! this program reads several input netcdf files, presumably containing "compressed
! by gathering" data, and combines them into a single output file
#define __NF_ASRT__(ierr) call nfu_check_err(ierr,__FILE__,__LINE__)
program combine_res

  use nfu_mod
  use nfu_compress_mod
  implicit none
  include 'netcdf.inc'

  integer, parameter :: PATH_MAX = 1024 ! max len of the file name; 
  integer, parameter :: HEADERPAD = 16384 ! Use mpp_io large headers; 

  character(PATH_MAX), allocatable :: files(:) ! names of all files on the command line
  character(PATH_MAX)              :: outfile  ! name of the output file
  integer :: nfiles    ! number of files on command line
  integer :: debug = 0 ! debug output verbosity level
  integer, allocatable :: input(:)             ! netcdf IDs of input files
  integer :: i,ncid,dimid,varid,dimlen,vsize,ndims,nvars,ngatts
  integer :: dimlens(NF_MAX_DIMS)
  logical :: has_records
  integer :: in_format ! format of input files
  integer :: cmode     ! mode for output file creation
  character(NF_MAX_NAME) :: dimname,varname,attname
  real(kind=8), allocatable :: buffer(:)
  logical, allocatable :: mask(:)

  ! get command line options and list of files
  call parse_command_line() ! modigies global data!

  call assert(nfiles>0,'at least one input file must be specified')
  if(debug>0) then
     do i = 1,nfiles
        write(*,'("input file",i3,":",a)')i, '"'//trim(files(i))//'"'
     enddo
     write(*,'("output file:",a)')'"'//trim(outfile)//'"'
  endif

  ! open all input files and determine the creation mode of output file:
  ! if any of the input files is 64-bit then the output is 64-bit as well,
  ! otherwise it's 32-bit
  allocate(input(nfiles))
  do i = 1,nfiles
     __NF_ASRT__(nf_open(files(i),NF_NOWRITE,input(i)))
     __NF_ASRT__(nf_inq_format(input(i),in_format))
  enddo

  if (in_format==NF_FORMAT_NETCDF4) then
     cmode = NF_NETCDF4
  elseif (in_format==NF_FORMAT_NETCDF4_CLASSIC) then
     cmode=IOR(NF_NETCDF4,NF_CLASSIC_MODEL)
  elseif (in_format==NF_FORMAT_64BIT) then
     cmode=IOR(NF_CLOBBER,NF_64BIT_OFFSET)
     if(debug>0)write(*,'("output file is 64-bit netcdf")')
  elseif (in_format==NF_FORMAT_CLASSIC) then
     cmode=IOR(NF_CLOBBER,NF_CLASSIC_MODEL)
     if(debug>0)write(*,'("output file is 32-bit netcdf")')
  else
     call assert(.false.,'Unknown netCDF format')
  endif

  ! create output file

  ! mpp_io supports environment variables to set these. For Riga, we'll simply use the defaults`

  __NF_ASRT__(nf__create(outfile,cmode,0,65536,ncid))

  ! Create netcdf structure in the output NetCDF file, using last input file
  ! as a template.

  ! clone all dimensions; for compressed dimensions calculate the length
  __NF_ASRT__(nf_inq_ndims(input(nfiles),ndims))
  do dimid = 1,ndims
     __NF_ASRT__(nfu_inq_dim(input(nfiles),dimid,dimname=dimname,dimlen=dimlen,is_unlim=has_records))
     if(nfu_inq_att(input(nfiles),dimname,'compress')==NF_NOERR) then
        __NF_ASRT__(nfu_inq_compressed_var(input(nfiles),dimname,varsize=vsize))
        allocate(buffer(vsize),mask(vsize))
        mask(:) = .false.
        do i=1,nfiles
           __NF_ASRT__(nfu_get_compressed_var_r8n(input(i),dimname,buffer,mask))
        enddo
        dimlen = max(count(mask),1)
        ! can't have 0-length dimension, since it is (mis-)understood by netcdf as 
        ! a record one.
        deallocate(buffer,mask)
     endif
     if(debug>0)&
          write(*,*)'defining dimension "'//trim(dimname)//'" with length',dimlen
     if(has_records)then
        dimlen = NF_UNLIMITED
     endif
     __NF_ASRT__(nf_def_dim(ncid,dimname,dimlen,i)) ! i is just a space for id

  enddo

  ! clone all variable definitions
  __NF_ASRT__(nf_inq_nvars(input(nfiles),nvars))
  do i = 1,nvars
     __NF_ASRT__(nfu_clone_var(input(nfiles),i,ncid))
     ! NOTE: since cloning of variable definition relies on dimension names,
     ! each variable tile and compressed dimensions automaticaly get the right
     ! size, as defined while creating dimensions in the output file
  enddo

  ! clone all global attributes
  __NF_ASRT__(nf_inq_natts(input(nfiles),ngatts))
  do i = 1,ngatts
     __NF_ASRT__(nf_inq_attname(input(nfiles),NF_GLOBAL,i,attname))
     __NF_ASRT__(nf_copy_att(input(nfiles),NF_GLOBAL,attname,ncid,NF_GLOBAL))
  enddo

  ! ---- end of definition stage
  __NF_ASRT__(nf__enddef(ncid,HEADERPAD,4,0,4))

  ! grow unlimited dimension, if necessary
  do varid = 1,nvars
     __NF_ASRT__(nfu_inq_var(input(nfiles),varid,dimlens=dimlens,has_records=has_records))
     if(has_records)then
        __NF_ASRT__(nf_put_var1_int(ncid,varid,dimlens,0))
        exit ! loop
     endif
  enddo


  ! gather and copy data
  do varid = 1,nvars
     __NF_ASRT__(nfu_inq_compressed_var(ncid,varid,name=varname,varsize=vsize))
     if(debug>0) &
          write(*,*)'processing var "'//trim(varname)//'"'
     allocate(buffer(vsize),mask(vsize))
     mask(:) = .false.
     do i=1,nfiles
        __NF_ASRT__(nfu_get_compressed_var_r8n(input(i),varname,buffer,mask))
     enddo
     if (count(mask)>0) then
        __NF_ASRT__(nfu_put_var_r8(ncid,varname,pack(buffer,mask)))
     endif
     deallocate(buffer,mask)
  enddo
     
  __NF_ASRT__(nf_close(ncid))

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ---- parses command line arguments, getting options and gathering list of
! file names
! NOTE: updates global variables.
subroutine parse_command_line()
  character(PATH_MAX) :: arg, param

  integer :: nargs     ! number of command-line arguments
  logical :: do_interpret_arguments
  integer :: i, iostat

  integer, external :: iargc

  nargs = iargc()
  if(nargs==0) then
     call usage()
     call exit(1)
  endif
  
  allocate(files(nargs))  ! allocate storage for all file names
  do_interpret_arguments = .true.
  i=1        ! counter of all command-line arguments
  nfiles = 0 ! counter of input files
  do while (i<=nargs)
     call getarg(i,arg)
     if(debug>1) write(*,*)'argument ',i, trim(arg)
     if(arg(1:1)=='-'.and.do_interpret_arguments) then
        select case(trim(arg))
        case('--')
           do_interpret_arguments = .false.

        case('-D','--debug-level')
           call assert(i<nargs,trim(arg)//' flag must be followed by integer verbosity level')
           call getarg(i+1,param)
           read(param,*,iostat=iostat) debug
           call assert(iostat==0,trim(arg)//' flag must be followed by integer verbosity level')
           i=i+1

        case ('-h','-?','--help')
           call usage()
           call exit(1)

        case default
           call usage()
           call assert(.false.,'argument "'//trim(arg)//'" is illegal')
        end select
     else
        ! argument is either input or output file name, add it to the list
        nfiles = nfiles+1
        files(nfiles) = arg
     endif
     i = i+1
  enddo
  if (nfiles>0) then
     outfile = files(nfiles)
     nfiles  = nfiles-1
  endif
  if(debug>0) &
       write(*,*) nfiles, ' input files'
end subroutine


! ---- prints usage information
subroutine usage()
  character(len=PATH_MAX) :: name
  call getarg(0,name)
  write(*,'(a)')'Combines several compressed-by-gathering netcdf files into one.'
  write(*,'(a)')'Normally used to combine lm3 restarts generated by each processor.'
  write(*,'(a)')
  write(*,'(a)')'Usage:'
  write(*,'(a)')'  '//trim(name)//' [-D debug-level] in.nc [...] out.nc'
  write(*,'(a)')
  write(*,'(a)')'-D debug-level   Specifies level of debug output verbosity'
  write(*,'(a)')'in.nc            Input file name(s)'
  write(*,'(a)')'out.nc           Output file name'
  write(*,'(a)')
  write(*,'(a)')'WARNING: output file is overwritten.'
  
end subroutine


! ===========================================================================
! ---- prints error message an exits if condition is not satisfied
subroutine assert(cond,message)
  logical     , intent(in) :: cond    ! condition to check
  character(*), intent(in) :: message ! error message to print if condition is not satisfied
  
  if(.not.cond) then
     write(*,*) 'ERROR :: ',trim(message)
     call exit(1)
  endif
end subroutine

end program combine_res


#define __NF_TRY__(err_code,iret,LABEL) iret=err_code;\
call cdfe(iret,"",__LINE__,verb);\
if(iret/=NF_NOERR)goto LABEL

module nfu_mod

implicit none
private

! ==== public interface ======================================================
public :: nfu_def_var, nfu_def_dim
public :: nfu_inq_var, nfu_inq_dim, nfu_inq_att
public :: nfu_get_var_r8, nfu_get_var_r4, nfu_get_var_int
public :: nfu_put_var_r8, nfu_put_var_r4, nfu_put_var_int
public :: nfu_get_rec_r8, nfu_get_rec_r4
public :: nfu_put_rec_r8, nfu_put_rec_r4
public :: nfu_get_att, nfu_put_att, nfu_append_att, nfu_copy_att
public :: nfu_clone_dim, nfu_clone_var
public :: nfu_copy_var_data
public :: nfu_check_err
public :: nfu_get_valid_range, is_valid, validtype

! ---- error codes
public :: nfu_ediffdimsize,nfu_elimunlim

public :: cdfe
! ==== end of public interface ===============================================

! ==== module constants ======================================================
integer, parameter :: nfu_ediffdimsize = -1001
integer, parameter :: nfu_elimunlim    = -1002

type validtype
   logical :: hasmax = .false.
   logical :: hasmin = .false.
!   real(kind=8) :: max=HUGE(max),min=-HUGE(min)
   real(kind=8) :: max=0,min=0
end type

! ==== interfaces for overloaded functions ===================================
interface nfu_def_var
   module procedure nfu_def_var_0
   module procedure nfu_def_var_1
end interface

interface nfu_inq_var
   module procedure inq_var_i
   module procedure inq_var_n
end interface

interface nfu_inq_dim
   module procedure inq_dim_i
   module procedure inq_dim_n
end interface

interface nfu_inq_att
   module procedure inq_att_i_n
   module procedure inq_att_n_n
   module procedure inq_att_i_i
   module procedure inq_att_n_i
end interface

interface nfu_get_rec_r8
   module procedure get_r8_rec
   module procedure get_r8_n_rec
end interface

interface nfu_get_rec_r4
   module procedure get_r4_rec
   module procedure get_r4_n_rec
end interface

interface nfu_put_rec_r8
   module procedure put_r8_rec
   module procedure put_r8_n_rec_1d
   module procedure put_r8_n_rec_2d
end interface

interface nfu_put_rec_r4
   module procedure put_r4_rec
   module procedure put_r4_n_rec
end interface

interface nfu_get_att
   module procedure get_att_text
   module procedure get_att_int
   module procedure get_att_r4
   module procedure get_att_r8
   module procedure get_att_int_1
   module procedure get_att_r4_1
   module procedure get_att_r8_1
end interface

interface nfu_put_att
   module procedure put_att_text
   module procedure put_att_int
   module procedure put_att_r8
   module procedure put_att_r4
   module procedure put_att_int_1
   module procedure put_att_r8_1
   module procedure put_att_r4_1
end interface

interface nfu_append_att
   module procedure append_att_text_i
   module procedure append_att_text_n
end interface

interface nfu_clone_dim
  module procedure clone_dim_n
  module procedure clone_dim_i
end interface

interface nfu_clone_var
   module procedure clone_var_n
   module procedure clone_var_i
end interface

interface nfu_copy_var_data
   module procedure copy_var_data_i
   module procedure copy_var_data_n
end interface

! ==== module data ==========================================================
integer :: verb = 0 ! verbosity level

#include <netcdf.inc>

contains

! ============================================================================
function inq_dim_n(ncid,name,dimlen,is_unlim,dimid) result (iret)
  integer, intent(in) :: ncid
  character(*), intent(in) :: name
  integer, optional, intent(out) :: dimid
  logical, optional, intent(out) :: is_unlim
  integer, optional, intent(out) :: dimlen
  integer :: iret

  integer :: dimid_
  __NF_TRY__(nf_inq_dimid(ncid,name,dimid_),iret,7)
  if(present(dimid)) dimid = dimid_
  __NF_TRY__(inq_dim_i(ncid,dimid_,dimlen,is_unlim),iret,7)
7 return
end function


! ============================================================================
function inq_dim_i(ncid,dimid,dimlen,is_unlim,dimname) result (iret)
  integer, intent(in) :: ncid
  integer, intent(in) :: dimid
  character(*), optional, intent(out) :: dimname
  logical     , optional, intent(out) :: is_unlim
  integer     , optional, intent(out) :: dimlen
  integer :: iret
  
  integer :: unlimdimid

  if(present(dimname)) then
     __NF_TRY__(nf_inq_dimname(ncid,dimid,dimname),iret,7)
  end if
  if(present(is_unlim)) then
     __NF_TRY__(nf_inq_unlimdim(ncid,unlimdimid),iret,7)
     is_unlim = (dimid==unlimdimid)
  end if
  if(present(dimlen))then
     __NF_TRY__(nf_inq_dimlen(ncid,dimid,dimlen),iret,7)
  end if

7 return
end function

! ============================================================================
function inq_var_n(ncid, name, id, xtype, ndims, dimids, dimlens, natts, &
     is_dim, has_records, varsize, recsize, nrec) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*),intent(in) :: name
  integer, intent(out), optional :: id
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records

  integer :: vid
  character(len=NF_MAX_NAME) :: vname

  __NF_TRY__(nf_inq_varid(ncid,name,vid),iret,7)
  if(present(id)) id = vid
  iret = inq_var_i(ncid,vid,vname,xtype,ndims,dimids,dimlens,natts,&
       is_dim,has_records,varsize,recsize,nrec)

7 return  
end function

! ============================================================================
function inq_var_i(ncid, vid, name, xtype, ndims, dimids, dimlens,natts, &
     is_dim, has_records, varsize, recsize, nrec) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: vid
  character(*),intent(out), optional :: name
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records

  integer :: vxtype, vndims, vdimids(NF_MAX_VAR_DIMS), vnatts
  integer :: vsize, vrecsize
  integer :: unlimdim, did, dlen, i
  character(len=NF_MAX_NAME) :: vname

  __NF_TRY__(nf_inq_var(ncid,vid,vname,vxtype,vndims,vdimids,vnatts),iret,7)
  if (present(name)) name = vname
  if (present(xtype)) xtype = vxtype
  if (present(ndims)) ndims = vndims
  if (present(dimids)) dimids(1:min(vndims,size(dimids))) = &
       vdimids(1:min(vndims,size(dimids)))
  if (present(natts)) natts = vnatts
  if (present(is_dim)) then
     is_dim = (nf_inq_dimid(ncid,vname,did)==NF_NOERR)
  endif
  __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
  if (present(has_records)) then
     has_records = ANY(vdimids(1:vndims)==unlimdim)
  endif
  if (present(varsize).or.present(recsize).or.present(dimlens)) then
     vsize = 1; vrecsize=1
     do i = 1,vndims
        __NF_TRY__(nf_inq_dimlen(ncid,vdimids(i),dlen),iret,7)
        vsize = vsize*dlen
        if(vdimids(i)/=unlimdim) vrecsize=vrecsize*dlen
        if(present(dimlens)) dimlens(i)=dlen
     enddo
     if(present(varsize)) varsize=vsize
     if(present(recsize)) recsize=vrecsize 
  endif
  if(present(nrec)) then
     nrec=1
     if(unlimdim/=-1.and.ANY(vdimids(1:vndims)==unlimdim)) then
        __NF_TRY__(nf_inq_dimlen(ncid,unlimdim,nrec),iret,7)
     endif
  endif

7 return  
end function

! ============================================================================
function inq_att_i_n(ncid, varid, att, xtype, len, attid) result (iret)
  integer     , intent(in) :: ncid
  integer     , intent(in) :: varid
  character(*), intent(in) :: att
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  integer, optional, intent(out) :: attid
  integer :: iret

  integer :: xtype_, len_

  __NF_TRY__(nf_inq_att(ncid,varid,att,xtype_,len_),iret,7)
  if(present(attid)) then
     __NF_TRY__(nf_inq_attid(ncid,varid,att,attid),iret,7)
  endif
  if(present(xtype)) xtype = xtype_
  if(present(len))   len   = len_
  
7 return
end function

! ============================================================================
function inq_att_n_n(ncid, var, att, xtype, len, attid) result (iret)
  integer     , intent(in) :: ncid
  character(*), intent(in) :: var
  character(*), intent(in) :: att
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  integer, optional, intent(out) :: attid
  integer :: iret


  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7)
  __NF_TRY__(inq_att_i_n(ncid,varid,att,xtype,len,attid),iret,7)
7 return
end function

! ============================================================================
function inq_att_i_i(ncid, varid, attid, xtype, len, name) result (iret)
  integer, intent(in) :: ncid
  integer, intent(in) :: varid
  integer, intent(in) :: attid
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  character(*), optional, intent(out) :: name
  integer :: iret

  character(NF_MAX_NAME) :: name_

  __NF_TRY__(nf_inq_attname(ncid,varid,attid,name_),iret,7)
  __NF_TRY__(inq_att_i_n(ncid,varid,name_,xtype,len),iret,7)
  if(present(name)) name = name_
7 return
end function


! ============================================================================
function inq_att_n_i(ncid, var, attid, xtype, len, name) result (iret)
  integer, intent(in) :: ncid
  character(*) :: var
  integer, intent(in) :: attid
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  character(*), optional, intent(out) :: name
  integer :: iret

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7)
  __NF_TRY__(inq_att_i_i(ncid,varid,attid,xtype,len,name),iret,7)
7 return
end function

! ============================================================================
function nfu_def_dim(ncid,name,size,xtype,long_name,units,bounds,dimid,varid) &
     result (iret)
  integer         , intent(in) :: ncid  ! id of NetCDF file to create 
  character(len=*), intent(in) :: name  ! name of the dimension
  integer         , intent(in) :: size  ! size of the dimension
  integer,optional, intent(in) :: xtype ! external type of the associated variable
  character(len=*), intent(in), optional :: &
       long_name, &
       units,     &
       bounds
  integer,optional,intent(out) :: dimid,varid
  integer :: iret

  integer :: did,vid

  iret=nf_redef(ncid)

  did = -1; vid = -1
  __NF_TRY__(nf_def_dim(ncid,name,size,did),iret,7)
  if(present(xtype)) then
     __NF_TRY__(nf_def_var(ncid,name,xtype,1,(/did/),vid),iret,7)
     if (present(long_name)) then
        __NF_TRY__(nf_put_att_text(ncid,vid,'long_name',len(long_name),long_name),iret,7)
     endif
     if (present(units)) then
        __NF_TRY__(nf_put_att_text(ncid,vid,'units',len(units),units),iret,7)
     endif
     if (present(bounds)) then
        __NF_TRY__(nf_put_att_text(ncid,vid,'bounds',len(bounds),bounds),iret,7)
     endif
  endif
  if(present(dimid))dimid=did
  if(present(varid))varid=vid
7 return
end function

! ============================================================================
! define variable using its symbolic name and symbolic names of the dimensions
function nfu_def_var_0(ncid,name,xtype,dimc,dimv) result(iret)
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: name       ! name of the variable
  integer         , intent(in) :: xtype      ! external type of the var
  integer         , intent(in) :: dimc       ! number of dimensions
  character(len=*), intent(in) :: dimv(dimc) ! vector of dimension names 
  integer :: iret

  integer :: i,dimids(NF_MAX_VAR_DIMS),varid
  do i=1,dimc
     __NF_TRY__(nf_inq_dimid(ncid,dimv(i),dimids(i)),iret,7)
  enddo
  __NF_TRY__(nf_def_var(ncid,name,xtype,dimc,dimids,varid),iret,7)

7 return
end function


function nfu_def_var_1(ncid,name,xtype,dimv) result(iret)
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: name       ! name of the variable
  integer         , intent(in) :: xtype      ! external type of the var
  character(len=*), intent(in) :: dimv(:)    ! vector of dimension names 
  integer :: iret

  integer :: i,dimids(NF_MAX_VAR_DIMS),varid
  integer :: dimc

  dimc = size(dimv)
  do i=1,dimc
     __NF_TRY__(nf_inq_dimid(ncid,dimv(i),dimids(i)),iret,7)
  enddo
  __NF_TRY__(nf_def_var(ncid,name,xtype,dimc,dimids,varid),iret,7)

7 return
end function

! ===========================================================================
function clone_var_n(incid,vname,oncid,name) result(iret)
  integer :: iret ! return value
  integer      , intent(in) :: incid, oncid
  character*(*), intent(in) :: vname
  character*(*), intent(in), optional :: name

  integer :: varid
  __NF_TRY__(nf_inq_varid(incid,vname,varid),iret,7)
  __NF_TRY__(clone_var_i(incid,varid,oncid,name),iret,7)
7 return
end function

! ===========================================================================
function clone_var_i(incid,ivarid,oncid,name) result(iret)
  integer :: iret ! return value
  integer      , intent(in) :: incid, oncid
  integer      , intent(in) :: ivarid
  character*(*), intent(in), optional :: name
  
  character(len=NF_MAX_NAME) :: vname ! name of the var to be cloned
  character(len=NF_MAX_NAME) :: oname ! resulting name of the variable
  character(len=NF_MAX_NAME) :: str   ! name of the dimension or attribute 
  integer :: xtype,ndims,dimids(NF_MAX_VAR_DIMS),natts,i,ovarid

  ! get the info about variable to be cloned
  __NF_TRY__(nf_inq_var(incid,ivarid,vname,xtype,ndims,dimids,natts),iret,7)
  ! get respective dimension ids in output file
  do i = 1,ndims
     __NF_TRY__(nf_inq_dimname(incid,dimids(i),str),iret,7)
     __NF_TRY__(nf_inq_dimid(oncid,str,dimids(i)),iret,7)
  enddo
  ! set the name of the variable clone
  if (present(name)) then
     oname = name
  else
     oname = vname
  end if
  ! define clone variable
  __NF_TRY__(nf_def_var(oncid,oname,xtype,ndims,dimids,ovarid),iret,7)
  ! copy all attributes
  do i = 1,natts
     __NF_TRY__(nf_inq_attname(incid,ivarid,i,str),iret,7)
     __NF_TRY__(nf_copy_att(incid,ivarid,str,oncid,ovarid),iret,7)
  enddo
7 return
  ! note taht according to docs allocatable array is supposed to
  ! be deallocated on exit from procedure
end function

! ===========================================================================
function clone_dim_n(incid,iname,oncid,name) result(iret)
  integer :: iret
  integer, intent(in) :: incid,oncid
  character*(*),intent(in) :: iname
  character*(*),intent(in),optional :: name
  
  integer :: dimid
  
  __NF_TRY__(nf_inq_dimid(incid,iname,dimid),iret,7)
  iret = clone_dim_i(incid,dimid,oncid,name)
7 return  
end function

! ===========================================================================
function clone_dim_i(incid,dimid,oncid,name) result(iret)
  integer :: iret
  integer, intent(in) :: incid,dimid,oncid
  character*(*), intent(in), optional :: name ! name of the dimension copy
    
  character(len=NF_MAX_NAME) :: dname
  integer :: unlimid,len,newdimid,newlen,newunlimid

  ! get the name of the dimension
  __NF_TRY__(nf_inq_dim(incid,dimid,dname,len),iret,7)
  ! get the id of unlimited dimension in source file
  __NF_TRY__(nf_inq_unlimdim(incid,unlimid),iret,7)
  if(dimid==unlimid) len = NF_UNLIMITED
  ! if new output name is specified, replace the name of the input dim
  ! with it
  if(present(name)) dname = name
  ! check if the desired dimension already exists in the dest file
  if(nf_inq_dimid(oncid,dname,newdimid)==NF_NOERR) then
    ! dimension already exists in output file, make sure the size is the same,
    ! or both are unlimited dimensions
    __NF_TRY__(nf_inq_dimlen(oncid,newdimid,newlen),iret,7)
    __NF_TRY__(nf_inq_unlimdim(oncid,newunlimid),iret,7)
    
    if((dimid==unlimid).neqv.(newdimid==newunlimid)) then
       __NF_TRY__(nfu_elimunlim,iret,7)
    endif
    if(dimid/=unlimid.and.len/=newlen) then
       __NF_TRY__(nfu_ediffdimsize,iret,7)
    endif
  else
    __NF_TRY__(nf_def_dim(oncid,dname,len,newdimid),iret,7)
  endif
7 return  
end function

! ============================================================================
function copy_var_data_n(ncid,varname,ncid1,name) result (iret)
  integer :: iret
  integer     , intent(in) :: ncid
  character(*), intent(in) :: varname
  integer     , intent(in) :: ncid1
  character(*), intent(in), optional :: name ! name of output variable
  
  integer :: varid, varid1
  
  __NF_TRY__(nf_inq_varid(ncid,varname,varid),iret,7)
  if(present(name)) then
     __NF_TRY__(nf_inq_varid(ncid1,name,varid1),iret,7)
  else
     __NF_TRY__(nf_inq_varid(ncid1,varname,varid1),iret,7)
  endif
  
  __NF_TRY__(copy_var_data_i(ncid,varid,ncid1,varid1),iret,7)
7 continue
end function
  

function copy_var_data_i(ncid,varid,ncid1,varid1) result (iret)
  integer :: iret
  integer, intent(in) :: ncid,  varid
  integer, intent(in) :: ncid1, varid1
  
  integer :: recsize,nrec,rec
  real(kind=8), allocatable :: buffer(:)
  
  __NF_TRY__(nfu_inq_var(ncid,varid,recsize=recsize,nrec=nrec),iret,7)
  allocate(buffer(recsize))
  
  if(ncid/=ncid1.or.varid/=varid1) then
    do rec=1,nrec
       __NF_TRY__(nfu_get_rec_r8(ncid,varid,rec,buffer),iret,7)
       __NF_TRY__(nfu_put_rec_r8(ncid1,varid1,rec,buffer),iret,7)
    enddo
  endif

7 continue
  if (allocated(buffer)) deallocate(buffer)
end function


! ============================================================================
function nfu_get_var_r8(ncid,name,var) result(iret)
  integer :: iret ! return value
  integer, intent(in) :: ncid   ! id of netcdf data set
  character(*), intent(in)  :: name
  real(kind=8), intent(out) :: var(*) ! storage for the variable     [out]

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nf_get_var_double(ncid,varid,var)
7 return
end function

function nfu_get_var_r4(ncid,name,var) result(iret)
  integer :: iret ! return value
  integer, intent(in) :: ncid   ! id of netcdf data set
  character(*), intent(in)  :: name
  real(kind=4), intent(out) :: var(*) ! storage for the variable     [out]

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nf_get_var_real(ncid,varid,var)
7 return
end function

function nfu_get_var_int(ncid,name,var) result(iret)
  integer :: iret ! return value
  integer, intent(in) :: ncid   ! id of netcdf data set
  character(*), intent(in)  :: name
  integer     , intent(out) :: var(*) ! storage for the variable

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nf_get_var_int(ncid,varid,var)
7 return
end function

! ============================================================================
function nfu_put_var_r8(ncid,name,var) result(iret)
  integer :: iret ! return value
  integer     , intent(in) :: ncid   ! id of netcdf data set
  character(*), intent(in) :: name
  real(kind=8), intent(in) :: var(*)

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nf_put_var_double(ncid,varid,var)
7 return
end function

function nfu_put_var_r4(ncid,name,var) result(iret)
  integer :: iret ! return value
  integer     , intent(in) :: ncid   ! id of netcdf data set
  character(*), intent(in) :: name
  real(kind=4), intent(in) :: var(*)

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nf_put_var_real(ncid,varid,var)
7 return
end function

function nfu_put_var_int(ncid,name,var) result(iret)
  integer :: iret ! return value
  integer     , intent(in) :: ncid   ! id of netcdf data set
  character(*), intent(in) :: name
  integer,      intent(in) :: var(*)

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nf_put_var_int(ncid,varid,var)
7 return
end function

! ============================================================================
function get_r8_n_rec(ncid, name, rec, data) result(iret)
  integer :: iret
  integer     , intent(in)  :: ncid
  character(*), intent(in)  :: name
  integer     , intent(in)  :: rec
  real(kind=8), intent(out) :: data(*)

  integer :: varid
  
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret=get_r8_rec(ncid, varid, rec, data)
7 return

end function

! ============================================================================
function get_r4_n_rec(ncid, name, rec, data) result(iret)
  integer :: iret
  integer     , intent(in)  :: ncid
  character(*), intent(in)  :: name
  integer     , intent(in)  :: rec
  real(kind=4), intent(out) :: data(*)

  integer :: varid
  
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret=get_r4_rec(ncid, varid, rec, data)
7 return

end function

! ============================================================================
! reads double precision record from the file
function get_r8_rec(ncid, varid, rec, var) result(iret)
  integer :: iret
  integer, intent(in) :: ncid   ! id of netcdf data set
  integer, intent(in) :: varid  ! id of the variable           [in]
  integer, intent(in) :: rec       ! number of the record to get  [in]
  real(kind=8), intent(out) :: var(*) ! storage for the variable     [out]
 
  integer :: dimids(NF_MAX_VAR_DIMS), ndims, unlimdim
  integer :: start(NF_MAX_VAR_DIMS)
  integer :: count(NF_MAX_VAR_DIMS)
  integer :: i
      
  __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
  __NF_TRY__(nf_inq_varndims(ncid,varid,ndims),iret,7)
  __NF_TRY__(nf_inq_vardimid(ncid,varid,dimids),iret,7)

  do i = 1, ndims
     if (dimids(i).eq.unlimdim) then
        start(i) = rec
        count(i) = 1
     else
        start(i) = 1
        __NF_TRY__(nf_inq_dimlen(ncid,dimids(i),count(i)),iret,7)
     endif
     ! write(*,*) i, dimids(i), start(i), count(i)
  enddo
  iret = nf_get_vara_double(ncid,varid,start,count,var)

7 return
end function

! ============================================================================
! reads single precision record from the file
function get_r4_rec(ncid, varid, rec, var) result(iret)
  integer :: iret
  integer, intent(in) :: ncid   ! id of netcdf data set
  integer, intent(in) :: varid  ! id of the variable           [in]
  integer, intent(in) :: rec       ! number of the record to get  [in]
  real(kind=4), intent(out) :: var(*) ! storage for the variable     [out]
 
  integer :: dimids(NF_MAX_VAR_DIMS), ndims, unlimdim
  integer :: start(NF_MAX_VAR_DIMS)
  integer :: count(NF_MAX_VAR_DIMS)
  integer :: i
      
  __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
  __NF_TRY__(nf_inq_varndims(ncid,varid,ndims),iret,7)
  __NF_TRY__(nf_inq_vardimid(ncid,varid,dimids),iret,7)

  do i = 1, ndims
     if (dimids(i).eq.unlimdim) then
        start(i) = rec
        count(i) = 1
     else
        start(i) = 1
        __NF_TRY__(nf_inq_dimlen(ncid,dimids(i),count(i)),iret,7)
     endif
     ! write(*,*) i, dimids(i), start(i), count(i)
  enddo
  iret = nf_get_vara_real(ncid,varid,start,count,var)

7 return
end function

! ============================================================================
function put_r4_n_rec(ncid, name, rec, data) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*), intent(in) :: name
  integer, intent(in) :: rec
  real(4), intent(in) :: data(*)

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = put_r4_rec(ncid, varid, rec, data)
7 return

end function

! ============================================================================
function put_r8_n_rec_2d(ncid, name, rec, data) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*), intent(in) :: name
  integer, intent(in) :: rec
  real(8), intent(in) :: data(:,:)

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = put_r8_rec(ncid, varid, rec, data)
7 return

end function

! ============================================================================
function put_r8_n_rec_1d(ncid, name, rec, data) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*), intent(in) :: name
  integer, intent(in) :: rec
  real(8), intent(in) :: data(*)

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = put_r8_rec(ncid, varid, rec, data)
7 return

end function

! ============================================================================
function put_r4_rec(ncid, varid, rec, data) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: varid
  integer, intent(in) :: rec
  real(4), intent(in) :: data(*)
      
  integer :: dimids(NF_MAX_VAR_DIMS), ndims
  integer :: unlimdim, unlimlen
  integer :: start(NF_MAX_VAR_DIMS)
  integer :: count(NF_MAX_VAR_DIMS)
  integer :: i
      
  __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
  __NF_TRY__(nf_inq_varndims(ncid,varid,ndims),iret,7)
  __NF_TRY__(nf_inq_vardimid(ncid,varid,dimids),iret,7)

  do i = 1, ndims
     if (dimids(i).eq.unlimdim) then
        start(i) = rec
        count(i) = 1
     else
        start(i) = 1
        __NF_TRY__(nf_inq_dimlen(ncid,dimids(i),count(i)),iret,7)
     endif
!          write(*,*) i, dimids(i), start(i), count(i)
  enddo
  iret = nf_put_vara_real(ncid,varid,start,count,data)
7 return
end function

! ============================================================================
function put_r8_rec(ncid, varid, rec, data) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: varid
  integer, intent(in) :: rec
  real(8), intent(in) :: data(*)
      
  integer :: dimids(NF_MAX_VAR_DIMS), ndims
  integer :: unlimdim, unlimlen
  integer :: start(NF_MAX_VAR_DIMS)
  integer :: count(NF_MAX_VAR_DIMS)
  integer :: i
      
  __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
  __NF_TRY__(nf_inq_varndims(ncid,varid,ndims),iret,7)
  __NF_TRY__(nf_inq_vardimid(ncid,varid,dimids),iret,7)

  do i = 1, ndims
     if (dimids(i).eq.unlimdim) then
        start(i) = rec
        count(i) = 1
     else
        start(i) = 1
        __NF_TRY__(nf_inq_dimlen(ncid,dimids(i),count(i)),iret,7)
     endif
!          write(*,*) i, dimids(i), start(i), count(i)
  enddo
  iret = nf_put_vara_double(ncid,varid,start,count,data)
7 return
end function

! ===========================================================================
function get_att_text(ncid, name, att, text) result(iret)
  integer :: iret
  integer, intent(in) :: ncid         ! id of the NetCDF file [in]
  character(*),intent(in) :: name   ! name of the variable  [in]
  character(*),intent(in) :: att    ! attribute name [in]
  character(*),intent(out) :: text   ! attribute value [out]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_get_att_text(ncid, varid, att, text)
      
7 return
end function

! ===========================================================================
function get_att_int(ncid, name, att, d) result(iret)
  integer :: iret
  integer, intent(in)      :: ncid   ! id of the NetCDF file [in]
  character(*),intent(in)  :: name   ! name of the variable  [in]
  character(*),intent(in)  :: att    ! attribute name [in]
  integer     ,intent(inout) :: d(:)   ! attribute value [out]
  
  integer :: varid,len
  integer, allocatable :: data(:)

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  __NF_TRY__(nf_inq_attlen(ncid,varid,att,len),iret,7)
  allocate(data(len))
  iret = nf_get_att_int(ncid, varid, att, data)
  d(1:min(size(d),size(data))) = data(1:min(size(d),size(data)))
7 return
end function

! ===========================================================================
function get_att_r4(ncid, name, att, d) result(iret)
  integer :: iret
  integer, intent(in)      :: ncid   ! id of the NetCDF file [in]
  character(*),intent(in)  :: name   ! name of the variable  [in]
  character(*),intent(in)  :: att    ! attribute name [in]
  real(4)     ,intent(inout) :: d(:)   ! attribute value [out]
  
  integer :: varid,len
  real(4), allocatable :: data(:)

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  __NF_TRY__(nf_inq_attlen(ncid,varid,att,len),iret,7)
  allocate(data(len))
  iret = nf_get_att_real(ncid, varid, att, data)
  d(1:min(size(d),size(data))) = data(1:min(size(d),size(data)))
7 return

end function

! ===========================================================================
function get_att_r8(ncid, name, att, d) result(iret)
  integer :: iret
  integer, intent(in)      :: ncid   ! id of the NetCDF file [in]
  character(*),intent(in)  :: name   ! name of the variable  [in]
  character(*),intent(in)  :: att    ! attribute name [in]
  real(8)     ,intent(out) :: d(:)   ! attribute value [out]
  
  integer :: varid,len
  real(8), allocatable :: data(:)

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  __NF_TRY__(nf_inq_attlen(ncid,varid,att,len),iret,7)
  allocate(data(len))
  iret = nf_get_att_double(ncid, varid, att, data)
  d(1:min(size(d),size(data))) = data(1:min(size(d),size(data)))
7 return
end function


! ===========================================================================
function get_att_int_1(ncid, name, att, d) result(iret)
  integer :: iret
  integer, intent(in)      :: ncid   ! id of the NetCDF file [in]
  character(*),intent(in)  :: name   ! name of the variable  [in]
  character(*),intent(in)  :: att    ! attribute name [in]
  integer     ,intent(out) :: d    ! attribute value [out]

  integer :: data(1)

  iret = get_att_int(ncid,name,att,data)
  d = data(1)
end function

! ===========================================================================
function get_att_r4_1(ncid, name, att, d) result(iret)
  integer :: iret
  integer, intent(in)      :: ncid   ! id of the NetCDF file [in]
  character(*),intent(in)  :: name   ! name of the variable  [in]
  character(*),intent(in)  :: att    ! attribute name [in]
  real(4)     ,intent(out) :: d    ! attribute value [out]

  real(4) :: data(1)

  iret = get_att_r4(ncid,name,att,data)
  d = data(1)
end function

! ===========================================================================
function get_att_r8_1(ncid, name, att, d) result(iret)
  integer :: iret
  integer, intent(in)      :: ncid   ! id of the NetCDF file [in]
  character(*),intent(in)  :: name   ! name of the variable  [in]
  character(*),intent(in)  :: att    ! attribute name [in]
  real(8)     ,intent(out) :: d    ! attribute value [out]

  real(8) :: data(1)

  iret = get_att_r8(ncid,name,att,data)
  d = data(1)
end function


! ===========================================================================
function put_att_text(ncid,name,att,text) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  character*(*),intent(in) :: text   ! text to put in attribute [in]
  
  integer :: varid
      
  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_text(ncid,varid,att,len(text),text)
      
7 return
end function

! ===========================================================================
function put_att_int(ncid,name,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  integer      ,intent(in) :: data(:)! text to put in attribute [in]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_int(ncid,varid,att,NF_INT,size(data),data)
      
7 return
end function

! ===========================================================================
function put_att_r4(ncid,name,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  real(4)      ,intent(in) :: data(:)! text to put in attribute [in]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_real(ncid,varid,att,NF_REAL,size(data),data)
      
7 return
end function

! ===========================================================================
function put_att_r8(ncid,name,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  real(8)      ,intent(in) :: data(:)! text to put in attribute [in]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_double(ncid,varid,att,NF_DOUBLE,size(data),data)
      
7 return
end function

! ===========================================================================
function put_att_int_1(ncid,name,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  integer      ,intent(in) :: data   ! text to put in attribute [in]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_int(ncid,varid,att,NF_INT,1,data)
      
7 return
end function

! ===========================================================================
function put_att_r4_1(ncid,name,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  real(4)      ,intent(in) :: data   ! text to put in attribute [in]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_real(ncid,varid,att,NF_REAL,1,data)
      
7 return
end function

! ===========================================================================
function put_att_r8_1(ncid,name,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: name   ! name of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  real(8)      ,intent(in) :: data   ! text to put in attribute [in]
  
  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  iret = nf_put_att_double(ncid,varid,att,NF_DOUBLE,1,data)
      
7 return
end function

! ===========================================================================
! appends specified text to the attribute
function append_att_text_n(ncid,var,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  character*(*),intent(in) :: var  ! id of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  character*(*),intent(in) :: data   ! text to put in attribute [in]

  integer :: varid

  __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7)
  __NF_TRY__(append_att_text_i(ncid,varid,att,data),iret,7)
7 return
end function

! ===========================================================================
! appends specified text to the attribute
function append_att_text_i(ncid,varid,att,data) result(iret)
  integer :: iret
  integer      ,intent(in) :: ncid   ! id of the NetCDF file [in]
  integer      ,intent(in) :: varid  ! id of the variable  [in]
  character*(*),intent(in) :: att    ! attribute name [in]
  character*(*),intent(in) :: data   ! text to put in attribute [in]

  integer :: i,n ! original length of the attribute
  character, allocatable :: text(:)

  if(nf_inq_attlen(ncid,varid,att,n)/=NF_NOERR)then
     iret = nf_put_att_text(ncid,varid,att,len(data),data)
  else
     allocate(text(n+len(data)))
     __NF_TRY__(nf_get_att_text(ncid,varid,att,text),iret,7)
     ! erase trailing zero byte (normally appended by C), if necessary
     if(text(n)==char(0))n = n-1
     ! is there a better way to copy string to array of chars?
     ! or, even better, to allocate a string of specified length?
     do i = 1,len(data)
        text(n+i) = data(i:i)
     enddo
     __NF_TRY__(nf_put_att_text(ncid,varid,att,n+len(data),text),iret,7)
  endif
7 return
end function

! ===========================================================================
function nfu_copy_att(incid,iname,oncid,oname,aname) result(iret)
  integer :: iret
  integer, intent(in) :: incid,oncid
  character*(*), intent(in) :: iname,oname
  character*(*), intent(in) :: aname

  integer :: ivarid,ovarid

  __NF_TRY__(nf_inq_varid(incid,iname,ivarid),iret,7)
  __NF_TRY__(nf_inq_varid(oncid,oname,ovarid),iret,7)
  __NF_TRY__(nf_copy_att(incid,ivarid,aname,oncid,ovarid),iret,7)
7 return
end function

! ========================================================================
! based on presence/absence of attributes, defines valid range or missing 
! value. For details, see section 8.1 of NetCDF User Guide
function nfu_get_valid_range(ncid, name, v) result (iret)
  integer     , intent(in) :: ncid
  character(*), intent(in) :: name
  type(validtype),intent(out) :: v ! validator

  integer :: iret
  
  integer :: var_T, valid_T, scale_T, T ! types variable and of attributes
  real(kind=8) :: scale, offset, fill, r(2)
  
  ! find the type of the variable
  __NF_TRY__(nfu_inq_var(ncid,name,xtype=var_T),iret,7)

  ! find the widest type of scale and offset; note that the code
  ! uses assumption that NetCDF types are arranged in th order of rank,
  ! that is NF_BYTE < NF_CHAR < NF_SHORT < NF_INT < NF_FLOAT < NF_DOUBLE
  scale = 1; offset = 0;
  scale_T = 0
  if(nfu_inq_att(ncid,name,'scale_factor',xtype=T)==NF_NOERR) then
     __NF_TRY__(nfu_get_att(ncid,name,'scale_factor',scale),iret,7)
     scale_T = T
  endif
  if(nfu_inq_att(ncid,name,'add_offset',xtype=T)==NF_NOERR) then
     __NF_TRY__(nfu_get_att(ncid,name,'add_offset',offset),iret,7)
     scale_T = max(scale_T,T)
  endif
     
  ! examine possible range attributes
  valid_T = 0; v%hasmax=.false. ; v%hasmin=.false.
  if (nfu_inq_att(ncid,name,'valid_range',xtype=T)==NF_NOERR) then
     __NF_TRY__(nfu_get_att(ncid,name,'valid_range',r),iret,7)
     v%min = r(1)      ; v%max = r(2)
     v%hasmax = .true. ; v%hasmin = .true.
     valid_T = max(valid_T,T)
  else if(nfu_inq_att(ncid,name,'valid_max',xtype=T)==NF_NOERR) then
     __NF_TRY__(nfu_get_att(ncid,name,'valid_max',v%max),iret,7)
     v%hasmax = .true.
     valid_T = max(valid_T,T)
  else if(nfu_inq_att(ncid,name,'valid_min',xtype=T)==NF_NOERR) then
     __NF_TRY__(nfu_get_att(ncid,name,'valid_min',v%min),iret,7)
     v%hasmin = .true.
     valid_T = max(valid_T,T)
  else if(nfu_inq_att(ncid,name,'missing_value',xtype=T)==NF_NOERR) then
     ! here we always scale, since missing_value is supposed to be in 
     ! external representation
     __NF_TRY__(nfu_get_att(ncid,name,'missing_value',v%min),iret,7)
     v%min = v%min*scale + offset
  else
     ! as a last resort, define range based on _FillValue
     ! get fill value and its type: from var, from file, or default
     if(nfu_get_att(ncid,name,'_FillValue',fill)/=NF_NOERR) then
        if(nf_get_att_double(ncid,NF_GLOBAL,'_FillValue',fill)/=NF_NOERR) then
           select case(var_T)
           case(NF_CHAR)
              fill = NF_FILL_CHAR
           case(NF_BYTE)
              fill = NF_FILL_BYTE
           case(NF_SHORT)
              fill = NF_FILL_SHORT
           case(NF_INT)
              fill = NF_FILL_INT
           case(NF_REAL)
              fill = NF_FILL_REAL
           case(NF_DOUBLE)
              fill = NF_FILL_DOUBLE
           end select
        endif
     endif
     if(fill>0) then
        ! if _FillValue is positive, then it defines valid maximum
        v%hasmax = .true.
        v%max = fill
        select case(T)
        case (NF_BYTE,NF_CHAR,NF_SHORT,NF_INT)
           v%max = v%max-1
        case (NF_FLOAT)
           v%max = nearest(nearest(real(v%max,4),-1.0),-1.0)
        case (NF_DOUBLE)
           v%max = nearest(nearest(real(v%max,8),-1.0),-1.0)
        end select
     else
        ! if _FillValue is negative or zero, then it defines valid minimum
        v%hasmin = .true.
        v%min = fill
        select case(T)
        case (NF_BYTE,NF_CHAR,NF_SHORT,NF_INT)
           v%min = v%min+1
        case (NF_FLOAT)
           v%min = nearest(nearest(real(v%min,4),+1.0),+1.0)
        case (NF_DOUBLE)
           v%min = nearest(nearest(real(v%min,8),+1.0),+1.0)
        end select
     endif
     ! NOTE: if we go through _FillValue branch, valid_T is 0, so values
     ! are always scaled, as it should be because _FillValue is in external 
     ! representation
  endif
  ! If valid_range is the same type as scale_factor (actually the wider of
  ! scale_factor and add_offset) and this is wider than the external data, then it
  ! will be interpreted as being in the units of the internal (unpacked) data.
  ! Otherwise it is in the units of the external (packed) data.
  if(.not.((valid_T == scale_T).and.(scale_T>var_T))) then
     v%min = v%min*scale + offset
     v%max = v%max*scale + offset
  endif
7 return
end function
   
! ========================================================================
elemental function is_valid(x, v) result (lret)
  real           , intent(in) :: x ! real value to be examined
  type(validtype), intent(in) :: v ! validator
  logical :: lret

!  if (x is NaN) then
!     lret = .false.
!  else 
  if (v%hasmin.or.v%hasmax) then
     lret = ((.not.v%hasmin).or.v%min<=x).and.((.not.v%hasmax).or.x<=v%max)
  else
     lret = x/=v%min
  endif
end function

! ===========================================================================
subroutine nfu_check_err(code,file,line)
  integer      , intent(in) :: code  ! error code
  character*(*), intent(in) :: file  ! file name
  integer      , intent(in) :: line  ! line number

  call cdfe(code,file,line,1)
  if(code/=NF_NOERR) call exit(code)

end subroutine

! ===========================================================================
! prints error message
subroutine cdfe(code, file, line, verb)
  integer      , intent(in) :: code  ! error code
  character*(*), intent(in) :: file  ! file name
  integer      , intent(in) :: line  ! line number
  integer      , intent(in) :: verb  ! verbosity level
      
  if((code/=NF_NOERR).and.(verb>0)) then
     write(*,'("File ",a," ; Line ",i5," # ",a)') file,line,nfu_strerror(code)
!     write(*,*) file,line,nfu_strerror(code)
  endif
end subroutine

function nfu_strerror(code) result(string)
  character*(80) :: string
  integer, intent(in) :: code

  select case (code)
  case (nfu_ediffdimsize)
     string = 'dimension already exists and has different size'
  case (nfu_elimunlim)
     string = 'dimension already exists and has different UNLIMITED status'
  case default
     string = nf_strerror(code)
  end select
end function


end module nfu_mod


#define __NF_TRY__(err_code,iret,LABEL) iret=err_code;\
call cdfe(iret,"",__LINE__,verb);\
if(iret/=NF_NOERR)goto LABEL


module nfu_compress_mod

  use nfu_mod

implicit none
private

! ==== public interface ======================================================
public :: nfu_inq_compressed_dim, nfu_inq_compressed_var
public :: nfu_get_compressed_var_r8, nfu_get_compressed_var_int
public :: nfu_put_compressed_var_r8, nfu_put_compressed_var_int
public :: nfu_get_compressed_var_r8n
public :: nfu_put_compressed_var_r8n
! ==== end of public interface ===============================================

! ==== interfaces for overloaded functions ===================================
interface nfu_inq_compressed_dim
   module procedure inq_compressed_dim_n
   module procedure inq_compressed_dim_i
end interface

interface nfu_inq_compressed_var
   module procedure inq_compressed_var_n
   module procedure inq_compressed_var_i
end interface

#include <netcdf.inc>

integer :: verb = 0


! ---- private type - used to hold dimension/packing information during unpacking
! (see get_compressed_var_i_r8)
type diminfo_type
   integer, pointer :: idx(:)=>NULL() ! packing information
   integer :: length  ! size of the dimension in the input array
   integer :: stride  ! stide along the dimension in the output array
end type 


contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ===========================================================================
function nfu_get_compressed_var_r8n(ncid,name,data,mask) result (iret)
  integer          , intent(in)    :: ncid
  character(*)     , intent(in)  :: name
  real(kind=8)     , intent(inout) :: data(*)
  logical, optional, intent(inout) :: mask(*)
  integer :: iret

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nfu_get_compressed_var_r8(ncid,varid,data,mask)
7 return

end function 

! ===========================================================================
function nfu_get_compressed_var_r8(ncid,varid,data,mask) result (iret)
  integer          , intent(in)    :: ncid,varid
  real(kind=8)     , intent(inout) :: data(*)
  logical, optional, intent(inout) :: mask(*)
  integer :: iret

  integer :: ndims,dimids(NF_MAX_VAR_DIMS),dimlen
  integer :: varsize ! total size of the compressed variable
  integer :: cndims, cdimids(NF_MAX_VAR_DIMS),cdimlens(NF_MAX_VAR_DIMS)
  character(NF_MAX_NAME) :: dimname

  real(kind=8),allocatable :: buffer(:)
  integer :: i, ii, n, length, idx(NF_MAX_VAR_DIMS)
  integer :: stride

  type(diminfo_type) :: diminfo(NF_MAX_VAR_DIMS)

  ! get the information for the compressed variable
  iret = nfu_inq_var(ncid,varid,ndims=ndims,dimids=dimids,varsize=varsize)
  __NF_TRY__(iret,iret,7)

  ! get the compressed dimensions
  stride = 1
  do i = 1,ndims
     __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=diminfo(i)%length,dimname=dimname),iret,7)
     if(nfu_inq_compressed_dim(ncid,dimids(i),&
          ndims=cndims,dimids=cdimids,dimlens=cdimlens)==NF_NOERR) then
        ! it is a compressed dimension; get dimension itself and calculate
        ! get the dimension (that is, compression information)
        __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=dimlen,dimname=dimname),iret,7)
        allocate(diminfo(i)%idx(0:dimlen-1))
        __NF_TRY__(nfu_get_var_int(ncid,dimname,diminfo(i)%idx),iret,7)
        ! calculate corresponding stride in output (unpacked) array
        length = 1
        do n = 1,cndims
           length = length*cdimlens(n)
        enddo
     else
        length = diminfo(i)%length
     endif
     diminfo(i)%stride = stride
     stride = stride*length
  enddo
        
  ! get the entire variable
  allocate(buffer(varsize))
  __NF_TRY__(nf_get_var_double(ncid,varid,buffer),iret,7)

  ! move the data to the output buffer
  idx(:) = 0
  do i = 1,size(buffer)
     ! calculate destination index
     ii = 1
     do n = 1,ndims
        if(associated(diminfo(n)%idx)) then
           if(diminfo(n)%idx(idx(n)) >= 0)then
              ii = ii+diminfo(n)%idx(idx(n))*diminfo(n)%stride
           else
              ii = -1 ! set a value flagging an invalid point
              exit    ! from index loop
           endif
        else
           ii = ii+idx(n)*diminfo(n)%stride
        endif
     enddo

     ! if index is negative, skip an invalid point
     if (ii > 0) then
        data(ii) = buffer(i)
        if(present(mask))mask(ii) = .true.
     endif

     ! increment indices
     do n = 1,ndims
        idx(n) = idx(n)+1
        if(idx(n)<diminfo(n)%length)exit
        idx(n) = 0
     enddo
  enddo

7 continue
  ! clean up memory
  do i = 1,size(diminfo)
     if(associated(diminfo(i)%idx)) &
          deallocate(diminfo(i)%idx)
  enddo
  if (allocated(buffer)) &
       deallocate(buffer)
end function


! ===========================================================================
function nfu_get_compressed_var_int(ncid,varid,data,mask) result (iret)
  integer :: iret
  integer, intent(in)    :: ncid,varid
  integer, intent(inout) :: data(*)
  logical, optional, intent(inout) :: mask(*)

  integer :: ndims,dimids(NF_MAX_VAR_DIMS),dimlen
  integer :: varsize ! total size of the compressed variable
  integer :: cndims, cdimids(NF_MAX_VAR_DIMS),cdimlens(NF_MAX_VAR_DIMS)
  character(NF_MAX_NAME) :: dimname

  integer, allocatable :: buffer(:)
  integer :: i, ii, n, length, idx(NF_MAX_VAR_DIMS)
  integer :: stride

  type(diminfo_type) :: diminfo(NF_MAX_VAR_DIMS)

  ! get the information for the compressed variable
  iret = nfu_inq_var(ncid,varid,ndims=ndims,dimids=dimids,varsize=varsize)
  __NF_TRY__(iret,iret,7)

  ! get the compressed dimensions
  stride = 1
  do i = 1,ndims
     __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=diminfo(i)%length,dimname=dimname),iret,7)
     if(nfu_inq_compressed_dim(ncid,dimids(i),&
          ndims=cndims,dimids=cdimids,dimlens=cdimlens)==NF_NOERR) then
        ! it is a compressed dimension; get dimension itself and calculate
        ! get the dimension (that is, compression information)
        __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=dimlen,dimname=dimname),iret,7)
        allocate(diminfo(i)%idx(0:dimlen-1))
        __NF_TRY__(nfu_get_var_int(ncid,dimname,diminfo(i)%idx),iret,7)
        ! calculate corresponding stride in output (unpacked) array
        length = 1
        do n = 1,cndims
           length = length*cdimlens(n)
        enddo
     else
        length = diminfo(i)%length
     endif
     diminfo(i)%stride = stride
     stride = stride*length
  enddo
        
  ! get the entire variable
  allocate(buffer(varsize))
  __NF_TRY__(nf_get_var_int(ncid,varid,buffer),iret,7)

  ! move the data to the output buffer
  idx(:) = 0
  do i = 1,size(buffer)
     ! calculate destination index
     ii = 1
     do n = 1,ndims
        if(associated(diminfo(n)%idx)) then
           if(diminfo(n)%idx(idx(n)) >= 0)then
              ii = ii+diminfo(n)%idx(idx(n))*diminfo(n)%stride
           else
              ii = -1 ! set a value flagging an invalid point
              exit    ! from index loop
           endif
        else
           ii = ii+idx(n)*diminfo(n)%stride
        endif
     enddo

     ! if index is negative, skip an invalid point
     if (ii > 0) then
        data(ii) = buffer(i)
        if(present(mask)) mask(ii) = .true.
     endif

     ! increment indices
     do n = 1,ndims
        idx(n) = idx(n)+1
        if(idx(n)<diminfo(n)%length)exit
        idx(n) = 0
     enddo
  enddo

7 continue
  ! clean up memory
  do i = 1,size(diminfo)
     if(associated(diminfo(i)%idx)) &
          deallocate(diminfo(i)%idx)
  enddo
  if (allocated(buffer)) &
       deallocate(buffer)
end function

! ===========================================================================
function nfu_put_compressed_var_r8n(ncid,name,src) result (iret)
  integer     , intent(in)    :: ncid
  character(*), intent(in)    :: name
  real(kind=8), intent(inout) :: src(*)      ! data to write
  integer :: iret

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7)
  iret = nfu_put_compressed_var_r8(ncid,varid,src)
7 return
end function

! ===========================================================================
function nfu_put_compressed_var_r8(ncid,varid,src) result (iret)
  integer     , intent(in)    :: ncid,varid
  real(kind=8), intent(inout) :: src(*)      ! data to write
  integer :: iret

  integer :: ndims,dimids(NF_MAX_VAR_DIMS),dimlen
  integer :: varsize ! total size of the compressed variable
  integer :: cndims, cdimids(NF_MAX_VAR_DIMS),cdimlens(NF_MAX_VAR_DIMS)
  character(NF_MAX_NAME) :: dimname

  real(kind=8),allocatable :: buffer(:)
  integer :: i, ii, n, length, idx(NF_MAX_VAR_DIMS)
  integer :: stride

  type(diminfo_type) :: diminfo(NF_MAX_VAR_DIMS)

  ! get the information for the compressed variable
  iret = nfu_inq_var(ncid,varid,ndims=ndims,dimids=dimids,varsize=varsize)
  __NF_TRY__(iret,iret,7)

  ! get the compressed dimensions
  stride = 1
  do i = 1,ndims
     __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=diminfo(i)%length,dimname=dimname),iret,7)
     if(nfu_inq_compressed_dim(ncid,dimids(i),&
          ndims=cndims,dimids=cdimids,dimlens=cdimlens)==NF_NOERR) then
        ! it is a compressed dimension; get dimension itself and calculate
        ! get the dimension (that is, compression information)
        __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=dimlen,dimname=dimname),iret,7)
        allocate(diminfo(i)%idx(0:dimlen-1))
        __NF_TRY__(nfu_get_var_int(ncid,dimname,diminfo(i)%idx),iret,7)
        ! calculate corresponding stride in output (unpacked) array
        length = 1
        do n = 1,cndims
           length = length*cdimlens(n)
        enddo
     else
        length = diminfo(i)%length
     endif
     diminfo(i)%stride = stride
     stride = stride*length
  enddo
        
  ! get the entire variable
  allocate(buffer(varsize))

  ! move the data to the output buffer
  idx(:) = 0
  do i = 1,size(buffer)
     ! calculate destination index
     ii = 1
     do n = 1,ndims
        if(associated(diminfo(n)%idx)) then
           ii = ii+diminfo(n)%idx(idx(n))*diminfo(n)%stride
        else
           ii = ii+idx(n)*diminfo(n)%stride
        endif
     enddo

     buffer(i) = src(ii)

     ! increment indices
     do n = 1,ndims
        idx(n) = idx(n)+1
        if(idx(n)<diminfo(n)%length)exit
        idx(n) = 0
     enddo
  enddo

  __NF_TRY__(nf_put_var_double(ncid,varid,buffer),iret,7)

7 continue
  ! clean up memory
  do i = 1,size(diminfo)
     if(associated(diminfo(i)%idx)) &
          deallocate(diminfo(i)%idx)
  enddo
  if (allocated(buffer)) &
       deallocate(buffer)
end function


! ===========================================================================
function nfu_put_compressed_var_int(ncid,varid,src) result (iret)
  integer :: iret
  integer, intent(in)    :: ncid,varid
  integer, intent(inout) :: src(*)

  integer :: ndims,dimids(NF_MAX_VAR_DIMS),dimlen
  integer :: varsize ! total size of the compressed variable
  integer :: cndims, cdimids(NF_MAX_VAR_DIMS),cdimlens(NF_MAX_VAR_DIMS)
  character(NF_MAX_NAME) :: dimname

  integer, allocatable :: buffer(:)
  integer :: i, ii, n, length, idx(NF_MAX_VAR_DIMS)
  integer :: stride

  type(diminfo_type) :: diminfo(NF_MAX_VAR_DIMS)

  ! get the information for the compressed variable
  iret = nfu_inq_var(ncid,varid,ndims=ndims,dimids=dimids,varsize=varsize)
  __NF_TRY__(iret,iret,7)

  ! get the compressed dimensions
  stride = 1
  do i = 1,ndims
     __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=diminfo(i)%length,dimname=dimname),iret,7)
     if(nfu_inq_compressed_dim(ncid,dimids(i),&
          ndims=cndims,dimids=cdimids,dimlens=cdimlens)==NF_NOERR) then
        ! it is a compressed dimension; get dimension itself and calculate
        ! get the dimension (that is, compression information)
        __NF_TRY__(nfu_inq_dim(ncid,dimids(i),dimlen=dimlen,dimname=dimname),iret,7)
        allocate(diminfo(i)%idx(0:dimlen-1))
        __NF_TRY__(nfu_get_var_int(ncid,dimname,diminfo(i)%idx),iret,7)
        ! calculate corresponding stride in output (unpacked) array
        length = 1
        do n = 1,cndims
           length = length*cdimlens(n)
        enddo
     else
        length = diminfo(i)%length
     endif
     diminfo(i)%stride = stride
     stride = stride*length
  enddo
        
  ! get the entire variable
  allocate(buffer(varsize))

  ! move the data to the output buffer
  idx(:) = 0
  do i = 1,size(buffer)
     ! increment indices
     do n = 1,ndims
        idx(n) = idx(n)+1
        if(idx(n)<diminfo(n)%length)exit
        idx(n) = 0
     enddo
     ! calculate destination index
     ii = 1
     do n = 1,ndims
        if(associated(diminfo(n)%idx)) then
           ii = ii+diminfo(n)%idx(idx(n))*diminfo(n)%stride
        else
           ii = ii+idx(n)*diminfo(n)%stride
        endif
     enddo
     buffer(i) = src(ii)
  enddo

  __NF_TRY__(nf_get_var_int(ncid,varid,buffer),iret,7)

7 continue
  ! clean up memory
  do i = 1,size(diminfo)
     if(associated(diminfo(i)%idx)) &
          deallocate(diminfo(i)%idx)
  enddo
  if (allocated(buffer)) &
       deallocate(buffer)
end function

! ===========================================================================
function inq_compressed_dim_n(ncid,name,ndims,dimids,dimlens,dimid) result (iret)
  integer :: iret
  integer, intent(in)  :: ncid
  character(*), intent(in) :: name
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: dimid

  integer :: dimid_

  __NF_TRY__(nf_inq_dimid(ncid,name,dimid_),iret,7)
  if(present(dimid)) dimid = dimid_
  __NF_TRY__(inq_compressed_dim_i(ncid,dimid_,ndims,dimids,dimlens),iret,7)
7 return
end function

! ===========================================================================
function inq_compressed_dim_i(ncid,dimid,ndims,dimids,dimlens,dimname) result (iret)
  integer :: iret
  integer, intent(in)  :: ncid,dimid
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  character(*), intent(out), optional :: dimname
  
  character(NF_MAX_NAME) :: dimname_
  character(1024) :: compress ! should be more than enough to hold the compression info
  integer :: dimlen,dimid0,n,is,ie

  __NF_TRY__(nfu_inq_dim(ncid,dimid,dimname=dimname_),iret,7)
  if(present(dimname)) dimname = dimname_
  compress = ''
  __NF_TRY__(nfu_get_att(ncid,dimname_,'compress',compress),iret,7)

  ! parse the description of the compression
  ie = len_trim(compress)
  n = 0
  do while(ie>0)
     is = scan(compress(1:ie),' ',back=.true.)
     if(is==ie) then
        ! skip space runs
     else
        n = n+1
        iret = nfu_inq_dim(ncid,compress(is+1:ie),dimlen=dimlen,dimid=dimid0)
        __NF_TRY__(iret,iret,7)
        if(present(dimids)) dimids(n) = dimid0
        if(present(dimlens)) dimlens(n) = dimlen
     endif
     ie = is-1
  enddo
  if(present(ndims))ndims=n
7 return
end function

! ============================================================================
function inq_compressed_var_n(ncid, name, id, xtype, ndims, dimids, dimlens, natts, &
     is_dim, has_records, varsize, recsize, nrec, is_compressed) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*),intent(in) :: name
  integer, intent(out), optional :: id
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records
  logical, intent(out), optional :: is_compressed ! true if variable is actually compressed

  integer :: vid
  character(len=NF_MAX_NAME) :: vname

  __NF_TRY__(nf_inq_varid(ncid,name,vid),iret,7)
  if(present(id)) id = vid
  iret = inq_compressed_var_i(ncid,vid,vname,xtype,ndims,dimids,dimlens,natts,&
       is_dim,has_records,varsize,recsize,nrec,is_compressed)

7 return  
end function

! ============================================================================
function inq_compressed_var_i(ncid, vid, name, xtype, ndims, dimids, dimlens, &
     natts, is_dim, has_records, varsize, recsize, nrec, is_compressed) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: vid
  character(*),intent(out), optional :: name
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records
  logical, intent(out), optional :: is_compressed ! true if variable is actually compressed

  
  integer :: nd0, dids0(NF_MAX_VAR_DIMS),dlens0(NF_MAX_VAR_DIMS)
  integer :: nd1, dids1(NF_MAX_VAR_DIMS),dlens1(NF_MAX_VAR_DIMS)
  integer :: i,n,unlimdim,vsize,rsize

  iret =  nfu_inq_var(ncid, vid, name, xtype, nd0, dids0, dlens0, natts, &
     is_dim, has_records, varsize, recsize, nrec)

  nd1=1
  if(present(is_compressed)) is_compressed=.false.
  do i = 1, nd0
     if(nfu_inq_compressed_dim(ncid,dids0(i),&
          ndims=n,dimids=dids1(nd1:),dimlens=dlens1(nd1:))==NF_NOERR) then
        nd1 = nd1+n
        if(present(is_compressed)) is_compressed=.true.
     else
        dlens1(nd1) = dlens0(i)
        dids1(nd1) = dids0(i)
        nd1 = nd1+1
     endif
  enddo
  nd1 = nd1-1

  if(present(ndims))   ndims   = nd1
  if(present(dimids))  dimids  = dids1
  if(present(dimlens)) dimlens = dlens1
  if(present(varsize).or.present(recsize)) then
     __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
     vsize = 1; rsize=1
     do i = 1,nd1
        vsize = vsize*dlens1(i)
        if(dids1(i)/=unlimdim)&
             rsize = rsize*dlens1(i)
     enddo
     if (present(varsize)) varsize=vsize
     if (present(recsize)) recsize=rsize
  end if
7 return

end function

end module nfu_compress_mod


module atmos_model_mod
!<CONTACT EMAIL="Bruce.Wyman@noaa.gov"> Bruce Wyman  
!</CONTACT>
! <REVIEWER EMAIL="Zhi.Liang@noaa.gov">
!  Zhi Liang
! </REVIEWER>
!-----------------------------------------------------------------------
!<OVERVIEW>
!  Driver for the atmospheric model, contains routines to advance the
!  atmospheric model state by one time step.
!</OVERVIEW>

!<DESCRIPTION>
!     This version of atmos_model_mod has been designed around the implicit
!     version diffusion scheme of the GCM. It requires two routines to advance
!     the atmospheric model one time step into the future. These two routines
!     correspond to the down and up sweeps of the standard tridiagonal solver.
!     Most atmospheric processes (dynamics,radiation,etc.) are performed
!     in the down routine. The up routine finishes the vertical diffusion
!     and computes moisture related terms (convection,large-scale condensation,
!     and precipitation).

!     The boundary variables needed by other component models for coupling
!     are contained in a derived data type. A variable of this derived type
!     is returned when initializing the atmospheric model. It is used by other
!     routines in this module and by coupling routines. The contents of
!     this derived type should only be modified by the atmospheric model.

!</DESCRIPTION>

use mpp_mod,            only: mpp_pe, mpp_root_pe, mpp_clock_id, mpp_clock_begin
use mpp_mod,            only: mpp_clock_end, CLOCK_COMPONENT, mpp_error, mpp_chksum
use mpp_domains_mod,    only: domain2d
use fms_mod,            only: file_exist, error_mesg, field_size, FATAL, NOTE
use fms_mod,            only: close_file,  write_version_number, stdlog, stdout
use fms_mod,            only: read_data, write_data, clock_flag_default
use fms_mod,            only: open_restart_file, open_namelist_file, check_nml_error
use fms_io_mod,         only: get_restart_io_mode
use fms_io_mod,         only: restart_file_type, register_restart_field
use fms_io_mod,         only: save_restart, restore_state, get_mosaic_tile_file
use time_manager_mod,   only: time_type, operator(+), get_time
use field_manager_mod,  only: MODEL_ATMOS
use tracer_manager_mod, only: get_number_tracers, get_tracer_index, NO_TRACER
use diag_integral_mod,  only: diag_integral_init, diag_integral_end
use diag_integral_mod,  only: diag_integral_output
use atmosphere_mod,     only: atmosphere_cell_area
use xgrid_mod,          only: grid_box_type
use atmosphere_mod,     only: atmosphere_up, atmosphere_down, atmosphere_init
use atmosphere_mod,     only: atmosphere_end, get_bottom_mass, get_bottom_wind
use atmosphere_mod,     only: atmosphere_resolution, atmosphere_domain
use atmosphere_mod,     only: atmosphere_boundary, get_atmosphere_axes
use atmosphere_mod,     only: get_stock_pe
use atmosphere_mod,     only: surf_diff_type
use atmosphere_mod,     only: atmosphere_restart
use coupler_types_mod,  only: coupler_2d_bc_type


!-----------------------------------------------------------------------

implicit none
private

public update_atmos_model_down, update_atmos_model_up
public atmos_model_init, atmos_model_end, atmos_data_type
public land_ice_atmos_boundary_type, land_atmos_boundary_type
public atm_stock_pe
public ice_atmos_boundary_type
public atmos_model_restart
public atmos_data_type_chksum
public lnd_ice_atm_bnd_type_chksum, lnd_atm_bnd_type_chksum
public ice_atm_bnd_type_chksum
!-----------------------------------------------------------------------

!<PUBLICTYPE >
 type atmos_data_type
     type (domain2d)               :: domain             ! domain decomposition
     integer                       :: axes(4)            ! axis indices (returned by diag_manager) for the atmospheric grid 
                                                         ! (they correspond to the x, y, pfull, phalf axes)
     real, pointer, dimension(:,:) :: lon_bnd  => NULL() ! local longitude axis grid box corners in radians.
     real, pointer, dimension(:,:) :: lat_bnd  => NULL() ! local latitude axis grid box corners in radians.
     real, pointer, dimension(:,:) :: t_bot    => NULL() ! temperature at lowest model level
     real, pointer, dimension(:,:,:) :: tr_bot   => NULL() ! tracers at lowest model level
     real, pointer, dimension(:,:) :: z_bot    => NULL() ! height above the surface for the lowest model level
     real, pointer, dimension(:,:) :: p_bot    => NULL() ! pressure at lowest model level
     real, pointer, dimension(:,:) :: u_bot    => NULL() ! zonal wind component at lowest model level
     real, pointer, dimension(:,:) :: v_bot    => NULL() ! meridional wind component at lowest model level
     real, pointer, dimension(:,:) :: p_surf   => NULL() ! surface pressure 
     real, pointer, dimension(:,:) :: slp      => NULL() ! sea level pressure 
     real, pointer, dimension(:,:) :: gust     => NULL() ! gustiness factor
     real, pointer, dimension(:,:) :: coszen   => NULL() ! cosine of the zenith angle
     real, pointer, dimension(:,:) :: flux_sw  => NULL() ! net shortwave flux (W/m2) at the surface
     real, pointer, dimension(:,:) :: flux_sw_dir            =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_dif            =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_down_vis_dir   =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_down_vis_dif   =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_down_total_dir =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_down_total_dif =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_vis            =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_vis_dir        =>NULL()
     real, pointer, dimension(:,:) :: flux_sw_vis_dif        =>NULL()
     real, pointer, dimension(:,:) :: flux_lw  => NULL() ! net longwave flux (W/m2) at the surface
     real, pointer, dimension(:,:) :: lprec    => NULL() ! mass of liquid precipitation since last time step (Kg/m2)
     real, pointer, dimension(:,:) :: fprec    => NULL() ! ass of frozen precipitation since last time step (Kg/m2)
     logical, pointer, dimension(:,:) :: maskmap =>NULL()! A pointer to an array indicating which
                                                         ! logical processors are actually used for
                                                         ! the ocean code. The other logical
                                                         ! processors would be all land points and
                                                         ! are not assigned to actual processors.
                                                         ! This need not be assigned if all logical
                                                         ! processors are used. This variable is dummy and need 
                                                         ! not to be set, but it is needed to pass compilation.
     type (surf_diff_type)         :: Surf_diff          ! store data needed by the multi-step version of the diffusion algorithm
     type (time_type)              :: Time               ! current time
     type (time_type)              :: Time_step          ! atmospheric time step.
     type (time_type)              :: Time_init          ! reference time.
     integer, pointer              :: pelist(:) =>NULL() ! pelist where atmosphere is running.
     logical                       :: pe                 ! current pe.
     type(coupler_2d_bc_type)      :: fields             ! array of fields used for additional tracers
     type(grid_box_type)           :: grid               ! hold grid information needed for 2nd order conservative flux exchange 
                                                         ! to calculate gradient on cubic sphere grid.
 end type atmos_data_type
!</PUBLICTYPE >

!<PUBLICTYPE >
type land_ice_atmos_boundary_type
   ! variables of this type are declared by coupler_main, allocated by flux_exchange_init.
!quantities going from land+ice to atmos
   real, dimension(:,:),   pointer :: t              =>NULL() ! surface temperature for radiation calculations
   real, dimension(:,:),   pointer :: albedo         =>NULL() ! surface albedo for radiation calculations
   real, dimension(:,:),   pointer :: albedo_vis_dir =>NULL()
   real, dimension(:,:),   pointer :: albedo_nir_dir =>NULL()
   real, dimension(:,:),   pointer :: albedo_vis_dif =>NULL()
   real, dimension(:,:),   pointer :: albedo_nir_dif =>NULL()
   real, dimension(:,:),   pointer :: land_frac      =>NULL() ! fraction amount of land in a grid box 
   real, dimension(:,:),   pointer :: dt_t           =>NULL() ! temperature tendency at the lowest level
   real, dimension(:,:,:), pointer :: dt_tr          =>NULL() ! tracer tendency at the lowest level
   real, dimension(:,:),   pointer :: u_flux         =>NULL() ! zonal wind stress
   real, dimension(:,:),   pointer :: v_flux         =>NULL() ! meridional wind stress
   real, dimension(:,:),   pointer :: dtaudu         =>NULL() ! derivative of zonal wind stress w.r.t. the lowest zonal level wind speed
   real, dimension(:,:),   pointer :: dtaudv         =>NULL() ! derivative of meridional wind stress w.r.t. the lowest meridional level wind speed
   real, dimension(:,:),   pointer :: u_star         =>NULL() ! friction velocity
   real, dimension(:,:),   pointer :: b_star         =>NULL() ! bouyancy scale
   real, dimension(:,:),   pointer :: q_star         =>NULL() ! moisture scale
   real, dimension(:,:),   pointer :: rough_mom      =>NULL() ! surface roughness (used for momentum)
   real, dimension(:,:,:), pointer :: data           =>NULL() !collective field for "named" fields above
   integer                         :: xtype                   !REGRID, REDIST or DIRECT
end type land_ice_atmos_boundary_type
!</PUBLICTYPE >

!<PUBLICTYPE >
type :: land_atmos_boundary_type
   real, dimension(:,:), pointer :: data =>NULL() ! quantities going from land alone to atmos (none at present)
end type land_atmos_boundary_type
!</PUBLICTYPE >

!<PUBLICTYPE >
!quantities going from ice alone to atmos (none at present)
type :: ice_atmos_boundary_type
   real, dimension(:,:), pointer :: data =>NULL() ! quantities going from ice alone to atmos (none at present)
end type ice_atmos_boundary_type
!</PUBLICTYPE >

!Balaji
integer :: atmClock

!for restart
integer                 :: ipts, jpts, dto
type(restart_file_type), pointer, save :: Atm_restart => NULL()
type(restart_file_type), pointer, save :: Til_restart => NULL()
logical                                :: in_different_file = .false.

!-----------------------------------------------------------------------

character(len=128) :: version = '$Id: atmos_model.F90,v 18.0.2.2.2.1 2010/08/16 15:06:19 z1l Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

integer :: ivapor = NO_TRACER ! index of water vapor tracer

!-----------------------------------------------------------------------
character(len=80) :: restart_format = 'atmos_coupled_mod restart format 01'
!-----------------------------------------------------------------------
logical           :: do_netcdf_restart = .true.
logical           :: restart_tbot_qbot = .false.
namelist /atmos_model_nml/ do_netcdf_restart, restart_tbot_qbot  

contains

!#######################################################################
! <SUBROUTINE NAME="update_atmos_model_down">
!
! <OVERVIEW>
!   compute the atmospheric tendencies for dynamics, radiation, 
!   vertical diffusion of momentum, tracers, and heat/moisture.
! </OVERVIEW>
!
!<DESCRIPTION>
!   Called every time step as the atmospheric driver to compute the
!   atmospheric tendencies for dynamics, radiation, vertical diffusion of
!   momentum, tracers, and heat/moisture.  For heat/moisture only the
!   downward sweep of the tridiagonal elimination is performed, hence
!   the name "_down". 
!</DESCRIPTION>

!   <TEMPLATE>
!     call  update_atmos_model_down( Surface_boundary, Atmos )
!   </TEMPLATE>

! <IN NAME = "Surface_boundary" TYPE="type(land_ice_atmos_boundary_type)">
!   Derived-type variable that contains quantities going from land+ice to atmos.  
! </IN>

! <INOUT NAME="Atmos" TYPE="type(atmos_data_type)">
!   Derived-type variable that contains fields needed by the flux exchange module.
!   These fields describe the atmospheric grid and are needed to
!   compute/exchange fluxes with other component models.  All fields in this
!   variable type are allocated for the global grid (without halo regions).
! </INOUT>

subroutine update_atmos_model_down( Surface_boundary, Atmos )
!
!-----------------------------------------------------------------------
  type(land_ice_atmos_boundary_type), intent(inout) :: Surface_boundary
  type (atmos_data_type), intent(inout) :: Atmos
                                      
!-----------------------------------------------------------------------
  call mpp_clock_begin(atmClock)

    call atmosphere_down (Atmos%Time, Surface_boundary%land_frac,        &
                          Surface_boundary%t,  Surface_boundary%albedo,  &
                          Surface_boundary%albedo_vis_dir,   &
                          Surface_boundary%albedo_nir_dir,   &
                          Surface_boundary%albedo_vis_dif,   &
                          Surface_boundary%albedo_nir_dif,   &
                          Surface_boundary%rough_mom,   &
                          Surface_boundary%u_star,      &
                          Surface_boundary%b_star,      &
                          Surface_boundary%q_star, &
                          Surface_boundary%dtaudu,      &
                          Surface_boundary%dtaudv,      &
                          Surface_boundary%u_flux,      &
                          Surface_boundary%v_flux,      &
                          Atmos%gust,                   &
                          Atmos%coszen,                 &
                          Atmos%flux_sw,                &
                          Atmos%flux_sw_dir,            &
                          Atmos%flux_sw_dif,            &
                          Atmos%flux_sw_down_vis_dir,   &
                          Atmos%flux_sw_down_vis_dif,   &
                          Atmos%flux_sw_down_total_dir, &
                          Atmos%flux_sw_down_total_dif, &
                          Atmos%flux_sw_vis,            &
                          Atmos%flux_sw_vis_dir,        &
                          Atmos%flux_sw_vis_dif,        &
                          Atmos%flux_lw,                &
                          Atmos%Surf_diff               )

!-----------------------------------------------------------------------

  call mpp_clock_end(atmClock)
 end subroutine update_atmos_model_down
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="update_atmos_model_up">
!
!-----------------------------------------------------------------------
! <OVERVIEW>
!   upward vertical diffusion of heat/moisture and moisture processes
! </OVERVIEW>

!<DESCRIPTION>
!   Called every time step as the atmospheric driver to finish the upward
!   sweep of the tridiagonal elimination for heat/moisture and compute the
!   convective and large-scale tendencies.  The atmospheric variables are
!   advanced one time step and tendencies set back to zero. 
!</DESCRIPTION>

! <TEMPLATE>
!     call  update_atmos_model_up( Surface_boundary, Atmos )
! </TEMPLATE>

! <IN NAME = "Surface_boundary" TYPE="type(land_ice_atmos_boundary_type)">
!   Derived-type variable that contains quantities going from land+ice to atmos.  
! </IN>

! <INOUT NAME="Atmos" TYPE="type(atmos_data_type)">
!   Derived-type variable that contains fields needed by the flux exchange module.
!   These fields describe the atmospheric grid and are needed to
!   compute/exchange fluxes with other component models.  All fields in this
!   variable type are allocated for the global grid (without halo regions).
! </INOUT>

 subroutine update_atmos_model_up( Surface_boundary, Atmos )

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

type(land_ice_atmos_boundary_type), intent(in) :: Surface_boundary
type (atmos_data_type), intent(inout) :: Atmos
                                      
!-----------------------------------------------------------------------
  call mpp_clock_begin(atmClock)


    Atmos%Surf_diff%delta_t = Surface_boundary%dt_t
    Atmos%Surf_diff%delta_tr = Surface_boundary%dt_tr

    call atmosphere_up (Atmos%Time,  Surface_boundary%land_frac, Atmos%Surf_diff, &
                        Atmos%lprec, Atmos%fprec, Atmos%gust, &
                        Surface_boundary%u_star, Surface_boundary%b_star, Surface_boundary%q_star)

!   --- advance time ---

    Atmos % Time = Atmos % Time + Atmos % Time_step


    call get_bottom_mass (Atmos % t_bot,  Atmos % tr_bot, &
                          Atmos % p_bot,  Atmos % z_bot,  &
                          Atmos % p_surf, Atmos % slp     )

    call get_bottom_wind (Atmos % u_bot, Atmos % v_bot)


!------ global integrals ------

    call diag_integral_output (Atmos % Time)

!-----------------------------------------------------------------------
  call mpp_clock_end(atmClock)

end subroutine update_atmos_model_up
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="atmos_model_init">
!
! <OVERVIEW>
! Routine to initialize the atmospheric model
! </OVERVIEW>

! <DESCRIPTION>
!     This routine allocates storage and returns a variable of type
!     atmos_boundary_data_type, and also reads a namelist input and restart file. 
! </DESCRIPTION>

! <TEMPLATE>
!     call atmos_model_init (Atmos, Time_init, Time, Time_step)
! </TEMPLATE>

! <IN NAME="Time_init" TYPE="type(time_type)" >
!   The base (or initial) time of the experiment.
! </IN>

! <IN NAME="Time" TYPE="type(time_type)" >
!   The current time.
! </IN>

! <IN NAME="Time_step" TYPE="type(time_type)" >
!   The atmospheric model/physics time step.
! </IN>

! <INOUT NAME="Atmos" TYPE="type(atmos_data_type)">
!   Derived-type variable that contains fields needed by the flux exchange module.
! </INOUT>

subroutine atmos_model_init (Atmos, Time_init, Time, Time_step)


type (atmos_data_type), intent(inout) :: Atmos
type (time_type), intent(in) :: Time_init, Time, Time_step

  integer :: unit, ntrace, ntprog, ntdiag, ntfamily, i, j
  integer :: mlon, mlat, nlon, nlat, sec, day, dt
  character(len=80) :: control
  real, dimension(:,:), allocatable :: area
  integer :: ierr, io, logunit
  character(len=64) :: filename, filename2
  integer           :: id_restart
!-----------------------------------------------------------------------

!---- set the atmospheric model time ------

   Atmos % Time_init = Time_init
   Atmos % Time      = Time
   Atmos % Time_step = Time_step
   logunit = stdlog()

   if ( file_exist('input.nml')) then
      unit = open_namelist_file ( )
      ierr=1
      do while (ierr /= 0)
         read  (unit, nml=atmos_model_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'atmos_model_nml')
      enddo
 10     call close_file (unit)
   endif
   call get_restart_io_mode(do_netcdf_restart)

!-----------------------------------------------------------------------
! how many tracers have been registered?
!  (will print number below)
   call get_number_tracers ( MODEL_ATMOS, ntrace, ntprog, ntdiag, ntfamily )
   if ( ntfamily > 0 ) call error_mesg ('atmos_model', 'ntfamily > 0', FATAL)
   ivapor = get_tracer_index( MODEL_ATMOS, 'sphum' )
   if (ivapor==NO_TRACER) &
        ivapor = get_tracer_index( MODEL_ATMOS, 'mix_rat' )
   if (ivapor==NO_TRACER) &
        call error_mesg('atmos_model_init', 'Cannot find water vapor in ATM tracer table', FATAL)

!-----------------------------------------------------------------------
!  ----- initialize atmospheric model -----

    call atmosphere_init (Atmos%Time_init, Atmos%Time, Atmos%Time_step,&
                          Atmos%Surf_diff, Atmos%grid )
                           
!-----------------------------------------------------------------------
!---- allocate space ----

    call atmosphere_resolution (mlon, mlat, global=.true.)
    call atmosphere_resolution (nlon, nlat, global=.false.)
    call atmosphere_domain     (Atmos%domain)

    allocate ( Atmos %  lon_bnd (nlon+1,nlat+1), &
               Atmos %  lat_bnd (nlon+1,nlat+1), &
               Atmos % t_bot    (nlon,nlat), &
               Atmos % tr_bot    (nlon,nlat, ntprog), &
               Atmos % z_bot    (nlon,nlat), &
               Atmos % p_bot    (nlon,nlat), &
               Atmos % u_bot    (nlon,nlat), &
               Atmos % v_bot    (nlon,nlat), &
               Atmos % p_surf   (nlon,nlat), &
               Atmos % slp      (nlon,nlat), &
               Atmos % gust     (nlon,nlat), &
               Atmos % flux_sw  (nlon,nlat), &
               Atmos % flux_sw_dir (nlon,nlat), &
               Atmos % flux_sw_dif (nlon,nlat), &
               Atmos % flux_sw_down_vis_dir (nlon,nlat), &
               Atmos % flux_sw_down_vis_dif (nlon,nlat), &
               Atmos % flux_sw_down_total_dir (nlon,nlat), &
               Atmos % flux_sw_down_total_dif (nlon,nlat), &
               Atmos % flux_sw_vis (nlon,nlat), &
               Atmos % flux_sw_vis_dir (nlon,nlat), &
               Atmos % flux_sw_vis_dif(nlon,nlat), &
               Atmos % flux_lw  (nlon,nlat), &
               Atmos % coszen   (nlon,nlat), &
               Atmos % lprec    (nlon,nlat), &
               Atmos % fprec    (nlon,nlat)  )

    do j = 1, nlat
       do i = 1, nlon    
          Atmos % flux_sw(i,j)                 = 0.0
          Atmos % flux_lw(i,j)                 = 0.0    
          Atmos % flux_sw_dir (i,j)            = 0.0
          Atmos % flux_sw_dif (i,j)            = 0.0 
          Atmos % flux_sw_down_vis_dir (i,j)   = 0.0 
          Atmos % flux_sw_down_vis_dif (i,j)   = 0.0 
          Atmos % flux_sw_down_total_dir (i,j) = 0.0 
          Atmos % flux_sw_down_total_dif (i,j) = 0.0 
          Atmos % flux_sw_vis (i,j)            = 0.0 
          Atmos % flux_sw_vis_dir (i,j)        = 0.0 
          Atmos % flux_sw_vis_dif(i,j)         = 0.0 
          Atmos % coszen(i,j)                  = 0.0 
       enddo
    enddo
!-----------------------------------------------------------------------
!------ get initial state for dynamics -------

    call get_atmosphere_axes ( Atmos % axes )

    call atmosphere_boundary ( Atmos %  lon_bnd, Atmos %  lat_bnd, &
                               global=.false. )

    call get_bottom_mass (Atmos % t_bot,  Atmos % tr_bot, &
                          Atmos % p_bot,  Atmos % z_bot,  &
                          Atmos % p_surf, Atmos % slp     )

    call get_bottom_wind (Atmos % u_bot, Atmos % v_bot)

!-----------------------------------------------------------------------
!---- print version number to logfile ----

   call write_version_number ( version, tagname )
!  write the namelist to a log file
   if (mpp_pe() == mpp_root_pe()) then
      unit = stdlog( )
      write (unit, nml=atmos_model_nml)
      call close_file (unit)
!  number of tracers
      write (unit, '(a,i3)') 'Number of tracers =', ntrace
      write (unit, '(a,i3)') 'Number of prognostic tracers =', ntprog
      write (unit, '(a,i3)') 'Number of diagnostic tracers =', ntdiag
   endif

!------ read initial state for several atmospheric fields ------
   filename = 'atmos_coupled.res.nc'
   call get_mosaic_tile_file(filename, filename2, .false., Atmos%domain ) 
   allocate(Atm_restart)
   if(trim(filename2) == trim(filename)) then
      Til_restart => Atm_restart
      in_different_file = .false.
      id_restart = register_restart_field(Atm_restart, filename, 'glon_bnd', ipts, domain=Atmos%domain)
      id_restart = register_restart_field(Atm_restart, filename, 'glat_bnd', jpts, domain=Atmos%domain)
      id_restart = register_restart_field(Atm_restart, filename, 'dt', dto, domain=Atmos%domain)
   else
      in_different_file = .true.
      allocate(Til_restart)
      id_restart = register_restart_field(Atm_restart, filename, 'glon_bnd', ipts, no_domain=.true.)
      id_restart = register_restart_field(Atm_restart, filename, 'glat_bnd', jpts, no_domain=.true.)
      id_restart = register_restart_field(Atm_restart, filename, 'dt', dto, no_domain=.true.)
   endif

   id_restart = register_restart_field(Til_restart, filename, 'lprec', Atmos % lprec, domain=Atmos%domain)
   id_restart = register_restart_field(Til_restart, filename, 'fprec', Atmos % fprec, domain=Atmos%domain)
   id_restart = register_restart_field(Til_restart, filename, 'gust',  Atmos % gust,  domain=Atmos%domain)
   if (restart_tbot_qbot) then
      id_restart = register_restart_field(Til_restart, filename, 't_bot', Atmos%t_bot, domain=Atmos%domain)
      id_restart = register_restart_field(Til_restart, filename, 'q_bot', Atmos%tr_bot(:,:,ivapor), domain=Atmos%domain)
   end if

   call get_time (Atmos % Time_step, sec, day)
   dt = sec + 86400*day  ! integer seconds

   filename = 'INPUT/atmos_coupled.res.nc'
   if ( file_exist(filename, domain=Atmos%domain) ) then
       if(mpp_pe() == mpp_root_pe() ) call mpp_error ('atmos_model_mod', &
                   'Reading netCDF formatted restart file: INPUT/atmos_coupled.res.nc', NOTE)
       call restore_state(Atm_restart)
       if(in_different_file)call restore_state(Til_restart)
       if (ipts /= mlon .or. jpts /= mlat) call error_mesg &
               ('coupled_atmos_init', 'incorrect resolution on restart file', FATAL)

!---- if the time step has changed then convert ----
!        tendency to conserve mass of water
       if (dto /= dt) then
          Atmos % lprec = Atmos % lprec * real(dto)/real(dt)
          Atmos % fprec = Atmos % fprec * real(dto)/real(dt)
          if (mpp_pe() == mpp_root_pe()) write (logunit,50)
       endif
   else if (file_exist('INPUT/atmos_coupled.res')) then
          if(mpp_pe() == mpp_root_pe() ) call mpp_error ('atmos_model_mod', &
                   'Reading native formatted restart file: INPUT/atmos_coupled.res', NOTE)
          unit = open_restart_file ('INPUT/atmos_coupled.res', 'read')
          !--- check version number (format) of restart file ---
          read  (unit) control
          if (trim(control) /= trim(restart_format)) call error_mesg &
               ('coupled_atmos_init', 'invalid restart format', FATAL)
          !--- check resolution and time step ---
          read  (unit) ipts,jpts,dto
          if (ipts /= mlon .or. jpts /= mlat) call error_mesg &
               ('coupled_atmos_init', 'incorrect resolution on restart file', FATAL)

          !--- read data ---
          call read_data ( unit, Atmos % lprec )
          call read_data ( unit, Atmos % fprec )
          call read_data ( unit, Atmos % gust  )
          if (restart_tbot_qbot) then
             call read_data ( unit, Atmos % t_bot  )
             call read_data ( unit, Atmos % tr_bot(:,:,ivapor) )
          endif
          call close_file (unit)

!---- if the time step has changed then convert ----
!        tendency to conserve mass of water
          if (dto /= dt) then
             Atmos % lprec = Atmos % lprec * real(dto)/real(dt)
             Atmos % fprec = Atmos % fprec * real(dto)/real(dt)
             if (mpp_pe() == mpp_root_pe()) write (logunit,50)
 50         format (/,'The model time step changed .... &
                      &modifying precipitation tendencies')
          endif
   else
        Atmos % lprec = 0.0
        Atmos % fprec = 0.0
        Atmos % gust  = 1.0
   endif

   ! to be written to restart file
   ipts = mlon
   jpts = mlat  
   dto  = dt 

!------ initialize global integral package ------
!**** TEMPORARY FIX FOR GRID CELL CORNER PROBLEM ****

    allocate (area (nlon, nlat))
! call atmosphere_cell_area to obtain array of grid cell areas needed
! by diag_integral_init
    call atmosphere_cell_area (area)
    call diag_integral_init (Atmos % Time_init, Atmos % Time,  &
                             Atmos % lon_bnd(:,:),  &
                             Atmos % lat_bnd(:,:), area)
    deallocate (area)

!-----------------------------------------------------------------------
atmClock = mpp_clock_id( 'Atmosphere', flags=clock_flag_default, grain=CLOCK_COMPONENT )
end subroutine atmos_model_init
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="atmos_model_end">
!
! <OVERVIEW>
!  termination routine for atmospheric model
! </OVERVIEW>

! <DESCRIPTION>
!  Call once to terminate this module and any other modules used.
!  This routine writes a restart file and deallocates storage
!  used by the derived-type variable atmos_boundary_data_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call atmos_model_end (Atmos)
! </TEMPLATE>

! <INOUT NAME="Atmos" TYPE="type(atmos_data_type)">
!   Derived-type variable that contains fields needed by the flux exchange module.
! </INOUT>

subroutine atmos_model_end (Atmos)

type (atmos_data_type), intent(inout) :: Atmos

!-----------------------------------------------------------------------
!---- termination routine for atmospheric model ----
                                              
  call atmosphere_end (Atmos % Time, Atmos%grid)

!------ global integrals ------

  call diag_integral_end (Atmos % Time)

!------ write several atmospheric fields ------
!        also resolution and time step
  call atmos_model_local_restart(Atmos)

!-------- deallocate space --------

  deallocate ( Atmos %  lon_bnd , &
               Atmos %  lat_bnd , &
               Atmos % t_bot    , &
               Atmos % tr_bot   , &
               Atmos % z_bot    , &
               Atmos % p_bot    , &
               Atmos % u_bot    , &
               Atmos % v_bot    , &
               Atmos % p_surf   , &
               Atmos % slp      , &
               Atmos % gust     , &
               Atmos % flux_sw  , &
               Atmos % flux_sw_dir  , &
               Atmos % flux_sw_dif  , &
               Atmos % flux_sw_down_vis_dir  , &
               Atmos % flux_sw_down_vis_dif  , &
               Atmos % flux_sw_down_total_dir  , &
               Atmos % flux_sw_down_total_dif  , &
               Atmos % flux_sw_vis  , &
               Atmos % flux_sw_vis_dir  , &
               Atmos % flux_sw_vis_dif  , &
               Atmos % flux_lw  , &
               Atmos % coszen   , &
               Atmos % lprec    , &
               Atmos % fprec      )

!-----------------------------------------------------------------------

end subroutine atmos_model_end
! </SUBROUTINE>
  !#######################################################################
  ! <SUBROUTINE NAME="atmos_model_restart">
  ! <DESCRIPTION>
  !  Write out restart files registered through register_restart_file
  ! </DESCRIPTION>
  subroutine atmos_model_restart(Atmos, timestamp)
    type (atmos_data_type),   intent(inout) :: Atmos
    character(len=*),  intent(in)           :: timestamp

    call atmosphere_restart(timestamp)
    call atmos_model_local_restart(Atmos, timestamp)

  end subroutine atmos_model_restart
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="atmos_model_local_restart">
  ! <DESCRIPTION>
  !  Write out restart files registered through register_restart_file
  ! </DESCRIPTION>
  subroutine atmos_model_local_restart(Atmos, timestamp)
    type (atmos_data_type),   intent(inout) :: Atmos
    character(len=*),  intent(in), optional :: timestamp
    integer :: unit
    if( do_netcdf_restart) then
       if(mpp_pe() == mpp_root_pe()) then
          call mpp_error ('atmos_model_mod', 'Writing netCDF formatted restart file.', NOTE)
       endif
       call save_restart(Atm_restart, timestamp)
       if(in_different_file) call save_restart(Til_restart, timestamp)
    else
       if(present(timestamp)) call mpp_error ('atmos_model_mod',  &
            'intermediate restart capability is not implemented for non-netcdf file', FATAL)
       unit = open_restart_file ('RESTART/atmos_coupled.res', 'write')
       if (mpp_pe() == mpp_root_pe()) then
          write (unit) restart_format
          write (unit) ipts, jpts, dto
       endif
       call write_data ( unit, Atmos % lprec )
       call write_data ( unit, Atmos % fprec )
       call write_data ( unit, Atmos % gust  )
       if(restart_tbot_qbot) then
          call write_data ( unit, Atmos % t_bot  )
          call write_data ( unit, Atmos % tr_bot(:,:,ivapor)  )
       endif
       call close_file (unit)
    endif

  end subroutine atmos_model_local_restart
  ! </SUBROUTINE>
!#######################################################################
! <SUBROUTINE NAME="atm_stock_pe">
!
! <OVERVIEW>
!  returns the total stock in atmospheric model
! </OVERVIEW>

! <DESCRIPTION>
!  Called to compute and return the total stock (e.g., water, heat, etc.)
! in the atmospheric on the current PE.
! </DESCRIPTION>

! <TEMPLATE>
!   call atm_stock_pe (Atmos, index, value)
! </TEMPLATE>

! <INOUT NAME="Atm" TYPE="type(atmos_data_type)">
!   Derived-type variable that contains fields needed by the flux exchange module.
! </INOUT>
!
! <IN NAME="index" TYPE="integer">
!   Index of stock to be computed.
! </IN>
!
! <OUT NAME="value" TYPE="real">
!   Value of stock on the current processor.
! </OUT>

subroutine atm_stock_pe (Atm, index, value)

type (atmos_data_type), intent(inout) :: Atm
integer,                intent(in)    :: index
real,                   intent(out)   :: value

   value = 0.0
   if(Atm%pe) call get_stock_pe (index, value)

end subroutine atm_stock_pe

! </SUBROUTINE>

!#######################################################################
!#######################################################################
! <SUBROUTINE NAME="atmos_data_type_chksum">
!
! <OVERVIEW>
!  Print checksums of the various fields in the atmos_data_type.
! </OVERVIEW>

! <DESCRIPTION>
!  Routine to print checksums of the various fields in the atmos_data_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call atmos_data_type_chksum(id, timestep, atm)
! </TEMPLATE>

! <IN NAME="Atm" TYPE="type(atmos_data_type)">
!   Derived-type variable that contains fields in the atmos_data_type.
! </INOUT>
!
! <IN NAME="id" TYPE="character">
!   Label to differentiate where this routine in being called from.
! </IN>
!
! <IN NAME="timestep" TYPE="integer">
!   An integer to indicate which timestep this routine is being called for.
! </IN>
!
subroutine atmos_data_type_chksum(id, timestep, atm)
type(atmos_data_type), intent(in) :: atm 
    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    integer :: n, outunit

100 FORMAT("CHECKSUM::",A32," = ",Z20)
101 FORMAT("CHECKSUM::",A16,a,'%',a," = ",Z20)

  outunit = stdout()
  write(outunit,*) 'BEGIN CHECKSUM(Atmos_data_type):: ', id, timestep
  write(outunit,100) ' atm%lon_bnd                ', mpp_chksum(atm%lon_bnd               )
  write(outunit,100) ' atm%lat_bnd                ', mpp_chksum(atm%lat_bnd               )
  write(outunit,100) ' atm%t_bot                  ', mpp_chksum(atm%t_bot                 )
  do n = 1, size(atm%tr_bot,3)
  write(outunit,100) ' atm%tr_bot(:,:,n)          ', mpp_chksum(atm%tr_bot(:,:,n)         )
  enddo
  write(outunit,100) ' atm%z_bot                  ', mpp_chksum(atm%z_bot                 )
  write(outunit,100) ' atm%p_bot                  ', mpp_chksum(atm%p_bot                 )
  write(outunit,100) ' atm%u_bot                  ', mpp_chksum(atm%u_bot                 )
  write(outunit,100) ' atm%v_bot                  ', mpp_chksum(atm%v_bot                 )
  write(outunit,100) ' atm%p_surf                 ', mpp_chksum(atm%p_surf                )
  write(outunit,100) ' atm%slp                    ', mpp_chksum(atm%slp                   )
  write(outunit,100) ' atm%gust                   ', mpp_chksum(atm%gust                  )
  write(outunit,100) ' atm%coszen                 ', mpp_chksum(atm%coszen                )
  write(outunit,100) ' atm%flux_sw                ', mpp_chksum(atm%flux_sw               )
  write(outunit,100) ' atm%flux_sw_dir            ', mpp_chksum(atm%flux_sw_dir           )
  write(outunit,100) ' atm%flux_sw_dif            ', mpp_chksum(atm%flux_sw_dif           )
  write(outunit,100) ' atm%flux_sw_down_vis_dir   ', mpp_chksum(atm%flux_sw_down_vis_dir  )
  write(outunit,100) ' atm%flux_sw_down_vis_dif   ', mpp_chksum(atm%flux_sw_down_vis_dif  )
  write(outunit,100) ' atm%flux_sw_down_total_dir ', mpp_chksum(atm%flux_sw_down_total_dir)
  write(outunit,100) ' atm%flux_sw_down_total_dif ', mpp_chksum(atm%flux_sw_down_total_dif)
  write(outunit,100) ' atm%flux_sw_vis            ', mpp_chksum(atm%flux_sw_vis           )
  write(outunit,100) ' atm%flux_sw_vis_dir        ', mpp_chksum(atm%flux_sw_vis_dir       )
  write(outunit,100) ' atm%flux_sw_vis_dif        ', mpp_chksum(atm%flux_sw_vis_dif       )
  write(outunit,100) ' atm%flux_lw                ', mpp_chksum(atm%flux_lw               )
  write(outunit,100) ' atm%lprec                  ', mpp_chksum(atm%lprec                 )
  write(outunit,100) ' atm%fprec                  ', mpp_chksum(atm%fprec                 )
!  call surf_diff_type_chksum(id, timestep, atm%surf_diff)

end subroutine atmos_data_type_chksum

! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="lnd_ice_atm_bnd_type_chksum">
!
! <OVERVIEW>
!  Print checksums of the various fields in the land_ice_atmos_boundary_type.
! </OVERVIEW>

! <DESCRIPTION>
!  Routine to print checksums of the various fields in the land_ice_atmos_boundary_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call atmos_data_type_chksum(id, timestep, bnd_type)
! </TEMPLATE>

! <IN NAME="bnd_type" TYPE="type(land_ice_atmos_boundary_type)">
!   Derived-type variable that contains fields in the land_ice_atmos_boundary_type.
! </INOUT>
!
! <IN NAME="id" TYPE="character">
!   Label to differentiate where this routine in being called from.
! </IN>
!
! <IN NAME="timestep" TYPE="integer">
!   An integer to indicate which timestep this routine is being called for.
! </IN>
!


subroutine lnd_ice_atm_bnd_type_chksum(id, timestep, bnd_type)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(land_ice_atmos_boundary_type), intent(in) :: bnd_type
 integer ::   n, outunit

    outunit = stdout()
    write(outunit,*) 'BEGIN CHECKSUM(lnd_ice_Atm_bnd_type):: ', id, timestep
100 FORMAT("CHECKSUM::",A32," = ",Z20)
    write(outunit,100) 'lnd_ice_atm_bnd_type%t             ',mpp_chksum(bnd_type%t              )
    write(outunit,100) 'lnd_ice_atm_bnd_type%albedo        ',mpp_chksum(bnd_type%albedo         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%albedo_vis_dir',mpp_chksum(bnd_type%albedo_vis_dir )
    write(outunit,100) 'lnd_ice_atm_bnd_type%albedo_nir_dir',mpp_chksum(bnd_type%albedo_nir_dir )
    write(outunit,100) 'lnd_ice_atm_bnd_type%albedo_vis_dif',mpp_chksum(bnd_type%albedo_vis_dif )
    write(outunit,100) 'lnd_ice_atm_bnd_type%albedo_nir_dif',mpp_chksum(bnd_type%albedo_nir_dif )
    write(outunit,100) 'lnd_ice_atm_bnd_type%land_frac     ',mpp_chksum(bnd_type%land_frac      )
    write(outunit,100) 'lnd_ice_atm_bnd_type%dt_t          ',mpp_chksum(bnd_type%dt_t           )
    do n = 1, size(bnd_type%dt_tr,3)
    write(outunit,100) 'lnd_ice_atm_bnd_type%dt_tr(:,:,n)  ',mpp_chksum(bnd_type%dt_tr(:,:,n)   )
    enddo
    write(outunit,100) 'lnd_ice_atm_bnd_type%u_flux        ',mpp_chksum(bnd_type%u_flux         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%v_flux        ',mpp_chksum(bnd_type%v_flux         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%dtaudu        ',mpp_chksum(bnd_type%dtaudu         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%dtaudv        ',mpp_chksum(bnd_type%dtaudv         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%u_star        ',mpp_chksum(bnd_type%u_star         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%b_star        ',mpp_chksum(bnd_type%b_star         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%q_star        ',mpp_chksum(bnd_type%q_star         )
    write(outunit,100) 'lnd_ice_atm_bnd_type%rough_mom     ',mpp_chksum(bnd_type%rough_mom      )
!    write(outunit,100) 'lnd_ice_atm_bnd_type%data          ',mpp_chksum(bnd_type%data           )

end subroutine lnd_ice_atm_bnd_type_chksum
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="lnd_atm_bnd_type_chksum">
!
! <OVERVIEW>
!  Print checksums of the various fields in the land_atmos_boundary_type.
! </OVERVIEW>

! <DESCRIPTION>
!  Routine to print checksums of the various fields in the land_atmos_boundary_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call lnd_atm_bnd_type_chksum(id, timestep, bnd_type)
! </TEMPLATE>

! <IN NAME="bnd_type" TYPE="type(land_atmos_boundary_type)">
!   Derived-type variable that contains fields in the land_atmos_boundary_type.
! </INOUT>
!
! <IN NAME="id" TYPE="character">
!   Label to differentiate where this routine in being called from.
! </IN>
!
! <IN NAME="timestep" TYPE="integer">
!   An integer to indicate which timestep this routine is being called for.
! </IN>
!


subroutine lnd_atm_bnd_type_chksum(id, timestep, bnd_type)
  use fms_mod,                 only: stdout
  use mpp_mod,                 only: mpp_chksum

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(land_atmos_boundary_type), intent(in) :: bnd_type
 integer ::   n, outunit

    outunit = stdout()
    write(outunit,*) 'BEGIN CHECKSUM(lnd_atmos_boundary_type):: ', id, timestep
!    write(outunit,100) 'lnd_atm_bnd_type%data',mpp_chksum(bnd_type%data)

100 FORMAT("CHECKSUM::",A32," = ",Z20)

end subroutine lnd_atm_bnd_type_chksum
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="ice_atm_bnd_type_chksum">
!
! <OVERVIEW>
!  Print checksums of the various fields in the ice_atmos_boundary_type.
! </OVERVIEW>

! <DESCRIPTION>
!  Routine to print checksums of the various fields in the ice_atmos_boundary_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call ice_atm_bnd_type_chksum(id, timestep, bnd_type)
! </TEMPLATE>

! <IN NAME="bnd_type" TYPE="type(ice_atmos_boundary_type)">
!   Derived-type variable that contains fields in the ice_atmos_boundary_type.
! </INOUT>
!
! <IN NAME="id" TYPE="character">
!   Label to differentiate where this routine in being called from.
! </IN>
!
! <IN NAME="timestep" TYPE="integer">
!   An integer to indicate which timestep this routine is being called for.
! </IN>
!


subroutine ice_atm_bnd_type_chksum(id, timestep, bnd_type)
  use fms_mod,                 only: stdout
  use mpp_mod,                 only: mpp_chksum

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(ice_atmos_boundary_type), intent(in) :: bnd_type
 integer ::   n, outunit

    outunit = stdout()
    write(outunit,*) 'BEGIN CHECKSUM(ice_atmos_boundary_type):: ', id, timestep
!    write(outunit,100) 'ice_atm_bnd_type%data',mpp_chksum(data_type%data)

100 FORMAT("CHECKSUM::",A32," = ",Z20)


end subroutine ice_atm_bnd_type_chksum
! </SUBROUTINE>


end module atmos_model_mod



module atmosphere_mod

!-----------------------------------------------------------------------
!
! Interface for Cubed_Sphere fv dynamical core and physics
!
!-----------------------------------------------------------------------

!-----------------
! FMS modules:
!-----------------
use constants_mod,      only: cp_air, rdgas, grav, rvgas, kappa, pstd_mks
use time_manager_mod,   only: time_type, get_time, set_time, operator(+)
use fms_mod,            only: file_exist, open_namelist_file,    &
                              close_file, error_mesg, FATAL,     &
                              check_nml_error, stdlog,           &
                              write_version_number,              &
                              mpp_pe, mpp_root_pe, set_domain,   &
                              mpp_clock_id, mpp_clock_begin,     &
                              mpp_clock_end, CLOCK_SUBCOMPONENT, &
                              clock_flag_default, nullify_domain
use mpp_mod,            only: mpp_error, FATAL, input_nml_file
use mpp_domains_mod,    only: domain2d
use xgrid_mod,          only: grid_box_type
!miz
use diag_manager_mod,   only: diag_axis_init, register_diag_field, &
                              register_static_field, send_data
!miz
use field_manager_mod,  only: MODEL_ATMOS
use tracer_manager_mod, only: get_tracer_index,&
                              get_number_tracers, &
                              get_tracer_names

!-----------------
! FV core modules:
!-----------------
use fv_grid_tools_mod,  only: area, grid_type, dx, dy, area
use fv_grid_utils_mod,  only: edge_w, edge_e, edge_s, edge_n, en1, en2, vlon, vlat
use fv_arrays_mod,      only: fv_atmos_type
use fv_control_mod,     only: fv_init, domain, fv_end, p_ref
use fv_mp_mod,          only: domain_for_coupler
use fv_dynamics_mod,    only: fv_dynamics
use fv_diagnostics_mod, only: fv_diag_init, fv_diag, fv_time
use fv_restart_mod,     only: fv_restart, fv_write_restart
use fv_timing_mod,      only: timing_on, timing_off
use fv_physics_mod,     only: fv_physics_down, fv_physics_up,  &
                              fv_physics_init, fv_physics_end, &
                              surf_diff_type, fv_physics_restart
use fv_nwp_nudge_mod,   only: fv_nwp_nudge_init, fv_nwp_nudge_end

implicit none
private

public  atmosphere_down,       atmosphere_up,       &
        atmosphere_init,       atmosphere_end,      &
        atmosphere_resolution, atmosphere_boundary, &
        get_atmosphere_axes,   atmosphere_domain,   &
        get_bottom_mass,       get_bottom_wind,     &
        atmosphere_cell_area,  atmosphere_restart,  &
        get_stock_pe,          surf_diff_type

!-----------------------------------------------------------------------

character(len=128) :: version = '$Id: atmosphere.F90,v 17.0.2.3.2.1.4.1 2010/08/03 20:29:21 rab Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
character(len=7)   :: mod_name = 'atmos'

!---- namelist (saved in file input.nml) ----
!
! physics_window  The number of "i" by "j" rows processed each time
!                 the modular physics is called. To process the entire
!                 domain use physics_window = (/0,0/).
!                   [integer, default: physics_window = 0,0]

  integer, dimension(2) :: physics_window = (/0,0/)
  namelist /atmosphere_nml/ physics_window

!---- private data ----
  type (time_type) :: Time_step_atmos
  type (fv_atmos_type), allocatable :: Atm(:)
  public Atm

  real    :: dt_atmos
  real    :: zvir
  integer :: npx, npy, npz, ncnst, pnats
  integer :: isc, iec, jsc, jec
  integer :: nq                       ! transported tracers
  integer :: sec, seconds, days
  integer :: atmos_axes(4)
  integer :: ntiles=1
  integer :: id_dynam, id_phys_down, id_phys_up, id_fv_diag
  logical :: cold_start = .false.       ! read in initial condition

  integer, dimension(:), allocatable :: id_tracerdt_dyn
  integer :: num_tracers = 0
!miz
  integer :: id_tdt_dyn, id_qdt_dyn, id_qldt_dyn, id_qidt_dyn, id_qadt_dyn
  logical :: used
  character(len=64) :: field
  real, allocatable :: ttend(:,:,:)
  real, allocatable :: qtendyyf(:,:,:,:)
  real, allocatable :: qtend(:,:,:,:)
  real              :: mv = -1.e10
!miz

contains



 subroutine atmosphere_init (Time_init, Time, Time_step, Surf_diff, Grid_box)
   type (time_type),     intent(in)    :: Time_init, Time, Time_step
   type(surf_diff_type), intent(inout) :: Surf_diff
   type(grid_box_type),  intent(inout) :: Grid_box

   integer :: unit, ierr, io, i
   integer :: itrac
   character(len=32) :: tracer_name, tracer_units

   call get_number_tracers(MODEL_ATMOS, num_prog= num_tracers)

   zvir = rvgas/rdgas - 1.

!----- read namelist -----
#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=atmosphere_nml, iostat=io)
   ierr = check_nml_error (io, 'atmosphere_nml')
#else
   if ( file_exist('input.nml') ) then
       unit = open_namelist_file ( )
       ierr=1
       do while (ierr /= 0)
          read (unit, nml=atmosphere_nml, iostat=io, end=10)
          ierr = check_nml_error (io, 'atmosphere_nml')
       enddo
 10    call close_file (unit)
   endif
#endif

!----- write version and namelist to log file -----

   unit = stdlog()
   call write_version_number ( version, tagname )
   if ( mpp_pe() == mpp_root_pe() ) write (unit, nml=atmosphere_nml)

!---- compute physics/atmos time step in seconds ----

   Time_step_atmos = Time_step
   call get_time (Time_step_atmos, sec)
   dt_atmos = real(sec)

!----- initialize FV dynamical core -----
   cold_start = (.not.file_exist('INPUT/fv_core.res.nc'))

   allocate( Atm(ntiles) )

   call fv_init( Atm(:), dt_atmos )  ! allocates Atm components

   npx   = Atm(1)%npx
   npy   = Atm(1)%npy
   npz   = Atm(1)%npz
   ncnst = Atm(1)%ncnst
   pnats = Atm(1)%pnats

   isc = Atm(1)%isc
   iec = Atm(1)%iec
   jsc = Atm(1)%jsc
   jec = Atm(1)%jec

   ! Allocate grid variables to be used to calculate gradient in 2nd order flux exchange
   allocate(Grid_box%dx    (   isc:iec  , jsc:jec+1))
   allocate(Grid_box%dy    (   isc:iec+1, jsc:jec  ))
   allocate(Grid_box%area  (   isc:iec  , jsc:jec  ))
   allocate(Grid_box%edge_w(              jsc:jec+1))
   allocate(Grid_box%edge_e(              jsc:jec+1))
   allocate(Grid_box%edge_s(   isc:iec+1           ))
   allocate(Grid_box%edge_n(   isc:iec+1           ))
   allocate(Grid_box%en1   (3, isc:iec  , jsc:jec+1))
   allocate(Grid_box%en2   (3, isc:iec+1, jsc:jec  ))
   allocate(Grid_box%vlon  (3, isc:iec  , jsc:jec  ))
   allocate(Grid_box%vlat  (3, isc:iec  , jsc:jec  ))
   Grid_box%dx    (   isc:iec  , jsc:jec+1) = dx    (   isc:iec,   jsc:jec+1)
   Grid_box%dy    (   isc:iec+1, jsc:jec  ) = dy    (   isc:iec+1, jsc:jec  )
   Grid_box%area  (   isc:iec  , jsc:jec  ) = area  (   isc:iec  , jsc:jec  )
   Grid_box%edge_w(              jsc:jec+1) = edge_w(              jsc:jec+1)
   Grid_box%edge_e(              jsc:jec+1) = edge_e(              jsc:jec+1)
   Grid_box%edge_s(   isc:iec+1           ) = edge_s(   isc:iec+1)
   Grid_box%edge_n(   isc:iec+1           ) = edge_n(   isc:iec+1)
   Grid_box%en1   (:, isc:iec  , jsc:jec+1) = en1   (:, isc:iec  , jsc:jec+1)
   Grid_box%en2   (:, isc:iec+1, jsc:jec  ) = en2   (:, isc:iec+1, jsc:jec  )
   if (allocated(vlon) .and. allocated(vlat)) then
      do i = 1, 3
         Grid_box%vlon  (i, isc:iec  , jsc:jec  ) = vlon  (isc:iec ,  jsc:jec, i  )
         Grid_box%vlat  (i, isc:iec  , jsc:jec  ) = vlat  (isc:iec ,  jsc:jec, i  )
      end do
   else
      do i = 1, 3
         Grid_box%vlon  (i, isc:iec  , jsc:jec  ) = 0.
         Grid_box%vlat  (i, isc:iec  , jsc:jec  ) = 0.
      end do
   endif
   nq = ncnst-pnats

   call fv_restart(domain, Atm, dt_atmos, seconds, days, cold_start, grid_type)

   fv_time = Time

!----- initialize atmos_axes and fv_dynamics diagnostics

   call fv_diag_init(Atm, atmos_axes, Time, npx, npy, npz, p_ref)

!----- initialize physics interface -----
!----- initialize domains for reading global physics data -----

   call set_domain ( domain )

   call fv_physics_init (Atm, atmos_axes, Time, physics_window, Surf_diff)

   call nullify_domain ( )

   if ( Atm(1)%nudge )    &
        call fv_nwp_nudge_init( npz, zvir, Atm(1)%ak, Atm(1)%bk, Atm(1)%ts, Atm(1)%phis)

!miz
   if( Atm(1)%ncep_ic ) Surf_diff%sst_miz(:,:) = Atm(1)%ts(isc:iec, jsc:jec)

   id_tdt_dyn =register_diag_field(mod_name,'tdt_dyn',  atmos_axes(1:3),Time,'tdt_dyn', 'K/s', missing_value=mv)
   id_qdt_dyn =register_diag_field(mod_name,'qdt_dyn',  atmos_axes(1:3),Time,'qdt_dyn', 'kg/kg/s', missing_value=mv)
   id_qldt_dyn=register_diag_field(mod_name,'qldt_dyn', atmos_axes(1:3),Time,'qldt_dyn','kg/kg/s', missing_value=mv)
   id_qidt_dyn=register_diag_field(mod_name,'qidt_dyn', atmos_axes(1:3),Time,'qidt_dyn','kg/kg/s', missing_value=mv)
   id_qadt_dyn=register_diag_field(mod_name,'qadt_dyn', atmos_axes(1:3),Time,'qadt_dyn','1/s', missing_value=mv)

!yyf---allocate id_tracer_dyn 
   allocate (id_tracerdt_dyn    (num_tracers))
!yyf---loop for tracers
   do itrac = 1, num_tracers
     call get_tracer_names (MODEL_ATMOS, itrac, name = tracer_name, &
                                                  units = tracer_units)
     if (get_tracer_index(MODEL_ATMOS,tracer_name)>0) &
         id_tracerdt_dyn(itrac) = register_diag_field  &
             (mod_name, TRIM(tracer_name)//'dt_dyn', atmos_axes(1:3), &
             Time, TRIM(tracer_name)//' total tendency from advection',&
             TRIM(tracer_units)//'/s', missing_value = mv)
   enddo
   if (any(id_tracerdt_dyn(:)>0))   &
                     allocate(qtendyyf(isc:iec, jsc:jec,1:npz,num_tracers))
!yyf---end loop

   if ( id_tdt_dyn>0 ) allocate(ttend (isc:iec, jsc:jec, 1:npz))
   if ( id_qdt_dyn>0 .or. id_qldt_dyn>0 .or. id_qidt_dyn>0 .or. id_qadt_dyn>0 )   &
   allocate(qtend (isc:iec, jsc:jec, 1:npz, 4))
!miz

!  --- initialize clocks for dynamics, physics_down and physics_up
   id_dynam     = mpp_clock_id ('FV dynamical core',   &
          flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT )
   id_phys_down = mpp_clock_id ('Physics_down',   &
          flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT )
   id_phys_up   = mpp_clock_id ('Physics_up',   &
          flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT )
   id_fv_diag   = mpp_clock_id ('FV Diag',   &
          flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT )

 end subroutine atmosphere_init



 subroutine atmosphere_down ( Time,    frac_land,          &
                           t_surf,  albedo,                &
                           albedo_vis_dir, albedo_nir_dir, &
                           albedo_vis_dif, albedo_nir_dif, &
                           rough_mom,                      &
                           u_star,  b_star, q_star,        &
                           dtau_du, dtau_dv, tau_x, tau_y, &
                           gust, coszen, flux_sw,          &
                           flux_sw_dir, flux_sw_dif,       &
                           flux_sw_down_vis_dir,           &          
                           flux_sw_down_vis_dif,           &
                           flux_sw_down_total_dir,         &
                           flux_sw_down_total_dif,         &
                           flux_sw_vis,                    &
                           flux_sw_vis_dir,                &
                           flux_sw_vis_dif,                &
                           flux_lw,                        &
                           Surf_diff                       )
!
!        Time = time at the current time level
!
   type(time_type),intent(in)      :: Time
   real, intent(in), dimension(:,:):: frac_land, t_surf, albedo,      &
                                      albedo_vis_dir, albedo_nir_dir, &
                                      albedo_vis_dif, albedo_nir_dif, &
                                      rough_mom, u_star, b_star,      &
                                      q_star, dtau_du, dtau_dv
   real, intent(inout), dimension(:,:):: tau_x,  tau_y
   real, intent(out),   dimension(:,:):: gust, coszen, flux_sw,    &
                                         flux_sw_dir, flux_sw_dif, &
                                         flux_sw_down_vis_dir,     &
                                         flux_sw_down_total_dir,   &
                                         flux_sw_down_vis_dif,     &
                                         flux_sw_down_total_dif,   &
                                         flux_sw_vis,              &
                                         flux_sw_vis_dir,          &
                                         flux_sw_vis_dif, flux_lw
   type(surf_diff_type), intent(inout):: Surf_diff
   type(time_type) :: Time_prev, Time_next
   integer         :: itrac

   Time_prev = Time                       ! two time-level scheme
   Time_next = Time + Time_step_atmos

!---- Call FV dynamics -----

   call mpp_clock_begin (id_dynam)
                    call timing_on('fv_dynamics')

!miz
   if ( id_tdt_dyn>0 ) ttend(:, :, :) = Atm(1)%pt(isc:iec, jsc:jec, :)
   if ( id_qdt_dyn>0 .or. id_qldt_dyn>0 .or. id_qidt_dyn>0 .or. id_qadt_dyn>0 )   &
   qtend(:, :, :, :) = Atm(1)%q (isc:iec, jsc:jec, :, :)
!miz
   do itrac = 1, num_tracers
     if (id_tracerdt_dyn (itrac) >0 )   &
            qtendyyf(:,:,:,itrac) = Atm(1)%q(isc:iec, jsc:jec, :,itrac)
   enddo

   call fv_dynamics(npx, npy, npz, nq, Atm(1)%ng, dt_atmos, Atm(1)%consv_te,         &
                    Atm(1)%fill,  Atm(1)%reproduce_sum, kappa, cp_air, zvir,         &
                    Atm(1)%ks,    ncnst,        Atm(1)%n_split,   Atm(1)%q_split,    &
                    Atm(1)%u, Atm(1)%v, Atm(1)%um, Atm(1)%vm,                        &
                    Atm(1)%w, Atm(1)%delz, Atm(1)%hydrostatic,   & 
                    Atm(1)%pt, Atm(1)%delp, Atm(1)%q, Atm(1)%ps, &
                    Atm(1)%pe, Atm(1)%pk, Atm(1)%peln, Atm(1)%pkz, Atm(1)%phis,      &
                    Atm(1)%omga, Atm(1)%ua, Atm(1)%va, Atm(1)%uc, Atm(1)%vc,         &
                    Atm(1)%ak, Atm(1)%bk, Atm(1)%mfx, Atm(1)%mfy,                    &
                    Atm(1)%cx, Atm(1)%cy, Atm(1)%ze0, Atm(1)%hybrid_z)

                    call timing_off('fv_dynamics')
!miz
   if ( id_tdt_dyn>0 ) then
        ttend = (Atm(1)%pt(isc:iec, jsc:jec, :)   - ttend(:, :, :   ))/dt_atmos
         used = send_data(id_tdt_dyn,  ttend(:,:,:),   Time)
   endif

   if ( id_qdt_dyn>0 .or. id_qldt_dyn>0 .or. id_qidt_dyn>0 .or. id_qadt_dyn>0 ) then
        qtend = (Atm(1)%q (isc:iec, jsc:jec, :, :)- qtend(:, :, :, :))/dt_atmos
        used = send_data(id_qdt_dyn,  qtend(:,:,:,1), Time)
        used = send_data(id_qldt_dyn, qtend(:,:,:,2), Time)
        used = send_data(id_qidt_dyn, qtend(:,:,:,3), Time)
        used = send_data(id_qadt_dyn, qtend(:,:,:,4), Time)
   endif
!miz

   do itrac = 1, num_tracers
     if(id_tracerdt_dyn(itrac)>0) then
       qtendyyf(:,:,:,itrac) = (Atm(1)%q (isc:iec, jsc:jec, :,itrac)-  &
                                        qtendyyf(:,:,:,itrac))/dt_atmos
       used = send_data(id_tracerdt_dyn(itrac), qtendyyf(:,:,:,itrac), &
                                                           Time)
     endif
   enddo

   call mpp_clock_end (id_dynam)


   call set_domain ( domain )
   call mpp_clock_begin (id_phys_down)
                         call timing_on('fv_physics_down')
   call fv_physics_down (Atm, dt_atmos, Time_prev, Time, Time_next,     &
                         frac_land, albedo,              &
                         albedo_vis_dir, albedo_nir_dir, &
                         albedo_vis_dif, albedo_nir_dif, &
                         rough_mom,  t_surf,             &
                         u_star,  b_star, q_star,        &
                         dtau_du, dtau_dv, tau_x, tau_y, &
                         flux_sw, flux_sw_dir,           &
                         flux_sw_dif,                    &
                         flux_sw_down_vis_dir,           &
                         flux_sw_down_vis_dif,           &
                         flux_sw_down_total_dir,         &
                         flux_sw_down_total_dif,         &
                         flux_sw_vis, flux_sw_vis_dir,   &
                         flux_sw_vis_dif, flux_lw,       &
                         coszen, gust, Surf_diff )
                         call timing_off('fv_physics_down')
   call mpp_clock_end (id_phys_down)
   call nullify_domain ( )

 end subroutine atmosphere_down



 subroutine atmosphere_up ( Time,  frac_land, Surf_diff, lprec, fprec, gust, &
                            u_star, b_star, q_star )

   type(time_type),intent(in)         :: Time
   type(surf_diff_type), intent(inout):: Surf_diff
   real, intent(in),  dimension(:,:)  :: frac_land
   real, intent(inout), dimension(:,:):: gust
   real, intent(out), dimension(:,:)  :: lprec,   fprec
   real, intent(in), dimension(:,:)   :: u_star, b_star, q_star

   type(time_type) :: Time_prev, Time_next

   Time_prev = Time                       ! two time-level scheme
   Time_next = Time + Time_step_atmos

   call set_domain ( domain )
   call mpp_clock_begin (id_phys_up)
!-----------------------------------------------------------------------
                       call timing_on('fv_physics_up')
   call fv_physics_up( Atm, dt_atmos, Time_prev, Time, Time_next,      &
                       frac_land, Surf_diff, lprec, fprec, gust ,      &
                       u_star, b_star, q_star   )
                       call timing_off('fv_physics_up')
!-----------------------------------------------------------------------
   call mpp_clock_end (id_phys_up)

   call mpp_clock_begin(id_fv_diag)

   fv_time = Time_next
   call get_time (fv_time, seconds,  days)
!-----------------------------------------------------------------------
                call timing_on('FV_DIAG')
   call fv_diag( Atm, zvir, fv_time, Atm(1)%print_freq )
                call timing_off('FV_DIAG')     
!-----------------------------------------------------------------------
   call mpp_clock_end(id_fv_diag)
   call nullify_domain ( )


 end subroutine atmosphere_up



 subroutine atmosphere_end (Time, Grid_box)
   type (time_type),       intent(in) :: Time
   type(grid_box_type), intent(inout) :: Grid_box

  ! initialize domains for writing global physics data
   call set_domain ( domain )

   call get_time (Time, seconds,  days)

   call fv_physics_end(Atm, Time)
   if ( Atm(1)%nudge ) call fv_nwp_nudge_end

   call nullify_domain ( )
   call fv_end(Atm)
   deallocate (Atm)

   deallocate(Grid_box%dx)
   deallocate(Grid_box%dy)
   deallocate(Grid_box%area)
   deallocate(Grid_box%edge_w)
   deallocate(Grid_box%edge_e)
   deallocate(Grid_box%edge_s)
   deallocate(Grid_box%edge_n)
   deallocate(Grid_box%en1)
   deallocate(Grid_box%en2)
   deallocate(Grid_box%vlon)
   deallocate(Grid_box%vlat)

   if ( id_tdt_dyn>0 ) deallocate(ttend)
   if ( id_qdt_dyn>0 .or. id_qldt_dyn>0 .or. id_qidt_dyn>0 .or. id_qadt_dyn>0 ) deallocate(qtend)

   if (allocated(qtendyyf)) deallocate (qtendyyf)

 end subroutine atmosphere_end



  !#######################################################################
  ! <SUBROUTINE NAME="atmosphere_restart">
  ! <DESCRIPTION>
  !  Write out restart files registered through register_restart_file
  ! </DESCRIPTION>
  subroutine atmosphere_restart(timestamp)
    character(len=*),  intent(in) :: timestamp

    call fv_physics_restart(timestamp)
    call fv_write_restart(Atm, timestamp)

  end subroutine atmosphere_restart
  ! </SUBROUTINE>



 subroutine atmosphere_resolution (i_size, j_size, global)
   integer, intent(out)          :: i_size, j_size
   logical, intent(in), optional :: global
   logical :: local

   local = .true.
   if( PRESENT(global) ) local = .NOT.global

   if( local ) then
       i_size = iec - isc + 1
       j_size = jec - jsc + 1
   else
       i_size = npx - 1
       j_size = npy - 1
   end if

 end subroutine atmosphere_resolution



 subroutine atmosphere_cell_area  (area_out)
   real, dimension(:,:),  intent(out)          :: area_out       

   area_out(1:iec-isc+1, 1:jec-jsc+1) =  area (isc:iec,jsc:jec)                        

 end subroutine atmosphere_cell_area 





 subroutine atmosphere_boundary (blon, blat, global)
!---------------------------------------------------------------
!    returns the longitude and latitude grid box edges
!    for either the local PEs grid (default) or the global grid
!---------------------------------------------------------------
    real,    intent(out) :: blon(:,:), blat(:,:)   ! Unit: radian
    logical, intent(in), optional :: global
! Local data:
    integer i,j

    if( PRESENT(global) ) then
      if (global) call mpp_error(FATAL, '==> global grid is no longer available &
                               & in the Cubed Sphere')
    endif

    do j=jsc,jec+1
       do i=isc,iec+1
          blon(i-isc+1,j-jsc+1) = Atm(1)%grid(i,j,1)
          blat(i-isc+1,j-jsc+1) = Atm(1)%grid(i,j,2)
       enddo
    end do

 end subroutine atmosphere_boundary



 subroutine atmosphere_domain ( fv_domain )
   type(domain2d), intent(out) :: fv_domain
!  returns the domain2d variable associated with the coupling grid
!  note: coupling is done using the mass/temperature grid with no halos

   fv_domain = domain_for_coupler

 end subroutine atmosphere_domain



 subroutine get_atmosphere_axes ( axes )
   integer, intent(out) :: axes (:)

!----- returns the axis indices for the atmospheric (mass) grid -----
   if ( size(axes(:)) < 0 .or. size(axes(:)) > 4 ) call error_mesg (    &
                               'get_atmosphere_axes in atmosphere_mod', &
                               'size of argument is incorrect', FATAL   )

   axes (1:size(axes(:))) = atmos_axes (1:size(axes(:)))
 
 end subroutine get_atmosphere_axes




 subroutine get_bottom_mass ( t_bot, tr_bot, p_bot, z_bot, p_surf, slp )
!--------------------------------------------------------------
! returns temp, sphum, pres, height at the lowest model level
! and surface pressure
!--------------------------------------------------------------
   real, intent(out), dimension(isc:iec,jsc:jec):: t_bot, p_bot, z_bot, p_surf
   real, intent(out), optional, dimension(isc:iec,jsc:jec):: slp
   real, intent(out), dimension(isc:iec,jsc:jec,nq):: tr_bot
   integer :: i, j, m, k, kr
   real    :: rrg, sigtop, sigbot
   real, dimension(isc:iec,jsc:jec) :: tref
   real, parameter :: tlaps = 6.5e-3

   rrg  = rdgas / grav

   do j=jsc,jec
      do i=isc,iec
         p_surf(i,j) = Atm(1)%ps(i,j)
         t_bot(i,j) = Atm(1)%pt(i,j,npz)
         p_bot(i,j) = Atm(1)%delp(i,j,npz)/(Atm(1)%peln(i,npz+1,j)-Atm(1)%peln(i,npz,j))
         z_bot(i,j) = rrg*t_bot(i,j)*(1.+zvir*Atm(1)%q(i,j,npz,1)) *  &
                      (1. - Atm(1)%pe(i,npz,j)/p_bot(i,j))
      enddo
   enddo

   if ( present(slp) ) then
     ! determine 0.8 sigma reference level
     sigtop = Atm(1)%ak(1)/pstd_mks+Atm(1)%bk(1)
     do k = 1, npz 
        sigbot = Atm(1)%ak(k+1)/pstd_mks+Atm(1)%bk(k+1)
        if (sigbot+sigtop > 1.6) then
           kr = k  
           exit    
        endif   
        sigtop = sigbot
     enddo
     do j=jsc,jec
        do i=isc,iec
           ! sea level pressure
           tref(i,j) = Atm(1)%pt(i,j,kr) * (Atm(1)%delp(i,j,kr)/ &
                            ((Atm(1)%peln(i,kr+1,j)-Atm(1)%peln(i,kr,j))*Atm(1)%ps(i,j)))**(-rrg*tlaps)
           slp(i,j) = Atm(1)%ps(i,j)*(1.+tlaps*Atm(1)%phis(i,j)/(tref(i,j)*grav))**(1./(rrg*tlaps))
        enddo
     enddo
   endif

! Copy tracers
   do m=1,nq
      do j=jsc,jec
         do i=isc,iec
            tr_bot(i,j,m) = Atm(1)%q(i,j,npz,m)
         enddo
      enddo
   enddo

 end subroutine get_bottom_mass



 subroutine get_bottom_wind ( u_bot, v_bot )
!-----------------------------------------------------------
! returns u and v on the mass grid at the lowest model level
!-----------------------------------------------------------
   real, intent(out), dimension(isc:iec,jsc:jec):: u_bot, v_bot
   integer i, j

   do j=jsc,jec
      do i=isc,iec
         u_bot(i,j) = Atm(1)%u_srf(i,j)
         v_bot(i,j) = Atm(1)%v_srf(i,j)
      enddo
   enddo

 end subroutine get_bottom_wind



 subroutine get_stock_pe(index, value)
   integer, intent(in) :: index
   real,   intent(out) :: value

#ifdef USE_STOCK
   include 'stock.inc' 
#endif

   real wm(isc:iec,jsc:jec)
   integer i,j,k
   
   select case (index)

#ifdef USE_STOCK
   case (ISTOCK_WATER)
#else
   case (1)
#endif
     
!----------------------
! Perform vertical sum:
!----------------------
     wm = 0.
     do j=jsc,jec
        do k=1,npz
           do i=isc,iec
! Warning: the following works only with AM2 physics: water vapor; cloud water, cloud ice.
              wm(i,j) = wm(i,j) + Atm(1)%delp(i,j,k) * ( Atm(1)%q(i,j,k,1) +    &
                                                         Atm(1)%q(i,j,k,2) +    &
                                                         Atm(1)%q(i,j,k,3) )
           enddo
        enddo
     enddo

!----------------------
! Horizontal sum:
!----------------------
     value = 0.
     do j=jsc,jec
        do i=isc,iec
           value = value + wm(i,j)*area(i,j)
        enddo
     enddo
     value = value/grav

   case default
     value = 0.0
   end select

 end subroutine get_stock_pe 

end module atmosphere_mod


module fv_physics_mod

!-----------------------------------------------------------------------
!
!  Interface for Cubed_sphere FV dynamics with GFDL atmospheric physics
!  History: modified by SJL based on Memphis release
!-----------------------------------------------------------------------

!-----------------
! FMS modules:
!-----------------
use atmos_co2_mod,         only: atmos_co2_rad, co2_radiation_override
use constants_mod,         only: rdgas, grav, rvgas, WTMAIR, WTMCO2
use time_manager_mod,      only: time_type, get_time, operator(-)
use fms_mod,               only: error_mesg, FATAL, write_version_number,clock_flag_default
use physics_driver_mod,    only: physics_driver_init, physics_driver_end,   &
                                 physics_driver_moist_init, &
                                 physics_driver_moist_end, &
                                 physics_driver_down, physics_driver_up, surf_diff_type, &
                                 physics_driver_down_time_vary, &
                                 physics_driver_up_time_vary,  &
                                 physics_driver_down_endts,  &
                                 physics_driver_up_endts, &
                                 physics_driver_restart
use field_manager_mod,     only: MODEL_ATMOS
use tracer_manager_mod,    only: get_tracer_index, NO_TRACER
use diag_manager_mod,      only: diag_send_complete
use mpp_domains_mod,       only: mpp_global_sum, BITWISE_EXACT_SUM
use mpp_mod,               only: mpp_error, mpp_clock_id,  mpp_clock_begin,  &
                                 mpp_clock_end, CLOCK_MODULE_DRIVER, mpp_pe
#ifdef ATMOS_NUDGE
use atmos_nudge_mod,       only: atmos_nudge_init, atmos_nudge_end
#endif

!-----------------
! FV core modules:
!-----------------
use fv_grid_tools_mod,     only: area
use fv_grid_utils_mod,     only: g_sum
use fv_arrays_mod,         only: fv_atmos_type
use fv_control_mod,        only: npx, npy, npz, ncnst, pnats, domain
use fv_eta_mod,            only: get_eta_level
use fv_update_phys_mod,    only: fv_update_phys, del2_phys
use fv_sg_mod,             only: fv_dry_conv, fv_olr, fv_abs_sw, irad
use fv_mp_mod,             only: gid, numthreads
use fv_timing_mod,         only: timing_on, timing_off

implicit none
private

public  fv_physics_down, fv_physics_up, fv_physics_init, fv_physics_end
public  surf_diff_type, fv_physics_restart

!-----------------------------------------------------------------------

   real, allocatable, dimension(:,:,:)   :: t_phys
   real, allocatable, dimension(:,:,:,:) :: q_phys
   real, allocatable, dimension(:,:,:)   :: u_dt, v_dt, t_dt
   real, allocatable, dimension(:,:,:,:) :: q_dt  ! potentially a huge array
   real, allocatable, dimension(:,:,:)   :: p_full, z_full, p_half, z_half
   logical :: do_atmos_nudge
   real    :: zvir, rrg, ginv
   integer :: id_fv_physics_down, id_fv_physics_up, id_fv_update_phys
   integer :: isc, iec, jsc, jec, ngc, nt_prog
   integer :: isd, ied, jsd, jed
   integer :: isw, iew, jsw, jew  ! window start/end in global index space
   integer :: nx_win, ny_win      ! iew-isw+1, jew-jsw+1 (window sizes)
   integer :: nx_dom, ny_dom      ! ie-is+1, je-js+1 (compute domain sizes)
   integer :: sphum
   integer :: ny_per_thread


!---- version number -----
   character(len=128) :: version = '$Id: fv_physics.F90,v 17.0.4.1.2.1.2.6 2010/05/24 18:09:47 rab Exp $'
   character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains


  subroutine fv_physics_init (Atm, axes, Time, window, Surf_diff)
    type(fv_atmos_type), intent(inout) :: Atm(:)
!-----------------------------------------------------------------------
!   axes      = array of axis indices for diagnostics (x,y,pf,ph)
!   Time      = current time (time_type)
!-----------------------------------------------------------------------
    integer,               intent(in)    :: axes(4)
    integer,               intent(in)    :: window(2)
    type (time_type),      intent(in)    :: Time
    type (surf_diff_type), intent(inout) :: Surf_diff
!-----------------------------------------------------------------------
! Local:
    character(len=132)  :: text
    real, allocatable   :: p_edge(:,:,:)  ! used by atmos_tracer_driver_init

    real    ::  pref(npz+1,2)
    real    :: phalf(npz+1)
    real    :: ps1, ps2
    integer :: i, j, k
    integer :: ios
    character(len=80) evalue

! All tracers are prognostic
    nt_prog = ncnst - pnats

    isc = Atm(1)%isc
    iec = Atm(1)%iec
    jsc = Atm(1)%jsc
    jec = Atm(1)%jec

    ngc = Atm(1)%ng

    isd = isc - ngc
    ied = iec + ngc
    jsd = jsc - ngc
    jed = jec + ngc

    zvir = rvgas/rdgas - 1.
    ginv = 1./ grav
    rrg  = rdgas / grav        

!----- write version to logfile --------
    call write_version_number (version,tagname)

! Specific humidity is assumed to be q(:,:,:,1)
    sphum = get_tracer_index (MODEL_ATMOS, 'sphum' )
    if(sphum /= 1) call error_mesg('fv_physics_init:','sphum /= 1', FATAL)

!---------- reference profile -----------
    ps1 = 101325.
    ps2 =  81060.
    pref(npz+1,1) = ps1
    pref(npz+1,2) = ps2
    call get_eta_level ( npz, ps1, pref(1,1), phalf, Atm(1)%ak, Atm(1)%bk )
    call get_eta_level ( npz, ps2, pref(1,2), phalf, Atm(1)%ak, Atm(1)%bk )

    allocate (  u_dt(isd:ied,jsd:jed, npz) )
    allocate (  v_dt(isd:ied,jsd:jed, npz) )
    allocate (  t_dt(isc:iec,jsc:jec, npz) )
    allocate (  q_dt(isc:iec,jsc:jec, npz, nt_prog) )
    allocate (p_edge(isc:iec,jsc:jec, npz+1))

! For phys_filter:
    if ( Atm(1)%tq_filter ) then
         allocate (  t_phys(isd:ied,jsd:jed,npz) )
         allocate (  q_phys(isd:ied,jsd:jed,npz,nt_prog) )
    endif

    allocate (    fv_olr(isc:iec,jsc:jec) )
    allocate ( fv_abs_sw(isc:iec,jsc:jec) )
    fv_olr    = 0.
    fv_abs_sw = 0.

!------- pressure at model layer interfaces -----
    do k=1,npz+1
       do j=jsc,jec
          do i=isc,iec
             p_edge(i,j,k) = Atm(1)%pe(i,k,j)
          enddo
       enddo
    enddo
!---------- initialize physics -------

    call physics_driver_init(Time, Atm(1)%grid(isc:iec+1,jsc:jec+1,1),             &
                                   Atm(1)%grid(isc:iec+1,jsc:jec+1,2),             &
                             axes, pref, Atm(1)%q(isc:iec,jsc:jec,1:npz,1:ncnst),  &
                             Surf_diff,  p_edge )
    deallocate ( p_edge )

!--- initialize nudging module ---
#ifdef ATMOS_NUDGE
    call atmos_nudge_init ( Time, axes(1:3), flag=do_atmos_nudge )
#endif

! physics window
    nx_dom = iec - isc + 1
    ny_dom = jec - jsc + 1

    nx_win = window(1)
    ny_win = window(2)

    if( nx_win.LE.0 ) nx_win = nx_dom
    if( ny_win.LE.0 ) ny_win = ny_dom

! Consistency check:
    if( mod(nx_dom,nx_win).NE.0 )then
        write( text,'(a,2i4)' )'FV_PHYSICS_INIT: atmosphere_nml problem,'// &
             ' physics_window must divide domain size: ',  nx_win, nx_dom
        call mpp_error( FATAL, text )
    end if
    if( mod(ny_dom,ny_win).NE.0 )then
        write( text,'(a,2i4)' )'FV_PHYSICS_INIT: atmosphere_nml problem,'// &
             ' physics_window must divide domain size: ',  ny_win, ny_dom
        call mpp_error( FATAL, text )
    end if

    allocate( p_full(nx_win,ny_win,npz) )
    allocate( z_full(nx_win,ny_win,npz) )
    allocate( p_half(nx_win,ny_win,npz+1) )
    allocate( z_half(nx_win,ny_win,npz+1) )

!MPP clocks
    id_fv_physics_down = mpp_clock_id( 'FV_PHYSICS_DOWN', &
         flags=clock_flag_default, grain=CLOCK_MODULE_DRIVER )
    id_fv_physics_up = mpp_clock_id( 'FV_PHYSICS_UP', &
         flags=clock_flag_default, grain=CLOCK_MODULE_DRIVER )
    id_fv_update_phys = mpp_clock_id( 'FV_UPDATE_PHYS', &
         flags=clock_flag_default, grain=CLOCK_MODULE_DRIVER )

    ny_per_thread = ny_win/numthreads
    if (mod(ny_win, numthreads ) /= 0) then
      call error_mesg ('physics_driver_down', &
         'The number of OpenMP threads must be an integral multiple &
                  &of the number of rows in the physics window', FATAL)
    endif

  end subroutine fv_physics_init



  subroutine fv_physics_down(Atm, dt_phys, Time_prev, Time, Time_next, &
                             frac_land,   albedo,            &
                             albedo_vis_dir, albedo_nir_dir, &
                             albedo_vis_dif, albedo_nir_dif, &
                             rough_vel,   t_surf,            &
                             u_star, b_star, q_star,         &
                             dtau_du, dtau_dv, tau_x, tau_y, &
                             flux_sw,                        &
                             flux_sw_dir, flux_sw_dif,       &
                             flux_sw_down_vis_dir,           &
                             flux_sw_down_vis_dif,           &
                             flux_sw_down_total_dir,         &
                             flux_sw_down_total_dif,         &
                             flux_sw_vis, flux_sw_vis_dir,   &
                             flux_sw_vis_dif,                &
                             flux_lw, coszen,                &
                             gust, Surf_diff )
!-----------------------------------------------------------------------
!
!   Time_prev =  time at the previous time level, tau-1 (time_type)
!   Time      =  time at the current time level,  tau   (time_type)
!   Time_next =  time at the next time level,     tau+1 (time_type)
!
!   NOTE: for a two time level scheme (e.g., forward-backward scheme)
!         Time_prev = Time.
!
!-----------------------------------------------------------------------
    type(time_type),     intent(in) :: Time_prev, Time, Time_next
    type(fv_atmos_type), intent(inout) :: Atm(:)
    real,                intent(in) :: dt_phys
    real, intent(in), dimension(isc:iec,jsc:jec):: frac_land,  albedo, &
                                       albedo_vis_dir, albedo_nir_dir, &
                                       albedo_vis_dif, albedo_nir_dif, &
                                       rough_vel, t_surf, u_star,      &
                                       b_star, q_star, dtau_du, dtau_dv

    type(surf_diff_type), intent(inout) :: Surf_diff
    real, intent(inout), dimension(isc:iec,jsc:jec):: tau_x, tau_y
    real, intent(out),   dimension(isc:iec,jsc:jec):: flux_sw, &
                                   flux_sw_dir, flux_sw_dif,   &
                                   flux_sw_down_vis_dir,       &
                                   flux_sw_down_vis_dif,       &
                                   flux_sw_down_total_dir,     &
                                   flux_sw_down_total_dif,     &
                                   flux_sw_vis,                &
                                   flux_sw_vis_dir,            &
                                   flux_sw_vis_dif, flux_lw, coszen, gust
!-----------------------------------------------------------------------
    real :: gavg_rrv(nt_prog)
    integer:: iq, idx
    integer :: is, ie, js, je
    real    :: dt 
    integer :: sec, day


!----------------------------------------------------------------------
! obtain pressure-weighted global mean co2 dry volume mixing ratio for
! use by radiation package.
!----------------------------------------------------------------------
    gavg_rrv = 0.
! check to override predicted global pressure-weighted rad co2
    idx = get_tracer_index(MODEL_ATMOS, 'co2')
    if(idx /= NO_TRACER .and. co2_radiation_override) then
      call atmos_co2_rad(Time, gavg_rrv(idx))
    elseif (idx /= NO_TRACER) then
      call compute_g_avg(gavg_rrv, 'co2', Atm(1)%pe, Atm(1)%q)
    endif

!---------------------------------------------------------------------
! compute the physics time step (from tau-1 to tau+1).
!---------------------------------------------------------------------
    call get_time (Time_next-Time_prev, sec, day)
    dt = real(sec+day*86400)
 
!---------------------------------------------------------------------
! call physics_driver_down_time_vary to do the time-dependent, spatially
! independent calculations before entering windows / threads loop. 
!--------------------------------------------------------------------- 
    call physics_driver_down_time_vary (Time, Time_next, gavg_rrv, dt)


    if ( Atm(1)%fv_sg_adj > 0 ) then
         call fv_dry_conv( isd, ied, jsd, jed, isc, iec, jsc, jec, npz, nt_prog, dt_phys,   &
                           Atm(1)%fv_sg_adj, Atm(1)%delp, Atm(1)%pe, Atm(1)%peln,  &
                           Atm(1)%pkz, Atm(1)%pt, Atm(1)%q, Atm(1)%ua, Atm(1)%va,  &
                           Atm(1)%hydrostatic, Atm(1)%w, Atm(1)%delz, u_dt, v_dt, t_dt, q_dt )
    else
         u_dt = 0.
         v_dt = 0.
         t_dt = 0.
         q_dt = 0.
    endif

    call mpp_clock_begin(id_fv_physics_down)

  if ( Atm(1)%tq_filter ) then
     
    t_phys(:,:,:) = Atm(1)%pt(:,:,:)
    call del2_phys(t_phys, Atm(1)%delp, 0.2, npx, npy, npz, isc, iec, jsc, jec, &
                   isd, ied, jsd, jed, ngc)
     
    q_phys(:,:,:,:) = Atm(1)%q(:,:,:,:)
    do iq=1,nt_prog
       call del2_phys(q_phys(:,:,:,iq), Atm(1)%delp, 0.2, npx, npy, npz, isc, iec, jsc, jec, &
                   isd, ied, jsd, jed, ngc)
    enddo

    do js = jsc, jec, ny_win
      je = js + ny_win - 1
      do is = isc, iec, nx_win
        ie = is + nx_win - 1

          call compute_p_z(npz, is, js, nx_win, ny_win, Atm(1)%phis, t_phys, &
                           q_phys, Atm(1)%delp, Atm(1)%pe, Atm(1)%peln,         &
                           Atm(1)%delz, Atm(1)%phys_hydrostatic)

!$OMP parallel do default(shared) private(isw, iew, jsw, jew )
         do jsw = js, je, ny_per_thread
           jew = jsw + ny_per_thread - 1
           isw = is
           iew = ie

          call physics_driver_down( isw-isc+1, iew-isc+1, jsw-jsc+1, jew-jsc+1, &
                   Time_prev, Time, Time_next                              , &
                   Atm(1)%agrid(isw:iew,jsw:jew,2)                         , &
                   Atm(1)%agrid(isw:iew,jsw:jew,1)                         , &
                   area(isw:iew,jsw:jew), p_half,  p_full, z_half,  z_full , &
!   p_half(1:1,1:1,:) is extra dummy argument in interface required/used to for 
!   grey radiation routine when using b-grid core
                   p_half(1:1,1:1,:)                                       , &
                   Atm(1)%ua(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%va(isw:iew,jsw:jew,:)                            , &
                      t_phys(isw:iew,jsw:jew,:)                            , &
                      q_phys(isw:iew,jsw:jew,:,1)                          , &
                      q_phys(isw:iew,jsw:jew,:,:)                          , &
                   Atm(1)%ua(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%va(isw:iew,jsw:jew,:)                            , &
                      t_phys(isw:iew,jsw:jew,:)                            , &
                      q_phys(isw:iew,jsw:jew,:,1)                          , &
                      q_phys(isw:iew,jsw:jew,:,:)                          , &
                   frac_land(isw:iew,jsw:jew), rough_vel(isw:iew,jsw:jew)  , &
                   albedo   (isw:iew,jsw:jew)                              , &
                   albedo_vis_dir(isw:iew,jsw:jew)                         , &
                   albedo_nir_dir(isw:iew,jsw:jew)                         , &
                   albedo_vis_dif(isw:iew,jsw:jew)                         , &
                   albedo_nir_dif(isw:iew,jsw:jew)                         , &
                   t_surf  (isw:iew,jsw:jew),  u_star(isw:iew,jsw:jew)     , &
                   b_star  (isw:iew,jsw:jew),  q_star(isw:iew,jsw:jew)     , &
                   dtau_du (isw:iew,jsw:jew), dtau_dv(isw:iew,jsw:jew)     , &
                   tau_x   (isw:iew,jsw:jew),   tau_y(isw:iew,jsw:jew)     , &
                   u_dt    (isw:iew,jsw:jew,:),  v_dt(isw:iew,jsw:jew,:)   , &
                   t_dt    (isw:iew,jsw:jew,:),  q_dt(isw:iew,jsw:jew,:,1) , &
                   q_dt    (isw:iew,jsw:jew,:,1:nt_prog)                   , &
                   flux_sw               (isw:iew,jsw:jew)                 , &
                   flux_sw_dir           (isw:iew,jsw:jew)                 , &
                   flux_sw_dif           (isw:iew,jsw:jew)                 , &
                   flux_sw_down_vis_dir  (isw:iew,jsw:jew)                 , &
                   flux_sw_down_vis_dif  (isw:iew,jsw:jew)                 , &
                   flux_sw_down_total_dir(isw:iew,jsw:jew)                 , &
                   flux_sw_down_total_dif(isw:iew,jsw:jew)                 , &
                   flux_sw_vis           (isw:iew,jsw:jew)                 , &
                   flux_sw_vis_dir       (isw:iew,jsw:jew)                 , &
                   flux_sw_vis_dif       (isw:iew,jsw:jew)                 , &
                   flux_lw               (isw:iew,jsw:jew)                 , &
                   coszen                (isw:iew,jsw:jew)                 , &
                   gust                  (isw:iew,jsw:jew)                 , &
                   Surf_diff,   gavg_rrv )
         enddo
       enddo
    enddo

    call physics_driver_down_endts (is-isc+1, js-jsc+1)

  else

    do js = jsc, jec, ny_win
      je = js + ny_win - 1
      do is = isc, iec, nx_win
        ie = is + nx_win - 1

          call compute_p_z(npz, is, js, nx_win, ny_win, Atm(1)%phis, Atm(1)%pt, &
                           Atm(1)%q, Atm(1)%delp, Atm(1)%pe, Atm(1)%peln,         &
                           Atm(1)%delz, Atm(1)%phys_hydrostatic)

!$OMP parallel do default(shared) private(isw, iew, jsw, jew )
         do jsw = js, je, ny_per_thread
           jew = jsw + ny_per_thread - 1
           isw = is
           iew = ie

          call physics_driver_down( isw-isc+1, iew-isc+1, jsw-jsc+1, jew-jsc+1, &
                   Time_prev, Time, Time_next                              , &
                   Atm(1)%agrid(isw:iew,jsw:jew,2)                         , &
                   Atm(1)%agrid(isw:iew,jsw:jew,1)                         , &
                   area(isw:iew,jsw:jew),  &
                   p_half(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:),  &
                   p_full(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:),  &
                   z_half(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:), &
                   z_full(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:) , &
!   p_half(1:1,1:1,:) is extra dummy argument in interface required/used to for 
!   grey radiation routine when using b-grid core
                   p_half(isw-is+1:isw-is+1,jsw-js+1:jsw-js+1,:)                                       , &
                   Atm(1)%ua(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%va(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%pt(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%q (isw:iew,jsw:jew,:,1)                          , &
                   Atm(1)%q (isw:iew,jsw:jew,:,:)                          , &
                   Atm(1)%ua(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%va(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%pt(isw:iew,jsw:jew,:)                            , &
                   Atm(1)%q (isw:iew,jsw:jew,:,1)                          , &
                   Atm(1)%q (isw:iew,jsw:jew,:,:)                          , &
                   frac_land(isw:iew,jsw:jew), rough_vel(isw:iew,jsw:jew)  , &
                   albedo   (isw:iew,jsw:jew)                              , &
                   albedo_vis_dir(isw:iew,jsw:jew)                         , &
                   albedo_nir_dir(isw:iew,jsw:jew)                         , &
                   albedo_vis_dif(isw:iew,jsw:jew)                         , &
                   albedo_nir_dif(isw:iew,jsw:jew)                         , &
                   t_surf  (isw:iew,jsw:jew),  u_star(isw:iew,jsw:jew)     , &
                   b_star  (isw:iew,jsw:jew),  q_star(isw:iew,jsw:jew)     , &
                   dtau_du (isw:iew,jsw:jew), dtau_dv(isw:iew,jsw:jew)     , &
                   tau_x   (isw:iew,jsw:jew),   tau_y(isw:iew,jsw:jew)     , &
                   u_dt    (isw:iew,jsw:jew,:),  v_dt(isw:iew,jsw:jew,:)   , &
                   t_dt    (isw:iew,jsw:jew,:),  q_dt(isw:iew,jsw:jew,:,1) , &
                   q_dt    (isw:iew,jsw:jew,:,1:nt_prog)                   , &
                   flux_sw               (isw:iew,jsw:jew)                 , &
                   flux_sw_dir           (isw:iew,jsw:jew)                 , &
                   flux_sw_dif           (isw:iew,jsw:jew)                 , &
                   flux_sw_down_vis_dir  (isw:iew,jsw:jew)                 , &
                   flux_sw_down_vis_dif  (isw:iew,jsw:jew)                 , &
                   flux_sw_down_total_dir(isw:iew,jsw:jew)                 , &
                   flux_sw_down_total_dif(isw:iew,jsw:jew)                 , &
                   flux_sw_vis           (isw:iew,jsw:jew)                 , &
                   flux_sw_vis_dir       (isw:iew,jsw:jew)                 , &
                   flux_sw_vis_dif       (isw:iew,jsw:jew)                 , &
                   flux_lw               (isw:iew,jsw:jew)                 , &
                   coszen                (isw:iew,jsw:jew)                 , &
                   gust                  (isw:iew,jsw:jew)                 , &
                   Surf_diff,   gavg_rrv )
         enddo
       enddo
    enddo

    call physics_driver_down_endts (is-isc+1, js-jsc+1)


  endif !(Atm(1)%tq_filter)

    call mpp_clock_end(id_fv_physics_down)

  end subroutine fv_physics_down



  subroutine fv_physics_up( Atm, dt_phys, Time_prev, Time, Time_next, &
                            frac_land, Surf_diff, lprec, fprec, gust, &
                            u_star, b_star, q_star )
!-----------------------------------------------------------------------
!
!   Time_prev =  time at the previous time level, tau-1 (time_type)
!   Time      =  time at the current time level,  tau   (time_type)
!   Time_next =  time at the next time level,     tau+1 (time_type)
!
!   NOTE: for a two time level scheme (e.g., forward-backward scheme)
!         Time_prev = Time.
!
!-----------------------------------------------------------------------
    type(time_type),     intent(in)    :: Time_prev, Time, Time_next
    type(fv_atmos_type), intent(inout) :: Atm(:)
    type(surf_diff_type),intent(inout) :: Surf_diff
    real,                intent(in)    :: dt_phys
    real, intent(in),    dimension(isc:iec,jsc:jec) :: frac_land
    real, intent(inout), dimension(isc:iec,jsc:jec) :: gust
    real, intent(out),   dimension(isc:iec,jsc:jec) :: lprec, fprec
    real, intent(in),    dimension(isc:iec,jsc:jec) :: u_star, b_star, q_star
    integer seconds, days
    real gmt1, gmt2
    integer :: is, ie, js, je
    integer :: sec, day
    real    :: dt
    type(time_type) :: Time_step

    call mpp_clock_begin(id_fv_physics_up)

!---------------------------------------------------------------------
!    compute the physics time step (from tau-1 to tau+1).
!---------------------------------------------------------------------
    call get_time (Time_next-Time_prev, sec, day)
    dt = real(sec+day*86400)
 
    call physics_driver_up_time_vary (Time, dt)
 

  if ( Atm(1)%tq_filter ) then

    do js = jsc, jec, ny_win
      je = js + ny_win - 1
      do is = isc, iec, nx_win
        ie = is + nx_win - 1

         call compute_p_z(npz, is, js, nx_win, ny_win, Atm(1)%phis, t_phys,  &
                          q_phys,  Atm(1)%delp, Atm(1)%pe, Atm(1)%peln,      &
                          Atm(1)%delz,  Atm(1)%hydrostatic)
         call physics_driver_moist_init (nx_win, ny_win,  npz, nt_prog) 

!$OMP parallel do default(shared) private(isw, iew, jsw, jew )
         do jsw = js, je, ny_per_thread
           jew = jsw + ny_per_thread - 1
           isw = is
           iew = ie
          call physics_driver_up( isw-isc+1, iew-isc+1, jsw-jsc+1, jew-jsc+1, &
                                  Time_prev, Time, Time_next             , &
                                  Atm(1)%agrid(isw:iew,jsw:jew,2)        , &
                                  Atm(1)%agrid(isw:iew,jsw:jew,1)        , &
                                  area(isw:iew,jsw:jew),                   &
              p_half(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:), &
              p_full(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:)  , &
              z_half(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:),  &
              z_full (isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:), &
                                  Atm(1)%omga(isw:iew,jsw:jew,:)         , &
                                  Atm(1)%ua(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%va(isw:iew,jsw:jew,:)           , &
!                                 Atm(1)%w(isw:iew,jsw:jew,:)            , &
                                    t_phys(isw:iew,jsw:jew,:)            , &
                                    q_phys(isw:iew,jsw:jew,:,1)          , &
                                    q_phys(isw:iew,jsw:jew,:,1:nt_prog)  , &
                                  Atm(1)%ua(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%va(isw:iew,jsw:jew,:)           , &
                                     t_phys(isw:iew,jsw:jew,:)           , &
                                     q_phys(isw:iew,jsw:jew,:,1)         , &
                                     q_phys(isw:iew,jsw:jew,:,1:nt_prog) , &
                                  frac_land(isw:iew,jsw:jew)             , &
                                  u_star   (isw:iew,jsw:jew)             , &
                                  b_star   (isw:iew,jsw:jew)             , &
                                  q_star   (isw:iew,jsw:jew)             , &
                                  u_dt     (isw:iew,jsw:jew,:)           , &
                                  v_dt     (isw:iew,jsw:jew,:)           , &
                                  t_dt     (isw:iew,jsw:jew,:)           , &
                                  q_dt     (isw:iew,jsw:jew,:,1)         , &
                                  q_dt     (isw:iew,jsw:jew,:,1:nt_prog) , &
                                  Surf_diff                              , &
                                  lprec    (isw:iew,jsw:jew)             , &
                                  fprec    (isw:iew,jsw:jew)             , &
                                  gust     (isw:iew,jsw:jew)             , &
                                  hydrostatic=Atm(1)%hydrostatic         , &
                                  phys_hydrostatic=Atm(1)%phys_hydrostatic )
         end do
          call physics_driver_moist_end
       enddo
    enddo

    if(numthreads>1) Then
       Time_step = Time_next - Time
       call diag_send_complete(Time_step)
    endif

       call physics_driver_up_endts (is-isc+1, js-jsc+1)

  else

    do js = jsc, jec, ny_win
      je = js + ny_win - 1
      do is = isc, iec, nx_win
        ie = is + nx_win - 1

          call compute_p_z(npz, is , js , nx_win, ny_win, Atm(1)%phis, Atm(1)%pt,  &
                           Atm(1)%q, Atm(1)%delp, Atm(1)%pe, Atm(1)%peln,      &
                           Atm(1)%delz,  Atm(1)%hydrostatic)
         call physics_driver_moist_init (nx_win, ny_win,  npz, nt_prog) 

!$OMP parallel do default(shared) private(isw, iew, jsw, jew )
         do jsw = js, je, ny_per_thread
           jew = jsw + ny_per_thread - 1
           isw = is
           iew = ie
          call physics_driver_up( isw-isc+1, iew-isc+1, jsw-jsc+1, jew-jsc+1, &
                                  Time_prev, Time, Time_next             , &
                                  Atm(1)%agrid(isw:iew,jsw:jew,2)        , &
                                  Atm(1)%agrid(isw:iew,jsw:jew,1)        , &
                                  area(isw:iew,jsw:jew), &
              p_half(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:), &
              p_full(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:)  , &
              z_half(isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:),  &
              z_full (isw-is+1:iew-is+1,jsw-js+1:jew-js+1,:), &
                                  Atm(1)%omga(isw:iew,jsw:jew,:)         , &
                                  Atm(1)%ua(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%va(isw:iew,jsw:jew,:)           , &
!                                  Atm(1)%w(isw:iew,jsw:jew,:)            , &
                                  Atm(1)%pt(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%q(isw:iew,jsw:jew,:,1)          , &
                                  Atm(1)%q(isw:iew,jsw:jew,:,1:nt_prog)  , &
                                  Atm(1)%ua(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%va(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%pt(isw:iew,jsw:jew,:)           , &
                                  Atm(1)%q(isw:iew,jsw:jew,:,1)          , &
                                  Atm(1)%q(isw:iew,jsw:jew,:,1:nt_prog)  , &
                                  frac_land(isw:iew,jsw:jew)             , &
                                  u_star   (isw:iew,jsw:jew)             , &
                                  b_star   (isw:iew,jsw:jew)             , &
                                  q_star   (isw:iew,jsw:jew)             , &
                                  u_dt     (isw:iew,jsw:jew,:)           , &
                                  v_dt     (isw:iew,jsw:jew,:)           , &
                                  t_dt     (isw:iew,jsw:jew,:)           , &
                                  q_dt     (isw:iew,jsw:jew,:,1)         , &
                                  q_dt     (isw:iew,jsw:jew,:,1:nt_prog) , &
                                  Surf_diff                              , &
                                  lprec    (isw:iew,jsw:jew)             , &
                                  fprec    (isw:iew,jsw:jew)             , &
                                  gust     (isw:iew,jsw:jew)             , &
                                  hydrostatic=Atm(1)%hydrostatic         , &
                                  phys_hydrostatic=Atm(1)%phys_hydrostatic )
         end do
          call physics_driver_moist_end
       enddo
    enddo

    if(numthreads>1) Then
       Time_step = Time_next - Time
       call diag_send_complete(Time_step)
    endif

       call physics_driver_up_endts (is-isc+1, js-jsc+1)


  endif !(Atm(1)%tq_filter)

    call mpp_clock_end(id_fv_physics_up)

    call mpp_clock_begin(id_fv_update_phys)
                                                            call timing_on('update_fv')
    call fv_update_phys( dt_phys,   isc,        iec,         jsc,    jec,   isd,       &
                         ied,       jsd,        jed,         ngc,       nt_prog,       &
                         Atm(1)%u,  Atm(1)%v,   Atm(1)%delp, Atm(1)%pt, Atm(1)%q,      &
                         Atm(1)%ua, Atm(1)%va,  Atm(1)%ps,   Atm(1)%pe, Atm(1)%peln,   &
                         Atm(1)%pk, Atm(1)%pkz, Atm(1)%ak,   Atm(1)%bk, Atm(1)%phis,   &
                         Atm(1)%u_srf, Atm(1)%v_srf, Atm(1)%ts, Atm(1)%delz, Atm(1)%hydrostatic, &
                         u_dt, v_dt, t_dt, q_dt, .true., Time_next, Atm(1)%nudge )
                                                            call timing_off('update_fv')
    call mpp_clock_end(id_fv_update_phys)

#ifdef FV_MONITOR
! fv_physics monitor:
    call get_time (time, seconds, days)
! SJL
    if ( seconds == 0 ) then
       fv_olr = fv_olr / real(irad)
       fv_abs_sw = fv_abs_sw / real(irad)
       gmt1 = g_sum(fv_olr,    isc, iec, jsc, jec, ngc, area, 1)
       gmt2 = g_sum(fv_abs_sw, isc, iec, jsc, jec, ngc, area, 1)
       if(gid==0) write(*,*) 'OLR=', gmt1, 'SW_abs=', gmt2, 'Net=', gmt2-gmt1, 'steps=', irad
       fv_olr = 0.
       fv_abs_sw = 0.
       irad = 0
    endif
#endif

  end subroutine fv_physics_up



  subroutine fv_physics_end (Atm, Time)
    type(fv_atmos_type), intent(inout) :: Atm(:)
    type(time_type), intent(in) :: Time
!                                 NOTE: this is not the dynamics time
    call physics_driver_end (Time)
#ifdef ATMOS_NUDGE
    call atmos_nudge_end
#endif

    deallocate ( u_dt )
    deallocate ( v_dt )
    deallocate ( t_dt )
    deallocate ( q_dt )
    deallocate ( p_full )
    deallocate ( z_full )
    deallocate ( p_half )
    deallocate ( z_half )

    if ( Atm(1)%tq_filter ) then
         deallocate ( t_phys )
         deallocate ( q_phys )
    endif

    deallocate ( fv_olr )
    deallocate ( fv_abs_sw )

  end subroutine fv_physics_end



  !#######################################################################
  ! <SUBROUTINE NAME="fv_physics_restart">
  ! <DESCRIPTION>
  !  Write out restart files registered through register_restart_file
  ! </DESCRIPTION>
  subroutine fv_physics_restart(timestamp)
    character(len=*),  intent(in) :: timestamp

    call physics_driver_restart(timestamp)

  end subroutine fv_physics_restart
  ! </SUBROUTINE>  



  subroutine compute_p_z (nlev, istart, jstart, isiz, jsiz, phis, pt, q,   &
                          delp, pe, peln, delz, hydrostatic)
    integer, intent(in):: nlev
    integer, intent(in):: istart, jstart, isiz, jsiz
    real,    intent(in):: phis(isd:ied,jsd:jed)
    real,    intent(in)::   pt(isd:ied,jsd:jed,nlev)
    real,    intent(in)::    q(isd:ied,jsd:jed,nlev,sphum)
    real,    intent(in):: delp(isd:ied,jsd:jed,nlev)
    real,    intent(in)::   pe(isc-1:iec+1,nlev+1,jsc-1:jec+1)
    real,    intent(in):: peln(isc  :iec,  nlev+1,jsc  :jec)
    real,    intent(in):: delz(isc:iec,jsc:jec,nlev)
    logical, intent(in):: hydrostatic
! local
    integer i,j,k,id,jd
    real    tvm

!----------------------------------------------------
! Compute pressure and height at full and half levels
!----------------------------------------------------
    do j=1,jsiz
       jd = j + jstart - 1
       do i=1,isiz
          id = i + istart - 1
          z_half(i,j,nlev+1) = phis(id,jd) * ginv
       enddo
    end do

    do k=1,nlev+1
       do j=1,jsiz
          jd = j + jstart - 1
          do i=1,isiz
             id = i + istart - 1
             p_half(i,j,k) = pe(id,k,jd)
          enddo
       enddo
    enddo

    if ( hydrostatic ) then
      do k=nlev,1,-1
         do j=1,jsiz
            jd = j + jstart - 1
            do i=1,isiz
               id = i + istart - 1
               tvm = rrg*pt(id,jd,k)*(1.+zvir*q(id,jd,k,sphum))
               p_full(i,j,k) = delp(id,jd,k)/(peln(id,k+1,jd)-peln(id,k,jd))
               z_full(i,j,k) = z_half(i,j,k+1) + tvm*(1.-p_half(i,j,k)/p_full(i,j,k))
               z_half(i,j,k) = z_half(i,j,k+1) + tvm*(peln(id,k+1,jd)-peln(id,k,jd))
            enddo
         enddo
      enddo
    else
!--------- Non-Hydrostatic option ------------------------------------------
      do k=nlev,1,-1
         do j=1,jsiz
            jd = j + jstart - 1
            do i=1,isiz
               id = i + istart - 1
               p_full(i,j,k) = delp(id,jd,k)/(peln(id,k+1,jd)-peln(id,k,jd))
               z_half(i,j,k) = z_half(i,j,k+1) - delz(id,jd,k)
               z_full(i,j,k) = 0.5*(z_half(i,j,k) + z_half(i,j,k+1))
            enddo
         enddo
      enddo
!--------- Non-Hydrostatic option ------------------------------------------
    endif

  end subroutine compute_p_z



  subroutine compute_g_avg(rrv, tracer_name, pe, q)
    real,          intent(inout) :: rrv(nt_prog)
    character(len=*), intent(in) :: tracer_name
    real, intent(in):: pe(isc-1:iec+1,npz+1,jsc-1:jec+1)
    real, intent(in)::  q(isd:ied,jsd:jed,npz, ncnst)
!------------------------------------------------------------
    real psfc_sum(isc:iec,jsc:jec,1), qp_sum(isc:iec,jsc:jec,1)
    real qp, s1, s2
    integer j, i, k, idx

    psfc_sum = 0.
    qp_sum = 0.
    idx = get_tracer_index(MODEL_ATMOS, trim(tracer_name))

    if(idx /= NO_TRACER) then
       do j=jsc,jec
          do i=isc,iec
             psfc_sum(i,j,1) = pe(i,npz+1,j)*area(i,j)
!---------------------------------------------------------------------
!  define pressure-weighted column mean value of dry mass mixing
!  ratio  for tracer idx. assumption is that the tracer field q_phys
!  is a moist mass mixing ratio. convert to dry mass mixing ratio by
!  dividing by (1 - qh2o).
!---------------------------------------------------------------------
             qp = 0.0
             do k=1,npz
! old formulation
!                qp = qp + q(i,j,k,idx)*(pe(i,k+1,j) - pe(i,k,j))
                qp = qp + (q(i,j,k,idx) / (1.0 - q_phys(i,j,k,sphum))) &
                                        * (pe(i,k+1,j) - pe(i,k,j))
             enddo
             qp_sum(i,j,1) = qp * area(i,j)
          enddo
       enddo
       s1 = mpp_global_sum(domain, psfc_sum, flags=BITWISE_EXACT_SUM)
       s2 = mpp_global_sum(domain, qp_sum,   flags=BITWISE_EXACT_SUM)
       rrv(idx) = s2 / s1
!---------------------------------------------------------------------
!    convert the tracer dry mass mixing ratio to the dry volume
!    mixing ratio.
!---------------------------------------------------------------------
       if (trim(tracer_name).eq.'co2') then
          rrv(idx) = rrv(idx)*WTMAIR/WTMCO2
       end if
    endif
  
  end subroutine compute_g_avg

end module fv_physics_mod


module a2b_edge_mod

  use fv_grid_utils_mod, only: edge_w, edge_e, edge_s, edge_n, sw_corner, se_corner,  &
                               nw_corner, ne_corner, van2
  use fv_grid_tools_mod, only: dxa, dya, grid_type
  use fv_mp_mod,         only: gid
  implicit none

  real, parameter:: r3 = 1./3.
!----------------------------
! 4-pt Lagrange interpolation
!----------------------------
  real, parameter:: a1 =  0.5625  !  9/16
  real, parameter:: a2 = -0.0625  ! -1/16
!----------------------
! PPM volume mean form:
!----------------------
  real, parameter:: b1 =  7./12.     ! 0.58333333
  real, parameter:: b2 = -1./12.

  private
  public :: a2b_ord2, a2b_ord4

contains

#ifdef TEST_VAND2
  subroutine a2b_ord4(qin, qout, npx, npy, is, ie, js, je, ng, replace)
! use  tp_core_mod,      only: copy_corners
  integer, intent(IN):: npx, npy, is, ie, js, je, ng
  real, intent(INOUT)::  qin(is-ng:ie+ng,js-ng:je+ng)   ! A-grid field
  real, intent(INOUT):: qout(is-ng:ie+ng,js-ng:je+ng)   ! Output  B-grid field
  logical, optional, intent(IN):: replace
  real, parameter:: d1 =  0.375                   !   0.5
  real, parameter:: d2 = -1./24.                  !  -1./6.
  real qx(is:ie+1,js-ng:je+ng)
  integer :: i, j


  if (grid_type < 3) then

!------------------------------------------
! Copy fields to the phantom corner region:
!------------------------------------------
!  call copy_corners(qin, npx, npy, 1)

  do j=js,je+1
     do i=is,ie+1
!SW:
     if ( i==1 .and. j==1 ) goto 123
          if ( i==2 .and. j==1 ) then
               qin(0,-1) = qin(-1,2)
               qin(0, 0) = qin(-1,1)
          endif
          if ( i==1 .and. j==2 ) then
               qin(-1,0) = qin(2,-1)
               qin( 0,0) = qin(1,-1)
          endif
          if ( i==2 .and. j==2 ) then
               qin( 0,0) = qin(4,4)
          endif
!SE:
      if ( i==npx   .and. j==1 ) goto 123
          if ( i==npx-1 .and. j==1 ) then
               qin(npx,-1) = qin(npx+1,2)
               qin(npx, 0) = qin(npx+1,1)
          endif
          if ( i==npx-1 .and. j==2 ) then
               qin(npx,0) = qin(npx-4,4)
          endif
          if ( i==npx   .and. j==2 ) then
               qin(npx+1,0) = qin(npx-2,-1)
               qin(npx,  0) = qin(npx-1,-1)
          endif
!NE:
      if ( i==npx   .and. j==npy   ) goto 123
          if ( i==npx-1 .and. j==npy-1 ) then
               qin(npx,npy) = qin(npx-4,npy-4)
          endif
          if ( i==npx   .and. j==npy-1 ) then
               qin(npx+1,npy) = qin(npx-2,npy+1)
               qin(npx,  npy) = qin(npx-1,npy+1)
          endif
          if ( i==npx-1 .and. j==npy   ) then
               qin(npx,npy+1) = qin(npx+1,npy-2)
               qin(npx,npy  ) = qin(npx+1,npy-1)
          endif
!NW:
      if ( i==1 .and. j==npy   ) goto 123
          if ( i==1 .and. j==npy-1 ) then
               qin(-1,npy) = qin(2,npy+1)
               qin( 0,npy) = qin(1,npy+1)
          endif
          if ( i==2 .and. j==npy-1 ) then
               qin(0,npy) = qin(4,npy-4)
          endif
          if ( i==2 .and. j==npy   ) then
               qin(0,npy+1) = qin(-1,npy-2)
               qin(0,npy  ) = qin(-1,npy-1)
          endif

          qout(i,j) = van2(1, i,j)*qin(i-2,j-2) + van2(2, i,j)*qin(i-1,j-2) +  &  
                      van2(3, i,j)*qin(i  ,j-2) + van2(4, i,j)*qin(i+1,j-2) +  &  
                      van2(5, i,j)*qin(i-2,j-1) + van2(6, i,j)*qin(i-1,j-1) +  &  
                      van2(7, i,j)*qin(i  ,j-1) + van2(8, i,j)*qin(i+1,j-1) +  &  
                      van2(9, i,j)*qin(i-2,j  ) + van2(10,i,j)*qin(i-1,j  ) +  &  
                      van2(11,i,j)*qin(i  ,j  ) + van2(12,i,j)*qin(i+1,j  ) +  &  
                      van2(13,i,j)*qin(i-2,j+1) + van2(14,i,j)*qin(i-1,j+1) +  &  
                      van2(15,i,j)*qin(i  ,j+1) + van2(16,i,j)*qin(i+1,j+1)
123  continue
     enddo
  enddo

    if ( sw_corner ) then
        qout(1,1) = d1*(qin(1, 0) + qin( 0,1) + qin(1,1)) +  &
                    d2*(qin(2,-1) + qin(-1,2) + qin(2,2))
    endif
    if ( se_corner ) then
        qout(npx,1) = d1*(qin(npx-1, 0) + qin(npx-1,1) + qin(npx,  1)) +  & 
                      d2*(qin(npx-2,-1) + qin(npx-2,2) + qin(npx+1,2))
    endif
    if ( ne_corner ) then
        qout(npx,npy) = d1*(qin(npx-1,npy-1) + qin(npx,  npy-1) + qin(npx-1,npy)) +  &
                        d2*(qin(npx-2,npy-2) + qin(npx+1,npy-2) + qin(npx-2,npy+1))
    endif
    if ( nw_corner ) then
        qout(1,npy) = d1*(qin( 0,npy-1) + qin(1,npy-1) + qin(1,npy)) +   &
                      d2*(qin(-1,npy-2) + qin(2,npy-2) + qin(2,npy+1))
    endif

    
 else  ! grid_type>=3

!------------------------
! Doubly periodic domain:
!------------------------
#ifdef TEST_DB
! X-sweep: PPM
    do j=js-2,je+2
       do i=is,ie+1
          qx(i,j) = b1*(qin(i-1,j)+qin(i,j)) + b2*(qin(i-2,j)+qin(i+1,j))
       enddo
    enddo
! Y-sweep: PPM
    do j=js,je+1
       do i=is,ie+1
          qout(i,j) = b1*qx(i,j-1)+qx(i,j) + b2*(qx(i,j-2)+qx(i,j+1))
       enddo
    enddo
#else
!------------------------ 
! Doubly periodic domain:
!------------------------
! X-sweep: PPM
    do j=js-2,je+2
       do i=is,ie+1
          qx(i,j) = b1*(qin(i-1,j)+qin(i,j)) + b2*(qin(i-2,j)+qin(i+1,j))
       enddo
    enddo
! Y-sweep: PPM
    do j=js,je+1
       do i=is-2,ie+2
          qy(i,j) = b1*(qin(i,j-1)+qin(i,j)) + b2*(qin(i,j-2)+qin(i,j+1))
       enddo
    enddo

    do j=js,je+1
       do i=is,ie+1
          qout(i,j) = 0.5*( a1*(qx(i,j-1)+qx(i,j  ) + qy(i-1,j)+qy(i,  j)) +  &
                            a2*(qx(i,j-2)+qx(i,j+1) + qy(i-2,j)+qy(i+1,j)) )
       enddo
    enddo
#endif
 endif

 if ( present(replace) ) then
     if ( replace ) then
          do j=js,je+1
             do i=is,ie+1
                qin(i,j) = qout(i,j)
             enddo
          enddo
     endif
 endif
    
  end subroutine a2b_ord4

#else
  subroutine a2b_ord4(qin, qout, npx, npy, is, ie, js, je, ng, replace)
  integer, intent(IN):: npx, npy, is, ie, js, je, ng
  real, intent(INOUT)::  qin(is-ng:ie+ng,js-ng:je+ng)   ! A-grid field
  real, intent(INOUT):: qout(is-ng:ie+ng,js-ng:je+ng)   ! Output  B-grid field
  logical, optional, intent(IN):: replace
! local: compact 4-pt cubic
  real, parameter:: c1 =  2./3.
  real, parameter:: c2 = -1./6.
! Parabolic spline
! real, parameter:: c1 =  0.75
! real, parameter:: c2 = -0.25
! 6-pt corner interpolation:
  real, parameter:: d1 =  0.375                   !   0.5
  real, parameter:: d2 = -1./24.                  !  -1./6.


  real qx(is:ie+1,js-ng:je+ng)
  real qy(is-ng:ie+ng,js:je+1)
  real qxx(is-ng:ie+ng,js-ng:je+ng)
  real qyy(is-ng:ie+ng,js-ng:je+ng)
  real fx(is:ie), fy(is-2:ie+2,js:je)
  real gratio, qt(npy)
  integer :: i, j, is1, js1, is2, js2, ie1, je1
  integer :: im2, jm2

    im2 = (npx-1)/2
    jm2 = (npy-1)/2

  if (grid_type < 3) then

    is1 = max(1,is-1)
    js1 = max(1,js-1)
    is2 = max(2,is)
    js2 = max(2,js)

    ie1 = min(npx-1,ie+1)
    je1 = min(npy-1,je+1)

! Corners:
#ifdef USE_3PT
   if ( sw_corner ) qout(1,    1) = r3*(qin(1,        1)+qin(1,      0)+qin(0,      1))
   if ( se_corner ) qout(npx,  1) = r3*(qin(npx-1,    1)+qin(npx-1,  0)+qin(npx,    1))
   if ( ne_corner ) qout(npx,npy) = r3*(qin(npx-1,npy-1)+qin(npx,npy-1)+qin(npx-1,npy))
   if ( nw_corner ) qout(1,  npy) = r3*(qin(1,    npy-1)+qin(0,  npy-1)+qin(1,    npy))
#else
! 6-point formular:
    if ( sw_corner ) then
        qout(1,1) = d1*(qin(1, 0) + qin( 0,1) + qin(1,1)) +  &
                    d2*(qin(2,-1) + qin(-1,2) + qin(2,2))
    endif
    if ( se_corner ) then
        qout(npx,1) = d1*(qin(npx-1, 0) + qin(npx-1,1) + qin(npx,  1)) +  &
                      d2*(qin(npx-2,-1) + qin(npx-2,2) + qin(npx+1,2))
    endif
    if ( ne_corner ) then
        qout(npx,npy) = d1*(qin(npx-1,npy-1) + qin(npx,  npy-1) + qin(npx-1,npy)) +  &
                        d2*(qin(npx-2,npy-2) + qin(npx+1,npy-2) + qin(npx-2,npy+1))
    endif
    if ( nw_corner ) then
        qout(1,npy) = d1*(qin( 0,npy-1) + qin(1,npy-1) + qin(1,npy)) +   &
                      d2*(qin(-1,npy-2) + qin(2,npy-2) + qin(2,npy+1))
    endif
#endif

!------------
! X-Interior:
!------------
    do j=max(1,js-2),min(npy-1,je+2)
       do i=max(3,is), min(npx-2,ie+1)
          qx(i,j) = b2*(qin(i-2,j)+qin(i+1,j)) + b1*(qin(i-1,j)+qin(i,j))
       enddo
    enddo

! West Edges:
    if ( is==1 ) then

       do j=max(1,js-2),min(npy-1,je+2)
           gratio = dxa(2,j) / dxa(1,j)
          qx(1,j) = 0.5*((2.+gratio)*(qin(0,j)+qin(1,j))    &
                  - (qin(-1,j)+qin(2,j))) / (1.+gratio)
#ifdef TEST2
! Note: Caused noises in test_case-5 for large n_split
          qx(2,j) = (2.*gratio*(gratio+1.)*qin(1,j)+qin(2,j) -     &
                     gratio*(gratio+0.5)*qx(1,j))/(1.+gratio*(gratio+1.5))
#else
          qx(2,j) = (3.*(gratio*qin(1,j)+qin(2,j)) - (gratio*qx(1,j)+qx(3,j)))/(2.+2.*gratio)
#endif
       enddo

       do j=max(3,js),min(npy-2,je+1)
          qout(1,j) = a2*(qx(1,j-2)+qx(1,j+1)) + a1*(qx(1,j-1)+qx(1,j))
       enddo

       if( js==1 )     qout(1,    2) = c1*(qx(1,1)+qx(1,2))         + c2*(qout(1,1)+qout(1,3))
       if((je+1)==npy) qout(1,npy-1) = c1*(qx(1,npy-2)+qx(1,npy-1)) + c2*(qout(1,npy-2)+qout(1,npy))
    endif

! East Edges:
    if ( (ie+1)==npx ) then

       do j=max(1,js-2),min(npy-1,je+2)
               gratio = dxa(npx-2,j) / dxa(npx-1,j)
          qx(npx  ,j) = 0.5*((2.+gratio)*(qin(npx-1,j)+qin(npx,j))   &
                        - (qin(npx-2,j)+qin(npx+1,j))) / (1.+gratio )
#ifdef TEST2
          qx(npx-1,j) = (2.*gratio*(gratio+1.)*qin(npx-1,j)+qin(npx-2,j) -  &
                         gratio*(gratio+0.5)*qx(npx,j))/(1.+gratio*(gratio+1.5))
#else
          qx(npx-1,j) = (3.*(qin(npx-2,j)+gratio*qin(npx-1,j)) - (gratio*qx(npx,j)+qx(npx-2,j)))/(2.+2.*gratio)
#endif
       enddo

       do j=max(3,js),min(npy-2,je+1)
          qout(npx,j) = a2*(qx(npx,j-2)+qx(npx,j+1)) + a1*(qx(npx,j-1)+qx(npx,j))
       enddo

       if(js==1) qout(npx,2) = c1*(qx(npx,1)+qx(npx,2))+c2*(qout(npx,1)+qout(npx,3))
       if((je+1)==npy)   qout(npx,npy-1) =             &
                         c1*(qx(npx,npy-2)+qx(npx,npy-1))+c2*(qout(npx,npy-2)+qout(npx,npy))
    endif

!------------
! Y-Interior:
!------------
    do j=max(3,js),min(npy-2,je+1)
       do i=max(1,is-2), min(npx-1,ie+2)
          qy(i,j) = b2*(qin(i,j-2)+qin(i,j+1)) + b1*(qin(i,j-1)+qin(i,j))
       enddo
    enddo

! South Edges:
    if ( js==1 ) then

       do i=max(1,is-2),min(npx-1,ie+2)
           gratio = dya(i,2) / dya(i,1)
          qy(i,1) = 0.5*((2.+gratio)*(qin(i,0)+qin(i,1))   &
                  - (qin(i,-1)+qin(i,2))) / (1.+gratio )
#ifdef TEST2
          qy(i,2) = (2.*gratio*(gratio+1.)*qin(i,1)+qin(i,2) -     &
                     gratio*(gratio+0.5)*qy(i,1))/(1.+gratio*(gratio+1.5))
#else
          qy(i,2) = (3.*(gratio*qin(i,1)+qin(i,2)) - (gratio*qy(i,1)+qy(i,3)))/(2.+2.*gratio)
#endif
       enddo

       do i=max(3,is),min(npx-2,ie+1)
          qout(i,1) = a2*(qy(i-2,1)+qy(i+1,1)) + a1*(qy(i-1,1)+qy(i,1))
       enddo

       if( is==1 )    qout(2,1) = c1*(qy(1,1)+qy(2,1))+c2*(qout(1,1)+qout(3,1))
       if((ie+1)==npx) qout(npx-1,1) = c1*(qy(npx-2,1)+qy(npx-1,1))+c2*(qout(npx-2,1)+qout(npx,1))
    endif


! North Edges:
    if ( (je+1)==npy ) then
       do i=max(1,is-2),min(npx-1,ie+2)
               gratio = dya(i,npy-2) / dya(i,npy-1)
          qy(i,npy  ) = 0.5*((2.+gratio)*(qin(i,npy-1)+qin(i,npy))  &
                      - (qin(i,npy-2)+qin(i,npy+1))) / (1.+gratio)
#ifdef TEST2
          qy(i,npy-1) = (2.*gratio*(gratio+1.)*qin(i,npy-1)+qin(i,npy-2) - &
                         gratio*(gratio+0.5)*qy(i,npy))/(1.+gratio*(gratio+1.5))
#else
          qy(i,npy-1) = (3.*(qin(i,npy-2)+gratio*qin(i,npy-1)) - (gratio*qy(i,npy)+qy(i,npy-2)))/(2.+2.*gratio)
#endif
       enddo

       do i=max(3,is),min(npx-2,ie+1)
          qout(i,npy) = a2*(qy(i-2,npy)+qy(i+1,npy)) + a1*(qy(i-1,npy)+qy(i,npy))
       enddo

       if( is==1 )  qout(2,npy) = c1*(qy(1,npy)+qy(2,npy))+c2*(qout(1,npy)+qout(3,npy))
       if((ie+1)==npx) qout(npx-1,npy) = c1*(qy(npx-2,npy)+qy(npx-1,npy))+c2*(qout(npx-2,npy)+qout(npx,npy))
    endif
    
    do j=max(3,js),min(npy-2,je+1)
       do i=max(2,is),min(npx-1,ie+1)
          qxx(i,j) = a2*(qx(i,j-2)+qx(i,j+1)) + a1*(qx(i,j-1)+qx(i,j))
       enddo
    enddo

    if ( js==1 ) then
       do i=max(2,is),min(npx-1,ie+1)
          qxx(i,2) = c1*(qx(i,1)+qx(i,2))+c2*(qout(i,1)+qxx(i,3))
       enddo
    endif
    if ( (je+1)==npy ) then
       do i=max(2,is),min(npx-1,ie+1)
          qxx(i,npy-1) = c1*(qx(i,npy-2)+qx(i,npy-1))+c2*(qout(i,npy)+qxx(i,npy-2))
       enddo
    endif

    
    do j=max(2,js),min(npy-1,je+1)
       do i=max(3,is),min(npx-2,ie+1)
          qyy(i,j) = a2*(qy(i-2,j)+qy(i+1,j)) + a1*(qy(i-1,j)+qy(i,j))
       enddo
       if ( is==1 ) qyy(2,j) = c1*(qy(1,j)+qy(2,j))+c2*(qout(1,j)+qyy(3,j))
       if((ie+1)==npx) qyy(npx-1,j) = c1*(qy(npx-2,j)+qy(npx-1,j))+c2*(qout(npx,j)+qyy(npx-2,j))
 
       do i=max(2,is),min(npx-1,ie+1)
          qout(i,j) = 0.5*(qxx(i,j) + qyy(i,j))   ! averaging
       enddo
    enddo

 else  ! grid_type>=3
!------------------------
! Doubly periodic domain:
!------------------------
! X-sweep: PPM
    do j=js-2,je+2
       do i=is,ie+1
          qx(i,j) = b1*(qin(i-1,j)+qin(i,j)) + b2*(qin(i-2,j)+qin(i+1,j))
       enddo
    enddo
! Y-sweep: PPM
    do j=js,je+1
       do i=is-2,ie+2
          qy(i,j) = b1*(qin(i,j-1)+qin(i,j)) + b2*(qin(i,j-2)+qin(i,j+1))
       enddo
    enddo
    
    do j=js,je+1
       do i=is,ie+1
          qout(i,j) = 0.5*( a1*(qx(i,j-1)+qx(i,j  ) + qy(i-1,j)+qy(i,  j)) +  &
                            a2*(qx(i,j-2)+qx(i,j+1) + qy(i-2,j)+qy(i+1,j)) )
       enddo
    enddo
 endif

    if ( present(replace) ) then
       if ( replace ) then
          do j=js,je+1
          do i=is,ie+1
             qin(i,j) = qout(i,j)
          enddo
          enddo
       endif
    endif
    
  end subroutine a2b_ord4
#endif


  subroutine a2b_ord2(qin, qout, npx, npy, is, ie, js, je, ng, replace)
    integer, intent(IN   ) :: npx, npy, is, ie, js, je, ng
    real   , intent(INOUT) ::  qin(is-ng:ie+ng,js-ng:je+ng)   ! A-grid field
    real   , intent(  OUT) :: qout(is-ng:ie+ng,js-ng:je+ng)   ! Output  B-grid field
    logical, optional, intent(IN) ::  replace
    ! local:
    real q1(npx), q2(npy)
    integer :: i,j
    integer :: is1, js1, is2, js2, ie1, je1

    if (grid_type < 3) then

    is1 = max(1,is-1)
    js1 = max(1,js-1)
    is2 = max(2,is)
    js2 = max(2,js)

    ie1 = min(npx-1,ie+1)
    je1 = min(npy-1,je+1)

    do j=js2,je1
       do i=is2,ie1
          qout(i,j) = 0.25*(qin(i-1,j-1)+qin(i,j-1)+qin(i-1,j)+qin(i,j))
       enddo
    enddo

! Fix the 4 Corners:
    if ( sw_corner ) qout(1,    1) = r3*(qin(1,        1)+qin(1,      0)+qin(0,      1))
    if ( se_corner ) qout(npx,  1) = r3*(qin(npx-1,    1)+qin(npx-1,  0)+qin(npx,    1))
    if ( ne_corner ) qout(npx,npy) = r3*(qin(npx-1,npy-1)+qin(npx,npy-1)+qin(npx-1,npy))
    if ( nw_corner ) qout(1,  npy) = r3*(qin(1,    npy-1)+qin(0,  npy-1)+qin(1,    npy))

    ! *** West Edges:
    if ( is==1 ) then
       do j=js1, je1
          q2(j) = 0.5*(qin(0,j) + qin(1,j))
       enddo
       do j=js2, je1
          qout(1,j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j)
       enddo
    endif

    ! East Edges:
    if ( (ie+1)==npx ) then
       do j=js1, je1
          q2(j) = 0.5*(qin(npx-1,j) + qin(npx,j))
       enddo
       do j=js2, je1
          qout(npx,j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j)
       enddo
    endif

    ! South Edges:
    if ( js==1 ) then
       do i=is1, ie1
          q1(i) = 0.5*(qin(i,0) + qin(i,1))
       enddo
       do i=is2, ie1
          qout(i,1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i)
       enddo
    endif

    ! North Edges:
    if ( (je+1)==npy ) then
       do i=is1, ie1
          q1(i) = 0.5*(qin(i,npy-1) + qin(i,npy))
       enddo
       do i=is2, ie1
          qout(i,npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i)
       enddo
    endif

 else

    do j=js,je+1
       do i=is,ie+1
          qout(i,j) = 0.25*(qin(i-1,j-1)+qin(i,j-1)+qin(i-1,j)+qin(i,j))
       enddo
    enddo

 endif

    
    if ( present(replace) ) then
       if ( replace ) then
          do j=js,je+1
             do i=is,ie+1
                qin(i,j) = qout(i,j)
             enddo
          enddo
       endif
    endif
    
  end subroutine a2b_ord2
  
end module a2b_edge_mod


module dyn_core_mod

  use mpp_domains_mod,    only: CGRID_NE, DGRID_NE, mpp_get_boundary,   &
                                mpp_update_domains
  use mpp_parameter_mod,  only: CORNER
  use fv_mp_mod,          only: domain, isd, ied, jsd, jed, is, ie, js, je
  use fv_control_mod,     only: hord_mt, hord_vt, hord_tm, hord_dp, hord_ze, hord_tr, n_sponge,  &
                                dddmp, d2_bg, d4_bg, d_ext, vtdm4, beta1, beta, init_wind_m, m_grad_p, &
                                a2b_ord, ppm_limiter, master, fv_debug, d_con, nord,   &
                                no_cgrid, fill_dp, nwat, inline_q, breed_vortex_inline,&
                                d2_bg_k1, d2_bg_k2, d2_divg_max_k1, d2_divg_max_k2, damp_k_k1, damp_k_k2 
  use sw_core_mod,        only: c_sw, d_sw, divergence_corner, d2a2c
  use a2b_edge_mod,       only: a2b_ord2, a2b_ord4
  use nh_core_mod,        only: Riem_Solver_C, Riem_Solver, update_dz_c, update_dz_d
  use fv_grid_tools_mod,  only: rdx, rdy, rdxc, dxc, dyc, rdyc, dx, dy, area, rarea, grid_type
  use fv_grid_utils_mod,  only: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n,  &
                                ec1, ec2, en1, en2, da_min_c
  use fv_timing_mod,      only: timing_on, timing_off
  use fv_diagnostics_mod, only: prt_maxmin
  use fv_nwp_nudge_mod,   only: breed_slp_inline

#ifdef SW_DYNAMICS
    use test_cases_mod,      only: test_case, case9_forcing1, case9_forcing2
#endif

implicit none
private

public :: dyn_core

    real, allocatable, dimension(:,:,:) :: delzc, ut, vt, crx, cry, xfx, yfx, divg_d, &
                                           zh, du, dv, pkc, delpc, pk3, ptc, gz
contains

!-----------------------------------------------------------------------
!     dyn_core :: FV Lagrangian dynamics driver
!-----------------------------------------------------------------------
 
 subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, grav, hydrostatic,  &
                     u,  v,  um, vm, w, delz, pt, q, delp, pe, pk, phis, omga, ptop, pfull, ua, va, & 
                     uc, vc, mfx, mfy, cx, cy, pem, pkz, peln, ak, bk, init_step, end_step, time_total)
    integer, intent(IN) :: npx
    integer, intent(IN) :: npy
    integer, intent(IN) :: npz
    integer, intent(IN) :: ng, nq, sphum
    integer, intent(IN) :: n_split
    real   , intent(IN) :: bdt
    real   , intent(IN) :: zvir, cp, akap, grav
    real   , intent(IN) :: ptop
    logical, intent(IN) :: hydrostatic
    logical, intent(IN) :: init_step, end_step
    real, intent(in) :: pfull(npz)
    real, intent(in),     dimension(npz+1) :: ak, bk
    real, intent(inout), dimension(isd:ied  ,jsd:jed+1,npz):: u, um  ! D grid zonal wind (m/s)
    real, intent(inout), dimension(isd:ied+1,jsd:jed  ,npz):: v, vm  ! D grid meridional wind (m/s)
    real, intent(inout) :: w(   isd:ied  ,jsd:jed  ,npz)  ! vertical vel. (m/s)
    real, intent(inout) :: delz(is :ie   ,js :je   ,npz)  ! delta-height (m)
    real, intent(inout) :: pt(  isd:ied  ,jsd:jed  ,npz)  ! temperature (K)
    real, intent(inout) :: delp(isd:ied  ,jsd:jed  ,npz)  ! pressure thickness (pascal)
    real, intent(inout) :: q(   isd:ied  ,jsd:jed  ,npz, nq)  ! 
    real, intent(in), optional:: time_total  ! total time (seconds) since start

!-----------------------------------------------------------------------
! Auxilliary pressure arrays:    
! The 5 vars below can be re-computed from delp and ptop.
!-----------------------------------------------------------------------
! dyn_aux:
    real, intent(inout):: phis(isd:ied,jsd:jed)      ! Surface geopotential (g*Z_surf)
    real, intent(inout):: pe(is-1:ie+1, npz+1,js-1:je+1)  ! edge pressure (pascal)
    real, intent(out) :: pem(is-1:ie+1, npz+1,js-1:je+1)
    real, intent(out) :: peln(is:ie,npz+1,js:je)          ! ln(pe)
    real, intent(inout):: pk(is:ie,js:je, npz+1)        ! pe**kappa

!-----------------------------------------------------------------------
! Others:
!-----------------------------------------------------------------------
    real, intent(inout):: omga(isd:ied,jsd:jed,npz)    ! Vertical pressure velocity (pa/s)
    real, intent(inout):: uc(isd:ied+1,jsd:jed  ,npz)  ! (uc, vc) are mostly used as the C grid winds
    real, intent(inout):: vc(isd:ied  ,jsd:jed+1,npz)
    real, intent(inout), dimension(isd:ied,jsd:jed,npz):: ua, va

! The Flux capacitors: accumulated Mass flux arrays
    real, intent(inout)::  mfx(is:ie+1, js:je,   npz)
    real, intent(inout)::  mfy(is:ie  , js:je+1, npz)
! Accumulated Courant number arrays
    real, intent(inout)::  cx(is:ie+1, jsd:jed, npz)
    real, intent(inout)::  cy(isd:ied ,js:je+1, npz)
! Work:
    real, intent(inout):: pkz(is:ie,js:je,npz)  ! 

! Auto 1D & 2D arrays:
    real wbuffer(npy+2,npz)
    real ebuffer(npy+2,npz)
    real nbuffer(npx+2,npz)
    real sbuffer(npx+2,npz)
! ----   For external mode:
    real divg2(is:ie+1,js:je+1)
    real wk(isd:ied,jsd:jed)
! ----   For no_cgrid option:
    real u2(isd:ied,jsd:jed+1)
    real v2(isd:ied+1,jsd:jed)
!-------------------------------------
    integer :: hord_m, hord_v, hord_t, hord_p, nord_k
    integer :: i,j,k, it, iq
    integer :: ism1, iep1, jsm1, jep1
    integer :: ieb1, jeb1
    real    :: alpha, damp_k
    real    :: dt, dt2, rdt, rgrav
    real    :: d2_divg, dd_divg
    real    :: ptk
    logical :: do_omega

    ptk  = ptop ** akap
    dt   = bdt / real(n_split)
    dt2  = 0.5*dt
    rdt  = 1.0/dt
    rgrav = 1.0/grav

! Indexes:
      ism1 = is - 1;  iep1 = ie + 1
      jsm1 = js - 1;  jep1 = je + 1
                                 call timing_on('COMM_TOTAL')
      if ( npz>1 )   &
      call mpp_update_domains(  pt, domain, complete=.false.)
      call mpp_update_domains(delp, domain, complete=.true.)
      call mpp_update_domains(u, v, domain, gridtype=DGRID_NE, complete=.true.)

                                 call timing_off('COMM_TOTAL')

      if ( init_step ) then

           allocate(    gz(isd:ied, jsd:jed ,npz+1) )
           allocate(   ptc(isd:ied, jsd:jed ,npz ) )
           allocate( delzc(is:ie, js:je ,npz ) )
           allocate( crx(is :ie+1, jsd:jed,  npz) )
           allocate( xfx(is :ie+1, jsd:jed,  npz) )
           allocate( cry(isd:ied,  js :je+1, npz) )
           allocate( yfx(isd:ied,  js :je+1, npz) )
           allocate( divg_d(isd:ied+1,jsd:jed+1,npz) )
           allocate(   pkc(isd:ied, jsd:jed  ,npz+1) )
           allocate( delpc(isd:ied, jsd:jed  ,npz  ) )

          if ( .not. no_cgrid ) then
               allocate( ut(isd:ied, jsd:jed, npz) )
               allocate( vt(isd:ied, jsd:jed, npz) )
               ut(:,:,:) = 0.
               vt(:,:,:) = 0.
          endif
          if ( .not. hydrostatic ) then
               allocate( zh(isd:ied, jsd:jed, npz) )
               if ( m_grad_p==0 ) allocate ( pk3(isd:ied,jsd:jed,npz+1) )
          endif

          if ( beta > 1.E-4 .or. no_cgrid ) then
               allocate( du(isd:ied,  jsd:jed+1,npz) )
               allocate( dv(isd:ied+1,jsd:jed,  npz) )
          endif
      endif

     if ( beta > 1.E-4 .or. (no_cgrid .and. init_wind_m) ) then
          call geopk(ptop, pe, peln, delp, pkc, gz, phis, pt, pkz, npz, akap, fill_dp, .false.)
          call grad1_p(du, dv, pkc, gz, delp, dt, ng, npx, npy, npz, ptop, ptk, hydrostatic)

          if( init_wind_m )   &
          call mpp_update_domains(du, dv, domain, gridtype=DGRID_NE)
     endif

! Empty the "flux capacitors"
      mfx(:,:,:) = 0.;  mfy(:,:,:) = 0.
       cx(:,:,:) = 0.;   cy(:,:,:) = 0.

!-----------------------------------------------------
  do it=1,n_split
!-----------------------------------------------------
     if ( .not. hydrostatic ) then
!$omp parallel do default(shared) private(i, j, k)
        do j=js,je
           do i=is,ie
              zh(i,j,npz) = phis(i,j)*rgrav - delz(i,j,npz)
           enddo
           do k=npz-1,1,-1
              do i=is,ie
                 zh(i,j,k) = zh(i,j,k+1) - delz(i,j,k)
              enddo
           enddo
        enddo
                                 call timing_on('COMM_TOTAL')
        call mpp_update_domains(zh, domain, complete=.false.)
        call mpp_update_domains(w,  domain, complete=.true.)
                                call timing_off('COMM_TOTAL')
     endif

#ifdef SW_DYNAMICS
      do_omega  = .false.
      if (test_case>1) then
      if (test_case==9) call case9_forcing1(phis, time_total)
#else
      if ( it==n_split ) then
!$omp parallel do default(shared) private(i, j, k)
      do j=jsm1,jep1
         do i=ism1,iep1
            pem(i,1,j) = ptop
         enddo
         do k=1,npz
            do i=ism1,iep1
               pem(i,k+1,j) = pem(i,k,j) + delp(i,j,k)
            enddo
         enddo
      enddo
           do_omega  = .true.
      else
           do_omega  = .false.
      endif
#endif

     if ( no_cgrid ) then
!---------------------------------------------------------------
! Using time extrapolated wind in place of computed C Grid wind
!---------------------------------------------------------------
                                               call timing_on('no_cgrid')
!$omp parallel do default(shared) private(i, j, k, u2, v2)
        do k=1,npz
           if ( init_wind_m ) then
              do j=jsd,jed+1
                 do i=isd,ied
                    u2(i,j) = u(i,j,k) + 0.5*du(i,j,k)
                 enddo
              enddo
              do j=jsd,jed
                 do i=isd,ied+1
                    v2(i,j) = v(i,j,k) + 0.5*dv(i,j,k)
                 enddo
              enddo
           else

           do j=jsd,jed+1
              do i=isd,ied
                 u2(i,j) = 1.5*u(i,j,k) - 0.5*um(i,j,k)
              enddo
           enddo
           do j=jsd,jed
              do i=isd,ied+1
                 v2(i,j) = 1.5*v(i,j,k) - 0.5*vm(i,j,k)
              enddo
           enddo
           endif
           call d2a2c( u(isd,jsd,k),  v(isd,jsd,k), u2, v2, ua(isd,jsd,k),   &
                      va(isd,jsd,k), uc(isd,jsd,k), vc(isd,jsd,k), nord>0 )
        enddo

        if ( .not. hydrostatic ) delpc(:,:,:) = delp(:,:,:)
        um(:,:,:) = u(:,:,:)
        vm(:,:,:) = v(:,:,:)
                                               call timing_off('no_cgrid')
    else
                                                     call timing_on('c_sw')
!$omp parallel do default(shared) private(i, j, k)
      do k=1,npz
         call c_sw(delpc(isd,jsd,k), delp(isd,jsd,k),  ptc(isd,jsd,k),  &
                      pt(isd,jsd,k),    u(isd,jsd,k),    v(isd,jsd,k),  &
                       w(isd,jsd,k),   uc(isd,jsd,k),   vc(isd,jsd,k),  &
                      ua(isd,jsd,k),   va(isd,jsd,k), omga(isd,jsd,k),  &
                      ut(isd,jsd,k),   vt(isd,jsd,k), dt2, hydrostatic, nord>0)
! on output omga is updated w
      enddo
                                                     call timing_off('c_sw')
      if ( hydrostatic ) then
           if ( beta1 > 0.001 ) then
              alpha = 1.0 - beta1
              delpc(:,:,:) = beta1*delp(:,:,:) + alpha*delpc(:,:,:)
              ptc(:,:,:) = beta1*pt(:,:,:) + alpha*ptc(:,:,:)
           endif
           call geopk(ptop, pe, peln, delpc, pkc, gz, phis, ptc, pkz, npz, akap, fill_dp, .true.)
      else
           call update_dz_c(is,   ie, js, je,  npz,    ng,    &
                            area, zh, ut, vt, delz, delzc, gz)
                                               call timing_on('Riem_C')
           call Riem_Solver_C( dt2,   is,  ie,   js,   je,   npz,   ng,   &
                               akap,  cp,  ptop, phis, omga, delzc, ptc,  &
                               delpc, gz,  pkc,  1 )
                                               call timing_off('Riem_C')
! pkc is full non-hydro pressure
                                               call timing_on('COMM_TOTAL')
           call mpp_update_domains(pkc, domain, complete=.false.)
           call mpp_update_domains(gz , domain, complete=.true.)
                                               call timing_off('COMM_TOTAL')
      endif

!-----------------------------------------
! Update time-centered winds on the C-Grid
!-----------------------------------------
      ieb1 = ie+1;   jeb1 = je+1

!$omp parallel do default(shared) private(i, j, k, wk)
      do k=1,npz
         if ( hydrostatic ) then
              do j=jsm1,jeb1
                 do i=ism1,ieb1
                    wk(i,j) = pkc(i,j,k+1) - pkc(i,j,k)
                 enddo
              enddo
         else
              do j=jsd,jed
                 do i=isd,ied
                       wk(i,j)   = delpc(i,j,k)
                    delpc(i,j,k) =  delp(i,j,k)   ! Save delp for update_dz_d
                 enddo
              enddo
         endif

         do j=js,je
            do i=is,ieb1
               uc(i,j,k) = uc(i,j,k) + dt2*rdxc(i,j) / (wk(i-1,j)+wk(i,j)) *   &
                      ( (gz(i-1,j,k+1)-gz(i,j,k  ))*(pkc(i,j,k+1)-pkc(i-1,j,k))  &
                      + (gz(i-1,j,k) - gz(i,j,k+1))*(pkc(i-1,j,k+1)-pkc(i,j,k)) )
            enddo
         enddo
         do j=js,jeb1
            do i=is,ie
               vc(i,j,k) = vc(i,j,k) + dt2*rdyc(i,j) / (wk(i,j-1)+wk(i,j)) *   &
                      ( (gz(i,j-1,k+1)-gz(i,j,k  ))*(pkc(i,j,k+1)-pkc(i,j-1,k))  &
                      + (gz(i,j-1,k) - gz(i,j,k+1))*(pkc(i,j-1,k+1)-pkc(i,j,k)) )
            enddo
         enddo
      enddo

   endif       ! end no_cgrid section
                                                     call timing_on('COMM_TOTAL')
      call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE, complete=.true.)
                                                     call timing_off('COMM_TOTAL')

#ifdef SW_DYNAMICS
      if (test_case==9) call case9_forcing2(phis)
      endif !test_case>1
#endif

    if ( inline_q ) then
                                 call timing_on('COMM_TOTAL')
         call mpp_update_domains( q, domain, complete=.true.)
                                call timing_off('COMM_TOTAL')
    endif

    if ( nord>0 ) then
         call divergence_corner(u, v, ua, va, divg_d, npz)
                                     call timing_on('COMM_TOTAL')
         call mpp_update_domains(divg_d, domain, position=CORNER)
                                    call timing_off('COMM_TOTAL')
    endif

                                                     call timing_on('d_sw')
!$omp parallel do default(shared) private(i, j, k, nord_k, damp_k, d2_divg, dd_divg, hord_m, hord_v, hord_t, hord_p, wk)
    do k=1,npz
         hord_m = hord_mt
         hord_t = hord_tm
         hord_v = hord_vt
         hord_p = hord_dp
         nord_k = nord
         damp_k = dddmp
         d2_divg = min(0.20, d2_bg*(1.-3.*tanh(0.1*log(pfull(k)/pfull(npz)))))
         if ( n_sponge==-1 .or. npz==1 ) then
! Constant divg damping coefficient:
           d2_divg = d2_bg
       else
         if ( n_sponge==0 .and. k==1 ) then
               hord_v = 2
               hord_t = 2
               hord_p = 2
               nord_k = max(0, nord-1)
               damp_k = 0.025
               d2_divg = min(0.20, 2.*d2_bg)
               d2_divg = max(0.05 ,  d2_divg)
         else
           if( k <= n_sponge .and. npz>16 ) then
! Apply first order scheme for damping the sponge layer
               hord_m = 1
               hord_v = 1
               hord_t = 1
               hord_p = 1
               nord_k = 0
               damp_k = damp_k_k1
               d2_divg = min(0.20, d2_bg_k1*d2_bg)   ! 0.25 is the stability limit
               d2_divg = max(d2_divg_max_k1, d2_divg)
           elseif( k == n_sponge+1 .and. npz>24 ) then
               hord_v = 2
               hord_t = 2
               hord_p = 2
               nord_k = max(0, nord-1)
               damp_k = damp_k_k2
               d2_divg = min(0.20, d2_bg_k2*d2_bg)
               d2_divg = max(d2_divg_max_k2, d2_divg)
           endif
         endif
       endif
       dd_divg = d4_bg

!--- external mode divergence damping ---
       if ( d_ext > 0. )  &
            call a2b_ord2(delp(isd,jsd,k), wk, npx, npy, is,    &
                          ie, js, je, ng, .false.)

       call d_sw(pkc(isd,jsd,k), delp(isd,jsd,k), ptc(isd,jsd,k),  pt(isd,jsd,k),     &
                  u(isd,jsd,k),    v(isd,jsd,k),   w(isd,jsd,k),  uc(isd,jsd,k),      &
                  vc(isd,jsd,k),   ua(isd,jsd,k),  va(isd,jsd,k), divg_d(isd,jsd,k),  &
                  mfx(is, js, k),  mfy(is, js, k),  cx(is, jsd,k),  cy(isd,js, k),    &
                  crx(is, jsd,k),  cry(isd,js, k), xfx(is, jsd,k), yfx(isd,js, k),    &
                  zvir, sphum, nq, q, k, npz, inline_q, pkz(is,js,k), dt,             &
                  hord_tr, hord_m, hord_v, hord_t, hord_p, nord_k, damp_k,            &
                  d2_divg, dd_divg, vtdm4, d_con, hydrostatic, ppm_limiter)

       if ( d_ext > 0. ) then
            do j=js,jep1
               do i=is,iep1
                  ptc(i,j,k) = wk(i,j)    ! delp at cell corners
               enddo
            enddo
       endif
    enddo         
                                                     call timing_off('d_sw')
   if ( fv_debug ) call prt_maxmin('DELP', delp, is, ie, js, je, ng, npz, 1.E-2, master)


    if ( d_ext > 0. ) then
          d2_divg = d_ext * da_min_c
! pkc() is 3D field of horizontal divergence
! ptc is "delp" at cell corners
!$omp parallel do default(shared) private(i, j, k)
          do j=js,jep1
              do i=is,iep1
                    wk(i,j) = ptc(i,j,1)
                 divg2(i,j) = wk(i,j)*pkc(i,j,1)
              enddo
              do k=2,npz
                 do i=is,iep1
                       wk(i,j) =    wk(i,j) + ptc(i,j,k)
                    divg2(i,j) = divg2(i,j) + ptc(i,j,k)*pkc(i,j,k)
                 enddo
              enddo
              do i=is,iep1
                 divg2(i,j) = d2_divg*divg2(i,j)/wk(i,j)
              enddo
          enddo
    else
        divg2 = 0.
    endif
                               call timing_on('COMM_TOTAL')
    call mpp_update_domains(  pt, domain, complete=.false.)
    call mpp_update_domains(delp, domain, complete=.true.)
                             call timing_off('COMM_TOTAL')

     if ( hydrostatic ) then
          call geopk(ptop, pe, peln, delp, pkc, gz, phis, pt, pkz, npz, akap, fill_dp, .false.)
     else
                                            call timing_on('UPDATE_DZ')
          call update_dz_d(hord_tm, is, ie, js, je, npz, ng, npx, npy, area,  &
                           zh, crx, cry, xfx, yfx, delz, delzc, delpc, n_sponge)
                                            call timing_off('UPDATE_DZ')
                                                          call timing_on('Riem_D')
!-----------------------------------------------------------
! mgrad_p = 1: pkc is full pressure
! mgrad_p = 0: pkc is non-hydrostatic perturbation pressure
!-----------------------------------------------------------
          call Riem_Solver(dt,   is,   ie,   js,   je, npz,  ng,  &
                           akap, cp,   ptop, phis, peln, w,  delz,      &
                           pt,   delp, gz,   pkc,  pk, pe, it==n_split, m_grad_p)
                                                 call timing_off('Riem_D')

                                       call timing_on('COMM_TOTAL')
          if ( m_grad_p==0 ) then
             do k=1,npz+1
                do j=js,je
                   do i=is,ie
                      pk3(i,j,k) = pk(i,j,k)
                   enddo
                enddo
             enddo
             call mpp_update_domains(pk3, domain, complete=.false.)
          endif

          call mpp_update_domains(pkc, domain, complete=.false.)
          call mpp_update_domains(gz , domain, complete=.true.)
                                       call timing_off('COMM_TOTAL')
     endif    ! end hydro case


#ifdef SW_DYNAMICS
      if (test_case > 1) then
#else
      if ( breed_vortex_inline .or. (it==n_split .and. hydrostatic) ) then
!$omp parallel do default(shared) private(i, j, k)
           do k=1,npz+1
              do j=js,je
                 do i=is,ie
                    pk(i,j,k) = pkc(i,j,k)
                 enddo
              enddo
           enddo
      endif
    
      if ( do_omega ) then
!------------------------------
! Compute time tendency
!------------------------------
!$omp parallel do default(shared) private(i, j, k)
         do k=1,npz
            do j=js,je
               do i=is,ie
                  omga(i,j,k) = (pe(i,k+1,j) - pem(i,k+1,j)) * rdt 
               enddo
            enddo
         enddo
!------------------------------
! Compute the "advective term"
!------------------------------
         call adv_pe(ua, va, pem, omga, npx, npy,  npz, ng)
      endif

#endif

      if ( .not.hydrostatic .and. m_grad_p == 0 ) then
           call two_grad_p(u, v, pkc, gz, delp, pk3, divg2, dt, ng, npx, npy,   &
                           npz, ptk)  
      else
       if ( beta > 1.E-4 ) then
!$omp parallel do default(shared) private(i, j, k)
          do k=1,npz
             do j=js,je+1
                do i=is,ie
                   u(i,j,k) = (u(i,j,k)+divg2(i,j)-divg2(i+1,j))*rdx(i,j) + beta*du(i,j,k)
                enddo
             enddo
          enddo
!$omp parallel do default(shared) private(i, j, k)
          do k=1,npz
             do j=js,je
                do i=is,ie+1
                   v(i,j,k) = (v(i,j,k)+divg2(i,j)-divg2(i,j+1))*rdy(i,j) + beta*dv(i,j,k)
                enddo
             enddo
          enddo
          call grad1_p(du, dv, pkc, gz, delp, dt, ng, npx, npy, npz, ptop, ptk, hydrostatic)
          alpha = 1. - beta
!$omp parallel do default(shared) private(i, j, k)
          do k=1,npz
             do j=js,je+1
                do i=is,ie
                   u(i,j,k) = u(i,j,k) + alpha*du(i,j,k)
                enddo
             enddo
          enddo
!$omp parallel do default(shared) private(i, j, k)
          do k=1,npz
             do j=js,je
                do i=is,ie+1
                   v(i,j,k) = v(i,j,k) + alpha*dv(i,j,k)
                enddo
             enddo
          enddo
       else
           call one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, npx, npy, npz,   &
                           ptop, ptk, hydrostatic)  
       endif
      endif

!-------------------------------------------------------------------------------------------------------
      if ( breed_vortex_inline )     &
      call breed_slp_inline(it, dt, npz, ak, bk, phis, pe, pk, peln, delp, u, v, pt, q, nwat, zvir)
!-------------------------------------------------------------------------------------------------------

                                                                call timing_on('COMM_TOTAL')
      if( it==n_split .and. grid_type<4 ) then
! Prevent accumulation of rounding errors at overlapped domain edges:
          call mpp_get_boundary(u, v, domain, wbuffery=wbuffer, ebuffery=ebuffer,  &
                            sbufferx=sbuffer, nbufferx=nbuffer, gridtype=DGRID_NE )
          u(is:ie,je+1,1:npz) = nbuffer
          v(ie+1,js:je,1:npz) = ebuffer
      else
          call mpp_update_domains(u, v, domain, gridtype=DGRID_NE)
      endif
                                                                call timing_off('COMM_TOTAL')
#ifdef SW_DYNAMICS
      endif
#endif
      init_wind_m = .false.

!-----------------------------------------------------
  enddo   ! time split loop
!-----------------------------------------------------

  if ( end_step ) then
    deallocate(    gz )
    deallocate(   ptc )
    deallocate( delzc )
    deallocate(   crx )
    deallocate(   xfx )
    deallocate(   cry )
    deallocate(   yfx )
    deallocate( divg_d )
    deallocate(   pkc )
    deallocate( delpc )

    if ( .not. no_cgrid ) then
      deallocate( ut )
      deallocate( vt )
    endif
    if ( .not. hydrostatic ) then
         deallocate( zh )
         if ( m_grad_p==0 ) deallocate ( pk3 )
    endif
    if ( beta > 1.E-4 .or. no_cgrid) then
      deallocate( du )
      deallocate( dv )
    endif
  endif

 end subroutine dyn_core



 subroutine two_grad_p(u, v, pk, gh, delp, pkt, divg2, dt, ng, npx, npy, npz, ptk)  

    integer, intent(IN) :: ng, npx, npy, npz
    real,    intent(IN) :: dt, ptk
    real,    intent(in) :: divg2(is:ie+1, js:je+1)
    real, intent(inout) ::  delp(isd:ied, jsd:jed, npz)
    real, intent(inout) ::    pk(isd:ied, jsd:jed, npz+1)  ! perturbation pressure
    real, intent(inout) ::   pkt(isd:ied, jsd:jed, npz+1)  ! p**kappa
    real, intent(inout) ::    gh(isd:ied, jsd:jed, npz+1)  ! g * zh
    real, intent(inout) ::     u(isd:ied,  jsd:jed+1,npz) 
    real, intent(inout) ::     v(isd:ied+1,jsd:jed,  npz)
! Local:
    real wk1(isd:ied, jsd:jed)
    real  wk(is: ie+1,js: je+1)
    integer iep1, jep1
    integer i,j,k

    iep1 = ie + 1
    jep1 = je + 1

    do j=js,jep1
       do i=is,iep1
          pk(i,j,1) = 0.
          pkt(i,j,1) = ptk
       enddo
    enddo

!$omp parallel do default(shared) private(i, j, k, wk1)
    do k=1,npz+1

       if ( k/=1 ) then
         if ( a2b_ord==4 ) then
           call a2b_ord4( pk(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng, .true.)
           call a2b_ord4(pkt(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng, .true.)
         else
           call a2b_ord2( pk(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng, .true.)
           call a2b_ord2(pkt(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng, .true.)
         endif
       endif

       if ( a2b_ord==4 ) then
           call a2b_ord4( gh(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng, .true.)
       else
           call a2b_ord2( gh(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo

!$omp parallel do default(shared) private(i, j, k, wk1, wk)
    do k=1,npz

       if ( a2b_ord==4 ) then
            call a2b_ord4(delp(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng)
       else
            call a2b_ord2(delp(isd,jsd,k), wk1, npx, npy, is, ie, js, je, ng)
       endif

       do j=js,jep1
          do i=is,iep1
             wk(i,j) = pkt(i,j,k+1) - pkt(i,j,k)
          enddo
       enddo

       do j=js,jep1
          do i=is,ie
!------------------
! Perturbation term:
!------------------
             u(i,j,k) = u(i,j,k) + dt/(wk1(i,j)+wk1(i+1,j)) *   &
                   ((gh(i,j,k+1)-gh(i+1,j,k))*(pk(i+1,j,k+1)-pk(i,j,k)) &
                  + (gh(i,j,k)-gh(i+1,j,k+1))*(pk(i,j,k+1)-pk(i+1,j,k)))
!-----------------
! Hydrostatic term
!-----------------
             u(i,j,k) = rdx(i,j)*(divg2(i,j)-divg2(i+1,j)+u(i,j,k) + dt/(wk(i,j)+wk(i+1,j)) *      &
                   ((gh(i,j,k+1)-gh(i+1,j,k))*(pkt(i+1,j,k+1)-pkt(i,j,k)) &
                  + (gh(i,j,k)-gh(i+1,j,k+1))*(pkt(i,j,k+1)-pkt(i+1,j,k))))
          enddo
       enddo

       do j=js,je
          do i=is,iep1
!------------------
! Perturbation term:
!------------------
             v(i,j,k) = v(i,j,k) + dt/(wk1(i,j)+wk1(i,j+1)) *   &
                   ((gh(i,j,k+1)-gh(i,j+1,k))*(pk(i,j+1,k+1)-pk(i,j,k)) &
                  + (gh(i,j,k)-gh(i,j+1,k+1))*(pk(i,j,k+1)-pk(i,j+1,k)))
!-----------------
! Hydrostatic term
!-----------------
             v(i,j,k) = rdy(i,j)*(divg2(i,j)-divg2(i,j+1)+v(i,j,k) + dt/(wk(i,j)+wk(i,j+1)) *      &
                   ((gh(i,j,k+1)-gh(i,j+1,k))*(pkt(i,j+1,k+1)-pkt(i,j,k)) &
                  + (gh(i,j,k)-gh(i,j+1,k+1))*(pkt(i,j,k+1)-pkt(i,j+1,k))))
          enddo
       enddo
    enddo    ! end k-loop

 end subroutine two_grad_p



 subroutine one_grad_p(u, v, pk, gh, divg2, delp, dt, ng, npx, npy, npz,  &
                       ptop, ptk,  hydrostatic)  

    integer, intent(IN) :: ng, npx, npy, npz
    real,    intent(IN) :: dt, ptop, ptk
    logical, intent(in) :: hydrostatic
    real,    intent(in) :: divg2(is:ie+1,js:je+1)
    real, intent(inout) ::    pk(isd:ied,  jsd:jed  ,npz+1)
    real, intent(inout) ::    gh(isd:ied,  jsd:jed  ,npz+1)
    real, intent(inout) ::  delp(isd:ied,  jsd:jed  ,npz)
    real, intent(inout) ::     u(isd:ied  ,jsd:jed+1,npz) 
    real, intent(inout) ::     v(isd:ied+1,jsd:jed  ,npz)
! Local:
    real, dimension(isd:ied,jsd:jed):: wk
    real:: wk1(is:ie+1,js:je)
    real:: wk2(is:ie,js:je+1)
    real top_value
    integer :: iep1, jep1
    integer i,j,k

    iep1 = ie + 1
    jep1 = je + 1


    if ( hydrostatic ) then
! pk is pe**kappa if hydrostatic
         top_value = ptk
    else
! pk is full pressure if non-hydrostatic
         top_value = ptop
    endif

    do j=js,jep1
       do i=is,iep1
          pk(i,j,1) = top_value
       enddo
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=2,npz+1
       if ( a2b_ord==4 ) then
         call a2b_ord4(pk(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       else
         call a2b_ord2(pk(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=1,npz+1
       if ( a2b_ord==4 ) then
         call a2b_ord4( gh(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       else
         call a2b_ord2( gh(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo

    do j=js,jep1
       do i=is,ie
          wk2(i,j) = divg2(i,j)-divg2(i+1,j)
       enddo
    enddo
    do j=js,je
       do i=is,iep1
          wk1(i,j) = divg2(i,j)-divg2(i,j+1)
       enddo
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=1,npz

       if ( hydrostatic ) then
            do j=js,jep1
               do i=is,iep1
                  wk(i,j) = pk(i,j,k+1) - pk(i,j,k)
               enddo
            enddo
       else
         if ( a2b_ord==4 ) then
            call a2b_ord4(delp(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng)
         else
            call a2b_ord2(delp(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng)
         endif
       endif

       do j=js,jep1
          do i=is,ie
             u(i,j,k) = rdx(i,j)*(wk2(i,j)+u(i,j,k) + dt/(wk(i,j)+wk(i+1,j)) * &
                        ((gh(i,j,k+1)-gh(i+1,j,k))*(pk(i+1,j,k+1)-pk(i,j,k)) &
                       + (gh(i,j,k)-gh(i+1,j,k+1))*(pk(i,j,k+1)-pk(i+1,j,k))))
          enddo
       enddo
       do j=js,je
          do i=is,iep1
             v(i,j,k) = rdy(i,j)*(wk1(i,j)+v(i,j,k) + dt/(wk(i,j)+wk(i,j+1)) * &
                        ((gh(i,j,k+1)-gh(i,j+1,k))*(pk(i,j+1,k+1)-pk(i,j,k)) &
                       + (gh(i,j,k)-gh(i,j+1,k+1))*(pk(i,j,k+1)-pk(i,j+1,k))))
          enddo
       enddo
    enddo    ! end k-loop

 end subroutine one_grad_p



#ifdef NEW_PZ
 subroutine grad1_p(delu, delv, pk, gh,  delp, dt, ng, npx, npy, npz,  &
                    ptop, ptk,  hydrostatic)  

    integer, intent(in) :: ng, npx, npy, npz
    real,    intent(in) :: dt, ptop, ptk
    logical, intent(in) :: hydrostatic
    real, intent(inout) ::    pk(isd:ied,  jsd:jed  ,npz+1)
    real, intent(inout) ::    gh(isd:ied,  jsd:jed  ,npz+1)
    real, intent(inout) ::  delp(isd:ied,  jsd:jed  ,npz)

    real, intent(out) ::    delu(isd:ied  ,jsd:jed+1,npz) 
    real, intent(out) ::    delv(isd:ied+1,jsd:jed  ,npz)
! Local:
    real:: ph_u(is:ie,js:je+1,npz+1), ph_v(is:ie+1,js:je,npz+1)
    real:: wk(isd:ied,jsd:jed)
    real:: pz(is:ie+1,js:je+1)

    real top_value
    integer i,j,k


    if ( hydrostatic ) then
! pk is pe**kappa if hydrostatic
         top_value = ptk
    else
! pk is full pressure if non-hydrostatic
         top_value = ptop
    endif

    do j=js,je+1
       do i=is,ie+1
          pk(i,j,1) = top_value
       enddo
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=2,npz+1
       if ( a2b_ord==4 ) then
         call a2b_ord4(pk(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       else
         call a2b_ord2(pk(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo

!-----
! k==1
!-----
       do j=js,je+1
          do i=is,ie
             ph_u(i,j,1) = 0.
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             ph_v(i,j,1) = 0.
          enddo
       enddo

!$omp parallel do default(shared) private(i, j, k)
    do k=2,npz+1
       do j=js,je+1
          do i=is,ie
             ph_u(i,j,k) = (gh(i,j-1,k)+gh(i,j,k))*(pk(i,j,k)-pk(i+1,j,k))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             ph_v(i,j,k) = (gh(i-1,j,k)+gh(i,j,k))*(pk(i,j,k)-pk(i,j+1,k))
          enddo
       enddo
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=1,npz+1
       if ( a2b_ord==4 ) then
         call a2b_ord4( gh(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       else
         call a2b_ord2( gh(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo


!$omp parallel do default(shared) private(i, j, k, wk, pz)
    do k=1,npz

       if ( hydrostatic ) then
            do j=js,je+1
               do i=is,ie+1
                  wk(i,j) = pk(i,j,k+1) - pk(i,j,k)
               enddo
            enddo
       else
         if ( a2b_ord==4 ) then
            call a2b_ord4(delp(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng)
         else
            call a2b_ord2(delp(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng)
         endif
       endif

! pz: 
       do j=js,je+1
          do i=is,ie+1
             pz(i,j) = (gh(i,j,k)+gh(i,j,k+1)) * wk(i,j)
          enddo
       enddo

       do j=js,je+1
          do i=is,ie
             delu(i,j,k) = rdx(i,j)*dt / (wk(i,j)+wk(i+1,j)) *  &
                        (pz(i,j)-pz(i+1,j) + ph_u(i,j,k)-ph_u(i,j,k+1))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             delv(i,j,k) = rdy(i,j)*dt / (wk(i,j)+wk(i,j+1)) *  &
                        (pz(i,j)-pz(i,j+1) + ph_v(i,j,k)-ph_v(i,j,k+1))
          enddo
       enddo
    enddo    ! end k-loop

 end subroutine grad1_p


#else
 subroutine grad1_p(delu, delv, pk, gh,  delp, dt, ng, npx, npy, npz,  &
                    ptop, ptk,  hydrostatic)  

    integer, intent(in) :: ng, npx, npy, npz
    real,    intent(in) :: dt, ptop, ptk
    logical, intent(in) :: hydrostatic
    real, intent(inout) ::    pk(isd:ied,  jsd:jed  ,npz+1)
    real, intent(inout) ::    gh(isd:ied,  jsd:jed  ,npz+1)
    real, intent(inout) ::  delp(isd:ied,  jsd:jed  ,npz)

    real, intent(out) ::    delu(isd:ied  ,jsd:jed+1,npz) 
    real, intent(out) ::    delv(isd:ied+1,jsd:jed  ,npz)
! Local:
    real:: wk(isd:ied,jsd:jed)
    real top_value
    integer i,j,k



    if ( hydrostatic ) then
! pk is pe**kappa if hydrostatic
         top_value = ptk
    else
! pk is full pressure if non-hydrostatic
         top_value = ptop
    endif

    do j=js,je+1
       do i=is,ie+1
          pk(i,j,1) = top_value
       enddo
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=2,npz+1
       if ( a2b_ord==4 ) then
         call a2b_ord4(pk(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       else
         call a2b_ord2(pk(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo

!$omp parallel do default(shared) private(i, j, k, wk)
    do k=1,npz+1
       if ( a2b_ord==4 ) then
         call a2b_ord4( gh(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       else
         call a2b_ord2( gh(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng, .true.)
       endif
    enddo


!$omp parallel do default(shared) private(i, j, k, wk)
    do k=1,npz

       if ( hydrostatic ) then
            do j=js,je+1
               do i=is,ie+1
                  wk(i,j) = pk(i,j,k+1) - pk(i,j,k)
               enddo
            enddo
       else
         if ( a2b_ord==4 ) then
            call a2b_ord4(delp(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng)
         else
            call a2b_ord2(delp(isd,jsd,k), wk, npx, npy, is, ie, js, je, ng)
         endif
       endif

       do j=js,je+1
          do i=is,ie
             delu(i,j,k) = rdx(i,j) * dt/(wk(i,j)+wk(i+1,j)) *  &
                         ((gh(i,j,k+1)-gh(i+1,j,k))*(pk(i+1,j,k+1)-pk(i,j,k)) &
                      + (gh(i,j,k)-gh(i+1,j,k+1))*(pk(i,j,k+1)-pk(i+1,j,k)))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             delv(i,j,k) = rdy(i,j) * dt/(wk(i,j)+wk(i,j+1)) *  &
                         ((gh(i,j,k+1)-gh(i,j+1,k))*(pk(i,j+1,k+1)-pk(i,j,k)) &
                      + (gh(i,j,k)-gh(i,j+1,k+1))*(pk(i,j,k+1)-pk(i,j+1,k)))
          enddo
       enddo
    enddo    ! end k-loop

 end subroutine grad1_p

#endif



 subroutine geopk(ptop, pe, peln, delp, pk, gh, hs, pt, pkz, km, akap, dp_check, CG)

     integer, intent(IN) :: km
     real   , intent(IN) :: akap, ptop
     real   , intent(IN) :: hs(isd:ied,jsd:jed)
     real, intent(INOUT), dimension(isd:ied,jsd:jed,km):: pt, delp
     logical, intent(IN) :: dp_check, CG
! !OUTPUT PARAMETERS
     real, intent(OUT), dimension(isd:ied,jsd:jed,km+1):: gh, pk
     real, intent(OUT) :: pe(is-1:ie+1,km+1,js-1:je+1)
     real, intent(out) :: peln(is:ie,km+1,js:je)          ! ln(pe)
     real, intent(out) :: pkz(is:ie,js:je,km)
! !DESCRIPTION:
!    Calculates geopotential and pressure to the kappa.
! Local:
     real p1d(is-2:ie+2)
     real logp(is-2:ie+2)
     real ptk, dp, dpmin
     integer i, j, k
     integer ifirst, ilast
     integer jfirst, jlast

     dpmin = 0.01*ptop
     ptk  = ptop ** akap

     if ( .not. CG .and. a2b_ord==4 ) then   ! D-Grid
          ifirst = is-2; ilast = ie+2
          jfirst = js-2; jlast = je+2
     else
          ifirst = is-1; ilast = ie+1
          jfirst = js-1; jlast = je+1
     endif

!$omp parallel do default(shared) private(i, j, k, p1d, dp, logp)
     do 2000 j=jfirst,jlast

        do i=ifirst, ilast
           p1d(i) = ptop
           pk(i,j,1) = ptk
           gh(i,j,km+1) = hs(i,j)
        enddo

        if( j>(js-2) .and. j<(je+2) ) then
           do i=max(ifirst,is-1), min(ilast,ie+1) 
              pe(i,1,j) = ptop
           enddo
        endif

#ifndef NO_CHECK
        if( dp_check ) then
          do k=1, km-1
             do i=ifirst, ilast
              if(delp(i,j,k) < dpmin) then
! Remap from below and mix pt
                dp = dpmin - delp(i,j,k)
                pt(i,j,k) = (pt(i,j,k)*delp(i,j,k) + pt(i,j,k+1)*dp) / dpmin
                delp(i,j,k) = dpmin
                delp(i,j,k+1) = delp(i,j,k+1) - dp
              endif
            enddo
          enddo

! Bottom (k=km):
          do i=ifirst, ilast
            if(delp(i,j,km) < dpmin) then
! Remap from above and mix pt
              dp = dpmin - delp(i,j,km)
              pt(i,j,km) = (pt(i,j,km)*delp(i,j,km) + pt(i,j,km-1)*dp)/dpmin
              delp(i,j,km) = dpmin
              delp(i,j,km-1) = delp(i,j,km-1) - dp
            endif
          enddo
        endif
#endif

! Top down
        do k=2,km+1
          do i=ifirst, ilast
             p1d(i)  = p1d(i) + delp(i,j,k-1)
!             pk(i,j,k) = p1d(i) ** akap
! Optimized form:
             logp(i) = log(p1d(i))
             pk(i,j,k) = exp( akap*logp(i) ) 
          enddo

          if( j>(js-2) .and. j<(je+2) ) then
             do i=max(ifirst,is-1), min(ilast,ie+1) 
                pe(i,k,j) = p1d(i)
             enddo
             if( j>=js .and. j<=je) then
                do i=is,ie
                   peln(i,k,j) = logp(i)
                enddo
             endif
          endif

        enddo

! Bottom up
        do k=km,1,-1
           do i=ifirst, ilast
              gh(i,j,k) = gh(i,j,k+1) + pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k))
           enddo
        enddo

2000  continue

      if ( .not. CG ) then
! This is for hydrostatic only
!$omp parallel do default(shared) private(i, j, k)
         do k=1,km
            do j=js,je
               do i=is,ie
                  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(akap*(peln(i,k+1,j)-peln(i,k,j)))
               enddo
            enddo
         enddo
      endif

 end subroutine geopk

 
 subroutine adv_pe(ua, va, pem, om, npx, npy, npz, ng)

 integer, intent(in) :: npx, npy, npz, ng
! Contra-variant wind components:
 real, intent(in), dimension(isd:ied,jsd:jed,npz):: ua, va
! Pressure at edges:
 real, intent(in) :: pem(is-1:ie+1,1:npz+1,js-1:je+1)
 real, intent(inout) :: om(isd:ied,jsd:jed,npz)

! Local:
 real, dimension(is:ie,js:je):: up, vp
 real v3(3,is:ie,js:je)

 real pin(isd:ied,jsd:jed)
 real  pb(isd:ied,jsd:jed)

 real grad(3,is:ie,js:je)
 real pdx(3,is:ie,js:je+1)
 real pdy(3,is:ie+1,js:je)
 integer :: i,j,k, n

!$omp parallel do default(shared) private(i, j, k, n, pdx, pdy, pin, pb, up, vp, grad, v3)
 do k=1,npz
    if ( k==npz ) then
       do j=js,je
          do i=is,ie
             up(i,j) = ua(i,j,npz)
             vp(i,j) = va(i,j,npz)
          enddo
       enddo
    else
       do j=js,je
          do i=is,ie
             up(i,j) = 0.5*(ua(i,j,k)+ua(i,j,k+1))
             vp(i,j) = 0.5*(va(i,j,k)+va(i,j,k+1))
          enddo
       enddo
    endif

! Compute Vect wind:
    do j=js,je
       do i=is,ie
          do n=1,3
             v3(n,i,j) = up(i,j)*ec1(n,i,j) + vp(i,j)*ec2(n,i,j) 
          enddo
       enddo
    enddo

    do j=js-1,je+1
       do i=is-1,ie+1
          pin(i,j) = pem(i,k+1,j)
       enddo
    enddo

! Compute pe at 4 cell corners:
    call a2b_ord2(pin, pb, npx, npy, is, ie, js, je, ng)


    do j=js,je+1
       do i=is,ie
          do n=1,3
             pdx(n,i,j) = (pb(i,j)+pb(i+1,j))*dx(i,j)*en1(n,i,j)
          enddo
       enddo
    enddo
    do j=js,je
       do i=is,ie+1
          do n=1,3
             pdy(n,i,j) = (pb(i,j)+pb(i,j+1))*dy(i,j)*en2(n,i,j)
          enddo
       enddo
    enddo

! Compute grad (pe) by Green's theorem
    do j=js,je
       do i=is,ie
          do n=1,3
             grad(n,i,j) = pdx(n,i,j+1) - pdx(n,i,j) - pdy(n,i,j) + pdy(n,i+1,j)
          enddo
       enddo
    enddo

! Compute inner product: V3 * grad (pe)
       do j=js,je
          do i=is,ie
             om(i,j,k) = om(i,j,k) + 0.5*rarea(i,j)*(v3(1,i,j)*grad(1,i,j) +   &
                         v3(2,i,j)*grad(2,i,j) + v3(3,i,j)*grad(3,i,j))
          enddo
       enddo
 enddo

 end subroutine adv_pe 

end module dyn_core_mod


module fv_arrays_mod
#include <fms_platform.h>
 use mpp_domains_mod,  only: domain2d
public
  type fv_atmos_type
     type(domain2d), pointer :: domain =>NULL()
!-----------------------------------------------------------------------
! Five prognostic state variables for the f-v dynamics
!-----------------------------------------------------------------------
! dyn_state:
! D-grid prognostatic variables: u, v, and delp (and other scalars)
!
!     o--------u(i,j+1)----------o
!     |           |              |
!     |           |              |
!  v(i,j)------scalar(i,j)----v(i+1,j)
!     |           |              |
!     |           |              |
!     o--------u(i,j)------------o
!
! The C grid component is "diagnostic" in that it is predicted every time step
! from the D grid variables.
    real, _ALLOCATABLE :: u(:,:,:)    _NULL  ! D grid zonal wind (m/s)
    real, _ALLOCATABLE :: v(:,:,:)    _NULL  ! D grid meridional wind (m/s)
    real, _ALLOCATABLE :: um(:,:,:)   _NULL  ! D grid zonal wind (m/s) at n-1
    real, _ALLOCATABLE :: vm(:,:,:)   _NULL  ! D .... meridional ............
    real, _ALLOCATABLE :: pt(:,:,:)   _NULL  ! temperature (K)
    real, _ALLOCATABLE :: delp(:,:,:) _NULL  ! pressure thickness (pascal)
    real, _ALLOCATABLE :: q(:,:,:,:)  _NULL  ! specific humidity and constituents

!----------------------
! non-hydrostatic state:
!----------------------------------------------------------------------
    real, _ALLOCATABLE ::     w(:,:,:)  _NULL  ! cell center vertical wind (m/s)
    real, _ALLOCATABLE ::  delz(:,:,:)  _NULL  ! layer thickness (meters)
    real, _ALLOCATABLE ::   ze0(:,:,:)  _NULL  ! height at layer edges for remapping

!-----------------------------------------------------------------------
! Auxilliary pressure arrays:
! The 5 vars below can be re-computed from delp and ptop.
!-----------------------------------------------------------------------
! dyn_aux:
    real, _ALLOCATABLE :: ps (:,:)      _NULL  ! Surface pressure (pascal)
    real, _ALLOCATABLE :: pe (:,:,: )   _NULL  ! edge pressure (pascal)
    real, _ALLOCATABLE :: pk  (:,:,:)   _NULL  ! pe**cappa
    real, _ALLOCATABLE :: peln(:,:,:)   _NULL  ! ln(pe)
    real, _ALLOCATABLE :: pkz (:,:,:)   _NULL  ! finite-volume mean pk

! For phys coupling:
    real, _ALLOCATABLE :: u_srf(:,:)    _NULL  ! Surface u-wind
    real, _ALLOCATABLE :: v_srf(:,:)    _NULL  ! Surface v-wind
    real, _ALLOCATABLE :: sgh(:,:)      _NULL  ! Terrain standard deviation
    real, _ALLOCATABLE :: oro(:,:)      _NULL  ! land fraction (1: all land; 0: all water)
    real, _ALLOCATABLE :: ts(:,:)       _NULL  ! skin temperature (sst) from NCEP/GFS (K) -- tile
 
!-----------------------------------------------------------------------
! Others:
!-----------------------------------------------------------------------
    real, _ALLOCATABLE :: phis(:,:)     _NULL  ! Surface geopotential (g*Z_surf)
    real, _ALLOCATABLE :: omga(:,:,:)   _NULL  ! Vertical pressure velocity (pa/s)
    real, _ALLOCATABLE :: ua(:,:,:)     _NULL  ! (ua, va) are mostly used as the A grid winds
    real, _ALLOCATABLE :: va(:,:,:)     _NULL
    real, _ALLOCATABLE :: uc(:,:,:)     _NULL  ! (uc, vc) are mostly used as the C grid winds
    real, _ALLOCATABLE :: vc(:,:,:)     _NULL

    real, _ALLOCATABLE :: ak(:)  _NULL
    real, _ALLOCATABLE :: bk(:)  _NULL

! Accumulated Mass flux arrays
    real, _ALLOCATABLE ::  mfx(:,:,:)  _NULL
    real, _ALLOCATABLE ::  mfy(:,:,:)  _NULL
! Accumulated Courant number arrays
    real, _ALLOCATABLE ::  cx(:,:,:)  _NULL
    real, _ALLOCATABLE ::  cy(:,:,:)  _NULL

! Horizontal Grid descriptors
    real, pointer :: grid(:,:,:)  _NULL  ! Leave as a pointer for now
    real, pointer :: agrid(:,:,:)  _NULL  ! Leave as a pointer for now

    real   :: consv_te

    integer :: isc, iec, jsc, jec
    integer :: isd, ied, jsd, jed
    integer :: ks, npx, npy, npz, npz_rst, ng, ntiles
    integer :: n_sponge    ! Number of sponge layers at the top of the atmosphere
    integer :: k_top       ! Starting layer for non-hydrostatic dynamics
    integer :: ncnst, pnats, ndims, k_split, n_split, m_split, q_split, print_freq
    integer :: nwat        ! water substance
    integer :: fv_sg_adj

! Namelist control values
    logical :: fill
    logical :: range_warn
    logical :: z_tracer
    logical :: do_Held_Suarez
    logical :: reproduce_sum
    logical :: moist_phys
    logical :: srf_init
    logical :: mountain
    logical :: non_ortho
    logical :: adjust_dry_mass
    logical :: hydrostatic, phys_hydrostatic
    logical :: hybrid_z, Make_NH, make_hybrid_z
    logical :: external_ic
    logical :: ncep_ic
    logical :: fv_diag_ic
    logical :: fv_land
    logical :: init_wind_m, no_cgrid
    logical :: nudge
    logical :: tq_filter
    logical :: warm_start

    character(len=128) :: res_latlon_dynamics  ! restart file from the latlon FV core
    character(len=128) :: res_latlon_tracers   ! tracer restart file from the latlon core

    real    :: dry_mass

  end type fv_atmos_type
end module fv_arrays_mod


! $Id: fv_control.F90,v 18.0.4.2.2.1 2010/08/20 16:44:04 rab Exp $
!
!----------------
! FV contro panel
!----------------

module fv_control_mod

   use constants_mod,      only: pi, kappa, radius
   use field_manager_mod,  only: MODEL_ATMOS
   use mpp_mod,            only: FATAL, mpp_error, mpp_pe, stdlog, &
                                 mpp_npes, mpp_get_current_pelist, get_unit, &
                                 input_nml_file
   use mpp_domains_mod,    only: mpp_get_data_domain, mpp_get_compute_domain
   use tracer_manager_mod, only: tm_get_number_tracers => get_number_tracers, &
                                 tm_get_tracer_index   => get_tracer_index,   &
                                 tm_get_tracer_indices => get_tracer_indices, &
                                 tm_set_tracer_profile => set_tracer_profile, &
                                 tm_get_tracer_names   => get_tracer_names,   &
                                 tm_check_if_prognostic=> check_if_prognostic,&
                                 tm_register_tracers   => register_tracers

   use fv_io_mod,          only: fv_io_exit
   use fv_restart_mod,     only: fv_restart_init, fv_restart_end
   use fv_arrays_mod,      only: fv_atmos_type
   use fv_grid_utils_mod,  only: grid_utils_init, grid_utils_end, ptop_min, deglat, &
                                 da_min_c, da_min
   use fv_grid_tools_mod,  only: init_grid, cosa, sina, area, area_c, dx, dy, dxa, dya, &
                                 dxc, dyc, grid_type, dx_const, dy_const,                         &
                                 deglon_start, deglon_stop, deglat_start, deglat_stop, &
                                 read_grid, debug_message_size, write_grid_char_file
   use fv_mp_mod,          only: mp_start, domain_decomp, domain, &
                                 ng, tile, npes_x, npes_y, gid, io_domain_layout
   use test_cases_mod,     only: test_case, alpha
   use fv_timing_mod,      only: timing_on, timing_off, timing_init, timing_prt
   use fv_mapz_mod,        only: mapz_init

   implicit none
   private

!-----------------------------------------------------------------------
! Grid descriptor file setup
!-----------------------------------------------------------------------
   character(len=80) :: grid_name = 'Gnomonic'
   character(len=120):: grid_file = 'Inline'
!   integer      :: grid_type = 0    ! -1: read from file; 0: ED Gnomonic
!                                    !  0: the "true" equal-distance Gnomonic grid
!                                    !  1: the traditional equal-distance Gnomonic grid
!                                    !  2: the equal-angular Gnomonic grid
!                                    !  3: the lat-lon grid -- to be implemented
!                                    !  4: double periodic boundary condition on Cartesian grid
!                                    !  5: channel flow on Cartesian grid
!  -> moved to grid_tools

! Momentum (or KE) options:
   integer :: hord_mt = 9    ! the best option for Gnomonic grids  
   integer :: kord_mt = 8    ! vertical mapping option

! Vorticity & w transport options:
   integer :: hord_vt = 9    ! 10 not recommended (noisy case-5) 

! Heat & air mass (delp) transport options:
   integer :: hord_tm = 9    ! virtual potential temperature
   integer :: hord_dp = 9    ! delp (positive definite)
   integer :: hord_ze = 9    ! edge height (can be negative near the surface)
   integer :: kord_tm =-8    !

! Tracer transport options:
   integer :: hord_tr = 12   !11: PPM mono constraint (Lin 2004); fast 
                             !12: Huynh 2nd constraint (Lin 2004) +
                             !    positive definite (Lin & Rood 1996); slower
                             !>12: positive definite only (Lin & Rood 1996); fastest
   integer :: kord_tr = 8    ! 

   integer :: nord=3         ! 0: del-2, 1: del-4, 2: del-6, 3: del-8 divergence damping
                             ! Alternative setting for high-res: nord=1; d4_bg = 0.075
   real    :: dddmp = 0.0    ! coefficient for del-2 divergence damping (0.2)
                             ! for C90 or lower: 0.2
   real    :: d2_bg = 0.0    ! coefficient for background del-2 divergence damping
   real    :: d4_bg = 0.16   ! coefficient for background del-4(6) divergence damping
                             ! for stability, d4_bg must be <=0.16 if nord=3
   real    :: vtdm4 = 0.0    ! coefficient for del-4 vorticity damping
   real    :: d2_bg_k1 = 4.         ! factor for d2_bg (k=1)
   real    :: d2_bg_k2 = 2.         ! factor for d2_bg (k=2)
   real    :: d2_divg_max_k1 = 0.05 ! d2_divg max value (k=1)
   real    :: d2_divg_max_k2 = 0.02 ! d2_divg max value (k=2)
   real    :: damp_k_k1 = 0.05      ! damp_k value (k=1)
   real    :: damp_k_k2 = 0.025     ! damp_k value (k=2)

! PG off centering:
   real    :: beta1 = 0.0    !
   real    :: beta  = 0.25   ! 0.5 is "neutral" but it may not be stable
#ifdef SW_DYNAMICS
   integer :: n_sponge = 0   ! Number of sponge layers at the top of the atmosphere
   real    :: d_ext = 0.    
   integer :: nwat  = 0      ! Number of water species
   logical :: warm_start = .false. 
#else
   integer :: n_sponge = 1   ! Number of sponge layers at the top of the atmosphere
   real    :: d_ext = 0.02   ! External model damping (was 0.02)
   integer :: nwat  = 3      ! Number of water species
                             ! Set to .F. if cold_start is desired (including terrain generation)
   logical :: warm_start = .true. 
#endif
   integer :: m_riem  = 0    ! Time scheme for Riem solver subcycling
   integer :: k_top   = 1    ! Starting layer for non-hydrostatic dynamics
   integer :: n_split = 0    ! Number of time splits for the lagrangian dynamics
                             ! Default = 0 (automatic computation of best value)
   integer :: m_split = 0    ! Number of time splits for Riemann solver
   integer :: k_split = 1    ! Number of time splits for Remapping

!            For doubly periodic domain with sim_phys
!                     5km        150         20 (7.5 s)  2
!
!                     Estimates for Gnomonic grids:
            !===================================================
            !        dx (km)    dt (sc)    n_split    m_split
            !===================================================
            ! C1000:  ~10        150         16          3
            ! C2000:   ~5         90         18 (5 s)    2
            !===================================================
! The nonhydrostatic algorithm is described in Lin 2006, QJ, (submitted)
! C2000 should easily scale to at least 6 * 100 * 100 = 60,000 CPUs  
! For a 1024 system: try 6 x 13 * 13 = 1014 CPUs
  
   integer :: q_split = 0    ! Number of time splits for tracer transport
   integer :: print_freq = 0 ! Print max/min of selected fields
                             ! 0: off
                             ! positive n: every n hours
                             ! negative n: every time step

!------------------------------------------
! Model Domain parameters
!------------------------------------------
   integer :: npx                     ! Number of Grid Points in X- dir
   integer :: npy                     ! Number of Grid Points in Y- dir
   integer :: npz                     ! Number of Vertical Levels
   integer :: npz_rst = 0             ! Original Vertical Levels (in the restart)
                                      ! 0: no change (default)
   integer :: layout(2)=(/2,2/)       ! Processor layout
   integer :: io_layout(2)=(/0,0/)    ! IO domain processor layout
   integer :: ncnst = 0               ! Number of advected consituents
   integer :: pnats = 0               ! Number of non-advected consituents
   integer :: ntiles                  ! Number or tiles that make up the Grid 
   integer :: ntilesMe                ! Number of tiles on this process =1 for now
   integer, parameter:: ndims = 2     ! Lat-Lon Dims for Grid in Radians
   integer :: nf_omega  = 1           ! Filter omega "nf_omega" times
   integer :: fv_sg_adj = -1          ! Perform grid-scale dry adjustment if > 0
                                      ! Relaxzation time  scale (sec) if positive
#ifdef MARS_GCM
   real    :: p_ref = 600.
   real    :: reference_sfc_pres = 7.7E2
   real    :: sponge_damp=   1.0
   real    :: dry_mass = 7.7E2
#else
   real    :: p_ref = 1.E5
   real    :: dry_mass = 98290.
#endif
   integer :: nt_prog = 0
   integer :: nt_phys = 0
   real    :: tau_h2o = 0.            ! Time scale (days) for ch4_chem

   real    :: too_big  = 1.E35
   real    :: d_con = 0.
   real    :: consv_te = 0.
   real    :: tau = 0.                ! Time scale (days) for Rayleigh friction
   real    :: rf_center = 0.          ! Center position of the hyper-tan profile
                                      ! 0: use the top layer center
                                      ! > 0, [Pascal]
   logical :: tq_filter = .false.
   logical :: filter_phys = .false.
   logical :: dwind_2d = .false.
   logical :: inline_q = .false.
   logical :: breed_vortex_inline = .false.
   logical :: no_cgrid = .false.
   logical :: init_wind_m = .false.
   logical :: range_warn = .false.
   logical :: fill = .false.
   logical :: fill_dp = .false.
   logical :: non_ortho = .true.
   logical :: adiabatic = .false.     ! Run without physics (full or idealized).
   logical :: moist_phys = .true.     ! Run with moist physics
   logical :: do_Held_Suarez = .false.
   logical :: reproduce_sum = .true.  ! Make global sum for consv_te reproduce
   logical :: adjust_dry_mass = .false.
   logical :: fv_debug  = .false.
   logical :: srf_init  = .false.
   logical :: mountain  = .true.
   logical :: uniform_ppm = .true.
   logical :: remap_t  = .true.
   logical :: z_tracer = .true.       ! transport tracers layer by layer with independent
                                      ! time split; use this if tracer number is huge and/or
                                      ! high resolution (nsplt > 1)

   logical :: old_divg_damp = .false. ! parameter to revert damping parameters back to values
                                      ! defined in a previous revision
                                      ! old_values:
                                      !    d2_bg_k1 = 6.           d2_bg_k2 = 4.
                                      !    d2_divg_max_k1 = 0.02   d2_divg_max_k2 = 0.01
                                      !    damp_k_k1 = 0.          damp_k_k2 = 0.
                                      ! current_values:
                                      !    d2_bg_k1 = 4.           d2_bg_k2 = 2.
                                      !    d2_divg_max_k1 = 0.05   d2_divg_max_k2 = 0.02
                                      !    damp_k_k1 = 0.05        damp_k_k2 = 0.025
   logical :: master

   logical :: fv_land = .false.       ! To cold starting the model with USGS terrain
!--------------------------------------------------------------------------------------
! The following options are useful for NWP experiments using datasets on the lat-lon grid
!--------------------------------------------------------------------------------------
   logical :: nudge = .false.         ! Perform nudging
   logical :: ncep_ic = .false.       ! use NCEP ICs 
   logical :: fv_diag_ic = .false.    ! reconstruct IC from fv_diagnostics on lat-lon grid
   logical :: external_ic = .false.   ! use ICs from external sources; e.g. lat-lon FV core
                                      ! or NCEP re-analysis; both vertical remapping & horizontal
                                      ! (lat-lon to cubed sphere) interpolation will be done
! Default restart files from the "Memphis" latlon FV core:
   character(len=128) :: res_latlon_dynamics = 'INPUT/fv_rst.res.nc'
   character(len=128) :: res_latlon_tracers  = 'INPUT/atmos_tracers.res.nc'
! The user also needs to copy the "cold start" cubed sphere restart files (fv_core.res.tile1-6)
! to the INPUT dir during runtime
!------------------------------------------------
! Parameters related to non-hydrostatic dynamics:
!------------------------------------------------
   logical :: hydrostatic = .true.
   logical :: phys_hydrostatic = .true.    ! heating/cooling term from the physics is hydrostatic
   logical :: hybrid_z    = .false. ! use hybrid_z for remapping
   logical :: quick_p_c   = .false. ! Use quick (approximated) algorithm for Riemann Solver (C grid)
   logical :: quick_p_d   = .false. ! Use quick (approximated) algorithm for Riemann Solver (D grid)
                                    ! The above two options run much faster; but it may be unstable
   logical :: Make_NH     = .false. ! Initialize (w, delz) from hydro restart file 
   logical :: make_hybrid_z  = .false. ! transform hydrostatic eta-coord IC into non-hydrostatic hybrid_z
   integer :: m_grad_p = 0   ! method for non-hydrostatic grad-p
                             ! m_grad_p=1:  one-stage full pressure for grad_p; this option is faster
                             !              but it is not suitable for low horizontal resolution
                             ! m_grad_p=0:  two-stage grad computation (best for low resolution runs)
   integer :: a2b_ord = 4    ! order for interpolation from A to B Grid (corners)
   integer :: c2l_ord = 4    ! order for interpolation from D to lat-lon A winds for phys & output
   real    :: ppm_limiter = 2.
   public :: npx,npy,npz, npz_rst, ntiles, ncnst, pnats, nwat
   public :: hord_mt, hord_vt, kord_mt, hord_tm, hord_dp, hord_ze, kord_tm, hord_tr, kord_tr
   public :: nord, no_cgrid, fill_dp, inline_q, breed_vortex_inline, dwind_2d, filter_phys, tq_filter 
   public :: k_split, n_split, m_split, q_split, master
   public :: dddmp, d2_bg, d4_bg, d_ext, vtdm4, beta1, beta, init_wind_m, ppm_limiter
   public :: k_top, m_riem, n_sponge, p_ref, mountain
   public :: uniform_ppm, remap_t,  z_tracer, fv_debug
   public :: external_ic, ncep_ic, fv_diag_ic, res_latlon_dynamics, res_latlon_tracers, fv_land
   public :: fv_sg_adj, tau, tau_h2o, rf_center, d_con
   public :: fv_init, fv_end
   public :: domain
   public :: adiabatic, nf_omega, moist_phys, range_warn
   public :: hydrostatic, phys_hydrostatic,  hybrid_z, quick_p_c, quick_p_d, m_grad_p, a2b_ord
   public :: nt_prog, nt_phys
   public :: d2_bg_k1, d2_bg_k2, d2_divg_max_k1, d2_divg_max_k2, damp_k_k1, damp_k_k2

#ifdef MARS_GCM
   public :: reference_sfc_pres, sponge_damp
#endif MARS

   integer, allocatable :: pelist(:)
   integer :: commID

 contains

!-------------------------------------------------------------------------------
         
 subroutine fv_init(Atm, dt_atmos)

   type(fv_atmos_type), intent(inout) :: Atm(:)
   real,                intent(in)    :: dt_atmos

   integer :: i, j, k, n
   integer :: isc, iec, jsc, jec
   integer :: isd, ied, jsd, jed
   real :: sdt


! tracers
   integer :: num_family          ! output of register_tracers

! Start up MPI
      allocate( pelist(mpp_npes()) )
      call mpp_get_current_pelist( pelist, commID=commID )
      call mp_start(commID)  ! fv_mp_mod will eventually be eliminated

      master = gid==0

    ! Initialize timing routines
      call timing_init
      call timing_on('TOTAL')

    ! Setup the run from namelist 
      ntilesMe = size(Atm(:))
      if(ntilesMe > 1)call mpp_error(FATAL,'More than 1 tile per process not implemented')

      call run_setup(Atm(1),dt_atmos)   ! initializes domain_decomp
                                        ! needs modification for multiple tiles
      k_top = max(1, k_top)   ! to idiot proof


!--------------------------------------------------
! override number of tracers by reading field_table
!--------------------------------------------------

      call tm_register_tracers (MODEL_ATMOS, ncnst, nt_prog, pnats, num_family)
      if(master) write(*,*) 'ncnst=', ncnst,' num_prog=',nt_prog,' pnats=',pnats,' num_family=',num_family

      Atm(1)%npx=npx; Atm(1)%npy=npy; Atm(1)%npz=npz; Atm(1)%ng=ng
      Atm(1)%npz_rst = npz_rst
      Atm(1)%k_split = k_split
      Atm(1)%n_split = n_split
      Atm(1)%m_split = m_split
      Atm(1)%q_split = q_split
      Atm(1)%print_freq = print_freq
      Atm(1)%consv_te = consv_te
      Atm(1)%ncnst = ncnst
      Atm(1)%pnats = pnats
      Atm(1)%nwat  = nwat 
      Atm(1)%range_warn = range_warn
      Atm(1)%fill = fill
      Atm(1)%warm_start = warm_start
      Atm(1)%tq_filter = tq_filter
      Atm(1)%no_cgrid = no_cgrid
      Atm(1)%init_wind_m = init_wind_m
      Atm(1)%z_tracer = z_tracer
      Atm(1)%do_Held_Suarez = do_Held_Suarez
      Atm(1)%reproduce_sum = reproduce_sum
      Atm(1)%moist_phys = moist_phys
      Atm(1)%srf_init = srf_init
      Atm(1)%mountain = mountain
      Atm(1)%non_ortho = non_ortho
      Atm(1)%adjust_dry_mass = adjust_dry_mass
      Atm(1)%fv_sg_adj = fv_sg_adj
      Atm(1)%dry_mass = dry_mass

      Atm(1)%fv_diag_ic = fv_diag_ic
      Atm(1)%ncep_ic = ncep_ic

      if ( ncep_ic .or. fv_diag_ic)  external_ic = .true.
      Atm(1)%external_ic = external_ic

      Atm(1)%nudge = nudge

      Atm(1)%fv_land     = fv_land
      Atm(1)%res_latlon_dynamics =  res_latlon_dynamics
      Atm(1)%res_latlon_tracers  =  res_latlon_tracers

      Atm(1)%hydrostatic = hydrostatic
      Atm(1)%phys_hydrostatic = phys_hydrostatic
      Atm(1)%hybrid_z    = hybrid_z
      Atm(1)%Make_NH     = Make_NH
      Atm(1)%make_hybrid_z  = make_hybrid_z
      Atm(1)%k_top       = k_top

    ! Read Grid from GRID_FILE and setup grid descriptors
    ! needs modification for multiple tiles
      
      if(grid_type <0 .AND. trim(grid_file) == 'INPUT/grid_spec.nc') then
         call read_grid(Atm(1), grid_name, grid_file, npx, npy, npz, ndims, ntiles, ng)
      else
         call init_grid(Atm(1), grid_name, grid_file, npx, npy, npz, ndims, ntiles, ng)
      endif
      Atm(1)%ndims = ndims
      Atm(1)%ntiles = ntiles

    ! Initialize the SW (2D) part of the model
      call grid_utils_init(Atm(1), Atm(1)%npx, Atm(1)%npy, Atm(1)%npz, Atm(1)%grid, Atm(1)%agrid,   &
                           area, area_c, cosa, sina, dx, dy, dxa, dya, dxc, dyc, non_ortho,   &
                           uniform_ppm, grid_type, c2l_ord)

      if ( master ) then
           sdt =  dt_atmos/real(n_split*k_split)
           write(*,*) ' '
           write(*,*) 'Divergence damping Coefficients * 1.E6:'
           write(*,*) 'For small dt=', sdt
           write(*,*) 'External mode del-2 (m**2/s)=',  d_ext*da_min_c     /sdt*1.E-6
           write(*,*) 'Internal mode del-2 SMAG dimensionless coeff=',  dddmp
           write(*,*) 'Internal mode del-2 background diff=', d2_bg

           if (nord==1) write(*,*) 'Internal mode del-4 background diff=', d4_bg
           if (nord==2) write(*,*) 'Internal mode del-6 background diff=', d4_bg
           if (nord==3) write(*,*) 'Internal mode del-8 background diff=', d4_bg

           write(*,*) 'Vorticity del-4 (m**4/s)=', (vtdm4*da_min)**2/sdt*1.E-6
           write(*,*) ' '
      endif

      Atm(1)%domain =>domain
      do n = 1, ntilesMe
        call mpp_get_compute_domain(domain,isc,iec,jsc,jec,tile_count=n)
        call mpp_get_data_domain(domain,isd,ied,jsd,jed,tile_count=n)
        if ( (iec-isc+1).lt.4 .or. (jec-jsc+1).lt.4 ) &
           call mpp_error(FATAL,'Domain Decomposition:  Cubed Sphere compute domain has a &
                                &minium requirement of 4 points in X and Y, respectively')
        Atm(n)%isc = isc; Atm(n)%iec = iec
        Atm(n)%jsc = jsc; Atm(n)%jec = jec
        Atm(n)%isd = isd; Atm(n)%ied = ied
        Atm(n)%jsd = jsd; Atm(n)%jed = jed

      ! Allocate State Variables
        allocate (    Atm(n)%u(isd:ied  ,jsd:jed+1,npz) )
        allocate (    Atm(n)%v(isd:ied+1,jsd:jed  ,npz) )

        if ( no_cgrid ) then
             allocate ( Atm(n)%um(isd:ied  ,jsd:jed+1,npz) )
             allocate ( Atm(n)%vm(isd:ied+1,jsd:jed  ,npz) )
        else
             allocate ( Atm(n)%um(1,1,1) )
             allocate ( Atm(n)%vm(1,1,1) )
        endif

        allocate (   Atm(n)%pt(isd:ied  ,jsd:jed  ,npz) )
        allocate ( Atm(n)%delp(isd:ied  ,jsd:jed  ,npz) )
        allocate (    Atm(n)%q(isd:ied  ,jsd:jed  ,npz, ncnst) )

      ! Allocate Auxilliary pressure arrays
        allocate (   Atm(n)%ps(isd:ied  ,jsd:jed) )
        allocate (   Atm(n)%pe(isc-1:iec+1, npz+1,jsc-1:jec+1) )
        allocate (   Atm(n)%pk(isc:iec    ,jsc:jec  , npz+1) )
        allocate ( Atm(n)%peln(isc:iec,npz+1,jsc:jec) )
        allocate (  Atm(n)%pkz(isc:iec,jsc:jec,npz) )

        allocate ( Atm(n)%u_srf(isc:iec,jsc:jec) )
        allocate ( Atm(n)%v_srf(isc:iec,jsc:jec) )

        if ( fv_land ) then
             allocate ( Atm(n)%sgh(isc:iec,jsc:jec) )
             allocate ( Atm(n)%oro(isc:iec,jsc:jec) )
        else
             allocate ( Atm(n)%oro(1,1) )
        endif

      ! Allocate others
        allocate ( Atm(n)%ts(isc:iec,jsc:jec) )
        allocate ( Atm(n)%phis(isd:ied  ,jsd:jed  ) )
        allocate ( Atm(n)%omga(isd:ied  ,jsd:jed  ,npz) ); Atm(n)%omga=0.
        allocate (   Atm(n)%ua(isd:ied  ,jsd:jed  ,npz) )
        allocate (   Atm(n)%va(isd:ied  ,jsd:jed  ,npz) )
        allocate (   Atm(n)%uc(isd:ied+1,jsd:jed  ,npz) )
        allocate (   Atm(n)%vc(isd:ied  ,jsd:jed+1,npz) )
      ! For tracer transport:
        allocate ( Atm(n)%mfx(isc:iec+1, jsc:jec,  npz) )
        allocate ( Atm(n)%mfy(isc:iec  , jsc:jec+1,npz) )
        allocate (  Atm(n)%cx(isc:iec+1, jsd:jed, npz) )
        allocate (  Atm(n)%cy(isd:ied ,jsc:jec+1, npz) )

!--------------------------
! Non-hydrostatic dynamics:
!--------------------------
      if ( hydrostatic ) then
          allocate (    Atm(n)%w(1, 1  ,1) )
          allocate ( Atm(n)%delz(1, 1  ,1) )
          allocate (  Atm(n)%ze0(1, 1  ,1) )
      else
          allocate (    Atm(n)%w(isd:ied, jsd:jed  ,npz  ) )
          allocate ( Atm(n)%delz(isc:iec, jsc:jec  ,npz) )
          if( hybrid_z ) then
             allocate (  Atm(n)%ze0(isc:iec, jsc:jec ,npz+1) )
          else
             allocate (  Atm(n)%ze0(1, 1  ,1) )
          endif
!         allocate ( mono(isd:ied, jsd:jed, npz))
      endif
 
        Atm(n)%ts   = 0.
        Atm(n)%phis = too_big
! The following statements are to prevent the phatom corner regions from
! growing instability
        Atm(n)%u  = 0.
        Atm(n)%v  = 0.
        Atm(n)%ua = too_big
        Atm(n)%va = too_big

        if ( no_cgrid ) then
             Atm(n)%um = 0.
             Atm(n)%vm = 0.
        endif

      end do
      
    ! Initialize restart functions
      call fv_restart_init()

    ! Initialize mapz (to be removed for S)
      call mapz_init

 end subroutine fv_init
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
         
 subroutine fv_end(Atm)

    type(fv_atmos_type), intent(inout) :: Atm(:)

    integer :: n

    call timing_off('TOTAL')
    call timing_prt( mpp_pe() )

    call fv_restart_end(Atm)
    call fv_io_exit()

  ! Free temporary memory from sw_core routines

  ! Deallocate
    call grid_utils_end( uniform_ppm )

    do n = 1, ntilesMe
      deallocate (    Atm(n)%u )
      deallocate (    Atm(n)%v )
      deallocate (    Atm(n)%um )
      deallocate (    Atm(n)%vm )
      deallocate (   Atm(n)%pt )
      deallocate ( Atm(n)%delp )
      deallocate (    Atm(n)%q )
      deallocate (   Atm(n)%ps )
      deallocate (   Atm(n)%pe )
      deallocate (   Atm(n)%pk )
      deallocate ( Atm(n)%peln )
      deallocate (  Atm(n)%pkz )
      deallocate ( Atm(n)%phis )
      deallocate ( Atm(n)%omga )
      deallocate (   Atm(n)%ua )
      deallocate (   Atm(n)%va )
      deallocate (   Atm(n)%uc )
      deallocate (   Atm(n)%vc )
      deallocate ( Atm(n)%mfx )
      deallocate ( Atm(n)%mfy )
      deallocate (  Atm(n)%cx )
      deallocate (  Atm(n)%cy )
      deallocate (  Atm(n)%ak )
      deallocate (  Atm(n)%bk )

      deallocate ( Atm(n)%u_srf )
      deallocate ( Atm(n)%v_srf )
      if( fv_land ) deallocate ( Atm(n)%sgh )
      deallocate ( Atm(n)%oro )

! Non-hydrostatic:
      deallocate ( Atm(n)%w )
      deallocate ( Atm(n)%delz  )
      deallocate ( Atm(n)%ze0   )
    end do


 end subroutine fv_end
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
!
!     run_setup :: initialize run from namelist
!
      subroutine run_setup(Atm, dt_atmos)
      type(fv_atmos_type), intent(inout) :: Atm
      real, intent(in)                   :: dt_atmos

      character(len=80) :: filename, tracerName
      integer :: ios, f_unit
      logical :: exists

      real :: dim0 = 180.           ! base dimension
      real :: dt0  = 1800.          ! base time step
      real :: ns0  = 5.             ! base nsplit for base dimension 
                                    ! For cubed sphere 5 is better
      real :: umax = 350.           ! max wave speed for grid_type>3
      real :: dimx, dl, dp, dxmin, dymin, d_fac

      integer :: n0split
      integer :: unit

      namelist /mpi_nml/npes_x,npes_y  ! Use of this namelist is deprecated
      namelist /fv_grid_nml/grid_name,grid_file
      namelist /fv_core_nml/npx, npy, ntiles, npz, npz_rst, layout, io_layout, ncnst, nwat,  &
                            k_split, n_split, m_split, q_split, print_freq,   &
                            hord_mt, hord_vt, hord_tm, hord_dp, hord_ze, hord_tr, &
                            kord_mt, kord_tm, kord_tr, fv_debug, fv_land, nudge,  &
                            external_ic, ncep_ic, fv_diag_ic, res_latlon_dynamics, res_latlon_tracers, &
                            dddmp, d2_bg, d4_bg, vtdm4, d_ext, beta1, beta, non_ortho, n_sponge, &
                            warm_start, adjust_dry_mass, mountain, d_con, nord, no_cgrid, init_wind_m, &
                            dry_mass, grid_type, do_Held_Suarez, consv_te, fill, tq_filter, filter_phys, fill_dp, &
                            range_warn, dwind_2d, inline_q, z_tracer, reproduce_sum, adiabatic,        &
                            tau, tau_h2o, rf_center, nf_omega, hydrostatic, fv_sg_adj, breed_vortex_inline,  &
                            hybrid_z, quick_p_c, quick_p_d, Make_NH, m_grad_p,   &
                            a2b_ord, uniform_ppm, remap_t, k_top, m_riem, p_ref, &
#ifdef MARS_GCM
                            sponge_damp, reference_sfc_pres,                     &
#endif
                            c2l_ord, dx_const, dy_const, umax, deglat,     &
                            deglon_start, deglon_stop, deglat_start, deglat_stop, &
                            phys_hydrostatic, make_hybrid_z, ppm_limiter, old_divg_damp, &
                            debug_message_size, write_grid_char_file


      namelist /test_case_nml/test_case,alpha

! Make alpha = 0 the default:
      alpha = 0.
      test_case = 11   ! (USGS terrain)

 ! Read Main namelist
#ifdef INTERNAL_FILE_NML
      read (input_nml_file,fv_grid_nml,iostat=ios)
#else
      f_unit = get_unit()
      filename = "input.nml"
      open (f_unit,file=filename)
 ! Read Main namelist
      rewind (f_unit)
      read (f_unit,fv_grid_nml,iostat=ios)
#endif
      if (ios .gt. 0) then
         if(master) write(6,*) 'fv_grid_nml ERROR: reading ',trim(filename),', iostat=',ios
         call mpp_error(FATAL,'FV core terminating')
      endif
      unit = stdlog()
      write(unit, nml=fv_grid_nml)

 ! Read FVCORE namelist 
#ifdef INTERNAL_FILE_NML
      read (input_nml_file,fv_core_nml,iostat=ios)
#else
      rewind (f_unit)
      read (f_unit,fv_core_nml,iostat=ios)
#endif
      if (ios .ne. 0) then
         if(master) write(6,*) 'fv_core_nml ERROR: reading ',trim(filename),', iostat=',ios
         call mpp_error(FATAL,'FV core terminating')
      endif
      unit = stdlog()
      write(unit, nml=fv_core_nml)

!*** single tile for Cartesian grids
      if (grid_type>3) then
         ntiles=1
         non_ortho = .false.
         uniform_ppm = .true.
         nf_omega = 0
      endif

!*** remap_t is NOT yet supported for non-hydrostatic option *****
      if ( .not. hydrostatic ) remap_t = .false.

      npes_x = layout(1)
      npes_y = layout(2)
      io_domain_layout = io_layout

 ! Read Test_Case namelist
#ifdef INTERNAL_FILE_NML
      read (input_nml_file,test_case_nml,iostat=ios)
#else
      rewind (f_unit)
      read (f_unit,test_case_nml,iostat=ios)
#endif
      if (ios .gt. 0) then
       if(master) write(6,*) 'test_case_nml ERROR: reading ',trim(filename),', iostat=',ios
          call mpp_error(FATAL,'FV core terminating')
      endif
      unit = stdlog()
      write(unit, nml=test_case_nml)

 ! Look for deprecated mpi_nml
#ifdef INTERNAL_FILE_NML
      read (input_nml_file,mpi_nml,iostat=ios)
#else
      rewind (f_unit)
      read (f_unit,mpi_nml,iostat=ios)
      close (f_unit)
#endif
      if (ios == 0) then
         call mpp_error(FATAL,'mpi_nml is deprecated. Use layout in fv_core_nml')
      endif


! Define n_split if not in namelist
          if (ntiles==6) then
             dimx = 4.0*(npx-1)
#ifdef MARS_GCM
             ns0 = 8
#else
             if ( hydrostatic ) then
                  if ( npx >= 120 ) ns0 = 6
             else
                  if ( npx <= 45 ) then
                       ns0 = 6
                  elseif ( npx <=90 ) then
                       ns0 = 7
                  else
                       ns0 = 8
                  endif
             endif
#endif
          else
             dimx = max ( npx, 2*(npy-1) )
          endif
          
          if (grid_type < 4) then
             n0split = nint ( ns0*abs(dt_atmos)*dimx/(dt0*dim0) + 0.49 )
          elseif (grid_type == 4 .or. grid_type == 7) then
             n0split = nint ( 2.*umax*dt_atmos/sqrt(dx_const**2 + dy_const**2) + 0.49 )
          elseif (grid_type == 5 .or. grid_type == 6) then
             if (grid_type == 6) then
                deglon_start = 0.; deglon_stop  = 360.
             endif
             dl = (deglon_stop-deglon_start)*pi/(180.*(npx-1))
             dp = (deglat_stop-deglat_start)*pi/(180.*(npy-1))

             dxmin=dl*radius*min(cos(deglat_start*pi/180.-ng*dp),   &
                                 cos(deglat_stop *pi/180.+ng*dp))
             dymin=dp*radius
             n0split = nint ( 2.*umax*dt_atmos/sqrt(dxmin**2 + dymin**2) + 0.49 )
          endif
          n0split = max ( 1, n0split )

      if ( n_split == 0 ) then
           n_split = n0split/k_split
           if(master) write(6,*) 'For k_split (remapping)=', k_split
           if(master) write(6,198) 'n_split is set to ', n_split, ' for resolution-dt=',npx,npy,ntiles,dt_atmos
      else
          if(master) write(6,199) 'Using n_split from the namelist: ', n_split
      endif

!----------------------------------------
! Adjust divergence damping coefficients:
!----------------------------------------
!      d_fac = real(n0split)/real(n_split)
!      dddmp = dddmp * d_fac
!      d2_bg = d2_bg * d_fac
!      d4_bg = d4_bg * d_fac
!      d_ext = d_ext * d_fac
!      vtdm4 = vtdm4 * d_fac
      if (old_divg_damp) then
        if (master) write(6,*) " fv_control: using original values for divergence damping "
        d2_bg_k1 = 6.         ! factor for d2_bg (k=1)  - default(4.)
        d2_bg_k2 = 4.         ! factor for d2_bg (k=2)  - default(2.)
        d2_divg_max_k1 = 0.02 ! d2_divg max value (k=1) - default(0.05)
        d2_divg_max_k2 = 0.01 ! d2_divg max value (k=2) - default(0.02)
        damp_k_k1 = 0.        ! damp_k value (k=1)      - default(0.05)
        damp_k_k2 = 0.        ! damp_k value (k=2)      - default(0.025)
      endif

      if ( (.not.hydrostatic) .and. (m_split==0) ) then
           m_split = max(1., 0.5 + abs(dt_atmos)/(n_split*6.) )
           if(master) write(*,198) 'm_split is set to ', m_split
      endif

      if(master) then
         write(6,199) 'Using n_sponge : ', n_sponge
         write(6,197) 'Using non_ortho : ', non_ortho
      endif

      if ( hydrostatic ) m_grad_p = 1

 197  format(A,l7)
 198  format(A,i2.2,A,i4.4,'x',i4.4,'x',i1.1,'-',f9.3)
 199  format(A,i2.2)
! 200  format(A,A,i4.4,A,i4.4,A)
! 201  format(A,A,f5.3,A,i4.4,A,i4.4,A)
! 202  format(A,A,A,i4.4,A,i4.4,A)
! 210  format(A,A,f5.3,A,i4.4,A,i4.4,A,i2.2,A)

      alpha = alpha*pi

      call domain_decomp(npx,npy,ntiles,ng,grid_type)

  end subroutine run_setup


end module fv_control_mod


module fv_dynamics_mod
   use constants_mod,      only: grav, pi, radius, hlv    ! latent heat of water vapor
   use dyn_core_mod,       only: dyn_core
   use fv_mapz_mod,        only: compute_total_energy, Lagrangian_to_Eulerian
   use fv_tracer2d_mod,    only: tracer_2d, tracer_2d_1L
   use fv_grid_tools_mod,  only: agrid
   use fv_control_mod,     only: hord_mt, hord_vt, hord_tm, hord_tr, &
                                 kord_mt, kord_tm, kord_tr, moist_phys, range_warn, &
                                 inline_q, z_tracer, tau, rf_center, nf_omega,   &
                                 remap_t,  k_top, p_ref, nwat, fv_debug, k_split
   use fv_grid_utils_mod,  only: sina_u, sina_v, sw_corner, se_corner, &
                                 ne_corner, nw_corner, da_min, ptop,   &
                                 cubed_to_latlon, c2l_ord2
   use fv_grid_tools_mod,  only: dx, dy, rdxa, rdya, rdxc, rdyc, area, rarea
   use fv_mp_mod,          only: is,js,ie,je, isd,jsd,ied,jed, gid, domain
   use fv_timing_mod,      only: timing_on, timing_off
   use diag_manager_mod,   only: send_data
   use fv_diagnostics_mod, only: id_divg, id_te, fv_time, prt_maxmin, range_check
   use mpp_domains_mod,    only: DGRID_NE, mpp_update_domains
   use field_manager_mod,  only: MODEL_ATMOS
   use tracer_manager_mod, only: get_tracer_index
   use fv_sg_mod,          only: neg_adj3
   use tp_core_mod,        only: copy_corners

#ifdef WAVE_MAKER
   use time_manager_mod,   only: get_time
#endif

implicit none
   logical :: RF_initialized = .false.
   logical :: bad_range
   real, allocatable ::  rf(:), rw(:)
   integer :: kmax=1
private
public :: fv_dynamics


contains

!-----------------------------------------------------------------------
!     fv_dynamics :: FV dynamical core driver
!-----------------------------------------------------------------------
 
  subroutine fv_dynamics(npx, npy, npz, nq,  ng, bdt, consv_te, fill,               &
                        reproduce_sum, kappa, cp_air, zvir, ks, ncnst, n_split,     &
                        q_split, u, v, um, vm, w, delz, hydrostatic, pt, delp, q,           &
                        ps, pe, pk, peln, pkz, phis, omga, ua, va, uc, vc,          &
                        ak, bk, mfx, mfy, cx, cy, ze0, hybrid_z, time_total)

    real, intent(IN) :: bdt  ! Large time-step
    real, intent(IN) :: consv_te
    real, intent(IN) :: kappa, cp_air
    real, intent(IN) :: zvir
    real, intent(IN), optional :: time_total

    integer, intent(IN) :: npx
    integer, intent(IN) :: npy
    integer, intent(IN) :: npz
    integer, intent(IN) :: nq             ! transported tracers
    integer, intent(IN) :: ng
    integer, intent(IN) :: ks
    integer, intent(IN) :: ncnst
    integer, intent(IN) :: n_split        ! small-step horizontal dynamics
    integer, intent(IN) :: q_split        ! tracer
    logical, intent(IN) :: fill
    logical, intent(IN) :: reproduce_sum
    logical, intent(IN) :: hydrostatic
    logical, intent(IN) :: hybrid_z       ! Using hybrid_z for remapping

    real, intent(inout), dimension(isd:ied  ,jsd:jed+1,npz) :: u, um ! D grid zonal wind (m/s)
    real, intent(inout), dimension(isd:ied+1,jsd:jed  ,npz) :: v, vm ! D grid meridional wind (m/s)
    real, intent(inout) :: w(   isd:ied  ,jsd:jed  ,npz)  !  W (m/s)
    real, intent(inout) :: pt(  isd:ied  ,jsd:jed  ,npz)  ! temperature (K)
    real, intent(inout) :: delp(isd:ied  ,jsd:jed  ,npz)  ! pressure thickness (pascal)
    real, intent(inout) :: q(   isd:ied  ,jsd:jed  ,npz, ncnst) ! specific humidity and constituents
    real, intent(inout) :: delz(is:ie,js:je,npz)   ! delta-height (m); non-hydrostatic only
    real, intent(inout) ::  ze0(is:ie,js:je,npz+1) ! height at edges (m); non-hydrostatic

!-----------------------------------------------------------------------
! Auxilliary pressure arrays:    
! The 5 vars below can be re-computed from delp and ptop.
!-----------------------------------------------------------------------
! dyn_aux:
    real, intent(inout) :: ps  (isd:ied  ,jsd:jed)           ! Surface pressure (pascal)
    real, intent(inout) :: pe  (is-1:ie+1, npz+1,js-1:je+1)  ! edge pressure (pascal)
    real, intent(inout) :: pk  (is:ie,js:je, npz+1)          ! pe**cappa
    real, intent(inout) :: peln(is:ie,npz+1,js:je)           ! ln(pe)
    real, intent(inout) :: pkz (is:ie,js:je,npz)             ! finite-volume mean pk
    
!-----------------------------------------------------------------------
! Others:
!-----------------------------------------------------------------------
    real, intent(inout) :: phis(isd:ied,jsd:jed)       ! Surface geopotential (g*Z_surf)
    real, intent(inout) :: omga(isd:ied,jsd:jed,npz)   ! Vertical pressure velocity (pa/s)
    real, intent(inout) :: uc(isd:ied+1,jsd:jed  ,npz) ! (uc,vc) mostly used as the C grid winds
    real, intent(inout) :: vc(isd:ied  ,jsd:jed+1,npz)

    real, intent(inout), dimension(isd:ied ,jsd:jed ,npz):: ua, va
    real, intent(in),    dimension(npz+1):: ak, bk

! Accumulated Mass flux arrays: the "Flux Capacitor"
    real, intent(inout) ::  mfx(is:ie+1, js:je,   npz)
    real, intent(inout) ::  mfy(is:ie  , js:je+1, npz)
! Accumulated Courant number arrays
    real, intent(inout) ::  cx(is:ie+1, jsd:jed, npz)
    real, intent(inout) ::  cy(isd:ied ,js:je+1, npz)


! Local Arrays
      real:: q2(isd:ied,jsd:jed,nq)
      real:: te_2d(is:ie,js:je)
      real::   teq(is:ie,js:je)
      real:: pfull(npz)
      real:: gz(is:ie)
      real, allocatable :: dp1(:,:,:)
      real, allocatable :: pem(:,:,:)
      real:: akap, rg, ph1, ph2, mdt
      integer :: i,j,k, iq, n_map
      integer :: sphum, liq_wat, ice_wat      ! GFDL physics
      integer :: rainwat, snowwat, graupel, cld_amt
      logical used, last_step
!      real te_den

#ifdef WAVE_MAKER
      integer seconds, days
      real  r0, stime

         call get_time (fv_time, seconds,  days)
         r0 = pi/30.
         stime = real(seconds)/86400.*2.*pi
         do j=jsd,jed
            do i=isd,ied
               phis(i,j) = grav*250.*sin(agrid(i,j,1))*sin(stime) / exp( (agrid(i,j,2)/r0)**2 )
            enddo
         enddo
#endif
      allocate ( dp1(is:ie, js:je, 1:npz) )
      allocate ( pem(is-1:ie+1, 1:npz+1, js-1:je+1) )

#ifdef SW_DYNAMICS
      akap  = 1.
#else
      if ( nwat==6 ) then
             sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
           liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
           ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
           rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
           snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
           graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
           cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt')
      else
           sphum = 1
      endif

      akap  = kappa
      rg = kappa*cp_air

      do k=1,npz
         ph1 = ak(k  ) + bk(k  )*p_ref
         ph2 = ak(k+1) + bk(k+1)*p_ref
         pfull(k) = (ph2 - ph1) / log(ph2/ph1)
      enddo

      if ( fv_debug ) then
         call prt_maxmin('T_dyn_b',   pt, is, ie, js, je, ng, npz, 1., gid==0)
         call prt_maxmin('delp_b ', delp, is, ie, js, je, ng, npz, 0.01, gid==0)
      endif

!---------------------
! Compute Total Energy
!---------------------
      if ( consv_te > 0. ) then
           call compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, npz,  &
                                     u, v, w, delz, pt, delp, q, pe, peln, phis, &
                                     zvir, cp_air, rg, hlv, te_2d, ua, va, teq,  &
                                     moist_phys, sphum, hydrostatic, id_te)
           if( id_te>0 ) then
               used = send_data(id_te, teq, fv_time)
!              te_den=1.E-9*g_sum(teq, is, ie, js, je, ng, area, 0)/(grav*4.*pi*radius**2)
!              if(gid==0)  write(*,*) 'Total Energy Density (Giga J/m**2)=',te_den
           endif
      endif

      if( tau > 0. )      &
      call Rayleigh_Friction(bdt, npx, npy, npz, ks, pfull, tau, rf_center, u, v, w, pt,  &
                             ua, va, delz, cp_air, rg,  hydrostatic, .true.)

! Convert pt to virtual potential temperature * CP
!$omp parallel do default(shared) private(i, j, k)
      do k=1,npz
         do j=js,je
            do i=is,ie
                pt(i,j,k) = cp_air*pt(i,j,k)/pkz(i,j,k)*(1.+zvir*q(i,j,k,sphum))
            enddo
         enddo
      enddo
#endif

  mdt = bdt / real(k_split)

  do n_map=1, k_split   ! first level of time-split

     if ( n_map==k_split )  then
          last_step = .true.
     else
          last_step = .false.
     endif

!$omp parallel do default(shared) private(i, j, k)
      do k=1,npz
         do j=js,je
            do i=is,ie
               dp1(i,j,k) = delp(i,j,k)
            enddo
         enddo
      enddo

      call dyn_core(npx, npy, npz, ng, sphum, nq, mdt, n_split, zvir, cp_air, akap, grav, hydrostatic, &
                    u, v, um, vm, w, delz, pt, q, delp, pe, pk, phis, omga, ptop, pfull, ua, va,       & 
                    uc, vc, mfx, mfy, cx, cy, pem, pkz, peln, ak, bk, n_map==1, last_step, time_total)

#ifdef SW_DYNAMICS
      do j=js,je
         do i=is,ie
            ps(i,j) = delp(i,j,1) / grav
         enddo
      enddo
#else
      if ( inline_q ) then
! diagnose divergence:
      elseif( nq /= 0 ) then    
!--------------------------------------------------------
! Perform large-time-step scalar transport using the accumulated CFL and
! mass fluxes
         call timing_on('tracer_2d')
       if ( z_tracer ) then
         do k=1,npz
            do iq=1,nq
            do j=js,je
               do i=is,ie                   ! To_do list:
                  q2(i,j,iq) = q(i,j,k,iq)  ! The data copying can be avoided if q is
                                            ! re-dimensioned as q(i,j,nq,k)
               enddo
            enddo
            enddo
         call tracer_2d_1L(q2, dp1(is,js,k), mfx(is,js,k), mfy(is,js,k), &
                           cx(is,jsd,k),  cy(isd,js,k), npx, npy, npz,   &
                           nq, hord_tr, q_split, k, q, mdt, id_divg)
         enddo
       else
         call tracer_2d(q, dp1, mfx, mfy, cx, cy, npx, npy, npz, nq, &
                        hord_tr, q_split, mdt, id_divg)
       endif
         call timing_off('tracer_2d')
         if( last_step .and. id_divg>0 ) used = send_data(id_divg, dp1, fv_time) 
      endif


      if ( npz > 4 ) then
!------------------------------------------------------------------------
! Peroform vertical remapping from Lagrangian control-volume to
! the Eulerian coordinate as specified by the routine set_eta.
! Note that this finite-volume dycore is otherwise independent of the vertical
! Eulerian coordinate.
!------------------------------------------------------------------------
                                                  call timing_on('Remapping')

         call Lagrangian_to_Eulerian(last_step, consv_te, ps, pe, delp,  &
                     pkz, pk, bdt, npz, is,ie,js,je, isd,ied,jsd,jed, &
                     nq, sphum, u,  v, w, delz, pt, q, phis, zvir, cp_air,   &
                     akap, kord_mt, kord_tr, kord_tm, peln, te_2d,  &
                     ng, ua, va, omga, dp1, pem, fill, reproduce_sum, &
                     ak, bk, ks, ze0, remap_t, hydrostatic, hybrid_z, last_step, k_top)

                                                  call timing_off('Remapping')
!--------------------------
! Filter omega for physics:
!--------------------------
         if( last_step .and. nf_omega>0 )  then
            call del2_cubed(omga, 0.20*da_min, npx, npy, npz, nf_omega)
         endif
      endif
#endif

  enddo    ! n_map loop

#ifndef SW_DYNAMICS
! Convert back to temperature
  do k=1,npz
     do j=js,je
        do i=is,ie
            pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)/(cp_air*(1.+zvir*q(i,j,k,sphum)))
        enddo
     enddo
  enddo
#endif

      deallocate ( dp1 )
      deallocate ( pem )

  if ( fv_debug ) then
       call prt_maxmin('delp_a',  delp, is, ie, js, je, ng, npz, 0.01, gid==0)
       call prt_maxmin('T_dyn_a',  pt, is, ie, js, je, ng, npz, 1., gid==0)
       call prt_maxmin('pk_a',   pk, is, ie, js, je, 0, npz+1, 1., gid==0)
       call prt_maxmin('pkz_a',  pkz, is, ie, js, je, 0, npz, 1., gid==0)
  endif

  if( nwat==6 ) then
      call neg_adj3(is, ie, js, je, ng, npz,        &
                    pt, delp, q(isd,jsd,1,sphum),   &
                              q(isd,jsd,1,liq_wat), &
                              q(isd,jsd,1,rainwat), &
                              q(isd,jsd,1,ice_wat), &
                              q(isd,jsd,1,snowwat), &
                              q(isd,jsd,1,graupel), &
                              q(isd,jsd,1,cld_amt)  )
     if ( fv_debug ) then
       call prt_maxmin('SPHUM_dyn',   q(isd,jsd,1,sphum  ), is, ie, js, je, ng, npz, 1., gid==0)
       call prt_maxmin('liq_wat_dyn', q(isd,jsd,1,liq_wat), is, ie, js, je, ng, npz, 1., gid==0)
       call prt_maxmin('ice_wat_dyn', q(isd,jsd,1,ice_wat), is, ie, js, je, ng, npz, 1., gid==0)
       call prt_maxmin('snowwat_dyn', q(isd,jsd,1,snowwat), is, ie, js, je, ng, npz, 1., gid==0)
       call prt_maxmin('graupel_dyn', q(isd,jsd,1,graupel), is, ie, js, je, ng, npz, 1., gid==0)
!      call prt_maxmin('cld_amt_dyn', q(isd,jsd,1,cld_amt), is, ie, js, je, ng, npz, 1., gid==0)
     endif
  endif

  call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, npz, 1)

  if ( range_warn ) then
       call range_check('UA_dyn', ua, is, ie, js, je, ng, npz, agrid,   &
                         gid==0, -220., 260., bad_range)
       call range_check('VA_dyn', ua, is, ie, js, je, ng, npz, agrid,   &
                         gid==0, -220., 220., bad_range)
#ifndef SW_DYNAMICS
       call range_check('TA_dyn', pt, is, ie, js, je, ng, npz, agrid,   &
                         gid==0, 150., 350., bad_range)
#endif
  endif

  end subroutine fv_dynamics


 subroutine del2_cubed(q, cd, npx, npy, km, nmax)
!---------------------------------------------------------------
! This routine is for filtering the omega field for the physics
!---------------------------------------------------------------
   integer, intent(in):: npx, npy, km, nmax
   real,    intent(in):: cd            ! cd = K * da_min;   0 < K < 0.25
   real, intent(inout):: q(isd:ied,jsd:jed,km)
   real, parameter:: r3  = 1./3.
   real :: fx(isd:ied+1,jsd:jed), fy(isd:ied,jsd:jed+1)
   real :: q2(isd:ied,jsd:jed)
   integer i,j,k, n, nt, ntimes

   ntimes = min(3, nmax)

                     call timing_on('COMM_TOTAL')
   call mpp_update_domains(q, domain, complete=.true.)
                     call timing_off('COMM_TOTAL')


   do n=1,ntimes
      nt = ntimes - n

   do k=1,km

      if ( sw_corner ) then
           q(1,1,k) = (q(1,1,k)+q(0,1,k)+q(1,0,k)) * r3
           q(0,1,k) =  q(1,1,k)
           q(1,0,k) =  q(1,1,k)
      endif
      if ( se_corner ) then
           q(ie, 1,k) = (q(ie,1,k)+q(npx,1,k)+q(ie,0,k)) * r3
           q(npx,1,k) =  q(ie,1,k)
           q(ie, 0,k) =  q(ie,1,k)
      endif
      if ( ne_corner ) then
           q(ie, je,k) = (q(ie,je,k)+q(npx,je,k)+q(ie,npy,k)) * r3
           q(npx,je,k) =  q(ie,je,k)
           q(ie,npy,k) =  q(ie,je,k)
      endif
      if ( nw_corner ) then
           q(1, je,k) = (q(1,je,k)+q(0,je,k)+q(1,npy,k)) * r3
           q(0, je,k) =  q(1,je,k)
           q(1,npy,k) =  q(1,je,k)
      endif

      if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 1)
      do j=js-nt,je+nt
         do i=is-nt,ie+1+nt
            fx(i,j) = dy(i,j)*sina_u(i,j)*(q(i-1,j,k)-q(i,j,k))*rdxc(i,j)
         enddo
      enddo

      if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 2)
      do j=js-nt,je+1+nt
         do i=is-nt,ie+nt
            fy(i,j) = dx(i,j)*sina_v(i,j)*(q(i,j-1,k)-q(i,j,k))*rdyc(i,j)
         enddo
      enddo

      do j=js-nt,je+nt
         do i=is-nt,ie+nt
            q(i,j,k) = q(i,j,k) + cd*rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))
         enddo
      enddo
   enddo
   enddo

 end subroutine del2_cubed


 subroutine del2_cubed_old(q, cd, npx, npy, km, ntimes)
!---------------------------------------------------------------
! This routine is for filtering the omega field for the physics
!---------------------------------------------------------------
   integer, intent(in):: npx, npy, km, ntimes
   real,    intent(in):: cd            ! cd = K * da_min;   0 < K < 0.25
   real, intent(inout):: q(isd:ied,jsd:jed,km)
   real, parameter:: r3  = 1./3.
   real :: fx(is:ie+1,js:je), fy(is:ie,js:je+1)
   integer i,j,k, n

   do n=1,ntimes
                     call timing_on('COMM_TOTAL')
   call mpp_update_domains(q, domain, complete=.true.)
                     call timing_off('COMM_TOTAL')
   do k=1,km
      if ( sw_corner ) then
           q(1,1,k) = (q(1,1,k)+q(0,1,k)+q(1,0,k)) * r3
           q(0,1,k) =  q(1,1,k)
           q(1,0,k) =  q(1,1,k)
      endif
      if ( se_corner ) then
           q(ie, 1,k) = (q(ie,1,k)+q(npx,1,k)+q(ie,0,k)) * r3
           q(npx,1,k) =  q(ie,1,k)
           q(ie, 0,k) =  q(ie,1,k)
      endif
      if ( ne_corner ) then
           q(ie, je,k) = (q(ie,je,k)+q(npx,je,k)+q(ie,npy,k)) * r3
           q(npx,je,k) =  q(ie,je,k)
           q(ie,npy,k) =  q(ie,je,k)
      endif
      if ( nw_corner ) then
           q(1, je,k) = (q(1,je,k)+q(0,je,k)+q(1,npy,k)) * r3
           q(0, je,k) =  q(1,je,k)
           q(1,npy,k) =  q(1,je,k)
      endif

      do j=js,je
         do i=is,ie+1
            fx(i,j) = cd*dy(i,j)*sina_u(i,j)*(q(i-1,j,k)-q(i,j,k))*rdxc(i,j)
         enddo
      enddo

      do j=js,je+1
         do i=is,ie
            fy(i,j) = cd*dx(i,j)*sina_v(i,j)*(q(i,j-1,k)-q(i,j,k))*rdyc(i,j)
         enddo
      enddo

      do j=js,je
         do i=is,ie
            q(i,j,k) = q(i,j,k) + rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))
         enddo
      enddo
   enddo
   enddo

 end subroutine del2_cubed_old



#ifdef OLD_RAYF

 subroutine Rayleigh_Friction(dt, npx, npy, npz, ks, pm, tau, p_c, u, v, w, pt,  &
                              ua, va, delz, cp, rg, hydrostatic, conserve)
    real, intent(in):: dt
    real, intent(in):: tau              ! time scale (days)
    real, intent(in):: p_c
    real, intent(in):: cp, rg
    real, intent(in),  dimension(npz):: pm
    integer, intent(in):: npx, npy, npz, ks
    logical, intent(in):: hydrostatic
    logical, intent(in):: conserve
    real, intent(inout):: u(isd:ied  ,jsd:jed+1,npz) ! D grid zonal wind (m/s)
    real, intent(inout):: v(isd:ied+1,jsd:jed,npz) ! D grid meridional wind (m/s)
    real, intent(inout)::  w(isd:ied,jsd:jed,npz) ! cell center vertical wind (m/s)
    real, intent(inout):: pt(isd:ied,jsd:jed,npz) ! temp
    real, intent(inout):: ua(isd:ied,jsd:jed,npz) ! 
    real, intent(inout):: va(isd:ied,jsd:jed,npz) ! 
    real, intent(inout):: delz(is:ie,js:je,npz)   ! delta-height (m); non-hydrostatic only
    real, parameter:: sday = 86400.
    real, parameter:: wfac = 10.     ! factor to amplify the drag on w
    real c1, pc, fac
    integer i, j, k

     kmax = max(npz/3+1, ks)

     if ( .not. RF_initialized ) then
          allocate( rf(npz) )
          allocate( rw(npz) )

          if ( p_c <= 0. ) then
               pc = pm(1)
          else
               pc = p_c
          endif

          if( gid==0 ) write(6,*) 'Rayleigh friction E-folding time [days]:'
          c1 = 1. / (tau*sday)
          do k=1,kmax
             if ( pm(k) < 30.E2 ) then
                  rf(k) = c1*(1.+tanh(log10(pc/pm(k))))
                  if( gid==0 ) write(6,*) k, 0.01*pm(k), 1./(rf(k)*sday)
                  rf(k) = 1./(1.+dt*rf(k))
                  rw(k) = 1./(1.+dt*rf(k)*wfac)
             endif
          enddo
          RF_initialized = .true.
     endif

     if(conserve) call c2l_ord2(u, v, ua, va, dx, dy, rdxa, rdya, npz)

!$omp parallel do default(shared) private(i, j, k)
     do k=1,kmax
        if ( pm(k) < 30.E2 ) then
! Add heat so as to conserve TE
          if ( conserve ) then
               fac = 0.5*(1.-rf(k)**2) / (cp-rg*ptop/pm(k))
               do j=js,je
                  do i=is,ie
                     pt(i,j,k) = pt(i,j,k) + fac*(ua(i,j,k)**2 + va(i,j,k)**2)
                  enddo
               enddo
          endif
             do j=js,je+1
                do i=is,ie
                   u(i,j,k) = u(i,j,k)*rf(k)
                enddo
             enddo
             do j=js,je
                do i=is,ie+1
                   v(i,j,k) = v(i,j,k)*rf(k)
                enddo
             enddo
          if ( .not. hydrostatic ) then
             do j=js,je
                do i=is,ie
                   w(i,j,k) = w(i,j,k)*rw(k)
                enddo
             enddo
          endif
        endif
     enddo

 end subroutine Rayleigh_Friction

#else
 subroutine Rayleigh_Friction(dt, npx, npy, npz, ks, pm, tau, p_c, u, v, w, pt,  &
                              ua, va, delz, cp, rg, hydrostatic, conserve)
    real, intent(in):: dt
    real, intent(in):: tau              ! time scale (days)
    real, intent(in):: p_c
    real, intent(in):: cp, rg
    real, intent(in),  dimension(npz):: pm
    integer, intent(in):: npx, npy, npz, ks
    logical, intent(in):: hydrostatic
    logical, intent(in):: conserve
    real, intent(inout):: u(isd:ied  ,jsd:jed+1,npz) ! D grid zonal wind (m/s)
    real, intent(inout):: v(isd:ied+1,jsd:jed,npz) ! D grid meridional wind (m/s)
    real, intent(inout)::  w(isd:ied,jsd:jed,npz) ! cell center vertical wind (m/s)
    real, intent(inout):: pt(isd:ied,jsd:jed,npz) ! temp
    real, intent(inout):: ua(isd:ied,jsd:jed,npz) ! 
    real, intent(inout):: va(isd:ied,jsd:jed,npz) ! 
    real, intent(inout):: delz(is:ie,js:je,npz)   ! delta-height (m); non-hydrostatic only
! local:
    real, allocatable ::  u2f(:,:,:)
    real, parameter:: sday = 86400.
    real, parameter:: u000 = 4900.   ! scaling velocity  **2
    real c1, pc, fac
    integer i, j, k

    if ( .not. RF_initialized ) then
          allocate( rf(npz) )
          allocate( rw(npz) )

          if ( p_c <= 0. ) then
               pc = pm(1)
          else
               pc = p_c
          endif

          if( gid==0 ) write(6,*) 'Rayleigh friction E-folding time [days]:'
          c1 = 1. / (tau*sday)

          kmax = 1
          do k=1,npz
             if ( pm(k) < 40.E2 ) then
                  rf(k) = c1*(1.+tanh(log10(pc/pm(k))))
                  kmax = k
                  if( gid==0 ) write(6,*) k, 0.01*pm(k), 1./(rf(k)*sday)
             else
                exit
             endif
          enddo
          if( gid==0 ) write(6,*) 'Rayleigh Friction kmax=', kmax

          RF_initialized = .true.
    endif

    allocate( u2f(isd:ied,jsd:jed,kmax) )

    call c2l_ord2(u, v, ua, va, dx, dy, rdxa, rdya, npz)
    u2f = 0.
!$omp parallel do default(shared) private(i, j, k)
    do k=1,kmax
        if ( hydrostatic ) then
           do j=js,je
              do i=is,ie
                 u2f(i,j,k) = ua(i,j,k)**2 + va(i,j,k)**2
              enddo
           enddo
        else
           do j=js,je
              do i=is,ie
                 u2f(i,j,k) = ua(i,j,k)**2 + va(i,j,k)**2 + w(i,j,k)**2
              enddo
           enddo
        endif
    enddo
                                                                call timing_on('COMM_TOTAL')
    call mpp_update_domains(u2f, domain, complete=.true.)
                                                                call timing_off('COMM_TOTAL')

!$omp parallel do default(shared) private(i, j, k)
     do k=1,kmax

        if ( conserve ) then
           if ( hydrostatic ) then
             do j=js,je
                do i=is,ie
                   pt(i,j,k) = pt(i,j,k) + 0.5*u2f(i,j,k)/(cp-rg*ptop/pm(k))      &
                             * ( 1. - 1./(1.+dt*rf(k)*sqrt(u2f(i,j,k)/u000))**2 )
                enddo
             enddo
           else
             do j=js,je
                do i=is,ie
                   delz(i,j,k) = delz(i,j,k) / pt(i,j,k)
                   pt(i,j,k) = pt(i,j,k) + 0.5*u2f(i,j,k)/(cp-rg*ptop/pm(k))      &
                             * ( 1. - 1./(1.+dt*rf(k)*sqrt(u2f(i,j,k)/u000))**2 )
                   delz(i,j,k) = delz(i,j,k) * pt(i,j,k)
                enddo
             enddo
           endif
        endif

        do j=js-1,je+1
           do i=is-1,ie+1
              u2f(i,j,k) = dt*rf(k)*sqrt(u2f(i,j,k)/u000)
           enddo
        enddo

        do j=js,je+1
           do i=is,ie
              u(i,j,k) = u(i,j,k) / (1.+0.5*(u2f(i,j-1,k)+u2f(i,j,k)))
           enddo
        enddo
        do j=js,je
           do i=is,ie+1
              v(i,j,k) = v(i,j,k) / (1.+0.5*(u2f(i-1,j,k)+u2f(i,j,k)))
           enddo
        enddo

        if ( .not. hydrostatic ) then
              do j=js,je
                 do i=is,ie
                    w(i,j,k) = w(i,j,k) / (1.+u2f(i,j,k))
                 enddo
              enddo
        endif

     enddo

     deallocate ( u2f )

 end subroutine Rayleigh_Friction
#endif

end module fv_dynamics_mod



module fv_fill_mod
     implicit none
     public fillz, pfix

contains

 subroutine fillz(im, km, nq, q, dp)
   integer,  intent(in):: im                ! No. of longitudes
   integer,  intent(in):: km                ! No. of levels
   integer,  intent(in):: nq                ! Total number of tracers
   real , intent(in)::  dp(im,km)       ! pressure thickness
   real , intent(inout) :: q(im,km,nq)   ! tracer mixing ratio
! !LOCAL VARIABLES:
   integer i, k, ic
   real  qup, qly, dup

   do ic=1,nq
! Top layer
      do i=1,im
         if( q(i,1,ic) < 0. ) then
             q(i,2,ic) = q(i,2,ic) + q(i,1,ic)*dp(i,1)/dp(i,2)
             q(i,1,ic) = 0.
          endif
      enddo

! Interior
      do k=2,km-1
         do i=1,im
         if( q(i,k,ic) < 0. ) then
! Borrow from above
             qup =  max(0., q(i,k-1,ic)*dp(i,k-1) )
             qly = -q(i,k  ,ic)*dp(i,k  )
             dup =  min( 0.5*qly, 0.99*qup )
             q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) 
! Borrow from below: q(i,k,ic) is still negative at this stage
             q(i,k+1,ic) = q(i,k+1,ic) - (qly-dup)/dp(i,k+1) 
             q(i,k  ,ic) = 0.
          endif
         enddo
      enddo
 
! Bottom layer
      k = km
      do i=1,im
         if( q(i,k,ic)<0. .and. q(i,k-1,ic)>0.) then
! Borrow from above
             qup =  q(i,k-1,ic)*dp(i,k-1)
             qly = -q(i,k  ,ic)*dp(i,k  )
             dup =  min(qly, qup)
             q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) 
             q(i,k,  ic) = q(i,k,  ic) + dup/dp(i,k  )
#ifdef NON_CONSV_Q
          else
             q(i,km,ic) = 0.
#endif
          endif
      enddo
   enddo
 end subroutine fillz

 subroutine pfix(q, qp, im, ipx, acap, cosp2)

 integer im                  ! Longitudes
 real  acap               ! ???
 real  cosp2              ! ???

 real  q(im)              ! Latitude-level field to adjust
 real  qp(im)             ! Second latitude-level field to adjust (usually pole)

! !OUTPUT PARAMETERS:
 integer ipx                 ! Flag:  0 if Q not change, 1 if changed


! !LOCAL VARIABLES:
 integer i
 real  summ, sump, pmean
 
   summ = 0.
   sump = 0.
   do i=1,im
     summ = summ + q(i)
     sump = sump + qp(i)
   enddo
 
   sump = sump/im
   pmean = (sump*acap + summ*cosp2) / (acap + cosp2*im)
 
   do i=1,im
      q(i) = pmean
      qp(i) = pmean
   enddo
 
   if( qp(1) < 0. ) then
      ipx = 1
   endif

 end subroutine pfix

end module fv_fill_mod


 module fv_grid_utils_mod
 
#include <fms_platform.h>

 use mpp_mod,         only: FATAL, mpp_error
 use mpp_domains_mod, only: mpp_update_domains, DGRID_NE, mpp_global_sum,   &
                            BITWISE_EXACT_SUM
 use mpp_parameter_mod, only: AGRID_PARAM=>AGRID, CGRID_NE_PARAM=>CGRID_NE, & 
                              CORNER, SCALAR_PAIR

 use external_sst_mod, only: i_sst, j_sst, sst_ncep, sst_anom
 use fv_arrays_mod,   only: fv_atmos_type
 use fv_eta_mod,      only: set_eta
 use fv_mp_mod,       only: domain, ng, is,js,ie,je, isd,jsd,ied,jed, gid,  &
                            mp_reduce_sum, mp_reduce_min, mp_reduce_max
 use fv_timing_mod,   only: timing_on, timing_off

 implicit none
 private
#ifdef NO_QUAD_PRECISION
! 64-bit precision (kind=8)
 integer, parameter:: f_p = selected_real_kind(15)
#else
! Higher precision (kind=16) for grid geometrical factors:
 integer, parameter:: f_p = selected_real_kind(20)
#endif
 real, parameter::  big_number=1.E35
 real, parameter:: tiny_number=1.E-35

! For computing mismatch for variable grid zise:
 real, allocatable :: cx1(:,:), cx2(:,:)    !
 real, allocatable :: cy1(:,:), cy2(:,:)    !

! Scalars:
 real, allocatable :: edge_s(:)
 real, allocatable :: edge_n(:)
 real, allocatable :: edge_w(:)
 real, allocatable :: edge_e(:)
! Vector:
 real, allocatable :: edge_vect_s(:)
 real, allocatable :: edge_vect_n(:)
 real, allocatable :: edge_vect_w(:)
 real, allocatable :: edge_vect_e(:)
! scalar:
 real, allocatable :: ex_s(:)
 real, allocatable :: ex_n(:)
 real, allocatable :: ex_w(:)
 real, allocatable :: ex_e(:)
! Vandermonde Matrix:
 real, allocatable :: van2(:,:,:)
! divergence Damping:
 real, allocatable :: divg_u(:,:), divg_v(:,:)    !
! Cubed_2_latlon:
 real, allocatable :: a11(:,:)
 real, allocatable :: a12(:,:)
 real, allocatable :: a21(:,:)
 real, allocatable :: a22(:,:)
! latlon_2_cubed:
 real, allocatable :: z11(:,:)
 real, allocatable :: z12(:,:)
 real, allocatable :: z21(:,:)
 real, allocatable :: z22(:,:)

 real:: global_area, da_min, da_max, da_min_c, da_max_c
 logical:: g_sum_initialized
 logical:: Gnomonic_grid
 logical:: sw_corner, se_corner, ne_corner, nw_corner 
 real, allocatable :: cosa_u(:,:)
 real, allocatable :: cosa_v(:,:)
 real, allocatable :: cosa_s(:,:)
 real, allocatable :: sina_s(:,:)
 real, allocatable :: sina_u(:,:)
 real, allocatable :: sina_v(:,:)
 real, allocatable :: rsin_u(:,:)
 real, allocatable :: rsin_v(:,:)
 real, allocatable ::  rsina(:,:)
 real, allocatable ::  rsin2(:,:)
 real, allocatable :: ee1(:,:,:)
 real, allocatable :: ee2(:,:,:)
 real, allocatable :: ec1(:,:,:)
 real, allocatable :: ec2(:,:,:)
 real, allocatable :: ew(:,:,:,:)
 real, allocatable :: es(:,:,:,:)

! Unit Normal vectors at cell edges:
 real, allocatable :: en1(:,:,:)
 real, allocatable :: en2(:,:,:)

! Extended Cubed cross-edge winds
 real, allocatable :: eww(:,:)
 real, allocatable :: ess(:,:)

! Unit vectors for lat-lon grid
 real, allocatable :: vlon(:,:,:), vlat(:,:,:)
 real, allocatable :: fC(:,:), f0(:,:)
 real :: deglat=15.

 real, parameter:: ptop_min=1.E-8
 real    :: ptop
 integer :: ks
 integer :: g_type, npxx, npyy
 integer :: c2l_ord

 public ptop, ks, ptop_min, fC, f0, deglat, big_number, ew, es, eww, ess, ec1, ec2
 public sina_u, sina_v, cosa_u, cosa_v, cosa_s, sina_s, rsin_u, rsin_v, rsina, rsin2
 public project_sphere_v, latlon2xyz,  gnomonic_grids, global_area,         &
        sw_corner, se_corner, ne_corner, nw_corner, global_mx,              &
        da_min, da_min_c, edge_s, edge_n, edge_w, edge_e,   &
        edge_vect_s,edge_vect_n,edge_vect_w,edge_vect_e, unit_vect_latlon,  &
        cubed_to_latlon, c2l_ord2, g_sum, global_qsum, great_circle_dist,  &
        v_prod, en1, en2, ex_w, ex_e, ex_s, ex_n, vlon, vlat, ee1, ee2, &
        cx1, cx2, cy1, cy2, Gnomonic_grid, van2, divg_u, divg_v
 public mid_pt_sphere,  mid_pt_cart, vect_cross, grid_utils_init, grid_utils_end, &
        spherical_angle, cell_center2, get_area, inner_prod, fill_ghost,    &
        make_eta_level, expand_cell, cart_to_latlon, intp_great_circle, normalize_vect
 public z11, z12, z21, z22

 contains

   subroutine grid_utils_init(Atm, npx, npy, npz, grid, agrid, area, area_c,  &
                              cosa, sina, dx, dy, dxa, dya, dxc, dyc, non_ortho,   &
                              uniform_ppm, grid_type, c2l_order)
! Initialize 2D memory and geometrical factors
      type(fv_atmos_type), intent(inout) :: Atm
      logical, intent(in):: non_ortho
      integer, intent(in):: npx, npy, npz
      integer, intent(in):: grid_type, c2l_order
      real, intent(in)::  grid(isd:ied+1,jsd:jed+1,2)
      real, intent(in):: agrid(isd:ied  ,jsd:jed  ,2)
      real, intent(in):: area(isd:ied,jsd:jed)
      real, intent(in):: area_c(isd:ied+1,jsd:jed+1)
      real, intent(in)::  dx(isd:ied  ,jsd:jed+1)
      real, intent(in)::  dy(isd:ied+1,jsd:jed  )
      real, intent(inout):: dxa(isd:ied  ,jsd:jed  )
      real, intent(inout):: dya(isd:ied  ,jsd:jed  )
      real, intent(inout):: dxc(isd:ied+1,jsd:jed  )
      real, intent(inout):: dyc(isd:ied  ,jsd:jed+1)

      real, intent(inout):: cosa(isd:ied+1,jsd:jed+1)
      real, intent(inout):: sina(isd:ied+1,jsd:jed+1)
      logical, intent(IN) :: uniform_ppm
!
      real grid3(3,isd:ied+1,jsd:jed+1)
      real p1(3), p2(3), p3(3), pp(3)
      real sin2, tmp1, tmp2
      integer i, j, k, n

      npxx = npx;  npyy = npy

      g_sum_initialized = .false.

      allocate ( Atm%ak(npz+1) )
      allocate ( Atm%bk(npz+1) )

      if ( npz == 1 ) then
           Atm%ak(1) = 0.
           Atm%ak(2) = 0.
           Atm%bk(1) = 0.
           Atm%bk(2) = 1.
           ptop      = 0.
           Atm%ks    = 0
      else
! Initialize (ak,bk) for cold start; overwritten with restart file
           call set_eta(npz, ks, ptop, Atm%ak, Atm%bk)
           Atm%ks = ks
#ifdef PRINT_GRID
           if ( gid==0 ) then
                write(*,*) 'Grid_init', ks, ptop
              do k=1,npz
                 write(*,*) k, atm%ak(k), atm%bk(k)
              enddo
           endif
#endif
      endif

! NCEP analysis available from amip-Interp (allocate if needed)
      if (.not. allocated(sst_ncep)) allocate (sst_ncep(i_sst,j_sst))
      if (.not. allocated(sst_anom)) allocate (sst_anom(i_sst,j_sst))

! Coriolis parameters:
      allocate ( f0(isd:ied  ,jsd:jed  ) )
      allocate ( fC(isd:ied+1,jsd:jed+1) )

! Corner unit vectors:
      allocate( ee1(3,isd:ied+1,jsd:jed+1) )
      allocate( ee2(3,isd:ied+1,jsd:jed+1) )

! Center unit vectors:
      allocate( ec1(3,isd:ied,jsd:jed) )
      allocate( ec2(3,isd:ied,jsd:jed) )

! Edge unit vectors:
      allocate( ew(3,isd:ied+1,jsd:jed,  2) )
      allocate( es(3,isd:ied  ,jsd:jed+1,2) )

! Edge unit "Normal" vectors: (for omega computation)
      allocate( en1(3,is:ie,  js:je+1) )   ! E-W edges
      allocate( en2(3,is:ie+1,js:je  ) )   ! N-S egdes
 
      allocate ( cosa_u(isd:ied+1,jsd:jed) )
      allocate ( sina_u(isd:ied+1,jsd:jed) )
      allocate ( rsin_u(isd:ied+1,jsd:jed) )

      allocate ( cosa_v(isd:ied,jsd:jed+1) )
      allocate ( sina_v(isd:ied,jsd:jed+1) )
      allocate ( rsin_v(isd:ied,jsd:jed+1) )

      allocate ( cosa_s(isd:ied,jsd:jed) )    ! cell center
      allocate ( sina_s(isd:ied,jsd:jed) )    ! cell center

      allocate (  rsina(is:ie+1,js:je+1) )    ! cell corners
      allocate (  rsin2(isd:ied,jsd:jed) )    ! cell center

      allocate( eww(3,4) )
      allocate( ess(3,4) )

! For diveregnce damping:
      allocate (  divg_u(isd:ied,  jsd:jed+1) )
      allocate (  divg_v(isd:ied+1,jsd:jed) )

      sw_corner = .false.
      se_corner = .false.
      ne_corner = .false.
      nw_corner = .false.

      if (grid_type < 3) then
         if (       is==1 .and.  js==1 )      sw_corner = .true.
         if ( (ie+1)==npx .and.  js==1 )      se_corner = .true.
         if ( (ie+1)==npx .and. (je+1)==npy ) ne_corner = .true.
         if (       is==1 .and. (je+1)==npy ) nw_corner = .true.
      endif

! For variable grid
   if ( .not. uniform_ppm ) then
      allocate ( cx1(isd:ied,jsd:jed) )
      allocate ( cx2(isd:ied,jsd:jed) )
      allocate ( cy1(isd:ied,jsd:jed) )
      allocate ( cy2(isd:ied,jsd:jed) )

     do j=jsd,jed
        do i=is-2,ie+2
               tmp1 = dxa(i,j)/(dxa(i-1,j) + dxa(i,j) + dxa(i+1,j))
           cx1(i,j) = tmp1*(dxa(i+1,j)+0.5*dxa(i,j))/(dxa(i-1,j)+dxa(i,j)) 
           cx2(i,j) = tmp1*(dxa(i-1,j)+0.5*dxa(i,j))/(dxa(i,j)+dxa(i+1,j)) 
        enddo
     enddo

     do j=js-2,je+2
        do i=isd,ied
               tmp2 = dya(i,j)/(dya(i,j-1) + dya(i,j) + dya(i,j+1)) 
           cy1(i,j) = tmp2*(dya(i,j+1)+0.5*dya(i,j))/(dya(i,j-1)+dya(i,j))
           cy2(i,j) = tmp2*(dya(i,j-1)+0.5*dya(i,j))/(dya(i,j)+dya(i,j+1)) 
        enddo
     enddo
  endif


  if (grid_type < 3) then
     do j=jsd,jed+1
        do i=isd,ied+1
           call latlon2xyz(grid(i,j,1:2), grid3(1,i,j))
        enddo
     enddo

     call get_center_vect( npx, npy, grid3, ec1, ec2 )

! Fill arbitrary values in the non-existing corner regions:
     do k=1,3
        call fill_ghost(ec1(k,:,:), npx, npy, big_number)
        call fill_ghost(ec2(k,:,:), npx, npy, big_number)
     enddo

     do j=jsd,jed
        do i=isd+1,ied
        if ( (i<1   .and. j<1  ) .or. (i>npx .and. j<1  ) .or.  &
             (i>npx .and. j>(npy-1)) .or. (i<1   .and. j>(npy-1)) ) then
!            (i>npx .and. j>npy) .or. (i<1   .and. j>npy) ) then
             ew(1:3,i,j,1:2) = 0.
        else
           call mid_pt_cart( grid(i,j,1:2), grid(i,j+1,1:2), pp)
           if (i==1) then
              call latlon2xyz( agrid(i,j,1:2), p1)
              call vect_cross(p2, pp, p1)
           elseif(i==npx) then
              call latlon2xyz( agrid(i-1,j,1:2), p1)
              call vect_cross(p2, p1, pp)
           else
              call latlon2xyz( agrid(i-1,j,1:2), p3)
              call latlon2xyz( agrid(i,  j,1:2), p1)
              call vect_cross(p2, p3, p1)
           endif
           call vect_cross(ew(1,i,j,1), p2, pp)
           call normalize_vect(ew(1,i,j,1))
!---
           call vect_cross(p1, grid3(1,i,j), grid3(1,i,j+1))
           call vect_cross(ew(1,i,j,2), p1, pp)
           call normalize_vect(ew(1,i,j,2))
        endif
        enddo
     enddo

     do j=jsd+1,jed
        do i=isd,ied
        if ( (i<1   .and. j<1  ) .or. (i>(npx-1) .and. j<1  ) .or.  &
             (i>(npx-1) .and. j>npy) .or. (i<1   .and. j>npy) ) then
             es(1:3,i,j,1:2) = 0.
        else
           call mid_pt_cart(grid(i,j,1:2), grid(i+1,j,1:2), pp)
           if (j==1) then
              call latlon2xyz( agrid(i,j,1:2), p1)
              call vect_cross(p2, pp, p1)
           elseif (j==npy) then
              call latlon2xyz( agrid(i,j-1,1:2), p1)
              call vect_cross(p2, p1, pp)
           else 
              call latlon2xyz( agrid(i,j  ,1:2), p1)
              call latlon2xyz( agrid(i,j-1,1:2), p3)
              call vect_cross(p2, p3, p1)
           endif
           call vect_cross(es(1,i,j,2), p2, pp)
           call normalize_vect(es(1,i,j,2))
!---
           call vect_cross(p3, grid3(1,i,j), grid3(1,i+1,j))
           call vect_cross(es(1,i,j,1), p3, pp)
           call normalize_vect(es(1,i,j,1))
        endif
        enddo
     enddo
  else
     ec1(1,:,:)=1.
     ec1(2,:,:)=0.
     ec1(3,:,:)=0.

     ec2(1,:,:)=0.
     ec2(2,:,:)=1.
     ec2(3,:,:)=0.

     ew(1,:,:,1)=1.
     ew(2,:,:,1)=0.
     ew(3,:,:,1)=0.
                                   
     ew(1,:,:,2)=0.
     ew(2,:,:,2)=1.
     ew(3,:,:,2)=0.

     es(1,:,:,1)=1.
     es(2,:,:,1)=0.
     es(3,:,:,1)=0.
                                   
     es(1,:,:,2)=0.
     es(2,:,:,2)=1.
     es(3,:,:,2)=0.
  endif

     if ( non_ortho ) then
           cosa_u = big_number
           cosa_v = big_number
           cosa_s = big_number
           sina_s = big_number
           sina_u = big_number
           sina_v = big_number
           rsin_u = big_number
           rsin_v = big_number
           rsina  = big_number
           rsin2  = big_number
#ifndef GLOBAL_TRIG
          cosa = big_number
          sina = big_number
!       if ( Gnomonic_grid ) then
! The following works well ONLY with the Gnomonic grid (type 0)
!           do j=js,je+1
!              do i=is,ie+1
!                 tmp1 = cos_angle(grid3(1,i,j), grid3(1,i+1,j), grid3(1,i,j+1))
!                 tmp2 = cos_angle(grid3(1,i,j), grid3(1,i-1,j), grid3(1,i,j-1))
!                 cosa(i,j) = 0.5*(tmp1+tmp2)
!                 sina(i,j) = sqrt( max(0.,1. -cosa(i,j)**2) )
!              enddo
!          enddo
!       endif

        do j=js,je+1
           do i=is,ie+1
! unit vect in X-dir: ee1
              if (i==1) then
                  call vect_cross(pp, grid3(1,i,  j), grid3(1,i+1,j))
              elseif(i==npx) then
                  call vect_cross(pp, grid3(1,i-1,j), grid3(1,i,  j))
              else
                  call vect_cross(pp, grid3(1,i-1,j), grid3(1,i+1,j))
              endif
              call vect_cross(ee1(1,i,j), pp, grid3(1,i,j))
              call normalize_vect( ee1(1,i,j) )

! unit vect in Y-dir: ee2
              if (j==1) then
                  call vect_cross(pp, grid3(1,i,j  ), grid3(1,i,j+1))
              elseif(j==npy) then
                  call vect_cross(pp, grid3(1,i,j-1), grid3(1,i,j  ))
              else
                  call vect_cross(pp, grid3(1,i,j-1), grid3(1,i,j+1))
              endif
              call vect_cross(ee2(1,i,j), pp, grid3(1,i,j))
              call normalize_vect( ee2(1,i,j) )

              tmp1 = inner_prod(ee1(1,i,j), ee2(1,i,j))
              cosa(i,j) = sign(min(1., abs(tmp1)), tmp1)
              sina(i,j) = sqrt(max(0.,1. -cosa(i,j)**2))
           enddo
        enddo
#endif

! call mpp_update_domains(cosa, domain, position=CORNER)
! The above does not work because cosa at edges should have two values (left and right)

      do j=jsd,jed
         do i=isd+1,ied
                   tmp1 = inner_prod(ew(1,i,j,1), ew(1,i,j,2))
            cosa_u(i,j) = sign( min(1., abs(tmp1)), tmp1 )
            sin2 = 1. - cosa_u(i,j)**2
            sin2 = min(1., sin2)
            sin2 = max(tiny_number, sin2)  ! sin(alpha)**2 >= 0.75
 
            sina_u(i,j) = sqrt( sin2 )
            rsin_u(i,j) =  1. / sin2
         enddo
      enddo

      do j=jsd+1,jed
         do i=isd,ied
                   tmp1 = inner_prod(es(1,i,j,1), es(1,i,j,2))
            cosa_v(i,j) = sign( min(1., abs(tmp1)), tmp1 )
            sin2 = 1. - cosa_v(i,j)**2
            sin2 = min(1., sin2)
            sin2 = max(tiny_number, sin2)
            sina_v(i,j) = sqrt( sin2 )
            rsin_v(i,j) =  1. / sin2
         enddo
      enddo
     
      do j=jsd,jed
         do i=isd,ied
                  tmp1  = inner_prod(ec1(1,i,j), ec2(1,i,j))
            cosa_s(i,j) = sign(min(1., abs(tmp1)), tmp1 )
            sin2 = 1. - cosa_s(i,j)**2
            sin2 = min(1., sin2)
            sin2 = max(tiny_number, sin2)
            sina_s(i,j) = min(1., sqrt(sin2))
            rsin2(i,j) = 1. / sin2
         enddo
      enddo
! Force the model to fail if incorrect corner values are to be used:
     call fill_ghost(cosa_s, npx, npy,  big_number)
     call fill_ghost(sina_s, npx, npy, tiny_number)

!------------------------------------
! Set special sin values at edges:
!------------------------------------
      do j=js,je+1
         do i=is,ie+1
            if ( i==1 .or. i==npx .or. j==1 .or. j==npy ) then
                 rsina(i,j) = 1. / sina(i,j)
            else
                 rsina(i,j) = 1. / sina(i,j)**2
            endif
         enddo
      enddo

      do j=jsd,jed
         do i=isd+1,ied
            if ( i==1 .or. i==npx ) then
                 rsin_u(i,j) = 1. / sina_u(i,j)
            endif
         enddo
      enddo

      do j=jsd+1,jed
         do i=isd,ied
            if ( j==1 .or. j==npy ) then
                 rsin_v(i,j) = 1. / sina_v(i,j)
            endif
         enddo
      enddo

   else
           sina = 1.
           cosa = 0.
           rsina  = 1.
           rsin2  = 1.
           sina_u = 1.
           sina_v = 1.
           cosa_u = 0.        
           cosa_v = 0.        
           cosa_s = 0.        
           sina_s = 1.        
           rsin_u = 1.
           rsin_v = 1.
   endif

   if ( grid_type < 3 ) then

#ifdef USE_NORM_VECT
!-------------------------------------------------------------
! Make normal vect at face edges after consines are computed:
!-------------------------------------------------------------
! for old d2a2c_vect routines
     do j=js-1,je+1
        if ( is==1 ) then
             i=1
             call vect_cross(ew(1,i,j,1), grid3(1,i,j+1), grid3(1,i,j)) 
             call normalize_vect( ew(1,i,j,1) )
        endif
        if ( (ie+1)==npx ) then
             i=npx
             call vect_cross(ew(1,i,j,1), grid3(1,i,j+1), grid3(1,i,j)) 
             call normalize_vect( ew(1,i,j,1) )
        endif
     enddo

     if ( js==1 ) then
        j=1
        do i=is-1,ie+1
             call vect_cross(es(1,i,j,2), grid3(1,i,j),grid3(1,i+1,j)) 
             call normalize_vect( es(1,i,j,2) )
        enddo
     endif
     if ( (je+1)==npy ) then
        j=npy
        do i=is-1,ie+1
             call vect_cross(es(1,i,j,2), grid3(1,i,j),grid3(1,i+1,j)) 
             call normalize_vect( es(1,i,j,2) )
        enddo
     endif
#endif

! For omega computation:
! Unit vectors:
     do j=js,je+1
        do i=is,ie
           call vect_cross(en1(1,i,j), grid3(1,i,j), grid3(1,i+1,j))
           call normalize_vect( en1(1,i,j) )
        enddo
     enddo
     do j=js,je
        do i=is,ie+1
           call vect_cross(en2(1,i,j), grid3(1,i,j+1), grid3(1,i,j)) 
           call normalize_vect( en2(1,i,j) )
        enddo
     enddo
!-------------------------------------------------------------
! Make unit vectors for the coordinate extension:
!-------------------------------------------------------------
#ifdef EXTEND_VG
     if ( sw_corner ) then
        do k=1,3
           ess(k,1) = grid3(k,1,1) - grid3(k,0,2)
        enddo
        call normalize_vect( ess(1,1) )
        do k=1,3
           eww(k,1) = grid3(k,1,1) - grid3(k,2,0)
        enddo
        call normalize_vect( eww(1,1) )
     endif
     if ( se_corner ) then
        do k=1,3
           ess(k,2) = grid3(k,npx+1,2) - grid3(k,npx,1)
        enddo
        call normalize_vect( ess(1,2) )
        do k=1,3
           eww(k,2) = grid3(k,npx,1) - grid3(k,npx-1,0)
        enddo
        call normalize_vect( eww(1,2) )
     endif
     if ( ne_corner ) then
        do k=1,3
           ess(k,3) = grid3(k,npx+1,npy-1) - grid3(k,npx,npy)
        enddo
        call normalize_vect( ess(1,3) )
        do k=1,3
           eww(k,3) = grid3(k,npx-1,npy+1) - grid3(k,npx,npy)
        enddo
        call normalize_vect( eww(1,3) )
     endif
     if ( nw_corner ) then
        do k=1,3
           ess(k,4) = grid3(k,1,npy) - grid3(k,0,npy-1)
        enddo
        call normalize_vect( ess(1,4) )
        do k=1,3
           eww(k,4) = grid3(k,2,npy+1) - grid3(k,1,npy)
        enddo
        call normalize_vect( eww(1,4) )
     endif
#endif
  endif
 
  do j=jsd,jed+1
     do i=isd,ied
        divg_u(i,j) = sina_v(i,j)*dyc(i,j)/dx(i,j)
     enddo
  enddo
  do j=jsd,jed
     do i=isd,ied+1
        divg_v(i,j) = sina_u(i,j)*dxc(i,j)/dy(i,j)
     enddo
  enddo

! Initialize cubed_sphere to lat-lon transformation:
     call init_cubed_to_latlon( agrid, grid_type, c2l_order )

     call global_mx(area, ng, da_min, da_max)
     if( gid==0 ) write(6,*) 'da_max/da_min=', da_max/da_min

     call global_mx_c(area_c(is:ie,js:je), is, ie, js, je, da_min_c, da_max_c)

     if( gid==0 ) write(6,*) 'da_max_c/da_min_c=', da_max_c/da_min_c

!------------------------------------------------
! Initialization for interpolation at face edges
!------------------------------------------------
! A->B scalar:
     if (grid_type < 3) then
        call mpp_update_domains(divg_v, divg_u, domain, flags=SCALAR_PAIR,      &
                                gridtype=CGRID_NE_PARAM, complete=.true.)
        call edge_factors (non_ortho, grid, agrid, npx, npy)
        call efactor_a2c_v(non_ortho, grid, agrid, npx, npy)
!       call extend_cube_s(non_ortho, grid, agrid, npx, npy, .false.)
!       call van2d_init(grid, agrid, npx, npy)
     else
        allocate ( edge_s(npx) )
        allocate ( edge_n(npx) )
        allocate ( edge_w(npy) )
        allocate ( edge_e(npy) )

        allocate ( edge_vect_s(isd:ied) )
        allocate ( edge_vect_n(isd:ied) )
        allocate ( edge_vect_w(jsd:jed) )
        allocate ( edge_vect_e(jsd:jed) )

        allocate ( ex_s(npx) )
        allocate ( ex_n(npx) )
        allocate ( ex_w(npy) )
        allocate ( ex_e(npy) )

        edge_s = big_number
        edge_n = big_number
        edge_w = big_number
        edge_e = big_number

        edge_vect_s = big_number
        edge_vect_n = big_number
        edge_vect_w = big_number
        edge_vect_e = big_number

        ex_s(npx) = big_number
        ex_n(npx) = big_number
        ex_w(npy) = big_number
        ex_e(npy) = big_number

     endif

  end subroutine grid_utils_init

 
  subroutine grid_utils_end(uniform_ppm)
  logical, intent(IN) :: uniform_ppm
 
! deallocate sst_ncep (if allocated)
      if (allocated(sst_ncep)) deallocate( sst_ncep )
      if (allocated(sst_anom)) deallocate( sst_anom )

  if ( .not. uniform_ppm ) then
      deallocate( cx1 )
      deallocate( cx2 )
      deallocate( cy1 )
      deallocate( cy2 )
  endif

      deallocate( cosa_u )
      deallocate( cosa_v )
      deallocate( cosa_s )
      deallocate( sina_s )
      deallocate( sina_u )
      deallocate( sina_v )

      deallocate( rsin_u )
      deallocate( rsin_v )
      deallocate( rsina  )
      deallocate( rsin2  )

!     if ( .not. Gnomonic_grid ) then
           deallocate( ee1 )
           deallocate( ee2 )
!     endif

      deallocate( ec1 )
      deallocate( ec2 )
      deallocate( ew )
      deallocate( es )

      deallocate( en1 )
      deallocate( en2 )

      deallocate( eww )
      deallocate( ess )

      deallocate( edge_s )
      deallocate( edge_n )
      deallocate( edge_w )
      deallocate( edge_e )

      deallocate( edge_vect_s )
      deallocate( edge_vect_n )
      deallocate( edge_vect_w )
      deallocate( edge_vect_e )

      if ( allocated(ex_s) ) then
           deallocate( ex_s )
           deallocate( ex_n )
           deallocate( ex_w )
           deallocate( ex_e )
      endif
      if ( allocated(van2) ) deallocate( van2 )

    if ( g_type<4 ) then
      deallocate( a11 )
      deallocate( a12 )
      deallocate( a21 )
      deallocate( a22 )
      deallocate( vlon )
      deallocate( vlat )
      deallocate( z11 )
      deallocate( z12 )
      deallocate( z21 )
      deallocate( z22 )
    endif

    deallocate( divg_u )
    deallocate( divg_v )

  end subroutine grid_utils_end



  real function inner_prod(v1, v2)
       real ,intent(in):: v1(3), v2(3)
       real (f_p) :: vp1(3), vp2(3), prod16
       integer k
      
         do k=1,3
            vp1(k) = v1(k)
           vp2(k) = v2(k)
         enddo
         prod16 = vp1(1)*vp2(1) + vp1(2)*vp2(2) + vp1(3)*vp2(3)
         inner_prod = prod16

  end function inner_prod


 subroutine van2d_init(grid, agrid0, npx, npy)
  integer, intent(in):: npx, npy
  real,    intent(in)::  grid(isd:ied+1,jsd:jed+1,2)
  real,    intent(in):: agrid0(isd:ied ,jsd:jed  ,2)
!
  integer, parameter:: n16 = 16
  real:: agrid(is-2:ie+2 ,js-2:je+2,2)
  real:: a(n16,n16), b(n16,n16), x(n16), y(n16)
  real:: x3, x2, x1, y3, y2, y1, lat, lon, lat0, lon0, sum0
  real:: cos_lat, sin_lat, cos_lat0, sin_lat0, cosc, mfactor
  integer i, j, k, ip, jp

  do j=js-2, je+2
     do i=is-2, ie+2
        agrid(i,j,1) = agrid0(i,j,1)
        agrid(i,j,2) = agrid0(i,j,2)
     enddo
  enddo

  allocate ( van2(n16,is:ie+1,js:je+1) )

  van2 = 0.
  do 2500 j=js, je+1
     do 2500 i=is, ie+1
            lon0 = grid(i,j,1)
            lat0 = grid(i,j,2)
        cos_lat0 = cos(lat0)
        sin_lat0 = sin(lat0)

!--------------
! fill corners:
!--------------
! SW:
        if ( i==1 .and. j==1 ) go to 2000       ! 12-pt matrix
        if ( i==2 .and. j==1 ) then 
!rab             go to 2000
! shift the commom point
             agrid(-1,-1,1:2) = agrid(2,-1,1:2)    ! k=1
             agrid( 0,-1,1:2) = agrid(2, 0,1:2)    ! k=2
             agrid(-1, 0,1:2) = agrid(1,-1,1:2)    ! k=3
             agrid( 0, 0,1:2) = agrid(1, 0,1:2)    ! k=4
        endif
! shift the commom point
        if ( i==1 .and. j==2 ) goto 2000
        if ( i==2 .and. j==2 ) agrid(0,0,1:2) = agrid(4,4,1:2) ! k=1 

! SE:
        if ( i==npx-1 .and. j==1 ) goto 2000
        if ( i==npx   .and. j==1 ) goto 2000    ! 12-pt matrix
        if ( i==npx-1 .and. j==2 ) agrid(npx,0,1:2) = agrid(npx-4,4,1:2) ! k=4
        if ( i==npx   .and. j==2 ) goto 2000

! NE:
        if ( i==npx-1 .and. j==npy-1) agrid(npx,npy,1:2) = agrid(npx-4,npy-4,1:2) ! k=16
        if ( i==npx   .and. j==npy-1) goto 2000
        if ( i==npx-1 .and. j==npy)   goto 2000
        if ( i==npx   .and. j==npy )  goto 2000 ! 12-pt matrix

! NW:
        if ( i==1 .and. j==npy-1 ) goto 2000
        if ( i==2 .and. j==npy-1 ) agrid(0,npy,1:2) = agrid(4,npy-4,1:2) ! k=13
        if ( i==1 .and. j==npy )   goto 2000     ! 12-pt matrix
        if ( i==2 .and. j==npy )   goto 2000

        do k=1,n16
           if    ( k==1 ) then
                               ip = i-2; jp = j-2
           elseif( k==2 ) then
                               ip = i-1; jp = j-2
           elseif( k==3 ) then
                               ip = i;   jp = j-2
           elseif( k==4 ) then
                               ip = i+1; jp = j-2
           elseif( k==5 ) then
                               ip = i-2; jp = j-1
           elseif( k==6 ) then
                               ip = i-1; jp = j-1
           elseif( k==7 ) then
                               ip = i  ; jp = j-1
           elseif( k==8 ) then
                               ip = i+1; jp = j-1
           elseif( k==9 ) then
                               ip = i-2; jp = j
           elseif( k==10 ) then
                               ip = i-1; jp = j
           elseif( k==11 ) then
                               ip = i;   jp = j
           elseif( k==12 ) then
                               ip = i+1; jp = j
           elseif( k==13 ) then
                               ip = i-2; jp = j+1
           elseif( k==14 ) then
                               ip = i-1; jp = j+1
           elseif( k==15 ) then
                               ip = i;   jp = j+1
           elseif( k==16 ) then
                               ip = i+1; jp = j+1
           endif

           lon = agrid(ip,jp,1) 
           lat = agrid(ip,jp,2) 
  
           cos_lat = cos(lat)
           sin_lat = sin(lat)
! Gnomonic projection:
           mfactor = 1. / (sin_lat*sin_lat0 + cos_lat*cos_lat0*cos(lon-lon0))
           x(k) =  cos_lat *sin(lon-lon0)*mfactor
           y(k) = (cos_lat0*sin_lat-sin_lat0*cos_lat*cos(lon-lon0))*mfactor
        enddo

        do k=1,n16
!-------------------------------------
! Full 16x16 "Vandermonde" Matrix
!-------------------------------------
           x1 = x(k)
           x2 = x1*x1
           x3 = x1*x2
           y1 = y(k)
           y2 = y1*y1
           y3 = y1*y2
           a( 1,k) = x3 * y3
           a( 2,k) = x3 * y2
           a( 3,k) = x2 * y3
           a( 4,k) = x2 * y2
           a( 5,k) = x3 * y1
           a( 6,k) = x2 * y1
           a( 7,k) = x1 * y3
           a( 8,k) = x1 * y2
           a( 9,k) = x1 * y1
           a(10,k) = x3
           a(11,k) = x2
           a(12,k) = x1
           a(13,k) = y3
           a(14,k) = y2
           a(15,k) = y1
           a(16,k) = 1.
        enddo

        call invert_matrix(n16, a, b)

        do k=1,n16
           van2(k,i,j) = b(k,n16)
        enddo

        sum0 = 0.
        do k=1,n16
           sum0 = sum0 + b(k,n16)
#ifdef CHECK_VAN2
           if ( k==1 .and. i==3 .and. j==3 ) then
                write(*,*) k,'Van2(3,3):', van2(k,i,j)
!               write(*,*) '          ', lon0, lat0
           endif
#endif
        enddo
        if (abs(sum0-1.)>1.e-10) call mpp_error(FATAL, 'van2_init')
2000 continue
2500 continue


 end subroutine van2d_init

  subroutine van2_init(xs, ys, npx, npy)
  integer, intent(in):: npx, npy
  real,    intent(in), dimension(npx,npy):: xs, ys   ! coner positions
! Local:
  real, dimension(npx,npy):: lon2, lat2
  real::  grid(isd:ied+1,jsd:jed+1,2)
  real:: agrid(is-2:ie+2,js-2:je+2,2)
  integer, parameter:: n16 = 16
  real:: a(n16,n16), b(n16,n16), x(n16), y(n16)
  real:: x3, x2, x1, y3, y2, y1, lat, lon, lat0, lon0, sum0, xk
  real:: cos_lat, sin_lat, cos_lat0, sin_lat0, cosc, mfactor
  real pi
  integer i, j, k, ip, jp

  pi = 4.*atan(1.)

  do j=1,npy
     do i=1,npx
        lat2(i,j) = ys(i,j)
        lon2(i,j) = xs(i,j)
        if ( lon2(i,j) < 0. ) lon2(i,j) = lon2(i,j) + 2.*pi
     enddo
  enddo

  do j=max(1,jsd), min(npy,jed+1)
     do i=max(1,isd), min(npx,ied+1)
        grid(i,j,1) = lon2(i,j)
        grid(i,j,2) = lat2(i,j)
     enddo
  enddo

! agrid = 0.
  do j=max(1,js-2), min(npy-1,je+2)
     do i=max(1,is-2), min(npx-1,ie+2)
        call cell_center2( grid(i,j,  1:2), grid(i+1,j,  1:2),                &
                           grid(i,j+1,1:2), grid(i+1,j+1,1:2), agrid(i,j,1:2) )
     enddo
  enddo

! Fill outer edges
  if ( is==1 ) then 
       do j=max(1,js-2), min(npy-1,je+2)
          call mirror_latlon(lon2(1,1), lat2(1,1), lon2(1,npy), lat2(1,npy),   &
                             agrid(1,j,1), agrid(1,j,2), agrid(0,j,1), agrid(0,j,2))
          call mirror_latlon(lon2(1,1), lat2(1,1), lon2(1,npy), lat2(1,npy),   &
                             agrid(2,j,1), agrid(2,j,2), agrid(-1,j,1), agrid(-1,j,2))
       enddo
  endif
  if ( (ie+1)==npx ) then 
       do j=max(1,js-2), min(npy-1,je+2)
          call mirror_latlon(lon2(npx,1), lat2(npx,1), lon2(npx,npy), lat2(npx,npy),   &
                             agrid(npx-1,j,1), agrid(npx-1,j,2), agrid(npx,j,1), agrid(npx,j,2))
          call mirror_latlon(lon2(npx,1), lat2(npx,1), lon2(npx,npy), lat2(npx,npy),   &
                             agrid(npx-2,j,1), agrid(npx-2,j,2), agrid(npx+1,j,1), agrid(npx+1,j,2))
       enddo
  endif
  if ( js==1 ) then 
       do i=max(1,is-2), min(npx-1,ie+2)
          call mirror_latlon(lon2(1,1), lat2(1,1), lon2(npx,1), lat2(npx,1),   &
                             agrid(i,1,1), agrid(i,1,2), agrid(i,0,1), agrid(i,0,2))
          call mirror_latlon(lon2(1,1), lat2(1,1), lon2(npx,1), lat2(npx,1),   &
                             agrid(i,2,1), agrid(i,2,2), agrid(i,-1,1), agrid(i,-1,2))
       enddo
  endif
  if ( (je+1)==npy ) then 
       do i=max(1,is-2), min(npx-1,ie+2)
          call mirror_latlon(lon2(1,npy), lat2(1,npy), lon2(npx,npy), lat2(npx,npy),   &
                             agrid(i,npy-1,1), agrid(i,npy-1,2), agrid(i,npy,1), agrid(i,npy,2))
          call mirror_latlon(lon2(1,npy), lat2(1,npy), lon2(npx,npy), lat2(npx,npy),   &
                             agrid(i,npy-2,1), agrid(i,npy-2,2), agrid(i,npy+1,1), agrid(i,npy+1,2))
       enddo
  endif

  allocate ( van2(n16,is:ie+1,js:je+1) )

  van2 = 0.
  do 2500 j=js, je+1
     do 2500 i=is, ie+1
            lon0 = grid(i,j,1)
            lat0 = grid(i,j,2)
        cos_lat0 = cos(lat0)
        sin_lat0 = sin(lat0)
!----
! SW:
!----
        if ( i==1 .and. j==1 ) then 
             go to 2000
        endif
        if ( i==2 .and. j==1 ) then 
             agrid(0,-1,1:2) = agrid(-1,2,1:2)
             agrid(0, 0,1:2) = agrid(-1,1,1:2)
        endif
        if ( i==1 .and. j==2 ) then 
             agrid(-1,0,1:2) = agrid(2,-1,1:2)
             agrid( 0,0,1:2) = agrid(1,-1,1:2)
        endif
        if ( i==2 .and. j==2 ) then 
             agrid(0,0,1:2) = agrid(4,4,1:2)   ! add extra point to make it 16
        endif
!----
! SE:
!----
        if ( i==npx   .and. j==1 ) then 
             go to 2000
        endif
        if ( i==npx-1 .and. j==1 ) then 
             agrid(npx,-1,1:2) = agrid(npx+1,2,1:2)
             agrid(npx, 0,1:2) = agrid(npx+1,1,1:2)
        endif
        if ( i==npx-1 .and. j==2 ) then 
             agrid(npx,0,1:2) = agrid(npx-4,4,1:2)
        endif
        if ( i==npx   .and. j==2 ) then 
             agrid(npx+1,0,1:2) = agrid(npx-2,-1,1:2)
             agrid(npx,  0,1:2) = agrid(npx-1,-1,1:2)
        endif
!----
! NE:
!----
        if ( i==npx   .and. j==npy ) then 
             go to 2000
        endif
        if ( i==npx-1 .and. j==npy-1) then 
             agrid(npx,npy,1:2) = agrid(npx-4,npy-4,1:2)
        endif
        if ( i==npx   .and. j==npy-1) then 
             agrid(npx+1,npy,1:2) = agrid(npx-2,npy+1,1:2)
             agrid(npx,  npy,1:2) = agrid(npx-1,npy+1,1:2)
        endif
        if ( i==npx-1 .and. j==npy) then 
             agrid(npx,npy+1,1:2) = agrid(npx+1,npy-2,1:2)
             agrid(npx,npy,  1:2) = agrid(npx+1,npy-1,1:2)
        endif
!----
! NW:
!----
        if ( i==1 .and. j==npy ) then 
             go to 2000
        endif
        if ( i==1 .and. j==npy-1 ) then 
             agrid(-1,npy,1:2) = agrid(2,npy+1,1:2)
             agrid( 0,npy,1:2) = agrid(1,npy+1,1:2)
        endif
        if ( i==2 .and. j==npy-1 ) then 
             agrid(0,npy,1:2) = agrid(4,npy-4,1:2)
        endif
        if ( i==2 .and. j==npy ) then 
             agrid(0,npy+1,1:2) = agrid(-1,npy-2,1:2)
             agrid(0,npy,  1:2) = agrid(-1,npy-1,1:2)
        endif

        do k=1,n16
           if    ( k==1 ) then
                               ip = i-2; jp = j-2
           elseif( k==2 ) then
                               ip = i-1; jp = j-2
           elseif( k==3 ) then
                               ip = i;   jp = j-2
           elseif( k==4 ) then
                               ip = i+1; jp = j-2
           elseif( k==5 ) then
                               ip = i-2; jp = j-1
           elseif( k==6 ) then
                               ip = i-1; jp = j-1
           elseif( k==7 ) then
                               ip = i  ; jp = j-1
           elseif( k==8 ) then
                               ip = i+1; jp = j-1
           elseif( k==9 ) then
                               ip = i-2; jp = j
           elseif( k==10 ) then
                               ip = i-1; jp = j
           elseif( k==11 ) then
                               ip = i;   jp = j
           elseif( k==12 ) then
                               ip = i+1; jp = j
           elseif( k==13 ) then
                               ip = i-2; jp = j+1
           elseif( k==14 ) then
                               ip = i-1; jp = j+1
           elseif( k==15 ) then
                               ip = i;   jp = j+1
           elseif( k==16 ) then
                               ip = i+1; jp = j+1
           endif

           lon = agrid(ip,jp,1) 
           lat = agrid(ip,jp,2) 
  
           cos_lat = cos(lat)
           sin_lat = sin(lat)
! Gnomonic projection:
           mfactor = 1. / (sin_lat*sin_lat0 + cos_lat*cos_lat0*cos(lon-lon0))
           x(k) =  cos_lat *sin(lon-lon0)*mfactor
           y(k) = (cos_lat0*sin_lat - sin_lat0*cos_lat*cos(lon-lon0))*mfactor
#ifdef MIRROR_V
           if ( j==1 .or. j==npy ) then
                  xk = x(k)
                x(k) = y(k)
                y(k) = xk
           endif
#endif

        enddo

        do k=1,n16
!-------------------------------------
! Full 16x16 "Vandermonde" Matrix
!-------------------------------------
           x1 = x(k)
           x2 = x1*x1
           x3 = x1*x2
           y1 = y(k)
           y2 = y1*y1
           y3 = y1*y2
!---------------------
           a( 1,k) = x3 * y3
           a( 2,k) = x3 * y2
           a( 3,k) = x2 * y3
           a( 4,k) = x2 * y2
           a( 5,k) = x3 * y1
           a( 6,k) = x2 * y1
           a( 7,k) = x1 * y3
           a( 8,k) = x1 * y2
           a( 9,k) = x1 * y1
           a(10,k) = x3
           a(11,k) = x2
           a(12,k) = x1
           a(13,k) = y3
           a(14,k) = y2
           a(15,k) = y1
           a(16,k) = 1.
        enddo

        call invert_matrix(n16, a, b)

        do k=1,n16
           van2(k,i,j) = b(k,n16)
        enddo

        sum0 = 0.
        do k=1,n16
           sum0 = sum0 + b(k,n16)
#ifdef CHECK_VAN2
           if ( k==1 .and. i==3 .and. j==3 ) then
                write(*,*) k,'Van2(3,3):', van2(k,i,j)
!               write(*,*) '          ', lon0, lat0
           endif
#endif
        enddo
        if (abs(sum0-1.)>1.e-12) then
            write(*,*) 'Failed van point:', i,j
            call mpp_error(FATAL, 'van2_init')
        endif
2000 continue
2500 continue


 end subroutine van2_init


#ifdef USE_EXTEND_CUBE
 subroutine extend_cube_s(non_ortho, grid, agrid, npx, npy, symm)
 
! Initialization of interpolation factors for the extended cubed sphere
! for interpolating cell mean scalars beyond the cubed face
 
 logical, intent(in):: non_ortho
 real,    intent(in)::  grid(isd:ied+1,jsd:jed+1,2)
 real,    intent(in):: agrid(isd:ied  ,jsd:jed  ,2)
 integer, intent(in):: npx, npy
 logical, intent(in):: symm  ! Not working; requires global grids

 real p1(3), p2(3), p3(3), p4(3), p5(3), pp(3)
 real q1(2), q2(2)
 real d1, d2, d3
 integer i, j
 integer im2, jm2
 logical local_in, local_out
 real, parameter:: esl = 1.E-5

 allocate ( ex_s(npx) )
 allocate ( ex_n(npx) )
 allocate ( ex_w(npy) )
 allocate ( ex_e(npy) )


  if ( .not. non_ortho ) then
     ex_s = 0.
     ex_n = 0.
     ex_w = 0.
     ex_e = 0.
  else
     ex_s = big_number 
     ex_n = big_number
     ex_w = big_number
     ex_e = big_number
 
     if ( npx /= npy ) call mpp_error(FATAL, 'extend_cube_s: npx /= npy')
     if ( (npx/2)*2 == npx ) call mpp_error(FATAL, 'extend_cube_s: npx/npy is not an odd number')

     im2 = (npx-1)/2
     jm2 = (npy-1)/2

 if ( is==1 ) then
    i=1
    do j=js,je
         call latlon2xyz( agrid(i,  j,  1:2), p1)
         call mid_pt_cart(grid(i,j,1:2), grid(i,j+1,1:2), p2)
       if ( j<=jm2 ) then
! q_w(j) = (1.-ex_w(j)) * q(j) + ex_w(j) * q(j+1)
! 1st column
          call latlon2xyz( agrid(i-1,j,  1:2), p3)
          call latlon2xyz( agrid(i-1,j+1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i-1,j,  1:2) )
          d2 = great_circle_dist( q1, agrid(i-1,j+1,1:2) )
          d3 = great_circle_dist( agrid(i-1,j,1:2), agrid(i-1,j+1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_w(j) = d1 / ( d1 + d2 )
          endif
          if( ex_w(j) < esl ) ex_w(j) = 0.
!         if(gid==0) write(*,*) i,j, ex_w(j)
       else
!
! q_w(j) = (1.-ex_w(j)) * q(j) + ex_w(j) * q(j-1)
! 1st column
          call latlon2xyz( agrid(i-1,j,  1:2), p3)
          call latlon2xyz( agrid(i-1,j-1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i-1,j,  1:2) )
          d2 = great_circle_dist( q1, agrid(i-1,j-1,1:2) )
          d3 = great_circle_dist( agrid(i-1,j,1:2), agrid(i-1,j-1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_w(j) = d1 / ( d1 + d2 )
          endif
          if( ex_w(j) < esl ) ex_w(j) = 0.
!         if(gid==0) write(*,*) i,j, ex_w(j)
       endif
    enddo
 endif

 if ( (ie+1)==npx ) then
    i=npx-1
    do j=js,je
         call latlon2xyz( agrid(i  ,j, 1:2), p1)
         call mid_pt_cart(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
       if ( j<=jm2 ) then
! q_e(j) = (1.-ex_e(j)) * q(j) + ex_e(j) * q(j+1)
! 1st column
          call latlon2xyz( agrid(i+1,j,  1:2), p3)
          call latlon2xyz( agrid(i+1,j+1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i+1,j,  1:2) )
          d2 = great_circle_dist( q1, agrid(i+1,j+1,1:2) )
          d3 = great_circle_dist( agrid(i+1,j,1:2), agrid(i+1,j+1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_e(j) = d1 / ( d1 + d2 )
          endif
          if( ex_e(j) < esl ) ex_e(j) = 0.
!         if(gid==0) write(*,*) i,j, ex_e(j) - ex_w(j)
       else
!
! q_e(j) = (1.-ex_e(j)) * q(j) + ex_e(j) * q(j-1)
! 1st column
          call latlon2xyz( agrid(i+1,j,  1:2), p3)
          call latlon2xyz( agrid(i+1,j-1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i+1,j,  1:2) )
          d2 = great_circle_dist( q1, agrid(i+1,j-1,1:2) )
          d3 = great_circle_dist( agrid(i+1,j,1:2), agrid(i+1,j-1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_e(j) = d1 / ( d1 + d2 )
          endif
          if( ex_e(j) < esl ) ex_e(j) = 0.
!         if(gid==0) write(*,*) i,j, ex_e(j) - ex_w(j)
       endif
    enddo
 endif

! Make it symmetrical
 if ( symm) then
    do j=js,je
       ex_e(j) = 0.5*(ex_e(j) + ex_w(j))
       ex_w(j) = ex_e(j)
    enddo
 endif

 if ( js==1 ) then
    j=1
    do i=is,ie
          call latlon2xyz( agrid(i,j,  1:2), p1)
          call mid_pt_cart(grid(i,j,1:2), grid(i+1,j,1:2), p2)
       if ( i<=im2 ) then
! q_s(i) = (1.-ex_s(i)) * q(i) + ex_s(i) * q(i+1)
! 1st row
          call latlon2xyz( agrid(i,  j-1,1:2), p3)
          call latlon2xyz( agrid(i+1,j-1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i,  j-1,1:2) )
          d2 = great_circle_dist( q1, agrid(i+1,j-1,1:2) )
          d3 = great_circle_dist( agrid(i,j-1,1:2), agrid(i+1,j-1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_s(i) = d1 / ( d1 + d2 )
          endif
          if( ex_s(i) < esl ) ex_s(i) = 0.
!         if(gid==0) write(*,*) i,j, ex_s(i)
       else
! q_s(i) = (1.-ex_s(i)) * q(i) + ex_s(i) * q(i-1)
! 1st row
          call latlon2xyz( agrid(i,  j-1,1:2), p3)
          call latlon2xyz( agrid(i-1,j-1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i,  j-1,1:2) )
          d2 = great_circle_dist( q1, agrid(i-1,j-1,1:2) )
          d3 = great_circle_dist( agrid(i,j-1,1:2), agrid(i-1,j-1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_s(i) = d1 / ( d1 + d2 )
          endif
          if( ex_s(i) < esl ) ex_s(i) = 0.
!         if(gid==0) write(*,*) i,j, ex_s(i)
       endif
    enddo
 endif


 if ( (je+1)==npy ) then
    j=npy-1
    do i=is,ie
          call latlon2xyz( agrid(i,j,  1:2), p1)
          call mid_pt_cart(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
       if ( i<=im2 ) then
! q_n(i) = (1.-ex_n(i)) * q(i) + ex_n(i) * q(i+1)
! 1st row
          call latlon2xyz( agrid(i,  j+1,1:2), p3)
          call latlon2xyz( agrid(i+1,j+1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i,  j+1,1:2) )
          d2 = great_circle_dist( q1, agrid(i+1,j+1,1:2) )
          d3 = great_circle_dist( agrid(i,j+1,1:2), agrid(i+1,j+1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_n(i) = d1 / ( d1 + d2 )
          endif
          if( ex_n(i) < esl ) ex_n(i) = 0.
!         if(gid==0) write(*,*) i,j, ex_n(i) - ex_s(i)
       else
! q_n(i) = (1.-ex_n(i)) * q(i) + ex_n(i) * q(i-1)
! 1st row
          call latlon2xyz( agrid(i,  j+1,1:2), p3)
          call latlon2xyz( agrid(i-1,j+1,1:2), p4)
          call intersect(p1, p2, p3, p4, 1., pp, local_in, local_out)
          call cart_to_latlon(1, pp, q1(1), q1(2))
          d1 = great_circle_dist( q1, agrid(i,  j+1,1:2) )
          d2 = great_circle_dist( q1, agrid(i-1,j+1,1:2) )
          d3 = great_circle_dist( agrid(i,j+1,1:2), agrid(i-1,j+1,1:2) )
          if ( d1 > d3 ) then
               call mpp_error(FATAL, 'extend_cube_s: 1st column intp violated')
          else
               ex_n(i) = d1 / ( d1 + d2 )
          endif
          if( ex_n(i) < esl ) ex_n(i) = 0.
!         if(gid==0) write(*,*) i,j, ex_n(i) - ex_s(i)
       endif
    enddo
 endif

! Make it symmetrical
 if ( symm) then
    do i=is,ie
       ex_n(i) = 0.5*(ex_n(i) + ex_s(i))
       ex_s(i) = ex_n(i)
    enddo
 endif

 endif

 end subroutine extend_cube_s
#endif


 subroutine efactor_a2c_v(non_ortho, grid, agrid, npx, npy)
!
! Initialization of interpolation factors at face edges
! for interpolating vectors from A to C grid
!
 logical, intent(in):: non_ortho
 real,    intent(in)::  grid(isd:ied+1,jsd:jed+1,2)
 real,    intent(in):: agrid(isd:ied  ,jsd:jed  ,2)
 integer, intent(in):: npx, npy

 real px(2,isd:ied+1),  py(2,jsd:jed+1)
 real p1(2,isd:ied+1),  p2(2,jsd:jed+1)       ! mid-point
 real d1, d2
 integer i, j
 integer im2, jm2

 allocate ( edge_vect_s(isd:ied) )
 allocate ( edge_vect_n(isd:ied) )
 allocate ( edge_vect_w(jsd:jed) )
 allocate ( edge_vect_e(jsd:jed) )

  if ( .not. non_ortho ) then
     edge_vect_s = 0.
     edge_vect_n = 0.
     edge_vect_w = 0.
     edge_vect_e = 0.
  else
     edge_vect_s = big_number
     edge_vect_n = big_number
     edge_vect_w = big_number
     edge_vect_e = big_number

     if ( npx /= npy ) call mpp_error(FATAL, 'efactor_a2c_v: npx /= npy')
     if ( (npx/2)*2 == npx ) call mpp_error(FATAL, 'efactor_a2c_v: npx/npy is not an odd number')

     im2 = (npx-1)/2
     jm2 = (npy-1)/2

 if ( is==1 ) then
    i=1
    do j=js-2,je+2
       call mid_pt_sphere(agrid(i-1,j,1:2), agrid(i,j,  1:2), py(1,j))
       call mid_pt_sphere( grid(i,  j,1:2),  grid(i,j+1,1:2), p2(1,j))
    enddo

! west edge:
!------------------------------------------------------------------
! v_sw(j) = (1.-edge_vect_w(j)) * p(j) + edge_vect_w(j) * p(j+1)
!------------------------------------------------------------------
    do j=js-1,je+1
       if ( j<=jm2 ) then
            d1 = great_circle_dist( py(1,j  ), p2(1,j) )
            d2 = great_circle_dist( py(1,j+1), p2(1,j) )
            edge_vect_w(j) = d1 / ( d1 + d2 )
       else
            d2 = great_circle_dist( py(1,j-1), p2(1,j) )
            d1 = great_circle_dist( py(1,j  ), p2(1,j) )
            edge_vect_w(j) = d1 / ( d2 + d1 )
       endif
    enddo
    if ( js==1 ) then
         edge_vect_w(0) = edge_vect_w(1)
    endif
    if ( (je+1)==npy ) then
         edge_vect_w(npy) = edge_vect_w(je)
    endif
    do j=js-1,je+1
!      if ( gid==0 ) write(*,*) j, edge_vect_w(j)
    enddo
 endif

 if ( (ie+1)==npx ) then
    i=npx
    do j=jsd,jed
       call mid_pt_sphere(agrid(i-1,j,1:2), agrid(i,j,  1:2), py(1,j))
       call mid_pt_sphere( grid(i,  j,1:2),  grid(i,j+1,1:2), p2(1,j))
    enddo

    do j=js-1,je+1
       if ( j<=jm2 ) then
            d1 = great_circle_dist( py(1,j  ), p2(1,j) )
            d2 = great_circle_dist( py(1,j+1), p2(1,j) )
            edge_vect_e(j) = d1 / ( d1 + d2 )
       else
            d2 = great_circle_dist( py(1,j-1), p2(1,j) )
            d1 = great_circle_dist( py(1,j  ), p2(1,j) )
            edge_vect_e(j) = d1 / ( d2 + d1 )
       endif
    enddo
    if ( js==1 ) then
         edge_vect_e(0) = edge_vect_e(1)
    endif
    if ( (je+1)==npy ) then
         edge_vect_e(npy) = edge_vect_e(je)
    endif
    do j=js-1,je+1
!      if ( gid==0 ) write(*,*) j, edge_vect_e(j)
    enddo
 endif

 if ( js==1 ) then
    j=1
    do i=isd,ied
       call mid_pt_sphere(agrid(i,j-1,1:2), agrid(i,  j,1:2), px(1,i))
       call mid_pt_sphere( grid(i,j,  1:2),  grid(i+1,j,1:2), p1(1,i))
    enddo
! south_west edge:
!------------------------------------------------------------------
! v_s(i) = (1.-edge_vect_s(i)) * p(i) + edge_vect_s(i) * p(i+1)
!------------------------------------------------------------------
    do i=is-1,ie+1
       if ( i<=im2 ) then
            d1 = great_circle_dist( px(1,i  ), p1(1,i) )
            d2 = great_circle_dist( px(1,i+1), p1(1,i) )
            edge_vect_s(i) = d1 / ( d1 + d2 )
       else
            d2 = great_circle_dist( px(1,i-1), p1(1,i) )
            d1 = great_circle_dist( px(1,i  ), p1(1,i) )
            edge_vect_s(i) = d1 / ( d2 + d1 )
       endif
    enddo
    if ( is==1 ) then
         edge_vect_s(0) = edge_vect_s(1)
    endif
    if ( (ie+1)==npx ) then
         edge_vect_s(npx) = edge_vect_s(ie)
    endif
    do i=is-1,ie+1
!      if ( gid==0 ) write(*,*) i, edge_vect_s(i)
    enddo
 endif


 if ( (je+1)==npy ) then
! v_n(i) = (1.-edge_vect_n(i)) * p(i) + edge_vect_n(i) * p(i+1)
    j=npy
    do i=isd,ied
       call mid_pt_sphere(agrid(i,j-1,1:2), agrid(i,  j,1:2), px(1,i))
       call mid_pt_sphere( grid(i,j,  1:2),  grid(i+1,j,1:2), p1(1,i))
    enddo

    do i=is-1,ie+1
       if ( i<=im2 ) then
            d1 = great_circle_dist( px(1,i  ), p1(1,i) )
            d2 = great_circle_dist( px(1,i+1), p1(1,i) )
            edge_vect_n(i) = d1 / ( d1 + d2 )
       else
            d2 = great_circle_dist( px(1,i-1), p1(1,i) )
            d1 = great_circle_dist( px(1,i  ), p1(1,i) )
            edge_vect_n(i) = d1 / ( d2 + d1 )
       endif
    enddo
    if ( is==1 ) then
         edge_vect_n(0) = edge_vect_n(1)
    endif
    if ( (ie+1)==npx ) then
         edge_vect_n(npx) = edge_vect_n(ie)
    endif
    do i=is-1,ie+1
!      if ( gid==0 ) write(*,*) i, edge_vect_n(i)
    enddo
 endif

 endif

 end subroutine efactor_a2c_v


 subroutine edge_factors(non_ortho, grid, agrid, npx, npy)
!
! Initialization of interpolation factors at face edges
! for interpolation from A to B grid
!
 logical, intent(in):: non_ortho
 real,    intent(in)::  grid(isd:ied+1,jsd:jed+1,2)
 real,    intent(in):: agrid(isd:ied  ,jsd:jed  ,2)
 integer, intent(in):: npx, npy

 real px(2,npx), py(2,npy)
 real d1, d2
 integer i, j

 allocate ( edge_s(npx) )
 allocate ( edge_n(npx) )
 allocate ( edge_w(npy) )
 allocate ( edge_e(npy) )


  if ( .not. non_ortho ) then
     edge_s = 0.5
     edge_n = 0.5
     edge_w = 0.5
     edge_e = 0.5
  else
     edge_s = big_number
     edge_n = big_number
     edge_w = big_number
     edge_e = big_number
 
! west edge:
!----------------------------------------------------------
! p_west(j) = (1.-edge_w(j)) * p(j) + edge_w(j) * p(j-1)
!----------------------------------------------------------
 if ( is==1 ) then
    i=1
    do j=max(1,js-1), min(npy-1,je+1)
       call mid_pt_sphere(agrid(i-1,j,1:2), agrid(i,j,1:2), py(1,j))
    enddo
    do j=max(2,js), min(npy-1,je+1)
       d1 = great_circle_dist( py(1,j-1), grid(i,j,1:2) )
       d2 = great_circle_dist( py(1,j  ), grid(i,j,1:2) )
       edge_w(j) = d2 / ( d1 + d2 )
    enddo
 endif

! east edge:
!----------------------------------------------------------
! p_east(j) = (1.-edge_e(j)) * p(j) + edge_e(j) * p(j-1)
!----------------------------------------------------------
 if ( (ie+1)==npx ) then
    i=npx
    do j=max(1,js-1), min(npy-1,je+1)
       call mid_pt_sphere(agrid(i-1,j,1:2), agrid(i,j,1:2), py(1,j))
    enddo
    do j=max(2,js), min(npy-1,je+1)
       d1 = great_circle_dist( py(1,j-1), grid(i,j,1:2) )
       d2 = great_circle_dist( py(1,j  ), grid(i,j,1:2) )
       edge_e(j) = d2 / ( d1 + d2 )
! Check rounding difference:
!      if(gid==0) write(*,*) j, edge_w(j) - edge_e(j)
    enddo
 endif


! south edge:
!----------------------------------------------------------
! p_south(j) = (1.-edge_s(i)) * p(i) + edge_s(i) * p(i-1)
!----------------------------------------------------------
 if ( js==1 ) then
    j=1
    do i=max(1,is-1), min(npx-1,ie+1)
       call mid_pt_sphere(agrid(i,j-1,1:2), agrid(i,j,1:2), px(1,i))
    enddo
    do i=max(2,is), min(npx-1,ie+1)
       d1 = great_circle_dist( px(1,i-1), grid(i,j,1:2) )
       d2 = great_circle_dist( px(1,i  ), grid(i,j,1:2) )
       edge_s(i) = d2 / ( d1 + d2 )
    enddo
 endif

! North edge:
!----------------------------------------------------------
! p_north(j) = (1.-edge_n(i)) * p(i) + edge_n(i) * p(i-1)
!----------------------------------------------------------
 if ( (je+1)==npy ) then
    j=npy
    do i=max(1,is-1), min(npx-1,ie+1)
       call mid_pt_sphere(agrid(i,j-1,1:2), agrid(i,j,1:2), px(1,i))
    enddo
    do i=max(2,is), min(npx-1,ie+1)
       d1 = great_circle_dist( px(1,i-1), grid(i,j,1:2) )
       d2 = great_circle_dist( px(1,i  ), grid(i,j,1:2) )
       edge_n(i) = d2 / ( d1 + d2 )
!      if(gid==0) write(*,*) i, edge_s(i), edge_n(i)-edge_s(i)
    enddo
 endif
 endif

 end subroutine edge_factors


 subroutine gnomonic_grids(grid_type, im, lon, lat)
 integer, intent(in):: im, grid_type
 real, intent(out):: lon(im+1,im+1)
 real, intent(out):: lat(im+1,im+1)
 real pi
 integer i, j

  pi = 4.*atan(1.)


  if(grid_type==0) call gnomonic_ed(  im, lon, lat)
  if(grid_type==1) call gnomonic_dist(im, lon, lat)
  if(grid_type==2) call gnomonic_angl(im, lon, lat)


  if(grid_type<3) then
     call symm_ed(im, lon, lat)
     do j=1,im+1
        do i=1,im+1
           lon(i,j) = lon(i,j) - pi
        enddo
     enddo
!    call van2_init(lon, lat, im+1, im+1)
  endif
  
 end subroutine gnomonic_grids



 subroutine gnomonic_ed(im, lamda, theta)
!-----------------------------------------------------
! Equal distance along the 4 edges of the cubed sphere
!-----------------------------------------------------
! Properties: 
!            * defined by intersections of great circles
!            * max(dx,dy; global) / min(dx,dy; global) = sqrt(2) = 1.4142
!            * Max(aspect ratio) = 1.06089
!            * the N-S coordinate curves are const longitude on the 4 faces with equator 
! For C2000: (dx_min, dx_max) = (3.921, 5.545)    in km unit
! This is the grid of choice for global cloud resolving

 integer, intent(in):: im
 real, intent(out):: lamda(im+1,im+1)
 real, intent(out):: theta(im+1,im+1)

! Local:
 real pp(3,im+1,im+1)
! real(f_p):: pi, rsq3, alpha, delx, dely
 real:: pi, rsq3, alpha, delx, dely
 integer i, j, k

    pi = 4.*atan(1.)
  rsq3 = 1./sqrt(3.) 
 alpha = asin( rsq3 )

! Ranges:
! lamda = [0.75*pi, 1.25*pi]
! theta = [-alpha, alpha]

    dely = 2.*alpha / real(im)

! Define East-West edges:
 do j=1,im+1
    lamda(1,   j) = 0.75*pi                  ! West edge
    lamda(im+1,j) = 1.25*pi                  ! East edge
    theta(1,   j) = -alpha + dely*real(j-1)  ! West edge
    theta(im+1,j) = theta(1,j)               ! East edge
 enddo

! Get North-South edges by symmetry:

 do i=2,im
    call mirror_latlon(lamda(1,1), theta(1,1), lamda(im+1,im+1), theta(im+1,im+1), &
                       lamda(1,i), theta(1,i), lamda(i,1),       theta(i,      1) )
    lamda(i,im+1) =  lamda(i,1)
    theta(i,im+1) = -theta(i,1)
 enddo

! Set 4 corners:
    call latlon2xyz2(lamda(1    ,  1), theta(1,      1), pp(1,   1,   1))
    call latlon2xyz2(lamda(im+1,   1), theta(im+1,   1), pp(1,im+1,   1))
    call latlon2xyz2(lamda(1,   im+1), theta(1,   im+1), pp(1,   1,im+1))
    call latlon2xyz2(lamda(im+1,im+1), theta(im+1,im+1), pp(1,im+1,im+1))

! Map edges on the sphere back to cube:
! Intersections at x=-rsq3

 i=1
 do j=2,im
    call latlon2xyz2(lamda(i,j), theta(i,j), pp(1,i,j))
    pp(2,i,j) = -pp(2,i,j)*rsq3/pp(1,i,j)
    pp(3,i,j) = -pp(3,i,j)*rsq3/pp(1,i,j)
 enddo

 j=1
 do i=2,im
    call latlon2xyz2(lamda(i,j), theta(i,j), pp(1,i,1))
    pp(2,i,1) = -pp(2,i,1)*rsq3/pp(1,i,1)
    pp(3,i,1) = -pp(3,i,1)*rsq3/pp(1,i,1)
 enddo

 do j=1,im+1
    do i=1,im+1
       pp(1,i,j) = -rsq3
    enddo
 enddo

 do j=2,im+1
    do i=2,im+1
! Copy y-z face of the cube along j=1
       pp(2,i,j) = pp(2,i,1)
! Copy along i=1
       pp(3,i,j) = pp(3,1,j)
    enddo
 enddo

 call cart_to_latlon( (im+1)*(im+1), pp, lamda, theta)

 end subroutine gnomonic_ed



 subroutine gnomonic_angl(im, lamda, theta)
! This is the commonly known equi-angular grid
 integer im
 real lamda(im+1,im+1)
 real theta(im+1,im+1)
 real p(3,im+1,im+1)
! Local
 real rsq3, xf, y0, z0, y, x, z, ds
 real dy, dz
 integer j,k
 real pi, dp

 pi = 4.*atan(1.)
 dp = 0.5*pi/real(im)

 rsq3 = 1./sqrt(3.) 
 do k=1,im+1
    do j=1,im+1
       p(1,j,k) =-rsq3               ! constant
       p(2,j,k) =-rsq3*tan(-0.25*pi+(j-1)*dp)
       p(3,j,k) = rsq3*tan(-0.25*pi+(k-1)*dp)
    enddo
 enddo

 call cart_to_latlon( (im+1)*(im+1), p, lamda, theta)

 end subroutine gnomonic_angl

 subroutine gnomonic_dist(im, lamda, theta)
! This is the commonly known equi-distance grid
 integer im
 real lamda(im+1,im+1)
 real theta(im+1,im+1)
 real p(3,im+1,im+1)
! Local
 real rsq3, xf, y0, z0, y, x, z, ds
 real dy, dz
 integer j,k
 real pi

 pi = 4.*atan(1.)

! Face-2

 rsq3 = 1./sqrt(3.) 
 xf = -rsq3
 y0 =  rsq3;  dy = -2.*rsq3/im 
 z0 = -rsq3;  dz =  2.*rsq3/im

 do k=1,im+1
    do j=1,im+1
       p(1,j,k) = xf
       p(2,j,k) = y0 + (j-1)*dy
       p(3,j,k) = z0 + (k-1)*dz
    enddo
 enddo
 call cart_to_latlon( (im+1)*(im+1), p, lamda, theta)

 end subroutine gnomonic_dist

 subroutine symm_ed(im, lamda, theta)
! Make grid symmetrical to i=im/2+1
 integer im
 real lamda(im+1,im+1)
 real theta(im+1,im+1)
 integer i,j,ip,jp
 real pi, avg

 pi = 4.*atan(1.)

 do j=2,im+1
    do i=2,im
       lamda(i,j) = lamda(i,1)
    enddo
 enddo

 do j=1,im+1
    do i=1,im/2
       ip = im + 2 - i
       avg = 0.5*(lamda(i,j)-lamda(ip,j))
       lamda(i, j) = avg + pi
       lamda(ip,j) = pi - avg 
       avg = 0.5*(theta(i,j)+theta(ip,j))
       theta(i, j) = avg
       theta(ip,j) = avg
    enddo
 enddo

! Make grid symmetrical to j=im/2+1
 do j=1,im/2
       jp = im + 2 - j
    do i=2,im
       avg = 0.5*(lamda(i,j)+lamda(i,jp))
       lamda(i, j) = avg
       lamda(i,jp) = avg
       avg = 0.5*(theta(i,j)-theta(i,jp))
       theta(i, j) =  avg
       theta(i,jp) = -avg
    enddo
 enddo

 end subroutine symm_ed

 subroutine latlon2xyz2(lon, lat, p3)
 real, intent(in):: lon, lat
 real, intent(out):: p3(3)
 real e(2)

    e(1) = lon;    e(2) = lat
    call latlon2xyz(e, p3)

 end subroutine latlon2xyz2


 subroutine latlon2xyz(p, e)
!
! Routine to map (lon, lat) to (x,y,z)
!
 real, intent(in) :: p(2)
 real, intent(out):: e(3)

 integer n
 real (f_p):: q(2)
 real (f_p):: e1, e2, e3

    do n=1,2
       q(n) = p(n)
    enddo

    e1 = cos(q(2)) * cos(q(1))
    e2 = cos(q(2)) * sin(q(1))
    e3 = sin(q(2))
!-----------------------------------
! Truncate to the desired precision:
!-----------------------------------
    e(1) = e1
    e(2) = e2
    e(3) = e3

 end subroutine latlon2xyz


 subroutine mirror_xyz(p1, p2, p0, p)

! Given the "mirror" as defined by p1(x1, y1, z1), p2(x2, y2, z2), and center 
! of the sphere, compute the mirror image of p0(x0, y0, z0) as p(x, y, z)

 real, intent(in) :: p1(3), p2(3), p0(3)
 real, intent(out):: p(3)
!
 real:: x1, y1, z1, x2, y2, z2, x0, y0, z0
 real nb(3)
 real pdot
 integer k

 call vect_cross(nb, p1, p2)
    pdot = sqrt(nb(1)**2+nb(2)**2+nb(3)**2)
 do k=1,3
    nb(k) = nb(k) / pdot
 enddo

 pdot = p0(1)*nb(1) + p0(2)*nb(2) + p0(3)*nb(3)
 do k=1,3
    p(k) = p0(k) - 2.*pdot*nb(k)
 enddo

 end subroutine mirror_xyz 


 subroutine mirror_latlon(lon1, lat1, lon2, lat2, lon0, lat0, lon3, lat3)
!
! Given the "mirror" as defined by (lon1, lat1), (lon2, lat2), and center 
! of the sphere, compute the mirror image of (lon0, lat0) as  (lon3, lat3)

 real, intent(in):: lon1, lat1, lon2, lat2, lon0, lat0
 real, intent(out):: lon3, lat3
!
 real p0(3), p1(3), p2(3), nb(3), pp(3), sp(2)
 real pdot
 integer k

 call latlon2xyz2(lon0, lat0, p0)
 call latlon2xyz2(lon1, lat1, p1)
 call latlon2xyz2(lon2, lat2, p2)
 call vect_cross(nb, p1, p2)

 pdot = sqrt(nb(1)**2+nb(2)**2+nb(3)**2)
 do k=1,3
    nb(k) = nb(k) / pdot
 enddo

 pdot = p0(1)*nb(1) + p0(2)*nb(2) + p0(3)*nb(3)
 do k=1,3
    pp(k) = p0(k) - 2.*pdot*nb(k)
 enddo

 call cart_to_latlon(1, pp, sp(1), sp(2))
 lon3 = sp(1)
 lat3 = sp(2)

 end subroutine  mirror_latlon


 subroutine cart_to_latlon(np, q, xs, ys)
! vector version of cart_to_latlon1
  integer, intent(in):: np
  real, intent(inout):: q(3,np)
  real, intent(inout):: xs(np), ys(np)
! local
  real, parameter:: esl=1.e-10
  real (f_p):: p(3)
  real (f_p):: pi, dist, lat, lon
  integer i,k

  pi = 4.*atan(1.)

  do i=1,np
     do k=1,3
        p(k) = q(k,i)
     enddo
     dist = sqrt(p(1)**2 + p(2)**2 + p(3)**2)
     do k=1,3
        p(k) = p(k) / dist
     enddo

     if ( (abs(p(1))+abs(p(2)))  < esl ) then
          lon = 0.
     else
          lon = atan2( p(2), p(1) )   ! range [-pi,pi]
     endif

     if ( lon < 0.) lon = 2.*pi + lon
     lat = asin(p(3))
     
     xs(i) = lon
     ys(i) = lat
! q Normalized:
     do k=1,3
        q(k,i) = p(k)
     enddo
  enddo

 end  subroutine cart_to_latlon



 subroutine vect_cross(e, p1, p2)
 real, intent(in) :: p1(3), p2(3)
 real, intent(out):: e(3)
!
! Perform cross products of 3D vectors: e = P1 X P2
!
      e(1) = p1(2)*p2(3) - p1(3)*p2(2)
      e(2) = p1(3)*p2(1) - p1(1)*p2(3)
      e(3) = p1(1)*p2(2) - p1(2)*p2(1)

 end subroutine vect_cross



 subroutine get_center_vect( npx, npy, pp, u1, u2 )
    integer, intent(in):: npx, npy
    real, intent(in) :: pp(3,isd:ied+1,jsd:jed+1)
    real, intent(out):: u1(3,isd:ied,  jsd:jed)
    real, intent(out):: u2(3,isd:ied,  jsd:jed)
! Local:
    integer i,j,k
    real p1(3), p2(3), pc(3), p3(3)

    do j=jsd,jed
       do i=isd,ied
        if ( (i<1       .and. j<1  )     .or. (i>(npx-1) .and. j<1) .or.  &
             (i>(npx-1) .and. j>(npy-1)) .or. (i<1       .and. j>(npy-1))) then
             u1(1:3,i,j) = 0.
             u2(1:3,i,j) = 0.
        else
#ifdef NEW_VECT
          call cell_center3(pp(1,i,j), pp(1,i+1,j), pp(1,i,j+1), pp(1,i+1,j+1), pc)
! e1:
          call mid_pt3_cart(pp(1,i,j),   pp(1,i,j+1),   p1)
          call mid_pt3_cart(pp(1,i+1,j), pp(1,i+1,j+1), p2)
          call vect_cross(p3, p2, p1)
          call vect_cross(u1(1,i,j), pc, p3)
          call normalize_vect( u1(1,i,j) )
! e2:
          call mid_pt3_cart(pp(1,i,j),   pp(1,i+1,j),   p1)
          call mid_pt3_cart(pp(1,i,j+1), pp(1,i+1,j+1), p2)
          call vect_cross(p3, p2, p1)
          call vect_cross(u2(1,i,j), pc, p3)
          call normalize_vect( u2(1,i,j) )
#else
          do k=1,3
             u1(k,i,j) = pp(k,i+1,j)+pp(k,i+1,j+1) - pp(k,i,j)-pp(k,i,j+1)
             u2(k,i,j) = pp(k,i,j+1)+pp(k,i+1,j+1) - pp(k,i,j)-pp(k,i+1,j) 
          enddo
          call normalize_vect( u1(1,i,j) )
          call normalize_vect( u2(1,i,j) )
#endif
        endif
       enddo
    enddo

 end subroutine get_center_vect


 subroutine normalize_vect(e)
!                              Make e an unit vector
 real, intent(inout):: e(3)
 real(f_p):: pdot
 integer k

    pdot = e(1)**2 + e(2)**2 + e(3)**2
    pdot = sqrt( pdot ) 

!if ( pdot > 0. ) then
    do k=1,3
       e(k) = e(k) / pdot
    enddo
!else
!   do k=1,3
!      e(k) = 1. / sqrt(3.)
!   enddo
!endif

 end subroutine normalize_vect


 subroutine project_sphere_v( np, f, e )
!---------------------------------
 integer, intent(in):: np           ! total number of points
 real,    intent(in):: e(3,np)      ! input position unit vector
 real, intent(inout):: f(3,np)
! local
 real(f_p):: ap
 integer i

 do i=1,np
    ap = f(1,i)*e(1,i) + f(2,i)*e(2,i) + f(3,i)*e(3,i)
    f(1,i) = f(1,i) - ap*e(1,i)
    f(2,i) = f(2,i) - ap*e(2,i)
    f(3,i) = f(3,i) - ap*e(3,i)
 enddo

 end subroutine project_sphere_v


 subroutine intp_great_circle(beta, p1, p2, x_o, y_o)
 real, intent(in)::  beta    ! [0,1]
 real, intent(in)::  p1(2), p2(2)
 real, intent(out):: x_o, y_o     ! between p1 and p2 along GC
!------------------------------------------
    real:: pm(2)
    real:: e1(3), e2(3), e3(3)
    real:: s1, s2, s3, dd, alpha

      call latlon2xyz(p1, e1)
      call latlon2xyz(p2, e2)

       alpha = 1. - beta

       s1 = alpha*e1(1) + beta*e2(1)
       s2 = alpha*e1(2) + beta*e2(2)
       s3 = alpha*e1(3) + beta*e2(3)

       dd = sqrt( s1**2 + s2**2 + s3**2 )

       e3(1) = s1 / dd
       e3(2) = s2 / dd
       e3(3) = s3 / dd

      call cart_to_latlon(1, e3, pm(1), pm(2))

      x_o = pm(1)
      y_o = pm(2)

 end subroutine intp_great_circle


 subroutine mid_pt_sphere(p1, p2, pm)
      real , intent(IN)  :: p1(2), p2(2)
      real , intent(OUT) :: pm(2)
!------------------------------------------
      real e1(3), e2(3), e3(3)

      call latlon2xyz(p1, e1)
      call latlon2xyz(p2, e2)
      call mid_pt3_cart(e1, e2, e3)
      call cart_to_latlon(1, e3, pm(1), pm(2))

 end subroutine mid_pt_sphere



 subroutine mid_pt3_cart(p1, p2, e)
       real, intent(IN)  :: p1(3), p2(3)
       real, intent(OUT) :: e(3)
!
       real (f_p):: q1(3), q2(3)
       real (f_p):: dd, e1, e2, e3
       integer k

       do k=1,3
          q1(k) = p1(k)
          q2(k) = p2(k)
       enddo

       e1 = q1(1) + q2(1)
       e2 = q1(2) + q2(2)
       e3 = q1(3) + q2(3)

       dd = sqrt( e1**2 + e2**2 + e3**2 )
       e1 = e1 / dd
       e2 = e2 / dd
       e3 = e3 / dd

       e(1) = e1
       e(2) = e2
       e(3) = e3

 end subroutine mid_pt3_cart



 subroutine mid_pt_cart(p1, p2, e3)
    real, intent(IN)  :: p1(2), p2(2)
    real, intent(OUT) :: e3(3)
!-------------------------------------
    real e1(3), e2(3)

    call latlon2xyz(p1, e1)
    call latlon2xyz(p2, e2)
    call mid_pt3_cart(e1, e2, e3)

 end subroutine mid_pt_cart



 real function great_circle_dist( q1, q2, radius )
      real, intent(IN)           :: q1(2), q2(2)
      real, intent(IN), optional :: radius
 
      real (f_p):: p1(2), p2(2)
      real (f_p):: beta
      integer n

      do n=1,2
         p1(n) = q1(n)
         p2(n) = q2(n)
      enddo

      beta = asin( sqrt( sin((p1(2)-p2(2))/2.)**2 + cos(p1(2))*cos(p2(2))*   &
                         sin((p1(1)-p2(1))/2.)**2 ) ) * 2.

      if ( present(radius) ) then
           great_circle_dist = radius * beta
      else
           great_circle_dist = beta   ! Returns the angle
      endif

  end function great_circle_dist



 subroutine intersect(a1,a2,b1,b2,radius,x_inter,local_a,local_b)
  !--------------------------------------------------------------------!
  ! author:  Michael Herzog                                            !
  ! email:   Michael.Herzog@noaa.gov                                   !
  ! date:    July 2006                                                 !
  ! version: 0.1                                                       !
  !                                                                    !
  ! calculate intersection of two great circles                        !
  !--------------------------------------------------------------------!
    !------------------------------------------------------------------!
    ! calculate intersection of two great circles                      !
    !                                                                  !
    ! input:                                                           !
    ! a1, a2,  -   pairs of points on sphere in cartesian coordinates  !
    ! b1, b2       defining great circles                              !
    ! radius   -   radius of the sphere                                !
    !                                                                  !
    ! output:                                                          !
    ! x_inter  -   nearest intersection point of the great circles     !
    ! local_a  -   true if x1 between (a1, a2)                         !
    ! local_b  -   true if x1 between (b1, b2)                         !
    !------------------------------------------------------------------!
    real, dimension(3), intent(in)  :: a1, a2, b1, b2
    real, intent(in) :: radius
    real, dimension(3), intent(out) :: x_inter
    logical, intent(out) :: local_a,local_b
    !------------------------------------------------------------------!
    ! local variables                                                  !
    !------------------------------------------------------------------!
    real :: a2_xy, b1_xy, b2_xy, a2_xz, b1_xz, b2_xz,                   &
            b1_xyz, b2_xyz, length
    !------------------------------------------------------------------!
    ! calculate intersection point                                     !
    !------------------------------------------------------------------!
    a2_xy=a2(1)*a1(2)-a2(2)*a1(1)
    b1_xy=b1(1)*a1(2)-b1(2)*a1(1)
    b2_xy=b2(1)*a1(2)-b2(2)*a1(1)

    a2_xz=a2(1)*a1(3)-a2(3)*a1(1)
    b1_xz=b1(1)*a1(3)-b1(3)*a1(1)
    b2_xz=b2(1)*a1(3)-b2(3)*a1(1)

    b1_xyz=b1_xy*a2_xz-b1_xz*a2_xy
    b2_xyz=b2_xy*a2_xz-b2_xz*a2_xy

    if (b1_xyz==0.0) then
       x_inter(:)=b1(:)
    elseif (b2_xyz==0.0) then
       x_inter(:)=b2(:)
    else
       x_inter(:)=b2(:)-b1(:)*b2_xyz/b1_xyz
       length=sqrt(x_inter(1)*x_inter(1)+x_inter(2)*x_inter(2)+x_inter(3)*x_inter(3))
       x_inter(:)=radius/length*x_inter(:)
    endif
    !------------------------------------------------------------------!
    ! check if intersection is between pairs of points on sphere       !
    !------------------------------------------------------------------!
    call get_nearest()
    call check_local(a1,a2,local_a)
    call check_local(b1,b2,local_b)

  contains
    !------------------------------------------------------------------!
    subroutine get_nearest()
      real, dimension(3) :: center, dx
      real :: dist1,dist2

      center(:)=0.25*(a1(:)+a2(:)+b1(:)+b2(:))
      dx(:)=+x_inter(:)-center(:)
      dist1=dx(1)*dx(1)+dx(2)*dx(2)+dx(3)*dx(3)
      dx(:)=-x_inter(:)-center(:)
      dist2=dx(1)*dx(1)+dx(2)*dx(2)+dx(3)*dx(3)

      if (dist2<dist1) x_inter(:)=-x_inter(:)

    end subroutine get_nearest
    !------------------------------------------------------------------!
    subroutine check_local(x1,x2,local)
      real, dimension(3), intent(in) :: x1,x2
      logical, intent(out) :: local

      real, dimension(3) :: dx
      real :: dist, dist1, dist2

      dx(:)=x1(:)-x2(:)
      dist=dx(1)*dx(1)+dx(2)*dx(2)+dx(3)*dx(3)
    
      dx(:)=x1(:)-x_inter(:)
      dist1=dx(1)*dx(1)+dx(2)*dx(2)+dx(3)*dx(3)
      dx(:)=x2(:)-x_inter(:)
      dist2=dx(1)*dx(1)+dx(2)*dx(2)+dx(3)*dx(3)

      if (dist1<=dist .and. dist2<=dist) then
         local=.true.
      else
         local=.false.
      endif
      
    end subroutine check_local
    !------------------------------------------------------------------!
  end subroutine intersect



  subroutine unit_vect_latlon(pp, elon, elat)
      real, intent(IN)  :: pp(2)
      real, intent(OUT) :: elon(3), elat(3)

      real (f_p):: lon, lat
      real (f_p):: sin_lon, cos_lon, sin_lat, cos_lat

      lon = pp(1)
      lat = pp(2)

      sin_lon = sin(lon)
      cos_lon = cos(lon)
      sin_lat = sin(lat)
      cos_lat = cos(lat)

      elon(1) = -sin_lon
      elon(2) =  cos_lon
      elon(3) =  0.

      elat(1) = -sin_lat*cos_lon
      elat(2) = -sin_lat*sin_lon
      elat(3) =  cos_lat

  end subroutine unit_vect_latlon



  real function v_prod(v1, v2)
  real v1(3), v2(3)

       v_prod = v1(1)*v2(1) + v1(2)*v2(2) + v1(3)*v2(3)

  end function v_prod



  subroutine init_cubed_to_latlon( agrid, grid_type, ord )

  real,    intent(in) :: agrid(isd:ied,jsd:jed,2)
  integer, intent(in) :: grid_type
  integer, intent(in) :: ord
  integer i, j

   g_type = grid_type
  c2l_ord = ord

  if ( g_type < 4 ) then

     allocate (  z11(is-1:ie+1,js-1:je+1) )
     allocate (  z12(is-1:ie+1,js-1:je+1) )
     allocate (  z21(is-1:ie+1,js-1:je+1) )
     allocate (  z22(is-1:ie+1,js-1:je+1) )

     allocate (  a11(is-1:ie+1,js-1:je+1) )
     allocate (  a12(is-1:ie+1,js-1:je+1) )
     allocate (  a21(is-1:ie+1,js-1:je+1) )
     allocate (  a22(is-1:ie+1,js-1:je+1) )
!     allocate ( vlon(is-1:ie+1,js-1:je+1,3) )
!     allocate ( vlat(is-1:ie+1,js-1:je+1,3) )
     allocate ( vlon(is-2:ie+2,js-2:je+2,3) )
     allocate ( vlat(is-2:ie+2,js-2:je+2,3) )

!     do j=js-1,je+1
!        do i=is-1,ie+1
     do j=js-2,je+2
        do i=is-2,ie+2
           call unit_vect_latlon(agrid(i,j,1:2), vlon(i,j,1:3), vlat(i,j,1:3))
        enddo
     enddo

     do j=js-1,je+1
        do i=is-1,ie+1
           z11(i,j) =  v_prod(ec1(1,i,j), vlon(i,j,1:3))
           z12(i,j) =  v_prod(ec1(1,i,j), vlat(i,j,1:3))
           z21(i,j) =  v_prod(ec2(1,i,j), vlon(i,j,1:3))
           z22(i,j) =  v_prod(ec2(1,i,j), vlat(i,j,1:3))
!-------------------------------------------------------------------------
           a11(i,j) =  0.5*v_prod(ec2(1,i,j), vlat(i,j,1:3)) / sina_s(i,j)
           a12(i,j) = -0.5*v_prod(ec1(1,i,j), vlat(i,j,1:3)) / sina_s(i,j)
           a21(i,j) = -0.5*v_prod(ec2(1,i,j), vlon(i,j,1:3)) / sina_s(i,j)
           a22(i,j) =  0.5*v_prod(ec1(1,i,j), vlon(i,j,1:3)) / sina_s(i,j)
        enddo
     enddo
  endif

  end subroutine init_cubed_to_latlon


 subroutine cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, mode)
 integer, intent(in) :: km
 integer, intent(in), optional:: mode   ! update if present
 real, intent(in) :: dx(isd:ied,jsd:jed+1)
 real, intent(in) :: dy(isd:ied+1,jsd:jed)
 real, intent(in) ::rdxa(isd:ied,  jsd:jed)
 real, intent(in) ::rdya(isd:ied,  jsd:jed)
 real, intent(inout):: u(isd:ied,jsd:jed+1,km)
 real, intent(inout):: v(isd:ied+1,jsd:jed,km)
 real, intent(out):: ua(isd:ied, jsd:jed,km)
 real, intent(out):: va(isd:ied, jsd:jed,km)

 if ( c2l_ord == 2 ) then
      call c2l_ord2(u, v, ua, va, dx, dy, rdxa, rdya, km)
 else
      call c2l_ord4(u, v, ua, va, dx, dy, rdxa, rdya, km, mode)
 endif

 end subroutine cubed_to_latlon


 subroutine c2l_ord4(u, v, ua, va, dx, dy, rdxa, rdya, km, mode)

  integer, intent(in) :: km
  integer, intent(in), optional:: mode   ! update if present
  real, intent(in) ::  dx(isd:ied,jsd:jed+1)
  real, intent(in) ::  dy(isd:ied+1,jsd:jed)
  real, intent(in) ::rdxa(isd:ied,  jsd:jed)
  real, intent(in) ::rdya(isd:ied,  jsd:jed)
  real, intent(inout):: u(isd:ied,jsd:jed+1,km)
  real, intent(inout):: v(isd:ied+1,jsd:jed,km)
  real, intent(out)::  ua(isd:ied, jsd:jed,km)
  real, intent(out)::  va(isd:ied, jsd:jed,km)
! Local 
! 4-pt Lagrange interpolation
  real, parameter:: a1 =  0.5625
  real, parameter:: a2 = -0.0625
  real, parameter:: c1 =  1.125
  real, parameter:: c2 = -0.125
  real utmp(is:ie,  js:je+1)
  real vtmp(is:ie+1,js:je)
  real wu(is:ie,  js:je+1)
  real wv(is:ie+1,js:je)
  integer i, j, k

  if ( present(mode) ) then
                                   call timing_on('COMM_TOTAL')
       call mpp_update_domains(u, v, domain, gridtype=DGRID_NE)
                                  call timing_off('COMM_TOTAL')
  endif

 do k=1,km
   if ( g_type < 4 ) then
     do j=max(2,js),min(npyy-2,je)
        do i=max(2,is),min(npxx-2,ie)
           utmp(i,j) = c2*(u(i,j-1,k)+u(i,j+2,k)) + c1*(u(i,j,k)+u(i,j+1,k))
           vtmp(i,j) = c2*(v(i-1,j,k)+v(i+2,j,k)) + c1*(v(i,j,k)+v(i+1,j,k))
        enddo
     enddo

    if ( js==1 ) then
         do i=is,ie+1
            wv(i,1) = v(i,1,k)*dy(i,1)
         enddo
         do i=is,ie
            vtmp(i,1) = (wv(i,1) + wv(i+1,1)) * rdya(i,1)
            utmp(i,1) = (u(i,1,k)*dx(i,1) + u(i,2,k)*dx(i,2)) * rdxa(i,1)
         enddo
    endif

    if ( (je+1)==npyy ) then
         j = npyy-1
         do i=is,ie+1
            wv(i,j) = v(i,j,k)*dy(i,j)
         enddo
         do i=is,ie
            vtmp(i,j) = (wv(i,j) + wv(i+1,j)) * rdya(i,j)
            utmp(i,j) = (u(i,j,k)*dx(i,j) + u(i,j+1,k)*dx(i,j+1)) * rdxa(i,j)
         enddo
    endif

    if ( is==1 ) then
      i = 1
      do j=js,je
         wv(1,j) = v(1,j,k)*dy(1,j)
         wv(2,j) = v(2,j,k)*dy(2,j)
      enddo
      do j=js,je+1
         wu(i,j) = u(i,j,k)*dx(i,j)
      enddo
      do j=js,je
         utmp(i,j) = (wu(i,j) + wu(i,  j+1)) * rdxa(i,j)
         vtmp(i,j) = (wv(i,j) + wv(i+1,j  )) * rdya(i,j)
      enddo
    endif

    if ( (ie+1)==npxx ) then
      i = npxx-1
      do j=js,je
         wv(i,  j) = v(i,  j,k)*dy(i,  j)
         wv(i+1,j) = v(i+1,j,k)*dy(i+1,j)
      enddo
      do j=js,je+1
         wu(i,j) = u(i,j,k)*dx(i,j)
      enddo
      do j=js,je
         utmp(i,j) = (wu(i,j) + wu(i,  j+1)) * rdxa(i,j)
         vtmp(i,j) = (wv(i,j) + wv(i+1,j  )) * rdya(i,j)
      enddo
    endif

     do j=js,je
        do i=is,ie
           ua(i,j,k) = a11(i,j)*utmp(i,j) + a12(i,j)*vtmp(i,j)
           va(i,j,k) = a21(i,j)*utmp(i,j) + a22(i,j)*vtmp(i,j)
        enddo
     enddo
   else
! Simple Cartesian Geometry:
     do j=js,je
        do i=is,ie
           ua(i,j,k) = a2*(u(i,j-1,k)+u(i,j+2,k)) + a1*(u(i,j,k)+u(i,j+1,k))
           va(i,j,k) = a2*(v(i-1,j,k)+v(i+2,j,k)) + a1*(v(i,j,k)+v(i+1,j,k))
        enddo
     enddo
   endif
 enddo
 end subroutine c2l_ord4

 subroutine c2l_ord2(u, v, ua, va, dx, dy, rdxa, rdya, km)
  integer, intent(in) :: km
  real, intent(in) ::  u(isd:ied,jsd:jed+1,km)
  real, intent(in) ::  v(isd:ied+1,jsd:jed,km)
  real, intent(in) :: dx(isd:ied,jsd:jed+1)
  real, intent(in) :: dy(isd:ied+1,jsd:jed)
  real, intent(in) ::rdxa(isd:ied,  jsd:jed)
  real, intent(in) ::rdya(isd:ied,  jsd:jed)
!
  real, intent(out):: ua(isd:ied, jsd:jed,km)
  real, intent(out):: va(isd:ied, jsd:jed,km)
!--------------------------------------------------------------
! Local 
  real wu(is:ie,  js:je+1)
  real wv(is:ie+1,js:je)
  real u1(is:ie), v1(is:ie)
  integer i, j, k

!$omp parallel do default(shared) private(i, j, k, wu, wv, u1, v1)
  do k=1,km
     if ( g_type < 4 ) then
       do j=js,je+1
          do i=is,ie
             wu(i,j) = u(i,j,k)*dx(i,j)
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             wv(i,j) = v(i,j,k)*dy(i,j)
          enddo
       enddo

       do j=js,je
          do i=is,ie
! Co-variant to Co-variant "vorticity-conserving" interpolation
             u1(i) = (wu(i,j) + wu(i,j+1)) * rdxa(i,j)
             v1(i) = (wv(i,j) + wv(i+1,j)) * rdya(i,j)
! Cubed (cell center co-variant winds) to lat-lon:
             ua(i,j,k) = a11(i,j)*u1(i) + a12(i,j)*v1(i)
             va(i,j,k) = a21(i,j)*u1(i) + a22(i,j)*v1(i)
          enddo
       enddo
     else
! 2nd order:
       do j=js,je
          do i=is,ie
             ua(i,j,k) = 0.5*(u(i,j,k)+u(i,  j+1,k))
             va(i,j,k) = 0.5*(v(i,j,k)+v(i+1,j,  k))
          enddo
       enddo
     endif
  enddo

 end subroutine c2l_ord2


 subroutine expand_cell(q1, q2, q3, q4, a1, a2, a3, a4, fac)
! Util for land model (for BW)
!
!        4----3
!        |  . |
!        1----2
!
      real, intent(in):: q1(2), q2(2), q3(2), q4(2)
      real, intent(in):: fac    ! expansion factor: outside: > 1
                                ! fac = 1: qq1 returns q1
                                ! fac = 0: qq1 returns the center position
      real, intent(out):: a1(2), a2(2), a3(2), a4(2)
! Local
      real qq1(3), qq2(3), qq3(3), qq4(3)
      real p1(3), p2(3), p3(3), p4(3)
      real ec(3)
      real(f_p):: dd, d1, d2, d3, d4
      integer k

! Transform to (x,y,z)
      call latlon2xyz(q1, p1)
      call latlon2xyz(q2, p2)
      call latlon2xyz(q3, p3)
      call latlon2xyz(q4, p4)

! Get center position:
      do k=1,3
         ec(k) = p1(k) + p2(k) + p3(k) + p4(k)
      enddo
      dd = sqrt( ec(1)**2 + ec(2)**2 + ec(3)**2 )

      do k=1,3
         ec(k) = ec(k) / dd   ! cell center position
      enddo

! Perform the "extrapolation" in 3D (x-y-z) 
      do k=1,3
         qq1(k) = ec(k) + fac*(p1(k)-ec(k)) 
         qq2(k) = ec(k) + fac*(p2(k)-ec(k)) 
         qq3(k) = ec(k) + fac*(p3(k)-ec(k)) 
         qq4(k) = ec(k) + fac*(p4(k)-ec(k)) 
      enddo

!--------------------------------------------------------
! Force the points to be on the sphere via normalization
!--------------------------------------------------------
      d1 = sqrt( qq1(1)**2 + qq1(2)**2 + qq1(3)**2 )
      d2 = sqrt( qq2(1)**2 + qq2(2)**2 + qq2(3)**2 )
      d3 = sqrt( qq3(1)**2 + qq3(2)**2 + qq3(3)**2 )
      d4 = sqrt( qq4(1)**2 + qq4(2)**2 + qq4(3)**2 )
      do k=1,3
         qq1(k) = qq1(k) / d1
         qq2(k) = qq2(k) / d2
         qq3(k) = qq3(k) / d3
         qq4(k) = qq4(k) / d4
      enddo

!----------------------------------------
! Transform back to lat-lon coordinates:
!----------------------------------------

      call cart_to_latlon(1, qq1, a1(1), a1(2))
      call cart_to_latlon(1, qq2, a2(1), a2(2))
      call cart_to_latlon(1, qq3, a3(1), a3(2))
      call cart_to_latlon(1, qq4, a4(1), a4(2))

 end subroutine expand_cell


 subroutine cell_center2(q1, q2, q3, q4, e2)
      real , intent(in ) :: q1(2), q2(2), q3(2), q4(2)
      real , intent(out) :: e2(2)
! Local
      real p1(3), p2(3), p3(3), p4(3)
      real ec(3)
      real dd
      integer k

      call latlon2xyz(q1, p1)
      call latlon2xyz(q2, p2)
      call latlon2xyz(q3, p3)
      call latlon2xyz(q4, p4)

      do k=1,3
         ec(k) = p1(k) + p2(k) + p3(k) + p4(k)
      enddo
      dd = sqrt( ec(1)**2 + ec(2)**2 + ec(3)**2 )

      do k=1,3
         ec(k) = ec(k) / dd
      enddo

      call cart_to_latlon(1, ec, e2(1), e2(2))

 end subroutine cell_center2


 subroutine cell_center3(p1, p2, p3, p4, ec)
! Get center position of a cell
         real , intent(IN)  :: p1(3), p2(3), p3(3), p4(3)
         real , intent(OUT) :: ec(3)
! Local
         real dd
         integer k

         do k=1,3
            ec(k) = p1(k) + p2(k) + p3(k) + p4(k)
         enddo
         dd = sqrt( ec(1)**2 + ec(2)**2 + ec(3)**2 )

         do k=1,3
            ec(k) = ec(k) / dd
         enddo

 end subroutine cell_center3



 real function get_area(p1, p4, p2, p3, radius)
!-----------------------------------------------
 real, intent(in), dimension(2):: p1, p2, p3, p4
 real, intent(in), optional:: radius
!-----------------------------------------------
 real e1(3), e2(3), e3(3)
 real ang1, ang2, ang3, ang4
 real pi

 pi = 4.*atan(1.)

! S-W: 1
       call latlon2xyz(p1, e1)   ! p1
       call latlon2xyz(p2, e2)   ! p2
       call latlon2xyz(p4, e3)   ! p4
       ang1 = spherical_angle(e1, e2, e3)
!----
! S-E: 2
!----
       call latlon2xyz(p2, e1)
       call latlon2xyz(p3, e2)
       call latlon2xyz(p1, e3)
       ang2 = spherical_angle(e1, e2, e3)
!----
! N-E: 3
!----
       call latlon2xyz(p3, e1)
       call latlon2xyz(p4, e2)
       call latlon2xyz(p2, e3)
       ang3 = spherical_angle(e1, e2, e3)
!----
! N-W: 4
!----
       call latlon2xyz(p4, e1)
       call latlon2xyz(p3, e2)
       call latlon2xyz(p1, e3)
       ang4 = spherical_angle(e1, e2, e3)

       if ( present(radius) ) then
            get_area = (ang1 + ang2 + ang3 + ang4 - 2.*pi) * radius**2
       else
            get_area = ang1 + ang2 + ang3 + ang4 - 2.*pi
       endif

 end function get_area



 real function spherical_angle(p1, p2, p3)
 
!           p3
!         /
!        /
!       p1 ---> angle
!         \
!          \
!           p2

 real p1(3), p2(3), p3(3)

 real (f_p):: e1(3), e2(3), e3(3)
 real (f_p):: px, py, pz
 real (f_p):: qx, qy, qz
 real (f_p):: angle, ddd
 integer n

  do n=1,3
     e1(n) = p1(n)
     e2(n) = p2(n)
     e3(n) = p3(n)
  enddo

!-------------------------------------------------------------------
! Page 41, Silverman's book on Vector Algebra; spherical trigonmetry
!-------------------------------------------------------------------
! Vector P:
   px = e1(2)*e2(3) - e1(3)*e2(2) 
   py = e1(3)*e2(1) - e1(1)*e2(3) 
   pz = e1(1)*e2(2) - e1(2)*e2(1) 
! Vector Q:
   qx = e1(2)*e3(3) - e1(3)*e3(2) 
   qy = e1(3)*e3(1) - e1(1)*e3(3) 
   qz = e1(1)*e3(2) - e1(2)*e3(1) 

   ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz)

   if ( ddd <= 0.0 ) then
        angle = 0.
   else
        ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd)
        if ( abs(ddd)>1.) then
             angle = 2.*atan(1.0)    ! 0.5*pi
        else
             angle = acos( ddd )
        endif
   endif

   spherical_angle = angle

 end function spherical_angle


 real function cos_angle(p1, p2, p3)
! As spherical_angle, but returns the cos(angle)
 real p1(3), p2(3), p3(3)

 real (f_p):: e1(3), e2(3), e3(3)
 real (f_p):: px, py, pz
 real (f_p):: qx, qy, qz
 real (f_p):: angle, ddd
 integer n

  do n=1,3
     e1(n) = p1(n)
     e2(n) = p2(n)
     e3(n) = p3(n)
  enddo

!-------------------------------------------------------------------
! Page 41, Silverman's book on Vector Algebra; spherical trigonmetry
!-------------------------------------------------------------------
! Vector P:
   px = e1(2)*e2(3) - e1(3)*e2(2) 
   py = e1(3)*e2(1) - e1(1)*e2(3) 
   pz = e1(1)*e2(2) - e1(2)*e2(1) 
! Vector Q:
   qx = e1(2)*e3(3) - e1(3)*e3(2) 
   qy = e1(3)*e3(1) - e1(1)*e3(3) 
   qz = e1(1)*e3(2) - e1(2)*e3(1) 

   ddd = sqrt( (px**2+py**2+pz**2)*(qx**2+qy**2+qz**2) )

   if ( ddd > 0. ) then
        angle = (px*qx+py*qy+pz*qz) / ddd 
   else
        angle = 1.
   endif

   cos_angle = angle

 end function cos_angle



 real function g_sum(p, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce)
! Fast version of globalsum 
      integer, intent(IN) :: ifirst, ilast
      integer, intent(IN) :: jfirst, jlast, ngc
      integer, intent(IN) :: mode  ! if ==1 divided by area
      logical, intent(in), optional :: reproduce
      real, intent(IN) :: p(ifirst:ilast,jfirst:jlast)      ! field to be summed
      real, intent(IN) :: area(ifirst-ngc:ilast+ngc,jfirst-ngc:jlast+ngc)
      integer :: i,j
      real gsum
         
      if ( .not. g_sum_initialized ) then
         global_area = mpp_global_sum(domain, area, flags=BITWISE_EXACT_SUM)
         if ( gid==0 ) write(*,*) 'Global Area=',global_area
         g_sum_initialized = .true.
      end if
 
!-------------------------
! FMS global sum algorithm:
!-------------------------
      if ( present(reproduce) ) then
         if (reproduce) then
            gsum = mpp_global_sum(domain, p(:,:)*area(ifirst:ilast,jfirst:jlast), &
                                  flags=BITWISE_EXACT_SUM)
         else
            gsum = mpp_global_sum(domain, p(:,:)*area(ifirst:ilast,jfirst:jlast))
         endif
      else
!-------------------------
! Quick local sum algorithm
!-------------------------
         gsum = 0.
         do j=jfirst,jlast
            do i=ifirst,ilast
               gsum = gsum + p(i,j)*area(i,j)
            enddo
         enddo
         call mp_reduce_sum(gsum)
      endif

      if ( mode==1 ) then
           g_sum = gsum / global_area
      else
           g_sum = gsum
      endif

 end function g_sum


 real function global_qsum(p, ifirst, ilast, jfirst, jlast)
! quick global sum without area weighting
      integer, intent(IN) :: ifirst, ilast
      integer, intent(IN) :: jfirst, jlast
      real, intent(IN) :: p(ifirst:ilast,jfirst:jlast)      ! field to be summed
      integer :: i,j
      real gsum
         
      gsum = 0.
      do j=jfirst,jlast
         do i=ifirst,ilast
            gsum = gsum + p(i,j)
         enddo
      enddo
      call mp_reduce_sum(gsum)

      global_qsum  = gsum

 end function global_qsum


 subroutine global_mx(q, n_g, qmin, qmax)
     integer, intent(in):: n_g
     real, intent(in)::q(is-n_g:ie+n_g, js-n_g:je+n_g)
     real, intent(out):: qmin, qmax
     integer i,j

      qmin = q(is,js)
      qmax = qmin
      do j=js,je
         do i=is,ie
            qmin = min(qmin, q(i,j))
            qmax = max(qmax, q(i,j))
         enddo
      enddo
      call mp_reduce_min(qmin)
      call mp_reduce_max(qmax)

 end subroutine global_mx

 subroutine global_mx_c(q, i1, i2, j1, j2, qmin, qmax)
! For computing global max/min at cell Corners
     integer, intent(in):: i1, i2, j1, j2
     real, intent(in)   :: q(i1:i2,j1:j2)
     real, intent(out)  :: qmin, qmax
     integer i,j

      qmin = q(i1,j1)
      qmax = qmin
      do j=j1,j2
         do i=i1,i2
            qmin = min(qmin, q(i,j))
            qmax = max(qmax, q(i,j))
         enddo
      enddo
      call mp_reduce_min(qmin)
      call mp_reduce_max(qmax)

 end subroutine global_mx_c



  subroutine fill_ghost(q, npx, npy, value)
  real, intent(inout):: q(isd:ied,jsd:jed)
  integer, intent(in):: npx, npy
  real, intent(in):: value
  integer i,j

     do j=jsd,jed
        do i=isd,ied
           if ( (i<1 .and. j<1) ) then
                q(i,j) = value
           endif
           if ( i>(npx-1) .and. j<1 ) then
                q(i,j) = value
           endif
           if ( i>(npx-1) .and. j>(npy-1) ) then
                q(i,j) = value
           endif
           if ( i<1 .and. j>(npy-1) ) then
                q(i,j) = value
           endif
        enddo
     enddo

  end subroutine fill_ghost



 subroutine make_eta_level(km, pe, area, kks, ak, bk)
  integer, intent(in ):: km
  integer, intent(out):: kks
  real, intent(in):: area(isd:ied,jsd:jed)
  real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1)
  real, intent(out):: ak(km+1), bk(km+1)
! local:
  real ph(km+1)
  real, allocatable:: pem(:,:)
  real(kind=4) :: p4
  integer k, i, j

     ph(1) = pe(is,1,js)

     allocate ( pem(is:ie,js:je) )

! Compute global mean values:
     do k=2,km+1
        do j=js,je
           do i=is,ie
               pem(i,j) = pe(i,k,j)
           enddo
        enddo
! Make it the same across all PEs
!       p4 = g_sum(pem, is, ie, js, je, ng, area, mode=1)
        p4 = g_sum(pem, is, ie, js, je, ng, area, 1)
        ph(k) = p4
     enddo

! Faking a's and b's for code compatibility with hybrid sigma-p
     kks = 0
     ak(1) = ph(1)
     bk(1) = 0.
     ak(km+1) = 0.
     bk(km+1) = 1.

     do k=2,km
        bk(k) = (ph(k) - ph(1)) / (ph(km+1)-ph(1))
        ak(k) = ph(1)*(1.-bk(k))
     enddo

    if ( gid==0 ) then
         write(*,*) 'Make_eta_level ...., ptop=', ph(1)
         ptop = ph(1)
#ifdef PRINT_GRID
         do k=1,km+1
            write(*,*) ph(k), ak(k), bk(k)
         enddo
#endif
    endif

    deallocate ( pem )

 end subroutine make_eta_level

 subroutine invert_matrix(n, a, x)
  integer, intent (in) :: n
  integer :: i,j,k
  real, intent (inout), dimension (n,n):: a
  real, intent (out), dimension (n,n):: x   ! inverted maxtrix
  real, dimension (n,n) :: b
  integer indx(n)
 
  do i = 1, n
     do j = 1, n
        b(i,j) = 0.0
     end do
  end do

  do i = 1, n
     b(i,i) = 1.0
  end do
 
  call elgs (a,n,indx)
 
  do i = 1, n-1
     do j = i+1, n
        do k = 1, n
           b(indx(j),k) = b(indx(j),k) - a(indx(j),i)*b(indx(i),k)
        end do
     end do
  end do
 
  do i = 1, n
     x(n,i) = b(indx(n),i)/a(indx(n),n)
     do j = n-1, 1, -1
        x(j,i) = b(indx(j),i)
        do k = j+1, n
           x(j,i) = x(j,i)-a(indx(j),k)*x(k,i)
        end do
        x(j,i) =  x(j,i)/a(indx(j),j)
     end do
  end do

 end subroutine invert_matrix
 

 subroutine elgs (a,n,indx)

!------------------------------------------------------------------
! subroutine to perform the partial-pivoting gaussian elimination.
! a(n,n) is the original matrix in the input and transformed matrix
! plus the pivoting element ratios below the diagonal in the output.
!------------------------------------------------------------------
 
  integer, intent (in) :: n
  integer :: i,j,k,itmp
  integer, intent (out), dimension (n) :: indx
  real, intent (inout), dimension (n,n) :: a
!
  real :: c1,pi,pi1,pj
  real, dimension (n) :: c
 
  do i = 1, n
     indx(i) = i
  end do
!
! find the rescaling factors, one from each row
!
  do i = 1, n
     c1= 0.0
     do j = 1, n
        c1 = max(c1,abs(a(i,j)))
     end do
     c(i) = c1
  end do
!
! search the pivoting (largest) element from each column
!
  do j = 1, n-1
     pi1 = 0.0
     do i = j, n
        pi = abs(a(indx(i),j))/c(indx(i))
        if (pi > pi1) then
            pi1 = pi
            k   = i
        endif
     end do
!
! interchange the rows via indx(n) to record pivoting order
!
    itmp    = indx(j)
    indx(j) = indx(k)
    indx(k) = itmp
    do i = j+1, n
       pj  = a(indx(i),j)/a(indx(j),j)
!
! record pivoting ratios below the diagonal
!
       a(indx(i),j) = pj
!
! modify other elements accordingly
!
       do k = j+1, n
          a(indx(i),k) = a(indx(i),k)-pj*a(indx(j),k)
       end do
     end do
  end do
 
 end subroutine elgs

 end module fv_grid_utils_mod



module fv_mapz_mod

  use constants_mod,     only: radius, pi, rvgas, rdgas, grav
  use fv_grid_tools_mod, only: area, dx, dy, rdxa, rdya
  use fv_grid_utils_mod, only: g_sum, ptop, ptop_min, cosa_s, rsin2
  use fv_fill_mod,       only: fillz
  use fv_mp_mod,         only: gid, domain
  use mpp_domains_mod,   only: mpp_update_domains
  use mpp_mod,           only: FATAL, mpp_error, get_unit, stdlog, mpp_root_pe, mpp_pe, input_nml_file

  implicit none
  real, parameter::  r3 = 1./3., r23 = 2./3., r12 = 1./12.
  real(kind=4) :: E_FLUX
  private

  public compute_total_energy, Lagrangian_to_Eulerian,    &
         rst_remap, mappm, E_Flux, mapz_init

! following added for code segment in cs_profile
! may be removed at a later date
  logical :: mapz_is_initialized = .false.
! vertical profile reconstruction parameters
! in cs_profile
! Default: pre-Quebec behavior
  logical :: vert_profile_reconstruct_top = .false. ! top of atmosphere
  logical :: vert_profile_reconstruct_bot = .false. ! bottom of atmosphere
  namelist /fv_mapz_nml/ vert_profile_reconstruct_top, vert_profile_reconstruct_bot

CONTAINS

 subroutine Lagrangian_to_Eulerian(do_consv, consv, ps, pe, delp, pkz, pk,   &
                      pdt, km, is,ie,js,je, isd,ied,jsd,jed,       &
                      nq, sphum, u, v, w, delz, pt, q, hs, r_vir, cp,  &
                      akap, kord_mt, kord_tr, kord_tm,  peln, te0_2d,        &
                      ng, ua, va, omga, te, pem, fill, reproduce_sum,        &
                      ak, bk, ks, ze0, remap_t, hydrostatic, hybrid_z, do_omega, ktop)
  logical, intent(in):: do_consv
  real,    intent(in):: pdt                   ! phys time step
  integer, intent(in):: km
  integer, intent(in):: nq                    ! number of tracers (including h2o)
  integer, intent(in):: sphum                 ! index for water vapor (specific humidity)
  integer, intent(in):: ng
  integer, intent(in):: is,ie,isd,ied         ! starting & ending X-Dir index
  integer, intent(in):: js,je,jsd,jed         ! starting & ending Y-Dir index
  integer, intent(in):: ks, ktop
  integer, intent(in):: kord_mt               ! Mapping oder for the vector winds
  integer, intent(in):: kord_tr               ! Mapping oder for tracers
  integer, intent(in):: kord_tm               ! Mapping oder for thermodynamics

  real, intent(in):: consv                 ! factor for TE conservation
  real, intent(in):: r_vir
  real, intent(in):: cp
  real, intent(in):: akap
  real, intent(in):: hs(isd:ied,jsd:jed)  ! surface geopotential
  real, intent(in):: te0_2d(is:ie,js:je)

  logical, intent(in):: fill                  ! fill negative tracers
  logical, intent(in):: reproduce_sum
  logical, intent(in):: do_omega
  real, intent(in) :: ak(km+1)
  real, intent(in) :: bk(km+1)

! !INPUT/OUTPUT
  real, intent(inout):: pk(is:ie,js:je,km+1) ! pe to the kappa
  real, intent(inout):: q(isd:ied,jsd:jed,km,*)
  real, intent(inout):: delp(isd:ied,jsd:jed,km) ! pressure thickness
  real, intent(inout)::  pe(is-1:ie+1,km+1,js-1:je+1) ! pressure at layer edges
  real, intent(inout):: pem(is-1:ie+1,km+1,js-1:je+1)
  real, intent(inout):: ps(isd:ied,jsd:jed)      ! surface pressure
  real, intent(inout):: ze0(is:ie,js:je,km+1)    ! Specified height at edges (m)

! u-wind will be ghosted one latitude to the north upon exit
  real, intent(inout)::  u(isd:ied  ,jsd:jed+1,km)   ! u-wind (m/s)
  real, intent(inout)::  v(isd:ied+1,jsd:jed  ,km)   ! v-wind (m/s)
  real, intent(inout)::  w(isd:ied  ,jsd:jed  ,km)   ! vertical velocity (m/s)
  real, intent(inout):: pt(isd:ied  ,jsd:jed  ,km)   ! cp*virtual potential temperature 
                                                     ! as input; output: temperature
  real, intent(inout):: delz(is:ie,js:je,km)   ! delta-height (m)
  logical, intent(in):: remap_t
  logical, intent(in):: hydrostatic
  logical, intent(in):: hybrid_z

  real, intent(inout)::   ua(isd:ied,jsd:jed,km)   ! u-wind (m/s) on physics grid
  real, intent(inout)::   va(isd:ied,jsd:jed,km)   ! v-wind (m/s) on physics grid
  real, intent(inout):: omga(isd:ied,jsd:jed,km)   ! vertical press. velocity (pascal/sec)
  real, intent(inout)::   peln(is:ie,km+1,js:je)     ! log(pe)
  real, intent(out)::    pkz(is:ie,js:je,km)       ! layer-mean pk for converting t to pt
  real, intent(out)::     te(is:ie,js:je,km)

! !DESCRIPTION:
!
! !REVISION HISTORY:
! SJL 03.11.04: Initial version for partial remapping
!
!-----------------------------------------------------------------------
  integer :: i,j,k 
     real q_source(is:ie,js:je,nq)    ! numerical tracer source from surface
                                      ! in case fillz is not sufficient
      real te_2d(is:ie,js:je)
      real zsum0(is:ie,js:je)
      real zsum1(is:ie,js:je)
      real   q2(is:ie,km)
      real  dp2(is:ie,km)
      real  pe1(is:ie,km+1)
      real  pe2(is:ie,km+1)
      real  pk1(is:ie,km+1)
      real  pk2(is:ie,km+1)
      real  pn2(is:ie,km+1)
      real  pe0(is:ie+1,km+1)
      real  pe3(is:ie+1,km+1)
      real phis(is:ie,km+1)
      real   gz(is:ie)
! for nonhydrostatic option with hybrid_z coordinate
      real ze1(is:ie,km+1), ze2(is:ie,km+1), deng(is:ie,km)
      real rcp, rg, ak1, tmp, tpe, cv, rgama
      real bkh, dtmp, dlnp
      integer iq, n, kp, k_next
      logical te_map
      real k1k, kapag

        k1k = akap / (1.-akap)    ! rg/Cv=0.4
      kapag = -akap / grav
         rg = akap * cp
         cv = cp - rg
      rgama = (1.-akap)           ! cv/cp
        rcp = 1./ cp
        ak1 = (akap + 1.) / akap

      if ( kord_tm < 0 ) then
           te_map = .false.
          if ( remap_t ) then
! Transform virtual pt to virtual Temp
             do k=1,km
                do j=js,je
                   do i=is,ie
                      pt(i,j,k) = pt(i,j,k) * (pk(i,j,k+1)-pk(i,j,k)) /  &
                                 (rg*(peln(i,k+1,j)-peln(i,k,j)) )
                   enddo
                enddo
             enddo
          endif 
      else
           te_map = .true.
           call pkez(km, is, ie, js, je, pe, pk, akap, peln, pkz)
!           call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, 1)
! Compute cp*T + KE
!$omp parallel do default(shared) private(i, j, k)
           do k=1,km
              do j=js,je
                 do i=is,ie
                    te(i,j,k) = 0.25*rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 +  &
                                                 v(i,j,k)**2+v(i+1,j,k)**2 -  &
                               (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j))  &
                              +  pt(i,j,k)*pkz(i,j,k)
                 enddo
              enddo
           enddo
     endif

     if ( (.not.hydrostatic) .and. (.not.hybrid_z) ) then
!$omp parallel do default(shared) private(i, j, k)
           do k=1,km
              do j=js,je
                 do i=is,ie
                    delz(i,j,k) = -delz(i,j,k) / delp(i,j,k) ! ="specific volume"/grav
                 enddo
              enddo
           enddo
     endif

!$omp parallel do default(shared) private(i, j, k, n, iq, kp, k_next, bkh, deng, dp2, pe0, pe1, pe2, pe3, pk1, pk2, pn2, phis, q2, ze1, ze2)
  do 1000 j=js,je+1

        do k=1,km+1
           do i=is,ie
              pe1(i,k) = pe(i,k,j)
           enddo
        enddo

        do i=is,ie
           pe2(i,   1) = ptop
           pe2(i,km+1) = pe(i,km+1,j)
        enddo

  if ( j < (je+1) )  then 
! update ps
        do i=is,ie
            ps(i,j) = pe1(i,km+1)
        enddo

   if ( hybrid_z ) then
!--------------------------
! hybrid z_p coordinate
!--------------------------

        do i=is,ie
           ze1(i,km+1) = ze0(i,j,km+1)
        enddo

        do k=km,1,-1
           do i=is,ie
              ze1(i,k) = ze1(i,k+1) - delz(i,j,k)   ! current height
           enddo
        enddo
!
! Copy ztop; the top layer must be thick enough to prevent numerical problems.
!
        do i=is,ie
           ze2(i,  1) = ze1(i,1)
           ze0(i,j,1) = ze1(i,1)      ! Note: ze0 (top) updated
        enddo

        do k=2,km+1
           do i=is,ie
              ze2(i,k) = ze0(i,j,k)   ! specified height
           enddo
        enddo
!
        do k=1,km
           do i=is,ie
              deng(i,k) = -delp(i,j,k)/delz(i,j,k)  ! density * grav
           enddo
        enddo

        call remap_z(km, ze1, deng, km, ze2, deng, is, ie, abs(kord_tm))
!-------------
! Update delz
!-------------
        do k=1,km
           do i=is,ie
              delz(i,j,k) = ze2(i,k+1) - ze2(i,k)
           enddo
        enddo

!------------
! update delp
!------------
        do k=1,km-1
           do i=is,ie
               dp2(i,k  ) = -delz(i,j,k) * deng(i,k)
               pe2(i,k+1) =     pe2(i,k) +  dp2(i,k)
           enddo
        enddo

        do i=is,ie
           dp2(i,km) = pe2(i,km+1) - pe2(i,km)  ! to reduce rounding error
        enddo
   else
!
! Hybrid sigma-P coordinate:
!
        do k=2,ks+1
           do i=is,ie
              pe2(i,k) = ak(k)
           enddo
        enddo
        do k=ks+2,km
           do i=is,ie
              pe2(i,k) = ak(k) + bk(k)*pe(i,km+1,j)
           enddo
        enddo

        do k=1,km
           do i=is,ie
              dp2(i,k) = pe2(i,k+1) - pe2(i,k)
           enddo
        enddo
   endif

!------------
! update delp
!------------
      do k=1,km
         do i=is,ie
            delp(i,j,k) = dp2(i,k)
         enddo
      enddo

!----------------
! Map constituents
!----------------
       if( nq /= 0 ) then
!------------------------------------------------------------------
! Do remapping one tracer at a time; seems to be faster on the SGI
! It requires less memory than mapn_ppm
!------------------------------------------------------------------
          do iq=1,nq
             call map1_q2(km, pe1, q(isd,jsd,1,iq),     &
                          km, pe2, q2, dp2,             &
                          is, ie, 0, kord_tr, j, isd, ied, jsd, jed)
!           if (fill) call fillz(ie-is+1, km, 1, q2, dp2, q_source(is,j,iq))
            if (fill) call fillz(ie-is+1, km, 1, q2, dp2)
            do k=1,km
               do i=is,ie
                  q(i,j,k,iq) = q2(i,k)
               enddo
            enddo
          enddo
       endif

!------------------
! Compute p**cappa
!------------------
   do k=1,km+1
      do i=is,ie
         pk1(i,k) = pk(i,j,k)
      enddo
   enddo

   do i=is,ie
      pn2(i,   1) = peln(i,   1,j)
      pn2(i,km+1) = peln(i,km+1,j)
      pk2(i,   1) = pk1(i,   1)
      pk2(i,km+1) = pk1(i,km+1)
   enddo

   do k=2,km
      do i=is,ie
!        pk2(i,k) = pe2(i,k) ** akap
         pn2(i,k) = log(pe2(i,k))
         pk2(i,k) = exp(akap*pn2(i,k))
      enddo
   enddo

   if ( te_map ) then
!---------------------
! Compute Total Energy
!---------------------
        do i=is,ie
           phis(i,km+1) = hs(i,j)
        enddo
        do k=km,1,-1
           do i=is,ie
              phis(i,k) = phis(i,k+1) + pt(i,j,k)*(pk1(i,k+1)-pk1(i,k))
           enddo
        enddo
        do k=1,km+1
           do i=is,ie
              phis(i,k) = phis(i,k) * pe1(i,k)
           enddo
        enddo
        do k=1,km
           do i=is,ie
              te(i,j,k) = te(i,j,k)+(phis(i,k+1)-phis(i,k))/(pe1(i,k+1)-pe1(i,k))
           enddo
        enddo
!----------------
! Map Total Energy
!----------------
        call map1_ppm (km,   pe1,  te,       &
                       km,   pe2,  te,       &
                       is, ie, j, is, ie, js, je, 1, kord_tm)
   else
     if ( remap_t ) then
!----------------
! Map t using logp
!----------------
       call map1_ppm (km,  peln(is,1,j),  pt,    &
                      km,  pn2,           pt,    &
                      is, ie, j, isd, ied, jsd, jed, 1, abs(kord_tm))
     else
!----------------
! Map pt using pk
!----------------
       call map1_ppm (km,  pk1,  pt,           &
                      km,  pk2,  pt,           &
                      is, ie, j, isd, ied, jsd, jed, 1, abs(kord_tm))
     endif
   endif

   if ( .not. hydrostatic ) then
! Remap vertical wind:
        call map1_ppm (km,   pe1,  w,       &
                       km,   pe2,  w,       &
                       is, ie, j, isd, ied, jsd, jed, -1, kord_mt)
     if ( .not. hybrid_z ) then
! Remap delz for hybrid sigma-p coordinate
        call map1_ppm (km,   pe1, delz,    &
                       km,   pe2, delz,    &
                       is, ie, j, is,  ie,  js,  je,  1, abs(kord_tm))
        do k=1,km
           do i=is,ie
              delz(i,j,k) = -delz(i,j,k)*dp2(i,k)
           enddo
        enddo
     endif
   endif

!----------
! Update pk
!----------
   do k=2,km
      do i=is,ie
         pk(i,j,k) = pk2(i,k)
      enddo
   enddo

!----------------
   if ( do_omega ) then
! Start do_omega
! Copy omega field to pe3
      do i=is,ie
         pe3(i,1) = 0.
      enddo
      do k=2,km+1
         do i=is,ie
            pe3(i,k) = omga(i,j,k-1)
         enddo
      enddo
   endif

   do k=1,km+1
      do i=is,ie
          pe0(i,k)   = peln(i,k,j)
         peln(i,k,j) =  pn2(i,k)
      enddo
   enddo

!------------
! Compute pkz
!------------
   if ( hydrostatic ) then
      do k=1,km
         do i=is,ie
            pkz(i,j,k) = (pk2(i,k+1)-pk2(i,k))/(akap*(peln(i,k+1,j)-peln(i,k,j)))
         enddo
      enddo
   else
      if ( ktop>1 ) then
         do k=1,ktop-1
         do i=is,ie
            pkz(i,j,k) = (pk2(i,k+1)-pk2(i,k))/(akap*(peln(i,k+1,j)-peln(i,k,j)))
         enddo
         enddo
      endif
      do k=ktop,km
         do i=is,ie
! Note: pt at this stage is cp*Theta_v
!           pkz(i,j,k) = ( kapag*delp(i,j,k)*pt(i,j,k) /            &
!                         (delz(i,j,k)*(1.+r_vir*q(i,j,k,sphum))) )**k1k
            pkz(i,j,k) = exp( k1k*log(kapag*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) )
         enddo
      enddo
   endif

! Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
   if ( do_omega ) then
   do k=1,km
      do i=is,ie
         dp2(i,k) = 0.5*(peln(i,k,j) + peln(i,k+1,j))
      enddo
   enddo
   do i=is,ie
       k_next = 1
       do n=1,km
          kp = k_next
          do k=kp,km
             if( dp2(i,n) <= pe0(i,k+1) .and. dp2(i,n) >= pe0(i,k) ) then
                 omga(i,j,n) = pe3(i,k)  +  (pe3(i,k+1) - pe3(i,k)) *    &
                       (dp2(i,n)-pe0(i,k)) / (pe0(i,k+1)-pe0(i,k) )
                 k_next = k
                 exit
             endif
          enddo
       enddo
   enddo
   endif     ! end do_omega

  endif !(j < je+1)

 if ( .not.hybrid_z ) then
      do i=is,ie+1
         pe0(i,1) = pe(i,1,j)
      enddo
!------
! map u
!------
      do k=2,km+1
         do i=is,ie
            pe0(i,k) = 0.5*(pe(i,k,j-1)+pe1(i,k))
         enddo
      enddo


      do k=1,ks+1
         do i=is,ie+1
            pe3(i,k) = ak(k)
         enddo
      enddo

      do k=ks+2,km+1
         bkh = 0.5*bk(k)
         do i=is,ie
            pe3(i,k) = ak(k) + bkh*(pe(i,km+1,j-1)+pe1(i,km+1))
         enddo
      enddo

      call map1_ppm( km, pe0(is:ie,:),   u,       &
                     km, pe3(is:ie,:),   u,       &
                     is, ie, j, isd, ied, jsd, jed+1, -1, kord_mt)

   if (j < je+1) then
!------
! map v
!------
       do k=2,km+1
          do i=is,ie+1
             pe0(i ,k) = 0.5*(pe(i-1,k,j)+pe(i,k,j))
          enddo
       enddo
       do k=ks+2,km+1
          bkh = 0.5*bk(k)
          do i=is,ie+1
             pe3(i,k) = ak(k) + bkh*(pe(i-1,km+1,j)+pe(i,km+1,j))
          enddo
       enddo

       call map1_ppm (km, pe0,  v,              &
                      km, pe3,  v, is, ie+1,    &
                      j, isd, ied+1, jsd, jed, -1, kord_mt)
   endif ! (j < je+1)
 endif    ! end hybrid_z check

     do k=1,km
        do i=is,ie
           ua(i,j,k) = pe2(i,k+1)
        enddo
     enddo

1000  continue

if ( hybrid_z ) then   !------- Hybrid_z section ---------------
     call mpp_update_domains(ua , domain, complete=.true.)
! u-wind
   do j=js,je+1
      do i=is,ie
         pe1(i,1) = ptop
         pe2(i,1) = ptop
      enddo
      do k=2,km+1
         do i=is,ie
            pe1(i,k) = 0.5*(pe(i,k,  j-1) + pe(i,k,j  ))
            pe2(i,k) = 0.5*(ua(i,j-1,k-1) + ua(i,j,k-1))
         enddo
      enddo

      call map1_ppm( km, pe1,   u,       &
                     km, pe2,   u,       &
                     is, ie, j, isd, ied, jsd, jed+1, -1, kord_mt)
   enddo

! v-wind
   do j=js,je
      do i=is,ie+1
         pe0(i,1) = ptop
         pe3(i,1) = ptop
      enddo

      do k=2,km+1
         do i=is,ie+1
            pe0(i,k) = 0.5*(pe(i-1,k,j  ) + pe(i,k,j  ))
            pe3(i,k) = 0.5*(ua(i-1,j,k-1) + ua(i,j,k-1))
         enddo
      enddo

      call map1_ppm (km, pe0,  v,              &
                     km, pe3,  v, is, ie+1,    &
                     j, isd, ied+1, jsd, jed, -1, kord_mt)
   enddo
endif         !------------- Hybrid_z section ----------------------

!$omp parallel do default(shared) private(i, j, k)
  do k=2,km
     do j=js,je
        do i=is,ie
           pe(i,k,j) = ua(i,j,k-1)
        enddo
     enddo
  enddo

!  call cubed_to_latlon(u,  v, ua, va, dx, dy, rdxa, rdya, km, 1)

  if( do_consv .and. consv > 0. ) then

    if ( te_map ) then
!$omp parallel do default(shared) private(i, j, k)
      do j=js,je
          do i=is,ie
             te_2d(i,j) = te(i,j,1)*delp(i,j,1)
          enddo
          do k=2,km
             do i=is,ie
                te_2d(i,j) = te_2d(i,j) + te(i,j,k)*delp(i,j,k)
             enddo
          enddo
      enddo
    else
!$omp parallel do default(shared) private(i, j, k, gz, phis)
      do j=js,je
        if ( remap_t ) then
         do i=is,ie
            gz(i) = hs(i,j)
            do k=1,km
               gz(i) = gz(i) + rg*pt(i,j,k)*(peln(i,k+1,j)-peln(i,k,j))
            enddo
         enddo
         do i=is,ie
            te_2d(i,j) = pe(i,km+1,j)*hs(i,j) - pe(i,1,j)*gz(i)
         enddo

         do k=1,km
            do i=is,ie
               te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*pt(i,j,k) +   &
                            0.25*rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 +  &
                                             v(i,j,k)**2+v(i+1,j,k)**2 -  &
                           (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j)))
            enddo
         enddo
        else
         if ( hydrostatic ) then
            do i=is,ie
               gz(i) = hs(i,j)
               do k=1,km
                  gz(i) = gz(i) + pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k))
               enddo
            enddo

            do i=is,ie
               te_2d(i,j) = pe(i,km+1,j)*hs(i,j) - pe(i,1,j)*gz(i)
            enddo
            do k=1,km
               do i=is,ie
                  te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(pt(i,j,k)*pkz(i,j,k) +   &
                               0.25*rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 +  &
                                                v(i,j,k)**2+v(i+1,j,k)**2 -  &
                            (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j)))
               enddo
            enddo
         else
!-----------------
! Non-hydrostatic:
!-----------------
           do i=is,ie
              phis(i,km+1) = hs(i,j)
              do k=km,1,-1
                 phis(i,k) = phis(i,k+1) - grav*delz(i,j,k)
              enddo
           enddo
           do i=is,ie
              te_2d(i,j) = 0.
           enddo
           do k=1,km
              do i=is,ie
                 te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( rgama*pt(i,j,k)*pkz(i,j,k) +  &
                              0.5*(phis(i,k)+phis(i,k+1) + 0.5*rsin2(i,j)*(            &
                              u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 -  &
                             (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j))))
              enddo
           enddo
         endif

       endif
      enddo
    endif

!$omp parallel do default(shared) private(i, j, k)
      do j=js,je
         do i=is,ie
            zsum1(i,j) = pkz(i,j,1)*delp(i,j,1)
         enddo
         do k=2,km
            do i=is,ie
               zsum1(i,j) = zsum1(i,j) + pkz(i,j,k)*delp(i,j,k)
            enddo
         enddo

         do i=is,ie
            zsum0(i,j) = ptop*(pk(i,j,1)-pk(i,j,km+1)) + zsum1(i,j)
            te_2d(i,j) = te0_2d(i,j) - te_2d(i,j)
         enddo
      enddo

         tpe = consv*g_sum(te_2d, is, ie, js, je, ng, area, 0)
      E_Flux = tpe / (grav*pdt*4.*pi*radius**2)    ! unit: W/m**2
                                                   ! Note pdt is "phys" time step

      if ( hydrostatic ) then
           dtmp = tpe / (cp*g_sum(zsum0,  is, ie, js, je, ng, area, 0))
      else
           dtmp = tpe / (cv*g_sum(zsum1,  is, ie, js, je, ng, area, 0))
      endif
!-------------------------------------------------------------------------------
! One may use this quick fix to ensure reproducibility at the expense of a lower
! floating precision; this is fine for the TE correction
!-------------------------------------------------------------------------------
      if ( reproduce_sum ) dtmp = real(dtmp, 4) ! convert to 4-byte real
  else
      dtmp   = 0.
      E_Flux = 0.
  endif        ! end consv check

  if ( te_map ) then
!$omp parallel do default(shared) private(i, j, k, gz, tpe, tmp, dlnp)
      do j=js,je
         do i=is,ie
            gz(i) = hs(i,j)
         enddo
         do k=km,1,-1
            do i=is,ie
               tpe = te(i,j,k) - gz(i) - 0.25*rsin2(i,j)*(    &
                     u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 -  &
                    (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j) )
               dlnp = rg*(peln(i,k+1,j) - peln(i,k,j))
#ifdef CONVERT_T
               tmp = tpe / ((cp - pe(i,k,j)*dlnp/delp(i,j,k))*(1.+r_vir*q(i,j,k,sphum)) )
               pt(i,j,k) =  tmp + dtmp*pkz(i,j,k) / (1.+r_vir*q(i,j,k,sphum))
               gz(i) = gz(i) + dlnp*tmp*(1.+r_vir*q(i,j,k,sphum))
#else
               tmp = tpe / (cp - pe(i,k,j)*dlnp/delp(i,j,k))
               pt(i,j,k) = cp*(tmp/pkz(i,j,k) + dtmp)
               gz(i) = gz(i) + dlnp*tmp
#endif
            enddo
         enddo           ! end k-loop
      enddo
  else
    if ( remap_t ) then
      do k=1,km
         do j=js,je
            do i=is,ie
#ifdef CONVERT_T
               pt(i,j,k) = (pt(i,j,k) + dtmp*pkz(i,j,k))/(1.+r_vir*q(i,j,k,sphum))
#else
               pt(i,j,k) = cp*(pt(i,j,k)/pkz(i,j,k) + dtmp)
#endif
            enddo
         enddo   
      enddo
    else
      do k=1,km
         do j=js,je
            do i=is,ie
#ifdef CONVERT_T
               pt(i,j,k) = (rcp*pt(i,j,k) + dtmp)*pkz(i,j,k)/(1.+r_vir*q(i,j,k,sphum))
#else
               pt(i,j,k) = pt(i,j,k) + cp*dtmp
#endif
            enddo
         enddo   
      enddo
    endif
  endif

! call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, 1)

 end subroutine Lagrangian_to_Eulerian


 subroutine compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km,  &
                                 u, v, w, delz, pt, delp, q, pe, peln, hs, &
                                 r_vir,  cp, rg, hlv, te_2d, ua, va, teq, &
                                 moist_phys, sphum, hydrostatic, id_te)
!------------------------------------------------------
! Compute vertically integrated total energy per column
!------------------------------------------------------
! !INPUT PARAMETERS:
   integer,  intent(in):: km, is, ie, js, je, isd, ied, jsd, jed, id_te
   integer,  intent(in):: sphum
   real, intent(inout), dimension(isd:ied,jsd:jed,km):: ua, va
   real, intent(in), dimension(isd:ied,jsd:jed,km):: pt, delp
   real, intent(in), dimension(isd:ied,jsd:jed,km,sphum):: q
   real, intent(inout)::  u(isd:ied,  jsd:jed+1,km)
   real, intent(inout)::  v(isd:ied+1,jsd:jed,  km)
   real, intent(in)::  w(isd:ied,jsd:jed,km)   ! vertical velocity (m/s)
   real, intent(in):: delz(is:ie,js:je,km)
   real, intent(in):: hs(isd:ied,jsd:jed)  ! surface geopotential
   real, intent(in)::   pe(is-1:ie+1,km+1,js-1:je+1) ! pressure at layer edges
   real, intent(in):: peln(is:ie,km+1,js:je)  ! log(pe)
   real, intent(in):: cp, rg, r_vir, hlv
   logical, intent(in):: moist_phys, hydrostatic
! Output:
   real, intent(out):: te_2d(is:ie,js:je)   ! vertically integrated TE
   real, intent(out)::   teq(is:ie,js:je)   ! Moist TE
! Local
   real, dimension(is:ie,km):: tv
   real  phiz(is:ie,km+1)
   real cv
   integer i, j, k

   cv = cp - rg

!----------------------
! Output lat-lon winds:
!----------------------
!  call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km)

!$omp parallel do default(shared) private(i, j, k, phiz, tv)
  do j=js,je

     if ( hydrostatic ) then

        do i=is,ie
           phiz(i,km+1) = hs(i,j)
        enddo
        do k=km,1,-1
           do i=is,ie
                   tv(i,k) = pt(i,j,k)*(1.+r_vir*q(i,j,k,sphum))
                 phiz(i,k) = phiz(i,k+1) + rg*tv(i,k)*(peln(i,k+1,j)-peln(i,k,j))
           enddo
        enddo

        do i=is,ie
           te_2d(i,j) = pe(i,km+1,j)*phiz(i,km+1) - pe(i,1,j)*phiz(i,1)
        enddo

        do k=1,km
           do i=is,ie
              te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*tv(i,k) +            &
                           0.25*rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 +      &
                                            v(i,j,k)**2+v(i+1,j,k)**2 -      &
                       (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j)))
           enddo
        enddo

     else
!-----------------
! Non-hydrostatic:
!-----------------
     do i=is,ie
        phiz(i,km+1) = hs(i,j)
        do k=km,1,-1
           phiz(i,k) = phiz(i,k+1) - grav*delz(i,j,k)
        enddo
     enddo
     do i=is,ie
        te_2d(i,j) = 0.
     enddo
     do k=1,km
        do i=is,ie
!          te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv*pt(i,j,k)*(1.+r_vir*q(i,j,k,sphum)) +  &
!                       0.5*(phiz(i,k)+phiz(i,k+1)+ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2) )
           te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv*pt(i,j,k)*(1.+r_vir*q(i,j,k,sphum)) +  &
                        0.5*(phiz(i,k)+phiz(i,k+1)+0.5*rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 +  &
                        v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s(i,j))))
        enddo
     enddo
     endif
  enddo

!-------------------------------------
! Doganostics computation for moist TE
!-------------------------------------
  if( id_te>0 ) then
      do j=js,je
         do i=is,ie
            teq(i,j) = te_2d(i,j)
         enddo
      enddo
      if ( moist_phys ) then
           do k=1,km
              do j=js,je
                 do i=is,ie
                    teq(i,j) = teq(i,j) + hlv*q(i,j,k,sphum)*delp(i,j,k)
                 enddo
              enddo
           enddo
      endif
!     do j=js,je
!        do i=is,ie
!           teq(i,j) = teq(i,j) / (pe(i,km,j) - pe(i,1,j))
!        enddo
!     enddo
   endif

  end subroutine compute_total_energy


  subroutine pkez(km, ifirst, ilast, jfirst, jlast, &
                  pe, pk, akap, peln, pkz)

! !INPUT PARAMETERS:
   integer, intent(in):: km
   integer, intent(in):: ifirst, ilast        ! Latitude strip
   integer, intent(in):: jfirst, jlast        ! Latitude strip
   real, intent(in):: akap
   real, intent(in):: pe(ifirst-1:ilast+1,km+1,jfirst-1:jlast+1)
   real, intent(in):: pk(ifirst:ilast,jfirst:jlast,km+1)
! !OUTPUT
   real, intent(out):: pkz(ifirst:ilast,jfirst:jlast,km)
   real, intent(inout):: peln(ifirst:ilast, km+1, jfirst:jlast)   ! log (pe)
! Local
   real pk2(ifirst:ilast, km+1)
   real pek
   real lnp
   real ak1
   integer i, j, k

   ak1 = (akap + 1.) / akap

!$omp parallel do default(shared) private(i, j, k, lnp, pek, pk2)
   do j=jfirst, jlast
        pek = pk(ifirst,j,1)
        do i=ifirst, ilast
           pk2(i,1) = pek
        enddo

        do k=2,km+1
           do i=ifirst, ilast
!             peln(i,k,j) =  log(pe(i,k,j))
              pk2(i,k) =  pk(i,j,k)
           enddo
        enddo

!---- GFDL modification
       if( ptop < ptop_min ) then
           do i=ifirst, ilast
               peln(i,1,j) = peln(i,2,j) - ak1
           enddo
       else
           lnp = log( ptop )
           do i=ifirst, ilast
              peln(i,1,j) = lnp
           enddo
       endif
!---- GFDL modification

       do k=1,km
          do i=ifirst, ilast
             pkz(i,j,k) = (pk2(i,k+1) - pk2(i,k) )  /  &
                          (akap*(peln(i,k+1,j) - peln(i,k,j)) )
          enddo
       enddo
    enddo

 end subroutine pkez



 subroutine remap_z(km, pe1, q1, kn, pe2, q2, i1, i2, kord)

! !INPUT PARAMETERS:
      integer, intent(in) :: i1                ! Starting longitude
      integer, intent(in) :: i2                ! Finishing longitude
      integer, intent(in) :: kord              ! Method order
      integer, intent(in) :: km                ! Original vertical dimension
      integer, intent(in) :: kn                ! Target vertical dimension

      real, intent(in) ::  pe1(i1:i2,km+1)     ! height at layer edges 
                                               ! (from model top to bottom surface)
      real, intent(in) ::  pe2(i1:i2,kn+1)     ! hieght at layer edges 
                                               ! (from model top to bottom surface)
      real, intent(in) ::  q1(i1:i2,km)        ! Field input

! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout)::  q2(i1:i2,kn)      ! Field output

! !LOCAL VARIABLES:
      real  dp1(  i1:i2,km)
      real   q4(4,i1:i2,km)
      real   pl, pr, qsum, delp, esl
      integer i, k, l, m, k0

      do k=1,km
         do i=i1,i2
             dp1(i,k) = pe1(i,k+1) - pe1(i,k)      ! negative
            q4(1,i,k) = q1(i,k)
         enddo
      enddo

! Compute vertical subgrid distribution
   if ( kord >7 ) then
        call  cs_profile( q4, dp1, km, i1, i2, 1 )
   else
        call ppm_profile( q4, dp1, km, i1, i2, 1, kord )
   endif

! Mapping
      do 1000 i=i1,i2
         k0 = 1
      do 555 k=1,kn
      do 100 l=k0,km
! locate the top edge: pe2(i,k)
      if(pe2(i,k) <= pe1(i,l) .and. pe2(i,k) >= pe1(i,l+1)) then
         pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l)
         if(pe2(i,k+1) >= pe1(i,l+1)) then
! entire new grid is within the original grid
            pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l)
            q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l))  &
                       *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2)
               k0 = l
               goto 555
          else
! Fractional area...
            qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+   &
                    q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)*           &
                     (r3*(1.+pl*(1.+pl))))
              do m=l+1,km
! locate the bottom edge: pe2(i,k+1)
                 if(pe2(i,k+1) < pe1(i,m+1) ) then
! Whole layer..
                    qsum = qsum + dp1(i,m)*q4(1,i,m)
                 else
                    delp = pe2(i,k+1)-pe1(i,m)
                    esl = delp / dp1(i,m)
                    qsum = qsum + delp*(q4(2,i,m)+0.5*esl*               &
                         (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl)))
                    k0 = m
                 goto 123
                 endif
              enddo
              goto 123
           endif
      endif
100   continue
123   q2(i,k) = qsum / ( pe2(i,k+1) - pe2(i,k) )
555   continue
1000  continue

 end subroutine remap_z


 subroutine map1_ppm( km,   pe1,    q1,                 &
                      kn,   pe2,    q2,   i1, i2,       &
                      j,    ibeg, iend, jbeg, jend, iv,  kord)
 integer, intent(in) :: i1                ! Starting longitude
 integer, intent(in) :: i2                ! Finishing longitude
 integer, intent(in) :: iv                ! Mode: 0 ==  constituents  1 == ???
                                          !       2 = potential temp
 integer, intent(in) :: kord              ! Method order
 integer, intent(in) :: j                 ! Current latitude
 integer, intent(in) :: ibeg, iend, jbeg, jend
 integer, intent(in) :: km                ! Original vertical dimension
 integer, intent(in) :: kn                ! Target vertical dimension
 real, intent(in) ::  pe1(i1:i2,km+1)  ! pressure at layer edges 
                                       ! (from model top to bottom surface)
                                       ! in the original vertical coordinate
 real, intent(in) ::  pe2(i1:i2,kn+1)  ! pressure at layer edges 
                                       ! (from model top to bottom surface)
                                       ! in the new vertical coordinate
 real, intent(in) ::    q1(ibeg:iend,jbeg:jend,km) ! Field input
! !INPUT/OUTPUT PARAMETERS:
 real, intent(inout)::  q2(ibeg:iend,jbeg:jend,kn) ! Field output

! !DESCRIPTION:
! IV = 0: constituents
! pe1: pressure at layer edges (from model top to bottom surface)
!      in the original vertical coordinate
! pe2: pressure at layer edges (from model top to bottom surface)
!      in the new vertical coordinate
! !LOCAL VARIABLES:
   real    dp1(i1:i2,km)
   real   q4(4,i1:i2,km)
   real    pl, pr, qsum, dp, esl
   integer i, k, l, m, k0

   do k=1,km
      do i=i1,i2
         dp1(i,k) = pe1(i,k+1) - pe1(i,k)
         q4(1,i,k) = q1(i,j,k)
      enddo
   enddo

! Compute vertical subgrid distribution
   if ( kord >7 ) then
        call  cs_profile( q4, dp1, km, i1, i2, iv )
   else
        call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
   endif

  do i=i1,i2
     k0 = 1
     do 555 k=1,kn
      do l=k0,km
! locate the top edge: pe2(i,k)
      if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then
         pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l)
         if( pe2(i,k+1) <= pe1(i,l+1) ) then
! entire new grid is within the original grid
            pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l)
            q2(i,j,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l))  &
                       *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2)
               k0 = l
               goto 555
         else
! Fractional area...
            qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+   &
                    q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)*           &
                     (r3*(1.+pl*(1.+pl))))
              do m=l+1,km
! locate the bottom edge: pe2(i,k+1)
                 if( pe2(i,k+1) > pe1(i,m+1) ) then
! Whole layer
                     qsum = qsum + dp1(i,m)*q4(1,i,m)
                 else
                     dp = pe2(i,k+1)-pe1(i,m)
                     esl = dp / dp1(i,m)
                     qsum = qsum + dp*(q4(2,i,m)+0.5*esl*               &
                           (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl)))
                     k0 = m
                     goto 123
                 endif
              enddo
              goto 123
         endif
      endif
      enddo
123   q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) )
555   continue
  enddo

 end subroutine map1_ppm


 subroutine map1_q2(km,   pe1,   q1,            &
                    kn,   pe2,   q2,   dp2,     &
                    i1,   i2,    iv,   kord, j, &
                    ibeg, iend, jbeg, jend )


! !INPUT PARAMETERS:
      integer, intent(in) :: j
      integer, intent(in) :: i1, i2
      integer, intent(in) :: ibeg, iend, jbeg, jend
      integer, intent(in) :: iv                ! Mode: 0 ==  constituents 1 == ???
      integer, intent(in) :: kord
      integer, intent(in) :: km                ! Original vertical dimension
      integer, intent(in) :: kn                ! Target vertical dimension

      real, intent(in) ::  pe1(i1:i2,km+1)     ! pressure at layer edges 
                                               ! (from model top to bottom surface)
                                               ! in the original vertical coordinate
      real, intent(in) ::  pe2(i1:i2,kn+1)     ! pressure at layer edges 
                                               ! (from model top to bottom surface)
                                               ! in the new vertical coordinate
      real, intent(in) ::  q1(ibeg:iend,jbeg:jend,km) ! Field input
      real, intent(in) ::  dp2(i1:i2,kn)
! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout):: q2(i1:i2,kn) ! Field output
! !LOCAL VARIABLES:
      real   dp1(i1:i2,km)
      real   q4(4,i1:i2,km)
      real   pl, pr, qsum, dp, esl

      integer i, k, l, m, k0

      do k=1,km
         do i=i1,i2
             dp1(i,k) = pe1(i,k+1) - pe1(i,k)
            q4(1,i,k) = q1(i,j,k)
         enddo
      enddo

! Compute vertical subgrid distribution
   if ( kord >7 ) then
        call  cs_profile( q4, dp1, km, i1, i2, iv )
   else
        call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
   endif

! Mapping
      do 1000 i=i1,i2
         k0 = 1
      do 555 k=1,kn
      do 100 l=k0,km
! locate the top edge: pe2(i,k)
      if(pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1)) then
         pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l)
         if(pe2(i,k+1) <= pe1(i,l+1)) then
! entire new grid is within the original grid
            pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l)
            q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l))  &
                       *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2)
               k0 = l
               goto 555
          else
! Fractional area...
            qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+   &
                    q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)*           &
                     (r3*(1.+pl*(1.+pl))))
              do m=l+1,km
! locate the bottom edge: pe2(i,k+1)
                 if(pe2(i,k+1) > pe1(i,m+1) ) then
                                                   ! Whole layer..
                    qsum = qsum + dp1(i,m)*q4(1,i,m)
                 else
                     dp = pe2(i,k+1)-pe1(i,m)
                    esl = dp / dp1(i,m)
                   qsum = qsum + dp*(q4(2,i,m)+0.5*esl*               &
                       (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl)))
                   k0 = m
                   goto 123
                 endif
              enddo
              goto 123
          endif
      endif
100   continue
123   q2(i,k) = qsum / dp2(i,k)
555   continue
1000  continue

 end subroutine map1_q2



 subroutine remap_2d(km,   pe1,   q1,        &
                     kn,   pe2,   q2,        &
                     i1,   i2,    iv,   kord )
   integer, intent(in):: i1, i2
   integer, intent(in):: iv               ! Mode: 0 ==  constituents 1 ==others
   integer, intent(in):: kord
   integer, intent(in):: km               ! Original vertical dimension
   integer, intent(in):: kn               ! Target vertical dimension
   real, intent(in):: pe1(i1:i2,km+1)     ! pressure at layer edges 
                                          ! (from model top to bottom surface)
                                          ! in the original vertical coordinate
   real, intent(in):: pe2(i1:i2,kn+1)     ! pressure at layer edges 
                                          ! (from model top to bottom surface)
                                          ! in the new vertical coordinate
   real, intent(in) :: q1(i1:i2,km) ! Field input
   real, intent(out):: q2(i1:i2,kn) ! Field output
! !LOCAL VARIABLES:
   real   dp1(i1:i2,km)
   real   q4(4,i1:i2,km)
   real   pl, pr, qsum, dp, esl
   integer i, k, l, m, k0

   do k=1,km
      do i=i1,i2
          dp1(i,k) = pe1(i,k+1) - pe1(i,k)
         q4(1,i,k) = q1(i,k)
      enddo
   enddo

! Compute vertical subgrid distribution
   if ( kord >7 ) then
        call  cs_profile( q4, dp1, km, i1, i2, iv )
   else
        call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
   endif

   do i=i1,i2
      k0 = 1
      do 555 k=1,kn
         if( pe2(i,k+1) <= pe1(i,1) ) then
! Entire grid above old ptop
             q2(i,k) = q4(2,i,1)
         elseif( pe2(i,k) < pe1(i,1) .and. pe2(i,k+1)>pe1(i,1) ) then
! Partially above old ptop:
             q2(i,k) = q1(i,1)
         else
           do l=k0,km
! locate the top edge: pe2(i,k)
           if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then
               pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l)
               if(pe2(i,k+1) <= pe1(i,l+1)) then
! entire new grid is within the original grid
                  pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l)
                  q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l))  &
                          *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2)
                  k0 = l
                  goto 555
               else
! Fractional area...
                 qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+   &
                         q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)*           &
                        (r3*(1.+pl*(1.+pl))))
                 do m=l+1,km
! locate the bottom edge: pe2(i,k+1)
                    if(pe2(i,k+1) > pe1(i,m+1) ) then
                                                   ! Whole layer..
                       qsum = qsum + dp1(i,m)*q4(1,i,m)
                    else
                       dp = pe2(i,k+1)-pe1(i,m)
                      esl = dp / dp1(i,m)
                      qsum = qsum + dp*(q4(2,i,m)+0.5*esl*               &
                            (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl)))
                      k0 = m
                      goto 123
                    endif
                 enddo
                 goto 123
               endif
           endif
           enddo
123        q2(i,k) = qsum / ( pe2(i,k+1) - pe2(i,k) )
         endif
555   continue
   enddo

 end subroutine remap_2d


 subroutine cs_profile(a4, delp, km, i1, i2, iv)
! Optimized vertical profile reconstruction:
! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
 integer, intent(in):: i1, i2
 integer, intent(in):: km      ! vertical dimension
 integer, intent(in):: iv      ! iv =-1: winds
                               ! iv = 0: positive definite scalars
                               ! iv = 1: others
 real, intent(in)   :: delp(i1:i2,km)     ! layer pressure thickness
 real, intent(inout):: a4(4,i1:i2,km)     ! Interpolated values
!-----------------------------------------------------------------------
 real  gam(i1:i2,km)
 real    q(i1:i2,km+1)
 real   d4(i1:i2)
 real   bet, a_bot, grat, pmp, lac
 integer i, k, im

  if (.not. mapz_is_initialized) then
!$OMP MASTER
     call mapz_init
!$OMP END MASTER
!$OMP BARRIER
  endif

  do i=i1,i2
         grat = delp(i,2) / delp(i,1)   ! grid ratio
          bet = grat*(grat+0.5)
       q(i,1) = ( (grat+grat)*(grat+1.)*a4(1,i,1) + a4(1,i,2) ) / bet
     gam(i,1) = ( 1. + grat*(grat+1.5) ) / bet
  enddo

  do k=2,km
     do i=i1,i2
           d4(i) = delp(i,k-1) / delp(i,k)
             bet =  2. + d4(i) + d4(i) - gam(i,k-1)
          q(i,k) = ( 3.*(a4(1,i,k-1)+d4(i)*a4(1,i,k)) - q(i,k-1) )/bet
        gam(i,k) = d4(i) / bet
     enddo
  enddo
 
  do i=i1,i2
         a_bot = 1. + d4(i)*(d4(i)+1.5)
     q(i,km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1,i,km)+a4(1,i,km-1)-a_bot*q(i,km))  &
               / ( d4(i)*(d4(i)+0.5) - a_bot*gam(i,km) )
  enddo

  do k=km,1,-1
     do i=i1,i2
        q(i,k) = q(i,k) - gam(i,k)*q(i,k+1)
     enddo
  enddo

!------------------
! Apply constraints
!------------------
  im = i2 - i1 + 1

  do k=2,km
     do i=i1,i2
        gam(i,k) = a4(1,i,k) - a4(1,i,k-1)
     enddo
  enddo

! Apply large-scale constraints to ALL fields if not local max/min

! added a namelist parameter for this section
! namelist and original method may be removed at a later date
! Top:
  IF ( vert_profile_reconstruct_top ) THEN
! new formulation of damping to reduce instabilities for remap temperature
    if ( iv==0 ) then
       do i=i1,i2
          q(i,2) = min( q(i,2), max(a4(1,i,1), a4(1,i,2)) )
          q(i,2) = max( q(i,2), min(a4(1,i,1), a4(1,i,2)), 0.)
       enddo
    else
       do i=i1,i2
          q(i,2) = min( q(i,2), max(a4(1,i,1), a4(1,i,2)) )
          q(i,2) = max( q(i,2), min(a4(1,i,1), a4(1,i,2)) )
       enddo
    endif
  ELSE   ! original method
! The following at times produced instability at layer #2 if used for remap temperature
    if ( iv==-1 ) then
       ! winds:
       do i=i1,i2
          q(i,2) = min( q(i,2), max(a4(1,i,1), a4(1,i,2)) )
          q(i,2) = max( q(i,2), min(a4(1,i,1), a4(1,i,2)) )
       enddo
    else     
       do i=i1,i2
          if ( (q(i,2)-q(i,1))*(q(i,3)-q(i,2))>0. ) then
               q(i,2) = min( q(i,2), max(a4(1,i,1), a4(1,i,2)) )
               q(i,2) = max( q(i,2), min(a4(1,i,1), a4(1,i,2)) )
           elseif ( iv==0 ) then
               q(i,2) = max(0., q(i,2))
           endif
       enddo
    endif
  ENDIF


! Interior:
  do k=3,km-1
     do i=i1,i2
        if ( gam(i,k-1)*gam(i,k+1)>0. ) then
! Apply large-scale constraint to ALL fields if not local max/min
             q(i,k) = min( q(i,k), max(a4(1,i,k-1),a4(1,i,k)) )
             q(i,k) = max( q(i,k), min(a4(1,i,k-1),a4(1,i,k)) )
        else
          if ( gam(i,k-1) > 0. ) then
! There exists a local max
               q(i,k) = max(q(i,k), min(a4(1,i,k-1),a4(1,i,k)))
          else
            if ( iv==0 ) then
                 q(i,k) = max(0., q(i,k))
            else
! There exists a local min
                 q(i,k) = min(q(i,k), max(a4(1,i,k-1),a4(1,i,k)))
            endif
          endif
        endif
     enddo
  enddo

! Top & bot surfaces
  if ( iv==0 ) then
       do i=i1,i2
          q(i,   1) = max(0., q(i,   1))
          q(i,km+1) = max(0., q(i,km+1))
       enddo
  endif


! added a namelist parameter for this section
! namelist and original method may be removed at a later date
! Bottom:
  IF ( vert_profile_reconstruct_bot ) THEN
! new formulation of damping to provide symmetry with new remapping at the top
    if ( iv==-1 ) then
       do i=i1,i2
          q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) )
          q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) )
          q(i,km+1) = sign(min(abs(q(i,km+1)), abs(a4(1,i,km))), a4(1,i,km))
       enddo
    elseif ( iv==0 ) then
       do i=i1,i2
          q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) )
          q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)), 0.)
       enddo
    else
       do i=i1,i2
          q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) )
          q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) )
       enddo
    endif
  ELSE   ! original method
    if ( iv==-1 ) then
       do i=i1,i2
          q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) )
          q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) )
       enddo
#ifndef SLIP_SURF
       do i=i1,i2
          q(i,km+1) = sign(min(abs(q(i,km+1)), abs(a4(1,i,km))), a4(1,i,km))
       enddo
#endif
    else
       do i=i1,i2
          if ( (q(i,km)-q(i,km-1))*(q(i,km+1)-q(i,km))>0. ) then
               q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) )
               q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) )
          elseif ( iv==0 ) then
               q(i,km) = max(0., q(i,km))
          endif
       enddo
    endif
  ENDIF



  do k=1,km
     do i=i1,i2
        a4(2,i,k) = q(i,k  )
        a4(3,i,k) = q(i,k+1)
     enddo
  enddo

! Top & bot surfaces
! do i=i1,i2
!    if ( a4(2,i, 1)*a4(1,i, 1) <= 0. ) a4(2,i, 1) = 0.
!    if ( a4(1,i,km)*a4(3,i,km) <= 0. ) a4(3,i,km) = 0.
! enddo

!-----------------------------------------------------------
! f(s) = AL + s*[(AR-AL) + A6*(1-s)]         ( 0 <= s  <= 1 )
!-----------------------------------------------------------
! Top 2 and bottom 2 layers always use monotonic mapping
  do k=1,2
     do i=i1,i2
        a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
     enddo
     call cs_limiters(im, a4(1,i1,k), 1)
  enddo

!-------------------------------------
! Huynh's 2nd constraint for interior:
!-------------------------------------
  do k=3,km-2
     do i=i1,i2
! Left  edges
!      a4(2,i,k) = a4(1,i,k) -   &
!                  sign(min(abs(a4(2,i,k)-a4(1,i,k)), abs(gam(i,k))),gam(i,k))
!----
             pmp = a4(1,i,k) - 2.*gam(i,k+1)
             lac = pmp + 1.5*gam(i,k+2)
       a4(2,i,k) = min(max(a4(2,i,k),  min(a4(1,i,k), pmp, lac)),   &
                                       max(a4(1,i,k), pmp, lac) )
! Right edges
!      a4(3,i,k) = a4(1,i,k) +  &
!                  sign(min(abs(a4(3,i,k)-a4(1,i,k)), abs(gam(i,k+1))),gam(i,k+1))
!----
             pmp = a4(1,i,k) + 2.*gam(i,k)
             lac = pmp - 1.5*gam(i,k-1)
       a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp, lac)),    &
                                      max(a4(1,i,k), pmp, lac) )
       a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
     enddo
! Additional constraint to ensure positivity
     if ( iv==0 ) call cs_limiters(im, a4(1,i1,k), 0)
  enddo

  do k=km-1,km
     do i=i1,i2
        a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
     enddo
     call cs_limiters(im, a4(1,i1,k), 1)
  enddo

 end subroutine cs_profile



 subroutine cs_limiters(im, a4, iv)
 integer, intent(in) :: im
 integer, intent(in) :: iv
 real , intent(inout) :: a4(4,im)   ! PPM array
! !LOCAL VARIABLES:
 real  da1, da2, a6da
 real  fmin
 integer i

 if ( iv==0 ) then
! Positive definite constraint
    do i=1,im
      if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then
         fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12
         if( fmin < 0. ) then
             if( a4(1,i)<a4(3,i) .and. a4(1,i)<a4(2,i) ) then
                 a4(3,i) = a4(1,i)
                 a4(2,i) = a4(1,i)
                a4(4,i) = 0.
             elseif( a4(3,i) > a4(2,i) ) then
                 a4(4,i) = 3.*(a4(2,i)-a4(1,i))
                 a4(3,i) = a4(2,i) - a4(4,i)
             else
                 a4(4,i) = 3.*(a4(3,i)-a4(1,i))
                 a4(2,i) = a4(3,i) - a4(4,i)
             endif
         endif
      endif
    enddo
 else
! Standard PPM constraint
    do i=1,im
      if( (a4(1,i)-a4(2,i))*(a4(1,i)-a4(3,i))>=0. ) then
         a4(2,i) = a4(1,i)
         a4(3,i) = a4(1,i)
         a4(4,i) = 0.
      else
         da1  = a4(3,i) - a4(2,i)
         da2  = da1**2
         a6da = a4(4,i)*da1
         if(a6da < -da2) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         elseif(a6da > da2) then
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
      endif
    enddo
 endif
 end subroutine cs_limiters



 subroutine ppm_profile(a4, delp, km, i1, i2, iv, kord)

! !INPUT PARAMETERS:
 integer, intent(in):: iv      ! iv =-1: winds
                               ! iv = 0: positive definite scalars
                               ! iv = 1: others
 integer, intent(in):: i1      ! Starting longitude
 integer, intent(in):: i2      ! Finishing longitude
 integer, intent(in):: km      ! vertical dimension
 integer, intent(in):: kord    ! Order (or more accurately method no.):
                               ! 
 real , intent(in):: delp(i1:i2,km)     ! layer pressure thickness

! !INPUT/OUTPUT PARAMETERS:
 real , intent(inout):: a4(4,i1:i2,km)  ! Interpolated values

! DESCRIPTION:
!
!   Perform the piecewise parabolic reconstruction
! 
! !REVISION HISTORY: 
! S.-J. Lin   revised at GFDL 2007
!-----------------------------------------------------------------------
! local arrays:
      real    dc(i1:i2,km)
      real    h2(i1:i2,km)
      real  delq(i1:i2,km)
      real   df2(i1:i2,km)
      real    d4(i1:i2,km)

! local scalars:
      integer i, k, km1, lmt, it
      real  fac
      real  a1, a2, c1, c2, c3, d1, d2
      real  qm, dq, lac, qmp, pmp

      km1 = km - 1
       it = i2 - i1 + 1

      do k=2,km
         do i=i1,i2
            delq(i,k-1) =   a4(1,i,k) - a4(1,i,k-1)
              d4(i,k  ) = delp(i,k-1) + delp(i,k)
         enddo
      enddo

      do k=2,km1
         do i=i1,i2
                 c1  = (delp(i,k-1)+0.5*delp(i,k))/d4(i,k+1)
                 c2  = (delp(i,k+1)+0.5*delp(i,k))/d4(i,k)
            df2(i,k) = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) /      &
                                    (d4(i,k)+delp(i,k+1))
            dc(i,k) = sign( min(abs(df2(i,k)),              &
                            max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))-a4(1,i,k),  &
                  a4(1,i,k)-min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))), df2(i,k) )
         enddo
      enddo

!-----------------------------------------------------------
! 4th order interpolation of the provisional cell edge value
!-----------------------------------------------------------

      do k=3,km1
         do i=i1,i2
            c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k)
            a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1))
            a2 = d4(i,k+1) / (d4(i,k) + delp(i,k))
            a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(d4(i,k-1)+d4(i,k+1)) *    &
                      ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) -          &
                        delp(i,k-1)*a1*dc(i,k  ) )
         enddo
      enddo

      if(km>8 .and. kord>3) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4)

! Area preserving cubic with 2nd deriv. = 0 at the boundaries
! Top
      do i=i1,i2
         d1 = delp(i,1)
         d2 = delp(i,2)
         qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2)
         dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2)
         c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) )
         c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1)
         a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
! Top edge:
!-------------------------------------------------------
         a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2)
!-------------------------------------------------------
!        a4(2,i,1) = (12./7.)*a4(1,i,1)-(13./14.)*a4(1,i,2)+(3./14.)*a4(1,i,3)
!-------------------------------------------------------
! No over- and undershoot condition
         a4(2,i,2) = max( a4(2,i,2), min(a4(1,i,1), a4(1,i,2)) )
         a4(2,i,2) = min( a4(2,i,2), max(a4(1,i,1), a4(1,i,2)) )
         dc(i,1) =  0.5*(a4(2,i,2) - a4(1,i,1))
      enddo

! Enforce monotonicity of the "slope" within the top layer

      if( iv==0 ) then
         do i=i1,i2
            a4(2,i,1) = max(0., a4(2,i,1))
            a4(2,i,2) = max(0., a4(2,i,2))
         enddo 
      elseif( iv==-1 ) then
         do i=i1,i2
            if ( a4(2,i,1)*a4(1,i,1) <= 0. ) then
                 a4(2,i,1) = 0.
            endif
         enddo
      endif


! Bottom
! Area preserving cubic with 2nd deriv. = 0 at the surface
      do i=i1,i2
         d1 = delp(i,km)
         d2 = delp(i,km1)
         qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2)
         dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2)
         c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1)))
         c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1)
         a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1)
! Bottom edge:
!-----------------------------------------------------
         a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km)
!        dc(i,km) = 0.5*(a4(3,i,km) - a4(1,i,km))
!-----------------------------------------------------
!        a4(3,i,km) = (12./7.)*a4(1,i,km)-(13./14.)*a4(1,i,km-1)+(3./14.)*a4(1,i,km-2)
! No over- and under-shoot condition
         a4(2,i,km) = max( a4(2,i,km), min(a4(1,i,km), a4(1,i,km1)) )
         a4(2,i,km) = min( a4(2,i,km), max(a4(1,i,km), a4(1,i,km1)) )
         dc(i,km) = 0.5*(a4(1,i,km) - a4(2,i,km))
      enddo


! Enforce constraint on the "slope" at the surface

#ifdef BOT_MONO
      do i=i1,i2
         a4(4,i,km) = 0
         if( a4(3,i,km) * a4(1,i,km) <= 0. ) a4(3,i,km) = 0.
         d1 = a4(1,i,km) - a4(2,i,km)
         d2 = a4(3,i,km) - a4(1,i,km)
         if ( d1*d2 < 0. ) then
              a4(2,i,km) = a4(1,i,km)
              a4(3,i,km) = a4(1,i,km)
         else
              dq = sign(min(abs(d1),abs(d2),0.5*abs(delq(i,km-1))), d1)
              a4(2,i,km) = a4(1,i,km) - dq
              a4(3,i,km) = a4(1,i,km) + dq
         endif
      enddo
#else
      if( iv==0 ) then
          do i=i1,i2
             a4(2,i,km) = max(0.,a4(2,i,km))
             a4(3,i,km) = max(0.,a4(3,i,km))
          enddo
      elseif( iv==-1 ) then
          do i=i1,i2
             if ( a4(1,i,km)*a4(3,i,km) <= 0. ) then
                  a4(3,i,km) = 0.
             endif
          enddo
      endif
#endif

   do k=1,km1
      do i=i1,i2
         a4(3,i,k) = a4(2,i,k+1)
      enddo
   enddo

!-----------------------------------------------------------
! f(s) = AL + s*[(AR-AL) + A6*(1-s)]         ( 0 <= s  <= 1 )
!-----------------------------------------------------------
! Top 2 and bottom 2 layers always use monotonic mapping
      do k=1,2
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
         call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 0)
      enddo

      if(kord >= 7) then
!-----------------------
! Huynh's 2nd constraint
!-----------------------
      do k=2,km1
         do i=i1,i2
! Method#1
!           h2(i,k) = delq(i,k) - delq(i,k-1)
! Method#2 - better
            h2(i,k) = 2.*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1))  &
                     / ( delp(i,k)+0.5*(delp(i,k-1)+delp(i,k+1)) )        &
                     * delp(i,k)**2 
! Method#3
!!!            h2(i,k) = dc(i,k+1) - dc(i,k-1)
         enddo
      enddo

      fac = 1.5           ! original quasi-monotone

      do k=3,km-2
        do i=i1,i2
! Right edges
!        qmp   = a4(1,i,k) + 2.0*delq(i,k-1)
!        lac   = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
!
         pmp   = 2.*dc(i,k)
         qmp   = a4(1,i,k) + pmp
         lac   = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k)
         a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), qmp, lac)),    &
                                        max(a4(1,i,k), qmp, lac) )
! Left  edges
!        qmp   = a4(1,i,k) - 2.0*delq(i,k)
!        lac   = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
!
         qmp   = a4(1,i,k) - pmp
         lac   = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k)
         a4(2,i,k) = min(max(a4(2,i,k),  min(a4(1,i,k), qmp, lac)),   &
                     max(a4(1,i,k), qmp, lac))
!-------------
! Recompute A6
!-------------
         a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
        enddo
! Additional constraint to ensure positivity when kord=7
         if (iv == 0 .and. kord >= 6 )                      &
             call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 2)
      enddo

      else

         lmt = kord - 3
         lmt = max(0, lmt)
         if (iv == 0) lmt = min(2, lmt)

         do k=3,km-2
            if( kord /= 4) then
              do i=i1,i2
                 a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
              enddo
            endif
            if(kord/=6) call ppm_limiters(dc(i1,k), a4(1,i1,k), it, lmt)
         enddo
      endif

      do k=km1,km
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
         call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 0)
      enddo

 end subroutine ppm_profile


 subroutine ppm_limiters(dm, a4, itot, lmt)

! !INPUT PARAMETERS:
      real , intent(in):: dm(*)     ! the linear slope
      integer, intent(in) :: itot      ! Total Longitudes
      integer, intent(in) :: lmt       ! 0: Standard PPM constraint
                                       ! 1: Improved full monotonicity constraint (Lin)
                                       ! 2: Positive definite constraint
                                       ! 3: do nothing (return immediately)
! !INPUT/OUTPUT PARAMETERS:
      real , intent(inout) :: a4(4,*)   ! PPM array
                                           ! AA <-- a4(1,i)
                                           ! AL <-- a4(2,i)
                                           ! AR <-- a4(3,i)
                                           ! A6 <-- a4(4,i)
! !LOCAL VARIABLES:
      real  qmp
      real  da1, da2, a6da
      real  fmin
      integer i

! Developer: S.-J. Lin, NASA-GSFC
! Last modified: Apr 24, 2000

      if ( lmt == 3 ) return

      if(lmt == 0) then
! Standard PPM constraint
      do i=1,itot
      if(dm(i) == 0.) then
         a4(2,i) = a4(1,i)
         a4(3,i) = a4(1,i)
         a4(4,i) = 0.
      else
         da1  = a4(3,i) - a4(2,i)
         da2  = da1**2
         a6da = a4(4,i)*da1
         if(a6da < -da2) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         elseif(a6da > da2) then
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
      endif
      enddo

      elseif (lmt == 1) then

! Improved full monotonicity constraint (Lin 2004)
! Note: no need to provide first guess of A6 <-- a4(4,i)
      do i=1, itot
           qmp = 2.*dm(i)
         a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp)
         a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp)
         a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) )
      enddo

      elseif (lmt == 2) then

! Positive definite constraint
      do i=1,itot
      if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then
      fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12
         if( fmin < 0. ) then
         if(a4(1,i)<a4(3,i) .and. a4(1,i)<a4(2,i)) then
            a4(3,i) = a4(1,i)
            a4(2,i) = a4(1,i)
            a4(4,i) = 0.
         elseif(a4(3,i) > a4(2,i)) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         else
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
         endif
      endif
      enddo

      endif

 end subroutine ppm_limiters



 subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4)
 integer, intent(in) :: km, i1, i2
   real , intent(in) ::  dp(i1:i2,km)       ! grid size
   real , intent(in) ::  dq(i1:i2,km)       ! backward diff of q
   real , intent(in) ::  d4(i1:i2,km)       ! backward sum:  dp(k)+ dp(k-1) 
   real , intent(in) :: df2(i1:i2,km)       ! first guess mismatch
   real , intent(in) ::  dm(i1:i2,km)       ! monotonic mismatch
! !INPUT/OUTPUT PARAMETERS:
      real , intent(inout) ::  a4(4,i1:i2,km)  ! first guess/steepened
! !LOCAL VARIABLES:
      integer i, k
      real  alfa(i1:i2,km)
      real     f(i1:i2,km)
      real   rat(i1:i2,km)
      real   dg2

! Compute ratio of dq/dp
      do k=2,km
         do i=i1,i2
            rat(i,k) = dq(i,k-1) / d4(i,k)
         enddo
      enddo

! Compute F
      do k=2,km-1
         do i=i1,i2
            f(i,k) =   (rat(i,k+1) - rat(i,k))                          &
                     / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) )
         enddo
      enddo

      do k=3,km-2
         do i=i1,i2
         if(f(i,k+1)*f(i,k-1)<0. .and. df2(i,k)/=0.) then
            dg2 = (f(i,k+1)-f(i,k-1))*((dp(i,k+1)-dp(i,k-1))**2          &
                   + d4(i,k)*d4(i,k+1) )
            alfa(i,k) = max(0., min(0.5, -0.1875*dg2/df2(i,k)))
         else
            alfa(i,k) = 0.
         endif
         enddo
      enddo

      do k=4,km-2
         do i=i1,i2
            a4(2,i,k) = (1.-alfa(i,k-1)-alfa(i,k)) * a4(2,i,k) +         &
                        alfa(i,k-1)*(a4(1,i,k)-dm(i,k))    +             &
                        alfa(i,k)*(a4(1,i,k-1)+dm(i,k-1))
         enddo
      enddo

 end subroutine steepz



 subroutine rst_remap(km, kn, is,ie,js,je, isd,ied,jsd,jed, nq,  &
                      delp_r, u_r, v_r, w_r, delz_r, pt_r, q_r,      &
                      delp,   u,   v,   w,   delz,   pt,   q,        &
                      ak_r, bk_r, ak, bk, hydrostatic)
!------------------------------------
! Assuming hybrid sigma-P coordinate:
!------------------------------------
! !INPUT PARAMETERS:
  integer, intent(in):: km                    ! Restart z-dimension
  integer, intent(in):: kn                    ! Run time dimension
  integer, intent(in):: nq                    ! number of tracers (including h2o)
  integer, intent(in):: is,ie,isd,ied         ! starting & ending X-Dir index
  integer, intent(in):: js,je,jsd,jed         ! starting & ending Y-Dir index
  logical, intent(in):: hydrostatic
  real, intent(in) :: ak_r(km+1)
  real, intent(in) :: bk_r(km+1)
  real, intent(in) :: ak(kn+1)
  real, intent(in) :: bk(kn+1)
  real, intent(in):: delp_r(is:ie,js:je,km) ! pressure thickness
  real, intent(in)::   u_r(is:ie,  js:je+1,km)   ! u-wind (m/s)
  real, intent(in)::   v_r(is:ie+1,js:je  ,km)   ! v-wind (m/s)
  real, intent(inout)::  pt_r(is:ie,js:je,km)
  real, intent(in)::   w_r(is:ie,js:je,km)
  real, intent(in)::   q_r(is:ie,js:je,km,*)
  real, intent(inout)::delz_r(is:ie,js:je,km)
! Output:
  real, intent(out):: delp(isd:ied,jsd:jed,kn) ! pressure thickness
  real, intent(out)::  u(isd:ied  ,jsd:jed+1,kn)   ! u-wind (m/s)
  real, intent(out)::  v(isd:ied+1,jsd:jed  ,kn)   ! v-wind (m/s)
  real, intent(out)::  w(isd:ied  ,jsd:jed  ,kn)   ! vertical velocity (m/s)
  real, intent(out):: pt(isd:ied  ,jsd:jed  ,kn)   ! temperature
  real, intent(out):: q(isd:ied,jsd:jed,kn,*)
  real, intent(out):: delz(is:ie,js:je,kn)   ! delta-height (m)
!-----------------------------------------------------------------------
  real r_vir
  real ps(isd:ied,jsd:jed)  ! surface pressure
  real  pe1(is:ie,km+1)
  real  pe2(is:ie,kn+1)
  real  pv1(is:ie+1,km+1)
  real  pv2(is:ie+1,kn+1)

  integer i,j,k , iq
  integer, parameter:: kord=4

  r_vir = rvgas/rdgas - 1.

  do j=js,je
     do i=is,ie
        ps(i,j) = ak_r(1)
     enddo
  enddo

  do k=1,km
     do j=js,je
        do i=is,ie
           ps(i,j) = ps(i,j) + delp_r(i,j,k)
        enddo
     enddo
  enddo

  call mpp_update_domains(ps, domain, complete=.true.)

! Compute virtual Temp
  do k=1,km
     do j=js,je
        do i=is,ie
           pt_r(i,j,k) = pt_r(i,j,k) * (1.+r_vir*q_r(i,j,k,1))
        enddo
     enddo
  enddo

  do 1000 j=js,je+1
!------
! map u
!------
     do k=1,km+1
        do i=is,ie
           pe1(i,k) = ak_r(k) + 0.5*bk_r(k)*(ps(i,j-1)+ps(i,j))
        enddo
     enddo

     do k=1,kn+1
        do i=is,ie
           pe2(i,k) = ak(k) + 0.5*bk(k)*(ps(i,j-1)+ps(i,j))
        enddo
     enddo

     call remap_2d(km, pe1, u_r(is:ie,j:j,1:km),       &
                   kn, pe2,   u(is:ie,j:j,1:kn),       &
                   is, ie, -1, kord)

  if ( j /= (je+1) )  then 

!---------------
! Hybrid sigma-p
!---------------
     do k=1,km+1
        do i=is,ie
           pe1(i,k) = ak_r(k) + bk_r(k)*ps(i,j)
        enddo
     enddo

     do k=1,kn+1
        do i=is,ie
           pe2(i,k) =   ak(k) + bk(k)*ps(i,j)
        enddo
     enddo

!-------------
! Compute delp
!-------------
      do k=1,kn
         do i=is,ie
            delp(i,j,k) = pe2(i,k+1) - pe2(i,k)
         enddo
      enddo

!----------------
! Map constituents
!----------------
      if( nq /= 0 ) then
          do iq=1,nq
             call remap_2d(km, pe1, q_r(is:ie,j:j,1:km,iq:iq),  &
                           kn, pe2,   q(is:ie,j:j,1:kn,iq:iq),  &
                           is, ie, 0, kord)
          enddo
      endif

      if ( .not. hydrostatic ) then
! Remap vertical wind:
         call remap_2d(km, pe1, w_r(is:ie,j:j,1:km),       &
                       kn, pe2,   w(is:ie,j:j,1:kn),       &
                       is, ie, -1, kord)
! Remap delz for hybrid sigma-p coordinate
         do k=1,km
            do i=is,ie
               delz_r(i,j,k) = -delz_r(i,j,k)/delp_r(i,j,k) ! ="specific volume"/grav
            enddo
         enddo
         call remap_2d(km, pe1, delz_r(is:ie,j:j,1:km),       &
                       kn, pe2,   delz(is:ie,j:j,1:kn),       &
                       is, ie, 1, kord)
         do k=1,kn
            do i=is,ie
               delz(i,j,k) = -delz(i,j,k)*delp(i,j,k)
            enddo
         enddo
      endif

! Geopotential conserving remap of virtual temperature:
       do k=1,km+1
          do i=is,ie
             pe1(i,k) = log(pe1(i,k))
          enddo
       enddo
       do k=1,kn+1
          do i=is,ie
             pe2(i,k) = log(pe2(i,k))
          enddo
       enddo

       call remap_2d(km, pe1, pt_r(is:ie,j:j,1:km),       &
                     kn, pe2,   pt(is:ie,j:j,1:kn),       &
                     is, ie, 1, kord)
!------
! map v
!------
       do k=1,km+1
          do i=is,ie+1
             pv1(i,k) = ak_r(k) + 0.5*bk_r(k)*(ps(i-1,j)+ps(i,j))
          enddo
       enddo
       do k=1,kn+1
          do i=is,ie+1
             pv2(i,k) = ak(k) + 0.5*bk(k)*(ps(i-1,j)+ps(i,j))
          enddo
       enddo

       call remap_2d(km, pv1, v_r(is:ie+1,j:j,1:km),       &
                     kn, pv2,   v(is:ie+1,j:j,1:kn),       &
                     is, ie+1, -1, kord)

  endif !(j < je+1)
1000  continue

  do k=1,kn
     do j=js,je
        do i=is,ie
           pt(i,j,k) = pt(i,j,k) / (1.+r_vir*q(i,j,k,1))
        enddo
     enddo   
  enddo

 end subroutine rst_remap



 subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)

! IV = 0: constituents
! IV = 1: potential temp
! IV =-1: winds
 
! Mass flux preserving mapping: q1(im,km) -> q2(im,kn)
 
! pe1: pressure at layer edges (from model top to bottom surface)
!      in the original vertical coordinate
! pe2: pressure at layer edges (from model top to bottom surface)
!      in the new vertical coordinate

 integer, intent(in):: i1, i2, km, kn, kord, iv
 real, intent(in ):: pe1(i1:i2,km+1), pe2(i1:i2,kn+1)
 real, intent(in )::  q1(i1:i2,km)
 real, intent(out)::  q2(i1:i2,kn)
! local
      real dp1(i1:i2,km)
      real a4(4,i1:i2,km)
      integer i, k, l
      integer k0, k1
      real pl, pr, tt, delp, qsum, dpsum, esl

      do k=1,km
         do i=i1,i2
             dp1(i,k) = pe1(i,k+1) - pe1(i,k)
            a4(1,i,k) = q1(i,k)
         enddo
      enddo

      if ( kord >7 ) then
           call  cs_profile( a4, dp1, km, i1, i2, iv )
      else
           call ppm_profile( a4, dp1, km, i1, i2, iv, kord )
      endif

!------------------------------------
! Lowest layer: constant distribution
!------------------------------------
      do i=i1,i2
         a4(2,i,km) = q1(i,km)
         a4(3,i,km) = q1(i,km)
         a4(4,i,km) = 0.
      enddo

      do 5555 i=i1,i2
         k0 = 1
      do 555 k=1,kn

         if(pe2(i,k+1) .le. pe1(i,1)) then
! Entire grid above old ptop
            q2(i,k) = a4(2,i,1)
         elseif(pe2(i,k) .ge. pe1(i,km+1)) then
! Entire grid below old ps
            q2(i,k) = a4(3,i,km)
         elseif(pe2(i,k  ) .lt. pe1(i,1) .and.   &
                pe2(i,k+1) .gt. pe1(i,1))  then
! Part of the grid above ptop
            q2(i,k) = a4(1,i,1)
         else

         do 45 L=k0,km
! locate the top edge at pe2(i,k)
         if( pe2(i,k) .ge. pe1(i,L) .and.        &
             pe2(i,k) .le. pe1(i,L+1)    ) then
             k0 = L
             PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L)
             if(pe2(i,k+1) .le. pe1(i,L+1)) then

! entire new grid is within the original grid
               PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L)
               TT = r3*(PR*(PR+PL)+PL**2)
               q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L)  &
                       - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT
              goto 555
             else
! Fractional area...
              delp = pe1(i,L+1) - pe2(i,k)
              TT   = r3*(1.+PL*(1.+PL))
              qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+            &
                     a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT)
              dpsum = delp
              k1 = L + 1
             goto 111
             endif
         endif
45       continue

111      continue
         do 55 L=k1,km
         if( pe2(i,k+1) .gt. pe1(i,L+1) ) then

! Whole layer..

            qsum  =  qsum + dp1(i,L)*q1(i,L)
            dpsum = dpsum + dp1(i,L)
         else
           delp = pe2(i,k+1)-pe1(i,L)
           esl  = delp / dp1(i,L)
           qsum = qsum + delp * (a4(2,i,L)+0.5*esl*            &
                 (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) )
          dpsum = dpsum + delp
           k0 = L
           goto 123
         endif
55       continue
        delp = pe2(i,k+1) - pe1(i,km+1)
        if(delp > 0.) then
! Extended below old ps
           qsum = qsum + delp * a4(3,i,km)
          dpsum = dpsum + delp
        endif
123     q2(i,k) = qsum / dpsum
      endif
555   continue
5555  continue

 end subroutine mappm


! subroutine to read in variable for cs_profile
 subroutine mapz_init
   character(len=9) :: filename = 'input.nml'
   integer :: f_unit, log_unit, ios

   if (mapz_is_initialized) return

!openmp statements needed to ensure only one thread
!executes this section of code
!this subroutine is unnecessary in S-release and will be removed
#ifdef INTERNAL_FILE_NML
   read (input_nml_file,fv_mapz_nml,iostat=ios)
#else
   f_unit = get_unit()
   open (f_unit,file=filename)
 ! Read fv_mapz namelist
   read (f_unit,fv_mapz_nml,iostat=ios)
   close (f_unit)
#endif
   if (ios .gt. 0) then
     if (mpp_pe() .eq. mpp_root_pe()) &
       call mpp_error(FATAL,'ERROR: reading fv_mapz_nml in '//trim(filename)//'')
   endif
   log_unit = stdlog()
   write(log_unit, nml=fv_mapz_nml)

   mapz_is_initialized = .true.

 end subroutine mapz_init

end module fv_mapz_mod


module fv_sg_mod

!-----------------------------------------------------------------------
! FV sub-grid mixing
!-----------------------------------------------------------------------
use constants_mod, only: rdgas, rvgas, cp_air, hlv, hlf, kappa, grav
use fv_mp_mod,     only: gid

implicit none
private

integer:: irad = 0
public  fv_dry_conv, fv_sg_conv, qsmith, neg_adj3
public  fv_olr, fv_abs_sw, irad

real, allocatable:: fv_olr(:,:), fv_abs_sw(:,:)

  real, parameter:: esl = 0.621971831
  real, parameter:: tice = 273.16
  real, parameter:: zvir =  rvgas/rdgas - 1.     ! = 0.607789855
  real, allocatable:: table(:),des(:)

contains

 subroutine fv_dry_conv( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt,    &
                         tau, delp, pe, peln, pkz, ta, qa, ua, va,  &
                         hydrostatic, w, delz, u_dt, v_dt, t_dt, q_dt )
! Dry convective adjustment-mixing
!-------------------------------------------
      integer, intent(in):: is, ie, js, je, km, nq
      integer, intent(in):: isd, ied, jsd, jed
      integer, intent(in):: tau         ! Relaxation time scale
      real, intent(in):: dt             ! model time step
      real, intent(in)::   pe(is-1:ie+1,km+1,js-1:je+1) 
      real, intent(in):: peln(is  :ie,  km+1,js  :je)
      real, intent(in):: delp(isd:ied,jsd:jed,km)      ! Delta p at each model level
      real, intent(in)::  pkz(is:ie,js:je,km)      ! Delta p at each model level
      real, intent(in):: delz(is:ie,js:je,km)      ! Delta p at each model level
      logical, intent(in)::  hydrostatic
! 
      real, intent(inout):: ua(isd:ied,jsd:jed,km)
      real, intent(inout):: va(isd:ied,jsd:jed,km)
      real, intent(inout)::  w(isd:ied,jsd:jed,km)      ! Delta p at each model level
      real, intent(inout):: ta(isd:ied,jsd:jed,km)      ! Temperature
      real, intent(inout):: qa(isd:ied,jsd:jed,km,nq)   ! Specific humidity & tracers
! Output:
      real, intent(out):: u_dt(isd:ied,jsd:jed,km) 
      real, intent(out):: v_dt(isd:ied,jsd:jed,km) 
      real, intent(out):: t_dt(is:ie,js:je,km) 
      real, intent(out):: q_dt(is:ie,js:je,km,nq) 
!---------------------------Local variables-----------------------------
      real, dimension(is:ie,km):: u0, v0, w0, t0, hd, te, gz, tvm, pm
      real q0(is:ie,km,nq) 
      real gzh(is:ie)
      real ri, pt1, pt2, ratio, tv, cv
      real qmix, h0, mc, fra, rk, rz, rcv, rdt
      real qs1, qs2, lf, dh, dhs
      integer mcond
      integer i, j, k, kk, n, m, iq
      real, parameter:: ustar2 = 1.E-8

        rz = rvgas - rdgas          ! rz = zvir * rdgas
        rk = cp_air/rdgas + 1.
        cv = cp_air - rdgas
       rcv = 1./cv

      rdt = 1./ dt

!------------------------------------------------------------------------
! The nonhydrostatic pressure changes if there is heating (under constant
! volume and mass is locally conserved).
!------------------------------------------------------------------------
   mcond = 1
   m = 3
   fra = dt/real(tau)

  do 1000 j=js,je       ! this main loop can be OpneMPed in j

    do iq=1,nq
       do k=mcond,km
          do i=is,ie
             q0(i,k,iq) = qa(i,j,k,iq)
          enddo
       enddo
    enddo

    do k=mcond,km
       do i=is,ie
          t0(i,k) = ta(i,j,k)
          u0(i,k) = ua(i,j,k)
          v0(i,k) = va(i,j,k)
          pm(i,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
       enddo
    enddo

    do i=is,ie
       gzh(i) = 0.
    enddo

    if( hydrostatic ) then
       do k=km, mcond,-1
          do i=is,ie
           tvm(i,k) = t0(i,k)*(1.+zvir*q0(i,k,1))
                tv  = rdgas*tvm(i,k)
            gz(i,k) = gzh(i) + tv*(1.-pe(i,k,j)/pm(i,k))
            hd(i,k) = cp_air*tvm(i,k)+gz(i,k)+0.5*(u0(i,k)**2+v0(i,k)**2)
             gzh(i) = gzh(i) + tv*(peln(i,k+1,j)-peln(i,k,j))
          enddo
       enddo
    else
       do k=km,mcond,-1
          do i=is,ie
             w0(i,k) = w(i,j,k)
             gz(i,k) = gzh(i)  - 0.5*grav*delz(i,j,k)
                 tv  = gz(i,k) + 0.5*(u0(i,k)**2+v0(i,k)**2+w0(i,k)**2)
             hd(i,k) = cp_air*t0(i,k) + tv
             te(i,k) =     cv*t0(i,k) + tv
              gzh(i) = gzh(i) - grav*delz(i,j,k)
          enddo
       enddo
    endif

   do n=1,m

      ratio = real(n)/real(m)

      do i=is,ie
         gzh(i) = 0.
      enddo

      do k=km,mcond+1,-1

         do i=is,ie
! Richardson number = g*delz * theta / ( del_theta * (del_u**2 + del_v**2) )
            pt1 = t0(i,k-1)/pkz(i,j,k-1)
            pt2 = t0(i,k  )/pkz(i,j,k  )
            ri = (gz(i,k-1)-gz(i,k))*(pt1-pt2)/( 0.5*(pt1+pt2)*        &
                ((u0(i,k-1)-u0(i,k))**2+(v0(i,k-1)-v0(i,k))**2+ustar2) )
! Dry convective adjustment for K-H instability:
! Compute equivalent mass flux: mc
            if ( ri < 0.25 ) then
                 mc = (1.-4.*max(0.0,ri)) ** 2
                 mc = ratio*mc*delp(i,j,k-1)*delp(i,j,k)/(delp(i,j,k-1)+delp(i,j,k))
                 do iq=1,nq
                    h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                    q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                    q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                 enddo
! u:
                 h0 = mc*(u0(i,k)-u0(i,k-1))
                 u0(i,k-1) = u0(i,k-1) + h0/delp(i,j,k-1)
                 u0(i,k  ) = u0(i,k  ) - h0/delp(i,j,k  )
! v:
                 h0 = mc*(v0(i,k)-v0(i,k-1))
                 v0(i,k-1) = v0(i,k-1) + h0/delp(i,j,k-1)
                 v0(i,k  ) = v0(i,k  ) - h0/delp(i,j,k  )
              if ( hydrostatic ) then
                 h0 = mc*(hd(i,k)-hd(i,k-1))
                 hd(i,k-1) = hd(i,k-1) + h0/delp(i,j,k-1)
                 hd(i,k  ) = hd(i,k  ) - h0/delp(i,j,k  )
              else
! Total energy
                        h0 = mc*(hd(i,k)-hd(i,k-1))
                 te(i,k-1) = te(i,k-1) + h0/delp(i,j,k-1)
                 te(i,k  ) = te(i,k  ) - h0/delp(i,j,k  )
! w:
                        h0 = mc*(w0(i,k)-w0(i,k-1))
                 w0(i,k-1) = w0(i,k-1) + h0/delp(i,j,k-1)
                 w0(i,k  ) = w0(i,k  ) - h0/delp(i,j,k  )
              endif
            endif
         enddo

!-------------- 
! Retrive Temp:
!--------------
       if ( hydrostatic ) then
         kk = k
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ( rk - pe(i,kk,j)/pm(i,kk) )
              gzh(i) = gzh(i) + t0(i,kk)*(peln(i,kk+1,j)-peln(i,kk,j))
            t0(i,kk) = t0(i,kk) / ( rdgas + rz*q0(i,kk,1) )
         enddo
         kk = k-1
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ((rk-pe(i,kk,j)/pm(i,kk))*(rdgas+rz*q0(i,kk,1)))
         enddo
       else
! Non-hydrostatic under constant volume heating/cooling
         do kk=k-1,k
            do i=is,ie
                     tv = gz(i,kk) + 0.5*(u0(i,kk)**2+v0(i,kk)**2+w0(i,kk)**2)
               t0(i,kk) = rcv*(te(i,kk)- tv)
               hd(i,kk) = cp_air*t0(i,kk) + tv
            enddo
         enddo
       endif
      enddo   ! k-loop
   enddo       ! n-loop


!--------------------
   if ( fra < 1. ) then
      do k=mcond,km
         do i=is,ie
            t0(i,k) = ta(i,j,k) + (t0(i,k) - ta(i,j,k))*fra
            u0(i,k) = ua(i,j,k) + (u0(i,k) - ua(i,j,k))*fra
            v0(i,k) = va(i,j,k) + (v0(i,k) - va(i,j,k))*fra
         enddo
      enddo

      if ( .not. hydrostatic ) then
         do k=mcond,km
            do i=is,ie
               w0(i,k) = w(i,j,k) + (w0(i,k) - w(i,j,k))*fra
            enddo
         enddo
      endif

      do iq=1,nq
         do k=mcond,km
            do i=is,ie
               q0(i,k,iq) = qa(i,j,k,iq) + (q0(i,k,iq) - qa(i,j,k,iq))*fra
            enddo
         enddo
      enddo
   endif
!--------------------

   if ( mcond/=1 ) then
   do k=1,mcond-1
      do i=is,ie
         u_dt(i,j,k) = 0.
         v_dt(i,j,k) = 0.
         t_dt(i,j,k) = 0.
      enddo
      do iq=1,nq
         do i=is,ie
            q_dt(i,j,k,iq) = 0.
         enddo
      enddo
   enddo
   endif

   do k=mcond,km
      do i=is,ie
         u_dt(i,j,k) = rdt*(u0(i,k) - ua(i,j,k))
         v_dt(i,j,k) = rdt*(v0(i,k) - va(i,j,k))
           ta(i,j,k) = t0(i,k)   ! *** temperature updated ***
         t_dt(i,j,k) = 0.
      enddo
   enddo

   do iq=1,nq
      do k=mcond,km
         do i=is,ie
            q_dt(i,j,k,iq) = rdt*(q0(i,k,iq)-qa(i,j,k,iq))
         enddo
      enddo
   enddo

   if ( .not. hydrostatic ) then
      do k=mcond,km
         do i=is,ie
            w(i,j,k) = w0(i,k)   ! w updated
         enddo
      enddo
   endif

1000 continue


 end subroutine fv_dry_conv


 subroutine fv_sg_conv( isd, ied, jsd, jed, is, ie, js, je, km,    &
                        nq, dt, tau, delp, pe, peln, pkz, ta, qa,  &
                        ua, va, hydrostatic, w, delz, u_dt, v_dt, t_dt, q_dt )
! Non-precipitating sub-grid scale convective adjustment-mixing
!-------------------------------------------
      integer, intent(in):: is, ie, js, je, km, nq
      integer, intent(in):: isd, ied, jsd, jed
      integer, intent(in):: tau         ! Relaxation time scale
      real, intent(in):: dt             ! model time step
      real, intent(in)::   pe(is-1:ie+1,km+1,js-1:je+1) 
      real, intent(in):: peln(is  :ie,  km+1,js  :je)
      real, intent(in):: delp(isd:ied,jsd:jed,km)      ! Delta p at each model level
      real, intent(in)::  pkz(is:ie,js:je,km)      ! Delta p at each model level
      real, intent(in):: delz(is:ie,js:je,km)      ! Delta p at each model level
      logical, intent(in)::  hydrostatic
! 
      real, intent(inout):: ua(isd:ied,jsd:jed,km)
      real, intent(inout):: va(isd:ied,jsd:jed,km)
      real, intent(inout)::  w(isd:ied,jsd:jed,km)      ! Delta p at each model level
      real, intent(inout):: ta(isd:ied,jsd:jed,km)      ! Temperature
      real, intent(inout):: qa(isd:ied,jsd:jed,km,nq)   ! Specific humidity & tracers
! Output:
      real, intent(out):: u_dt(isd:ied,jsd:jed,km) 
      real, intent(out):: v_dt(isd:ied,jsd:jed,km) 
      real, intent(out):: t_dt(is:ie,js:je,km) 
      real, intent(out):: q_dt(is:ie,js:je,km,nq) 
!---------------------------Local variables-----------------------------
      real, dimension(is:ie,km):: u0, v0, w0, t0, hd, te, gz, tvm, pm
      real q0(is:ie,km,nq) 
      real gzh(is:ie)
      real ri, pt1, pt2, ratio, tv, cv
      real qmix, h0, mc, fra, rk, rz, rcv, rdt
      real qs1, qs2, lf, dh, dhs
      integer mcond
      integer i, j, k, kk, n, m, iq
      real, parameter:: ustar2 = 1.E-8
      real, parameter:: p_crt = 100.E2
      real, parameter:: dh_min = 0.1

        rz = rvgas - rdgas          ! rz = zvir * rdgas
        rk = cp_air/rdgas + 1.
        cv = cp_air - rdgas
       rcv = 1./cv

      rdt = 1./ dt

!------------------------------------------------------------------------
! The nonhydrostatic pressure changes if there is heating (under constant
! volume and mass is locally conserved).
!------------------------------------------------------------------------
   mcond = 1
   m = 4
   fra = dt/real(tau)

  do 1000 j=js,je       ! this main loop can be OpneMPed in j

    do iq=1,nq
       do k=mcond,km
          do i=is,ie
             q0(i,k,iq) = qa(i,j,k,iq)
          enddo
       enddo
    enddo

    do k=mcond,km
       do i=is,ie
          t0(i,k) = ta(i,j,k)
          u0(i,k) = ua(i,j,k)
          v0(i,k) = va(i,j,k)
          pm(i,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
       enddo
    enddo

    do i=is,ie
       gzh(i) = 0.
    enddo

    if( hydrostatic ) then
       do k=km, mcond,-1
          do i=is,ie
           tvm(i,k) = t0(i,k)*(1.+zvir*q0(i,k,1))
                tv  = rdgas*tvm(i,k)
            gz(i,k) = gzh(i) + tv*(1.-pe(i,k,j)/pm(i,k))
            hd(i,k) = cp_air*tvm(i,k)+gz(i,k)+0.5*(u0(i,k)**2+v0(i,k)**2)
             gzh(i) = gzh(i) + tv*(peln(i,k+1,j)-peln(i,k,j))
          enddo
       enddo
    else
       do k=km,mcond,-1
          do i=is,ie
             w0(i,k) = w(i,j,k)
             gz(i,k) = gzh(i)  - 0.5*grav*delz(i,j,k)
                 tv  = gz(i,k) + 0.5*(u0(i,k)**2+v0(i,k)**2+w0(i,k)**2)
             hd(i,k) = cp_air*t0(i,k) + tv
             te(i,k) =     cv*t0(i,k) + tv
              gzh(i) = gzh(i) - grav*delz(i,j,k)
          enddo
       enddo
    endif

   do n=1,m

      ratio = real(n)/real(m)

      do i=is,ie
         gzh(i) = 0.
      enddo

      do k=km,mcond+1,-1

         do i=is,ie
! Richardson number = g*delz * theta / ( del_theta * (del_u**2 + del_v**2) )
            pt1 = t0(i,k-1)/pkz(i,j,k-1)
            pt2 = t0(i,k  )/pkz(i,j,k  )
            ri = (gz(i,k-1)-gz(i,k))*(pt1-pt2)/( 0.5*(pt1+pt2)*        &
                ((u0(i,k-1)-u0(i,k))**2+(v0(i,k-1)-v0(i,k))**2+ustar2) )
! Dry convective adjustment for K-H instability:
! Compute equivalent mass flux: mc
            if ( ri < 0.25 ) then
                 mc = (1.-4.*max(0.0,ri)) ** 2
                 mc = ratio*mc*delp(i,j,k-1)*delp(i,j,k)/(delp(i,j,k-1)+delp(i,j,k))
                 do iq=1,nq
                    h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                    q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                    q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                 enddo
! u:
                 h0 = mc*(u0(i,k)-u0(i,k-1))
                 u0(i,k-1) = u0(i,k-1) + h0/delp(i,j,k-1)
                 u0(i,k  ) = u0(i,k  ) - h0/delp(i,j,k  )
! v:
                 h0 = mc*(v0(i,k)-v0(i,k-1))
                 v0(i,k-1) = v0(i,k-1) + h0/delp(i,j,k-1)
                 v0(i,k  ) = v0(i,k  ) - h0/delp(i,j,k  )
              if ( hydrostatic ) then
                 h0 = mc*(hd(i,k)-hd(i,k-1))
                 hd(i,k-1) = hd(i,k-1) + h0/delp(i,j,k-1)
                 hd(i,k  ) = hd(i,k  ) - h0/delp(i,j,k  )
              else
! Total energy
                        h0 = mc*(hd(i,k)-hd(i,k-1))
                 te(i,k-1) = te(i,k-1) + h0/delp(i,j,k-1)
                 te(i,k  ) = te(i,k  ) - h0/delp(i,j,k  )
! w:
                        h0 = mc*(w0(i,k)-w0(i,k-1))
                 w0(i,k-1) = w0(i,k-1) + h0/delp(i,j,k-1)
                 w0(i,k  ) = w0(i,k  ) - h0/delp(i,j,k  )
              endif
            endif
         enddo

!-------------- 
! Retrive Temp:
!--------------
       if ( hydrostatic ) then
         kk = k
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ( rk - pe(i,kk,j)/pm(i,kk) )
              gzh(i) = gzh(i) + t0(i,kk)*(peln(i,kk+1,j)-peln(i,kk,j))
            t0(i,kk) = t0(i,kk) / ( rdgas + rz*q0(i,kk,1) )
         enddo
         kk = k-1
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ((rk-pe(i,kk,j)/pm(i,kk))*(rdgas+rz*q0(i,kk,1)))
         enddo
       else
! Non-hydrostatic under constant volume heating/cooling
         do kk=k-1,k
            do i=is,ie
                     tv = gz(i,kk) + 0.5*(u0(i,kk)**2+v0(i,kk)**2+w0(i,kk)**2)
               t0(i,kk) = rcv*(te(i,kk)- tv)
               hd(i,kk) = cp_air*t0(i,kk) + tv
            enddo
         enddo
       endif
      enddo   ! k-loop
   enddo       ! n-loop


!--------------
! Moist mixing:
!--------------

    if( .not. allocated(table) ) then
       call  qsmith_init
    endif

    do i=is,ie
       gzh(i) = 0.
    enddo

    if( hydrostatic ) then
       do k=km, mcond,-1
          do i=is,ie
           tvm(i,k) = t0(i,k)*(1.+zvir*q0(i,k,1))
                tv  = rdgas*tvm(i,k)
            gz(i,k) = gzh(i) + tv*(1.-pe(i,k,j)/pm(i,k))
            hd(i,k) = cp_air*tvm(i,k)+gz(i,k)+0.5*(u0(i,k)**2+v0(i,k)**2)
             gzh(i) = gzh(i) + tv*(peln(i,k+1,j)-peln(i,k,j))
          enddo
       enddo
    else
       do k=km,mcond,-1
          do i=is,ie
             gz(i,k) = gzh(i)  - 0.5*grav*delz(i,j,k)
                 tv  = gz(i,k) + 0.5*(u0(i,k)**2+v0(i,k)**2+w0(i,k)**2)
             hd(i,k) = cp_air*t0(i,k) + tv
             te(i,k) =     cv*t0(i,k) + tv
              gzh(i) = gzh(i) - grav*delz(i,j,k)
          enddo
       enddo
    endif

   do n=1,m
      ratio = 0.5*real(n)/real(m)

      do i=is,ie
         gzh(i) = 0.
      enddo

      do k=km,mcond+1,-1
         do i=is,ie
            if ( pm(i,k) > p_crt ) then
               qs1 = qs1d(t0(i,k-1), pm(i,k-1), q0(i,k-1,1))
!              qs2 = qs1d(t0(i,k  ), pm(i,k  ), q0(i,k  ,1))
!           if ( q0(i,k-1,1)>qs1 .and. q0(i,k,1)>qs2 ) then
               lf = hlv + hlf*min(1., max(0., (tice-t0(i,k-1))/30.))
              dh  = hd(i,k) - hd(i,k-1)
              dhs = dh + lf*(q0(i,k,1)-qs1        )
              dh  = dh + lf*(q0(i,k,1)-q0(i,k-1,1))

              if ( dh>dh_min .and. dhs>dh_min ) then   ! layer above is also saturated
                   mc = delp(i,j,k)  *     &
                        min( ratio*dhs/dh, delp(i,j,k-1)/(delp(i,j,k-1)+delp(i,j,k)) )
! Perform local mixing of all advected tracers:
                   do iq=1,nq
                                h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                      q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                      q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                   enddo
                          h0 = mc*(u0(i,k)-u0(i,k-1))
                   u0(i,k-1) = u0(i,k-1) + h0/delp(i,j,k-1)
                   u0(i,k  ) = u0(i,k  ) - h0/delp(i,j,k  )
                          h0 = mc*(v0(i,k)-v0(i,k-1))
                   v0(i,k-1) = v0(i,k-1) + h0/delp(i,j,k-1)
                   v0(i,k  ) = v0(i,k  ) - h0/delp(i,j,k  )
              if ( hydrostatic ) then
                          h0 = mc*(hd(i,k)-hd(i,k-1))
                   hd(i,k-1) = hd(i,k-1) + h0/delp(i,j,k-1)
                   hd(i,k  ) = hd(i,k  ) - h0/delp(i,j,k  )
              else
                          h0 = mc*(hd(i,k)-hd(i,k-1))
                   te(i,k-1) = te(i,k-1) + h0/delp(i,j,k-1)
                   te(i,k  ) = te(i,k  ) - h0/delp(i,j,k  )
                          h0 = mc*(w0(i,k)-w0(i,k-1))
                   w0(i,k-1) = w0(i,k-1) + h0/delp(i,j,k-1)
                   w0(i,k  ) = w0(i,k  ) - h0/delp(i,j,k  )
              endif
              endif  ! dh check
!           endif    ! qs check
            endif    ! p_crt check
         enddo

!-------------- 
! Retrive Temp:
!--------------
       if ( hydrostatic ) then
         kk = k
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ( rk - pe(i,kk,j)/pm(i,kk) )
              gzh(i) = gzh(i) + t0(i,kk)*(peln(i,kk+1,j)-peln(i,kk,j))
            t0(i,kk) = t0(i,kk) / ( rdgas + rz*q0(i,kk,1) )
         enddo
         kk = k-1
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ((rk-pe(i,kk,j)/pm(i,kk))*(rdgas+rz*q0(i,kk,1)))
         enddo
       else
! Non-hydrostatic under constant volume heating/cooling
         do kk=k-1,k
            do i=is,ie
                     tv = gz(i,kk) + 0.5*(u0(i,kk)**2+v0(i,kk)**2+w0(i,kk)**2)
               t0(i,kk) = rcv*(te(i,kk)- tv)
               hd(i,kk) = cp_air*t0(i,kk) + tv
            enddo
         enddo
       endif
      enddo    ! k-loop
   enddo       ! n-loop


   if ( fra < 1. ) then
      do k=mcond,km
         do i=is,ie
            t0(i,k) = ta(i,j,k) + (t0(i,k) - ta(i,j,k))*fra
            u0(i,k) = ua(i,j,k) + (u0(i,k) - ua(i,j,k))*fra
            v0(i,k) = va(i,j,k) + (v0(i,k) - va(i,j,k))*fra
         enddo
      enddo

      if ( .not. hydrostatic ) then
         do k=mcond,km
            do i=is,ie
               w0(i,k) = w(i,j,k) + (w0(i,k) - w(i,j,k))*fra
            enddo
         enddo
      endif

      do iq=1,nq
         do k=mcond,km
            do i=is,ie
               q0(i,k,iq) = qa(i,j,k,iq) + (q0(i,k,iq) - qa(i,j,k,iq))*fra
            enddo
         enddo
      enddo
   endif
!--------------------

   if ( mcond/=1 ) then
   do k=1,mcond-1
      do i=is,ie
         u_dt(i,j,k) = 0.
         v_dt(i,j,k) = 0.
         t_dt(i,j,k) = 0.
      enddo
      do iq=1,nq
         do i=is,ie
            q_dt(i,j,k,iq) = 0.
         enddo
      enddo
   enddo
   endif

   do k=mcond,km
      do i=is,ie
         u_dt(i,j,k) = rdt*(u0(i,k) - ua(i,j,k))
         v_dt(i,j,k) = rdt*(v0(i,k) - va(i,j,k))
           ta(i,j,k) = t0(i,k)   ! temperature updated
         t_dt(i,j,k) = 0.
      enddo
   enddo

   do iq=1,nq
      do k=mcond,km
         do i=is,ie
            q_dt(i,j,k,iq) = rdt*(q0(i,k,iq)-qa(i,j,k,iq))
         enddo
      enddo
   enddo

   if ( .not. hydrostatic ) then
      do k=mcond,km
         do i=is,ie
            w(i,j,k) = w0(i,k)   ! w updated
         enddo
      enddo
   endif

1000 continue


 end subroutine fv_sg_conv



 real function qs1d(t, p, q)
! Based on "moist" mixing ratio, p is the total (dry+vapor) pressure
  real, intent(in):: t, p, q
! Local:
  real es, ap1
  real, parameter:: Tmin=tice - 160.
  integer it

       ap1 = 10.*DIM(t, Tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
        es = table(it) + (ap1-it)*des(it)
      qs1d = esl*es*(1.+zvir*q)/p

  end function qs1d


  subroutine qsmith_init
  integer, parameter:: length=2621 
  integer i

  if( .not. allocated(table) ) then
!                            Generate es table (dT = 0.1 deg. C)

       allocate ( table(length) )
       allocate (  des (length) )

       call qs_table(length, table)

       do i=1,length-1
          des(i) = table(i+1) - table(i)
       enddo
       des(length) = des(length-1)
  endif
 
  end subroutine qsmith_init


  subroutine qsmith(im, km, k1, t, p, q, qs, dqdt)
! input T in deg K; p (Pa)
  integer, intent(in):: im, km, k1
  real, intent(in),dimension(im,km):: t, p, q
  real, intent(out),dimension(im,km):: qs
  real, intent(out), optional:: dqdt(im,km)
! Local:
  real es(im,km)
  real ap1, eps10
  real Tmin
  integer i, k, it

  Tmin = tice-160.
  eps10  = 10.*esl

  if( .not. allocated(table) ) then
       call  qsmith_init
  endif
 
      do k=k1,km
         do i=1,im
            ap1 = 10.*DIM(t(i,k), Tmin) + 1.
            ap1 = min(2621., ap1)
            it = ap1
            es(i,k) = table(it) + (ap1-it)*des(it)
            qs(i,k) = esl*es(i,k)*(1.+zvir*q(i,k))/p(i,k)
         enddo
      enddo

      if ( present(dqdt) ) then
      do k=k1,km
           do i=1,im
              ap1 = 10.*DIM(t(i,k), Tmin) + 1.
              ap1 = min(2621., ap1) - 0.5
              it  = ap1
              dqdt(i,k) = eps10*(des(it)+(ap1-it)*(des(it+1)-des(it)))*(1.+zvir*q(i,k))/p(i,k)
           enddo
      enddo
      endif
 
  end subroutine qsmith
 

  subroutine qs_table(n,table)
      integer, intent(in):: n
      real table (n)
      real esupc(200)
      real:: dt=0.1
      real esbasw, tbasw, esbasi, tbasi, Tmin, tem, aa, b, c, d, e, esh20 
      real wice, wh2o
      integer i

! Constants
      esbasw = 1013246.0
       tbasw =     373.16
      esbasi =    6107.1
       tbasi =     273.16
! ****************************************************
!  Compute es over ice between -160c and 0 c.
      Tmin = tbasi - 160.
!  see smithsonian meteorological tables page 350.
      do i=1,1600
         tem = Tmin+dt*real(i-1)
         aa  = -9.09718 *(tbasi/tem-1.0)
         b   = -3.56654 *alog10(tbasi/tem)
         c   =  0.876793*(1.0-tem/tbasi)
         e   = alog10(esbasi)
         table(i)=10**(aa+b+c+e)
      enddo
! *****************************************************
!  Compute es over water between -20c and 102c.
!  see smithsonian meteorological tables page 350.
      do  i=1,1221
          tem = 253.16+dt*real(i-1)
          aa  = -7.90298*(tbasw/tem-1)
          b   =  5.02808*alog10(tbasw/tem)
          c   = -1.3816e-07*(10**((1-tem/tbasw)*11.344)-1)
          d   =  8.1328e-03*(10**((tbasw/tem-1)*(-3.49149))-1)
          e   = alog10(esbasw)
          esh20  = 10**(aa+b+c+d+e)
          if (i <= 200) then
              esupc(i) = esh20
          else
              table(i+1400) = esh20
          endif
      enddo
!********************************************************************
!  Derive blended es over ice and supercooled water between -20c and 0c
      do i=1,200
         tem  = 253.16+dt*real(i-1)
         wice = 0.05*(273.16-tem)
         wh2o = 0.05*(tem-253.16)
         table(i+1400) = wice*table(i+1400)+wh2o*esupc(i)
      enddo

      do i=1,n
         table(i) = table(i)*0.1
      enddo

 end subroutine qs_table

 subroutine neg_adj3(is, ie, js, je, ng, kbot,      &
                     pt, dp, qv, ql, qr, qi, qs, qg, qa)

! This is designed for 6-class micro-physics schemes
 integer, intent(in):: is, ie, js, je, ng, kbot
 real, intent(in):: dp(is-ng:ie+ng,js-ng:je+ng,kbot)
 real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,kbot)::    &
                                 pt, qv, ql, qr, qi, qs, qg
 real, intent(inout), optional, dimension(is-ng:ie+ng,js-ng:je+ng,kbot):: qa
! Local:
 real lcp, icp
 real dq, qsum, psum
 integer i, j, k

 lcp = hlv / cp_air
 icp = hlf / cp_air

 do k=1, kbot
    do j=js, je
       do i=is, ie
!-----------
! Ice-phase:
!-----------
! if ice<0 borrow from snow (since main source of snow is cloud ice)
          if( qi(i,j,k) < 0. ) then
              qs(i,j,k) = qs(i,j,k) + qi(i,j,k)
              qi(i,j,k) = 0.
          endif
! if snow<0 borrow from graupel (same as above)
          if( qs(i,j,k) < 0. ) then
              qg(i,j,k) = qg(i,j,k) + qs(i,j,k)
              qs(i,j,k) = 0.
          endif
! If graupel < 0 then borrow from cloud ice (loop back)
          if ( qg(i,j,k) < 0. ) then
               qi(i,j,k) = qi(i,j,k) + qg(i,j,k)
               qg(i,j,k) = 0.
          endif

! If ice < 0 then borrow from cloud water
          if ( qi(i,j,k) < 0. ) then
               ql(i,j,k) = ql(i,j,k) + qi(i,j,k)
               pt(i,j,k) = pt(i,j,k) - qi(i,j,k)*icp   ! heating
               qi(i,j,k) = 0.
          endif

! Liquid phase:
! Fix negative cloud water by borrowing from rain
          if ( ql(i,j,k) < 0. ) then
               qr(i,j,k) = qr(i,j,k) + ql(i,j,k)
               ql(i,j,k) = 0.
          endif
! fix negative rain with vapor
          if ( qr(i,j,k) < 0. ) then
               qv(i,j,k) = qv(i,j,k) + qr(i,j,k)
               pt(i,j,k) = pt(i,j,k) - qr(i,j,k)*lcp
               qr(i,j,k) = 0.
          endif
     enddo
   enddo
 enddo

!-----------------------------------
! Fix water vapor
!-----------------------------------
! Top layer: borrow from below
    k = 1
    do j=js, je
       do i=is, ie
          if( qv(i,j,k) < 0. ) then
              qv(i,j,k+1) = qv(i,j,k+1) + qv(i,j,k)*dp(i,j,k)/dp(i,j,k+1)
              qv(i,j,k  ) = 0.
          endif
     enddo
   enddo

 do k=2,kbot-1
    do j=js, je
       do i=is, ie
          if( qv(i,j,k) < 0. .and. qv(i,j,k-1) > 0. ) then
              dq = min(-qv(i,j,k)*dp(i,j,k), qv(i,j,k-1)*dp(i,j,k-1))
              qv(i,j,k-1) = qv(i,j,k-1) - dq/dp(i,j,k-1) 
              qv(i,j,k  ) = qv(i,j,k  ) + dq/dp(i,j,k  ) 
          endif
          if( qv(i,j,k) < 0. ) then
              qv(i,j,k+1) = qv(i,j,k+1) + qv(i,j,k)*dp(i,j,k)/dp(i,j,k+1)
              qv(i,j,k  ) = 0.
          endif
     enddo
   enddo
 enddo
 
! Bottom layer; Borrow from above
  do j=js, je
     do i=is, ie
        if( qv(i,j,kbot) < 0. .and. qv(i,j,kbot-1)>0.) then
            dq = min(-qv(i,j,kbot)*dp(i,j,kbot), qv(i,j,kbot-1)*dp(i,j,kbot-1))
            qv(i,j,kbot-1) = qv(i,j,kbot-1) - dq/dp(i,j,kbot-1) 
            qv(i,j,kbot  ) = qv(i,j,kbot  ) + dq/dp(i,j,kbot  ) 
        endif
! Last attempt to fix negative qv from condensates
!       if( qv(i,j,kbot) < 0. ) then
!       endif
   enddo
 enddo

!-----------------------------------
! Fix negative cloud fraction
!-----------------------------------
 if ( present(qa) ) then
 do k=1,kbot-1
    do j=js, je
       do i=is, ie
          if( qa(i,j,k) < 0. ) then
              qa(i,j,k+1) = qa(i,j,k+1) + qa(i,j,k)*dp(i,j,k)/dp(i,j,k+1)
              qa(i,j,k  ) = 0.
          endif
     enddo
   enddo
 enddo
 
! Bottom layer; Borrow from above
  do j=js, je
     do i=is, ie
        if( qa(i,j,kbot) < 0. .and. qa(i,j,kbot-1)>0.) then
            dq = min(-qa(i,j,kbot)*dp(i,j,kbot), qa(i,j,kbot-1)*dp(i,j,kbot-1))
            qa(i,j,kbot-1) = qa(i,j,kbot-1) - dq/dp(i,j,kbot-1) 
            qa(i,j,kbot  ) = qa(i,j,kbot  ) + dq/dp(i,j,kbot  ) 
        endif
! if qa is still < 0
        qa(i,j,kbot) = max(0., qa(i,j,kbot))
   enddo
 enddo
 endif

 end subroutine neg_adj3

end module fv_sg_mod


module fv_tracer2d_mod
      use tp_core_mod,          only: fv_tp_2d
      use fv_grid_tools_mod,      only: area, rarea, dxa, dya, dx, dy
      use fv_grid_utils_mod,      only: sina_u, sina_v
      use fv_mp_mod,          only: gid, domain, mp_reduce_max,   &
                                 ng,isd,ied,jsd,jed,is,js,ie,je
      use mpp_domains_mod, only: mpp_update_domains
      use fv_timing_mod,    only: timing_on, timing_off

implicit none
private

public :: tracer_2d, tracer_2d_1L


contains

!-----------------------------------------------------------------------
! !ROUTINE: Perform 2D horizontal-to-lagrangian transport
!-----------------------------------------------------------------------

subroutine tracer_2d_1L(q, dp0, mfx, mfy, cx, cy, npx, npy, npz, nq, hord,  &
                        q_split, k, q3, dt, id_divg)
      integer, intent(IN) :: npx, npy, npz
      integer, intent(IN) :: k
      integer, intent(IN) :: nq    ! number of tracers to be advected
      integer, intent(IN) :: hord
      integer, intent(IN) :: q_split
      integer, intent(IN) :: id_divg
      real   , intent(IN) :: dt
      real   , intent(INOUT) :: q(isd:ied,jsd:jed,nq)       ! 2D Tracers
      real   , intent(INOUT) ::q3(isd:ied,jsd:jed,npz,nq)   ! Tracers
      real   , intent(INOUT) :: dp0(is:ie,js:je)        ! DELP before dyn_core
      real   , intent(IN) :: mfx(is:ie+1,js:je)    ! Mass Flux X-Dir
      real   , intent(IN) :: mfy(is:ie  ,js:je+1)    ! Mass Flux Y-Dir
      real   , intent(IN) ::  cx(is:ie+1,jsd:jed)  ! Courant Number X-Dir
      real   , intent(IN) ::  cy(isd:ied,js :je +1)  ! Courant Number Y-Dir

! Local Arrays
      real :: mfx2(is:ie+1,js:je)
      real :: mfy2(is:ie  ,js:je+1)
      real ::  cx2(is:ie+1,jsd:jed)
      real ::  cy2(isd:ied,js :je +1)

      real :: dp1(is:ie,js:je)
      real :: dp2(is:ie,js:je)
      real :: fx(is:ie+1,js:je )
      real :: fy(is:ie , js:je+1)
      real :: ra_x(is:ie,jsd:jed)
      real :: ra_y(isd:ied,js:je)
      real :: xfx(is:ie+1,jsd:jed)
      real :: yfx(isd:ied,js: je+1)
      real :: cmax
      real :: frac, rdt
      integer :: nsplt
      integer :: i,j,it,iq


      do j=jsd,jed
         do i=is,ie+1
            if (cx(i,j) > 0.) then
                xfx(i,j) = cx(i,j)*dxa(i-1,j)*dy(i,j)*sina_u(i,j)
            else
                xfx(i,j) = cx(i,j)*dxa(i,j)*dy(i,j)*sina_u(i,j)
            endif
         enddo
      enddo
      do j=js,je+1
         do i=isd,ied
            if (cy(i,j) > 0.) then
                yfx(i,j) = cy(i,j)*dya(i,j-1)*dx(i,j)*sina_v(i,j)
            else
                yfx(i,j) = cy(i,j)*dya(i,j)*dx(i,j)*sina_v(i,j)
            endif
         enddo
      enddo


      if ( q_split==0 ) then
! Determine nsplt for tracer advection
         cmax = 0.
         do j=js,je
            do i=is,ie
               cmax = max(abs(cx(i,j))+(1.-sina_u(i,j)),     &
                          abs(cy(i,j))+(1.-sina_v(i,j)), cmax)
            enddo
         enddo
         call mp_reduce_max(cmax)
         nsplt = int(1.01 + cmax)
         if ( gid == 0 .and. nsplt > 5 )  write(6,*) k, 'Tracer_2d_split=', nsplt, cmax
      else
         nsplt = q_split
      endif


      frac  = 1. / real(nsplt)
          do j=jsd,jed
             do i=is,ie+1
                cx2(i,j) =  cx(i,j) * frac
                xfx(i,j) = xfx(i,j) * frac
             enddo
          enddo
          do j=js,je
             do i=is,ie+1
                mfx2(i,j) = mfx(i,j) * frac
             enddo
          enddo

          do j=js,je+1
             do i=isd,ied
                cy2(i,j) =  cy(i,j) * frac
               yfx(i,j) = yfx(i,j) * frac
             enddo
          enddo

          do j=js,je+1
             do i=is,ie
                mfy2(i,j) = mfy(i,j) * frac
             enddo
          enddo

      do j=jsd,jed
         do i=is,ie
            ra_x(i,j) = area(i,j) + xfx(i,j) - xfx(i+1,j)
         enddo
      enddo
      do j=js,je
         do i=isd,ied
            ra_y(i,j) = area(i,j) + yfx(i,j) - yfx(i,j+1)
         enddo
      enddo

      do j=js,je
         do i=is,ie
            dp1(i,j) = dp0(i,j)
         enddo
      enddo

      do it=1,nsplt

         do j=js,je
            do i=is,ie
               dp2(i,j) = dp1(i,j) + (mfx2(i,j) - mfx2(i+1,j) +  &
                          mfy2(i,j) - mfy2(i,j+1)) * rarea(i,j)
            enddo
         enddo

         call timing_on('COMM_TOTAL')
              call timing_on('COMM_TRAC')
         call mpp_update_domains( q, domain, complete= .true. )
              call timing_off('COMM_TRAC')
         call timing_off('COMM_TOTAL')

         do iq=1,nq
            call fv_tp_2d( q(isd,jsd,iq), cx2, cy2, npx, npy, hord, fx, fy, &
                           xfx, yfx, area, ra_x, ra_y, mfx=mfx2, mfy=mfy2 )
            if( it==nsplt ) then
            do j=js,je
               do i=is,ie
                  q3(i,j,k,iq) = (q(i,j,iq)*dp1(i,j) + (fx(i,j)-fx(i+1,j) + &
                                  fy(i,j)-fy(i,j+1))*rarea(i,j)) / dp2(i,j)
               enddo
            enddo
            else
            do j=js,je
               do i=is,ie
                  q(i,j,iq) = (q(i,j,iq)*dp1(i,j) + (fx(i,j)-fx(i+1,j) + &
                              fy(i,j)-fy(i,j+1))*rarea(i,j)) / dp2(i,j)
               enddo
            enddo
           endif
         enddo

         if ( it/=nsplt ) then
              do j=js,je
                 do i=is,ie
                    dp1(i,j) = dp2(i,j)
                 enddo
              enddo
         endif
     enddo  ! nsplt

     if ( id_divg > 0 ) then
         rdt = 1./(frac*dt)
         do j=js,je
            do i=is,ie
               dp0(i,j) = (xfx(i+1,j)-xfx(i,j) + yfx(i,j+1)-yfx(i,j))*rarea(i,j)*rdt
            enddo
         enddo
     endif

end subroutine tracer_2d_1L

subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, npx, npy, npz,   &
                     nq,  hord, q_split, dt, id_divg)

      integer, intent(IN) :: npx
      integer, intent(IN) :: npy
      integer, intent(IN) :: npz
      integer, intent(IN) :: nq    ! number of tracers to be advected
      integer, intent(IN) :: hord
      integer, intent(IN) :: q_split
      integer, intent(IN) :: id_divg
      real   , intent(IN) :: dt
      real   , intent(INOUT) :: q(isd:ied,jsd:jed,npz,nq)   ! Tracers
      real   , intent(INOUT) :: dp1(is:ie,js:je,npz)        ! DELP before dyn_core
      real   , intent(INOUT) :: mfx(is:ie+1,js:je,  npz)    ! Mass Flux X-Dir
      real   , intent(INOUT) :: mfy(is:ie  ,js:je+1,npz)    ! Mass Flux Y-Dir
      real   , intent(INOUT) ::  cx(is:ie+1,jsd:jed  ,npz)  ! Courant Number X-Dir
      real   , intent(INOUT) ::  cy(isd:ied,js :je +1,npz)  ! Courant Number Y-Dir

! Local Arrays
      real :: dp2(is:ie,js:je)
      real :: fx(is:ie+1,js:je )
      real :: fy(is:ie , js:je+1)
      real :: ra_x(is:ie,jsd:jed)
      real :: ra_y(isd:ied,js:je)
      real :: xfx(is:ie+1,jsd:jed  ,npz)
      real :: yfx(isd:ied,js: je+1, npz)
      real :: cmax(npz)

      real :: c_global
      real :: frac, rdt
      integer :: nsplt
      integer :: i,j,k,it,iq

      do k=1,npz
         do j=jsd,jed
            do i=is,ie+1
               if (cx(i,j,k) > 0.) then
                  xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sina_u(i,j)
               else
                  xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sina_u(i,j)
               endif
            enddo
         enddo
         do j=js,je+1
            do i=isd,ied
               if (cy(i,j,k) > 0.) then
                  yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sina_v(i,j)
               else
                  yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sina_v(i,j)
               endif
            enddo
         enddo
      enddo

!--------------------------------------------------------------------------------
  if ( q_split == 0 ) then
! Determine nsplt
      do k=1,npz
         cmax(k) = 0.
         do j=js,je
            do i=is,ie
               cmax(k) = max(abs(cx(i,j,k))+1.-sina_u(i,j), abs(cy(i,j,k))+1.-sina_v(i,j), cmax(k))
            enddo
         enddo
      enddo

      call mp_reduce_max(cmax,npz)

! find global max courant number and define nsplt to scale cx,cy,mfx,mfy
      c_global = cmax(1)
      if ( npz /= 1 ) then                ! if NOT shallow water test case
         do k=2,npz
            c_global = max(cmax(k), c_global)
         enddo
      endif
      nsplt = int(1. + c_global)
      if ( gid == 0 .and. nsplt > 5 )  write(6,*) 'Tracer_2d_split=', nsplt, c_global
   else
      nsplt = q_split
   endif
!--------------------------------------------------------------------------------

   frac  = 1. / real(nsplt)

      if( nsplt /= 1 ) then
          do k=1,npz
             do j=jsd,jed
                do i=is,ie+1
                   cx(i,j,k) =  cx(i,j,k) * frac
                   xfx(i,j,k) = xfx(i,j,k) * frac
                enddo
             enddo
             do j=js,je
                do i=is,ie+1
                   mfx(i,j,k) = mfx(i,j,k) * frac
                enddo
             enddo

             do j=js,je+1
                do i=isd,ied
                   cy(i,j,k) =  cy(i,j,k) * frac
                  yfx(i,j,k) = yfx(i,j,k) * frac
                enddo
             enddo

             do j=js,je+1
                do i=is,ie
                  mfy(i,j,k) = mfy(i,j,k) * frac
                enddo
             enddo
          enddo
      endif

    do it=1,nsplt

            call timing_on('COMM_TOTAL')
              call timing_on('COMM_TRAC')
       call mpp_update_domains( q, domain, complete=.true. )
              call timing_off('COMM_TRAC')
            call timing_off('COMM_TOTAL')

      do k=1,npz

         do j=jsd,jed
            do i=is,ie
               ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k)
            enddo
         enddo
         do j=js,je
            do i=isd,ied
               ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k)
            enddo
         enddo

         do j=js,je
            do i=is,ie
               dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k) - mfx(i+1,j,k) +  &
                          mfy(i,j,k) - mfy(i,j+1,k)) * rarea(i,j)
            enddo
         enddo

         do iq=1,nq
            call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), &
                          npx, npy, hord, fx, fy,            &
                          xfx(is,jsd,k), yfx(isd,js,k), area, ra_x, ra_y, &
                          mfx=mfx(is,js,k), mfy=mfy(is,js,k))

            do j=js,je
               do i=is,ie
                  q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + &
                                (fx(i,j)-fx(i+1,j) + fy(i,j)-fy(i,j+1))*rarea(i,j) ) / dp2(i,j)
               enddo
            enddo

         enddo

         do j=js,je
            do i=is,ie
               dp1(i,j,k) = dp2(i,j)
            enddo
         enddo


      enddo ! npz

   enddo  ! nsplt

   if ( id_divg > 0 ) then
        rdt = 1./(frac*dt)
        do k=1,npz
        do j=js,je
           do i=is,ie
              dp1(i,j,k) = (xfx(i+1,j,k)-xfx(i,j,k) + yfx(i,j+1,k)-yfx(i,j,k))*rarea(i,j)*rdt
           enddo
        enddo
        enddo
   endif

end subroutine tracer_2d

end module fv_tracer2d_mod


module fv_update_phys_mod

  use constants_mod,      only: kappa, rdgas, rvgas, grav, cp_air, pi
  use field_manager_mod,  only: MODEL_ATMOS
  use mpp_domains_mod,    only: mpp_update_domains
  use mpp_parameter_mod,  only: AGRID_PARAM=>AGRID
  use mpp_mod,            only: FATAL, mpp_error
  use time_manager_mod,   only: time_type
  use tracer_manager_mod, only: get_tracer_index

  use fv_arrays_mod,      only: fv_atmos_type
  use fv_control_mod,     only: npx, npy, npz, ncnst, k_top, nwat, fv_debug, &
                                tau_h2o, phys_hydrostatic, dwind_2d, filter_phys
  use fv_mp_mod,          only: domain, gid
  use fv_eta_mod,         only: get_eta_level
  use fv_grid_utils_mod,  only: edge_vect_s,edge_vect_n,edge_vect_w,edge_vect_e, &
                                es, ew, vlon, vlat, z11, z12, z21, z22, &
                                sina_u, sina_v, da_min
  use fv_grid_tools_mod,  only: dx, dy, rdxc, rdyc, rarea, dxa, dya, grid_type
  use fv_timing_mod,      only: timing_on, timing_off
  use fv_diagnostics_mod, only: prt_maxmin

#ifdef CLIMATE_NUDGE
  use atmos_nudge_mod,    only: get_atmos_nudge, do_ps
#else
  use fv_nwp_nudge_mod,   only: fv_nwp_nudge
#endif

  implicit none

  public :: fv_update_phys, del2_phys

  contains

  subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq,     &
                              u, v, delp, pt, q, ua, va, ps, pe,  peln, pk, pkz,  &
                              ak, bk, phis, u_srf, v_srf, ts, delz, hydrostatic,  &
                              u_dt, v_dt, t_dt, q_dt, moist_phys, Time, nudge )
    real, intent(in)   :: dt
    integer, intent(in):: is,  ie,  js,  je, ng
    integer, intent(in):: isd, ied, jsd, jed
    integer, intent(in):: nq            ! tracers modified by physics 
                                        ! ncnst is the total nmber of tracers
    logical, intent(in):: moist_phys
    logical, intent(in):: hydrostatic
    logical, optional, intent(in):: nudge

    type (time_type), intent(in) :: Time

    real, intent(in), dimension(npz+1):: ak, bk
    real, intent(in) :: phis(isd:ied,jsd:jed)
    real, intent(inout):: delz(is:ie,js:je,npz)

! Winds on lat-lon grid:
    real, intent(inout), dimension(isd:ied,jsd:jed,npz):: ua, va

! Tendencies from Physics:
    real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt
    real, intent(inout):: t_dt(is:ie,js:je,npz)
    real, intent(inout):: q_dt(is:ie,js:je,npz,nq)

! Saved Bottom winds for GFDL Physics Interface
    real, intent(out), dimension(is:ie,js:je):: u_srf, v_srf, ts

    real, intent(inout):: u(isd:ied  ,jsd:jed+1,npz)  ! D grid zonal wind (m/s)
    real, intent(inout):: v(isd:ied+1,jsd:jed  ,npz)  ! D grid meridional wind (m/s)
    real, intent(inout), dimension(isd:ied,jsd:jed,npz):: pt, delp
    real, intent(inout):: q(isd:ied,jsd:jed,npz, ncnst)   ! specific humidity and constituents

!-----------------------------------------------------------------------
! Auxilliary pressure arrays:    
! The 5 vars below can be re-computed from delp and ptop.
!-----------------------------------------------------------------------
! dyn_aux:
    real, intent(inout):: ps  (isd:ied  ,jsd:jed)           ! Surface pressure (pascal)
    real, intent(inout):: pe  (is-1:ie+1, npz+1,js-1:je+1)  ! edge pressure (pascal)
    real, intent(inout):: pk  (is:ie,js:je  , npz+1)        ! pe**cappa
    real, intent(inout):: peln(is:ie,npz+1,js:je)           ! ln(pe)
    real, intent(inout):: pkz (is:ie,js:je,npz)             ! finite-volume mean pk

!**********
! Halo Data
!**********
    real, parameter::    q1_h2o = 2.2E-6
    real, parameter::    q7_h2o = 3.8E-6
    real, parameter::  q100_h2o = 3.8E-6
    real, parameter:: q1000_h2o = 3.1E-6
    real, parameter:: q2000_h2o = 2.8E-6
    real, parameter:: q3000_h2o = 3.0E-6

! Local arrays:
    real  ps_dt(is:ie,js:je)
    real  phalf(npz+1), pfull(npz)

    integer  i, j, k, m
    integer  sphum, liq_wat, ice_wat, cld_amt   ! GFDL AM physics
    integer  rainwat, snowwat, graupel          ! Lin Micro-physics
    real     qstar, dbk, rdg, gama_dt, zvir

    if ( filter_phys ) then
         call del2_phys(t_dt, delp, 0.2, npx, npy, npz, is, ie, js, je, &
                        isd, ied, jsd, jed, 0)
         do m=1,nq
            call del2_phys(q_dt(:,:,:,m), delp, 0.2, npx, npy, npz, is, ie, js, je, &
                           isd, ied, jsd, jed, 0)
         enddo
    endif

    rdg = -rdgas / grav
    gama_dt = dt * cp_air / (cp_air-rdgas)

#if defined(MARS_GCM) || defined(VENUS_GCM)
!$omp parallel do default(shared) private(i, j, k, m, qstar, ps_dt)
    do k=1, npz
       do j=js,je
          do i=is,ie
             ua(i,j,k) = ua(i,j,k) + dt*u_dt(i,j,k)
             va(i,j,k) = va(i,j,k) + dt*v_dt(i,j,k)
          enddo
       enddo

       if ( hydrostatic ) then
          do j=js,je
             do i=is,ie
                pt(i,j,k) = pt(i,j,k) + dt*t_dt(i,j,k)
             enddo
          enddo
       else
         if ( phys_hydrostatic ) then
! Heating/cooling from physics is assumed to be isobaric hydrostatic proc
! "nagative" definiteness of delz is maintained.
             do j=js,je
                do i=is,ie
                   delz(i,j,k) = delz(i,j,k) / pt(i,j,k)
               pt(i,j,k) = pt(i,j,k) + dt*t_dt(i,j,k)
                   delz(i,j,k) = delz(i,j,k) * pt(i,j,k)
                enddo
             enddo
         else
! Convert tendency from constant-p to constant-volume
             do j=js,je
                do i=is,ie
                   pt(i,j,k) = pt(i,j,k) + t_dt(i,j,k)*gama_dt
                enddo
             enddo
         endif
       endif

!----------------
! Update tracers:
!----------------
       do m=1,nq
          do j=js,je
             do i=is,ie
                q(i,j,k,m) = q(i,j,k,m) + dt*q_dt(i,j,k,m)
             enddo
          enddo
       enddo
    enddo  ! openmp k-loop

#else
    sphum   = 1

    if ( moist_phys ) then
        cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt')
           zvir = rvgas/rdgas - 1.
    else
        cld_amt = 7
           zvir = 0.
    endif

    if ( nwat>=3 ) then
        sphum   = get_tracer_index (MODEL_ATMOS, 'sphum')
        liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
        ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
    endif

    if ( nwat==6 ) then
! Micro-physics:
        rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
        snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
        graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
        if ( cld_amt<7 ) call mpp_error(FATAL,'Cloud Fraction allocation error') 
    endif

    if ( fv_debug ) then
       if ( gid==0 ) write(*,*) nq, nwat, sphum, liq_wat, ice_wat, rainwat, snowwat, graupel
       call prt_maxmin('delp_b_update', delp, is, ie, js,  je, ng, npz, 0.01, gid==0)
       do m=1,nq
          call prt_maxmin('q_dt', q_dt(is,js,1,m), is, ie, js, je, 0, npz, 1., gid==0)
       enddo
    endif

    call get_eta_level(npz, 1.0E5, pfull, phalf, ak, bk)

!$omp parallel do default(shared) private(i, j, k, m, qstar, ps_dt)
    do k=1, npz

! Do idealized Ch4 chemistry
       if ( tau_h2o>0.0 .and. pfull(k) < 3000. ) then

           if ( pfull(k) < 1. ) then
               qstar = q1_h2o
           elseif ( pfull(k) <   7. .and. pfull(k) >=    1. ) then
               qstar = q1_h2o + (q7_h2o-q1_h2o)*log(pfull(k)/1.)/log(7.)
           elseif ( pfull(k) <  100. .and. pfull(k) >=    7. ) then
               qstar = q7_h2o + (q100_h2o-q7_h2o)*log(pfull(k)/7.)/log(100./7.)
           elseif ( pfull(k) < 1000. .and. pfull(k) >=  100. ) then
               qstar = q100_h2o + (q1000_h2o-q100_h2o)*log(pfull(k)/1.E2)/log(10.)
           elseif ( pfull(k) < 2000. .and. pfull(k) >= 1000. ) then
               qstar = q1000_h2o + (q2000_h2o-q1000_h2o)*log(pfull(k)/1.E3)/log(2.)
           else
               qstar = q3000_h2o
           endif

           do j=js,je
              do i=is,ie
                 q_dt(i,j,k,sphum) = q_dt(i,j,k,sphum) + (qstar-q(i,j,k,sphum))/(tau_h2o*86400.)
              enddo
           enddo
       endif

       do j=js,je
          do i=is,ie
             ua(i,j,k) = ua(i,j,k) + dt*u_dt(i,j,k)
             va(i,j,k) = va(i,j,k) + dt*v_dt(i,j,k)
          enddo
       enddo

       if ( hydrostatic ) then
          do j=js,je
             do i=is,ie
!               pt(i,j,k) = pt(i,j,k) + dt*t_dt(i,j,k) /     &
!                           (1.-kappa*ak(1)/delp(i,j,k)*(peln(i,k+1,j)-peln(i,k,j)))
                pt(i,j,k) = pt(i,j,k) + dt*t_dt(i,j,k)
             enddo
          enddo
       else
         if ( phys_hydrostatic ) then
! Heating/cooling from physics is assumed to be isobaric hydrostatic proc
! "nagative" definiteness of delz is maintained.
             do j=js,je
                do i=is,ie
                   delz(i,j,k) = delz(i,j,k) / pt(i,j,k)
!                     pt(i,j,k) = pt(i,j,k) + dt*t_dt(i,j,k) /     &
!                              (1.-kappa*ak(1)/delp(i,j,k)*(peln(i,k+1,j)-peln(i,k,j)))
               pt(i,j,k) = pt(i,j,k) + dt*t_dt(i,j,k)
                   delz(i,j,k) = delz(i,j,k) * pt(i,j,k)
                enddo
             enddo
         else
! Convert tendency from constant-p to constant-volume
             do j=js,je
                do i=is,ie
                   pt(i,j,k) = pt(i,j,k) + t_dt(i,j,k)*gama_dt
                enddo
             enddo
         endif
       endif

!----------------
! Update tracers:
!----------------
       do m=1,nq
          do j=js,je
             do i=is,ie
                q(i,j,k,m) = q(i,j,k,m) + dt*q_dt(i,j,k,m)
             enddo
          enddo
       enddo

!--------------------------------------------------------
! Adjust total air mass due to changes in water substance
!--------------------------------------------------------

      if ( nwat==6 ) then
! micro-physics with 6 water substances
        do j=js,je
           do i=is,ie
              ps_dt(i,j)  = 1. + dt * ( q_dt(i,j,k,sphum  ) +    &
                                        q_dt(i,j,k,liq_wat) +    &
                                        q_dt(i,j,k,rainwat) +    &
                                        q_dt(i,j,k,ice_wat) +    &
                                        q_dt(i,j,k,snowwat) +    &
                                        q_dt(i,j,k,graupel) )
              delp(i,j,k) = delp(i,j,k) * ps_dt(i,j)
           enddo
        enddo
      elseif( nwat==3 ) then
! GFDL AM2/3 phys (cloud water + cloud ice)
        do j=js,je
           do i=is,ie
               ps_dt(i,j) = 1. + dt*(q_dt(i,j,k,sphum  ) +    &
                                     q_dt(i,j,k,liq_wat) +    &
                                     q_dt(i,j,k,ice_wat) )
              delp(i,j,k) = delp(i,j,k) * ps_dt(i,j)
           enddo
        enddo
      elseif ( nwat>0 ) then
        do j=js,je
           do i=is,ie
              ps_dt(i,j)  = 1. + dt*sum(q_dt(i,j,k,1:nwat))
              delp(i,j,k) = delp(i,j,k) * ps_dt(i,j)
           enddo
        enddo
      endif

!-----------------------------------------
! Adjust mass mixing ratio of all tracers 
!-----------------------------------------
      if ( nwat /=0 ) then
        do m=1,ncnst   
          if( m /= cld_amt ) then  ! cloud fraction in GFDL physics
            do j=js,je
               do i=is,ie
                  q(i,j,k,m) = q(i,j,k,m) / ps_dt(i,j)
               enddo
            enddo
          endif
        enddo
      endif
   enddo ! openmp k-loop

#endif ! Mars and Venus GCM

! [delp, (ua, va), pt, q] updated. Perform nudging if requested

!------- nudging of atmospheric variables toward specified data --------

    ps_dt(:,:) = 0.

    if (present(nudge)) then
#ifdef CLIMATE_NUDGE
!--------------------------------------------
! All fields will be updated; tendencies added
!--------------------------------------------
      if (nudge) then
        call get_atmos_nudge ( Time, dt, beglon, endlon, beglat, endlat,    &
             npz, ng, ps(beglon:endlon,:), ua(beglon:endlon,:,:), &
             va(beglon:endlon,:,:), pt(beglon:endlon,:,:), &
             q(beglon:endlon,:,:,:), ps_dt(beglon:endlon,:), u_dt(beglon:endlon,:,:),  & 
             v_dt(beglon:endlon,:,:), t_dt(beglon:endlon,:,:), &
             q_dt(beglon:endlon,:,:,:) )

        if (do_ps) then
!--------------
! Update delp
!--------------
            do k=1,npz
               dbk = dt * (bk(k+1) - bk(k))
               do j=js,je
                  do i=is,ie
                     delp(i,j,k) = delp(i,j,k) + dbk*ps_dt(i,j)
                  enddo
               enddo
            enddo
        endif
      endif
#else
! All fields will be updated except winds; wind tendencies added
      if (nudge) then
!$omp parallel do default(shared) private(i, j, k)
        do j=js,je
         do k=2,npz+1                                                                             
          do i=is,ie
            pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
          enddo
         enddo
         do i=is,ie
           ps(i,j) = pe(i,npz+1,j)
         enddo
        enddo
        call fv_nwp_nudge ( Time, dt, npz,  ps_dt, u_dt, v_dt, t_dt, q_dt,   &
                            zvir, ak, bk, ts, ps, delp, ua, va, pt, nwat, q,  phis )
      endif
#endif
    endif

!----------------------------------------
! Update pe, peln, pkz, and surface winds
!----------------------------------------
  if ( fv_debug ) then
       call prt_maxmin('PS_b_update',     ps, is, ie, js,  je, ng,   1, 0.01, gid==0)
!       call prt_maxmin('pd_dt',  ps_dt, is, ie, js,  je, 0,   1, 1., gid==0)
       call prt_maxmin('delp_a_update', delp, is, ie, js,  je, ng, npz, 0.01, gid==0)
  endif

!$omp parallel do default(shared) private(i, j, k)
   do j=js,je
      do k=2,npz+1                                                                             
         do i=is,ie
              pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
            peln(i,k,j) = log( pe(i,k,j) )
              pk(i,j,k) = exp( kappa*peln(i,k,j) )
         enddo
      enddo

      do i=is,ie
            ps(i,j) = pe(i,npz+1,j)
         u_srf(i,j) = ua(i,j,npz)
         v_srf(i,j) = va(i,j,npz)
      enddo

      if ( hydrostatic ) then
         do k=1,npz
            do i=is,ie
               pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
            enddo
         enddo
      endif
   enddo      ! j-loop

!-------------------------------------------------------------------------
! Re-compute the full (nonhydrostatic) pressure due to temperature changes
!-------------------------------------------------------------------------
    if ( .not.hydrostatic ) then
      if ( k_top>1 ) then
         do k=1,k_top-1
            do j=js,je
               do i=is,ie
                  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k)) /     &
                         (kappa*(peln(i,k+1,j)-peln(i,k,j)))
               enddo
            enddo
         enddo
      endif

      do k=k_top,npz
         do j=js,je
            do i=is,ie
! perfect gas law: p = density * rdgas * virtual_temperature
!              pkz(i,j,k) = ( rdg*delp(i,j,k)*pt(i,j,k)/delz(i,j,k) )**kappa
               pkz(i,j,k) = exp( kappa*log(rdg*delp(i,j,k)*pt(i,j,k)*    &
                                           (1.+zvir*q(i,j,k,sphum))/delz(i,j,k)) )
            enddo
         enddo
      enddo
    endif
                                                    call timing_on(' Update_dwinds')
  if ( dwind_2d ) then
    call update2d_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v)
  else
    call update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v)
  endif
                                                    call timing_off(' Update_dwinds')

  if ( fv_debug ) then
       call prt_maxmin('PS_a_update', ps, is, ie, js, je, ng,   1, 0.01, gid==0)
  endif

  end subroutine fv_update_phys


  subroutine del2_phys(qdt, delp, cd, npx, npy, km, is, ie, js, je, &
                       isd, ied, jsd, jed, ngc)
! This routine is for filtering the physics tendency
   integer, intent(in):: npx, npy, km
   integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed, ngc
   real,    intent(in):: cd            ! cd = K * da_min;   0 < K < 0.25
   real, intent(in   ):: delp(isd:ied,jsd:jed,km)
   real, intent(inout):: qdt(is-ngc:ie+ngc,js-ngc:je+ngc,km)
!
   real :: q(isd:ied,jsd:jed,km)
   real :: fx(is:ie+1,js:je), fy(is:ie,js:je+1)
   real :: mask(is:ie+1,js:je+1)
   real :: f1(is:ie+1), f2(js:je+1)
   real :: damp
   integer i,j,k

! Applying mask to cd, the damping coefficient?
   damp = 0.25 * cd * da_min

! Mask defined at corners
   do i=is,ie+1
      f1(i) = (1. - sin(real(i-1)/real(npx-1)*pi))**2
   enddo

   do j=js,je+1
      f2(j) = (1. - sin(real(j-1)/real(npy-1)*pi))**2
      do i=is,ie+1
         mask(i,j) = damp * (f1(i) + f2(j))
      enddo
   enddo

! mass weighted tendency from physics is filtered
   do k=1,km
      do j=js,je
         do i=is,ie
            q(i,j,k) = qdt(i,j,k)*delp(i,j,k)
         enddo
      enddo
   enddo
                     call timing_on('COMM_TOTAL')
   call mpp_update_domains(q, domain, complete=.true.)
                     call timing_off('COMM_TOTAL')

   do k=1,km
      do j=js,je
         do i=is,ie+1
            fx(i,j) = (mask(i,j)+mask(i,j+1))*dy(i,j)*sina_u(i,j)*(q(i-1,j,k)-q(i,j,k))*rdxc(i,j)
         enddo
      enddo
      do j=js,je+1
         do i=is,ie
            fy(i,j) = (mask(i,j)+mask(i+1,j))*dx(i,j)*sina_v(i,j)*(q(i,j-1,k)-q(i,j,k))*rdyc(i,j)
         enddo
      enddo
      do j=js,je
         do i=is,ie
            qdt(i,j,k) = qdt(i,j,k) + rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))/delp(i,j,k)
         enddo
      enddo
   enddo

  end subroutine del2_phys


  subroutine update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v)

! Purpose; Transform wind tendencies on A grid to D grid for the final update
 
  integer, intent(in):: is,  ie,  js,  je
  integer, intent(in):: isd, ied, jsd, jed
  real,    intent(in):: dt
  real, intent(inout):: u(isd:ied,  jsd:jed+1,npz)
  real, intent(inout):: v(isd:ied+1,jsd:jed  ,npz)
  real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt

! local:
  real v3(is-1:ie+1,js-1:je+1,3)
  real ue(is-1:ie+1,js:je+1,3)    ! 3D winds at edges
  real ve(is:ie+1,js-1:je+1,  3)    ! 3D winds at edges
  real, dimension(is:ie):: ut1, ut2, ut3
  real, dimension(js:je):: vt1, vt2, vt3
  real dt5, gratio
  integer i, j, k, m, im2, jm2


       call timing_on('COMM_TOTAL')
  call mpp_update_domains(u_dt, domain, complete=.false.)
  call mpp_update_domains(v_dt, domain, complete=.true.)
       call timing_off('COMM_TOTAL')

    dt5 = 0.5 * dt
    im2 = (npx-1)/2
    jm2 = (npy-1)/2

!$omp parallel do default(shared) private(i, j, k, ut1, ut2, ut3, vt1, vt2, vt3, ue, ve, v3)
    do k=1, npz

     if ( grid_type > 3 ) then    ! Local & one tile configurations

       do j=js,je+1
          do i=is,ie
             u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k))
          enddo
       enddo

     else
! Compute 3D wind tendency on A grid
       do j=js-1,je+1
          do i=is-1,ie+1
             v3(i,j,1) = u_dt(i,j,k)*vlon(i,j,1) + v_dt(i,j,k)*vlat(i,j,1)
             v3(i,j,2) = u_dt(i,j,k)*vlon(i,j,2) + v_dt(i,j,k)*vlat(i,j,2)
             v3(i,j,3) = u_dt(i,j,k)*vlon(i,j,3) + v_dt(i,j,k)*vlat(i,j,3)
          enddo
       enddo

! Interpolate to cell edges
       do j=js,je+1
          do i=is-1,ie+1
             ue(i,j,1) = v3(i,j-1,1) + v3(i,j,1)
             ue(i,j,2) = v3(i,j-1,2) + v3(i,j,2)
             ue(i,j,3) = v3(i,j-1,3) + v3(i,j,3)
          enddo
       enddo

       do j=js-1,je+1
          do i=is,ie+1
             ve(i,j,1) = v3(i-1,j,1) + v3(i,j,1)
             ve(i,j,2) = v3(i-1,j,2) + v3(i,j,2)
             ve(i,j,3) = v3(i-1,j,3) + v3(i,j,3)
          enddo
       enddo

! --- E_W edges (for v-wind):
     if ( is==1 ) then
       i = 1
       do j=js,je
        if ( j>jm2 ) then
             vt1(j) = edge_vect_w(j)*ve(i,j-1,1)+(1.-edge_vect_w(j))*ve(i,j,1)
             vt2(j) = edge_vect_w(j)*ve(i,j-1,2)+(1.-edge_vect_w(j))*ve(i,j,2)
             vt3(j) = edge_vect_w(j)*ve(i,j-1,3)+(1.-edge_vect_w(j))*ve(i,j,3)
        else
             vt1(j) = edge_vect_w(j)*ve(i,j+1,1)+(1.-edge_vect_w(j))*ve(i,j,1)
             vt2(j) = edge_vect_w(j)*ve(i,j+1,2)+(1.-edge_vect_w(j))*ve(i,j,2)
             vt3(j) = edge_vect_w(j)*ve(i,j+1,3)+(1.-edge_vect_w(j))*ve(i,j,3)
        endif
       enddo
       do j=js,je
          ve(i,j,1) = vt1(j)
          ve(i,j,2) = vt2(j)
          ve(i,j,3) = vt3(j)
       enddo
     endif
     if ( (ie+1)==npx ) then
       i = npx
       do j=js,je
        if ( j>jm2 ) then
             vt1(j) = edge_vect_e(j)*ve(i,j-1,1)+(1.-edge_vect_e(j))*ve(i,j,1)
             vt2(j) = edge_vect_e(j)*ve(i,j-1,2)+(1.-edge_vect_e(j))*ve(i,j,2)
             vt3(j) = edge_vect_e(j)*ve(i,j-1,3)+(1.-edge_vect_e(j))*ve(i,j,3)
        else
             vt1(j) = edge_vect_e(j)*ve(i,j+1,1)+(1.-edge_vect_e(j))*ve(i,j,1)
             vt2(j) = edge_vect_e(j)*ve(i,j+1,2)+(1.-edge_vect_e(j))*ve(i,j,2)
             vt3(j) = edge_vect_e(j)*ve(i,j+1,3)+(1.-edge_vect_e(j))*ve(i,j,3)
        endif
       enddo
       do j=js,je
          ve(i,j,1) = vt1(j)
          ve(i,j,2) = vt2(j)
          ve(i,j,3) = vt3(j)
       enddo
     endif
! N-S edges (for u-wind):
     if ( js==1 ) then
       j = 1
       do i=is,ie
        if ( i>im2 ) then
             ut1(i) = edge_vect_s(i)*ue(i-1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1)
             ut2(i) = edge_vect_s(i)*ue(i-1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2)
             ut3(i) = edge_vect_s(i)*ue(i-1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3)
        else
             ut1(i) = edge_vect_s(i)*ue(i+1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1)
             ut2(i) = edge_vect_s(i)*ue(i+1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2)
             ut3(i) = edge_vect_s(i)*ue(i+1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3)
        endif
       enddo
       do i=is,ie
          ue(i,j,1) = ut1(i)
          ue(i,j,2) = ut2(i)
          ue(i,j,3) = ut3(i)
       enddo
     endif
     if ( (je+1)==npy ) then
       j = npy
       do i=is,ie
        if ( i>im2 ) then
             ut1(i) = edge_vect_n(i)*ue(i-1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1)
             ut2(i) = edge_vect_n(i)*ue(i-1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2)
             ut3(i) = edge_vect_n(i)*ue(i-1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3)
        else
             ut1(i) = edge_vect_n(i)*ue(i+1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1)
             ut2(i) = edge_vect_n(i)*ue(i+1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2)
             ut3(i) = edge_vect_n(i)*ue(i+1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3)
        endif
       enddo
       do i=is,ie
          ue(i,j,1) = ut1(i)
          ue(i,j,2) = ut2(i)
          ue(i,j,3) = ut3(i)
       enddo
     endif
       do j=js,je+1
          do i=is,ie
             u(i,j,k) = u(i,j,k) + dt5*( ue(i,j,1)*es(1,i,j,1) +  &
                                         ue(i,j,2)*es(2,i,j,1) +  &
                                         ue(i,j,3)*es(3,i,j,1) )
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             v(i,j,k) = v(i,j,k) + dt5*( ve(i,j,1)*ew(1,i,j,2) +  &
                                         ve(i,j,2)*ew(2,i,j,2) +  &
                                         ve(i,j,3)*ew(3,i,j,2) )
          enddo
       enddo
! Update:
      endif   ! end grid_type
 
    enddo         ! k-loop

  end subroutine update_dwinds_phys 


  subroutine update2d_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v)

! Purpose; Transform wind tendencies on A grid to D grid for the final update

  integer, intent(in):: is,  ie,  js,  je
  integer, intent(in):: isd, ied, jsd, jed
  real,    intent(in):: dt
  real, intent(inout):: u(isd:ied,  jsd:jed+1,npz)
  real, intent(inout):: v(isd:ied+1,jsd:jed  ,npz)
  real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt

! local:
  real ut(isd:ied,jsd:jed)
  real:: dt5, gratio
  integer i, j, k

! Transform wind tendency on A grid to local "co-variant" components:
!$omp parallel do private (i,j,k, ut)
    do k=1,npz
       do j=js,je
          do i=is,ie
                 ut(i,j) = z11(i,j)*u_dt(i,j,k) + z12(i,j)*v_dt(i,j,k)
             v_dt(i,j,k) = z21(i,j)*u_dt(i,j,k) + z22(i,j)*v_dt(i,j,k)
             u_dt(i,j,k) = ut(i,j)
          enddo
       enddo
    enddo
! (u_dt,v_dt) are now on local coordinate system
       call timing_on('COMM_TOTAL')
  call mpp_update_domains(u_dt, v_dt, domain, gridtype=AGRID_PARAM)
       call timing_off('COMM_TOTAL')

    dt5 = 0.5 * dt

!$omp parallel do private (i,j,k, gratio)
    do k=1, npz

     if ( grid_type > 3 ) then    ! Local & one tile configurations

       do j=js,je+1
          do i=is,ie
             u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k))
          enddo
       enddo

     else

!--------
! u-wind
!--------
! Edges:
    if ( js==1 ) then
       do i=is,ie
          gratio = dya(i,2) / dya(i,1)
          u(i,1,k) = u(i,1,k) + dt5*((2.+gratio)*(u_dt(i,0,k)+u_dt(i,1,k))  &
                   -(u_dt(i,-1,k)+u_dt(i,2,k)))/(1.+gratio)
       enddo
    endif

! Interior
    do j=max(2,js),min(npy-1,je+1)
       do i=is,ie
          u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k)+u_dt(i,j,k))
       enddo
    enddo

    if ( (je+1)==npy ) then
       do i=is,ie
          gratio = dya(i,npy-2) / dya(i,npy-1)
          u(i,npy,k) = u(i,npy,k) + dt5*((2.+gratio)*(u_dt(i,npy-1,k)+u_dt(i,npy,k)) &
                     -(u_dt(i,npy-2,k)+u_dt(i,npy+1,k)))/(1.+gratio)
       enddo
    endif

!--------
! v-wind
!--------
! West Edges:
    if ( is==1 ) then
       do j=js,je
          gratio = dxa(2,j) / dxa(1,j)
          v(1,j,k) = v(1,j,k) + dt5*((2.+gratio)*(v_dt(0,j,k)+v_dt(1,j,k)) &
                   -(v_dt(-1,j,k)+v_dt(2,j,k)))/(1.+gratio)
       enddo
    endif

! Interior
    do j=js,je
       do i=max(2,is),min(npx-1,ie+1)
          v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k)+v_dt(i,j,k))
       enddo
    enddo

! East Edges:
    if ( (ie+1)==npx ) then
       do j=js,je
          gratio = dxa(npx-2,j) / dxa(npx-1,j)
          v(npx,j,k) = v(npx,j,k) + dt5*((2.+gratio)*(v_dt(npx-1,j,k)+v_dt(npx,j,k)) &
                     -(v_dt(npx-2,j,k)+v_dt(npx+1,j,k)))/(1.+gratio)
       enddo
    endif

    endif   ! end grid_type

    enddo         ! k-loop

  end subroutine update2d_dwinds_phys


end module fv_update_phys_mod


module nh_core_mod

! Notes:
! Using k_top=2 to treat the top layer hydrostatically so that delz will
! be computed using hydrostatic balance (instead of the update by
! advection of height using extrapolated winds at the model top)
!
! To do list:
! include moisture effect in pt
!------------------------------

   use fms_mod, only: error_mesg, FATAL

   implicit none
   private

   public Riem_Solver, Riem_Solver_C, update_dz_c, update_dz_d
   real, parameter:: dz_max = -0.5               ! (meters)

CONTAINS 

  subroutine update_dz_c(is, ie, js, je, km, ng, area, zh, ut, vt, dz_in, dz_out, wk)
! !INPUT PARAMETERS:
  integer, intent(in):: is, ie, js, je, ng, km
  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: ut, vt, zh
  real, intent(in ):: area(is-ng:ie+ng,js-ng:je+ng)
  real, intent(in ):: dz_in (is:ie,js:je,km) 
  real, intent(out):: dz_out(is:ie,js:je,km) 
  real, intent(out):: wk(is-ng:ie+ng,js-ng:je+ng,km+1)  ! work array
! Local Work array:
  real, dimension(is:ie+1,js:je  ):: xfx, fx
  real, dimension(is:ie  ,js:je+1):: yfx, fy
  integer  i, j, k

  call error_mesg('update_dz_c','The null version of update_dz_c should not be called.',FATAL)

  end subroutine update_dz_c



  subroutine update_dz_d(hord, is, ie, js, je, km, ng, npx, npy, area, zh, crx, cry, xfx, yfx, delz, wk, delp, n_sponge)

  integer, intent(in):: is, ie, js, je, ng, km, npx, npy
  integer, intent(in):: hord, n_sponge
  real, intent(in)   :: area(is-ng:ie+ng,js-ng:je+ng)
  real, intent(inout) ::  zh(is-ng:ie+ng,js-ng:je+ng,km)
  real, intent(inout) ::delz(is:ie,js:je,km)
  real, intent(inout) ::delp(is-ng:ie+ng,js-ng:je+ng,km)
  real, intent(inout), dimension(is:ie+1,js-ng:je+ng,km):: crx, xfx
  real, intent(inout), dimension(is-ng:ie+ng,js:je+1,km):: cry, yfx
  real, intent(  out) ::   wk(is:ie,js:je,km)  ! work array
!-----------------------------------------------------
! Local array:
  real, dimension(is:   ie+1, js-ng:je+ng):: crx_adv, xfx_adv
  real, dimension(is-ng:ie+ng,js:   je+1 ):: cry_adv, yfx_adv
  real, dimension(is:ie+1,js:je  ):: fx
  real, dimension(is:ie  ,js:je+1):: fy
  real  delx(is:ie+1,km), dely(is-ng:ie+ng,km)
  real :: ra_x(is:ie,js-ng:je+ng)
  real :: ra_y(is-ng:ie+ng,js:je)
!--------------------------------------------------------------------
  integer  i, j, k, iord, isd, ied, jsd, jed, lm

  call error_mesg('update_dz_d','The null version of update_dz_d should not be called.',FATAL)

  end subroutine update_dz_d


  subroutine Riem_Solver_C(dt, is, ie, js, je, km, ng, akap, cp, ptop, hs, w, delz, pt, delp, gz, pk, ip)

   integer, intent(in):: is, ie, js, je, ng, km
   integer, intent(in):: ip       ! ip==1 pk is full pressure
   real, intent(in):: dt,  akap, cp, ptop
   real, intent(in):: delz(is:ie,js:je,km)
   real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delp
   real, intent(in)::       hs(is-ng:ie+ng,js-ng:je+ng)
   real, intent(inout):: w(is-ng:ie+ng,js-ng:je+ng,km)
! OUTPUT PARAMETERS 
   real, intent(out), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: gz, pk
! Local:
  real, dimension(is:ie,km  ):: pm, dm, dz2
  real, dimension(is:ie,km+1):: pem, pk2
  real gama, rgrav, ptk
  integer i, j, k
  integer m_split_c

  call error_mesg('Riem_Solver_C','The null version of Riem_Solver_C should not be called.',FATAL)

  end subroutine Riem_Solver_C


  subroutine Riem_Solver(dt, is, ie, js, je, km, ng, akap, cp, ptop, hs, peln, w, delz, pt, delp, gz, pkc, pk, pe, last_call, ip)
!--------------------------------------------
! !OUTPUT PARAMETERS
! Ouput: gz: grav*height at edges
!        pe: full     hydrostatic pressure
!       pkc: full non-hydrostatic pressure
!--------------------------------------------
   integer, intent(in):: is, ie, js, je, km, ng
   integer, intent(in):: ip      ! ip==0 pkc is perturbation pressure
   real, intent(in):: dt         ! the BIG horizontal Lagrangian time step
   real, intent(in):: akap, cp, ptop
   real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng)
   logical, intent(in):: last_call
   real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: w, delp, pt
   real, intent(inout):: delz(is:ie,js:je,km)
   real, intent(out), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: gz, pkc
   real, intent(out):: pk(is:ie,js:je,km+1)
   real, intent(out):: pe(is-1:ie+1,km+1,js-1:je+1)
   real, intent(out):: peln(is:ie,km+1,js:je)           ! ln(pe)
! Local:
  real, dimension(is:ie,km):: pm, dm, dz2
  real :: pem(is:ie,km+1)
  real gama, rgrav, ptk
  integer i, j, k

  call error_mesg('Riem_Solver','The null version of Riem_Solver should not be called.',FATAL)

  end subroutine Riem_Solver


end module nh_core_mod



 module sw_core_mod

 use fv_mp_mod,         only: ng, is,js,ie,je, isd,jsd,ied,jed,  &
                              mp_corner_comm, domain
 use fv_grid_tools_mod, only: npx=>npx_g,npy=>npy_g, cosa, sina,  &
                              rdxc, rdyc, dx,dy, dxc,dyc, dxa,dya,  &
                              rdxa, rdya, area, area_c, rarea, rarea_c, rdx, rdy
 use fv_grid_tools_mod, only: grid_type
 use tp_core_mod,       only: fv_tp_2d, pert_ppm, copy_corners
 use fv_grid_utils_mod, only: edge_vect_s,edge_vect_n,edge_vect_w,edge_vect_e,  &
                              sw_corner, se_corner, ne_corner, nw_corner,       &
                              cosa_u, cosa_v, cosa_s, sina_s, sina_u, sina_v,   &
                              rsin_u, rsin_v, rsin_v, rsina, ec1, ec2, ew, es,  &
                              big_number, da_min_c, da_min, fC, f0,   &
                              rsin2, divg_u, divg_v, Gnomonic_grid
 use fv_mp_mod, only: fill_corners, XDir, YDir

#ifdef SW_DYNAMICS
 use test_cases_mod,   only: test_case
#endif

 implicit none

  real, parameter:: r3 =   1./3.
  real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28.
  real, parameter:: s11=11./14., s13=-13./14., s14=4./7., s15=3./14.
!----------------------
! PPM volume mean form:
!----------------------
  real, parameter:: p1 =  7./12.     ! 0.58333333
  real, parameter:: p2 = -1./12.
!----------------------------
! 4-pt Lagrange interpolation
!----------------------------
  real, parameter:: a1 =  0.5625
  real, parameter:: a2 = -0.0625
!----------------------------------------------
! volume-conserving cubic with 2nd drv=0 at end point:
  real, parameter:: c1 = -2./14.
  real, parameter:: c2 = 11./14.
  real, parameter:: c3 =  5./14.
! 3-pt off-center intp formular:
! real, parameter:: c1 = -0.125
! real, parameter:: c2 =  0.75
! real, parameter:: c3 =  0.375
!----------------------------------------------
! scheme 2.1: perturbation form
  real, parameter:: b1 =   1./30.
  real, parameter:: b2 = -13./60.
  real, parameter:: b3 = -13./60.
  real, parameter:: b4 =  0.45
  real, parameter:: b5 = -0.05

      private
      public :: c_sw, d_sw, d2a2c, divergence_corner

      contains

 
   subroutine c_sw(delpc, delp, ptc, pt, u,v, w, uc,vc, ua,va, wc,  &
                   ut, vt, dt2, hydrostatic, dord4)
      real, intent(INOUT), dimension(isd:ied,  jsd:jed+1):: u, vc
      real, intent(INOUT), dimension(isd:ied+1,jsd:jed  ):: v, uc
      real, intent(INOUT), dimension(isd:ied, jsd:jed):: delp,  pt,  ua, va, w
      real, intent(OUT  ), dimension(isd:ied, jsd:jed):: delpc, ptc, ut, vt, wc
      real,    intent(IN) :: dt2
      logical, intent(IN) :: hydrostatic
      logical, intent(IN) :: dord4
! Local:
      real, dimension(is-1:ie+1,js-1:je+1):: vort, ke
      real, dimension(is-1:ie+2,js-1:je+1):: fx, fx1, fx2
      real, dimension(is-1:ie+1,js-1:je+2):: fy, fy1, fy2
      real :: dt4
      integer :: i,j, is2, ie1
      integer iep1, jep1

#ifdef FIX_C_BOUNDARY 
      iep1 = ie;   jep1 = je
#else
      iep1 = ie+1; jep1 = je+1
#endif

      call d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4)  
!     call d2a2c_vect_v2(u, v, ua, va, uc, vc, ut, vt)

      do j=js-1,jep1
         do i=is-1,iep1+1
            ut(i,j) = dt2*ut(i,j)*dy(i,j)*sina_u(i,j)
         enddo
      enddo
      do j=js-1,jep1+1
         do i=is-1,iep1
            vt(i,j) = dt2*vt(i,j)*dx(i,j)*sina_v(i,j)
         enddo
      enddo

!----------------
! Transport delp:
!----------------
! Xdir:
      if (grid_type < 3) call fill2_4corners(delp, pt, 1)
      if ( hydrostatic ) then
#ifdef SW_DYNAMICS
           do j=js-1,jep1
              do i=is-1,iep1+1      
                 if ( ut(i,j) > 0. ) then
                      fx1(i,j) = delp(i-1,j)
                 else
                      fx1(i,j) = delp(i,j)
                 endif
                 fx1(i,j) =  ut(i,j)*fx1(i,j)
              enddo
           enddo
#else
           do j=js-1,jep1
              do i=is-1,iep1+1
                 if ( ut(i,j) > 0. ) then
                      fx1(i,j) = delp(i-1,j)
                       fx(i,j) =   pt(i-1,j)
                 else
                      fx1(i,j) = delp(i,j)
                       fx(i,j) =   pt(i,j)
                 endif
                 fx1(i,j) =  ut(i,j)*fx1(i,j)
                  fx(i,j) = fx1(i,j)* fx(i,j)
              enddo
           enddo
#endif
      else
           if (grid_type < 3) call fill_4corners(w, 1)
           do j=js-1,je+1
              do i=is-1,ie+2      
                 if ( ut(i,j) > 0. ) then
                      fx1(i,j) = delp(i-1,j)
                       fx(i,j) =   pt(i-1,j)
                      fx2(i,j) =    w(i-1,j)
                 else
                      fx1(i,j) = delp(i,j)
                       fx(i,j) =   pt(i,j)
                      fx2(i,j) =    w(i,j)
                 endif
                 fx1(i,j) =  ut(i,j)*fx1(i,j)
                  fx(i,j) = fx1(i,j)* fx(i,j)
                 fx2(i,j) = fx1(i,j)*fx2(i,j)
              enddo
           enddo
      endif

! Ydir:
      if (grid_type < 3) call fill2_4corners(delp, pt, 2)
      if ( hydrostatic ) then
           do j=js-1,jep1+1
              do i=is-1,iep1      
                 if ( vt(i,j) > 0. ) then
                      fy1(i,j) = delp(i,j-1)
                       fy(i,j) =   pt(i,j-1)
                 else
                      fy1(i,j) = delp(i,j)
                       fy(i,j) =   pt(i,j)
                 endif
                 fy1(i,j) =  vt(i,j)*fy1(i,j)
                  fy(i,j) = fy1(i,j)* fy(i,j)
              enddo
           enddo
           do j=js-1,jep1
              do i=is-1,iep1    
                 delpc(i,j) = delp(i,j) + (fx1(i,j)-fx1(i+1,j)+fy1(i,j)-fy1(i,j+1))*rarea(i,j)
#ifdef SW_DYNAMICS
                   ptc(i,j) = pt(i,j)
#else
                   ptc(i,j) = (pt(i,j)*delp(i,j) +   &
                              (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/delpc(i,j)
#endif
              enddo
           enddo
      else
           if (grid_type < 3) call fill_4corners(w, 2)
           do j=js-1,je+2
              do i=is-1,ie+1      
                 if ( vt(i,j) > 0. ) then
                      fy1(i,j) = delp(i,j-1)
                       fy(i,j) =   pt(i,j-1)
                      fy2(i,j) =    w(i,j-1)
                 else
                      fy1(i,j) = delp(i,j)
                       fy(i,j) =   pt(i,j)
                      fy2(i,j) =    w(i,j)
                 endif
                 fy1(i,j) =  vt(i,j)*fy1(i,j)
                  fy(i,j) = fy1(i,j)* fy(i,j)
                 fy2(i,j) = fy1(i,j)*fy2(i,j)
              enddo
           enddo
           do j=js-1,je+1
              do i=is-1,ie+1    
                 delpc(i,j) = delp(i,j) + (fx1(i,j)-fx1(i+1,j)+fy1(i,j)-fy1(i,j+1))*rarea(i,j)
                   ptc(i,j) = (pt(i,j)*delp(i,j) +   &
                              (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/delpc(i,j)
                    wc(i,j) = (w(i,j)*delp(i,j) + (fx2(i,j)-fx2(i+1,j) +    &
                               fy2(i,j)-fy2(i,j+1))*rarea(i,j))/delpc(i,j)
              enddo
           enddo
      endif

!------------
! Compute KE:
!------------
      do j=js-1,jep1
         do i=is-1,iep1
            if ( ua(i,j) > 0. ) then
                 if ( i==1 ) then
                    ke(1,j) = uc(1,  j)*sina_u(1,  j)+v(1,  j)*cosa_u(1,  j)
                 elseif ( i==npx ) then
                    ke(i,j) = uc(npx,j)*sina_u(npx,j)-v(npx,j)*cosa_u(npx,j)
                 else
                    ke(i,j) = uc(i,j)
                 endif
            else
                 if ( i==0 ) then
                    ke(0,j) = uc(1,  j)*sina_u(1,  j)-v(1,  j)*cosa_u(1,  j)
                 elseif ( i==(npx-1) ) then
                    ke(i,j) = uc(npx,j)*sina_u(npx,j)+v(npx,j)*cosa_u(npx,j)
                 else
                    ke(i,j) = uc(i+1,j)
                 endif
            endif
         enddo
      enddo
      do j=js-1,jep1
         do i=is-1,iep1
            if ( va(i,j) > 0. ) then
               if ( j==1 ) then
                  vort(i,1) = vc(i,  1)*sina_v(i,  1)+u(i,  1)*cosa_v(i,  1)
               elseif ( j==npy ) then
                  vort(i,j) = vc(i,npy)*sina_v(i,npy)-u(i,npy)*cosa_v(i,npy)
               else
                  vort(i,j) = vc(i,j)
               endif
            else
               if ( j==0 ) then
                  vort(i,0) = vc(i,  1)*sina_v(i,  1)-u(i,  1)*cosa_v(i,  1)
               elseif ( j==(npy-1) ) then
                  vort(i,j) = vc(i,npy)*sina_v(i,npy)+u(i,npy)*cosa_v(i,npy)
               else
                  vort(i,j) = vc(i,j+1)
               endif
            endif
         enddo
      enddo

      dt4 = 0.5*dt2
      do j=js-1,jep1
         do i=is-1,iep1
            ke(i,j) = dt4*(ua(i,j)*ke(i,j) + va(i,j)*vort(i,j)) 
         enddo
      enddo

!------------------------------
! Compute circulation on C grid
!------------------------------
! To consider using true co-variant winds at face edges?
#ifdef TEST_EDGE
      do j=js-1,je+1
         do i=is,ie+1
            fx(i,j) = uc(i,j) * dxc(i,j)
         enddo
      enddo
      do j=js,je+1
         do i=is-1,ie+1
            fy(i,j) = vc(i,j) * dyc(i,j)
         enddo
      enddo
#else
      is2 = max(2,is); ie1 = min(npx-1,ie+1)
      do j=js-1,je+1
         do i=is2,ie1
            fx(i,j) = uc(i,j)*dxc(i,j)
         enddo
         if(  is   ==  1 ) fx(1,  j) = uc(1,  j)*sina_u(1,  j)*dxc(1,  j)
         if( (ie+1)==npx ) fx(npx,j) = uc(npx,j)*sina_u(npx,j)*dxc(npx,j)
      enddo

      do j=js,je+1
         if( j==1 .or. j==npy ) then
           do i=is-1,ie+1
              fy(i,j) = vc(i,j)*sina_v(i,j)*dyc(i,j)
           enddo
         else
           do i=is-1,ie+1
              fy(i,j) = vc(i,j)*dyc(i,j)
           enddo
         endif
      enddo
#endif
      do j=js,je+1
         do i=is,ie+1
            vort(i,j) =  fx(i,j-1) - fx(i,j) - fy(i-1,j) + fy(i,j)
         enddo
      enddo

! Remove the extra term at the corners:
      if ( sw_corner ) vort(1,    1) = vort(1,    1) + fy(0,   1)
      if ( se_corner ) vort(npx  ,1) = vort(npx,  1) - fy(npx, 1)
      if ( ne_corner ) vort(npx,npy) = vort(npx,npy) - fy(npx,npy)
      if ( nw_corner ) vort(1,  npy) = vort(1,  npy) + fy(0,  npy)

!----------------------------
! Compute absolute vorticity
!----------------------------
      do j=js,je+1
         do i=is,ie+1
            vort(i,j) = fC(i,j) + rarea_c(i,j) * vort(i,j)
         enddo
      enddo

!----------------------------------
! Transport absolute vorticity:
!----------------------------------
      do j=js,je
         do i=is,iep1
            if ( i==1 .or. i==npx ) then
                 fy1(i,j) = dt2*v(i,j)*sina_u(i,j)
            else
                 fy1(i,j) = dt2*(v(i,j)-uc(i,j)*cosa_u(i,j))/sina_u(i,j)
            endif
            if ( fy1(i,j) > 0. ) then
                 fy(i,j) = vort(i,j)
            else
                 fy(i,j) = vort(i,j+1)
            endif
          enddo
      enddo

      do j=js,jep1
         if ( j==1 .or. j==npy ) then
            do i=is,ie
               fx1(i,j) = dt2*u(i,j)*sina_v(i,j)
               if ( fx1(i,j) > 0. ) then
                    fx(i,j) = vort(i,j)
               else
                    fx(i,j) = vort(i+1,j)
               endif
            enddo
         else
            do i=is,ie
               fx1(i,j) = dt2*(u(i,j)-vc(i,j)*cosa_v(i,j))/sina_v(i,j)
               if ( fx1(i,j) > 0. ) then
                    fx(i,j) = vort(i,j)
               else
                    fx(i,j) = vort(i+1,j)
               endif
            enddo
         endif
      enddo

! Update time-centered winds on the C-Grid
      do j=js,je
         do i=is,iep1
            uc(i,j) = uc(i,j) + fy1(i,j)*fy(i,j) + rdxc(i,j)*(ke(i-1,j)-ke(i,j))
         enddo
      enddo
      do j=js,jep1
         do i=is,ie
            vc(i,j) = vc(i,j) - fx1(i,j)*fx(i,j) + rdyc(i,j)*(ke(i,j-1)-ke(i,j))
         enddo
      enddo

   end subroutine c_sw



!-------------------------------------------------------------------------------
!
!     d_sw :: D-Grid Shallow Water Routine
!
   subroutine d_sw(delpc, delp,  ptc,   pt, u,  v, w, uc,vc, &
                   ua, va, divg_d, xflux, yflux, cx, cy,              &
                   crx_adv, cry_adv,  xfx_adv, yfx_adv,      &
                   zvir, sphum, nq, q, k, km, inline_q,  &
                   pkz, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord,   &
                   dddmp, d2_bg, d4_bg, vtdm4, d_con, hydrostatic, ppm_limiter)

      integer, intent(IN):: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp
      integer, intent(IN):: nord   ! nord=1 (del-4) or 3 (del-8)
      integer, intent(IN):: sphum, nq, k, km
      real   , intent(IN):: dt, dddmp, d2_bg, d4_bg, vtdm4, d_con
      real   , intent(IN):: zvir
      real   , intent(IN):: ppm_limiter
      real, intent(in):: pkz(is:ie,js:je)
      real, intent(inout):: divg_d(isd:ied+1,jsd:jed+1) ! divergence
      real, intent(INOUT), dimension(isd:ied,  jsd:jed):: delp, pt, ua, va, w
      real, intent(INOUT), dimension(isd:ied  ,jsd:jed+1):: u, vc
      real, intent(INOUT), dimension(isd:ied+1,jsd:jed  ):: v, uc
      real, intent(INOUT):: q(isd:ied,jsd:jed,km,nq)
      real, intent(OUT),   dimension(isd:ied,  jsd:jed)  :: delpc, ptc
! The flux capacitors:
      real, intent(INOUT):: xflux(is:ie+1,js:je  )
      real, intent(INOUT):: yflux(is:ie  ,js:je+1)
!------------------------
      real, intent(INOUT)::    cx(is:ie+1,jsd:jed  )
      real, intent(INOUT)::    cy(isd:ied,js:je+1)
      logical, intent(IN):: hydrostatic
      logical, intent(IN):: inline_q
      real, intent(OUT), dimension(is:ie+1,jsd:jed):: crx_adv, xfx_adv
      real, intent(OUT), dimension(isd:ied,js:je+1):: cry_adv, yfx_adv
! Local:
      real :: ut(isd:ied+1,jsd:jed)
      real :: vt(isd:ied,  jsd:jed+1)
      real, dimension(is:ie+1,js:je+1):: ub, vb
      real :: wk(isd:ied,jsd:jed) !  work array
      real :: vt2(is-1:ie+1,js-1:je+1) !  work array
      real :: ke(isd:ied+1,jsd:jed+1) !  needs this for corner_comm
      real :: vort(isd:ied,jsd:jed)     ! Vorticity
      real ::   fx(is:ie+1,js:je  )  ! 1-D X-direction Fluxes
      real ::   fy(is:ie  ,js:je+1)  ! 1-D Y-direction Fluxes
      real :: ra_x(is:ie,jsd:jed)
      real :: ra_y(isd:ied,js:je)
      real :: gx(is:ie+1,js:je  )  ! work x-dir flux
      real :: gy(is:ie  ,js:je+1)  ! work Y-dir flux array
      logical :: fill_c

      real :: dt4, dt5, dt6
      real :: damp, damp2, damp4, dd8, u2, v2, du2, dv2
      integer :: i,j, is2, ie1, js2, je1, n, nt, n2, iq


#ifdef SW_DYNAMICS
      if ( test_case == 1 ) then
        do j=jsd,jed
           do i=is,ie+1
              xfx_adv(i,j) = dt * uc(i,j) / sina_u(i,j)
              if (xfx_adv(i,j) > 0.) then
                  crx_adv(i,j) = xfx_adv(i,j) * rdxa(i-1,j)
              else
                  crx_adv(i,j) = xfx_adv(i,j) * rdxa(i,j)
              endif
              xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sina_u(i,j)
           enddo
        enddo

        do j=js,je+1
           do i=isd,ied
              yfx_adv(i,j) = dt * vc(i,j) / sina_v(i,j)
              if (yfx_adv(i,j) > 0.) then
                 cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j-1)
              else
                 cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j)
              endif
              yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sina_v(i,j)
           enddo
        enddo
      else
#endif


     if ( grid_type < 3 ) then
! Interior:
        do j=jsd,jed
           if(j/=0 .and. j/=1 .and. j/=(npy-1) .and. j/=npy) then
             do i=is-1,ie+2
                ut(i,j) = ( uc(i,j) - 0.25 * cosa_u(i,j) *     &
                    (vc(i-1,j)+vc(i,j)+vc(i-1,j+1)+vc(i,j+1)))*rsin_u(i,j)
             enddo
           endif
        enddo

        do j=js-1,je+2
           if( j/=1 .and. j/=npy ) then
              do i=isd,ied
                 vt(i,j) = ( vc(i,j) - 0.25 * cosa_v(i,j) *     &
                    (uc(i,j-1)+uc(i+1,j-1)+uc(i,j)+uc(i+1,j)))*rsin_v(i,j)
              enddo
           endif
        enddo

! West edge:
        if ( is==1 ) then
           do j=jsd,jed
              ut(1,j) = uc(1,j) * rsin_u(1,j)
           enddo
           do j=max(3,js), min(npy-2,je+1)
!             vt(0,j) = vc(0,j) - 0.25*cosa_v(0,j)*   &
              vt(0,j) = vc(0,j) + 0.25*cosa_v(1,j)*   &
                       (ut(0,j-1)+ut(1,j-1)+ut(0,j)+ut(1,j))
              vt(1,j) = vc(1,j) - 0.25*cosa_v(1,j)*   &
                       (ut(1,j-1)+ut(2,j-1)+ut(1,j)+ut(2,j))
           enddo
        endif

! East edge:
        if ( (ie+1)==npx ) then
           do j=jsd,jed
              ut(npx,j) = uc(npx,j) * rsin_u(npx,j)
           enddo
           do j=max(3,js), min(npy-2,je+1)
              vt(npx-1,j) = vc(npx-1,j) - 0.25*cosa_v(npx-1,j)*   &
                           (ut(npx-1,j-1)+ut(npx,j-1)+ut(npx-1,j)+ut(npx,j))
!             vt(npx,j) = vc(npx,j) - 0.25*cosa_v(npx,j)*   &
              vt(npx,j) = vc(npx,j) + 0.25*cosa_v(npx-1,j)*   &
                         (ut(npx,j-1)+ut(npx+1,j-1)+ut(npx,j)+ut(npx+1,j))
           enddo
        endif

! South (Bottom) edge:
        if ( js==1 ) then
           do i=isd,ied
              vt(i,1) = vc(i,1) * rsin_v(i,1)
           enddo
           do i=max(3,is),min(npx-2,ie+1)
!             ut(i,0) = uc(i,0) - 0.25*cosa_u(i,0)*   &
              ut(i,0) = uc(i,0) + 0.25*cosa_u(i,1)*   &
                       (vt(i-1,0)+vt(i,0)+vt(i-1,1)+vt(i,1))
              ut(i,1) = uc(i,1) - 0.25*cosa_u(i,1)*   &
                       (vt(i-1,1)+vt(i,1)+vt(i-1,2)+vt(i,2))
           enddo
        endif

! North edge:
        if ( (je+1)==npy ) then
           do i=isd,ied
              vt(i,npy) = vc(i,npy) * rsin_v(i,npy)
           enddo
           do i=max(3,is),min(npx-2,ie+1)
              ut(i,npy-1) = uc(i,npy-1) - 0.25*cosa_u(i,npy-1)*   &
                           (vt(i-1,npy-1)+vt(i,npy-1)+vt(i-1,npy)+vt(i,npy))
!             ut(i,npy) = uc(i,npy) - 0.25*cosa_u(i,npy)*   &
              ut(i,npy) = uc(i,npy) + 0.25*cosa_u(i,npy-1)*   &
                         (vt(i-1,npy)+vt(i,npy)+vt(i-1,npy+1)+vt(i,npy+1))
           enddo
        endif

        if( sw_corner ) then
            damp = 1. / (1.-0.0625*cosa_u(2,1)*cosa_v(1,2))
            ut(2,0) = (uc(2,0)-0.25*cosa_u(2,0)*(vt(1,1)+vt(2,1)+vt(2,0)+vc(1,0) -   &
                      0.25*cosa_v(1,0)*(ut(1,0)+ut(1,-1)+ut(2,-1))) ) * damp
            ut(2,1) = (uc(2,1)-0.25*cosa_u(2,1)*(vt(1,1)+vt(2,1)+vt(2,2)+vc(1,2) -   &
                      0.25*cosa_v(1,2)*(ut(1,1)+ut(1,2)+ut(2,2))) ) * damp
            vt(1,2) = (vc(1,2)-0.25*cosa_v(1,2)*(ut(1,1)+ut(1,2)+ut(2,2)+uc(2,1) -   &
                      0.25*cosa_u(2,1)*(vt(1,1)+vt(2,1)+vt(2,2))) ) * damp
            vt(0,2) = (vc(0,2)-0.25*cosa_v(0,2)*(ut(1,1)+ut(1,2)+ut(0,2)+uc(0,1) -   &
                      0.25*cosa_u(0,1)*(vt(0,1)+vt(-1,1)+vt(-1,2))) ) * damp
        endif

        if( se_corner ) then
            damp = 1. / (1. - 0.0625*cosa_u(npx-1,1)*cosa_v(npx-1,2))
            ut(npx-1,0) = ( uc(npx-1,0)+0.25*cosa_u(npx-1,1)*(   &
                            vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,0)+vc(npx-1,0) +   &
                      0.25*cosa_v(npx-1,2)*(ut(npx,0)+ut(npx,-1)+ut(npx-1,-1))) ) * damp
            ut(npx-1,1) = ( uc(npx-1,1)-0.25*cosa_u(npx-1,1)*(  &
                            vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,2)+vc(npx-1,2) -   &
                      0.25*cosa_v(npx-1,2)*(ut(npx,1)+ut(npx,2)+ut(npx-1,2))) ) * damp
            vt(npx-1,2) = ( vc(npx-1,2)-0.25*cosa_v(npx-1,2)*(  &
                            ut(npx,1)+ut(npx,2)+ut(npx-1,2)+uc(npx-1,1) -   &
                      0.25*cosa_u(npx-1,1)*(vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,2))) ) * damp
            vt(npx,  2) = ( vc(npx,2)+0.25*cosa_v(npx-1,2)*(  &
                            ut(npx,1)+ut(npx,2)+ut(npx+1,2)+uc(npx+1,1) +   &
                      0.25*cosa_u(npx-1,1)*(vt(npx,1)+vt(npx+1,1)+vt(npx+1,2))) ) * damp
        endif

        if( ne_corner ) then
            damp = 1. / (1. - 0.0625*cosa_u(npx-1,npy-1)*cosa_v(npx-1,npy-1))
            ut(npx-1,npy) = ( uc(npx-1,npy)+0.25*cosa_u(npx-1,npy-1)*(   &
                              vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy+1)+vc(npx-1,npy+1) +   &
                0.25*cosa_v(npx-1,npy-1)*(ut(npx,npy)+ut(npx,npy+1)+ut(npx-1,npy+1))) ) * damp
            ut(npx-1,npy-1) = ( uc(npx-1,npy-1)-0.25*cosa_u(npx-1,npy-1)*(  &
                                vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy-1)+vc(npx-1,npy-1) -  &
                0.25*cosa_v(npx-1,npy-1)*(ut(npx,npy-1)+ut(npx,npy-2)+ut(npx-1,npy-2))) ) * damp
            vt(npx-1,npy-1) = ( vc(npx-1,npy-1)-0.25*cosa_v(npx-1,npy-1)*(  &
                                ut(npx,npy-1)+ut(npx,npy-2)+ut(npx-1,npy-2)+uc(npx-1,npy-1) -  &
                0.25*cosa_u(npx-1,npy-1)*(vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy-1))) ) * damp
            vt(npx,  npy-1) = ( vc(npx,npy-1)+0.25*cosa_v(npx-1,npy-1)*(   &
                                ut(npx,npy-1)+ut(npx,npy-2)+ut(npx+1,npy-2)+uc(npx+1,npy-1) +   &
                0.25*cosa_u(npx-1,npy-1)*(vt(npx,npy)+vt(npx+1,npy)+vt(npx+1,npy-1))) ) * damp
        endif

        if( nw_corner ) then
            damp = 1. / (1. - 0.0625*cosa_u(2,npy-1)*cosa_v(1,npy-1))
            ut(2,npy) = ( uc(2,npy)+0.25*cosa_u(2,npy-1)*(   &
                          vt(1,npy)+vt(2,npy)+vt(2,npy+1)+vc(1,npy+1) +   &
                      0.25*cosa_v(1,npy-1)*(ut(1,npy)+ut(1,npy+1)+ut(2,npy+1))) ) * damp
            ut(2,npy-1) = ( uc(2,npy-1)-0.25*cosa_u(2,npy-1)*(  &
                            vt(1,npy)+vt(2,npy)+vt(2,npy-1)+vc(1,npy-1) -   &
                      0.25*cosa_v(1,npy-1)*(ut(1,npy-1)+ut(1,npy-2)+ut(2,npy-2))) ) * damp
            vt(1,npy-1) = ( vc(1,npy-1)-0.25*cosa_v(1,npy-1)*(  &
                            ut(1,npy-1)+ut(1,npy-2)+ut(2,npy-2)+uc(2,npy-1) -   &
                      0.25*cosa_u(2,npy-1)*(vt(1,npy)+vt(2,npy)+vt(2,npy-1))) ) * damp
            vt(0,npy-1) = ( vc(0,npy-1)+0.25*cosa_v(1,npy-1)*(  &
                            ut(1,npy-1)+ut(1,npy-2)+ut(0,npy-2)+uc(0,npy-1) +   &
                      0.25*cosa_u(2,npy-1)*(vt(0,npy)+vt(-1,npy)+vt(-1,npy-1))) ) * damp
        endif
 
     else
! grid_type >= 3
        do j=jsd,jed
           do i=is-1,ie+2
              ut(i,j) =  uc(i,j)
           enddo
        enddo
        
        do j=js-1,je+2
           do i=isd,ied
              vt(i,j) = vc(i,j) 
           enddo
        enddo
     endif      ! end grid_type choices

        do j=jsd,jed
           do i=is,ie+1
              xfx_adv(i,j) = dt*ut(i,j)
           enddo
        enddo

        do j=js,je+1
           do i=isd,ied
              yfx_adv(i,j) = dt*vt(i,j)
           enddo
        enddo

! Compute E-W CFL number:
        do j=jsd,jed
           do i=is,ie+1
              if (xfx_adv(i,j) > 0.) then
                  crx_adv(i,j) = xfx_adv(i,j) * rdxa(i-1,j)
              else
                  crx_adv(i,j) = xfx_adv(i,j) * rdxa(i,j)
              endif
           enddo
        enddo
        do j=jsd,jed
           do i=is,ie+1
              xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sina_u(i,j)
           enddo
        enddo


        do j=js,je+1
           do i=isd,ied
              if (yfx_adv(i,j) > 0.) then
                 cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j-1)
              else
                 cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j)
              endif
           enddo
        enddo
        do j=js,je+1
           do i=isd,ied
              yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sina_v(i,j)
           enddo
        enddo

#ifdef SW_DYNAMICS
      endif
#endif

      do j=jsd,jed
         do i=is,ie
            ra_x(i,j) = area(i,j) + xfx_adv(i,j) - xfx_adv(i+1,j)
         enddo
      enddo
      do j=js,je
         do i=isd,ied
            ra_y(i,j) = area(i,j) + yfx_adv(i,j) - yfx_adv(i,j+1)
         enddo
      enddo



      call fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy,  &
                    xfx_adv, yfx_adv, area, ra_x, ra_y)

#ifdef SW_DYNAMICS
        do j=js,je
           do i=is,ie
              delp(i,j) = delp(i,j) +    &
                         (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j)
              ptc(i,j) = pt(i,j)
           enddo
        enddo
#else

! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>>
        do j=jsd,jed
            do i=is,ie+1
              cx(i,j) = cx(i,j) + crx_adv(i,j)
           enddo
        enddo       
        do j=js,je
           do i=is,ie+1
              xflux(i,j) = xflux(i,j) + fx(i,j)
           enddo
        enddo       

        do j=js,je+1
           do i=isd,ied
              cy(i,j) = cy(i,j) + cry_adv(i,j)
           enddo
           do i=is,ie
              yflux(i,j) = yflux(i,j) + fy(i,j)
           enddo
        enddo 

        if ( .not. hydrostatic ) then
            call fv_tp_2d(w, crx_adv,cry_adv, npx, npy, hord_vt, ub, gy, &
                          xfx_adv,yfx_adv, area, ra_x, ra_y, mfx=fx, mfy=fy)
            do j=js,je
               do i=is,ie
                  w(i,j) = w(i,j)*delp(i,j) +             &
                           (ub(i,j)-ub(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j)
               enddo
            enddo
        endif

     if ( inline_q ) then
        do j=jsd,jed
           do i=isd,ied
              pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum))
           enddo
        enddo
     endif

        call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, ub, gy,  &
                      xfx_adv,yfx_adv, area, ra_x, ra_y, mfx=fx, mfy=fy)

     if ( inline_q ) then
        do j=js,je
           do i=is,ie
                wk(i,j) = delp(i,j)
              delp(i,j) = wk(i,j) + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j)
              pt(i,j) = (pt(i,j)*wk(i,j) +               &
                        (ub(i,j)-ub(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j))/delp(i,j)
           enddo
        enddo
        do iq=1,nq
           call fv_tp_2d(q(isd,jsd,k,iq), crx_adv,cry_adv, npx, npy, hord_tr, ub, gy,  &
                         xfx_adv,yfx_adv, area, ra_x, ra_y, mfx=fx, mfy=fy)
           do j=js,je
              do i=is,ie
                 q(i,j,k,iq) = (q(i,j,k,iq)*wk(i,j) +               &
                         (ub(i,j)-ub(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j))/delp(i,j)
              enddo
           enddo
        enddo
        do j=js,je
           do i=is,ie
              pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum))
           enddo
        enddo
     else
        do j=js,je
           do i=is,ie
              pt(i,j) = pt(i,j)*delp(i,j) +               &
                         (ub(i,j)-ub(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j)
              delp(i,j) = delp(i,j) +                     &
                         (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j)
              pt(i,j) = pt(i,j) / delp(i,j)
           enddo
        enddo
     endif

        if ( .not. hydrostatic ) then
            do j=js,je
               do i=is,ie
                  w(i,j) = w(i,j) / delp(i,j)
               enddo
            enddo
        endif
#endif

#ifdef SW_DYNAMICS
      if (test_case > 1) then
#endif

!----------------------
! Kinetic Energy Fluxes
!----------------------
! Compute B grid contra-variant components for KE:

      dt5 = 0.5 *dt
      dt4 = 0.25*dt

      is2 = max(2,is); ie1 = min(npx-1,ie+1)
      js2 = max(2,js); je1 = min(npy-1,je+1)

      if (grid_type < 3) then

         if ( js==1 ) then
            do i=is,ie+1
               vb(i,1) = dt5*(vt(i-1,1)+vt(i,1))       ! corner values are incorrect
            enddo
         endif
         
         do j=js2,je1
            do i=is2,ie1
               vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)-(uc(i,j-1)+uc(i,j))*cosa(i,j))*rsina(i,j)
            enddo
            if ( is==1 ) then
!               vb(1,j) = dt5*(vt(0,j)+vt(1,j)) 
! 2-pt extrapolation from both sides:
               vb(1,j) = dt4*(-vt(-1,j) + 3.*(vt(0,j)+vt(1,j)) - vt(2,j))
            endif
            if ( (ie+1)==npx ) then
!               vb(npx,j) = dt5*(vt(npx-1,j)+vt(npx,j))
               ! 2-pt extrapolation from both sides:
               vb(npx,j) = dt4*(-vt(npx-2,j) + 3.*(vt(npx-1,j)+vt(npx,j)) - vt(npx+1,j))
            endif
         enddo

         if ( (je+1)==npy ) then
            do i=is,ie+1
               vb(i,npy) = dt5*(vt(i-1,npy)+vt(i,npy)) ! corner values are incorrect
            enddo
         endif
         
      else
         do j=js,je+1
            do i=is,ie+1
               vb(i,j) = dt5*(vc(i-1,j)+vc(i,j))
            enddo
         enddo
      endif

      call ytp_v(vb, u, v, ub, hord_mt)

      do j=js,je+1
         do i=is,ie+1
            ke(i,j) = vb(i,j)*ub(i,j)
         enddo
      enddo

      if (grid_type < 3) then
         if ( is==1 ) then
            do j=js,je+1
               ub(1,j) = dt5*(ut(1,j-1)+ut(1,j))       ! corner values are incorrect
            enddo
         endif
         
         do j=js,je+1
            if ( j==1 .or. j==npy ) then
               do i=is2,ie1
!                  ub(i,j) = dt5*(ut(i,j-1)+ut(i,j))
! 2-pt extrapolation from both sides:
                  ub(i,j) = dt4*(-ut(i,j-2) + 3.*(ut(i,j-1)+ut(i,j)) - ut(i,j+1))
               enddo
            else
               do i=is2,ie1
                  ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)-(vc(i-1,j)+vc(i,j))*cosa(i,j))*rsina(i,j)
               enddo
            endif
         enddo
         
         if ( (ie+1)==npx ) then
            do j=js,je+1
               ub(npx,j) = dt5*(ut(npx,j-1)+ut(npx,j))       ! corner values are incorrect
            enddo
         endif
         
      else
         do j=js,je+1
            do i=is,ie+1
               ub(i,j) = dt5*(uc(i,j-1)+uc(i,j))
            enddo
         enddo
      endif

      call xtp_u(ub, u, v, vb, hord_mt)

      do j=js,je+1
         do i=is,ie+1
            ke(i,j) = 0.5*(ke(i,j) + ub(i,j)*vb(i,j))
         enddo
      enddo

!-----------------------------------------
! Fix KE at the 4 corners of the face:
!-----------------------------------------
   if ( Gnomonic_grid ) then
      dt6 = dt / 6.
      if ( sw_corner ) then
           ke(1,1) = dt6*( (ut(1,1) + ut(1,0)) * u(1,1) +  &
                           (vt(1,1) + vt(0,1)) * v(1,1) +  &
                           (ut(1,1) + vt(1,1)) * u(0,1) )
      endif
      if ( se_corner ) then
           i = npx
           ke(i,1) = dt6*( (ut(i,1) + ut(i,  0)) * u(i-1,1) + &
                           (vt(i,1) + vt(i-1,1)) * v(i,  1) + &
                           (ut(i,1) - vt(i-1,1)) * u(i,  1) )
      endif
      if ( ne_corner ) then
           i = npx;      j = npy
           ke(i,j) = dt6*( (ut(i,j  ) + ut(i,j-1)) * u(i-1,j) +  &
                           (vt(i,j  ) + vt(i-1,j)) * v(i,j-1) +  &
                           (ut(i,j-1) + vt(i-1,j)) * u(i,j  )  )
      endif
      if ( nw_corner ) then
           j = npy
           ke(1,j) = dt6*( (ut(1,  j) + ut(1,j-1)) * u(1,j  ) +  &
                           (vt(1,  j) + vt(0,  j)) * v(1,j-1) +  &
                           (ut(1,j-1) - vt(1,  j)) * u(0,j  )  )
      endif
   elseif (grid_type < 3) then
      call mp_corner_comm(ke, npx, npy) 
      if (sw_corner) ke(1,    1) = r3*(ke(2,      1)+ke(1,      2)+ke(0,      1))
      if (se_corner) ke(npx,  1) = r3*(ke(npx+1,  1)+ke(npx,    2)+ke(npx-1,  1))
      if (ne_corner) ke(npx,npy) = r3*(ke(npx+1,npy)+ke(npx,npy-1)+ke(npx-1,npy))
      if (nw_corner) ke(1,  npy) = r3*(ke(2,    npy)+ke(1,  npy-1)+ke(0,    npy))
   endif

! Compute vorticity:
       do j=jsd,jed+1
          do i=isd,ied
             vt(i,j) = u(i,j)*dx(i,j)
          enddo
       enddo
       do j=jsd,jed
          do i=isd,ied+1
             ut(i,j) = v(i,j)*dy(i,j)
          enddo
       enddo

! wk is "volume-mean" relative vorticity
       do j=jsd,jed
          do i=isd,ied
             wk(i,j) = rarea(i,j)*(vt(i,j)-vt(i,j+1)-ut(i,j)+ut(i+1,j))
          enddo
       enddo

!-----------------------------
! Compute divergence damping
!-----------------------------
   damp = dddmp * da_min_c

   if ( nord==0 ) then
!         area ~ dxb*dyb*sin(alpha)
      do j=js,je+1
         if ( j==1 .or. j==npy ) then
            do i=is-1,ie+1
               ptc(i,j) = u(i,j)*dyc(i,j)*sina_v(i,j)
            enddo
         else
            do i=is-1,ie+1
               ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j))   &
                        *dyc(i,j)*sina_v(i,j)
            enddo
         endif
      enddo

      do j=js-1,je+1
         do i=is2,ie1
            vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j))  &
                        *dxc(i,j)*sina_u(i,j)
         enddo
         if (  is   ==  1 ) vort(1,  j) = v(1,  j)*dxc(1,  j)*sina_u(1,  j)
         if ( (ie+1)==npx ) vort(npx,j) = v(npx,j)*dxc(npx,j)*sina_u(npx,j)
      enddo

      do j=js,je+1
         do i=is,ie+1
            delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j)
         enddo
      enddo

! Remove the extra term at the corners:
      if (sw_corner) delpc(1,    1) = delpc(1,    1) - vort(1,    0)
      if (se_corner) delpc(npx,  1) = delpc(npx,  1) - vort(npx,  0)
      if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy)
      if (nw_corner) delpc(1,  npy) = delpc(1,  npy) + vort(1,  npy)

      do j=js,je+1
         do i=is,ie+1
            delpc(i,j) = rarea_c(i,j)*delpc(i,j)
                damp = da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt)))
                vort(i,j) = damp*delpc(i,j)
                ke(i,j) = ke(i,j) + vort(i,j)
         enddo
      enddo
   else
!--------------------------
! Higher order divg damping
!--------------------------
     do j=js,je+1
        do i=is,ie+1
! Save divergence for external mode filter
           delpc(i,j) = divg_d(i,j)
        enddo
     enddo

     n2 = nord + 1
     do n=1,nord
        nt = nord-n

        fill_c = (nt/=0) .and. (grid_type<3) .and.               &
                 ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner )

        if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.)
        do j=js-nt,je+1+nt
           do i=is-1-nt,ie+1+nt
              vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j)
           enddo
        enddo

        if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.)
        do j=js-1-nt,je+1+nt
           do i=is-nt,ie+1+nt
              uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j)
           enddo
        enddo

        if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.)
        do j=js-nt,je+1+nt
           do i=is-nt,ie+1+nt
              divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j)
           enddo
        enddo

! Remove the extra term at the corners:
        if (sw_corner) divg_d(1,    1) = divg_d(1,    1) - uc(1,    0)
        if (se_corner) divg_d(npx,  1) = divg_d(npx,  1) - uc(npx,  0)
        if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy)
        if (nw_corner) divg_d(1,  npy) = divg_d(1,  npy) + uc(1,  npy)

        do j=js-nt,je+1+nt
           do i=is-nt,ie+1+nt
              divg_d(i,j) = divg_d(i,j)*rarea_c(i,j)
           enddo
        enddo
     enddo

     if ( dddmp<1.E-5) then
          vort = 0.
     else
! Compute "time-scale" for del-2 background damping
        do j=js-1,je+1
           do i=is-1,ie+1
              vt2(i,j) = wk(i,j)**2
           enddo
        enddo
        do j=js,je+1
           do i=is,ie+1
              vort(i,j) = dt*sqrt(delpc(i,j)**2 + 0.25*(vt2(i-1,j-1) +    &
                                  vt2(i,j-1) + vt2(i-1,j) + vt2(i,j)))
           enddo
        enddo
        if (sw_corner) vort(1,1) = dt*sqrt( delpc(1,1)**2 +   &
                       r3*(vt2(1,0) + vt2(0,1) + vt2(1,1)) )

        if (se_corner) vort(npx,1) = dt*sqrt( delpc(npx,1)**2 +   &
                       r3*(vt2(npx-1,0) + vt2(npx-1,1) + vt2(npx,1)) )

        if (ne_corner) vort(npx,npy) = dt*sqrt( delpc(npx,npy)**2 +   &
                       r3*(vt2(npx-1,npy-1) + vt2(npx,npy-1) + vt2(npx-1,npy)) )

        if (nw_corner) vort(1,npy) = dt*sqrt( delpc(1,npy)**2 +   &
                       r3*(vt2(0,npy-1) + vt2(1,npy-1) + vt2(1,npy)) )
     endif

     dd8 = ( da_min_c*d4_bg )**n2
     do j=js,je+1
        do i=is,ie+1
           damp2 =  da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j)))  ! del-2
           vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j)
             ke(i,j) = ke(i,j) + vort(i,j)
        enddo
     enddo

   endif

!----------------------------------
! Heating due to divergent damping:
!----------------------------------
   if ( d_con > 1.e-5 ) then
!  damp = 0.5*0.25*d_con
   damp = 0.25*d_con
   do j=js,je+1
      do i=is,ie
         ub(i,j) = (vort(i,j) - vort(i+1,j)) * rdx(i,j)  ! du
         gy(i,j) = u(i,j)*ub(i,j)                        ! u*du
      enddo
   enddo
   do j=js,je
      do i=is,ie+1
         vb(i,j) = (vort(i,j) - vort(i,j+1)) * rdy(i,j)  ! dv
         gx(i,j) = v(i,j)*vb(i,j)                        ! v*dv
      enddo
   enddo
   do j=js,je
      do i=is,ie
              u2 = u(i,j) + u(i,j+1)
             du2 = ub(i,j)+ub(i,j+1)
              v2 = v(i,j) + v(i+1,j)
             dv2 = vb(i,j)+vb(i+1,j)
! Total energy conserving:
! Convert lost KE due to divergence damping to "heat"
         pt(i,j) = pt(i,j) - damp*rsin2(i,j)/pkz(i,j)*(              &
                               (ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2)  &
                          + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j))   &
                          - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)  )
      enddo
   enddo
   endif

! Vorticity transport
    do j=jsd,jed
       do i=isd,ied
          vort(i,j) = wk(i,j) + f0(i,j)
       enddo
    enddo

    call fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy, &
                  xfx_adv,yfx_adv, area, ra_x, ra_y,                 &
                  ppm_fac=ppm_limiter, nord=nord, damp_c=vtdm4)
    do j=js,je+1
       do i=is,ie
          u(i,j) = vt(i,j) + ke(i,j) - ke(i+1,j) + fy(i,j)
       enddo
    enddo
    do j=js,je
       do i=is,ie+1
          v(i,j) = ut(i,j) + ke(i,j) - ke(i,j+1) - fx(i,j)
       enddo
    enddo

! damping applied to relative vorticity:
!   if ( vtdm4>0. ) then
!      damp4 = (vtdm4*da_min)**(nord+1)
!      call del6_flux(nord, npx, npy, damp4, wk, u, v)
!   endif

#ifdef SW_DYNAMICS
      endif ! test_case
#endif

 end subroutine d_sw


 subroutine divergence_corner(u, v, ua, va, divg_d, km)
 integer, intent(in):: km
 real, intent(in),  dimension(isd:ied,  jsd:jed+1,km):: u
 real, intent(in),  dimension(isd:ied+1,jsd:jed  ,km):: v
 real, intent(in),  dimension(isd:ied,jsd:jed,km):: ua, va
 real, intent(out), dimension(isd:ied+1,jsd:jed+1,km):: divg_d
! local
 real uf(is-2:ie+2,js-1:je+2)
 real vf(is-1:ie+2,js-2:je+2)
 integer i,j,k
 integer is2, ie1

 is2 = max(2,is); ie1 = min(npx-1,ie+1)

!$omp parallel do default(shared) private(i, j, k, uf, vf)
 do k=1,km
    if (grid_type==4) then
        do j=js-1,je+2
           do i=is-2,ie+2
              uf(i,j) = u(i,j,k)*dyc(i,j)
           enddo
        enddo
        do j=js-2,je+2
           do i=is-1,ie+2
              vf(i,j) = v(i,j,k)*dxc(i,j)
           enddo
        enddo
        do j=js-1,je+2
           do i=is-1,ie+2
              divg_d(i,j,k) = rarea_c(i,j)*(vf(i,j-1)-vf(i,j)+uf(i-1,j)-uf(i,j))
           enddo
        enddo
    else

! divg_u(i,j) = sina_v(i,j)*dyc(i,j)/dx(i,j)
    do j=js,je+1
       if ( j==1 .or. j==npy ) then
            do i=is-1,ie+1
               uf(i,j) = u(i,j,k)*dyc(i,j)*sina_v(i,j)
            enddo
       else
            do i=is-1,ie+1
               uf(i,j) = (u(i,j,k)-0.5*(va(i,j-1,k)+va(i,j,k))*cosa_v(i,j))   &
                        *dyc(i,j)*sina_v(i,j)
            enddo
       endif
    enddo

    do j=js-1,je+1
       do i=is2,ie1
          vf(i,j) = (v(i,j,k) - 0.5*(ua(i-1,j,k)+ua(i,j,k))*cosa_u(i,j))  &
                    *dxc(i,j)*sina_u(i,j)
       enddo
       if (  is   ==  1 ) vf(1,  j) = v(1,  j,k)*dxc(1,  j)*sina_u(1,  j)
       if ( (ie+1)==npx ) vf(npx,j) = v(npx,j,k)*dxc(npx,j)*sina_u(npx,j)
    enddo

    do j=js,je+1
       do i=is,ie+1
          divg_d(i,j,k) = vf(i,j-1) - vf(i,j) + uf(i-1,j) - uf(i,j)
       enddo
    enddo

! Remove the extra term at the corners:
    if (sw_corner) divg_d(1,    1,k) = divg_d(1,    1,k) - vf(1,    0)
    if (se_corner) divg_d(npx,  1,k) = divg_d(npx,  1,k) - vf(npx,  0)
    if (ne_corner) divg_d(npx,npy,k) = divg_d(npx,npy,k) + vf(npx,npy)
    if (nw_corner) divg_d(1,  npy,k) = divg_d(1,  npy,k) + vf(1,  npy)

    do j=js,je+1
       do i=is,ie+1
          divg_d(i,j,k) = rarea_c(i,j)*divg_d(i,j,k)
       enddo
    enddo

    endif

 enddo

 end subroutine divergence_corner



 subroutine xtp_u(c, u, v, flux, iord)

 real, INTENT(IN)  ::   u(isd:ied,jsd:jed+1)
 real, INTENT(IN)  ::   v(isd:ied+1,jsd:jed)
 real, INTENT(IN)  ::   c(is:ie+1,js:je+1)
 real, INTENT(out):: flux(is:ie+1,js:je+1)
 integer, INTENT(IN) :: iord
! Local
 real al(is-1:ie+2), dm(is-2:ie+2)
 real bl(is-1:ie+1)
 real br(is-1:ie+1)
 real dq(is-3:ie+2)
 real dl, dr, xt, pmp, lac, dqt, cfl
 real x0, x1
 integer i, j

 select case ( iord )

 case (1)

     do j=js,je+1
        do i=is,ie+1
           if( c(i,j)>0. ) then
               flux(i,j) = u(i-1,j)
           else
               flux(i,j) = u(i,j)
           endif
        enddo
     enddo

 case (2)

     do j=js,je+1

        do i=is-2,ie+2
              xt = 0.25*(u(i+1,j) - u(i-1,j))
           dm(i) = sign(min(abs(xt), max(u(i-1,j), u(i,j), u(i+1,j)) - u(i,j),  &
                            u(i,j) - min(u(i-1,j), u(i,j), u(i+1,j))), xt)
        enddo

! Fix slopes near edges:
      if (grid_type < 3) then
        if ( is==1 ) then
           if ( j==1 .or. j==npy ) then
              dm(0) = 0.
              dm(1) = 0.
           else
              x0 = 0.5*((2.*dx(1,j)+dx(2,j))*(u(0,j)+u(1,j))   &
                 - dx(1,j)*(u(-1,j)+u(2,j)))/(dx(1,j)+dx(2,j))
              x1 = s15*u(0,j) + s11*u(-1,j) + s14*dm(-1)
!          dm(0) = u(0,j) - x1
           dm(0) = 0.5*(x0 - x1)
           dm(0) = sign(min(abs(dm(0)), max(u(0,j), x0, x1) - u(0,j),   &
                               u(0,j) - min(u(0,j), x0, x1)), dm(0))
              x1 = s15*u(1,j) + s11*u(2,j) - s14*dm(2)
!          dm(1) = x1 - u(1,j)
           dm(1) = 0.5*(x1 - x0)
           dm(1) = sign(min(abs(dm(1)), max(u(1,j), x0, x1) - u(1,j),   &
                               u(1,j) - min(u(1,j), x0, x1)), dm(1))
           endif
        endif

        if ( (ie+1)==npx ) then
           if ( j==1 .or. j==npy ) then
              dm(npx-1) = 0.
              dm(npx  ) = 0.
           else
              x0 = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)+u(npx,j))  &
                - dx(npx-1,j)*(u(npx-2,j)+u(npx+1,j)))/(dx(npx-1,j)+dx(npx-2,j))
              x1 = s15*u(npx-1,j) + s11*u(npx-2,j) + s14*dm(npx-2)
!          dm(npx-1) = u(npx-1,j) - x1
           dm(npx-1) = 0.5*(x0 - x1)
           dm(npx-1) = sign(min(abs(dm(npx-1)), max(u(npx-1,j), x0, x1) - u(npx-1,j),  &
                                   u(npx-1,j) - min(u(npx-1,j), x0, x1)), dm(npx-1))
                x1 = s15*u(npx,j) + s11*u(npx+1,j) - s14*dm(npx+1)
!          dm(npx) = x1 - u(npx,j)
           dm(npx) = 0.5*(x1 - x0)
           dm(npx) = sign(min(abs(dm(npx)), max(u(npx,j), x0, x1) - u(npx,j),   &
                                 u(npx,j) - min(u(npx,j), x0, x1)), dm(npx))
           endif
        endif
      endif

       do i=is,ie+1
          if( c(i,j)>0. ) then
             flux(i,j) = u(i-1,j) + (1.-c(i,j)*rdx(i-1,j))*dm(i-1)
          else
             flux(i,j) = u(i,  j) - (1.+c(i,j)*rdx(i,  j))*dm(i)
          endif
       enddo
     enddo

 case (4)

     do j=js,je+1

        do i=is-2,ie+2
           xt = 0.25*(u(i+1,j) - u(i-1,j))
           dm(i) = sign(min(abs(xt), max(u(i-1,j), u(i,j), u(i+1,j)) - u(i,j),  &
                            u(i,j) - min(u(i-1,j), u(i,j), u(i+1,j))), xt)
        enddo

        do i=max(3,is-1),min(npx-2,ie+2)
           al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i))
        enddo

! Fix slopes near edges:
      if (grid_type < 3) then
        if ( is==1 ) then
          if ( j==1 .or. j==npy ) then
              dm(0) = 0.
              dm(1) = 0.
           al(0) = 0.5*(u(-1,j)+u(0,j)) + r3*dm(-1)
           al(1) = 0.5*((2.*dx(1,j)+dx(2,j))*(u(0,j)+u(1,j))   &
                 - dx(1,j)*(u(-1,j)+u(2,j)))/(dx(1,j)+dx(2,j))
           al(2) = 0.5*(u(1,j)+u(2,j)) - r3*dm(2)
          else
              x0 = 0.5*((2.*dx(1,j)+dx(2,j))*(u(0,j)+u(1,j))   &
                 - dx(1,j)*(u(-1,j)+u(2,j)))/(dx(1,j)+dx(2,j))
              x1 = s15*u(1,j) + s11*u(2,j) - s14*dm(2)
           dm(1) = 0.5*(x1 - x0)
!          dm(1) = sign(min(abs(dm(1)), max(u(1,j), x0, x1) - u(1,j),   &
!                              u(1,j) - min(u(1,j), x0, x1)), dm(1))
              x1 = s15*u(0,j) + s11*u(-1,j) + s14*dm(-1)
           dm(0) = 0.5*(x0 - x1)
!          dm(0) = sign(min(abs(dm(0)), max(u(0,j), x0, x1) - u(0,j),   &
!                              u(0,j) - min(u(0,j), x0, x1)), dm(0))
           al(0) = 0.5*(u(-1,j)+u(0,j)) + r3*(dm(-1)-dm(0))
           al(1) = x0
           al(2) = 0.5*(u(1,j)+u(2,j)) + r3*(dm(1)-dm(2))
          endif
        endif

        if ( (ie+1)==npx ) then
           if ( j==1 .or. j==npy ) then
              dm(npx-1) = 0.
              dm(npx  ) = 0.
              al(npx-1) = 0.5*(u(npx-2,j)+u(npx-1,j)) + r3*dm(npx-2)
              al(npx  ) = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)+u(npx,j))  &
                        - dx(npx-1,j)*(u(npx-2,j)+u(npx+1,j)))/(dx(npx-1,j)+dx(npx-2,j))
              al(npx+1) = 0.5*(u(npx,j)+u(npx+1,j)) - r3*dm(npx+1)
           else
              x0 = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)+u(npx,j))  &
                - dx(npx-1,j)*(u(npx-2,j)+u(npx+1,j)))/(dx(npx-1,j)+dx(npx-2,j))
              x1 = s15*u(npx-1,j) + s11*u(npx-2,j) + s14*dm(npx-2)
           dm(npx-1) = 0.5*(x0 - x1)
!          dm(npx-1) = sign(min(abs(dm(npx-1)), max(u(npx-1,j), x0, x1) - u(npx-1,j),  &
!                                  u(npx-1,j) - min(u(npx-1,j), x0, x1)), dm(npx-1))
                x1 = s15*u(npx,j) + s11*u(npx+1,j) - s14*dm(npx+1)
           dm(npx) = 0.5*(x1 - x0)
!          dm(npx) = sign(min(abs(dm(npx)), max(u(npx,j), x0, x1) - u(npx,j),   &
!                                u(npx,j) - min(u(npx,j), x0, x1)), dm(npx))
           al(npx-1) = 0.5*(u(npx-2,j)+u(npx-1,j)) + r3*(dm(npx-2) - dm(npx-1))
           al(npx  ) = x0
           al(npx+1) = 0.5*(u(npx,j)+u(npx+1,j)) + r3*(dm(npx) - dm(npx+1))
           endif
        endif
      endif

        do i=is,ie+1
          if( c(i,j)>0. ) then
             xt = 2.*dm(i-1)
             dl = sign(min(abs(xt), abs(al(i-1)-u(i-1,j))), xt)
             dr = sign(min(abs(xt), abs(al(i  )-u(i-1,j))), xt)
             cfl = c(i,j) * rdx(i-1,j)
             flux(i,j) = u(i-1,j) + (1.-cfl)*(dr + cfl*(dl-dr))
          else
             xt = 2.*dm(i)
             dl = sign(min(abs(xt), abs(al(i  )-u(i,j))), xt)
             dr = sign(min(abs(xt), abs(al(i+1)-u(i,j))), xt)
             cfl = c(i,j) * rdx(i,j)
             flux(i,j) = u(i,j) - (1.+cfl)*(dl + cfl*(dl-dr))
          endif
        enddo
     enddo

 case (6)

     do j=js,je+1

        do i=max(3,is-1),min(npx-3,ie+1)
           bl(i) = b5*u(i-2,j) + b4*u(i-1,j) + b3*u(i,j) + b2*u(i+1,j) + b1*u(i+2,j)
           br(i) = b1*u(i-2,j) + b2*u(i-1,j) + b3*u(i,j) + b4*u(i+1,j) + b5*u(i+2,j)
        enddo

        if (grid_type < 3) then
        if ( is==1 ) then
             br(2) = p1*(u(2,j)+u(3,j)) + p2*(u(1,j)+u(4,j)) - u(2,j)
                xt = c3*u(1,j) + c2*u(2,j) + c1*u(3,j)
             bl(2) = xt - u(2,j)
             if( j==1 .or. j==npy ) then
                 bl(0) = 0.   ! out
                 br(0) = 0.   ! edge
                 bl(1) = 0.   ! edge
                 br(1) = 0.   ! in
             else
             br(1) = xt - u(1,j)
             xt = 0.5*((2.*dx(1,j)+dx(2,j))*(u(0,j)+u(1,j))   &
                - dx(1,j)*(u(-1,j)+u(2,j)))/(dx(1,j)+dx(2,j))
             bl(1) = xt - u(1,j)
             br(0) = xt - u(0,j)
                xt = c1*u(-2,j) + c2*u(-1,j) + c3*u(0,j)
             bl(0) = xt - u(0,j)
             endif
        endif

        if ( (ie+1)==npx ) then
             bl(npx-2) = p1*(u(npx-2,j)+u(npx-3,j)) + p2*(u(npx-4,j)+u(npx-1,j)) - u(npx-2,j)
             xt = c1*u(npx-3,j) + c2*u(npx-2,j) + c3*u(npx-1,j)
             br(npx-2) = xt - u(npx-2,j)
             if( j==1 .or. j==npy ) then
                 bl(npx-1) = 0.  ! in
                 br(npx-1) = 0.  ! edge
                 bl(npx  ) = 0.  ! edge
                 br(npx  ) = 0.  ! out
             else
                 bl(npx-1) = xt - u(npx-1,j)
                 xt = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)+u(npx,j))  &
                    - dx(npx-1,j)*(u(npx-2,j)+u(npx+1,j)))/(dx(npx-1,j)+dx(npx-2,j))
                 br(npx-1) = xt - u(npx-1,j)
                 bl(npx  ) = xt - u(npx  ,j)
                      xt = c3*u(npx,j) + c2*u(npx+1,j) + c1*u(npx+2,j)
                 br(npx) = xt - u(npx,j)
             endif
        endif
        endif

        do i=is,ie+1
           if( c(i,j)>0. ) then
                     cfl = c(i,j)*rdx(i-1,j)
               flux(i,j) = u(i-1,j) + (1.-cfl)*(br(i-1)-cfl*(bl(i-1)+br(i-1)))
           else
                     cfl = c(i,j)*rdx(i,j)
               flux(i,j) = u(i,  j) + (1.+cfl)*(bl(i  )+cfl*(bl(i  )+br(i  )))
           endif
        enddo
     enddo

 case default
 ! iord = 8, 9, 10

     do j=js,je+1
        do i=is-2,ie+2
           xt = 0.25*(u(i+1,j) - u(i-1,j))
           dm(i) = sign(min(abs(xt), max(u(i-1,j), u(i,j), u(i+1,j)) - u(i,j),  &
                            u(i,j) - min(u(i-1,j), u(i,j), u(i+1,j))), xt)
        enddo
        do i=is-3,ie+2
           dq(i) = u(i+1,j) - u(i,j)
        enddo

        if (grid_type < 3) then

           do i=max(3,is-1),min(npx-2,ie+2)
              al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i))
           enddo

! Perturbation form:
           if( iord==8 ) then
             do i=max(3,is-1),min(npx-3,ie+1)
                xt = 2.*dm(i)
                bl(i) = -sign(min(abs(xt), abs(al(i  )-u(i,j))), xt)
                br(i) =  sign(min(abs(xt), abs(al(i+1)-u(i,j))), xt)
             enddo
           elseif( iord==9 ) then
             do i=max(3,is-1),min(npx-3,ie+1)
                pmp = 2.*dq(i-1)
                lac = pmp - 1.5*dq(i-2)
                br(i) = min(max(0., pmp, lac), max(al(i+1)-u(i,j), min(0.,pmp, lac)))
                pmp = -2.*dq(i)
                lac = pmp + 1.5*dq(i+1)
                bl(i) = min(max(0., pmp, lac), max(al(i  )-u(i,j), min(0.,pmp, lac)))
             enddo
           else
! un-limited:
             do i=max(3,is-1),min(npx-3,ie+1)
                bl(i) = al(i  ) - u(i,j)
                br(i) = al(i+1) - u(i,j)
             enddo
           endif

!--------------
! fix the edges
!--------------
           if ( is==1 ) then
              br(2) = al(3) - u(2,j)
              xt = s15*u(1,j) + s11*u(2,j) - s14*dm(2)
              bl(2) = xt - u(2,j)
              br(1) = xt - u(1,j)
              if( j==1 .or. j==npy ) then
                 bl(0) = 0.   ! out
                 br(0) = 0.   ! edge
                 bl(1) = 0.   ! edge
                 br(1) = 0.   ! in
              else
                 bl(0) = s14*dm(-1) - s11*dq(-1)
!---------------------------------------------------------------
#ifdef ONE_SIDE
                 xt = t14*u(0,j) + t12*u(-1,j) + t15*u(-2,j)
                 br(0) = 2.*xt - u(0,j)
                 xt = t14*u(1,j) + t12*u(2,j) + t15*u(3,j)
                 bl(1) = 2.*xt - u(1,j)
#else
                 xt = 0.5*((2.*dx(1,j)+dx(2,j))*(u(0,j)+u(1,j))   &
                    - dx(1,j)*(u(-1,j)+u(2,j)))/(dx(1,j)+dx(2,j))
                 br(0) = xt - u(0,j)
                 bl(1) = xt - u(1,j)
!                 br(0) = xt - 0.5*(v(1,j-1)+v(1,j))*cosa(1,j) - u(0,j)
!                 bl(1) = xt + 0.5*(v(1,j-1)+v(1,j))*cosa(1,j) - u(1,j)
#endif
!---------------------------------------------------------------
                 endif
                 if(iord<10) call pert_ppm(1, u(2,j), bl(2), br(2), -1)
              endif

           if ( (ie+1)==npx ) then
              bl(npx-2) = al(npx-2) - u(npx-2,j)
              xt = s15*u(npx-1,j) + s11*u(npx-2,j) + s14*dm(npx-2)
              br(npx-2) = xt - u(npx-2,j)
              bl(npx-1) = xt - u(npx-1,j)
              if( j==1 .or. j==npy ) then
                 bl(npx-1) = 0.   ! in
                 br(npx-1) = 0.   ! edge
                 bl(npx  ) = 0.   ! edge
                 br(npx  ) = 0.   ! out
              else
                 br(npx) = s11*dq(npx) - s14*dm(npx+1)
#ifdef ONE_SIDE
                 xt = t14*u(npx-1,j) + t12*u(npx-2,j) + t15*u(npx-3,j)
                 br(npx-1) = 2.*xt - u(npx-1,j)
                 xt = t14*u(npx,j) + t12*u(npx+1,j) + t15*u(npx+2,j)
                 bl(npx  ) = 2.*xt - u(npx  ,j)
#else
                 xt = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)+u(npx,j))  &
                    - dx(npx-1,j)*(u(npx-2,j)+u(npx+1,j)))/(dx(npx-1,j)+dx(npx-2,j))
                 br(npx-1) = xt - u(npx-1,j)
                 bl(npx  ) = xt - u(npx  ,j)
!                 br(npx-1) = xt + 0.5*(v(npx,j-1)+v(npx,j))*cosa(npx,j) - u(npx-1,j)
!                 bl(npx  ) = xt - 0.5*(v(npx,j-1)+v(npx,j))*cosa(npx,j) - u(npx  ,j)
#endif
                 endif
                 if(iord<10) call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1)
              endif
          else
          
              do i=is-1,ie+2
                 al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i))
              enddo

              do i=is-1,ie+1
                 pmp = -2.*dq(i)
                 lac = pmp + 1.5*dq(i+1)
                 bl(i) = min(max(0., pmp, lac), max(al(i  )-u(i,j), min(0.,pmp, lac)))
                 pmp = 2.*dq(i-1)
                 lac = pmp - 1.5*dq(i-2)
                 br(i) = min(max(0., pmp, lac), max(al(i+1)-u(i,j), min(0.,pmp, lac)))
              enddo
          endif
       
          do i=is,ie+1
             if( c(i,j)>0. ) then
                cfl = c(i,j)*rdx(i-1,j)
                flux(i,j) = u(i-1,j) + (1.-cfl)*(br(i-1)-cfl*(bl(i-1)+br(i-1)))
             else
                cfl = c(i,j)*rdx(i,j)
                flux(i,j) = u(i,  j) + (1.+cfl)*(bl(i  )+cfl*(bl(i  )+br(i  )))
             endif
          enddo
     enddo

 end select

 end subroutine xtp_u


 subroutine ytp_v(c, u, v, flux, jord)
 integer, intent(IN):: jord
 real, INTENT(IN)  ::   u(isd:ied,jsd:jed+1)
 real, INTENT(IN)  ::   v(isd:ied+1,jsd:jed)
 real, INTENT(IN) ::    c(is:ie+1,js:je+1)   !  Courant   N (like FLUX)
 real, INTENT(OUT):: flux(is:ie+1,js:je+1)
! Local:
 real dm(is:ie+1,js-2:je+2)
 real al(is:ie+1,js-1:je+2)
 real bl(is:ie+1,js-1:je+1)
 real br(is:ie+1,js-1:je+1)
 real dq(is:ie+1,js-3:je+2)
 real xt, dl, dr, pmp, lac, dqt, cfl
 real x0, x1
 integer i, j

 select case ( jord )
 case (1)

      do j=js,je+1
         do i=is,ie+1
            if( c(i,j)>0. ) then
               flux(i,j) = v(i,j-1)
            else
               flux(i,j) = v(i,j)
            endif
         enddo
      enddo

 case (2)

   do j=js-2,je+2
      do i=is,ie+1
              xt = 0.25*(v(i,j+1) - v(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(v(i,j-1), v(i,j), v(i,j+1)) - v(i,j),   &
                            v(i,j) - min(v(i,j-1), v(i,j), v(i,j+1))), xt)
      enddo
   enddo

   if (grid_type < 3) then
   if( js==1 ) then
         do i=is,ie+1
            x0 = 0.5*( (2.*dy(i,1)+dy(i,2))*(v(i,0)+v(i,1))   &
               - dy(i,1)*(v(i,-1)+v(i,2)))/(dy(i,1)+dy(i,2))
            x1 = s15*v(i,1) + s11*v(i,2) - s14*dm(i,2)
!           dm(i,1) = x1 - v(i,1)
            dm(i,1) = 0.5*(x1 - x0)
            dm(i,1) = sign(min(abs(dm(i,1)), max(v(i,1), x0, x1) - v(i,1),   &
                                    v(i,1) - min(v(i,1), x0, x1)), dm(i,1))
            x1 = s15*v(i,0) + s11*v(i,-1) + s14*dm(i,-1)
!           dm(i,0) = v(i,0) - x1
            dm(i,0) = 0.5*(x0 - x1)
            dm(i,0) = sign(min(abs(dm(i,0)), max(v(i,0), x0, x1) - v(i,0),   &
                                    v(i,0) - min(v(i,0), x0, x1)), dm(i,0))
         enddo
      if (     is == 1   ) then
           dm(1,0) = 0.
           dm(1,1) = 0.
      endif
      if ( (ie+1) == npx ) then
           dm(npx,0) = 0.
           dm(npx,1) = 0.
      endif
   endif

   if( (je+1)==npy ) then
         do i=is,ie+1
            x0 = 0.5*((2.*dy(i,npy-1)+dy(i,npy-2))*(v(i,npy-1)+v(i,npy)) -  &
                 dy(i,npy-1)*(v(i,npy-2)+v(i,npy+1)))/(dy(i,npy-1)+dy(i,npy-2))
            x1 = s15*v(i,npy-1) + s11*v(i,npy-2) + s14*dm(i,npy-2)
!           dm(i,npy-1) = v(i,npy-1) - x1
            dm(i,npy-1) = 0.5*(x0 - x1)
            dm(i,npy-1) = sign(min(abs(dm(i,npy-1)), max(v(i,npy-1), x0, x1) - v(i,npy-1),  &
                                        v(i,npy-1) - min(v(i,npy-1), x0, x1)), dm(i,npy-1))
            x1 = s15*v(i,npy) + s11*v(i,npy+1) - s14*dm(i,npy+1)
!           dm(i,npy) = x1 - v(i,npy)
            dm(i,npy) = 0.5*(x1 - x0)
            dm(i,npy) = sign(min(abs(dm(i,npy)), max(v(i,npy), x0, x1) - v(i,npy),   &
                                      v(i,npy) - min(v(i,npy), x0, x1)), dm(i,npy))
         enddo
      if (     is == 1   ) then
           dm(1,npy-1) = 0.
           dm(1,npy  ) = 0.
      endif
      if ( (ie+1) == npx ) then
           dm(npx,npy-1) = 0.
           dm(npx,npy  ) = 0.
      endif
   endif
   endif

   do j=js,je+1
      do i=is,ie+1
         if( c(i,j)>0. ) then
            flux(i,j) = v(i,j-1) + (1.-c(i,j)*rdy(i,j-1))*dm(i,j-1)
         else
            flux(i,j) = v(i,j  ) - (1.+c(i,j)*rdy(i,j  ))*dm(i,j)
         endif
      enddo
   enddo

 case (4)

   do j=js-2,je+2
      do i=is,ie+1
              xt = 0.25*(v(i,j+1) - v(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(v(i,j-1), v(i,j), v(i,j+1)) - v(i,j),   &
                            v(i,j) - min(v(i,j-1), v(i,j), v(i,j+1))), xt)
      enddo
   enddo

   do j=js-1,je+2
      do i=is,ie+1
         al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1) - dm(i,j))
      enddo
   enddo

   if (grid_type < 3) then
   if( js==1 ) then
         do i=is,ie+1
            x0 = 0.5*( (2.*dy(i,1)+dy(i,2))*(v(i,0)+v(i,1))   &
               - dy(i,1)*(v(i,-1)+v(i,2)))/(dy(i,1)+dy(i,2))
            x1 = s15*v(i,1) + s11*v(i,2) - s14*dm(i,2)
            dm(i,1) = 0.5*(x1 - x0)
!           dm(i,1) = sign(min(abs(dm(i,1)), max(v(i,1), x0, x1) - v(i,1),   &
!                                   v(i,1) - min(v(i,1), x0, x1)), dm(i,1))
            x1 = s15*v(i,0) + s11*v(i,-1) + s14*dm(i,-1)
            dm(i,0) = 0.5*(x0 - x1)
!           dm(i,0) = sign(min(abs(dm(i,0)), max(v(i,0), x0, x1) - v(i,0),   &
!                                   v(i,0) - min(v(i,0), x0, x1)), dm(i,0))
            al(i,0) = 0.5*(v(i,-1)+v(i,0)) + r3*(dm(i,-1) - dm(i,0))
            al(i,1) = x0
            al(i,2) = 0.5*(v(i,1)+v(i,2)) + r3*(dm(i,1) - dm(i,2))
         enddo

         if (     is == 1   ) then
             dm(1,0) = 0.
             dm(1,1) = 0.
            i = 1
            al(i,0) = 0.5*(v(i,-1)+v(i,0)) + r3*(dm(i,-1) - dm(i,0))
            al(i,2) = 0.5*(v(i, 1)+v(i,2)) + r3*(dm(i, 1) - dm(i,2))
         endif
         if ( (ie+1) == npx ) then
             dm(npx,0) = 0.
             dm(npx,1) = 0.
            i = npx
            al(i,0) = 0.5*(v(i,-1)+v(i,0)) + r3*dm(i,-1)
            al(i,2) = 0.5*(v(i, 1)+v(i,2)) - r3*dm(i,2)
         endif
   endif

   if( (je+1)==npy ) then
         do i=is,ie+1
            x0 = 0.5*((2.*dy(i,npy-1)+dy(i,npy-2))*(v(i,npy-1)+v(i,npy)) -  &
                 dy(i,npy-1)*(v(i,npy-2)+v(i,npy+1)))/(dy(i,npy-1)+dy(i,npy-2))
            x1 = s15*v(i,npy-1) + s11*v(i,npy-2) + s14*dm(i,npy-2)
            dm(i,npy-1) = 0.5*(x0 - x1)
!           dm(i,npy-1) = sign(min(abs(dm(i,npy-1)), max(v(i,npy-1), x0, x1) - v(i,npy-1),  &
!                                       v(i,npy-1) - min(v(i,npy-1), x0, x1)), dm(i,npy-1))
            x1 = s15*v(i,npy) + s11*v(i,npy+1) - s14*dm(i,npy+1)
            dm(i,npy) = 0.5*(x1 - x0)
!           dm(i,npy) = sign(min(abs(dm(i,npy)), max(v(i,npy), x0, x1) - v(i,npy),   &
!                                     v(i,npy) - min(v(i,npy), x0, x1)), dm(i,npy))
            al(i,npy-1) = 0.5*(v(i,npy-2)+v(i,npy-1)) + r3*(dm(i,npy-2) - dm(i,npy-1))
            al(i,npy  ) = x0
            al(i,npy+1) = 0.5*(v(i,npy)+v(i,npy+1)) + r3*(dm(i,npy) - dm(i,npy+1))
         enddo
         if (     is == 1   ) then
              dm(1,npy-1) = 0.
              dm(1,npy  ) = 0.
            i = 1
            al(i,npy-1) = 0.5*(v(i,npy-2)+v(i,npy-1)) + r3*dm(i,npy-2)
            al(i,npy+1) = 0.5*(v(i,npy  )+v(i,npy+1)) - r3*dm(i,npy+1)
         endif
         if ( (ie+1) == npx ) then
              dm(npx,npy-1) = 0.
              dm(npx,npy  ) = 0.
            i = npx
            al(i,npy-1) = 0.5*(v(i,npy-2)+v(i,npy-1)) + r3*dm(i,npy-2)
            al(i,npy+1) = 0.5*(v(i,npy  )+v(i,npy+1)) - r3*dm(i,npy+1)
        endif
   endif
   endif


   do j=js,je+1
      do i=is,ie+1
         if(c(i,j)>0.) then
            xt = 2.*dm(i,j-1)
            dl = sign(min(abs(xt), abs(al(i,j-1)-v(i,j-1))), xt)
            dr = sign(min(abs(xt), abs(al(i,j)-v(i,j-1))),   xt)
            cfl = c(i,j)*rdy(i,j-1)
            flux(i,j) = v(i,j-1) + (1.-cfl)*(dr + cfl*(dl-dr))
         else
            xt = 2.*dm(i,j)
            dl = sign(min(abs(xt), abs(al(i,j)-v(i,j))),   xt)
            dr = sign(min(abs(xt), abs(al(i,j+1)-v(i,j))), xt)
            cfl = c(i,j)*rdy(i,j)
            flux(i,j) = v(i,j) - (1.+cfl)*(dl + cfl*(dl-dr))
         endif
      enddo
   enddo

 case (6)

   do j=max(3,js-1),min(npy-3,je+1)
      do i=is,ie+1
         bl(i,j) = b5*v(i,j-2) + b4*v(i,j-1) + b3*v(i,j) + b2*v(i,j+1) + b1*v(i,j+2)
         br(i,j) = b1*v(i,j-2) + b2*v(i,j-1) + b3*v(i,j) + b4*v(i,j+1) + b5*v(i,j+2)
      enddo
   enddo

   if (grid_type < 3) then
   if( js==1 ) then
       do i=is,ie+1
          br(i,2) = p1*(v(i,2)+v(i,3)) + p2*(v(i,1)+v(i,4)) - v(i,2)
               xt = c3*v(i,1) + c2*v(i,2) + c1*v(i,3)
          br(i,1) = xt - v(i,1)
          bl(i,2) = xt - v(i,2)

          bl(i,0) = c1*v(i,-2) + c2*v(i,-1) + c3*v(i,0) - v(i,0)

          xt = 0.5*( (2.*dy(i,1)+dy(i,2))*(v(i,0)+v(i,1))   &
             - dy(i,1)*(v(i,-1)+v(i,2)))/(dy(i,1)+dy(i,2))
          bl(i,1) = xt - v(i,1)
          br(i,0) = xt - v(i,0)
       enddo
       if ( is==1 ) then
            bl(1,0) = 0.  ! out
            br(1,0) = 0.  ! edge
            bl(1,1) = 0.  ! edge
            br(1,1) = 0.  ! in
       endif
       if ( (ie+1)==npx ) then
            bl(npx,0) = 0.   ! out
            br(npx,0) = 0.   ! edge
            bl(npx,1) = 0.   ! edge
            br(npx,1) = 0.   ! in
       endif
   endif

   if( (je+1)==npy ) then
       do i=is,ie+1
            bl(i,npy-2) = p1*(v(i,npy-3)+v(i,npy-2)) + p2*(v(i,npy-4)+v(i,npy-1)) - v(i,npy-2)
            xt = c1*v(i,npy-3) + c2*v(i,npy-2) + c3*v(i,npy-1)
            br(i,npy-2) = xt - v(i,npy-2)
            bl(i,npy-1) = xt - v(i,npy-1)
            br(i,npy) = c3*v(i,npy)+ c2*v(i,npy+1) + c1*v(i,npy+2) - v(i,npy)
            xt = 0.5*((2.*dy(i,npy-1)+dy(i,npy-2))*(v(i,npy-1)+v(i,npy)) -  &
                 dy(i,npy-1)*(v(i,npy-2)+v(i,npy+1)))/(dy(i,npy-1)+dy(i,npy-2))
            br(i,npy-1) = xt - v(i,npy-1)
            bl(i,npy  ) = xt - v(i,npy)
       enddo
       if ( is==1 ) then
            bl(1,npy-1) = 0.  ! in
            br(1,npy-1) = 0.  ! edge
            bl(1,npy  ) = 0.  ! edge
            br(1,npy  ) = 0.  ! out
       endif
       if ( (ie+1)==npx ) then
            bl(npx,npy-1) = 0.  ! in
            br(npx,npy-1) = 0.  ! edge
            bl(npx,npy  ) = 0.  ! edge
            br(npx,npy  ) = 0.  ! out
       endif
   endif
   endif

   do j=js,je+1
      do i=is,ie+1
         if( c(i,j)>0. ) then
                  cfl = c(i,j)*rdy(i,j-1)
            flux(i,j) = v(i,j-1) + (1.-cfl)*(br(i,j-1)-cfl*(bl(i,j-1)+br(i,j-1)))
         else
                  cfl = c(i,j)*rdy(i,j)
            flux(i,j) = v(i,j  ) + (1.+cfl)*(bl(i,j  )+cfl*(bl(i,j  )+br(i,j  )))
         endif
      enddo
   enddo

 case default
! jord= 8, 9, 10

   do j=js-2,je+2
      do i=is,ie+1
         xt = 0.25*(v(i,j+1) - v(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(v(i,j-1), v(i,j), v(i,j+1)) - v(i,j),   &
                            v(i,j) - min(v(i,j-1), v(i,j), v(i,j+1))), xt)
      enddo
   enddo

   do j=js-3,je+2
      do i=is,ie+1
         dq(i,j) = v(i,j+1) - v(i,j)
      enddo
   enddo

   if (grid_type < 3) then
      do j=max(3,js-1),min(npy-2,je+2)
         do i=is,ie+1
            al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1)-dm(i,j))
         enddo
      enddo
      
      if ( jord==8 ) then
        do j=max(3,js-1),min(npy-3,je+1)
           do i=is,ie+1
              xt =  2.*dm(i,j)
              bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-v(i,j))),   xt)
              br(i,j) =  sign(min(abs(xt), abs(al(i,j+1)-v(i,j))), xt)
           enddo
        enddo
      elseif ( jord==9 ) then
        do j=max(3,js-1),min(npy-3,je+1)
           do i=is,ie+1
              pmp = 2.*dq(i,j-1)
              lac = pmp - 1.5*dq(i,j-2)
              br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-v(i,j), min(0.,pmp,lac)))
              pmp = -2.*dq(i,j) 
              lac = pmp + 1.5*dq(i,j+1)
              bl(i,j) = min(max(0.,pmp,lac), max(al(i,j)-v(i,j), min(0.,pmp,lac)))
           enddo
        enddo
      else
! Unlimited:
        do j=max(3,js-1),min(npy-3,je+1)
           do i=is,ie+1
              bl(i,j) = al(i,j  ) - v(i,j)
              br(i,j) = al(i,j+1) - v(i,j)
           enddo
        enddo
      endif
      
!--------------
! fix the edges
!--------------
      if( js==1 ) then
         do i=is,ie+1
            br(i,2) = al(i,3) - v(i,2)
            xt = s15*v(i,1) + s11*v(i,2) - s14*dm(i,2)
            br(i,1) = xt - v(i,1)
            bl(i,2) = xt - v(i,2)

            bl(i,0) = s14*dm(i,-1) - s11*dq(i,-1)

#ifdef ONE_SIDE
            xt =  t14*v(i,1) +  t12*v(i,2) + t15*v(i,3)
            bl(i,1) = 2.*xt - v(i,1)
            xt =  t14*v(i,0) +  t12*v(i,-1) + t15*v(i,-2)
            br(i,0) = 2.*xt - v(i,0)
#else
            xt = 0.5*( (2.*dy(i,1)+dy(i,2))*(v(i,0)+v(i,1))   &
               - dy(i,1)*(v(i,-1)+v(i,2)))/(dy(i,1)+dy(i,2))
             bl(i,1) = xt - v(i,1)
             br(i,0) = xt - v(i,0)
!             br(i,0) = xt - 0.5*(u(i-1,1)+u(i,1))*cosa(i,1) - v(i,0)
!             bl(i,1) = xt + 0.5*(u(i-1,1)+u(i,1))*cosa(i,1) - v(i,1)
#endif
         enddo
         if ( is==1 ) then
               bl(1,0) = 0.   ! out
               br(1,0) = 0.   ! edge
               bl(1,1) = 0.   ! edge
               br(1,1) = 0.   ! in
         endif
         if ( (ie+1)==npx ) then
               bl(npx,0) = 0.   ! out
               br(npx,0) = 0.   ! edge
               bl(npx,1) = 0.   ! edge
               br(npx,1) = 0.   ! in
         endif
         j=2
         if ( jord<10 ) call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
      endif

      if( (je+1)==npy ) then
         do i=is,ie+1
            bl(i,npy-2) = al(i,npy-2) - v(i,npy-2)
            xt = s15*v(i,npy-1) + s11*v(i,npy-2) + s14*dm(i,npy-2)
            br(i,npy-2) = xt - v(i,npy-2)
            bl(i,npy-1) = xt - v(i,npy-1)
            br(i,npy) = s11*dq(i,npy) - s14*dm(i,npy+1)
#ifdef ONE_SIDE
            xt = t14*v(i,npy-1) + t12*v(i,npy-2) + t15*v(i,npy-3)
            br(i,npy-1) = 2.*xt - v(i,npy-1)
            xt = t14*v(i,npy) + t12*v(i,npy+1) + t15*v(i,npy+2)
            bl(i,npy  ) = 2.*xt - v(i,npy)
#else
            xt = 0.5*((2.*dy(i,npy-1)+dy(i,npy-2))*(v(i,npy-1)+v(i,npy)) -  &
                 dy(i,npy-1)*(v(i,npy-2)+v(i,npy+1)))/(dy(i,npy-1)+dy(i,npy-2))
            br(i,npy-1) = xt - v(i,npy-1)
            bl(i,npy  ) = xt - v(i,npy)
!            br(i,npy-1) = xt + 0.5*(u(i-1,npy)+u(i,npy))*cosa(i,npy) - v(i,npy-1)
!            bl(i,npy  ) = xt - 0.5*(u(i-1,npy)+u(i,npy))*cosa(i,npy) - v(i,npy)
#endif
         enddo
         if ( is==1 ) then
               bl(1,npy-1) = 0.   ! in
               br(1,npy-1) = 0.   ! edge
               bl(1,npy  ) = 0.   ! edge
               br(1,npy  ) = 0.   ! out
         endif
         if ( (ie+1)==npx ) then
               bl(npx,npy-1) = 0.   ! in
               br(npx,npy-1) = 0.   ! edge
               bl(npx,npy  ) = 0.   ! edge
               br(npx,npy  ) = 0.   ! out
         endif
         j=npy-2
         if ( jord<10 ) call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
      endif

   else

      do j=js-1,je+2
         do i=is,ie+1
            al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1)-dm(i,j))
         enddo
      enddo
      
      do j=js-1,je+1
         do i=is,ie+1
            pmp = 2.*dq(i,j-1)
            lac = pmp - 1.5*dq(i,j-2)
            br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-v(i,j), min(0.,pmp,lac)))
            pmp = -2.*dq(i,j) 
            lac = pmp + 1.5*dq(i,j+1)
            bl(i,j) = min(max(0.,pmp,lac), max(al(i,j)-v(i,j), min(0.,pmp,lac)))
         enddo
      enddo
      
   endif

   do j=js,je+1
      do i=is,ie+1
         if(c(i,j)>0.) then
            cfl = c(i,j)*rdy(i,j-1)
            flux(i,j) = v(i,j-1) + (1.-cfl)*(br(i,j-1)-cfl*(bl(i,j-1)+br(i,j-1)))
         else
            cfl = c(i,j)*rdy(i,j)
            flux(i,j) = v(i,j  ) + (1.+cfl)*(bl(i,j  )+cfl*(bl(i,j  )+br(i,j  )))
         endif
      enddo
   enddo

 end select

end subroutine ytp_v



 subroutine d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4)
  logical, intent(in):: dord4
  real, intent(in) ::  u(isd:ied,jsd:jed+1)
  real, intent(in) ::  v(isd:ied+1,jsd:jed)
  real, intent(out), dimension(isd:ied+1,jsd:jed  ):: uc
  real, intent(out), dimension(isd:ied  ,jsd:jed+1):: vc
  real, intent(out), dimension(isd:ied  ,jsd:jed  ):: ua, va, ut, vt
! Local 
  real, dimension(isd:ied,jsd:jed):: utmp, vtmp
  integer npt, i, j, ifirst, ilast, id

  if ( dord4 ) then
       id = 1
  else
       id = 0
  endif


  if (grid_type < 3) then
     npt = 4
  else
     npt = -2
  endif

! Initialize utmp and vtmp to zero
  utmp=1.e35
  vtmp=1.e35

!----------
! Interior:
!----------
  do j=max(npt,js-1),min(npy-npt,je+1)
     do i=max(npt,isd),min(npx-npt,ied)
        utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1))
     enddo
  enddo
  do j=max(npt,jsd),min(npy-npt,jed)
     do i=max(npt,is-1),min(npx-npt,ie+1)
        vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j))
     enddo
  enddo

!----------
! edges:
!----------
  if (grid_type < 3) then

  if ( js==1 .or. jsd<npt) then
#ifdef CONSV_VT
      do j=jsd,npt-1
         do i=isd,ied+1
            uc(i,j) = v(i,j)*dy(i,j)
         enddo
      enddo
      do j=jsd,npt
         do i=isd,ied
            vc(i,j) = u(i,j)*dx(i,j)
         enddo
      enddo
#endif
      do j=jsd,npt-1
         do i=isd,ied
#ifdef CONSV_VT
            utmp(i,j) = 0.5*(vc(i,j) + vc(i,j+1)) * rdxa(i,j)
            vtmp(i,j) = 0.5*(uc(i,j) + uc(i+1,j)) * rdya(i,j)
#else
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
#endif
         enddo
      enddo
  endif
  if ( (je+1)==npy .or. jed>=(npy-npt)) then
#ifdef CONSV_VT
      do j=npy-npt+1,jed
         do i=isd,ied+1
            uc(i,j) = v(i,j)*dy(i,j)
         enddo
      enddo
      do j=npy-npt+1,jed+1
         do i=isd,ied
            vc(i,j) = u(i,j)*dx(i,j)
         enddo
      enddo
#endif
      do j=npy-npt+1,jed
         do i=isd,ied
#ifdef CONSV_VT
            utmp(i,j) = 0.5*(vc(i,j) + vc(i,j+1)) * rdxa(i,j)
            vtmp(i,j) = 0.5*(uc(i,j) + uc(i+1,j)) * rdya(i,j)
#else
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
#endif
         enddo
      enddo
  endif
  if ( is==1 .or. isd<npt ) then
#ifdef CONSV_VT
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=isd,npt
            uc(i,j) = v(i,j)*dy(i,j)
         enddo
      enddo
      do j=max(npt,jsd),min(npy-npt+1,jed+1)
         do i=isd,npt-1
            vc(i,j) = u(i,j)*dx(i,j)
         enddo
      enddo
#endif
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=isd,npt-1
#ifdef CONSV_VT
            utmp(i,j) = 0.5*(vc(i,j) + vc(i,j+1)) * rdxa(i,j)
            vtmp(i,j) = 0.5*(uc(i,j) + uc(i+1,j)) * rdya(i,j)
#else
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
#endif
         enddo
      enddo
  endif
  if ( (ie+1)==npx .or. ied>=(npx-npt)) then
#ifdef CONSV_VT
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=npx-npt+1,ied+1
            uc(i,j) = v(i,j)*dy(i,j)
         enddo
      enddo
      do j=max(npt,jsd),min(npy-npt+1,jed+1)
         do i=npx-npt+1,ied
            vc(i,j) = u(i,j)*dx(i,j)
         enddo
      enddo
#endif
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=npx-npt+1,ied
#ifdef CONSV_VT
            utmp(i,j) = 0.5*(vc(i,j) + vc(i,j+1)) * rdxa(i,j)
            vtmp(i,j) = 0.5*(uc(i,j) + uc(i+1,j)) * rdya(i,j)
#else
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
#endif
         enddo
      enddo
  endif

  endif

  do j=js-1-id,je+1+id
     do i=is-1-id,ie+1+id
        ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j)
        va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j)
     enddo
  enddo

! A -> C
!--------------
! Fix the edges
!--------------
! Xdir:
     if( sw_corner ) then
         do i=-2,0
            utmp(i,0) = -vtmp(0,1-i)
         enddo
     endif
     if( se_corner ) then
         do i=0,2
            utmp(npx+i,0) = vtmp(npx,i+1)
         enddo
     endif
     if( ne_corner ) then
         do i=0,2
            utmp(npx+i,npy) = -vtmp(npx,je-i)
         enddo
     endif
     if( nw_corner ) then
         do i=-2,0
            utmp(i,npy) = vtmp(0,je+i)
         enddo
     endif

  if (grid_type < 3) then
     ifirst = max(3,    is-1)
     ilast  = min(npx-2,ie+2)
  else
     ifirst = is-1
     ilast  = ie+2
  endif
!---------------------------------------------
! 4th order interpolation for interior points:
!---------------------------------------------
     do j=js-1,je+1
        do i=ifirst,ilast
           uc(i,j) = a1*(utmp(i-1,j)+utmp(i,j))+a2*(utmp(i-2,j)+utmp(i+1,j))
           ut(i,j) = (uc(i,j) - v(i,j)*cosa_u(i,j))*rsin_u(i,j)
        enddo
     enddo

     if (grid_type < 3) then

     if( is==1 ) then
        do j=js-1,je+1
           uc(0,j) = c1*utmp(-2,j) + c2*utmp(-1,j) + c3*utmp(0,j) 
! 3-pt extrapolation --------------------------------------------------
           uc(1,j) = ( t14*(utmp( 0,j)+utmp(1,j))    &
                     + t12*(utmp(-1,j)+utmp(2,j))    &
                     + t15*(utmp(-2,j)+utmp(3,j)) )*rsin_u(1,j)
           uc(2,j) = c1*utmp(3,j) + c2*utmp(2,j) + c3*utmp(1,j)
           ut(0,j) = (uc(0,j) - v(0,j)*cosa_u(0,j))*rsin_u(0,j)
           ut(1,j) =  uc(1,j) * rsin_u(1,j)
           ut(2,j) = (uc(2,j) - v(2,j)*cosa_u(2,j))*rsin_u(2,j)
        enddo
     endif

     if( (ie+1)==npx ) then
        do j=js-1,je+1
           uc(npx-1,j) = c1*utmp(npx-3,j)+c2*utmp(npx-2,j)+c3*utmp(npx-1,j) 
! 3-pt extrapolation --------------------------------------------------------
           uc(npx,j) = (t14*(utmp(npx-1,j)+utmp(npx,j))+      &
                        t12*(utmp(npx-2,j)+utmp(npx+1,j))     &
                      + t15*(utmp(npx-3,j)+utmp(npx+2,j)))*rsin_u(npx,j)
           uc(npx+1,j) = c3*utmp(npx,j)+c2*utmp(npx+1,j)+c1*utmp(npx+2,j) 
           ut(npx-1,j) = (uc(npx-1,j)-v(npx-1,j)*cosa_u(npx-1,j))*rsin_u(npx-1,j)
           ut(npx,  j) =  uc(npx,j) * rsin_u(npx,j)
           ut(npx+1,j) = (uc(npx+1,j)-v(npx+1,j)*cosa_u(npx+1,j))*rsin_u(npx+1,j)
        enddo
     endif

     endif

!------
! Ydir:
!------
     if( sw_corner ) then
         do j=-2,0
            vtmp(0,j) = -utmp(1-j,0)
         enddo
     endif
     if( nw_corner ) then
         do j=0,2
            vtmp(0,npy+j) = utmp(j+1,npy)
         enddo
     endif
     if( se_corner ) then
         do j=-2,0
            vtmp(npx,j) = utmp(ie+j,0)
         enddo
     endif
     if( ne_corner ) then
         do j=0,2
            vtmp(npx,npy+j) = -utmp(ie-j,npy)
         enddo
     endif

     if (grid_type < 3) then

     do j=js-1,je+2
      if ( j==1 ) then
        do i=is-1,ie+1
! 3-pt extrapolation -----------------------------------------
           vc(i,1) = (t14*(vtmp(i, 0)+vtmp(i,1))    &
                    + t12*(vtmp(i,-1)+vtmp(i,2))    &
                    + t15*(vtmp(i,-2)+vtmp(i,3)))*rsin_v(i,1)
           vt(i,1) = vc(i,1) * rsin_v(i,1)
        enddo
      elseif ( j==0 .or. j==(npy-1) ) then
        do i=is-1,ie+1
           vc(i,j) = c1*vtmp(i,j-2) + c2*vtmp(i,j-1) + c3*vtmp(i,j)
           vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j)
        enddo
      elseif ( j==2 .or. j==(npy+1) ) then
        do i=is-1,ie+1
           vc(i,j) = c1*vtmp(i,j+1) + c2*vtmp(i,j) + c3*vtmp(i,j-1)
           vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j)
        enddo
      elseif ( j==npy ) then
        do i=is-1,ie+1
! 3-pt extrapolation --------------------------------------------------------
           vc(i,npy) = (t14*(vtmp(i,npy-1)+vtmp(i,npy))    &
                      + t12*(vtmp(i,npy-2)+vtmp(i,npy+1))  &
                      + t15*(vtmp(i,npy-3)+vtmp(i,npy+2)))*rsin_v(i,npy)
           vt(i,npy) = vc(i,npy) * rsin_v(i,npy)
        enddo
      else
! 4th order interpolation for interior points:
        do i=is-1,ie+1
           vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j))
           vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j)
        enddo
      endif
     enddo

    else
! 4th order interpolation:
       do j=js-1,je+2
          do i=is-1,ie+1
             vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j))
             vt(i,j) = vc(i,j)
          enddo
       enddo
    endif

 end subroutine d2a2c_vect
 

 subroutine d2a2c_vect_v2( u, v, ua, va, uc, vc, ut, vt )
  real, intent(in) ::  u(isd:ied,jsd:jed+1)
  real, intent(in) ::  v(isd:ied+1,jsd:jed)
  real, intent(out), dimension(isd:ied+1,jsd:jed  ):: uc
  real, intent(out), dimension(isd:ied  ,jsd:jed+1):: vc
  real, intent(out), dimension(isd:ied  ,jsd:jed  ):: ua, va, ut, vt
! Local 
    real, dimension(is-2:ie+2,js-2:je+2):: wk
    real :: utmp, vtmp
    integer i, j

! needs only ut[is-1:ie+2,js-1:je+1], vt[is-1:ie+1,js-1:je+2]

     do j=js-2,je+2
        do i=is-2,ie+3
           uc(i,j) = v(i,j)*dy(i,j)
        enddo
     enddo
     do j=js-2,je+3
        do i=is-2,ie+2
           vc(i,j) = u(i,j)*dx(i,j)
        enddo
     enddo

! D --> A
! Co-variant to Co-variant "vorticity-conserving" interpolation
     do j=js-2,je+2
        do i=is-2,ie+2
           utmp = 0.5*(vc(i,j) + vc(i,j+1)) * rdxa(i,j)
           vtmp = 0.5*(uc(i,j) + uc(i+1,j)) * rdya(i,j)
           ua(i,j) = (utmp-vtmp*cosa_s(i,j))*rsin2(i,j)
           va(i,j) = (vtmp-utmp*cosa_s(i,j))*rsin2(i,j)
        enddo
     enddo

! Xdir:
     if( sw_corner ) then
         ua(-1,0) = -va(0,2)
         ua( 0,0) = -va(0,1) 
     endif
     if( se_corner ) then
         ua(npx,  0) = va(npx,1)
         ua(npx+1,0) = va(npx,2) 
     endif
     if( ne_corner ) then
         ua(npx,  npy) = -va(npx,npy-1)
         ua(npx+1,npy) = -va(npx,npy-2) 
     endif
     if( nw_corner ) then
         ua(-1,npy) = va(0,npy-2)
         ua( 0,npy) = va(0,npy-1) 
     endif

! A -> C
!--------------------------------------------
! Divergence conserving interp to cell walls
!--------------------------------------------
     do j=js-1,je+1
        do i=is-2,ie+2
           wk(i,j) = ua(i,j)*dya(i,j)*sina_s(i,j)
        enddo
     enddo
     do j=js-1,je+1
        do i=is-1,ie+2
           ut(i,j) = 0.5*(wk(i-1,j)+wk(i,j)) / (dy(i,j)*sina_u(i,j))
           uc(i,j) = ut(i,j) + 0.5*(va(i-1,j)*cosa_s(i-1,j)+va(i,j)*cosa_s(i,j))
        enddo
     enddo

     if (grid_type < 3) then
     if ( is==1 ) then
        i=1
        do j=js-1,je+1
!          ut(i,j) = 0.75*(ua(i-1,j)+ua(i,j))-0.25*(ua(i-2,j)+ua(i+1,j))
           ut(i,j) = 0.25*(-ua(-1,j) + 3.*(ua(0,j)+ua(1,j)) - ua(2,j))
           uc(i,j) = ut(i,j)*sina_u(i,j)
        enddo
     endif

     if ( (ie+1)==npx ) then
        i=npx
        do j=js-1,je+1
!          ut(i,j) = 0.75*(ua(i-1,j)+ua(i,j))-0.25*(ua(i-2,j)+ua(i+1,j))
           ut(i,j) = 0.25*(-ua(i-2,j) + 3.*(ua(i-1,j)+ua(i,j)) - ua(i+1,j))
           uc(i,j) = ut(i,j)*sina_u(i,j)
        enddo
     endif
     endif

! Ydir:
     if( sw_corner ) then
         va(0,-1) = -ua(2,0)
         va(0, 0) = -ua(1,0)
     endif
     if( se_corner ) then
         va(npx, 0) = ua(npx-1,0)
         va(npx,-1) = ua(npx-2,0)
     endif
     if( ne_corner ) then
         va(npx,npy  ) = -ua(npx-1,npy)
         va(npx,npy+1) = -ua(npx-2,npy)
     endif
     if( nw_corner ) then
         va(0,npy)   = ua(1,npy)
         va(0,npy+1) = ua(2,npy)
     endif

     do j=js-2,je+2
        do i=is-1,ie+1
           wk(i,j) = va(i,j)*dxa(i,j)*sina_s(i,j)
        enddo
     enddo

     if (grid_type < 3) then
     do j=js-1,je+2
        if ( j==1 .or. j==npy ) then
          do i=is-1,ie+1
             vt(i,j) = 0.25*(-va(i,j-2) + 3.*(va(i,j-1)+va(i,j)) - va(i,j+1))
             vc(i,j) = vt(i,j)*sina_v(i,j)
          enddo
        else
          do i=is-1,ie+1
             vt(i,j) = 0.5*(wk(i,j-1)+wk(i,j)) / (dx(i,j)*sina_v(i,j))
             vc(i,j) = vt(i,j) + 0.5*(ua(i,j-1)*cosa_s(i,j-1)+ua(i,j)*cosa_s(i,j))
          enddo
        endif
     enddo
     else
        do j=js-1,je+2
           do i=is-1,ie+1
              vt(i,j) = 0.5*(wk(i,j-1)+wk(i,j)) / (dx(i,j)*sina_v(i,j))
              vc(i,j) = vt(i,j) + 0.5*(ua(i,j-1)*cosa_s(i,j-1)+ua(i,j)*cosa_s(i,j))
           enddo
        enddo
     endif

 end subroutine d2a2c_vect_v2

 
      
 subroutine d2a2c_vect_v1( u,v, ua,va, uc,vc, ut,vt )
  real, intent(in) ::  u(isd:ied,jsd:jed+1)
  real, intent(in) ::  v(isd:ied+1,jsd:jed)
  real, intent(out), dimension(isd:ied+1,jsd:jed  ):: uc
  real, intent(out), dimension(isd:ied  ,jsd:jed+1):: vc
  real, intent(out), dimension(isd:ied  ,jsd:jed  ):: ua, va, ut, vt
! Local 
  real, dimension(isd:ied,jsd:jed):: v1, v2, v3
  real, dimension(isd:ied,jsd:jed):: utmp, vtmp
    real vw1, vw2, vw3
    real vs1, vs2, vs3
    real up, vp
    integer i, j

! Needs ut[is-1:ie+2,js-1:je+1], vt[is-1:ie+1,js-1:je+2]

     do j=jsd,jed
        do i=isd,ied+1
           uc(i,j) = v(i,j)*dy(i,j)
        enddo
     enddo
     do j=jsd,jed+1
        do i=isd,ied
           vc(i,j) = u(i,j)*dx(i,j)
        enddo
     enddo

! D --> A
     do j=jsd,jed
        do i=isd,ied
           up = 0.5*(vc(i,j) + vc(i,j+1)) * rdxa(i,j)
           vp = 0.5*(uc(i,j) + uc(i+1,j)) * rdya(i,j)
           ua(i,j) = (up-vp*cosa_s(i,j)) * rsin2(i,j)
           va(i,j) = (vp-up*cosa_s(i,j)) * rsin2(i,j)
           v1(i,j) = ua(i,j)*ec1(1,i,j) + va(i,j)*ec2(1,i,j)
           v2(i,j) = ua(i,j)*ec1(2,i,j) + va(i,j)*ec2(2,i,j)
           v3(i,j) = ua(i,j)*ec1(3,i,j) + va(i,j)*ec2(3,i,j)
        enddo
     enddo

! A -> C (across face averaging taking place here):
! Xdir
     call fill3_4corners(v1, v2, v3, 1)
!    call copy_corners(v1, npx, npy, 1)
!    call copy_corners(v2, npx, npy, 1)
!    call copy_corners(v3, npx, npy, 1)

! 4th order interpolation:
     do j=js-1,je+1
        do i=max(3,is-1),min(npx-2,ie+2)
           vw1 = a2*(v1(i-2,j)+v1(i+1,j)) + a1*(v1(i-1,j)+v1(i,j))
           vw2 = a2*(v2(i-2,j)+v2(i+1,j)) + a1*(v2(i-1,j)+v2(i,j))
           vw3 = a2*(v3(i-2,j)+v3(i+1,j)) + a1*(v3(i-1,j)+v3(i,j))
           uc(i,j) = vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1)
           ut(i,j) = (uc(i,j)-v(i,j)*cosa_u(i,j)) * rsin_u(i,j)
        enddo
     enddo

! Fix the edge:
     if ( is==1 ) then
        do j=js-1,je+1
        i=0
           vw1 = c1*v1(-2,j) + c2*v1(-1,j) + c3*v1(0,j) 
           vw2 = c1*v2(-2,j) + c2*v2(-1,j) + c3*v2(0,j) 
           vw3 = c1*v3(-2,j) + c2*v3(-1,j) + c3*v3(0,j) 
           uc(i,j) = vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1)
           ut(i,j) = (uc(i,j)-v(i,j)*cosa_u(i,j)) * rsin_u(i,j)
        i=1
           vw1 = 3.*(v1(0,j)+v1(1,j)) - (v1(-1,j)+v1(2,j))
           vw2 = 3.*(v2(0,j)+v2(1,j)) - (v2(-1,j)+v2(2,j))
           vw3 = 3.*(v3(0,j)+v3(1,j)) - (v3(-1,j)+v3(2,j))
           uc(i,j) = 0.25*(vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1))
           ut(i,j) = uc(i,j)*rsin_u(i,j)
        i=2
           vw1 = c3*v1(1,j) + c2*v1(2,j) + c1*v1(3,j)
           vw2 = c3*v2(1,j) + c2*v2(2,j) + c1*v2(3,j)
           vw3 = c3*v3(1,j) + c2*v3(2,j) + c1*v3(3,j)
           uc(i,j) = vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1)
           ut(i,j) = (uc(i,j)-v(i,j)*cosa_u(i,j)) * rsin_u(i,j)
        enddo
     endif

     if ( (ie+1)==npx ) then
        do j=js-1,je+1
        i=npx-1
           vw1 = c1*v1(npx-3,j) + c2*v1(npx-2,j) + c3*v1(npx-1,j) 
           vw2 = c1*v2(npx-3,j) + c2*v2(npx-2,j) + c3*v2(npx-1,j) 
           vw3 = c1*v3(npx-3,j) + c2*v3(npx-2,j) + c3*v3(npx-1,j) 
           uc(i,j) = vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1)
           ut(i,j) = (uc(i,j)-v(i,j)*cosa_u(i,j)) * rsin_u(i,j)
        i=npx
           vw1 = 3.*(v1(i-1,j)+v1(i,j)) - (v1(i-2,j)+v1(i+1,j))
           vw2 = 3.*(v2(i-1,j)+v2(i,j)) - (v2(i-2,j)+v2(i+1,j))
           vw3 = 3.*(v3(i-1,j)+v3(i,j)) - (v3(i-2,j)+v3(i+1,j))
           uc(i,j) = 0.25*(vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1))
           ut(i,j) = uc(i,j)*rsin_u(i,j)
        i=npx+1
           vw1 = c3*v1(npx,j) + c2*v1(npx+1,j) + c1*v1(npx+2,j) 
           vw2 = c3*v2(npx,j) + c2*v2(npx+1,j) + c1*v2(npx+2,j) 
           vw3 = c3*v3(npx,j) + c2*v3(npx+1,j) + c1*v3(npx+2,j) 
           uc(i,j) = vw1*ew(1,i,j,1) + vw2*ew(2,i,j,1) + vw3*ew(3,i,j,1)
           ut(i,j) = (uc(i,j)-v(i,j)*cosa_u(i,j)) * rsin_u(i,j)
        enddo
     endif

! Ydir:
     call fill3_4corners(v1, v2, v3, 2)
!    call copy_corners(v1, npx, npy, 2)
!    call copy_corners(v2, npx, npy, 2)
!    call copy_corners(v3, npx, npy, 2)

     do j=js-1,je+2
        if( j==0 .or. j==(npy-1) ) then
          do i=is-1,ie+1
             vs1 = c1*v1(i,j-2) + c2*v1(i,j-1) + c3*v1(i,j)
             vs2 = c1*v2(i,j-2) + c2*v2(i,j-1) + c3*v2(i,j)
             vs3 = c1*v3(i,j-2) + c2*v3(i,j-1) + c3*v3(i,j)
             vc(i,j) = vs1*es(1,i,j,2) + vs2*es(2,i,j,2) + vs3*es(3,i,j,2)
             vt(i,j) = (vc(i,j)-u(i,j)*cosa_v(i,j)) * rsin_v(i,j)
          enddo
        elseif ( j==2 .or. j==(npy+1) ) then
          do i=is-1,ie+1
             vs1 = c3*v1(i,j-1) + c2*v1(i,j) + c1*v1(i,j+1)
             vs2 = c3*v2(i,j-1) + c2*v2(i,j) + c1*v2(i,j+1)
             vs3 = c3*v3(i,j-1) + c2*v3(i,j) + c1*v3(i,j+1)
             vc(i,j) = vs1*es(1,i,j,2) + vs2*es(2,i,j,2) + vs3*es(3,i,j,2)
             vt(i,j) = (vc(i,j)-u(i,j)*cosa_v(i,j)) * rsin_v(i,j)
          enddo
        elseif ( j==1 .or. j==npy ) then
          do i=is-1,ie+1
              vs1 = 3.*(v1(i,j-1)+v1(i,j)) - (v1(i,j-2)+v1(i,j+1))
              vs2 = 3.*(v2(i,j-1)+v2(i,j)) - (v2(i,j-2)+v2(i,j+1))
              vs3 = 3.*(v3(i,j-1)+v3(i,j)) - (v3(i,j-2)+v3(i,j+1))
              vc(i,j) = 0.25*(vs1*es(1,i,j,2) + vs2*es(2,i,j,2) + vs3*es(3,i,j,2))
              vt(i,j) = vc(i,j)*rsin_v(i,j)
          enddo
        else
! Interior: 4th order
          do i=is-1,ie+1
             vs1 = a2*(v1(i,j-2)+v1(i,j+1)) + a1*(v1(i,j-1)+v1(i,j))
             vs2 = a2*(v2(i,j-2)+v2(i,j+1)) + a1*(v2(i,j-1)+v2(i,j))
             vs3 = a2*(v3(i,j-2)+v3(i,j+1)) + a1*(v3(i,j-1)+v3(i,j))
             vc(i,j) = vs1*es(1,i,j,2) + vs2*es(2,i,j,2) + vs3*es(3,i,j,2)
             vt(i,j) = (vc(i,j)-u(i,j)*cosa_v(i,j)) * rsin_v(i,j)
          enddo
        endif
     enddo

 end subroutine d2a2c_vect_v1
      

 subroutine fill3_4corners(q1, q2, q3, dir)
! This routine fill the 4 corners of the scalar fileds only as needed by c_core
  integer, intent(in):: dir                ! 1: x-dir; 2: y-dir
  real, intent(inout):: q1(isd:ied,jsd:jed)
  real, intent(inout):: q2(isd:ied,jsd:jed)
  real, intent(inout):: q3(isd:ied,jsd:jed)
  integer i,j

  select case(dir)
  case(1)
      if ( sw_corner ) then
          q1(-1,0) = q1(0,2); q1(0,0) = q1(0,1); q1(0,-1) = q1(-1,1)
          q2(-1,0) = q2(0,2); q2(0,0) = q2(0,1); q2(0,-1) = q2(-1,1)
          q3(-1,0) = q3(0,2); q3(0,0) = q3(0,1); q3(0,-1) = q3(-1,1)
      endif
      if ( se_corner ) then
          q1(npx+1,0) = q1(npx,2); q1(npx,0) = q1(npx,1); q1(npx,-1) = q1(npx+1,1)
          q2(npx+1,0) = q2(npx,2); q2(npx,0) = q2(npx,1); q2(npx,-1) = q2(npx+1,1)
          q3(npx+1,0) = q3(npx,2); q3(npx,0) = q3(npx,1); q3(npx,-1) = q3(npx+1,1)
      endif
      if ( ne_corner ) then
          q1(npx,npy) = q1(npx,npy-1); q1(npx+1,npy) = q1(npx,npy-2); q1(npx,npy+1) = q1(npx+1,npy-1)
          q2(npx,npy) = q2(npx,npy-1); q2(npx+1,npy) = q2(npx,npy-2); q2(npx,npy+1) = q2(npx+1,npy-1)
          q3(npx,npy) = q3(npx,npy-1); q3(npx+1,npy) = q3(npx,npy-2); q3(npx,npy+1) = q3(npx+1,npy-1)
      endif
      if ( nw_corner ) then
          q1(0,npy) = q1(0,npy-1); q1(-1,npy) = q1(0,npy-2); q1(0,npy+1) = q1(-1,npy-1)
          q2(0,npy) = q2(0,npy-1); q2(-1,npy) = q2(0,npy-2); q2(0,npy+1) = q2(-1,npy-1)
          q3(0,npy) = q3(0,npy-1); q3(-1,npy) = q3(0,npy-2); q3(0,npy+1) = q3(-1,npy-1)
      endif

  case(2)
      if ( sw_corner ) then
          q1(0,0) = q1(1,0); q1(0,-1) = q1(2,0); q1(-1,0) = q1(1,-1)
          q2(0,0) = q2(1,0); q2(0,-1) = q2(2,0); q2(-1,0) = q2(1,-1)
          q3(0,0) = q3(1,0); q3(0,-1) = q3(2,0); q3(-1,0) = q3(1,-1)
      endif
      if ( se_corner ) then
          q1(npx,0) = q1(npx-1,0); q1(npx,-1) = q1(npx-2,0); q1(npx+1,0) = q1(npx-1,-1)
          q2(npx,0) = q2(npx-1,0); q2(npx,-1) = q2(npx-2,0); q2(npx+1,0) = q2(npx-1,-1)
          q3(npx,0) = q3(npx-1,0); q3(npx,-1) = q3(npx-2,0); q3(npx+1,0) = q3(npx-1,-1)
      endif
      if ( ne_corner ) then
          q1(npx,npy) = q1(npx-1,npy); q1(npx,npy+1) = q1(npx-2,npy); q1(npx+1,npy) = q1(npx-1,npy+1)
          q2(npx,npy) = q2(npx-1,npy); q2(npx,npy+1) = q2(npx-2,npy); q2(npx+1,npy) = q2(npx-1,npy+1)
          q3(npx,npy) = q3(npx-1,npy); q3(npx,npy+1) = q3(npx-2,npy); q3(npx+1,npy) = q3(npx-1,npy+1)
      endif
      if ( nw_corner ) then
          q1(0,npy) = q1(1,npy); q1(0,npy+1) = q1(2,npy); q1(-1,npy) = q1(1,npy+1)
          q2(0,npy) = q2(1,npy); q2(0,npy+1) = q2(2,npy); q2(-1,npy) = q2(1,npy+1)
          q3(0,npy) = q3(1,npy); q3(0,npy+1) = q3(2,npy); q3(-1,npy) = q3(1,npy+1)
      endif

  end select
 end subroutine fill3_4corners


 subroutine fill2_4corners(q1, q2, dir)
! This routine fill the 4 corners of the scalar fileds only as needed by c_core
  integer, intent(in):: dir                ! 1: x-dir; 2: y-dir
  real, intent(inout):: q1(isd:ied,jsd:jed)
  real, intent(inout):: q2(isd:ied,jsd:jed)

  select case(dir)
  case(1)
      if ( sw_corner ) then
          q1(-1,0) = q1(0,2);    q1(0,0) = q1(0,1)
          q2(-1,0) = q2(0,2);    q2(0,0) = q2(0,1)
      endif
      if ( se_corner ) then
          q1(npx+1,0) = q1(npx,2); q1(npx,0) = q1(npx,1)
          q2(npx+1,0) = q2(npx,2); q2(npx,0) = q2(npx,1)
      endif
      if ( nw_corner ) then
          q1(0,npy) = q1(0,npy-1); q1(-1,npy) = q1(0,npy-2)
          q2(0,npy) = q2(0,npy-1); q2(-1,npy) = q2(0,npy-2)
      endif
      if ( ne_corner ) then
          q1(npx,npy) = q1(npx,npy-1); q1(npx+1,npy) = q1(npx,npy-2)
          q2(npx,npy) = q2(npx,npy-1); q2(npx+1,npy) = q2(npx,npy-2)
      endif

  case(2)
      if ( sw_corner ) then
          q1(0,0) = q1(1,0); q1(0,-1) = q1(2,0)
          q2(0,0) = q2(1,0); q2(0,-1) = q2(2,0)
      endif
      if ( se_corner ) then
          q1(npx,0) = q1(npx-1,0); q1(npx,-1) = q1(npx-2,0)
          q2(npx,0) = q2(npx-1,0); q2(npx,-1) = q2(npx-2,0)
      endif
      if ( nw_corner ) then
          q1(0,npy) = q1(1,npy); q1(0,npy+1) = q1(2,npy)
          q2(0,npy) = q2(1,npy); q2(0,npy+1) = q2(2,npy)
      endif
      if ( ne_corner ) then
          q1(npx,npy) = q1(npx-1,npy); q1(npx,npy+1) = q1(npx-2,npy)
          q2(npx,npy) = q2(npx-1,npy); q2(npx,npy+1) = q2(npx-2,npy)
      endif

  end select

 end subroutine fill2_4corners

 subroutine fill_4corners(q, dir)
! This routine fill the 4 corners of the scalar fileds only as needed by c_core
  integer, intent(in):: dir                ! 1: x-dir; 2: y-dir
  real, intent(inout):: q(isd:ied,jsd:jed)

  select case(dir)
  case(1)
      if ( sw_corner ) then
          q(-1,0) = q(0,2)
          q( 0,0) = q(0,1)
      endif
      if ( se_corner ) then
          q(npx+1,0) = q(npx,2)
          q(npx,  0) = q(npx,1)
      endif
      if ( nw_corner ) then
          q( 0,npy) = q(0,npy-1)
          q(-1,npy) = q(0,npy-2)
      endif
      if ( ne_corner ) then
          q(npx,  npy) = q(npx,npy-1)
          q(npx+1,npy) = q(npx,npy-2)
      endif

  case(2)
      if ( sw_corner ) then
          q(0, 0) = q(1,0)
          q(0,-1) = q(2,0)
      endif
      if ( se_corner ) then
          q(npx, 0) = q(npx-1,0)
          q(npx,-1) = q(npx-2,0)
      endif
      if ( nw_corner ) then
          q(0,npy  ) = q(1,npy)
          q(0,npy+1) = q(2,npy)
      endif
      if ( ne_corner ) then
          q(npx,npy  ) = q(npx-1,npy)
          q(npx,npy+1) = q(npx-2,npy)
      endif

  end select

 end subroutine fill_4corners


#ifdef REL_VOR_DMP
 subroutine del6_flux( nord, npx, npy, damp, q, u, v)
! Del-nord damping for the relative vorticity
!------------------
! nord = 0:   del-2
! nord = 1:   del-4
! nord = 2:   del-6
!------------------
   integer, intent(in):: nord            ! del-n
   integer, intent(in):: npx, npy
   real, intent(in):: damp
   real, intent(in):: q(isd:ied, jsd:jed)  ! q ghosted on input
   real, intent(inout),  dimension(isd:ied,  jsd:jed+1):: u
   real, intent(inout),  dimension(isd:ied+1,jsd:jed  ):: v
! local:
   real fx2(isd:ied+1,jsd:jed), fy2(isd:ied,jsd:jed+1)
   real d2(isd:ied,jsd:jed)
   integer i,j, n, nt


   do j=jsd,jed
      do i=isd,ied
         d2(i,j) = damp*q(i,j)
      enddo
   enddo

   if( nord>0 ) call copy_corners(d2, npx, npy, 1)
   do j=js-nord,je+nord
      do i=is-nord,ie+nord+1
         fx2(i,j) = dy(i,j)*sina_u(i,j)*(d2(i-1,j)-d2(i,j))*rdxc(i,j)
      enddo
   enddo

   if( nord>0 ) call copy_corners(d2, npx, npy, 2)
   do j=js-nord,je+nord+1
      do i=is-nord,ie+nord
         fy2(i,j) = dx(i,j)*sina_v(i,j)*(d2(i,j-1)-d2(i,j))*rdyc(i,j)
      enddo
   enddo

   if ( nord>0 ) then

!----------
! high-order
!----------

   do n=1, nord

      nt = nord-n

      do j=js-nt-1,je+nt+1
         do i=is-nt-1,ie+nt+1
            d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j)
         enddo
      enddo

      call copy_corners(d2, npx, npy, 1)
      do j=js-nt,je+nt
         do i=is-nt,ie+nt+1
            fx2(i,j) = dy(i,j)*sina_u(i,j)*(d2(i,j)-d2(i-1,j))*rdxc(i,j)
         enddo
      enddo

      call copy_corners(d2, npx, npy, 2)
      do j=js-nt,je+nt+1
         do i=is-nt,ie+nt
            fy2(i,j) = dx(i,j)*sina_v(i,j)*(d2(i,j)-d2(i,j-1))*rdyc(i,j)
         enddo
      enddo
   enddo

   endif

   do j=js,je
      do i=is,ie+1
         u(i,j) = u(i,j) + fx2(i,j)
      enddo
   enddo

   do j=js,je+1
      do i=is,ie
         v(i,j) = v(i,j) - fy2(i,j)
      enddo
   enddo

 end subroutine del6_flux
#endif


 subroutine d2a2c(u, v, um, vm,  ua, va, uc, vc, dord4)
  real, intent(in), dimension(isd:ied,jsd:jed+1):: u, um
  real, intent(in), dimension(isd:ied+1,jsd:jed):: v, vm
  logical, intent(in):: dord4
  real, intent(out), dimension(isd:ied+1,jsd:jed  ):: uc
  real, intent(out), dimension(isd:ied  ,jsd:jed+1):: vc
  real, intent(out), dimension(isd:ied  ,jsd:jed  ):: ua, va
! Local 
  real, dimension(isd:ied,jsd:jed):: utmp, vtmp
  integer npt, i, j, ifirst, ilast, id

  if ( dord4 ) then
       id = 1
  else
       id = 0
  endif


  if (grid_type < 3) then
     npt = 4
  else
     npt = -2
  endif

!----------
! Interior:
!----------
  do j=max(npt,js-1),min(npy-npt,je+1)
     do i=max(npt,isd),min(npx-npt,ied)
        utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1))
     enddo
  enddo
  do j=max(npt,jsd),min(npy-npt,jed)
     do i=max(npt,is-1),min(npx-npt,ie+1)
        vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j))
     enddo
  enddo

!----------
! edges:
!----------
  if (grid_type < 3) then

  if ( js==1 .or. jsd<npt) then
      do j=jsd,npt-1
         do i=isd,ied
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
         enddo
      enddo
  endif
  if ( (je+1)==npy .or. jed>=(npy-npt)) then
      do j=npy-npt+1,jed
         do i=isd,ied
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
         enddo
      enddo
  endif
  if ( is==1 .or. isd<npt ) then
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=isd,npt-1
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
         enddo
      enddo
  endif
  if ( (ie+1)==npx .or. ied>=(npx-npt)) then
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=npx-npt+1,ied
            utmp(i,j) = 0.5*(u(i,j) + u(i,j+1))
            vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j))
         enddo
      enddo
  endif

  endif

  do j=js-1-id,je+1+id
     do i=is-1-id,ie+1+id
        ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j)
        va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j)
     enddo
  enddo

! Re-compute (utmp, vtmp) using (um,vm)
!----------
! Interior:
!----------
  do j=max(npt,js-1),min(npy-npt,je+1)
     do i=max(npt,isd),min(npx-npt,ied)
        utmp(i,j) = a2*(um(i,j-1)+um(i,j+2)) + a1*(um(i,j)+um(i,j+1))
     enddo
  enddo
  do j=max(npt,jsd),min(npy-npt,jed)
     do i=max(npt,is-1),min(npx-npt,ie+1)
        vtmp(i,j) = a2*(vm(i-1,j)+vm(i+2,j)) + a1*(vm(i,j)+vm(i+1,j))
     enddo
  enddo

!----------
! edges:
!----------
  if (grid_type < 3) then

  if ( js==1 .or. jsd<npt) then
      do j=jsd,npt-1
         do i=isd,ied
            utmp(i,j) = 0.5*(um(i,j) + um(i,j+1))
            vtmp(i,j) = 0.5*(vm(i,j) + vm(i+1,j))
         enddo
      enddo
  endif
  if ( (je+1)==npy .or. jed>=(npy-npt)) then
      do j=npy-npt+1,jed
         do i=isd,ied
            utmp(i,j) = 0.5*(um(i,j) + um(i,j+1))
            vtmp(i,j) = 0.5*(vm(i,j) + vm(i+1,j))
         enddo
      enddo
  endif
  if ( is==1 .or. isd<npt ) then
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=isd,npt-1
            utmp(i,j) = 0.5*(um(i,j) + um(i,j+1))
            vtmp(i,j) = 0.5*(vm(i,j) + vm(i+1,j))
         enddo
      enddo
  endif
  if ( (ie+1)==npx .or. ied>=(npx-npt)) then
      do j=max(npt,jsd),min(npy-npt,jed)
         do i=npx-npt+1,ied
            utmp(i,j) = 0.5*(um(i,j) + um(i,j+1))
            vtmp(i,j) = 0.5*(vm(i,j) + vm(i+1,j))
         enddo
      enddo
  endif

  endif

! A -> C
!--------------
! Fix the edges
!--------------
! Xdir:
     if( sw_corner ) then
         do i=-2,0
            utmp(i,0) = -vtmp(0,1-i)
         enddo
     endif
     if( se_corner ) then
         do i=0,2
            utmp(npx+i,0) = vtmp(npx,i+1)
         enddo
     endif
     if( ne_corner ) then
         do i=0,2
            utmp(npx+i,npy) = -vtmp(npx,je-i)
         enddo
     endif
     if( nw_corner ) then
         do i=-2,0
            utmp(i,npy) = vtmp(0,je+i)
         enddo
     endif

  if (grid_type < 3) then
     ifirst = max(3,    is  )
     ilast  = min(npx-2,ie+1)
  else
     ifirst = is
     ilast  = ie+1
  endif
!---------------------------------------------
! 4th order interpolation for interior points:
!---------------------------------------------
     do j=js,je
        do i=ifirst,ilast
           uc(i,j) = a1*(utmp(i-1,j)+utmp(i,j))+a2*(utmp(i-2,j)+utmp(i+1,j))
        enddo
     enddo

     if (grid_type < 3) then

     if( is==1 ) then
        do j=js,je
! 3-pt extrapolation --------------------------------------------------
           uc(1,j) = ( t14*(utmp( 0,j)+utmp(1,j))    &
                     + t12*(utmp(-1,j)+utmp(2,j))    &
                     + t15*(utmp(-2,j)+utmp(3,j)) )*rsin_u(1,j)
           uc(2,j) = c1*utmp(3,j) + c2*utmp(2,j) + c3*utmp(1,j)
        enddo
     endif

     if( (ie+1)==npx ) then
        do j=js,je
           uc(npx-1,j) = c1*utmp(npx-3,j)+c2*utmp(npx-2,j)+c3*utmp(npx-1,j) 
! 3-pt extrapolation --------------------------------------------------------
           uc(npx,j) = (t14*(utmp(npx-1,j)+utmp(npx,j))+      &
                        t12*(utmp(npx-2,j)+utmp(npx+1,j))     &
                      + t15*(utmp(npx-3,j)+utmp(npx+2,j)))*rsin_u(npx,j)
        enddo
     endif

     endif

!------
! Ydir:
!------
     if( sw_corner ) then
         do j=-2,0
            vtmp(0,j) = -utmp(1-j,0)
         enddo
     endif
     if( nw_corner ) then
         do j=0,2
            vtmp(0,npy+j) = utmp(j+1,npy)
         enddo
     endif
     if( se_corner ) then
         do j=-2,0
            vtmp(npx,j) = utmp(ie+j,0)
         enddo
     endif
     if( ne_corner ) then
         do j=0,2
            vtmp(npx,npy+j) = -utmp(ie-j,npy)
         enddo
     endif

     if (grid_type < 3) then

     do j=js,je+1
      if ( j==1 ) then
        do i=is,ie
! 3-pt extrapolation -----------------------------------------
           vc(i,1) = (t14*(vtmp(i, 0)+vtmp(i,1))    &
                    + t12*(vtmp(i,-1)+vtmp(i,2))    &
                    + t15*(vtmp(i,-2)+vtmp(i,3)))*rsin_v(i,1)
        enddo
      elseif ( j==(npy-1) ) then
        do i=is,ie
           vc(i,j) = c1*vtmp(i,j-2) + c2*vtmp(i,j-1) + c3*vtmp(i,j)
        enddo
      elseif ( j==2 ) then
        do i=is,ie
!          vc(i,j) = c1*vtmp(i,j+1) + c2*vtmp(i,j) + c3*vtmp(i,j-1)
           vc(i,j) = c3*vtmp(i,j-1) + c2*vtmp(i,j) + c1*vtmp(i,j+1)
        enddo
      elseif ( j==npy ) then
        do i=is,ie
! 3-pt extrapolation --------------------------------------------------------
           vc(i,npy) = (t14*(vtmp(i,npy-1)+vtmp(i,npy))    &
                      + t12*(vtmp(i,npy-2)+vtmp(i,npy+1))  &
                      + t15*(vtmp(i,npy-3)+vtmp(i,npy+2)))*rsin_v(i,npy)
        enddo
      else
! 4th order interpolation for interior points:
        do i=is,ie
           vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j))
        enddo
      endif
     enddo

    else
! 4th order interpolation:
       do j=js,je+1
          do i=is,ie
             vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j))
          enddo
       enddo
    endif

 end subroutine d2a2c

 end module sw_core_mod



module tp_core_mod
!BOP
!
! !MODULE: tp_core --- A collection of routines to support FV transport
!
 use fv_mp_mod,         only: is,js,ie,je, ng, isd,jsd,ied,jed
 use fv_grid_utils_mod, only: sw_corner, se_corner, ne_corner, nw_corner, &
                              sina_u, sina_v, da_min
 use fv_grid_tools_mod, only: dx, dy, rdxc, rdyc, rarea, dxa, dya, grid_type

 implicit none

 private
 public fv_tp_2d, pert_ppm, copy_corners

 real, parameter:: r3 = 1./3.

#ifdef WAVE_FORM
! Suresh & Huynh scheme 2.2 (purtabation form)
! The wave-form is more diffusive than scheme 2.1
 real, parameter:: b1 =   0.0375
 real, parameter:: b2 =  -7./30.
 real, parameter:: b3 =  -23./120.
 real, parameter:: b4 =  13./30.
 real, parameter:: b5 = -11./240.
#else
! scheme 2.1: perturbation form
 real, parameter:: b1 =   1./30.
 real, parameter:: b2 = -13./60.
 real, parameter:: b3 = -13./60.
 real, parameter:: b4 =  0.45
 real, parameter:: b5 = -0.05
#endif
 real, parameter:: t11 = 27./28., t12 = -13./28., t13=3./7.
 real, parameter:: s11 = 11./14., s14 = 4./7.,    s15=3./14.
!----------------------------------------------------
! volume-conserving cubic with 2nd drv=0 at end point:
!----------------------------------------------------
! Non-monotonic
  real, parameter:: c1 = -2./14.
  real, parameter:: c2 = 11./14.
  real, parameter:: c3 =  5./14.
!----------------------
! PPM volume mean form:
!----------------------
  real, parameter:: p1 =  7./12.     ! 0.58333333
  real, parameter:: p2 = -1./12.


!
! !DESCRIPTION:
!
! !REVISION HISTORY:
!
!EOP
!-----------------------------------------------------------------------

CONTAINS

 subroutine fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, &
                     xfx, yfx, area, ra_x, ra_y, mfx, mfy, ppm_fac, nord, damp_c)
   integer, intent(in):: npx, npy
   integer, intent(in)::hord

   real, intent(in)::  crx(is:ie+1,jsd:jed)  !
   real, intent(in)::  xfx(is:ie+1,jsd:jed)  !
   real, intent(in)::  cry(isd:ied,js:je+1 )  !
   real, intent(in)::  yfx(isd:ied,js:je+1 )  !
   real, intent(in):: area(isd:ied,jsd:jed)
   real, intent(in):: ra_x(is:ie,jsd:jed)
   real, intent(in):: ra_y(isd:ied,js:je)
   real, intent(inout):: q(isd:ied,jsd:jed)  ! transported scalar
   real, intent(out)::fx(is:ie+1 ,js:je)    ! Flux in x ( E )
   real, intent(out)::fy(is:ie,   js:je+1 )    ! Flux in y ( N )
! optional Arguments:
   real, OPTIONAL, intent(in):: mfx(is:ie+1,js:je  )  ! Mass Flux X-Dir
   real, OPTIONAL, intent(in):: mfy(is:ie  ,js:je+1)  ! Mass Flux Y-Dir
   real, OPTIONAL, intent(in):: ppm_fac               ! for ord=4 option
   real, OPTIONAL, intent(in):: damp_c
   integer, OPTIONAL, intent(in):: nord
! Local:
   integer ord, ord_in
   real q_i(isd:ied,js:je)
   real q_j(is:ie,jsd:jed)
   real   fx2(is:ie+1,jsd:jed)
   real   fy2(isd:ied,js:je+1)
   real   fyy(isd:ied,js:je+1)
   real   fx1(is:ie+1)
   real   ppm_limiter, damp
   integer i, j


   if ( hord < 0 ) then
        ord_in = 2 ! more dissipation
        ord    = abs(hord)
   else
        ord_in = hord
        ord    = hord
   endif

   if ( present (ppm_fac) ) then
        ppm_limiter = ppm_fac
   else
        ppm_limiter = 2.0
   endif

   call copy_corners(q, npx, npy, 2)
   call ytp(fy2, q, cry, ord_in, isd, ied, js, je, npx, npy, ppm_limiter)

   do j=js,je+1
      do i=isd,ied
         fyy(i,j) = yfx(i,j) * fy2(i,j) 
      enddo
   enddo
   do j=js,je
      do i=isd,ied
         q_i(i,j) = (q(i,j)*area(i,j) + fyy(i,j)-fyy(i,j+1))/ra_y(i,j)
      enddo
  enddo
  call xtp(fx, q_i, crx(is,js), ord, is, ie, js,  je, npx, npy, ppm_limiter)

  call copy_corners(q, npx, npy, 1)
  call xtp(fx2, q, crx, ord_in, is, ie, jsd,jed, npx, npy, ppm_limiter)

  do j=jsd,jed
     do i=is,ie+1
        fx1(i) =  xfx(i,j) * fx2(i,j)
     enddo
     do i=is,ie
        q_j(i,j) = (q(i,j)*area(i,j) + fx1(i)-fx1(i+1))/ra_x(i,j)
     enddo
  enddo
  call ytp(fy, q_j, cry, ord, is, ie, js, je, npx, npy, ppm_limiter)

!----------------
! Flux averaging:
!----------------

   if ( present(mfx) .and. present(mfy) ) then
!---------------------------------
! For transport of pt and tracers
!---------------------------------
      do j=js,je
         do i=is,ie+1
            fx(i,j) = 0.5*(fx(i,j) + fx2(i,j)) * mfx(i,j)
         enddo
      enddo
      do j=js,je+1
         do i=is,ie
            fy(i,j) = 0.5*(fy(i,j) + fy2(i,j)) * mfy(i,j)
         enddo
      enddo
      if ( present(nord) .and. present(damp_c) ) then
        if ( damp_c > 1.e-4 ) then
           damp = (damp_c * da_min)**(nord+1)
           call deln_flux( nord, npx, npy, damp, q, fx, fy, mfx, mfy )
        endif
      endif
   else
!---------------------------------
! For transport of delp, vorticity
!---------------------------------
      do j=js,je
         do i=is,ie+1
            fx(i,j) = 0.5*(fx(i,j) + fx2(i,j)) * xfx(i,j)
         enddo
      enddo
      do j=js,je+1
         do i=is,ie
            fy(i,j) = 0.5*(fy(i,j) + fy2(i,j)) * yfx(i,j)
         enddo
      enddo
      if ( present(nord) .and. present(damp_c) ) then
           if ( damp_c > 1.E-4 ) then
                damp = (damp_c * da_min)**(nord+1)
                call deln_flux( nord, npx, npy, damp, q, fx, fy, xfx(is:ie+1,js:je), yfx(is:ie,js:je+1) )
           endif
      endif
   endif

 end subroutine fv_tp_2d


 subroutine copy_corners(q, npx, npy, dir)
 integer, intent(in):: npx, npy, dir
 real, intent(inout):: q(isd:ied,jsd:jed)
 integer  i,j

 if ( dir == 1 ) then
! XDir:
    if ( sw_corner ) then
         do j=1-ng,0
            do i=1-ng,0
               q(i,j) = q(j,1-i)
            enddo
         enddo
    endif
    if ( se_corner ) then
         do j=1-ng,0
            do i=npx,npx+ng-1
               q(i,j) = q(npy-j,i-npx+1)
            enddo
         enddo
    endif
    if ( ne_corner ) then
         do j=npy,npy+ng-1
            do i=npx,npx+ng-1
               q(i,j) = q(j,2*npx-1-i)
            enddo
         enddo
    endif
    if ( nw_corner ) then
         do j=npy,npy+ng-1
            do i=1-ng,0
               q(i,j) = q(npy-j,i-1+npx)
            enddo
         enddo
    endif

 elseif ( dir == 2 ) then
! YDir:

    if ( sw_corner ) then
         do j=1-ng,0
            do i=1-ng,0
               q(i,j) = q(1-j,i)
            enddo
         enddo
    endif
    if ( se_corner ) then
         do j=1-ng,0
            do i=npx,npx+ng-1
               q(i,j) = q(npy+j-1,npx-i)
            enddo
         enddo
    endif
    if ( ne_corner ) then
         do j=npy,npy+ng-1
            do i=npx,npx+ng-1
               q(i,j) = q(2*npy-1-j,i)
            enddo
         enddo
    endif
    if ( nw_corner ) then
         do j=npy,npy+ng-1
            do i=1-ng,0
               q(i,j) = q(j+1-npx,npy-i)
            enddo
         enddo
    endif

 endif
      
 end subroutine copy_corners


 subroutine xtp(fx,  q,  c, iord, ifirst, ilast, jfirst, jlast, npx, npy, ppm_limiter)
   integer, intent(IN):: ifirst, ilast   !  X-Dir strip
   integer, intent(IN):: jfirst, jlast   !  Y-Dir strip
   integer, intent(IN):: npx, npy
   integer, intent(IN):: iord
   real   , intent(in):: c(is :ie+1, jfirst:jlast)      ! Courant numbers
   real   , intent(in):: q(isd:ied,  jfirst:jlast)
   real   , intent(IN):: ppm_limiter
   real   , intent(out):: fx(ifirst:ilast+1,jfirst:jlast)           
! Local:
   real   dm(is-2:ie+2)
   real   x0, x1
   integer i, j

   if (iord==1) then

      do j=jfirst,jlast
         do i=ifirst,ilast+1
           if ( c(i,j)>0. ) then
                fx(i,j) = q(i-1,j)
           else
                fx(i,j) = q(i,j)
           endif
         enddo
      enddo

   elseif (iord==2) then

     do j=jfirst,jlast
        do i=is-2,ie+2
           dm(i) = 0.25*(q(i+1,j) - q(i-1,j))
           dm(i) = sign(min(abs(dm(i)), max(q(i-1,j),q(i,j),q(i+1,j)) - q(i,j),  &
                               q(i,j) - min(q(i-1,j),q(i,j),q(i+1,j))), dm(i))
        enddo

      if (grid_type < 3) then
!--------------
! fix the edges
!--------------
        if ( is==1 ) then
             x0 = 0.5*((2.*dxa(1,j)+dxa(2,j))*(q(0,j)+q(1,j))   &
                - dxa(1,j)*(q(-1,j)+q(2,j)))/ ( dxa(1,j)+dxa(2,j))
             x1 = s15*q(1,j) + s11*q(2,j) - s14*dm(2)
           dm(1) = 0.5*(x1 - x0)
           dm(1) = sign( min(abs(dm(1)), max(q(1,j), x0, x1) - q(1,j),   &
                                q(1,j) - min(q(1,j), x0, x1)), dm(1) )
!
              x1 = s15*q(0,j) + s11*q(-1,j) + s14*dm(-1)
           dm(0) = 0.5*(x0 - x1)
           dm(0) = sign(min(abs(dm(0)), max(q(0,j), x0, x1) - q(0,j),   &
                               q(0,j) - min(q(0,j), x0, x1)),  dm(0))
        endif

        if ( (ie+1)==npx ) then
              x0 = 0.5*( (2.*dxa(npx-1,j)+dxa(npx-2,j))*(q(npx-1,j)+q(npx,j))   &
                - dxa(npx-1,j)*(q(npx-2,j)+q(npx+1,j)))/( dxa(npx-1,j)+dxa(npx-2,j))
              x1 = s15*q(npx-1,j) + s11*q(npx-2,j) + s14*dm(npx-2)
           dm(npx-1) = 0.5*(x0 - x1)
           dm(npx-1) = sign(min(abs(dm(npx-1)), max(q(npx-1,j), x0, x1) - q(npx-1,j),  &
                                   q(npx-1,j) - min(q(npx-1,j), x0, x1)), dm(npx-1))
!
                x1 = s15*q(npx,j) + s11*q(npx+1,j) - s14*dm(npx+1)
           dm(npx) = 0.5*(x1 - x0)
           dm(npx) = sign(min(abs(dm(npx)), max(q(npx,j), x0, x1) - q(npx,j),   &
                                 q(npx,j) - min(q(npx,j), x0, x1)), dm(npx))
        endif
      endif

        do i=is,ie+1
           if ( c(i,j)>0. ) then
                fx(i,j) = q(i-1,j) + (1.-c(i,j))*dm(i-1)
           else
                fx(i,j) = q(i,  j) - (1.+c(i,j))*dm(i)
           endif
        enddo
     enddo

   else
      call fxppm(c, q, fx, iord, ifirst, ilast, jfirst, jlast, npx, npy, ppm_limiter)
   endif

 end subroutine xtp



 subroutine ytp(fy, q, c, jord, ifirst, ilast, jfirst, jlast, npx, npy, ppm_limiter)
 integer, intent(in) :: npx, npy
 integer, INTENT(IN) :: ifirst, ilast  !  X-Dir strip
 integer, INTENT(IN) :: jfirst, jlast  !  Y-Dir strip
 integer, intent(in):: jord
 real, intent(in)::   q(ifirst:ilast,jfirst-ng:jlast+ng) 
 real, intent(in)::   c(isd:ied,js:je+1 )  ! Courant number
 real, intent(in)::  ppm_limiter
 real, intent(out):: fy(ifirst:ilast,jfirst:jlast+1)     !  Flux
! !LOCAL VARIABLES:
 real   dm(ifirst:ilast,jfirst-2:jlast+2)
 real   x0, x1
 integer i, j

   if(jord==1) then

      do j=jfirst,jlast+1
         do i=ifirst,ilast
            if ( c(i,j)>0. ) then
                 fy(i,j) = q(i,j-1)
            else
                 fy(i,j) = q(i,j)
            endif
         enddo
      enddo

   elseif (jord==2) then

      do j=jfirst-2,jlast+2
         do i=ifirst,ilast
            dm(i,j) = 0.25*(q(i,j+1) - q(i,j-1))
            dm(i,j) = sign(min(abs(dm(i,j)), max(q(i,j-1),q(i,j),q(i,j+1)) - q(i,j),  &
                                    q(i,j) - min(q(i,j-1),q(i,j),q(i,j+1))), dm(i,j))
         enddo
      enddo
!--------------
! Fix the edges:
!--------------
    if (grid_type < 3) then
      if( js==1 ) then
         do i=ifirst,ilast
            x0 = 0.5*((2.*dya(i,1)+dya(i,2))*(q(i,0)+q(i,1))   &
               -dya(i,1)*(q(i,-1)+q(i,2))) / ( dya(i,1)+dya(i,2) )
            x1 = s15*q(i,1) + s11*q(i,2) - s14*dm(i,2)
            dm(i,1) = 0.5*(x1 - x0)
            dm(i,1) = sign(min(abs(dm(i,1)), max(q(i,1), x0, x1) - q(i,1),  &
                                    q(i,1) - min(q(i,1), x0, x1)), dm(i,1))
!
            x1 = s15*q(i,0) + s11*q(i,-1) + s14*dm(i,-1)
            dm(i,0) = 0.5*(x0 - x1)
            dm(i,0) = sign(min(abs(dm(i,0)), max(q(i,0), x0, x1) - q(i,0),   &
                                    q(i,0) - min(q(i,0), x0, x1)), dm(i,0))
         enddo
      endif

      if( (je+1)==npy ) then
         do i=ifirst,ilast
            x0 = 0.5*((2.*dya(i,npy-1)+dya(i,npy-2))*(q(i,npy-1)+q(i,npy))  &
               -dya(i,npy-1)*(q(i,npy-2)+q(i,npy+1)))/(dya(i,npy-1)+dya(i,npy-2))
            x1 = s15*q(i,npy-1) + s11*q(i,npy-2) + s14*dm(i,npy-2)
            dm(i,npy-1) = 0.5*(x0 - x1)
            dm(i,npy-1) = sign(min(abs(dm(i,npy-1)), max(q(i,npy-1), x0, x1) - q(i,npy-1),  &
                                        q(i,npy-1) - min(q(i,npy-1), x0, x1)), dm(i,npy-1))
!
            x1 = s15*q(i,npy) + s11*q(i,npy+1) - s14*dm(i,npy+1)
            dm(i,npy) = 0.5*(x1 - x0)
            dm(i,npy) = sign(min(abs(dm(i,npy)), max(q(i,npy), x0, x1) - q(i,npy),  &
                                      q(i,npy) - min(q(i,npy), x0, x1)), dm(i,npy))
         enddo
      endif
    endif

      do j=jfirst,jlast+1
         do i=ifirst,ilast
            if ( c(i,j)>0. ) then
                 fy(i,j) = q(i,j-1) + (1.-c(i,j))*dm(i,j-1)
            else
                 fy(i,j) = q(i,j) - (1.+c(i,j))*dm(i,j)
            endif
         enddo
      enddo

   else
      call fyppm(c, q, fy, jord, ifirst,ilast,jfirst,jlast, npx, npy, dm, ppm_limiter)
   endif

 end subroutine ytp



 subroutine fxppm(c, q, flux, iord, ifirst, ilast, jfirst, jlast, npx, npy, ppm_limiter)
! !INPUT PARAMETERS:
 integer, INTENT(IN) :: ifirst, ilast               !  X-Dir strip
 integer, INTENT(IN) :: jfirst, jlast               !  Y-Dir strip
 integer, INTENT(IN) :: iord
 integer, INTENT(IN) :: npx, npy
 real   , INTENT(IN) :: q(ifirst-ng:ilast+ng,jfirst:jlast)
 real   , INTENT(IN) :: c(ifirst   :ilast+1 ,jfirst:jlast) ! Courant   N (like FLUX)
 real   , INTENT(IN) :: ppm_limiter
! !OUTPUT PARAMETERS:
 real   , INTENT(OUT) :: flux(ifirst:ilast+1,jfirst:jlast) !  Flux
! Local
 real dm1(ifirst-2:ilast+2)
 real  al(ifirst-1:ilast+2)
 real  bl(ifirst-1:ilast+1)
 real  br(ifirst-1:ilast+1)
 real  dq(ifirst-3:ilast+2)
 real dl, dr, pmp, lac, ct, qe
 real xt, x1, x0
 integer i, j, is3, ie3, it

 is3 = max(3,is-1);   ie3 = min(npx-3,ie+1)

 if (iord<=4) then

     do j=jfirst,jlast

        do i=is-2,ie+2
           xt = 0.25*(q(i+1,j) - q(i-1,j))
           dm1(i) = sign(min(abs(xt), max(q(i-1,j), q(i,j), q(i+1,j)) - q(i,j),  &
                             q(i,j) - min(q(i-1,j), q(i,j), q(i+1,j))), xt)
        enddo

      if (grid_type < 3) then
        do i=max(3,is-1),min(npx-2,ie+2)
           al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1) - dm1(i))
        enddo

! Fix the edges:
        if ( is==1 ) then
             x0 = 0.5*((2.*dxa(1,j)+dxa(2,j))*(q(0,j)+q(1,j))   &
                - dxa(1,j)*(q(-1,j)+q(2,j)))/ ( dxa(1,j)+dxa(2,j))
            al(1) = x0
               x1 = s15*q(0,j) + s11*q(-1,j) + s14*dm1(-1)
           dm1(0) = 0.5*(x0 - x1)
           dm1(0) = sign(min(abs(dm1(0)), max(q(0,j), x0, x1) - q(0,j),    &
                                 q(0,j) - min(q(0,j), x0, x1)), dm1(0) )
            al(0) = 0.5*(q(-1,j)+q(0,j)) + r3*(dm1(-1) - dm1(0))
!
               x1 = s15*q(1,j) + s11*q(2,j) - s14*dm1(2)
           dm1(1) = 0.5*(x1 - x0)
           dm1(1) = sign( min(abs(dm1(1)),  max(q(1,j), x0, x1) - q(1,j),  &
                                   q(1,j) - min(q(1,j), x0, x1) ), dm1(1) )
            al(2) = 0.5*(q(1,j)+q(2,j)) + r3*(dm1(1) - dm1(2))
        endif

        if ( (ie+1)==npx ) then
              x0 = 0.5*( (2.*dxa(npx-1,j)+dxa(npx-2,j))*(q(npx-1,j)+q(npx,j))   &
                - dxa(npx-1,j)*(q(npx-2,j)+q(npx+1,j)))/( dxa(npx-1,j)+dxa(npx-2,j))
           al(npx) = x0
              x1 = s15*q(npx-1,j) + s11*q(npx-2,j) + s14*dm1(npx-2)
           dm1(npx-1) = 0.5*(x0 - x1)
           dm1(npx-1) = sign(min(abs(dm1(npx-1)), max(q(npx-1,j), x0, x1) - q(npx-1,j),   &
                                     q(npx-1,j) - min(q(npx-1,j), x0, x1)), dm1(npx-1) )
           al(npx-1) = 0.5*(q(npx-2,j)+q(npx-1,j)) + r3*(dm1(npx-2) - dm1(npx-1))
!
                 x1 = s15*q(npx,j) + s11*q(npx+1,j) - s14*dm1(npx+1)
           dm1(npx) = 0.5*(x1 - x0)
           dm1(npx) = sign(min(abs(dm1(npx)),  max(q(npx,j), x0, x1) - q(npx,j),   &
                                    q(npx,j) - min(q(npx,j), x0, x1)), dm1(npx))
           al(npx+1) = 0.5*(q(npx,j)+q(npx+1,j)) + r3*(dm1(npx) - dm1(npx+1))
        endif
      else
! For doubly periodic BC
           do i=is-1,ie+2
              al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1) - dm1(i))
           enddo
      endif

      if ( iord==3 ) then
           do i=is-1,ie+1
              bl(i) = al(i  ) - q(i,j)
              br(i) = al(i+1) - q(i,j)
           enddo
           call pert_ppm(ie-is+3, q(is-1,j), bl(is-1), br(is-1), 1)
           do i=is,ie+1
              if(c(i,j)>0.) then
                 flux(i,j) = q(i-1,j) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1)))
              else
                 flux(i,j) = q(i,  j) + (1.+c(i,j))*(bl(i  )+c(i,j)*(bl(i  )+br(i  )))
              endif
        enddo
      else
        do i=is,ie+1
          if( c(i,j)>0. ) then
              xt = ppm_limiter*dm1(i-1)
              dl = sign(min(abs(xt), abs(al(i-1)-q(i-1,j))), xt)
              dr = sign(min(abs(xt), abs(al(i  )-q(i-1,j))), xt)
              flux(i,j) = q(i-1,j) + (1.-c(i,j))*(c(i,j)*(dl-dr) + dr)
          else
              xt = ppm_limiter*dm1(i)
              dl = sign(min(abs(xt), abs(al(i  )-q(i,j))), xt)
              dr = sign(min(abs(xt), abs(al(i+1)-q(i,j))), xt)
              flux(i,j) = q(i,j) - (1.+c(i,j))*(c(i,j)*(dl-dr) + dl)
          endif
        enddo
      endif
     enddo

 elseif (iord==5) then
! PPM with Hunyh's 2nd constraint
     do j=jfirst,jlast
        do i=ifirst-3,ilast+2
           dq(i) = q(i+1,j) - q(i,j)
        enddo

        do i=ifirst-2,ilast+2
           xt = 0.25*(q(i+1,j) - q(i-1,j))
           dm1(i) = sign(min(abs(xt), max(q(i-1,j), q(i,j), q(i+1,j)) - q(i,j),  &
                             q(i,j) - min(q(i-1,j), q(i,j), q(i+1,j))), xt)
        enddo

        do i=ifirst-1,ilast+2
           al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1) - dm1(i))
        enddo

        do i=ifirst-1,ilast+1
           pmp = -2.*dq(i)
           lac = pmp + 1.5*dq(i+1)
           bl(i) = min(max(0., pmp, lac), max(al(i)-q(i,j), min(0.,pmp, lac)))
           pmp = 2.*dq(i-1)
           lac = pmp - 1.5*dq(i-2)
           br(i) = min(max(0., pmp, lac), max(al(i+1)-q(i,j), min(0.,pmp, lac)))
        enddo

        do i=ifirst,ilast+1
           if(c(i,j)>0.) then
              flux(i,j) = q(i-1,j) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1)))
           else
              flux(i,j) = q(i,  j) + (1.+c(i,j))*(bl(i  )+c(i,j)*(bl(i  )+br(i  )))
           endif
        enddo
     enddo

 elseif ( iord==6 .or. iord==7 ) then

     do j=jfirst,jlast

        if ( iord==6 ) then
! Non-monotonic "5th order" scheme (not really 5th order)
          do i=is3, ie3
             bl(i) = b5*q(i-2,j) + b4*q(i-1,j) + b3*q(i,j) + b2*q(i+1,j) + b1*q(i+2,j)
             br(i) = b1*q(i-2,j) + b2*q(i-1,j) + b3*q(i,j) + b4*q(i+1,j) + b5*q(i+2,j)
          enddo
        else
          do i=is-3,ie+2
             dq(i) = q(i+1,j) - q(i,j)
          enddo
          do i=is3, ie3
!-----------------------------------------------
!- Huynh's 2nd constraint + simple mono limiter
!-----------------------------------------------
             dl = b5*q(i-2,j) + b4*q(i-1,j) + b3*q(i,j) + b2*q(i+1,j) + b1*q(i+2,j)
             dr = b1*q(i-2,j) + b2*q(i-1,j) + b3*q(i,j) + b4*q(i+1,j) + b5*q(i+2,j)
               dl = -sign(min(abs(dl), abs(dq(i-1))), dq(i-1))   ! 1st constraint
              pmp = -2.*dq(i)
              lac = pmp + 1.5*dq(i+1)
            bl(i) = min(max(0., pmp, lac), max(dl, min(0.,pmp, lac)))  ! 2nd constraint
!---
               dr = sign(min(abs(dr), abs(dq(i))), dq(i))   ! 1st constraint
              pmp = 2.*dq(i-1)
              lac = pmp - 1.5*dq(i-2)
            br(i) = min(max(0., pmp, lac), max(dr, min(0.,pmp, lac)))
          enddo
        endif

!--------------
! fix the edges
!--------------
        if ( is==1 ) then
             br(2) = p1*(q(2,j)+q(3,j)) + p2*(q(1,j)+q(4,j)) - q(2,j)
             xt = 0.5*((2.*dxa(1,j)+dxa(2,j))*(q(0,j)+q(1,j))   &
                - dxa(1,j)*(q(-1,j)+q(2,j)))/ ( dxa(1,j)+dxa(2,j))
             bl(1) = xt - q(1,j)
             br(0) = xt - q(0,j)

             xt = c1*q(-2,j) + c2*q(-1,j) + c3*q(0,j)
             xt = max( xt, min(q(-1,j),q(0,j)) )
             xt = min( xt, max(q(-1,j),q(0,j)) )
             bl(0) = xt - q(0,j)

             xt = c3*q(1,j) + c2*q(2,j) +c1*q(3,j)
             xt = max( xt, min(q(1,j),q(2,j)) )
             xt = min( xt, max(q(1,j),q(2,j)) )
             br(1) = xt - q(1,j)
             bl(2) = xt - q(2,j)

             if(iord==7) call pert_ppm(3, q(0,j), bl(0), br(0), 1)
        endif

        if ( (ie+1)==npx ) then
             bl(npx-2) = p1*(q(npx-2,j)+q(npx-3,j)) + p2*(q(npx-4,j)+q(npx-1,j)) - q(npx-2,j)
             xt = 0.5*( (2.*dxa(npx-1,j)+dxa(npx-2,j))*(q(npx-1,j)+q(npx,j))   &
                - dxa(npx-1,j)*(q(npx-2,j)+q(npx+1,j)))/( dxa(npx-1,j)+dxa(npx-2,j))

             br(npx-1) = xt - q(npx-1,j)
             bl(npx  ) = xt - q(npx  ,j)

             xt = c3*q(npx,j) + c2*q(npx+1,j) + c1*q(npx+2,j)
             xt = max( xt, min(q(npx,j),q(npx+1,j)) )
             xt = min( xt, max(q(npx,j),q(npx+1,j)) )
             br(npx) = xt - q(npx,j)

             xt = c1*q(npx-3,j) + c2*q(npx-2,j) + c3*q(npx-1,j)
             xt = max( xt, min(q(npx-2,j),q(npx-1,j)) )
             xt = min( xt, max(q(npx-2,j),q(npx-1,j)) )
             br(npx-2) = xt - q(npx-2,j)
             bl(npx-1) = xt - q(npx-1,j)

             if(iord==7) call pert_ppm(3, q(npx-2,j), bl(npx-2), br(npx-2), 1)
        endif

        do i=ifirst,ilast+1
           if(c(i,j)>0.) then
              flux(i,j) = q(i-1,j) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1)))
           else
              flux(i,j) = q(i,  j) + (1.+c(i,j))*(bl(i  )+c(i,j)*(bl(i  )+br(i  )))
           endif
        enddo
     enddo

 elseif( iord<=10 ) then    ! iord=8, 9, 10

     do j=jfirst,jlast

        if (grid_type < 3) then

        do i=is-3,ie+2
           dq(i) = q(i+1,j) - q(i,j)
        enddo

        do i=is-2,ie+2
               xt = 0.25*(q(i+1,j) - q(i-1,j))
           dm1(i) = sign(min(abs(xt), max(q(i-1,j), q(i,j), q(i+1,j)) - q(i,j),  &
                             q(i,j) - min(q(i-1,j), q(i,j), q(i+1,j))), xt)
        enddo

        do i=is3,min(npx-2,ie+2)
           al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1)-dm1(i))
        enddo

        if ( iord==8 ) then
           do i=is3, ie3
              xt = 2.*dm1(i)
              bl(i) = -sign(min(abs(xt), abs(al(i  )-q(i,j))), xt)
              br(i) =  sign(min(abs(xt), abs(al(i+1)-q(i,j))), xt)
           enddo
        elseif ( iord==9 ) then
           do i=is3, ie3
              pmp = -2.*dq(i)
              lac = pmp + 1.5*dq(i+1)
              bl(i) = min(max(0., pmp, lac), max(al(i  )-q(i,j), min(0.,pmp, lac)))
              pmp = 2.*dq(i-1)
              lac = pmp - 1.5*dq(i-2)
              br(i) = min(max(0., pmp, lac), max(al(i+1)-q(i,j), min(0.,pmp, lac)))
           enddo
        else
           do i=is3, ie3
              bl(i) = al(i  ) - q(i,j)
              br(i) = al(i+1) - q(i,j)
              if ( dq(i-1)*dq(i) <= 0. ) then
                   pmp = -2.*dq(i)
                   lac = pmp + 1.5*dq(i+1)
                   bl(i) = min(max(0., pmp, lac), max(bl(i), min(0.,pmp, lac)))
                   pmp = 2.*dq(i-1)
                   lac = pmp - 1.5*dq(i-2)
                   br(i) = min(max(0., pmp, lac), max(br(i), min(0.,pmp, lac)))
              endif
           enddo
        endif

!--------------
! fix the edges
!--------------
           if ( is==1 ) then
              br(2) = al(3) - q(2,j)
!             xt = t11*(q(0,j)+q(1,j)) + t12*(q(-1,j)+q(2,j)) + t13*(dm1(2)-dm1(-1))
              xt = 0.5*((2.*dxa(1,j)+dxa(2,j))*(q(0,j)+q(1,j))   &
                 - dxa(1,j)*(q(-1,j)+q(2,j)))/ ( dxa(1,j)+dxa(2,j))
              bl(1) = xt - q(1,j)
              br(0) = xt - q(0,j)
              xt = s14*dm1(-1) - s11*dq(-1) + q(0,j)

!             xt = max( xt, min(q(-1,j),q(0,j)) )
!             xt = min( xt, max(q(-1,j),q(0,j)) )

              bl(0) = xt - q(0,j)
              xt = s15*q(1,j) + s11*q( 2,j) - s14*dm1( 2)

!             xt = max( xt, min(q(1,j),q(2,j)) )
!             xt = min( xt, max(q(1,j),q(2,j)) )

              br(1) = xt - q(1,j)
              bl(2) = xt - q(2,j)
              call pert_ppm(3, q(0,j), bl(0), br(0), 1)
           endif

           if ( (ie+1)==npx ) then
              bl(npx-2) = al(npx-2) - q(npx-2,j)
!             xt = t11*(q(npx-1,j)+q(npx,j)) + t12*(q(npx-2,j)+q(npx+1,j))   &
!                                            + t13*(dm1(npx+1)-dm1(npx-2))
              xt = 0.5*( (2.*dxa(npx-1,j)+dxa(npx-2,j))*(q(npx-1,j)+q(npx,j))   &
                 - dxa(npx-1,j)*(q(npx-2,j)+q(npx+1,j)))/( dxa(npx-1,j)+dxa(npx-2,j))

              br(npx-1) = xt - q(npx-1,j)
              bl(npx  ) = xt - q(npx  ,j)
              xt = s11*dq(npx) - s14*dm1(npx+1) + q(npx,j)

!             xt = min( xt, max(q(npx,j), q(npx+1,j)) )
!             xt = max( xt, min(q(npx,j), q(npx+1,j)) )

              br(npx) = xt - q(npx,j)
              xt = s15*q(npx-1,j) + s11*q(npx-2,j) + s14*dm1(npx-2)

!             xt = min( xt, max(q(npx-2,j), q(npx-1,j)) )
!             xt = max( xt, min(q(npx-2,j), q(npx-1,j)) )

              br(npx-2) = xt - q(npx-2,j)
              bl(npx-1) = xt - q(npx-1,j)
              call pert_ppm(3, q(npx-2,j), bl(npx-2), br(npx-2), 1)
           endif
        else
!---------------
! grid_type == 4
!---------------
           do i=ifirst-2,ilast+2
              xt = 0.25*(q(i+1,j) - q(i-1,j))
              dm1(i) = sign(min(abs(xt), max(q(i-1,j), q(i,j), q(i+1,j)) - q(i,j),  &
                                q(i,j) - min(q(i-1,j), q(i,j), q(i+1,j))), xt)
           enddo

           do i=ifirst-1,ilast+2
              al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1)-dm1(i))
           enddo

           do i=ifirst-3,ilast+2
              dq(i) = q(i+1,j) - q(i,j)
           enddo

           do i=ifirst-1,ilast+1
              pmp = -2.*dq(i)
              lac = pmp + 1.5*dq(i+1)
              bl(i) = min(max(0., pmp, lac), max(al(i  )-q(i,j), min(0.,pmp, lac)))
              pmp = 2.*dq(i-1)
              lac = pmp - 1.5*dq(i-2)
              br(i) = min(max(0., pmp, lac), max(al(i+1)-q(i,j), min(0.,pmp, lac)))
           enddo

        endif     ! grid_type check

        do i=ifirst,ilast+1
#ifdef INTEL_OPT
             ct = c(i,j)
             if( ct>0. ) then
                it = i-1
                qe = br(i-1)
             else
                it = i
                qe = bl(i)
             endif
             ct = -abs(ct)
             flux(i,j) = q(it,j) + (1.+ct)*( qe + ct*(bl(it)+br(it)) )
#else
             if( c(i,j)>0. ) then
                flux(i,j) = q(i-1,j) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1)))
             else
                flux(i,j) = q(i,  j) + (1.+c(i,j))*(bl(i  )+c(i,j)*(bl(i  )+br(i  )))
             endif
#endif
           enddo


        enddo
    else
!------------------------------
! For positive definite tracers:
!------------------------------
! iord=11: PPM mono constraint (Lin 2004)
! iord=12: Huynh 2nd constraint (Lin 2004) + positive definite (Lin & Rood 1996)
! iord>12: positive definite only (Lin & Rood 1996)

       do j=jfirst,jlast

          do i=is-2,ie+2
             xt = 0.25*(q(i+1,j) - q(i-1,j))
             dm1(i) = sign(min(abs(xt), max(q(i-1,j), q(i,j), q(i+1,j)) - q(i,j),  &
                               q(i,j) - min(q(i-1,j), q(i,j), q(i+1,j))), xt)
          enddo

          if (grid_type < 3) then

             is3 = max(3,is-1);   ie3 = min(npx-3,ie+1)

             do i=is3,min(npx-2,ie+2)
                al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1)-dm1(i))
             enddo

             if ( iord ==11 ) then
                do i=is3,ie3
                   xt = 2.*dm1(i)
                   bl(i) =-sign(min(abs(xt), abs(al(i)  -q(i,j))), xt)
                   br(i) = sign(min(abs(xt), abs(al(i+1)-q(i,j))), xt)
                enddo
             elseif( iord==12 ) then
                do i=is-3,ie+2
                   dq(i) = q(i+1,j) - q(i,j)
                enddo
                do i=is3,ie3
                   pmp = -2.*dq(i)
                   lac = pmp + 1.5*dq(i+1)
                   bl(i) = min(max(0., pmp, lac), max(al(i  )-q(i,j), min(0.,pmp, lac)))
                   pmp = 2.*dq(i-1)
                   lac = pmp - 1.5*dq(i-2)
                   br(i) = min(max(0., pmp, lac), max(al(i+1)-q(i,j), min(0.,pmp, lac)))
                enddo
             else
                do i=is3,ie3
                   bl(i) = al(i  ) - q(i,j)
                   br(i) = al(i+1) - q(i,j)
                enddo
             endif

! Positive definite constraint:
             if(iord/=11) call pert_ppm(ie3-is3+1, q(is3,j), bl(is3), br(is3), 0)

!--------------
! fix the edges
!--------------
             if ( is==1 ) then
                br(2) = al(3) - q(2,j)
!               xt = t11*(q(0,j)+q(1,j)) + t12*(q(-1,j)+q(2,j)) + t13*(dm1(2)-dm1(-1))
!!!             xt = 0.75*(q(0,j)+q(1,j)) - 0.25*(q(-1,j)+q(2,j))
                xt = 0.5*( (2.*dxa(1,j)+dxa(2,j))*(q(0,j)+q(1,j))  &
                   - dxa(1,j)*(q(-1,j)+q(2,j)) ) / ( dxa(1,j)+dxa(2,j) )
                xt = max(0., xt)
                bl(1) = xt - q(1,j)
                br(0) = xt - q(0,j)
                xt = 4./7.*dm1(-1) + 11./14.*q(-1,j) + 3./14.*q(0,j)
                xt = max(0., xt)
                bl(0) =  xt - q(0,j)
                xt = 3./14.*q(1,j) + 11./14.*q(2,j) - 4./7.*dm1(2)
                xt = max(0., xt)
                br(1) = xt - q(1,j)
                bl(2) = xt - q(2,j)
                call pert_ppm(3, q(0,j), bl(0), br(0), 1)
             endif

             if ( (ie+1)==npx ) then
                bl(npx-2) = al(npx-2) - q(npx-2,j)
!               xt = t11*(q(npx-1,j)+q(npx,j)) + t12*(q(npx-2,j)+q(npx+1,j))   &
!                  + t13*(dm1(npx+1)-dm1(npx-2))
!!!             xt = 0.75*(q(npx-1,j)+q(npx,j)) - 0.25*(q(npx-2,j)+q(npx+1,j))
                xt = 0.5*((2.*dxa(npx-1,j)+dxa(npx-2,j))*(q(npx-1,j)+q(npx,j)) -   &
                     dxa(npx-1,j)*(q(npx-2,j)+q(npx+1,j)) )  &
                 / ( dxa(npx-1,j)+dxa(npx-2,j) )
                xt = max(0., xt)
                br(npx-1) = xt - q(npx-1,j)
                bl(npx  ) = xt - q(npx  ,j)
!               br(npx) = 11./14.*q(npx+1,j) + 3./14.*q(npx,j) - 4./7.*dm1(npx+1)
                xt = 11./14.*q(npx+1,j) + 3./14.*q(npx,j) - 4./7.*dm1(npx+1)
                xt = max(0., xt)
                br(npx) = xt - q(npx,j)
                xt = 3./14.*q(npx-1,j) + 11./14.*q(npx-2,j) + 4./7.*dm1(npx-2)
                xt = max(0., xt)
                br(npx-2) = xt - q(npx-2,j)
                bl(npx-1) = xt - q(npx-1,j)
                call pert_ppm(3, q(npx-2,j), bl(npx-2), br(npx-2), 1)
             endif
          else
!--------------
! grid_type >=4
!--------------
             do i=ifirst-1,ilast+2
                al(i) = 0.5*(q(i-1,j)+q(i,j)) + r3*(dm1(i-1)-dm1(i))
             enddo

             if ( iord ==11 ) then
                do i=ifirst-1,ilast+1
                   xt = 2.*dm1(i)
                   bl(i) =-sign(min(abs(xt), abs(al(i)  -q(i,j))), xt)
                   br(i) = sign(min(abs(xt), abs(al(i+1)-q(i,j))), xt)
                enddo
             elseif( iord==12 ) then
                do i=ifirst-3,ilast+2
                   dq(i) = q(i+1,j) - q(i,j)
                enddo
                do i=ifirst-1,ilast+1
                   pmp = -2.*dq(i)
                   lac = pmp + 1.5*dq(i+1)
                   bl(i) = min(max(0., pmp, lac), max(al(i  )-q(i,j), min(0.,pmp, lac)))
                   pmp = 2.*dq(i-1)
                   lac = pmp - 1.5*dq(i-2)
                   br(i) = min(max(0., pmp, lac), max(al(i+1)-q(i,j), min(0.,pmp, lac)))
                enddo
             else
                do i=is-1,ie+1
                   bl(i) = al(i  ) - q(i,j)
                   br(i) = al(i+1) - q(i,j)
                enddo
             endif

! Positive definite constraint:
             if(iord/=11) call pert_ppm(ie-is+3, q(is-1,j), bl(is-1), br(is-1), 0)

          endif

          do i=ifirst,ilast+1
             if( c(i,j)>0. ) then
                flux(i,j) = q(i-1,j) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1)))
             else
                flux(i,j) = q(i,  j) + (1.+c(i,j))*(bl(i  )+c(i,j)*(bl(i  )+br(i  )))
             endif
          enddo

       enddo

    endif

 end subroutine fxppm



 subroutine fyppm(c,  q,  flux, jord, ifirst, ilast, jfirst, jlast, npx, npy, dm, ppm_limiter)
 integer, INTENT(IN) :: ifirst, ilast               !  X-Dir strip
 integer, INTENT(IN) :: jfirst, jlast               !  Y-Dir strip
 integer, INTENT(IN) :: jord
 integer, INTENT(IN) :: npx, npy
 real   , intent(IN) :: ppm_limiter
 real   , INTENT(IN) :: q(ifirst:ilast,jfirst-ng:jlast+ng)
 real   , intent(in) :: c(isd:ied,js:je+1 )  ! Courant number
 real   , INTENT(OUT):: flux(ifirst:ilast,jfirst:jlast+1)   !  Flux
 real   , INTENT(OUT)::   dm(ifirst:ilast,jfirst-2:jlast+2)
! Local:
 real al(ifirst:ilast,jfirst-1:jlast+2)
 real bl(ifirst:ilast,jfirst-1:jlast+1)
 real br(ifirst:ilast,jfirst-1:jlast+1)
 real dq(ifirst:ilast,jfirst-3:jlast+2)
 real dl, dr, pmp, lac, ct, qe
 real xt, x0, x1
 integer i, j, js3, je3, jt

 if (jord<=4) then

   do j=js-2,je+2
      do i=ifirst,ilast
         xt = 0.25*(q(i,j+1) - q(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(q(i,j-1), q(i,j), q(i,j+1)) - q(i,j),   &
                            q(i,j) - min(q(i,j-1), q(i,j), q(i,j+1))), xt)
      enddo
   enddo

  if (grid_type < 3) then
   do j=max(3,js-1),min(npy-2,je+2)
      do i=ifirst,ilast
         al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
      enddo
   enddo
!--------------
! Fix the edges:
!--------------
      if( js==1 ) then
         do i=ifirst,ilast
            x0 = 0.5*((2.*dya(i,1)+dya(i,2))*(q(i,0)+q(i,1))   &
               -dya(i,1)*(q(i,-1)+q(i,2))) / ( dya(i,1)+dya(i,2) )
            al(i,1) = x0
            x1 = s15*q(i,0) + s11*q(i,-1) + s14*dm(i,-1)
            dm(i,0) = 0.5*(x0 - x1)
            dm(i,0) = sign(min(abs(dm(i,0)), max(q(i,0), x0, x1) - q(i,0),   &
                          q(i,0) - min(q(i,0), x0, x1)), dm(i,0))
            al(i,0) = 0.5*(q(i,-1)+q(i,0)) + r3*(dm(i,-1) - dm(i,0))
!
                 x1 = s15*q(i,1) + s11*q(i,2) - s14*dm(i,2)
            dm(i,1) = 0.5*(x1 - x0)
            dm(i,1) = sign(min(abs(dm(i,1)), max(q(i,1), x0, x1) - q(i,1),    &
                                    q(i,1) - min(q(i,1), x0, x1)), dm(i,1))
            al(i,2) = 0.5*(q(i,1)+q(i,2)) + r3*(dm(i,1) - dm(i,2))
         enddo
      endif

      if( (je+1)==npy ) then
         do i=ifirst,ilast
            x0 = 0.5*((2.*dya(i,npy-1)+dya(i,npy-2))*(q(i,npy-1)+q(i,npy))  &
               -dya(i,npy-1)*(q(i,npy-2)+q(i,npy+1)))/(dya(i,npy-1)+dya(i,npy-2))
            al(i,npy) = x0
            x1 = s15*q(i,npy-1) + s11*q(i,npy-2) + s14*dm(i,npy-2)
            dm(i,npy-1) = 0.5*(x0 - x1)
            dm(i,npy-1) = sign(min(abs(dm(i,npy-1)), max(q(i,npy-1), x0, x1) - q(i,npy-1),  &
                                        q(i,npy-1) - min(q(i,npy-1), x0, x1)), dm(i,npy-1))
            al(i,npy-1) = 0.5*(q(i,npy-2)+q(i,npy-1)) + r3*(dm(i,npy-2) - dm(i,npy-1))
!
            x1 = s15*q(i,npy) + s11*q(i,npy+1) - s14*dm(i,npy+1)
            dm(i,npy) = 0.5*(x1 - x0)
            dm(i,npy) = sign(min(abs(dm(i,npy)), max(q(i,npy), x0, x1) - q(i,npy),   &
                                      q(i,npy) - min(q(i,npy), x0, x1)), dm(i,npy))
            al(i,npy+1) = 0.5*(q(i,npy)+q(i,npy+1)) + r3*(dm(i,npy) - dm(i,npy+1))
         enddo
      endif
  else
! Doubly periodic BC:
      do j=js-1,je+2
         do i=ifirst,ilast
            al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
         enddo
      enddo
  endif

  if ( jord==3 ) then
      do j=js-1,je+1
         do i=ifirst,ilast
            bl(i,j) = al(i,j  ) - q(i,j)
            br(i,j) = al(i,j+1) - q(i,j)
         enddo
         call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
      enddo
      do j=js,je+1
         do i=ifirst,ilast
         if( c(i,j)>0. ) then
            flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1)))
         else
            flux(i,j) = q(i,j  ) + (1.+c(i,j))*(bl(i,j  )+c(i,j)*(bl(i,j  )+br(i,j  )))
         endif
         enddo
      enddo
  else
! Inlined limiter
   do j=js,je+1
      do i=ifirst,ilast
         if( c(i,j)>0. ) then
             xt = ppm_limiter*dm(i,j-1)
             dl = sign(min(abs(xt), abs(al(i,j-1)-q(i,j-1))), xt)
             dr = sign(min(abs(xt), abs(al(i,j)-q(i,j-1))),   xt)
             flux(i,j) = q(i,j-1) + (1.-c(i,j))*(c(i,j)*(dl-dr)+dr)
         else
             xt = ppm_limiter*dm(i,j)
             dl = sign(min(abs(xt), abs(al(i,j)-q(i,j))),   xt)
             dr = sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt)
             flux(i,j) = q(i,j) - (1.+c(i,j))*(c(i,j)*(dl-dr)+dl)
         endif
      enddo
   enddo
  endif

 elseif (jord==5) then
! PPM with Hunyh's 2nd constraint

   do j=jfirst-3, jlast+2
      do i=ifirst,ilast
         dq(i,j) = q(i,j+1) - q(i,j)
      enddo
   enddo

   do j=jfirst-2,jlast+2
      do i=ifirst,ilast
         xt = 0.25*(q(i,j+1) - q(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(q(i,j-1), q(i,j), q(i,j+1)) - q(i,j),   &
                            q(i,j) - min(q(i,j-1), q(i,j), q(i,j+1))), xt)
      enddo
   enddo

   do j=jfirst-1,jlast+2
      do i=ifirst,ilast
         al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
      enddo
   enddo

   do j=jfirst-1,jlast+1
      do i=ifirst,ilast
            pmp = -2.*dq(i,j) 
            lac = pmp + 1.5*dq(i,j+1)
            bl(i,j) = min(max(0.,pmp,lac), max(al(i,j)-q(i,j), min(0.,pmp,lac)))
            pmp = 2.*dq(i,j-1)
            lac = pmp - 1.5*dq(i,j-2)
            br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-q(i,j), min(0.,pmp,lac)))
      enddo
   enddo

   do j=jfirst,jlast+1
      do i=ifirst,ilast
         if(c(i,j)>0.) then
            flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1)))
         else
            flux(i,j) = q(i,j  ) + (1.+c(i,j))*(bl(i,j  )+c(i,j)*(bl(i,j  )+br(i,j  )))
         endif
      enddo
   enddo

 elseif( jord==6 .or. jord==7 ) then


   if ( jord==6 ) then

! Non-monotonic "5th order" scheme (not really 5th order)
   do j=max(3,js-1),min(npy-3,je+1)
      do i=ifirst,ilast
         bl(i,j) = b5*q(i,j-2) + b4*q(i,j-1) + b3*q(i,j) + b2*q(i,j+1) + b1*q(i,j+2)
         br(i,j) = b1*q(i,j-2) + b2*q(i,j-1) + b3*q(i,j) + b4*q(i,j+1) + b5*q(i,j+2)
      enddo
   enddo

   else
!-- Huynh's 2nd constraint + simple mono limiter ---------------------------------
     do j=js-3,je+2
        do i=ifirst,ilast
           dq(i,j) = q(i,j+1) - q(i,j)
        enddo
     enddo

     do j=max(3,js-1),min(npy-3,je+1)
        do i=ifirst,ilast
           dl = b5*q(i,j-2) + b4*q(i,j-1) + b3*q(i,j) + b2*q(i,j+1) + b1*q(i,j+2)
           dr = b1*q(i,j-2) + b2*q(i,j-1) + b3*q(i,j) + b4*q(i,j+1) + b5*q(i,j+2)
           dl = -sign(min(abs(dl), abs(dq(i,j-1))), dq(i,j-1))   ! 1st constraint
          pmp = -2.*dq(i,j)
          lac = pmp + 1.5*dq(i,j+1)
          bl(i,j) = min(max(0.,pmp, lac), max(dl,  min(0.,pmp, lac)))
!
           dr = sign(min(abs(dr), abs(dq(i,j))), dq(i,j))    ! 1st constraint
          pmp = 2.*dq(i,j-1)
          lac = pmp - 1.5*dq(i,j-2)
          br(i,j) =  min(max(0.,pmp, lac), max(dr,  min(0.,pmp, lac)))
        enddo
     enddo
   endif

   if( js==1 ) then
         do i=ifirst,ilast
!           br(i,2) = al(i,3) - q(i,2)
            br(i,2) = p1*(q(i,2)+q(i,3)) + p2*(q(i,1)+q(i,4)) - q(i,2)
            xt = 0.5*((2.*dya(i,1)+dya(i,2))*(q(i,0)+q(i,1))   &
               -dya(i,1)*(q(i,-1)+q(i,2))) / ( dya(i,1)+dya(i,2) )
            bl(i,1) = xt - q(i,1)
            br(i,0) = xt - q(i,0)

!           xt = s14*0.25*(q(i,0)-q(i,-2)) - s11*(q(i,0)-q(i,-1)) + q(i,0)
            xt = c1*q(i,-2) + c2*q(i,-1) + c3*q(i,0)
            xt = min( xt, max(q(i,-1), q(i,0)) )
            xt = max( xt, min(q(i,-1), q(i,0)) )
            bl(i,0) = xt - q(i,0)

!           xt = s15*q(i,1) + s11*q(i,2) - s14*0.25*(q(i,3)-q(i,1))
            xt = c3*q(i,1) + c2*q(i,2) + c1*q(i,3)
            xt = min( xt, max(q(i,1), q(i,2)) )
            xt = max( xt, min(q(i,1), q(i,2)) )
            br(i,1) = xt - q(i,1)
            bl(i,2) = xt - q(i,2)
         enddo
         if ( jord==7 ) then
            do j=0,2
               call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
            enddo
         endif
   endif

   if( (je+1)==npy ) then
         do i=ifirst,ilast
!           bl(i,npy-2) = al(i,npy-2) - q(i,npy-2)
            bl(i,npy-2) = p1*(q(i,npy-3)+q(i,npy-2)) + p2*(q(i,npy-4)+q(i,npy-1)) - q(i,npy-2)
            xt = 0.5*((2.*dya(i,npy-1)+dya(i,npy-2))*(q(i,npy-1)+q(i,npy))  &
               -dya(i,npy-1)*(q(i,npy-2)+q(i,npy+1)))/(dya(i,npy-1)+dya(i,npy-2))
            br(i,npy-1) = xt - q(i,npy-1)
            bl(i,npy  ) = xt - q(i,npy)

!           xt = s11*(q(i,npy+1)-q(i,npy)) - s14*0.25*(q(i,npy+2)-q(i,npy)) + q(i,npy)
            xt = c3*q(i,npy) + c2*q(i,npy+1) + c1*q(i,npy+2)
            xt = min( xt, max(q(i,npy), q(i,npy+1)) )
            xt = max( xt, min(q(i,npy), q(i,npy+1)) )
            br(i,npy) = xt - q(i,npy)

!           xt = s15*q(i,npy-1) + s11*q(i,npy-2) + s14*0.25*(q(i,npy-1)-q(i,npy-3))
            xt = c1*q(i,npy-3) + c2*q(i,npy-2) + c3*q(i,npy-1)
            xt = min( xt, max(q(i,npy-2), q(i,npy-1)) )
            xt = max( xt, min(q(i,npy-2), q(i,npy-1)) )
            br(i,npy-2) = xt - q(i,npy-2)
            bl(i,npy-1) = xt - q(i,npy-1)
         enddo
         if ( jord==7 ) then
            do j=npy-2,npy
               call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
            enddo
         endif
   endif

   do j=jfirst,jlast+1
      do i=ifirst,ilast
         if(c(i,j)>0.) then
            flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1)))
         else
            flux(i,j) = q(i,j  ) + (1.+c(i,j))*(bl(i,j  )+c(i,j)*(bl(i,j  )+br(i,j  )))
         endif
      enddo
   enddo

 elseif( jord<=10 ) then    ! jord=8, 9, 10

   do j=js-2,je+2
      do i=ifirst,ilast
              xt = 0.25*(q(i,j+1) - q(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(q(i,j-1), q(i,j), q(i,j+1)) - q(i,j),   &
                            q(i,j) - min(q(i,j-1), q(i,j), q(i,j+1))), xt)
      enddo
   enddo

   if (grid_type < 3) then

       do j=max(3,js-1),min(npy-2,je+2)
          do i=ifirst,ilast
             al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
          enddo
       enddo

       do j=js-3,je+2
          do i=ifirst,ilast
             dq(i,j) = q(i,j+1) - q(i,j)
          enddo
       enddo
      
       if ( jord==8 ) then
         do j=max(3,js-1),min(npy-3,je+1)
         do i=ifirst,ilast
            xt = 2.*dm(i,j)
            bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-q(i,j))),   xt)
            br(i,j) =  sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt)
         enddo
         enddo
       elseif( jord==9 ) then
         do j=max(3,js-1),min(npy-3,je+1)
         do i=ifirst,ilast
            pmp = -2.*dq(i,j) 
            lac = pmp + 1.5*dq(i,j+1)
            bl(i,j) = min(max(0.,pmp,lac), max(al(i,j  )-q(i,j), min(0.,pmp,lac)))
            pmp = 2.*dq(i,j-1)
            lac = pmp - 1.5*dq(i,j-2)
            br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-q(i,j), min(0.,pmp,lac)))
         enddo
         enddo
       else
         do j=max(3,js-1),min(npy-3,je+1)
            do i=ifirst,ilast
               bl(i,j) = al(i,j  ) - q(i,j)
               br(i,j) = al(i,j+1) - q(i,j)
            if ( dq(i,j-1)*dq(i,j) <= 0. ) then
                 pmp = -2.*dq(i,j)
                 lac = pmp + 1.5*dq(i,j+1)
                 bl(i,j) = min(max(0.,pmp,lac), max(bl(i,j), min(0.,pmp,lac)))
                 pmp = 2.*dq(i,j-1)
                 lac = pmp - 1.5*dq(i,j-2)
                 br(i,j) = min(max(0.,pmp,lac), max(br(i,j), min(0.,pmp,lac)))
            endif
         enddo
         enddo
       endif

!--------------
! Fix the edges:
!--------------
      if( js==1 ) then
         do i=ifirst,ilast
            br(i,2) = al(i,3) - q(i,2)
!           xt = t11*(q(i,0)+q(i,1)) + t12*(q(i,-1)+q(i,2))   &
!                                  + t13*(dm(i,2)-dm(i,-1))
            xt = 0.5*((2.*dya(i,1)+dya(i,2))*(q(i,0)+q(i,1))   &
               -dya(i,1)*(q(i,-1)+q(i,2))) / ( dya(i,1)+dya(i,2) )
            bl(i,1) = xt - q(i,1)
            br(i,0) = xt - q(i,0)
            xt = s14*dm(i,-1) - s11*dq(i,-1) + q(i,0)

!           xt = min( xt, max(q(i,-1), q(i,0)) )
!           xt = max( xt, min(q(i,-1), q(i,0)) )

            bl(i,0) = xt - q(i,0)
            xt = s15*q(i,1) + s11*q(i,2) - s14*dm(i,2)

!           xt = min( xt, max(q(i,1), q(i,2)) )
!           xt = max( xt, min(q(i,1), q(i,2)) )

            br(i,1) = xt - q(i,1)
            bl(i,2) = xt - q(i,2)
         enddo
!         if ( jord<=9 ) then
            do j=0,2
               call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
            enddo
!         endif
      endif

      if( (je+1)==npy ) then
         do i=ifirst,ilast
            bl(i,npy-2) = al(i,npy-2) - q(i,npy-2)
!           xt = t11*( q(i,npy-1)+q(i,npy)) + t12*(q(i,npy-2)+q(i,npy+1))   &
!                                         + t13*(dm(i,npy+1)-dm(i,npy-2))
            xt = 0.5*((2.*dya(i,npy-1)+dya(i,npy-2))*(q(i,npy-1)+q(i,npy))  &
               -dya(i,npy-1)*(q(i,npy-2)+q(i,npy+1)))/(dya(i,npy-1)+dya(i,npy-2))
            br(i,npy-1) = xt - q(i,npy-1)
            bl(i,npy  ) = xt - q(i,npy)
            xt = s11*dq(i,npy) - s14*dm(i,npy+1) + q(i,npy)

!           xt = min( xt, max( q(i,npy), q(i,npy+1)) )
!           xt = max( xt, min( q(i,npy), q(i,npy+1)) )

            br(i,npy) = xt - q(i,npy)
            xt = s15*q(i,npy-1) + s11*q(i,npy-2) + s14*dm(i,npy-2)

!           xt = min( xt, max( q(i,npy-2), q(i,npy-1)) )
!           xt = max( xt, min( q(i,npy-2), q(i,npy-1)) )

            br(i,npy-2) = xt - q(i,npy-2)
            bl(i,npy-1) = xt - q(i,npy-1)
         enddo
!         if ( jord<=9 ) then
            do j=npy-2,npy
               call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
            enddo
!         endif
      endif

   else
!---------------
! grid_type == 4
!---------------

      do j=jfirst-1,jlast+2
         do i=ifirst,ilast
            al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
         enddo
      enddo

      do j=jfirst-3,jlast+2
         do i=ifirst,ilast
            dq(i,j) = q(i,j+1) - q(i,j)
         enddo
      enddo
      
      do j=jfirst-1,jlast+1
         do i=ifirst,ilast
            pmp = -2.*dq(i,j) 
            lac = pmp + 1.5*dq(i,j+1)
            bl(i,j) = min(max(0.,pmp,lac), max(al(i,j  )-q(i,j), min(0.,pmp,lac)))
            pmp = 2.*dq(i,j-1)
            lac = pmp - 1.5*dq(i,j-2)
            br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-q(i,j), min(0.,pmp,lac)))
         enddo
      enddo

   endif

   do j=jfirst,jlast+1
      do i=ifirst,ilast
#ifdef INTEL_OPT
         ct = c(i,j)
         if( ct>0. ) then
             jt = j-1
             qe = br(i,j-1) 
         else
             jt = j
             qe = bl(i,j) 
         endif
         ct = -abs(ct)
         flux(i,j) = q(i,jt) + (1.+ct)*( qe + ct*(bl(i,jt)+br(i,jt)) )
#else
         if( c(i,j)>0. ) then
            flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1)))
         else
            flux(i,j) = q(i,j  ) + (1.+c(i,j))*(bl(i,j  )+c(i,j)*(bl(i,j  )+br(i,j  )))
         endif
#endif
      enddo
   enddo

 else
!-------------------------------
! For positive definite tracers:
!-------------------------------
! jord=11: PPM mono constraint (Lin 2004)
! jord=12: Huynh 2nd constraint (Lin 2004) + positive definite (Lin & Rood 1996)
! jord>12: positive definite only (Lin & Rood 1996)


   do j=js-2,je+2
      do i=ifirst,ilast
         xt = 0.25*(q(i,j+1) - q(i,j-1))
         dm(i,j) = sign(min(abs(xt), max(q(i,j-1), q(i,j), q(i,j+1)) - q(i,j),   &
                            q(i,j) - min(q(i,j-1), q(i,j), q(i,j+1))), xt)
      enddo
   enddo

   if (grid_type < 3) then

      js3 = max(3,js-1); je3 = min(npy-3,je+1)

      do j=js3,min(npy-2,je+2)
         do i=ifirst,ilast
            al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
         enddo
      enddo

      if ( jord==11 ) then
         do j=js3,je3
            do i=ifirst,ilast
               xt = 2.*dm(i,j)
               bl(i,j) = -sign(min(abs(xt), abs(al(i,j  )-q(i,j))), xt)
               br(i,j) =  sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt)
            enddo
         enddo
      elseif( jord==12 ) then
         do j=js-3,je+2
            do i=ifirst,ilast
               dq(i,j) = q(i,j+1) - q(i,j)
            enddo
         enddo
         do j=js3,je3
            do i=ifirst,ilast
               pmp = -2.*dq(i,j) 
               lac = pmp + 1.5*dq(i,j+1)
               bl(i,j) = min(max(0.,pmp,lac), max(al(i,j  )-q(i,j), min(0.,pmp,lac)))
               pmp = 2.*dq(i,j-1)
               lac = pmp - 1.5*dq(i,j-2)
               br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-q(i,j), min(0.,pmp,lac)))
            enddo
         enddo
      else
         do j=js3,je3
            do i=ifirst,ilast
               bl(i,j) = al(i,j  ) - q(i,j)
               br(i,j) = al(i,j+1) - q(i,j)
            enddo
         enddo
      endif
      
      if ( jord/=11 ) then
! Positive definite constraint:
         do j=js3,je3
            call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 0)
         enddo
      endif

!--------------
! Fix the edges:
!--------------
      if( js==1 ) then
         do i=ifirst,ilast
            br(i,2) = al(i,3) - q(i,2)
!           xt = t11*(q(i,0)+q(i,1)) + t12*(q(i,-1)+q(i,2))   &
!              + t13*(dm(i,2)-dm(i,-1))
!!!         xt = 0.75*(q(i,0)+q(i,1)) - 0.25*(q(i,-1)+q(i,2))
            xt = 0.5*((2.*dya(i,1)+dya(i,2))*(q(i,0)+q(i,1))  &
               -dya(i,1)*(q(i,-1)+q(i,2))) / (dya(i,1)+dya(i,2))
            xt = max(0., xt)
            bl(i,1) = xt - q(i,1)
            br(i,0) = xt - q(i,0)
            xt = 4./7.*dm(i,-1) + 11./14.*q(i,-1) + 3./14.*q(i,0)
            xt = max(0., xt)
            bl(i,0) = xt - q(i,0)

            xt = 3./14.*q(i,1) + 11./14.*q(i,2) - 4./7.*dm(i,2)
            xt = max(0., xt)
            br(i,1) = xt - q(i,1)
            bl(i,2) = xt - q(i,2)
         enddo
         do j=0,2
            call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
         enddo
      endif

      if( (je+1)==npy ) then
         do i=ifirst,ilast
            bl(i,npy-2) = al(i,npy-2) - q(i,npy-2)
!           xt = t11*(q(i,npy-1)+q(i,npy)) + t12*(q(i,npy-2)+q(i,npy+1))   &
!               + t13*(dm(i,npy+1)-dm(i,npy-2))
!!!         xt = 0.75*(q(i,npy-1)+q(i,npy)) - 0.25*(q(i,npy-2)+q(i,npy+1))
            xt = 0.5*((2.*dya(i,npy-1)+dya(i,npy-2))*(q(i,npy-1)+q(i,npy)) &
               - dya(i,npy-1)*(q(i,npy-2)+q(i,npy+1)))  &
                / ( dya(i,npy-1)+dya(i,npy-2) )
            xt = max(0., xt)
            br(i,npy-1) = xt - q(i,npy-1)
            bl(i,npy  ) = xt - q(i,npy)
            xt = 3./14.*q(i,npy) + 11./14.*q(i,npy+1) - 4./7.*dm(i,npy+1)
            xt = max(0., xt)
            br(i,npy) = xt - q(i,npy)
            xt = 3./14.*q(i,npy-1) + 11./14.*q(i,npy-2) + 4./7.*dm(i,npy-2)
            xt = max(0., xt)
            br(i,npy-2) = xt - q(i,npy-2)
            bl(i,npy-1) = xt - q(i,npy-1)
         enddo
         do j=npy-2,npy
            call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 1)
         enddo
      endif

   else

      do j=js-1,je+2
         do i=ifirst,ilast
            al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
         enddo
      enddo

      if ( jord==11 ) then
         do j=js-1,je+1
            do i=ifirst,ilast
               xt = 2.*dm(i,j)
               bl(i,j) = -sign(min(abs(xt), abs(al(i,j  )-q(i,j))), xt)
               br(i,j) =  sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt)
            enddo
         enddo
      elseif( jord==12 ) then
         do j=js-3,je+2
            do i=ifirst,ilast
               dq(i,j) = q(i,j+1) - q(i,j)
            enddo
         enddo
         do j=js-1,je+1
            do i=ifirst,ilast
               pmp = -2.*dq(i,j) 
               lac = pmp + 1.5*dq(i,j+1)
               bl(i,j) = min(max(0.,pmp,lac), max(al(i,j  )-q(i,j), min(0.,pmp,lac)))
               pmp = 2.*dq(i,j-1)
               lac = pmp - 1.5*dq(i,j-2)
               br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-q(i,j), min(0.,pmp,lac)))
            enddo
         enddo
      else
         do j=js-1,je+1
            do i=ifirst,ilast
               bl(i,j) = al(i,j  ) - q(i,j)
               br(i,j) = al(i,j+1) - q(i,j)
            enddo
         enddo
      endif

      if ( jord/=11 ) then
! Positive definite constraint:
         do j=js-1,je+1
            call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 0)
         enddo
      endif

   endif

   do j=js,je+1
      do i=ifirst,ilast
         if( c(i,j)>0. ) then
            flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1)))
         else
            flux(i,j) = q(i,j  ) + (1.+c(i,j))*(bl(i,j  )+c(i,j)*(bl(i,j  )+br(i,j  )))
         endif
      enddo
   enddo
 endif

 end subroutine fyppm

                       

 subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
                              kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
!
! !INPUT PARAMETERS:
      integer, intent(in):: im, jm, km, nq
      integer, intent(in):: ifirst, ilast
      integer, intent(in):: jfirst, jlast
      integer, intent(in):: kfirst, klast
      integer, intent(in):: ng_e      ! eastern  zones to ghost
      integer, intent(in):: ng_w      ! western  zones to ghost
      integer, intent(in):: ng_s      ! southern zones to ghost
      integer, intent(in):: ng_n      ! northern zones to ghost
      real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
      real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq)
!
! !DESCRIPTION:
!
!     Ghost 4d east/west 
!
! !REVISION HISTORY:
!    2005.08.22   Putman
!
!EOP
!------------------------------------------------------------------------------
!BOC
      integer :: i,j,k,n

      if (present(q)) then
         q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = &
              q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq)
      endif

!      Assume Periodicity in X-dir and not overlapping
      do n=1,nq
         do k=kfirst,klast
            do j=jfirst-ng_s,jlast+ng_n
               do i=1, ng_w
                  q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n)
               enddo
               do i=1, ng_e
                  q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n)
               enddo
            enddo
         enddo
      enddo

 end subroutine mp_ghost_ew



 subroutine pert_ppm(im, a0, al, ar, iv)
 integer, intent(in):: im
 integer, intent(in):: iv
 real, intent(in)   :: a0(im)
 real, intent(inout):: al(im), ar(im)
! Local:
 real a4, da1, da2, a6da, fmin
 integer i
 real, parameter:: r12 = 1./12.

!-----------------------------------
! Optimized PPM in perturbation form:
!-----------------------------------

 if ( iv==0 ) then
! Positive definite constraint
    do i=1,im
        a4 = -3.*(ar(i) + al(i))
       da1 =      ar(i) - al(i)
      if( abs(da1) < -a4 ) then
         fmin = a0(i) + 0.25/a4*da1**2 + a4*r12
         if( fmin < 0. ) then
             if( ar(i)>0. .and. al(i)>0. ) then
                 ar(i) = 0.
                 al(i) = 0.
             elseif( da1 > 0. ) then
                 ar(i) = -2.*al(i)
             else
                 al(i) = -2.*ar(i)
             endif
         endif
      endif
    enddo
 else
! Standard PPM constraint
    do i=1,im
       if ( al(i)*ar(i) < 0. ) then
            da1 = al(i) - ar(i)
            da2 = da1**2
            a6da = 3.*(al(i)+ar(i))*da1
            if( a6da < -da2 ) then
                ar(i) = -2.*al(i)
            elseif( a6da > da2 ) then
                al(i) = -2.*ar(i)
            endif
       else
! effect of dm=0 included here
            al(i) = 0.
            ar(i) = 0.
       endif
  enddo
 endif

 end subroutine pert_ppm


 subroutine deln_flux( nord, npx, npy, damp, q, fx, fy, mfx, mfy )
! Del-n damping for the cell-mean values (A grid)
!------------------
! nord = 0:   del-2
! nord = 1:   del-4
! nord = 2:   del-6
! nord = 3:   del-8 --> requires more ghosting than current
!------------------
   integer, intent(in):: nord            ! del-n
   integer, intent(in):: npx, npy
   real, intent(in):: damp
   real, intent(in):: q(is-ng:ie+ng, js-ng:je+ng)  ! q ghosted on input
! diffusive fluxes:
   real, intent(in):: mfx(is:ie+1,js:je), mfy(is:ie,js:je+1)
   real, intent(inout):: fx(is:ie+1,js:je), fy(is:ie,js:je+1)
! local:
   real fx2(isd:ied+1,jsd:jed), fy2(isd:ied,jsd:jed+1)
   real d2(isd:ied,jsd:jed)
   integer i,j, n, nt


   do j=jsd,jed
      do i=isd,ied
         d2(i,j) = damp*q(i,j)
      enddo
   enddo

   if( nord>0 ) call copy_corners(d2, npx, npy, 1)
   do j=js-nord,je+nord
      do i=is-nord,ie+nord+1
         fx2(i,j) = dy(i,j)*sina_u(i,j)*(d2(i-1,j)-d2(i,j))*rdxc(i,j)
      enddo
   enddo

   if( nord>0 ) call copy_corners(d2, npx, npy, 2)
   do j=js-nord,je+nord+1
      do i=is-nord,ie+nord
         fy2(i,j) = dx(i,j)*sina_v(i,j)*(d2(i,j-1)-d2(i,j))*rdyc(i,j)
      enddo
   enddo

   if ( nord>0 ) then

!----------
! high-order
!----------

   do n=1, nord

      nt = nord-n

      do j=js-nt-1,je+nt+1
         do i=is-nt-1,ie+nt+1
            d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j)
         enddo
      enddo

      call copy_corners(d2, npx, npy, 1)
      do j=js-nt,je+nt
         do i=is-nt,ie+nt+1
            fx2(i,j) = dy(i,j)*sina_u(i,j)*(d2(i,j)-d2(i-1,j))*rdxc(i,j)
         enddo
      enddo

      call copy_corners(d2, npx, npy, 2)
      do j=js-nt,je+nt+1
         do i=is-nt,ie+nt
            fy2(i,j) = dx(i,j)*sina_v(i,j)*(d2(i,j)-d2(i,j-1))*rdyc(i,j)
         enddo
      enddo
   enddo

   endif

!---------------------------------------------
! Add the diffusive fluxes to the flux arrays:
!---------------------------------------------
   do j=js,je
      do i=is,ie+1
!        fx(i,j) = fx(i,j) + fx2(i,j)*mfx(i,j)
         fx(i,j) = fx(i,j) + fx2(i,j)
      enddo
   enddo

   do j=js,je+1
      do i=is,ie
!        fy(i,j) = fy(i,j) + fy2(i,j)*mfy(i,j)
         fy(i,j) = fy(i,j) + fy2(i,j)
      enddo
   enddo

 end subroutine deln_flux


end module tp_core_mod


 module external_ic_mod

   use fms_mod,            only: file_exist, read_data, field_exist
   use fms_io_mod,         only: get_tile_string, field_size
   use mpp_mod,            only: mpp_error, FATAL, NOTE
   use mpp_parameter_mod,  only: AGRID_PARAM=>AGRID
   use mpp_domains_mod,    only: mpp_get_tile_id, domain2d, mpp_update_domains
   use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index
   use field_manager_mod,  only: MODEL_ATMOS

   use constants_mod,     only: pi, omega, grav, kappa, rdgas, rvgas, cp_air
   use external_sst_mod,    only: i_sst, j_sst, sst_ncep
   use fv_arrays_mod,     only: fv_atmos_type
   use fv_diagnostics_mod,only: prt_maxmin
   use fv_grid_tools_mod, only: grid, agrid, cubed_sphere,  &
                                dx,dy, dxa,dya, dxc,dyc, area, rarea
   use fv_grid_utils_mod, only: ptop_min, fc, f0, ew, es, g_sum, vlon, vlat,  &
                                edge_vect_s,edge_vect_n,edge_vect_w,edge_vect_e
   use fv_io_mod,         only: fv_io_read_tracers 
   use fv_mapz_mod,       only: mappm
   use fv_mp_mod,         only: gid, domain, tile, ng,         &
                                is,js,ie,je, isd,jsd,ied,jed, fill_corners, YDir
   use fv_surf_map_mod,   only: surfdrv
   use fv_timing_mod,     only: timing_on, timing_off
   use init_hydro_mod,    only: p_var

   implicit none
   private

   real, parameter:: zvir = rvgas/rdgas - 1.
   real :: deg2rad

   public get_external_ic

contains

   subroutine get_external_ic( Atm, fv_domain )

      type(fv_atmos_type), intent(inout) :: Atm(:)
      type(domain2d),      intent(inout) :: fv_domain
      real:: alpha = 0.
      integer i,j, nq

! * Initialize coriolis param:
 
      do j=jsd,jed+1
         do i=isd,ied+1
            fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
                                     sin(grid(i,j,2))*cos(alpha) )
         enddo
      enddo

      do j=jsd,jed
         do i=isd,ied
            f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
                                     sin(agrid(i,j,2))*cos(alpha) )
         enddo
      enddo

      call mpp_update_domains( f0, domain )
      if ( cubed_sphere ) call fill_corners(f0, Atm(1)%npx, Atm(1)%npy, YDir)
 
! Read in cubed_sphere terrain
      if ( Atm(1)%mountain ) then
           call get_cubed_sphere_terrain(Atm, fv_domain)
      else
           Atm(1)%phis = 0.
      endif
 
! Read in the specified external dataset and do all the needed transformation
      if ( Atm(1)%ncep_ic ) then
           nq = 1
                             call timing_on('NCEP_IC')
           call get_ncep_ic( Atm, fv_domain, nq )
                             call timing_off('NCEP_IC')
#ifndef NO_FV_TRACERS
           call fv_io_read_tracers( fv_domain, Atm )
           if(gid==0) write(6,*) 'All tracers except sphum replaced by FV IC'
#endif
          elseif ( Atm(1)%fv_diag_ic ) then
! Interpolate/remap diagnostic output from a FV model diagnostic output file on lat-lon A grid:
               nq = 1
               call get_latlon_ic( Atm, fv_domain, nq )
      else
!  is Atm%q defined in all cases?
           nq = size(Atm(1)%q,4)
           call get_fv_ic( Atm, fv_domain, nq )
      endif

      call prt_maxmin('T', Atm(1)%pt, is, ie, js, je, ng, Atm(1)%npz, 1., gid==0)

      call p_var(Atm(1)%npz,  is, ie, js, je, Atm(1)%ak(1),  ptop_min,     &
                 Atm(1)%delp, Atm(1)%delz, Atm(1)%pt, Atm(1)%ps,   &
                 Atm(1)%pe,   Atm(1)%peln, Atm(1)%pk, Atm(1)%pkz,  &
                 kappa, Atm(1)%q, ng, Atm(1)%ncnst, Atm(1)%dry_mass,  &
                 Atm(1)%adjust_dry_mass, .true., .true.,         &
                 Atm(1)%hydrostatic, Atm(1)%k_top, Atm(1)%nwat)

  end subroutine get_external_ic



  subroutine get_cubed_sphere_terrain( Atm, fv_domain )
    type(fv_atmos_type), intent(inout) :: Atm(:)
    type(domain2d),      intent(inout) :: fv_domain
    integer              :: ntileMe
    integer, allocatable :: tile_id(:)
    character(len=64)    :: fname
    integer              ::  n
    real ftop

    ntileMe = size(Atm(:))  ! This will have to be modified for mult tiles per PE
                            ! always one at this point

    allocate( tile_id(ntileMe) )
    tile_id = mpp_get_tile_id( fv_domain )
 
    do n=1,ntileMe

       call get_tile_string(fname, 'INPUT/fv_core.res.tile', tile_id(n), '.nc' )

       if( file_exist(fname) ) then
          call read_data(fname, 'phis', Atm(n)%phis(is:ie,js:je),      &
                         domain=fv_domain, tile_count=n)
       else
          call surfdrv(  Atm(n)%npx, Atm(n)%npy, grid, agrid,   &
                         area, dx, dy, dxc, dyc, Atm(n)%phis, gid==0 ) 
          call mpp_error(NOTE,'terrain datasets generated using USGS data')
       endif

    end do
 
    call mpp_update_domains( Atm(1)%phis, domain )
    ftop = g_sum(Atm(1)%phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
 
    call prt_maxmin('ZS', Atm(1)%phis,  is, ie, js, je, ng, 1, 1./grav, gid==0)
    if(gid==0) write(6,*) 'mean terrain height (m)=', ftop/grav
 
    deallocate( tile_id )

  end subroutine get_cubed_sphere_terrain



  subroutine get_latlon_ic( Atm, fv_domain, nq )
      type(fv_atmos_type), intent(inout) :: Atm(:)
      type(domain2d),      intent(inout) :: fv_domain
      integer, intent(in):: nq

      character(len=128) :: fname
      real, allocatable:: ps0(:,:), gz0(:,:), t0(:,:,:), q0(:,:,:)
      real, allocatable:: ua(:,:,:), va(:,:,:)
      real, allocatable:: lat(:), lon(:), ak0(:), bk0(:)
      integer :: i, j, k, im, jm, km, npz
      integer tsize(4)
      integer  sphum, liq_wat, ice_wat, cld_amt       ! GFDL AM2 physics
      logical found
      real dak, dbk

      npz = Atm(1)%npz

! Zero out all initial tracer fields:
      Atm(1)%q = 0.

! Read in lat-lon file
      fname = Atm(1)%res_latlon_dynamics

      if( file_exist(fname) ) then
          call field_size(fname, 'temp', tsize, field_found=found)
          if(gid==0) write(*,*) 'Reconstruct cubed-sphere restart file from FV diagnostic file', fname

          if ( found ) then
               im = tsize(1); jm = tsize(2); km = tsize(3)
               if(gid==0)  write(*,*) 'External IC dimensions:', tsize
          else
               call mpp_error(FATAL,'==> Error in get_external_ic: field not found')
          endif

! Define the lat-lon coordinate:
          allocate (  lon(im) )
          allocate (  lat(jm) )

          allocate ( ak0(km+1) )
          allocate ( bk0(km+1) )
          allocate ( gz0(im,jm) )
          allocate ( ps0(im,jm) )
          allocate (  ua(im,jm,km) )
          allocate (  va(im,jm,km) )
          allocate (  t0(im,jm,km) )
          allocate (  q0(im,jm,km) )

          call read_data (fname, 'LAT', lat)
          call read_data (fname, 'LON', lon)

          do i=1,im
             lon(i) = lon(i) * (pi/180.)  ! lon(1) = 0.
          enddo
          do j=1,jm
             lat(j) = lat(j) * (pi/180.)
          enddo

          call read_data (fname, 'ps', ps0)
          if(gid==0) call pmaxmin( 'PS_data', ps0, im,    jm, 0.01)

          call read_data (fname, 'zsurf', gz0)
          if(gid==0) call pmaxmin( 'ZS_data', gz0, im,    jm, 1.)

          gz0(:,:) = grav * gz0(:,:)

          call read_data (fname, 'ucomp',     ua)
          call read_data (fname, 'vcomp',     va)
          if(gid==0) call pmaxmin( 'U_data',   ua, im*jm, km, 1.)
          if(gid==0) call pmaxmin( 'V_data',   va, im*jm, km, 1.)

          call read_data (fname, 'temp',     t0)
          if(gid==0) call pmaxmin( 'T_data',   t0, im*jm, km, 1.)

          do k=1,km+1
              ak0(k) = Atm(1)%ak(k)
              bk0(k) = Atm(1)%bk(k)
          enddo

! Read in tracers: only sphum at this point
          sphum   = get_tracer_index(MODEL_ATMOS, 'sphum')
          call read_data (fname, 'sphum',  q0)
      else
          call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' does not exist')
      endif

! Horizontal interpolation to the cubed sphere grid center
! remap vertically with terrain adjustment

! nq is assumed to be 1 here:
      call remap_xyz( im, jm, km, npz, nq, nq, lon, lat, ak0, bk0, ps0,   &
                      gz0, ua, va, t0, q0, Atm )

      deallocate ( ak0 )
      deallocate ( bk0 )
      deallocate ( ps0 )
      deallocate ( gz0 )
      deallocate ( t0 )
      deallocate ( q0 )
      deallocate ( ua )
      deallocate ( va )
      deallocate ( lat )
      deallocate ( lon )

  end subroutine get_latlon_ic



  subroutine get_ncep_ic( Atm, fv_domain, nq )
      type(fv_atmos_type), intent(inout) :: Atm(:)
      type(domain2d),      intent(inout) :: fv_domain
      integer, intent(in):: nq
! local:
      character(len=128) :: fname
      real, allocatable:: oro(:,:), wk2(:,:), wk3(:,:,:)
      real, allocatable:: tp(:,:,:), qp(:,:,:)
      real, allocatable:: ua(:,:,:), va(:,:,:)
      real, allocatable:: lat(:), lon(:), ak0(:), bk0(:)
      real:: s2c(is:ie,js:je,4)
      integer, dimension(is:ie,js:je):: id1, id2, jdc
      real psc(is:ie,js:je)
      real gzc(is:ie,js:je)
      real tmean
      integer:: i, j, k, im, jm, km, npz, npt
      integer:: i1, i2, j1
      integer tsize(4)
      logical found
      logical:: read_ts = .true.
      logical:: land_ts = .false.

      deg2rad = pi/180.

      npz = Atm(1)%npz

! Zero out all initial tracer fields:
      Atm(1)%q = 0.

      fname = Atm(1)%res_latlon_dynamics

      if( file_exist(fname) ) then
          call field_size(fname, 'T', tsize, field_found=found)
          if(gid==0) write(*,*) 'Using NCEP restart:', fname 

          if ( found ) then
               im = tsize(1); jm = tsize(2); km = tsize(3)
               if(gid==0)  write(*,*) 'External IC dimensions:', tsize
          else
               call mpp_error(FATAL,'==> Error in get_external_ic: field not found')
          endif

          allocate (  lon(im) )
          allocate (  lat(jm) )
 
          call read_data (fname, 'LAT', lat)
          call read_data (fname, 'LON', lon)
! Convert to radian
          do i=1,im
             lon(i) = lon(i) * deg2rad  ! lon(1) = 0.
          enddo
          do j=1,jm
             lat(j) = lat(j) * deg2rad
          enddo

          allocate ( ak0(km+1) )
          allocate ( bk0(km+1) )
          call read_data (fname, 'hyai', ak0)
          call read_data (fname, 'hybi', bk0)
! Note: definition of NCEP hybrid is p(k) = a(k)*1.E5 + b(k)*ps
          ak0(:) = ak0(:) * 1.E5

! Limiter to prevent NAN at top during remapping
          ak0(1) = max(1.e-9, ak0(1))
      else
          call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' does not exist')
      endif

! Initialize lat-lon to Cubed bi-linear interpolation coeff:
      call remap_coef( im, jm, lon, lat, id1, id2, jdc, s2c )

! remap surface pressure and height:
      allocate ( wk2(im,jm) )
      call read_data (fname, 'PS', wk2)
      if(gid==0) call pmaxmin( 'PS_ncep', wk2, im,  jm, 0.01)

      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            psc(i,j) = s2c(i,j,1)*wk2(i1,j1  ) + s2c(i,j,2)*wk2(i2,j1  ) +  &
                       s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
         enddo
      enddo

      call read_data (fname, 'PHIS', wk2)
      if(gid==0) call pmaxmin( 'ZS_ncep', wk2, im,  jm, 1./grav)
      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            gzc(i,j) = s2c(i,j,1)*wk2(i1,j1  ) + s2c(i,j,2)*wk2(i2,j1  ) +  &
                       s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
         enddo
      enddo

      if ( read_ts ) then       ! read skin temperature; could be used for SST

        call read_data (fname, 'TS', wk2)

        if ( .not. land_ts ) then
           allocate ( oro(im,jm) )
! Read NCEP ORO (1; land; 0: ocean; 2: sea_ice)
           call read_data (fname, 'ORO', oro)

           do j=1,jm
              tmean = 0.
              npt = 0
              do i=1,im
                 if( abs(oro(i,j)-1.) > 0.5 ) then
                     tmean = tmean + wk2(i,j)
                     npt = npt + 1
                 endif
              enddo
!------------------------------------------------------
! Replace TS over interior land with zonal mean SST/Ice
!------------------------------------------------------
              if ( npt /= 0 ) then
                   tmean= tmean / real(npt)
                   do i=1,im
                      if( abs(oro(i,j)-1.) <= 0.5 ) then
                          if ( i==1 ) then
                               i1 = im;     i2 = 2
                          elseif ( i==im ) then
                               i1 = im-1;   i2 = 1
                          else
                               i1 = i-1;    i2 = i+1
                          endif
                          if ( abs(oro(i2,j)-1.)>0.5 ) then     ! east side has priority
                               wk2(i,j) = wk2(i2,j)
                          elseif ( abs(oro(i1,j)-1.)>0.5 ) then ! west side
                               wk2(i,j) = wk2(i1,j)
                          else
                               wk2(i,j) = tmean
                          endif
                      endif
                   enddo
              endif
           enddo
           deallocate ( oro )
        endif   !(.not.land_ts)

        if(gid==0) call pmaxmin('SST_ncep', wk2, im,  jm, 1.)
        do j=js,je
          do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            Atm(1)%ts(i,j) = s2c(i,j,1)*wk2(i1,j1  ) + s2c(i,j,2)*wk2(i2,j1  ) +  &
                             s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
          enddo
        enddo
        call prt_maxmin('SST_model', Atm(1)%ts, is, ie, js, je, 0, 1, 1., gid==0)

! Perform interp to FMS SST format/grid
        call ncep2fms(im, jm, lon, lat, wk2)
        if( gid==0 ) then
          write(*,*) 'External_ic_mod: i_sst=', i_sst, ' j_sst=', j_sst
          call pmaxmin( 'SST_ncep_fms',  sst_ncep, i_sst, j_sst, 1.)
        endif
      endif  !(read_ts)

      deallocate ( wk2 )

! Read in temperature:
      allocate (  wk3(im,jm,km) )
      call read_data (fname, 'T',  wk3)
      if(gid==0) call pmaxmin( 'T_ncep',   wk3, im*jm, km, 1.)
      allocate (  tp(is:ie,js:je,km) )
      do k=1,km
        do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            tp(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                        s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
         enddo
        enddo
      enddo

! Read in tracers: only sphum at this point
      call read_data (fname, 'Q',  wk3)
      if(gid==1) call pmaxmin( 'Q_ncep',   wk3, im*jm, km, 1.)
      allocate ( qp(is:ie,js:je,km) )
      do k=1,km
        do j=js,je
          do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            qp(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                        s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
          enddo
        enddo
      enddo

      call remap_scalar(im, jm, km, npz, nq, nq, ak0, bk0, psc, gzc, tp, qp, Atm)
      deallocate ( tp )
      deallocate ( qp )

! Winds:
      call read_data (fname, 'U',  wk3)
      if(gid==2) call pmaxmin( 'U_ncep',   wk3, im*jm, km, 1.)
      allocate ( ua(is:ie,js:je,km) )
      do k=1,km
        do j=js,je
          do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            ua(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                        s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
          enddo
        enddo
      enddo

      call read_data (fname, 'V',  wk3)
      if(gid==3) call pmaxmin( 'V_ncep',  wk3, im*jm, km, 1.)
      allocate ( va(is:ie,js:je,km) )
      do k=1,km
        do j=js,je
          do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            va(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                        s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
          enddo
        enddo
      enddo
      deallocate ( wk3 )

      call remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm)

      deallocate ( ua )
      deallocate ( va )

      deallocate ( ak0 )
      deallocate ( bk0 )
      deallocate ( lat )
      deallocate ( lon )

  end subroutine get_ncep_ic



  subroutine get_fv_ic( Atm, fv_domain, nq )
      type(fv_atmos_type), intent(inout) :: Atm(:)
      type(domain2d),      intent(inout) :: fv_domain
      integer, intent(in):: nq

      character(len=128) :: fname, tracer_name
      real, allocatable:: ps0(:,:), gz0(:,:), u0(:,:,:), v0(:,:,:), t0(:,:,:), dp0(:,:,:), q0(:,:,:,:)
      real, allocatable:: ua(:,:,:), va(:,:,:)
      real, allocatable:: lat(:), lon(:), ak0(:), bk0(:)
      integer :: i, j, k, im, jm, km, npz, tr_ind
      integer tsize(4)
!     integer sphum, liq_wat, ice_wat, cld_amt       ! GFDL AM2 physics
      logical found

      npz = Atm(1)%npz

! Zero out all initial tracer fields:
      Atm(1)%q = 0.

! Read in lat-lon FV core restart file
      fname = Atm(1)%res_latlon_dynamics

      if( file_exist(fname) ) then
          call field_size(fname, 'T', tsize, field_found=found)
          if(gid==0) write(*,*) 'Using lat-lon FV restart:', fname 

          if ( found ) then
               im = tsize(1); jm = tsize(2); km = tsize(3)
               if(gid==0)  write(*,*) 'External IC dimensions:', tsize
          else
               call mpp_error(FATAL,'==> Error in get_external_ic: field not found')
          endif

! Define the lat-lon coordinate:
          allocate (  lon(im) )
          allocate (  lat(jm) )

          do i=1,im
             lon(i) = (0.5 + real(i-1)) * 2.*pi/real(im)
          enddo

          do j=1,jm
             lat(j) = -0.5*pi + real(j-1)*pi/real(jm-1)   ! SP to NP 
          enddo
 
          allocate ( ak0(1:km+1) )
          allocate ( bk0(1:km+1) )
          allocate ( ps0(1:im,1:jm) )
          allocate ( gz0(1:im,1:jm) )
          allocate (  u0(1:im,1:jm,1:km) )
          allocate (  v0(1:im,1:jm,1:km) )
          allocate (  t0(1:im,1:jm,1:km) )
          allocate ( dp0(1:im,1:jm,1:km) )

          call read_data (fname, 'ak', ak0)
          call read_data (fname, 'bk', bk0)
          call read_data (fname, 'Surface_geopotential', gz0)
          call read_data (fname, 'U',     u0)
          call read_data (fname, 'V',     v0)
          call read_data (fname, 'T',     t0)
          call read_data (fname, 'DELP', dp0)

! Share the load
          if(gid==0) call pmaxmin( 'ZS_data', gz0, im,    jm, 1./grav)
          if(gid==1) call pmaxmin( 'U_data',   u0, im*jm, km, 1.)
          if(gid==1) call pmaxmin( 'V_data',   v0, im*jm, km, 1.)
          if(gid==2) call pmaxmin( 'T_data',   t0, im*jm, km, 1.)
          if(gid==3) call pmaxmin( 'DEL-P',   dp0, im*jm, km, 0.01)


      else
          call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' does not exist')
      endif

! Read in tracers: only AM2 "physics tracers" at this point
      fname = Atm(1)%res_latlon_tracers

      if( file_exist(fname) ) then
          if(gid==0) write(*,*) 'Using lat-lon tracer restart:', fname 

          allocate ( q0(im,jm,km,Atm(1)%ncnst) )
          q0 = 0.

          do tr_ind = 1, nq
            call get_tracer_names(MODEL_ATMOS, tr_ind, tracer_name)
            if (field_exist(fname,tracer_name)) then
               call read_data(fname, tracer_name, q0(1:im,1:jm,1:km,tr_ind))
               call mpp_error(NOTE,'==>  Have read tracer '//trim(tracer_name)//' from '//trim(fname))
               cycle
            endif
          enddo
      else
          call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' does not exist')
      endif

! D to A transform on lat-lon grid:
      allocate (  ua(im,jm,km) )
      allocate (  va(im,jm,km) )

      call d2a3d(u0, v0,  ua,  va, im, jm, km, lon)

      deallocate ( u0 ) 
      deallocate ( v0 ) 

      if(gid==4) call pmaxmin( 'UA', ua, im*jm, km, 1.)
      if(gid==4) call pmaxmin( 'VA', va, im*jm, km, 1.)

      do j=1,jm
         do i=1,im
            ps0(i,j) = ak0(1)
         enddo
      enddo

      do k=1,km
         do j=1,jm
            do i=1,im
               ps0(i,j) = ps0(i,j) + dp0(i,j,k)
            enddo
         enddo
      enddo

  if (gid==0) call pmaxmin( 'PS_data (mb)', ps0, im, jm, 0.01)

! Horizontal interpolation to the cubed sphere grid center
! remap vertically with terrain adjustment

      call remap_xyz( im, jm, km, npz, nq, Atm(1)%ncnst, lon, lat, ak0, bk0,   &
                      ps0,  gz0, ua, va, t0, q0, Atm )

      deallocate ( ak0 ) 
      deallocate ( bk0 ) 
      deallocate ( ps0 ) 
      deallocate ( gz0 ) 
      deallocate ( t0 ) 
      deallocate ( q0 ) 
      deallocate ( dp0 ) 
      deallocate ( ua ) 
      deallocate ( va ) 
      deallocate ( lat ) 
      deallocate ( lon ) 

  end subroutine get_fv_ic


 subroutine ncep2fms(im, jm, lon, lat, wk)

  integer, intent(in):: im, jm
  real,    intent(in):: lon(im), lat(jm)
  real,    intent(in):: wk(im,jm)
! local:
  real :: rdlon(im)
  real :: rdlat(jm)
  real:: a1, b1
  real:: delx, dely
  real:: xc, yc    ! "data" location
  real:: c1, c2, c3, c4
  integer i,j, i1, i2, jc, i0, j0, it, jt

  do i=1,im-1
     rdlon(i) = 1. / (lon(i+1) - lon(i))
  enddo
     rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im))

  do j=1,jm-1
     rdlat(j) = 1. / (lat(j+1) - lat(j))
  enddo

! * Interpolate to "FMS" 1x1 SST data grid
! lon: 0.5, 1.5, ..., 359.5
! lat: -89.5, -88.5, ... , 88.5, 89.5

  delx = 360./real(i_sst)
  dely = 180./real(j_sst)

  jt = 1
  do 5000 j=1,j_sst

     yc = (-90. + dely * (0.5+real(j-1)))  * deg2rad
     if ( yc<lat(1) ) then
            jc = 1
            b1 = 0.
     elseif ( yc>lat(jm) ) then
            jc = jm-1
            b1 = 1.
     else
          do j0=jt,jm-1
          if ( yc>=lat(j0) .and. yc<=lat(j0+1) ) then
               jc = j0
               jt = j0
               b1 = (yc-lat(jc)) * rdlat(jc)
               go to 222
          endif
          enddo
     endif
222  continue
     it = 1

     do i=1,i_sst
        xc = delx * (0.5+real(i-1)) * deg2rad
       if ( xc>lon(im) ) then
            i1 = im;     i2 = 1
            a1 = (xc-lon(im)) * rdlon(im)
       elseif ( xc<lon(1) ) then
            i1 = im;     i2 = 1
            a1 = (xc+2.*pi-lon(im)) * rdlon(im)
       else
            do i0=it,im-1
            if ( xc>=lon(i0) .and. xc<=lon(i0+1) ) then
               i1 = i0;  i2 = i0+1
               it = i0
               a1 = (xc-lon(i1)) * rdlon(i0)
               go to 111
            endif
            enddo
       endif
111    continue

       if ( a1<0.0 .or. a1>1.0 .or.  b1<0.0 .or. b1>1.0 ) then
            write(*,*) 'gid=', gid, i,j,a1, b1
       endif

       c1 = (1.-a1) * (1.-b1)
       c2 =     a1  * (1.-b1)
       c3 =     a1  *     b1
       c4 = (1.-a1) *     b1
! Interpolated surface pressure
       sst_ncep(i,j) = c1*wk(i1,jc  ) + c2*wk(i2,jc  ) +    &
                       c3*wk(i2,jc+1) + c4*wk(i1,jc+1)
     enddo   !i-loop
5000 continue   ! j-loop

 end subroutine ncep2fms



 subroutine remap_coef( im, jm, lon, lat, id1, id2, jdc, s2c )

  integer, intent(in):: im, jm
  real,    intent(in):: lon(im), lat(jm)
  real,    intent(out):: s2c(is:ie,js:je,4)
  integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc
! local:
  real :: rdlon(im)
  real :: rdlat(jm)
  real:: a1, b1
  integer i,j, i1, i2, jc, i0, j0

  do i=1,im-1
     rdlon(i) = 1. / (lon(i+1) - lon(i))
  enddo
     rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im))

  do j=1,jm-1
     rdlat(j) = 1. / (lat(j+1) - lat(j))
  enddo

! * Interpolate to cubed sphere cell center
  do 5000 j=js,je

     do i=is,ie

       if ( agrid(i,j,1)>lon(im) ) then
            i1 = im;     i2 = 1
            a1 = (agrid(i,j,1)-lon(im)) * rdlon(im)
       elseif ( agrid(i,j,1)<lon(1) ) then
            i1 = im;     i2 = 1
            a1 = (agrid(i,j,1)+2.*pi-lon(im)) * rdlon(im)
       else
            do i0=1,im-1
            if ( agrid(i,j,1)>=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then
               i1 = i0;  i2 = i0+1
               a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0)
               go to 111
            endif
            enddo
       endif
111    continue

       if ( agrid(i,j,2)<lat(1) ) then
            jc = 1
            b1 = 0.
       elseif ( agrid(i,j,2)>lat(jm) ) then
            jc = jm-1
            b1 = 1.
       else
          do j0=1,jm-1
          if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then
               jc = j0
               b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc)
               go to 222
          endif
          enddo
       endif
222    continue

       if ( a1<0.0 .or. a1>1.0 .or.  b1<0.0 .or. b1>1.0 ) then
            write(*,*) 'gid=', gid, i,j,a1, b1
       endif

       s2c(i,j,1) = (1.-a1) * (1.-b1)
       s2c(i,j,2) =     a1  * (1.-b1)
       s2c(i,j,3) =     a1  *     b1
       s2c(i,j,4) = (1.-a1) *     b1
       id1(i,j) = i1
       id2(i,j) = i2
       jdc(i,j) = jc
     enddo   !i-loop
5000 continue   ! j-loop

 end subroutine remap_coef


 subroutine remap_scalar(im, jm, km, npz, nq, ncnst, ak0, bk0, psc, gzc, ta, qa, Atm)
  type(fv_atmos_type), intent(inout) :: Atm(:)
  integer, intent(in):: im, jm, km, npz, nq, ncnst
  real,    intent(in):: ak0(km+1), bk0(km+1)
  real,    intent(in), dimension(is:ie,js:je):: psc, gzc
  real,    intent(in), dimension(is:ie,js:je,km):: ta
  real,    intent(in), dimension(is:ie,js:je,km,ncnst):: qa
! local:
  real, dimension(is:ie,km):: tp
  real, dimension(is:ie,km+1):: pe0, pn0
  real, dimension(is:ie,npz):: qn1
  real, dimension(is:ie,npz+1):: pe1, pn1
  real pt0(km), gz(km+1), pk0(km+1)
  real qp(is:ie,km,ncnst)
  real pst
  integer i,j,k, iq
  integer  sphum

  sphum   = get_tracer_index(MODEL_ATMOS, 'sphum')
! liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat')
! ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat')
! cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt')

   if ( sphum/=1 ) then
        call mpp_error(FATAL,'SPHUM must be 1st tracer')
   endif

  pk0(1) = ak0(1)**kappa

  do 5000 j=js,je

     do i=is,ie
        pe0(i,1) = ak0(1)
        pn0(i,1) = log(ak0(1))
     enddo

     do i=is,ie

       do iq=1,ncnst
          do k=1,km
             qp(i,k,iq) = qa(i,j,k,iq)
          enddo
       enddo

       do k=1,km
          tp(i,k) = ta(i,j,k)*(1.+zvir*qp(i,k,sphum))
       enddo
! Tracers:

       do k=2,km+1
          pe0(i,k) = ak0(k) + bk0(k)*psc(i,j)
          pn0(i,k) = log(pe0(i,k))
          pk0(k) = pe0(i,k)**kappa
       enddo

#ifdef USE_DATA_ZS
       Atm(1)%  ps(i,j) = psc(i,j)
       Atm(1)%phis(i,j) = gzc(i,j)
#else

! * Adjust interpolated ps to model terrain
       gz(km+1) = gzc(i,j)
       do k=km,1,-1
           gz(k) = gz(k+1) + rdgas*tp(i,k)*(pn0(i,k+1)-pn0(i,k))
       enddo
! Only lowest layer potential temp is needed
          pt0(km) = tp(i,km)/(pk0(km+1)-pk0(km))*(kappa*(pn0(i,km+1)-pn0(i,km)))
       if( Atm(1)%phis(i,j)>gzc(i,j) ) then
           do k=km,1,-1
              if( Atm(1)%phis(i,j) <  gz(k)  .and.    &
                  Atm(1)%phis(i,j) >= gz(k+1) ) then
                  pst = pk0(k) + (pk0(k+1)-pk0(k))*(gz(k)-Atm(1)%phis(i,j))/(gz(k)-gz(k+1))
                  go to 123
              endif
           enddo
       else
! Extrapolation into the ground
           pst = pk0(km+1) + (gzc(i,j)-Atm(1)%phis(i,j))/(cp_air*pt0(km))
       endif

123    Atm(1)%ps(i,j) = pst**(1./kappa)
#endif
     enddo   !i-loop


     do i=is,ie
        pe1(i,1) = Atm(1)%ak(1)
        pn1(i,1) = log(pe1(i,1))
     enddo
     do k=2,npz+1
       do i=is,ie
          pe1(i,k) = Atm(1)%ak(k) + Atm(1)%bk(k)*Atm(1)%ps(i,j)
          pn1(i,k) = log(pe1(i,k))
       enddo
     enddo

! * Compute delp
     do k=1,npz
        do i=is,ie
           Atm(1)%delp(i,j,k) = pe1(i,k+1) - pe1(i,k)
        enddo
     enddo

!---------------
! map tracers
!----------------
      do iq=1,ncnst
         call mappm(km, pe0, qp(is,1,iq), npz, pe1,  qn1, is,ie, 0, 8)
         do k=1,npz
            do i=is,ie
               Atm(1)%q(i,j,k,iq) = qn1(i,k)
            enddo
         enddo
      enddo

!-------------------------------------------------------------
! map virtual temperature using geopotential conserving scheme.
!-------------------------------------------------------------
      call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 8)
      do k=1,npz
         do i=is,ie
            Atm(1)%pt(i,j,k) = qn1(i,k)/(1.+zvir*Atm(1)%q(i,j,k,sphum))
         enddo
      enddo

5000 continue

  call prt_maxmin('PS_model', Atm(1)%ps, is, ie, js, je, ng, 1, 0.01, gid==0)

  if (gid==0) write(*,*) 'done remap_scalar'

 end subroutine remap_scalar



 subroutine remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm)
  type(fv_atmos_type), intent(inout) :: Atm(:)
  integer, intent(in):: im, jm, km, npz
  real,    intent(in):: ak0(km+1), bk0(km+1)
  real,    intent(in):: psc(is:ie,js:je)
  real,    intent(in), dimension(is:ie,js:je,km):: ua, va
! local:
  real, dimension(isd:ied,jsd:jed,npz):: ut, vt   ! winds
  real, dimension(is:ie, km+1):: pe0
  real, dimension(is:ie,npz+1):: pe1
  real, dimension(is:ie,npz):: qn1
  integer i,j,k

  do 5000 j=js,je

     do i=is,ie
        pe0(i,1) = ak0(1)
        pe1(i,1) = Atm(1)%ak(1)
     enddo

     do k=2,km+1
        do i=is,ie
           pe0(i,k) = ak0(k) + bk0(k)*psc(i,j)
        enddo
     enddo

     do k=2,npz+1
       do i=is,ie
          pe1(i,k) = Atm(1)%ak(k) + Atm(1)%bk(k)*Atm(1)%ps(i,j)
       enddo
     enddo

! Use kord=4 for winds; kord=8 for others
!------
! map u
!------
      call mappm(km, pe0, ua(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 4)
      do k=1,npz
         do i=is,ie
            ut(i,j,k) = qn1(i,k)
         enddo
      enddo
!------
! map v
!------
      call mappm(km, pe0, va(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 4)
      do k=1,npz
         do i=is,ie
            vt(i,j,k) = qn1(i,k)
         enddo
      enddo

5000 continue

  call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1., gid==0)
  call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1., gid==0)

!----------------------------------------------
! winds: lat-lon ON A to Cubed-D transformation:
!----------------------------------------------
  call cubed_a2d(Atm(1)%npx, Atm(1)%npy, npz, ut, vt, Atm(1)%u, Atm(1)%v )

  if (gid==0) write(*,*) 'done remap_winds'

 end subroutine remap_winds



  subroutine remap_xyz( im, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0, ps0, gz0,   &
                        ua, va, ta, qa, Atm )

  type(fv_atmos_type), intent(inout) :: Atm(:)
  integer, intent(in):: im, jm, km, npz, nq, ncnst
  real,    intent(in):: lon(im), lat(jm), ak0(km+1), bk0(km+1)
  real,    intent(in):: gz0(im,jm), ps0(im,jm)
  real,    intent(in), dimension(im,jm,km):: ua, va, ta
  real,    intent(in), dimension(im,jm,km,ncnst):: qa
! local:
  real, dimension(isd:ied,jsd:jed,npz):: ut, vt   ! winds 
  real, dimension(is:ie,km):: up, vp, tp
  real, dimension(is:ie,km+1):: pe0, pn0
  real pt0(km), gz(km+1), pk0(km+1)
  real qp(is:ie,km,ncnst)
  real, dimension(is:ie,npz):: qn1
  real, dimension(is:ie,npz+1):: pe1, pn1
  real :: rdlon(im)
  real :: rdlat(jm)
  real:: a1, b1, c1, c2, c3, c4
  real:: gzc, psc, pst
  integer i,j,k, i1, i2, jc, i0, j0, iq
! integer  sphum, liq_wat, ice_wat, cld_amt
  integer  sphum

  sphum   = get_tracer_index(MODEL_ATMOS, 'sphum')
! liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat')
! ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat')
! cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt')

   if ( sphum/=1 ) then
        call mpp_error(FATAL,'SPHUM must be 1st tracer')
   endif

! call prt_maxmin('C_LON', agrid(isd,jsd,1), is, ie, js, je, ng, 1, 180./pi, gid==0)
! call prt_maxmin('C_LAT', agrid(isd,jsd,2), is, ie, js, je, ng, 1, 180./pi, gid==0)

  pk0(1) = ak0(1)**kappa 

  do i=1,im-1
     rdlon(i) = 1. / (lon(i+1) - lon(i))
  enddo
     rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im))

  do j=1,jm-1
     rdlat(j) = 1. / (lat(j+1) - lat(j))
  enddo

! * Interpolate to cubed sphere cell center
  do 5000 j=js,je

     do i=is,ie
        pe0(i,1) = ak0(1)
        pn0(i,1) = log(ak0(1))
     enddo

     do i=is,ie

       if ( agrid(i,j,1)>lon(im) ) then
            i1 = im;     i2 = 1
            a1 = (agrid(i,j,1)-lon(im)) * rdlon(im)
       elseif ( agrid(i,j,1)<lon(1) ) then
            i1 = im;     i2 = 1
            a1 = (agrid(i,j,1)+2.*pi-lon(im)) * rdlon(im)
       else
            do i0=1,im-1
            if ( agrid(i,j,1)>=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then
               i1 = i0;  i2 = i0+1
               a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0)
               go to 111
            endif
            enddo
       endif

111    continue

       if ( agrid(i,j,2)<lat(1) ) then
            jc = 1
            b1 = 0.
       elseif ( agrid(i,j,2)>lat(jm) ) then
            jc = jm-1
            b1 = 1.
       else
          do j0=1,jm-1
          if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then
               jc = j0
               b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc)
               go to 222
          endif
          enddo
       endif
222    continue

#ifndef DEBUG_REMAP
       if ( a1<0.0 .or. a1>1.0 .or.  b1<0.0 .or. b1>1.0 ) then
            write(*,*) i,j,a1, b1
       endif
#endif
       c1 = (1.-a1) * (1.-b1)
       c2 =     a1  * (1.-b1)
       c3 =     a1  *     b1
       c4 = (1.-a1) *     b1

! Interpolated surface pressure
       psc = c1*ps0(i1,jc  ) + c2*ps0(i2,jc  ) +    &
             c3*ps0(i2,jc+1) + c4*ps0(i1,jc+1)

! Interpolated surface geopotential
       gzc = c1*gz0(i1,jc  ) + c2*gz0(i2,jc  ) +    &
             c3*gz0(i2,jc+1) + c4*gz0(i1,jc+1)

! 3D fields:
       do iq=1,ncnst
!          if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then
          do k=1,km
             qp(i,k,iq) = c1*qa(i1,jc,  k,iq) + c2*qa(i2,jc,  k,iq) +  &
                          c3*qa(i2,jc+1,k,iq) + c4*qa(i1,jc+1,k,iq)
          enddo
!          endif
       enddo

       do k=1,km
          up(i,k) = c1*ua(i1,jc,  k) + c2*ua(i2,jc,  k) +  &
                    c3*ua(i2,jc+1,k) + c4*ua(i1,jc+1,k)
          vp(i,k) = c1*va(i1,jc,  k) + c2*va(i2,jc,  k) +  &
                    c3*va(i2,jc+1,k) + c4*va(i1,jc+1,k)
          tp(i,k) = c1*ta(i1,jc,  k) + c2*ta(i2,jc,  k) +  &
                    c3*ta(i2,jc+1,k) + c4*ta(i1,jc+1,k)
! Virtual effect:
          tp(i,k) = tp(i,k)*(1.+zvir*qp(i,k,sphum))
       enddo
! Tracers:

       do k=2,km+1
          pe0(i,k) = ak0(k) + bk0(k)*psc
          pn0(i,k) = log(pe0(i,k))
          pk0(k) = pe0(i,k)**kappa
       enddo

#ifdef USE_DATA_ZS
       Atm(1)%  ps(i,j) = psc
       Atm(1)%phis(i,j) = gzc
#else

! * Adjust interpolated ps to model terrain
       gz(km+1) = gzc 
       do k=km,1,-1
           gz(k) = gz(k+1) + rdgas*tp(i,k)*(pn0(i,k+1)-pn0(i,k)) 
       enddo
! Only lowest layer potential temp is needed
          pt0(km) = tp(i,km)/(pk0(km+1)-pk0(km))*(kappa*(pn0(i,km+1)-pn0(i,km)))
       if( Atm(1)%phis(i,j)>gzc ) then
           do k=km,1,-1
              if( Atm(1)%phis(i,j) <  gz(k)  .and.    &
                  Atm(1)%phis(i,j) >= gz(k+1) ) then
                  pst = pk0(k) + (pk0(k+1)-pk0(k))*(gz(k)-Atm(1)%phis(i,j))/(gz(k)-gz(k+1))
                  go to 123
              endif
           enddo
       else
! Extrapolation into the ground
           pst = pk0(km+1) + (gzc-Atm(1)%phis(i,j))/(cp_air*pt0(km))
       endif

123    Atm(1)%ps(i,j) = pst**(1./kappa)
#endif
     enddo   !i-loop
 

! * Compute delp from ps
     do i=is,ie
        pe1(i,1) = Atm(1)%ak(1)
        pn1(i,1) = log(pe1(i,1))
     enddo
     do k=2,npz+1
       do i=is,ie
          pe1(i,k) = Atm(1)%ak(k) + Atm(1)%bk(k)*Atm(1)%ps(i,j)
          pn1(i,k) = log(pe1(i,k))
       enddo
     enddo

     do k=1,npz
        do i=is,ie
           Atm(1)%delp(i,j,k) = pe1(i,k+1) - pe1(i,k)
        enddo
     enddo
 
! Use kord=4 for winds; kord=8 for others
!------
! map u
!------
      call mappm(km, pe0, up, npz, pe1, qn1, is,ie, -1, 4)
      do k=1,npz
         do i=is,ie
            ut(i,j,k) = qn1(i,k)
         enddo
      enddo
!------
! map v
!------
      call mappm(km, pe0, vp, npz, pe1, qn1, is,ie, -1, 4)
      do k=1,npz
         do i=is,ie
            vt(i,j,k) = qn1(i,k)
         enddo
      enddo

!---------------
! map tracers
!----------------
      do iq=1,ncnst
! Note: AM2 physics tracers only
!         if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then
         call mappm(km, pe0, qp(is,1,iq), npz, pe1,  qn1, is,ie, 0, 8)
         do k=1,npz
            do i=is,ie
               Atm(1)%q(i,j,k,iq) = qn1(i,k)
            enddo
         enddo
!         endif
      enddo

!-------------------------------------------------------------
! map virtual temperature using geopotential conserving scheme.
!-------------------------------------------------------------
      call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 8)
      do k=1,npz
         do i=is,ie
            Atm(1)%pt(i,j,k) = qn1(i,k)/(1.+zvir*Atm(1)%q(i,j,k,sphum))
         enddo
      enddo

5000 continue

  call prt_maxmin('PS_model', Atm(1)%ps, is, ie, js, je, ng, 1, 0.01, gid==0)
  call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1., gid==0)
  call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1., gid==0)

!----------------------------------------------
! winds: lat-lon ON A to Cubed-D transformation:
!----------------------------------------------
  call cubed_a2d(Atm(1)%npx, Atm(1)%npy, npz, ut, vt, Atm(1)%u, Atm(1)%v )

  if (gid==0) write(*,*) 'done remap_xyz'

 end subroutine remap_xyz


 subroutine cubed_a2d( npx, npy, npz, ua, va, u, v )

! Purpose; Transform wind on A grid to D grid

  use mpp_domains_mod,    only: mpp_update_domains

  integer, intent(in):: npx, npy, npz
  real, intent(inout), dimension(isd:ied,jsd:jed,npz):: ua, va
  real, intent(out):: u(isd:ied,  jsd:jed+1,npz)
  real, intent(out):: v(isd:ied+1,jsd:jed  ,npz)
! local:
  real v3(is-1:ie+1,js-1:je+1,3)
  real ue(is-1:ie+1,js:je+1,3)    ! 3D winds at edges
  real ve(is:ie+1,js-1:je+1,  3)    ! 3D winds at edges
  real, dimension(is:ie):: ut1, ut2, ut3
  real, dimension(js:je):: vt1, vt2, vt3
  integer i, j, k, im2, jm2

  call mpp_update_domains(ua, domain, complete=.false.)
  call mpp_update_domains(va, domain, complete=.true.)

    im2 = (npx-1)/2
    jm2 = (npy-1)/2

    do k=1, npz
! Compute 3D wind on A grid
       do j=js-1,je+1
          do i=is-1,ie+1
             v3(i,j,1) = ua(i,j,k)*vlon(i,j,1) + va(i,j,k)*vlat(i,j,1)
             v3(i,j,2) = ua(i,j,k)*vlon(i,j,2) + va(i,j,k)*vlat(i,j,2)
             v3(i,j,3) = ua(i,j,k)*vlon(i,j,3) + va(i,j,k)*vlat(i,j,3)
          enddo
       enddo

! A --> D
! Interpolate to cell edges
       do j=js,je+1
          do i=is-1,ie+1
             ue(i,j,1) = 0.5*(v3(i,j-1,1) + v3(i,j,1))
             ue(i,j,2) = 0.5*(v3(i,j-1,2) + v3(i,j,2))
             ue(i,j,3) = 0.5*(v3(i,j-1,3) + v3(i,j,3))
          enddo
       enddo

       do j=js-1,je+1
          do i=is,ie+1
             ve(i,j,1) = 0.5*(v3(i-1,j,1) + v3(i,j,1))
             ve(i,j,2) = 0.5*(v3(i-1,j,2) + v3(i,j,2))
             ve(i,j,3) = 0.5*(v3(i-1,j,3) + v3(i,j,3))
          enddo
       enddo

! --- E_W edges (for v-wind):
     if ( is==1 ) then
       i = 1
       do j=js,je
        if ( j>jm2 ) then
             vt1(j) = edge_vect_w(j)*ve(i,j-1,1)+(1.-edge_vect_w(j))*ve(i,j,1)
             vt2(j) = edge_vect_w(j)*ve(i,j-1,2)+(1.-edge_vect_w(j))*ve(i,j,2)
             vt3(j) = edge_vect_w(j)*ve(i,j-1,3)+(1.-edge_vect_w(j))*ve(i,j,3)
        else
             vt1(j) = edge_vect_w(j)*ve(i,j+1,1)+(1.-edge_vect_w(j))*ve(i,j,1)
             vt2(j) = edge_vect_w(j)*ve(i,j+1,2)+(1.-edge_vect_w(j))*ve(i,j,2)
             vt3(j) = edge_vect_w(j)*ve(i,j+1,3)+(1.-edge_vect_w(j))*ve(i,j,3)
        endif
       enddo
       do j=js,je
          ve(i,j,1) = vt1(j)
          ve(i,j,2) = vt2(j)
          ve(i,j,3) = vt3(j)
       enddo
     endif

     if ( (ie+1)==npx ) then
       i = npx
       do j=js,je
        if ( j>jm2 ) then
             vt1(j) = edge_vect_e(j)*ve(i,j-1,1)+(1.-edge_vect_e(j))*ve(i,j,1)
             vt2(j) = edge_vect_e(j)*ve(i,j-1,2)+(1.-edge_vect_e(j))*ve(i,j,2)
             vt3(j) = edge_vect_e(j)*ve(i,j-1,3)+(1.-edge_vect_e(j))*ve(i,j,3)
        else
             vt1(j) = edge_vect_e(j)*ve(i,j+1,1)+(1.-edge_vect_e(j))*ve(i,j,1)
             vt2(j) = edge_vect_e(j)*ve(i,j+1,2)+(1.-edge_vect_e(j))*ve(i,j,2)
             vt3(j) = edge_vect_e(j)*ve(i,j+1,3)+(1.-edge_vect_e(j))*ve(i,j,3)
        endif
       enddo
       do j=js,je
          ve(i,j,1) = vt1(j)
          ve(i,j,2) = vt2(j)
          ve(i,j,3) = vt3(j)
       enddo
     endif

! N-S edges (for u-wind):
     if ( js==1 ) then
       j = 1
       do i=is,ie
        if ( i>im2 ) then
             ut1(i) = edge_vect_s(i)*ue(i-1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1)
             ut2(i) = edge_vect_s(i)*ue(i-1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2)
             ut3(i) = edge_vect_s(i)*ue(i-1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3)
        else
             ut1(i) = edge_vect_s(i)*ue(i+1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1)
             ut2(i) = edge_vect_s(i)*ue(i+1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2)
             ut3(i) = edge_vect_s(i)*ue(i+1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3)
        endif
       enddo
       do i=is,ie
          ue(i,j,1) = ut1(i)
          ue(i,j,2) = ut2(i)
          ue(i,j,3) = ut3(i)
       enddo
     endif

     if ( (je+1)==npy ) then
       j = npy
       do i=is,ie
        if ( i>im2 ) then
             ut1(i) = edge_vect_n(i)*ue(i-1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1)
             ut2(i) = edge_vect_n(i)*ue(i-1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2)
             ut3(i) = edge_vect_n(i)*ue(i-1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3)
        else
             ut1(i) = edge_vect_n(i)*ue(i+1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1)
             ut2(i) = edge_vect_n(i)*ue(i+1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2)
             ut3(i) = edge_vect_n(i)*ue(i+1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3)
        endif
       enddo
       do i=is,ie
          ue(i,j,1) = ut1(i)
          ue(i,j,2) = ut2(i)
          ue(i,j,3) = ut3(i)
       enddo
     endif

     do j=js,je+1
        do i=is,ie
           u(i,j,k) =  ue(i,j,1)*es(1,i,j,1) +  &
                       ue(i,j,2)*es(2,i,j,1) +  &
                       ue(i,j,3)*es(3,i,j,1)
        enddo
     enddo
     do j=js,je
        do i=is,ie+1
           v(i,j,k) = ve(i,j,1)*ew(1,i,j,2) +  &
                      ve(i,j,2)*ew(2,i,j,2) +  &
                      ve(i,j,3)*ew(3,i,j,2)
        enddo
     enddo
 
   enddo         ! k-loop

 end subroutine cubed_a2d



 subroutine d2a3d(u, v,  ua,   va,  im,  jm, km, lon)
      integer, intent(in):: im, jm, km           ! Dimensions
      real, intent(in ) :: lon(im)
      real, intent(in ), dimension(im,jm,km):: u, v
      real, intent(out), dimension(im,jm,km):: ua, va
! local
      real :: coslon(im),sinlon(im)    ! Sine and cosine in longitude
      integer i, j, k
      integer imh
      real un, vn, us, vs

      integer :: ks, ke

      imh = im/2

      do i=1,im
         sinlon(i) = sin(lon(i))
         coslon(i) = cos(lon(i))
      enddo

      do k=1,km
         do j=2,jm-1
            do i=1,im
               ua(i,j,k) = 0.5*(u(i,j,k) + u(i,j+1,k))
            enddo
         enddo

         do j=2,jm-1
            do i=1,im-1
               va(i,j,k) = 0.5*(v(i,j,k) + v(i+1,j,k))
            enddo
            va(im,j,k) = 0.5*(v(im,j,k) + v(1,j,k))
         enddo

! Projection at SP
             us = 0.
             vs = 0.
             do i=1,imh
                us = us + (ua(i+imh,2,k)-ua(i,2,k))*sinlon(i)      &
                     + (va(i,2,k)-va(i+imh,2,k))*coslon(i)
                vs = vs + (ua(i+imh,2,k)-ua(i,2,k))*coslon(i)      &
                     + (va(i+imh,2,k)-va(i,2,k))*sinlon(i)
             enddo
             us = us/im
             vs = vs/im
             do i=1,imh
                ua(i,1,k)   = -us*sinlon(i) - vs*coslon(i)
                va(i,1,k)   =  us*coslon(i) - vs*sinlon(i)
                ua(i+imh,1,k)   = -ua(i,1,k)
                va(i+imh,1,k)   = -va(i,1,k)
             enddo

! Projection at NP
             un = 0.
             vn = 0.
             do i=1,imh
                un = un + (ua(i+imh,jm-1,k)-ua(i,jm-1,k))*sinlon(i)    &
                     + (va(i+imh,jm-1,k)-va(i,jm-1,k))*coslon(i)
                vn = vn + (ua(i,jm-1,k)-ua(i+imh,jm-1,k))*coslon(i)    &
                     + (va(i+imh,jm-1,k)-va(i,jm-1,k))*sinlon(i)
             enddo

             un = un/im
             vn = vn/im
             do i=1,imh
                ua(i,jm,k) = -un*sinlon(i) + vn*coslon(i)
                va(i,jm,k) = -un*coslon(i) - vn*sinlon(i)
                ua(i+imh,jm,k) = -ua(i,jm,k)
                va(i+imh,jm,k) = -va(i,jm,k)
             enddo
      enddo

  end subroutine d2a3d



  subroutine pmaxmin( qname, a, im, jm, fac )

      integer, intent(in):: im, jm
      character(len=*) :: qname
      integer i, j
      real a(im,jm)

      real qmin(jm), qmax(jm)
      real pmax, pmin
      real fac                     ! multiplication factor

      do j=1,jm
         pmax = a(1,j)
         pmin = a(1,j)
         do i=2,im
            pmax = max(pmax, a(i,j))
            pmin = min(pmin, a(i,j))
         enddo
         qmax(j) = pmax
         qmin(j) = pmin
      enddo
!
! Now find max/min of amax/amin
!
            pmax = qmax(1)
            pmin = qmin(1)
         do j=2,jm
            pmax = max(pmax, qmax(j))
            pmin = min(pmin, qmin(j))
         enddo

      write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac

 end subroutine pmaxmin



 end module external_ic_mod



module external_sst_mod

#ifdef NO_GFDL_SHARED
!----------------- Public Data -----------------------------------
integer :: i_sst = -1
integer :: j_sst = -1
logical :: forecast_mode = .false.
real, allocatable, dimension(:,:) ::  sst_ncep, sst_anom
#else
use amip_interp_mod, only: i_sst, j_sst, sst_ncep, sst_anom, &
                           forecast_mode
#endif

public i_sst, j_sst, sst_ncep, sst_anom, forecast_mode

end module external_sst_mod


module fv_diagnostics_mod

 use constants_mod,    only: grav, rdgas, rvgas, pi, radius, kappa
 use fms_io_mod,       only: set_domain, nullify_domain
 use time_manager_mod, only: time_type, get_date, get_time
 use mpp_domains_mod,  only: domain2d, mpp_update_domains, DGRID_NE
 use diag_manager_mod, only: diag_axis_init, register_diag_field, &
                             register_static_field, send_data, diag_grid_init
 use fv_arrays_mod,    only: fv_atmos_type
 use fv_mapz_mod,      only: E_Flux
 use fv_mp_mod,        only: domain, gid, masterproc, &
                             mp_reduce_sum, mp_reduce_min, mp_reduce_max
 use fv_eta_mod,        only: get_eta_level, gw_1d
 use fv_grid_tools_mod, only: dx, dy, rdxa, rdya, area, rarea
 use fv_grid_utils_mod, only: f0, cosa_s, g_sum, sina_u, sina_v, en1, en2, vlon
 use a2b_edge_mod,     only: a2b_ord4
 use fv_surf_map_mod,  only: zs_g
 use fv_sg_mod,        only: qsmith

 use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index
 use field_manager_mod,  only: MODEL_ATMOS
 use mpp_mod,            only: mpp_error, FATAL, stdlog
 use sat_vapor_pres_mod, only: compute_qs, lookup_es

#if defined(MARS_GCM) && defined(MARS_SURFACE)
 use mars_surface_mod,     only:  sfc_snow, sfc_frost
#  ifdef DUST_SOURCE
 use dust_source_mod,      only:  sfc_dust, odcol
!!!  use aerosol_mod,          only:  ndust_bins, nice_bins, nice_moms, aerosol_bins, &
!!!                                   dust_indx, ice_bin_indx, ice_mom_indx
#  endif DUST_SOURCE

#  ifdef WATER_CYCLE
 use cloud_physics_mod,   only:  cldcol, wcol
#  endif WATER_CYCLE
#endif

 implicit none
 private

 integer ::id_ps, id_slp, id_ua, id_va, id_pt, id_omga, id_vort,  &
           id_tm, id_pv, id_zsurf, id_oro, id_sgh, id_divg, id_w, &
           id_te, id_zs, id_ze, id_mq, id_vorts, id_us, id_vs,    &
           id_tq, id_rh, id_c15, id_c25, id_c35, id_c45,          &
                         id_f15, id_f25, id_f35, id_f45,          &
           id_ppt, id_ts, id_pmask, id_pmaskv2

! Selected p-level fields from 3D variables:
 integer :: id_vort850, id_w850,  &
            id_w200, id_s200, id_sl12, id_sl13
 integer :: id_h200, id_t200, id_q200, id_omg200, id_rh200, id_u200, id_v200, &
            id_h50, id_t50, id_q50, id_rh50, id_u50, id_v50
 integer :: id_h100, id_h250, id_h300, id_h500, id_h700, id_h850
! IPCC diag
 integer :: id_u100, id_v100, id_t100, id_q100, id_rh100, id_omg100, &
            id_u250, id_v250, id_t250, id_q250, id_rh250, id_omg250, &
            id_u500, id_v500, id_t500, id_q500, id_rh500, id_omg500, &
            id_u700, id_v700, id_t700, id_q700, id_rh700, id_omg700, &
            id_u850, id_v850, id_t850, id_q850, id_rh850, id_omg850, &
            id_u1000,id_v1000,id_t1000,id_q1000,id_rh1000,id_omg1000
 integer :: id_rh1000_cmip, id_rh850_cmip, id_rh700_cmip, id_rh500_cmip, &
            id_rh250_cmip, id_rh100_cmip, id_rh50_cmip, id_rh10_cmip
 integer :: id_u10, id_v10, id_t10, id_q10, id_omg50, id_omg10, id_h10
 integer :: id_hght

#ifdef MARS_GCM
 integer ::  id_t05
 integer ::  id_tdust, id_sfc_dust
#endif MARS_GCM

 integer, parameter:: max_step = 1000
 integer steps
 real(kind=4):: efx(max_step), mtq(max_step)
 real(kind=4):: efx_sum,       mtq_sum
! For initial conditions:
 integer ic_ps, ic_ua, ic_va, ic_ppt
 integer, allocatable :: id_tracer(:)

 integer  :: ncnst
 real :: missing_value = -1.e10
 real :: ginv
 real, allocatable :: phalf(:)
 real, allocatable :: zsurf(:,:)
 real, allocatable :: zxg(:,:)
 real, allocatable :: pt1(:)
 real :: pk0
 logical master

 type(time_type) :: fv_time

 logical :: module_is_initialized=.false.
 logical :: moist_phys
 integer  sphum, liq_wat, ice_wat       ! GFDL physics
 integer  rainwat, snowwat, graupel
 real    :: ptop
 real    :: rad2deg
! tracers
 character(len=128)   :: tname
 character(len=256)   :: tlongname, tunits

 public :: fv_diag_init, fv_time, fv_diag, prt_maxmin, range_check, id_divg, id_te
 public :: efx, efx_sum, mtq, mtq_sum, steps

!---- version number -----
 character(len=128) :: version = '$Id: fv_diagnostics.F90,v 17.0.6.10.2.1.2.1.2.1 2010/08/10 17:27:38 rab Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains

 subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
    type(fv_atmos_type), intent(inout) :: Atm(:)
    integer, intent(out) :: axes(4)
    type(time_type), intent(in) :: Time
    integer,         intent(in) :: npx, npy, npz
    real, intent(in):: p_ref

    real, allocatable :: grid_xt(:), grid_yt(:), grid_xe(:), grid_ye(:), grid_xn(:), grid_yn(:)
    real, allocatable :: grid_x(:),  grid_y(:)
    real              :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2)
    real, allocatable :: a3(:,:,:)
    real              :: pfull(npz)
    real              :: hyam(npz), hybm(npz)

    integer :: id_bk, id_pk, id_area, id_lon, id_lat, id_lont, id_latt, id_phalf, id_pfull
    integer :: id_hyam, id_hybm
    integer :: i, j, k, n, ntileMe, id_xt, id_yt, id_x, id_y, id_xe, id_ye, id_xn, id_yn
    integer :: isc, iec, jsc, jec

    logical :: used

    character(len=64) :: field
    integer              :: ntprog
    integer              :: unit

    rad2deg = 180./pi

! For total energy diagnostics:
    steps = 0
    efx = 0.;       efx_sum = 0.
    mtq = 0.;       mtq_sum = 0.

    ncnst = Atm(1)%ncnst
    moist_phys = Atm(1)%moist_phys

    call set_domain(Atm(1)%domain)  ! Set domain so that diag_manager can access tile information

    if ( Atm(1)%nwat>=3 ) then
         sphum   = get_tracer_index (MODEL_ATMOS, 'sphum')
         liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
         ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
    endif

    if ( Atm(1)%nwat==6 ) then
        rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
        snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
        graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
    else
         sphum   = 1
     endif

! valid range for some fields

!!!  This will need mods for more than 1 tile per pe  !!!

    vsrange = (/ -200.,  200. /)  ! surface (lowest layer) winds

    vrange = (/ -330.,  330. /)  ! winds
    wrange = (/  -80.,   50. /)  ! vertical wind
   rhrange = (/  -10.,  150. /)  ! RH

#if defined(MARS_GCM)
    slprange = (/0.,  100./)  ! sea-level-pressure
    trange = (/  50., 360. /)  ! temperature
#elif defined(VENUS_GCM)
    trange = (/  100.,  900. /)  ! temperature
    slprange = (/80.E3,  98.E3/)  ! sea-level-pressure
#else
    trange = (/  100.,  350. /)  ! temperature
    slprange = (/800.,  1200./)  ! sea-level-pressure
#endif

    ginv = 1./GRAV
    fv_time = Time

    allocate ( phalf(npz+1) )
    call get_eta_level(Atm(1)%npz, p_ref, pfull, phalf, Atm(1)%ak, Atm(1)%bk, 0.01)

!   allocate(grid_xt(npx-1), grid_yt(npy-1), grid_xe(npx), grid_ye(npy-1), grid_xn(npx-1), grid_yn(npy))
    allocate(grid_xt(npx-1), grid_yt(npy-1))
    grid_xt = (/ (i, i=1,npx-1) /)
    grid_yt = (/ (j, j=1,npy-1) /)
!   grid_xe = (/ (i, i=1,npx) /)
!   grid_ye = (/ (j, j=1,npy-1) /)
!   grid_xn = (/ (i, i=1,npx-1) /)
!   grid_yn = (/ (j, j=1,npy) /)

    allocate(grid_x(npx), grid_y(npy))
    grid_x = (/ (i, i=1,npx) /)
    grid_y = (/ (j, j=1,npy) /)

    n=1
    isc = Atm(n)%isc; iec = Atm(n)%iec
    jsc = Atm(n)%jsc; jec = Atm(n)%jec

    ! Send diag_manager the grid informtaion
    call diag_grid_init(DOMAIN=Atm(n)%domain, &
         &              GLO_LON=rad2deg*Atm(n)%grid(isc:iec+1,jsc:jec+1,1), &
         &              GLO_LAT=rad2deg*Atm(n)%grid(isc:iec+1,jsc:jec+1,2), &
         &              AGLO_LON=rad2deg*Atm(n)%agrid(isc-1:iec+1,jsc-1:jec+1,1), &
         &              AGLO_LAT=rad2deg*Atm(n)%agrid(isc-1:iec+1,jsc-1:jec+1,2))

    ntileMe = size(Atm(:))
    do n = 1, ntileMe
       field = 'grid'

       id_xt = diag_axis_init('grid_xt',grid_xt,'degrees_E','x','T-cell longitude', &
                           set_name=trim(field),Domain2=Domain, tile_count=n)
       id_yt = diag_axis_init('grid_yt',grid_yt,'degrees_N','y','T-cell latitude',  &
                           set_name=trim(field), Domain2=Domain, tile_count=n)
!  Don't need these right now
!      id_xe = diag_axis_init ('grid_xe',grid_xe,'degrees_E','x','E-cell longitude', &
!                              set_name=trim(field),Domain2=Domain, tile_count=n)
!      id_ye = diag_axis_init ('grid_ye',grid_ye,'degrees_N','y','E-cell latitude',  &
!                              set_name=trim(field), Domain2=Domain, tile_count=n)
!      id_xn = diag_axis_init ('grid_xn',grid_xn,'degrees_E','x','N-cell longitude', &
!                              set_name=trim(field),Domain2=Domain, aux='geolon_n, geolat_n', tile_count=n)
!      id_yn = diag_axis_init ('grid_yn',grid_yn,'degrees_N','y','N-cell latitude',  &
!                              set_name=trim(field), Domain2=Domain, tile_count=n)

       id_x = diag_axis_init('grid_x',grid_x,'degrees_E','x','cell corner longitude', &
                           set_name=trim(field),Domain2=Domain, tile_count=n)
       id_y = diag_axis_init('grid_y',grid_y,'degrees_N','y','cell corner latitude',  &
                           set_name=trim(field), Domain2=Domain, tile_count=n)

    end do
!   deallocate(grid_xt, grid_yt, grid_xe, grid_ye, grid_xn, grid_yn)
    deallocate(grid_xt, grid_yt)
    deallocate(grid_x,  grid_y )

    id_phalf = diag_axis_init('phalf', phalf, 'mb', 'z', &
            'ref half pressure level', direction=-1, set_name="dynamics")
    id_pfull = diag_axis_init('pfull', pfull, 'mb', 'z', &
            'ref full pressure level', direction=-1, set_name="dynamics", edges=id_phalf)

!---- register static fields -------

    id_bk    = register_static_field ( "dynamics", 'bk', (/id_phalf/), &
         'vertical coordinate sigma value', 'none' )

    id_pk    = register_static_field ( "dynamics", 'pk', (/id_phalf/), &
         'pressure part of the hybrid coordinate', 'pascal' )

    id_hyam    = register_static_field ( "dynamics", 'hyam', (/id_pfull/), &
         'vertical coordinate A value', '1E-5 Pa' )

    id_hybm    = register_static_field ( "dynamics", 'hybm', (/id_pfull/), &
         'vertical coordinate B value', 'none' )

!--- Send static data

    if ( id_bk > 0 )    used = send_data ( id_bk,Atm(1)%bk, Time )
    if ( id_pk > 0 )    used = send_data ( id_pk,Atm(1)%ak, Time )
    if ( id_hyam > 0 ) then
         do k=1,npz
            hyam(k) = 0.5 * ( Atm(1)%ak(k) + Atm(1)%ak(k+1) ) * 1.E-5
         enddo
         used = send_data ( id_hyam, hyam, Time )
    endif
    if ( id_hybm > 0 ) then
         do k=1,npz
            hybm(k) = 0.5 * ( Atm(1)%bk(k) + Atm(1)%bk(k+1) )
         enddo
         used = send_data ( id_hybm, hybm, Time )
    endif

!   Approach will need modification if we wish to write values on other than A grid.
    axes(1) = id_xt
    axes(2) = id_yt
    axes(3) = id_pfull
    axes(4) = id_phalf

!---- register time independent fields -------

    do n = 1, ntileMe
       field= 'dynamics'
       id_lon  = register_static_field ( trim(field), 'grid_lon', (/id_x,id_y/),  &
                                         'longitude', 'degrees_E' )
       id_lat  = register_static_field ( trim(field), 'grid_lat', (/id_x,id_y/),  &
                                         'latitude', 'degrees_N' )
       id_lont = register_static_field ( trim(field), 'grid_lont', (/id_xt,id_yt/),  &
                                         'longitude', 'degrees_E' )
       id_latt = register_static_field ( trim(field), 'grid_latt', (/id_xt,id_yt/),  &
                                         'latitude', 'degrees_N' )
       id_area = register_static_field ( trim(field), 'area', axes(1:2),  &
                                         'cell area', 'm**2' )
#ifndef DYNAMICS_ZS
       id_zsurf = register_static_field ( trim(field), 'zsurf', axes(1:2),  &
                                         'surface height', 'm' )
#endif
       id_zs = register_static_field ( trim(field), 'zs', axes(1:2),  &
                                        'Original Mean Terrain', 'm' )
! 3D hybrid_z fields:
       id_ze = register_static_field ( trim(field), 'ze', axes(1:3),  &
                                        'Hybrid_Z_surface', 'm' )
! For mountain torque in zonal dir:
       id_oro = register_static_field ( trim(field), 'oro', axes(1:2),  &
                                        'Land/Water Mask', 'none' )
       id_sgh = register_static_field ( trim(field), 'sgh', axes(1:2),  &
                                        'Terrain Standard deviation', 'm' )
       id_ts = register_static_field ( trim(field), 'ts', axes(1:2),  &
                                        'Skin temperature', 'K' )

!--------------------
! Initial conditions:
!--------------------
       ic_ps  = register_static_field ( trim(field), 'ps_ic', axes(1:2),  &
                                         'initial surface pressure', 'Pa' )
       ic_ua = register_static_field ( trim(field), 'ua_ic', axes(1:3),        &
            'zonal wind', 'm/sec' )
       ic_va = register_static_field ( trim(field), 'va_ic', axes(1:3),        &
            'meridional wind', 'm/sec' )
       ic_ppt= register_static_field ( trim(field), 'ppt_ic', axes(1:3),        &
            'potential temperature perturbation', 'K' )

    end do

    master = (gid == masterproc)

    n = 1 

    allocate ( zsurf(isc:iec,jsc:jec) )

    do j=jsc,jec
       do i=isc,iec
          zsurf(i,j) = ginv * Atm(n)%phis(i,j)
       enddo
    enddo

!--- Send time independent data

    do n = 1, ntileMe
       isc = Atm(n)%isc; iec = Atm(n)%iec
       jsc = Atm(n)%jsc; jec = Atm(n)%jec
       if (id_lon  > 0) used = send_data(id_lon,  180./pi*Atm(n)%grid(isc:iec+1,jsc:jec+1,1), Time)
       if (id_lat  > 0) used = send_data(id_lat,  180./pi*Atm(n)%grid(isc:iec+1,jsc:jec+1,2), Time)
       if (id_lont > 0) used = send_data(id_lont, 180./pi*Atm(n)%agrid(isc:iec,jsc:jec,1), Time)
       if (id_latt > 0) used = send_data(id_latt, 180./pi*Atm(n)%agrid(isc:iec,jsc:jec,2), Time)
       if (id_area > 0) used = send_data(id_area, area(isc:iec,jsc:jec), Time)
#ifndef DYNAMICS_ZS
       if (id_zsurf > 0) used = send_data(id_zsurf, zsurf, Time)
#endif
       if ( Atm(n)%fv_land ) then
         if (id_zs  > 0) used = send_data(id_zs , zs_g, Time)
         if (id_oro > 0) used = send_data(id_oro, Atm(n)%oro(isc:iec,jsc:jec), Time)
         if (id_sgh > 0) used = send_data(id_sgh, Atm(n)%sgh(isc:iec,jsc:jec), Time)
       endif

       if ( Atm(n)%ncep_ic ) then
         if (id_ts > 0) used = send_data(id_ts, Atm(n)%ts(isc:iec,jsc:jec), Time)
       endif

       if ( Atm(n)%hybrid_z .and. id_ze > 0 ) &
                      used = send_data(id_ze, Atm(n)%ze0(isc:iec,jsc:jec,1:npz), Time)

       if (ic_ps > 0) used = send_data(ic_ps, Atm(n)%ps(isc:iec,jsc:jec)*ginv, Time)

       if(ic_ua > 0) used=send_data(ic_ua, Atm(n)%ua(isc:iec,jsc:jec,:), Time)
       if(ic_va > 0) used=send_data(ic_va, Atm(n)%va(isc:iec,jsc:jec,:), Time)

       pk0 = 1000.E2 ** kappa
       if(ic_ppt> 0) then
! Potential temperature
          allocate ( pt1(npz) )
          allocate ( a3(isc:iec,jsc:jec,npz) )
#ifdef TEST_GWAVES
          call gw_1d(npz, 1000.E2, Atm(n)%ak, Atm(n)%ak, Atm(n)%ak(1), 10.E3, pt1)
#else
          pt1 = 0.
#endif
          do k=1,npz
          do j=jsc,jec
             do i=isc,iec
                a3(i,j,k) =  (Atm(n)%pt(i,j,k)/Atm(n)%pkz(i,j,k) - pt1(k)) * pk0
             enddo
          enddo
          enddo
          used=send_data(ic_ppt, a3, Time)
          deallocate ( a3 )
          deallocate ( pt1 )
       endif
    end do

!--------------------------------------------------------------
! Register main prognostic fields: ps, (u,v), t, omega (dp/dt)
!--------------------------------------------------------------

    allocate(id_tracer(ncnst))

    do n = 1, ntileMe
       field= 'dynamics'

#ifdef DYNAMICS_ZS
       id_zsurf = register_diag_field ( trim(field), 'zsurf', axes(1:2), Time,           &
                                       'surface height', 'm')
#endif
!-------------------
! Surface pressure
!-------------------
       id_ps = register_diag_field ( trim(field), 'ps', axes(1:2), Time,           &
            'surface pressure', 'Pa', missing_value=missing_value )

!-------------------
! Mountain torque
!-------------------
       id_mq = register_diag_field ( trim(field), 'mq', axes(1:2), Time,           &
            'mountain torque', 'Hadleys per unit area', missing_value=missing_value )

!--------------
! 10 mb Height
!--------------
      id_h10 = register_diag_field (trim(field), 'h10', axes(1:2),  Time,   &
                                     '10-mb hght', 'm', missing_value=missing_value )
!--------------
! 50 mb Height
!--------------
      id_h50 = register_diag_field (trim(field), 'h50', axes(1:2),  Time,   &
                                     '50-mb hght', 'm', missing_value=missing_value )
!--------------
! 100 mb Height
!--------------
      id_h100 = register_diag_field (trim(field), 'h100', axes(1:2),  Time,   &
                                     '100-mb hght', 'm', missing_value=missing_value )
!--------------
! 200 mb Height
!--------------
      id_h200 = register_diag_field (trim(field), 'h200', axes(1:2),  Time,   &
                                     '200-mb hght', 'm', missing_value=missing_value )
!--------------
! 250 mb Height
!--------------
      id_h250 = register_diag_field (trim(field), 'h250', axes(1:2),  Time,   &
                                     '250-mb hght', 'm', missing_value=missing_value )
!--------------
! 300 mb Height
!--------------
      id_h300 = register_diag_field (trim(field), 'h300', axes(1:2),  Time,   &
                                     '300-mb hght', 'm', missing_value=missing_value )
!--------------
! 500 mb Height
!--------------
      id_h500 = register_diag_field (trim(field), 'h500', axes(1:2),  Time,   &
                                     '500-mb hght', 'm', missing_value=missing_value )
!--------------
! 700 mb Height
!--------------
      id_h700 = register_diag_field (trim(field), 'h700', axes(1:2),  Time,   &
                                     '700-mb hght', 'm', missing_value=missing_value )
!--------------
! 850 mb Height
!--------------
      id_h850 = register_diag_field (trim(field), 'h850', axes(1:2),  Time,   &
                                     '850-mb hght', 'm', missing_value=missing_value )

      ! flag for calculation of geopotential
      if ( id_h10>0  .or. id_h50>0  .or. id_h100>0 .or. id_h200>0 .or.  id_h250>0 .or. &
           id_h300>0 .or. id_h500>0 .or. id_h700>0 .or. id_h850>0 ) then
           id_hght = 1
      else
           id_hght = 0
      endif
!-----------------------------
! mean temp between 300-500 mb
!-----------------------------
      id_tm = register_diag_field (trim(field), 'tm', axes(1:2),  Time,   &
                                   'mean 300-500 mb temp', 'K', missing_value=missing_value )

!-------------------
! Sea-level-pressure
!-------------------
       id_slp = register_diag_field (trim(field), 'slp', axes(1:2),  Time,   &
                                     'sea-level pressure', 'mb', missing_value=missing_value,  &
                                      range=slprange )
!----------------------------------
! Bottom level pressure for masking
!----------------------------------
       id_pmask = register_diag_field (trim(field), 'pmask', axes(1:2),  Time,   &
                                     'masking pressure at lowest level', 'mb',   &
                                      missing_value=missing_value )
!------------------------------------------
! Fix for Bottom level pressure for masking
!------------------------------------------
       id_pmaskv2 = register_diag_field(TRIM(field), 'pmaskv2', axes(1:2), Time,&
            & 'masking pressure at lowest level', 'mb', missing_value=missing_value)
                                     
!-------------------
! Hurricane scales:
!-------------------
! Net effects: ~ intensity * freq
       id_c15 = register_diag_field (trim(field), 'cat15', axes(1:2),  Time,   &
                                     'de-pression < 1000', 'mb', missing_value=missing_value)
       id_c25 = register_diag_field (trim(field), 'cat25', axes(1:2),  Time,   &
                                     'de-pression < 980', 'mb', missing_value=missing_value)
       id_c35 = register_diag_field (trim(field), 'cat35', axes(1:2),  Time,   &
                                     'de-pression < 964', 'mb', missing_value=missing_value)
       id_c45 = register_diag_field (trim(field), 'cat45', axes(1:2),  Time,   &
                                     'de-pression < 944', 'mb', missing_value=missing_value)
! Frequency:
       id_f15 = register_diag_field (trim(field), 'f15', axes(1:2),  Time,   &
                                     'Cat15 frequency', 'none', missing_value=missing_value)
       id_f25 = register_diag_field (trim(field), 'f25', axes(1:2),  Time,   &
                                     'Cat25 frequency', 'none', missing_value=missing_value)
       id_f35 = register_diag_field (trim(field), 'f35', axes(1:2),  Time,   &
                                     'Cat35 frequency', 'none', missing_value=missing_value)
       id_f45 = register_diag_field (trim(field), 'f45', axes(1:2),  Time,   &
                                     'Cat45 frequency', 'none', missing_value=missing_value)
!-------------------
! A grid winds (lat-lon)
!-------------------
       id_ua = register_diag_field ( trim(field), 'ucomp', axes(1:3), Time,        &
            'zonal wind', 'm/sec', missing_value=missing_value, range=vrange )
       id_va = register_diag_field ( trim(field), 'vcomp', axes(1:3), Time,        &
            'meridional wind', 'm/sec', missing_value=missing_value, range=vrange)

       id_w = register_diag_field ( trim(field), 'w', axes(1:3), Time,        &
            'vertical wind', 'm/sec', missing_value=missing_value, range=wrange )

       id_pt   = register_diag_field ( trim(field), 'temp', axes(1:3), Time,       &
            'temperature', 'K', missing_value=missing_value, range=trange )
       id_ppt  = register_diag_field ( trim(field), 'ppt', axes(1:3), Time,       &
            'potential temperature perturbation', 'K', missing_value=missing_value )
       id_omga = register_diag_field ( trim(field), 'omega', axes(1:3), Time,      &
            'omega', 'Pa/s', missing_value=missing_value )
       id_divg  = register_diag_field ( trim(field), 'divg', axes(1:3), Time,      &
            'mean divergence', '1/s', missing_value=missing_value )

       id_rh = register_diag_field ( trim(field), 'rh', axes(1:3), Time,        &
            'Relative Humidity', '%', missing_value=missing_value, range=rhrange )
! Total energy (only when moist_phys = .T.)
       id_te    = register_diag_field ( trim(field), 'te', axes(1:2), Time,      &
            'Total Energy', 'J/kg', missing_value=missing_value )
!--------------------
! Relative vorticity
!--------------------
       id_vort = register_diag_field ( trim(field), 'vort', axes(1:3), Time,       &
            'vorticity', '1/s', missing_value=missing_value )
!--------------------
! Potential vorticity
!--------------------
       id_pv = register_diag_field ( trim(field), 'pv', axes(1:3), Time,       &
            'potential vorticity', '1/s', missing_value=missing_value )

#ifdef MARS_GCM
!--------------------------
! Extra Martian diagnostics:
!--------------------------

       id_t05 = register_diag_field ( trim(field), 't05', axes(1:2), Time,       &
               '0.5-mb temperature', 'K', missing_value=missing_value )
!!       id_sfc_dust = register_diag_field ( trim(field), 'sfc_dust', axes(1:2), Time,        &
!!             'Total sfc dust', 'kg/m**2', missing_value=missing_value )
!!        id_tdust = register_diag_field ( trim(field), 'odcol', axes(1:2), Time,        &
!!             'Total dust column', 'kg/m**2', missing_value=missing_value )
#endif MARS_GCM

!--------------------------
! Extra surface diagnistics:
!--------------------------
! Surface (lowest layer) vorticity: for tropical cyclones diag.
       id_vorts = register_diag_field ( trim(field), 'vorts', axes(1:2), Time,       &
            'surface vorticity', '1/s', missing_value=missing_value )
       id_us = register_diag_field ( trim(field), 'us', axes(1:2), Time,        &
            'surface u-wind', 'm/sec', missing_value=missing_value, range=vsrange )
       id_vs = register_diag_field ( trim(field), 'vs', axes(1:2), Time,        &
            'surface v-wind', 'm/sec', missing_value=missing_value, range=vsrange )
!       id_tq = register_diag_field ( trim(field), 'tq', axes(1:2), Time,        &
!            'Total water vapor', 'kg/m**2', missing_value=missing_value )
       id_tq = register_diag_field ( trim(field), 'tq', axes(1:2), Time,        &
            'Total water path', 'kg/m**2', missing_value=missing_value )

!--------------------------
! 850-mb vorticity
!--------------------------
       id_vort850 = register_diag_field ( trim(field), 'vort850', axes(1:2), Time,       &
                           '850-mb vorticity', '1/s', missing_value=missing_value )

!--------------------------
! 10-mb winds:
!--------------------------
       id_u10 = register_diag_field ( trim(field), 'u10', axes(1:2), Time,       &
                           '10-mb u-wind', '1/s', missing_value=missing_value )
       id_v10 = register_diag_field ( trim(field), 'v10', axes(1:2), Time,       &
                           '10-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! 50-mb winds:
!--------------------------
       id_u50 = register_diag_field ( trim(field), 'u50', axes(1:2), Time,       &
                           '50-mb u-wind', '1/s', missing_value=missing_value )
       id_v50 = register_diag_field ( trim(field), 'v50', axes(1:2), Time,       &
                           '50-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! 100-mb winds:
!--------------------------
       id_u100 = register_diag_field ( trim(field), 'u100', axes(1:2), Time,       &
                           '100-mb u-wind', '1/s', missing_value=missing_value )
       id_v100 = register_diag_field ( trim(field), 'v100', axes(1:2), Time,       &
                           '100-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! 200-mb winds:
!--------------------------
       id_u200 = register_diag_field ( trim(field), 'u200', axes(1:2), Time,       &
                           '200-mb u-wind', '1/s', missing_value=missing_value )
       id_v200 = register_diag_field ( trim(field), 'v200', axes(1:2), Time,       &
                           '200-mb v-wind', '1/s', missing_value=missing_value )
       id_w200 = register_diag_field ( trim(field), 'w200', axes(1:2), Time,       &
                           '200-mb w-wind', '1/s', missing_value=missing_value )
! s200: wind speed for computing KE spectrum
! Cubed_2_latlon interpolation is more accurate, particularly near the poles, using
! winds speed (a scalar), rather than wind vectors or kinetic energy directly.
       id_s200 = register_diag_field ( trim(field), 's200', axes(1:2), Time,       &
                           '200-mb wind_speed', 'm/s', missing_value=missing_value )
       id_sl12 = register_diag_field ( trim(field), 'sl12', axes(1:2), Time,       &
                           '12th L wind_speed', 'm/s', missing_value=missing_value )
       id_sl13 = register_diag_field ( trim(field), 'sl13', axes(1:2), Time,       &
                           '13th L wind_speed', 'm/s', missing_value=missing_value )
!--------------------------
! 250-mb winds:
!--------------------------
       id_u250 = register_diag_field ( trim(field), 'u250', axes(1:2), Time,       &
                           '250-mb u-wind', '1/s', missing_value=missing_value )
       id_v250 = register_diag_field ( trim(field), 'v250', axes(1:2), Time,       &
                           '250-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! 500-mb winds:
!--------------------------
       id_u500 = register_diag_field ( trim(field), 'u500', axes(1:2), Time,       &
                           '500-mb u-wind', '1/s', missing_value=missing_value )
       id_v500 = register_diag_field ( trim(field), 'v500', axes(1:2), Time,       &
                           '500-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! 700-mb winds:
!--------------------------
       id_u700 = register_diag_field ( trim(field), 'u700', axes(1:2), Time,       &
                           '700-mb u-wind', '1/s', missing_value=missing_value )
       id_v700 = register_diag_field ( trim(field), 'v700', axes(1:2), Time,       &
                           '700-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! 850-mb winds:
!--------------------------
       id_u850 = register_diag_field ( trim(field), 'u850', axes(1:2), Time,       &
                           '850-mb u-wind', '1/s', missing_value=missing_value )
       id_v850 = register_diag_field ( trim(field), 'v850', axes(1:2), Time,       &
                           '850-mb v-wind', '1/s', missing_value=missing_value )
       id_w850 = register_diag_field ( trim(field), 'w850', axes(1:2), Time,       &
                           '850-mb w-wind', '1/s', missing_value=missing_value )
!--------------------------
! 1000-mb winds:
!--------------------------
       id_u1000 = register_diag_field ( trim(field), 'u1000', axes(1:2), Time,       &
                           '1000-mb u-wind', '1/s', missing_value=missing_value )
       id_v1000 = register_diag_field ( trim(field), 'v1000', axes(1:2), Time,       &
                           '1000-mb v-wind', '1/s', missing_value=missing_value )
!--------------------------
! temperature:
!--------------------------
       id_t10 = register_diag_field ( trim(field), 't10', axes(1:2), Time,       &
                           '10-mb temperature', 'K', missing_value=missing_value )
       id_t50 = register_diag_field ( trim(field), 't50', axes(1:2), Time,       &
                           '50-mb temperature', 'K', missing_value=missing_value )
       id_t100 = register_diag_field ( trim(field), 't100', axes(1:2), Time,       &
                           '100-mb temperature', 'K', missing_value=missing_value )
       id_t200 = register_diag_field ( trim(field), 't200', axes(1:2), Time,       &
                           '200-mb temperature', 'K', missing_value=missing_value )
       id_t250 = register_diag_field ( trim(field), 't250', axes(1:2), Time,       &
                           '250-mb temperature', 'K', missing_value=missing_value )
       id_t500 = register_diag_field ( trim(field), 't500', axes(1:2), Time,       &
                           '500-mb temperature', 'K', missing_value=missing_value )
       id_t700 = register_diag_field ( trim(field), 't700', axes(1:2), Time,       &
                           '700-mb temperature', 'K', missing_value=missing_value )
       id_t850 = register_diag_field ( trim(field), 't850', axes(1:2), Time,       &
                           '850-mb temperature', 'K', missing_value=missing_value )
       id_t1000 = register_diag_field ( trim(field), 't1000', axes(1:2), Time,       &
                           '1000-mb temperature', 'K', missing_value=missing_value )
!--------------------------
! specific humidity:
!--------------------------
       id_q10 = register_diag_field ( trim(field), 'q10', axes(1:2), Time,       &
                           '10-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q50 = register_diag_field ( trim(field), 'q50', axes(1:2), Time,       &
                           '50-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q100 = register_diag_field ( trim(field), 'q100', axes(1:2), Time,       &
                           '100-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q200 = register_diag_field ( trim(field), 'q200', axes(1:2), Time,       &
                           '200-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q250 = register_diag_field ( trim(field), 'q250', axes(1:2), Time,       &
                           '250-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q500 = register_diag_field ( trim(field), 'q500', axes(1:2), Time,       &
                           '500-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q700 = register_diag_field ( trim(field), 'q700', axes(1:2), Time,       &
                           '700-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q850 = register_diag_field ( trim(field), 'q850', axes(1:2), Time,       &
                           '850-mb specific humidity', 'kg/kg', missing_value=missing_value )
       id_q1000 = register_diag_field ( trim(field), 'q1000', axes(1:2), Time,       &
                           '1000-mb specific humidity', 'kg/kg', missing_value=missing_value )
!--------------------------
! relative humidity (physics definition):
!--------------------------
       id_rh50 = register_diag_field ( trim(field), 'rh50', axes(1:2), Time,       &
                           '50-mb relative humidity', '%', missing_value=missing_value )
       id_rh100 = register_diag_field ( trim(field), 'rh100', axes(1:2), Time,       &
                           '100-mb relative humidity', '%', missing_value=missing_value )
       id_rh200 = register_diag_field ( trim(field), 'rh200', axes(1:2), Time,       &
                           '200-mb relative humidity', '%', missing_value=missing_value )
       id_rh250 = register_diag_field ( trim(field), 'rh250', axes(1:2), Time,       &
                           '250-mb relative humidity', '%', missing_value=missing_value )
       id_rh500 = register_diag_field ( trim(field), 'rh500', axes(1:2), Time,       &
                           '500-mb relative humidity', '%', missing_value=missing_value )
       id_rh700 = register_diag_field ( trim(field), 'rh700', axes(1:2), Time,       &
                           '700-mb relative humidity', '%', missing_value=missing_value )
       id_rh850 = register_diag_field ( trim(field), 'rh850', axes(1:2), Time,       &
                           '850-mb relative humidity', '%', missing_value=missing_value )
       id_rh1000 = register_diag_field ( trim(field), 'rh1000', axes(1:2), Time,       &
                           '1000-mb relative humidity', '%', missing_value=missing_value )
!--------------------------
! relative humidity (CMIP definition):
!--------------------------
       id_rh10_cmip = register_diag_field ( trim(field), 'rh10_cmip', axes(1:2), Time,       &
                           '10-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh50_cmip = register_diag_field ( trim(field), 'rh50_cmip', axes(1:2), Time,       &
                           '50-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh100_cmip = register_diag_field ( trim(field), 'rh100_cmip', axes(1:2), Time,       &
                           '100-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh250_cmip = register_diag_field ( trim(field), 'rh250_cmip', axes(1:2), Time,       &
                           '250-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh500_cmip = register_diag_field ( trim(field), 'rh500_cmip', axes(1:2), Time,       &
                           '500-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh700_cmip = register_diag_field ( trim(field), 'rh700_cmip', axes(1:2), Time,       &
                           '700-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh850_cmip = register_diag_field ( trim(field), 'rh850_cmip', axes(1:2), Time,       &
                           '850-mb relative humidity (CMIP)', '%', missing_value=missing_value )
       id_rh1000_cmip = register_diag_field ( trim(field), 'rh1000_cmip', axes(1:2), Time,       &
                           '1000-mb relative humidity (CMIP)', '%', missing_value=missing_value )
!--------------------------
! specific humidity:
!--------------------------
       id_omg10 = register_diag_field ( trim(field), 'omg10', axes(1:2), Time,       &
                           '10-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg50 = register_diag_field ( trim(field), 'omg50', axes(1:2), Time,       &
                           '50-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg100 = register_diag_field ( trim(field), 'omg100', axes(1:2), Time,       &
                           '100-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg200 = register_diag_field ( trim(field), 'omg200', axes(1:2), Time,       &
                           '200-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg250 = register_diag_field ( trim(field), 'omg250', axes(1:2), Time,       &
                           '250-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg500 = register_diag_field ( trim(field), 'omg500', axes(1:2), Time,       &
                           '500-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg700 = register_diag_field ( trim(field), 'omg700', axes(1:2), Time,       &
                           '700-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg850 = register_diag_field ( trim(field), 'omg850', axes(1:2), Time,       &
                           '850-mb omega', 'Pa/s', missing_value=missing_value )
       id_omg1000 = register_diag_field ( trim(field), 'omg1000', axes(1:2), Time,       &
                           '1000-mb omega', 'Pa/s', missing_value=missing_value )

!--------------------
! Tracer diagnostics:
!--------------------
       do i=1, ncnst
           call get_tracer_names ( MODEL_ATMOS, i, tname, tlongname, tunits )
           id_tracer(i) = register_diag_field ( field, trim(tname),  &
                axes(1:3), Time, trim(tlongname), &
                trim(tunits), missing_value=missing_value)
           if (master) then
               if (id_tracer(i) > 0) then
                   unit = stdlog()
                   write(unit,'(a,a,a,a)') &
                        & 'Diagnostics available for tracer ',tname, &
                        ' in module ', field
               end if
           endif
       enddo

       if ( id_mq > 0 )  then
            allocate ( zxg(isc:iec,jsc:jec) )
! Initialize gradient of terrain for mountain torque computation:
            call init_mq(Atm(n)%phis, Atm(n)%agrid(isc:iec,jsc:jec,2), npx, npy, isc, iec, jsc, jec, Atm(n)%ng)
       endif

    end do

    call nullify_domain()  ! Nullify  set_domain info

    module_is_initialized=.true.
 end subroutine fv_diag_init


 subroutine init_mq(phis, rlat, npx, npy, is, ie, js, je, ng)
    integer, intent(in):: npx, npy, is, ie, js, je, ng
    real, intent(in):: phis(is-ng:ie+ng, js-ng:je+ng)
    real, intent(in):: rlat(is:ie, js:je)  ! latitude (radian)
! local:
    real zs(is-ng:ie+ng, js-ng:je+ng)
    real zb(is-ng:ie+ng, js-ng:je+ng)
    real pdx(3,is:ie,js:je+1)
    real pdy(3,is:ie+1,js:je)
    integer i, j, n

!   do j=js,je
!      do i=is,ie
    do j=js-ng,je+ng
       do i=is-ng,ie+ng
          zs(i,j) = phis(i,j) / grav
       enddo
    enddo
!   call mpp_update_domains( zs, domain )

    call a2b_ord4(zs, zb, npx, npy, is, ie, js, je, ng)

    do j=js,je+1
       do i=is,ie
          do n=1,3
             pdx(n,i,j) = 0.5*(zb(i,j)+zb(i+1,j))*dx(i,j)*en1(n,i,j)
          enddo
       enddo
    enddo
    do j=js,je
       do i=is,ie+1
          do n=1,3
             pdy(n,i,j) = 0.5*(zb(i,j)+zb(i,j+1))*dy(i,j)*en2(n,i,j)
          enddo
       enddo
    enddo

! Compute gradient by Green's theorem
    do j=js,je
       do i=is,ie
          zxg(i,j) = vlon(i,j,1)*(pdx(1,i,j+1)-pdx(1,i,j)-pdy(1,i,j)+pdy(1,i+1,j))  &
                   + vlon(i,j,2)*(pdx(2,i,j+1)-pdx(2,i,j)-pdy(2,i,j)+pdy(2,i+1,j))  &
                   + vlon(i,j,3)*(pdx(3,i,j+1)-pdx(3,i,j)-pdy(3,i,j)+pdy(3,i+1,j))
! Times surface pressure to get Hadleys per unit area
! Unit Hadley = 1.E18 kg m**2 / s**2
          zxg(i,j) = -zxg(i,j) * radius * cos(rlat(i,j)) * rarea(i,j) * 1.E-18
       enddo
    enddo

 end subroutine init_mq

 subroutine fv_diag(Atm, zvir, Time, print_freq)

    type(fv_atmos_type), intent(inout) :: Atm(:)
    type(time_type),     intent(in) :: Time
    real,                intent(in):: zvir
    integer,             intent(in):: print_freq

    integer :: isc, iec, jsc, jec, n, ntileMe
    integer :: isd, ied, jsd, jed, npz, itrac
    integer :: ngc, nwater

    real, allocatable :: a2(:,:),a3(:,:,:), wk(:,:,:), wz(:,:,:), ucoor(:,:,:), vcoor(:,:,:)
    real, allocatable :: slp(:,:), depress(:,:), ws_max(:,:), tc_count(:,:)
    real, allocatable :: u2(:,:), v2(:,:)
    real height(2)
    real plevs(9)
    real tot_mq, tmp
    logical :: used
    logical :: bad_range
    logical :: prt_minmax
    integer i,j,k, yr, mon, dd, hr, mn, days, seconds
    character(len=128)   :: tname
    real, parameter:: ws_0 = 16.   ! minimum max_wind_speed within the 7x7 search box
    real, parameter:: ws_1 = 20.
    real, parameter:: vort_c0= 2.2e-5 
    logical, allocatable :: storm(:,:), cat_crt(:,:)

#ifdef MARS_GCM
    real  ::   atm_mass,  sfc_mass, atm_cloud
    real  ::   tsfc_dust, tcol_dust
#endif

! cat15: SLP<1000; srf_wnd>ws_0; vort>vort_c0
! cat25: SLP< 980; srf_wnd>ws_1; vort>vort_c0
! cat35: SLP< 964; srf_wnd>ws_1; vort>vort_c0
! cat45: SLP< 944; srf_wnd>ws_1; vort>vort_c0

    height(1) = 5.E3      ! for computing 5-km "pressure"
    height(2) = 0.        ! for sea-level pressure

    ntileMe = size(Atm(:))
    n = 1
    isc = Atm(n)%isc; iec = Atm(n)%iec
    jsc = Atm(n)%jsc; jec = Atm(n)%jec
    ngc = Atm(n)%ng
    npz = Atm(n)%npz
    ptop = Atm(n)%ak(1)

    isd = Atm(n)%isd; ied = Atm(n)%ied
    jsd = Atm(n)%jsd; jed = Atm(n)%jed


    if( id_c15>0 ) then
        allocate (   storm(isc:iec,jsc:jec) )
        allocate ( depress(isc:iec,jsc:jec) )
        allocate (  ws_max(isc:iec,jsc:jec) )
        allocate ( cat_crt(isc:iec,jsc:jec) )
        allocate (tc_count(isc:iec,jsc:jec) )
    endif

    fv_time = Time
    call set_domain(Atm(1)%domain)

    if ( moist_phys ) then
#if defined(MARS_GCM) || defined(VENUS_GCM)
         call get_time (fv_time, seconds,  days)
         mn= 0
         hr= 0
         mon= 0
#else
         call get_date(fv_time, yr, mon, dd, hr, mn, seconds)
#endif 
         if( print_freq == 0 ) then
                 prt_minmax = .false.
         elseif( print_freq < 0 ) then
                 prt_minmax = .true.
         else
                 prt_minmax = mod(hr, print_freq) == 0 .and. mn==0 .and. seconds==0
         endif
     else
         call get_time (fv_time, seconds,  days)
         if( print_freq == 0 ) then
                 prt_minmax = .false.
         elseif( print_freq < 0 ) then
                 prt_minmax = .true.
         else
                 prt_minmax = mod(seconds, 3600*print_freq) == 0
         endif
     endif

     if(prt_minmax) then
#if defined(MARS_GCM) || defined(VENUS_GCM)
        if(master) write(6,*) Days, seconds
#else
         if ( moist_phys ) then
              if(master) write(6,*) yr, mon, dd, hr, mn, seconds
         else
              if(master) write(6,*) Days, seconds
         endif
#endif
     endif

    if( prt_minmax ) then

        call prt_maxmin('ZS', zsurf,     isc, iec, jsc, jec, 0,   1, 1.0,  master)
        call prt_maxmin('PS', Atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01, master)

        call prt_mass(npz, ncnst, isc, iec, jsc, jec, ngc, Atm(n)%nwat,    &
                      Atm(n)%ps, Atm(n)%delp, Atm(n)%q, master)
#ifndef SW_DYNAMICS
             steps = steps + 1
           efx_sum = efx_sum + E_Flux
        if ( steps <= max_step ) efx(steps) = E_Flux
        if (master)  then
            write(6,*) 'ENG Deficit (W/m**2)=', E_Flux
        endif
#endif
        call prt_maxmin('UA', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, 1., master)
        call prt_maxmin('VA', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, 1., master)

        if ( .not. Atm(n)%hydrostatic ) then
          call prt_maxmin('W ', Atm(n)%w , isc, iec, jsc, jec, ngc, npz, 1., master)
          if ( Atm(n)%hybrid_z ) call prt_maxmin('Hybrid_ZTOP (km)', Atm(n)%ze0(isc:iec,jsc:jec,1), &
                                                 isc, iec, jsc, jec, 0, 1, 1.E-3, master)
          call prt_maxmin('Bottom DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,npz),    &
                          isc, iec, jsc, jec, 0, 1, 1., master)
          call prt_maxmin('Top DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,1),    &
                          isc, iec, jsc, jec, 0, 1, 1., master)
        endif

#ifndef SW_DYNAMICS
        call prt_maxmin('TA', Atm(n)%pt,   isc, iec, jsc, jec, ngc, npz, 1., master)
        call prt_maxmin('OM', Atm(n)%omga, isc, iec, jsc, jec, ngc, npz, 1., master)
#endif

#if defined(MARS_GCM) && defined(MARS_SURFACE)
        atm_mass  = g_sum( Atm(n)%ps(isc:iec,jsc:jec), isc, iec, jsc, jec, ngc, area,mode=1)
        sfc_mass  = g_sum( sfc_snow,isc, iec, jsc, jec, ngc, area,mode=1)
        sfc_mass= sfc_mass*grav   !   Conversion to pressure units

        if(master) write(*,*) 'Atmospheric CO2 (mb) =', atm_mass*0.01
        if(master) write(*,*) 'CO2 sfc frost   (mb) =', sfc_mass*0.01
        if(master) write(*,*) 'Total CO2 Inventory  =', (atm_mass+sfc_mass)*0.01

#ifdef WATER_CYCLE
        sfc_mass  = g_sum( sfc_frost, isc, iec, jsc, jec, ngc, area,mode=1)
        atm_mass  = g_sum(      wcol, isc, iec, jsc, jec, ngc, area,mode=1)
        atm_cloud = g_sum(    cldcol, isc, iec, jsc, jec, ngc, area,mode=1)
        sfc_mass= sfc_mass - 3.7   !  Arbitrary offset

        if(master) write(*,*) 'Atmospheric H2o vapor (kg/m**2) =', atm_mass
        if(master) write(*,*) 'Atmospheric H2o cloud (kg/m**2) =', atm_cloud
        if(master) write(*,*) 'Total Atmospheric H2o ', atm_cloud + atm_mass

        if(master) write(*,*) 'H2O surface frost (kg/m**2) ==', sfc_mass
        if(master) write(*,*) 'Total H2O inventory =', atm_mass+sfc_mass+atm_cloud
#endif WATER_CYCLE

#ifdef DUST_SOURCE
        tsfc_dust  = g_sum( sfc_dust(:,:,1),isc, iec, jsc, jec, ngc, area,mode=1)
        tcol_dust  = g_sum( odcol   (:,:,1),isc, iec, jsc, jec, ngc, area,mode=1)

        if(master) write(*,*) 'Surface dust inventory (kg/m**2) =', tsfc_dust - 30.0
        if(master) write(*,*) 'Atmospheric dust (kg/m**2) =', tcol_dust
        if(master) write(*,*) 'Total dust inventory ', tsfc_dust - 30.0 + tcol_dust
#endif DUST_SOURCE
#endif

    elseif ( Atm(n)%range_warn ) then
         call range_check('DELP', Atm(n)%delp, isc, iec, jsc, jec, ngc, npz, Atm(n)%agrid,    &
                           master, 0.1*ptop, 200.E2, bad_range)
         call range_check('UA', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, Atm(n)%agrid,   &
                           master, -220., 250., bad_range)
         call range_check('VA', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, Atm(n)%agrid,   &
                           master, -220., 220., bad_range)
#ifndef SW_DYNAMICS
         call range_check('TA', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, Atm(n)%agrid,   &
                           master, 150., 350., bad_range)
#endif

    endif

    allocate ( a2(isc:iec,jsc:jec) )
    allocate ( wk(isc:iec,jsc:jec,npz) )

    do n = 1, ntileMe

#ifdef DYNAMICS_ZS
       if(id_zsurf > 0)  used=send_data(id_zsurf, zsurf, Time)
#endif
       if(id_ps > 0) used=send_data(id_ps, Atm(n)%ps(isc:iec,jsc:jec), Time)

       if(id_c15>0 .or. id_c25>0 .or. id_c35>0 .or. id_c45>0) then
          call wind_max(isc, iec, jsc, jec ,isd, ied, jsd, jed, Atm(n)%ua(isc:iec,jsc:jec,npz),   &
                        Atm(n)%va(isc:iec,jsc:jec,npz), ws_max)
          do j=jsc,jec
             do i=isc,iec
                if( abs(Atm(n)%agrid(i,j,2)*rad2deg)<60.0 .and.     &
                    Atm(n)%phis(i,j)*ginv<500.0 .and. ws_max(i,j)>ws_0 ) then
                    storm(i,j) = .true.
                else
                    storm(i,j) = .false.
                endif
             enddo
          enddo
       endif

       if ( id_vort850>0 .or. id_vorts>0 .or. id_vort>0 .or. id_pv>0 .or. id_rh>0 ) then
          call get_vorticity(isc, iec, jsc, jec, isd, ied, jsd, jed, npz, Atm(n)%u, Atm(n)%v, wk)

          if(id_vort >0) used=send_data(id_vort,  wk, Time)
          if(id_vorts>0) used=send_data(id_vorts, wk(isc:iec,jsc:jec,npz), Time)

          if(id_c15>0) then
             do j=jsc,jec
                do i=isc,iec
                   if ( storm(i,j) )    &
                   storm(i,j) = (Atm(n)%agrid(i,j,2)>0. .and. wk(i,j,npz)> vort_c0) .or. &
                                (Atm(n)%agrid(i,j,2)<0. .and. wk(i,j,npz)<-vort_c0) 
                enddo
             enddo
          endif


          if(id_vort850>0) then
             call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                       850.e2, Atm(n)%peln, wk, a2)
             used=send_data(id_vort850, a2, Time)

             if(id_c15>0) then
             do j=jsc,jec
                do i=isc,iec
                   if ( storm(i,j) )    &
                     storm(i,j) = (Atm(n)%agrid(i,j,2)>0. .and. a2(i,j)> vort_c0) .or.     &
                                  (Atm(n)%agrid(i,j,2)<0. .and. a2(i,j)<-vort_c0) 
                enddo
             enddo
             endif

          endif

          if ( id_pv > 0 ) then
! Note: this is expensive computation.
              call pv_entropy(isc, iec, jsc, jec, ngc, npz, wk,    &
                              f0, Atm(n)%pt, Atm(n)%pkz, Atm(n)%delp, grav)
              used = send_data ( id_pv, wk, Time )
          endif

! Relative Humidity
          if ( id_rh > 0 ) then
! Compute FV mean pressure
               do k=1,npz
                  do j=jsc,jec
                     do i=isc,iec
                        a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
                     enddo
                  enddo
                  call qsmith(iec-isc+1, jec-jsc+1, 1, Atm(n)%pt(isc:iec,jsc:jec,k),   &
                              a2, Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc,jsc,k))
                  do j=jsc,jec
                     do i=isc,iec
                        wk(i,j,k) = 100.*Atm(n)%q(i,j,k,sphum)/wk(i,j,k)
                     enddo
                  enddo
               enddo
               used = send_data ( id_rh, wk, Time )
               if(prt_minmax) then
                  call prt_maxmin('RH_sf (%)', wk(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0,   1, 1., master)
                  call prt_maxmin('RH_3D (%)', wk, isc, iec, jsc, jec, 0, npz, 1., master)
               endif
          endif

       endif

       ! rel hum from physics at selected press levels (for IPCC)
       if (id_rh50>0  .or. id_rh100>0 .or. id_rh200>0 .or. id_rh250>0 .or. &
           id_rh500>0 .or. id_rh700>0 .or. id_rh850>0 .or. id_rh1000>0) then
           ! compute mean pressure
           do k=1,npz
               do j=jsc,jec
               do i=isc,iec
                   a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
               enddo
               enddo
               call rh_calc (a2, Atm(n)%pt(isc:iec,jsc:jec,k), &
                             Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k))
           enddo
           if (id_rh50>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh50, a2, Time)
           endif
           if (id_rh100>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh100, a2, Time)
           endif
           if (id_rh200>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh200, a2, Time)
           endif
           if (id_rh250>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh250, a2, Time)
           endif
           if (id_rh500>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh500, a2, Time)
           endif
           if (id_rh700>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh700, a2, Time)
           endif
           if (id_rh850>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh850, a2, Time)
           endif
           if (id_rh1000>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh1000, a2, Time)
           endif
       endif
       ! rel hum (CMIP definition) at selected press levels  (for IPCC)
       if (id_rh10_cmip>0 .or. id_rh50_cmip>0  .or. id_rh100_cmip>0 .or. &
           id_rh250_cmip>0 .or. id_rh500_cmip>0 .or. id_rh700_cmip>0 .or. &
           id_rh850_cmip>0 .or. id_rh1000_cmip>0) then
           ! compute mean pressure
           do k=1,npz
               do j=jsc,jec
               do i=isc,iec
                   a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
               enddo
               enddo
               call rh_calc (a2, Atm(n)%pt(isc:iec,jsc:jec,k), &
                             Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k), do_cmip=.true.)
           enddo
           if (id_rh10_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 10.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh10_cmip, a2, Time)
           endif
           if (id_rh50_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh50_cmip, a2, Time)
           endif
           if (id_rh100_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh100_cmip, a2, Time)
           endif
           if (id_rh250_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh250_cmip, a2, Time)
           endif
           if (id_rh500_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh500_cmip, a2, Time)
           endif
           if (id_rh700_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh700_cmip, a2, Time)
           endif
           if (id_rh850_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh850_cmip, a2, Time)
           endif
           if (id_rh1000_cmip>0) then
               call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
               used=send_data(id_rh1000_cmip, a2, Time)
           endif
       endif

       if(id_c25>0 .or. id_c35>0 .or. id_c45>0) then
          do j=jsc,jec
             do i=isc,iec
                if ( storm(i,j) .and. ws_max(i,j)>ws_1 ) then
                     cat_crt(i,j) = .true.
                else
                     cat_crt(i,j) = .false.
                endif
             enddo
          enddo
       endif



       if( id_slp>0 .or. id_tm>0 .or. id_hght>0 .or. id_c15>0 ) then

          allocate ( wz(isc:iec,jsc:jec,npz+1) )
          call get_height_field(isc, iec, jsc, jec, ngc, npz, wz, Atm(n)%pt, Atm(n)%q, Atm(n)%peln, zvir)
          if( prt_minmax )   &
          call prt_maxmin('ZTOP', wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3, master)

          if(id_slp > 0) then
! Cumpute SLP (pressure at height=0)
          allocate ( slp(isc:iec,jsc:jec) )
          call get_pressure_given_height(isc, iec, jsc, jec, ngc, npz, wz, 1, height(2),   &
                                        Atm(n)%pt(:,:,npz), Atm(n)%peln, slp, 0.01)
          used = send_data (id_slp, slp, Time)
          if( prt_minmax )   &
             call prt_maxmin('SLP', slp, isc, iec, jsc, jec, 0, 1, 1., master)
          endif

! Compute H3000 and/or H500
          if( id_tm>0 .or. id_hght>0 .or. id_ppt>0) then

              allocate( a3(isc:iec,jsc:jec,size(plevs,1)) )
              plevs(1) = log( 1000. )
              plevs(2) = log( 5000. )
              plevs(3) = log( 10000. )
              plevs(4) = log( 20000. )
              plevs(5) = log( 25000. )
              plevs(6) = log( 30000. )
              plevs(7) = log( 50000. )
              plevs(8) = log( 70000. )
              plevs(9) = log( 85000. )

             call get_height_given_pressure(isc, iec, jsc, jec, ngc, npz, wz, 9, plevs, Atm(n)%peln, a3)
             if(id_h10>0)  used = send_data ( id_h10,  a3(isc:iec,jsc:jec,1), Time )
             if(id_h50>0)  used = send_data ( id_h50,  a3(isc:iec,jsc:jec,2), Time )
             if(id_h100>0) used = send_data ( id_h100, a3(isc:iec,jsc:jec,3), Time )
             if(id_h200>0) used = send_data ( id_h200, a3(isc:iec,jsc:jec,4), Time )
             if(id_h250>0) used = send_data ( id_h250, a3(isc:iec,jsc:jec,5), Time )
             if(id_h300>0) used = send_data ( id_h300, a3(isc:iec,jsc:jec,6), Time )
             if(id_h500>0) used = send_data ( id_h500, a3(isc:iec,jsc:jec,7), Time )
             if(id_h700>0) used = send_data ( id_h700, a3(isc:iec,jsc:jec,8), Time )
             if(id_h850>0) used = send_data ( id_h850, a3(isc:iec,jsc:jec,9), Time )

             ! mean temp 300mb to 500mb
             if( id_tm>0 ) then
                 do j=jsc,jec
                    do i=isc,iec
                       a2(i,j) = grav*(a3(i,j,6)-a3(i,j,7))/(rdgas*(plevs(7)-plevs(6)))
                    enddo
                 enddo
                 used = send_data ( id_tm, a2, Time )
             endif

            if(id_c15>0 .or. id_c25>0 .or. id_c35>0 .or. id_c45>0) then
             do j=jsc,jec
                do i=isc,iec
! Minimum warm core:
                   if ( storm(i,j) ) then
                        if( a2(i,j)<254.0 .or. Atm(n)%pt(i,j,npz)<281.0 ) Then
                              storm(i,j) = .false.
                            cat_crt(i,j) = .false.
                        endif
                   endif
                enddo
             enddo
! Cat 1-5:
             do j=jsc,jec
                do i=isc,iec
                   if ( storm(i,j) .and. slp(i,j)<1000.0 ) then
                         depress(i,j) = 1000. - slp(i,j)
                        tc_count(i,j) = 1.
                   else
                         depress(i,j) = 0.
                        tc_count(i,j) = 0.
                   endif
                enddo
             enddo
             used = send_data(id_c15, depress, Time)
             if(id_f15>0) used = send_data(id_f15, tc_count, Time)
             if(prt_minmax) then
!               tmp = g_sum(depress, isc, iec, jsc, jec, ngc, area, 1) 
!               if(master) write(*,*) 'Mean Tropical Cyclone depression (mb)=', tmp
                call prt_maxmin('Depression', depress, isc, iec, jsc, jec, 0,   1, 1., master)
             endif
            endif

! Cat 2-5:
            if(id_c25>0) then
             do j=jsc,jec
                do i=isc,iec
                   if ( cat_crt(i,j) .and. slp(i,j)<980.0 ) then
                        depress(i,j) = 980. - slp(i,j)
                       tc_count(i,j) = 1.
                   else
                        depress(i,j) = 0.
                       tc_count(i,j) = 0.
                   endif
                enddo
             enddo
             used = send_data(id_c25, depress, Time)
             if(id_f25>0) used = send_data(id_f25, tc_count, Time)
            endif

! Cat 3-5:
            if(id_c35>0) then
             do j=jsc,jec
                do i=isc,iec
                   if ( cat_crt(i,j) .and. slp(i,j)<964.0 ) then
                        depress(i,j) = 964. - slp(i,j)
                       tc_count(i,j) = 1.
                   else
                        depress(i,j) = 0.
                       tc_count(i,j) = 0.
                   endif
                enddo
             enddo
             used = send_data(id_c35, depress, Time)
             if(id_f35>0) used = send_data(id_f35, tc_count, Time)
            endif

! Cat 4-5:
            if(id_c45>0) then
             do j=jsc,jec
                do i=isc,iec
                   if ( cat_crt(i,j) .and. slp(i,j)<944.0 ) then
                        depress(i,j) = 944. - slp(i,j)
                       tc_count(i,j) = 1.
                   else
                        depress(i,j) = 0.
                       tc_count(i,j) = 0.
                   endif
                enddo
             enddo
             used = send_data(id_c45, depress, Time)
             if(id_f45>0) used = send_data(id_f45, tc_count, Time)
            endif

            if (id_c15>0) then
                deallocate(depress)
                deallocate(cat_crt)
                deallocate(storm)
                deallocate(ws_max)
                deallocate(tc_count)
            endif

            if(id_slp>0 )  deallocate( slp )

            deallocate( a3 )
          endif

         deallocate ( wz )
       endif


       if(id_mq > 0)  then
          do j=jsc,jec
             do i=isc,iec
                a2(i,j) = Atm(n)%ps(i,j)*zxg(i,j)
             enddo
          enddo
          used = send_data(id_mq, a2, Time)
          if( prt_minmax ) then
              tot_mq  = g_sum( a2, isc, iec, jsc, jec, ngc, area, 0) 
              mtq_sum = mtq_sum + tot_mq
              if ( steps <= max_step ) mtq(steps) = tot_mq
              if(master) write(*,*) 'Total (global) mountain torque (Hadleys)=', tot_mq
          endif
       endif

#ifdef MARS_GCM
       if ( id_t05>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      0.5e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t05, a2, Time)
       endif
#  ifdef WATER_CYCLE
       if ( id_tq>0 ) then
          itrac= get_tracer_index (MODEL_ATMOS, 'h2o_vapor')
          a2 = 0.
          do k=1,npz
          do j=jsc,jec
             do i=isc,iec
                a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,itrac)*Atm(n)%delp(i,j,k)
             enddo
          enddo
          enddo
          used = send_data(id_tq, a2*ginv, Time)
       endif
#  endif WATER_CYCLE
#else
       if ( id_tq>0 ) then
          nwater = Atm(1)%nwat
          a2 = 0.
          do k=1,npz
          do j=jsc,jec
             do i=isc,iec
!                a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,1)*Atm(n)%delp(i,j,k)
                a2(i,j) = a2(i,j) + sum(Atm(n)%q(i,j,k,1:nwater))*Atm(n)%delp(i,j,k)
             enddo
          enddo
          enddo
          used = send_data(id_tq, a2*ginv, Time)
       endif
#endif MARS_GCM

       if(id_us > 0) used=send_data(id_us, Atm(n)%ua(isc:iec,jsc:jec,npz), Time)
       if(id_vs > 0) used=send_data(id_vs, Atm(n)%va(isc:iec,jsc:jec,npz), Time)

       if(id_ua > 0) used=send_data(id_ua, Atm(n)%ua(isc:iec,jsc:jec,:), Time)
       if(id_va > 0) used=send_data(id_va, Atm(n)%va(isc:iec,jsc:jec,:), Time)

! pressure for masking p-level fields
! incorrectly defines a2 to be ps (in mb).
       if (id_pmask>0) then
            do j=jsc,jec
            do i=isc,iec
                a2(i,j) = exp((Atm(n)%peln(i,npz+1,j)+Atm(n)%peln(i,npz+1,j))*0.5)*0.01
               !a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))*0.01
            enddo
            enddo
            used=send_data(id_pmask, a2, Time)
       endif
! fix for pressure for masking p-level fields
! based on lowest-level pfull
! define pressure at lowest level the same as interpolate_vertical (in mb)
       if (id_pmaskv2>0) then
            do j=jsc,jec
            do i=isc,iec
                a2(i,j) = exp((Atm(n)%peln(i,npz,j)+Atm(n)%peln(i,npz+1,j))*0.5)*0.01
            enddo
            enddo
            used=send_data(id_pmaskv2, a2, Time)
       endif

! 10-mb
       if ( id_u10>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      10.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u10, a2, Time)
       endif
       if ( id_v10>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      10.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v10, a2, Time)
       endif
       if ( id_t10>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      10.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t10, a2, Time)
       endif
       if ( id_q10>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      10.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q10, a2, Time)
       endif
       if ( id_omg10>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      10.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg10, a2, Time)
       endif
! 50-mb
       if ( id_u50>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      50.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u50, a2, Time)
       endif
       if ( id_v50>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      50.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v50, a2, Time)
       endif
       if ( id_t50>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      50.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t50, a2, Time)
       endif
       if ( id_q50>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      50.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q50, a2, Time)
       endif
       if ( id_omg50>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      50.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg50, a2, Time)
       endif
! 100-mb
       if ( id_u100>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      100.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u100, a2, Time)
       endif
       if ( id_v100>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      100.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v100, a2, Time)
       endif
       if ( id_t100>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      100.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t100, a2, Time)
       endif
       if ( id_q100>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      100.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q100, a2, Time)
       endif
       if ( id_omg100>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      100.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg100, a2, Time)
       endif
! 200-mb
       if ( id_u200>0 .or. id_s200>0 ) then
            allocate( u2(isc:iec,jsc:jec) )
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      200.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), u2)
            if( id_u200>0 ) used=send_data(id_u200, u2, Time)
       endif
       if ( id_v200>0 .or. id_s200>0 ) then
            allocate( v2(isc:iec,jsc:jec) )
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      200.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), v2)
            if( id_v200>0 ) used=send_data(id_v200, v2, Time)
       endif
       if ( id_s200>0 ) then
            do j=jsc,jec
               do i=isc,iec
                  a2(i,j) = sqrt(u2(i,j)**2 + v2(i,j)**2)
               enddo
            enddo
            used=send_data(id_s200, a2, Time)
       endif
       if ( id_sl12>0 ) then   ! 13th level wind speed (~ 222 mb for the 32L setup)
            do j=jsc,jec
               do i=isc,iec
                  a2(i,j) = sqrt(Atm(n)%ua(i,j,12)**2 + Atm(n)%va(i,j,12)**2)
               enddo
            enddo
            used=send_data(id_sl12, a2, Time)
       endif
       if ( id_sl13>0 ) then   ! 13th level wind speed (~ 222 mb for the 32L setup)
            do j=jsc,jec
               do i=isc,iec
                  a2(i,j) = sqrt(Atm(n)%ua(i,j,13)**2 + Atm(n)%va(i,j,13)**2)
               enddo
            enddo
            used=send_data(id_sl13, a2, Time)
       endif
       if ( allocated (u2) )  deallocate ( u2 )
       if ( allocated (v2) )  deallocate ( v2 )

       if ( id_w200>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      200.e2, Atm(n)%peln, Atm(n)%w(isc:iec,jsc:jec,:), a2)
            used=send_data(id_w200, a2, Time)
       endif
       if ( id_t200>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      200.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t200, a2, Time)
       endif
       if ( id_q200>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      200.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q200, a2, Time)
       endif
       if ( id_omg200>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      200.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg200, a2, Time)
       endif
! 250-mb
       if ( id_u250>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      250.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u250, a2, Time)
       endif
       if ( id_v250>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      250.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v250, a2, Time)
       endif
       if ( id_t250>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      250.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t250, a2, Time)
       endif
       if ( id_q250>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      250.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q250, a2, Time)
       endif
       if ( id_omg250>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      250.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg250, a2, Time)
       endif
! 500-mb
       if ( id_u500>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      500.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u500, a2, Time)
       endif
       if ( id_v500>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      500.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v500, a2, Time)
       endif
       if ( id_t500>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      500.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t500, a2, Time)
       endif
       if ( id_q500>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      500.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q500, a2, Time)
       endif
       if ( id_omg500>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      500.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg500, a2, Time)
       endif
! 700-mb
       if ( id_u700>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      700.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u700, a2, Time)
       endif
       if ( id_v700>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      700.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v700, a2, Time)
       endif
       if ( id_t700>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      700.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t700, a2, Time)
       endif
       if ( id_q700>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      700.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q700, a2, Time)
       endif
       if ( id_omg700>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      700.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg700, a2, Time)
       endif
! 850-mb
       if ( id_u850>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      850.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u850, a2, Time)
       endif
       if ( id_v850>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      850.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v850, a2, Time)
       endif
       if ( id_w850>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      850.e2, Atm(n)%peln, Atm(n)%w(isc:iec,jsc:jec,:), a2)
            used=send_data(id_w850, a2, Time)
       endif
       if ( id_t850>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      850.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t850, a2, Time)
       endif
       if ( id_q850>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      850.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q850, a2, Time)
       endif
       if ( id_omg850>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      850.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg850, a2, Time)
       endif
! 1000-mb
       if ( id_u1000>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      1000.e2, Atm(n)%peln, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
            used=send_data(id_u1000, a2, Time)
       endif
       if ( id_v1000>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      1000.e2, Atm(n)%peln, Atm(n)%va(isc:iec,jsc:jec,:), a2)
            used=send_data(id_v1000, a2, Time)
       endif
       if ( id_t1000>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      1000.e2, Atm(n)%peln, Atm(n)%pt(isc:iec,jsc:jec,:), a2)
            used=send_data(id_t1000, a2, Time)
       endif
       if ( id_q1000>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      1000.e2, Atm(n)%peln, Atm(n)%q(isc:iec,jsc:jec,:,sphum), a2)
            used=send_data(id_q1000, a2, Time)
       endif
       if ( id_omg1000>0 ) then
            call interpolate_vertical(isc, iec, jsc, jec, npz,   &
                                      1000.e2, Atm(n)%peln, Atm(n)%omga(isc:iec,jsc:jec,:), a2)
            used=send_data(id_omg1000, a2, Time)
       endif

       if ( .not.Atm(n)%hydrostatic .and. id_w>0  )     &
                 used=send_data(id_w, Atm(n)%w(isc:iec,jsc:jec,:), Time)

       if(id_pt   > 0) used=send_data(id_pt  , Atm(n)%pt  (isc:iec,jsc:jec,:), Time)
       if(id_omga > 0) used=send_data(id_omga, Atm(n)%omga(isc:iec,jsc:jec,:), Time)

       if(id_ppt> 0) then
! Potential temperature perturbation for gravity wave test_case
          allocate ( pt1(npz) )
          if( .not. allocated(a3) ) allocate ( a3(isc:iec,jsc:jec,npz) )
#ifdef TEST_GWAVES
          call gw_1d(npz, 1000.E2, Atm(n)%ak, Atm(n)%ak, Atm(n)%ak(1), 10.E3, pt1)
#else
          pt1 = 0. 
#endif
          do k=1,npz
          do j=jsc,jec
             do i=isc,iec
                wk(i,j,k) =  (Atm(n)%pt(i,j,k)/Atm(n)%pkz(i,j,k) - pt1(k)) * pk0
             enddo
          enddo
          enddo
          used=send_data(id_ppt, wk, Time)

          if( prt_minmax ) then
              call prt_maxmin('PoTemp', wk, isc, iec, jsc, jec, 0, npz, 1., master)
          endif

          if( allocated(a3) ) deallocate ( a3 )
          deallocate ( pt1 )
       endif


        do itrac=1, ncnst
          if (id_tracer(itrac) > 0) &
               & used = send_data (id_tracer(itrac), Atm(n)%q(isc:iec,jsc:jec,:,itrac), Time )
          if( prt_minmax ) then
              call get_tracer_names ( MODEL_ATMOS, itrac, tname )
#ifndef SW_DYNAMICS
              call prt_maxmin(trim(tname), Atm(n)%q(:,:,1,itrac), &
                              isc, iec, jsc, jec, ngc, npz, 1., master)
#endif
          endif
        enddo

    enddo

    deallocate ( a2 )
    deallocate ( wk )

    call nullify_domain()


 end subroutine fv_diag

 subroutine wind_max(isc, iec, jsc, jec ,isd, ied, jsd, jed, us, vs, ws_max)
 integer isc, iec, jsc, jec
 integer isd, ied, jsd, jed
 real, intent(in), dimension(isc:iec,jsc:jec):: us, vs
 real, intent(out) :: ws_max(isc:iec,jsc:jec)
! Local
 real :: wx(isc:iec,jsd:jed), ws(isd:ied,jsd:jed)
 integer:: i,j

 ws = 0.   ! fill corners with zeros
 do j=jsc,jec
    do i=isc,iec
       ws(i,j) = sqrt(us(i,j)**2 + vs(i,j)**2)
    enddo
 enddo

 call mpp_update_domains( ws, domain )

 do j=jsd,jed
    do i=isc,iec
       wx(i,j) = max(ws(i-3,j), ws(i-2,j), ws(i-1,j), ws(i,j), ws(i+1,j), ws(i+2,j), ws(i+3,j))
    enddo
 enddo

 do j=jsc,jec
    do i=isc,iec
       ws_max(i,j) = max(wx(i,j-3), wx(i,j-2), wx(i,j-1), wx(i,j), wx(i,j+1), wx(i,j+2), wx(i,j+3))
    enddo
 enddo

 end subroutine wind_max


 subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort)
 integer isd, ied, jsd, jed, npz
 integer isc, iec, jsc, jec
 real, intent(in)  :: u(isd:ied, jsd:jed+1, npz), v(isd:ied+1, jsd:jed, npz)
 real, intent(out) :: vort(isc:iec, jsc:jec, npz)
! Local
 real :: utmp(isc:iec, jsc:jec+1), vtmp(isc:iec+1, jsc:jec)
 integer :: i,j,k

      do k=1,npz
         do j=jsc,jec+1
            do i=isc,iec
               utmp(i,j) = u(i,j,k)*dx(i,j)
            enddo
         enddo
         do j=jsc,jec
            do i=isc,iec+1
               vtmp(i,j) = v(i,j,k)*dy(i,j)
            enddo
         enddo

         do j=jsc,jec
            do i=isc,iec
               vort(i,j,k) = rarea(i,j)*(utmp(i,j)-utmp(i,j+1)-vtmp(i,j)+vtmp(i+1,j))
            enddo
         enddo
      enddo

 end subroutine get_vorticity


 subroutine get_height_field(is, ie, js, je, ng, km, wz, pt, q, peln, zvir)
  integer, intent(in):: is, ie, js, je, km, ng
  real, intent(in):: peln(is:ie,km+1,js:je)
  real, intent(in):: pt(is-ng:ie+ng,js-ng:je+ng,km)
  real, intent(in)::  q(is-ng:ie+ng,js-ng:je+ng,km,*) ! water vapor
  real, intent(in):: zvir
  real, intent(out):: wz(is:ie,js:je,km+1)
!
  integer i,j,k
  real gg

      gg  = rdgas * ginv

      do j=js,je
         do i=is,ie
            wz(i,j,km+1) = zsurf(i,j)
         enddo
         do k=km,1,-1
            do i=is,ie
               wz(i,j,k) = wz(i,j,k+1) + gg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))  &
                          *(peln(i,k+1,j)-peln(i,k,j))
            enddo
         enddo
      enddo

 end subroutine get_height_field

 subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, master, q_low, q_hi, bad_range)
      character(len=*), intent(in)::  qname
      integer, intent(in):: is, ie, js, je
      integer, intent(in):: n_g, km
      real, intent(in)::    q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
      real, intent(in):: pos(is-n_g:ie+n_g, js-n_g:je+n_g,2)
      real, intent(in):: q_low, q_hi
      logical, intent(in):: master
      logical, optional, intent(out):: bad_range
!
      real qmin, qmax
      integer i,j,k

      if ( present(bad_range) ) bad_range = .false. 
      qmin = q(is,js,1)
      qmax = qmin

      do k=1,km
      do j=js,je
         do i=is,ie
            if( q(i,j,k) < qmin ) then
                qmin = q(i,j,k)
            elseif( q(i,j,k) > qmax ) then
                qmax = q(i,j,k)
            endif
          enddo
      enddo
      enddo

      call mp_reduce_min(qmin)
      call mp_reduce_max(qmax)

      if( qmin<q_low .or. qmax>q_hi ) then
          if(master) write(6,*) 'Range_check Warning:', qname, ' max = ', qmax, ' min = ', qmin
          if ( present(bad_range) ) then
               bad_range = .true. 
          endif
      endif

      if ( present(bad_range) ) then
! Print out where the bad value(s) is (are)
         if ( bad_range .EQV. .false. ) return
         do k=1,km
            do j=js,je
               do i=is,ie
                  if( q(i,j,k)<q_low .or. q(i,j,k)>q_hi ) then
!                     write(*,*) 'gid=', gid, k,i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, q(i,j,k)
                      write(*,*) 'k=',k,' (i,j)=',i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, q(i,j,k)
                      if ( k/= 1 ) write(*,*) k-1, q(i,j,k-1)
                      if ( k/=km ) write(*,*) k+1, q(i,j,k+1)
                  endif
               enddo
            enddo
         enddo
         call mpp_error(FATAL,'==> Error from range_check: data out of bound')
      endif

 end subroutine range_check

 subroutine prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac, master)
      character(len=*), intent(in)::  qname
      integer, intent(in):: is, ie, js, je
      integer, intent(in):: n_g, km
      real, intent(in)::    q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
      real, intent(in)::    fac
      logical, intent(in):: master
!
      real qmin, qmax
      integer i,j,k

      qmin = q(is,js,1)
      qmax = qmin

      do k=1,km
      do j=js,je
         do i=is,ie
!           qmin = min(qmin, q(i,j,k))
!           qmax = max(qmax, q(i,j,k))
            if( q(i,j,k) < qmin ) then
                qmin = q(i,j,k)
            elseif( q(i,j,k) > qmax ) then
                qmax = q(i,j,k)
            endif
          enddo
      enddo
      enddo

      call mp_reduce_min(qmin)
      call mp_reduce_max(qmax)

      if(master) write(6,*) qname, ' max = ', qmax*fac, ' min = ', qmin*fac

 end subroutine prt_maxmin


 subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, master)

 integer, intent(in):: is, ie, js, je
 integer, intent(in):: nq, n_g, km, nwat
 real, intent(in)::   ps(is-n_g:ie+n_g, js-n_g:je+n_g)
 real, intent(in):: delp(is-n_g:ie+n_g, js-n_g:je+n_g, km)
 real, intent(in)::  q(is-n_g:ie+n_g, js-n_g:je+n_g, km, nq)
 logical, intent(in):: master
! Local:
 real psq(is:ie,js:je,nwat)
 real q_strat(is:ie,js:je)
 real qtot(nwat)
 real psmo, totw, psdry
 integer k, n, kstrat

#if defined(MARS_GCM) || defined(VENUS_GCM)
 psmo = g_sum(ps(is:ie,js:je), is, ie, js, je, n_g, area, 1)
 totw  = 0.0
 psdry = psmo - totw
 if ( nwat > 0 ) then
    qtot(:)= 0.0
 endif

 if( master ) then
     write(6,*) 'Total surface pressure (mb) = ',  0.01*psmo
!!!     write(6,*) 'mean dry surface pressure = ',    0.01*psdry
  endif
#else

 if ( nwat==0 ) then
      psmo = g_sum(ps(is:ie,js:je), is, ie, js, je, n_g, area, 1) 
      if( master ) write(6,*) 'Total surface pressure (mb) = ',  0.01*psmo
      return
 endif

 call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,sphum  ), psq(is,js,sphum  )) 
 call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,liq_wat), psq(is,js,liq_wat))
 call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,ice_wat), psq(is,js,ice_wat))

! Mean water vapor in the "stratosphere" (75 mb and above):
 if ( phalf(2)< 75. ) then
 kstrat = 1
 do k=1,km
    if ( phalf(k+1) > 75. ) exit
    kstrat = k
 enddo
 call z_sum(is, ie, js, je, kstrat, n_g, delp, q(is-n_g,js-n_g,1,sphum), q_strat(is,js)) 
 psmo = g_sum(q_strat(is,js), is, ie, js, je, n_g, area, 1) * 1.e6           &
      / p_sum(is, ie, js, je, kstrat, n_g, delp)
 if(master) write(*,*) 'Mean specific humidity (mg/kg) above 75 mb=', psmo, kstrat
 endif



 if ( nwat==6 ) then
     call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,rainwat), psq(is,js,rainwat))
     call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,snowwat), psq(is,js,snowwat))
     call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,graupel), psq(is,js,graupel))
 endif

!-------------------
! Check global means
!-------------------
 psmo = g_sum(ps(is:ie,js:je), is, ie, js, je, n_g, area, 1) 

 do n=1,nwat
    qtot(n) = g_sum(psq(is,js,n), is, ie, js, je, n_g, area, 1) 
 enddo

 totw  = sum(qtot(1:nwat))
 psdry = psmo - totw

 if( master ) then
     write(6,*) 'Total surface pressure (mb) = ',  0.01*psmo
     write(6,*) 'mean dry surface pressure = ',    0.01*psdry
     write(6,*) 'Total Water Vapor (kg/m**2) =',  qtot(sphum)*ginv
     if ( nwat==6 ) then
          write(6,*) '--- Micro Phys water substances (kg/m**2) ---'
          write(6,*) 'Total cloud water=', qtot(liq_wat)*ginv
          write(6,*) 'Total rain  water=', qtot(rainwat)*ginv
          write(6,*) 'Total cloud ice  =', qtot(ice_wat)*ginv
          write(6,*) 'Total snow       =', qtot(snowwat)*ginv
          write(6,*) 'Total graupel    =', qtot(graupel)*ginv
          write(6,*) '---------------------------------------------'
     endif
  endif

#endif MARS_GCM

 end subroutine prt_mass


 subroutine z_sum(is, ie, js, je, km, n_g, delp, q, sum2)
 integer, intent(in):: is, ie, js, je,  n_g, km
 real, intent(in):: delp(is-n_g:ie+n_g, js-n_g:je+n_g, km)
 real, intent(in)::    q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
 real, intent(out):: sum2(is:ie,js:je)
 integer i,j,k

 do j=js,je
    do i=is,ie
       sum2(i,j) = delp(i,j,1)*q(i,j,1)
    enddo
    do k=2,km
       do i=is,ie
          sum2(i,j) = sum2(i,j) + delp(i,j,k)*q(i,j,k)
       enddo
    enddo
 enddo

 end subroutine z_sum


 real function p_sum(is, ie, js, je, km, n_g, delp)
 integer, intent(in):: is, ie, js, je,  n_g, km
 real, intent(in):: delp(is-n_g:ie+n_g, js-n_g:je+n_g, km)
 real :: sum2(is:ie,js:je)
 integer i,j,k

 do j=js,je
    do i=is,ie
       sum2(i,j) = delp(i,j,1)
    enddo
    do k=2,km
       do i=is,ie
          sum2(i,j) = sum2(i,j) + delp(i,j,k)
       enddo
    enddo
 enddo
 p_sum = g_sum(sum2, is, ie, js, je, n_g, area, 1)

 end function p_sum



 subroutine get_pressure_given_height(is, ie, js, je, ng, km, wz, kd, height,   &
                                      ts, peln, a2, fac)

 integer,  intent(in):: is, ie, js, je, km, ng
 integer,  intent(in):: kd           ! vertical dimension of the ouput height
 real, intent(in):: wz(is:ie,js:je,km+1)
 real, intent(in):: ts(is-ng:ie+ng,js-ng:je+ng)
 real, intent(in):: peln(is:ie,km+1,js:je)
 real, intent(in):: height(kd)   ! must be monotonically decreasing with increasing k
 real, intent(out):: a2(is:ie,js:je,kd)      ! pressure (pa)
 real, optional, intent(in):: fac

! local:
 integer n, i,j,k
 real ptmp, tm


 do n=1,kd

!$omp parallel do default(shared) private(i, j, k, ptmp, tm)
    do j=js,je

       do 1000 i=is,ie

         if ( height(n) >= wz(i,j,km+1) ) then
!---------------------
! Search from top down
!---------------------
          do k=1,km
             if( height(n) < wz(i,j,k) .and. height(n) >= wz(i,j,k+1) ) then
! Found it!
                 ptmp = peln(i,k,j) + (peln(i,k+1,j)-peln(i,k,j)) *   &
                       (wz(i,j,k)-height(n)) / (wz(i,j,k)-wz(i,j,k+1))
                 a2(i,j,n) = exp(ptmp)
                 go to 500
             endif
          enddo

         else
!-----------------------------------------
! xtrapolation: mean laspe rate 6.5 deg/km
!-----------------------------------------
                tm = rdgas*ginv*(ts(i,j) + 3.25E-3*(wz(i,j,km)-height(n)))
          a2(i,j,n) = exp( peln(i,km+1,j) + (wz(i,j,km+1) - height(n))/tm )
         endif
500      if ( present(fac) ) a2(i,j,n) = fac * a2(i,j,n)
1000   continue
    enddo
 enddo

 end subroutine get_pressure_given_height


 subroutine get_height_given_pressure(is, ie, js, je, ng, km, wz, kd, log_p,   &
                                      peln, a2)
 integer,  intent(in):: is, ie, js, je, ng, km
 integer,  intent(in):: kd           ! vertical dimension of the ouput height
 real, intent(in):: log_p(kd)    ! must be monotonically decreasing with increasing k
                                 ! log (p)
 real, intent(in):: wz(is:ie,js:je,km+1)
 real, intent(in):: peln(is:ie,km+1,js:je)
 real, intent(out):: a2(is:ie,js:je,kd)      ! height (m)

! local:
 integer n, i,j,k

 do n=1,kd

!$omp parallel do default(shared) private(i, j, k)
    do j=js,je
       do 1000 i=is,ie
          do k=1,km
             if( log_p(n) <= peln(i,k+1,j) .and. log_p(n) >= peln(i,k,j) ) then
! Found it!
                 a2(i,j,n) = wz(i,j,k)  +  (wz(i,j,k+1) - wz(i,j,k)) *   &
                       (log_p(n)-peln(i,k,j)) / (peln(i,k+1,j)-peln(i,k,j) )
                 go to 1000
             endif
          enddo
!                a2(i,j,n) = missing_value
! Extrapolation into ground:  use wz(km-1:km+1)
                 a2(i,j,n) = wz(i,j,km+1) + (wz(i,j,km+1) - wz(i,j,km-1)) *   &
                       (log_p(n)-peln(i,km+1,j)) / (peln(i,km+1,j)-peln(i,km-1,j) )
1000   continue
    enddo
 enddo

 end subroutine get_height_given_pressure


 subroutine interpolate_vertical(is, ie, js, je, km, plev, peln, a3, a2)

 integer,  intent(in):: is, ie, js, je, km
 real, intent(in):: peln(is:ie,km+1,js:je)
 real, intent(in):: a3(is:ie,js:je,km)
 real, intent(in):: plev
 real, intent(out):: a2(is:ie,js:je)
! local:
 real pm(km)
 real logp
 integer i,j,k

 logp = log(plev)

 do j=js,je
    do 1000 i=is,ie

       do k=1,km
          pm(k) = 0.5*(peln(i,k,j)+peln(i,k+1,j))
       enddo

       if( logp <= pm(1) ) then
           a2(i,j) = a3(i,j,1)
       elseif ( logp >= pm(km) ) then
           a2(i,j) = a3(i,j,km)
       else 
           do k=1,km-1
              if( logp <= pm(k+1) .and. logp >= pm(k) ) then
                  a2(i,j) = a3(i,j,k) + (a3(i,j,k+1)-a3(i,j,k))*(logp-pm(k))/(pm(k+1)-pm(k))
                  go to 1000
              endif
           enddo
       endif
1000   continue
 enddo

 end subroutine interpolate_vertical



 subroutine pv_entropy(is, ie, js, je, ng, km, vort, f_d, pt, pkz, delp, grav)

! !INPUT PARAMETERS:
   integer, intent(in)::  is, ie, js, je, ng, km
   real, intent(in):: grav
   real, intent(in):: pt(is-ng:ie+ng,js-ng:je+ng,km) 
   real, intent(in):: pkz(is:ie,js:je,km) 
   real, intent(in):: delp(is-ng:ie+ng,js-ng:je+ng,km)
   real, intent(in):: f_d(is-ng:ie+ng,js-ng:je+ng) 

! vort is relative vorticity as input. Becomes PV on output
      real, intent(inout):: vort(is:ie,js:je,km)

! !DESCRIPTION:
!        EPV = 1/r * (vort+f_d) * d(S)/dz; where S is a conservative scalar
!        r the fluid density, and S is chosen to be the entropy here: S = log(pt)
!        pt == potential temperature.
! Computation are performed assuming the input is on "x-y-z" Cartesian coordinate.
! The approximation made here is that the relative vorticity computed on constant
! z-surface is not that different from the hybrid sigma-p coordinate.
! See page 39, Pedlosky 1979: Geophysical Fluid Dynamics
!
! The follwoing simplified form is strictly correct only if vort is computed on 
! constant z surfaces. In addition hydrostatic approximation is made.
!        EPV = - GRAV * (vort+f_d) / del(p) * del(pt) / pt 
! where del() is the vertical difference operator.
!
! programmer: S.-J. Lin, shian-jiann.lin@noaa.gov
!
!EOP
!---------------------------------------------------------------------
!BOC
      real w3d(is:ie,js:je,km)
      real te(is:ie,js:je,km+1), t2(is:ie,km), delp2(is:ie,km)
      real te2(is:ie,km+1)
      integer i, j, k

#ifdef SW_DYNAMICS
        do j=js,je
          do i=is,ie
            vort(i,j,1) = grav * (vort(i,j,1)+f_d(i,j)) / delp(i,j,1)
          enddo
        enddo
#else
! Compute PT at layer edges.
     do j=js,je
        do k=1,km
          do i=is,ie
               t2(i,k) = pt(i,j,k) / pkz(i,j,k)
              w3d(i,j,k) = t2(i,k)
            delp2(i,k) = delp(i,j,k)
          enddo
        enddo

        call ppme(t2, te2, delp2, ie-is+1, km)

        do k=1,km+1
           do i=is,ie
              te(i,j,k) = te2(i,k)
           enddo
        enddo
     enddo

     do k=1,km
        do j=js,je
          do i=is,ie
! Entropy is the thermodynamic variable in the following form
            vort(i,j,k) = (vort(i,j,k)+f_d(i,j)) * ( te(i,j,k)-te(i,j,k+1) )  &
                          / ( w3d(i,j,k)*delp(i,j,k) )  * grav
          enddo
        enddo
     enddo
#endif

 end subroutine pv_entropy


 subroutine ppme(p,qe,delp,im,km)

  integer, intent(in):: im, km
  real, intent(in)::    p(im,km)
  real, intent(in):: delp(im,km)
  real, intent(out)::qe(im,km+1)

! local arrays.
      real dc(im,km),delq(im,km), a6(im,km)
      real c1, c2, c3, tmp, qmax, qmin
      real a1, a2, s1, s2, s3, s4, ss3, s32, s34, s42
      real a3, b2, sc, dm, d1, d2, f1, f2, f3, f4
      real qm, dq
      integer i, k, km1

      km1 = km - 1

      do 500 k=2,km
      do 500 i=1,im
500   a6(i,k) = delp(i,k-1) + delp(i,k)

      do 1000 k=1,km1
      do 1000 i=1,im
      delq(i,k) = p(i,k+1) - p(i,k)
1000  continue

      do 1220 k=2,km1
      do 1220 i=1,im
      c1 = (delp(i,k-1)+0.5*delp(i,k))/a6(i,k+1)
      c2 = (delp(i,k+1)+0.5*delp(i,k))/a6(i,k)
      tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) /    &
                                    (a6(i,k)+delp(i,k+1))
      qmax = max(p(i,k-1),p(i,k),p(i,k+1)) - p(i,k)
      qmin = p(i,k) - min(p(i,k-1),p(i,k),p(i,k+1))
      dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp)
1220  continue

!****6***0*********0*********0*********0*********0*********0**********72
! 4th order interpolation of the provisional cell edge value
!****6***0*********0*********0*********0*********0*********0**********72

   do k=3,km1
      do i=1,im
         c1 = delq(i,k-1)*delp(i,k-1) / a6(i,k)
         a1 = a6(i,k-1) / (a6(i,k) + delp(i,k-1))
         a2 = a6(i,k+1) / (a6(i,k) + delp(i,k))
         qe(i,k) = p(i,k-1) + c1 + 2./(a6(i,k-1)+a6(i,k+1)) *        &
                   ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) -         &
                                delp(i,k-1)*a1*dc(i,k  ) )
      enddo
   enddo

! three-cell parabolic subgrid distribution at model top

   do i=1,im
! three-cell PP-distribution
! Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
! a3 = a / 3
! b2 = b / 2
      s1 = delp(i,1)
      s2 = delp(i,2) + s1
!
      s3 = delp(i,2) + delp(i,3)
      s4 = s3 + delp(i,4)
      ss3 =  s3 + s1
      s32 = s3*s3
      s42 = s4*s4
      s34 = s3*s4
! model top
      a3 = (delq(i,2) - delq(i,1)*s3/s2) / (s3*ss3)
!
      if(abs(a3) .gt. 1.e-14) then
         b2 =  delq(i,1)/s2 - a3*(s1+s2)
         sc = -b2/(3.*a3)
         if(sc .lt. 0. .or. sc .gt. s1) then
             qe(i,1) = p(i,1) - s1*(a3*s1 + b2)
         else
             qe(i,1) = p(i,1) - delq(i,1)*s1/s2
         endif
      else
! Linear
         qe(i,1) = p(i,1) - delq(i,1)*s1/s2
      endif
      dc(i,1) = p(i,1) - qe(i,1)
! compute coef. for the off-centered area preserving cubic poly.
      dm = delp(i,1) / (s34*ss3*(delp(i,2)+s3)*(s4+delp(i,1)))
      f1 = delp(i,2)*s34 / ( s2*ss3*(s4+delp(i,1)) )
      f2 = (delp(i,2)+s3) * (ss3*(delp(i,2)*s3+s34+delp(i,2)*s4)   &
            + s42*(delp(i,2)+s3+s32/s2))
      f3 = -delp(i,2)*( ss3*(s32*(s3+s4)/(s4-delp(i,2))            &
            + (delp(i,2)*s3+s34+delp(i,2)*s4))                     &
            + s42*(delp(i,2)+s3) )
      f4 = ss3*delp(i,2)*s32*(delp(i,2)+s3) / (s4-delp(i,2))
      qe(i,2) = f1*p(i,1)+(f2*p(i,2)+f3*p(i,3)+f4*p(i,4))*dm
   enddo

! Bottom
! Area preserving cubic with 2nd deriv. = 0 at the surface
   do i=1,im
      d1 = delp(i,km)
      d2 = delp(i,km1)
      qm = (d2*p(i,km)+d1*p(i,km1)) / (d1+d2)
      dq = 2.*(p(i,km1)-p(i,km)) / (d1+d2)
      c1 = (qe(i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1)))
      c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2)
      qe(i,km  ) = qm - c1*d1*d2*(d2+3.*d1)
      qe(i,km+1) = d1*(8.*c1*d1**2-c3) + qe(i,km)
   enddo

 end subroutine ppme

!#######################################################################

subroutine rh_calc (pfull, t, qv, rh, do_cmip)
  
   real, intent (in),  dimension(:,:) :: pfull, t, qv
   real, intent (out), dimension(:,:) :: rh
   real, dimension(size(t,1),size(t,2)) :: esat
   logical, intent(in), optional :: do_cmip

   real, parameter :: d622 = rdgas/rvgas
   real, parameter :: d378 = 1.-d622

   logical :: do_simple = .false.

! because Betts-Miller uses a simplified scheme for calculating the relative humidity

     if (do_simple) then
        call lookup_es (t, esat)
        rh(:,:) = pfull(:,:)
        rh(:,:) = MAX(rh(:,:),esat(:,:))  !limit where pfull ~ esat
        rh(:,:)=100.*qv(:,:)/(d622*esat(:,:)/rh(:,:))
     else
        if (present(do_cmip)) then
         call compute_qs (t, pfull, rh, q=qv, es_over_liq_and_ice = .true.)
         rh(:,:)=100.*qv(:,:)/rh(:,:)
        else
        call compute_qs (t, pfull, rh, q=qv)
        rh(:,:)=100.*qv(:,:)/rh(:,:)
     endif
     endif

end subroutine rh_calc

!#######################################################################

end module fv_diagnostics_mod


module fv_eta_mod
 use constants_mod,  only: kappa, grav, cp_air, rdgas
 use fv_mp_mod,      only: gid
 implicit none
 private
 public set_eta, get_eta_level, compute_dz_L32, set_hybrid_z, compute_dz, gw_1d

 contains

 subroutine set_eta(km, ks, ptop, ak, bk)

      integer,  intent(in)::  km           ! vertical dimension
      integer,  intent(out):: ks           ! number of pure p layers
      real, intent(out):: ak(km+1)
      real, intent(out):: bk(km+1)
      real, intent(out):: ptop         ! model top (Pa)
! local
      real a24(25),b24(25)            ! GFDL AM2L24
      real a26(27),b26(27)            ! Jablonowski & Williamson 26-level
      real a32(33),b32(33)
      real a32w(33),b32w(33)
      real a47(48),b47(48)
      real a48(49),b48(49)
      real a52(53),b52(53)
      real a54(55),b54(55)
      real a55(56),b55(56)
      real a56(57),b56(57)            ! For Mars GCM
      real a60(61),b60(61)
      real a64(65),b64(65)
      real a100(101),b100(101)
      real a104(105),b104(105)

#if defined(MARS_GCM)
      real:: p0= 6.0E2
      real:: pc= 1.0e-3
      real a36(37),b36(37)            ! For Mars GCM
      real a28(29),b28(29)            !  Mars 28 levels 
      real a30(31),b30(31)            !  Mars 31 levels
      real a46(47),b46(47)            !  Mars 46 levels 
#elif defined(VENUS_GCM)
      real:: p0= 92.E5
      real:: pc= 20.E5
      real a50(51), b50(51)
#else
      real:: p0=1000.E2
      real:: pc=200.E2
#endif

      real pt, pint, lnpe, dlnp
      real press(km+1), pt1(km)
      integer  k

#ifdef MARS_GCM
!------- Mars vertical levels -----------------------------

  data a28 /     &
       2.0000000e-02,5.7381273e-02,1.9583981e-01,5.9229580e-01, &
       1.5660228e+00,2.4454965e+00,2.7683755e+00,2.8851692e+00, &
       2.9172228e+00,2.9087039e+00,2.8598939e+00,2.7687652e+00, &
       2.6327054e+00,2.4509219e+00,2.2266811e+00,1.9684681e+00, &
       1.6894832e+00,1.4055812e+00,1.1324258e+00,8.8289177e-01, &
       6.6548467e-01,4.8401020e-01,3.3824119e-01,2.2510704e-01, &
       1.3995719e-01,7.7611554e-02,3.3085503e-02,2.0000000e-03, &
       0.0000000e+00  /

  data b28 /      &
       0.0000000e+00,0.0000000e+00,0.0000000e+00,0.0000000e+00, &
       0.0000000e+00,1.9366394e-03,7.4419133e-03,1.6227267e-02, &
       2.7075192e-02,4.3641000e-02,6.8106804e-02,1.0280240e-01, &
       1.4971954e-01,2.0987133e-01,2.8270233e-01,3.6581610e-01, &
       4.5520230e-01,5.4593599e-01,6.3310970e-01,7.1267629e-01, &
       7.8196151e-01,8.3977530e-01,8.8620345e-01,9.2223168e-01, &
       9.4934533e-01,9.6919618e-01,9.8337259e-01,9.9326941e-01, &
       1.0000000e+00  /


  data a36 /      &
  2.0000000000e-03,  6.3299931399e-03,  1.2501646444e-02, & 
  2.4215113043e-02,  4.6000346612e-02,  8.5702012910e-02, & 
  1.5659441036e-01,  2.8061882660e-01,  4.9318818941e-01, & 
  8.5008792314e-01,  1.4370449074e+00,  2.0054945771e+00, & 
  2.3335916338e+00,  2.5221957520e+00,  2.6264602874e+00, & 
  2.6762480591e+00,  2.6870173757e+00,  2.6657174771e+00, & 
  2.6140573091e+00,  2.5304052915e+00,  2.4110051828e+00, &
  2.2508885698e+00,  2.0446940567e+00,  1.8074358726e+00, & 
  1.5511877409e+00,  1.2904762231e+00,  1.0396626704e+00, & 
  8.1055438393e-01,  6.1095195817e-01,  4.4434410651e-01, & 
  3.1051916267e-01,  2.0665632614e-01,  1.2848513437e-01, & 
  7.1249514632e-02,  3.0373097709e-02,  2.1040298410e-16, & 
  0.0000000000e+00  /
  
  data b36 /      &
  0.0000000000e+00,  0.0000000000e+00,  0.0000000000e+00, & 
  0.0000000000e+00,  0.0000000000e+00,  0.0000000000e+00, & 
  0.0000000000e+00,  0.0000000000e+00,  0.0000000000e+00, & 
  0.0000000000e+00,  0.0000000000e+00,  6.2833541661e-04, & 
  2.5671934940e-03,  6.0923860938e-03,  1.1725248117e-02, & 
  2.0238695380e-02,  3.2676843179e-02,  5.0373898012e-02, & 
  7.4959525687e-02,  1.0833815470e-01,  1.5263019875e-01, & 
  2.1006506655e-01,  2.8281982789e-01,  3.6584598427e-01, & 
  4.5513763376e-01,  5.4577516959e-01,  6.3285639147e-01, & 
  7.1233851133e-01,  7.8155013540e-01,  8.3930250332e-01, & 
  8.8568132228e-01,  9.2167127115e-01,  9.4875609753e-01, & 
  9.6858585131e-01,  9.8274719475e-01,  9.9326941371e-01, & 
  1.0000000000e+00  /

  data a46 /      &
  2.0000000000e-02, 8.8226564292e-02, 1.8334634034e-01, 3.6277029587e-01, &
  6.8399136107e-01, 1.2304729574e+00, 2.1153951709e+00, 3.4820467261e+00, &
  4.7509071547e+00, 5.4799134056e+00, 5.9007382453e+00, 6.1362740550e+00, &
  6.2537922912e+00, 6.2913572009e+00, 6.2713602880e+00, 6.2076404259e+00, &
  6.1093030517e+00, 5.9827893289e+00, 5.8329954377e+00, 5.6638694533e+00, &
  5.4787213167e+00, 5.2803784904e+00, 5.0712624943e+00, 4.8534284591e+00, &
  4.6285904465e+00, 4.3981439438e+00, 4.1631904900e+00, 3.9245659713e+00, &
  3.6828725958e+00, 3.4385142141e+00, 3.1917350931e+00, 2.9426632973e+00, &
  2.6913614665e+00, 2.4378901625e+00, 2.1823923203e+00, 1.9252119309e+00, &
  1.6670657806e+00, 1.4092925303e+00, 1.1542040649e+00, 9.0554851909e-01, &
  6.6904038704e-01, 4.5279074036e-01, 2.6727564587e-01, 1.2432437078e-01, &
  3.4798358332e-02, 5.4562474330e-16, 0.0000000000e+00 /



  data b46 /      &
  0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
  0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
  1.2273971271e-03, 4.7116904788e-03, 1.0383505003e-02, 1.8331837344e-02, &
  2.8691688586e-02, 4.1579931981e-02, 5.7059712148e-02, 7.5124205614e-02, &
  9.5694383465e-02, 1.1862663695e-01, 1.4372658884e-01, 1.7076585043e-01, &
  1.9949909211e-01, 2.2967952981e-01, 2.6107167554e-01, 2.9346085040e-01, &
  3.2665945404e-01, 3.6051030738e-01, 3.9488755084e-01, 4.2969561994e-01, &
  4.6486676688e-01, 5.0035747810e-01, 5.3614396907e-01, 5.7221672149e-01, &
  6.0857374865e-01, 6.4521190566e-01, 6.8211505810e-01, 7.1923725109e-01, &
  7.5647819344e-01, 7.9364758261e-01, 8.3041470044e-01, 8.6624194162e-01, &
  9.0030869896e-01, 9.3144962000e-01, 9.5815926078e-01, 9.7873764014e-01, &
  9.9162395396e-01, 9.9663254714e-01, 1.0000000000e+00 /

#endif MARS_GCM 

#ifdef VENUS_GCM
 data a50 / &
    0.00000010869565, 0.00000066411131, 0.00000155378600, 0.00000307196430,  &
    0.00000559748410, 0.00000865786490, 0.00001208302700, 0.00001686322300,  &
    0.00002353452900, 0.00003284508400, 0.00004583901900, 0.00006397351100,  &
    0.00008928224800, 0.00012460342000, 0.00017389813000, 0.00024269441000,  &
    0.00033870732000, 0.00047270409000, 0.00065971149000, 0.00092070125000,  &
    0.00128494170000, 0.00179328000000, 0.00250272310000, 0.00349283030000,  &
    0.00487463590000, 0.00680310020000, 0.00949448820000, 0.01325062100000,  &
    0.01849272900000, 0.02580867000000, 0.03575192000000, 0.04360806400000,  &
    0.04724580000000, 0.04891368500000, 0.04912682400000, 0.04779955700000,  &
    0.04488280300000, 0.04068075800000, 0.03553518700000, 0.02984945900000,  &
    0.02404690900000, 0.01851416600000, 0.01355795600000, 0.00937562030000,  &
    0.00605329780000, 0.00358216310000, 0.00188345090000, 0.00083402713000,  &
    0.00028369645000, 0.00007132091600, 0.00000000000000  /

data b50  / &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000000000000, 0.00000000000000, 0.00000000000000,  &
    0.00000000000000, 0.00000005382545, 0.00026699486563, 0.00666028808698,  &
    0.02290928554681, 0.04899577982109, 0.08751637834259, 0.14290085869467,  &
    0.21474170412983, 0.29863125317552, 0.39140024722511, 0.48881848341266,  &
    0.58609291099510, 0.67851634714958, 0.76198545182255, 0.83348584823964,  &
    0.89131068624888, 0.93508544124457, 0.96563140848759, 0.98471159261535,  &
    0.99478675027412, 0.99868812493551, 1.00000000000000 /
#endif VENUS_GCM


! Definition: press(i,j,k) = ak(k) + bk(k) * ps(i,j)

!-----------------------------------------------
! GFDL AM2-L24: modified by SJL at the model top
!-----------------------------------------------
!     data a24 /  100.0000,  1050.0000,  3474.7942,  7505.5556, 12787.2428,   &
      data a24 /  100.0000,   903.4465,  3474.7942,  7505.5556, 12787.2428,   &
                19111.3683, 21854.9274, 22884.1866, 22776.3058, 21716.1604,   &
                20073.2963, 18110.5123, 16004.7832, 13877.6253, 11812.5452,   &
                 9865.8840,  8073.9726,  6458.0834,  5027.9899,  3784.6085,   &
                 2722.0086,  1828.9752,  1090.2396,   487.4595,     0.0000    /

      data b24 / 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000,       &
                 0.0000000, 0.0435679, 0.1102275, 0.1922249, 0.2817656,       &
                 0.3694997, 0.4532348, 0.5316253, 0.6038733, 0.6695556,       &
                 0.7285176, 0.7808017, 0.8265992, 0.8662148, 0.9000406,       &
                 0.9285364, 0.9522140, 0.9716252, 0.9873523, 1.0000000        /

! Jablonowski & Williamson 26-level setup
      data a26 /  219.4067,   489.5209,   988.2418,  1805.2010,  2983.7240,  4462.3340,   &
                 6160.5870,  7851.2430,  7731.2710,  7590.1310,  7424.0860,   &
                 7228.7440,  6998.9330,  6728.5740,  6410.5090,  6036.3220,   &
                 5596.1110,  5078.2250,  4468.9600,  3752.1910,  2908.9490,   &
                  2084.739,   1334.443,    708.499,   252.1360,  0.0, 0.0     /

      data b26 / 0.0, 0.0, 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000,&
                 0.0000000, 0.01505309, 0.03276228, 0.05359622, 0.07810627,      &
                 0.1069411, 0.1408637, 0.1807720, 0.2277220, 0.2829562,       &
                 0.3479364, 0.4243822, 0.5143168, 0.6201202, 0.7235355,       &
                 0.8176768, 0.8962153, 0.9534761, 0.9851122, 1.0000000        /


! High-resolution troposphere setup
! Revised Apr 14, 2004: PINT = 245.027 mb
      data a32/100.00000,     400.00000,     818.60211, &
              1378.88653,    2091.79519,    2983.64084, &
              4121.78960,    5579.22148,    7419.79300, &
              9704.82578,   12496.33710,   15855.26306, &
             19839.62499,   24502.73262,   28177.10152, &
             29525.28447,   29016.34358,   27131.32792, &
             24406.11225,   21326.04907,   18221.18357, &
             15275.14642,   12581.67796,   10181.42843, &
              8081.89816,    6270.86956,    4725.35001, &
              3417.39199,    2317.75459,    1398.09473, &
               632.49506,       0.00000,       0.00000  /

      data b32/0.00000,       0.00000,       0.00000, &
               0.00000,       0.00000,       0.00000, &
               0.00000,       0.00000,       0.00000, &
               0.00000,       0.00000,       0.00000, &
               0.00000,       0.00000,       0.01711, &
               0.06479,       0.13730,       0.22693, &
               0.32416,       0.42058,       0.51105, &
               0.59325,       0.66628,       0.73011, &
               0.78516,       0.83217,       0.87197, &
               0.90546,       0.93349,       0.95685, &
               0.97624,       0.99223,       1.00000  /

!---------------------
! Wilson's 32L settings:
!---------------------
! Top changed to 0.01 mb
      data a32w/  1.00,       26.6378,     84.5529,     228.8592,   & 
                539.9597,   1131.7087,   2141.8082,    3712.0454,   &
               5963.5317,   8974.1873,  12764.5388,   17294.5911,   &
              20857.7007,  22221.8651,  22892.7202,   22891.1641,   &
              22286.0724,  21176.0846,  19673.0671,   17889.0989,   &
              15927.5060,  13877.6239,  11812.5474,    9865.8830,   &
               8073.9717,   6458.0824,   5027.9893,    3784.6104,   &
               2722.0093,   1828.9741,   1090.2397,     487.4575,   &
               0.0000 /
         
      data b32w/ 0.0000,   0.0000,   0.0000,   0.0000,       &
                0.0000,   0.0000,   0.0000,    0.0000,       &
                0.0000,   0.0000,   0.0000,    0.0000,       &
                0.0159,   0.0586,   0.1117,    0.1734,       &
                0.2415,   0.3137,   0.3878,    0.4619,       &
                0.5344,   0.6039,   0.6696,    0.7285,       &
                0.7808,   0.8266,   0.8662,    0.9000,       &
                0.9285,   0.9522,   0.9716,    0.9874,       &
                1.0000 /


! QBO setting with ptop = 0.1 mb and p_full=0.17 mb
      data a47/   10.00000,      24.45365,      48.76776,  &
                  85.39458,     133.41983,     191.01402,  &
                 257.94919,     336.63306,     431.52741,  &
                 548.18995,     692.78825,     872.16512,  &
                1094.18467,    1368.11917,    1704.99489,  &
                2117.91945,    2622.42986,    3236.88281,  &
                3982.89623,    4885.84733,    5975.43260,  &
                7286.29500,    8858.72424,   10739.43477,  &
               12982.41110,   15649.68745,   18811.37629,  &
               22542.71275,   25724.93857,   27314.36781,  &
               27498.59474,   26501.79312,   24605.92991,  &
               22130.51655,   19381.30274,   16601.56419,  &
               13952.53231,   11522.93244,    9350.82303,  &
                7443.47723,    5790.77434,    4373.32696,  &
                3167.47008,    2148.51663,    1293.15510,  &
                 581.62429,       0.00000,       0.00000   /

      data b47/ 0.0000,        0.0000,        0.0000,      &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.01188,       0.04650,     &
                0.10170,       0.17401,       0.25832,     &
                0.34850,       0.43872,       0.52448,     &
                0.60307,       0.67328,       0.73492,     &
                0.78834,       0.83418,       0.87320,     &
                0.90622,       0.93399,       0.95723,     &
                0.97650,       0.99223,       1.00000   /

#ifdef HI_48
! High trop-resolution (Feb 2004)
      data a48/40.00000,     100.00000,     200.00000,     &
              350.00000,     550.00000,     800.00000,     &
             1085.00000,    1390.00000,    1720.00000,     &
             2080.00000,    2470.00000,    2895.00000,     &
             3365.00000,    3890.00000,    4475.00000,     &
             5120.00000,    5830.00000,    6608.00000,     &
             7461.00000,    8395.00000,    9424.46289,     &
            10574.46900,   11864.80330,   13312.58850,     &
            14937.03770,   16759.70760,   18804.78670,     &
            21099.41250,   23674.03720,   26562.82650,     &
            29804.11680,   32627.31601,   34245.89759,     &
            34722.29104,   34155.20062,   32636.50533,     &
            30241.08406,   27101.45052,   23362.20912,     &
            19317.04955,   15446.17194,   12197.45091,     &
             9496.39912,    7205.66920,    5144.64339,     &
             3240.79521,    1518.62245,       0.00000,     &
                0.00000  /

      data b48/0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00813,       0.03224,      &
               0.07128,       0.12445,       0.19063,      &
               0.26929,       0.35799,       0.45438,      &
               0.55263,       0.64304,       0.71703,      &
               0.77754,       0.82827,       0.87352,      &
               0.91502,       0.95235,       0.98511,      &
               1.00000      /
#else
           data a48/                                &
                   1.00000,       2.69722,       5.17136,   &
                   8.89455,      14.24790,      22.07157,   &
                  33.61283,      50.48096,      74.79993,   &
                 109.40055,     158.00460,     225.44108,   &
                 317.89560,     443.19350,     611.11558,   &
                 833.74392,    1125.83405,    1505.20759,   &
                1993.15829,    2614.86254,    3399.78420,   &
                4382.06240,    5600.87014,    7100.73115,   &
                8931.78242,   11149.97021,   13817.16841,   &
               17001.20930,   20775.81856,   23967.33875,   &
               25527.64563,   25671.22552,   24609.29622,   &
               22640.51220,   20147.13482,   17477.63530,   &
               14859.86462,   12414.92533,   10201.44191,   &
                8241.50255,    6534.43202,    5066.17865,   &
                3815.60705,    2758.60264,    1870.64631,   &
                1128.33931,     510.47983,       0.00000,   &
                   0.00000  /

           data b48/              &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.00000,   &
                   0.00000,       0.00000,       0.01253,   &
                   0.04887,       0.10724,       0.18455,   &
                   0.27461,       0.36914,       0.46103,   &
                   0.54623,       0.62305,       0.69099,   &
                   0.75016,       0.80110,       0.84453,   &
                   0.88127,       0.91217,       0.93803,   &
                   0.95958,       0.97747,       0.99223,   &
                   1.00000   /
#endif

#ifdef TTT
      data a52/10.00000,      28.03821,      47.30985,
               73.04316,     104.06818,     138.87408,
              176.68177,     217.95192,     264.18103,
              317.38922,     379.72218,     453.32332,
              540.40931,     643.41528,     765.12346,
              908.75865,    1078.06815,    1277.40350,
             1511.81203,    1787.14119,    2110.15735,
             2488.68103,    2931.74058,    3449.74671,
             4054.69027,    4760.36642,    5582.62804,
             6539.67222,    7652.36351,    8944.59841,
            10443.71572,   12180.95818,   14191.99107,
            16517.48428,   19203.76464,   22303.54062,
            25055.65282,   26711.91307,   27331.21218,
            26954.08613,   25620.43358,   23404.71758,
            20462.02531,   17054.81751,   13523.60500,
            10200.47371,    7317.24740,    4967.87694,
             3135.41449,    1747.40389,     722.93629,
                0.00000,       0.00000 /


      data b52 /0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00000,       0.00000,       0.00000,
                0.00821,       0.03278,       0.07386,
                0.13169,       0.20624,       0.29626,
                0.39833,       0.50628,       0.61217,
                0.70842,       0.79008,       0.85568,
                0.90635,       0.94448,       0.97251,
                0.99223,       1.00000 /
#endif

! High PBL resolution with top at 1 mb
      data a54/100.00000,     254.83931,     729.54278,   &
              1602.41121,    2797.50667,    4100.18977,   &
              5334.87140,    6455.24153,    7511.80944,   &
              8580.26355,    9714.44293,   10938.62253,   &
             12260.23793,   13681.38045,   15202.98892,   &
             16825.44410,   18548.56604,   20371.61864,   &
             22293.32079,   24033.35009,   25351.40415,   &
             26299.18673,   26920.83214,   27254.25434,   &
             27332.23371,   27183.29496,   26832.41840,   &
             26301.61755,   25610.40943,   24776.19833,   &
             23814.58975,   22739.64777,   21564.10661,   &
             20299.54484,   18956.61643,   17545.95425,   &
             16081.13773,   14583.85910,   13086.91505,   &
             11629.08518,   10243.59383,    8949.94267,   &
              7754.77820,    6657.52188,    5654.67945,   &
              4741.55941,    3912.82209,    3162.77710,   &
              2485.60664,    1875.52987,    1326.92552,   &
               834.46138,     393.36354,       0.00000,   &
                 0.00000 /

      data b54/0.00000,       0.00000,       0.00000,  &
               0.00000,       0.00000,       0.00000,  &
               0.00000,       0.00000,       0.00000,  &
               0.00000,       0.00000,       0.00000,  &
               0.00000,       0.00000,       0.00000,  &
               0.00000,       0.00000,       0.00000,  &
               0.00000,       0.00279,       0.01074,  &
               0.02331,       0.04002,       0.06047,  &
               0.08428,       0.11112,       0.14071,  &
               0.17276,       0.20703,       0.24330,  &
               0.28136,       0.32101,       0.36207,  &
               0.40437,       0.44775,       0.49201,  &
               0.53690,       0.58187,       0.62608,  &
               0.66854,       0.70844,       0.74534,  &
               0.77916,       0.81002,       0.83807,  &
               0.86349,       0.88647,       0.90721,  &
               0.92587,       0.94265,       0.95770,  &
               0.97119,       0.98326,       0.99400,  &
               1.00000   /

      data a55/ 1.00000,     2.00000,       3.27000,       &
              4.75850,       6.60000,       8.93450,       &
             11.97030,      15.94950,      21.13490,       &
             27.85260,      36.50410,      47.58060,       &
             61.67790,      79.51340,     101.94420,       &
            130.05080,     165.07920,     208.49720,       &
            262.02120,     327.64330,     407.65670,       &
            504.68050,     621.68000,     761.98390,       &
            929.29430,    1127.68880,    1364.33920,       &
           1645.70720,    1979.15540,    2373.03610,       &
           2836.78160,    3380.99550,    4017.54170,       &
           4764.39320,    5638.79380,    6660.33770,       &
           7851.22980,    9236.56610,   10866.34270,       &
          12783.70000,   15039.30000,   17693.00000,       &
          20119.20876,   21686.49129,   22436.28749,       &
          22388.46844,   21541.75227,   19873.78342,       &
          17340.31831,   13874.44006,   10167.16551,       &
           6609.84274,    3546.59643,    1270.49390,       &
              0.00000,       0.00000   /

      data b55 /0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     & 
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00696,       0.02801,       0.06372,     &
                0.11503,       0.18330,       0.27033,     &
                0.37844,       0.51046,       0.64271,     &
                0.76492,       0.86783,       0.94329,     &
                0.98511,       1.00000  /

! The 56-L setup Can be used for Mars:
#ifdef MARS_GCM
      data a56/ 0.33, 1.00000,  2.00000,    3.27000,       &
              4.75850,       6.60000,       8.93450,       &
             11.97030,      15.94950,      21.13490,       &
             27.85260,      36.50410,      47.58060,       &
             61.67790,      79.51340,     101.94420,       &
            130.05080,     165.07920,     208.49720,       &
            262.02120,     327.64330,     407.65670,       &
            504.68050,     621.68000,     761.98390,       &
            929.29430,    1127.68880,    1364.33920,       &
           1645.70720,    1979.15540,    2373.03610,       &
           2836.78160,    3380.99550,    4017.54170,       &
           4764.39320,    5638.79380,    6660.33770,       &
           7851.22980,    9236.56610,   10866.34270,       &
          12783.70000,   15039.30000,   17693.00000,       &
          20119.20876,   21686.49129,   22436.28749,       &
          22388.46844,   21541.75227,   19873.78342,       &
          17340.31831,   13874.44006,   10167.16551,       &
           6609.84274,    3546.59643,    1270.49390,       &
              0.00000,       0.00000   /

      data b56 /0., 0.00000,       0.00000,       0.00000, &
                0.00000,       0.00000,       0.00000,     & 
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00000,       0.00000,       0.00000,     &
                0.00696,       0.02801,       0.06372,     &
                0.11503,       0.18330,       0.27033,     &
                0.37844,       0.51046,       0.64271,     &
                0.76492,       0.86783,       0.94329,     &
                0.98511,       1.00000  /
#else
      data a56/  10.00000,      24.97818,      58.01160,   &
                115.21466,     199.29210,     309.39897,   &
                445.31785,     610.54747,     812.28518,   &
               1059.80882,    1363.07092,    1732.09335,   &
               2176.91502,    2707.68972,    3334.70962,   &
               4068.31964,    4918.76594,    5896.01890,   &
               7009.59166,    8268.36324,    9680.41211,   &
              11252.86491,   12991.76409,   14901.95764,   &
              16987.01313,   19249.15733,   21689.24182,   &
              23845.11055,   25330.63353,   26243.52467,   &
              26663.84998,   26657.94696,   26281.61371,   &
              25583.05256,   24606.03265,   23393.39510,   &
              21990.28845,   20445.82122,   18811.93894,   &
              17139.59660,   15473.90350,   13850.50167,   &
              12294.49060,   10821.62655,    9440.57746,   &
               8155.11214,    6965.72496,    5870.70511,   &
               4866.83822,    3949.90019,    3115.03562,   &
               2357.07879,    1670.87329,    1051.65120,   &
                495.51399,       0.00000,       0.00000 /

      data b56 /0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00000,       0.00000,       0.00000,  &
                0.00462,       0.01769,       0.03821,  &
                0.06534,       0.09834,       0.13659,  &
                0.17947,       0.22637,       0.27660,  &
                0.32929,       0.38343,       0.43791,  &
                0.49162,       0.54361,       0.59319,  &
                0.63989,       0.68348,       0.72391,  &
                0.76121,       0.79545,       0.82679,  &
                0.85537,       0.88135,       0.90493,  &
                0.92626,       0.94552,       0.96286,  &
                0.97840,       0.99223,       1.00000 /
#endif

      data a60/  1.7861000000e-01,   1.0805100000e+00,   3.9647100000e+00, &
                 9.7516000000e+00,   1.9816580000e+01,   3.6695950000e+01, &
                 6.2550570000e+01,   9.9199620000e+01,   1.4792505000e+02, &
                 2.0947487000e+02,   2.8422571000e+02,   3.7241721000e+02, &
                 4.7437835000e+02,   5.9070236000e+02,   7.2236063000e+02, &
                 8.7076746000e+02,   1.0378138800e+03,   1.2258877300e+03, &
                 1.4378924600e+03,   1.6772726600e+03,   1.9480506400e+03, &
                 2.2548762700e+03,   2.6030909400e+03,   2.9988059200e+03, &
                 3.4489952300e+03,   3.9616028900e+03,   4.5456641600e+03, &
                 5.2114401700e+03,   5.9705644000e+03,   6.8361981800e+03, &
                 7.8231906000e+03,   8.9482351000e+03,   1.0230010660e+04, &
                 1.1689289750e+04,   1.3348986860e+04,   1.5234111060e+04, &
                 1.7371573230e+04,   1.9789784580e+04,   2.2005564550e+04, &
                 2.3550115120e+04,   2.4468583320e+04,   2.4800548800e+04, &
                 2.4582445070e+04,   2.3849999620e+04,   2.2640519740e+04, &
                 2.0994737150e+04,   1.8957848730e+04,   1.6579413230e+04, &
                 1.4080071030e+04,   1.1753630920e+04,   9.6516996300e+03, &
                 7.7938009300e+03,   6.1769062800e+03,   4.7874276000e+03, &
                 3.6050497500e+03,   2.6059860700e+03,   1.7668328200e+03, &
                 1.0656131200e+03,   4.8226201000e+02,   0.0000000000e+00, &
                 0.0000000000e+00 /  


      data b60/ 0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
                0.0000000000e+00,   0.0000000000e+00,   5.0600000000e-03, &
                2.0080000000e-02,   4.4900000000e-02,   7.9360000000e-02, &
                1.2326000000e-01,   1.7634000000e-01,   2.3820000000e-01, &
                3.0827000000e-01,   3.8581000000e-01,   4.6989000000e-01, &
                5.5393000000e-01,   6.2958000000e-01,   6.9642000000e-01, &
                7.5458000000e-01,   8.0463000000e-01,   8.4728000000e-01, &
                8.8335000000e-01,   9.1368000000e-01,   9.3905000000e-01, &
                9.6020000000e-01,   9.7775000000e-01,   9.9223000000e-01, &
                1.0000000000e+00 /


      data a64/1.00000,       3.90000,       8.70000,      &
              15.42000,      24.00000,      34.50000,      &
              47.00000,      61.50000,      78.60000,      &
              99.13500,     124.12789,     154.63770,      &
             191.69700,     236.49300,     290.38000,      &
             354.91000,     431.82303,     523.09300,      &
             630.92800,     757.79000,     906.45000,      &
            1079.85000,    1281.00000,    1515.00000,      &
            1788.00000,    2105.00000,    2470.00000,      &
            2889.00000,    3362.00000,    3890.00000,      &
            4475.00000,    5120.00000,    5830.00000,      &
            6608.00000,    7461.00000,    8395.00000,      &
            9424.46289,   10574.46880,   11864.80270,      &
           13312.58890,   14937.03710,   16759.70700,      &
           18804.78710,   21099.41210,   23674.03710,      &
           26562.82810,   29804.11720,   32627.31640,      &
           34245.89840,   34722.28910,   34155.19920,      &
           32636.50390,   30241.08200,   27101.44920,      &
           23362.20700,   19317.05270,   15446.17090,      &
           12197.45210,    9496.39941,    7205.66992,      &
            5144.64307,    3240.79346,    1518.62134,      &
               0.00000,       0.00000 /

      data b64/0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00000,      &
               0.00000,       0.00000,       0.00813,      &
               0.03224,       0.07128,       0.12445,      &
               0.19063,       0.26929,       0.35799,      &
               0.45438,       0.55263,       0.64304,      &
               0.71703,       0.77754,       0.82827,      &
               0.87352,       0.91502,       0.95235,      &
               0.98511,       1.00000 /
!
! Ultra high troposphere resolution
      data a100/100.00000,     300.00000,     800.00000,   &
               1762.35235,    3106.43596,    4225.71874,   &
               4946.40525,    5388.77387,    5708.35540,   &
               5993.33124,    6277.73673,    6571.49996,   &
               6877.05339,    7195.14327,    7526.24920,   &
               7870.82981,    8229.35361,    8602.30193,   &
               8990.16936,    9393.46399,    9812.70768,   &
              10248.43625,   10701.19980,   11171.56286,   &
              11660.10476,   12167.41975,   12694.11735,   &
              13240.82253,   13808.17600,   14396.83442,   &
              15007.47066,   15640.77407,   16297.45067,   &
              16978.22343,   17683.83253,   18415.03554,   &
              19172.60771,   19957.34218,   20770.05022,   &
              21559.14829,   22274.03147,   22916.87519,   &
              23489.70456,   23994.40187,   24432.71365,   &
              24806.25734,   25116.52754,   25364.90190,   &
              25552.64670,   25680.92203,   25750.78675,   &
              25763.20311,   25719.04113,   25619.08274,   &
              25464.02630,   25254.49482,   24991.06137,   &
              24674.32737,   24305.11235,   23884.79781,   &
              23415.77059,   22901.76510,   22347.84738,   &
              21759.93950,   21144.07284,   20505.73136,   &
              19849.54271,   19179.31412,   18498.23400,   &
              17809.06809,   17114.28232,   16416.10343,   &
              15716.54833,   15017.44246,   14320.43478,   &
              13627.01116,   12938.50682,   12256.11762,   &
              11580.91062,   10913.83385,   10255.72526,   &
               9607.32122,    8969.26427,    8342.11044,   &
               7726.33606,    7122.34405,    6530.46991,   &
               5950.98721,    5384.11279,    4830.01153,   &
               4288.80090,    3760.55514,    3245.30920,   &
               2743.06250,    2253.78294,    1777.41285,   &
               1313.88054,     863.12371,     425.13088,   &
                  0.00000,       0.00000  /


      data b100/0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00000,       0.00000,       0.00000,   &
                0.00052,       0.00209,       0.00468,   &
                0.00828,       0.01288,       0.01849,   &
                0.02508,       0.03266,       0.04121,   &
                0.05075,       0.06126,       0.07275,   &
                0.08521,       0.09866,       0.11308,   &
                0.12850,       0.14490,       0.16230,   &
                0.18070,       0.20009,       0.22042,   &
                0.24164,       0.26362,       0.28622,   &
                0.30926,       0.33258,       0.35605,   &
                0.37958,       0.40308,       0.42651,   &
                0.44981,       0.47296,       0.49591,   &
                0.51862,       0.54109,       0.56327,   &
                0.58514,       0.60668,       0.62789,   &
                0.64872,       0.66919,       0.68927,   &
                0.70895,       0.72822,       0.74709,   &
                0.76554,       0.78357,       0.80117,   &
                0.81835,       0.83511,       0.85145,   &
                0.86736,       0.88286,       0.89794,   &
                0.91261,       0.92687,       0.94073,   &
                0.95419,       0.96726,       0.97994,   &
                0.99223,       1.00000  /

      data a104/           &
  1.8827062944e-01,   7.7977549145e-01,   2.1950593583e+00, &
  4.9874566624e+00,   9.8041418997e+00,   1.7019717163e+01, &
  2.7216579591e+01,   4.0518628401e+01,   5.6749646818e+01, &
  7.5513868331e+01,   9.6315093333e+01,   1.1866706195e+02, &
  1.4216835396e+02,   1.6653733709e+02,   1.9161605772e+02, &
  2.1735580129e+02,   2.4379516604e+02,   2.7103771847e+02, &
  2.9923284173e+02,   3.2856100952e+02,   3.5922338766e+02, &
  3.9143507908e+02,   4.2542117983e+02,   4.6141487902e+02, &
  4.9965698106e+02,   5.4039638379e+02,   5.8389118154e+02, &
  6.3041016829e+02,   6.8023459505e+02,   7.3366009144e+02, &
  7.9099869949e+02,   8.5258099392e+02,   9.1875827946e+02, &
  9.8990486716e+02,   1.0664204381e+03,   1.1487325074e+03, &
  1.2372990044e+03,   1.3326109855e+03,   1.4351954993e+03, &
  1.5456186222e+03,   1.6644886848e+03,   1.7924597105e+03, &
  1.9302350870e+03,   2.0785714934e+03,   2.2382831070e+03, &
  2.4102461133e+03,   2.5954035462e+03,   2.7947704856e+03, &
  3.0094396408e+03,   3.2405873512e+03,   3.4894800360e+03, &
  3.7574811281e+03,   4.0460585279e+03,   4.3567926151e+03, &
  4.6913848588e+03,   5.0516670674e+03,   5.4396113207e+03, &
  5.8573406270e+03,   6.3071403487e+03,   6.7914704368e+03, &
  7.3129785102e+03,   7.8745138115e+03,   8.4791420557e+03, &
  9.1301611750e+03,   9.8311179338e+03,   1.0585825354e+04, &
  1.1398380836e+04,   1.2273184781e+04,   1.3214959424e+04, &
  1.4228767429e+04,   1.5320029596e+04,   1.6494540743e+04, &
  1.7758482452e+04,   1.9118430825e+04,   2.0422798801e+04, &
  2.1520147587e+04,   2.2416813461e+04,   2.3118184510e+04, &
  2.3628790785e+04,   2.3952411814e+04,   2.4092209011e+04, &
  2.4050892106e+04,   2.3830930156e+04,   2.3434818358e+04, &
  2.2865410898e+04,   2.2126326004e+04,   2.1222420323e+04, &
  2.0160313690e+04,   1.8948920926e+04,   1.7599915822e+04, &
  1.6128019809e+04,   1.4550987232e+04,   1.2889169132e+04, &
  1.1164595563e+04,   9.4227665517e+03,   7.7259097899e+03, &
  6.1538244381e+03,   4.7808126007e+03,   3.5967415552e+03, &
  2.5886394104e+03,   1.7415964865e+03,   1.0393721271e+03, &
  4.6478852032e+02,   7.0308342481e-13,   0.0000000000e+00    / 




      data b104/           &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   0.0000000000e+00, &
  0.0000000000e+00,   0.0000000000e+00,   1.5648447298e-03, &
  6.2617046389e-03,   1.4104157933e-02,   2.5118187415e-02, &
  3.9340510972e-02,   5.6816335609e-02,   7.7596328431e-02, &
  1.0173255472e-01,   1.2927309709e-01,   1.6025505622e-01, &
  1.9469566981e-01,   2.3258141217e-01,   2.7385520518e-01, &
  3.1840233814e-01,   3.6603639170e-01,   4.1648734767e-01, &
  4.6939496013e-01,   5.2431098738e-01,   5.8071350676e-01, &
  6.3803478105e-01,   6.9495048840e-01,   7.4963750338e-01, &
  7.9975208897e-01,   8.4315257576e-01,   8.8034012292e-01, &
  9.1184389721e-01,   9.3821231526e-01,   9.6000677644e-01, &
  9.7779792223e-01,   9.9216315122e-01,   1.0000000000e+00     /


      select case (km)

       case (24)

          ks = 5     
          do k=1,km+1
            ak(k) = a24(k)
            bk(k) = b24(k)
          enddo

       case (26)
                
          ks = 7
          do k=1,km+1
            ak(k) = a26(k)     
            bk(k) = b26(k)     
          enddo

        case (32)
!         ks = 11              ! John Wilson's setup
          ks = 13              ! high-res trop_32 setup
          do k=1,km+1
            ak(k) = a32(k)
            bk(k) = b32(k)
          enddo

#ifdef MARS_GCM
       case (28)
          ks = 4     
          do k=1,km+1
            ak(k) = a28(k)
            bk(k) = b28(k)
          enddo

       case (30)
          ks = 6      
          do k=1,km+1 
            ak(k) = a30(k)
            bk(k) = b30(k)
          enddo

       case (36)
          ks = 10     
          do k=1,km+1
            ak(k) = a36(k)
            bk(k) = b36(k)
          enddo

       case (46)
          ks = 7     
          do k=1,km+1
            ak(k) = a46(k)
            bk(k) = b46(k)
          enddo
#endif MARS_GCM 

#ifdef VENUS_GCM
       case (50)
          ks = 28
          do k=1,km+1
            ak(k) = a50(k) * 92.E5
            bk(k) = b50(k)
          enddo
       if ( gid==0 ) then
            write(*,*) 'Venus pressure levels'
               do k=1,km+1
                 write(*,*) k, ak(k), bk(k)
               enddo
       endif
#endif VENUS_GCM

        case (47)
          ks = 27       ! high-res trop-strat
          do k=1,km+1
            ak(k) = a47(k)
            bk(k) = b47(k)
          enddo

        case (48)
#ifdef HI_48
          ks = 30
#else
          ks = 28
#endif
          do k=1,km+1
            ak(k) = a48(k)
            bk(k) = b48(k)
          enddo

        case (52)
          ks = 35         ! pint = 223
          do k=1,km+1
            ak(k) = a52(k)
            bk(k) = b52(k)
          enddo

        case (54)
          ks = 18         ! pint =  222.9332
          do k=1,km+1
            ak(k) = a54(k)
            bk(k) = b54(k)
          enddo

        case (55)
          ks = 41
          do k=1,km+1
            ak(k) = a55(k)
            bk(k) = b55(k)
          enddo

        case (56)
#ifdef MARS_GCM
          ks = 42
#else
          ks = 26
#endif
          do k=1,km+1
#ifdef MARS_GCM
            ak(k) = a56(k) * (6./1000.)
#else
            ak(k) = a56(k)
#endif
            bk(k) = b56(k)
          enddo

        case (60)
          ks = 37
          do k=1,km+1
            ak(k) = a60(k)
            bk(k) = b60(k)
          enddo


        case (64)
          ks = 46
          do k=1,km+1
            ak(k) = a64(k)
            bk(k) = b64(k)
          enddo

        case (100)
          ks = 38
          do k=1,km+1
            ak(k) = a100(k)
            bk(k) = b100(k)
          enddo

        case (104)
          ks = 73
          do k=1,km+1
            ak(k) = a104(k)
            bk(k) = b104(k)
          enddo


#ifndef TEST_GWAVES
        case (10)
!--------------------------------------------------
! Pure sigma-coordinate with uniform spacing in "z"
!--------------------------------------------------
!
         pt = 2000.           ! model top pressure (pascal)
!        pt =  100.           ! 1 mb
         press(1) = pt
         press(km+1) = p0
         dlnp = (log(p0) - log(pt)) / real(km)

            lnpe = log(press(km+1))
         do k=km,2,-1
            lnpe = lnpe - dlnp
            press(k) = exp(lnpe)
         enddo

! Search KS
            ks = 0
         do k=1,km
            if(press(k) >= pc) then
               ks = k-1
               goto 123
            endif
         enddo
123   continue

         if(ks /= 0) then
            do k=1,ks
               ak(k) = press(k)
               bk(k) = 0.
            enddo                                                
          endif                                                

             pint = press(ks+1)
          do k=ks+1,km                                        
             ak(k) =  pint*(press(km)-press(k))/(press(km)-pint)               
             bk(k) = (press(k) - ak(k)) / press(km+1)          
          enddo                                                
             ak(km+1) = 0. 
             bk(km+1) = 1.                                     
                                                              
!         do k=2,km
!            bk(k) = real(k-1) / real(km)
!            ak(k) = pt * ( 1. - bk(k) )
!         enddo

             ak(km+1) = 0.
             bk(km+1) = 1.
#endif

        case default

#ifdef TEST_GWAVES
!--------------------------------------------------
! Pure sigma-coordinate with uniform spacing in "z"
!--------------------------------------------------
          call gw_1d(km, 1000.E2, ak, bk, ptop, 10.E3, pt1)

            ks = 0
          pint = ak(1)
#else

!----------------------------------------------------------------
! Sigma-coordinate with uniform spacing in sigma and ptop = 1 mb
!----------------------------------------------------------------
         pt = 100.
! One pressure layer
         ks = 1
         pint = pt + 0.5*1.E5/real(km)

         ak(1) = pt
         bk(1) = 0.
         ak(2) = pint
         bk(2) = 0.
 
          do k=3,km+1
             bk(k) = real(k-2) / real(km-1)
             ak(k) = pint - bk(k)*pint
          enddo
          ak(km+1) = 0.
          bk(km+1) = 1.
#endif
      end select
      ptop = ak(1)

 end subroutine set_eta


 subroutine get_eta_level(npz, p_s, pf, ph, ak, bk, pscale)
  integer, intent(in) :: npz    
  real, intent(in)  :: p_s            ! unit: pascal
  real, intent(in)  :: ak(npz+1)
  real, intent(in)  :: bk(npz+1)
  real, intent(in), optional :: pscale
  real, intent(out) :: pf(npz)
  real, intent(out) :: ph(npz+1)
  integer k

  ph(1) = ak(1)               
  do k=2,npz+1
     ph(k) = ak(k) + bk(k)*p_s
  enddo                           
   
  if ( present(pscale) ) then
      do k=1,npz+1
         ph(k) = pscale*ph(k)
      enddo
  endif 

  if( ak(1) > 1.E-8 ) then   
     pf(1) = (ph(2) - ph(1)) / log(ph(2)/ph(1))
  else
     pf(1) = (ph(2) - ph(1)) * kappa/(kappa+1.)
  endif

  do k=2,npz
     pf(k) = (ph(k+1) - ph(k)) / log(ph(k+1)/ph(k))
  enddo

 end subroutine get_eta_level



 subroutine compute_dz(km, ztop, dz)

  integer, intent(in):: km
  real,   intent(in):: ztop        ! try 50.E3
  real,   intent(out):: dz(km)
!------------------------------
  real ze(km+1), dzt(km)
  integer k


! ztop = 30.E3
  dz(1) = ztop / real(km) 
  dz(km) = 0.5*dz(1)

  do k=2,km-1
     dz(k) = dz(1)
  enddo

! Top:
  dz(1) = 2.*dz(2)

  ze(km+1) = 0.
  do k=km,1,-1
     ze(k) = ze(k+1) + dz(k)
  enddo

  if ( gid==0 ) then
       write(*,*) 'Hybrid_z:  dz, zm'
       do k=1,km
          dzt(k) = 0.5*(ze(k)+ze(k+1)) / 1000.
          write(*,*) k, dz(k), dzt(k)
       enddo
  endif

 end subroutine compute_dz

 subroutine compute_dz_L32(km, ztop, dz)

  integer, intent(in):: km
  real,   intent(out):: dz(km)
  real,   intent(out):: ztop        ! try 50.E3
!------------------------------
  real dzt(km)
  real ze(km+1)
  real dz0, dz1, dz2
  real z0, z1, z2
  integer k, k0, k1, k2, n

!-------------------
        k2 =  8
        z2 = 30.E3
!-------------------
        k1 = 21
        z1 = 10.0E3
!-------------------
        k0 = 2
        z0 = 0.
!       dz0 = 80.   ! meters
        dz0 = 75.   ! meters
!-------------------
! Treat the surface layer as a special layer
        ze(1) = z0
        dz(1) = dz0

        ze(2) = dz(1)
          dz0 = 1.5*dz0
        dz(2) = dz0     

        ze(3) = ze(2) + dz(2)

        dz1 = 2.*(z1-ze(3) - k1*dz0) / (k1*(k1-1))

        do k=k0+1,k0+k1
           dz(k) = dz0 + (k-k0)*dz1
           ze(k+1) = ze(k) + dz(k)
        enddo

        dz0 = dz(k1+k0)
        dz2 = 2.*(z2-ze(k0+k1+1)-k2*dz0) / (k2*(k2-1))

        do k=k0+k1+1,k0+k1+k2
           dz(k) = dz0 + (k-k0-k1)*dz2
           ze(k+1) = ze(k) + dz(k)
        enddo

        dz(km) = 2.*dz(km-1)
        ztop = ze(km) + dz(km)
        ze(km+1) = ze(km) + dz(km)

        call zflip (dz, 1, km)

        ze(km+1) = 0.
        do k=km,1,-1
           ze(k) = ze(k+1) + dz(k)
        enddo

        if ( gid==0 ) then
           write(*,*) 'Hybrid_z:  dz, zm'
           do k=1,km
              dzt(k) = 0.5*(ze(k)+ze(k+1)) / 1000.
              write(*,*) k, dz(k), dzt(k)
           enddo
        endif

 end subroutine compute_dz_L32


 subroutine set_hybrid_z(is, ie, js, je, ng, km, ztop, dz, rgrav, hs, ze, delz)

 integer,  intent(in):: is, ie, js, je, ng, km
 real, intent(in):: rgrav, ztop
 real, intent(in):: dz(km)       ! Reference vertical resolution for zs=0
 real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng)
 real, intent(out), optional:: delz(is:ie,js:je,km)
 real, intent(out)::   ze(is:ie,js:je,km+1)
! local
 integer ntimes
 real zint
 real:: z1(is:ie,js:je)
 real:: z(km+1)
 real sig
 integer ks(is:ie,js:je)
 integer i, j, k, ks_min, kint

 z(km+1) = 0.
 do k=km,1,-1
    z(k) = z(k+1) + dz(k)
 enddo

  do j=js,je
     do i=is,ie
        ze(i,j,   1) = ztop 
        ze(i,j,km+1) = hs(i,j) * rgrav 
     enddo
  enddo

 do k=2,km
   do j=js,je
      do i=is,ie
         ze(i,j,k) = z(k)
      enddo
   enddo
 enddo

! Set interface:
#ifdef USE_CONST_ZINT
  zint = 8.5E3
  ntimes = 4
  kint = 2
  do k=2,km
     if ( z(k)<=zint ) then
          kint = k
          exit
     endif
  enddo

  if ( gid==0 ) write(*,*) 'Z_coord interface set at k=',kint, ' ZE=', z(kint)

  do j=js,je
     do i=is,ie
        do k=kint+1,km
           sig = 1. - min(1., z(k)/z(kint))
           ze(i,j,k) = z(k) + ze(i,j,km+1)*sig
        enddo
!--------------------------------------
! Apply vertical smoother locally to dz
!--------------------------------------
        call sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
    enddo
  enddo
#else
! ZINT is a function of local terrain
  ntimes = 5
  do j=js,je
     do i=is,ie
        z1(i,j) = 1.75*max(0.0, ze(i,j,km+1)) + z(km-2)
     enddo
  enddo

   ks_min = km
   do j=js,je
      do i=is,ie
         do k=km,2,-1
            if ( z(k)>=z1(i,j) ) then
                 ks(i,j) = k
                 ks_min = min(ks_min, k)
                 go to 555
            endif
        enddo
555     continue
      enddo
   enddo

  do j=js,je
     do i=is,ie
        kint = ks(i,j) + 1
        do k=kint,km
           sig = 1. - min(1., z(k)/z1(i,j))
           ze(i,j,k) = z(k) + ze(i,j,km+1)*sig
        enddo
!--------------------------------------
! Apply vertical smoother locally to dz
!--------------------------------------
        call sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
    enddo
  enddo
#endif

  if ( present(delz) ) then
  do k=1,km
     do j=js,je
        do i=is,ie
           delz(i,j,k) = ze(i,j,k+1) - ze(i,j,k)
           if ( delz(i,j,k) > 0. ) then
                write(*,*) 'Error in set_hybrid_z:', k,j,i, delz(i,j,k)
!               stop
           endif
        enddo
     enddo
  enddo
  endif

  end subroutine set_hybrid_z


  subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
  integer, intent(in):: is, ie, js, je, km
  integer, intent(in):: ntimes, i, j
  real, intent(inout):: ze(is:ie,js:je,km+1)
! local:
  real, parameter:: df = 0.25
  real dz(km)
  real flux(km+1)
  integer k, n, k1, k2

      k2 = km-1
      do k=1,km
         dz(k) = ze(i,j,k+1) - ze(i,j,k)
      enddo

   do n=1,ntimes
      k1 = 2 + (ntimes-n)

      flux(k1  ) = 0.
      flux(k2+1) = 0.
      do k=k1+1,k2
         flux(k) = df*(dz(k) - dz(k-1))
      enddo

      do k=k1,k2
         dz(k) = dz(k) - flux(k) + flux(k+1)
      enddo
   enddo

   do k=km,1,-1
      ze(i,j,k) = ze(i,j,k+1) - dz(k)
   enddo

  end subroutine sm1_edge

  subroutine gw_1d(km, p0, ak, bk, ptop, ztop, pt1)
  integer, intent(in):: km
  real,    intent(in):: p0, ztop
  real,    intent(inout):: ptop
  real,    intent(inout):: ak(km+1), bk(km+1)
  real, intent(out):: pt1(km)
! Local
  logical:: isothermal
  real, dimension(km+1):: ze, pe1, pk1
  real, dimension(km):: dz1
  real t0, n2, s0
  integer  k

! Set up vertical coordinare with constant del-z spacing:
       isothermal = .false.
       t0 = 300.

       if ( isothermal ) then
            n2 = grav**2/(cp_air*t0)
       else
            n2 = 0.0001
       endif

       s0 = grav*grav / (cp_air*n2) 

       ze(km+1) = 0.
       do k=km,1,-1
          dz1(k) = ztop / real(km)
           ze(k) = ze(k+1) + dz1(k)
       enddo

! Given z --> p
       do k=1,km+1
          pe1(k) = p0*( (1.-s0/t0) + s0/t0*exp(-n2*ze(k)/grav) )**(1./kappa)
       enddo

       ptop = pe1(1) 
!      if ( gid==0 ) write(*,*) 'GW_1D: computed model top (pa)=', ptop

! Set up "sigma" coordinate 
       ak(1) = pe1(1)
       bk(1) = 0.
       do k=2,km
          bk(k) = (pe1(k) - pe1(1)) / (pe1(km+1)-pe1(1))  ! bk == sigma
          ak(k) =  pe1(1)*(1.-bk(k)) 
       enddo                                                
       ak(km+1) = 0.
       bk(km+1) = 1.

       do k=1,km+1
          pk1(k) = pe1(k) ** kappa
       enddo

! Compute volume mean potential temperature with hydrostatic eqn:
       do k=1,km
          pt1(k) = grav*dz1(k) / ( cp_air*(pk1(k+1)-pk1(k)) )
       enddo

  end subroutine gw_1d



  subroutine zflip(q, im, km)
  integer, intent(in):: im, km
  real, intent(inout):: q(im,km)
!---
  integer i, k
  real qtmp

    do i = 1, im
       do k = 1, (km+1)/2
          qtmp = q(i,k)
          q(i,k) = q(i,km+1-k)
          q(i,km+1-k) = qtmp
       end do                                              
    end do                                                
                                                              
  end subroutine zflip   

end module fv_eta_mod


module fv_grid_tools_mod

  use constants_mod, only: radius, pi, omega, grav
  use fv_arrays_mod, only: fv_atmos_type
  use fv_grid_utils_mod,    only: gnomonic_grids, great_circle_dist,  &
                           mid_pt_sphere, spherical_angle,     &
                           project_sphere_v,  cell_center2,    &
                           get_area, inner_prod, deglat,       &
                           sw_corner, se_corner, ne_corner, nw_corner, fill_ghost, &
                           Gnomonic_grid
  use fv_timing_mod,  only: timing_on, timing_off
  use fv_mp_mod, only: gid, masterproc, domain, tile, &
                    is,js,ie,je,isd,jsd,ied,jed, ng, &
                    fill_corners, XDir, YDir, &
                    mp_gather, mp_bcst, mp_reduce_max, mp_stop, &
                    npes_x, npes_y
  use sorted_index_mod,  only: sorted_inta, sorted_intb
  use mpp_mod,           only: mpp_error, FATAL, get_unit, mpp_chksum, mpp_pe, stdout, &
                               mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_npes, &
                               mpp_sum, mpp_max, mpp_min
  use mpp_domains_mod,   only: mpp_update_domains, mpp_get_boundary, &
                               mpp_get_ntile_count, mpp_get_pelist, &
                               mpp_get_compute_domains, mpp_global_field
  use mpp_io_mod,        only: mpp_get_att_value     

  use mpp_parameter_mod, only: AGRID_PARAM=>AGRID,       & 
                               CGRID_NE_PARAM=>CGRID_NE, &
                               CGRID_SW_PARAM=>CGRID_SW, &
                               BGRID_NE_PARAM=>BGRID_NE, &
                               BGRID_SW_PARAM=>BGRID_SW, & 
                               SCALAR_PAIR,              &
                               CORNER, CENTER, XUPDATE
  use fms_mod,           only: get_mosaic_tile_grid
  use fms_io_mod,        only: file_exist, field_exist, read_data, &
                               get_global_att_value, get_var_att_value
  use mosaic_mod,       only : get_mosaic_ntiles
  implicit none
  private
#include "netcdf.inc"

  real :: csFac = -999
  real            :: zeta = 1.0                ! non-linear flag 
  real , parameter:: todeg = 180.0/pi          ! convert to degrees
  real , parameter:: torad = pi/180.0          ! convert to radians
  real , parameter:: missing = 1.e25
  real    :: stretch ! Optional stretching factor for the grid 
  logical :: dxdy_area = .false.   ! define area using dx*dy else spherical excess formula
  logical :: latlon = .false.
  logical :: cubed_sphere = .false.
  logical :: double_periodic = .false.
  logical :: latlon_patch = .false.
  logical :: latlon_strip = .false.
  logical :: channel = .false.
  logical :: have_south_pole = .false.
  logical :: have_north_pole = .false.
  logical :: uniform_ppm = .true.     ! assume uniform grid spacing for PPM calcs, else variable dx,dy
  integer :: interpOrder = 1
  logical :: debug_message_size = .false.
  logical :: write_grid_char_file = .false.

  ! grid descriptors

  ! Horizontal
  integer :: npx_g, npy_g, npz_g, ntiles_g ! global domain
  real, allocatable, target, dimension(:,:,:) :: grid, agrid
  real, allocatable, dimension(:,:) :: area, area_c
  real, allocatable, dimension(:,:) :: sina, cosa
  real, allocatable, dimension(:,:,:) :: e1,e2
  real, allocatable, dimension(:,:) :: dx, dy
  real, allocatable, dimension(:,:) :: dxc, dyc
  real, allocatable, dimension(:,:) :: dxa, dya
  real, allocatable, dimension(:,:) :: rarea, rarea_c
  real, allocatable, dimension(:,:) :: rdx, rdy
  real, allocatable, dimension(:,:) :: rdxc, rdyc
  real, allocatable, dimension(:,:) :: rdxa, rdya
  real  :: acapN, acapS
  real  :: globalarea  ! total Global Area
  real, allocatable :: cose(:,:)
  real, allocatable :: cosp(:,:)
  real, allocatable :: acosp(:,:)
  
  integer, dimension(:,:,:), allocatable :: iinta, jinta, iintb, jintb
  
  integer :: grid_type = 0    ! -1: read from file; 0: ED Gnomonic
                              !  0: the "true" equal-distance Gnomonic grid
                              !  1: the traditional equal-distance Gnomonic grid
                              !  2: the equal-angular Gnomonic grid
                              !  3: the lat-lon grid -- to be implemented
                              !  4: double periodic boundary condition on Cartesian grid
                              !  5: latlon patch
                              !  6: latlon strip (cyclic in longitude)
                              !  7: channel flow on Cartesian grid

  real :: dx_const = 1000.    ! spatial resolution for double periodic boundary configuration [m]
  real :: dy_const = 1000.
  real :: deglon_start = -30., deglon_stop = 30., &  ! boundaries of latlon patch
          deglat_start = -30., deglat_stop = 30.

  public :: npx_g, npy_g, npz_g, grid, agrid, stretch, todeg, &
            interpOrder, uniform_ppm, zeta, missing, &
            cubed_sphere, latlon, have_south_pole, have_north_pole, &
            double_periodic, channel, &
            dx,dy, dxa,dya, dxc,dyc, rdx,rdy, rdxc,rdyc,  &
            sina, cosa, area, rarea, area_c, rarea_c,  &
            acapN, acapS, cosp, cose, acosp, init_grid, read_grid, &
            rdxa, rdya, d2a2c, ctoa, atod, dtoa, atoc, atob_s,   &
            mp_update_dwinds, rotate_winds, &
            spherical_to_cartesian, globalsum, &
            get_unit_vector, unit_vect2
  public :: grid_type, dx_const, dy_const
  public :: deglon_start, deglon_stop, deglat_start, deglat_stop
  public :: debug_message_size, write_grid_char_file

  INTERFACE get_unit_vector
     MODULE PROCEDURE get_unit_vector_3pts
     MODULE PROCEDURE get_unit_vector_2pts
  END INTERFACE

  INTERFACE mp_update_dwinds
     MODULE PROCEDURE mp_update_dwinds_2d
     MODULE PROCEDURE mp_update_dwinds_3d
  END INTERFACE

contains

  subroutine read_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, ng)
    !     read_grid :: read grid from mosaic grid file.
    type(fv_atmos_type), intent(inout) :: Atm
    character(len=*),    intent(IN)    :: grid_name
    character(len=*),    intent(IN)    :: grid_file
    integer,             intent(IN)    :: npx, npy, npz
    integer,             intent(IN)    :: ndims
    integer,             intent(IN)    :: nregions
    integer,             intent(IN)    :: ng

    real, allocatable, dimension(:,:)  :: tmpx, tmpy
    real, allocatable, dimension(:)    :: ebuffer, wbuffer, sbuffer, nbuffer
    character(len=128)                 :: units = ""
    character(len=256)                 :: atm_mosaic, atm_hgrid, grid_form
    character(len=1024)                :: attvalue
    integer                            :: ntiles, i, j
    integer                            :: isg, ieg, jsg, jeg
    integer                            :: isc2, iec2, jsc2, jec2
    real                               :: p1(3), p2(3), p3(3), p4(3)
    integer                            :: start(4), nread(4)
    real                               :: angN,angM,angAV,ang
    real                               :: aspN,aspM,aspAV,asp
    real                               ::  dxN, dxM, dxAV
    real                               :: dx_local, dy_local
    real, allocatable, dimension(:,:)  :: tmp, g_tmp, angs, asps, dxs
    character(len=80)                  :: gcharFile
    integer                            :: fileLun, n
    real                               :: p_lL(ndims) ! lower Left
    real                               :: p_uL(ndims) ! upper Left
    real                               :: p_lR(ndims) ! lower Right
    real                               :: p_uR(ndims) ! upper Right
    real                               :: d1, d2, mydx, mydy

    Gnomonic_grid = .true.   
    cubed_sphere = .true.
    uniform_ppm = .true.
    npx_g = npx
    npy_g = npy
    npz_g = npz
    ntiles_g = nregions

    if(.not. file_exist(grid_file)) call mpp_error(FATAL, 'fv_grid_tools(read_grid): file '// &
         trim(grid_file)//' does not exist')

    !--- make sure the grid file is mosaic file.
    if( field_exist(grid_file, 'atm_mosaic_file') .OR. field_exist(grid_file, 'gridfiles') ) then
       write(stdout(),*) '==>Note from fv_grid_tools_mod(read_grid): read atmosphere grid from mosaic version grid'
    else
       call mpp_error(FATAL, 'fv_grid_tools(read_grid): neither atm_mosaic_file nor gridfiles exists in file ' &
            //trim(grid_file))
    endif

    if(field_exist(grid_file, 'atm_mosaic_file')) then
       call read_data(grid_file, "atm_mosaic_file", atm_mosaic)
       atm_mosaic = "INPUT/"//trim(atm_mosaic)
    else 
       atm_mosaic = trim(grid_file)
    endif

    call get_mosaic_tile_grid(atm_hgrid, atm_mosaic, domain)

    grid_form = "none"    
    if( get_global_att_value(atm_hgrid, "history", attvalue) ) then
       if( index(attvalue, "gnomonic_ed") > 0) grid_form = "gnomonic_ed"
    endif
    if(grid_form .NE. "gnomonic_ed") call mpp_error(FATAL, &
         "fv_grid_tools(read_grid): the grid should be 'gnomonic_ed' when reading from grid file, contact developer")

    ntiles = get_mosaic_ntiles(atm_mosaic)
    if(ntiles .NE. 6) call mpp_error(FATAL, &
       'fv_grid_tools(read_grid): ntiles should be 6 in mosaic file '//trim(atm_mosaic) )
    if(nregions .NE. 6) call mpp_error(FATAL, &
       'fv_grid_tools(read_grid): nregions should be 6 when reading from mosaic file '//trim(grid_file) )

    !-------------------------------------------------------------------
    !   memory allocation for module variable or public variable
    !------------------------------------------------------------------
    allocate (  area(isd:ied  ,jsd:jed  ) )   ! Cell Centered
    allocate ( rarea(isd:ied  ,jsd:jed  ) )   ! Cell Centered
    
    allocate (  area_c(isd:ied+1,jsd:jed+1) )  ! Cell Corners
    allocate ( rarea_c(isd:ied+1,jsd:jed+1) )  ! Cell Corners
    
    allocate (  dx(isd:ied  ,jsd:jed+1) )
    allocate ( rdx(isd:ied  ,jsd:jed+1) )
    allocate (  dy(isd:ied+1,jsd:jed  ) )
    allocate ( rdy(isd:ied+1,jsd:jed  ) )
    
    allocate (  dxc(isd:ied+1,jsd:jed  ) )
    allocate ( rdxc(isd:ied+1,jsd:jed  ) )
    allocate (  dyc(isd:ied  ,jsd:jed+1) )
    allocate ( rdyc(isd:ied  ,jsd:jed+1) )
    
    allocate (  dxa(isd:ied  ,jsd:jed  ) )
    allocate ( rdxa(isd:ied  ,jsd:jed  ) )
    allocate (  dya(isd:ied  ,jsd:jed  ) )
    allocate ( rdya(isd:ied  ,jsd:jed  ) )
    
    allocate ( grid (isd:ied+1,jsd:jed+1,1:ndims) )
    allocate ( agrid(isd:ied  ,jsd:jed  ,1:ndims) )
    
    Atm%grid  =>grid
    Atm%agrid =>agrid
    
    allocate ( sina(isd:ied+1,jsd:jed+1) )   ! SIN(angle of intersection)
    allocate ( cosa(isd:ied+1,jsd:jed+1) )   ! COS(angle of intersection)
    
    allocate (   e1(3,isd:ied+1,jsd:jed+1) )
    allocate (   e2(3,isd:ied+1,jsd:jed+1) )

    call get_var_att_value(atm_hgrid, 'x', 'units', units)

    !--- get the geographical coordinates of super-grid.
    isc2 = 2*is-1; iec2 = 2*ie+1
    jsc2 = 2*js-1; jec2 = 2*je+1  
    allocate(tmpx(isc2:iec2, jsc2:jec2) )
    allocate(tmpy(isc2:iec2, jsc2:jec2) )
    start = 1; nread = 1
    start(1) = isc2; nread(1) = iec2 - isc2 + 1
    start(2) = jsc2; nread(2) = jec2 - jsc2 + 1
    call read_data(atm_hgrid, 'x', tmpx, start, nread, no_domain=.TRUE.)
    call read_data(atm_hgrid, 'y', tmpy, start, nread, no_domain=.TRUE.)

    !--- geographic grid at cell corner
    grid(isd: is-1, jsd:js-1,1:ndims)=0.
    grid(isd: is-1, je+2:jed+1,1:ndims)=0.
    grid(ie+2:ied+1,jsd:js-1,1:ndims)=0.
    grid(ie+2:ied+1,je+2:jed+1,1:ndims)=0.
    if(len_trim(units) < 6) call mpp_error(FATAL, &
          "fv_grid_tools_mod(read_grid): the length of units must be no less than 6")
    if(units(1:6) == 'degree') then
       do j = js, je+1
          do i = is, ie+1
             grid(i,j,1) = tmpx(2*i-1,2*j-1)*pi/180.
             grid(i,j,2) = tmpy(2*i-1,2*j-1)*pi/180.
          enddo
       enddo
    else if(units(1:6) == 'radian') then
       do j = js, je+1
          do i = is, ie+1
             grid(i,j,1) = tmpx(2*i-1,2*j-1)
             grid(i,j,2) = tmpy(2*i-1,2*j-1)
          enddo
       enddo
    else
       print*, 'units is ' , trim(units), len_trim(units), mpp_pe()
       call mpp_error(FATAL, 'fv_grid_tools_mod(read_grid): units must start with degree or radian')
    endif

    call mpp_update_domains( grid, domain, position=CORNER)    

    !--- geographic grid at cell center
    agrid(:,:,:) = -1.e25
    if(units(1:6) == 'degree') then
       do j = js, je
          do i = is, ie
             agrid(i,j,1) = tmpx(2*i,2*j)*pi/180.
             agrid(i,j,2) = tmpy(2*i,2*j)*pi/180.
          enddo
       enddo
    else if(units(1:6) == 'radian') then
       do j = js, je
          do i = is, ie
             agrid(i,j,1) = tmpx(2*i,2*j)
             agrid(i,j,2) = tmpy(2*i,2*j)
          enddo
       enddo
    endif
    
    call mpp_update_domains( agrid, domain)       
    call fill_corners(agrid(:,:,1), npx, npy, XDir, AGRID=.true.)
    call fill_corners(agrid(:,:,2), npx, npy, YDir, AGRID=.true.)
    deallocate(tmpx, tmpy)

    !--- dx and dy         
    do j = js, je+1
       do i = is, ie
          p1(1) = grid(i  ,j,1)
          p1(2) = grid(i  ,j,2)
          p2(1) = grid(i+1,j,1)
          p2(2) = grid(i+1,j,2)
          dx(i,j) = great_circle_dist( p2, p1, radius )
       enddo
    enddo
    call get_symmetry(dx(is:ie,js:je+1), dy(is:ie+1,js:je), 0, 1 )     
    allocate(ebuffer(js:je), wbuffer(js:je), sbuffer(is:ie), nbuffer(is:ie))
    call mpp_get_boundary( dy, dx, domain, ebufferx=ebuffer, wbufferx=wbuffer, sbuffery=sbuffer, nbuffery=nbuffer,&
         flags=SCALAR_PAIR+XUPDATE, gridtype=CGRID_NE_PARAM)
    if(is == 1 .AND. mod(tile,2) .NE. 0) then ! on the west boundary
       dy(is, js:je) = wbuffer(js:je)
    endif
    if(ie == npx-1) then  ! on the east boundary
       dy(ie+1, js:je) = ebuffer(js:je)
    endif
    deallocate(wbuffer, ebuffer, sbuffer, nbuffer)

    call mpp_update_domains( dy, dx, domain, flags=SCALAR_PAIR,      &
         gridtype=CGRID_NE_PARAM, complete=.true.)

    call fill_corners(dx, dy, npx, npy, DGRID=.true.)

    !--- dxa and dya

    do j=jsd,jed
       do i=isd,ied
          !        do j=js,je
          !           do i=is,ie
          call mid_pt_sphere(grid(i,  j,1:2), grid(i,  j+1,1:2), p1)
          call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
          dxa(i,j) = great_circle_dist( p2, p1, radius )
          !
          call mid_pt_sphere(grid(i,j  ,1:2), grid(i+1,j  ,1:2), p1)
          call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
          dya(i,j) = great_circle_dist( p2, p1, radius )
       enddo
    enddo
    !      call mpp_update_domains( dxa, dya, domain, flags=SCALAR_PAIR, gridtype=AGRID_PARAM)
    call fill_corners(dxa, dya, npx, npy, AGRID=.true.)

    !--- dxc and dyc
    do j=js,je
       do i=is,ie+1
          p1(1) = agrid(i-1,j,1)
          p1(2) = agrid(i-1,j,2)
          p2(1) = agrid(i  ,j,1)
          p2(2) = agrid(i  ,j,2)
          dxc(i,j) = great_circle_dist( p2, p1, radius )
       enddo
    enddo
    do j=js,je+1
       do i=is,ie
          p1(1) = agrid(i,j-1,1)
          p1(2) = agrid(i,j-1,2)
          p2(1) = agrid(i,j  ,1)
          p2(2) = agrid(i,j  ,2)
          dyc(i,j) = great_circle_dist( p2, p1, radius )
       enddo
    enddo

    !--- area and area_c
    allocate (iinta(4, isd:ied ,jsd:jed), jinta(4, isd:ied ,jsd:jed),  &
              iintb(4, is:ie+1 ,js:je+1), jintb(4, is:ie+1 ,js:je+1))
    call sorted_inta(isd, ied, jsd, jed, cubed_sphere, grid, iinta, jinta)
    call sorted_intb(isd, ied, jsd, jed, is, ie, js, je, npx, npy, &
         cubed_sphere, agrid, iintb, jintb)
    call grid_area( npx, npy, ndims, nregions )
    deallocate(iintb, jintb)

#ifndef ORIG_AREA_C
    ! Compute area_c, rarea_c, dxc, dyc
    if ( is==1 ) then
       i = 1
       do j=js,je+1
          call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,  1:2), p1)
          call mid_pt_sphere(grid(i,j  ,1:2), grid(i,j+1,1:2), p4)
          p2(1:2) = agrid(i,j-1,1:2)
          p3(1:2) = agrid(i,j,  1:2)
          area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
       enddo
       do j=js,je
          call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
          p2(1:2) = agrid(i,j,1:2)
          dxc(i,j) = 2.*great_circle_dist( p1, p2, radius )
       enddo
    endif
    if ( (ie+1)==npx ) then
       i = npx
       do j=js,je+1
          p1(1:2) = agrid(i-1,j-1,1:2)
          call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,  1:2), p2)
          call mid_pt_sphere(grid(i,j  ,1:2), grid(i,j+1,1:2), p3)
          p4(1:2) = agrid(i-1,j,1:2)
          area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
       enddo
       do j=js,je
          p1(1:2) = agrid(i-1,j,1:2)
          call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
          dxc(i,j) = 2.*great_circle_dist( p1, p2, radius )
       enddo
    endif
    if ( js==1 ) then
       j = 1
       do i=is,ie+1
          call mid_pt_sphere(grid(i-1,j,1:2), grid(i,  j,1:2), p1)
          call mid_pt_sphere(grid(i,  j,1:2), grid(i+1,j,1:2), p2)
          p3(1:2) = agrid(i,  j,1:2)
          p4(1:2) = agrid(i-1,j,1:2)
          area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
       enddo
       do i=is,ie
          call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
          p2(1:2) = agrid(i,j,1:2)
          dyc(i,j) = 2.*great_circle_dist( p1, p2, radius )
       enddo
    endif
    if ( (je+1)==npy ) then
       j = npy
       do i=is,ie+1
          p1(1:2) = agrid(i-1,j-1,1:2)
          p2(1:2) = agrid(i  ,j-1,1:2)
          call mid_pt_sphere(grid(i,  j,1:2), grid(i+1,j,1:2), p3)
          call mid_pt_sphere(grid(i-1,j,1:2), grid(i,  j,1:2), p4)
          area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
       enddo
       do i=is,ie
          p1(1:2) = agrid(i,j-1,1:2)
          call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
          dyc(i,j) = 2.*great_circle_dist( p1, p2, radius )
       enddo
    endif
    if ( sw_corner ) then
       i=1; j=1
       p1(1:2) = grid(i,j,1:2)
       call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
       p3(1:2) = agrid(i,j,1:2)
       call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p4)
       area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
    endif
    if ( se_corner ) then
       i=npx; j=1
       call mid_pt_sphere(grid(i-1,j,1:2), grid(i,j,1:2), p1)
       p2(1:2) = grid(i,j,1:2)
       call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p3)
       p4(1:2) = agrid(i,j,1:2)
       area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
    endif
    if ( ne_corner ) then
       i=npx; j=npy
       p1(1:2) = agrid(i-1,j-1,1:2)
       call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,1:2), p2)
       p3(1:2) = grid(i,j,1:2)
       call mid_pt_sphere(grid(i-1,j,1:2), grid(i,j,1:2), p4)
       area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
    endif
    if ( nw_corner ) then
       i=1; j=npy
       call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,1:2), p1)
       p2(1:2) = agrid(i,j-1,1:2)
       call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p3)
       p4(1:2) = grid(i,j,1:2)
       area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
    endif
#endif

    call mpp_update_domains( dxc, dyc, domain, flags=SCALAR_PAIR,   &
         gridtype=CGRID_NE_PARAM, complete=.true.)
    call fill_corners(dxc, dyc, npx, npy, CGRID=.true.)

    call mpp_update_domains( area,   domain, complete=.true. )
    call mpp_update_domains( area_c, domain, position=CORNER, complete=.true.)

    ! Handle corner Area ghosting
    call fill_ghost(area, npx, npy, -1.E35)  ! fill in garbage values
    call fill_corners(area_c, npx, npy, FILL=XDir, BGRID=.true.)

    do j=jsd,jed+1
       do i=isd,ied
          rdx(i,j) = 1.0/dx(i,j)
       enddo
    enddo
    do j=jsd,jed
       do i=isd,ied+1
          rdy(i,j) = 1.0/dy(i,j)
       enddo
    enddo
    do j=jsd,jed
       do i=isd,ied+1
          rdxc(i,j) = 1.0/dxc(i,j)
       enddo
    enddo
    do j=jsd,jed+1
       do i=isd,ied
          rdyc(i,j) = 1.0/dyc(i,j)
       enddo
    enddo
    do j=jsd,jed
       do i=isd,ied
          rarea(i,j) = 1.0/area(i,j)
          rdxa(i,j) = 1./dxa(i,j)
          rdya(i,j) = 1./dya(i,j)
       enddo
    enddo
    do j=jsd,jed+1
       do i=isd,ied+1
          rarea_c(i,j) = 1.0/area_c(i,j)
       enddo
    enddo

200    format(A,f9.2,A,f9.2,A,f9.2)
201    format(A,f9.2,A,f9.2,A,f9.2,A,f9.2)
202    format(A,A,i4.4,A,i4.4,A)

    ! Get and print Grid Statistics, Only from tile 1
    dxAV =0.0
    angAV=0.0
    aspAV=0.0
    dxN  =  missing
    dxM  = -missing
    angN =  missing
    angM = -missing
    aspN =  missing
    aspM = -missing
    allocate(angs(is:ie,js:je), asps(is:ie,js:je), dxs(is:ie,js:je) )
    if (tile == 1) then
       do j=js, je
          do i=is, ie
             if(i>ceiling(npx/2.) .OR. j>ceiling(npy/2.)) cycle
             ang  = get_angle(2, grid(i,j+1,1:2), grid(i,j,1:2), grid(i+1,j,1:2))
             ang  = ABS(90.0 - ang)
             angs(i,j) = ang

             if ( (i==1) .and. (j==1) ) then
             else 
                angAV = angAV + ang
                angM  = MAX(angM,ang)
                angN  = MIN(angN,ang)
             endif

             dx_local = dx(i,j)
             dy_local = dy(i,j)

             dxAV  = dxAV + 0.5 * (dx_local + dy_local)
             dxM   = MAX(dxM,dx_local)
             dxM   = MAX(dxM,dy_local)
             dxN   = MIN(dxN,dx_local)
             dxN   = MIN(dxN,dy_local)
             dxs(i,j) = dy_local !0.5 * (dx_local + dy_local)

             asp   = ABS(dx_local/dy_local)
             if (asp < 1.0) asp = 1.0/asp
             asps(i,j) = asp 
             aspAV = aspAV + asp
             aspM  = MAX(aspM,asp)
             aspN  = MIN(aspN,asp)
          enddo
       enddo
    else
       angs = 0
       asps = 0
       dxs  = 0 
    endif
    call mpp_sum(angAv)
    call mpp_sum(dxAV)
    call mpp_sum(aspAV)
    call mpp_max(angM)
    call mpp_min(angN)
    call mpp_max(dxM)
    call mpp_min(dxN)
    call mpp_max(aspM)
    call mpp_min(aspN)

    if( gid==masterproc ) then
       angAV = angAV / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) - 1 )
       dxAV  = dxAV  / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) )
       aspAV = aspAV / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) )
       write(*,*  ) ''
       write(*,*  ) ' Cubed-Sphere Grid Stats : ', npx,'x',npy,'x',nregions
       write(*,201) '      Grid Length               : min: ', dxN,' max: ', dxM,' avg: ', dxAV, ' min/max: ',dxN/dxM
       write(*,200) '      Deviation from Orthogonal : min: ',angN,' max: ',angM,' avg: ',angAV
       write(*,200) '      Aspect Ratio              : min: ',aspN,' max: ',aspM,' avg: ',aspAV
       write(*,*  ) ''
    endif

    if(write_grid_char_file) then
       allocate(g_tmp(npx-1,npy-1))
       call mpp_global_field(domain, angs, g_tmp)
       if( gid==masterproc ) then
          write(gcharFile,202) TRIM(grid_name),'_chars_',npx,'x',npy,'.dat'
          fileLun=get_unit()
          open(unit=fileLun,file=gcharFile, form='unformatted', access='direct',  &
               recl=((npx/2)+1)*((npy/2)+1)*8, status='unknown')
          allocate(tmp(1:(npx/2)+1, 1:(npy/2)+1))
          do j = 1,ceiling(npy/2.)
             do i=1,ceiling(npx/2.)
                tmp(i,j) = g_tmp(i,j)
             enddo
          enddo
          write(fileLun,rec=1) tmp
       endif

       call mpp_global_field(domain, asps, g_tmp)
       if( gid==masterproc ) then
          do j = 1,ceiling(npy/2.)
             do i=1,ceiling(npx/2.)
                tmp(i,j) = g_tmp(i,j)
             enddo
          enddo
          write(fileLun,rec=2) tmp
       endif

       call mpp_global_field(domain, dxs,  g_tmp)
       if( gid==masterproc ) then
          do j = 1,ceiling(npy/2.)
             do i=1,ceiling(npx/2.)
                tmp(i,j) = g_tmp(i,j)
             enddo
          enddo
          write(fileLun,rec=3) tmp
       endif

       if(tile == 1) then
          do j=js, je
             do i=is, ie
                if(i>(npx/2.0)+1 .OR. j>(npy/2.0)+1) cycle
                do n=1,ndims
                   p_lL(n) = grid(i  ,j  ,n)
                   p_uL(n) = grid(i  ,j+1,n)
                   p_lR(n) = grid(i+1,j  ,n)
                   p_uR(n) = grid(i+1,j+1,n)
                enddo
                if ((latlon) .or. (dxdy_area)) then
                   ! DX_*DY_
                   d1 = dx(i  ,j  )
                   d2 = dx(i  ,j+1)
                   mydx = 0.5 * ( d1+d2 )
                   d1 = dy(i  ,j)
                   d2 = dy(i+1,j)
                   mydy = 0.5 * ( d1+d2 )
                   angs(i,j) = (mydx*mydy)
                else
                   ! Spherical Excess Formula
                   angs(i,j) = get_area(p_lL, p_uL, p_lR, p_uR, radius)
                endif
             enddo
          enddo
       else
          angs = 0
       endif
       call mpp_global_field(domain, angs,  g_tmp)
       if( gid==masterproc ) then
          do j = 1,npy/2+1
             do i=1,npx/2+1
                tmp(i,j) = g_tmp(i,j)
             enddo
          enddo
          write(fileLun,rec=4) tmp
          close(unit=fileLun)
          deallocate(tmp ) 
       endif
       deallocate(angs, asps, dxs, g_tmp)
    endif
#ifdef GLOBAL_TRIG
    call mpp_error(FATAL, 'fv_grid_tools(read_grid): when reading from '// &
         trim(grid_file)//', -DGLOBAL_TRIG should not be present when compiling')
#endif

  end subroutine read_grid

  !#################################################################################
  subroutine get_symmetry(data_in, data_out, ishift, jshift)
    integer,                                            intent(in)  :: ishift, jshift
    real, dimension(is:ie+ishift, js:je+jshift ), intent(in)  :: data_in
    real, dimension(is:ie+jshift,js:je+ishift  ), intent(out) :: data_out      
    real,    dimension(:), allocatable :: send_buffer
    real,    dimension(:), allocatable :: recv_buffer
    integer, dimension(:), allocatable :: is_recv, ie_recv, js_recv, je_recv, pe_recv
    integer, dimension(:), allocatable :: is_send, ie_send, js_send, je_send, pe_send
    integer, dimension(:), allocatable :: isl, iel, jsl, jel, pelist, msg1, msg2
    integer                            :: msgsize, pos, ntiles, npes_per_tile, npes
    integer                            :: send_buf_size, recv_buf_size, buffer_pos
    integer                            :: is0, ie0, js0, je0
    integer                            :: is1, ie1, js1, je1
    integer                            :: is2, ie2, js2, je2
    integer                            :: i, j, p, nrecv, nsend, tile_you, is3, ie3, nlist
    integer                            :: start_pe, ipos, jpos, from_pe, to_pe
    
    !--- This routine will be called only for cubic sphere grid. so 6 tiles will be assumed
    !--- also number of processors on each tile will be the same.
    ntiles = mpp_get_ntile_count(domain)
    npes = mpp_npes()

    if(ntiles .NE. 6 ) call mpp_error(FATAL, 'fv_grid_tools(get_symmetry): ntiles should be 6 ')
    if(mod(npes,ntiles) .NE. 0) call mpp_error(FATAL, 'fv_grid_tools(get_symmetry): npes should be divided by ntiles')
    npes_per_tile = npes/ntiles

    if(npes_x == npes_y .AND. mod(npx_g-1,npes_x) == 0 ) then ! even, simple communication
       msgsize = (ie-is+1+jshift)*(je-js+1+ishift)

       pos = mod(mpp_pe(), npes_x*npes_y)
       start_pe = mpp_pe() - pos
       ipos = mod(pos, npes_x)
       jpos = pos/npes_x
       from_pe = start_pe + ipos*npes_x + jpos
       to_pe   = from_pe
       allocate(recv_buffer(msgsize))
       call mpp_recv(recv_buffer(1), glen=msgsize, from_pe=from_pe, block=.FALSE. )

       pos = 0
       allocate(send_buffer(msgsize))
       do j = js, je+jshift
          do i = is, ie+ishift
             pos = pos + 1
             send_buffer(pos) = data_in(i,j)
          enddo
       enddo

       call mpp_send(send_buffer(1), plen=msgsize, to_pe=to_pe)
       call mpp_sync_self(check=EVENT_RECV) ! To ensure recv is completed.

       !--unpack buffer
       pos = 0
       do i = is, ie+jshift
          do j = js, je+ishift
             pos = pos + 1
             data_out(i,j) = recv_buffer(pos)
          enddo
       enddo

       call mpp_sync_self()     
       deallocate(send_buffer, recv_buffer)
    else

       allocate(is_recv(0:npes_per_tile-1), ie_recv(0:npes_per_tile-1))
       allocate(js_recv(0:npes_per_tile-1), je_recv(0:npes_per_tile-1))
       allocate(is_send(0:npes_per_tile-1), ie_send(0:npes_per_tile-1))
       allocate(js_send(0:npes_per_tile-1), je_send(0:npes_per_tile-1))
       allocate(pe_send(0:npes_per_tile-1), pe_recv(0:npes_per_tile-1))
       if(debug_message_size) then
          allocate(msg1   (0:npes_per_tile-1), msg2   (0:npes_per_tile-1))
          msg1 = 0
          msg2 = 0
       endif

       allocate(pelist(0:npes-1))
       call mpp_get_pelist(domain, pelist)
       allocate(isl(0:npes-1), iel(0:npes-1), jsl(0:npes-1), jel(0:npes-1) )
       call mpp_get_compute_domains(domain, xbegin=isl, xend=iel, ybegin=jsl, yend=jel)
       !--- pre-post receiving 
       buffer_pos = 0  
       nrecv = 0
       nsend = 0
       recv_buf_size = 0

       !--- first set up the receiving index
       nlist = 0
       do p = 0, npes-1
          tile_you = p/(npes_x*npes_y) + 1
          if(tile_you .NE. tile) cycle

          !--- my index for data_out after rotation
          is1 = js; ie1 = je + ishift;
          js1 = is; je1 = ie + jshift;
          !--- your index for data_out
          is2 = isl(p); ie2 = iel(p) + ishift;
          js2 = jsl(p); je2 = jel(p) + jshift;
          is0 = max(is1,is2); ie0 = min(ie1,ie2)
          js0 = max(js1,js2); je0 = min(je1,je2)             
          msgsize = 0             
          if(ie0 .GE. is0 .AND. je0 .GE. js0) then
             msgsize = (ie0-is0+1)*(je0-js0+1)
             recv_buf_size = recv_buf_size + msgsize
             pe_recv(nrecv) = pelist(p)
             !--- need to rotate back the index
             is_recv(nrecv) = js0; ie_recv(nrecv) = je0
             js_recv(nrecv) = is0; je_recv(nrecv) = ie0
             nrecv = nrecv+1
          endif
          if(debug_message_size) then
             msg1(nlist) = msgsize
             call mpp_recv(msg2(nlist), glen=1, from_pe=pelist(p), block=.FALSE. )
             nlist = nlist + 1
          endif
       enddo

       !--- Then setup the sending index.
       send_buf_size = 0
       do p = 0, npes-1
          tile_you = p/(npes_x*npes_y) + 1
          if(tile_you .NE. tile) cycle
          !--- my index on data_in
          is1 = is; ie1 = ie + ishift;
          js1 = js; je1 = je + jshift;
          !--- your index on data_out after rotate
          is2 = jsl(p); ie2 = jel(p) + ishift;
          js2 = isl(p); je2 = iel(p) + jshift;
          is0 = max(is1,is2); ie0 = min(ie1,ie2)
          js0 = max(js1,js2); je0 = min(je1,je2)
          msgsize = 0
          if(ie0 .GE. is0 .AND. je0 .GE. js0 )then
             msgsize = (ie0-is0+1)*(je0-js0+1)
             send_buf_size = send_buf_size + msgsize
             pe_send(nsend) = pelist(p)
             is_send(nsend) = is0; ie_send(nsend) = ie0
             js_send(nsend) = js0; je_send(nsend) = je0
             nsend = nsend+1
          endif
          IF(debug_message_size) call mpp_send(msgsize, plen=1, to_pe=pelist(p) )
       enddo

       !--- check to make sure send and recv size match.
       if(debug_message_size) then
          call mpp_sync_self(check=EVENT_RECV) ! To ensure recv is completed.
          do p = 0, nlist-1
             if(msg1(p) .NE. msg2(p)) then
                call mpp_error(FATAL, "fv_grid_tools_mod(get_symmetry): mismatch on send and recv size")
             endif
          enddo
          call mpp_sync_self()
          deallocate(msg1, msg2)
       endif

       !--- pre-post data
       allocate(recv_buffer(recv_buf_size))
       buffer_pos = 0
       do p = 0, nrecv-1
          is0 = is_recv(p); ie0 = ie_recv(p)
          js0 = js_recv(p); je0 = je_recv(p)
          msgsize = (ie0-is0+1)*(je0-js0+1)
          call mpp_recv(recv_buffer(buffer_pos+1), glen=msgsize, from_pe=pe_recv(p), block=.FALSE. )
          buffer_pos = buffer_pos + msgsize       
       enddo

       !--- send the data
       buffer_pos = 0
       allocate(send_buffer(send_buf_size))
       do p = 0, nsend-1
          is0 = is_send(p); ie0 = ie_send(p)
          js0 = js_send(p); je0 = je_send(p)
          msgsize = (ie0-is0+1)*(je0-js0+1)
          pos = buffer_pos
          do j = js0, je0
             do i = is0, ie0
                pos = pos+1
                send_buffer(pos) = data_in(i,j)
             enddo
          enddo
          call mpp_send(send_buffer(buffer_pos+1), plen=msgsize, to_pe=pe_send(p) )
          buffer_pos = buffer_pos + msgsize       
       enddo

       call mpp_sync_self(check=EVENT_RECV) ! To ensure recv is completed.

       !--- unpack buffer
       pos = 0
       do p = 0, nrecv-1
          is0 = is_recv(p); ie0 = ie_recv(p)       
          js0 = js_recv(p); je0 = je_recv(p)

          do i = is0, ie0
             do j = js0, je0
                pos = pos + 1
                data_out(i,j) = recv_buffer(pos)
             enddo
          enddo
       enddo

       call mpp_sync_self()
       deallocate(isl, iel, jsl, jel, pelist)
       deallocate(is_recv, ie_recv, js_recv, je_recv, pe_recv)
       deallocate(is_send, ie_send, js_send, je_send, pe_send)
       deallocate(recv_buffer, send_buffer)
     endif

  end subroutine get_symmetry

  subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, ng)
 
!     init_grid :: read grid from input file and setup grid descriptors
 
!--------------------------------------------------------
    type(fv_atmos_type), intent(inout) :: Atm
    character*80, intent(IN) :: grid_name
    character*120,intent(IN) :: grid_file
    integer,      intent(IN) :: npx, npy, npz
    integer,      intent(IN) :: ndims
    integer,      intent(IN) :: nregions
    integer,      intent(IN) :: ng
!--------------------------------------------------------
    real   ::  xs(npx,npy)
    real   ::  ys(npx,npy)
    real*8 ::  grid_R8(npx,npy)

    real  :: dp, dl
    real  :: x1,x2,y1,y2,z1,z2
    integer :: i,j,k,n,nreg
    integer :: fileLun

    real  :: p_lL(ndims) ! lower Left
    real  :: p_uL(ndims) ! upper Left
    real  :: p_lR(ndims) ! lower Right
    real  :: p_uR(ndims) ! upper Right
    real  :: d1, d2, mydx, mydy, tmp

    real  :: p1(3), p2(3), p3(3), p4(3)
    real  :: dist,dist1,dist2, pa(2), pa1(2), pa2(2), pb(2)
    real  :: pt(3), pt1(3), pt2(3), pt3(3)
    real :: ee1(3), ee2(3)

    real  :: angN,angM,angAV,ang
    real  :: aspN,aspM,aspAV,asp
    real  ::  dxN, dxM, dxAV
    real  :: dx_local, dy_local

    real  :: vec1(3), vec2(3), vec3(3), vec4(3)
    real  :: vecAvg(3), vec3a(3), vec3b(3), vec4a(3), vec4b(3)
    real  :: xyz1(3), xyz2(3)

    real  :: angs(1:(npx/2)+1, 1:(npy/2)+1)
    real  :: asps(1:(npx/2)+1, 1:(npy/2)+1)
    real  ::  dxs(1:(npx/2)+1, 1:(npy/2)+1)
    character*80 :: gcharFile

    real :: grid_global(1-ng:npx  +ng,1-ng:npy  +ng,ndims,1:nregions)
    real ::   dx_global(1:npx-1,1:npy  ,1:nregions)
    real ::   dy_global(1:npx  ,1:npy-1,1:nregions)
#ifdef GLOBAL_TRIG
    real ::      sina_g(1:npx  ,1:npy  ,1:nregions)
    real ::      cosa_g(1:npx  ,1:npy  ,1:nregions)
#endif

    character*80 :: evalue
    integer :: ios, ip, jp
    
    integer :: igrid
    
    integer :: tmplun
    character*80 :: tmpFile   

    npx_g = npx
    npy_g = npy
    npz_g = npz
    ntiles_g = nregions
    latlon = .false.
    cubed_sphere = .false.
    if ( grid_type < 0 ) then
       Gnomonic_grid = .false.
    else
       Gnomonic_grid = .true.
    endif
    
    allocate (  area(isd:ied  ,jsd:jed  ) )   ! Cell Centered
    allocate ( rarea(isd:ied  ,jsd:jed  ) )   ! Cell Centered
    
    allocate (  area_c(isd:ied+1,jsd:jed+1) )  ! Cell Corners
    allocate ( rarea_c(isd:ied+1,jsd:jed+1) )  ! Cell Corners
    
    allocate (  dx(isd:ied  ,jsd:jed+1) )
    allocate ( rdx(isd:ied  ,jsd:jed+1) )
    allocate (  dy(isd:ied+1,jsd:jed  ) )
    allocate ( rdy(isd:ied+1,jsd:jed  ) )
    
    allocate (  dxc(isd:ied+1,jsd:jed  ) )
    allocate ( rdxc(isd:ied+1,jsd:jed  ) )
    allocate (  dyc(isd:ied  ,jsd:jed+1) )
    allocate ( rdyc(isd:ied  ,jsd:jed+1) )
    
    allocate (  dxa(isd:ied  ,jsd:jed  ) )
    allocate ( rdxa(isd:ied  ,jsd:jed  ) )
    allocate (  dya(isd:ied  ,jsd:jed  ) )
    allocate ( rdya(isd:ied  ,jsd:jed  ) )
    
    allocate ( grid (isd:ied+1,jsd:jed+1,1:ndims) )
    allocate ( agrid(isd:ied  ,jsd:jed  ,1:ndims) )
    
    Atm%grid  =>grid
    Atm%agrid =>agrid
    
    allocate ( sina(isd:ied+1,jsd:jed+1) )   ! SIN(angle of intersection)
    allocate ( cosa(isd:ied+1,jsd:jed+1) )   ! COS(angle of intersection)
    
    allocate (   e1(3,isd:ied+1,jsd:jed+1) )
    allocate (   e2(3,isd:ied+1,jsd:jed+1) )
    
    
    if (TRIM(grid_name) == 'Lat-Lon') then
       allocate ( cose(isd:ied,jsd:jed))
       allocate ( cosp(isd:ied,jsd:jed))
       allocate ( acosp(isd:ied,jsd:jed))
    endif
    
!mlh
    allocate (iinta(4, isd:ied ,jsd:jed), jinta(4, isd:ied ,jsd:jed),  &
              iintb(4, is:ie+1 ,js:je+1), jintb(4, is:ie+1 ,js:je+1))
!mlh

    if (grid_type>3) then
       uniform_ppm = .true.
       if (grid_type == 4) then
          double_periodic = .true.
          call setup_cartesian(npx, npy)
       elseif  (grid_type == 5) then
          latlon_patch = .true.
          call setup_latlon()
       elseif  (grid_type == 6) then
          latlon_strip = .true.
          call setup_latlon()
       elseif  (grid_type == 7) then
          channel = .true.
          call setup_cartesian(npx, npy)
       else
          call mpp_error(FATAL, 'init_grid: unknown grid type')
       endif
    else

       if (TRIM(grid_name) == 'Lat-Lon') then

          latlon = .true.
          uniform_ppm = .true.

          dp = pi/(npy-2)
          dl = (pi+pi)/(npx-1)

          do n=1,nregions
             do j=1,npy
                do i=1,npx
                   grid_global(i,j,1,n) = real(i-1)*dl
                   grid_global(i,j,2,n) = (-1.*(pi/2.)) + real(j-1)*dp - dp/2.
                   if (j==1)   grid_global(i,j,2,n) =-1.*(pi/2.)
                   if (j==npy) grid_global(i,j,2,n) = 1.*(pi/2.)
                enddo
             enddo
          enddo
          
       else
          cubed_sphere = .true.
          uniform_ppm = .true.

          if (grid_type>=0) call gnomonic_grids(grid_type, npx-1, xs, ys)

          if (gid == masterproc) then

             if (grid_type>=0) then
                do j=1,npy
                   do i=1,npx
                      grid_global(i,j,1,1) = xs(i,j)
                      grid_global(i,j,2,1) = ys(i,j)
                   enddo
                enddo
! mirror_grid assumes that the tile=1 is centered on equator and greenwich meridian Lon[-pi,pi] 
                call mirror_grid(grid_global, ng, npx, npy, 2, 6)
                do n=1,nregions
                   do j=1,npy
                      do i=1,npx
!---------------------------------
! Shift the corner away from Japan
!---------------------------------
#ifndef SW_DYNAMICS
! This will result in the corner close to east coast of China
#ifndef NO_SHIFT

                         grid_global(i,j,1,n) = grid_global(i,j,1,n) - pi/18.
#endif
#endif
                         if ( grid_global(i,j,1,n) < 0. )              &
                              grid_global(i,j,1,n) = grid_global(i,j,1,n) + 2.*pi
                         if (ABS(grid_global(i,j,1,1)) < 1.e-10) grid_global(i,j,1,1) = 0.0
                         if (ABS(grid_global(i,j,2,1)) < 1.e-10) grid_global(i,j,2,1) = 0.0
                      enddo
                   enddo
                enddo
             else
                print*, 'Reading Grid from file: ', trim(grid_file)
                fileLun=get_unit()
                open(unit=fileLun,file=grid_file, form='unformatted', access='sequential')
                do n=1,nregions
                   do k=1,ndims
                      read(unit=fileLun) grid_R8(1:npx,1:npy)
                      do j=1,npy
                         do i=1,npx
                            grid_global(i,j,k,n) = grid_R8(i,j)
                            if (ABS(grid_global(i,j,k,n)) < 1.e-10) grid_global(i,j,k,n) = 0.0
                         enddo
                      enddo
                   enddo
                enddo
                close(unit=fileLun)
             endif

             grid_global(  1,1:npy,:,2)=grid_global(npx,1:npy,:,1)
             grid_global(  1,1:npy,:,3)=grid_global(npx:1:-1,npy,:,1)
             grid_global(1:npx,npy,:,5)=grid_global(1,npy:1:-1,:,1)
             grid_global(1:npx,npy,:,6)=grid_global(1:npx,1,:,1)
             
             grid_global(1:npx,  1,:,3)=grid_global(1:npx,npy,:,2)
             grid_global(1:npx,  1,:,4)=grid_global(npx,npy:1:-1,:,2)
             grid_global(npx,1:npy,:,6)=grid_global(npx:1:-1,1,:,2)
             
             grid_global(  1,1:npy,:,4)=grid_global(npx,1:npy,:,3)
             grid_global(  1,1:npy,:,5)=grid_global(npx:1:-1,npy,:,3)
             
             grid_global(npx,1:npy,:,3)=grid_global(1,1:npy,:,4)
             grid_global(1:npx,  1,:,5)=grid_global(1:npx,npy,:,4)
             grid_global(1:npx,  1,:,6)=grid_global(npx,npy:1:-1,:,4)
             
             grid_global(  1,1:npy,:,6)=grid_global(npx,1:npy,:,5)

! Compute dx:
             do n=1,nregions
                do j=1,npy
                   do i=1,npx-1
                      p1(1) = grid_global(i  ,j,1,n)
                      p1(2) = grid_global(i  ,j,2,n)
                      p2(1) = grid_global(i+1,j,1,n)
                      p2(2) = grid_global(i+1,j,2,n)
                      dx_global(i,j,n) = great_circle_dist( p2, p1, radius )
                   enddo
                enddo
             enddo
             
             dx_global(1:npx-1,  1,1) = dx_global(1:npx-1,npy,6)
             dx_global(1:npx-1,npy,2) = dx_global(1:npx-1,1,  3)
             dx_global(1:npx-1,npy,4) = dx_global(1:npx-1,1,  5)

! Compute dy:
             do n=1,nregions
                do j=1,npy
                   do i=1,npx-1
! Symmetry is assumed here:
                      dy_global(j,i,n) = dx_global(i,j,n)
                   enddo
                enddo
             enddo
             
             dy_global(  1,1:npy-1,1)=dx_global(npx-1:1:-1,npy,5)
             dy_global(npx,1:npy-1,1)=dy_global(1,1:npy-1,2)
             
             dy_global(npx,1:npy-1,2)=dx_global(npx-1:1:-1,1,4)
             
             dy_global(  1,1:npy-1,3)=dx_global(npx-1:1:-1,npy,1)
             dy_global(npx,1:npy-1,3)=dy_global(1,1:npy-1,4)
             
             dy_global(  1,1:npy-1,4)=dy_global(npx,1:npy-1,3)
             dy_global(npx,1:npy-1,4)=dx_global(npx-1:1:-1,1,6)
             
             dy_global(  1,1:npy-1,5)=dx_global(npx-1:1:-1,npy,3)
             dy_global(npx,1:npy-1,5)=dy_global(1,1:npy-1,6)
             
             dy_global(npx,1:npy-1,6)=dx_global(npx-1:1:-1,1,2)
             
          endif ! masterproc
          
       endif  ! (latlon vs cubed_sphere)
      
       call mp_bcst(grid_global, (npx+ng)-(1-ng)+1, (npy+ng)-(1-ng)+1, ndims, nregions )
       call mp_bcst(  dx_global, npx-1, npy  , nregions )
       call mp_bcst(  dy_global, npx  , npy-1, nregions )

       grid(isd: is-1, jsd:js-1,1:ndims)=0.
       grid(isd: is-1, je+2:jed+1,1:ndims)=0.
       grid(ie+2:ied+1,jsd:js-1,1:ndims)=0.
       grid(ie+2:ied+1,je+2:jed+1,1:ndims)=0.
       
       do n=1,ndims
          do j=js,je+1
             do i=is,ie+1
                grid(i,j,n) = grid_global(i,j,n,tile)
             enddo
          enddo
       enddo
       
       call mpp_update_domains( grid, domain, position=CORNER)

!mlh
       call sorted_inta(isd, ied, jsd, jed, cubed_sphere, grid, iinta, jinta)
!mlh

       agrid(:,:,:) = -1.e25
 
       do j=js,je
          do i=is,ie
             if (latlon) then
                x1=grid(i  ,j  ,1)*todeg
                x2=grid(i+1,j  ,1)*todeg
                if ((x2-x1).gt.180) x2=x2-360
                if ((x1-x2).gt.180) x2=x2+360
                agrid(i,j,1) = torad*(x1 + (x2-x1)/2.)
                
                y1=grid(i  ,j  ,2)*todeg
                y2=grid(i  ,j+1,2)*todeg
                agrid(i,j,2) = torad*(y1 + (y2-y1)/2.)
             else
#ifndef SIMP_GRID
                call cell_center2(grid(iinta(1,i,j),jinta(1,i,j),1:2),  &
                                  grid(iinta(2,i,j),jinta(2,i,j),1:2),  &
                                  grid(iinta(3,i,j),jinta(3,i,j),1:2),  &
                                  grid(iinta(4,i,j),jinta(4,i,j),1:2),  &
                                  agrid(i,j,1:2) )
#else
                call cell_center2(grid(i,j,  1:2), grid(i+1,j,  1:2),   &
                                  grid(i,j+1,1:2), grid(i+1,j+1,1:2),   &
                                  agrid(i,j,1:2) )
#endif
             endif
          enddo
       enddo

       call mpp_update_domains( agrid, domain, position=CENTER, complete=.true. )
       call fill_corners(agrid(:,:,1), npx, npy, XDir, AGRID=.true.)
       call fill_corners(agrid(:,:,2), npx, npy, YDir, AGRID=.true.)
!mlh
       call sorted_intb(isd, ied, jsd, jed, is, ie, js, je, npx, npy, &
                        cubed_sphere, agrid, iintb, jintb)
!mlh

       if (latlon) then

          DL = 2.*PI/float(npx-1)
          DP = PI/float(npy-1)

          do j=js,je
             do i=is,ie+1
                dxc(i,j) = DL*radius*COS(agrid(i,j,2))
             enddo
          enddo
          do j=js,je+1
             do i=is,ie
                dyc(i,j) = DP*radius
             enddo
          enddo

          do j=js,je
             do i=is,ie
                dxa(i,j) = DL*radius*COS(agrid(i,j,2))
                dya(i,j) = DP*radius
             enddo
          enddo
          
          do j=jsd,jed+1
             do i=isd,ied
                dx(i,j) = DL*radius*COS(grid(i,j,2))
             enddo
          enddo
          do j=jsd,jed
             do i=isd,ied+1
                dy(i,j) = DP*radius
             enddo
          enddo

       else
            
          do j=js,je+1
             do i=is,ie
                dx(i,j) = dx_global(i,j,tile)
             enddo
          enddo
          do j=js,je
             do i=is,ie+1
                dy(i,j) = dy_global(i,j,tile)
             enddo
          enddo
          
       endif  ! latlon -v- cubed_sphere

       call mpp_update_domains( dy, dx, domain, flags=SCALAR_PAIR,      &
                                gridtype=CGRID_NE_PARAM, complete=.true.)
       if (cubed_sphere) call fill_corners(dx, dy, npx, npy, DGRID=.true.)

       do j=jsd,jed
          do i=isd,ied
!        do j=js,je
!           do i=is,ie
             call mid_pt_sphere(grid(i,  j,1:2), grid(i,  j+1,1:2), p1)
             call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
             dxa(i,j) = great_circle_dist( p2, p1, radius )
!
             call mid_pt_sphere(grid(i,j  ,1:2), grid(i+1,j  ,1:2), p1)
             call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
             dya(i,j) = great_circle_dist( p2, p1, radius )
          enddo
       enddo
!      call mpp_update_domains( dxa, dya, domain, flags=SCALAR_PAIR, gridtype=AGRID_PARAM)
       if (cubed_sphere) call fill_corners(dxa, dya, npx, npy, AGRID=.true.)

       do j=js,je
          do i=is,ie+1
             p1(1) = agrid(i-1,j,1)
             p1(2) = agrid(i-1,j,2)
             p2(1) = agrid(i  ,j,1)
             p2(2) = agrid(i  ,j,2)
             dxc(i,j) = great_circle_dist( p2, p1, radius )
          enddo
       enddo
       do j=js,je+1
          do i=is,ie
             p1(1) = agrid(i,j-1,1)
             p1(2) = agrid(i,j-1,2)
             p2(1) = agrid(i,j  ,1)
             p2(2) = agrid(i,j  ,2)
             dyc(i,j) = great_circle_dist( p2, p1, radius )
          enddo
       enddo
       if (gid == masterproc) then
          if (nregions > 1) then
!             print*, 'Resolution in Lon-Direction: ', 360./( (npx*4.)-3. )
!             print*, 'Resolution in Lat-Direction: ', 360./( (npy*4.)-3. )
          else
             print*, 'Resolution in Lon-Direction: ', 360./(npx-1.)
             print*, 'Resolution in Lat-Direction: ', 180./(npy-1.)
          endif
       endif

       call grid_area( npx, npy, ndims, nregions )

#ifndef ORIG_AREA_C
! Compute area_c, rarea_c, dxc, dyc
       if ( is==1 ) then
          i = 1
          do j=js,je+1
             call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,  1:2), p1)
             call mid_pt_sphere(grid(i,j  ,1:2), grid(i,j+1,1:2), p4)
             p2(1:2) = agrid(i,j-1,1:2)
             p3(1:2) = agrid(i,j,  1:2)
             area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
          enddo
          do j=js,je
             call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
             p2(1:2) = agrid(i,j,1:2)
             dxc(i,j) = 2.*great_circle_dist( p1, p2, radius )
          enddo
       endif
       if ( (ie+1)==npx ) then
          i = npx
          do j=js,je+1
             p1(1:2) = agrid(i-1,j-1,1:2)
             call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,  1:2), p2)
             call mid_pt_sphere(grid(i,j  ,1:2), grid(i,j+1,1:2), p3)
             p4(1:2) = agrid(i-1,j,1:2)
             area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
          enddo
          do j=js,je
             p1(1:2) = agrid(i-1,j,1:2)
             call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
             dxc(i,j) = 2.*great_circle_dist( p1, p2, radius )
          enddo
       endif
       if ( js==1 ) then
          j = 1
          do i=is,ie+1
             call mid_pt_sphere(grid(i-1,j,1:2), grid(i,  j,1:2), p1)
             call mid_pt_sphere(grid(i,  j,1:2), grid(i+1,j,1:2), p2)
             p3(1:2) = agrid(i,  j,1:2)
             p4(1:2) = agrid(i-1,j,1:2)
             area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
          enddo
          do i=is,ie
             call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
             p2(1:2) = agrid(i,j,1:2)
             dyc(i,j) = 2.*great_circle_dist( p1, p2, radius )
          enddo
       endif
       if ( (je+1)==npy ) then
          j = npy
          do i=is,ie+1
             p1(1:2) = agrid(i-1,j-1,1:2)
             p2(1:2) = agrid(i  ,j-1,1:2)
             call mid_pt_sphere(grid(i,  j,1:2), grid(i+1,j,1:2), p3)
             call mid_pt_sphere(grid(i-1,j,1:2), grid(i,  j,1:2), p4)
             area_c(i,j) = 2.*get_area(p1, p4, p2, p3, radius)
          enddo
          do i=is,ie
             p1(1:2) = agrid(i,j-1,1:2)
             call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
             dyc(i,j) = 2.*great_circle_dist( p1, p2, radius )
          enddo
       endif
       if ( sw_corner ) then
             i=1; j=1
             p1(1:2) = grid(i,j,1:2)
             call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
             p3(1:2) = agrid(i,j,1:2)
             call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p4)
             area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
       endif
       if ( se_corner ) then
             i=npx; j=1
             call mid_pt_sphere(grid(i-1,j,1:2), grid(i,j,1:2), p1)
             p2(1:2) = grid(i,j,1:2)
             call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p3)
             p4(1:2) = agrid(i,j,1:2)
             area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
       endif
       if ( ne_corner ) then
             i=npx; j=npy
             p1(1:2) = agrid(i-1,j-1,1:2)
             call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,1:2), p2)
             p3(1:2) = grid(i,j,1:2)
             call mid_pt_sphere(grid(i-1,j,1:2), grid(i,j,1:2), p4)
             area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
       endif
       if ( nw_corner ) then
             i=1; j=npy
             call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,1:2), p1)
             p2(1:2) = agrid(i,j-1,1:2)
             call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p3)
             p4(1:2) = grid(i,j,1:2)
             area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
       endif
#endif
       call mpp_update_domains( dxc, dyc, domain, flags=SCALAR_PAIR,   &
                                gridtype=CGRID_NE_PARAM, complete=.true.)
       if (cubed_sphere) call fill_corners(dxc, dyc, npx, npy, CGRID=.true.)
       
       call mpp_update_domains( area,   domain, complete=.true. )
       call mpp_update_domains( area_c, domain, position=CORNER, complete=.true.)
       
       ! Handle corner Area ghosting
       if (cubed_sphere) then
          call fill_ghost(area, npx, npy, -1.E35)  ! fill in garbage values
          call fill_corners(area_c, npx, npy, FILL=XDir, BGRID=.true.)
       endif
       
       do j=jsd,jed+1
          do i=isd,ied
             rdx(i,j) = 1.0/dx(i,j)
          enddo
       enddo
       do j=jsd,jed
          do i=isd,ied+1
             rdy(i,j) = 1.0/dy(i,j)
          enddo
       enddo
       do j=jsd,jed
          do i=isd,ied+1
             rdxc(i,j) = 1.0/dxc(i,j)
          enddo
       enddo
       do j=jsd,jed+1
          do i=isd,ied
             rdyc(i,j) = 1.0/dyc(i,j)
          enddo
       enddo
       do j=jsd,jed
          do i=isd,ied
             rarea(i,j) = 1.0/area(i,j)
             rdxa(i,j) = 1./dxa(i,j)
             rdya(i,j) = 1./dya(i,j)
          enddo
       enddo
       do j=jsd,jed+1
          do i=isd,ied+1
             rarea_c(i,j) = 1.0/area_c(i,j)
          enddo
       enddo

200    format(A,f9.2,A,f9.2,A,f9.2)
201    format(A,f9.2,A,f9.2,A,f9.2,A,f9.2)
202    format(A,A,i4.4,A,i4.4,A)
       
! Get and print Grid Statistics
       if ((gid==masterproc) .and. (cubed_sphere)) then
          dxAV =0.0
          angAV=0.0
          aspAV=0.0
          dxN  =  missing
          dxM  = -missing
          angN =  missing
          angM = -missing
          aspN =  missing
          aspM = -missing
          angs(1,1) = get_angle(2, grid_global(1,2,1:2,1), grid_global(1,1,1:2,1), grid_global(2,1,1:2,1))
          angs(1,1) = ABS(90.0 - angs(1,1))
          do j=1,ceiling(npy/2.)
             do i=1,ceiling(npx/2.)
                ang  = get_angle(2, grid_global(i,j+1,1:2,1), grid_global(i,j,1:2,1), grid_global(i+1,j,1:2,1))
                ang  = ABS(90.0 - ang)
                angs(i,j) = ang

                if ( (i==1) .and. (j==1) ) then
                else 
                   angAV = angAV + ang
                   angM  = MAX(angM,ang)
                   angN  = MIN(angN,ang)
                endif

                dx_local = dx_global(i,j,1)
                dy_local = dy_global(i,j,1)

                dxAV  = dxAV + 0.5 * (dx_local + dy_local)
                dxM   = MAX(dxM,dx_local)
                dxM   = MAX(dxM,dy_local)
                dxN   = MIN(dxN,dx_local)
                dxN   = MIN(dxN,dy_local)
                dxs(i,j) = dy_local !0.5 * (dx_local + dy_local)

                asp   = ABS(dx_local/dy_local)
                if (asp < 1.0) asp = 1.0/asp
                asps(i,j) = asp 
                aspAV = aspAV + asp
                aspM  = MAX(aspM,asp)
                aspN  = MIN(aspN,asp)
             enddo
          enddo
          angAV = angAV / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) - 1 )
          dxAV  = dxAV  / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) )
          aspAV = aspAV / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) )
          write(*,*  ) ''
          write(*,*  ) ' Cubed-Sphere Grid Stats : ', npx,'x',npy,'x',nregions
          write(*,201) '      Grid Length               : min: ', dxN,' max: ', dxM,' avg: ', dxAV, ' min/max: ',dxN/dxM
          write(*,200) '      Deviation from Orthogonal : min: ',angN,' max: ',angM,' avg: ',angAV
          write(*,200) '      Aspect Ratio              : min: ',aspN,' max: ',aspM,' avg: ',aspAV
          write(*,*  ) ''
          write(gcharFile,202) TRIM(grid_name),'_chars_',npx,'x',npy,'.dat'
          fileLun=get_unit()
          open(unit=fileLun,file=gcharFile, form='unformatted', access='direct',  &
               recl=((npx/2)+1)*((npy/2)+1)*8, status='unknown')
          write(fileLun,rec=1) angs
          write(fileLun,rec=2) asps
          write(fileLun,rec=3)  dxs
          do j=1,(npy/2.0)+1
             do i=1,(npx/2.0)+1
                do n=1,ndims
                   p_lL(n) = grid_global(i  ,j  ,n,1)
                   p_uL(n) = grid_global(i  ,j+1,n,1)
                   p_lR(n) = grid_global(i+1,j  ,n,1)
                   p_uR(n) = grid_global(i+1,j+1,n,1)
                enddo
                if ((latlon) .or. (dxdy_area)) then
                   ! DX_*DY_
                   d1 = dx_global(i  ,j  ,1)
                   d2 = dx_global(i  ,j+1,1)
                   mydx = 0.5 * ( d1+d2 )
                   d1 = dy_global(i  ,j  ,1)
                   d2 = dy_global(i+1,j  ,1)
                   mydy = 0.5 * ( d1+d2 )
                   angs(i,j) = (mydx*mydy)
                else
                   ! Spherical Excess Formula
                   angs(i,j) = get_area(p_lL, p_uL, p_lR, p_uR, radius)
                endif
             enddo
          enddo
          write(fileLun,rec=4) angs
          close(unit=fileLun)

#ifdef GLOBAL_TRIG
!----------------------------------------------------
! Initialize sina and cosa forcing an 8-fold symmetry
!----------------------------------------------------
          do j=1,ceiling(npy/2.)
             do i=1,ceiling(npx/2.)

                if (i==1) then
                   call get_unit_vector(grid_global(i,j,1:2,1), grid_global(i+1,j,1:2,1), ee1)
                elseif (i==npx) then
                   call get_unit_vector(grid_global(i-1,j,1:2,1), grid_global(i,j,1:2,1), ee1)
                else
                   call get_unit_vector(grid_global(i-1,j,1:2,1), grid_global(i,j,1:2,1), grid_global(i+1,j,1:2,1), ee1)
                endif
                
                if (j==1) then
                   call get_unit_vector(grid_global(i,j,1:2,1), grid_global(i,j+1,1:2,1), ee2)
                elseif (j==npy) then
                   call get_unit_vector(grid_global(i,j-1,1:2,1), grid_global(i,j,1:2,1), ee2)
                else
                   call get_unit_vector(grid_global(i,j-1,1:2,1), grid_global(i,j,1:2,1), grid_global(i,j+1,1:2,1), ee2)
                endif

                if (j<=i) then  ! force 8-fold symmetry
                   tmp = inner_prod(ee1,ee2)
                   cosa_g(i ,j,:) = tmp
                   cosa_g(j ,i,:) = tmp
                   tmp = sqrt ( 1. - tmp**2 )
                   sina_g(i ,j,:) = tmp
                   sina_g(j ,i,:) = tmp
                endif
             enddo
          enddo

! force remainder of symmetry
          do j=1,ceiling(npy/2.)
             do i=1,ceiling(npx/2.)
                sina_g(npx-(i-1),j        ,:) = sina_g(i        ,j        ,:)
                sina_g(i        ,npy-(j-1),:) = sina_g(i        ,j        ,:)
                sina_g(npx-(i-1),npy-(j-1),:) = sina_g(i        ,j        ,:)
                cosa_g(npx-(i-1),j        ,:) = cosa_g(i        ,j        ,:)
                cosa_g(i        ,npy-(j-1),:) = cosa_g(i        ,j        ,:)
                cosa_g(npx-(i-1),npy-(j-1),:) = cosa_g(i        ,j        ,:)
             enddo
          enddo
          
          do n=nregions,1,-1
             do j=1,npy
                do i=1,npy
                   if (i==1) then
                      call get_unit_vector(grid_global(i,j,1:2,1), grid_global(i+1,j,1:2,1), ee1)
                   elseif (i==npx) then
                      call get_unit_vector(grid_global(i-1,j,1:2,1), grid_global(i,j,1:2,1), ee1)
                   else
                      call get_unit_vector(grid_global(i-1,j,1:2,1), grid_global(i,j,1:2,1), grid_global(i+1,j,1:2,1), ee1)
                   endif
                   if (j==1) then
                      call get_unit_vector(grid_global(i,j,1:2,1), grid_global(i,j+1,1:2,1), ee2)
                   elseif (j==npy) then
                      call get_unit_vector(grid_global(i,j-1,1:2,1), grid_global(i,j,1:2,1), ee2)
                   else
                      call get_unit_vector(grid_global(i,j-1,1:2,1), grid_global(i,j,1:2,1), grid_global(i,j+1,1:2,1), ee2)
                   endif
                   ! Ensure correct sign for cosa
                   cosa_g(i,j,n) = SIGN(cosa_g(i,j,1), inner_prod(ee1,ee2))
                enddo
             enddo
          enddo
         
          sina_g(  1,1:npy,2)=sina_g(npx,1:npy,1)
          sina_g(  1,1:npy,3)=sina_g(npx:1:-1,npy,1)
          sina_g(1:npx,npy,5)=sina_g(1,npy:1:-1,1)
          sina_g(1:npx,npy,6)=sina_g(1:npx,1,1)
          
          sina_g(1:npx,  1,3)=sina_g(1:npx,npy,2)
          sina_g(1:npx,  1,4)=sina_g(npx,npy:1:-1,2)
          sina_g(npx,1:npy,6)=sina_g(npx:1:-1,1,2)
          
          sina_g(  1,1:npy,4)=sina_g(npx,1:npy,3)
          sina_g(  1,1:npy,5)=sina_g(npx:1:-1,npy,3)
          
          sina_g(npx,1:npy,3)=sina_g(1,1:npy,4)
          sina_g(1:npx,  1,5)=sina_g(1:npx,npy,4)
          sina_g(1:npx,  1,6)=sina_g(npx,npy:1:-1,4)
          
          sina_g(  1,1:npy,6)=sina_g(npx,1:npy,5)
          
          
          cosa_g(  1,1:npy,2)=cosa_g(npx,1:npy,1)
          cosa_g(  1,1:npy,3)=cosa_g(npx:1:-1,npy,1)
          cosa_g(1:npx,npy,5)=cosa_g(1,npy:1:-1,1)
          cosa_g(1:npx,npy,6)=cosa_g(1:npx,1,1)
          
          cosa_g(1:npx,  1,3)=cosa_g(1:npx,npy,2)
          cosa_g(1:npx,  1,4)=cosa_g(npx,npy:1:-1,2)
          cosa_g(npx,1:npy,6)=cosa_g(npx:1:-1,1,2)
          
          cosa_g(  1,1:npy,4)=cosa_g(npx,1:npy,3)
          cosa_g(  1,1:npy,5)=cosa_g(npx:1:-1,npy,3)
          
          cosa_g(npx,1:npy,3)=cosa_g(1,1:npy,4)
          cosa_g(1:npx,  1,5)=cosa_g(1:npx,npy,4)
          cosa_g(1:npx,  1,6)=cosa_g(npx,npy:1:-1,4)
          
          cosa_g(  1,1:npy,6)=cosa_g(npx,1:npy,5)
       endif                  ! end master
       
       call mp_bcst(sina_g, npx, npy, nregions)
       call mp_bcst(cosa_g, npx, npy, nregions)

       do j=js,je+1
          do i=is,ie+1
             sina(i,j) = sina_g(i,j,1)
             cosa(i,j) = cosa_g(i,j,tile)
          enddo
       enddo
!      call mpp_update_domains( sina, domain, position=CORNER, complete=.true. )
!      call mpp_update_domains( cosa, domain, position=CORNER, complete=.true. )
#else
       endif
#endif
    endif

  contains

    subroutine setup_cartesian(npx, npy)
       integer, intent(in):: npx, npy
       real lat_rad, lon_rad, domain_rad
       integer i,j

       domain_rad = pi/16.   ! arbitrary
       lat_rad = deglat * pi/180.
       lon_rad = 0.          ! arbitrary

       dx(:,:)  = dx_const
       rdx(:,:) = 1./dx_const
       dy(:,:)  = dy_const
       rdy(:,:) = 1./dy_const
       
       dxc(:,:)  = dx_const
       rdxc(:,:) = 1./dx_const
       dyc(:,:)  = dy_const
       rdyc(:,:) = 1./dy_const
       
       dxa(:,:)  = dx_const
       rdxa(:,:) = 1./dx_const
       dya(:,:)  = dy_const
       rdya(:,:) = 1./dy_const
       
       area(:,:)  = dx_const*dy_const
       rarea(:,:) = 1./(dx_const*dy_const)
       
       area_c(:,:)  = dx_const*dy_const
       rarea_c(:,:) = 1./(dx_const*dy_const)
       
! The following is a hack to get pass the am2 phys init:
       do j=max(1,jsd),min(jed,npy)
          do i=max(1,isd),min(ied,npx)
             grid(i,j,1) = lon_rad - 0.5*domain_rad + real(i-1)/real(npx-1)*domain_rad
             grid(i,j,2) = lat_rad - 0.5*domain_rad + real(j-1)/real(npy-1)*domain_rad
          enddo
       enddo

       agrid(:,:,1)  = lon_rad
       agrid(:,:,2)  = lat_rad
       
       sina(:,:) = 1.
       cosa(:,:) = 0.

       e1(1,:,:) = 1.
       e1(2,:,:) = 0.
       e1(3,:,:) = 0.

       e2(1,:,:) = 0.
       e2(2,:,:) = 1.
       e2(3,:,:) = 0.

    end subroutine setup_cartesian


    subroutine setup_latlon()
      real, parameter :: big_number = 1.e30
      real :: lon_start, lat_start, area_j

      dl = (deglon_stop-deglon_start)*pi/(180.*(npx-1))
      dp = (deglat_stop-deglat_start)*pi/(180.*(npy-1))

      lon_start = deglon_start*pi/180.
      lat_start = deglat_start*pi/180.
      
      do j=jsd,jed+1
         do i=isd,ied+1
            grid(i,j,1) = lon_start + real(i-1)*dl
            grid(i,j,2) = lat_start + real(j-1)*dp
         enddo
      enddo

      do j=jsd,jed
         do i=isd,ied
            agrid(i,j,1) = (grid(i,j,1) + grid(i+1,j,1))/2.
            agrid(i,j,2) = (grid(i,j,2) + grid(i,j+1,2))/2.
         enddo
      enddo


      do j=jsd,jed
         do i=isd,ied+1
            dxc(i,j) = dl*radius*cos(agrid(is,j,2))
            rdxc(i,j) = 1./dxc(i,j)
         enddo
      enddo
      do j=jsd,jed+1
         do i=isd,ied
            dyc(i,j) = dp*radius
            rdyc(i,j) = 1./dyc(i,j)
         enddo
      enddo

      do j=jsd,jed
         do i=isd,ied
            dxa(i,j) = dl*radius*cos(agrid(i,j,2))
            dya(i,j) = dp*radius
            rdxa(i,j) = 1./dxa(i,j)
            rdya(i,j) = 1./dya(i,j)
         enddo
      enddo
          
      do j=jsd,jed+1
         do i=isd,ied
            dx(i,j) = dl*radius*cos(grid(i,j,2))
            rdx(i,j) = 1./dx(i,j)
         enddo
      enddo
      do j=jsd,jed
         do i=isd,ied+1
            dy(i,j) = dp*radius
            rdy(i,j) = 1./dy(i,j)
         enddo
      enddo

      do j=jsd,jed
         area_j = radius*radius*dl*(sin(grid(is,j+1,2))-sin(grid(is,j,2)))
         do i=isd,ied
            area(i,j) = area_j
            rarea(i,j) = 1./area_j
         enddo
      enddo

      do j=jsd+1,jed
         area_j = radius*radius*dl*(sin(agrid(is,j,2))-sin(agrid(is,j-1,2)))
         do i=isd,ied+1
            area_c(i,j) = area_j
            rarea_c(i,j) = 1./area_j
         enddo
      enddo
      if (jsd==1) then
         j=1
         area_j = radius*radius*dl*(sin(agrid(is,j,2))-sin(agrid(is,j,2)-dp))
         do i=isd,ied+1
            area_c(i,j) = area_j
            rarea_c(i,j) = 1./area_j
         enddo
      endif
      if (jed+1==npy) then
         j=npy
         area_j = radius*radius*dl*(sin(agrid(is,j-1,2)+dp)-sin(agrid(is,j-1,2)))
         do i=isd,ied+1
            area_c(i,j) = area_j
            rarea_c(i,j) = 1./area_j
         enddo
      endif
      call mpp_update_domains( area_c, domain, position=CORNER, complete=.true.)

      sina(:,:) = 1.
      cosa(:,:) = 0.
      
      e1(1,:,:) = 1.
      e1(2,:,:) = 0.
      e1(3,:,:) = 0.
      
      e2(1,:,:) = 0.
      e2(2,:,:) = 1.
      e2(3,:,:) = 0.

    end subroutine setup_latlon
  
   end subroutine init_grid


      subroutine cartesian_to_spherical(x, y, z, lon, lat, r) 
      real , intent(IN)  :: x, y, z
      real , intent(OUT) :: lon, lat, r

      r = SQRT(x*x + y*y + z*z)
      if ( (abs(x) + abs(y)) < 1.E-10 ) then       ! poles:
           lon = 0.
      else
           lon = ATAN2(y,x)    ! range: [-pi,pi]
      endif 

#ifdef RIGHT_HAND
      lat = asin(z/r)
#else
      lat = ACOS(z/r) - pi/2.
#endif

      end subroutine cartesian_to_spherical
 

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     spherical_to_cartesian :: convert from spheircal coordinates to xyz coords
! 
      subroutine spherical_to_cartesian(lon, lat, r, x, y, z)

         real , intent(IN)  :: lon, lat, r
         real , intent(OUT) :: x, y, z

         x = r * COS(lon) * cos(lat)
         y = r * SIN(lon) * cos(lat)

#ifdef RIGHT_HAND
         z =  r * SIN(lat)
#else
         z = -r * sin(lat)
#endif

      end subroutine spherical_to_cartesian



!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     rot_3d :: rotate points on a sphere in xyz coords (convert angle from
!               degrees to radians if necessary)
!
      subroutine rot_3d(axis, x1in, y1in, z1in, angle, x2out, y2out, z2out, degrees, convert)

         integer, intent(IN) :: axis         ! axis of rotation 1=x, 2=y, 3=z
         real , intent(IN)    :: x1in, y1in, z1in
         real , intent(INOUT) :: angle        ! angle to rotate in radians
         real , intent(OUT)   :: x2out, y2out, z2out
         integer, intent(IN), optional :: degrees ! if present convert angle 
                                                  ! from degrees to radians
         integer, intent(IN), optional :: convert ! if present convert input point
                                                  ! from spherical to cartesian, rotate, 
                                                  ! and convert back

         real  :: c, s
         real  :: x1,y1,z1, x2,y2,z2

         if ( present(convert) ) then
           call spherical_to_cartesian(x1in, y1in, z1in, x1, y1, z1)
         else
           x1=x1in
           y1=y1in
           z1=z1in
         endif

         if ( present(degrees) ) then
            angle = angle*torad
         endif

         c = COS(angle)
         s = SIN(angle)

         SELECT CASE(axis)
             
            CASE(1)
               x2 =  x1
               y2 =  c*y1 + s*z1
               z2 = -s*y1 + c*z1
            CASE(2)
               x2 = c*x1 - s*z1
               y2 = y1
               z2 = s*x1 + c*z1
            CASE(3)
               x2 =  c*x1 + s*y1
               y2 = -s*x1 + c*y1
               z2 = z1
            CASE DEFAULT
              write(*,*) "Invalid axis: must be 1 for X, 2 for Y, 3 for Z."
 
         END SELECT

         if ( present(convert) ) then
           call cartesian_to_spherical(x2, y2, z2, x2out, y2out, z2out)
         else
           x2out=x2
           y2out=y2
           z2out=z2
         endif

      end subroutine rot_3d





      real  function get_area_tri(ndims, p_1, p_2, p_3) &
                        result (myarea)
 
!     get_area_tri :: get the surface area of a cell defined as a triangle
!                  on the sphere. Area is computed as the spherical excess
!                  [area units are based on the units of radius]
 

      integer, intent(IN)    :: ndims          ! 2=lat/lon, 3=xyz
      real , intent(IN)    :: p_1(ndims) ! 
      real , intent(IN)    :: p_2(ndims) ! 
      real , intent(IN)    :: p_3(ndims) ! 

      real  :: angA, angB, angC

        if ( ndims==3 ) then
            angA = spherical_angle(p_1, p_2, p_3)
            angB = spherical_angle(p_2, p_3, p_1)
            angC = spherical_angle(p_3, p_1, p_2)
        else
            angA = get_angle(ndims, p_1, p_2, p_3, 1)
            angB = get_angle(ndims, p_2, p_3, p_1, 1)
            angC = get_angle(ndims, p_3, p_1, p_2, 1)
        endif

        myarea = (angA+angB+angC - pi) * radius**2

      end function get_area_tri
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     grid_area :: get surface area on grid in lat/lon coords or xyz coords
!                    (determined by ndims argument 2=lat/lon, 3=xyz)
!                    [area is returned in m^2 on Unit sphere]
!
      subroutine grid_area(nx, ny, ndims, nregions)

         integer, intent(IN) :: nx, ny, ndims, nregions

         real  :: p_lL(ndims) ! lower Left
         real  :: p_uL(ndims) ! upper Left
         real  :: p_lR(ndims) ! lower Right
         real  :: p_uR(ndims) ! upper Right
         real  :: a1, d1, d2, mydx, mydy

         real  :: p1(ndims), p2(ndims), p3(ndims), pi1(ndims), pi2(ndims)

         real  :: maxarea, minarea

         integer :: i,j,n, nreg

         real, allocatable :: p_R8(:,:,:) 

         maxarea = -1.e25
         minarea =  1.e25

         globalarea = 0.0
         do j=js,je
            do i=is,ie
               do n=1,ndims
                  p_lL(n) = grid(iinta(1,i,j), jinta(1,i,j), n)
                  p_uL(n) = grid(iinta(2,i,j), jinta(2,i,j), n)
                  p_lR(n) = grid(iinta(4,i,j), jinta(4,i,j), n)
                  p_uR(n) = grid(iinta(3,i,j), jinta(3,i,j), n)
!!$                  p_lL(n) = grid(i  ,j  ,n)
!!$                  p_uL(n) = grid(i  ,j+1,n)
!!$                  p_lR(n) = grid(i+1,j  ,n)
!!$                  p_uR(n) = grid(i+1,j+1,n)
               enddo

              if ((latlon) .or. (dxdy_area)) then
              ! DX_*DY_
                   d1 = dx(i  ,j  )
                   d2 = dx(i  ,j+1)
                 mydx = 0.5 * ( d1+d2 )
                   d1 = dy(i  ,j  )
                   d2 = dy(i+1,j  )
                 mydy = 0.5 * ( d1+d2 )
                 area(i,j) = (mydx*mydy)
              else
              ! Spherical Excess Formula
                area(i,j) = get_area(p_lL, p_uL, p_lR, p_uR, radius)
              endif
              maxarea=MAX(area(i,j),maxarea)
              minarea=MIN(area(i,j),minarea)
              globalarea = globalarea + area(i,j)
            enddo
         enddo

         allocate( p_R8(nx-1,ny-1,ntiles_g) )
         do j=js,je
            do i=is,ie
               p_R8(i,j,tile) = area(i,j)
            enddo
         enddo
         call mp_gather(p_R8, is,ie, js,je, nx-1, ny-1, ntiles_g)
         if (gid == masterproc) then
            globalarea = 0.0
            do n=1,ntiles_g
               do j=1,ny-1
                  do i=1,nx-1
                     globalarea = globalarea + p_R8(i,j,n)
                  enddo
               enddo
            enddo
         endif
         call mp_bcst(globalarea) 
         deallocate( p_R8 )

        if (latlon) then
           acapS = 0.0
           acapN = 0.0
           do i=1,nx-1
              acapS = acapS + area(i,   1)
              acapN = acapN + area(i,ny-1)
           enddo
           if (gid == masterproc) print*, 'AREA Southern Polar Cap (m*m):', acapS, ' AREA Northern Polar Cap (m*m):', acapN
        endif

         call mp_reduce_max(maxarea)
         minarea = -minarea                  
         call mp_reduce_max(minarea)
         minarea = -minarea

        if (gid == masterproc) write(*,209) 'MAX    AREA (m*m):', maxarea,            '          MIN AREA (m*m):', minarea
        if (gid == masterproc) write(*,209) 'GLOBAL AREA (m*m):', globalarea, ' IDEAL GLOBAL AREA (m*m):', 4.0*pi*radius**2
 209  format(A,e21.14,A,e21.14)

         do j=js,je+1
            do i=is,ie+1

               do n=1,ndims
                  p_lL(n) = agrid(iintb(1,i,j), jintb(1,i,j), n)
                  p_lR(n) = agrid(iintb(2,i,j), jintb(2,i,j), n)
                  p_uL(n) = agrid(iintb(4,i,j), jintb(4,i,j), n)
                  p_uR(n) = agrid(iintb(3,i,j), jintb(3,i,j), n)
!!$                  p_lL(n) = agrid(i-1,j-1,n)
!!$                  p_lR(n) = agrid(i  ,j-1,n)
!!$                  p_uL(n) = agrid(i-1,j  ,n)
!!$                  p_uR(n) = agrid(i  ,j  ,n)
               enddo
 
        
              if ((latlon) .or. (dxdy_area)) then
              ! DX_*DY_
                 d1 = dxc(i  ,j  ) !
                 d2 = dxc(i  ,j-1) !
               mydx = 0.5 * ( d1+d2 )
                 d1 = dyc(i-1,j  ) !
                 d2 = dyc(i  ,j  ) !
               mydy = 0.5 * ( d1+d2 )
                 area_c(i,j) = (mydx*mydy)
              else
              ! Spherical Excess Formula
                area_c(i,j) = get_area(p_lL, p_uL, p_lR, p_uR, radius)
              endif

            enddo
         enddo

         if (cubed_sphere) then
            i=1
            j=1
            if ( (is==1) .and. (js==1) ) then
              do n=1,ndims
               p1(n) = agrid(iintb(1,i,j), jintb(1,i,j), n)
               p2(n) = agrid(iintb(2,i,j), jintb(2,i,j), n)
               p3(n) = agrid(iintb(3,i,j), jintb(3,i,j), n)
!!$               p1(n) = agrid(i-1,j  ,n)
!!$               p2(n) = agrid(i  ,j  ,n)
!!$               p3(n) = agrid(i  ,j-1,n)
              enddo
              area_c(i,j) = get_area_tri(ndims, p1, p2, p3)
            endif

            i=nx
            j=1
            if ( (ie+1==nx) .and. (js==1) ) then
              do n=1,ndims
               p1(n) = agrid(iintb(1,i,j), jintb(1,i,j), n)
               p2(n) = agrid(iintb(2,i,j), jintb(2,i,j), n)
               p3(n) = agrid(iintb(3,i,j), jintb(3,i,j), n)
!!$               p1(n) = agrid(i  ,j  ,n)
!!$               p2(n) = agrid(i-1,j  ,n)
!!$               p3(n) = agrid(i-1,j-1,n)
              enddo
              area_c(i,j) = get_area_tri(ndims, p1, p2, p3)
            endif

            i=nx
            j=ny
            if ( (ie+1==nx) .and. (je+1==ny) ) then
              do n=1,ndims
               p1(n) = agrid(iintb(1,i,j), jintb(1,i,j), n)
               p2(n) = agrid(iintb(2,i,j), jintb(2,i,j), n)
               p3(n) = agrid(iintb(3,i,j), jintb(3,i,j), n)
!!$               p1(n) = agrid(i-1,j  ,n)
!!$               p2(n) = agrid(i-1,j-1,n)
!!$               p3(n) = agrid(i  ,j-1,n)
              enddo
              area_c(i,j) = get_area_tri(ndims, p1, p2, p3)
            endif

            i=1
            j=ny
            if ( (is==1) .and. (je+1==ny) ) then
              do n=1,ndims
               p1(n) = agrid(iintb(1,i,j), jintb(1,i,j), n)
               p2(n) = agrid(iintb(2,i,j), jintb(2,i,j), n)
               p3(n) = agrid(iintb(3,i,j), jintb(3,i,j), n)
!!$               p1(n) = agrid(i  ,j  ,n)
!!$               p2(n) = agrid(i  ,j-1,n)
!!$               p3(n) = agrid(i-1,j-1,n)
              enddo
              area_c(i,j) = get_area_tri(ndims, p1, p2, p3)
            endif
         endif

!         if (tile==1) then
!            if ( (is==   1) .and. (js==   1) ) write(*,316) 'A: SW', area(is,js), ' AC: SW', area_c(is  ,js  )
!            if ( (is==   1) .and. (je==ny-1) ) write(*,316) 'A: SW', area(is,je), ' AC: SW', area_c(is  ,je+1)
!            if ( (ie==nx-1) .and. (je==ny-1) ) write(*,316) 'A: SW', area(ie,je), ' AC: SW', area_c(ie+1,je+1)
!            if ( (ie==nx-1) .and. (js==   1) ) write(*,316) 'A: SW', area(ie,js), ' AC: SW', area_c(ie+1,js  )
!         endif
! 316     format(A,e21.14,A,e21.14)

      end subroutine grid_area




      real  function get_angle(ndims, p1, p2, p3, rad) result (angle)
!     get_angle :: get angle between 3 points on a sphere in lat/lon coords or
!                  xyz coords (determined by ndims argument 2=lat/lon, 3=xyz)
!                  [angle is returned in degrees]

         integer, intent(IN) :: ndims         ! 2=lat/lon, 3=xyz
         real , intent(IN)   :: p1(ndims)
         real , intent(IN)   :: p2(ndims)
         real , intent(IN)   :: p3(ndims)
         integer, intent(in), optional:: rad

         real  :: e1(3), e2(3), e3(3)

         if (ndims == 2) then
            call spherical_to_cartesian(p2(1), p2(2), 1., e1(1), e1(2), e1(3))
            call spherical_to_cartesian(p1(1), p1(2), 1., e2(1), e2(2), e2(3))
            call spherical_to_cartesian(p3(1), p3(2), 1., e3(1), e3(2), e3(3))
         else
            e1 = p2; e2 = p1; e3 = p3
         endif

! High precision version:
         if ( present(rad) ) then
           angle = spherical_angle(e1, e2, e3)
         else
           angle = todeg * spherical_angle(e1, e2, e3)
         endif

      end function get_angle
 

 
      subroutine mp_update_dwinds_2d(u, v, npx, npy)
        use mpp_parameter_mod, only: DGRID_NE
         real  , intent(INOUT)   :: u(isd:ied  ,jsd:jed+1) ! D-grid u-wind field
         real  , intent(INOUT)   :: v(isd:ied+1,jsd:jed  ) ! D-grid v-wind field
         integer,      intent(IN) :: npx, npy

         call mpp_update_domains( u, v, domain, gridtype=DGRID_NE, complete=.true.)
!        call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.)

      end subroutine mp_update_dwinds_2d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
      subroutine mp_update_dwinds_3d(u, v, npx, npy, npz)
        use mpp_parameter_mod, only: DGRID_NE
         real  , intent(INOUT)   :: u(isd:ied  ,jsd:jed+1,npz) ! D-grid u-wind field
         real  , intent(INOUT)   :: v(isd:ied+1,jsd:jed  ,npz) ! D-grid v-wind field
         integer,      intent(IN) :: npx, npy, npz
         integer k

      call mpp_update_domains( u, v, domain, gridtype=DGRID_NE, complete=.true.)
!     do k=1,npz
!        call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.)
!     enddo

      end subroutine mp_update_dwinds_3d



      subroutine atob_s(qin, qout, npx, npy, altInterp)

!     atob_s :: interpolate scalar from the A-Grid to the B-grid
!
         integer,      intent(IN) :: npx, npy
         real  , intent(IN)    ::  qin(isd:ied  ,jsd:jed  )    ! A-grid field
         real  , intent(OUT)   :: qout(isd:ied+1,jsd:jed+1)    ! Output  B-grid field
         integer, OPTIONAL, intent(IN) :: altInterp 

         integer :: i,j,n

         real :: tmp1j(jsd:jed+1)
         real :: tmp2j(jsd:jed+1)
         real :: tmp3j(jsd:jed+1)
         real :: tmp1i(isd:ied+1)
         real :: tmp2i(isd:ied+1)
         real :: tmp3i(isd:ied+1)
         real :: tmpq(isd:ied  ,jsd:jed  )
         real :: tmpq1(isd:ied+1,jsd:jed+1)
         real :: tmpq2(isd:ied+1,jsd:jed+1)

         if (present(altInterp)) then

         tmpq(:,:) = qin(:,:)

         call fill_corners(tmpq  , npx, npy, FILL=XDir, AGRID=.true.)
! ATOC
         do j=jsd,jed
            call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altInterp) 
         enddo

         call fill_corners(tmpq  , npx, npy, FILL=YDir, AGRID=.true.)
! ATOD
         do i=isd,ied
            tmp1j(jsd:jed) = 0.0 
            tmp2j(jsd:jed) = tmpq(i,jsd:jed)
            tmp3j(jsd:jed) = dya(i,jsd:jed)
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altInterp)
            tmpq2(i,jsd:jed) = tmp1j(jsd:jed)
         enddo

! CTOB
         do i=isd,ied
            tmp1j(:) = tmpq1(i,:)
            tmp2j(:) = tmpq1(i,:)
            tmp3j(:) = 1.0  ! Uniform Weighting missing first value so will not reproduce
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altInterp) 
            tmpq1(i,:) = tmp1j(:)
         enddo

! DTOB
         do j=jsd,jed
            tmp1i(:) = tmpq2(:,j)
            tmp2i(:) = tmpq2(:,j)
            tmp3i(:) = 1.0  ! Uniform Weighting missing first value so will not reproduce
            call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altInterp)
            tmpq2(:,j) = tmp1i(:)
         enddo

! Average 
         do j=jsd,jed+1
            do i=isd,ied+1
               qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j))
            enddo
         enddo

! Fix Corners
         if (cubed_sphere) then
            i=1
            j=1
            if ( (is==i) .and. (js==j) ) then
               qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
            endif

            i=npx
            j=1
            if ( (ie+1==i) .and. (js==j) ) then
               qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
            endif

            i=1
            j=npy
            if ( (is==i) .and. (je+1==j) ) then
               qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
            endif

            i=npx
            j=npy
            if ( (ie+1==i) .and. (je+1==j) ) then
               qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
            endif
        endif

        else ! altInterp

            do j=js,je+1
               do i=is,ie+1
                  qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + &
                                      qin(i  ,j) + qin(i  ,j-1))
               enddo
            enddo
            i=1
            j=1
            if ( (is==i) .and. (js==j) ) then
               qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
            endif

            i=npx
            j=1
            if ( (ie+1==i) .and. (js==j) ) then
               qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
            endif

            i=1
            j=npy
            if ( (is==i) .and. (je+1==j) ) then
               qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
            endif

            i=npx
            j=npy
            if ( (ie+1==i) .and. (je+1==j) ) then
               qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
            endif

        endif ! altInterp

      end subroutine atob_s
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     atod :: interpolate from the A-Grid to the D-grid
!
      subroutine atod(uin, vin, uout, vout, npx, npy, ng)


         integer,      intent(IN) :: npx, npy, ng
         real  , intent(IN)    ::  uin(isd:ied  ,jsd:jed  ) ! A-grid u-wind field
         real  , intent(IN)    ::  vin(isd:ied  ,jsd:jed  ) ! A-grid v-wind field
         real  , intent(OUT)   :: uout(isd:ied  ,jsd:jed+1) ! D-grid u-wind field
         real  , intent(OUT)   :: vout(isd:ied+1,jsd:jed  ) ! D-grid v-wind field

         integer :: i,j
         real :: tmp1i(isd:ied+1)
         real :: tmp2i(isd:ied)
         real :: tmp3i(isd:ied)
         real :: tmp1j(jsd:jed+1)
         real :: tmp2j(jsd:jed)
         real :: tmp3j(jsd:jed)

         do j=jsd+1,jed
            tmp1i(:) = 0.0
            tmp2i(:) = vin(:,j)*dxa(:,j)
            tmp3i(:) = dxa(:,j)
            call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interpOrder)
            vout(:,j) = tmp1i(:)/dxc(:,j)
         enddo
         do i=isd+1,ied
            tmp1j(:) = 0.0
            tmp2j(:) = uin(i,:)*dya(i,:)
            tmp3j(:) = dya(i,:)
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder)
            uout(i,:) = tmp1j(:)/dyc(i,:)
         enddo
         call mp_update_dwinds(uout, vout, npx, npy)
         call fill_corners(uout, vout, npx, npy, VECTOR=.true., DGRID=.true.)
      end subroutine atod
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     dtoa :: interpolate from the D-Grid to the A-grid
!
      subroutine dtoa(uin, vin, uout, vout, npx, npy, ng)

         integer,      intent(IN) :: npx, npy, ng
         real  , intent(IN)    ::  uin(isd:ied  ,jsd:jed+1)    ! D-grid u-wind field
         real  , intent(IN)    ::  vin(isd:ied+1,jsd:jed  )    ! D-grid v-wind field
         real  , intent(OUT)   :: uout(isd:ied  ,jsd:jed  )    ! A-grid u-wind field
         real  , intent(OUT)   :: vout(isd:ied  ,jsd:jed  )    ! A-grid v-wind field

         integer :: i,j,n

         real :: tmp1i(isd:ied+1)
         real :: tmp2i(isd:ied+1)
         real :: tmp3i(isd:ied+1)
         real :: tmp1j(jsd:jed+1)
         real :: tmp2j(jsd:jed+1)
         real :: tmp3j(jsd:jed+1)

#ifdef VORT_ON
! circulation (therefore, vort) conserving:
         do j=jsd,jed
            do i=isd,ied
                uout(i,j) = 0.5*(uin(i,j)*dx(i,j)+uin(i,j+1)*dx(i,j+1))/dxa(i,j)
                vout(i,j) = 0.5*(vin(i,j)*dy(i,j)+vin(i+1,j)*dy(i+1,j))/dya(i,j)
            enddo
         enddo
#else
         do i=isd,ied
            tmp1j(:) = 0.0
            tmp2j(:) = uin(i,:)*dyc(i,:)
            tmp3j(:) = dyc(i,:)
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interpOrder) 
            uout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dya(i,jsd:jed)
         enddo
         do j=jsd,jed
            tmp1i(:) = 0.0
            tmp2i(:) = vin(:,j)*dxc(:,j)
            tmp3i(:) = dxc(:,j)
            call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interpOrder) 
            vout(isd:ied,j) = tmp1i(isd+1:ied+1)/dxa(isd:ied,j)
         enddo
#endif

      end subroutine dtoa
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     atoc :: interpolate from the A-Grid to the C-grid
!
      subroutine atoc(uin, vin, uout, vout, npx, npy, ng, noComm)


         integer,      intent(IN) :: npx, npy, ng
         real  , intent(IN)    ::  uin(isd:ied  ,jsd:jed  ) ! A-grid u-wind field
         real  , intent(IN)    ::  vin(isd:ied  ,jsd:jed  ) ! A-grid v-wind field
         real  , intent(OUT)   :: uout(isd:ied+1,jsd:jed  ) ! C-grid u-wind field
         real  , intent(OUT)   :: vout(isd:ied  ,jsd:jed+1) ! C-grid v-wind field
         logical, OPTIONAL, intent(IN)   :: noComm

         real :: ang1
         integer :: i,j,n

         real :: tmp1i(isd:ied+1)
         real :: tmp2i(isd:ied)
         real :: tmp3i(isd:ied)
         real :: tmp1j(jsd:jed+1)
         real :: tmp2j(jsd:jed)
         real :: tmp3j(jsd:jed)

#if !defined(ALT_INTERP)
#ifdef VORT_ON
! Circulation conserving
         do j=jsd,jed
            do i=isd+1,ied
               uout(i,j) = ( uin(i,j)*dxa(i,j) + uin(i-1,j)*dxa(i-1,j) )    &
                           /        ( dxa(i,j) +            dxa(i-1,j) )
            enddo
         enddo
         do j=jsd+1,jed
            do i=isd,ied
               vout(i,j) = ( vin(i,j)*dya(i,j) + vin(i,j-1)*dya(i,j-1) )    &
                           /        ( dya(i,j) +            dya(i,j-1) )
            enddo
         enddo
#else
         do j=jsd,jed
            call interp_left_edge_1d(uout(:,j), uin(:,j), dxa(:,j), isd, ied, interpOrder)
         enddo
         do i=isd,ied
!!$            tmp1j(:) = vout(i,:)
            tmp2j(:) = vin(i,:)
            tmp3j(:) = dya(i,:)
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder)
            vout(i,:) = tmp1j(:)
         enddo 
#endif
#else

         do j=jsd,jed
!!$            tmp1i(:) = uout(:,j)
            tmp2i(:) = uin(:,j)*dya(:,j)
            tmp3i(:) = dxa(:,j)
            call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interpOrder)
            uout(:,j) = tmp1i(:)/dy(:,j)
         enddo
         do i=isd,ied
!!$            tmp1j(:) = vout(i,:)
            tmp2j(:) = vin(i,:)*dxa(i,:)
            tmp3j(:) = dya(i,:)
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder)
            vout(i,:) = tmp1j(:)/dx(i,:)
         enddo

       if (cubed_sphere) then
         csFac = COS(30.0*PI/180.0)
      ! apply Corner scale factor for interp on Cubed-Sphere
         if ( (is==1) .and. (js==1) ) then
            i=1
            j=1
            uout(i,j)=uout(i,j)*csFac
            uout(i,j-1)=uout(i,j-1)*csFac
            vout(i,j)=vout(i,j)*csFac
            vout(i-1,j)=vout(i-1,j)*csFac
         endif
         if ( (is==1) .and. (je==npy-1) ) then
            i=1
            j=npy-1
            uout(i,j)=uout(i,j)*csFac
            uout(i,j+1)=uout(i,j+1)*csFac
            vout(i,j+1)=vout(i,j+1)*csFac
            vout(i-1,j+1)=vout(i-1,j+1)*csFac
         endif
         if ( (ie==npx-1) .and. (je==npy-1) ) then
            i=npx-1
            j=npy-1
            uout(i+1,j)=uout(i+1,j)*csFac
            uout(i+1,j+1)=uout(i+1,j+1)*csFac
            vout(i,j+1)=vout(i,j+1)*csFac
            vout(i+1,j+1)=vout(i+1,j+1)*csFac
         endif
         if ( (ie==npx-1) .and. (js==1) ) then
            i=npx-1
            j=1
            uout(i+1,j)=uout(i+1,j)*csFac
            uout(i+1,j-1)=uout(i+1,j-1)*csFac
            vout(i,j)=vout(i,j)*csFac
            vout(i+1,j)=vout(i+1,j)*csFac
         endif
       endif

#endif

         if (present(noComm)) then
            if (.not. noComm) call mpp_update_domains( uout,vout, domain, gridtype=CGRID_NE_PARAM, complete=.true.)
         else
            call mpp_update_domains( uout,vout, domain, gridtype=CGRID_NE_PARAM, complete=.true.)
         endif
         call fill_corners(uout, vout, npx, npy, VECTOR=.true., CGRID=.true.)

      end subroutine atoc
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     ctoa :: interpolate from the C-Grid to the A-grid
!
      subroutine ctoa(uin, vin, uout, vout, npx, npy, ng)


         integer,      intent(IN) :: npx, npy, ng 
         real  , intent(IN)    ::  uin(isd:ied+1,jsd:jed  )    ! C-grid u-wind field
         real  , intent(IN)    ::  vin(isd:ied  ,jsd:jed+1)    ! C-grid v-wind field
         real  , intent(OUT)   :: uout(isd:ied  ,jsd:jed  )    ! A-grid u-wind field
         real  , intent(OUT)   :: vout(isd:ied  ,jsd:jed  )    ! A-grid v-wind field

         integer :: i,j

         real :: tmp1i(isd:ied+1)
         real :: tmp2i(isd:ied+1)
         real :: tmp3i(isd:ied+1)
         real :: tmp1j(jsd:jed+1)
         real :: tmp2j(jsd:jed+1)
         real :: tmp3j(jsd:jed+1)

        ! do j=jsd,jed
        !    do i=isd,ied
        !       uout(i,j) = 0.5 * (uin(i,j)*dy(i,j) + uin(i+1,j)*dy(i+1,j))/dya(i,j)
        !    enddo
        !  enddo
        ! do j=jsd,jed
        !    do i=isd,ied
        !       vout(i,j) = 0.5 * (vin(i,j)*dx(i,j) + vin(i,j+1)*dx(i,j+1))/dxa(i,j)
        !    enddo
        ! enddo
         do i=isd,ied
            tmp1j(:) = 0.0
            tmp2j(:) = vin(i,:)*dx(i,:)
            tmp3j(:) = dyc(i,:)
            call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interpOrder)
            vout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dxa(i,jsd:jed)
         enddo
         do j=jsd,jed
            tmp1i(:) = 0.0
            tmp2i(:) = uin(:,j)*dy(:,j)
            tmp3i(:) = dxc(:,j)
            call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interpOrder)
            uout(isd:ied,j) = tmp1i(isd+1:ied+1)/dya(isd:ied,j)
         enddo

      end subroutine ctoa
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     rotate_winds :: rotate winds from the sphere-to-cube || cube-to-sphere
!
      subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)


         integer,      intent(IN) :: ndims
         real  , intent(INOUT) :: myU    ! u-wind field
         real  , intent(INOUT) :: myV    ! v-wind field
         real  , intent(IN)    :: p1(ndims)    !             p4     
         real  , intent(IN)    :: p2(ndims)    !                    
         real  , intent(IN)    :: p3(ndims)    !        p1   t1   p3
         real  , intent(IN)    :: p4(ndims)    !                    
         real  , intent(IN)    :: t1(ndims)    !             p2     
         integer,   intent(IN)    :: dir   ! Direction ; 1=>sphere-to-cube  2=> cube-to-sphere

         real :: ee1(3), ee2(3), ee3(3), elon(3), elat(3)

         real :: g11, g12, g21, g22

         real :: newu, newv

         call get_unit_vector(p3, t1, p1, ee1)
         call get_unit_vector(p4, t1, p2, ee2)
         elon(1) = -SIN(t1(1) - pi)
         elon(2) =  COS(t1(1) - pi)
         elon(3) = 0.0
         elat(1) = -SIN(t1(2))*COS(t1(1) - pi)
         elat(2) = -SIN(t1(2))*SIN(t1(1) - pi)
         elat(3) =  COS(t1(2))

         g11 = inner_prod(ee1,elon)
         g12 = inner_prod(ee1,elat)
         g21 = inner_prod(ee2,elon)
         g22 = inner_prod(ee2,elat)

         if (dir == 1) then    ! Sphere to Cube Rotation
            newu = myU*g11 + myV*g12
            newv = myU*g21 + myV*g22
         else
            newu = ( myU*g22 - myV*g12)/(g11*g22 - g21*g12) 
            newv = (-myU*g21 + myV*g11)/(g11*g22 - g21*g12)
         endif
         myU = newu
         myV = newv

      end subroutine rotate_winds




      subroutine mirror_grid(grid_global,ng,npx,npy,ndims,nregions)
         integer, intent(IN)    :: ng,npx,npy,ndims,nregions
         real   , intent(INOUT) :: grid_global(1-ng:npx  +ng,1-ng:npy  +ng,ndims,1:nregions)
         integer :: i,j,n,n1,n2,nreg
         real :: x1,y1,z1, x2,y2,z2, ang
!
!    Mirror Across the 0-longitude
!
         nreg = 1
         do j=1,ceiling(npy/2.)
            do i=1,ceiling(npx/2.)

            x1 = 0.25 * (ABS(grid_global(i        ,j        ,1,nreg)) + &
                         ABS(grid_global(npx-(i-1),j        ,1,nreg)) + &
                         ABS(grid_global(i        ,npy-(j-1),1,nreg)) + &
                         ABS(grid_global(npx-(i-1),npy-(j-1),1,nreg)))
            grid_global(i        ,j        ,1,nreg) = SIGN(x1,grid_global(i        ,j        ,1,nreg))
            grid_global(npx-(i-1),j        ,1,nreg) = SIGN(x1,grid_global(npx-(i-1),j        ,1,nreg))
            grid_global(i        ,npy-(j-1),1,nreg) = SIGN(x1,grid_global(i        ,npy-(j-1),1,nreg))
            grid_global(npx-(i-1),npy-(j-1),1,nreg) = SIGN(x1,grid_global(npx-(i-1),npy-(j-1),1,nreg))

            y1 = 0.25 * (ABS(grid_global(i        ,j        ,2,nreg)) + &   
                         ABS(grid_global(npx-(i-1),j        ,2,nreg)) + &
                         ABS(grid_global(i        ,npy-(j-1),2,nreg)) + &
                         ABS(grid_global(npx-(i-1),npy-(j-1),2,nreg)))
            grid_global(i        ,j        ,2,nreg) = SIGN(y1,grid_global(i        ,j        ,2,nreg))
            grid_global(npx-(i-1),j        ,2,nreg) = SIGN(y1,grid_global(npx-(i-1),j        ,2,nreg))
            grid_global(i        ,npy-(j-1),2,nreg) = SIGN(y1,grid_global(i        ,npy-(j-1),2,nreg))
            grid_global(npx-(i-1),npy-(j-1),2,nreg) = SIGN(y1,grid_global(npx-(i-1),npy-(j-1),2,nreg))
             
           ! force dateline/greenwich-meridion consitency
            if (mod(npx,2) /= 0) then
              if ( (i==1+(npx-1)/2.0) ) then
                 grid_global(i,j        ,1,nreg) = 0.0
                 grid_global(i,npy-(j-1),1,nreg) = 0.0
              endif
            endif

            enddo
         enddo

         do nreg=2,nregions
           do j=1,npy
             do i=1,npx

               x1 = grid_global(i,j,1,1)
               y1 = grid_global(i,j,2,1)
               z1 = radius

               if (nreg == 2) then
                  ang = -90.
                  call rot_3d( 3, x1, y1, z1, ang, x2, y2, z2, 1, 1)  ! rotate about the z-axis
               elseif (nreg == 3) then
                  ang = -90.
                  call rot_3d( 3, x1, y1, z1, ang, x2, y2, z2, 1, 1)  ! rotate about the z-axis
                  ang = 90.
                  call rot_3d( 1, x2, y2, z2, ang, x1, y1, z1, 1, 1)  ! rotate about the x-axis
                  x2=x1
                  y2=y1
                  z2=z1

           ! force North Pole and dateline/greenwich-meridion consitency
                  if (mod(npx,2) /= 0) then
                     if ( (i==1+(npx-1)/2.0) .and. (i==j) ) then
                        x2 = 0.0
                        y2 = pi/2.0
                     endif
                     if ( (j==1+(npy-1)/2.0) .and. (i < 1+(npx-1)/2.0) ) then
                        x2 = 0.0
                     endif
                     if ( (j==1+(npy-1)/2.0) .and. (i > 1+(npx-1)/2.0) ) then
                        x2 = pi
                     endif
                  endif

               elseif (nreg == 4) then
                  ang = -180.
                  call rot_3d( 3, x1, y1, z1, ang, x2, y2, z2, 1, 1)  ! rotate about the z-axis
                  ang = 90.
                  call rot_3d( 1, x2, y2, z2, ang, x1, y1, z1, 1, 1)  ! rotate about the x-axis
                  x2=x1
                  y2=y1
                  z2=z1

               ! force dateline/greenwich-meridion consitency
                  if (mod(npx,2) /= 0) then
                    if ( (j==1+(npy-1)/2.0) ) then
                       x2 = pi
                    endif
                  endif

               elseif (nreg == 5) then
                  ang = 90.
                  call rot_3d( 3, x1, y1, z1, ang, x2, y2, z2, 1, 1)  ! rotate about the z-axis
                  ang = 90.
                  call rot_3d( 2, x2, y2, z2, ang, x1, y1, z1, 1, 1)  ! rotate about the y-axis
                  x2=x1
                  y2=y1
                  z2=z1
               elseif (nreg == 6) then
                  ang = 90.
                  call rot_3d( 2, x1, y1, z1, ang, x2, y2, z2, 1, 1)  ! rotate about the y-axis
                  ang = 0.
                  call rot_3d( 3, x2, y2, z2, ang, x1, y1, z1, 1, 1)  ! rotate about the z-axis
                  x2=x1
                  y2=y1
                  z2=z1

           ! force South Pole and dateline/greenwich-meridion consitency
                  if (mod(npx,2) /= 0) then
                     if ( (i==1+(npx-1)/2.0) .and. (i==j) ) then
                        x2 = 0.0
                        y2 = -pi/2.0
                     endif
                     if ( (i==1+(npx-1)/2.0) .and. (j > 1+(npy-1)/2.0) ) then
                        x2 = 0.0
                     endif
                     if ( (i==1+(npx-1)/2.0) .and. (j < 1+(npy-1)/2.0) ) then
                        x2 = pi
                     endif
                  endif

               endif

               grid_global(i,j,1,nreg) = x2
               grid_global(i,j,2,nreg) = y2

              enddo
            enddo
          enddo

  end subroutine mirror_grid




 subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, &
                  u,v, ua,va, uc,vc)

! Input
  integer, intent(IN) :: im,jm,km
  integer, intent(IN) :: ifirst,ilast
  integer, intent(IN) :: jfirst,jlast
  integer, intent(IN) :: ng
  !real   , intent(in) :: sinlon(im,jm)
  !real   , intent(in) :: coslon(im,jm)
  !real   , intent(in) :: sinl5(im,jm)
  !real   , intent(in) :: cosl5(im,jm)

! Output
 ! real   , intent(inout) ::  u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
 ! real   , intent(inout) ::  v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
 ! real   , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
 ! real   , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
 ! real   , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
 ! real   , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)

  real   , intent(inout) ::  u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
  real   , intent(inout) ::  v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
  real   , intent(inout) :: ua(isd:ied,jsd:jed)   !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
  real   , intent(inout) :: va(isd:ied,jsd:jed)   !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
  real   , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
  real   , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)

!--------------------------------------------------------------
! Local 

  real   :: sinlon(im,jm)
  real   :: coslon(im,jm)
  real   :: sinl5(im,jm)
  real   :: cosl5(im,jm)

    real :: tmp1(jsd:jed+1)
    real :: tmp2(jsd:jed)
    real :: tmp3(jsd:jed)

    real  mag,mag1,mag2, ang,ang1,ang2 
    real  us, vs, un, vn
    integer i, j, k, im2
    integer js1g1
    integer js2g1
    integer js2g2
    integer js2gc
    integer js2gc1
    integer js2gcp1
    integer js2gd
    integer jn2gc
    integer jn1g1
    integer jn1g2
    integer jn2gd
    integer jn2gsp1

 if (cubed_sphere) then

    call dtoa( u, v,ua,va,im,jm,ng)
    call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.)
    call atoc(ua,va,uc,vc,im,jm,ng, noComm=.true.)
    call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.)

 else  ! Lat-Lon

    im2 = im/2

! Set loop limits

    js1g1   = jfirst-1
    js2g1   = jfirst-1
    js2g2   = jfirst-2
    js2gc   = jfirst-ng
    js2gcp1 = jfirst-ng-1
    js2gd   = jfirst-ng
    jn1g1   = jlast+1
    jn1g2   = jlast+2
    jn2gc   = jlast+ng
    jn2gd   = jlast+ng-1
    jn2gsp1 = jlast+ng-1

    if (have_south_pole) then
       js1g1   = 1
       js2g1   = 2
       js2g2   = 2
       js2gc   = 2
       js2gcp1 = 2   ! NG-1 latitudes on S (starting at 2)
       js2gd   = 2
    endif
    if (have_north_pole) then
       jn1g1   = jm
       jn1g2   = jm
       jn2gc   = jm-1  ! NG latitudes on N (ending at jm-1)
       jn2gd   = jm-1
       jn2gsp1 = jm-1
    endif
!
! Treat the special case of ng = 1
!
    if ( ng == 1 .AND. ng > 1 ) THEN
        js2gc1 = js2gc
    else
        js2gc1 = jfirst-ng+1
        if (have_south_pole) js2gc1 = 2  ! NG-1 latitudes on S (starting at 2)
    endif

  do k=1,km

       if ((have_south_pole) .or. (have_north_pole)) then
! Get D-grid V-wind at the poles.
          call vpol5(u(1:im,:), v(1:im,:), im, jm,            &
                     coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast )
          call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:))
       endif

       call dtoa(u, v, ua, va, im, jm, ng)
       call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.)

       if ( have_south_pole ) then
! Projection at SP
          us = 0.
          vs = 0.
          do i=1,im2
            us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2)         &
                    + (va(i,2)-va(i+im2,2))*coslon(i,2)
            vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2)         &
                    + (va(i+im2,2)-va(i,2))*sinlon(i,2)
          enddo
          us = us/im
          vs = vs/im
! SP
          do i=1,im2
            ua(i,1)  = -us*sinlon(i,1) - vs*coslon(i,1)
            va(i,1)  =  us*coslon(i,1) - vs*sinlon(i,1)
            ua(i+im2,1)  = -ua(i,1)
            va(i+im2,1)  = -va(i,1)
          enddo
          ua(0   ,1) = ua(im,1)
          ua(im+1,1) = ua(1 ,1)
          va(im+1,1) = va(1 ,1)
        endif

        if ( have_north_pole ) then
! Projection at NP
          un = 0.
          vn = 0.
          j = jm-1
          do i=1,im2
            un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j)        &
                    + (va(i+im2,j)-va(i,j))*coslon(i,j)
            vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j)        &
                    + (va(i+im2,j)-va(i,j))*sinlon(i,j)
          enddo
          un = un/im
          vn = vn/im
! NP
          do i=1,im2
            ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm)
            va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm)
            ua(i+im2,jm) = -ua(i,jm)
            va(i+im2,jm) = -va(i,jm)
          enddo
          ua(0   ,jm) = ua(im,jm)
          ua(im+1,jm) = ua(1 ,jm)
          va(im+1,jm) = va(1 ,jm)
        endif

        if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:))
        if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:))

! A -> C
        call atoc(ua, va, uc, vc, im, jm, ng, noComm=.true.)

     enddo ! km loop

     call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.)
   endif


 end subroutine d2a2c

!----------------------------------------------------------------------- 
!----------------------------------------------------------------------- 
!BOP
!
 subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5,    &
                  ng_d,  ng_s,  jfirst, jlast)

! !INPUT PARAMETERS:
      integer im                       ! Total longitudes
      integer jm                       ! Total latitudes
      integer jfirst                   ! First PE latitude (no ghosting)
      integer jlast                    ! Last  PE latitude (no ghosting)
      integer, intent(in):: ng_s, ng_d
      real, intent(in):: coslon(im,jm), sinlon(im,jm)
      real, intent(in):: cosl5(im,jm),sinl5(im,jm)
      real, intent(in):: u(im,jfirst-ng_d:jlast+ng_s)

! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout):: v(im,jfirst-ng_d:jlast+ng_d)

! !DESCRIPTION:
!
!   Treat the V winds at the poles.  This requires an average 
!   of the U- and V-winds, weighted by their angles of incidence
!   at the pole points.     
!
! !REVISION HISTORY:
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:

      integer i, imh
      real  uanp(im), uasp(im), vanp(im), vasp(im)
      real  un, vn, us, vs, r2im

! WS 99.05.25 :  Replaced conversions of IMR with IM
      r2im = 0.5d0/dble(im)
      imh  = im / 2

! WS 990726 :  Added condition to decide if poles are on this processor

   if ( jfirst-ng_d <= 1 ) then
         do i=1,im
            uasp(i) = u(i,  2) + u(i,3)
         enddo

         do i=1,im-1
            vasp(i)  = v(i,  2) + v(i+1,2)
         enddo
            vasp(im) = v(im,2) + v(1,2)

! Projection at SP
      us = 0.; vs = 0.

      do i=1,imh
         us = us + (uasp(i+imh)-uasp(i))*sinlon(i,1)    &
                 + (vasp(i)-vasp(i+imh))*coslon(i,1)
         vs = vs + (uasp(i+imh)-uasp(i))*coslon(i,1)    &
                 + (vasp(i+imh)-vasp(i))*sinlon(i,1)
      enddo
      us = us*r2im
      vs = vs*r2im

! get V-wind at SP

      do i=1,imh
         v(i,    1) =  us*cosl5(i,1) - vs*sinl5(i,1)
         v(i+imh,1) = -v(i,1)
      enddo

   endif

   if ( jlast+ng_d >= jm ) then

      do i=1,im
         uanp(i) = u(i,jm-1) + u(i,jm)
      enddo

      do i=1,im-1
         vanp(i) = v(i,jm-1) + v(i+1,jm-1)
      enddo
         vanp(im) = v(im,jm-1) + v(1,jm-1)

! Projection at NP

      un = 0.
      vn = 0.
      do i=1,imh
         un = un + (uanp(i+imh)-uanp(i))*sinlon(i,jm)   &
                 + (vanp(i+imh)-vanp(i))*coslon(i,jm)
         vn = vn + (uanp(i)-uanp(i+imh))*coslon(i,jm)   &
                 + (vanp(i+imh)-vanp(i))*sinlon(i,jm)
      enddo
      un = un*r2im
      vn = vn*r2im

! get V-wind at NP

      do i=1,imh
         v(i,    jm) = -un*cosl5(i,jm) - vn*sinl5(i,jm)
         v(i+imh,jm) = -v(i,jm)
      enddo

   endif

 end subroutine vpol5

!------------------------------------------------------------------------------
!BOP
! !ROUTINE: mp_ghost_ew --- Ghost 4d east/west "lat/lon periodic
!
! !INTERFACE:
      subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
                              kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
!
! !INPUT PARAMETERS:
      integer, intent(in):: im, jm, km, nq
      integer, intent(in):: ifirst, ilast
      integer, intent(in):: jfirst, jlast
      integer, intent(in):: kfirst, klast
      integer, intent(in):: ng_e      ! eastern  zones to ghost
      integer, intent(in):: ng_w      ! western  zones to ghost
      integer, intent(in):: ng_s      ! southern zones to ghost
      integer, intent(in):: ng_n      ! northern zones to ghost
      real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
      real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq)
!
! !DESCRIPTION:
!
!     Ghost 4d east/west 
!
! !REVISION HISTORY:
!    2005.08.22   Putman
!
!EOP
!------------------------------------------------------------------------------
!BOC
      integer :: i,j,k,n

      if (present(q)) then
         q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = &
              q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq)
      endif

!      Assume Periodicity in X-dir and not overlapping
      do n=1,nq
         do k=kfirst,klast
            do j=jfirst-ng_s,jlast+ng_n
               do i=1, ng_w
                  q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n)
               enddo
               do i=1, ng_e
                  q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n)
               enddo
            enddo
         enddo
      enddo

!EOC
      end subroutine mp_ghost_ew





      subroutine unit_vect2( p1, p2, uvect )
! No normal projection version
      real, intent(in):: p1(2), p2(2)        ! input position unit vectors (spherical coordinates)
      real, intent(out):: uvect(3)           ! output unit vspherical cartesian
! local        
      integer :: n
      real :: xyz1(3), xyz2(3)

      call spherical_to_cartesian(p1(1), p1(2), 1.0, xyz1(1), xyz1(2), xyz1(3))
      call spherical_to_cartesian(p2(1), p2(2), 1.0, xyz2(1), xyz2(2), xyz2(3))
      do n=1,3
         uvect(n) = xyz2(n)-xyz1(n)
      enddo
      call normalize_vect(1, uvect)

      end subroutine unit_vect2


 subroutine get_unit_vector_3pts( p1, p2, p3, uvect )
 real, intent(in):: p1(2), p2(2), p3(2) ! input position unit vectors (spherical coordinates)
 real, intent(out):: uvect(3)           ! output unit vspherical cartesian
! local
 integer :: n 
 real :: xyz1(3), xyz2(3), xyz3(3)
 real :: dp(3) 
 real :: dp_dot_p2

  call spherical_to_cartesian(p1(1), p1(2), 1.0, xyz1(1), xyz1(2), xyz1(3))
  call spherical_to_cartesian(p2(1), p2(2), 1.0, xyz2(1), xyz2(2), xyz2(3))
  call spherical_to_cartesian(p3(1), p3(2), 1.0, xyz3(1), xyz3(2), xyz3(3))
  do n=1,3
     uvect(n) = xyz3(n)-xyz1(n)
  enddo
  call project_sphere_v(1, uvect,xyz2)
  call normalize_vect(1, uvect)

 end subroutine get_unit_vector_3pts


 subroutine get_unit_vector_2pts( p1, p2, uvect )
 real, intent(in):: p1(2), p2(2)        ! input position unit vectors (spherical coordinates)
 real, intent(out):: uvect(3)           ! output unit vspherical cartesian
! local        
 integer :: n 
 real :: xyz1(3), xyz2(3)         
 real :: dp_dot_xyz1
                  
  call spherical_to_cartesian(p1(1), p1(2), 1.0, xyz1(1), xyz1(2), xyz1(3))
  call spherical_to_cartesian(p2(1), p2(2), 1.0, xyz2(1), xyz2(2), xyz2(3))
  do n=1,3                 
     uvect(n) = xyz2(n)-xyz1(n)   
  enddo                 
  call project_sphere_v(1, uvect,xyz1)
  call normalize_vect(1, uvect)

 end subroutine get_unit_vector_2pts




 subroutine normalize_vect(np, e)
!
! Make e an unit vector
!
 implicit none
 integer, intent(in):: np
 real, intent(inout):: e(3,np)
! local:
 integer k, n
 real pdot

 do n=1,np
    pdot = sqrt(e(1,n)**2+e(2,n)**2+e(3,n)**2)
    do k=1,3
       e(k,n) = e(k,n) / pdot
    enddo
 enddo

 end subroutine normalize_vect

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     
!     interp_left_edge_1d :: interpolate to left edge of a cell either
!               order = 1 -> Linear average
!               order = 2 -> Uniform PPM
!               order = 3 -> Non-Uniform PPM  
!
 subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
 integer, intent(in):: ifirst,ilast
 real, intent(out)  :: qout(ifirst:)
 real, intent(in)   ::  qin(ifirst:)
 real, intent(in)   ::   dx(ifirst:)
 integer, intent(in):: order
 integer :: i

 real :: dm(ifirst:ilast),qmax,qmin
 real :: r3, da1, da2, a6da, a6, al, ar  
 real :: qLa, qLb1, qLb2
 real :: x

 r3 = 1./3.

 qout(:) = 0.0 
 if (order==1) then 
! 1st order Uniform linear averaging
    do i=ifirst+1,ilast
       qout(i) = 0.5 * (qin(i-1) + qin(i))
    enddo
 elseif (order==2) then
! Non-Uniform 1st order average 
    do i=ifirst+1,ilast
       qout(i) = (dx(i-1)*qin(i-1) + dx(i)*qin(i))/(dx(i-1)+dx(i))
    enddo
 elseif (order==3) then 

! PPM - Uniform 
    do i=ifirst+1,ilast-1
       dm(i) = 0.25*(qin(i+1) - qin(i-1))
    enddo
!
! Applies monotonic slope constraint
!
     do i=ifirst+1,ilast-1
        qmax = max(qin(i-1),qin(i),qin(i+1)) - qin(i)
        qmin = qin(i) - min(qin(i-1),qin(i),qin(i+1))
        dm(i) = sign(min(abs(dm(i)),qmin,qmax),dm(i))
     enddo

     do i=ifirst+1,ilast-1
         qout(i) = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
       ! al = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
       ! da1 = dm(i) + dm(i)
       ! qout(i) = qin(i) - sign(min(abs(da1),abs(al-qin(i))), da1)
     enddo

! First order average to fill in end points
     qout(ifirst+1) = 0.5 * (qin(ifirst) + qin(ifirst+1))
     qout(ilast) = 0.5 * (qin(ilast-1) + qin(ilast))

 elseif (order==4) then

  ! Non-Uniform PPM
     do i=ifirst+1,ilast-1
        dm(i) = ( (2.*dx(i-1) + dx(i) ) /                         &
                  (   dx(i+1) + dx(i) )  )  * ( qin(i+1) - qin(i) ) + &
                ( (dx(i)   + 2.*dx(i+1)) /                        &
                  (dx(i-1) +    dx(i)  )  ) * ( qin(i) - qin(i-1) )
        dm(i) = ( dx(i) / ( dx(i-1) + dx(i) + dx(i+1) ) ) * dm(i)
        if ( (qin(i+1)-qin(i))*(qin(i)-qin(i-1)) > 0.) then
           dm(i) = SIGN( MIN( ABS(dm(i)), 2.*ABS(qin(i)-qin(i-1)), 2.*ABS(qin(i+1)-qin(i)) ) , dm(i) )
        else
           dm(i) = 0.
        endif
     enddo

     do i=ifirst+2,ilast-1
        qLa = ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) +  dx(i)) ) - &
              ( (dx(i+1) + dx(i)) / (2.*dx(i) +  dx(i-1)) )
        qLa = ( (2.*dx(i) * dx(i-1))  / (dx(i-1) + dx(i)) ) * qLa * &
                (qin(i) - qin(i-1))
        qLb1 = dx(i-1) * ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) * &
              dm(i)
        qLb2 = dx(i) * ( (dx(i) + dx(i+1)) / (dx(i-1) + 2.*dx(i)) ) * &
              dm(i-1)

        qout(i) = 1. / ( dx(i-2) + dx(i-1) + dx(i) + dx(i+1) )
        qout(i) = qout(i) * ( qLa - qLb1 + qLb2 )
        qout(i) = qin(i-1) + ( dx(i-1) / ( dx(i-1) + dx(i) ) ) * (qin(i) - qin(i-1)) + qout(i)
     enddo

 elseif (order==5) then
  
     ! Linear Spline
    do i=ifirst+1,ilast-1
       x = FLOAT(i-(ifirst+1))*FLOAT(ilast-ifirst+1-1)/FLOAT(ilast-ifirst-1) 
       qout(i) = qin(ifirst+NINT(x)) + (x - NINT(x)) * (qin(ifirst+NINT(x+1)) - qin(ifirst+NINT(x)))
      ! if (tile==1) print*, ifirst+NINT(x+1), ifirst+NINT(x), (x - NINT(x)) 
      ! if (tile==1) print*, 0.5*(qin(i-1)+qin(i)), qout(i)
    enddo

   if (tile==1) print*,'x=fltarr(28)'
    do i=ifirst,ilast
       if (tile==1) print*, 'x(',i-ifirst,')=',qin(i)
    enddo


	call mp_stop
	stop

 endif

 end subroutine interp_left_edge_1d
!------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     gsum :: get global sum
!
      real  function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast) result (gsum)
             
         integer,   intent(IN)    :: npx, npy
         integer,   intent(IN)    :: ifirst, ilast
         integer,   intent(IN)    :: jfirst, jlast
         real  , intent(IN)    :: p(ifirst:ilast,jfirst:jlast)      ! field to be summed
         
         integer :: i,j,k,n
         integer :: j1, j2
         real  :: gsum0
         real :: p_R8(npx-1,npy-1,ntiles_g)
         
         gsum = 0.
            
         if (latlon) then          
            j1 = 2                          
            j2 = npy-2
            gsum = gsum + p(1,1)*acapS
            gsum = gsum + p(1,npy-1)*acapN
            do j=j1,j2
               do i=1,npx-1
                  gsum = gsum + p(i,j)*cos(agrid(i,j,2))
               enddo
            enddo
         else

            do n=tile,tile            
               do j=jfirst,jlast
                  do i=ifirst,ilast
                     p_R8(i,j,n) = p(i,j)*area(i,j)
                  enddo
               enddo
            enddo
            call mp_gather(p_R8, ifirst,ilast, jfirst,jlast, npx-1, npy-1, ntiles_g)
            if (gid == masterproc) then
               do n=1,ntiles_g
                  do j=1,npy-1
                     do i=1,npx-1
                        gsum = gsum + p_R8(i,j,n)
                     enddo
                  enddo
               enddo
               gsum = gsum/globalarea
            endif
            call mp_bcst(gsum)

         endif

      end function globalsum
 

      end module fv_grid_tools_mod



module fv_io_mod
  !-----------------------------------------------------------------------
  !                   GNU General Public License                        
  !                                                                      
  ! This program is free software; you can redistribute it and/or modify it and  
  ! are expected to follow the terms of the GNU General Public License  
  ! as published by the Free Software Foundation; either version 2 of   
  ! the License, or (at your option) any later version.                 
  !                                                                      
  ! MOM 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.                                           
  !                                                                      
  ! For the full text of the GNU General Public License,                
  ! write to: Free Software Foundation, Inc.,                           
  !           675 Mass Ave, Cambridge, MA 02139, USA.                   
  ! or see:   http://www.gnu.org/licenses/gpl.html                      
  !-----------------------------------------------------------------------
  ! 
  ! <CONTACT EMAIL= "Jeffrey.Durachta@noaa.gov">Jeffrey Durachta </CONTACT>

  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

  !<OVERVIEW>
  ! Restart facilities for FV core
  !</OVERVIEW>
  !<DESCRIPTION>
  ! This module writes and reads restart files for the FV core. Additionally
  ! it provides setup and calls routines necessary to provide a complete restart
  ! for the model.
  !</DESCRIPTION>

  use fms_mod,                 only: file_exist, read_data, write_data, field_exist    
  use fms_io_mod,              only: fms_io_exit, get_tile_string, &
                                     restart_file_type, register_restart_field, &
                                     save_restart, restore_state, &
                                     set_domain, nullify_domain
  use mpp_mod,                 only: mpp_error, FATAL, NOTE
  use mpp_domains_mod,         only: domain2d, EAST, NORTH, mpp_get_tile_id, &
                                     mpp_get_compute_domain, mpp_get_data_domain, &
                                     mpp_get_ntile_count
  use tracer_manager_mod,      only: tr_get_tracer_names=>get_tracer_names, &
                                     get_tracer_names, get_number_tracers, &
                                     set_tracer_profile, &
                                     get_tracer_index
  use field_manager_mod,       only: MODEL_ATMOS  
  use external_sst_mod,        only: sst_ncep, sst_anom
  use fv_arrays_mod,           only: fv_atmos_type

  implicit none
  private

  public :: fv_io_init, fv_io_exit, fv_io_read_restart, remap_restart, fv_io_write_restart
  public :: fv_io_read_tracers, fv_io_register_restart

  logical                       :: module_is_initialized = .FALSE.

  !--- for restart file writing
  type(restart_file_type),        save :: Fv_restart
  type(restart_file_type),        save :: SST_restart
  type(restart_file_type), allocatable :: Fv_tile_restart(:)
  type(restart_file_type), allocatable :: Rsf_restart(:)
  type(restart_file_type), allocatable :: Mg_restart(:)
  type(restart_file_type), allocatable :: Lnd_restart(:)
  type(restart_file_type), allocatable :: Tra_restart(:)


  !--- version information variables ----
  character(len=128) :: version = '$Id: fv_io.F90,v 17.0.2.6.2.1.2.1 2009/11/17 19:27:13 pjp Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains 

  !#####################################################################
  ! <SUBROUTINE NAME="fv_io_init">
  !
  ! <DESCRIPTION>
  ! Initialize the fv core restart facilities
  ! </DESCRIPTION>
  !
  subroutine fv_io_init()
    module_is_initialized = .TRUE.
  end subroutine fv_io_init
  ! </SUBROUTINE> NAME="fv_io_init"


  !#####################################################################
  ! <SUBROUTINE NAME="fv_io_exit">
  !
  ! <DESCRIPTION>
  ! Close the fv core restart facilities
  ! </DESCRIPTION>
  !
  subroutine fv_io_exit
    module_is_initialized = .FALSE.
  end subroutine fv_io_exit
  ! </SUBROUTINE> NAME="fv_io_exit"



  !#####################################################################
  ! <SUBROUTINE NAME="fv_io_read_restart">
  !
  ! <DESCRIPTION>
  ! Write the fv core restart quantities 
  ! </DESCRIPTION>
  subroutine  fv_io_read_restart(fv_domain,Atm)
    type(domain2d),      intent(inout) :: fv_domain
    type(fv_atmos_type), intent(inout) :: Atm(:)

    character(len=64)    :: fname, fname_nd, tracer_name
    integer              :: isc, iec, jsc, jec, n, nt, nk, ntracers
    integer              :: ntileMe
    integer, allocatable :: tile_id(:)

    character(len=128)           :: tracer_longname, tracer_units

    ntileMe = size(Atm(:))  ! This will have to be modified for mult tiles per PE
    allocate(tile_id(ntileMe))
    tile_id = mpp_get_tile_id(fv_domain)
 
!   call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers)
    ntracers = size(Atm(1)%q,4)  ! Temporary until we get tracer manager integrated

    fname_nd = 'INPUT/sst_ncep.res.nc'
    if(file_exist(fname_nd))then
! sst_ncep may be used in free-running forecast mode
       call read_data(fname_nd, 'sst_ncep', sst_ncep)
       if (field_exist(fname_nd,'sst_anom')) then
           call read_data(fname_nd, 'sst_anom', sst_anom)
       else
           sst_anom(:,:) = 1.E8   ! make it big enough to cause blowup if used
       endif
    endif
 
    fname_nd = 'INPUT/fv_core.res.nc'
  ! write_data does not (yet?) support vector data and tiles
    call read_data(fname_nd, 'ak', Atm(1)%ak(:))
    call read_data(fname_nd, 'bk', Atm(1)%bk(:))
    call set_domain(fv_domain) 
   
    do n = 1, ntileMe
       isc = Atm(n)%isc; iec = Atm(n)%iec; jsc = Atm(n)%jsc; jec = Atm(n)%jec
       call get_tile_string(fname, 'INPUT/fv_core.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'u', Atm(n)%u(isc:iec,jsc:jec+1,:), domain=fv_domain, position=NORTH,tile_count=n)
         call read_data(fname, 'v', Atm(n)%v(isc:iec+1,jsc:jec,:), domain=fv_domain, position=EAST,tile_count=n)

       if ( Atm(n)%no_cgrid ) then
         if ( Atm(n)%init_wind_m ) then
             call mpp_error(NOTE,'==> note from fv_read_restart: (um,vm) initialized from current time step')
             Atm(n)%um(:,:,:) = Atm(n)%u(:,:,:)
             Atm(n)%vm(:,:,:) = Atm(n)%v(:,:,:)
         else
         call read_data(fname, 'um', Atm(n)%um(isc:iec,jsc:jec+1,:), domain=fv_domain, position=NORTH,tile_count=n)
         call read_data(fname, 'vm', Atm(n)%vm(isc:iec+1,jsc:jec,:), domain=fv_domain, position=EAST,tile_count=n)
         endif
       endif

         if ( (.not.Atm(n)%hydrostatic) .and. (.not.Atm(n)%make_nh) ) then
              call read_data(fname, 'W',     Atm(n)%w(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
              call read_data(fname, 'DZ', Atm(n)%delz(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
              if ( Atm(n)%hybrid_z .and. (.not. Atm(n)%make_hybrid_z) )   &
              call read_data(fname, 'ZE0', Atm(n)%ze0(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
         endif

         call read_data(fname, 'T', Atm(n)%pt(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
         call read_data(fname, 'delp', Atm(n)%delp(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
         call read_data(fname, 'phis', Atm(n)%phis(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
       else
         call mpp_error(FATAL,'==> Error from fv_read_restart: Expected file '//trim(fname)//' does not exist')
       endif

       call get_tile_string(fname, 'INPUT/fv_srf_wnd.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'u_srf', Atm(n)%u_srf(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
         call read_data(fname, 'v_srf', Atm(n)%v_srf(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
         if (field_exist(fname,'ts'))   &
               call read_data(fname, 'ts', Atm(n)%ts(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
         Atm(n)%srf_init = .true.
       else
         call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
         Atm(n)%srf_init = .false.
       endif

  if ( Atm(n)%fv_land ) then
!----------------------------------------------------------------------------------------------------------------
! Optional terrain deviation (sgh) and land fraction (oro)
       call get_tile_string(fname, 'INPUT/mg_drag.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'ghprime', Atm(n)%sgh(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
       else
         call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
       endif
! Land-water mask:
       call get_tile_string(fname, 'INPUT/fv_land.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'oro', Atm(n)%oro(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
       else
         call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
       endif
!----------------------------------------------------------------------------------------------------------------
  endif
       call get_tile_string(fname, 'INPUT/fv_tracer.res.tile', tile_id(n), '.nc' )

         DO nt = 1, ntracers
           call get_tracer_names(MODEL_ATMOS, nt, tracer_name)

           if (file_exist(fname)) then
              if (field_exist(fname,tracer_name)) then
                 call read_data(fname, tracer_name, Atm(n)%q(isc:iec,jsc:jec,:,nt), &
                                                      domain=fv_domain, tile_count=n)
                 call mpp_error(NOTE,'==>  Have read tracer '//trim(tracer_name)//' from fv_tracer.res')
                 cycle
              endif
           endif

           call set_tracer_profile (MODEL_ATMOS, nt, Atm(n)%q(isc:iec,jsc:jec,:,nt)  )
           call mpp_error(NOTE,'==>  Setting tracer '//trim(tracer_name)//' from set_tracer')
         ENDDO

    end do
 
    deallocate(tile_id)
    call nullify_domain()

  end subroutine  fv_io_read_restart
  ! </SUBROUTINE> NAME="fv_io_read_restart"
  !#####################################################################


  subroutine fv_io_read_tracers(fv_domain,Atm)
    type(domain2d),      intent(inout) :: fv_domain
    type(fv_atmos_type), intent(inout) :: Atm(:)

    character(len=64)    :: fname, fname_nd, tracer_name
    integer              :: isc, iec, jsc, jec, n, nt, nk, ntracers
    integer              :: ntileMe
    integer, allocatable :: tile_id(:)

    character(len=128)           :: tracer_longname, tracer_units

    ntileMe = size(Atm(:))  ! This will have to be modified for mult tiles per PE
    allocate(tile_id(ntileMe))
    tile_id = mpp_get_tile_id(fv_domain)

!   call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers)
    ntracers = size(Atm(1)%q,4)  ! Temporary until we get tracer manager integrated

    call set_domain(fv_domain) 
! skip the first tracer, which is sphum
    do n = 1, ntileMe
       isc = Atm(n)%isc; iec = Atm(n)%iec; jsc = Atm(n)%jsc; jec = Atm(n)%jec
       call get_tile_string(fname, 'INPUT/fv_tracer.res.tile', tile_id(n), '.nc' )
         DO nt = 2, ntracers
           call get_tracer_names(MODEL_ATMOS, nt, tracer_name)

           if (file_exist(fname)) then
              if (field_exist(fname,tracer_name)) then
                 call read_data(fname, tracer_name, Atm(n)%q(isc:iec,jsc:jec,:,nt), &
                                                      domain=fv_domain, tile_count=n)
                 call mpp_error(NOTE,'==>  Have read tracer '//trim(tracer_name)//' from fv_tracer.res')
                 cycle
              endif
           endif

           call set_tracer_profile (MODEL_ATMOS, nt, Atm(n)%q(isc:iec,jsc:jec,:,nt)  )
           call mpp_error(NOTE,'==>  Setting tracer '//trim(tracer_name)//' from set_tracer')
         ENDDO
    end do
    
    call nullify_domain()
    deallocate(tile_id)

  end subroutine  fv_io_read_tracers


  subroutine  remap_restart(fv_domain,Atm)
  use fv_mapz_mod,       only: rst_remap

    type(domain2d),      intent(inout) :: fv_domain
    type(fv_atmos_type), intent(inout) :: Atm(:)

    character(len=64)    :: fname, fname_nd, tracer_name
    integer              :: isc, iec, jsc, jec, n, nt, nk, ntracers
    integer              :: isd, ied, jsd, jed
    integer              :: ntileMe
    integer, allocatable :: tile_id(:)
!
!-------------------------------------------------------------------------
    real, allocatable:: ak_r(:), bk_r(:)
    real, allocatable:: u_r(:,:,:), v_r(:,:,:), pt_r(:,:,:), delp_r(:,:,:)
    real, allocatable:: w_r(:,:,:), delz_r(:,:,:), ze0_r(:,:,:)
    real, allocatable:: q_r(:,:,:,:)
!-------------------------------------------------------------------------
    integer npz, npz_rst, ng

    npz     = Atm(1)%npz       ! run time z dimension
    npz_rst = Atm(1)%npz_rst   ! restart z dimension
    isc = Atm(1)%isc; iec = Atm(1)%iec; jsc = Atm(1)%jsc; jec = Atm(1)%jec
    ng = Atm(1)%ng

    isd = isc - ng;  ied = iec + ng
    jsd = jsc - ng;  jed = jec + ng


!   call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers)
    ntracers = size(Atm(1)%q,4)  ! Temporary until we get tracer manager integrated

    ntileMe = size(Atm(:))  ! This will have to be modified for mult tiles per PE
    allocate(tile_id(ntileMe))
    tile_id = mpp_get_tile_id(fv_domain)


! Allocate arrays for reading old restart file:
    allocate ( ak_r(npz_rst+1) )
    allocate ( bk_r(npz_rst+1) )

    allocate ( u_r(isc:iec,  jsc:jec+1,npz_rst) )
    allocate ( v_r(isc:iec+1,jsc:jec  ,npz_rst) )

    allocate (   pt_r(isc:iec, jsc:jec,  npz_rst) )
    allocate ( delp_r(isc:iec, jsc:jec,  npz_rst) )
    allocate (    q_r(isc:iec, jsc:jec,  npz_rst, ntracers) )

    if ( (.not.Atm(1)%hydrostatic) .and. (.not.Atm(1)%make_nh) ) then
           allocate (    w_r(isc:iec, jsc:jec,  npz_rst) )
           allocate ( delz_r(isc:iec, jsc:jec,  npz_rst) )
           if ( Atm(1)%hybrid_z )   &
           allocate ( ze0_r(isc:iec, jsc:jec,  npz_rst+1) )
    endif

    fname_nd = 'INPUT/fv_core.res.nc'

  ! write_data does not (yet?) support vector data and tiles
    call read_data(fname_nd, 'ak', ak_r(1:npz_rst+1))
    call read_data(fname_nd, 'bk', bk_r(1:npz_rst+1))
    call set_domain(fv_domain) 

    do n = 1, ntileMe
       call get_tile_string(fname, 'INPUT/fv_core.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'u', u_r(isc:iec,jsc:jec+1,:), domain=fv_domain, position=NORTH,tile_count=n)
         call read_data(fname, 'v', v_r(isc:iec+1,jsc:jec,:), domain=fv_domain, position=EAST,tile_count=n)

         if ( (.not.Atm(n)%hydrostatic) .and. (.not.Atm(n)%make_nh) ) then
              call read_data(fname, 'W',     w_r(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
              call read_data(fname, 'DZ', delz_r(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
              if ( Atm(n)%hybrid_z )   &
              call read_data(fname, 'ZE0', ze0_r(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
         endif

         call read_data(fname, 'T', pt_r(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
         call read_data(fname, 'delp', delp_r(isc:iec,jsc:jec,:), domain=fv_domain, tile_count=n)
         call read_data(fname, 'phis', Atm(n)%phis(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
       else
         call mpp_error(FATAL,'==> Error from fv_read_restart: Expected file '//trim(fname)//' does not exist')
       endif

       call get_tile_string(fname, 'INPUT/fv_srf_wnd.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'u_srf', Atm(n)%u_srf(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
         call read_data(fname, 'v_srf', Atm(n)%v_srf(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
         if (field_exist(fname,'ts'))   &
               call read_data(fname, 'ts', Atm(n)%ts(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
         Atm(n)%srf_init = .true.
       else
         call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
         Atm(n)%srf_init = .false.
       endif

     if ( Atm(n)%fv_land ) then
! Optional terrain deviation (sgh)
       call get_tile_string(fname, 'INPUT/mg_drag.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'ghprime', Atm(n)%sgh(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
       else
         call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
       endif
! Land-water mask
       call get_tile_string(fname, 'INPUT/fv_land.res.tile', tile_id(n), '.nc' )
       if(file_exist(fname))then
         call read_data(fname, 'oro', Atm(n)%oro(isc:iec,jsc:jec), domain=fv_domain, tile_count=n)
       else
         call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
       endif
     endif

       call get_tile_string(fname, 'INPUT/fv_tracer.res.tile', tile_id(n), '.nc' )

       do nt = 1, ntracers
           call get_tracer_names(MODEL_ATMOS, nt, tracer_name)

          if(file_exist(fname))then
              if (field_exist(fname,tracer_name)) then
                 call read_data(fname, tracer_name, q_r(isc:iec,jsc:jec,:,nt), domain=fv_domain, tile_count=n)
                 call mpp_error(NOTE,'==>  Have read tracer '//trim(tracer_name)//' from fv_tracer.res')
                 cycle
              endif
          endif

          call set_tracer_profile (MODEL_ATMOS, nt, q_r(isc:iec,jsc:jec,:,nt)  )
          call mpp_error(NOTE,'==>  Setting tracer '//trim(tracer_name)//' from set_tracer')
       enddo

       call rst_remap(npz_rst, npz, isc, iec, jsc, jec, isd, ied, jsd, jed, ntracers,              &
                      delp_r,      u_r,      v_r,      w_r,      delz_r,      pt_r,      q_r,      &
                      Atm(n)%delp, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, Atm(n)%pt, Atm(n)%q, &
                      ak_r,  bk_r, Atm(n)%ak, Atm(n)%bk, Atm(n)%hydrostatic)
    end do

    call nullify_domain()

    deallocate(tile_id)
    deallocate( ak_r )
    deallocate( bk_r )
    deallocate( u_r )
    deallocate( v_r )
    deallocate( pt_r )
    deallocate( delp_r )
    deallocate( q_r )

    if ( (.not.Atm(1)%hydrostatic) .and. (.not.Atm(1)%make_nh) ) then
         deallocate ( w_r )
         deallocate ( delz_r )
         if ( Atm(1)%hybrid_z ) deallocate ( ze0_r )
    endif

  end subroutine  remap_restart



  !#####################################################################
  ! <SUBROUTINE NAME="fv_io_register_restart">
  !
  ! <DESCRIPTION>
  !   register restart field to be written out to restart file. 
  ! </DESCRIPTION>
  subroutine  fv_io_register_restart(fv_domain,Atm)
    type(domain2d),      intent(inout) :: fv_domain
    type(fv_atmos_type), intent(inout) :: Atm(:)

    character(len=64) :: fname_nd, tracer_name
    integer           :: id_restart
    integer           :: n, nt, ntracers, ntileMe, ntiles

    ntileMe = size(Atm(:)) 
    ntracers = size(Atm(1)%q,4) 

    fname_nd = 'fv_core.res.nc'
    id_restart = register_restart_field(Fv_restart, fname_nd, 'ak', Atm(1)%ak(:))
    id_restart = register_restart_field(Fv_restart, fname_nd, 'bk', Atm(1)%bk(:)) 

    allocate(Fv_tile_restart(ntileMe), Rsf_restart(ntileMe) )
    allocate(Mg_restart(ntileMe), Lnd_restart(ntileMe), Tra_restart(ntileMe) )


! fix for single tile runs where you need fv_core.res.nc and fv_core.res.tile1.nc
    ntiles = mpp_get_ntile_count(fv_domain)
    if(ntiles == 1) fname_nd =  'fv_core.res.tile1.nc'

    do n = 1, ntileMe
       id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'u', Atm(n)%u, &
                     domain=fv_domain, position=NORTH,tile_count=n)
       id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'v', Atm(n)%v, &
                     domain=fv_domain, position=EAST,tile_count=n)
       if (.not.Atm(n)%hydrostatic) then
          id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'W', Atm(n)%w, &
                        domain=fv_domain, tile_count=n, mandatory=.false.)
          id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'DZ', Atm(n)%delz, &
                        domain=fv_domain, tile_count=n, mandatory=.false.)
          if ( Atm(n)%hybrid_z ) then
             id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'ZE0', Atm(n)%ze0, &
                           domain=fv_domain, tile_count=n, mandatory=.false.)
          endif
       endif
       id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'T', Atm(n)%pt, &
                     domain=fv_domain, tile_count=n)
       id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'delp', Atm(n)%delp, &
                     domain=fv_domain, tile_count=n)
       id_restart =  register_restart_field(Fv_tile_restart(n), fname_nd, 'phis', Atm(n)%phis, &
                     domain=fv_domain, tile_count=n)

       fname_nd = 'fv_srf_wnd.res.nc'
       if(ntiles == 1) fname_nd = 'fv_srf_wnd.res.tile1.nc'
       id_restart =  register_restart_field(Rsf_restart(n), fname_nd, 'u_srf', Atm(n)%u_srf, &
                     domain=fv_domain, tile_count=n)
       id_restart =  register_restart_field(Rsf_restart(n), fname_nd, 'v_srf', Atm(n)%v_srf, &
                     domain=fv_domain, tile_count=n)

       if ( Atm(n)%fv_land ) then
          !-------------------------------------------------------------------------------------------------
          ! Optional terrain deviation (sgh) and land fraction (oro)
          fname_nd = 'mg_drag.res.nc'
          id_restart =  register_restart_field(Mg_restart(n), fname_nd, 'ghprime', Atm(n)%sgh, &
                        domain=fv_domain, tile_count=n)  

          fname_nd = 'fv_land.res.nc'
          id_restart = register_restart_field(Lnd_restart(n), fname_nd, 'oro', Atm(n)%oro, &
                        domain=fv_domain, tile_count=n)
       endif
       fname_nd = 'fv_tracer.res.nc'
       if(ntiles == 1) fname_nd = 'fv_tracer.res.tile1.nc'
       do nt = 1, ntracers
          call get_tracer_names(MODEL_ATMOS, nt, tracer_name)
          id_restart = register_restart_field(Tra_restart(n), fname_nd, tracer_name, Atm(n)%q(:,:,:,nt), &
                       domain=fv_domain, tile_count=n, mandatory=.false.)
       enddo

    enddo

! sst_ncep and sst_anom may be used in free-running forecast mode
    if ( Atm(1)%nudge .or. Atm(1)%ncep_ic ) then
       fname_nd = 'sst_ncep.res.nc'
       id_restart = register_restart_field(SST_restart, fname_nd, 'sst_ncep', sst_ncep)
       id_restart = register_restart_field(SST_restart, fname_nd, 'sst_anom', sst_anom)
    endif

  end subroutine  fv_io_register_restart
  ! </SUBROUTINE> NAME="fv_io_register_restart"



  !#####################################################################
  ! <SUBROUTINE NAME="fv_io_write_restart">
  !
  ! <DESCRIPTION>
  ! Write the fv core restart quantities 
  ! </DESCRIPTION>
  subroutine  fv_io_write_restart(Atm, timestamp)
    type(fv_atmos_type),        intent(in) :: Atm(:)
    character(len=*), optional, intent(in) :: timestamp
    integer                                :: n, ntileMe

    ntileMe = size(Atm(:))  ! This will need mods for more than 1 tile per pe

    call save_restart(Fv_restart, timestamp)

    if ( Atm(1)%nudge .or. Atm(1)%ncep_ic ) then
       call save_restart(SST_restart, timestamp)
    endif
 
    do n = 1, ntileMe
       call save_restart(Fv_tile_restart(n), timestamp)
       call save_restart(Rsf_restart(n), timestamp)

       if ( Atm(n)%fv_land ) then
          call save_restart(Mg_restart(n), timestamp)
          call save_restart(Lnd_restart(n), timestamp)
       endif

       call save_restart(Tra_restart(n), timestamp)
    end do

  end subroutine  fv_io_write_restart
  ! </SUBROUTINE> NAME="fv_io_write_restart"
  !#####################################################################

end module fv_io_mod


!------------------------------------------------------------------------------
!BOP
!
! !MODULE: fv_mp_mod --- SPMD parallel decompostion/communication module
      module fv_mp_mod

#if defined(SPMD)
! !USES:
      use fms_mod,         only : fms_init, fms_end
      use mpp_mod,         only : FATAL, MPP_DEBUG, NOTE, MPP_CLOCK_SYNC,MPP_CLOCK_DETAILED
      use mpp_mod,         only : mpp_pe, mpp_npes, mpp_node, mpp_root_pe, mpp_error, mpp_set_warn_level
      use mpp_mod,         only : mpp_declare_pelist, mpp_set_current_pelist, mpp_sync
      use mpp_mod,         only : mpp_clock_begin, mpp_clock_end, mpp_clock_id
      use mpp_mod,         only : mpp_chksum, stdout, stderr, mpp_broadcast
      use mpp_mod,         only : mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_gather
      use mpp_domains_mod, only : GLOBAL_DATA_DOMAIN, BITWISE_EXACT_SUM, BGRID_NE, FOLD_NORTH_EDGE, CGRID_NE
      use mpp_domains_mod, only : MPP_DOMAIN_TIME, CYCLIC_GLOBAL_DOMAIN, NUPDATE,EUPDATE, XUPDATE, YUPDATE, SCALAR_PAIR
      use mpp_domains_mod, only : domain1D, domain2D, DomainCommunicator2D
      use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_domains_set_stack_size
      use mpp_domains_mod, only : mpp_global_field, mpp_global_sum, mpp_global_max, mpp_global_min
      use mpp_domains_mod, only : mpp_domains_init, mpp_domains_exit, mpp_broadcast_domain
      use mpp_domains_mod, only : mpp_check_field, mpp_define_layout 
      use mpp_domains_mod, only : mpp_get_neighbor_pe, mpp_define_mosaic, mpp_define_io_domain
      use mpp_domains_mod, only : NORTH, NORTH_EAST, EAST, SOUTH_EAST
      use mpp_domains_mod, only : SOUTH, SOUTH_WEST, WEST, NORTH_WEST
      use mpp_parameter_mod, only : WUPDATE, EUPDATE, SUPDATE, NUPDATE, XUPDATE, YUPDATE

      implicit none
      private

#include "mpif.h"
      integer, parameter :: XDir=1
      integer, parameter :: YDir=2
      integer :: npes, npes_x, npes_y, gid, masterproc, commglobal, ierror
      integer :: io_domain_layout(2) = (/1,1/)

      type(domain2D), target, save :: domain
      type(domain2D), target, save :: domain_for_coupler ! domain used in coupled model with halo = 1.
      integer :: num_contact, ntiles, npes_per_tile, tile
      integer, allocatable, dimension(:)       :: npes_tile, tile1, tile2
      integer, allocatable, dimension(:)       :: istart1, iend1, jstart1, jend1
      integer, allocatable, dimension(:)       :: istart2, iend2, jstart2, jend2
      integer, allocatable, dimension(:,:)     :: layout2D, global_indices
      integer, parameter:: ng    = 3     ! Number of ghost zones required
      integer :: is, ie, js, je, isd, ied, jsd, jed
      integer :: numthreads
      logical:: square_domain = .false.

      
      public mp_start, mp_barrier, mp_stop, npes, npes_x, npes_y, ng, gid, masterproc
      public io_domain_layout, square_domain
      public domain, tile, domain_for_coupler
      public is, ie, js, je, isd, ied, jsd, jed
      public domain_decomp, mp_bcst, mp_reduce_max, mp_reduce_sum, mp_gather
      public mp_reduce_min
      public fill_corners, mp_corner_comm, XDir, YDir
      public numthreads

      INTERFACE fill_corners
        MODULE PROCEDURE fill_corners_2d
        MODULE PROCEDURE fill_corners_xy_2d
        MODULE PROCEDURE fill_corners_xy_3d
      END INTERFACE

      INTERFACE mp_bcst
        MODULE PROCEDURE mp_bcst_i4
        MODULE PROCEDURE mp_bcst_r8
        MODULE PROCEDURE mp_bcst_3d_r8
        MODULE PROCEDURE mp_bcst_4d_r8
      END INTERFACE

      INTERFACE mp_reduce_max
        MODULE PROCEDURE mp_reduce_max_r8_1d
        MODULE PROCEDURE mp_reduce_max_r8
        MODULE PROCEDURE mp_reduce_max_i4
      END INTERFACE

      INTERFACE mp_reduce_sum
        MODULE PROCEDURE mp_reduce_sum_r8
        MODULE PROCEDURE mp_reduce_sum_r8_1d
      END INTERFACE

      INTERFACE mp_gather
        MODULE PROCEDURE mp_gather_4d_r4
        MODULE PROCEDURE mp_gather_3d_r4
        MODULE PROCEDURE mp_gather_3d_r8
      END INTERFACE

!---- version number -----
      character(len=128) :: version = '$Id: fv_mp_mod.F90,v 17.0.4.3.2.2 2010/05/08 03:30:28 z1l Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_start :: Start SPMD processes
!
        subroutine mp_start(commID)
          integer, intent(in), optional :: commID

         integer :: ios
         integer :: unit
         character(len=80) evalue

         gid = mpp_pe()
         npes = mpp_npes()

         masterproc = mpp_root_pe()
         commglobal = MPI_COMM_WORLD
         if( PRESENT(commID) )then
             commglobal = commID
         end if

         numthreads = 1
         if (gid==masterproc) then
           call getenv('OMP_NUM_THREADS',evalue)
           read(evalue,*,iostat=ios) numthreads
           if ( ios .ne. 0 ) then
               print *, 'WARNING: cannot read OMP_NUM_THREADS, defaults to 1', &
                        trim(evalue)
               numthreads = 1
           end if
         endif
         call mpp_broadcast(numthreads, masterproc)
!         call mp_bcst(numthreads)

         if ( mpp_pe()==mpp_root_pe() ) then
           unit = stdout()
           write(unit,*) 'Starting PEs : ', npes
           write(unit,*) 'Starting Threads : ', numthreads
         endif

         call MPI_BARRIER(commglobal, ierror)
      end subroutine mp_start
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_barrier :: Wait for all SPMD processes
!
      subroutine mp_barrier()
        
         call MPI_BARRIER(commglobal, ierror)
      
      end subroutine mp_barrier
!       
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_stop :: Stop SPMD processes
!
      subroutine mp_stop()

         call MPI_BARRIER(commglobal, ierror)
         if (gid==masterproc) print*, 'Stopping PEs : ', npes
         call fms_end()
        ! call MPI_FINALIZE (ierror)

      end subroutine mp_stop
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     domain_decomp :: Setup domain decomp
!
      subroutine domain_decomp(npx,npy,nregions,ng,grid_type)

         integer, intent(IN)  :: npx,npy,nregions,ng,grid_type

         integer :: layout(2)
         integer, allocatable :: pe_start(:), pe_end(:)

         character(len=80) :: evalue
         integer :: ios,nx,ny,n,num_alloc
         character(len=32) :: type = "unknown"
         logical :: is_symmetry 
         logical :: debug=.false.

         nx = npx-1
         ny = npy-1

         call mpp_domains_init(MPP_DOMAIN_TIME)

       ! call mpp_domains_set_stack_size(10000)
       ! call mpp_domains_set_stack_size(900000)
         call mpp_domains_set_stack_size(1500000)

         select case(nregions)
         case ( 1 )  ! Lat-Lon "cyclic"

            select case (grid_type)
            case (3)   ! Lat-Lon "cyclic"
               type="Lat-Lon: cyclic"
               ntiles = 4
               num_contact = 8
               if( mod(npes,ntiles) .NE. 0 ) then
                  call mpp_error(NOTE,'TEST_MPP_DOMAINS: for Cyclic mosaic, npes should be multiple of ntiles. ' // &
                                       'No test is done for Cyclic mosaic. ' )
                  return
               end if
               npes_per_tile = npes/ntiles
               call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout )
               layout = (/1,npes_per_tile/) ! force decomp only in Lat-Direction
            case (4)   ! Cartesian, double periodic
               type="Cartesian: double periodic"
               ntiles = 1
               num_contact = 2
               npes_per_tile = npes/ntiles
               if(npes_x*npes_y == npes_per_tile) then
                  layout = (/npes_x,npes_y/)
               else
                  call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout )
               endif
            case (5)   ! latlon patch
               type="Lat-Lon: patch"
               ntiles = 1
               num_contact = 0
               npes_per_tile = npes/ntiles
               call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout )
            case (6)   ! latlon strip
               type="Lat-Lon: strip"
               ntiles = 1
               num_contact = 1
               npes_per_tile = npes/ntiles
               call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout )
            case (7)   ! Cartesian, channel
               type="Cartesian: channel"
               ntiles = 1
               num_contact = 1
               npes_per_tile = npes/ntiles
               call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout )
            end select

         case ( 6 )  ! Cubed-Sphere
            type="Cubic: cubed-sphere"
            ntiles = 6
            num_contact = 12
            !--- cubic grid always have six tiles, so npes should be multiple of 6
            if( mod(npes,ntiles) .NE. 0 .OR. npx-1 .NE. npy-1) then
               call mpp_error(NOTE,'domain_decomp: for Cubic_grid mosaic, npes should be multiple of ntiles(6) ' // &
                                   'and npx-1 should equal npy-1, domain_decomp is NOT done for Cubic-grid mosaic. ' )
               return
            end if
            npes_per_tile = npes/ntiles
            call  mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout )

            if ( npes_x == 0 ) then 
               npes_x = layout(1)
            endif
            if ( npes_y == 0 ) then
               npes_y = layout(2)
            endif

            if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x )  square_domain = .true.

            if ( (npx/npes_x < ng) .or. (npy/npes_y < ng) ) then
               write(*,310) npes_x, npes_y, npx/npes_x, npy/npes_y
 310           format('Invalid layout, NPES_X:',i4.4,'NPES_Y:',i4.4,'ncells_X:',i4.4,'ncells_Y:',i4.4)
               call mp_stop
               call exit(1)
            endif
           
            layout = (/npes_x,npes_y/)
         case default
            call mpp_error(FATAL, 'domain_decomp: no such test: '//type)
         end select

         allocate(layout2D(2,ntiles), global_indices(4,ntiles), npes_tile(ntiles) )
         allocate(pe_start(ntiles),pe_end(ntiles))
         npes_tile = npes_per_tile
         do n = 1, ntiles
            global_indices(:,n) = (/1,npx-1,1,npy-1/)
            layout2D(:,n)         = layout
            pe_start(n) = mpp_root_pe() + (n-1)*layout(1)*layout(2)
            pe_end(n)   = pe_start(n) + layout(1)*layout(2) -1
         end do
         num_alloc=max(1,num_contact)
         allocate(tile1(num_alloc), tile2(num_alloc) )
         allocate(istart1(num_alloc), iend1(num_alloc), jstart1(num_alloc), jend1(num_alloc) )
         allocate(istart2(num_alloc), iend2(num_alloc), jstart2(num_alloc), jend2(num_alloc) )
 
         is_symmetry = .true.
         select case(nregions)
         case ( 1 )

            select case (grid_type)
            case (3)   ! Lat-Lon "cyclic"
               !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST)
               tile1(1) = 1; tile2(1) = 2
               istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
               istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
               !--- Contact line 2, between tile 1 (SOUTH) and tile 3 (NORTH)  --- cyclic
               tile1(2) = 1; tile2(2) = 3
               istart1(2) = 1;  iend1(2) = nx; jstart1(2) = 1;   jend1(2) = 1
               istart2(2) = 1;  iend2(2) = nx; jstart2(2) = ny;  jend2(2) = ny
               !--- Contact line 3, between tile 1 (WEST) and tile 2 (EAST) --- cyclic
               tile1(3) = 1; tile2(3) = 2
               istart1(3) = 1;  iend1(3) = 1;  jstart1(3) = 1;  jend1(3) = ny
               istart2(3) = nx; iend2(3) = nx; jstart2(3) = 1;  jend2(3) = ny
               !--- Contact line 4, between tile 1 (NORTH) and tile 3 (SOUTH)
               tile1(4) = 1; tile2(4) = 3
               istart1(4) = 1;  iend1(4) = nx; jstart1(4) = ny;  jend1(4) = ny
               istart2(4) = 1;  iend2(4) = nx; jstart2(4) = 1;   jend2(4) = 1
               !--- Contact line 5, between tile 2 (SOUTH) and tile 4 (NORTH) --- cyclic
               tile1(5) = 2; tile2(5) = 4
               istart1(5) = 1;  iend1(5) = nx; jstart1(5) = 1;  jend1(5) = 1
               istart2(5) = 1;  iend2(5) = nx; jstart2(5) = ny; jend2(5) = ny
               !--- Contact line 6, between tile 2 (NORTH) and tile 4 (SOUTH)
               tile1(6) = 2; tile2(6) = 4
               istart1(6) = 1;  iend1(6) = nx; jstart1(6) = ny;  jend1(6) = ny
               istart2(6) = 1;  iend2(6) = nx; jstart2(6) = 1;   jend2(6) = 1
               !--- Contact line 7, between tile 3 (EAST) and tile 4 (WEST)
               tile1(7) = 3; tile2(7) = 4
               istart1(7) = nx; iend1(7) = nx; jstart1(7) = 1;  jend1(7) = ny
               istart2(7) = 1;  iend2(7) = 1;  jstart2(7) = 1;  jend2(7) = ny
               !--- Contact line 8, between tile 3 (WEST) and tile 4 (EAST) --- cyclic
               tile1(8) = 3; tile2(8) = 4
               istart1(8) = 1;  iend1(8) = 1;  jstart1(8) = 1;  jend1(8) = ny
               istart2(8) = nx; iend2(8) = nx; jstart2(8) = 1;  jend2(8) = ny
               is_symmetry = .false.
            case (4)   ! Cartesian, double periodic
               !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST)
               tile1(1) = 1; tile2(1) = 1
               istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
               istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
               !--- Contact line 2, between tile 1 (SOUTH) and tile 1 (NORTH)  --- cyclic
               tile1(2) = 1; tile2(2) = 1
               istart1(2) = 1;  iend1(2) = nx; jstart1(2) = 1;   jend1(2) = 1
               istart2(2) = 1;  iend2(2) = nx; jstart2(2) = ny;  jend2(2) = ny
            case (5)   ! latlon patch

            case (6)   !latlon strip
               !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST)
               tile1(1) = 1; tile2(1) = 1
               istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
               istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
            case (7)   ! Cartesian, channel
               !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST)
               tile1(1) = 1; tile2(1) = 1
               istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
               istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
            end select

         case ( 6 )  ! Cubed-Sphere
            !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST)
            tile1(1) = 1; tile2(1) = 2
            istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
            istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
            !--- Contact line 2, between tile 1 (NORTH) and tile 3 (WEST)
            tile1(2) = 1; tile2(2) = 3
            istart1(2) = 1;  iend1(2) = nx; jstart1(2) = ny; jend1(2) = ny
            istart2(2) = 1;  iend2(2) = 1;  jstart2(2) = ny; jend2(2) = 1
            !--- Contact line 3, between tile 1 (WEST) and tile 5 (NORTH)
            tile1(3) = 1; tile2(3) = 5
            istart1(3) = 1;  iend1(3) = 1;  jstart1(3) = 1;  jend1(3) = ny
            istart2(3) = nx; iend2(3) = 1;  jstart2(3) = ny; jend2(3) = ny
            !--- Contact line 4, between tile 1 (SOUTH) and tile 6 (NORTH)
            tile1(4) = 1; tile2(4) = 6
            istart1(4) = 1;  iend1(4) = nx; jstart1(4) = 1;  jend1(4) = 1
            istart2(4) = 1;  iend2(4) = nx; jstart2(4) = ny; jend2(4) = ny
            !--- Contact line 5, between tile 2 (NORTH) and tile 3 (SOUTH)
            tile1(5) = 2; tile2(5) = 3
            istart1(5) = 1;  iend1(5) = nx; jstart1(5) = ny; jend1(5) = ny
            istart2(5) = 1;  iend2(5) = nx; jstart2(5) = 1;  jend2(5) = 1
            !--- Contact line 6, between tile 2 (EAST) and tile 4 (SOUTH)
            tile1(6) = 2; tile2(6) = 4
            istart1(6) = nx; iend1(6) = nx; jstart1(6) = 1;  jend1(6) = ny
            istart2(6) = nx; iend2(6) = 1;  jstart2(6) = 1;  jend2(6) = 1
            !--- Contact line 7, between tile 2 (SOUTH) and tile 6 (EAST)
            tile1(7) = 2; tile2(7) = 6
            istart1(7) = 1;  iend1(7) = nx; jstart1(7) = 1;  jend1(7) = 1
            istart2(7) = nx; iend2(7) = nx; jstart2(7) = ny; jend2(7) = 1
            !--- Contact line 8, between tile 3 (EAST) and tile 4 (WEST)
            tile1(8) = 3; tile2(8) = 4
            istart1(8) = nx; iend1(8) = nx; jstart1(8) = 1;  jend1(8) = ny
            istart2(8) = 1;  iend2(8) = 1;  jstart2(8) = 1;  jend2(8) = ny
            !--- Contact line 9, between tile 3 (NORTH) and tile 5 (WEST)
            tile1(9) = 3; tile2(9) = 5
            istart1(9) = 1;  iend1(9) = nx; jstart1(9) = ny; jend1(9) = ny
            istart2(9) = 1;  iend2(9) = 1;  jstart2(9) = ny; jend2(9) = 1
            !--- Contact line 10, between tile 4 (NORTH) and tile 5 (SOUTH)
            tile1(10) = 4; tile2(10) = 5
            istart1(10) = 1;  iend1(10) = nx; jstart1(10) = ny; jend1(10) = ny
            istart2(10) = 1;  iend2(10) = nx; jstart2(10) = 1;  jend2(10) = 1
            !--- Contact line 11, between tile 4 (EAST) and tile 6 (SOUTH)
            tile1(11) = 4; tile2(11) = 6
            istart1(11) = nx; iend1(11) = nx; jstart1(11) = 1;  jend1(11) = ny
            istart2(11) = nx; iend2(11) = 1;  jstart2(11) = 1;  jend2(11) = 1
            !--- Contact line 12, between tile 5 (EAST) and tile 6 (WEST)
            tile1(12) = 5; tile2(12) = 6
            istart1(12) = nx; iend1(12) = nx; jstart1(12) = 1;  jend1(12) = ny
            istart2(12) = 1;  iend2(12) = 1;  jstart2(12) = 1;  jend2(12) = ny
         end select

       call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                              istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                              pe_start=pe_start, pe_end=pe_end, symmetry=is_symmetry,              &
                              shalo = ng, nhalo = ng, whalo = ng, ehalo = ng, name = type)
       call mpp_define_mosaic(global_indices, layout2D, domain_for_coupler, ntiles, num_contact, tile1, tile2, &
                              istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,                  &
                              pe_start=pe_start, pe_end=pe_end, symmetry=is_symmetry,                          &
                              shalo = 1, nhalo = 1, whalo = 1, ehalo = 1, name = type)

       call mpp_define_io_domain(domain, io_domain_layout)
       call mpp_define_io_domain(domain_for_coupler, io_domain_layout)

       deallocate(pe_start,pe_end)

        !--- find the tile number
         tile = (mpp_pe()-mpp_root_pe())/npes_per_tile+1
         call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
         call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )

         if (debug .and. nregions==1) then
            tile=1
            write(*,200) tile, is, ie, js, je
         !   call mp_stop
         !   stop
         endif
 200     format(i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ')

      end subroutine domain_decomp
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !!
!     
      subroutine fill_corners_2d(q, npx, npy, FILL, AGRID, BGRID)
         real, DIMENSION(isd:,jsd:), intent(INOUT):: q
         integer, intent(IN):: npx,npy
         integer, intent(IN):: FILL  ! X-Dir or Y-Dir 
         logical, OPTIONAL, intent(IN) :: AGRID, BGRID 
         integer :: i,j

         if (present(BGRID)) then
            if (BGRID) then
              select case (FILL)
              case (XDir)
                 do j=1,ng
                    do i=1,ng
                     if ((is==    1) .and. (js==    1)) q(1-i  ,1-j  ) = q(1-j  ,i+1    )  !SW Corner 
                     if ((is==    1) .and. (je==npy-1)) q(1-i  ,npy+j) = q(1-j  ,npy-i  )  !NW Corner
                     if ((ie==npx-1) .and. (js==    1)) q(npx+i,1-j  ) = q(npx+j,i+1    )  !SE Corner
                     if ((ie==npx-1) .and. (je==npy-1)) q(npx+i,npy+j) = q(npx+j,npy-i  )  !NE Corner
                    enddo
                 enddo
              case (YDir)
                 do j=1,ng
                    do i=1,ng
                     if ((is==    1) .and. (js==    1)) q(1-j  ,1-i  ) = q(i+1  ,1-j    )  !SW Corner 
                     if ((is==    1) .and. (je==npy-1)) q(1-j  ,npy+i) = q(i+1  ,npy+j  )  !NW Corner
                     if ((ie==npx-1) .and. (js==    1)) q(npx+j,1-i  ) = q(npx-i,1-j    )  !SE Corner
                     if ((ie==npx-1) .and. (je==npy-1)) q(npx+j,npy+i) = q(npx-i,npy+j  )  !NE Corner
                    enddo
                 enddo
              case default
                 do j=1,ng
                    do i=1,ng
                     if ((is==    1) .and. (js==    1)) q(1-i  ,1-j  ) = q(1-j  ,i+1    )  !SW Corner 
                     if ((is==    1) .and. (je==npy-1)) q(1-i  ,npy+j) = q(1-j  ,npy-i  )  !NW Corner
                     if ((ie==npx-1) .and. (js==    1)) q(npx+i,1-j  ) = q(npx+j,i+1    )  !SE Corner
                     if ((ie==npx-1) .and. (je==npy-1)) q(npx+i,npy+j) = q(npx+j,npy-i  )  !NE Corner
                    enddo
                 enddo
              end select
            endif
          elseif (present(AGRID)) then
            if (AGRID) then
              select case (FILL)
              case (XDir)
                 do j=1,ng
                    do i=1,ng
                       if ((is==    1) .and. (js==    1)) q(1-i    ,1-j    ) = q(1-j    ,i        )  !SW Corner 
                       if ((is==    1) .and. (je==npy-1)) q(1-i    ,npy-1+j) = q(1-j    ,npy-1-i+1)  !NW Corner
                       if ((ie==npx-1) .and. (js==    1)) q(npx-1+i,1-j    ) = q(npx-1+j,i        )  !SE Corner
                       if ((ie==npx-1) .and. (je==npy-1)) q(npx-1+i,npy-1+j) = q(npx-1+j,npy-1-i+1)  !NE Corner
                    enddo
                 enddo
              case (YDir)
                 do j=1,ng
                    do i=1,ng
                       if ((is==    1) .and. (js==    1)) q(1-j    ,1-i    ) = q(i        ,1-j    )  !SW Corner 
                       if ((is==    1) .and. (je==npy-1)) q(1-j    ,npy-1+i) = q(i        ,npy-1+j)  !NW Corner
                       if ((ie==npx-1) .and. (js==    1)) q(npx-1+j,1-i    ) = q(npx-1-i+1,1-j    )  !SE Corner
                       if ((ie==npx-1) .and. (je==npy-1)) q(npx-1+j,npy-1+i) = q(npx-1-i+1,npy-1+j)  !NE Corner
                    enddo
                 enddo
              case default
                 do j=1,ng
                    do i=1,ng        
                       if ((is==    1) .and. (js==    1)) q(1-j    ,1-i    ) = q(i        ,1-j    )  !SW Corner 
                       if ((is==    1) .and. (je==npy-1)) q(1-j    ,npy-1+i) = q(i        ,npy-1+j)  !NW Corner
                       if ((ie==npx-1) .and. (js==    1)) q(npx-1+j,1-i    ) = q(npx-1-i+1,1-j    )  !SE Corner
                       if ((ie==npx-1) .and. (je==npy-1)) q(npx-1+j,npy-1+i) = q(npx-1-i+1,npy-1+j)  !NE Corner
                   enddo
                 enddo          
              end select
            endif
          endif

      end subroutine fill_corners_2d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !!
!     fill_corners_xy_2d
      subroutine fill_corners_xy_2d(x, y, npx, npy, DGRID, AGRID, CGRID, VECTOR)
         real, DIMENSION(isd:,jsd:), intent(INOUT):: x !(isd:ied  ,jsd:jed+1)
         real, DIMENSION(isd:,jsd:), intent(INOUT):: y !(isd:ied+1,jsd:jed  )
         integer, intent(IN):: npx,npy
         logical, OPTIONAL, intent(IN) :: DGRID, AGRID, CGRID, VECTOR
         integer :: i,j

         real :: mySign

         mySign = 1.0
         if (present(VECTOR)) then
            if (VECTOR) mySign = -1.0
         endif

         if (present(DGRID)) then
            call fill_corners_dgrid(x, y, npx, npy, mySign)
         elseif (present(CGRID)) then
            call fill_corners_cgrid(x, y, npx, npy, mySign)
         elseif (present(AGRID)) then
            call fill_corners_agrid(x, y, npx, npy, mySign)
         else
            call fill_corners_agrid(x, y, npx, npy, mySign)
         endif

      end subroutine fill_corners_xy_2d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !!
!     fill_corners_xy_3d
      subroutine fill_corners_xy_3d(x, y, npx, npy, npz, DGRID, AGRID, CGRID, VECTOR)
         real, DIMENSION(isd:,jsd:,:), intent(INOUT):: x !(isd:ied  ,jsd:jed+1)
         real, DIMENSION(isd:,jsd:,:), intent(INOUT):: y !(isd:ied+1,jsd:jed  )
         integer, intent(IN):: npx,npy,npz
         logical, OPTIONAL, intent(IN) :: DGRID, AGRID, CGRID, VECTOR
         integer :: i,j,k

         real :: mySign

         mySign = 1.0
         if (present(VECTOR)) then
            if (VECTOR) mySign = -1.0
         endif

         if (present(DGRID)) then
            do k=1,npz
               call fill_corners_dgrid(x(:,:,k), y(:,:,k), npx, npy, mySign)
            enddo
         elseif (present(CGRID)) then
            do k=1,npz
               call fill_corners_cgrid(x(:,:,k), y(:,:,k), npx, npy, mySign)
            enddo
         elseif (present(AGRID)) then
            do k=1,npz
               call fill_corners_agrid(x(:,:,k), y(:,:,k), npx, npy, mySign)
            enddo
         else
            do k=1,npz
               call fill_corners_agrid(x(:,:,k), y(:,:,k), npx, npy, mySign)
            enddo
         endif

      end subroutine fill_corners_xy_3d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
      subroutine fill_corners_dgrid(x, y, npx, npy, mySign)
         real, DIMENSION(isd:,jsd:), intent(INOUT):: x
         real, DIMENSION(isd:,jsd:), intent(INOUT):: y
         integer, intent(IN):: npx,npy
         real, intent(IN) :: mySign 
         integer :: i,j

               do j=1,ng
                  do i=1,ng
                   !   if ((is  ==  1) .and. (js  ==  1)) x(1-i    ,1-j  ) =        y(j+1  ,1-i    )  !SW Corner 
                   !   if ((is  ==  1) .and. (je+1==npy)) x(1-i    ,npy+j) = mySign*y(j+1  ,npy-1+i)  !NW Corner
                   !   if ((ie+1==npx) .and. (js  ==  1)) x(npx-1+i,1-j  ) = mySign*y(npx-j,1-i    )  !SE Corner
                   !   if ((ie+1==npx) .and. (je+1==npy)) x(npx-1+i,npy+j) =        y(npx-j,npy-1+i)  !NE Corner
                      if ((is  ==  1) .and. (js  ==  1)) x(1-i    ,1-j  ) = mySign*y(1-j  ,i    )  !SW Corner 
                      if ((is  ==  1) .and. (je+1==npy)) x(1-i    ,npy+j) =        y(1-j  ,npy-i)  !NW Corner
                      if ((ie+1==npx) .and. (js  ==  1)) x(npx-1+i,1-j  ) =        y(npx+j,i    )  !SE Corner
                      if ((ie+1==npx) .and. (je+1==npy)) x(npx-1+i,npy+j) = mySign*y(npx+j,npy-i)  !NE Corner
                  enddo
               enddo
               do j=1,ng
                  do i=1,ng
                   !  if ((is  ==  1) .and. (js  ==  1)) y(1-i    ,1-j    ) =        x(1-j    ,i+1  )  !SW Corner 
                   !  if ((is  ==  1) .and. (je+1==npy)) y(1-i    ,npy-1+j) = mySign*x(1-j    ,npy-i)  !NW Corner
                   !  if ((ie+1==npx) .and. (js  ==  1)) y(npx+i  ,1-j    ) = mySign*x(npx-1+j,i+1  )  !SE Corner
                   !  if ((ie+1==npx) .and. (je+1==npy)) y(npx+i  ,npy-1+j) =        x(npx-1+j,npy-i)  !NE Corner
                     if ((is  ==  1) .and. (js  ==  1)) y(1-i    ,1-j    ) = mySign*x(j      ,1-i  )  !SW Corner 
                     if ((is  ==  1) .and. (je+1==npy)) y(1-i    ,npy-1+j) =        x(j      ,npy+i)  !NW Corner
                     if ((ie+1==npx) .and. (js  ==  1)) y(npx+i  ,1-j    ) =        x(npx-j  ,1-i  )  !SE Corner
                     if ((ie+1==npx) .and. (je+1==npy)) y(npx+i  ,npy-1+j) = mySign*x(npx-j  ,npy+i)  !NE Corner
                  enddo
               enddo

      end subroutine fill_corners_dgrid
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
      subroutine fill_corners_cgrid(x, y, npx, npy, mySign)
         real, DIMENSION(isd:,jsd:), intent(INOUT):: x
         real, DIMENSION(isd:,jsd:), intent(INOUT):: y
         integer, intent(IN):: npx,npy
         real, intent(IN) :: mySign
         integer :: i,j

                  do j=1,ng
                     do i=1,ng
                        if ((is  ==  1) .and. (js  ==  1)) x(1-i    ,1-j    ) =        y(j      ,1-i  )  !SW Corner 
                        if ((is  ==  1) .and. (je+1==npy)) x(1-i    ,npy-1+j) = mySign*y(j      ,npy+i)  !NW Corner
                        if ((ie+1==npx) .and. (js  ==  1)) x(npx+i  ,1-j    ) = mySign*y(npx-j  ,1-i  )  !SE Corner
                        if ((ie+1==npx) .and. (je+1==npy)) x(npx+i  ,npy-1+j) =        y(npx-j  ,npy+i)  !NE Corner
                     enddo
                  enddo
                  do j=1,ng
                     do i=1,ng
                        if ((is  ==  1) .and. (js  ==  1)) y(1-i    ,1-j  ) =        x(1-j  ,i    )  !SW Corner 
                        if ((is  ==  1) .and. (je+1==npy)) y(1-i    ,npy+j) = mySign*x(1-j  ,npy-i)  !NW Corner
                        if ((ie+1==npx) .and. (js  ==  1)) y(npx-1+i,1-j  ) = mySign*x(npx+j,i    )  !SE Corner
                        if ((ie+1==npx) .and. (je+1==npy)) y(npx-1+i,npy+j) =        x(npx+j,npy-i)  !NE Corner
                     enddo
                  enddo
      
      end subroutine fill_corners_cgrid
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
      subroutine fill_corners_agrid(x, y, npx, npy, mySign)
         real, DIMENSION(isd:,jsd:), intent(INOUT):: x
         real, DIMENSION(isd:,jsd:), intent(INOUT):: y
         integer, intent(IN):: npx,npy
         real, intent(IN) :: mySign
         integer :: i,j

                 do j=1,ng
                    do i=1,ng
                       if ((is==    1) .and. (js==    1)) x(1-i    ,1-j    ) = mySign*y(1-j    ,i        )  !SW Corner
                       if ((is==    1) .and. (je==npy-1)) x(1-i    ,npy-1+j) =        y(1-j    ,npy-1-i+1)  !NW Corner
                       if ((ie==npx-1) .and. (js==    1)) x(npx-1+i,1-j    ) =        y(npx-1+j,i        )  !SE Corner
                       if ((ie==npx-1) .and. (je==npy-1)) x(npx-1+i,npy-1+j) = mySign*y(npx-1+j,npy-1-i+1)  !NE Corner
                    enddo
                 enddo
                 do j=1,ng
                    do i=1,ng
                       if ((is==    1) .and. (js==    1)) y(1-j    ,1-i    ) = mySign*x(i        ,1-j    )  !SW Corner
                       if ((is==    1) .and. (je==npy-1)) y(1-j    ,npy-1+i) =        x(i        ,npy-1+j)  !NW Corner
                       if ((ie==npx-1) .and. (js==    1)) y(npx-1+j,1-i    ) =        x(npx-1-i+1,1-j    )  !SE Corner
                       if ((ie==npx-1) .and. (je==npy-1)) y(npx-1+j,npy-1+i) = mySign*x(npx-1-i+1,npy-1+j)  !NE Corner
                    enddo
                 enddo

      end subroutine fill_corners_agrid
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     
!     mp_corner_comm :: Point-based MPI communcation routine for Cubed-Sphere
!                       ghosted corner point on B-Grid 
!                       this routine sends 24 16-byte messages 
!     
      subroutine mp_corner_comm(q, npx, npy)
         integer, intent(IN)  :: npx,npy
         real  , intent(INOUT):: q(isd:ied+1,jsd:jed+1)

         real :: qsend(24)
         real :: send_tag, recv_tag
         integer :: sqest(24), rqest(24)
         integer :: Stats(24*MPI_STATUS_SIZE)
         integer :: nsend, nrecv, nread
         integer :: dest_gid, src_gid
         integer :: n

         qsend = 1.e25
         nsend=0
         nrecv=0

         if ( mod(tile,2) == 0 ) then
! Even Face LL and UR pairs 6 2-way
            if ( (is==1) .and. (js==1) ) then
               nsend=nsend+1
               qsend(nsend) = q(is,js+1)
               send_tag = 300+tile
               dest_gid = (tile-2)*npes_x*npes_y - 1
               if (dest_gid < 0) dest_gid=npes+dest_gid
               recv_tag = 100+(tile-2)
               if (tile==2) recv_tag = 100+(ntiles)
               src_gid  = (tile-3)*npes_x*npes_y
               src_gid  = src_gid + npes_x*(npes_y-1) + npes_x - 1
               if (src_gid < 0) src_gid=npes+src_gid
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &
                                     dest_gid, send_tag, &
                                     q(is-1,js), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else 
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(is-1,js), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
            endif
            if ( (ie==npx-1) .and. (je==npy-1) ) then
               nsend=nsend+1
               qsend(nsend) = q(ie,je+1)
               send_tag = 100+tile
               dest_gid = (tile+1)*npes_x*npes_y
               if (dest_gid+1 > npes) dest_gid=dest_gid-npes
               recv_tag = 300+(tile+2)
               if (tile==6) recv_tag = 300+2
               src_gid  = (tile+1)*npes_x*npes_y
               if (src_gid+1 > npes) src_gid=src_gid-npes
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &
                                     dest_gid, send_tag, &
                                     q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
            endif
! wait for comm to complete
            if (npes==6) then
               if (nsend>0) then
                  call MPI_WAITALL(nsend, sqest, Stats, ierror)
!!$                  do n=1,nsend
!!$                     call MPI_REQUEST_FREE( sqest(n), ierror )
!!$                  enddo
               endif
               if (nrecv>0) then
                  call MPI_WAITALL(nrecv, rqest, Stats, ierror)
!!$                  do n=1,nrecv
!!$                     call MPI_REQUEST_FREE( rqest(n), ierror )
!!$                  enddo
               endif
               nsend=0 ; nrecv=0
            endif

! Even Face LR 1 pair ; 1 1-way
            if ( (tile==2) .and. (ie==npx-1) .and. (js==1) ) then
               nsend=nsend+1
               qsend(nsend) = q(ie,js)
               send_tag = 200+tile
               dest_gid = (tile+1)*npes_x*npes_y + npes_x-1
               recv_tag = 200+(tile+2)
               src_gid  = dest_gid
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &
                                     dest_gid, send_tag, &
                                     q(ie+2,js), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
            endif
            if ( (tile==4) .and. (ie==npx-1) .and. (js==1) ) then 
               nsend=nsend+1
               qsend(nsend) = q(ie+1,js+1)
               send_tag = 200+tile
               dest_gid = (tile-3)*npes_x*npes_y + npes_x-1
               recv_tag = 200+(tile-2)
               src_gid  = dest_gid
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &     
                                     dest_gid, send_tag, &
                                     q(ie+2,js), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &          
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &        
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
               nsend=nsend+1
               qsend(nsend) = q(ie,js)
               send_tag = 200+tile
               dest_gid = (tile+1)*npes_x*npes_y + npes_x-1
               call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                               send_tag, commglobal, sqest(nsend), ierror )
            endif
            if ( (tile==6) .and. (ie==npx-1) .and. (js==1) ) then
               recv_tag = 200+(tile-2)
               src_gid  = (tile-3)*npes_x*npes_y + npes_x-1
               nrecv=nrecv+1
               call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                               recv_tag, commglobal, rqest(nrecv), ierror )
            endif

! wait for comm to complete 
            if (npes==6) then
               if (nsend>0) then
                  call MPI_WAITALL(nsend, sqest, Stats, ierror)
!!$                  do n=1,nsend
!!$                     call MPI_REQUEST_FREE( sqest(n), ierror )
!!$                  enddo
               endif
               if (nrecv>0) then
                  call MPI_WAITALL(nrecv, rqest, Stats, ierror)
!!$                  do n=1,nrecv
!!$                     call MPI_REQUEST_FREE( rqest(n), ierror )
!!$                  enddo
               endif
               nsend=0 ; nrecv=0
            endif

! Send to Odd face LR 3 1-way
            if ( (is==1) .and. (js==1) ) then
               nsend=nsend+1
               qsend(nsend) = q(is+1,js)
               send_tag = 200+tile
               dest_gid = (tile-2)*npes_x*npes_y + npes_x-1
               call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                               send_tag, commglobal, sqest(nsend), ierror )
            endif

! Receive Even Face UL 3 1-way
            if ( (is==1) .and. (je==npy-1) ) then
               recv_tag = 400+(tile-1)
               src_gid  = (tile-2)*npes_x*npes_y + npes_x*(npes_y-1) + npes_x-1
               nrecv=nrecv+1
               call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                               recv_tag, commglobal, rqest(nrecv), ierror )
            endif

         else

! Odd Face LL and UR pairs 6 2-way
            if ( (is==1) .and. (js==1) ) then
               nsend=nsend+1
               qsend(nsend) = q(is+1,js)
               send_tag = 300+tile
               dest_gid = (tile-2)*npes_x*npes_y - 1
               if (dest_gid < 0) dest_gid=npes+dest_gid
               recv_tag = 100+(tile-2)
               if (tile==1) recv_tag = 100+(ntiles-tile)
               src_gid  = (tile-3)*npes_x*npes_y
               src_gid  = src_gid + npes_x*(npes_y-1) + npes_x - 1
               if (src_gid < 0) src_gid=npes+src_gid
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &
                                     dest_gid, send_tag, &
                                     q(is-1,js), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &             
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else 
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(is-1,js), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
            endif
            if ( (ie==npx-1) .and. (je==npy-1) ) then
               nsend=nsend+1
               qsend(nsend) = q(ie+1,je)
               send_tag = 100+tile
               dest_gid = (tile+1)*npes_x*npes_y
               if (dest_gid+1 > npes) dest_gid=dest_gid-npes
               recv_tag = 300+(tile+2)
               if (tile==5) recv_tag = 300+1
               src_gid  = (tile+1)*npes_x*npes_y
               if (src_gid+1 > npes) src_gid=src_gid-npes
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &      
                                     dest_gid, send_tag, &
                                     q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &             
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else 
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
            endif
! wait for comm to complete 
            if (npes==6) then
               if (nsend>0) then
                  call MPI_WAITALL(nsend, sqest, Stats, ierror)
!!$                  do n=1,nsend
!!$                     call MPI_REQUEST_FREE( sqest(n), ierror )
!!$                  enddo
               endif
               if (nrecv>0) then
                  call MPI_WAITALL(nrecv, rqest, Stats, ierror)
!!$                  do n=1,nrecv
!!$                     call MPI_REQUEST_FREE( rqest(n), ierror )
!!$                  enddo
               endif
               nsend=0 ; nrecv=0
            endif
            
! Odd Face UL 1 pair ; 1 1-way
            if ( (tile==1) .and. (is==1) .and. (je==npy-1) ) then
               nsend=nsend+1
               qsend(nsend) = q(is,je)
               send_tag = 400+tile
               dest_gid = (tile+1)*npes_x*npes_y + npes_x*(npes_y-1)
               recv_tag = 400+(tile+2)
               src_gid  = dest_gid
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &
                                     dest_gid, send_tag, &
                                     q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &
                                     commglobal, Stats, ierror )
                  nsend=nsend-1
               else
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif
            endif
            if ( (tile==3) .and. (is==1) .and. (je==npy-1) ) then
               nsend=nsend+1
               qsend(nsend) = q(is+1,je+1)
               send_tag = 400+tile
               dest_gid = npes_x*(npes_y-1)
               recv_tag = 400+(tile-2)           
               src_gid  = dest_gid
               if (npes>6) then
                  call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, &     
                                     dest_gid, send_tag, &
                                     q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, &
                                     src_gid, recv_tag, &          
                                     commglobal, Stats, ierror )
                  nsend=nsend-1             
               else
                  call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &        
                                  send_tag, commglobal, sqest(nsend), ierror )
                  nrecv=nrecv+1
                  call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                                  recv_tag, commglobal, rqest(nrecv), ierror )
               endif            
               nsend=nsend+1
               qsend(nsend) = q(is,je)
               send_tag = 400+tile
               dest_gid = (tile+1)*npes_x*npes_y + npes_x*(npes_y-1)
               call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                               send_tag, commglobal, sqest(nsend), ierror )
            endif
            if ( (tile==5) .and. (is==1) .and. (je==npy-1) ) then
               recv_tag = 400+(tile-2)
               src_gid  = (tile-3)*npes_x*npes_y + npes_x*(npes_y-1)
               nrecv=nrecv+1 
               call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                               recv_tag, commglobal, rqest(nrecv), ierror ) 
            endif

! wait for comm to complete 
            if (npes==6) then
               if (nsend>0) then
                  call MPI_WAITALL(nsend, sqest, Stats, ierror)
!!$                  do n=1,nsend
!!$                     call MPI_REQUEST_FREE( sqest(n), ierror )
!!$                  enddo
               endif
               if (nrecv>0) then
                  call MPI_WAITALL(nrecv, rqest, Stats, ierror)
!!$                  do n=1,nrecv
!!$                     call MPI_REQUEST_FREE( rqest(n), ierror )
!!$                  enddo
               endif
               nsend=0 ; nrecv=0
            endif

! Send to Even face UL 3 1-way 
            if ( (ie==npx-1) .and. (je==npy-1) ) then
               nsend=nsend+1
               qsend(nsend) = q(ie,je+1)
               send_tag = 400+tile
               dest_gid = tile*npes_x*npes_y + npes_x*(npes_y-1)
               call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, &
                               send_tag, commglobal, sqest(nsend), ierror )
            endif

! Receive Odd Face LR 3 1-way
            if ( (ie==npx-1) .and. (js==1) ) then
               recv_tag = 200+(tile+1)
               src_gid  = (tile-1)*npes_x*npes_y + npes_x*npes_y 
               nrecv=nrecv+1
               call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid,  &
                               recv_tag, commglobal, rqest(nrecv), ierror )
            endif

         endif

! wait for comm to complete
         if (nsend>0) then
            call MPI_WAITALL(nsend, sqest, Stats, ierror)
!!$            do n=1,nsend
!!$               call MPI_REQUEST_FREE( sqest(n), ierror )
!!$            enddo
         endif
         if (nrecv>0) then
            call MPI_WAITALL(nrecv, rqest, Stats, ierror)
!!$            do n=1,nrecv
!!$               call MPI_REQUEST_FREE( rqest(n), ierror )
!!$            enddo
         endif

      end subroutine mp_corner_comm
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!       
!     mp_gather_4d_r4 :: Call SPMD Gather 
!     
      subroutine mp_gather_4d_r4(q, i1,i2, j1,j2, idim, jdim, kdim, ldim)
         integer, intent(IN)  :: i1,i2, j1,j2
         integer, intent(IN)  :: idim, jdim, kdim, ldim
         real(kind=4), intent(INOUT):: q(idim,jdim,kdim,ldim)
         integer :: i,j,k,l,n,icnt 
         integer :: Lsize, Lsize_buf(1)
         integer :: Gsize
         integer :: LsizeS(npes), Ldispl(npes), cnts(npes)
         integer :: Ldims(5), Gdims(5*npes)
         real(kind=4), allocatable, dimension(:) :: larr, garr
        
         Ldims(1) = i1
         Ldims(2) = i2
         Ldims(3) = j1
         Ldims(4) = j2
         Ldims(5) = tile 
         do l=1,npes
            cnts(l) = 5
            Ldispl(l) = 5*(l-1)
         enddo 
         call mpp_gather(Ldims, Gdims)
!         call MPI_GATHERV(Ldims, 5, MPI_INTEGER, Gdims, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
      
         Lsize = ( (i2 - i1 + 1) * (j2 - j1 + 1) ) * kdim
         do l=1,npes
            cnts(l) = 1
            Ldispl(l) = l-1
         enddo 
         LsizeS(:)=1
         Lsize_buf(1) = Lsize
         call mpp_gather(Lsize_buf, LsizeS)
!         call MPI_GATHERV(Lsize, 1, MPI_INTEGER, LsizeS, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)

         allocate ( larr(Lsize) )
         icnt = 1
         do k=1,kdim
            do j=j1,j2
               do i=i1,i2
                  larr(icnt) = q(i,j,k,tile)
                  icnt=icnt+1
               enddo
            enddo
         enddo
         Ldispl(1) = 0.0
!         call mp_bcst(LsizeS(1))
         call mpp_broadcast(LsizeS, npes, masterproc)
         Gsize = LsizeS(1)
         do l=2,npes
!            call mp_bcst(LsizeS(l))
            Ldispl(l) = Ldispl(l-1) + LsizeS(l-1)
            Gsize = Gsize + LsizeS(l)
         enddo
         allocate ( garr(Gsize) )

         call mpp_gather(larr, garr)
!         call MPI_GATHERV(larr, Lsize, MPI_REAL, garr, LsizeS, Ldispl, MPI_REAL, masterproc, commglobal, ierror)

         if (gid==masterproc) then
            do n=2,npes
               icnt=1
               do l=Gdims( (n-1)*5 + 5 ), Gdims( (n-1)*5 + 5 )
                  do k=1,kdim
                     do j=Gdims( (n-1)*5 + 3 ), Gdims( (n-1)*5 + 4 )
                        do i=Gdims( (n-1)*5 + 1 ), Gdims( (n-1)*5 + 2 )
                           q(i,j,k,l) = garr(Ldispl(n)+icnt)
                           icnt=icnt+1
                        enddo
                    enddo
                 enddo
               enddo
            enddo
         endif
         deallocate( larr )
         deallocate( garr )

      end subroutine mp_gather_4d_r4
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_gather_3d_r4 :: Call SPMD Gather 
!
      subroutine mp_gather_3d_r4(q, i1,i2, j1,j2, idim, jdim, ldim)
         integer, intent(IN)  :: i1,i2, j1,j2
         integer, intent(IN)  :: idim, jdim, ldim
         real(kind=4), intent(INOUT):: q(idim,jdim,ldim)
         integer :: i,j,l,n,icnt 
         integer :: Lsize, Lsize_buf(1)
         integer :: Gsize
         integer :: LsizeS(npes), Ldispl(npes), cnts(npes)
         integer :: Ldims(5), Gdims(5*npes)
         real(kind=4), allocatable, dimension(:) :: larr, garr 

         Ldims(1) = i1
         Ldims(2) = i2
         Ldims(3) = j1
         Ldims(4) = j2
         Ldims(5) = tile
         do l=1,npes
            cnts(l) = 5
            Ldispl(l) = 5*(l-1)
         enddo
!         call MPI_GATHERV(Ldims, 5, MPI_INTEGER, Gdims, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
         call mpp_gather(Ldims, Gdims)

         Lsize = ( (i2 - i1 + 1) * (j2 - j1 + 1) )
         do l=1,npes
            cnts(l) = 1
            Ldispl(l) = l-1
         enddo 
         LsizeS(:)=1
         Lsize_buf(1) = Lsize
         call mpp_gather(Lsize_buf, LsizeS)
!         call MPI_GATHERV(Lsize, 1, MPI_INTEGER, LsizeS, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)

         allocate ( larr(Lsize) )
         icnt = 1
         do j=j1,j2
            do i=i1,i2
               larr(icnt) = q(i,j,tile)  
               icnt=icnt+1
            enddo
         enddo
         Ldispl(1) = 0.0
!         call mp_bcst(LsizeS(1))
         call mpp_broadcast(LsizeS, npes, masterproc)
         Gsize = LsizeS(1)
         do l=2,npes
!            call mp_bcst(LsizeS(l))
            Ldispl(l) = Ldispl(l-1) + LsizeS(l-1)
            Gsize = Gsize + LsizeS(l)
         enddo
         allocate ( garr(Gsize) )
         call mpp_gather(larr, garr)
!         call MPI_GATHERV(larr, Lsize, MPI_REAL, garr, LsizeS, Ldispl, MPI_REAL, masterproc, commglobal, ierror)
         if (gid==masterproc) then
            do n=2,npes
               icnt=1
               do l=Gdims( (n-1)*5 + 5 ), Gdims( (n-1)*5 + 5 )
                  do j=Gdims( (n-1)*5 + 3 ), Gdims( (n-1)*5 + 4 ) 
                     do i=Gdims( (n-1)*5 + 1 ), Gdims( (n-1)*5 + 2 )
                        q(i,j,l) = garr(Ldispl(n)+icnt)
                        icnt=icnt+1
                     enddo
                 enddo
               enddo
            enddo
         endif
         deallocate( larr )
         deallocate( garr )

      end subroutine mp_gather_3d_r4
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_gather_3d_r8 :: Call SPMD Gather 
!
      subroutine mp_gather_3d_r8(q, i1,i2, j1,j2, idim, jdim, ldim)
         integer, intent(IN)  :: i1,i2, j1,j2
         integer, intent(IN)  :: idim, jdim, ldim
         real(kind=8),  intent(INOUT):: q(idim,jdim,ldim)
         integer :: i,j,l,n,icnt
         integer :: Lsize, Lsize_buf(1)
         integer :: Gsize
         integer :: LsizeS(npes), Ldispl(npes), cnts(npes)
         integer :: Ldims(5), Gdims(5*npes)
         real,   allocatable, dimension(:) :: larr, garr

         Ldims(1) = i1
         Ldims(2) = i2
         Ldims(3) = j1
         Ldims(4) = j2
         Ldims(5) = tile
         do l=1,npes
            cnts(l) = 5
            Ldispl(l) = 5*(l-1)
         enddo
!         call MPI_GATHER(Ldims, 5, MPI_INTEGER, Gdims, cnts, MPI_INTEGER, masterproc, commglobal, ierror)
         call mpp_gather(Ldims, Gdims)
         Lsize = ( (i2 - i1 + 1) * (j2 - j1 + 1) )
         do l=1,npes
            cnts(l) = 1
            Ldispl(l) = l-1
         enddo
         LsizeS(:)=0.

!         call MPI_GATHERV(Lsize, 1, MPI_INTEGER, LsizeS, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
         Lsize_buf(1) = Lsize
         call mpp_gather(Lsize_buf, LsizeS)

         allocate ( larr(Lsize) )
         icnt = 1
         do j=j1,j2
            do i=i1,i2
               larr(icnt) = q(i,j,tile)
               icnt=icnt+1
            enddo
         enddo
         Ldispl(1) = 0.0
         call mpp_broadcast(LsizeS, npes, masterproc)
!         call mp_bcst(LsizeS(1))
         Gsize = LsizeS(1)
         do l=2,npes
!            call mp_bcst(LsizeS(l))
            Ldispl(l) = Ldispl(l-1) + LsizeS(l-1)
            Gsize = Gsize + LsizeS(l)
         enddo

         allocate ( garr(Gsize) )
         call mpp_gather(larr, garr)
!         call MPI_GATHERV(larr, Lsize, MPI_DOUBLE_PRECISION, garr, LsizeS, Ldispl, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)
         if (gid==masterproc) then
            do n=2,npes
               icnt=1
               do l=Gdims( (n-1)*5 + 5 ), Gdims( (n-1)*5 + 5 )
                  do j=Gdims( (n-1)*5 + 3 ), Gdims( (n-1)*5 + 4 )
                     do i=Gdims( (n-1)*5 + 1 ), Gdims( (n-1)*5 + 2 )
                        q(i,j,l) = garr(Ldispl(n)+icnt)
                        icnt=icnt+1
                     enddo
                 enddo
               enddo
            enddo
         endif
         deallocate( larr )
         deallocate( garr )

      end subroutine mp_gather_3d_r8
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_bcst_i4 :: Call SPMD broadcast 
!
      subroutine mp_bcst_i4(q)
         integer, intent(INOUT)  :: q

         call MPI_BCAST(q, 1, MPI_INTEGER, masterproc, commglobal, ierror)

      end subroutine mp_bcst_i4
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_bcst_r8 :: Call SPMD broadcast 
!
      subroutine mp_bcst_r8(q)
         real, intent(INOUT)  :: q

         call MPI_BCAST(q, 1, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)

      end subroutine mp_bcst_r8
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_bcst_3d_r8 :: Call SPMD broadcast 
!
      subroutine mp_bcst_3d_r8(q, idim, jdim, kdim)
         integer, intent(IN)  :: idim, jdim, kdim
         real, intent(INOUT)  :: q(idim,jdim,kdim)

         call MPI_BCAST(q, idim*jdim*kdim, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)

      end subroutine mp_bcst_3d_r8
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!       
!     mp_bcst_4d_r8 :: Call SPMD broadcast 
!
      subroutine mp_bcst_4d_r8(q, idim, jdim, kdim, ldim)
         integer, intent(IN)  :: idim, jdim, kdim, ldim
         real, intent(INOUT)  :: q(idim,jdim,kdim,ldim)

         call MPI_BCAST(q, idim*jdim*kdim*ldim, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)
        
      end subroutine mp_bcst_4d_r8
!     
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!       
!     mp_reduce_max_r8_1d :: Call SPMD REDUCE_MAX 
!
      subroutine mp_reduce_max_r8_1d(mymax,npts)
         integer, intent(IN)  :: npts
         real, intent(INOUT)  :: mymax(npts)
        
         real :: gmax(npts)
        
         call MPI_ALLREDUCE( mymax, gmax, npts, MPI_DOUBLE_PRECISION, MPI_MAX, &
                             commglobal, ierror )
      
         mymax = gmax
        
      end subroutine mp_reduce_max_r8_1d
!     
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_reduce_max_r8 :: Call SPMD REDUCE_MAX 
!
      subroutine mp_reduce_max_r8(mymax)
         real, intent(INOUT)  :: mymax

         real :: gmax

         call MPI_ALLREDUCE( mymax, gmax, 1, MPI_DOUBLE_PRECISION, MPI_MAX, &
                             commglobal, ierror )

         mymax = gmax

      end subroutine mp_reduce_max_r8

      subroutine mp_reduce_min(mymin)
         real, intent(INOUT)  :: mymin

         real :: gmin

         call MPI_ALLREDUCE( mymin, gmin, 1, MPI_DOUBLE_PRECISION, MPI_MIN, &
                             commglobal, ierror )

         mymin = gmin

      end subroutine mp_reduce_min
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_bcst_4d_i4 :: Call SPMD REDUCE_MAX 
!
      subroutine mp_reduce_max_i4(mymax)
         integer, intent(INOUT)  :: mymax

         integer :: gmax

         call MPI_ALLREDUCE( mymax, gmax, 1, MPI_INTEGER, MPI_MAX, &
                             commglobal, ierror )

         mymax = gmax

      end subroutine mp_reduce_max_i4
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_reduce_sum_r8 :: Call SPMD REDUCE_SUM 
!
      subroutine mp_reduce_sum_r8(mysum)
         real, intent(INOUT)  :: mysum

         real :: gsum

         call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
                             commglobal, ierror )

         mysum = gsum

      end subroutine mp_reduce_sum_r8
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     mp_reduce_sum_r8_1d :: Call SPMD REDUCE_SUM 
!
      subroutine mp_reduce_sum_r8_1d(mysum, sum1d, npts)
         integer, intent(in)  :: npts
         real, intent(in)     :: sum1d(npts)
         real, intent(INOUT)  :: mysum

         real :: gsum
         integer :: i

         mysum = 0.0
         do i=1,npts
            mysum = mysum + sum1d(i)
         enddo 

         call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
                             commglobal, ierror )

         mysum = gsum

      end subroutine mp_reduce_sum_r8_1d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

#else
      implicit none
      private
      integer :: masterproc = 0
      integer :: gid = 0
      integer, parameter:: ng    = 3     ! Number of ghost zones required
      public gid, masterproc, ng
#endif

      end module fv_mp_mod
!-------------------------------------------------------------------------------


module fv_nwp_nudge_mod

 use constants_mod,     only: pi, grav, rdgas, cp_air, kappa, radius
 use fms_mod,           only: write_version_number, open_namelist_file, &
                              check_nml_error, file_exist, close_file, read_data
 use fms_io_mod,        only: field_size
 use mpp_mod,           only: mpp_error, FATAL, stdlog, get_unit, input_nml_file
 use mpp_domains_mod,   only: mpp_update_domains
 use time_manager_mod,  only: time_type,  get_time, get_date

 use external_sst_mod,   only: i_sst, j_sst, sst_ncep, sst_anom, forecast_mode
 use fv_control_mod,    only: npx, npy
 use fv_grid_utils_mod, only: vlon, vlat, sina_u, sina_v, da_min, great_circle_dist, ks, intp_great_circle
 use fv_grid_utils_mod, only: latlon2xyz, vect_cross, normalize_vect
 use fv_grid_tools_mod, only: agrid, dx, dy, rdxc, rdyc, rarea, area
 use fv_diagnostics_mod,only: prt_maxmin, fv_time
 use tp_core_mod,       only: copy_corners
 use fv_mapz_mod,       only: mappm
 use fv_mp_mod,         only: is,js,ie,je, isd,jsd,ied,jed, gid, masterproc, domain,    &
                              mp_reduce_sum, mp_reduce_min, mp_reduce_max
 use fv_timing_mod,     only: timing_on, timing_off

!----------------------------------------------------------------------------------------
! Note: using FMS read_data for reading multiple analysis files requires too much memory
! and too many files open (led to fatal errors); 
!----------------------------------------------------------------------------------------
 use sim_nc_mod,        only: open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_double,   &
                              get_var3_double

 implicit none
 private

 character(len=128) :: version = ''
 character(len=128) :: tagname = ''

 public fv_nwp_nudge, fv_nwp_nudge_init, fv_nwp_nudge_end, breed_slp_inline

 integer im     ! Data x-dimension
 integer jm     ! Data y-dimension
 integer km     ! Data z-dimension
 real, allocatable:: ak0(:), bk0(:)
 real, allocatable:: lat(:), lon(:)

 logical :: module_is_initialized = .false.
 logical :: master
 logical :: no_obs
 real :: deg2rad, rad2deg
 real :: time_nudge = 0.
 integer :: time_interval = 6*3600   ! dataset time interval (seconds)
 integer, parameter :: nfile_max = 125
 integer :: nfile

 integer :: k_breed = 0
 integer :: k_trop = 0
 real    :: p_trop = 200.E2

 real,    allocatable:: s2c(:,:,:)
 integer, allocatable:: id1(:,:), id2(:,:), jdc(:,:)
 real, allocatable :: ps_dat(:,:,:)
 real(KIND=4), allocatable, dimension(:,:,:,:):: u_dat, v_dat, t_dat, q_dat
 real, allocatable:: gz0(:,:)

! Namelist variables:
 character(len=128):: file_names(nfile_max)
 character(len=128):: track_file_name
 integer :: nfile_total = 0       ! =5 for 1-day (if datasets are 6-hr apart)
 real    :: p_wvp = 100.E2        ! cutoff level for specific humidity nudging 
 integer :: kord_data = 8

 logical :: add_bg_wind = .true.
 logical :: pre_test = .false.
 logical :: conserve_mom = .true.
 logical :: tc_mask = .false.
 logical :: strong_mask = .true. 
 logical :: ibtrack = .true. 
 logical :: nudge_debug = .false.
 logical :: nudge_t     = .false.
 logical :: nudge_q     = .false.
 logical :: nudge_winds = .true.
 logical :: nudge_virt  = .false.
 logical :: nudge_hght  = .false.
 logical :: nudge_tpw   = .false.   ! nudge total precipitable water
 logical :: time_varying = .true.
 logical :: time_track   = .false.
 logical :: print_end_breed = .true.
 logical :: print_end_nudge = .true.


! Nudging time-scales (seconds): note, however, the effective time-scale is 2X smaller (stronger) due
! to the use of the time-varying weighting factor
 real :: tau_q      = 86400.       ! 1-day
 real :: tau_tpw    = 86400.       ! 1-day
 real :: tau_winds  = 21600.       !  6-hr
 real :: tau_t      = 86400.
 real :: tau_virt   = 86400. 
 real :: tau_hght   = 86400.

 real :: q_min      = 1.E-8

 integer :: nf_uv = 0 
 integer :: nf_t  = 1 

! starting layer (top layer is sponge layer and is skipped)
 integer :: kstart = 2 

! skip "kbot" layers
 integer :: kbot_winds = 0 
 integer :: kbot_t     = 0 
 integer :: kbot_q     = 1 
 logical :: analysis_time

!-- Tropical cyclones  --------------------------------------------------------------------

! track dataset: 'INPUT/tropical_cyclones.txt'

  logical :: breed_vortex = .false.
  real :: grid_size     = 28.E3
  real :: tau_vt_slp    = 1800.
  real :: tau_vt_wind   = 1200.
  real :: tau_vt_rad    = 4.0  ! TEST.exe: 2.0

  real ::  slp_env = 101010.    ! storm environment pressure (pa)
  real :: pre0_env = 100000.    ! critical storm environment pressure (pa) for size computation
!------------------
  real:: r_lo = 2.0
  real:: r_hi = 5.0    ! try 4.0?
!------------------
  real::  r_fac = 1.2
  real :: r_min = 200.E3
  real :: r_inc =  25.E3
  real, parameter:: del_r = 50.E3
  real:: elapsed_time = 0.0
  real:: nudged_time = 1.E12 ! seconds 
                             ! usage example: set to 43200. to do inline vortex breeding
                             ! for only the first 12 hours
                             ! In addition, specify only 3 analysis files (12 hours)
  integer:: year_track_data
  integer, parameter:: max_storm = 140     ! max # of storms to process
  integer, parameter::  nobs_max = 125     ! Max # of observations per storm

  integer :: nstorms = 0
  integer :: nobs_tc(max_storm)
  real(KIND=4)::     x_obs(nobs_max,max_storm)           ! longitude in degrees
  real(KIND=4)::     y_obs(nobs_max,max_storm)           ! latitude in degrees
  real(KIND=4)::  wind_obs(nobs_max,max_storm)           ! observed 10-m wind speed (m/s)
  real(KIND=4)::  mslp_obs(nobs_max,max_storm)           ! observed SLP in mb
  real(KIND=4)::  mslp_out(nobs_max,max_storm)           ! outer ring SLP in mb
  real(KIND=4)::   rad_out(nobs_max,max_storm)           ! outer ring radius in meters
  real(KIND=4)::   time_tc(nobs_max,max_storm)           ! start time of the track
!------------------------------------------------------------------------------------------

 namelist /fv_nwp_nudge_nml/ nudge_virt, nudge_hght, nudge_t, nudge_q, nudge_winds, nudge_tpw, &
                          tau_winds, tau_t, tau_q, tau_virt, tau_hght,  kstart, kbot_winds, &
                          k_breed, k_trop, p_trop, kord_data, tc_mask, nudge_debug, nf_t,    &
                          nf_uv, breed_vortex, tau_vt_wind, tau_vt_slp, tau_tpw, strong_mask,   &
                          kbot_t, kbot_q, p_wvp, time_varying, time_track, time_interval,  &
                          pre0_env, tau_vt_rad, r_lo, r_hi, add_bg_wind, pre_test, conserve_mom,  &
                          nudged_time, r_fac, r_min, r_inc, ibtrack, track_file_name, file_names

 contains
 

  subroutine fv_nwp_nudge ( Time, dt, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, zvir, &
                            ak, bk, ts, ps, delp, ua, va, pt, nwat, q, phis )

  type(time_type), intent(in):: Time
  integer,         intent(in):: npz           ! vertical dimension
  integer,         intent(in):: nwat
  real,            intent(in):: dt
  real,            intent(in):: zvir
  real, intent(in   ), dimension(npz+1):: ak, bk
  real, intent(in   ), dimension(isd:ied,jsd:jed    ):: phis
  real, intent(inout), dimension(isd:ied,jsd:jed,npz):: pt, ua, va, delp
  real, intent(inout):: q(isd:ied,jsd:jed,npz,nwat)
  real, intent(inout), dimension(isd:ied,jsd:jed):: ps
! Accumulated tendencies
  real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt
  real, intent(out):: t_dt(is:ie,js:je,npz)
  real, intent(out):: q_dt(is:ie,js:je,npz)
  real, intent(out), dimension(is:ie,js:je):: ps_dt, ts
! local:
  real:: m_err(is:ie,js:je)         ! height error at specified model interface level
  real:: slp_n(is:ie,js:je)         ! "Observed" SLP
  real:: slp_m(is:ie,js:je)         ! "model" SLP
  real:: tpw_dat(is:ie,js:je)
  real:: tpw_mod(is:ie,js:je)
  real::   mask(is:ie,js:je)
  real:: gz_int(is:ie,js:je), gz(is:ie,npz+1), peln(is:ie,npz+1), pk(is:ie,npz+1)
  real:: pe1(is:ie)
  real:: pkz, ptmp
  real, allocatable :: ps_obs(:,:)
  real, allocatable, dimension(:,:,:):: u_obs, v_obs, t_obs, q_obs
  real, allocatable, dimension(:,:,:):: du_obs, dv_obs
  integer :: seconds, days
  integer :: i,j,k, iq, kht
  real :: factor, rms, bias, co
  real :: q_rat
  real :: dbk, rdt, press(npz), profile(npz), prof_t(npz), prof_q(npz), du, dv


  if ( .not. module_is_initialized ) then 
        call mpp_error(FATAL,'==> Error from fv_nwp_nudge: module not initialized')
  endif

  if ( no_obs ) then
       forecast_mode = .true.
       return
  endif

  call get_time (time, seconds, days)

  do j=js,je
     do i=is,ie
        mask(i,j) = 1.
     enddo
  enddo
  if ( tc_mask )  call get_tc_mask(time, mask)

! The following profile is suitable only for nwp purposes; if the analysis has a good representation
! of the strat-meso-sphere the profile for upper layers should be changed.

  profile(:) = 1.
  do k=1,npz
     press(k) = 0.5*(ak(k) + ak(k+1)) + 0.5*(bk(k)+bk(k+1))*1.E5
     if ( press(k) < 30.E2 ) then
          profile(k) =  max(0.01, press(k)/30.E2) 
     endif
  enddo
  profile(1) = 0.

! Thermodynamics:
  prof_t(:) = 1.
  do k=1,npz
     if ( press(k) < 30.E2 ) then
          prof_t(k) =  max(0.01, press(k)/30.E2) 
     endif
  enddo
  prof_t(1) = 0.
 
! Water vapor:
  prof_q(:) = 1.
  do k=1,npz
     if ( press(k) < 300.E2 ) then
          prof_q(k) =  max(0., press(k)/300.E2) 
     endif
  enddo
  prof_q(1) = 0.

! Height
  if ( k_trop == 0 ) then
       k_trop = 2
       do k=2,npz-1
          ptmp = ak(k+1) + bk(k+1)*1.E5
          if ( ptmp > p_trop ) then
               k_trop = k
               exit              
          endif
       enddo
  endif

  if ( time_varying ) then
       factor = 1. + cos(real(mod(seconds,time_interval))/real(time_interval)*2.*pi)
       factor = max(1.e-5, factor)
  else
       factor = 1.
  endif

  allocate (ps_obs(is:ie,js:je) )
  allocate ( t_obs(is:ie,js:je,npz) )
  allocate ( q_obs(is:ie,js:je,npz) )

  if ( nudge_winds ) then
       allocate (u_obs(is:ie,js:je,npz) )
       allocate (v_obs(is:ie,js:je,npz) )
  endif


  call get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, u_obs, v_obs, t_obs, q_obs,   &
               tpw_dat, phis, gz_int, npz)

  if ( no_obs ) then
       deallocate (ps_obs)
       deallocate (t_obs)
       deallocate (q_obs)
       if ( nudge_winds ) then
            deallocate (u_obs)
            deallocate (v_obs)
       endif
       forecast_mode = .true.
       return
   endif

  if( analysis_time ) then
!     call prt_maxmin('PS_o', ps_obs, is, ie, js, je, 0, 1, 0.01, master)

! Compute RMSE, bias, and correlation of SLP 
      call compute_slp(is, ie, js, je,    pt(is:ie,js:je,npz:npz), ps(is:ie,js:je), phis(is:ie,js:je), slp_m)
      call compute_slp(is, ie, js, je, t_obs(is:ie,js:je,npz:npz), ps_obs, gz0, slp_n)

      call prt_maxmin('SLP_m', slp_m, is, ie, js, je, 0, 1, 0.01, master)
      call prt_maxmin('SLP_o', slp_n, is, ie, js, je, 0, 1, 0.01, master)

      do j=js,je
         do i=is,ie
            if ( phis(i,j)/grav > 500. ) then
! Exclude high terrains region for RMS and bias computation
                 m_err(i,j) = 0.
            else
                 m_err(i,j) = mask(i,j)*(slp_m(i,j) - slp_n(i,j))
            endif
         enddo
      enddo
     
      call rmse_bias(m_err, rms, bias)
      call corr(slp_m, slp_n, co)

      if(master) write(*,*) 'SLP (mb): RMS=', 0.01*rms, ' Bias=', 0.01*bias
      if(master) write(*,*) 'SLP correlation=',co
  endif

  ps_dt(:,:) = 0.

  if ( nudge_winds ) then

       allocate (du_obs(is:ie,js:je,npz) )
       allocate (dv_obs(is:ie,js:je,npz) )

! Compute tendencies:
     rdt = 1. / (tau_winds/factor + dt)
     do k=kstart, npz - kbot_winds
        do j=js,je
           do i=is,ie
              du_obs(i,j,k) = profile(k)*(u_obs(i,j,k)-ua(i,j,k))*rdt
              dv_obs(i,j,k) = profile(k)*(v_obs(i,j,k)-va(i,j,k))*rdt
           enddo
        enddo
     enddo

     if ( nf_uv>0 ) call del2_uv(du_obs, dv_obs, 0.20, npz, nf_uv)

     do k=kstart, npz - kbot_winds
        do j=js,je
           do i=is,ie
! Apply TC mask
              du_obs(i,j,k) = du_obs(i,j,k) * mask(i,j)
              dv_obs(i,j,k) = dv_obs(i,j,k) * mask(i,j)
!
              u_dt(i,j,k) = u_dt(i,j,k) + du_obs(i,j,k)
              v_dt(i,j,k) = v_dt(i,j,k) + dv_obs(i,j,k)
                ua(i,j,k) =   ua(i,j,k) + du_obs(i,j,k)*dt
                va(i,j,k) =   va(i,j,k) + dv_obs(i,j,k)*dt
           enddo
        enddo
     enddo

     deallocate (du_obs)
     deallocate (dv_obs)

  endif

  if ( nudge_t .or. nudge_virt ) then
     if(nudge_debug) call prt_maxmin('T_obs', t_obs, is, ie, js, je, 0, npz, 1., master)
  endif

!---------------------- temp -----------
  if ( nudge_virt .and. nudge_hght ) then
       tau_virt = max(tau_hght, tau_virt)
       kht = k_trop
  else
       kht = npz-kbot_t
  endif
!---------------------- temp -----------

  t_dt(:,:,:) = 0.

  if ( nudge_hght ) then
     if(nudge_debug) call prt_maxmin('H_int', gz_int, is, ie, js, je, 0, 1, 1./grav, master)

        rdt = dt / (tau_hght/factor + dt)

        do j=js,je
 
           do i=is,ie
              pe1(i) = ak(1)
              peln(i,1) = log(pe1(i))
                pk(i,1) = pe1(i)**kappa
           enddo
           do k=2, npz+1
              do i=is,ie
                    pe1(i) = pe1(i) + delp(i,j,k-1)
                 peln(i,k) = log(pe1(i))
                   pk(i,k) = pe1(i)**kappa
              enddo
           enddo

           do i=is,ie
              gz(i,npz+1) = phis(i,j)
           enddo
           do i=is,ie
              do k=npz,k_trop+1,-1
                 gz(i,k) = gz(i,k+1) + rdgas*pt(i,j,k)*(1.+zvir*q(i,j,k,1))*(peln(i,k+1)-peln(i,k))
              enddo
           enddo

           do i=is,ie
              m_err(i,j) = gz(i,k_trop+1)
           enddo

           do i=is,ie
              do k=k_trop+1,npz
! Add constant "virtual potential temperature" increment to correct height at p_interface
                       pkz = (pk(i,k+1)-pk(i,k))/(kappa*(peln(i,k+1)-peln(i,k)))
                 pt(i,j,k) = pt(i,j,k) + mask(i,j)*rdt*pkz*(gz_int(i,j)-gz(i,k_trop+1)) /     &
                            (cp_air*(1.+zvir*q(i,j,k,1))*(pk(i,npz+1)-pk(i,k_trop+1)))
              enddo
           enddo
        enddo   ! j-loop

! Compute RMSE of height
        if( analysis_time ) then
            call corr(m_err, gz_int, co)
            do j=js,je
               do i=is,ie
                  m_err(i,j) = (m_err(i,j) - gz_int(i,j)) / grav
               enddo
            enddo
            call rmse_bias(m_err, rms, bias)
            if(master) write(*,*) 'HGHT: RMSE (m)=', rms, ' Bias (m)=', bias
            if(master) write(*,*) 'HGHT: correlation=', co
        endif
  endif

  if ( nudge_t ) then
       rdt = 1./(tau_t/factor + dt)
     do k=kstart, kht
        do j=js,je
           do i=is,ie
              t_dt(i,j,k) = prof_t(k)*(t_obs(i,j,k)-pt(i,j,k))*rdt
           enddo
        enddo
     enddo
  elseif ( nudge_virt ) then
        rdt = 1./(tau_virt/factor + dt)
     do k=kstart, kht
        do j=js,je
           do i=is,ie
              t_dt(i,j,k) = prof_t(k)*(t_obs(i,j,k)/(1.+zvir*q(i,j,k,1))-pt(i,j,k))*rdt
           enddo
        enddo
     enddo
  endif

  deallocate ( t_obs )

  if ( nudge_t .or. nudge_virt ) then
! Filter t_dt here:
       if ( nf_t>0 ) call del2_scalar(t_dt, 0.20, npz, nf_t)

       do k=kstart, kht
          do j=js,je
             do i=is,ie
                pt(i,j,k) = pt(i,j,k) + t_dt(i,j,k)*dt*mask(i,j)
            enddo
         enddo
       enddo
  endif

  q_dt(:,:,:) = 0.
  if ( nudge_q ) then
       rdt = 1./(tau_q/factor + dt)
     do k=kstart, npz - kbot_q
        if ( press(k) > p_wvp ) then
            do iq=2,nwat
               do j=js,je
                  do i=is,ie
                     q(i,j,k,iq) = q(i,j,k,iq)*delp(i,j,k)
                  enddo
               enddo
            enddo
! Specific humidity:
            do j=js,je
               do i=is,ie
                  delp(i,j,k) = delp(i,j,k)*(1.-q(i,j,k,1))
                  q_dt(i,j,k) = prof_q(k)*(max(q_min,q_obs(i,j,k))-q(i,j,k,1))*rdt*mask(i,j)
                   q(i,j,k,1) = q(i,j,k,1) + q_dt(i,j,k)*dt
                  delp(i,j,k) = delp(i,j,k)/(1.-q(i,j,k,1))
               enddo
            enddo
            do iq=2,nwat
               do j=js,je
                  do i=is,ie
                     q(i,j,k,iq) = q(i,j,k,iq)/delp(i,j,k)
                  enddo
               enddo
            enddo
        endif
     enddo
  elseif ( nudge_tpw ) then
! Compute tpw_model
    tpw_mod(:,:) = 0.
    do k=1,npz
       do j=js,je
          do i=is,ie
             tpw_mod(i,j) = tpw_mod(i,j) + q(i,j,k,1)*delp(i,j,k)
          enddo
       enddo
    enddo

   do j=js,je
      do i=is,ie
         tpw_dat = tpw_dat(i,j) / max(tpw_mod(i,j), q_min)
      enddo
   enddo
   if(nudge_debug) call prt_maxmin('TPW_rat', tpw_dat, is, ie, js, je, 0, 1, 1., master)

   do k=1,npz

      do iq=2,nwat
         do j=js,je
            do i=is,ie
               q(i,j,k,iq) = q(i,j,k,iq)*delp(i,j,k)
            enddo
         enddo
      enddo

      do j=js,je
         do i=is,ie
            delp(i,j,k) = delp(i,j,k)*(1.-q(i,j,k,1))
                  q_rat = max(0.25,  min(tpw_dat(i,j), 4.))
             q(i,j,k,1) = q(i,j,k,1)*(tau_tpw/factor + mask(i,j)*dt*q_rat)/(tau_tpw/factor + mask(i,j)*dt)
            delp(i,j,k) = delp(i,j,k)/(1.-q(i,j,k,1))
         enddo
      enddo

      do iq=2,nwat
         do j=js,je
            do i=is,ie
               q(i,j,k,iq) = q(i,j,k,iq)/delp(i,j,k)
            enddo
         enddo
      enddo

   enddo   ! k-loop
  endif

  deallocate ( q_obs )
  deallocate ( ps_obs )



  if ( breed_vortex )   &
  call breed_srf_winds(Time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, ua, va, u_dt, v_dt, pt, q, nwat, zvir)

  if ( nudge_winds ) then
     deallocate ( u_obs )
     deallocate ( v_obs )
  endif

 end  subroutine fv_nwp_nudge


 subroutine compute_slp(isc, iec, jsc, jec, tm, ps, gz, slp)
 integer, intent(in):: isc, iec, jsc, jec
 real, intent(in), dimension(isc:iec,jsc:jec):: tm, ps, gz
 real, intent(out):: slp(isc:iec,jsc:jec)
 integer:: i,j

    do j=jsc,jec
       do i=isc,iec
          slp(i,j) = ps(i,j) * exp( gz(i,j)/(rdgas*(tm(i,j) + 3.25E-3*gz(i,j)/grav)) )
       enddo
    enddo

 end subroutine compute_slp


 subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, u_obs, v_obs, t_obs, q_obs,  &
                    tpw_dat, phis, gz_int, npz)
  type(time_type), intent(in):: Time
  integer,         intent(in):: npz           ! vertical dimension
  real,            intent(in):: zvir
  real,            intent(in):: dt
  real, intent(in), dimension(npz+1):: ak, bk
  real, intent(in), dimension(isd:ied,jsd:jed):: phis
  real, intent(in), dimension(isd:ied,jsd:jed,npz):: delp
  real, intent(inout), dimension(isd:ied,jsd:jed):: ps
  real, intent(out), dimension(is:ie,js:je):: ts, ps_obs
  real, intent(out), dimension(is:ie,js:je,npz):: u_obs, v_obs, t_obs, q_obs
  real, intent(out)::  gz_int(is:ie,js:je)
  real, intent(out):: tpw_dat(is:ie,js:je)
! local:
  real(KIND=4), allocatable:: ut(:,:,:), vt(:,:,:)
  real, dimension(is:ie,js:je):: h1, h2
  integer :: seconds, days
  integer :: i,j,k
  real :: alpha, beta

  call get_time (time, seconds, days)

  seconds = seconds - nint(dt)

! Data must be "time_interval" (hr) apart; keep two time levels in memory

  no_obs = .false.
  analysis_time = .false.

  if ( mod(seconds, time_interval) == 0 ) then

    if ( nfile == nfile_total ) then
         no_obs = .true.
         forecast_mode = .true.
         if(print_end_nudge)  then
            print_end_nudge = .false.
            if (master) write(*,*) '*** L-S nudging Ended at', days, seconds
         endif
         return              ! free-running mode
    endif

      ps_dat(:,:,1) = ps_dat(:,:,2)
      if ( nudge_winds ) then
         u_dat(:,:,:,1) = u_dat(:,:,:,2)
         v_dat(:,:,:,1) = v_dat(:,:,:,2)
      endif
      t_dat(:,:,:,1) = t_dat(:,:,:,2)
      q_dat(:,:,:,1) = q_dat(:,:,:,2)

!---------------
! Read next data
!---------------
      nfile = nfile + 1
      call get_ncep_analysis ( ps_dat(:,:,2), u_dat(:,:,:,2), v_dat(:,:,:,2),    &
                              t_dat(:,:,:,2), q_dat(:,:,:,2), zvir,  &
                              ts, nfile, file_names(nfile) )
      analysis_time = .true.
      time_nudge = dt
  else
      time_nudge = time_nudge + dt
  endif

!--------------------
! Time interpolation:
!--------------------

  beta = time_nudge / real(time_interval)

  if ( beta < 0. .or. beta >  (1.+1.E-7) ) then
       call mpp_error(FATAL,'==> Error from get_obs:data out of range')
  endif

  alpha = 1. - beta

! Warning: ps_data are not adjusted for the differences in terrain yet
  ps_obs(:,:)  = alpha*ps_dat(:,:,1) + beta*ps_dat(:,:,2)

  allocate ( ut(is:ie,js:je,npz) )
  allocate ( vt(is:ie,js:je,npz) )

  if ( nudge_winds ) then

       call remap_uv(npz, ak,  bk, ps(is:ie,js:je), delp,  ut,     vt,   &
                     km, ps_dat(is:ie,js:je,1),  u_dat(:,:,:,1), v_dat(:,:,:,1) )

       u_obs(:,:,:) = alpha*ut(:,:,:)
       v_obs(:,:,:) = alpha*vt(:,:,:)

       call remap_uv(npz, ak, bk, ps(is:ie,js:je), delp,   ut,      vt,   &
                     km, ps_dat(is:ie,js:je,2),  u_dat(:,:,:,2), v_dat(:,:,:,2) )

       u_obs(:,:,:) = u_obs(:,:,:) + beta*ut(:,:,:)
       v_obs(:,:,:) = v_obs(:,:,:) + beta*vt(:,:,:)
  endif

! if ( nudge_t .or. nudge_virt .or. nudge_q .or. nudge_hght .or. nudge_tpw ) then

       call remap_tq(npz, ak, bk, ps(is:ie,js:je), delp,  ut,  vt,  &
                     km,  ps_dat(is:ie,js:je,1),  t_dat(:,:,:,1), q_dat(:,:,:,1), zvir)

       t_obs(:,:,:) = alpha*ut(:,:,:)
       q_obs(:,:,:) = alpha*vt(:,:,:)

       call remap_tq(npz, ak, bk, ps(is:ie,js:je), delp,  ut,  vt,  &
                     km,  ps_dat(is:ie,js:je,2),  t_dat(:,:,:,2), q_dat(:,:,:,2), zvir)

       t_obs(:,:,:) = t_obs(:,:,:) + beta*ut(:,:,:)
       q_obs(:,:,:) = q_obs(:,:,:) + beta*vt(:,:,:)

           do j=js,je
              do i=is,ie
                 tpw_dat(i,j) = 0.
              enddo
           enddo
       if ( nudge_tpw ) then
           do k=1,km
           do j=js,je
              do i=is,ie
                 tpw_dat(i,j) = tpw_dat(i,j) + q_obs(i,j,k) *     &
                              ( ak0(k+1)-ak0(k) + (bk0(k+1)-bk0(k))*ps_obs(i,j) )
              enddo
           enddo
           enddo
       endif
! endif

  if ( nudge_hght ) then
       call get_int_hght(h1, npz, ak, bk, ps(is:ie,js:je), delp, ps_dat(is:ie,js:je,1), t_dat(:,:,:,1))
!      if(nudge_debug) call prt_maxmin('H_1', h1, is, ie, js, je, 0, 1, 1./grav, master)

       call get_int_hght(h2, npz, ak, bk, ps(is:ie,js:je), delp, ps_dat(is:ie,js:je,2), t_dat(:,:,:,2))
!      if(nudge_debug) call prt_maxmin('H_2', h2, is, ie, js, je, 0, 1, 1./grav, master)

       gz_int(:,:) = alpha*h1(:,:) + beta*h2(:,:) 
  endif

  deallocate ( ut ) 
  deallocate ( vt ) 

 end subroutine get_obs


 subroutine fv_nwp_nudge_init(npz, zvir, ak, bk, ts, phis)
  integer,  intent(in):: npz           ! vertical dimension 
  real,     intent(in):: zvir
  real, intent(in), dimension(isd:ied,jsd:jed):: phis
  real, intent(in), dimension(npz+1):: ak, bk
  real, intent(out), dimension(is:ie,js:je):: ts
  logical found
  integer tsize(4)
  integer :: i, j, f_unit, unit, io, ierr, nt, k
  integer :: ncid

   master = gid==masterproc

   deg2rad = pi/180.
   rad2deg = 180./pi

   grid_size = 1.E7/real(npx-1)         ! mean grid size

   do nt=1,nfile_max
      file_names(nt) = "No_File_specified"
   enddo

   track_file_name = "No_File_specified"

#ifdef INTERNAL_FILE_NML
    read( input_nml_file, nml = fv_nwp_nudge_nml, iostat = io )
    ierr = check_nml_error(io,'fv_nwp_nudge_nml')
#else
    if( file_exist( 'input.nml' ) ) then
       unit = open_namelist_file ()
       io = 1
       do while ( io .ne. 0 )
          read( unit, nml = fv_nwp_nudge_nml, iostat = io, end = 10 )
          ierr = check_nml_error(io,'fv_nwp_nudge_nml')
       end do
10     call close_file ( unit )
    end if
#endif
    call write_version_number (version, tagname)
    if ( master ) then
         f_unit=stdlog()
         write( f_unit, nml = fv_nwp_nudge_nml )
         write(*,*) 'NWP nudging initialized.'
    endif

    if ( nudge_virt ) then
         nudge_t = .false.
!        nudge_q = .false.
    endif

    if ( nudge_t ) nudge_virt = .false.

    do nt=1,nfile_max
      if ( file_names(nt) == "No_File_specified" ) then
           nfile_total = nt - 1
           if(master) write(*,*) 'Total of NCEP files specified=', nfile_total
           exit
      endif
    enddo


! Initialize remapping coefficients:

!   call field_size(file_names(1), 'T', tsize, field_found=found)
!   if ( found ) then
!        im = tsize(1); jm = tsize(2); km = tsize(3)
!        if(master)  write(*,*) 'NCEP analysis dimensions:', tsize
!   else
!        call mpp_error(FATAL,'==> Error from get_ncep_analysis: T field not found')
!   endif
    call open_ncfile( file_names(1), ncid )        ! open the file
    call get_ncdim1( ncid, 'lon', im )
    call get_ncdim1( ncid, 'lat', jm )
    call get_ncdim1( ncid, 'lev', km )
    if(master)  write(*,*) 'NCEP analysis dimensions:', im, jm, km

    allocate ( s2c(is:ie,js:je,4) )
    allocate ( id1(is:ie,js:je) )
    allocate ( id2(is:ie,js:je) )
    allocate ( jdc(is:ie,js:je) )

    allocate (  lon(im) )
    allocate (  lat(jm) )

!   call read_data (file_names(1), 'LAT', lat, no_domain=.true.)
!   call read_data (file_names(1), 'LON', lon, no_domain=.true.)
    call get_var1_double (ncid, 'lon', im, lon )
    call get_var1_double (ncid, 'lat', jm, lat )

! Convert to radian
    do i=1,im
       lon(i) = lon(i) * deg2rad ! lon(1) = 0.
    enddo
    do j=1,jm
       lat(j) = lat(j) * deg2rad
    enddo
 
    allocate ( ak0(km+1) )
    allocate ( bk0(km+1) )

!   call read_data (file_names(1), 'hyai', ak0, no_domain=.true.)
!   call read_data (file_names(1), 'hybi', bk0, no_domain=.true.)
    call get_var1_double (ncid, 'hyai', km+1, ak0 )
    call get_var1_double (ncid, 'hybi', km+1, bk0 )
    call close_ncfile( ncid )

! Note: definition of NCEP hybrid is p(k) = a(k)*1.E5 + b(k)*ps
    ak0(:) = ak0(:) * 1.E5

! Limiter to prevent NAN at top during remapping 
    ak0(1) = max(1.e-8, ak0(1))

   if ( master ) then
      do k=1,npz
         write(*,*) k, 0.5*(ak(k)+ak(k+1))+0.5*(bk(k)+bk(k+1))*1.E5,  'del-B=', bk(k+1)-bk(k)
      enddo
   endif

   if ( k_breed==0 ) k_breed = ks
!  k_breed = ks

   call slp_obs_init

!-----------------------------------------------------------
! Initialize lat-lon to Cubed bi-linear interpolation coeff:
!-----------------------------------------------------------
    call remap_coef

    allocate ( gz0(is:ie,js:je) )
    allocate (ps_dat(is:ie,js:je,2) )
    allocate ( u_dat(is:ie,js:je,km,2) )
    allocate ( v_dat(is:ie,js:je,km,2) )
    allocate ( t_dat(is:ie,js:je,km,2) )
    allocate ( q_dat(is:ie,js:je,km,2) )


! Get first dataset
    nt = 2
    nfile = 1
    call get_ncep_analysis ( ps_dat(:,:,nt), u_dat(:,:,:,nt), v_dat(:,:,:,nt),     &
                            t_dat(:,:,:,nt), q_dat(:,:,:,nt), zvir,   &
                            ts, nfile, file_names(nfile) )


    module_is_initialized = .true.
    
 end subroutine fv_nwp_nudge_init


 subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname )
  real,     intent(in):: zvir
  character(len=128), intent(in):: fname
  integer,  intent(inout):: nfile
!
  real, intent(out), dimension(is:ie,js:je):: ts
  real, intent(out), dimension(is:ie,js:je):: ps
  real(KIND=4), intent(out), dimension(is:ie,js:je,km):: u, v, t, q
! local:
  real, allocatable:: oro(:,:), wk2(:,:), wk3(:,:,:)
  real tmean
  integer:: i, j, k, npt
  integer:: i1, i2, j1, ncid
  logical found
  logical:: read_ts = .true.
  logical:: land_ts = .false.

  if( .not. file_exist(fname) ) then
     call mpp_error(FATAL,'==> Error from get_ncep_analysis: file not found')
  else
     if(master) write(*,*) 'Reading NCEP anlysis file:', fname 
  endif

!----------------------------------
! remap surface pressure and height:
!----------------------------------
     allocate ( wk2(im,jm) )

!    call read_data (fname, 'PS', wk2, no_domain=.true.)
     call open_ncfile( fname, ncid )        ! open the file
     call get_var2_double( ncid, 'PS', im, jm, wk2 )

     if(gid==0) call pmaxmin( 'PS_ncep', wk2, im,  jm, 0.01)

     do j=js,je
        do i=is,ie
           i1 = id1(i,j)
           i2 = id2(i,j)
           j1 = jdc(i,j)
           ps(i,j) = s2c(i,j,1)*wk2(i1,j1  ) + s2c(i,j,2)*wk2(i2,j1  ) +  &
                     s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
        enddo
     enddo

!    call read_data (fname, 'PHIS', wk2, no_domain=.true.)
     call get_var2_double( ncid, 'PHIS', im, jm, wk2 )

!    if(gid==0) call pmaxmin( 'ZS_ncep', wk2, im,  jm, 1./grav)
     do j=js,je
        do i=is,ie
           i1 = id1(i,j)
           i2 = id2(i,j)
           j1 = jdc(i,j)
           gz0(i,j) = s2c(i,j,1)*wk2(i1,j1  ) + s2c(i,j,2)*wk2(i2,j1  ) +  &
                      s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
        enddo
     enddo
     call prt_maxmin('ZS_ncep', gz0, is, ie, js, je, 0, 1, 1./grav, master)

     if ( read_ts ) then       ! read skin temperature; could be used for SST

!     call read_data (fname, 'TS', wk2, no_domain=.true.)
      call get_var2_double( ncid, 'TS', im, jm, wk2 )

      if ( .not. land_ts ) then
           allocate ( oro(im,jm) )

! Read NCEP ORO (1; land; 0: ocean; 2: sea_ice)
!          call read_data (fname, 'ORO', oro, no_domain=.true.)
           call get_var2_double( ncid, 'ORO', im, jm, oro )

           do j=1,jm
              tmean = 0.
              npt = 0
              do i=1,im
                 if( abs(oro(i,j)-1.) > 0.5 ) then
                     tmean = tmean + wk2(i,j)
                     npt = npt + 1
                 endif
              enddo
!-------------------------------------------------------
! Replace TS over interior land with zonal mean SST/Ice 
!-------------------------------------------------------
              if ( npt /= 0 ) then
                   tmean= tmean / real(npt)
                   do i=1,im
                      if( abs(oro(i,j)-1.) <= 0.5 ) then
                          if ( i==1 ) then
                               i1 = im;     i2 = 2
                          elseif ( i==im ) then
                               i1 = im-1;   i2 = 1
                          else
                               i1 = i-1;    i2 = i+1
                          endif
                          if ( abs(oro(i2,j)-1.)>0.5 ) then     ! east side has priority
                               wk2(i,j) = wk2(i2,j)
                          elseif ( abs(oro(i1,j)-1.)>0.5 ) then ! west side
                               wk2(i,j) = wk2(i1,j)
                          else
                               wk2(i,j) = tmean
                          endif
                      endif
                   enddo
              endif
           enddo
           deallocate ( oro )
      endif   ! land_ts

      if(gid==0) call pmaxmin('SST_ncep', wk2, im,  jm, 1.)
      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            ts(i,j) = s2c(i,j,1)*wk2(i1,j1  ) + s2c(i,j,2)*wk2(i2,j1  ) +  &
                      s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
         enddo
      enddo
      call prt_maxmin('SST_model', ts, is, ie, js, je, 0, 1, 1., master)

! Perform interp to FMS SST format/grid
      call ncep2fms( wk2 )
      if(gid==0) call pmaxmin( 'SST_ncep', sst_ncep, i_sst, j_sst, 1.)
      if(gid==0) call pmaxmin( 'SST_anom', sst_anom, i_sst, j_sst, 1.)

      endif     ! read_ts

      deallocate ( wk2 ) 

! Read in temperature:
      allocate (  wk3(im,jm,km) )

! Winds:
   if ( nudge_winds ) then

!     call read_data (fname, 'U',  wk3, no_domain=.true.)
      call get_var3_double( ncid, 'U', im, jm, km , wk3 )
      if( master ) call pmaxmin( 'U_ncep',   wk3, im*jm, km, 1.)

      do k=1,km
      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            u(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                       s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
         enddo
      enddo
      enddo

!     call read_data (fname, 'V',  wk3, no_domain=.true.)
      call get_var3_double( ncid, 'V', im, jm, km , wk3 )

      if( master ) call pmaxmin( 'V_ncep',  wk3, im*jm, km, 1.)
      do k=1,km
      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            v(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                       s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
         enddo
      enddo
      enddo

   endif

!  if ( nudge_t .or. nudge_virt .or. nudge_q .or. nudge_tpw .or. nudge_hght ) then

! Read in tracers: only sphum at this point
!     call read_data (fname, 'Q', wk3, no_domain=.true.)
      call get_var3_double( ncid, 'Q', im, jm, km , wk3 )

      if(gid==1) call pmaxmin( 'Q_ncep',   wk3, im*jm, km, 1.)
      do k=1,km
      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            q(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                       s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
         enddo
      enddo
      enddo

!     call read_data (fname, 'T',  wk3, no_domain=.true.)
      call get_var3_double( ncid, 'T', im, jm, km , wk3 )
      call close_ncfile ( ncid )

      if(gid==0) call pmaxmin( 'T_ncep',   wk3, im*jm, km, 1.)

      do k=1,km
      do j=js,je
         do i=is,ie
            i1 = id1(i,j)
            i2 = id2(i,j)
            j1 = jdc(i,j)
            t(i,j,k) = s2c(i,j,1)*wk3(i1,j1  ,k) + s2c(i,j,2)*wk3(i2,j1  ,k) +  &
                       s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
! Convert t to virtual temperature:
            t(i,j,k) = t(i,j,k)*(1.+zvir*q(i,j,k))
         enddo
      enddo
      enddo

!  endif

   deallocate ( wk3 ) 

! nfile = nfile + 1

 end subroutine get_ncep_analysis



 subroutine remap_coef

! local:
  real :: rdlon(im)
  real :: rdlat(jm)
  real:: a1, b1
  integer i,j, i1, i2, jc, i0, j0

  do i=1,im-1
     rdlon(i) = 1. / (lon(i+1) - lon(i))
  enddo
     rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im))

  do j=1,jm-1
     rdlat(j) = 1. / (lat(j+1) - lat(j))
  enddo

! * Interpolate to cubed sphere cell center
  do 5000 j=js,je

     do i=is,ie

       if ( agrid(i,j,1)>lon(im) ) then
            i1 = im;     i2 = 1
            a1 = (agrid(i,j,1)-lon(im)) * rdlon(im)
       elseif ( agrid(i,j,1)<lon(1) ) then
            i1 = im;     i2 = 1
            a1 = (agrid(i,j,1)+2.*pi-lon(im)) * rdlon(im)
       else
            do i0=1,im-1
            if ( agrid(i,j,1)>=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then
               i1 = i0;  i2 = i0+1
               a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0)
               go to 111
            endif
            enddo
       endif
111    continue

       if ( agrid(i,j,2)<lat(1) ) then
            jc = 1
            b1 = 0.
       elseif ( agrid(i,j,2)>lat(jm) ) then
            jc = jm-1
            b1 = 1.
       else
          do j0=1,jm-1
          if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then
               jc = j0
               b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc)
               go to 222
          endif
          enddo
       endif
222    continue

       if ( a1<0.0 .or. a1>1.0 .or.  b1<0.0 .or. b1>1.0 ) then
            write(*,*) 'gid=', gid, i,j,a1, b1
       endif

       s2c(i,j,1) = (1.-a1) * (1.-b1)
       s2c(i,j,2) =     a1  * (1.-b1)
       s2c(i,j,3) =     a1  *     b1
       s2c(i,j,4) = (1.-a1) *     b1
       id1(i,j) = i1
       id2(i,j) = i2
       jdc(i,j) = jc
     enddo   !i-loop
5000 continue   ! j-loop

 end subroutine remap_coef


 subroutine ncep2fms( sst )
  real, intent(in):: sst(im,jm)
! local:
  real :: rdlon(im)
  real :: rdlat(jm)
  real:: a1, b1
  real:: delx, dely
  real:: xc, yc    ! "data" location
  real:: c1, c2, c3, c4
  integer i,j, i1, i2, jc, i0, j0, it, jt

  do i=1,im-1
     rdlon(i) = 1. / (lon(i+1) - lon(i))
  enddo
     rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im))

  do j=1,jm-1
     rdlat(j) = 1. / (lat(j+1) - lat(j))
  enddo

! * Interpolate to "FMS" 1x1 SST data grid
! lon: 0.5, 1.5, ..., 359.5
! lat: -89.5, -88.5, ... , 88.5, 89.5

  delx = 360./real(i_sst) 
  dely = 180./real(j_sst) 

  jt = 1
  do 5000 j=1,j_sst

     yc = (-90. + dely * (0.5+real(j-1)))  * deg2rad
     if ( yc<lat(1) ) then
            jc = 1
            b1 = 0.
     elseif ( yc>lat(jm) ) then
            jc = jm-1
            b1 = 1.
     else
          do j0=jt,jm-1
          if ( yc>=lat(j0) .and. yc<=lat(j0+1) ) then
               jc = j0
               jt = j0
               b1 = (yc-lat(jc)) * rdlat(jc)
               go to 222
          endif
          enddo
     endif
222  continue
     it = 1

     do i=1,i_sst
        xc = delx * (0.5+real(i-1)) * deg2rad
       if ( xc>lon(im) ) then
            i1 = im;     i2 = 1
            a1 = (xc-lon(im)) * rdlon(im)
       elseif ( xc<lon(1) ) then
            i1 = im;     i2 = 1
            a1 = (xc+2.*pi-lon(im)) * rdlon(im)
       else
            do i0=it,im-1
            if ( xc>=lon(i0) .and. xc<=lon(i0+1) ) then
               i1 = i0;  i2 = i0+1
               it = i0
               a1 = (xc-lon(i1)) * rdlon(i0)
               go to 111
            endif
            enddo
       endif
111    continue

!      if ( a1<0.0 .or. a1>1.0 .or.  b1<0.0 .or. b1>1.0 ) then
!           write(*,*) 'gid=', gid, i,j,a1, b1
!      endif
       c1 = (1.-a1) * (1.-b1)
       c2 =     a1  * (1.-b1)
       c3 =     a1  *     b1
       c4 = (1.-a1) *     b1
! Interpolated surface pressure
       sst_ncep(i,j) = c1*sst(i1,jc  ) + c2*sst(i2,jc  ) +    &
                       c3*sst(i2,jc+1) + c4*sst(i1,jc+1)
     enddo   !i-loop
5000 continue   ! j-loop

 end subroutine ncep2fms


 subroutine get_int_hght(h_int, npz, ak, bk, ps, delp, ps0, tv)
  integer, intent(in):: npz
  real,    intent(in):: ak(npz+1), bk(npz+1)
  real,    intent(in), dimension(is:ie,js:je):: ps, ps0
  real, intent(in), dimension(isd:ied,jsd:jed,npz):: delp
  real(KIND=4),  intent(in), dimension(is:ie,js:je,km):: tv
  real,   intent(out), dimension(is:ie,js:je):: h_int  ! g*height
! local:
  real, dimension(is:ie,km+1):: pn0, gz
  real:: logp(is:ie)
  integer i,j,k

  h_int(:,:) = 1.E25

  do 5000 j=js,je

     do k=1,km+1
        do i=is,ie
           pn0(i,k) = log( ak0(k) + bk0(k)*ps0(i,j) )
        enddo
     enddo 
!------
! Model
!------
     do i=is,ie
        logp(i) = ak(1)
     enddo
     do k=1,k_trop
       do i=is,ie
          logp(i) = logp(i) + delp(i,j,k)
       enddo
     enddo
     do i=is,ie
        logp(i) = log( logp(i) )
        gz(i,km+1) = gz0(i,j)   ! Data Surface geopotential
     enddo

! Linear in log-p interpolation
     do i=is,ie
        do k=km,1,-1
           gz(i,k) = gz(i,k+1) + rdgas*tv(i,j,k)*(pn0(i,k+1)-pn0(i,k))
           if ( logp(i)>=pn0(i,k) .and. logp(i)<=pn0(i,k+1) ) then
               h_int(i,j) = gz(i,k+1) + (gz(i,k)-gz(i,k+1))*(pn0(i,k+1)-logp(i))/(pn0(i,k+1)-pn0(i,k))
               goto 400
          endif
       enddo
400    continue
    enddo

5000 continue


 end subroutine get_int_hght



 subroutine remap_tq( npz, ak,  bk,  ps, delp,  t,  q,  &
                      kmd, ps0, ta, qa, zvir)
  integer, intent(in):: npz, kmd
  real,    intent(in):: zvir
  real,    intent(in):: ak(npz+1), bk(npz+1)
  real,    intent(in), dimension(is:ie,js:je):: ps0
  real,    intent(inout), dimension(is:ie,js:je):: ps
  real, intent(in), dimension(isd:ied,jsd:jed,npz):: delp
  real(KIND=4),    intent(in), dimension(is:ie,js:je,kmd):: ta
  real(KIND=4),    intent(in), dimension(is:ie,js:je,kmd):: qa
  real(KIND=4),    intent(out), dimension(is:ie,js:je,npz):: t
  real(KIND=4),    intent(out), dimension(is:ie,js:je,npz):: q
! local:
  real, dimension(is:ie,kmd):: tp, qp
  real, dimension(is:ie,kmd+1):: pe0, pn0
  real, dimension(is:ie,npz):: qn1
  real, dimension(is:ie,npz+1):: pe1, pn1
  integer i,j,k


  do 5000 j=js,je

     do k=1,kmd+1
        do i=is,ie
           pe0(i,k) = ak0(k) + bk0(k)*ps0(i,j)
           pn0(i,k) = log(pe0(i,k))
       enddo
     enddo 
!------
! Model
!------
     do i=is,ie
        pe1(i,1) = ak(1)
     enddo
     do k=1,npz
       do i=is,ie
          pe1(i,k+1) = pe1(i,k) + delp(i,j,k)
       enddo
     enddo
     do i=is,ie
        ps(i,j) = pe1(i,npz+1)
     enddo
     do k=1,npz+1
        do i=is,ie
           pn1(i,k) = log(pe1(i,k))
        enddo
     enddo

   if ( nudge_t .or. nudge_q ) then
        do k=1,kmd
           do i=is,ie
              qp(i,k) = qa(i,j,k)
           enddo
        enddo
        call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_data)
        do k=1,npz
           do i=is,ie
              q(i,j,k) = qn1(i,k)
           enddo
        enddo
   endif

   do k=1,kmd
      do i=is,ie
         tp(i,k) = ta(i,j,k)
      enddo
   enddo
   call mappm(kmd, pn0, tp, npz, pn1, qn1, is,ie, 1, kord_data)

   if ( nudge_t ) then
        do k=1,npz
           do i=is,ie
              t(i,j,k) = qn1(i,k)/(1.+zvir*q(i,j,k))
           enddo
        enddo
   else
        do k=1,npz
           do i=is,ie
              t(i,j,k) = qn1(i,k)
           enddo
        enddo
   endif

5000 continue

 end subroutine remap_tq


 subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0)
  integer, intent(in):: npz
  real,    intent(in):: ak(npz+1), bk(npz+1)
  real,    intent(inout):: ps(is:ie,js:je)
  real, intent(in), dimension(isd:ied,jsd:jed,npz):: delp
  real(KIND=4),    intent(inout), dimension(is:ie,js:je,npz):: u, v
!
  integer, intent(in):: kmd
  real,    intent(in):: ps0(is:ie,js:je)
  real(KIND=4),    intent(in), dimension(is:ie,js:je,kmd):: u0, v0
!
! local:
  real, dimension(is:ie,kmd+1):: pe0
  real, dimension(is:ie,npz+1):: pe1
  real, dimension(is:ie,kmd):: qt
  real, dimension(is:ie,npz):: qn1
  integer i,j,k

  do 5000 j=js,je
!------
! Data
!------
     do k=1,kmd+1
       do i=is,ie
          pe0(i,k) = ak0(k) + bk0(k)*ps0(i,j)
       enddo
     enddo
!------
! Model
!------
     do i=is,ie
        pe1(i,1) = ak(1)
     enddo
     do k=1,npz
       do i=is,ie
          pe1(i,k+1) = pe1(i,k) + delp(i,j,k)
       enddo
     enddo
     do i=is,ie
        ps(i,j) = pe1(i,npz+1)
     enddo
!------
! map u
!------
      do k=1,kmd
         do i=is,ie
            qt(i,k) = u0(i,j,k)
         enddo
      enddo
      call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data)
      do k=1,npz
         do i=is,ie
            u(i,j,k) = qn1(i,k)
         enddo
      enddo
!------
! map v
!------
      do k=1,kmd
         do i=is,ie
            qt(i,k) = v0(i,j,k)
         enddo
      enddo
      call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data)
      do k=1,npz
         do i=is,ie
            v(i,j,k) = qn1(i,k)
         enddo
      enddo
5000 continue

 end subroutine remap_uv



 subroutine fv_nwp_nudge_end

    deallocate ( ps_dat )
    deallocate (  t_dat )
    deallocate (  q_dat )

    if ( nudge_winds ) then
         deallocate ( u_dat )
         deallocate ( v_dat )
    endif

    deallocate ( s2c )
    deallocate ( id1 )
    deallocate ( id2 )
    deallocate ( jdc )

    deallocate ( ak0 )
    deallocate ( bk0 )
    deallocate ( lat ) 
    deallocate ( lon ) 

    deallocate ( gz0 ) 

 end subroutine fv_nwp_nudge_end


 subroutine get_tc_mask(time, mask)
      real :: slp_mask = 100900.    ! crtical SLP to apply mask
! Input
      type(time_type), intent(in):: time
      real, intent(inout):: mask(is:ie,js:je)
! local
      real:: pos(2)
      real:: slp_o         ! sea-level pressure (Pa)
      real:: w10_o         ! 10-m wind
      real:: r_vor, p_vor
      real:: dist
      integer n, i, j

    do 5000 n=1,nstorms      ! looop through all storms
!----------------------------------------
! Obtain slp observation
!----------------------------------------
      call get_slp_obs(time, nobs_tc(n), x_obs(1,n), y_obs(1,n), wind_obs(1,n),  mslp_obs(1,n), mslp_out(1,n), rad_out(1,n),   &
                       time_tc(1,n), pos(1), pos(2), w10_o, slp_o, r_vor, p_vor)

      if ( slp_o<880.E2 .or. slp_o>min(slp_env,slp_mask) .or. abs(pos(2))*rad2deg>40. ) goto 5000  ! next storm

      if ( r_vor < 30.E3 ) then
           r_vor = r_min + (slp_env-slp_o)/20.E2*r_inc   ! radius of influence
      endif

      do j=js, je
         do i=is, ie
            dist = great_circle_dist(pos, agrid(i,j,1:2), radius)
            if( dist < 5.*r_vor  ) then 
                if ( strong_mask ) then
                     mask(i,j) = mask(i,j) * ( 1. - exp(-(0.50*dist/r_vor)**2)*min(1.,(slp_env-slp_o)/5.E2) )
                else
! Better analysis data (NCEP 2007 and later) may use a weak mask
                     mask(i,j) = mask(i,j) * ( 1. - exp(-(0.70*dist/r_vor)**2)*min(1.,(slp_env-slp_o)/10.E2) )
                endif
            endif
         enddo             ! i-loop
      enddo                ! end j-loop

5000 continue

 end subroutine get_tc_mask


 subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, delp, u, v, pt, q, nwat, zvir)
!------------------------------------------------------------------------------------------
! Purpose:  Vortex-breeding by nudging sea-level-pressure towards single point observations
! Note: conserve water mass, geopotential, and momentum at the expense of dry air mass
!------------------------------------------------------------------------------------------
! Input
      integer, intent(in):: nstep, npz, nwat
      real, intent(in):: dt       ! (small) time step in seconds
      real, intent(in):: zvir
      real, intent(in), dimension(npz+1):: ak, bk
      real, intent(in):: phis(isd:ied,jsd:jed)
! Input/Output
      real, intent(inout):: u(isd:ied,jsd:jed+1,npz)
      real, intent(inout):: v(isd:ied+1,jsd:jed,npz)
      real, intent(inout), dimension(isd:ied,jsd:jed,npz):: delp, pt
      real, intent(inout)::q(isd:ied,jsd:jed,npz,*)

      real, intent(inout):: pk(is:ie,js:je, npz+1)          ! pe**kappa
      real, intent(inout):: pe(is-1:ie+1, npz+1,js-1:je+1)  ! edge pressure (pascal)
      real, intent(out):: peln(is:ie,npz+1,js:je)           ! ln(pe)
! local
      type(time_type):: time
      real:: ps(is:ie,js:je)
      real:: dist(is:ie,js:je)
      real::   tm(is:ie,js:je)
      real::  slp(is:ie,js:je)
      real:: pos(2)
      real:: slp_o         ! sea-level pressure (Pa)
      real:: w10_o, p_env, pre_env
      real:: r_vor
      real:: relx0, relx, f1, pbreed, pbtop, pkz, delp0, dp0
      real:: ratio, p_count, p_sum, a_sum, mass_sink, delps
      real:: p_lo, p_hi, tau_vt
      real:: split_time, fac, pdep, r2, r3
      integer year, month, day, hour, minute, second
      integer n, i, j, k, iq, k0

    if ( nstorms==0 ) then
         if(master) write(*,*) 'NO TC data to process'
         return
    endif

   if ( k_breed==0 ) k_breed = ks
!  k_breed = ks

   k0 = k_breed

! Advance (local) time
    call get_date(fv_time, year, month, day, hour, minute, second)
    if ( year /= year_track_data ) then
        if (master) write(*,*) 'Warning: The year in storm track data is not the same as model year' 
        return
     endif
    time = fv_time   ! fv_time is the time at past time step (set in fv_diag)
    split_time = calday(year, month, day, hour, minute, second) + dt*real(nstep)/86400.

    elapsed_time = elapsed_time + dt
    if ( elapsed_time > nudged_time + 0.1 ) then
         if(print_end_breed)  then
            print_end_breed = .false.
            if (master) write(*,*) '*** Vortext Breeding Ended at', day, hour, minute, second
         endif
         return        !  time to return to forecast mode
    endif

    do j=js,je
! ---- Compute ps
       do i=is,ie
          ps(i,j) = ak(1)
       enddo
       do k=1,npz
          do i=is,ie
             ps(i,j) = ps(i,j) + delp(i,j,k)
          enddo
       enddo
! Compute lowest layer air temperature:
       do i=is,ie
              pkz = (pk(i,j,npz+1)-pk(i,j,npz))/(kappa*log(ps(i,j)/(ps(i,j)-delp(i,j,npz))))
          tm(i,j) = pkz*pt(i,j,npz)/(cp_air*(1.+zvir*q(i,j,npz,1)))
       enddo
    enddo

    do k=k_breed+1,npz

       if ( conserve_mom ) then
       do j=js,je+1
          do i=is,ie
             u(i,j,k) = u(i,j,k) * (delp(i,j-1,k)+delp(i,j,k))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             v(i,j,k) = v(i,j,k) * (delp(i-1,j,k)+delp(i,j,k))
          enddo
       enddo
       endif

       do j=js,je
          do i=is,ie
             pt(i,j,k) = pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k))
          enddo
       enddo
! Convert tracer moist mixing ratio to mass
       do iq=1,nwat
          do j=js,je
             do i=is,ie
                q(i,j,k,iq) = q(i,j,k,iq) * delp(i,j,k)
             enddo
          enddo
       enddo

    enddo

    do 5000 n=1,nstorms      ! looop through all storms

!----------------------------------------
! Obtain slp observation
!----------------------------------------
      call get_slp_obs(time, nobs_tc(n), x_obs(1,n), y_obs(1,n), wind_obs(1,n),  mslp_obs(1,n), mslp_out(1,n), rad_out(1,n),   &
                       time_tc(1,n), pos(1), pos(2), w10_o, slp_o, r_vor, p_env, stime=split_time, fact=fac)

      if ( slp_o<87500. .or. slp_o>slp_env .or. abs(pos(2))*rad2deg>45. ) then
           goto 5000         ! next storm
      endif

      if(nudge_debug .and. master)    &
         write(*,*) 'Vortex breeding for TC:', n, ' slp=',slp_o/100.,pos(1)*rad2deg,pos(2)*rad2deg

#ifndef CONST_BREED_DEPTH
! Determine pbtop (top pressure of vortex breeding)

      if ( slp_o > 1000.E2 ) then
!          pbtop = 850.E2
           pbtop = 900.E2
      else
!          pbtop = max(125.E2, 850.E2-30.*(1000.E2-slp_o))
!          pbtop = max(125.E2, 900.E2-30.*(1000.E2-slp_o))
           pbtop = max(120.E2, 900.E2-40.*(1000.E2-slp_o))
      endif

      do k=1,npz
         pbreed = ak(k) + bk(k)*1000.E2
         if ( pbreed>pbtop ) then
              k0 = k
              exit
         endif
      enddo
      k0 = max(k0, k_breed)
#endif

      do j=js, je
         do i=is, ie
            dist(i,j) = great_circle_dist( pos, agrid(i,j,1:2), radius)
         enddo
      enddo

      call compute_slp(is, ie, js, je, tm, ps, phis(is:ie,js:je), slp)

    if ( r_vor < 30.E3 .or. p_env<900.E2 ) then

! Compute r_vor & p_env
         r_vor = r_min + (slp_env-slp_o)/25.E2*r_inc

123   continue
      p_count = 0.
        p_sum = 0.
        a_sum = 0.
      do j=js, je
         do i=is, ie
            if( dist(i,j)<(r_vor+del_r) .and. dist(i,j)>r_vor .and. phis(i,j)<500.*grav ) then 
                p_count = p_count + 1.
                  p_sum = p_sum + slp(i,j)*area(i,j) 
                  a_sum = a_sum + area(i,j) 
            endif
         enddo
      enddo

      call mp_reduce_sum(p_count)

      if ( p_count<32. ) then
           if(nudge_debug .and. master) write(*,*) p_count, 'Skipping obs: too few p_count'
           goto 5000
      endif

      call mp_reduce_sum(p_sum)
      call mp_reduce_sum(a_sum)
      p_env = p_sum / a_sum

      if(nudge_debug .and. master) write(*,*) 'Environmental SLP=', p_env/100., ' computed radius=', r_vor/1.E3

      if ( p_env>1020.E2 .or. p_env<900.E2 ) then
         if( nudge_debug ) then
            if(master)  write(*,*) 'Environmental SLP out of bound; skipping obs. p_count=', p_count, p_sum
            call prt_maxmin('SLP_breeding', slp, is, ie, js, je, 0, 1, 0.01, master)
         endif
         goto 5000
      endif

    endif

      pre_env = pre0_env

      if ( p_env < max(pre_env, slp_o + 250.0) ) then
         if(nudge_debug .and. master) then
            write(*,*) 'Computed environmental SLP too low'
            write(*,*) ' ', p_env/100., slp_o/100.,pos(1)*rad2deg, pos(2)*rad2deg
         endif

         if ( r_vor < 850.E3 ) then
              r_vor = r_vor + del_r
              if(nudge_debug .and. master) write(*,*) 'Vortex radius (km) increased to:', r_vor/1.E3
              goto 123
         else
              p_env = max( slp_o + 250.0, 1000.E2)
         endif
      endif

!     tau_vt = tau_vt_slp + 6.*(980.E2-slp_o)/100.
      tau_vt = tau_vt_slp * (1. + (960.E2-slp_o)/100.E2 )

      tau_vt = max(dt, tau_vt)

      if ( time_track ) then
           relx0  = min(1., fac*dt/tau_vt)
      else
           relx0  = min(1., dt/tau_vt)
      endif

      mass_sink = 0.
      do j=js, je
         do i=is, ie
            if( dist(i,j) < r_vor .and. phis(i,j)<500.*grav ) then
                f1 = dist(i,j)/r_vor
                relx = relx0*exp( -tau_vt_rad*f1**2 )
! Compute p_obs: assuming local radial distributions of slp are Gaussian
                p_hi = p_env - (p_env-slp_o) * exp( -r_hi*f1**2 )    ! upper bound
                p_lo = p_env - (p_env-slp_o) * exp( -r_lo*f1**2 )    ! lower bound

                if ( ps(i,j) > p_hi ) then 
! Under-development:
                     delps = relx*(ps(i,j) - p_hi)   ! Note: ps is used here to prevent
                                                     !       over deepening over terrain
                elseif ( slp(i,j) < p_lo ) then
! Over-development:
                      relx = max(0.5, relx0)
                     delps = relx*(slp(i,j) - p_lo)  ! Note: slp is used here
                else
                     goto 400        ! do nothing; proceed to next storm
                endif 

                if ( delps > 0. ) then
                      pbreed = ak(1)
                      do k=1,k0
                         pbreed = pbreed + delp(i,j,k)
                      enddo
                      f1 = 1. - delps/(ps(i,j)-pbreed)
                      do k=k0+1,npz
                         delp(i,j,k) = delp(i,j,k)*f1
                      enddo
                      mass_sink = mass_sink + delps*area(i,j)
                else
                      dp0 = abs(delps)
                      do k=npz,k0+1,-1
                         if ( abs(delps) < 1. ) then
                              delp(i,j,k) = delp(i,j,k) - delps
                              mass_sink = mass_sink + delps*area(i,j)
                              go to 400
                         else
!                             pdep = max(1.0, min(abs(0.5*delps), 0.2*dp0,  0.02*delp(i,j,k)))
                              pdep = max(1.0, min(abs(0.4*delps), 0.2*dp0,  0.02*delp(i,j,k)))
                              pdep = - min(pdep, abs(delps))
                              delp(i,j,k) = delp(i,j,k) - pdep
                              delps = delps - pdep
                              mass_sink = mass_sink + pdep*area(i,j)
                         endif
                      enddo
                endif

            endif
400     continue 
        enddo        ! end i-loop
      enddo        ! end j-loop

      call mp_reduce_sum(mass_sink)
      if ( abs(mass_sink)<1.E-40 ) goto 5000

      r2 = r_vor + del_r
      r3 = min(2500.E3, 5.*r_vor + del_r)

      p_sum = 0.
      do j=js, je
         do i=is, ie
            if( dist(i,j)<r3 .and. dist(i,j)>r2 ) then
                p_sum = p_sum + area(i,j) 
            endif
         enddo
      enddo

      call mp_reduce_sum(p_sum)
      mass_sink = mass_sink / p_sum ! mean delta pressure to be added back to the environment to conserve mass
      if(master .and. nudge_debug) write(*,*) 'TC#',n, 'Mass tele-ported (pa)=', mass_sink

      do j=js, je
         do i=is, ie
            if( dist(i,j)<r3 .and. dist(i,j)>r2 ) then
                pbreed = ak(1)
                do k=1,k_breed
                   pbreed = pbreed + delp(i,j,k)
                enddo
                f1 = 1. + mass_sink/(ps(i,j)-pbreed)
                do k=k_breed+1,npz
                   delp(i,j,k) = delp(i,j,k)*f1
                enddo
            endif
         enddo
      enddo

! ---- re-compute ps
      do j=js,je
         do i=is,ie
            ps(i,j) = ak(1)
         enddo
         do k=1,npz
            do i=is,ie
               ps(i,j) = ps(i,j) + delp(i,j,k)
            enddo
         enddo
      enddo

5000 continue

!--------------------------
! Update delp halo regions:
!--------------------------
    call mpp_update_domains(delp, domain, complete=.true.)

    do j=js-1,je+1
       do i=is-1,ie+1
          pe(i,1,j) = ak(1)
       enddo
       do k=2,npz+1
          do i=is-1,ie+1
             pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
          enddo
       enddo
    enddo

    do k=k_breed+1,npz+1
      do j=js,je
         do i=is,ie
            peln(i,k,j) = log(pe(i,k,j))
              pk(i,j,k) = pe(i,k,j)**kappa
         enddo
      enddo
    enddo


    do k=k_breed+1,npz

       if ( conserve_mom ) then
       do j=js,je+1
          do i=is,ie
             u(i,j,k) = u(i,j,k) / (delp(i,j-1,k)+delp(i,j,k))
          enddo
       enddo
       do j=js,je
          do i=is,ie+1
             v(i,j,k) = v(i,j,k) / (delp(i-1,j,k)+delp(i,j,k))
          enddo
       enddo
       endif

       do j=js,je
          do i=is,ie
             pt(i,j,k) = pt(i,j,k) / (pk(i,j,k+1)-pk(i,j,k))
          enddo
       enddo
    enddo


! Convert tracer mass back to moist mixing ratio
    do iq=1,nwat
       do k=k_breed+1,npz
          do j=js,je
             do i=is,ie
                q(i,j,k,iq) = q(i,j,k,iq) / delp(i,j,k)
             enddo
          enddo
       enddo
    enddo

    call mpp_update_domains(pt, domain, complete=.true.)

  end subroutine breed_slp_inline


 subroutine breed_srf_winds(time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, ua, va, u_dt, v_dt, pt, q, nwat, zvir)
!------------------------------------------------------------------------------------------
! Purpose:  Vortex-breeding by nudging sea-level-pressure towards single point observations
! Note: conserve water mass, geopotential, and momentum at the expense of dry air mass
!------------------------------------------------------------------------------------------
! Input
      type(time_type), intent(in):: time
      integer, intent(in):: npz, nwat
      real, intent(in):: dt       ! time step in seconds
      real, intent(in):: zvir
      real, intent(in), dimension(npz+1):: ak, bk
      real, intent(in):: phis(isd:ied,jsd:jed)
      real, intent(in)::   ps(isd:ied,jsd:jed)
      real, intent(in), dimension(is:ie,js:je,npz):: u_obs, v_obs
! Input/Output
      real, intent(inout), dimension(isd:ied,jsd:jed,npz):: delp, pt, ua, va, u_dt, v_dt
      real, intent(inout)::q(isd:ied,jsd:jed,npz,nwat)
! local
      real:: dist(is:ie,js:je), wind(is:ie,js:je)
      real::  slp(is:ie,js:je)
      real:: pos(2)
      real:: slp_o         ! sea-level pressure (Pa)
      real:: w10_o, p_env
      real:: r_vor, pc, p_count
      real:: r_max, speed, ut, vt, speed_local        ! tangent wind speed
      real:: u_bg, v_bg, mass, t_mass
      real:: relx0, relx, f1, rdt
      real:: z0
      real:: zz = 35.
!     real:: wind_fac = 1.2     ! adjustment factor to account for departure from 10 meter wind
                                ! Computed using Moon et al 2007 
      real:: wind_fac
      integer n, i, j, k, iq

    if ( nstorms==0 ) then
         if(master) write(*,*) 'NO TC data to process'
         return
    endif

       rdt = 1./dt
    relx0  = min(1., dt/tau_vt_wind)

    do j=js, je
       do i=is, ie
           slp(i,j) = ps(i,j)*exp(phis(i,j)/(rdgas*(pt(i,j,npz)+3.25E-3*phis(i,j)/grav)))
          wind(i,j) = sqrt( ua(i,j,npz)**2 + va(i,j,npz)**2 )
       enddo
    enddo

    do 3000 n=1,nstorms      ! looop through all storms

!----------------------------------------
! Obtain slp observation
!----------------------------------------
      call get_slp_obs(time, nobs_tc(n), x_obs(1,n), y_obs(1,n), wind_obs(1,n),  mslp_obs(1,n), mslp_out(1,n), rad_out(1,n),   &
                       time_tc(1,n), pos(1), pos(2), w10_o, slp_o, r_vor, p_env)

      if ( slp_o<87000. .or. slp_o>slp_env .or. abs(pos(2))*rad2deg>35. ) goto 3000         ! next storm

      do j=js, je
         do i=is, ie
            dist(i,j) = great_circle_dist( pos, agrid(i,j,1:2), radius )
         enddo
      enddo

      r_vor = r_min + (slp_env-slp_o)/25.E2*r_inc

!----------------------------------------------------
     if ( w10_o < 0. ) then   ! 10-m wind obs is not available
! Uses Atkinson_Holliday wind-pressure correlation
          w10_o = 3.446778 * (1010.-slp_o/100.)**0.644
     endif

! * Find model's SLP center nearest to the observation
! * Find maximum wind speed at the lowest model level

     speed_local = 0.
           r_max = -999.
              pc = 1013.E2
     do j=js, je
        do i=is, ie
           if( dist(i,j) < r_vor ) then

               pc = min(pc, slp(i,j))

               if ( speed_local < wind(i,j) ) then
                    speed_local = wind(i,j)
                    r_max = dist(i,j)
               endif

           endif
        enddo
     enddo

     speed = speed_local
     call mp_reduce_max(speed)     ! global max wind (near storm)
     call mp_reduce_min(pc)

    if ( speed_local < speed ) then
         r_max = -999.
    endif
    call mp_reduce_max(r_max)
    if( r_max<0. ) call mpp_error(FATAL,'==> Error in r_max')

! ---------------------------------------------------
! Determine surface wind speed and radius for nudging 
! ---------------------------------------------------

! Compute surface roughness z0 from w10, based on Eq (4) & (5) from Moon et al. 2007
     if ( w10_o > 12.5 ) then
          z0 = (0.085*w10_o - 0.58) * 1.E-3
     else
          z0 = 0.0185/grav*(0.001*w10_o**2 + 0.028*w10_o)**2
     endif

! lowest layer height: zz

     wind_fac = log(zz/z0) / log(10./z0)
     if( nudge_debug .and. master ) write(*,*) 'Wind adjustment factor=', wind_fac
     if( wind_fac<1. ) call mpp_error(FATAL,'==> Error in wind_fac')

     if ( pc < slp_o ) then
!--
!         The storm in the model is over developed
!         if ( (pc+3.0E2)>slp_o .or. speed <= w10_o ) go to 3000    ! next storm
!--
! using radius (r_max) as dtermined above;
! What if model's pressure center is very far from the observed?
! using obs wind
          speed = wind_fac*w10_o
     else
!         The storm in the model is under developed; using max wind
          speed = max(wind_fac*w10_o, speed)
          if ( pc>1009.E2 )  r_max = 0.5 * r_vor
     endif

! Some bounds on the radius of maximum wind:
     r_max = max(2.5*grid_size, r_max)      ! at least 2.5X the grid size
     r_max = min(0.75*r_vor, r_max)

     t_mass = 0.
     u_bg = 0.
     v_bg = 0.

     if ( add_bg_wind ) then
       p_count = 0.
       do j=js, je
          do i=is, ie
           if( dist(i,j) <= min(r_vor,2.*r_fac*r_max) .and. phis(i,j)<1.0*grav ) then
               mass = area(i,j)*delp(i,j,npz)
!-- using model winds ----------------------------------
!              u_bg = u_bg + ua(i,j,npz)*mass
!              v_bg = v_bg + va(i,j,npz)*mass
!-------------------------------------------------------
! Using analysis winds
               u_bg = u_bg + u_obs(i,j,npz)*mass
               v_bg = v_bg + v_obs(i,j,npz)*mass
               t_mass = t_mass + mass
               p_count = p_count + 1.
           endif
          enddo
       enddo
       call mp_reduce_sum(p_count)
       if ( p_count<16. ) go to 3000

       call mp_reduce_sum(t_mass)
       call mp_reduce_sum(u_bg)
       call mp_reduce_sum(v_bg)
       u_bg = u_bg / t_mass
       v_bg = v_bg / t_mass
!      if ( master ) write(*,*) pos(2)*rad2deg, 'vortex bg wind=', u_bg, v_bg
     endif

     relx = relx0
     k = npz                 ! lowest layer only
! Nudge wind in the "inner core":
      do j=js, je
         do i=is, ie
            if( dist(i,j) <= min(r_vor, r_fac*r_max) .and. phis(i,j)<1.0*grav ) then
                f1 = dist(i,j)/r_max
!               relx = relx0*exp( -f1**2 )
                relx = relx0*exp( -tau_vt_rad*f1**2 )
                if( dist(i,j)<=r_max ) then
                    speed_local = speed * f1
                else
                    speed_local = speed / f1**0.75
                endif
                call tangent_wind(vlon(i,j,1:3), vlat(i,j,1:3), speed_local, pos, agrid(i,j,1:2), ut, vt)
                ut = ut + u_bg
                vt = vt + v_bg
                u_dt(i,j,k) = u_dt(i,j,k) + relx*(ut-ua(i,j,k)) * rdt
                v_dt(i,j,k) = v_dt(i,j,k) + relx*(vt-va(i,j,k)) * rdt
! Update:
                ua(i,j,k) = ua(i,j,k) + relx*(ut-ua(i,j,k))
                va(i,j,k) = va(i,j,k) + relx*(vt-va(i,j,k))
            endif
400     continue 
        enddo        ! end i-loop
      enddo        ! end j-loop

3000 continue

  end subroutine breed_srf_winds

  subroutine tangent_wind ( elon, elat, speed, po, pp, ut, vt )
  real, intent(in):: speed
  real, intent(in):: po(2), pp(2)
  real, intent(in):: elon(3), elat(3)
  real, intent(out):: ut, vt
! local
  real:: e1(3), eo(3), ep(3), op(3)

  call latlon2xyz(po, eo)
  call latlon2xyz(pp, ep)

  op(:) = ep(:) - eo(:)
  call normalize_vect( op )

  call vect_cross(e1, ep, eo)

  ut = speed * (e1(1)*elon(1) + e1(2)*elon(2) + e1(3)*elon(3))
  vt = speed * (e1(1)*elat(1) + e1(2)*elat(2) + e1(3)*elat(3))

! SH:
  if ( po(2) < 0. ) then
       ut = -ut
       vt = -vt
  endif

  end subroutine tangent_wind


  subroutine get_slp_obs(time, nobs, lon_obs, lat_obs, w10, mslp, slp_out, r_out, time_obs,    &
                         x_o, y_o, w10_o, slp_o, r_vor, p_vor, stime, fact)
! Input
    type(time_type), intent(in):: time
    integer, intent(in)::  nobs   ! number of observations in this particular storm
    real(KIND=4), intent(in)::  lon_obs(nobs)
    real(KIND=4), intent(in)::  lat_obs(nobs)
    real(KIND=4), intent(in)::      w10(nobs)        ! observed 10-m widn speed
    real(KIND=4), intent(in)::     mslp(nobs)        ! observed SLP in pa
    real(KIND=4), intent(in)::  slp_out(nobs)        ! slp at r_out
    real(KIND=4), intent(in)::    r_out(nobs)        ! 
    real(KIND=4), intent(in):: time_obs(nobs)
    real, optional, intent(in):: stime
    real, optional, intent(out):: fact
! Output
    real, intent(out):: x_o , y_o      ! position of the storm center 
    real, intent(out):: w10_o          ! 10-m wind speed
    real, intent(out):: slp_o          ! Observed sea-level-pressure (pa)
    real, intent(out):: r_vor, p_vor
! Internal:
    real:: t_thresh
      real:: p1(2), p2(2)
      real time_model
      real fac
      integer year, month, day, hour, minute, second, n

      t_thresh = 600./86400.  ! unit: days

       w10_o = -100000.
       slp_o = -100000.
         x_o = -100.*pi
         y_o = -100.*pi
       p_vor = -1.E10
       r_vor = -1.E10

   if ( present(stime) ) then
      time_model = stime
   else
      call get_date(time, year, month, day, hour, minute, second)

      if ( year /= year_track_data ) then
           if (master) write(*,*) 'Warning: The year in storm track data is not the same as model year' 
           return
      endif

      time_model = calday(year, month, day, hour, minute, second)
!     if(nudge_debug .and. master) write(*,*) 'Model:', time_model, year, month, day, hour, minute, second
   endif

!-------------------------------------------------------------------------------------------
!     if ( time_model <= time_obs(1)  .or.  time_model >= time_obs(nobs) ) then
!          return
!-------------------------------------------------------------------------------------------

      if ( time_model <= (time_obs(1)-t_thresh)  .or.  time_model >= time_obs(nobs) ) return

      if ( time_model <=  time_obs(1) ) then
!--
! This is an attempt to perform vortex breeding several minutes before the first available observation
!--
                 w10_o =     w10(1)
                 slp_o =    mslp(1)
                   x_o = lon_obs(1)
                   y_o = lat_obs(1)
                 if ( present(fact) )  fact = 1.25
      else
           do n=1,nobs-1
             if( time_model >= time_obs(n) .and. time_model <= time_obs(n+1) ) then
                   fac = (time_model-time_obs(n)) / (time_obs(n+1)-time_obs(n))
                 w10_o =     w10(n) + (    w10(n+1)-    w10(n)) * fac
                 slp_o =    mslp(n) + (   mslp(n+1)-   mslp(n)) * fac
! Trajectory interpolation:
! Linear in (lon,lat) space
!                  x_o = lon_obs(n) + (lon_obs(n+1)-lon_obs(n)) * fac
!                  y_o = lat_obs(n) + (lat_obs(n+1)-lat_obs(n)) * fac
                 p1(1) = lon_obs(n);     p1(2) = lat_obs(n)
                 p2(1) = lon_obs(n+1);   p2(2) = lat_obs(n+1)
                 call intp_great_circle(fac, p1, p2, x_o, y_o)
!----------------------------------------------------------------------
                  if ( present(fact) )   fact = 1. + 0.25*cos(fac*2.*pi)
! Additional data from the extended best track
!                if ( slp_out(n)>0. .and. slp_out(n+1)>0. .and. r_out(n)>0. .and. r_out(n+1)>0. ) then
!                     p_vor = slp_out(n) + ( slp_out(n+1) - slp_out(n)) * fac
!                     r_vor =   r_out(n) + (   r_out(n+1) -   r_out(n)) * fac
!                endif
                 return
             endif
           enddo
      endif

  end subroutine get_slp_obs


  subroutine slp_obs_init
  integer:: unit, n, nobs
  character(len=3):: GMT
  character(len=9):: ts_name
  character(len=19):: comment
  integer:: mmddhh, yr, year, month, day, hour, MPH, islp
  integer:: it, i1, i2, p_ring, d_ring
  real:: lon_deg, lat_deg, cald, slp, mps

  nobs_tc(:) = 0
  time_tc(:,:) = 0.
  wind_obs(:,:) = -100000.
  mslp_obs(:,:) = -100000.
  x_obs(:,:) = - 100.*pi
  y_obs(:,:) = - 100.*pi

  mslp_out(:,:) = -1.E10
   rad_out(:,:) = -1.E10

  if( track_file_name == "No_File_specified" ) then
      if(master) write(*,*) 'No TC track file specified'
      return
  else
      unit = get_unit()
      open( unit, file=track_file_name)
  endif

  read(unit, *) year
  if(master) write(*,*) 'Reading TC track data for YEAR=', year

  year_track_data = year

  nstorms = 0
     nobs = 0
    month = 99

  if ( ibtrack ) then

!---------------------------------------------------------------
! The data format is from Ming Zhoa's processed ibTrack datasets
!---------------------------------------------------------------

    read(unit, *) ts_name, nobs, yr, month, day, hour

    if ( yr /= year ) then
         if(master) write(*, *) 'Year inconsistency found !!!'
         call mpp_error(FATAL,'==> Error in reading best track data')
    endif

    do while ( ts_name=='start' ) 

               nstorms  = nstorms + 1
       nobs_tc(nstorms) = nobs       ! observation count for this storm
       if(nudge_debug .and. master) write(*, *) 'Read Data for TC#', nstorms, nobs

       do it=1, nobs
          read(unit, *) lon_deg, lat_deg, mps, slp, yr, month, day, hour
!         if ( yr /= year ) then
!             if(master) write(*, *) 'Extended to year + 1', yr
!         endif
          cald = calday(yr, month, day, hour, 0, 0)
          time_tc(it,nstorms) = cald
          if(nudge_debug .and. master) write(*, 100) cald, month, day, hour, lon_deg, lat_deg, mps, slp

          wind_obs(it,nstorms) = mps       ! m/s
          mslp_obs(it,nstorms) = 100.*slp
             y_obs(it,nstorms) = lat_deg * deg2rad
             x_obs(it,nstorms) = lon_deg * deg2rad
       enddo

       read(unit, *) ts_name, nobs, yr, month, day, hour
    enddo
100  format(1x, f9.2, 1x, i3, 1x, i2, 1x, i2, 1x, f6.1, 1x, f6.1, 1x, f4.1, 1x, f6.1)

  else

  do while ( month /= 0 )

     read(unit, *) month, day, hour, GMT, lat_deg, lon_deg, MPH, islp, comment

     select case (month)

     case (99)                ! New storm record to start
          nstorms = nstorms + 1
          nobs = 0
          if(master) write(*, *) 'Reading data for TC#', nstorms, comment
     case ( 0)                ! end of record
          if(master) write(*, *) 'End of record reached'
     case default
           nobs = nobs + 1
           cald = calday(year, month, day, hour, 0, 0)
           time_tc(nobs,nstorms) = cald
           nobs_tc(nstorms) = nobs       ! observation count for this storm

          if(master) write(*, 200) nobs, cald,  month, day, hour, GMT, lat_deg, lon_deg, MPH, islp, comment
          mslp_obs(nobs,nstorms) = 100. * real(islp)
             y_obs(nobs,nstorms) = lat_deg * deg2rad
          if ( GMT == 'GMT' ) then
!                                  Transfrom x from (-180 , 180) to (0, 360) then to radian
             if ( lon_deg < 0 ) then 
                  x_obs(nobs,nstorms) = (360.+lon_deg) * deg2rad
             else
                  x_obs(nobs,nstorms) = (360.-lon_deg) * deg2rad
             endif
          elseif ( GMT == 'PAC' ) then   ! Pacific storms
             x_obs(nobs,nstorms) = lon_deg * deg2rad
          endif
     end select

  enddo

  endif

  close(unit)

  if(master) then 
     write(*,*) 'TC vortex breeding: total storms=', nstorms
     if ( nstorms/=0 ) then
          do n=1,nstorms
             write(*, *) 'TC#',n, ' contains ',  nobs_tc(n),' observations'
          enddo
     endif
  endif

200  format(i3, 1x,f9.4, 1x, i2, 1x, i2, 1x, i2, 1x, a3, f5.1, 1x, f5.1, 1x, i3, 1x, i4, 1x, a19)

  end subroutine slp_obs_init


  real function calday(year, month, day, hour, minute, sec)
! For time interpolation; Julian day (0 to 365 for non-leap year)
! input:
    integer, intent(in):: year, month, day, hour
    integer, intent(in):: minute, sec
! Local:
      integer n, m, ds, nday
      real tsec
      integer days(12)
      data days /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/

      ds = day - 1

      if( month /= 1 ) then
          do m=1, month-1
            if( m==2  .and. leap_year(year) ) then 
                ds = ds + 29
            else
                ds = ds + days(m)
            endif
          enddo
      endif

      if ( leap_year(year_track_data) ) then
           nday = 366
      else
           nday = 365
      endif

      calday = real((year-year_track_data)*nday + ds)  + real(hour*3600 + minute*60 + sec)/86400.

  end function calday


  logical function leap_year(ny)
  integer, intent(in):: ny
!
! Determine if year ny is a leap year
! Author: S.-J. Lin
   integer ny00
!
! No leap years prior to 0000
!
      parameter ( ny00 = 0000 )   ! The threshold for starting leap-year 

      if( ny >= ny00 ) then
         if( mod(ny,100) == 0. .and. mod(ny,400) == 0. ) then
             leap_year = .true.
         elseif( mod(ny,4) == 0. .and. mod(ny,100) /= 0.  ) then
             leap_year = .true.
         else
             leap_year = .false.
         endif
      else
          leap_year = .false.
      endif

  end function leap_year


 subroutine pmaxmin( qname, a, imax, jmax, fac )

      character(len=*)  qname
      integer imax, jmax
      integer i, j
      real a(imax,jmax)

      real qmin(jmax), qmax(jmax)
      real pmax, pmin
      real fac                     ! multiplication factor

      do j=1,jmax
         pmax = a(1,j)
         pmin = a(1,j)
         do i=2,imax
            pmax = max(pmax, a(i,j))
            pmin = min(pmin, a(i,j))
         enddo
         qmax(j) = pmax
         qmin(j) = pmin
      enddo
!
! Now find max/min of amax/amin
!
            pmax = qmax(1)
            pmin = qmin(1)
         do j=2,jmax
            pmax = max(pmax, qmax(j))
            pmin = min(pmin, qmin(j))
         enddo

      write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac

 end subroutine pmaxmin


 subroutine del2_uv(du, dv, cd, kmd, ntimes)
! This routine is for filtering the wind tendency
   integer, intent(in):: kmd
   integer, intent(in):: ntimes
   real,    intent(in):: cd            ! cd = K * da_min;   0 < K < 0.25
   real, intent(inout):: du(is:ie,js:je,kmd)
   real, intent(inout):: dv(is:ie,js:je,kmd)
! local:
   real, dimension(is:ie,js:je,kmd):: v1, v2, v3
   integer i,j,k

! transform to 3D Cartesian:
   do k=1,kmd
      do j=js,je
         do i=is,ie
            v1(i,j,k) = du(i,j,k)*vlon(i,j,1) + dv(i,j,k)*vlat(i,j,1)
            v2(i,j,k) = du(i,j,k)*vlon(i,j,2) + dv(i,j,k)*vlat(i,j,2)
            v3(i,j,k) = du(i,j,k)*vlon(i,j,3) + dv(i,j,k)*vlat(i,j,3)
         enddo
      enddo
   enddo

! Filter individual components as scalar:
   call del2_scalar( v1(is,js,1), cd, kmd, ntimes )
   call del2_scalar( v2(is,js,1), cd, kmd, ntimes )
   call del2_scalar( v3(is,js,1), cd, kmd, ntimes )

! Convert back to lat-lon components:
   do k=1,kmd
      do j=js,je
         do i=is,ie
            du(i,j,k) = v1(i,j,k)*vlon(i,j,1) + v2(i,j,k)*vlon(i,j,2) + v3(i,j,k)*vlon(i,j,3)
            dv(i,j,k) = v1(i,j,k)*vlat(i,j,1) + v2(i,j,k)*vlat(i,j,2) + v3(i,j,k)*vlat(i,j,3)
         enddo
      enddo
   enddo

 end subroutine del2_uv

 subroutine del2_scalar(qdt, cd, kmd, ntimes)
! This routine is for filtering the physics tendency
   integer, intent(in):: kmd
   integer, intent(in):: ntimes
   real,    intent(in):: cd            ! cd = K * da_min;   0 < K < 0.25
   real, intent(inout):: qdt(is:ie,js:je,kmd)
! local:
   real::  q(isd:ied,jsd:jed,kmd)
   real:: fx(isd:ied+1,jsd:jed), fy(isd:ied,jsd:jed+1)
   integer i,j,k, n, nt
   real :: damp

   damp = cd * da_min

   do k=1,kmd
      do j=js,je
         do i=is,ie
            q(i,j,k) = qdt(i,j,k)
         enddo
      enddo
   enddo
                     call timing_on('COMM_TOTAL')
   call mpp_update_domains(q, domain, complete=.true.)
                     call timing_off('COMM_TOTAL')

   do n=1,ntimes

   nt = ntimes - n

   do k=1,kmd

      if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 1)
      do j=js-nt,je+nt
         do i=is-nt,ie+1+nt
            fx(i,j) = dy(i,j)*sina_u(i,j)*(q(i-1,j,k)-q(i,j,k))*rdxc(i,j)
         enddo
      enddo

      if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 2)
      do j=js-nt,je+1+nt
         do i=is-nt,ie+nt
            fy(i,j) = dx(i,j)*sina_v(i,j)*(q(i,j-1,k)-q(i,j,k))*rdyc(i,j)
         enddo
      enddo

      if ( nt==0 ) then
          do j=js,je
             do i=is,ie
                qdt(i,j,k) = q(i,j,k) + damp*rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))
             enddo
          enddo
      else
          do j=js-nt,je+nt
             do i=is-nt,ie+nt
                q(i,j,k) = q(i,j,k) + damp*rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))
             enddo
          enddo
      endif
   enddo

   enddo

 end subroutine del2_scalar

 subroutine rmse_bias(a, rms, bias)
   real, intent(in):: a(is:ie,js:je)
   real, intent(out):: rms, bias
   integer:: i,j
   real:: total_area

   total_area = 4.*pi*radius**2

    rms = 0.
   bias = 0.
   do j=js,je
      do i=is,ie
         bias = bias + area(i,j) * a(i,j)
          rms = rms  + area(i,j) * a(i,j)**2
      enddo
   enddo
   call mp_reduce_sum(bias)
   call mp_reduce_sum(rms)

   bias = bias / total_area
    rms = sqrt( rms / total_area )

 end subroutine rmse_bias


 subroutine corr(a, b, co)
 real, intent(in):: a(is:ie,js:je), b(is:ie,js:je)
 real, intent(out):: co
 real:: m_a, m_b, std_a, std_b
 integer:: i,j
 real:: total_area

   total_area = 4.*pi*radius**2

! Compute standard deviation:
   call std(a, m_a, std_a)
   call std(b, m_b, std_b)

! Compute correlation: 
   co = 0.
   do j=js,je
      do i=is,ie
         co = co + area(i,j) * (a(i,j)-m_a)*(b(i,j)-m_b)
      enddo
   enddo
   call mp_reduce_sum(co)
   co = co / (total_area*std_a*std_b )

 end subroutine corr

 subroutine std(a, mean, stdv)
 real,  intent(in):: a(is:ie,js:je)
 real, intent(out):: mean, stdv
 integer:: i,j
 real:: total_area

   total_area = 4.*pi*radius**2

   mean = 0.
   do j=js,je
      do i=is,ie
         mean = mean + area(i,j) * a(i,j)
      enddo
   enddo
   call mp_reduce_sum(mean)
   mean = mean / total_area 

   stdv = 0.
   do j=js,je
      do i=is,ie
         stdv = stdv + area(i,j) * (a(i,j)-mean)**2
      enddo
   enddo
   call mp_reduce_sum(stdv)
   stdv = sqrt( stdv / total_area )

 end subroutine std


end module fv_nwp_nudge_mod


module fv_restart_mod
  !-----------------------------------------------------------------------
  !                   GNU General Public License                        
  !                                                                      
  ! This program is free software; you can redistribute it and/or modify it and  
  ! are expected to follow the terms of the GNU General Public License  
  ! as published by the Free Software Foundation; either version 2 of   
  ! the License, or (at your option) any later version.                 
  !                                                                      
  ! MOM 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.                                           
  !                                                                      
  ! For the full text of the GNU General Public License,                
  ! write to: Free Software Foundation, Inc.,                           
  !           675 Mass Ave, Cambridge, MA 02139, USA.                   
  ! or see:   http://www.gnu.org/licenses/gpl.html                      
  !-----------------------------------------------------------------------
  ! 
  ! <CONTACT EMAIL= "Jeffrey.Durachta@noaa.gov">Jeffrey Durachta </CONTACT>

  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

  !<OVERVIEW>
  ! Restart facilities for FV core
  !</OVERVIEW>
  !<DESCRIPTION>
  ! This module writes and reads restart files for the FV core. Additionally
  ! it provides setup and calls routines necessary to provide a complete restart
  ! for the model.
  !</DESCRIPTION>

  use constants_mod,       only: kappa, pi, omega, rdgas, grav
  use fv_arrays_mod,       only: fv_atmos_type
  use fv_io_mod,           only: fv_io_init, fv_io_read_restart, fv_io_write_restart, &
                                 remap_restart, fv_io_register_restart
  use fv_grid_tools_mod,   only: area, dx, dy, rdxa, rdya
  use fv_grid_utils_mod,   only: fc, f0, ptop, ptop_min, fill_ghost, big_number,   &
                                 make_eta_level, deglat, cubed_to_latlon
  use fv_diagnostics_mod,  only: prt_maxmin
  use init_hydro_mod,      only: p_var
  use mpp_domains_mod,     only: mpp_update_domains, domain2d, DGRID_NE
  use mpp_mod,             only: mpp_chksum, stdout, mpp_error, FATAL, get_unit
  use test_cases_mod,      only: alpha, init_case, init_double_periodic, init_latlon
  use fv_mp_mod,           only: gid, masterproc
  use fv_surf_map_mod,     only: sgh_g, oro_g
  use fv_diagnostics_mod,  only: steps, efx, efx_sum, mtq, mtq_sum
  use tracer_manager_mod,  only: get_tracer_names
  use field_manager_mod,   only: MODEL_ATMOS
  use external_ic_mod,     only: get_external_ic
  use fv_eta_mod,          only: compute_dz_L32, set_hybrid_z


  implicit none
  private

  public :: fv_restart_init, fv_restart_end, fv_restart, fv_write_restart

  !--- private data type
  logical                       :: module_is_initialized = .FALSE.

  !--- version information variables ----
  character(len=128) :: version = '$Id: fv_restart.F90,v 18.0 2010/03/02 23:27:40 fms Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains 

  !#####################################################################
  ! <SUBROUTINE NAME="fv_restart_init">
  !
  ! <DESCRIPTION>
  ! Initialize the fv core restart facilities
  ! </DESCRIPTION>
  !
  subroutine fv_restart_init()
    call fv_io_init()
    module_is_initialized = .TRUE.
  end subroutine fv_restart_init
  ! </SUBROUTINE> NAME="fv_restart_init"


    !#####################################################################
  ! <SUBROUTINE NAME="fv_restart">
  !
  ! <DESCRIPTION>
  ! The fv core restart facility
  ! </DESCRIPTION>
  !
  subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_type)
    type(domain2d),      intent(inout) :: fv_domain
    type(fv_atmos_type), intent(inout) :: Atm(:)
    real,                intent(in)    :: dt_atmos
    integer,             intent(out)   :: seconds
    integer,             intent(out)   :: days
    logical,             intent(in)    :: cold_start
    integer,             intent(in)    :: grid_type


    integer :: i, j, k, n, ntileMe
    integer :: isc, iec, jsc, jec, npz, npz_rst, ncnst
    integer :: isd, ied, jsd, jed

    integer :: unit
    real, allocatable :: dz1(:)
    real rgrav, f00, ztop
    logical :: hybrid
    character(len=128):: tname

    rgrav = 1. / grav

    if(.not.module_is_initialized) call mpp_error(FATAL, 'You must call fv_restart_init.')

    ntileMe = size(Atm(:))
    npz     = Atm(1)%npz
    npz_rst = Atm(1)%npz_rst

    !--- call fv_io_register_restart to register restart field to be written out in fv_io_write_restart
    call fv_io_register_restart(fv_domain,Atm)

    if( .not.cold_start .and. (.not. Atm(1)%external_ic) ) then
        if ( npz_rst /= 0 .and. npz_rst /= npz ) then
!            Remap vertically the prognostic variables for the chosen vertical resolution
             if( gid==masterproc ) then
                 write(*,*) ' '
                 write(*,*) '***** Important Note from FV core ********************'
                 write(*,*) 'Remapping dynamic IC from', npz_rst, 'levels to ', npz,'levels'
                 write(*,*) '***** End Note from FV core **************************'
                 write(*,*) ' '
             endif
             call remap_restart( fv_domain, Atm )
             if( gid==masterproc ) write(*,*) 'Done remapping dynamical IC'
        else
             call fv_io_read_restart(fv_domain,Atm)
        endif
    endif

!---------------------------------------------------------------------------------------------
! Read, interpolate (latlon to cubed), then remap vertically with terrain adjustment if needed
!---------------------------------------------------------------------------------------------
    if ( Atm(1)%external_ic ) then
         call get_external_ic(Atm, fv_domain) 
         if( gid==masterproc ) write(*,*) 'IC generated from the specified external source'
    endif

    seconds = 0; days = 0   ! Restart needs to be modified to record seconds and days.

! Notes by Jeff D.
  ! This logic doesn't work very well.
  ! Shouldn't have read for all tiles then loop over tiles

    do n = 1, ntileMe

       isd = Atm(n)%isd
       ied = Atm(n)%ied
       jsd = Atm(n)%jsd
       jed = Atm(n)%jed
       ncnst = Atm(n)%ncnst
       isc = Atm(n)%isc; iec = Atm(n)%iec; jsc = Atm(n)%jsc; jec = Atm(n)%jec

      ! Init model data
      if(.not.cold_start)then  ! This is not efficient stacking if there are really more tiles than 1.
        if ( Atm(n)%mountain ) then
             call mpp_update_domains( Atm(n)%phis, fv_domain, complete=.true. )
        else
             Atm(n)%phis = 0.
            if( gid==masterproc ) write(*,*) 'phis set to zero'
        endif

#ifdef SW_DYNAMICS
        Atm(n)%pt(:,:,:)=1.
#else
        if (ptop/=Atm(n)%ak(1)) call mpp_error(FATAL,'FV restart: ptop not equal Atm(n)%ak(1)')
        call p_var(npz,         isc,         iec,       jsc,     jec,   ptop,     ptop_min,  &
                   Atm(n)%delp, Atm(n)%delz, Atm(n)%pt, Atm(n)%ps, Atm(n)%pe, Atm(n)%peln,   &
                   Atm(n)%pk,   Atm(n)%pkz, kappa, Atm(n)%q, Atm(n)%ng, ncnst,  Atm(n)%dry_mass,  &
                   Atm(n)%adjust_dry_mass,  Atm(n)%mountain, Atm(n)%moist_phys,  Atm(n)%hydrostatic, &
                   Atm(n)%k_top, Atm(n)%nwat, Atm(n)%make_nh)
#endif
        if ( grid_type < 7 .and. grid_type /= 4 ) then
! Fill big values in the non-existinng corner regions:
!          call fill_ghost(Atm(n)%phis, Atm(n)%npx, Atm(n)%npy, big_number)
           do j=jsd,jed+1
           do i=isd,ied+1
              fc(i,j) = 2.*omega*( -cos(Atm(n)%grid(i,j,1))*cos(Atm(n)%grid(i,j,2))*sin(alpha) + &
                                    sin(Atm(n)%grid(i,j,2))*cos(alpha) )
           enddo
           enddo
           do j=jsd,jed
           do i=isd,ied
             f0(i,j) = 2.*omega*( -cos(Atm(n)%agrid(i,j,1))*cos(Atm(n)%agrid(i,j,2))*sin(alpha) + &
                                    sin(Atm(n)%agrid(i,j,2))*cos(alpha) )
           enddo
           enddo
        else
           f00 = 2.*omega*sin(deglat/180.*pi)
           do j=jsd,jed+1
              do i=isd,ied+1
                 fc(i,j) = f00
              enddo
           enddo
           do j=jsd,jed
              do i=isd,ied
                 f0(i,j) = f00
              enddo
           enddo
        endif
      else
       if ( Atm(n)%warm_start ) then
         call mpp_error(FATAL, 'FV restart files not found; set warm_start = .F. if cold_start is desired.')
       endif
! Cold start
       if ( Atm(n)%make_hybrid_z ) then
         hybrid = .false.
       else
         hybrid = Atm(n)%hybrid_z
       endif
         if (grid_type < 4) then
            if ( .not. Atm(n)%external_ic ) then
            call init_case(Atm(n)%u,Atm(n)%v,Atm(n)%w,Atm(n)%pt,Atm(n)%delp,Atm(n)%q,Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, &
                           Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va,        & 
                           Atm(n)%ak, Atm(n)%bk, Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ng, ncnst, Atm(n)%nwat,  &
                           Atm(n)%k_top, Atm(n)%ndims, Atm(n)%ntiles, Atm(n)%dry_mass, Atm(n)%mountain,       &
                           Atm(n)%moist_phys, Atm(n)%hydrostatic, hybrid, Atm(n)%delz, Atm(n)%ze0)
            endif
         elseif (grid_type == 4) then
            call init_double_periodic(Atm(n)%u,Atm(n)%v,Atm(n)%w,Atm(n)%pt,Atm(n)%delp,Atm(n)%q,Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, &
                                      Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va,        & 
                                      Atm(n)%ak, Atm(n)%bk, Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ng, ncnst, Atm(n)%nwat,  &
                                      Atm(n)%k_top, Atm(n)%ndims, Atm(n)%ntiles, Atm(n)%dry_mass, Atm(n)%mountain,       &
                                      Atm(n)%moist_phys, Atm(n)%hydrostatic, hybrid, Atm(n)%delz, Atm(n)%ze0)
            if( gid==masterproc ) write(*,*) 'Doubly Periodic IC generated'
         elseif (grid_type == 5 .or. grid_type == 6) then
            call init_latlon(Atm(n)%u,Atm(n)%v,Atm(n)%pt,Atm(n)%delp,Atm(n)%q,Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, &
                             Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va,        &
                             Atm(n)%ak, Atm(n)%bk, Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ng, ncnst, &
                             Atm(n)%k_top, Atm(n)%ndims, Atm(n)%ntiles, Atm(n)%dry_mass, Atm(n)%mountain,       &
                             Atm(n)%moist_phys, hybrid, Atm(n)%delz, Atm(n)%ze0)
         endif

        if ( Atm(n)%fv_land ) then
             do j=jsc,jec
                do i=isc,iec
                   Atm(n)%sgh(i,j) = sgh_g(i,j)
                   Atm(n)%oro(i,j) = oro_g(i,j)
                enddo
             enddo
        endif

        if ( Atm(n)%no_cgrid ) then
             Atm(n)%um(:,:,:) = Atm(n)%u(:,:,:)
             Atm(n)%vm(:,:,:) = Atm(n)%v(:,:,:)
        endif

      endif  !end cold_start check

!---------------------------------------------------------------------------------------------
! Transform the (starting) Eulerian vertical coordinate from sigma-p to hybrid_z
     if ( Atm(n)%hybrid_z ) then
       if ( Atm(n)%make_hybrid_z ) then
          allocate ( dz1(npz) )
          if( npz==32 ) then
              call compute_dz_L32(npz, ztop, dz1)
          else
              call mpp_error(FATAL, 'You must provide a specific routine for hybrid_z')
          endif
          call set_hybrid_z(isc, iec, jsc, jec, Atm(n)%ng, npz, ztop, dz1, rgrav,  &
                            Atm(n)%phis, Atm(n)%ze0)
          deallocate ( dz1 )
!         call prt_maxmin('ZE0', Atm(n)%ze0,  isc, iec, jsc, jec, 0, npz, 1.E-3, gid==masterproc)
!         call prt_maxmin('DZ0', Atm(n)%delz, isc, iec, jsc, jec, 0, npz, 1.   , gid==masterproc)
       endif
       call make_eta_level(npz, Atm(n)%pe, area, Atm(n)%ks, Atm(n)%ak, Atm(n)%bk)
      endif
!---------------------------------------------------------------------------------------------

      unit = stdout()
      write(unit,*)
      write(unit,*) 'fv_restart u    = ', mpp_chksum(Atm(n)%u(isc:iec,jsc:jec,:))
      write(unit,*) 'fv_restart v    = ', mpp_chksum(Atm(n)%v(isc:iec,jsc:jec,:))
      write(unit,*) 'fv_restart delp = ', mpp_chksum(Atm(n)%delp(isc:iec,jsc:jec,:))
      write(unit,*) 'fv_restart phis = ', mpp_chksum(Atm(n)%phis(isc:iec,jsc:jec))

#ifdef SW_DYNAMICS
      call prt_maxmin('H ', Atm(n)%delp, isc, iec, jsc, jec, Atm(n)%ng, 1, rgrav, gid==masterproc)
#else
      write(unit,*) 'fv_restart pt   = ', mpp_chksum(Atm(n)%pt(isc:iec,jsc:jec,:))
      if (ncnst>0) write(unit,*) 'fv_init nq =',ncnst, mpp_chksum(Atm(n)%q(isc:iec,jsc:jec,:,:))
!---------------
! Check Min/Max:
!---------------
      call prt_maxmin('ZS', Atm(n)%phis, isc, iec, jsc, jec, Atm(n)%ng, 1, rgrav, gid==masterproc)
!     call prt_maxmin('ORO',Atm(n)%oro, isc, iec, jsc, jec,          0, 1, 1., gid==masterproc)

      if ( (.not.Atm(n)%hydrostatic) .and. (.not.Atm(n)%make_nh) ) then
            call prt_maxmin('DZ', Atm(n)%delz, isc, iec, jsc, jec, 0, npz, 1., gid==masterproc)
            if ( Atm(n)%hybrid_z ) then
            call prt_maxmin('ZTOP(km)', Atm(n)%ze0, isc, iec, jsc, jec, 0, 1, 1.E-3, gid==masterproc)
            call prt_maxmin('DZ_top', Atm(n)%delz, isc, iec, jsc, jec, 0, 1, 1.E-3, gid==masterproc)
            endif
      endif

      call prt_maxmin('PS', Atm(n)%ps, isc, iec, jsc, jec, Atm(n)%ng, 1,    0.01, gid==masterproc)
      call prt_maxmin('T ', Atm(n)%pt, isc, iec, jsc, jec, Atm(n)%ng, npz, 1., gid==masterproc)

! Check tracers:
      do i=1, ncnst
          call get_tracer_names ( MODEL_ATMOS, i, tname )
          call prt_maxmin(trim(tname), Atm(n)%q(isd:ied,jsd:jed,1:npz,i), isc, iec, jsc, jec, Atm(n)%ng, npz, 1.,gid==masterproc)
      enddo
#endif
      call prt_maxmin('U ', Atm(n)%u(isc:iec,jsc:jec,1:npz), isc, iec, jsc, jec, 0, npz, 1., gid==masterproc)
      call prt_maxmin('V ', Atm(n)%v(isc:iec,jsc:jec,1:npz), isc, iec, jsc, jec, 0, npz, 1., gid==masterproc)
      if ( .not.Atm(n)%hydrostatic )   &
      call prt_maxmin('W ', Atm(n)%w, isc, iec, jsc, jec, Atm(n)%ng, npz, 1.,gid==masterproc)

      if ( (.not.Atm(n)%hydrostatic) .and. Atm(n)%make_nh ) then
         Atm(n)%w = 0.
         if ( .not.Atm(n)%hybrid_z ) then
             do k=1,npz
                do j=jsc,jec
                   do i=isc,iec
                      Atm(n)%delz(i,j,k) = (rdgas*rgrav)*Atm(n)%pt(i,j,k)*(Atm(n)%peln(i,k,j)-Atm(n)%peln(i,k+1,j))
                   enddo
                enddo
             enddo
         endif
      endif

      if (gid==masterproc) write(unit,*)

!--------------------------------------------
! Initialize surface winds for flux coupler:
!--------------------------------------------
    if ( .not. Atm(n)%srf_init ) then
         call cubed_to_latlon(Atm(n)%u, Atm(n)%v, Atm(n)%ua, Atm(n)%va, dx, dy, rdxa, rdya, npz, 1)
         do j=jsc,jec
            do i=isc,iec
               Atm(n)%u_srf(i,j) = Atm(n)%ua(i,j,npz)
               Atm(n)%v_srf(i,j) = Atm(n)%va(i,j,npz)
            enddo
         enddo
         Atm(n)%srf_init = .true.
    endif

    end do   ! n_tile

  end subroutine fv_restart
  ! </SUBROUTINE> NAME="fv_restart"



  !#######################################################################
  ! <SUBROUTINE NAME="fv_write_restart">
  ! <DESCRIPTION>
  !  Write out restart files registered through register_restart_file
  ! </DESCRIPTION>
  subroutine fv_write_restart(Atm, timestamp)
    type(fv_atmos_type), intent(inout) :: Atm(:)
    character(len=*),    intent(in)    :: timestamp

    call fv_io_write_restart(Atm, timestamp)

  end subroutine fv_write_restart
  ! </SUBROUTINE>



  !#####################################################################
  ! <SUBROUTINE NAME="fv_restart_end">
  !
  ! <DESCRIPTION>
  ! Initialize the fv core restart facilities
  ! </DESCRIPTION>
  !
  subroutine fv_restart_end(Atm)
    type(fv_atmos_type), intent(in) :: Atm(:)

    integer :: isc, iec, jsc, jec
    integer :: iq, n, ntileMe
    integer :: isd, ied, jsd, jed, npz
    integer :: unit
    integer :: file_unit

    ntileMe = size(Atm(:))

    do n = 1, ntileMe
      isc = Atm(n)%isc; iec = Atm(n)%iec; jsc = Atm(n)%jsc; jec = Atm(n)%jec

      isd = Atm(n)%isd
      ied = Atm(n)%ied
      jsd = Atm(n)%jsd
      jed = Atm(n)%jed
      npz = Atm(n)%npz
 
      unit = stdout()
      write(unit,*)
      write(unit,*) 'fv_restart_end u    = ', mpp_chksum(Atm(n)%u(isc:iec,jsc:jec,:))
      write(unit,*) 'fv_restart_end v    = ', mpp_chksum(Atm(n)%v(isc:iec,jsc:jec,:))
      if ( .not. Atm(n)%hydrostatic )    &
         write(unit,*) 'fv_restart_end w    = ', mpp_chksum(Atm(n)%w(isc:iec,jsc:jec,:))
      write(unit,*) 'fv_restart_end delp = ', mpp_chksum(Atm(n)%delp(isc:iec,jsc:jec,:))
      write(unit,*) 'fv_restart_end phis = ', mpp_chksum(Atm(n)%phis(isc:iec,jsc:jec))
#ifndef SW_DYNAMICS
      write(unit,*) 'fv_restart_end pt   = ', mpp_chksum(Atm(n)%pt(isc:iec,jsc:jec,:))
      do iq=1,min(7, Atm(n)%ncnst)     ! Check up to 7 tracers
        write(unit,*) 'fv_restart_end q    = ', mpp_chksum(Atm(n)%q(isc:iec,jsc:jec,:,iq))
      enddo

!---------------
! Check Min/Max:
!---------------
      call prt_maxmin('ZS', Atm(n)%phis, isc, iec, jsc, jec, Atm(n)%ng, 1, 1./grav, gid==masterproc)
      call prt_maxmin('PS', Atm(n)%ps, isc, iec, jsc, jec, Atm(n)%ng, 1, 0.01, gid==masterproc)
      call prt_maxmin('U ', Atm(n)%u(isd:ied,jsd:jed,1:npz), isc, iec, jsc, jec, Atm(n)%ng, npz, 1., gid==masterproc)
      call prt_maxmin('V ', Atm(n)%v(isd:ied,jsd:jed,1:npz), isc, iec, jsc, jec, Atm(n)%ng, npz, 1., gid==masterproc)
      if ( .not. Atm(n)%hydrostatic )    &
      call prt_maxmin('W ', Atm(n)%w , isc, iec, jsc, jec, Atm(n)%ng, npz, 1., gid==masterproc)
      call prt_maxmin('T ', Atm(n)%pt, isc, iec, jsc, jec, Atm(n)%ng, npz, 1., gid==masterproc)
! Write4 energy correction term
#endif
    end do

    call fv_io_write_restart(Atm)
    module_is_initialized = .FALSE.

#ifdef EFLUX_OUT
    if( gid==masterproc ) then
        write(*,*) steps, 'Mean equivalent Heat flux for this integration period=',efx_sum/real(max(1,steps)), &
                          'Mean mountain torque=',mtq_sum/real(max(1,steps))
        file_unit = get_unit()
        open (unit=file_unit, file='e_flux.data', form='unformatted',status='unknown', access='sequential')
        do n=1,steps
           write(file_unit) efx(n)
           write(file_unit) mtq(n)    ! time series global mountain torque
        enddo
        close(unit=file_unit)
    endif
#endif

  end subroutine fv_restart_end
  ! </SUBROUTINE> NAME="fv_restart_end"

end module fv_restart_mod


 module fv_surf_map_mod

      use fms_mod,           only: file_exist, check_nml_error,            &
                                   open_namelist_file, close_file, stdlog, &
                                   mpp_pe, mpp_root_pe, FATAL, error_mesg
      use mpp_mod,           only: get_unit, input_nml_file
      use mpp_domains_mod,   only: mpp_update_domains
      use constants_mod,     only: grav
#ifdef MARS_GCM
      use fms_mod,           only: read_data
      use fms_io_mod,        only: field_size
#endif

      use fv_grid_utils_mod, only: great_circle_dist, latlon2xyz, v_prod,  &
                                   sina_u, sina_v, g_sum, global_mx 
      use fv_mp_mod,         only: domain, ng, is,js,ie,je, isd,jsd,ied,jed, &
                                   gid, mp_stop, mp_reduce_min, mp_reduce_max
      use fv_timing_mod,     only: timing_on, timing_off

      implicit none

      real pi
      private
      real, allocatable:: sgh_g(:,:), oro_g(:,:), zs_g(:,:)
!-----------------------------------------------------------------------
! NAMELIST
!    Name, resolution, and format of XXmin USGS datafile
!      1min
!         nlon = 10800 * 2
!         nlat =  5400 * 2
!      2min
!         nlon = 10800
!         nlat =  5400
!      5min
!         nlon = 4320
!         nlat = 2160
!    surf_format:      netcdf (default)
!                      binary
      integer           ::  nlon = 10800
      integer           ::  nlat =  5400
#ifdef MARS_GCM
      character(len=128)::  surf_file = "INPUT/mars_topo.nc"
      character(len=6)  ::  surf_format = 'netcdf'
      character(len=80) :: field_name 
      integer           :: fld_dims(4)
      real, allocatable :: rtopo(:,:)
#else
      character(len=128)::  surf_file = "INPUT/topo5min.nc"
      character(len=6)  ::  surf_format = 'netcdf'
#endif
      namelist /surf_map_nml/ surf_file,surf_format,nlon,nlat
!
      public  sgh_g, oro_g, zs_g
      public  surfdrv, map_to_cubed_simple

      contains

      subroutine surfdrv(npx, npy, grid, agrid,   &
                         area, dx, dy, dxc, dyc, phis, master) 

      implicit         none
#include <netcdf.inc>
      integer, intent(in):: npx, npy
      logical master

    ! INPUT arrays
      real, intent(in)::area(is-ng:ie+ng, js-ng:je+ng)
      real, intent(in):: dx(is-ng:ie+ng, js-ng:je+ng+1)
      real, intent(in):: dy(is-ng:ie+ng+1, js-ng:je+ng)
      real, intent(in)::dxc(is-ng:ie+ng+1, js-ng:je+ng)
      real, intent(in)::dyc(is-ng:ie+ng, js-ng:je+ng+1)

      real, intent(in):: grid(is-ng:ie+ng+1, js-ng:je+ng+1,2)
      real, intent(in):: agrid(is-ng:ie+ng, js-ng:je+ng,2)

    ! OUTPUT arrays
      real, intent(out):: phis(is-ng:ie+ng, js-ng:je+ng)
! Local:
      real :: z2(is:ie, js:je)
! Position of edges of the box containing the original data point:

      integer          londim
      integer          latdim

      real dx1, dx2, dy1, dy2

      character(len=80) :: topoflnm
      real(kind=4) :: fmin, fmax
      real(kind=4), allocatable :: ftopo(:,:), htopo(:,:)
      real, allocatable :: lon1(:),  lat1(:)
      integer i, j, n
      integer ncid, lonid, latid, ftopoid, htopoid
      integer status
      logical check_orig
      real da_min, da_max, cd2, cd4, zmean, z2mean
      integer fid

! Output the original 10 min NAVY data in grads readable format
      data             check_orig /.false./

      allocate ( oro_g(isd:ied, jsd:jed) )
      allocate ( sgh_g(isd:ied, jsd:jed) )
      allocate (  zs_g(is:ie, js:je) )


      call read_namelist

#ifdef MARS_GCM
      if (surf_format == "binary")  &
          call error_mesg ( 'surfdrv', ' binary input not allowed for Mars Model', FATAL )

      if (file_exist(surf_file)) then
         field_name = 'topo'
 
!         call field_size( trim(surf_file), 'lat', fld_dims )
!         call field_size( trim(surf_file), 'lon', fld_dims )
         call field_size( trim(surf_file), trim(field_name), fld_dims )

         nlon= fld_dims(1);  nlat= fld_dims(2);

         if(master) write(*,*) 'Mars Terrain dataset dims=', nlon, nlat

         allocate ( htopo(nlon,nlat) )
         allocate ( rtopo(nlon,nlat) )
         allocate ( ftopo(nlon,nlat) )

         call read_data( trim(surf_file), trim(field_name), rtopo, no_domain=.true. )

!   This is needed because htopo is declared as real*4
         htopo= rtopo
         ftopo = 1.0              ! all land points

         if ( master ) then
            write(6,*) 'Check Hi-res Mars data ..'
            fmax =  vmax(htopo,fmin,nlon,nlat,1)
            write(6,*) 'hmax=', fmax
            write(6,*) 'hmin=', fmin
         endif
      else
         call error_mesg ( 'surfdrv', 'mars_topo not found in INPUT', FATAL )
      endif
#else

      if (file_exist(surf_file)) then
!
! surface file in NetCDF format
!
        if (surf_format == "netcdf") then

          allocate ( ftopo(nlon,nlat) )
          allocate ( htopo(nlon,nlat) )

          if ( master ) write(*,*) 'Opening USGS datset file:', surf_file, surf_format, nlon, nlat
  
          status = nf_open (surf_file, NF_NOWRITE, ncid)
          if (status .ne. NF_NOERR) call handle_err(status)
  
          status = nf_inq_dimid (ncid, 'lon', lonid)
          if (status .ne. NF_NOERR) call handle_err(status)
          status = nf_inq_dimlen (ncid, lonid, londim)
          if (status .ne. NF_NOERR) call handle_err(status)

          status = nf_inq_dimid (ncid, 'lat', latid)
          if (status .ne. NF_NOERR) call handle_err(status)
          status = nf_inq_dimlen (ncid, latid, latdim)
          if (status .ne. NF_NOERR) call handle_err(status)

          status = nf_inq_varid (ncid, 'ftopo', ftopoid)
          if (status .ne. NF_NOERR) call handle_err(status)
          status = nf_get_var_real (ncid, ftopoid, ftopo)
          if (status .ne. NF_NOERR) call handle_err(status)

          status = nf_inq_varid (ncid, 'htopo', htopoid)
          if (status .ne. NF_NOERR) call handle_err(status)
          status = nf_get_var_real (ncid, htopoid, htopo)
          if (status .ne. NF_NOERR) call handle_err(status)

          status = nf_close (ncid)
          if (status .ne. NF_NOERR) call handle_err(status)
!
! ... Set check_orig=.true. to output original 10-minute
!         real(kind=4) ::  data (GrADS format)
!
          if (check_orig) then
            topoflnm = 'topo.bin'
            fid = get_unit()
            open (unit=fid, file=topoflnm, form='unformatted', &
                status='unknown', access='direct', recl=nlon*nlat*4)
            write (fid, rec=1) ftopo
            write (fid, rec=2) htopo
            close (unit=fid)
          endif
  
!
! surface file in binary format
!
        elseif (surf_format == "binary") then 
!        nlon = 10800
!        nlat =  5400
!        surf_file    = '/work/sjl/topo/topo2min.bin'
  
          if ( master ) write(*,*) 'Opening USGS datset file:', surf_file, surf_format, nlon, nlat

          fid = get_unit()
          open (unit=fid, file=surf_file, form='unformatted', &
                    status='unknown', access='direct', recl=nlon*nlat*4)

          allocate ( ftopo(nlon,nlat) )
          allocate ( htopo(nlon,nlat) )
          read (fid, rec=1) ftopo
          read (fid, rec=2) htopo
          close (unit=fid)
        endif

      else
        if(master) write(*,*) 'USGS dataset = ', surf_file, surf_format
        call error_mesg ( 'surfdrv',  &
            'missing input file', FATAL )
      endif
#endif MARS_GCM

      allocate ( lat1(nlat+1) )
      allocate ( lon1(nlon+1) )

      pi = 4.0 * datan(1.0d0)

      dx1 = 2.*pi/real(nlon)
      dy1 = pi/real(nlat)

      do i=1,nlon+1
         lon1(i) = dx1 * real(i-1)    ! between 0 2pi
      enddo

         lat1(1) = - 0.5*pi
         lat1(nlat+1) =  0.5*pi
      do j=2,nlat
         lat1(j) = -0.5*pi + dy1*(j-1)
      enddo

      if ( master ) then
           write(6,*) 'check original data ..'
           fmax =  vmax(htopo,fmin,nlon,nlat,1)
           write(6,*) 'hmax=', fmax
           write(6,*) 'hmin=', fmin
      endif

!-------------------------------------
! Compute raw phis and oro
!-------------------------------------

                                                      call timing_on('map_to_cubed')
      call map_to_cubed_raw(nlon, nlat, lat1, lon1, htopo, ftopo, grid, agrid,  &
                            phis, oro_g, sgh_g, master, npx, npy)

      if(master) write(*,*) 'map_to_cubed_raw: done'
!     write(*,*) gid, 'map_to_cubed_raw: done'
                                                      call timing_off('map_to_cubed')
      deallocate ( htopo )
      deallocate ( ftopo )
      deallocate ( lon1 )
      deallocate ( lat1 )

#ifndef MARS_GCM
      call remove_ice_sheets (agrid(isd,jsd,1), agrid(isd,jsd,2), oro_g )
#endif

      call global_mx(oro_g, ng, da_min, da_max)
      if ( master ) write(*,*) 'ORO min=', da_min, ' Max=', da_max

      do j=js,je
         do i=is,ie
            zs_g(i,j) = phis(i,j)
            z2(i,j) = phis(i,j)**2
         end do
      end do
!--------
! Filter:
!--------
      call global_mx(phis, ng, da_min, da_max)
      zmean = g_sum(zs_g, is, ie, js, je, ng, area, 1)
      z2mean = g_sum(z2 , is, ie, js, je, ng, area, 1)

      if ( master ) then
           write(*,*) 'Before filter ZS min=', da_min, ' Max=', da_max,' Mean=',zmean
           write(*,*) '*** Mean variance *** =', z2mean
      endif

      call global_mx(area, ng, da_min, da_max)

                                                    call timing_on('Terrain_filter')
! Del-2:
      cd2 = 0.20*da_min
      if ( npx>=721 ) then
           if ( npx<=1001 ) then
                call del2_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 1, cd2)
           else
                call del2_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 2, cd2)
           endif
      endif

! MFCT Del-4:
      if ( npx<=91 ) then
         cd4 = 0.20 * da_min
         call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 1, cd4)
      elseif( npx<=181 ) then
         cd4 = 0.20 * da_min
         call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 2, cd4)
      elseif( npx<=361 ) then
         cd4 = 0.20 * da_min
         call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 4, cd4)
      elseif( npx<=721 ) then
         cd4 = 0.20 * da_min
         call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 6, cd4)
      else
         cd4 = 0.20 * da_min
         call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, 8, cd4)
      endif

      do j=js,je
         do i=is,ie
            z2(i,j) = phis(i,j)**2
         end do
      end do

      call global_mx(phis, ng, da_min, da_max)
      zmean  = g_sum(phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
      z2mean = g_sum(z2,                is, ie, js, je, ng, area, 1)

      if ( master ) then
           write(*,*) 'After filter Phis min=', da_min, ' Max=', da_max, 'Mean=', zmean
           write(*,*) '*** Mean variance *** =', z2mean
      endif

      do j=js,je
         do i=is,ie
            phis(i,j) =  grav * phis(i,j)
            if ( sgh_g(i,j) <= 0. ) then
                 sgh_g(i,j) = 0.
            else
                 sgh_g(i,j) = sqrt(sgh_g(i,j))
            endif
#ifdef SET_FLAG
            if ( oro_g(i,j) > .5 ) then
                oro_g(i,j) = 1.
            else
                oro_g(i,j) = 0.
            endif
#endif
         end do
      end do

      call global_mx(sgh_g, ng, da_min, da_max)
      if ( master ) write(*,*) 'Before filter SGH min=', da_min, ' Max=', da_max


!-----------------------------------------------
! Filter the standard deviation of mean terrain:
!-----------------------------------------------
      call global_mx(area, ng, da_min, da_max)
      call del4_cubed_sphere(npx, npy, sgh_g, area, dx, dy, dxc, dyc, 1, cd4)
      call global_mx(sgh_g, ng, da_min, da_max)
      if ( master ) write(*,*) 'After filter SGH min=', da_min, ' Max=', da_max
      do j=js,je
         do i=is,ie
            sgh_g(i,j) = max(0., sgh_g(i,j))
         enddo
      enddo
                                                    call timing_off('Terrain_filter')


 end subroutine surfdrv



 subroutine del2_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, nmax, cd)
      integer, intent(in):: npx, npy
      integer, intent(in):: nmax
      real, intent(in):: cd
    ! INPUT arrays
      real, intent(in)::area(isd:ied,  jsd:jed)
      real, intent(in)::  dx(isd:ied,  jsd:jed+1)
      real, intent(in)::  dy(isd:ied+1,jsd:jed)
      real, intent(in):: dxc(isd:ied+1,jsd:jed)
      real, intent(in):: dyc(isd:ied,  jsd:jed+1)
    ! OUTPUT arrays
      real, intent(inout):: q(is-ng:ie+ng, js-ng:je+ng)
! Local:
      real ddx(is:ie+1,js:je), ddy(is:ie,js:je+1)
      integer i,j,n

      call mpp_update_domains(q,domain,whalo=ng,ehalo=ng,shalo=ng,nhalo=ng)

! First step: average the corners:
      if ( is==1 .and. js==1 ) then
           q(1,1) = (q(1,1)+q(0,1)+q(1,0)) / 3.
           q(0,1) =  q(1,1)
           q(1,0) =  q(1,1)
      endif
      if ( (ie+1)==npx .and. js==1 ) then
           q(ie, 1) = (q(ie,1)+q(npx,1)+q(ie,0)) / 3.
           q(npx,1) =  q(ie,1)
           q(ie, 0) =  q(ie,1)
      endif
      if ( (ie+1)==npx .and. (je+1)==npy ) then
           q(ie, je) = (q(ie,je)+q(npx,je)+q(ie,npy)) / 3.
           q(npx,je) =  q(ie,je)
           q(ie,npy) =  q(ie,je)
      endif
      if ( is==1 .and. (je+1)==npy ) then
           q(1, je) = (q(1,je)+q(0,je)+q(1,npy)) / 3.
           q(0, je) =  q(1,je)
           q(1,npy) =  q(1,je)
      endif


      do n=1,nmax

         if( n>1 ) call mpp_update_domains(q,domain,whalo=ng,ehalo=ng,shalo=ng,nhalo=ng)

         do j=js,je
            do i=is,ie+1
               ddx(i,j) = dy(i,j)*sina_u(i,j)*(q(i-1,j)-q(i,j))/dxc(i,j)
            enddo
         enddo

         do j=js,je+1
            do i=is,ie
               ddy(i,j) = dx(i,j)*sina_v(i,j)*(q(i,j-1)-q(i,j))/dyc(i,j)
            enddo
         enddo

         do j=js,je
            do i=is,ie
               q(i,j) = q(i,j) + cd/area(i,j)*(ddx(i,j)-ddx(i+1,j)+ddy(i,j)-ddy(i,j+1))
            enddo
         enddo
       
      enddo

 end subroutine del2_cubed_sphere


 subroutine del4_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, nmax, cd)
      real, parameter:: esl = 1.E-20
      integer, intent(in):: npx, npy, nmax
      real, intent(in)::area(isd:ied,  jsd:jed)
      real, intent(in)::  dx(isd:ied,  jsd:jed+1)
      real, intent(in)::  dy(isd:ied+1,jsd:jed)
      real, intent(in):: dxc(isd:ied+1,jsd:jed)
      real, intent(in):: dyc(isd:ied,  jsd:jed+1)
      real, intent(in):: cd
      real, intent(inout):: q(is-ng:ie+ng, js-ng:je+ng)
! diffusive fluxes: 
      real :: fx2(is:ie+1,js:je), fy2(is:ie,js:je+1)
      real :: fx4(is:ie+1,js:je), fy4(is:ie,js:je+1)
      real   d2(isd:ied,jsd:jed)
      real  win(isd:ied,jsd:jed)
      real  wou(isd:ied,jsd:jed)

      real qlow(is:ie,js:je)
      real qmin(is:ie,js:je)
      real qmax(is:ie,js:je)
      integer i,j, n

  do n=1,nmax
      call mpp_update_domains(q,domain)

! First step: average the corners:
      if ( is==1 .and. js==1 ) then
           q(1,1) = (q(1,1)+q(0,1)+q(1,0)) / 3.
           q(0,1) =  q(1,1)
           q(1,0) =  q(1,1)
      endif
      if ( (ie+1)==npx .and. js==1 ) then
           q(ie, 1) = (q(ie,1)+q(npx,1)+q(ie,0)) / 3.
           q(npx,1) =  q(ie,1)
           q(ie, 0) =  q(ie,1)
      endif
      if ( (ie+1)==npx .and. (je+1)==npy ) then
           q(ie, je) = (q(ie,je)+q(npx,je)+q(ie,npy)) / 3.
           q(npx,je) =  q(ie,je)
           q(ie,npy) =  q(ie,je)
      endif
      if ( is==1 .and. (je+1)==npy ) then
           q(1, je) = (q(1,je)+q(0,je)+q(1,npy)) / 3.
           q(0, je) =  q(1,je)
           q(1,npy) =  q(1,je)
      endif

     do j=js,je
        do i=is,ie
           qmin(i,j) = min(q(i,j-1), q(i-1,j), q(i,j), q(i+1,j), q(i,j+1))
           qmax(i,j) = max(q(i,j-1), q(i-1,j), q(i,j), q(i+1,j), q(i,j+1))
        enddo
     enddo

!--------------
! Compute del-2
!--------------
!     call copy_corners(q, npx, npy, 1)
      do j=js,je
         do i=is,ie+1
            fx2(i,j) = cd*dy(i,j)*sina_u(i,j)*(q(i-1,j)-q(i,j))/dxc(i,j)
         enddo
      enddo

!     call copy_corners(q, npx, npy, 2)
      do j=js,je+1
         do i=is,ie
            fy2(i,j) = cd*dx(i,j)*sina_v(i,j)*(q(i,j-1)-q(i,j))/dyc(i,j)
         enddo
      enddo

      do j=js,je
         do i=is,ie
            d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1)) / area(i,j)
! Low order monotonic solution
            qlow(i,j) = q(i,j) + d2(i,j)
            d2(i,j) = cd * d2(i,j)
         enddo
      enddo

      call mpp_update_domains(d2,domain)

!---------------------
! Compute del4 fluxes:
!---------------------
!     call copy_corners(d2, npx, npy, 1)
      do j=js,je
         do i=is,ie+1
            fx4(i,j) = dy(i,j)*sina_u(i,j)*(d2(i,j)-d2(i-1,j))/dxc(i,j)-fx2(i,j)
         enddo
      enddo

!     call copy_corners(d2, npx, npy, 2)
      do j=js,je+1
         do i=is,ie
            fy4(i,j) = dx(i,j)*sina_v(i,j)*(d2(i,j)-d2(i,j-1))/dyc(i,j)-fy2(i,j)
         enddo
      enddo

!----------------
! Flux limitting:
!----------------
#ifndef NO_MFCT_FILTER
      do j=js,je
         do i=is,ie
            win(i,j) = max(0.,fx4(i,  j)) - min(0.,fx4(i+1,j)) +   &
                       max(0.,fy4(i,  j)) - min(0.,fy4(i,j+1)) + esl
            wou(i,j) = max(0.,fx4(i+1,j)) - min(0.,fx4(i,  j)) +   &
                       max(0.,fy4(i,j+1)) - min(0.,fy4(i,  j)) + esl
            win(i,j) = max(0., qmax(i,j) - qlow(i,j)) / win(i,j)*area(i,j)
            wou(i,j) = max(0., qlow(i,j) - qmin(i,j)) / wou(i,j)*area(i,j)
         enddo
      enddo

      call mpp_update_domains(win,domain, complete=.false.)
      call mpp_update_domains(wou,domain, complete=.true.)

      do j=js,je
         do i=is,ie+1
            if ( fx4(i,j) > 0. ) then
                 fx4(i,j) = min(1., wou(i-1,j), win(i,j)) * fx4(i,j) 
            else
                 fx4(i,j) = min(1., win(i-1,j), wou(i,j)) * fx4(i,j) 
            endif
         enddo
      enddo
      do j=js,je+1
         do i=is,ie
            if ( fy4(i,j) > 0. ) then
                 fy4(i,j) = min(1., wou(i,j-1), win(i,j)) * fy4(i,j) 
            else
                 fy4(i,j) = min(1., win(i,j-1), wou(i,j)) * fy4(i,j) 
            endif
         enddo
      enddo
#endif

! Update:
      do j=js,je
         do i=is,ie
            q(i,j) = qlow(i,j) + (fx4(i,j)-fx4(i+1,j)+fy4(i,j)-fy4(i,j+1))/area(i,j)
         enddo
      enddo

  enddo    ! end n-loop

 end subroutine del4_cubed_sphere




 subroutine map_to_cubed_raw(im, jm, lat1, lon1, q1, f1,  grid, agrid,  &
                                  q2, f2, h2, master, npx, npy)

! Input
      integer, intent(in):: im, jm        ! original dimensions
      integer, intent(in):: npx, npy
      real, intent(in):: lat1(jm+1)       ! original southern edge of the cell [-pi/2:pi/2]
      real, intent(in):: lon1(im+1)       ! original western edge of the cell [0:2*pi]
      real(kind=4), intent(in):: q1(im,jm)      ! original data at center of the cell
      real(kind=4), intent(in):: f1(im,jm)      !

      real, intent(in)::  grid(isd:ied+1, jsd:jed+1,2)
      real, intent(in):: agrid(isd:ied,   jsd:jed,  2)
      logical, intent(in):: master
! Output
      real, intent(out):: q2(isd:ied,jsd:jed) ! Mapped data at the target resolution
      real, intent(out):: f2(isd:ied,jsd:jed) ! oro
      real, intent(out):: h2(isd:ied,jsd:jed) ! variances of terrain

! Local
      real(kind=4), allocatable:: qt(:,:), ft(:,:), lon_g(:)
      real lat_g(jm)
      real pc(3), p2(2), pp(3), grid3(3, is:ie+1, js:je+1)
      integer i,j, np
      integer igh
      integer ii, jj, i1, i2, j1, j2
      integer ifirst, ilast
      real qsum, fsum, hsum, lon_w, lon_e, lat_s, lat_n, r2d
      real delg, dlat
!     integer, parameter:: lat_crit = 15             ! 15 * (1/30) = 0.5 deg
      integer:: lat_crit
      integer, parameter:: ig = 2
      real q1_np, q1_sp, f1_np, f1_sp, h1_sp, h1_np, pi5, deg0
      logical inside

      pi5 = 0.5 * pi
      r2d = 180./pi

!     lat_crit = jm / min(360, 4*(npx-1))    ! 0.5  (deg) or larger
      lat_crit = jm / min(720, 8*(npx-1))    ! 0.25 (deg) or larger

      dlat = 180./real(jm)

      igh = im/4 + 1

      if (master) write(*,*) 'Terrain dataset im=', im, 'jm=', jm
      if (master) write(*,*) 'igh (terrain ghosting)=', igh

      allocate (    qt(-igh:im+igh,jm) )
      allocate (    ft(-igh:im+igh,jm) )
      allocate ( lon_g(-igh:im+igh   ) )

! Ghost the input coordinates:
      do i=1,im
         lon_g(i) = 0.5*(lon1(i)+lon1(i+1))
      enddo

      do i=-igh,0
         lon_g(i) = lon_g(i+im)
      enddo
      do i=im+1,im+igh
         lon_g(i) = lon_g(i-im)
      enddo

      do j=1,jm
         lat_g(j) = 0.5*(lat1(j)+lat1(j+1))
      enddo

!     if ( 2*(im/2) /= im ) then
!          write(*,*) 'Warning: Terrain datset must have an even nlon dimension'
!     endif

! Ghost Data
      do j=1,jm
         do i=1,im
            qt(i,j) = q1(i,j)
            ft(i,j) = f1(i,j)
         enddo
         do i=-igh,0
            qt(i,j) = qt(i+im,j)
            ft(i,j) = ft(i+im,j)
         enddo
         do i=im+1,im+igh
            qt(i,j) = qt(i-im,j)
            ft(i,j) = ft(i-im,j)
         enddo
      enddo

      do j=js,je+1
         do i=is,ie+1
            call latlon2xyz(grid(i,j,1:2), grid3(1,i,j))
         enddo
      enddo

! Compute values very close to the poles:
!----
! SP:
!----
     qsum = 0.
     fsum = 0.
     hsum = 0.
     np   = 0
     do j=1,lat_crit
        do i=1,im
           np = np + 1
           qsum = qsum + q1(i,j)
           fsum = fsum + f1(i,j)
        enddo
     enddo
     q1_sp = qsum / real(np)
     f1_sp = fsum / real(np)

     hsum = 0.
     do j=1,lat_crit
        do i=1,im
           hsum = hsum + (q1_sp-q1(i,j))**2
        enddo
     enddo
     h1_sp = hsum / real(np)

     if(master) write(*,*) 'SP:', q1_sp, f1_sp, sqrt(h1_sp)
!----
! NP:
!----
     qsum = 0.
     fsum = 0.
     hsum = 0.
     np   = 0
     do j=jm-lat_crit+1,jm
        do i=1,im
           np = np + 1
           qsum = qsum + q1(i,j)
           fsum = fsum + f1(i,j)
        enddo
     enddo
     q1_np = qsum / real(np)
     f1_np = fsum / real(np)

     hsum = 0.
     do j=jm-lat_crit+1,jm
        do i=1,im
           hsum = hsum + (q1_np-q1(i,j))**2
        enddo
     enddo
     h1_np = hsum / real(np)

     if(master) write(*,*) 'NP:', q1_np, f1_np, sqrt(h1_np)
     if(master) write(*,*) 'surf_map: Search started ....'

      do 4444 j=js,je
         do 4444 i=is,ie
 
            lat_s = min( grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2) )
            lat_n = max( grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2) )

            if ( r2d*lat_n < (lat_crit*dlat - 90.) ) then
                 q2(i,j) = q1_sp
                 f2(i,j) = f1_sp
                 h2(i,j) = h1_sp
                 go to 4444
            elseif ( r2d*lat_s > (90. - lat_crit*dlat) ) then
                 q2(i,j) = q1_np
                 f2(i,j) = f1_np
                 h2(i,j) = h1_np
                 go to 4444
            endif

            j1 = nint( (pi5+lat_s)/(pi/real(jm)) ) - ig
            j2 = nint( (pi5+lat_n)/(pi/real(jm)) ) + ig
            j1 = max(1,  j1)
            j2 = min(jm, j2)

            lon_w = min( grid(i,j,1), grid(i+1,j,1), grid(i,j+1,1), grid(i+1,j+1,1) ) 
            lon_e = max( grid(i,j,1), grid(i+1,j,1), grid(i,j+1,1), grid(i+1,j+1,1) )
            if ( (lon_e - lon_w) > pi ) then
                 i1 = nint( (lon_e-2.*pi)/(2.*pi/real(im)) )
                 i2 = nint(  lon_w       /(2.*pi/real(im)) )
            else
                 i1 = nint( lon_w / (2.*pi/real(im)) )
                 i2 = nint( lon_e / (2.*pi/real(im)) )
            endif

            i1 = max(  -igh, i1 - ig)
            i2 = min(im+igh, i2 + ig)

              np = 0
            qsum = 0.
            fsum = 0.
            hsum = 0.
            do jj=j1,j2
               p2(2) = lat_g(jj)
               do ii=i1,i2
                  p2(1) = lon_g(ii)
                  call latlon2xyz(p2, pp)
                  inside=inside_p4(grid3(1,i,j), grid3(1,i+1,j), grid3(1,i+1,j+1), grid3(1,i,j+1), pp)
                  if ( inside ) then
                      np = np + 1
                      qsum = qsum + qt(ii,jj)
                      fsum = fsum + ft(ii,jj)
                      hsum = hsum + qt(ii,jj)**2
                  endif
               enddo
            enddo

            if ( np > 0 ) then
                 q2(i,j) = qsum / real(np)
                 f2(i,j) = fsum / real(np)
                 h2(i,j) = hsum / real(np) - q2(i,j)**2
            else
                 write(*,*) 'Surf_map failed for GID=', gid, '(lon,lat)=', agrid(i,j,1)*r2d,agrid(i,j,2)*r2d
                 stop
!                call mp_stop   ! does not really stop !!!
            endif

4444  continue

      deallocate (   qt )
      deallocate (   ft )
      deallocate (lon_g )

 end subroutine map_to_cubed_raw



 logical function inside_p4(p1, p2, p3, p4, pp)
!
!            4----------3
!           /          /
!          /    pp    /
!         /          /
!        1----------2
!
! A * B = |A| |B| cos(angle)

      real, intent(in):: p1(3), p2(3), p3(3), p4(3)
      real, intent(in):: pp(3)
! Local:
      real v1(3), v2(3), vp(3)
      real a1, a2, aa, s1, s2, ss
      integer k

! S-W:
      do k=1,3
         v1(k) = p2(k) - p1(k) 
         v2(k) = p4(k) - p1(k) 
         vp(k) = pp(k) - p1(k) 
      enddo
      s1 = sqrt( v1(1)**2 + v1(2)**2 + v1(3)**2 )
      s2 = sqrt( v2(1)**2 + v2(2)**2 + v2(3)**2 )
      ss = sqrt( vp(1)**2 + vp(2)**2 + vp(3)**2 )

! Compute cos(angle):
      aa = v_prod(v1, v2) / (s1*s2)
      a1 = v_prod(v1, vp) / (s1*ss)
      a2 = v_prod(v2, vp) / (s2*ss)

      if ( a1<aa  .or.  a2<aa ) then
           inside_p4 = .false.
           return
      endif

! N-E:
      do k=1,3
         v1(k) = p2(k) - p3(k) 
         v2(k) = p4(k) - p3(k) 
         vp(k) = pp(k) - p3(k) 
      enddo
      s1 = sqrt( v1(1)**2 + v1(2)**2 + v1(3)**2 )
      s2 = sqrt( v2(1)**2 + v2(2)**2 + v2(3)**2 )
      ss = sqrt( vp(1)**2 + vp(2)**2 + vp(3)**2 )

! Compute cos(angle):
      aa = v_prod(v1, v2) / (s1*s2)
      a1 = v_prod(v1, vp) / (s1*ss)
      a2 = v_prod(v2, vp) / (s2*ss)

      if ( a1<aa  .or.  a2<aa ) then
           inside_p4 = .false.
      else
           inside_p4 = .true.
      endif

 end function inside_p4



 subroutine handle_err(status)
#include <netcdf.inc>
      integer          status

      if (status .ne. nf_noerr) then
        print *, nf_strerror(status)
        stop 'Stopped'
      endif

 end subroutine  handle_err


 real function vmax(a,pmin,m,n,z)
      integer m,n,z, i,j,k
      real(kind=4) :: pmin, pmax
      real(kind=4) :: a(m,n,z)

      pmax = a(1,1,1)
      pmin = a(1,1,1)

      do k=1,z
      do j=1,n
      do i=1,m
         pmax = max(pmax,a(i,j,k))
         pmin = min(pmin,a(i,j,k))
      enddo
      enddo
      enddo   

      vmax = pmax
 end function vmax

         
 subroutine remove_ice_sheets (lon, lat, lfrac )
!---------------------------------
! Bruce Wyman's fix for Antarctic
!--------------------------------- 
      real, intent(in)    :: lon(isd:ied,jsd:jed), lat(isd:ied,jsd:jed)
      real, intent(inout) :: lfrac(isd:ied,jsd:jed)
        
! lon   = longitude in radians
! lat   = latitude in radians
! lfrac = land-sea mask (land=1, sea=0)
            
      integer :: i, j
      real :: dtr, phs, phn
            
      dtr = acos(0.)/90.
      phs = -83.9999*dtr                                  
!     phn = -78.9999*dtr
      phn = -76.4*dtr
            
      do j = js, je
         do i = is, ie
         if ( lat(i,j) < phn ) then
                              ! replace all below this latitude
         if ( lat(i,j) < phs ) then
              lfrac(i,j) = 1.0
              cycle
         endif
                              ! replace between 270 and 360 deg
         if ( sin(lon(i,j)) < 0. .and. cos(lon(i,j)) > 0.) then
              lfrac(i,j) = 1.0
              cycle 
         endif
         endif
         enddo
      enddo
 end subroutine remove_ice_sheets

    subroutine map_to_cubed_simple(im, jm, lat1, lon1, q1, grid, agrid, q2, npx, npy)


! Input
      integer, intent(in):: im,jm         ! original dimensions
      integer, intent(in):: npx, npy
!rjw      logical, intent(in):: master
      real, intent(in):: lat1(jm+1)       ! original southern edge of the cell [-pi/2:pi/2]
      real, intent(in):: lon1(im+1)       ! original western edge of the cell [0:2*pi]
      real(kind=4), intent(in):: q1(im,jm)        ! original data at center of the cell
!rjw      real(kind=4), intent(in):: f1(im,jm)        !

      real, intent(in)::  grid(is-ng:ie+ng+1, js-ng:je+ng+1,2)
      real, intent(in):: agrid(is-ng:ie+ng,   js-ng:je+ng,  2)

! Output
      real, intent(out):: q2(is-ng:ie+ng, js-ng:je+ng) ! Mapped data at the target resolution
!rjw      real, intent(out):: f2(isd:ied,jsd:jed) ! oro
!rjw      real, intent(out):: h2(isd:ied,jsd:jed) ! variances of terrain

! Local
      real(kind=4)  qt(-im/32:im+im/32,jm)    ! ghosted east-west
!rjw      real(kind=4)  ft(-im/32:im+im/32,jm)    ! 
      real lon_g(-im/32:im+im/32)
      real lat_g(jm)

      real pc(3), p2(2), pp(3), grid3(3,is-ng:ie+ng+1, js-ng:je+ng+1)
      integer i,j, np
      integer ii, jj, i1, i2, j1, j2
      integer ifirst, ilast
      real ddeg, latitude, qsum, fsum, hsum, lon_w, lon_e, lat_s, lat_n, r2d
      real delg

      pi = 4.0 * datan(1.0d0)

      r2d = 180./pi
      ddeg = 2.*pi/real(4*npx)

! Ghost the input coordinates:
      do i=1,im
         lon_g(i) = 0.5*(lon1(i)+lon1(i+1))
      enddo

      do i=-im/32,0
         lon_g(i) = lon_g(i+im)
      enddo
      do i=im+1,im+im/32
         lon_g(i) = lon_g(i-im)
      enddo

      do j=1,jm
         lat_g(j) = 0.5*(lat1(j)+lat1(j+1))
      enddo

      if ( 2*(im/2) /= im ) then
           write(*,*) 'Warning: Terrain datset must have an even nlon dimension'
      endif
! Ghost Data
      do j=1,jm
         do i=1,im
            qt(i,j) = q1(i,j)
!rjw            ft(i,j) = f1(i,j)
         enddo
         do i=-im/32,0
            qt(i,j) = qt(i+im,j)
!rjw            ft(i,j) = ft(i+im,j)
         enddo
         do i=im+1,im+im/32
            qt(i,j) = qt(i-im,j)
!rjw            ft(i,j) = ft(i-im,j)
         enddo
      enddo
      
      do j=js,je+1
         do i=is,ie+1
            call latlon2xyz(grid(i,j,1:2), grid3(1,i,j))
         enddo
      enddo

!rjw     if(master) write(*,*) 'surf_map: Search started ....'
! Mapping:
      do j=js,je
         do i=is,ie
! Determine the approximate local loop bounds (slightly larger than needed)
            lon_w = min( grid(i,j,1), grid(i+1,j,1), grid(i,j+1,1), grid(i+1,j+1,1) ) - ddeg
            lon_e = max( grid(i,j,1), grid(i+1,j,1), grid(i,j+1,1), grid(i+1,j+1,1) ) + ddeg
            if ( (lon_e - lon_w) > pi ) then
                 delg = max( abs(lon_e-2.*pi), abs(lon_w) ) + ddeg
                 i1 = -delg / (2.*pi/real(im)) - 1
                 i2 = -i1 + 1
            else 
                 i1 = lon_w / (2.*pi/real(im)) - 1
                 i2 = lon_e / (2.*pi/real(im)) + 2
            endif
            i1 = max(-im/32, i1)
            i2 = min(im+im/32, i2)
!           
            lat_s = min( grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2) ) - ddeg
            lat_n = max( grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2) ) + ddeg
            j1 = (0.5*pi + lat_s) / (pi/real(jm)) - 1
            j2 = (0.5*pi + lat_n) / (pi/real(jm)) + 2
              
              np = 0
            qsum = 0.
!rjw            fsum = 0.
!rjw            hsum = 0.
!           call latlon2xyz(agrid(i,j,1:2), pc)

!rjw             print *, 'Interior loop:  ',  i, j, i1, i2, j1, j2,  grid(i,j,1:2)*r2d,  agrid(i,j,1:2)*r2d

            do jj=max(1,j1),min(jm,j2)
                  p2(2) = lat_g(jj)
                  latitude =  p2(2)*r2d
               if ( abs(latitude) > 80.  ) then
                  ifirst = 1; ilast = im
               else
                  ifirst = i1; ilast = i2
               endif

               do ii=ifirst, ilast
                  p2(1) = lon_g(ii)
                  call latlon2xyz(p2, pp)
                  if (inside_p4(grid3(1,i,j), grid3(1,i+1,j), grid3(1,i+1,j+1), grid3(1,i,j+1), pp)) then
                       np = np + 1
                       qsum = qsum + qt(ii,jj)
!rjw                       fsum = fsum + ft(ii,jj)
!rjw                       hsum = hsum + qt(ii,jj)**2
                  endif

               enddo
            enddo
! Compute weighted average:
            if ( np > 0 ) then
                 q2(i,j) = qsum / real(np)
!rjw                 f2(i,j) = fsum / real(np)
!rjw                 h2(i,j) = hsum / real(np) - q2(i,j)**2
            else                    ! the subdomain could be totally flat
!rjw            if(master) write(*,*) 'Warning: surf_map failed'
                write(*,*) 'Warning: surf_map_simple failed'
                q2(i,j) = 1.E8
                call mp_stop

            endif
         enddo
      enddo
      end subroutine map_to_cubed_simple

!#######################################################################
! reads the namelist file, write namelist to log file,
! and initializes constants

subroutine read_namelist

   integer :: unit, ierr, io
!   real    :: dtr, ght

!  read namelist

#ifdef INTERNAL_FILE_NML
   read  (input_nml_file, nml=surf_map_nml, iostat=io)
   ierr = check_nml_error(io,'surf_map_nml')
#else
   if ( file_exist('input.nml')) then
      unit = open_namelist_file ( )
      ierr=1; do while (ierr /= 0)
         read  (unit, nml=surf_map_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'surf_map_nml')
      enddo
 10   call close_file (unit)
   endif
#endif

!  write version and namelist to log file

   if (mpp_pe() == mpp_root_pe()) then
     unit = stdlog()
     write (unit, nml=surf_map_nml)
   endif

end subroutine read_namelist


 end module fv_surf_map_mod


      module fv_timing_mod

#if defined(SPMD)
      use fv_mp_mod, only: masterproc, mp_reduce_max
#endif
!
! ... Use system etime() function for timing
!
      implicit none

      integer, private      :: nblks
      parameter  (nblks   = 100)

      character(len=20), private :: blkname(nblks)

      integer , private      :: tblk

#if defined(SPMD)
      real , external       :: MPI_Wtime
#endif
      real , private       :: etime
      real , private       :: totim
      real , private       :: tarray(2)
      type tms
           private
           real :: usr, sys
      end type tms


      type (tms), private   :: accum(nblks), last(nblks)

      real , private       :: us_tmp1(nblks,2)
      real , private       :: us_tmp2(nblks,2)

      contains
         subroutine timing_init
!
! init
!
         implicit none

         integer  :: C, R, M
         real    :: wclk

         integer  n


         tblk=0
         do n = 1, nblks
            accum(n)%usr = 0.
            accum(n)%sys = 0.
            last(n)%usr  = 0.
            last(n)%sys  = 0.
         end do
!
! ... To reduce the overhead for the first call
!
#if defined(SPMD)
    wclk = MPI_Wtime() 
    totim = wclk
#else
#   if defined( IRIX64 ) || ( defined FFC )
         totim = etime(tarray)
#   else
         CALL SYSTEM_CLOCK(Count=C, Count_Rate=R, Count_Max=M)
         wclk =  REAL(C) / REAL(R)
         totim = wclk
#   endif
#endif

         end subroutine timing_init


         subroutine timing_on(blk_name)
!
! timing_on
!

         implicit none

         character(len=*) :: blk_name



         character(len=20) :: UC_blk_name
         character(len=20) ::  ctmp 
         integer i
         integer iblk

         integer :: C, R, M
         real   :: wclk

         integer ierr

         UC_blk_name = blk_name

         call upper(UC_blk_name,len_trim(UC_blk_name))
!c         ctmp=UC_blk_name(:len_trim(UC_blk_name))
         ctmp=trim(UC_blk_name)

!         write(*,*) 'timing_on ', ctmp
         iblk=0
         do i=1, tblk
            if ( ctmp .EQ. blkname(i) ) then
               iblk =i
            endif
         enddo
      
         if ( iblk .eq. 0 ) then
            tblk=tblk+1
            iblk=tblk
            call upper(UC_blk_name,len_trim(UC_blk_name))
!C            blkname(iblk)=UC_blk_name(:len_trim(UC_blk_name))
            blkname(iblk)=trim(UC_blk_name)

        endif

#if defined(SPMD)
        wclk = MPI_Wtime()
        last(iblk)%usr = wclk
        last(iblk)%sys = 0.0
#else
# if defined( IRIX64 ) || ( defined FFC )
        totim = etime(tarray)
        last(iblk)%usr = tarray(1)
        last(iblk)%sys = tarray(2)
# else
        CALL SYSTEM_CLOCK(Count=C, Count_Rate=R, Count_Max=M)
        wclk = REAL(C) / REAL(R)
        last(iblk)%usr = wclk
        last(iblk)%sys = 0.0
# endif
#endif  

        end subroutine timing_on


        subroutine timing_off(blk_name)
!
! Timing_off
!

        implicit none
        character(len=*) :: blk_name

        character(len=20) :: UC_blk_name
        character(len=20) :: ctmp
        integer i

        integer  :: C, R, M
        real    :: wclk

        integer  iblk

        UC_blk_name = blk_name

        call upper(UC_blk_name,len_trim(UC_blk_name))
!v        ctmp=UC_blk_name(:len_trim(UC_blk_name))
        ctmp=trim(UC_blk_name)

        iblk=0
        do i=1, tblk
           if ( ctmp .EQ. blkname(i) ) then
              iblk =i
           endif
        enddo
      
!         write(*,*) 'timing_off ', ctmp, tblk, tblk
        if ( iblk .eq. 0 ) then
!           write(*,*) 'stop in timing off in ', ctmp
!           stop 
        endif

#if defined(SPMD)
        wclk = MPI_Wtime()
        accum(iblk)%usr = accum(iblk)%usr + wclk - last(iblk)%usr
        accum(iblk)%sys = 0.0
        last(iblk)%usr  = wclk
        last(iblk)%sys  = 0.0
#else
# if defined( IRIX64 ) || ( defined FFC ) 
        totim = etime(tarray)
        accum(iblk)%usr = accum(iblk)%usr +           &
                        tarray(1) - last(iblk)%usr
        accum(iblk)%sys = accum(iblk)%sys +           &
                        tarray(2) - last(iblk)%sys
        last(iblk)%usr = tarray(1)
        last(iblk)%sys = tarray(2)
# else
        CALL SYSTEM_CLOCK(Count=C, Count_Rate=R, Count_Max=M)
        wclk = REAL(C) / REAL(R)
        accum(iblk)%usr = accum(iblk)%usr + wclk - last(iblk)%usr
        accum(iblk)%sys = 0.0
        last(iblk)%usr  = wclk
        last(iblk)%sys  = 0.0
# endif
#endif
        end subroutine timing_off


        subroutine timing_clear()
        integer  n
          do n = 1, nblks
             accum(n)%usr = 0
             accum(n)%sys = 0
          enddo
        end subroutine timing_clear


        subroutine timing_prt(gid)
!
! Timing_prt
!
        implicit none
        integer  gid
        integer  n

        type (tms)   :: others, tmp(nblks)
        real         :: tmpmax

#if defined( SPMD )
        do n = 1, nblks                   !will clean these later
           tmpmax = accum(n)%usr
           call mp_reduce_max(tmpmax)
           tmp(n)%usr = tmpmax
           tmpmax = accum(n)%sys
           call mp_reduce_max(tmpmax)
           tmp(n)%sys = tmpmax
        enddo
        if ( gid .eq. masterproc ) then
#else
        do n = 1, nblks
           tmp(n)%usr = accum(n)%usr
           tmp(n)%sys = accum(n)%sys
        enddo
#endif

        print *
        print *,                                  &
        '  -----------------------------------------------------'
        print *,                                  &
        '     Block          User time  System Time   Total Time'
        print *,                                  &
        '  -----------------------------------------------------'

        do n = 1, tblk
           print '(3x,a20,2x,3(1x,f12.4))', blkname(n),     &
               tmp(n)%usr, tmp(n)%sys, tmp(n)%usr + tmp(n)%sys
        end do


        print *
#if defined( SPMD )
        endif ! masterproc
#endif

        end subroutine timing_prt

      subroutine upper(string,length)

!***********************************************************************
!
!     upper.f - change lower case letter to upper case letter          *
!                                                                      *
!     George Lai Tue Jun 28 16:37:00 1994                              *
!                                                                      *
!***********************************************************************

      implicit         none

!      character string(length)
!      character(len=20) string
!      character, dimension(length) :: string
!      character (len=*), intent(inout) ::  string
!      character (len=*) ::  string
!      character (len=1), intent(inout) ::  string(20)
!ok      character (len=20), intent(inout) ::  string
      character (len=*), intent(inout) ::  string
      character char1
      integer,   intent(in)    ::  length
      integer i
      integer a, z, dist
      a = ichar('a')
      z = ichar('z')
      dist = ichar('A') - a

      do i = 1,length
        char1=string(i:i)
        if (ichar(char1) .ge. a .and.       &
            ichar(char1) .le. z) then
          string(i:i) = char(ichar(char1)+dist)
        endif
      end do

      return
      end subroutine upper

      end module fv_timing_mod


! $Id: init_hydro.F90,v 17.0 2009/07/21 02:52:36 fms Exp $

module init_hydro_mod

      use constants_mod, only: grav, rdgas
      use fv_grid_utils_mod,    only: g_sum
      use fv_grid_tools_mod,    only: area
      use fv_mp_mod,        only: gid, masterproc
!     use fv_diagnostics_mod, only: prt_maxmin

      implicit none
      private

      public :: p_var, hydro_eq

contains

!-------------------------------------------------------------------------------
 subroutine p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min,    &
                  delp, delz, pt, ps,  pe, peln, pk, pkz, cappa, q, ng, nq,    &
                  dry_mass, adjust_dry_mass, mountain, moist_phys,      &
                  hydrostatic, ktop, nwat, make_nh)
               
! Given (ptop, delp) computes (ps, pk, pe, peln, pkz)
! Input:
   integer,  intent(in):: km
   integer,  intent(in):: ifirst, ilast            ! Longitude strip
   integer,  intent(in):: jfirst, jlast            ! Latitude strip
   integer,  intent(in):: nq, nwat
   integer,  intent(in):: ng
   integer,  intent(in):: ktop
   logical, intent(in):: adjust_dry_mass, mountain, moist_phys, hydrostatic
   real, intent(in):: dry_mass, cappa, ptop, ptop_min
   real, intent(in   )::   pt(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km)
   real, intent(inout):: delz(ifirst   :ilast   ,jfirst   :jlast   , km)
   real, intent(inout):: delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km)
   real, intent(inout)::    q(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km, nq)
   logical, optional:: make_nh
! Output:
   real, intent(out) ::   ps(ifirst-ng:ilast+ng, jfirst-ng:jlast+ng)
   real, intent(out) ::   pk(ifirst:ilast, jfirst:jlast, km+1)
   real, intent(out) ::   pe(ifirst-1:ilast+1,km+1,jfirst-1:jlast+1) ! Ghosted Edge pressure
   real, intent(out) :: peln(ifirst:ilast, km+1, jfirst:jlast)    ! Edge pressure
   real, intent(out) ::  pkz(ifirst:ilast, jfirst:jlast, km)

! Local
   real ratio(ifirst:ilast)
   real pek, lnp, ak1, rdg, dpd
   integer i, j, k


! Check dry air mass & compute the adjustment amount:
   call drymadj(km, ifirst, ilast,  jfirst,  jlast, ng, cappa, ptop, ps, &
                delp, q, nq, nwat, dry_mass, adjust_dry_mass, moist_phys, dpd)

   pek = ptop ** cappa

   do j=jfirst,jlast
      do i=ifirst,ilast
         pe(i,1,j) = ptop
         pk(i,j,1) = pek
      enddo

      if ( adjust_dry_mass ) then
         do i=ifirst,ilast
            ratio(i) = 1. + dpd/(ps(i,j)-ptop)
         enddo 
         do k=1,km
            do i=ifirst,ilast
               delp(i,j,k) = delp(i,j,k) * ratio(i)
            enddo
         enddo
      endif

      do k=2,km+1
         do i=ifirst,ilast
            pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
            peln(i,k,j) = log(pe(i,k,j))
            pk(i,j,k) = exp( cappa*peln(i,k,j) )
!            pk(i,j,k) = pe(i,k,j)**cappa
         enddo
      enddo

      do i=ifirst,ilast
         ps(i,j) = pe(i,km+1,j)
      enddo

      if( ptop < ptop_min ) then
!---- small ptop modification -------------
          ak1 = (cappa + 1.) / cappa
          do i=ifirst,ilast
             peln(i,1,j) = peln(i,2,j) - ak1
          enddo
      else
             lnp = log( ptop )
          do i=ifirst,ilast
             peln(i,1,j) = lnp
          enddo
      endif

      if ( hydrostatic ) then
         do k=1,km
            do i=ifirst,ilast
               pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(cappa*(peln(i,k+1,j)-peln(i,k,j)))
            enddo
         enddo
      endif
   enddo

!--------
! Caution:
!------------------------------------------------------------------
! The following form is the same as in "fv_update_phys.F90"
! Therefore, restart reproducibility is only enforced in diabatic cases
!------------------------------------------------------------------
! For adiabatic runs, this form is not exactly the same as in mapz_module;
! Therefore, rounding differences will occur with restart!

   if ( .not.hydrostatic ) then

      if ( ktop>1 ) then
! Compute pkz using hydrostatic formular:
         do k=1,ktop-1
            do j=jfirst,jlast
            do i=ifirst,ilast
               pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(cappa*(peln(i,k+1,j)-peln(i,k,j)))
            enddo
            enddo
         enddo
      endif

      rdg = -rdgas / grav
      if ( present(make_nh) ) then
          if ( make_nh ) then
             do k=1,km
                do j=jfirst,jlast
                   do i=ifirst,ilast
                      delz(i,j,k) = rdg*pt(i,j,k)*(peln(i,k+1,j)-peln(i,k,j))
                   enddo
                enddo
             enddo
             if(gid==0) write(*,*) 'delz computed from hydrostatic state'
!            call prt_maxmin('delz', delz, ifirst, ilast, jfirst, jlast, 0, km, 1., gid==masterproc)
          endif
      endif

      do k=ktop,km
         do j=jfirst,jlast
            do i=ifirst,ilast
               pkz(i,j,k) = (rdg*delp(i,j,k)*pt(i,j,k)/delz(i,j,k))**cappa
            enddo
         enddo
      enddo
   endif

 end subroutine p_var



 subroutine drymadj(km,  ifirst, ilast, jfirst,  jlast,  ng, &  
                    cappa,   ptop, ps, delp, q,  nq,  nwat,  &
                    dry_mass, adjust_dry_mass, moist_phys, dpd)

! !INPUT PARAMETERS:
      integer km
      integer ifirst, ilast  ! Long strip
      integer jfirst, jlast  ! Latitude strip    
      integer nq, ng, nwat
      real, intent(in):: dry_mass
      real, intent(in):: ptop
      real, intent(in):: cappa
      logical, intent(in):: adjust_dry_mass
      logical, intent(in):: moist_phys

! !INPUT/OUTPUT PARAMETERS:     
      real, intent(in)::   q(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng,km,nq)
      real, intent(in)::delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng,km)     !
      real, intent(inout):: ps(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)        ! surface pressure
      real, intent(out):: dpd
! Local
      real  psd(ifirst:ilast,jfirst:jlast)     ! surface pressure  due to dry air mass
      real  psmo, psdry
      integer i, j, k

!$omp parallel do default(shared) private(i, j, k)
      do j=jfirst,jlast

         do i=ifirst,ilast
             ps(i,j) = ptop
            psd(i,j) = ptop
         enddo

         do k=1,km
            do i=ifirst,ilast
               ps(i,j) = ps(i,j) + delp(i,j,k)
            enddo
         enddo

       if ( nwat>=1 ) then
          do k=1,km
             do i=ifirst,ilast
                psd(i,j) = psd(i,j) + delp(i,j,k)*(1. - sum(q(i,j,k,1:nwat)))
             enddo
          enddo
        else
          do i=ifirst,ilast
             psd(i,j) = ps(i,j)
          enddo
        endif
      enddo

! Check global maximum/minimum
#ifndef QUICK_SUM
      psdry = g_sum(psd, ifirst, ilast, jfirst, jlast, ng, area, 1, .true.) 
       psmo = g_sum(ps(ifirst:ilast,jfirst:jlast), ifirst, ilast, jfirst, jlast,  &
                     ng, area, 1, .true.) 
#else
      psdry = g_sum(psd, ifirst, ilast, jfirst, jlast, ng, area, 1) 
       psmo = g_sum(ps(ifirst:ilast,jfirst:jlast), ifirst, ilast, jfirst, jlast,  &
                     ng, area, 1) 
#endif

      if(gid==masterproc) then
         write(6,*) 'Total surface pressure (mb) = ', 0.01*psmo
         if ( moist_phys ) then
              write(6,*) 'mean dry surface pressure = ', 0.01*psdry
              write(6,*) 'Total Water (kg/m**2) =', real(psmo-psdry,4)/GRAV
         endif
      endif

      if( adjust_dry_mass ) Then
          dpd = real(dry_mass - psdry,4)
          if(gid==masterproc) write(6,*) 'dry mass to be added (pascals) =', dpd
      endif

 end subroutine drymadj



 subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk,  &
                     pt, delz, ng, mountain, hybrid_z)
! Input: 
  integer, intent(in):: is, ie, js, je, km, ng
  real, intent(in):: ak(km+1), bk(km+1)
  real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng)
  real, intent(in):: drym
  logical, intent(in):: mountain
  logical, intent(in):: hybrid_z
! Output
  real, intent(out):: ps(is-ng:ie+ng,js-ng:je+ng)
  real, intent(out)::   pt(is-ng:ie+ng,js-ng:je+ng,km)
  real, intent(out):: delp(is-ng:ie+ng,js-ng:je+ng,km)
  real, intent(inout):: delz(is:ie,js:je,km)
! Local
  real   gz(is:ie,km+1)
  real   ph(is:ie,km+1)
  real mslp, z1, t1, p1, t0, a0, psm
  real ztop, c0
#ifdef INIT_4BYTE
  real(kind=4) ::  dps 
#else
  real dps    ! note that different PEs will get differt dps during initialization
              ! this has no effect after cold start
#endif
  real p0, gztop, ptop
  integer  i,j,k

  if ( gid==masterproc ) write(*,*) 'Initializing ATM hydrostatically'

#if defined(MARS_GCM)
  if ( gid==masterproc ) write(*,*) 'Initializing Mars'
      p0 = 6.5E2         !
      t0 = 200.0

!         Isothermal temperature
      pt = t0

      gztop = rdgas*t0*log(p0/ak(1))        ! gztop when zs==0

     do j=js,je
        do i=is,ie
           ps(i,j) = ak(1)*exp((gztop-hs(i,j))/(rdgas*t0))
        enddo
     enddo

     psm = g_sum(ps(is:ie,js:je), is, ie, js, je, ng, area, 1, .true.)
     dps = drym - psm

     if(gid==masterproc) write(6,*) 'Initializing:  Computed mean ps=', psm
     if(gid==masterproc) write(6,*) '            Correction delta-ps=', dps

!           Add correction to surface pressure to yield desired
!                globally-integrated atmospheric mass  (drym)
     do j=js,je
        do i=is,ie
           ps(i,j) = ps(i,j) + dps
        enddo
     enddo

      do k=1,km
         do j=js,je
            do i=is,ie
               delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
            enddo
         enddo
      enddo

#elif defined(VENUS_GCM)
  if ( gid==masterproc ) write(*,*) 'Initializing Venus'
      p0 = 92.E5         ! need to tune this value
      t0 = 700.
      pt = t0
! gztop when zs==0
      gztop = rdgas*t0*log(p0/ak(1))

     do j=js,je
        do i=is,ie
           ps(i,j) = ak(1)*exp((gztop-hs(i,j))/(rdgas*t0))
        enddo
     enddo

      do k=1,km
         do j=js,je
            do i=is,ie
               delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
            enddo
         enddo
      enddo

#else
  if ( gid==masterproc ) write(*,*) 'Initializing Earth'
! Given p1 and z1 (250mb, 10km)
        p1 = 25000.
        z1 = 10.E3 * grav
        t1 = 215.
        t0 = 280.            ! sea-level temp.
        a0 = (t1-t0)/z1
        c0 = t0/a0

     if ( hybrid_z ) then
          ptop = 100.   ! *** hardwired model top *** 
     else
          ptop = ak(1)
     endif

     ztop = z1 + (rdgas*t1)*log(p1/ptop)
     if(gid==masterproc) write(6,*) 'ZTOP is computed as', ztop/grav*1.E-3

  if ( mountain ) then
     mslp = 100917.4
     do j=js,je
        do i=is,ie
           ps(i,j) = mslp*( c0/(hs(i,j)+c0))**(1./(a0*rdgas))
        enddo
     enddo
     psm = g_sum(ps(is:ie,js:je), is, ie, js, je, ng, area, 1, .true.)
     dps = drym - psm
     if(gid==masterproc) write(6,*) 'Computed mean ps=', psm
     if(gid==masterproc) write(6,*) 'Correction delta-ps=', dps
  else
     mslp = 1000.E2
     do j=js,je
        do i=is,ie
           ps(i,j) = mslp
        enddo
     enddo
     dps = 0.
  endif


  do j=js,je
     do i=is,ie
        ps(i,j) = ps(i,j) + dps
        gz(i,   1) = ztop
        gz(i,km+1) = hs(i,j)
        ph(i,   1) = ptop                                                     
        ph(i,km+1) = ps(i,j)                                               
     enddo

     if ( hybrid_z ) then
!---------------
! Hybrid Z
!---------------
        do k=km,2,-1
           do i=is,ie
              gz(i,k) = gz(i,k+1) - delz(i,j,k)*grav 
           enddo
        enddo
! Correct delz at the top:
        do i=is,ie
            delz(i,j,1) = (gz(i,2) - ztop) / grav
        enddo
 
        do k=2,km
           do i=is,ie
              if ( gz(i,k) >= z1 ) then
! Isothermal
                 ph(i,k) = ptop*exp( (gz(i,1)-gz(i,k))/(rdgas*t1) )
              else
! Constant lapse rate region (troposphere)
                 ph(i,k) = ps(i,j)*((hs(i,j)+c0)/(gz(i,k)+c0))**(1./(a0*rdgas))
              endif
           enddo
        enddo
     else
!---------------
! Hybrid sigma-p
!---------------
       do k=2,km+1
          do i=is,ie
             ph(i,k) = ak(k) + bk(k)*ps(i,j)
          enddo
       enddo

       do k=2,km
          do i=is,ie
             if ( ph(i,k) <= p1 ) then
! Isothermal
                 gz(i,k) = ztop + (rdgas*t1)*log(ptop/ph(i,k))
             else
! Constant lapse rate region (troposphere)
                 gz(i,k) = (hs(i,j)+c0)/(ph(i,k)/ps(i,j))**(a0*rdgas) - c0
             endif
          enddo
       enddo
     endif  ! end hybrid_z

! Convert geopotential to Temperature
      do k=1,km
         do i=is,ie
              pt(i,j,k) = (gz(i,k)-gz(i,k+1))/(rdgas*(log(ph(i,k+1)/ph(i,k))))
              pt(i,j,k) = max(t1, pt(i,j,k))
            delp(i,j,k) = ph(i,k+1) - ph(i,k)
         enddo
      enddo
   enddo    ! j-loop

   if ( hybrid_z ) then 
!      call prt_maxmin('INIT_hydro: delz', delz, is, ie, js, je,  0, km, 1., gid==masterproc)
!      call prt_maxmin('INIT_hydro: DELP', delp, is, ie, js, je, ng, km, 1., gid==masterproc)
   endif
!  call prt_maxmin('INIT_hydro: PT  ', pt,   is, ie, js, je, ng, km, 1., gid==masterproc)

#endif

 end subroutine hydro_eq


end module init_hydro_mod


module sim_nc_mod

! This is S-J Lin's private netcdf file reader
! This code is needed because FMS utilitty (read_data) led to too much
! memory usage and too many files openned. Perhaps lower-level FMS IO
! calls should be used instaed.

 use mpp_mod,     only: mpp_error, FATAL

 implicit none
#include <netcdf.inc>

 private
 public  open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_double,   &
         get_var3_double

 contains

      subroutine open_ncfile( iflnm, ncid )
      character*(*), intent(in)::  iflnm
      integer, intent(out)::      ncid
      integer::  status

      status = nf_open (iflnm, NF_NOWRITE, ncid)
      if (status .ne. NF_NOERR) call handle_err(status)


      end subroutine open_ncfile


      subroutine close_ncfile( ncid )
      integer, intent(in)::    ncid
      integer::  status

      status = nf_close (ncid)
      if (status .ne. NF_NOERR) call handle_err(status)


      end subroutine close_ncfile


      subroutine get_ncdim1( ncid, var1_name, im )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var1_name
      integer, intent(out):: im
      integer::  status, var1id

      status = nf_inq_dimid (ncid, var1_name, var1id)
      if (status .ne. NF_NOERR) call handle_err(status)

      status = nf_inq_dimlen (ncid, var1id, im)
      if (status .ne. NF_NOERR) call handle_err(status)

      end subroutine get_ncdim1




      subroutine get_var1_double( ncid, var1_name, im, var1 )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var1_name
      integer, intent(in):: im
      real*8, intent(out):: var1(im)

      integer::  status, var1id

      status = nf_inq_varid (ncid, var1_name, var1id)
      if (status .ne. NF_NOERR) call handle_err(status)

      status = nf_get_var_double (ncid, var1id, var1)
      if (status .ne. NF_NOERR) call handle_err(status)


      end subroutine get_var1_double

      subroutine get_var1_real( ncid, var1_name, im, var1 )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var1_name
      integer, intent(in):: im
      real*4, intent(out):: var1(im)

      integer::  status, var1id

      status = nf_inq_varid (ncid, var1_name, var1id)
      if (status .ne. NF_NOERR) call handle_err(status)

      status = nf_get_var_real (ncid, var1id, var1)
      if (status .ne. NF_NOERR) call handle_err(status)

      end subroutine get_var1_real



      subroutine get_var2_double( ncid, var2_name, im, jm, var2 )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var2_name
      integer, intent(in):: im, jm
      real*8, intent(out):: var2(im,jm)

      integer::  status, var2id

      status = nf_inq_varid (ncid, var2_name, var2id)
      if (status .ne. NF_NOERR) call handle_err(status)

      status = nf_get_var_double (ncid, var2id, var2)
      if (status .ne. NF_NOERR) call handle_err(status)


      end subroutine get_var2_double


      subroutine get_var3_double( ncid, var3_name, im, jm, km, var3 )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var3_name
      integer, intent(in):: im, jm, km
      real*8, intent(out):: var3(im,jm,km)

      integer::  status, var3id

      status = nf_inq_varid (ncid, var3_name, var3id)

      if (status .ne. NF_NOERR) call handle_err(status)

      status = nf_get_var_double (ncid, var3id, var3)
      if (status .ne. NF_NOERR) call handle_err(status)

      end subroutine get_var3_double

!------------------------------------------------------------------------
      subroutine get_var4_double( ncid, var4_name, im, jm, km, nt, var4 )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var4_name
      integer, intent(in):: im, jm, km, nt
      real*8, intent(out):: var4(im,jm,km,1)
      integer::  status, var4id
!
      integer:: start(4), icount(4) 

      start(1) = 1
      start(2) = 1
      start(3) = 1
      start(4) = nt

      icount(1) = im    ! all range
      icount(2) = jm    ! all range
      icount(3) = km    ! all range
      icount(4) = 1     ! one time level at a time


      status = nf_inq_varid (ncid, var4_name, var4id)

      status = nf_get_vara_double(ncid, var4id, start, icount, var4)

      if (status .ne. NF_NOERR) call handle_err(status)

      end subroutine get_var4_double
!------------------------------------------------------------------------

      subroutine get_real3( ncid, var4_name, im, jm, nt, var4 )
! This is for multi-time-level 2D var
      integer, intent(in):: ncid
      character*(*), intent(in)::  var4_name
      integer, intent(in):: im, jm, nt
      real*4, intent(out):: var4(im,jm)
      integer::  status, var4id
      integer:: start(3), icount(3)
      integer:: i,j

      start(1) = 1
      start(2) = 1
      start(3) = nt

      icount(1) = im
      icount(2) = jm
      icount(3) = 1

      status = nf_inq_varid (ncid, var4_name, var4id)
      status = nf_get_vara_real(ncid, var4id, start, icount, var4)

      if (status .ne. NF_NOERR) call handle_err(status)

      end subroutine get_real3
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine get_var4_real( ncid, var4_name, im, jm, km, nt, var4 )
      integer, intent(in):: ncid
      character*(*), intent(in)::  var4_name
      integer, intent(in):: im, jm, km, nt
      real*4:: wk4(im,jm,km,4)
      real*4, intent(out):: var4(im,jm)
      integer::  status, var4id
      integer:: start(4), icount(4) 
      integer:: i,j

      start(1) = 1
      start(2) = 1
      start(3) = 1
      start(4) = nt

      icount(1) = im    ! all range
      icount(2) = jm    ! all range
      icount(3) = km    ! all range
      icount(4) = 1     ! one time level at a time

      status = nf_inq_varid (ncid, var4_name, var4id)

      status = nf_get_vara_real(ncid, var4id, start, icount, var4)
!     status = nf_get_vara_real(ncid, var4id, start, icount, wk4)

      do j=1,jm
      do i=1,im
!        var4(i,j) = wk4(i,j,1,nt)
      enddo
      enddo

      if (status .ne. NF_NOERR) call handle_err(status)

      end subroutine get_var4_real
!------------------------------------------------------------------------


      subroutine handle_err(status)
      integer          status

      if (status .ne. nf_noerr) then
        call mpp_error(FATAL,'Error in handle_err')
      endif

      end subroutine handle_err

   subroutine calendar(year, month, day, hour)
      integer, intent(inout) :: year              ! year
      integer, intent(inout) :: month             ! month
      integer, intent(inout) :: day               ! day
      integer, intent(inout) :: hour
!
! Local variables
!
      integer irem4,irem100
      integer mdays(12)                           ! number day of month 
      data mdays /31,28,31,30,31,30,31,31,30,31,30,31/
!
!***********************************************************************
!******         compute current GMT                               ******
!***********************************************************************
!
!**** consider leap year
!
      irem4    = mod( year, 4 )
      irem100  = mod( year, 100 )
      if( irem4 == 0 .and. irem100 /= 0) mdays(2) = 29
!
      if( hour >= 24 ) then
        day    = day + 1
        hour   = hour - 24
      end if

      if( day > mdays(month) ) then
        day    = day - mdays(month)
        month  = month + 1
      end if
      if( month > 12 ) then
        year   = year + 1
        month  = 1
      end if

  end subroutine calendar

end module sim_nc_mod


!-*- F90 -*-
module sorted_index_mod
  !---------------------------------------------------------------------
  ! <CONTACT EMAIL= "Michael.Herzog@noaa.gov">Michael Herzog </CONTACT>
  !
  !<OVERVIEW>
  ! sort cell corner indices in latlon space to ensure same order of
  ! operations regardless of orientation in index space
  !</OVERVIEW>
  !
  !<DESCRIPTION>
  ! i/jinta are indices of b-grid locations needed for line integrals 
  ! around an a-grid cell including ghosting.
  !
  ! i/jintb are indices of a-grid locations needed for line integrals
  ! around a b-grid cell, no ghosting.
  !</DESCRIPTION>
  !---------------------------------------------------------------------

  implicit none
  private
  public :: sorted_inta, sorted_intb


contains
  !#####################################################################
  ! <SUBROUTINE NAME="sorted_inta">
  !
  ! <DESCRIPTION>
  ! Sort cell corner indices in latlon space based on grid locations 
  ! in index space. If not cubed_sphere assume orientations in index 
  ! and latlon space are identical.
  !
  ! i/jinta are indices of b-grid locations needed for line integrals 
  ! around an a-grid cell including ghosting.
  !
  ! i/jintb are indices of a-grid locations needed for line integrals
  ! around a b-grid cell, no ghosting.
  ! </DESCRIPTION>
  !
  subroutine sorted_inta(isd, ied, jsd, jed, cubed_sphere, bgrid, iinta, jinta)

    integer, intent(in) :: isd, ied, jsd, jed
    real,    intent(in), dimension(isd:ied+1,jsd:jed+1,2) :: bgrid
    logical, intent(in) :: cubed_sphere

    integer, intent(out), dimension(4,isd:ied,jsd:jed) :: iinta, jinta
    !------------------------------------------------------------------!
    ! local variables                                                  !
    !------------------------------------------------------------------!
    real,    dimension(4) :: xsort, ysort
    integer, dimension(4) :: isort, jsort
    integer :: i, j
    !------------------------------------------------------------------!
    ! special treatment for cubed sphere                               !
    !------------------------------------------------------------------!
    if (cubed_sphere) then
       !---------------------------------------------------------------!
       ! get order of indices for line integral around a-grid cell     ! 
       !---------------------------------------------------------------!
       do j=jsd,jed
          do i=isd,ied
             xsort(1)=bgrid(i  ,j  ,1); ysort(1)=bgrid(i  ,j  ,2); isort(1)=i  ; jsort(1)=j
             xsort(2)=bgrid(i  ,j+1,1); ysort(2)=bgrid(i  ,j+1,2); isort(2)=i  ; jsort(2)=j+1
             xsort(3)=bgrid(i+1,j+1,1); ysort(3)=bgrid(i+1,j+1,2); isort(3)=i+1; jsort(3)=j+1
             xsort(4)=bgrid(i+1,j  ,1); ysort(4)=bgrid(i+1,j  ,2); isort(4)=i+1; jsort(4)=j
             call sort_rectangle(iinta(1,i,j), jinta(1,i,j))
          enddo
       enddo
    else
       !---------------------------------------------------------------!
       ! default behavior for other grids                              !
       !---------------------------------------------------------------!
       do j=jsd,jed
          do i=isd,ied
             iinta(i,j,1)=i  ; jinta(i,j,1)=j
             iinta(i,j,2)=i  ; jinta(i,j,2)=j+1
             iinta(i,j,3)=i+1; jinta(i,j,3)=j+1
             iinta(i,j,4)=i+1; jinta(i,j,4)=j  
          enddo
       enddo
    endif

  contains
    !------------------------------------------------------------------!
    subroutine sort_rectangle(iind, jind)
      integer, dimension(4), intent(inout) :: iind, jind
      !----------------------------------------------------------------!
      ! local variables                                                !
      !----------------------------------------------------------------!
      real,    dimension(4) :: xsorted, ysorted
      integer, dimension(4) :: isorted, jsorted
      integer :: l, ll, lll
      !----------------------------------------------------------------!
      ! sort in east west                                              !
      !----------------------------------------------------------------!
      xsorted(:)=10.
      ysorted(:)=10.
      isorted(:)=0
      jsorted(:)=0
             
      do l=1,4
         do ll=1,4
            if (xsort(l)<xsorted(ll)) then
               do lll=3,ll,-1
                  xsorted(lll+1)=xsorted(lll)
                  ysorted(lll+1)=ysorted(lll)
                  isorted(lll+1)=isorted(lll)
                  jsorted(lll+1)=jsorted(lll)
               enddo
               xsorted(ll)=xsort(l)
               ysorted(ll)=ysort(l)
               isorted(ll)=isort(l)
               jsorted(ll)=jsort(l)
               exit
            endif
         enddo
      enddo
      !----------------------------------------------------------------!
      ! sort in north south                                            !
      !----------------------------------------------------------------!
      do l=1,4
         xsort(l)=xsorted(l); ysort(l)=ysorted(l)
         isort(l)=isorted(l); jsort(l)=jsorted(l)
      enddo
      xsorted(:)=10.
      ysorted(:)=10.
      isorted(:)=0
      jsorted(:)=0
      
      do l=1,4
         do ll=1,4
            if (ysort(l)<ysorted(ll)) then
               do lll=3,ll,-1
                  xsorted(lll+1)=xsorted(lll)
                  ysorted(lll+1)=ysorted(lll)
                  isorted(lll+1)=isorted(lll)
                  jsorted(lll+1)=jsorted(lll)
               enddo
               xsorted(ll)=xsort(l)
               ysorted(ll)=ysort(l)
               isorted(ll)=isort(l)
               jsorted(ll)=jsort(l)
               exit
            endif
         enddo
      enddo
      !----------------------------------------------------------------!
      ! use first two grid point for start and orientation             !
      !----------------------------------------------------------------!
      if ( isorted(1)==i .and. jsorted(1)==j ) then
         if ( isorted(2)==i+1 .and. jsorted(2)==j+1 ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i   .and. jsorted(2)==j+1 ) then
            iind(1)=i  ; jind(1)=j
            iind(2)=i  ; jind(2)=j+1
            iind(3)=i+1; jind(3)=j+1
            iind(4)=i+1; jind(4)=j  
         elseif ( isorted(2)==i+1 .and. jsorted(2)==j ) then
            iind(1)=i  ; jind(1)=j
            iind(2)=i+1; jind(2)=j
            iind(3)=i+1; jind(3)=j+1
            iind(4)=i  ; jind(4)=j+1
         endif
         
      elseif ( isorted(1)==i .and. jsorted(1)==j+1 ) then
         if ( isorted(2)==i+1 .and. jsorted(2)==j ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i+1 .and. jsorted(2)==j+1 ) then
            iind(1)=i  ; jind(1)=j+1
            iind(2)=i+1; jind(2)=j+1
            iind(3)=i+1; jind(3)=j
            iind(4)=i  ; jind(4)=j  
         elseif ( isorted(2)==i   .and. jsorted(2)==j ) then
            iind(1)=i  ; jind(1)=j+1
            iind(2)=i  ; jind(2)=j
            iind(3)=i+1; jind(3)=j
            iind(4)=i+1; jind(4)=j+1
         endif
         
      elseif ( isorted(1)==i+1 .and. jsorted(1)==j+1 ) then
         if ( isorted(2)==i .and. jsorted(2)==j ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i+1 .and. jsorted(2)==j ) then
            iind(1)=i+1; jind(1)=j+1
            iind(2)=i+1; jind(2)=j
            iind(3)=i  ; jind(3)=j
            iind(4)=i  ; jind(4)=j+1  
         elseif ( isorted(2)==i   .and. jsorted(2)==j+1 ) then
            iind(1)=i+1; jind(1)=j+1
            iind(2)=i  ; jind(2)=j+1
            iind(3)=i  ; jind(3)=j
            iind(4)=i+1; jind(4)=j
         endif
         
      elseif ( isorted(1)==i+1 .and. jsorted(1)==j ) then
         if ( isorted(2)==i .and. jsorted(2)==j+1 ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i   .and. jsorted(2)==j ) then
            iind(1)=i+1; jind(1)=j
            iind(2)=i  ; jind(2)=j
            iind(3)=i  ; jind(3)=j+1
            iind(4)=i+1; jind(4)=j+1
         elseif ( isorted(2)==i+1 .and. jsorted(2)==j+1 ) then
            iind(1)=i+1; jind(1)=j
            iind(2)=i+1; jind(2)=j+1
            iind(3)=i  ; jind(3)=j+1
            iind(4)=i  ; jind(4)=j  
         endif
         
      endif

    end subroutine sort_rectangle
    !------------------------------------------------------------------!
  end subroutine sorted_inta
  ! </SUBROUTINE> NAME="sorted_inta"
  !#####################################################################
  ! <SUBROUTINE NAME="sorted_intb">
  !
  ! <DESCRIPTION>
  ! Sort cell corner indices in latlon space based on grid locations 
  ! in index space. If not cubed_sphere assume orientations in index 
  ! and latlon space are identical.
  !
  ! i/jinta are indices of b-grid locations needed for line integrals 
  ! around an a-grid cell including ghosting.
  !
  ! i/jintb are indices of a-grid locations needed for line integrals
  ! around a b-grid cell, no ghosting.
  ! </DESCRIPTION>
  !
  subroutine sorted_intb(isd, ied, jsd, jed, is, ie, js, je, npx, npy, &
                          cubed_sphere, agrid, iintb, jintb)

    integer, intent(in) :: isd, ied, jsd, jed, is, ie, js, je, npx, npy
    real,    intent(in), dimension(isd:ied,jsd:jed,2) :: agrid
    logical, intent(in) :: cubed_sphere

    integer, dimension(4,is:ie+1,js:je+1), intent(out) :: iintb, jintb
    !------------------------------------------------------------------!
    ! local variables                                                  !
    !------------------------------------------------------------------!
    real,    dimension(4) :: xsort, ysort, xsorted, ysorted 
    integer, dimension(4) :: isort, jsort, isorted, jsorted
    integer :: i, j, l, ll, lll
    !------------------------------------------------------------------!
    ! special treatment for cubed sphere                               !
    !------------------------------------------------------------------!
    if (cubed_sphere) then
       !---------------------------------------------------------------!
       ! get order of indices for line integral around b-grid cell     ! 
       !---------------------------------------------------------------!
       do j=js,je+1
          do i=is,ie+1
             xsort(1)=agrid(i  ,j  ,1); ysort(1)=agrid(i  ,j  ,2); isort(1)=i  ; jsort(1)=j
             xsort(2)=agrid(i  ,j-1,1); ysort(2)=agrid(i  ,j-1,2); isort(2)=i  ; jsort(2)=j-1
             xsort(3)=agrid(i-1,j-1,1); ysort(3)=agrid(i-1,j-1,2); isort(3)=i-1; jsort(3)=j-1
             xsort(4)=agrid(i-1,j  ,1); ysort(4)=agrid(i-1,j  ,2); isort(4)=i-1; jsort(4)=j
             call sort_rectangle(iintb(1,i,j), jintb(1,i,j))
          enddo
       enddo
       !---------------------------------------------------------------!
       ! take care of corner points                                    !
       !---------------------------------------------------------------!
       if ( (is==1) .and. (js==1) ) then
          i=1
          j=1
          xsort(1)=agrid(i  ,j  ,1); ysort(1)=agrid(i  ,j  ,2); isort(1)=i  ; jsort(1)=j  
          xsort(2)=agrid(i  ,j-1,1); ysort(2)=agrid(i  ,j-1,2); isort(2)=i  ; jsort(2)=j-1
          xsort(3)=agrid(i-1,j  ,1); ysort(3)=agrid(i-1,j  ,2); isort(3)=i-1; jsort(3)=j
          call sort_triangle()
          iintb(4,i,j)=i-1; jintb(4,i,j)=j-1
       endif

       if ( (ie+1==npx) .and. (js==1) ) then
          i=npx
          j=1
          xsort(1)=agrid(i  ,j  ,1); ysort(1)=agrid(i  ,j  ,2); isort(1)=i  ; jsort(1)=j
          xsort(2)=agrid(i-1,j  ,1); ysort(2)=agrid(i-1,j  ,2); isort(2)=i-1; jsort(2)=j
          xsort(3)=agrid(i-1,j-1,1); ysort(3)=agrid(i-1,j-1,2); isort(3)=i-1; jsort(3)=j-1
          call sort_triangle()
          iintb(4,i,j)=i; jintb(4,i,j)=j-1
       endif

       if ( (ie+1==npx) .and. (je+1==npy) ) then
          i=npx
          j=npy
          xsort(1)=agrid(i-1,j-1,1); ysort(1)=agrid(i-1,j-1,2); isort(1)=i-1; jsort(1)=j-1
          xsort(2)=agrid(i  ,j-1,1); ysort(2)=agrid(i  ,j-1,2); isort(2)=i  ; jsort(2)=j-1
          xsort(3)=agrid(i-1,j  ,1); ysort(3)=agrid(i-1,j  ,2); isort(3)=i-1; jsort(3)=j
          call sort_triangle()
          iintb(4,i,j)=i; jintb(4,i,j)=j
       endif
       
       if ( (is==1) .and. (je+1==npy) ) then
          i=1
          j=npy
          xsort(1)=agrid(i  ,j  ,1); ysort(1)=agrid(i  ,j  ,2); isort(1)=i  ; jsort(1)=j
          xsort(2)=agrid(i-1,j-1,1); ysort(2)=agrid(i-1,j-1,2); isort(2)=i-1; jsort(2)=j-1
          xsort(3)=agrid(i  ,j-1,1); ysort(3)=agrid(i  ,j-1,2); isort(3)=i  ; jsort(3)=j-1
          call sort_triangle()
          iintb(4,i,j)=i-1; jintb(4,i,j)=j
       endif
    else
       !---------------------------------------------------------------!
       ! default behavior for other grids                              !
       !---------------------------------------------------------------!
       do j=js,je+1
          do i=is,ie+1
             iintb(1,i,j)=i  ; jintb(1,i,j)=j
             iintb(2,i,j)=i  ; jintb(2,i,j)=j-1
             iintb(3,i,j)=i-1; jintb(3,i,j)=j-1
             iintb(4,i,j)=i-1; jintb(4,i,j)=j  
          enddo
       enddo
    endif

  contains
    !------------------------------------------------------------------!
    subroutine sort_rectangle(iind, jind)

      integer, dimension(4), intent(inout) :: iind, jind
      !----------------------------------------------------------------!
      ! local variables                                                !
      !----------------------------------------------------------------!
      real,    dimension(4) :: xsorted, ysorted 
      integer, dimension(4) :: isorted, jsorted
      !----------------------------------------------------------------!
      ! sort in east west                                              !
      !----------------------------------------------------------------!
      xsorted(:)=10.
      ysorted(:)=10.
      isorted(:)=0
      jsorted(:)=0
             
      do l=1,4
         do ll=1,4
            if (xsort(l)<xsorted(ll)) then
               do lll=3,ll,-1
                  xsorted(lll+1)=xsorted(lll)
                  ysorted(lll+1)=ysorted(lll)
                  isorted(lll+1)=isorted(lll)
                  jsorted(lll+1)=jsorted(lll)
               enddo
               xsorted(ll)=xsort(l)
               ysorted(ll)=ysort(l)
               isorted(ll)=isort(l)
               jsorted(ll)=jsort(l)
               exit
            endif
         enddo
      enddo
      !----------------------------------------------------------------!
      ! sort in north south                                            !
      !----------------------------------------------------------------!
      do l=1,4
         xsort(l)=xsorted(l); ysort(l)=ysorted(l)
         isort(l)=isorted(l); jsort(l)=jsorted(l)
      enddo
      xsorted(:)=10.
      ysorted(:)=10.
      isorted(:)=0
      jsorted(:)=0
      
      do l=1,4
         do ll=1,4
            if (ysort(l)<ysorted(ll)) then
               do lll=3,ll,-1
                  xsorted(lll+1)=xsorted(lll)
                  ysorted(lll+1)=ysorted(lll)
                  isorted(lll+1)=isorted(lll)
                  jsorted(lll+1)=jsorted(lll)
               enddo
               xsorted(ll)=xsort(l)
               ysorted(ll)=ysort(l)
               isorted(ll)=isort(l)
               jsorted(ll)=jsort(l)
               exit
            endif
         enddo
      enddo
      !----------------------------------------------------------------!
      ! use first two grid point for start and orientation             !
      !----------------------------------------------------------------!
      if ( isorted(1)==i .and. jsorted(1)==j ) then
         if ( isorted(2)==i-1 .and. jsorted(2)==j-1 ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i   .and. jsorted(2)==j-1 ) then
            iind(1)=i  ; jind(1)=j
            iind(2)=i  ; jind(2)=j-1
            iind(3)=i-1; jind(3)=j-1
            iind(4)=i-1; jind(4)=j  
         elseif ( isorted(2)==i-1 .and. jsorted(2)==j ) then
            iind(1)=i  ; jind(1)=j
            iind(2)=i-1; jind(2)=j
            iind(3)=i-1; jind(3)=j-1
            iind(4)=i  ; jind(4)=j-1
         endif
         
      elseif ( isorted(1)==i .and. jsorted(1)==j-1 ) then
         if ( isorted(2)==i-1 .and. jsorted(2)==j ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i-1 .and. jsorted(2)==j-1 ) then
            iind(1)=i  ; jind(1)=j-1
            iind(2)=i-1; jind(2)=j-1
            iind(3)=i-1; jind(3)=j
            iind(4)=i  ; jind(4)=j  
         elseif ( isorted(2)==i   .and. jsorted(2)==j ) then
            iind(1)=i  ; jind(1)=j-1
            iind(2)=i  ; jind(2)=j
            iind(3)=i-1; jind(3)=j
            iind(4)=i-1; jind(4)=j-1
         endif
         
      elseif ( isorted(1)==i-1 .and. jsorted(1)==j-1 ) then
         if ( isorted(2)==i .and. jsorted(2)==j ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i-1 .and. jsorted(2)==j ) then
            iind(1)=i-1; jind(1)=j-1
            iind(2)=i-1; jind(2)=j
            iind(3)=i  ; jind(3)=j
            iind(4)=i  ; jind(4)=j-1  
         elseif ( isorted(2)==i   .and. jsorted(2)==j-1 ) then
            iind(1)=i-1; jind(1)=j-1
            iind(2)=i  ; jind(2)=j-1
            iind(3)=i  ; jind(3)=j
            iind(4)=i-1; jind(4)=j
         endif
         
      elseif ( isorted(1)==i-1 .and. jsorted(1)==j ) then
         if ( isorted(2)==i .and. jsorted(2)==j-1 ) then
            isorted(2)=isorted(3); jsorted(2)=jsorted(3)
         endif
         if ( isorted(2)==i   .and. jsorted(2)==j ) then
            iind(1)=i-1; jind(1)=j
            iind(2)=i  ; jind(2)=j
            iind(3)=i  ; jind(3)=j-1
            iind(4)=i-1; jind(4)=j-1
         elseif ( isorted(2)==i-1 .and. jsorted(2)==j-1 ) then
            iind(1)=i-1; jind(1)=j
            iind(2)=i-1; jind(2)=j-1
            iind(3)=i  ; jind(3)=j-1
            iind(4)=i  ; jind(4)=j  
         endif
         
      endif

    end subroutine sort_rectangle
    !------------------------------------------------------------------!
    subroutine sort_triangle()

      xsorted(1:3)=10.
      ysorted(1:3)=10.
      isorted(1:3)=0
      jsorted(1:3)=0
      !----------------------------------------------------------------!
      ! sort in east west                                              !
      !----------------------------------------------------------------!
      do l=1,3
         do ll=1,3
            if (xsort(l)<xsorted(ll)) then
               do lll=2,ll,-1
                  xsorted(lll+1)=xsorted(lll)
                  ysorted(lll+1)=ysorted(lll)
                  isorted(lll+1)=isorted(lll)
                  jsorted(lll+1)=jsorted(lll)
               enddo
               xsorted(ll)=xsort(l)
               ysorted(ll)=ysort(l)
               isorted(ll)=isort(l)
               jsorted(ll)=jsort(l)
               exit
            endif
         enddo
      enddo
      !----------------------------------------------------------------!
      ! sort in north south                                            !
      !----------------------------------------------------------------!
      do l=1,3
         xsort(l)=xsorted(l); ysort(l)=ysorted(l)
         isort(l)=isorted(l); jsort(l)=jsorted(l)
      enddo
      xsorted(1:3)=10.
      ysorted(1:3)=10.
      isorted(1:3)=0
      jsorted(1:3)=0
      
      do l=1,3
         do ll=1,3
            if (ysort(l)<ysorted(ll)) then
               do lll=2,ll,-1
                  xsorted(lll+1)=xsorted(lll)
                  ysorted(lll+1)=ysorted(lll)
                  isorted(lll+1)=isorted(lll)
                  jsorted(lll+1)=jsorted(lll)
               enddo
               xsorted(ll)=xsort(l)
               ysorted(ll)=ysort(l)
               isorted(ll)=isort(l)
               jsorted(ll)=jsort(l)
               exit
            endif
         enddo
      enddo
      !----------------------------------------------------------------!
      ! use first two grid point for start and orientation             !
      !----------------------------------------------------------------!
      iintb(1,i,j)=isorted(1) ; jintb(1,i,j)=jsorted(1)
      iintb(2,i,j)=isorted(2) ; jintb(2,i,j)=jsorted(2)
      iintb(3,i,j)=isorted(3) ; jintb(3,i,j)=jsorted(3)
   
    end subroutine sort_triangle
    !------------------------------------------------------------------!
  end subroutine sorted_intb
  ! </SUBROUTINE> NAME="sorted_intb"
  !#####################################################################
end module sorted_index_mod


 module test_cases_mod

      use constants_mod,     only: radius, pi, omega, grav, kappa, rdgas, cp_air
      use init_hydro_mod,    only: p_var, hydro_eq
      use fv_mp_mod,         only: gid, masterproc, domain, tile, ng,         &
                                   is,js,ie,je, isd,jsd,ied,jed, &
                                   domain_decomp, fill_corners, XDir, YDir, &
                                   mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst
      use fv_grid_utils_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere,   &
                                   ptop, ptop_min, fC, f0, deglat, inner_prod, normalize_vect, &
                                   ee1, ee2, ew, es, g_sum, latlon2xyz, cart_to_latlon
      use fv_surf_map_mod,   only: surfdrv

      use fv_grid_tools_mod, only: grid, agrid, cubed_sphere, latlon,  todeg, missing,  &
                                   dx,dy, dxa,dya, rdxa, rdya, dxc,dyc, area, rarea,rarea_c, &
                                   ctoa, atod, dtoa, atoc, atob_s, mp_update_dwinds, rotate_winds, &
                                   globalsum, get_unit_vector, unit_vect2,                         &
                                   dx_const, dy_const
      use fv_eta_mod,        only: compute_dz_L32, set_hybrid_z, gw_1d

      use mpp_mod,           only: mpp_error, FATAL
      use mpp_domains_mod,   only: mpp_update_domains
      use mpp_parameter_mod, only: AGRID_PARAM=>AGRID,CGRID_NE_PARAM=>CGRID_NE, &
                                   SCALAR_PAIR
!     use fv_diagnostics_mod,  only: prt_maxmin

      implicit none
      private

! Test Case Number  
!                   -1 = Divergence conservation test
!                    0 = Idealized non-linear deformational flow
!                    1 = Cosine Bell advection
!                    2 = Zonal geostrophically balanced flow
!                    3 = non-rotating potential flow 
!                    4 = Tropical cyclones (merger of Rankine vortices)
!                    5 = Zonal geostrophically balanced flow over an isolated mountain
!                    6 = Rossby Wave number 4 
!                    7 = Barotropic instability
!                    8 = Potential flow (as in 5 but no rotation and initially at rest)
!                    9 = Polar vortex
!                   10 = hydrostatically balanced 3D test with idealized mountain
!                   11 = Use this for cold starting the climate model with USGS terrain
!                   12 = Jablonowski & Williamson Baroclinic test case (Steady State)
!                   13 = Jablonowski & Williamson Baroclinic test case Perturbation
!                   14 = Use this for cold starting the Aqua-planet model
!                   15 = Small Earth density current
!                   16 = 3D hydrostatic non-rotating Gravity waves
!                   17 = 3D hydrostatic rotating Inertial Gravity waves (case 6-3-0)
!                   18 = 3D mountain-induced Rossby wave
!                   19 = As in 15 but without rotation
!                   20 = 3D non-hydrostatic lee vortices; non-rotating (small planet)
!                   21 = 3D non-hydrostatic lee vortices; rotating     (small planet)
      integer :: test_case
! alpha = angle of axis rotation about the poles
      real   :: alpha = 0.
! Ubar = initial wind speed parameter
      real   :: Ubar
! gh0 = initial surface height parameter
      real   :: gh0

! Case 0 parameters
      real :: p0 = 3.0
      real :: rgamma = 5.0
      real :: lat0 = pi/2.0 !pi/4.8
      real :: lon0 = 0.0 !pi-0.8

!  pi_shift moves the initial location of the cosine bell for Case 1
      real, parameter :: pi_shift = 0.0 !3.0*pi/4.

!  case 9 parameters 
      real  , allocatable :: case9_B(:,:)
      real   :: AofT(2)

!  Validating fields used in statistics
      real  , allocatable :: phi0(:,:,:) ! Validating Field
      real  , allocatable :: ua0(:,:,:)  ! Validating U-Wind
      real  , allocatable :: va0(:,:,:)  ! Validating V-Wind
      real  , allocatable :: gh_table(:), lats_table(:)

!  Initial Conservation statistics ; total mass ; enstrophy ; energy
      real   :: tmass_orig
      real   :: tvort_orig
      real   :: tener_orig

 ! -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
      integer, parameter :: initWindsCase0 =-1 
      integer, parameter :: initWindsCase1 = 1
      integer, parameter :: initWindsCase2 = 5 
      integer, parameter :: initWindsCase5 = 5
      integer, parameter :: initWindsCase6 =-1 
      integer, parameter :: initWindsCase9 =-1

      public :: test_case, alpha
      public :: init_case, get_stats, check_courant_numbers, output, output_ncdf
      public :: case9_forcing1, case9_forcing2
      public :: init_double_periodic, init_latlon

      contains

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     init_winds :: initialize the winds 
!
      subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions)
 ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate

      real  ,    intent(INOUT) :: UBar
      real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1)
      real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  )
      real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  )
      real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1)
      real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  )
      real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  )
      integer,      intent(IN) :: defOnGrid
      integer,      intent(IN) :: npx, npy
      integer,      intent(IN) :: ng
      integer,      intent(IN) :: ndims
      integer,      intent(IN) :: nregions

      real   :: p1(2),p2(2),p3(2),p4(2), pt(2)
      real :: e1(3), e2(3), ex(3), ey(3)

      real   :: dist, r, r0 
      integer :: i,j,k,n
      real :: utmp, vtmp

      real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2 

 200  format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)

      psi(:,:) = 1.e25
      psi_b(:,:) = 1.e25
      do j=jsd,jed
         do i=isd,ied
            psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2))                  *cos(alpha) - &
                                            cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
         enddo
      enddo
      call mpp_update_domains( psi, domain )
      do j=jsd,jed+1
         do i=isd,ied+1
            psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2))                 *cos(alpha) - &
                                              cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
         enddo
      enddo

      if ( (cubed_sphere) .and. (defOnGrid==0) ) then
         do j=js,je+1
            do i=is,ie
               dist = dx(i,j)
               vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
               if (dist==0) vc(i,j) = 0.
            enddo
         enddo
         do j=js,je
            do i=is,ie+1
               dist = dy(i,j)
               uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
               if (dist==0) uc(i,j) = 0.
            enddo
         enddo
         call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
         call fill_corners(uc, vc, npx, npy, VECTOR=.true., CGRID=.true.)
         do j=js,je
            do i=is,ie+1
               dist = dxc(i,j)
               v(i,j) = (psi(i,j)-psi(i-1,j))/dist
               if (dist==0) v(i,j) = 0.
            enddo
         enddo
         do j=js,je+1
            do i=is,ie
               dist = dyc(i,j)
               u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
               if (dist==0) u(i,j) = 0.
            enddo
         enddo
         call mp_update_dwinds(u, v, npx, npy)
         do j=js,je
            do i=is,ie
               psi1 = 0.5*(psi(i,j)+psi(i,j-1))
               psi2 = 0.5*(psi(i,j)+psi(i,j+1))
               dist = dya(i,j)
               ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
               if (dist==0) ua(i,j) = 0.
               psi1 = 0.5*(psi(i,j)+psi(i-1,j))
               psi2 = 0.5*(psi(i,j)+psi(i+1,j))
               dist = dxa(i,j)
               va(i,j) = (psi2 - psi1) / (dist)
               if (dist==0) va(i,j) = 0.
            enddo
         enddo

      elseif ( (cubed_sphere) .and. (defOnGrid==1) ) then
         do j=js,je+1
            do i=is,ie
               dist = dx(i,j)
               vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
               if (dist==0) vc(i,j) = 0.
            enddo
         enddo
         do j=js,je
            do i=is,ie+1
               dist = dy(i,j)
               uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
               if (dist==0) uc(i,j) = 0.
            enddo
         enddo
         call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
         call fill_corners(uc, vc, npx, npy, VECTOR=.true., CGRID=.true.)
         call ctoa(uc,vc,ua,va,npx,npy,ng)
         call atod(ua,va,u ,v ,npx,npy,ng)
        ! call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd),v(isd,jsd), &
        !            ua(isd,jsd),va(isd,jsd), uc(isd,jsd),vc(isd,jsd))
      elseif ( (cubed_sphere) .and. (defOnGrid==2) ) then
         do j=js,je
            do i=is,ie+1
               dist = dxc(i,j)
               v(i,j) = (psi(i,j)-psi(i-1,j))/dist
               if (dist==0) v(i,j) = 0.            
            enddo
         enddo
         do j=js,je+1
            do i=is,ie
               dist = dyc(i,j)
               u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
               if (dist==0) u(i,j) = 0. 
            enddo
         enddo
         call mp_update_dwinds(u, v, npx, npy)
         call dtoa( u, v,ua,va,npx,npy,ng)
         call atoc(ua,va,uc,vc,npx,npy,ng) 
      elseif ( (cubed_sphere) .and. (defOnGrid==3) ) then
         do j=js,je
            do i=is,ie
               psi1 = 0.5*(psi(i,j)+psi(i,j-1))
               psi2 = 0.5*(psi(i,j)+psi(i,j+1))
               dist = dya(i,j)
               ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
               if (dist==0) ua(i,j) = 0.
               psi1 = 0.5*(psi(i,j)+psi(i-1,j))
               psi2 = 0.5*(psi(i,j)+psi(i+1,j))
               dist = dxa(i,j)
               va(i,j) = (psi2 - psi1) / (dist)
               if (dist==0) va(i,j) = 0.
            enddo
         enddo
         call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
         call atod(ua,va, u, v,npx,npy,ng)
         call atoc(ua,va,uc,vc,npx,npy,ng)
      elseif ( (latlon) .or. (defOnGrid==4) ) then

         do j=js,je
            do i=is,ie
               ua(i,j) =  Ubar * ( COS(agrid(i,j,2))*COS(alpha) + &
                                     SIN(agrid(i,j,2))*COS(agrid(i,j,1))*SIN(alpha) )
               va(i,j) = -Ubar *   SIN(agrid(i,j,1))*SIN(alpha)  
               call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
               call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
               call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
               call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
               if (cubed_sphere) call rotate_winds(ua(i,j), va(i,j), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)

               psi1 = 0.5*(psi(i,j)+psi(i,j-1))
               psi2 = 0.5*(psi(i,j)+psi(i,j+1))
               dist = dya(i,j)
    if ( (tile==1) .and.(i==1) ) print*, ua(i,j), -1.0 * (psi2 - psi1) / (dist)

            enddo
         enddo
         call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
         call atod(ua,va, u, v,npx,npy,ng)
         call atoc(ua,va,uc,vc,npx,npy,ng)

     elseif ( (latlon) .or. (defOnGrid==5) ) then
! SJL mods:
! v-wind:
         do j=js,je
            do i=is,ie+1
               p1(:) = grid(i  ,j ,1:2)
               p2(:) = grid(i,j+1 ,1:2)
               call mid_pt_sphere(p1, p2, pt)
               call get_unit_vector(p1, p2, e2)
!              call unit_vect2(p1, p2, e2)
               call get_latlon_vector(pt, ex, ey)
               utmp =  Ubar * ( COS(pt(2))*COS(alpha) + &
                                SIN(pt(2))*COS(pt(1))*SIN(alpha) )
               vtmp = -Ubar *   SIN(pt(1))*SIN(alpha)
               v(i,j) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
            enddo
         enddo
! D grid u-wind:
         do j=js,je+1
            do i=is,ie
               p1(:) = grid(i  ,j  ,1:2)
               p2(:) = grid(i+1,j  ,1:2)
               call mid_pt_sphere(p1, p2, pt)
               call get_unit_vector(p1, p2, e1)
!              call unit_vect2(p1, p2, e1)
               call get_latlon_vector(pt, ex, ey)
               utmp =  Ubar * ( COS(pt(2))*COS(alpha) + &
                                SIN(pt(2))*COS(pt(1))*SIN(alpha) )
               vtmp = -Ubar *   SIN(pt(1))*SIN(alpha)
               u(i,j) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
            enddo
         enddo

         call mp_update_dwinds(u, v, npx, npy)
         call dtoa( u, v,ua,va,npx,npy,ng)
         call atoc(ua,va,uc,vc,npx,npy,ng)
     else
         !print*, 'Choose an appropriate grid to define the winds on'
         !stop
     endif

      end subroutine init_winds
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     init_case :: initialize the Williamson test cases:
!                  case 1 (2-D advection of a cosine bell)
!                  case 2 (Steady State Zonal Geostrophic Flow)
!                  case 5 (Steady State Zonal Geostrophic Flow over Mountain)
!                  case 6 (Rossby Wave-4 Case)
!                  case 9 (Stratospheric Vortex Breaking Case)
!
      subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz,  uc,vc, ua,va, ak, bk,  &
                           npx, npy, npz, ng, ncnst, nwat, k_top, ndims, nregions,        &
                           dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0)

      real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1,npz)
      real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  ,npz)
      real ,      intent(INOUT) ::    w(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   pt(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) :: delp(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::    q(isd:ied  ,jsd:jed  ,npz, ncnst)

      real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )

      real ,      intent(INOUT) ::   ps(isd:ied  ,jsd:jed  )
      real ,      intent(INOUT) ::   pe(is-1:ie+1,npz+1,js-1:je+1)
      real ,      intent(INOUT) ::   pk(is:ie    ,js:je    ,npz+1)
      real ,      intent(INOUT) :: peln(is :ie   ,npz+1    ,js:je)
      real ,      intent(INOUT) ::  pkz(is:ie    ,js:je    ,npz  )

      real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1,npz)
      real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(inout) :: delz(is:ie,js:je,npz)
      real ,      intent(inout)   ::  ze0(is:ie,js:je,npz+1)

      real ,      intent(inout) ::   ak(npz+1)
      real ,      intent(inout) ::   bk(npz+1)

      integer,      intent(IN) :: npx, npy, npz
      integer,      intent(IN) :: ng, ncnst, nwat
      integer,      intent(IN) :: k_top
      integer,      intent(IN) :: ndims
      integer,      intent(IN) :: nregions

      real,         intent(IN) :: dry_mass
      logical,      intent(IN) :: mountain
      logical,      intent(IN) :: moist_phys
      logical,      intent(IN) :: hydrostatic
      logical,      intent(IN) :: hybrid_z

      real   ::  tmp(1-ng:npx  +ng,1-ng:npy  +ng,1:nregions)
      real   :: tmp1(1   :npx     ,1   :npy     ,1:nregions)

      real   :: p1(2)      ! Temporary Point
      real   :: p2(2)      ! Temporary Point
      real   :: p3(2)      ! Temporary Point
      real   :: p4(2)      ! Temporary Point
      real   :: pa(2)      ! Temporary Point
      real   :: pb(2)      ! Temporary Point
      real   :: pcen(2)    ! Temporary Point
      real   :: e1(3), e2(3), e3(3), ex(3), ey(3)
      real   :: dist, r, r0, omg, A, B, C
      integer :: i,j,k,nreg,z,zz
      integer :: i0,j0,n0
      real   :: utmp,vtmp,ftmp
      real   :: rk

      integer, parameter :: jm = 5761
      real   :: ll_phi(jm)
      real   ::   ll_u(jm)
      real   ::   ll_j(jm)
      real   ::   cose(jm)
      real   ::   sine(jm)
      real   ::   cosp(jm)
      real   :: ddeg, deg, DDP, DP, ph5
      real   :: myB, myC, yy
      integer   :: jj,jm1

      real :: Vtx, p, w_p
      real :: x1,y1,z1,x2,y2,z2,ang

      integer :: initWindsCase

      real :: dummy
      real :: ftop
      real :: v1,v2
      real :: m=1
      real :: n=1
      real :: L1_norm
      real :: L2_norm
      real :: Linf_norm
      real :: pmin, pmin1
      real :: pmax, pmax1
      real :: grad(isd:ied  ,jsd:jed,2)
      real :: div0(isd:ied  ,jsd:jed  ) 
      real :: vor0(isd:ied  ,jsd:jed  )
      real :: divg(isd:ied  ,jsd:jed  )
      real :: vort(isd:ied  ,jsd:jed  )
      real :: ztop, rgrav, p00, pturb, zmid, pk0, t00
      real :: dz1(npz), ppt(npz)
      real :: ze1(npz+1), pe1(npz+1)

      integer :: nlon,nlat
      character(len=80) :: oflnm, hgtflnm

! Baroclinic Test Case 12
      real :: eta, eta_0, eta_s, eta_t
      real :: eta_v(npz), press, anti_rot
      real :: T_0, T_mean, delta_T, lapse_rate, n2, zeta, s0
      real :: pt1,pt2,pt3,pt4,pt5,pt6, pt7, pt8, pt9, u1, pt0
      real :: uu1, uu2, uu3, vv1, vv2, vv3
!     real wbuffer(npx+1,npz)
!     real sbuffer(npy+1,npz)
      real wbuffer(npy+2,npz)
      real sbuffer(npx+2,npz)

      allocate ( phi0(isd:ied  ,jsd:jed  ,npz) )
      allocate (  ua0(isd:ied  ,jsd:jed  ,npz) )
      allocate (  va0(isd:ied  ,jsd:jed  ,npz) )

      pe(:,:,:) = 0.0
      pt(:,:,:) = 1.0
      f0(:,:) = huge(dummy)
      fC(:,:) = huge(dummy)
      do j=jsd,jed+1
         do i=isd,ied+1
            fC(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
                                     sin(grid(i,j,2))*cos(alpha) )
         enddo
      enddo
      do j=jsd,jed
         do i=isd,ied
            f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
                                     sin(agrid(i,j,2))*cos(alpha) )
         enddo
      enddo
      call mpp_update_domains( f0, domain )
      if (cubed_sphere) call fill_corners(f0, npx, npy, YDir)

      delp(isd:is-1,jsd:js-1,1:npz)=0.
      delp(isd:is-1,je+1:jed,1:npz)=0.
      delp(ie+1:ied,jsd:js-1,1:npz)=0.
      delp(ie+1:ied,je+1:jed,1:npz)=0.

#if defined(SW_DYNAMICS)
      select case (test_case)
      case(-2)
      case(-1)
         Ubar = (2.0*pi*radius)/(12.0*86400.0)
         gh0  = 2.94e4
         phis = 0.0
         do j=js,je
            do i=is,ie
               delp(i,j,1) = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(agrid(i  ,j  ,1))*cos(agrid(i  ,j  ,2))*sin(alpha) + &
                                   sin(agrid(i  ,j  ,2))*cos(alpha) ) ** 2.0
            enddo
         enddo
         call init_winds(UBar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions)

! Test Divergence operator at cell centers
         do j=js,je
            do i=is,ie
               divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
                                            (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
      if ( (tile==1) .and. (i==1) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
            enddo
         enddo
! Test Vorticity operator at cell centers
         do j=js,je
            do i=is,ie
               vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
                                            (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
           enddo
        enddo
        div0(:,:) = 1.e-20
     ! call mpp_update_domains( div0, domain )
     ! call mpp_update_domains( vor0, domain )
     ! call mpp_update_domains( divg, domain )
     ! call mpp_update_domains( vort, domain )
      call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
                             pmin, pmax, L1_norm, L2_norm, Linf_norm)
 200  format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
 201  format('          ',A,e21.14,' ',e21.14)
 202  format('          ',A,i4.4,'x',i4.4,'x',i4.4)
      if ( (gid == masterproc) ) then
          write(*,*) ' Error Norms of Analytical Divergence field C-Winds initialized'
          write(*,201) 'Divergence MAX error     : ', pmax
          write(*,201) 'Divergence MIN error     : ', pmin
          write(*,201) 'Divergence L1_norm       : ', L1_norm
          write(*,201) 'Divergence L2_norm       : ', L2_norm
          write(*,201) 'Divergence Linf_norm     : ', Linf_norm
      endif 

         call init_winds(UBar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions)
! Test Divergence operator at cell centers
         do j=js,je
            do i=is,ie
               divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
                                            (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
      if ( (tile==1) .and. (i==1) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
            enddo
         enddo
! Test Vorticity operator at cell centers
         do j=js,je
            do i=is,ie
               vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
                                            (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
           enddo
        enddo
        ua0 = ua
        va0 = va
        div0(:,:) = 1.e-20
      call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
                             pmin, pmax, L1_norm, L2_norm, Linf_norm)
      if ( (gid == masterproc) ) then
          write(*,*) ' Error Norms of Analytical Divergence field A-Winds initialized'
          write(*,201) 'Divergence MAX error     : ', pmax
          write(*,201) 'Divergence MIN error     : ', pmin
          write(*,201) 'Divergence L1_norm       : ', L1_norm
          write(*,201) 'Divergence L2_norm       : ', L2_norm
          write(*,201) 'Divergence Linf_norm     : ', Linf_norm
      endif

         call init_winds(UBar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions)
         !call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd,1),v(isd,jsd,1), &
         !           ua(isd,jsd,1),va(isd,jsd,1), uc(isd,jsd,1),vc(isd,jsd,1))
! Test Divergence operator at cell centers
         do j=js,je
            do i=is,ie
               divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
                                            (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
      if ( (tile==1) .and. ((i==1) .or.(i==npx-1)) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
            enddo
         enddo
! Test Vorticity operator at cell centers
         do j=js,je
            do i=is,ie
               vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
                                            (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
           enddo
        enddo
        div0(:,:) = 1.e-20
      call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
                             pmin, pmax, L1_norm, L2_norm, Linf_norm)
      if ( (gid == masterproc) ) then
          write(*,*) ' Error Norms of Analytical Divergence field D-Winds initialized'
          write(*,201) 'Divergence MAX error     : ', pmax
          write(*,201) 'Divergence MIN error     : ', pmin
          write(*,201) 'Divergence L1_norm       : ', L1_norm
          write(*,201) 'Divergence L2_norm       : ', L2_norm
          write(*,201) 'Divergence Linf_norm     : ', Linf_norm
      endif

      call mp_stop()
      stop
      case(0)
         do j=jsd,jed
            do i=isd,ied

               x1 = agrid(i,j,1) 
               y1 = agrid(i,j,2)
               z1 = radius

               p = p0 * cos(y1)
               Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
               w_p = 0.0
               if (p /= 0.0) w_p = Vtx/p 
               delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*0.0) )
               ua(i,j,1) = w_p*(sin(lat0)*cos(agrid(i,j,2)) + cos(lat0)*cos(agrid(i,j,1) - lon0)*sin(agrid(i,j,2)))
               va(i,j,1) = w_p*cos(lat0)*sin(agrid(i,j,1) - lon0)
               ua(i,j,1) = ua(i,j,1)*radius/86400.0
               va(i,j,1) = va(i,j,1)*radius/86400.0

               call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
               call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
               call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
               call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)      
               if (cubed_sphere) call rotate_winds(ua(i,j,1),va(i,j,1), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)

            enddo
         enddo
         call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
         call atod(ua,va, u, v,npx,npy,ng)
         call mp_update_dwinds(u, v, npx, npy, npz)
         call atoc(ua,va,uc,vc,npx,npy,ng)
         call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
         call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.)
         initWindsCase=initWindsCase0
      case(1)
         Ubar = (2.0*pi*radius)/(12.0*86400.0)
         gh0  = 1.0
         phis = 0.0
         r0 = radius/3. !RADIUS radius/3.
         p1(1) = pi/2. + pi_shift
         p1(2) = 0.
         do j=jsd,jed
            do i=isd,ied
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = great_circle_dist( p1, p2, radius )
               if (r < r0) then
                  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
               else
                  delp(i,j,1) = phis(i,j)
               endif
            enddo
         enddo
         initWindsCase=initWindsCase1
      case(2)
         Ubar = (2.0*pi*radius)/(12.0*86400.0)
         gh0  = 2.94e4
         phis = 0.0
         do j=js,je
            do i=is,ie
#ifdef FIVE_AVG
               pt5 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(agrid(i  ,j  ,1))*cos(agrid(i  ,j  ,2))*sin(alpha) + &
                                   sin(agrid(i  ,j  ,2))*cos(alpha) ) ** 2.0
               pt1 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(grid(i  ,j  ,1))*cos(grid(i  ,j  ,2))*sin(alpha) + &
                                   sin(grid(i  ,j  ,2))*cos(alpha) ) ** 2.0
               pt2 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(grid(i+1,j  ,1))*cos(grid(i+1,j  ,2))*sin(alpha) + &
                                   sin(grid(i+1,j  ,2))*cos(alpha) ) ** 2.0
               pt3 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(grid(i+1,j+1,1))*cos(grid(i+1,j+1,2))*sin(alpha) + &
                                   sin(grid(i+1,j+1,2))*cos(alpha) ) ** 2.0
               pt4 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(grid(i,j+1,1))*cos(grid(i,j+1,2))*sin(alpha) + &
                                   sin(grid(i,j+1,2))*cos(alpha) ) ** 2.0
               delp(i,j,1) = (0.25*(pt1+pt2+pt3+pt4) + 3.*pt5) / 4.
#else
               delp(i,j,1) = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(agrid(i  ,j  ,1))*cos(agrid(i  ,j  ,2))*sin(alpha) + &
                                   sin(agrid(i  ,j  ,2))*cos(alpha) ) ** 2.0
#endif
            enddo
         enddo
         initWindsCase=initWindsCase2
      case(3)
!----------------------------
! Non-rotating potential flow
!----------------------------
#ifdef NO_WIND
         ubar = 0.
#else
         ubar = 40.
#endif
         gh0  = 1.0e3 * grav
         phis = 0.0
         r0 = radius/3. !RADIUS radius/3.
         p1(1) = pi*1.5
         p1(2) = 0.
         do j=jsd,jed
            do i=isd,ied
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = great_circle_dist( p1, p2, radius )
               if (r < r0) then
                  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
               else
                  delp(i,j,1) = phis(i,j)
               endif
! Add a constant:
               delp(i,j,1) = delp(i,j,1) + grav*2.e3
            enddo
         enddo

#ifdef NO_WIND
         u  = 0.;   v = 0.
         f0 = 0.;  fC = 0.
#else

         do j=js,je
            do i=is,ie+1
               p1(:) = grid(i  ,j ,1:2)
               p2(:) = grid(i,j+1 ,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e2)
               call get_latlon_vector(p3, ex, ey)
               utmp = ubar * cos(p3(2))
               vtmp = 0.
               v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
            enddo
         enddo
         do j=js,je+1
            do i=is,ie
               p1(:) = grid(i,  j,1:2)
               p2(:) = grid(i+1,j,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e1)
               call get_latlon_vector(p3, ex, ey)
               utmp = ubar * cos(p3(2))
               vtmp = 0.
               u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
            enddo
         enddo

         anti_rot = -ubar/ radius
         do j=jsd,jed+1
            do i=isd,ied+1
               fC(i,j) = 2.*anti_rot*sin(grid(i,j,2))
            enddo
         enddo
         do j=jsd,jed
            do i=isd,ied
               f0(i,j) = 2.*anti_rot*sin(agrid(i,j,2))
            enddo
         enddo
#endif
         initWindsCase= -1

      case(4)

!----------------------------
! Tropical cyclones
!----------------------------
!        f0 = 0.;  fC = 0.          ! non-rotating planet setup
          u = 0.
          v = 0.
         phis = 0.0                 ! flat terrain

         ubar = 50.                 ! maxmium wind speed (m/s)
           r0 = 250.e3              ! RADIUS of the maximum wind of the Rankine vortex
          gh0 = grav * 1.e3
 
        do j=jsd,jed
           do i=isd,ied
              delp(i,j,1) = gh0
           enddo
        enddo

!       ddeg = 2.*r0/radius     ! no merger
        ddeg = 1.80*r0/radius   ! merged 

        p1(1) = pi*1.5 - ddeg
        p1(2) = pi/18.              ! 10 N
        call rankine_vortex(ubar, r0, p1, u, v)

        p2(1) = pi*1.5 + ddeg
        p2(2) = pi/18.              ! 10 N
        call rankine_vortex(ubar, r0, p2, u, v)

#ifndef SINGULAR_VORTEX
!-----------
! Anti-pole:
!-----------
        ubar = -ubar
        call latlon2xyz(p1, e1)
        do i=1,3
           e1(i) = -e1(i)
        enddo
        call cart_to_latlon(1, e1, p3(1), p3(2))
        call rankine_vortex(ubar, r0, p3, u, v)

        call latlon2xyz(p2, e1)
        do i=1,3
           e1(i) = -e1(i)
        enddo
        call cart_to_latlon(1, e1, p4(1), p4(2))
        call rankine_vortex(ubar, r0, p4, u, v)
#endif
        call mp_update_dwinds(u, v, npx, npy, npz)
        initWindsCase=-1   ! do nothing

      case(5)

         Ubar = 20.        
         gh0  = 5960.*Grav
         phis = 0.0
         r0 = PI/9.
         p1(1) = PI/2.
         p1(2) = PI/6.
         do j=js,je
            do i=is,ie
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
               r = SQRT(r)
               phis(i,j) = 2000.0*Grav*(1.0-(r/r0))
            enddo
         enddo
         do j=js,je
            do i=is,ie
               delp(i,j,1) =gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                             ( -1.*cos(agrid(i  ,j  ,1))*cos(agrid(i  ,j  ,2))*sin(alpha) + &
                                   sin(agrid(i  ,j  ,2))*cos(alpha) ) ** 2  - phis(i,j)
            enddo
         enddo
         initWindsCase=initWindsCase5
      case(6)
         gh0  = 8.E3*Grav
         R    = 4.
         omg  = 7.848E-6
         rk    = 7.848E-6
         phis = 0.0
         do j=js,je
            do i=is,ie
               A = 0.5*omg*(2.*omega+omg)*(COS(agrid(i,j,2))**2) + &
                   0.25*rk*rk*(COS(agrid(i,j,2))**(r+r)) * &
                   ( (r+1)*(COS(agrid(i,j,2))**2) + (2.*r*r-r-2.) - &
                     2.*(r*r)*COS(agrid(i,j,2))**(-2.) )
               B = (2.*(omega+omg)*rk / ((r+1)*(r+2))) * (COS(agrid(i,j,2))**r) * &
                    ( (r*r+2.*r+2.) - ((r+1.)*COS(agrid(i,j,2)))**2 )
               C = 0.25*rk*rk*(COS(agrid(i,j,2))**(2.*r)) * ( &
                   (r+1) * (COS(agrid(i,j,2))**2.) - (r+2.) )
               delp(i,j,1) =gh0 + radius*radius*(A+B*COS(r*agrid(i,j,1))+C*COS(2.*r*agrid(i,j,1)))
               delp(i,j,1) = delp(i,j,1) - phis(i,j)
            enddo
         enddo
         do j=js,je
            do i=is,ie+1
               p1(:) = grid(i  ,j ,1:2)
               p2(:) = grid(i,j+1 ,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e2)
               call get_latlon_vector(p3, ex, ey)
               utmp = radius*omg*cos(p3(2)) +                      &
                      radius*rk*(cos(p3(2))**(R-1))*(R*sin(p3(2))**2-cos(p3(2))**2)*cos(R*p3(1)) 
               vtmp = -radius*rk*R*sin(p3(2))*sin(R*p3(1))*cos(p3(2))**(R-1)
               v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
            enddo
         enddo
         do j=js,je+1
            do i=is,ie
               p1(:) = grid(i,  j,1:2)
               p2(:) = grid(i+1,j,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e1)
               call get_latlon_vector(p3, ex, ey)
               utmp = radius*omg*cos(p3(2)) +                      &
                      radius*rk*(cos(p3(2))**(R-1))*(R*sin(p3(2))**2-cos(p3(2))**2)*cos(R*p3(1)) 
               vtmp = -radius*rk*R*sin(p3(2))*sin(R*p3(1))*cos(p3(2))**(R-1)
               u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
            enddo
         enddo
         call mp_update_dwinds(u, v, npx, npy, npz)
         call dtoa( u, v,ua,va,npx,npy,ng)
         !call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
         call atoc(ua,va,uc,vc,npx,npy,ng)
         initWindsCase=initWindsCase6
      case(7)
! Barotropically unstable jet
         gh0  = 10.E3*Grav
         phis = 0.0
         r0 = radius/12.
         p2(1) = pi/2.
         p2(2) = pi/4.
         do j=js,je
            do i=is,ie
!              ftmp = gh0
! 9-point average:
!      9  4  8
!
!      5  1  3
!          
!      6  2  7
               pt1 = gh_jet(npy, agrid(i,j,2))
               call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), pa)
               pt2 = gh_jet(npy, pa(2))
               call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), pa)
               pt3 = gh_jet(npy, pa(2))
               call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), pa)
               pt4 = gh_jet(npy, pa(2))
               call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), pa)
               pt5 = gh_jet(npy, pa(2))
               pt6 = gh_jet(npy, grid(i,  j,  2))
               pt7 = gh_jet(npy, grid(i+1,j,  2))
               pt8 = gh_jet(npy, grid(i+1,j+1,2))
               pt9 = gh_jet(npy, grid(i  ,j+1,2))
               ftmp = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
#ifndef NEW_PERT
               delp(i,j,1) = ftmp + 120.*grav*cos(agrid(i,j,2)) *  &
               exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
!              phis(i,j) = ftmp
!              delp(i,j,1) = 10.E3*grav + 120.*grav*cos(agrid(i,j,2)) *  &
!              exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
#else
! Using great circle dist:
               p1(:) = agrid(i,j,1:2)
               delp(i,j,1) = ftmp
               r = great_circle_dist(p1, p2, radius)
               if ( r < 3.*r0 ) then
                    delp(i,j,1) = delp(i,j,1) + 1000.*grav*exp(-(r/r0)**2)
               endif
#endif
            enddo
         enddo

! v-wind:
         do j=js,je
            do i=is,ie+1
               p2(:) = grid(i,j+1,1:2)
               vv1 = u_jet(p2(2))*(ee2(2,i,j+1)*cos(p2(1)) - ee2(1,i,j+1)*sin(p2(1)))
               p1(:) = grid(i,j,1:2)
               vv3 = u_jet(p1(2))*(ee2(2,i,j)*cos(p1(1)) - ee2(1,i,j)*sin(p1(1)))
! Mid-point:
               call mid_pt_sphere(p1, p2, pa)
               vv2 = u_jet(pa(2))*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
! 3-point average:
               v(i,j,1) = 0.25*(vv1 + 2.*vv2 + vv3)
!              v(i,j,1) = vv2
            enddo
         enddo
! U-wind:
         do j=js,je+1
            do i=is,ie
               p1(:) = grid(i,j,1:2)
               uu1 = u_jet(p1(2))*(ee1(2,i,j)*cos(p1(1)) - ee1(1,i,j)*sin(p1(1)))
               p2(:) = grid(i+1,j,1:2)
               uu3 = u_jet(p2(2))*(ee1(2,i+1,j)*cos(p2(1)) - ee1(1,i+1,j)*sin(p2(1)))
! Mid-point:
               call mid_pt_sphere(p1, p2, pa)
               uu2 = u_jet(pa(2))*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
! 3-point average:
               u(i,j,1) = 0.25*(uu1 + 2.*uu2 + uu3)
!              u(i,j,1) = uu2
            enddo
         enddo
         initWindsCase=initWindsCase6  ! shouldn't do anything with this

      case(8)
!----------------------------
! Non-rotating potential flow
!----------------------------
         gh0  = 5960.*Grav
         phis = 0.0
         r0 = PI/9.
         p1(1) = PI/2.
         p1(2) = PI/6.
         do j=js,je
            do i=is,ie
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
               r = SQRT(r)
               phis(i,j) = 2000.0*Grav*(1.0-(r/r0))
            enddo
         enddo
         do j=js,je
            do i=is,ie
               delp(i,j,1) = gh0
            enddo
         enddo
         u  = 0.;   v = 0.
         f0 = 0.;  fC = 0.
         initWindsCase= -1

      case(9)
         jm1 = jm - 1
         DDP = PI/DBLE(jm1)
         DP  = DDP
         ll_j(1) = -0.5*PI
         do j=2,jm
            ph5  = -0.5*PI + (DBLE(j-1)-0.5)*DDP
            ll_j(j) = -0.5*PI + (DBLE(j-1)*DDP)
            sine(j) = SIN(ph5)
         enddo
         cosp( 1) =  0.
         cosp(jm) =  0.
         do j=2,jm1
            cosp(j) = (sine(j+1)-sine(j)) / DP
         enddo
         do j=2,jm
            cose(j) = 0.5 * (cosp(j-1) + cosp(j))
         enddo
         cose(1) = cose(2)
         ddeg = 180./float(jm-1)
         do j=2,jm
            deg = -90. + (float(j-1)-0.5)*ddeg
            if (deg <= 0.) then
               ll_u(j) = -10.*(deg+90.)/90.
            elseif (deg <= 60.) then
               ll_u(j) = -10. +  deg
            else
               ll_u(j) = 50. - (50./30.)* (deg - 60.)
            endif
         enddo
         ll_phi(1) = 6000. * Grav
         do j=2,jm1
            ll_phi(j)=ll_phi(j-1)  - DP*sine(j) * &
                    (radius*2.*omega + ll_u(j)/cose(j))*ll_u(j)
         enddo
         phis = 0.0
         do j=js,je
            do i=is,ie
               do jj=1,jm1
                  if ( (ll_j(jj) <= agrid(i,j,2)) .and. (agrid(i,j,2) <= ll_j(jj+1)) ) then
                     delp(i,j,1)=0.5*(ll_phi(jj)+ll_phi(jj+1))
                  endif
               enddo
            enddo
         enddo

         do j=js,je
            do i=is,ie
               if (agrid(i,j,2)*todeg <= 0.0) then
                  ua(i,j,1) = -10.*(agrid(i,j,2)*todeg + 90.)/90.
               elseif (agrid(i,j,2)*todeg <= 60.0) then
                  ua(i,j,1) = -10. + agrid(i,j,2)*todeg
               else
                  ua(i,j,1) = 50. - (50./30.)* (agrid(i,j,2)*todeg - 60.)
               endif
               va(i,j,1) = 0.0
               call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
               call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
               call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
               call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
               if (cubed_sphere) call rotate_winds(ua(i,j,1), va(i,j,1), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
            enddo
         enddo

         call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
         call atoc(ua,va,uc,vc,npx,npy,ng)
         call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
         call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.)
         call atod(ua,va, u, v,npx,npy,ng)
         call mp_update_dwinds(u, v, npx, npy, npz)
         initWindsCase=initWindsCase9


         allocate( case9_B(isd:ied,jsd:jed) )
         call get_case9_B(case9_B)
         AofT(:) = 0.0
      end select
!--------------- end s-w cases --------------------------

! Copy 3D data for Shallow Water Tests
      do z=2,npz
         delp(:,:,z) = delp(:,:,1)
      enddo

      call mpp_update_domains( delp, domain )
      call mpp_update_domains( phis, domain )
      phi0  = delp

      call init_winds(UBar, u,v,ua,va,uc,vc, initWindsCase, npx, npy, ng, ndims, nregions)
! Copy 3D data for Shallow Water Tests
      do z=2,npz
         u(:,:,z) = u(:,:,1)
         v(:,:,z) = v(:,:,1)
      enddo

      do j=js,je
         do i=is,ie
            ps(i,j) = delp(i,j,1)
         enddo
      enddo
! -------- end s-w section ----------------------------------
#else

      if (test_case==10 .or. test_case==14) then

         alpha = 0.

   ! Initialize dry atmosphere
         q(:,:,:,:) = 3.e-6
         u(:,:,:) = 0.0
         v(:,:,:) = 0.0

       if ( test_case==14 ) then
! Aqua-planet case: mean SLP=1.E5
         phis = 0.0
         call hydro_eq(npz, is, ie, js, je, ps, phis, 1.E5,      &
                       delp, ak, bk, pt, delz, ng, .false., hybrid_z)
       else
! Initialize topography
#ifdef MARS_GCM
         gh0  = 0.*Grav
#else
         gh0  = 5960.*Grav
#endif MARS_GCM
         phis = 0.0
         r0 = PI/9.
         p1(1) = PI/4.
         p1(2) = PI/6. + (7.5/180.0)*PI
         do j=js,je
            do i=is,ie
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
               r = SQRT(r)
               phis(i,j) = gh0*(1.0-(r/r0))
            enddo
         enddo
         call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass,  &
                       delp, ak, bk, pt, delz, ng, mountain, hybrid_z)
       endif

      else if (test_case==11) then

#ifdef CHECK_GRID
       call pmxn(agrid, npx, npy, nregions, pmin1, pmax1, i0, j0, n0)
       if ( gid==masterproc ) write(*,*) 'A grid: Min Lon=', pmin1, 'Max lon=', pmax1
       call pmxn(agrid(isd, jsd,2), npx, npy, nregions, pmin1, pmax1, i0, j0, n0)
       if ( gid==masterproc ) write(*,*) 'A grid: Min Lat=', pmin1, 'Max lat=', pmax1
       call pmxn(grid(isd:ied,jsd:jed,1), npx, npy, nregions, pmin1, pmax1, i0, j0, n0)
       if ( gid==masterproc ) write(*,*) 'B grid: Min Lon=', pmin1, 'Max lon=', pmax1
       call pmxn(grid(isd:ied,jsd:jed,2), npx, npy, nregions, pmin1, pmax1, i0, j0, n0)
       if ( gid==masterproc ) write(*,*) 'B grid: Min Lat=', pmin1, 'Max lat=', pmax1
#endif
       call surfdrv(npx, npy, grid, agrid,   &
                    area, dx, dy, dxc, dyc, phis, gid==masterproc)
       call mpp_update_domains( phis, domain )

       if ( hybrid_z ) then
            rgrav = 1./ grav
            if( npz==32 ) then
                call compute_dz_L32( npz, ztop, dz1 )
            else
!               call mpp_error(FATAL, 'You must provide a routine for hybrid_z')
                if ( gid==masterproc ) write(*,*) 'Using const DZ'
                ztop = 45.E3           ! assuming ptop = 100.
                dz1(1) = ztop / real(npz) 
                dz1(npz) = 0.5*dz1(1)
                do z=2,npz-1
                   dz1(z) = dz1(1)
                enddo
                dz1(1) = 2.*dz1(2)
            endif

            call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav,  &
                              phis, ze0, delz)
!           call prt_maxmin('ZE0', ze0,  is, ie, js, je, 0, npz, 1.E-3, gid==masterproc)
!           call prt_maxmin('DZ0', delz, is, ie, js, je, 0, npz, 1.   , gid==masterproc)
       endif

! Initialize dry atmosphere
       u = 0.
       v = 0.
       q(:,:,:,:) = 0.
       q(:,:,:,1) = 3.e-6

       call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass,  &
                     delp, ak, bk, pt, delz, ng, mountain, hybrid_z)

      else if ( (test_case==12) .or. (test_case==13) ) then

         q(:,:,:,:) = 3.e-6
#ifdef TEST_TRACER
          q(:,:,:,:) = 0.
          if ( ncnst==6 ) then
              do j=js,je
                 do i=is,ie
                    q(i,j,1,1:6) = 1.
                 enddo
              enddo
              do z=1,ncnst
              do j=js,je
                 do i=is,ie
                    q(i,j,npz,z) = z
                 enddo
              enddo
              enddo
          endif
#endif
    ! Initialize surface Pressure
         ps(:,:) = 1.e5
    ! Initialize detla-P
         do z=1,npz
            do j=js,je
               do i=is,ie
                  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
               enddo
            enddo
         enddo
    ! Setup ETA auxil variable
         eta_0 = 0.252
         do z=1,npz
            eta = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
            eta_v(z) = (eta - eta_0)*PI*0.5
         enddo
    ! Initialize winds 
         Ubar = 35.0
         r0 = 1.0
         pcen(1) = PI/9.
         pcen(2) = 2.0*PI/9. 
         if (test_case == 13) then
#ifdef ALT_PERT
             u1 = 0.0
            pt0 = 3.0
#else
             u1 = 1.0
            pt0 = 0.0
#endif
             r0 = radius/10.0
         endif
         do z=1,npz
            do j=js,je
               do i=is,ie+1
                  utmp =  Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i,j+1,2))**2.0
             ! Perturbation if Case==13
                  r = great_circle_dist( pcen, grid(i,j+1,1:2), radius )
                  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0) 
                  vv1 = utmp*(ee2(2,i,j+1)*cos(grid(i,j+1,1)) - ee2(1,i,j+1)*sin(grid(i,j+1,1)))

                  utmp =  Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i,j,2))**2.0
             ! Perturbation if Case==13
                  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
                  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0) 
                  vv3 = utmp*(ee2(2,i,j)*cos(grid(i,j,1)) - ee2(1,i,j)*sin(grid(i,j,1)))
! Mid-point:
                  p1(:) = grid(i  ,j ,1:2)
                  p2(:) = grid(i,j+1 ,1:2)
                  call mid_pt_sphere(p1, p2, pa)
                  utmp =  Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*pa(2))**2.0
             ! Perturbation if Case==13
                  r = great_circle_dist( pcen, pa, radius )
                  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0) 
                  vv2 = utmp*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
! 3-point average:
                  v(i,j,z) = 0.25*(vv1 + 2.*vv2 + vv3)
               enddo
            enddo
            do j=js,je+1
               do i=is,ie
                  utmp =  Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i,j,2))**2.0
             ! Perturbation if Case==13
                  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
                  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
                  uu1 = utmp*(ee1(2,i,j)*cos(grid(i,j,1)) - ee1(1,i,j)*sin(grid(i,j,1)))

                  utmp =  Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i+1,j,2))**2.0
             ! Perturbation if Case==13
                  r = great_circle_dist( pcen, grid(i+1,j,1:2), radius )
                  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
                  uu3 = utmp*(ee1(2,i+1,j)*cos(grid(i+1,j,1)) - ee1(1,i+1,j)*sin(grid(i+1,j,1)))
! Mid-point:
                  p1(:) = grid(i  ,j  ,1:2)
                  p2(:) = grid(i+1,j  ,1:2)
                  call mid_pt_sphere(p1, p2, pa)
                  utmp =  Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*pa(2))**2.0
             ! Perturbation if Case==13
                  r = great_circle_dist( pcen, pa, radius )
                  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
                  uu2 = utmp*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
! 3-point average:
                  u(i,j,z) = 0.25*(uu1 + 2.*uu2 + uu3)
               enddo
            enddo
         enddo

    ! Temperature
         eta_s = 1.0 ! Surface Level
         eta_t = 0.2 ! Tropopause
         T_0 = 288.0
         delta_T = 480000.0
         lapse_rate = 0.005
         do z=1,npz
            eta = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
        !   if (gid==masterproc) print*, z, eta
            T_mean = T_0 * eta**(RDGAS*lapse_rate/Grav)
            if (eta_t > eta) T_mean = T_mean + delta_T*(eta_t - eta)**5.0

 230  format(i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
            press = ptop
            do zz=1,z
               press = press + delp(is,js,zz)
            enddo
            if (gid==masterproc) write(*,230) z, eta, press/100., T_mean
            do j=js,je
               do i=is,ie
! A-grid cell center: i,j
                  pt1 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(agrid(i,j,2))**6.0) *(COS(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(agrid(i,j,2))**3.0)*(SIN(agrid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
#ifndef NO_AVG13
! 9-point average: should be 2nd order accurate for a rectangular cell
!
!      9  4  8
!
!      5  1  3
!          
!      6  2  7
!
                  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
                  pt2 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
                  pt3 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
                  pt4 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
                  pt5 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )

                  pt6 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(grid(i,j,2))**6.0) *(COS(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i,j,2))**3.0)*(SIN(grid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  pt7 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(grid(i+1,j,2))**6.0) *(COS(grid(i+1,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i+1,j,2))**3.0)*(SIN(grid(i+1,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  pt8 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(grid(i+1,j+1,2))**6.0) *(COS(grid(i+1,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i+1,j+1,2))**3.0)*(SIN(grid(i+1,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  pt9 = T_mean + 0.75*(eta*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
                              ( -2.0*(SIN(grid(i,j+1,2))**6.0) *(COS(grid(i,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i,j+1,2))**3.0)*(SIN(grid(i,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
                  pt(i,j,z) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
#else
                  pt(i,j,z) = pt1
#endif

#ifdef ALT_PERT
                  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
                  if ( (r/r0)**2 < 40. ) then
                        pt(i,j,z) = pt(i,j,z) + pt0*exp(-(r/r0)**2)
                  endif
#endif
               enddo
            enddo
         enddo
         if (gid==masterproc) print*,' '
      ! Surface Geopotential
         phis(:,:)=1.e25
         do j=js,je
            do i=is,ie
               pt1 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                              ( -2.0*(SIN(agrid(i,j,2))**6.0) *(COS(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(agrid(i,j,2))**3.0)*(SIN(agrid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
#ifndef NO_AVG13
! 9-point average:
!
!      9  4  8
!
!      5  1  3
!          
!      6  2  7
!
               call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
               pt2 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                           ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                             Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
               pt3 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                           ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                             Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
               pt4 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                           ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                             Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
               pt5 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                           ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                             Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )

               pt6 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                              ( -2.0*(SIN(grid(i,j,2))**6.0) *(COS(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i,j,2))**3.0)*(SIN(grid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               pt7 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                              ( -2.0*(SIN(grid(i+1,j,2))**6.0) *(COS(grid(i+1,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i+1,j,2))**3.0)*(SIN(grid(i+1,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               pt8 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                              ( -2.0*(SIN(grid(i+1,j+1,2))**6.0) *(COS(grid(i+1,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i+1,j+1,2))**3.0)*(SIN(grid(i+1,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               pt9 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
                              ( -2.0*(SIN(grid(i,j+1,2))**6.0) *(COS(grid(i,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
                              Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
                              ( (8.0/5.0)*(COS(grid(i,j+1,2))**3.0)*(SIN(grid(i,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
               phis(i,j) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
#else
               phis(i,j) = pt1
#endif
            enddo
         enddo

      else if ( test_case==15 .or. test_case==19 ) then
!------------------------------------
! Non-hydrostatic 3D density current:
!------------------------------------
! C100_L64; hybrid_z = .T., make_nh = .F. ,   make_hybrid_z = .false.
! Control: npz=64;  dx = 100 m; dt = 1; n_split=10

        if ( test_case == 19 ) then
             f0(:,:) = 0.
             fC(:,:) = 0.
        endif

           phis = 0.
           u = 0.
           v = 0.
           w = 0.
          t00 = 300.
          p00 = 1.E5
          pk0 = p00**kappa
! Set up vertical coordinare with constant del-z spacing:
         ztop = 6.4E3
         ze1(    1) = ztop
         ze1(npz+1) = 0.
         do k=npz,2,-1
            ze1(k) = ze1(k+1) + ztop/real(npz)
         enddo

! Provide some room for the top layer
         ze1(1) = ztop + 1.5*ztop/real(npz)

         do j=js,je
            do i=is,ie
               ps(i,j) = p00
               pe(i,npz+1,j) = p00
               pk(i,j,npz+1) = pk0
            enddo
         enddo

         do k=npz,1,-1
            do j=js,je
               do i=is,ie
                  delz(i,j,k) = ze1(k+1) - ze1(k)
                    pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
                    pe(i,k,j) = pk(i,j,k)**(1./kappa)
               enddo
            enddo
         enddo

         ptop = pe(is,1,js)
         if ( gid==masterproc ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.

         do k=1,npz+1
            do j=js,je
               do i=is,ie
                  peln(i,k,j) = log(pe(i,k,j))
                   ze0(i,j,k) = ze1(k)
               enddo
            enddo
         enddo

         do k=1,npz
            do j=js,je
               do i=is,ie
                  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
                 delp(i,j,k) =  pe(i,k+1,j)-pe(i,k,j)
                   pt(i,j,k) = t00/pk0   ! potential temp
                enddo
            enddo
         enddo

! Perturbation: center at 3 km from the ground
         pturb = 15.
         p1(1) = pi
         p1(2) = 0.

         do k=1,npz
#ifndef STD_BUBBLE
            r0 = 0.5*(ze1(k)+ze1(k+1)) - 3.2E3
#else
            r0 = (0.5*(ze1(k)+ze1(k+1)) - 3.0E3) / 2.E3
#endif
            do j=js,je
               do i=is,ie
! Impose perturbation in potential temperature: pturb
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
#ifndef STD_BUBBLE
               r = great_circle_dist( p1, p2, radius )
               dist = sqrt( r**2 + r0**2 ) / 3.2E3
#else
               r = great_circle_dist( p1, p2, radius ) / 4.E3
               dist = sqrt( r**2 + r0**2 )
#endif
                  if ( dist<=1. ) then
                       q(i,j,k,1) =      pk0 * pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
                       pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
                  else
                       q(i,j,k,1) = 0.
                  endif
! Transform back to temperature:
                   pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
               enddo
            enddo
          enddo

      else if ( test_case==16 ) then

! Non-rotating:
       f0(:,:) = 0.
       fC(:,:) = 0.
! Initialize dry atmosphere
       phis = 0.
       u = 0.
       v = 0.
       p00 = 1000.E2
! Set up vertical coordinare with constant del-z spacing:
       ztop = 10.E3
       call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)

       do z=1,npz+1
          pe1(z) = ak(z) + bk(z)*p00
       enddo

       ze1(npz+1) = 0.
       do z=npz,2,-1
          ze1(z) = ze1(z+1) + ztop/real(npz)
       enddo
       ze1(1) = ztop

       if ( gid==masterproc ) write(*,*) 'Model top (pa)=', ptop

       do j=jsd,jed
          do i=isd,ied
             ps(i,j) = pe1(npz+1) 
          enddo
       enddo

       do z=1,npz+1
          do j=js,je
             do i=is,ie
                  pe(i,z,j) = pe1(z) 
                peln(i,z,j) = log(pe1(z)) 
                  pk(i,j,z) = exp(kappa*peln(i,z,j))
             enddo
          enddo
       enddo

! Horizontal shape function
       p1(1) = pi
       p1(2) = 0.
       r0 = radius / 3.
       do j=js,je
          do i=is,ie
             r = great_circle_dist( p1, agrid(i,j,1:2), radius )
             if ( r<r0 ) then
                  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
             else
                  vort(i,j) = 0 
             endif
          enddo
       enddo

       q = 0.
       pk0 = p00**kappa
       pturb = 10./pk0
       do z=1,npz
          zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
          do j=js,je
             do i=is,ie
                 pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
                delp(i,j,z) =  pe(i,z+1,j)-pe(i,z,j)  
! Impose perturbation in potential temperature: pturb
                  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
                  q(i,j,z,1) = q(i,j,z,1) + vort(i,j)*zmid
             enddo
          enddo
       enddo

      elseif ( test_case==17 ) then
! Initialize dry atmosphere
       phis = 0.
       u = 0.
       v = 0.
       p00 = 1000.E2
! Set up vertical coordinare with constant del-z spacing:
       ztop = 10.E3
       call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)

       do z=1,npz+1
          pe1(z) = ak(z) + bk(z)*p00
       enddo

       ze1(npz+1) = 0.
       do z=npz,2,-1
          ze1(z) = ze1(z+1) + ztop/real(npz)
       enddo
       ze1(1) = ztop

       if ( gid==masterproc ) write(*,*) 'Model top (pa)=', ptop

       do j=jsd,jed
          do i=isd,ied
             ps(i,j) = pe1(npz+1) 
          enddo
       enddo

       do z=1,npz+1
          do j=js,je
             do i=is,ie
                  pe(i,z,j) = pe1(z) 
                peln(i,z,j) = log(pe1(z)) 
                  pk(i,j,z) = exp(kappa*peln(i,z,j))
             enddo
          enddo
       enddo

! Horizontal shape function
       p1(1) = pi
       p1(2) = pi/4.
       r0 = radius / 3.
       do j=js,je
          do i=is,ie
             r = great_circle_dist( p1, agrid(i,j,1:2), radius )
             if ( r<r0 ) then
                  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
             else
                  vort(i,j) = 0 
             endif
          enddo
       enddo

         pk0 = p00**kappa
       pturb = 10./pk0
       do z=1,npz
          zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
          do j=js,je
             do i=is,ie
                 pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
                delp(i,j,z) =  pe(i,z+1,j)-pe(i,z,j)  
! Impose perturbation in potential temperature: pturb
                  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
             enddo
          enddo
       enddo

      elseif ( test_case==18 ) then
         ubar = 20.
          pt0 = 288.
         n2 = grav**2 / (cp_air*pt0)

         pcen(1) = PI/2.
         pcen(2) = PI/6.

    ! Initialize surface Pressure
         do j=js,je
            do i=is,ie
               r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
               phis(i,j) = grav*2.E3*exp( -(r/1500.E3)**2 )
               ps(i,j) = 930.E2 * exp( -radius*n2*ubar/(2.*grav*grav*kappa)*(ubar/radius+2.*omega)*   &
                                       (sin(agrid(i,j,2))**2-1.) - n2/(grav*grav*kappa)*phis(i,j))
            enddo
         enddo

      do z=1,npz
            do j=js,je
               do i=is,ie
                    pt(i,j,z) = pt0
                  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
               enddo
            enddo
! v-wind:
         do j=js,je
            do i=is,ie+1
               p1(:) = grid(i  ,j ,1:2)
               p2(:) = grid(i,j+1 ,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e2)
               call get_latlon_vector(p3, ex, ey)
               utmp = ubar * cos(p3(2))
               vtmp = 0.
               v(i,j,z) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
            enddo
         enddo

! u-wind
         do j=js,je+1
            do i=is,ie
               p1(:) = grid(i,  j,1:2)
               p2(:) = grid(i+1,j,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e1)
               call get_latlon_vector(p3, ex, ey)
               utmp = ubar * cos(p3(2))
               vtmp = 0.
               u(i,j,z) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
            enddo
         enddo
      enddo

      else if ( test_case==20 .or. test_case==21 ) then
!------------------------------------
! Non-hydrostatic 3D lee vortices
!------------------------------------
        f0(:,:) = 0.
        fC(:,:) = 0.

        if ( test_case == 20 ) then
             Ubar = 4.       ! u = Ubar * cos(lat)
             ftop = 2.0E3 * grav
        else
             Ubar = 8.       ! u = Ubar * cos(lat)
             ftop = 4.0E3 * grav
        endif

        w = 0.

         do j=js,je
            do i=is,ie+1
               p1(:) = grid(i  ,j ,1:2)
               p2(:) = grid(i,j+1 ,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e2)
               call get_latlon_vector(p3, ex, ey)
               utmp = ubar * cos(p3(2))
               vtmp = 0.
               v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
            enddo
         enddo
         do j=js,je+1
            do i=is,ie
               p1(:) = grid(i,  j,1:2)
               p2(:) = grid(i+1,j,1:2)
               call mid_pt_sphere(p1, p2, p3)
               call get_unit_vector(p1, p2, e1)
               call get_latlon_vector(p3, ex, ey)
               utmp = ubar * cos(p3(2))
               vtmp = 0.
               u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
            enddo
         enddo

! copy vertically; no wind shear
        do k=2,npz
           do j=js,je+1
              do i=is,ie
                 u(i,j,k) = u(i,j,1)
              enddo
           enddo
           do j=js,je
              do i=is,ie+1
                 v(i,j,k) = v(i,j,1)
              enddo
           enddo
        enddo

! Center of the mountain:
        p1(1) = (0.5-0.125) * pi
        p1(2) = 0.
        call latlon2xyz(p1, e1)
         uu1 =  5.0E3
         uu2 = 10.0E3
         do j=js,je
            do i=is,ie
              p2(:) = agrid(i,j,1:2)
                  r = great_circle_dist( p1, p2, radius ) 
              if ( r < pi*radius ) then
#ifdef T_ANGLE
                   call latlon2xyz(p2, e2)
! eastward vector parallel to equator
                   p3(1) = p1(1) + 0.01*pi  ! arbitrary positive number
                   p3(2) = p1(2)
                   call latlon2xyz(p3, e3)
                   e2(:) = e2(:) - e1(:)
                   e3(:) = e3(:) - e1(:)
                   call normalize_vect( e2 )
                   call normalize_vect( e3 )
! Compute angle: 0 <= acos() <= pi
                   zeta = acos( e2(1)*e3(1) + e2(2)*e3(2) + e2(3)*e3(3) )
                   if ( p2(2) <= p1(2) ) then
                        zeta = 2.*pi - zeta
                   endif
#else
                   p4(:) = p2(:) - p1(:)
                   if ( abs(p4(1)) > 1.E-12 ) then
                        zeta = asin ( p4(2) / sqrt(p4(1)**2 + p4(2)**2) ) 
                   else
                        zeta = pi/2.
                   endif
                   if ( p4(1) <= 0. ) zeta = pi - zeta
#endif
                    zeta = zeta + pi/6.
                     v1 = r/uu1 * cos( zeta )
                     v2 = r/uu2 * sin( zeta )
                   phis(i,j) = ftop / ( 1. + v1**2 + v2**2 )  
              else
                   phis(i,j) = 0.
              endif
            enddo
         enddo

       if ( hybrid_z ) then
            rgrav = 1./ grav
            if( npz==32 ) then
                call compute_dz_L32( npz, ztop, dz1 )
            else
                if ( gid==masterproc ) write(*,*) 'Using const DZ'
                ztop = 15.E3
                dz1(1) = ztop / real(npz) 
                do k=2,npz
                   dz1(k) = dz1(1)
                enddo
! Make top layer thicker
                dz1(1) = max( 1.0E3, 3.*dz1(2) )   ! min 1 km
            endif

! Re-compute ztop
             ze1(npz+1) = 0.
             do k=npz,1,-1
                ze1(k) = ze1(k+1) + dz1(k)
             enddo
             ztop = ze1(1)

            call set_hybrid_z( is, ie, js, je, ng, npz, ztop, dz1, rgrav,  &
                               phis, ze0, delz )
       else
            call mpp_error(FATAL, 'This test case is only currently setup for hybrid_z')
       endif

       do k=1,npz
          do j=js,je
             do i=is,ie
                delz(i,j,k) = ze0(i,j,k+1) - ze0(i,j,k)
             enddo
          enddo
       enddo

       p00 = 1.E5        ! mean SLP
       pk0 = p00**kappa
       t00 = 300.
       pt0 = t00/pk0
        n2 = 1.E-4
        s0 = grav*grav / (cp_air*n2) 

! For constant N2, Given z --> p
       do k=1,npz+1
          pe1(k) = p00*( (1.-s0/t00) + s0/t00*exp(-n2*ze1(k)/grav) )**(1./kappa)
       enddo

       ptop = pe1(1) 
       if ( gid==masterproc ) write(*,*) 'Lee vortex testcase: model top (mb)=', ptop/100.

! Set up fake "sigma" coordinate 
       ak(1) = pe1(1)
       bk(1) = 0.
       do k=2,npz
          bk(k) = (pe1(k) - pe1(1)) / (pe1(npz+1)-pe1(1))  ! bk == sigma
          ak(k) =  pe1(1)*(1.-bk(k)) 
       enddo                                                
       ak(npz+1) = 0.
       bk(npz+1) = 1.

! Assuming constant N
       do k=2,npz+1
          do j=js,je
             do i=is,ie
                pk(i,j,k) = pk0 - (1.-exp(-n2/grav*ze0(i,j,k))) * (grav*grav)/(n2*cp_air*pt0)
                pe(i,k,j) = pk(i,j,k) ** (1./kappa)
                peln(i,k,j) = log(pe(i,k,j)) 
             enddo
          enddo
       enddo

       do j=js,je
          do i=is,ie
               pe(i,1,j) = ptop
             peln(i,1,j) = log(pe(i,1,j)) 
               pk(i,j,1) = pe(i,1,j) ** kappa
                 ps(i,j) = pe(i,npz+1,j)
          enddo
       enddo

       do k=1,npz
          do j=js,je
             do i=is,ie
                pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
               delp(i,j,k) =  pe(i,k+1,j)-pe(i,k,j)  
                 pt(i,j,k) =  pkz(i,j,k)*grav*delz(i,j,k) / ( cp_air*(pk(i,j,k)-pk(i,j,k+1)) )
              enddo
          enddo
      enddo

      endif !test_case

      call mpp_update_domains( phis, domain )

     ftop = g_sum(phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
     if(gid==masterproc) write(6,*) 'mean terrain height (m)=', ftop/grav

! The flow is initially hydrostatic
     call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps,   &
                pe, peln, pk, pkz, kappa, q, ng, ncnst, dry_mass, .false., mountain, &
                moist_phys, .true., k_top, nwat)

#ifdef COLUMN_TRACER
      if( ncnst>1 ) q(:,:,:,2:ncnst) = 0.0
   ! Initialize a dummy Column Tracer
         pcen(1) = PI/9.
         pcen(2) = 2.0*PI/9.
         r0 = radius/10.0
         do z=1,npz
            do j=js,je
               do i=is,ie
                  p1(:) = grid(i  ,j ,1:2)
                  p2(:) = grid(i,j+1 ,1:2)
                  call mid_pt_sphere(p1, p2, pa)
                  call get_unit_vector(p1, p2, e2)
                  call get_latlon_vector(pa, ex, ey)
             ! Perturbation Location Case==13
                  r = great_circle_dist( pcen, pa, radius )
                  if (-(r/r0)**2.0 > -40.0) q(i,j,z,1) = EXP(-(r/r0)**2.0)
               enddo
            enddo
         enddo
#endif

#endif
    call mp_update_dwinds(u, v, npx, npy, npz)
  end subroutine init_case


  subroutine rankine_vortex(ubar, r0, p1, u, v)
!----------------------------
! Rankine vortex
!----------------------------
  real, intent(in):: ubar ! max wind (m/s)
  real, intent(in):: r0   ! Radius of max wind (m)
  real, intent(in):: p1(2)   ! center position (longitude, latitude) in radian
  real, intent(inout):: u(isd:ied,  jsd:jed+1)
  real, intent(inout):: v(isd:ied+1,jsd:jed)
! local:
  real:: p2(2), p3(2), p4(2)
  real:: e1(3), e2(3), ex(3), ey(3)
  real:: vr, r, d2, cos_p, x1, y1
  real:: utmp, vtmp
  integer i, j

! Compute u-wind
  do j=js,je+1
     do i=is,ie
        call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
! shift:
        p2(1) = p2(1) - p1(1)
        cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))  
        r = radius*acos(cos_p)   ! great circle distance
!       if( r<0.) call mpp_error(FATAL, 'radius negative!')
        if( r<r0 ) then
            vr = ubar*r/r0
        else
            vr = ubar*r0/r
        endif
        x1 = cos(p2(2))*sin(p2(1))
        y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
        d2 = max(1.e-25, sqrt(x1**2 + y1**2))
        utmp = -vr*y1/d2
        vtmp =  vr*x1/d2
        p3(1) = grid(i,j,  1) - p1(1)
        p3(2) = grid(i,j,  2)
        p4(1) = grid(i+1,j,1) - p1(1)
        p4(2) = grid(i+1,j,2)
        call get_unit_vector(p3, p4, e1)
        call get_latlon_vector(p2, ex, ey)  ! note: p2 shifted
        u(i,j) = u(i,j) + utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
      enddo
  enddo

! Compute v-wind
  do j=js,je
     do i=is,ie+1
        call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
! shift:
        p2(1) = p2(1) - p1(1)
        cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))  
        r = radius*acos(cos_p)   ! great circle distance
        if( r<r0 ) then
            vr = ubar*r/r0
        else
            vr = ubar*r0/r
        endif
        x1 = cos(p2(2))*sin(p2(1))
        y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
        d2 = max(1.e-25, sqrt(x1**2 + y1**2))
        utmp = -vr*y1/d2
        vtmp =  vr*x1/d2
        p3(1) = grid(i,j,  1) - p1(1)
        p3(2) = grid(i,j,  2)
        p4(1) = grid(i,j+1,1) - p1(1)
        p4(2) = grid(i,j+1,2)
        call get_unit_vector(p3, p4, e2)
        call get_latlon_vector(p2, ex, ey)  ! note: p2 shifted
        v(i,j) = v(i,j) + utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
      enddo
  enddo
  end subroutine rankine_vortex



     real function gh_jet(npy, lat_in)
     integer, intent(in):: npy
     real, intent(in):: lat_in
     real lat, lon, dp, uu
     real h0, ft
     integer j,jm

      jm = 4 * npy 
!     h0 = 10.E3
      h0 = 10.157946867E3
      dp = pi / real(jm-1)

     if ( .not. allocated(gh_table) ) then
          allocate (   gh_table(jm) )
           allocate ( lats_table(jm) )
! SP:
        gh_table(1) = grav*h0 
        lats_table(1) = -pi/2.
! Using only the mid-point for integration
      do j=2,jm
         lat = -pi/2. + (real(j-1)-0.5)*dp
         uu = u_jet(lat)
         ft = 2.*omega*sin(lat)
         gh_table(j) = gh_table(j-1) - uu*(radius*ft + tan(lat)*uu) * dp
         lats_table(j) = -pi/2. + real(j-1)*dp
      enddo
     endif

     if ( lat_in <= lats_table(1) ) then
          gh_jet = gh_table(1)
          return
     endif
     if ( lat_in >= lats_table(jm) ) then
          gh_jet = gh_table(jm)
          return
     endif

! Search:
     do j=1,jm-1
        if ( lat_in >=lats_table(j) .and. lat_in<=lats_table(j+1) ) then
             gh_jet = gh_table(j) + (gh_table(j+1)-gh_table(j))/dp * (lat_in-lats_table(j))
             return
        endif
     enddo
     end function gh_jet

     real function u_jet(lat)
      real lat, lon, dp
      real umax, en, ph0, ph1

      umax = 80.
      ph0 = pi/7.
      ph1 = pi/2. - ph0
      en =  exp( -4./(ph1-ph0)**2 )

      if ( lat>ph0 .and. lat<ph1 ) then
           u_jet = (umax/en)*exp( 1./( (lat-ph0)*(lat-ph1) ) )
      else
           u_jet = 0.
      endif
     end function u_jet
     
      subroutine get_case9_B(B)
      real, intent(OUT) :: B(isd:ied,jsd:jed)
      real :: myC,yy,myB
      integer :: i,j
! Generate B forcing function
!
      gh0 = 720.*grav
      do j=jsd,jed
         do i=isd,ied
            if (sin(agrid(i,j,2)) > 0.) then
               myC = sin(agrid(i,j,1))
                yy = (cos(agrid(i,j,2))/sin(agrid(i,j,2)))**2
               myB = gh0*yy*exp(1.-yy)
               B(i,j) = myB*myC
            else
               B(i,j) = 0.
            endif
         enddo
      enddo

   end subroutine get_case9_B
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     
   subroutine case9_forcing1(phis,time_since_start)

   real , intent(INOUT) :: phis(isd:ied  ,jsd:jed  )
   real , intent(IN) :: time_since_start
   real :: tday, amean
   integer :: i,j
!
! Generate B forcing function
!
              tday = time_since_start/86400.0
              if (tday >= 20.) then
                 AofT(2) = 0.5*(1.-cos(0.25*PI*(tday-20)))
                 if (tday == 24) AofT(2) = 1.0
              elseif (tday <= 4.) then
                 AofT(2) = 0.5*(1.-cos(0.25*PI*tday))
              elseif (tday <= 16.) then
                 AofT(2) = 1.
              else
                 AofT(2) = 0.5*(1.+cos(0.25*PI*(tday-16.)))
              endif
              amean = 0.5*(AofT(1)+AofT(2))
              do j=jsd,jed
                 do i=isd,ied
                    phis(i,j) = amean*case9_B(i,j)
                enddo
             enddo

   end subroutine case9_forcing1
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     
   subroutine case9_forcing2(phis)
     real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )
     integer :: i,j
!
! Generate B forcing function
!
          do j=jsd,jed
             do i=isd,ied
                phis(i,j) = AofT(2)*case9_B(i,j)
             enddo
          enddo
          AofT(1) = AofT(2)

   end subroutine case9_forcing2
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

      subroutine get_latlon_vector (pp, elon, elat)
      real, intent(IN)  :: pp(2)
      real, intent(OUT) :: elon(3), elat(3)

         elon(1) = -SIN(pp(1))
         elon(2) =  COS(pp(1))
         elon(3) =  0.0
         elat(1) = -SIN(pp(2))*COS(pp(1))
         elat(2) = -SIN(pp(2))*SIN(pp(1))
#ifdef RIGHT_HAND
         elat(3) =  COS(pp(2))
#else
! Left-hand system needed to be consistent with rest of the codes
         elat(3) = -COS(pp(2))
#endif

      end subroutine get_latlon_vector

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     
!      get_stats :: get L-1, L-2, and L-inf norms and other stats as defined
!                                                in Williamson, 1994 (p.16)
       subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, &
                            uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions,    &
                            stats_lun, consv_lun, monitorFreq)
         integer,      intent(IN) :: nt, maxnt
         real  ,    intent(IN) :: dt, dtout, ndays
         real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1,npz)
         real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  ,npz)
         real ,      intent(INOUT) ::   pt(isd:ied  ,jsd:jed  ,npz)
         real ,      intent(INOUT) :: delp(isd:ied  ,jsd:jed  ,npz)
         real ,      intent(INOUT) ::    q(isd:ied  ,jsd:jed  ,npz, ncnst)
         real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )
         real ,      intent(INOUT) ::   ps(isd:ied  ,jsd:jed  )
         real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  ,npz)
         real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1,npz)
         real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  ,npz)
         real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  ,npz)
         integer,      intent(IN) :: npx, npy, npz, ncnst
         integer,      intent(IN) :: ndims
         integer,      intent(IN) :: nregions
         integer,      intent(IN) :: stats_lun
         integer,      intent(IN) :: consv_lun
         integer,      intent(IN) :: monitorFreq

         real   :: L1_norm
         real   :: L2_norm
         real   :: Linf_norm
         real   :: pmin, pmin1, uamin1, vamin1
         real   :: pmax, pmax1, uamax1, vamax1
         real(kind=4) :: arr_r4(5)
         real   :: tmass0, tvort0, tener0, tKE0
         real   :: tmass, tvort, tener, tKE
         real   :: temp(is:ie,js:je)
         integer :: i0, j0, k0, n0
         integer :: i, j, k, n, iq

         real :: psmo, Vtx, p, w_p
         real :: x1,y1,z1,x2,y2,z2,ang

         real   :: p1(2), p2(2), p3(2), r, r0, dist, heading

         real :: uc0(isd:ied+1,jsd:jed  ,npz)
         real :: vc0(isd:ied  ,jsd:jed+1,npz)

         real :: myDay
         integer :: myRec

         myDay = ndays*((FLOAT(nt)/FLOAT(maxnt)))

#if defined(SW_DYNAMICS)
      if (test_case==0) then
         phi0 = 0.0
         do j=js,je
            do i=is,ie
               x1 = agrid(i,j,1)
               y1 = agrid(i,j,2)
               z1 = radius
               p = p0 * cos(y1)
               Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
               w_p = 0.0
               if (p /= 0.0) w_p = Vtx/p
              ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
               phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
            enddo
         enddo
      elseif (test_case==1) then
! Get Current Height Field "Truth"
         p1(1) = pi/2.  + pi_shift
         p1(2) = 0.
         p2(1) = 3.*pi/2.  + pi_shift
         p2(2) = 0.
         r0 = radius/3. !RADIUS 3.
         dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
         heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha
         call get_pt_on_great_circle( p1, p2, dist, heading, p3)
         phi0 = 0.0
         do j=js,je
            do i=is,ie
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = great_circle_dist( p3, p2, radius )
               if (r < r0) then
                  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
               else
                  phi0(i,j,1) = phis(i,j)
               endif
            enddo
         enddo
     endif

! Get Height Field Stats
         call pmxn(delp(:,:,1), npx, npy, nregions, pmin1, pmax1, i0, j0, n0)
         pmin1=pmin1/Grav
         pmax1=pmax1/Grav
         if (test_case <= 2) then
            call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, &
                                   pmin, pmax, L1_norm, L2_norm, Linf_norm)
            pmin=pmin/Grav
            pmax=pmax/Grav
            arr_r4(1) = pmin1
            arr_r4(2) = pmax1
            arr_r4(3) = L1_norm
            arr_r4(4) = L2_norm
            arr_r4(5) = Linf_norm
            if (gid == masterproc) write(stats_lun,rec=(nt)*2 + 1) arr_r4
         else
            arr_r4(1) = pmin1
            arr_r4(2) = pmax1
            arr_r4(3:5) = 0.
            pmin      = 0.
            pmax      = 0.
            L1_norm   = 0.
            L2_norm   = 0.
            Linf_norm = 0.
         endif

 200  format(i6.6,A,i6.6,A,e21.14)
 201  format('          ',A,e21.14,' ',e21.14)
 202  format('          ',A,i4.4,'x',i4.4,'x',i4.4)

         if ( (gid == masterproc) .and. MOD(nt,monitorFreq)==0 ) then
             write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay
             write(*,201) 'Height MAX        : ', pmax1
             write(*,201) 'Height MIN        : ', pmin1
             write(*,202) 'HGT MAX location  : ', i0, j0, n0
             if (test_case <= 2) then
                write(*,201) 'Height L1_norm    : ', L1_norm
                write(*,201) 'Height L2_norm    : ', L2_norm
                write(*,201) 'Height Linf_norm  : ', Linf_norm
             endif
         endif

! Get UV Stats
         call dtoa(u , v , ua, va, npx, npy, ng)
         call pmxn(ua(:,:,1), npx, npy, nregions, pmin1, pmax1, i0, j0, n0)
         if (test_case <= 2) then
            call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, &
                                   pmin, pmax, L1_norm, L2_norm, Linf_norm)
         endif
         arr_r4(1) = pmin1
         arr_r4(2) = pmax1
         arr_r4(3) = L1_norm
         arr_r4(4) = L2_norm
         arr_r4(5) = Linf_norm
         if (gid == masterproc) write(stats_lun,rec=(nt)*2 + 2) arr_r4
         if ( (gid == masterproc) .and. MOD(nt,monitorFreq)==0) then
             write(*,201) 'UV     MAX        : ', pmax1
             write(*,201) 'UV     MIN        : ', pmin1
             write(*,202) 'UV  MAX location  : ', i0, j0, n0
             if (test_case <= 2) then
                write(*,201) 'UV     L1_norm    : ', L1_norm
                write(*,201) 'UV     L2_norm    : ', L2_norm
                write(*,201) 'UV     Linf_norm  : ', Linf_norm
             endif
         endif
#else

 200  format(i6.6,A,i6.6,A,e10.4)
 201  format('          ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
 202  format('          ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4)
 203  format('          ',A,i3.3,A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)

      if(gid==masterproc) write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay

! Surface Pressure
     psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je)
     if(gid==masterproc) write(6,*) '         Total surface pressure =', 0.01*psmo
     call pmxn(ps, npx, npy, nregions, pmin, pmax, i0, j0, n0)
     if (gid == masterproc) then
        write(*,201) 'PS   MAX|MIN      : ', 0.01*pmax, 0.01*pmin, i0, j0, n0
     endif

! Get PT Stats
         pmax1 = -1.e25 
         pmin1 =  1.e25  
         i0=-999
         j0=-999
         k0=-999
         n0=-999
         do k=1,npz 
            call pmxn(pt(:,:,k), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            pmin1 = min(pmin, pmin1)
            pmax1 = max(pmax, pmax1)
            if (pmax1 == pmax) k0 = k
         enddo
         if (gid == masterproc) then
             write(*,201) 'PT   MAX|MIN      : ', pmax1, pmin1, i0, j0, k0, n0
         endif

#if defined(DEBUG)
     if(gid==masterproc) write(6,*) ' '
         do k=1,npz
            pmax1 = -1.e25
            pmin1 =  1.e25
            i0=-999
            j0=-999
            k0=-999
            n0=-999
            call pmxn(pt(:,:,k), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            pmin1 = min(pmin, pmin1)
            pmax1 = max(pmax, pmax1)
            if (gid == masterproc) then
                write(*,202) 'PT   MAX|MIN      : ', pmax1, pmin1, i0, j0, k, n0, 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
            endif
         enddo
     if(gid==masterproc) write(6,*) ' '
#endif

! Get DELP Stats
         pmax1 = -1.e25 
         pmin1 =  1.e25 
         i0=-999
         j0=-999
         k0=-999
         n0=-999
         do k=1,npz
            call pmxn(delp(:,:,k), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            pmin1 = min(pmin, pmin1)
            pmax1 = max(pmax, pmax1)
            if (pmax1 == pmax) k0 = k
         enddo
         if (gid == masterproc) then
             write(*,201) 'Delp MAX|MIN      : ', pmax1, pmin1, i0, j0, k0, n0
         endif

! Get UV Stats
         uamax1 = -1.e25
         uamin1 =  1.e25
         i0=-999
         j0=-999
         k0=-999
         n0=-999
         do k=1,npz
            call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), npx, npy, ng)
            call pmxn(ua(:,:,k), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            uamin1 = min(pmin, uamin1)
            uamax1 = max(pmax, uamax1)
            if (uamax1 == pmax) k0 = k
         enddo
         if (gid == masterproc) then
             write(*,201) 'U    MAX|MIN      : ', uamax1, uamin1, i0, j0, k0, n0
         endif

         vamax1 = -1.e25
         vamin1 =  1.e25
         i0=-999
         j0=-999
         k0=-999
         n0=-999
         do k=1,npz
            call pmxn(va(:,:,k), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            vamin1 = min(pmin, vamin1)
            vamax1 = max(pmax, vamax1)
            if (vamax1 == pmax) k0 = k
         enddo
         if (gid == masterproc) then
             write(*,201) 'V    MAX|MIN      : ', vamax1, vamin1, i0, j0, k0, n0
         endif

! Get Q Stats
         pmax1 = -1.e25 
         pmin1 =  1.e25 
         i0=-999
         j0=-999
         k0=-999
         n0=-999
         do k=1,npz
            call pmxn(q(isd,jsd,k,1), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            pmin1 = min(pmin, pmin1)
            pmax1 = max(pmax, pmax1)
            if (pmax1 == pmax) k0 = k
         enddo
         if (gid == masterproc) then
             write(*,201) 'Q    MAX|MIN      : ', pmax1, pmin1, i0, j0, k0, n0
         endif

! Get tracer Stats
       do iq=2,ncnst
         pmax1 = -1.e25
         pmin1 =  1.e25
         i0=-999
         j0=-999
         k0=-999
         n0=-999
         do k=1,npz
            call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, pmin, pmax, i0, j0, n0)
            pmin1 = min(pmin, pmin1)
            pmax1 = max(pmax, pmax1)
            if (pmax1 == pmax) k0 = k
         enddo
         if (gid == masterproc) then
             write(*,203) 'TR',iq-1,' MAX|MIN      : ', pmax1, pmin1, i0, j0, k0, n0
         endif
       enddo

#endif

      if (test_case == 12) then
! Get UV Stats
          call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, &
                                 pmin, pmax, L1_norm, L2_norm, Linf_norm)
          if (gid == masterproc) then
             write(*,201) 'UV(850) L1_norm    : ', L1_norm
             write(*,201) 'UV(850) L2_norm    : ', L2_norm
             write(*,201) 'UV(850) Linf_norm  : ', Linf_norm
          endif
      endif 

      tmass = 0.0
      tKE   = 0.0
      tener = 0.0
      tvort = 0.0
#if defined(SW_DYNAMICS)
      do k=1,1
#else
      do k=1,npz
#endif
! Get conservation Stats

! Conservation of Mass
         temp(:,:) = delp(is:ie,js:je,k)
         tmass0 = globalsum(temp, npx, npy, is,ie, js,je)
         tmass = tmass + tmass0

         call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),npx,npy,ng)
! Conservation of Kinetic Energy
         do j=js,je
            do i=is,ie
                  temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + &
                                vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) )
            enddo
         enddo
         tKE0 = globalsum(temp, npx, npy, is,ie, js,je)
         tKE = tKE + tKE0

! Conservation of Energy
         do j=js,je
            do i=is,ie
                  temp(i,j) = 0.5 * (delp(i,j,k)/Grav) * temp(i,j)  ! Include Previously calcullated KE 
                  temp(i,j) = temp(i,j) + &
                          Grav*((delp(i,j,k)/Grav + phis(i,j))*(delp(i,j,k)/Grav + phis(i,j))) - &
                          phis(i,j)*phis(i,j)
            enddo
         enddo
         tener0 = globalsum(temp, npx, npy, is,ie, js,je)
         tener = tener + tener0

! Conservation of Potential Enstrophy
         if (test_case>1) then
            do j=js,je
               do i=is,ie
                  temp(i,j) =  f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - &
                                                            (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
                  temp(i,j) = ( Grav*(temp(i,j)*temp(i,j))/delp(i,j,k) )
               enddo
            enddo
            tvort0 = globalsum(temp, npx, npy, is,ie, js,je)
            tvort = tvort + tvort0
         else
            tvort=1.
         endif
      enddo

         if (nt == 0) then
            tmass_orig = tmass
            tener_orig = tener
            tvort_orig = tvort
         endif 
         arr_r4(1) = (tmass-tmass_orig)/tmass_orig
         arr_r4(2) = (tener-tener_orig)/tener_orig
         arr_r4(3) = (tvort-tvort_orig)/tvort_orig
         arr_r4(4) = tKE
         if (test_case==12) arr_r4(4) = L2_norm 
#if defined(SW_DYNAMICS)
         myRec = nt+1
#else
         myRec = myDay*86400.0/dtout + 1 
#endif
         if (gid == masterproc) write(consv_lun,rec=myRec) arr_r4(1:4)
#if defined(SW_DYNAMICS)
         if ( (gid == masterproc) .and. MOD(nt,monitorFreq)==0) then
#else
         if ( (gid == masterproc) ) then 
#endif
             write(*,201) 'MASS TOTAL        : ', tmass
             write(*,201) 'NORMALIZED MASS   : ', (tmass-tmass_orig)/tmass_orig
             if (test_case >= 2) then
                write(*,201) 'Kinetic Energy KE : ', tKE
                write(*,201) 'ENERGY TOTAL      : ', tener
                write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig
                write(*,201) 'ENSTR TOTAL       : ', tvort
                write(*,201) 'NORMALIZED ENSTR  : ', (tvort-tvort_orig)/tvort_orig
             endif
             write(*,*) ' '
         endif
      end subroutine get_stats



   subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3) 
!     get_pt_on_great_circle :: Get the mid-point on a great circle given:
!                                 -2 points (Lon/Lat) to define a great circle
!                                 -Great Cirle distance between 2 defining points
!                                 -Heading
!                              compute:
!                                 Arrival Point (Lon/Lat)

         real , intent(IN)  :: p1(2), p2(2)
         real , intent(IN)  :: dist
         real , intent(IN)  :: heading
         real , intent(OUT) :: p3(2)

         real  pha, dp

         pha = dist/radius

         p3(2) = ASIN( (COS(heading)*COS(p1(2))*SIN(pha)) + (SIN(p1(2))*COS(pha)) )
         dp = ATAN2( SIN(heading)*SIN(pha)*COS(p1(2)) , COS(pha) - SIN(p1(2))*SIN(p3(2)) )
         p3(1) = MOD( (p1(1)-pi)-dp+pi , 2.*pi ) !- pi Leave at 0 to 360

      end subroutine get_pt_on_great_circle
 

!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!      get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
!                                                in Williamson, 1994 (p.16)
!                     for any var

       subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, &
                            vmin, vmax, L1_norm, L2_norm, Linf_norm)
         integer,      intent(IN) :: npx, npy
         integer,      intent(IN) :: ndims
         integer,      intent(IN) :: nregions
         real  ,    intent(IN) ::  var(isd:ied,jsd:jed)
         real  ,    intent(IN) :: varT(isd:ied,jsd:jed)
         real  ,   intent(OUT) :: vmin
         real  ,   intent(OUT) :: vmax
         real  ,   intent(OUT) :: L1_norm
         real  ,   intent(OUT) :: L2_norm
         real  ,   intent(OUT) :: Linf_norm

         real   :: vmean
         real   :: vvar
         real   :: vmin1
         real   :: vmax1
         real   :: pdiffmn
         real   :: pdiffmx

         real   :: varSUM, varSUM2, varMAX
         real   :: gsum
         real   :: vminT, vmaxT, vmeanT, vvarT
         integer :: i0, j0, n0

         varSUM = 0.
         varSUM2 = 0.
         varMAX = 0.
         L1_norm = 0.
         L2_norm = 0.
         Linf_norm = 0.
         vmean  = 0.
         vvar   = 0.
         vmax   = 0.
         vmin   = 0.
         pdiffmn= 0.
         pdiffmx= 0.
         vmeanT = 0.
         vvarT  = 0.
         vmaxT  = 0.
         vminT  = 0.

         vmean   = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je)
         vmeanT  = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je)
         vmean  = vmean  / (4.0*pi)
         vmeanT = vmeanT / (4.0*pi)

         call pmxn(var, npx, npy, nregions, vmin , vmax , i0, j0, n0)
         call pmxn(varT, npx, npy, nregions, vminT, vmaxT, i0, j0, n0)
         call pmxn(var-varT, npx, npy, nregions, pdiffmn, pdiffmx, i0, j0, n0)

         vmax = (vmax - vmaxT) / (vmaxT-vminT)
         vmin = (vmin - vminT) / (vmaxT-vminT)

         varSUM  = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je)
         varSUM2 = globalsum(varT(is:ie,js:je)**2., npx, npy, is,ie, js,je)
         L1_norm = globalsum(ABS(var(is:ie,js:je)-varT(is:ie,js:je)), npx, npy, is,ie, js,je)
         L2_norm = globalsum((var(is:ie,js:je)-varT(is:ie,js:je))**2., npx, npy, is,ie, js,je)
         L1_norm = L1_norm/varSUM
         L2_norm = SQRT(L2_norm)/SQRT(varSUM2)

         call pmxn(ABS(varT), npx, npy, nregions, vmin, vmax, i0, j0, n0)
         varMAX = vmax
         call pmxn(ABS(var-varT), npx, npy, nregions, vmin, vmax, i0, j0, n0)
         Linf_norm = vmax/varMAX

      end subroutine get_scalar_stats
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!      get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
!                                                in Williamson, 1994 (p.16)
!                     for any var

       subroutine get_vector_stats(varU, varUT, varV, varVT, &
                            npx, npy, ndims, nregions, &
                            vmin, vmax, L1_norm, L2_norm, Linf_norm)
         integer,      intent(IN) :: npx, npy
         integer,      intent(IN) :: ndims
         integer,      intent(IN) :: nregions
         real  ,    intent(IN) ::  varU(isd:ied,jsd:jed)
         real  ,    intent(IN) :: varUT(isd:ied,jsd:jed)
         real  ,    intent(IN) ::  varV(isd:ied,jsd:jed)
         real  ,    intent(IN) :: varVT(isd:ied,jsd:jed)
         real  ,   intent(OUT) :: vmin
         real  ,   intent(OUT) :: vmax
         real  ,   intent(OUT) :: L1_norm
         real  ,   intent(OUT) :: L2_norm
         real  ,   intent(OUT) :: Linf_norm

         real   ::  var(isd:ied,jsd:jed)
         real   :: varT(isd:ied,jsd:jed)
         real   :: vmean
         real   :: vvar
         real   :: vmin1
         real   :: vmax1
         real   :: pdiffmn
         real   :: pdiffmx

         real   :: varSUM, varSUM2, varMAX
         real   :: gsum
         real   :: vminT, vmaxT, vmeanT, vvarT
         integer :: i,j,n
         integer :: i0, j0, n0

         varSUM = 0.
         varSUM2 = 0.
         varMAX = 0.
         L1_norm = 0.
         L2_norm = 0.
         Linf_norm = 0.
         vmean  = 0.
         vvar   = 0.
         vmax   = 0.
         vmin   = 0.
         pdiffmn= 0.
         pdiffmx= 0.
         vmeanT = 0.
         vvarT  = 0.
         vmaxT  = 0.
         vminT  = 0.

         do j=js,je
            do i=is,ie
               var(i,j) = SQRT( (varU(i,j)-varUT(i,j))**2. + &
                                (varV(i,j)-varVT(i,j))**2. )
               varT(i,j) = SQRT( varUT(i,j)*varUT(i,j) + &
                                 varVT(i,j)*varVT(i,j) )
            enddo
         enddo
         varSUM  = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je)
         L1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je)
         L1_norm = L1_norm/varSUM

         call pmxn(varT, npx, npy, nregions, vmin, vmax, i0, j0, n0)
         varMAX = vmax
         call pmxn(var, npx, npy, nregions, vmin, vmax, i0, j0, n0)
         Linf_norm = vmax/varMAX

         do j=js,je
            do i=is,ie
               var(i,j) = ( (varU(i,j)-varUT(i,j))**2. + &
                            (varV(i,j)-varVT(i,j))**2. )
              varT(i,j) = ( varUT(i,j)*varUT(i,j) + &
                            varVT(i,j)*varVT(i,j) )
            enddo
         enddo
         varSUM  = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je)
         L2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je)
         L2_norm = SQRT(L2_norm)/SQRT(varSUM)

      end subroutine get_vector_stats
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     check_courant_numbers :: 
!
       subroutine check_courant_numbers(uc,vc, ndt, n_split, npx, npy, npz, noPrint)

       real, intent(IN) :: ndt
       integer, intent(IN) :: n_split
       integer, intent(IN) :: npx, npy, npz
       logical, OPTIONAL, intent(IN) :: noPrint
       real ,      intent(IN) ::   uc(isd:ied+1,jsd:jed  ,npz)
       real ,      intent(IN) ::   vc(isd:ied  ,jsd:jed+1,npz)
 
       real :: ideal_c=0.06
       real :: tolerance= 1.e-3
       real :: dt_inc, dt_orig 
       real   :: meanCy, minCy, maxCy, meanCx, minCx, maxCx

       real :: counter
       logical :: ideal 

       integer :: i,j,k
       real :: dt

       dt = ndt/real(n_split)

 300  format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)

       dt_orig = dt
       dt_inc = 1
       ideal = .false.

       do while(.not. ideal)
       
         counter = 0
         minCy = missing
         maxCy = -1.*missing
         minCx = missing
         maxCx = -1.*missing
         meanCx = 0
         meanCy = 0
         do k=1,npz
         do j=js,je
            do i=is,ie+1
               minCx = MIN(minCx, ABS( (dt/dxc(i,j))*uc(i,j,k) ))
               maxCx = MAX(maxCx, ABS( (dt/dxc(i,j))*uc(i,j,k) ))
               meanCx = meanCx + ABS( (dt/dxc(i,j))*uc(i,j,k) )

        if (ABS( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then
           counter = counter+1
           write(*,300) i,j,k,tile, ABS( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter 
           call exit(1)
        endif

            enddo
         enddo
         do j=js,je+1
            do i=is,ie
               minCy = MIN(minCy, ABS( (dt/dyc(i,j))*vc(i,j,k) ))
               maxCy = MAX(maxCy, ABS( (dt/dyc(i,j))*vc(i,j,k) ))
               meanCy = meanCy + ABS( (dt/dyc(i,j))*vc(i,j,k) )

        if (ABS( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then
           counter = counter+1
           write(*,300) i,j,k,tile, ABS( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter
           call exit(1)
        endif

            enddo
         enddo
         enddo

         call mp_reduce_max(maxCx)
         call mp_reduce_max(maxCy)
         minCx = -minCx
         minCy = -minCy
         call mp_reduce_max(minCx)
         call mp_reduce_max(minCy)
         minCx = -minCx
         minCy = -minCy
         call mp_reduce_sum(meanCx)
         call mp_reduce_sum(meanCy)
         meanCx = meanCx/(6.0*DBLE(npx)*DBLE(npy-1))
         meanCy = meanCy/(6.0*DBLE(npx-1)*DBLE(npy))

         !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then 
            ideal = .true. 
         !elseif (maxCy-ideal_c > 0) then
         !   dt = dt - dt_inc 
         !else
         !   dt = dt + dt_inc
         !endif

      enddo

         if ( (.not. present(noPrint)) .and. (gid == masterproc) ) then
            print*, ''
            print*, '--------------------------------------------'
            print*, 'Y-dir Courant number MIN  : ', minCy
            print*, 'Y-dir Courant number MAX  : ', maxCy
            print*, ''
            print*, 'X-dir Courant number MIN  : ', minCx
            print*, 'X-dir Courant number MAX  : ', maxCx
            print*, ''
            print*, 'X-dir Courant number MEAN : ', meanCx
            print*, 'Y-dir Courant number MEAN : ', meanCy
            print*, ''
            print*, 'NDT: ', ndt
            print*, 'n_split: ', n_split
            print*, 'DT: ', dt
            print*, ''
            print*, '--------------------------------------------'
            print*, ''
         endif

      end subroutine check_courant_numbers
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     pmxn :: find max and min of field p
!
      subroutine pmxn(p, npx, npy, nregions, pmin, pmax, i0, j0, n0)
         integer,      intent(IN) :: npx
         integer,      intent(IN) :: npy
         integer,      intent(IN) :: nregions
         real  , intent(IN)  :: p(isd:ied,jsd:jed)
         real  , intent(OUT) :: pmin
         real  , intent(OUT) :: pmax
         integer,      intent(OUT) :: i0
         integer,      intent(OUT) :: j0
         integer,      intent(OUT) :: n0

         real   :: temp
         integer :: i,j,n

         pmax = -1.e25
         pmin =  1.e25 
         i0 = -999
         j0 = -999
         n0 = tile

            do j=js,je
               do i=is,ie
                  temp = p(i,j)
                  if (temp > pmax) then
                     pmax = temp
                     i0 = i
                     j0 = j
                  elseif (temp < pmin) then
                     pmin = temp
                  endif
            enddo
         enddo

         temp = pmax
         call mp_reduce_max(temp)
         if (temp /= pmax) then
            i0 = -999
            j0 = -999
            n0 = -999
         endif
         pmax = temp
         call mp_reduce_max(i0)
         call mp_reduce_max(j0)
         call mp_reduce_max(n0)

         pmin = -pmin                  
         call mp_reduce_max(pmin)
         pmin = -pmin

      end subroutine pmxn
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     output_ncdf :: write out NETCDF fields
!
      subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
                        omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, &
                        npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, &
                        phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids,  &
                        lats_id, lons_id)
      real,         intent(IN) :: dt
      integer,      intent(IN) :: nt, maxnt
      integer,      intent(INOUT) :: nout

      real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1,npz)
      real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   pt(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) :: delp(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::    q(isd:ied  ,jsd:jed  ,npz, ncnst)

      real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )
      real ,      intent(INOUT) ::   ps(isd:ied  ,jsd:jed  )

      real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1,npz)
      real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) :: omga(isd:ied  ,jsd:jed  ,npz)

      integer,      intent(IN) :: npx, npy, npz
      integer,      intent(IN) :: ng, ncnst
      integer,      intent(IN) :: ndims
      integer,      intent(IN) :: nregions
      integer,      intent(IN) :: ncid
      integer,      intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id
      integer,      intent(IN) :: ntiles_id, nt_id
      integer,      intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id
      integer,      intent(IN) :: om_id          ! omega (dp/dt)
      integer,      intent(IN) :: tracers_ids(ncnst-1)
      integer,      intent(IN) :: lats_id, lons_id

      real, allocatable :: tmp(:,:,:)
      real, allocatable :: tmpA(:,:,:)
#if defined(SW_DYNAMICS) 
      real, allocatable :: ut(:,:,:)
      real, allocatable :: vt(:,:,:)
#else       
      real, allocatable :: ut(:,:,:,:)
      real, allocatable :: vt(:,:,:,:)
      real, allocatable :: tmpA_3d(:,:,:,:)
#endif
      real, allocatable :: vort(:,:)

      real   :: p1(2)      ! Temporary Point
      real   :: p2(2)      ! Temporary Point
      real   :: p3(2)      ! Temporary Point
      real   :: p4(2)      ! Temporary Point
      real   :: pa(2)      ! Temporary Point
      real   :: utmp, vtmp, r, r0, dist, heading
      integer   ::  i,j,k,n,iq,nreg

      real :: Vtx, p, w_p
      real :: x1,y1,z1,x2,y2,z2,ang

      allocate( tmp(npx  ,npy  ,nregions) )
      allocate( tmpA(npx-1,npy-1,nregions) )
#if defined(SW_DYNAMICS) 
      allocate( ut(npx-1,npy-1,nregions) )
      allocate( vt(npx-1,npy-1,nregions) )
#else
      allocate( ut(npx-1,npy-1,npz,nregions) )
      allocate( vt(npx-1,npy-1,npz,nregions) )
      allocate( tmpA_3d(npx-1,npy-1,npz,nregions) )
#endif
      allocate( vort(isd:ied,jsd:jed) ) 

      nout = nout + 1

      if (nt==0) then
         tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2)
         call wrtvar_ncdf(ncid, lats_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3)
         tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1)
         call wrtvar_ncdf(ncid, lons_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3)
      endif

#if defined(SW_DYNAMICS)
      if (test_case > 1) then
         tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav

         if ((nt==0) .and. (test_case==2)) then
         Ubar = (2.0*pi*radius)/(12.0*86400.0)
         gh0  = 2.94e4
         phis = 0.0
         do j=js,je+1
            do i=is,ie+1
               tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                           ( -1.*cos(grid(i  ,j  ,1))*cos(grid(i  ,j  ,2))*sin(alpha) + &
                                 sin(grid(i  ,j  ,2))*cos(alpha) ) ** 2.0) / Grav
            enddo
         enddo
         endif

      else

       if (test_case==1) then
! Get Current Height Field "Truth"
         p1(1) = pi/2. + pi_shift
         p1(2) = 0.
         p2(1) = 3.*pi/2. + pi_shift
         p2(2) = 0.
         r0 = radius/3. !RADIUS /3.
         dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
         heading = 5.0*pi/2.0 - alpha
         call get_pt_on_great_circle( p1, p2, dist, heading, p3)
            do j=jsd,jed
               do i=isd,ied
                  p2(1) = agrid(i,j,1)
                  p2(2) = agrid(i,j,2)
                  r = great_circle_dist( p3, p2, radius )
                  if (r < r0) then
                     phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
                  else
                     phi0(i,j,1) = phis(i,j)
                  endif
               enddo
            enddo
         elseif (test_case == 0) then
           phi0 = 0.0
           do j=jsd,jed
              do i=isd,ied
               x1 = agrid(i,j,1)
               y1 = agrid(i,j,2)
               z1 = radius
               p = p0 * cos(y1)
               Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
               w_p = 0.0
               if (p /= 0.0) w_p = Vtx/p
               phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
              enddo
           enddo
         endif

         tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
         call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
         tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)
      endif
      call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)

      if (test_case == 9) then
! Calc Vorticity
         do j=jsd,jed
            do i=isd,ied
               vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
                                                        (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
               vort(i,j) = Grav*vort(i,j)/delp(i,j,1)
            enddo
         enddo
         tmpA(is:ie,js:je,tile) = vort(is:ie,js:je)
         call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
      endif

      call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, 1)
      do j=js,je
         do i=is,ie
            ut(i,j,tile) = ua(i,j,1)
            vt(i,j,tile) = va(i,j,1)
         enddo
      enddo

      call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:nregions), 3)
      call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:nregions), 3)

      if ((test_case >= 2) .and. (nt==0) ) then
         tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
         call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
      endif
#else

! Write Moisture Data
      tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1)
      call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)

! Write Tracer Data
      do iq=2,ncnst
         tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq)
         call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
      enddo

! Write Surface height data
      tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
      call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3)

! Write Pressure Data
      tmpA(is:ie,js:je,tile) = ps(is:ie,js:je)
      call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3)
      do k=1,npz
         tmpA_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/Grav
      enddo
      call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)

! Write PT Data
      do k=1,npz
         tmpA_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k)
      enddo
      call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)

! Write U,V Data
      call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, npz, 1)
      do k=1,npz
         do j=js,je
            do i=is,ie
               ut(i,j,k,tile) = ua(i,j,k)
               vt(i,j,k,tile) = va(i,j,k)
            enddo
         enddo
      enddo
      call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:npz,1:nregions), 4)
      call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:npz,1:nregions), 4)


! Calc Vorticity
      do k=1,npz
         do j=js,je
            do i=is,ie
               tmpA_3d(i,j,k,tile) = rarea(i,j) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - &
                                                    (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
            enddo
         enddo
      enddo
      call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
!
! Output omega (dp/dt):
      do k=1,npz
         do j=js,je
            do i=is,ie
               tmpA_3d(i,j,k,tile) = omga(i,j,k)
            enddo
         enddo
      enddo
      call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)

#endif

      deallocate( tmp )
      deallocate( tmpA )
#if defined(SW_DYNAMICS) 
      deallocate( ut )
      deallocate( vt )
#else
      deallocate( ut )
      deallocate( vt )
      deallocate( tmpA_3d )
#endif
      deallocate( vort )

      end subroutine output_ncdf
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
!     output :: write out fields
!
      subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
                        npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, &
                        pt_lun, pv_lun, uv_lun)

      real,         intent(IN) :: dt
      integer,      intent(IN) :: nt, maxnt
      integer,      intent(INOUT) :: nout

      real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1,npz)
      real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   pt(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) :: delp(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::    q(isd:ied  ,jsd:jed  ,npz, ncnst)

      real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )
      real ,      intent(INOUT) ::   ps(isd:ied  ,jsd:jed  )

      real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1,npz)
      real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  ,npz)
      real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  ,npz)

      integer,      intent(IN) :: npx, npy, npz
      integer,      intent(IN) :: ng, ncnst
      integer,      intent(IN) :: ndims
      integer,      intent(IN) :: nregions
      integer,      intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun

      real   ::  tmp(1-ng:npx  +ng,1-ng:npy  +ng,1:nregions)
      real   :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions)
      real   :: p1(2)      ! Temporary Point
      real   :: p2(2)      ! Temporary Point
      real   :: p3(2)      ! Temporary Point
      real   :: p4(2)      ! Temporary Point
      real   :: pa(2)      ! Temporary Point
      real   :: ut(1:npx,1:npy,1:nregions)
      real   :: vt(1:npx,1:npy,1:nregions)
      real   :: utmp, vtmp, r, r0, dist, heading
      integer   ::  i,j,k,n,nreg
      real   :: vort(isd:ied,jsd:jed)

      real :: Vtx, p, w_p
      real :: x1,y1,z1,x2,y2,z2,ang

      nout = nout + 1

#if defined(SW_DYNAMICS)
      if (test_case > 1) then
         call atob_s(delp(:,:,1)/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy) !, altInterp=1)
         tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav

         if ((nt==0) .and. (test_case==2)) then
         Ubar = (2.0*pi*radius)/(12.0*86400.0)
         gh0  = 2.94e4
         phis = 0.0
         do j=js,je+1
            do i=is,ie+1
               tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
                           ( -1.*cos(grid(i  ,j  ,1))*cos(grid(i  ,j  ,2))*sin(alpha) + &
                                 sin(grid(i  ,j  ,2))*cos(alpha) ) ** 2.0) / Grav
            enddo
         enddo
         endif

      else

       if (test_case==1) then
! Get Current Height Field "Truth"
         p1(1) = pi/2. + pi_shift
         p1(2) = 0.
         p2(1) = 3.*pi/2. + pi_shift
         p2(2) = 0.
         r0 = radius/3. !RADIUS /3.
         dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
         heading = 5.0*pi/2.0 - alpha
         call get_pt_on_great_circle( p1, p2, dist, heading, p3)
            do j=jsd,jed
               do i=isd,ied
                  p2(1) = agrid(i,j,1)
                  p2(2) = agrid(i,j,2)
                  r = great_circle_dist( p3, p2, radius )
                  if (r < r0) then
                     phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
                  else
                     phi0(i,j,1) = phis(i,j)
                  endif
               enddo
            enddo
         elseif (test_case == 0) then
           phi0 = 0.0
           do j=jsd,jed
              do i=isd,ied
               x1 = agrid(i,j,1) 
               y1 = agrid(i,j,2)
               z1 = radius
               p = p0 * cos(y1)
               Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
               w_p = 0.0
               if (p /= 0.0) w_p = Vtx/p
               phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
              enddo
           enddo
         endif

         call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy) !, altInterp=1)
         tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
         call wrt2d(phis_lun, nout  , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
         call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy) !, altInterp=1)
         tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)
      endif
   !   call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
      call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))

      if (test_case == 9) then
! Calc Vorticity
         do j=jsd,jed
            do i=isd,ied
               vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
                                                        (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
               vort(i,j) = Grav*vort(i,j)/delp(i,j,1)
            enddo
         enddo
         call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy) !, altInterp=1)
         call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
      endif

      call dtoa(u , v , ua, va, npx, npy, ng)
! Rotate winds to standard Lat-Lon orientation
      if (cubed_sphere) then
         do j=js,je
            do i=is,ie
               call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
               call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
               call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
               call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
               utmp = ua(i,j,1)
               vtmp = va(i,j,1)
               if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
               ut(i,j,tile) = utmp
               vt(i,j,tile) = vtmp
            enddo
         enddo
      endif

      call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions,   ut(1:npx-1,1:npy-1,1:nregions))
      call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions,   vt(1:npx-1,1:npy-1,1:nregions))

      if ((test_case >= 2) .and. (nt==0) ) then
         call atob_s(phis/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy) !, altInterp=1)
       !  call wrt2d(phis_lun, nout  , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
         tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
         call wrt2d(phis_lun, nout  , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
      endif
#else

! Write Surface height data
      if (nt==0) then
         tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
         call wrt2d(phis_lun, nout  , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
      endif

! Write Pressure Data

      !if (tile==2) then
      !   do i=is,ie
      !      print*, i, ps(i,35) 
      !   enddo
      !endif
      tmpA(is:ie,js:je,tile) = ps(is:ie,js:je)
      call wrt2d(phi_lun, (nout-1)*(npz+1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
      do k=1,npz
         tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,k)/Grav
         call wrt2d(phi_lun, (nout-1)*(npz+1) + 1 + k, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
      enddo

! Write PT Data
      do k=1,npz
         tmpA(is:ie,js:je,tile) = pt(is:ie,js:je,k)
         call wrt2d(pt_lun, (nout-1)*npz + (k-1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
      enddo

! Write U,V Data
      do k=1,npz
         call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), npx, npy, ng)
! Rotate winds to standard Lat-Lon orientation
         if (cubed_sphere) then
            do j=js,je
               do i=is,ie
                 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
                 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
                 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
                 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
                 utmp = ua(i,j,k)
                 vtmp = va(i,j,k)
                 if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
                 ut(i,j,tile) = utmp
                 vt(i,j,tile) = vtmp
               enddo
            enddo
         endif
         call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 1, is,ie, js,je, npx, npy, nregions,   ut(1:npx-1,1:npy-1,1:nregions))
         call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 2, is,ie, js,je, npx, npy, nregions,   vt(1:npx-1,1:npy-1,1:nregions))
      enddo
#endif
      end subroutine output
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     wrt2d_ncdf :: write out a 2d field
!        
      subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims)
#include <netcdf.inc>
         integer,      intent(IN) :: ncid, varid
         integer,      intent(IN) :: nrec
         integer,      intent(IN) :: i1,i2,j1,j2
         integer,      intent(IN) :: npx
         integer,      intent(IN) :: npy
         integer,      intent(IN) :: npz
         integer,      intent(IN) :: ntiles
         real  , intent(IN)  :: p(npx-1,npy-1,npz,ntiles)
         integer,      intent(IN) :: ndims

         integer :: error
         real(kind=4), allocatable :: p_R4(:,:,:,:)
         integer :: i,j,k,n
         integer :: istart(ndims+1), icount(ndims+1)

         allocate( p_R4(npx-1,npy-1,npz,ntiles) )

         p_R4(:,:,:,:) = missing
         p_R4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile)
         call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles)

         istart(:) = 1
         istart(ndims+1) = nrec
         icount(1) = npx-1
         icount(2) = npy-1
         icount(3) = npz
         if (ndims == 3) icount(3) = ntiles
         if (ndims == 4) icount(4) = ntiles
         icount(ndims+1) = 1

         if (gid == masterproc) then  
            error = NF_PUT_VARA_REAL(ncid, varid, istart, icount, p_R4)
         endif ! masterproc

         deallocate( p_R4 )

      end subroutine wrtvar_ncdf
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     wrt2d :: write out a 2d field
!
      subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p)
         integer,      intent(IN) :: iout
         integer,      intent(IN) :: nrec
         integer,      intent(IN) :: i1,i2,j1,j2
         integer,      intent(IN) :: npx
         integer,      intent(IN) :: npy
         integer,      intent(IN) :: nregions
         real  , intent(IN)  :: p(npx-1,npy-1,nregions)

         real(kind=4) :: p_R4(npx-1,npy-1,nregions)
         integer :: i,j,n

         do n=tile,tile
            do j=j1,j2
               do i=i1,i2
                  p_R4(i,j,n) = p(i,j,n)
               enddo
            enddo
         enddo

         call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, nregions) 

         if (gid == masterproc) then
            write(iout,rec=nrec) p_R4(1:npx-1,1:npy-1,1:nregions)
         endif ! masterproc

      end subroutine wrt2d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!     init_double_periodic
!
      subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz,  uc,vc, ua,va, ak, bk,  &
                                      npx, npy, npz, ng, ncnst, nwat, k_top, ndims, nregions, dry_mass, &
                                      mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0)

#ifdef QS_TEST
!       use mp_lin_mod, only: qsmith
#endif
        real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1,npz)
        real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  ,npz)
        real ,      intent(INOUT) ::    w(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) ::   pt(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) :: delp(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) ::    q(isd:ied  ,jsd:jed  ,npz, ncnst)
        
        real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )

        real ,      intent(INOUT) ::   ps(isd:ied  ,jsd:jed  )
        real ,      intent(INOUT) ::   pe(is-1:ie+1,npz+1,js-1:je+1)
        real ,      intent(INOUT) ::   pk(is:ie    ,js:je    ,npz+1)
        real ,      intent(INOUT) :: peln(is :ie   ,npz+1    ,js:je)
        real ,      intent(INOUT) ::  pkz(is:ie    ,js:je    ,npz  )
        
        real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  ,npz)
        real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1,npz)
        real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(inout) :: delz(is:ie,js:je,npz)
        real ,      intent(inout)   ::  ze0(is:ie,js:je,npz+1)
        
        real ,      intent(inout)    ::   ak(npz+1)
        real ,      intent(inout)    ::   bk(npz+1)
        
        integer,      intent(IN) :: npx, npy, npz
        integer,      intent(IN) :: ng, ncnst, nwat
        integer,      intent(IN) :: k_top
        integer,      intent(IN) :: ndims
        integer,      intent(IN) :: nregions
        
        real,         intent(IN) :: dry_mass
        logical,      intent(IN) :: mountain
        logical,      intent(IN) :: moist_phys
        logical,      intent(IN) :: hydrostatic, hybrid_z

        real, dimension(is:ie):: pm, qs
        real :: dist, r0, f0_const, prf
        real :: ptmp, ze, zc, zm
        real :: t00, p00, xmax, xc, xx, yy, zz, pk0, pturb, ztop
        real :: ze1(npz+1)
        integer :: i, j, k, m, icenter, jcenter

        f0_const = 2.*omega*sin(deglat/180.*pi)
        f0(:,:) = f0_const
        fC(:,:) = f0_const

        q = 0.

        select case (test_case)
        case ( 1 )

           phis(:,:)=0.

           u (:,:,:)=10.
           v (:,:,:)=10.
           ua(:,:,:)=10.
           va(:,:,:)=10.
           uc(:,:,:)=10.
           vc(:,:,:)=10.
           pt(:,:,:)=1.
           delp(:,:,:)=0.
           
           do j=js,je
              if (j>0 .and. j<5) then
                 do i=is,ie
                    if (i>0 .and. i<5) then
                       delp(i,j,:)=1.
                    endif
                 enddo
              endif
           enddo
           call mpp_update_domains( delp, domain )

        case ( 2 )

           phis(:,:) = 0.

!          r0 = 5000.
           r0 = 5.*sqrt(dx_const**2 + dy_const**2)
           icenter = npx/2
           jcenter = npy/2
           do j=jsd,jed
              do i=isd,ied
                 dist=(i-icenter)*dx_const*(i-icenter)*dx_const   &
                       +(j-jcenter)*dy_const*(j-jcenter)*dy_const
                 dist=min(r0,sqrt(dist))
                 phis(i,j)=1500.*(1. - (dist/r0))
              enddo
           enddo

           u (:,:,:)=0.
           v (:,:,:)=0.
           ua(:,:,:)=0.
           va(:,:,:)=0.
           uc(:,:,:)=0.
           vc(:,:,:)=0.
           pt(:,:,:)=1.
           delp(:,:,:)=1500.

        case ( 14 )
!---------------------------
! Doubly periodic Aqua-plane
!---------------------------
           u(:,:,:) = 0.
           v(:,:,:) = 0.
           do j=jsd,jed
              do i=isd,ied
                 phis(i,j) = 0.
                   ps(i,j) = 1000.E2
              enddo
           enddo

           do k=1,npz
              do j=jsd,jed
                 do i=isd,ied
                    pt(i,j,k) = 250.  ! really cold start
                    delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
                 enddo
              enddo
           enddo

! *** Add Initial perturbation ***
           r0 = 20.*sqrt(dx_const**2 + dy_const**2)
!          icenter = npx/2
!          jcenter = npy/2
! Off center for spin up hurricanes
           icenter = npx/2 + 1
           jcenter = npy/2 + 1

           do j=js,je
              do i=is,ie
                 dist = (i-icenter)*dx_const*(i-icenter)*dx_const   &
                         +(j-jcenter)*dy_const*(j-jcenter)*dy_const
                 dist = min(r0,sqrt(dist))
                 do k=1,npz
                    prf = ak(k) + ps(i,j)*bk(k)
                    if ( prf > 100.E2 ) then
                         pt(i,j,k) = pt(i,j,k) + 50.*(1. - (dist/r0)) * prf/ps(i,j) 
                    endif
                 enddo
              enddo
           enddo

          call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps,   &
                     pe, peln, pk, pkz, kappa, q, ng, ncnst, dry_mass, .false., .false., &
                     moist_phys, .true., k_top, nwat)

          q = 0.
#ifdef QS_TEST
         do k=3,npz
            do j=js,je
               do i=is,ie
                  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
               enddo
!              call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
               do i=is,ie
!                 q(i,j,k,1) = 0.99*qs(i)
                  q(i,j,k,1) = 1.e-4
               enddo
            enddo
         enddo
#else
          if ( ncnst==6 ) then
              do j=js,je
                 do i=is,ie
                    q(i,j,1,1:6) = 1.
                 enddo
              enddo
              do m=1,ncnst
              do j=js,je
                 do i=is,ie
                    q(i,j,npz,m) = m
                 enddo
              enddo
              enddo
          endif
#endif

        case ( 15 )
!---------------------------
! Doubly periodic bubble
!---------------------------
           u(:,:,:) = 0.
           v(:,:,:) = 0.
          q(:,:,:,:) = 1.
           do j=jsd,jed
              do i=isd,ied
                 phis(i,j) = 0.
                   ps(i,j) = 1000.E2
              enddo
           enddo

           do k=1,npz
              do j=jsd,jed
                 do i=isd,ied
                    delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
                 enddo
              enddo
           enddo

           do k=1,npz
              do j=jsd,jed
                 do i=isd,ied
                           ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
                      pt(i,j,k) = 300.*(ps(i,j)/ptmp)**kappa
                 enddo
              enddo
           enddo

          call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps,   &
                     pe, peln, pk, pkz, kappa, q, ng, ncnst, dry_mass, .false., .false., &
                     moist_phys, .false., k_top, nwat, .true.)

! *** Add Initial perturbation ***
           r0 = 0.5e3         ! 500 m
           zc = 0.5e3         ! center of bubble 
           icenter = npx/2
           jcenter = npy/2

           do j=jsd,jed
              do i=isd,ied
                 ze = 0.
                 do k=npz,1,-1
!                   ptmp = 0.5*(ak(k+1)+ak(k) + ps(i,j)*(bk(k+1)+bk(k))) 
                    zm = ze - 0.5*delz(i,j,k)   ! layer center
                    ze = ze - delz(i,j,k)
                    dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 +  &
                           (zm-zc)**2
                    if ( sqrt(dist) <= r0 ) then
                         pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
                    endif
                 enddo
              enddo
           enddo
        case ( 16 )
!------------------------------------
! Non-hydrostatic 3D density current:
!------------------------------------
           phis = 0.
           u = 0.
           v = 0.
           w = 0.
          t00 = 300.
          p00 = 1.E5
          pk0 = p00**kappa
! Set up vertical coordinare with constant del-z spacing:
! Control: npz=64;  dx = 100 m; dt = 1; n_split=10
          ztop = 6.4E3
         ze1(    1) = ztop
         ze1(npz+1) = 0.
         do k=npz,2,-1
            ze1(k) = ze1(k+1) + ztop/real(npz)
         enddo

          do j=js,je
             do i=is,ie
                ps(i,j) = p00
                pe(i,npz+1,j) = p00
                pk(i,j,npz+1) = pk0
             enddo
          enddo

          do k=npz,1,-1
             do j=js,je
                do i=is,ie
                   delz(i,j,k) = ze1(k+1) - ze1(k)
                     pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
                     pe(i,k,j) = pk(i,j,k)**(1./kappa) 
                enddo
             enddo
          enddo

          ptop = pe(is,1,js)
          if ( gid==masterproc ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.

          do k=1,npz+1
             do j=js,je
                do i=is,ie
                   peln(i,k,j) = log(pe(i,k,j)) 
                    ze0(i,j,k) = ze1(k)
                enddo
             enddo
          enddo

          do k=1,npz
             do j=js,je
                do i=is,ie
                   pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
                  delp(i,j,k) =  pe(i,k+1,j)-pe(i,k,j)  
                    pt(i,j,k) = t00/pk0   ! potential temp
                enddo
             enddo
          enddo

          pturb = 15.
           xmax = 51.2E3 
             xc = xmax / 2.

         do k=1,npz
            zz = (0.5*(ze1(k)+ze1(k+1))-3.E3) / 2.E3
            do j=js,je
               do i=is,ie
! Impose perturbation in potential temperature: pturb
                  xx = (dx_const * (0.5+real(i-1)) - xc) / 4.E3 
                  yy = (dy_const * (0.5+real(j-1)) - xc) / 4.E3
                  dist = sqrt( xx**2 + yy**2 + zz**2 )
                  if ( dist<=1. ) then
                       pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2. 
                  endif
! Transform back to temperature:
                  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
               enddo
            enddo
          enddo

        end select

      end subroutine init_double_periodic

      subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz,  uc,vc, ua,va, ak, bk,  &
                             npx, npy, npz, ng, ncnst, k_top, ndims, nregions, dry_mass,    &
                             mountain, moist_phys, hybrid_z, delz, ze0)

        real ,      intent(INOUT) ::    u(isd:ied  ,jsd:jed+1,npz)
        real ,      intent(INOUT) ::    v(isd:ied+1,jsd:jed  ,npz)
        real ,      intent(INOUT) ::   pt(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) :: delp(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) ::    q(isd:ied  ,jsd:jed  ,npz, ncnst)
        
        real ,      intent(INOUT) :: phis(isd:ied  ,jsd:jed  )

        real ,      intent(INOUT) ::   ps(isd:ied  ,jsd:jed  )
        real ,      intent(INOUT) ::   pe(is-1:ie+1,npz+1,js-1:je+1)
        real ,      intent(INOUT) ::   pk(is:ie    ,js:je    ,npz+1)
        real ,      intent(INOUT) :: peln(is :ie   ,npz+1    ,js:je)
        real ,      intent(INOUT) ::  pkz(is:ie    ,js:je    ,npz  )
        
        real ,      intent(INOUT) ::   uc(isd:ied+1,jsd:jed  ,npz)
        real ,      intent(INOUT) ::   vc(isd:ied  ,jsd:jed+1,npz)
        real ,      intent(INOUT) ::   ua(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(INOUT) ::   va(isd:ied  ,jsd:jed  ,npz)
        real ,      intent(inout) :: delz(is:ie,js:je,npz)
        real ,      intent(inout)   ::  ze0(is:ie,js:je,npz+1)
        
        real ,      intent(IN)    ::   ak(npz+1)
        real ,      intent(IN)    ::   bk(npz+1)
        
        integer,      intent(IN) :: npx, npy, npz
        integer,      intent(IN) :: ng, ncnst
        integer,      intent(IN) :: k_top
        integer,      intent(IN) :: ndims
        integer,      intent(IN) :: nregions
        
        real,         intent(IN) :: dry_mass
        logical,      intent(IN) :: mountain
        logical,      intent(IN) :: moist_phys
        logical,      intent(IN) :: hybrid_z

        real    :: p1(2), p2(2), r, r0
        integer :: i,j

        do j=jsd,jed+1
           do i=isd,ied+1
              fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha)  &
                                   +sin(grid(i,j,2))*cos(alpha) )
           enddo
        enddo
        do j=jsd,jed
           do i=isd,ied
              f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha)  &
                                   +sin(agrid(i,j,2))*cos(alpha) )
           enddo
        enddo

        select case (test_case)
        case ( 1 )

         Ubar = (2.0*pi*radius)/(12.0*86400.0)
         phis = 0.0
         r0 = radius/3. !RADIUS radius/3.
!!$         p1(1) = 0.
         p1(1) = pi/2. + pi_shift
         p1(2) = 0.
         do j=jsd,jed
            do i=isd,ied
               p2(1) = agrid(i,j,1)
               p2(2) = agrid(i,j,2)
               r = great_circle_dist( p1, p2, radius )
               if (r < r0) then
                  delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(PI*r/r0))
               else
                  delp(i,j,1) = phis(i,j)
               endif
            enddo
         enddo
         call init_latlon_winds(UBar, u, v, ua, va, uc, vc, 1)


!!$           phis(:,:)=0.
!!$
!!$           u (:,:,:)=10.
!!$           v (:,:,:)=10.
!!$           ua(:,:,:)=10.
!!$           va(:,:,:)=10.
!!$           uc(:,:,:)=10.
!!$           vc(:,:,:)=10.
!!$           pt(:,:,:)=1.
!!$           delp(:,:,:)=0.
!!$           
!!$           do j=js,je
!!$              if (j>10 .and. j<15) then
!!$                 do i=is,ie
!!$                    if (i>10 .and. i<15) then
!!$                       delp(i,j,:)=1.
!!$                    endif
!!$                 enddo
!!$              endif
!!$           enddo
!!$           call mpp_update_domains( delp, domain )

        end select

      end subroutine init_latlon

      subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid)

        ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate

        real,    intent(INOUT) :: UBar
        real,    intent(INOUT) ::  u(isd:ied  ,jsd:jed+1)
        real,    intent(INOUT) ::  v(isd:ied+1,jsd:jed  )
        real,    intent(INOUT) :: uc(isd:ied+1,jsd:jed  )
        real,    intent(INOUT) :: vc(isd:ied  ,jsd:jed+1)
        real,    intent(INOUT) :: ua(isd:ied  ,jsd:jed  )
        real,    intent(INOUT) :: va(isd:ied  ,jsd:jed  )
        integer, intent(IN)    :: defOnGrid

        real   :: p1(2),p2(2),p3(2),p4(2), pt(2)
        real :: e1(3), e2(3), ex(3), ey(3)

        real   :: dist, r, r0 
        integer :: i,j,k,n
        real :: utmp, vtmp

        real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2 

        psi(:,:) = 1.e25
        psi_b(:,:) = 1.e25
        do j=jsd,jed
           do i=isd,ied
              psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2))                  *cos(alpha) - &
                                                  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
           enddo
        enddo
        do j=jsd,jed+1
           do i=isd,ied+1
              psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2))                 *cos(alpha) - &
                                                    cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
           enddo
        enddo
        
        if ( defOnGrid == 1 ) then
           do j=jsd,jed+1
              do i=isd,ied
                 dist = dx(i,j)
                 vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
                 if (dist==0) vc(i,j) = 0.
              enddo
           enddo
           do j=jsd,jed
              do i=isd,ied+1
                 dist = dy(i,j)
                 uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
                 if (dist==0) uc(i,j) = 0.
              enddo
           enddo

           
           do j=js,je
              do i=is,ie+1
                 dist = dxc(i,j)
                 v(i,j) = (psi(i,j)-psi(i-1,j))/dist
                 if (dist==0) v(i,j) = 0.            
              enddo
           enddo
           do j=js,je+1
              do i=is,ie
                 dist = dyc(i,j)
                 u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
                 if (dist==0) u(i,j) = 0. 
              enddo
           enddo
        endif
     
      end subroutine init_latlon_winds
      
end module test_cases_mod



module betts_miller_mod

!----------------------------------------------------------------------
!use      utilities_mod, only:  file_exist, error_mesg, open_file,  &
!                               check_nml_error, get_my_pe, FATAL,  &
!                               close_file

use            mpp_mod, only:  input_nml_file
use            fms_mod, only:  file_exist, error_mesg, open_namelist_file, &
                               check_nml_error, mpp_pe, mpp_root_pe, &
                               FATAL, close_file, write_version_number, stdlog

use sat_vapor_pres_mod, only:  escomp, descomp
use      constants_mod, only:  HLv,HLs,Cp_air,Grav,rdgas,rvgas, &
                               kappa, es0

implicit none
private
!---------------------------------------------------------------------
!  ---- public interfaces ----

   public  betts_miller, betts_miller_init, betts_miller_end

!-----------------------------------------------------------------------
!   ---- version number ----

 character(len=128) :: version = '$Id: betts_miller.F90,v 18.0.2.1 2010/08/30 20:39:42 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
!   ---- local/private data ----

    real, parameter :: d622 = rdgas/rvgas
    real, parameter :: d378 = 1.-d622

    logical :: module_is_initialized=.false.

!-----------------------------------------------------------------------
!   --- namelist ----

real    :: tau_bm=7200.
real    :: rhbm = .8
logical :: do_simp = .true.
!logical :: do_enadjusttemp = .false.
logical :: do_shallower = .false.
logical :: do_changeqref = .false.
logical :: do_envsat = .false.
logical :: do_taucape = .false.
real    :: capetaubm = 900.
real    :: tau_min = 2400.

namelist /betts_miller_nml/  tau_bm, rhbm, do_simp, &
!                            do_enadjusttemp, &
                            do_shallower, do_changeqref, &
                            do_envsat, do_taucape, capetaubm, tau_min

!-----------------------------------------------------------------------
!           description of namelist variables
!
!  tau_bm    =  betts-miller relaxation timescale (seconds)
!
!  rhbm      = relative humidity that you're relaxing towards
!
!  do_simp = do the simple method where you adjust timescales to make 
!            precip continuous always
!
!  do_enadjusttemp = do the betts-miller (1986) way of conserving energy:
!                    adjust the reference temperature by a fixed amount w/ 
!                    height.  

! ***   if neither of the two above are true, then we instead adjust the 
!       humidity profile so its precipitation is increased to balance the 
!       precip_t change, and hence dries more than the 
! 
!  do_shallower = do the shallow convection scheme where it chooses a smaller
!                 depth such that precipitation is zero
! 
!  do_changeqref = do the shallow convection scheme where if changes the 
!                  profile of both q and T in order make precip zero
! 
!  do_envsat = reference profile is rhbm times saturated wrt environment 
!              (if false, it's rhbm times parcel)
!  
!  do_taucape = scheme where taubm is proportional to CAPE**-1/2
!
!  capetaubm = for the above scheme, the value of CAPE for which 
!              tau = tau_bm
!  
!  tau_min   = minimum relaxation time allowed for the above scheme
!
!  
!
!-----------------------------------------------------------------------

contains

!#######################################################################

   subroutine betts_miller (dt, tin, qin, pfull, phalf, coldT, &
                           rain, snow, tdel, qdel, q_ref, bmflag, &
                           klzbs, cape, cin, t_ref,invtau_bm_t,invtau_bm_q, &
                           mask, conv)

!-----------------------------------------------------------------------
!
!                     Betts-Miller Convection Scheme
!
!-----------------------------------------------------------------------
!
!   input:  dt       time step in seconds
!           tin      temperature at full model levels
!           qin      specific humidity of water vapor at full
!                      model levels
!           pfull    pressure at full model levels
!           phalf    pressure at half (interface) model levels
!           coldT    should precipitation be snow at this point?
!   optional:
!           mask     optional mask (0 or 1.) 
!           conv     logical flag; if true then no betts-miller
!                       adjustment is performed at that grid-point or
!                       model level
!
!  output:  rain     liquid precipitation (kg/m2)
!           snow     frozen precipitation (kg/m2)
!           tdel     temperature tendency at full model levels
!           qdel     specific humidity tendency (of water vapor) at
!                      full model levels
!           bmflag   flag for which routines you're calling
!           klzbs    stored klzb values
!           cape     convectively available potential energy 
!           cin      convective inhibition (this and the above are before the 
!                    adjustment)
!           invtau_bm_t temperature relaxation timescale
!           invtau_bm_q humidity relaxation timescale
!
!-----------------------------------------------------------------------
!--------------------- interface arguments -----------------------------

   real   , intent(in) , dimension(:,:,:) :: tin, qin, pfull, phalf
   real   , intent(in)                    :: dt
   logical   , intent(in) , dimension(:,:):: coldT
   real   , intent(out), dimension(:,:)   :: rain,snow, bmflag, klzbs, cape, &
       cin, invtau_bm_t, invtau_bm_q
   real   , intent(out), dimension(:,:,:) :: tdel, qdel, q_ref, t_ref
   real   , intent(in) , dimension(:,:,:), optional :: mask
   logical, intent(in) , dimension(:,:,:), optional :: conv
!-----------------------------------------------------------------------
!---------------------- local data -------------------------------------

   logical :: avgbl
   real,dimension(size(tin,1),size(tin,2),size(tin,3)) :: rin
   real,dimension(size(tin,1),size(tin,2))             :: precip, precip_t
   real,dimension(size(tin,3))                         :: rpc, tpc

   real                                                :: &
       cape1, cin1, tot, deltak, deltaq, qrefint, deltaqfrac, deltaqfrac2, &
       ptopfrac, es, small
integer  i, j, k, ix, jx, kx, klzb, ktop
!-----------------------------------------------------------------------
!     computation of precipitation by betts-miller scheme
!-----------------------------------------------------------------------

      if (.not. module_is_initialized) call error_mesg ('betts_miller',  &
                         'betts_miller_init has not been called.', FATAL)

      ix=size(tin,1)
      jx=size(tin,2)
      kx=size(tin,3)
      avgbl = .false.
      small = 1.e-10

! calculate r
       rin = qin/(1.0 - qin)
       do i=1,ix
          do j=1,jx
             cape1 = 0.
             cin1 = 0.
             tot = 0.
             klzb=0
! the bmflag is written out to show what aspects of the bm scheme is called
! bmflag = 0 is no cape, no convection
! bmflag = 1 is shallow conv, the predicted precip is less than zero
! bmflag = 2 is deep convection
             bmflag(i,j) = 0.
             tpc = tin(i,j,:)
             rpc = rin(i,j,:)
! calculate cape, cin, level of zero buoyancy, and parcel properties 
! new code (second order in delta ln p and exact LCL calculation)
             call capecalcnew( kx,  pfull(i,j,:),  phalf(i,j,:),&
                            cp_air, rdgas, rvgas, hlv, kappa, tin(i,j,:), &
                            rin(i,j,:), avgbl, cape1, cin1, tpc, &
                            rpc, klzb)

! set values for storage
             cape(i,j) = cape1
             cin(i,j) = cin1
             klzbs(i,j) = klzb
             if(cape1.gt.0.) then 
!             if((tot.gt.0.).and.(cape1.gt.0.)) then 
                bmflag(i,j) = 1.
! reference temperature is just that of the parcel all the way up
                t_ref(i,j,:) = tpc
                do k=klzb,kx
! sets reference spec hum to a certain relative hum (change to vapor pressure, 
! multiply by rhbm, then back to spec humid)
                   if(do_envsat) then 
!                      call establ2(es,tin(i,j,k))
                      call escomp(tin(i,j,k),es)
                      es = es*rhbm
!                      rpc(k) = d622*es/(pfull(i,j,k) - d378*es)
                      rpc(k) = rdgas/rvgas*es/pfull(i,j,k)
                      q_ref(i,j,k) = rpc(k)/(1 + rpc(k))
                   else 
                      rpc(k) = rhbm*rpc(k)
!                      eref(k) = rhbm*pfull(i,j,k)*rpc(k)/(d622 + d378*rpc(k))
!                      rpc(k) = d622*eref(k)/(pfull(i,j,k) - d378*eref(k))
                      q_ref(i,j,k) = rpc(k)/(1 + rpc(k))
                   endif 
                end do
! set the tendencies to zero where you don't adjust
! set the reference profiles to be the original profiles (for diagnostic 
! purposes only --  you can think of this as what you're relaxing to in
! areas above the actual convection
                do k=1,max(klzb-1,1)
                   qdel(i,j,k) = 0.0
                   tdel(i,j,k) = 0.0
                   q_ref(i,j,k) = qin(i,j,k)
                   t_ref(i,j,k) = tin(i,j,k)
                end do
! initialize p to zero for the loop
                precip(i,j) = 0.
                precip_t(i,j) = 0.
! makes t_bm prop to (CAPE)**-.5.  Gives a relaxation time of tau_bm when 
! CAPE = sqrt(capetaubm)
                if(do_taucape) then
                   tau_bm = sqrt(capetaubm)*tau_bm/sqrt(cape1)
                   if(tau_bm.lt.tau_min) tau_bm = tau_min
                endif 
                do k=klzb, kx
! relax to reference profiles
                   tdel(i,j,k) = - (tin(i,j,k) - t_ref(i,j,k))/tau_bm*dt
                   qdel(i,j,k) = - (qin(i,j,k) - q_ref(i,j,k))/tau_bm*dt
! Precipitation can be calculated already, based on the change in q on the 
! way up (this isn't altered in the energy conservation scheme).  
                   precip(i,j) = precip(i,j) - qdel(i,j,k)*(phalf(i,j,k+1)- &
                                 phalf(i,j,k))/grav
                   precip_t(i,j)= precip_t(i,j) + cp_air/(hlv+small)*tdel(i,j,k)* &
                                 (phalf(i,j,k+1)-phalf(i,j,k))/grav
                end do
                if ((precip(i,j).gt.0.).and.(precip_t(i,j).gt.0.)) then 
! If precip > 0, then correct energy. 
                   bmflag(i,j) = 2.
                   if(precip(i,j).gt.precip_t(i,j)) then
! if the q precip is greater, then lengthen the relaxation timescale on q to
! conserve energy.  qdel is therefore changed.
                      invtau_bm_q(i,j) = precip_t(i,j)/precip(i,j)/tau_bm
                      qdel(i,j,klzb:kx) = tau_bm*invtau_bm_q(i,j)* &
                         qdel(i,j,klzb:kx)
                      precip(i,j) = precip_t(i,j)
                      invtau_bm_t(i,j) = 1./tau_bm
                   else
                      if(do_simp) then
! simple scheme:
! if the t precip is greater, then lengthen the relaxation timescale on t to
! conserve energy.  tdel is therefore changed.
                         invtau_bm_t(i,j) = precip(i,j)/precip_t(i,j)/tau_bm
                         tdel(i,j,klzb:kx) = tau_bm*invtau_bm_t(i,j)* &
                            tdel(i,j,klzb:kx)
                         invtau_bm_q(i,j) = 1./tau_bm
!                      else if(do_enadjusttemp)
                      else
! not simple scheme: shift the reference profile of temperature
! deltak is the energy correction that you make to the temperature reference
! profile
                         deltak = 0.
                         do k=klzb, kx
! Calculate the integrated difference in energy change within each level.
                            deltak = deltak - (tdel(i,j,k) + hlv/cp_air*&
                                     qdel(i,j,k))* &
                                     (phalf(i,j,k+1) - phalf(i,j,k))
                         end do
! Divide by total pressure.
                         deltak = deltak/(phalf(i,j,kx+1) - phalf(i,j,klzb))
! Adjust the reference profile (uniformly with height), and correspondingly 
! the temperature change.
                         t_ref(i,j,klzb:kx) = t_ref(i,j,klzb:kx)+ &
                              deltak*tau_bm/dt
                         tdel(i,j,klzb:kx) = tdel(i,j,klzb:kx) + deltak
                      endif
                   endif
                else if(precip_t(i,j).gt.0.) then
! If precip < 0, then do the shallow conv routine.
! First option: do_shallower = true
! This chooses the depth of convection based on choosing the height that 
! it can make precip zero, i.e., subtract off heights until that precip 
! becomes positive.  
                   if (do_shallower) then
! ktop is the new top of convection.  set this initially to klzb.
                      ktop = klzb
! Work your way down until precip is positive again.
                      do while ((precip(i,j).lt.0.).and.(ktop.le.kx))
                         precip(i,j) = precip(i,j) - qdel(i,j,ktop)* &
                                  (phalf(i,j,ktop) - phalf(i,j,ktop+1))/grav
                         ktop = ktop + 1
                      end do
! since there will be an overshoot (precip is going to be greater than zero 
! once we finish this), the actual new top of convection is somewhere between
! the current ktop, and one level above this.  set ktop to the level above.
                      ktop = ktop - 1
! Adjust the tendencies in the places above back to zero, and the reference 
! profiles back to the original t,q.
                      if (ktop.gt.klzb) then
                         qdel(i,j,klzb:ktop-1) = 0.
                         q_ref(i,j,klzb:ktop-1) = qin(i,j,klzb:ktop-1)
                         tdel(i,j,klzb:ktop-1) = 0.
                         t_ref(i,j,klzb:ktop-1) = tin(i,j,klzb:ktop-1)
                      end if
! Then make the change only a fraction of the new top layer so the precip is 
! identically zero.
! Calculate the fractional penetration of convection through that top layer.  
! This is the amount necessary to make precip identically zero.  
                      if (precip(i,j).gt.0.) then 
                         ptopfrac = precip(i,j)/(qdel(i,j,ktop)* &
                            (phalf(i,j,ktop+1) - phalf(i,j,ktop)))*grav
! Reduce qdel in the top layer by this fraction. 
                         qdel(i,j,ktop) = ptopfrac*qdel(i,j,ktop)
! Set precip to zero
                         precip(i,j) = 0.
! Now change the reference temperature in such a way to make the net 
! heating zero.
!! Reduce tdel in the top layer
                         tdel(i,j,ktop) = ptopfrac*tdel(i,j,ktop)
                         deltak = 0.
                         if (ktop.lt.kx) then
! Integrate temperature tendency up to 1 level below top.
                            do k=ktop,kx
                               deltak = deltak + tdel(i,j,k)* &
                                   (phalf(i,j,k) - phalf(i,j,k+1))
                            end do
! Normalize by the pressure difference.
                            deltak = deltak/(phalf(i,j,kx+1) - phalf(i,j,ktop))
! Subtract this value uniformly from tdel, and make the according change to 
! t_ref.
                            do k=ktop,kx
                               tdel(i,j,k) = tdel(i,j,k) + deltak
                               t_ref(i,j,k) = t_ref(i,j,k) + deltak*tau_bm/dt
                            end do
                         end if
                      else
                         precip(i,j) = 0.
                         qdel(i,j,kx) = 0.
                         q_ref(i,j,kx) = qin(i,j,kx)
                         tdel(i,j,kx) = 0.
                         t_ref(i,j,kx) = tin(i,j,kx)
                         invtau_bm_t(i,j) = 0.
                         invtau_bm_q(i,j) = 0.
                      end if
                   else if(do_changeqref) then
! Change the reference profile of q by a certain fraction so that precip is 
! zero.  This involves calculating the total integrated q_ref dp (this is the
! quantity intqref), as well as the necessary change in q_ref (this is the 
! quantity deltaq).  Then the fractional change in q_ref at each level (the 
! quantity deltaqfrac) is 1-deltaq/intqref.  (have to multiply q_ref by 
! 1-deltaq/intqref at every level)  Then the change in qdel is 
! -deltaq/intqref*q_ref*dt/tau_bm.
! Change the reference profile of T by a uniform amount so that precip is zero.
                      deltak = 0.
                      deltaq = 0.
                      qrefint = 0.
                      do k=klzb,kx
! deltaq = a positive quantity (since int qdel is positive).  It's how 
! much q_ref must be changed by, in an integrated sense.  The requisite 
! change in qdel is this without the factors of tau_bm and dt.
                         deltaq = deltaq - qdel(i,j,k)*tau_bm/dt* &
                                   (phalf(i,j,k) - phalf(i,j,k+1))
! deltak = the amount tdel needs to be changed
                         deltak  = deltak  + tdel(i,j,k)* &
                                   (phalf(i,j,k) - phalf(i,j,k+1))
! qrefint = integrated value of qref
                         qrefint = qrefint - q_ref(i,j,k)* &
                                   (phalf(i,j,k) - phalf(i,j,k+1))
                      end do
! Normalize deltak by total pressure.
                      deltak  = deltak /(phalf(i,j,kx+1) - phalf(i,j,klzb))
! multiplying factor for q_ref is 1 + the ratio
                      deltaqfrac = 1. - deltaq/qrefint
! multiplying factor for qdel adds dt/tau_bm
                      deltaqfrac2 = - deltaq/qrefint*dt/tau_bm
                      precip(i,j) = 0.0
                      do k=klzb,kx
                         qdel(i,j,k) = qdel(i,j,k) + deltaqfrac2*q_ref(i,j,k)
                         q_ref(i,j,k) = deltaqfrac*q_ref(i,j,k)
                         tdel(i,j,k) = tdel(i,j,k) + deltak
                         t_ref(i,j,k) = t_ref(i,j,k) + deltak*tau_bm/dt
                      end do
                   else
                      precip(i,j) = 0.
                      tdel(i,j,:) = 0.
                      qdel(i,j,:) = 0.
                      invtau_bm_t(i,j) = 0.
                      invtau_bm_q(i,j) = 0.
                   end if
! for cases where virtual temp predicts CAPE but precip_t < 0.
                else
                   tdel(i,j,:) = 0.0
                   qdel(i,j,:) = 0.0
                   precip(i,j) = 0.0
                   q_ref(i,j,:) = qin(i,j,:)
                   t_ref(i,j,:) = tin(i,j,:)
                   invtau_bm_t(i,j) = 0.
                   invtau_bm_q(i,j) = 0.
                end if
! if no CAPE, set tendencies to zero.
             else 
                tdel(i,j,:) = 0.0
                qdel(i,j,:) = 0.0
                precip(i,j) = 0.0
                q_ref(i,j,:) = qin(i,j,:)
                t_ref(i,j,:) = tin(i,j,:)
                invtau_bm_t(i,j) = 0.
                invtau_bm_q(i,j) = 0.
             end if
          end do
       end do

       rain = precip
       snow = 0.
   

   end subroutine betts_miller

!#######################################################################

!all new cape calculation.

      subroutine capecalcnew(kx,p,phalf,cp_air,rdgas,rvgas,hlv,kappa,tin,rin,&
                             avgbl,cape,cin,tp,rp,klzb)

!
!    Input:
!
!    kx          number of levels
!    p           pressure (index 1 refers to TOA, index kx refers to surface)
!    phalf       pressure at half levels
!    cp_air      specific heat of dry air
!    rdgas       gas constant for dry air
!    rvgas       gas constant for water vapor (used in Clausius-Clapeyron, 
!                not for virtual temperature effects, which are not considered)
!    hlv         latent heat of vaporization
!    kappa       the constant kappa
!    tin         temperature of the environment
!    rin         specific humidity of the environment
!    avgbl       if true, the parcel is averaged in theta and r up to its LCL
!
!    Output:
!    cape        Convective available potential energy
!    cin         Convective inhibition (if there's no LFC, then this is set 
!                to zero)
!    tp          Parcel temperature (set to the environmental temperature 
!                where no adjustment)
!    rp          Parcel specific humidity (set to the environmental humidity 
!                where no adjustment, and set to the saturation humidity at 
!                the parcel temperature below the LCL)
!    klzb        Level of zero buoyancy
!
!    Algorithm: 
!    Start with surface parcel. 
!    Calculate the lifting condensation level (uses an analytic formula and a 
!       lookup table).  
!    Average under the LCL if desired, if this is done, then a new LCL must
!       be calculated.  
!    Calculate parcel ascent up to LZB.
!    Calculate CAPE and CIN.  
      implicit none
      integer, intent(in)                    :: kx
      logical, intent(in)                    :: avgbl
      real, intent(in), dimension(:)         :: p, phalf, tin, rin
      real, intent(in)                       :: rdgas, rvgas, hlv, kappa, cp_air
      integer, intent(out)                   :: klzb
      real, intent(out), dimension(:)        :: tp, rp
      real, intent(out)                      :: cape, cin

      integer            :: k, klcl, klfc, klcl2
      logical            :: nocape
      real, dimension(kx)   :: theta
      real                  :: t0, r0, es, rs, theta0, pstar, value, tlcl, &
                               a, b, dtdlnp, thetam, rm, tlcl2, &
                               plcl2, plcl, plzb, small

      pstar = 1.e5
! so we can run dry limit (one expression involves 1/hlv)
      small = 1.e-10

      nocape = .true.
      cape = 0.
      cin = 0.
      plcl = 0.
      plzb = 0.
      klfc = 0
      klcl = 0
      klzb = 0
      tp(1:kx) = tin(1:kx)
      rp(1:kx) = rin(1:kx)

! start with surface parcel
      t0 = tin(kx)
      r0 = rin(kx)
! calculate the lifting condensation level by the following:
! are you saturated to begin with?  
      call escomp(t0,es)
      rs = rdgas/rvgas*es/p(kx)
      if (r0.ge.rs) then
! if youre already saturated, set lcl to be the surface value.
         plcl = p(kx)
! the first level where youre completely saturated.
         klcl = kx
! saturate out to get the parcel temp and humidity at this level
! first order (in delta T) accurate expression for change in temp
         tp(kx) = t0 + (r0 - rs)/(cp_air/(hlv+small) + hlv*rs/rvgas/t0**2.)
         call escomp(tp(kx),es)
         rp(kx) = rdgas/rvgas*es/p(kx)
      else
! if not saturated to begin with, use the analytic expression to calculate the 
! exact pressure and temperature where youre saturated.  
         theta0 = tin(kx)*(pstar/p(kx))**kappa
! the expression that we utilize is 
! log(r/theta**(1/kappa)*pstar*rvgas/rdgas/es00) = log(es/T**(1/kappa))
! (the division by es00 is necessary because the RHS values are tabulated
! for control moisture content)
! The right hand side of this is only a function of temperature, therefore 
! this is put into a lookup table to solve for temperature.  
         if (r0.gt.0.) then
            value = log(theta0**(-1/kappa)*r0*pstar*rvgas/rdgas/es0)
            call lcltabl(value,tlcl)
            plcl = pstar*(tlcl/theta0)**(1/kappa)
! just in case plcl is very high up
            if (plcl.lt.p(1)) then
               plcl = p(1)
               tlcl = theta0*(plcl/pstar)**kappa
               write (*,*) 'hi lcl'
            end if
            k = kx
         else
! if the parcel sp hum is zero or negative, set lcl to top level
            plcl = p(1)
            tlcl = theta0*(plcl/pstar)**kappa
!            write (*,*) 'zero r0', r0
            do k=1,kx
               tp(k) = theta0*(p(k)/pstar)**kappa
               rp(k) = 0.
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            end do
            go to 11
         end if
! calculate the parcel temperature (adiabatic ascent) below the LCL.  
! the mixing ratio stays the same
         do while (p(k).gt.plcl)
            tp(k) = theta0*(p(k)/pstar)**kappa
            call escomp(tp(k),es)
            rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            k = k-1
         end do
! first level where you're saturated at the level
         klcl = k
         if (klcl.eq.1) klcl = 2
! do a saturated ascent to get the parcel temp at the LCL.  
! use your 2nd order equation up to the pressure above.  
! moist adaibat derivatives: (use the lcl values for temp, humid, and 
! pressure)
         a = kappa*tlcl + hlv/cp_air*r0
         b = hlv**2.*r0/cp_air/rvgas/tlcl**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
! second order in p (RK2)
! first get temp halfway up 
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)/2.
         if ((tp(klcl).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/(p(klcl) + plcl)*2.
         a = kappa*tp(klcl) + hlv/cp_air*rp(klcl)
         b = hlv**2./cp_air/rvgas*rp(klcl)/tp(klcl)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
!         d2tdlnp2 = (kappa + b - 1. - b/tlcl*(hlv/rvgas/tlcl - &
!                   2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*r0/cp_air/ &
!                   (1. + b)
! second order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl) + .5*d2tdlnp2*(log(&
!             p(klcl)/plcl))**2.
         if ((tp(klcl).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/p(klcl)
!         write (*,*) 'tp, rp klcl:kx, new', tp(klcl:kx), rp(klcl:kx)
! CAPE/CIN stuff
         if ((tp(klcl).lt.tin(klcl)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(klcl) - &
                 tp(klcl))*log(phalf(klcl+1)/phalf(klcl))
         else
! if youre buoyant, then add to cape
            cape = cape + rdgas*(tp(klcl) - &
                  tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if its the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = klcl
            endif
         end if
      end if
! then average the properties over the boundary layer if so desired.  to give 
! a new "parcel".  this may not be saturated at the LCL, so make sure you get 
! to a level where it is before moist adiabatic ascent!
!!!! take out all the below (between the exclamation points) if no avgbl !!!!
      if (avgbl) then
         theta(klcl:kx) = tin(klcl:kx)*(pstar/p(klcl:kx))**kappa
         thetam = 0.
         rm = 0.
         do k=klcl,kx
            thetam = thetam + theta(k)*(phalf(k+1) - phalf(k))
            rm = rm + rin(k)*(phalf(k+1) - phalf(k))
         end do
         thetam = thetam/(phalf(kx+1) - phalf(klcl))
         rm = rm/(phalf(kx+1) - phalf(klcl))
! check if you're saturated at the top level.  if not, then get a new LCL
         tp(klcl) = thetam*(p(klcl)/pstar)**kappa
         call escomp(tp(klcl),es)
         rs = rdgas/rvgas*es/p(klcl)
! if you're not saturated, get a new LCL
         if (rm.lt.rs) then
! reset CIN to zero.  
            cin = 0.
! again, use the analytic expression to calculate the exact pressure and 
! temperature where youre saturated.  
! the expression that we utilize is 
! log(r/theta**(1/kappa)*pstar*rvgas/rdgas/es00)= log(es/T**(1/kappa))
! (the division by es00 is necessary because the RHS values are tabulated
! for control moisture content)
! The right hand side of this is only a function of temperature, therefore 
! this is put into a lookup table to solve for temperature.  
            value = log(thetam**(-1/kappa)*rm*pstar*rvgas/rdgas/es0)
            call lcltabl(value,tlcl2)
            plcl2 = pstar*(tlcl2/thetam)**(1/kappa)
! just in case plcl is very high up
            if (plcl2.lt.p(1)) then
               plcl2 = p(1)
            end if
            k = kx
! calculate the parcel temperature (adiabatic ascent) below the LCL.  
! the mixing ratio stays the same
            do while (p(k).gt.plcl2) 
               tp(k) = thetam*(p(k)/pstar)**kappa
               call escomp(tp(k),es)
               rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
               k = k-1
            end do
! first level where youre saturated at the level
            klcl2 = k
            if (klcl2.eq.1) klcl2 = 2
! do a saturated ascent to get the parcel temp at the LCL.  
! use your 2nd order equation up to the pressure above.  
! moist adaibat derivatives: (use the lcl values for temp, humid, and 
! pressure)
            a = kappa*tlcl2 + hlv/cp_air*rm
            b = hlv**2.*rm/cp_air/rvgas/tlcl2**2.
            dtdlnp = a/(1. + b)
! first order in p
!            tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)
! second order in p (RK2)
! first get temp halfway up 
         tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)/2.
         if ((tp(klcl2).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl2),es)
         rp(klcl2) = rdgas/rvgas*es/(p(klcl2) + plcl2)*2.
         a = kappa*tp(klcl2) + hlv/cp_air*rp(klcl2)
         b = hlv**2./cp_air/rvgas*rp(klcl2)/tp(klcl2)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)
!            d2tdlnp2 = (kappa + b - 1. - b/tlcl2*(hlv/rvgas/tlcl2 - &
!                          2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*rm/cp_air/ &
!                          (1. + b)
! second order in p
!            tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2) + &
!               .5*d2tdlnp2*(log(p(klcl2)/plcl2))**2.
            call escomp(tp(klcl2),es)
            rp(klcl2) = rdgas/rvgas*es/p(klcl2)
! CAPE/CIN stuff
            if ((tp(klcl2).lt.tin(klcl2)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
               cin = cin + rdgas*(tin(klcl2) - &
                    tp(klcl2))*log(phalf(klcl2+1)/phalf(klcl2))
            else
! if youre buoyant, then add to cape
               cape = cape + rdgas*(tp(klcl) - &
                     tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if its the first time buoyant, then set the level of free convection to k
               if (nocape) then
                  nocape = .false.
                  klfc = klcl2
               endif
            end if
         end if
      end if
!!!! take out all of the above (within the exclamations) if no avgbl !!!!
! then, start at the LCL, and do moist adiabatic ascent by the first order 
! scheme -- 2nd order as well
      do k=klcl-1,1,-1
         a = kappa*tp(k+1) + hlv/cp_air*rp(k+1)
         b = hlv**2./cp_air/rvgas*rp(k+1)/tp(k+1)**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
! second order in p (RK2)
! first get temp halfway up 
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))/2.
         if ((tp(k).lt.173.16).and.nocape) go to 11
         call escomp(tp(k),es)
         rp(k) = rdgas/rvgas*es/(p(k) + p(k+1))*2.
         a = kappa*tp(k) + hlv/cp_air*rp(k)
         b = hlv**2./cp_air/rvgas*rp(k)/tp(k)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
!         d2tdlnp2 = (kappa + b - 1. - b/tp(k+1)*(hlv/rvgas/tp(k+1) - & 
!               2.)*dtdlnp)/(1. + b)*dtdlnp - hlv/cp_air*rp(k+1)/(1. + b)
! second order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1)) + .5*d2tdlnp2*(log( &
!             p(k)/p(k+1)))**2.
! if you're below the lookup table value, just presume that there's no way 
! you could have cape and call it quits
         if ((tp(k).lt.173.16).and.nocape) go to 11
         call escomp(tp(k),es)
         rp(k) = rdgas/rvgas*es/p(k)
         if ((tp(k).lt.tin(k)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
         elseif((tp(k).lt.tin(k)).and.(.not.nocape)) then
! if you have CAPE, and its your first time being negatively buoyant, 
! then set the level of zero buoyancy to k+1, and stop the moist ascent
            klzb = k+1
            go to 11
         else
! if youre buoyant, then add to cape
            cape = cape + rdgas*(tp(k) - tin(k))*log(phalf(k+1)/phalf(k))
! if its the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = k
            endif
         end if
      end do
 11   if(nocape) then 
! this is if you made it through without having a LZB
! set LZB to be the top level.
         plzb = p(1)
         klzb = 0
         klfc = 0
         cin = 0.
         tp(1:kx) = tin(1:kx)
         rp(1:kx) = rin(1:kx)
      end if
!      write (*,*) 'plcl, klcl, tlcl, r0 new', plcl, klcl, tlcl, r0
!      write (*,*) 'tp, rp new', tp, rp
!       write (*,*) 'tp, new', tp
!       write (*,*) 'tin new', tin 
!       write (*,*) 'klcl, klfc, klzb new', klcl, klfc, klzb
      end subroutine capecalcnew

! lookup table for the analytic evaluation of LCL
      subroutine lcltabl(value,tlcl)
!
! Table of values used to compute the temperature of the lifting condensation
! level.  
! 
! the expression that we utilize is 
! log(r/theta**(1/kappa)*pstar*rvgas/rdgas/es00) = log(es/T**(1/kappa))
! the RHS is tabulated for control moisture content, hence the division 
! by es00 on the LHS
! 
! Gives the values of the temperature for the following range: 
!   starts with -23, is uniformly distributed up to -10.4.  There are a 
! total of 127 values, and the increment is .1.  
!
      implicit none 
      real, intent(in)     :: value
      real, intent(out)    :: tlcl

      integer              :: ival
      real, dimension(127) :: lcltable
      real                 :: v1, v2

      data lcltable/  1.7364512e+02,   1.7427449e+02,   1.7490874e+02, &
      1.7554791e+02,   1.7619208e+02,   1.7684130e+02,   1.7749563e+02, &
      1.7815514e+02,   1.7881989e+02,   1.7948995e+02,   1.8016539e+02, &
      1.8084626e+02,   1.8153265e+02,   1.8222461e+02,   1.8292223e+02, &
      1.8362557e+02,   1.8433471e+02,   1.8504972e+02,   1.8577068e+02, &
      1.8649767e+02,   1.8723077e+02,   1.8797006e+02,   1.8871561e+02, &
      1.8946752e+02,   1.9022587e+02,   1.9099074e+02,   1.9176222e+02, &
      1.9254042e+02,   1.9332540e+02,   1.9411728e+02,   1.9491614e+02, &
      1.9572209e+02,   1.9653521e+02,   1.9735562e+02,   1.9818341e+02, &
      1.9901870e+02,   1.9986158e+02,   2.0071216e+02,   2.0157057e+02, &
      2.0243690e+02,   2.0331128e+02,   2.0419383e+02,   2.0508466e+02, &
      2.0598391e+02,   2.0689168e+02,   2.0780812e+02,   2.0873335e+02, &
      2.0966751e+02,   2.1061074e+02,   2.1156316e+02,   2.1252493e+02, &
      2.1349619e+02,   2.1447709e+02,   2.1546778e+02,   2.1646842e+02, &
      2.1747916e+02,   2.1850016e+02,   2.1953160e+02,   2.2057364e+02, &
      2.2162645e+02,   2.2269022e+02,   2.2376511e+02,   2.2485133e+02, &
      2.2594905e+02,   2.2705847e+02,   2.2817979e+02,   2.2931322e+02, &
      2.3045895e+02,   2.3161721e+02,   2.3278821e+02,   2.3397218e+02, &
      2.3516935e+02,   2.3637994e+02,   2.3760420e+02,   2.3884238e+02, &
      2.4009473e+02,   2.4136150e+02,   2.4264297e+02,   2.4393941e+02, &
      2.4525110e+02,   2.4657831e+02,   2.4792136e+02,   2.4928053e+02, &
      2.5065615e+02,   2.5204853e+02,   2.5345799e+02,   2.5488487e+02, &
      2.5632953e+02,   2.5779231e+02,   2.5927358e+02,   2.6077372e+02, &
      2.6229310e+02,   2.6383214e+02,   2.6539124e+02,   2.6697081e+02, &
      2.6857130e+02,   2.7019315e+02,   2.7183682e+02,   2.7350278e+02, &
      2.7519152e+02,   2.7690354e+02,   2.7863937e+02,   2.8039954e+02, &
      2.8218459e+02,   2.8399511e+02,   2.8583167e+02,   2.8769489e+02, &
      2.8958539e+02,   2.9150383e+02,   2.9345086e+02,   2.9542719e+02, &
      2.9743353e+02,   2.9947061e+02,   3.0153922e+02,   3.0364014e+02, &
      3.0577420e+02,   3.0794224e+02,   3.1014515e+02,   3.1238386e+02, &
      3.1465930e+02,   3.1697246e+02,   3.1932437e+02,   3.2171609e+02, &
      3.2414873e+02,   3.2662343e+02,   3.2914139e+02,   3.3170385e+02 /

      v1 = value
      if (value.lt.-23.0) v1 = -23.0
      if (value.gt.-10.4) v1 = -10.4
      ival = floor(10.*(v1 + 23.0))
      v2 = -230. + ival
      v1 = 10.*v1
      tlcl = (v2 + 1.0 - v1)*lcltable(ival+1) + (v1 - v2)*lcltable(ival+2)


      end subroutine lcltabl

!#######################################################################

   subroutine betts_miller_init ()

!-----------------------------------------------------------------------
!
!        initialization for betts_miller
!
!-----------------------------------------------------------------------

  integer  unit,io,ierr, logunit

!----------- read namelist ---------------------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=betts_miller_nml, iostat=io)
      ierr = check_nml_error(io,'betts_miller_nml')
#else   
      if (file_exist('input.nml')) then
         unit = open_namelist_file ( )
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=betts_miller_nml, iostat=io, end=10)
            ierr = check_nml_error (io,'betts_miller_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist --------------------------------------------

      call write_version_number ( version, tagname )
      logunit = stdlog()
      if ( mpp_pe() == mpp_root_pe() ) then
           write (logunit,nml=betts_miller_nml)
      endif

      module_is_initialized =.true.

   end subroutine betts_miller_init

!#######################################################################
   subroutine betts_miller_end ()

      module_is_initialized =.false.

   end subroutine betts_miller_end

end module betts_miller_mod




module bm_massflux_mod

!----------------------------------------------------------------------
use            mpp_mod, only:  input_nml_file
use            fms_mod, only:  file_exist, error_mesg, open_namelist_file,  &
                               check_nml_error, mpp_pe, FATAL,  &
                               close_file, mpp_root_pe, write_version_number, stdlog
use sat_vapor_pres_mod, only:  escomp, descomp
use      constants_mod, only:  HLv,HLs,Cp_air,Grav,rdgas,rvgas, cp_vapor, kappa

implicit none
private
!----------------------------------------------------------------------
!  ---- public interfaces ----

   public  bm_massflux, bm_massflux_init, bm_massflux_end

!-----------------------------------------------------------------------
!   ---- version number ----

 character(len=128) :: version = '$Id: bm_massflux.F90,v 18.0.2.1 2010/08/30 20:39:42 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
!   ---- local/private data ----

    real, parameter :: d622 = rdgas/rvgas
    real, parameter :: d378 = 1.-d622

    logical :: module_is_initialized=.false.

!-----------------------------------------------------------------------
!   --- namelist ----

real    :: tau_bm=7200.
real    :: rhbm = .8
real    :: revap = 1.0
real    :: minstatstab = .1
logical :: do_shallower = .false.
logical :: do_changeqref = .false.

namelist /bm_massflux_nml/  tau_bm, rhbm, do_shallower, do_changeqref, revap, &
   minstatstab

!-----------------------------------------------------------------------
!           description of namelist variables
!
!  tau_bm    =  betts-miller relaxation timescale (seconds)
!  rhbm      = relative humidity that you're relaxing towards
!             In contrast to standard BM, this can be put as high as 100%
!             as long as the convection scheme is not overwhelmd by 
!             the large-scale condensation.
!  revap     = the precipiation efficiency reevaporation parameter, i.e., 
!              the moistening of the atmosphere per heating.  
!
!  not used:
!
!
!  do_shallower = do the shallow convection scheme where it chooses a smaller
!                 depth such that precipitation is zero
! 
!  do_changeqref = do the shallow convection scheme where if changes the 
!                  profile of both q and T in order make precip zero
!
!-----------------------------------------------------------------------

contains

!#######################################################################

   subroutine bm_massflux (dt, tin, qin, pfull, phalf, coldT, &
                           rain, snow, tdel, qdel, q_ref, bmflag, &
                           klzbs, t_ref, massflux,&
                           mask, conv)

!-----------------------------------------------------------------------
!
!                     Betts-Miller Convection Scheme
!
!-----------------------------------------------------------------------
!
!   input:  dt       time step in seconds
!           tin      temperature at full model levels
!           qin      specific humidity of water vapor at full
!                      model levels
!           pfull    pressure at full model levels
!           phalf    pressure at half (interface) model levels
!           coldT    should precipitation be snow at this point?
!   optional:
!           mask     optional mask (0 or 1.) 
!           conv     logical flag; if true then no betts-miller
!                       adjustment is performed at that grid-point or
!                       model level
!
!  output:  rain     liquid precipitation (kg/m2)
!           snow     frozen precipitation (kg/m2)
!           tdel     temperature tendency at full model levels
!           qdel     specific humidity tendency (of water vapor) at
!                      full model levels
!           bmflag   flag for which routines you're calling
!           klzbs    stored klzb values
!           massflux the massflux used to calculate the humidity adjustment
!
!-----------------------------------------------------------------------
!--------------------- interface arguments -----------------------------

   real   , intent(in) , dimension(:,:,:) :: tin, qin, pfull, phalf
   real   , intent(in)                    :: dt
   logical, intent(in) , dimension(:,:)   :: coldT
   real   , intent(out), dimension(:,:)   :: rain,snow, bmflag, klzbs
   real   , intent(out), dimension(:,:,:) :: tdel, qdel, q_ref, t_ref, massflux
   real   , intent(in) , dimension(:,:,:), optional :: mask
   logical, intent(in) , dimension(:,:,:), optional :: conv
!-----------------------------------------------------------------------
!---------------------- local data -------------------------------------

   logical :: avgbl
   real,dimension(size(tin,1),size(tin,2),size(tin,3)) ::  rin
   real,dimension(size(tin,1),size(tin,2))             ::  &
                     hlcp, precip, cape, cin
   real,dimension(size(tin,3))                         :: rpc, tpc, &
             statstab, theta
   real                                                ::  & 
       cape1, cin1, tot, deltak, deltaq, qrefint, deltaqfrac, deltaqfrac2, &
       ptopfrac
integer  i, j, k, ix, jx, kx, klzb, ktop, klcl

!modif omp:
real :: prec_rev, ratio, q_src, ratio_q, ratio_T, en_acc, ratio_ml
!-----------------------------------------------------------------------
!     computation of precipitation by betts-miller scheme
!-----------------------------------------------------------------------

      if (.not. module_is_initialized) call error_mesg ('bm_massflux',  &
                         'bm_massflux_init has not been called.', FATAL)

      ix=size(tin,1)
      jx=size(tin,2)
      kx=size(tin,3)
      avgbl = .false.

!----- compute proper latent heat --------------------------------------
!
!  omp: at this stage,uses only the latent heat of vaporization. 
!       --- this is used only by the energy budget. The lapse rate 
!       has its own value. (This should be made consistent.)  
!      
!
!      WHERE (coldT)
!           hlcp = HLs/Cp_air
!      ELSEWHERE
           hlcp = HLv/Cp_air
!      END WHERE

!------------------- calculate CAPE and CIN ----------------------------

! calculate r
       rin = qin/(1.0 - qin)
       do i=1,ix
          do j=1,jx

             cape1 = 0.
             cin1 = 0.
             tot = 0.
             klzb=0
             klcl = 0
! the bmflag is written out to show what aspects of the bm scheme is called
! bmflag = 0 is no cape, no convection
! bmflag = 1 cape but no precip: nothing happens
! bmflag = 2 is deep convection
! it's either 0 or 2 in this scheme


             bmflag(i,j) = 0.
             tpc = tin(i,j,:)
             rpc = rin(i,j,:)
! calculate cape, cin, level of zero buoyancy, and parcel properties w/ leo's
! code
!             call capecalc( Cp_air, cp_vapor, d622, kx, pfull(i,j,:),&
!                            rin(i,j,:), rdgas, hlv, rvgas, tin(i,j,:),&
!                            cape1, cin1, tot, tpc, rpc, klcl, klzb)
! new code (second order in delta ln p and exact LCL calculation)
             call capecalcnew( kx,  pfull(i,j,:),  phalf(i,j,:),&
                            Cp_air, rdgas, rvgas, hlv, kappa, tin(i,j,:), &
                            rin(i,j,:), avgbl, cape1, cin1, tpc, &
                            rpc, klzb,klcl)
! set values for storage
             cape(i,j) = cape1
             cin(i,j) = cin1
             klzbs(i,j) = klzb
             massflux(i,j,1:kx) = 0.
             if(cape1.gt.0.) then
!             if( (tot .gt. 0.) .and. (cape1.gt.0.) ) then 
                bmflag(i,j) = 1.

! reference temperature is just that of the parcel all the way up

                t_ref(i,j,:) = tpc

                do k=klzb,kx
!                   q_ref(i,j,k) = rpc(k)/(1. + rpc(k))

! use this for relaxation toward virtual adiabat
!                t_ref(i,j,k) = tpc(k) * ( 1+0.608 * q_ref(i,j,k))/ (1+ 0.608 * qin(i,j,k))


! modif omp: free troposphere is relaxed  toward saturated profile at CURRENT temperature
!                   call escomp(tin(i,j,k),es)
!                   rs=d622*es/(pfull(i,j,k)+(d622-1.)*es)
!                   q_sat(k) = rs/(1. + rs)


! This shouldn't happen, but set reference humidity to be positive just in 
! case
!                   if (q_ref(i,j,k).lt.0.) then
!                      q_ref(i,j,k) = 0.
!                      write (*,*) 'doh! q neg'
!                   end if

                end do

! set the tendencies to zero where you don't adjust
! set the reference profiles to be the original profiles (for diagnostic 
! purposes only --  you can think of this as what you're relaxing to in
! areas above the actual convection

                

                do k=1,max(klzb-1,1)
                   qdel(i,j,k) = 0.0
                   tdel(i,j,k) = 0.0
                   q_ref(i,j,k) = qin(i,j,k)
                   t_ref(i,j,k) = tin(i,j,k)
                end do




! initialize p to zero for the loop

!modif omp: my way...

! check on the LCL. if LCL is less than 50mb above the surface, 
! the 'lcl' is put at the first 
! level above 950mb (required for adjustment near surface) 
! (adjustment dries out ML if lcl too low).

                if (phalf(i,j,kx+1) -phalf(i,j,klcl+1) .LT. 2500) then
                   do k = kx-1,1,-1
                      if (phalf(i,j,kx+1) -phalf(i,j,k+1) .GT. 2500) then
                         klcl = k
                         go to 11
                      end if
                   end do
                end if

! alternatively, just ensure that there is one layer where convection occurs.
!if (klcl .eq. kx ) then
!   klcl = kx -1
!end if


11  continue


                precip(i,j) = 0.0
                prec_rev = 0.0
                en_acc = 0.0
                q_src = 0.0

!adjustment above PBL. 1st compute difference between the 
! profile and computed tendecies

! We need the potential temperature for the static stability.  
                theta(1:kx) = tin(i,j,1:kx)* &
                   (phalf(i,j,kx+1)/pfull(i,j,1:kx))**kappa
! This is actually the static stability * dz (all you need).  
                statstab(1:kx-1) = theta(1:kx-1) - theta(2:kx)
! Since we're going to divide by the static stability, make sure it's not
! too close to zero (minstatstab is a nml parameter).
                do k=1,kx-1
                statstab(k) = max(statstab(k),minstatstab)
!               if (statstab(k).eq.minstatstab) then
!                write (*,*) 'ouch', k
!               end if 
                enddo
! This should never happen, but just in case, make sure the level of zero 
! buoyancy isn't at the very top.  
                if (klzb.eq.1) then
                   klzb = 2
!                   write (*,*) 'doh, klzb = 1'
                end if 
! T is adjusted toward pseudo-adiabat -- this and the static stab determines 
! a mass flux.  
! q is adjusted based on mass flux and moisture stability
                do k=klzb, klcl
! tdel is the temperature adjustment when you multiply it by dt/tau
                   tdel(i,j,k) = - (tin(i,j,k) - t_ref(i,j,k))
! This is actually the downward mass flux/dz*tau.
                   massflux(i,j,k) = tdel(i,j,k)/statstab(k-1)
! Cap the massflux at a maximum value.  1.0 is picked to be 1/2 the 
! maximum allowed by the Courant criterion for tau=7200 s, dt=1800 s
                   if (abs(massflux(i,j,k)).gt.1.0) then
!                   write (*,*) massflux(i,j,k)
                   massflux(i,j,k) = 1.0*massflux(i,j,k)/abs(massflux(i,j,k))
!                   write (*,*) massflux(i,j,k), k, tdel(i,j,k), statstab(k-1)
                   endif
! qdel is the humidity adjustment when you multiply it by dt/tau
! This is just upwind differencing.
! Also, there is a Courant criterion for this advection equation.  The 
! advection velocity is massflux(i,j,k)*dz/tau.  The condition is:
! dt < dz/M = tau/massflux(i,j,k), i.e., massflux(i,j,k) < tau/dt
! The massflux can achieve values around 10 (minstatstab = .5, and 
! the temperature deficits of 5 deg).  
                   if (massflux(i,j,k).gt.0.) then 
                      qdel(i,j,k) = massflux(i,j,k)*(qin(i,j,k-1) - qin(i,j,k))
                   else
                      qdel(i,j,k) = massflux(i,j,k)*(qin(i,j,k) - qin(i,j,k+1))
                   end if 
! Additional moistening from precip eff if heating > 0
                   if (tdel(i,j,k).gt.0.0) then
                      qdel(i,j,k) = qdel(i,j,k) + revap*Cp_air/hlv*tdel(i,j,k)
                   endif 
!!                   qdel(i,j,k) = - (qin(i,j,k) - rhbm * q_ref(i,j,k))
!                   qdel(i,j,k) = - (qin(i,j,k) - rhbm * q_sat(k))
                   precip(i,j) = precip(i,j) + tdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav/hlcp(i,j)
                   prec_rev = prec_rev + qdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav
                end do


                do k = klcl + 1, kx
!no temperature change in the ML
                   tdel(i,j,k) = 0.0
! relax the ML temp. toward the pseudo-adiabat
!                tdel(i,j,k) = - (tin(i,j,k) - t_ref(i,j,k))
                   precip(i,j) = precip(i,j) + tdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav/hlcp(i,j)
                end do

! at this point: precip = total amount of precip required to brin the temperature to the m. adiabat.
!                prec_rev = total water deficit (respectively to saturation at CURRENT temperature)

! humidity adjustment in the ML

! modif df: the following calculations are no longer used, due to the modification
!           described below
!                en_acc = precip(i,j) + min(prec_rev, revap*precip(i,j))
!                en_acc = en_acc * grav /   &
!                   (phalf(i,j,klcl+1) - phalf(i,j,klzb))


! en_acc is the average energy difference (measured in qv) between the atmosphere and the state at which it would
! equilibrate for the current adiabat. 

! adjustment in the pbl
                do k = klcl + 1, kx

! modif df: changed this line (it was caused energy not to be conserved in the
!           case where the atmosphere is too moist, and en_acc is negative --
!           this allowed q_src to be negative, and the expression in that 
!           case was incorrect.  this could have been fixed by putting in a 
!           different expression, but it seems like the boundary layer should
!           be able to be a source of moisture even if the free troposphere 
!           is being dried; further the boundary layer should never be 
!           moistened (which was happening before).  therefore, this line is 
!           removed and replaced just by uniform drying of the boundary layer)
!                qdel(i,j,k) = max( - qin(i,j,k) ,-en_acc)
                   qdel(i,j,k) = -qin(i,j,k)
                   q_src = q_src - qdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav
                end do

! Determine the adjustment time-scale


                if (precip(i,j) .gt. 0.0) then 

! If precip > 0, then correct energy. 

                   bmflag(i,j) = 2.

                   ratio = min(dt / tau_bm, 1.0)
! modif df: due to the modification above, it's impossible for this to be negative.
!           therefore everything is commented out.  in case someone wants to use
!           this however, i put in the proper correction into the ratio_q line
!           (the added minus sign, which keeps the timescale positive in this case),
!           so this will conserve energy if you uncomment all the rele,vant lines.  
!                if (q_src .lt. 0.0) then
!                   ratio_ML = 0.0
!                   if (prec_rev .gt. 0.0) then
!should not be happening
!                      write (*,*) 'BUGGGGGGG', precip(i,j), prec_rev, en_acc, q_src
!                      write (*,*) 'QREF:',q_ref(i,j,klcl+1:kx),'QIN',qin(i,j,klcl+1:kx)
!                   end if
!                   ratio_T = ratio
!                   ratio_q = -precip(i,j) * ratio_T / prec_rev
!                else

!try convection limited by low level moisture supply
! modif df: a lot of this doesn't make sense to me, so this is commented out and 
!           changed to what's described in olivier's writeup
!                   if (prec_rev .lt. 0.0 ) then
!                      ratio_q = ratio
!                      ratio_ML = ratio
!                      ratio_T = (ratio_ML * q_src - ratio_q * prec_rev)  &
!                           / precip(i,j)    
!                      if (ratio_T .GT. ratio) then
!                         ratio_T = ratio
!                         ratio_ML = ( ratio_T * precip(i,j) + ratio_q * prec_rev) &
!                           /q_src
!                         if (ratio_ML .GT. ratio) then
!                            write(*,*)'danger: ', ratio, ratio_ML, precip(i,j), q_src, prec_rev
!                         end if
!                      end if
!                   else 
!                      ratio_ML = ratio
!                      ratio_T = ratio * q_src / ((1.0 + revap) * precip(i,j))
!!               ratio_q = revap * ratio_T
!                      ratio_q = precip(i,j) * revap * ratio_T / prec_rev
!                      if (ratio_q .gt. ratio) then
!                         ratio_q = ratio
!                         ratio_T = (ratio_ML * q_src - ratio_q * prec_rev)  &
!                             / precip(i,j)  
!                      end if
!
!
!                      if ( ratio_T  .gt. ratio) then
!                  
!                         ratio_T = ratio
!                         ratio_q = max(ratio, precip(i,j)*revap*ratio_T/prec_rev)
!                         ratio_ML = (ratio_T*precip(i,j) + ratio_q*prec_rev) &
!                           /q_src
!                      end if
!                   end if
! Adjust T and q, and conserve energy by draining the boundary layer by the 
! required amount.  
! Don't allow the ML to be moistened!  
                   if (precip(i,j)+prec_rev.gt.0.0) then
                      ratio_q = ratio
                      ratio_T = ratio
                      ratio_ML = ( ratio_T * precip(i,j) + ratio_q * prec_rev) &
                        /q_src
! If you're draining the boundary layer too fast (in a way that would allow 
! humidities to become negative), then limit the convection by reducing 
! the adjustment of temperature and humidity in concert.  
                      if (ratio_ML.gt.ratio) then 
                         ratio_ML = ratio
                         ratio_T = (ratio_ML * q_src )  &
                              / (precip(i,j) + prec_rev)
                         ratio_q = ratio_T
                      end if
                   else
! If the scheme tries to moisten the ML, don't allow this.  
                      ratio_ML = 0.0
                      ratio_T = ratio
                      ratio_q = -ratio_T*precip(i,j)/prec_rev
                   end if

!adjust the tendencies
                
                   do k = klzb,klcl
                      qdel(i,j,k)= qdel(i,j,k) * ratio_q  
                      tdel(i,j,k)= tdel(i,j,k) * ratio_T 
                      massflux(i,j,k) = massflux(i,j,k)*ratio_q/dt* &
                          (phalf(i,j,k+1) - phalf(i,j,k))/grav
                   end do
                   do k = klcl+1,kx
                      qdel(i,j,k)= qdel(i,j,k) * ratio_ML  
                      tdel(i,j,k)= tdel(i,j,k) * ratio_T
                   end do
                   precip(i,j) = precip(i,j) * ratio_T
                       





                else

!omp: This is Dargan's and not used in my version (put do_shallower and  
!do change_qref as .false.

! Shallow / non-precipitating adjustment from dargan. It has not been tested 
! with this version of the deep convection scehme. Use do_shallower = .false.
! and do_changeqref = .false. to turn off. In this case, no convection occurs 
! when the computed precipitation is 0. 


! If precip < 0, then do the shallow conv routine.
! First option: do_shallower = true
! This chooses the depth of convection based on choosing the height that 
! it can make precip zero, i.e., subtract off heights until that precip 
! becomes positive.  

                    if (do_shallower) then
! ktop is the new top of convection.  set this initially to klzb.
                       ktop = klzb
! Work your way down until precip is positive again.
                       do while ( (precip(i,j).lt.0) .and. (ktop.le.kx) )
                          precip(i,j) = precip(i,j) - qdel(i,j,ktop)* &
                                   (phalf(i,j,ktop) - phalf(i,j,ktop+1))/grav
                          ktop = ktop + 1
                       end do
! since there will be an overshoot (precip is going to be greater than zero 
! once we finish this), the actual new top of convection is somewhere between
! the current ktop, and one level above this.  set ktop to the level above.
                       ktop = ktop - 1
! Adjust the tendencies in the places above back to zero, and the reference 
! profiles back to the original t,q.
                       if (ktop.gt.klzb) then
                          qdel(i,j,klzb:ktop-1) = 0.
                          q_ref(i,j,klzb:ktop-1) = qin(i,j,klzb:ktop-1)
                          tdel(i,j,klzb:ktop-1) = 0.
                          t_ref(i,j,klzb:ktop-1) = tin(i,j,klzb:ktop-1)
                       end if
! Then make the change only a fraction of the new top layer so the precip is 
! identically zero.
! Calculate the fractional penetration of convection through that top layer.  
! This is the amount necessary to make precip identically zero.  
                       ptopfrac = precip(i,j)/(qdel(i,j,ktop)* &
                          (phalf(i,j,ktop+1) - phalf(i,j,ktop)))
! Reduce qdel in the top layer by this fraction. 
                       qdel(i,j,ktop) = ptopfrac*qdel(i,j,ktop)
! Set precip to zero
                       precip(i,j) = 0.
! A diagnostic which allows calculating precip to make sure it's zero.
                       do k=ktop,kx
                          precip(i,j)=precip(i,j)+qdel(i,j,k)* &
                                 (phalf(i,j,k) - phalf(i,j,k+1))/grav
                       end do
                       if (abs(precip(i,j)).gt.1.e-5) &
                           write(6,*) 'doh! precip.ne.0'
! Now change the reference temperature in such a way to make the net 
! heating zero.
                       deltak = 0.
                       if (ktop.lt.kx) then
! Integrate temperature tendency up to 1 level below top.
                          do k=ktop+1,kx
                             deltak = deltak + tdel(i,j,k)* &
                                 (phalf(i,j,k) - phalf(i,j,k+1))
                          end do
! Then for the top level, use only a fraction.
                          deltak = deltak + ptopfrac*tdel(i,j,ktop)* &
                               (phalf(i,j,ktop) - phalf(i,j,ktop+1))
! Normalize by the pressure difference.
                          deltak = deltak/(phalf(i,j,kx+1) - & 
                           phalf(i,j,ktop+1) + ptopfrac*(phalf(i,j,ktop+1) - &
                           phalf(i,j,ktop)))
! Subtract this value uniformly from tdel, and make the according change to 
! t_ref.
                          do k=ktop,kx
                             tdel(i,j,k) = tdel(i,j,k) + deltak
                             t_ref(i,j,k) = t_ref(i,j,k) + deltak*tau_bm/dt
                          end do
                       end if
                    else if(do_changeqref) then
! Change the reference profile of q by a certain fraction so that precip is 
! zero.  This involves calculating the total integrated q_ref dp (this is the
! quantity intqref), as well as the necessary change in q_ref (this is the 
! quantity deltaq).  Then the fractional change in q_ref at each level (the 
! quantity deltaqfrac) is 1-deltaq/intqref.  (have to multiply q_ref by 
! 1-deltaq/intqref at every level)  Then the change in qdel is 
! -deltaq/intqref*q_ref*dt/tau_bm.
! Change the reference profile of T by a uniform amount so that precip is zero.
                       deltak = 0.
                       deltaq = 0.
                       qrefint = 0.
                       do k=klzb,kx
! deltaq = a positive quantity (since int qdel is positive).  It's how 
! much q_ref must be changed by, in an integrated sense.  The requisite 
! change in qdel is this without the factors of tau_bm and dt.
                          deltaq = deltaq - qdel(i,j,k)*tau_bm/dt* &
                                    (phalf(i,j,k) - phalf(i,j,k+1))
! deltak = the amount tdel needs to be changed
                          deltak  = deltak  + tdel(i,j,k)* &
                                    (phalf(i,j,k) - phalf(i,j,k+1))
! qrefint = integrated value of qref
                          qrefint = qrefint - q_ref(i,j,k)* &
                                    (phalf(i,j,k) - phalf(i,j,k+1))
                       end do
! Normalize deltak by total pressure.
                       deltak  = deltak /(phalf(i,j,kx+1) - phalf(i,j,klzb))
! multiplying factor for q_ref is 1 + the ratio
                       deltaqfrac = 1. - deltaq/qrefint
! multiplying factor for qdel adds dt/tau_bm
                       deltaqfrac2 = - deltaq/qrefint*dt/tau_bm
! let's check that the precip really is zero as in the shallower scheme
                       precip(i,j) = 0.0
                       do k=klzb,kx
                          qdel(i,j,k) = qdel(i,j,k) + deltaqfrac2*q_ref(i,j,k)
                          q_ref(i,j,k) = deltaqfrac*q_ref(i,j,k)
                          tdel(i,j,k) = tdel(i,j,k) + deltak
                          t_ref(i,j,k) = t_ref(i,j,k) + deltak*tau_bm/dt
                          precip(i,j) = precip(i,j) + qdel(i,j,k)* &
                                 (phalf(i,j,k) - phalf(i,j,k+1))/grav
                       end do
                       if (abs(precip(i,j)).gt.1.e-5) &
                         write(6,*) 'doh! precip.ne.0)'
                    else
                       precip(i,j) = 0.
                       tdel(i,j,:) = 0.
                       qdel(i,j,:) = 0.
                    end if
                end if
             else 
                tdel(i,j,:) = 0.0
                qdel(i,j,:) = 0.0
                precip(i,j) = 0.0
                q_ref(i,j,:) = qin(i,j,:)
                t_ref(i,j,:) = tin(i,j,:)
             end if
          end do
       end do

       rain = precip
       snow = 0.
   

!-----------------------------------------------------------------------

   end subroutine bm_massflux

!#######################################################################

    subroutine capecalc(cpd, cpv, epsilo, nlev, pback, rback, rd, rl, rv, &
                        tback, xcape, cin, tot, tpcback, rpcback,         &
                        klclback, klzbback)
!
! modif omp: klcl is an additional output

!      Calculates convective available potential energy for a cloud whose
!      temperature follows a saturated adiabat.
!
!      On Input
!
!      cpd     specific heat of dry air at constant pressure (J/(kg K))
!      cpv     specific heat of water vapor
!      epsilo  ratio of molecular weights of water vapor to dry air
!      nlev    number of levels 
!      p       pressure (Pa)
!              Index 1 refers to level nearest earth's surface.
!      r       mixing ratio (kg(H2O)/kg)
!              Index 1 refers to level nearest earth's surface.
!      rd      gas constant for dry air (J/(kg K))
!      rl      latent heat of vaporization (J/kg)
!      rv      gas constant for water vapor (J/(kg K))
!      t       temperature (K)
!              Index 1 refers to level nearest earth's surface.
!
!     Output:
!   
!     tpc      parcel temperature (K)
!              Set to environment below istart.
!              Index 1 refers to level nearest earth's surface.
!     rpc      parcel mixing ratio (kg(H2O)/kg)
!              Set to environment below istart.
!              Index 1 refers to level nearest earth's surface.
!     cin      convective inhibition (J/kg)
!              energy required to lift parcel from level istart to
!              level of free convection
!     xcape    convective available potential energy (J/kg)
!              energy released as parcel moves from level of free
!              convection to level of zero buoyancy
!     tot      xcape+cin (J/kg)
!     klcl     first level above the LCL
!     klzb     the level where you hit LZB
!
!     For definitions of cin and xcape, see notes (4 Apr 95) (LAN Notes).
!
        implicit none
        integer, intent(in) :: nlev
        REAL, INTENT (IN),    DIMENSION(:) :: pback, tback, rback
        real, intent (in) :: cpd, cpv, epsilo, rd, rl, rv
        integer, intent(out) :: klzbback, klclback
        real, intent (out) :: xcape, cin, tot
        real, intent (out), dimension(nlev) :: tpcback, rpcback

      integer :: istart, ieq, klcl, k, klzb, klfc, ieqa, nlevm
      logical :: capepos
      real, dimension(nlev) :: p, r, t, tpc, rpc
      real :: ro, tc, tp, plcl, es, rs, rlcl, tlcl, pb, tb, rb, q, cp, dp, &
              dt1, plzb, qe, tve, pc, qs, tv, rc, fact1, fact2, fact3, &
              dtdp, rbc, rbe, qc, tvc, delt

!modif omp
      real :: rsb, tplcl

!      parameter(nlev=25,nlevm=nlev-1)
!      dimension t(nlev),r(nlev),p(nlev)
!      dimension tpc(nlev),rpc(nlev)
!      logical capepos
!
      capepos=.false.
      nlevm = nlev-1

     do k=1,nlev
        t(k) = tback(nlev+1-k)
        r(k) = rback(nlev+1-k)
        p(k) = pback(nlev+1-k)
        tpc(k) = t(k)
        rpc(k) = r(k)
     end do

!
!     Calculate LCL
!     istart-index of level whose mixing ratio is conserved as a parcel 
!            leaves it undergoing dry adiabatic ascent
!
      istart=1
      ro=r(istart)
      tc=t(istart)
      tp=tc
      plcl=0.
      do k=1,istart
        tpc(k)=t(k)
        rpc(k)=r(k)
      end do
      do k=istart,nlev
        call establ(es,tp)
        rs=epsilo*es/(p(k)+(epsilo-1.)*es)
!       write(6,*) 'k,tp,rs= ',k,tp,rs
        ieq=iequ(rs,ro)
        if (ieq .eq. 0) then
          plcl=p(k)
          rlcl=r(k)
          tlcl=t(k)
          klcl=k
          go to 11
        end if
        if (k .eq. istart) then
           if (ieq .lt. 0) then
              plcl=p(istart)
              tlcl=t(istart)
              rlcl=r(istart)
! omp: try this before, did not change much. 
! (The lowest level should not be supersaturated.)
!             rlcl=rs
              klcl=istart
              go to 11
           else
              go to 13
           end if
        end if
        if (k .gt. 1) then
           pb=(p(k)+p(k-1))/2.
           tb=(t(k)+t(k-1))/2.
           rb=(r(k)+r(k-1))/2.
           if (rs .lt. ro) then

              fact1 = (ro - rs)/(rsb-rs)
              fact2 = (rsb - ro)/(rsb-rs)
             plcl=fact1* p(k-1) + fact2 * p(k) 
             tlcl=fact1* t(k-1) + fact2 * t(k) 
             rlcl=rb
             tplcl = fact1* tpc(k-1) + fact2 * tpc(k) 
             klcl=k
             go to 11
           end if
        end if
        if (k .eq. nlev) go to 11

!     Convert mixing ratio to specific humidity.
!
 13   continue
         q=ro/(1.+ro)
         cp=cpd*(1.+((cpv/cpd)-1.)*q)
         dp=p(k+1)-p(k)
         dtdp=rd*tp/cp
!        write(6,*) 'dp,dtdp,pb= ',dp,dtdp,pb
         dt1=dtdp*alog((p(k)+dp)/p(k))
         tp=tp+dt1
         tpc(k+1)=tp
         rpc(k+1)=ro
         rsb = rs
      end do
 11   continue
      ieq=iequ(plcl,0.)
      if (ieq .eq. 0) then
         xcape = 0.
         cin = 0.
         tot = 0.
         tpcback = tback
         rpcback = rback
!        write(6,*) 'plcl=0'
!         stop
         call error_mesg ('bm_massflux:capecalc', 'ieq = 0', FATAL)
      end if
!
!     Calculate temperature along saturated adiabat, starting at p(kLCL).
!
!       write(6,*) 'plcl,klcl,tlcl,rlcl= ',plcl,klcl,tlcl,rlcl
!       write(6,*) 'p(klcl)= ',p(klcl)

!modif omp: first find saturated temp at level klcl
!           In the previous version, the parcel temperature
!           was obtained from a dry adiabat ascent all the way
!           to the level k. 




      tc = tplcl
      call establ(es,tc)
      pc = plcl
      rs=epsilo*es/(pc+(epsilo-1.)*es)
      qs=rs/(1.+rs)
      tv=tc*(1.+.61*qs)
      dp=p(klcl)-plcl
      rc=(1.-qs)*rd+qs*rv
!        write(6,*) 'tv= ',tv
      pb=(p(klcl)+plcl)/2.
      fact1=rd/cpd
      fact2=tv+(rl*qs/rc)
!         write(6,*) 'fact1,fact2,rc= ',fact1,fact2,rc
      fact1=fact1*fact2
      fact3=epsilo*(rl**2)*es/(cpd*pb*rv*(tv**2))
!        write(6,*) 'fact1,fact3= ',fact1,fact3
      fact3=1.+fact3
      dtdp=fact1/fact3
!         write(6,*) 'dtdp= ',dtdp
      tc=tc+dtdp*alog((pc+dp)/pc)
!         write(6,*) 'tc,t= ',tc,t(k+1)
      tpc(klcl)=tc
      rpc(klcl)=rs
!         write(6,*) 'p,r,rs= ',p(k+1),r(k+1),rs

!       tc=tpc(klcl)
!end modif omp


! omp note: the adiabat is computed by a forward integeration of the
! lapse rate. Thiscould be improved at coarse resolution by implementing 
! a 2nd or 3rd order Runge-Kunta scheme.

       plzb=0.
       do k=klcl,nlevm
          qe=r(k)/(1.+r(k))
          tve=t(k)*(1.+.61*qe)
          call establ(es,tc)
          pc=p(k)
          rs=epsilo*es/(pc+(epsilo-1.)*es)
          qs=rs/(1.+rs)
          tv=tc*(1.+.61*qs)
!          write(6,*) 'k,tv,tve= ',k,tv,tve
          ieq=iequ(tv,tve)
          if ((ieq .gt. 0) .and. (.not. capepos)) then
             capepos=.true.
          end if
          if ((ieq .lt. 0) .and. (capepos)) then
             klzb=k
             plzb=(p(k)+p(k-1))/2.
!             write(6,*) 'klzb,plzb,p(klzb)= ',klzb,plzb,p(klzb)
             go to 12
          end if
          dp=p(k+1)-p(k)
          rc=(1.-qs)*rd+qs*rv
!           write(6,*) 'tv= ',tv
          pb=(p(k)+p(k+1))/2.
          fact1=rd/cpd
          fact2=tv+(rl*qs/rc)
!          write(6,*) 'fact1,fact2,rc= ',fact1,fact2,rc
          fact1=fact1*fact2
          fact3=epsilo*(rl**2)*es/(cpd*pb*rv*(tv**2))
!          write(6,*) 'fact1,fact3= ',fact1,fact3
          fact3=1.+fact3
          dtdp=fact1/fact3
!          write(6,*) 'dtdp= ',dtdp
          tc=tc+dtdp*alog((pc+dp)/pc)
!          write(6,*) 'tc,t= ',tc,t(k+1)
          tpc(k+1)=tc
          rpc(k+1)=rs
!          write(6,*) 'p,r,rs= ',p(k+1),r(k+1),rs
       end do
 12    continue
      ieq=iequ(plzb,0.)
      if (ieq .eq. 0) then
         xcape = 0.
         cin = 0.
         tot = 0.
         tpcback = tback
         rpcback = rback
!         write(6,*) 'plzb=0'
         return
      end if
      cin=0.
      xcape=0.
      tot=0.
!
!     Calculate convective inhibition.
!
       klfc=0
       do k=istart,nlevm
          ieq=iequ(p(k),plzb)
          if (ieq .le. 0) then
!             write(6,*) 'cin= ',cin
!            write(6,*) 'cape = 0 NO LFC'
             return 
          end if
          rbc=(rpc(k)+rpc(k+1))/2.
          rbe=(r(k)+r(k+1))/2.
          qc=rbc/(1.+rbc)
          qe=rbe/(1.+rbe)
          tvc=tpc(k)*(1.+.61*qc)
          tve=t(k)*(1.+.61*qe)
!          write(6,*) 'k,tvc,tve= ',k,tvc,tve
          ieq=iequ(tvc,tve)
          ieqa=iequ(p(k),plcl)
          if ((ieq .le. 0) .or. (ieqa .ge. 0)) then
             delt=rd*(tvc-tve)*alog(p(k)/p(k+1))
             cin=cin-delt
          else
             klfc=k
             go to 14
          end if
       end do
 14    continue
!
!      Calculate convective available potential energy.
!
!       write(6,*) 'klfc,p(klfc)= ',klfc,p(klfc)
!
! omp note: CAPE is calculated using full levels. This can create a
! significant amount of flickering, espcially when the LCL and LZB
! switch from one model level to another. 
!
       if (klfc .eq. 0) then
          xcape=0.
!          write(6,*) 'klfc=0'
          return
       end if
       do k=klfc,klzb
          ieq=iequ(p(k+1),plzb)
          if (ieq .ge. 0) then
             rbc=(rpc(k)+rpc(k+1))/2.
             rbe=(r(k)+r(k+1))/2.
             qc=rbc/(1.+rbc)
             qe=rbe/(1.+rbe)
             tvc=tpc(k)*(1.+.61*qc)
             tve=t(k)*(1.+.61*qe)
             ieq=iequ(tvc,tve)
             if (ieq .gt. 0) then
                delt=rd*(tvc-tve)*alog(p(k)/p(k+1))
!                write(6,*) 'cape k,delt,xcape= ',k,delt,xcape
                xcape=xcape+delt
                if (xcape .lt. 0.) then
!                   write(6,*) 'xcape error'
                    call error_mesg ('bm_massflux:capecalc', &
                                     'xcape error', FATAL)
!                   stop
                end if
              end if
          end if
       end do
       tot=xcape-cin
!       write(6,*) 'cin= ',cin,' J/kg'
!       write(6,*) 'xcape= ',xcape,' J/kg'
!       write(6,*) 'tot= ',tot,' J/kg'
       do k=1,nlev
          tpcback(k) = tpc(nlev+1-k)
          rpcback(k) = rpc(nlev+1-k)
       end do
       klzbback = nlev + 1 - klzb
      klclback = nlev + 1 - klcl

       return
       end subroutine capecalc

!###############################################################
!all new cape calculation.

      subroutine capecalcnew(kx,p,phalf,cp_air,rdgas,rvgas,hlv,kappa,tin,rin,&
                             avgbl,cape,cin,tp,rp,klzb,klcl)

!
!    Input:
!
!    kx          number of levels
!    p           pressure (index 1 refers to TOA, index kx refers to surface)
!    phalf       pressure at half levels
!    cp_air      specific heat of dry air
!    rdgas       gas constant for dry air
!    rvgas       gas constant for water vapor (used in Clausius-Clapeyron, 
!                not for virtual temperature effects, which are not considered)
!    hlv         latent heat of vaporization
!    kappa       the constant kappa
!    tin         temperature of the environment
!    rin         specific humidity of the environment
!    avgbl       if true, the parcel is averaged in theta and r up to its LCL
!
!    Output:
!    cape        Convective available potential energy
!    cin         Convective inhibition (if there's no LFC, then this is set 
!                to zero)
!    tp          Parcel temperature (set to the environmental temperature 
!                where no adjustment)
!    rp          Parcel specific humidity (set to the environmental humidity 
!                where no adjustment, and set to the saturation humidity at 
!                the parcel temperature below the LCL)
!    klzb        Level of zero buoyancy
!    klcl        Lifting condensation level
!
!    Algorithm: 
!    Start with surface parcel. 
!    Calculate the lifting condensation level (uses an analytic formula and a 
!       lookup table).  
!    Average under the LCL if desired, if this is done, then a new LCL must
!       be calculated.  
!    Calculate parcel ascent up to LZB.
!    Calculate CAPE and CIN.  
      implicit none
      integer, intent(in)                    :: kx
      logical, intent(in)                    :: avgbl
      real, intent(in), dimension(:)         :: p, phalf, tin, rin
      real, intent(in)                       :: rdgas, rvgas, hlv, kappa, cp_air
      integer, intent(out)                   :: klzb, klcl
      real, intent(out), dimension(:)        :: tp, rp
      real, intent(out)                      :: cape, cin

      integer            :: k, klfc, klcl2
      logical            :: nocape
      real, dimension(kx)   :: theta
      real                  :: t0, r0, es, rs, theta0, pstar, value, tlcl, &
                               a, b, dtdlnp, thetam, rm, tlcl2, &
                               plcl2, plcl, plzb

      pstar = 1.e5

      nocape = .true.
      cape = 0.
      cin = 0.
      plcl = 0.
      plzb = 0.
      klfc = 0
      klcl = 0
      klzb = 0
      tp(1:kx) = tin(1:kx)
      rp(1:kx) = rin(1:kx)

! start with surface parcel
      t0 = tin(kx)
      r0 = rin(kx)
! calculate the lifting condensation level by the following:
! are you saturated to begin with?  
!      call establ(es,t0)
      call escomp(t0,es)
      rs = rdgas/rvgas*es/p(kx)
      if (r0.ge.rs) then
! if youre already saturated, set lcl to be the surface value.
         plcl = p(kx)
! the first level where youre completely saturated.
         klcl = kx
! saturate out to get the parcel temp and humidity at this level
! first order (in delta T) accurate expression for change in temp
         tp(kx) = t0 + (r0 - rs)/(cp_air/hlv + hlv*rs/rvgas/t0**2.)
!         call establ(es,tp(kx))
         call escomp(tp(kx),es)
         rp(kx) = rdgas/rvgas*es/p(kx)
      else
! if not saturated to begin with, use the analytic expression to calculate the 
! exact pressure and temperature where youre saturated.  
         theta0 = tin(kx)*(pstar/p(kx))**kappa
! the expression that we utilize is log(r/theta**(1/kappa)*pstar*rvgas/rdgas) =
! log(es/T**(1/kappa))
! The right hand side of this is only a function of temperature, therefore 
! this is put into a lookup table to solve for temperature.  
         if (r0.gt.0.) then
            value = log(theta0**(-1/kappa)*r0*pstar*rvgas/rdgas)
            call lcltabl(value,tlcl)
            plcl = pstar*(tlcl/theta0)**(1/kappa)
! just in case plcl is very high up
            if (plcl.lt.p(1)) then
               plcl = p(1)
               tlcl = theta0*(plcl/pstar)**kappa
               write (*,*) 'hi lcl'
            end if
            k = kx
         else
! if the parcel sp hum is zero or negative, set lcl to 2nd to top level
            plcl = p(2)
            tlcl = theta0*(plcl/pstar)**kappa
!            write (*,*) 'zero r0', r0
            do k=2,kx
               tp(k) = theta0*(p(k)/pstar)**kappa
               rp(k) = 0.
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            end do
            go to 11
         end if
! calculate the parcel temperature (adiabatic ascent) below the LCL.  
! the mixing ratio stays the same
!!! the right command??
         do while (p(k).gt.plcl)
            tp(k) = theta0*(p(k)/pstar)**kappa
!            call establ(es,tp(k))
            call escomp(tp(k),es)
            rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            k = k-1
         end do
! first level where you're saturated at the level
         klcl = k
         if (klcl.eq.1) klcl = 2
! do a saturated ascent to get the parcel temp at the LCL.  
! use your 2nd order equation up to the pressure above.  
! moist adaibat derivatives: (use the lcl values for temp, humid, and 
! pressure)
         a = kappa*tlcl + hlv/cp_air*r0
         b = hlv**2.*r0/cp_air/rvgas/tlcl**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
! second order in p (RK2)
! first get temp halfway up 
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)/2.
         if ((tp(klcl).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/(p(klcl) + plcl)*2.
         a = kappa*tp(klcl) + hlv/cp_air*rp(klcl)
         b = hlv**2./cp_air/rvgas*rp(klcl)/tp(klcl)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
!         d2tdlnp2 = (kappa + b - 1. - b/tlcl*(hlv/rvgas/tlcl - &
!                   2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*r0/cp_air/ &
!                   (1. + b)
! second order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl) + .5*d2tdlnp2*(log(&
!             p(klcl)/plcl))**2.
!         call establ(es,tp(klcl))
         call escomp(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/p(klcl)
!         write (*,*) 'tp, rp klcl:kx, new', tp(klcl:kx), rp(klcl:kx)
! CAPE/CIN stuff
         if ((tp(klcl).lt.tin(klcl)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(klcl) - &
                 tp(klcl))*log(phalf(klcl+1)/phalf(klcl))
         else
! if youre buoyant, then add to cape
            cape = cape + rdgas*(tp(klcl) - &
                  tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if its the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = klcl
            endif
         end if
      end if
! then average the properties over the boundary layer if so desired.  to give 
! a new "parcel".  this may not be saturated at the LCL, so make sure you get 
! to a level where it is before moist adiabatic ascent!
!!!! take out all the below (between the exclamation points) if no avgbl !!!!
      if (avgbl) then
         theta(klcl:kx) = tin(klcl:kx)*(pstar/p(klcl:kx))**kappa
         thetam = 0.
         rm = 0.
         do k=klcl,kx
            thetam = thetam + theta(k)*(phalf(k+1) - phalf(k))
            rm = rm + rin(k)*(phalf(k+1) - phalf(k))
         end do
         thetam = thetam/(phalf(kx+1) - phalf(klcl))
         rm = rm/(phalf(kx+1) - phalf(klcl))
! check if youre saturated at the top level.  if not, then get a new LCL
         tp(klcl) = thetam*(p(klcl)/pstar)**kappa
!         call establ(es,tp(klcl))
         call escomp(tp(klcl),es)
         rs = rdgas/rvgas*es/p(klcl)
! if youre not saturated, get a new LCL
         if (rm.lt.rs) then
! reset CIN to zero.  
            cin = 0.
! again, use the analytic expression to calculate the exact pressure and 
! temperature where youre saturated.  
! the expression that we utilize is log(r/theta**(1/kappa)*pstar*rvgas/rdgas)=
! log(es/T**(1/kappa))
! The right hand side of this is only a function of temperature, therefore 
! this is put into a lookup table to solve for temperature.  
            value = log(thetam**(-1/kappa)*rm*pstar*rvgas/rdgas)
            call lcltabl(value,tlcl2)
            plcl2 = pstar*(tlcl2/thetam)**(1/kappa)
! just in case plcl is very high up
            if (plcl2.lt.p(1)) then
               plcl2 = p(1)
            end if
            k = kx
! calculate the parcel temperature (adiabatic ascent) below the LCL.  
! the mixing ratio stays the same
!!! the right command??
            do while (p(k).gt.plcl2) 
               tp(k) = thetam*(p(k)/pstar)**kappa
!               call establ(es,tp(k))
               call escomp(tp(k),es)
               rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
               k = k-1
            end do
! first level where you're saturated at the level
            klcl2 = k
            if(klcl2.eq.1) klcl2 = 2
! do a saturated ascent to get the parcel temp at the LCL.  
! use your 2nd order equation up to the pressure above.  
! moist adaibat derivatives: (use the lcl values for temp, humid, and 
! pressure)
            a = kappa*tlcl2 + hlv/cp_air*rm
            b = hlv**2.*rm/cp_air/rvgas/tlcl2**2.
            dtdlnp = a/(1. + b)
! first order in p
!            tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)
! second order in p (RK2)
! first get temp halfway up 
         tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)/2.
         if ((tp(klcl2).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl2),es)
         rp(klcl2) = rdgas/rvgas*es/(p(klcl2) + plcl2)*2.
         a = kappa*tp(klcl2) + hlv/cp_air*rp(klcl2)
         b = hlv**2./cp_air/rvgas*rp(klcl2)/tp(klcl2)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)
!            d2tdlnp2 = (kappa + b - 1. - b/tlcl2*(hlv/rvgas/tlcl2 - &
!                          2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*rm/cp_air/ &
!                          (1. + b)
! second order in p
!            tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2) + &
!               .5*d2tdlnp2*(log(p(klcl2)/plcl2))**2.
!            call establ(es,tp(klcl2))
            call escomp(tp(klcl2),es)
            rp(klcl2) = rdgas/rvgas*es/p(klcl2)
! CAPE/CIN stuff
            if ((tp(klcl2).lt.tin(klcl2)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
               cin = cin + rdgas*(tin(klcl2) - &
                    tp(klcl2))*log(phalf(klcl2+1)/phalf(klcl2))
            else
! if youre buoyant, then add to cape
               cape = cape + rdgas*(tp(klcl) - &
                     tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if its the first time buoyant, then set the level of free convection to k
               if (nocape) then
                  nocape = .false.
                  klfc = klcl2
               endif
            end if
         end if
      end if
!!!! take out all of the above (within the exclamations) if no avgbl !!!!
! then, start at the LCL, and do moist adiabatic ascent by the first order 
! scheme -- 2nd order as well
      do k=klcl-1,1,-1
         a = kappa*tp(k+1) + hlv/cp_air*rp(k+1)
         b = hlv**2./cp_air/rvgas*rp(k+1)/tp(k+1)**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
! second order in p (RK2)
! first get temp halfway up 
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))/2.
         if ((tp(k).lt.173.16).and.nocape) go to 11
         call escomp(tp(k),es)
         rp(k) = rdgas/rvgas*es/(p(k) + p(k+1))*2.
         a = kappa*tp(k) + hlv/cp_air*rp(k)
         b = hlv**2./cp_air/rvgas*rp(k)/tp(k)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
!         d2tdlnp2 = (kappa + b - 1. - b/tp(k+1)*(hlv/rvgas/tp(k+1) - & 
!               2.)*dtdlnp)/(1. + b)*dtdlnp - hlv/cp_air*rp(k+1)/(1. + b)
! second order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1)) + .5*d2tdlnp2*(log( &
!             p(k)/p(k+1)))**2.
! if you're below the lookup table value, just presume that there's no way 
! you could have cape and call it quits
         if ((tp(k).lt.173.16).and.nocape) go to 11
!         call establ(es,tp(k))
         call escomp(tp(k),es)
         rp(k) = rdgas/rvgas*es/p(k)
         if ((tp(k).lt.tin(k)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
         elseif((tp(k).lt.tin(k)).and.(.not.nocape)) then
! if you have CAPE, and its your first time being negatively buoyant, 
! then set the level of zero buoyancy to k+1, and stop the moist ascent
            klzb = k+1
            go to 11
         else
! if youre buoyant, then add to cape
            cape = cape + rdgas*(tp(k) - tin(k))*log(phalf(k+1)/phalf(k))
! if its the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = k
            endif
         end if
      end do
 11   if(nocape) then 
! this is if you made it through without having a LZB
! set LZB to be the top level.
         plzb = p(1)
         klzb = 0
         klfc = 0
         cin = 0.
         tp(1:kx) = tin(1:kx)
         rp(1:kx) = rin(1:kx)
      end if
!      write (*,*) 'plcl, klcl, tlcl, r0 new', plcl, klcl, tlcl, r0
!      write (*,*) 'tp, rp new', tp, rp
!       write (*,*) 'tp, new', tp
!       write (*,*) 'tin new', tin 
!       write (*,*) 'klcl, klfc, klzb new', klcl, klfc, klzb
      end subroutine capecalcnew

! lookup table with e_s(T) using the new analytic expression
      subroutine establ2(es,t)
      

! Table of es values as a function of temperature.  
! Uses the analytic expression for e_s which assumes fixed latent heat 
!    coefficient.  
! Gives the values from -100 to 60 Celsius in 1 degree increments.  

      implicit none 
      real, intent(in)     :: t
      real, intent(out)    :: es

      integer              :: it
      real, dimension(161) :: table
      real                 :: t1, t2

      data table / 6.4876769e-03,   7.7642650e-03,   9.2730105e-03, & ! XXX Too many continuation lines 
       1.1052629e-02,   1.3147696e-02,   1.5609446e-02,   1.8496657e-02,   2.1876647e-02,   2.5826384e-02,   3.0433719e-02, &
       3.5798760e-02,   4.2035399e-02,   4.9272997e-02,   5.7658264e-02,   6.7357319e-02,   7.8557979e-02,   9.1472273e-02, &
       1.0633921e-01,   1.2342784e-01,   1.4304057e-01,   1.6551683e-01,   1.9123713e-01,   2.2062738e-01,   2.5416374e-01, &
       2.9237778e-01,   3.3586224e-01,   3.8527718e-01,   4.4135673e-01,   5.0491638e-01,   5.7686092e-01,   6.5819298e-01, &
       7.5002239e-01,   8.5357615e-01,   9.7020925e-01,   1.1014164e+00,   1.2488446e+00,   1.4143067e+00,   1.5997959e+00, &
       1.8075013e+00,   2.0398249e+00,   2.2993996e+00,   2.5891082e+00,   2.9121041e+00,   3.2718336e+00,   3.6720588e+00, &
       4.1168837e+00,   4.6107798e+00,   5.1586157e+00,   5.7656865e+00,   6.4377468e+00,   7.1810447e+00,   8.0023579e+00, &
       8.9090329e+00,   9.9090255e+00,   1.1010944e+01,   1.2224096e+01,   1.3558536e+01,   1.5025116e+01,   1.6635542e+01, &
       1.8402429e+01,   2.0339361e+01,   2.2460955e+01,   2.4782931e+01,   2.7322176e+01,   3.0096824e+01,   3.3126327e+01, &
       3.6431545e+01,   4.0034823e+01,   4.3960087e+01,   4.8232935e+01,   5.2880735e+01,   5.7932732e+01,   6.3420149e+01, &
       6.9376307e+01,   7.5836738e+01,   8.2839310e+01,   9.0424352e+01,   9.8634795e+01,   1.0751630e+02,   1.1711742e+02, &
       1.2748974e+02,   1.3868802e+02,   1.5077039e+02,   1.6379851e+02,   1.7783773e+02,   1.9295728e+02,   2.0923048e+02, &
       2.2673493e+02,   2.4555268e+02,   2.6577049e+02,   2.8748004e+02,   3.1077813e+02,   3.3576694e+02,   3.6255429e+02, &
       3.9125382e+02,   4.2198536e+02,   4.5487511e+02,   4.9005594e+02,   5.2766770e+02,   5.6785749e+02,   6.1078000e+02, &
       6.5659776e+02,   7.0548154e+02,   7.5761062e+02,   8.1317317e+02,   8.7236659e+02,   9.3539788e+02,   1.0024840e+03, &
       1.0738523e+03,   1.1497408e+03,   1.2303987e+03,   1.3160868e+03,   1.4070779e+03,   1.5036572e+03,   1.6061228e+03, &
       1.7147860e+03,   1.8299721e+03,   1.9520206e+03,   2.0812857e+03,   2.2181372e+03,   2.3629602e+03,   2.5161565e+03, &
       2.6781448e+03,   2.8493609e+03,   3.0302589e+03,   3.2213112e+03,   3.4230097e+03,   3.6358656e+03,   3.8604109e+03, &
       4.0971982e+03,   4.3468019e+03,   4.6098188e+03,   4.8868684e+03,   5.1785938e+03,   5.4856626e+03,   5.8087673e+03, &
       6.1486259e+03,   6.5059830e+03,   6.8816104e+03,   7.2763077e+03,   7.6909031e+03,   8.1262545e+03,   8.5832496e+03, &
       9.0628075e+03,   9.5658788e+03,   1.0093447e+04,   1.0646529e+04,   1.1226176e+04,   1.1833474e+04,   1.2469546e+04, &
       1.3135552e+04,   1.3832687e+04,   1.4562188e+04,   1.5325331e+04,   1.6123432e+04,   1.6957848e+04,   1.7829980e+04, &
       1.8741270e+04,   1.9693207e+04,   2.0687323e+04,   2.1725199e+04 /

      t1 = t
      if (t.lt.173.16) t1 = 173.16
      if (t.gt.333.16) t1 = 333.16
      it = floor(t1 - 173.16)
      t2 = 173.16 + it
      es = (t2 + 1.0 - t1)*table(it+1) + (t1 - t2)*table(it+2)
      end subroutine establ2

! lookup table for the analytic evaluation of LCL
      subroutine lcltabl(value,tlcl)
!
! Table of values used to compute the temperature of the lifting condensation
! level.  
! 
! the expression that we utilize is log(r/theta**(1/kappa)*pstar*rvgas/rdgas) = 
! log(es/T**(1/kappa))
! 
! Gives the values of the temperature for the following range: 
!   starts with -23, is uniformly distributed up to -10.4.  There are a 
! total of 127 values, and the increment is .1.  
!
      implicit none 
      real, intent(in)     :: value
      real, intent(out)    :: tlcl

      integer              :: ival
      real, dimension(127) :: lcltable
      real                 :: v1, v2

      data lcltable/  1.7364512e+02,   1.7427449e+02,   1.7490874e+02, &
      1.7554791e+02,   1.7619208e+02,   1.7684130e+02,   1.7749563e+02, &
      1.7815514e+02,   1.7881989e+02,   1.7948995e+02,   1.8016539e+02, &
      1.8084626e+02,   1.8153265e+02,   1.8222461e+02,   1.8292223e+02, &
      1.8362557e+02,   1.8433471e+02,   1.8504972e+02,   1.8577068e+02, &
      1.8649767e+02,   1.8723077e+02,   1.8797006e+02,   1.8871561e+02, &
      1.8946752e+02,   1.9022587e+02,   1.9099074e+02,   1.9176222e+02, &
      1.9254042e+02,   1.9332540e+02,   1.9411728e+02,   1.9491614e+02, &
      1.9572209e+02,   1.9653521e+02,   1.9735562e+02,   1.9818341e+02, &
      1.9901870e+02,   1.9986158e+02,   2.0071216e+02,   2.0157057e+02, &
      2.0243690e+02,   2.0331128e+02,   2.0419383e+02,   2.0508466e+02, &
      2.0598391e+02,   2.0689168e+02,   2.0780812e+02,   2.0873335e+02, &
      2.0966751e+02,   2.1061074e+02,   2.1156316e+02,   2.1252493e+02, &
      2.1349619e+02,   2.1447709e+02,   2.1546778e+02,   2.1646842e+02, &
      2.1747916e+02,   2.1850016e+02,   2.1953160e+02,   2.2057364e+02, &
      2.2162645e+02,   2.2269022e+02,   2.2376511e+02,   2.2485133e+02, &
      2.2594905e+02,   2.2705847e+02,   2.2817979e+02,   2.2931322e+02, &
      2.3045895e+02,   2.3161721e+02,   2.3278821e+02,   2.3397218e+02, &
      2.3516935e+02,   2.3637994e+02,   2.3760420e+02,   2.3884238e+02, &
      2.4009473e+02,   2.4136150e+02,   2.4264297e+02,   2.4393941e+02, &
      2.4525110e+02,   2.4657831e+02,   2.4792136e+02,   2.4928053e+02, &
      2.5065615e+02,   2.5204853e+02,   2.5345799e+02,   2.5488487e+02, &
      2.5632953e+02,   2.5779231e+02,   2.5927358e+02,   2.6077372e+02, &
      2.6229310e+02,   2.6383214e+02,   2.6539124e+02,   2.6697081e+02, &
      2.6857130e+02,   2.7019315e+02,   2.7183682e+02,   2.7350278e+02, &
      2.7519152e+02,   2.7690354e+02,   2.7863937e+02,   2.8039954e+02, &
      2.8218459e+02,   2.8399511e+02,   2.8583167e+02,   2.8769489e+02, &
      2.8958539e+02,   2.9150383e+02,   2.9345086e+02,   2.9542719e+02, &
      2.9743353e+02,   2.9947061e+02,   3.0153922e+02,   3.0364014e+02, &
      3.0577420e+02,   3.0794224e+02,   3.1014515e+02,   3.1238386e+02, &
      3.1465930e+02,   3.1697246e+02,   3.1932437e+02,   3.2171609e+02, &
      3.2414873e+02,   3.2662343e+02,   3.2914139e+02,   3.3170385e+02 /

      v1 = value
      if (value.lt.-23.0) v1 = -23.0
      if (value.gt.-10.4) v1 = -10.4
      ival = floor(10.*(v1 + 23.0))
      v2 = -230. + ival
      v1 = 10.*v1
      tlcl = (v2 + 1.0 - v1)*lcltable(ival+1) + (v1 - v2)*lcltable(ival+2)


      end subroutine lcltabl



!#######################################################################


      SUBROUTINE ESTABL(ES,TP)
!
!   TABLE OF ES FROM -100 TO +60 C IN ONE-DEGREE INCREMENTS(ICE).
!
!   RAT GIVES THE RATIO OF ES(ICE)/ES(LIQUID)
!
!  es refers to liquid above 273, ice below 273
!
!

     implicit none
     real, intent(in)  :: TP
     real, intent(out) :: ES

     integer :: it
     real, dimension(161) :: table
     real :: ft, t2, tp1

!      DIMENSION TABLE(161)

      DATA TABLE/.01403,.01719,.02101,.02561,.03117,.03784, &
      .04584,.05542,.06685,.08049,.09672,.1160,.1388,.1658, &
      .1977,.2353,.2796,.3316,.3925,.4638,.5472,.6444,.7577, &
      .8894,1.042,1.22,1.425,1.622,1.936,2.252,2.615,3.032, &
      3.511,4.06,4.688,5.406,6.225,7.159,8.223,9.432,10.80, &
      12.36,14.13,16.12,18.38,20.92,23.80,27.03,30.67,34.76, &
      39.35,44.49,50.26,56.71,63.93,71.98,80.97,90.98,102.1, &
      114.5,128.3,143.6,160.6,179.4,200.2,223.3,248.8,276.9, &
      307.9,342.1,379.8,421.3,466.9,517.0,572.0,632.3,698.5, &
      770.9,850.2,937.0,1032.0,1146.6,1272.0,1408.1,1556.7, &
      1716.9,1890.3,2077.6,2279.6,2496.7,2729.8,2980.,3247.8, &
      3534.1,3839.8,4164.8,4510.5,4867.9,5265.1,5675.2,6107.8, &
      6566.2,7054.7,7575.3,8129.4,8719.2,9346.5,10013.,10722., &
      11474.,12272.,13119.,14017.,14969.,15977.,17044.,18173., &
      19367.,20630.,21964.,23373.,24861.,26430.,28086.,29831., &
      31671.,33608.,35649.,37796.,40055.,42430.,44927.,47551., &
      50307.,53200.,56236.,59422.,62762.,66264.,69934.,73777., &
      77802.,82015.,86423.,91034.,95855.,100890.,106160., &
      111660.,117400.,123400.,129650.,136170.,142980.,150070., &
      157460.,165160.,173180.,181530.,190220.,199260./ 

!      DATA TABLE/.01403,.01719,.02101,.02561,.03117,.03784,
!     A .04584,.05542,.06685,.08049,.09672,.1160,.1388,.1658,
!     B .1977,.2353,.2796,.3316,.3925,.4638,.5472,.6444,.7577,
!     C .8894,1.042,1.22,1.425,1.622,1.936,2.252,2.615,3.032,
!     D 3.511,4.06,4.688,5.406,6.225,7.159,8.223,9.432,10.80,
!     E 12.36,14.13,16.12,18.38,20.92,23.80,27.03,30.67,34.76,
!     F 39.35,44.49,50.26,56.71,63.93,71.98,80.97,90.98,102.1,
!     G 114.5,128.3,143.6,160.6,179.4,200.2,223.3,248.8,276.9,
!     H 307.9,342.1,379.8,421.3,466.9,517.0,572.0,632.3,698.5,
!     I 770.9,850.2,937.0,1032.0,1146.6,1272.0,1408.1,1556.7,
!     J 1716.9,1890.3,2077.6,2279.6,2496.7,2729.8,2980.,3247.8,
!     K 3534.1,3839.8,4164.8,4510.5,4867.9,5265.1,5675.2,6107.8,
!     L 6566.2,7054.7,7575.3,8129.4,8719.2,9346.5,10013.,10722.,
!     M 11474.,12272.,13119.,14017.,14969.,15977.,17044.,18173.,
!     N 19367.,20630.,21964.,23373.,24861.,26430.,28086.,29831.,
!     O 31671.,33608.,35649.,37796.,40055.,42430.,44927.,47551.,
!     P 50307.,53200.,56236.,59422.,62762.,66264.,69934.,73777.,
!     Q 77802.,82015.,86423.,91034.,95855.,100890.,106160.,
!     R 111660.,117400.,123400.,129650.,136170.,142980.,150070.,
!     S 157460.,165160.,173180.,181530.,190220.,199260./
!
      tp1 = tp
      IF (TP1 .LT. 173.16) GO TO 1
      IF (TP1 .LE. 333.16) GO TO 2
      TP1=333.16
      GO TO 2
 1    TP1=173.16
 2    IT= floor(TP1-173.16)
      FT= IT
      T2=173.16+FT
      ES=(T2+1.0-TP1)*TABLE(IT+1)+(TP1-T2)*TABLE(IT+2)
      ES=ES*.1
!
!     CONVERT FROM ES(LIQUID) TO ES(ICE)
!
!      R1=EXP(28.92-(6142./TP1))
!      R2=EXP(26.27-(5421./TP1))
!      RAT=R1/R2
!                        RAT=1.
!     ES=ES*R1/R2
      RETURN
      END subroutine establ

!#######################################################################


      integer function iequ(x,y)
!
!     Checks for equality of two variable, within a tolerance eps.
!
!     On Input:
!
!        x    first variable
!        y    second variable
!
!     On Output:
!
!        equ  flag, equal to zero if x=y within eps
!                   equal to 10 if x greater than y
!                   equal to -10, if x less than y
!

      real, intent(in) :: x, y
      real :: eps, epsm, d

      iequ=0
      eps=1.e-10
      epsm=-eps
      d=x-y
      if (d .gt. eps) iequ=10
      if (d .lt. epsm) iequ=-10
      return
      end function iequ


!#######################################################################

   subroutine bm_massflux_init ()

!-----------------------------------------------------------------------
!
!        initialization for bm_massflux
!
!-----------------------------------------------------------------------

  integer  unit,io,ierr, logunit

!----------- read namelist ---------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=bm_massflux_nml, iostat=io)
      ierr = check_nml_error(io,"bm_massflux_nml")
#else
      if (file_exist('input.nml')) then
         unit = open_namelist_file ( )
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=bm_massflux_nml, iostat=io, end=10)
            ierr = check_nml_error (io,'bm_massflux_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist --------------------------------------------

      call write_version_number ( version, tagname )
      if ( mpp_pe() == mpp_root_pe() ) then
           logunit = stdlog()
           write (logunit,nml=bm_massflux_nml)
      endif
      call close_file (unit)

      module_is_initialized =.true.

   end subroutine bm_massflux_init

!#######################################################################

   subroutine bm_massflux_end()
   
      module_is_initialized =.false.
   
   end subroutine bm_massflux_end

!#######################################################################

end module bm_massflux_mod





module bm_omp_mod

!----------------------------------------------------------------------
use             mpp_mod, only: input_nml_file
use             fms_mod, only: file_exist, open_namelist_file, check_nml_error, &
                               error_mesg, FATAL, mpp_pe, mpp_root_pe, &
                               close_file, write_version_number, stdlog

use sat_vapor_pres_mod, only:  escomp, descomp
use      constants_mod, only:  HLv,HLs,Cp_air,Grav,rdgas,rvgas, cp_vapor, &
                               kappa

implicit none
private
!-----------------------------------------------------------------------
!  ---- public interfaces ----

   public  bm_omp, bm_omp_init, bm_omp_end

!-----------------------------------------------------------------------
!   ---- version number ----

 character(len=128) :: version = '$Id: bm_omp.F90,v 18.0.2.1 2010/08/30 20:39:42 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
!   ---- local/private data ----

    real, parameter :: d622 = rdgas/rvgas
    real, parameter :: d378 = 1.-d622

    logical :: module_is_initialized =.false.

!-----------------------------------------------------------------------
!   --- namelist ----

real    :: tau_bm=7200.
real    :: rhbm = .8
real    :: revap = 1.0
logical :: do_shallower = .false.
logical :: do_changeqref = .false.

namelist /bm_omp_nml/  tau_bm, rhbm, do_shallower, do_changeqref, revap

!-----------------------------------------------------------------------
!           description of namelist variables
!
!  tau_bm    =  betts-miller relaxation timescale (seconds)
!  rhbm      = relative humidity that you're relaxing towards
!             In contrast to standard BM, this can be put as high as 100%
!             as long as the convection scheme is not overwhelmd by 
!             the large-scale condensation.
!
!  not used:
!
!
!  do_shallower = do the shallow convection scheme where it chooses a smaller
!                 depth such that precipitation is zero
! 
!  do_changeqref = do the shallow convection scheme where if changes the 
!                  profile of both q and T in order make precip zero
!
!-----------------------------------------------------------------------

contains

!#######################################################################

   subroutine bm_omp (dt, tin, qin, pfull, phalf, coldT, &
                           rain, snow, tdel, qdel, q_ref, bmflag, &
                           klzbs, t_ref, &
                           mask, conv)

!-----------------------------------------------------------------------
!
!                     Betts-Miller Convection Scheme
!
!-----------------------------------------------------------------------
!
!   input:  dt       time step in seconds
!           tin      temperature at full model levels
!           qin      specific humidity of water vapor at full
!                      model levels
!           pfull    pressure at full model levels
!           phalf    pressure at half (interface) model levels
!           coldT    should precipitation be snow at this point?
!   optional:
!           mask     optional mask (0 or 1.) 
!           conv     logical flag; if true then no betts-miller
!                       adjustment is performed at that grid-point or
!                       model level
!
!  output:  rain     liquid precipitation (kg/m2)
!           snow     frozen precipitation (kg/m2)
!           tdel     temperature tendency at full model levels
!           qdel     specific humidity tendency (of water vapor) at
!                      full model levels
!           bmflag   flag for which routines you're calling
!           klzbs    stored klzb values
!
!-----------------------------------------------------------------------
!--------------------- interface arguments -----------------------------

   real   , intent(in) , dimension(:,:,:) :: tin, qin, pfull, phalf
   real   , intent(in)                    :: dt
   logical   , intent(in) , dimension(:,:):: coldT
   real   , intent(out), dimension(:,:)   :: rain,snow, bmflag, klzbs
   real   , intent(out), dimension(:,:,:) :: tdel, qdel, q_ref, t_ref
   real   , intent(in) , dimension(:,:,:), optional :: mask
   logical, intent(in) , dimension(:,:,:), optional :: conv
!-----------------------------------------------------------------------
!---------------------- local data -------------------------------------

logical :: avgbl
   real,dimension(size(tin,1),size(tin,2),size(tin,3)) ::  rin
   real,dimension(size(tin,1),size(tin,2))             ::  &
                     hlcp, precip, cape, cin
   real,dimension(size(tin,3))                         :: rpc, tpc
   real                                                ::  & 
       cape1, cin1, tot, deltak, deltaq, qrefint, deltaqfrac, deltaqfrac2, &
       ptopfrac, revap_eff
integer  i, j, k, ix, jx, kx, klzb, ktop, klcl

!modif omp:
real :: q_src_up, ratio, q_src, ratio_q, ratio_T, en_acc, ratio_ml
!-----------------------------------------------------------------------
!     computation of precipitation with a betts-miller-like scheme
!
!        (Olivier Pauluis / Dargan Frierson 2003-2004)
!
!     In this convection scheme, the atmosphere is separated between 
!     a boundary layer and the free troposphere above. The boundary 
!     layer is taken here to be fixed by the liftiing condensation 
!     level. First, a moist adiabat is computed for an air parcel 
!     originating near the surface. Temperature above the LCL are 
!     relaxed toward this moist adiabat, while the BL supply the 
!     moisture. Humidity tendency above the LC are obtained by  
!     precribing the reevaporation rate.
!
!-----------------------------------------------------------------------



      if (.not. module_is_initialized) call error_mesg ('bm_omp',  &
                         'bm_omp_init has not been called.', FATAL)

      ix=size(tin,1)
      jx=size(tin,2)
      kx=size(tin,3)
      avgbl = .false.

!----- compute proper latent heat --------------------------------------
!
!  omp: at this stage,uses only the latent heat of vaporization. 
!       --- this is used only by the energy budget. The lapse rate 
!       has its own value. (This should be made consistent.)  
!      WHERE (coldT)
!           hlcp = HLs/Cp_air
!      ELSEWHERE
           hlcp = HLv/Cp_air
!      END WHERE

!------------------- calculate CAPE and CIN ----------------------------

! calculate r
       rin = qin/(1.0 - qin)
       do i=1,ix
          do j=1,jx

             cape1 = 0.
             cin1 = 0.
             tot = 0.
             klzb=0
             klcl = 0
             bmflag(i,j) = 0.

! the bmflag is written out to show what aspects of the bm scheme is called
! bmflag = 0 is no cape, no convection
! bmflag = 1 cape but no precip: nothing happens
! bmflag = 2 is deep convection

             tpc = tin(i,j,:)
             rpc = rin(i,j,:)
! calculate cape, cin, level of zero buoyancy, and parcel properties w/ leo's
! code
!             call capecalc( Cp_air, cp_vapor, d622, kx, pfull(i,j,:),&
!                            rin(i,j,:), rdgas, hlv, rvgas, tin(i,j,:),&
!                            cape1, cin1, tot, tpc, rpc, klcl, klzb)
             call capecalcnew( kx,  pfull(i,j,:),  phalf(i,j,:),&
                            Cp_air, rdgas, rvgas, hlv, kappa, tin(i,j,:), &
                            rin(i,j,:), avgbl, cape1, cin1, tpc, &
                            rpc, klzb,klcl)
! set values for storage
             cape(i,j) = cape1
             cin(i,j) = cin1
             klzbs(i,j) = klzb
             if(cape1.gt.0.) then
!             if( (tot .gt. 0.) .and. (cape1.gt.0.) ) then 
                bmflag(i,j) = 1.

! reference temperature is just that of the parcel all the way up

                t_ref(i,j,:) = tpc

                do k=klzb,kx
                   q_ref(i,j,k) = rpc(k)/(1. + rpc(k))
                end do

! set the tendencies to zero where you don't adjust
! set the reference profiles to be the original profiles (for diagnostic 
! purposes only --  you can think of this as what you're relaxing to in
! areas above the actual convection

                

                do k=1,max(klzb-1,1)
                   qdel(i,j,k) = 0.0
                   tdel(i,j,k) = 0.0
                   q_ref(i,j,k) = qin(i,j,k)
                   t_ref(i,j,k) = tin(i,j,k)
                end do




! initialize p to zero for the loop

!modif omp: my way...

! check on the LCL. if LCL is less than 50mb above the surface, 
! the 'lcl' is put at the first 
! level above 950mb (required for adjustment near surface) 
! (adjustment dries out ML if lcl too low).

                if (phalf(i,j,kx+1) -phalf(i,j,klcl+1) .LT. 5000) then
                   do k = kx-1,1,-1
                      if (phalf(i,j,kx+1) -phalf(i,j,k+1) .GT. 5000) then
                         klcl = k
                         go to 11
                      end if
                   end do
                end if

! alternatively, just ensure that there is one layer where convection occurs.
!if (klcl .eq. kx ) then
!   klcl = kx -1
!end if


11  continue


                precip(i,j) = 0.0
                q_src_up = 0.0
                en_acc = 0.0
                q_src = 0.0

!adjustement above PBL. 1st compute difference between the 
! profile and computed tendecies
! T adjusted toward pseudo-adiabat
! qv adjusted to reference profile multiplied by prescribed relative humidity

                do k=klzb, klcl

                   tdel(i,j,k) = - (tin(i,j,k) - t_ref(i,j,k))

                   qdel(i,j,k) =  - (qin(i,j,k) - rhbm * q_ref(i,j,k))
                   precip(i,j) = precip(i,j) + tdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav/hlcp(i,j)
!note omp: I change the sign when I changed prec_rev into prec_src!
                   q_src_up = q_src_up - qdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav
                end do

                do k = klcl + 1, kx
!no temperature change in the ML
                   tdel(i,j,k) = 0.0
! alternatively:
! relax the ML temp. toward the pseudo-adiabat
!                tdel(i,j,k) = - (tin(i,j,k) - t_ref(i,j,k))
                   precip(i,j) = precip(i,j) + tdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav/hlcp(i,j)
                end do

! at this point: precip = total amount of precip required to brin the temperature to moist adiabat.
!                q_src_up = total water excess (respectively to moist adiabat)
!                            >0 : there will be a net drying of the free troposphere
!                            <0 : "                 " moistening "                "

! humidity adjustment in the ML

! modif df/omp: changed from earlier version. 
                en_acc = precip(i,j) * grav /   &
                   (phalf(i,j,kx+1) - phalf(i,j,klcl+1))

! en_acc is the change in specific humidity in the BL required to  
! to  bring the free troposphere to the current adiabat. 

! adjustment in the pbl
                do k = klcl + 1, kx
                   qdel(i,j,k) = -min(qin(i,j,k), en_acc)
                   q_src = q_src - qdel(i,j,k)*(phalf(i,j,k+1) - &
                        phalf(i,j,k))/grav
                end do
! Determine the adjustment time-scale
                if (precip(i,j) .gt. 0.0) then 
! note: if cape is computed correctly, precip should always be positive at this point. 

! If precip > 0, then correct energy. 

                   bmflag(i,j) = 2.

                   ratio = min(dt / tau_bm, 1.0)
! modif df: due to the modification above, it's impossible for this to be negative.
!           therefore everything is commented out.  in case someone wants to use
!           this however, I put in the proper correction into the ratio_q line
!           (the added minus sign, which keeps the timescale positive in this case),
!           so this will conserve energy if you uncomment all the rele,vant lines.  
! note omp: q_src should always be positive at this point.


! Adjust T and q, and conserve energy by draining the boundary layer by the 
! required amount.  
                   if (q_src_up.gt.0.0) then
! upper troposphere is getting dryer

                      if ( (q_src + q_src_up) .gt. precip(i,j)) then
! adjustment limited by temperature
                         ratio_T = ratio
                         ratio_q = (ratio * precip(i,j)) / (q_src + q_src_up) 
                         ratio_ML = ratio_q
                      else
! adjustment limited by water supply
                         ratio_q = ratio
                         ratio_ML = ratio
                         ratio_T = ratio * (q_src + q_src_up)/precip(i,j) 
                      end if
                   else
! upper troposphere is getting more humid

                      revap_eff = min(revap, -q_src_up/precip(i,j))
                         if (q_src .gt. (precip(i,j) * (1+revap_eff))) then
                            ratio_T = ratio
                            ratio_ML = ratio * precip(i,j) * (1+revap_eff) / q_src 
                            ratio_q = (ratio_T * precip(i,j) - ratio_ML * q_src )/ (q_src_up)
                         else 
                            ratio_ML = ratio
                            ratio_T =  ratio *q_src / ( precip(i,j) * (1+revap_eff))
                            ratio_q = (ratio_T * precip(i,j) - ratio_ML * q_src )/ (q_src_up)
                         end if
                      end if

!adjust the tendencies
                
                   do k = klzb,klcl
                      qdel(i,j,k)= qdel(i,j,k) * ratio_q  
                      tdel(i,j,k)= tdel(i,j,k) * ratio_T 
                   end do
                   do k = klcl+1,kx
                      qdel(i,j,k)= qdel(i,j,k) * ratio_ML  
                      tdel(i,j,k)= tdel(i,j,k) * ratio_T
                   end do
                   precip(i,j) = precip(i,j) * ratio_T
                       





                else

!              write(*,*) 'warning: precip < 0 in bm_omp'
!              write(*,*) 'this should not happen!!! i = ',i,'j=',j
!              write(*,*) 'cape =  ',cape(i,j),'precip(i,j)',precip(i,j)
              

!omp: This is Dargan's and not used in my version (put do_shallower and  
!do change_qref as .false.

! Shallow / non-precipitating adjustment from dargan. It has not been tested 
! with this version of the deep convection scehme. Use do_shallower = .false.
! and do_changeqref = .false. to turn off. In this case, no convection occurs 
! when the computed precipitation is 0. 


! If precip < 0, then do the shallow conv routine.
! First option: do_shallower = true
! This chooses the depth of convection based on choosing the height that 
! it can make precip zero, i.e., subtract off heights until that precip 
! becomes positive.  

                    if (do_shallower) then
! ktop is the new top of convection.  set this initially to klzb.
                       ktop = klzb
! Work your way down until precip is positive again.
                       do while ( (precip(i,j).lt.0) .and. (ktop.le.kx) )
                          precip(i,j) = precip(i,j) - qdel(i,j,ktop)* &
                                   (phalf(i,j,ktop) - phalf(i,j,ktop+1))/grav
                          ktop = ktop + 1
                       end do
! since there will be an overshoot (precip is going to be greater than zero 
! once we finish this), the actual new top of convection is somewhere between
! the current ktop, and one level above this.  set ktop to the level above.
                       ktop = ktop - 1
! Adjust the tendencies in the places above back to zero, and the reference 
! profiles back to the original t,q.
                       if (ktop.gt.klzb) then
                          qdel(i,j,klzb:ktop-1) = 0.
                          q_ref(i,j,klzb:ktop-1) = qin(i,j,klzb:ktop-1)
                          tdel(i,j,klzb:ktop-1) = 0.
                          t_ref(i,j,klzb:ktop-1) = tin(i,j,klzb:ktop-1)
                       end if
! Then make the change only a fraction of the new top layer so the precip is 
! identically zero.
! Calculate the fractional penetration of convection through that top layer.  
! This is the amount necessary to make precip identically zero.  
                       ptopfrac = precip(i,j)/(qdel(i,j,ktop)* &
                          (phalf(i,j,ktop+1) - phalf(i,j,ktop)))
! Reduce qdel in the top layer by this fraction. 
                       qdel(i,j,ktop) = ptopfrac*qdel(i,j,ktop)
! Set precip to zero
                       precip(i,j) = 0.
! A diagnostic which allows calculating precip to make sure it's zero.
                       do k=ktop,kx
                          precip(i,j)=precip(i,j)+qdel(i,j,k)* &
                                 (phalf(i,j,k) - phalf(i,j,k+1))/grav
                       end do
                       if (abs(precip(i,j)).gt.1.e-5) &
                           write(6,*) 'doh! precip.ne.0'
! Now change the reference temperature in such a way to make the net 
! heating zero.
                       deltak = 0.
                       if (ktop.lt.kx) then
! Integrate temperature tendency up to 1 level below top.
                          do k=ktop+1,kx
                             deltak = deltak + tdel(i,j,k)* &
                                 (phalf(i,j,k) - phalf(i,j,k+1))
                          end do
! Then for the top level, use only a fraction.
                          deltak = deltak + ptopfrac*tdel(i,j,ktop)* &
                               (phalf(i,j,ktop) - phalf(i,j,ktop+1))
! Normalize by the pressure difference.
                          deltak = deltak/(phalf(i,j,kx+1) - & 
                           phalf(i,j,ktop+1) + ptopfrac*(phalf(i,j,ktop+1) - &
                           phalf(i,j,ktop)))
! Subtract this value uniformly from tdel, and make the according change to 
! t_ref.
                          do k=ktop,kx
                             tdel(i,j,k) = tdel(i,j,k) + deltak
                             t_ref(i,j,k) = t_ref(i,j,k) + deltak*tau_bm/dt
                          end do
                       end if
                    else if(do_changeqref) then
! Change the reference profile of q by a certain fraction so that precip is 
! zero.  This involves calculating the total integrated q_ref dp (this is the
! quantity intqref), as well as the necessary change in q_ref (this is the 
! quantity deltaq).  Then the fractional change in q_ref at each level (the 
! quantity deltaqfrac) is 1-deltaq/intqref.  (have to multiply q_ref by 
! 1-deltaq/intqref at every level)  Then the change in qdel is 
! -deltaq/intqref*q_ref*dt/tau_bm.
! Change the reference profile of T by a uniform amount so that precip is zero.
                       deltak = 0.
                       deltaq = 0.
                       qrefint = 0.
                       do k=klzb,kx
! deltaq = a positive quantity (since int qdel is positive).  It's how 
! much q_ref must be changed by, in an integrated sense.  The requisite 
! change in qdel is this without the factors of tau_bm and dt.
                          deltaq = deltaq - qdel(i,j,k)*tau_bm/dt* &
                                    (phalf(i,j,k) - phalf(i,j,k+1))
! deltak = the amount tdel needs to be changed
                          deltak  = deltak  + tdel(i,j,k)* &
                                    (phalf(i,j,k) - phalf(i,j,k+1))
! qrefint = integrated value of qref
                          qrefint = qrefint - q_ref(i,j,k)* &
                                    (phalf(i,j,k) - phalf(i,j,k+1))
                       end do
! Normalize deltak by total pressure.
                       deltak  = deltak /(phalf(i,j,kx+1) - phalf(i,j,klzb))
! multiplying factor for q_ref is 1 + the ratio
                       deltaqfrac = 1. - deltaq/qrefint
! multiplying factor for qdel adds dt/tau_bm
                       deltaqfrac2 = - deltaq/qrefint*dt/tau_bm
! let's check that the precip really is zero as in the shallower scheme
                       precip(i,j) = 0.0
                       do k=klzb,kx
                          qdel(i,j,k) = qdel(i,j,k) + deltaqfrac2*q_ref(i,j,k)
                          q_ref(i,j,k) = deltaqfrac*q_ref(i,j,k)
                          tdel(i,j,k) = tdel(i,j,k) + deltak
                          t_ref(i,j,k) = t_ref(i,j,k) + deltak*tau_bm/dt
                          precip(i,j) = precip(i,j) + qdel(i,j,k)* &
                                 (phalf(i,j,k) - phalf(i,j,k+1))/grav
                       end do
                       if (abs(precip(i,j)).gt.1.e-5) &
                         write(6,*) 'doh! precip.ne.0)'
                    else
                       precip(i,j) = 0.
                       tdel(i,j,:) = 0.
                       qdel(i,j,:) = 0.
                    end if
                end if
             else 
                tdel(i,j,:) = 0.0
                qdel(i,j,:) = 0.0
                precip(i,j) = 0.0
                q_ref(i,j,:) = qin(i,j,:)
                t_ref(i,j,:) = tin(i,j,:)
             end if
          end do
       end do

       rain = precip
       snow = 0.
   

   end subroutine bm_omp

!#######################################################################

    subroutine capecalc(cpd, cpv, epsilo, nlev, pback, rback, rd, rl, rv, &
                        tback, xcape, cin, tot, tpcback, rpcback,         &
                        klclback, klzbback)
!
! modif omp: klcl is an additional output

!      Calculates convective available potential energy for a cloud whose
!      temperature follows a saturated adiabat.
!
!      On Input
!
!      cpd     specific heat of dry air at constant pressure (J/(kg K))
!      cpv     specific heat of water vapor
!      epsilo  ratio of molecular weights of water vapor to dry air
!      nlev    number of levels 
!      p       pressure (Pa)
!              Index 1 refers to level nearest earth's surface.
!      r       mixing ratio (kg(H2O)/kg)
!              Index 1 refers to level nearest earth's surface.
!      rd      gas constant for dry air (J/(kg K))
!      rl      latent heat of vaporization (J/kg)
!      rv      gas constant for water vapor (J/(kg K))
!      t       temperature (K)
!              Index 1 refers to level nearest earth's surface.
!
!     Output:
!   
!     tpc      parcel temperature (K)
!              Set to environment below istart.
!              Index 1 refers to level nearest earth's surface.
!     rpc      parcel mixing ratio (kg(H2O)/kg)
!              Set to environment below istart.
!              Index 1 refers to level nearest earth's surface.
!     cin      convective inhibition (J/kg)
!              energy required to lift parcel from level istart to
!              level of free convection
!     xcape    convective available potential energy (J/kg)
!              energy released as parcel moves from level of free
!              convection to level of zero buoyancy
!     tot      xcape+cin (J/kg)
!     klcl     first level above the LCL
!     klzb     the level where you hit LZB
!
!     For definitions of cin and xcape, see notes (4 Apr 95) (LAN Notes).
!
        implicit none
        integer, intent(in) :: nlev
        REAL, INTENT (IN),    DIMENSION(:) :: pback, tback, rback
        real, intent (in) :: cpd, cpv, epsilo, rd, rl, rv
        integer, intent(out) :: klzbback, klclback
        real, intent (out) :: xcape, cin, tot
        real, intent (out), dimension(nlev) :: tpcback, rpcback

      integer :: istart, ieq, klcl, k, klzb, klfc, ieqa, nlevm
      logical :: capepos
      real, dimension(nlev) :: p, r, t, tpc, rpc
      real :: ro, tc, tp, plcl, es, rs, rlcl, tlcl, pb, tb, rb, q, cp, dp, &
              dt1, plzb, qe, tve, pc, qs, tv, rc, fact1, fact2, fact3, &
              dtdp, rbc, rbe, qc, tvc, delt

!modif omp
      real :: rsb, tplcl

!      parameter(nlev=25,nlevm=nlev-1)
!      dimension t(nlev),r(nlev),p(nlev)
!      dimension tpc(nlev),rpc(nlev)
!      logical capepos
!
      capepos=.false.
      nlevm = nlev-1

     do k=1,nlev
        t(k) = tback(nlev+1-k)
        r(k) = rback(nlev+1-k)
        p(k) = pback(nlev+1-k)
        tpc(k) = t(k)
        rpc(k) = r(k)
     end do

!
!     Calculate LCL
!     istart-index of level whose mixing ratio is conserved as a parcel 
!            leaves it undergoing dry adiabatic ascent
!
      istart=1
      ro=r(istart)
      tc=t(istart)
      tp=tc
      plcl=0.
      do k=1,istart
        tpc(k)=t(k)
        rpc(k)=r(k)
      end do
      do k=istart,nlev
        call establ(es,tp)
        rs=epsilo*es/(p(k)+(epsilo-1.)*es)
!       write(6,*) 'k,tp,rs= ',k,tp,rs
        ieq=iequ(rs,ro)
        if (ieq .eq. 0) then
          plcl=p(k)
          rlcl=r(k)
          tlcl=t(k)
          klcl=k
          go to 11
        end if
        if (k .eq. istart) then
           if (ieq .lt. 0) then
              plcl=p(istart)
              tlcl=t(istart)
              rlcl=r(istart)
! omp: try this before, did not change much. 
! (The lowest level should not be supersaturated.)
!             rlcl=rs
              klcl=istart
              go to 11
           else
              go to 13
           end if
        end if
        if (k .gt. 1) then
           pb=(p(k)+p(k-1))/2.
           tb=(t(k)+t(k-1))/2.
           rb=(r(k)+r(k-1))/2.
           if (rs .lt. ro) then

              fact1 = (ro - rs)/(rsb-rs)
              fact2 = (rsb - ro)/(rsb-rs)
              plcl=fact1* p(k-1) + fact2 * p(k) 
              tlcl=fact1* t(k-1) + fact2 * t(k) 
              rlcl=rb
             tplcl = fact1* tpc(k-1) + fact2 * tpc(k) 
             klcl=k
             go to 11
           end if
        end if
if (k .eq. nlev) go to 11

!     Convert mixing ratio to specific humidity.
!
 13   continue
         q=ro/(1.+ro)
         cp=cpd*(1.+((cpv/cpd)-1.)*q)
         dp=p(k+1)-p(k)
         dtdp=rd*tp/cp
!        write(6,*) 'dp,dtdp,pb= ',dp,dtdp,pb
         dt1=dtdp*alog((p(k)+dp)/p(k))
         tp=tp+dt1
         tpc(k+1)=tp
         rpc(k+1)=ro
         rsb = rs
      end do
 11   continue
      ieq=iequ(plcl,0.)
      if (ieq .eq. 0) then
         xcape = 0.
         cin = 0.
         tot = 0.
         tpcback = tback
         rpcback = rback
!        write(6,*) 'plcl=0'
         call error_mesg ('bm_omp:capecalc', 'ieq = 0', FATAL)
!         stop
      end if
!
!     Calculate temperature along saturated adiabat, starting at p(kLCL).
!
!       write(6,*) 'plcl,klcl,tlcl,rlcl= ',plcl,klcl,tlcl,rlcl
!       write(6,*) 'p(klcl)= ',p(klcl)

!modif omp: first find saturated temp at level klcl
!           In the previous version, the parcel temperature
!           was obtained from a dry adiabat ascent all the way
!           to the level k. 




      tc = tplcl
      call establ(es,tc)
      pc = plcl
      rs=epsilo*es/(pc+(epsilo-1.)*es)
      qs=rs/(1.+rs)
      tv=tc*(1.+.61*qs)
      dp=p(klcl)-plcl
      rc=(1.-qs)*rd+qs*rv
!         write(6,*) 'tv= ',tv
      pb=(p(klcl)+plcl)/2.
      fact1=rd/cpd
      fact2=tv+(rl*qs/rc)
!         write(6,*) 'fact1,fact2,rc= ',fact1,fact2,rc
      fact1=fact1*fact2
      fact3=epsilo*(rl**2)*es/(cpd*pb*rv*(tv**2))
!         write(6,*) 'fact1,fact3= ',fact1,fact3
      fact3=1.+fact3
      dtdp=fact1/fact3
!         write(6,*) 'dtdp= ',dtdp
      tc=tc+dtdp*alog((pc+dp)/pc)
!         write(6,*) 'tc,t= ',tc,t(k+1)
      tpc(klcl)=tc
      rpc(klcl)=rs
!         write(6,*) 'p,r,rs= ',p(k+1),r(k+1),rs

!       tc=tpc(klcl)
!end modif omp


! omp note: the adiabat is computed by a forward integeration of the
! lapse rate. Thiscould be improved at coarse resolution by implementing 
! a 2nd or 3rd order Runge-Kunta scheme.

       plzb=0.
       do k=klcl,nlevm
          qe=r(k)/(1.+r(k))
          tve=t(k)*(1.+.61*qe)
          call establ(es,tc)
          pc=p(k)
          rs=epsilo*es/(pc+(epsilo-1.)*es)
          qs=rs/(1.+rs)
          tv=tc*(1.+.61*qs)
!         write(6,*) 'k,tv,tve= ',k,tv,tve
          ieq=iequ(tv,tve)
          if ((ieq .gt. 0) .and. (.not. capepos)) then
             capepos=.true.
          end if
          if ((ieq .lt. 0) .and. (capepos)) then
             klzb=k
             plzb=(p(k)+p(k-1))/2.
!            write(6,*) 'klzb,plzb,p(klzb)= ',klzb,plzb,p(klzb)
             go to 12
          end if
          dp=p(k+1)-p(k)
          rc=(1.-qs)*rd+qs*rv
!         write(6,*) 'tv= ',tv
          pb=(p(k)+p(k+1))/2.
          fact1=rd/cpd
          fact2=tv+(rl*qs/rc)
!         write(6,*) 'fact1,fact2,rc= ',fact1,fact2,rc
          fact1=fact1*fact2
          fact3=epsilo*(rl**2)*es/(cpd*pb*rv*(tv**2))
!         write(6,*) 'fact1,fact3= ',fact1,fact3
          fact3=1.+fact3
          dtdp=fact1/fact3
!         write(6,*) 'dtdp= ',dtdp
          tc=tc+dtdp*alog((pc+dp)/pc)
!         write(6,*) 'tc,t= ',tc,t(k+1)
          tpc(k+1)=tc
          rpc(k+1)=rs
!         write(6,*) 'p,r,rs= ',p(k+1),r(k+1),rs
       end do
 12    continue
      ieq=iequ(plzb,0.)
      if (ieq .eq. 0) then
         xcape = 0.
         cin = 0.
         tot = 0.
         tpcback = tback
         rpcback = rback
!        write(6,*) 'plzb=0'
         return
      end if
      cin=0.
      xcape=0.
      tot=0.
!
!     Calculate convective inhibition.
!
       klfc=0
       do k=istart,nlevm
          ieq=iequ(p(k),plzb)
          if (ieq .le. 0) then
!            write(6,*) 'cin= ',cin
!            write(6,*) 'cape = 0 NO LFC'
             return 
          end if
          rbc=(rpc(k)+rpc(k+1))/2.
          rbe=(r(k)+r(k+1))/2.
          qc=rbc/(1.+rbc)
          qe=rbe/(1.+rbe)
          tvc=tpc(k)*(1.+.61*qc)
          tve=t(k)*(1.+.61*qe)
!         write(6,*) 'k,tvc,tve= ',k,tvc,tve
          ieq=iequ(tvc,tve)
          ieqa=iequ(p(k),plcl)
          if ((ieq .le. 0) .or. (ieqa .ge. 0)) then
             delt=rd*(tvc-tve)*alog(p(k)/p(k+1))
             cin=cin-delt
          else
             klfc=k
             go to 14
          end if
       end do
 14    continue
!
!      Calculate convective available potential energy.
!
!       write(6,*) 'klfc,p(klfc)= ',klfc,p(klfc)
!
! omp note: CAPE is calculated using full levels. This can create a
! significant amount of flickering, espcially when the LCL and LZB
! switch from one model level to another. 
!
       if (klfc .eq. 0) then
          xcape=0.
!         write(6,*) 'klfc=0'
          return
       end if
       do k=klfc,klzb
          ieq=iequ(p(k+1),plzb)
          if (ieq .ge. 0) then
             rbc=(rpc(k)+rpc(k+1))/2.
             rbe=(r(k)+r(k+1))/2.
             qc=rbc/(1.+rbc)
             qe=rbe/(1.+rbe)
             tvc=tpc(k)*(1.+.61*qc)
             tve=t(k)*(1.+.61*qe)
             ieq=iequ(tvc,tve)
             if (ieq .gt. 0) then
                delt=rd*(tvc-tve)*alog(p(k)/p(k+1))
!               write(6,*) 'cape k,delt,xcape= ',k,delt,xcape
                xcape=xcape+delt
                if (xcape .lt. 0.) then
!                  write(6,*) 'xcape error'
                   call error_mesg ('bm_omp:capecalc', &
                                    'xcape error', FATAL)
!                  stop
                end if
              end if
          end if
       end do
       tot=xcape-cin
!       write(6,*) 'cin= ',cin,' J/kg'
!       write(6,*) 'xcape= ',xcape,' J/kg'
!       write(6,*) 'tot= ',tot,' J/kg'
       do k=1,nlev
          tpcback(k) = tpc(nlev+1-k)
          rpcback(k) = rpc(nlev+1-k)
       end do
       klzbback = nlev + 1 - klzb
      klclback = nlev + 1 - klcl

       return
       end subroutine capecalc


!#######################################################################
!all new cape calculation.

      subroutine capecalcnew(kx,p,phalf,Cp_air,rdgas,rvgas,hlv,kappa,tin,rin,&
                             avgbl,cape,cin,tp,rp,klzb,klcl)

!
!    Input:
!
!    kx          number of levels
!    p           pressure (index 1 refers to TOA, index kx refers to surface)
!    phalf       pressure at half levels
!    Cp_air      specific heat of dry air
!    rdgas       gas constant for dry air
!    rvgas       gas constant for water vapor (used in Clausius-Clapeyron, 
!                not for virtual temperature effects, which are not considered)
!    hlv         latent heat of vaporization
!    kappa       the constant kappa
!    tin         temperature of the environment
!    rin         specific humidity of the environment
!    avgbl       if true, the parcel is averaged in theta and r up to its LCL
!
!    Output:
!    cape        Convective available potential energy
!    cin         Convective inhibition (if there's no LFC, then this is set 
!                to zero)
!    tp          Parcel temperature (set to the environmental temperature 
!                where no adjustment)
!    rp          Parcel specific humidity (set to the environmental humidity 
!                where no adjustment, and set to the saturation humidity at 
!                the parcel temperature below the LCL)
!    klzb        Level of zero buoyancy
!    klcl        Lifting condensation level
!
!    Algorithm: 
!    Start with surface parcel. 
!    Calculate the lifting condensation level (uses an analytic formula and a 
!       lookup table).  
!    Average under the LCL if desired, if this is done, then a new LCL must
!       be calculated.  
!    Calculate parcel ascent up to LZB.
!    Calculate CAPE and CIN.  
      implicit none
      integer, intent(in)                    :: kx
      logical, intent(in)                    :: avgbl
      real, intent(in), dimension(:)         :: p, phalf, tin, rin
      real, intent(in)                       :: rdgas, rvgas, hlv, kappa, Cp_air
      integer, intent(out)                   :: klzb, klcl
      real, intent(out), dimension(:)        :: tp, rp
      real, intent(out)                      :: cape, cin

      integer            :: k, klfc, klcl2
      logical            :: nocape
      real, dimension(kx)   :: theta
      real                  :: t0, r0, es, rs, theta0, pstar, value, tlcl, &
                               a, b, dtdlnp, thetam, rm, tlcl2, &
                               plcl2, plcl, plzb

      pstar = 1.e5

      nocape = .true.
      cape = 0.
      cin = 0.
      plcl = 0.
      plzb = 0.
      klfc = 0
      klcl = 0
      klzb = 0
      tp(1:kx) = tin(1:kx)
      rp(1:kx) = rin(1:kx)

! start with surface parcel
      t0 = tin(kx)
      r0 = rin(kx)
! calculate the lifting condensation level by the following:
! are you saturated to begin with?  
!      call establ(es,t0)
      call escomp(t0,es)
      rs = rdgas/rvgas*es/p(kx)
      if (r0.ge.rs) then
! if youre already saturated, set lcl to be the surface value.
         plcl = p(kx)
! the first level where youre completely saturated.
         klcl = kx
! saturate out to get the parcel temp and humidity at this level
! first order (in delta T) accurate expression for change in temp
         tp(kx) = t0 + (r0 - rs)/(Cp_air/hlv + hlv*rs/rvgas/t0**2.)
!         call establ(es,tp(kx))
         call escomp(tp(kx),es)
         rp(kx) = rdgas/rvgas*es/p(kx)
      else
! if not saturated to begin with, use the analytic expression to calculate the 
! exact pressure and temperature where youre saturated.  
         theta0 = tin(kx)*(pstar/p(kx))**kappa
! the expression that we utilize is log(r/theta**(1/kappa)*pstar*rvgas/rdgas) =
! log(es/T**(1/kappa))
! The right hand side of this is only a function of temperature, therefore 
! this is put into a lookup table to solve for temperature.  
         if (r0.gt.0.) then
            value = log(theta0**(-1/kappa)*r0*pstar*rvgas/rdgas)
            call lcltabl(value,tlcl)
            plcl = pstar*(tlcl/theta0)**(1/kappa)
! just in case plcl is very high up
            if (plcl.lt.p(1)) then
               plcl = p(1)
               tlcl = theta0*(plcl/pstar)**kappa
               write (*,*) 'hi lcl'
            end if
            k = kx
         else
! if the parcel sp hum is zero or negative, set lcl to 2nd to top level
            plcl = p(2)
            tlcl = theta0*(plcl/pstar)**kappa
!            write (*,*) 'zero r0', r0
            do k=2,kx
               tp(k) = theta0*(p(k)/pstar)**kappa
               rp(k) = 0.
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            end do
            go to 11
         end if
! calculate the parcel temperature (adiabatic ascent) below the LCL.  
! the mixing ratio stays the same
!!! the right command??
         do while (p(k).gt.plcl)
            tp(k) = theta0*(p(k)/pstar)**kappa
!            call establ(es,tp(k))
            call escomp(tp(k),es)
            rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            k = k-1
         end do
! first level where youre saturated at the level
         klcl = k
         if (klcl.eq.1) klcl = 2
! do a saturated ascent to get the parcel temp at the LCL.  
! use your 2nd order equation up to the pressure above.  
! moist adaibat derivatives: (use the lcl values for temp, humid, and 
! pressure)
         a = kappa*tlcl + hlv/Cp_air*r0
         b = hlv**2.*r0/Cp_air/rvgas/tlcl**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
! second order in p (RK2)
! first get temp halfway up 
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)/2.
         if ((tp(klcl).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/(p(klcl) + plcl)*2.
         a = kappa*tp(klcl) + hlv/Cp_air*rp(klcl)
         b = hlv**2./Cp_air/rvgas*rp(klcl)/tp(klcl)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
!         d2tdlnp2 = (kappa + b - 1. - b/tlcl*(hlv/rvgas/tlcl - &
!                   2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*r0/Cp_air/ &
!                   (1. + b)
! second order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl) + .5*d2tdlnp2*(log(&
!             p(klcl)/plcl))**2.
!         call establ(es,tp(klcl))
         call escomp(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/p(klcl)
!         write (*,*) 'tp, rp klcl:kx, new', tp(klcl:kx), rp(klcl:kx)
! CAPE/CIN stuff
         if ((tp(klcl).lt.tin(klcl)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(klcl) - &
                 tp(klcl))*log(phalf(klcl+1)/phalf(klcl))
         else
! if youre buoyant, then add to cape
            cape = cape + rdgas*(tp(klcl) - &
                  tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if its the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = klcl
            endif
         end if
      end if
! then average the properties over the boundary layer if so desired.  to give 
! a new "parcel".  this may not be saturated at the LCL, so make sure you get 
! to a level where it is before moist adiabatic ascent!
!!!! take out all the below (between the exclamation points) if no avgbl !!!!
      if (avgbl) then
         theta(klcl:kx) = tin(klcl:kx)*(pstar/p(klcl:kx))**kappa
         thetam = 0.
         rm = 0.
         do k=klcl,kx
            thetam = thetam + theta(k)*(phalf(k+1) - phalf(k))
            rm = rm + rin(k)*(phalf(k+1) - phalf(k))
         end do
         thetam = thetam/(phalf(kx+1) - phalf(klcl))
         rm = rm/(phalf(kx+1) - phalf(klcl))
! check if youre saturated at the top level.  if not, then get a new LCL
         tp(klcl) = thetam*(p(klcl)/pstar)**kappa
!         call establ(es,tp(klcl))
         call escomp(tp(klcl),es)
         rs = rdgas/rvgas*es/p(klcl)
! if youre not saturated, get a new LCL
         if (rm.lt.rs) then
! reset CIN to zero.  
            cin = 0.
! again, use the analytic expression to calculate the exact pressure and 
! temperature where youre saturated.  
! the expression that we utilize is log(r/theta**(1/kappa)*pstar*rvgas/rdgas)=
! log(es/T**(1/kappa))
! The right hand side of this is only a function of temperature, therefore 
! this is put into a lookup table to solve for temperature.  
            value = log(thetam**(-1/kappa)*rm*pstar*rvgas/rdgas)
            call lcltabl(value,tlcl2)
            plcl2 = pstar*(tlcl2/thetam)**(1/kappa)
! just in case plcl is very high up
            if (plcl2.lt.p(1)) then
               plcl2 = p(1)
            end if
            k = kx
! calculate the parcel temperature (adiabatic ascent) below the LCL.  
! the mixing ratio stays the same
!!! the right command??
            do while (p(k).gt.plcl2) 
               tp(k) = thetam*(p(k)/pstar)**kappa
!               call establ(es,tp(k))
               call escomp(tp(k),es)
               rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
               k = k-1
            end do
! first level where you're saturated at the level
            klcl2 = k
            if (klcl2.eq.1) klcl2 = 2
! do a saturated ascent to get the parcel temp at the LCL.  
! use your 2nd order equation up to the pressure above.  
! moist adaibat derivatives: (use the lcl values for temp, humid, and 
! pressure)
            a = kappa*tlcl2 + hlv/Cp_air*rm
            b = hlv**2.*rm/Cp_air/rvgas/tlcl2**2.
            dtdlnp = a/(1. + b)
! first order in p
!            tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)
! second order in p (RK2)
! first get temp halfway up 
         tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)/2.
         if ((tp(klcl2).lt.173.16).and.nocape) go to 11
         call escomp(tp(klcl2),es)
         rp(klcl2) = rdgas/rvgas*es/(p(klcl2) + plcl2)*2.
         a = kappa*tp(klcl2) + hlv/Cp_air*rp(klcl2)
         b = hlv**2./Cp_air/rvgas*rp(klcl2)/tp(klcl2)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2)
!            d2tdlnp2 = (kappa + b - 1. - b/tlcl2*(hlv/rvgas/tlcl2 - &
!                          2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*rm/Cp_air/ &
!                          (1. + b)
! second order in p
!            tp(klcl2) = tlcl2 + dtdlnp*log(p(klcl2)/plcl2) + &
!               .5*d2tdlnp2*(log(p(klcl2)/plcl2))**2.
!            call establ(es,tp(klcl2))
            call escomp(tp(klcl2),es)
            rp(klcl2) = rdgas/rvgas*es/p(klcl2)
! CAPE/CIN stuff
            if ((tp(klcl2).lt.tin(klcl2)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
               cin = cin + rdgas*(tin(klcl2) - &
                    tp(klcl2))*log(phalf(klcl2+1)/phalf(klcl2))
            else
! if youre buoyant, then add to cape
               cape = cape + rdgas*(tp(klcl) - &
                     tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if its the first time buoyant, then set the level of free convection to k
               if (nocape) then
                  nocape = .false.
                  klfc = klcl2
               endif
            end if
         end if
      end if
!!!! take out all of the above (within the exclamations) if no avgbl !!!!
! then, start at the LCL, and do moist adiabatic ascent by the first order 
! scheme -- 2nd order as well
      do k=klcl-1,1,-1
         a = kappa*tp(k+1) + hlv/Cp_air*rp(k+1)
         b = hlv**2./Cp_air/rvgas*rp(k+1)/tp(k+1)**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
! second order in p (RK2)
! first get temp halfway up 
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))/2.
         if ((tp(k).lt.173.16).and.nocape) go to 11
         call escomp(tp(k),es)
         rp(k) = rdgas/rvgas*es/(p(k) + p(k+1))*2.
         a = kappa*tp(k) + hlv/Cp_air*rp(k)
         b = hlv**2./Cp_air/rvgas*rp(k)/tp(k)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
!         d2tdlnp2 = (kappa + b - 1. - b/tp(k+1)*(hlv/rvgas/tp(k+1) - & 
!               2.)*dtdlnp)/(1. + b)*dtdlnp - hlv/Cp_air*rp(k+1)/(1. + b)
! second order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1)) + .5*d2tdlnp2*(log( &
!             p(k)/p(k+1)))**2.
! if you're below the lookup table value, just presume that there's no way 
! you could have cape and call it quits
         if ((tp(k).lt.173.16).and.nocape) go to 11
!         call establ(es,tp(k))
         call escomp(tp(k),es)
         rp(k) = rdgas/rvgas*es/p(k)
         if ((tp(k).lt.tin(k)).and.nocape) then
! if youre not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
         elseif((tp(k).lt.tin(k)).and.(.not.nocape)) then
! if you have CAPE, and its your first time being negatively buoyant, 
! then set the level of zero buoyancy to k+1, and stop the moist ascent
            klzb = k+1
            go to 11
         else
! if youre buoyant, then add to cape
            cape = cape + rdgas*(tp(k) - tin(k))*log(phalf(k+1)/phalf(k))
! if its the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = k
            endif
         end if
      end do
 11   if(nocape) then 
! this is if you made it through without having a LZB
! set LZB to be the top level.
         plzb = p(1)
         klzb = 0
         klfc = 0
         cin = 0.
         tp(1:kx) = tin(1:kx)
         rp(1:kx) = rin(1:kx)
      end if
!      write (*,*) 'plcl, klcl, tlcl, r0 new', plcl, klcl, tlcl, r0
!      write (*,*) 'tp, rp new', tp, rp
!       write (*,*) 'tp, new', tp
!       write (*,*) 'tin new', tin 
!       write (*,*) 'klcl, klfc, klzb new', klcl, klfc, klzb
      end subroutine capecalcnew

! lookup table with e_s(T) using the new analytic expression
      subroutine establ2(es,t)
      

! Table of es values as a function of temperature.  
! Uses the analytic expression for e_s which assumes fixed latent heat 
!    coefficient.  
! Gives the values from -100 to 60 Celsius in 1 degree increments.  

      implicit none 
      real, intent(in)     :: t
      real, intent(out)    :: es

      integer              :: it
      real, dimension(161) :: table
      real                 :: t1, t2

      data table /      6.4876769e-03,   7.7642650e-03,   9.2730105e-03, &
       1.1052629e-02,   1.3147696e-02,   1.5609446e-02,   1.8496657e-02, &
       2.1876647e-02,   2.5826384e-02,   3.0433719e-02,   3.5798760e-02, &
       4.2035399e-02,   4.9272997e-02,   5.7658264e-02,   6.7357319e-02, &
       7.8557979e-02,   9.1472273e-02,   1.0633921e-01,   1.2342784e-01, &
       1.4304057e-01,   1.6551683e-01,   1.9123713e-01,   2.2062738e-01, &
       2.5416374e-01,   2.9237778e-01,   3.3586224e-01,   3.8527718e-01, &
       4.4135673e-01,   5.0491638e-01,   5.7686092e-01,   6.5819298e-01, &
       7.5002239e-01,   8.5357615e-01,   9.7020925e-01,   1.1014164e+00, &
       1.2488446e+00,   1.4143067e+00,   1.5997959e+00,   1.8075013e+00, &
       2.0398249e+00,   2.2993996e+00,   2.5891082e+00,   2.9121041e+00, &
       3.2718336e+00,   3.6720588e+00,   4.1168837e+00,   4.6107798e+00, &
       5.1586157e+00,   5.7656865e+00,   6.4377468e+00,   7.1810447e+00, &
       8.0023579e+00,   8.9090329e+00,   9.9090255e+00,   1.1010944e+01, &
       1.2224096e+01,   1.3558536e+01,   1.5025116e+01,   1.6635542e+01, &
       1.8402429e+01,   2.0339361e+01,   2.2460955e+01,   2.4782931e+01, &
       2.7322176e+01,   3.0096824e+01,   3.3126327e+01,   3.6431545e+01, &
       4.0034823e+01,   4.3960087e+01,   4.8232935e+01,   5.2880735e+01, &
       5.7932732e+01,   6.3420149e+01,   6.9376307e+01,   7.5836738e+01, &
       8.2839310e+01,   9.0424352e+01,   9.8634795e+01,   1.0751630e+02, &
       1.1711742e+02,   1.2748974e+02,   1.3868802e+02,   1.5077039e+02, &
       1.6379851e+02,   1.7783773e+02,   1.9295728e+02,   2.0923048e+02, &
       2.2673493e+02,   2.4555268e+02,   2.6577049e+02,   2.8748004e+02, &
       3.1077813e+02,   3.3576694e+02,   3.6255429e+02,   3.9125382e+02, &
       4.2198536e+02,   4.5487511e+02,   4.9005594e+02,   5.2766770e+02, &
       5.6785749e+02,   6.1078000e+02,   6.5659776e+02,   7.0548154e+02, &
       7.5761062e+02,   8.1317317e+02,   8.7236659e+02,   9.3539788e+02, &
       1.0024840e+03,   1.0738523e+03,   1.1497408e+03,   1.2303987e+03, &
       1.3160868e+03,   1.4070779e+03,   1.5036572e+03,   1.6061228e+03, &
       1.7147860e+03,   1.8299721e+03,   1.9520206e+03,   2.0812857e+03, &
       2.2181372e+03,   2.3629602e+03,   2.5161565e+03,   2.6781448e+03, &
       2.8493609e+03,   3.0302589e+03,   3.2213112e+03,   3.4230097e+03, &
       3.6358656e+03,   3.8604109e+03,   4.0971982e+03,   4.3468019e+03, &
       4.6098188e+03,   4.8868684e+03,   5.1785938e+03,   5.4856626e+03, &
       5.8087673e+03,   6.1486259e+03,   6.5059830e+03,   6.8816104e+03, &
       7.2763077e+03,   7.6909031e+03,   8.1262545e+03,   8.5832496e+03, &
       9.0628075e+03,   9.5658788e+03,   1.0093447e+04,   1.0646529e+04, &
       1.1226176e+04,   1.1833474e+04,   1.2469546e+04,   1.3135552e+04, &
       1.3832687e+04,   1.4562188e+04,   1.5325331e+04,   1.6123432e+04, &
       1.6957848e+04,   1.7829980e+04,   1.8741270e+04,   1.9693207e+04, 2.0687323e+04,   2.1725199e+04 /
      t1 = t
      if (t.lt.173.16) t1 = 173.16
      if (t.gt.333.16) t1 = 333.16
      it = floor(t1 - 173.16)
      t2 = 173.16 + it
      es = (t2 + 1.0 - t1)*table(it+1) + (t1 - t2)*table(it+2)
      end subroutine establ2

! lookup table for the analytic evaluation of LCL
      subroutine lcltabl(value,tlcl)
!
! Table of values used to compute the temperature of the lifting condensation
! level.  
! 
! the expression that we utilize is log(r/theta**(1/kappa)*pstar*rvgas/rdgas) = 
! log(es/T**(1/kappa))
! 
! Gives the values of the temperature for the following range: 
!   starts with -23, is uniformly distributed up to -10.4.  There are a 
! total of 127 values, and the increment is .1.  
!
      implicit none 
      real, intent(in)     :: value
      real, intent(out)    :: tlcl

      integer              :: ival
      real, dimension(127) :: lcltable
      real                 :: v1, v2

      data lcltable/  1.7364512e+02,   1.7427449e+02,   1.7490874e+02, &
      1.7554791e+02,   1.7619208e+02,   1.7684130e+02,   1.7749563e+02, &
      1.7815514e+02,   1.7881989e+02,   1.7948995e+02,   1.8016539e+02, &
      1.8084626e+02,   1.8153265e+02,   1.8222461e+02,   1.8292223e+02, &
      1.8362557e+02,   1.8433471e+02,   1.8504972e+02,   1.8577068e+02, &
      1.8649767e+02,   1.8723077e+02,   1.8797006e+02,   1.8871561e+02, &
      1.8946752e+02,   1.9022587e+02,   1.9099074e+02,   1.9176222e+02, &
      1.9254042e+02,   1.9332540e+02,   1.9411728e+02,   1.9491614e+02, &
      1.9572209e+02,   1.9653521e+02,   1.9735562e+02,   1.9818341e+02, &
      1.9901870e+02,   1.9986158e+02,   2.0071216e+02,   2.0157057e+02, &
      2.0243690e+02,   2.0331128e+02,   2.0419383e+02,   2.0508466e+02, &
      2.0598391e+02,   2.0689168e+02,   2.0780812e+02,   2.0873335e+02, &
      2.0966751e+02,   2.1061074e+02,   2.1156316e+02,   2.1252493e+02, &
      2.1349619e+02,   2.1447709e+02,   2.1546778e+02,   2.1646842e+02, &
      2.1747916e+02,   2.1850016e+02,   2.1953160e+02,   2.2057364e+02, &
      2.2162645e+02,   2.2269022e+02,   2.2376511e+02,   2.2485133e+02, &
      2.2594905e+02,   2.2705847e+02,   2.2817979e+02,   2.2931322e+02, &
      2.3045895e+02,   2.3161721e+02,   2.3278821e+02,   2.3397218e+02, &
      2.3516935e+02,   2.3637994e+02,   2.3760420e+02,   2.3884238e+02, &
      2.4009473e+02,   2.4136150e+02,   2.4264297e+02,   2.4393941e+02, &
      2.4525110e+02,   2.4657831e+02,   2.4792136e+02,   2.4928053e+02, &
      2.5065615e+02,   2.5204853e+02,   2.5345799e+02,   2.5488487e+02, &
      2.5632953e+02,   2.5779231e+02,   2.5927358e+02,   2.6077372e+02, &
      2.6229310e+02,   2.6383214e+02,   2.6539124e+02,   2.6697081e+02, &
      2.6857130e+02,   2.7019315e+02,   2.7183682e+02,   2.7350278e+02, &
      2.7519152e+02,   2.7690354e+02,   2.7863937e+02,   2.8039954e+02, &
      2.8218459e+02,   2.8399511e+02,   2.8583167e+02,   2.8769489e+02, &
      2.8958539e+02,   2.9150383e+02,   2.9345086e+02,   2.9542719e+02, &
      2.9743353e+02,   2.9947061e+02,   3.0153922e+02,   3.0364014e+02, &
      3.0577420e+02,   3.0794224e+02,   3.1014515e+02,   3.1238386e+02, &
      3.1465930e+02,   3.1697246e+02,   3.1932437e+02,   3.2171609e+02, &
      3.2414873e+02,   3.2662343e+02,   3.2914139e+02,   3.3170385e+02 /

      v1 = value
      if (value.lt.-23.0) v1 = -23.0
      if (value.gt.-10.4) v1 = -10.4
      ival = floor(10.*(v1 + 23.0))
      v2 = -230. + ival
      v1 = 10.*v1
      tlcl = (v2 + 1.0 - v1)*lcltable(ival+1) + (v1 - v2)*lcltable(ival+2)


      end subroutine lcltabl


!#######################################################################


      SUBROUTINE ESTABL(ES,TP)
!
!   TABLE OF ES FROM -100 TO +60 C IN ONE-DEGREE INCREMENTS(ICE).
!
!   RAT GIVES THE RATIO OF ES(ICE)/ES(LIQUID)
!
!  es refers to liquid above 273, ice below 273
!
!

     implicit none
     real, intent(in)  :: TP
     real, intent(out) :: ES

     integer :: it
     real, dimension(161) :: table
     real :: ft, t2, tp1

!      DIMENSION TABLE(161)

      DATA TABLE/.01403,.01719,.02101,.02561,.03117,.03784, &
      .04584,.05542,.06685,.08049,.09672,.1160,.1388,.1658, &
      .1977,.2353,.2796,.3316,.3925,.4638,.5472,.6444,.7577, &
      .8894,1.042,1.22,1.425,1.622,1.936,2.252,2.615,3.032, &
      3.511,4.06,4.688,5.406,6.225,7.159,8.223,9.432,10.80, &
      12.36,14.13,16.12,18.38,20.92,23.80,27.03,30.67,34.76, &
      39.35,44.49,50.26,56.71,63.93,71.98,80.97,90.98,102.1, &
      114.5,128.3,143.6,160.6,179.4,200.2,223.3,248.8,276.9, &
      307.9,342.1,379.8,421.3,466.9,517.0,572.0,632.3,698.5, &
      770.9,850.2,937.0,1032.0,1146.6,1272.0,1408.1,1556.7, &
      1716.9,1890.3,2077.6,2279.6,2496.7,2729.8,2980.,3247.8, &
      3534.1,3839.8,4164.8,4510.5,4867.9,5265.1,5675.2,6107.8, &
      6566.2,7054.7,7575.3,8129.4,8719.2,9346.5,10013.,10722., &
      11474.,12272.,13119.,14017.,14969.,15977.,17044.,18173., &
      19367.,20630.,21964.,23373.,24861.,26430.,28086.,29831., &
      31671.,33608.,35649.,37796.,40055.,42430.,44927.,47551., &
      50307.,53200.,56236.,59422.,62762.,66264.,69934.,73777., &
      77802.,82015.,86423.,91034.,95855.,100890.,106160., &
      111660.,117400.,123400.,129650.,136170.,142980.,150070., &
      157460.,165160.,173180.,181530.,190220.,199260./ 

!      DATA TABLE/.01403,.01719,.02101,.02561,.03117,.03784,
!     A .04584,.05542,.06685,.08049,.09672,.1160,.1388,.1658,
!     B .1977,.2353,.2796,.3316,.3925,.4638,.5472,.6444,.7577,
!     C .8894,1.042,1.22,1.425,1.622,1.936,2.252,2.615,3.032,
!     D 3.511,4.06,4.688,5.406,6.225,7.159,8.223,9.432,10.80,
!     E 12.36,14.13,16.12,18.38,20.92,23.80,27.03,30.67,34.76,
!     F 39.35,44.49,50.26,56.71,63.93,71.98,80.97,90.98,102.1,
!     G 114.5,128.3,143.6,160.6,179.4,200.2,223.3,248.8,276.9,
!     H 307.9,342.1,379.8,421.3,466.9,517.0,572.0,632.3,698.5,
!     I 770.9,850.2,937.0,1032.0,1146.6,1272.0,1408.1,1556.7,
!     J 1716.9,1890.3,2077.6,2279.6,2496.7,2729.8,2980.,3247.8,
!     K 3534.1,3839.8,4164.8,4510.5,4867.9,5265.1,5675.2,6107.8,
!     L 6566.2,7054.7,7575.3,8129.4,8719.2,9346.5,10013.,10722.,
!     M 11474.,12272.,13119.,14017.,14969.,15977.,17044.,18173.,
!     N 19367.,20630.,21964.,23373.,24861.,26430.,28086.,29831.,
!     O 31671.,33608.,35649.,37796.,40055.,42430.,44927.,47551.,
!     P 50307.,53200.,56236.,59422.,62762.,66264.,69934.,73777.,
!     Q 77802.,82015.,86423.,91034.,95855.,100890.,106160.,
!     R 111660.,117400.,123400.,129650.,136170.,142980.,150070.,
!     S 157460.,165160.,173180.,181530.,190220.,199260./
!
      tp1 = tp
      IF (TP1 .LT. 173.16) GO TO 1
      IF (TP1 .LE. 333.16) GO TO 2
      TP1=333.16
      GO TO 2
 1    TP1=173.16
 2    IT= floor(TP1-173.16)
      FT= IT
      T2=173.16+FT
      ES=(T2+1.0-TP1)*TABLE(IT+1)+(TP1-T2)*TABLE(IT+2)
      ES=ES*.1
!
!     CONVERT FROM ES(LIQUID) TO ES(ICE)
!
!      R1=EXP(28.92-(6142./TP1))
!      R2=EXP(26.27-(5421./TP1))
!      RAT=R1/R2
!                        RAT=1.
!     ES=ES*R1/R2
      RETURN
      END subroutine establ

!#######################################################################


      integer function iequ(x,y)
!
!     Checks for equality of two variable, within a tolerance eps.
!
!     On Input:
!
!        x    first variable
!        y    second variable
!
!     On Output:
!
!        equ  flag, equal to zero if x=y within eps
!                   equal to 10 if x greater than y
!                   equal to -10, if x less than y
!

      real, intent(in) :: x, y
      real :: eps, epsm, d

      iequ=0
      eps=1.e-10
      epsm=-eps
      d=x-y
      if (d .gt. eps) iequ=10
      if (d .lt. epsm) iequ=-10
      return
      end function iequ


!#######################################################################

   subroutine bm_omp_init ()

!-----------------------------------------------------------------------
!
!        initialization for bm_omp
!
!-----------------------------------------------------------------------

  integer  unit,io,ierr, logunit

!----------- read namelist ---------------------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=bm_omp_nml, iostat=io)
      ierr = check_nml_error(io,"bm_omp_nml")
#else
      if (file_exist('input.nml')) then
         unit = open_namelist_file ( )
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=bm_omp_nml, iostat=io, end=10)
            ierr = check_nml_error (io,'bm_omp_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist --------------------------------------------

      call write_version_number( version, tagname )
      if ( mpp_pe() == mpp_root_pe() ) then
           logunit = stdlog()
           write (logunit,nml=bm_omp_nml)
      endif
      call close_file (unit)

      module_is_initialized =.true.

   end subroutine bm_omp_init

!#######################################################################

   subroutine bm_omp_end()

      module_is_initialized =.false.

   end subroutine bm_omp_end

!#######################################################################

end module bm_omp_mod




module cg_drag_mod

use mpp_mod,                only:  input_nml_file
use fms_mod,                only:  fms_init, mpp_pe, mpp_root_pe,  &
                                   file_exist, check_nml_error,  &
                                   error_mesg,  FATAL, WARNING, NOTE, &
                                   close_file, open_namelist_file, &
                                   stdlog, write_version_number, &
                                   read_data, write_data,   &
                                   open_restart_file
use fms_io_mod,             only:  register_restart_field, restart_file_type
use fms_io_mod,             only:  save_restart, restore_state, get_mosaic_tile_file
use time_manager_mod,       only:  time_manager_init, time_type
use diag_manager_mod,       only:  diag_manager_init,   &
                                   register_diag_field, send_data
use constants_mod,          only:  constants_init, PI, RDGAS, GRAV, CP_AIR, &
                                   SECONDS_PER_DAY

#ifdef COL_DIAG
use column_diagnostics_mod, only:  column_diagnostics_init, &
                                   initialize_diagnostic_columns, &
                                   column_diagnostics_header, &
                                   close_column_diagnostics_units
#endif

!-------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    cg_drag_mod computes the convective gravity wave forcing on 
!    the zonal flow. the parameterization is described in Alexander and 
!    Dunkerton [JAS, 15 December 1999]. 
!--------------------------------------------------------------------
  

!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------


character(len=128)  :: version =  '$Id: cg_drag.F90,v 17.0.2.1.2.1.4.2.2.1 2010/08/30 20:33:27 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public    cg_drag_init, cg_drag_calc, cg_drag_end, cg_drag_restart, &
          cg_drag_time_vary, cg_drag_endts


private   read_restart_file, read_nc_restart_file, &
          write_restart_file, gwfc

!--- for netcdf restart
type(restart_file_type), pointer, save :: Cg_restart => NULL()
type(restart_file_type), pointer, save :: Til_restart => NULL()
logical                                :: in_different_file = .false.
integer                                :: vers, old_time_step

!wfc++ Addition for regular use
      integer, allocatable, dimension(:,:)     ::  source_level

      real,     allocatable, dimension(:,:)     ::  source_amp
      real,     allocatable, dimension(:,:,:)   ::  gwd_u, gwd_v
!wfc--


!--------------------------------------------------------------------
!---- namelist -----

integer     :: cg_drag_freq=0     ! calculation frequency [ s ]
integer     :: cg_drag_offset=0   ! offset of calculation from 00Z [ s ]
                                  ! only has use if restarts are written
                                  ! at 00Z and calculations are not done
                                  ! every time step

real        :: source_level_pressure= 315.e+02    
                                  ! highest model level with  pressure 
                                  ! greater than this value (or sigma
                                  ! greater than this value normalized
                                  ! by 1013.25 hPa) will be the gravity
                                  ! wave source level at the equator 
                                  ! [ Pa ]
integer     :: nk=1               ! number of wavelengths contained in 
                                  ! the gravity wave spectrum
real        :: cmax=99.6          ! maximum phase speed in gravity wave
                                  ! spectrum [ m/s ]
real        :: dc=1.2             ! gravity wave spectral resolution 
                                  ! [ m/s ]
                                  ! previous values: 0.6
real        :: Bt_0=.003          ! sum across the wave spectrum of 
                                  ! the magnitude of momentum flux, 
                                  ! divided by density [ m^2/s^2 ]
            
real        :: Bt_aug=.000        ! magnitude of momentum flux divided by density 

real        :: Bt_nh=.003         ! magnitude of momentum flux divided by density   (SH limit )

real        :: Bt_sh=.003         ! magnitude of momentum flux divided by density  (SH limit )

real        :: Bt_eq=.000         ! magnitude of momentum flux divided by density  (equator) 

real        :: Bt_eq_width=4.0    ! scaling for width of equtorial momentum flux  (equator) 

real        :: phi0n = 30., phi0s = -30., dphin = 5., dphis = -5.

logical     :: calculate_ked=.false. 
                                  ! calculate ked diagnostic ?
integer     :: num_diag_pts_ij=0  ! number of diagnostic columns specif-
                                  ! ied by global (i,j) coordinates
integer     :: num_diag_pts_latlon=0 
                                  ! number of diagnostic columns
                                  ! specified by lat-lon coordinates
integer, parameter           ::  MAX_PTS= 20
                                  ! maximum number of diagnostic columns
integer, dimension(MAX_PTS)  ::  i_coords_gl=-100     
                                  ! global i coordinates for ij 
                                  ! diagnostic columns 
integer, dimension(MAX_PTS)  ::  j_coords_gl=-100   
                                  ! global j coordinates for ij 
                                  ! diagnostic columns 
real,    dimension(MAX_PTS)  ::  lat_coords_gl=-999. 
                                  ! latitudes for latlon diagnostic 
                                  ! columns  [degrees, -90. -> 90. ]
real,    dimension(MAX_PTS)  ::  lon_coords_gl=-999. 
                                  ! longitudes for latlon diagnostic 
                                  ! columns [ degrees, 0. -> 360. ]


namelist / cg_drag_nml /         &
                          cg_drag_freq, cg_drag_offset, &
                          source_level_pressure,   &
                          nk, cmax, dc, Bt_0, Bt_aug,  &
                          Bt_sh, Bt_nh, Bt_eq,  Bt_eq_width,  &
                          calculate_ked,    &
                          num_diag_pts_ij, num_diag_pts_latlon, &
                          i_coords_gl, j_coords_gl,   &
                          lat_coords_gl, lon_coords_gl, &
                          phi0n,phi0s,dphin,dphis

!--------------------------------------------------------------------
!-------- public data  -----


!--------------------------------------------------------------------
!------ private data ------

!--------------------------------------------------------------------
!   list of restart versions readable by this module.
!--------------------------------------------------------------------
integer, dimension(3)  :: restart_versions = (/ 1, 2, 3 /)
! v1 :
! v2 : 
! v3 : Now use NetCDF for restart file.
!
!--------------------------------------------------------------------
!   these arrays must be preserved across timesteps in case the
!   parameterization is not called every timestep:
!
!   gwd      time tendency for u eqn due to gravity wave forcing 
!            [ m/s^2 ]
!   ked      effective eddy diffusion coefficient resulting from 
!            gravity wave forcing [ m^2/s ]
!
!--------------------------------------------------------------------
!wfc++ not needed if calcucate_ked is removed.
!!!!rjw real,    dimension(:,:,:), allocatable   :: gwd, ked
!wfc--
!--------------------------------------------------------------------
!   these are the arrays which define the gravity wave source spectrum:
!
!   c0       gravity wave phase speeds [ m/s ]
!   kwv      horizontal wavenumbers of gravity waves  [  /m ]
!   k2       squares of wavenumbers [ /(m^2) ]
!
!-------------------------------------------------------------------
real,    dimension(:),     allocatable   :: c0, kwv, k2


!---------------------------------------------------------------------
!   wave spectrum parameters.
!---------------------------------------------------------------------
integer    :: nc        ! number of wave speeds in spectrum
                        ! (symmetric around c = 0)
integer    :: flag = 1  ! flag = 1  for peak flux at  c    = 0
                        ! flag = 0  for peak flux at (c-u) = 0
real       :: Bw = 0.4  ! amplitude for the wide spectrum [ m^2/s^2 ]  
                        ! ~ u'w'
real       :: Bn = 0.0  ! amplitude for the narrow spectrum [ m^2/s^2 ] 
                        ! ~ u'w';  previous values: 5.4
real       :: cw = 40.0 ! half-width for the wide c spectrum [ m/s ]
                        ! previous values: 50.0, 25.0 
real       :: cn =  2.0 ! half-width for the narrow c spectrum  [ m/s ]
integer    :: klevel_of_source
                        ! k index of the gravity wave source level at
                        ! the equator in a standard atmosphere

!---------------------------------------------------------------------
!   variables which control module calculations:
!   
!   cgdrag_alarm time remaining until next cg_drag calculation  [ s ]
!
!---------------------------------------------------------------------
integer          :: cgdrag_alarm

!---------------------------------------------------------------------
!   variables used with column diagnostics:
!
!   diag_units     output unit numbers
!   num_diag_pts   number of columns where diagnostics are desired 
!   column_diagnostics_desired
!                  column diagnostics are desired ?
!   do_column_diagnostics 
!                  a diagnostic column is in this jrow ?  
!   diag_lon       longitude of diagnostic columns [ degrees ]
!   diag_lat       latiude of diagnostic columns  [ degrees ]
!   diag_i         processor-based i index of diagnostic columns
!   diag_j         processor-based j index of diagnostic columns
!
!--------------------------------------------------------------------
integer                            :: num_diag_pts = 0  
logical                            :: column_diagnostics_desired=.false.
integer, dimension(:), allocatable :: diag_units         
logical, dimension(:), allocatable :: do_column_diagnostics
real,    dimension(:), allocatable :: diag_lon, diag_lat
integer, dimension(:), allocatable :: diag_j, diag_i   

!---------------------------------------------------------------------
!   variables for netcdf diagnostic fields.
!---------------------------------------------------------------------
integer          :: id_kedx_cgwd, id_kedy_cgwd, id_bf_cgwd, &
                    id_gwfx_cgwd, id_gwfy_cgwd
real             :: missing_value = -999.
character(len=7) :: mod_name = 'cg_drag'


logical          :: module_is_initialized=.false.

!-------------------------------------------------------------------
!-------------------------------------------------------------------



                        contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                      PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!####################################################################

subroutine cg_drag_init (lonb, latb, pref, Time, axes)

!-------------------------------------------------------------------
!   cg_drag_init is the constructor for cg_drag_mod.
!-------------------------------------------------------------------

!-------------------------------------------------------------------
real,    dimension(:,:), intent(in)      :: lonb, latb
real,    dimension(:),   intent(in)      :: pref
integer, dimension(4),   intent(in)      :: axes
type(time_type),         intent(in)      :: Time
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!   intent(in) variables:
!
!       lonb      2d array of model longitudes on cell corners [radians]
!       latb      2d array of model latitudes at cell corners [radians]
!       pref      array of reference pressures at full levels (plus
!                 surface value at nlev+1), based on 1013.25hPa pstar
!                 [ Pa ]
!       Time      current time (time_type)
!       axes      data axes for diagnostics
!
!------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables: 

      integer                 :: unit, ierr, io, logunit
      integer                 :: n, i, j, k
      integer                 :: idf, jdf, kmax
      real                    :: pif = 3.14159265358979/180.
!      real                    :: pif = PI/180.

!      real, allocatable       :: lat(:,:)
      real                    :: lat(size(lonb,1) - 1, size(latb,2) - 1)
!-------------------------------------------------------------------
!   local variables: 
!   
!       unit           unit number for nml file 
!       ierr           error return flag 
!       io             error return code 
!       n              loop index
!       k              loop index
!       idf            number of i points on this processor
!       jdf            number of j points on this processor
!       kmax           number of k points on this processor
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, return.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that all modules used by this module have been initialized.
!---------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call diag_manager_init
      call constants_init
#ifdef COL_DIAG
      call column_diagnostics_init 
#endif SKIP
!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cg_drag_nml, iostat=io)
      ierr = check_nml_error(io,"cg_drag_nml")
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read (unit, nml=cg_drag_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'cg_drag_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe()) write (logunit, nml=cg_drag_nml)

!-------------------------------------------------------------------
!  define the grid dimensions. idf and jdf are the (i,j) dimensions of 
!  domain on this processor, kmax is the number of model layers.
!-------------------------------------------------------------------
      kmax = size(pref(:)) - 1
      jdf  = size(latb,2) - 1
      idf  = size(lonb,1) - 1

      allocate(  source_level(idf,jdf)  )
      allocate(  source_amp(idf,jdf)  )
!      allocate(  lat(idf,jdf)  )

!--------------------------------------------------------------------
!    define the k level which will serve as source level for the grav-
!    ity waves. it is that model level just below the pressure specif-
!    ied as the source location via namelist input.
!--------------------------------------------------------------------
      do k=1,kmax
        if (pref(k) > source_level_pressure) then
          klevel_of_source = k
          exit
        endif
      end do

      do j=1,jdf
        lat(:,j)=  0.5*( latb(:,j+1)+latb(:,j) )
        do i=1,idf
          source_level(i,j) = (kmax + 1) - ((kmax + 1 -    &
                              klevel_of_source)*cos(lat(i,j)) + 0.5)
          source_amp(i,j) = Bt_0 +                         &
                      Bt_nh*0.5*(1.+tanh((lat(i,j)/pif-phi0n)/dphin)) + &
                      Bt_sh*0.5*(1.+tanh((lat(i,j)/pif-phi0s)/dphis))
        end do
      end do
      source_level = MIN (source_level, kmax-1)

!      deallocate( lat )

!---------------------------------------------------------------------
!    determine if column diagnostics are desired from this module. if
!    so, set a flag to so indicate.
!---------------------------------------------------------------------
      num_diag_pts = num_diag_pts_ij + num_diag_pts_latlon
      if (num_diag_pts > 0) then
        column_diagnostics_desired = .true.
      endif

!---------------------------------------------------------------------
!    if column diagnostics are desired, check that array dimensions are
!    sufficiently large for the number of requests. 
!---------------------------------------------------------------------
#ifdef COL_DIAG
      if (column_diagnostics_desired) then
        if (num_diag_pts > MAX_PTS) then
          call error_mesg ( 'cg_drag_mod', &
         ' must reset MAX_PTS or reduce number of diagnostic points', &
                                                     FATAL)
        endif

!---------------------------------------------------------------------
!    allocate arrays needed for column diagnostics. 
!---------------------------------------------------------------------
        allocate (do_column_diagnostics   (jdf)          )
        allocate (diag_units              (num_diag_pts) )
        allocate (diag_lon                (num_diag_pts) )
        allocate (diag_lat                (num_diag_pts) )
        allocate (diag_i                  (num_diag_pts) )
        allocate (diag_j                  (num_diag_pts) )

!---------------------------------------------------------------------
!    call initialize_diagnostic_columns to determine the locations 
!    (i, j, lat and lon) of any diagnostic columns in this processsor's 
!    space and to open output files for the diagnostics.
!---------------------------------------------------------------------
        call initialize_diagnostic_columns    &
                     (mod_name, num_diag_pts_latlon, num_diag_pts_ij, &
                      i_coords_gl, j_coords_gl, lat_coords_gl,   &
                      lon_coords_gl, lonb(:,1), latb(1,:), do_column_diagnostics, &
                      diag_lon, diag_lat, diag_i, diag_j, diag_units)
      endif
#endif

!---------------------------------------------------------------------
!    define the number of waves in the gravity wave spectrum, and define
!    an array of their speeds. They are defined symmetrically around
!    c = 0.0 m/s.
!---------------------------------------------------------------------
      nc = 2.0*cmax/dc + 1
      allocate ( c0(nc) )
      do n=1,nc
        c0(n) = (n-1)*dc - cmax
      end do
 
!--------------------------------------------------------------------
!    define the wavenumber kwv and its square k2 for the gravity waves 
!    contained in the spectrum. currently nk = 1, which means that the 
!    wavelength of all gravity waves considered is 300 km. 
!--------------------------------------------------------------------
      allocate ( kwv(nk) )
      allocate ( k2 (nk) )
      do n=1,nk
        kwv(n) = 2.*PI/((30.*(10.**n))*1.e3)
        k2(n) = kwv(n)*kwv(n)
      end do

!--------------------------------------------------------------------
!    initialize netcdf diagnostic fields.
!-------------------------------------------------------------------
      id_bf_cgwd =  &
         register_diag_field (mod_name, 'bf_cgwd', axes(1:3), Time, &
              'buoyancy frequency from cg_drag', ' /s',   &
              missing_value=missing_value)
      id_gwfx_cgwd =  &
         register_diag_field (mod_name, 'gwfx_cgwd', axes(1:3), Time, &
              'gravity wave forcing on mean flow', &
              'm/s^2',  missing_value=missing_value)
      id_gwfy_cgwd =  &
         register_diag_field (mod_name, 'gwfy_cgwd', axes(1:3), Time, &
              'gravity wave forcing on mean flow', &
              'm/s^2',  missing_value=missing_value)
      id_kedx_cgwd =  &
         register_diag_field (mod_name, 'kedx_cgwd', axes(1:3), Time, &
               'effective eddy viscosity from cg_drag', 'm^2/s',   &
               missing_value=missing_value)
      id_kedy_cgwd =  &
         register_diag_field (mod_name, 'kedy_cgwd', axes(1:3), Time, &
               'effective eddy viscosity from cg_drag', 'm^2/s',   &
               missing_value=missing_value)

!--------------------------------------------------------------------
!    allocate and define module variables to hold values across 
!    timesteps, in the event that cg_drag is not called on every step.
!--------------------------------------------------------------------
     allocate ( gwd_u(idf,jdf,kmax) )
     allocate ( gwd_v(idf,jdf,kmax) )

!--------------------------------------------------------------------
!    if present, read the restart data file.
!---------------------------------------------------------------------
      if (size(restart_versions(:)) .gt. 2 ) then
        call cg_drag_register_restart
      endif

      if (file_exist('INPUT/cg_drag.res.nc')) then
        call read_nc_restart_file

      elseif (file_exist('INPUT/cg_drag.res')) then
        call read_restart_file
!-------------------------------------------------------------------
!    if no restart file is present, initialize the gwd field to zero.
!    define the time remaining until the next cg_drag calculation from
!    the namelist inputs.
!-------------------------------------------------------------------
      else
        gwd_u(:,:,:) = 0.0
        gwd_v(:,:,:) = 0.0
        if (cg_drag_offset > 0) then
          cgdrag_alarm = cg_drag_offset
        else 
          cgdrag_alarm = cg_drag_freq
        endif
      endif
      vers = restart_versions(size(restart_versions(:)))
      old_time_step = cgdrag_alarm 
!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------



end subroutine cg_drag_init


!####################################################################
 
subroutine cg_drag_time_vary (delt)

real           ,        intent(in)      :: delt

!---------------------------------------------------------------------
!    decrement the time remaining until the next cg_drag calculation.
!---------------------------------------------------------------------
      cgdrag_alarm = cgdrag_alarm - delt

!---------------------------------------------------------------------
 
end subroutine cg_drag_time_vary


!####################################################################
 
subroutine cg_drag_endts
 
!--------------------------------------------------------------------
!    if this was a calculation step, reset cgdrag_alarm to indicate 
!    the time remaining before the next calculation of gravity wave 
!    forcing.
!--------------------------------------------------------------------
      if (cgdrag_alarm <= 0 ) then
        cgdrag_alarm = cgdrag_alarm + cg_drag_freq
      endif

end subroutine cg_drag_endts


!####################################################################

subroutine cg_drag_calc (is, js, lat, pfull, zfull, temp, uuu, vvv,  &
                         Time, delt, gwfcng_x, gwfcng_y)
!--------------------------------------------------------------------  
!    cg_drag_calc defines the arrays needed to calculate the convective
!    gravity wave forcing, calls gwfc to calculate the forcing, returns 
!    the desired output fields, and saves the values for later retrieval
!    if they are not calculated on every timestep.
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
integer,                intent(in)      :: is, js
real, dimension(:,:),   intent(in)      :: lat
real, dimension(:,:,:), intent(in)      :: pfull, zfull, temp, uuu, vvv
type(time_type),        intent(in)      :: Time
real           ,        intent(in)      :: delt
real, dimension(:,:,:), intent(out)     :: gwfcng_x, gwfcng_y

!-------------------------------------------------------------------
!    intent(in) variables:
!
!       is,js    starting subdomain i,j indices of data in 
!                the physics_window being integrated
!       lat      array of model latitudes at cell boundaries [radians]
!       pfull    pressure at model full levels [ Pa ]
!       zfull    height at model full levels [ m ]
!       temp     temperature at model levels [ deg K ]
!       uuu      zonal wind  [ m/s ]
!       vvv      meridional wind  [ m/s ]
!       Time     current time, needed for diagnostics [ time_type ]
!       delt     physics time step [ s ]
!
!    intent(out) variables:
!
!       gwfcng_x time tendency for u eqn due to gravity-wave forcing
!                [ m/s^2 ]
!       gwfcng_y time tendency for v eqn due to gravity-wave forcing
!                [ m/s^2 ]
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!    local variables:

      real,    dimension (size(uuu,1), size(uuu,2), size(uuu,3))  ::  &
                                         dtdz, ked_gwfc_x, ked_gwfc_y

      real,    dimension (size(uuu,1),size(uuu,2), 0:size(uuu,3)) ::  &
                                         zzchm, zu, zv, zden, zbf,    &
                                         gwd_xtnd, ked_xtnd, &
                                         gwd_ytnd, ked_ytnd

      integer           :: iz0
      logical           :: used
      real              :: bflim = 2.5E-5
      integer           :: ie, je
      integer           :: imax, jmax, kmax
      integer           :: i, j, k

!-------------------------------------------------------------------
!    local variables:
!
!       dtdz          temperature lapse rate [ deg K/m ]
!       ked_gwfc      effective diffusion coefficient from cg_drag_mod 
!                     [ m^2/s ]
!       zzchm         heights at model levels [ m ]
!       zu            zonal velocity [ m/s ]
!       zden          atmospheric density [ kg/m^3 ]
!       zbf           buoyancy frequency [ /s ]
!       gwd_xtnd      zonal wind tendency resulting from cg_drag_mod 
!                     [ m/s^2 ]
!       ked_xtnd      effective diffusion coefficient from cg_drag_mod 
!                     [ m^2/s ]
!       source_level  k index of gravity wave source level ((i,j) array)
!       iz0           k index of gravity wave source level in a column
!       used          return code for netcdf diagnostics
!       bflim         minimum allowable value of squared buoyancy 
!                     frequency [ /s^2 ]
!       ie, je        ending subdomain indices of data in the current 
!                     physics window being integrated
!       imax, jmax, kmax 
!                     physics window dimensions
!       i, j, k, nn   do loop indices
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    define processor extents and loop limits.
!---------------------------------------------------------------------
      imax = size(uuu,1)
      jmax = size(uuu,2)
      kmax = size(uuu,3)
      ie = is + imax - 1
      je = js + jmax - 1

!---------------------------------------------------------------------
!    if the convective gravity wave forcing should be calculated on 
!    this timestep (i.e., the alarm has gone off), proceed with the
!    calculation.
!---------------------------------------------------------------------


      if (cgdrag_alarm <= 0) then

!-----------------------------------------------------------------------
!    calculate temperature lapse rate. do one-sided differences over 
!    delta z at upper boundary and centered differences over 2 delta z 
!    in the interior.  dtdz is not needed at the lower boundary, since
!    the source level is constrained to be above level kmax.
!----------------------------------------------------------------------
        do j=1,jmax
          do i=1,imax
! The following index-offsets are needed in case a physics_window is being used.
            iz0 = source_level(i +is-1,j+js-1)
            dtdz(i,j,1) = (temp  (i,j,1) - temp  (i,j,2))/    &
                          (zfull(i,j,1) - zfull(i,j,2))
            do k=2,iz0
              dtdz(i,j,k) = (temp  (i,j,k-1) - temp  (i,j,k+1))/   &
                            (zfull(i,j,k-1) - zfull(i,j,k+1))
            end do

!--------------------------------------------------------------------
!    calculate air density.
!--------------------------------------------------------------------
            do k=1,iz0+1
              zden(i,j,k  ) = pfull(i,j,k)/(temp(i,j,k)*RDGAS)
            end do

!----------------------------------------------------------------------
!    calculate buoyancy frequency. restrict the squared buoyancy 
!    frequency to be no smaller than bflim.
!----------------------------------------------------------------------
            do k=1,iz0 
              zbf(i,j,k) = (GRAV/temp(i,j,k))*(dtdz(i,j,k) + GRAV/CP_AIR)
              if (zbf(i,j,k) < bflim) then
                zbf(i,j,k) = sqrt(bflim)
              else 
                zbf(i,j,k) = sqrt(zbf(i,j,k))
              endif
            end do

!----------------------------------------------------------------------
!    if zbf is to be saved for netcdf output, the remaining vertical
!    levels must be initialized.
!----------------------------------------------------------------------
            if (id_bf_cgwd > 0) then
              zbf(i,j,iz0+1:) = 0.0
            endif

!----------------------------------------------------------------------
!    define an array of heights at model levels and an array containing
!    the zonal wind component.
!----------------------------------------------------------------------
            do k=1,iz0+1
              zzchm(i,j,k) = zfull(i,j,k)
            end do
            do k=1,iz0   
              zu(i,j,k) = uuu(i,j,k)
              zv(i,j,k) = vvv(i,j,k)
            end do

!----------------------------------------------------------------------
!    add an extra level above model top so that the gravity wave forcing
!    occurring between the topmost model level and the upper boundary
!    may be calculated. define variable values at the new top level as
!    follows: z - use delta z of layer just below; u - extend vertical 
!    gradient occurring just below; density - geometric mean; buoyancy 
!    frequency - constant across model top.
!----------------------------------------------------------------------
            zzchm(i,j,0) = zzchm(i,j,1) + zzchm(i,j,1) - zzchm(i,j,2)
            zu(i,j,0)    = 2.*zu(i,j,1) - zu(i,j,2)
            zv(i,j,0)    = 2.*zv(i,j,1) - zv(i,j,2)
            zden(i,j,0)  = zden(i,j,1)*zden(i,j,1)/zden(i,j,2)
            zbf(i,j,0)   = zbf(i,j,1)
          end do
        end do
      
!---------------------------------------------------------------------
!    pass the vertically-extended input arrays to gwfc. gwfc will cal-
!    culate the gravity-wave forcing and, if desired, an effective eddy 
!    diffusion coefficient at each level above the source level. output
!    is returned in the vertically-extended arrays gwfcng and ked_gwfc.
!    upon return move the output fields into model-sized arrays. 
!---------------------------------------------------------------------
       call gwfc (is, ie, js, je, source_level, source_amp,    &
                     zden, zu, zbf,zzchm, gwd_xtnd, ked_xtnd)

         gwfcng_x  (:,:,1:kmax) = gwd_xtnd(:,:,1:kmax  )
          ked_gwfc_x(:,:,1:kmax) = ked_xtnd(:,:,1:kmax  )

       call gwfc (is, ie, js, je, source_level, source_amp,    &
                     zden, zv, zbf,zzchm, gwd_ytnd, ked_ytnd)
          gwfcng_y  (:,:,1:kmax) = gwd_ytnd(:,:,1:kmax  )
          ked_gwfc_y(:,:,1:kmax) = ked_ytnd(:,:,1:kmax  )

!--------------------------------------------------------------------
!    store the gravity wave forcing into a processor-global array.
!-------------------------------------------------------------------
          gwd_u(is:ie,js:je,:) = gwfcng_x(:,:,:)
          gwd_v(is:ie,js:je,:) = gwfcng_y(:,:,:)


#ifdef COL_DIAG
!--------------------------------------------------------------------
!  if column diagnostics are desired, determine if any columns are on
!  this processor. if so, call column_diagnostics_header to write
!  out location and timestamp information. then output desired 
!  quantities to the diag_unit file.
!---------------------------------------------------------------------
        if (column_diagnostics_desired) then
          do j=1,jmax
            if (do_column_diagnostics(j+js-1)) then
              do nn=1,num_diag_pts
                if (js + j - 1 == diag_j(nn)) then
                  call column_diagnostics_header   &
                       (mod_name, diag_units(nn), Time, nn, diag_lon, &
                        diag_lat, diag_i, diag_j) 
                  iz0 = source_level (diag_i(nn), j)
                  write (diag_units(nn),'(a, i5)')    &
                                              '  source_level  =', iz0
                  write (diag_units(nn),'(a)')     &
                         '   k         u           z        density&
                         &         bf      gwforcing'
                  do k=0,iz0 
                    write (diag_units(nn), '(i5, 2x, 5e12.5)')   &
                                       k,                         &
                                       zu       (diag_i(nn),j,k), &
                                       zzchm    (diag_i(nn),j,k), &
                                       zden     (diag_i(nn),j,k), &
                                       zbf      (diag_i(nn),j,k), &
                                       gwd_xtnd (diag_i(nn),j,k) 
                  end do
                  write (diag_units(nn), '(i5, 14x, 2e12.5)')     &
                                       iz0+1,                       &
                                       zzchm  (diag_i(nn),j,iz0+1), &
                                       zden   (diag_i(nn),j,iz0+1)
                endif
              end do  ! (nn loop)
            endif    ! (do_column_diagnostics)
          end do   ! (j loop)
        endif    ! (column_diagnostics_desired)
#endif


!--------------------------------------------------------------------
!    if activated, store the effective eddy diffusivity into a 
!    processor-global array, and if desired as a netcdf diagnostic, 
!    send the data to diag_manager_mod.
!-------------------------------------------------------------------

          if (id_kedx_cgwd > 0) then
            used = send_data (id_kedx_cgwd, ked_gwfc_x, Time, is, js, 1)
          endif

          if (id_kedy_cgwd > 0) then
            used = send_data (id_kedy_cgwd, ked_gwfc_y, Time, is, js, 1)
          endif



!--------------------------------------------------------------------
!    save any other netcdf file diagnostics that are desired.
!--------------------------------------------------------------------
        if (id_bf_cgwd > 0) then
          used = send_data (id_bf_cgwd,  zbf(:,:,1:), Time, is, js )
        endif

        if (id_gwfx_cgwd > 0) then
          used = send_data (id_gwfx_cgwd, gwfcng_x, Time, is, js, 1)
        endif
        if (id_gwfy_cgwd > 0) then
          used = send_data (id_gwfy_cgwd, gwfcng_y, Time, is, js, 1)
        endif



!--------------------------------------------------------------------
!    if this is not a timestep on which gravity wave forcing is to be 
!    calculated, retrieve the values calculated previously from storage
!    and return to the calling subroutine.
!--------------------------------------------------------------------
      else   ! (cgdrag_alarm <= 0)
        gwfcng_x(:,:,:) = gwd_u(is:ie,js:je,:)
        gwfcng_y(:,:,:) = gwd_v(is:ie,js:je,:)
     endif  ! (cgdrag_alarm <= 0)

!--------------------------------------------------------------------



end subroutine cg_drag_calc



!###################################################################

subroutine cg_drag_end

!--------------------------------------------------------------------
!    cg_drag_end is the destructor for cg_drag_mod.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    local variables

!For version 3 and after, use NetCDF restarts.
      if (mpp_pe() == mpp_root_pe() ) &
            call error_mesg ('cg_drag_mod', 'write_restart_nc: &
              &Writing netCDF formatted restart file as &
                &requested. ', NOTE)
      call cg_drag_restart


#ifdef COL_DIAG
      if (column_diagnostics_desired) then
        call close_column_diagnostics_units (diag_units)
      endif
#endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------


end subroutine cg_drag_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


subroutine  write_restart_file

integer :: unit     ! unit for writing restart file

!-------------------------------------------------------------------
!    open unit for restart file.
!-------------------------------------------------------------------
      unit = open_restart_file ('RESTART/cg_drag.res', 'write')

!-------------------------------------------------------------------
!    the root pe writes out the restart version, the time remaining 
!    before the next call to cg_drag_mod and the current cg_drag 
!    timestep.
!-------------------------------------------------------------------
      if (mpp_pe() == mpp_root_pe() ) then
        write (unit) restart_versions(size(restart_versions(:)))
        write (unit) cgdrag_alarm, cg_drag_freq
      endif

!-------------------------------------------------------------------
!    each processor writes out its gravity wave forcing tendency 
!    on the zonal flow.
!-------------------------------------------------------------------
      call write_data (unit, gwd_u)

!---------  ----------------------------------------------------------
!    close restart file unit. if column diagnostics have been generated,
!    close the units to which they were written.
!---------------------------------------------------------------------
      call close_file (unit)

end subroutine write_restart_file


!#####################################################################

subroutine read_restart_file

!-------------------------------------------------------------------
!   read_restart_file reads the cg_drag_mod restart file.
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables

      integer                 :: unit
      character(len=8)        :: chvers
      integer, dimension(5)   :: dummy
      real                    :: secs_per_day = SECONDS_PER_DAY

!-------------------------------------------------------------------
!   local variables: 
!   
!       unit           unit number for nml file 
!       chvers         character representation of restart version 
!       vers           restart version 
!       dummy          array to hold restart version 1 control variables
!       old_time_step  cg_drag timestep used in previous model run [ s ]
!       secs_per_day   seconds in a day [ s ]
!
!---------------------------------------------------------------------


!--------------------------------------------------------------------
!    open file to read restart data. 
!---------------------------------------------------------------------
      unit = open_restart_file ('INPUT/cg_drag.res','read')

!--------------------------------------------------------------------
!    read and check restart version number.
!---------------------------------------------------------------------
      read (unit) vers
      if (.not. any(vers == restart_versions) ) then
        write (chvers, '(i4)') vers
        call error_mesg ('cg_drag_init', &
               'restart version '//chvers//' cannot be read &
               &by this module version', FATAL)
      endif

!--------------------------------------------------------------------
!    read control information from restart file. 
!--------------------------------------------------------------------
      if (vers == 1) then

!--------------------------------------------------------------------
!    if reading restart version 1, use the contents of array dummy to
!    define the cg_drag timestep that was used in the run which wrote 
!    the restart. define the time remaining before the next cg_drag 
!    calculation to either be the previous timestep or the current
!    offset, if that is specified. this assumes that the restart was
!    written at 00Z.
!--------------------------------------------------------------------
        read (unit) dummy           
        old_time_step = secs_per_day*dummy(4) + dummy(3)
        if (cg_drag_offset == 0) then
          cgdrag_alarm =  old_time_step
        else
          cgdrag_alarm = cg_drag_offset 
        endif
      else 

!--------------------------------------------------------------------
!    for restart version 2, read the time remaining until the next 
!    cg_drag calculation, and the previously used timestep.
!---------------------------------------------------------------------
        read (unit) cgdrag_alarm, old_time_step
      endif

!-------------------------------------------------------------------
!    read  restart data (gravity wave forcing tendency terms) and close 
!    unit.
!-------------------------------------------------------------------
      call read_data (unit, gwd_u)
      gwd_v(:,:,:) = 0.0
      call close_file (unit)

!--------------------------------------------------------------------
!    if current cg_drag calling frequency differs from that previously 
!    used, adjust the time remaining before the next calculation. 
!--------------------------------------------------------------------
      if (cg_drag_freq /= old_time_step) then
        cgdrag_alarm = cgdrag_alarm - old_time_step + cg_drag_freq
        if (mpp_pe() == mpp_root_pe() ) then
          call error_mesg ('cg_drag_mod',   &
                'cgdrag time step has changed, &
                &next cgdrag time also changed', NOTE)
        endif
      endif

!--------------------------------------------------------------------
!    if cg_drag_offset is specified and is smaller than the time remain-
!    ing until the next calculation, modify the time remaining to be 
!    that offset time. the assumption is made that the restart was
!    written at 00Z.
!--------------------------------------------------------------------
      if (cg_drag_offset /= 0) then
        if (cgdrag_alarm > cg_drag_offset) then
          cgdrag_alarm = cg_drag_offset
        endif
      endif

!---------------------------------------------------------------------


end subroutine read_restart_file


subroutine read_nc_restart_file
!-----------------------------------------------------------------------
!    subroutine read_restart_nc reads a netcdf restart file to obtain 
!    the variables needed upon experiment restart. 
!-----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      character(len=64)     :: fname='INPUT/cg_drag.res.nc'
      character(len=8)      :: chvers

!---------------------------------------------------------------------
!   local variables:
!
!        fname            restart file name
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!    output a message indicating entrance into this routine.
!--------------------------------------------------------------------
      if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('cg_drag_mod',  'read_restart_nc:&
             &Reading netCDF formatted restart file:'//trim(fname), NOTE)
      endif

!-------------------------------------------------------------------
!    read the values of gwd_u and gwd_v
!-------------------------------------------------------------------
      if (size(restart_versions(:)) .le. 2 ) then
         call error_mesg ('cg_drag_mod',  'read_restart_nc: restart file format is netcdf, ' // &
              'restart_versions is not netcdf file version', FATAL)
      endif
      call restore_state(Cg_restart)
      if(in_different_file) call restore_state(Til_restart)
      if (.not. any(vers == restart_versions) ) then
        write (chvers, '(i4)') vers
        call error_mesg ('cg_drag_init', &
               'restart version '//chvers//' cannot be read &
               &by this module version', FATAL)
      endif
      vers = restart_versions(size(restart_versions(:)))

!--------------------------------------------------------------------
!    if current cg_drag calling frequency differs from that previously 
!    used, adjust the time remaining before the next calculation. 
!--------------------------------------------------------------------
      if (cg_drag_freq /= old_time_step) then
        cgdrag_alarm = cgdrag_alarm - old_time_step + cg_drag_freq
        if (mpp_pe() == mpp_root_pe() ) then
          call error_mesg ('cg_drag_mod',   &
                'cgdrag time step has changed, &
                &next cgdrag time also changed', NOTE)
        endif
        old_time_step = cg_drag_freq
      endif

!--------------------------------------------------------------------
!    if cg_drag_offset is specified and is smaller than the time remain-
!    ing until the next calculation, modify the time remaining to be 
!    that offset time. the assumption is made that the restart was
!    written at 00Z.
!--------------------------------------------------------------------
      if (cg_drag_offset /= 0) then
        if (cgdrag_alarm > cg_drag_offset) then
          cgdrag_alarm = cg_drag_offset
        endif
      endif

!---------------------------------------------------------------------
end subroutine read_nc_restart_file

!####################################################################
! register restart field to be read and written through save_restart and restore_state.
subroutine cg_drag_register_restart

  character(len=64) :: fname = 'cg_drag.res.nc'    ! name of restart file
  character(len=64) :: fname2 
  integer           :: id_restart

  call get_mosaic_tile_file(fname, fname2, .false. ) 
  allocate(Cg_restart)
  if(trim(fname2) == trim(fname)) then
     Til_restart => Cg_restart
     in_different_file = .false.
  else
     in_different_file = .true.
     allocate(Til_restart)
  endif

  id_restart = register_restart_field(Cg_restart, fname, 'restart_version', vers, no_domain = .true. )
  id_restart = register_restart_field(Cg_restart, fname, 'cgdrag_alarm', cgdrag_alarm, no_domain = .true. )
  id_restart = register_restart_field(Cg_restart, fname, 'cg_drag_freq', old_time_step, no_domain = .true. )
  id_restart = register_restart_field(Til_restart, fname, 'gwd_u', gwd_u)
  id_restart = register_restart_field(Til_restart, fname, 'gwd_v', gwd_v)

  return

end subroutine cg_drag_register_restart

!####################################################################
! <SUBROUTINE NAME="cg_drag_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine cg_drag_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

  call save_restart(Cg_restart, timestamp)
  if(in_different_file) call save_restart(Til_restart, timestamp)

end subroutine cg_drag_restart
! </SUBROUTINE> NAME=cg_drag_restart"


!####################################################################

subroutine gwfc (is, ie, js, je, source_level, source_amp, rho, u,    &
                 bf, z, gwf, ked)

!-------------------------------------------------------------------
!    subroutine gwfc computes the gravity wave-driven-forcing on the
!    zonal wind given vertical profiles of wind, density, and buoyancy 
!    frequency. 
!    Based on version implemented in SKYHI -- 27 Oct 1998 by M.J. 
!    Alexander and L. Bruhwiler.
!-------------------------------------------------------------------

!-------------------------------------------------------------------
integer,                     intent(in)             :: is, ie, js, je
integer, dimension(:,:),     intent(in)             :: source_level
real,    dimension(:,:),     intent(in)             :: source_amp
real,    dimension(:,:,0:),  intent(in)             :: rho, u, bf, z
real,    dimension(:,:,0:),  intent(out)            :: gwf
real,    dimension(:,:,0:),  intent(out)            :: ked

!-------------------------------------------------------------------
!  intent(in) variables:
!
!      is, ie, js, je   starting/ending subdomain i,j indices of data
!                       in the physics_window being integrated
!      source_level     k index of model level serving as gravity wave
!                       source
!      source_amp     amplitude of  gravity wave source
!                       
!      rho              atmospheric density [ kg/m^3 ] 
!      u                zonal wind component [ m/s ]
!      bf               buoyancy frequency [ /s ]
!      z                height of model levels  [ m ]
!
!  intent(out) variables:
!
!      gwf              gravity wave forcing in u equation  [ m/s^2 ]
!
!  intent(out), optional variables:
!
!      ked              eddy diffusion coefficient from gravity wave 
!                       forcing [ m^2/s ]
!
!------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables

      real,    dimension (0:size(u,3)-1 ) ::       &
                                   wv_frcng, diff_coeff, c0mu, dz,    &
                                   fac, omc
      integer, dimension (nc) ::   msk
      real   , dimension (nc) ::   c0mu0, B0
      real                    ::   fm, fe, Hb, alp2, Foc, c, test, rbh,&
                                   eps, Bsum
      integer                 ::   iz0 
      integer                 ::   i, j, k, ink, n
      real                    ::   ampl
!------------------------------------------------------------------
!  local variables:
! 
!      wv_frcng    gravity wave forcing tendency [ m/s^2 ]
!      diff_coeff  eddy diffusion coefficient [ m2/s ]
!      c0mu        difference between phase speed of wave n and u 
!                  [ m/s ]
!      dz          delta z between model levels [ m ]
!      fac         factor used in determining if wave is breaking 
!                  [ s/m ]
!      omc         critical frequency that marks total internal 
!                  reflection  [ /s ]
!      msk         indicator as to whether wave n is still propagating 
!                  upwards (msk=1), or has been removed from the 
!                  spectrum because of breaking or reflection (msk=0)
!      c0mu0       difference between phase speed of wave n and u at the
!                  source level [ m/s ]
!      B0          wave momentum flux amplitude for wave n [ (m/s)^2 ]
!      fm          used to sum up momentum flux from all waves n 
!                  deposited at a level [ (m/s)^2 ]
!      fe          used to sum up contributions to diffusion coefficient
!                  from all waves n at a level [ (m/s)^3 ]
!      Hb          density scale height [ m ]
!      alp2        scale height factor: 1/(2*Hb)**2  [ /m^2 ]
!      Foc         wave breaking threshold [ s/m ]
!      c           wave phase speed used in defining wave momentum flux
!                  amplitude [ m/s ]
!      test        condition defining internal reflection [ /s ]
!      rbh         atmospheric density at half-level (geometric mean)
!                  [ kg/m^3 ]
!      eps         intermittency factor
!      Bsum        total mag of gravity wave momentum flux at source 
!                  level, divided by the density  [ m^2/s^2 ]
!      iz0         source level vertical index for the given column
!      i,j,k       spatial do loop indices
!      ink         wavenumber loop index 
!      n           phase speed loop index 
!      ampl        phase speed loop index 
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    initialize the output arrays. these will hold values at each 
!    (i,j,k) point, summed over the wavelengths and phase speeds
!    defining the gravity wave spectrum.
!-------------------------------------------------------------------
      gwf = 0.0
      ked = 0.0

      do j=1,size(u,2)
        do i=1,size(u,1)  
! The following index-offsets are needed in case a physics_window is being used.
          iz0 = source_level(i+is-1,j+js-1)
          ampl= source_amp(i+is-1,j+js-1)

!--------------------------------------------------------------------
!    define wave momentum flux (B0) at source level for each phase 
!    speed n, and the sum over all phase speeds (Bsum), which is needed 
!    to calculate the intermittency. 
!-------------------------------------------------------------------
          Bsum = 0.
          do n=1,nc
            c0mu0(n) = c0(n) - u(i,j,iz0)   

!---------------------------------------------------------------------
!    when the wave phase speed is same as wind speed, there is no
!    momentum flux.
!---------------------------------------------------------------------
            if (c0mu0(n) == 0.0)  then
              B0(n) = 0.0
            else 

!---------------------------------------------------------------------
!    define wave momentum flux at source level for phase speed n. Add
!    the contribution from this phase speed to the previous sum.
!---------------------------------------------------------------------
              c = c0(n)*flag + c0mu0(n)*(1 - flag)
              if (c0mu0(n) < 0.0) then
                B0(n) = -1.0*(Bw*exp(-alog(2.0)*(c/cw)**2) +    &
                              Bn*exp(-alog(2.0)*(c/cn)**2))
              else 
                B0(n) = (Bw*exp(-alog(2.0)*(c/cw)**2)  +  &
                         Bn*exp(-alog(2.0)*(c/cn)**2))
              endif
              Bsum = Bsum + abs(B0(n))
            endif
          end do

!---------------------------------------------------------------------
!    define the intermittency factor eps. the factor of 1.5 is currently
!    unexplained.
!---------------------------------------------------------------------
          if (Bsum == 0.0) then
            call error_mesg ('cg_drag_mod', &
               ' zero flux input at source level', FATAL)
          endif
          eps = (ampl*1.5/nk)/Bsum

!--------------------------------------------------------------------
!    loop over the nk different wavelengths in the spectrum.
!--------------------------------------------------------------------
          do ink=1,nk   ! wavelength loop

!----------------------------------------------------------------------
!    define variables needed at levels above the source level.
!---------------------------------------------------------------------
            do k=0,iz0
              fac(k) = 0.5*(rho(i,j,k)/rho(i,j,iz0))*kwv(ink)/bf(i,j,k)
            end do

            do k=0,iz0 
              dz(k) = z(i,j,k) - z(i,j,k+1)
              Hb = -(dz(k))/alog(rho(i,j,k)/rho(i,j,k+1))
              alp2 = 0.25/(Hb*Hb)
              omc(k) = sqrt((bf(i,j,k)*bf(i,j,k)*k2(ink))/    &
                            (k2(ink) + alp2))
            end do

!---------------------------------------------------------------------
!    initialize a flag which will indicate which waves are still 
!    propagating upwards.
!---------------------------------------------------------------------
            msk = 1

!----------------------------------------------------------------------
!    integrate upwards from the source level.  define variables over 
!    which to sum the deposited flux and effective eddy diffusivity 
!    from all waves breaking at a given level.
!----------------------------------------------------------------------
            do k=iz0, 0, -1
              fm = 0.
              fe = 0.
              do n=1,nc     ! phase speed loop

!----------------------------------------------------------------------
!    check only those waves which are still propagating, i.e., msk = 1.
!----------------------------------------------------------------------
                if (msk(n) == 1) then
                  c0mu(k) = c0(n) - u(i,j,k)

!----------------------------------------------------------------------
!    if phase speed matches the wind speed, remove c0(n) from the 
!    set of propagating waves.
!----------------------------------------------------------------------
                  if (c0mu(k) == 0.) then
                    msk(n) = 0
                  else

!---------------------------------------------------------------------
!    define the criterion which determines if wave is reflected at this 
!    level (test).
!---------------------------------------------------------------------
                    test = abs(c0mu(k))*kwv(ink) - omc(k)
                    if (test >= 0.0) then

!---------------------------------------------------------------------
!    wave has undergone total internal reflection. remove it from the
!    propagating set.
!---------------------------------------------------------------------
                      msk(n) = 0
                    else 

!---------------------------------------------------------------------
!    if wave is  not reflected at this level, determine if it is 
!    breaking at this level (Foc >= 0),  or if wave speed relative to 
!    windspeed has changed sign from its value at the source level 
!    (c0mu0(n)*c0mu <= 0). if it is above the source level and is
!    breaking, then add its momentum flux to the accumulated sum at 
!    this level, and increase the effective diffusivity accordingly. 
!    set flag to remove phase speed c0(n) from the set of active waves
!    moving upwards to the next level.
!---------------------------------------------------------------------
                      Foc = B0(n)/(c0mu(k) )**3 - fac(k)
                      if ((Foc >= 0.0) .or.     &
                              (c0mu0(n)*c0mu(k)  <= 0.0)) then
                        msk(n) = 0
                        if (k  < iz0) then
                          fm = fm + B0(n)
                          fe = fe + c0mu(k)*B0(n)
                        endif
                      endif                      
                    endif   ! (test >= 0.0)
                  endif ! (c0mu == 0.0)
                endif   ! (msk == 1)
              end do  ! phase speed loop

!----------------------------------------------------------------------
!    compute the gravity wave momentum flux forcing and eddy 
!    diffusion coefficient obtained across the entire wave spectrum
!    at this level.
!----------------------------------------------------------------------
              if ( k < iz0) then
                rbh = sqrt(rho(i,j,k)*rho(i,j,k+1))
                wv_frcng(k) = ( rho(i,j,iz0)/rbh)*fm*eps/dz(k)
                wv_frcng(k+1) =  0.5*(wv_frcng(k+1) + wv_frcng(k))
                diff_coeff(k) = (rho(i,j,iz0)/rbh)*fe*eps/(dz(k)*   &
                                 bf(i,j,k)*bf(i,j,k))
                diff_coeff(k+1) = 0.5*(diff_coeff(k+1) +    &
                                       diff_coeff(k))
              else 
                wv_frcng(iz0) = 0.0
                diff_coeff(iz0) = 0.0
              endif
            end do  ! (k loop)               

!---------------------------------------------------------------------
!    increment the total forcing at each point with that obtained from
!    the set of waves with the current wavenumber.
!---------------------------------------------------------------------
            do k=0,iz0      
              gwf(i,j,k) = gwf(i,j,k) + wv_frcng(k)
              ked(i,j,k) = ked(i,j,k) + diff_coeff(k)
            end do              
          end do   ! wavelength loop
        end do  ! i loop                      
      end do   ! j loop                 

!--------------------------------------------------------------------



end subroutine gwfc



!####################################################################


end module cg_drag_mod





                      module clouds_mod

!=======================================================================
!
!            determines cloud properties necessary for 
!                    fels-schwartzkopf radiation
!
!=======================================================================

use    cloud_rad_mod, only:  cloud_rad_init, cloud_summary
use  cloud_zonal_mod, only:  cloud_zonal
use    cloud_obs_mod, only:  cloud_obs, cloud_obs_init
use time_manager_mod, only:  time_type
use          mpp_mod, only:  input_nml_file
use          fms_mod, only:  error_mesg, FATAL, file_exist,   &
                             check_nml_error, open_namelist_file,      &
                             mpp_pe, mpp_root_pe, close_file, &
                             write_version_number, stdlog
use    rh_clouds_mod, only:  do_rh_clouds, rh_clouds, rh_clouds_avg
use  strat_cloud_mod, only:  do_strat_cloud, strat_cloud_avg
use   diag_cloud_mod, only:  do_diag_cloud, diag_cloud_driver, &
                             diag_cloud_avg
use diag_manager_mod, only:  register_diag_field, send_data

implicit none
private

!------------------- public interfaces ---------------------------------

public   clouds, clouds_init, clouds_end

!-----------------------------------------------------------------------
!--------------------- version number ----------------------------------
 character(len=128) :: version = '$Id: clouds.F90,v 17.0.4.1 2010/08/30 20:33:31 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!   note:  the fels-schwarzkopf radiation code permits bi-spectral
!          cloud reflectivity associated with cloud cdwtr droplets:
!            -->  visible band - (cao3sw and cuvrf);
!            -->  near infra-red band - (cah2sw and cirrf).
!          the f-s code assumes that all gaseous absorption by
!          cdwtr vapor occurs in the near infra-red band.
!          thus, original code contains cbsw and cirab.
!          we shall include cbo3sw and cuvab and let cbsw = cbh2sw.
!          however, these spectral absorptivities will be set to zero.

      real, dimension(3) :: cao3sw = (/ 0.210, 0.450, 0.590 /)
      real, dimension(3) :: cah2sw = (/ 0.210, 0.450, 0.590 /)
      real, dimension(3) :: cbsw   = (/ 0.005, 0.020, 0.035 /)


!-----------------------------------------------------------------------

      logical :: module_is_initialized =.false.

      integer :: id_tot_cld_amt, id_high_cld_amt, id_mid_cld_amt, &
                 id_low_cld_amt, id_cld_amt, id_em_cld,  &
                 id_alb_uv_cld, id_alb_nir_cld,          &
                 id_abs_uv_cld, id_abs_nir_cld

      character(len=6), parameter :: mod_name = 'clouds'

      real :: missing_value = -999.

!-----------------------------------------------------------------------
!------------------------- namelist ------------------------------------

      logical :: do_zonal_clouds = .false.
      logical :: do_obs_clouds   = .false.
      logical :: do_no_clouds    = .false.
      logical :: do_isccp_cloud_diags = .false.
      
      namelist /clouds_nml/ do_zonal_clouds,  &
                            do_obs_clouds,    &
                            do_no_clouds,     &
                            do_isccp_cloud_diags

!-----------------------------------------------------------------------

contains

!#######################################################################

subroutine clouds  (is, js, clear_sky, Time, Time_diag, lat, &
                    land, tsfc, pfull, phalf, t, q, cosz,    &
                    nclds, ktopsw, kbtmsw, ktoplw, kbtmlw,   &
                    cldamt, cuvrf, cirrf, cirab, emcld, mask, kbot)

!-----------------------------------------------------------------------
        integer, intent(in)                    :: is, js
        logical, intent(in)                    :: clear_sky
type(time_type), intent(in)                    :: Time, Time_diag

   real, intent(in), dimension(:,:)    :: lat
   real, intent(in), dimension(:,:)    :: land,tsfc
   real, intent(in), dimension(:,:,:)  :: pfull,phalf,t,q
   real, intent(in), dimension(:,:)    :: cosz
integer, intent(out), dimension(:,:)   :: nclds
integer, intent(out), dimension(:,:,:) :: ktopsw,kbtmsw,ktoplw,kbtmlw
   real, intent(out), dimension(:,:,:) :: cldamt,cuvrf,cirrf,cirab,emcld
   real, intent(in),  dimension(:,:,:),optional :: mask
integer, intent(in),  dimension(:,:),  optional :: kbot
!-----------------------------------------------------------------------
   real,dimension(size(cirab,1),size(cirab,2),size(cirab,3)) :: cuvab
integer,dimension(size(ktoplw,1),size(ktoplw,2),size(ktoplw,3)) ::  &
                       ktop, kbtm
!      TCA_CA   array for total clouds diagnositc
!      HML_CA   array for high, middle and low clouds diagnostics
!               as per 3rd index values of 1,2 and 3 respectively.
   real,dimension(size(pfull,1),size(pfull,2))   :: tca
   real,dimension(size(pfull,1),size(pfull,2),3) :: hml_ca
 
!      pflux    array for the flux pressure levels for isccp cloud
!               diagnostics calculations
   real,dimension(size(phalf,1),size(phalf,2),size(phalf,3))  :: pflux
   

   real,dimension(size(pfull,1),size(pfull,2),size(pfull,3)) ::  &
                                                     ql,qi,cf,rh,cloud
   real,dimension(size(phalf,1),size(phalf,2),size(phalf,3)) :: phaf
   real :: rad2deg
integer :: i,j,k,kb,kx,kp1,n,ierr
logical :: used
!-----------------------------------------------------------------------

! The following local quantitities are used exclusively for diagnostic clouds
!      TEMP     Averaged temperature (Deg K) at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      QMIX     Averaged specific humidity at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      OMEGA  Averaged pressure vertical velocity at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      LGSCLDELQ  Averaged rate of change in mix ratio due to lg scale precip 
!               at full model levels  
!               (dimensioned IX x JX x KX)
!      CNVCNTQ  Accumulated count of change in mix ratio due to conv precip 
!               at full model levels  
!               (dimensioned IX x JX x KX)
!      CONVPRC  Accumulated conv precip rate summed over all
!               full model levels (mm/day )
!               (dimensioned IX x JX)
!      Note:    RH is also a predictor but since it is used in the rh cloud
!               scheme as well it has already been declared.
!      PSFC     Surface pressure
!               (dimensioned IX x JX)
real, dimension(size(t,1),size(t,2),size(t,3)) :: temp,qmix,omega
real, dimension(size(t,1),size(t,2),size(t,3)) :: lgscldelq,cnvcntq
real, dimension(size(t,1),size(t,2)) :: convprc,psfc

!-----------------------------------------------------------------------

  ierr = 1

  kx  = size(ktopsw,3)-1
  kp1 = kx+1
    
  if (kx /= size(pfull,3)) call error_mesg ('clouds in clouds_mod', &
                       'input arrays have the incorrect size.',FATAL)

!-----------------------------------------------------------------------
!----------- default clouds values ----------

      call default_clouds (nclds,ktopsw,kbtmsw,ktoplw,kbtmlw,  &
                           cldamt,cuvrf,cirrf,cuvab,cirab,emcld)

!-------------- no clouds ----------------------------------------------

      if (clear_sky .or. do_no_clouds) then
          if (present(kbot)) call step_mtn_clouds (kx,kbot,          &
                                 nclds,ktopsw,kbtmsw,ktoplw,kbtmlw,  &
                                 cldamt,cuvrf,cirrf,cirab,emcld)
          return
      endif

!-----------------------------------------------------------------------
!--------------- determine rh cloud properties -----------------
 if ( do_rh_clouds() ) then
!-----------------------------------------------------------------------
!---- compute rh_clouds -----

     call rh_clouds_avg (is, js, rh, ierr)

     if (ierr == 0) then
         rad2deg = 90./acos(0.0)
         call rh_clouds(rh,pfull,phalf(:,:,kx+1),cosz,lat*rad2deg,&
                        nclds,ktop(:,:,2:kp1),kbtm(:,:,2:kp1),  &
                        cldamt(:,:,2:kp1),cuvrf(:,:,2:kp1),  &
                        cirrf(:,:,2:kp1),cuvab(:,:,2:kp1),  &
                        cirab(:,:,2:kp1),emcld(:,:,2:kp1))
     endif     

!-----------------------------------------------------------------------
 endif
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!--------------- determine prognostic cloud properties -----------------
 if ( do_strat_cloud() ) then
!-----------------------------------------------------------------------
      
     call strat_cloud_avg (is, js, ql, qi, cf, ierr)

     if (ierr == 0) then
         call cloud_summary (is,js,land,ql,qi,cf,q,pfull, &
                             phalf,t,cosz,tsfc,&
                             nclds,ktop(:,:,2:kp1),kbtm(:,:,2:kp1),  &
                             cldamt(:,:,2:kp1), &
                             Time=Time_diag, &
                             r_uv=cuvrf(:,:,2:kp1), &
                             r_nir=cirrf(:,:,2:kp1), &
                             ab_uv=cuvab(:,:,2:kp1), &
                             ab_nir=cirab(:,:,2:kp1), &
                             em_lw=emcld(:,:,2:kp1))
     endif     

!-----------------------------------------------------------------------
 endif     
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!--------------- determine diagnostic cloud properties -----------------
 if ( do_diag_cloud() ) then
!-----------------------------------------------------------------------
      
     call diag_cloud_avg (is, js, temp,qmix,rh,omega, &
                          lgscldelq,cnvcntq,convprc,ierr)

     psfc(:,:) = phalf(:,:,kp1)
     if (ierr == 0) then
         call diag_cloud_driver (is,js, &
                    temp,qmix,rh,omega,lgscldelq,cnvcntq,convprc, &
                    pfull,phalf,psfc,cosz,lat,Time, &
                    nclds,ktop(:,:,2:kp1),kbtm(:,:,2:kp1), &
                    cldamt(:,:,2:kp1),cuvrf(:,:,2:kp1),  &
                    cirrf(:,:,2:kp1),cuvab(:,:,2:kp1),  &
                    cirab(:,:,2:kp1),emcld(:,:,2:kp1) )
!                    cirab(:,:,2:kp1),emcld(:,:,2:kp1) ,kbot)
     endif     

!-----------------------------------------------------------------------
 endif     
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!  ----------- zonal or observed clouds ??? --------------
!  (also do if avg cloud properties could not be returned)
!-----------------------------------------------------------------------
 if ( (do_zonal_clouds .or. do_obs_clouds) .and. ierr /= 0  ) then
!-----------------------------------------------------------------------

!    ---- constrain phalf to:  0. <= phalf <= 101325. ----
      if (present(kbot)) then
         do k=1,kx+1; do j=1,size(phalf,2); do i=1,size(phalf,1)
            kb=kbot(i,j)
            phaf(i,j,k)=101325.*phalf(i,j,k)/phalf(i,j,kb+1)
         enddo; enddo; enddo
      else
         do k=1,kx+1
            phaf(:,:,k)=101325.*phalf(:,:,k)/phalf(:,:,kx+1)
         enddo
      endif

!   ---- get three cloud levels (store in k=2,4) -----

      call cloud_zonal (Time, lat, phaf, nclds,  &
                        ktopsw(:,:,2:4), kbtmsw(:,:,2:4), &
                        ktoplw(:,:,2:4), kbtmlw(:,:,2:4), &
                        cldamt(:,:,2:4), cuvrf(:,:,2:4),  &
                        cirrf(:,:,2:4), cirab(:,:,2:4),  &
                        emcld(:,:,2:4))

      if (do_obs_clouds) call cloud_obs (is, js, Time, cldamt(:,:,2:4))

!-----------------------------------------------------------------------
 endif
!-----------------------------------------------------------------------


!----- store longwave and shortwave indices -----

   if ( (do_rh_clouds() .or. do_strat_cloud() .or. do_diag_cloud()) &
        .and. ierr == 0 ) then

         do j=1,size(ktoplw,2)
         do i=1,size(ktoplw,1)
            if (nclds(i,j) > 0) then
               n=nclds(i,j)
               ktoplw(i,j,2:n+1)=ktop(i,j,2:n+1)
               kbtmlw(i,j,2:n+1)=kbtm(i,j,2:n+1)
               ktopsw(i,j,2:n+1)=ktop(i,j,2:n+1)
               kbtmsw(i,j,2:n+1)=kbtm(i,j,2:n+1)+1
            endif
         enddo
         enddo
   endif


!-----------------------------------------------------------------------
!------------------------ diagnostics section --------------------------

!---- total cloud diagnostic ----
      if ( id_tot_cld_amt > 0 ) then
         call compute_tca_random ( nclds, cldamt(:,:,2:kp1), tca )
         used = send_data ( id_tot_cld_amt, tca, Time_diag, is, js )
      endif

!---- high,mid,low cloud diagnostics ----
      if ( id_high_cld_amt > 0 .or. id_mid_cld_amt > 0 .or. &
            id_low_cld_amt > 0 ) then

         if (do_isccp_cloud_diags) then
!           Do alternative (isccp) high,mid,low cloud methodology.            
!           Use methodology adopted from cloudrad_package:

!           Construct the pflux array, which is the flux pressure
!           level midway between the pressure levels in the model
!           where radiation is actually computed.  Add surface
!           pressure as the final vertical level of the 3-D array.
!           The first element of the array is set to zero.
!           The array which uses these is based on cgs units, 
!           so also multiply by 10 to convert from Pa to dynes/cm2.

            if (present(kbot)) then
               call error_mesg ('clouds in clouds_mod', &
                  'compute_isccp_clds not set up/tested on case where kbot is present.',FATAL)
            end if
     
            pflux(:,:,1) = 0.
            do k = 2, kx
               pflux(:,:,k) = 0.5 * (pfull(:,:,k-1)+pfull(:,:,k)) * 10.0
            end do
            pflux(:,:,kp1) = phalf(:,:,kp1) * 10.0  
       
            call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
                             cldamt(:,:,2:kp1), cloud )
                             
            call compute_isccp_clds ( pflux, cloud, hml_ca)               

         else
!           Use original methodology contained in this module:            
            call compute_hml_ca_random ( nclds, cldamt(:,:,2:kp1), &
                    kbtmlw(:,:,2:kp1), pfull, phalf, hml_ca, kbot )
         end if           
                    
         if ( id_high_cld_amt > 0 ) used = send_data &
                     ( id_high_cld_amt, hml_ca(:,:,1), Time_diag, is, js )
         if ( id_mid_cld_amt > 0 ) used = send_data &
                      ( id_mid_cld_amt, hml_ca(:,:,2), Time_diag, is, js )
         if ( id_low_cld_amt > 0 ) used = send_data &
                      ( id_low_cld_amt, hml_ca(:,:,3), Time_diag, is, js )
      endif

!------- cloud amount -------------------------
      if ( id_cld_amt > 0 ) then
         call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
                             cldamt(:,:,2:kp1), cloud )
         used = send_data ( id_cld_amt, cloud, Time_diag, is, js, 1, &
                            rmask=mask )
      endif

!------- cloud emissivity ---------------------------------------
      if ( id_em_cld > 0 ) then
         call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
                             emcld(:,:,2:kp1), cloud )
         used = send_data ( id_em_cld, cloud, Time_diag, is, js, 1, &
                            rmask=mask )
      endif

!------- ultra-violet reflected by cloud -----------------------------
      if ( id_alb_uv_cld > 0 ) then
         call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
                             cuvrf(:,:,2:kp1), cloud )
         used = send_data ( id_alb_uv_cld, cloud, Time_diag, is, js, 1, &
                            rmask=mask )
      endif

!------- infra-red reflected by cloud -----------------------------
      if ( id_alb_nir_cld > 0 ) then
         call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
                             cirrf(:,:,2:kp1), cloud )
         used = send_data ( id_alb_nir_cld, cloud, Time_diag, is, js, 1, &
                            rmask=mask )
      endif

!------- ultra-violet absorbed by cloud (not implemented)------------
!     if ( id_abs_uv_cld > 0 ) then
!        call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
!                            cuvab(:,:,2:kp1), cloud )
!        used = send_data ( id_abs_uv_cld, cloud, Time_diag, is, js, 1, &
!                           rmask=mask )
!     endif

!------- infra-red absorbed by cloud -----------------------------
      if ( id_abs_nir_cld > 0 ) then
         call expand_cloud (nclds, ktoplw(:,:,2:kp1),kbtmlw(:,:,2:kp1), &
                             cirab(:,:,2:kp1), cloud )
         used = send_data ( id_abs_nir_cld, cloud, Time_diag, is, js, 1, &
                            rmask=mask )
      endif

!--------------END OF DIAGNOSTICS --------------------------------------
!-----------------------------------------------------------------------
!---- step mountain clouds in underground levels ----

     if (present(kbot)) call step_mtn_clouds (kx,kbot,              &
                                nclds,ktopsw,kbtmsw,ktoplw,kbtmlw,  &
                                cldamt,cuvrf,cirrf,cirab,emcld)

!-----------------------------------------------------------------------

      end subroutine clouds

!#######################################################################

 subroutine compute_tca_random ( nclds, cldamt, tca )

   integer, intent(in)  :: nclds (:,:)
   real,    intent(in)  :: cldamt(:,:,:)
   real,    intent(out) :: tca   (:,:)

   integer :: k, max_cld

!---- find maximum number of clouds -----

    max_cld = maxval(nclds)

!---- compute total cloud amount assuming that -----
!       independent clouds overlap randomly

    tca = 1.0

    do k = 1, max_cld
       tca(:,:) = tca(:,:) * (1. - cldamt(:,:,k))
    enddo

    tca = (1. - tca) * 100.


 end subroutine compute_tca_random

!#######################################################################

 subroutine compute_hml_ca_random ( nclds, cldamt, kbtm, pfull, phalf, &
                                    hml_ca, kbot )

   integer, intent(in)  :: nclds (:,:), kbtm(:,:,:)
   real,    intent(in)  :: cldamt(:,:,:), pfull(:,:,:), phalf(:,:,:)
   real,    intent(out) :: hml_ca   (:,:,:)
   integer, intent(in), optional :: kbot(:,:)

! hml_ca - array for high, middle and low clouds as per 3rd index values
!          of 1,2 and 3 respectively.

! ---------------------------------------------------------------------

   integer,  parameter :: mid_btm = 7.0e4,high_btm = 4.0e4

! local array
real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: pfull_norm
! pfull_norm is normalized pressure at full model levels

   integer :: i, j, k, kx, kb

   kx   = size(pfull,3)

!  calculate normalized presure to allow full range of high middle low 
!  clouds independent of orography

   if (present(kbot)) then
         do k=1,kx+1; do j=1,size(phalf,2); do i=1,size(phalf,1)
            kb=kbot(i,j)
            pfull_norm(i,j,k)=101325.*phalf(i,j,k)/phalf(i,j,kb+1)
         enddo; enddo; enddo
   else
         do k=1,kx
            pfull_norm(:,:,k)=101325.*pfull(:,:,k)/phalf(:,:,kx+1)
         enddo
   endif

!---- compute high, middle and low cloud amounts assuming that -----
!       independent clouds overlap randomly

    hml_ca = 1.0

    do j=1,size(nclds,2)
    do i=1,size(nclds,1)
!   if (nclds(i,j) == 0) cycle

      do k = 1, nclds(i,j)
         if (pfull_norm(i,j,kbtm(i,j,k)) .le. high_btm) then
           hml_ca(i,j,1) = hml_ca(i,j,1) * (1. - cldamt(i,j,k))
         else if ( (pfull_norm(i,j,kbtm(i,j,k)) .le. mid_btm) .and.  &
                   (pfull_norm(i,j,kbtm(i,j,k)) .gt. high_btm) ) then
           hml_ca(i,j,2) = hml_ca(i,j,2) * (1. - cldamt(i,j,k))
         else 
           hml_ca(i,j,3) = hml_ca(i,j,3) * (1. - cldamt(i,j,k))
         endif
      enddo

    enddo
    enddo

    hml_ca = (1. - hml_ca) * 100.


 end subroutine compute_hml_ca_random

!#######################################################################

subroutine compute_isccp_clds ( pflux, cloud, hml_ca)

real,  dimension(:,:,:),   intent(in)  :: pflux, cloud
real,  dimension(:,:,:),   intent(out) :: hml_ca

!
!   define arrays giving the fractional cloudiness for clouds with
!   tops within the ISCCP definitions of high (10-440 hPa), middle
!   (440-680 hPa) and low (680-1000 hPa).
 
!    note that at this point pflux is in cgs units. change this later.

!    This routine is copied from cloudrad_package_mod, where
!    it is private and thus non-accessible from here directly.
!    Modified to work within this routine...
 
! ---------------------------------------------------------------------

   real,  parameter :: mid_btm = 6.8e5,high_btm = 4.4e5
  
! local array

integer :: i, j, k

 
!---- compute high, middle and low cloud amounts assuming that -----
!       independent clouds overlap randomly

    hml_ca = 1.0
    
 
   do j=1, size(cloud,2)
    do i=1, size(cloud,1)
      do k = 1, size(cloud,3)
        if (pflux(i,j,k)  <=  high_btm) then
          hml_ca(i,j,1) = hml_ca(i,j,1) * (1. - cloud(i,j,k))
        else if ( (pflux(i,j,k) >  high_btm) .and.  &
           (pflux(i,j,k) <=  mid_btm) ) then
         hml_ca(i,j,2) = hml_ca(i,j,2) * (1. - cloud(i,j,k))
       else  if ( pflux(i,j,k) > mid_btm ) then
         hml_ca(i,j,3) = hml_ca(i,j,3) * (1. - cloud(i,j,k))
       endif
    enddo
  enddo
  enddo

    hml_ca = 1. - hml_ca
    hml_ca = 100. * hml_ca
  
end subroutine compute_isccp_clds
!#######################################################################

      subroutine default_clouds (nclds,ktopsw,kbtmsw,ktop,kbtm,  &
                                 cldamt,cuvrf,cirrf,cuvab,cirab,emcld)

!----------------------------------------------------------------------
   integer, intent(inout), dimension(:,:)   :: nclds
   integer, intent(inout), dimension(:,:,:) :: ktopsw,kbtmsw,ktop,kbtm
      real, intent(inout), dimension(:,:,:) :: cldamt,cuvrf,cirrf,  &
                                               cuvab,cirab,emcld
!----------------------------------------------------------------------
      integer  kp1

      kp1=size(ktopsw,3)

      nclds(:,:)=0

      cldamt=0.0; emcld =1.0
      cuvrf =0.0; cirrf =0.0; cuvab =0.0; cirab =0.0
      ktopsw=kp1; kbtmsw=kp1
!     ktop  =kp1; kbtm  =kp1
      ktop  =kp1-1; kbtm  =kp1-1
!     ---- reset top properties ----
      ktopsw(:,:,1)=1
      kbtmsw(:,:,1)=0
      ktop  (:,:,1)=1
      kbtm  (:,:,1)=0

!----------------------------------------------------------------------

      end subroutine default_clouds

!#######################################################################

      subroutine step_mtn_clouds (kmax,kbot,nclds,  &
                                  ktopsw,kbtmsw,ktop,kbtm,  &
                                  cldamt,cuvrf,cirrf,cirab,emcld)

!-----------------------------------------------------------------------
   integer, intent(in)                      :: kmax
   integer, intent(in),    dimension(:,:)   :: kbot
   integer, intent(inout), dimension(:,:)   :: nclds
   integer, intent(inout), dimension(:,:,:) :: ktopsw,kbtmsw,ktop,kbtm
      real, intent(inout), dimension(:,:,:) :: cldamt,cuvrf,cirrf,  &
                                                      cirab,emcld
!-----------------------------------------------------------------------
   integer  i,j,n,kp1

   kp1=kmax+1

         do j=1,size(kbot,2)
         do i=1,size(kbot,1)
            if (kbot(i,j) < kmax) then
               nclds(i,j)=nclds(i,j)+1
               n=nclds(i,j)+1
               ktopsw(i,j,n)=kbot(i,j)+1
               kbtmsw(i,j,n)=kp1
               ktop  (i,j,n)=kbot(i,j)+1
               kbtm  (i,j,n)=kmax
               cldamt(i,j,n)=1.0
               cuvrf (i,j,n)=0.0
               cirrf (i,j,n)=0.0
               cirab (i,j,n)=0.0
               emcld (i,j,n)=1.0
            endif
         enddo
         enddo

!-----------------------------------------------------------------------

      end subroutine step_mtn_clouds

!#######################################################################

      subroutine remove_cloud_overlap (nclds,ktop,kbtm)

!-----------------------------------------------------------------------
   integer, intent(in),    dimension(:,:)   :: nclds
   integer, intent(inout), dimension(:,:,:) :: ktop,kbtm
!-----------------------------------------------------------------------
!                   removes sw cloud overlap
!
!    nclds = number of clouds
!    ktop  = sw indice for cloud top
!    kbtm  = sw indice for cloud bottom
!
!-----------------------------------------------------------------------
   integer  i,j,kc

         do j=1,size(nclds,2)
         do i=1,size(nclds,1)
            if (nclds(i,j) <= 1) cycle

            do kc=2,nclds(i,j)
               if (ktop(i,j,kc+1) >= kbtm(i,j,kc)) cycle
!    case 1: thin or thick upper cloud, thick lower cloud
                  if (ktop(i,j,kc+1) <  kbtm(i,j,kc+1)) then
                     ktop(i,j,kc+1)=ktop(i,j,kc+1)+1
                  else
!    case 2: thick upper cloud, thin lower cloud
                     kbtm(i,j,kc)=kbtm(i,j,kc)-1
                  endif
            enddo

         enddo
         enddo

!-----------------------------------------------------------------------

      end subroutine remove_cloud_overlap

!#######################################################################

      subroutine expand_cloud ( nclds, ktop, kbtm, cloud_in, cloud_out )

      integer, intent(in)  :: nclds(:,:), ktop(:,:,:), kbtm(:,:,:)
      real,    intent(in)  :: cloud_in (:,:,:)
      real,    intent(out) :: cloud_out(:,:,:)

      integer :: i, j, n

         cloud_out = 0.0
         do j=1,size(nclds,2)
         do i=1,size(nclds,1)
            do n=1,nclds(i,j)
              cloud_out(i,j,ktop(i,j,n):kbtm(i,j,n)) = cloud_in(i,j,n)
            enddo
         enddo
         enddo

      end subroutine expand_cloud

!#######################################################################

      subroutine clouds_init ( lonb, latb, axes, Time )

!-----------------------------------------------------------------------
           real, intent(in), dimension(:,:) :: lonb, latb
        integer, intent(in), dimension(4) :: axes
type(time_type), intent(in)               :: Time
!-----------------------------------------------------------------------
      integer  unit,io,ierr, logunit

!-------------- read namelist --------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=clouds_nml, iostat=io)
      ierr = check_nml_error(io,"clouds_nml")
#else
      if ( file_exist('input.nml')) then
         unit = open_namelist_file ()
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=clouds_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'clouds_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!      ----- write namelist -----

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=clouds_nml)
      endif


      if (do_obs_clouds) call cloud_obs_init (lonb, latb)

!------------ initialize diagnostic fields -----------------------------

      call diag_field_init ( Time, axes )

!-----------------------------------------------------------------------
       if (do_strat_cloud() ) then
         call cloud_rad_init
       endif

      module_is_initialized =.true.

!-----------------------------------------------------------------------

      end subroutine clouds_init

!#######################################################################

      subroutine clouds_end

!-----------------------------------------------------------------------

      module_is_initialized =.false.

!-----------------------------------------------------------------------

      end subroutine clouds_end

!#######################################################################

   subroutine diag_field_init ( Time, axes )

     type(time_type), intent(in) :: Time
     integer        , intent(in) :: axes(4)

!-----------------------------------------------------------------------

    id_tot_cld_amt = &
    register_diag_field ( mod_name, 'tot_cld_amt', axes(1:2), Time, &
                         'total cloud amount', 'percent'            )

    id_high_cld_amt = &
    register_diag_field ( mod_name, 'high_cld_amt', axes(1:2), Time, &
                         'high cloud amount', 'percent'            )

    id_mid_cld_amt = &
    register_diag_field ( mod_name, 'mid_cld_amt', axes(1:2), Time, &
                         'mid cloud amount', 'percent'            )

    id_low_cld_amt = &
    register_diag_field ( mod_name, 'low_cld_amt', axes(1:2), Time, &
                         'low cloud amount', 'percent'            )

    id_cld_amt = &
    register_diag_field ( mod_name, 'cld_amt', axes(1:3), Time, &
                         'cloud amount', 'percent',             &
                         missing_value=missing_value            )

    id_em_cld = &
    register_diag_field ( mod_name, 'em_cld', axes(1:3), Time, &
                         'cloud emissivity', 'none',           &
                          missing_value=missing_value          )

    id_alb_uv_cld = &
    register_diag_field ( mod_name, 'alb_uv_cld', axes(1:3), Time, &
                         'UV reflected by cloud', 'none',          &
                          missing_value=missing_value              )

    id_alb_nir_cld = &
    register_diag_field ( mod_name, 'alb_nir_cld', axes(1:3), Time, &
                         'IR reflected by cloud', 'none',           &
                          missing_value=missing_value               )

!   --- do not output this field ---
!   id_abs_uv_cld = &
!   register_diag_field ( mod_name, 'abs_uv_cld', axes(1:3), Time, &
!                        'UV absorbed by cloud', 'none',           &
!                         missing_value=missing_value              )

    id_abs_nir_cld = &
    register_diag_field ( mod_name, 'abs_nir_cld', axes(1:3), Time, &
                         'IR absorbed by cloud', 'none',            &
                          missing_value=missing_value               )

!-----------------------------------------------------------------------

   end subroutine diag_field_init

!#######################################################################

end module clouds_mod



module beta_dist_mod
  use fms_mod,only: stdlog, write_version_number, &
                    error_mesg, FATAL
  use mpp_mod,only: get_unit                  
  implicit none
  private 
  
  ! Provide values of the beta distribtion as a function of the CDF (the incomplete beta
  !   function). Returns a value as a function of two beta distribution parameters p, q 
  !   (here they must be integers) and the value x of the CDF between 0 and 1. 
  
  ! In this version we build tables using the NAG library function nag_beta_deviate, then 
  !   look up values from a table. The table can be built at run time or read from 
  !   a file (this version uses netcdf format). 
  
  ! betaDeviateTable is a 3D table with dimensions
  !   x, p, q. The range of P and Q are specified when the tables are built. 
  !   The arrays bounds are from 0 to nSteps + 1, just in case we draw exactly 0 or 1. 
  !
  character(len=128)  :: version =  '$Id: betaDistribution.F90,v 16.0 2008/07/30 22:06:18 fms Exp $'
  character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'
  
  logical         :: module_is_initialized = .false.
  
  real, parameter :: failureValue = -1. 
  real, parameter :: Xmin = 0., Xmax = 1.

  integer         :: Pmax, Qmax, numXSteps
  real, dimension(:, :, :), allocatable &
                  :: betaDeviateTable, incompleteBetaTable
  character(len = 32) &
                  :: fileName = "INPUT/BetaDistributionTable.txt" 
  
  interface interpolateFromTable
    module procedure interpolateFromTable_s,  interpolateFromTable_1D, interpolateFromTable_2D, &
                     interpolateFromTable_3D, interpolateFromTable_4D
  end interface ! interpolateFromTable

  interface beta_deviate
    module procedure betaDeviate_s,  betaDeviate_1D, betaDeviate_2D, &
                     betaDeviate_3D, betaDeviate_4D
  end interface ! betaDeviate

  interface incomplete_beta
    module procedure incompleteBeta_s,  incompleteBeta_1D, incompleteBeta_2D, &
                     incompleteBeta_3D, incompleteBeta_4D
  end interface ! incompleteBeta

  public :: beta_dist_init, beta_deviate, incomplete_beta, beta_dist_end
contains
 ! ---------------------------------------------------------
  subroutine test_beta
  
    integer :: i
    real    :: x, inc_x, inv_inc_x, inv_x, inc_inv_x
    
    print *, "TESTING BETA" 
    print *, "x    inc(x)    inv(inc(x))   inv(x)   inc(inv(x))"
    do i = 0, numXSteps
      x = real(i)/real(numXSteps) 
      inc_x     = incomplete_beta(    x, 5, 5)
      inv_inc_x = beta_deviate(   inc_x, 5, 5)
      inv_x     = beta_deviate(       x, 5, 5)
      inc_inv_x = incomplete_beta(inv_x, 5, 5)
      write(*, "(5(f10.7, 1x))") x, inc_x, inv_inc_x, inv_x, inc_inv_x
    end do
  end subroutine test_beta
  ! ---------------------------------------------------------
  subroutine beta_dist_init
    ! Initialize the tables containing the incomplete beta function
    !   and its inverse (beta deviate). 
    !   If the table parameters are supplied we use the NAG libraries to 
    !   compute a new table and write it to a file; if just
    !   the file name is supplied we read the table from the file. 
    !
    
    !---------------------------------------------------------------------
    !    if routine has already been executed, exit.
    !---------------------------------------------------------------------
      if (module_is_initialized) return
    
    !---------------------------------------------------------------------
    !    mark the module as initialized if we're able to read the tables
    !---------------------------------------------------------------------
    call write_version_number (version, tagname)
    module_is_initialized = readFromFile(fileName)
    
  end subroutine beta_dist_init
!---------------------------------------------------------------------
  subroutine beta_dist_end

    !---------------------------------------------------------------------
    !    be sure module has been initialized.
    !---------------------------------------------------------------------
    if (.not. module_is_initialized ) return
    
    if(allocated(betaDeviateTable))    deallocate(betaDeviateTable)
    if(allocated(incompleteBetaTable)) deallocate(incompleteBetaTable)
    module_is_initialized = .false.
    
  end subroutine beta_dist_end
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     SEMI-PRIVATE PROCEDURES 
!            Not accessed directly but through generic interface
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! ---------------------------------------------------------
!  Functions to look up the beta deviate (inverse incomplete beta distribution) 
!    from a table
!    Overloaded, to allow for input arguments from 0 to 4 dimensions
!    It might be more efficient to loop over dimensions higher than 1 to 
!    avoid using reshape.
! ---------------------------------------------------------
  function betaDeviate_s(x, p, q) result (betaDeviate)
    real,                  intent( in) :: x
    integer,               intent( in) :: p, q
    real                               :: betaDeviate
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax, x < Xmin, x > Xmax /) )) then
      betaDeviate = FailureValue
    else
      betaDeviate = interpolateFromTable(x, p, q, betaDeviateTable)
    end if
  end function betaDeviate_s
! ---------------------------------------------------------
  function betaDeviate_1D(x, p, q) result (betaDeviate)
    real,    dimension(:),    intent( in) :: x
    integer,                  intent( in) :: p, q
    real,    dimension(size(x))           :: betaDeviate
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      betaDeviate(:) = FailureValue
    else
      betaDeviate(:) = interpolateFromTable(x, p, q, betaDeviateTable)
    end if
  end function betaDeviate_1D
! ---------------------------------------------------------
  function betaDeviate_2D(x, p, q) result (betaDeviate)
    real,    dimension(:, :), intent( in) :: x
    integer,                  intent( in) :: p, q
    real,    dimension(size(x, 1), &
                       size(x, 2))        :: betaDeviate
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      betaDeviate(:, :) = FailureValue
    else
      betaDeviate(:, :) = interpolateFromTable(x, p, q, betaDeviateTable)
    end if
  end function betaDeviate_2D
! ---------------------------------------------------------
  function betaDeviate_3D(x, p, q) result (betaDeviate)
    real,    dimension(:, :, :), intent( in) :: x
    integer,                     intent( in) :: p, q
    real,    dimension(size(x, 1), &
                       size(x, 2), &
                       size(x, 3))           :: betaDeviate
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      betaDeviate(:, :, :) = FailureValue
    else
      betaDeviate(:, :, :) = interpolateFromTable(x, p, q, betaDeviateTable)
    end if
  end function betaDeviate_3D
! ---------------------------------------------------------
  function betaDeviate_4D(x, p, q) result (betaDeviate)
    real,    dimension(:, :, :, :), intent( in) :: x
    integer,                        intent( in) :: p, q
    real,    dimension(size(x, 1), size(x, 2), &
                       size(x, 3), size(x, 4))  :: betaDeviate
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      betaDeviate(:, :, :, :) = FailureValue
    else
      betaDeviate(:, :, :, :) = interpolateFromTable(x, p, q, betaDeviateTable)
    end if
  end function betaDeviate_4D
! ---------------------------------------------------------
! ---------------------------------------------------------
!  Functions to look up the incomplete beta function from a table. 
!    Overloaded, to allow for input arguments from 0 to 4 dimensions
!    It might be more efficient to loop over dimensions higher than 1 to 
!    avoid using reshape.
! ---------------------------------------------------------
  function incompleteBeta_s(x, p, q) result (incompleteBeta)
    real,                  intent( in) :: x
    integer,               intent( in) :: p, q
    real                               :: incompleteBeta
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax, x < Xmin, x > Xmax /) )) then
      incompleteBeta = FailureValue
    else
      incompleteBeta = interpolateFromTable(x, p, q, incompleteBetaTable)
    end if
  end function incompleteBeta_s
! ---------------------------------------------------------
  function incompleteBeta_1D(x, p, q) result (incompleteBeta)
    real,    dimension(:),    intent( in) :: x
    integer,                  intent( in) :: p, q
    real,    dimension(size(x))           :: incompleteBeta
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      incompleteBeta(:) = FailureValue
    else
      incompleteBeta(:) = interpolateFromTable(x, p, q, incompleteBetaTable)
    end if
  end function incompleteBeta_1D
! ---------------------------------------------------------
  function incompleteBeta_2D(x, p, q) result (incompleteBeta)
    real,    dimension(:, :), intent( in) :: x
    integer,                  intent( in) :: p, q
    real,    dimension(size(x, 1), &
                       size(x, 2))        :: incompleteBeta
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      incompleteBeta(:, :) = FailureValue
    else
      incompleteBeta(:, :) = interpolateFromTable(x, p, q, incompleteBetaTable)
    end if
  end function incompleteBeta_2D
! ---------------------------------------------------------
  function incompleteBeta_3D(x, p, q) result (incompleteBeta)
    real,    dimension(:, :, :), intent( in) :: x
    integer,                     intent( in) :: p, q
    real,    dimension(size(x, 1), &
                       size(x, 2), &
                       size(x, 3))           :: incompleteBeta
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      incompleteBeta(:, :, :) = FailureValue
    else
      incompleteBeta(:, :, :) = interpolateFromTable(x, p, q, incompleteBetaTable)
    end if
  end function incompleteBeta_3D
! ---------------------------------------------------------
  function incompleteBeta_4D(x, p, q) result (incompleteBeta)
    real,    dimension(:, :, :, :), intent( in) :: x
    integer,                        intent( in) :: p, q
    real,    dimension(size(x, 1), size(x, 2), &
                       size(x, 3), size(x, 4))  :: incompleteBeta
    
    if (.not. module_is_initialized ) then
      call error_mesg ('beta_dist_mod', 'module has not been initialized', FATAL )
    endif
    
    if(any( (/ p < 1, p > pMax, q < 1, q > qMax /) )) then
      incompleteBeta(:, :, :, :) = FailureValue
    else
      incompleteBeta(:, :, :, :) = interpolateFromTable(x, p, q, incompleteBetaTable)
    end if
  end function incompleteBeta_4D
! ---------------------------------------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PRIVATE PROCEDURES 
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  ! ---------------------------------------------------------
  function interpolateFromTable_s(x, p, q, table) result (values)
    real,                      intent( in) :: x
    integer,                   intent( in) :: p, q
    real, dimension(0:, :, :), intent( in) :: table
    real                                  :: values
    
    ! Local variables
    integer :: xIndex
    real    :: xWeight
    
    ! Check to see if we're at an endpoint of the distribution 
    if      (abs(x - xMax) < spacing(Xmax)) then
      values = 1.
    else if (abs(x - XMin) < spacing(Xmin))  then
      values = 0.
    else
      !
      ! Linear interpolation in x
      !
      xIndex = int( x * numXSteps)
      xWeight = numXSteps *  x - xIndex
      values = (1. - xWeight) * table(xIndex    , p, q) + & 
               (     xWeight) * table(xIndex + 1, p, q)
    end if
  end function interpolateFromTable_s
  ! ---------------------------------------------------------
  function interpolateFromTable_1D(x, p, q, table) result(values)
    real,    dimension(:),        intent( in) :: x
    integer,                      intent( in) :: p, q
    real,    dimension(0:, :, :), intent( in) :: table
    real,    dimension(size(x))           :: values
    
    ! Local variables
    integer, dimension(size(x)) :: xIndex
    real,    dimension(size(x)) :: xWeight
    
    ! Check for parameters out of bounds, and be sure the table has been initialized. 
    ! 
    where(x(:) < Xmin .or. x(:) > Xmax) 
      values(:) = FailureValue
    else where
      !
      ! Linear interpolation in x
      !
      xIndex(:)  = int( x(:) * numXSteps)
      xWeight(:) = numXSteps *  x(:) - xIndex(:)
      values(:)  = (1. - xWeight(:)) * table(xIndex(:)    , p, q) + & 
                   (     xWeight(:)) * table(xIndex(:) + 1, p, q)
    end where

     ! Check to see if we're at an endpoint of the distribution 
    where (abs(x(:) - xMax) < spacing(Xmax)) values(:) = 1.
    where (abs(x(:) - XMin) < spacing(Xmin)) values(:) = 0.
  end function interpolateFromTable_1D
  ! ---------------------------------------------------------
  function interpolateFromTable_2D(x, p, q, table) result(values)
    real,    dimension(:, :),     intent( in) :: x
    integer,                      intent( in) :: p, q
    real,    dimension(0:, :, :), intent( in) :: table
    real,    dimension(size(x, 1), &
                       size(x, 2))           :: values
    ! Local variables 
    integer :: i
 
    do i = 1, size(x, 2)
      values(:, i) = interpolateFromTable(x(:, i), p, q, table)
    end do 
  end function interpolateFromTable_2D
  ! ---------------------------------------------------------
  function interpolateFromTable_3D(x, p, q, table) result(values)
    real,    dimension(:, :, :),  intent( in) :: x
    integer,                      intent( in) :: p, q
    real,    dimension(0:, :, :), intent( in) :: table
    real,    dimension(size(x, 1), &
                       size(x, 2), &  
                       size(x, 3))           :: values
    ! Local variables 
    integer :: i
 
    do i = 1, size(x, 3)
      values(:, :, i) = interpolateFromTable(x(:, :, i), p, q, table)
    end do 
  end function interpolateFromTable_3D
  ! ---------------------------------------------------------
  function interpolateFromTable_4D(x, p, q, table) result(values)
    real,    dimension(:, :, :, :),  intent( in) :: x
    integer,                         intent( in) :: p, q
    real,    dimension(0:, :, :),    intent( in) :: table
    real,    dimension(size(x, 1), &
                       size(x, 2), &
                       size(x, 3), &
                       size(x, 4))              :: values
    ! Local variables 
    integer :: i

    do i = 1, size(x, 4)
      values(:, :, :, i) = interpolateFromTable(x(:, :, :, i), p, q, table)
    end do 
  end function interpolateFromTable_4D
  ! ---------------------------------------------------------
  ! Reading and writing procedures
  ! ---------------------------------------------------------
  function readFromFile(fileName)
    character(len = *), intent( in) :: fileName
    logical                         :: readFromFile

    ! Local variables
!    integer, parameter :: unit = 909
    integer :: unit
    
    unit = get_unit()
    open(unit = unit, file = trim(fileName), status = 'old')
    read(unit, '(3(i5, 1x))') Pmax, Qmax, numXSteps
    allocate(   betaDeviateTable(0:numXSteps + 1, Pmax, Qmax), &
             incompleteBetaTable(0:numXSteps + 1, Pmax, Qmax))
    read(unit, '(8(f10.8, 1x))') betaDeviateTable
    read(unit, '(8(f10.8, 1x))') incompleteBetaTable
    close(unit)
 
!    print *, "Reading beta distribution tables..."
!    write(*, '(8(f10.8, 1x))') betaDeviateTable(:8, 5, 5)
!    write(*, '(8(f10.8, 1x))') incompleteBetaTable(:8, 5, 5)
   
    readFromFile = .true.
  end function readFromFile 
  
!   function readFromFile(fileName) 
!     use netcdf
!     character(len = *), intent( in) :: fileName
!     logical                         :: readFromFile
!     
!     ! Local variables - all related to netcdf
!     integer, dimension(16) :: status
!     integer                :: fileId, ncDimId, ncVarId
!    
!     status( :) = nf90_NoErr
!     status( 1) = nf90_open(trim(fileName), nf90_NoWrite, fileID)
!     status( 2) = nf90_inq_dimid(fileId, "x", ncDimId)
!     status( 3) = nf90_Inquire_Dimension(fileId, ncDimId, len = numXSteps)
!     
!     if(allocated(betaDeviateTable)) deallocate(betaDeviateTable)
!     allocate(betaDeviateTable(0:numXSteps-1, Pmax, Qmax))
!     status( 4) = nf90_inq_varId(fileId, "betaDeviateTable", ncVarId)
!     status( 5) = nf90_get_var(fileId, ncVarId, betaDeviateTable)
!     
!     if(allocated(incompleteBetaTable)) deallocate(incompleteBetaTable)
!     allocate(incompleteBetaTable(0:numXSteps-1, Pmax, Qmax))
!     status( 7) = nf90_inq_varId(fileId, "incompleteBetaTable", ncVarId)
!     status( 8) = nf90_get_var(fileId, ncVarId, betaDeviateTable)
!  
!     status( 9) = nf90_close(fileId)
!     
!     !
!     ! Make the definitions of numXSteps, consistent with what's in routine 
!     !   initializeIncBetaTables, which has a zero at one end an one extra element in each 
!     !   direction, just in case we hit the last element. 
!     ! 
!     numXSteps = numXSteps - 2
!    
!     readFromFile = all(status(:) == nf90_NoErr)
!   end function readFromFile
end module beta_dist_mod



module cloud_generator_mod

!   shared modules:
  use sat_vapor_pres_mod, only: compute_qs
  use constants_mod,      only: hlv, hls, cp_air, tfreeze, &
                                rvgas, rdgas
  use mpp_mod,            only: input_nml_file
  use fms_mod,            only: open_namelist_file, mpp_pe,       &
                                mpp_root_pe, stdlog,              &
                                write_version_number, file_exist, &
                                check_nml_error, error_mesg,      &
                                FATAL, close_file
  use random_numbers_mod, only: randomNumberStream,        &
                                getRandomNumbers
  use beta_dist_mod,      only: beta_dist_init, beta_dist_end, &
                                incomplete_beta, beta_deviate
!--------------------------------------------------------------------
  !
  ! Given a profile of cloud fraction, produce a set of columns indicating 
  !   the presence or absence of cloud consistent with one of four overlap  
  !   assumptions: random, maximum, maximum-random, and one allowing 
  !   the rank correlation of the variable to be specified between layers.
  ! The module uses a random number generation module which can be used to wrap
  !   an arbitrary random number generator. The module defines a type that keeps 
  !   the state (the seed, a generator indicator, or whatever).  
  ! Each function takes cloud fraction as a function of height. You can either supply 
  !   a vector or a 3D array of dimensions (nX, ny, nLevels); in either case the 
  !   first element in the level dimension is the highest model layer. 
  ! Each function returns an array nSamples by nLevels long, where nLevels
  !   is determined by the size of the cloud fraction array. 
  ! The neighbor-to-neighbor correlation routine takes an additional 
  !   parameters described below. 
  !
!--------------------------------------------------------------------
  implicit none
  private

!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: cloud_generator.F90,v 17.0.6.1 2010/08/30 20:39:45 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

  interface genRandomOverlapSamples
    module procedure genRandomOverlapSamples_1D, genRandomOverlapSamples_3D
  end interface ! genRandomOverlapSamples
  
  interface genMaximumOverlapSamples
    module procedure genMaximumOverlapSamples_1D, genMaximumOverlapSamples_3D
  end interface ! genMaximumOverlapSamples
  
  interface genMaxRanOverlapSamples
    module procedure genMaxRanOverlapSamples_1D, genMaxRanOverlapSamples_3D
  end interface ! genMaxRanOverlapSamples
  
  interface genWeightedOverlapSamples
    module procedure genWeightedOverlapSamples_1D, genWeightedOverlapSamples_3D
  end interface ! genWeightedOverlapSamples
  
  public :: cloud_generator_init, &
            cloud_generator_end,  &
            generate_stochastic_clouds, &
            do_cloud_generator,   &
            compute_overlap_weighting
  
!---------------------------------------------------------------------
!-------- namelist  ---------

  ! Minimum values for cloud fraction, water, ice contents
  !   Taken from cloud_rad. Perhaps these should be namelist parameters? 
  real, parameter :: qcmin = 1.E-10, qamin = 1.E-2
  
  ! Pressure scale height - for converting pressure differentials to height
  real, parameter :: pressureScaleHeight = 7.3 ! km
  
  ! Overlap parameter: 1 - Maximum, 2 - Random, 3 - Maximum/Random,
  !                    4 - Exponential
  integer         :: defaultOverlap = 2 
  real            :: overlapLengthScale = 2.0  ! km
  ! These control the option to pull cloud condensate from a symmetric  
  !    beta distribution with p = q = betaP, adjusting 
  !    the upper and lower bounds of the ditribution to match 
  !    cloud fraction and cloud condensate. 
  logical         :: do_inhomogeneous_clouds = .false. 
  integer         :: betaP = 5

  !The following apply for pdf cloud scheme
  !
  ! qthalfwidth defines the fraction of qtbar (mean total water in the
  ! grid box) that the maximum and minimum of the distribution differ 
  ! from qtbar. That is, total water at the sub-grid scale may take on 
  ! values anywhere between (1.-qthalfwidth)*qtbar and (1.+qthalfwidth)*
  ! qtbar
  !
  logical         :: do_pdf_clouds = .false.
  real            :: qthalfwidth = 0.1  
  
  ! The following apply for ppm vertical interpolation if done.
  !
  !      nsublevels      This is the number of sub-levels to be used
  !                      for sub-grid scale vertical structure to
  !                      clouds. If equal to 1, then no vertical
  !                      sub-grid scale structure is calculated.
  !
  !      kmap, kord      Quantities related to the PPM vertical inter-
  !                      polation calculation.
  !
  integer           :: nsublevels     = 1
  integer           :: kmap           = 1
  integer           :: kord           = 7
  
namelist /cloud_generator_nml/  defaultOverlap, overlapLengthScale, &
                                  do_inhomogeneous_clouds, betaP,     &
                                  do_pdf_clouds, qthalfwidth, nsublevels, &
                                  kmap,kord

!----------------------------------------------------------------------
!----  private data -------

logical :: module_is_initialized = .false.  ! module is initialized ?
logical :: cloud_generator_on    = .false.  ! is module being operated?

!----------------------------------------------------------------------

                              contains 
                              
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                              
!######################################################################
subroutine cloud_generator_init


!---------------------------------------------------------------------
!    cloud_generator_init is the constructor for 
!    cloud_generator_mod.

!----------------------------------------------------------------------
!   local variables:
      integer   ::   unit, ierr, io, logunit

!--------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      ierr     error code
!      io       error status returned from io operation  
!
!--------------------------------------------------------------------

      if (.not. module_is_initialized) then
!---------------------------------------------------------------------
!    read namelist.         
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=cloud_generator_nml, iostat=io)
        ierr = check_nml_error(io,"cloud_generator_nml")
#else
!---------------------------------------------------------------------
        if (file_exist('input.nml')) then
          unit =  open_namelist_file ( )
          ierr=1; do while (ierr /= 0)
          read (unit, nml=cloud_generator_nml, iostat=io, end=10) 
          ierr = check_nml_error (io, 'cloud_generator_nml')
          enddo                       
10        call close_file (unit)      
        endif                         
#endif
!----------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
        call write_version_number (version, tagname)
        logunit = stdlog()
        if (mpp_pe() == mpp_root_pe() ) &
                   write (logunit, nml=cloud_generator_nml)
                   
!-----------------------------------------------------------------------
!    do_inhomogeneous_clouds and do_pdf_clouds cannot be 
!    simultaneously true
!-----------------------------------------------------------------------
        if (do_inhomogeneous_clouds .and. do_pdf_clouds) then
          call error_mesg ( 'cloud_generator_mod', &
           'do_inhomogeneous_clouds and do_pdf_clouds cannot'//&
           'be simultaneously true', FATAL)
        endif
!-----------------------------------------------------------------------
!    qthalfwidth must be greater than 0.
!-----------------------------------------------------------------------
        if (qthalfwidth .lt. 1.e-03) then
          call error_mesg ( 'cloud_generator_mod', &
           'qthalfwidth must be greater than 0.001', FATAL)
        endif

!---------------------------------------------------------------------
!    Initialize the beta distribution module if we're going to need it. 
!---------------------------------------------------------------------
        if(do_inhomogeneous_clouds .or. do_pdf_clouds) &
             call beta_dist_init

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
        module_is_initialized = .true.
        cloud_generator_on    = .true.
     end if

end subroutine cloud_generator_init
!----------------------------------------------------------------------
!----------------------------------------------------------------------
subroutine generate_stochastic_clouds(streams, ql, qi, qa, qn,     &
                                      overlap, pFull, pHalf, & 
                                      temperature, qv,&
                                      cld_thickness, &
                                      ql_stoch, qi_stoch, qa_stoch, &
                                      qn_stoch)
!--------------------------------------------------------------------
!   intent(in) variables:
!
  type(randomNumberStream), &
           dimension(:, :),     intent(inout) :: streams
  ! Dimension nx, ny, nz
  real,    dimension(:, :, :),    intent( in) :: ql, qi, qa, qn
  integer,                     optional, &
                                  intent( in) :: overlap
  real,    dimension(:, :, :), optional, &
                                 intent( in)  :: pFull, temperature, qv
  ! Dimension nx, ny, nz+1
  real,    dimension(:, :, :), optional, &
                                 intent( in)  :: pHalf                  
  ! Dimension nx, ny, nz, nCol = nBands
  integer, dimension(:, :, :, :), intent(out) :: cld_thickness 
  real,    dimension(:, :, :, :), intent(out) :: ql_stoch, qi_stoch, &
                                                 qa_stoch, qn_stoch
  ! ---------------------------------------------------------
  ! Local variables
  real,    dimension(size(ql_stoch, 1), &
                     size(ql_stoch, 2), &
                     size(ql_stoch, 3)) :: qa_local, ql_local, qi_local
  real,    dimension(size(ql_stoch, 1), &
                     size(ql_stoch, 2), &
                     size(ql_stoch, 3)) :: heightDifference, &
                                           overlapWeighting  ! 1 for max, 0 for random
                         
  real,    dimension(size(ql_stoch, 1), &
                     size(ql_stoch, 2), &
                     size(ql_stoch, 3), &
                     size(ql_stoch, 4)) :: pdfRank ! continuously from 0 to 1
                                  
  ! These arrays could be declared allocatable and used only when 
  !    do_inhomogeneous_clouds OR do_pdf_clouds is true. 
  real,    dimension(size(ql_stoch, 1), &  ! Quantities for estimating condensate variability
                     size(ql_stoch, 2), &  !   from a beta distribution
                     size(ql_stoch, 3)) :: aThermo, qlqcRatio, qs_norm, &
                                           deltaQ, qs

  real,    dimension(size(ql_stoch, 1), &
                     size(ql_stoch, 2), &
                     size(ql_stoch, 3), &
                     size(ql_stoch, 4)) :: qc_stoch !stochastic condensate
  real,    dimension(4,                 &
                     size(ql_stoch,1),  &
                     size(ql_stoch,2),  &
                     size(ql_stoch,3)) :: qta4,qtqsa4 !used for ppm
  real,    dimension(size(ql_stoch,1),  &
                     size(ql_stoch,2),  &
                     size(ql_stoch,3)) :: delp !used for ppm
  real,    dimension(size(ql_stoch,1),  &
                     size(ql_stoch,2),  &
                     size(ql_stoch,4)) :: qctmp, qatmp !temporary summing 
                                                       !variables
                                   
  real    :: pnorm   !fraction of level- used for ppm interpolation    
  real    :: tmpr  
  integer :: nLev, nCol
  integer :: overlapToUse
  integer :: i, j, k, n, ns
 
  ! ---------------------------------------------------------

  nLev = size(ql_stoch, 3)
  nCol = size(ql_stoch, 4)
  
  !
  ! Normally, we use the overlap specified in the namelist for this module, but
  !   this can be overridden with an optional argument. 
  !
  if(present(overlap)) then
    overlapToUse = overlap
  else
    overlapToUse = defaultOverlap
  end if
  
  !
  ! Ensure that cloud fraction, water vapor, and water and ice contents are 
  ! in bounds
  !
  !   After similar code in cloud_summary3
  !
  qa_local(:,:,:) = 0.
  do k=1, nLev
       do j=1, size(qa_stoch,2)
       do i=1, size(qa_stoch,1)
         if (qa(i,j,k) > qamin .and. ql(i,j,k) > qcmin) then
           qa_local(i,j,k) = qa(i,j,k)
           ql_local(i,j,k) = ql(i,j,k)
         else
           ql_local(i,j,k) = 0.0           
         endif
         if (qa(i,j,k) > qamin .and. qi(i,j,k) > qcmin) then
           qa_local(i,j,k) = qa(i,j,k)
           qi_local(i,j,k) = qi(i,j,k)
         else
           qi_local(i,j,k) = 0.0           
         endif
       end do
       end do
  end do

  
  !
  ! Apply overlap assumption
  !
   if (overlapToUse == 2) then
      pdfRank(:, :, :, :) = genRandomOverlapSamples( qa_local(:, :, :), nCol, streams(:, :))
   else if (overlapToUse == 1) then
      pdfRank(:, :, :, :) = genMaximumOverlapSamples(qa_local(:, :, :), nCol, streams(:, :))
   else if (overlapToUse == 3) then
      pdfRank(:, :, :, :) = genMaxRanOverlapSamples( qa_local(:, :, :), nCol, streams(:, :))
   else if (overlapToUse == 4) then
      if(.not. present(pFull)) call error_mesg("cloud_generator_mod", &
                                               "Need to provide pFull when using overlap = 4", FATAL)
      !
      ! Height difference from hydrostatic equation with fixed scale height for T = 250 K
      !
      heightDifference(:, :, :nLev-1) = (log(pFull(:, :, 2:nLev)) - log(pFull(:, :, 1:nLev-1))) * &
                                         pressureScaleHeight 
      heightDifference(:, :, nLev) = heightDifference(:, :, nLev-1)
      !
      ! Overlap is weighted between max and random with parameter overlapWeighting (0 = random, 
      !    1 = max), which decreases exponentially with the separation distance. 
      !
      overlapWeighting(:, :, :) = exp( - heightDifference(:, :, :) / overlapLengthScale )
      pdfRank(:, :, :, :) = genWeightedOverlapSamples(qa_local(:, :, :),         &
                                                      overlapWeighting(:, :, :), & 
                             nCol, streams(:, :))
    else
      call error_mesg("cloud_generator_mod", "unknown overlap parameter", FATAL)
     
     endif



  
  if(.not. do_inhomogeneous_clouds .and. .not. do_pdf_clouds) then
    !
    ! The clouds are uniform, so every cloudy cell at a given level 
    !   gets the same ice and/or liquid concentration (subject to a minumum). 
    ! We're looking for in-cloud ice and water contents, so we 
    !   divide by cloud fraction
    !  
    do n=1,nCol
      do k=1,nLev
       do j=1, size(qa_stoch,2)
       do i=1, size(qa_stoch,1)
!  a "true" for the following test indicates the presence of cloudiness
         if (pdfRank(i,j,k,n) > (1.-qa_local(i,j,k))) then
           cld_thickness(i,j,k,n   ) = 1.
           qa_stoch(i,j,k,n   ) = 1. 
           ql_stoch(i,j,k,n   ) = ql_local(i,j,k)/qa_local(i,j,k)
           qi_stoch(i,j,k,n   ) = qi_local(i,j,k)/qa_local(i,j,k)
         else
           cld_thickness(i,j,k,n   ) = 0.
           qa_stoch(i,j,k,n   ) = 0. 
           ql_stoch(i,j,k,n   ) = 0.                              
           qi_stoch(i,j,k,n   ) = 0.                              
         endif
        end do
        end do
        end do
        end do
           

  end if
  
  if (do_inhomogeneous_clouds) then
    if(.not. present(pFull) .or. .not. present(temperature)) &
      call error_mesg("cloud_generator_mod",                 &
      "Need to provide pFull and temperature when using inhomogenous clouds", FATAL)
    !
    ! Assume that total water in each grid cell follows a symmetric beta distribution with  
    !   exponents p=q set in the namelist. Determine the normalized amount of condensate 
    !   (qc - qmin)/(qmax - qmin) from the incomplete beta distribution at the pdf rank. 
    !   Convert to physical units based on three equations
    !   qs_norm = (qs - qmin)/(qmax - qmin)
    !   qa = 1. - betaIncomplete(qs_norm, p, q)
    !   qc_mean/(qmax - qmin) = aThermo( p/(p+q) (1 - betaIncomplete(qs_norm, p+1, q)) - 
    !                                    qs_norm * (1 - cf) )
    !   The latter equation comes from integrating aThermo * (qtot - qsat) times a beta distribution 
    !   from qsat to qmax; see, for example, from Tompkins 2002 (Eq. 14), but including a thermodynamic 
    !   term aThermo = 1/(1 + L/cp dqs/dt) evaluated at the "frozen temperature", as per SAK. 
    !   
    where (qa_local(:, :, :) > qamin) 
      qlqcRatio(:, :, :) = ql_local(:, :, :) / (ql_local(:, :, :) + qi_local(:, :, :))
    elsewhere
      qlqcRatio(:, :, :) = 1 ! Shouldn't be used. 
    end where
    call computeThermodynamics(temperature, pFull, ql, qi, aThermo)

    qs_norm(:, :, :) = 1. ! This assignment is made so the values of qs_norm 
                          ! are always valid; in practice these should be masked out 
  ! in the regions below. 
    where(qa_local(:, :, :) < qamin)
      !
      ! Not cloudy, so deltaQ is irrelevant
      !
      qs_norm(:, :, :) = 1. 
      deltaQ(:, :, :) = 0.
    elsewhere
      !
      ! Hey, is this the right test for fully cloudy conditions? Is cloud fraction ever 1.? 
      !
      where (qa_local(:, :, :) >= 1.) 
        !
        ! In fully cloudy conditions we don't have any information about the bounds
        !   of the total water distribution. We arbitrarily set the lower bound to qsat.
        !   For a symmetric distribution the upper bound to qsat plus twice the amount of 
        !   condensate. 
        !
          qs_norm(:, :, :) = 0.
        deltaQ(:, :, :) = (2/aThermo(:, :, :)) * &
                          (ql_local(:, :, :) + qi_local(:, :, :)) / qa_local(:, :, :)
        ! qMin(:, :, :) = qsat(:, :, :)
      elsewhere 
        !
        ! Partially cloudy conditions - diagnose width of distribution from mean 
        !   condensate amount and cloud fraction. 
        !   The factor 1/2 = p/(p+q)
        !
        qs_norm(:, :, :) = beta_deviate(1. - qa_local(:, :, :), p = betaP, q = betaP)
        deltaQ(:, :, :) =                                                               &
          (ql_local(:, :, :) + qi_local(:, :, :)) /                                     &
          (aThermo(:, :, :) * ((1./2. * (1. - incomplete_beta(qs_norm(:, :, :),         &
                                                          p = betaP + 1, q = betaP))) - &
                               qs_norm(:, :, :) * qa_local(:, :, :) ))
        ! qMin(:, :, :) = qsat(:, :, :) - qs_norm(:, :, :) * deltaQ(:, :, :)
      end where 
    end where
  
    do n=1,nCol
      do k=1,nLev
       do j=1, size(qa_stoch,2)
       do i=1, size(qa_stoch,1)
!  a "true" for the following test indicates the presence of cloudiness
         if (pdfRank(i,j,k,n) > (1.-qa_local(i,j,k))) then
           cld_thickness(i,j,k,n   ) = 1.
           qa_stoch(i,j,k,n   ) = 1. 
      !
      ! Hey, do we need to account for cloud fraction here, as we do in the homogeneous case? 
      !   Also, does this seem like the right way to go from the mean to individual samples? 
      !
      qc_stoch(i, j, k, n) = aThermo(i,j,k  ) * deltaQ(i,j,k  ) * &
            (beta_deviate(pdfRank(i,j,k,n   ), p = betaP, q = betaP) - &
                   qs_norm(i,j,k) ) 
      ! 
      ! The proportion of ice and water in each sample is the same as the mean proportion.  
      !
           ql_stoch(i,j,k,n   ) = qc_stoch(i,j,k,n)* qlqcRatio(i,j,k)
           qi_stoch(i,j,k,n   ) = qc_stoch(i,j,k,n)*   &
                                     (1.-qlqcRatio(i,j,k))
         else
           cld_thickness(i,j,k,n   ) = 0.
           qa_stoch(i,j,k,n   ) = 0. 
           ql_stoch(i,j,k,n   ) = 0.                              
           qi_stoch(i,j,k,n   ) = 0.                              
         endif
        end do
        end do
        end do
        end do
           
  end if 

  if (do_pdf_clouds) then
    if(.not. present(pFull) .or. .not. present(temperature) .or. &
       .not. present(qv)    .or. .not. present(pHalf)) &

      call error_mesg("cloud_generator_mod",                 &
      "Need to provide pFull, pHalf, temperature and water vapor when using pdf clouds", FATAL)
    !
    ! Assume that total water in each grid cell follows a symmetric beta distribution with  
    !   exponents p=q set in the namelist. In contrast to the procedure for inhomogen-
    !   eous clouds, here the distribution is known (either from prognostic variance)
    !   or from diagnostic variance. In this case one can directly determine
    !   the cloud condensate from:
    !   
    !   qc = aThermo * (qt -qs) =
    !      = aThermo * deltaQ * (beta_deviate(pdfRank,p,q) - qsnorm)
    !
    !   Note that the qlqcRatio needs to be defined in the case that there is no
    !   cloud in the grid box from what enters this subroutine (qa_local) yet there
    !   is condensate diagnosed in this routine. The formula that weights the
    !   saturation vapor pressure as a function of temperature is used.
    
       
    where (qa_local(:, :, :) > qamin) 
      qlqcRatio(:, :, :) = ql_local(:, :, :) / (ql_local(:, :, :) + qi_local(:, :, :))
    elsewhere
      qlqcRatio(:, :, :) = min(1., max(0., 0.05*(temperature(:,:,:)-tfreeze+20.))) 
    end where
    call computeThermodynamics(temperature, pFull, ql, qi, aThermo, qs)

    !Compute ppm interpolation - if nsublevels > 1
    do k = 1, nLev
         delp(:,:,k) = pHalf(:,:,k+1)-pHalf(:,:,k)
    enddo     
    qta4(1,:,:,:) = max(qcmin,qv+ql_local+qi_local)
    qtqsa4(1,:,:,:) = qta4(1,:,:,:)-qs
        
    if (nsublevels.gt.1) then
        do i=1, size(qa_stoch,1)
            call ppm2m_sak(qta4(:,i,:,:),delp(i,:,:),nLev,kmap,1,&
                       size(qa_stoch,2),0,kord)
            call ppm2m_sak(qtqsa4(:,i,:,:),delp(i,:,:),nLev,kmap,1,&
                       size(qa_stoch,2),0,kord)
        enddo                
    else
        qta4(2,:,:,:) = qta4(1,:,:,:)
        qta4(3,:,:,:) = qta4(1,:,:,:)
        qta4(4,:,:,:) = 0.
        qtqsa4(2,:,:,:) = qtqsa4(1,:,:,:)
        qtqsa4(3,:,:,:) = qtqsa4(1,:,:,:)
        qtqsa4(4,:,:,:) = 0.   
    end if
    
    !loop over vertical levels       
    do k=1, nLev
         
        !initialize summing variable
        qctmp(:,:,:) = 0.         
        qatmp(:,:,:) = 0.
        
        !Create loop over sub-levels within a grid box
        do ns = 1, nsublevels
             
             !calculate normalized vertical level
             ! 0. = top of gridbox
             ! 1. = bottom of gridbox
        
             pnorm =  (real(ns) - 0.5 )/real(nsublevels)
             
             !First step is to calculating the 
             !the width of the qt distribution (deltaQ)
             deltaQ(:,:,k) = max(qcmin, &
                          qta4(2,:,:,k)+pnorm*( (qta4(3,:,:,k)- &
                          qta4(2,:,:,k)) +  qta4(4,:,:,j)*(1-pnorm) ) )
             deltaQ(:,:,k) = 2.*qthalfwidth*deltaQ(:,:,k)
             
             !From this the variable normalized saturation specific
             !humidity qs_norm is calculated.
             !
             !  qs_norm = (qs(Tl) - qtmin)/(qtmax-qtmin)
             !
             !          = 0.5  - (qtbar - qs(Tl))/deltaQ
             !
             !Note that if qs_norm > 1., the grid box is fully clear.
             !If qs_norm < 0., the grid box is fully cloudy.
             qs_norm(:,:,k) = qtqsa4(2,:,:,k)+  &
                       pnorm*( (qtqsa4(3,:,:,k)-qtqsa4(2,:,:,k)) + &
                       qtqsa4(4,:,:,k)*(1-pnorm) )
             qs_norm(:,:,k) = 0.5 - ( qs_norm(:,:,k)/deltaQ(:,:,k) )
             
             do j=1, size(qa_stoch,2)
             do i=1, size(qa_stoch,1)             
             do n=1,nCol
       
                  if (qs_norm(i,j,k).lt.1.) then
                      tmpr =           aThermo(i,j,k  ) * &
                                        deltaQ(i,j,k  ) * &
                               (beta_deviate(pdfRank(i,j,k,n   ), &
                                          p = betaP, q = betaP) - &
                                       qs_norm(i,j,k) )
                      if (tmpr.gt.qcmin) then                 
                          qctmp(i, j, n) = qctmp(i, j, n) + tmpr
                          qatmp(i, j, n) = qatmp(i, j, n) + 1.
                      end if           
                  end if
                  
             enddo !for nCol
             enddo !for i
             enddo !for j
             
        enddo !for ns (nsublevels)
         
        !produce vertical average qc
        do j=1, size(qa_stoch,2)
        do i=1, size(qa_stoch,1)
        do n=1, nCol
            
             qctmp(i,j,n) = qctmp(i,j,n) / real (nsublevels)
             qa_stoch(i,j,k,n) = qatmp(i,j,n) / real (nsublevels)
             if (qctmp(i,j,n).le.qcmin) then
                  cld_thickness(i,j,k,n) = 0.
                  qa_stoch(i,j,k,n) = 0.
                  qc_stoch(i,j,k,n) = 0.
                  ql_stoch(i,j,k,n) = 0.
                  qi_stoch(i,j,k,n) = 0.
             else
                  qc_stoch(i,j,k,n) = qctmp(i,j,n)             
                  cld_thickness(i,j,k,n) = 1.
                  !qa_stoch(i,j,k,n) = 1.          
       
                  ! 
                  ! The proportion of ice and water in each 
                  ! sample is the same as the mean proportion.  
                  !
                  ql_stoch(i,j,k,n   ) = qc_stoch(i,j,k,n)* &
                                        qlqcRatio(i,j,k)
                  qi_stoch(i,j,k,n   ) = qc_stoch(i,j,k,n)* &
                                     (1.-qlqcRatio(i,j,k))
             end if !for column containing cloud
             
        enddo !for nCol
        enddo !for i
        enddo !for j 
        
    end do !for k (vertical loop)
           
  end if  ! for do_pdf_clouds


  ! Create qn_stoch - the stochastic cloud droplet number
  ! 
  do n=1,nCol
  do k=1,nLev
  do j=1, size(qa_stoch,2)
  do i=1, size(qa_stoch,1)
    if (ql_stoch(i,j,k,n)>qcmin .and. qa_stoch(i,j,k,n)>qcmin) then
      qn_stoch(i,j,k,n) = qa_stoch(i,j,k,n)* &
                          max(0.,qn(i,j,k)/max(qcmin,qa(i,j,k)))
      !note that qa is compared to qcmin to minimize the impact of the
      !limiters on calculating the in-cloud cloud droplet number
    else
      qn_stoch(i,j,k,n) = 0.                           
    endif
  end do
  end do
  end do
  end do

end subroutine generate_stochastic_clouds

  ! ---------------------------------------------------------
  !  Function to return the weighting between maximum and random overlap 
  !    given the pressure difference 
  ! 
  !  Note pPlus is the pressure at a higher altitude
  !  (i.e. pPlus < pMinus)
  ! ---------------------------------------------------------
function compute_overlap_weighting(qaPlus, qaMinus, pPlus, pMinus) result(weighting)
  real, dimension(:, :), intent( in) :: qaPlus, qaMinus, pPlus, pMinus
  real, dimension(size(pPlus, 1), &
                  size(pPlus, 2))    :: weighting
        
  select case(defaultOverlap)
    case(1) ! Maximum overlap
      weighting(:, :) = 1.
    case(2) ! Random overlap
      weighting(:, :) = 0.
    case(3) ! Maximum-random
      where(qaPlus(:, :) > qamin) 
        weighting(:, :) = 1.
      elsewhere
        weighting(:, :) = 0.
      end where
    case(4)
      !
      ! Overlap is weighted between max and random with parameter overlapWeighting (0 = random, 
      !    1 = max), which decreases exponentially with the separation distance. 
      !
      weighting(:, :) = exp(-abs(log(pMinus(:, :)) - log(pPlus(:, :))) * &
                              pressureScaleHeight / overlapLengthScale)
    case default 
      call error_mesg("cloud_generator_mod", "unknown overlap parameter", FATAL)
    end select
      
end function compute_overlap_weighting

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PRIVATE SUBROUTINES
!  These generate cloud samples according to specific overlap rules.  
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine computeThermodynamics(temperature, pressure, ql, qi, aThermo, qs)
    real, dimension(:, :, :), intent( in) :: temperature, pressure, ql, qi
    real, dimension(:, :, :), intent(out) :: aThermo
    real, dimension(:, :, :), optional, intent(out) :: qs
        
    real, parameter :: d608 = (rvgas - rdgas)/rdgas, &
                       d622 = rdgas/rvgas,           &
                       d378 = 1. - d622
    
    ! Compute saturation mixing ratio and gamma = 1/(1 + L/cp dqs/dT) evaluated
    !   at the ice water temperature
    ! Taken from strat_cloud_mod
    
    ! Local variables
    real, dimension(size(temperature, 1), &
                    size(temperature, 2), &
                    size(temperature, 3)) :: Tl, L, dqsdT,qsloc
    
    !
    ! Ice water temperature - ql and qi are grid cell means
    !
    Tl(:, :, :) =  temperature(:, :, :) -       &
                   (hlv/cp_air) * ql(:, :, :) - &
                   (hls/cp_air) * qi(:, :, :)
  
    !calculate qs and dqsdT
    call compute_qs (Tl, pressure,  qsloc, dqsdT = dqsdT)
    if (present(qs)) then
       qs = qsloc
    endif
 
    ! Latent heat of phase change, varying from that of water to ice with temperature.
    ! 
    L(:, :, :) = (min(1., max(0., 0.05*(temperature(:, :, :) - tfreeze + 20.)))*hlv + &
                  min(1., max(0., 0.05*(tfreeze - temperature(:, :, :)      )))*hls)
    aThermo(:, :, :) = 1./ (1. + L(:, :, :)/cp_air * dqsdT(:, :, :)) 
    
  end subroutine computeThermodynamics
  ! ---------------------------------------------------------
  ! Random overlap - the value is chosen randomly from the distribution at 
  !   every height. 
  ! ---------------------------------------------------------
  function genRandomOverlapSamples_1D(cloudFraction, nSamples, stream) &
           result(randomValues)
    real,    dimension(:),    intent(in   ) :: cloudFraction
    integer,                  intent(in   ) :: nSamples
    type(randomNumberStream), intent(inout) :: stream
    real,    dimension(size(cloudFraction), nSamples) &
                                            :: randomValues
    ! -------------------
    call getRandomNumbers(stream, randomValues)
  end  function genRandomOverlapSamples_1D
  ! ---------------------------------------------------------
  function genRandomOverlapSamples_3D(cloudFraction, nSamples, stream) &
           result(randomValues)
    real,    dimension(:, :, :),    intent(in   ) :: cloudFraction
    integer,                        intent(in   ) :: nSamples
    type(randomNumberStream), &
             dimension(:, :),       intent(inout) :: stream
    real,    dimension(size(cloudFraction, 1), &
                       size(cloudFraction, 2), &
                       size(cloudFraction, 3), &
                       nSamples)                  :: randomValues
    ! Local variables
    integer :: i, j
    ! -------------------
    do j = 1, size(cloudFraction, 2)
      do i = 1, size(cloudFraction, 1)
        call getRandomNumbers(stream(i, j), randomValues(i, j, :, :))
      end do
    end do
  end  function genRandomOverlapSamples_3D
  ! ---------------------------------------------------------

  ! ---------------------------------------------------------
  ! Maximum overlap - the position in the PDF is the same 
  !   at every height in a given column (though it varies from 
  !   column to column). 
  ! ---------------------------------------------------------

  function genMaximumOverlapSamples_1D(cloudFraction, nSamples, stream) &
           result(randomValues)
    real,    dimension(:),    intent(in   ) :: cloudFraction
    integer,                  intent(in   ) :: nSamples
    type(randomNumberStream), intent(inout) :: stream
    real,     dimension(size(cloudFraction), nSamples) &
                                            :: randomValues
    
    
    ! -------------------
    call getRandomNumbers(stream, randomValues(1, :))
    randomValues(:, :)  = spread(randomValues(1, :), &
                                 dim = 1, nCopies = size(cloudFraction))
  end  function genMaximumOverlapSamples_1D
  ! ---------------------------------------------------------
  function genMaximumOverlapSamples_3D(cloudFraction, nSamples, stream) &
           result(randomValues)
    real,    dimension(:, :, :),    intent(in   ) :: cloudFraction
    integer,                        intent(in   ) :: nSamples
    type(randomNumberStream), &
             dimension(:, :),       intent(inout) :: stream
    real,    dimension(size(cloudFraction, 1), &
                       size(cloudFraction, 2), &
                       size(cloudFraction, 3), &
                       nSamples)                  :: randomValues
    ! -------------------
    ! Local variables
    integer :: i, j, nX, nY, nLev
    ! -------------------
    nX   = size(cloudFraction, 1); nY  = size(cloudFraction, 2)
    nLev = size(cloudFraction, 3)
    
    do j = 1, nY
      do i = 1, nX
        call getRandomNumbers(stream(i, j), randomValues(i, j, 1, :))
      end do
    end do 
    randomValues(:, :, :, :)  = spread(randomValues(:, :, 1, :), dim = 3, nCopies = nLev)

  end  function genMaximumOverlapSamples_3D
  ! ---------------------------------------------------------
  
  ! ---------------------------------------------------------
  ! Meximum-random overlap. 
  ! Within each column, the value in the top layer is chosen 
  !   at random. We then walk down one layer at a time. If the layer above is cloudy
  !   we use the same random deviate in this layer; otherwise
  !   we choose a new value. 
  ! ---------------------------------------------------------
  
  function genMaxRanOverlapSamples_1D(cloudFraction, nSamples, stream) &
           result(randomValues)
    real,    dimension(:),    intent(in   ) :: cloudFraction
    integer,                  intent(in   ) :: nSamples
    type(randomNumberStream), intent(inout) :: stream
    real,    dimension(size(cloudFraction), nSamples) &
                                            :: randomValues
    ! Local variables
    integer                                 :: level
    
    ! -------------------
    call getRandomNumbers(stream, randomValues)
    do level = 2, size(cloudFraction)
      where(randomValues(:, level - 1) > 1. - cloudFraction(level - 1))
        randomValues(level, :) = randomValues(level - 1, :)
      elsewhere
        randomValues(level, :) = randomValues(level, :) * (1. - cloudFraction(level - 1))
      end where
    end do
  end  function genMaxRanOverlapSamples_1D
  ! ---------------------------------------------------------
  function genMaxRanOverlapSamples_3D(cloudFraction, nSamples, stream) &
           result(randomValues)
    real,    dimension(:, :, :),    intent(in   ) :: cloudFraction
    integer,                        intent(in   ) :: nSamples
    type(randomNumberStream), &
             dimension(:, :),       intent(inout) :: stream
    real,    dimension(size(cloudFraction, 1), &
                       size(cloudFraction, 2), &
                       size(cloudFraction, 3), &
                       nSamples)                  :: randomValues
    ! -------------------
    ! Local variables
    integer :: i, j, level, nX, nY, nLev
    ! -------------------
    nX   = size(cloudFraction, 1); nY  = size(cloudFraction, 2)
    nLev = size(cloudFraction, 3)
    
    do j = 1, nY
      do i = 1, nX
        call getRandomNumbers(stream(i, j), randomValues(i, j, :, :))
      end do
    end do 
              
    do level = 2, nLev
      where(randomValues(:, :, level - 1, :) > &
            spread(1. - cloudFraction(:, :, level - 1), dim = 3, nCopies = nSamples))
        randomValues(:, :, level, :) = randomValues(:, :, level - 1, :)
      elsewhere
        randomValues(:, :, level, :) = randomValues(:, :, level, :) * &
                                       spread(1. - cloudFraction(:, :, level - 1), &
                                              dim = 3, nCopies = nSamples)
      end where
    end do
  end  function genMaxRanOverlapSamples_3D
  ! ---------------------------------------------------------
  
  ! Neighbor to neighbor rank correlation, which gives exponential dependence 
  !   of rank correlation if the correlation is fixed. The correlation coefficient 
  !   is the array alpha. 
  ! Two streams of random numbers are generated. The first corresponds to the postion in 
  !   the PDF, and the second is used to enforce the correlation . If the value of 
  !   the second stream at one level in one column is less than alpha at that level, 
  !   the same relative position in the PDF is chosen in the lower layer as the upper.  
  ! ---------------------------------------------------------
  function genWeightedOverlapSamples_1D(cloudFraction, alpha, nSamples, stream) &
           result(randomValues)
    real,    dimension(:),    intent(in   ) :: cloudFraction, alpha
    integer,                  intent(in   ) :: nSamples
    type(randomNumberStream), intent(inout) :: stream
    real,    dimension(size(cloudFraction), nSamples) &
                                            :: randomValues
    
    ! Local variables
    real, dimension(size(cloudFraction), nSamples) :: randomValues2
    integer                                        :: level
    
    ! -------------------
    call getRandomNumbers(stream, randomValues)
    call getRandomNumbers(stream, randomValues2)
    
    do level = 1, size(cloudFraction) - 1 
      where(randomValues2(level + 1, :) < alpha(level)) &
        randomValues(level + 1, :) = randomValues(level, :)
    end do   
  end  function genWeightedOverlapSamples_1D
  ! ---------------------------------------------------------
  function genWeightedOverlapSamples_3D(cloudFraction, alpha, nSamples, stream) &
           result(randomValues)
    real,    dimension(:, :, :), intent(in   ) :: cloudFraction, alpha
    integer,                     intent(in   ) :: nSamples
    type(randomNumberStream), &
             dimension(:, :),    intent(inout) :: stream
    real,    dimension(size(cloudFraction, 1), &
                       size(cloudFraction, 2), &
                       size(cloudFraction, 3), &
                       nSamples)               :: randomValues
     
    ! Local variables
    real, dimension(size(cloudFraction, 1), &
                    size(cloudFraction, 2), &
                    size(cloudFraction, 3), &
                                  nSamples) :: randomValues2
    integer                                 :: i, j, nX, nY, nLev, level
    
    ! -------------------
    nX   = size(cloudFraction, 1); nY  = size(cloudFraction, 2)
    nLev = size(cloudFraction, 3)
    
    do j = 1, nY
      do i = 1, nX
        call getRandomNumbers(stream(i, j), randomValues (i, j, :, :))
      end do
    end do 
    do j = 1, nY
      do i = 1, nX
        call getRandomNumbers(stream(i, j), randomValues2(i, j, :, :))
      end do
    end do 
     
    do level = 1, nLev - 1
      where(randomValues2(:, :, level + 1, :) < spread(alpha(:, :, level),           &
                                                       dim = 3, nCopies = nSamples)) &
        randomValues(:, :, level + 1, :) = randomValues(:, :, level, :)
    end do
  end  function genWeightedOverlapSamples_3D
  ! ---------------------------------------------------------

  subroutine cloud_generator_end       
  !----------------------------------------------------------------------
  !    cloud_generator_end is the destructor for cloud_generator_mod.
  !----------------------------------------------------------------------
          
  !---------------------------------------------------------------------
  !    be sure module has been initialized.
  !---------------------------------------------------------------------
        if (.not. module_is_initialized ) then
          call error_mesg ('cloud_generator_mod',   &
               'module has not been initialized', FATAL )
        endif
        
        if(do_inhomogeneous_clouds .or. do_pdf_clouds) &
             call beta_dist_end
  !---------------------------------------------------------------------
  !    mark the module as not initialized.
  !---------------------------------------------------------------------
        module_is_initialized = .false.
  end subroutine cloud_generator_end
  !--------------------------------------------------------------------

  !--------------------------------------------------------------------
  !
  !  Function to report if the cloud generator is being used. 
  !
  function do_cloud_generator()
    logical :: do_cloud_generator
    
    do_cloud_generator = cloud_generator_on
  end function do_cloud_generator
  !--------------------------------------------------------------------

!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  ppm2m_sak --- Piecewise parabolic method for fields
!
! !INTERFACE:
 subroutine ppm2m_sak(a4, delp, km, kmap, i1, i2, iv, kord)

 implicit none

! !INPUT PARAMETERS:
 integer, intent(in):: iv      ! iv =-1: winds
                               ! iv = 0: positive definite scalars
                               ! iv = 1: others
 integer, intent(in):: i1      ! Starting longitude
 integer, intent(in):: i2      ! Finishing longitude
 integer, intent(in):: km      ! vertical dimension
 integer, intent(in):: kmap    ! partial remap to start
 integer, intent(in):: kord    ! Order (or more accurately method no.):
                               ! 
 real, intent(in):: delp(i1:i2,km)     ! layer pressure thickness

! !INPUT/OUTPUT PARAMETERS:
 real, intent(inout):: a4(4,i1:i2,km)  ! Interpolated values

! !DESCRIPTION:
!
!   Perform the piecewise parabolic method 
! 
! !REVISION HISTORY: 
!   ??.??.??    Lin        Creation
!   02.04.04    Sawyer     Newest release from FVGCM
! 
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
! local arrays:
      real   dc(i1:i2,km)
      real   h2(i1:i2,km)
      real delq(i1:i2,km)
      real  df2(i1:i2,km)
      real   d4(i1:i2,km)

! local scalars:
      integer i, k, km1, lmt
      integer it
      real fac
      real a1, a2, c1, c2, c3, d1, d2
      real qmax, qmin, cmax, cmin
      real qm, dq, tmp
      real qmp, pmp
      real lac

      km1 = km - 1
       it = i2 - i1 + 1

      do k=max(2,kmap-2),km
         do i=i1,i2
            delq(i,k-1) =   a4(1,i,k) - a4(1,i,k-1)
              d4(i,k  ) = delp(i,k-1) + delp(i,k)
         enddo
      enddo
 
      do k=max(2,kmap-2),km1
         do i=i1,i2
            c1  = (delp(i,k-1)+0.5*delp(i,k))/d4(i,k+1)
            c2  = (delp(i,k+1)+0.5*delp(i,k))/d4(i,k)
            tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) /      &
                                    (d4(i,k)+delp(i,k+1))
            qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k)
            qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))
             dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp)
            df2(i,k) = tmp
         enddo
      enddo

!-----------------------------------------------------------
! 4th order interpolation of the provisional cell edge value
!-----------------------------------------------------------

      do k=max(3,kmap), km1
      do i=i1,i2
        c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k)
        a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1))
        a2 = d4(i,k+1) / (d4(i,k) + delp(i,k))
        a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(d4(i,k-1)+d4(i,k+1)) *    &
                  ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) -          &
                                delp(i,k-1)*a1*dc(i,k  ) )
      enddo
      enddo

      if(km>8 .and. kord>3) call steepz_sak(i1, i2, km, kmap, a4, df2, dc, delq, delp, d4)

! Area preserving cubic with 2nd deriv. = 0 at the boundaries
! Top
      if ( kmap <= 2 ) then
      do i=i1,i2
         d1 = delp(i,1)
         d2 = delp(i,2)
         qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2)
         dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2)
         c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) )
         c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2)
         a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
         a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2)
         dc(i,1) =  a4(1,i,1) - a4(2,i,1)
! No over- and undershoot condition
         cmax = max(a4(1,i,1), a4(1,i,2))
         cmin = min(a4(1,i,1), a4(1,i,2))
         a4(2,i,2) = max(cmin,a4(2,i,2))
         a4(2,i,2) = min(cmax,a4(2,i,2))
      enddo
      endif

! Bottom
! Area preserving cubic with 2nd deriv. = 0 at the surface
      do i=i1,i2
         d1 = delp(i,km)
         d2 = delp(i,km1)
         qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2)
         dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2)
         c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1)))
         c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2)
         a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1)
         a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km)
         dc(i,km) = a4(3,i,km) -  a4(1,i,km)
! No over- and under-shoot condition
         cmax = max(a4(1,i,km), a4(1,i,km1))
         cmin = min(a4(1,i,km), a4(1,i,km1))
         a4(2,i,km) = max(cmin,a4(2,i,km))
         a4(2,i,km) = min(cmax,a4(2,i,km))
      enddo

      do k=max(1,kmap),km1
         do i=i1,i2
            a4(3,i,k) = a4(2,i,k+1)
         enddo
      enddo

! Enforce monotonicity of the "slope" within the top layer
      if ( kmap <= 2 ) then
      do i=i1,i2
         if ( a4(2,i,1) * a4(1,i,1) <= 0. ) then 
              a4(2,i,1) = 0.
                dc(i,1) = a4(1,i,1)
         endif
         if ( dc(i,1) * (a4(2,i,2) - a4(1,i,1)) <= 0. ) then
! Setting DC==0 will force piecewise constant distribution after
! calling kmppm_sak
              dc(i,1) = 0.
         endif
      enddo
      endif

! Enforce constraint on the "slope" at the surface

      do i=i1,i2
         if( a4(3,i,km) * a4(1,i,km) <= 0. ) then
!            a4(3,i,km) = 0.
!              dc(i,km) =  -a4(1,i,km)
               dc(i,km) = 0.
         endif
         if( dc(i,km) * (a4(1,i,km) - a4(2,i,km)) <= 0. ) then
             dc(i,km) = 0.
         endif
      enddo
 
!-----------------------------------------------------------
! f(s) = AL + s*[(AR-AL) + A6*(1-s)]         ( 0 <= s  <= 1 )
!-----------------------------------------------------------
! Top 2 and bottom 2 layers always use monotonic mapping
      if ( kmap <= 2 ) then
      do k=1,2
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
            call kmppm_sak(dc(i1,k), a4(1,i1,k), it, 0)
      enddo
      endif

      if(kord >= 7) then
!-----------------------
! Huynh's 2nd constraint
!-----------------------
      do k=max(2,kmap-1), km1
         do i=i1,i2
! Method#1
!           h2(i,k) = delq(i,k) - delq(i,k-1)
! Method#2
!           h2(i,k) = 2.*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1))
!    &               / ( delp(i,k)+0.5*(delp(i,k-1)+delp(i,k+1)) )
!    &               * delp(i,k)**2
! Method#3
            h2(i,k) = dc(i,k+1) - dc(i,k-1)
         enddo
      enddo

      if( kord == 7 ) then
         fac = 1.5           ! original quasi-monotone
      else
         fac = 0.125         ! full monotone
      endif

      do k=max(3,kmap), km-2
        do i=i1,i2
! Right edges
!        qmp   = a4(1,i,k) + 2.0*delq(i,k-1)
!        lac   = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
!
         pmp   = 2.*dc(i,k)
         qmp   = a4(1,i,k) + pmp
         lac   = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k)
         qmin  = min(a4(1,i,k), qmp, lac)
         qmax  = max(a4(1,i,k), qmp, lac)
         a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax)
! Left  edges
!        qmp   = a4(1,i,k) - 2.0*delq(i,k)
!        lac   = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
!
         qmp   = a4(1,i,k) - pmp
         lac   = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k)
         qmin  = min(a4(1,i,k), qmp, lac)
         qmax  = max(a4(1,i,k), qmp, lac)
         a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax)
! Recompute A6
         a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
        enddo
! Additional constraint to ensure positivity when kord=7
         if (iv == 0 .and. kord == 7) then
             call kmppm_sak(dc(i1,k), a4(1,i1,k), it, 2)
         endif
      enddo

      else
 
         lmt = kord - 3
         lmt = max(0, lmt)
         if (iv == 0) lmt = min(2, lmt)

      do k=max(3,kmap), km-2
      if( kord /= 4) then
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
      endif
         call kmppm_sak(dc(i1,k), a4(1,i1,k), it, lmt)
      enddo
      endif

      do k=km1,km
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
         call kmppm_sak(dc(i1,k), a4(1,i1,k), it, 0)
      enddo
!EOC
 end subroutine ppm2m_sak
!-----------------------------------------------------------------------

!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  kmppm_sak --- Perform piecewise parabolic method in vertical
!
! !INTERFACE:
 subroutine kmppm_sak(dm, a4, itot, lmt)

 implicit none

! !INPUT PARAMETERS:
      real, intent(in):: dm(*)     ! the linear slope
      integer, intent(in) :: itot      ! Total Longitudes
      integer, intent(in) :: lmt       ! 0: Standard PPM constraint
                                       ! 1: Improved full monotonicity constraint (Lin)
                                       ! 2: Positive definite constraint
                                       ! 3: do nothing (return immediately)
! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout) :: a4(4,*)   ! PPM array
                                           ! AA <-- a4(1,i)
                                           ! AL <-- a4(2,i)
                                           ! AR <-- a4(3,i)
                                           ! A6 <-- a4(4,i)

! !DESCRIPTION:
!
! !REVISION HISTORY: 
!    00.04.24   Lin       Last modification
!    01.03.26   Sawyer    Added ProTeX documentation
!    02.04.04   Sawyer    Incorporated newest FVGCM version
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:

      real, parameter:: r12 = 1./12.
      real qmp
      real da1, da2, a6da
      real fmin
      integer i

! Developer: S.-J. Lin, NASA-GSFC
! Last modified: Apr 24, 2000

      if ( lmt == 3 ) return

      if(lmt == 0) then
! Standard PPM constraint
      do i=1,itot
      if(dm(i) == 0.) then
         a4(2,i) = a4(1,i)
         a4(3,i) = a4(1,i)
         a4(4,i) = 0.
      else
         da1  = a4(3,i) - a4(2,i)
         da2  = da1**2
         a6da = a4(4,i)*da1
         if(a6da < -da2) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         elseif(a6da > da2) then
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
      endif
      enddo

      elseif (lmt == 1) then

! Improved full monotonicity constraint (Lin 2003)
! Note: no need to provide first guess of A6 <-- a4(4,i)
      do i=1, itot
           qmp = 2.*dm(i)
         a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp)
         a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp)
         a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) )
      enddo

      elseif (lmt == 2) then

! Positive definite constraint
      do i=1,itot
      if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then
      fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12
         if( fmin < 0. ) then
         if(a4(1,i)<a4(3,i) .and. a4(1,i)<a4(2,i)) then
            a4(3,i) = a4(1,i)
            a4(2,i) = a4(1,i)
            a4(4,i) = 0.
         elseif(a4(3,i) > a4(2,i)) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         else
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
         endif
      endif
      enddo

      endif

!EOC
 end subroutine kmppm_sak
!-----------------------------------------------------------------------

!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  steepz_sak --- Calculate attributes for PPM
!
! !INTERFACE:
 subroutine steepz_sak(i1, i2, km, kmap, a4, df2, dm, dq, dp, d4)

   implicit none

! !INPUT PARAMETERS:
      integer, intent(in) :: km                   ! Total levels
      integer, intent(in) :: kmap                 ! 
      integer, intent(in) :: i1                   ! Starting longitude
      integer, intent(in) :: i2                   ! Finishing longitude
      real, intent(in) ::  dp(i1:i2,km)       ! grid size
      real, intent(in) ::  dq(i1:i2,km)       ! backward diff of q
      real, intent(in) ::  d4(i1:i2,km)       ! backward sum:  dp(k)+ dp(k-1) 
      real, intent(in) :: df2(i1:i2,km)       ! first guess mismatch
      real, intent(in) ::  dm(i1:i2,km)       ! monotonic mismatch

! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout) ::  a4(4,i1:i2,km)  ! first guess/steepened

!
! !DESCRIPTION:
!   This is complicated stuff related to the Piecewise Parabolic Method
!   and I need to read the Collela/Woodward paper before documenting
!   thoroughly.
!
! !REVISION HISTORY: 
!   ??.??.??    Lin?       Creation
!   01.03.26    Sawyer     Added ProTeX documentation
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      integer i, k
      real alfa(i1:i2,km)
      real    f(i1:i2,km)
      real  rat(i1:i2,km)
      real  dg2

! Compute ratio of dq/dp
      do k=max(2,kmap-1),km
         do i=i1,i2
            rat(i,k) = dq(i,k-1) / d4(i,k)
         enddo
      enddo

! Compute F
      do k=max(2,kmap-1),km-1
         do i=i1,i2
            f(i,k) =   (rat(i,k+1) - rat(i,k))                          &
                     / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) )
         enddo
      enddo

      do k=max(3,kmap),km-2
         do i=i1,i2
         if(f(i,k+1)*f(i,k-1)<0. .and. df2(i,k)/=0.) then
            dg2 = (f(i,k+1)-f(i,k-1))*((dp(i,k+1)-dp(i,k-1))**2          &
                   + d4(i,k)*d4(i,k+1) )
            alfa(i,k) = max(0., min(0.5, -0.1875*dg2/df2(i,k))) 
         else
            alfa(i,k) = 0.
         endif
         enddo
      enddo

      do k=max(4,kmap+1),km-2
         do i=i1,i2
            a4(2,i,k) = (1.-alfa(i,k-1)-alfa(i,k)) * a4(2,i,k) +         &
                        alfa(i,k-1)*(a4(1,i,k)-dm(i,k))    +             &
                        alfa(i,k)*(a4(1,i,k-1)+dm(i,k-1))
         enddo
      enddo

!EOC
 end subroutine steepz_sak
!----------------------------------------------------------------------- 

end module cloud_generator_mod



                    module cloud_obs_mod

!-----------------------------------------------------------------------
!
!           sets up observed (climatological) clouds
!
!-----------------------------------------------------------------------

use horiz_interp_mod, only: horiz_interp_type, horiz_interp_init, &
                            horiz_interp_new, horiz_interp, horiz_interp_del
use          mpp_mod, only: input_nml_file
use          fms_mod, only: file_exist, error_mesg, FATAL, NOTE,     &
                            open_namelist_file, close_file,          &
                            check_nml_error, mpp_pe, mpp_root_pe,    &
                            write_version_number, stdlog, open_ieee32_file
use fms_io_mod,       only: read_data
use time_manager_mod, only: time_type, get_date
use  time_interp_mod, only: time_interp

implicit none
private

!---------- public interfaces ----------

public  cloud_obs, cloud_obs_init, cloud_obs_end

!-----------------------------------------------------------------------
!   ---------- private data ------------

   character(len=128) :: version = '$Id: cloud_obs.F90,v 18.0.2.1 2010/08/30 20:33:31 wfc Exp $'
   character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

      real, allocatable, dimension(:,:,:) :: clda,cldb
      real, allocatable, dimension(:)     :: londat,latdat
   integer :: yrclda=-99,moclda=-99, yrcldb=-99,mocldb=-99
   logical :: module_is_initialized = .false.

!   ---------- namelist ---------------

   logical :: use_climo = .true.
   integer :: verbose = 0

   namelist /cloud_obs_nml/ use_climo, verbose


!------------ input grid parameters ----------
     integer, parameter :: mobs=144, nobs=72
        real :: sb, wb, dx, dy

     type (horiz_interp_type), save :: Interp   ! kerr
!-----------------------------------------------------------------------

contains

!#######################################################################

subroutine cloud_obs ( is, js, Time, cldamt )

!-----------------------------------------------------------------------
!    routine that reads monthly records of climatological
!    isccp cloud amount and then linearly interpolates between them
!-----------------------------------------------------------------------
!     input
!     -----
!     is, js   starting i,j indices (dimension(2))
!     Time     current time (time_type)
!
!     output
!     ------
!     cldamt    cloud amount data on horizontal grid,
!               dimensioned ix x jx x 3, for high,med, & low clouds.
!-----------------------------------------------------------------------
        integer, intent(in)                    :: is, js
type(time_type), intent(in)                    :: Time
           real, intent(out), dimension(:,:,:) :: cldamt
!-----------------------------------------------------------------------
      real, dimension(mobs,nobs,3) :: obs

   integer  day,month,year, second,minute,hour
   integer  month1,month2,mo,year1,year2,yr,unit,irec,n
   integer  ie,je,ix,jx,pe
      real  dmonth,dif
   logical,save :: useclimo1,useclimo2
   logical      :: unit_opened
   integer :: nrecords, tlvl
!-----------------------------------------------------------------------

   if ( .not. module_is_initialized)  &
                call error_mesg ('cloud_obs',  &
                         'cloud_obs_init has not been called.',FATAL)

   if (size(cldamt,3) < 3) call error_mesg ('cloud_obs',  &
                                'dimension 3 of cldamt is < 3', FATAL)

   pe = mpp_pe()

!------------ size & position of this window ---------------------------
      ix=size(cldamt,1); jx=size(cldamt,2)
      ie=is+ix-1;        je=js+jx-1

!  --- check existence of cloud data set --------

      if (.not.file_exist('INPUT/cloud_obs.data')) then
        call error_mesg ('observed_cloud',  &
                    'file INPUT/cloud_obs.data does not exist.', FATAL)
      endif

!-----------------------------------------------------------------------
! ---- time interpolation for months -----

      call time_interp (Time, dmonth, year1, year2, month1, month2)
      
! ---- force climatology ----

      if (use_climo) then
          year1 = 0; year2 = 0
      endif

!-----------------------------------------------------------------------
      ! This code works with the current 1 year (12 records) cloud_obs.data.nc
      ! converted from a one year 12 records native format input file.
      ! In the future, a multi-year, multi-month data series maybe introduced,
      ! we can easily modify the code to accommodate the change. As of now,
      ! since the native format data file does not contain any year information,
      ! we don't process year and just use month to get data.
      if(file_exist('INPUT/cloud_obs.data.nc')) then
         call get_date (Time, year, month, day, hour, minute, second)
         if(mpp_pe() == mpp_root_pe()) call error_mesg ('cloud_obs_mod',  &
              'Reading NetCDF formatted input file: INPUT/cloud_obs.data.nc', NOTE)
         call read_data('INPUT/cloud_obs.data.nc', 'nrecords', nrecords, no_domain=.true.)
         tlvl = month
         call read_data('INPUT/cloud_obs.data.nc', 'obs', obs, timelevel=tlvl, no_domain=.true.)
         do n=1,3
            call horiz_interp (Interp, obs(:,:,n), cldb(:,:,n), verbose=verbose)
         enddo
         goto 381
      end if
      
      unit_opened=.false.

!    assumption is being made that the record for (year1,month1)
!    precedes the record for (year2,month2)

      if (year1 .ne. yrclda .or. month1 .ne. moclda) then
         
          unit_opened=.true.
          unit = open_ieee32_file ( 'INPUT/cloud_obs.data', action='read' )
          irec=0
          do
!!!!               read (unit,end=380)  yr,mo,obs
             yr=0; read (unit,end=380)     mo,obs
             irec=irec+1
             dif=12*(year1-yr)+month1-mo
             if (dif == 0) then
                yrclda=yr
                moclda=mo
                useclimo1=.false.
                if (yr == 0) useclimo1=.true.
                exit
             endif
!           --- otherwise use climo ---
             if (yr == 0 .and. month1 == mo) then
                yrclda=yr
                moclda=mo
                useclimo1=.true.
                exit
             endif
          enddo
          do n=1,3
            call horiz_interp (Interp, obs(:,:,n), clda(:,:,n), verbose=verbose)
          enddo
      endif

      if (year2 .ne. yrcldb .or. month2 .ne. mocldb) then
          if (.not.unit_opened) then
             unit_opened=.true.
             unit = open_ieee32_file ( 'INPUT/cloud_obs.data', action='read' )
          endif
          if (useclimo1 .and. month2 <= month1 ) then
             if (verbose > 1 .and. pe == mpp_root_pe())  &
                       print *, ' rewinding INPUT/cloud_obs.data'
             rewind unit
          endif
          irec=0
          do
!!!!               read (unit,end=380)  yr,mo,obs
             yr=0; read (unit,end=380)     mo,obs
             irec=irec+1
             dif=12*(year2-yr)+month2-mo
             if (dif == 0) then
                yrcldb=yr
                mocldb=mo
                useclimo2=.false.
                if (yr == 0) useclimo2=.true.
                exit
             endif
!           --- climo ---
             if (yr == 0 .and. month2 == mo) then
                yrcldb=yr
                mocldb=mo
                useclimo2=.true.
                exit
             endif
          enddo
          do n=1,3
            call horiz_interp (Interp, obs(:,:,n), cldb(:,:,n), verbose=verbose)
          enddo
      endif
          goto 381

 380  if (pe == 0) print *, ' month1,month2=',month1,month2
      if (pe == 0) print *, ' useclimo1,useclimo2=',useclimo1,useclimo2
      call error_mesg ('observed_cloud',  &
                       'eof reading file=INPUT/cloud_obs.data', FATAL)

 381  continue

   if (unit_opened .or. file_exist('INPUT/cloud_obs.data.nc')) then
      if(unit_opened) call close_file (unit)
      if (verbose > 0 .and. pe == 0) then
         call get_date (Time, year, month, day, hour, minute, second)
         write (*,600) year,month,day, hour,minute,second
600      format (/,'from cloud_obs:',   &
              /,' date(y/m/d h:m:s) = ', &
              i4,2('/',i2.2),1x,2(i2.2,':'),i2.2)
         print *, ' dmonth=',dmonth
         print *, ' year1,month1, yrclda,moclda, useclimo1=',  &
              year1,month1, yrclda,moclda, useclimo1
         print *, ' year2,month2, yrcldb,mocldb, useclimo2=',  &
              year2,month2, yrcldb,mocldb, useclimo2
         print *, ' '
      endif
   endif

!------------ time interpolation ---------------------------------------

      do n=1,3
         cldamt(:,:,n)=clda(is:ie,js:je,n)+  &
                       dmonth*(cldb(is:ie,js:je,n)-clda(is:ie,js:je,n))
      enddo

!-----------------------------------------------------------------------

 end subroutine cloud_obs

!#######################################################################

 subroutine cloud_obs_init (lonb,latb)

!-----------------------------------------------------------------------
!  lonb  =   longitude in radians at the grid box corners
!  latb  =   longitude in radians at the grid box corners
!-----------------------------------------------------------------------
   real, intent(in), dimension(:,:) :: lonb,latb
!-----------------------------------------------------------------------
   real    :: hpie
   integer :: i, j, in, jn, unit, ierr, io, logunit
   real :: lonb_obs(mobs+1), latb_obs(nobs+1)

   if (module_is_initialized) return

!------- read namelist --------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cloud_obs_nml, iostat=io)
      ierr = check_nml_error(io,"cloud_obs_nml")
#else
      if (file_exist('input.nml')) then
          unit = open_namelist_file ()
          ierr=1; do while (ierr /= 0)
             read  (unit, nml=cloud_obs_nml, iostat=io, end=10)
             ierr = check_nml_error(io,'cloud_obs_nml')
          enddo
  10      call close_file (unit)
      endif
#endif

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=cloud_obs_nml)
      endif

!------- setup for observed grid -------

      hpie=acos(0.0)
      sb=-hpie; wb=0.0; dx=4.0*hpie/float(mobs); dy=2.0*hpie/float(nobs)

      do i = 1, mobs
         lonb_obs(i) = wb + float(i-1)*dx
      enddo
         lonb_obs(mobs+1) = lonb_obs(1) + 4.0*hpie
      do j = 2, nobs
         latb_obs(i) = wb + float(i-1)*dx
      enddo
         latb_obs(1) = -hpie
         latb_obs(nobs+1) = hpie

      call horiz_interp_init
      call horiz_interp_new ( Interp, lonb_obs, latb_obs, lonb, latb )


!------- setup for data grid -------

      in=size(lonb,1); jn=size(latb,2)
      allocate (clda(in-1,jn-1,3), cldb(in-1,jn-1,3))

      module_is_initialized = .true.

!-----------------------------------------------------------------------

 end subroutine cloud_obs_init

!#######################################################################

 subroutine cloud_obs_end
 
      module_is_initialized = .false.

!-----------------------------------------------------------------------

 end subroutine cloud_obs_end

!#######################################################################

end module cloud_obs_mod



!FDOC_TAG_GFDL


                 module cloud_rad_mod
! <CONTACT EMAIL="Stephen.Klein@noaa.gov">
!   Steve Klein
! </CONTACT>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!        The cloud radiation module uses the stored values of the
!     prognostic cloud variables, and computes the cloud albedo and
!     absorption for the two shortwave bands (ultra-violet/visible and
!     near-infrared), the longwave cloud emissivity, and the 
!     fractional areas covered by clouds.
! </OVERVIEW>
! <DESCRIPTION>
!      The cloud radiation module condenses the cloud information 
!     provided by the stratiform cloud scheme and converts it into
!     the areas covered by, the water paths and the effective particle 
!     sizes of liquid and ice. This cloud information is stored into 
!     cloud blocks which are assumed to be randomly overlapped (done 
!     in CLOUD_ORGANIZE subroutine). From these, the single-scattering 
!     albedo, asymmetry parameter, and optical depth for the two short 
!     wave bands and the longwave cloud emissivity for each cloud are 
!     calculated in the subroutine CLOUD_OPTICAL_PROPERTIES. Finally, 
!     the subroutine CLOUD_RAD takes the shortwave cloud properties 
!     and converts them using the Delta-Eddington solution to albedo 
!     and absorption in each of the shortwave bands.
!
!     In CLOUD_OPTICAL_PROPERTIES, the parameterization of Slingo (1989)
!     and Ebert and Curry (1992) are used for the shortwave properties of 
!     liquid and ice clouds, respectively.  For the longwave cloud 
!     emissivity, the empirical observation result of Stephens (1978) is
!     used for liquid clouds whereas the parameterization of Ebert and
!     Curry (1992) is used for ice clouds.
!
!     In CLOUD_ORGANIZE, the effective radius for liquid clouds is 
!     calculated using the parameterization of Martin et al. (1994)
!     whereas the effective radius of ice clouds is parameterized using
!     that of Donner et al. (1997).
!
!  
! </DESCRIPTION>
!

!  <DIAGFIELDS>
!  ************************Note***********************
!   This part of the documentation needs to be updated
!  ***************************************************
!
!  Diagnostic fields may be output to a netcdf file by specifying the
!  module name cloud_rad and the desired field names (given below)
!  in file diag_table. See the documentation for diag_manager.
!  
!  Diagnostic fields for module name: cloud_rad
!  
!     nisccp       frequency of sunlit times at the times of the radiation
!                  calculation at each point {fraction} [real,dimension(:,:)]
!  
!     pc#tau%      where # is a number from 1 to 7
!                  and   % is a number from 1 to 7
!                  {fraction} [real,dimension(:,:)]
!  
!                  Thus there are 49 diagnostic fields of this type.  All
!                  of them are necessary to receive the complete decomposition
!                  of clouds visible from space into the ISCCP categories.
!  
!                  The 7 cloud top pressure ("pc") categories and 7 optical
!                  depth ("tau") categories are defined as:
!  
!                  pc #      pc range (mb)    tau %        tau range
!                  ----    ----------------   -----    ---------------------
!  
!                   1              pc < 180     1     0.0    < tau < taumin 
!                   2        180 < pc < 310     2     taumin < tau < 1.3
!                   3        310 < pc < 440     3     1.3    < tau < 3.6
!                   4        440 < pc < 560     4     3.6    < tau < 9.4
!                   5        560 < pc < 680     5     9.4    < tau < 23
!                   6        680 < pc < 800     6     23     < tau < 60
!                   7        800 < pc                 60     < tau
!  
!                  What is saved in these diagnostics is the time mean of
!                  the area covered by clouds of this type when the sun is
!                  above the horizon. This is done so that the calculation 
!                  will mimic the ISCCP product which is broken down into 
!                  these categories only for sunlit places.
!  
!                  NOTE:  TO DETERMINE THE MEAN AREA COVERED BY A CLOUD TYPE 
!                         WHEN THE SUN IS ABOVE THE HORIZON YOU MUST DIVIDE
!                         BY NISCCP:
!  
!                         area of cloud type pc#tau% =   pc#tau% / nisccp
!  
!     aice         fractional area of sunlit clouds seen from space whose cloud 
!                  top contains ice. {fraction} [real,dimension(:,:)]
!  
!     reffice      time mean ice effective radius of cloud tops visible from
!                  space including areas where there is no such cloud {microns} 
!                  [real,dimension(:,:)]
!  
!                  NOTE:  THUS THE TIME MEAN CLOUD TOP EFFECTIVE RADIUS OF CLOUD 
!                         TOPS WITH ICE VISIBLE FROM SPACE IS:
!  
!                         mean reffice  =    reffice /  aice
!        
!     aliq         fractional area of sunlit clouds seen from space whose cloud 
!                  top contains liquid. {fraction} [real,dimension(:,:)]
!  
!     reffliq      time mean cloud droplet effective radius of cloud tops 
!                  visible from space including areas where there is no such 
!                  cloud {microns} [real,dimension(:,:)]
!     
!                  NOTE:  mean reffliq  =    reffliq / aliq
!  
!     alow         fractional area of sunlit clouds seen from space whose cloud 
!                  tops are low (pc > 680 mb). {fraction} [real,dimension(:,:)]
!  
!     tauicelow    time mean optical depth of ice for cloud tops visible from 
!                  space including areas where there is no such cloud {microns} 
!                  [real,dimension(:,:)]
!    
!     tauliqlow    time mean optical depth of liquid for cloud tops visible from 
!                  space including areas where there is no such cloud {microns} 
!                  [real,dimension(:,:)]
!     
!     tlaylow      time mean of the low level mean temperature (pc > 680 mb) 
!                  when low cloud tops are visible from space including times 
!                  where there is no such cloud {microns} 
!                  [real,dimension(:,:)]
!        
!     tcldlow      time mean of the cloud top temperature for cloud tops visible 
!                  from space including times where there is no such cloud 
!                  {microns}  [real,dimension(:,:)]
!        
!                  NOTE:  mean tauicelow  =    tauicelow / alow
!                         mean tauliqlow  =    tauliqlow / alow
!                         mean tlaylow    =    tlaylow   / alow
!                         mean tcldlow    =    tcldlow   / alow
!  
! </DIAGFIELDS>
!  
!  
! <DATASET NAME="">
!
! </DATASET>
!  
!  
! <INFO>
!  
!   <REFERENCE>            
! The shortwave properties of liquid clouds come from:
! 
 !     Slingo, A., 1989: A GCM parameterization for the shortwave 
 !     radiative properties of water clouds. J. Atmos. Sci., vol. 46, 
 !     pp. 1419-1427.
!
!   </REFERENCE>

!   <REFERENCE>            
! The shortwave and longwave properties of ice clouds come from:
! 
 !     Ebert, E. E. and J. A. Curry, 1992: A parameterization of ice cloud
 !     optical properties for climate models. J. Geophys. Res., vol. 97,
 !     D1, pp. 3831-3836.
!
!   </REFERENCE>

!   <REFERENCE>            
! The longwave emissivity parameterization of liquid clouds comes from:
! 
 !     Stephens, G. L., 1978: Radiation profiles in extended water clouds.
 !     II: Parameterization schemes. J. Atmos. Sci., vol. 35, 
 !     pp. 2123-2132.
!
!   </REFERENCE>

!   <REFERENCE>            
! The parameterization of liquid cloud effective radius comes from:
! 
 !     Martin, G. M., D. W. Johnson, and A. Spice, 1994: The measurement 
 !     and parameterization of effective radius of droplets in warm stratocumulus
 !     clouds. J. Atmos. Sci, vol 51, pp. 1823-1842.
!
!   </REFERENCE>

!   <REFERENCE>            
! The parameterization of ice cloud effective radius comes from:
! 
 !     Donner, L. J., C. J. Seman, B. J. Soden, R. S. Hemler, J. C. Warren,
 !     J. Strom, and K.-N. Liou, 1997: Large-scale ice clouds in the GFDL
 !     SKYHI general circulation model. J. Geophys. Res., vol. 102, D18,
 !     pp. 21,745-21,768.
!
!   </REFERENCE>

!   <REFERENCE>            
! The algorithm to reproduce the ISCCP satellite view of clouds comes from:
! 
 !     Klein, S. A., and C. Jakob, 1999: Validation and sensitivities of 
 !     frontal clouds simulated by the ECMWF model. Monthly Weather Review,
 !     127(10),  2514-2531.
!
!   </REFERENCE>

!   <COMPILER NAME="">     </COMPILER>
!   <PRECOMP FLAG="">      </PRECOMP>
!   <LOADER FLAG="">       </LOADER>
!   <TESTPROGRAM NAME="">  </TESTPROGRAM>
!   <BUG>                  </BUG>
!   <NOTE> 
!     
!   </NOTE>
!   <FUTURE>The optical depth and particle size for every model level will
!     become a diagnostic output field.               </FUTURE>

! </INFO>

!   shared modules:

use  mpp_mod,             only:  input_nml_file
use  fms_mod,             only:  file_exist, fms_init,       &
                                 stdlog, mpp_pe, mpp_root_pe, &
                                 open_namelist_file, &
                                 write_version_number,  &
                                 error_mesg, FATAL,     &
                                 close_file,  &
                                 check_nml_error
use  constants_mod,       only:  RDGAS, GRAV, TFREEZE, DENS_H2O, &
                                 constants_init
use  diag_manager_mod,    only:  diag_manager_init,    &
                                 register_diag_field, send_data
use  time_manager_mod,    only:  time_type, time_manager_init

implicit none
private

!---------------------------------------------------------------------
!    cloud_rad_mod does the following:           
!     
!    (a)  subroutine cloud_summary3 returns cloud specification var-
!         iables that are used in calculating the cloud radiative prop-
!         erties. these include cloud locations, water paths and effect-
!         ive particle sizes for use in determining bulk properties and
!         concentrations and drop sizes if microphysically-based prop-
!         erties are desired.
!    (b)  subroutine lw_emissivity returns the long wave cloud emis-
!         sivity and subroutine sw_optical_properties returns the cloud 
!         reflectivities and absorptions in the nir and uv spectral
!         bands when using non-microphysically-based cloud radiative
!         properties.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!------------ version number for this module -------------------------
        
character(len=128) :: version = '$Id: cloud_rad.F90,v 17.0.6.1 2010/08/30 20:39:46 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------- 
!--------- interfaces --------

public     &
         cloud_rad_init, &
         cloud_rad_end, &
         cloud_summary, &
         lw_emissivity, &
         sw_optical_properties, &
         cloud_summary3, &
         cloud_rad_k_diag,  &
         cloud_rad

!---------------------------------------------------------------------
!    public subroutines:
!
!      cloud_rad_init
!                        Initializes values of qmin, N_land, and 
!                        N_ocean using values from strat_cloud namelist
!                        as well as reads its own namelist variables. 
!                        In addition, it registed diagnostic fields
!                        if needed, and returns the value of the
!                        cloud overlap to strat_cloud.
!      cloud_summary
!                        This is the main driver program of the module
!      cloud_rad   
!                        this solves for the radiative properties of the
!                        clouds given the cloud optical properties
!                        (tau,w0,gg) for each cloud using either a 
!                        Delta-Eddington solution (default) or the
!                        two stream approximation.
!      cloud_optical_properties
!                        for each cloud this calculates the mixed phase
!                        values of the optical depth, the single scat-
!                        tering albedo, and the asymmetry parameter 
!                        (tau, w0,and g) for the visible and near infra-
!                        red bands.  It also computes the longwave 
!                        emissivity of each cloud.
!
!----------------------------------------------------------------------

private     &
         max_rnd_overlap, rnd_overlap, cloud_rad_k
     
!---------------------------------------------------------------------
!    private subroutines:
!
!       max_rnd_overlap
!       rnd_overlap
!       cloud_rad_k
!      cloud_organize
!                        for each cloud this computes the cloud amount,
!                        the liquid and ice water paths, the effective
!                        particle sizes, the tops and bottoms of clouds.
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!-------- namelist  ---------

integer      :: overlap = 1
logical      :: l2strem = .false.
real         :: taucrit = 1.
logical      :: adjust_top = .true.
real         :: scale_factor = 0.85
real         :: qamin = 1.E-2
logical      :: do_brenguier = .true.
real         :: N_min = 1.e6

!--------------------------------------------------------------------
!    namelist variables:
!
!      overlap        integer variable indicating which overlap 
!                     assumption to use:
!                     overlap = 1. means condensate in adjacent levels 
!                                  is treated as part of the same cloud
!                                  i.e. maximum-random overlap
!                     overlap = 2. means condensate in adjacent levels 
!                                  is treated as different clouds
!                                  i.e. random overlap
!      l2strem        logical variable indicating which solution for 
!                     cloud radiative properties is being used.
!                     l2strem = T  2 stream solution
!                     l2strem = F  Delta-Eddington solution
!                     Note that IF l2strem = T then the solution does 
!                     not depend on solar zenith angle
!      taucrit        critical optical depth for switching direct beam 
!                     to diffuse beam for use in Delta-Eddington 
!                     solution [ dimensionless] 
!      adjust_top     logical variable indicating whether or not to use 
!                     the code which places the top and bottom of the 
!                     cloud at the faces which are most in view from
!                     the top and bottom of the cloud block. this is 
!                     done to avoid undue influence of very small cloud
!                     fractions. if true this adjustment of tops is 
!                     performed; if false this is not performed.
!      scale_factor   factor which multiplies actual cloud optical 
!                     depths to account for the plane-parallel homo-
!                     genous cloud bias  (e.g. Cahalan effect).
!                     [ dimensionless] 
!      qamin          minimum permissible cloud fraction 
!                     [ dimensionless] 
!      do_brenguier   should drops at top of stratocumulus clouds be
!                     scaled?
!
!----------------------------------------------------------------------

! <NAMELIST NAME="cloud_rad_nml">
!  <DATA NAME="overlap" UNITS="" TYPE="" DIM="" DEFAULT="">
!integer variable indicating which overlap 
!                     assumption to use:
!                     overlap = 1. means condensate in adjacent levels 
!                                  is treated as part of the same cloud
!                                  i.e. maximum-random overlap
!                     overlap = 2. means condensate in adjacent levels 
!                                  is treated as different clouds
!                                  i.e. random overlap
!  </DATA>
!  <DATA NAME="l2strem" UNITS="" TYPE="" DIM="" DEFAULT="">
!logical variable indicating which solution for 
!                     cloud radiative properties is being used.
!                     l2strem = T  2 stream solution
!                     l2strem = F  Delta-Eddington solution
!                     Note that IF l2strem = T then the solution does 
!                     not depend on solar zenith angle
!  </DATA>
!  <DATA NAME="taucrit" UNITS="" TYPE="" DIM="" DEFAULT="">
! critical optical depth for switching direct beam 
!                     to diffuse beam for use in Delta-Eddington 
!                     solution [ dimensionless] 
!  </DATA>
!  <DATA NAME="adjust_top" UNITS="" TYPE="" DIM="" DEFAULT="">
!logical variable indicating whether or not to use 
!                     the code which places the top and bottom of the 
!                     cloud at the faces which are most in view from
!                     the top and bottom of the cloud block. this is 
!                     done to avoid undue influence of very small cloud
!                     fractions. if true this adjustment of tops is 
!                     performed; if false this is not performed.
!  </DATA>
!  <DATA NAME="scale_factor" UNITS="" TYPE="" DIM="" DEFAULT="">
!factor which multiplies actual cloud optical 
!                     depths to account for the plane-parallel homo-
!                     genous cloud bias  (e.g. Cahalan effect).
!                     [ dimensionless] 
!  </DATA>
!  <DATA NAME="qamin" UNITS="" TYPE="" DIM="" DEFAULT="">
!minimum permissible cloud fraction 
!                     [ dimensionless] 
!  </DATA>
!  <DATA NAME="do_brenguier" UNITS="" TYPE="" DIM="" DEFAULT="">
!should drops at top of stratocumulus clouds be
!                     scaled?
!  </DATA>
! </NAMELIST>
!

namelist /cloud_rad_nml/                                       &
                         overlap, l2strem, taucrit,     &
                         adjust_top, scale_factor, qamin, &
                         do_brenguier, N_min


!------------------------------------------------------------------
!---- public data ------


!-------------------------------------------------------------------
!---- private data ------

!-------------------------------------------------------------------
!   various physical parameters:
!-------------------------------------------------------------------
real, parameter :: taumin = 1.E-06  ! minimum permissible tau  
                                    ! [ dimensionless ]
real            :: qmin = 1.E-10    ! minimum permissible cloud 
                                    ! condensate [ kg condensate / 
                                    ! kg air ]                 
real            :: N_land = 3.E+08  ! number of cloud droplets in liquid
                                    ! clouds over land  [ m**(-3) ]
real            :: N_ocean = 1.E+08 ! number of cloud droplets in liquid
                                    ! clouds over ocean [ m**(-3) ]
real, parameter :: k_land = 1.143   ! ratio of effective radius to 
                                    ! volume radius for continental
                                    ! air masses  [ dimensionless ]
real, parameter :: k_ocean = 1.077  ! ratio of effective radius to 
                                    ! volume radius for continental
                                    ! air masses  [ dimensionless ]
!       IMPORTANT NOTE qmin, N_land, N_ocean are initialized with a 
!       call from strat_cloud_init to cloud_rad_init.  This guarantees
!       that both strat_cloud and cloud_rad have the exact same values
!       for these parameters.
 
!----------------------------------------------------------------------
!    diagnostics variables.        
!----------------------------------------------------------------------
character(len=8)    :: mod_name = 'cloud_rad'
real                :: missing_value = -999.

integer ::            id_aice, id_reffice, id_aliq, id_reffliq, &
           id_alow, id_tauicelow, id_tauliqlow, id_tlaylow, id_tcldlow


!---------------------------------------------------------------------
!   logical variables:
!--------------------------------------------------------------------
logical   :: module_is_initialized = .false.  ! is module initialized ?
logical   :: do_liq_num          = .false.  ! use prog. droplet number ?




!---------------------------------------------------------------------
!---------------------------------------------------------------------




                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#######################################################################


! <SUBROUTINE NAME="cloud_rad_init">
!  <OVERVIEW>
!
!   Called once to initialize cloud_rad module.   This routine reads the
!   namelist, registers any requested diagnostic fields, and (when
!   called from strat_cloud_init [standard practice]) returns the
!   overlap assumption to strat_cloud for use in determining cloud and
!   large-scale precipitation overlap. 
!
!  </OVERVIEW>
!  <DESCRIPTION>
!
!   Initializes values of qmin, N_land, and  N_ocean using values from
!   strat_cloud namelist as well as reads its own namelist variables. In
!   addition, it registers diagnostic fields if needed, and returns the 
!   value of the cloud overlap to strat_cloud.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_rad_init (axes, Time, qmin_in, N_land_in, N_ocean_in, &
!                        overlap_out)
!
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="integer, optional">
!    Axis integers for diagnostics
!  </IN>
!  <IN NAME="Time" TYPE="time_type, optional">
!     Time type variable for diagnostics
!  </IN>
!  <IN NAME="qmin_in" TYPE="real, kg condensate/kg air, optional">
!      Input value of minimum permissible cloud liquid, ice,
!      or fraction                
!  </IN>
!  <IN NAME="N_land_in" TYPE="real, #/(m*m*m), optional">
!    Input value of number of cloud drop per cubic meter
!    over land
!  </IN>
!  <IN NAME="N_ocean_in" TYPE="real, #/(m*m*m), optional">
!    Input value of number of cloud drop per cubic meter
!    over ocean
!  </IN>
!  <OUT NAME="overlap_out" TYPE="integer, optional">
!    Integer indicating the overlap assumption being used 
!                       (1 = maximum-random, 2 = random)
!  </OUT>
!  <ERROR MSG="" STATUS="FATAL">
!   Fatal crashes occur in initialization of the module if:
!
!   1. overlap does not equal 1 or 2
!
!   2. taucrit < 0.
!
!   3. scale_factor < 0.
!
!   4. qamin outside of the range of 0 to 1.
!  </ERROR>
! </SUBROUTINE>
!
subroutine cloud_rad_init (axes, Time, qmin_in, N_land_in, N_ocean_in, &
                           prog_droplet_in, overlap_out)
                               
!--------------------------------------------------------------------
!    cloud_rad_init is the constructor for cloud_rad_mod.
!--------------------------------------------------------------------

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!       This subroutine initializes values of qmin, N_land, and 
!       N_ocean using values from the strat_cloud_module, 
!        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!
!VARIABLES
!
!
!       --------------
!       OPTIONAL INPUT
!       --------------
!
!
!         variable              definition                  unit
!       ------------   -----------------------------   ---------------
!
!       axes           axis integers for diagnostics
!
!       Time           time type variable for 
!                      diagnostics
!     
!       qmin_in        input value of minimum per-     kg condensate/ 
!                      missible cloud liquid, ice,     kg air
!                      or fraction                     or fraction
!
!       N_land_in      input value of number of        #/(m*m*m)
!                      of cloud drop per cubic meter
!                      over land
!
!       N_ocean_in     input value of number of        #/(m*m*m)
!                      of cloud drop per cubic meter
!                      over ocean
!
!       ---------------
!       OPTIONAL OUTPUT
!       ---------------
!
!       overlap_out    value of the namelist variable overlap
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       unit,io        namelist integers
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

integer,         intent(in), optional     :: axes(4)
type(time_type), intent(in), optional     :: Time
REAL,     INTENT (IN),  OPTIONAL          :: qmin_in,N_land_in,&
                                             N_ocean_in
LOGICAL,  INTENT (IN), OPTIONAL           :: prog_droplet_in
INTEGER,  INTENT (OUT), OPTIONAL          :: overlap_out

!  Internal variables
!  ------------------


INTEGER                                  :: unit,io,ierr, logunit

!-----------------------------------------------------------------------
!       
!       Code
!
    
!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call constants_init
      call diag_manager_init

!--------------------------------------------------------------------
!    read namelist.
!--------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cloud_rad_nml, iostat=io)
      ierr = check_nml_error(io,'cloud_rad_nml')
#else   
      if ( file_exist('input.nml')) then
        unit = open_namelist_file ()
        ierr=1; do while (ierr /= 0)
           read  (unit, nml=cloud_rad_nml, iostat=io, end=10)
           ierr = check_nml_error(io,'cloud_rad_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=cloud_rad_nml)

!-----------------------------------------------------------------------
!
!       Prevent unreasonable values

        if (overlap.ne.1 .and. overlap.ne.2) &
                call error_mesg  ('cloud_rad_init in cloud_rad module',&
                                'overlap must be either 1 or 2 ', FATAL)
        if (taucrit .lt. 0.) &
                call error_mesg  ('cloud_rad_init in cloud_rad module',&
                  'taucrit must be greater than or equal to 0. ', FATAL)
        if (scale_factor .lt. 0.) &
                call error_mesg  ('cloud_rad_init in cloud_rad module',&
                         'scale_factor must be greater than 0. ', FATAL)
        if (qamin .le. 0. .or. qamin .ge. 1.) &
                call error_mesg  ('cloud_rad_init in cloud_rad module',&
                               'qamin must be between 0. and 1.', FATAL)
        
!-----------------------------------------------------------------------
!
!       Assign values

        if (present(qmin_in)) then
              qmin = qmin_in
        end if
        if (present(N_land_in)) then
              N_land = N_land_in
        end if
        if (present(N_ocean_in)) then
              N_ocean = N_ocean_in
        end if
        if (present(overlap_out)) then
              overlap_out = overlap
        end if
        if (present(prog_droplet_in)) then
              do_liq_num = prog_droplet_in
        end if
        
       module_is_initialized = .true.

end subroutine cloud_rad_init

!###################################################################

! <SUBROUTINE NAME="cloud_rad_end">
!  <OVERVIEW>
!
!    A destructor routine for the cloud_rad module.
!
!  </OVERVIEW>
!  <DESCRIPTION>
!
!    A destructor routine for the cloud_rad module.
!
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_rad_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine cloud_rad_end

       module_is_initialized = .false.

end subroutine cloud_rad_end

!#####################################################################

! <SUBROUTINE NAME="lw_emissivity">
!  <OVERVIEW>
!   
!    Subroutine lw_emissivity computes the longwave cloud emissivity 
!    using the cloud mass absorption coefficient and the water path.
!
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_emissivity (is, js, lwp, iwp, reff_liq, reff_ice,   &
!                       nclds, em_lw)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!     Starting subdomain i index of data 
!     in the physics_window being integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!     Starting subdomain j index of data 
!     in the physics_window being integrated
!  </IN>
!  <IN NAME="lwp" TYPE="real">
!     Liquid water path [ kg / m**2 ]
!  </IN>
!  <IN NAME="iwp" TYPE="real">
!     Ice water path [ kg / m**2 ]
!  </IN>
!  <IN NAME="reff_liq" TYPE="real">
!     Effective cloud drop radius used with
!     bulk cloud physics scheme [ microns ]
!  </IN>
!  <IN NAME="reff_ice" TYPE="real">
!     Effective ice crystal radius used with
!     bulk cloud physics scheme [ microns ]
!  </IN>
!  <IN NAME="nclds" TYPE="integer">
!     Number of random overlapping clouds in column
!  </IN>
!  <OUT NAME="em_lw" TYPE="real">
!     longwave cloud emmissivity [ dimensionless ]
!  </OUT>
! </SUBROUTINE>
!
subroutine lw_emissivity (is, js, lwp, iwp, reff_liq, reff_ice,   &
                          nclds, em_lw)

!---------------------------------------------------------------------
!    subroutine lw_emissivity computes the longwave cloud emissivity 
!    using the cloud mass absorption coefficient and the water path.
!---------------------------------------------------------------------

integer,                 intent(in)   ::  is,js
real, dimension(:,:,:),  intent(in)   ::  lwp, iwp, reff_liq, reff_ice
integer, dimension(:,:), intent(in)   ::  nclds
real, dimension(:,:,:),  intent(out)  ::  em_lw


!--------------------------------------------------------------------
!   intent(in) variables:
!
!        is,js           starting subdomain i,j indices of data 
!                        in the physics_window being integrated     
!        lwp             liquid water path [ kg / m**2 ]
!        iwp             ice water path [ kg / m**2 ]
!        reff_liq        effective cloud drop radius  used with
!                        bulk cloud physics scheme [ microns ]
!        reff_ice        effective ice crystal radius used with
!                        bulk cloud physics scheme [ microns ]
!        nclds           number of random overlapping clouds in column
!
!    intent(out) variables:
!
!        em_lw           longwave cloud emmissivity [ dimensionless ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (size(em_lw,1), size(em_lw,2),                 &
                                      size(em_lw,3)) ::  k_liq, k_ice

!---------------------------------------------------------------------
!   local variables:
!     
!     k_liq             liquid cloud mass absorption coefficient for 
!                       longwave portion of spectrum 
!                       [ m**2 / kg condensate ]
!     k_ice             ice cloud mass absorption coefficient for 
!                       longwave portion of spectrum 
!                       [ m**2 / kg condensate ]
!     i,j,k             do-loop indices
!
!---------------------------------------------------------------------
              
!----------------------------------------------------------------------
!    compute longwave emissivity, including contributions from both the
!    ice and liquid cloud particles present.
!----------------------------------------------------------------------
      k_liq = 140.
      k_ice = 4.83591 + 1758.511/reff_ice       
      em_lw = 1. - exp(-1.*( k_liq*lwp +  k_ice*iwp))

!----------------------------------------------------------------------


    
end subroutine lw_emissivity                   




!######################################################################

! <SUBROUTINE NAME="cloud_summary3">
!  <OVERVIEW>
!
!   cloud_summary3 returns the specification properties of the clouds
!    present in the strat_cloud_mod.
!
!  </OVERVIEW>
!  <DESCRIPTION>
!
!   cloud_summary3 returns the specification properties of the clouds
!    present in the strat_cloud_mod.
!
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_summary3 (is, js, land, ql, qi, qa, qn, pfull, phalf, &
!                        tkel, nclds, cldamt, lwp, iwp, reff_liq,  &
!                        reff_ice, ktop, kbot, conc_drop, conc_ice, &
!                        size_drop, size_ice)
!
!  </TEMPLATE>
!  <IN NAME="is,js" TYPE="integer">
!    Indices for model slab
!  </IN>
!  <IN NAME="land" TYPE="real">
!    Fraction of the grid box covered by land
!                    [ dimensionless ]
!  </IN>
!  <IN NAME="ql" TYPE="real">
!    Cloud liquid condensate [ kg condensate/kg air ]
!  </IN>
!  <IN NAME="qi" TYPE="real">
!    Cloud ice condensate [ kg condensate/kg air ]
!  </IN>
!  <IN NAME="qa" TYPE="real">
!    Cloud volume fraction [ fraction ]
!  </IN>
!  <IN NAME="qn" TYPE="real">
!    Cloud droplet number [ #/kg air ]
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!    Pressure at full levels [ Pascals ]
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!    Pressure at half levels [ Pascals ]
!    NOTE: it is assumed that phalf(j+1) > phalf(j)
!  </IN>
!  <IN NAME="tkel" TYPE="real">
!    Temperature [ deg. Kelvin ]
!  </IN>
!  <OUT NAME="nclds" TYPE="integer">
!    Number of random-overlap clouds in a column
!  </OUT>
!  <OUT NAME="cldamt" TYPE="real">
!    Cloud amount of condensed cloud
!  </OUT>
!  <OUT NAME="lwp" TYPE="real">
!    Liquid water path
!  </OUT>
!  <OUT NAME="iwp" TYPE="real">
!    Ice water path
!  </OUT>
!  <OUT NAME="reff_liq" TYPE="real">
!    Effective radius of cloud drops
!  </OUT>
!  <OUT NAME="reff_ice" TYPE="real">
!    Effective radius of ice crystals
!  </OUT>
!  <OUT NAME="ktop" TYPE="integer, optional">
!    Integer level for top of cloud, present when 
!    max-random overlap assumption made.
!  </OUT>
!  <OUT NAME="kbot" TYPE="integer, optional">
!    Integer level for bottom of cloud, present when
!    max-random overlap assumption made.
!  </OUT>
!  <OUT NAME="conc_drop" TYPE="real, optional">
!    Liquid cloud droplet mass concentration, present 
!    when microphysically-based cloud radiative
!    properties are desired.
!  </OUT>
!  <OUT NAME="conc_ice" TYPE="real, optional">
!    Ice cloud mass concentration, present when
!    microphysically-based cloud radiative
!    properties are desired
!  </OUT>
!  <OUT NAME="size_drop" TYPE="real, optional">
!    Effective diameter of liquid cloud droplets, 
!    present when microphysically-based cloud radiative
!    properties are desired.
!  </OUT>
!  <OUT NAME="size_ice" TYPE="real, optional">
!     Effective diameter of ice cloud, present when 
!     microphysically-based cloud radiative
!     properties are desired.
!  </OUT>
! </SUBROUTINE>
!
subroutine cloud_summary3 (is, js, land,  use_fu2007, ql, qi, qa, qn, &
                           pfull, phalf, &
                           tkel, nclds, cldamt, lwp, iwp, reff_liq,  &
                           reff_ice, ktop, kbot, conc_drop, conc_ice, &
!                          size_drop, size_ice)
                           size_drop, size_ice, droplet_number)
   
!---------------------------------------------------------------------
!    cloud_summary3 returns the specification properties of the clouds
!    present in the strat_cloud_mod.
!---------------------------------------------------------------------
 
integer,                   intent(in)            :: is,js
real, dimension(:,:),      intent(in)            :: land
logical,                   intent(in)             :: use_fu2007
real, dimension(:,:,:),    intent(in)            :: ql, qi, qa, qn, pfull,&
                                                    phalf, tkel
integer, dimension(:,:),   intent(out)           :: nclds          
real, dimension(:,:,:),    intent(out)           :: cldamt, lwp, iwp, &
                                                    reff_liq, reff_ice
integer, dimension(:,:,:), intent(out), optional :: ktop, kbot 
real,    dimension(:,:,:), intent(out), optional :: conc_drop,conc_ice,&
                                                    size_drop,size_ice,&
                                                    droplet_number

!---------------------------------------------------------------------
!    intent(in) variables:
!
!       is,js        Indices for model slab
!       land         Fraction of the grid box covered by land
!                    [ dimensionless ]
!       ql           Cloud liquid condensate [ kg condensate/kg air ]
!       qi           Cloud ice condensate [ kg condensate/kg air ]
!       qa           Cloud volume fraction [ fraction ]
!       qn           Cloud droplet number [ #/kg air]
!       pfull        Pressure at full levels [ Pascals ]
!       phalf        Pressure at half levels [ Pascals ]
!                    NOTE: it is assumed that phalf(j+1) > phalf(j)
!       tkel         Temperature [ deg. Kelvin ] 
!
!    intent(out) variables:
!
!       nclds        Number of random-overlap clouds in a column
!       cldamt       Cloud amount of condensed cloud
!       lwp          Liquid water path 
!       iwp          Ice water path
!       reff_liq     Effective radius of cloud drops
!       reff_ice     Effective radius of ice crystals
!
!   intent(out), optional variables:
! 
!       ktop         Integer level for top of cloud, present when 
!                    max-random overlap assumption made
!       kbot         Integer level for bottom of cloud, present when
!                    max-random overlap assumption made
!       conc_drop    Liquid cloud droplet mass concentration, present 
!                    when microphysically-based cloud radiative
!                    properties are desired
!       conc_ice     Ice cloud mass concentration, present when
!                    microphysically-based cloud radiative
!                    properties are desired
!       size_drop    Effective diameter of liquid cloud droplets, 
!                    present when microphysically-based cloud radiative
!                    properties are desired
!       size_ice     Effective diameter of ice cloud, present when 
!                    microphysically-based cloud radiative
!                    properties are desired
!       droplet_number
!                    number of cloud droplets [ # / kg(air) ]
!
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!    local variables:

      real,dimension (size(ql,1),size(ql,2),   &
                                 size(ql,3)) :: qa_local, ql_local, &
                                                qi_local, N_drop3D

      real,dimension (size(ql,1),size(ql,2)) :: N_drop2D, k_ratio
      integer  :: i, j, k

!--------------------------------------------------------------------
!    local variables:
!
!       qa_local     local value of qa (fraction)
!       ql_local     local value of ql (kg condensate / kg air)
!       qi_local     local value of qi (kg condensate / kg air)
!       N_drop[23]D  number of cloud droplets per cubic meter
!       k_ratio      ratio of effective radius to mean volume radius
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    create local values of ql and qi. this step is necessary to remove 
!    the values of (qi,ql) which are 0 < (qi,ql) < qmin   or
!    (qi,ql) > qmin and qa <= qamin.
!--------------------------------------------------------------------

      do k=1, size(ql,3)
        do j=1, size(ql,2)
          do i=1, size(ql,1)
            qa_local(i,j,k) = 0.
            if ((qa(i,j,k) > qamin) .and. (ql(i,j,k) > qmin) ) then
              ql_local(i,j,k) = ql(i,j,k)
              qa_local(i,j,k) = qa(i,j,k)
            else
              ql_local(i,j,k) = 0.
            endif      
            if ((qa(i,j,k) > qamin) .and. (qi(i,j,k) > qmin) ) then
              qi_local(i,j,k) = qi(i,j,k)
              qa_local(i,j,k) = qa(i,j,k)
            else
              qi_local(i,j,k) = 0.
            endif       
          end do
        end do
      end do

!--------------------------------------------------------------------
!    define the cloud droplet concentration and the ratio of the 
!    effective drop radius to the mean volume radius.
!--------------------------------------------------------------------
      N_drop2D(:,:)  = N_land*land(:,:) + N_ocean*(1. - land(:,:))
      k_ratio(:,:) = k_land*land(:,:) + k_ocean*(1. - land(:,:))
!yim prognostic droplet number
      if (do_liq_num) then
        N_drop3D=qn
        droplet_number = qn
      else 
        do k=1, size(ql,3)
          do j=1, size(ql,2)
            do i=1, size(ql,1)
              droplet_number(i,j,k) = N_drop2D(i,j)/(pfull(i,j,k)/  &
                                      (RDGAS*tkel(i,j,k)))
            end do
          end do
        end do
      endif    

!--------------------------------------------------------------------
!    execute the following when  the max-random overlap assumption 
!    is being made. 
!--------------------------------------------------------------------
      if (present(ktop) .and. present(kbot)) then    ! max-rnd

!--------------------------------------------------------------------
!    if microphysics output is required, only the random overlap assump-
!    tion is allowed; if max-random overlap is requested, an error
!    message will be issued. if random overlap is requested, call
!    subroutine rnd_overlap to obtain the cloud specification proper-
!    ties, including the microphysical parameters.
!--------------------------------------------------------------------
        if (present (conc_drop) .and.  present (conc_ice ) .and. &
            present (size_ice ) .and.  present (size_drop)) then      
          call error_mesg ( 'cloud_rad_mod', &
       ' max-random overlap not currently available for radiation '//&
              'scheme requiring microphysically-based outputs', FATAL)
     
!----------------------------------------------------------------------
!    if some but not all of the microphysics variables are present,
!    stop execution.
!---------------------------------------------------------------------
        else if (present (conc_drop) .or.  present (conc_ice ) .or. &
                 present (size_ice ) .or.  present (size_drop)) then
          call error_mesg ('cloud_rad_mod', &
                ' if any microphysical args present, all must be '//&
                                                    'present', FATAL)

        else
          call  max_rnd_overlap (ql_local, qi_local, qa_local, pfull,  &
                                 phalf, tkel, N_drop3D, N_drop2D, k_ratio, nclds,  &
                                 ktop, kbot, cldamt, lwp, iwp,   &
                                 reff_liq, reff_ice)
        endif
     
!---------------------------------------------------------------------
!    if only ktop or kbot is present, stop execution; both are needed
!    for max-random overlap and neither are prrmitted when the 
!    random overlap assumption is made.
!---------------------------------------------------------------------
      else if (present(ktop) .or. present(kbot)) then ! error
        call error_mesg ('cloud_rad_mod',  &
                  'kbot and ktop must either both be absent or both '//&
                    'be present', FATAL)

!---------------------------------------------------------------------
!    if neither are present, then random overlap is assumed.
!---------------------------------------------------------------------
      else                 

!---------------------------------------------------------------------
!    if microphysical properties are desired, call subroutine 
!    rnd_overlap to obtain the cloud specification properties, including
!    the microphysical parameters.
!--------------------------------------------------------------------
        if (present (conc_drop) .and.  present (conc_ice ) .and. &
            present (size_ice ) .and.  present (size_drop)) then      
          call rnd_overlap (ql_local, qi_local, qa_local,  &
                            use_fu2007, pfull, phalf, tkel,  &
                            N_drop3D, N_drop2D, k_ratio, nclds,      &
                            cldamt, lwp, iwp, reff_liq, reff_ice,   &
                            conc_drop_org=conc_drop,&
                            conc_ice_org =conc_ice,&
                            size_drop_org=size_drop,&
                            size_ice_org =size_ice)

!--------------------------------------------------------------------
!    account for the plane-parallel homogeneous cloud bias.
!--------------------------------------------------------------------
          conc_drop = scale_factor*conc_drop
          conc_ice  = scale_factor*conc_ice 

!----------------------------------------------------------------------
!    if some but not all of the microphysics variables are present,
!    stop execution.
!---------------------------------------------------------------------
        else if (present (conc_drop) .or.  present (conc_ice ) .or. &
                 present (size_ice ) .or.  present (size_drop)) then   
          call error_mesg ('cloud_rad_mod', &
                ' if any microphysical args present, all must '//&
                                                'be present', FATAL)

!----------------------------------------------------------------------
!    if microphysics terms are not required, call rnd_overlap to obtain
!    the cloud specification variables.
!----------------------------------------------------------------------
        else
           call  rnd_overlap (ql_local, qi_local, qa_local,  &
                              use_fu2007, pfull, phalf, tkel,  &
                              N_drop3D, N_drop2D, k_ratio, nclds,  &
                              cldamt, lwp, iwp, reff_liq, reff_ice)
        endif
      endif ! (present(ktop and kbot))

!---------------------------------------------------------------------
    


end subroutine cloud_summary3



!######################################################################

! <SUBROUTINE NAME="max_rnd_overlap">
!  <OVERVIEW>
!
!    max_rnd_overlap returns various cloud specification properties
!    obtained with the maximum-random overlap assumption.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!
!    max_rnd_overlap returns various cloud specification properties
!    obtained with the maximum-random overlap assumption.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call max_rnd_overlap (ql, qi, qa, pfull, phalf, tkel, N_drop3D, N_drop2D,  &
!                         k_ratio, nclds, ktop, kbot, cldamt, lwp,  &
!                         iwp, reff_liq, reff_ice)
!
!  </TEMPLATE>
!  <IN NAME="ql" TYPE="real">
!    Cloud liquid condensate [ kg condensate/kg air ]
!  </IN>
!  <IN NAME="qi" TYPE="real">
!    Cloud ice condensate [ kg condensate/kg air ]
!  </IN>
!  <IN NAME="qa" TYPE="real">
!    Cloud volume fraction [ fraction ]
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!    Pressure at full levels [ Pascals ]
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!    Pressure at half levels, index 1 at model top 
!    [ Pascals ]
!  </IN>
!  <IN NAME="tkel" TYPE="real">
!    Temperature [ deg Kelvin ]
!  </IN>
!  <IN NAME="N_drop[23]D" TYPE="real">
!    Number of cloud droplets per cubic meter (2 and 3 dimensional array)
!  </IN>
!  <IN NAME="k_ratio" TYPE="real">
!    Ratio of effective radius to mean volume radius
!  </IN>
!  <OUT NAME="nclds" TYPE="integer">
!    Number of (random overlapping) clouds in column 
!  </OUT>
!  <OUT NAME="ktop" TYPE="integer">
!    Level of the top of the cloud.
!  </OUT>
!  <OUT NAME="kbot" TYPE="integer">
!    Level of the bottom of the cloud.
!  </OUT>
!  <OUT NAME="cldamt" TYPE="real">
!    Cloud amount of condensed cloud [ dimensionless ]
!  </OUT>
!  <OUT NAME="lwp" TYPE="real">
!    Cloud liquid water path [ kg condensate / m **2 ]
!  </OUT>
!  <OUT NAME="iwp" TYPE="real">
!    Cloud ice path [ kg condensate / m **2 ]
!  </OUT>
!  <OUT NAME="reff_liq" TYPE="real">
!    Effective radius for liquid clouds [ microns ]
!  </OUT>
!  <OUT NAME="reff_ice" TYPE="real">
!    Effective particle size for ice clouds [ microns ]
!  </OUT>
! </SUBROUTINE>
!
subroutine max_rnd_overlap (ql, qi, qa, pfull, phalf, tkel, N_drop3D, N_drop2D,  &
                           k_ratio, nclds, ktop, kbot, cldamt, lwp,  &
                           iwp, reff_liq, reff_ice)

!----------------------------------------------------------------------
!    max_rnd_overlap returns various cloud specification properties
!    obtained with the maximum-random overlap assumption.
!----------------------------------------------------------------------
 
real,    dimension(:,:,:), intent(in)             :: ql, qi, qa,  &
                                                     pfull, phalf, tkel, N_drop3D
real,    dimension(:,:),   intent(in)             :: N_drop2D, k_ratio
integer, dimension(:,:),   intent(out)            :: nclds
integer, dimension(:,:,:), intent(out)            :: ktop, kbot
real,    dimension(:,:,:), intent(out)            :: cldamt, lwp, iwp, &
                                                     reff_liq, reff_ice

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       ql           Cloud liquid condensate [ kg condensate/kg air ]
!       qi           Cloud ice condensate [ kg condensate/kg air ]
!       qa           Cloud volume fraction [ fraction ]
!       pfull        Pressure at full levels [ Pascals ]
!       phalf        Pressure at half levels, index 1 at model top 
!                    [ Pascals ]
!       tkel         Temperature [ deg Kelvin ]
!       N_drop       Number of cloud droplets per cubic meter
!       k_ratio      Ratio of effective radius to mean volume radius
!
!   intent(out) variables:
!
!       nclds        Number of (random overlapping) clouds in column 
!       ktop         Level of the top of the cloud
!       kbot         Level of the bottom of the cloud
!       cldamt       Cloud amount of condensed cloud [ dimensionless ]
!       lwp          Cloud liquid water path [ kg condensate / m **2 ]
!       iwp          Cloud ice path [ kg condensate / m **2 ]
!       reff_liq     Effective radius for liquid clouds [ microns ]
!       reff_ice     Effective particle size for ice clouds [ microns ]
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real, dimension (size(ql,1), size(ql,2), size(ql,3))  :: &
                    cldamt_cs, lwp_cs, iwp_cs, reff_liq_cs, reff_ice_cs 

      integer    :: kdim
      integer    :: top_t, bot_t
      integer    :: tmp_top, tmp_bot, nlev
      logical    :: already_in_cloud, cloud_bottom_reached
      real       :: sum_liq, sum_ice, maxcldfrac
      real       :: totcld_bot, max_bot
      real       :: totcld_top, max_top, tmp_val
      real       :: reff_liq_local, sum_reff_liq
      real       :: reff_ice_local, sum_reff_ice
      integer    :: i, j, k, kc, t

!--------------------------------------------------------------------
!   local variables:
!
!       kdim              number of model layers
!       top_t             used temporarily as tag for cloud top index
!       bot_t             used temporarily as tag for cloud bottom index
!       tmp_top           used temporarily as tag for cloud top index
!       tmp_bot           used temporarily as tag for cloud bottom index
!       nlev              number of levels in the cloud
!       already_in_cloud  if true, previous layer contained cloud
!       cloud_bottom_reached
!                         if true, the cloud-free layer beneath a cloud
!                         has been reached
!       sum_liq           sum of liquid in cloud 
!                         [ kg condensate / m**2 ]
!       sum_ice           sum of ice in cloud 
!                         [ kg condensate / m**2 ]
!       maxcldfrac        maximum cloud fraction in any layer of cloud
!                         [ fraction ]
!       totcld_bot        total cloud fraction from bottom view
!       max_bot           largest cloud fraction face from bottom view
!       totcld_top        total cloud fraction from top view
!       max_top           largest cloud fraction face from top view
!       tmp_val           temporary number used in the assigning of top 
!                         and bottom
!       reff_liq_local    gridpoint value of reff of liquid clouds 
!                         [ microns ]
!       sum_reff_liq      condensate-weighted sum over cloud of 
!                         reff_liq_local  
!                         [ (kg condensate / m**2) * microns ]
!       reff_ice_local    gridpoint value ofreff of ice clouds  
!                         [ microns ]
!       sum_reff_ice      condensate-weighted sum over cloud of 
!                         reff_ice_local 
!                         [ (kg condensate / m**2) * microns ]
!       i,j,k,kc,t        do-loop indices
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the number of vertical layers in the model. initialize the
!    output fields to correspond to the absence of clouds.
!---------------------------------------------------------------------
      kdim     = size(ql,3)
      nclds    = 0
      ktop     = 1
      kbot     = 0
      cldamt   = 0.
      lwp      = 0.
      iwp      = 0.
      reff_liq = 10.
      reff_ice = 30.

!--------------------------------------------------------------------
!    find the levels with cloud in each column. determine the vertical
!    extent of each individual cloud, treating cloud in adjacent layers
!    as components of a multi-layer cloud, and then calculate appropr-
!    iate values of water paths and effective particle size.
!--------------------------------------------------------------------

      do j=1,size(ql,2)
        do i=1,size(ql,1)

!--------------------------------------------------------------------
!    set a flag indicating that we are searching for the next cloud top.
!--------------------------------------------------------------------
          already_in_cloud  = .false.
          cloud_bottom_reached = .false.

!--------------------------------------------------------------------
!    march down the column.
!--------------------------------------------------------------------
          do k=1,kdim      

!--------------------------------------------------------------------
!    find a layer containing cloud in the column. 
!--------------------------------------------------------------------
            if ( (ql(i,j,k) .gt. qmin) .or. &
                 (qi(i,j,k) .gt. qmin) ) then      

!--------------------------------------------------------------------
!    if the previous layer was not cloudy, then a new cloud has been
!    found. increment the cloud counter, set the flag to indicate the 
!    layer is in a cloud, save its cloud top level, initialize the 
!    values of its ice and liquid contents and fractional area and 
!    effective crystal and drop sizes. 
!--------------------------------------------------------------------
              if (.not. already_in_cloud)  then
                nclds(i,j) = nclds(i,j) + 1
                already_in_cloud = .true.
                cloud_bottom_reached = .false.
                ktop(i,j,nclds(i,j)) = k
                sum_liq          = 0.
                sum_ice          = 0.
                maxcldfrac       = 0.
                sum_reff_liq     = 0.
                sum_reff_ice     = 0.        
              endif

!--------------------------------------------------------------------
!    if liquid is present in the layer, compute the effective drop
!    radius. the following formula, recommended by (Martin et al., 
!    J. Atmos. Sci, vol 51, pp. 1823-1842) is used for liquid droplets:
!    reff (in microns) =  k * 1.E+06 *
!                    (3*airdens*(ql/qa)/(4*pi*Dens_h2o*N_liq))**(1/3)
!
!    where airdens = density of air in kg air/m3
!               ql = liquid condensate in kg cond/kg air
!               qa = cloud fraction
!               pi = 3.14159
!         Dens_h2o = density of pure liquid water (kg liq/m3) 
!            N_liq = density of cloud droplets (number per cubic meter)
!                k = factor to account for difference between 
!                    mean volume radius and effective radius
!--------------------------------------------------------------------
             if(.not. do_liq_num) then
               if (ql(i,j,k) > qmin) then
                  reff_liq_local = k_ratio(i,j)*620350.49*    &
                                   (pfull(i,j,k)*ql(i,j,k)/qa(i,j,k)/  &
                                   RDGAS/tkel(i,j,k)/DENS_H2O/  &
                                   N_drop2D(i,j))**(1./3.)
               else
                 reff_liq_local = 0.
               endif
             else
!--------------------------------------------------------------------
! yim: a variant for prognostic droplet number
!    reff (in microns) =  k * 1.E+06 *
!                    (3*(ql/qa)/(4*pi*Dens_h2o*N_liq))**(1/3)
!
!    where airdens = density of air in kg air/m3
!               ql = liquid condensate in kg cond/kg air
!               qa = cloud fraction
!               pi = 3.14159
!         Dens_h2o = density of pure liquid water (kg liq/m3) 
!            N_liq = mixing ratio of cloud droplets (number/kg air)
!                k = factor to account for difference between 
!                    mean volume radius and effective radius
!--------------------------------------------------------------------
               if (ql(i,j,k) > qmin) then
                 reff_liq_local = k_ratio(i,j)*620350.49*    &
                                  (ql(i,j,k)/DENS_H2O/  &
                                  max(N_drop3D(i,j,k),   &
                                      N_min*max(qa(i,j,k),qmin)/  &
                             (pfull(i,j,k)/RDGAS/tkel(i,j,k))))**(1./3.)
               else
                 reff_liq_local = 0.
               endif
             endif   

!----------------------------------------------------------------------
!    for single layer liquid or mixed phase clouds it is assumed that
!    cloud liquid is vertically stratified within the cloud.  under
!    such situations for observed stratocumulus clouds it is found
!    that the cloud mean effective radius is between 80 and 100% of
!    the cloud top effective radius. (Brenguier et al., Journal of
!    Atmospheric Sciences, vol. 57, pp. 803-821 (2000))  for linearly 
!    stratified cloud in liquid specific humidity, the cloud top 
!    effective radius is greater than the effective radius of the 
!    cloud mean specific humidity by a factor of 2**(1./3.).
!    this correction, 0.9*(2**(1./3.)) = 1.134, is applied only to 
!    single layer liquid or mixed phase clouds.
!
!---------------------------------------------------------------------- 
              if (do_brenguier) then
              if ( k == 1 ) then
                 if (qa(i,j,2) < qamin) then
                   reff_liq_local = 1.134*reff_liq_local
                 endif
              else if (k == kdim ) then
                 if ( qa(i,j,kdim-1) < qamin) then
                   reff_liq_local = 1.134*reff_liq_local
                 endif
              else if (qa(i,j,k-1) .lt. qamin .and. & 
                       qa(i,j,k+1) .lt. qamin)  then
                reff_liq_local = 1.134*reff_liq_local
              end if
              end if

!--------------------------------------------------------------------
!    if ice crystals are present, define their effective size, which
!    is a function of temperature. for ice clouds the effective radius
!    is taken from the formulation in Donner (1997, J. Geophys. Res., 
!    102, pp. 21745-21768) which is based on Heymsfield and Platt (1984)
!    with enhancement for particles smaller than 20 microns.  
!
!              T Range (K)               Reff (microns) 
!     -------------------------------    --------------
!
!     tfreeze-25. < T                       92.46298       
!     tfreeze-30. < T <= Tfreeze-25.        72.35392     
!     tfreeze-35. < T <= Tfreeze-30.        85.19071         
!     tfreeze-40. < T <= Tfreeze-35.        55.65818        
!     tfreeze-45. < T <= Tfreeze-40.        35.29989       
!     tfreeze-50. < T <= Tfreeze-45.        32.89967     
!     Tfreeze-55  < T <= Tfreeze-50         16.60895      
!                   T <= Tfreeze-55.        15.41627    
!
!--------------------------------------------------------------------
              if (qi(i,j,k) > qmin) then
                if (tkel(i,j,k) > TFREEZE - 25. ) then
                  reff_ice_local = 92.46298
                else if (tkel(i,j,k) >  TFREEZE - 30. .and. &
                         tkel(i,j,k) <= TFREEZE - 25.) then
                  reff_ice_local = 72.35392
                else if (tkel(i,j,k) >  TFREEZE - 35. .and. &
                         tkel(i,j,k) <= TFREEZE - 30.) then
                  reff_ice_local = 85.19071 
                else if (tkel(i,j,k) >  TFREEZE - 40. .and. &
                         tkel(i,j,k) <= TFREEZE - 35.) then
                  reff_ice_local = 55.65818
                else if (tkel(i,j,k) >  TFREEZE - 45. .and. &
                         tkel(i,j,k) <= TFREEZE - 40.) then
                  reff_ice_local = 35.29989
                else if (tkel(i,j,k) >  TFREEZE - 50. .and. &
                         tkel(i,j,k) <= TFREEZE - 45.) then
                  reff_ice_local = 32.89967
                else if (tkel(i,j,k) >  TFREEZE - 55. .and. &
                         tkel(i,j,k) <= TFREEZE - 50.) then
                  reff_ice_local = 16.60895
                else
                  reff_ice_local = 15.41627
                end if

              else
                reff_ice_local = 0.
              end if  

!---------------------------------------------------------------------
!    add this layer's contributions to the current cloud. total liquid
!    content, ice content, largest cloud fraction and condensate-
!    weighted effective droplet and crystal radii are accumulated over 
!    the cloud.
!---------------------------------------------------------------------
              sum_liq = sum_liq + ql(i,j,k)*  &
                        (phalf(i,j,k+1) - phalf(i,j,k))/GRAV
              sum_ice = sum_ice + qi(i,j,k)* &
                        (phalf(i,j,k+1) - phalf(i,j,k))/GRAV
              maxcldfrac = MAX(maxcldfrac,qa(i,j,k))
              sum_reff_liq  = sum_reff_liq + (reff_liq_local*ql(i,j,k)*&
                              (phalf(i,j,k+1) - phalf(i,j,k))/GRAV)
              sum_reff_ice  = sum_reff_ice + &
                              (reff_ice_local * qi(i,j,k) * &
                              (phalf(i,j,k+1) - phalf(i,j,k))/GRAV)
            endif ! (ql > qmin or qi > qmin)

!--------------------------------------------------------------------
!    when the cloud-free layer below a cloud is reached, or if the
!    bottom model level is reached, define the cloud bottom level and
!    set a flag indicating that mean values for the cloud may now be
!    calculated.
!--------------------------------------------------------------------
            if (ql(i,j,k) <= qmin .and. qi(i,j,k) <= qmin .and. &
                already_in_cloud) then                 
              cloud_bottom_reached = .true.
              kbot(i,j,nclds(i,j)) = k - 1
            else if (already_in_cloud .and. k == kdim) then
              cloud_bottom_reached = .true.
              kbot(i,j,nclds(i,j)) = kdim
            endif

!--------------------------------------------------------------------
!    define the cloud fraction as the largest value of any layer in the
!    cloud. define the water paths as the total liquid normalized by the
!    fractional area of the cloud. define the condensate-weighted 
!    effective water and ice radii. 
!--------------------------------------------------------------------
            if (cloud_bottom_reached) then
              cldamt_cs(i,j,nclds(i,j)) = maxcldfrac
              lwp_cs(i,j,nclds(i,j)) = sum_liq/cldamt_cs(i,j,nclds(i,j))
              iwp_cs(i,j,nclds(i,j)) = sum_ice/cldamt_cs(i,j,nclds(i,j))
              if (sum_liq > 0.) then
                reff_liq_cs(i,j,nclds(i,j)) = sum_reff_liq/sum_liq
              else
                reff_liq_cs(i,j,nclds(i,j)) = 10.0
              end if
              if (sum_ice > 0.) then
                reff_ice_cs(i,j,nclds(i,j)) = sum_reff_ice/sum_ice
              else
                reff_ice_cs(i,j,nclds(i,j)) = 30.0
              end if

!----------------------------------------------------------------------
!    if adjust_top is true, the top and bottom indices of multi-layer
!    clouds are adjusted to be those that are the most exposed to top 
!    and bottom view.
!----------------------------------------------------------------------
              if (adjust_top) then
    
!---------------------------------------------------------------------
!    define the cloud thickness.
!---------------------------------------------------------------------
                nlev = kbot(i,j,nclds(i,j)) - ktop(i,j,nclds(i,j)) + 1
                if (nlev > 1) then

!---------------------------------------------------------------------
!    use the current top and bottom as the first guess for the new 
!    values.
!---------------------------------------------------------------------
                  tmp_top = ktop(i,j,nclds(i,j))
                  tmp_bot = kbot(i,j,nclds(i,j))

!--------------------------------------------------------------------
!    initialize local search variables.
!--------------------------------------------------------------------
                  totcld_bot = 0.
                  totcld_top = 0.
                  max_bot    = 0.
                  max_top    = 0.
          
!--------------------------------------------------------------------
!    to find the adjusted cloud top, begin at current top and work 
!    downward. find the layer which is most exposed when viewed from
!    the top; i.e., the cloud fraction increase is largest for that
!    layer. the adjusted cloud base is found equivalently, starting
!    from the actual cloud base and working upwards.
!--------------------------------------------------------------------
                  do t=1,nlev

!--------------------------------------------------------------------
!    find adjusted cloud top.
!--------------------------------------------------------------------
                    top_t   = ktop(i,j,nclds(i,j)) + t - 1
                    tmp_val = MAX(0., qa(i,j,top_t) - totcld_top)
                    if (tmp_val > max_top) then
                      max_top = tmp_val
                      tmp_top = top_t
                    end if
                    totcld_top = totcld_top + tmp_val         
                              
!--------------------------------------------------------------------
!    find adjusted cloud base.
!--------------------------------------------------------------------
                    bot_t   = kbot(i,j,nclds(i,j)) - t + 1
                    tmp_val = MAX(0., qa(i,j,bot_t) - totcld_bot)
                    if (tmp_val > max_bot) then
                      max_bot = tmp_val
                      tmp_bot = bot_t
                    end if
                    totcld_bot = totcld_bot + tmp_val         
                  end do
                       
!--------------------------------------------------------------------
!    assign tmp_top and tmp_bot as the new ktop and kbot.
!--------------------------------------------------------------------
                  ktop(i,j,nclds(i,j)) = tmp_top
                  kbot(i,j,nclds(i,j)) = tmp_bot
                endif  !(nlev > 1)  
              endif  ! (adjust_top)

!---------------------------------------------------------------------
!    reset already_in_cloud and cloud_bottom_reached to indicate that
!    the current cloud has been exited.
!---------------------------------------------------------------------
              already_in_cloud     = .false.
              cloud_bottom_reached = .false.
            endif   ! (cloud_bottom_reached)
          end do
        end do
      end do

!---------------------------------------------------------------------
!    place cloud properties into physical-space arrays for return to
!    calling routine. NOTE THAT ALL LEVELS IN A GIVEN CLOUD ARE
!    ASSIGNED THE SAME PROPERTIES.
!---------------------------------------------------------------------
      do j=1,size(ql,2)
        do i=1,size(ql,1)
          do kc=1, nclds(i,j)
            do k= ktop(i,j,kc), kbot(i,j,kc)
              cldamt(i,j,k)   = cldamt_cs(i,j,kc)
              lwp(i,j,k)      = lwp_cs(i,j,kc)
              iwp(i,j,k)      = iwp_cs(i,j,kc)
              reff_liq(i,j,k) = reff_liq_cs(i,j,kc)
              reff_ice(i,j,k) = reff_ice_cs(i,j,kc)
            end do
          end do
        end do
      end do
     
!---------------------------------------------------------------------

end subroutine max_rnd_overlap




!#####################################################################

! <SUBROUTINE NAME="rnd_overlap">
!  <OVERVIEW>
!    rnd_overlap returns various cloud specification properties, 
!    obtained with the random-overlap assumption. implicit in this
!    assumption is that all clouds are only a single layer thick; i.e.,
!    clouds at adjacent levels in the same column are independent of
!    one another.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    rnd_overlap returns various cloud specification properties, 
!    obtained with the random-overlap assumption. implicit in this
!    assumption is that all clouds are only a single layer thick; i.e.,
!    clouds at adjacent levels in the same column are independent of
!    one another.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rnd_overlap    (ql, qi, qa, pfull, phalf, tkel, N_drop,  &
!                        k_ratio, nclds, cldamt, lwp, iwp, reff_liq, &
!                        reff_ice, conc_drop_org, conc_ice_org,  &
!                        size_drop_org, size_ice_org)
!
!  </TEMPLATE>
!  <IN NAME="ql" TYPE="real">
!    Cloud liquid condensate [ kg condensate/kg air ]
!  </IN>
!  <IN NAME="qi" TYPE="real">
!    Cloud ice condensate [ kg condensate/kg air ]
!  </IN>
!  <IN NAME="qa" TYPE="real">
!    Cloud volume fraction [ fraction ]
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!    Pressure at full levels [ Pascals ]
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!    Pressure at half levels, index 1 at model top 
!    [ Pascals ]
!  </IN>
!  <IN NAME="tkel" TYPE="real">
!    Temperature [ deg Kelvin ]
!  </IN>
!  <IN NAME="N_drop" TYPE="real">
!    Number of cloud droplets per cubic meter
!  </IN>
!  <IN NAME="k_ratio" TYPE="real">
!    Ratio of effective radius to mean volume radius
!  </IN>
!  <OUT NAME="nclds" TYPE="integer">
!    Number of (random overlapping) clouds in column 
!  </OUT>
!  <OUT NAME="cldamt" TYPE="real">
!    Cloud amount of condensed cloud [ dimensionless ]
!  </OUT>
!  <OUT NAME="lwp" TYPE="real">
!    Cloud liquid water path [ kg condensate / m **2 ]
!  </OUT>
!  <OUT NAME="iwp" TYPE="real">
!    Cloud ice path [ kg condensate / m **2 ]
!  </OUT>
!  <OUT NAME="reff_liq" TYPE="real">
!    Effective radius for liquid clouds [ microns ]
!  </OUT>
!  <OUT NAME="reff_ice" TYPE="real">
!    Effective particle size for ice clouds [ microns ]
!  </OUT>
!  <OUT NAME="conc_drop_org" TYPE="real, optional">
!    Liquid cloud droplet mass concentration 
!    [ g / m**3 ]
!  </OUT>
!  <OUT NAME="conc_ice_org" TYPE="real, optional">
!    Ice cloud mass concentration [ g / m**3 ]
!  </OUT>
!  <OUT NAME="size_drop_org" TYPE="real, optional">
!    Effective diameter of liquid cloud droplets 
!    [ microns ]
!  </OUT>
!  <OUT NAME="size_ice_org" TYPE="real, optional">
!    Effective diameter of ice clouds [ microns ]
!  </OUT>
! </SUBROUTINE>
!
subroutine rnd_overlap    (ql, qi, qa, use_fu2007, pfull, phalf,   &
                           tkel, N_drop3D, N_drop2D,  &
                           k_ratio, nclds, cldamt, lwp, iwp, reff_liq, &
                           reff_ice, conc_drop_org, conc_ice_org,  &
                           size_drop_org, size_ice_org)

!----------------------------------------------------------------------
!    rnd_overlap returns various cloud specification properties, 
!    obtained with the random-overlap assumption. implicit in this
!    asusmption is that all clouds are only a single layer thick; i.e.,
!    clouds at adjacent levels in the same column are independent of
!    one another.
!----------------------------------------------------------------------
 
real,    dimension(:,:,:), intent(in)             :: ql, qi, qa,  &
                                                     pfull, phalf, tkel, N_drop3D
logical,                   intent(in)             :: use_fu2007
real,    dimension(:,:),   intent(in)             :: N_drop2D, k_ratio
integer, dimension(:,:),   intent(out)            :: nclds
real,    dimension(:,:,:), intent(out)            :: cldamt, lwp, iwp, &
                                                     reff_liq, reff_ice
real,    dimension(:,:,:), intent(out), optional  :: conc_drop_org,  &
                                                     conc_ice_org,  &
                                                     size_drop_org,  &
                                                     size_ice_org

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       ql           Cloud liquid condensate [ kg condensate/kg air ]
!       qi           Cloud ice condensate [ kg condensate/kg air ]
!       qa           Cloud volume fraction [ fraction ]
!       pfull        Pressure at full levels [ Pascals ]
!       phalf        Pressure at half levels, index 1 at model top 
!                    [ Pascals ]
!       tkel         Temperature [ deg Kelvin ]
!       N_drop       Number of cloud droplets per cubic meter
!       k_ratio      Ratio of effective radius to mean volume radius
!
!   intent(out) variables:
!
!       nclds        Number of (random overlapping) clouds in column 
!       cldamt       Cloud amount of condensed cloud [ dimensionless ]
!       lwp          Cloud liquid water path [ kg condensate / m **2 ]
!       iwp          Cloud ice path [ kg condensate / m **2 ]
!       reff_liq     Effective radius for liquid clouds [ microns ]
!       reff_ice     Effective particle size for ice clouds [ microns ]
!
!    intent(out), optional variables:
!
!       conc_drop_org Liquid cloud droplet mass concentration 
!                     [ g / m**3 ]
!       conc_ice_org  Ice cloud mass concentration [ g / m**3 ]
!       size_drop_org Effective diameter of liquid cloud droplets 
!                     [ microns ]
!       size_ice_org  Effective diameter of ice clouds { microns ]
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      logical    ::  want_microphysics
      real       ::  reff_liq_local, reff_ice_local
      integer    ::  kdim
      integer    ::  i, j, k

!--------------------------------------------------------------------
!   local variables:
!
!       want_microphysics   logical indicating if microphysical 
!                           parameters are to be calculated
!       reff_liq_local      reff of liquid clouds used locally
!                           [ microns ]
!       reff_ice_local      reff of ice clouds used locally 
!                           [ microns ]
!       kdim                number of vertical layers
!       i,j,k               do-loop indices
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the number of vertical layers in the model. initialize the
!    output fields to correspond to the absence of clouds.
!---------------------------------------------------------------------
      kdim     = size(ql,3)
      nclds    = 0
      cldamt   = 0.
      lwp      = 0.
      iwp      = 0.
      reff_liq = 10.
      reff_ice = 30.

!--------------------------------------------------------------------
!    initialize the optional output arguments, if present. define a
!    logical, indicating their presence.
!--------------------------------------------------------------------
      if (present(conc_drop_org) .and. present(conc_ice_org ) .and. &
          present(size_ice_org ) .and. present(size_drop_org)) then  
        conc_drop_org = 0.
        conc_ice_org  = 0.
        size_drop_org = 20.
        size_ice_org  = 60.
        want_microphysics = .true.

!----------------------------------------------------------------------
!    if some but not all of the microphysics variables are present,
!    stop execution.
!---------------------------------------------------------------------
      else if (present(conc_drop_org) .or. present(conc_ice_org ) .or. &
               present(size_ice_org ) .or. present(size_drop_org)) then 
        call error_mesg ('cloud_rad_mod', &
            ' if any microphysical args present, all must be present',&
                                                                FATAL)

!----------------------------------------------------------------------
!    if the optional arguments are not present, set the appropriate
!    flag to indicate that only bulk properties will be calculated.
!---------------------------------------------------------------------
      else
         want_microphysics = .false.
      end if

!--------------------------------------------------------------------
!    find the layers with cloud in each column, starting at model top. 
!--------------------------------------------------------------------
      do k=1,size(ql,3)
        do j=1,size(ql,2)
          do i=1,size(ql,1)
            if (ql(i,j,k) > qmin .or. qi(i,j,k) > qmin) then
               
!---------------------------------------------------------------------
!    when cloud is found, increment the cloud column counter.
!---------------------------------------------------------------------
              nclds(i,j) = nclds(i,j) + 1

!---------------------------------------------------------------------
!    if liquid water is present, compute the liquid water path. 
!---------------------------------------------------------------------
              if (ql(i,j,k) > qmin) then
                lwp(i,j,k) = ql(i,j,k)*    &
                                      (phalf(i,j,k+1) - phalf(i,j,k))/ &
                                      GRAV/qa(i,j,k)

!----------------------------------------------------------------------
!    if microphysical properties are desired, calculate the droplet
!    concentrations. units of concentration are in g / m**3.
!----------------------------------------------------------------------
                if (want_microphysics) then
                  conc_drop_org(i,j,k) =     &
                      1000.*ql(i,j,k)*(phalf(i,j,k+1) - phalf(i,j,k))/&
                      RDGAS/tkel(i,j,k)/log(phalf(i,j,k+1)/  &
                      MAX(phalf(i,j,k), pfull(i,j,1)))/qa(i,j,k)
                endif  

!---------------------------------------------------------------------
!    compute the effective cloud droplet radius. for liquid clouds the 
!    following formula is used, as recommended by 
!    Martin et al., J. Atmos. Sci, vol 51, pp. 1823-1842:
!
!    reff (in microns) =  k * 1.E+06 *
!                    (3*airdens*(ql/qa)/(4*pi*Dens_h2o*N_liq))**(1/3)
!
!    where airdens = density of air in kg air/m3
!               ql = liquid condensate in kg cond/kg air
!               qa = cloud fraction
!               pi = 3.14159
!         Dens_h2o = density of pure liquid water (kg liq/m3) 
!            N_liq = density of cloud droplets (number per cubic meter)
!                k = factor to account for difference between 
!                    mean volume radius and effective radius
!---------------------------------------------------------------------
        if (.not. do_liq_num) then
                reff_liq_local = k_ratio(i,j)* 620350.49 *    &
                                 (pfull(i,j,k)*ql(i,j,k)/qa(i,j,k)/   & 
                                 RDGAS/tkel(i,j,k)/DENS_H2O/    &
                                 N_drop2D(i,j))**(1./3.)
        else
!--------------------------------------------------------------------
! yim: a variant for prognostic droplet number
!    reff (in microns) =  k * 1.E+06 *
!                    (3*ql/(4*pi*Dens_h2o*N_liq))**(1/3)
!
!    where airdens = density of air in kg air/m3
!               ql = liquid condensate in kg cond/kg air
!               qa = cloud fraction
!               pi = 3.14159
!         Dens_h2o = density of pure liquid water (kg liq/m3) 
!            N_liq = mixing ratio of cloud droplets (number/kg air)
!                k = factor to account for difference between 
!                    mean volume radius and effective radius
!--------------------------------------------------------------------
              if (ql(i,j,k) > qmin) then
                reff_liq_local = k_ratio(i,j)*620350.49*    &
                                 (ql(i,j,k)/DENS_H2O/  &
                                 max(N_drop3D(i,j,k),  &
                                      N_min*max(qa(i,j,k),qmin)/  &
                             (pfull(i,j,k)/RDGAS/tkel(i,j,k))))**(1./3.)
              else
                reff_liq_local = 0.0
              endif
           endif
                       
!----------------------------------------------------------------------
!    for single layer liquid or mixed phase clouds it is assumed that
!    cloud liquid is vertically stratified within the cloud.  under
!    such situations for observed stratocumulus clouds it is found
!    that the cloud mean effective radius is between 80 and 100% of
!    the cloud top effective radius. (Brenguier et al., Journal of
!    Atmospheric Sciences, vol. 57, pp. 803-821 (2000))  for linearly 
!    stratified cloud in liquid specific humidity, the cloud top 
!    effective radius is greater than the effective radius of the 
!    cloud mean specific humidity by a factor of 2**(1./3.).
!    this correction, 0.9*(2**(1./3.)) = 1.134, is applied only to 
!    single layer liquid or mixed phase clouds.
!----------------------------------------------------------------------
                if (do_brenguier) then
! should this be applied to all clouds ? 
! random overlap ==> all clouds are of 1 layer
                if ( k == 1 ) then
                  if (qa(i,j,2) < qamin) then
                    reff_liq_local = 1.134*reff_liq_local
                  endif
                else if (k == kdim ) then
                  if ( qa(i,j,kdim-1) < qamin) then
                    reff_liq_local = 1.134*reff_liq_local
                  endif
                else if (qa(i,j,k-1) .lt. qamin .and. & 
                         qa(i,j,k+1) .lt. qamin)  then
                  reff_liq_local = 1.134*reff_liq_local
!! ADD for random overlap -- all clouds are 1 layer thick
!!! WAIT FOR SAK REPLY
!               else
!                 reff_liq_local = 1.134*reff_liq_local
                end if
                end if


                reff_liq(i,j,k) =  reff_liq_local
                if (want_microphysics)      &
                   size_drop_org(i,j,k) = 2.*reff_liq_local
              endif  ! (ql > qmin)

!---------------------------------------------------------------------
!    if ice is present, compute the ice water path.
!---------------------------------------------------------------------
              if (qi(i,j,k) .gt. qmin) then
                iwp(i,j,k) = qi(i,j,k)*    &
                                      (phalf(i,j,k+1) - phalf(i,j,k))/ &
                                      GRAV/qa(i,j,k)
                          
!----------------------------------------------------------------------
!    if microphysical properties are desired, calculate the ice con-
!    centration. units of concentration are in g / m**3.
!----------------------------------------------------------------------
                if (want_microphysics) then
                  conc_ice_org (i,j,k) =     &
                      1000.*qi(i,j,k)*(phalf(i,j,k+1) - phalf(i,j,k))/ &
                      RDGAS/tkel(i,j,k)/log(phalf(i,j,k+1)/   &
                      MAX(phalf(i,j,k), pfull(i,j,1)))/ qa(i,j,k)
                end if  
                       
!---------------------------------------------------------------------
!    compute the effective ice crystal size. for bulk physics cases, the
!    effective radius is taken from the formulation in Donner 
!    (1997, J. Geophys. Res., 102, pp. 21745-21768) which is based on 
!    Heymsfield and Platt (1984) with enhancement for particles smaller
!    than 20 microns.  
!    if microphysical properties are requested, then the size of the
!    ice crystals comes from the Deff column [ reference ?? ].     
!
!              T Range (K)               Reff (microns)   Deff (microns)
!     -------------------------------    --------------   --------------
!
!     Tfreeze-25. < T                       92.46298         100.6
!     Tfreeze-30. < T <= Tfreeze-25.        72.35392          80.8
!     Tfreeze-35. < T <= Tfreeze-30.        85.19071          93.5
!     Tfreeze-40. < T <= Tfreeze-35.        55.65818          63.9
!     Tfreeze-45. < T <= Tfreeze-40.        35.29989          42.5
!     Tfreeze-50. < T <= Tfreeze-45.        32.89967          39.9
!     Tfreeze-55  < T <= Tfreeze-50         16.60895          21.6
!                   T <= Tfreeze-55.        15.41627          20.2
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    calculate the effective ice crystal size using the data approp-
!    riate for the microphysics case.
!---------------------------------------------------------------------
            if (use_fu2007) then
!+yim Fu's parameterization of dge
              reff_ice_local = 47.05 +   &
                                0.6624*(tkel(i,j,k) - TFREEZE) +&
                               0.001741*(tkel(i,j,k)-TFREEZE)**2
              size_ice_org(i,j,k) = reff_ice_local
            else ! (use_fu2007)
                if (want_microphysics) then
                  if (tkel(i,j,k) > TFREEZE - 25.) then
                    reff_ice_local = 100.6      
                  else if (tkel(i,j,k) >  TFREEZE - 30. .and. &
                           tkel(i,j,k) <= TFREEZE - 25.) then
                    reff_ice_local = 80.8        
                  else if (tkel(i,j,k) >  TFREEZE - 35. .and. &
                           tkel(i,j,k) <= TFREEZE - 30.) then
                    reff_ice_local = 93.5       
                  else if (tkel(i,j,k) >  TFREEZE - 40. .and. &
                           tkel(i,j,k) <= TFREEZE - 35.) then
                    reff_ice_local = 63.9         
                  else if (tkel(i,j,k) >  TFREEZE - 45. .and. &
                           tkel(i,j,k) <= TFREEZE - 40.) then
                    reff_ice_local = 42.5       
                  else if (tkel(i,j,k) >  TFREEZE - 50. .and. &
                           tkel(i,j,k) <= TFREEZE - 45.) then
                    reff_ice_local = 39.9           
                  else if (tkel(i,j,k) >  TFREEZE - 55. .and. &
                           tkel(i,j,k) <= TFREEZE - 50.) then
                    reff_ice_local = 21.6         
                  else
                    reff_ice_local = 20.2             
                  endif

                  size_ice_org(i,j,k) = reff_ice_local
                endif
           endif ! (use_fu2007)

!---------------------------------------------------------------------
!    calculate reff_ice using the bulk physics data.
!---------------------------------------------------------------------
                if (tkel(i,j,k) > TFREEZE - 25.) then
                  reff_ice_local = 92.46298
                else if (tkel(i,j,k) >  TFREEZE - 30. .and. &
                         tkel(i,j,k) <= TFREEZE - 25.) then
                  reff_ice_local = 72.35392
                else if (tkel(i,j,k) >  TFREEZE - 35. .and. &
                         tkel(i,j,k) <= TFREEZE - 30.) then
                  reff_ice_local = 85.19071 
                else if (tkel(i,j,k) >  TFREEZE - 40. .and. &
                         tkel(i,j,k) <= TFREEZE - 35.) then
                  reff_ice_local = 55.65818
                else if (tkel(i,j,k) >  TFREEZE - 45. .and. &
                         tkel(i,j,k) <= TFREEZE - 40.) then
                  reff_ice_local = 35.29989
                else if (tkel(i,j,k) >  TFREEZE - 50. .and. &
                         tkel(i,j,k) <= TFREEZE - 45.) then
                  reff_ice_local = 32.89967
                else if (tkel(i,j,k) >  TFREEZE - 55. .and. &
                         tkel(i,j,k) <= TFREEZE - 50.) then
                  reff_ice_local = 16.60895
                else
                  reff_ice_local = 15.41627
                endif

                reff_ice(i,j,k) = reff_ice_local
              end if ! (qi > qmin)                    
                          
!---------------------------------------------------------------------
!    define the cloud fraction.
!---------------------------------------------------------------------
              cldamt(i,j,k) = qa(i,j,k)
            endif   !( ql > 0 or qi > 0)
          end do
        end do
      end do

!-------------------------------------------------------------------
    
end subroutine rnd_overlap   




!#####################################################################

! <SUBROUTINE NAME="CLOUD_RAD_k_diag">
!  <OVERVIEW>
!      This subroutine calculates the following radiative properties
!      for each cloud:
!
!<PRE>               1. r_uv : cloud reflectance in uv band
!               2. r_nir: cloud reflectance in nir band
!               3. ab_uv: cloud absorption in uv band
!               4. ab_nir:cloud absorption in nir band
!</PRE>   
!  </OVERVIEW>
!  <DESCRIPTION>
!      This subroutine calculates the following radiative properties
!      for each cloud:
!
!<PRE>               1. r_uv : cloud reflectance in uv band
!               2. r_nir: cloud reflectance in nir band
!               3. ab_uv: cloud absorption in uv band
!               4. ab_nir:cloud absorption in nir band
!</PRE>
!
!      These quantities are computed by dividing the shortwave
!      spectrum into 4 bands and then computing the reflectance
!      and absorption for each band individually and then setting
!      the uv reflectance and absorption equal to that of band
!      1 and the nir reflectance and absorption equal to the
!      spectrum weighted results of bands 2,3,and 4.  The limits
!      of bands are described in CLOUD_OPTICAL_PROPERTIES.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call CLOUD_RAD_k_diag(tau, direct, w0,gg,coszen,r_uv,r_nir,ab_uv,ab_nir)
!
!  </TEMPLATE>
!  <IN NAME="tau" TYPE="real">
!    Optical depth in 4 bands [ dimensionless ]
!  </IN>
!  <IN NAME="direct" TYPE="logical">
!    Logical variable for each cloud indicating whether
!     or not to use the direct beam solution for the
!     delta-eddington radiation or the diffuse beam
!     radiation solution.
!  </IN>
!  <IN NAME="w0" TYPE="real">
!    Single scattering albedo in 4 bands [ dimensionless ]
!  </IN>
!  <IN NAME="gg" TYPE="real">
!    Asymmetry parameter in 4 bands  [ dimensionless ]
!  </IN>
!  <IN NAME="coszen" TYPE="real">
!    Cosine of the zenith angle  [ dimensionless ]
!  </IN>
!  <INOUT NAME="r_uv" TYPE="real">
!    Cloud reflectance in uv band
!  </INOUT>
!  <INOUT NAME="r_nir" TYPE="real">
!    Cloud reflectance in nir band
!  </INOUT>
!  <INOUT NAME="ab_nir" TYPE="real">
!    Cloud absorption in nir band
!  </INOUT>
!  <INOUT NAME="ab_uv" TYPE="real">
!    Cloud absorption in uv band
!  </INOUT>
! </SUBROUTINE>

SUBROUTINE CLOUD_RAD_k_diag(tau, direct, w0,gg,coszen,r_uv,r_nir,ab_uv,ab_nir)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following radiative properties
!      for each cloud:
!
!               1. r_uv : cloud reflectance in uv band
!               2. r_nir: cloud reflectance in nir band
!               3. ab_uv: cloud absorption in uv band
!               4. ab_nir:cloud absorption in nir band
!               
!
!      These quantities are computed by dividing the shortwave
!      spectrum into 4 bands and then computing the reflectance
!      and absorption for each band individually and then setting
!      the uv reflectance and absorption equal to that of band
!      1 and the nir reflectance and absorption equal to the
!      spectrum weighted results of bands 2,3,and 4.  The limits
!      of bands are described in CLOUD_OPTICAL_PROPERTIES.
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!
!       tau          Optical depth in 4 bands (dimensionless)
!       direct       Logical variable for each cloud indicating whether
!                      or not to use the direct beam solution for the
!                      delta-eddington radiation or the diffuse beam
!                      radiation solution.
!       w0           Single scattering albedo in 4 bands (dimensionless)
!       gg           Asymmetry parameter in 4 bands (dimensionless)
!       coszen       Cosine of the zenith angle
!
!       ------
!INPUT/OUTPUT:
!       ------
!
!       r_uv         Cloud reflectance in uv band
!       r_nir        Cloud reflectance in nir band
!       ab_uv        Cloud absorption in uv band
!       ab_nir       Cloud absorption in nir band
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!      tau_local    optical depth for the band being solved
!      w0_local     single scattering albedo for the band being solved
!      g_local      asymmetry parameter for the band being solved
!      coszen_3d    3d version of coszen
!      I            looping variable
!      iband        looping variables over band number
!      taucum       cumulative sum of visible optical depth
!      g_prime      scaled g
!      w0_prime     scaled w0
!      tau_prime    scaled tau
!      crit         variable equal to 1./(4 - 3g')
!      AL           variable equal to sqrt(3*(1-w0')*(1-w0'*g'))
!      ALPHV        temporary work variable
!      GAMV         temporary work variable
!      T1V          exp( -1.*AL * tau')
!      trans_dir    direct radiation beam transmittance
!      U            1.5 * (1. - w0'*g')/AL
!      r_diffus     diffuse beam reflection
!      trans_diffus diffuse beam transmission
!
!      r            cloud reflectance for each cloud in each band
!      ab           cloud absorption for each cloud in each band
!      r_dir_uv       direct beam reflection for uv band
!      r_dir_nir      direct beam reflection for nir band
!      trans_dir_uv   direct beam transmission for uv band
!      trans_dir_nir  direct beam transmission for uv band
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

REAL,     INTENT (IN), DIMENSION(:,:,:,:):: tau,w0,gg
REAL,     INTENT (IN), DIMENSION(:,:)    :: coszen
REAL,     INTENT (INOUT),DIMENSION(:,:,:):: r_uv,r_nir,ab_uv,ab_nir
logical,  INTENT (IN   ),DIMENSION(:,:,:):: direct                        

!  Internal variables
!  ------------------

INTEGER                                  :: I,iband
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: coszen_3d
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: tau_local
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: w0_local,g_local
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: g_prime,w0_prime
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: tau_prime,crit,AL
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: ALPHV,GAMV,T1V,U
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: r_diffus
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: trans_diffus
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: r_dir,trans_dir
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3),SIZE(tau,4)) :: r,ab

!
! Code
! ----

        ! reinitialize variables
        r_uv(:,:,:) = 0.
        r_nir(:,:,:)= 0.
        ab_uv(:,:,:)= 0.
        ab_nir(:,:,:)=0.

        !create 3d zenith angle
        DO I = 1, SIZE(tau,3)
               coszen_3d(:,:,I)=coszen(:,:)
        END DO
        WHERE (coszen_3d(:,:,:) .lt. 1.E-06)
                coszen_3d(:,:,:) = 1.E-06
        END WHERE

        

    !----------------- LOOP OVER BAND -----------------------------!

    DO iband = 1, SIZE(tau,4)

        !-----------------------------------------------------------
        !  assign w0, g, tau to the value appropriate for the band

        w0_local(:,:,:) = w0(:,:,:,iband)
        tau_local(:,:,:)= tau(:,:,:,iband)
        g_local(:,:,:) =  gg(:,:,:,iband)

        !-------------------------------------------------------------------
        ! for delta-Eddington scaled ('prime') g, w0, tau where:
        !
        !               g' = g / (1 + g)
        !              w0' = (1 - g*g) * w0 / (1 - w*g*g)
        !             tau' = (1 - w*g*g) * tau
        !

                 tau_prime(:,:,:) = 1. - &
                      (w0_local(:,:,:)*g_local(:,:,:)*g_local(:,:,:))
                 w0_prime(:,:,:) = w0_local(:,:,:) * &
                   (1. - (g_local(:,:,:)*g_local(:,:,:)))/tau_prime(:,:,:)
                 tau_prime(:,:,:) = tau_prime(:,:,:) * tau_local(:,:,:)
                 g_prime(:,:,:) = g_local(:,:,:) / (1. + g_local(:,:,:))

        !-------------------------------------------------------------------
        ! create other variables
        !
        !        crit = 1./(4 - 3g')
        !
        !      and where w0' < crit set w0' = crit
        !
        !        AL = sqrt( 3. * (1. - w0') * (1. - w0'*g') )
        !

                 crit(:,:,:) = 1./(4.- 3.*g_prime(:,:,:))

                 WHERE (w0_prime(:,:,:) .lt. crit(:,:,:) )
                           w0_prime(:,:,:) = crit(:,:,:)
                 END WHERE

                 AL(:,:,:) =  ( 3. * (1. - w0_prime(:,:,:) ) &
                    * (1. - (w0_prime(:,:,:)*g_prime(:,:,:)))  )**0.5

                 !set up a minimum to AL
                 WHERE (AL(:,:,:) .lt. 1.E-06)
                        AL(:,:,:) = 1.E-06
                 END WHERE


        !-------------------------------------------------------------------
        ! simplifications if not two stream
        !
        !        ALPHV = 0.75*w0'*coszen*(1.+g'(1.-w0'))/
        !                          (1.-(AL*coszen)**2.)
        !        GAMV = 0.5*w0'*(3.*g'*(1.-w0')*coszen*coszen + 1.)/
        !                          (1.-(AL*coszen)**2.)
        !

        IF (.NOT. l2strem) THEN


                ALPHV(:,:,:) = 0.75 * w0_prime(:,:,:)*coszen_3d(:,:,:) * &
                 (1. + (g_prime(:,:,:)*(1. - w0_prime(:,:,:)))) / &
                 (1. - (AL(:,:,:)*coszen_3d(:,:,:))**2.0)

                GAMV(:,:,:) =  0.50 * w0_prime(:,:,:) * &
                (  (3.* g_prime(:,:,:) * (1. - w0_prime(:,:,:)) * &
                    coszen_3d(:,:,:) * coszen_3d(:,:,:)) + 1. ) / &
                 (1. - (AL(:,:,:)*coszen_3d(:,:,:))**2.0)

        END IF


        !-------------------------------------------------------------------
        ! calculate T1V
        !
        !    T1V = exp (-1* AL * tau' )


                  T1V(:,:,:) = exp( -1.*AL(:,:,:) * tau_prime(:,:,:) )


        !-------------------------------------------------------------------
        !calculate diffuse beam reflection and transmission
        !

        !first calculate U  = 1.5 * (1. - w0'*g')/AL
        U(:,:,:) = 1.5 *(1. - w0_prime(:,:,:)*g_prime(:,:,:))/AL(:,:,:)

        !initialize variables
        r_diffus(:,:,:)= 0.
        trans_diffus(:,:,:) = 1.



        trans_diffus(:,:,:) = 4. * U(:,:,:) * T1V(:,:,:) / &
            ( ( (U(:,:,:)+1.) * (U(:,:,:)+1.)  ) - &
              ( (U(:,:,:)-1.) * (U(:,:,:)-1.) * &
                   T1V(:,:,:) *   T1V(:,:,:)   )    )

        r_diffus(:,:,:) =     ((U(:,:,:)*U(:,:,:))-1.) * &
                   ( 1. -   (T1V(:,:,:)*T1V(:,:,:)) ) / &
             ( ( (U(:,:,:)+1.) * (U(:,:,:)+1.)  ) - &
               ( (U(:,:,:)-1.) * (U(:,:,:)-1.) * &
                    T1V(:,:,:) *   T1V(:,:,:)   )    )



        !-------------------------------------------------------------------
        ! calculate direct bean transmission
        !
        !
        IF (.NOT. l2strem) THEN


            !initialize variables
            trans_dir(:,:,:) = 1.
            r_dir(:,:,:) = 0.

            r_dir(:,:,:) = ( (ALPHV(:,:,:) - GAMV(:,:,:)) * &
               exp(-1.*tau_prime(:,:,:)/coszen_3d(:,:,:)) * &
               trans_diffus(:,:,:) ) +  &
              ( (ALPHV(:,:,:) + GAMV(:,:,:)) * &
              r_diffus(:,:,:) )  -  (ALPHV(:,:,:) - GAMV(:,:,:))

            trans_dir(:,:,:) = &
              ( (ALPHV(:,:,:)+GAMV(:,:,:))*trans_diffus(:,:,:) ) + &
              ( exp(-1.*tau_prime(:,:,:)/coszen_3d(:,:,:)) * &
              ( ( (ALPHV(:,:,:)-GAMV(:,:,:))*r_diffus(:,:,:) ) - &
                (ALPHV(:,:,:)+GAMV(:,:,:)) + 1. )   )

        END IF


        !-------------------------------------------------------------------
        ! patch together final solution
        !
        !


        IF (l2strem) THEN

             !two-stream solution
             r(:,:,:,iband) = r_diffus(:,:,:)
             ab(:,:,:,iband) = 1. - trans_diffus(:,:,:) - r_diffus(:,:,:)

        ELSE

             !delta-Eddington solution
             WHERE (.not. direct)

                   r(:,:,:,iband) = r_diffus(:,:,:)
                   ab(:,:,:,iband) = 1. - trans_diffus(:,:,:) &
                                     - r_diffus(:,:,:)


             END WHERE

             WHERE (direct)

                   r(:,:,:,iband) = r_dir(:,:,:)
                   ab(:,:,:,iband) = 1. - trans_dir(:,:,:) &
                                     - r_dir(:,:,:)

             END WHERE

        END IF

    !----------------- END LOOP OVER BAND -----------------------------!

    END DO


    !----------------- CREATE SUM OVER BAND ---------------------------!

    r_uv(:,:,:) = r(:,:,:,1)
    ab_uv(:,:,:) = ab(:,:,:,1)

    r_nir(:,:,:) =  (  0.326158 * r(:,:,:,2) + &
                       0.180608 * r(:,:,:,3) + &
                       0.033474 * r(:,:,:,4) ) / 0.540240

    ab_nir(:,:,:) =  (  0.326158 * ab(:,:,:,2) + &
                        0.180608 * ab(:,:,:,3) + &
                        0.033474 * ab(:,:,:,4) ) / 0.540240


        !-------------------------------------------------------------------
        ! guarantee that clouds for tau = 0. have the properties
        ! of no cloud

        
        WHERE(tau(:,:,:,1) .le. 0.)
             r_uv(:,:,:) = 0.
             ab_uv(:,:,:)= 0.                       
        END WHERE
        WHERE((tau(:,:,:,2)+tau(:,:,:,3)+tau(:,:,:,4)) .le. 0.)
             r_nir(:,:,:)= 0.
             ab_nir(:,:,:)=0.
        END WHERE       

        !-------------------------------------------------------------------
        ! guarantee that for coszen lt. or equal to zero that solar
        ! reflectances and absorptances are equal to zero.
        DO I = 1, SIZE(tau,3)
               WHERE (coszen(:,:) .lt. 1.E-06)
                    r_uv(:,:,I) = 0. 
                    ab_uv(:,:,I) = 0.
                    r_nir(:,:,I) = 0.
                    ab_nir(:,:,I) = 0.
               END WHERE
        END DO
        
        !-------------------------------------------------------------------
        ! guarantee that each cloud has some transmission by reducing
        ! the actual cloud reflectance in uv and nir band
        ! this break is necessary to avoid the rest of the
        ! radiation code from breaking up.
        !

        WHERE ( (1. - r_uv(:,:,:) - ab_uv(:,:,:)) .lt. 0.01)
                      r_uv(:,:,:) = r_uv(:,:,:) - 0.01
        END WHERE
        WHERE ( (1. - r_nir(:,:,:) - ab_nir(:,:,:)) .lt. 0.01)
                      r_nir(:,:,:) = r_nir(:,:,:) - 0.01
        END WHERE

        !-------------------------------------------------------------------
        ! guarantee that cloud reflectance and absorption are greater than
        ! or equal to zero

        WHERE (r_uv(:,:,:) .lt. 0.)
               r_uv(:,:,:) = 0.
        END WHERE
        WHERE (r_nir(:,:,:) .lt. 0.)
               r_nir(:,:,:) = 0.
        END WHERE
        WHERE (ab_uv(:,:,:) .lt. 0.)
               ab_uv(:,:,:) = 0.
        END WHERE
        WHERE (ab_nir(:,:,:) .lt. 0.)
               ab_nir(:,:,:) = 0.
        END WHERE


END SUBROUTINE CLOUD_RAD_k_diag



!#####################################################################

! <SUBROUTINE NAME="cloud_rad_k">
!  <OVERVIEW>
!    Subroutine cloud_rad_k calculates the cloud reflectances and
!    absorptions in the uv and nir wavelength bands. These quantities 
!    are computed by dividing the shortwave spectrum into 4 bands and 
!    then computing the reflectance and absorption for each band 
!    individually and then setting the uv reflectance and absorption 
!    equal to that of band 1 and the nir reflectance and absorption 
!    equal to the spectrum-weighted results of bands 2,3,and 4.  The 
!    limits of bands are defined in subroutine sw_optical_properties.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    Subroutine cloud_rad_k calculates the cloud reflectances and
!    absorptions in the uv and nir wavelength bands. These quantities 
!    are computed by dividing the shortwave spectrum into 4 bands and 
!    then computing the reflectance and absorption for each band 
!    individually and then setting the uv reflectance and absorption 
!    equal to that of band 1 and the nir reflectance and absorption 
!    equal to the spectrum-weighted results of bands 2,3,and 4.  The 
!    limits of bands are defined in subroutine sw_optical_properties.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_rad_k (tau, w0, gg, coszen, r_uv, r_nir,    &
!                     ab_nir, ab_uv_out)
!
!  </TEMPLATE>
!  <IN NAME="tau" TYPE="real">
!    Optical depth [ dimensionless ]
!  </IN>
!  <IN NAME="w0" TYPE="real">
!    Single scattering albedo [ dimensionless ]
!  </IN>
!  <IN NAME="gg" TYPE="real">
!    Asymmetry parameter for each band
!    [ dimensionless ]
!  </IN>
!  <IN NAME="coszen" TYPE="real">
!    Cosine of zenith angle  [ dimensionless ]
!  </IN>
!  <INOUT NAME="r_uv" TYPE="real">
!    Cloud reflectance in uv band
!  </INOUT>
!  <INOUT NAME="r_nir" TYPE="real">
!    Cloud reflectance in nir band
!  </INOUT>
!  <INOUT NAME="ab_nir" TYPE="real">
!    Cloud absorption in nir band
!  </INOUT>
!  <INOUT NAME="ab_uv_out" TYPE="real, optional">
!    Cloud absorption in uv band
!  </INOUT>
! </SUBROUTINE>
!
subroutine cloud_rad_k (tau, w0, gg, coszen, r_uv, r_nir,    &
                        ab_nir, ab_uv_out)

!----------------------------------------------------------------------
!    subroutine cloud_rad_k calculates the cloud reflectances and
!    absorptions in the uv and nir wavelength bands. these quantities 
!    are computed by dividing the shortwave spectrum into 4 bands and 
!    then computing the reflectance and absorption for each band 
!    individually and then setting the uv reflectance and absorption 
!    equal to that of band 1 and the nir reflectance and absorption 
!    equal to the spectrum-weighted results of bands 2,3,and 4.  The 
!    limits of bands are defined in subroutine sw_optical_properties.
!----------------------------------------------------------------------

real, dimension(:,:,:,:), intent(in)             :: tau, w0, gg
real, dimension(:,:),     intent(in)             :: coszen
real, dimension(:,:,:),   intent(inout)          :: r_uv, r_nir, ab_nir
real, dimension(:,:,:),   intent(inout),optional :: ab_uv_out

!---------------------------------------------------------------------
!   intent(in) variables:
!
!         tau            Optical depth [ dimensionless ]
!         w0             Single scattering albedo [ dimensionless ]
!         gg             Asymmetry parameter for each band
!                        [ dimensionless ]
!         coszen         Cosine of zenith angle  [ dimensionless ]
!
!    intent(inout) variables:
!
!         r_uv            Cloud reflectance in uv band
!         r_nir           Cloud reflectance in nir band
!         ab_nir          Cloud absorption in nir band
!
!    intent(inout), optional variables:
!
!         ab_uv_out       Cloud absorption in uv band
! 
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real,    dimension (size(tau,1), size(tau,2)) :: taucum

      logical, dimension (size(tau,1), size(tau,2),                 &
                                       size(tau,3)) :: direct

      real,    dimension (size(tau,1), size(tau,2),                  &
                                       size(tau,3)) ::              &
                          coszen_3d, tau_local, w0_local, g_local, &
                          g_prime, w0_prime, tau_prime, crit, al,   &
                          alphv, gamv, t1v, u, denom, r_diffus,   &
                          trans_diffus, r_dir, trans_dir, ab_uv

      real, dimension (size(tau,1), size(tau,2),                    &
                       size(tau,3), size(tau,4)) :: r, ab

      integer   :: iband, k

!---------------------------------------------------------------------
!   local variables:
!
!     taucum       cumulative sum of visible optical depth from top
!                  of atmosphere to current layer
!     direct       logical variable for each cloud indicating whether
!                  or not to use the direct beam solution for the
!                  delta-eddington radiation or the diffuse beam
!                  radiation solution.
!      coszen_3d    3d version of coszen
!      tau_local    optical depth for the band being solved
!      w0_local     single scattering albedo for the band being solved
!      g_local      asymmetry parameter for the band being solved
!      g_prime      scaled g
!      w0_prime     scaled w0
!      tau_prime    scaled tau
!      crit         variable equal to 1./(4 - 3g')
!      al           variable equal to sqrt(3*(1-w0')*(1-w0'*g'))
!      alphv        temporary work variable
!      gamv         temporary work variable
!      t1v          exp( -1.*AL * tau')
!      u            1.5 * (1. - w0'*g')/AL
!      denom        [(u+1)*(u+1)] - [(u-1)*(u-1)*t1v*t1v]
!      r_diffus     diffuse beam reflection
!      trans_diffus diffuse beam transmission
!      r_dir        diffuse beam reflection
!      trans_dir    direct radiation beam transmittance
!      ab_uv        cloud absorption in uv band
!      r            cloud reflectance for each cloud in each band
!      ab           cloud absorption for each cloud in each band
!      i,j,k,iband  do-loop indices
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    define some values needed when the delta-eddington approach is
!    being taken.
!-------------------------------------------------------------------
      if (.not. l2strem) then

!--------------------------------------------------------------------
!    create 3d version of zenith angle array. allow it to be no 
!    smaller than 1.0e-06.
!--------------------------------------------------------------------
        do k=1,size(tau,3)
          coszen_3d(:,:,k) = coszen(:,:)
        end do
        where (coszen_3d(:,:,:) < 1.E-06) 
          coszen_3d(:,:,:) = 1.E-06
        end where
        
!--------------------------------------------------------------------
!    initialize taucum and direct. taucum will be the accumulated tau
!    from model top to the current level and will be the basis of
!    deciding whether the incident beam is treated as direct or diffuse.
!--------------------------------------------------------------------
        taucum(:,:) = 0.
        direct(:,:,:) = .true.
        do k=1,size(tau,3)      

!---------------------------------------------------------------------
!    find if taucum from model top to level above has exceeded taucrit.
!----------------------------------------------------------------------
          where (taucum(:,:) > taucrit)
            direct(:,:,k) = .false.
          end where

!---------------------------------------------------------------------
!    increment the cumulative tau.
!---------------------------------------------------------------------
          taucum(:,:) = taucum(:,:) + tau(:,:,k,1)
        end do
      endif 

!---------------------------------------------------------------------
!    loop over the wavelength bands, calculating the reflectivity 
!    and absorption for each band.
!---------------------------------------------------------------------
      do iband=1,size(tau,4)

!---------------------------------------------------------------------
!    assign local values of w0, g and  tau appropriate for the current
!    band under consideration.
!---------------------------------------------------------------------
        w0_local (:,:,:) = w0 (:,:,:,iband)
        tau_local(:,:,:) = tau(:,:,:,iband)
        g_local  (:,:,:) = gg (:,:,:,iband)

!---------------------------------------------------------------------
!    define the scaled (prime) values of g, w0 and tau used in the 
!    delta-Eddington calculation:
!               g' = g / (1 + g)
!              w0' = (1 - g*g) * w0 / (1 - w*g*g)
!             tau' = (1 - w*g*g) * tau
!---------------------------------------------------------------------
        tau_prime(:,:,:) = 1. - (w0_local(:,:,:)*g_local(:,:,:)*   &
                                 g_local(:,:,:))
        w0_prime(:,:,:) = w0_local(:,:,:)*(1. - (g_local(:,:,:)*    &
                          g_local(:,:,:)))/tau_prime(:,:,:)
        tau_prime(:,:,:) = tau_prime(:,:,:)*tau_local(:,:,:)
        g_prime(:,:,:) = g_local(:,:,:)/(1. + g_local(:,:,:))

!-------------------------------------------------------------------
!    define other variables:
!      crit = 1./(4 - 3g')  and where w0' < crit set w0' = crit
!      al = sqrt( 3. * (1. - w0') * (1. - w0'*g') ) and where 
!      al < 1.0e-06, set al = 1.0e-06.
!--------------------------------------------------------------------
        crit(:,:,:) = 1./(4.- 3.*g_prime(:,:,:))
        where (w0_prime(:,:,:) < crit(:,:,:) )
          w0_prime(:,:,:) = crit(:,:,:)
        end where
        al(:,:,:) = (3.*(1. - w0_prime(:,:,:) ) *      &
                    (1. - (w0_prime(:,:,:)*g_prime(:,:,:))) )**0.5
        where (al(:,:,:) < 1.E-06)
          al(:,:,:) = 1.E-06
        end where

!--------------------------------------------------------------------
!    calculate t1v:
!    t1v = exp (-1* al * tau')
!--------------------------------------------------------------------
        t1v(:,:,:) = exp(-1.*al(:,:,:)*tau_prime(:,:,:))

!-------------------------------------------------------------------
!    calculate diffuse beam reflection and transmission. first calculate
!    the factor u  = 1.5 * (1. - w0'*g')/al and the value denom =
!    [ (u+1)*(u+1) - (u-1)*(u-1)*t1v*t1v ].
!---------------------------------------------------------------------
        u(:,:,:) = 1.5*(1. - w0_prime(:,:,:)*g_prime(:,:,:))/al(:,:,:)
        denom(:,:,:) = ( ( (u(:,:,:) + 1.)*(u(:,:,:) + 1.) ) - &
                         ( (u(:,:,:) - 1.)*(u(:,:,:) - 1.)* &
                            t1v(:,:,:)*t1v(:,:,:)   )    )
        trans_diffus(:,:,:) = 4.*u(:,:,:)*t1v(:,:,:)/denom(:,:,:)
        r_diffus(:,:,:) = ((u(:,:,:)*u(:,:,:)) - 1.) * &
                          (1. - (t1v(:,:,:)*t1v(:,:,:)) )/denom(:,:,:)

!-------------------------------------------------------------------
!    calculate direct beam transmission for the delta-eddington case.
!    alphv = 0.75*w0'*coszen*(1.+g'(1.-w0'))/
!            (1.-(al*coszen)**2.)
!    gamv = 0.5*w0'*(3.*g'*(1.-w0')*coszen*coszen + 1.)/
!           (1.-(al*coszen)**2.)
!-------------------------------------------------------------------
        if (.not. l2strem) then
          where (direct)
            alphv(:,:,:) = 0.75 * w0_prime(:,:,:)*coszen_3d(:,:,:)* &
                           (1. + (g_prime(:,:,:)*    &
                           (1. - w0_prime(:,:,:))))/ &
                           (1. - (al(:,:,:)*coszen_3d(:,:,:))**2)
            gamv(:,:,:) =  0.50 * w0_prime(:,:,:)* &
                           (  (3.* g_prime(:,:,:)*(1. -     &
                           w0_prime(:,:,:))*&
                           coszen_3d(:,:,:)*coszen_3d(:,:,:)) + 1. )/ &
                           (1. - (al(:,:,:)*coszen_3d(:,:,:))**2)
            r_dir(:,:,:) = ( (alphv(:,:,:) - gamv(:,:,:)) * &
                           exp(-1.*tau_prime(:,:,:)/coszen_3d(:,:,:))* &
                           trans_diffus(:,:,:) ) + ((alphv(:,:,:) +   &
                           gamv(:,:,:)) * r_diffus(:,:,:) )  -  &
                           (alphv(:,:,:) - gamv(:,:,:))
            trans_dir(:,:,:) = ( (alphv(:,:,:) + gamv(:,:,:))*  &
                               trans_diffus(:,:,:) ) + &
                               (exp(-1.*tau_prime(:,:,:)/   &
                                coszen_3d(:,:,:)) * &
                                ( ( (alphv(:,:,:) - gamv(:,:,:))*  &
                                r_diffus(:,:,:) ) - (alphv(:,:,:) + &
                                gamv(:,:,:)) + 1. )   )
          end where
        endif 

!-------------------------------------------------------------------
!    patch together final solution.
!-------------------------------------------------------------------
        if (l2strem) then

!---------------------------------------------------------------------
!    two-stream solution.
!---------------------------------------------------------------------
          r(:,:,:,iband)  = r_diffus(:,:,:)
          ab(:,:,:,iband) = 1. - trans_diffus(:,:,:) - r_diffus(:,:,:)
        else

!----------------------------------------------------------------------
!    delta-eddington solution.
!----------------------------------------------------------------------
          where (.not. direct)
            r (:,:,:,iband) = r_diffus(:,:,:)
            ab(:,:,:,iband) = 1. - trans_diffus(:,:,:) - r_diffus(:,:,:)
          end where
          where (direct)
            r (:,:,:,iband) = r_dir(:,:,:)
            ab(:,:,:,iband) = 1. - trans_dir(:,:,:) - r_dir(:,:,:)
          end where
        endif 
      end do  ! (iband loop)


!---------------------------------------------------------------------
!    sum over the apprpriate bands to obtain values for the uv and nir
!    bands.
!----------------------------------------------------------------------

      r_uv (:,:,:) = r (:,:,:,1)
      ab_uv(:,:,:) = ab(:,:,:,1)
      r_nir(:,:,:) = ( 0.326158*r(:,:,:,2) + &
                       0.180608*r(:,:,:,3) + &
                       0.033474*r(:,:,:,4) ) / 0.540240
      ab_nir(:,:,:) =  ( 0.326158*ab(:,:,:,2) + &
                         0.180608*ab(:,:,:,3) + &
                         0.033474*ab(:,:,:,4) ) / 0.540240

!-------------------------------------------------------------------
!    guarantee that when tau = 0., the sw properties are clear-sky 
!    values.
!-------------------------------------------------------------------
      where (tau(:,:,:,1) <= 0.)
        r_uv (:,:,:) = 0.
        ab_uv(:,:,:) = 0.                       
      end where
      where ((tau(:,:,:,2) + tau(:,:,:,3) + tau(:,:,:,4)) <= 0.)
        r_nir (:,:,:) = 0.
        ab_nir(:,:,:) = 0.
      end where       

!-------------------------------------------------------------------
!    guarantee that for coszen .le. 1.0E-6 that solar reflectances and 
!    absorptances are equal to zero.
!-------------------------------------------------------------------
      do k=1,size(tau,3)
        where (coszen(:,:) < 1.E-06)
          r_uv  (:,:,k) = 0. 
          ab_uv (:,:,k) = 0.
          r_nir (:,:,k) = 0.
          ab_nir(:,:,k) = 0.
        end where
      end do
        
!-------------------------------------------------------------------
!    guarantee that each cloud has some transmission by reducing the 
!    actual cloud reflectance. this break is necessary to avoid the 
!    rest of the radiation code from breaking up.
!---------------------------------------------------------------------
      where ( (1. - r_uv(:,:,:) - ab_uv(:,:,:)) < 0.01)
        r_uv(:,:,:) = r_uv(:,:,:) - 0.01
      end where
      where ( (1. - r_nir(:,:,:) - ab_nir(:,:,:)) < 0.01)
        r_nir(:,:,:) = r_nir(:,:,:) - 0.01
      end where

!-------------------------------------------------------------------
!    guarantee that cloud reflectance and absorption are .ge. 0.0.
!-------------------------------------------------------------------
      where (r_uv(:,:,:) < 0.)
        r_uv(:,:,:) = 0.
      end where
      where (r_nir(:,:,:) < 0.)
        r_nir(:,:,:) = 0.
      end where
      where (ab_uv(:,:,:) < 0.)
        ab_uv(:,:,:) = 0.
      end where
      where (ab_nir(:,:,:) < 0.)
        ab_nir(:,:,:) = 0.
      end where

!--------------------------------------------------------------------
!    if ab_uv is desired as an output variable from this subroutine,
!    fill the variable being returned.
!--------------------------------------------------------------------
      if (present (ab_uv_out)) then
        ab_uv_out = ab_uv
      endif

!----------------------------------------------------------------------



end subroutine cloud_rad_k


!#####################################################################

SUBROUTINE CLOUD_RAD(tau,w0,gg,coszen,r_uv,r_nir,ab_uv,ab_nir)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following radiative properties
!      for each cloud:
!
!               1. r_uv : cloud reflectance in uv band
!               2. r_nir: cloud reflectance in nir band
!               3. ab_uv: cloud absorption in uv band
!               4. ab_nir:cloud absorption in nir band
!               
!
!      These quantities are computed by dividing the shortwave
!      spectrum into 4 bands and then computing the reflectance
!      and absorption for each band individually and then setting
!      the uv reflectance and absorption equal to that of band
!      1 and the nir reflectance and absorption equal to the
!      spectrum weighted results of bands 2,3,and 4.  The limits
!      of bands are described in CLOUD_OPTICAL_PROPERTIES.
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!
!       tau          optical depth in 4 bands (dimensionless)
!       w0           single scattering albedo in 4 bands (dimensionless)
!       gg           asymmetry parameter in 4 bands (dimensionless)
!       coszen       cosine of the zenith angle
!
!       ------
!INPUT/OUTPUT:
!       ------
!
!       r_uv         cloud reflectance in uv band
!       r_nir        cloud reflectance in nir band
!       ab_uv        cloud absorption in uv band
!       ab_nir       cloud absorption in nir band
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!      direct       logical variable for each cloud indicating whether
!                       or not to use the direct beam solution for the
!                       delta-eddington radiation or the diffuse beam
!                       radiation solution.
!      tau_local    optical depth for the band being solved
!      w0_local     single scattering albedo for the band being solved
!      g_local      asymmetry parameter for the band being solved
!      coszen_3d    3d version of coszen
!      I            looping variable
!      iband        looping variables over band number
!      taucum       cumulative sum of visible optical depth
!      g_prime      scaled g
!      w0_prime     scaled w0
!      tau_prime    scaled tau
!      crit         variable equal to 1./(4 - 3g')
!      AL           variable equal to sqrt(3*(1-w0')*(1-w0'*g'))
!      ALPHV        temporary work variable
!      GAMV         temporary work variable
!      T1V          exp( -1.*AL * tau')
!      trans_dir    direct radiation beam transmittance
!      U            1.5 * (1. - w0'*g')/AL
!      r_diffus     diffuse beam reflection
!      trans_diffus diffuse beam transmission
!
!      r            cloud reflectance for each cloud in each band
!      ab           cloud absorption for each cloud in each band
!      r_dir_uv       direct beam reflection for uv band
!      r_dir_nir      direct beam reflection for nir band
!      trans_dir_uv   direct beam transmission for uv band
!      trans_dir_nir  direct beam transmission for uv band
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

REAL,     INTENT (IN), DIMENSION(:,:,:,:):: tau,w0,gg
REAL,     INTENT (IN), DIMENSION(:,:)    :: coszen
REAL,     INTENT (INOUT),DIMENSION(:,:,:):: r_uv,r_nir,ab_uv,ab_nir

!  Internal variables
!  ------------------

INTEGER                                  :: I,iband
REAL,    DIMENSION(SIZE(tau,1),SIZE(tau,2)) :: taucum
LOGICAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: direct
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: coszen_3d
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: tau_local
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: w0_local,g_local
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: g_prime,w0_prime
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: tau_prime,crit,AL
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: ALPHV,GAMV,T1V,U
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: r_diffus
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: trans_diffus
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3)) :: r_dir,trans_dir
REAL, DIMENSION(SIZE(tau,1),SIZE(tau,2),SIZE(tau,3),SIZE(tau,4)) :: r,ab

!
! Code
! ----

        ! reinitialize variables
        r_uv(:,:,:) = 0.
        r_nir(:,:,:)= 0.
        ab_uv(:,:,:)= 0.
        ab_nir(:,:,:)=0.

        !create 3d zenith angle
        DO I = 1, SIZE(tau,3)
               coszen_3d(:,:,I)=coszen(:,:)
        END DO
        WHERE (coszen_3d(:,:,:) .lt. 1.E-06)
                coszen_3d(:,:,:) = 1.E-06
        END WHERE

        
        !------------------------------------------------------------------
        !do logical variable to determine where total cloud optical depth
        !at uv wavelengths exceeds taucrit
        IF (.NOT. l2strem) THEN

                !---- initialize taucum and direct
                taucum(:,:)=0.
                direct(:,:,:)=.TRUE.

                DO I = 1, SIZE(tau,3)

                      !find if taucum to levels above has exceeded taucrit
                      WHERE (taucum(:,:) .gt. taucrit)
                            direct(:,:,I)=.FALSE.
                      END WHERE

                      !increment cumulative tau
                      taucum(:,:)=taucum(:,:)+tau(:,:,I,1)

                END DO
        END IF

    !----------------- LOOP OVER BAND -----------------------------!

    DO iband = 1, SIZE(tau,4)

        !-----------------------------------------------------------
        !  assign w0, g, tau to the value appropriate for the band

        w0_local(:,:,:) = w0(:,:,:,iband)
        tau_local(:,:,:)= tau(:,:,:,iband)
        g_local(:,:,:) =  gg(:,:,:,iband)

        !-------------------------------------------------------------------
        ! for delta-Eddington scaled ('prime') g, w0, tau where:
        !
        !               g' = g / (1 + g)
        !              w0' = (1 - g*g) * w0 / (1 - w*g*g)
        !             tau' = (1 - w*g*g) * tau
        !

                 tau_prime(:,:,:) = 1. - &
                      (w0_local(:,:,:)*g_local(:,:,:)*g_local(:,:,:))
                 w0_prime(:,:,:) = w0_local(:,:,:) * &
                   (1. - (g_local(:,:,:)*g_local(:,:,:)))/tau_prime(:,:,:)
                 tau_prime(:,:,:) = tau_prime(:,:,:) * tau_local(:,:,:)
                 g_prime(:,:,:) = g_local(:,:,:) / (1. + g_local(:,:,:))

        !-------------------------------------------------------------------
        ! create other variables
        !
        !        crit = 1./(4 - 3g')
        !
        !      and where w0' < crit set w0' = crit
        !
        !        AL = sqrt( 3. * (1. - w0') * (1. - w0'*g') )
        !

                 crit(:,:,:) = 1./(4.- 3.*g_prime(:,:,:))

                 WHERE (w0_prime(:,:,:) .lt. crit(:,:,:) )
                           w0_prime(:,:,:) = crit(:,:,:)
                 END WHERE

                 AL(:,:,:) =  ( 3. * (1. - w0_prime(:,:,:) ) &
                    * (1. - (w0_prime(:,:,:)*g_prime(:,:,:)))  )**0.5

                 !set up a minimum to AL
                 WHERE (AL(:,:,:) .lt. 1.E-06)
                        AL(:,:,:) = 1.E-06
                 END WHERE


        !-------------------------------------------------------------------
        ! simplifications if not two stream
        !
        !        ALPHV = 0.75*w0'*coszen*(1.+g'(1.-w0'))/
        !                          (1.-(AL*coszen)**2.)
        !        GAMV = 0.5*w0'*(3.*g'*(1.-w0')*coszen*coszen + 1.)/
        !                          (1.-(AL*coszen)**2.)
        !

        IF (.NOT. l2strem) THEN


                ALPHV(:,:,:) = 0.75 * w0_prime(:,:,:)*coszen_3d(:,:,:) * &
                 (1. + (g_prime(:,:,:)*(1. - w0_prime(:,:,:)))) / &
                 (1. - (AL(:,:,:)*coszen_3d(:,:,:))**2.0)

                GAMV(:,:,:) =  0.50 * w0_prime(:,:,:) * &
                (  (3.* g_prime(:,:,:) * (1. - w0_prime(:,:,:)) * &
                    coszen_3d(:,:,:) * coszen_3d(:,:,:)) + 1. ) / &
                 (1. - (AL(:,:,:)*coszen_3d(:,:,:))**2.0)

        END IF


        !-------------------------------------------------------------------
        ! calculate T1V
        !
        !    T1V = exp (-1* AL * tau' )


                  T1V(:,:,:) = exp( -1.*AL(:,:,:) * tau_prime(:,:,:) )


        !-------------------------------------------------------------------
        !calculate diffuse beam reflection and transmission
        !

        !first calculate U  = 1.5 * (1. - w0'*g')/AL
        U(:,:,:) = 1.5 *(1. - w0_prime(:,:,:)*g_prime(:,:,:))/AL(:,:,:)

        !initialize variables
        r_diffus(:,:,:)= 0.
        trans_diffus(:,:,:) = 1.



        trans_diffus(:,:,:) = 4. * U(:,:,:) * T1V(:,:,:) / &
            ( ( (U(:,:,:)+1.) * (U(:,:,:)+1.)  ) - &
              ( (U(:,:,:)-1.) * (U(:,:,:)-1.) * &
                   T1V(:,:,:) *   T1V(:,:,:)   )    )

        r_diffus(:,:,:) =     ((U(:,:,:)*U(:,:,:))-1.) * &
                   ( 1. -   (T1V(:,:,:)*T1V(:,:,:)) ) / &
             ( ( (U(:,:,:)+1.) * (U(:,:,:)+1.)  ) - &
               ( (U(:,:,:)-1.) * (U(:,:,:)-1.) * &
                    T1V(:,:,:) *   T1V(:,:,:)   )    )



        !-------------------------------------------------------------------
        ! calculate direct bean transmission
        !
        !
        IF (.NOT. l2strem) THEN


            !initialize variables
            trans_dir(:,:,:) = 1.
            r_dir(:,:,:) = 0.

            r_dir(:,:,:) = ( (ALPHV(:,:,:) - GAMV(:,:,:)) * &
               exp(-1.*tau_prime(:,:,:)/coszen_3d(:,:,:)) * &
               trans_diffus(:,:,:) ) +  &
              ( (ALPHV(:,:,:) + GAMV(:,:,:)) * &
              r_diffus(:,:,:) )  -  (ALPHV(:,:,:) - GAMV(:,:,:))

            trans_dir(:,:,:) = &
              ( (ALPHV(:,:,:)+GAMV(:,:,:))*trans_diffus(:,:,:) ) + &
              ( exp(-1.*tau_prime(:,:,:)/coszen_3d(:,:,:)) * &
              ( ( (ALPHV(:,:,:)-GAMV(:,:,:))*r_diffus(:,:,:) ) - &
                (ALPHV(:,:,:)+GAMV(:,:,:)) + 1. )   )

        END IF


        !-------------------------------------------------------------------
        ! patch together final solution
        !
        !


        IF (l2strem) THEN

             !two-stream solution
             r(:,:,:,iband) = r_diffus(:,:,:)
             ab(:,:,:,iband) = 1. - trans_diffus(:,:,:) - r_diffus(:,:,:)

        ELSE

             !delta-Eddington solution
             WHERE (.not. direct)

                   r(:,:,:,iband) = r_diffus(:,:,:)
                   ab(:,:,:,iband) = 1. - trans_diffus(:,:,:) &
                                     - r_diffus(:,:,:)


             END WHERE

             WHERE (direct)

                   r(:,:,:,iband) = r_dir(:,:,:)
                   ab(:,:,:,iband) = 1. - trans_dir(:,:,:) &
                                     - r_dir(:,:,:)

             END WHERE

        END IF

    !----------------- END LOOP OVER BAND -----------------------------!

    END DO


    !----------------- CREATE SUM OVER BAND ---------------------------!

    r_uv(:,:,:) = r(:,:,:,1)
    ab_uv(:,:,:) = ab(:,:,:,1)

    r_nir(:,:,:) =  (  0.326158 * r(:,:,:,2) + &
                       0.180608 * r(:,:,:,3) + &
                       0.033474 * r(:,:,:,4) ) / 0.540240

    ab_nir(:,:,:) =  (  0.326158 * ab(:,:,:,2) + &
                        0.180608 * ab(:,:,:,3) + &
                        0.033474 * ab(:,:,:,4) ) / 0.540240


        !-------------------------------------------------------------------
        ! guarantee that clouds for tau = 0. have the properties
        ! of no cloud

        
        WHERE(tau(:,:,:,1) .le. 0.)
             r_uv(:,:,:) = 0.
             ab_uv(:,:,:)= 0.                       
        END WHERE
        WHERE((tau(:,:,:,2)+tau(:,:,:,3)+tau(:,:,:,4)) .le. 0.)
             r_nir(:,:,:)= 0.
             ab_nir(:,:,:)=0.
        END WHERE       

        !-------------------------------------------------------------------
        ! guarantee that for coszen lt. or equal to zero that solar
        ! reflectances and absorptances are equal to zero.
        DO I = 1, SIZE(tau,3)
               WHERE (coszen(:,:) .lt. 1.E-06)
                    r_uv(:,:,I) = 0. 
                    ab_uv(:,:,I) = 0.
                    r_nir(:,:,I) = 0.
                    ab_nir(:,:,I) = 0.
               END WHERE
        END DO
        
        !-------------------------------------------------------------------
        ! guarantee that each cloud has some transmission by reducing
        ! the actual cloud reflectance in uv and nir band
        ! this break is necessary to avoid the rest of the
        ! radiation code from breaking up.
        !

        WHERE ( (1. - r_uv(:,:,:) - ab_uv(:,:,:)) .lt. 0.01)
                      r_uv(:,:,:) = r_uv(:,:,:) - 0.01
        END WHERE
        WHERE ( (1. - r_nir(:,:,:) - ab_nir(:,:,:)) .lt. 0.01)
                      r_nir(:,:,:) = r_nir(:,:,:) - 0.01
        END WHERE

        !-------------------------------------------------------------------
        ! guarantee that cloud reflectance and absorption are greater than
        ! or equal to zero

        WHERE (r_uv(:,:,:) .lt. 0.)
               r_uv(:,:,:) = 0.
        END WHERE
        WHERE (r_nir(:,:,:) .lt. 0.)
               r_nir(:,:,:) = 0.
        END WHERE
        WHERE (ab_uv(:,:,:) .lt. 0.)
               ab_uv(:,:,:) = 0.
        END WHERE
        WHERE (ab_nir(:,:,:) .lt. 0.)
               ab_nir(:,:,:) = 0.
        END WHERE


END SUBROUTINE CLOUD_RAD

!######################################################################

! <SUBROUTINE NAME="sw_optical_properties">
!  <OVERVIEW>
!    sw_optical_properties computes the needed optical parameters and
!    then calls cloud_rad_k in order to compute the cloud radiative
!    properties.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    sw_optical_properties computes the needed optical parameters and
!    then calls cloud_rad_k in order to compute the cloud radiative
!    properties.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sw_optical_properties (nclds, lwp, iwp, reff_liq, reff_ice, &
!                               coszen, r_uv, r_nir, ab_nir)
!
!  </TEMPLATE>
!  <IN NAME="nclds" TYPE="integer">
!    Number of random overlapping clouds in column





!  </IN>
!  <IN NAME="lwp" TYPE="real">
!    Liquid water path [ kg / m**2 ]
!  </IN>
!  <IN NAME="iwp" TYPE="real">
!    Ice water path [ kg / m**2 ]
!  </IN>
!  <IN NAME="reff_liq" TYPE="real">
!    Effective cloud drop radius  used with
!    bulk cloud physics scheme [ microns ]
!  </IN>
!  <IN NAME="reff_ice" TYPE="real">
!    Effective ice crystal radius used with
!    bulk cloud physics scheme [ microns ]
!  </IN>
!  <IN NAME="coszen" TYPE="real">
!    Cosine of zenith angle [ dimensionless ]
!  </IN>
!  <INOUT NAME="r_uv" TYPE="real">
!    Cloud reflectance in uv band
!  </INOUT>
!  <INOUT NAME="r_nir" TYPE="real">
!    Cloud reflectance in nir band
!  </INOUT>
!  <INOUT NAME="ab_nir" TYPE="real">
!    Cloud absorption in nir band
!  </INOUT>
! </SUBROUTINE>
!
subroutine sw_optical_properties (nclds, lwp, iwp, reff_liq, reff_ice, &
                                  coszen, r_uv, r_nir, ab_nir)

!----------------------------------------------------------------------
!    sw_optical_properties computes the needed optical parameters and
!    then calls cloud_rad_k in order to compute the cloud radiative
!    properties.
!---------------------------------------------------------------------
                              
integer, dimension(:,:),   intent(in)      :: nclds
real,    dimension(:,:,:), intent(in)      :: lwp, iwp, reff_liq,   &
                                              reff_ice
real,    dimension(:,:),   intent(in)      :: coszen
real,    dimension(:,:,:), intent(inout)   :: r_uv, r_nir, ab_nir

!----------------------------------------------------------------------
!    intent(in) variables:
!
!        nclds           Number of random overlapping clouds in column
!        lwp             Liquid water path [ kg / m**2 ]
!        iwp             Ice water path [ kg / m**2 ]
!        reff_liq        Effective cloud drop radius  used with
!                        bulk cloud physics scheme [ microns ]
!        reff_ice        Effective ice crystal radius used with
!                        bulk cloud physics scheme [ microns ]
!        coszen          Cosine of zenith angle [ dimensionless ]
!
!    intent(out) variables:
!
!        r_uv            Cloud reflectance in uv band
!        r_nir           Cloud reflectance in nir band
!        ab_nir          Cloud absorption in nir band
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (size(lwp,1),                                   &
                       size(lwp,2),                                   &
                       size(lwp,3), 4) ::  tau, w0, gg, tau_liq,   &
                                           tau_ice, w0_liq, w0_ice, &
                                           g_liq, g_ice
      integer :: max_cld
      integer :: i,j, k, m

!---------------------------------------------------------------------
!   local variables:
!
!           tau            optical depth [ dimensionless ]
!           w0             single scattering albedo
!           gg             asymmetry parameter for each band
!           tau_liq        optical depth due to cloud liquid 
!                          [ dimensionless ]
!           tau_ice        optical depth due to cloud liquid 
!                          [ dimensionless ]
!           w0_liq         single scattering albedo due to liquid
!           w0_ice         single scattering albedo due to ice
!           g_liq          asymmetry factor for cloud liquid
!           g_ice          asymmetry factor for cloud ice      
!           max_cld        largest number of clouds in any column in
!                          the current physics window
!           i,j,l,m        do-loop indices 
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the maximum number of random overlap clouds in any column
!    in the current physics window.
!---------------------------------------------------------------------
      max_cld = maxval (nclds(:,:))

!--------------------------------------------------------------------
!    spatial loop.
!--------------------------------------------------------------------
      do j=1,size(lwp,2)
        do i=1,size(lwp,1)
          do k=1,size(lwp,3)  

!---------------------------------------------------------------------
!    initialize local variables to default values.
!---------------------------------------------------------------------
            tau    (i,j,k ,:) = 0.
            tau_liq(i,j,k ,:) = 0.
            tau_ice(i,j,k ,:) = 0.
            gg     (i,j,k ,:) = 0.85
            g_liq  (i,j,k ,:) = 0.85
            g_ice  (i,j,k ,:) = 0.85
            w0     (i,j,k ,:) = 0.95
            w0_liq (i,j,k ,:) = 0.95
            w0_ice (i,j,k ,:) = 0.95

!--------------------------------------------------------------------
!    compute uv cloud optical depths due to liquid droplets in each 
!    of the wavelength bands. the formulas for optical depth come from 
!    Slingo (1989, J. Atmos. Sci., vol. 46, pp. 1419-1427)
!--------------------------------------------------------------------
            tau_liq(i,j,k,1) = lwp(i,j,k)*1000.* &
                               (0.02817 + (1.305/reff_liq(i,j,k)))
            tau_liq(i,j,k,2) = lwp(i,j,k)*1000.* &
                               (0.02682 + (1.346/reff_liq(i,j,k)))
            tau_liq(i,j,k,3) = lwp(i,j,k)*1000.* &
                               (0.02264 + (1.454/reff_liq(i,j,k)))
            tau_liq(i,j,k,4) = lwp(i,j,k)*1000.* &
                               (0.01281 + (1.641/reff_liq(i,j,k)))
        
!--------------------------------------------------------------------
!    compute uv cloud optical depths due to ice crystals. the ice
!    optical depth is independent of wavelength band. the formulas for 
!    optical depth come from Ebert and Curry (1992, J. Geophys. Res., 
!    vol. 97, pp. 3831-3836. IMPORTANT!!! NOTE WE ARE CHEATING HERE 
!    BECAUSE WE ARE FORCING THE FIVE BAND MODEL OF EBERT AND CURRY INTO
!    THE FOUR BAND MODEL OF SLINGO. THIS IS DONE BY COMBINING BANDS 3 
!    and 4 OF EBERT AND CURRY TOGETHER. EVEN SO THE EXACT BAND LIMITS 
!    DO NOT MATCH.  FOR COMPLETENESS HERE ARE THE BAND LIMITS (MICRONS)
!
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!--------------------------------------------------------------------
            tau_ice(i,j,k,1) = iwp(i,j,k)*1000.* &
                               (0.003448 + (2.431/reff_ice(i,j,k)))
            tau_ice(i,j,k,2) = tau_ice(i,j,k,1)
            tau_ice(i,j,k,3) = tau_ice(i,j,k,1)
            tau_ice(i,j,k,4) = tau_ice(i,j,k,1)
        
!--------------------------------------------------------------------
!    compute total cloud optical depth as the sum of the liquid and
!    ice components. the mixed phase optical properties are based upon 
!    equation 14 of Rockel et al. 1991, Contributions to Atmospheric 
!    Physics, volume 64, pp.1-12:  
!           tau = tau_liq + tau_ice
!--------------------------------------------------------------------
            tau(i,j,k,:) = tau_liq(i,j,k,:) + tau_ice(i,j,k,:)
        
!---------------------------------------------------------------------
!    compute single-scattering albedo resulting from the presence
!    of liquid droplets.
!---------------------------------------------------------------------
            w0_liq(i,j,k,1) =  5.62E-08 - 1.63E-07*reff_liq(i,j,k)
            w0_liq(i,j,k,2) =  6.94E-06 - 2.35E-05*reff_liq(i,j,k)
            w0_liq(i,j,k,3) = -4.64E-04 - 1.24E-03*reff_liq(i,j,k)
            w0_liq(i,j,k,4) = -2.01E-01 - 7.56E-03*reff_liq(i,j,k)

            w0_liq(i,j,k,:) = w0_liq(i,j,k,:) + 1.

!---------------------------------------------------------------------
!    compute single-scattering albedo resulting from the presence
!    of ice crystals.
!---------------------------------------------------------------------
            w0_ice(i,j,k,1) = -1.00E-05
            w0_ice(i,j,k,2) = -1.10E-04 - 1.41E-05*reff_ice(i,j,k)
            w0_ice(i,j,k,3) = -1.86E-02 - 8.33E-04*reff_ice(i,j,k)
            w0_ice(i,j,k,4) = -4.67E-01 - 2.05E-05*reff_ice(i,j,k)

            w0_ice(i,j,k,:) = w0_ice(i,j,k,:) + 1.
          end do
        end do
      end do

!----------------------------------------------------------------------
!    compute total single scattering albedo. the mixed phase value is
!    obtained from equation 14 of Rockel et al. 1991, Contributions to 
!    Atmospheric Physics, volume 64, pp.1-12:
!           w0  =   ( w0_liq * tau_liq  +  w0_ice * tau_ice ) /
!                   (          tau_liq  +           tau_ice )
!----------------------------------------------------------------------
      do j=1,size(lwp,2)
        do i=1,size(lwp,1)
          do k=1, size(lwp,3)    
            do m=1,4
              if (tau(i,j,k,m) > 0.0) then
                w0(i,j,k,m) = (w0_liq(i,j,k,m) * tau_liq(i,j,k,m) + &
                               w0_ice(i,j,k,m) * tau_ice(i,j,k,m)) / &
                               tau(i,j,k,m)
              endif
            end do
          end do
        end do
      end do

!---------------------------------------------------------------------
!    compute asymmetry factor.
!---------------------------------------------------------------------
      do j=1,size(lwp,2)
        do i=1,size(lwp,1)
          do k=1, size(lwp,3)  

!---------------------------------------------------------------------
!    compute asymmetry factor resulting from the presence
!    of liquid droplets.
!---------------------------------------------------------------------
            g_liq(i,j,k,1) = 0.829 + 2.482E-03*reff_liq(i,j,k)
            g_liq(i,j,k,2) = 0.794 + 4.226E-03*reff_liq(i,j,k)
            g_liq(i,j,k,3) = 0.754 + 6.560E-03*reff_liq(i,j,k)
            g_liq(i,j,k,4) = 0.826 + 4.353E-03*reff_liq(i,j,k)

!---------------------------------------------------------------------
!    compute asymmetry factor resulting from the presence
!    of ice crystals.
!---------------------------------------------------------------------
            g_ice(i,j,k,1) = 0.7661 + 5.851E-04*reff_ice(i,j,k)
            g_ice(i,j,k,2) = 0.7730 + 5.665E-04*reff_ice(i,j,k)
            g_ice(i,j,k,3) = 0.7940 + 7.267E-04*reff_ice(i,j,k)
            g_ice(i,j,k,4) = 0.9595 + 1.076E-04*reff_ice(i,j,k)
          end do
        end do
      end do

!----------------------------------------------------------------------
!    compute combined asymmetry factor, including effects of both
!    liquid droplets and ice crystals. the mixed phase value is obtained
!    from equation 14 of Rockel et al. 1991, Contributions to 
!    Atmospheric Physics, volume 64, pp.1-12: 
!      g  = ( g_liq * w0_liq * tau_liq + g_ice * w0_ice * tau_ice ) /
!           (         w0_liq * tau_liq +         w0_ice * tau_ice )
!----------------------------------------------------------------------
      do j=1,size(lwp,2)
        do i=1,size(lwp,1)
          do k=1, size(lwp,3)   
            do m=1,4
              if (tau(i,j,k,m) > 0.0) then
                gg(i,j,k,m) = (w0_liq(i,j,k,m)*g_liq(i,j,k,m)*   &
                               tau_liq(i,j,k,m) + w0_ice(i,j,k,m)*  &
                               g_ice(i,j,k,m)*tau_ice(i,j,k,m) ) / &
                               (w0_liq(i,j,k,m)*tau_liq(i,j,k,m) + &
                                w0_ice(i,j,k,m)*tau_ice(i,j,k,m) )

              endif
            end do
          end do
        end do
      end do
        
!--------------------------------------------------------------------
!    apply constraints to the values of these variables.
!--------------------------------------------------------------------
      do j=1,size(lwp,2)
        do i=1,size(lwp,1)
          do k=1, size(lwp,3)
            do m=1,4
              if (tau(i,j,k,m) < taumin .and. tau(i,j,k,m) /= 0.0 ) then
                tau(i,j,k,m) = taumin
              endif
            end do
          end do
        end do
      end do

!---------------------------------------------------------------------
!    account for plane-parallel homogenous cloud bias.
!---------------------------------------------------------------------
      tau(:,:,:,:) = scale_factor*tau(:,:,:,:)

!---------------------------------------------------------------------
!    call cloud_rad_k to calculate the cloud radiative properties.
!---------------------------------------------------------------------
     call cloud_rad_k (tau, w0, gg, coszen, r_uv, r_nir, ab_nir)

!----------------------------------------------------------------------


end subroutine sw_optical_properties


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!         USED WITH ORIGINAL FMS RADIATION:
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


!#####################################################################

SUBROUTINE CLOUD_SUMMARY (is,js,                        &
                  LAND,ql,qi,qa,qv,pfull,phalf,TKel,coszen,skt,&
                  nclds,ktop,kbot,cldamt,Time,&
                  r_uv,r_nir,ab_uv,ab_nir,em_lw,&
                  conc_drop,conc_ice,size_drop,size_ice)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine returns the following properties of clouds
!
!               1. nclds: # of clouds
!               2. ktop : integer level for top of cloud
!               3. kbot : integer level for bottom of cloud
!               4. cldamt:horizontal cloud amount of every cloud
!
!      Optional arguments
!               5. r_uv : cloud reflectance in uv band
!               6. r_nir: cloud reflectance in nir band
!               7. ab_uv: cloud absorption in uv band
!               8. ab_nir:cloud absorption in nir band
!               9. em_lw :longwave cloud emmissivity
!              10. conc_drop : liquid cloud droplet mass concentration
!              11. conc_ice  : ice cloud mass concentration
!              12. size_drop : effective diameter of liquid cloud droplets
!              13. size_ice  : effective diameter of ice cloud 
!
!      given inputs of ql and qi (liquid and ice condensate),
!      cloud volume fraction, and pressure at the half and full levels
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!
!       is,js        indices for model slab
!       LAND         fraction of the grid box covered by LAND
!       ql           cloud liquid condensate (kg condensate/kg air)
!       qi           cloud ice condensate (kg condensate/kg air)
!       qa           cloud volume fraction (fraction)
!       qv           water vapor specific humidity (kg vapor/kg air)
!       pfull        pressure at full levels (Pascals)
!       phalf        pressure at half levels (Pascals)
!                     NOTE: it is assumed that phalf(j+1) > phalf(j)
!       TKel            temperature (Kelvin)
!       coszen       cosine of the zenith angle
!       skt          surface skin temperature (Kelvin)
!
!       -------------
!INPUT/OUTPUT:
!       -------------
!
!       nclds        number of (random overlapping) clouds in column and also
!                        the current # for clouds to be operating on
!       ktop         level of the top of the cloud
!       kbot         level of the bottom of the cloud
!       cldamt       cloud amount of condensed cloud
!
!       ---------------------
!       OPTIONAL INPUT/OUTPUT
!       ---------------------
!
!       r_uv         cloud reflectance in uv band
!       r_nir        cloud reflectance in nir band
!       ab_uv        cloud absorption in uv band
!       ab_nir       cloud absorption in nir band
!       em_lw        longwave cloud emmissivity
!       conc_drop    liquid cloud droplet mass concentration (g /m3)
!       conc_ice     ice cloud mass concentration (g /m3)
!       size_drop    effective diameter of liquid cloud droplets (microns)
!       size_ice   : effective diameter of ice clouds (microns)
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       i,j,k,t      looping variables
!       IDIM         number of first dimension points
!       JDIM         number of second dimension points
!       KDIM         number of third dimension points
!       N_drop       number of cloud droplets per cubic meter
!       k_ratio      ratio of effective radius to mean volume radius
!       max_cld      maximum number of clouds in whole array
!       qa_local     local value of qa (fraction)
!       ql_local     local value of ql (kg condensate / kg air)
!       qi_local     local value of qi (kg condensate / kg air)
!       LWP          cloud liquid water path (kg condensate per square meter)
!       IWP          cloud ice path (kg condensate per square meter)
!       Reff_liq     effective radius for liquid clouds (microns)
!       Reff_ice     effective particle size for ice clouds (microns)
!       tau          optical depth in 4 bands (dimensionless)
!       w0           single scattering albedo in 4 bands (dimensionless)
!       gg           asymmetry parameter in 4 bands (dimensionless)
!       rad_prop     logical indicating if you are requesting the
!                    radiative properties of the clouds
!       wat_prop     logical determining if you are requesting the
!                    concentrations and particle sizes of clouds
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

INTEGER,  INTENT (IN)                    :: is,js
REAL,     INTENT (IN), DIMENSION(:,:)    :: LAND,skt
REAL,     INTENT (IN), DIMENSION(:,:)    :: coszen
REAL,     INTENT (IN), DIMENSION(:,:,:)  :: ql,qi,qa,qv,pfull,TKel
REAL,     INTENT (IN), DIMENSION(:,:,:)  :: phalf
INTEGER,  INTENT (INOUT),DIMENSION(:,:)  :: nclds
INTEGER,  INTENT (INOUT),DIMENSION(:,:,:):: ktop,kbot
REAL,     INTENT (INOUT),DIMENSION(:,:,:):: cldamt
type(time_type), intent(in), optional    :: Time
REAL,     INTENT (INOUT),OPTIONAL,DIMENSION(:,:,:):: r_uv,r_nir,ab_uv,ab_nir,em_lw
REAL,     INTENT (INOUT),OPTIONAL,DIMENSION(:,:,:):: conc_drop,conc_ice
REAL,     INTENT (INOUT),OPTIONAL,DIMENSION(:,:,:):: size_drop,size_ice



!  Internal variables
!  ------------------

INTEGER                                           :: i,j,IDIM,JDIM,KDIM,max_cld
LOGICAL                                           :: rad_prop, wat_prop
REAL, DIMENSION(SIZE(ql,1),SIZE(ql,2),SIZE(ql,3)) :: qa_local,ql_local,qi_local
REAL, DIMENSION(SIZE(ql,1),SIZE(ql,2))            :: N_drop, k_ratio
REAL, DIMENSION(:,:,:), allocatable               :: r_uv_local, r_nir_local
REAL, DIMENSION(:,:,:), allocatable               :: ab_uv_local, ab_nir_local
REAL, DIMENSION(:,:,:), allocatable               :: em_lw_local
REAL, DIMENSION(:,:,:), allocatable               :: conc_drop_local,conc_ice_local
REAL, DIMENSION(:,:,:), allocatable               :: size_drop_local,size_ice_local
REAL, DIMENSION(:,:,:), allocatable               :: LWP,IWP,Reff_liq,Reff_ice
REAL, DIMENSION(:,:,:,:), allocatable             :: tau,w0,gg


!
! Code
! ----

    
    ! reinitialize variables
    IDIM=SIZE(ql,1)
    JDIM=SIZE(ql,2)
    KDIM=SIZE(ql,3)
    nclds(:,:)    = 0
    ktop(:,:,:)   = 0
    kbot(:,:,:)   = 0
    cldamt(:,:,:) = 0.

    rad_prop = .FALSE.
    wat_prop = .FALSE.
    if (PRESENT(r_uv).or.PRESENT(r_nir).or.PRESENT(ab_uv).or.PRESENT(ab_nir).or.&
        PRESENT(em_lw)) then
        rad_prop = .TRUE.
    end if
    if (PRESENT(conc_drop).or.PRESENT(conc_ice).or.PRESENT(size_drop).or.&
        PRESENT(size_ice)) then
        wat_prop = .TRUE.
    end if
    if ((.not.rad_prop).and.(.not.wat_prop)) then
        rad_prop = .TRUE.
    end if

    !create local values of ql and qi
    !this step is necessary to remove the values of (qi,ql) which are
    !           0 < (qi,ql) < qmin   or
    !               (qi,ql) > qmin and qa <= qamin

    ql_local(:,:,:) = 0.
    qi_local(:,:,:) = 0.
    qa_local(:,:,:) = 0.
    WHERE ( (qa(:,:,:) .gt. qamin) .and. (ql(:,:,:) .gt. qmin) )
                  ql_local(:,:,:) = ql(:,:,:)
                  qa_local(:,:,:) = qa(:,:,:)
    END WHERE
    WHERE ( (qa(:,:,:) .gt. qamin) .and. (qi(:,:,:) .gt. qmin) )
                  qi_local(:,:,:) = qi(:,:,:)
                  qa_local(:,:,:) = qa(:,:,:)
    END WHERE

    !compute N_drop and k_ratio
    N_drop(:,:)=N_land*LAND(:,:) + N_ocean*(1.-LAND(:,:))
    k_ratio(:,:)=k_land*LAND(:,:) + k_ocean*(1.-LAND(:,:))

    !do solution for new radiation code
    if (wat_prop) then

         ALLOCATE(conc_drop_local(IDIM,JDIM,KDIM))
         ALLOCATE(conc_ice_local(IDIM,JDIM,KDIM))
         ALLOCATE(size_drop_local(IDIM,JDIM,KDIM))
         ALLOCATE(size_ice_local(IDIM,JDIM,KDIM))
         
         conc_drop_local(:,:,:) = 0.
         conc_ice_local(:,:,:)  = 0.
         size_drop_local(:,:,:) = 20.
         size_ice_local(:,:,:)  = 60.

         call  cloud_organize(ql_local,qi_local,qa_local,&
                  pfull,phalf,TKel,coszen,N_drop,&
                  k_ratio,nclds,ktop,kbot,cldamt,&
                  conc_drop_org=conc_drop_local,&
                  conc_ice_org =conc_ice_local,&
                  size_drop_org=size_drop_local,&
                  size_ice_org =size_ice_local)

         !assign to output
         if (PRESENT(conc_drop)) conc_drop = scale_factor*conc_drop_local
         if (PRESENT(conc_ice)) conc_ice = scale_factor*conc_ice_local
         if (PRESENT(size_drop)) size_drop = size_drop_local
         if (PRESENT(size_ice)) size_ice = size_ice_local
    
         DEALLOCATE(conc_drop_local)
         DEALLOCATE(conc_ice_local)
         DEALLOCATE(size_drop_local)
         DEALLOCATE(size_ice_local)
         
    end if
     
         
    !do solution for old radiation code
    if (rad_prop) then

    
         ALLOCATE(r_uv_local(IDIM,JDIM,KDIM))
         ALLOCATE(r_nir_local(IDIM,JDIM,KDIM))
         ALLOCATE(ab_uv_local(IDIM,JDIM,KDIM))
         ALLOCATE(ab_nir_local(IDIM,JDIM,KDIM))
         ALLOCATE(em_lw_local(IDIM,JDIM,KDIM))
         ALLOCATE(LWP(IDIM,JDIM,KDIM))
         ALLOCATE(IWP(IDIM,JDIM,KDIM))
         ALLOCATE(Reff_liq(IDIM,JDIM,KDIM))
         ALLOCATE(Reff_ice(IDIM,JDIM,KDIM))
         ALLOCATE(tau(IDIM,JDIM,KDIM,4))
         ALLOCATE(w0(IDIM,JDIM,KDIM,4))
         ALLOCATE(gg(IDIM,JDIM,KDIM,4))
         
         r_uv_local(:,:,:)   = 0.
         r_nir_local(:,:,:)  = 0.
         ab_uv_local(:,:,:)  = 0.
         ab_nir_local(:,:,:) = 0.
         em_lw_local(:,:,:)  = 0.
         LWP(:,:,:)    = 0.
         IWP(:,:,:)    = 0.
         Reff_liq(:,:,:) = 10.
         Reff_ice(:,:,:) = 30.
         tau(:,:,:,:)    = 0.
         w0(:,:,:,:)     = 0.
         gg(:,:,:,:)     = 0.

    
         call  cloud_organize(ql_local,qi_local,qa_local,&
                  pfull,phalf,TKel,coszen,N_drop,&
                  k_ratio,nclds,ktop,kbot,cldamt,&
                  LWP_in=LWP,IWP_in=IWP,Reff_liq_in=Reff_liq,Reff_ice_in=Reff_ice)
         
         !find maximum number of clouds
         max_cld  = MAXVAL(nclds(:,:))
         
         !compute cloud radiative properties
         IF (max_cld .gt. 0) then

              CALL CLOUD_OPTICAL_PROPERTIES(LWP(:,:,1:max_cld),IWP(:,:,1:max_cld),&
                      Reff_liq(:,:,1:max_cld),Reff_ice(:,:,1:max_cld),&
                      tau(:,:,1:max_cld,:),w0(:,:,1:max_cld,:),gg(:,:,1:max_cld,:),&
                      em_lw_local(:,:,1:max_cld))
              
              !Account for plane-parallel homogenous cloud bias
              tau(:,:,:,:) = scale_factor * tau(:,:,:,:)

              !compute cloud radiative properties
              CALL CLOUD_RAD(tau(:,:,1:max_cld,:),w0(:,:,1:max_cld,:),&
                       gg(:,:,1:max_cld,:),coszen,&
                       r_uv_local(:,:,1:max_cld),r_nir_local(:,:,1:max_cld),&
                       ab_uv_local(:,:,1:max_cld),ab_nir_local(:,:,1:max_cld))
              
              !assure that zero clouds have properties of zero clouds
              DO i = 1, IDIM
              DO j = 1, JDIM
                       if (nclds(i,j).lt.max_cld) then
                               r_uv_local(i,j,nclds(i,j)+1:max_cld)   = 0.
                               r_nir_local(i,j,nclds(i,j)+1:max_cld)  = 0.
                               ab_uv_local(i,j,nclds(i,j)+1:max_cld)  = 0.
                               ab_nir_local(i,j,nclds(i,j)+1:max_cld) = 0.
                               em_lw_local(i,j,nclds(i,j)+1:max_cld)  = 0.
                       end if
              ENDDO
              ENDDO

         END IF

         if (PRESENT(r_uv)) r_uv = r_uv_local
         if (PRESENT(r_nir)) r_nir = r_nir_local
         if (PRESENT(ab_uv)) ab_uv = ab_uv_local
         if (PRESENT(ab_nir)) ab_nir = ab_nir_local
         if (PRESENT(em_lw)) em_lw = em_lw_local
          
         DEALLOCATE(r_uv_local)
         DEALLOCATE(r_nir_local)
         DEALLOCATE(ab_uv_local)
         DEALLOCATE(ab_nir_local)
         DEALLOCATE(em_lw_local)
         DEALLOCATE(LWP)
         DEALLOCATE(IWP)
         DEALLOCATE(Reff_liq)
         DEALLOCATE(Reff_ice)
         DEALLOCATE(tau)
         DEALLOCATE(w0)
         DEALLOCATE(gg)
         
    end if
    
END SUBROUTINE CLOUD_SUMMARY

SUBROUTINE CLOUD_ORGANIZE(ql,qi,qa,pfull,phalf,TKel,coszen,N_drop,&
                  k_ratio,nclds,ktop,kbot,cldamt,&
                  LWP_in,IWP_in,Reff_liq_in,Reff_ice_in, &
                  conc_drop_org,conc_ice_org,size_drop_org,size_ice_org)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine returns the following properties of clouds
!
!               1. nclds: # of clouds
!               2. ktop : integer level for top of cloud
!               3. kbot : integer level for bottom of cloud
!               4. cldamt:horizontal cloud amount of every cloud
!               5. LWP :
!
!      given inputs of ql and qi (liquid and ice condensate),
!      cloud volume fraction, and pressure at the half and full levels
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!
!       LAND         fraction of the grid box covered by LAND
!       ql           cloud liquid condensate (kg condensate/kg air)
!       qi           cloud ice condensate (kg condensate/kg air)
!       qa           cloud volume fraction (fraction)
!       pfull        pressure at full levels (Pascals)
!       phalf        pressure at half levels (Pascals)
!                     NOTE: it is assumed that phalf(j+1) > phalf(j)
!       TKel            temperature (Kelvin)
!       coszen       cosine of the zenith angle
!       N_drop       number of cloud droplets per cubic meter
!       k_ratio      ratio of effective radius to mean volume radius
!
!       -------------
!INPUT/OUTPUT:
!       -------------
!
!       nclds        number of (random overlapping) clouds in column and also
!                        the current # for clouds to be operating on
!       ktop         level of the top of the cloud
!       kbot         level of the bottom of the cloud
!       cldamt       cloud amount of condensed cloud
!
!       ---------------------
!       OPTIONAL INPUT/OUTPUT
!       ---------------------
!
!       LWP          cloud liquid water path (kg condensate per square meter)
!       IWP          cloud ice path (kg condensate per square meter)
!       Reff_liq     effective radius for liquid clouds (microns)
!       Reff_ice     effective particle size for ice clouds (microns)
!       conc_drop_org liquid cloud droplet mass concentration (g /m3)
!       conc_ice_org  ice cloud mass concentration (g /m3)
!       size_drop_org effective diameter of liquid cloud droplets (microns)
!       size_ice_org  effective diameter of ice clouds (microns)
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       i,j,k,t      looping variables
!       IDIM         number of first dimension points
!       JDIM         number of second dimension points
!       KDIM         number of vertical levels
!       nlev         number of levels in the cloud
!       reff_liq_local   reff of liquid clouds used locally (microns)
!       sum_reff_liq  a sum of reff_liq_local
!       reff_ice_local   reff of ice clouds used locally (microns)
!       sum_reff_ice  a sum of reff_liq_local
!       sum_liq      sum of liquid in cloud (kg condensate per square meter)
!       sum_ice      sum of ice in cloud (kg condensate per square meter)
!       maxcldfrac   maximum cloud fraction in cloud block (fraction)
!       top_t,bot_t  temporary integers used to identify cloud edges
!       totcld_bot   total cloud fraction from bottom view
!       max_bot      largest cloud fraction face from bottom view
!       totcld_top   total cloud fraction from top view
!       max_top      largest cloud fraction face from top view
!       tmp_val      temporary number used in the assigning of top and bottoms
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      NOTE ON THE FORMULAS FOR EFFECTIVE RADIUS OF LIQUID AND ICE
!      CLOUDS:
!
!
!      FOR LIQUID CLOUDS THE FOLLOWING FORMULA IS USED:
!
!      THIS FORMULA IS THE RECOMMENDATION OF
!      Martin et al., J. Atmos. Sci, vol 51, pp. 1823-1842
!
!
!        reff (in microns) =  k * 1.E+06 *
!                    (3*airdens*(ql/qa)/(4*pi*Dens_h2o*N_liq))**(1/3)
!
!       where airdens = density of air in kg air/m3
!                  ql = liquid condensate in kg cond/kg air
!                  qa = cloud fraction
!                  pi = 3.14159
!            Dens_h2o = density of pure liquid water (kg liq/m3) 
!               N_liq = density of cloud droplets (number per cubic meter)
!                   k = factor to account for difference between 
!                       mean volume radius and effective radius
!
!        IN THIS PROGRAM reff_liq is limited to be between 4.2 microns
!        and 16.6 microns, which is the range of validity for the
!        Slingo (1989) radiation.
!
!     For single layer liquid or mixed phase clouds it is assumed that
!     cloud liquid is vertically stratified within the cloud.  Under
!     such situations for observed stratocumulus clouds it is found
!     that the cloud mean effective radius is between 80 and 100% of
!     the cloud top effective radius. (Brenguier et al., Journal of
!     Atmospheric Sciences, vol. 57, pp. 803-821 (2000))  For linearly 
!     stratified cloud in liquid specific humidity, the cloud top 
!     effective radius is greater than the effective radius of the 
!     cloud mean specific humidity by a factor of 2**(1./3.).
!
!     This correction, 0.9*(2**(1./3.)) = 1.134, is applied only to 
!     single layer liquid or mixed phase clouds.
!
!
!     FOR ICE CLOUDS THE EFFECTIVE RADIUS IS TAKEN FROM THE FORMULATION
!     IN DONNER (1997, J. Geophys. Res., 102, pp. 21745-21768) WHICH IS
!     BASED ON HEYMSFIELD AND PLATT (1984) WITH ENHANCEMENT FOR PARTICLES
!     SMALLER THAN 20 MICRONS.  
!
!              T Range (K)               Reff (microns)   Deff (microns)
!     -------------------------------    --------------   --------------
!
!     Tfreeze-25. < T                       92.46298         100.6
!     Tfreeze-30. < T <= Tfreeze-25.        72.35392          80.8
!     Tfreeze-35. < T <= Tfreeze-30.        85.19071          93.5
!     Tfreeze-40. < T <= Tfreeze-35.        55.65818          63.9
!     Tfreeze-45. < T <= Tfreeze-40.        35.29989          42.5
!     Tfreeze-50. < T <= Tfreeze-45.        32.89967          39.9
!     Tfreeze-55  < T <= Tfreeze-50         16.60895          21.6
!                   T <= Tfreeze-55.        15.41627          20.2
!
!        IN THIS PROGRAM, reff_ice is limited to be between 10 microns
!        and 130 microns, which is the range of validity for the Ebert
!        and Curry (1992) radiation.
!
!        IN THIS PROGRAM, size_ice (i.e. Deff) is limited to be between
!        18.6 microns and 130.2 microns, which is the range of validity 
!        for the Fu Liou JAS 1993 radiation.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

REAL,     INTENT (IN), DIMENSION(:,:)    :: coszen, N_drop, k_ratio
REAL,     INTENT (IN), DIMENSION(:,:,:)  :: ql,qi,qa,pfull,TKel
REAL,     INTENT (IN), DIMENSION(:,:,:)  :: phalf
INTEGER,  INTENT (INOUT),DIMENSION(:,:)  :: nclds
INTEGER,  INTENT (INOUT),DIMENSION(:,:,:):: ktop,kbot
REAL,     INTENT (INOUT),DIMENSION(:,:,:):: cldamt
REAL,     INTENT (INOUT),OPTIONAL,DIMENSION(:,:,:):: LWP_in,IWP_in,Reff_liq_in,Reff_ice_in
REAL,     INTENT (INOUT),OPTIONAL,DIMENSION(:,:,:):: conc_drop_org,conc_ice_org
REAL,     INTENT (INOUT),OPTIONAL,DIMENSION(:,:,:):: size_drop_org,size_ice_org


!  Internal variables
!  ------------------

INTEGER                                  :: i,j,k,IDIM,JDIM,KDIM
INTEGER                                  :: t,top_t,bot_t
INTEGER                                  :: tmp_top,tmp_bot,nlev
LOGICAL                                  :: add_cld,lhsw,sea_esf
REAL                                     :: sum_liq,sum_ice,maxcldfrac
REAL                                     :: totcld_bot,max_bot
REAL                                     :: totcld_top,max_top,tmp_val
REAL                                     :: reff_liq_local,sum_reff_liq
REAL                                     :: reff_ice_local,sum_reff_ice
real, dimension(:,:,:), allocatable :: lwp, iwp, reff_liq, reff_ice

!
! Code
! ----


    ! reinitialize variables
    IDIM=SIZE(ql,1)
    JDIM=SIZE(ql,2)
    KDIM=SIZE(ql,3)
    nclds(:,:)    = 0
    ktop(:,:,:)   = 0
    kbot(:,:,:)   = 0
    cldamt(:,:,:) = 0.

    !decide which type of output is necessary
    lhsw = .FALSE.
    sea_esf = .FALSE.
    if (PRESENT(conc_drop_org).or.PRESENT(conc_ice_org).or.  &
        PRESENT(size_drop_org).or.PRESENT(size_ice_org)) then
        sea_esf = .TRUE.
    end if
    if (PRESENT(LWP_in).or.PRESENT(IWP_in).or.PRESENT(Reff_liq_in).or. &
        PRESENT(Reff_ice_in)) then
        lhsw = .true.
    end if
        allocate ( lwp(idim, jdim,kdim))
        allocate ( iwp(idim, jdim,kdim))
        allocate ( reff_liq(idim, jdim,kdim))
        allocate ( reff_ice(idim, jdim,kdim))
    if ((.not.lhsw).and.(.not.sea_esf)) then
        lhsw = .TRUE.
    end if


    !initialize output fields
         LWP(:,:,:)    = 0.
         IWP(:,:,:)    = 0.
         Reff_liq(:,:,:) = 10.
         Reff_ice(:,:,:) = 30.

    if (sea_esf) then
         conc_drop_org(:,:,:) = 0.
         conc_ice_org (:,:,:) = 0.
         size_drop_org(:,:,:) = 20.
         size_ice_org (:,:,:) = 60.
    end if
        


    !-----------  DETERMINE CLOUD AMOUNT, LWP, IWP FOR EACH CLOUD ------!

    if (overlap .eq. 1) then


         !-----------  prevent user from attempting to do maximum
         !-----------  -random overlap with new radiation code

         if (sea_esf) then

              call error_mesg  ('cloud_rad_organize in cloud_rad module',&
                                'maximum random overlap is not currently '//&
                                'available with sea_esf radiation', FATAL)

        end if

        !---- DO CONDENSING OF CLOUDS ----!

        
        !---loop over vertical levels----!
        DO i = 1, IDIM
        DO j = 1, JDIM
        
        add_cld  = .FALSE.

        DO k = 1, KDIM

                 !identify new cloud tops
                 IF ( ( (ql(i,j,k) .gt. qmin) .or. &
                        (qi(i,j,k) .gt. qmin) ) .and. &
                           (.NOT. add_cld) ) then
                       nclds(i,j) = nclds(i,j) + 1
                       add_cld = .TRUE.
                       ktop(i,j,nclds(i,j)) = k
                       sum_liq          = 0.
                       sum_ice          = 0.
                       maxcldfrac       = 0.
                       sum_reff_liq     = 0.
                       sum_reff_ice     = 0.        
                 END IF

                 !increment sums where cloud
                 IF (   (ql(i,j,k) .gt. qmin) .or. &
                        (qi(i,j,k) .gt. qmin)  ) then

                       !compute reff
                       if (ql(i,j,k) .gt. qmin) then
                          reff_liq_local = k_ratio(i,j)* 620350.49 *    &
                             (pfull(i,j,k)*ql(i,j,k)/qa(i,j,k)/Rdgas/   &
                             TKel(i,j,k)/Dens_h2o/N_drop(i,j))**(1./3.)
                       else
                          reff_liq_local = 0.
                       end if

                       if ( (k .eq. 1    .and. qa(i,j,2)      .lt. qamin) &
                          .or. &
                          (k .eq. KDIM .and. qa(i,j,KDIM-1) .lt. qamin) &
                          .or. &
                          (k .gt. 1 .and. k .lt. KDIM .and. &
                          qa(i,j,k-1) .lt. qamin .and. &
                          qa(i,j,k+1) .lt. qamin) ) then
                          reff_liq_local = 1.134 * reff_liq_local
                       end if

                       !limit reff_liq_local to values for which
                       !Slingo radiation is valid :
                       ! 4.2 microns < reff < 16.6 microns
                       reff_liq_local = MIN(16.6,reff_liq_local)
                       reff_liq_local = MAX(4.2, reff_liq_local)

                       if (qi(i,j,k) .gt. qmin) then
                          
                          if (TKel(i,j,k) .gt. Tfreeze-25.) then
                             reff_ice_local = 92.46298
                          else if (TKel(i,j,k) .gt. Tfreeze-30. .and. &
                                   TKel(i,j,k) .le. Tfreeze-25.) then
                             reff_ice_local = 72.35392
                          else if (TKel(i,j,k) .gt. Tfreeze-35. .and. &
                                   TKel(i,j,k) .le. Tfreeze-30.) then
                             reff_ice_local = 85.19071 
                          else if (TKel(i,j,k) .gt. Tfreeze-40. .and. &
                                   TKel(i,j,k) .le. Tfreeze-35.) then
                             reff_ice_local = 55.65818
                          else if (TKel(i,j,k) .gt. Tfreeze-45. .and. &
                                   TKel(i,j,k) .le. Tfreeze-40.) then
                             reff_ice_local = 35.29989
                          else if (TKel(i,j,k) .gt. Tfreeze-50. .and. &
                                   TKel(i,j,k) .le. Tfreeze-45.) then
                             reff_ice_local = 32.89967
                          else if (TKel(i,j,k) .gt. Tfreeze-55. .and. &
                                   TKel(i,j,k) .le. Tfreeze-50.) then
                             reff_ice_local = 16.60895
                          else
                             reff_ice_local = 15.41627
                          end if
                          !limit values to that for which Ebert and
                          !Curry radiation is valid :
                          !  10 microns < reff < 130 microns
                          !
                          reff_ice_local = MIN(130.,reff_ice_local)
                          reff_ice_local = MAX(10.,reff_ice_local)

                       else
                          reff_ice_local = 0.
                       end if   !end if for qi > qmin

                       !increment sums
                       sum_liq = sum_liq + ql(i,j,k)* &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Grav
                       sum_ice = sum_ice + qi(i,j,k)* &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Grav
                       maxcldfrac = MAX(maxcldfrac,qa(i,j,k))
                       sum_reff_liq  = sum_reff_liq + &
                          ( reff_liq_local * ql(i,j,k) * &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Grav )
                       sum_reff_ice  = sum_reff_ice + &
                          ( reff_ice_local * qi(i,j,k) * &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Grav )

                 END IF


                 !where the first cloud gap exists after a cloud
                 ! or bottom level is reached compute kbot, cldamt,
                 ! LWP, IWP, Reff_liq, and Reff_ice
                 IF (  ( (ql(i,j,k) .le. qmin) .and. &
                         (qi(i,j,k) .le. qmin) .and. &
                         (add_cld) ) .or. &
                         (add_cld .and. k .eq. KDIM)) then

                    !reset add_cld
                    add_cld     = .FALSE.

                    !determine kbot
                    kbot(i,j,nclds(i,j))= k-1
                    if ((ql(i,j,k) .gt. qmin) .or. &
                        (qi(i,j,k) .gt. qmin)) then
                       kbot(i,j,nclds(i,j)) = k
                    end if

                    cldamt(i,j,nclds(i,j)) = maxcldfrac
                    LWP(i,j,nclds(i,j)) = sum_liq / cldamt(i,j,nclds(i,j))
                    IWP(i,j,nclds(i,j)) = sum_ice / cldamt(i,j,nclds(i,j))
                    if (sum_liq .gt. 0.) then
                       Reff_liq(i,j,nclds(i,j)) = sum_reff_liq / sum_liq
                    end if
                    if (sum_ice .gt. 0.) then
                       Reff_ice(i,j,nclds(i,j)) = sum_reff_ice / sum_ice
                    end if

                    ! If adjust_top is T then
                    !change top and bottom indices to those that
                    !are at the most exposed to top and bottom
                    !view
                    nlev = kbot(i,j,nclds(i,j))-ktop(i,j,nclds(i,j))+1
                    if (adjust_top .and. nlev .gt. 1) then

                       !reset tmp_top,tmp_bot
                       tmp_top = ktop(i,j,nclds(i,j))
                       tmp_bot = kbot(i,j,nclds(i,j))

                       !find top and base of cloud
                       totcld_bot=0.
                       totcld_top=0.
                       max_bot=0.
                       max_top=0.
          
                       DO t = 1,nlev

                          top_t = ktop(i,j,nclds(i,j))+t-1
                          bot_t = kbot(i,j,nclds(i,j))-t+1
                          
                          tmp_val = MAX(0.,qa(i,j,top_t)-totcld_top)
                          if (tmp_val .gt. max_top) then
                             max_top = tmp_val
                             tmp_top = top_t
                          end if
                          totcld_top = totcld_top+tmp_val         
                              
                          tmp_val = MAX(0.,qa(i,j,bot_t)-totcld_bot)
                          if (tmp_val .gt. max_bot) then
                             max_bot = tmp_val
                             tmp_bot = bot_t
                          end if
                          totcld_bot = totcld_bot+tmp_val         
                               
                       END DO
                       
                       !assign tmp_top and tmp_bot to ktop and kbot
                       ktop(i,j,nclds(i,j)) = tmp_top
                       kbot(i,j,nclds(i,j)) = tmp_bot

                    end if  !for adjust_top

                 END IF  !for end of cloud

        END DO
        END DO
        END DO

    else if (overlap .eq. 2) then

           
        !---loop over vertical levels----!
        DO i = 1, IDIM
        DO j = 1, JDIM
        DO k = 1, KDIM
               
                 !where cloud exists compute ktop,kbot, cldamt and LWP and IWP
                 IF ( (ql(i,j,k) .gt. qmin) .or. &
                      (qi(i,j,k) .gt. qmin)  ) then

                    nclds(i,j) = nclds(i,j) + 1
                    ktop(i,j,nclds(i,j)) = k
                    kbot(i,j,nclds(i,j)) = k

                    if (lhsw) then
                       cldamt(i,j,nclds(i,j)) = qa(i,j,k)
                       LWP(i,j,nclds(i,j))    = ql(i,j,k)*    &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Grav/ &
                          cldamt(i,j,nclds(i,j))
                       IWP(i,j,nclds(i,j))    = qi(i,j,k)*    &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Grav/ &
                          cldamt(i,j,nclds(i,j))
                    end if  !lhsw if

                    if (sea_esf) then
                       cldamt(i,j,k) = qa(i,j,k)
                       !Note units are in g/m3!
                       conc_drop_org(i,j,k) = 1000.*ql(i,j,k)*                &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Rdgas/TKel(i,j,k)/    &
                          log(phalf(i,j,k+1)/MAX(phalf(i,j,k),pfull(i,j,1)))/ &
                          cldamt(i,j,k)
                       conc_ice_org (i,j,k) = 1000.*qi(i,j,k)*                &
                          (phalf(i,j,k+1)-phalf(i,j,k))/Rdgas/TKel(i,j,k)/    &
                          log(phalf(i,j,k+1)/MAX(phalf(i,j,k),pfull(i,j,1)))/ &
                          cldamt(i,j,k)
                    end if  !sea_esf if

                    !compute reff_liquid
                    if (ql(i,j,k) .gt. qmin) then

                       reff_liq_local = k_ratio(i,j)* 620350.49 *    &
                          (pfull(i,j,k)*ql(i,j,k)/qa(i,j,k)/Rdgas/   &
                          TKel(i,j,k)/Dens_h2o/N_drop(i,j))**(1./3.)
                       
                       if ( (k .eq. 1    .and. qa(i,j,2)      .lt. qamin) &
                            .or. &
                            (k .eq. KDIM .and. qa(i,j,KDIM-1) .lt. qamin) &
                            .or. &
                            (k .gt. 1 .and. k .lt. KDIM .and. &
                            qa(i,j,k-1) .lt. qamin .and. &
                            qa(i,j,k+1) .lt. qamin) ) then
                          reff_liq_local = 1.134 * reff_liq_local
                       end if

                       !limit reff_liq_local to values for which
                       !Slingo radiation is valid :
                       ! 4.2 microns < reff < 16.6 microns
                       reff_liq_local = MIN(16.6,reff_liq_local)
                       reff_liq_local = MAX(4.2, reff_liq_local)

                       if (lhsw) Reff_liq(i,j,nclds(i,j)) =  reff_liq_local
                       if (sea_esf) size_drop_org(i,j,k) = 2. * reff_liq_local

                    end if  !ql calculation

                    !compute reff_ice
                    if (qi(i,j,k) .gt. qmin) then
                          
                       if (lhsw) then
                       
                          if (TKel(i,j,k) .gt. Tfreeze-25.) then
                              reff_ice_local = 92.46298
                          else if (TKel(i,j,k) .gt. Tfreeze-30. .and. &
                                   TKel(i,j,k) .le. Tfreeze-25.) then
                              reff_ice_local = 72.35392
                          else if (TKel(i,j,k) .gt. Tfreeze-35. .and. &
                                   TKel(i,j,k) .le. Tfreeze-30.) then
                              reff_ice_local = 85.19071 
                          else if (TKel(i,j,k) .gt. Tfreeze-40. .and. &
                                   TKel(i,j,k) .le. Tfreeze-35.) then
                              reff_ice_local = 55.65818
                          else if (TKel(i,j,k) .gt. Tfreeze-45. .and. &
                                   TKel(i,j,k) .le. Tfreeze-40.) then
                              reff_ice_local = 35.29989
                          else if (TKel(i,j,k) .gt. Tfreeze-50. .and. &
                                   TKel(i,j,k) .le. Tfreeze-45.) then
                              reff_ice_local = 32.89967
                          else if (TKel(i,j,k) .gt. Tfreeze-55. .and. &
                                   TKel(i,j,k) .le. Tfreeze-50.) then
                              reff_ice_local = 16.60895
                          else
                              reff_ice_local = 15.41627
                          end if

                          !limit values to that for which Ebert and
                          !Curry radiation is valid :
                          !  10 microns < reff < 130 microns
                          !
                          reff_ice_local = MIN(130.,reff_ice_local)
                          Reff_ice(i,j,nclds(i,j)) = MAX(10.,reff_ice_local)                  
                       end if  !end of lhsw if

                       if (sea_esf) then

                          if (TKel(i,j,k) .gt. Tfreeze-25.) then
                              reff_ice_local = 100.6
                          else if (TKel(i,j,k) .gt. Tfreeze-30. .and. &
                                   TKel(i,j,k) .le. Tfreeze-25.) then
                              reff_ice_local = 80.8
                          else if (TKel(i,j,k) .gt. Tfreeze-35. .and. &
                                   TKel(i,j,k) .le. Tfreeze-30.) then
                              reff_ice_local = 93.5 
                          else if (TKel(i,j,k) .gt. Tfreeze-40. .and. &
                                   TKel(i,j,k) .le. Tfreeze-35.) then
                              reff_ice_local = 63.9
                          else if (TKel(i,j,k) .gt. Tfreeze-45. .and. &
                                   TKel(i,j,k) .le. Tfreeze-40.) then
                              reff_ice_local = 42.5
                          else if (TKel(i,j,k) .gt. Tfreeze-50. .and. &
                                   TKel(i,j,k) .le. Tfreeze-45.) then
                              reff_ice_local = 39.9
                          else if (TKel(i,j,k) .gt. Tfreeze-55. .and. &
                                   TKel(i,j,k) .le. Tfreeze-50.) then
                              reff_ice_local = 21.6
                          else
                              reff_ice_local = 20.2
                          end if

                          !the ice crystal effective size can          
                          !only be 18.6 <= D^sub^e <= 130.2 microns. 
                          !for Fu Liou JAS 1993 code                    
                          reff_ice_local = MIN(130.2,reff_ice_local)
                          size_ice_org(i,j,k) = &
                                           MAX(18.6,reff_ice_local)
                        

                       end if  !end of sea_esf if
                             
                    end if !qi loop                       
                          
                 END IF  !cloud exist if

           END DO
           END DO
           END DO



    end if   !overlap = 2  if

    if (present(lwp_in)) then
      lwp_in = lwp
      iwp_in = iwp
      reff_liq_in = reff_liq
      reff_ice_in = reff_ice
     endif
    
      deallocate (lwp, iwp, reff_liq, reff_ice)

END SUBROUTINE CLOUD_ORGANIZE
SUBROUTINE CLOUD_OPTICAL_PROPERTIES(LWP,IWP,Reff_liq,Reff_ice,&
                        tau,w0,gg,em_lw,tau_ice_diag)

                              

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following optical properties
!      for each cloud:
!
!               1. tau   :optical depth in each band
!               2. w0    :single scattering albedo for each band
!               3. gg     :asymmetry parameter for each band
!               4. em_lw    :longwave cloud emmissivity
!
!   The formulas for optical depth come from Slingo (1989) for liquid
!   clouds and from Ebert and Curry (1992) for ice clouds.
!
!   Slingo (1989) is at J. Atmos. Sci., vol. 46, pp. 1419-1427
!   Ebert and Curry (1992) is at J. Geophys. Res., vol. 97, pp. 3831-3836
!
!                    IMPORTANT!!!
!
!    NOTE WE ARE CHEATING HERE BECAUSE WE ARE FORCING THE FIVE BAND
!    MODEL OF EBERT AND CURRY INTO THE FOUR BAND MODEL OF SLINGO
!
!    THIS IS DONE BY COMBINING BANDS 3 and 4 OF EBERT AND CURRY TOGETHER
!
!   EVEN SO THE EXACT BAND LIMITS DO NOT MATCH.  FOR COMPLETENESS
!   HERE ARE THE BAND LIMITS IN MICRONS
!
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!
!
!   The mixed phase optical properties are based upon equation 14
!   of Rockel et al. 1991, Contributions to Atmospheric Physics,
!   volume 64, pp.1-12.   These equations are:
!
!   (1)    tau = tau_liq + tau_ice
!
!   (2)    w0  =   ( w0_liq * tau_liq  +  w0_ice * tau_ice ) /
!                  (          tau_liq  +           tau_ice )
!
!   (3)     g  = ( g_liq * w0_liq * tau_liq +  g_ice * w0_ice * tau_ice ) /
!                (         w0_liq * tau_liq +          w0_ice * tau_ice )
!
!
!   (4) transmivvity_lw =   transmissivity_lw_ice * transmissivity_lw_liq
!
!    The last equation can be rewritten as:
!
!   (5)  em_lw =  em_lw_liq + em_lw_ice -  (em_lw_liq * em_lw_ice )
!
!   Which is what is solved here.
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!
!       LWP          cloud liquid water path (kg condensate per square meter)
!       IWP          cloud ice path (kg condensate per square meter)
!       Reff_liq     effective radius for liquid clouds (microns)
!       Reff_ice     effective particle size for ice clouds (microns)
!
!       ------
!INPUT/OUTPUT:
!       ------
!
!      tau          optical depth in each band
!      w0           single scattering albedo for each band
!      gg           asymmetry parameter for each band
!      em_lw        longwave cloud emmissivity
!
!       ---------------------
!       OPTIONAL INPUT/OUTPUT
!       ---------------------
!
!       tau_ice_diag    optical depth in each band
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       tau_liq   optical depth            at each band for cloud liquid
!       tau_ice   optical depth            at each band for cloud ice
!       w0_liq    single scattering albedo at each band for cloud liquid
!       w0_ice    single scattering albedo at each band for cloud ice
!       g_liq     asymmetry parameter      at each band for cloud liquid
!       g_ice     asymmetry parameter      at each band for cloud ice
!       k_liq        liquid cloud mass absorption coefficient for longwave
!                         portion of the spectrum (meters**2./kg condensate)
!       k_ice           ice cloud mass absorption coefficient for longwave
!                         portion of the spectrum (meters**2./kg condensate)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------


REAL,     INTENT (IN)   ,DIMENSION(:,:,:)   :: LWP,IWP,Reff_liq,Reff_ice
REAL,     INTENT (INOUT),DIMENSION(:,:,:,:) :: tau,w0,gg
REAL,     INTENT (INOUT),DIMENSION(:,:,:)   :: em_lw
REAL,     INTENT (INOUT), OPTIONAL, DIMENSION(:,:,:,:) :: tau_ice_diag
        
!  Internal variables
!  ------------------
REAL, DIMENSION(SIZE(LWP,1),SIZE(LWP,2),SIZE(LWP,3),4) :: tau_liq,tau_ice
REAL, DIMENSION(SIZE(LWP,1),SIZE(LWP,2),SIZE(LWP,3),4) :: w0_liq,w0_ice
REAL, DIMENSION(SIZE(LWP,1),SIZE(LWP,2),SIZE(LWP,3),4) :: g_liq,g_ice
REAL, DIMENSION(SIZE(LWP,1),SIZE(LWP,2),SIZE(LWP,3))   :: k_liq,k_ice

!
! Code
! ----
        
        ! reinitialize output variables to default values
        ! (not usually used)
        tau(:,:,:,:)=0.
        gg(:,:,:,:) = 0.85
        w0(:,:,:,:) = 0.95
        em_lw(:,:,:) = 0.
        
        ! reinitialize internal variables (not usually used)
        w0_liq(:,:,:,:) = 0.95
        w0_ice(:,:,:,:) = 0.95
        g_liq(:,:,:,:)  = 0.85
        g_ice(:,:,:,:)  = 0.85
        tau_liq(:,:,:,:)= 0.
        tau_ice(:,:,:,:)= 0.



   !---------------   COMPUTE OPTICAL DEPTH ---------------------------!

        ! compute uv cloud optical depths due to liquid
        ! and ice phase separately

        tau_liq(:,:,:,1) = LWP(:,:,:) * 1000. * &
                           (0.02817 + (1.305/Reff_liq(:,:,:)))
        tau_liq(:,:,:,2) = LWP(:,:,:) * 1000. * &
                           (0.02682 + (1.346/Reff_liq(:,:,:)))
        tau_liq(:,:,:,3) = LWP(:,:,:) * 1000. * &
                           (0.02264 + (1.454/Reff_liq(:,:,:)))
        tau_liq(:,:,:,4) = LWP(:,:,:) * 1000. * &
                           (0.01281 + (1.641/Reff_liq(:,:,:)))
        
        tau_ice(:,:,:,1) = IWP(:,:,:) * 1000. * &
                           (0.003448 + (2.431/Reff_ice(:,:,:)))
        tau_ice(:,:,:,2) = tau_ice(:,:,:,1)
        tau_ice(:,:,:,3) = tau_ice(:,:,:,1)
        tau_ice(:,:,:,4) = tau_ice(:,:,:,1)
        

        ! compute total cloud optical depth
        tau(:,:,:,:) = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)
        

   !---------------   COMPUTE SINGLE SCATTERING ALBEDO ----------------!

        w0_liq(:,:,:,1) =  5.62E-08   - 1.63E-07*Reff_liq(:,:,:)
        w0_liq(:,:,:,2) =  6.94E-06   - 2.35E-05*Reff_liq(:,:,:)
        w0_liq(:,:,:,3) = -4.64E-04   - 1.24E-03*Reff_liq(:,:,:)
        w0_liq(:,:,:,4) = -2.01E-01   - 7.56E-03*Reff_liq(:,:,:)
        w0_liq(:,:,:,:) = w0_liq(:,:,:,:) + 1.

        w0_ice(:,:,:,1) = -1.00E-05
        w0_ice(:,:,:,2) = -1.10E-04   - 1.41E-05*Reff_ice(:,:,:)
        w0_ice(:,:,:,3) = -1.86E-02   - 8.33E-04*Reff_ice(:,:,:)
        w0_ice(:,:,:,4) = -4.67E-01   - 2.05E-05*Reff_ice(:,:,:)
        w0_ice(:,:,:,:) = w0_ice(:,:,:,:) + 1.


        ! compute total single scattering albedo
        WHERE (tau(:,:,:,:) .gt. 0.)
               w0(:,:,:,:) = ( w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                               w0_ice(:,:,:,:) * tau_ice(:,:,:,:) )  /&
                             tau(:,:,:,:)
        END WHERE
        
   !---------------   COMPUTE ASYMMETRY PARAMETER --------------------!


       g_liq(:,:,:,1) = 0.829 + 2.482E-03*Reff_liq(:,:,:)
       g_liq(:,:,:,2) = 0.794 + 4.226E-03*Reff_liq(:,:,:)
       g_liq(:,:,:,3) = 0.754 + 6.560E-03*Reff_liq(:,:,:)
       g_liq(:,:,:,4) = 0.826 + 4.353E-03*Reff_liq(:,:,:)

       g_ice(:,:,:,1) = 0.7661+ 5.851E-04*Reff_ice(:,:,:)
       g_ice(:,:,:,2) = 0.7730+ 5.665E-04*Reff_ice(:,:,:)
       g_ice(:,:,:,3) = 0.7940+ 7.267E-04*Reff_ice(:,:,:)
       g_ice(:,:,:,4) = 0.9595+ 1.076E-04*Reff_ice(:,:,:)

        ! compute  asymmetry parameter
        WHERE (tau(:,:,:,:) .gt. 0. )
              gg(:,:,:,:) = ( &
                 w0_liq(:,:,:,:) * g_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                 w0_ice(:,:,:,:) * g_ice(:,:,:,:) * tau_ice(:,:,:,:) ) &
                       /          (w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                                   w0_ice(:,:,:,:) * tau_ice(:,:,:,:) )
        END WHERE

        
   !---------------   COMPUTE LONGWAVE EMMISSIVITY --------------------!


        k_liq(:,:,:) = 140.
        k_ice(:,:,:) = 4.83591 + 1758.511/Reff_ice(:,:,:)
        
        ! compute combined emmisivity
        em_lw(:,:,:) =  1. - exp( -1. * ( k_liq(:,:,:) * LWP(:,:,:) + &
                                          k_ice(:,:,:) * IWP(:,:,:) ) )

        
   !--------------    RANGE LIMIT QUANTITIES --------------------------!

        WHERE (tau(:,:,:,:) .lt. taumin)
               tau(:,:,:,:) = taumin
        END WHERE

   !----- ---------    EVALUATE TAU_ICE_DIAG (OPTIONAL) ---------------!

        
        if (present(tau_ice_diag)) then
               tau_ice_diag(:,:,:,:) = 0.
               tau_ice_diag(:,:,:,:) = tau_ice(:,:,:,:)
        end if
 

END SUBROUTINE CLOUD_OPTICAL_PROPERTIES






                  end module cloud_rad_mod

      





module cloud_zonal_mod

!=======================================================================
!
!       determines zonal cloud amounts and model levels.
!
!=======================================================================

use time_manager_mod, only:  time_type
use  time_interp_mod, only:  fraction_of_year
use          fms_mod, only:  error_mesg, FATAL, open_file, &
                             close_file, mpp_pe, mpp_root_pe, &
                             write_version_number

implicit none
private

public   cloud_zonal, cloud_zonal_init, getcld

!------------------- private data used by this module ------------------

   integer                 :: iseason = -1
   real, dimension(37,3,4) :: camt
   real, dimension(37,4)   :: phigh,pmidl,ptop,pbtm
   real                    :: rad2deg

   character(len=128) :: version = '$Id: cloud_zonal.F90,v 13.0 2006/03/28 21:07:56 fms Exp $'
   character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
   logical            :: module_is_initialized = .false.

!-----------------------------------------------------------------------
!--------cloud amounts every 5 deg. for high,mid, & low-----------------
!-----------------------------------------------------------------------
!--------------------------- w i n t e r -------------------------------
      data camt(:,:,1)  &
           / 0.0850,0.1000,0.1150,0.1300,0.1570,0.1840,0.1970,0.2090, &
      0.2030,0.1970,0.1860,0.1740,0.1570,0.1390,0.1360,0.1320,0.1590, &
      0.1860,0.2300,0.2300,0.2130,0.1960,0.1760,0.1560,0.1460,0.1360, &
      0.1570,0.1780,0.1990,0.2190,0.2420,0.2640,0.2830,0.3010,0.2770, &
      0.2520,0.2270,0.0730,0.0780,0.0830,0.0880,0.0990,0.1110,0.1210, &
      0.1310,0.1220,0.1120,0.0950,0.0780,0.0690,0.0600,0.0550,0.0500, &
      0.0600,0.0700,0.0830,0.0810,0.0760,0.0700,0.0650,0.0590,0.0650, &
      0.0700,0.0790,0.0880,0.0990,0.1100,0.1140,0.1180,0.1220,0.1260, &
      0.1180,0.1100,0.1020,0.2500,0.2770,0.3040,0.3300,0.3750,0.4200, &
      0.4380,0.4550,0.4410,0.4260,0.3840,0.3410,0.2910,0.2410,0.2310, &
      0.2200,0.2610,0.3020,0.3500,0.3420,0.3270,0.3120,0.2920,0.2710, &
      0.2730,0.2750,0.3340,0.3920,0.4240,0.4560,0.4650,0.4740,0.4830, &
      0.4910,0.4710,0.4510,0.4310 /
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!--------------------------- s p r i n g -------------------------------
      data camt(:,:,2)  &
           / 0.2080,0.2170,0.2260,0.2340,0.2390,0.2440,0.2510,0.2580, &
      0.2520,0.2460,0.2370,0.2280,0.2030,0.1780,0.1820,0.1850,0.2100, &
      0.2360,0.2630,0.2470,0.2300,0.2120,0.1900,0.1670,0.1770,0.1870, &
      0.2020,0.2170,0.2500,0.2830,0.3040,0.3250,0.3330,0.3410,0.2960, &
      0.2500,0.2040,0.0720,0.0780,0.0840,0.0890,0.0960,0.1030,0.1180, &
      0.1340,0.1270,0.1200,0.1050,0.0900,0.0800,0.0700,0.0680,0.0650, &
      0.0690,0.0730,0.0780,0.0760,0.0730,0.0700,0.0670,0.0640,0.0700, &
      0.0760,0.0970,0.1180,0.1340,0.1490,0.1460,0.1440,0.1430,0.1420, &
      0.1220,0.1020,0.0820,0.3580,0.3750,0.3920,0.4100,0.4080,0.4070, &
      0.4050,0.4030,0.3900,0.3770,0.3450,0.3130,0.2760,0.2380,0.2370, &
      0.2360,0.2700,0.3050,0.3385,0.3200,0.3030,0.2860,0.2640,0.2410, &
      0.2600,0.2780,0.3180,0.3580,0.3970,0.4360,0.4550,0.4740,0.4700, &
      0.4650,0.4300,0.3950,0.3600 /
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!--------------------------- s u m m e r -------------------------------
      data camt(:,:,3)  &
           / 0.2270,0.2520,0.2770,0.3010,0.2830,0.2640,0.2420,0.2190, &
      0.1990,0.1780,0.1570,0.1360,0.1460,0.1560,0.1760,0.1960,0.2130, &
      0.2300,0.2300,0.1860,0.1590,0.1320,0.1360,0.1390,0.1570,0.1740, &
      0.1860,0.1970,0.2030,0.2090,0.1970,0.1840,0.1570,0.1300,0.1150, &
      0.1000,0.0850,0.1020,0.1100,0.1180,0.1260,0.1220,0.1180,0.1140, &
      0.1100,0.0990,0.0880,0.0790,0.0700,0.0650,0.0590,0.0650,0.0700, &
      0.0760,0.0810,0.0830,0.0700,0.0600,0.0500,0.0550,0.0600,0.0690, &
      0.0780,0.0950,0.1120,0.1220,0.1310,0.1210,0.1110,0.0990,0.0880, &
      0.0830,0.0780,0.0730,0.4310,0.4510,0.4710,0.4910,0.4830,0.4740, &
      0.4650,0.4560,0.4240,0.3920,0.3340,0.2750,0.2730,0.2710,0.2920, &
      0.3120,0.3270,0.3420,0.3500,0.3020,0.2610,0.2200,0.2310,0.2410, &
      0.2910,0.3410,0.3840,0.4260,0.4410,0.4550,0.4380,0.4200,0.3750, &
      0.3300,0.3040,0.2770,0.2500 /
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!----------------------------- f a l l ---------------------------------
      data camt(:,:,4)   &
           / 0.2040,0.2500,0.2960,0.3410,0.3330,0.3250,0.3040,0.2830, &
      0.2500,0.2170,0.2020,0.1870,0.1770,0.1670,0.1900,0.2120,0.2300, &
      0.2470,0.2630,0.2360,0.2100,0.1850,0.1820,0.1780,0.2030,0.2280, &
      0.2370,0.2460,0.2520,0.2580,0.2510,0.2440,0.2390,0.2340,0.2260, &
      0.2170,0.2080,0.0820,0.1020,0.1220,0.1420,0.1430,0.1440,0.1460, &
      0.1490,0.1340,0.1180,0.0970,0.0760,0.0700,0.0640,0.0670,0.0700, &
      0.0730,0.0760,0.0780,0.0730,0.0690,0.0650,0.0680,0.0700,0.0800, &
      0.0900,0.1050,0.1200,0.1270,0.1340,0.1180,0.1030,0.0960,0.0890, &
      0.0840,0.0780,0.0720,0.3600,0.3950,0.4300,0.4650,0.4700,0.4740, &
      0.4550,0.4360,0.3970,0.3580,0.3180,0.2780,0.2600,0.2410,0.2640, &
      0.2860,0.3030,0.3200,0.3385,0.3050,0.2700,0.2360,0.2370,0.2380, &
      0.2760,0.3130,0.3450,0.3770,0.3900,0.4030,0.4050,0.4070,0.4080, &
      0.4100,0.3920,0.3750,0.3580 /
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!---------pressure for high clouds (winter,spring,summer,fall)----------
      data  phigh  &
     /42253., 41101., 39434., 37223., 35249., 34212., 33924., 33682., &
      32911., 31304., 28946., 26365., 23980., 21839., 20149., 19267., &
      19074., 19104., 19115., 19111., 19113., 19126., 19191., 19445., &
      20168., 21652., 23863., 26357., 28787., 31081., 32924., 33884., &
      34093., 34061., 34049., 34053., 34053., &
      34053., 34053., 34053., 34051., 34038., 33967., 33690., 32907., &
      31304., 28947., 26364., 23980., 21839., 20149., 19267., 19074., &
      19104., 19115., 19111., 19113., 19126., 19191., 19445., 20168., &
      21652., 23863., 26357., 28787., 31081., 32924., 33884., 34093., &
      34061., 34049., 34053., 34053., 34053., &
      34053., 34053., 34051., 34038., 33967., 33690., 32907., 31304., &
      28947., 26364., 23980., 21839., 20149., 19267., 19074., 19104., &
      19115., 19111., 19113., 19126., 19191., 19445., 20168., 21652., &
      23863., 26357., 28787., 31081., 32926., 33900., 34184., 34442., &
      35242., 36864., 39075., 41055., 42253., &
      34053., 34053., 34053., 34051., 34038., 33967., 33690., 32907., &
      31304., 28947., 26364., 23980., 21839., 20149., 19267., 19074., &
      19104., 19115., 19111., 19113., 19126., 19191., 19445., 20168., &
      21652., 23863., 26357., 28787., 31081., 32924., 33884., 34093., &
      34061., 34049., 34053., 34053., 34053./
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!--------pressure for middle clouds (winter,spring,summer,fall)---------
      data  pmidl  &
     /63172., 63172., 63172., 63172., 63172., 63172., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172., 63170., 63155., 63080., &
      62786., 61964., 60324., 58078., 56082., 55059., 54916., 55244., &
      56080., 57715., 59961., 61959., 62996., 63215., 63180., 63167., &
      63172., 63172., 63172., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172., 63172., 63172., 63170., &
      63155., 63080., 62786., 61964., 60324., 58078., 56079., 55043., &
      54824., 54859., 54874., 54883., 54959., 55252., 56075., 57715., &
      59961., 61959., 62996., 63215., 63180., 63167., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172., 63170., 63155., 63080., &
      62786., 61964., 60324., 58078., 56082., 55059., 54916., 55244., &
      56080., 57715., 59961., 61959., 62996., 63215., 63180., 63167., &
      63172., 63172., 63172., 63172., 63172., 63172., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172., 63172., 63172., 63170., &
      63155., 63080., 62786., 61964., 60324., 58078., 56079., 55043., &
      54824., 54859., 54874., 54883., 54959., 55252., 56075., 57715., &
      59961., 61959., 62996., 63215., 63180., 63167., 63172., 63172., &
      63172., 63172., 63172., 63172., 63172./
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!-------pressure for top of low clouds (winter,spring,summer,fall)------
      data  ptop  &
     /75056., 75056., 75056., 75056., 75056., 75056., 75055., 75054., &
      75040., 74969., 74694., 73923., 72386., 70281., 68406., 67421., &
      67141., 66886., 66099., 64550., 62622., 61462., 62058., 64061., &
      66082., 67189., 67675., 68412., 69937., 72047., 73919., 74890., &
      75096., 75063., 75051., 75056., 75056., &
      75056., 75056., 75056., 75055., 75054., 75040., 74969., 74694., &
      73923., 72386., 70281., 68408., 67437., 67232., 67264., 67276., &
      67272., 67272., 67272., 67272., 67272., 67274., 67287., 67358., &
      67633., 68404., 69941., 72046., 73919., 74890., 75096., 75063., &
      75051., 75056., 75056., 75055., 75056., &
      75056., 75055., 75054., 75040., 74969., 74694., 73923., 72386., &
      70279., 68392., 67347., 66853., 66087., 64555., 62622., 61461., &
      62058., 64059., 66068., 67118., 67400., 67641., 68400., 69942., &
      72047., 73919., 74890., 75096., 75063., 75051., 75056., 75056., &
      75055., 75056., 75056., 75056., 75056., &
      75056., 75056., 75056., 75055., 75054., 75040., 74969., 74694., &
      73923., 72386., 70281., 68408., 67437., 67232., 67264., 67276., &
      67272., 67272., 67272., 67272., 67272., 67274., 67287., 67358., &
      67633., 68404., 69941., 72046., 73919., 74890., 75096., 75063., &
      75051., 75056., 75056., 75055., 75056./
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!------pressure for bottom of low clouds (winter,spring,summer,fall)----
      data  pbtm  &
     /93819., 93818., 93809., 93761., 93574., 93051., 92008., 90580., &
      89309., 88650., 88510., 88532., 88541., 88538., 88538., 88538., &
      88538., 88538., 88538., 88538., 88538., 88538., 88538., 88538., &
      88538., 88538., 88538., 88538., 88539., 88548., 88596., 88783., &
      89306., 90348., 91772., 93048., 93819., &
      93819., 93575., 93050., 92008., 90580., 89309., 88650., 88510., &
      88532., 88541., 88538., 88538., 88538., 88538., 88538., 88538., &
      88538., 88538., 88538., 88538., 88538., 88538., 88538., 88538., &
      88538., 88538., 88538., 88539., 88548., 88596., 88783., 89306., &
      90349., 91778., 93048., 93699., 93819., &
      93819., 93077., 92003., 90579., 89309., 88650., 88510., 88532., &
      88541., 88538., 88538., 88538., 88538., 88538., 88538., 88538., &
      88538., 88538., 88538., 88538., 88538., 88538., 88538., 88538., &
      88539., 88548., 88596., 88783., 89306., 90349., 91777., 93048., &
      93707., 93847., 93825., 93817., 93819., &
      93819., 93575., 93050., 92008., 90580., 89309., 88650., 88510., &
      88532., 88541., 88538., 88538., 88538., 88538., 88538., 88538., &
      88538., 88538., 88538., 88538., 88538., 88538., 88538., 88538., &
      88538., 88538., 88538., 88539., 88548., 88596., 88783., 89306., &
      90349., 91778., 93048., 93699., 93819./
!-----------------------------------------------------------------------
!   note:  the fels-schwarzkopf radiation code permits bi-spectral
!          cloud reflectivity associated with cloud cdwtr droplets:
!            -->  visible band - (cao3sw and cuvrf);
!            -->  near infra-red band - (cah2sw and cirrf).
!          the f-s code assumes that all gaseous absorption by
!          cdwtr vapor occurs in the near infra-red band.
!          thus, original code contains cbsw and cirab.
!          we shall include cbo3sw and cuvab and let cbsw = cbh2sw.
!          however, these spectral absorptivities will be set to zero.

   real, dimension(3) :: cao3sw = (/ 0.210, 0.450, 0.590 /)
   real, dimension(3) :: cah2sw = (/ 0.210, 0.450, 0.590 /)
   real, dimension(3) :: cbsw   = (/ 0.005, 0.020, 0.035 /)

!-----------------------------------------------------------------------

contains

!#######################################################################

subroutine cloud_zonal_init (season)

!-----------------------------------------------------------------------
!
!             initialization routine for retrieval of 
!             zonal cloud amounts and level indices.
!
!   input argument
!   --------------
!
!      season     scalar integer between 1-5
!                 where 1-4 uses fixed data (1=winter, 2=spring, etc.)
!                 season=5 is seasonal varying clouds
!

      integer, intent(in) :: season

      character(len=34) :: err_string
!-----------------------------------------------------------------------

!---- error checks -----

      if (iseason /= -1) then
          return
!DEL      call error_mesg ('cloud_zonal_init',  &
!DEL           'initialization routine can not be called twice.', FATAL)
      endif

      if (season < 1 .or. season > 5) then
          write (err_string,9001) season
 9001     format ('invalid value of season=',i10)
          call error_mesg ('cloud_zonal_init', err_string, FATAL)
      endif

      iseason=season

      rad2deg=90./acos(0.0)

!---- print version number to logfile ----

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.
!-----------------------------------------------------------------------

end subroutine cloud_zonal_init

!#######################################################################
 subroutine cloud_zonal_end

      module_is_initialized =.false.
!-----------------------------------------------------------------------

end subroutine cloud_zonal_end

!#######################################################################

subroutine getcld (time, lat, phalf, ktopsw, kbtmsw, cldamt)

!-----------------------------------------------------------------------
!
!  routine for retrieval of zonal cloud amounts and level indices.
!
!   input arguments
!   --------------
!
!      time       time of year (time_type)
!      lat        latitudes in radians, dimensioned by ncol   
!      phalf      pressure at model layer interfaces,
!                    dimensioned mxcol x nlev, although only
!                    the first ncol points of the first dimension
!                    are processed
!
!   output arguments
!   ----------------
!
!   (all output arguments are dimensioned ncol x 3; the second
!    dimension represents high, middle, and low clouds)
!
!      ktopsw     model layer interface indices for cloud tops
!      kbtmsw     model layer interface indices for cloud bottoms
!      cldamt     fractional cloud amounts
!

type(time_type), intent(in)  :: time
real,            intent(in)  :: lat(:,:), phalf(:,:,:)
integer,         intent(out) :: ktopsw(:,:,:),kbtmsw(:,:,:)
real , intent(out), optional :: cldamt(:,:,:)

!-----------------------------------------------------------------------

real     dlag,rsea,dsea,than,pptop,ppmid,ppbtm,phdeg,  &
         pcnt,ppup,pplo, fyear
integer  i,j,k,n,isea1,isea2,kmx,lat1,ltop,lbtm

!-----------------------------------------------------------------------
      real  cam (37,3),phi(37),pmi(37),plu(37),plb(37)
!-----------------------------------------------------------------------

      if (iseason == -1) then
          call cloud_zonal_init (5)
      endif
      
!-----------------------------------------------------------------------
!--------------time interpolation if seasonally varying-----------------
!-----------------------------------------------------------------------
   if (iseason == 5) then

      fyear = fraction_of_year (time)

      dlag=1./24.
      rsea=4.*(fyear-dlag)+1.0
      isea1=int(rsea)
      dsea=rsea-float(isea1)
      if (isea1 < 1) isea1=isea1+4
      if (isea1 > 4) isea1=isea1-4
      isea2=isea1+1
      if (isea2 > 4) isea2=isea2-4

      cam(:,:) = camt(:,:,isea1)+dsea*(camt(:,:,isea2)-camt(:,:,isea1))
      phi(:)   = phigh(:,isea1) + dsea*(phigh(:,isea2)-phigh(:,isea1))
      pmi(:)   = pmidl(:,isea1) + dsea*(pmidl(:,isea2)-pmidl(:,isea1))
      plu(:)   = ptop (:,isea1) + dsea*(ptop (:,isea2)-ptop (:,isea1))
      plb(:)   = pbtm (:,isea1) + dsea*(pbtm (:,isea2)-pbtm (:,isea1))

                       else

!-----------------------------------------------------------------------
!--------------no interpolation: not seasonally varying-----------------
!-----------------------------------------------------------------------
         cam(:,:)=camt(:,:,iseason)
         phi(:) = phigh(:,iseason)
         pmi(:) = pmidl(:,iseason)
         plu(:) = ptop (:,iseason)
         plb(:) = pbtm (:,iseason)

                       endif
!-----------------------------------------------------------------------
!=======================================================================
!---------------------vertical interpolation----------------------------
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!    cloud interpolation ---> 18 level data to more than 18 levels
!
!       high cloud (lc=1)     interpolates to upper layer interfaces
!        mid cloud (lc=2)     interpolates to middle of layer
!        low cloud (lc=3)     interpolates to upper and lower
!                                    layer interfaces
!
!        **** note: high and middle clouds are one layer thick
!-----------------------------------------------------------------------
      kmx=size(phalf,3)

   do n=1,3
   do j=1,size(lat,2)
   do i=1,size(lat,1)
!-----------------------------------------------------------------------
      phdeg=max(min(lat(i,j)*rad2deg,90.),-90.)
      lat1=19.000-0.20*phdeg
      lat1=max(min(lat1,36),1)
      than=(19-lat1)-0.20*phdeg
!-----------------------------------------------------------------------

!       ------ cloud amount ------
      if (present(cldamt)) then
         cldamt(i,j,n)=cam(lat1,n)+than*(cam(lat1+1,n)-cam(lat1,n))
      endif

!******************** high and low clouds ******************************
                    if (n == 1 .or. n == 3) then
      if (n == 1) pptop=phi(lat1)+than*(phi(lat1+1)-phi(lat1))
      if (n == 3) pptop=plu(lat1)+than*(plu(lat1+1)-plu(lat1))

!    --- upper interface ---
          do 801 k=2,kmx
      if (pptop > phalf(i,j,k)) go to 801
      if ( abs(pptop-phalf(i,j,k-1)) < abs(pptop-phalf(i,j,k)) ) then
              ltop=k-1
      else
              ltop=k
      endif
      go to 802
 801  continue
      ltop=kmx
 802  continue
      if (n == 1) lbtm=ltop+1
                    endif
!***********************************************************************
!
!******************** middle clouds only *******************************
                    if (n == 2) then
      ppmid=pmi(lat1)+than*(pmi(lat1+1)-pmi(lat1))

!    --- upper interface ---
          do 803 k=2,kmx
      if (ppmid > phalf(i,j,k)) go to 803
              ltop=k-1
              lbtm=k
              go to 804
 803  continue
      ltop=kmx
      lbtm=kmx
 804  continue
                    endif
!***********************************************************************
!
!******************** low clouds only**********************************
                    if (n == 3) then
      ppbtm=plb(lat1)+than*(plb(lat1+1)-plb(lat1))

!    --- lower interface ---
         do 807 k=2,kmx
      if (ppbtm > phalf(i,j,k)) go to 807
      if ( abs(ppbtm-phalf(i,j,k-1)) < abs(ppbtm-phalf(i,j,k)) ) then
              lbtm=k-1
      else
              lbtm=k
      endif
      go to 808
 807  continue
      lbtm=kmx
 808  continue

      if (ltop == lbtm) then
          pcnt=pptop+ppbtm
          ppup=phalf(i,j,ltop-1)+phalf(i,j,lbtm  )
          pplo=phalf(i,j,ltop  )+phalf(i,j,lbtm+1)
            if ( abs(pcnt-ppup) <= abs(pcnt-pplo) ) then
                ltop=ltop-1
            else
                lbtm=lbtm+1
            endif
      endif
                    endif
!***********************************************************************

      if ( n >= 2 ) then
          if ( ltop <  kbtmsw(i,j,n-1) )  ltop=kbtmsw(i,j,n-1)
          if ( lbtm <= ltop )             lbtm=ltop+1
      endif

      ktopsw(i,j,n)=ltop
      kbtmsw(i,j,n)=lbtm

!-----------------------------------------------------------------------
   enddo
   enddo
   enddo
!-----------------------------------------------------------------------

end subroutine getcld

!#######################################################################

subroutine cloud_zonal (time, lat, phalf,  &
                        nclds, ktopsw, kbtmsw, ktoplw, kbtmlw,  &
                        cldamt, cuvrf, cirrf, cirab, emcld)

!-----------------------------------------------------------------------
type(time_type), intent(in) :: time
           real, intent(in) :: lat(:,:), phalf(:,:,:)
integer, intent(out), dimension(:,:)   :: nclds
integer, intent(out), dimension(:,:,:) :: ktopsw,kbtmsw,ktoplw,kbtmlw
   real, intent(out), dimension(:,:,:) :: cldamt,cuvrf,cirrf,cirab,emcld
!-----------------------------------------------------------------------
integer,dimension(size(ktopsw,1),size(ktopsw,2),3) :: ktopsw3,kbtmsw3
   real,dimension(size(cldamt,1),size(cldamt,2),3) :: cldamt3
integer  k
!-----------------------------------------------------------------------

!!    kp1=size(ktopsw,3)

!  ------- default clouds --------

!!    cldamt=0.0; emcld =1.0
!!    cuvrf =0.0; cirrf =0.0; cirab =0.0
!!    ktopsw=kp1; kbtmsw=kp1
!!    ktoplw=kp1; kbtmlw=kp1
!     ---- reset top properties ----
!!    ktopsw(:,:,1)=1
!!    kbtmsw(:,:,1)=0
!!    ktoplw(:,:,1)=1
!!    kbtmlw(:,:,1)=0


!-------- insert the 3 cloud layers into array positions 1-3 -----------

      call getcld (time, lat, phalf, ktopsw3, kbtmsw3, cldamt3)

      nclds = 3
      emcld = 1.0

   do k = 1,3
      ktopsw(:,:,k)=ktopsw3(:,:,k)
      kbtmsw(:,:,k)=kbtmsw3(:,:,k)
      cldamt(:,:,k)=cldamt3(:,:,k)

      ktoplw(:,:,k)=ktopsw(:,:,k)
      kbtmlw(:,:,k)=kbtmsw(:,:,k)-1
      cuvrf (:,:,k)=cao3sw(k)
      cirrf (:,:,k)=cah2sw(k)
      cirab (:,:,k)=cbsw  (k)
   enddo

!-----------------------------------------------------------------------

end subroutine cloud_zonal

!#######################################################################

end module cloud_zonal_mod



 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp.F90,v 1.1.2.1 2010/03/04 08:04:37 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#include "cosp_defs.h"
MODULE MOD_COSP
  USE MOD_COSP_TYPES
  USE MOD_COSP_SIMULATOR
  USE MOD_COSP_MODIS_SIMULATOR
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------------- SUBROUTINE COSP ---------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#ifdef RTTOV
SUBROUTINE COSP(me,overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar, sghydro,cloud_type)
#else
SUBROUTINE COSP(me,overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar, sghydro, cloud_type)
#endif

  ! Arguments
  integer, intent(in) :: me
  integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
  integer,intent(in) :: Ncolumns
  type(cosp_config),intent(in) :: cfg   ! Configuration options
  type(cosp_vgrid),intent(in) :: vgrid   ! Information on vertical grid of stats
  type(cosp_gridbox),intent(inout) :: gbx
  type(cosp_subgrid),intent(inout) :: sgx   ! Subgrid info
  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
  type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator
  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
  type(cosp_MODIS),intent(inout)   :: modis   ! Output from MODIS simulator
#ifdef RTTOV
  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
#endif
  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
  type(cosp_sghydro), intent(inout)   :: sghydro   ! Subgrid info for hydrometeors en each iteration
  real, dimension(gbx%Npoints, Ncolumns, gbx%Nlevels),  &
                  intent(in), optional ::  cloud_type

  ! Local variables 
  integer :: Npoints   ! Number of gridpoints
  integer :: Nlevels   ! Number of levels
  integer :: Nhydro    ! Number of hydrometeors
  integer :: Niter     ! Number of calls to cosp_simulator
  integer :: i_first,i_last ! First and last gridbox to be processed in each iteration
  integer :: i,j,k,Ni
  integer,dimension(2) :: ix,iy
  logical :: reff_zero
  real :: minv,maxv
  real :: maxp,minp
  integer,dimension(:),allocatable :: & ! Dimensions nPoints
                  seed    !  It is recommended that the seed is set to a different value for each model
                          !  gridbox it is called on, as it is possible that the choice of the same 
                          !  seed value every time may introduce some statistical bias in the results, 
                          !  particularly for low values of NCOL.
  ! Types used in one iteration
  type(cosp_gridbox) :: gbx_it
  type(cosp_subgrid) :: sgx_it
  type(cosp_sghydro) :: sghydro_it
  type(cosp_vgrid)   :: vgrid_it
  type(cosp_sgradar) :: sgradar_it
  type(cosp_sglidar) :: sglidar_it
  type(cosp_isccp)   :: isccp_it
  type(cosp_MODIS)   :: modis_it
  type(cosp_misr)    :: misr_it
#ifdef RTTOV
  type(cosp_rttov)   :: rttov_it
#endif
  type(cosp_radarstats) :: stradar_it
  type(cosp_lidarstats) :: stlidar_it
  
  !++++++++++ Dimensions ++++++++++++
  Npoints  = gbx%Npoints
  Nlevels  = gbx%Nlevels
  Nhydro   = gbx%Nhydro

!++++++++++ Apply sanity checks to inputs ++++++++++
  call cosp_check_input('longitude',gbx%longitude,min_val=0.0,max_val=360.0)
  call cosp_check_input('latitude',gbx%latitude,min_val=-90.0,max_val=90.0)
  call cosp_check_input('dlev',gbx%dlev,min_val=0.0)
  call cosp_check_input('p',gbx%p,min_val=0.0)
  call cosp_check_input('ph',gbx%ph,min_val=0.0)
  call cosp_check_input('T',gbx%T,min_val=0.0)
  call cosp_check_input('q',gbx%q,min_val=0.0)
  call cosp_check_input('sh',gbx%sh,min_val=0.0)
  call cosp_check_input('dtau_s',gbx%dtau_s,min_val=0.0)
  call cosp_check_input('dtau_c',gbx%dtau_c,min_val=0.0)
  call cosp_check_input('dem_s',gbx%dem_s,min_val=0.0,max_val=1.0)
  call cosp_check_input('dem_c',gbx%dem_c,min_val=0.0,max_val=1.0)
  ! Point information (Npoints)
  call cosp_check_input('land',gbx%land,min_val=0.0,max_val=1.0)
  call cosp_check_input('psfc',gbx%psfc,min_val=0.0)
  call cosp_check_input('sunlit',gbx%sunlit,min_val=0.0,max_val=1.0)
  call cosp_check_input('skt',gbx%skt,min_val=0.0)
  ! TOTAL and CONV cloud fraction for SCOPS
  call cosp_check_input('tca',gbx%tca,min_val=0.0,max_val=1.0)
  call cosp_check_input('cca',gbx%cca,min_val=0.0,max_val=1.0)
  ! Precipitation fluxes on model levels
  call cosp_check_input('rain_ls',gbx%rain_ls,min_val=0.0)
  call cosp_check_input('rain_cv',gbx%rain_cv,min_val=0.0)
  call cosp_check_input('snow_ls',gbx%snow_ls,min_val=0.0)
  call cosp_check_input('snow_cv',gbx%snow_cv,min_val=0.0)
  call cosp_check_input('grpl_ls',gbx%grpl_ls,min_val=0.0)
  ! Hydrometeors concentration and distribution parameters
  call cosp_check_input('mr_hydro',gbx%mr_hydro,min_val=0.0)
  ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
  call cosp_check_input('Reff',gbx%Reff,min_val=0.0)

  reff_zero=.true.
  if (any(gbx%Reff > 1.e-8)) then
     reff_zero=.false.
      ! reff_zero == .false.
      !     and gbx%use_reff == .true.   Reff use in radar and lidar
      !     and reff_zero    == .false.  Reff use in lidar and set to 0 for radar
  endif
  if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar
        gbx%Reff = DEFAULT_LIDAR_REFF
        print *, '---------- COSP WARNING ------------'
        print *, ''
        print *, 'Using default Reff in lidar simulations'
        print *, ''
        print *, '----------------------------------'
  endif
  
  ! Aerosols concentration and distribution parameters
  call cosp_check_input('conc_aero',gbx%conc_aero,min_val=0.0)
  ! Check sg tau, emiss, mrs and sizes if they are being input from 
  ! model
  if (sgx%cols_input_from_model) then
  call cosp_check_input('sgx%Reff1',sghydro%Reff(:,:,:,1),min_val=0.0)
  call cosp_check_input('sgx%Reff2',sghydro%Reff(:,:,:,2),min_val=0.0)
  call cosp_check_input('sgx%Reff5',sghydro%Reff(:,:,:,5),min_val=0.0)
  call cosp_check_input('sgx%Reff6',sghydro%Reff(:,:,:,6),min_val=0.0)
  call cosp_check_input('sgx%  mr1',sghydro%mr_hydro(:,:,:,1),min_val=0.0)
  call cosp_check_input('sgx%  mr2',sghydro%mr_hydro(:,:,:,2),min_val=0.0)
  call cosp_check_input('sgx%  mr5',sghydro%mr_hydro(:,:,:,5),min_val=0.0)  
  call cosp_check_input('sgx%  mr6',sghydro%mr_hydro(:,:,:,6),min_val=0.0)
  call cosp_check_input('sgx%  tau',sgx%dtau_col,min_val=0.0)   
  call cosp_check_input('sgx%   em',sgx%dem_col,min_val=0.0)
 endif

   ! We base the seed in the decimal part of the surface pressure.
   allocate(seed(Npoints))
   seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1   
      ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to 
      ! randomize for each call to COSP even when Npoints ==1
   minp = minval(gbx%psfc)
   maxp = maxval(gbx%psfc)
   if (Npoints .gt. 1) seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1

  
   if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints
#ifdef RTTOV
        call cosp_iter(me,overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar,sghydro,cloud_type)
#else
        call cosp_iter(me,overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar, sghydro,cloud_type)
#endif
   else ! Several iterations to save memory
        Niter = gbx%Npoints/gbx%Npoints_it ! Integer division
        if (Niter*gbx%Npoints_it < gbx%Npoints) Niter = Niter + 1
        do i=1,Niter
            i_first = (i-1)*gbx%Npoints_it + 1
            i_last  = i_first + gbx%Npoints_it - 1
            i_last  = min(i_last,gbx%Npoints)
            Ni = i_last - i_first + 1
            if (i == 1) then
                ! Allocate types for all but last iteration
                call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, &
                                            gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, &
                                            Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
                                            gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
                                            gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
                                            gbx%use_precipitation_fluxes,gbx%use_reff, &
                                            gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, &
                                            gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), &
                                            gbx%co2,gbx%ch4,gbx%n2o,gbx%co, &
                                            gbx_it)
                call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it)
                call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it)
                call construct_cosp_sghydro(Ni, Ncolumns, Nlevels, N_hydro, sghydro_it)
                call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it)
                call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
                call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
                call construct_cosp_modis(cfg, Ni, Ncolumns, modis_it)
                call construct_cosp_misr(cfg,Ni,misr_it)
#ifdef RTTOV
                call construct_cosp_rttov(Ni,gbx%nchan,rttov_it)
#endif
                call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
                call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
            elseif (i == Niter) then ! last iteration
                call free_cosp_gridbox(gbx_it,.true.)
                call free_cosp_subgrid(sgx_it)
                call free_cosp_sghydro(sghydro_it)
                call free_cosp_vgrid(vgrid_it)
                call free_cosp_sgradar(sgradar_it)
                call free_cosp_sglidar(sglidar_it)
                call free_cosp_isccp(isccp_it)
                call free_cosp_modis(modis_it)
                call free_cosp_misr(misr_it)
#ifdef RTTOV
                call free_cosp_rttov(rttov_it)
#endif
                call free_cosp_radarstats(stradar_it)
                call free_cosp_lidarstats(stlidar_it)
                ! Allocate types for iterations
                call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,  &
                                            gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,  &
                                            Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
                                            gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
                                            gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
                                            gbx%use_precipitation_fluxes,gbx%use_reff, &
                                            gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, &
                                            gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), &
                                            gbx%co2,gbx%ch4,gbx%n2o,gbx%co, &
                                            gbx_it)
                ! --- Copy arrays without Npoints as dimension ---
                gbx_it%dist_prmts_hydro = gbx%dist_prmts_hydro
                gbx_it%dist_type_aero   = gbx_it%dist_type_aero
                call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it)
                call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it)
                call construct_cosp_sghydro(Ni, Ncolumns, Nlevels, N_hydro, sghydro_it)
                call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it)
                call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
                call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
                call construct_cosp_modis(cfg,Ni, Ncolumns, modis_it)
                call construct_cosp_misr(cfg,Ni,misr_it)
#ifdef RTTOV 
                call construct_cosp_rttov(Ni,gbx%nchan,rttov_it)
#endif
                call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
                call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
            endif
            ! --- Copy sections of arrays with Npoints as dimension ---
            ix=(/i_first,i_last/)
            iy=(/1,Ni/)
            call cosp_gridbox_cpsection(ix,iy,gbx,gbx_it)
              ! These serve as initialisation of *_it types
            call cosp_subgrid_cpsection(ix,iy,sgx,sgx_it)
            if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar,sgradar_it)
            if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it)
            if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it)
            if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis,modis_it)
            if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr,misr_it)
#ifdef RTTOV 
            if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov,rttov_it)
#endif
            if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it)
            if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it)
            print *,'---------ix: ',ix
#ifdef RTTOV
            call cosp_iter(me,overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
                           sglidar_it,isccp_it,misr_it,modis_it,rttov_it,stradar_it,stlidar_it, sghydro_it, cloud_type)
#else
            call cosp_iter(me, overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
                           sglidar_it,isccp_it,misr_it,modis_it,stradar_it,stlidar_it, sghydro_it,cloud_type)
#endif
            
            ! --- Copy results to output structures ---
            ix=(/1,Ni/)
            iy=(/i_first,i_last/)
            call cosp_subgrid_cpsection(ix,iy,sgx_it,sgx)
            if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar_it,sgradar)
            if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar)
            if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp)
            if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis_it,modis)
            if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr_it,misr)
#ifdef RTTOV 
            if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov_it,rttov)
#endif
            if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar)
            if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar)
        enddo
        ! Deallocate types
        call free_cosp_gridbox(gbx_it,.true.)
        call free_cosp_subgrid(sgx_it)
        call free_cosp_sghydro(sghydro_it)
        call free_cosp_vgrid(vgrid_it)
        call free_cosp_sgradar(sgradar_it)
        call free_cosp_sglidar(sglidar_it)
        call free_cosp_isccp(isccp_it)
        call free_cosp_modis(modis_it)
        call free_cosp_misr(misr_it)
#ifdef RTTOV 
        call free_cosp_rttov(rttov_it)
#endif
        call free_cosp_radarstats(stradar_it)
        call free_cosp_lidarstats(stlidar_it)
   endif
   deallocate(seed)

    
END SUBROUTINE COSP

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------------- SUBROUTINE COSP_ITER ----------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#ifdef RTTOV
SUBROUTINE COSP_ITER(me,overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar, sghydro, cloud_type)
#else
SUBROUTINE COSP_ITER(me,overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar, sghydro,cloud_type)
#endif

  ! Arguments
  integer, intent(in) :: me
  integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
  integer,dimension(:),intent(in) :: seed
  type(cosp_config),intent(in) :: cfg   ! Configuration options
  type(cosp_vgrid),intent(in) :: vgrid   ! Information on vertical grid of stats
  type(cosp_gridbox),intent(inout) :: gbx
  type(cosp_subgrid),intent(inout) :: sgx   ! Subgrid info
  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
  type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator
  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
#ifdef RTTOV
  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
#endif
  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
  type(cosp_sghydro), intent(inout)   :: sghydro   ! Subgrid info for hydrometeors en each iteration
  real, dimension(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels),  &
                  intent(in), optional ::  cloud_type

  ! Local variables 
  integer :: Npoints   ! Number of gridpoints
  integer :: Ncolumns  ! Number of subcolumns
  integer :: Nlevels   ! Number of levels
  integer :: Nhydro    ! Number of hydrometeors
  integer :: Niter     ! Number of calls to cosp_simulator
  integer :: i,j,k
  real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out
  integer :: scops_debug=0    !  set to non-zero value to print out inputs for debugging in SCOPS
  real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, &
                     tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud.
                               ! Levels are from TOA to SURFACE. (nPoints, nLev)
  real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level
                                                                     ! Levels are from SURFACE to TOA
! type(cosp_sghydro) :: sghydro   ! Subgrid info for hydrometeors en each iteration

  
  !++++++++++ Dimensions ++++++++++++
  Npoints  = gbx%Npoints
  Ncolumns = gbx%Ncolumns
  Nlevels  = gbx%Nlevels
  Nhydro   = gbx%Nhydro
   
  !++++++++++ Climate/NWP mode ++++++++++  
  if (Ncolumns > 1) then
        !++++++++++ Subgrid sampling ++++++++++
        ! Allocate arrays before calling SCOPS
        allocate(frac_ls(Npoints,Nlevels),frac_cv(Npoints,Nlevels),prec_ls(Npoints,Nlevels),prec_cv(Npoints,Nlevels))
        allocate(tca_scops(Npoints,Nlevels),cca_scops(Npoints,Nlevels), &
                ls_p_rate(Npoints,Nlevels),cv_p_rate(Npoints,Nlevels))
        ! Initialize to zero
        frac_ls=0.0
        prec_ls=0.0
        frac_cv=0.0
        prec_cv=0.0

IF (sgx%cols_input_from_model) then
  sgx%frac_out = cloud_type
ELSE
        ! Cloud fractions for SCOPS from TOA to SFC
        tca_scops = gbx%tca(:,Nlevels:1:-1)
        cca_scops = gbx%cca(:,Nlevels:1:-1)
        
        ! Call to SCOPS
        ! strat and conv arrays are passed with levels from TOA to SURFACE.
        call scops(Npoints,Nlevels,Ncolumns,seed,tca_scops,cca_scops,overlap,sgx%frac_out,scops_debug)
ENDIF
        
        ! temporarily use prec_ls/cv to transfer information about precipitation flux into prec_scops
        if(gbx%use_precipitation_fluxes) then
            ls_p_rate(:,Nlevels:1:-1)=gbx%rain_ls(:,1:Nlevels)+gbx%snow_ls(:,1:Nlevels)+gbx%grpl_ls(:,1:Nlevels)
            cv_p_rate(:,Nlevels:1:-1)=gbx%rain_cv(:,1:Nlevels)+gbx%snow_cv(:,1:Nlevels)
        else
            ls_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_LSRAIN)+ &
                                      gbx%mr_hydro(:,1:Nlevels,I_LSSNOW)+ &
                                      gbx%mr_hydro(:,1:Nlevels,I_LSGRPL)
            cv_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_CVRAIN)+ &
                                      gbx%mr_hydro(:,1:Nlevels,I_CVSNOW)
        endif
        
        call prec_scops(Npoints,Nlevels,Ncolumns,ls_p_rate,cv_p_rate,sgx%frac_out,sgx%prec_frac)
        
        ! Precipitation fraction
        do j=1,Npoints,1
        do k=1,Nlevels,1
            do i=1,Ncolumns,1
                if (sgx%frac_out (j,i,Nlevels+1-k) .eq. I_LSC) frac_ls(j,k)=frac_ls(j,k)+1.
                if (sgx%frac_out (j,i,Nlevels+1-k) .eq. I_CVC) frac_cv(j,k)=frac_cv(j,k)+1.
                if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 1) prec_ls(j,k)=prec_ls(j,k)+1.
                if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 2) prec_cv(j,k)=prec_cv(j,k)+1.
                if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 3) then
                    prec_cv(j,k)=prec_cv(j,k)+1.
                    prec_ls(j,k)=prec_ls(j,k)+1.
                endif
            enddo  !i
            frac_ls(j,k)=frac_ls(j,k)/Ncolumns
            frac_cv(j,k)=frac_cv(j,k)/Ncolumns
            prec_ls(j,k)=prec_ls(j,k)/Ncolumns
            prec_cv(j,k)=prec_cv(j,k)/Ncolumns
        enddo  !k
        enddo  !j
        
         ! Levels from SURFACE to TOA.
        if (Npoints*Ncolumns*Nlevels < 10000) then
            sgx%frac_out(1:Npoints,:,1:Nlevels)  = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
            sgx%prec_frac(1:Npoints,:,1:Nlevels) = sgx%prec_frac(1:Npoints,:,Nlevels:1:-1)
        else
            ! This is done within a loop (unvectorized) over nPoints to save memory
            do j=1,Npoints
                sgx%frac_out(j,:,1:Nlevels)  = sgx%frac_out(j,:,Nlevels:1:-1)
                sgx%prec_frac(j,:,1:Nlevels) = sgx%prec_frac(j,:,Nlevels:1:-1)
            enddo
        endif
       
       ! Deallocate arrays that will no longer be used
        deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate)
         
        ! Populate the subgrid arrays
!       call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
        do k=1,Ncolumns
IF (sgx%cols_input_from_model) then
!   the sghydro%mr_hydro cloud components were previously defined in 
!   cosp_driver and have been passed in 
ELSE
            !--------- Mixing ratios for clouds and Reff for Clouds and precip -------
            column_frac_out => sgx%frac_out(:,k,:)
            where (column_frac_out == I_LSC)     !+++++++++++ LS clouds ++++++++
                sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ)
                sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE)
                
                sghydro%Reff(:,k,:,I_LSCLIQ)     = gbx%Reff(:,:,I_LSCLIQ)
                sghydro%Reff(:,k,:,I_LSCICE)     = gbx%Reff(:,:,I_LSCICE)
                sghydro%Reff(:,k,:,I_LSRAIN)     = gbx%Reff(:,:,I_LSRAIN)
                sghydro%Reff(:,k,:,I_LSSNOW)     = gbx%Reff(:,:,I_LSSNOW)
                sghydro%Reff(:,k,:,I_LSGRPL)     = gbx%Reff(:,:,I_LSGRPL)
            elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++
                sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ) 
                sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE) 
                
                sghydro%Reff(:,k,:,I_CVCLIQ)     = gbx%Reff(:,:,I_CVCLIQ) 
                sghydro%Reff(:,k,:,I_CVCICE)     = gbx%Reff(:,:,I_CVCICE) 
                sghydro%Reff(:,k,:,I_CVRAIN)     = gbx%Reff(:,:,I_CVRAIN) 
                sghydro%Reff(:,k,:,I_CVSNOW)     = gbx%Reff(:,:,I_CVSNOW) 
            end where 
ENDIF
            !--------- Precip -------
            if (.not. gbx%use_precipitation_fluxes) then
                where (column_frac_out == I_LSC)  !+++++++++++ LS Precipitation ++++++++
                    sghydro%mr_hydro(:,k,:,I_LSRAIN) = gbx%mr_hydro(:,:,I_LSRAIN)
                    sghydro%mr_hydro(:,k,:,I_LSSNOW) = gbx%mr_hydro(:,:,I_LSSNOW)
                    sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL)
                elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++
                    sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) 
                    sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) 
                end where 
            endif
        enddo
        ! convert the mixing ratio and precipitation flux from gridbox mean to the fraction-based values
        do k=1,Nlevels
            do j=1,Npoints
!RSH: When  columns are input, are already in-cloud values.
IF (sgx%cols_input_from_model) then
ELSE
                !--------- Clouds -------
                if (frac_ls(j,k) .ne. 0.) then
                    sghydro%mr_hydro(j,:,k,I_LSCLIQ) = sghydro%mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k)
                    sghydro%mr_hydro(j,:,k,I_LSCICE) = sghydro%mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k)
                endif
                if (frac_cv(j,k) .ne. 0.) then
                    sghydro%mr_hydro(j,:,k,I_CVCLIQ) = sghydro%mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k)
                    sghydro%mr_hydro(j,:,k,I_CVCICE) = sghydro%mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k)
                endif
ENDIF
                !--------- Precip -------
                if (gbx%use_precipitation_fluxes) then
                    if (prec_ls(j,k) .ne. 0.) then
                        gbx%rain_ls(j,k) = gbx%rain_ls(j,k)/prec_ls(j,k)
                        gbx%snow_ls(j,k) = gbx%snow_ls(j,k)/prec_ls(j,k)
                        gbx%grpl_ls(j,k) = gbx%grpl_ls(j,k)/prec_ls(j,k)
                    endif
                    if (prec_cv(j,k) .ne. 0.) then
                        gbx%rain_cv(j,k) = gbx%rain_cv(j,k)/prec_cv(j,k)
                        gbx%snow_cv(j,k) = gbx%snow_cv(j,k)/prec_cv(j,k)
                    endif
                else
                    if (prec_ls(j,k) .ne. 0.) then
                        sghydro%mr_hydro(j,:,k,I_LSRAIN) = sghydro%mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k)
                        sghydro%mr_hydro(j,:,k,I_LSSNOW) = sghydro%mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k)
                        sghydro%mr_hydro(j,:,k,I_LSGRPL) = sghydro%mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k)
                    endif
                    if (prec_cv(j,k) .ne. 0.) then
                        sghydro%mr_hydro(j,:,k,I_CVRAIN) = sghydro%mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k)
                        sghydro%mr_hydro(j,:,k,I_CVSNOW) = sghydro%mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k)
                    endif
                endif  
            enddo !k
        enddo !j
        deallocate(frac_ls,prec_ls,frac_cv,prec_cv)
        
        if (gbx%use_precipitation_fluxes) then
            ! convert precipitation flux into mixing ratio

            call pf_to_mr(me,Npoints,Nlevels,Ncolumns,gbx%rain_ls,gbx%snow_ls,gbx%grpl_ls, &
                        gbx%rain_cv,gbx%snow_cv,sgx%prec_frac,gbx%p,gbx%T, &
                        sghydro%mr_hydro(:,:,:,I_LSRAIN),sghydro%mr_hydro(:,:,:,I_LSSNOW),sghydro%mr_hydro(:,:,:,I_LSGRPL), &
                        sghydro%mr_hydro(:,:,:,I_CVRAIN),sghydro%mr_hydro(:,:,:,I_CVSNOW))
        endif
   !++++++++++ CRM mode ++++++++++
   else
!     call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
      sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro
      sghydro%Reff(:,1,:,:) = gbx%Reff
      !--------- Clouds -------
      where ((gbx%dtau_s > 0.0))
             sgx%frac_out(:,1,:) = 1  ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels)
      endwhere
   endif ! Ncolumns > 1
   
   !++++++++++ Simulator ++++++++++
#ifdef RTTOV
    call cosp_simulator(me,gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
#else
    call cosp_simulator(me,gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
#endif


    ! Deallocate subgrid arrays
END SUBROUTINE COSP_ITER

END MODULE MOD_COSP


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp_constants.f90,v 1.1.2.1.2.1.6.1 2010/03/04 08:23:33 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2007 - A. Bodas-Salcedo - Initial version
! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes
! Oct 2008 - H. Chepfer       - Added PARASOL_NREFL
!
! 

MODULE MOD_COSP_CONSTANTS
    IMPLICIT NONE
    
    ! Indices to address arrays of LS and CONV hydrometeors
    integer,parameter :: I_LSCLIQ = 1
    integer,parameter :: I_LSCICE = 2
    integer,parameter :: I_LSRAIN = 3
    integer,parameter :: I_LSSNOW = 4
    integer,parameter :: I_CVCLIQ = 5
    integer,parameter :: I_CVCICE = 6
    integer,parameter :: I_CVRAIN = 7
    integer,parameter :: I_CVSNOW = 8
    integer,parameter :: I_LSGRPL = 9
    
    ! Missing value
    real,parameter :: R_UNDEF = -1.0E30
    ! Number of possible output variables
    integer,parameter :: N_OUT_LIST = 45
    ! Value for forward model result from a level that is under the ground
    real,parameter :: R_GROUND = -1.0E20
    
    ! Stratiform and convective clouds in frac_out
    integer, parameter :: I_LSC = 1, & ! Large-scale clouds
                          I_CVC = 2    ! Convective clouds
    !--- Radar constants
    ! CFAD constants
    integer,parameter :: DBZE_BINS     =   15   ! Number of dBZe bins in histogram (cfad)
    real,parameter    :: DBZE_MIN      = -100.0 ! Minimum value for radar reflectivity
    real,parameter    :: DBZE_MAX      =   80.0 ! Maximum value for radar reflectivity
    real,parameter    :: CFAD_ZE_MIN   =  -50.0 ! Lower value of the first CFAD Ze bin
    real,parameter    :: CFAD_ZE_WIDTH =    5.0 ! Bin width (dBZe)

   
    !--- Lidar constants
    ! CFAD constants
    integer,parameter :: SR_BINS       =   15
    integer,parameter :: DPOL_BINS     =   6
    real,parameter    :: LIDAR_UNDEF   =   999.999
    ! Other constants
    integer,parameter :: LIDAR_NCAT    =   4
    integer,parameter :: PARASOL_NREFL =   5 ! parasol
    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/)
    real,parameter    :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius
    
    !--- MISR constants
    integer,parameter :: MISR_N_CTH = 16

    !--- RTTOV constants
    integer,parameter :: RTTOV_MAX_CHANNELS = 20
    
    ! ISCCP tau-Pc axes
    real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/)
    real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, &
                                                      9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/))
!     real,parameter,dimension(7) :: ISCCP_PC = (/9000., 24500., 37500., 50000., 62000., 74000., 90000./)
!     real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/0.0,18000.0,18000.0,31000.0,31000.0, &
!                                44000.0,44000.0,56000.0,56000.0,68000.0,68000.0,80000.0,80000.0,100000.0/), shape=(/2,7/))
   
    real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./)
    real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/100000.0,80000.0,80000.0,68000.0,68000.0,56000.0 &
                               ,56000.0,44000.0,44000.0,31000.0,31000.0,18000.0,18000.0,0.0/), shape=(/2,7/))
    
    real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = 1000.0*(/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, &
                                            4.5, 6., 8., 10., 12., 14.5, 16., 18./)
    real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = 1000.0*reshape(source=(/ &
                                            -99.0,  0.0,       0.0,  0.5,       0.5,  1.0,      1.0,  1.5, &
                                              1.5,  2.0,       2.0,  2.5,       2.5,  3.0,      3.0,  4.0, &
                                              4.0,  5.0,       5.0,  7.0,       7.0,  9.0,      9.0, 11.0, &
                                             11.0, 13.0,      13.0, 15.0,      15.0, 17.0,     17.0, 99.0/), &
                                             shape=(/2,MISR_N_CTH/))
            
    !  Table hclass for quickbeam
    integer,parameter :: N_HYDRO = 9
    real :: HCLASS_TYPE(N_HYDRO),HCLASS_COL(N_HYDRO),HCLASS_PHASE(N_HYDRO), &
            HCLASS_CP(N_HYDRO),HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO)
    real :: HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
            HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO)
    data HCLASS_TYPE/5,1,2,2,5,1,2,2,2/
    data HCLASS_COL/1,2,3,4,5,6,7,8,9/
    data HCLASS_PHASE/0,1,0,1,0,1,0,1,1/
    data HCLASS_CP/0,0,0,0,0,0,0,0,0/            ! This is not used in the version of Quickbeam included in COSP
    data HCLASS_DMIN/-1,-1,-1,-1,-1,-1,-1,-1,-1/
    data HCLASS_DMAX/-1,-1,-1,-1,-1,-1,-1,-1,-1/
    data HCLASS_APM/524,110.8,524, -1,524,110.8,524, -1, -1/
    data HCLASS_BPM/  3, 2.91,  3, -1,  3, 2.91,  3, -1, -1/
    data HCLASS_RHO/ -1,   -1, -1,100, -1,   -1, -1,100,400/
    data HCLASS_P1/ -1,-1,8000000.,3000000., -1,-1,8000000.,3000000.,4000000./
    data HCLASS_P2/  6,40,      -1,      -1,  6,40,      -1,      -1,      -1/
    data HCLASS_P3/0.3, 2,      -1,      -1,0.3, 2,      -1,      -1,      -1/

!                     LSL    LSI   LSR     LSS   CVL    CVI   CVR     CVS     LSG
!     data HCLASS_TYPE/   1,     1,    1,     -1,    1,     1,    1,      1,     -1/
!     data HCLASS_COL/    1,     2,    3,      4,    5,     6,    7,      8,      9/
!     data HCLASS_PHASE/  0,     1,    0,      1,    0,     1,    0,      1,      1/
!     data HCLASS_CP/     0,     0,    0,      0,    0,     0,    0,      0,      0/ ! This is not used in the version of Quickbeam included in COSP
!     data HCLASS_DMIN/  -1,    -1,   -1,     -1,   -1,    -1,   -1,     -1,     -1/
!     data HCLASS_DMAX/  -1,    -1,   -1,     -1,   -1,    -1,   -1,     -1,     -1/
!     data HCLASS_APM/   -1, 0.587,   -1, 0.0444,   -1, 0.587,   -1, 0.0444,  261.8/
!     data HCLASS_BPM/   -1,  2.45,   -1,    2.1,   -1,  2.45,   -1,    2.1,      3/
!     data HCLASS_RHO/ 1000,    -1, 1000,     -1, 1000,    -1, 1000,     -1,     -1/
!     data HCLASS_P1/    -1,    -1,   -1,     -1,   -1,    -1,   -1,     -1,     -1/
!     data HCLASS_P2/    10,    40, 1000,    120,   10,    40, 1000,    120,   1000/
!     data HCLASS_P3/     3,     1,    1,      1,    3,     1,    1,      1,    3.5/


END MODULE MOD_COSP_CONSTANTS



! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without mod        ification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distributio
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THECOPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
!
! History:
! Feb 2008 - A. Bodas-Salcedo - Initial version
!

#include "cosp_defs.h"
!PROGRAM COSPTEST
module cosp_driver_mod

use mpp_mod,        only: input_nml_file
use fms_mod,            only: open_namelist_file, open_file,  &
                              close_file, error_mesg, FATAL, &
                              file_exist, mpp_pe, mpp_root_pe,   &
                              check_nml_error, write_version_number, &
                              stdlog
use sat_vapor_pres_mod, only: compute_qs
use time_manager_mod, only: set_date, time_type, operator (+), &
                            operator(-), &
                            operator(<), operator(>), operator(<=), &
                            operator(>=),  get_date, print_date, &
                            get_calendar_type, NOLEAP, &
                            assignment(=), set_time
use diag_grid_mod, only: get_local_indexes2
use diag_manager_mod,   only: register_diag_field, send_data,  &
                              diag_axis_init, register_static_field
USE MOD_COSP_TYPES,     only: cosp_config, cosp_gridbox, cosp_subgrid,&
                              cosp_sgradar, cosp_sglidar, cosp_isccp, &
#ifdef RTTOV
                              cosp_rttov, &
#endif
                              cosp_vgrid, cosp_radarstats,  &
                              cosp_lidarstats, &
                              cosp_sghydro,  cosp_misr, &
                              construct_cosp_gridbox,  &
                              construct_cosp_misr,  &
                              construct_cosp_vgrid,  &
                              construct_cosp_subgrid, &
                              construct_cosp_sghydro, &
                              construct_cosp_sgradar, &
                              construct_cosp_radarstats, &
                              construct_cosp_sglidar, &
                              construct_cosp_lidarstats, &
                              construct_cosp_isccp, &           
#ifdef RTTOV
                              construct_cosp_rttov, &           
                              free_cosp_rttov, &           
#endif
                              free_cosp_gridbox,  &
                              free_cosp_misr,  &
                              free_cosp_vgrid,  &
                              free_cosp_subgrid, &
                              free_cosp_sghydro, &
                              free_cosp_sgradar, &
                              free_cosp_radarstats, &
                              free_cosp_sglidar, &
                              free_cosp_lidarstats, &
                              free_cosp_isccp
USE MOD_COSP,           only: cosp
USE MOD_COSP_IO,        only: read_cosp_output_nl,  &
!   references to these routines are currently commented out when
!   COSP is run within GCM
!                             nc_read_input_file,&
!                             nc_write_cosp_1d, nc_write_cosp_2d, &
                              map_ll_to_point, map_point_to_ll
                       
use MOD_COSP_CONSTANTS, only: DBZE_BINS,SR_BINS, PARASOL_NREFL,  &
                              PARASOL_SZA, CFAD_ZE_MIN, CFAD_ZE_WIDTH, &
                              LIDAR_UNDEF, ISCCP_PC_BNDS, ISCCP_TAU, &
                              I_LSCLIQ, I_LSCICE, I_CVCLIQ, I_CVCICE, &
                              I_LSGRPL, &
                              I_LSRAIN, I_LSSNOW, I_CVRAIN, I_CVSNOW, &
                              N_HYDRO, ISCCP_TAU_BNDS,&
                              RTTOV_MAX_CHANNELS, MISR_N_CTH,  &
                              MISR_CTH_BNDS
use MOD_LMD_IPSL_STATS, only: define_srbval
use radar_simulator_types, only: radar_simulator_types_init
use MOD_COSP_Modis_Simulator, only: COSP_MODIS, FREE_COSP_MODIS,  &
                                    CONSTRUCT_COSP_MODIS
use mod_modis_sim,      only:      numTauHistogramBins,   &
                                   numPressureHistogramBins, &
                                   tauHistogramBoundaries, &
                                   nominalTauHistogramBoundaries, &
                                   nominalTauHistogramCenters, &
                                   nominalPressureHistogramBoundaries
                              
IMPLICIT NONE

!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: cosp_driver.F90,v 1.1.2.1.4.1.4.1.2.1.2.1.2.1.2.2.8.2.2.1.6.1 2011/12/12 19:30:45 Peter.Phillipps Exp $'
character(len=128)  :: tagname =  '$Name:  $'
 


  ! Local variables
  character(len=64)  :: cosp_input_nl='cosp_input_nl.txt'
  character(len=64)  :: cosp_output_nl='cosp_output_nl.txt'
  character(len=512) :: finput ! Input file name
  character(len=512) :: cmor_nl
  character(len=8)  :: wmode ! Writing mode 'replace' or 'append'
  integer :: overlap   !  overlap type: 1=max, 2=rand, 3=max/rand
  integer :: isccp_topheight,isccp_topheight_direction
  integer :: Ncolumns ! Number of subcolumns in SCOPS
! integer :: Npoints  ! Number of gridpoints
  integer :: Nlevels  ! Number of levels
  integer :: Nlr      ! Number of levels in statistical outputs
  integer :: Npoints_it   ! Max number of gridpoints to be processed in one iteration
  integer,parameter :: ntsteps=5 
  type(cosp_config) :: cfg   ! Configuration options
  integer :: t0,t1,count_rate,count_max
! integer :: Nlon,Nlat,geomode
  integer ::           geomode
  real :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw
  integer,dimension(RTTOV_MAX_CHANNELS) :: Channels
  real,dimension(RTTOV_MAX_CHANNELS) :: Surfem
  integer :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay
  integer :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type
  integer :: platform,satellite,Instrument,Nchannels
  logical :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff
  logical :: use_input_file = .true.
  logical :: produce_cmor_output_fields = .true.
  logical :: output_p_and_z_by_index = .false.
  logical :: generate_orbital_output = .false.
  character (len = 128) :: orbital_filename =  '  '
  integer, dimension(6) :: sat_begin_time = (/0,0,0,0,0,0/)
  integer :: sat_period     = 0  ! [seconds]
  integer :: num_sat_periods = 0
  integer :: max_sdgs_per_sat_period = 3500
  real    :: emsfc_lw_nml=0.94
  logical :: use_rh_wrt_liq = .true.
  namelist/COSP_INPUT/cmor_nl,overlap,isccp_topheight, &
                      isccp_topheight_direction, &
              use_vgrid,nlr,csat_vgrid,  &
              npoints_it,finput, &
              radar_freq,surface_radar,use_mie_tables, &
              use_input_file, produce_cmor_output_fields, &
              output_p_and_z_by_index, &
              generate_orbital_output, orbital_filename, &
              sat_begin_time, sat_period, num_sat_periods, &
              max_sdgs_per_sat_period, &
              emsfc_lw_nml, use_rh_wrt_liq, &
              use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,  &
              Naero,Nprmts_max_aero,lidar_ice_type, &
              use_precipitation_fluxes,use_reff, &
              platform,satellite,Instrument,Nchannels, &
              Channels,Surfem,ZenAng,co2,ch4,n2o,co
  double precision :: time(ntsteps)=(/1.D0,2.D0,3.D0,4.D0,5.D0/)

  !---------------- End of declaration of variables --------------


public cosp_driver, cosp_driver_init, cosp_driver_end

character(len=16) :: mod_name = 'cosp'

integer, dimension(14)  :: cosp_axes

integer :: id_lat, id_lon, id_p, id_ph, id_z, id_zh, id_T, id_sh, &
           id_u_wind, id_v_wind, id_mr_ozone, &
           id_tot_h2o, &
           id_rh, id_tca, id_cca, id_lsliq, id_lsice, id_ccliq, &
           id_ccice, id_fl_lsrain, id_fl_lssnow, id_fl_lsgrpl, &
           id_fl_ccrain, id_fl_ccsnow, &
           id_reff_lsclliq, id_reff_lsclice, &
           id_reff_lsprliq, id_reff_lsprice, &
           id_reff_ccclliq, id_reff_ccclice, &
           id_reff_ccprliq, id_reff_ccprice, &
           id_reff_lsclliq_cmip, id_reff_ccclliq_cmip, &
           id_lsca_cmip, id_cca_cmip, &
           id_dtau_s, id_dtau_c, id_dem_s, id_dem_c, id_skt, id_land, &
           id_sfcht, id_sunlit
integer :: id_cltcalipso_sat, id_cllcalipso_sat, id_clmcalipso_sat,  &
           id_clhcalipso_sat
integer :: id_cltcalipso, id_cllcalipso, id_clmcalipso, id_clhcalipso, &
           id_cltlidarradar, id_tclisccp, id_ctpisccp, id_tauisccp, &
           id_tbisccp, id_tbclrisccp, &
           id_betamol532, &
           id_albisccp, id_clcalipso, id_clcalipso2, &
           id_clcalipso_sat, id_clcalipso2_sat, &
           id_clcalipso_mdl, id_clcalipso2_mdl, &
           id_boxtauisccp, id_boxptopisccp, id_parasolrefl, &
           id_parasolrefl_sat, &
           id_sampling_sat, id_location_sat, id_lat_sat, id_lon_sat
integer :: id_tclmodis, id_lclmodis, id_iclmodis, id_ttaumodis, &
           id_ltaumodis, id_itaumodis, id_tlogtaumodis, &
           id_llogtaumodis, id_ilogtaumodis, id_lremodis, &
           id_badlremodis, id_badiremodis, &
           id_locldmodis, id_mdcldmodis, id_hicldmodis, &
           id_iremodis, id_ctpmodis, id_lwpmodis, id_iwpmodis
integer, allocatable, dimension(:) :: id_dbze94, id_cloudsatcfad, &
                                      id_cloudsatcfad_sat, &
                                      id_atb532, id_calipsosrcfad, &
                                      id_calipsosrcfad_sat, &
                                      id_cloud_type, id_boxtauisccp_n, &
                                      id_boxptopisccp_n, &
                                      id_taumodis_n, id_ptopmodis_n, &
                                      id_badsizemodis_n, &
                                      id_sizemodis_n, id_phasemodis_n
integer, allocatable, dimension(:) :: id_cloudsatcfad_mdl, &
                                      id_calipsosrcfad_mdl
integer , dimension(7)   :: id_clisccp
integer , dimension(7,7) :: id_clisccp_n
integer , dimension(MISR_N_CTH)   :: id_misr    
integer , dimension(7,MISR_N_CTH) :: id_misr_n
integer , dimension(numTauHistogramBins, numPressureHistogramBins) ::  &
                                                         id_tauctpmodis_n
integer , dimension(numPressureHistogramBins) :: id_tauctpmodis

real  :: missing_value = -1.0E30
real  :: missing_value2 = -.000999
real  :: time_bnds(2,ntsteps)

real, dimension(:,:,:), allocatable        :: location   
logical, dimension(:,:,:), allocatable     :: lflag_array
logical, dimension(:,:,:,:), allocatable   :: lflag_array_temp, &
                                              lflag_array_parasol
real, dimension(:,:,:), allocatable        :: flag_array
type(time_type), dimension(:), allocatable :: Time_start, Time_end
integer   :: imax, jmax
integer   :: nsat_time_prev

include 'netcdf.inc'

contains

!######################################################################

subroutine cosp_driver_init (lonb, latb, Time_diag, axes,kd_in, ncol_in)

   real, dimension(:,:), intent(in) :: lonb, latb
   type(time_type), intent(in) :: Time_diag
   integer, dimension(4), intent(in) :: axes
   integer,               intent(in) :: kd_in, ncol_in

   integer :: io, unit, ierr, logunit

#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=cosp_input, iostat=io)
    ierr = check_nml_error(io,"cosp_input")
#else
!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
    if ( file_exist('input.nml')) then
       unit =  open_namelist_file ()
      ierr=1; do while (ierr /= 0)
      read  (unit, nml=cosp_input, iostat=io, end=10)
      ierr = check_nml_error(io,'cosp_input')
      enddo
10      call close_file (unit)
    endif
#endif
        
!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
    call write_version_number (version, tagname)
    logunit = stdlog()
    if (mpp_pe() == mpp_root_pe() )    &
                        write (logunit, nml=cosp_input)

    nlevels = kd_in
    ncolumns = ncol_in 
    imax = size(lonb,1)- 1
    jmax = size(lonb,2)- 1

    if (generate_orbital_output) then
      if (sat_begin_time(1) == 0 .or. sat_begin_time(2) == 0 .or. &
          sat_begin_time(3) ==0) then
        call error_mesg ('cosp_driver_init', &
           'requesting orbital output but not supplying &
                                               &valid start time', FATAL)
      endif
      if (sat_period == 0) then
        call error_mesg ('cosp_driver_init', &
           'satellite sampling period [seconds] must be non-zero', FATAL)
      endif
      if (num_sat_periods == 0) then
        call error_mesg ('cosp_driver_init', &
         'must define number of satellite periods to be processed', FATAL)
      endif
      if (trim(orbital_filename) == '') then
        call error_mesg ('cosp_driver_init', &
              'filename for orbital specification not provided', FATAL)
      endif
    endif
       
    call read_cosp_output_nl(cosp_output_nl,cfg)

    call diag_field_init (Time_diag, axes)

!---------------------------------------------------------------------
!   COSP takes a single, spacially independent value for surface
!   emissivity. it may be supplied via namelist.
!---------------------------------------------------------------------
    emsfc_lw = emsfc_lw_nml
 
!--------------------------------------------------------------------
!   variable geomode indicates that the grid (i,j) => (lon,lat)
!--------------------------------------------------------------------
    geomode = 2
 
    call radar_simulator_types_init

    if (generate_orbital_output) then
      allocate (location    (imax,jmax, 1:num_sat_periods))
      allocate (lflag_array (imax,jmax, 0:num_sat_periods))
      allocate (lflag_array_temp (imax,jmax, nlr, 0:num_sat_periods))
      allocate (lflag_array_parasol   &
                            (imax,jmax, PARASOL_NREFL, 0:num_sat_periods))
      allocate (flag_array(imax,jmax,12))
      allocate (Time_start(num_sat_periods))
      allocate (Time_end  (num_sat_periods))
      call read_cloudsat_orbit
      nsat_time_prev = 1
    endif

end subroutine cosp_driver_init



!#####################################################################

  subroutine diag_field_init (Time, axes)

   type(time_type), intent(in) :: Time
   integer, dimension(4), intent(in) :: axes

   real :: column_ax(Ncolumns)
   real :: level_ax(Nlevels )
   real :: isccp_ax(7)           
   real :: modis_ax(numTauHistogramBins)
   real :: dbze_ax(DBZE_BINS)
   real :: lidar_ax(SR_BINS)
   real :: sratio_bounds(2, SR_BINS)
   real :: srbval(SR_BINS)
   real :: csat_ax(NLR)
   real :: month_ax(12)
   real :: hr_ax(num_sat_periods)
   integer :: parasol_ax(PARASOL_NREFL)
   integer, dimension(3) :: halfindx = (/1,2,4/)
   integer, dimension(3) :: columnindx = (/1,2,5/)
   integer, dimension(3) :: levelindx = (/1,2,11/)
   integer, dimension(3) :: parasolindx = (/1,2,6/)
   integer, dimension(3) :: dbzeindx = (/1,2,7/)
   integer, dimension(3) :: lidarindx = (/1,2,8/)
   integer, dimension(3) :: tauindx = (/1,2,9/)
   integer, dimension(3) :: modistauindx = (/1,2,12/)
   integer, dimension(3) :: csatindx = (/1,2,10/)
   integer, dimension(3) :: samplingindx = (/1,2,13/)
   integer, dimension(3) :: samplingindx2 = (/1,2,14/)
   integer :: i, n, m
   integer :: id_columnindx, id_parasolindx, id_dbzeindx, id_lidarindx
   integer :: id_levelindx
   integer :: id_tauindx
   integer :: id_modistauindx
   integer :: id_csatindx
   integer :: id_monindx
   integer :: id_3hrindx
   character(len=2) :: chvers, chvers4
   character(len=8) :: chvers2, chvers3, chvers5, chvers6
   type(cosp_gridbox) :: gbx_t ! Gridbox information. Input for COSP
   type(cosp_vgrid)   :: vgrid_t   ! Information on vertical grid of stats


!--------------------------------------------------------------------
!    define the varisous axes needed for this data.
!--------------------------------------------------------------------
   cosp_axes(1:4) = axes(1:4)

!--------------------------------------------------------------------
! a level counter:
!--------------------------------------------------------------------
   do i=1,Nlevels 
     level_ax(i) = float(i)
   end do
   id_levelindx = diag_axis_init  ('levelindx', level_ax, &
          'levels', 'n', 'level number', & 
           set_name =  mod_name)
   cosp_axes(11) = id_levelindx

!--------------------------------------------------------------------
! a stochastic column counter:
!--------------------------------------------------------------------
   do i=1,Ncolumns
     column_ax(i) = float(i)
   end do
   id_columnindx = diag_axis_init  ('columnindx', column_ax, &
          'subcol', 'n', 'subcolumn number', & 
           set_name =  mod_name)
   cosp_axes(5) = id_columnindx

!--------------------------------------------------------------------
!  a PARASOL index counter:
!--------------------------------------------------------------------
   id_parasolindx = diag_axis_init  ('parasolindx', PARASOL_SZA, &
          'parasolindx', 'n', 'parasol reflectivity index', & 
           set_name =  mod_name)
   cosp_axes(6) = id_parasolindx

!--------------------------------------------------------------------
!  a radar bin counter:
!--------------------------------------------------------------------
   do i=1,DBZE_BINS
      dbze_ax(i) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(i-0.5)
   end do
   id_dbzeindx = diag_axis_init  ('dbzeindx', dbze_ax, &
          'dbzeindx', 'n', 'dbze', & 
           set_name =  mod_name)
   cosp_axes(7) = id_dbzeindx

!--------------------------------------------------------------------
!  a lidar bin counter:
!--------------------------------------------------------------------

   call define_srbval (srbval)

   sratio_bounds(1,:) = srbval(:)
   sratio_bounds(2,1:SR_BINS-1) = srbval(2:SR_BINS)
   sratio_bounds(2,SR_BINS) = srbval(SR_BINS) +10.0
   lidar_ax(1:SR_BINS) = (sratio_bounds(1,1:SR_BINS) + sratio_bounds(2,1:SR_BINS))/2.0
   id_lidarindx = diag_axis_init  ('lidarindx', lidar_ax, &
          'lidarindx', 'n', 'lidar scattering', & 
           set_name =  mod_name)
   cosp_axes(8) = id_lidarindx

!--------------------------------------------------------------------
!  an isccp tau bin counter:
!--------------------------------------------------------------------
   isccp_ax = isccp_tau
   id_tauindx = diag_axis_init  ('tauindx', isccp_ax, &
          'tauindx', 'n', 'isccp tau category', & 
           set_name =  mod_name)
   cosp_axes(9) = id_tauindx

!--------------------------------------------------------------------
!  a modis tau bin counter:
!--------------------------------------------------------------------
   modis_ax = nominalTauHistogramCenters
   id_modistauindx = diag_axis_init  ('modistauindx', modis_ax, &
          'modistauindx', 'n', 'modis tau category', &
           set_name =  mod_name)
   cosp_axes(12) = id_modistauindx

!--------------------------------------------------------------------
!  a specified vertical index needed when use_vgrid = .true. 
!--------------------------------------------------------------------
   gbx_t%Npoints = 256       
   gbx_t%Ncolumns = ncolumns    
   gbx_t%Nlevels = Nlevels
   allocate(gbx_t%zlev(256    , nlevels))
   allocate(gbx_t%zlev_half(256    , nlevels))
   gbx_t%zlev = 0.0
   gbx_t%zlev_half = 0.0
  call construct_cosp_vgrid(gbx_t,Nlr,use_vgrid,csat_vgrid,vgrid_t)
   csat_ax = vgrid_t%z
   id_csatindx = diag_axis_init  ('csatindx', csat_ax, &
          'csatindx', 'z', 'csat vert index', & 
           set_name =  mod_name)
   cosp_axes(10) = id_csatindx
   deallocate (gbx_t%zlev, gbx_t%zlev_half) 
   deallocate (vgrid_t%z,  vgrid_t%zl, vgrid_t%zu,  &
               vgrid_t%mz, vgrid_t%mzl, vgrid_t%mzu)
   do i=1,12
     month_ax(i) = i
   end do
   id_monindx = diag_axis_init  ('samplingindx', month_ax, &
          'samplingindx', 'n', 'month index', & 
           set_name =  mod_name)
   cosp_axes(13) = id_monindx
   
   do i=1,num_sat_periods
     hr_ax(i) = i
   end do
   id_3hrindx = diag_axis_init  ('samplingindx2', hr_ax, &
          'samplingindx2', 'n', '3hr index', & 
           set_name =  mod_name)
   cosp_axes(14) = id_3hrindx
   
!--------------------------------------------------------------------
!    register input fields with diag_manager.
!--------------------------------------------------------------------
   id_lat        = register_diag_field &
      (mod_name, 'lat', axes(1:2), Time, 'Latitude',  'degrees N')

   id_lon        = register_diag_field &
      (mod_name, 'lon', axes(1:2), Time, 'Longitude',  'degrees E')

   id_u_wind     = register_diag_field &
      (mod_name, 'u_wind', axes(1:2), Time, 'sfc u wind',  'm / s')

   id_v_wind     = register_diag_field &
      (mod_name, 'v_wind', axes(1:2), Time, 'sfc v wind',  'm / s')

   if (output_p_and_z_by_index) then
     id_p          = register_diag_field &
       (mod_name, 'p', cosp_axes(levelindx), Time,  &
                                        'P at full levels',  'Pa  ')
     id_ph         = register_diag_field &
       (mod_name, 'ph', cosp_axes(levelindx), Time, &
                                        'p at half levels',  'Pa')
     id_z        = register_diag_field &
       (mod_name, 'z', cosp_axes(levelindx), Time, 'height  ', 'meters')
     id_zh        = register_diag_field &
       (mod_name, 'zh', cosp_axes(levelindx), Time, &
                                      'height at half levs',  'meters')
   else
     id_p          = register_diag_field &
      (mod_name, 'p', axes(1:3), Time, 'P at full levels',  'Pa  ')
     id_ph         = register_diag_field &
      (mod_name, 'ph', axes(halfindx), Time, 'p at half levels',  'Pa')
     id_z        = register_diag_field &
      (mod_name, 'z', axes(1:3), Time,  'height  ',  'meters  ')
     id_zh        = register_diag_field &
      (mod_name, 'zh', axes(halfindx), Time, 'height at half levs', &
                                                              'meters')
   endif

   id_mr_ozone   = register_diag_field &
      (mod_name, 'ozone', axes(1:3), Time, 'Ozone mass mixing ratio', &
                                                   'kg (o3) / kg (air)')

   id_T          = register_diag_field &
      (mod_name, 'T', axes(1:3), Time, 'Temp at full levels',  'deg K ')

   id_sh         = register_diag_field &
      (mod_name, 'sh', axes(1:3), Time, &
        'vapor specific humidity at full levels',  'kg(h2o) / kg(air) ')

   id_rh         = register_diag_field &
      (mod_name, 'relhum', axes(1:3), Time, &
                      'relative humidity at full levels',  'fraction ')

   id_tot_h2o   = register_diag_field &
      (mod_name, 'tot_h2o', axes(1:3), Time, &
                                  'total water substance',  &
                            'kg(h2o) / kg(air) ' )

   id_lsca_cmip       = register_diag_field &
      (mod_name, 'lsca_cmip', axes(1:3), Time, &
                'ls liq cld fraction',  'fraction ', &
                mask_variant = .true., &
                   missing_value = missing_value)

   id_cca_cmip   = register_diag_field &
      (mod_name, 'cca_cmip', axes(1:3), Time, &
                 'convective liq cld fraction',  'fraction ', &
                mask_variant = .true., &
                   missing_value = missing_value)

   id_tca       = register_diag_field &
      (mod_name, 'tca', axes(1:3), Time, &
                                  'total cld fraction',  'fraction ')

   id_cca        = register_diag_field &
      (mod_name, 'cca', axes(1:3), Time, &
                           'convective cld fraction',  'fraction ')

   id_lsliq      = register_diag_field &
      (mod_name, 'lsliq', axes(1:3), Time, &
                                  'large scale cld liq',  'kg / kg  ')

   id_lsice      = register_diag_field &
      (mod_name, 'lsice', axes(1:3), Time, &
                                   'large scale cld ice',  'kg / kg  ')

   id_ccliq      = register_diag_field &
      (mod_name, 'ccliq', axes(1:3), Time, &
                                   'convective  cld liq',  'kg / kg  ')

   id_ccice      = register_diag_field &
      (mod_name, 'ccice', axes(1:3), Time, &
                                   'convective  cld ice',  'kg / kg  ')

   id_fl_lsrain  = register_diag_field &
      (mod_name, 'fl_lsrain', axes(1:3), Time, &
                             'large scale rain flx',  'kg / (m**2 s)')

   id_fl_lssnow  = register_diag_field &
      (mod_name, 'fl_lssnow', axes(1:3), Time, &
                             'large scale snow flx',  'kg / (m**2 s)')

   id_fl_lsgrpl  = register_diag_field &
      (mod_name, 'fl_lsgrpl', axes(1:3), Time, &
                           'large scale graupel flx',  'kg / (m**2 s)')

   id_fl_ccrain  = register_diag_field &
      (mod_name, 'fl_ccrain', axes(1:3), Time, &
                            'cnvctv scale rain flx',  'kg / (m**2 s)')

   id_fl_ccsnow  = register_diag_field &
      (mod_name, 'fl_ccsnow', axes(1:3), Time, &
                            'cnvctv scale snow flx',  'kg / (m**2 s)')

   id_reff_lsclliq_cmip  = register_diag_field &
      (mod_name, 'reff_lsclliq_cmip', axes(1:3), Time, &
           'ls liq cld drop size*cfrac ',  'm', mask_variant = .true., &
                   missing_value = missing_value)

   id_reff_ccclliq_cmip  = register_diag_field &
      (mod_name, 'reff_ccclliq_cmip', axes(1:3), Time, &
         'cv liq cld drop size*cfrac ',  'm', mask_variant = .true., &
                   missing_value = missing_value)

   id_reff_lsclliq  = register_diag_field &
      (mod_name, 'reff_lsclliq', axes(1:3), Time, &
               'ls liq cld drop size ',  'm', mask_variant = .true., &
                   missing_value = missing_value)

   id_reff_lsclice  = register_diag_field &
      (mod_name, 'reff_lsclice', axes(1:3), Time, &
                'ls ice cld drop size ',  'm', mask_variant = .true., &
                   missing_value = missing_value)

   id_reff_lsprliq  = register_diag_field &
      (mod_name, 'reff_lsprliq', axes(1:3), Time, &
                                       'ls liq prcp drop size ',  'm')

   id_reff_lsprice  = register_diag_field &
      (mod_name, 'reff_lsprice', axes(1:3), Time, &
                                        'ls ice prcp drop size ',  'm')

   id_reff_ccclliq  = register_diag_field &
      (mod_name, 'reff_ccclliq', axes(1:3), Time, &
             'cv liq cld drop size ',  'm', mask_variant = .true., &
                   missing_value = missing_value)

   id_reff_ccclice  = register_diag_field &
      (mod_name, 'reff_ccclice', axes(1:3), Time, &
          'cv ice cld drop size ',  'm', mask_variant = .true., &
                   missing_value = missing_value)

   id_reff_ccprliq  = register_diag_field &
      (mod_name, 'reff_ccprliq', axes(1:3), Time, &
                                        'cv liq prcp drop size ',  'm')

   id_reff_ccprice  = register_diag_field &
      (mod_name, 'reff_ccprice', axes(1:3), Time, &
                                        'cv ice prcp drop size ',  'm')

   id_dtau_s  = register_diag_field &
      (mod_name, 'dtau_s', axes(1:3), Time, &
                   'ls cloud optical depth ',  'dimensionless')

   id_dtau_c  = register_diag_field &
      (mod_name, 'dtau_c', axes(1:3), Time, &
                    'cv cloud optical depth ',  'dimensionless')

   id_dem_s  = register_diag_field &
      (mod_name, 'dem_s', axes(1:3), Time, &
                             'ls cloud emissivity ',  'dimensionless')

   id_dem_c  = register_diag_field &
      (mod_name, 'dem_c', axes(1:3), Time, &
                             'cv cloud emissivity  ',  'dimensionless')

   id_skt        = register_diag_field &
      (mod_name, 'skt', axes(1:2), Time, 'skin temp',  'deg K')

   id_sunlit     = register_diag_field &
      (mod_name, 'sunlit', axes(1:2), Time, 'sun is shining?',  'none')

   id_land       = register_diag_field &
      (mod_name, 'land', axes(1:2), Time, 'land frac',  'fraction')

   id_sfcht      = register_diag_field &
      (mod_name, 'sfc_ht', axes(1:2), Time, 'height of surface',   &
                                                             'meters')

!---------------------------------------------------------------------
!    COSP output fields:
!---------------------------------------------------------------------
   allocate (id_dbze94(Ncolumns))
   if (use_vgrid) then
     allocate (id_cloudsatcfad(DBZE_BINS))
     allocate (id_calipsosrcfad(SR_BINS ))
     allocate (id_cloudsatcfad_sat(DBZE_BINS))
     allocate (id_calipsosrcfad_sat(SR_BINS ))
   else
     allocate (id_cloudsatcfad_mdl(DBZE_BINS))
     allocate (id_calipsosrcfad_mdl(SR_BINS ))
   endif
   allocate (id_cloud_type     (Ncolumns ))
   do n=1, size(id_cloud_type,1)
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
        'can not process over 99 levels', FATAL)
     endif
     id_cloud_type(n) = register_diag_field &
         (mod_name, 'cloud_type_' // trim(chvers), axes(1:3), Time, &
           'Cloud type present in column ' // trim(chvers), 'none')
   end do

 if (cfg%Llidar_sim) then
   id_cltcalipso = register_diag_field &
      (mod_name, 'cltcalipso', axes(1:2), Time, &
          'Lidar Total Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_cllcalipso = register_diag_field &
      (mod_name, 'cllcalipso', axes(1:2), Time, &
          'Lidar Low-level Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_clmcalipso = register_diag_field &
      (mod_name, 'clmcalipso', axes(1:2), Time, &
          'Lidar Mid-level Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_clhcalipso = register_diag_field &
      (mod_name, 'clhcalipso', axes(1:2), Time, &
          'Lidar High-level Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

if (generate_orbital_output) then

   id_cltcalipso_sat = register_diag_field &
      (mod_name, 'cltcalipso_sat', axes(1:2), Time, &
          'Lidar Total Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_cllcalipso_sat = register_diag_field &
      (mod_name, 'cllcalipso_sat', axes(1:2), Time, &
          'Lidar Low-level Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_clmcalipso_sat = register_diag_field &
      (mod_name, 'clmcalipso_sat', axes(1:2), Time, &
          'Lidar Mid-level Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_clhcalipso_sat = register_diag_field &
      (mod_name, 'clhcalipso_sat', axes(1:2), Time, &
          'Lidar High-level Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_clcalipso_sat = register_diag_field &
      (mod_name, 'clcalipso_sat', cosp_axes(csatindx), Time, &
       'Lidar Cloud Fraction (532 nm)', 'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_sampling_sat = register_static_field &
      (mod_name, 'sampling_sat', cosp_axes(samplingindx),       &
       'Times sampled by Cloudsat', 'number', &
           missing_value=missing_value)

   id_location_sat = register_static_field &
      (mod_name, 'location_sat', cosp_axes(samplingindx2),       &
       'Satellite location index', 'counter', &
           missing_value=missing_value)

   id_lon_sat = register_diag_field &
      (mod_name, 'lon_sat', axes(1:2),  Time,      &
       'Satellite longitude', 'degrees E', &
          mask_variant = .true.,  missing_value=missing_value)

   id_lat_sat = register_diag_field &
      (mod_name, 'lat_sat', axes(1:2), Time,      &
       'Satellite latitude', 'degrees N', &
      mask_variant = .true.,     missing_value=missing_value)

   id_parasolrefl_sat = register_diag_field &
      (mod_name, 'parasol_refl_sat', cosp_axes(parasolindx), Time, &
      'PARASOL-like mono-directional reflectance', 'fraction', &
          mask_variant = .true., missing_value=missing_value)

endif

   id_clcalipso = register_diag_field &
      (mod_name, 'clcalipso', cosp_axes(csatindx), Time, &
       'Lidar Cloud Fraction (532 nm)', 'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_clcalipso_mdl = register_diag_field &
      (mod_name, 'clcalipso_mdl', axes(1:3), Time, &
       'Lidar Cloud Fraction (532 nm)', 'percent', &
          mask_variant = .true., missing_value=missing_value)
   id_parasolrefl = register_diag_field &
      (mod_name, 'parasol_refl', cosp_axes(parasolindx), Time, &
      'PARASOL-like mono-directional reflectance', 'fraction', &
          mask_variant = .true., missing_value=missing_value)
   id_betamol532 = register_diag_field &
        (mod_name, 'betamol532', axes(1:3       ), Time, &
           'Lidar Molecular Backscatter (532 nm)', &
           '(m sr)**(-1)', &
          mask_variant = .true., missing_value=missing_value)
   allocate (id_atb532(Ncolumns))
   do n=1, size(id_atb532,1)
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
        'can not process over 99 columns', FATAL)
     endif
     id_atb532(n) = register_diag_field &
        (mod_name, 'atb532_' // trim(chvers), axes(1:3       ), Time, &
           'Lidar Attenuated Total Backscatter (532 nm) column# ' // &
          & trim(chvers), '(m sr)**(-1)', &
          mask_variant = .true., missing_value=missing_value)
   end do

   do n=1, SR_BINS                       
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
        'can not process over 99 levels', FATAL)
     endif
     if (n == 1) then
       write (chvers2, '(f8.2)') -100.0            
     else
       write (chvers2, '(f8.2)') srbval(n-1)
     endif
     write (chvers3, '(f8.2)') srbval(n)
     if (use_vgrid) then
       id_calipsosrcfad(n) = register_diag_field &
          (mod_name, 'calipsosrcfad_' // trim(chvers),  &
            cosp_axes(csatindx ), Time, &
              'Fractional area with Lidar 532 nm Scattering Ratio  &
              &between' // trim(chvers2) // ' and' // trim(chvers3) // &
                    ' -- bin' // trim(chvers),  'fraction', &
                    mask_variant = .true., missing_value=missing_value)
       if (generate_orbital_output) then
         id_calipsosrcfad_sat(n) = register_diag_field &
          (mod_name, 'calipsosrcfad_sat_' // trim(chvers),  &
            cosp_axes(csatindx ), Time, &
              'Fractional area with Lidar 532 nm Scattering Ratio  &
              &between' // trim(chvers2) // ' and' // trim(chvers3) // &
                    ' -- bin' // trim(chvers),  'fraction', &
                    mask_variant = .true., missing_value=missing_value)
       endif
     else
       id_calipsosrcfad_mdl(n) = register_diag_field &
         (mod_name, 'calipsosrcfad_mdl_' // trim(chvers), axes(1:3), &
          Time, 'Fractional area with Lidar 532 nm Scattering Ratio  &
           &between' // trim(chvers2) // ' and' // trim(chvers3) // &
                ' -- bin' // trim(chvers), 'fraction', &
                mask_variant = .true., missing_value=missing_value)
     endif
   end do
 endif  !(Llidar_sim)

 if (cfg%Lradar_sim) then
   do n=1, size(id_dbze94,1)
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
        'can not process over 99 levels', FATAL)
     endif
     id_dbze94(n) = register_diag_field &
       (mod_name, 'dbze94_' // trim(chvers), axes(1:3), Time, &
      'Radar Effective Reflectivity Factor in dBZe (94 GHz) column# ' &
            // trim(chvers), 'dBZe')
   end do

   do n=1, DBZE_BINS              
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
        'can not process over 99 levels', FATAL)
     endif
     write (chvers2, '(i6)') INT(cfad_ze_min + float(n-1)*cfad_ze_width)
     write (chvers3, '(i6)') INT(cfad_ze_min + float(n)*cfad_ze_width)
     if (use_vgrid) then
       id_cloudsatcfad(n) = register_diag_field &
          (mod_name, 'cloudsatcfad_' // trim(chvers),   &
           cosp_axes(csatindx), Time, &
           'Fractional area with radar reflectivity (94 GHz) between ' &
              // trim(chvers2) //  ' and' // trim(chvers3) //  &
               ' dbZe -- bin # '  //  trim(chvers),   'fraction', &
                mask_variant = .true., missing_value=missing_value)
       if (generate_orbital_output) then
         id_cloudsatcfad_sat(n) = register_diag_field &
          (mod_name, 'cloudsatcfad_sat_' // trim(chvers),   &
           cosp_axes(csatindx), Time, &
           'Fractional area with radar reflectivity (94 GHz) between ' &
              // trim(chvers2) //  ' and' // trim(chvers3) //  &
               ' dbZe -- bin # '  //  trim(chvers),   'fraction', &
                mask_variant = .true., missing_value=missing_value)
       endif
     else
       id_cloudsatcfad_mdl(n) = register_diag_field &
           (mod_name, 'cloudsatcfad_mdl_' // trim(chvers), axes(1:3), &
              Time, 'Fractional area with radar reflectivity &
             &(94 GHz) between ' // trim(chvers2) //  ' and' // &
             & trim(chvers3) //  ' dbZe -- bin # '  //  trim(chvers),  &
             'fraction', &
             mask_variant = .true., missing_value=missing_value)
     endif
   end do
 endif ! (Lradar_sim)


 if (cfg%Lradar_sim .and. cfg%Llidar_sim) then
   id_cltlidarradar = register_diag_field &
      (mod_name, 'cltlidarradar', axes(1:2), Time, &
          'Lidar and Radar Total Cloud Fraction',  'percent', &
          mask_variant = .true., missing_value=missing_value)
   id_clcalipso2 = register_diag_field &
      (mod_name, 'clcalipso2', cosp_axes(csatindx), Time, &
'Cloud frequency of occurrence as seen by CALIPSO but not CloudSat', &
         'percent', &
          mask_variant = .true., missing_value=missing_value)

   if (generate_orbital_output) then
     id_clcalipso2_sat = register_diag_field &
      (mod_name, 'clcalipso2_sat', cosp_axes(csatindx), Time, &
'Cloud frequency of occurrence as seen by CALIPSO but not CloudSat', &
         'percent', &
          mask_variant = .true., missing_value=missing_value)
   endif

   id_clcalipso2_mdl = register_diag_field &
      (mod_name, 'clcalipso2_mdl', axes(1:3), Time, &
'Cloud frequency of occurrence as seen by CALIPSO but not CloudSat', &
         'percent', &
          mask_variant = .true., missing_value=missing_value)
 endif !(cfg%Lradar_sim .and. cfg%Llidar_sim) 

 if (cfg%Lisccp_sim) then
   id_tclisccp = register_diag_field &
      (mod_name, 'tclisccp', axes(1:2), Time, &
          'Total Cloud Fraction as Calculated by the ISCCP Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_ctpisccp = register_diag_field &
      (mod_name, 'ctpisccp', axes(1:2), Time, &
       'Mean Cloud Top Pressure *CPCT as Calculated by the ISCCP Simulator', &
         'Pa', mask_variant = .true., missing_value=missing_value)

   id_tbisccp = register_diag_field &
      (mod_name, 'tbisccp', axes(1:2), Time, &
       'Mean All-sky 10.5 micron brightness temp -- ISCCP Simulator', &
         'deg K', mask_variant = .true., missing_value=missing_value)

   id_tbclrisccp = register_diag_field &
      (mod_name, 'tbclrisccp', axes(1:2), Time, &
       'Mean Clr-sky 10.5 micron brightness temp -- ISCCP Simulator', &
         'deg K', mask_variant = .true., missing_value=missing_value)

   id_tauisccp = register_diag_field &
      (mod_name, 'tauisccp', axes(1:2), Time, &
       'Mean Optical Depth *CPCT as Calculated by the ISCCP Simulator', &
         'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_albisccp = register_diag_field &
      (mod_name, 'albisccp', axes(1:2), Time, &
       'Mean Cloud Albedo *CPCT as Calculated by the ISCCP Simulator', &
         'fraction', &
          mask_variant = .true., missing_value=missing_value)
   id_boxtauisccp = register_diag_field &
      (mod_name, 'boxtauisccp', cosp_axes(columnindx), Time, &
         'Optical Depth  from the ISCCP Simulator', 'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_boxptopisccp = register_diag_field &
      (mod_name, 'boxptopisccp', cosp_axes(columnindx), Time, &
          'Cloud Top Pressure from the ISCCP Simulator', 'Pa')

   allocate (id_boxtauisccp_n(Ncolumns))
   allocate (id_boxptopisccp_n(Ncolumns))
   do n=1,Ncolumns
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
                   'can not process over 99 levels', FATAL)
     endif

     id_boxtauisccp_n(n) = register_diag_field &
        (mod_name, 'boxtauisccp_' // trim(chvers), axes(1:2), Time, &
          'Optical Depth in stochastic Column' // trim(chvers) //  &
            ' from the ISCCP Simulator', 'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

     id_boxptopisccp_n(n) = register_diag_field &
       (mod_name, 'boxptopisccp_' // trim(chvers), axes(1:2), Time, &
          'Cloud Top Pressure in stochastic column' // trim(chvers)  &
             //' from the ISCCP Simulator', 'Pa', &
          mask_variant = .true., missing_value=missing_value)
   end do
   do n=1,7
     write (chvers, '(i1)') n
     write (chvers2, '(i6)') INT(isccp_pc_bnds(1,n)*1.0e-02)
     write (chvers3, '(i6)') INT(isccp_pc_bnds(2,n)*1.0e-02)
     id_clisccp(n) = register_diag_field &
       (mod_name, 'clisccp_'// trim(chvers), cosp_axes(tauindx), &
          Time, 'ISCP Cld Frac for clouds between ' // trim(chvers2) &
             // ' and' // trim(chvers3) // ' hPa', 'percent', &
                  mask_variant = .true., missing_value=missing_value)
   end do

   do m=1,7
     write (chvers4, '(i1)') m
     write (chvers5, '(f4.1)') isccp_tau_bnds(1,m)
     write (chvers6, '(f8.1)') isccp_tau_bnds(2,m)
     do n=1,7
       write (chvers, '(i1)') n
       write (chvers2, '(i5)') INT(isccp_pc_bnds(1,n)*1.0e-02)
       write (chvers3, '(i5)') INT(isccp_pc_bnds(2,n)*1.0e-02)
       id_clisccp_n(m,n) = register_diag_field &
         (mod_name, 'clisccp_'// trim(chvers4)//'_' // trim(chvers), &
          axes(1:2), Time, 'ISCCP CldFrac - tau between ' // &
           trim(chvers5) // ' and ' // trim(chvers6) //  &
           ' , pr between ' // trim(chvers2) // ' and' // &
             trim(chvers3) // ' hPa',  'percent', &
                mask_variant = .true., missing_value=missing_value)
     end do
   end do
 endif !(Lisccp_sim)

  if (cfg%Lmisr_sim) then
   do n=1,MISR_N_CTH
       if (n <=9) then
       write (chvers, '(i1)') n
       else
       write (chvers, '(i2)') n
       endif
     write (chvers2, '(f6.1)') 1.0e-03*MISR_CTH_BNDS(1,n)
     write (chvers3, '(f6.1)') 1.0E-03*MISR_CTH_BNDS(2,n)
     id_misr(n) = register_diag_field &
       (mod_name, 'misr_'// trim(chvers), cosp_axes(tauindx), &
          Time, 'MISR Cld Frac for clouds with top between ' // trim(chvers2) &
             // ' and' // trim(chvers3) // ' km', 'percent', &
                  mask_variant = .true., missing_value=missing_value)
   end do

   do m=1,7
     write (chvers4, '(i1)') m
     write (chvers5, '(f4.1)') isccp_tau_bnds(1,m)
     write (chvers6, '(f8.1)') isccp_tau_bnds(2,m)
     do n=1,MISR_N_CTH
       if (n <=9) then
       write (chvers, '(i1)') n
       else
       write (chvers, '(i2)') n
       endif
       write (chvers2, '(f6.1)') 1.0e-03*MISR_CTH_BNDS(1,n)
       write (chvers3, '(f6.1)') 1.0e-03*MISR_CTH_BNDS(2,n)
       id_misr_n(m,n) = register_diag_field &
         (mod_name, 'misr_'// trim(chvers4)//'_' // trim(chvers), &
          axes(1:2), Time, 'MISR CldFrac - tau between ' // &
           trim(chvers5) // ' and ' // trim(chvers6) //  &
           ' , top between ' // trim(chvers2) // ' and' // &
             trim(chvers3) // ' km', 'percent', &
                mask_variant = .true., missing_value=missing_value)
     end do
   end do
 endif !(Lmisr_sim)

  if (cfg%Lmodis_sim) then

   id_tclmodis = register_diag_field &
      (mod_name, 'tclmodis', axes(1:2), Time, &
          'Total Cloud Fraction as Calculated by the MODIS Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_locldmodis = register_diag_field &
      (mod_name, 'locldmodis', axes(1:2), Time, &
          'Low Cloud Fraction as Calculated by the MODIS Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_mdcldmodis = register_diag_field &
      (mod_name, 'mdcldmodis', axes(1:2), Time, &
          'Middle Cloud Fraction as Calculated by the MODIS Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_hicldmodis = register_diag_field &
      (mod_name, 'hicldmodis', axes(1:2), Time, &
          'High Cloud Fraction as Calculated by the MODIS Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_lclmodis = register_diag_field &
      (mod_name, 'lclmodis', axes(1:2), Time, &
          'Total Liquid Cloud Fraction as Calculated by the MODIS Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_iclmodis = register_diag_field &
      (mod_name, 'iclmodis', axes(1:2), Time, &
          'Total Ice Cloud Fraction as Calculated by the MODIS Simulator', &
          'percent', &
          mask_variant = .true., missing_value=missing_value)

   id_ttaumodis = register_diag_field &
      (mod_name, 'ttaumodis', axes(1:2), Time, &
          'Total Optical Thickness*CPCT as Calculated by the MODIS Simulator', &
          'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_ltaumodis = register_diag_field &
      (mod_name, 'ltaumodis', axes(1:2), Time, &
          'Total Liquid Optical Thickness*CPCT as Calculated by the MODIS Simulator', &
          'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_itaumodis = register_diag_field &
      (mod_name, 'itaumodis', axes(1:2), Time, &
          'Total Ice Optical Thickness*CPCT as Calculated by the MODIS Simulator', &
          'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_tlogtaumodis = register_diag_field &
      (mod_name, 'tlogtaumodis', axes(1:2), Time, &
          'Total Log Mean Optical Thickness*CPCT as Calculated by the MODIS Simulator', &
          'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_llogtaumodis = register_diag_field &
      (mod_name, 'llogtaumodis', axes(1:2), Time, &
          'Total Log Mean Liquid Optical Thickness*CPCT as Calculated by the MODIS Simulator', &
          'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_ilogtaumodis = register_diag_field &
      (mod_name, 'ilogtaumodis', axes(1:2), Time, &
          'Total Log Mean Ice Optical Thickness*CPCT as Calculated by the MODIS Simulator', &
          'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

   id_lremodis = register_diag_field &
      (mod_name, 'lremodis', axes(1:2), Time, &
          ' Liquid Water particle Size*CPCT as Calculated by the MODIS Simulator', &
          'm', &
          mask_variant = .true., missing_value=missing_value)

   id_badlremodis = register_diag_field &
      (mod_name, 'badlsizemodis', axes(1:2), Time, &
          ' Flag for liquid size retrieval failure in the MODIS Simulator', &
          '1', &
          mask_variant = .true., missing_value=missing_value)

   id_badiremodis = register_diag_field &
      (mod_name, 'badisizemodis', axes(1:2), Time, &
          ' Flag for ice size retrieval failure in the MODIS Simulator', &
          '1', &
          mask_variant = .true., missing_value=missing_value)

   id_iremodis = register_diag_field &
      (mod_name, 'iremodis', axes(1:2), Time, &
          ' Ice Water particle Size*CPCT as Calculated by the MODIS Simulator', &
          'm', &
          mask_variant = .true., missing_value=missing_value)

   id_ctpmodis = register_diag_field &
      (mod_name, 'ctpmodis', axes(1:2), Time, &
          ' Mean Cloud Top Pressure*CPCT as Calculated by the MODIS Simulator', &
          'Pa', &
          mask_variant = .true., missing_value=missing_value)

   id_lwpmodis = register_diag_field &
      (mod_name, 'lwpmodis', axes(1:2), Time, &
          ' Mean Liquid Water Path*CPCT as Calculated by the MODIS Simulator', &
          'kg / ( m**2)',   &
          mask_variant = .true., missing_value=missing_value)

   id_iwpmodis = register_diag_field &
      (mod_name, 'iwpmodis', axes(1:2), Time, &
          ' Mean Ice Water Path*CPCT as Calculated by the MODIS Simulator', &
          'kg / ( m**2)',  &
          mask_variant = .true., missing_value=missing_value)

   allocate (id_taumodis_n(Ncolumns))
   allocate (id_ptopmodis_n(Ncolumns))
   allocate (id_sizemodis_n(Ncolumns))
   allocate (id_badsizemodis_n(Ncolumns))
   allocate (id_phasemodis_n(Ncolumns))
   do n=1,Ncolumns
     if (n <= 9) then
       write (chvers, '(i1)') n
     else if (n <=99) then
       write (chvers, '(i2)') n
     else
       call error_mesg ('cosp_driver', &      
                   'can not process over 99 levels', FATAL)
     endif

     id_taumodis_n(n) = register_diag_field &
        (mod_name, 'taumodis_' // trim(chvers), axes(1:2), Time, &
          'Optical Depth in stochastic Column' // trim(chvers) //  &
            ' from the MODIS Simulator', 'dimensionless', &
          mask_variant = .true., missing_value=missing_value)

     id_ptopmodis_n(n) = register_diag_field &
       (mod_name, 'ptopmodis_' // trim(chvers), axes(1:2), Time, &
          'Cloud Top Pressure in stochastic column' // trim(chvers)  &
             //' from the MODIS Simulator', 'hPa', &
          mask_variant = .true., missing_value=missing_value)

     id_sizemodis_n(n) = register_diag_field &
        (mod_name, 'sizemodis_' // trim(chvers), axes(1:2), Time, &
          'Particle Size in stochastic Column' // trim(chvers) //  &
            ' from the MODIS Simulator', 'meters', &
          mask_variant = .true., missing_value=missing_value)

     id_badsizemodis_n(n) = register_diag_field &
        (mod_name, 'badsizemodis_' // trim(chvers), axes(1:2), Time, &
          'Particle Size failures in stochastic Column' // trim(chvers) //  &
            ' from the MODIS Simulator', 'meters', &
          mask_variant = .true., missing_value=missing_value)

     id_phasemodis_n(n) = register_diag_field &
        (mod_name, 'phasemodis_' // trim(chvers), axes(1:2), Time, &
          'Phase in stochastic Column' // trim(chvers) //  &
            ' from the MODIS Simulator', 'unitless', &
          mask_variant = .true., missing_value=missing_value)

   end do
   do n=numPressureHistogramBins,1,-1
       if (n <=9) then
       write (chvers, '(i1)') n
       else
       write (chvers, '(i2)') n
       endif
     write (chvers2, '(f8.1)') nominalPressureHistogramBoundaries(1,n)
     write (chvers3, '(f8.1)') nominalPressureHistogramBoundaries(2,n)
     id_tauctpmodis(n) = register_diag_field &
       (mod_name, 'tauctpmodis_'// trim(chvers), cosp_axes(modistauindx), &
          Time, 'MODIS Cld Frac for clouds with top between ' // trim(chvers2) &
             // ' and' // trim(chvers3) // ' Pa', 'percent', &
                  mask_variant = .true., missing_value=missing_value)
   end do

   do m=1,numTauHistogramBins
     write (chvers4, '(i1)') m + 1
     write (chvers5, '(f6.1)') nominalTauHistogramBoundaries(1,m)
     write (chvers6, '(f6.1)') nominalTauHistogramBoundaries(2,m)
     do n=numPressureHistogramBins,1,-1
       if (n <=9) then
       write (chvers, '(i1)') n
       else
       write (chvers, '(i2)') n
       endif
       write (chvers2, '(f8.1)') nominalPressureHistogramBoundaries(1,n)
       write (chvers3, '(f8.1)') nominalPressureHistogramBoundaries(2,n)
       id_tauctpmodis_n(m,n) = register_diag_field &
         (mod_name, 'tauctpmodis_'// trim(chvers4)//'_' // trim(chvers), &
          axes(1:2), Time, 'MODIS CldFrac - tau between ' // &
           trim(chvers5) // ' and ' // trim(chvers6) //  &
           ' , top between ' // trim(chvers2) // ' and' // &
             trim(chvers3) // ' Pa', 'percent', &
                mask_variant = .true., missing_value=missing_value)
     end do
   end do
 endif !(Lmodis_sim)




  end subroutine diag_field_init 


!####################################################################

subroutine cosp_driver   &
        (lat_in, lon_in, daytime_in, phalf_plus, p_full_in, zhalf_plus,&
         z_full_in, u_wind_in, v_wind_in, mr_ozone_in, &
         T_in, sh_in, tca_in, cca_in, lsliq_in, lsice_in, ccliq_in, &
         ccice_in, fl_lsrain_in, fl_lssnow_in, fl_lsgrpl_in, &
         fl_ccrain_in,  &
         fl_ccsnow_in, reff_lsclliq_in, reff_lsclice_in,   &
         reff_lsprliq_in, reff_lsprice_in, reff_ccclliq_in,  &
         reff_ccclice_in, reff_ccprliq_in, reff_ccprice_in,  &
         skt_in, land_in, Time_diag, is, js, stoch_mr_liq_in, &
         stoch_mr_ice_in, stoch_size_liq_in, stoch_size_frz_in, &
         tau_stoch_in, lwem_stoch_in, stoch_cloud_type_in)
!--------------------------------------------------------------------
!    subroutine cosp_driver is the interface between the cosp simulator 
!    code and the AM model.
!--------------------------------------------------------------------
real, dimension(:,:),   intent(in) :: lat_in, lon_in, skt_in, land_in, &
                                      u_wind_in, v_wind_in
real, dimension(:,:), intent(in) :: daytime_in
real, dimension(:,:,:), intent(in) :: phalf_plus, p_full_in, &
        zhalf_plus, z_full_in, T_in, sh_in, &
        tca_in, cca_in, lsliq_in, lsice_in, ccliq_in, ccice_in, &
        fl_lsrain_in, fl_lssnow_in, fl_lsgrpl_in, fl_ccrain_in, &
        fl_ccsnow_in, mr_ozone_in, &
        reff_lsclliq_in, reff_lsclice_in, reff_lsprliq_in, &
        reff_lsprice_in, reff_ccclliq_in, reff_ccclice_in, &
        reff_ccprliq_in, reff_ccprice_in
real, dimension(:,:,:,:), intent(in), optional ::  &
               tau_stoch_in, lwem_stoch_in, stoch_cloud_type_in, &
               stoch_mr_liq_in, stoch_mr_ice_in, stoch_size_liq_in, &
               stoch_size_frz_in
type(time_type), intent(in) :: Time_diag

!local variables:

      integer, intent(in) :: is, js
      real, dimension(size(T_in,1)*size(T_in,2), size(T_in,3), &
                              ncolumns)  :: y3, y3a, y4, y5, y6, y7, y8
      integer :: nxdir, nydir, npts
      integer :: i, j, n, l
      integer :: k
      integer :: me
      logical :: used

  type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP
  type(cosp_subgrid) :: sgx     ! Subgrid outputs
  type(cosp_sghydro) :: sghydro ! Subgrid condensate
  type(cosp_sgradar) :: sgradar ! Output from radar simulator
  type(cosp_sglidar) :: sglidar ! Output from lidar simulator
  type(cosp_isccp)   :: isccp   ! Output from ISCCP simulator
  type(cosp_modis)   :: modis   ! Output from MODIS simulator
  type(cosp_misr)    :: misr    ! Output from MISR simulator
#ifdef RTTOV 
  type(cosp_rttov)   :: rttov   ! Output from RTTOV 
#endif
  type(cosp_vgrid)   :: vgrid   ! Information on vertical grid of stats
  type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator
  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
  real,dimension(:),allocatable :: lon,lat
  real,dimension(:),allocatable :: daytime
  real,dimension(:,:),allocatable        ::     &
                    p, ph, zlev, zlev_half, T, sh, rh, tca, cca, &
                    mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, fl_lsrain, &
                    fl_lssnow, fl_lsgrpl, fl_ccrain, fl_ccsnow, dtau_s, dtau_c, &
                    dem_s,dem_c, mr_ozone
  real,dimension(:,:,:),allocatable :: cloud_type
  real,dimension(:,:,:),allocatable :: Reff
  real,dimension(:,:,:),allocatable :: p_half_in, z_half_in
  real,dimension(:),allocatable :: skt,landmask,sfc_height,u_wind,v_wind
  integer :: nlon,nlat,npoints

      nlon = size(T_in,1)
      nlat = size(T_in,2)
      npoints = nlon*nlat                  

      allocate (p_half_in (size(T_in,1),size(T_in,2), size(T_in,3)) ) 
      allocate (z_half_in (size(T_in,1),size(T_in,2), size(T_in,3))  )
      p_half_in(:,:,1:size(T_in,3)) = phalf_plus(:,:,2:size(T_in,3)+1)
      z_half_in(:,:,1:size(T_in,3)) = zhalf_plus(:,:,2:size(T_in,3)+1)
      if (present (tau_stoch_in)         .and. &
          present (lwem_stoch_in)        .and. &
          present (stoch_cloud_type_in)  .and. &
          present (stoch_mr_liq_in)      .and. &
          present (stoch_mr_ice_in)      .and. &
          present (stoch_size_liq_in)    .and. &
          present (stoch_size_frz_in) ) then
        sgx%cols_input_from_model = .true.
      else
        sgx%cols_input_from_model = .false.
      endif

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! Allocate arrays which are passed to the simulator code.
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      allocate(lon(Npoints),lat(Npoints), &
                p(Npoints,Nlevels),ph(Npoints,Nlevels), &
                zlev(Npoints,Nlevels), zlev_half(Npoints,Nlevels), &
                T(Npoints,Nlevels), sh(Npoints,Nlevels), &
                rh(Npoints,Nlevels), tca(Npoints,Nlevels), &
                cca(Npoints,Nlevels), mr_lsliq(Npoints,Nlevels), &
                mr_lsice(Npoints,Nlevels), mr_ccliq(Npoints,Nlevels),&
                mr_ccice(Npoints,Nlevels), fl_lsrain(Npoints,Nlevels),&
                fl_lssnow(Npoints,Nlevels), fl_lsgrpl(Npoints,Nlevels),&
                fl_ccrain(Npoints,Nlevels),&
                fl_ccsnow(Npoints,Nlevels), &
                Reff(Npoints,Nlevels,N_hydro), dtau_s(Npoints,Nlevels), &
                dtau_c(Npoints,Nlevels), dem_s(Npoints,Nlevels), &
                dem_c(Npoints,Nlevels), skt(Npoints),  &
                landmask(Npoints), sfc_height(Npoints), &
                mr_ozone(Npoints,Nlevels), u_wind(Npoints), &
                v_wind(Npoints), daytime(Npoints))
      allocate ( cloud_type(Npoints, Ncolumns, Nlevels))
  
  ! Example that processes ntsteps. It always uses the same input data
  wmode = 'replace' ! Only for first iteration
  do i=1,1
    time_bnds(:,i) = (/time(i)-0.5,time(i)+0.5/) ! This is just for exam    ple purposes
!   if (use_input_file) then
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Read input geophysical variables from NetCDF file
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! input : surface to top
!       call nc_read_input_file(finput,Npoints,Nlevels,N_hydro,lon,lat,p,ph,zlev,zlev_half,T,sh,rh,tca,cca, &
!               mr_lsliq,mr_lsice,mr_ccliq,mr_ccice,fl_lsrain,fl_lssnow,fl_lsgrpl,fl_ccrain,fl_ccsnow,Reff, &
!               dtau_s,dtau_c,dem_s,dem_c,skt,landmask, &
!               sfc_height,mr_ozone,u_wind,v_wind, &
!               emsfc_lw,geomode,Nlon,Nlat)
                ! geomode = 2 for (lon,lat) mode.
                ! geomode = 3 for (lat,lon) mode.
                ! In those modes it returns Nlon and Nlat with the correct values
        
!      else
!---------------------------------------------------------------------
!   this code used when attached to AM3
!---------------------------------------------------------------------
       call produce_cosp_input_fields ( Npoints, Nlevels, N_hydro,  &
              lon_in, lat_in, daytime_in, p_half_in, p_full_in, z_half_in, &
              z_full_in, u_wind_in, v_wind_in, mr_ozone_in, T_in, &
              sh_in, tca_in, &
              cca_in, lsliq_in, lsice_in, ccliq_in, ccice_in,  &
              fl_lsrain_in,  &
              fl_lssnow_in, fl_lsgrpl_in, fl_ccrain_in, fl_ccsnow_in, &
              reff_lsclliq_in, reff_lsclice_in, reff_lsprliq_in, &
              reff_lsprice_in, reff_ccclliq_in, reff_ccclice_in,  &
              reff_ccprliq_in, reff_ccprice_in, tau_stoch_in,  &
              lwem_stoch_in, stoch_cloud_type_in, skt_in, land_in, &
              lon,lat, daytime, p, ph, zlev, zlev_half, u_wind, v_wind, &
              mr_ozone, T, sh, rh,&
              tca, &
              cca, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, fl_lsrain,&
              fl_lssnow, fl_lsgrpl, fl_ccrain, fl_ccsnow, Reff, dtau_s,&
              dtau_c,&
              dem_s, dem_c, cloud_type, skt, landmask,   &
              sfc_height)  

        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Allocate memory for gridbox type
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!       print *, 'Allocating memory for gridbox type...'
        if (use_mie_tables /= 0) then
          call error_mesg ('cosp_driver', &      
              'use_mie_tables must be set to 0 currently', FATAL)
        endif
        call construct_cosp_gridbox(time(i), time_bnds(:,i), radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
                                    Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero, Npoints_it, &
                                    lidar_ice_type, &
                                    isccp_topheight,isccp_topheight_direction,overlap, &
         emsfc_lw, use_precipitation_fluxes,use_reff, &
                     Platform,Satellite,Instrument,Nchannels,ZenAng, &
             channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co, &
                          gbx)
        
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Here code to populate input structure
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!       print *, 'Populating input structure...'
        gbx%longitude = lon
        gbx%latitude = lat
        gbx%p = p
        gbx%ph = ph
        gbx%zlev = zlev
        gbx%zlev_half = zlev_half
        gbx%T = T
        gbx%q = rh
        gbx%sh = sh
        gbx%cca = cca
        gbx%tca = tca
        gbx%psfc = ph(:,1)
        gbx%skt  = skt
        gbx%land = landmask
        gbx%sfc_height  = sfc_height
        gbx%mr_ozone  = mr_ozone
        gbx%u_wind  = u_wind
        gbx%v_wind  = v_wind
        gbx%sunlit(:) = daytime(:)
        
        gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq
        gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice
        gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq
        gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice




        gbx%rain_ls = fl_lsrain
        gbx%snow_ls = fl_lssnow
        gbx%grpl_ls = fl_lsgrpl
        gbx%rain_cv = fl_ccrain
        gbx%snow_cv = fl_ccsnow
        me = mpp_pe()
        
        gbx%Reff = Reff
        
        ! ISCCP simulator
        gbx%dtau_s   = dtau_s
        gbx%dtau_c   = dtau_c
        gbx%dem_s    = dem_s
        gbx%dem_c    = dem_c

               
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Define new vertical grid
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!       print *, 'Defining new vertical grid...'
        call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid)
        
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Allocate memory for other types
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!       print *, 'Allocating memory for other types...'
        call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx)
        call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,N_hydro,sghydro)

     if (sgx%cols_input_from_model) then
!---------------------------------------------------------------------
!    convert the stochastic column inputs from lon-lat to npoints, then
!    save the column values, reversing the vertical indices, into the
!    cosp_subgrid_type variables.
!---------------------------------------------------------------------
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= stoch_mr_liq_in, y3= y3  )
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= stoch_mr_ice_in   (:,:,:,:), y3= y4  )
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= stoch_size_liq_in, y3= y5  )
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= stoch_size_frz_in, y3= y6  )
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= tau_stoch_in, y3= y7  )
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= lwem_stoch_in, y3= y8  )
        call map_ll_to_point(nlon,nlat,npoints, &
                        x4= stoch_cloud_type_in(:,:,:,:), y3= y3a  )
        do l=1, NCOLUMNS
          do k=1,nlevels
            do n=1,npoints
              if (y3a(n,k,l) == 1.0) then
                sghydro%mr_hydro(n,l,nlevels-k+1,I_LSCLIQ) = y3(n,k,l)
                sghydro%mr_hydro(n,l,nlevels+1-k,I_LSCICE) = y4(n,k,l)
            if ( sghydro%mr_hydro(n,l,nlevels-k+1,I_LSCLIQ) > 0.0) then
                sghydro%Reff(n,l,nlevels-k+1,I_LSCLIQ) = y5(n,k,l)
            else
                sghydro%Reff(n,l,nlevels+1-k,I_LSCLIQ) = 0.0          
            endif
            if (sghydro%mr_hydro(n,l,nlevels+1-k,I_LSCICE) > 0.0) then
                sghydro%Reff(n,l,nlevels+1-k,I_LSCICE) = y6(n,k,l)
            else
                sghydro%Reff(n,l,nlevels+1-k,I_LSCICE) = 0.0          
            endif
              else
                sghydro%mr_hydro(n,l,nlevels+1-k,I_LSCLIQ) = 0.0          
                sghydro%mr_hydro(n,l,nlevels+1-k,I_LSCICE) = 0.0          
                sghydro%Reff(n,l,nlevels+1-k,I_LSCLIQ) = 0.0          
                sghydro%Reff(n,l,nlevels+1-k,I_LSCICE) = 0.0          
              endif
              if (y3a(n,k,l) == 2.0) then
                sghydro%mr_hydro(n,l,nlevels+1-k,I_CVCLIQ) = y3(n,k,l)
                sghydro%mr_hydro(n,l,nlevels+1-k,I_CVCICE) = y4(n,k,l)
            if (sghydro%mr_hydro(n,l,nlevels+1-k,I_CVCLIQ) > 0.0) then
                sghydro%Reff(n,l,nlevels+1-k,I_CVCLIQ) = y5(n,k,l)
            else
                sghydro%Reff(n,l,nlevels+1-k,I_CVCLIQ) = 0.0          
            endif
            if (sghydro%mr_hydro(n,l,nlevels+1-k,I_CVCICE) > 0.0) then
                sghydro%Reff(n,l,nlevels+1-k,I_CVCICE) = y6(n,k,l)
            else
                sghydro%Reff(n,l,nlevels+1-k,I_CVCICE) = 0.0          
            endif
              else
                sghydro%mr_hydro(n,l,nlevels+1-k,I_CVCLIQ) = 0.0          
                sghydro%mr_hydro(n,l,nlevels+1-k,I_CVCICE) = 0.0          
                sghydro%Reff(n,l,nlevels+1-k,I_CVCLIQ) = 0.0          
                sghydro%Reff(n,l,nlevels+1-k,I_CVCICE) = 0.0          
              endif
              sgx%dtau_col(n,l,k) = y7(n,k,l)
              sgx%dem_col(n,l,k) = y8(n,k,l)
            end do
          end do
        end do
      endif

        
        call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar)
        call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar)
        call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar)
        call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar)
        call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp)
        call construct_cosp_modis(cfg,Npoints,Ncolumns,modis)
!       call construct_cosp_modis(cfg,Npoints,modis)
        call construct_cosp_misr(cfg,Npoints,misr)
#ifdef RTTOV 
        call construct_cosp_rttov(Npoints,Nchannels,rttov)
#endif
        
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Call simulator
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!       print *, 'Calling simulator...'
        me = mpp_pe()
        if (Ncolumns == 1) then
         if (gbx%use_precipitation_fluxes) then
            call error_mesg ('cosp_driver:cosp_driver', &
             'Use of precipitation fluxes not supported in&
                               & CRM mode (Ncolumns=1)', FATAL)
         endif
         if ((maxval(gbx%dtau_c) > 0.0).or.(maxval(gbx%dem_c) > 0.0)) then
            call error_mesg ('cosp_driver:cosp_driver', &
             ' dtau_c > 0.0 or dem_c > 0.0. In CRM mode (Ncolumns=1) &
             &the optical depth (emmisivity) of all clouds must be &
             &passed through dtau_s (dem_s)', FATAL)
         endif
      endif
#ifdef RTTOV 
        call cosp(me,overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar, sghydro, cloud_type)
#else
        call cosp(me,overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar, sghydro, cloud_type)
#endif
        
!output results
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Write outputs to CMOR-compliant NetCDF
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        if (i /= 1) wmode = 'append'
        gbx%time = time(i)
!       if (cfg%Lwrite_output) then
!       print *, 'Writing outputs...'
!    if (produce_cmor_output_fields) then
!           if (geomode == 1)  then 
!#ifdef RTTOV
!             call nc_write_cosp_1d(cmor_nl,wmode,cfg,vgrid,gbx,sgx,sgradar,sglidar, &
!                                            isccp,misr,modis, rttov,stradar,stlidar)
!#else
!             call nc_write_cosp_1d(cmor_nl,wmode,cfg,vgrid,gbx,sgx,sgradar,sglidar, &
!                                            isccp,misr,modis, stradar,stlidar)
!#endif
!           else if (geomode >  1)  then
!#ifdef RTTOV
!               call nc_write_cosp_2d(cmor_nl,wmode,cfg,vgrid,gbx,sgx,sgradar,sglidar, &
!                                                   isccp,misr,modis, rttov, stradar,stlidar,geomode,Nlon,Nlat)
!#else
!               call nc_write_cosp_2d(cmor_nl,wmode,cfg,vgrid,gbx,sgx,sgradar,sglidar, &
!                                                   isccp,misr,modis, stradar,stlidar,geomode,Nlon,Nlat)
!#endif
!       endif
!    else
!---------------------------------------------------------------------
!    this is the routine which accesses diag_manager when run in AM3.
!---------------------------------------------------------------------
!      print *, 'calling output_cosp_fields'
       used = send_data (id_ph    , phalf_plus, Time_diag, is, js, 1 )
       used = send_data (id_zh     , zhalf_plus, Time_diag, is, js, 1 )
       call output_cosp_fields (nlon,nlat,npoints, &
                            stlidar, stradar, isccp, modis, misr, sgradar, &
                           sglidar, sgx, Time_diag, is, js, lat, lon,&
                               p, ph, zlev, zlev_half, u_wind, v_wind, &
                                mr_ozone, T, sh, rh, &
                                 tca, cca, mr_lsliq, mr_lsice, &
                                 mr_ccliq, mr_ccice, fl_lsrain, &
                                 fl_lssnow, fl_lsgrpl, fl_ccrain,  &
                                 fl_ccsnow, &
                                 Reff, dtau_s, dtau_c, dem_s, dem_c, &
                                 gbx%sunlit, &
                                 skt,landmask, cloud_type, sfc_height)
!    endif

        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ! Deallocate memory in derived types
        !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!       print *, 'Deallocating memory...'
        call free_cosp_gridbox(gbx)
        call free_cosp_subgrid(sgx)
        call free_cosp_sghydro(sghydro)
        call free_cosp_sgradar(sgradar)
        call free_cosp_radarstats(stradar)
        call free_cosp_sglidar(sglidar)
        call free_cosp_lidarstats(stlidar)
        call free_cosp_isccp(isccp)
        call free_cosp_misr(misr)
        call free_cosp_modis(modis)
#ifdef RTTOV 
        call free_cosp_rttov(rttov)
#endif
        call free_cosp_vgrid(vgrid)  
  enddo
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  ! Deallocate memory in local arrays
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  deallocate(lon,lat,daytime, p,ph,zlev,zlev_half,T,sh,rh,tca,cca,  &
             mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, &
             fl_lsrain,fl_lssnow,fl_lsgrpl,fl_ccrain,fl_ccsnow,Reff,dtau_s, &
             dtau_c,dem_s,dem_c, cloud_type, skt,landmask,sfc_height,mr_ozone,u_wind,v_wind)


  ! Time in s. Only for testing purposes
! call system_clock(t1,count_rate,count_max)
! print *,(t1-t0)*1.0/count_rate


end subroutine cosp_driver



!#####################################################################

subroutine cosp_driver_end 

!-------------------------------------------------------------------
!    deallocate the module arrays.
!-------------------------------------------------------------------
      deallocate (id_dbze94)
      deallocate (id_cloud_type)
      if (allocated(id_atb532)) deallocate (id_atb532)
      if (use_vgrid) then
        deallocate (id_cloudsatcfad)
        deallocate (id_calipsosrcfad)
        deallocate (id_cloudsatcfad_sat)
        deallocate (id_calipsosrcfad_sat)
      else
        deallocate (id_cloudsatcfad_mdl)
        deallocate (id_calipsosrcfad_mdl)
      endif
      if (generate_orbital_output) then
        deallocate (location, lflag_array, flag_array, lflag_array_temp, &
                    lflag_array_parasol, Time_start, Time_end)
      endif

end subroutine cosp_driver_end

!#####################################################################

subroutine output_cosp_fields   &
          (nlon,nlat,npoints,stlidar, stradar, isccp, modis, misr, sgradar, sglidar, sg, &
            Time_diag, is, &
           js, lat, lon, p, ph, z, zh, u_wind, v_wind, mr_ozone, T, &
           sh, rh, tca, cca, lsliq, &
           lsice, ccliq, ccice, fl_lsrain, fl_lssnow, fl_lsgrpl, &
           fl_ccrain, &
           fl_ccsnow, reff, dtau_s, dtau_c, dem_s, dem_c, sunlit,skt,landmask,&
           cloud_type, sfc_height)

!---------------------------------------------------------------------
!     subroutine output_cosp_fields outputs fields relevant to the
!     cosp ismulator, both input and output.
!---------------------------------------------------------------------

integer,                            intent(in) :: nlon,nlat,npoints
integer,                            intent(in) :: is, js
real, dimension(npoints),           intent(in) :: lat, lon, sunlit, skt, &
                                                  landmask, sfc_height,&
                                                  u_wind, v_wind
real, dimension(npoints, nlevels),  intent(in) :: p, z, mr_ozone
real, dimension(npoints, nlevels),  intent(in) ::      &
                          ph, zh, T, sh, rh, tca, cca, lsliq, lsice, &
                        ccliq, ccice, fl_lsrain, fl_lssnow, fl_lsgrpl, &
                          fl_ccrain, fl_ccsnow, dtau_s, dtau_c, dem_s, &
                          dem_c
real, dimension(npoints, nlevels,n_hydro),  intent(in) :: reff
real, dimension(npoints, ncolumns, nlevels),  intent(in) :: cloud_type
type(cosp_lidarstats), intent(in) :: stlidar
type(cosp_radarstats), intent(in) :: stradar
type(cosp_isccp     ), intent(in) :: isccp  
type(cosp_modis     ), intent(in) :: modis
type(cosp_misr      ), intent(in) :: misr   
type(cosp_sgradar   ), intent(in) :: sgradar
type(cosp_sglidar   ), intent(in) :: sglidar
type(cosp_subgrid   ), intent(in) :: sg
type(time_type)      , intent(in) :: Time_diag

!   local variables:

      logical :: used
      integer :: n, m
      real, dimension(Nlon,Nlat) :: y2, y2save, alpha, y2sunlit 
      real, dimension(Nlon,Nlat) :: y2lsave, y2isave
      real, dimension(Nlon,Nlat,Nlevels) :: y3 
      real, dimension(Nlon,Nlat,Nlevels) :: y31,y32, y33,y34, y35, y36,y37 
      real, dimension(Nlon,Nlat,Nlevels) :: y3a
      real, dimension(Nlon,Nlat,Nlr    ) :: z3 
      real, dimension(Nlon,Nlat,Nlr    ) :: z3a
      real, dimension(Nlon,Nlat,Ncolumns) :: y4 
      real, dimension(Nlon,Nlat,PARASOL_NREFL) :: y5 
      real, dimension(Nlon,Nlat,Ncolumns,Nlevels) :: y6,y6a 
      real, dimension(Nlon,Nlat,Ncolumns,Nlr    ) :: z6,z6a 
      real, dimension(Nlon,Nlat,DBZE_BINS,Nlevels) :: y7,y7a 
      real, dimension(Nlon,Nlat,DBZE_BINS,Nlr    ) :: z7,z7a 
      real, dimension(Nlon,Nlat,SR_BINS,Nlevels) :: y8, y8a
      real, dimension(Nlon,Nlat,SR_BINS,Nlr    ) :: z8, z8a
      real, dimension(Nlon,Nlat,7,7            ) :: y9 
      real, dimension(Nlon,Nlat,numTauHistogramBins,  &
                                      numPressureHistogramBins  ) :: y12
      real, dimension(Nlon,Nlat,7,MISR_N_CTH   ) :: y10
      logical, dimension (Nlon,Nlat,Nlevels) :: mask_y3a
      logical, dimension (Nlon,Nlat) :: lmsk
      integer :: nsat_time

      if (generate_orbital_output) then
!----------------------------------------------------------------------
!    determine the time index of the current time in the satellite 
!    orbit data.
!----------------------------------------------------------------------
        do n= nsat_time_prev, num_sat_periods  
          if (Time_diag >= Time_start(n) .and.   &
                                           Time_diag <= Time_end(n)) then
            nsat_time = n
            nsat_time_prev = nsat_time
            exit
          else
!   set nsat_time to 0 if current time not within sampling region
            nsat_time = 0
          endif
        end do
      endif

!----------------------------------------------------------------------
!    output the input fields to COSP. fields must be converted from
!    2d arrays (i,j)
!----------------------------------------------------------------------

!   2D fields:
   call map_point_to_ll (Nlon, Nlat, geomode, x1=lat, y2 = y2)
   used = send_data (id_lat       , y2, Time_diag, is, js )
   used = send_data (id_lat_sat   , y2, Time_diag, is, js,  mask =  &
                                           lflag_array(:,:,nsat_time))

   call map_point_to_ll (Nlon, Nlat, geomode, x1=lon, y2 = y2)
   used = send_data (id_lon       , y2, Time_diag, is, js )
   used = send_data (id_lon_sat   , y2, Time_diag, is, js,  mask =  &
                                           lflag_array(:,:,nsat_time))

   call map_point_to_ll (Nlon, Nlat, geomode, x1=sunlit, y2 = y2sunlit)
   used = send_data (id_sunlit    , y2sunlit, Time_diag, is, js )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=skt, y2 = y2)
   used = send_data (id_skt       , y2, Time_diag, is, js )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=landmask, y2 = y2)
   used = send_data (id_land      , y2, Time_diag, is, js )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=u_wind, y2 = y2)
   used = send_data (id_u_wind    , y2, Time_diag, is, js )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=v_wind, y2 = y2)
   used = send_data (id_v_wind    , y2, Time_diag, is, js )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=sfc_height, y2 = y2)
   used = send_data (id_sfcht     , y2, Time_diag, is, js )

!   3D fields:
   call map_point_to_ll (Nlon, Nlat, geomode, x2=p,  y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_p         , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=z, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_z         , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=mr_ozone, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_mr_ozone  , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=T, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_T         , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=sh, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y37   )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=rh, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_rh        , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=tca, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y35   )
   used = send_data (id_tca       , y35, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=cca, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y36   )
   used = send_data (id_cca       , y36, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=lsliq, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y31   )
   call map_point_to_ll (Nlon, Nlat, geomode, x2=lsice, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y32   )
   call map_point_to_ll (Nlon, Nlat, geomode, x2=ccliq, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y33   )
   call map_point_to_ll (Nlon, Nlat, geomode, x2=ccice, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y34   )

   used = send_data (id_lsca_cmip  , y35-y36, Time_diag, is, js, 1, &
                                           mask =  y31 > 0)
   used = send_data (id_cca_cmip  , y36, Time_diag, is, js, 1, &
                                           mask =  y33 > 0)

   used = send_data (id_lsliq     , (y35-y36)*y31/((1.0+y36*(y33+y34))*&
                                       (1+y31)), Time_diag, is, js, 1 )

   used = send_data (id_lsice     , (y35-y36)*y32/((1.0+y36*  &
                            (y33+y34))*(1+y32)), Time_diag, is, js, 1 )

   used = send_data (id_ccliq     , y36*y33/((1.0+y36*(y33+y34))*  &
                                       (1+y33)), Time_diag, is, js, 1 )

   used = send_data (id_ccice     , y36*y34/((1.0+y36*(y33+y34))* &
                                       (1+y34)), Time_diag, is, js, 1 )

  used = send_data (id_sh        , y37/(1.+y36*(y33+y34)),  &
                                                 Time_diag, is, js, 1 )
   used = send_data (id_tot_h2o   , (y37 + (y35-y36)*y31/(1.+y31)+ &
          (y35-y36)*y32/(1.+y32)+y36*(y33/(1.+y33)+y34/(1.+y34)))/ &
                     ((1.0+y36*(y33+y34) )), Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=fl_lsrain, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_fl_lsrain , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=fl_lssnow, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_fl_lssnow , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=fl_lsgrpl, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_fl_lsgrpl , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=fl_ccrain, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_fl_ccrain , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=fl_ccsnow, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_fl_ccsnow , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_lscliq),&
                                                             y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a )
   used = send_data (id_reff_lsclliq , 0.5*y3a, Time_diag, is, js, 1, &
                   mask = y31 > 0.0 )
   used = send_data (id_reff_lsclliq_cmip , 0.5*y3a*(y35-y36) , Time_diag, is, js, 1, &
                   mask = y31 > 0.0 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_lscice),&
                                                               y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_lsclice , 0.5*y3a, Time_diag, is, js, 1 , &
                   mask = y32 > 0.0)

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_lsrain),&
                                                               y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_lsprliq , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_lssnow),&
                                                               y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_lsprice , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_cvcliq),&
                                                               y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_ccclliq , 0.5*y3a, Time_diag, is, js, 1 , &
                   mask = y33 > 0.0)
   used = send_data (id_reff_ccclliq_cmip , 0.5*y3a*y36 , Time_diag, is, js, 1 , &
                   mask = y33 > 0.0)

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_cvcice),&
                                                                y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_ccclice , 0.5*y3a, Time_diag, is, js, 1 , &
                   mask = y34 > 0.0)

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_cvrain),&
                                                              y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_ccprliq , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=reff(:,:,i_cvsnow),&
                                                              y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_reff_ccprice , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=dtau_s, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_dtau_s       , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=dtau_c, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_dtau_c       , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=dem_s, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_dem_s       , y3a, Time_diag, is, js, 1 )

   call map_point_to_ll (Nlon, Nlat, geomode, x2=dem_c, y3 = y3)
   call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_dem_c       , y3a, Time_diag, is, js, 1 )

!---------------------------------------------------------------------
!    process COSP output variables
!---------------------------------------------------------------------

 if (cfg%Llidar_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode, x1=stlidar%cldlayer(:,4),&
                                                               y2 = y2)
   used = send_data (id_cltcalipso,      y2, Time_diag, is, js , &
                                          mask = y2 /= missing_value )

   if (generate_orbital_output) then
     used = send_data (id_cltcalipso_sat,      y2, Time_diag, is, js , &
                                     mask = y2 /= missing_value  .and. &
                                          lflag_array(:,:,nsat_time))
   endif

   call map_point_to_ll (Nlon, Nlat, geomode, x1=stlidar%cldlayer(:,1),&
                                                               y2 = y2)
   used = send_data (id_cllcalipso,      y2, Time_diag, is, js , &
                           mask = y2 /= missing_value )

   if (generate_orbital_output) then
     used = send_data (id_cllcalipso_sat,      y2, Time_diag, is, js , &
                                     mask = y2 /= missing_value  .and. &
                                          lflag_array(:,:,nsat_time))
   endif

   call map_point_to_ll (Nlon, Nlat, geomode, x1=stlidar%cldlayer(:,2),&
                                                               y2 = y2)
   used = send_data (id_clmcalipso,      y2, Time_diag, is, js , &
                           mask = y2 /= missing_value )

   if (generate_orbital_output) then
     used = send_data (id_clmcalipso_sat,      y2, Time_diag, is, js , &
                                     mask = y2 /= missing_value  .and. &
                                          lflag_array(:,:,nsat_time))
   endif

   call map_point_to_ll (Nlon, Nlat, geomode, x1=stlidar%cldlayer(:,3),&
                                                               y2 = y2)
   used = send_data (id_clhcalipso,      y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   if (generate_orbital_output) then
     used = send_data (id_clhcalipso_sat,      y2, Time_diag, is, js , &
                                     mask = y2 /= missing_value  .and. &
                                          lflag_array(:,:,nsat_time))
   endif
 endif

 if(cfg%Lradar_sim .and.cfg%Llidar_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,  &
                                    x1=stradar%radar_lidar_tcc,y2 = y2)
   used = send_data (id_cltlidarradar, y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )
 endif

 if (cfg%Lisccp_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode, x1=isccp%totalcldarea,&
                                                       y2 = y2save)
   used = send_data (id_tclisccp,      y2save, Time_diag, is, js , &
                                           mask = y2save /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=isccp%meanptop,&
                                                              y2 = y2)
   where (y2save== 0.0 .and. y2sunlit == 1.0)
     alpha = 0.0
   elsewhere
     alpha =     y2*y2save
   endwhere

   used = send_data (id_ctpisccp , alpha     , Time_diag, is, js , &
                                           mask = y2sunlit == 1.0    )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=isccp%meantb,&
                                                              y2 = y2)

   used = send_data (id_tbisccp  , y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=isccp%meantbclr,&
                                                              y2 = y2)

   used = send_data (id_tbclrisccp  , y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=isccp%meantaucld,&
                                                             y2 = y2)
   where (y2save== 0.0 .and. y2sunlit == 1.0)
     alpha = 0.0
   elsewhere
     alpha = y2*y2save
   endwhere

   used = send_data (id_tauisccp  , alpha    , Time_diag, is, js , &
                                           mask = y2sunlit == 1.0 )

   call map_point_to_ll (Nlon, Nlat, geomode, x1=isccp%meanalbedocld,&
                                                              y2 = y2)
   where (y2save== 0.0 .and. y2sunlit == 1.0)
     alpha = 0.0
   elsewhere
     alpha = y2*y2save
   endwhere

   used = send_data (id_albisccp  , alpha, Time_diag, is, js , &
                                           mask = y2sunlit == 1.0 )
 endif

 if (cfg%Lmodis_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Fraction_Total_Mean,   &
                                                           y2 = y2save)
   used = send_data (id_tclmodis  , y2save, Time_diag, is, js , &
                                           mask = y2save /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Fraction_High_Mean,   &
                                                           y2 = y2)
   used = send_data (id_hicldmodis  , y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Fraction_Mid_Mean,   &
                                                           y2 = y2)
   used = send_data (id_mdcldmodis  , y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Fraction_Low_Mean,   &
                                                           y2 = y2)
   used = send_data (id_locldmodis  , y2, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Fraction_Water_Mean,   &
                                                              y2 = y2lsave)
   used = send_data (id_lclmodis  , y2lsave, Time_diag, is, js , &
                                           mask = y2lsave /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Fraction_Ice_Mean,   &
                                                              y2 = y2isave)
   used = send_data (id_iclmodis  , y2isave, Time_diag, is, js , &
                                           mask = y2isave /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                           x1=modis%Optical_Thickness_Total_Mean,   &
                                                              y2 = y2)

   where (y2save == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2save
   endwhere

   used = send_data (id_ttaumodis  , alpha, Time_diag, is, js , &
                                         mask = y2sunlit == 1.0 )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                           x1=modis%Optical_Thickness_Water_Mean,   &
                                                              y2 = y2)
   where (y2lsave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2lsave
   endwhere

   used = send_data (id_ltaumodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                           x1=modis%Optical_Thickness_Ice_Mean,   &
                                                              y2 = y2)
   where (y2isave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2save
     alpha = y2*y2isave
   endwhere

   used = send_data (id_itaumodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                        x1=modis%Optical_Thickness_Total_LogMean,   &
                                                              y2 = y2)
   where (y2save == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2save
   endwhere

   used = send_data (id_tlogtaumodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                           x1=modis%Optical_Thickness_Water_LogMean,   &
                                                              y2 = y2)
   where (y2lsave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2lsave
   endwhere

   used = send_data (id_llogtaumodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                           x1=modis%Optical_Thickness_Ice_LogMean,   &
                                                              y2 = y2)
   where (y2isave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2isave
   endwhere

   used = send_data (id_ilogtaumodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Particle_Size_Water_Mean,   &
                                                              y2 = y2)
   where (y2lsave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2lsave
   endwhere

   used = send_data (id_lremodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )
     lmsk(:,:) = (y2(:,:) < 0.0) .and. (y2(:,:) > -1.0)
   used = send_data (id_badlremodis  , y2, Time_diag, is, js , &
                                           mask = lmsk                )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Particle_Size_Ice_Mean,   &
                                                              y2 = y2)
  where (y2isave == 0.0 .and. y2sunlit == 1.0) 
    alpha = 0.
  elsewhere
     alpha = y2*y2isave
   endwhere

   used = send_data (id_iremodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )
     lmsk(:,:) = (y2(:,:) < 0.0) .and. (y2(:,:) > -1.0)
   used = send_data (id_badiremodis  , y2, Time_diag, is, js , &
                                           mask = lmsk                )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Cloud_Top_Pressure_Total_Mean,   &
                                                              y2 = y2)
   where (y2save == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2save
   endwhere

   used = send_data (id_ctpmodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Liquid_Water_Path_Mean,   &
                                                              y2 = y2)
   where (y2lsave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2lsave
   endwhere

   used = send_data (id_lwpmodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )

   call map_point_to_ll (Nlon, Nlat, geomode,  &
                               x1=modis%Ice_Water_Path_Mean,   &
                                                              y2 = y2)
   where (y2isave == 0.0 .and. y2sunlit == 1.0) 
     alpha = 0.
   elsewhere
     alpha = y2*y2isave
   endwhere

   used = send_data (id_iwpmodis  , alpha, Time_diag, is, js , &
                                           mask = y2 /= missing_value )


   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x2=modis%Column_Optical_Thickness, y3 = y4)
   do n=1,ncolumns
     used = send_data (id_taumodis_n(n), y4(:,:,n), Time_diag,  &
                       is, js, mask = y4(:,:,n) /= missing_value )
   end do

   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x2=modis%Column_Cloud_Top_Pressure, y3 = y4)
   do n=1,ncolumns
     used = send_data (id_ptopmodis_n(n), 0.01*y4(:,:,n), Time_diag, &
                       is, js, mask = y4(:,:,n) /= missing_value )
   end do
   
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x2=modis%Column_Particle_Size, y3 = y4)
   do n=1,ncolumns
     used = send_data (id_sizemodis_n(n), y4(:,:,n), Time_diag, &
                       is, js, mask = y4(:,:,n) > 0.0 )
    
     lmsk(:,:) = (y4(:,:,n) < 0.0) .and. (y4(:,:,n) > -1.0)
     used = send_data (id_badsizemodis_n(n), y4(:,:,n), Time_diag, &
                       is, js, mask =  lmsk       )
   end do

   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x2=modis%retrievedPhase      , y3 = y4)
   do n=1,ncolumns
     used = send_data (id_phasemodis_n(n), y4(:,:,n), Time_diag, &
                       is, js, mask = y4(:,:,n) /= missing_value )
   end do

 endif 

 if (use_vgrid) then
   if (cfg%Llidar_sim) then
     
     call map_point_to_ll (Nlon, Nlat, geomode, x2=stlidar%lidarcld,&
                                                             y3 = z3)
     used = send_data (id_clcalipso,      z3 , Time_diag, is, js, 1,  &
                                  mask = z3 (:,:,:) /= missing_value )
     if (generate_orbital_output) then
       used = send_data (id_clcalipso_sat,   z3 , Time_diag, is, js, 1,  &
                               mask = (z3 (:,:,:) /= missing_value) .and.& 
                                         lflag_array_temp(:,:,:,nsat_time))
     endif
   endif
   if(cfg%Lradar_sim .and. cfg%Llidar_sim) then
     call map_point_to_ll (Nlon, Nlat, geomode,   &
                            x2=stradar%lidar_only_freq_cloud, y3 = z3)
     used = send_data (id_clcalipso2,      z3 , Time_diag, is, js, 1 , &
                                 mask = z3 (:,:,:) /= missing_value )
     if (generate_orbital_output) then
       used = send_data (id_clcalipso2_sat,  z3 , Time_diag, is, js, 1,  &
                               mask = (z3 (:,:,:) /= missing_value) .and.& 
                                         lflag_array_temp(:,:,:,nsat_time))
     endif
   endif
 else
   if (cfg%Llidar_sim) then
     call map_point_to_ll (Nlon, Nlat, geomode, x2=stlidar%lidarcld,&
                                                              y3 = y3)
     call flip_vert_index_3D (y3, nlevels,y3a   )
     used = send_data (id_clcalipso_mdl, y3a, Time_diag, is, js, 1,  &
                                   mask = y3a(:,:,:) /= missing_value )
   endif
   if(cfg%Lradar_sim .and. cfg%Llidar_sim) then
     call map_point_to_ll (Nlon, Nlat, geomode,   &
                             x2=stradar%lidar_only_freq_cloud, y3 = y3)
     call flip_vert_index_3D (y3, nlevels,y3a   )
     used = send_data (id_clcalipso2_mdl, y3a, Time_diag, is, js, 1 , &
                                  mask = y3a(:,:,:) /= missing_value )
   endif
 endif

!3d arrays (i,j,columns):
 if (cfg%Lisccp_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x2=isccp%boxtau, y3 = y4)
   used = send_data (id_boxtauisccp, y4, Time_diag, is, js,  &
                           mask = y4 /= missing_value )
   do n=1,ncolumns
     used = send_data (id_boxtauisccp_n(n), y4(:,:,n), Time_diag,  &
                       is, js, mask = y4(:,:,n) /= missing_value )
   end do

   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x2=isccp%boxptop, y3 = y4)
   used = send_data (id_boxptopisccp, y4, Time_diag, is, js )
   do n=1,ncolumns
     used = send_data (id_boxptopisccp_n(n),      y4(:,:,n), Time_diag, &
                       is, js, mask = y4(:,:,n) /= missing_value )
   end do
 endif

!3d arrays (i,j,parasol_nrefl):
 if (cfg%Llidar_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                                       x2=stlidar%parasolrefl, y3 = y5)
   used = send_data (id_parasolrefl, y5, Time_diag, is, js, 1 , &
                                          mask = y5 /= missing_value )
   if (generate_orbital_output) then
     used = send_data (id_parasolrefl_sat, y5, Time_diag, is, js, 1 , &
                                     mask = y5 /= missing_value  .and. &
                                  lflag_array_parasol(:,:,:,nsat_time))
   endif
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                                       x2=sglidar%beta_mol, y3 = y3)
     call flip_vert_index_3D (y3, nlevels,y3a   )
   used = send_data (id_betamol532, y3a, Time_diag, is, js, 1 , &
                                          mask = y3 /= missing_value )
 endif

!4d array (i,j,columns, levels):
   call map_point_to_ll (Nlon, Nlat, geomode, x3=sg%frac_out, y4 = y6)
     call flip_vert_index_4D (y6, nlevels,y6a   )
   do n=1, size(id_cloud_type,1)
     used = send_data (id_cloud_type(n), y6a(:,:,n,:),  &
                                                 Time_diag, is, js,1 )
   end do

!4d array (i,j,columns, levels):
 if(cfg%Lradar_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x3=sgradar%Ze_tot, y4 = y6)
   call flip_vert_index_4D (y6, nlevels,y6a   )
   do n=1, size(id_dbze94,1)
     used = send_data (id_dbze94(n), y6a(:,:,n,:), Time_diag, is, js,1 )
   end do

!4d array (i,j, dbze_bins, levels):
   if (use_vgrid) then
     call map_point_to_ll (Nlon, Nlat, geomode, x3=stradar%cfad_ze, &
                                                              y4 = z7)
     do n=1, size(id_cloudsatcfad,1)
       used = send_data (id_cloudsatcfad(n), z7(:,:,n,:), Time_diag, &
                        is, js, 1, mask = z7(:,:,n,:) /= missing_value )
       if (generate_orbital_output) then
         used = send_data (id_cloudsatcfad_sat(n), z7(:,:,n,:), Time_diag,&
                  is, js, 1, mask = (z7(:,:,n,:) /= missing_value) .and. & 
                       lflag_array_temp(:,:,:,nsat_time))
       endif
     end do
   else
     call map_point_to_ll (Nlon, Nlat, geomode,   &
                                         x3=stradar%cfad_ze, y4 = y7)
     call flip_vert_index_4D (y7, nlevels,y7a   )
     do n=1, size(id_cloudsatcfad_mdl,1)
       used = send_data (id_cloudsatcfad_mdl(n), y7a(:,:,n,:),  &
                             Time_diag, is, js,1 , &
                                mask = y7a(:,:,n,:) /= missing_value )
     end do
   endif
endif

!4d array (i,j,columns, levels   ):
 if (cfg%Llidar_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                                          x3=sglidar%beta_tot, y4 = y6)
   call flip_vert_index_4D (y6, nlevels,y6a   )
   do n=1, size(id_atb532,1)
     used = send_data (id_atb532(n), y6a(:,:,n,:), Time_diag, is,  &
                        js, 1, mask = y6a(:,:,n,:) /= missing_value )
   end do

!4d array (i,j, sr_bins,levels):
   if (use_vgrid) then
     call map_point_to_ll (Nlon, Nlat, geomode,   &
                          x3=stlidar%cfad_sr, y4 = z8)
     do n=1, size(id_calipsosrcfad,1)
       used = send_data (id_calipsosrcfad(n), z8(:,:,n,:),    &
                          Time_diag, is, js,1 , &
                                 mask = z8 (:,:,n,:) /= missing_value )
       if (generate_orbital_output) then
         used = send_data (id_calipsosrcfad_sat(n), z8(:,:,n,:),    &
                          Time_diag, is, js,1 , &
                            mask = (z8 (:,:,n,:) /= missing_value) .and. & 
                                       lflag_array_temp(:,:,:,nsat_time))
       endif
     end do
   else
     call map_point_to_ll (Nlon, Nlat, geomode,   &
                                          x3=stlidar%cfad_sr, y4 = y8)
     call flip_vert_index_4D (y8, nlevels,y8a   )
     do n=1, size(id_calipsosrcfad_mdl,1)
       used = send_data (id_calipsosrcfad_mdl(n), y8a (:,:,n,:),    &
                          Time_diag, is, js,1 , &
                                 mask = y8a(:,:,n,:) /= missing_value )
     end do
   endif
 endif

!4d array (i,j, isccp_tau,isccp_press):
 if (cfg%Lisccp_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                                            x3=isccp%fq_isccp, y4 = y9)
   do n=1, 7                           
     used = send_data (id_clisccp(n),      y9(:,:,:,n), Time_diag, is, &
                           js, 1, mask = y9(:,:,:,n) /= missing_value )
   end do

   do m=1,7
     do n=1, 7                           
       used = send_data (id_clisccp_n(m,n), y9(:,:,m,n), Time_diag, &
                           is, js, mask = y9(:,:,m,n) /= missing_value )
     end do
   end do
 endif


!4d array (i,j, modis_tau,modis_press):
 if (cfg%Lmodis_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
             x3=modis%Optical_Thickness_vs_Cloud_Top_Pressure, y4 = y12)
   do n=1, numPressureHistogramBins   
     used = send_data (id_tauctpmodis(n), y12(:,:,:,n), Time_diag, is, &
                           js, 1, mask = y12(:,:,:,n) /= missing_value )
   end do

   do m=1,numTauHistogramBins
     do n=1, numPressureHistogramBins   
       used = send_data (id_tauctpmodis_n(m,n), y12(:,:,m,n), Time_diag, &
                           is, js, mask = y12(:,:,m,n) /= missing_value )
     end do
   end do
 endif

!4d array (i,j, isccp_tau,MISR_N_CTH ):
 if (cfg%Lmisr_sim) then
   call map_point_to_ll (Nlon, Nlat, geomode,   &
                                            x3=misr%fq_misr, y4 = y10)
   do n=1, MISR_N_CTH                  
     used = send_data (id_misr(n), y10(:,:,:,n), Time_diag, is, &
                           js, 1, mask = y10(:,:,:,n) /= missing_value )
   end do

   do m=1,7
     do n=1, MISR_N_CTH                  
       used = send_data (id_misr_n(m,n), y10(:,:,m,n), Time_diag, &
                          is, js, mask = y10(:,:,m,n) /= missing_value )
     end do
   end do
 endif

!-------------------------------------------------------------------
 
 
end subroutine output_cosp_fields



!#####################################################################

subroutine produce_cosp_input_fields   &
        (Npnts, Nl, N_hydro, lon_in, lat_in, daytime_in, p_half_in, p_full_in, &
         z_half_in, z_full_in, u_wind_in, v_wind_in, mr_ozone_in, &
         T_in, sh_in, tca_in,&
         cca_in, lsliq_in, &
         lsice_in, ccliq_in, ccice_in, fl_lsrain_in, fl_lssnow_in, &
         fl_lsgrpl_in, &
         fl_ccrain_in, fl_ccsnow_in, reff_lsclliq_in, reff_lsclice_in, &
         reff_lsprliq_in, reff_lsprice_in, reff_ccclliq_in, &
         reff_ccclice_in, reff_ccprliq_in, reff_ccprice_in, &
         tau_stoch_in, lwem_stoch_in, stoch_cloud_type_in, skt_in, &
         land_in, &
         lon,lat, daytime, p, ph, z, zh, u_wind, v_wind, mr_ozone, T, qv, rh, &
         tca, cca, mr_lsliq,  &
         mr_lsice, mr_ccliq, mr_ccice, fl_lsrain, fl_lssnow,  &
         fl_lsgrpl, fl_ccrain,&
         fl_ccsnow, Reff, dtau_s, dtau_c, dem_s, dem_c, cloud_type, &
         skt, landmask, sfc_height) 

!--------------------------------------------------------------------
!    subroutine produce_cosp_input_fields converts inputs from AM3 
!    to the form needed by COSP.
!--------------------------------------------------------------------

integer,                  intent(in) :: Npnts, Nl, N_hydro
real,dimension(:,:),      intent(in) :: lon_in,lat_in, skt_in, land_in,&
                                        u_wind_in, v_wind_in
real, dimension(:,:),  intent(in) :: daytime_in
real,dimension(:,:,:),    intent(in) ::    &
            p_half_in, p_full_in, z_half_in, z_full_in, T_in, sh_in,  &
            tca_in, cca_in, lsliq_in, lsice_in, ccliq_in, ccice_in, &
            fl_lsrain_in, fl_lssnow_in, fl_lsgrpl_in, fl_ccrain_in, &
            fl_ccsnow_in, mr_ozone_in, &
            reff_lsclliq_in, reff_lsclice_in, reff_lsprliq_in, &
            reff_lsprice_in, reff_ccclliq_in, reff_ccclice_in, &
            reff_ccprliq_in, reff_ccprice_in
real,dimension(:,:,:,:),intent(in)   :: tau_stoch_in, lwem_stoch_in, &
                                        stoch_cloud_type_in
real,dimension(Npnts),intent(inout)  :: lon,lat, u_wind, v_wind
real,dimension(Npnts),intent(inout)  :: daytime
real,dimension(Npnts,Nl),           intent(out) ::   &
            p, ph, z, zh, T, qv, rh, tca, cca, mr_lsliq, mr_lsice, &
            mr_ccliq, mr_ccice, fl_lsrain, fl_lssnow, fl_lsgrpl, &
            fl_ccrain, mr_ozone, &
            fl_ccsnow, dtau_s, dtau_c, dem_s, dem_c
real,dimension(Npnts,Nl,N_hydro),    intent(out) :: Reff
real,dimension(Npnts,Ncolumns,Nl),  intent(out) :: cloud_type
real,dimension(Npnts),              intent(out) :: skt,landmask
real,dimension(Npnts),              intent(out) :: sfc_height   

!  local variables:

     real,dimension(Npnts,Nl)             :: y2                         
     real,dimension(Npnts,Nl,Ncolumns)    :: y3,y3a                   
     real, dimension(Npnts,Nl) :: qs
     real, dimension(size(T_in,1), size(T_in,2), size(T_in,3)) :: &
              qs_in, tau_stoch_mean, lwem_stoch_mean, tau_s_in, &
              tau_c_in, lwem_s_in, lwem_c_in
     integer :: nxdir, nydir, npts
     integer :: n, i, j, k
     real :: sum_s1, sum_s2, sum_c1, sum_c2
     integer :: ctr_s, ctr_c 


!--------------------------------------------------------------------
!   define array dimensions; verify consistency.
!--------------------------------------------------------------------
     nxdir = size(lat_in,1)
     nydir = size(lat_in, 2)
     npts = nxdir*nydir
     if (npts /= Npnts) then
       call error_mesg ('cosp_driver/produce_cosp_input_fields', &
                                     'ERROR -- i*j /= npts', FATAL)
     endif
   
!---------------------------------------------------------------------
!   map the 2d lon-lat arrays to 1D (npoints).
!---------------------------------------------------------------------
   call map_ll_to_point(nxdir,nydir,npts,x2=daytime_in, y1=daytime)
   call map_ll_to_point(nxdir,nydir,npts,x2=lat_in, y1=lat)
   call map_ll_to_point(nxdir,nydir,npts,x2=lon_in, y1=lon)
   call map_ll_to_point(nxdir,nydir,npts,x2=skt_in, y1=skt)
   call map_ll_to_point(nxdir,nydir,npts,x2=land_in, y1=landmask)
   call map_ll_to_point(nxdir,nydir,npts,x2=u_wind_in, y1=u_wind)
   call map_ll_to_point(nxdir,nydir,npts,x2=v_wind_in, y1=v_wind)

!---------------------------------------------------------------------
!   map the 3d lon-lat-k arrays to 2D (npoints,k), and flip their
!   vertical indices (index 1 nearest ground in COSP).
!---------------------------------------------------------------------
   call map_ll_to_point(nxdir,nydir,npts,x3=p_full_in, y2=y2)
   call flip_vert_index_2D (y2, nl,p  )
   call map_ll_to_point(nxdir,nydir,npts,x3=p_half_in, y2=y2)
   call flip_vert_index_2D (y2, nl,ph )
   call map_ll_to_point(nxdir,nydir,npts,x3=z_full_in, y2=y2)
   call flip_vert_index_2D (y2, nl,z  )
   call map_ll_to_point(nxdir,nydir,npts,x3=z_half_in, y2=y2)
   call flip_vert_index_2D (y2, nl,zh )
   call map_ll_to_point(nxdir,nydir,npts,x3=mr_ozone_in, y2=y2)
   call flip_vert_index_2D (y2, nl,mr_ozone )
   call map_ll_to_point(nxdir,nydir,npts,x3=T_in, y2=y2)
   call flip_vert_index_2D (y2, nl,T  )
   call map_ll_to_point(nxdir,nydir,npts,x3=sh_in, y2=y2)
   call flip_vert_index_2D (y2, nl,qv )

!---------------------------------------------------------------------
!   define surface height
!---------------------------------------------------------------------
   sfc_height(:) = zh(:,1)

!--------------------------------------------------------------------
!   compute qs and then the relative humidity.
!   a limit my be imposed (nml control) to account for slightly inexact
!   values near saturation.
!--------------------------------------------------------------------
   if (use_rh_wrt_liq) then
     call compute_qs (T_in, p_full_in, qs_in, q=sh_in,  &
                                          es_over_liq = use_rh_wrt_liq)
   else
     call compute_qs (T_in, p_full_in, qs_in, q=sh_in)
   endif
   call map_ll_to_point(nxdir,nydir,npts,x3=qs_in, y2=y2)
   call flip_vert_index_2D (y2, nl,qs )
   rh = qv/qs

   call map_ll_to_point(nxdir,nydir,npts,x3=tca_in, y2=y2 )
   call flip_vert_index_2D (y2, nl,tca)
   call map_ll_to_point(nxdir,nydir,npts,x3=cca_in, y2=y2 )
   call flip_vert_index_2D (y2, nl,cca)
   call map_ll_to_point(nxdir,nydir,npts,x3=lsliq_in, y2=y2      )
   call flip_vert_index_2D (y2, nl,mr_lsliq )
   call map_ll_to_point(nxdir,nydir,npts,x3=lsice_in, y2=y2      )
   call flip_vert_index_2D (y2, nl,mr_lsice)
   call map_ll_to_point(nxdir,nydir,npts,x3=ccliq_in, y2=y2      )
   call flip_vert_index_2D (y2, nl,mr_ccliq)
   call map_ll_to_point(nxdir,nydir,npts,x3=ccice_in, y2=y2      )
   call flip_vert_index_2D (y2, nl,mr_ccice)
   call map_ll_to_point(nxdir,nydir,npts,x3=fl_lsrain_in, y2=y2       )
   call flip_vert_index_2D (y2, nl,fl_lsrain)
   call map_ll_to_point(nxdir,nydir,npts,x3=fl_lssnow_in, y2=y2       )
   call flip_vert_index_2D (y2, nl,fl_lssnow)
   call map_ll_to_point(nxdir,nydir,npts,x3=fl_lsgrpl_in, y2=y2       )
   call flip_vert_index_2D (y2, nl,fl_lsgrpl)
   call map_ll_to_point(nxdir,nydir,npts,x3=fl_ccrain_in, y2=y2       )
   call flip_vert_index_2D (y2, nl,fl_ccrain)
   call map_ll_to_point(nxdir,nydir,npts,x3=fl_ccsnow_in, y2=y2       )
   call flip_vert_index_2D (y2, nl,fl_ccsnow)


   call map_ll_to_point(nxdir,nydir,npts,x3=reff_lsclliq_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_lscliq ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_lsclice_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_lscice ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_lsprliq_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_lsrain ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_lsprice_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_lssnow ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_ccclliq_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_cvcliq ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_ccclice_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_cvcice ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_ccprliq_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_cvrain ))
   call map_ll_to_point(nxdir,nydir,npts,x3=reff_ccprice_in,  &
                                                  y2=y2   )
   call flip_vert_index_2D (y2, nl,reff(:,:,i_cvsnow ))

   reff(:,:,i_lsgrpl) = 0.0

!---------------------------------------------------------------------
!   the values of tau and lwem are passed in for each stochastic column.
!   here grid box mean values are obtained for the convective and
!   large-scale components
!---------------------------------------------------------------------

   do k=1, size(tau_stoch_in,3)
     do j=1, size(tau_stoch_in,2)
       do i=1, size(tau_stoch_in,1)
         ctr_s = 0
         ctr_c = 0
         sum_s1 = 0.
         sum_c1 = 0.
         sum_s2 = 0.
         sum_c2 = 0.
         do n=1, size(tau_stoch_in,4)
           if (stoch_cloud_type_in(i,j,k,n) == 1. ) then 
             ctr_s = ctr_s + 1
             sum_s1 = sum_s1 +  tau_stoch_in(i,j,k,n)
             sum_s2 = sum_s2 +  lwem_stoch_in(i,j,k,n)
           else if(stoch_cloud_type_in(i,j,k,n) == 2. ) then 
             ctr_c = ctr_c + 1
             sum_c1 = sum_c1 +  tau_stoch_in(i,j,k,n)
             sum_c2 = sum_c2 +  lwem_stoch_in(i,j,k,n)
           endif
         end do
         if (ctr_s > 0) then
           tau_s_in(i,j,k) = sum_s1/ctr_s
           lwem_s_in(i,j,k) = sum_s2/ctr_s
         else
           tau_s_in(i,j,k) = 0.             
           lwem_s_in(i,j,k) = 0.               
         endif
         if (ctr_c > 0) then
           tau_c_in(i,j,k) = sum_c1/ctr_c
           lwem_c_in(i,j,k) = sum_c2/ctr_c
         else
           tau_c_in(i,j,k) = 0.             
           lwem_c_in(i,j,k) = 0.               
         endif
       end do
     end do
   end do
       
   call map_ll_to_point(nxdir,nydir,npts,x3=tau_s_in(:,:,:), y2=y2)
   call flip_vert_index_2D (y2, nl,dtau_s )

   call map_ll_to_point(nxdir,nydir,npts,x3=tau_c_in(:,:,:), y2=y2)
   call flip_vert_index_2D (y2, nl,dtau_c )

   call map_ll_to_point(nxdir,nydir,npts,x3=lwem_s_in(:,:,:), y2=y2)
   call flip_vert_index_2D (y2, nl,dem_s)

   call map_ll_to_point(nxdir,nydir,npts,x3=lwem_c_in(:,:,:), y2=y2)
   call flip_vert_index_2D (y2, nl,dem_c)

!----------------------------------------------------------------------
!    stoch_cloud_type is not flipped here; it will be used in subroutine
!    cosp where it is needed with index 1 being TOA. however the
!    column and vertical indices do need to be reversed.
!----------------------------------------------------------------------
   call map_ll_to_point(nxdir,nydir,npts,  &
                        x4=stoch_cloud_type_in(:,:,:,:), y3=y3        )
   do j=1,nl
     do i=1,Ncolumns
       cloud_type(:,i,j) = y3 (:,j,i)
     end do
   end do
   
!---------------------------------------------------------------------
!   COSP takes a single, spacially independent value for surface
!   emissivity. it may be supplied via namelist.
!---------------------------------------------------------------------
!  emsfc_lw = emsfc_lw_nml

!--------------------------------------------------------------------
!   variable mode indicates that the grid (i,j) => (lon,lat)
!--------------------------------------------------------------------
!  mode = 2
      
!-------------------------------------------------------------------


end subroutine produce_cosp_input_fields
    
!#####################################################################

subroutine flip_vert_index_2D (in, dim,out)
  real,dimension(:,:), intent(in) :: in
  integer, intent(in)   :: dim
  real,dimension(:,:), intent(out) :: out

  integer k, kinv

  do k=1,dim
    kinv = dim - k +1
    out(:,k) = in(:,kinv)
  end do
  
end subroutine flip_vert_index_2D



!#####################################################################

subroutine flip_vert_index_3D (in, dim,out)
  real,dimension(:,:,:), intent(in) :: in
  integer, intent(in)   :: dim
  real,dimension(:,:,:), intent(out) :: out

  integer k, kinv

  do k=1,dim
    kinv = dim - k +1
    out(:,:,k) = in(:,:,kinv)
  end do
  
end subroutine flip_vert_index_3D

!#####################################################################

subroutine flip_vert_index_4D (in, dim,out)
  real,dimension(:,:,:,:), intent(in) :: in
  integer, intent(in)   :: dim
  real,dimension(:,:,:,:), intent(out) :: out

  integer k, kinv

  do k=1,dim
    kinv = dim - k +1
    out(:,:,:,k) = in(:,:,:,kinv)
  end do
  
end subroutine flip_vert_index_4D


!####################################################################


subroutine read_cloudsat_orbit

!------------------------------------------------------------------------
!    subroutine read_cloudsat_orbit reads a netcdf file containing the
!    orbital position of the satellites as a function of time.
!------------------------------------------------------------------------

      real*4, dimension(:), allocatable    :: lat_in, lon_in
      integer*2, dimension(:), allocatable :: year_in
      byte, dimension(:), allocatable      ::  mon_in
      byte, dimension(:), allocatable      :: day_in, hour_in
      byte, dimension(:), allocatable      :: min_in
      real*4, dimension(:), allocatable    :: sec_in
      integer, dimension(:), allocatable   :: int_year_in
      integer, dimension(:), allocatable   ::  int_mon_in
      integer, dimension(:), allocatable   :: int_day_in, int_hour_in
      integer, dimension(:), allocatable   :: int_min_in
      real*8, dimension(:,:), allocatable  :: lat_out, lon_out

      character (len = *), parameter :: LAT_NAME  = "lat"
      character (len = *), parameter :: LON_NAME  = "lon"
      character (len = *), parameter :: YEAR_NAME = "year"
      character (len = *), parameter ::  MON_NAME = "month"
      character (len = *), parameter ::  DAY_NAME = "day"
      character (len = *), parameter :: HOUR_NAME = "hour"
      character (len = *), parameter ::  MIN_NAME = "minute"
      character (len = *), parameter ::  SEC_NAME = "second"

      integer          :: lat_varid, lon_varid, year_varid, day_varid,  &
                          mon_varid, hour_varid, min_varid, sec_varid
      integer          :: ncid
      integer          :: nlocs
      integer (kind=4) :: rcode, recdim
      type(time_type)  :: Time
      integer          :: k, mm, ptctr, n, ll, j, i
      integer          :: yeara, montha, daya, houra, minutea, seconda
      integer          :: yearb, monthb, dayb, hourb, minuteb, secondb
      integer          :: is, ie, js, je
      real             :: UNSET = -500.
      integer          :: calendar, nstart
      logical          :: used
      integer          :: ndims, nvars, ngatts
      integer          :: ndsize
      character*31     :: dummy
   
!------------------------------------------------------------------------
!    open the netcdf file. 
!------------------------------------------------------------------------
      ncid = ncopn (orbital_filename,   0, rcode)

!------------------------------------------------------------------------
!    determine number of dimensions (ndims); current file has 
!    only 1 ("location")
!------------------------------------------------------------------------
      call ncinq (ncid, ndims, nvars, ngatts, recdim, rcode)

!------------------------------------------------------------------------
!    determine value of the location dimension (nlocs) to use to dimension
!    arrays allocated below.
!------------------------------------------------------------------------
      do n=1,ndims
        call ncdinq(ncid, n, dummy, ndsize, rcode)
        if (trim(dummy) == 'location') then
          nlocs = ndsize
        endif
      end do

!------------------------------------------------------------------------
!    allocate arrays to hold the data read from the file.
!------------------------------------------------------------------------
      allocate (lat_in(nlocs), lon_in(nlocs), year_in(nlocs),  &
                mon_in(nlocs), day_in(nlocs), hour_in(nlocs),  &
                min_in(nlocs), sec_in(nlocs), int_year_in(nlocs), &
                int_mon_in(nlocs), int_day_in(nlocs), int_hour_in(nlocs), &
                int_min_in(nlocs) )
      allocate (lat_out(num_sat_periods, max_sdgs_per_sat_period), &
                lon_out(num_sat_periods, max_sdgs_per_sat_period) )
 
!------------------------------------------------------------------------
!    obtain the var_ids for the needed variables.
!------------------------------------------------------------------------

      lat_varid = ncvid(ncid, LAT_NAME , rcode)
      lon_varid = ncvid(ncid, LON_NAME , rcode)
      year_varid = ncvid(ncid, YEAR_NAME , rcode)
      mon_varid = ncvid(ncid, MON_NAME , rcode)
      day_varid = ncvid(ncid, DAY_NAME , rcode)
      hour_varid = ncvid(ncid, HOUR_NAME , rcode)
      min_varid = ncvid(ncid, MIN_NAME , rcode)
      sec_varid = ncvid(ncid, SEC_NAME , rcode)

!------------------------------------------------------------------------
!    read the netcdf data.
!------------------------------------------------------------------------
      call ncvgt (ncid, lat_varid, 1, nlocs, lat_in, rcode)
      call ncvgt (ncid, lon_varid, 1, nlocs, lon_in, rcode)
      call ncvgt (ncid, year_varid, 1, nlocs, year_in, rcode)
      call ncvgt (ncid, mon_varid, 1, nlocs, mon_in, rcode)
      call ncvgt (ncid, day_varid, 1, nlocs, day_in, rcode)
      call ncvgt (ncid, hour_varid, 1, nlocs, hour_in, rcode)
      call ncvgt (ncid, min_varid, 1, nlocs, min_in, rcode)
      call ncvgt (ncid, sec_varid, 1, nlocs, sec_in, rcode)

      call ncclos (ncid, rcode)

!------------------------------------------------------------------------
!    convert non-integer fields to integers.
!------------------------------------------------------------------------
      int_year_in = year_in
      int_mon_in = mon_in
      int_day_in = day_in
      int_hour_in = hour_in
      int_min_in = min_in

!------------------------------------------------------------------------
!    convert longitude to lie between 0 --> 360, rather than -180 --> 180.
!------------------------------------------------------------------------
      do  mm=1, size(lon_in)
        if (lon_in(mm) < 0.) then
          lon_in(mm) = lon_in(mm) + 360.
        endif
      end do

!------------------------------------------------------------------------
!    define the start and end of each time period for which the satellite 
!    orbital curtain data is desired. it is centered on sat_begin_time from
!    the cosp_input namelist.
!------------------------------------------------------------------------
      Time_start(1) = set_date (sat_begin_time(1), sat_begin_time(2),  &
                                sat_begin_time(3), sat_begin_time(4),  &
                                sat_begin_time(5), sat_begin_time(6))  - &
                                                   set_time(sat_period/2,0)
      Time_end(1) = Time_start(1) + set_time(sat_period, 0)

      do mm = 2,num_sat_periods 
        Time_start(mm) = Time_start(mm-1) + set_time(sat_period, 0)      
        Time_end  (mm) = Time_end  (mm-1) + set_time(sat_period, 0)      
      end do

!------------------------------------------------------------------------
!    initialize output variables.
!------------------------------------------------------------------------
      lat_out = UNSET
      lon_out = UNSET
      flag_array = 0.
      lflag_array = .false.
      location = 0.

!------------------------------------------------------------------------
!    define the latitudes/longitudes coordinates over which the satellite 
!    passes during each of the requested model sampling periods.
!------------------------------------------------------------------------
      calendar = get_calendar_type()

      nstart = 1
      do k=1,num_sat_periods      
        ptctr = 0
        do n=nstart, nlocs
          if (calendar == NOLEAP) then
!------------------------------------------------------------------------
!    ignore 2/29 when using the noleap calendar
!------------------------------------------------------------------------
            if (int_mon_in(n) == 2 .and. int_day_in(n) == 29) cycle
          endif

!-------------------------------------------------------------------------
!    determine if satellite observation time n is in any of the requested 
!    sampling periods. if it is before the first sampling period, cycle. 
!    if it is within sampling period k, increment the counter of obser-
!    vation times ptctr and enter the satellite location in the output 
!    arrays as the ptctr occurrence for sampling period k. if the sampling 
!    period has ended, exit the loop.
!-------------------------------------------------------------------------
          Time = set_date(int_year_in(n), int_mon_in(n), int_day_in(n), &
                          int_hour_in(n), int_min_in(n), INT(sec_in(n)))
          if (Time < Time_start(k)) then
            cycle
          else if (Time > Time_start(k) .and. Time <= Time_end(k)) then
            ptctr = ptctr + 1
            if (ptctr >= max_sdgs_per_sat_period) then
              call error_mesg ('cosp_driver:read_cloudsat_orbit', &
                    ' Need to increase &cosp_input variable &
                                       &max_sdgs_per_sat_period', FATAL)
            endif
            lat_out(k, ptctr) = lat_in(n)
            lon_out(k,ptctr) = lon_in(n)
          else if (Time > Time_end(k))  then

!-------------------------------------------------------------------------
!    reset starting index into observations for next sampling period.
!-------------------------------------------------------------------------
            nstart = n - 1
            exit
          endif
        end do  ! n

!-------------------------------------------------------------------------
!    reset counter for next sampling period.
!-------------------------------------------------------------------------
        ptctr = 0
      end do   ! k

!-------------------------------------------------------------------------
!    call get_local_indexes2 to map the latitudes/longitudes seen by the 
!    satellite during sampling period k to the closest model grid  point 
!    (is,js). set a logical to indicate that grid point (is,js) is seen 
!    during time period k. 
!-------------------------------------------------------------------------
      do k=1,num_sat_periods   
        do ll = 1,max_sdgs_per_sat_period
          if (lat_out(k,ll) == UNSET .and. lon_out(k,ll) == UNSET) exit
          call get_local_indexes2(lat_out(k,ll),lon_out(k,ll), is,js)
          if (is /= 0 .and. js /= 0 .and. is <= imax .and. js <= jmax) then
            lflag_array(is,js,k) = .true.
            location(is,js,k) = ll
          endif
        end do

!-------------------------------------------------------------------------
!     collect sampling frequency diagnostic, if desired.
!-------------------------------------------------------------------------
        if (id_sampling_sat > 0) then
          call get_date(Time_end(k), yearb, monthb, dayb, hourb,    &
                                                         minuteb, secondb)
          do j=1,jmax
            do i=1,imax
              if (lflag_array(i,j,k)) then
                flag_array(i,j,monthb) = flag_array(i,j,monthb) + 1.
              endif
            end do
          end do
        endif
      end do

!-------------------------------------------------------------------------
!    define additional flag arrays for other diagnostics.
!-------------------------------------------------------------------------
      do k=1,PARASOL_NREFL
        lflag_array_parasol(:,:,k,:) = lflag_array(:,:,:)
      end do
      do k=1,nlr
        lflag_array_temp(:,:,k,:) = lflag_array(:,:,:)
      end do
   
!-------------------------------------------------------------------------
!    output the satellite sampling frequency at each point for each
!    month of the year for which data is requested.
!-------------------------------------------------------------------------
      used = send_data (id_sampling_sat, flag_array,   &
                                             is_in=1, js_in=1, ks_in=1) 

!-------------------------------------------------------------------------
!    output the satellite location index for each sampling period
!    for which data is requested.
!-------------------------------------------------------------------------
      used = send_data (id_location_sat, location,   &
                          is_in=1, js_in=1, ks_in=1, mask = location > 0.) 

!-----------------------------------------------------------------------
!    deallocate local variables.
!-----------------------------------------------------------------------
      deallocate (lat_in, lon_in, year_in, mon_in,&
                  day_in, hour_in, min_in, sec_in,&
                  int_year_in, int_mon_in, int_day_in, &
                  int_hour_in, int_min_in, lat_out, lon_out )

end subroutine read_cloudsat_orbit


!END PROGRAM COSPTEST
end module cosp_driver_mod





!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
 
! $Id: cosp_io.F90,v 1.1.2.1.8.1.4.1 2011/12/12 19:30:45 Peter.Phillipps Exp $
! $Name:  $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2008 - A. Bodas-Salcedo - Initial version
! Oct 2008 - S. Bony - In nc_write_cosp_1d and nc_write_cosp_2d :
!                      the label of layered cloud fractions was wrong -> corrected
!                      (before: low was actually mid, mid was high, high was total,
!                      total was low)
! Sep 2009 - A. Bodas-Salcedo - CMIP5 variable names implemented
!
 
#include "cosp_defs.h"
MODULE MOD_COSP_IO
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
! USE cmor_users_functions
  USE netcdf
  use MOD_COSP_Modis_Simulator
  use mpp_mod, only: input_nml_file
  use fms_mod, only: open_namelist_file, open_file, close_file,   &
                     file_exist, mpp_pe, mpp_root_pe,   &
                     error_mesg, FATAL, &
                     check_nml_error, write_version_number, stdlog
  
  IMPLICIT NONE
!  INCLUDE 'netcdf.inc'
  
!---------------------------------------------------------------------
!----------- version number for this module --------------------------     
character(len=128)  :: versiona =  '$Id: cosp_io.F90,v 1.1.2.1.8.1.4.1 2011/12/12 19:30:45 Peter.Phillipps Exp $'
character(len=128)  :: tagnamea =  '$Name:  $'

  ! Types to be used as arrays of pointers
  TYPE var1d
     character(len=16) :: name
     character(len=16) :: units
     integer :: dimsid(3)
     integer :: dimssz(2)
     real,pointer,dimension(:) :: pntr
  END TYPE
  TYPE var2d
     character(len=16) :: name
     character(len=16) :: units
     integer :: dimsid(4)
     integer :: dimssz(3)
     real,pointer,dimension(:,:) :: pntr
  END TYPE
  TYPE var3d
     character(len=16) :: name
     character(len=16) :: units
     integer :: dimsid(5)
     integer :: dimssz(4)
     real,pointer,dimension(:,:,:) :: pntr
  END TYPE
CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE CONSTRUCT_VAR1D --------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_VAR1D(name,dimsid,dimssz,pntr,y,units)
     ! Input arguments
     character(len=*),intent(in) :: name
     integer,intent(in) :: dimsid(3)
     integer,intent(in) :: dimssz(2)
     real,dimension(:),target,intent(in) :: pntr
     type(var1d),intent(out) :: y
     character(len=*),optional,intent(in) :: units
     
     y%name =  name
     if (present(units)) y%units   =  units
     y%dimsid =  dimsid
     y%dimssz =  dimssz
     y%pntr => pntr
  
  END SUBROUTINE CONSTRUCT_VAR1D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE CONSTRUCT_VAR2D --------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_VAR2D(name,dimsid,dimssz,pntr,y,units)
     ! Input arguments
     character(len=*),intent(in) :: name
     integer,intent(in) :: dimsid(4)
     integer,intent(in) :: dimssz(3)
     real,dimension(:,:),target,intent(in) :: pntr
     type(var2d),intent(out) :: y
     character(len=*),optional,intent(in) :: units
     
     y%name =  name
     if (present(units)) y%units   =  units
     y%dimsid =  dimsid
     y%dimssz =  dimssz
     y%pntr => pntr
  
  END SUBROUTINE CONSTRUCT_VAR2D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE CONSTRUCT_VAR3D --------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_VAR3D(name,dimsid,dimssz,pntr,y,units)
     ! Input arguments
     character(len=*),intent(in) :: name
     integer,intent(in) :: dimsid(5)
     integer,intent(in) :: dimssz(4)
     real,dimension(:,:,:),target,intent(in) :: pntr
     type(var3d),intent(out) :: y
     character(len=*),optional,intent(in) :: units
     
     y%name =  name
     if (present(units)) y%units   =  units
     y%dimsid =  dimsid
     y%dimssz =  dimssz
     y%pntr => pntr
  
  END SUBROUTINE CONSTRUCT_VAR3D

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE MAP_POINT_TO_LL---------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE MAP_POINT_TO_LL(Nx,Ny,geomode,x1,x2,x3,x4,y2,y3,y4,y5)
     ! Input arguments
     integer,intent(in) :: Nx,Ny,geomode
     real,intent(in),optional :: x1(:),x2(:,:),x3(:,:,:), &
                                 x4(:,:,:,:)
     real,intent(out),optional :: y2(:,:),y3(:,:,:), &
                                  y4(:,:,:,:),y5(:,:,:,:,:)
     ! Local variables
     integer :: Npoints
     integer :: px(Nx*Ny),py(Nx*Ny)
     integer :: i,j,k,l,m
     integer :: Ni,Nj,Nk,Nl
     integer :: Mi,Mj,Mk,Ml,Mm
     character(len=128) :: proname='MAP_POINT_TO_LL'

     Npoints = Nx*Ny
     
     px=0
     py=0
     ! Obtain pointers to do the mapping
     if (geomode == 2) then ! (lon,lat) mode
      do j=1,Ny
        do i=1,Nx
            k = (j-1)*Nx+i
            px(k) = i  
            py(k) = j  
        enddo
      enddo
     else if (geomode == 3) then ! (lon,lat) mode
      do j=1,Nx
        do i=1,Ny
            k = (j-1)*Ny+i
            px(k) = j
            py(k) = i  
        enddo
      enddo
     else
       call error_mesg ('cosp_io:map_point_to_ll',  &
                    ' -- '//trim(proname)//': geomode not supported, ', &
                                                            FATAL)
     endif

     if (present(x1).and.present(y2)) then
        Ni = size(x1,1)
        Mi = size(y2,1)
        Mj = size(y2,2)
        if (Mi*Mj /= Ni) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
           ' -- '//trim(proname)//': Nlon*Nlat /= Npoints (opt 1)', &
                                                            FATAL)
        endif
        do i=1,Npoints
          y2(px(i),py(i)) = x1(i)
        enddo
     else if (present(x2).and.present(y3)) then
        Ni = size(x2,1)
        Nj = size(x2,2)
        Mi = size(y3,1)
        Mj = size(y3,2)
        Mk = size(y3,3)
        if (Mi*Mj /= Ni) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
           ' -- '//trim(proname)//': Nlon*Nlat /= Npoints (opt 2)', &
                                                            FATAL)
        endif
        if (Nj /= Mk) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
           ' -- '//trim(proname)//': Nj /= Mk (opt 2)', &
                                                            FATAL)
        endif
        do k=1,Mk
         do i=1,Npoints
            y3(px(i),py(i),k) = x2(i,k)
         enddo
        enddo
     else if (present(x3).and.present(y4)) then
        Ni = size(x3,1)
        Nj = size(x3,2)
        Nk = size(x3,3)
        Mi = size(y4,1)
        Mj = size(y4,2)
        Mk = size(y4,3)
        Ml = size(y4,4)
        if (Mi*Mj /= Ni) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
           ' -- '//trim(proname)//': Nlon*Nlat /= Npoints (opt 3)', &
                                                            FATAL)

        endif
        if (Nj /= Mk) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
           ' -- '//trim(proname)//': Nj /= Mk (opt 3)', &
                                                            FATAL)
        endif
        if (Nk /= Ml) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
                   ' -- '//trim(proname)//': Nk /= Ml (opt 3)', &
                                                            FATAL)
        endif
        do l=1,Ml
         do k=1,Mk
          do i=1,Npoints
            y4(px(i),py(i),k,l) = x3(i,k,l)
          enddo
         enddo
        enddo
     else if (present(x4).and.present(y5)) then
        Ni = size(x4,1)
        Nj = size(x4,2)
        Nk = size(x4,3)
        Nl = size(x4,4)
        Mi = size(y5,1)
        Mj = size(y5,2)
        Mk = size(y5,3)
        Ml = size(y5,4)
        Mm = size(y5,5)
        if (Mi*Mj /= Ni) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
                 ' -- '//trim(proname)//': Nlon*Nlat /= Npoints (opt 4)', &
                                                            FATAL)
        endif
        if (Nj /= Mk) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
                   ' -- '//trim(proname)//': Nj /= Mk (opt 4)', &
                                                            FATAL)
        endif
        if (Nk /= Ml) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
                   ' -- '//trim(proname)//': Nk /= Ml (opt 4)', &
                                                            FATAL)
        endif
        if (Nl /= Mm) then
          call error_mesg ('cosp_io:map_point_to_ll',  &
                   ' -- '//trim(proname)//': Nl /= Mm (opt 4)', &
                                                            FATAL)
        endif
        do m=1,Mm
         do l=1,Ml
          do k=1,Mk
            do i=1,Npoints
                y5(px(i),py(i),k,l,m) = x4(i,k,l,m)
            enddo
          enddo
         enddo
        enddo
     else
        call error_mesg ('cosp_io:map_point_to_ll',  &
                 ' -- '//trim(proname)//': wrong option', &
                                                            FATAL)
     endif

     
  END SUBROUTINE MAP_POINT_TO_LL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE MAP_LL_TO_POINT---------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE MAP_LL_TO_POINT(Nx,Ny,Np,x2,x3,x4,x5,y1,y2,y3,y4)
     ! Input arguments
     integer,intent(in) :: Nx,Ny,Np
     real,intent(in),optional :: x2(:,:),x3(:,:,:), &
                                 x4(:,:,:,:),x5(:,:,:,:,:)
     real,intent(out),optional :: y1(:),y2(:,:),y3(:,:,:), &
                                 y4(:,:,:,:)
     ! Local variables
     integer :: px(Nx*Ny),py(Nx*Ny)
     integer :: i,j,k,l,m
     integer :: Ni,Nj,Nk,Nl,Nm
     integer :: Mi,Mj,Mk,Ml
     character(len=128) :: proname='MAP_LL_TO_POINT'
     
     px=0
     py=0
     if (Nx*Ny < Np) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                ' -- '//trim(proname)//': Nx*Ny < Np', &
                                                            FATAL)
     endif
     do j=1,Ny
       do i=1,Nx
          k = (j-1)*Nx+i
          px(k) = i  
          py(k) = j  
       enddo
     enddo
     
     if (present(x2).and.present(y1)) then
        Ni = size(x2,1)
        Nj = size(x2,2)
        Mi = size(y1,1)
        if (Ni*Nj < Mi) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                ' -- '//trim(proname)//': Nlon*Nlat < Npoints (opt 1)', &
                                                            FATAL)
        endif
        do j=1,Np
          y1(j) = x2(px(j),py(j))
        enddo
     else if (present(x3).and.present(y2)) then
        Ni = size(x3,1)
        Nj = size(x3,2)
        Nk = size(x3,3)
        Mi = size(y2,1)
        Mj = size(y2,2)
        if (Ni*Nj < Mi) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
              ' -- '//trim(proname)//': Nlon*Nlat < Npoints (opt 2)', &
                                                            FATAL)
        endif
        if (Nk /= Mj) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                   ' -- '//trim(proname)//': Nk /= Mj (opt 2)', &
                                                            FATAL)
        endif
        do k=1,Nk
          do j=1,Np
            y2(j,k) = x3(px(j),py(j),k)
          enddo
        enddo
     else if (present(x4).and.present(y3)) then
        Ni = size(x4,1)
        Nj = size(x4,2)
        Nk = size(x4,3)
        Nl = size(x4,4)
        Mi = size(y3,1)
        Mj = size(y3,2)
        Mk = size(y3,3)
        if (Ni*Nj < Mi) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
              ' -- '//trim(proname)//': Nlon*Nlat < Npoints (opt 3)', &
                                                            FATAL)
        endif
        if (Nk /= Mj) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                   ' -- '//trim(proname)//': Nk /= Mj (opt 3)', &
                                                            FATAL)
        endif
        if (Nl /= Mk) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                   ' -- '//trim(proname)//': Nl /= Mk (opt 3)', &
                                                            FATAL)
        endif
        do l=1,Nl
         do k=1,Nk
          do j=1,Np
            y3(j,k,l) = x4(px(j),py(j),k,l)
          enddo
         enddo
        enddo
     else if (present(x5).and.present(y4)) then
        Ni = size(x5,1)
        Nj = size(x5,2)
        Nk = size(x5,3)
        Nl = size(x5,4)
        Nm = size(x5,5)
        Mi = size(y4,1)
        Mj = size(y4,2)
        Mk = size(y4,3)
        Ml = size(y4,4)
        if (Ni*Nj < Mi) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
               ' -- '//trim(proname)//': Nlon*Nlat < Npoints (opt 4)', &
                                                            FATAL)
        endif
        if (Nk /= Mj) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                   ' -- '//trim(proname)//': Nk /= Mj (opt 4)', &
                                                            FATAL)
        endif
        if (Nl /= Mk) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                   ' -- '//trim(proname)//': Nl /= Mk (opt 4)', &
                                                            FATAL)
        endif
        if (Nm /= Ml) then
        call error_mesg ('cosp_io:map_ll_to_point',  &
                   ' -- '//trim(proname)//': Nm /= Ml (opt 4)', &
                                                            FATAL)
        endif
        do m=1,Nm
         do l=1,Nl
          do k=1,Nk
           do j=1,Np
            y4(j,k,l,m) = x5(px(j),py(j),k,l,m)
           enddo
          enddo
         enddo
        enddo
     else
        call error_mesg ('cosp_io:map_ll_to_point',  &
                 ' -- '//trim(proname)//': wrong option', &
                                                            FATAL)
     endif
  
  END SUBROUTINE MAP_LL_TO_POINT
  
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE NC_READ_INPUT_FILE -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE NC_READ_INPUT_FILE(fname,Npnts,Nl,Nhydro,lon,lat,p,ph,z,zh,T,qv,rh,tca,cca, &
            mr_lsliq,mr_lsice,mr_ccliq,mr_ccice,fl_lsrain,fl_lssnow,fl_lsgrpl, &
            fl_ccrain,fl_ccsnow,Reff,dtau_s,dtau_c,dem_s,dem_c,skt,landmask,sfc_height, &
            mr_ozone,u_wind,v_wind,emsfc_lw,mode,Nlon,Nlat)
    
    !Arguments
    character(len=512),intent(in) :: fname ! File name
    integer,intent(in) :: Npnts,Nl,Nhydro
    real,dimension(Npnts),intent(out) :: lon,lat
    real,dimension(Npnts,Nl),target,intent(out) :: p,ph,z,zh,T,qv,rh,tca,cca, &
                  mr_lsliq,mr_lsice,mr_ccliq,mr_ccice,fl_lsrain,fl_lssnow,fl_lsgrpl, &
                  fl_ccrain,fl_ccsnow,dtau_s,dtau_c,dem_s,dem_c,mr_ozone
    real,dimension(Npnts,Nl,Nhydro),intent(out) :: Reff
    real,dimension(Npnts),intent(out) :: skt,landmask,sfc_height,u_wind,v_wind
    real,intent(out) :: emsfc_lw
    integer,intent(out) :: mode,Nlon,Nlat
    
        
    !Local variables
    integer :: Npoints,Nlevels,i,j,k
    character(len=128) :: vname
    integer,parameter :: NMAX_DIM=5
    integer :: vrank,vdimid(NMAX_DIM)
    character(len=256) :: dimname(NMAX_DIM) ! 256 hardcoded, instead of MAXNCNAM. This works for NetCDF 3 and 4.
    integer :: ncid,vid,ndims,nvars,ngatts,recdim,dimsize(NMAX_DIM)
    integer :: errst
    logical :: Llat,Llon,Lpoint
    integer :: Na,Nb,Nc,Nd,Ne
    real,dimension(Npnts) :: ll
    integer,dimension(:),allocatable :: plon,plat
    real,allocatable :: x1(:),x2(:,:),x3(:,:,:),x4(:,:,:,:),x5(:,:,:,:,:) ! Temporary arrays
    
    mode = 0
    Nlon = 0
    Nlat = 0
    
    Npoints = Npnts
    Nlevels = Nl
    
    ! Open file
    errst = nf90_open(fname, nf90_nowrite, ncid)
    
    ! Get information about dimensions. Curtain mode or lat/lon mode?
    Llat  =.false.
    Llon  =.false.
    Lpoint=.false.
    errst = nf90_inquire(ncid, ndims, nvars, ngatts, recdim)
    if (errst /= 0) then
        call error_mesg ('cosp_io:nc_read_input_file',  &
                ' --- NC_READ_INPUT_FILE: error in  nf90_inquire', &
                                                            FATAL)
    endif
    do i = 1,ndims
       errst = nf90_Inquire_Dimension(ncid,i,name=dimname(i),len=dimsize(i))
       if (errst /= 0) then
        print *, 'nf90 error, i=', i
        call error_mesg ('cosp_io:nc_read_input_file',  &
                   ' --- NC_READ_INPUT_FILE: error in nf90_Inquire_Dimension ',  &
                                                            FATAL)
       endif
       if ((trim(dimname(i)).eq.'level').and.(Nlevels > dimsize(i))) then
        call error_mesg ('cosp_io:nc_read_input_file',  &
                 ' --- NC_READ_INPUT_FILE: number of levels selected is greater than in input file '//trim(fname), &
                                                            FATAL)
       endif
       if (trim(dimname(i)).eq.'point') then
         Lpoint = .true.
         if (Npnts > dimsize(i)) then
        call error_mesg ('cosp_io:nc_read_input_file',  &
                   ' --- NC_READ_INPUT_FILE: number of points selected is greater than in input file '//trim(fname), &
                                                            FATAL)
         endif
       endif
       if (trim(dimname(i)).eq.'lon') then
         Llon = .true.
         Nlon = dimsize(i)
       endif
       if (trim(dimname(i)).eq.'lat') then
         Llat = .true.
         Nlat = dimsize(i)
       endif
    enddo

    ! Get lon and lat
    if (Llon.and.Llat) then ! 2D mode
        if ((Npnts) > Nlon*Nlat) Npoints=Nlon*Nlat
        lon = R_UNDEF
        lat = R_UNDEF
        mode = 2 ! Don't know yet if (lon,lat) or (lat,lon) at this point
    else if (Lpoint) then ! 1D mode
        Nlon = Npoints
        Nlat = Npoints
        mode = 1
    else
        call error_mesg ('cosp_io:nc_read_input_file',  &
                 ' -- NC_READ_INPUT_FILE: '//trim(fname)//' file contains wrong dimensions', &
                                                            FATAL)
    endif
    errst = nf90_inq_varid(ncid, 'lon', vid)
    errst = nf90_get_var(ncid, vid, lon, start = (/1/), count = (/Nlon/))
    errst = nf90_inq_varid(ncid, 'lat', vid)
    errst = nf90_get_var(ncid, vid, lat, start = (/1/), count = (/Nlat/))
    
    ! Get all variables
    do vid = 1,nvars
       vdimid=0
       errst = nf90_Inquire_Variable(ncid, vid, name=vname, ndims=vrank, dimids=vdimid)
       if (errst /= 0) then
        print *, 'vid, errst = ', vid, errst
        call error_mesg ('cosp_io:nc_read_input_file',  &
                 ' --- NC_READ_INPUT_FILE: error reading ', &
                                                            FATAL)
       endif
       ! Read in into temporary array of correct shape
       print *, 'Reading '//trim(vname)//' ...'
       if (vrank == 1) then
          Na = dimsize(vdimid(1))
          allocate(x1(Na))
          errst = nf90_get_var(ncid, vid, x1, start=(/1/), count=(/Na/))
       endif
       if (vrank == 2) then
          Na = dimsize(vdimid(1))
          Nb = dimsize(vdimid(2))
          allocate(x2(Na,Nb))
          errst = nf90_get_var(ncid, vid, x2, start=(/1,1/), count=(/Na,Nb/))
       endif
       if (vrank == 3) then
          Na = dimsize(vdimid(1))
          Nb = dimsize(vdimid(2))
          Nc = dimsize(vdimid(3))
          allocate(x3(Na,Nb,Nc))
          errst = nf90_get_var(ncid, vid, x3, start=(/1,1,1/), count=(/Na,Nb,Nc/))
          if ((mode == 2).or.(mode == 3)) then
            if ((Na == Nlon).and.(Nb == Nlat)) then
              mode = 2
            else if ((Na == Nlat).and.(Nb == Nlon)) then
              mode = 3
            else
        call error_mesg ('cosp_io:nc_read_input_file',  &
                       '  -- NC_READ_INPUT_FILE: wrong mode for variable '//trim(vname), &
                                                            FATAL)
            endif
          endif
       endif
       if (vrank == 4) then
          Na = dimsize(vdimid(1))
          Nb = dimsize(vdimid(2))
          Nc = dimsize(vdimid(3))
          Nd = dimsize(vdimid(4))
          allocate(x4(Na,Nb,Nc,Nd))
          errst = nf90_get_var(ncid, vid, x4, start=(/1,1,1,1/), count=(/Na,Nb,Nc,Nd/))
       endif
       if (vrank == 5) then
          Na = dimsize(vdimid(1))
          Nb = dimsize(vdimid(2))
          Nc = dimsize(vdimid(3))
          Nd = dimsize(vdimid(4))
          Ne = dimsize(vdimid(5))
          allocate(x5(Na,Nb,Nc,Nd,Ne))
          errst = nf90_get_var(ncid, vid, x5, start=(/1,1,1,1,1/), count=(/Na,Nb,Nc,Nd,Ne/))
       endif
       ! Map to the right input argument
       select case (trim(vname))
       case ('pfull')
         if (Lpoint) then
           p(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=p)
         endif
       case ('phalf')
         if (Lpoint) then
           ph(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=ph)
         endif
       case ('height')
         if (Lpoint) then
           z(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=z)
         endif
       case ('height_half')
         if (Lpoint) then
           zh(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=zh)
         endif
       case ('T_abs')
         if (Lpoint) then
           T(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=T)
         endif
       case ('qv')
         if (Lpoint) then
           qv(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=qv)
         endif
       case ('rh')
         if (Lpoint) then
           rh(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=rh)
         endif
       case ('tca')
         if (Lpoint) then
           tca(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=tca)
         endif
         tca = tca
       case ('cca')
         if (Lpoint) then
           cca(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=cca)
         endif
         cca = cca
       case ('mr_lsliq')
         if (Lpoint) then
           mr_lsliq(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_lsliq)
         endif
       case ('mr_lsice')
         if (Lpoint) then
           mr_lsice(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_lsice)
         endif
       case ('mr_ccliq')
         if (Lpoint) then
           mr_ccliq(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_ccliq)
         endif
       case ('mr_ccice')
         if (Lpoint) then
           mr_ccice(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_ccice)
         endif
       case ('fl_lsrain')
         if (Lpoint) then
           fl_lsrain(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_lsrain)
         endif
       case ('fl_lssnow')
         if (Lpoint) then
           fl_lssnow(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_lssnow)
         endif
       case ('fl_lsgrpl')
         if (Lpoint) then
           fl_lsgrpl(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_lsgrpl)
         endif
       case ('fl_ccrain')
         if (Lpoint) then
           fl_ccrain(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_ccrain)
         endif
       case ('fl_ccsnow')
         if (Lpoint) then
           fl_ccsnow(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_ccsnow)
         endif
       case ('dtau_s')
         if (Lpoint) then
           dtau_s(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dtau_s)
         endif
       case ('dtau_c')
         if (Lpoint) then
           dtau_c(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dtau_c)
         endif
       case ('dem_s')
         if (Lpoint) then
           dem_s(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dem_s)
         endif
       case ('dem_c')
         if (Lpoint) then
           dem_c(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dem_c)
         endif
       case ('Reff')
         if (Lpoint) then
           Reff(1:Npoints,:,:) = x3(1:Npoints,1:Nlevels,:)
         else
           call map_ll_to_point(Na,Nb,Npoints,x4=x4,y3=Reff)
         endif
       case ('skt')
         if (Lpoint) then
           skt(1:Npoints) = x1(1:Npoints)
         else
           call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=skt)
         endif
       case ('landmask')
         if (Lpoint) then
           landmask(1:Npoints) = x1(1:Npoints)
         else
           call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=landmask)
         endif
       case ('orography')
         if (Lpoint) then
           sfc_height(1:Npoints) = x1(1:Npoints)
         else
           call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=sfc_height)
         endif
       case ('mr_ozone')
         if (Lpoint) then
           mr_ozone(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
         else
           call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_ozone)
         endif
       case ('u_wind')
         if (Lpoint) then
           u_wind(1:Npoints) = x1(1:Npoints)
         else
           call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=u_wind)
         endif
       case ('v_wind')
         if (Lpoint) then
           v_wind(1:Npoints) = x1(1:Npoints)
         else
           call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=v_wind)
         endif
       end select
!        select case (trim(vname))
!        case ('pfull')
!          if (Lpoint) then
!            p(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=p)
!          endif
!        case ('phalf')
!          if (Lpoint) then
!            ph(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=ph)
!          endif
!        case ('zfull')
!          if (Lpoint) then
!            z(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=z)
!          endif
!        case ('zhalf')
!          if (Lpoint) then
!            zh(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=zh)
!          endif
!        case ('ta')
!          if (Lpoint) then
!            T(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=T)
!          endif
!        case ('hus')
!          if (Lpoint) then
!            qv(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=qv)
!          endif
!        case ('hur')
!          if (Lpoint) then
!            rh(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=rh)
!          endif
!        case ('cl')
!          if (Lpoint) then
!            tca(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=tca)
!          endif
!          tca = tca/100.0
!        case ('clc')
!          if (Lpoint) then
!            cca(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=cca)
!          endif
!          cca = cca/100.0
!        case ('clws')
!          if (Lpoint) then
!            mr_lsliq(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_lsliq)
!          endif
!        case ('clis')
!          if (Lpoint) then
!            mr_lsice(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_lsice)
!          endif
!        case ('clwc')
!          if (Lpoint) then
!            mr_ccliq(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_ccliq)
!          endif
!        case ('clic')
!          if (Lpoint) then
!            mr_ccice(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_ccice)
!          endif
!        case ('prsprof')
!          if (Lpoint) then
!            fl_lsrain(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_lsrain)
!          endif
!        case ('prsns')
!          if (Lpoint) then
!            fl_lssnow(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_lssnow)
!          endif
!        case ('grplprof')
!          if (Lpoint) then
!            fl_lsgrpl(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_lsgrpl)
!          endif
!        case ('prcprof')
!          if (Lpoint) then
!            fl_ccrain(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_ccrain)
!          endif
!        case ('prsnc')
!          if (Lpoint) then
!            fl_ccsnow(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=fl_ccsnow)
!          endif
!        case ('dtaus')
!          if (Lpoint) then
!            dtau_s(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dtau_s)
!          endif
!        case ('dtauc')
!          if (Lpoint) then
!            dtau_c(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dtau_c)
!          endif
!        case ('dems')
!          if (Lpoint) then
!            dem_s(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dem_s)
!          endif
!        case ('demc')
!          if (Lpoint) then
!            dem_c(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=dem_c)
!          endif
!        case ('reff')
!          if (Lpoint) then
!            Reff(1:Npoints,:,:) = x3(1:Npoints,1:Nlevels,:)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x4=x4,y3=Reff)
!          endif
!        case ('ts')
!          if (Lpoint) then
!            skt(1:Npoints) = x1(1:Npoints)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=skt)
!          endif
!        case ('landmask')
!          if (Lpoint) then
!            landmask(1:Npoints) = x1(1:Npoints)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=landmask)
!          endif
!        case ('orog')
!          if (Lpoint) then
!            sfc_height(1:Npoints) = x1(1:Npoints)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=sfc_height)
!          endif
!        case ('mrozone')
!          if (Lpoint) then
!            mr_ozone(1:Npoints,:) = x2(1:Npoints,1:Nlevels)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x3=x3,y2=mr_ozone)
!          endif
!        case ('uas')
!          if (Lpoint) then
!            u_wind(1:Npoints) = x1(1:Npoints)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=u_wind)
!          endif
!        case ('vas')
!          if (Lpoint) then
!            v_wind(1:Npoints) = x1(1:Npoints)
!          else
!            call map_ll_to_point(Na,Nb,Npoints,x2=x2,y1=v_wind)
!          endif
!        end select
       ! Free memory
       if (vrank == 1) deallocate(x1)
       if (vrank == 2) deallocate(x2)
       if (vrank == 3) deallocate(x3)
       if (vrank == 4) deallocate(x4)
       if (vrank == 5) deallocate(x5)
    enddo
       
    ! SFC emissivity
    errst = nf90_inq_varid(ncid, 'emsfclw', vid)
    errst = nf90_get_var(ncid, vid, emsfc_lw)
    
    ! Fill in the lat/lon vectors with the right values for 2D modes
    ! This might be helpful if the inputs are 2D (gridded) and 
    ! you want outputs in 1D mode
    allocate(plon(Npoints),plat(Npoints))
    if (mode == 2) then !(lon,lat)
      ll = lat
      do j=1,Nb
        do i=1,Na
          k = (j-1)*Na + i
          plon(k) = i  
          plat(k) = j
        enddo
      enddo
      lon(1:Npoints) = lon(plon(1:Npoints))
      lat(1:Npoints) = ll(plat(1:Npoints))
    else if (mode == 3) then !(lat,lon)
      ll = lon
      do j=1,Nb
        do i=1,Na
          k = (j-1)*Na + i
          lon(k) = ll(j)
          lat(k) = lat(i)
        enddo
      enddo
      lon(1:Npoints) = ll(plon(1:Npoints))
      lat(1:Npoints) = lat(plat(1:Npoints))
    endif
    deallocate(plon,plat)
    
    ! Close file
!     call ncclos(ncid,errst)
    errst = nf90_close(ncid)

  END SUBROUTINE NC_READ_INPUT_FILE


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------- SUBROUTINE READ_COSP_OUTPUT_NL -------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 SUBROUTINE READ_COSP_OUTPUT_NL(cosp_nl,cfg)
  character(len=*),intent(in) :: cosp_nl
  type(cosp_config),intent(out) :: cfg
  ! Local variables
  integer :: i
  logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfaddbze94, &
             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
             Llongitude,Llatitude,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
             Lfracout,LlidarBetaMol532,Ltbrttov, &
             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
             Liwpmodis,Lclmodis
  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfaddbze94, &
             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp, &
             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp, &
             Lcltisccp,Llongitude,Llatitude,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
             Lfracout,LlidarBetaMol532,Ltbrttov, &
             Lcltmodis,Lclwmodis,Lclimodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
             Liwpmodis,Lclmodis

  integer :: unit, io, ierr, logunit
  
  do i=1,N_OUT_LIST
    cfg%out_list(i)=''
  enddo
! open(10,file=cosp_nl,status='old')
! read(10,nml=cosp_output)
! close(10)
!---------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=cosp_output, iostat=io)
    ierr = check_nml_error(io,"cosp_output")
#else
!---------------------------------------------------------------------
    if ( file_exist('input.nml')) then
      unit =  open_namelist_file ()
      ierr=1; do while (ierr /= 0)
      read  (unit, nml=cosp_output, iostat=io, end=10)
      ierr = check_nml_error(io,'cosp_output')
      enddo
10      call close_file (unit)
    endif
#endif
!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
     call write_version_number (versiona, tagnamea)
     logunit = stdlog()
     if (mpp_pe() == mpp_root_pe() )    &
                        write (logunit, nml=cosp_output)

  
  ! Deal with dependencies
  if (.not.Lradar_sim) then
    Lcfaddbze94   = .false.
    Lclcalipso2    = .false.
    Lcltlidarradar = .false.
    Ldbze94        = .false.
  endif
  if (.not.Llidar_sim) then
    Latb532 = .false.
    LcfadLidarsr532 = .false.
    Lclcalipso2      = .false.
    Lclcalipso       = .false.
    Lclhcalipso      = .false.
    Lcllcalipso      = .false.
    Lclmcalipso      = .false.
    Lcltcalipso      = .false.
    Lcltlidarradar   = .false.
    LparasolRefl    = .false.
    LlidarBetaMol532     = .false.
  endif
  if (.not.Lisccp_sim) then
    Lalbisccp       = .false.
    Lboxptopisccp   = .false.
    Lboxtauisccp    = .false.
    Lclisccp        = .false.
    Lpctisccp       = .false.
    Ltauisccp       = .false.
    Lcltisccp       = .false.
    Lmeantbisccp    = .false.
    Lmeantbclrisccp = .false.
  endif
  if (.not.Lmisr_sim) then
    LclMISR = .false.
  endif
  if (.not.Lrttov_sim) then
    Ltbrttov = .false.
  endif
  if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. &
      (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then
    Lfracout = .false.
  endif
  if (.not.Lmodis_sim) then
    Lcltmodis=.false.
    Lclwmodis=.false.
    Lclimodis=.false.
    Lclhmodis=.false.
    Lclmmodis=.false.
    Lcllmodis=.false.
    Ltautmodis=.false.
    Ltauwmodis=.false.
    Ltauimodis=.false.
    Ltautlogmodis=.false.
    Ltauwlogmodis=.false.
    Ltauilogmodis=.false.
    Lreffclwmodis=.false.
    Lreffclimodis=.false.
    Lpctmodis=.false.
    Llwpmodis=.false.
    Liwpmodis=.false.
    Lclmodis=.false.
  endif
  if (Lmodis_sim) Lisccp_sim = .true.
  
  ! Diagnostics that use Radar and Lidar
  if (((Lclcalipso2).or.(Lcltlidarradar)).and.((Lradar_sim).or.(Llidar_sim))) then
    Lclcalipso2    = .true.
    Lcltlidarradar = .true.
    Llidar_sim     = .true.
    Lradar_sim     = .true.
  endif
  
  cfg%Lstats = .false.
  if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) cfg%Lstats = .true.
  
  ! Copy instrument flags to cfg structure
  cfg%Lradar_sim = Lradar_sim
  cfg%Llidar_sim = Llidar_sim
  cfg%Lisccp_sim = Lisccp_sim
  cfg%Lmodis_sim = Lmodis_sim
  cfg%Lmisr_sim  = Lmisr_sim
  cfg%Lrttov_sim = Lrttov_sim
  
  ! Flag to control output to file
  cfg%Lwrite_output = .false.
  if (cfg%Lstats.or.cfg%Lmisr_sim.or.cfg%Lrttov_sim) then
    cfg%Lwrite_output = .true.
  endif
  
  ! Output diagnostics
  i = 1
  if (Lalbisccp)        cfg%out_list(i) = 'albisccp'
  i = i+1
  if (Latb532)          cfg%out_list(i) = 'atb532'
  i = i+1
  if (Lboxptopisccp)    cfg%out_list(i) = 'boxptopisccp'
  i = i+1
  if (Lboxtauisccp)     cfg%out_list(i) = 'boxtauisccp'
  i = i+1
  if (Lcfaddbze94)     cfg%out_list(i) = 'cfaddbze94'
  i = i+1
  if (LcfadLidarsr532) cfg%out_list(i) = 'cfadLidarsr532'
  i = i+1
  if (Lclcalipso2)      cfg%out_list(i) = 'clcalipso2'
  i = i+1
  if (Lclcalipso)       cfg%out_list(i) = 'clcalipso'
  i = i+1
  if (Lclhcalipso)      cfg%out_list(i) = 'clhcalipso'
  i = i+1
  if (Lclisccp)        cfg%out_list(i) = 'clisccp'
  i = i+1
  if (Lcllcalipso)      cfg%out_list(i) = 'cllcalipso'
  i = i+1
  if (Lclmcalipso)      cfg%out_list(i) = 'clmcalipso'
  i = i+1
  if (Lcltcalipso)      cfg%out_list(i) = 'cltcalipso'
  i = i+1
  if (Lcltlidarradar)   cfg%out_list(i) = 'cltlidarradar'
  i = i+1
  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
  i = i+1
  if (Ldbze94)          cfg%out_list(i) = 'dbze94'
  i = i+1
  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
  i = i+1
  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
  i = i+1
  if (Llongitude)       cfg%out_list(i) = 'lon'
  i = i+1
  if (Llatitude)        cfg%out_list(i) = 'lat'
  i = i+1
  if (LparasolRefl)    cfg%out_list(i) = 'parasolRefl'
  i = i+1
  if (LclMISR)          cfg%out_list(i) = 'clMISR'
  i = i+1
  if (Lmeantbisccp)     cfg%out_list(i) = 'meantbisccp'
  i = i+1
  if (Lmeantbclrisccp)  cfg%out_list(i) = 'meantbclrisccp'
  i = i+1
  if (Lfracout)        cfg%out_list(i) = 'fracout'
  i = i+1
  if (LlidarBetaMol532)     cfg%out_list(i) = 'lidarBbetaMol532'
  i = i+1
  if (Ltbrttov)         cfg%out_list(i) = 'tbrttov'
  i = i+1
  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
  i = i+1
  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
  i = i+1
  if (Lclimodis)        cfg%out_list(i) = 'climodis'
  i = i+1
  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
  i = i+1
  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
  i = i+1
  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
  i = i+1
  if (Ltautmodis)       cfg%out_list(i) = 'tautmodis'
  i = i+1
  if (Ltauwmodis)       cfg%out_list(i) = 'tauwmodis'
  i = i+1
  if (Ltauimodis)       cfg%out_list(i) = 'tauimodis'
  i = i+1
  if (Ltautlogmodis)    cfg%out_list(i) = 'tautlogmodis'
  i = i+1
  if (Ltauwlogmodis)    cfg%out_list(i) = 'tauwlogmodis'
  i = i+1
  if (Ltauilogmodis)    cfg%out_list(i) = 'tauilogmodis'
  i = i+1
  if (Lreffclwmodis)    cfg%out_list(i) = 'reffclwmodis'
  i = i+1
  if (Lreffclimodis)    cfg%out_list(i) = 'reffclimodis'
  i = i+1
  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
  i = i+1
  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
  i = i+1
  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
  i = i+1
  if (Lclmodis)         cfg%out_list(i) = 'clmodis'

  if (i /= N_OUT_LIST) then
        call error_mesg ('cosp_io:read_cosp_output_nl',  &
              'COSP_IO: wrong number of output diagnostics', &
                                                            FATAL)
  endif

  ! Copy diagnostic flags to cfg structure
  ! ISCCP simulator
  cfg%Lalbisccp = Lalbisccp
  cfg%Latb532 = Latb532
  cfg%Lboxptopisccp = Lboxptopisccp
  cfg%Lboxtauisccp = Lboxtauisccp
  cfg%Lmeantbisccp = Lmeantbisccp
  cfg%Lmeantbclrisccp = Lmeantbclrisccp
  cfg%Lclisccp = Lclisccp
  cfg%Lpctisccp = Lpctisccp
  cfg%Ltauisccp = Ltauisccp
  cfg%Lcltisccp = Lcltisccp
  ! CloudSat simulator
  cfg%Ldbze94 = Ldbze94
  cfg%Lcfaddbze94 = Lcfaddbze94
  ! CALIPSO/PARASOL simulator  
  cfg%LcfadLidarsr532 = LcfadLidarsr532
  cfg%Lclcalipso2 = Lclcalipso2
  cfg%Lclcalipso = Lclcalipso
  cfg%Lclhcalipso = Lclhcalipso
  cfg%Lcllcalipso = Lcllcalipso
  cfg%Lclmcalipso = Lclmcalipso
  cfg%Lcltcalipso = Lcltcalipso
  cfg%Lcltlidarradar = Lcltlidarradar
  cfg%LparasolRefl = LparasolRefl
  ! MISR simulator  
  cfg%LclMISR = LclMISR
  ! Other
  cfg%Llongitude = Llongitude
  cfg%Llatitude = Llatitude
  cfg%Lfracout = Lfracout
  cfg%LlidarBetaMol532 = LlidarBetaMol532
  ! RTTOV
  cfg%Ltbrttov = Ltbrttov
  ! MODIS simulator  
  cfg%Lcltmodis=Lcltmodis
  cfg%Lclwmodis=Lclwmodis
  cfg%Lclimodis=Lclimodis
  cfg%Lclhmodis=Lclhmodis
  cfg%Lclmmodis=Lclmmodis
  cfg%Lcllmodis=Lcllmodis
  cfg%Ltautmodis=Ltautmodis
  cfg%Ltauwmodis=Ltauwmodis
  cfg%Ltauimodis=Ltauimodis
  cfg%Ltautlogmodis=Ltautlogmodis
  cfg%Ltauwlogmodis=Ltauwlogmodis
  cfg%Ltauilogmodis=Ltauilogmodis
  cfg%Lreffclwmodis=Lreffclwmodis
  cfg%Lreffclimodis=Lreffclimodis
  cfg%Lpctmodis=Lpctmodis
  cfg%Llwpmodis=Llwpmodis
  cfg%Liwpmodis=Liwpmodis
  cfg%Lclmodis=Lclmodis
 END SUBROUTINE READ_COSP_OUTPUT_NL
   
END MODULE MOD_COSP_IO



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp_isccp_simulator.f90,v 1.1.2.1.4.1.6.1 2010/03/04 08:23:34 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

MODULE MOD_COSP_ISCCP_SIMULATOR
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y)
  
  ! Arguments
  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
  type(cosp_isccp),intent(inout) :: y   ! ISCCP simulator output
  
  ! Local variables 
  integer :: i,Nlevels,Npoints
  real :: pfull(gbx%Npoints, gbx%Nlevels)
  real :: phalf(gbx%Npoints, gbx%Nlevels + 1)
  real :: qv(gbx%Npoints, gbx%Nlevels)
  real :: cc(gbx%Npoints, gbx%Nlevels)
  real :: conv(gbx%Npoints, gbx%Nlevels)
  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
  real :: at(gbx%Npoints, gbx%Nlevels)
  real :: dem_s(gbx%Npoints, gbx%Nlevels)
  real :: dem_c(gbx%Npoints, gbx%Nlevels)
  real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
  integer :: sunlit(gbx%Npoints)
  real :: dum1    (gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
  real :: dum2    (gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
  
  Nlevels = gbx%Nlevels
  Npoints = gbx%Npoints
  ! Flip inputs. Levels from TOA to surface
  pfull  = gbx%p(:,Nlevels:1:-1) 
  phalf(:,1)         = 0.0 ! Top level
  phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1)
  qv     = gbx%sh(:,Nlevels:1:-1) 
  cc     = 0.999999*gbx%tca(:,Nlevels:1:-1) 
  conv   = 0.999999*gbx%cca(:,Nlevels:1:-1) 
  dtau_s = gbx%dtau_s(:,Nlevels:1:-1) 
  dtau_c = gbx%dtau_c(:,Nlevels:1:-1) 
  at     = gbx%T(:,Nlevels:1:-1) 
  dem_s  = gbx%dem_s(:,Nlevels:1:-1) 
  dem_c  = gbx%dem_c(:,Nlevels:1:-1) 
  frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
  sunlit = int(gbx%sunlit)

  if (sgx%cols_input_from_model) then
    call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, &
            pfull,phalf,qv,cc,conv,dtau_s,dtau_c, &
            gbx%isccp_top_height,gbx%isccp_top_height_direction, &
            gbx%isccp_overlap,frac_out, &
            gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, &
            y%meanptop,y%meantaucld,y%meanalbedocld, &
            y%meantb,y%meantbclr,y%boxtau,y%boxptop, &
             sgx%dtau_col, sgx%dem_col, .true.)
  else
    call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, &
            pfull,phalf,qv,cc,conv,dtau_s,dtau_c, &
            gbx%isccp_top_height,gbx%isccp_top_height_direction, &
            gbx%isccp_overlap,frac_out, &
            gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, &
            y%meanptop,y%meantaucld,y%meanalbedocld, &
            y%meantb,y%meantbclr,y%boxtau,y%boxptop, &
            dum1, dum2, .false.)
  endif

  ! Flip outputs. Levels from surface to TOA
  ! --- (npoints,tau=7,pressure=7)
  y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1)
     
  
  ! Check if there is any value slightly greater than 1
  where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5))
    y%totalcldarea = 1.0
  endwhere
              
END SUBROUTINE COSP_ISCCP_SIMULATOR

END MODULE MOD_COSP_ISCCP_SIMULATOR


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
 
! $Id: cosp_lidar.f90,v 1.1.2.1.4.1.6.1 2010/03/04 08:23:34 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2007 - A. Bodas-Salcedo - Initial version
! Oct 2008 - S. Bony          - Instructions "Call for large-scale cloud" removed  -> sgx%frac_out is used instead.
!                               Call lidar_simulator changed (lsca, gbx%cca and depol removed; 
!                               frac_out changed in sgx%frac_out)
!
! 
MODULE MOD_COSP_LIDAR
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------- SUBROUTINE COSP_LIDAR ------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y)
  
  ! Arguments
  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
  type(cosp_sglidar),intent(inout) :: y ! Subgrid output
  
  ! Local variables 
  integer :: i
  real :: presf(sgx%Npoints, sgx%Nlevels + 1)
  real :: frac_out(sgx%Npoints, sgx%Nlevels)
  real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci
  real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot
  real,dimension(sgx%Npoints, PARASOL_NREFL)  :: refle
  
  
  presf(:,1:sgx%Nlevels) = gbx%ph
  presf(:,sgx%Nlevels + 1) = 0.0
  lsca = gbx%tca-gbx%cca
  do i=1,sgx%Ncolumns
      ! Temporary arrays for simulator call
      mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ)
      mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE)
      mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ)
      mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE)
     if (sgx%cols_input_from_model) then
      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4 &
                 , PARASOL_NREFL, LIDAR_UNDEF  &
                 , gbx%p, presf, gbx%T &
                 , mr_ll, mr_li, mr_cl, mr_ci &
                 , sghydro%Reff(:,i,:,I_LSCLIQ),  &
                   sghydro%Reff(:,i,:,I_LSCICE), &
                   sghydro%Reff(:,i, :,I_CVCLIQ), &
                   sghydro%Reff(:,i,:,I_CVCICE) &
                 , sgx%frac_out, gbx%lidar_ice_type,  &
                   y%beta_mol, beta_tot, tau_tot  &
                 , refle ) ! reflectance
     else
      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4 &
                 , PARASOL_NREFL, LIDAR_UNDEF  &
                 , gbx%p, presf, gbx%T &
                 , mr_ll, mr_li, mr_cl, mr_ci &
                 , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE), gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
                 , sgx%frac_out, gbx%lidar_ice_type, y%beta_mol, beta_tot, tau_tot  &
                 , refle ) ! reflectance
     endif
      
      y%beta_tot(:,i,:) = beta_tot(:,:)
      y%tau_tot(:,i,:)  = tau_tot(:,:)
      y%refl(:,i,:)     = refle(:,:)
  enddo

END SUBROUTINE COSP_LIDAR

END MODULE MOD_COSP_LIDAR



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp_misr_simulator.f90,v 1.1.2.1 2009/08/10 10:44:30 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Nov 2008 - A. Bodas-Salcedo - Initial version
!
!

MODULE MOD_COSP_MISR_SIMULATOR
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-------------- SUBROUTINE COSP_MISR_SIMULATOR -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y)
  
  ! Arguments
  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
  type(cosp_misr),intent(inout) :: y    ! MISR simulator output
  
  ! Local variables 
  integer :: i,Nlevels,Npoints
  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
  real :: at(gbx%Npoints, gbx%Nlevels)
  real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
  integer :: sunlit(gbx%Npoints)
  
  real :: zfull(gbx%Npoints, gbx%Nlevels) !  height (in meters) of full model levels (i.e. midpoints)
                                          !  zfull(npoints,1)    is    top level of model
                                          !  zfull(npoints,nlev) is bottom level of model
  real :: phy_t0p1_mean_ztop              ! mean cloud top height(m) of 0.1 tau treshold
  real :: fq_phy_t0p1_TAU_v_CTH(7,16)      
  real :: dum1(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
     
  	
  Nlevels = gbx%Nlevels
  Npoints = gbx%Npoints
  ! Levels from TOA to surface
  zfull  = gbx%zlev(:,Nlevels:1:-1)
  at     = gbx%T(:,Nlevels:1:-1) 
  dtau_s = gbx%dtau_s(:,Nlevels:1:-1) 
  dtau_c = gbx%dtau_c(:,Nlevels:1:-1) 
  frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
  sunlit = int(gbx%sunlit)
 
 if (sgx%cols_input_from_model) then
  call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,&
                     sunlit,zfull,at,dtau_s,dtau_c,frac_out, &
                     y%fq_MISR,y%MISR_dist_model_layertops,  &
                     y%MISR_meanztop,y%MISR_cldarea,   &
                     sgx%dtau_col, .true.)
 else
  call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,&
                     sunlit,zfull,at,dtau_s,dtau_c,frac_out, &
                     y%fq_MISR,y%MISR_dist_model_layertops,  &
                     y%MISR_meanztop,y%MISR_cldarea,   &
                     dum1, .false.)
 endif
            
END SUBROUTINE COSP_MISR_SIMULATOR

END MODULE MOD_COSP_MISR_SIMULATOR


      
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
 
! $Id: cosp_modis_simulator.f90,v 1.1.2.1.8.1 2010/05/26 17:18:32 wfc Exp $
! $Name: hiram_20101115_bw $

! (c) 2009, Regents of the Unversity of Colorado
!   Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!

!
! History:
!   May 2009 - Robert Pincus - Initial version
!   Dec 2009 - Robert Pincus - Tiny revisions
!
MODULE MOD_COSP_Modis_Simulator
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  use mod_modis_sim, numModisTauBins      => numTauHistogramBins,      &
                     numModisPressureBins => numPressureHistogramBins, &
                     MODIS_TAU      => nominalTauHistogramCenters,     &
                     MODIS_TAU_BNDS => nominalTauHistogramBoundaries,  &
                     MODIS_PC       => nominalPressureHistogramCenters, &
                     MODIS_PC_BNDS  => nominalPressureHistogramBoundaries                     
  implicit none
  !------------------------------------------------------------------------------------------------
  ! Public type
  !
  ! Summary statistics from MODIS retrievals
  type COSP_MODIS
     ! Dimensions
     integer :: Npoints   ! Number of gridpoints
     integer :: Ncolumns  ! Number of columns
     
     !
     ! Grid means; dimension nPoints
     ! 
     real, dimension(:),       pointer :: & 
       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
       Optical_Thickness_Total_LogMean, Optical_Thickness_Water_LogMean, Optical_Thickness_Ice_LogMean, &
                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
       Cloud_Top_Pressure_Total_Mean,                                                                   &
                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean
     !  Subcolumn particle sizes, optical thickness and cloud top pressure
     !  dimensions (npoints, ncolumns)
     real, dimension(:,:),       pointer :: &
       Column_Particle_Size, Column_Optical_Thickness, &
       Column_Cloud_Top_Pressure, &
       retrievedPhase
     !
     ! Also need the ISCCP-type optical thickness/cloud top pressure histogram
     !
     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_Cloud_Top_Pressure
  end type COSP_MODIS 
  
contains
  !------------------------------------------------------------------------------------------------
  subroutine COSP_Modis_Simulator(gridBox, subCols, subcolHydro, isccpSim, nSunlit, modisSim)
    ! Arguments
    type(cosp_gridbox), intent(in   ) :: gridBox     ! Gridbox info
    type(cosp_subgrid), intent(in   ) :: subCols     ! subCol indicators of convective/stratiform 
    type(cosp_sghydro), intent(in   ) :: subcolHydro ! subcol hydrometeor contens
    type(cosp_isccp),   intent(in   ) :: isccpSim    ! ISCCP simulator output
    integer,            intent(in   ) :: nSunlit     ! Are there any sunlit points? 
    type(cosp_modis),   intent(  out) :: modisSim    ! MODIS simulator subcol output
    
    ! ------------------------------------------------------------
    ! Local variables 
    !   Leave space only for sunlit points
    
    integer :: nPoints, nSubCols, nLevels, i, j
    
    ! Grid-mean quanties;  dimensions nPoints, nLevels
    real, &
      dimension(nSunlit,                  gridBox%nLevels) :: &
        temperature, pressureLayers
    real, &
      dimension(nSunlit,                  gridBox%nLevels + 1) :: &
        pressureLevels
    
    ! Subcol quantities, dimension nPoints, nSubCols, nLevels 
    real, &
      dimension(nSunlit, subCols%nColumns, gridBox%nLevels) :: & 
        opticalThickness, cloudWater, cloudIce, waterSize, iceSize, &
        liquid_opticalThickness, ice_opticalThickness
    
    ! Vertically-integrated subcol quantities; dimensions nPoints, nSubcols 
    integer, &
      dimension(nSunlit, subCols%nColumns) :: & 
        retrievedPhase
    real, &
      dimension(nSunlit, subCols%nColumns) :: & 
        isccpTau, isccpCloudTopPressure, retrievedCloudTopPressure, retrievedTau, retrievedSize  
    
    ! Vertically-integrated results
    real, dimension(nSunlit) :: & 
        cfTotal, cfLiquid, cfIce,                &
        cfHigh,  cfMid,    cfLow,                &
        meanTauTotal, meanTauLiquid, meanTauIce, &
        meanLogTauTotal, meanLogTauLiquid, meanLogTauIce , &
        meanSizeLiquid, meanSizeIce,             &
        meanCloudTopPressure,                    &
        meanLiquidWaterPath, meanIceWaterPath
        
    real, dimension(nSunlit, numModisTauBins, numModisPressureBins) :: & 
       jointHistogram
    
    integer, dimension(nSunlit) :: sunlit
!    integer, dimension(count(gridBox%sunlit(:) <= 0)) :: notSunlit
    integer, dimension(:), allocatable :: notSunlit
    ! ------------------------------------------------------------
    
    !
    ! Are there any sunlit points? 
    !
    allocate(notSunlit(count(gridBox%sunlit(:) <= 0)))

!    nSunlit = count(gridBox%sunlit(:) > 0)
    if(nSunlit > 0) then 
      nLevels  = gridBox%Nlevels
      nPoints  = gridBox%Npoints
      nSubCols = subCols%Ncolumns
      !
      ! This is a vector index indicating which points are sunlit
      !
      sunlit(:)    = pack((/ (i, i = 1, nPoints ) /), mask =       gridBox%sunlit(:) > 0)
      notSunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = .not. gridBox%sunlit(:) > 0)
               
      !
      ! Copy needed quantities, reversing vertical order and removing points with no sunlight 
      !
      pressureLevels(:, 1) = 0.0 ! Top of model, following ISCCP sim
      temperature(:, :)     = gridBox%T (sunlit(:), nLevels:1:-1) 
      pressureLayers(:, :)  = gridBox%p (sunlit(:), nLevels:1:-1) 
      pressureLevels(:, 2:) = gridBox%ph(sunlit(:), nLevels:1:-1) 
      
      !
      ! Subcolumn properties - first stratiform cloud...
      ! 
      ! Use stochastic column taus
      opticalThickness(:, :, :) = subCols%dtau_col(sunlit(:),:,:)
      where(subCols%frac_out(sunlit(:), :, :) == I_LSC)
        cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCLIQ)
        waterSize (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_LSCLIQ)
        cloudIce  (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCICE)
        iceSize   (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_LSCICE)
      elsewhere
        cloudWater      (:, :, :) = 0.
        cloudIce        (:, :, :) = 0.
        waterSize       (:, :, :) = 0.
        iceSize         (:, :, :) = 0.
      end where 
      !
      ! .. then add convective cloud 
      !
      where(subCols%frac_out(sunlit(:), :, :) == I_CVC) 
        cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCLIQ)
        waterSize (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_CVCLIQ)
        cloudIce  (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCICE)
        iceSize   (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_CVCICE)
      end where
      !
      ! Reverse vertical order 
      ! Optical thickness need not be reversed when using subcolumn values 
      !
      cloudWater      (:, :, :)  = cloudWater      (:, :, nLevels:1:-1)
      waterSize       (:, :, :)  = waterSize       (:, :, nLevels:1:-1)
      cloudIce        (:, :, :)  = cloudIce        (:, :, nLevels:1:-1)
      iceSize         (:, :, :)  = iceSize         (:, :, nLevels:1:-1)
      
      isccpTau(:, :)              = isccpSim%boxtau (sunlit(:), :)
      isccpCloudTopPressure(:, :) = isccpSim%boxptop(sunlit(:), :)
      
      do i = 1, nSunlit
        call modis_L2_simulator(temperature(i, :), pressureLayers(i, :), pressureLevels(i, :),     &
                                opticalThickness(i, :, :), cloudWater(i, :, :), cloudIce(i, :, :), &
                                waterSize(i, :, :), iceSize(i, :, :),                       &
                                isccpTau(i, :), isccpCloudTopPressure(i, :),                &
                                retrievedPhase(i, :), retrievedCloudTopPressure(i, :),      & 
                                retrievedTau(i, :), retrievedSize(i, :))
      end do
      call modis_L3_simulator(retrievedPhase,              &
                              retrievedCloudTopPressure,   &
                              retrievedTau, retrievedSize, &
                              cfTotal,         cfLiquid,         cfIce,         &
                              cfHigh,          cfMid,            cfLow,         &
                              meanTauTotal,    meanTauLiquid,    meanTauIce,    &
                              meanLogTauTotal, meanLogTauLiquid, meanLogTauIce, &
                                               meanSizeLiquid,   meanSizeIce,   &
                              meanCloudTopPressure,                             &
                                               meanLiquidWaterPath, meanIceWaterPath, &
                              jointHistogram)
      !
      ! Copy results into COSP structure
      !
      modisSim%Cloud_Fraction_Total_Mean(sunlit(:)) = cfTotal(:)
      modisSim%Cloud_Fraction_Water_Mean(sunlit(:)) = cfLiquid
      modisSim%Cloud_Fraction_Ice_Mean  (sunlit(:)) = cfIce
  
      modisSim%Cloud_Fraction_High_Mean(sunlit(:)) = cfHigh
      modisSim%Cloud_Fraction_Mid_Mean (sunlit(:)) = cfMid
      modisSim%Cloud_Fraction_Low_Mean (sunlit(:)) = cfLow

      modisSim%Optical_Thickness_Total_Mean(sunlit(:)) = meanTauTotal
      modisSim%Optical_Thickness_Water_Mean(sunlit(:)) = meanTauLiquid
      modisSim%Optical_Thickness_Ice_Mean  (sunlit(:)) = meanTauIce
  
      modisSim%Optical_Thickness_Total_LogMean(sunlit(:)) = meanLogTauTotal
      modisSim%Optical_Thickness_Water_LogMean(sunlit(:)) = meanLogTauLiquid
      modisSim%Optical_Thickness_Ice_LogMean  (sunlit(:)) = meanLogTauIce
  
      modisSim%Cloud_Particle_Size_Water_Mean(sunlit(:)) = meanSizeLiquid
      modisSim%Cloud_Particle_Size_Ice_Mean  (sunlit(:)) = meanSizeIce
  
      modisSim%Cloud_Top_Pressure_Total_Mean(sunlit(:)) = meanCloudTopPressure
  
      modisSim%Liquid_Water_Path_Mean(sunlit(:)) = meanLiquidWaterPath
      modisSim%Ice_Water_Path_Mean   (sunlit(:)) = meanIceWaterPath
      
      modisSim%Column_Particle_Size(sunlit(:),:) = RetrievedSize(:,:)
      modisSim%retrievedPhase      (sunlit(:),:) = RetrievedPhase(:,:)
      modisSim%Column_Optical_Thickness(sunlit(:),:) = RetrievedTau(:,:)
      modisSim%Column_Cloud_Top_Pressure(sunlit(:),:) = RetrievedCloudTopPressure(:,:)

      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(sunlit(:), :, :) = jointHistogram(:, :, :)
      ! 
      ! Reorder pressure bins in joint histogram to go from surface to TOA 
      !
      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = &
        modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, numModisPressureBins:1:-1)
      if(nSunlit < nPoints) then 
        !
        ! Where it's night and we haven't done the retrievals the values are undefined
        !
        modisSim%Cloud_Fraction_Total_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Cloud_Fraction_Water_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Cloud_Fraction_Ice_Mean  (notSunlit(:)) = R_UNDEF
    
        modisSim%Cloud_Fraction_High_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Cloud_Fraction_Mid_Mean (notSunlit(:)) = R_UNDEF
        modisSim%Cloud_Fraction_Low_Mean (notSunlit(:)) = R_UNDEF

        modisSim%Optical_Thickness_Total_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Optical_Thickness_Water_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Optical_Thickness_Ice_Mean  (notSunlit(:)) = R_UNDEF
    
        modisSim%Optical_Thickness_Total_LogMean(notSunlit(:)) = R_UNDEF
        modisSim%Optical_Thickness_Water_LogMean(notSunlit(:)) = R_UNDEF
        modisSim%Optical_Thickness_Ice_LogMean  (notSunlit(:)) = R_UNDEF
    
        modisSim%Cloud_Particle_Size_Water_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Cloud_Particle_Size_Ice_Mean  (notSunlit(:)) = R_UNDEF
    
        modisSim%Cloud_Top_Pressure_Total_Mean(notSunlit(:)) = R_UNDEF
    
        modisSim%Liquid_Water_Path_Mean(notSunlit(:)) = R_UNDEF
        modisSim%Ice_Water_Path_Mean   (notSunlit(:)) = R_UNDEF
  
       modisSim%Column_Particle_Size(notSunlit(:),:) = R_UNDEF
       modisSim%retrievedPhase(notSunlit(:),:) = R_UNDEF
       modisSim%Column_Optical_Thickness(notSunlit(:),:) = R_UNDEF
       modisSim%Column_Cloud_Top_Pressure(notSunlit(:),:) = R_UNDEF

        modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(notSunlit(:), :, :) = R_UNDEF
      end if 
    else
      !
      ! It's nightime everywhere - everything is undefined
      !
      modisSim%Cloud_Fraction_Total_Mean(:) = R_UNDEF
      modisSim%Cloud_Fraction_Water_Mean(:) = R_UNDEF
      modisSim%Cloud_Fraction_Ice_Mean  (:) = R_UNDEF
  
      modisSim%Cloud_Fraction_High_Mean(:) = R_UNDEF
      modisSim%Cloud_Fraction_Mid_Mean (:) = R_UNDEF
      modisSim%Cloud_Fraction_Low_Mean (:) = R_UNDEF

      modisSim%Optical_Thickness_Total_Mean(:) = R_UNDEF
      modisSim%Optical_Thickness_Water_Mean(:) = R_UNDEF
      modisSim%Optical_Thickness_Ice_Mean  (:) = R_UNDEF
  
      modisSim%Optical_Thickness_Total_LogMean(:) = R_UNDEF
      modisSim%Optical_Thickness_Water_LogMean(:) = R_UNDEF
      modisSim%Optical_Thickness_Ice_LogMean  (:) = R_UNDEF
  
      modisSim%Cloud_Particle_Size_Water_Mean(:) = R_UNDEF
      modisSim%Cloud_Particle_Size_Ice_Mean  (:) = R_UNDEF
  
      modisSim%Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF
  
      modisSim%Liquid_Water_Path_Mean(:) = R_UNDEF
      modisSim%Ice_Water_Path_Mean   (:) = R_UNDEF
  
      modisSim%Column_Particle_Size(:,:) = R_UNDEF
      modisSim%retrievedPhase      (:,:) = R_UNDEF
      modisSim%Column_Optical_Thickness(:,:) = R_UNDEF
      modisSim%Column_Cloud_Top_Pressure(:,:) = R_UNDEF

      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF
    end if 

  end subroutine COSP_Modis_Simulator
  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  !------------- SUBROUTINE CONSTRUCT_COSP_MODIS ------------------
  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_MODIS(cfg, nPoints, nColumns, x)
    type(cosp_config), intent(in)  :: cfg ! Configuration options
    integer,           intent(in)  :: Npoints  ! Number of sampled points
    integer,           intent(in)  :: Ncolumns  ! Number of subgrid columns
    type(cosp_MODIS),  intent(out) :: x
    !
    ! Allocate minumum storage if simulator not used
    !
    if (cfg%LMODIS_sim) then
      x%nPoints  = nPoints
      x%nColumns  = nColumns
    else
      x%Npoints  = 1
      x%Ncolumns  = 1
    endif
    
    ! --- Allocate arrays ---
    allocate(x%Cloud_Fraction_Total_Mean(x%nPoints)) 
    allocate(x%Cloud_Fraction_Water_Mean(x%nPoints)) 
    allocate(x%Cloud_Fraction_Ice_Mean(x%nPoints)) 
    
    allocate(x%Cloud_Fraction_High_Mean(x%nPoints))
    allocate(x%Cloud_Fraction_Mid_Mean(x%nPoints))
    allocate(x%Cloud_Fraction_Low_Mean(x%nPoints))

    allocate(x%Optical_Thickness_Total_Mean(x%nPoints)) 
    allocate(x%Optical_Thickness_Water_Mean(x%nPoints)) 
    allocate(x%Optical_Thickness_Ice_Mean(x%nPoints)) 
    
    allocate(x%Optical_Thickness_Total_LogMean(x%nPoints)) 
    allocate(x%Optical_Thickness_Water_LogMean(x%nPoints)) 
    allocate(x%Optical_Thickness_Ice_LogMean(x%nPoints)) 
    
    allocate(x%Cloud_Particle_Size_Water_Mean(x%nPoints)) 
    allocate(x%Cloud_Particle_Size_Ice_Mean(x%nPoints)) 
    
    allocate(x%Cloud_Top_Pressure_Total_Mean(x%nPoints)) 
    
    allocate(x%Liquid_Water_Path_Mean(x%nPoints)) 
    allocate(x%Ice_Water_Path_Mean(x%nPoints)) 
      
    allocate(x%Column_Particle_Size(x%nPoints,x%nColumns))
    allocate(x%retrievedPhase      (x%nPoints,x%nColumns))
    allocate(x%Column_Optical_Thickness(x%nPoints,x%nColumns))
    allocate(x%Column_Cloud_Top_Pressure(x%nPoints,x%nColumns))

    allocate(x%Optical_Thickness_vs_Cloud_Top_Pressure(nPoints, numModisTauBins, numModisPressureBins))
  END SUBROUTINE CONSTRUCT_COSP_MODIS

  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  !------------- SUBROUTINE FREE_COSP_MODIS -----------------------
  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_MODIS(x)
    type(cosp_MODIS),intent(inout) :: x
    !
    ! Free space used by cosp_modis variable. 
    !
    
    if(associated(x%Cloud_Fraction_Total_Mean)) deallocate(x%Cloud_Fraction_Total_Mean) 
    if(associated(x%Cloud_Fraction_Water_Mean)) deallocate(x%Cloud_Fraction_Water_Mean) 
    if(associated(x%Cloud_Fraction_Ice_Mean  )) deallocate(x%Cloud_Fraction_Ice_Mean) 
    
    if(associated(x%Cloud_Fraction_High_Mean)) deallocate(x%Cloud_Fraction_High_Mean)
    if(associated(x%Cloud_Fraction_Mid_Mean )) deallocate(x%Cloud_Fraction_Mid_Mean)
    if(associated(x%Cloud_Fraction_Low_Mean )) deallocate(x%Cloud_Fraction_Low_Mean)

    if(associated(x%Optical_Thickness_Total_Mean)) deallocate(x%Optical_Thickness_Total_Mean) 
    if(associated(x%Optical_Thickness_Water_Mean)) deallocate(x%Optical_Thickness_Water_Mean) 
    if(associated(x%Optical_Thickness_Ice_Mean  )) deallocate(x%Optical_Thickness_Ice_Mean) 
    
    if(associated(x%Optical_Thickness_Total_LogMean)) deallocate(x%Optical_Thickness_Total_LogMean) 
    if(associated(x%Optical_Thickness_Water_LogMean)) deallocate(x%Optical_Thickness_Water_LogMean) 
    if(associated(x%Optical_Thickness_Ice_LogMean  )) deallocate(x%Optical_Thickness_Ice_LogMean) 
    
    if(associated(x%Cloud_Particle_Size_Water_Mean)) deallocate(x%Cloud_Particle_Size_Water_Mean) 
    if(associated(x%Cloud_Particle_Size_Ice_Mean  )) deallocate(x%Cloud_Particle_Size_Ice_Mean) 
    
    if(associated(x%Cloud_Top_Pressure_Total_Mean )) deallocate(x%Cloud_Top_Pressure_Total_Mean   ) 
    
    if(associated(x%Liquid_Water_Path_Mean)) deallocate(x%Liquid_Water_Path_Mean   ) 
    if(associated(x%Ice_Water_Path_Mean   )) deallocate(x%Ice_Water_Path_Mean   ) 
    
    if(associated(x%Column_Particle_Size  )) deallocate(x%Column_Particle_Size  )
    if(associated(x%retrievedPhase        )) deallocate(x%retrievedPhase )
    if(associated(x%Column_Optical_Thickness)) deallocate(x%Column_Optical_Thickness)
    if(associated(x%Column_Cloud_Top_Pressure)) deallocate(x%Column_Cloud_Top_Pressure  )

    if(associated(x%Optical_Thickness_vs_Cloud_Top_Pressure)) deallocate(x%Optical_Thickness_vs_Cloud_Top_Pressure   ) 
  END SUBROUTINE FREE_COSP_MODIS
  ! -----------------------------------------------------

  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  !------------- SUBROUTINE COSP_MODIS_CPSECTION -----------------
  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE COSP_MODIS_CPSECTION(ix, iy, orig, copy)
    integer, dimension(2), intent(in) :: ix, iy
    type(cosp_modis),      intent(in   ) :: orig
    type(cosp_modis),      intent(  out) :: copy
    !
    ! Copy a set of grid points from one cosp_modis variable to another.
    !   Should test to be sure ix and iy refer to the same number of grid points 
    !
    integer :: orig_start, orig_end, copy_start, copy_end
    
    orig_start = ix(1); orig_end = ix(2)
    copy_start = iy(1); copy_end = iy(2) 
    
    copy%Cloud_Fraction_Total_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Total_Mean(orig_start:orig_end)
    copy%Cloud_Fraction_Water_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Water_Mean(orig_start:orig_end)
    copy%Cloud_Fraction_Ice_Mean  (copy_start:copy_end) = orig%Cloud_Fraction_Ice_Mean  (orig_start:orig_end)
    
    copy%Cloud_Fraction_High_Mean(copy_start:copy_end) = orig%Cloud_Fraction_High_Mean(orig_start:orig_end)
    copy%Cloud_Fraction_Mid_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Mid_Mean (orig_start:orig_end)
    copy%Cloud_Fraction_Low_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Low_Mean (orig_start:orig_end)

    copy%Optical_Thickness_Total_Mean(copy_start:copy_end) = orig%Optical_Thickness_Total_Mean(orig_start:orig_end)
    copy%Optical_Thickness_Water_Mean(copy_start:copy_end) = orig%Optical_Thickness_Water_Mean(orig_start:orig_end)
    copy%Optical_Thickness_Ice_Mean  (copy_start:copy_end) = orig%Optical_Thickness_Ice_Mean  (orig_start:orig_end)
    
    copy%Optical_Thickness_Total_LogMean(copy_start:copy_end) = &
                                                          orig%Optical_Thickness_Total_LogMean(orig_start:orig_end)
    copy%Optical_Thickness_Water_LogMean(copy_start:copy_end) = &
                                                          orig%Optical_Thickness_Water_LogMean(orig_start:orig_end)
    copy%Optical_Thickness_Ice_LogMean  (copy_start:copy_end) = &
                                                          orig%Optical_Thickness_Ice_LogMean  (orig_start:orig_end)

    copy%Cloud_Particle_Size_Water_Mean(copy_start:copy_end) = orig%Cloud_Particle_Size_Water_Mean(orig_start:orig_end)
    copy%Cloud_Particle_Size_Ice_Mean  (copy_start:copy_end) = orig%Cloud_Particle_Size_Ice_Mean  (orig_start:orig_end)

    copy%Cloud_Top_Pressure_Total_Mean(copy_start:copy_end) = orig%Cloud_Top_Pressure_Total_Mean(orig_start:orig_end)
    
    copy%Liquid_Water_Path_Mean(copy_start:copy_end) = orig%Liquid_Water_Path_Mean(orig_start:orig_end)
    copy%Ice_Water_Path_Mean   (copy_start:copy_end) = orig%Ice_Water_Path_Mean  (orig_start:orig_end)
    
    copy%Column_Particle_Size  (copy_start:copy_end,:) = orig%Column_Particle_Size (orig_start:orig_end,:)
    copy%retrievedPhase        (copy_start:copy_end,:) = orig%retrievedPhase       (orig_start:orig_end,:)
    copy%Column_Optical_Thickness  (copy_start:copy_end,:) = orig%Column_Optical_Thickness (orig_start:orig_end,:)
    copy%Column_Cloud_Top_Pressure  (copy_start:copy_end,:) = orig%Column_Cloud_Top_Pressure (orig_start:orig_end,:)

    copy%Optical_Thickness_vs_Cloud_Top_Pressure(copy_start:copy_end, :, :) = &
                          orig%Optical_Thickness_vs_Cloud_Top_Pressure(orig_start:orig_end, :, :)
  END SUBROUTINE COSP_MODIS_CPSECTION
  ! -----------------------------------------------------

END MODULE MOD_COSP_Modis_Simulator


! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Aug 2008 - V. John - Initial version
! Feb 2009 - V. John - Trace gases and max number of profiles
!


#include "cosp_defs.h"
MODULE MOD_COSP_RTTOV_SIMULATOR
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINE COSP_RTTOV_SIMULATOR ---------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_RTTOV_SIMULATOR(gbx,y)
  
  ! Arguments
  type(cosp_gridbox),intent(in)  :: gbx ! Gridbox info
  type(cosp_rttov),intent(inout) :: y   ! RTTOV output
  
  ! some local variables for profile conversions etc.
  real, parameter :: eps    =  0.622
  real, parameter :: Mdry   =  28.966
  real, parameter :: Mo3    =  47.9983
  real, parameter :: Mco2   =  44.0096
  real, parameter :: Mch4   =  16.0426
  real, parameter :: Mn2o   =  44.0129
  real, parameter :: Mco    =  28.0102
  integer, parameter :: MaxLim  =  100
  
  ! Local variables 
  integer :: i,Nlevels,Npoints
  real :: sh(gbx%Npoints, gbx%Nlevels)
  real :: pp(gbx%Npoints, gbx%Nlevels)
  real :: tt(gbx%Npoints, gbx%Nlevels)
  real :: o3(gbx%Npoints, gbx%Nlevels)
  integer :: ichan(gbx%Nchan)

  real :: co2,ch4,n2o,co
  real :: tt_surf(gbx%Npoints) ! 1.5 m T
  real :: sh_surf(gbx%Npoints) ! 1.5 m q 
  integer :: nprof,nloop,rmod,il
  integer :: istart,istop
  
  Nlevels = gbx%Nlevels
  Npoints = gbx%Npoints
  ! Reverting Levels from TOA to surface
  sh  = gbx%sh(:,Nlevels:1:-1) 
  pp  = gbx%p(:,Nlevels:1:-1) / 100.
  tt  = gbx%t(:,Nlevels:1:-1) 
  o3  = gbx%mr_ozone(:,Nlevels:1:-1)
  
  ! FIXME: 1.5 m T and q should be added to input
  tt_surf  =  tt(:, Nlevels)
  sh_surf  =  sh(:, Nlevels)
  
  !Converting Specific Humidity to PPMV
  sh  =  ( sh / ( sh + eps * ( 1. - sh ) ) ) * 1e6

  !Converting Mass mixing ratio of other trace gases to ppmv
  o3   =  ( Mdry / Mo3  ) *     o3  * 1e6
  co2  =  ( Mdry / Mco2 ) * gbx%co2 * 1e6
  ch4  =  ( Mdry / Mch4 ) * gbx%ch4 * 1e6  
  n2o  =  ( Mdry / Mn2o ) * gbx%n2o * 1e6
  co   =  ( Mdry / Mco  ) * gbx%co  * 1e6
!   print *, 'COSP_RTTOV_SIMULATOR: B' 
!   print *, shape(gbx%ichan)
!   print *, shape(gbx%surfem)
!   print *, shape(pp)
!   print *, shape(tt)
!   print *, shape(sh)
!   print *, shape(o3)
!   print *, shape(gbx%sfc_height)
!   print *, shape(gbx%u_wind)
!   print *, shape(gbx%v_wind)
!   print *, shape(gbx%land)
!   print *, shape(y%tbs)
  
  !! RTTOV can handle only about 100 profiles at a time (FIXME: Check this with Roger) 
  !! So we are putting a loop of 100 
  
  nloop  =  Npoints / MaxLim
  rmod   =  MOD( Npoints, MaxLim )
  
  if( rmod .ne. 0 ) then  
     nloop = nloop + 1
  endif
  
  !! looping over MaxLim number of profiles
  do il = 1, nloop
     istart  =  (il - 1) * MaxLim + 1
     istop   =  min(il * MaxLim, Npoints) 
     
     if( ( il .eq. nloop ) .and. ( rmod .ne. 0 ) ) then
        nprof   =  rmod
     else
        nprof   =  MaxLim
     endif
          
#ifdef RTTOV
     call  rttov_multprof(              &
          gbx%Nchan,                    &
          gbx%ichan,                    &
          gbx%surfem,                   &
          nprof,                        &
          gbx%Nlevels,                  &
          gbx%Plat,                     &
          gbx%Sat,                      &
          gbx%Inst,                     &
          gbx%ZenAng,                   &
          pp(istart:istop, :),          &
          tt(istart:istop, :),          &
          sh(istart:istop, :),          &
          o3(istart:istop, :),          &
          co2,                          &
          ch4,                          &
          n2o,                          &
          co,                           &
          gbx%sfc_height(istart:istop), &
          gbx%u_wind(istart:istop),     &
          gbx%v_wind(istart:istop),     &
          gbx%skt(istart:istop),        &
          gbx%psfc(istart:istop)/100.,  &
          tt_surf(istart:istop),        &
          sh_surf(istart:istop),        &
          gbx%land(istart:istop),       &
          gbx%latitude(istart:istop),   &
          y%tbs(istart:istop, :) )
#endif
  enddo
  
END SUBROUTINE COSP_RTTOV_SIMULATOR

END MODULE MOD_COSP_RTTOV_SIMULATOR



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp_simulator.F90,v 1.1.2.1.8.2 2010/09/08 21:21:34 wfc Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2007 - A. Bodas-Salcedo - Initial version
!
!

#include "cosp_defs.h"
MODULE MOD_COSP_SIMULATOR
  USE MOD_COSP_TYPES
  USE MOD_COSP_RADAR
  USE MOD_COSP_LIDAR
  USE MOD_COSP_ISCCP_SIMULATOR
  USE MOD_COSP_MODIS_SIMULATOR
  USE MOD_COSP_MISR_SIMULATOR
#ifdef RTTOV
  USE MOD_COSP_RTTOV_SIMULATOR
#endif
  USE MOD_COSP_STATS
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------------- SUBROUTINE COSP_SIMULATOR ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#ifdef RTTOV
SUBROUTINE COSP_SIMULATOR(me,gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
#else
SUBROUTINE COSP_SIMULATOR(me,gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
#endif

  ! Arguments
  integer, intent(in) :: me
  type(cosp_gridbox),intent(inout) :: gbx      ! Grid-box inputs
  type(cosp_subgrid),intent(in) :: sgx      ! Subgrid inputs
  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
  type(cosp_config),intent(in)  :: cfg      ! Configuration options
  type(cosp_vgrid),intent(in)   :: vgrid    ! Information on vertical grid of stats
  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
  type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator
  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
#ifdef RTTOV
  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
#endif
  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
  ! Local variables
  integer :: i,j,k,nSunlit
  ! ***Timing variables 
  integer :: t0,t1,count_rate,count_max

  do k=1,gbx%Nhydro
  do j=1,gbx%Nlevels
  do i=1,gbx%Npoints
    if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) then
       print *, '%%%% COSP_SIMULATOR: inconsistency in ',i,j,k,' :',gbx%mr_hydro(i,j,k),gbx%Reff(i,j,k)
    endif
  enddo
  enddo
  enddo

  !+++++++++ Radar model ++++++++++  
  if (cfg%Lradar_sim) then
!   call system_clock(t0,count_rate,count_max)
    call cosp_radar(me, gbx,sgx,sghydro,sgradar)
!   call system_clock(t1,count_rate,count_max)
!   print *, '%%%%%%  Radar:', (t1-t0)*1.0/count_rate, ' s'
  endif
  
  !+++++++++ Lidar model ++++++++++
  if (cfg%Llidar_sim) then
!   call system_clock(t0,count_rate,count_max)
    call cosp_lidar(gbx,sgx,sghydro,sglidar)
!   call system_clock(t1,count_rate,count_max)
!   print *, '%%%%%%  Lidar:', (t1-t0)*1.0/count_rate, ' s'
  endif

  
  !+++++++++ ISCCP simulator ++++++++++
  if (cfg%Lisccp_sim) then
!   call system_clock(t0,count_rate,count_max)
    call cosp_isccp_simulator(gbx,sgx,isccp)
!   call system_clock(t1,count_rate,count_max)
!   print *, '%%%%%%  ISCCP:', (t1-t0)*1.0/count_rate, ' s'
  endif
  
  !+++++++++ MISR simulator ++++++++++
  if (cfg%Lmisr_sim) then
!   call system_clock(t0,count_rate,count_max)
    call cosp_misr_simulator(gbx,sgx,misr)
!   call system_clock(t1,count_rate,count_max)
!   print *, '%%%%%%  MISR:', (t1-t0)*1.0/count_rate, ' s'
  endif
  
  !+++++++++ MODIS simulator ++++++++++
  if (cfg%Lmodis_sim) then
    !call system_clock(t0,count_rate,count_max)
    nSunlit = count(gbx%sunlit(:) > 0)
    call cosp_modis_simulator(gbx,sgx,sghydro,isccp, nSunlit, modis)
    !call system_clock(t1,count_rate,count_max)
    !print *, '%%%%%%  MODIS:', (t1-t0)*1.0/count_rate, ' s'
  endif
 
  !+++++++++ RTTOV ++++++++++ 
#ifdef RTTOV 
  if (cfg%Lrttov_sim) then
    !call system_clock(t0,count_rate,count_max) 
    call cosp_rttov_simulator(gbx,rttov)
    !call system_clock(t1,count_rate,count_max) 
    !print *, '%%%%%%  RTTOV:', (t1-t0)*1.0/count_rate, ' s' 
  endif
#endif


  !+++++++++++ Summary statistics +++++++++++
  if (cfg%Lstats) then
    !call system_clock(t0,count_rate,count_max)
    call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar)
    !call system_clock(t1,count_rate,count_max)
    !print *, '%%%%%%  Stats:', (t1-t0)*1.0/count_rate, ' s'
  endif

  !+++++++++++ Change of units after computation of statistics +++++++++++
  ! This avoids using UDUNITS in CMOR
 
!   if (cfg%Latb532) then
!     where((sglidar%beta_tot > 0.0) .and. (sglidar%beta_tot /= R_UNDEF)) 
!         sglidar%beta_tot = log10(sglidar%beta_tot)
!     elsewhere
!         sglidar%beta_tot = R_UNDEF
!     end where
!   endif
 
  ! Cloud fractions from 1 to %
  if (cfg%Lclcalipso) then
    where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0
  endif
  if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then
    where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0
  endif
  if (cfg%Lclcalipso2) then
    where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0
  endif
 
  if (cfg%Lcltisccp) then
     where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0
  endif
  if (cfg%Lclisccp) then
     where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0
  endif

  if (cfg%LclMISR) then
    where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0
  endif

  if (cfg%Lcltlidarradar) then
    where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0
  endif

  if (cfg%Lclmodis) then
    where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = &
                                                      modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0
  endif
  if (cfg%Lcltmodis) then
     where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0
  endif
  if (cfg%Lclwmodis) then
     where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0
  endif
  if (cfg%Lclimodis) then
     where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0
  endif

  if (cfg%Lclhmodis) then
     where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0
  endif
  if (cfg%Lclmmodis) then
     where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0
  endif
  if (cfg%Lcllmodis) then
     where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0
  endif

! Change pressure from hPa to Pa.
  if (cfg%Lboxptopisccp) then
    where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0
  endif
  if (cfg%Lpctisccp) then
    where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0
  endif


END SUBROUTINE COSP_SIMULATOR

END MODULE MOD_COSP_SIMULATOR



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp_stats.f90,v 1.1.2.1.2.1.2.1.6.1 2010/03/04 08:09:16 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2007 - A. Bodas-Salcedo - Initial version
! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid
! Oct 2008 - J.-L. Dufresne   - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns in COSP_STATS
! Oct 2008 - H. Chepfer       - Added PARASOL reflectance arguments
!
! 
MODULE MOD_COSP_STATS
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  USE MOD_LLNL_STATS
  USE MOD_LMD_IPSL_STATS
  IMPLICIT NONE

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------- SUBROUTINE COSP_STATS ------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar)
  
   ! Input arguments
   type(cosp_gridbox),intent(in) :: gbx
   type(cosp_subgrid),intent(in) :: sgx
   type(cosp_config),intent(in)  :: cfg
   type(cosp_sgradar),intent(in) :: sgradar
   type(cosp_sglidar),intent(in) :: sglidar
   type(cosp_vgrid),intent(in)   :: vgrid
   ! Output arguments
   type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar
   type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar 
   
   ! Local variables 
   integer :: Npoints  !# of grid points
   integer :: Nlevels  !# of levels
   integer :: Nhydro   !# of hydrometeors
   integer :: Ncolumns !# of columns
   integer :: Nlr
   logical :: ok_lidar_cfad = .false.
   real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out
   real,dimension(:,:),allocatable :: ph_c,betamol_c
 
   Npoints  = gbx%Npoints
   Nlevels  = gbx%Nlevels
   Nhydro   = gbx%Nhydro
   Ncolumns = gbx%Ncolumns
   Nlr      = vgrid%Nlvgrid
  
   if (cfg%LcfadLidarsr532)  ok_lidar_cfad=.true.

   if (vgrid%use_vgrid) then ! Statistics in a different vertical grid
        allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), &
                 betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), &
                 ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr))
        Ze_out = 0.0
        betatot_out  = 0.0
        betamol_out= 0.0
        betamol_c  = 0.0
        ph_in(:,1,:)  = gbx%ph(:,:)
        ph_out  = 0.0
        ph_c    = 0.0
        !++++++++++++ Radar CFAD ++++++++++++++++
        if (cfg%Lradar_sim) then
            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, &
                                           Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.)
            stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, &
                                        DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH)
        endif
        !++++++++++++ Lidar CFAD ++++++++++++++++
        if (cfg%Llidar_sim) then
            betamol_in(:,1,:) = sglidar%beta_mol(:,:)
            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, &
                                           Nlr,vgrid%zl,vgrid%zu,betamol_out)
            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, &
                                           Nlr,vgrid%zl,vgrid%zu,betatot_out)
            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, &
                                           Nlr,vgrid%zl,vgrid%zu,ph_out)
            ph_c(:,:) = ph_out(:,1,:)
            betamol_c(:,:) = betamol_out(:,1,:)
            ! Stats from lidar_stat_summary
            call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
                            ,betatot_out,betamol_c,sglidar%refl,gbx%land,ph_c &
                            ,LIDAR_UNDEF,ok_lidar_cfad &
                            ,stlidar%cfad_sr,stlidar%srbval &
                            ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
        endif
        !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
        if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
                                    betatot_out,betamol_c,Ze_out, &
                                    stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)   
        ! Deallocate arrays at coarse resolution
        deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c)
   else ! Statistics in model levels
        !++++++++++++ Radar CFAD ++++++++++++++++
        if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, &
                                        DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH)
        !++++++++++++ Lidar CFAD ++++++++++++++++
        ! Stats from lidar_stat_summary
        if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
                        ,sglidar%beta_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph &
                        ,LIDAR_UNDEF,ok_lidar_cfad &
                        ,stlidar%cfad_sr,stlidar%srbval &
                        ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
        !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
        if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
                                    sglidar%beta_tot,sglidar%beta_mol,sgradar%Ze_tot, &
                                    stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)   
   endif
   ! Replace undef
   where (stlidar%cfad_sr   == LIDAR_UNDEF) stlidar%cfad_sr   = R_UNDEF 
   where (stlidar%lidarcld  == LIDAR_UNDEF) stlidar%lidarcld  = R_UNDEF 
   where (stlidar%cldlayer  == LIDAR_UNDEF) stlidar%cldlayer  = R_UNDEF 
   where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF 

END SUBROUTINE COSP_STATS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,M,zl,zu,r,log_units)
   implicit none
   ! Input arguments
   integer,intent(in) :: Npoints  !# of grid points
   integer,intent(in) :: Nlevels  !# of levels
   integer,intent(in) :: Ncolumns !# of columns
   real,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer)
   real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
   integer,intent(in) :: M  !# levels in the new grid
   real,dimension(M),intent(in) :: zl ! Lower boundary of new levels  [m]
   real,dimension(M),intent(in) :: zu ! Upper boundary of new levels  [m]
   logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
   ! Output
   real,dimension(Npoints,Ncolumns,M),intent(out) :: r ! Variable on new grid

   ! Local variables
   integer :: i,j,k
   logical :: lunits
   real :: ws
   real,dimension(Nlevels) :: xl,xu ! Lower and upper boundaries of model grid
   real,dimension(M) :: dz          ! Layer depth
   real,dimension(Nlevels,M) :: w   ! Weights to do the mean at each point
   real,dimension(Ncolumns,Nlevels) :: yp  ! Variable to be changed to a different grid.
                                           ! Local copy at a particular point.
                                           ! This allows for change of units.
   
   lunits=.false.
   if (present(log_units)) lunits=log_units
   
   r = R_UNDEF
   do i=1,Npoints
     ! Vertical grid at that point
     xl = zhalf(i,:)
     xu(1:Nlevels-1) = xl(2:Nlevels)
     xu(Nlevels) = zfull(i,Nlevels) +  zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric
     dz = zu - zl
     yp = y(i,:,:) ! Temporary variable to regrid
     ! Find weights
     w = 0.0
     do k=1,M
       do j=1,Nlevels
         if ((xl(j) < zl(k)).and.(xu(j) > zl(k)).and.(xu(j) <= zu(k))) then
           !xl(j)-----------------xu(j)
           !      zl(k)------------------------------zu(k)
           w(j,k) = xu(j) - zl(k)
         else if ((xl(j) >= zl(k)).and.(xu(j) <= zu(k))) then
           !           xl(j)-----------------xu(j)
           !      zl(k)------------------------------zu(k)
           w(j,k) = xu(j) - xl(j)
         else if ((xl(j) >= zl(k)).and.(xl(j) < zu(k)).and.(xu(j) >= zu(k))) then
           !                           xl(j)-----------------xu(j)
           !      zl(k)------------------------------zu(k)
           w(j,k) = zu(k) - xl(j)
         else if ((xl(j) <= zl(k)).and.(xu(j) >= zu(k))) then
           !  xl(j)---------------------------xu(j)
           !        zl(k)--------------zu(k)
           w(j,k) = dz(j)
         endif
       enddo
     enddo
     ! Check for dBZ and change if necessary
     if (lunits) then
        where (yp /= R_UNDEF)
          yp = 10.0**(yp/10.0)
        elsewhere
          yp = 0.0
        end where
     endif
     ! Do the weighted mean
     do j=1,Ncolumns
       do k=1,M
          if (zu(k) <= zhalf(i,1)) then ! Level below model bottom level
             r(i,j,k) = R_GROUND
          else
            ws = sum(w(:,k))
            if ((ws > 0.0).and.(r(i,j,k) /= R_GROUND)) r(i,j,k) = sum(w(:,k)    *yp(j,:))/ws
            ! Check for dBZ and change if necessary
            if ((lunits).and.(r(i,j,k) /= R_GROUND)) then
                if (r(i,j,k) <= 0.0) then
                    r(i,j,k) = R_UNDEF
                else
                    r(i,j,k) = 10.0*log10(r(i,j,k))
                endif
            endif
          endif
       enddo
     enddo
   enddo
 
 
   
END SUBROUTINE COSP_CHANGE_VERTICAL_GRID 

END MODULE MOD_COSP_STATS


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
 
! $Id: cosp_types.f90,v 1.1.2.1.4.1.2.1.6.1 2010/03/04 08:23:34 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2007 - A. Bodas-Salcedo - Initial version
! Feb 2008 - R. Marchand      - Added Quickbeam types and initialisation
! Oct 2008 - H. Chepfer       - Added PARASOL reflectance diagnostic
! Nov 2008 - R. Marchand      - Added MISR diagnostics
! Nov 2008 - V. John          - Added RTTOV diagnostics
!
! 
MODULE MOD_COSP_TYPES
    USE MOD_COSP_CONSTANTS
    USE MOD_COSP_UTILS

    use radar_simulator_types, only: class_param, mie, nd, mt_nd, dmax, dmin, mt_ttl, mt_tti, cnt_liq, cnt_ice	! added by roj Feb 2008

    IMPLICIT NONE
    
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------------- DERIVED TYPES ----------------------------    
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  ! Configuration choices (simulators, variables)
  TYPE COSP_CONFIG
     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfaddbze94, &
                LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
                Llongitude,Llatitude,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
                Lfracout,LlidarBetaMol532,Ltbrttov, &
                Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
                Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
                Liwpmodis,Lclmodis

     character(len=32) :: out_list(N_OUT_LIST)
  END TYPE COSP_CONFIG
  
  ! Outputs from RTTOV
  TYPE COSP_RTTOV
     ! Dimensions
     integer :: Npoints   ! Number of gridpoints
     integer :: Nchan     ! Number of channels
     
     ! Brightness temperatures (Npoints,Nchan)
     real,pointer :: tbs(:,:)
     
  END TYPE COSP_RTTOV
  
  ! Outputs from MISR simulator
  TYPE COSP_MISR
     ! Dimensions
     integer :: Npoints   ! Number of gridpoints
     integer :: Ntau      ! Number of tau intervals
     integer :: Nlevels   ! Number of cth levels

     ! --- (npoints,ntau,nlevels)
     !  the fraction of the model grid box covered by each of the MISR cloud types
     real,pointer :: fq_MISR(:,:,:)  
     
     ! --- (npoints)
     real,pointer :: MISR_meanztop(:), MISR_cldarea(:)
     ! --- (npoints,nlevels)
     real,pointer :: MISR_dist_model_layertops(:,:)
  END TYPE COSP_MISR

  ! Outputs from ISCCP simulator
  TYPE COSP_ISCCP
     ! Dimensions
     integer :: Npoints   ! Number of gridpoints
     integer :: Ncolumns  ! Number of columns
     integer :: Nlevels   ! Number of levels

    
     ! --- (npoints,tau=7,pressure=7)
     !  the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types
     real,pointer :: fq_isccp(:,:,:)
     
     ! --- (npoints) ---
     ! The fraction of model grid box columns with cloud somewhere in them.
     ! This should equal the sum over all entries of fq_isccp
     real,pointer :: totalcldarea(:)
     ! mean all-sky 10.5 micron brightness temperature
     real,pointer ::  meantb(:)
     ! mean clear-sky 10.5 micron brightness temperature
     real,pointer ::  meantbclr(:)
     
     ! The following three means are averages over the cloudy areas only.  If no
     ! clouds are in grid box all three quantities should equal zero.
     
     !  mean cloud top pressure (mb) - linear averaging in cloud top pressure.
     real,pointer :: meanptop(:)
     !  mean optical thickness linear averaging in albedo performed.
     real,pointer :: meantaucld(:)
     ! mean cloud albedo. linear averaging in albedo performed 
     real,pointer :: meanalbedocld(:)  
     
     !--- (npoints,ncol) ---
     !  optical thickness in each column     
     real,pointer :: boxtau(:,:)
     !  cloud top pressure (mb) in each column
     real,pointer :: boxptop(:,:)        
  END TYPE COSP_ISCCP
  
  ! Summary statistics from radar
  TYPE COSP_VGRID
    logical :: use_vgrid ! Logical flag that indicates change of grid
    logical :: csat_vgrid ! Flag for Cloudsat grid
    integer :: Npoints   ! Number of sampled points
    integer :: Ncolumns  ! Number of subgrid columns
    integer :: Nlevels   ! Number of model levels
    integer :: Nlvgrid   ! Number of levels of new grid
    ! Array with dimensions (Nlvgrid)
    real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels
    ! Array with dimensions (Nlevels)
    real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels
  END TYPE COSP_VGRID
  
  ! Output data from lidar code
  TYPE COSP_SGLIDAR
    ! Dimensions
    integer :: Npoints   ! Number of gridpoints
    integer :: Ncolumns  ! Number of columns
    integer :: Nlevels   ! Number of levels
    integer :: Nhydro    ! Number of hydrometeors    
    integer :: Nrefl     ! Number of parasol reflectances
    ! Arrays with dimensions (Npoints,Nlevels)
    real,dimension(:,:),pointer :: beta_mol   ! Molecular backscatter
    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
    real,dimension(:,:,:),pointer :: beta_tot   ! Total backscattered signal
    real,dimension(:,:,:),pointer :: tau_tot    ! Optical thickness integrated from top to level z
    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
    real,dimension(:,:,:),pointer :: refl       ! parasol reflectances
  END TYPE COSP_SGLIDAR
  
  ! Output data from radar code
  TYPE COSP_SGRADAR
    ! Dimensions
    integer :: Npoints   ! Number of gridpoints
    integer :: Ncolumns  ! Number of columns
    integer :: Nlevels   ! Number of levels
    integer :: Nhydro    ! Number of hydrometeors
    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
    ! Arrays with dimensions (Npoints,Nlevels)
    real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ]
    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
    real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ]
 
  END TYPE COSP_SGRADAR

  
  ! Summary statistics from radar
  TYPE COSP_RADARSTATS
    integer :: Npoints  ! Number of sampled points
    integer :: Ncolumns ! Number of subgrid columns
    integer :: Nlevels  ! Number of model levels
    integer :: Nhydro   ! Number of hydrometeors
    ! Array with dimensions (Npoints,dBZe_bins,Nlevels)
    real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD
    ! Array with dimensions (Npoints)
    real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale
    ! Arrays with dimensions (Npoints,Nlevels)
    real, dimension(:,:),pointer :: lidar_only_freq_cloud
  END TYPE COSP_RADARSTATS

  ! Summary statistics from lidar
  TYPE COSP_LIDARSTATS
    integer :: Npoints  ! Number of sampled points
    integer :: Ncolumns ! Number of subgrid columns
    integer :: Nlevels  ! Number of model levels
    integer :: Nhydro   ! Number of hydrometeors
    integer :: Nrefl    ! Number of parasol reflectances
    
    ! Arrays with dimensions (SR_BINS)
    real, dimension(:),pointer :: srbval ! SR bins in cfad_sr
    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
    real, dimension(:,:,:),pointer :: cfad_sr   ! CFAD of scattering ratio
    ! Arrays with dimensions (Npoints,Nlevels)
    real, dimension(:,:),pointer :: lidarcld    ! 3D "lidar" cloud fraction 
    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level lidar cloud cover
    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
    real, dimension(:,:),pointer :: parasolrefl   ! mean parasol reflectance

  END TYPE COSP_LIDARSTATS

    
  ! Input data for simulator. Subgrid scale.
  ! Input data from SURFACE to TOA
  TYPE COSP_SUBGRID
    ! Dimensions
    integer :: Npoints   ! Number of gridpoints
    integer :: Ncolumns  ! Number of columns
    integer :: Nlevels   ! Number of levels
    integer :: Nhydro    ! Number of hydrometeors
    logical :: cols_input_from_model ! is column data input from model ?
    
    real,dimension(:,:,:),pointer :: prec_frac  ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels)
    real,dimension(:,:,:),pointer :: frac_out  ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels)
    real,dimension(:,:,:),pointer :: dtau_col  ! Subgrid tau   array. Dimensions (Npoints,Ncolumns,Nlevels)
    real,dimension(:,:,:),pointer :: dem_col   ! Subgrid emiss array. Dimensions (Npoints,Ncolumns,Nlevels)
  END TYPE COSP_SUBGRID

  ! Input data for simulator at Subgrid scale.
  ! Used on a reduced number of points
  TYPE COSP_SGHYDRO
    ! Dimensions
    integer :: Npoints   ! Number of gridpoints
    integer :: Ncolumns  ! Number of columns
    integer :: Nlevels   ! Number of levels
    integer :: Nhydro    ! Number of hydrometeors
    real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor 
                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg]
    real,dimension(:,:,:,:),pointer :: Reff     ! Effective Radius of each hydrometeor
                                                ! (Reff==0 means use default size)   
                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [m]
  END TYPE COSP_SGHYDRO
  
  ! Input data for simulator. Gridbox scale.
  TYPE COSP_GRIDBOX
    ! Scalars and dimensions
    integer :: Npoints   ! Number of gridpoints
    integer :: Nlevels   ! Number of levels
    integer :: Ncolumns  ! Number of columns
    integer :: Nhydro    ! Number of hydrometeors
    integer :: Nprmts_max_hydro    ! Max number of parameters for hydrometeor size distributions
    integer :: Naero    ! Number of aerosol species
    integer :: Nprmts_max_aero    ! Max number of parameters for aerosol size distributions
    integer :: Npoints_it   ! Max number of gridpoints to be processed in one iteration
    
    ! Time [days]
    double precision :: time
    double precision :: time_bnds(2)
    
    ! Radar ancillary info
    real :: radar_freq, & ! Radar frequency [GHz]
            k2 ! |K|^2, -1=use frequency dependent default
    integer :: surface_radar, & ! surface=1, spaceborne=0
	       use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
	       use_gas_abs, & ! include gaseous absorption? yes=1,no=0
	       do_ray, & ! calculate/output Rayleigh refl=1, not=0
	       melt_lay ! melting layer model off=0, on=1
 
    ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008
    type(class_param) ::  hp	! structure used by radar simulator to store Ze and N scaling constants and other information
    type(mie)::  mt		! structure used by radar simulator to store mie LUT information
    integer :: nsizes 		! number of discrete drop sizes (um) used to represent the distribution
    real*8, dimension(:), pointer :: D ! array of discrete drop sizes (um) used to represent the distribution
    real*8, dimension(:), pointer :: mt_ttl, mt_tti ! array of temperatures used with Ze_scaling (also build into mie LUT)
    
    ! Lidar
    integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations 
                              !(ice_type=0 for spheres, ice_type=1 for non spherical particles)
    
    ! Radar
    logical ::  use_precipitation_fluxes  ! True if precipitation fluxes are input to the algorithm 
    logical ::  use_reff  ! True if Reff is to be used by radar 
    
    ! Geolocation (Npoints)
    real,dimension(:),pointer :: longitude ! longitude [degrees East]
    real,dimension(:),pointer :: latitude  ! latitude [deg North]
    ! Gridbox information (Npoints,Nlevels)
    real,dimension(:,:),pointer :: zlev ! Height of model levels [m]
    real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer)
    real,dimension(:,:),pointer :: dlev ! Depth of model levels  [m]
    real,dimension(:,:),pointer :: p  ! Pressure at full model levels [Pa]
    real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa]
    real,dimension(:,:),pointer :: T ! Temperature at model levels [K]
    real,dimension(:,:),pointer :: q  ! Relative humidity to water (%)
    real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg]
    real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform
                                          !  clouds in each model level
                                          !  NOTE:  this the cloud optical depth of only the
                                          !  cloudy part of the grid box, it is not weighted
                                          !  with the 0 cloud optical depth of the clear
                                          !         part of the grid box
    real,dimension(:,:),pointer :: dtau_c !  mean 0.67 micron optical depth of convective
                                          !  clouds in each model level.  Same note applies as in dtau_s.
    real,dimension(:,:),pointer :: dem_s  !  10.5 micron longwave emissivity of stratiform
                                          !  clouds in each model level.  Same note applies as in dtau_s.
    real,dimension(:,:),pointer :: dem_c  !  10.5 micron longwave emissivity of convective
                                          !  clouds in each model level.  Same note applies as in dtau_s.
    real,dimension(:,:),pointer :: mr_ozone !  Ozone mass mixing ratio [kg/kg]

    ! Point information (Npoints)
    real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land]
    real,dimension(:),pointer :: psfc !Surface pressure [Pa]
    real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime
    real,dimension(:),pointer :: skt  ! Skin temperature (K)
    real,dimension(:),pointer :: sfc_height  ! Surface height [m]
    real,dimension(:),pointer :: u_wind  ! eastward wind [m s-1]
    real,dimension(:),pointer :: v_wind  ! northward wind [m s-1]

    ! TOTAL and CONV cloud fraction for SCOPS
    real,dimension(:,:),pointer :: tca ! Total cloud fraction
    real,dimension(:,:),pointer :: cca ! Convective cloud fraction
    ! Precipitation fluxes on model levels
    real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s]
    real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s]
    real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s]
    real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s]
    real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s]
    ! Hydrometeors concentration and distribution parameters
!     real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro)
    real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg]
    real,dimension(:,:),pointer   :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro)
    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
    real,dimension(:,:,:),pointer :: Reff
    ! Aerosols concentration and distribution parameters
    real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero)
    integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero)
    real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols 
                                                       ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
    ! ISCCP simulator inputs
    integer :: isccp_top_height !  1 = adjust top height using both a computed
                                !  infrared brightness temperature and the visible
                                !  optical depth to adjust cloud top pressure. Note
                                !  that this calculation is most appropriate to compare
                                !  to ISCCP data during sunlit hours.
                                !  2 = do not adjust top height, that is cloud top
                                !  pressure is the actual cloud top pressure
                                !  in the model
                                !  3 = adjust top height using only the computed
                                !  infrared brightness temperature. Note that this
                                !  calculation is most appropriate to compare to ISCCP
                                !  IR only algortihm (i.e. you can compare to nighttime
                                !  ISCCP data with this option)
    integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level
                                 ! with interpolated temperature equal to the radiance
                                 ! determined cloud-top temperature
                                 ! 1 = find the *lowest* altitude (highest pressure) level
                                 ! with interpolated temperature equal to the radiance
                                 ! determined cloud-top temperature
                                 ! 2 = find the *highest* altitude (lowest pressure) level
                                 ! with interpolated temperature equal to the radiance 
                                 ! determined cloud-top temperature
                                 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
                                 ! 1 = default setting, and matches all versions of 
                                 ! ISCCP simulator with versions numbers 3.5.1 and lower
                                 ! 2 = experimental setting  
    integer :: isccp_overlap !  overlap type (1=max, 2=rand, 3=max/rand)
    real :: isccp_emsfc_lw      ! 10.5 micron emissivity of surface (fraction)
  
    ! RTTOV inputs/options
    integer :: plat      ! satellite platform
    integer :: sat       ! satellite
    integer :: inst      ! instrument
    integer :: Nchan     ! Number of channels to be computed
    integer, dimension(:), pointer :: Ichan   ! Channel numbers
    real,    dimension(:), pointer :: Surfem  ! Surface emissivity
    real    :: ZenAng ! Satellite Zenith Angles
    real :: co2,ch4,n2o,co ! Mixing ratios of trace gases

  END TYPE COSP_GRIDBOX
 
CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV -------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_RTTOV(Npoints,Nchan,x)
    integer,intent(in) :: Npoints  ! Number of sampled points
    integer,intent(in) :: Nchan ! Number of channels
    type(cosp_rttov),intent(out) :: x
    
    ! Dimensions
    x%Npoints  = Npoints
    x%Nchan    = Nchan
      
    ! --- Allocate arrays ---
    allocate(x%tbs(Npoints, Nchan))
    ! --- Initialise to zero ---
    x%tbs     = 0.0
  END SUBROUTINE CONSTRUCT_COSP_RTTOV

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_RTTOV(x)
    type(cosp_rttov),intent(inout) :: x
    
    ! --- Deallocate arrays ---
    deallocate(x%tbs)
  END SUBROUTINE FREE_COSP_RTTOV
  
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x)
    type(cosp_config),intent(in) :: cfg ! Configuration options
    integer,intent(in) :: Npoints   ! Number of gridpoints
    type(cosp_misr),intent(out) :: x
    ! Local variables
    integer :: i,j,k
    
   
    ! Allocate minumum storage if simulator not used
    if (cfg%Lmisr_sim) then
      i = Npoints
      j = 7
      k = MISR_N_CTH
    else
      i = 1
      j = 1
      k = 1
    endif
    
    ! Dimensions
    x%Npoints = i
    x%Ntau    = j
    x%Nlevels = k
    
    ! allocate space for MISR simulator outputs ...
    allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k))
    x%fq_MISR = 0.0
    x%MISR_meanztop = 0.0
    x%MISR_cldarea = 0.0
    x%MISR_dist_model_layertops = 0.0
    
  END SUBROUTINE CONSTRUCT_COSP_MISR
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE FREE_COSP_MISR ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_MISR(x)
    type(cosp_misr),intent(inout) :: x
    deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops)
    
  END SUBROUTINE FREE_COSP_MISR

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x)
    type(cosp_config),intent(in) :: cfg ! Configuration options
    integer,intent(in) :: Npoints  ! Number of sampled points
    integer,intent(in) :: Ncolumns ! Number of subgrid columns
    integer,intent(in) :: Nlevels  ! Number of model levels
    type(cosp_isccp),intent(out) :: x
    ! Local variables
    integer :: i,j,k
    
    ! Allocate minumum storage if simulator not used
    if (cfg%Lisccp_sim) then
      i = Npoints
      j = Ncolumns
      k = Nlevels
    else
      i = 1
      j = 1
      k = 1
    endif
    
    ! Dimensions
    x%Npoints  = i
    x%Ncolumns = j
    x%Nlevels  = k
    
    ! --- Allocate arrays ---
    allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), &
         x%meanptop(i), x%meantaucld(i), &
         x%meantb(i), x%meantbclr(i), &
         x%boxtau(i,j), x%boxptop(i,j), &
         x%meanalbedocld(i))
    ! --- Initialise to zero ---
    x%fq_isccp     = 0.0
    x%totalcldarea = 0.0
    x%meanptop     = 0.0
    x%meantaucld   = 0.0
    x%meantb       = 0.0
    x%meantbclr    = 0.0
    x%boxtau       = 0.0
    x%boxptop      = 0.0
    x%meanalbedocld= 0.0
  END SUBROUTINE CONSTRUCT_COSP_ISCCP

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE FREE_COSP_ISCCP -----------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_ISCCP(x)
    type(cosp_isccp),intent(inout) :: x
    
    deallocate(x%fq_isccp, x%totalcldarea, &
         x%meanptop, x%meantaucld, x%meantb, x%meantbclr, &
         x%boxtau, x%boxptop, x%meanalbedocld)
  END SUBROUTINE FREE_COSP_ISCCP
  
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x)
    type(cosp_gridbox),intent(in) :: gbx ! Gridbox information
    integer,intent(in) :: Nlvgrid  ! Number of new levels    
    logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid
    logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested
    type(cosp_vgrid),intent(out) :: x
    
    ! Local variables
    integer :: i
    real :: zstep
    
    x%use_vgrid  = use_vgrid
    x%csat_vgrid = cloudsat
    
    ! Dimensions
    x%Npoints  = gbx%Npoints
    x%Ncolumns = gbx%Ncolumns
    x%Nlevels  = gbx%Nlevels
    
    ! --- Allocate arrays ---
    if (use_vgrid) then
      x%Nlvgrid = Nlvgrid
    else 
      x%Nlvgrid = gbx%Nlevels
    endif
    allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid))
    allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels))
    
    ! --- Model vertical levels ---
    ! Use height levels of first model gridbox
    x%mz  = gbx%zlev(1,:)
    x%mzl = gbx%zlev_half(1,:)
    x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels)
    x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels))
    
    if (use_vgrid) then
      ! --- Initialise to zero ---
      x%z  = 0.0
      x%zl = 0.0
      x%zu = 0.0
      if (cloudsat) then ! --- CloudSat grid requested ---
         zstep = 480.0
      else
         ! Other grid requested. Constant vertical spacing with top at 20 km
         zstep = 20000.0/x%Nlvgrid
      endif
      do i=1,x%Nlvgrid
         x%zl(i) = (i-1)*zstep
         x%zu(i) = i*zstep
      enddo
      x%z = (x%zl + x%zu)/2.0
    else
      x%z  = x%mz
      x%zl = x%mzl
      x%zu = x%mzu
    endif
    
  END SUBROUTINE CONSTRUCT_COSP_VGRID

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------ SUBROUTINE FREE_COSP_VGRID ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_VGRID(x)
    type(cosp_vgrid),intent(inout) :: x

    deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu)
  END SUBROUTINE FREE_COSP_VGRID

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x)
    type(cosp_config),intent(in) :: cfg ! Configuration options
    integer,intent(in) :: Npoints  ! Number of sampled points
    integer,intent(in) :: Ncolumns ! Number of subgrid columns
    integer,intent(in) :: Nlevels  ! Number of model levels
    integer,intent(in) :: Nhydro   ! Number of hydrometeors
    integer,intent(in) :: Nrefl    ! Number of parasol reflectances ! parasol
    type(cosp_sglidar),intent(out) :: x
    ! Local variables
    integer :: i,j,k,l,m
    
    ! Allocate minumum storage if simulator not used
    if (cfg%Llidar_sim) then
      i = Npoints
      j = Ncolumns
      k = Nlevels
      l = Nhydro
      m = Nrefl
    else
      i = 1
      j = 1
      k = 1
      l = 1
      m = 1
    endif
    
    ! Dimensions
    x%Npoints  = i
    x%Ncolumns = j
    x%Nlevels  = k
    x%Nhydro   = l
    x%Nrefl    = m
    
    ! --- Allocate arrays ---
    allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), &
             x%tau_tot(i,j,k),x%refl(i,j,m))
    ! --- Initialise to zero ---
    x%beta_mol   = 0.0
    x%beta_tot   = 0.0
    x%tau_tot    = 0.0
    x%refl       = 0.0 ! parasol
  END SUBROUTINE CONSTRUCT_COSP_SGLIDAR

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_SGLIDAR(x)
    type(cosp_sglidar),intent(inout) :: x

    deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl)
  END SUBROUTINE FREE_COSP_SGLIDAR

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x)
    type(cosp_config),intent(in) :: cfg ! Configuration options
    integer,intent(in) :: Npoints  ! Number of sampled points
    integer,intent(in) :: Ncolumns ! Number of subgrid columns
    integer,intent(in) :: Nlevels  ! Number of model levels
    integer,intent(in) :: Nhydro   ! Number of hydrometeors
    type(cosp_sgradar),intent(out) :: x
    ! Local variables
    integer :: i,j,k,l
    
    if (cfg%Lradar_sim) then
      i = Npoints
      j = Ncolumns
      k = Nlevels
      l = Nhydro
    else ! Allocate minumum storage if simulator not used
      i = 1
      j = 1
      k = 1
      l = 1
    endif
    
    ! Dimensions
    x%Npoints  = i
    x%Ncolumns = j
    x%Nlevels  = k
    x%Nhydro   = l
    
    ! --- Allocate arrays ---
    allocate(x%att_gas(i,k), x%Ze_tot(i,j,k))
    ! --- Initialise to zero ---
    x%att_gas   = 0.0
    x%Ze_tot    = 0.0
    ! The following line give a compilation error on the Met Office NEC
!     call zero_real(x%Z_hydro, x%att_hydro)
!     f90: error(666): cosp_types.f90, line nnn:
!                                        Actual argument corresponding to dummy
!                                        argument of ELEMENTAL subroutine
!                                        "zero_real" with INTENET(OUT) attribute
!                                        is not array.
  END SUBROUTINE CONSTRUCT_COSP_SGRADAR

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------ SUBROUTINE FREE_COSP_SGRADAR ----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_SGRADAR(x)
    type(cosp_sgradar),intent(inout) :: x

    deallocate(x%att_gas, x%Ze_tot)
  END SUBROUTINE FREE_COSP_SGRADAR

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS ---------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x)
    type(cosp_config),intent(in) :: cfg ! Configuration options
    integer,intent(in) :: Npoints  ! Number of sampled points
    integer,intent(in) :: Ncolumns ! Number of subgrid columns
    integer,intent(in) :: Nlevels  ! Number of model levels
    integer,intent(in) :: Nhydro   ! Number of hydrometeors
    type(cosp_radarstats),intent(out) :: x    
    ! Local variables
    integer :: i,j,k,l
    
    ! Allocate minumum storage if simulator not used
    if (cfg%Lradar_sim) then
      i = Npoints
      j = Ncolumns
      k = Nlevels
      l = Nhydro
    else
      i = 1
      j = 1
      k = 1
      l = 1
    endif
    
    ! Dimensions
    x%Npoints  = i
    x%Ncolumns = j
    x%Nlevels  = k
    x%Nhydro   = l
    
    ! --- Allocate arrays ---
    allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k))
    allocate(x%radar_lidar_tcc(i))
    ! --- Initialise to zero ---
    x%cfad_ze = 0.0
    x%lidar_only_freq_cloud = 0.0
    x%radar_lidar_tcc = 0.0
  END SUBROUTINE CONSTRUCT_COSP_RADARSTATS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------ SUBROUTINE FREE_COSP_RADARSTATS -------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_RADARSTATS(x)
    type(cosp_radarstats),intent(inout) :: x

    deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc)
  END SUBROUTINE FREE_COSP_RADARSTATS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS ---------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x)
    type(cosp_config),intent(in) :: cfg ! Configuration options
    integer,intent(in) :: Npoints  ! Number of sampled points
    integer,intent(in) :: Ncolumns ! Number of subgrid columns
    integer,intent(in) :: Nlevels  ! Number of model levels
    integer,intent(in) :: Nhydro   ! Number of hydrometeors
    integer,intent(in) :: Nrefl    ! Number of parasol reflectance
    type(cosp_lidarstats),intent(out) :: x
    ! Local variables
    integer :: i,j,k,l,m
    
    ! Allocate minumum storage if simulator not used
    if (cfg%Llidar_sim) then
      i = Npoints
      j = Ncolumns
      k = Nlevels
      l = Nhydro
      m = Nrefl
    else
      i = 1
      j = 1
      k = 1
      l = 1
      m = 1
    endif
    
    ! Dimensions
    x%Npoints  = i
    x%Ncolumns = j
    x%Nlevels  = k
    x%Nhydro   = l
    x%Nrefl    = m
    
    ! --- Allocate arrays ---
    allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), & 
             x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m))
    ! --- Initialise to zero ---
    x%srbval    = 0.0
    x%cfad_sr   = 0.0
    x%lidarcld  = 0.0
    x%cldlayer  = 0.0
    x%parasolrefl  = 0.0
  END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------ SUBROUTINE FREE_COSP_LIDARSTATS -------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_LIDARSTATS(x)
    type(cosp_lidarstats),intent(inout) :: x

    deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl)
  END SUBROUTINE FREE_COSP_LIDARSTATS
 

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y)
    integer,intent(in) :: Npoints, & ! Number of gridpoints
                                        Ncolumns, & ! Number of columns
                                        Nlevels   ! Number of levels
    type(cosp_subgrid),intent(out) :: y
    
    ! Dimensions
    y%Npoints  = Npoints
    y%Ncolumns = Ncolumns
    y%Nlevels  = Nlevels

    ! --- Allocate arrays ---
    allocate(y%frac_out(Npoints,Ncolumns,Nlevels))
    allocate (y%dtau_col(Npoints,Ncolumns,Nlevels), &
              y%dem_col(Npoints,Ncolumns,Nlevels) )
    if (Ncolumns > 1) then
      allocate(y%prec_frac(Npoints,Ncolumns,Nlevels))
    else ! CRM mode, not needed
      allocate(y%prec_frac(1,1,1))
    endif
    ! --- Initialise to zero ---
    y%prec_frac = 0.0
    y%frac_out  = 0.0
    y%dtau_col    = 0.0
    y%dem_col    = 0.0
    ! The following line gives a compilation error on the Met Office NEC
!     call zero_real(y%mr_hydro)
!     f90: error(666): cosp_types.f90, line nnn:
!                                        Actual argument corresponding to dummy
!                                        argument of ELEMENTAL subroutine
!                                        "zero_real" with INTENET(OUT) attribute
!                                        is not array.

  END SUBROUTINE CONSTRUCT_COSP_SUBGRID

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE FREE_COSP_SUBGRID -----------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_SUBGRID(y)
    type(cosp_subgrid),intent(inout) :: y
    
    ! --- Deallocate arrays ---
    deallocate(y%prec_frac, y%frac_out, y%dtau_col, y%dem_col)
        
  END SUBROUTINE FREE_COSP_SUBGRID

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y)
    integer,intent(in) :: Npoints, & ! Number of gridpoints
                                        Ncolumns, & ! Number of columns
                                        Nhydro, & ! Number of hydrometeors
                                        Nlevels   ! Number of levels
    type(cosp_sghydro),intent(out) :: y
    
    ! Dimensions
    y%Npoints  = Npoints
    y%Ncolumns = Ncolumns
    y%Nlevels  = Nlevels
    y%Nhydro   = Nhydro

    ! --- Allocate arrays ---
    allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), &
             y%Reff(Npoints,Ncolumns,Nlevels,Nhydro))
    ! --- Initialise to zero ---
    y%mr_hydro = 0.0
    y%Reff     = 0.0

  END SUBROUTINE CONSTRUCT_COSP_SGHYDRO

 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE FREE_COSP_SGHYDRO -----------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_SGHYDRO(y)
    type(cosp_sghydro),intent(inout) :: y
    
    ! --- Deallocate arrays ---
    deallocate(y%mr_hydro, y%Reff)
        
  END SUBROUTINE FREE_COSP_SGHYDRO
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
                                   Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & 
                                   lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, &
                                   use_precipitation_fluxes,use_reff, &
                                   ! RTTOV inputs
                                   Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,&
                                   y)
    double precision,intent(in) :: time ! Time since start of run [days] 
    double precision, intent(in) :: time_bnds(2)  ! Time boundaries
    real,intent(in)    :: radar_freq, & ! Radar frequency [GHz]
                          k2            ! |K|^2, -1=use frequency dependent default
    integer,intent(in) :: &
        surface_radar, &  ! surface=1,spaceborne=0
        use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere
        use_gas_abs, &    ! include gaseous absorption? yes=1,no=0
        do_ray, &         ! calculate/output Rayleigh refl=1, not=0
        melt_lay          ! melting layer model off=0, on=1
    integer,intent(in) :: Npoints   ! Number of gridpoints
    integer,intent(in) :: Nlevels   ! Number of levels
    integer,intent(in) :: Ncolumns  ! Number of columns
    integer,intent(in) :: Nhydro    ! Number of hydrometeors
    integer,intent(in) :: Nprmts_max_hydro    ! Max number of parameters for hydrometeor size distributions
    integer,intent(in) :: Naero    ! Number of aerosol species
    integer,intent(in) :: Nprmts_max_aero    ! Max number of parameters for aerosol size distributions
    integer,intent(in) :: Npoints_it   ! Number of gridpoints processed in one iteration
    integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical)
    integer,intent(in) :: isccp_top_height
    integer,intent(in) :: isccp_top_height_direction
    integer,intent(in) :: isccp_overlap
    real,intent(in)    :: isccp_emsfc_lw
    logical,intent(in) :: use_precipitation_fluxes,use_reff
    integer,intent(in) :: Plat
    integer,intent(in) :: Sat
    integer,intent(in) :: Inst
    integer,intent(in) :: Nchan
    integer,intent(in) :: Ichan(Nchan)
    real,intent(in)    :: SurfEm(Nchan)
    real,intent(in)    :: ZenAng
    real,intent(in)    :: co2,ch4,n2o,co
    type(cosp_gridbox),intent(out) :: y

        
    ! local variables
!    integer i, cnt_ice, cnt_liq
     integer i
    character*200 :: mie_table_name ! Mie table name  
    real*8  :: delt, deltp
 
    ! Dimensions and scalars
    y%radar_freq       = radar_freq
    y%surface_radar    = surface_radar
    y%use_mie_tables   = use_mie_tables
    y%use_gas_abs      = use_gas_abs
    y%do_ray           = do_ray
    y%melt_lay         = melt_lay
    y%k2               = k2
    y%Npoints          = Npoints
    y%Nlevels          = Nlevels
    y%Ncolumns         = Ncolumns
    y%Nhydro           = Nhydro
    y%Nprmts_max_hydro = Nprmts_max_hydro
    y%Naero            = Naero
    y%Nprmts_max_aero  = Nprmts_max_aero
    y%Npoints_it       = Npoints_it
    y%lidar_ice_type   = lidar_ice_type
    y%isccp_top_height = isccp_top_height
    y%isccp_top_height_direction = isccp_top_height_direction
    y%isccp_overlap    = isccp_overlap
    y%isccp_emsfc_lw   = isccp_emsfc_lw
    y%use_precipitation_fluxes = use_precipitation_fluxes
    y%use_reff = use_reff
    
    y%time = time
    y%time_bnds = time_bnds
    
    ! RTTOV parameters
    y%Plat   = Plat
    y%Sat    = Sat
    y%Inst   = Inst
    y%Nchan  = Nchan
    y%ZenAng = ZenAng
    y%co2    = co2
    y%ch4    = ch4
    y%n2o    = n2o
    y%co     = co

    ! --- Allocate arrays ---
    ! Gridbox information (Npoints,Nlevels)
    allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), &
             y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), &
             y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), &
             y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), &
             y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), &
             y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), &
             y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), &
             y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels))
             
             
    ! Surface information and geolocation (Npoints)
    allocate(y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
             y%sunlit(Npoints),y%skt(Npoints),y%sfc_height(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
    ! Hydrometeors concentration and distribution parameters
    allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), &
             y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), &
             y%Reff(Npoints,Nlevels,Nhydro))
    ! Aerosols concentration and distribution parameters
    allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), &
             y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero))
    
    ! RTTOV channels and sfc. emissivity
    allocate(y%ichan(Nchan),y%surfem(Nchan))
    
    ! RTTOV parameters
    y%ichan   =  ichan
    y%surfem  =  surfem
    
    ! --- Initialise to zero ---
    y%zlev      = 0.0
    y%zlev_half = 0.0
    y%dlev      = 0.0
    y%p         = 0.0
    y%ph        = 0.0
    y%T         = 0.0
    y%q         = 0.0
    y%sh        = 0.0
    y%dtau_s    = 0.0
    y%dtau_c    = 0.0
    y%dem_s     = 0.0
    y%dem_c     = 0.0
    y%tca       = 0.0
    y%cca       = 0.0
    y%rain_ls   = 0.0
    y%rain_cv   = 0.0
    y%grpl_ls   = 0.0
    y%snow_ls   = 0.0
    y%snow_cv   = 0.0
    y%Reff      = 0.0
    y%mr_ozone  = 0.0
    y%u_wind    = 0.0
    y%v_wind    = 0.0

    
    ! (Npoints)
!     call zero_real(y%psfc, y%land)
    y%longitude = 0.0
    y%latitude = 0.0
    y%psfc = 0.0
    y%land = 0.0
    y%sunlit = 0.0
    y%skt = 0.0
    y%sfc_height = 0.0
    ! (Npoints,Nlevels,Nhydro)
!     y%fr_hydro = 0.0
    y%mr_hydro = 0.0
    ! Others
    y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro)
    y%conc_aero        = 0.0 ! (Npoints,Nlevels,Naero)
    y%dist_type_aero   = 0   ! (Naero)
    y%dist_prmts_aero  = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero)

    y%hp%p1 = 0.0
    y%hp%p2 = 0.0
    y%hp%p3 = 0.0
    y%hp%dmin = 0.0
    y%hp%dmax = 0.0
    y%hp%apm = 0.0
    y%hp%bpm = 0.0
    y%hp%rho = 0.0
    y%hp%dtype = 0
    y%hp%col = 0
    y%hp%cp = 0
    y%hp%phase = 0
    y%hp%scaled = .false.
    y%hp%z_flag = .false.
    y%hp%Ze_scaled = 0.0
    y%hp%Zr_scaled = 0.0
    y%hp%kr_scaled = 0.0
    y%hp%fc = 0.0
    y%hp%rho_eff = 0.0
    y%hp%ifc = 0
    y%hp%idd = 0
    y%mt%freq = 0.0
    y%mt%tt = 0.0
    y%mt%f = 0.0
    y%mt%D = 0.0
    y%mt%qext = 0.0
    y%mt%qbsca = 0.0
    y%mt%phase = 0
    
    
    ! --- Initialize the distributional parameters for hydrometeors
    y%dist_prmts_hydro( 1,:) = HCLASS_TYPE(:)
    y%dist_prmts_hydro( 2,:) = HCLASS_COL(:)
    y%dist_prmts_hydro( 3,:) = HCLASS_PHASE(:)
    y%dist_prmts_hydro( 4,:) = HCLASS_CP(:)
    y%dist_prmts_hydro( 5,:) = HCLASS_DMIN(:)
    y%dist_prmts_hydro( 6,:) = HCLASS_DMAX(:)
    y%dist_prmts_hydro( 7,:) = HCLASS_APM(:)
    y%dist_prmts_hydro( 8,:) = HCLASS_BPM(:)
    y%dist_prmts_hydro( 9,:) = HCLASS_RHO(:)
    y%dist_prmts_hydro(10,:) = HCLASS_P1(:)
    y%dist_prmts_hydro(11,:) = HCLASS_P2(:)
    y%dist_prmts_hydro(12,:) = HCLASS_P3(:)

    ! the following code added by roj to initialize structures used by radar simulator, Feb 2008
    call load_hydrometeor_classes(y%Nprmts_max_hydro,y%dist_prmts_hydro(:,:),y%hp,y%Nhydro)

    ! load mie tables ?
    if (y%use_mie_tables == 1) then
! This problem taken care of in cosp_driver prior to this call
!     print *, '%%% COSP: Mie tables option for Quickbem not supported'
!     stop
!       ! ----- Mie tables ----
! 	    mie_table_name='mie_table.dat'
!       call load_mie_table(mie_table_name,y%mt)
!
!    !   :: D specified by table ... not must match that used when mie LUT generated!
!   	y%nsizes = mt_nd
!   	allocate(y%D(y%nsizes))
!   	y%D = y%mt%D

    else
	   ! otherwise we still need to initialize temperature arrays for Ze scaling (which is only done when not using mie table)
	   
!   cnt_ice=19
!   cnt_liq=20
!      if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then
!         allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))  ! note needed as this is global array ... 
                                                     ! which should be changed in the future
!      endif
		  
!   do i=1,cnt_ice
!	  mt_tti(i)=(i-1)*5-90
!   enddo
    
!   do i=1,cnt_liq
!	  mt_ttl(i)=(i-1)*5 - 60
!   enddo 
    
	   allocate(y%mt_ttl(cnt_liq),y%mt_tti(cnt_ice))

       y%mt_ttl = mt_ttl
       y%mt_tti = mt_tti

! !------ OLD code in v0.1 ---------------------------
!        allocate(mt_ttl(2),mt_tti(2))
!        allocate(y%mt_ttl(2),y%mt_tti(2))
!        mt_ttl = 0.0
!        mt_tti = 0.0
!        y%mt_ttl = mt_ttl
!        y%mt_tti = mt_tti
! !---------------------------------------------------
       
       ! :: D created on a log-linear scale
       y%nsizes = nd
       delt = (log(dmax)-log(dmin))/(y%nsizes-1)
       deltp = exp(delt)
       allocate(y%D(y%nsizes))
       y%D(1) = dmin
       do i=2,y%nsizes
          y%D(i) = y%D(i-1)*deltp
       enddo   
   
    endif


END SUBROUTINE CONSTRUCT_COSP_GRIDBOX

  
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE FREE_COSP_GRIDBOX -----------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal)
    type(cosp_gridbox),intent(inout) :: y
    logical,intent(in),optional :: dglobal

    ! --- Free arrays ---
    deallocate(y%D,y%mt_ttl,y%mt_tti)	! added by roj Feb 2008
!   if (.not.present(dglobal)) deallocate(mt_ttl,mt_tti)
    
!     deallocate(y%hp%p1,y%hp%p2,y%hp%p3,y%hp%dmin,y%hp%dmax,y%hp%apm,y%hp%bpm,y%hp%rho, &
!               y%hp%dtype,y%hp%col,y%hp%cp,y%hp%phase,y%hp%scaled, &
!               y%hp%z_flag,y%hp%Ze_scaled,y%hp%Zr_scaled,y%hp%kr_scaled, &
!               y%hp%fc, y%hp%rho_eff, y%hp%ifc, y%hp%idd)
!     deallocate(y%mt%freq, y%mt%tt, y%mt%f, y%mt%D, y%mt%qext, y%mt%qbsca, y%mt%phase)
    
    deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, &
               y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, &
               y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
               y%mr_hydro, y%dist_prmts_hydro, &
               y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, &
               y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, &
               y%sunlit, y%skt, y%sfc_height, y%Reff,y%ichan,y%surfem, &
               y%mr_ozone,y%u_wind,y%v_wind)
 
  END SUBROUTINE FREE_COSP_GRIDBOX
  

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_GRIDBOX_CPHP ----------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_GRIDBOX_CPHP(x,y)
    type(cosp_gridbox),intent(in) :: x
    type(cosp_gridbox),intent(inout) :: y
    
    integer :: i,j,k,sz(3)
    double precision :: tny
    
    tny = tiny(tny)
    y%hp%p1      = x%hp%p1
    y%hp%p2      = x%hp%p2
    y%hp%p3      = x%hp%p3
    y%hp%dmin    = x%hp%dmin
    y%hp%dmax    = x%hp%dmax
    y%hp%apm     = x%hp%apm
    y%hp%bpm     = x%hp%bpm
    y%hp%rho     = x%hp%rho
    y%hp%dtype   = x%hp%dtype
    y%hp%col     = x%hp%col
    y%hp%cp      = x%hp%cp
    y%hp%phase   = x%hp%phase

    y%hp%fc      = x%hp%fc
    y%hp%rho_eff = x%hp%rho_eff
    y%hp%ifc     = x%hp%ifc
    y%hp%idd     = x%hp%idd
    sz = shape(x%hp%z_flag)
    do k=1,sz(3)
      do j=1,sz(2)
        do i=1,sz(1)
           if (x%hp%scaled(i,k))   y%hp%scaled(i,k)      = .true.
           if (x%hp%z_flag(i,j,k)) y%hp%z_flag(i,j,k)    = .true.
           if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k)
           if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k)
           if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k)
        enddo
      enddo
    enddo
    
END SUBROUTINE COSP_GRIDBOX_CPHP

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_gridbox),intent(in) :: x
    type(cosp_gridbox),intent(inout) :: y
    
    integer :: i,j,k,sz(3)
    
    ! --- Copy arrays without Npoints as dimension ---
    y%dist_prmts_hydro = x%dist_prmts_hydro
    y%dist_type_aero   = x%dist_type_aero
    y%D                = x%D
    y%mt_ttl           = x%mt_ttl
    y%mt_tti           = x%mt_tti
    
    
!     call cosp_gridbox_cphp(x,y)    
    
    ! 1D
    y%longitude(iy(1):iy(2))  = x%longitude(ix(1):ix(2))
    y%latitude(iy(1):iy(2))   = x%latitude(ix(1):ix(2))
    y%psfc(iy(1):iy(2))       = x%psfc(ix(1):ix(2))
    y%land(iy(1):iy(2))       = x%land(ix(1):ix(2))
    y%sunlit(iy(1):iy(2))     = x%sunlit(ix(1):ix(2))
    y%skt(iy(1):iy(2))        = x%skt(ix(1):ix(2))
    y%sfc_height(iy(1):iy(2)) = x%sfc_height(ix(1):ix(2))
    y%u_wind(iy(1):iy(2))     = x%u_wind(ix(1):ix(2))
    y%v_wind(iy(1):iy(2))     = x%v_wind(ix(1):ix(2))
    ! 2D
    y%zlev(iy(1):iy(2),:)      = x%zlev(ix(1):ix(2),:)
    y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:)
    y%dlev(iy(1):iy(2),:)      = x%dlev(ix(1):ix(2),:)
    y%p(iy(1):iy(2),:)         = x%p(ix(1):ix(2),:)
    y%ph(iy(1):iy(2),:)        = x%ph(ix(1):ix(2),:)
    y%T(iy(1):iy(2),:)         = x%T(ix(1):ix(2),:)
    y%q(iy(1):iy(2),:)         = x%q(ix(1):ix(2),:)
    y%sh(iy(1):iy(2),:)        = x%sh(ix(1):ix(2),:)
    y%dtau_s(iy(1):iy(2),:)    = x%dtau_s(ix(1):ix(2),:)
    y%dtau_c(iy(1):iy(2),:)    = x%dtau_c(ix(1):ix(2),:)
    y%dem_s(iy(1):iy(2),:)     = x%dem_s(ix(1):ix(2),:)
    y%dem_c(iy(1):iy(2),:)     = x%dem_c(ix(1):ix(2),:)
    y%tca(iy(1):iy(2),:)       = x%tca(ix(1):ix(2),:)
    y%cca(iy(1):iy(2),:)       = x%cca(ix(1):ix(2),:)
    y%rain_ls(iy(1):iy(2),:)   = x%rain_ls(ix(1):ix(2),:)
    y%rain_cv(iy(1):iy(2),:)   = x%rain_cv(ix(1):ix(2),:)
    y%grpl_ls(iy(1):iy(2),:)   = x%grpl_ls(ix(1):ix(2),:)
    y%snow_ls(iy(1):iy(2),:)   = x%snow_ls(ix(1):ix(2),:)
    y%snow_cv(iy(1):iy(2),:)   = x%snow_cv(ix(1):ix(2),:)
    y%mr_ozone(iy(1):iy(2),:)  = x%mr_ozone(ix(1):ix(2),:)
    ! 3D
    y%Reff(iy(1):iy(2),:,:)      = x%Reff(ix(1):ix(2),:,:)
    y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:)
    y%mr_hydro(iy(1):iy(2),:,:)  = x%mr_hydro(ix(1):ix(2),:,:)
    ! 4D
    y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:)

END SUBROUTINE COSP_GRIDBOX_CPSECTION
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_SUBGRID_CPSECTION -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_subgrid),intent(in) :: x
    type(cosp_subgrid),intent(inout) :: y
    
    y%prec_frac(iy(1):iy(2),:,:)  = x%prec_frac(ix(1):ix(2),:,:)
    y%frac_out(iy(1):iy(2),:,:)   = x%frac_out(ix(1):ix(2),:,:)
END SUBROUTINE COSP_SUBGRID_CPSECTION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_SGRADAR_CPSECTION -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_sgradar),intent(in) :: x
    type(cosp_sgradar),intent(inout) :: y
    
    y%att_gas(iy(1):iy(2),:)  = x%att_gas(ix(1):ix(2),:)
    y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:)
END SUBROUTINE COSP_SGRADAR_CPSECTION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_sglidar),intent(in) :: x
    type(cosp_sglidar),intent(inout) :: y
    
    y%beta_mol(iy(1):iy(2),:)       = x%beta_mol(ix(1):ix(2),:)
    y%beta_tot(iy(1):iy(2),:,:)     = x%beta_tot(ix(1):ix(2),:,:)
    y%tau_tot(iy(1):iy(2),:,:)      = x%tau_tot(ix(1):ix(2),:,:)
    y%refl(iy(1):iy(2),:,:)         = x%refl(ix(1):ix(2),:,:)
END SUBROUTINE COSP_SGLIDAR_CPSECTION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_ISCCP_CPSECTION -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_isccp),intent(in) :: x
    type(cosp_isccp),intent(inout) :: y
            
    y%fq_isccp(iy(1):iy(2),:,:)  = x%fq_isccp(ix(1):ix(2),:,:)
    y%totalcldarea(iy(1):iy(2))  = x%totalcldarea(ix(1):ix(2))
    y%meantb(iy(1):iy(2))        = x%meantb(ix(1):ix(2))
    y%meantbclr(iy(1):iy(2))     = x%meantbclr(ix(1):ix(2))
    y%meanptop(iy(1):iy(2))      = x%meanptop(ix(1):ix(2))
    y%meantaucld(iy(1):iy(2))    = x%meantaucld(ix(1):ix(2))
    y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2))
    y%boxtau(iy(1):iy(2),:)      = x%boxtau(ix(1):ix(2),:)
    y%boxptop(iy(1):iy(2),:)     = x%boxptop(ix(1):ix(2),:)
END SUBROUTINE COSP_ISCCP_CPSECTION


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_MISR_CPSECTION -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_misr),intent(in) :: x
    type(cosp_misr),intent(inout) :: y
            
    y%fq_MISR(iy(1):iy(2),:,:)                 = x%fq_MISR(ix(1):ix(2),:,:)
    y%MISR_meanztop(iy(1):iy(2))               = x%MISR_meanztop(ix(1):ix(2))
    y%MISR_cldarea(iy(1):iy(2))                = x%MISR_cldarea(ix(1):ix(2))
    y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:)
END SUBROUTINE COSP_MISR_CPSECTION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_RTTOV_CPSECTION -------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_rttov),intent(in) :: x
    type(cosp_rttov),intent(inout) :: y
            
    y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:)
END SUBROUTINE COSP_RTTOV_CPSECTION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION --------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_radarstats),intent(in) :: x
    type(cosp_radarstats),intent(inout) :: y
            
    y%cfad_ze(iy(1):iy(2),:,:)             = x%cfad_ze(ix(1):ix(2),:,:)
    y%radar_lidar_tcc(iy(1):iy(2))         = x%radar_lidar_tcc(ix(1):ix(2))
    y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:)
END SUBROUTINE COSP_RADARSTATS_CPSECTION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION --------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y)
    integer,intent(in),dimension(2) :: ix,iy
    type(cosp_lidarstats),intent(in) :: x
    type(cosp_lidarstats),intent(inout) :: y
            
    y%srbval                     = x%srbval
    y%cfad_sr(iy(1):iy(2),:,:)   = x%cfad_sr(ix(1):ix(2),:,:)
    y%lidarcld(iy(1):iy(2),:)    = x%lidarcld(ix(1):ix(2),:)
    y%cldlayer(iy(1):iy(2),:)    = x%cldlayer(ix(1):ix(2),:)
    y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:)
END SUBROUTINE COSP_LIDARSTATS_CPSECTION
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- PRINT SUBROUTINES --------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_GRIDBOX_PRINT(x)
    type(cosp_gridbox),intent(in) :: x

    print *, '%%%%----- Information on COSP_GRIDBOX ------'
    ! Scalars and dimensions
    print *,  x%Npoints
    print *,  x%Nlevels
    print *,  x%Ncolumns
    print *,  x%Nhydro
    print *,  x%Nprmts_max_hydro
    print *,  x%Naero
    print *,  x%Nprmts_max_aero
    print *,  x%Npoints_it
    
    ! Time [days]
    print *,  x%time
    
    ! Radar ancillary info
    print *,  x%radar_freq, &
            x%k2
    print *,  x%surface_radar, &
	       x%use_mie_tables, &
	       x%use_gas_abs, &
	       x%do_ray, &
	       x%melt_lay

!               print *,  'shape(x%): ',shape(x%)
 
!     type(class_param) ::  hp	! structure used by radar simulator to store Ze and N scaling constants and other information
!     type(mie)::  mt		! structure used by radar simulator to store mie LUT information
    print *,  x%nsizes
    print *,  'shape(x%D): ',shape(x%D)
    print *,  'shape(x%mt_ttl): ',shape(x%mt_ttl)
    print *,  'shape(x%mt_tti): ',shape(x%mt_tti)
    
    ! Lidar
    print *,  x%lidar_ice_type
    
    ! Radar
    print *,  x%use_precipitation_fluxes
    print *,  x%use_reff
    
    ! Geolocation (Npoints)
    print *,  'shape(x%longitude): ',shape(x%longitude)
    print *,  'shape(x%latitude): ',shape(x%latitude)
    ! Gridbox information (Npoints,Nlevels)
    print *,  'shape(x%zlev): ',shape(x%zlev)
    print *,  'shape(x%zlev_half): ',shape(x%zlev_half)
    print *,  'shape(x%dlev): ',shape(x%dlev)
    print *,  'shape(x%p): ',shape(x%p)
    print *,  'shape(x%ph): ',shape(x%ph)
    print *,  'shape(x%T): ',shape(x%T)
    print *,  'shape(x%q): ',shape(x%q)
    print *,  'shape(x%sh): ',shape(x%sh)
    print *,  'shape(x%dtau_s): ',shape(x%dtau_s)
    print *,  'shape(x%dtau_c): ',shape(x%dtau_c)
    print *,  'shape(x%dem_s): ',shape(x%dem_s)
    print *,  'shape(x%dem_c): ',shape(x%dem_c)
    print *,  'shape(x%mr_ozone): ',shape(x%mr_ozone)

    ! Point information (Npoints)
    print *,  'shape(x%land): ',shape(x%land)
    print *,  'shape(x%psfc): ',shape(x%psfc)
    print *,  'shape(x%sunlit): ',shape(x%sunlit)
    print *,  'shape(x%skt): ',shape(x%skt)
    print *,  'shape(x%sfc_height): ',shape(x%sfc_height)
    print *,  'shape(x%u_wind): ',shape(x%u_wind)
    print *,  'shape(x%v_wind): ',shape(x%v_wind)

    ! TOTAL and CONV cloud fraction for SCOPS
    print *,  'shape(x%tca): ',shape(x%tca)
    print *,  'shape(x%cca): ',shape(x%cca)
    ! Precipitation fluxes on model levels
    print *,  'shape(x%rain_ls): ',shape(x%rain_ls)
    print *,  'shape(x%rain_cv): ',shape(x%rain_cv)
    print *,  'shape(x%snow_ls): ',shape(x%snow_ls)
    print *,  'shape(x%snow_cv): ',shape(x%snow_cv)
    print *,  'shape(x%grpl_ls): ',shape(x%grpl_ls)
    ! Hydrometeors concentration and distribution parameters
    print *,  'shape(x%mr_hydro): ',shape(x%mr_hydro)
    print *,  'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro)
    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
    print *,  'shape(x%Reff): ',shape(x%Reff)
    ! Aerosols concentration and distribution parameters
    print *,  'shape(x%conc_aero): ',shape(x%conc_aero)
    print *,  'shape(x%dist_type_aero): ',shape(x%dist_type_aero)
    print *,  'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero)
    ! ISCCP simulator inputs
    print *, x%isccp_top_height
    print *, x%isccp_top_height_direction
    print *, x%isccp_overlap
    print *, x%isccp_emsfc_lw
  
    ! RTTOV inputs/options
    print *, x%plat
    print *, x%sat
    print *, x%inst
    print *, x%Nchan
    print *,  'shape(x%Ichan): ',x%Ichan
    print *,  'shape(x%Surfem): ',x%Surfem
    print *, x%ZenAng
    print *, x%co2,x%ch4,x%n2o,x%co
                
END SUBROUTINE COSP_GRIDBOX_PRINT

SUBROUTINE COSP_MISR_PRINT(x)
    type(cosp_misr),intent(in) :: x

    print *, '%%%%----- Information on COSP_MISR ------'
                
     ! Dimensions
    print *, x%Npoints
    print *, x%Ntau
    print *, x%Nlevels

     ! --- (npoints,ntau,nlevels)
     !  the fraction of the model grid box covered by each of the MISR cloud types
     print *,  'shape(x%fq_MISR): ',shape(x%fq_MISR)
     
     ! --- (npoints)
     print *,  'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop)
     print *,  'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea)
     ! --- (npoints,nlevels)
     print *,  'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops)
    
END SUBROUTINE COSP_MISR_PRINT

SUBROUTINE COSP_ISCCP_PRINT(x)
    type(cosp_isccp),intent(in) :: x
            
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels

    print *, '%%%%----- Information on COSP_ISCCP ------'
    
     print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp)
     print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea)
     print *, 'shape(x%meantb): ',shape(x%meantb)
     print *, 'shape(x%meantbclr): ',shape(x%meantbclr)
     
     print *, 'shape(x%meanptop): ',shape(x%meanptop)
     print *, 'shape(x%meantaucld): ',shape(x%meantaucld)
     print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld)
     print *, 'shape(x%boxtau): ',shape(x%boxtau)
     print *, 'shape(x%boxptop): ',shape(x%boxptop)
END SUBROUTINE COSP_ISCCP_PRINT

SUBROUTINE COSP_VGRID_PRINT(x)
    type(cosp_vgrid),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_VGRID ------'
    print *, x%use_vgrid
    print *, x%csat_vgrid
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nlvgrid
    ! Array with dimensions (Nlvgrid)
    print *, 'shape(x%z): ',shape(x%z)
    print *, 'shape(x%zl): ',shape(x%zl)
    print *, 'shape(x%zu): ',shape(x%zu)
    ! Array with dimensions (Nlevels)
    print *, 'shape(x%mz): ',shape(x%mz)
    print *, 'shape(x%mzl): ',shape(x%mzl)
    print *, 'shape(x%mzu): ',shape(x%mzu)
END SUBROUTINE COSP_VGRID_PRINT

SUBROUTINE COSP_SGLIDAR_PRINT(x)
    type(cosp_sglidar),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_SGLIDAR ------'
    ! Dimensions
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nhydro
    print *, x%Nrefl
    ! Arrays with dimensions (Npoints,Nlevels)
    print *, 'shape(x%beta_mol): ',shape(x%beta_mol)
    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
    print *, 'shape(x%beta_tot): ',shape(x%beta_tot)
    print *, 'shape(x%tau_tot): ',shape(x%tau_tot)
    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
    print *, 'shape(x%refl): ',shape(x%refl)
END SUBROUTINE COSP_SGLIDAR_PRINT

SUBROUTINE COSP_SGRADAR_PRINT(x)
    type(cosp_sgradar),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_SGRADAR ------'
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nhydro
    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
    ! Arrays with dimensions (Npoints,Nlevels)
    print *, 'shape(x%att_gas): ', shape(x%att_gas)
    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
    print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot)
END SUBROUTINE COSP_SGRADAR_PRINT

SUBROUTINE COSP_RADARSTATS_PRINT(x)
    type(cosp_radarstats),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_SGRADAR ------'
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nhydro
    print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze)
    print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc)
    print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud)
END SUBROUTINE COSP_RADARSTATS_PRINT

SUBROUTINE COSP_LIDARSTATS_PRINT(x)
    type(cosp_lidarstats),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_SGLIDAR ------'
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nhydro
    print *, x%Nrefl
    
    ! Arrays with dimensions (SR_BINS)
    print *, 'shape(x%srbval): ',shape(x%srbval)
    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
    print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr)
    ! Arrays with dimensions (Npoints,Nlevels)
    print *, 'shape(x%lidarcld): ',shape(x%lidarcld)
    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
    print *, 'shape(x%cldlayer): ',shape(x%cldlayer)
    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
    print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl)
END SUBROUTINE COSP_LIDARSTATS_PRINT

SUBROUTINE COSP_SUBGRID_PRINT(x)
    type(cosp_subgrid),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_SUBGRID ------'
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nhydro
    
    print *, 'shape(x%prec_frac): ',shape(x%prec_frac)
    print *, 'shape(x%frac_out): ',shape(x%frac_out)
END SUBROUTINE COSP_SUBGRID_PRINT

SUBROUTINE COSP_SGHYDRO_PRINT(x)
    type(cosp_sghydro),intent(in) :: x
            
    print *, '%%%%----- Information on COSP_SGHYDRO ------'
    print *, x%Npoints
    print *, x%Ncolumns
    print *, x%Nlevels
    print *, x%Nhydro
    
    print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro)
    print *, 'shape(x%Reff): ',shape(x%Reff)
END SUBROUTINE COSP_SGHYDRO_PRINT


END MODULE MOD_COSP_TYPES


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: cosp_utils.f90,v 1.1.2.1.2.1.6.1 2010/03/04 08:23:34 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!
! History:
! Jul 2007 - A. Bodas-Salcedo - Initial version
!

MODULE MOD_COSP_UTILS
  USE MOD_COSP_CONSTANTS
  IMPLICIT NONE

  INTERFACE Z_TO_DBZ
    MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D
  END INTERFACE

  INTERFACE COSP_CHECK_INPUT
    MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D
  END INTERFACE
CONTAINS


! ! FUNCTION GAMMA(Y)
! !       real,intent(in) :: y
! !       integer :: i,m
! !       real gg,g,pare,x
! !       real :: gamma
! !       
! !       gg=1.
! !       m=y
! !       x=y-m
! !       if (m /= 1) then
! !          do i=1,m-1
! !          g=y-i
! !          gg=gg*g
! !          end do
! !       end if
! !       pare=-0.5748646*x+0.9512363*x*x-0.6998588*x*x*x              &
! !             +0.4245549*x*x*x*x-0.1010678*x*x*x*x*x+1.
! !       gamma=pare*gg
! !       
! ! END FUNCTION GAMMA

! ! !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! ! !------------------- SUBROUTINE COSP_PRECIP_MXRATIO --------------
! ! !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! ! SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,rho,prec_frac,prec_type, &
! !                           n_ax,n_bx,alpha_x,lambda_x,c_x,d_x,g_x,a_x,b_x, &
! !                           flux,mxratio)
! ! 
! !     ! Input arguments, (IN)
! !     integer,intent(in) :: Npoints,Nlevels,Ncolumns,Nprecip
! !     real,intent(in),dimension(Npoints,Nlevels) :: rho,flux
! !     real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
! !     real,intent(in) :: n_ax,n_bx,alpha_x,lambda_x, &
! !                        c_x,d_x,g_x,a_x,b_x,prec_type
! !     ! Input arguments, (OUT)
! !     real,intent(out),dimension(Npoints,Ncolumns,Nlevels),mxratio
! !     ! Local variables
! !     integer :: i,j,k
! !     real :: gamma1,gamma2,sigma,one_over_xip1
! !     real :: ,dimension(Npoints,Nlevels) :: rho
! !     
! !     gamma1  = gamma(alpha_x + b_x + d_x + 1.0)
! !     gamma2  = gamma(alpha_x + b_x + 1.0)
! !     xi      = 1.0/(alpha_x + b_x + d_x - n_bx + 1.0)
! !     rho0    = 1.29
! !     mxratio = 0.0
! !     sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
! !     one_over_xip1 = 1.0/(xi + 1.0)
! !     
! !     
! !     do k=1,Nlev
! !         do j=1,Ncolumns
! !             do i=1,Npoints
! !                 if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then
! !                     mxratio(i,j,k)=(flux(i,k)*((rho(i,k)/rho0)**g_x)*sigma)**one_over_xip1
! !                     mxratio(i,j,k)=mxratio(i,j,k)/rho(i,k)
! !                 endif
! !             enddo
! !         enddo
! !     enddo
! ! 
! ! END SUBROUTINE COSP_PRECIP_MXRATIO


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------- SUBROUTINE ZERO_INT -------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30)

  integer,intent(inout) :: x
  integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
                                    y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
                                    y21,y22,y23,y24,y25,y26,y27,y28,y29,y30
  x = 0
  if (present(y01)) y01 = 0
  if (present(y02)) y02 = 0
  if (present(y03)) y03 = 0
  if (present(y04)) y04 = 0
  if (present(y05)) y05 = 0
  if (present(y06)) y06 = 0
  if (present(y07)) y07 = 0
  if (present(y08)) y08 = 0
  if (present(y09)) y09 = 0
  if (present(y10)) y10 = 0
  if (present(y11)) y11 = 0
  if (present(y12)) y12 = 0
  if (present(y13)) y13 = 0
  if (present(y14)) y14 = 0
  if (present(y15)) y15 = 0
  if (present(y16)) y16 = 0
  if (present(y17)) y17 = 0
  if (present(y18)) y18 = 0
  if (present(y19)) y19 = 0
  if (present(y20)) y20 = 0
  if (present(y21)) y21 = 0
  if (present(y22)) y22 = 0
  if (present(y23)) y23 = 0
  if (present(y24)) y24 = 0
  if (present(y25)) y25 = 0
  if (present(y26)) y26 = 0
  if (present(y27)) y27 = 0
  if (present(y28)) y28 = 0
  if (present(y29)) y29 = 0
  if (present(y30)) y30 = 0
END SUBROUTINE  ZERO_INT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------- SUBROUTINE ZERO_REAL ------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30)

  real,intent(inout) :: x
  real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30
  x = 0.0
  if (present(y01)) y01 = 0.0
  if (present(y02)) y02 = 0.0
  if (present(y03)) y03 = 0.0
  if (present(y04)) y04 = 0.0
  if (present(y05)) y05 = 0.0
  if (present(y06)) y06 = 0.0
  if (present(y07)) y07 = 0.0
  if (present(y08)) y08 = 0.0
  if (present(y09)) y09 = 0.0
  if (present(y10)) y10 = 0.0
  if (present(y11)) y11 = 0.0
  if (present(y12)) y12 = 0.0
  if (present(y13)) y13 = 0.0
  if (present(y14)) y14 = 0.0
  if (present(y15)) y15 = 0.0
  if (present(y16)) y16 = 0.0
  if (present(y17)) y17 = 0.0
  if (present(y18)) y18 = 0.0
  if (present(y19)) y19 = 0.0
  if (present(y20)) y20 = 0.0
  if (present(y21)) y21 = 0.0
  if (present(y22)) y22 = 0.0
  if (present(y23)) y23 = 0.0
  if (present(y24)) y24 = 0.0
  if (present(y25)) y25 = 0.0
  if (present(y26)) y26 = 0.0
  if (present(y27)) y27 = 0.0
  if (present(y28)) y28 = 0.0
  if (present(y29)) y29 = 0.0
  if (present(y30)) y30 = 0.0
END SUBROUTINE  ZERO_REAL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------------- SUBROUTINE Z_TO_DBZ_2D --------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE Z_TO_DBZ_2D(mdi,z)
    real,intent(in) :: mdi
    real,dimension(:,:),intent(inout) :: z
    ! Reflectivity Z:
    ! Input in [m3]
    ! Output in dBZ, with Z in [mm6 m-3]
    
    ! 1.e18 to convert from [m3] to [mm6 m-3]
    z = 1.e18*z
    where (z > 1.0e-6) ! Limit to -60 dBZ
      z = 10.0*log10(z)
    elsewhere
      z = mdi
    end where  
  END SUBROUTINE Z_TO_DBZ_2D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------------- SUBROUTINE Z_TO_DBZ_3D --------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE Z_TO_DBZ_3D(mdi,z)
    real,intent(in) :: mdi
    real,dimension(:,:,:),intent(inout) :: z
    ! Reflectivity Z:
    ! Input in [m3]
    ! Output in dBZ, with Z in [mm6 m-3]
    
    ! 1.e18 to convert from [m3] to [mm6 m-3]
    z = 1.e18*z
    where (z > 1.0e-6) ! Limit to -60 dBZ
      z = 10.0*log10(z)
    elsewhere
      z = mdi
    end where  
  END SUBROUTINE Z_TO_DBZ_3D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!--------------------- SUBROUTINE Z_TO_DBZ_4D --------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE Z_TO_DBZ_4D(mdi,z)
    real,intent(in) :: mdi
    real,dimension(:,:,:,:),intent(inout) :: z
    ! Reflectivity Z:
    ! Input in [m3]
    ! Output in dBZ, with Z in [mm6 m-3]
    
    ! 1.e18 to convert from [m3] to [mm6 m-3]
    z = 1.e18*z
    where (z > 1.0e-6) ! Limit to -60 dBZ
      z = 10.0*log10(z)
    elsewhere
      z = mdi
    end where  
  END SUBROUTINE Z_TO_DBZ_4D

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINES COSP_CHECK_INPUT_1D ---------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val)
    character(len=*) :: vname
    real,intent(inout) :: x(:)
    real,intent(in),optional :: min_val,max_val
    logical :: l_min,l_max
    character(len=128) :: pro_name='COSP_CHECK_INPUT_1D'
    
    l_min=.false.
    l_max=.false.
    
    if (present(min_val)) then
!       if (x < min_val) x = min_val
      if (any(x < min_val)) then 
      l_min = .true.
        where (x < min_val)
          x = min_val
        end where
      endif
    endif    
    if (present(max_val)) then
!       if (x > max_val) x = max_val
      if (any(x > max_val)) then 
        l_max = .true.
        where (x > max_val)
          x = max_val
        end where  
      endif    
    endif    
    
    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
  END SUBROUTINE COSP_CHECK_INPUT_1D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINES COSP_CHECK_INPUT_2D ---------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val)
    character(len=*) :: vname
    real,intent(inout) :: x(:,:)
    real,intent(in),optional :: min_val,max_val
    logical :: l_min,l_max
    character(len=128) :: pro_name='COSP_CHECK_INPUT_2D'
    
    l_min=.false.
    l_max=.false.
    
    if (present(min_val)) then
!       if (x < min_val) x = min_val
      if (any(x < min_val)) then 
      l_min = .true.
        where (x < min_val)
          x = min_val
        end where
      endif
    endif    
    if (present(max_val)) then
!       if (x > max_val) x = max_val
      if (any(x > max_val)) then 
        l_max = .true.
        where (x > max_val)
          x = max_val
        end where  
      endif    
    endif    
    
    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
  END SUBROUTINE COSP_CHECK_INPUT_2D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!----------------- SUBROUTINES COSP_CHECK_INPUT_3D ---------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val)
    character(len=*) :: vname
    real,intent(inout) :: x(:,:,:)
    real,intent(in),optional :: min_val,max_val
    logical :: l_min,l_max
    character(len=128) :: pro_name='COSP_CHECK_INPUT_3D'
    
    l_min=.false.
    l_max=.false.
    
    if (present(min_val)) then
!       if (x < min_val) x = min_val
      if (any(x < min_val)) then 
      l_min = .true.
        where (x < min_val)
          x = min_val
        end where
      endif
    endif    
    if (present(max_val)) then
!       if (x > max_val) x = max_val
      if (any(x > max_val)) then 
        l_max = .true.
        where (x > max_val)
          x = max_val
        end where  
      endif    
    endif    
    
    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
  END SUBROUTINE COSP_CHECK_INPUT_3D


END MODULE MOD_COSP_UTILS



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: lidar_simulator.f90,v 1.1.2.1.2.1 2009/08/10 10:45:27 rsh Exp $
! $Name: hiram_20101115_bw $

! Copyright (c) 2009, Centre National de la Recherche Scientifique
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its
!       contributors may be used to endorse or promote products derived from this software without 
!       specific prior written permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
      
      SUBROUTINE lidar_simulator(npoints,nlev,npart,nrefl &
                , undef &
                , pres, presf, temp &
                , q_lsliq, q_lsice, q_cvliq, q_cvice &
                , ls_radliq, ls_radice, cv_radliq, cv_radice &
                , frac_out, ice_type &
                , pmol, pnorm, tautot, refl )
!
!---------------------------------------------------------------------------------
! Purpose: To compute lidar signal from model-simulated profiles of cloud water
!          and cloud fraction in each sub-column of each model gridbox.
!
! References: 
! Chepfer H., S. Bony, D. Winker, M. Chiriaco, J.-L. Dufresne, G. Seze (2008),
! Use of CALIPSO lidar observations to evaluate the cloudiness simulated by a 
! climate model, Geophys. Res. Lett., 35, L15704, doi:10.1029/2008GL034207.
!
! Previous references:
! Chiriaco et al, MWR, 2006; Chepfer et al., MWR, 2007
!
! Contacts: Helene Chepfer (chepfer@lmd.polytechnique.fr), Sandrine Bony (bony@lmd.jussieu.fr)
!
! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony
!
! May 2008, H. Chepfer:
! - Units of pressure inputs: Pa 
! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients
! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical)
!
! June 2008, A. Bodas-Salcedo:
! - Ported to Fortran 90 and optimisation changes
!
! August 2008, J-L Dufresne:
! - Optimisation changes (sum instructions suppressed)
!
! October 2008, S. Bony,  H. Chepfer and J-L. Dufresne :  
! - Interface with COSP v2.0:
!      cloud fraction removed from inputs
!      in-cloud condensed water now in input (instead of grid-averaged value)
!      depolarisation diagnostic removed
!      parasol (polder) reflectances (for 5 different solar zenith angles) added
!
! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
! - Modification of the integration of the lidar equation.
! - change the cloud detection threshold
!
! April 2008, A. Bodas-Salcedo:
! - Bug fix in computation of pmol and pnorm of upper layer
!
! April 2008, J-L. Dufresne
! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a
!   factor 2 was missing. This affects the ATB values but not the 
!   cloud fraction. 
!

!---------------------------------------------------------------------------------
!
! Inputs:
!  npoints  : number of horizontal points
!  nlev : number of vertical levels
!  npart: numberb of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). 
!        Currently npart must be 4
!  nrefl: number of solar zenith angles for parasol reflectances
!  pres : pressure in the middle of atmospheric layers (full levels): Pa
!  presf: pressure in the interface of atmospheric layers (half levels): Pa
!     presf(..,1) : surface pressure ; presf(..,nlev+1)= TOA pressure
!  temp : temperature of atmospheric layers: K
!  q_lsliq: LS sub-column liquid water mixing ratio (kg/kg)
!  q_lsice: LS sub-column ice water mixing ratio (kg/kg)
!  q_cvliq: CONV sub-column liquid water mixing ratio (kg/kg)
!  q_cvice: CONV sub-column ice water mixing ratio (kg/kg)
!  ls_radliq: effective radius of LS liquid particles (meters)
!  ls_radice: effective radius of LS ice particles (meters)
!  cv_radliq: effective radius of CONV liquid particles (meters)
!  cv_radice: effective radius of CONV ice particles (meters)
!  frac_out : cloud cover in each sub-column of the gridbox (output from scops)
!  ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1 
!             for non spherical particles)
!
! Outputs:
!  pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1)
!  pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1)
!  tautot: optical thickess integrated from top to level z
!  refl : parasol(polder) reflectance
!
! Version 1.0 (June 2007)
! Version 1.1 (May 2008)
! Version 1.2 (June 2008)
! Version 2.0 (October 2008)
! Version 2.1 (December 2008)
!---------------------------------------------------------------------------------

      IMPLICIT NONE
      REAL :: SRsat
      PARAMETER (SRsat = 0.01) ! threshold full attenuation 

      LOGICAL ok_parasol
      PARAMETER (ok_parasol=.true.)  ! set to .true. if you want to activate parasol reflectances

      INTEGER i, k
      
      INTEGER INDX_LSLIQ,INDX_LSICE,INDX_CVLIQ,INDX_CVICE
      PARAMETER (INDX_LSLIQ=1,INDX_LSICE=2,INDX_CVLIQ=3,INDX_CVICE=4)
! inputs:
      INTEGER npoints,nlev,npart,ice_type
      INTEGER nrefl
      real undef                 ! undefined value
      REAL pres(npoints,nlev)    ! pressure full levels
      REAL presf(npoints,nlev+1) ! pressure half levels
      REAL temp(npoints,nlev)
      REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev)
      REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev)
      REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev)
      REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev)
      REAL frac_out(npoints,nlev)

! outputs (for each subcolumn):

      REAL pmol(npoints,nlev)  ! molecular backscatter signal power (m^-1.sr^-1)
      REAL pnorm(npoints,nlev) ! total lidar backscatter signal power (m^-1.sr^-1)
      REAL tautot(npoints,nlev)! optical thickess integrated from top
      REAL refl(npoints,nrefl)! parasol reflectance ! parasol

! actsim variables:

      REAL km, rdiffm, Qscat, Cmol
      PARAMETER (Cmol = 6.2446e-32) ! depends on wavelength
      PARAMETER (km = 1.38e-23)     ! Boltzmann constant (J/K)

      PARAMETER (rdiffm = 0.7)      ! multiple scattering correction parameter
      PARAMETER (Qscat = 2.0)       ! particle scattering efficiency at 532 nm

      REAL rholiq, rhoice
      PARAMETER (rholiq=1.0e+03)     ! liquid water (kg/m3)
      PARAMETER (rhoice=0.5e+03)     ! ice (kg/m3)

      REAL pi, rhopart(npart)
      REAL polpart(npart,5)  ! polynomial coefficients derived for spherical and non spherical
                             ! particules

!   grid-box variables:
      REAL rad_part(npoints,nlev,npart)
      REAL rhoair(npoints,nlev), zheight(npoints,nlev+1)
      REAL beta_mol(npoints,nlev), alpha_mol(npoints,nlev)
      REAL kp_part(npoints,nlev,npart)

!   sub-column variables:
      REAL frac_sub(npoints,nlev)
      REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn
      REAL alpha_part(npoints,nlev,npart)
      REAL tau_mol_lay(npoints)  ! temporary variable, moL. opt. thickness of layer k
      REAL tau_mol(npoints,nlev) ! optical thickness between TOA and bottom of layer k
      REAL tau_part(npoints,nlev,npart)
      REAL betatot(npoints,nlev)
      REAL tautot_lay(npoints)   ! temporary variable, total opt. thickness of layer k
!     Optical thickness from TOA to surface for Parasol
      REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds


!------------------------------------------------------------
!---- 1. Preliminary definitions and calculations :
!------------------------------------------------------------

      if ( npart .ne. 4 ) then
        print *,'Error in lidar_simulator, npart should be 4, not',npart
        stop
      endif

      pi = dacos(-1.D0)

! Polynomial coefficients for spherical liq/ice particles derived from Mie theory.
! Polynomial coefficients for non spherical particles derived from a composite of
! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001)
! and FDTD theory for very small particles (Yang et al., JQSRT, 2003).

! We repeat the same coefficients for LS and CONV cloud to make code more readable
!*     LS Liquid water coefficients:
         polpart(INDX_LSLIQ,1) =  2.6980e-8     
         polpart(INDX_LSLIQ,2) = -3.7701e-6
         polpart(INDX_LSLIQ,3) =  1.6594e-4
         polpart(INDX_LSLIQ,4) = -0.0024
         polpart(INDX_LSLIQ,5) =  0.0626
!*     LS Ice coefficients: 
      if (ice_type.eq.0) then     
         polpart(INDX_LSICE,1) = -1.0176e-8   
         polpart(INDX_LSICE,2) =  1.7615e-6
         polpart(INDX_LSICE,3) = -1.0480e-4
         polpart(INDX_LSICE,4) =  0.0019
         polpart(INDX_LSICE,5) =  0.0460
      endif
!*     LS Ice NS coefficients: 
      if (ice_type.eq.1) then 
         polpart(INDX_LSICE,1) = 1.3615e-8  
         polpart(INDX_LSICE,2) = -2.04206e-6 
         polpart(INDX_LSICE,3) = 7.51799e-5
         polpart(INDX_LSICE,4) = 0.00078213
         polpart(INDX_LSICE,5) = 0.0182131
      endif
!*     CONV Liquid water coefficients:
         polpart(INDX_CVLIQ,1) =  2.6980e-8     
         polpart(INDX_CVLIQ,2) = -3.7701e-6
         polpart(INDX_CVLIQ,3) =  1.6594e-4
         polpart(INDX_CVLIQ,4) = -0.0024
         polpart(INDX_CVLIQ,5) =  0.0626
!*     CONV Ice coefficients: 
      if (ice_type.eq.0) then 
         polpart(INDX_CVICE,1) = -1.0176e-8   
         polpart(INDX_CVICE,2) =  1.7615e-6
         polpart(INDX_CVICE,3) = -1.0480e-4
         polpart(INDX_CVICE,4) =  0.0019
         polpart(INDX_CVICE,5) =  0.0460
      endif
      if (ice_type.eq.1) then
         polpart(INDX_CVICE,1) = 1.3615e-8
         polpart(INDX_CVICE,2) = -2.04206e-6
         polpart(INDX_CVICE,3) = 7.51799e-5
         polpart(INDX_CVICE,4) = 0.00078213
         polpart(INDX_CVICE,5) = 0.0182131
      endif

! density:
!*    clear-sky air:
      rhoair = pres/(287.04*temp)

!*    liquid/ice particules:
      rhopart(INDX_LSLIQ) = rholiq
      rhopart(INDX_LSICE) = rhoice
      rhopart(INDX_CVLIQ) = rholiq
      rhopart(INDX_CVICE) = rhoice

! effective radius particles:
      rad_part(:,:,INDX_LSLIQ) = ls_radliq(:,:)
      rad_part(:,:,INDX_LSICE) = ls_radice(:,:)
      rad_part(:,:,INDX_CVLIQ) = cv_radliq(:,:)
      rad_part(:,:,INDX_CVICE) = cv_radice(:,:)
      rad_part(:,:,:)=MAX(rad_part(:,:,:),0.)
      rad_part(:,:,:)=MIN(rad_part(:,:,:),70.0e-6)
      
! altitude at half pressure levels:
      zheight(:,1) = 0.0
      do k = 2, nlev+1
        zheight(:,k) = zheight(:,k-1) &
                  -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81)
      enddo

! cloud fraction (0 or 1) in each sub-column:
! (if frac_out=1or2 -> frac_sub=1; if frac_out=0 -> frac_sub=0)
      frac_sub = MIN( frac_out, 1.0 )

!------------------------------------------------------------
!---- 2. Molecular alpha and beta:
!------------------------------------------------------------

      beta_mol = pres/km/temp * Cmol
      alpha_mol = 8.0*pi/3.0 * beta_mol

!------------------------------------------------------------
!---- 3. Particles alpha and beta:
!------------------------------------------------------------

! polynomes kp_lidar derived from Mie theory:
      do i = 1, npart
       where ( rad_part(:,:,i).gt.0.0)
         kp_part(:,:,i) = &
            polpart(i,1)*(rad_part(:,:,i)*1e6)**4 &
          + polpart(i,2)*(rad_part(:,:,i)*1e6)**3 &
          + polpart(i,3)*(rad_part(:,:,i)*1e6)**2 &
          + polpart(i,4)*(rad_part(:,:,i)*1e6) &
          + polpart(i,5)
        elsewhere
         kp_part(:,:,i) = 0.
        endwhere
      enddo
      
! mixing ratio particules in each subcolumn:
          qpart(:,:,INDX_LSLIQ) = q_lsliq(:,:) ! oct08
          qpart(:,:,INDX_LSICE) = q_lsice(:,:) ! oct08
          qpart(:,:,INDX_CVLIQ) = q_cvliq(:,:) ! oct08
          qpart(:,:,INDX_CVICE) = q_cvice(:,:) ! oct08

! alpha of particles in each subcolumn:
      do i = 1, npart
        where ( rad_part(:,:,i).gt.0.0)
          alpha_part(:,:,i) = 3.0/4.0 * Qscat &
                 * rhoair(:,:) * qpart(:,:,i) &
                 / (rhopart(i) * rad_part(:,:,i) )
        elsewhere
          alpha_part(:,:,i) = 0.
        endwhere
      enddo

!------------------------------------------------------------
!---- 4. Backscatter signal:
!------------------------------------------------------------

! optical thickness (molecular):
!     opt. thick of each layer
      tau_mol(:,1:nlev) = alpha_mol(:,1:nlev) &
         & *(zheight(:,2:nlev+1)-zheight(:,1:nlev))
!     opt. thick from TOA
      DO k = nlev-1, 1, -1
        tau_mol(:,k) = tau_mol(:,k) + tau_mol(:,k+1)
      ENDDO

! optical thickness (particles):

      tau_part = rdiffm * alpha_part
      DO i = 1, npart
!       opt. thick of each layer
        tau_part(:,:,i) = tau_part(:,:,i) &
           & * (zheight(:,2:nlev+1)-zheight(:,1:nlev) )
!       opt. thick from TOA
        DO k = nlev-1, 1, -1 
          tau_part(:,k,i) = tau_part(:,k,i) + tau_part(:,k+1,i)
        ENDDO
      ENDDO

! molecular signal:
!      Upper layer 
       pmol(:,nlev) = beta_mol(:,nlev) / (2.*tau_mol(:,nlev)) &
            & * (1.-exp(-2.0*tau_mol(:,nlev)))
!      Other layers
       DO k= nlev-1, 1, -1
        tau_mol_lay(:) = tau_mol(:,k)-tau_mol(:,k+1) ! opt. thick. of layer k
        WHERE (tau_mol_lay(:).GT.0.)
          pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) / (2.*tau_mol_lay(:)) &
            & * (1.-exp(-2.0*tau_mol_lay(:)))
        ELSEWHERE
!         This must never happend, but just in case, to avoid div. by 0
          pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1))
        END WHERE
      END DO
!
! Total signal (molecular + particules):
!
! For performance reason on vector computers, the 2 following lines should not be used
! and should be replace by the later one.
!      betatot(:,:) = beta_mol(:,:) + sum(kp_part*alpha_part,dim=3)
!      tautot(:,:)  = tau_mol(:,:)  + sum(tau_part,dim=3)
      betatot(:,:) = beta_mol(:,:)
      tautot(:,:)  = tau_mol(:,:)
      DO i = 1, npart
           betatot(:,:) = betatot(:,:) + kp_part(:,:,i)*alpha_part(:,:,i)
           tautot(:,:) = tautot(:,:)  + tau_part(:,:,i)
      ENDDO ! i
!
!     Upper layer 
      pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) &
            & * (1.-exp(-2.0*tautot(:,nlev)))
!     Other layers
      DO k= nlev-1, 1, -1
        tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
        WHERE (tautot_lay(:).GT.0.)
          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
               & * (1.-EXP(-2.0*tautot_lay(:)))
        ELSEWHERE
!         This must never happend, but just in case, to avoid div. by 0
          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1))
        END WHERE
      END DO

!-------- End computation Lidar --------------------------

!---------------------------------------------------------
!  Parasol/Polder module
!
!  Purpose : Compute reflectance for one particular viewing direction
!  and 5 solar zenith angles (calculation valid only over ocean)
! ---------------------------------------------------------

! initialization:
    refl(:,:) = 0.0

! activate parasol calculations:
    if (ok_parasol) then

!     Optical thickness from TOA to surface
      tautot_S_liq = 0.
      tautot_S_ice = 0.
      tautot_S_liq(:) = tautot_S_liq(:) &
         + tau_part(:,1,1) + tau_part(:,1,3)
      tautot_S_ice(:) = tautot_S_ice(:) &
         + tau_part(:,1,2) + tau_part(:,1,4)

      call parasol(npoints,nrefl,undef  &
                 ,tautot_S_liq,tautot_S_ice &
                 ,refl)

    endif ! ok_parasol

  END SUBROUTINE lidar_simulator
!
!---------------------------------------------------------------------------------
!
  SUBROUTINE parasol(npoints,nrefl,undef  &
                       ,tautot_S_liq,tautot_S_ice  &
                       ,refl)
!---------------------------------------------------------------------------------
! Purpose: To compute Parasol reflectance signal from model-simulated profiles 
!          of cloud water and cloud fraction in each sub-column of each model 
!          gridbox.
!
!
! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
! - optimization for vectorization
!
! Version 2.0 (October 2008)
! Version 2.1 (December 2008)
!---------------------------------------------------------------------------------

    IMPLICIT NONE

! inputs
    INTEGER npoints              ! Number of horizontal gridpoints
    INTEGER nrefl                ! Number of angles for which the reflectance 
                                 ! is computed. Can not be greater then ntetas
    REAL undef                   ! Undefined value. Currently not used
    REAL tautot_S_liq(npoints)   ! liquid water cloud optical thickness, 
                                   ! integrated from TOA to surface
    REAL tautot_S_ice(npoints)   ! same for ice water clouds only
! outputs
    REAL refl(npoints,nrefl)     ! Parasol reflectances
!
! Local variables
    REAL tautot_S(npoints)       ! cloud optical thickness, from TOA to surface
    REAL frac_taucol_liq(npoints), frac_taucol_ice(npoints)

    REAL pi
!   look up table variables:
    INTEGER ny, it
    INTEGER ntetas, nbtau        ! number of angle and of optical thickness
                                   ! of the look-up table
    PARAMETER (ntetas=5, nbtau=7)
    REAL aa(ntetas,nbtau-1), ab(ntetas,nbtau-1)
    REAL ba(ntetas,nbtau-1), bb(ntetas,nbtau-1)  
    REAL tetas(ntetas),tau(nbtau)                        
    REAL r_norm(ntetas)
    REAL rlumA(ntetas,nbtau), rlumB(ntetas,nbtau)       
    REAL rlumA_mod(npoints,5), rlumB_mod(npoints,5) 

    DATA tau   /0., 1., 5., 10., 20., 50., 100./
    DATA tetas /0., 20., 40., 60., 80./
    
! Look-up table for spherical liquid particles:
    DATA (rlumA(1,ny),ny=1,nbtau) /0.03, 0.090886, 0.283965, &
     0.480587, 0.695235, 0.908229, 1.0 /
    DATA (rlumA(2,ny),ny=1,nbtau) /0.03, 0.072185, 0.252596, &
      0.436401,  0.631352, 0.823924, 0.909013 /
    DATA (rlumA(3,ny),ny=1,nbtau) /0.03, 0.058410, 0.224707, &
      0.367451,  0.509180, 0.648152, 0.709554 /
    DATA (rlumA(4,ny),ny=1,nbtau) /0.03, 0.052498, 0.175844, &
      0.252916,  0.326551, 0.398581, 0.430405 /
    DATA (rlumA(5,ny),ny=1,nbtau) /0.03, 0.034730, 0.064488, &
      0.081667,  0.098215, 0.114411, 0.121567 /

! Look-up table for ice particles:
    DATA (rlumB(1,ny),ny=1,nbtau) /0.03, 0.092170, 0.311941, &
       0.511298, 0.712079 , 0.898243 , 0.976646 /
    DATA (rlumB(2,ny),ny=1,nbtau) /0.03, 0.087082, 0.304293, &
       0.490879,  0.673565, 0.842026, 0.912966 /
    DATA (rlumB(3,ny),ny=1,nbtau) /0.03, 0.083325, 0.285193, &
      0.430266,  0.563747, 0.685773,  0.737154 /
    DATA (rlumB(4,ny),ny=1,nbtau) /0.03, 0.084935, 0.233450, &
      0.312280, 0.382376, 0.446371, 0.473317 /
    DATA (rlumB(5,ny),ny=1,nbtau) /0.03, 0.054157, 0.089911, &
      0.107854, 0.124127, 0.139004, 0.145269 /

!--------------------------------------------------------------------------------
! Lum_norm=f(tetaS,tau_cloud) derived from adding-doubling calculations
!        valid ONLY ABOVE OCEAN (albedo_sfce=5%)
!        valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�)
!        based on adding-doubling radiative transfer computation
!        for tau values (0 to 100) and for tetas values (0 to 80)
!        for 2 scattering phase functions: liquid spherical, ice non spherical

    IF ( nrefl.GT. ntetas ) THEN
        PRINT *,'Error in lidar_simulator, nrefl should be less then ',ntetas,' not',nrefl
        STOP
    ENDIF

    rlumA_mod=0
    rlumB_mod=0
!
    pi = ACOS(-1.0)
    r_norm(:)=1./ COS(pi/180.*tetas(:))
!
    tautot_S_liq(:)=MAX(tautot_S_liq(:),tau(1))
    tautot_S_ice(:)=MAX(tautot_S_ice(:),tau(1))
    tautot_S(:) = tautot_S_ice(:) + tautot_S_liq(:)
!
! relative fraction of the opt. thick due to liquid or ice clouds
    WHERE (tautot_S(:) .GT. 0.)
        frac_taucol_liq(:) = tautot_S_liq(:) / tautot_S(:)
        frac_taucol_ice(:) = tautot_S_ice(:) / tautot_S(:)
    ELSEWHERE
        frac_taucol_liq(:) = 1.
        frac_taucol_ice(:) = 0.
    END WHERE
    tautot_S(:)=MIN(tautot_S(:),tau(nbtau))
!
! Linear interpolation :

    DO ny=1,nbtau-1
! microphysics A (liquid clouds) 
      aA(:,ny) = (rlumA(:,ny+1)-rlumA(:,ny))/(tau(ny+1)-tau(ny))
      bA(:,ny) = rlumA(:,ny) - aA(:,ny)*tau(ny)
! microphysics B (ice clouds)
      aB(:,ny) = (rlumB(:,ny+1)-rlumB(:,ny))/(tau(ny+1)-tau(ny))
      bB(:,ny) = rlumB(:,ny) - aB(:,ny)*tau(ny)
    ENDDO
!
    DO it=1,ntetas
      DO ny=1,nbtau-1
        WHERE (tautot_S(:).GE.tau(ny).AND.tautot_S(:).LE.tau(ny+1))
            rlumA_mod(:,it) = aA(it,ny)*tautot_S(:) + bA(it,ny)
            rlumB_mod(:,it) = aB(it,ny)*tautot_S(:) + bB(it,ny)
        END WHERE
      END DO
    END DO
!
    DO it=1,ntetas
      refl(:,it) = frac_taucol_liq(:) * rlumA_mod(:,it) &
         + frac_taucol_ice(:) * rlumB_mod(:,it)
! normalized radiance -> reflectance: 
      refl(:,it) = refl(:,it) * r_norm(it)
    ENDDO

    RETURN
  END SUBROUTINE parasol



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: lmd_ipsl_stats.f90,v 1.1.2.1.2.1.6.1 2010/03/04 08:23:49 rsh Exp $
! $Name: hiram_20101115_bw $

! Copyright (c) 2009, Centre National de la Recherche Scientifique
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its
!       contributors may be used to endorse or promote products derived from this software without 
!       specific prior written permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


!------------------------------------------------------------------------------------
! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France).
!------------------------------------------------------------------------------------
MODULE MOD_LMD_IPSL_STATS
  USE MOD_LLNL_STATS
  use mod_cosp_constants
  IMPLICIT NONE

!RSH made module variables so can be accessed from cosp_driver_init for
! use in defining netcdf axes.
! c threshold for cloud detection :
      real S_clr 
      parameter (S_clr = 1.2) 
      real S_cld
!      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
      parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
      real S_att
      parameter (S_att = 0.01)

CONTAINS
      SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl &
                  ,pnorm,pmol,refl,land,pplay,undef,ok_lidar_cfad &
                  ,cfad2,srbval &
                  ,ncat,lidarcld,cldlayer,parasolrefl)
!
! -----------------------------------------------------------------------------------
! Lidar outputs :
! 
! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction
! from the lidar signals (ATB and molecular ATB) computed from model outputs
!      +
! Compute CFADs of lidar scattering ratio SR and of depolarization index
! 
! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France).
!
! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
! - change of the cloud detection threshold S_cld from 3 to 5, for better
! with both day and night observations. The optical thinest clouds are missed.
! - remove of the detection of the first fully attenuated layer encountered from above.
! December 2008, A. Bodas-Salcedo:
! - Dimensions of pmol reduced to (npoints,llm)
! August 2009, A. Bodas-Salcedo:
! - Warning message regarding PARASOL being valid only over ocean deleted.
! February 2010, A. Bodas-Salcedo:
! - Undef passed into cosp_cfad_sr
!
! Version 1.0 (June 2007)
! Version 1.1 (May 2008)
! Version 1.2 (June 2008)
! Version 2.0 (October 2008)
! Version 2.1 (December 2008)
! c------------------------------------------------------------------------------------

! c inputs :
      integer npoints
      integer ncol
      integer llm
      integer max_bin               ! nb of bins for SR CFADs
      integer ncat                  ! nb of cloud layer types (low,mid,high,total)
      integer nrefl                 ! nb of solar zenith angles for parasol reflectances

      real undef                    ! undefined value
      real pnorm(npoints,ncol,llm)  ! lidar ATB 
      real pmol(npoints,llm)        ! molecular ATB
      real land(npoints)            ! Landmask [0 - Ocean, 1 - Land]    
      real pplay(npoints,llm)       ! pressure on model levels (Pa)
      logical ok_lidar_cfad         ! true if lidar CFAD diagnostics need to be computed
      real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol

! c outputs :
      real lidarcld(npoints,llm)     ! 3D "lidar" cloud fraction 
      real cldlayer(npoints,ncat)    ! "lidar" cloud fraction (low, mid, high, total)
      real cfad2(npoints,max_bin,llm) ! CFADs of SR  
      real srbval(max_bin)           ! SR bins in CFADs  
      real parasolrefl(npoints,nrefl)! grid-averaged parasol reflectance


! c local variables :
      integer ic,k
      real x3d(npoints,ncol,llm)
      real x3d_c(npoints,llm),pnorm_c(npoints,llm)
      real xmax
!
! c -------------------------------------------------------
! c 0- Initializations
! c -------------------------------------------------------
!

!  Should be modified in future version
      xmax=undef-1.0

! c -------------------------------------------------------
! c 1- Lidar scattering ratio :
! c -------------------------------------------------------
!
!       where ((pnorm.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) 
!          x3d = pnorm/pmol
!       elsewhere
!           x3d = undef
!       end where
! A.B-S: pmol reduced to 2D (npoints,llm) (Dec 08)
      do ic = 1, ncol
        pnorm_c = pnorm(:,ic,:)
        where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) 
            x3d_c = pnorm_c/pmol
        elsewhere
            x3d_c = undef
        end where
        x3d(:,ic,:) = x3d_c
      enddo

! c -------------------------------------------------------
! c 2- Diagnose cloud fractions (3D, low, middle, high, total)
! c from subgrid-scale lidar scattering ratios :
! c -------------------------------------------------------

      CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,  &
              x3d,pplay, S_att,S_cld,undef,lidarcld, &
              cldlayer)

! c -------------------------------------------------------
! c 3- CFADs 
! c -------------------------------------------------------
      if (ok_lidar_cfad) then
!
! c CFADs of subgrid-scale lidar scattering ratios :
! c -------------------------------------------------------
      CALL COSP_CFAD_SR(npoints,ncol,llm,max_bin, undef, &
                 x3d, &
                 S_att,S_clr,xmax,cfad2,srbval)

      endif   ! ok_lidar_cfad
! c -------------------------------------------------------

! c -------------------------------------------------------
! c 4- Compute grid-box averaged Parasol reflectances
! c -------------------------------------------------------

      parasolrefl(:,:) = 0.0

      do k = 1, nrefl
       do ic = 1, ncol
         parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k)
       enddo
      enddo

      do k = 1, nrefl
        parasolrefl(:,k) = parasolrefl(:,k) / float(ncol)
! if land=1 -> parasolrefl=undef
! if land=0 -> parasolrefl=parasolrefl
        parasolrefl(:,k) = parasolrefl(:,k) * MAX(1.0-land(:),0.0) &
                           + (1.0 - MAX(1.0-land(:),0.0))*undef 
      enddo

      RETURN
      END SUBROUTINE diag_lidar
	  
	  
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-------------------- FUNCTION COSP_CFAD_SR ------------------------
! Author: Sandrine Bony (LMD/IPSL, CNRS, Paris)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      SUBROUTINE COSP_CFAD_SR(Npoints,Ncolumns,Nlevels,Nbins,undef, &
                      x,S_att,S_clr,xmax,cfad,srbval)
      IMPLICIT NONE

!--- Input arguments
! Npoints: Number of horizontal points
! Ncolumns: Number of subcolumns
! Nlevels: Number of levels
! Nbins: Number of x axis bins
! xmax: maximum value allowed for x
! S_att: Threshold for full attenuation
! S_clr: Threshold for clear-sky layer
!
!--- Input-Outout arguments
! x: variable to process (Npoints,Ncolumns,Nlevels), mofified where saturation occurs
!
! -- Output arguments
! srbval : values of the histogram bins
! cfad: 2D histogram on each horizontal point

! Input arguments
      integer Npoints,Ncolumns,Nlevels,Nbins
      real xmax,S_att,S_clr,undef
! Input-output arguments
      real x(Npoints,Ncolumns,Nlevels)
! Output :
      real cfad(Npoints,Nbins,Nlevels)
      real srbval(Nbins)
! Local variables
      integer i, j, k, ib
      real srbval_ext(0:Nbins)

! c -------------------------------------------------------
! c 0- Initializations
! c -------------------------------------------------------
      if ( Nbins .lt. 6) return

      call define_srbval (srbval)



      cfad(:,:,:) = 0.0

      srbval_ext(1:Nbins) = srbval
      srbval_ext(0) = -1.0

! c -------------------------------------------------------
! c c- Compute CFAD
! c -------------------------------------------------------

      do j = 1, Nlevels
        do ib = 1, Nbins
          do i = 1, Npoints
            do k = 1, Ncolumns
              if (x(i,k,j) /= undef) then
                if ((x(i,k,j).gt.srbval_ext(ib-1)).and.(x(i,k,j).le.srbval_ext(ib))) &
                    cfad(i,ib,j) = cfad(i,ib,j) + 1.0
              else
                cfad(i,:,j) = undef
              endif
            enddo
          enddo
        enddo  !k
      enddo  !j
 
      where (cfad .ne. undef)  cfad = cfad / float(Ncolumns)

! c -------------------------------------------------------
      RETURN
      END SUBROUTINE COSP_CFAD_SR


subroutine define_srbval (srbval)

real, dimension(:), intent(out) :: srbval

     integer :: i, Nbins

     Nbins = SR_BINS

     srbval(1) =  S_att
     srbval(2) =  S_clr
     srbval(3) =  3.0
     srbval(4) =  5.0
     srbval(5) =  7.0
     srbval(6) = 10.0
     do i = 7, MIN(10,Nbins)
      srbval(i) = srbval(i-1) + 5.0
     enddo
     DO i = 11, MIN(13,Nbins)
      srbval(i) = srbval(i-1) + 10.0
     enddo
     srbval(MIN(14,Nbins)) = 80.0
     srbval(Nbins) = LIDAR_UNDEF - 1.0

end subroutine define_srbval



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-------------------- SUBROUTINE COSP_CLDFRAC -------------------
! c Purpose: Cloud fraction diagnosed from lidar measurements 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat, &
                  x,pplay,S_att,S_cld,undef,lidarcld, &
                  cldlayer)
      IMPLICIT NONE
! Input arguments
      integer Npoints,Ncolumns,Nlevels,Ncat
      real x(Npoints,Ncolumns,Nlevels)
      real pplay(Npoints,Nlevels)
      real S_att,S_cld
      real undef
! Output :
      real lidarcld(Npoints,Nlevels) ! 3D cloud fraction
      real cldlayer(Npoints,Ncat)    ! low, middle, high, total cloud fractions
! Local variables
      integer ip, k, iz, ic
      real p1
      real cldy(Npoints,Ncolumns,Nlevels)
      real srok(Npoints,Ncolumns,Nlevels)
      real cldlay(Npoints,Ncolumns,Ncat)
      real nsublay(Npoints,Ncolumns,Ncat), nsublayer(Npoints,Ncat)
      real nsub(Npoints,Nlevels)


! ---------------------------------------------------------------
! 1- initialization 
! ---------------------------------------------------------------

      if ( Ncat .ne. 4 ) then
         print *,'Error in lmd_ipsl_stats.cosp_cldfrac, Ncat must be 4, not',Ncat
         stop
      endif

      lidarcld = 0.0
      nsub = 0.0
      cldlay = 0.0
      nsublay = 0.0

! ---------------------------------------------------------------
! 2- Cloud detection
! ---------------------------------------------------------------

      do k = 1, Nlevels

! cloud detection at subgrid-scale:
         where ( (x(:,:,k).gt.S_cld) .and. (x(:,:,k).ne. undef) )
           cldy(:,:,k)=1.0
         elsewhere
           cldy(:,:,k)=0.0
         endwhere

! number of usefull sub-columns:
         where ( (x(:,:,k).gt.S_att) .and. (x(:,:,k).ne. undef)  ) 
           srok(:,:,k)=1.0
         elsewhere
           srok(:,:,k)=0.0
         endwhere

      enddo ! k

! ---------------------------------------------------------------
! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure
! categories) :
! ---------------------------------------------------------------

      do k = Nlevels, 1, -1
       do ic = 1, Ncolumns
        do ip = 1, Npoints

          iz=1
          p1 = pplay(ip,k)
          if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds
            iz=3
          else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then  ! mid clouds
            iz=2
         endif

         cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
         cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
         lidarcld(ip,k)=lidarcld(ip,k) + cldy(ip,ic,k)

         nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
         nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
         nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k)

        enddo
       enddo
      enddo

! -- grid-box 3D cloud fraction

      where ( nsub(:,:).gt.0.0 )
         lidarcld(:,:) = lidarcld(:,:)/nsub(:,:)
      elsewhere
         lidarcld(:,:) = undef
      endwhere

! -- layered cloud fractions

      cldlayer = 0.0
      nsublayer = 0.0

      do iz = 1, Ncat
       do ic = 1, Ncolumns

          cldlayer(:,iz)=cldlayer(:,iz) + cldlay(:,ic,iz)    
          nsublayer(:,iz)=nsublayer(:,iz) + nsublay(:,ic,iz) 

       enddo
      enddo
      where ( nsublayer(:,:).gt.0.0 )
         cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:)
      elsewhere
         cldlayer(:,:) = undef
      endwhere

      RETURN
      END SUBROUTINE COSP_CLDFRAC
! ---------------------------------------------------------------
	  
END MODULE MOD_LMD_IPSL_STATS



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: icarus.f90,v 1.1.2.2 2010/05/24 18:59:16 wfc Exp $
! $Name: hiram_20101115_bw $

      SUBROUTINE ICARUS(          &
     &     debug,                 &
     &     debugcol,              &
     &     npoints,               &
     &     sunlit,                &
     &     nlev,                  &
     &     ncol,                  &
     &     pfull,                 &
     &     phalf,                 &
     &     qv,                    &
     &     cc,                    &
     &     conv,                  &
     &     dtau_s,                &
     &     dtau_c,                &
     &     top_height,            &
     &     top_height_direction,  &
     &     overlap,               &
     &     frac_out,              &
     &     skt,                   &
     &     emsfc_lw,              &
     &     at,                    &
     &     dem_s,                 &
     &     dem_c,                 &
     &     fq_isccp,              &
     &     totalcldarea,          &
     &     meanptop,              &
     &     meantaucld,            &
     &     meanalbedocld,         &
     &     meantb,                &
     &     meantbclr,             &
     &     boxtau,                &
     &     boxptop,               &
     &     dtau_col,              &
     &     dem_col,               &
     &     passing_in_column_data &
     &)

!$Id: icarus.f90,v 1.1.2.2 2010/05/24 18:59:16 wfc Exp $

! *****************************COPYRIGHT****************************
! (c) 2009, Lawrence Livermore National Security Limited Liability 
! Corporation.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without 
! modification, are permitted provided that the
! following conditions are met:
! 
!     * Redistributions of source code must retain the above 
!       copyright  notice, this list of conditions and the following 
!       disclaimer.
!     * Redistributions in binary form must reproduce the above 
!       copyright notice, this list of conditions and the following 
!       disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Lawrence Livermore National Security 
!       Limited Liability Corporation nor the names of its 
!       contributors may be used to endorse or promote products
!       derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 
! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 
! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  
! 
! *****************************COPYRIGHT*******************************
! *****************************COPYRIGHT*******************************
! *****************************COPYRIGHT*******************************
  use mpp_mod,only: get_unit                  
  use fms_mod,only: stdlog, error_mesg, FATAL

      implicit none

!     NOTE:   the maximum number of levels and columns is set by
!             the following parameter statement

      INTEGER ncolprint
      
!     -----
!     Input 
!     -----

      INTEGER npoints       !  number of model points in the horizontal
      INTEGER nlev          !  number of model levels in column
      INTEGER ncol          !  number of subcolumns

      INTEGER sunlit(npoints) !  1 for day points, 0 for night time

      REAL pfull(npoints,nlev)
                       !  pressure of full model levels (Pascals)
                  !  pfull(npoints,1) is top level of model
                  !  pfull(npoints,nlev) is bot of model

      REAL phalf(npoints,nlev+1)
                  !  pressure of half model levels (Pascals)
                  !  phalf(npoints,1) is top of model
                  !  phalf(npoints,nlev+1) is the surface pressure

      REAL qv(npoints,nlev)
                  !  water vapor specific humidity (kg vapor/ kg air)
                  !         on full model levels

      REAL cc(npoints,nlev)   
                  !  input cloud cover in each model level (fraction) 
                  !  NOTE:  This is the HORIZONTAL area of each
                  !         grid box covered by clouds

      REAL conv(npoints,nlev) 
                  !  input convective cloud cover in each model
                  !   level (fraction) 
                  !  NOTE:  This is the HORIZONTAL area of each
                  !         grid box covered by convective clouds

      REAL dtau_s(npoints,nlev) 
                  !  mean 0.67 micron optical depth of stratiform
                !  clouds in each model level
                  !  NOTE:  this the cloud optical depth of only the
                  !  cloudy part of the grid box, it is not weighted
                  !  with the 0 cloud optical depth of the clear
                  !         part of the grid box

      REAL dtau_c(npoints,nlev) 
                  !  mean 0.67 micron optical depth of convective
                !  clouds in each
                  !  model level.  Same note applies as in dtau_s.

      INTEGER overlap                   !  overlap type
                              !  1=max
                              !  2=rand
                              !  3=max/rand

      INTEGER top_height                !  1 = adjust top height using both a computed
                                        !  infrared brightness temperature and the visible
                              !  optical depth to adjust cloud top pressure. Note
                              !  that this calculation is most appropriate to compare
                              !  to ISCCP data during sunlit hours.
                                        !  2 = do not adjust top height, that is cloud top
                                        !  pressure is the actual cloud top pressure
                                        !  in the model
                              !  3 = adjust top height using only the computed
                              !  infrared brightness temperature. Note that this
                              !  calculation is most appropriate to compare to ISCCP
                              !  IR only algortihm (i.e. you can compare to nighttime
                              !  ISCCP data with this option)

      INTEGER top_height_direction ! direction for finding atmosphere pressure level
                                 ! with interpolated temperature equal to the radiance
				 ! determined cloud-top temperature
				 !
				 ! 1 = find the *lowest* altitude (highest pressure) level
				 ! with interpolated temperature equal to the radiance
				 ! determined cloud-top temperature
				 !
				 ! 2 = find the *highest* altitude (lowest pressure) level
				 ! with interpolated temperature equal to the radiance 
				 ! determined cloud-top temperature
				 ! 
				 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
				 !				 !
				 ! 1 = old setting: matches all versions of 
				 ! ISCCP simulator with versions numbers 3.5.1 and lower
				 !
				 ! 2 = default setting: for version numbers 4.0 and higher
!
!     The following input variables are used only if top_height = 1 or top_height = 3
!
      REAL skt(npoints)                 !  skin Temperature (K)
      REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)                                            
      REAL at(npoints,nlev)                   !  temperature in each model level (K)
      REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
                              !  clouds in each
                                        !  model level.  Same note applies as in dtau_s.
      REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
                              !  clouds in each
                                        !  model level.  Same note applies as in dtau_s.

      REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
                              ! Equivalent of BOX in original version, but
                              ! indexed by column then row, rather than
                              ! by row then column

      REAL          dtau_col(npoints,ncol,nlev)  
                              ! tau values obtained from model
                              ! stochastic columns
 
      REAL          dem_col(npoints,ncol,nlev) 
                              ! lw emissivity values obtained
                              ! from model stochastic columns

      LOGICAL    passing_in_column_data   
                              ! tau and emissivity from model columns 
                              ! is passed in ?


!     ------
!     Output
!     ------

      REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
                                        !  each of the 49 ISCCP D level cloud types

      REAL totalcldarea(npoints)        !  the fraction of model grid box columns
                                        !  with cloud somewhere in them.  NOTE: This diagnostic
					! does not count model clouds with tau < isccp_taumin
                              ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
			      ! However, this diagnostic does equal the sum over entries of fq_isccp with
			      ! itau = 2:7 (omitting itau = 1)
      
      
      ! The following three means are averages only over the cloudy areas with tau > isccp_taumin.  
      ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.      
                              
      REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
                                        !  in cloud top pressure.
                              
      REAL meantaucld(npoints)          !  mean optical thickness 
                                        !  linear averaging in albedo performed.
      
      real meanalbedocld(npoints)        ! mean cloud albedo
                                        ! linear averaging in albedo performed
					
      real meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature
      
      real meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature
      
      REAL boxtau(npoints,ncol)         !  optical thickness in each column
      
      REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
                              
                                                                                          
!
!     ------
!     Working variables added when program updated to mimic Mark Webb's PV-Wave code
!     ------

      REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave 
                              !  emissivity in part of
                              !  gridbox under consideration

      REAL ptrop(npoints)
      REAL attrop(npoints)
      REAL attropmin (npoints)
      REAL atmax(npoints)
      REAL btcmin(npoints)
      REAL transmax(npoints)

      INTEGER i,j,ilev,ibox,itrop(npoints)
      INTEGER ipres(npoints)
      INTEGER itau(npoints),ilev2
      INTEGER acc(nlev,ncol)
      INTEGER match(npoints,nlev-1)
      INTEGER nmatch(npoints)
      INTEGER levmatch(npoints,ncol)
      
      !variables needed for water vapor continuum absorption
      real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
      real taumin(npoints)
      real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
      real press(npoints), dpress(npoints), atmden(npoints)
      real rvh20(npoints), wk(npoints), rhoave(npoints)
      real rh20s(npoints), rfrgn(npoints)
      real tmpexp(npoints),tauwv(npoints)
      
      character(len=1) :: cchar(6),cchar_realtops(6)
      integer icycle
      REAL tau(npoints,ncol)
      LOGICAL box_cloudy(npoints,ncol)
      REAL tb(npoints,ncol)
      REAL ptop(npoints,ncol)
      REAL emcld(npoints,ncol)
      REAL fluxtop(npoints,ncol)
      REAL trans_layers_above(npoints,ncol)
      real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
      REAL albedocld(npoints,ncol)
      real boxarea
      integer debug       ! set to non-zero value to print out inputs
                    ! with step debug
      integer debugcol    ! set to non-zero value to print out column
                    ! decomposition with step debugcol
      integer rangevec(npoints),rangeerror

      integer index1(npoints),num1,jj,k1,k2, funit, logunit
      real rec2p13,tauchk,logp,logp1,logp2,atd
      real output_missing_value

      character(len=10) :: ftn09
      
      DATA isccp_taumin / 0.3 /
      DATA output_missing_value / -1.E+30 /
      DATA cchar / ' ','-','1','+','I','+'/
      DATA cchar_realtops / ' ',' ','1','1','I','I'/

!     ------ End duplicate definitions common to wrapper routine

      tauchk = -1.*log(0.9999999)
      rec2p13=1./2.13

      ncolprint=0

      logunit = stdlog()
      if ( debug.ne.0 ) then
          j=1
          write(logunit,'(a10)') 'j='
          write(logunit,'(8I10)') j
          write(logunit,'(a10)') 'debug='
          write(logunit,'(8I10)') debug
          write(logunit,'(a10)') 'debugcol='
          write(logunit,'(8I10)') debugcol
          write(logunit,'(a10)') 'npoints='
          write(logunit,'(8I10)') npoints
          write(logunit,'(a10)') 'nlev='
          write(logunit,'(8I10)') nlev
          write(logunit,'(a10)') 'ncol='
          write(logunit,'(8I10)') ncol
          write(logunit,'(a11)') 'top_height='
          write(logunit,'(8I10)') top_height
	  write(logunit,'(a21)') 'top_height_direction='
          write(logunit,'(8I10)') top_height_direction
          write(logunit,'(a10)') 'overlap='
          write(logunit,'(8I10)') overlap
          write(logunit,'(a10)') 'emsfc_lw='
          write(logunit,'(8f10.2)') emsfc_lw
        do j=1,npoints,debug
          write(logunit,'(a10)') 'j='
          write(logunit,'(8I10)') j
          write(logunit,'(a10)') 'sunlit='
          write(logunit,'(8I10)') sunlit(j)
          write(logunit,'(a10)') 'pfull='
          write(logunit,'(8f10.2)') (pfull(j,i),i=1,nlev)
          write(logunit,'(a10)') 'phalf='
          write(logunit,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
          write(logunit,'(a10)') 'qv='
          write(logunit,'(8f10.3)') (qv(j,i),i=1,nlev)
          write(logunit,'(a10)') 'cc='
          write(logunit,'(8f10.3)') (cc(j,i),i=1,nlev)
          write(logunit,'(a10)') 'conv='
          write(logunit,'(8f10.2)') (conv(j,i),i=1,nlev)
          write(logunit,'(a10)') 'dtau_s='
          write(logunit,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
          write(logunit,'(a10)') 'dtau_c='
          write(logunit,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
          write(logunit,'(a10)') 'skt='
          write(logunit,'(8f10.2)') skt(j)
          write(logunit,'(a10)') 'at='
          write(logunit,'(8f10.2)') (at(j,i),i=1,nlev)
          write(logunit,'(a10)') 'dem_s='
          write(logunit,'(8f10.3)') (dem_s(j,i),i=1,nlev)
          write(logunit,'(a10)') 'dem_c='
          write(logunit,'(8f10.3)') (dem_c(j,i),i=1,nlev)
        enddo
      endif

!     ---------------------------------------------------!

      if (ncolprint.ne.0) then
      do j=1,npoints,1000
        write(logunit,'(a10)') 'j='
        write(logunit,'(8I10)') j
      enddo
      endif

      if (top_height .eq. 1 .or. top_height .eq. 3) then 

      do j=1,npoints 
          ptrop(j)=5000.
          attropmin(j) = 400.
          atmax(j) = 0.
          attrop(j) = 120.
          itrop(j) = 1
      enddo 

      do 12 ilev=1,nlev
        do j=1,npoints 
         if (pfull(j,ilev) .lt. 40000. .and. &
     &          pfull(j,ilev) .gt.  5000. .and. &
     &          at(j,ilev) .lt. attropmin(j)) then
                ptrop(j) = pfull(j,ilev)
                attropmin(j) = at(j,ilev)
                attrop(j) = attropmin(j)
                itrop(j)=ilev
           end if
        enddo
12    continue

      do 13 ilev=1,nlev
        do j=1,npoints
          if (at(j,ilev) .gt. atmax(j) .and. &
     &             ilev  .ge. itrop(j)) atmax(j) = at(j,ilev)
        enddo
13    continue
      end if


      if (top_height .eq. 1 .or. top_height .eq. 3) then
          do j=1,npoints
              meantb(j) = 0.
	      meantbclr(j) = 0. 
          end do
      else
          do j=1,npoints
              meantb(j) = output_missing_value
       	      meantbclr(j) = output_missing_value
          end do
      end if
      
!     -----------------------------------------------------!

!     ---------------------------------------------------!

      do ilev=1,nlev
        do j=1,npoints

          rangevec(j)=0

          if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
!           error = cloud fraction less than zero
!           error = cloud fraction greater than 1
            rangevec(j)=rangevec(j)+1
          endif

          if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
!           ' error = convective cloud fraction less than zero'
!           ' error = convective cloud fraction greater than 1'
            rangevec(j)=rangevec(j)+2
          endif

          if (dtau_s(j,ilev) .lt. 0.) then
!           ' error = stratiform cloud opt. depth less than zero'
            rangevec(j)=rangevec(j)+4
          endif

          if (dtau_c(j,ilev) .lt. 0.) then
!           ' error = convective cloud opt. depth less than zero'
            rangevec(j)=rangevec(j)+8
          endif

          if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
!             ' error = stratiform cloud emissivity less than zero'
!             ' error = stratiform cloud emissivity greater than 1'
            rangevec(j)=rangevec(j)+16
          endif

          if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
!             ' error = convective cloud emissivity less than zero'
!             ' error = convective cloud emissivity greater than 1'
              rangevec(j)=rangevec(j)+32
          endif
        enddo

        rangeerror=0
        do j=1,npoints
            rangeerror=rangeerror+rangevec(j)
        enddo

        if (rangeerror.ne.0) then 
              write (logunit,*) 'Input variable out of range'
              write (logunit,*) 'rangevec:'
              write (logunit,*) rangevec
!             call flush(6)
!              STOP
              call error_mesg('ICARUS','Input variable out of range',FATAL)

        endif
      enddo

!
!     ---------------------------------------------------!

      
!
!     ---------------------------------------------------!
!     COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
!     put into vector tau
 
      !initialize tau and albedocld to zero
      do 15 ibox=1,ncol
        do j=1,npoints 
            tau(j,ibox)=0.
          albedocld(j,ibox)=0.
          boxtau(j,ibox)=output_missing_value
          boxptop(j,ibox)=output_missing_value
          box_cloudy(j,ibox)=.false.
        enddo
15    continue

      !compute total cloud optical depth for each column     
      if (passing_in_column_data) then
        do ilev=1,nlev
            !increment tau for each of the boxes
            do ibox=1,ncol
              do j=1,npoints
                tau(j,ibox)=tau(j,ibox) &
     &                     + dtau_col(j,ibox,ilev)
              enddo
            enddo ! ibox
        enddo ! ilev
 
      else


      do ilev=1,nlev
            !increment tau for each of the boxes
            do ibox=1,ncol
              do j=1,npoints 
                 if (frac_out(j,ibox,ilev).eq.1) then
                        tau(j,ibox)=tau(j,ibox) &
     &                     + dtau_s(j,ilev)
                 endif
                 if (frac_out(j,ibox,ilev).eq.2) then
                        tau(j,ibox)=tau(j,ibox) &
     &                     + dtau_c(j,ilev)
                 end if
              enddo
            enddo ! ibox
      enddo ! ilev

      endif

          if (ncolprint.ne.0) then

              do j=1,npoints ,1000
                write(logunit,'(a10)') 'j='
                write(logunit,'(8I10)') j
                write(logunit,'(i2,1X,8(f7.2,1X))')  &
     &          ilev,                                &
     &          (tau(j,ibox),ibox=1,ncolprint)
              enddo
          endif 
!
!     ---------------------------------------------------!



!     
!     ---------------------------------------------------!
!     COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
!     AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
!
!     again this is only done if top_height = 1 or 3
!
!     fluxtop is the 10.5 micron radiance at the top of the
!              atmosphere
!     trans_layers_above is the total transmissivity in the layers
!             above the current layer
!     fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
!             sky versions of these quantities.

      if (top_height .eq. 1 .or. top_height .eq. 3) then


        !----------------------------------------------------------------------
        !    
        !             DO CLEAR SKY RADIANCE CALCULATION FIRST
        !
        !compute water vapor continuum emissivity
        !this treatment follows Schwarkzopf and Ramasamy
        !JGR 1999,vol 104, pages 9467-9499.
        !the emissivity is calculated at a wavenumber of 955 cm-1, 
        !or 10.47 microns 
        wtmair = 28.9644
        wtmh20 = 18.01534
        Navo = 6.023E+23
        grav = 9.806650E+02
        pstd = 1.013250E+06
        t0 = 296.
        if (ncolprint .ne. 0) &
     &         write(logunit,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
        do 125 ilev=1,nlev
          do j=1,npoints 
               !press and dpress are dyne/cm2 = Pascals *10
               press(j) = pfull(j,ilev)*10.
               dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
               !atmden = g/cm2 = kg/m2 / 10 
               atmden(j) = dpress(j)/grav
               rvh20(j) = qv(j,ilev)*wtmair/wtmh20
               wk(j) = rvh20(j)*Navo*atmden(j)/wtmair
               rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
               rh20s(j) = rvh20(j)*rhoave(j)
               rfrgn(j) = rhoave(j)-rh20s(j)
               tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
               tauwv(j) = wk(j)*1.e-20*(          &
     &           (0.0224697*rh20s(j)*tmpexp(j)) + &
     &                (3.41817e-7*rfrgn(j)) )*0.98
               dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j))
          enddo
               if (ncolprint .ne. 0) then
               do j=1,npoints ,1000
               write(logunit,'(a10)') 'j='
               write(logunit,'(8I10)') j
               write(logunit,'(i2,1X,3(f8.3,3X))') ilev,                 &
     &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), &
     &           tauwv(j),dem_wv(j,ilev)
               enddo
             endif
125     continue

        !initialize variables
        do j=1,npoints 
          fluxtop_clrsky(j) = 0.
          trans_layers_above_clrsky(j)=1.
        enddo

        do ilev=1,nlev
          do j=1,npoints 
 
            ! Black body emission at temperature of the layer

              bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
              !bb(j)= 5.67e-8*at(j,ilev)**4

              ! increase TOA flux by flux emitted from layer
              ! times total transmittance in layers above

                fluxtop_clrsky(j) = fluxtop_clrsky(j) &
     &            + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) 
            
                ! update trans_layers_above with transmissivity
              ! from this layer for next time around loop

                trans_layers_above_clrsky(j)= &
     &            trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev))
                   

          enddo   
            if (ncolprint.ne.0) then
             do j=1,npoints ,1000
              write(logunit,'(a10)') 'j='
              write(logunit,'(8I10)') j
              write (logunit,'(a)') 'ilev:'
              write (logunit,'(I2)') ilev
    
              write (logunit,'(a)') &
     &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
              write (logunit,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), &
     &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
             enddo   
            endif

        enddo   !loop over level
        
        do j=1,npoints 
          !add in surface emission
          bb(j)=1/( exp(1307.27/skt(j)) - 1. )
          !bb(j)=5.67e-8*skt(j)**4

          fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) &
     &     * trans_layers_above_clrsky(j)
     
          !clear sky brightness temperature
          meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
	  
        enddo

        if (ncolprint.ne.0) then
        do j=1,npoints ,1000
          write(logunit,'(a10)') 'j='
          write(logunit,'(8I10)') j
          write (logunit,'(a)') 'id:'
          write (logunit,'(a)') 'surface'

          write (logunit,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
          write (logunit,'(5(f7.2,1X))') emsfc_lw,100.*bb(j), &
     &      100.*fluxtop_clrsky(j), &
     &       trans_layers_above_clrsky(j), meantbclr(j)
        enddo
      endif
    

        !
        !           END OF CLEAR SKY CALCULATION
        !
        !----------------------------------------------------------------



        if (ncolprint.ne.0) then

        do j=1,npoints ,1000
            write(logunit,'(a10)') 'j='
            write(logunit,'(8I10)') j
            write (logunit,'(a)') 'ts:'
            write (logunit,'(8f7.2)') (skt(j),ibox=1,ncolprint)
    
            write (logunit,'(a)') 'ta_rev:'
            write (logunit,'(8f7.2)') &
     &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)

        enddo
        endif 
        !loop over columns 
        do ibox=1,ncol
          do j=1,npoints
            fluxtop(j,ibox)=0.
            trans_layers_above(j,ibox)=1.
          enddo
        enddo

        do ilev=1,nlev
              do j=1,npoints 
                ! Black body emission at temperature of the layer

              bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
              !bb(j)= 5.67e-8*at(j,ilev)**4
              enddo

            do ibox=1,ncol
              do j=1,npoints 

         if (passing_in_column_data) then
               ! emissivity for point in this layer
                if (frac_out(j,ibox,ilev).eq.1 .or. &
     &              frac_out(j,ibox,ilev).eq.2) then
                dem(j,ibox)= 1. - &
     &          ( (1. - dem_wv(j,ilev)) * (1. -  dem_col(j,ibox,ilev)) )
                else
                dem(j,ibox)=  dem_wv(j,ilev)
                end if

         else
              ! emissivity for point in this layer
                if (frac_out(j,ibox,ilev).eq.1) then
                dem(j,ibox)= 1. - &
     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
                else if (frac_out(j,ibox,ilev).eq.2) then
                dem(j,ibox)= 1. - &
     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
                else
                dem(j,ibox)=  dem_wv(j,ilev)
                end if

         endif
                

                ! increase TOA flux by flux emitted from layer
              ! times total transmittance in layers above

                fluxtop(j,ibox) = fluxtop(j,ibox) &
     &            + dem(j,ibox) * bb(j)           &
     &            * trans_layers_above(j,ibox) 
            
                ! update trans_layers_above with transmissivity
              ! from this layer for next time around loop

                trans_layers_above(j,ibox)= &
     &            trans_layers_above(j,ibox)*(1.-dem(j,ibox))

              enddo ! j
            enddo ! ibox

            if (ncolprint.ne.0) then
              do j=1,npoints,1000
              write (logunit,'(a)') 'ilev:'
              write (logunit,'(I2)') ilev
    
              write(logunit,'(a10)') 'j='
              write(logunit,'(8I10)') j
              write (logunit,'(a)') 'emiss_layer:'
              write (logunit,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
        
              write (logunit,'(a)') '100.*bb(j):'
              write (logunit,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
        
              write (logunit,'(a)') '100.*f:'
              write (logunit,'(8f7.2)') &
     &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
        
              write (logunit,'(a)') 'total_trans:'
              write (logunit,'(8f7.2)') &
     &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
            enddo
          endif

        enddo ! ilev


          do j=1,npoints 
            !add in surface emission
            bb(j)=1/( exp(1307.27/skt(j)) - 1. )
            !bb(j)=5.67e-8*skt(j)**4
          end do

        do ibox=1,ncol
          do j=1,npoints 

            !add in surface emission

            fluxtop(j,ibox) = fluxtop(j,ibox) &
     &         + emsfc_lw * bb(j)             &
     &         * trans_layers_above(j,ibox) 
            
          end do
        end do

        !calculate mean infrared brightness temperature
        do ibox=1,ncol
          do j=1,npoints 
            meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox))))
	  end do
        end do
	  do j=1, npoints
	    meantb(j) = meantb(j) / real(ncol)
	  end do        

        if (ncolprint.ne.0) then

          do j=1,npoints ,1000
          write(logunit,'(a10)') 'j='
          write(logunit,'(8I10)') j
          write (logunit,'(a)') 'id:'
          write (logunit,'(a)') 'surface'

          write (logunit,'(a)') 'emiss_layer:'
          write (logunit,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') '100.*bb(j):'
          write (logunit,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
    
          write (logunit,'(a)') '100.*f:'
          write (logunit,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
          
	  write (logunit,'(a)') 'meantb(j):'
          write (logunit,'(8f7.2)') (meantb(j),ibox=1,ncolprint)
      
          end do
      endif
    
        !now that you have the top of atmosphere radiance account
        !for ISCCP procedures to determine cloud top temperature

        !account for partially transmitting cloud recompute flux 
        !ISCCP would see assuming a single layer cloud
        !note choice here of 2.13, as it is primarily ice
        !clouds which have partial emissivity and need the 
        !adjustment performed in this section
        !
      !If it turns out that the cloud brightness temperature
      !is greater than 260K, then the liquid cloud conversion
        !factor of 2.56 is used.
      !
        !Note that this is discussed on pages 85-87 of 
        !the ISCCP D level documentation (Rossow et al. 1996)
           
          do j=1,npoints  
            !compute minimum brightness temperature and optical depth
            btcmin(j) = 1. /  ( exp(1307.27/(attrop(j)-5.)) - 1. ) 
          enddo 
        do ibox=1,ncol
          do j=1,npoints  
            transmax(j) = (fluxtop(j,ibox)-btcmin(j)) &
     &                /(fluxtop_clrsky(j)-btcmin(j))
          !note that the initial setting of tauir(j) is needed so that
          !tauir(j) has a realistic value should the next if block be
          !bypassed
            tauir(j) = tau(j,ibox) * rec2p13
            taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001))

          enddo 

          if (top_height .eq. 1) then
            do j=1,npoints  
              if (transmax(j) .gt. 0.001 .and. &
     &          transmax(j) .le. 0.9999999) then
                fluxtopinit(j) = fluxtop(j,ibox)
              tauir(j) = tau(j,ibox) *rec2p13
              endif
            enddo
            do icycle=1,2
              do j=1,npoints  
                if (tau(j,ibox) .gt. (tauchk            )) then 
                if (transmax(j) .gt. 0.001 .and. &
     &            transmax(j) .le. 0.9999999) then
                  emcld(j,ibox) = 1. - exp(-1. * tauir(j)  )
                  fluxtop(j,ibox) = fluxtopinit(j) -   &
     &              ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
                  fluxtop(j,ibox)=max(1.E-06, &
     &              (fluxtop(j,ibox)/emcld(j,ibox)))
                  tb(j,ibox)= 1307.27 &
     &              / (log(1. + (1./fluxtop(j,ibox))))
                  if (tb(j,ibox) .gt. 260.) then
                  tauir(j) = tau(j,ibox) / 2.56
                  end if                   
                end if
                end if
              enddo
            enddo
                
          endif
        
          do j=1,npoints
            if (tau(j,ibox) .gt. (tauchk            )) then 
                !cloudy box 
		!NOTE: tb is the cloud-top temperature not infrared brightness temperature 
		!at this point in the code
                tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox))))
                if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then
                         tb(j,ibox) = attrop(j) - 5. 
                   tau(j,ibox) = 2.13*taumin(j)
                end if
            else
                !clear sky brightness temperature
                tb(j,ibox) = meantbclr(j)
            end if
          enddo ! j
        enddo ! ibox

        if (ncolprint.ne.0) then

          do j=1,npoints,1000
          write(logunit,'(a10)') 'j='
          write(logunit,'(8I10)') j

          write (logunit,'(a)') 'attrop:'
          write (logunit,'(8f7.2)') (attrop(j))
    
          write (logunit,'(a)') 'btcmin:'
          write (logunit,'(8f7.2)') (btcmin(j))
    
          write (logunit,'(a)') 'fluxtop_clrsky*100:'
          write (logunit,'(8f7.2)') &
     &      (100.*fluxtop_clrsky(j))

          write (logunit,'(a)') '100.*f_adj:'
          write (logunit,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'transmax:'
          write (logunit,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'tau:'
          write (logunit,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'emcld:'
          write (logunit,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'total_trans:'
          write (logunit,'(8f7.2)') &
     &        (trans_layers_above(j,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'total_emiss:'
          write (logunit,'(8f7.2)') &
     &        (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'total_trans:'
          write (logunit,'(8f7.2)') &
     &        (trans_layers_above(j,ibox),ibox=1,ncolprint)
    
          write (logunit,'(a)') 'ppout:'
          write (logunit,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
          enddo ! j
      endif

      end if

!     ---------------------------------------------------!

!     
!     ---------------------------------------------------!
!     DETERMINE CLOUD TOP PRESSURE
!
!     again the 2 methods differ according to whether
!     or not you use the physical cloud top pressure (top_height = 2)
!     or the radiatively determined cloud top pressure (top_height = 1 or 3)
!

      !compute cloud top pressure
      do 30 ibox=1,ncol
        !segregate according to optical thickness
        if (top_height .eq. 1 .or. top_height .eq. 3) then  
          !find level whose temperature
          !most closely matches brightness temperature
          do j=1,npoints 
            nmatch(j)=0
          enddo
          do 29 k1=1,nlev-1
	    if (top_height_direction .eq. 2) then
	      ilev = nlev - k1 
	    else
	      ilev = k1
	    end if
            !cdir nodep
            do j=1,npoints 
	     if (ilev .ge. itrop(j)) then
              if ((at(j,ilev)   .ge. tb(j,ibox) .and. &
     &          at(j,ilev+1) .le. tb(j,ibox)) .or. &
     &          (at(j,ilev) .le. tb(j,ibox) .and. &
     &          at(j,ilev+1) .ge. tb(j,ibox))) then 
                nmatch(j)=nmatch(j)+1
		match(j,nmatch(j))=ilev
              end if  
	     end if                         
            enddo
29        continue

          do j=1,npoints 
            if (nmatch(j) .ge. 1) then
              k1 = match(j,nmatch(j))
	      k2 = k1 + 1
              logp1 = log(pfull(j,k1))
              logp2 = log(pfull(j,k2))
	      atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
              logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
              ptop(j,ibox) = exp(logp)
	      if(abs(pfull(j,k1)-ptop(j,ibox)) .lt. &
     &            abs(pfull(j,k2)-ptop(j,ibox))) then
                 levmatch(j,ibox)=k1
              else
                 levmatch(j,ibox)=k2
              end if   
            else
              if (tb(j,ibox) .le. attrop(j)) then
                ptop(j,ibox)=ptrop(j)
                levmatch(j,ibox)=itrop(j)
              end if
              if (tb(j,ibox) .ge. atmax(j)) then
                ptop(j,ibox)=pfull(j,nlev)
                levmatch(j,ibox)=nlev
              end if                                
            end if
          enddo ! j

        else ! if (top_height .eq. 1 .or. top_height .eq. 3) 
 
          do j=1,npoints     
            ptop(j,ibox)=0.
          enddo
          do ilev=1,nlev
            do j=1,npoints     
              if ((ptop(j,ibox) .eq. 0. ) &
     &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
                ptop(j,ibox)=phalf(j,ilev)
              levmatch(j,ibox)=ilev
              end if
            end do
          end do
        end if                            
          
        do j=1,npoints
          if (tau(j,ibox) .le. (tauchk            )) then
            ptop(j,ibox)=0.
            levmatch(j,ibox)=0      
          endif 
        enddo

30    continue
              
!
!
!     ---------------------------------------------------!


!     
!     ---------------------------------------------------!
!     DETERMINE ISCCP CLOUD TYPE FREQUENCIES
!
!     Now that ptop and tau have been determined, 
!     determine amount of each of the 49 ISCCP cloud
!     types
!
!     Also compute grid box mean cloud top pressure and
!     optical thickness.  The mean cloud top pressure and
!     optical thickness are averages over the cloudy 
!     area only. The mean cloud top pressure is a linear
!     average of the cloud top pressures.  The mean cloud
!     optical thickness is computed by converting optical
!     thickness to an albedo, averaging in albedo units,
!     then converting the average albedo back to a mean
!     optical thickness.  
!

      !compute isccp frequencies

      !reset frequencies
      do 38 ilev=1,7
      do 38 ilev2=1,7
        do j=1,npoints ! 
             if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
                fq_isccp(j,ilev,ilev2)= 0.
	     else
	        fq_isccp(j,ilev,ilev2)= output_missing_value
	     end if
        enddo
38    continue

      !reset variables need for averaging cloud properties
      do j=1,npoints 
        if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
             totalcldarea(j) = 0.
             meanalbedocld(j) = 0.
             meanptop(j) = 0.
             meantaucld(j) = 0.
	else
             totalcldarea(j) = output_missing_value
             meanalbedocld(j) = output_missing_value
             meanptop(j) = output_missing_value
             meantaucld(j) = output_missing_value
	end if
      enddo ! j

      boxarea = 1./real(ncol)
     
      do 39 ibox=1,ncol
        do j=1,npoints 

          if (tau(j,ibox) .gt. (tauchk            ) &
     &      .and. ptop(j,ibox) .gt. 0.) then
              box_cloudy(j,ibox)=.true.
          endif

          if (box_cloudy(j,ibox)) then

              if (sunlit(j).eq.1 .or. top_height .eq. 3) then

                boxtau(j,ibox) = tau(j,ibox)

		if (tau(j,ibox) .ge. isccp_taumin) then
		   totalcldarea(j) = totalcldarea(j) + boxarea
		
                   !convert optical thickness to albedo
                   albedocld(j,ibox) &
     &		   = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82)
         
                   !contribute to averaging
                   meanalbedocld(j) = meanalbedocld(j)  &
     &                                +albedocld(j,ibox)*boxarea

                end if

            endif

          endif

          if (sunlit(j).eq.1 .or. top_height .eq. 3) then 

           if (box_cloudy(j,ibox)) then
          
              !convert ptop to millibars
              ptop(j,ibox)=ptop(j,ibox) / 100.
            
              !save for output cloud top pressure and optical thickness
              boxptop(j,ibox) = ptop(j,ibox)
    
              if (tau(j,ibox) .ge. isccp_taumin) then
	      	meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
              end if		

              !reset itau(j), ipres(j)
              itau(j) = 0
              ipres(j) = 0

              !determine optical depth category
              if (tau(j,ibox) .lt. isccp_taumin) then
                  itau(j)=1
              else if (tau(j,ibox) .ge. isccp_taumin &
     &          .and. tau(j,ibox) .lt. 1.3) then
                itau(j)=2
              else if (tau(j,ibox) .ge. 1.3 &
     &          .and. tau(j,ibox) .lt. 3.6) then
                itau(j)=3
              else if (tau(j,ibox) .ge. 3.6 &
     &          .and. tau(j,ibox) .lt. 9.4) then
                  itau(j)=4
              else if (tau(j,ibox) .ge. 9.4 &
     &          .and. tau(j,ibox) .lt. 23.) then
                  itau(j)=5
              else if (tau(j,ibox) .ge. 23. &
     &          .and. tau(j,ibox) .lt. 60.) then
                  itau(j)=6
              else if (tau(j,ibox) .ge. 60.) then
                  itau(j)=7
              end if

              !determine cloud top pressure category
              if (    ptop(j,ibox) .gt. 0.   &
     &          .and.ptop(j,ibox) .lt. 180.) then
                  ipres(j)=1
              else if(ptop(j,ibox) .ge. 180. &
     &          .and.ptop(j,ibox) .lt. 310.) then
                  ipres(j)=2
              else if(ptop(j,ibox) .ge. 310. &
     &          .and.ptop(j,ibox) .lt. 440.) then
                  ipres(j)=3
              else if(ptop(j,ibox) .ge. 440. &
     &          .and.ptop(j,ibox) .lt. 560.) then
                  ipres(j)=4
              else if(ptop(j,ibox) .ge. 560. &
     &          .and.ptop(j,ibox) .lt. 680.) then
                  ipres(j)=5
              else if(ptop(j,ibox) .ge. 680. &
     &          .and.ptop(j,ibox) .lt. 800.) then
                  ipres(j)=6
              else if(ptop(j,ibox) .ge. 800.) then
                  ipres(j)=7
              end if 

              !update frequencies
              if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then
              fq_isccp(j,itau(j),ipres(j))= &
     &          fq_isccp(j,itau(j),ipres(j))+ boxarea
              end if

            end if

          end if
                       
        enddo ! j
39    continue
      
      !compute mean cloud properties
      do j=1,npoints 
        if (totalcldarea(j) .gt. 0.) then
	  ! code above guarantees that totalcldarea > 0 
	  ! only if sunlit .eq. 1 .or. top_height = 3 
	  ! and applies only to clouds with tau > isccp_taumin
          meanptop(j) = meanptop(j) / totalcldarea(j)
          meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
          meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895)
	else
	  ! this code is necessary so that in the case that totalcldarea = 0.,
	  ! that these variables, which are in-cloud averages, are set to missing
	  ! note that totalcldarea will be 0. if all the clouds in the grid box have
	  ! tau < isccp_taumin 
	  meanptop(j) = output_missing_value
          meanalbedocld(j) = output_missing_value
          meantaucld(j) = output_missing_value
        end if
      enddo ! j
!
!     ---------------------------------------------------!

!     ---------------------------------------------------!
!     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
!
      if (debugcol.ne.0) then
!     
         do j=1,npoints,debugcol

            !produce character output
            do ilev=1,nlev
              do ibox=1,ncol
                   acc(ilev,ibox)=0
              enddo
            enddo

            do ilev=1,nlev
              do ibox=1,ncol
                   acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
                   if (levmatch(j,ibox) .eq. ilev) &
     &                 acc(ilev,ibox)=acc(ilev,ibox)+1
              enddo
            enddo

             !print test

          write(ftn09,11) j
11        format('ftn09.',i4.4)
          funit = get_unit()
          open(funit, FILE=ftn09, FORM='FORMATTED')

             write(funit,'(a1)') ' '
             write(funit,'(10i5)')  &
     &                  (ilev,ilev=5,nlev,5)
             write(funit,'(a1)') ' '
             
             do ibox=1,ncol
               write(funit,'(40(a1),1x,40(a1))')                &
     &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) &
     &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 
             end do
             close(funit)

             if (ncolprint.ne.0) then
               write(logunit,'(a1)') ' '
                    write(logunit,'(a2,1X,5(a7,1X),a50)') &
     &                  'ilev',                           &
     &                  'pfull','at',                     &
     &                  'cc*100','dem_s','dtau_s',        &
     &                  'cchar'

!               do 4012 ilev=1,nlev
!                    write(logunit,'(60i2)') (box(i,ilev),i=1,ncolprint)
!                   write(logunit,'(i2,1X,5(f7.2,1X),50(a1))') 
!     &                  ilev,
!     &                  pfull(j,ilev)/100.,at(j,ilev),
!     &                  cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
!     &                  ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
!4012           continue
               write (logunit,'(a)') 'skt(j):'
               write (logunit,'(8f7.2)') skt(j)
                                      
               write (logunit,'(8I7)') (ibox,ibox=1,ncolprint)
            
               write (logunit,'(a)') 'tau:'
               write (logunit,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
    
               write (logunit,'(a)') 'tb:'
               write (logunit,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
    
               write (logunit,'(a)') 'ptop:'
               write (logunit,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
             endif 
    
        enddo
       
      end if 

      return
      end 




 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
 
! $Id: cosp_radar.f90,v 1.1.2.1.4.1.6.1.2.1 2010/09/08 21:23:39 wfc Exp $
! $Name: hiram_20101115_bw $

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

MODULE MOD_COSP_RADAR
  USE MOD_COSP_CONSTANTS
  USE MOD_COSP_TYPES
  USE MOD_COSP_UTILS
  use radar_simulator_types
  use array_lib
  use atmos_lib
  use format_input
  IMPLICIT NONE
  
  INTERFACE
    subroutine radar_simulator(me,freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
        nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, &
        rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, &
        g_to_vol_in,g_to_vol_out)
  
        use m_mrgrnk 
        use array_lib
        use math_lib
        use optics_lib
        use radar_simulator_types
        implicit none
        ! ----- INPUTS -----  
        integer, intent(in) :: me
        type(mie), intent(in) :: mt
        type(class_param) :: hp
        real*8, intent(in) :: freq,k2
        integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
            nhclass,nprof,ngate,nsizes
        real*8, dimension(nsizes), intent(in) :: D
        real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
            t_matrix,rh_matrix
        real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
        real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
        ! ----- OUTPUTS -----
        real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
            g_atten_to_vol,dBZe,h_atten_to_vol    
        ! ----- OPTIONAL -----
        real*8, optional, dimension(ngate,nprof) :: &
            g_to_vol_in,g_to_vol_out
     end subroutine radar_simulator
  END INTERFACE

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------------- SUBROUTINE COSP_RADAR ------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_RADAR(me, gbx,sgx,sghydro,z)
  IMPLICIT NONE

  ! Arguments
  integer, intent(in) :: me
  type(cosp_gridbox),intent(inout) :: gbx  ! Gridbox info
  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
  type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid

  ! Local variables 
  integer :: & 
  nsizes			! num of discrete drop sizes

  real*8 :: &
  freq, &			! radar frequency (GHz)
  k2 				! |K|^2, -1=use frequency dependent default
  
  real*8, dimension(:,:), allocatable :: &
  g_to_vol ! integrated atten due to gases, r>v (dB)
  
  real*8, dimension(:,:), allocatable :: &
  Ze_non, &			! radar reflectivity withOUT attenuation (dBZ)
  Ze_ray, &			! Rayleigh reflectivity (dBZ)
  h_atten_to_vol, &		! attenuation by hydromets, radar to vol (dB)
  g_atten_to_vol, &		! gaseous atteunation, radar to vol (dB)
  dBZe, &			! effective radar reflectivity factor (dBZ)
  hgt_matrix, &			! height of hydrometeors (km)
  t_matrix, &                   !temperature (k)
  p_matrix, &                   !pressure (hPa)
  rh_matrix                     !relative humidity (%)
  
  real*8, dimension(:,:,:), allocatable :: &
  hm_matrix, &			! hydrometeor mixing ratio (g kg^-1)
  re_matrix

  integer, parameter :: one = 1
  logical :: hgt_reversed
  integer :: pr,i,j,k,unt

! ----- main program settings ------

  freq = gbx%radar_freq
  k2 = gbx%k2
 
  !
  ! note:  intitialization section that was here has been relocated to SUBROUTINE CONSTRUCT_COSP_GRIDBOX by roj, Feb 2008
  !
  mt_ttl=gbx%mt_ttl  ! these variables really should be moved into the mt structure rather than kept as global arrays.
  mt_tti=gbx%mt_tti

  ! Inputs to Quickbeam
  allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), &
           t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels))
  allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) 
  allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))

  ! Outputs from Quickbeam
  allocate(Ze_non(gbx%Npoints,gbx%Nlevels))
  allocate(Ze_ray(gbx%Npoints,gbx%Nlevels))
  allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels))
  allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels))
  allocate(dBZe(gbx%Npoints,gbx%Nlevels))
  
  ! Optional argument. It is computed and returned in the first call to
  ! radar_simulator, and passed as input in the rest
  allocate(g_to_vol(gbx%Nlevels,gbx%Npoints))
  
  p_matrix   = gbx%p/100.0     ! From Pa to hPa
  hgt_matrix = gbx%zlev/1000.0 ! From m to km
  t_matrix   = gbx%T-273.15    ! From K to C
  rh_matrix  = gbx%q
  re_matrix  = 0.0
  
  ! Quickbeam assumes the first row is closest to the radar
  call order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
      rh_matrix,gbx%surface_radar,hgt_reversed)
  
  ! ----- loop over subcolumns -----
  do pr=1,sgx%Ncolumns
      !  atmospheric profiles are the same within the same gridbox
      !  only hydrometeor profiles will be different
      if (hgt_reversed) then  
         do i=1,gbx%Nhydro  
            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,gbx%Nlevels:1:-1,i)*1000.0 ! Units from kg/kg to g/kg
            if (gbx%use_reff) then
              re_matrix(i,:,:) = sghydro%Reff(:,pr,gbx%Nlevels:1:-1,i)*1.e6     ! Units from m to micron
            endif
         enddo  
      else  
         do i=1,gbx%Nhydro
            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg
            if (gbx%use_reff) then
              re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6       ! Units from m to micron
            endif
         enddo
      endif  

      !   ----- call radar simulator -----
      if (pr == 1) then ! Compute gaseous attenuation for all profiles
         call radar_simulator(me,freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &    !  v0.2: mt changed to gbx%mt, roj
           gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &                         !  v0.2: hp->gbx%hp, D->gbx%d, nsizes->gbx%nsizes, roj
           hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, &
           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol)
      else ! Use gaseous atteunuation for pr = 1
         call radar_simulator(me, freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &
           gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &
           hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, &
           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol)
      endif
      ! ----- BEGIN output section -----
      ! spaceborne radar : from TOA to SURFACE
      if (gbx%surface_radar == 1) then
        z%Ze_tot(:,pr,:)=dBZe(:,:)
      else if (gbx%surface_radar == 0) then ! Spaceborne
        z%Ze_tot(:,pr,:)=dBZe(:,gbx%Nlevels:1:-1)
      endif

  enddo !pr
  
  ! Change undefined value to one defined in COSP
  where (z%Ze_tot == -999.0) z%Ze_tot = R_UNDEF

  deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix)
  deallocate(hm_matrix,re_matrix, &
      Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe)
  deallocate(g_to_vol)
 
  ! deallocate(mt_ttl,mt_tti)	!v0.2: roj feb 2008 can not be done here,
                                !these variables now part of gbx structure and dealocated later

END SUBROUTINE COSP_RADAR

END MODULE MOD_COSP_RADAR



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: llnl_stats.f90,v 1.1.2.1.2.1.6.1 2010/03/04 08:23:49 rsh Exp $
! $Name: hiram_20101115_bw $

! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list 
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation 
!       nor the names of its contributors may be used to endorse or promote products derived from 
!       this software without specific prior written permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

MODULE MOD_LLNL_STATS
  USE MOD_COSP_CONSTANTS
  IMPLICIT NONE

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-------------------- FUNCTION COSP_CFAD ------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth)
   ! Input arguments
   integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins
   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x
   real,intent(in) :: xmin,xmax 
   real,intent(in) :: bmin,bwidth
   
   real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad
   ! Local variables
   integer :: i, j, k
   integer :: ibin
   
   !--- Input arguments
   ! Npoints: Number of horizontal points
   ! Ncolumns: Number of subcolumns
   ! Nlevels: Number of levels
   ! Nbins: Number of x axis bins
   ! x: variable to process (Npoints,Ncolumns,Nlevels)
   ! xmin: minimum value allowed for x
   ! xmax: minimum value allowed for x
   ! bmin: mimumum value of first bin
   ! bwidth: bin width
   !
   ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels)
   
   cosp_cfad = 0.0
   ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth]
   ! Valid x values smaller than bmin and larger than bmax are set 
   ! into the smallest bin and largest bin, respectively.
   do j = 1, Nlevels, 1
      do k = 1, Ncolumns, 1
         do i = 1, Npoints, 1 
            if (x(i,k,j) == R_GROUND) then
               cosp_cfad(i,:,j) = R_UNDEF
            elseif ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then 
               ibin = ceiling((x(i,k,j) - bmin)/bwidth)
               if (ibin > Nbins) ibin = Nbins
               if (ibin < 1)     ibin = 1
               cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 
            end if
         enddo  !i
      enddo  !k
   enddo  !j
   where ((cosp_cfad /= R_UNDEF).and.(cosp_cfad /= 0.0)) cosp_cfad = cosp_cfad / Ncolumns
END FUNCTION COSP_CFAD

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
   ! Input arguments
   integer,intent(in) :: Npoints,Ncolumns,Nlevels
   real,dimension(Npoints,Nlevels),intent(in) :: beta_mol   ! Molecular backscatter
   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot   ! Total backscattered signal
   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot     ! Radar reflectivity
   ! Output arguments
   real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud
   real,dimension(Npoints),intent(out) :: tcc
   
   ! local variables
   real :: sc_ratio
   real :: s_cld, s_att
!      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
   parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
   parameter (s_att = 0.01)
   integer :: flag_sat !first saturated level encountered from top
   integer :: flag_cld !cloudy column
   integer :: pr,i,j
   
     lidar_only_freq_cloud = 0.0
     tcc = 0.0
   do pr=1,Npoints
     do i=1,Ncolumns
       flag_sat = 0
       flag_cld = 0
       do j=Nlevels,1,-1 !top->surf
        sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
!         if ((pr == 1).and.(j==8)) print *, pr,i,j,sc_ratio,Ze_tot(pr,i,j)
        if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
        if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
         if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
!             if ((pr == 1).and.(j==8)) print *, 'L'
            lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
            flag_cld=1
         endif
        else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
!            if ((pr == 1).and.(j==8)) print *, 'R'
           flag_cld=1
        endif
       enddo !levels
       if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1.
     enddo !columns
!      if (tcc(pr) > Ncolumns) then
!      print *, 'tcc(',pr,'): ', tcc(pr)
!      tcc(pr) = Ncolumns
!      endif
   enddo !points
   lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns
   tcc=tcc/Ncolumns

END SUBROUTINE COSP_LIDAR_ONLY_CLOUD
END MODULE MOD_LLNL_STATS


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------

! $Id: modis_simulator.f90,v 1.1.2.1.2.1.6.4 2010/06/03 18:39:51 wfc Exp $
! $Name: hiram_20101115_bw $


! (c) 2009-2010, Regents of the Unversity of Colorado
!   Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!

!
! History:
!   May 2009 - Robert Pincus - Initial version
!   June 2009 - Steve Platnick and Robert Pincus - Simple radiative transfer for size retrievals
!   August 2009 - Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) 
!   November 2009 - Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler using AM2 (GFDL) 
!   January 2010 - Robert Pincus - Added high, middle, low cloud fractions
!

!
! Notes on using the MODIS simulator: 
!  *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1 microns, or 
!     optical thickness at 0.67 microns and ice- and liquid-water contents (in consistent units of 
!     your choosing)
!  *) Required input also includes the optical thickness and cloud top pressure 
!     derived from the ISCCP simulator run with parameter top_height = 1. 
!  *) Cloud particle sizes are specified as radii, measured in meters, though within the module we 
!     use units of microns. Where particle sizes are outside the bounds used in the MODIS retrieval
!     libraries (parameters re_water_min, re_ice_min, etc.) the simulator returns missing values (re_fill)

!
! When error conditions are encountered this code calls the function complain_and_die, supplied at the 
!   bottom of this module. Users probably want to replace this with something more graceful. 
!
module mod_modis_sim
  use MOD_COSP_TYPES, only : R_UNDEF
  use fms_mod, only : error_mesg, FATAL
  implicit none
  ! ------------------------------
  ! Algorithmic parameters
  !
 
  real, parameter :: ice_density          = 0.93               ! liquid density is 1.  
  !
  ! Retrieval parameters
  !
  real, parameter :: min_OpticalThickness = 0.3,             & ! Minimum detectable optical thickness
                     CO2Slicing_PressureLimit = 700. * 100., & ! Cloud with higher pressures use thermal methods, units Pa
                     CO2Slicing_TauLimit = 1.,               & ! How deep into the cloud does CO2 slicing see? 
                     phase_TauLimit      = 1.,               & ! How deep into the cloud does the phase detection see?
                     size_TauLimit       = 2.,               & ! Depth of the re retreivals
                     phaseDiscrimination_Threshold = 0.7       ! What fraction of total extincton needs to be 
                                                               !  in a single category to make phase discrim. work? 
  real,    parameter :: re_fill= -999.
  integer, parameter :: phaseIsNone = 0, phaseIsLiquid = 1, phaseIsIce = 2, phaseIsUndetermined = 3
  
  logical, parameter :: useSimpleReScheme = .false. 
  !
  ! These are the limits of the libraries for the MODIS collection 5 algorithms 
  !   They are also the limits used in the fits for g and w0
  !
  real,    parameter :: re_water_min= 4., re_water_max= 30., re_ice_min= 5., re_ice_max= 90.
  integer, parameter :: num_trial_res = 15             ! increase to make the linear pseudo-retrieval of size more accurate
  logical, parameter :: use_two_re_iterations = .false. ! do two retrieval iterations? 
  
  !
  ! Precompute near-IR optical params vs size for retrieval scheme
  !
  integer, private :: i 
  real, dimension(num_trial_res), parameter :: & 
        trial_re_w = re_water_min + (re_water_max - re_water_min)/(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /), &
        trial_re_i = re_ice_min   + (re_ice_max -   re_ice_min)  /(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /)
  
  ! Can't initialze these during compilation, but do in before looping columns in retrievals
  real, dimension(num_trial_res) ::  g_w, g_i, w0_w, w0_i
  ! ------------------------------
  ! Bin boundaries for the joint optical thickness/cloud top pressure histogram
  !
  integer, parameter :: numTauHistogramBins = 6, numPressureHistogramBins = 7

  real, private :: dummy_real 
  real, dimension(numTauHistogramBins + 1),      parameter :: &
    tauHistogramBoundaries = (/ min_OpticalThickness, 1.3, 3.6, 9.4, 23., 60., huge(dummy_real) /) 
  real, dimension(numPressureHistogramBins + 1), parameter :: & ! Units Pa 
    pressureHistogramBoundaries = (/ 0., 180., 310., 440., 560., 680., 800., huge(dummy_real) /) * 100. 
  real, parameter :: highCloudPressureLimit = 440. * 100., lowCloudPressureLimit = 680.  * 100.

  !
  ! For output - nominal bin centers and  bin boundaries. On output pressure bins are highest to lowest. 
  !
  integer, private :: k, l
  real, parameter, dimension(2, numTauHistogramBins) ::   &
    nominalTauHistogramBoundaries =                       &
        reshape(source = (/ tauHistogramBoundaries(1),    &
                            ((tauHistogramBoundaries(k), l = 1, 2), k = 2, numTauHistogramBins), &
                            100000. /),                    &
                shape = (/2,  numTauHistogramBins /) )
  real, parameter, dimension(numTauHistogramBins) ::                    &
    nominalTauHistogramCenters = (nominalTauHistogramBoundaries(1, :) + &
                                  nominalTauHistogramBoundaries(2, :) ) / 2.
  
  real, parameter, dimension(2, numPressureHistogramBins) :: &
    nominalPressureHistogramBoundaries =                     &
        reshape(source = (/ 100000.,                         &
                            ((pressureHistogramBoundaries(k), l = 1, 2), k = numPressureHistogramBins, 2, -1), &
                            0.  /), &
                shape = (/2,  numPressureHistogramBins /) )
  real, parameter, dimension(numPressureHistogramBins) ::                         &
    nominalPressureHistogramCenters = (nominalPressureHistogramBoundaries(1, :) + &
                                       nominalPressureHistogramBoundaries(2, :) ) / 2.
  ! ------------------------------
  ! There are two ways to call the MODIS simulator: 
  !  1) Provide total optical thickness and liquid/ice water content and we'll partition tau in 
  !     subroutine modis_L2_simulator_oneTau, or 
  !  2) Provide ice and liquid optical depths in each layer
  !
  interface modis_L2_simulator
    module procedure modis_L2_simulator_oneTau, modis_L2_simulator_twoTaus
  end interface 
contains
  !------------------------------------------------------------------------------------------------
  ! MODIS simulator using specified liquid and ice optical thickness in each layer 
  !
  !   Note: this simulator operates on all points; to match MODIS itself night-time 
  !     points should be excluded
  !
  !   Note: the simulator requires as input the optical thickness and cloud top pressure 
  !     derived from the ISCCP simulator run with parameter top_height = 1. 
  !     If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing 
  !     and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that 
  !     alogrithm in this simulator we simply report the values from the ISCCP simulator. 
  !
  subroutine modis_L2_simulator_twoTaus(                                       &
                                temp, pressureLayers, pressureLevels,          &
                                liquid_opticalThickness, ice_opticalThickness, &
                                waterSize, iceSize,                            & 
                                isccpTau, isccpCloudTopPressure,               &
                                retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)

    ! Grid-mean quantities at layer centers, starting at the model top
    !   dimension nLayers
    real, dimension(:),    intent(in ) :: temp,           & ! Temperature, K
                                          pressureLayers, & ! Pressure, Pa
                                          pressureLevels    ! Pressure at layer edges, Pa (dimension nLayers + 1) 
    ! Sub-column quantities
    !   dimension  nSubcols, nLayers
    real, dimension(:, :), intent(in ) :: liquid_opticalThickness, & ! Layer optical thickness @ 0.67 microns due to liquid
                                          ice_opticalThickness       ! ditto, due to ice
    real, dimension(:, :), intent(in ) :: waterSize,        & ! Cloud drop effective radius, microns
                                          iceSize             ! Cloud ice effective radius, microns
                                          
    ! Cloud properties retrieved from ISCCP using top_height = 1
    !    dimension nSubcols
    real, dimension(:),    intent(in ) :: isccpTau, &           ! Column-integrated optical thickness 
                                          isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) 

    ! Properties retrieved by MODIS
    !   dimension nSubcols
    integer, dimension(:), intent(out) :: retrievedPhase               ! liquid/ice/other - integer, defined in module header
    real,    dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers
                                          retrievedTau,              & ! unitless
                                          retrievedSize                ! microns 
    ! ---------------------------------------------------
    ! Local variables
    logical, dimension(size(retrievedTau))                     :: cloudMask
    real,    dimension(size(waterSize, 1), size(waterSize, 2)) :: tauLiquidFraction, tauTotal
    real    :: integratedLiquidFraction
    integer :: i, j,  nSubcols, nLevels

    ! ---------------------------------------------------
    nSubcols = size(liquid_opticalThickness, 1)
    nLevels  = size(liquid_opticalThickness, 2) 
 
    !
    ! Initial error checks 
    !   
    if(any((/ size(ice_opticalThickness, 1), size(waterSize, 1), size(iceSize, 1), &
              size(isccpTau), size(isccpCloudTopPressure),              &
              size(retrievedPhase), size(retrievedCloudTopPressure),    &
              size(retrievedTau), size(retrievedSize) /) /= nSubcols )) &
!      call complain_and_die("Differing number of subcolumns in one or more arrays") 
       call error_mesg ('modis_L2_simulator_two_taus', &
          'Differing number of subcolumns in one or more arrays', FATAL) 
    
    if(any((/ size(ice_opticalThickness, 2), size(waterSize, 2), size(iceSize, 2),      &
              size(temp), size(pressureLayers), size(pressureLevels)-1 /) /= nLevels )) &
!      call complain_and_die("Differing number of levels in one or more arrays") 
       call error_mesg ('modis_L2_simulator_two_taus', &
            'Differing number of levels in one or more arrays', FATAL) 
       
       
    if(any( (/ any(temp <= 0.), any(pressureLayers <= 0.),  &
               any(liquid_opticalThickness < 0.),           &
               any(ice_opticalThickness < 0.),              &
               any(waterSize < 0.), any(iceSize < 0.) /) )) &
!      call complain_and_die("Input values out of bounds") 
       call error_mesg ('modis_L2_simulator_two_taus', &
                             'Input values out of bounds', FATAL) 
             
    ! ---------------------------------------------------
    !
    ! Compute the total optical thickness and the proportion due to liquid in each cell
    !
    where(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) > 0.) 
      tauLiquidFraction(:, :) = liquid_opticalThickness(:, :)/(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :))
    elsewhere
      tauLiquidFraction(:, :) = 0. 
    end  where 
    tauTotal(:, :) = liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) 
    
    !
    ! Optical depth retrieval 
    !   This is simply a sum over the optical thickness in each layer 
    !   It should agree with the ISCCP values after min values have been excluded 
    !
    retrievedTau(:) = sum(tauTotal(:, :), dim = 2)

    !
    ! Cloud detection - does optical thickness exceed detection threshold? 
    !
    cloudMask = retrievedTau(:) >= min_OpticalThickness
    
    !
    ! Initialize initial estimates for size retrievals
    !
    if(any(cloudMask) .and. .not. useSimpleReScheme) then 
      g_w(:)  = get_g_nir(  phaseIsLiquid, trial_re_w(:))
      w0_w(:) = get_ssa_nir(phaseIsLiquid, trial_re_w(:))
      g_i(:)  = get_g_nir(  phaseIsIce,    trial_re_i(:))
      w0_i(:) = get_ssa_nir(phaseIsIce,    trial_re_i(:))
    end if 
    
    do i = 1, nSubCols
      if(cloudMask(i)) then 
        !
        ! Cloud top pressure determination 
        !   MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal methods for clouds
        !   lower than that. 
        !  For CO2 slicing we report the optical-depth weighted pressure, integrating to a specified 
        !    optical depth
        ! This assumes linear variation in p between levels. Linear in ln(p) is probably better, 
        !   though we'd need to deal with the lowest pressure gracefully. 
        !
        retrievedCloudTopPressure(i) = cloud_top_pressure((/ 0., tauTotal(i, :) /), &
                                                          pressureLevels,           &
                                                          CO2Slicing_TauLimit)  
        
        
        !
        ! Phase determination - determine fraction of total tau that's liquid 
        ! When ice and water contribute about equally to the extinction we can't tell 
        !   what the phase is 
        !
        integratedLiquidFraction = weight_by_extinction(tauTotal(i, :),          &
                                                        tauLiquidFraction(i, :), &
                                                        phase_TauLimit)
        if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then 
          retrievedPhase(i) = phaseIsLiquid
        else if (integratedLiquidFraction <= 1.- phaseDiscrimination_Threshold) then 
          retrievedPhase(i) = phaseIsIce
        else 
          retrievedPhase(i) = phaseIsUndetermined
        end if 
        
        !
        ! Size determination 
        !
        if(useSimpleReScheme) then 
          !   This is the extinction-weighted size considering only the phase we've chosen 
          !
          if(retrievedPhase(i) == phaseIsIce) then 
            retrievedSize(i) = weight_by_extinction(ice_opticalThickness(i, :),  &
                                                    iceSize(i, :), &
                                                    (1. - integratedLiquidFraction) * size_TauLimit)
  
          else if(retrievedPhase(i) == phaseIsLiquid) then 
            retrievedSize(i) = weight_by_extinction(liquid_opticalThickness(i, :), &
                                                    waterSize(i, :), &
                                                    integratedLiquidFraction * size_TauLimit)
  
          else
            retrievedSize(i) = 0. 
          end if 
        else
          retrievedSize(i) = 1.0e-06*retrieve_re(retrievedPhase(i), retrievedTau(i), &
                                         obs_Refl_nir = compute_nir_reflectance(liquid_opticalThickness(i, :), waterSize(i, :)*1.0e6, & 
                                                                                ice_opticalThickness(i, :),      iceSize(i, :)*1.0e6))
        end if 
      else 
        !
        ! Values when we don't think there's a cloud. 
        !
        retrievedCloudTopPressure(i) = R_UNDEF
        retrievedPhase(i) = phaseIsNone
        retrievedSize(i) = R_UNDEF
        retrievedTau(i) = R_UNDEF
      end if
    end do 
    where((retrievedSize(:) < 0.) .and. &
          (retrievedSize(:) /= R_UNDEF)) retrievedSize(:) = 1.0e-06*re_fill
    
    ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS 
    !   mimics what MODIS does to first order. 
    !   Of course, ISCCP cloud top pressures are in mb. 
    !   
    where(cloudMask(:) .and. retrievedCloudTopPressure(:) > CO2Slicing_PressureLimit) &
      retrievedCloudTopPressure(:) = isccpCloudTopPressure * 100. 
    
  end subroutine modis_L2_simulator_twoTaus
  !------------------------------------------------------------------------------------------------
  !
  ! MODIS simulator: provide a single optical thickness and the cloud ice and liquid contents; 
  !   we'll partition this into ice and liquid optical thickness and call the full MODIS simulator 
  ! 
  subroutine modis_L2_simulator_oneTau(                                         &
                                temp, pressureLayers, pressureLevels,           &
                                opticalThickness, cloudWater, cloudIce,         &
                                waterSize, iceSize,                             & 
                                isccpTau, isccpCloudTopPressure,                &
                                retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
    ! Grid-mean quantities at layer centers, 
    !   dimension nLayers
    real, dimension(:),    intent(in ) :: temp,           & ! Temperature, K
                                          pressureLayers, & ! Pressure, Pa
                                          pressureLevels    ! Pressure at layer edges, Pa (dimension nLayers + 1) 
    ! Sub-column quantities
    !   dimension nLayers, nSubcols
    real, dimension(:, :), intent(in ) :: opticalThickness, & ! Layer optical thickness @ 0.67 microns
                                          cloudWater,       & ! Cloud water content, arbitrary units
                                          cloudIce            ! Cloud water content, same units as cloudWater
    real, dimension(:, :), intent(in ) :: waterSize,        & ! Cloud drop effective radius, microns
                                          iceSize             ! Cloud ice effective radius, microns

    ! Cloud properties retrieved from ISCCP using top_height = 1
    !    dimension nSubcols
    
    real, dimension(:),    intent(in ) :: isccpTau, &           ! Column-integrated optical thickness 
                                          isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) 

    ! Properties retrieved by MODIS
    !   dimension nSubcols
    integer, dimension(:), intent(out) :: retrievedPhase               ! liquid/ice/other - integer
    real,    dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers
                                          retrievedTau,              & ! unitless
                                          retrievedSize                ! microns (or whatever units 
                                                                       !   waterSize and iceSize are supplied in)
    ! ---------------------------------------------------
    ! Local variables
    real, dimension(size(opticalThickness, 1), size(opticalThickness, 2)) :: & 
           liquid_opticalThickness, ice_opticalThickness, tauLiquidFraction
    
    ! ---------------------------------------------------
    
    where(cloudIce(:, :) <= 0.) 
      tauLiquidFraction(:, :) = 1. 
    elsewhere
      where (cloudWater(:, :) <= 0.) 
        tauLiquidFraction(:, :) = 0. 
      elsewhere 
        ! 
        ! Geometic optics limit - tau as LWP/re  (proportional to LWC/re) 
        !
        tauLiquidFraction(:, :) = (cloudWater(:, :)/waterSize(:, :)) / &
                                  (cloudWater(:, :)/waterSize(:, :) + cloudIce(:, :)/(ice_density * iceSize(:, :)) ) 
      end where
    end where
    liquid_opticalThickness(:, :) = tauLiquidFraction(:, :) * opticalThickness(:, :) 
    ice_opticalThickness   (:, :) = opticalThickness(:, :) - liquid_opticalThickness(:, :)
    
    call modis_L2_simulator_twoTaus(temp, pressureLayers, pressureLevels,          &
                                    liquid_opticalThickness, ice_opticalThickness, &
                                    waterSize, iceSize,                            & 
                                    isccpTau, isccpCloudTopPressure,               &
                                    retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
                                
  end subroutine modis_L2_simulator_oneTau
  !------------------------------------------------------------------------------------------------
  subroutine modis_L3_simulator(phase, cloud_top_pressure, optical_thickness, particle_size,            &
       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10, &
                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
       Cloud_Top_Pressure_Total_Mean,                                                                   &
                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean,           &    
       Optical_Thickness_vs_Cloud_Top_Pressure)
    !
    ! Inputs; dimension nPoints, nSubcols
    !
    integer, dimension(:, :),   intent(in)  :: phase
    real,    dimension(:, :),   intent(in)  :: cloud_top_pressure, optical_thickness, particle_size
    !
    ! Outputs; dimension nPoints
    !
    real,    dimension(:),      intent(out) :: &
       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10, &
                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
       Cloud_Top_Pressure_Total_Mean,                                                                   &
                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean
    ! tau/ctp histogram; dimensions nPoints, numTauHistogramBins , numPressureHistogramBins 
    real,    dimension(:, :, :), intent(out) :: Optical_Thickness_vs_Cloud_Top_Pressure
    ! ---------------------------
    ! Local variables
    !
    real, parameter :: LWP_conversion = 2./3. * 1000. ! modulo units. 
    integer :: i, j
    integer :: nPoints, nSubcols 
    logical, dimension(size(phase, 1), size(phase, 2)) :: &
      cloudMask, waterCloudMask, iceCloudMask, validRetrievalMask
    logical, dimension(size(phase, 1), size(phase, 2), numTauHistogramBins     ) :: tauMask
    logical, dimension(size(phase, 1), size(phase, 2), numPressureHistogramBins) :: pressureMask
    ! ---------------------------
    
    nPoints  = size(phase, 1) 
    nSubcols = size(phase, 2) 
    !
    ! Array conformance checks
    !
    if(any( (/ size(cloud_top_pressure, 1), size(optical_thickness, 1), size(particle_size, 1),                                   &
               size(Cloud_Fraction_Total_Mean),       size(Cloud_Fraction_Water_Mean),       size(Cloud_Fraction_Ice_Mean),       &
               size(Cloud_Fraction_High_Mean),        size(Cloud_Fraction_Mid_Mean),         size(Cloud_Fraction_Low_Mean),       &
               size(Optical_Thickness_Total_Mean),    size(Optical_Thickness_Water_Mean),    size(Optical_Thickness_Ice_Mean),    &
               size(Optical_Thickness_Total_MeanLog10), size(Optical_Thickness_Water_MeanLog10), size(Optical_Thickness_Ice_MeanLog10), &
                                                      size(Cloud_Particle_Size_Water_Mean),  size(Cloud_Particle_Size_Ice_Mean),  &
               size(Cloud_Top_Pressure_Total_Mean),                                                                               &
                                                      size(Liquid_Water_Path_Mean),          size(Ice_Water_Path_Mean) /) /= nPoints)) &
!     call complain_and_die("Some L3 arrays have wrong number of grid points") 
       call error_mesg ('modis_L3_simulator', &
             'Some L3 arrays have wrong number of grid points', FATAL) 
    if(any( (/ size(cloud_top_pressure, 2), size(optical_thickness, 2), size(particle_size, 2) /)  /= nSubcols)) &
!     call complain_and_die("Some L3 arrays have wrong number of subcolumns") 
       call error_mesg ('modis_L3_simulator', &
              'Some L3 arrays have wrong number of subcolumns', FATAL) 
    
    
    !
    ! Include only those pixels with successful retrievals in the statistics 
    !
    validRetrievalMask(:, :) = particle_size(:, :) > 0.
    cloudMask      = phase(:, :) /= phaseIsNone   .and. validRetrievalMask(:, :)
    waterCloudMask = phase(:, :) == phaseIsLiquid .and. validRetrievalMask(:, :)
    iceCloudMask   = phase(:, :) == phaseIsIce    .and. validRetrievalMask(:, :)
    !
    ! Use these as pixel counts at first 
    !
    Cloud_Fraction_Total_Mean(:) = real(count(cloudMask,      dim = 2))
    Cloud_Fraction_Water_Mean(:) = real(count(waterCloudMask, dim = 2))
    Cloud_Fraction_Ice_Mean(:)   = real(count(iceCloudMask,   dim = 2))
 
    Cloud_Fraction_High_Mean(:) = real(count(cloudMask .and. cloud_top_pressure <= highCloudPressureLimit, dim = 2))
    Cloud_Fraction_Low_Mean(:)  = real(count(cloudMask .and. cloud_top_pressure >  lowCloudPressureLimit,  dim = 2))
    Cloud_Fraction_Mid_Mean(:)  = Cloud_Fraction_Total_Mean(:) - Cloud_Fraction_High_Mean(:) - Cloud_Fraction_Low_Mean(:)

    !
    ! Don't want to divide by 0, even though the sums will be 0 where the pixel counts are 0. 
    !
    where (Cloud_Fraction_Total_Mean == 0) Cloud_Fraction_Total_Mean = -1. 
    where (Cloud_Fraction_Water_Mean == 0) Cloud_Fraction_Water_Mean = -1.
    where (Cloud_Fraction_Ice_Mean   == 0) Cloud_Fraction_Ice_Mean   = -1.
    
!wfc Moving the following sums to a do loop below. 
!    Optical_Thickness_Total_Mean = sum(optical_thickness, mask = cloudMask,      dim = 2) / Cloud_Fraction_Total_Mean(:) 
!    Optical_Thickness_Water_Mean = sum(optical_thickness, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
!    Optical_Thickness_Ice_Mean   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
   
!wfc The following sum of a log10 fails under debug conditions. The Intel compiler does the log10 operation before the mask gets applied.
!wfc Therefore you are taking the log of a negative number. 
!    Optical_Thickness_Total_MeanLog10 = sum(log10(optical_thickness), mask = cloudMask,      dim = 2) / Cloud_Fraction_Total_Mean(:)
!    Optical_Thickness_Water_MeanLog10 = sum(log10(optical_thickness), mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
!    Optical_Thickness_Ice_MeanLog10   = sum(log10(optical_thickness), mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
   
!    Cloud_Particle_Size_Water_Mean = sum(particle_size, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
!    Cloud_Particle_Size_Ice_Mean   = sum(particle_size, mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
    
!!    Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2)  &
!!                                    / max(1, count(phase(:, :) /= phaseIsNone, dim = 2))
!        Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / max(1, count(cloudMask, dim = 2))

!    Liquid_Water_Path_Mean = LWP_conversion &
!                             * sum(particle_size * optical_thickness, mask = waterCloudMask, dim = 2) &
!                             / Cloud_Fraction_Water_Mean(:)
!    Ice_Water_Path_Mean    = LWP_conversion * ice_density &
!                             * sum(particle_size * optical_thickness, mask = iceCloudMask,   dim = 2) &
!                             / Cloud_Fraction_Ice_Mean(:)

    Optical_Thickness_Total_Mean = 0.0
    Optical_Thickness_Water_Mean = 0.0
    Optical_Thickness_Ice_Mean   = 0.0
    Optical_Thickness_Total_MeanLog10 = 0.0
    Optical_Thickness_Water_MeanLog10 = 0.0
    Optical_Thickness_Ice_MeanLog10  = 0.0
    Cloud_Particle_Size_Water_Mean = 0.0 
    Cloud_Particle_Size_Ice_Mean   = 0.0
    Cloud_Top_Pressure_Total_Mean = 0.0
    Liquid_Water_Path_Mean = 0.0
    Ice_Water_Path_Mean    = 0.0

    do j = 1, size(optical_thickness,2)
      do i = 1, size(optical_thickness,1)
        if (cloudMask(i,j)) then
          Optical_Thickness_Total_Mean(i)      = Optical_Thickness_Total_Mean(i)      + optical_thickness(i,j)
          Optical_Thickness_Total_MeanLog10(i) = Optical_Thickness_Total_MeanLog10(i) + log10(optical_thickness(i,j))
          Cloud_Top_Pressure_Total_Mean(i)   = Cloud_Top_Pressure_Total_Mean(i)   + cloud_top_pressure(i,j)
        endif
        if (waterCloudMask(i,j)) then
          Optical_Thickness_Water_Mean(i)      = Optical_Thickness_Water_Mean(i)      + optical_thickness(i,j)
          Optical_Thickness_Water_MeanLog10(i) = Optical_Thickness_Water_MeanLog10(i) + log10(optical_thickness(i,j))
          Cloud_Particle_Size_Water_Mean(i)    = Cloud_Particle_Size_Water_Mean(i)    + particle_size(i,j)
          Liquid_Water_Path_Mean(i)            = Liquid_Water_Path_Mean(i)            + &
                                                 LWP_conversion * particle_size(i,j) * optical_thickness(i,j)
        endif
        if (iceCloudMask(i,j)) then
          Optical_Thickness_Ice_Mean(i)        = Optical_Thickness_Ice_Mean(i)        + optical_thickness(i,j)
          Optical_Thickness_Ice_MeanLog10(i)   = Optical_Thickness_Ice_MeanLog10(i)   + log10(optical_thickness(i,j))
          Cloud_Particle_Size_Ice_Mean(i)      = Cloud_Particle_Size_Ice_Mean(i)      + particle_size(i,j)
          Ice_Water_Path_Mean(i)               = Ice_Water_Path_Mean(i)               + &
                                                 LWP_conversion * ice_density * particle_size(i,j) * optical_thickness(i,j)
        endif
      enddo
    enddo
    Optical_Thickness_Total_Mean(:)      = Optical_Thickness_Total_Mean(:)      / Cloud_Fraction_Total_Mean(:) 
    Optical_Thickness_Water_Mean(:)      = Optical_Thickness_Water_Mean(:)      / Cloud_Fraction_Water_Mean(:)
    Optical_Thickness_Ice_Mean(:)        = Optical_Thickness_Ice_Mean(:)        / Cloud_Fraction_Ice_Mean(:)
   
    Optical_Thickness_Total_MeanLog10(:) = Optical_Thickness_Total_MeanLog10(:) / Cloud_Fraction_Total_Mean(:)
    Optical_Thickness_Water_MeanLog10(:) = Optical_Thickness_Water_MeanLog10(:) / Cloud_Fraction_Water_Mean(:)
    Optical_Thickness_Ice_MeanLog10(:)   = Optical_Thickness_Ice_MeanLog10(:)   / Cloud_Fraction_Ice_Mean(:)
   
    Cloud_Particle_Size_Water_Mean(:)    = Cloud_Particle_Size_Water_Mean(:)    / Cloud_Fraction_Water_Mean(:)
    Cloud_Particle_Size_Ice_Mean(:)      = Cloud_Particle_Size_Ice_Mean(:)      / Cloud_Fraction_Ice_Mean(:)
    
    Cloud_Top_Pressure_Total_Mean(:)     = Cloud_Top_Pressure_Total_Mean(:)     / max(1, count(cloudMask, dim = 2))
    
    Liquid_Water_Path_Mean(:)            = Liquid_Water_Path_Mean(:)            / Cloud_Fraction_Water_Mean(:)
    Ice_Water_Path_Mean(:)               = Ice_Water_Path_Mean(:)               / Cloud_Fraction_Ice_Mean(:)
    

    !
    ! Normalize pixel counts to fraction
    !   The first three cloud fractions have been set to -1 in cloud-free areas, so set those places to 0.
    ! 
!   where(Cloud_Fraction_Total_Mean(:) > 0) 
!     Cloud_Fraction_Total_Mean(:) = Cloud_Fraction_Total_Mean(:)/nSubcols
!   elsewhere
!     Cloud_Fraction_Total_Mean(:) = 0. 
!   end where
    
!   where(Cloud_Fraction_Water_Mean(:) > 0) 
!     Cloud_Fraction_Water_Mean(:) = Cloud_Fraction_Water_Mean(:)/nSubcols
!   elsewhere
!     Cloud_Fraction_Water_Mean(:) = 0. 
!   end where
    
!   where(Cloud_Fraction_Ice_Mean(:) > 0) 
!     Cloud_Fraction_Ice_Mean(:) = Cloud_Fraction_Ice_Mean(:)/nSubcols
!   elsewhere
!     Cloud_Fraction_Ice_Mean(:) = 0. 
!   end where
    Cloud_Fraction_Total_Mean(:) = max(0., Cloud_Fraction_Total_Mean(:)/nSubcols)
    Cloud_Fraction_Water_Mean(:) = max(0., Cloud_Fraction_Water_Mean(:)/nSubcols)
    Cloud_Fraction_Ice_Mean(:)   = max(0., Cloud_Fraction_Ice_Mean(:)  /nSubcols)
 
    Cloud_Fraction_High_Mean(:)  = Cloud_Fraction_High_Mean(:) /nSubcols
    Cloud_Fraction_Mid_Mean(:)   = Cloud_Fraction_Mid_Mean(:)  /nSubcols
    Cloud_Fraction_Low_Mean(:)   = Cloud_Fraction_Low_Mean(:)  /nSubcols
    
    ! ----
    ! Joint histogram 
    ! 
    do i = 1, numTauHistogramBins 
      where(cloudMask(:, :)) 
        tauMask(:, :, i) = optical_thickness(:, :) >= tauHistogramBoundaries(i) .and. &
                           optical_thickness(:, :) <  tauHistogramBoundaries(i+1)
      elsewhere
        tauMask(:, :, i) = .false.
      end where
    end do 

    do i = 1, numPressureHistogramBins 
      where(cloudMask(:, :)) 
        pressureMask(:, :, i) = cloud_top_pressure(:, :) >= pressureHistogramBoundaries(i) .and. &
                                cloud_top_pressure(:, :) <  pressureHistogramBoundaries(i+1)
      elsewhere
        pressureMask(:, :, i) = .false.
      end where
    end do 
    
    do i = 1, numPressureHistogramBins
      do j = 1, numTauHistogramBins
        Optical_Thickness_vs_Cloud_Top_Pressure(:, j, i) = & 
          real(count(tauMask(:, :, j) .and. pressureMask(:, :, i), dim = 2)) / real(nSubcols)
      end do 
    end do 
    
  end subroutine modis_L3_simulator
  !------------------------------------------------------------------------------------------------
  function cloud_top_pressure(tauIncrement, pressure, tauLimit) 
    real, dimension(:), intent(in) :: tauIncrement, pressure
    real,               intent(in) :: tauLimit
    real                           :: cloud_top_pressure
    !
    ! Find the extinction-weighted pressure. Assume that pressure varies linearly between 
    !   layers and use the trapezoidal rule.
    !
    
    real :: deltaX, totalTau, totalProduct
    integer :: i 
    
    totalTau = 0.; totalProduct = 0. 
    do i = 2, size(tauIncrement)
      if(totalTau + tauIncrement(i) > tauLimit) then 
        deltaX = tauLimit - totalTau
        totalTau = totalTau + deltaX
        !
        ! Result for trapezoidal rule when you take less than a full step
        !   tauIncrement is a layer-integrated value
        !
!        totalProduct = totalProduct + &
!                       deltaX * ((pressure(i) - pressure(i-1)) * deltaX**2/(2. * tauIncrement(i)) + &
!                                 pressure(i-1) * deltaX)
        totalProduct = totalProduct           &
                     + pressure(i-1) * deltaX &
                     + (pressure(i) - pressure(i-1)) * deltaX**2/(2. * tauIncrement(i))
      else
        totalTau =     totalTau     + tauIncrement(i) 
        totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2.
      end if 
      if(totalTau >= tauLimit) exit
    end do 
    cloud_top_pressure = totalProduct/totalTau
  end function cloud_top_pressure
  !------------------------------------------------------------------------------------------------
  function weight_by_extinction(tauIncrement, f, tauLimit) 
    real, dimension(:), intent(in) :: tauIncrement, f
    real,               intent(in) :: tauLimit
    real                           :: weight_by_extinction
    !
    ! Find the extinction-weighted value of f(tau), assuming constant f within each layer
    !
    
    real    :: deltaX, totalTau, totalProduct
    integer :: i 
    
    totalTau = 0.; totalProduct = 0. 
    do i = 1, size(tauIncrement)
      if(totalTau + tauIncrement(i) > tauLimit) then 
        deltaX       = tauLimit - totalTau
        totalTau     = totalTau     + deltaX
        totalProduct = totalProduct + deltaX * f(i) 
      else
        totalTau     = totalTau     + tauIncrement(i) 
        totalProduct = totalProduct + tauIncrement(i) * f(i) 
      end if 
      if(totalTau >= tauLimit) exit
    end do 
    weight_by_extinction = totalProduct/totalTau
  end function weight_by_extinction
  !------------------------------------------------------------------------------------------------
  pure function compute_nir_reflectance(water_tau, water_size, ice_tau, ice_size) 
    real, dimension(:), intent(in) :: water_tau, water_size, ice_tau, ice_size
    real                           :: compute_nir_reflectance
    
    real, dimension(size(water_tau)) :: water_g, water_w0, ice_g, ice_w0, &
                                        tau, g, w0
    integer                          :: cnt_tau
    !----------------------------------------
    water_g(:)  = get_g_nir(  phaseIsLiquid, water_size) 
    water_w0(:) = get_ssa_nir(phaseIsLiquid, water_size) 
    ice_g(:)    = get_g_nir(  phaseIsIce,    ice_size) 
    ice_w0(:)   = get_ssa_nir(phaseIsIce,    ice_size) 
    !
    ! Combine ice and water optical properties
    !
    g(:) = 0; w0(:) = 0. 
    tau(:) = ice_tau(:) + water_tau(:) 
    where (tau(:) > 0) 
      g(:)  = (water_tau(:) * water_g(:)                + ice_tau(:) * ice_g(:)            ) / & 
              tau(:) 
      w0(:) = (water_tau(:) * water_g(:) * water_w0(:)  + ice_tau(:) * ice_g(:) * ice_w0(:)) / &
              (g(:) * tau(:))
    end where
    
    cnt_tau = count(tau(:) > 0.0)
    compute_nir_reflectance = compute_toa_reflectace(tau, g, w0, cnt_tau)
  end function compute_nir_reflectance
  !------------------------------------------------------------------------------------------------
  ! Retreivals
  !------------------------------------------------------------------------------------------------
  elemental function retrieve_re (phase, tau, obs_Refl_nir)
      integer, intent(in) :: phase
      real,    intent(in) :: tau, obs_Refl_nir
      real                :: retrieve_re
	  !
	  ! Finds the re that produces the minimum mis-match between predicted and observed reflectance in 
	  !   MODIS band 7 (near IR)
	  ! Uses 
	  !  fits for asymmetry parameter g(re) and single scattering albedo w0(re) based on MODIS tables 
	  !  two-stream for layer reflectance and transmittance as a function of optical thickness tau, g, and w0
	  !  adding-doubling for total reflectance 
	  !  
	  !
      !
      ! Local variables
      !
      real, parameter :: min_distance_to_boundary = 0.01
      real    :: re_min, re_max, delta_re
      integer :: i 
      
      real, dimension(num_trial_res) :: trial_re, g, w0, predicted_Refl_nir
      ! --------------------------
    
	if(any(phase == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then 
      if (phase == phaseIsLiquid .OR. phase == phaseIsUndetermined) then
        re_min = re_water_min
        re_max = re_water_max
        trial_re(:) = trial_re_w
        g(:)   = g_w(:) 
        w0(:)  = w0_w(:)
      else
        re_min = re_ice_min
        re_max = re_ice_max
        trial_re(:) = trial_re_i
        g(:)   = g_i(:) 
        w0(:)  = w0_i(:)
      end if
      !
      ! 1st attempt at index: w/coarse re resolution
      !
      predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:))
      retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) 
      !
      ! If first retrieval works, can try 2nd iteration using greater re resolution 
      !
      if(use_two_re_iterations .and. retrieve_re > 0.) then
        re_min = retrieve_re - delta_re
        re_max = retrieve_re + delta_re
        delta_re = (re_max - re_min)/real(num_trial_res-1)
  
        trial_re(:) = re_min + delta_re * (/ (i - 1, i = 1, num_trial_res) /) 
        g(:)  = get_g_nir(  phase, trial_re(:))
        w0(:) = get_ssa_nir(phase, trial_re(:))
        predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:))
        retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) 
      end if
    else 
      retrieve_re = re_fill
    end if 
    
  end function retrieve_re
  ! --------------------------------------------
  pure function interpolate_to_min(x, y, yobs)
    real, dimension(:), intent(in) :: x, y 
    real,               intent(in) :: yobs
    real                           :: interpolate_to_min
    ! 
    ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs)
    !   y must be monotonic in x
    !
    real, dimension(size(x)) :: diff
    real                     :: weight
    integer                  :: nPoints, minDiffLoc, lowerBound, upperBound
    ! ---------------------------------
    nPoints = size(y)
    diff(:) = y(:) - yobs
    minDiffLoc = minloc(abs(diff), dim = 1) 
    
    if(minDiffLoc == 1) then 
      lowerBound = minDiffLoc
      upperBound = minDiffLoc + 1
    else if(minDiffLoc == nPoints) then
      lowerBound = minDiffLoc - 1
      upperBound = minDiffLoc
    else
      if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then
        lowerBound = minDiffLoc-1
        upperBound = minDiffLoc
      else 
        lowerBound = minDiffLoc
        upperBound = minDiffLoc + 1
      end if 
    end if 
    
    if(diff(lowerBound) * diff(upperBound) < 0) then     
      !
      ! Interpolate the root position linearly if we bracket the root
      !
      interpolate_to_min = x(upperBound) - & 
                           diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound))
    else 
      interpolate_to_min = re_fill
    end if 
    

  end function interpolate_to_min
  ! --------------------------------------------
  ! Optical properties
  ! --------------------------------------------
  elemental function get_g_nir (phase, re)
    !
    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
    !   of size for ice and water
    ! Fits from Steve Platnick
    !

    integer, intent(in) :: phase
    real,    intent(in) :: re
    real :: get_g_nir 
    
    real, dimension(3), parameter :: ice_coefficients   = (/ 0.7432,  4.5563e-3, -2.8697e-5 /), & 
                               small_water_coefficients = (/ 0.8027, -1.0496e-2,  1.7071e-3 /), & 
                                 big_water_coefficients = (/ 0.7931,  5.3087e-3, -7.4995e-5 /) 
    
    ! approx. fits from MODIS Collection 5 LUT scattering calculations
    if(phase == phaseIsLiquid) then
      if(re < 8.) then 
        get_g_nir = fit_to_quadratic(re, small_water_coefficients)
        if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients)
      else
        get_g_nir = fit_to_quadratic(re,   big_water_coefficients)
        if(re > re_water_max) get_g_nir = fit_to_quadratic(re_water_max, big_water_coefficients)
      end if 
    else
      get_g_nir = fit_to_quadratic(re, ice_coefficients)
      if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients)
      if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients)
    end if 
    
  end function get_g_nir

  ! --------------------------------------------
	elemental function get_ssa_nir (phase, re)
		integer, intent(in) :: phase
	    real,    intent(in) :: re
		real                :: get_ssa_nir
		!
		! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
		!   of size for ice and water
		! Fits from Steve Platnick
		!
		
		real, dimension(4), parameter :: ice_coefficients   = (/ 0.9994, -4.5199e-3, 3.9370e-5, -1.5235e-7 /)
		real, dimension(3), parameter :: water_coefficients = (/ 1.0008, -2.5626e-3, 1.6024e-5 /) 
		
		! approx. fits from MODIS Collection 5 LUT scattering calculations
		if(phase == phaseIsLiquid) then
		  get_ssa_nir = fit_to_quadratic(re, water_coefficients)
          if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients)
          if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients)
		else
		  get_ssa_nir = fit_to_cubic(re, ice_coefficients)
          if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients)
          if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients)
		end if 

	end function get_ssa_nir
   ! --------------------------------------------
  pure function fit_to_cubic(x, coefficients) 
    real,               intent(in) :: x
    real, dimension(:), intent(in) :: coefficients
    real                           :: fit_to_cubic
    
    
    fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4)))
 end function fit_to_cubic
   ! --------------------------------------------
  pure function fit_to_quadratic(x, coefficients) 
    real,               intent(in) :: x
    real, dimension(:), intent(in) :: coefficients
    real                           :: fit_to_quadratic
    
    
    fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3)))
 end function fit_to_quadratic
  ! --------------------------------------------
  ! Radiative transfer
  ! --------------------------------------------
  pure function compute_toa_reflectace(tau, g, w0, cnt_tau)
    real, dimension(:), intent(in) :: tau, g, w0
    integer,            intent(in) :: cnt_tau
    real                           :: compute_toa_reflectace
    
    logical, dimension(size(tau))         :: cloudMask
    integer, dimension(cnt_tau) :: cloudIndicies
    real,    dimension(cnt_tau) :: Refl,     Trans
    real                                  :: Refl_tot, Trans_tot
    integer                               :: i
    ! ---------------------------------------
    !
    ! This wrapper reports reflectance only and strips out non-cloudy elements from the calculation
    !
    cloudMask = tau(:) > 0. 
    cloudIndicies = pack((/ (i, i = 1, size(tau)) /), mask = cloudMask) 
    do i = 1, size(cloudIndicies)
      call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i))
    end do 
                    
	call adding_doubling(Refl(:), Trans(:), Refl_tot, Trans_tot)  
	
	compute_toa_reflectace = Refl_tot
	
  end function compute_toa_reflectace
  ! --------------------------------------------
  pure subroutine two_stream(tauint, gint, w0int, ref, tra) 
    real, intent(in)  :: tauint, gint, w0int
    real, intent(out) :: ref, tra
    !
    ! Compute reflectance in a single layer using the two stream approximation 
    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
    !
    ! ------------------------
    ! Local variables 
    !   for delta Eddington code
    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
    integer, parameter :: beam = 2
    real,    parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
    real :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
            rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
    !
    ! Compute reflectance and transmittance in a single layer using the two stream approximation 
    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
    !
    f   = gint**2
    tau = (1 - w0int * f) * tauint
    w0  = (1 - f) * w0int / (1 - w0int * f)
    g   = (gint - f) / (1 - f)

    ! delta-Eddington (Joseph et al. 1976)
    gamma1 =  (7 - w0* (4 + 3 * g)) / 4.0
    gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0
    gamma3 =  (2 - 3*g*xmu) / 4.0
    gamma4 =   1 - gamma3

    if (w0int > minConservativeW0) then
      ! Conservative scattering
      if (beam == 1) then
          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
          ref = rh / (1 + gamma1 * tau)
          tra = 1 - ref       
      else if(beam == 2) then
          ref = gamma1*tau/(1 + gamma1*tau)
          tra = 1 - ref
      endif
    else
      ! Non-conservative scattering
      a1 = gamma1 * gamma4 + gamma2 * gamma3
      a2 = gamma1 * gamma3 + gamma2 * gamma4

      rk = sqrt(gamma1**2 - gamma2**2)
      
      r1 = (1 - rk * xmu) * (a2 + rk * gamma3)
      r2 = (1 + rk * xmu) * (a2 - rk * gamma3)
      r3 = 2 * rk *(gamma3 - a2 * xmu)
      r4 = (1 - (rk * xmu)**2) * (rk + gamma1)
      r5 = (1 - (rk * xmu)**2) * (rk - gamma1)
      
      t1 = (1 + rk * xmu) * (a1 + rk * gamma4)
      t2 = (1 - rk * xmu) * (a1 - rk * gamma4)
      t3 = 2 * rk * (gamma4 + a1 * xmu)
      t4 = r4
      t5 = r5

      beta = -r5 / r4         
      
      e1 = min(rk * tau, 500.) 
      e2 = min(tau / xmu, 500.) 
      
      if (beam == 1) then
         den = r4 * exp(e1) + r5 * exp(-e1)
         ref  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
         den = t4 * exp(e1) + t5 * exp(-e1)
         th  = exp(-e2)
         tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den
      elseif (beam == 2) then
         ef1 = exp(-e1)
         ef2 = exp(-2*e1)
         ref = (gamma2*(1-ef2))/((rk+gamma1)*(1-beta*ef2))
         tra = (2*rk*ef1)/((rk+gamma1)*(1-beta*ef2))
      endif
    end if
  end subroutine two_stream
  ! --------------------------------------------------
  elemental function two_stream_reflectance(tauint, gint, w0int) 
    real, intent(in) :: tauint, gint, w0int
    real             :: two_stream_reflectance
    !
    ! Compute reflectance in a single layer using the two stream approximation 
    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
    !
    ! ------------------------
    ! Local variables 
    !   for delta Eddington code
    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
    integer, parameter :: beam = 2
    real,    parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
    real :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
            rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
    ! ------------------------


    f   = gint**2
    tau = (1 - w0int * f) * tauint
    w0  = (1 - f) * w0int / (1 - w0int * f)
    g   = (gint - f) / (1 - f)

    ! delta-Eddington (Joseph et al. 1976)
    gamma1 =  (7 - w0* (4 + 3 * g)) / 4.0
    gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0
    gamma3 =  (2 - 3*g*xmu) / 4.0
    gamma4 =   1 - gamma3

    if (w0int > minConservativeW0) then
      ! Conservative scattering
      if (beam == 1) then
          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
          two_stream_reflectance = rh / (1 + gamma1 * tau)
      elseif (beam == 2) then
          two_stream_reflectance = gamma1*tau/(1 + gamma1*tau)
      endif
        
    else	!

        ! Non-conservative scattering
         a1 = gamma1 * gamma4 + gamma2 * gamma3
         a2 = gamma1 * gamma3 + gamma2 * gamma4

         rk = sqrt(gamma1**2 - gamma2**2)
         
         r1 = (1 - rk * xmu) * (a2 + rk * gamma3)
         r2 = (1 + rk * xmu) * (a2 - rk * gamma3)
         r3 = 2 * rk *(gamma3 - a2 * xmu)
         r4 = (1 - (rk * xmu)**2) * (rk + gamma1)
         r5 = (1 - (rk * xmu)**2) * (rk - gamma1)
         
         t1 = (1 + rk * xmu) * (a1 + rk * gamma4)
         t2 = (1 - rk * xmu) * (a1 - rk * gamma4)
         t3 = 2 * rk * (gamma4 + a1 * xmu)
         t4 = r4
         t5 = r5

         beta = -r5 / r4         
         
         e1 = min(rk * tau, 500.) 
         e2 = min(tau / xmu, 500.) 
         
         if (beam == 1) then
           den = r4 * exp(e1) + r5 * exp(-e1)
           two_stream_reflectance  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
         elseif (beam == 2) then
           ef1 = exp(-e1)
           ef2 = exp(-2*e1)
           two_stream_reflectance = (gamma2*(1-ef2))/((rk+gamma1)*(1-beta*ef2))
         endif
           
      end if
  end function two_stream_reflectance 
  ! --------------------------------------------
	pure subroutine adding_doubling (Refl, Tran, Refl_tot, Tran_tot)      
      real,    dimension(:), intent(in)  :: Refl,     Tran
      real,                  intent(out) :: Refl_tot, Tran_tot
	  !
	  ! Use adding/doubling formulas to compute total reflectance and transmittance from layer values
	  !
	  
	  integer :: i
      real, dimension(size(Refl)) :: Refl_cumulative, Tran_cumulative
      
      Refl_cumulative(1) = Refl(1); Tran_cumulative(1) = Tran(1)	
      
      do i=2, size(Refl)
          ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface):
          Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1 - Refl_cumulative(i-1) * Refl(i))
          Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1 - Refl_cumulative(i-1) * Refl(i))
      end do
      
      Refl_tot = Refl_cumulative(size(Refl))
      Tran_tot = Tran_cumulative(size(Refl))

	end subroutine adding_doubling
  ! --------------------------------------------------
  subroutine complain_and_die(message) 
    character(len = *), intent(in) :: message
    
!    write(6, *) "Failure in MODIS simulator" 
!    write(6, *)  trim(message) 
!    flush(6)
!    stop
    call error_mesg ('modis_simulator', trim(message), FATAL) 

  end subroutine complain_and_die
  !------------------------------------------------------------------------------------------------
end module mod_modis_sim


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
        
! $Id: array_lib.f90,v 1.1.2.1.2.1 2009/08/10 10:48:13 rsh Exp $
! $Name: hiram_20101115_bw $

! ARRAY_LIB: Array procedures for F90
! Compiled/Modified:
!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
!
! infind (function)
! lin_interpolate (function)
  
  module array_lib
  implicit none

  contains

! ----------------------------------------------------------------------------
! function INFIND
! ----------------------------------------------------------------------------
  function infind(list,val,sort,dist)
  use m_mrgrnk
  implicit none
!
! Purpose:
!   Finds the index of an array that is closest to a value, plus the
!   difference between the value found and the value specified
!
! Inputs:
!   [list]   an array of sequential values
!   [val]    a value to locate
! Optional input:
!   [sort]   set to 1 if [list] is in unknown/non-sequential order
!
! Returns:
!   index of [list] that is closest to [val]
!
! Optional output:
!   [dist]   set to variable containing [list([result])] - [val]
!
! Requires:
!   mrgrnk library
!
! Created:
!   10/16/03  John Haynes (haynes@atmos.colostate.edu)
! Modified:
!   01/31/06  IDL to Fortran 90
 
! ----- INPUTS -----
  real*8, dimension(:), intent(in) :: list
  real*8, intent(in) :: val  
  integer, intent(in), optional :: sort
  
! ----- OUTPUTS -----
  integer*4 :: infind
  real*8, intent(out), optional :: dist

! ----- INTERNAL -----
  real*8, dimension(size(list)) :: lists
  integer*4 :: nlist, result, tmp(1), sort_list
  integer*4, dimension(size(list)) :: mask, idx

  if (present(sort)) then
    sort_list = sort
  else
    sort_list = 0
  endif  

  nlist = size(list)
  if (sort_list == 1) then
    call mrgrnk(list,idx)
    lists = list(idx)
  else
    lists = list
  endif

  if (val >= lists(nlist)) then
    result = nlist
  else if (val <= lists(1)) then
    result = 1
  else
    mask(:) = 0
    where (lists < val) mask = 1
      tmp = minloc(mask,1)
      if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then
        result = tmp(1) - 1
      else
        result = tmp(1)
      endif
  endif
  if (present(dist)) dist = lists(result)-val
  if (sort_list == 1) then
    infind = idx(result)
  else
    infind = result
  endif

  end function infind

! ----------------------------------------------------------------------------
! function LIN_INTERPOLATE
! ----------------------------------------------------------------------------  
  subroutine lin_interpolate(yarr,xarr,yyarr,xxarr,tol)
  use m_mrgrnk
  implicit none
!
! Purpose:
!   linearly interpolate a set of y2 values given a set of y1,x1,x2
!
! Inputs:
!   [yarr]    an array of y1 values
!   [xarr]    an array of x1 values
!   [xxarr]   an array of x2 values
!   [tol]     maximum distance for a match
!
! Output:
!   [yyarr]   interpolated array of y2 values
!
! Requires:
!   mrgrnk library
!
! Created:
!   06/07/06  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----
  real*8, dimension(:), intent(in) :: yarr, xarr, xxarr
  real*8, intent(in) :: tol

! ----- OUTPUTS -----
  real*8, dimension(size(xxarr)), intent(out) :: yyarr

! ----- INTERNAL -----
  real*8, dimension(size(xarr)) :: ysort, xsort
  integer*4, dimension(size(xarr)) :: ist
  integer*4 :: nx, nxx, i, iloc
  real*8 :: d, m

  nx = size(xarr)
  nxx = size(xxarr)

! // xsort, ysort are sorted versions of xarr, yarr  
  call mrgrnk(xarr,ist)
  ysort = yarr(ist)
  xsort = xarr(ist)
  
  do i=1,nxx
    iloc = infind(xsort,xxarr(i),dist=d)
    if (d > tol) then
      print *, 'interpolation error'
      stop
    endif
    if (iloc == nx) then
!     :: set to the last value
      yyarr(i) = ysort(nx)
    else
!     :: is there another closeby value?
      if (abs(xxarr(i)-xsort(iloc+1)) < 2*tol) then
!       :: yes, do a linear interpolation      
        m = (ysort(iloc+1)-ysort(iloc))/(xsort(iloc+1)-xsort(iloc))
        yyarr(i) = ysort(iloc) + m*(xxarr(i)-xsort(iloc))
      else
!       :: no, set to the only nearby value
        yyarr(i) = ysort(iloc)
      endif
    endif
  enddo
  
  end subroutine lin_interpolate

  end module array_lib



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
        
! $Id: atmos_lib.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

! ATMOS_LIB: Atmospheric science procedures for F90
! Compiled/Modified:
!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
!
! mcclatchey (subroutine)
  
  module atmos_lib
  implicit none
  
  contains
  
! ----------------------------------------------------------------------------
! subroutine MCCLATCHEY
! ----------------------------------------------------------------------------
  subroutine mcclatchey(stype,hgt,prs,tk,rh)
  implicit none
!
! Purpose:
!   returns a standard atmospheric profile
!
! Input:
!   [stype]   type of profile to return
!             1 = mid-latitude summer
!             2 = mid-latitude winter
!             3 = tropical
!
! Outputs:
!   [hgt]     height (m)
!   [prs]     pressure (hPa)
!   [tk]      temperature (K)
!   [rh]      relative humidity (%)
!
! Created:
!   06/01/2006  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----
  integer, intent(in) :: &
  stype

  integer, parameter :: ndat = 33

! ----- OUTPUTS -----
  real*8, intent(out), dimension(ndat) :: &
  hgt, &                        ! height (m)
  prs, &                        ! pressure (hPa)
  tk, &                         ! temperature (K)
  rh                            ! relative humidity (%)
  
  hgt = (/0.00000,1000.00,2000.00,3000.00,4000.00,5000.00, &
          6000.00,7000.00,8000.00,9000.00,10000.0,11000.0, &
          12000.0,13000.0,14000.0,15000.0,16000.0,17000.0, &
          18000.0,19000.0,20000.0,21000.0,22000.0,23000.0, &
          24000.0,25000.0,30000.0,35000.0,40000.0,45000.0, &
          50000.0,70000.0,100000./)

  select case(stype)

  case(1)
!   // mid-latitide summer  
    prs = (/1013.00, 902.000, 802.000, 710.000, 628.000, 554.000, &
            487.000, 426.000, 372.000, 324.000, 281.000, 243.000, &
            209.000, 179.000, 153.000, 130.000, 111.000, 95.0000, &
            81.2000, 69.5000, 59.5000, 51.0000, 43.7000, 37.6000, &
            32.2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, &
            0.951000,0.0671000,0.000300000/)
	   
    tk =  (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, &
            261.000, 255.000, 248.000, 242.000, 235.000, 229.000, &
            222.000, 216.000, 216.000, 216.000, 216.000, 216.000, &
            216.000, 217.000, 218.000, 219.000, 220.000, 222.000, &
            223.000, 224.000, 234.000, 245.000, 258.000, 270.000, &
            276.000, 218.000, 210.000/)

    rh =  (/74.8384, 63.4602, 55.0485, 45.4953, 39.3805, 31.7965, &
            30.3958, 29.5966, 30.1626, 29.3624, 30.3334, 19.0768, &
            11.0450, 6.61278, 3.67379, 2.79209, 2.35123, 2.05732, &
            1.83690, 1.59930, 1.30655, 1.31890, 1.17620,0.994076, &
            0.988566,0.989143,0.188288,0.0205613,0.00271164,0.000488798, &
            0.000107066,0.000406489,7.68645e-06/)

  case(2)
!   // mid-latitude winter
    prs = (/1018.00, 897.300, 789.700, 693.800, 608.100, 531.300, &
            462.700, 401.600, 347.300, 299.200, 256.800, 219.900, &
            188.200, 161.000, 137.800, 117.800, 100.700, 86.1000, &
            73.5000, 62.8000, 53.7000, 45.8000, 39.1000, 33.4000, &
            28.6000, 24.3000, 11.1000, 5.18000, 2.53000, 1.29000, &
            0.682000,0.0467000,0.000300000/)

    tk =  (/272.200, 268.700, 265.200, 261.700, 255.700, 249.700, &
            243.700, 237.700, 231.700, 225.700, 219.700, 219.200, &
            218.700, 218.200, 217.700, 217.200, 216.700, 216.200, &
            215.700, 215.200, 215.200, 215.200, 215.200, 215.200, &
            215.200, 215.200, 217.400, 227.800, 243.200, 258.500, &
            265.700, 230.700, 210.200/)

    rh =  (/76.6175, 70.1686, 65.2478, 56.6267, 49.8755, 47.1765, &
            44.0477, 31.0565, 23.0244, 19.6510, 17.8987, 17.4376, &
            16.0621, 5.10608, 3.00679, 2.42293, 2.16406, 2.00901, &
            1.90374, 1.98072, 1.81902, 2.06155, 2.06154, 2.18280, &
            2.42531,2.70824,1.12105,0.108119,0.00944200,0.00115201, &
            0.000221094,0.000101946,7.49350e-06/)

  case(3)
!   // tropical
    prs = (/1013.00, 904.000, 805.000, 715.000, 633.000, 559.000, &
            492.000, 432.000, 378.000, 329.000, 286.000, 247.000, &
            213.000, 182.000, 156.000, 132.000, 111.000, 93.7000, &
            78.9000, 66.6000, 56.5000, 48.0000, 40.9000, 35.0000, &
            30.0000, 25.7000, 12.2000, 6.00000, 3.05000, 1.59000, &
            0.854000,0.0579000,0.000300000/)

    tk =  (/300.000, 294.000, 288.000, 284.000, 277.000, 270.000, &
            264.000, 257.000, 250.000, 244.000, 237.000, 230.000, &
            224.000, 217.000, 210.000, 204.000, 197.000, 195.000, &
            199.000, 203.000, 207.000, 211.000, 215.000, 217.000, &
            219.000, 221.000, 232.000, 243.000, 254.000, 265.000, &
            270.000, 219.000, 210.000/)

    rh =  (/71.4334, 69.4097, 71.4488, 46.7724, 34.7129, 38.3820, &
            33.7214, 32.0122, 30.2607, 24.5059, 19.5321, 13.2966, &
            8.85795, 5.87496, 7.68644, 12.8879, 29.4976, 34.9351, &
            17.1606, 9.53422, 5.10154, 3.45407, 2.11168, 1.76247, &
            1.55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, &
            0.000162076,0.000362055,7.68645e-06/)
	    
  case default
    print *, 'Must enter a profile type'
    stop
    
  end select
  
  end subroutine mcclatchey
  
  end module atmos_lib



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
         
! $Id: dsd.f90,v 1.1.2.1.2.1.6.1 2010/03/04 08:23:50 rsh Exp $
! $Name: hiram_20101115_bw $

  subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, &
             dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled)
  use array_lib
  use math_lib 
  implicit none

! Purpose:
!   Create a discrete drop size distribution
!   Part of QuickBeam v1.03 by John Haynes
!   http://reef.atmos.colostate.edu/haynes/radarsim
!
! Inputs:
!   [Q]        hydrometeor mixing ratio (g/kg)
!   [Re]       Optional Effective Radius (microns).  0 = use default.
!   [D]        discrete drop sizes (um)
!   [nsizes]   number of elements of [D]
!   [dtype]    distribution type
!   [rho_a]    ambient air density (kg m^-3)
!   [tc]       temperature (C)
!   [dmin]     minimum size cutoff (um)
!   [dmax]     maximum size cutoff (um)
!   [rho_c]    alternate constant density (kg m^-3)
!   [p1],[p2],[p3]  distribution parameters
!
! Input/Output:
!   [fc]       scaling factor for the distribution
!   [scaled]   has this hydrometeor type been scaled?
!   [apm]      a parameter for mass (kg m^[-bpm])
!   [bmp]      b params for mass
!
! Outputs:
!   [N]        discrete concentrations (cm^-3 um^-1)
!              or, for monodisperse, a constant (1/cm^3)
!
! Requires:
!   function infind
!
! Created:
!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
! Modified:
!   01/31/06  Port from IDL to Fortran 90
!   07/07/06  Rewritten for variable DSD's
!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH)
 
! ----- INPUTS -----  
  
  integer, intent(in) :: nsizes
  integer, intent(in) :: dtype
  real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, &
    rho_c,p1,p2,p3
    
! ----- INPUT/OUTPUT -----

  real*8, intent(inout) :: fc(nsizes),apm,bpm,Re
  logical, intent(inout) :: scaled  
    
! ----- OUTPUTS -----

  real*8, intent(out) :: N(nsizes)
  
! ----- INTERNAL -----
  
  real*8 :: &
  N0,D0,vu,np,dm,ld, &			! gamma, exponential variables
  dmin_mm,dmax_mm,ahp,bhp, &		! power law variables
  rg,log_sigma_g, &			! lognormal variables
  rho_e					! particle density (kg m^-3)
  
  real*8 :: tmp1, tmp2
  real*8 :: pi,rc

  integer k,lidx,uidx

  pi = acos(-1.0)
  
! // if density is constant, store equivalent values for apm and bpm
  if ((rho_c > 0) .and. (apm < 0)) then
    apm = (pi/6)*rho_c
    bpm = 3.
  endif
  
  select case(dtype)
  
! ---------------------------------------------------------!
! // modified gamma                                        !
! ---------------------------------------------------------!
! :: N0 = total number concentration (m^-3)
! :: np = fixed number concentration (kg^-1)
! :: D0 = characteristic diameter (um)
! :: dm = mean diameter (um)
! :: vu = distribution width parameter

  case(1)  
    if (abs(p1+1) < 1E-8) then

!     // D0, vu are given  
      vu = p3 
      
      if(Re.le.0) then 
      	dm = p2
	D0 = gamma(vu)/gamma(vu+1)*dm
      else
	D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
      endif
     
      if (scaled .eqv. .false.) then
      
        fc = ( &
             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
	     ) * 1E-12
	scaled = .true.

      endif	   

      N = fc*rho_a*(Q*1E-3)
    
    elseif (abs(p2+1) < 1E-8) then

!     // N0, vu are given    
      np = p1
      vu = p3 
      tmp1 = (Q*1E-3)**(1./bpm)
      
      if (scaled .eqv. .false.) then

        fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** &
             (1./bpm))**vu
	     
        scaled = .true.

      endif

      N = ( &
          (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
          exp(-1.*fc**(1./vu)/tmp1) &
 	  ) * 1E-12

    else

!     // vu isn't given
      print *, 'Error: Must specify a value for vu'
      stop
    
    endif
    
! ---------------------------------------------------------!
! // exponential                                           !
! ---------------------------------------------------------!
! :: N0 = intercept parameter (m^-4)
! :: ld = slope parameter (um)

  case(2)
    if (abs(p1+1) > 1E-8) then

!     // N0 has been specified, determine ld
      N0 = p1

      if(Re>0) then

	! if Re is set and No is set than the distribution is fully defined.
	! so we assume Re and No have already been chosen consistant with  
	! the water content, Q.

	! print *,'using Re pass ...'

	ld = 1.5/Re   ! units 1/um

	N = ( &
          	N0*exp(-1*ld*D) &
        ) * 1E-12
    
      else

      	tmp1 = 1./(1.+bpm)
      
      	if (scaled .eqv. .false.) then
        	fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
		scaled = .true.

      	endif
     
      	N = ( &
        	N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
	) * 1E-12

      endif	

    elseif (abs(p2+1) > 1E-8) then

!     // ld has been specified, determine N0
      ld = p2

      if (scaled .eqv. .false.) then

        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
        scaled = .true.

      endif

      N = fc*rho_a*(Q*1E-3)

    else

!     // ld will be determined from temperature, then N0 follows
      ld = 1220*10.**(-0.0245*tc)*1E-6
      N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
    
      N = ( &
          N0*exp(-1*ld*D) &
          ) * 1E-12
    
    endif
  
! ---------------------------------------------------------!
! // power law                                             !
! ---------------------------------------------------------!
! :: ahp = Ar parameter (m^-4 mm^-bhp)
! :: bhp = br parameter
! :: dmin_mm = lower bound (mm)
! :: dmax_mm = upper bound (mm)

  case(3)

!   :: br parameter
    if (abs(p1+2) < 1E-8) then
!     :: if p1=-2, bhp is parameterized according to Ryan (2000),
!     :: applicatable to cirrus clouds
      if (tc < -30) then
        bhp = -1.75+0.09*((tc+273)-243.16)
      elseif ((tc >= -30) .and. (tc < -9)) then
        bhp = -3.25-0.06*((tc+273)-265.66)
      else
        bhp = -2.15
      endif
    elseif (abs(p1+3) < 1E-8) then      
!     :: if p1=-3, bhp is parameterized according to Ryan (2000),
!     :: applicable to frontal clouds
      if (tc < -35) then
        bhp = -1.75+0.09*((tc+273)-243.16)
      elseif ((tc >= -35) .and. (tc < -17.5)) then
        bhp = -2.65+0.09*((tc+273)-255.66)
      elseif ((tc >= -17.5) .and. (tc < -9)) then
        bhp = -3.25-0.06*((tc+273)-265.66)
      else
        bhp = -2.15
      endif    
    else
!     :: otherwise the specified value is used
      bhp = p1
    endif

!   :: Ar parameter
    dmin_mm = dmin*1E-3
    dmax_mm = dmax*1E-3

!   :: commented lines are original method with constant density
      ! rc = 500.		! (kg/m^3)
      ! tmp1 = 6*rho_a*(bhp+4)
      ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
      ! ahp = (Q*1E-3)*1E12*tmp1/tmp2

!   :: new method is more consistent with the rest of the distributions
!   :: and allows density to vary with particle size
      tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
      tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
      ahp = tmp1/tmp2 * 1E24
      ! ahp = tmp1/tmp2 
 
      lidx = infind(D,dmin)
      uidx = infind(D,dmax)    
      do k=lidx,uidx
 
    	N(k) = ( &
        ahp*(D(k)*1E-3)**bhp &
	) * 1E-12    

      enddo

	! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm

! ---------------------------------------------------------!
! // monodisperse                                          !
! ---------------------------------------------------------!
! :: D0 = particle diameter (um)

  case(4)
  
    if (scaled .eqv. .false.) then
    
      D0 = p1
      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
      fc(1) = (6./(pi*D0**3*rho_e))*1E12
      scaled = .true.
      
    endif
    
    N(1) = fc(1)*rho_a*(Q*1E-3)
    
! ---------------------------------------------------------!
! // lognormal                                             !
! ---------------------------------------------------------!
! :: N0 = total number concentration (m^-3)
! :: np = fixed number concentration (kg^-1)
! :: rg = mean radius (um)
! :: log_sigma_g = ln(geometric standard deviation)

  case(5)
    if (abs(p1+1) < 1E-8) then

!     // rg, log_sigma_g are given
      log_sigma_g = p3
      tmp2 = (bpm*log_sigma_g)**2.
      if(Re.le.0) then 
      	rg = p2
      else
	rg =Re*exp(-2.5*(log_sigma_g**2))
      endif
 
      if (scaled .eqv. .false.) then
            
        fc = 0.5 * ( &
	     (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
	     log_sigma_g*D*0.5*1E-6)) * &
	     exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
	     ) * 1E-12
	scaled = .true.
	     
      endif
	        
      N = fc*rho_a*(Q*1E-3)
      
    elseif (abs(p2+1) < 1E-8) then

!     // N0, log_sigma_g are given    
      Np = p1
      log_sigma_g = p3
      N0 = np*rho_a
      tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
      tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.      
      rg = ((tmp1/tmp2)**(1/bpm))*1E6
      
      N = 0.5*( &
        N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
	exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
	) * 1E-12      
      
    else

!     // vu isn't given
      print *, 'Error: Must specify a value for sigma_g'
      stop
    
    endif
    
  end select
  
  end subroutine dsd



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
         
! $Id: format_input.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

! FORMAT_INPUT: Procedures to prepare data for input to the simulator
! Compiled/Modified:
!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
!
! irreg_to_grid (subroutine)
! order_data (subroutine)

  module format_input

  contains

! ----------------------------------------------------------------------------
! SUBROUTINE IRREG_TO_GRID
! ----------------------------------------------------------------------------
  subroutine irreg_to_grid(hgt_matrix,t_matrix,p_matrix,rh_matrix, &
    env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix)
  use array_lib
  implicit none

! Purpose:
!   Linearly interpolate sounding-level data to the hydrometeor-level
!   resolution
!
! Inputs:
!   [hgt_matrix]       hydrometeor-level heights
!   [env_hgt_matrix]   sounding-level heights
!   [env_t_matrix]     sounding-level temperatures
!   [env_p_matrix]     sounding-level pressures
!   [env_rh_matrix]    sounding-level relative humidities
!
! Outputs:
!   [t_matrix]         hydrometeor-level temperatures
!   [p_matrix]         hydrometeor-level pressures
!   [rh_matrix]        hydrometeor-level relative humidities
!
! Created:
!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----
  real*8, dimension(:,:), intent(in) :: &
    hgt_matrix,env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix

! ----- OUTPUTS -----
  real*8, dimension(:,:), intent(out) :: &
    t_matrix,p_matrix,rh_matrix

! ----- INTERNAL -----
  integer :: nprof, i
  integer,parameter :: KR8 = selected_real_kind(15,300)

  nprof = size(hgt_matrix,1)
  do i=1,nprof
    call lin_interpolate(env_t_matrix(i,:),env_hgt_matrix(i,:), &
      t_matrix(i,:),hgt_matrix(i,:),1000._KR8)
    call lin_interpolate(env_p_matrix(i,:),env_hgt_matrix(i,:), &
      p_matrix(i,:),hgt_matrix(i,:),1000._KR8)
    call lin_interpolate(env_rh_matrix(i,:),env_hgt_matrix(i,:), &
      rh_matrix(i,:),hgt_matrix(i,:),1000._KR8)
  enddo

  end subroutine irreg_to_grid

! ----------------------------------------------------------------------------
! SUBROUTINE ORDER_DATA
! ----------------------------------------------------------------------------
  subroutine order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
    rh_matrix,sfc_radar,hgt_reversed)
  implicit none

! Purpose:
!   Ensure that input data is in top-down order/bottom-up order,
!   for space-based/surface based radars, respectively
!
! Inputs:
!   [hgt_matrix]   heights
!   [hm_matrix]    mixing ratios
!   [t_matrix]     temperatures
!   [p_matrix]     pressures
!   [rh_matrix]    relative humidities
!   [sfc_radar]    1=surface radar, 0=spaceborne
!
! Outputs:
!   [hgt_matrix],[hm_matrix],[p_matrix,[t_matrix],[rh_matrix] in proper
!   order for input to the radar simulator routine
!   [hgt_reversed]   T=heights were reordered,F=heights were not reordered
!
! Note:
!   The order for all profiles is assumed to the same as the first profile.
!
! Created:
!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----
  integer, intent(in) :: sfc_radar

! ----- OUTPUTS -----
  real*8, dimension(:,:), intent(inout) :: &
    hgt_matrix,p_matrix,t_matrix,rh_matrix
  real*8, dimension(:,:,:), intent(inout) :: &
    hm_matrix
  logical, intent(out) :: hgt_reversed

! ----- INTERNAL -----
  integer :: ngate
  logical :: hgt_descending
  

  ngate = size(hgt_matrix,2)
  hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
      
! :: surface: heights must be ascending
! :: space-based: heights must be descending
  if ( &
     (sfc_radar == 1 .and. hgt_descending) .or.  &
     (sfc_radar == 0 .and. (.not. hgt_descending)) &
     ) &
  then

    hgt_matrix(:,:) = hgt_matrix(:,ngate:1:-1)
    hm_matrix(:,:,:) = hm_matrix(:,:,ngate:1:-1)
    p_matrix(:,:) = p_matrix(:,ngate:1:-1)
    t_matrix(:,:) = t_matrix(:,ngate:1:-1)
    rh_matrix(:,:) = rh_matrix(:,ngate:1:-1) 

    hgt_reversed = .true.
  else
    hgt_reversed = .false.
  endif

  end subroutine order_data

  end module format_input


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
         
! $Id: gases.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

  function gases(PRES_mb,T,RH,f)
  implicit none
  
! Purpose:
!   Compute 2-way gaseous attenuation through a volume in microwave
!
! Inputs:
!   [PRES_mb]   pressure (mb) (hPa)
!   [T]         temperature (K)
!   [RH]        relative humidity (%)
!   [f]         frequency (GHz), < 300 GHz
!
! Returns:
!   2-way gaseous attenuation (dB/km)
!
! Reference:
!   Uses method of Liebe (1985)
!
! Created:
!   12/09/05  John Haynes (haynes@atmos.colostate.edu)
! Modified:
!   01/31/06  Port from IDL to Fortran 90

  integer, parameter :: &
  nbands_o2 = 48 ,&
  nbands_h2o = 30
  real*8, intent(in) :: PRES_mb, T, RH, f
  real*8 :: gases, th, e, p, sumo, gm0, a0, ap, term1, term2, term3, &
            bf, be, term4, npp
  real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6
  real*8, dimension(nbands_h2o) :: v1, b1, b2, b3
  integer :: i
  
! // table1 parameters  v0, a1, a2, a3, a4, a5, a6  
  data v0/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500, &
  52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570, &
  55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810, &
  58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750, &
  61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150, &
  64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270, &
  67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420, &
  118.7503410,368.4983500,424.7631200,487.2493700,715.3931500, &
  773.8387300, 834.1453300/
  data a1/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141, &
  0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535, &
  0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240, &
  0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152, &
  0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801, &
  0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002, &
  0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/
  data a2/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000, &
  6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000, &
  0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000, &
  0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000, &
  1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000, &
  6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000, &
  0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/
  data a3/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000, &
  0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000, &
  0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900, &
  0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800, &
  0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000, &
  0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000, &
  0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/
  data a4/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
  0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/
  data a5/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000, &
  0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500, &
  0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400, &
  0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600, &
  -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000, &
  -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000, &
  -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000, &
  0.0000000,0.0000000,0.0000000,0.0000000/
  data a6/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,&
  1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000, &
  0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, &
  0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, &
  2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000, &
  1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000, &
  0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/

! // table2 parameters  v1, b1, b2, b3
  data v1/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440, &
  325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, &
  443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, &
  504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, &
  859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, &
  987.9267640/
  data b1/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000, &
  0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, &
  0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, &
  0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, &
  8.5600000,9.1600000,138.0000000/
  data b2/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000, &
  9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000, &
  3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000, &
  7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000, &
  1.3690000,1.8420000,0.1780000/
  data b3/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000, &
  0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000, &
  0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000, &
  0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000, &
  0.0253000,0.0240000,0.0286000/
  
! // conversions
  th = 300./T		! unitless
  e = (RH*th**5)/(41.45*10**(9.834*th-10))	! kPa
  p = PRES_mb/10.-e	! kPa

! // term1
  sumo = 0.
  do i=1,nbands_o2
    sumo = sumo + fpp_o2(p,th,e,a3(i),a4(i),a5(i),a6(i),f,v0(i)) &
           * s_o2(p,th,a1(i),a2(i))
  enddo
  term1 = sumo

! // term2
  gm0 = 5.6E-3*(p+1.1*e)*th**(0.8)
  a0 = 3.07E-4
  ap = 1.4*(1-1.2*f**(1.5)*1E-5)*1E-10
  term2 = (2*a0*(gm0*(1+(f/gm0)**2)*(1+(f/60.)**2))**(-1) + ap*p*th**(2.5)) &
          * f*p*th**2

! // term3
  sumo = 0.
  do i=1,nbands_h2o
    sumo = sumo + fpp_h2o(p,th,e,b3(i),f,v1(i)) &
           * s_h2o(th,e,b1(i),b2(i))
  enddo
  term3 = sumo

! // term4
  bf = 1.4E-6
  be = 5.41E-5
  term4 = (bf*p+be*e*th**3)*f*e*th**(2.5)

! // summation and result
  npp = term1 + term2 + term3 + term4
  gases = 0.182*f*npp

! ----- SUB FUNCTIONS -----
    
  contains
  
  function fpp_o2(p,th,e,a3,a4,a5,a6,f,v0)
  real*8 :: fpp_o2,p,th,e,a3,a4,a5,a6,f,v0
  real*8 :: gm, delt, x, y
  gm = a3*(p*th**(0.8-a4)+1.1*e*th)
  delt = a5*p*th**(a6)
  x = (v0-f)**2+gm**2
  y = (v0+f)**2+gm**2
  fpp_o2 = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))  
  end function fpp_o2
  
  function fpp_h2o(p,th,e,b3,f,v0)
  real*8 :: fpp_h2o,p,th,e,b3,f,v0
  real*8 :: gm, delt, x, y
  gm = b3*(p*th**(0.8)+4.8*e*th)
  delt = 0.
  x = (v0-f)**2+gm**2
  y = (v0+f)**2+gm**2
  fpp_h2o = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))
  end function fpp_h2o
  
  function s_o2(p,th,a1,a2)
  real*8 :: s_o2,p,th,a1,a2
  s_o2 = a1*p*th**(3)*exp(a2*(1-th))
  end function s_o2

  function s_h2o(th,e,b1,b2)
  real*8 :: s_h2o,th,e,b1,b2
  s_h2o = b1*e*th**(3.5)*exp(b2*(1-th))
  end function s_h2o
  
  end function gases



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
        
! $Id: load_hydrometeor_classes.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

  subroutine load_hydrometeor_classes(Nprmts_max,dist_prmts_hydro,hp,nhclass)
  use radar_simulator_types
  implicit none
  
! Purpose:
!   Loads the hydrometeor classes to be used in calculations
!   Part of QuickBeam v1.03 by John Haynes
!   http://reef.atmos.colostate.edu/haynes/radarsim
!
! Inputs:  
!   [dist_prmts_hydro]   from data in hydrometeor class input 
!
! Outputs:
!   [hp]            structure that define hydrometeor types
!
! Modified:
!   08/23/2006  placed into subroutine form (Roger Marchand)
   
! ----- INPUT -----
  integer, intent(in) :: nhclass,Nprmts_max
  real,dimension(Nprmts_max,nhclass), intent(in) :: dist_prmts_hydro
! ----- OUTPUTS -----  
  type(class_param), intent(out) :: hp
  
! ----- INTERNAL -----  
  integer :: i
	
    hp%rho(:) = -1

    do i = 1,nhclass,1
    hp%dtype(i) = dist_prmts_hydro(1,i)
    hp%col(i) = dist_prmts_hydro(2,i)
    hp%phase(i) = dist_prmts_hydro(3,i)
    hp%cp(i) = dist_prmts_hydro(4,i)
    hp%dmin(i) = dist_prmts_hydro(5,i)
    hp%dmax(i) = dist_prmts_hydro(6,i)
    hp%apm(i) = dist_prmts_hydro(7,i)
    hp%bpm(i) = dist_prmts_hydro(8,i)
    hp%rho(i) = dist_prmts_hydro(9,i)
    hp%p1(i) = dist_prmts_hydro(10,i)
    hp%p2(i) = dist_prmts_hydro(11,i)
    hp%p3(i) = dist_prmts_hydro(12,i)
    enddo
        
!   // setup scaling arrays
    hp%fc = -999.
    hp%scaled = .false.	
    hp%z_flag = .false.
    hp%rho_eff = -999.
    hp%ifc = -9
    hp%idd = -9
   
  
  end subroutine load_hydrometeor_classes


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
         
! $Id: load_mie_table.f90,v 1.1.2.1.2.1.8.1 2010/04/29 21:14:27 wfc Exp $
! $Name: hiram_20101115_bw $

  subroutine load_mie_table(mie_table_name,mt)
  use radar_simulator_types
  use mpp_mod,only: get_unit                  
  implicit none
  
! Purpose:
!   Loads the Mie table data
!   Part of Quickbeam v1.03
!   http://reef.atmos.colostate.edu/haynes/radarsim
!
! Inputs:  
!   [mie_table_name]   Mie table input file
!
! Outputs:
!   [mt]            structure of Mie table data
!
! Created from Quickbeam v1.02 08/24/2006 by Roger Marchand  

! ----- INPUT -----
  character*200, intent(in) :: mie_table_name

! ----- OUTPUT -----
  type(mie), intent(out) :: mt

! ----- INTERNAL -----  
  integer :: i, funit

  integer*4 :: dummy_in(4)
	
    funit = get_unit()
    open(funit,file=mie_table_name,action='read')
 
    read(funit,*) dummy_in 

	if(dummy_in(1).ne. mt_nfreq .or. &
	   dummy_in(2).ne. mt_ntt .or. &
	   dummy_in(3).ne. mt_nf .or. &
	   dummy_in(4).ne. mt_nd) then

		print *,'Mie file is of size :',dummy_in(:)
		print *,'  expected a size of:',mt_nfreq, mt_ntt,mt_nf,mt_nf
		print *,'  change paramters in radar_simulator_types.f90 ?? '
		stop
	endif

    read(funit,*) mt%freq
    read(funit,*) mt%tt
    read(funit,*) mt%f
    read(funit,*) mt%phase
    read(funit,*) mt%D
    read(funit,*) mt%qext
    read(funit,*) mt%qbsca
    
    close(funit)

! // create arrays of liquid/ice temperature
  cnt_liq = 0
  cnt_ice = 0
  do i=1,mt_ntt
    if (mt%phase(i) == 0) cnt_liq = cnt_liq + 1
    if (mt%phase(i) == 1) cnt_ice = cnt_ice + 1
  enddo
  allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))
  do i=1,cnt_liq
    mt_ttl(i) = mt%tt(i)
  enddo
  do i=1,cnt_ice
    mt_tti(i) = mt%tt(cnt_liq+i)
  enddo

  end subroutine load_mie_table


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
        
! $Id: math_lib.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

! MATH_LIB: Mathematics procedures for F90
! Compiled/Modified:
!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
! 
! gamma (function)
! path_integral (function)
! avint (subroutine)
  
  module math_lib
  implicit none

  contains

! ----------------------------------------------------------------------------
! function GAMMA
! ----------------------------------------------------------------------------
  function gamma(x)
  implicit none
!
! Purpose:
!   Returns the gamma function
!
! Input:
!   [x]   value to compute gamma function of
!
! Returns:
!   gamma(x)
!
! Coded:
!   02/02/06  John Haynes (haynes@atmos.colostate.edu)
!   (original code of unknown origin)

! ----- INPUTS -----
  real*8, intent(in) :: x
  
! ----- OUTPUTS -----
  real*8 :: gamma

! ----- INTERNAL -----  
  real*8 :: pi,ga,z,r,gr
  real*8 :: g(26)
  integer :: k,m1,m
       
  pi = acos(-1.)	
  if (x ==int(x)) then
    if (x > 0.0) then
      ga=1.0
      m1=x-1
      do k=2,m1
        ga=ga*k
      enddo
    else
      ga=1.0+300
    endif
  else
    if (abs(x) > 1.0) then
      z=abs(x)
      m=int(z)
      r=1.0
      do k=1,m
        r=r*(z-k)
      enddo
      z=z-m
    else
      z=x
    endif
    data g/1.0,0.5772156649015329, &
           -0.6558780715202538, -0.420026350340952d-1, &
           0.1665386113822915,-.421977345555443d-1, &
           -.96219715278770d-2, .72189432466630d-2, &
           -.11651675918591d-2, -.2152416741149d-3, &
           .1280502823882d-3, -.201348547807d-4, &
           -.12504934821d-5, .11330272320d-5, &
           -.2056338417d-6, .61160950d-8, &
           .50020075d-8, -.11812746d-8, &
           .1043427d-9, .77823d-11, &
          -.36968d-11, .51d-12, &
          -.206d-13, -.54d-14, .14d-14, .1d-15/
    gr=g(26)
    do k=25,1,-1
      gr=gr*z+g(k)
    enddo 
    ga=1.0/(gr*z)
    if (abs(x) > 1.0) then
      ga=ga*r
      if (x < 0.0) ga=-pi/(x*ga*sin(pi*x))
    endif
  endif
  gamma = ga
  return
  end function gamma
  
! ----------------------------------------------------------------------------
! function PATH_INTEGRAL 
! ----------------------------------------------------------------------------
  function path_integral(f,s,i1,i2)
  use m_mrgrnk
  use array_lib
  implicit none
!
! Purpose:
!   evalues the integral (f ds) between f(index=i1) and f(index=i2)
!   using the AVINT procedure
!
! Inputs:
!   [f]    functional values
!   [s]    abscissa values
!   [i1]   index of lower limit
!   [i2]   index of upper limit
!
! Returns:
!   result of path integral
!
! Notes:
!   [s] may be in forward or reverse numerical order
!
! Requires:
!   mrgrnk package
!
! Created:
!   02/02/06  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----  
  real*8, intent(in), dimension(:) :: f,s  
  integer, intent(in) :: i1, i2

! ---- OUTPUTS -----
  real*8 :: path_integral  
  
! ----- INTERNAL -----    
  real*8 :: sumo, deltah, val
  integer*4 :: nelm, j
  integer*4, dimension(i2-i1+1) :: idx
  real*8, dimension(i2-i1+1) :: f_rev, s_rev

  nelm = i2-i1+1
  if (nelm > 3) then
    call mrgrnk(s(i1:i2),idx)
    s_rev = s(idx)
    f_rev = f(idx)
    call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), &
      s_rev(i1),s_rev(i2), val)
    path_integral = val
  else
     sumo = 0.
     do j=i1,i2
       deltah = abs(s(i1+1)-s(i1))
       sumo = sumo + f(j)*deltah
    enddo
    path_integral = sumo
  endif 
  ! print *, sumo

  return
  end function path_integral
  
! ----------------------------------------------------------------------------
! subroutine AVINT
! ----------------------------------------------------------------------------
  subroutine avint ( ftab, xtab, ntab, a_in, b_in, result )
  implicit none
!
! Purpose:
!   estimate the integral of unevenly spaced data
!
! Inputs:
!   [ftab]     functional values
!   [xtab]     abscissa values
!   [ntab]     number of elements of [ftab] and [xtab]
!   [a]        lower limit of integration
!   [b]        upper limit of integration
!
! Outputs:
!   [result]   approximate value of integral
!
! Reference:
!   From SLATEC libraries, in public domain
!
!***********************************************************************
!
!  AVINT estimates the integral of unevenly spaced data.
!
!  Discussion:
!
!    The method uses overlapping parabolas and smoothing.
!
!  Modified:
!
!    30 October 2000
!    4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of
!                    loop to allow vectorization.
!
!  Reference:
!
!    Philip Davis and Philip Rabinowitz,
!    Methods of Numerical Integration,
!    Blaisdell Publishing, 1967.
!
!    P E Hennion,
!    Algorithm 77,
!    Interpolation, Differentiation and Integration,
!    Communications of the Association for Computing Machinery,
!    Volume 5, page 96, 1962.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) FTAB(NTAB), the function values,
!    FTAB(I) = F(XTAB(I)).
!
!    Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the
!    function values are given.  The XTAB's must be distinct
!    and in ascending order.
!
!    Input, integer NTAB, the number of entries in FTAB and
!    XTAB.  NTAB must be at least 3.
!
!    Input, real ( kind = 8 ) A, the lower limit of integration.  A should
!    be, but need not be, near one endpoint of the interval
!    (X(1), X(NTAB)).
!
!    Input, real ( kind = 8 ) B, the upper limit of integration.  B should
!    be, but need not be, near one endpoint of the interval
!    (X(1), X(NTAB)).
!
!    Output, real ( kind = 8 ) RESULT, the approximate value of the integral.

  integer, intent(in) :: ntab

  integer,parameter :: KR8 = selected_real_kind(15,300)
  real ( kind = KR8 ), intent(in) :: a_in
  real ( kind = KR8 ) a
  real ( kind = KR8 ) atemp
  real ( kind = KR8 ), intent(in) :: b_in
  real ( kind = KR8 ) b
  real ( kind = KR8 ) btemp
  real ( kind = KR8 ) ca
  real ( kind = KR8 ) cb
  real ( kind = KR8 ) cc
  real ( kind = KR8 ) ctemp
  real ( kind = KR8 ), intent(in) :: ftab(ntab)
  integer i
  integer ihi
  integer ilo
  integer ind
  real ( kind = KR8 ), intent(out) :: result
  real ( kind = KR8 ) sum1
  real ( kind = KR8 ) syl
  real ( kind = KR8 ) term1
  real ( kind = KR8 ) term2
  real ( kind = KR8 ) term3
  real ( kind = KR8 ) x1
  real ( kind = KR8 ) x2
  real ( kind = KR8 ) x3
  real ( kind = KR8 ), intent(in) :: xtab(ntab)
  logical lerror
  
  lerror = .false.
  a = a_in
  b = b_in  
  
  if ( ntab < 3 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'AVINT - Fatal error!'
    write ( *, '(a,i6)' ) '  NTAB is less than 3.  NTAB = ', ntab
    stop
  end if
 
  do i = 2, ntab
    if ( xtab(i) <= xtab(i-1) ) then
       lerror = .true.
       exit
    end if
  end do
  
  if (lerror) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'AVINT - Fatal error!'
      write ( *, '(a)' ) '  XTAB(I) is not greater than XTAB(I-1).'
      write ( *, '(a,i6)' ) '  Here, I = ', i
      write ( *, '(a,g14.6)' ) '  XTAB(I-1) = ', xtab(i-1)
      write ( *, '(a,g14.6)' ) '  XTAB(I) =   ', xtab(i)
      stop  
  end if
 
  result = 0.0D+00
 
  if ( a == b ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'AVINT - Warning!'
    write ( *, '(a)' ) '  A = B, integral=0.'
    return
  end if
!
!  If B < A, temporarily switch A and B, and store sign.
!
  if ( b < a ) then
    syl = b
    b = a
    a = syl
    ind = -1
  else
    syl = a
    ind = 1
  end if
!
!  Bracket A and B between XTAB(ILO) and XTAB(IHI).
!
  ilo = 1
  ihi = ntab

  do i = 1, ntab
    if ( a <= xtab(i) ) then
      exit
    end if
    ilo = ilo + 1
  end do

  ilo = max ( 2, ilo )
  ilo = min ( ilo, ntab - 1 )

  do i = 1, ntab
    if ( xtab(i) <= b ) then
      exit
    end if
    ihi = ihi - 1
  end do
  
  ihi = min ( ihi, ntab - 1 )
  ihi = max ( ilo, ihi - 1 )
!
!  Carry out approximate integration from XTAB(ILO) to XTAB(IHI).
!
  sum1 = 0.0D+00
 
  do i = ilo, ihi
 
    x1 = xtab(i-1)
    x2 = xtab(i)
    x3 = xtab(i+1)
    
    term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) )
    term2 = ftab(i)   / ( ( x2 - x1 ) * ( x2 - x3 ) )
    term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) )
 
    atemp = term1 + term2 + term3

    btemp = - ( x2 + x3 ) * term1 &
            - ( x1 + x3 ) * term2 &
            - ( x1 + x2 ) * term3

    ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3
 
    if ( i <= ilo ) then
      ca = atemp
      cb = btemp
      cc = ctemp
    else
      ca = 0.5D+00 * ( atemp + ca )
      cb = 0.5D+00 * ( btemp + cb )
      cc = 0.5D+00 * ( ctemp + cc )
    end if
 
    sum1 = sum1 &
          + ca * ( x2**3 - syl**3 ) / 3.0D+00 &
          + cb * 0.5D+00 * ( x2**2 - syl**2 ) &
          + cc * ( x2 - syl )
 
    ca = atemp
    cb = btemp
    cc = ctemp
 
    syl = x2
 
  end do
 
  result = sum1 &
        + ca * ( b**3 - syl**3 ) / 3.0D+00 &
        + cb * 0.5D+00 * ( b**2 - syl**2 ) &
        + cc * ( b - syl )
!
!  Restore original values of A and B, reverse sign of integral
!  because of earlier switch.
!
  if ( ind /= 1 ) then
    ind = 1
    syl = b
    b = a
    a = syl
    result = -result
  end if
 
  return
  end subroutine avint
  
  end module math_lib



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
       
! $Id: mrgrnk.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

Module m_mrgrnk
Integer, Parameter :: kdp = selected_real_kind(15)
!RSH ADD since FMS default real is 64bit
!  See note in subroutine R_mrgrnk
Integer, Parameter :: ksp = selected_real_kind( 6)
public :: mrgrnk
private :: kdp
private :: R_mrgrnk, I_mrgrnk, D_mrgrnk
interface mrgrnk
  module procedure D_mrgrnk, R_mrgrnk, I_mrgrnk
end interface mrgrnk
contains

Subroutine D_mrgrnk (XDONT, IRNGT)
! __________________________________________________________
!   MRGRNK = Merge-sort ranking of an array
!   For performance reasons, the first 2 passes are taken
!   out of the standard loop, and use dedicated coding.
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
      Integer*4, Dimension (:), Intent (Out) :: IRNGT
! __________________________________________________________
      Real (kind=kdp) :: XVALA, XVALB
!
      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
!
      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
      Select Case (NVAL)
      Case (:0)
         Return
      Case (1)
         IRNGT (1) = 1
         Return
      Case Default
         Continue
      End Select
!
!  Fill-in the index array, creating ordered couples
!
      Do IIND = 2, NVAL, 2
         If (XDONT(IIND-1) <= XDONT(IIND)) Then
            IRNGT (IIND-1) = IIND - 1
            IRNGT (IIND) = IIND
         Else
            IRNGT (IIND-1) = IIND
            IRNGT (IIND) = IIND - 1
         End If
      End Do
      If (Modulo(NVAL, 2) /= 0) Then
         IRNGT (NVAL) = NVAL
      End If
!
!  We will now have ordered subsets A - B - A - B - ...
!  and merge A and B couples into     C   -   C   - ...
!
      LMTNA = 2
      LMTNC = 4
!
!  First iteration. The length of the ordered subsets goes from 2 to 4
!
      Do
         If (NVAL <= 2) Exit
!
!   Loop on merges of A and B into C
!
         Do IWRKD = 0, NVAL - 1, 4
            If ((IWRKD+4) > NVAL) Then
               If ((IWRKD+2) >= NVAL) Exit
!
!   1 2 3
!
               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
!
!   1 3 2
!
               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
                  IRNG2 = IRNGT (IWRKD+2)
                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
                  IRNGT (IWRKD+3) = IRNG2
!
!   3 1 2
!
               Else
                  IRNG1 = IRNGT (IWRKD+1)
                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
                  IRNGT (IWRKD+2) = IRNG1
               End If
               Exit
            End If
!
!   1 2 3 4
!
            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
!
!   1 3 x x
!
            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
               IRNG2 = IRNGT (IWRKD+2)
               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
!   1 3 2 4
                  IRNGT (IWRKD+3) = IRNG2
               Else
!   1 3 4 2
                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                  IRNGT (IWRKD+4) = IRNG2
               End If
!
!   3 x x x
!
            Else
               IRNG1 = IRNGT (IWRKD+1)
               IRNG2 = IRNGT (IWRKD+2)
               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
                  IRNGT (IWRKD+2) = IRNG1
                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
!   3 1 2 4
                     IRNGT (IWRKD+3) = IRNG2
                  Else
!   3 1 4 2
                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                     IRNGT (IWRKD+4) = IRNG2
                  End If
               Else
!   3 4 1 2
                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
                  IRNGT (IWRKD+3) = IRNG1
                  IRNGT (IWRKD+4) = IRNG2
               End If
            End If
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 4
         Exit
      End Do
!
!  Iteration loop. Each time, the length of the ordered subsets
!  is doubled.
!
      Do
         If (LMTNA >= NVAL) Exit
         IWRKF = 0
         LMTNC = 2 * LMTNC
!
!   Loop on merges of A and B into C
!
         Do
            IWRK = IWRKF
            IWRKD = IWRKF + 1
            JINDA = IWRKF + LMTNA
            IWRKF = IWRKF + LMTNC
            If (IWRKF >= NVAL) Then
               If (JINDA >= NVAL) Exit
               IWRKF = NVAL
            End If
            IINDA = 1
            IINDB = JINDA + 1
!
!   Shortcut for the case when the max of A is smaller
!   than the min of B. This line may be activated when the
!   initial set is already close to sorted.
!
!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
!
!  One steps in the C subset, that we build in the final rank array
!
!  Make a copy of the rank array for the merge iteration
!
            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
!
            XVALA = XDONT (JWRKT(IINDA))
            XVALB = XDONT (IRNGT(IINDB))
!
            Do
               IWRK = IWRK + 1
!
!  We still have unprocessed values in both A and B
!
               If (XVALA > XVALB) Then
                  IRNGT (IWRK) = IRNGT (IINDB)
                  IINDB = IINDB + 1
                  If (IINDB > IWRKF) Then
!  Only A still with unprocessed values
                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
                     Exit
                  End If
                  XVALB = XDONT (IRNGT(IINDB))
               Else
                  IRNGT (IWRK) = JWRKT (IINDA)
                  IINDA = IINDA + 1
                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
                  XVALA = XDONT (JWRKT(IINDA))
               End If
!
            End Do
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 2 * LMTNA
      End Do
!
      Return
!
End Subroutine D_mrgrnk

Subroutine R_mrgrnk (XDONT, IRNGT)
! __________________________________________________________
!   MRGRNK = Merge-sort ranking of an array
!   For performance reasons, the first 2 passes are taken
!   out of the standard loop, and use dedicated coding.
! __________________________________________________________
! _________________________________________________________
      Real (kind=ksp), Dimension (:), Intent (In) :: XDONT
!RSH above needed since FMS default real is 64 bit, handled by D_mrgrnk
!  without this mod R_mrgrnk and D_mrgrnk are duplicates, which
!  compiler dislikes 
!     Real, Dimension (:), Intent (In) :: XDONT
      Integer*4, Dimension (:), Intent (Out) :: IRNGT
! __________________________________________________________
      Real :: XVALA, XVALB
!
      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
!
      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
      Select Case (NVAL)
      Case (:0)
         Return
      Case (1)
         IRNGT (1) = 1
         Return
      Case Default
         Continue
      End Select
!
!  Fill-in the index array, creating ordered couples
!
      Do IIND = 2, NVAL, 2
         If (XDONT(IIND-1) <= XDONT(IIND)) Then
            IRNGT (IIND-1) = IIND - 1
            IRNGT (IIND) = IIND
         Else
            IRNGT (IIND-1) = IIND
            IRNGT (IIND) = IIND - 1
         End If
      End Do
      If (Modulo(NVAL, 2) /= 0) Then
         IRNGT (NVAL) = NVAL
      End If
!
!  We will now have ordered subsets A - B - A - B - ...
!  and merge A and B couples into     C   -   C   - ...
!
      LMTNA = 2
      LMTNC = 4
!
!  First iteration. The length of the ordered subsets goes from 2 to 4
!
      Do
         If (NVAL <= 2) Exit
!
!   Loop on merges of A and B into C
!
         Do IWRKD = 0, NVAL - 1, 4
            If ((IWRKD+4) > NVAL) Then
               If ((IWRKD+2) >= NVAL) Exit
!
!   1 2 3
!
               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
!
!   1 3 2
!
               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
                  IRNG2 = IRNGT (IWRKD+2)
                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
                  IRNGT (IWRKD+3) = IRNG2
!
!   3 1 2
!
               Else
                  IRNG1 = IRNGT (IWRKD+1)
                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
                  IRNGT (IWRKD+2) = IRNG1
               End If
               Exit
            End If
!
!   1 2 3 4
!
            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
!
!   1 3 x x
!
            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
               IRNG2 = IRNGT (IWRKD+2)
               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
!   1 3 2 4
                  IRNGT (IWRKD+3) = IRNG2
               Else
!   1 3 4 2
                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                  IRNGT (IWRKD+4) = IRNG2
               End If
!
!   3 x x x
!
            Else
               IRNG1 = IRNGT (IWRKD+1)
               IRNG2 = IRNGT (IWRKD+2)
               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
                  IRNGT (IWRKD+2) = IRNG1
                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
!   3 1 2 4
                     IRNGT (IWRKD+3) = IRNG2
                  Else
!   3 1 4 2
                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                     IRNGT (IWRKD+4) = IRNG2
                  End If
               Else
!   3 4 1 2
                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
                  IRNGT (IWRKD+3) = IRNG1
                  IRNGT (IWRKD+4) = IRNG2
               End If
            End If
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 4
         Exit
      End Do
!
!  Iteration loop. Each time, the length of the ordered subsets
!  is doubled.
!
      Do
         If (LMTNA >= NVAL) Exit
         IWRKF = 0
         LMTNC = 2 * LMTNC
!
!   Loop on merges of A and B into C
!
         Do
            IWRK = IWRKF
            IWRKD = IWRKF + 1
            JINDA = IWRKF + LMTNA
            IWRKF = IWRKF + LMTNC
            If (IWRKF >= NVAL) Then
               If (JINDA >= NVAL) Exit
               IWRKF = NVAL
            End If
            IINDA = 1
            IINDB = JINDA + 1
!
!   Shortcut for the case when the max of A is smaller
!   than the min of B. This line may be activated when the
!   initial set is already close to sorted.
!
!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
!
!  One steps in the C subset, that we build in the final rank array
!
!  Make a copy of the rank array for the merge iteration
!
            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
!
            XVALA = XDONT (JWRKT(IINDA))
            XVALB = XDONT (IRNGT(IINDB))
!
            Do
               IWRK = IWRK + 1
!
!  We still have unprocessed values in both A and B
!
               If (XVALA > XVALB) Then
                  IRNGT (IWRK) = IRNGT (IINDB)
                  IINDB = IINDB + 1
                  If (IINDB > IWRKF) Then
!  Only A still with unprocessed values
                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
                     Exit
                  End If
                  XVALB = XDONT (IRNGT(IINDB))
               Else
                  IRNGT (IWRK) = JWRKT (IINDA)
                  IINDA = IINDA + 1
                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
                  XVALA = XDONT (JWRKT(IINDA))
               End If
!
            End Do
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 2 * LMTNA
      End Do
!
      Return
!
End Subroutine R_mrgrnk
Subroutine I_mrgrnk (XDONT, IRNGT)
! __________________________________________________________
!   MRGRNK = Merge-sort ranking of an array
!   For performance reasons, the first 2 passes are taken
!   out of the standard loop, and use dedicated coding.
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In)  :: XDONT
      Integer*4, Dimension (:), Intent (Out) :: IRNGT
! __________________________________________________________
      Integer :: XVALA, XVALB
!
      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
!
      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
      Select Case (NVAL)
      Case (:0)
         Return
      Case (1)
         IRNGT (1) = 1
         Return
      Case Default
         Continue
      End Select
!
!  Fill-in the index array, creating ordered couples
!
      Do IIND = 2, NVAL, 2
         If (XDONT(IIND-1) <= XDONT(IIND)) Then
            IRNGT (IIND-1) = IIND - 1
            IRNGT (IIND) = IIND
         Else
            IRNGT (IIND-1) = IIND
            IRNGT (IIND) = IIND - 1
         End If
      End Do
      If (Modulo(NVAL, 2) /= 0) Then
         IRNGT (NVAL) = NVAL
      End If
!
!  We will now have ordered subsets A - B - A - B - ...
!  and merge A and B couples into     C   -   C   - ...
!
      LMTNA = 2
      LMTNC = 4
!
!  First iteration. The length of the ordered subsets goes from 2 to 4
!
      Do
         If (NVAL <= 2) Exit
!
!   Loop on merges of A and B into C
!
         Do IWRKD = 0, NVAL - 1, 4
            If ((IWRKD+4) > NVAL) Then
               If ((IWRKD+2) >= NVAL) Exit
!
!   1 2 3
!
               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
!
!   1 3 2
!
               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
                  IRNG2 = IRNGT (IWRKD+2)
                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
                  IRNGT (IWRKD+3) = IRNG2
!
!   3 1 2
!
               Else
                  IRNG1 = IRNGT (IWRKD+1)
                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
                  IRNGT (IWRKD+2) = IRNG1
               End If
               Exit
            End If
!
!   1 2 3 4
!
            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
!
!   1 3 x x
!
            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
               IRNG2 = IRNGT (IWRKD+2)
               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
!   1 3 2 4
                  IRNGT (IWRKD+3) = IRNG2
               Else
!   1 3 4 2
                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                  IRNGT (IWRKD+4) = IRNG2
               End If
!
!   3 x x x
!
            Else
               IRNG1 = IRNGT (IWRKD+1)
               IRNG2 = IRNGT (IWRKD+2)
               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
                  IRNGT (IWRKD+2) = IRNG1
                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
!   3 1 2 4
                     IRNGT (IWRKD+3) = IRNG2
                  Else
!   3 1 4 2
                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                     IRNGT (IWRKD+4) = IRNG2
                  End If
               Else
!   3 4 1 2
                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
                  IRNGT (IWRKD+3) = IRNG1
                  IRNGT (IWRKD+4) = IRNG2
               End If
            End If
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 4
         Exit
      End Do
!
!  Iteration loop. Each time, the length of the ordered subsets
!  is doubled.
!
      Do
         If (LMTNA >= NVAL) Exit
         IWRKF = 0
         LMTNC = 2 * LMTNC
!
!   Loop on merges of A and B into C
!
         Do
            IWRK = IWRKF
            IWRKD = IWRKF + 1
            JINDA = IWRKF + LMTNA
            IWRKF = IWRKF + LMTNC
            If (IWRKF >= NVAL) Then
               If (JINDA >= NVAL) Exit
               IWRKF = NVAL
            End If
            IINDA = 1
            IINDB = JINDA + 1
!
!   Shortcut for the case when the max of A is smaller
!   than the min of B. This line may be activated when the
!   initial set is already close to sorted.
!
!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
!
!  One steps in the C subset, that we build in the final rank array
!
!  Make a copy of the rank array for the merge iteration
!
            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
!
            XVALA = XDONT (JWRKT(IINDA))
            XVALB = XDONT (IRNGT(IINDB))
!
            Do
               IWRK = IWRK + 1
!
!  We still have unprocessed values in both A and B
!
               If (XVALA > XVALB) Then
                  IRNGT (IWRK) = IRNGT (IINDB)
                  IINDB = IINDB + 1
                  If (IINDB > IWRKF) Then
!  Only A still with unprocessed values
                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
                     Exit
                  End If
                  XVALB = XDONT (IRNGT(IINDB))
               Else
                  IRNGT (IWRK) = JWRKT (IINDA)
                  IINDA = IINDA + 1
                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
                  XVALA = XDONT (JWRKT(IINDA))
               End If
!
            End Do
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 2 * LMTNA
      End Do
!
      Return
!
End Subroutine I_mrgrnk
end module m_mrgrnk


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
        
! $Id: optics_lib.f90,v 18.0.2.1 2010/03/25 00:31:40 pjp Exp $
! $Name: hiram_20101115_bw $
 
! OPTICS_LIB: Optical proecures for for F90
! Compiled/Modified:
!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
!
! m_wat (subroutine)
! m_ice (subroutine)
! mie_int (subroutine)
  
  module optics_lib
  implicit none

  contains

! ----------------------------------------------------------------------------
! subroutine M_WAT
! ----------------------------------------------------------------------------
  subroutine m_wat(freq, t, n_r, n_i)
  implicit none
!  
! Purpose:
!   compute complex index of refraction of liquid water
!
! Inputs:
!   [freq]    frequency (GHz)
!   [t]       temperature (C)
!
! Outputs:
!   [n_r]     real part index of refraction
!   [n_i]     imaginary part index of refraction
!
! Reference:
!   Based on the work of Ray (1972)
!
! Coded:
!   03/22/05  John Haynes (haynes@atmos.colostate.edu)
  
! ----- INPUTS -----
  real*8, intent(in) :: freq,t
  
! ----- OUTPUTS -----
  real*8, intent(out) :: n_r, n_i

! ----- INTERNAL -----    
  real*8 ld,es,ei,a,ls,sg,tm1,cos1,sin1
  real*8 e_r,e_i
  real*8 pi
  complex*16 e_comp, sq

  ld = 100.*2.99792458E8/(freq*1E9)
  es = 78.54*(1-(4.579E-3*(t-25.)+1.19E-5*(t-25.)**2 &
       -2.8E-8*(t-25.)**3))
  ei = 5.27137+0.021647*t-0.00131198*t**2
  a = -(16.8129/(t+273.))+0.0609265
  ls = 0.00033836*exp(2513.98/(t+273.))
  sg = 12.5664E8

  tm1 = (ls/ld)**(1-a)
  pi = acos(-1.D0)
  cos1 = cos(0.5*a*pi)
  sin1 = sin(0.5*a*pi)

  e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1.+2*tm1*sin1+tm1**2))
  e_i = (((es-ei)*tm1*cos1)/(1.+2*tm1*sin1+tm1**2)) &
        +((sg*ld)/1.885E11)

  e_comp = dcmplx(e_r,e_i)
  sq = sqrt(e_comp)
  
  n_r = real(sq)
  n_i = aimag(sq)      

  return
  end subroutine m_wat

! ----------------------------------------------------------------------------
! subroutine M_ICE
! ----------------------------------------------------------------------------
  subroutine m_ice(freq,t,n_r,n_i)
  implicit none
!
! Purpose:
!   compute complex index of refraction of ice
!
! Inputs:
!   [freq]    frequency (GHz)
!   [t]       temperature (C)
!
! Outputs:
!   [n_r]     real part index of refraction
!   [n_i]     imaginary part index of refraction
!
! Reference:
!    Fortran 90 port from IDL of REFICE by Stephen G. Warren
!
! Modified:
!   05/31/05  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----
  real*8, intent(in) :: freq, t
  
! ----- OUTPUTS -----  
  real*8, intent(out) :: n_r,n_i

! Parameters:
  integer*2 :: i,lt1,lt2,nwl,nwlt
  parameter(nwl=468,nwlt=62)

  real*8 :: alam,cutice,pi,t1,t2,tk,wlmax,wlmin, &
            x,x1,x2,y,y1,y2,ylo,yhi

  real*8 :: &
       tabim(nwl),tabimt(nwlt,4),tabre(nwl),tabret(nwlt,4),temref(4), &
       wl(nwl),wlt(nwlt)

! Defines wavelength dependent complex index of refraction for ice.
! Allowable wavelength range extends from 0.045 microns to 8.6 meter
! temperature dependence only considered beyond 167 microns.
! 
! interpolation is done     n_r  vs. log(xlam)
!                           n_r  vs.        t
!                       log(n_i) vs. log(xlam)
!                       log(n_i) vs.        t
!
! Stephen G. Warren - 1983
! Dept. of Atmospheric Sciences
! University of Washington
! Seattle, Wa  98195
!
! Based on
!
!    Warren,S.G.,1984.
!    Optical constants of ice from the ultraviolet to the microwave.
!    Applied Optics,23,1206-1225
!
! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C
 
      data temref/272.16,268.16,253.16,213.16/
 
      data wlmin,wlmax/0.045,8.6e6/
      data cutice/167.0/
 
      data (wl(i),i=1,114)/ &
      0.4430e-01,0.4510e-01,0.4590e-01,0.4680e-01,0.4770e-01,0.4860e-01, &
      0.4960e-01,0.5060e-01,0.5170e-01,0.5280e-01,0.5390e-01,0.5510e-01, &
      0.5640e-01,0.5770e-01,0.5900e-01,0.6050e-01,0.6200e-01,0.6360e-01, &
      0.6530e-01,0.6700e-01,0.6890e-01,0.7080e-01,0.7290e-01,0.7380e-01, &
      0.7510e-01,0.7750e-01,0.8000e-01,0.8270e-01,0.8550e-01,0.8860e-01, &
      0.9180e-01,0.9300e-01,0.9540e-01,0.9920e-01,0.1033e+00,0.1078e+00, &
      0.1100e+00,0.1127e+00,0.1140e+00,0.1181e+00,0.1210e+00,0.1240e+00, &
      0.1272e+00,0.1295e+00,0.1305e+00,0.1319e+00,0.1333e+00,0.1348e+00, &
      0.1362e+00,0.1370e+00,0.1378e+00,0.1387e+00,0.1393e+00,0.1409e+00, &
      0.1425e+00,0.1435e+00,0.1442e+00,0.1450e+00,0.1459e+00,0.1468e+00, &
      0.1476e+00,0.1480e+00,0.1485e+00,0.1494e+00,0.1512e+00,0.1531e+00, &
      0.1540e+00,0.1550e+00,0.1569e+00,0.1580e+00,0.1589e+00,0.1610e+00, &
      0.1625e+00,0.1648e+00,0.1669e+00,0.1692e+00,0.1713e+00,0.1737e+00, &
      0.1757e+00,0.1779e+00,0.1802e+00,0.1809e+00,0.1821e+00,0.1833e+00, &
      0.1843e+00,0.1850e+00,0.1860e+00,0.1870e+00,0.1880e+00,0.1890e+00, &
      0.1900e+00,0.1910e+00,0.1930e+00,0.1950e+00,0.2100e+00,0.2500e+00, &
      0.3000e+00,0.3500e+00,0.4000e+00,0.4100e+00,0.4200e+00,0.4300e+00, &
      0.4400e+00,0.4500e+00,0.4600e+00,0.4700e+00,0.4800e+00,0.4900e+00, &
      0.5000e+00,0.5100e+00,0.5200e+00,0.5300e+00,0.5400e+00,0.5500e+00/
      data (wl(i),i=115,228)/ &
      0.5600e+00,0.5700e+00,0.5800e+00,0.5900e+00,0.6000e+00,0.6100e+00, &
      0.6200e+00,0.6300e+00,0.6400e+00,0.6500e+00,0.6600e+00,0.6700e+00, &
      0.6800e+00,0.6900e+00,0.7000e+00,0.7100e+00,0.7200e+00,0.7300e+00, &
      0.7400e+00,0.7500e+00,0.7600e+00,0.7700e+00,0.7800e+00,0.7900e+00, &
      0.8000e+00,0.8100e+00,0.8200e+00,0.8300e+00,0.8400e+00,0.8500e+00, &
      0.8600e+00,0.8700e+00,0.8800e+00,0.8900e+00,0.9000e+00,0.9100e+00, &
      0.9200e+00,0.9300e+00,0.9400e+00,0.9500e+00,0.9600e+00,0.9700e+00, &
      0.9800e+00,0.9900e+00,0.1000e+01,0.1010e+01,0.1020e+01,0.1030e+01, &
      0.1040e+01,0.1050e+01,0.1060e+01,0.1070e+01,0.1080e+01,0.1090e+01, &
      0.1100e+01,0.1110e+01,0.1120e+01,0.1130e+01,0.1140e+01,0.1150e+01, &
      0.1160e+01,0.1170e+01,0.1180e+01,0.1190e+01,0.1200e+01,0.1210e+01, &
      0.1220e+01,0.1230e+01,0.1240e+01,0.1250e+01,0.1260e+01,0.1270e+01, &
      0.1280e+01,0.1290e+01,0.1300e+01,0.1310e+01,0.1320e+01,0.1330e+01, &
      0.1340e+01,0.1350e+01,0.1360e+01,0.1370e+01,0.1380e+01,0.1390e+01, &
      0.1400e+01,0.1410e+01,0.1420e+01,0.1430e+01,0.1440e+01,0.1449e+01, &
      0.1460e+01,0.1471e+01,0.1481e+01,0.1493e+01,0.1504e+01,0.1515e+01, &
      0.1527e+01,0.1538e+01,0.1563e+01,0.1587e+01,0.1613e+01,0.1650e+01, &
      0.1680e+01,0.1700e+01,0.1730e+01,0.1760e+01,0.1800e+01,0.1830e+01, &
      0.1840e+01,0.1850e+01,0.1855e+01,0.1860e+01,0.1870e+01,0.1890e+01/
      data (wl(i),i=229,342)/ &
      0.1905e+01,0.1923e+01,0.1942e+01,0.1961e+01,0.1980e+01,0.2000e+01, &
      0.2020e+01,0.2041e+01,0.2062e+01,0.2083e+01,0.2105e+01,0.2130e+01, &
      0.2150e+01,0.2170e+01,0.2190e+01,0.2220e+01,0.2240e+01,0.2245e+01, &
      0.2250e+01,0.2260e+01,0.2270e+01,0.2290e+01,0.2310e+01,0.2330e+01, &
      0.2350e+01,0.2370e+01,0.2390e+01,0.2410e+01,0.2430e+01,0.2460e+01, &
      0.2500e+01,0.2520e+01,0.2550e+01,0.2565e+01,0.2580e+01,0.2590e+01, &
      0.2600e+01,0.2620e+01,0.2675e+01,0.2725e+01,0.2778e+01,0.2817e+01, &
      0.2833e+01,0.2849e+01,0.2865e+01,0.2882e+01,0.2899e+01,0.2915e+01, &
      0.2933e+01,0.2950e+01,0.2967e+01,0.2985e+01,0.3003e+01,0.3021e+01, &
      0.3040e+01,0.3058e+01,0.3077e+01,0.3096e+01,0.3115e+01,0.3135e+01, &
      0.3155e+01,0.3175e+01,0.3195e+01,0.3215e+01,0.3236e+01,0.3257e+01, &
      0.3279e+01,0.3300e+01,0.3322e+01,0.3345e+01,0.3367e+01,0.3390e+01, &
      0.3413e+01,0.3436e+01,0.3460e+01,0.3484e+01,0.3509e+01,0.3534e+01, &
      0.3559e+01,0.3624e+01,0.3732e+01,0.3775e+01,0.3847e+01,0.3969e+01, &
      0.4099e+01,0.4239e+01,0.4348e+01,0.4387e+01,0.4444e+01,0.4505e+01, &
      0.4547e+01,0.4560e+01,0.4580e+01,0.4719e+01,0.4904e+01,0.5000e+01, &
      0.5100e+01,0.5200e+01,0.5263e+01,0.5400e+01,0.5556e+01,0.5714e+01, &
      0.5747e+01,0.5780e+01,0.5814e+01,0.5848e+01,0.5882e+01,0.6061e+01, &
      0.6135e+01,0.6250e+01,0.6289e+01,0.6329e+01,0.6369e+01,0.6410e+01/
      data (wl(i),i=343,456)/ &
      0.6452e+01,0.6494e+01,0.6579e+01,0.6667e+01,0.6757e+01,0.6897e+01, &
      0.7042e+01,0.7143e+01,0.7246e+01,0.7353e+01,0.7463e+01,0.7576e+01, &
      0.7692e+01,0.7812e+01,0.7937e+01,0.8065e+01,0.8197e+01,0.8333e+01, &
      0.8475e+01,0.8696e+01,0.8929e+01,0.9091e+01,0.9259e+01,0.9524e+01, &
      0.9804e+01,0.1000e+02,0.1020e+02,0.1031e+02,0.1042e+02,0.1053e+02, &
      0.1064e+02,0.1075e+02,0.1087e+02,0.1100e+02,0.1111e+02,0.1136e+02, &
      0.1163e+02,0.1190e+02,0.1220e+02,0.1250e+02,0.1282e+02,0.1299e+02, &
      0.1316e+02,0.1333e+02,0.1351e+02,0.1370e+02,0.1389e+02,0.1408e+02, &
      0.1429e+02,0.1471e+02,0.1515e+02,0.1538e+02,0.1563e+02,0.1613e+02, &
      0.1639e+02,0.1667e+02,0.1695e+02,0.1724e+02,0.1818e+02,0.1887e+02, &
      0.1923e+02,0.1961e+02,0.2000e+02,0.2041e+02,0.2083e+02,0.2222e+02, &
      0.2260e+02,0.2305e+02,0.2360e+02,0.2460e+02,0.2500e+02,0.2600e+02, &
      0.2857e+02,0.3100e+02,0.3333e+02,0.3448e+02,0.3564e+02,0.3700e+02, &
      0.3824e+02,0.3960e+02,0.4114e+02,0.4276e+02,0.4358e+02,0.4458e+02, &
      0.4550e+02,0.4615e+02,0.4671e+02,0.4736e+02,0.4800e+02,0.4878e+02, &
      0.5003e+02,0.5128e+02,0.5275e+02,0.5350e+02,0.5424e+02,0.5500e+02, &
      0.5574e+02,0.5640e+02,0.5700e+02,0.5746e+02,0.5840e+02,0.5929e+02, &
      0.6000e+02,0.6100e+02,0.6125e+02,0.6250e+02,0.6378e+02,0.6467e+02, &
      0.6558e+02,0.6655e+02,0.6760e+02,0.6900e+02,0.7053e+02,0.7300e+02/
      data (wl(i),i=457,468)/ &
      0.7500e+02,0.7629e+02,0.8000e+02,0.8297e+02,0.8500e+02,0.8680e+02, &
      0.9080e+02,0.9517e+02,0.1000e+03,0.1200e+03,0.1500e+03,0.1670e+03/
      data  wlt/ &
                                       0.1670e+03,0.1778e+03,0.1884e+03, &
      0.1995e+03,0.2113e+03,0.2239e+03,0.2371e+03,0.2512e+03,0.2661e+03, &
      0.2818e+03,0.2985e+03,0.3162e+03,0.3548e+03,0.3981e+03,0.4467e+03, &
      0.5012e+03,0.5623e+03,0.6310e+03,0.7943e+03,0.1000e+04,0.1259e+04, &
      0.2500e+04,0.5000e+04,0.1000e+05,0.2000e+05,0.3200e+05,0.3500e+05, &
      0.4000e+05,0.4500e+05,0.5000e+05,0.6000e+05,0.7000e+05,0.9000e+05, &
      0.1110e+06,0.1200e+06,0.1300e+06,0.1400e+06,0.1500e+06,0.1600e+06, &
      0.1700e+06,0.1800e+06,0.2000e+06,0.2500e+06,0.2900e+06,0.3200e+06, &
      0.3500e+06,0.3800e+06,0.4000e+06,0.4500e+06,0.5000e+06,0.6000e+06, &
      0.6400e+06,0.6800e+06,0.7200e+06,0.7600e+06,0.8000e+06,0.8400e+06, &
      0.9000e+06,0.1000e+07,0.2000e+07,0.5000e+07,0.8600e+07/
      data (tabre(i),i=1,114)/ &
         0.83441,   0.83676,   0.83729,   0.83771,   0.83827,   0.84038, &
         0.84719,   0.85522,   0.86047,   0.86248,   0.86157,   0.86093, &
         0.86419,   0.86916,   0.87764,   0.89296,   0.91041,   0.93089, &
         0.95373,   0.98188,   1.02334,   1.06735,   1.11197,   1.13134, &
         1.15747,   1.20045,   1.23840,   1.27325,   1.32157,   1.38958, &
         1.41644,   1.40906,   1.40063,   1.40169,   1.40934,   1.40221, &
         1.39240,   1.38424,   1.38075,   1.38186,   1.39634,   1.40918, &
         1.40256,   1.38013,   1.36303,   1.34144,   1.32377,   1.30605, &
         1.29054,   1.28890,   1.28931,   1.30190,   1.32025,   1.36302, &
         1.41872,   1.45834,   1.49028,   1.52128,   1.55376,   1.57782, &
         1.59636,   1.60652,   1.61172,   1.61919,   1.62522,   1.63404, &
         1.63689,   1.63833,   1.63720,   1.63233,   1.62222,   1.58269, &
         1.55635,   1.52453,   1.50320,   1.48498,   1.47226,   1.45991, &
         1.45115,   1.44272,   1.43498,   1.43280,   1.42924,   1.42602, &
         1.42323,   1.42143,   1.41897,   1.41660,   1.41434,   1.41216, &
         1.41006,   1.40805,   1.40423,   1.40067,   1.38004,   1.35085, &
         1.33394,   1.32492,   1.31940,   1.31854,   1.31775,   1.31702, &
         1.31633,   1.31569,   1.31509,   1.31452,   1.31399,   1.31349, &
         1.31302,   1.31257,   1.31215,   1.31175,   1.31136,   1.31099/
      data (tabre(i),i=115,228)/ &
         1.31064,   1.31031,   1.30999,   1.30968,   1.30938,   1.30909, &
         1.30882,   1.30855,   1.30829,   1.30804,   1.30780,   1.30756, &
         1.30733,   1.30710,   1.30688,   1.30667,   1.30646,   1.30625, &
         1.30605,   1.30585,   1.30566,   1.30547,   1.30528,   1.30509, &
         1.30491,   1.30473,   1.30455,   1.30437,   1.30419,   1.30402, &
         1.30385,   1.30367,   1.30350,   1.30333,   1.30316,   1.30299, &
         1.30283,   1.30266,   1.30249,   1.30232,   1.30216,   1.30199, &
         1.30182,   1.30166,   1.30149,   1.30132,   1.30116,   1.30099, &
         1.30082,   1.30065,   1.30048,   1.30031,   1.30014,   1.29997, &
         1.29979,   1.29962,   1.29945,   1.29927,   1.29909,   1.29891, &
         1.29873,   1.29855,   1.29837,   1.29818,   1.29800,   1.29781, &
         1.29762,   1.29743,   1.29724,   1.29705,   1.29686,   1.29666, &
         1.29646,   1.29626,   1.29605,   1.29584,   1.29563,   1.29542, &
         1.29521,   1.29499,   1.29476,   1.29453,   1.29430,   1.29406, &
         1.29381,   1.29355,   1.29327,   1.29299,   1.29272,   1.29252, &
         1.29228,   1.29205,   1.29186,   1.29167,   1.29150,   1.29130, &
         1.29106,   1.29083,   1.29025,   1.28962,   1.28891,   1.28784, &
         1.28689,   1.28623,   1.28521,   1.28413,   1.28261,   1.28137, &
         1.28093,   1.28047,   1.28022,   1.27998,   1.27948,   1.27849/
      data (tabre(i),i=229,342)/ &
         1.27774,   1.27691,   1.27610,   1.27535,   1.27471,   1.27404, &
         1.27329,   1.27240,   1.27139,   1.27029,   1.26901,   1.26736, &
         1.26591,   1.26441,   1.26284,   1.26036,   1.25860,   1.25815, &
         1.25768,   1.25675,   1.25579,   1.25383,   1.25179,   1.24967, &
         1.24745,   1.24512,   1.24266,   1.24004,   1.23725,   1.23270, &
         1.22583,   1.22198,   1.21548,   1.21184,   1.20790,   1.20507, &
         1.20209,   1.19566,   1.17411,   1.14734,   1.10766,   1.06739, &
         1.04762,   1.02650,   1.00357,   0.98197,   0.96503,   0.95962, &
         0.97269,   0.99172,   1.00668,   1.02186,   1.04270,   1.07597, &
         1.12954,   1.21267,   1.32509,   1.42599,   1.49656,   1.55095, &
         1.59988,   1.63631,   1.65024,   1.64278,   1.62691,   1.61284, &
         1.59245,   1.57329,   1.55770,   1.54129,   1.52654,   1.51139, &
         1.49725,   1.48453,   1.47209,   1.46125,   1.45132,   1.44215, &
         1.43366,   1.41553,   1.39417,   1.38732,   1.37735,   1.36448, &
         1.35414,   1.34456,   1.33882,   1.33807,   1.33847,   1.34053, &
         1.34287,   1.34418,   1.34634,   1.34422,   1.33453,   1.32897, &
         1.32333,   1.31800,   1.31432,   1.30623,   1.29722,   1.28898, &
         1.28730,   1.28603,   1.28509,   1.28535,   1.28813,   1.30156, &
         1.30901,   1.31720,   1.31893,   1.32039,   1.32201,   1.32239/
      data (tabre(i),i=343,456)/ &
         1.32149,   1.32036,   1.31814,   1.31705,   1.31807,   1.31953, &
         1.31933,   1.31896,   1.31909,   1.31796,   1.31631,   1.31542, &
         1.31540,   1.31552,   1.31455,   1.31193,   1.30677,   1.29934, &
         1.29253,   1.28389,   1.27401,   1.26724,   1.25990,   1.24510, &
         1.22241,   1.19913,   1.17150,   1.15528,   1.13700,   1.11808, &
         1.10134,   1.09083,   1.08734,   1.09254,   1.10654,   1.14779, &
         1.20202,   1.25825,   1.32305,   1.38574,   1.44478,   1.47170, &
         1.49619,   1.51652,   1.53328,   1.54900,   1.56276,   1.57317, &
         1.58028,   1.57918,   1.56672,   1.55869,   1.55081,   1.53807, &
         1.53296,   1.53220,   1.53340,   1.53289,   1.51705,   1.50097, &
         1.49681,   1.49928,   1.50153,   1.49856,   1.49053,   1.46070, &
         1.45182,   1.44223,   1.43158,   1.41385,   1.40676,   1.38955, &
         1.34894,   1.31039,   1.26420,   1.23656,   1.21663,   1.20233, &
         1.19640,   1.19969,   1.20860,   1.22173,   1.24166,   1.28175, &
         1.32784,   1.38657,   1.46486,   1.55323,   1.60379,   1.61877, &
         1.62963,   1.65712,   1.69810,   1.72065,   1.74865,   1.76736, &
         1.76476,   1.75011,   1.72327,   1.68490,   1.62398,   1.59596, &
         1.58514,   1.59917,   1.61405,   1.66625,   1.70663,   1.73713, &
         1.76860,   1.80343,   1.83296,   1.85682,   1.87411,   1.89110/
      data (tabre(i),i=457,468)/ &
         1.89918,   1.90432,   1.90329,   1.88744,   1.87499,   1.86702, &
         1.85361,   1.84250,   1.83225,   1.81914,   1.82268,   1.82961/
      data (tabret(i,1),i=1,nwlt)/ &
                                          1.82961,   1.83258,   1.83149, &
         1.82748,   1.82224,   1.81718,   1.81204,   1.80704,   1.80250, &
         1.79834,   1.79482,   1.79214,   1.78843,   1.78601,   1.78434, &
         1.78322,   1.78248,   1.78201,   1.78170,   1.78160,   1.78190, &
         1.78300,   1.78430,   1.78520,   1.78620,   1.78660,   1.78680, &
         1.78690,   1.78700,   1.78700,   1.78710,   1.78710,   1.78720, &
         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
         1.78720,   1.78720,   1.78720,   1.78720,   1.78800/
      data (tabret(i,2),i=1,nwlt)/ &
                               1.82961,   1.83258,   1.83149,   1.82748, &
         1.82224,   1.81718,   1.81204,   1.80704,   1.80250,   1.79834, &
         1.79482,   1.79214,   1.78843,   1.78601,   1.78434,   1.78322, &
         1.78248,   1.78201,   1.78170,   1.78160,   1.78190,   1.78300, &
         1.78430,   1.78520,   1.78610,   1.78630,   1.78640,   1.78650, &
         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
         1.78650,   1.78650,   1.78650,   1.78720/
      data(tabret(i,3),i=1,nwlt)/ &
                    1.82961,   1.83258,   1.83149,   1.82748,   1.82224, &
         1.81718,   1.81204,   1.80704,   1.80250,   1.79834,   1.79482, &
         1.79214,   1.78843,   1.78601,   1.78434,   1.78322,   1.78248, &
         1.78201,   1.78160,   1.78140,   1.78160,   1.78220,   1.78310, &
         1.78380,   1.78390,   1.78400,   1.78400,   1.78400,   1.78400, &
         1.78400,   1.78390,   1.78380,   1.78370,   1.78370,   1.78370, &
         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
         1.78370,   1.78400,   1.78450/
      data (tabret(i,4),i=1,nwlt)/ &
         1.82961,   1.83258,   1.83149,   1.82748,   1.82224,   1.81718, &
         1.81204,   1.80704,   1.80250,   1.79834,   1.79482,   1.79214, &
         1.78843,   1.78601,   1.78434,   1.78322,   1.78248,   1.78201, &
         1.78150,   1.78070,   1.78010,   1.77890,   1.77790,   1.77730, &
         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
         1.77720,   1.77800/
      data(tabim(i),i=1,114)/ &
      0.1640e+00,0.1730e+00,0.1830e+00,0.1950e+00,0.2080e+00,0.2230e+00, &
      0.2400e+00,0.2500e+00,0.2590e+00,0.2680e+00,0.2790e+00,0.2970e+00, &
      0.3190e+00,0.3400e+00,0.3660e+00,0.3920e+00,0.4160e+00,0.4400e+00, &
      0.4640e+00,0.4920e+00,0.5170e+00,0.5280e+00,0.5330e+00,0.5340e+00, &
      0.5310e+00,0.5240e+00,0.5100e+00,0.5000e+00,0.4990e+00,0.4680e+00, &
      0.3800e+00,0.3600e+00,0.3390e+00,0.3180e+00,0.2910e+00,0.2510e+00, &
      0.2440e+00,0.2390e+00,0.2390e+00,0.2440e+00,0.2470e+00,0.2240e+00, &
      0.1950e+00,0.1740e+00,0.1720e+00,0.1800e+00,0.1940e+00,0.2130e+00, &
      0.2430e+00,0.2710e+00,0.2890e+00,0.3340e+00,0.3440e+00,0.3820e+00, &
      0.4010e+00,0.4065e+00,0.4050e+00,0.3890e+00,0.3770e+00,0.3450e+00, &
      0.3320e+00,0.3150e+00,0.2980e+00,0.2740e+00,0.2280e+00,0.1980e+00, &
      0.1720e+00,0.1560e+00,0.1100e+00,0.8300e-01,0.5800e-01,0.2200e-01, &
      0.1000e-01,0.3000e-02,0.1000e-02,0.3000e-03,0.1000e-03,0.3000e-04, &
      0.1000e-04,0.3000e-05,0.1000e-05,0.7000e-06,0.4000e-06,0.2000e-06, &
      0.1000e-06,0.6377e-07,0.3750e-07,0.2800e-07,0.2400e-07,0.2200e-07, &
      0.1900e-07,0.1750e-07,0.1640e-07,0.1590e-07,0.1325e-07,0.8623e-08, &
      0.5504e-08,0.3765e-08,0.2710e-08,0.2510e-08,0.2260e-08,0.2080e-08, &
      0.1910e-08,0.1540e-08,0.1530e-08,0.1550e-08,0.1640e-08,0.1780e-08, &
      0.1910e-08,0.2140e-08,0.2260e-08,0.2540e-08,0.2930e-08,0.3110e-08/
      data(tabim(i),i=115,228)/ &
      0.3290e-08,0.3520e-08,0.4040e-08,0.4880e-08,0.5730e-08,0.6890e-08, &
      0.8580e-08,0.1040e-07,0.1220e-07,0.1430e-07,0.1660e-07,0.1890e-07, &
      0.2090e-07,0.2400e-07,0.2900e-07,0.3440e-07,0.4030e-07,0.4300e-07, &
      0.4920e-07,0.5870e-07,0.7080e-07,0.8580e-07,0.1020e-06,0.1180e-06, &
      0.1340e-06,0.1400e-06,0.1430e-06,0.1450e-06,0.1510e-06,0.1830e-06, &
      0.2150e-06,0.2650e-06,0.3350e-06,0.3920e-06,0.4200e-06,0.4440e-06, &
      0.4740e-06,0.5110e-06,0.5530e-06,0.6020e-06,0.7550e-06,0.9260e-06, &
      0.1120e-05,0.1330e-05,0.1620e-05,0.2000e-05,0.2250e-05,0.2330e-05, &
      0.2330e-05,0.2170e-05,0.1960e-05,0.1810e-05,0.1740e-05,0.1730e-05, &
      0.1700e-05,0.1760e-05,0.1820e-05,0.2040e-05,0.2250e-05,0.2290e-05, &
      0.3040e-05,0.3840e-05,0.4770e-05,0.5760e-05,0.6710e-05,0.8660e-05, &
      0.1020e-04,0.1130e-04,0.1220e-04,0.1290e-04,0.1320e-04,0.1350e-04, &
      0.1330e-04,0.1320e-04,0.1320e-04,0.1310e-04,0.1320e-04,0.1320e-04, &
      0.1340e-04,0.1390e-04,0.1420e-04,0.1480e-04,0.1580e-04,0.1740e-04, &
      0.1980e-04,0.2500e-04,0.5400e-04,0.1040e-03,0.2030e-03,0.2708e-03, &
      0.3511e-03,0.4299e-03,0.5181e-03,0.5855e-03,0.5899e-03,0.5635e-03, &
      0.5480e-03,0.5266e-03,0.4394e-03,0.3701e-03,0.3372e-03,0.2410e-03, &
      0.1890e-03,0.1660e-03,0.1450e-03,0.1280e-03,0.1030e-03,0.8600e-04, &
      0.8220e-04,0.8030e-04,0.8500e-04,0.9900e-04,0.1500e-03,0.2950e-03/
      data(tabim(i),i=229,342)/ &
      0.4687e-03,0.7615e-03,0.1010e-02,0.1313e-02,0.1539e-02,0.1588e-02, &
      0.1540e-02,0.1412e-02,0.1244e-02,0.1068e-02,0.8414e-03,0.5650e-03, &
      0.4320e-03,0.3500e-03,0.2870e-03,0.2210e-03,0.2030e-03,0.2010e-03, &
      0.2030e-03,0.2140e-03,0.2320e-03,0.2890e-03,0.3810e-03,0.4620e-03, &
      0.5480e-03,0.6180e-03,0.6800e-03,0.7300e-03,0.7820e-03,0.8480e-03, &
      0.9250e-03,0.9200e-03,0.8920e-03,0.8700e-03,0.8900e-03,0.9300e-03, &
      0.1010e-02,0.1350e-02,0.3420e-02,0.7920e-02,0.2000e-01,0.3800e-01, &
      0.5200e-01,0.6800e-01,0.9230e-01,0.1270e+00,0.1690e+00,0.2210e+00, &
      0.2760e+00,0.3120e+00,0.3470e+00,0.3880e+00,0.4380e+00,0.4930e+00, &
      0.5540e+00,0.6120e+00,0.6250e+00,0.5930e+00,0.5390e+00,0.4910e+00, &
      0.4380e+00,0.3720e+00,0.3000e+00,0.2380e+00,0.1930e+00,0.1580e+00, &
      0.1210e+00,0.1030e+00,0.8360e-01,0.6680e-01,0.5400e-01,0.4220e-01, &
      0.3420e-01,0.2740e-01,0.2200e-01,0.1860e-01,0.1520e-01,0.1260e-01, &
      0.1060e-01,0.8020e-02,0.6850e-02,0.6600e-02,0.6960e-02,0.9160e-02, &
      0.1110e-01,0.1450e-01,0.2000e-01,0.2300e-01,0.2600e-01,0.2900e-01, &
      0.2930e-01,0.3000e-01,0.2850e-01,0.1730e-01,0.1290e-01,0.1200e-01, &
      0.1250e-01,0.1340e-01,0.1400e-01,0.1750e-01,0.2400e-01,0.3500e-01, &
      0.3800e-01,0.4200e-01,0.4600e-01,0.5200e-01,0.5700e-01,0.6900e-01, &
      0.7000e-01,0.6700e-01,0.6500e-01,0.6400e-01,0.6200e-01,0.5900e-01/
      data(tabim(i),i=343,456)/ &
      0.5700e-01,0.5600e-01,0.5500e-01,0.5700e-01,0.5800e-01,0.5700e-01, &
      0.5500e-01,0.5500e-01,0.5400e-01,0.5200e-01,0.5200e-01,0.5200e-01, &
      0.5200e-01,0.5000e-01,0.4700e-01,0.4300e-01,0.3900e-01,0.3700e-01, &
      0.3900e-01,0.4000e-01,0.4200e-01,0.4400e-01,0.4500e-01,0.4600e-01, &
      0.4700e-01,0.5100e-01,0.6500e-01,0.7500e-01,0.8800e-01,0.1080e+00, &
      0.1340e+00,0.1680e+00,0.2040e+00,0.2480e+00,0.2800e+00,0.3410e+00, &
      0.3790e+00,0.4090e+00,0.4220e+00,0.4220e+00,0.4030e+00,0.3890e+00, &
      0.3740e+00,0.3540e+00,0.3350e+00,0.3150e+00,0.2940e+00,0.2710e+00, &
      0.2460e+00,0.1980e+00,0.1640e+00,0.1520e+00,0.1420e+00,0.1280e+00, &
      0.1250e+00,0.1230e+00,0.1160e+00,0.1070e+00,0.7900e-01,0.7200e-01, &
      0.7600e-01,0.7500e-01,0.6700e-01,0.5500e-01,0.4500e-01,0.2900e-01, &
      0.2750e-01,0.2700e-01,0.2730e-01,0.2890e-01,0.3000e-01,0.3400e-01, &
      0.5300e-01,0.7550e-01,0.1060e+00,0.1350e+00,0.1761e+00,0.2229e+00, &
      0.2746e+00,0.3280e+00,0.3906e+00,0.4642e+00,0.5247e+00,0.5731e+00, &
      0.6362e+00,0.6839e+00,0.7091e+00,0.6790e+00,0.6250e+00,0.5654e+00, &
      0.5433e+00,0.5292e+00,0.5070e+00,0.4883e+00,0.4707e+00,0.4203e+00, &
      0.3771e+00,0.3376e+00,0.3056e+00,0.2835e+00,0.3170e+00,0.3517e+00, &
      0.3902e+00,0.4509e+00,0.4671e+00,0.4779e+00,0.4890e+00,0.4899e+00, &
      0.4873e+00,0.4766e+00,0.4508e+00,0.4193e+00,0.3880e+00,0.3433e+00/
      data(tabim(i),i=457,468)/ &
      0.3118e+00,0.2935e+00,0.2350e+00,0.1981e+00,0.1865e+00,0.1771e+00, &
      0.1620e+00,0.1490e+00,0.1390e+00,0.1200e+00,0.9620e-01,0.8300e-01/
      data(tabimt(i,1),i=1,nwlt)/ &
                                       0.8300e-01,0.6900e-01,0.5700e-01, &
      0.4560e-01,0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01, &
      0.1760e-01,0.1665e-01,0.1620e-01,0.1550e-01,0.1470e-01,0.1390e-01, &
      0.1320e-01,0.1250e-01,0.1180e-01,0.1060e-01,0.9540e-02,0.8560e-02, &
      0.6210e-02,0.4490e-02,0.3240e-02,0.2340e-02,0.1880e-02,0.1740e-02, &
      0.1500e-02,0.1320e-02,0.1160e-02,0.8800e-03,0.6950e-03,0.4640e-03, &
      0.3400e-03,0.3110e-03,0.2940e-03,0.2790e-03,0.2700e-03,0.2640e-03, &
      0.2580e-03,0.2520e-03,0.2490e-03,0.2540e-03,0.2640e-03,0.2740e-03, &
      0.2890e-03,0.3050e-03,0.3150e-03,0.3460e-03,0.3820e-03,0.4620e-03, &
      0.5000e-03,0.5500e-03,0.5950e-03,0.6470e-03,0.6920e-03,0.7420e-03, &
      0.8200e-03,0.9700e-03,0.1950e-02,0.5780e-02,0.9700e-02/
      data(tabimt(i,2),i=1,nwlt)/ &
                            0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01, &
      0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01,0.1760e-01, &
      0.1665e-01,0.1600e-01,0.1500e-01,0.1400e-01,0.1310e-01,0.1230e-01, &
      0.1150e-01,0.1080e-01,0.9460e-02,0.8290e-02,0.7270e-02,0.4910e-02, &
      0.3300e-02,0.2220e-02,0.1490e-02,0.1140e-02,0.1060e-02,0.9480e-03, &
      0.8500e-03,0.7660e-03,0.6300e-03,0.5200e-03,0.3840e-03,0.2960e-03, &
      0.2700e-03,0.2520e-03,0.2440e-03,0.2360e-03,0.2300e-03,0.2280e-03, &
      0.2250e-03,0.2200e-03,0.2160e-03,0.2170e-03,0.2200e-03,0.2250e-03, &
      0.2320e-03,0.2390e-03,0.2600e-03,0.2860e-03,0.3560e-03,0.3830e-03, &
      0.4150e-03,0.4450e-03,0.4760e-03,0.5080e-03,0.5400e-03,0.5860e-03, &
      0.6780e-03,0.1280e-02,0.3550e-02,0.5600e-02/
      data(tabimt(i,3),i=1,nwlt)/ &
                 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01,0.3790e-01, &
      0.3140e-01,0.2620e-01,0.2190e-01,0.1880e-01,0.1660e-01,0.1540e-01, &
      0.1470e-01,0.1350e-01,0.1250e-01,0.1150e-01,0.1060e-01,0.9770e-02, &
      0.9010e-02,0.7660e-02,0.6520e-02,0.5540e-02,0.3420e-02,0.2100e-02, &
      0.1290e-02,0.7930e-03,0.5700e-03,0.5350e-03,0.4820e-03,0.4380e-03, &
      0.4080e-03,0.3500e-03,0.3200e-03,0.2550e-03,0.2120e-03,0.2000e-03, &
      0.1860e-03,0.1750e-03,0.1660e-03,0.1560e-03,0.1490e-03,0.1440e-03, &
      0.1350e-03,0.1210e-03,0.1160e-03,0.1160e-03,0.1170e-03,0.1200e-03, &
      0.1230e-03,0.1320e-03,0.1440e-03,0.1680e-03,0.1800e-03,0.1900e-03, &
      0.2090e-03,0.2160e-03,0.2290e-03,0.2400e-03,0.2600e-03,0.2920e-03, &
      0.6100e-03,0.1020e-02,0.1810e-02/
      data(tabimt(i,4),i=1,nwlt)/ &
      0.8300e-01,0.6900e-01,0.5700e-01,0.4450e-01,0.3550e-01,0.2910e-01, &
      0.2440e-01,0.1970e-01,0.1670e-01,0.1400e-01,0.1235e-01,0.1080e-01, &
      0.8900e-02,0.7340e-02,0.6400e-02,0.5600e-02,0.5000e-02,0.4520e-02, &
      0.3680e-02,0.2990e-02,0.2490e-02,0.1550e-02,0.9610e-03,0.5950e-03, &
      0.3690e-03,0.2670e-03,0.2510e-03,0.2290e-03,0.2110e-03,0.1960e-03, &
      0.1730e-03,0.1550e-03,0.1310e-03,0.1130e-03,0.1060e-03,0.9900e-04, &
      0.9300e-04,0.8730e-04,0.8300e-04,0.7870e-04,0.7500e-04,0.6830e-04, &
      0.5600e-04,0.4960e-04,0.4550e-04,0.4210e-04,0.3910e-04,0.3760e-04, &
      0.3400e-04,0.3100e-04,0.2640e-04,0.2510e-04,0.2430e-04,0.2390e-04, &
      0.2370e-04,0.2380e-04,0.2400e-04,0.2460e-04,0.2660e-04,0.4450e-04, &
      0.8700e-04,0.1320e-03/
 
  pi = acos(-1.0)
  n_r=0.0
  n_i=0.0

! // convert frequency to wavelength (um)
  alam=3E5/freq
  if((alam < wlmin) .or. (alam > wlmax)) then
    print *, 'm_ice: wavelength out of bounds'
    stop
  endif

! // convert temperature to K
  tk = t + 273.16

  if (alam < cutice) then

!   // region from 0.045 microns to 167.0 microns - no temperature depend
    do i=2,nwl
      if(alam < wl(i)) continue
    enddo
    x1=log(wl(i-1))
    x2=log(wl(i))
    y1=tabre(i-1)
    y2=tabre(i)
    x=log(alam)
    y=((x-x1)*(y2-y1)/(x2-x1))+y1
    n_r=y
    y1=log(abs(tabim(i-1)))
    y2=log(abs(tabim(i)))
    y=((x-x1)*(y2-y1)/(x2-x1))+y1
    n_i=exp(y)

  else

!   // region from 167.0 microns to 8.6 meters - temperature dependence
    if(tk > temref(1)) tk=temref(1)
    if(tk < temref(4)) tk=temref(4)
    do 11 i=2,4
      if(tk.ge.temref(i)) go to 12
    11 continue
    12 lt1=i
    lt2=i-1
    do 13 i=2,nwlt
      if(alam.le.wlt(i)) go to 14
    13 continue
    14 x1=log(wlt(i-1))
    x2=log(wlt(i))
    y1=tabret(i-1,lt1)
    y2=tabret(i,lt1)
    x=log(alam)
    ylo=((x-x1)*(y2-y1)/(x2-x1))+y1
    y1=tabret(i-1,lt2)
    y2=tabret(i,lt2)
    yhi=((x-x1)*(y2-y1)/(x2-x1))+y1
    t1=temref(lt1)
    t2=temref(lt2)
    y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
    n_r=y
    y1=log(abs(tabimt(i-1,lt1)))
    y2=log(abs(tabimt(i,lt1)))
    ylo=((x-x1)*(y2-y1)/(x2-x1))+y1
    y1=log(abs(tabimt(i-1,lt2)))
    y2=log(abs(tabimt(i,lt2)))
    yhi=((x-x1)*(y2-y1)/(x2-x1))+y1
    y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
    n_i=exp(y)

  endif

  end subroutine m_ice

! ----------------------------------------------------------------------------
! subroutine MIEINT
! ----------------------------------------------------------------------------
!
!     General purpose Mie scattering routine for single particles
!     Author: R Grainger 1990
!     History:
!     G Thomas, March 2005: Added calculation of Phase function and
!     code to ensure correct calculation of backscatter coeficient
!     Options/Extend_Source
!
      Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error)

      Integer * 2  Imaxx
      Parameter (Imaxx = 12000)
      Real * 4     RIMax          ! largest real part of refractive index
      Parameter (RIMax = 2.5)
      Real * 4     IRIMax         ! largest imaginary part of refractive index
      Parameter (IRIMax = -2)
      Integer * 2  Itermax
      Parameter (Itermax = 12000 * 2.5)
                                ! must be large enough to cope with the
                                ! largest possible nmx = x * abs(scm) + 15
                                ! or nmx =  Dx + 4.05*Dx**(1./3.) + 2.0
      Integer * 2  Imaxnp
      Parameter (Imaxnp = 10000)  ! Change this as required
!     INPUT
      Real * 8     Dx
      Complex * 16  SCm
      Integer * 4  Inp
      Real * 8     Dqv(Inp)
!     OUTPUT
      Complex * 16  Xs1(InP)
      Complex * 16  Xs2(InP)
      Real * 8     Dqxt
      Real * 8     Dqsc
      Real * 8     Dg
      Real * 8     Dbsc
      Real * 8     DPh(InP)
      Integer * 4  Error
!     LOCAL
      Integer * 2  I
      Integer * 2  NStop
      Integer * 2  NmX
      Integer * 4  N    ! N*N > 32767 ie N > 181
      Integer * 4  Inp2
      Real * 8     Chi,Chi0,Chi1
      Real * 8     APsi,APsi0,APsi1
      Real * 8     Pi0(Imaxnp)
      Real * 8     Pi1(Imaxnp)
      Real * 8     Taun(Imaxnp)
      Real * 8     Psi,Psi0,Psi1
      Complex * 8  Ir
      Complex * 16 Cm
      Complex * 16 A,ANM1,APB
      Complex * 16 B,BNM1,AMB
      Complex * 16 D(Itermax)
      Complex * 16 Sp(Imaxnp)
      Complex * 16 Sm(Imaxnp)
      Complex * 16 Xi,Xi0,Xi1
      Complex * 16 Y
!     ACCELERATOR VARIABLES
      Integer * 2  Tnp1
      Integer * 2  Tnm1
      Real * 8     Dn
      Real * 8     Rnx
      Real * 8     S(Imaxnp)
      Real * 8     T(Imaxnp)
      Real * 8     Turbo
      Real * 8     A2
      Complex * 16 A1
      
      If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then
        Error = 1
        Return
      EndIf
      Cm = SCm
      Ir = 1 / Cm
      Y =  Dx * Cm
      If (Dx.Lt.0.02) Then
         NStop = 2
      Else
         If (Dx.Le.8.0) Then
            NStop = Dx + 4.00*Dx**(1./3.) + 2.0
         Else
            If (Dx.Lt. 4200.0) Then
               NStop = Dx + 4.05*Dx**(1./3.) + 2.0
            Else
               NStop = Dx + 4.00*Dx**(1./3.) + 2.0
            End If
         End If
      End If
      NmX = Max(Real(NStop),Real(Abs(Y))) + 15.
      If (Nmx .gt. Itermax) then
          Error = 1
          Return
      End If
      Inp2 = Inp+1
      D(NmX) = Dcmplx(0,0)
      Do N = Nmx-1,1,-1
         A1 = (N+1) / Y
         D(N) = A1 - 1/(A1+D(N+1))
      End Do
      Do I =1,Inp2
         Sm(I) = Dcmplx(0,0)
         Sp(I) = Dcmplx(0,0)
         Pi0(I) = 0
         Pi1(I) = 1
      End Do
      Psi0 = Cos(Dx)
      Psi1 = Sin(Dx)
      Chi0 =-Sin(Dx)
      Chi1 = Cos(Dx)
      APsi0 = Psi0
      APsi1 = Psi1
      Xi0 = Dcmplx(APsi0,Chi0)
      Xi1 = Dcmplx(APsi1,Chi1)
      Dg = 0
      Dqsc = 0
      Dqxt = 0
      Tnp1 = 1
      Do N = 1,Nstop
         DN = N
         Tnp1 = Tnp1 + 2
         Tnm1 = Tnp1 - 2
         A2 = Tnp1 / (DN*(DN+1D0))
         Turbo = (DN+1D0) / DN
         Rnx = DN/Dx
         Psi = Dble(Tnm1)*Psi1/Dx - Psi0
         APsi = Psi
         Chi = Tnm1*Chi1/Dx       - Chi0
         Xi = Dcmplx(APsi,Chi)
         A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)*  Xi-  Xi1)
         B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)*  Xi-  Xi1)
         Dqxt = Tnp1 *      Dble(A + B)          + Dqxt
         Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
         If (N.Gt.1) then
	    Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
         End If
         Anm1 = A
         Bnm1 = B
         APB = A2 * (A + B)
         AMB = A2 * (A - B)
         Do I = 1,Inp2
            If (I.GT.Inp) Then
               S(I) = -Pi1(I)
            Else
               S(I) = Dqv(I) * Pi1(I)
            End If
            T(I) = S(I) - Pi0(I)
            Taun(I) = N*T(I) - Pi0(I)
            Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I)
            Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I)
            Pi0(I) = Pi1(I)
            Pi1(I) = S(I) + T(I)*Turbo
         End Do
         Psi0 = Psi1
         Psi1 = Psi
         Apsi1 = Psi1
         Chi0 = Chi1
         Chi1 = Chi
         Xi1 = Dcmplx(APsi1,Chi1)
      End Do
      If (Dg .GT.0) Dg = 2 * Dg / Dqsc
      Dqsc =  2 * Dqsc / Dx**2
      Dqxt =  2 * Dqxt / Dx**2
      Do I = 1,Inp
         Xs1(I) = (Sp(I)+Sm(I)) / 2
         Xs2(I) = (Sp(I)-Sm(I)) / 2
         Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
      End Do
      Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2
      Error = 0
      Return
      End subroutine MieInt

  end module optics_lib


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
         
! $Id: radar_simulator.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

  subroutine radar_simulator(me,freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
    nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, &
    rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, &
    g_to_vol_in,g_to_vol_out)

!     rh_matrix,Ze_non,Ze_ray,kr_matrix,g_atten_to_vol,dBZe)
 
  use m_mrgrnk 
  use array_lib
  use math_lib
  use optics_lib
  use radar_simulator_types
  implicit none
  
! Purpose:
!   Simulates a vertical profile of radar reflectivity
!   Part of QuickBeam v1.04 by John Haynes & Roger Marchand
!
! Inputs:
!   [freq]            radar frequency (GHz), can be anything unless
!                     use_mie_table=1, in which case one of 94,35,13.8,9.6,3
!   [k2]              |K|^2, the dielectric constant, set to -1 to use the
!                     frequency dependent default
!   [do_ray]          1=do Rayleigh calcs, 0=not
!   [use_gas_abs]     1=do gaseous abs calcs, 0=not,
!                     2=use same as first profile (undocumented)
!   [use_mie_table]   1=use Mie tables, 0=not
!   [mt]              Mie look up table
!   [nhclass]         number of hydrometeor types
!   [hp]              structure that defines hydrometeor types
!   [nprof]           number of hydrometeor profiles
!   [ngate]           number of vertical layers
!   [nsizes]          number of discrete particles in [D]
!   [D]               array of discrete particles (um)
!
!   (The following 5 arrays must be in order from closest to the radar
!    to farthest...)
!   [hgt_matrix]      height of hydrometeors (km)
!   [hm_matrix]       table of hydrometeor mixing rations (g/kg)
!   [re_matrix]       OPTIONAL table of hydrometeor effective radii (microns)
!   [p_matrix]        pressure profile (hPa)
!   [t_matrix]        temperature profile (C)
!   [rh_matrix]       relative humidity profile (%)
!
! Outputs:
!   [Ze_non]          radar reflectivity without attenuation (dBZ)
!   [Ze_ray]          Rayleigh reflectivity (dBZ)
!   [h_atten_to_vol]  attenuation by hydromets, radar to vol (dB)
!   [g_atten_to_vol]  gaseous atteunation, radar to vol (dB)
!   [dBZe]            effective radar reflectivity factor (dBZ)
!
! Optional:
!   [g_to_vol_in]     integrated atten due to gases, r>v (dB).
!                     If present then is used as gaseous absorption, independently of the
!                     value in use_gas_abs
!   [g_to_vol_out]    integrated atten due to gases, r>v (dB).
!                     If present then gaseous absorption for each profile is returned here.
!
! Created:
!   11/28/2005  John Haynes (haynes@atmos.colostate.edu)
! Modified:
!   09/2006  placed into subroutine form, scaling factors (Roger Marchand,JMH)
!   08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
!   01/2008  'Do while' to determine if hydrometeor(s) present in volume
!             changed for vectorization purposes (A. Bodas-Salcedo)

! ----- INPUTS -----  
  integer, intent(in) :: me
  type(mie), intent(in) :: mt
  type(class_param), intent(inout) :: hp
  real*8, intent(in) :: freq,k2
  integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
    nhclass,nprof,ngate,nsizes
  real*8, dimension(nsizes), intent(in) :: D
  real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
    t_matrix,rh_matrix
  real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
  real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
    
! ----- OUTPUTS -----
  real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
 	g_atten_to_vol,dBZe,h_atten_to_vol

! ----- OPTIONAL -----
  real*8, optional, dimension(ngate,nprof) :: &
  g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input
                           ! the same gaseous absorption in different calls. Optional to allow compatibility
                           ! with original version. A. Bodas April 2008.
        
!  real*8, dimension(nprof,ngate) :: kr_matrix 

! ----- INTERNAL -----
  integer :: &
  phase, &			! 0=liquid, 1=ice
  ns 				! number of discrete drop sizes

  integer*4, dimension(ngate) :: &
  hydro				! 1=hydrometeor in vol, 0=none
  real*8 :: &
  rho_a, &			! air density (kg m^-3)
  gases				! function: 2-way gas atten (dB/km)

  real*8, dimension(:), allocatable :: &
  Di, Deq, &      		! discrete drop sizes (um)
  Ni, Ntemp, &    		! discrete concentrations (cm^-3 um^-1)
  rhoi				! discrete densities (kg m^-3)
  
  real*8, dimension(ngate) :: &
  z_vol, &			! effective reflectivity factor (mm^6/m^3)
  z_ray, &                      ! reflectivity factor, Rayleigh only (mm^6/m^3)
  kr_vol, &			! attenuation coefficient hydro (dB/km)
  g_vol, &			! attenuation coefficient gases (dB/km)
  a_to_vol, &			! integrated atten due to hydometeors, r>v (dB)
  g_to_vol			! integrated atten due to gases, r>v (dB)
   
 
  integer,parameter :: KR8 = selected_real_kind(15,300)
  real*8, parameter :: xx = -1.0_KR8
  real*8,  dimension(:), allocatable :: xxa
  real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2,apm,bpm
  integer*4 :: tp, i, j, k, pr, itt, iff

  real*8 bin_length,step,base,step_list(25),base_list(25)
  integer*4 iRe_type,n,max_bin
  
  logical :: g_to_vol_in_present, g_to_vol_out_present
	
  ! Logicals to avoid calling present within the loops
  g_to_vol_in_present  = present(g_to_vol_in)
  g_to_vol_out_present = present(g_to_vol_out)
  
    ! set up Re bins for z_scalling
	bin_length=50;
	max_bin=25

	step_list(1)=1
	base_list(1)=75 
	do j=2,max_bin
		step_list(j)=3*(j-1);
		if(step_list(j)>bin_length) then
			step_list(j)=bin_length;
		endif
		base_list(j)=base_list(j-1)+floor(bin_length/step_list(j-1));
	enddo


  pi = acos(-1.0)
  if (use_mie_table == 1) iff = infind(mt%freq,freq,sort=1)

	
  ! // loop over each profile (nprof)
  do pr=1,nprof

!   ----- calculations for each volume ----- 
    z_vol(:) = 0
    z_ray(:) = 0
    kr_vol(:) = 0
    hydro(:) = 0    

!   // loop over eacho range gate (ngate)
    do k=1,ngate
  
!     :: determine if hydrometeor(s) present in volume
      hydro(k) = 0
      do j=1,nhclass ! Do while changed for vectorization purposes (A. B-S)
        if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then
          hydro(k) = 1
          exit
        endif
      enddo

      if (hydro(k) == 1) then
!     :: if there is hydrometeor in the volume            

        rho_a = (p_matrix(pr,k)*100.)/(287*(t_matrix(pr,k)+273.15))

!       :: loop over hydrometeor type
        do tp=1,nhclass

          if (hm_matrix(tp,pr,k) <= 1E-12) cycle

	  phase = hp%phase(tp)
	  if(phase==0) then
		itt = infind(mt_ttl,t_matrix(pr,k))
  	  else
		itt = infind(mt_tti,t_matrix(pr,k))
      endif

	  ! calculate Re if we have an exponential distribution with fixed No ... precipitation type particle
	  if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8)  then

		apm=hp%apm(tp)
		bpm=hp%bpm(tp)

  		if ((hp%rho(tp) > 0) .and. (apm < 0)) then
    			apm = (pi/6)*hp%rho(tp)
    			bpm = 3.
  		endif

		tmp1 = 1./(1.+bpm)
		ld = ((apm*gamma(1.+bpm)*hp%p1(tp))/(rho_a*hm_matrix(tp,pr,k)*1E-3))**tmp1
		
		Re = 1.5E6/ld 
		
		re_matrix(tp,pr,k) = Re;

	  endif
  
	  if(re_matrix(tp,pr,k).eq.0) then

		iRe_type=1
		Re=0
	  else
		iRe_type=1
		Re=re_matrix(tp,pr,k)
		
		n=floor(Re/bin_length)
		if(n==0) then
			if(Re<25) then
				step=0.5
				base=0
			else			
				step=1
				base=25
			endif
		else
			if(n>max_bin) then
				n=max_bin	
			endif

			step=step_list(n)
			base=base_list(n)
		endif

		iRe_type=floor(Re/step)

		if(iRe_type.lt.1) then  
			iRe_type=1			
		endif

		Re=step*(iRe_type+0.5)
		iRe_type=iRe_type+base-floor(n*bin_length/step)

	 	! make sure iRe_type is within bounds
		if(iRe_type.ge.nRe_types) then  

			! print *, tp, re_matrix(tp,pr,k), Re, iRe_type

			! no scaling allowed
			Re=re_matrix(tp,pr,k)

			iRe_type=nRe_types
			hp%z_flag(tp,itt,iRe_type)=.false.
			hp%scaled(tp,iRe_type)=.false.			
		endif
	  endif
	
  	  ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
	  ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
  	  if( .not. hp%z_flag(tp,itt,iRe_type) )  then
 	 
!         :: create a distribution of hydrometeors within volume	  
	  select case(hp%dtype(tp))
          case(4)
	    ns = 1
	    allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
	    if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))
	    Di = hp%p1(tp)
	    Ni = 0.
	  case default
 	    ns = nsizes            
	    allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
	    if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))	    
 	    Di = D
 	    Ni = 0.
	  end select

!         :: create a DSD (using scaling factor if applicable)
	  ! hp%scaled(tp,iRe_type)=.false.   ! turn off N scaling

	  call dsd(hm_matrix(tp,pr,k),Re,Di,Ni,ns,hp%dtype(tp),rho_a, &
	    t_matrix(pr,k),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
	    hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),hp%fc(tp,1:ns,iRe_type), &
	    hp%scaled(tp,iRe_type))

!         :: calculate particle density 
          ! if ((hp%rho_eff(tp,1,iRe_type) < 0) .and. (phase == 1)) then
	  if (phase == 1) then
	    if (hp%rho(tp) < 0) then
                
		! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density		
		! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
		
		! as the particle size gets small it is possible that the mass to size relationship of 
		! (given by power law in hclass.data) can produce impossible results 
		! where the mass is larger than a solid sphere of ice.  
		! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
		! do i=1,ns
		! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
		!	hp%rho_eff(tp,i,iRe_type) = 917
		!endif
		!enddo

		! alternative is to use equivalent volume spheres.
	    	hp%rho_eff(tp,1:ns,iRe_type) = 917  				! solid ice == equivalent volume approach
	      	Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * &
			   ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6 		! Di now really Deq in microns.
		
            else

            	! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
	     	
		! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
	     	hp%rho_eff(tp,1:ns,iRe_type) = 917
	     	Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0))  

	    endif

		! if using equivalent volume spheres
		if (use_mie_table == 1) then

			Ntemp=Ni

			! Find N(Di) from N(Deq) which we know
			do i=1,ns
                     		j=infind(Deq,Di(i))
				Ni(i)=Ntemp(j)
	        	enddo
		else
			! just use Deq and D variable input to mie code
			Di=Deq;
		endif

	  endif
	  rhoi = hp%rho_eff(tp,1:ns,iRe_type)
	  
!         :: calculate effective reflectivity factor of volume
	  if (use_mie_table == 1) then
	  
	    if ((hp%dtype(tp) == 4) .and. (hp%idd(tp) < 0)) then
              hp%idd(tp) = infind(mt%D,Di(1))
	    endif
	    
	    if (phase == 0) then
	    
	      ! itt = infind(mt_ttl,t_matrix(pr,k))
              select case(hp%dtype(tp))
	      case(4)
		mt_qext(1) = mt%qext(hp%idd(tp),itt,1,iff)
	        mt_qbsca(1) = mt%qbsca(hp%idd(tp),itt,1,iff)
              case default
  	        mt_qext = mt%qext(:,itt,1,iff)
	        mt_qbsca = mt%qbsca(:,itt,1,iff)
	      end select

          call zeff(freq,Di,Ni,ns,k2,mt_ttl(itt),0,do_ray, &
	        ze,zr,kr,mt_qext,mt_qbsca,xx)
	    
	    else

	      ! itt = infind(mt_tti,t_matrix(pr,k))
	      select case(hp%dtype(tp))
	      case(4)
                if (hp%ifc(tp,1,iRe_type) < 0) then
                  hp%ifc(tp,1,iRe_type) = infind(mt%f,rhoi(1)/917.)
 	        endif	   	      
                mt_qext(1) = &
		  mt%qext(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)
	        mt_qbsca(1) = &
		  mt%qbsca(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)	      
	      case default
 	        do i=1,ns
 	          if (hp%ifc(tp,i,iRe_type) < 0) then
                    hp%ifc(tp,i,iRe_type) = infind(mt%f,rhoi(i)/917.)
 	          endif	      
       	          mt_qext(i) = mt%qext(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
		  mt_qbsca(i) = mt%qbsca(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
	        enddo
	      end select

		   call zeff(freq,Di,Ni,ns,k2,mt_tti(itt),1,do_ray, &
	        ze,zr,kr,mt_qext,mt_qbsca,xx)

	    endif

	  else
       
	    xxa = -9.9
	    call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
	      ze,zr,kr,xxa,xxa,rhoi)

	      
	  endif  ! end of use mie table 

		! xxa = -9.9
	    	!call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
	      	!	ze2,zr,kr2,xxa,xxa,rhoi)

		! if(abs(ze2-ze)/ze2 > 0.1) then
  		! if(abs(kr2-kr)/kr2 > 0.1) then
  		
		! write(*,*) pr,k,tp,ze2,ze2-ze,abs(ze2-ze)/ze2,itt+cnt_liq,iff
		! write(*,*) pr,k,tp,ze2,kr2,kr2-kr,abs(kr2-kr)/kr2
		! stop

		!endif

	  deallocate(Di,Ni,rhoi,xxa,Deq)
  	  if (use_mie_table == 1) deallocate(mt_qext,mt_qbsca,Ntemp)

	  else ! can use z scaling
	  
		if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 )  then
		 
			ze = hp%Ze_scaled(tp,itt,iRe_type)
			zr = hp%Zr_scaled(tp,itt,iRe_type)
			kr = hp%kr_scaled(tp,itt,iRe_type)

		else
	    		scale_factor=rho_a*hm_matrix(tp,pr,k) 

			zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor 
			ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
			kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor	
		endif

	  endif  ! end z_scaling
 
	  ! kr=0 

	  kr_vol(k) = kr_vol(k) + kr
	  z_vol(k) = z_vol(k) + ze
	  z_ray(k) = z_ray(k) + zr
	
	  ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
	  if( .not. hp%z_flag(tp,itt,iRe_type) .and. 1.eq.1 ) then

		if( ( (hp%dtype(tp)==1 .or. hp%dtype(tp)==5 .or.  hp%dtype(tp)==2)  .and. abs(hp%p1(tp)+1) < 1E-8  ) .or. &
		    (  hp%dtype(tp)==3 .or. hp%dtype(tp)==4 )  &
		) then

			scale_factor=rho_a*hm_matrix(tp,pr,k) 

			hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
			hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
			hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor

			hp%z_flag(tp,itt,iRe_type)=.True.

		elseif( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then 
		 
			hp%Ze_scaled(tp,itt,iRe_type) = ze
			hp%Zr_scaled(tp,itt,iRe_type) = zr
			hp%kr_scaled(tp,itt,iRe_type) = kr

			hp%z_flag(tp,itt,iRe_type)=.True.
		endif

	  endif

        enddo	! end loop of tp (hydrometeor type)

      else
!     :: volume is hydrometeor-free
	
        kr_vol(k) = 0
	z_vol(k) = -999
        z_ray(k) = -999
	
      endif

!     :: attenuation due to hydrometeors between radar and volume
      a_to_vol(k) = 2*path_integral(kr_vol,hgt_matrix(pr,:),1,k-1)
      
!     :: attenuation due to gaseous absorption between radar and volume
      if (g_to_vol_in_present) then
        g_to_vol(k) = g_to_vol_in(k,pr)
      else
        if ( (use_gas_abs == 1) .or. ((use_gas_abs == 2) .and. (pr == 1)) )  then
            g_vol(k) = gases(p_matrix(pr,k),t_matrix(pr,k)+273.15, &
            rh_matrix(pr,k),freq)
            g_to_vol(k) = path_integral(g_vol,hgt_matrix(pr,:),1,k-1)
        elseif (use_gas_abs == 0) then
            g_to_vol(k) = 0
        endif  
      endif
    
!      kr_matrix(pr,:)=kr_vol

!     :: store results in matrix for return to calling program
      h_atten_to_vol(pr,k)=a_to_vol(k)
      g_atten_to_vol(pr,k)=g_to_vol(k)
      if ((do_ray == 1) .and. (z_ray(k) > 0)) then
        Ze_ray(pr,k) = 10*log10(z_ray(k))
      else
        Ze_ray(pr,k) = -999
      endif
      if (z_vol(k) > 0) then
        dBZe(pr,k) = 10*log10(z_vol(k))-a_to_vol(k)-g_to_vol(k)
        Ze_non(pr,k) = 10*log10(z_vol(k))
      else
        dBZe(pr,k) = -999
        Ze_non(pr,k) = -999
      endif
      
    enddo	! end loop of k (range gate)
    ! Output array with gaseous absorption
    if (g_to_vol_out_present) g_to_vol_out(:,pr) = g_to_vol
  enddo		! end loop over pr (profile)  

  end subroutine radar_simulator
  


 
!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
        
! $Id: radar_simulator_types.f90,v 1.1.2.1.2.1.2.1 2009/10/06 17:54:20 rsh Exp $
! $Name: hiram_20101115_bw $

  module radar_simulator_types

   public radar_simulator_types_init

! Collection of common variables and types
! Part of QuickBeam v1.03 by John Haynes
! http://reef.atmos.colostate.edu/haynes/radarsim

  integer, parameter ::       &
  maxhclass = 20 	     ,& ! max number of hydrometeor classes
  nd = 85		     ,& ! number of discrete particles  
  nRe_types = 250		! number or Re size bins allowed in N and Z_scaled look up table

  real*8, parameter ::        &
  dmin = 0.1                 ,& ! min size of discrete particle
  dmax = 10000.                	! max size of discrete particle
   
  integer, parameter :: &
  mt_nfreq = 5              , &
  mt_ntt = 39               , &	! num temperatures in table
  mt_nf	= 14		    , &	! number of ice fractions in table  
  mt_nd = 85                   ! num discrete mode-p drop sizes in table


! ---- hydrometeor class type -----  
  
  type class_param
    real*8,  dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
    integer, dimension(maxhclass) :: dtype,col,cp,phase
    logical, dimension(maxhclass,nRe_types) :: scaled
    logical, dimension(maxhclass,mt_ntt,nRe_types) :: z_flag
    real*8,  dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
    real*8,  dimension(maxhclass,nd,nRe_types) :: fc, rho_eff
    integer, dimension(maxhclass,nd,nRe_types) :: ifc
    integer, dimension(maxhclass) :: idd
  end type class_param

! ----- mie table structure -----
  
  type mie
    real*8 :: freq(mt_nfreq), tt(mt_ntt), f(mt_nf), D(mt_nd)
    real*8, dimension(mt_nd,mt_ntt,mt_nf,mt_nfreq) :: qext, qbsca
    integer :: phase(mt_ntt)
  end type mie

  real*8, dimension(:), allocatable :: &
    mt_ttl, &			! liquid temperatures (C)
    mt_tti, &			! ice temperatures (C)
    mt_qext, mt_qbsca		! extincion/backscatter efficiency

  integer*4 :: &
    cnt_liq, &			! liquid temperature count
      cnt_ice			! ice temperature count

  contains

subroutine radar_simulator_types_init

    
    integer :: i

! otherwise we still need to initialize temperature arrays for Ze 
! scaling (which is only done when not using mie table)
           
           cnt_ice=19
           cnt_liq=20
!      if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then
          allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))  ! note needed as th        is is global array ... 
                                                      ! which should be c        hanged in the future 
!     endif
                  
        do i=1,cnt_ice
           mt_tti(i)=(i-1)*5-90
        enddo 

        do i=1,cnt_liq
          mt_ttl(i)=(i-1)*5 - 60
       enddo

     
end subroutine radar_simulator_types_init


  end module radar_simulator_types



!---------------------------------------------------------------------
!------------ FMS version number and tagname for this file -----------
       
! $Id: zeff.f90,v 1.1.2.1.2.1 2009/08/10 10:48:14 rsh Exp $
! $Name: hiram_20101115_bw $

  subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
  use math_lib
  use optics_lib
  implicit none
  
! Purpose:
!   Simulates radar return of a volume given DSD of spheres
!   Part of QuickBeam v1.03 by John Haynes
!   http://reef.atmos.colostate.edu/haynes/radarsim
!
! Inputs:
!   [freq]      radar frequency (GHz)
!   [D]         discrete drop sizes (um)
!   [N]         discrete concentrations (cm^-3 um^-1)
!   [nsizes]    number of discrete drop sizes
!   [k2]        |K|^2, -1=use frequency dependent default 
!   [tt]        hydrometeor temperature (C)
!   [ice]       indicates volume consists of ice
!   [xr]        perform Rayleigh calculations?
!   [qe]        if using a mie table, these contain ext/sca ...
!   [qs]        ... efficiencies; otherwise set to -1
!   [rho_e]     medium effective density (kg m^-3) (-1 = pure)
!
! Outputs:
!   [z_eff]     unattenuated effective reflectivity factor (mm^6/m^3)
!   [z_ray]     reflectivity factor, Rayleigh only (mm^6/m^3)
!   [kr]        attenuation coefficient (db km^-1)
!
! Created:
!   11/28/05  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----  
  integer, intent(in) :: ice, xr
  integer, intent(in) :: nsizes
  real*8, intent(in) :: freq,D(nsizes),N(nsizes),tt,qe(nsizes), &
    qs(nsizes), rho_e(nsizes)
  real*8, intent(inout) :: k2
  
! ----- OUTPUTS -----
  real*8, intent(out) :: z_eff,z_ray,kr
    
! ----- INTERNAL -----
  integer :: &
  correct_for_rho		! correct for density flag
  real*8, dimension(nsizes) :: &
  D0, &				! D in (m)
  N0, &				! N in m^-3 m^-1
  sizep, &			! size parameter
  qext, &			! extinction efficiency
  qbsca, &			! backscatter efficiency
  rho_ice, &			! bulk density ice (kg m^-3)
  f				! ice fraction
  real*8 :: &
  wl, &				! wavelength (m)
  cr                            ! kr(dB/km) = cr * kr(1/km)
  complex*16 :: &
  m				! complex index of refraction of bulk form
  complex*16, dimension(nsizes) :: &
  m0				! complex index of refraction
  
  integer*4 :: i,one
  real*8 :: pi
  real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, &
            n_r, n_i, dqv(1), dqxt, dqsc, dbsc, dg, dph(1)
  integer*4 :: err
  complex*16 :: Xs1(1), Xs2(1)

  one=1
  pi = acos(-1.0)
  rho_ice(:) = 917
  z0_ray = 0.0

! // conversions
  D0 = d*1E-6			! m
  N0 = n*1E12			! 1/(m^3 m)
  wl = 2.99792458/(freq*10)	! m
  
! // dielectric constant |k^2| defaults
  if (k2 < 0) then
    k2 = 0.933
    if (abs(94.-freq) < 3.) k2=0.75
    if (abs(35.-freq) < 3.) k2=0.88
    if (abs(13.8-freq) < 3.) k2=0.925
  endif  
  
  if (qe(1) < -9) then

!   // get the refractive index of the bulk hydrometeors
    if (ice == 0) then
      call m_wat(freq,tt,n_r,n_i)
    else
      call m_ice(freq,tt,n_r,n_i)
    endif
    m = cmplx(n_r,-n_i)
    m0(:) = m
    
    correct_for_rho = 0
    if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1
    
!   :: correct refractive index for ice density if needed
    if (correct_for_rho == 1) then
      f = rho_e/rho_ice
      m0 = ((2+m0**2+2*f*(m0**2-1))/(2+m0**2+f*(1-m0**2)))**(0.5)
    endif       
    
!   :: Mie calculations
    sizep = (pi*D0)/wl
    dqv(1) = 0.
    do i=1,nsizes
      call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), &
        dg, xs1, xs2, dph, err)
    end do
    
  else
!   // Mie table used
    
    qext = qe
    qbsca = qs
    
  endif
  
! // eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD]
!                   <--------- eta_sum --------->
! // z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie
  eta_sum = 0.
  if (size(D0) == 1) then
    eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2
  else
    call avint(qbsca*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
  endif
 
  eta_mie = eta_sum*0.25*pi
  const = (wl**4/pi**5)*(1./k2)
  z0_eff = const*eta_mie

! // kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD]
!                 <---------- k_sum --------->  
  k_sum = 0.
  if (size(D0) == 1) then
    k_sum = qext(1)*(n(1)*1E6)*D0(1)**2
  else
    call avint(qext*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
  endif
  cr = 10./log(10.)
  kr = k_sum*0.25*pi*(1000.*cr)
	
! // z_ray = sum[D^6*N(D)*deltaD]
  if (xr == 1) then
    z0_ray = 0.
    if (size(D0) == 1) then
      z0_ray = (n(1)*1E6)*D0(1)**6
    else
      call avint(N0*D0**6,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
    endif
  endif
  
! // convert to mm^6/m^3
  z_eff = z0_eff*1E18 !  10.*alog10(z0_eff*1E18)
  z_ray = z0_ray*1E18 !  10.*alog10(z0_ray*1E18)
  
  end subroutine zeff


!FDOC_TAG_GFDL

module cu_mo_trans_mod
! <CONTACT EMAIL="Isaac.Held@noaa.gov">
!  Isaac Held
! </CONTACT>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    A simple module that computes a diffusivity proportional to the 
!    convective mass flux, for use with diffusive 
!    convective momentum transport closure
! </OVERVIEW>
! <DESCRIPTION>
!   A diffusive approximation to convective momentum transport is crude but
!    has been found to be useful in improving the simulation of tropical
!     precipitation in some models.  The diffusivity computed here is
!     simply 
!<PRE>
! diffusivity = c*W*L 
! W = M/rho  (m/sec) 
! M = convective mass flux (kg/(m2 sec)) 
! rho - density of air <p>
! L = depth of convecting layer (m)
! c = normalization constant = diff_norm/g 
!   (diff_norm is a namelist parameter;
!      the factor of g = acceleration of gravity here is an historical artifact) <p>
! for further discussion see 
!     <LINK SRC="cu_mo_trans.pdf">cu_mo_trans.pdf</LINK>
!</PRE>
! </DESCRIPTION>


!=======================================================================
!
!                 DIFFUSIVE CONVECTIVE MOMENTUM TRANSPORT MODULE
!
!=======================================================================

  use   constants_mod, only:  GRAV, RDGAS, RVGAS, CP_AIR
 

  use         mpp_mod, only: input_nml_file
  use         fms_mod, only: file_exist, check_nml_error,    &
                             open_namelist_file, close_file, &
                             write_version_number,           &
                             mpp_pe, mpp_root_pe, stdlog,    &
                             error_mesg, FATAL, NOTE

  use  Diag_Manager_Mod, ONLY: register_diag_field, send_data
  use  Time_Manager_Mod, ONLY: time_type

implicit none
private


! public interfaces
!=======================================================================
public :: cu_mo_trans_init, &
          cu_mo_trans,      &
          cu_mo_trans_end

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

! form of interfaces
!=======================================================================

      
logical :: module_is_initialized = .false.


!---------------diagnostics fields------------------------------------- 

integer :: id_diff_cmt, id_utnd_cmt, id_vtnd_cmt, id_ttnd_cmt, &
           id_massflux_cmt, id_detmf_cmt

character(len=11) :: mod_name = 'cu_mo_trans'

real :: missing_value = -999.
logical  ::  do_diffusive_transport = .false.
logical  ::  do_nonlocal_transport = .false.


!--------------------- namelist variables with defaults -------------

real    :: diff_norm =   1.0
logical :: limit_mass_flux = .false.  ! when true, the mass flux 
                                      ! out of a grid box is limited to
                                      ! the mass in that grid box
character(len=64) :: transport_scheme = 'diffusive'
integer :: non_local_iter = 2  ! iteration count for non-local scheme
logical :: conserve_te = .true.  ! conserve total energy ?
real    ::  gki = 0.7  ! Gregory et. al. constant for p-gradient param
real    :: amplitude = 1.0 ! Tuning parameter (1=full strength)

namelist/cu_mo_trans_nml/ diff_norm, &
                          limit_mass_flux, &
                          non_local_iter, conserve_te, gki, &
                          amplitude,  &
                          transport_scheme


!--------------------- version number ---------------------------------

character(len=128) :: version = '$Id: cu_mo_trans.F90,v 17.0.6.2 2010/09/07 16:17:10 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains

!#######################################################################

! <SUBROUTINE NAME="cu_mo_trans_init">
!  <OVERVIEW>
!   initializes module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Reads namelist and registers one diagnostic field
!     (diff_cmt:  the kinematic diffusion coefficient)
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cu_mo_trans_init( axes, Time )
!
!  </TEMPLATE>
!  <IN NAME=" axes" TYPE="integer">
!    axes identifier needed by diag manager
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!    time at initialization needed by diag manager
!  </IN>
! </SUBROUTINE>
!
subroutine cu_mo_trans_init( axes, Time, doing_diffusive )

 integer,         intent(in) :: axes(4)
 type(time_type), intent(in) :: Time
 logical,         intent(out) :: doing_diffusive

integer :: unit, ierr, io, logunit
integer, dimension(3)  :: half =  (/1,2,4/)

!------ read namelist ------

   if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cu_mo_trans_nml, iostat=io)
      ierr = check_nml_error(io,'cu_mo_trans_nml')
#else   
      unit = open_namelist_file ( )
      ierr=1; do while (ierr /= 0)
         read  (unit, nml=cu_mo_trans_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'cu_mo_trans_nml')
      enddo
 10   call close_file (unit)
#endif
   endif

!--------- write version number and namelist ------------------

      call write_version_number ( version, tagname )
      logunit = stdlog()
      if ( mpp_pe() == mpp_root_pe() ) &
        write ( logunit, nml=cu_mo_trans_nml )

!----------------------------------------------------------------------
!    define logicals indicating momentum transport scheme to use.
!----------------------------------------------------------------------
      if (trim(transport_scheme) == 'diffusive') then
        do_diffusive_transport = .true.
      else if (trim(transport_scheme) == 'nonlocal') then
        do_nonlocal_transport = .true.
      else
        call error_mesg ('cu_mo_trans', &
         'invalid specification of transport_scheme', FATAL)
      endif

      doing_diffusive = do_diffusive_transport

! --- initialize quantities for diagnostics output -------------

   if (do_diffusive_transport) then
     id_diff_cmt = &
      register_diag_field ( mod_name, 'diff_cmt', axes(1:3), Time,    &
                        'cu_mo_trans coeff for momentum',  'm2/s', &
                         missing_value=missing_value               )
     id_massflux_cmt = &
      register_diag_field ( mod_name, 'massflux_cmt', axes(half), Time, &
                        'cu_mo_trans mass flux',  'kg/(m2 s)', &
                         missing_value=missing_value               )
    else if (do_nonlocal_transport) then 
     id_utnd_cmt = &
      register_diag_field ( mod_name, 'utnd_cmt', axes(1:3), Time,    &
                        'cu_mo_trans u tendency',  'm/s2', &
                         missing_value=missing_value               )
     id_vtnd_cmt = &
      register_diag_field ( mod_name, 'vtnd_cmt', axes(1:3), Time,    &
                        'cu_mo_trans v tendency',  'm/s2', &
                         missing_value=missing_value               )
     id_ttnd_cmt = &
      register_diag_field ( mod_name, 'ttnd_cmt', axes(1:3), Time,    &
                        'cu_mo_trans temp tendency',  'deg K/s', &
                         missing_value=missing_value               )
     id_massflux_cmt = &
      register_diag_field ( mod_name, 'massflux_cmt', axes(half), Time, &
                        'cu_mo_trans mass flux',  'kg/(m2 s)', &
                         missing_value=missing_value               )
     id_detmf_cmt = &
      register_diag_field ( mod_name, 'detmf_cmt', axes(1:3), Time,  &
                      'cu_mo_trans detrainment mass flux',  'kg/(m2 s)',&
                         missing_value=missing_value               )
    endif

!--------------------------------------------------------------

  module_is_initialized = .true.


end subroutine cu_mo_trans_init

!#######################################################################

! <SUBROUTINE NAME="cu_mo_trans_end">
!  <OVERVIEW>
!   terminates module
!  </OVERVIEW>
!  <DESCRIPTION>
!   This is the destructor for cu_mo_trans
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cu_mo_trans_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine cu_mo_trans_end()

  module_is_initialized = .false.

end subroutine cu_mo_trans_end

!#######################################################################

! <SUBROUTINE NAME="cu_mo_trans">
!  <OVERVIEW>
!   picks one of the available cumulus momentum transport parameteriz-
!    ations based on namelist-supplied information (currently diffusive 
!    or non-local options are available).  For the diffusive scheme, it
!    returns a diffusivity proportional to the convective mass 
!    flux. For the non-local scheme temperature, specific humidity and
!    momentum tendencies are returned.
!  </OVERVIEW>
!  <DESCRIPTION>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cu_mo_trans (is, js, Time, mass_flux, t,           &
!                p_half, p_full, z_half, z_full, diff)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! ! horizontal domain on which computation to be performed is
!    (is:is+size(t,1)-1,ie+size(t,2)-1) in global coordinates
!   (used by diag_manager only)
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
! current time, used by diag_manager
!  </IN>
!  <IN NAME="mass_flux" TYPE="real">
! convective mass flux (Kg/(m**2 s)), dimension(:,:,:), 3rd dimension is
!    vertical level (top down) -- defined at interfaces, so that
!    size(mass_flux,3) = size(p_half,3); entire field processed;
!   all remaining fields are 3 dimensional;
!  size of first two dimensions must confrom for all variables
!  </IN>
!  <IN NAME="t" TYPE="real">
! temperature (K) at full levels, size(t,3) = size(p_full,3)
!  </IN>
!  <IN NAME="p_half" TYPE="real">
! pressure at interfaces (Pascals) 
!  size(p_half,3) = size(p_full,3) + 1
!  </IN>
!  <IN NAME="p_full" TYPE="real">
! pressure at full levels (levels at which temperature is defined)
!  </IN>
!  <IN NAME="z_half" TYPE="real">
! height at half levels (meters); size(z_half,3) = size(p_half,3)
!  </IN>
!  <IN NAME="z_full" TYPE="real">
! height at full levels (meters); size(z_full,3) = size(p_full,3)
!  </IN>
!  <OUT NAME="diff" TYPE="real">
! kinematic diffusivity (m*2/s); defined at half levels 
!   size(diff,3) = size(p_half,3)
!  </OUT>
! </SUBROUTINE>
!




subroutine cu_mo_trans (is, js, Time, mass_flux, t,           &
                        p_half, p_full, z_half, z_full, dt, uin, vin,&
                        tracer, pmass, det0, utnd, vtnd, ttnd, &
                        qtrcumo, diff)

type(time_type), intent(in) :: Time
integer,         intent(in) :: is, js

real,   intent(in) :: dt
real, intent(inout)   , dimension(:,:,:,:) :: tracer           
real, intent(inout)   , dimension(:,:,:) :: uin, vin, t        
real, intent(in)   , dimension(:,:,:) :: mass_flux, &
                                         pmass, det0, &
                                         p_half, p_full, z_half, z_full
real, intent(out), dimension(:,:,:) :: utnd, vtnd          
real, intent(out), dimension(:,:,:) :: ttnd          
real, intent(out), dimension(:,:,:,:) :: qtrcumo                   
real, intent(inout), dimension(:,:,:) :: diff                      


      integer :: im, jm, km, nq, nq_skip

!-----------------------------------------------------------------------

 if (.not.module_is_initialized) call error_mesg ('cu_mo_trans',  &
                      'cu_mo_trans_init has not been called.', FATAL)

!-----------------------------------------------------------------------
!   utnd = 0.
!   vtnd = 0.
!   ttnd = 0.
!   qtrcumo = 0.

    if (do_diffusive_transport) then
      call diffusive_cu_mo_trans (is, js, Time, mass_flux, t,      &
                      p_half, p_full, z_half, z_full, diff)
    utnd = 0.
    vtnd = 0.
    ttnd = 0.
    qtrcumo = 0.
      
    else if (do_nonlocal_transport) then
!      call error_mesg ('cu_mo_trans',  &
!        'non-local transport not currently available', FATAL)
       im = size(uin,1)
       jm = size(uin,2)
       km = size(uin,3)
       nq = size(tracer,4)
       nq_skip = nq
       qtrcumo(:,:,:,1:nq_skip) = 0.0
       call non_local_mot (im, jm, km, is, js, Time, dt, t, uin, vin,  &
                           nq, nq_skip,   &
                 tracer, pmass, mass_flux, det0, utnd, vtnd, ttnd,  &
                 qtrcumo)
    endif

end subroutine cu_mo_trans


!#######################################################################

! <SUBROUTINE NAME="diffusive_cu_mo_trans">
!  <OVERVIEW>
!   returns a diffusivity proportional to the 
!    convective mass flux, for use with diffusive 
!    convective momentum transport closure
!  </OVERVIEW>
!  <DESCRIPTION>
!   A diffusive approximation to convective momentum transport is crude but
!    has been found to be useful in inproving the simulation of tropical
!    precipitation in some models.  The diffusivity computed here is
!    simply 
!<PRE>
! diffusivity = c*W*L
! W = M/rho  (m/sec)
! M = convective mass flux (kg/(m2 sec)) 
! rho - density of air
! L = depth of convecting layer (m)
! c = normalization constant = diff_norm/g
!   (diff_norm is a namelist parameter;
!      the factor of g here is an historical artifact)
! for further discussion see cu_mo_trans.ps
!</PRE>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diffusive_cu_mo_trans (is, js, Time, mass_flux, t,      &
!                p_half, p_full, z_half, z_full, diff)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! ! horizontal domain on which computation to be performed is
!    (is:is+size(t,1)-1,ie+size(t,2)-1) in global coordinates
!   (used by diag_manager only)
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
! current time, used by diag_manager
!  </IN>
!  <IN NAME="mass_flux" TYPE="real">
! convective mass flux (Kg/(m**2 s)), dimension(:,:,:), 3rd dimension is
!    vertical level (top down) -- defined at interfaces, so that
!    size(mass_flux,3) = size(p_half,3); entire field processed;
!   all remaining fields are 3 dimensional;
!  size of first two dimensions must confrom for all variables
!  </IN>
!  <IN NAME="t" TYPE="real">
! temperature (K) at full levels, size(t,3) = size(p_full,3)
!  </IN>
!  <IN NAME="p_half" TYPE="real">
! pressure at interfaces (Pascals) 
!  size(p_half,3) = size(p_full,3) + 1
!  </IN>
!  <IN NAME="p_full" TYPE="real">
! pressure at full levels (levels at which temperature is defined)
!  </IN>
!  <IN NAME="z_half" TYPE="real">
! height at half levels (meters); size(z_half,3) = size(p_half,3)
!  </IN>
!  <IN NAME="z_full" TYPE="real">
! height at full levels (meters); size(z_full,3) = size(p_full,3)
!  </IN>
!  <OUT NAME="diff" TYPE="real">
! kinematic diffusivity (m*2/s); defined at half levels 
!   size(diff,3) = size(p_half,3)
!  </OUT>
! </SUBROUTINE>
!
subroutine diffusive_cu_mo_trans (is, js, Time, mass_flux, t,     &
                        p_half, p_full, z_half, z_full, diff)

  type(time_type), intent(in) :: Time
  integer,         intent(in) :: is, js

real, intent(in)   , dimension(:,:,:) :: mass_flux, t, &
                                         p_half, p_full, z_half, z_full
real, intent(out), dimension(:,:,:) :: diff                      

real, dimension(size(t,1),size(t,2),size(t,3)) :: rho
real, dimension(size(t,1),size(t,2))           :: zbot, ztop

integer :: k, nlev
logical :: used

!-----------------------------------------------------------------------

 if (.not.module_is_initialized) call error_mesg ('cu_mo_trans',  &
                      'cu_mo_trans_init has not been called.', FATAL)

!-----------------------------------------------------------------------

nlev = size(t,3)

zbot = z_half(:,:,nlev+1)
ztop = z_half(:,:,nlev+1)
  
do k = 2, nlev
  where(mass_flux(:,:,k) .ne. 0.0 .and. mass_flux(:,:,k+1) == 0.0) 
    zbot = z_half(:,:,k)
  endwhere
  where(mass_flux(:,:,k-1) == 0.0 .and. mass_flux(:,:,k) .ne. 0.0) 
    ztop = z_half(:,:,k)
  endwhere
end do

rho  = p_full/(RDGAS*t)  ! density 
   ! (including the virtual temperature effect here might give the 
   ! impression that this theory is accurate to 2%!)

! diffusivity = c*W*L
! W = M/rho  (m/sec)
! M = convective mass flux (kg/(m2 sec)) 
! L = ztop - zbot = depth of convecting layer (m)
! c = normalization constant = diff_norm/g
!   (the factor of g here is an historical artifact)

diff(:,:,1) = 0.0
do k = 2, nlev
  diff(:,:,k) = diff_norm*mass_flux(:,:,k)*(ztop-zbot)/(rho(:,:,k)*GRAV)
end do


! --- diagnostics
     if ( id_diff_cmt > 0 ) then
        used = send_data ( id_diff_cmt, diff, Time, is, js, 1 )
     endif
     if ( id_massflux_cmt > 0 ) then
        used = send_data ( id_massflux_cmt, mass_flux, Time, is, js, 1 )
     endif

end subroutine diffusive_cu_mo_trans


!#######################################################################

 subroutine non_local_mot(im, jm, km, is, js, Time, dt, tin, uin, vin, nq, nq_skip, qin, pmass, mc,       &
                          det0, utnd, vtnd, ttnd, qtnd)
!
! This is a non-local cumulus transport algorithm based on the given cloud mass fluxes (mc).
! Detrainment fluxes are computed internally by mass (or momentum) conservation.
! Simple upwind algorithm is used. It is possible replace the large-scale part by
! a higher-order upwind scheme (such as van Leer or PPM). But the cost is perhaps
! not worth it becasue there is so much uncertainty in the accuracy of the cloud
! mass fluxes.
! Contact Shian-Jiann Lin for more information and a tech-note.
!
   implicit none
  integer, intent(in):: im, jm, km                   ! dimensions
  integer, intent(in):: is, js                                   
  type(time_type), intent(in) :: Time      ! timestamp for diagnmostics
  integer, intent(in):: nq                           ! tracer dimension
  integer, intent(in):: nq_skip                      ! # of tracers to skip
                                ! Here the assumption is that sphum is the #1 tracer
!  integer, intent(in):: iter                         ! Number of iterations
  real,    intent(in):: dt                           ! model time step (seconds)
  real,    intent(inout):: tin (im,jm,km)  ! temperature    
  real,    intent(inout):: uin(im,jm,km), vin(im,jm,km) ! input winds (m/s)
  real,    intent(inout):: qin(im,jm,km,nq)
  real,    intent(in):: pmass(im,jm,km)              ! layer mass (kg/m**2)
  real,    intent(in):: mc(im,jm,km+1)               ! cloud mass flux [kg/(s m**2)]
                                                     ! positive -> upward
  real,    intent(in):: det0(im,jm,km)               ! detrained mass fluxes

!  real,    intent(in):: cp                           ! 
!  real,    intent(in):: gki                          ! Gregory et al constant (0.7)
!  logical, intent(in):: conserve                     ! Conserve Total Energy?
! Output
! added on tendencies
! real,    intent(inout)::ttnd(im,jm,km)             ! temperature due to TE conservation
  real,    intent(out)::ttnd(im,jm,km)             ! temperature due to TE conservation
! real,    intent(inout)::qtnd(im,jm,km,nq)
  real,    intent(out)::qtnd(im,jm,km,nq)

  real,    intent(out)::utnd(im,jm,km), vtnd(im,jm,km)   ! m/s**2
!
! Local 
  real dm1(km), u1(km), v1(km), u2(km), v2(km)
  real q1(km,nq), q2(km,nq), qc(km,nq)
  real uc(km), vc(km)
  real mc1(km+1)
  real mc2(km+1)
  real det1(km), det2(km)

  integer i, j, k, it, iq
  integer ktop, kbot, kdet
  real rdt, ent, fac_mo, fac_t
  real,  parameter:: eps = 1.E-15       ! Cutoff value
! real,  parameter:: amplitude = 1.0    ! Tuning parameter (1=full strength)
  real x_frac
  real rtmp
  logical :: used

  utnd = 0.
  vtnd = 0.
  ttnd =0.
  qtnd = 0.

  rdt   = 1./dt
  fac_mo = amplitude * dt
!  fac_t = 0.5/(dt*cp)
  fac_t = 0.5/(dt*CP_AIR)

!  write(*,*) 'Within non_local_mot, num_tracers=', nq

  do j=1,jm
     do i=1,im

! Copy to 1D arrays to better utilize the cache
        do k=1,km
           dm1(k) = pmass(i,j,k)
        enddo

        do k=1,km
          if (limit_mass_flux) then
 ! Limit mass flux by available layer mass
            mc1(k) = min(dm1(k),   mc(i,j,k)*fac_mo) 
           det1(k) = min(dm1(k), det0(i,j,k)*fac_mo)  
          else
            mc1(k) =  mc(i,j,k)*fac_mo
           det1(k) =  det0(i,j,k)*fac_mo  
          endif
        enddo

!---------------------------
! Locate cloud base
!---------------------------
        kbot = 1
        do k = km,2,-1
           if( mc1(k) > eps ) then
                 kbot = k
                 go to 1111
           endif
        end do
1111    continue

!---------------------------
! Locate cloud top
!---------------------------
        ktop = km
        do k = 1, km-1 
           if( mc1(k+1) > eps ) then
                 ktop = k
                 go to 2222
           endif
        end do
2222    continue

        if ( kbot > ktop+1 ) then    ! ensure there are at least 3 layers to work with

           kdet = ktop
           do k=kbot-1,ktop,-1
              if ( det1(k) > eps ) then
                 kdet = k
                 go to 3333
              endif
           enddo
3333       continue
                                     ! cloudbase, interior, and cloudtop layers
           do k=ktop, kbot
              u1(k) = uin(i,j,k)
              u2(k) = u1(k)
              v1(k) = vin(i,j,k)
              v2(k) = v1(k)
           enddo

        if ( nq_skip < nq ) then
           do iq=nq_skip+1,nq
           do k=ktop, kbot
              q1(k,iq) = qin(i,j,k,iq)
              q2(k,iq) = q1(k,iq)
           enddo
           enddo
        endif

!       do it=1, iter
        do it=1, non_local_iter

!          x_frac = real(it) / real(iter)
           x_frac = real(it) / real(non_local_iter)
           do k=ktop, kbot
                 mc2(k) = x_frac * mc1(k)
                det2(k) = x_frac * det1(k)
           enddo

!----------------------------------------------------------
! In-cloud fields: Cloud base
!----------------------------------------------------------
           rtmp = 1. / (dm1(kbot)+mc2(kbot))
           uc(kbot) = (dm1(kbot)*u1(kbot) + mc2(kbot)*u2(kbot-1)) * rtmp
           vc(kbot) = (dm1(kbot)*v1(kbot) + mc2(kbot)*v2(kbot-1)) * rtmp

           if ( nq_skip < nq ) then
              do iq=nq_skip+1,nq
                 qc(kbot,iq) = (dm1(kbot)*q1(kbot,iq) + mc2(kbot)*q2(kbot-1,iq)) * rtmp
              enddo
           endif
!----------------------------------------------------------
! In-cloud fields: interior
!----------------------------------------------------------
!
!
! Below the detrainment level:  (det=0)
           if ( kdet < kbot-1 ) then
!-----------------------------------------------------------
! The in-cloud fields are modified (diluted) by entrainment of
! environment air, and the GKI effect will not be added here.
!-----------------------------------------------------------
              do k=kbot-1, kdet+1,-1
                 ent = mc2(k) - mc2(k+1) + det2(k)
                uc(k) = (mc2(k+1)*uc(k+1)+ent*u2(k)) / mc2(k)  
                vc(k) = (mc2(k+1)*vc(k+1)+ent*v2(k)) / mc2(k) 
              enddo
              if ( nq_skip < nq ) then
                 do iq=nq_skip+1,nq
                    do k=kbot-1, kdet+1,-1
                       ent = mc2(k) - mc2(k+1) + det2(k)
                       qc(k,iq) = (mc2(k+1)*qc(k+1,iq)+ent*q2(k,iq)) / mc2(k) 
                    enddo
                 enddo
              endif
           endif
!
! Pressure-gradient effect of Gregory et al 1997 added when
! the clouds are detraining.
! Entrained mass fluxes are diagnosed by mass conservation law
           if ( kdet > ktop ) then
              do k=kdet, ktop+1, -1
                 ent = mc2(k) - mc2(k+1) + det2(k)
                 uc(k) = (mc2(k+1)*uc(k+1)+ent*u2(k))/(mc2(k+1)+ent)     &
                        + gki*(u2(k)-u2(k+1))
                 vc(k) = (mc2(k+1)*vc(k+1)+ent*v2(k))/(mc2(k+1)+ent)     &
                        + gki*(v2(k)-v2(k+1))
              enddo
              if ( nq_skip < nq ) then
                 do iq=nq_skip+1,nq
                    do k=kdet, ktop+1, -1
                       ent = mc2(k) - mc2(k+1) + det2(k)
                       qc(k,iq) = (mc2(k+1)*qc(k+1,iq)+ent*q2(k,iq))/(mc2(k+1)+ent)
                    enddo
                 enddo
              endif
           endif

!----------------
! Update fields:
!----------------
! Cloud top
          rtmp = 1. / (dm1(ktop)+mc2(ktop+1))
          u2(ktop) = (dm1(ktop)*u1(ktop)+mc2(ktop+1)*uc(ktop+1)) * rtmp
          v2(ktop) = (dm1(ktop)*v1(ktop)+mc2(ktop+1)*vc(ktop+1)) * rtmp
          if ( nq_skip < nq ) then
               do iq=nq_skip+1,nq
                  q2(ktop,iq) = (dm1(ktop)*q1(ktop,iq)+mc2(ktop+1)*qc(ktop+1,iq)) * rtmp
               enddo
          endif

!---------------------------------------------------------------------
! Interior (this loop can't be vectorized due to k to k-1 dependency)
!---------------------------------------------------------------------
           do k=ktop+1,kbot-1
              u2(k) = (dm1(k)*u1(k) + mc2(k)*(u2(k-1)-uc(k)) + mc2(k+1)*uc(k+1)) /  &
                      (dm1(k) + mc2(k+1))
              v2(k) = (dm1(k)*v1(k) + mc2(k)*(v2(k-1)-vc(k)) + mc2(k+1)*vc(k+1)) /  &
                      (dm1(k) + mc2(k+1))
           enddo

          if ( nq_skip < nq ) then
           do iq=nq_skip+1,nq
           do k=ktop+1,kbot-1
              q2(k,iq) = (dm1(k)*q1(k,iq)+mc2(k)*(q2(k-1,iq)-qc(k,iq))+mc2(k+1)*qc(k+1,iq))  &
                       / (dm1(k) + mc2(k+1))
           enddo
           enddo
          endif

!---------------------------------
! Update fields in the Cloud base
!---------------------------------
               rtmp = mc2(kbot)/dm1(kbot)
           u2(kbot) = u1(kbot) + rtmp*(u2(kbot-1)-uc(kbot))
           v2(kbot) = v1(kbot) + rtmp*(v2(kbot-1)-vc(kbot))
          if ( nq_skip < nq ) then
            do iq=nq_skip+1,nq
               q2(kbot,iq) = q1(kbot,iq) + rtmp*(q2(kbot-1,iq)-qc(kbot,iq))
            enddo
          endif
        enddo         ! end iteration

!--------------------
! Compute tendencies:
!--------------------
           do k=ktop,kbot
              utnd(i,j,k) = (u2(k) - u1(k)) * rdt
              vtnd(i,j,k) = (v2(k) - v1(k)) * rdt
! Update winds:
              uin(i,j,k) = u2(k)
              vin(i,j,k) = v2(k)
           enddo
           if ( nq_skip < nq ) then
              do iq=nq_skip+1,nq
                 do k=ktop,kbot
! qtnd is the total tendency
!                   qtnd(i,j,k,iq) = qtnd(i,j,k,iq) + (q2(k,iq) - q1(k,iq)) * rdt
                    qtnd(i,j,k,iq) =                (q2(k,iq) - q1(k,iq)) * rdt
                    qin(i,j,k,iq) = q2(k,iq)
                 enddo
              enddo
           endif
  
!          if ( conserve ) then
           if ( conserve_te ) then
           do k=ktop,kbot
! ttnd is the total tendency containing contribution from RAS
              ttnd(i,j,k) = ((u1(k)+u2(k))*(u1(k)-u2(k)) + (v1(k)+v2(k))*(v1(k)-v2(k))) &
!                          * fac_t + ttnd(i,j,k)
                           * fac_t 
              tin(i,j,k) = tin(i,j,k) + ttnd(i,j,k)*dt
           enddo
            else
             do k=ktop,kbot
               ttnd(i,j,k) = 0.0
             enddo
           endif
        endif
     enddo
  enddo

! --- diagnostics
     if ( id_utnd_cmt > 0 ) then
        used = send_data ( id_utnd_cmt, utnd, Time, is, js, 1 )
     endif
     if ( id_vtnd_cmt > 0 ) then
        used = send_data ( id_vtnd_cmt, vtnd, Time, is, js, 1 )
     endif
     if (conserve_te) then
     if ( id_ttnd_cmt > 0 ) then
        used = send_data ( id_ttnd_cmt, ttnd, Time, is, js, 1 )
     endif
     endif
     if ( id_massflux_cmt > 0 ) then
        used = send_data ( id_massflux_cmt, mc, Time, is, js, 1 )
     endif
     if ( id_detmf_cmt > 0 ) then
        used = send_data ( id_detmf_cmt, det0, Time, is, js, 1 )
     endif

 end subroutine non_local_mot

end module cu_mo_trans_mod

! <INFO>

! </INFO>





module damping_driver_mod

!-----------------------------------------------------------------------
!
!       This module controls four functions:
!
!   (1) rayleigh friction applied to momentum fields at levels
!       1 to kbot (i.e., momentum is damped toward zero).
!
!   (2) mountain gravity wave drag module may be called
!
!   (3) Alexander-Dunkerton gravity wave drag may be called
!
!   (4) Garner topo_drag module may be called
!
!-----------------------------------------------------------------------

 use      mg_drag_mod, only:  mg_drag, mg_drag_init, mg_drag_end, &
                              mg_drag_restart
 use      cg_drag_mod, only:  cg_drag_init, cg_drag_calc, cg_drag_end, &
                              cg_drag_time_vary, cg_drag_endts, &
                              cg_drag_restart
 use    topo_drag_mod, only:  topo_drag_init, topo_drag, topo_drag_end, &
                              topo_drag_restart
 use          mpp_mod, only:  input_nml_file
 use          fms_mod, only:  file_exist, mpp_pe, mpp_root_pe, stdlog, &
                              write_version_number, &
                              open_namelist_file, error_mesg, &
                              check_nml_error,                   &
                              FATAL, close_file
 use diag_manager_mod, only:  register_diag_field,  &
                              register_static_field, send_data
 use time_manager_mod, only:  time_type
 use    constants_mod, only:  cp_air, grav

 implicit none
 private

 public   damping_driver, damping_driver_init, damping_driver_end
 public   damping_driver_time_vary, damping_driver_endts
 public   damping_driver_restart

!-----------------------------------------------------------------------
!---------------------- namelist ---------------------------------------

   real     :: trayfric = 0.
   integer  :: nlev_rayfric = 1
   logical  :: do_mg_drag = .false.
   logical  :: do_cg_drag = .false.
   logical  :: do_topo_drag = .false.
   logical  :: do_conserve_energy = .false.

   namelist /damping_driver_nml/  trayfric,   nlev_rayfric,  &
                                  do_cg_drag, do_topo_drag, &
                                  do_mg_drag, do_conserve_energy

!
!   trayfric = damping time in seconds for rayleigh damping momentum
!              in the top nlev_rayfric layers (if trayfric < 0 then time
!              in days)
!                 [real, default: trayfric=0.]
!
!   nlev_rayfric = number of levels at the top of the model where
!                  rayleigh friction of momentum is performed, if
!                  trayfric=0. then nlev_rayfric has no effect
!                    [integer, default: nlev_rayfric=1]
!
!-----------------------------------------------------------------------
!----- id numbers for diagnostic fields -----

integer :: id_udt_rdamp,  id_vdt_rdamp,   &
           id_udt_gwd,    id_vdt_gwd,     &
                          id_sgsmtn,      &
           id_udt_cgwd,   id_taus
integer    id_vdt_cgwd

integer :: id_tdt_diss_rdamp,  id_diss_heat_rdamp, &
           id_tdt_diss_gwd,    id_diss_heat_gwd,   &
           id_tdt_diss_topo,   id_diss_heat_topo

integer :: id_udt_topo,   id_vdt_topo,   id_taubx,  id_tauby

!----- missing value for all fields ------

real :: missing_value = -999.

character(len=7) :: mod_name = 'damping'

!-----------------------------------------------------------------------

 logical :: do_rayleigh

 real, parameter ::  daypsec=1./86400.
 logical :: module_is_initialized =.false.

 real :: rfactr

!   note:  
!     rfactr = coeff. for damping momentum at the top level

 character(len=128) :: version = '$Id: damping_driver.F90,v 18.0.2.1 2010/08/30 20:33:33 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------

contains

!#######################################################################

 subroutine damping_driver (is, js, lat, Time, delt, pfull, phalf, zfull, zhalf, &
                            u, v, t, q, r,  udt, vdt, tdt, qdt, rdt,  &
!                                   mask, kbot)
                            z_pbl,  mask, kbot)
 
!-----------------------------------------------------------------------
 integer,         intent(in)                :: is, js
 real, dimension(:,:), intent(in)           :: lat
 type(time_type), intent(in)                :: Time
 real,            intent(in)                :: delt
 real,    intent(in),    dimension(:,:,:)   :: pfull, phalf, &
                                               zfull, zhalf, &
                                               u, v, t, q
 real,    intent(in),    dimension(:,:,:,:) :: r
 real,    intent(inout), dimension(:,:,:)   :: udt,vdt,tdt,qdt
 real,    intent(inout), dimension(:,:,:,:) :: rdt
 real, dimension(:,:), intent(in)           :: z_pbl
 real,    intent(in),    dimension(:,:,:), optional :: mask
 integer, intent(in),    dimension(:,:),   optional :: kbot

!-----------------------------------------------------------------------
 real, dimension(size(udt,1),size(udt,2))             :: diag2
 real, dimension(size(udt,1),size(udt,2))             :: taubx, tauby
 real, dimension(size(udt,1),size(udt,2),size(udt,3)) :: taus
 real, dimension(size(udt,1),size(udt,2),size(udt,3)) :: utnd, vtnd, &
                                                         ttnd, pmass, &
                                                         p2
 integer :: k
 logical :: used

!-----------------------------------------------------------------------

   if (.not.module_is_initialized) call error_mesg ('damping_driver',  &
                     'damping_driver_init must be called first', FATAL)

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!----------------- r a y l e i g h   d a m p i n g ---------------------
!-----------------------------------------------------------------------
   if (do_rayleigh) then

       p2 = pfull * pfull
       call rayleigh (delt, p2, u, v, utnd, vtnd, ttnd)
       udt = udt + utnd
       vdt = vdt + vtnd
       tdt = tdt + ttnd

!----- diagnostics -----

       if ( id_udt_rdamp > 0 ) then
            used = send_data ( id_udt_rdamp, utnd, Time, is, js, 1, &
                               rmask=mask )
       endif

       if ( id_vdt_rdamp > 0 ) then
            used = send_data ( id_vdt_rdamp, vtnd, Time, is, js, 1, &
                               rmask=mask )
       endif

       if ( id_tdt_diss_rdamp > 0 ) then
            used = send_data ( id_tdt_diss_rdamp, ttnd, Time, is, js, 1, &
                               rmask=mask )
       endif

       if ( id_diss_heat_rdamp > 0 ) then
            do k = 1,size(u,3)
              pmass(:,:,k) = phalf(:,:,k+1)-phalf(:,:,k)
            enddo
            diag2 = cp_air/grav * sum(ttnd*pmass,3)
            used = send_data ( id_diss_heat_rdamp, diag2, Time, is, js )
       endif

   endif
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!--------- m t n   g r a v i t y   w a v e   d r a g -------------------
!-----------------------------------------------------------------------
   if (do_mg_drag) then

       call mg_drag (is, js, delt, u, v, t, pfull, phalf, zfull, zhalf,  &
                     utnd, vtnd, ttnd, taubx,tauby,taus,        kbot)
       udt = udt + utnd
       vdt = vdt + vtnd
       tdt = tdt + ttnd

!----- diagnostics -----

       if ( id_udt_gwd > 0 ) then
            used = send_data ( id_udt_gwd, utnd, Time, is, js, 1, &
                               rmask=mask )
       endif

       if ( id_vdt_gwd > 0 ) then
            used = send_data ( id_vdt_gwd, vtnd, Time, is, js, 1, &
                               rmask=mask )
       endif

       if ( id_taubx > 0 ) then
            used = send_data ( id_taubx, taubx, Time, is, js )
       endif

       if ( id_tauby > 0 ) then
            used = send_data ( id_tauby, tauby, Time, is, js )
       endif

       if ( id_taus > 0 ) then
           used = send_data ( id_taus, taus, Time, is, js, 1, &
                              rmask=mask )
       endif

       if ( id_tdt_diss_gwd > 0 ) then
            used = send_data ( id_tdt_diss_gwd, ttnd, Time, is, js, 1, &
                               rmask=mask )
       endif

       if ( id_diss_heat_gwd > 0 ) then
            do k = 1,size(u,3)
              pmass(:,:,k) = phalf(:,:,k+1)-phalf(:,:,k)
            enddo
            diag2 = cp_air/grav * sum(ttnd*pmass,3)
            used = send_data ( id_diss_heat_gwd, diag2, Time, is, js )
       endif

   endif

!   Alexander-Dunkerton gravity wave drag

   if (do_cg_drag) then

     call cg_drag_calc (is, js, lat, pfull, zfull, t, u, v, Time,    &
                        delt, utnd, vtnd)

     udt =  udt + utnd
     vdt =  vdt + vtnd

!----- diagnostics -----

     if ( id_udt_cgwd > 0 ) then
        used = send_data ( id_udt_cgwd, utnd, Time, is, js, 1, &
                          rmask=mask )
     endif
      if ( id_vdt_cgwd > 0 ) then
        used = send_data ( id_vdt_cgwd, vtnd, Time, is, js, 1, &
                          rmask=mask )
     endif


   endif

!-----------------------------------------------------------------------
!---------topographic   w a v e   d r a g -------------------
!-----------------------------------------------------------------------
   if (do_topo_drag) then

     call topo_drag ( is, js, delt, u, v, t, pfull, phalf, zfull, zhalf,  &
                      utnd, vtnd, ttnd, taubx, tauby, taus, kbot )

     udt = udt + utnd
     vdt = vdt + vtnd

!----- diagnostics -----

     if ( id_udt_topo > 0 ) then
        used = send_data ( id_udt_topo, utnd, Time, is, js, 1, &
                           rmask=mask )
     endif

     if ( id_vdt_topo > 0 ) then
        used = send_data ( id_vdt_topo, vtnd, Time, is, js, 1, &
                           rmask=mask )
     endif

     if ( id_taubx > 0 ) then
       used = send_data ( id_taubx, taubx, Time, is, js )
     endif

     if ( id_tauby > 0 ) then
        used = send_data ( id_tauby, tauby, Time, is, js )
     endif

     if ( id_taus > 0 ) then
        used = send_data ( id_taus, taus, Time, is, js, 1, &
                           rmask=mask )
     endif

     if ( id_tdt_diss_topo > 0 ) then
        used = send_data ( id_tdt_diss_topo, ttnd, Time, is, js, 1, &
                               rmask=mask )
     endif

     if ( id_diss_heat_topo > 0 ) then
          do k = 1,size(u,3)
             pmass(:,:,k) = phalf(:,:,k+1)-phalf(:,:,k)
          enddo
          diag2 = cp_air/grav * sum(ttnd*pmass,3)
          used = send_data ( id_diss_heat_topo, diag2, Time, is, js )
     endif

 endif

!-----------------------------------------------------------------------

 end subroutine damping_driver

!#######################################################################

 subroutine damping_driver_init ( lonb, latb, pref, axes, Time, sgsmtn)

 real,            intent(in) :: lonb(:,:), latb(:,:), pref(:)
 integer,         intent(in) :: axes(4)
 type(time_type), intent(in) :: Time
 real, dimension(:,:), intent(out) :: sgsmtn
!-----------------------------------------------------------------------
!     lonb  = longitude in radians of the grid box corners
!     latb  = latitude  in radians of the grid box corners
!     axes  = axis indices, (/x,y,pf,ph/)
!               (returned from diag axis manager)
!     Time  = current time (time_type)
!     sgsmtn = subgrid scale topography variance
!-----------------------------------------------------------------------
 integer :: unit, ierr, io, logunit
 logical :: used

!-----------------------------------------------------------------------
!----------------- namelist (read & write) -----------------------------

#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=damping_driver_nml, iostat=io)
   ierr = check_nml_error(io,"damping_driver_nml")
#else
   if (file_exist('input.nml')) then
      unit = open_namelist_file ()
      ierr=1; do while (ierr /= 0)
         read  (unit, nml=damping_driver_nml, iostat=io, end=10)
         ierr = check_nml_error (io, 'damping_driver_nml')
      enddo
 10   call close_file (unit)
   endif
#endif

   call write_version_number(version, tagname)
   logunit = stdlog()
   if(mpp_pe() == mpp_root_pe() ) then
        write (logunit,nml=damping_driver_nml)
   endif

!-----------------------------------------------------------------------
!--------- rayleigh friction ----------

   do_rayleigh=.false.

   if (abs(trayfric) > 0.0001 .and. nlev_rayfric > 0) then
      if (trayfric > 0.0) then
         rfactr=(1./trayfric)
      else
         rfactr=(1./abs(trayfric))*daypsec
      endif
         do_rayleigh=.true.
   else
         rfactr=0.0
   endif

!-----------------------------------------------------------------------
!----- mountain gravity wave drag -----

   if (do_mg_drag) call mg_drag_init (lonb, latb, sgsmtn)

!--------------------------------------------------------------------
!----- Alexander-Dunkerton gravity wave drag -----
 
   if (do_cg_drag)  then
     call cg_drag_init (lonb, latb, pref, Time=Time, axes=axes)
   endif

!-----------------------------------------------------------------------
!----- initialize diagnostic fields -----

if (do_rayleigh) then

   id_udt_rdamp = &
   register_diag_field ( mod_name, 'udt_rdamp', axes(1:3), Time,       &
                       'u wind tendency for Rayleigh damping', 'm/s2', &
                        missing_value=missing_value               )

   id_vdt_rdamp = &
   register_diag_field ( mod_name, 'vdt_rdamp', axes(1:3), Time,       &
                       'v wind tendency for Rayleigh damping', 'm/s2', &
                        missing_value=missing_value               )

   id_tdt_diss_rdamp = &
   register_diag_field ( mod_name, 'tdt_diss_rdamp', axes(1:3), Time,  &
                      'Dissipative heating from Rayleigh damping',&
                             'deg_k/s', missing_value=missing_value   )
       
   id_diss_heat_rdamp = &
   register_diag_field ( mod_name, 'diss_heat_rdamp', axes(1:2), Time,   &
                'Integrated dissipative heating from Rayleigh damping',&
                  'W/m2' )
endif

if (do_mg_drag) then

 ! register and send static field
   id_sgsmtn = &
   register_static_field ( mod_name, 'sgsmtn', axes(1:2), &
               'sub-grid scale topography for gravity wave drag', 'm')
   if (id_sgsmtn > 0) used = send_data (id_sgsmtn, sgsmtn, Time)

 ! register non-static field
   id_udt_gwd = &
   register_diag_field ( mod_name, 'udt_gwd', axes(1:3), Time,        &
                     'u wind tendency for gravity wave drag', 'm/s2', &
                        missing_value=missing_value               )

   id_vdt_gwd = &
   register_diag_field ( mod_name, 'vdt_gwd', axes(1:3), Time,        &
                     'v wind tendency for gravity wave drag', 'm/s2', &
                        missing_value=missing_value               )

   id_taubx = &
   register_diag_field ( mod_name, 'taubx', axes(1:2), Time,        &
                         'x base flux for grav wave drag', 'kg/m/s2', &
                         missing_value=missing_value               )

   id_tauby = &
   register_diag_field ( mod_name, 'tauby', axes(1:2), Time,        &
                         'y base flux for grav wave drag', 'kg/m/s2', &
                         missing_value=missing_value )

   id_taus = &
   register_diag_field ( mod_name, 'taus', axes(1:3), Time,        &
                       'saturation flux for gravity wave drag', 'kg/m/s2', &
                      missing_value=missing_value               )

   id_tdt_diss_gwd = &
   register_diag_field ( mod_name, 'tdt_diss_gwd', axes(1:3), Time,    &
                          'Dissipative heating from gravity wave drag',&
                              'deg_k/s', missing_value=missing_value   )
       
   id_diss_heat_gwd = &
   register_diag_field ( mod_name, 'diss_heat_gwd', axes(1:2), Time,      &
                'Integrated dissipative heating from gravity wave drag',&
                                 'W/m2' )
endif

   if (do_cg_drag) then

    id_udt_cgwd = &
    register_diag_field ( mod_name, 'udt_cgwd', axes(1:3), Time,        &
                 'u wind tendency for cg gravity wave drag', 'm/s2', &
                      missing_value=missing_value               )


    id_vdt_cgwd = &
    register_diag_field ( mod_name, 'vdt_cgwd', axes(1:3), Time,        &
                 'v wind tendency for cg gravity wave drag', 'm/s2', &
                      missing_value=missing_value               )


   endif

!-----------------------------------------------------------------------
!----- topo wave drag -----



  if (do_topo_drag) then
          call topo_drag_init (lonb, latb)
          sgsmtn(:,:) = -99999.
  endif



  if (do_topo_drag) then

   id_udt_topo = &
   register_diag_field ( mod_name, 'udt_topo', axes(1:3), Time,        &
                       'u wind tendency for topo wave drag', 'm/s2', &
                        missing_value=missing_value               )

  id_vdt_topo = &
   register_diag_field ( mod_name, 'vdt_topo', axes(1:3), Time,        &
                       'v wind tendency for topo wave drag', 'm/s2', &
                         missing_value=missing_value               )

   id_taubx = &
   register_diag_field ( mod_name, 'taubx', axes(1:2), Time,        &
                     'x base flux for topo wave drag', 'kg/m/s2', &
                        missing_value=missing_value               )

    id_tauby = &
    register_diag_field ( mod_name, 'tauby', axes(1:2), Time,        &
                    'y base flux for topo wave drag', 'kg/m/s2', &
                      missing_value=missing_value )

    id_taus = &
   register_diag_field ( mod_name, 'taus', axes(1:3), Time,        &
                  'saturation flux for topo wave drag', 'kg/m/s2', &
                     missing_value=missing_value               )

   id_tdt_diss_topo = &
   register_diag_field ( mod_name, 'tdt_diss_topo', axes(1:3), Time,    &
                          'Dissipative heating from topo wave drag',&
                              'deg_k/s', missing_value=missing_value   )
       
   id_diss_heat_topo = &
   register_diag_field ( mod_name, 'diss_heat_topo', axes(1:2), Time,      &
                'Integrated dissipative heating from topo wave drag',&
                                 'W/m2' )
 endif


!-----------------------------------------------------------------------

   module_is_initialized =.true.

!******************** end of initialization ****************************
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

 end subroutine damping_driver_init


!#####################################################################

subroutine damping_driver_time_vary (delt)

real, intent(in) :: delt


       call cg_drag_time_vary (delt)

end subroutine damping_driver_time_vary



!#####################################################################

subroutine damping_driver_endts


     call cg_drag_endts

end subroutine damping_driver_endts



!######################################################################
!#######################################################################

 subroutine damping_driver_end

     if (do_mg_drag)   call mg_drag_end
     if (do_cg_drag)   call cg_drag_end
     if (do_topo_drag) call topo_drag_end

     module_is_initialized =.false.


 end subroutine damping_driver_end

!#######################################################################
! <SUBROUTINE NAME="damping_driver_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine damping_driver_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

     if (do_mg_drag)   call mg_drag_restart(timestamp)
     if (do_cg_drag)   call cg_drag_restart(timestamp)
     if (do_topo_drag) call topo_drag_restart(timestamp)

end subroutine damping_driver_restart
! </SUBROUTINE> NAME="damping_driver_restart" 

!#######################################################################

 subroutine rayleigh (dt, p2, u, v, udt, vdt, tdt)

  real,    intent(in)                      :: dt
  real,    intent(in),  dimension(:,:,:)   :: p2, u, v
  real,    intent(out), dimension(:,:,:)   :: udt, vdt, tdt

  real, dimension(size(u,1),size(u,2)) :: fact
  integer :: k
!-----------------------------------------------------------------------
!--------------rayleigh damping of momentum (to zero)-------------------

   do k = 1, nlev_rayfric
     fact(:,:) = rfactr*(1.+(p2(:,:,1)-p2(:,:,k))/(p2(:,:,1)+p2(:,:,k)))
     udt(:,:,k) = -u(:,:,k)*fact(:,:)
     vdt(:,:,k) = -v(:,:,k)*fact(:,:)
   enddo

   do k = nlev_rayfric+1, size(u,3)
     udt(:,:,k) = 0.0
     vdt(:,:,k) = 0.0
   enddo

!  total energy conservation
!  compute temperature change loss due to ke dissipation

   if (do_conserve_energy) then
       do k = 1, nlev_rayfric
          tdt(:,:,k) = -((u(:,:,k)+.5*dt*udt(:,:,k))*udt(:,:,k) +  &
                         (v(:,:,k)+.5*dt*vdt(:,:,k))*vdt(:,:,k)) / cp_air
       enddo
       do k = nlev_rayfric+1, size(u,3)
          tdt(:,:,k) = 0.0
       enddo
   else
       tdt = 0.0
   endif

!-----------------------------------------------------------------------

 end subroutine rayleigh

!#######################################################################

end module damping_driver_mod



MODULE DIAG_CLOUD_MOD


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!       DIAGNOSTIC CLOUD PREDICTION - Gordon (1992)            
!
!       1999 Feb -> 2000 July
!       Contact persons: Bill Stern (for code structure information)
!                        Tony Gordon (for cloud scheme information)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!-------------------------------------------------------------------
!  Calculates cloud fractions diagnostically using relative humidity,
!  omega and stability 
!-------------------------------------------------------------------

use mpp_mod, only: input_nml_file
 use       fms_mod, only: error_mesg, FATAL, NOTE, file_exist,    &
                          check_nml_error, open_namelist_file,       &
                          mpp_pe, mpp_root_pe,  close_file, &
                          read_data, write_data, &
                          write_version_number, stdlog, open_restart_file
 use     fms_io_mod, only: register_restart_field, restart_file_type, &
                           save_restart, restore_state, get_restart_io_mode
 use  Constants_Mod, only: Cp_Air, rdgas, rvgas, Kappa, HLv
 use time_manager_mod, only:  TIME_TYPE
 use  cloud_zonal_mod, only:  CLOUD_ZONAL_INIT, GETCLD
 use  diag_cloud_rad_mod, only:  CLOUD_TAU_DRIVER, diag_cloud_rad_INIT,&
                                 cloud_pres_thick_for_tau,  &
                                 cloud_opt_prop_tg_lw, &
                                 cloud_opt_prop_tg_sw, &
                                 cloud_optical_depths, &
                                 cloud_optical_depths2
 use  sat_vapor_pres_mod, ONLY: compute_qs
 use  shallow_conv_mod, ONLY: SHALLOW_CONV_INIT,MYLCL

!-----------------------------------------------------------------------
 implicit none
!-----------------------------------------------------------------------

 private


!--------------------- version number ----------------------------------
 character(len=128) :: version = '$Id: diag_cloud.F90,v 17.0.4.1 2010/08/30 20:33:34 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.
!-----------------------------------------------------------------------

!  parmameter mxband = max number of radiative bands to be considered for some
!              cloud properties
 integer,  parameter :: mxband = 4
!  parmameter nrhc = number of critical relative humidity threshold values
!  as a function of vertical layers
 integer,  parameter :: nrhc = 3

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

!  WARNING: The parameter mxband and the namelist variable nband should have
!  the same value. Is there a way to guarantee this or can an error check
!  be added to the code to make sure that this condition is NOT violated?

! ****************************************************************************
!  The following constants are derive from other constants in constants_mod
   real,  parameter :: d622  = rdgas/rvgas, d378  = 1.0-d622
   real,  parameter :: p00 = 1000.0E2
!-----------------------------------------------------------------------

! ****  parameter used and defined in def_hi_mid_low ****

!  real,  parameter :: trshld_camt = 0.25

!      TRSHLD_CAMT - This is a cloud amounht threshold value, used in
!      conjunction with the thick cloud namelist options.  If a thick
!      cloud option is on then the level above the cloud amount max
!      for a particular cloud type is considered to be part of an
!      extended cloud if it is within this fraction of the max cloud amount.
!

!----------------- arrays for cloud predictor averaging code --------------------------

    real,    allocatable, dimension (:,:,:) :: temp_sum,qmix_sum,rhum_sum
    real,    allocatable, dimension (:,:) :: qmix_sum2
    real,    allocatable, dimension (:,:,:) :: omega_sum
    real,    allocatable, dimension (:,:,:) :: lgscldelq_sum,cnvcntq_sum
    real,    allocatable, dimension (:,:)   :: convprc_sum
    integer, allocatable, dimension (:,:)   :: nsum, nsum2

!-----------------------------------------------------------------------
! for netcdf restart
type(restart_file_type), save :: Dia_restart


!---------------------------------------------------------------------


! logical switches for initialization calls: 
! if = .false. -> has not been called
 logical :: do_cpred_init = .false.
 logical :: do_crad_init = .false.

!---------------------------------------------------------------------
! --- NAMELIST (diag_cloud_nml)
!---------------------------------------------------------------------
!     RHC -    critical humidity value (ras = 0.8 - 0.84, mca =0.7)
!              (note:  in vers >= 0.9.3 a function of 3 levels
!                i.e.,"high" , "mid", "low" - but here is more general)
!     PBOUNDS - sets pressure bounds for RHC (dimension = size(rhc) - 1
!     DO_AVERAGE - logical flag for time averaging cloud predictor variables
!     LQUADRA - logical switch for turning on quadratic relation
!             for calculating rhum clouds from rhum,
!             i.e., true for quadratice scheme, false for linear scheme
!     LRHCNV - logical switch for using rhum fields as follows:
!              if true - use rel humidities modified for presence of 
!              convective clouds (rhumcnv), otherwise use original 
!              rel humidities (rhum)
!     LOMEGA - logical switch for turning on omega correction to rhum 
!              clouds - true for omega correction, otherwise false 
!     LCNVCLD - logical switch for turning on calculation of deep convective 
!              clouds - true for deep convective clouds, otherwise false 
!     L_THEQV - logical switch for turning on calculation of shallow convective 
!              clouds - true for shallow convective clouds, otherwise false 
!     LINVERS - logical switch for turning on calculation of marine stratus 
!              clouds - true for marine stratus, otherwise false 
!     LSLINGO - logical variable = true apply Slingo marine stratus 
!                scheme, otherwise = false. 
!     LREGRSC - logical variable = true apply Tim Li marine stratus 
!                scheme, otherwise = false. Slingo & Li schemes may be
!                used in combination, but atleast one scheme must be used. 
!     LTHICK_HIGH - logical variable = true -> allow possibility of raising
!               high cloud tops one sigma level to increase their thickness
!               from 1 to nmax levels; otherwise they remain thin 
!               (1 level)
!     LTHICK_MID - logical variable = true -> allow possibility of raising
!               mid cloud tops one sigma level to increase their thickness
!               from 1 to nmax levels; otherwise they remain thin 
!               (1 level)
!     LTHICK_LOW - logical variable = true -> allow possibility of raising
!               low cloud tops one sigma level to increase their thickness
!               from 1 to nmax levels; otherwise they remain thin 
!               (1 level)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!     NBAND - max number of radiative bands to be considered for some
!              cloud properties
!     PSHALLOW - top of shallow convective layer (pressure level - n/m**2 )
!     WCUT0 - omega cutoff value for omega cloud depletion factor = 0
!     WCUT1 - omega cutoff value for omega cloud depletion factor = 1
!     t_cold     temperature defining ice-liquid cloud transition
!-----------------------------------------------------------------------

      real        :: t_cold= 263.16
 real :: &
      pshallow=.750E+05, wcut0 = .10, wcut1 = 0.0
 real, dimension(nrhc) :: rhc = (/ 0.8,0.8,0.84 /)
 real, dimension(nrhc-1) :: pbounds = (/ .400E5, .750e5 /)

 integer :: &
      high_lev_cloud_index=3, low_lev_cloud_index=16, nband=4 

 logical :: &
      do_average = .true., &
      lquadra = .true., nofog = .false.,lrhcnv = .false., & 
      lomega = .true.,lcnvcld = .true.,l_theqv = .true., & 
      linvers = .false.,lslingo = .true., lregrsc = .true., &
      lthick_high = .true.,lthick_mid = .true.,lthick_low = .true.

    NAMELIST / diag_cloud_nml /                         &
       rhc,pbounds,do_average,lquadra,lrhcnv,lomega,lcnvcld,l_theqv, & 
       linvers,lslingo,lregrsc,lthick_high,lthick_mid,lthick_low, & 
       high_lev_cloud_index, nofog, low_lev_cloud_index, nband, &
       pshallow, wcut0, wcut1, t_cold

integer :: num_pts, tot_pts
 logical :: do_netcdf_restart

 public diag_cloud_driver, diag_cloud_init, diag_cloud_end
 public diag_cloud_driver2
 public diag_cloud_sum, diag_cloud_avg, diag_cloud_avg2, do_diag_cloud
 public diag_cloud_restart

 contains

!#############################################################################      

 SUBROUTINE DIAG_CLOUD_DRIVER (is,js, &
                    temp,qmix,rhum,omega,lgscldelq,cnvcntq,convprc, &
                    pfull,phalf,psfc,coszen,lat,time, &
                    nclds,cldtop,cldbas,cldamt,r_uv,r_nir,ab_uv,ab_nir, &
                    em_lw, conc_drop, conc_ice, size_drop, size_ice, &
    kbot)

! Arguments (intent in)

 integer, intent(in)   ::  is,js
 type(time_type), intent(in)  :: time
 real, intent(in)  :: lat(:,:)
 real, intent(in), dimension (:,:,:) ::  temp,qmix,rhum,omega
 real, intent(in), dimension (:,:,:) ::  lgscldelq,cnvcntq,pfull, phalf
 real, intent(in), dimension (:,:)   ::  convprc,psfc, coszen
 
 integer, intent(in), OPTIONAL, dimension(:,:) :: kbot


!      INPUT
!      ------

!      IS,JS    starting i,j indices from the full horizontal grid
!      IX, IY   Horizontal dimensions for global storage arrays
!      TEMP     Temperature (Deg K) at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      QMIX     Mixing Ratio at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      RHUM     Relative humidity fraction at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      OMEGA  Pressure vertical velocity at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      LGSCLDELQ  Averaged rate of change in mix ratio due to lg scale precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      CNVCNTQ  Accumulated count of change in mix ratio due to conv precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      convprc Accumulated conv precip rate summed over all
!               full model levels (mm/day )
!               (dimensioned IDIM x JDIM)
!      PFULL    Pressure at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!      PSFC     Surface pressure field
!                   (dimensioned IDIM x JDIM)
!      COSZEN     cosine of the zenith angle
!                   (dimensioned IDIM x JDIM)
!      TIME       time of year (time_type)
!      LAT        latitudes in radians, dimensioned by (1xJDIM)   
!      KBOT      OPTIONAL; lowest model level index array
!                   (dimensioned IDIM x JDIM)
!===================================================================
! Arguments (intent out)

 integer, intent(out), dimension(:,:,:) :: cldtop,cldbas
 integer, intent(out), dimension(:,:)  ::  nclds

   real, intent(out), dimension(:,:,:), optional :: r_uv,r_nir,ab_uv, &
                                                  ab_nir,em_lw, &
                                                  conc_drop, conc_ice, &
                                                  size_drop, size_ice
   real, intent(out), dimension(:,:,:) :: cldamt

!      OUTPUT
!      ------

!       NCLDS   number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!                   (dimensioned IDIM x JDIM )
!      CLDTOP   index of cloud tops (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDBAS   index of cloud bottoms (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDAMT   cloud amount (fraction) (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      R_UV     fractional amount of ultraviolet radiation
!                     reflected by the clouds (at cloud levels)
!      R_NIRfractional amount of near inrared radiation
!                     reflected by the clouds (at cloud levels)
!      AB_UVfractional amount of ultraviolet radiation
!                     absorbed by the clouds (at cloud levels)
!      AB_NIRfractional amount of near inrared radiation
!                     absorbed by the clouds (at cloud levels)
!      EM_LWemissivity for the clouds (at cloud levels)

!=======================================================================
!  (Intent local)
integer, dimension(size(rhum,1),size(rhum,2)) :: &
         lhight, lhighb, lmidt, lmidb, llowt
integer,  dimension(size(rhum,1),size(rhum,2),size(rhum,3))  :: icld
real, dimension(size(rhum,1),size(rhum,2)) :: qmix_kx
real,  dimension(size(rhum,1),size(rhum,2),size(rhum,3),mxband)  :: tau
real,  dimension(size(rhum,1),size(rhum,2),size(rhum,3))  :: &
                  tempcld,delp_true, delp
integer idim, jdim, kx, lk
logical :: rad_prop, wat_prop
integer :: max_cld
integer :: i,j,k,n

!       TAU        cloud optical depth (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx x MXBAND)
!      TEMPCLD    cloud layer mean temperature (degrees Kelvin)
!                    (at cloud levels)
!      DELP_TRUE  true cloud pressure thickness of distinct cloud layers 
!                    (at cloud levels)
!       QMIX_KX     Lowest level mixing ratio 
!                   (dimensioned IDIM x JDIM)
!       ICLD          marker array of cloud types/heights (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!       LHIGHT        vertical level index upper limit for high cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LHIGHB        vertical level index lower limit for high cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDT         vertical level index upper limit for mid cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDB         vertical level index lower limit for mid cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LLOWT         vertical level index upper limit for low cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       IERR        Error flag
!       IPRNT       Longitude index for sample printing
!
!  note:  LK - vertical level below which no low cloud bases can exist, is
!         calculated in routines where needed using namelist inputs 
!         low_lev_cloud_index and nofog for the cloud amount prediction code
!         but is passed to the cloud raidiative properties code as an argument.
!===================================================================

!-----------------------------------------------------------------------

      idim = size(rhum,1)
      jdim = size(rhum,2)
      kx = size(rhum,3)
      tau = 0.0

      rad_prop = .false.
      wat_prop = .false.
      if (present (r_uv) .or. present(r_nir) .or. present (ab_uv) &
       .or. present(ab_nir) .or. present (em_lw) ) then
   rad_prop = .true.
   r_uv = 0.
   r_nir = 0.
   ab_uv = 0.
   ab_nir = 0.
   em_lw = 0.
endif
if (present(conc_drop) .or. present(conc_ice) .or.    &
     present(size_drop) .or. present(size_ice) ) then
   wat_prop = .true.
endif
if ( (.not. rad_prop) .and. (.not. wat_prop) ) then
  rad_prop = .true.
endif

  !  define lower limit for low cloud bases
if (nofog) then
  lk = low_lev_cloud_index
else
  lk = kx
endif

!  cldtim drives cloud prediction scheme
      call cldtim ( temp,qmix,rhum,omega,lgscldelq,cnvcntq,convprc, &
                    pfull, phalf,psfc, lat, time, tempcld,delp_true, &
                    cldtop,cldbas,cldamt,                              &
                    lhight,lhighb, lmidt, lmidb, llowt,icld,nclds,kbot)

! lowest level mixing ratio for anomalous absorption in cloud-radiation
      qmix_kx(:,:) = qmix(:,:,kx)

    max_cld  = MAXVAL(nclds(:,:))

    IF (max_cld .gt. 0) then

       call cloud_pres_thick_for_tau (nclds,icld,cldtop,cldbas, &
   &          delp_true,lhight,lhighb, lmidt, lmidb, llowt,lk, delp, &
   &          phalf, psfc )

       call cloud_optical_depths(nclds,icld,cldtop,cldbas,tempcld,delp, &
                          tau,phalf )

!  cloud_tau_driver drives cloud radiative properties scheme
      if (rad_prop) then
      call cloud_tau_driver (            qmix_kx,                   &
                                          tempcld, &
                                               tau, coszen,  &
                                   r_uv=r_uv, r_nir=r_nir, ab_nir=ab_nir, ab_uv=ab_uv, &
                 em_lw=em_lw)

      endif

      endif ! (max_cld > 0)

!-----------------------------------------------------------------------
!  print output for 1-d testing
!            iprnt = 1
!            print *, ' diag_cloud sample output for iprnt,js= ', iprnt,js
!            print *,'cloud layers = ', nclds(iprnt,1)     
!            print *,'cloud amounts = ', cldamt(iprnt,1,:)     
!            print *,'cloud tops = ', cldtop(iprnt,1,:)     
!            print *,'cloud bases = ', cldbas(iprnt,1,:)     
!            print *,'cloud types = ', icld(iprnt,1,:)    
!            print *, ' clouds_rad_tg sample output '
!            print *,'reflectivity uv = ', r_uv(iprnt,1,:)     
!            print *,'reflectivity nir = ', r_nir(iprnt,1,:)     
!            print *,'absorptivity uv = ', ab_uv(iprnt,1,:)     
!            print *,'absorptivity nir = ', ab_nir(iprnt,1,:)     
!            print *,'emissivity = ', em_lw(iprnt,1,:)     
!            print *,'optical depth = ', tau(iprnt,1,:,:)     

!-----------------------------------------------------------------------
   if (present (conc_drop)) then
!-----------------------------------------------------------------------
!!!RSH
!!      NOTE:
!  THE FOLLOWING is here as an INITIAL IMPLEMENTATION to allow compil-
!  ation and model execution, and provide "reasonable ?? " values.
!  Code developed but NOT YET ADDED HERE reflects the current approach.
!  That code is available under the fez release, and will be added to
!  the repository when upgrades to the cloud-radiation modules are com-
!  pleted.
!!!RSH
! obtain drop and ice size and concentration here, consistent with the
! diag_cloud scheme.
!  As a test case, 
!  the following is a simple specification of constant concentration and
!  size in all boxes defined as cloudy, attempting to come close to
!  the prescribd values in microphys_rad.
!  assume ice cld thickness = 2.0 km; then conc_ice=10.0E-03 => 
!    iwp = 20 g/m^2, similar to that prescribed in microphys_rad.
!  assume water cld thickness = 3.5 km; then conc_drop = 20E-03 =>
!    lwp = 70 g / m^2, similar to that prescribed in microphys_rad.
!   use sizes as used in microphys_rad (50 and 20 microns). when done,
!   radiative boundary fluxes are "similar" to non-microphysical results
!   for test case done here, and shows reasonable sensitivity to
!   variations in concentrations.

    conc_ice = 0.
    conc_drop = 0.
    size_ice = 50.
    size_drop = 20.


    IF (max_cld .gt. 0) then
         idim = size(tau,1)
           jdim = size(tau,2)
         do j= 1,jdim
           do i=1,idim
          do n=1,nclds(i,j)
          do k=cldtop(i,j,n), cldbas(i,j,n)
           if (tempcld(i,j,n) < t_cold) then
            conc_ice(i,j,k) = 10.0E-03  ! units : g/m^3
          size_ice(i,j,k) = 50.       ! units : diameter in microns
           else
            conc_drop(i,j,k) = 20.0E-03 ! units : g/m^3
            size_drop(i,j,k) = 20.      ! units : diameter in microns
           endif
           end do
        end do
           end do
           end do

    endif
 endif


end SUBROUTINE DIAG_CLOUD_DRIVER

!---------------------------------------------------------------------

subroutine diag_cloud_driver2 (is, js, press, pflux, lat, time, nclds, &
                               cldtop, cldbas, cldamt, liq_frac, tau, &
                               ice_cloud, kbot) 

!--------------------------------------------------------------------- 
!    diag_cloud_driver2 returns the cloud specification arrays for the 
!    gordon diag cloud scheme. returned are the number of clouds per 
!    column, the cloud top, cloud base and fractional coverage of each 
!    cloud, the amount of the cloud which is liquid, its optical depth 
!    and an indicator as to whether it is ice or liquid (a different 
!    criterion than is used for the liquid fraction determination).
!----------------------------------------------------------------------
 
integer,                     intent(in)             ::  is,js
real,    dimension (:,:,:),  intent(in)             ::  press, pflux 
real,    dimension(:,:),     intent(in)             ::  lat
type(time_type),             intent(in)             ::  time
integer, dimension(:,:),     intent(inout)          ::  nclds
integer, dimension(:,:,:),   intent(out)            ::  cldtop,cldbas
real,    dimension(:,:,:),   intent(out)            ::  cldamt, liq_frac
real,    dimension(:,:,:,:), intent(out)            ::  tau
logical, dimension(:,:,:),   intent(out)            ::  ice_cloud
integer, dimension(:,:),     intent(in), optional   ::  kbot

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,js             starting subdomain i,j indices of data 
!                        in the physics_window being integrated
!      press             pressure at model levels (1:nlev), surface    
!                        pressure is stored at index value nlev+1   
!                        [ (kg /( m s^2) ]
!      pflux             average of pressure at adjacent model levels  
!                        [ (kg /( m s^2) ]
!      lat               latitude of model points  [ radians ]
!      time              time at which radiation calculation is to apply
!                        [ time_type (days, seconds) ]
!
!   intent(inout) variables:
!
!      nclds             total number of clouds in each grid column
!
!   intent(out) variables:
!
!      cldtop            k index of cloud top for each cloud
!      cldbas            k index of cloud base for each cloud
!      cldamt            fractional cloudiness for each cloud
!                        [ dimensionless ]
!      liq_frac          fraction of cloud which is liquid 
!                        [ dimensionless ]
!      tau               cloud optical depth  [ dimensionless ]
!      ice_cloud         logical flag indicating whether cloud is liquid
!                        or ice
!
!    intent(in), optional variables:
!
!      kbot              present when running eta vertical coordinate,
!                        index of lowest model level above ground
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer, dimension (size(press,1), size(press,2)) :: &
                                    lhight, lhighb, lmidt, lmidb, llowt

      integer,  dimension (size(press,1), size(press,2),  &
                                          size(press,3)-1)  :: icld

      real,  dimension (size(press,1), size(press,2),   &
                                       size(press,3)-1)  :: &
                         temp, qmix, rhum, omega, lgscldelq, cnvcntq, &
                 delp, tempcld, delp_true, pfull

      real, dimension (size(press,1), size(press,2)) ::  convprc, psfc

      real,  dimension(size(press,1), size(press,2),  &
                       size(press,3))  ::  phalf

      integer     :: kx, lk, ierr, max_cld
      integer     :: i, j, n
      
!---------------------------------------------------------------------
!   local variables:
!
!       lhight     vertical level index upper limit for high cloud tops
!                  a function of lat and lon
!       lhighb     vertical level index lower limit for high cloud bases
!                  a function of lat and lon
!       lmidt      vertical level index upper limit for mid cloud tops
!                  a function of lat and lon
!       lmidb      vertical level index lower limit for mid cloud bases
!                  a function of lat and lon
!       llowt      vertical level index upper limit for low cloud tops
!                  a function of ltt and lon
!       icld       marker array of cloud types/heights (at cloud levels)
!       temp       temperature at full model levels [ deg K ]
!       qmix       mixing ratio at full model levels [ kg H2O / kg air ]
!       rhum       relative humidity fraction at full model levels
!                  [ dimensionless ]
!       omega      pressure vertical velocity at full model levels
!                  [ mb / sec ??????? ]
!       lgscldelq  averaged rate of change in mixing ratio due to large 
!                  scale precip at full model levels  
!       cnvcntq    accumulated count of change in mixing ratio due to 
!                  convective  precip at full model levels  
!       delp       pressure thickness of model layers [ kg / (m s^2) ]
!       tempcld    cloud layer mean temperature, at cloud levels
!                  [ deg K ]
!       delp_true  true cloud pressure thickness of distinct cloud 
!                  layers (at cloud levels) [ kg / (m s^2) ]
!       pfull      pressure at full levels [ kg / (m s^2) ]
!       convprc    accumulated conv precip rate summed over all
!                  full model levels [ mm/day ]
!       psfc       surface pressure field [ kg / (m s^2) ]
!       phalf      pressure at model half levels [ kg / (m s^2) ]


!       kx         number of model layers
!       lk         vertical level below which no low cloud bases can 
!                  exist
!       ierr       error flag
!       max_cld    max number of clouds in any column in the current
!                  physics window
!       i,j,n    do loop indices
!
!--------------------------------------------------------------------- 

!----------------------------------------------------------------------
!    define the number of model layers.
!----------------------------------------------------------------------
      kx   = size(press,3) - 1

!---------------------------------------------------------------------
!    define the needed pressure arrays. 
!---------------------------------------------------------------------
      pfull(:,:,:) = press(:,:,1:kx)
      phalf(:,:,:) = pflux(:,:,:)
      psfc(:,:)    = press(:,:,kx+1)

!--------------------------------------------------------------------
!    call diag_cloud_avg to obtain the appropriate values for the input 
!    arrays needed to define the cloud locations and amounts. these may
!    or may not be time-averaged values.
!---------------------------------------------------------------------
      call diag_cloud_avg (is, js, temp, qmix, rhum, omega, lgscldelq, &
                           cnvcntq, convprc, ierr)

!----------------------------------------------------------------------
!    initialize the output fields produced by this module.
!---------------------------------------------------------------------
      tau = 0.
      liq_frac = 0.
      cldamt = 0.
      cldtop = 0
      cldbas = 0
      ice_cloud = .false.

!----------------------------------------------------------------------
!    if input data was appropriately returned from diag_cloud_avg,
!    proceed with the determination of the cloud field.
!---------------------------------------------------------------------
      if (ierr == 0) then

!---------------------------------------------------------------------
!    define the lowest model level which can be a cloud base. it is 
!    either the lowest model level, or a level determined from namelist
!    input.
!---------------------------------------------------------------------
        if (nofog) then
          lk = low_lev_cloud_index
        else
          lk = kx
        endif

!--------------------------------------------------------------------
!    call cldtim to drive the cloud prediction scheme.
!--------------------------------------------------------------------
        call cldtim (temp, qmix, rhum, omega, lgscldelq, cnvcntq,   &
                     convprc, pfull, phalf, psfc, lat, time, tempcld, &
                     delp_true, cldtop, cldbas, cldamt, lhight, lhighb,&
                     lmidt, lmidb, llowt, icld, nclds, kbot)

!---------------------------------------------------------------------
!    determine the maximum number of clouds in any of the columns in the
!    physics window.
!---------------------------------------------------------------------
        max_cld  = MAXVAL(nclds(:,:))

!--------------------------------------------------------------------
!    if cloud is present anywhere in the window, call 
!    cloud_pres_thick_for_tau to determine the cloud thicknesses and
!    the call cloud_optical_depths2 to determine the optical depths and
!    liquid fraction of each cloud.
!---------------------------------------------------------------------
        if (max_cld > 0) then
          call cloud_pres_thick_for_tau (nclds, icld, cldtop, cldbas, &
                                         delp_true, lhight, lhighb,  &
                                         lmidt, lmidb, llowt, lk, delp,&
                                         phalf, psfc)
          call cloud_optical_depths2 (nclds, icld, cldtop, cldbas,  & 
                                      tempcld, delp, tau, phalf, &
                                      liq_frac)
        endif

!---------------------------------------------------------------------
!    determine whether the cloud temperature will support a liquid or
!    an ice cloud. the parameter t_cold is the cutoff temperature value.
!---------------------------------------------------------------------
        do j= 1,size(press,2)
          do i=1,size(press,1)
            do n=1,nclds(i,j)
              if (tempcld(i,j,n) < t_cold) then
                ice_cloud(i,j,n) = .true.
              endif
            end do
          end do
        end do

!----------------------------------------------------------------------
!    if input data was not acceptably returned from diag_cloud_avg,
!    determine if this represents an error, or is just a manifestation
!    of coldstart behavior. if this is coldstart step, set clouds to
!    zero and continue.
!---------------------------------------------------------------------
      else
        if (num_pts >= tot_pts) then
          call error_mesg ('diag_cloud_mod',  &
             ' no diag cloud data available; ierr /= 0', FATAL)
        else
          num_pts = num_pts + size(press,1)*size(press,2)
          nclds = 0
        endif
      endif ! (ierr=0)


!--------------------------------------------------------------------




end subroutine diag_cloud_driver2



!---------------------------------------------------------------------



!##################################################################      

 SUBROUTINE CLDTIM (temp,qmix,rhum, omega,lgscldelq,cnvcntq,convprc,  &
                    pfull, phalf,psfc, lat, time, tempcld,delp_true, &
                    cldtop,cldbas,cldamt,                              &
                    lhight,lhighb, lmidt, lmidb, llowt,icld,nclds,kbot)

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)


 type(time_type), intent(in)  :: time
 real, intent(in)  :: lat(:,:)
 real, intent(in), dimension (:,:,:) ::  temp,qmix,rhum,omega
 real, intent(in), dimension (:,:,:) ::  lgscldelq,cnvcntq,pfull, phalf
 real, intent(in), dimension (:,:) ::    convprc,psfc

!
!      INPUT
!      -----
!
!      TEMP     Temperature (Deg K) at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      QMIX     Mixing Ratio at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      RHUM     Relative humidity fraction at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      OMEGA  Pressure vertical velocity at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      LGSCLDELQ  Averaged rate of change in mix ratio due to lg scale precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      CNVCNTQ  Accumulated count of change in mix ratio due to conv precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      CONVPRC Accumulated conv precip rate summed over all
!               full model levels (mm/day )
!               (dimensioned IDIM x JDIM)
!      PFULL    Pressure at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!      PSFC     Surface pressure field
!                   (dimensioned IDIM x JDIM)
!      TIME       time of year (time_type)
!      LAT        latitudes in radians, dimensioned by (IDIMxJDIM)   
!      KBOT    -  OPTIONAL; lowest model level index array
!                   (dimensioned IDIM x JDIM)
!===================================================================
! Arguments (intent out)

integer, intent(out), dimension(:,:,:) :: cldtop,cldbas,icld
integer, intent(out), dimension(:,:)  :: nclds
integer, intent(out), dimension(:,:)  :: lhight,lhighb, lmidt, lmidb, llowt
   real, intent(out), dimension(:,:,:) :: cldamt
   real, intent(out), dimension(:,:,:) :: tempcld,delp_true


integer, intent(in), OPTIONAL, dimension(:,:) :: kbot


!      OUTPUT
!      ------

!      ICLD          marker array of cloud types (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDTOP     index of cloud tops (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDBAS     index of cloud bottoms (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDAMT   cloud amount (fraction) (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      TEMPCLD    cloud layer mean temperature (degrees Kelvin)
!                    (at cloud levels)
!      DELP_TRUE  true cloud pressure thickness of distinct cloud layers 
!                    (at cloud levels)
!      R_UV    fractional amount of ultraviolet radiation
!                     reflected by the clouds
!      R_NIRfractional amount of near inrared radiation
!                     reflected by the clouds
!      AB_UVfractional amount of ultraviolet radiation
!                     absorbed by the clouds
!      AB_NIRfractional amount of near inrared radiation
!                     absorbed by the clouds
!      EM_LWemissivity for the clouds
!       NCLDS        number of (random overlapping) clouds in column and also
!                        the current # for clouds to be operating on
!       LHIGHT        vertical level index upper limit for high cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LHIGHB        vertical level index lower limit for high cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDT         vertical level index upper limit for mid cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDB         vertical level index lower limit for mid cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LLOWT         vertical level index upper limit for low cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!
!  note:  vertical level below which no low cloud bases can exist is
!         calculated in routines where needed using namelist inputs 
!         low_lev_cloud_index and nofog

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


!=======================================================================
!  (Intent local)
 real , dimension(size(rhum,1),size(rhum,2),size(rhum,3)) :: theta
 real , dimension(size(rhum,1),size(rhum,2),size(rhum,3)) :: rhumcnv, &
      camtcnv,camtrh,camtw,camtsh,camtsc,camt
 real, dimension (size(rhum,1),size(rhum,2)) :: camtsh_mx 
 real, dimension (size(phalf,1),size(phalf,2),size(phalf,3)) :: pnorm
 integer , dimension(size(rhum,1),size(rhum,2),size(rhum,3)) :: icld_k
 integer , dimension(size(rhum,1),size(rhum,2),3) ::  kthclm, kbhclm
 integer, dimension (size(rhum,1),size(rhum,2)) :: kmaxshl,kminshl
! horizontal dimensions
 integer idim,jdim
! bottom level vertical index
 integer kx 
! loop index
 integer k 

!-----------------------------------------------------------------------
!      THETA    Potential temperature 
!               at full model levels (Deg K) )
!               (dimensioned IDIM x JDIM x kx)
!      THETA_E  Equivalent potential temperature 
!               at full model levels (Deg K) )
!               (dimensioned IDIM x JDIM x kx)
!      RHUMCNV  Relative humidity fraction modified for convective clouds
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTCNV  tentative deep convective cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTRH   tentative rel. humidity cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTW    tentative cloud amounts omega corrected clouds 
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTSH   tentative shallow convective cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTSC   tentativemarine stratus cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTSL   tentative Slingo marine stratus cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTTL   tentative Tim Li marine stratus cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTSH_MX maximum value of shallow convective cloud amount within
!                  shallow convective layer. (dimensioned IDIM x JDIM)
!      CAMT     tentative merged cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      PNORM    Normalized pressure at half or full  model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!      ICLD_K     tentative merged cloud marker array  
!                   (dimensioned IDIM x JDIM x kx)
!      KTHCLM,KBHCLM gcm vert coord indices of climo high, mid, low cloud   
!                   tops and bases, (dimensioned IDIM x JDIM x 3)
!      KMINSHL,KMAXSHL indices of vertical levels corresponding to 
!                   final top and base of shallow convective cloud layer
!                   (dimensioned IDIM x JDIM)

!-----------------------------------------------------------------------
! Calculate gcm vetical coord. indices for high, mid and low clouds based
! on observed  mean climatology. They will be a function of latitude and 
! time of year.  Optionally, climatological zonal mean cloud amounts may
! also be returned, presumably for a special "cold" start situation.

! ***** caveats: the current climo cloud setup uses climo average pressure 
! *****          values for locating single layer high and middle clouds
! *****          and the bottom and top of climo average low clouds
! *****          in the future a better approach to locating a vertical
! *****          layer range for each type of cloud will be needed

! *****          camt from getcld is only used to complete the argument list

! need to normalize pressures since table is based on assumption that 
! surface pressure = 101325 Pa


      idim = size(rhum,1)
      jdim = size(rhum,2)
      kx = size(rhum,3)

! for clouds at half levels
!         do k=1,kx+1
!            pnorm(:,:,k)=101325.*phalf(:,:,k)/phalf(:,:,kx+1)
!         enddo
! call getcld (time, lat, phalf, kthclm, kbhclm, camt)

! for clouds at full levels
         do k=1,kx
            pnorm(:,:,k)=101325.*pfull(:,:,k)/phalf(:,:,kx+1)
         enddo
         pnorm(:,:,kx+1) = 101325.
! call getcld (time, lat, pfull, kthclm, kbhclm, camt)
call getcld (time, lat, pnorm, kthclm, kbhclm, camt)

!  re-initialize camt, icld_k, nclds, cldbas,cldtop
      camt(:,:,:) = 0.0
      icld_k(:,:,:) = 0
      cldbas(:,:,:) = 0
      cldtop(:,:,:) = 0
      nclds(:,:) = 0

      lhight(:,:) = high_lev_cloud_index
      lhighb(:,:) = kthclm(:,:,2) - 1
      lmidt(:,:) = kthclm(:,:,2) 
!  if climo mid cloud top level = climo high cloud base level, reset high base 
      where (kthclm(:,:,2) .eq. kbhclm(:,:,1))
         lhighb(:,:) = kbhclm(:,:,1)
         lmidt(:,:) = kbhclm(:,:,1) + 1
      endwhere
      lmidb(:,:) = kthclm(:,:,3) - 1
      llowt(:,:) = kthclm(:,:,3) 
!  if climo low cloud top level = climo mid cloud base level, reset mid base 
      where (kthclm(:,:,3) .eq. kbhclm(:,:,2))
         lmidb(:,:) = kbhclm(:,:,2)
         llowt(:,:) = kbhclm(:,:,2) + 1
      endwhere
         
!      print *, ' climatological cloud tops & bases'
!      print *, ' kthclm = ', kthclm
!      print *, ' kbhclm = ', kbhclm

 
!-----------------------------------------------------------------------
!  calculate potential temperature for use in computing marine stratus and/or 
!  shallow convective clouds

      if (linvers .or. l_theqv) then
        theta(:,:,:) = temp(:,:,:)*(p00/pfull(:,:,:)**Kappa)
      endif

!  calculate deep convective clouds
          if (lcnvcld) then
call cloud_cnv (rhum,cnvcntq,convprc, pfull, phalf, camtcnv, rhumcnv )
          endif

!  calculate rel humidity clouds
          if (lrhcnv .and. lcnvcld) then
call cloud_rhum (rhumcnv, pnorm, camtrh)
          else
call cloud_rhum (rhum, pnorm, camtrh)
          endif

!  calculate omega corrected rel humidity clouds
          if (lomega) then
call cloud_omga (camtrh, omega, llowt, camtw)
          endif


!  calculate marine stratus clouds
! ******* not implemented at this time *******
          if (linvers) then
!!!  call cloud_m_stratus (...,camtsc )
          endif

      kx = size(rhum,3)
!  calculate shallow convective clouds
          if (l_theqv) then
!  need to call shallow_conv_init to set up constants for mylcl
call cloud_shallow_conv (theta,omega,pfull,phalf,temp,qmix,camtrh, &
                    camtsh,camtsh_mx,kminshl,kmaxshl,kbot)
          endif

!  merge stratiform cloud types
call merge_strat_clouds (camtrh,camtw,camtsc,llowt,camt,icld_k)


!  group clouds into high, middle and low
call def_hi_mid_low (phalf,lhight,lhighb,lmidt,lmidb,llowt,camt,icld_k)


!  merge convective cloud types
          if (lcnvcld .or. l_theqv) then
call merge_cnv_clouds (camtcnv,camtsh,camtsh_mx,kminshl,kmaxshl, &
                        lhight,lhighb,lmidt,lmidb,llowt,camt,icld_k)
          endif

!  calculate vertical indices and tot number of distinct cloud layers
!  as a  function of lat and longitude.
call layr_top_base (icld_k,nclds,cldtop,cldbas,icld)

!  calculate vertical, mass weighted cloud amount fraction of distinct cloud
!  layers
call cldamt_mn (nclds,cldtop,cldbas,phalf,camt,cldamt)

!  compute total cloud amount from cloud amount of in distinct cloud layers
! ***** this diagnostice routine is postpooned for now *******
! call total_cld_amt()

!  Define the occurence of anvil cirrus clouds
call anvil_cirrus (lhighb,lmidb,nclds,cldtop,cldbas,cnvcntq,lgscldelq, &
                    pfull,phalf,icld)

!  Compute the mass weighted mean cloud temperature and pressure thickness
!  of each distinct cloud layer
call cld_layr_mn_temp_delp (nclds,cldtop,cldbas,temp,phalf,tempcld,delp_true)

!  Compute the cum mean water vapor mixing ratio of each distinct cloud layer
!  (This is proposed for the future)
!  call cld_lay_cum_qmix()


!-----------------------------------------------------------------------

end subroutine CLDTIM
!=======================================================================

!#############################################################################      
 
subroutine CLOUD_CNV (rhum,cnvcntq,convprc, pfull, phalf, camtcnv, rhumcnv )
                                  


!-------------------------------------------------------------------
!  This subroutine calculates deep convective cloud amounts
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

!-------------------------------------------------------------------
! Namelist variables used in this routine (defined at top of module)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  parameters used in cloud_cnv

 real,  parameter :: beta = .125, cprc_thres = 0.14 
 real,  parameter :: cmax = 0.8, ctower = 0.25
 real,  parameter :: cnvdelqmn = 0.0

!      BETA -       convective cloud regression coefficients
!      CPRC_THRES - minimum convective precip amount imposed for
!                   for work array.  This allows the use of the log
!                   function in the convective cloud regression relation.
!      CMAX, CTOWER - factors limiting convective cloud amount
!                           and vertical profile
!      CNVDELQMN - min threshold value of accumulated count of mixing ratio 
!                  change due to convection above which convective clouds are 
!                  allowed
!                  ( It is set = 0.0 as a parameter, because it not anticipated
!                    that it would be changed.)
!-------------------------------------------------------------------

 real, intent(in), dimension (:,:,:) :: rhum, cnvcntq, pfull, phalf
 real, intent(in), dimension (:,:) :: convprc

!-------------------------------------------------------------------
!      RHUM     Relative humidity fraction at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      CNVCNTQ  Accumulated count of change in mix ratio due to conv precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      convprc Accumulated conv precip rate summed over all
!               full model levels (mm/day )
!               (dimensioned IDIM x JDIM)
!      PFULL    Pressure at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!===================================================================
! Arguments (intent out)
 real, intent(out), dimension (:,:,:) :: camtcnv, rhumcnv
!     CAMTCNV - convective cloud amount at full model levels 
!               (dimensioned IDIM x JDIM x kx)
!     RHUMCNV - relative humidity adjusted for convective clouds
!=======================================================================
!  (Intent local)

 real, dimension (size(rhum,1),size(rhum,2),size(rhum,3)) :: delp
 real, dimension (size(rhum,1),size(rhum,2)) :: wrkcprc

!      DELP       pressure thickness of model layers 
!                   (dimensioned IDIM x JDIM x kx)
!      DCPRC - weighted convective precip as a function of vertical layer
!                   (dimensioned IDIM x JDIM x kx)
!      WRKCPRC - convective precip work array
!                   (dimensioned IDIM x JDIM)

 integer i, j, idim, jdim, kx, lk, lkxm1, kcbtop
 real alpha
!-----------------------------------------------------------------------
!  type loop index variable
 integer k 

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

! Initialize convective cloud amount array
      camtcnv = 0.0

!  Define regression coefficient alpha base on coeficient beta, defined
!  above as a parameter
      alpha = -beta*log(cprc_thres)

!-----------------------------------------------------------------------
! <><><><><><><><>   set up vertical index range <><><><><><><><>
!-----------------------------------------------------------------------
      idim  = SIZE(rhum,1)
      jdim  = SIZE(rhum,2)
      kx = size(rhum,3)

!  define lower limit of cloud bottoms
      if (nofog) then
        lk = low_lev_cloud_index
      else
        lk = kx
      endif

!  no convective clouds allowed in lowest layer
      lkxm1 = min(lk,kx-1)  

!  define upper limit of cloud tops
      kcbtop = high_lev_cloud_index


! calculate pressure thickness of model layers, for vertcal averaging
      do k=1,kx
        delp (:,:,k) = phalf(:,:,k+1)-phalf(:,:,k)
      end do
!-----------------------------------------------------------------------
! <><><><><><><><>   code to identify convecting levels <><><><><><><><>
!-----------------------------------------------------------------------

! use total convective precip amount passed in as argument
      wrkcprc(:,:) = convprc(:,:)
!-----------------------------------------------------------------------
! <><><><><><><><>   code to compute conv cloud fraction <><><><><><><><>
!-----------------------------------------------------------------------

      do k=kcbtop,lkxm1
! check that accumulated count of convective mix ratio changes is greater
! than a minimum threshold (usually 0 )
        where (cnvcntq (:,:,k) > cnvdelqmn .and. wrkcprc(:,:) > cprc_thres)
          camtcnv(:,:,k) = alpha + beta * log(wrkcprc(:,:) )
        end where
      end do

! Impose contraints on convective cloud

      camtcnv(:,:,:) = min(camtcnv(:,:,:),cmax)


              do k=kcbtop,lkxm1
            do j=1,jdim
            do i=1,idim
      if (camtcnv(i,j,k) .lt. 0.0) then
         print *, ' pe,i,j,k,camtcnv = ', mpp_pe(),i,j,k,  &
                    camtcnv(i,j,k)
         call error_mesg ('cloud_cnv','cloud amount < 0' ,FATAL) 
      endif
            end do
            end do
              end do

      where (camtcnv(:,:,:) > 0.0 .and. pfull(:,:,:) < pshallow)
        camtcnv(:,:,:) = ctower * camtcnv(:,:,:) 
      endwhere

! calculate relative humidity adjusted for convective clouds

       rhumcnv (:,:,:) = (1.0 - camtcnv(:,:,:)) * rhum(:,:,:) 


!-----------------------------------------------------------------------

end subroutine CLOUD_CNV

!#############################################################################      

subroutine CLOUD_RHUM (rhum,pnorm, camtrh)
                                  


!-------------------------------------------------------------------
!  calculates stratiform cloud amounts based on relative humidities
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!-------------------------------------------------------------------

real, intent(in), dimension (:,:,:) :: rhum,pnorm

!-------------------------------------------------------------------
!      RHUM     Relative humidity fraction at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PNORM    Normalized pressure at half or full  model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!===================================================================

! Arguments (intent out)
 real, intent(out), dimension (:,:,:) :: camtrh
!     CAMTRH - Rel Humidity cloud amount at full model levels 
!               (dimensioned IDIM x JDIM x kx)
!=======================================================================
!  (Intent local)
 real, dimension (size(rhum,1),size(rhum,2)) :: rhc_work
! real, dimension (size(rhum,1),size(rhum,2),size(rhum,3)) :: rhum2      
 integer kx, lk, npower
!-----------------------------------------------------------------------
!  type loop index variable
 integer k,kk

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

      kx = size(rhum,3)


!  define cloud amt - rel hum relation as linear or quadratic

      if (lquadra) then
        npower = 2
      else
        npower = 1
      endif


!    if (mpp_pe() == 0) then
!      print *, 'npower', npower
!    endif

!  define lower limit rel hum clouds
      if (nofog) then
        lk = low_lev_cloud_index 
      else
        lk = kx
      endif

! Initialize rhum cloud amount array
     camtrh = 0.0
!
!-----------------------------------------------------------------------
! <><><><><><><><>   code to compute rhum cloud fraction <><><><><><><><>
!-----------------------------------------------------------------------

      do k=high_lev_cloud_index,lk
        where (pnorm(:,:,k) .ge. pbounds(nrhc-1))
              rhc_work(:,:) = rhc(nrhc)
        end where
      do kk=nrhc-1,2
        where ((pnorm(:,:,k).lt.pbounds(kk)) .and. &
               (pnorm(:,:,k).ge.pbounds(kk-1)))
              rhc_work(:,:) = rhc(kk)
        end where
      end do
        where (pnorm(:,:,k).lt.pbounds(1)) 
              rhc_work(:,:) = rhc(1)
        end where
!BUGFIX ??
!       where (rhum(:,:,k) == rhc_work(:,:))
!    rhum2(:,:,k) = rhum(:,:,k) - 0.00007
!elsewhere
!    rhum2(:,:,k) = rhum(:,:,k)
!       endwhere
        where (rhum (:,:,k) > rhc_work(:,:))
          camtrh(:,:,k) = min(1.0, (  &
           (rhum (:,:,k) - rhc_work(:,:))/(1-rhc_work(:,:)) )** npower)
        elsewhere
          camtrh(:,:,k) = 0.0
        end where
      end do


end subroutine CLOUD_RHUM

!#############################################################################      

subroutine CLOUD_OMGA (camtrh, omega, llowt, camtw)
                                  


!-------------------------------------------------------------------
!  calculates omega corrected cloud amounts
!  This subroutine reduces rel hum clouds in regions of decending motion
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!     WCUT0 - omega cutoff value for omega cloud depletion factor = 0
!     WCUT1 - omega cutoff value for omega cloud depletion factor = 1
!-----------------------------------------------------------------------

 real, intent(in), dimension (:,:,:) :: camtrh, omega
 integer, intent(in), dimension (:,:) :: llowt

!-----------------------------------------------------------------------
!      CAMTRH   tentative rel. humidity cloud amounts 
!                   (dimensioned IDIM x JDIM x kx)
!      OMEGA  Pressure vertical velocity at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      LLOWT    vertical level index upper limit for low cloud tops
!               a function of lon and latitude (dimensioned IDIMxJDIM)
!-----------------------------------------------------------------------

!===================================================================
! Arguments (intent out)
 real, intent(out), dimension (:,:,:) :: camtw
!     CAMTW - omega cloud amount at full model levels 
!               (dimensioned IDIM x JDIM x kx)
!=======================================================================

!  (Intent local)
!-----------------------------------------------------------------------
!  type loop limits 
integer kx, lk, idim, jdim
integer low_top
!-----------------------------------------------------------------------
!  type loop index variables
integer i,j, k 

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

      kx = size(camtrh,3)
      jdim = size(camtrh,2)
      idim = size(camtrh,1)

! Initialize omega cloud amount array
     camtw = 0.0

!  define lower limit for calculating omega corrected clouds
      if (nofog) then
        lk = low_lev_cloud_index 
      else
        lk = kx
      endif

!  llowt is used to define an upper bound for calculating omega corrected 
!  clouds, i.e., estimate of highest level of a low cloud top

!-----------------------------------------------------------------------
!===================================================================

!-----------------------------------------------------------------------
! <><><><><><><>   code to compute omega corrected cloud fraction <><><>
!-----------------------------------------------------------------------
     
      do j=1,jdim
      do i=1,idim
        low_top = llowt(i,j)
        do k=low_top,lk
!  For regions of upward motion (or zero) set = rhum clouds
          if (omega (i,j,k) .le. wcut1 ) then
            camtw(i,j,k) = camtrh(i,j,k)
          endif
!  For regions of descending motion reduce clouds linearly to 0 where
!  descent = 3.6mb/hr = .1 n m-2 s-1
          if (omega (i,j,k) .gt. wcut1 .and. omega (i,j,k) .lt. wcut0 ) then
            camtw(i,j,k) = camtrh(i,j,k)*(omega(i,j,k) - wcut0)/(wcut1-wcut0)
          endif
!  For regions of descent >= 3.6mb/hr set to 0 
          if (omega (i,j,k) .ge. wcut0 ) then
            camtw(i,j,k) = 0.0
          endif
        end do
        end do
      end do
!-----------------------------------------------------------------------

end subroutine CLOUD_OMGA


!#############################################################################      
 
subroutine CLOUD_SHALLOW_CONV (theta,omega,pfull,phalf,temp,qmix,camtrh, &
                    camtsh,camtsh_mx,kminshl,kmaxshl,kbot)
                                  

!-------------------------------------------------------------------
!  This subroutine calculates shallow convective cloud amounts
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     PSHALLOW - top of shallow convective layer (pressure level - n/m**2 )
!     L_THEQV - logical switch for turning on calculation of shallow convective 
!              clouds - true for shallow convective clouds, otherwise false 
!     WCUT1 - omega cutoff value for omega cloud depletion factor = 1
!     LOMEGA - logical switch for turning on omega correction to rhum 
!              clouds - true for omega correction, otherwise false 
!     LINVERS - logical switch for turning on calculation of marine stratus 
!              clouds - true for marine stratus, otherwise false 
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!-------------------------------------------------------------------
!  parameters used in cloud_shallow_conv

 real,  parameter :: twcfac = 0.2, crtcons = 0.0

!      TWCFAC - scaling factor for computing shallow conv cloud amt (= 0.2)
!      CRTCONS - crit value of d(Theta_e)/dP (= 0.0)


 real, intent(in), dimension (:,:,:) :: &
           theta,omega,pfull,phalf,temp,qmix,camtrh

 integer, intent(in), OPTIONAL, dimension(:,:) :: kbot

!     THETA     Potential temperature at full model levels ( Deg K )
!               (dimensioned IDIM x JDIM x kx)
!      OMEGA  Pressure vertical velocity at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PFULL    Pressure at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!      TEMP     Temperature (Deg K) at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      QMIX     Mixing Ratio at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTRH   tentative rel. humidity cloud amounts 
!                   (dimensioned IDIM x JDIM x kx)
!      KBOT      OPTIONAL; lowest model level index array
!                   (dimensioned IDIM x JDIM)
!===================================================================
! Arguments (intent out)

 real, intent(out), dimension (:,:,:) :: camtsh
 real, intent(out), dimension (:,:) :: camtsh_mx
 integer, intent(out), dimension (:,:) :: kminshl, kmaxshl

!     CAMTSH - shallow convective cloud amount at full model levels 
!               (dimensioned IDIM x JDIM x kx)
!     CAMTSH_MX  maximum value of shallow convective cloud amount within
!                  shallow convective layer. (dimensioned IDIM x JDIM)
!     KMINSHL,KMAXSHL indices of vertical levels corresponding to 
!                   final top and base of shallow convective cloud layer
!                   (dimensioned IDIM x JDIM)
!=======================================================================
!  (Intent local)

 real,    dimension(size(temp,1),size(temp,2),size(temp,3)) :: &
                   qsat,dcldnrm,theta_e,dtheta_e
 real,    dimension (size(temp,1),size(temp,2)) :: plcl
 integer, dimension (size(temp,1),size(temp,2)) :: ksiglcl,kshallow


!      QSAT - saturation vapor pressure
!                   (dimensioned IDIM x JDIM x KX)
!      PLCL - pressure of the lifting condensation level (LCL)
!                   (dimensioned IDIM x JDIM)
!      KSIGLCL - index of nearest vertical level to the LCL
!                   (dimensioned IDIM x JDIM)
!      DCLDNRM - normalization factor
!                   (dimensioned IDIM x JDIM x KX)
!      THETA_E  Equivalent potential temperature at full model levels ( Deg K )
!               (dimensioned IDIM x JDIM x kx)
!      DTHETA_E - vertical (p) derivative of theta_e
!                   (dimensioned IDIM x JDIM x KX)

! define 2-D work arrays
 real,    dimension(size(temp,1),size(temp,2)) ::  xy1, xy2, xy3

!-----------------------------------------------------------------------
!  type local variables
 integer i, j, k, kmin, kmax, kmin0, kmax0, idim, jdim,lk, lkxm1, kx, &
         kcbtop, kcount, knt_shl

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

  idim  = SIZE(Temp,1)
  jdim  = SIZE(Temp,2)
  kx  = SIZE(Temp,3)

 
!  define lower limit of cloud bottom
      if (nofog) then
        lk = low_lev_cloud_index
      else
        lk = kx
      endif

!  no convective clouds allowed in lowest layer
      lkxm1 = min(lk,kx-1) 

!  define upper limit of cloud tops
      kcbtop = high_lev_cloud_index

!  find index of vertical level closest to but not above the 
!  shallow convective lid (pshallow) 
     
      kshallow = 99999
      do k = kx,1,-1
        where (pfull(:,:,k) .ge. pshallow) 
           kshallow(:,:) = k
        end where
      end do

      
! Initialize shallow convective cloud amount and other related arrays
      camtsh = 0.0
      camtsh_mx = 0.0
      dcldnrm = 0.0

! calculate lcl 

! --- saturation mixing ratio 
     call compute_qs (Temp, pfull, qsat)

!  calculate equivalent potential temperature 
     
     theta_e(:,:,:) = theta(:,:,:)*exp(HLv*qmix(:,:,:)/    &
                      (Cp_Air*temp(:,:,:)))
 

!=======================================================================
! --- CALCULATE THE LIFTING CONDENSATION LEVEL, IE CLOUB BASE
!=======================================================================

! The optional argument array kbot allows for use of discontinuous vertical 
! coordinate systems. However, if the kbot index value relates to a level
! which is well above the local surface, the resulting lcl may not be 
! physically correct.

      if( PRESENT( kbot ) ) then
        do j=1,jdim
          do i=1,idim   
             k = kbot(i,j)
             xy1(i,j) =      Temp(i,j,k)
             xy2(i,j) =  MIN(MAX( qmix(i,j,k), 1.0e-6), qsat(i,j,k) )
             xy3(i,j) =     pfull(i,j,k)
          end do
        end do
      else
             xy1(:,:) =      Temp(:,:,kx)
             xy2(:,:) = MIN(MAX( qmix(:,:,kx), 1.0e-6), qsat(:,:,kx) )
             xy3(:,:) =     pfull(:,:,kx)
      end if

 

      CALL MYLCL( xy1, xy2, xy3, phalf, plcl, ksiglcl )


!=======================================================================
! --- Calculate d(theta_e)/dp
!=======================================================================

!  set dtheta_e = 0 at the first level 
      dtheta_e(:,:,1) = 0.0

      do k=2,kx-1
        dtheta_e(:,:,k) = &
       0.5*(theta_e(:,:,k+1)-theta_e(:,:,k))/(pfull(:,:,k+1)-pfull(:,:,k)) + &
       0.5*(theta_e(:,:,k)-theta_e(:,:,k-1))/(pfull(:,:,k)-pfull(:,:,k-1))
      end do

!  set dtheta_e at bottom level = detheta_e at next level up
!  (note:  bottom level value is not used in current scheme) 
      dtheta_e(:,:,kx) = dtheta_e(:,:,kx-1)


!=======================================================================
! --- Shallow Convective Cloud Calculation
!=======================================================================

      kmaxshl(:,:) = min(lkxm1,ksiglcl(:,:))
!  tentatively set kminshl to kshallow
      kminshl(:,:) = kshallow(:,:)
        
      do k = lkxm1,kcbtop,-1
        where (((k.ge.kshallow(:,:)) .and. (k.le.kmaxshl(:,:))) &
         .and. (dtheta_e(:,:,k).ge.crtcons )  &
         .and. (pfull(:,:,k) .le. plcl(:,:) ) )
           dcldnrm(:,:,k) = twcfac
        end where
      end do

!  Apply constraint that the shallow convective layer is confined to the
! lowest contigous layer between plcl and pshallow
     do j=1,jdim
       do i=1,idim
! no shallow conv clouds allowed in regions where lowest full P level
! is above the specified shallow convective lid
                   if (kshallow(i,j) .le. kx) then
         kmax=kmaxshl(i,j) 
         kmin=kshallow(i,j)
         kcount = 0
         knt_shl = 0
         do k = kmax,kmin,-1
             if (pfull(i,j,k) .le. plcl(i,j) ) then
               if (dcldnrm(i,j,k).eq.0.0 .and. knt_shl.ge.1) then
                 dcldnrm(i,j,k-1) = 0.0
                 kcount = kcount + 1
!  kminshl calculation is completed here
                 if (kcount .eq. 1) then
                   kminshl(i,j) = k
                 endif
               else
                 if (dcldnrm(i,j,k) .gt. 0.0) knt_shl = knt_shl + 1
               endif
             endif
         end do  
                   else
         dcldnrm(i,j,:) = 0.0
                   endif
       end do  
      end do  

!  calculate cloud amounts
      do k = lkxm1,kcbtop,-1
        where ((k.ge.kminshl(:,:)) .and. (k .le.kmaxshl(:,:)) &
         .and. dcldnrm(:,:,k).gt.0.0 .and. (omega(:,:,k).gt.wcut1) )
          camtsh(:,:,k) = dcldnrm(:,:,k)*camtrh(:,:,k)
          camtsh_mx (:,:) = max(camtsh_mx (:,:),camtsh (:,:,k) )      
        end where
      end do
!  impose maximum cloud overlap within the contiguous shallow convective 
!  cloud layer. Also check that an rhum cloud exists and that the condition
!  on vertical motion is satisfied
      do k = lkxm1,kcbtop,-1
        where ((k.ge.kminshl(:,:)) .and. (k .le.kmaxshl(:,:)) &
         .and. dcldnrm(:,:,k).gt.0.0 .and. (camtrh(:,:,k).gt.0.0) &
         .and. (omega(:,:,k).gt.wcut1) )
          camtsh(:,:,k) =  camtsh_mx (:,:)
        elsewhere
          camtsh(:,:,k) = 0.0 
        endwhere
      end do
!  redefine kminshl and kmaxshl based on actual shallow conv clouds
        do j=1,jdim
          do i=1,idim
                 if (camtsh_mx(i,j) .gt. 0.0) then

            kmax = kmaxshl(i,j)
            kmax0 = kmaxshl(i,j)
            kmin = kminshl(i,j)
            kmin0 = kminshl(i,j)
! find actual shallow conv cloud base by searching upwards 
            do k=kmax0,kmin0,-1
              if (camtsh(i,j,k) .gt. 0.0) then
                kmax = k
                go to 100
              endif
            end do
100    continue
! find actual shallow conv cloud top by searching downward
            do k=kmin0,kmax
              if (camtsh(i,j,k) .gt. 0.0) then
                kmin = k
                go to 200
              endif
            end do
200    continue
       kmaxshl(i,j) = kmax
       kminshl(i,j) = kmin

                 endif
          end do
        end do


!-----------------------------------------------------------------------

!-----------------------------------------------------------------------

end subroutine CLOUD_SHALLOW_CONV

!#######################################################################

subroutine MERGE_STRAT_CLOUDS (camtrh,camtw,camtsc,llowt,camt,icld_k)



!-------------------------------------------------------------------
!  This subroutine determines a dominant stratiform cloud amount
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     LOMEGA - logical switch for turning on omega correction to rhum 
!              clouds - true for omega correction, otherwise false 
!     LINVERS - logical switch for turning on calculation of marine stratus 
!              clouds - true for marine stratus, otherwise false 
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
 real, intent(in), dimension (:,:,:) ::  camtrh, camtw, camtsc 
 integer, intent(in), dimension (:,:) :: llowt

!      CAMTRH   tentative cloud amounts from stratiform clouds 
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTW    tentative cloud amounts omega corrected clouds 
!                   (dimensioned IDIM x JDIM x kx)
!      CAMTSC   tentativemarine stratus cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!       LLOWT   vertical level index upper limit for low cloud tops
!               a function of lon and latitude (dimensioned IDIMxJDIM)
!===================================================================
! Arguments (intent out)

 real, intent(out), dimension (:,:,:) :: camt
 integer, intent(out), dimension (:,:,:) :: icld_k

!      CAMT     tentative (only stratiform) merged cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      ICLD_K     tentative merged cloud marker array  
!                   (dimensioned IDIM x JDIM x kx)



!=======================================================================
!  (Intent local)
 integer kx, lk, idim, jdim, i, j, k
 integer low_top

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

  idim  = SIZE(camtrh,1)
  jdim  = SIZE(camtrh,2)
  kx  = SIZE(camtrh,3)

!  define lower limit for stratiform clouds
      if (nofog) then
        lk = low_lev_cloud_index 
      else
        lk = kx
      endif


!  Initialize output cloud amounts to rel hum cloud amounts and define
!  cloud type marker values

      camt(:,:,:) = camtrh(:,:,:)
      where ( camtrh(:,:,:) .gt. 0.0)
        icld_k(:,:,:) = 1
      endwhere

!  assign omega corrected cloud amounts
        if (lomega) then
      do j=1,jdim
      do i=1,idim
        low_top =llowt(i,j)
        do k=low_top,lk
          if ( camtw(i,j,k).gt. 0.0) then 
            camt(i,j,k) = camtw(i,j,k)
            if ( camtw(i,j,k) .lt. camtrh(i,j,k) ) then
              icld_k(i,j,k) = 2
            endif
          endif
        end do
      end do
      end do
        endif

!  assign marine stratus cloud amounts
        if (linvers) then
      where ( camtsc(:,:,:) .gt. camt(:,:,:) )
        camt(:,:,:) = camtsc(:,:,:)
        icld_k(:,:,:) = 3
      endwhere
        endif

!-----------------------------------------------------------------------

end subroutine MERGE_STRAT_CLOUDS


!#######################################################################

subroutine DEF_HI_MID_LOW (phalf,lhight,lhighb,lmidt,lmidb,llowt,camt,icld_k)


!-------------------------------------------------------------------
!  This subroutine transforms a vertical profile of stratiform cloud
!  amounts into "high", "middle" and "low" cloud layers 
!  if a "thick" cloud option is in effect the current implementation
!  extends the cloud up one layer (with current tentative cloud amounts)
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     LTHICK_HIGH - logical variable = true -> allow possibility of raising
!               high cloud tops one sigma level to increase their thickness
!               from 1 to 2 sigma levels; otherwise they remain thin 
!               (1 sigma level)
!     LTHICK_MID - logical variable = true -> allow possibility of raising
!               mid cloud tops one sigma level to increase their thickness
!               from 1 to 2 sigma levels; otherwise they remain thin 
!               (1 sigma level)
!     LTHICK_LOW - logical variable = true -> allow possibility of raising
!               low cloud tops one sigma level to increase their thickness
!               from 1 to 2 sigma levels; otherwise they remain thin 
!               (1 sigma level)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
 real, intent(in), dimension (:,:,:) ::  phalf 
 integer,intent(in), dimension(:,:) :: lhight, lhighb, lmidt, lmidb, llowt

!       PHALF         Pressure at half model levels
!                     (dimensioned IDIM x JDIM x kx+1)
!       LHIGHT        vertical level index upper limit for high cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LHIGHB        vertical level index lower limit for high cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDT         vertical level index upper limit for mid cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDB         vertical level index lower limit for mid cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LLOWT         vertical level index upper limit for low cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!
! !===================================================================
! Arguments (intent inout)

 real, intent(inout), dimension (:,:,:) :: camt
 integer, intent(inout), dimension (:,:,:) :: icld_k

!      CAMT     tentative merged cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      ICLD_K     tentative merged cloud marker array  
!                   (dimensioned IDIM x JDIM x kx)

!
!=======================================================================
!  (Intent local)

!  parameter used in def_hi_mid_low

 real,  parameter :: trshld_camt = 0.25
 integer,  parameter :: nmax = 2

!      TRSHLD_CAMT - This is a cloud amount threshold value, used in
!      conjunction with the thick cloud namelist options.  If a thick
!      cloud option is on then the level above the cloud amount max
!      for a particular cloud type is considered to be part of an
!      extended cloud if it is within this fraction of the max cloud amount.
!


  real,    dimension(SIZE(camt,1),SIZE(camt,2),SIZE(camt,3)) :: delp,c_work
  integer, dimension(SIZE(camt,1),SIZE(camt,2),SIZE(camt,3)) :: ic_work
  integer, dimension(1) :: kindex

!      DELP       pressure thickness of model layers 
!                   (dimensioned IDIM x JDIM x kx)
!      C_WORK     cloud amount work array 
!                   (dimensioned IDIM x JDIM x kx)
!      IC_WORK    cloud marker work array 
!                   (dimensioned IDIM x JDIM x kx)
!      NMAX       maximum number of model levels allowed in a thick cloud

       
! loop limits and indices
 integer idim,jdim,kx, lk, i, j, k, kbtm, ktop
!  special setting of max levels for special cases of mid & high thick clouds
 integer nmax_mh
! special threshold value for allowing thick middle and high clouds
! when cloud amounts at contiguous levels are the same value (typically 1.0)
 real trshld_mh

  idim  = SIZE(camt,1)
  jdim  = SIZE(camt,2)
  kx  = SIZE(camt,3)

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

 trshld_mh = .0001
 nmax_mh = kx

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


!  define lower limit for stratiform clouds
      if (nofog) then
        lk = low_lev_cloud_index 
      else
        lk = kx
      endif

!-----------------------------------------------------------------------

! caclulate stratiform  l-m-h cloud amounts for thin or thick clouds
! current implementation of thick clouds will extend max stratiform
! cloud layer upward 1 level - assuming the level
! above the max level is within a threshold cloud amount 

! [note: the maxloc function used below will choose the lowest value index
! in case of two identical max values. In the extremely unlikely event of
! two identical max cloud amounts in a particular column section, the
! maxloc selection priority will result in a bias toward higher clouds.]

      c_work(:,:,:) = 0.0
      ic_work(:,:,:) = 0

! calculate pressure thickness of model layers, for vertcal averaging
      do k=1,kx
        delp (:,:,k) = phalf(:,:,k+1)-phalf(:,:,k)
      end do
 

      do j = 1,jdim
        do i = 1,idim

! low clouds
          kbtm = min(lk,kx-1) 
          ktop = llowt(i,j)
          kindex(:) = maxloc (camt(i,j,ktop:kbtm)) 
          k=kindex(1) + ktop - 1
          c_work(i,j,k) = camt(i,j,k)
!  for low clouds add 300 to previous cloud marker type
          ic_work(i,j,k) = icld_k(i,j,k) + 300 

          if (lthick_low) then
!            do k = kbtm,ktop,-1
call THICK_CLOUDS (camt,delp,trshld_camt,i,j,k,ktop,kbtm,nmax,c_work,ic_work)
!            end do   
          endif

! mid clouds
          kbtm = lmidb(i,j) 
          ktop = lmidt(i,j)
          kindex(:) = maxloc (camt(i,j,ktop:kbtm)) 
          k=kindex(1) + ktop - 1
          c_work(i,j,k) = camt(i,j,k)         
!  for mid clouds add 200 to previous cloud marker type
          ic_work(i,j,k) = icld_k(i,j,k) + 200         

          if (lthick_mid) then
call THICK_CLOUDS (camt,delp,trshld_mh,i,j,k,ktop,kbtm,nmax_mh,c_work,ic_work)
! call THICK_CLOUDS (camt,delp,trshld_camt,i,j,k,ktop,kbtm,nmax,c_work,ic_work)
          endif

! high clouds
          kbtm = lhighb(i,j) 
          ktop = lhight(i,j)
          kindex(:) = maxloc (camt(i,j,ktop:kbtm)) 
          k=kindex(1) + ktop - 1
          c_work(i,j,k) = camt(i,j,k)         
!  for high clouds add 100 to previous cloud marker type
          ic_work(i,j,k) = icld_k(i,j,k) + 100         

          if (lthick_high) then
call THICK_CLOUDS (camt,delp,trshld_mh,i,j,k,ktop,kbtm,nmax_mh,c_work,ic_work)
! call THICK_CLOUDS (camt,delp,trshld_camt,i,j,k,ktop,kbtm,nmax,c_work,ic_work)
          endif

        end do
      end do

! Store the resulting values of c_work and ic_work back into camt and icld_k

      where (camt(:,:,:) .eq. 0.0)
        ic_work(:,:,:) = 0
      endwhere
!  Thick clouds are currently not allowed to extend to the lowest level, but
!  fog is allowed there if nofog = f
      do k=1,kx-1
        camt(:,:,k) = c_work(:,:,k)
        icld_k(:,:,k) = ic_work(:,:,k)
      end do
!  at lowest level check for fog and assign low cloud type
      where (icld_k(:,:,kx).gt.0)
       c_work(:,:,kx) = icld_k(:,:,kx) + 300
      endwhere
      icld_k(:,:,kx) = c_work(:,:,kx)


end subroutine DEF_HI_MID_LOW


!#######################################################################

subroutine THICK_CLOUDS (camt,delp,trshld_camt,i,j,kk,ktop,kbtm,nmax, &
                         c_work,ic_work)


!-------------------------------------------------------------------
!  This subroutine returns "thick" cloud amounts to routine def_hi_mid_low
!  if the criteria for those clouds are met.  First the level of the max 
!  cloud amount in a low, middle  or high cloud regime is determined.
!  A thick cloud layer consisting of a maximum of "nmax"  contiguous levels 
!  is determined to exist by looking for a cloud amount value one level
!  above that is within a specified threshold amount (trshld_camt). If
!  a contiguous cloud is found and nmax = 2 the search is over.  If no
!  contiguous cloud is found or nmax > 2 the search continues one level
!  below. If contiguous cloud is found both above and below and nmax > 3
!  the search will continue using the same threshold criteria 2 levels
!  above.  The search will continue to "zigzag" in this manner as long as
!  no maximum cloud thickness criteria has not been violated and as long
!  as there is no break in contiguous cloud amounts as described above.
!  Eventually a pressure thickness value will overide the nmax levels 
!  criteria for determining the maximum thickness of the clouds.  Another
!  factor limiting the thickness of clouds is that the cloud extent must 
!  remain within its respective high, middle, low cloud regime boundaries
!  ( i.e., ktop to kbtm). 
!-------------------------------------------------------------------
!
! !===================================================================
! Arguments (intent in)



 real, intent(in), dimension (:,:,:) :: camt,delp
 real, intent(in) :: trshld_camt
 integer, intent(in) :: i,j,kk,ktop,kbtm,nmax

!      CAMT     tentative merged cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      DELP       pressure thickness of model layers 
!                   (dimensioned IDIM x JDIM x kx)
!      I,J,KK     indicies for longitude, latitude and 
!                 vertical level (at level of max cloud amount)
!      KTOP,KBTM  - vertical index valid range for cloud top, cloud bottom
!      NMAX -       maximum number of model levels allowed in a thick cloud
!      TRSHLD_CAMT - This is a cloud amounht threshold value, used in
!                    conjunction with the thick cloud namelist options.   
!                    If a thick cloud option is on then level(s) adjacent  
!                    to the level of max cloud amount for a particular 
!                    cloud type is considered to be part of an extended cloud 
!                    if it is within this fraction of the max cloud amount.
!

!
!=======================================================================
! Arguments (intent inout)


  real, intent(inout), dimension(:,:,:) :: c_work
  integer,intent(inout), dimension(:,:,:) :: ic_work

!      C_WORK     cloud amount work array 
!                   (dimensioned IDIM x JDIM x kx)
!      IC_WORK    cloud marker work array 
!                   (dimensioned IDIM x JDIM x kx)
!
!=======================================================================
!  (Intent local)
 integer ncount,no_up,no_down,k,c_top,c_btm
! loop index
 integer ki,pass_count
 real delp_sum,thick_cld_amt
!      NCOUNT -       counter for number of model levels in a thick cloud
!      NO_UP -       if = 1 -> no more upward extension of cloud is possible
!      NO_DOWN -      if = 1 -> no more downward extension of cloud is possible
!      K  -          vertical level index of thick cloud as it being extended
!      C_TOP, C_BTM - Top and bottom of calculated thick cloud 
!      DELP_SUM - sum of pressure weights for thcik cloud layer
!      THICK_CLD_AMT - pressure weighted thick cloud amount     
!=======================================================================
!=======================================================================
      ncount = 1
      no_up = 0
      no_down = 0
      k = kk
      c_top = kk
      c_btm = kk

      pass_count = 0

!  no clouds to process
      if (camt(i,j,kk) .eq.0.0) go to 300 

100   continue

      pass_count = pass_count + 1

     
                     if (no_up .eq. 0) then
! First check to extend cloud upward
              k = c_top
              if (camt(i,j,k) .gt.0.0 .and. k.gt.ktop .and. k.le.kbtm) then
                if ((camt(i,j,kk)-camt(i,j,k-1)).le.trshld_camt) then
                  c_top = c_top - 1
                  ic_work(i,j,k-1) = ic_work(i,j,k)
                  ncount = ncount + 1
                else
! no upward extension of cloud possible
                  no_up = 1
                endif
             else
                no_up = 1
             endif
! check for reaching limiting number of levels in a thick cloud
     if (ncount .eq. nmax) go to 200
                     endif

! Next check to extend cloud downward
                     if (no_down .eq. 0) then
              k = c_btm
              if (camt(i,j,k) .gt.0.0 .and. k.ge.ktop .and. k.lt.kbtm) then
                if ((camt(i,j,kk)-camt(i,j,k+1)).le.trshld_camt) then
                  c_btm = c_btm + 1
                  ic_work(i,j,k+1) = ic_work(i,j,k)
                  ncount = ncount + 1
                else
! no downward extension of cloud possible
                  no_down = 1
                endif
             else
                no_down = 1
             endif
! check for reaching limiting number of levels in a thick cloud
      if (ncount .eq. nmax) go to 200
                     endif

!  Further tests for completion of thick cloud calculations
!  Make sure upward or downward extension of the cloud is still allowed
!  and the cloud level index is still within the allowable range
       if ( ( no_up.eq.1 .or. c_top.eq.ktop) .and. &
          ( no_down.eq.1 .or. c_btm.eq.kbtm) ) go to 200

! loop back to do another pass at extending the thick cloud
       go to 100

200   continue

!  calculate press thickness weighted thick clouds
      delp_sum = 0.0
      do ki=c_top,c_btm
        delp_sum = delp_sum + delp(i,j,ki)
      end do
      thick_cld_amt = 0.0
      do ki=c_top,c_btm
        thick_cld_amt = thick_cld_amt + camt(i,j,ki)*delp(i,j,ki)
      end do
      thick_cld_amt = thick_cld_amt/delp_sum

! broadcast thick cloud amount throughout thick cloud layer
      do ki=c_top,c_btm
        c_work(i,j,ki) = thick_cld_amt
      end do

300   continue

          
!===================================================================
end subroutine THICK_CLOUDS

!#######################################################################

subroutine MERGE_CNV_CLOUDS (camtcnv,camtsh,camtsh_mx,kminshl,kmaxshl, &
                           lhight,lhighb,lmidt,lmidb,llowt,camt,icld_k)



!-------------------------------------------------------------------
!  This subroutine adds convective cloud amounts to the already merged 
!  stratiform cloud amounts
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

!-------------------------------------------------------------------
! Namelist variables used in this routine (defined at top of module)
!     LCNVCLD - logical switch for turning on calculation of deep convective 
!              clouds - true for deep convective clouds, otherwise false 
!     L_THEQV - logical switch for turning on calculation of shallow convective 
!              clouds - true for shallow convective clouds, otherwise false 
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!!-------------------------------------------------------------------

 real, intent(in), dimension (:,:,:) :: camtcnv, camtsh
 real, intent(in), dimension (:,:) :: camtsh_mx
 integer, intent(in), dimension (:,:) :: kminshl, kmaxshl
 integer, intent(in), dimension(:,:) :: lhight, lhighb, lmidt, lmidb, llowt

!     CAMTCNV - deep convective cloud amounts at full model levels  
!                   (dimensioned IDIM x JDIM x kx)
!     CAMTSH - shallow convective cloud amount at full model levels 
!               (dimensioned IDIM x JDIM x kx)
!     CAMTSH_MX  maximum value of shallow convective cloud amount within
!                  shallow convective layer. (dimensioned IDIM x JDIM)
!     KMINSHL,KMAXSHL indices of vertical levels corresponding to 
!                   final top and base of shallow convective cloud layer
!                   (dimensioned IDIM x JDIM)
!       LHIGHT        vertical level index upper limit for high cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LHIGHB        vertical level index lower limit for high cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDT         vertical level index upper limit for mid cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDB         vertical level index lower limit for mid cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LLOWT         vertical level index upper limit for low cloud tops
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
! !===================================================================
! Arguments (intent inout)

 real, intent(inout), dimension (:,:,:) :: camt
 integer, intent(inout), dimension (:,:,:) :: icld_k

!      CAMT     tentative merged cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!      ICLD_K     tentative merged cloud marker array  
!                   (dimensioned IDIM x JDIM x kx)


!=======================================================================
!  (Intent local)
  real,    dimension(SIZE(camt,1),SIZE(camt,2)) ::   cmax_strat
  real,    dimension(SIZE(camt,1),SIZE(camt,2),SIZE(camt,3)) ::   c_work
  integer, dimension(SIZE(camt,1),SIZE(camt,2),SIZE(camt,3)) ::   ic_work

!      CMAX_STRAT   max stratiform cloud amount work array 
!                   (dimensioned IDIM x JDIM)
!      C_WORK     cloud amount work array 
!                   (dimensioned IDIM x JDIM x kx)
!      IC_WORK    cloud marker work array 
!                   (dimensioned IDIM x JDIM x kx)

 integer i,j,k,kx, lk, kcbtop, kbtm , ktop, idim, jdim

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

  idim  = SIZE(camt,1)
  jdim  = SIZE(camt,2)
  kx  = SIZE(camt,3)


      if (nofog) then
        lk = low_lev_cloud_index 
      else
        lk = kx
      endif
!  define upper limit of cloud tops
      kcbtop = high_lev_cloud_index

!  initialize work arrays
      c_work(:,:,:) = camt(:,:,:)

!  decide whether or not to replace stratiform low cloud within the
!  contiguous shallow convective layer with shallow convective cloud
      
      if (l_theqv) then
!  find maximum stratiform low cloud amount within shallow conv layer
!  assume shallow convective layer is always below upper bound for low clouds

      do j = 1,jdim
        do i = 1,idim
          kbtm = kmaxshl(i,j)
          ktop = kminshl(i,j)
          cmax_strat(i,j) = 0.0
          do k = kbtm,ktop,-1
            cmax_strat(i,j) = max (cmax_strat(i,j),camt(i,j,k))
          end do
        end do
      end do

!  check to see if shallow convective cloud will be dominant type
!  if so reset cloud amounts to shallow amount and reset cloud marker
      do k = lk,kcbtop,-1
        where ( (k.ge.kminshl(:,:)) .and. (k.le.kmaxshl(:,:)) .and. &
              (camtsh_mx(:,:) .gt. cmax_strat(:,:)) )
          c_work(:,:,k) =  camtsh (:,:,k)
          icld_k(:,:,k) = 304
        endwhere
      end do

      endif

!  randomly overlap stratiform and deep convective cloud amounts.
!  also check to see if the convective cloud is dominant based on
!  a comparison of cloud amounts (pre-random overlap), if so assign
!  cloud marker values based on H-M-L and cloud type (convective = 5)
  
      ic_work(:,:,:) = mod(icld_k(:,:,:),100)
       
        if (lcnvcld) then

      do k = lk,kcbtop,-1

        where ( ic_work(:,:,k) .le. 3)
          c_work(:,:,k) = camtcnv(:,:,k) + (1.0-camtcnv(:,:,k))*camt(:,:,k)
        endwhere

!  low cloud range
          where ( (camtcnv(:,:,k).gt.camt(:,:,k)) .and. &
             (k.ge.llowt(:,:) .and. k.le.lk) .and. (ic_work(:,:,k).le.3) )
            icld_k(:,:,k) = 305
          endwhere
!  mid cloud range
          where ( (camtcnv(:,:,k).gt.camt(:,:,k)) .and. &
             (k.ge.lmidt(:,:) .and. k.le.lmidb(:,:)) )
            icld_k(:,:,k) = 205
          endwhere
!  high cloud range
          where ( (camtcnv(:,:,k).gt.camt(:,:,k)) .and. &
             (k.ge.lhight(:,:) .and. k.le.lhighb(:,:)) )
            icld_k(:,:,k) = 105
          endwhere

      end do

        endif

!  re-define convective cloud amount as the max of deep and shallow convective
!  cloud at levels where shallow convective clouds are currently defined.

        if (lcnvcld .and. l_theqv) then

          where ( (camtcnv(:,:,:).gt.c_work(:,:,:)) .and. &
             (ic_work(:,:,:) .eq. 4 ) )
            c_work(:,:,:) = camtcnv(:,:,:)
            icld_k(:,:,:) = 305
          endwhere

        endif

! Store the resulting values of c_work back into camt

      camt(:,:,:) = c_work(:,:,:)

!-----------------------------------------------------------------------

end subroutine MERGE_CNV_CLOUDS

!#######################################################################

subroutine LAYR_TOP_BASE (icld_k,nclds,cldtop,cldbas,icld)



!-------------------------------------------------------------------
!  This subroutine determines cloud layers, tops and bases
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     LTHICK_HIGH - logical variable = true -> allow possibility of raising
!               high cloud tops one sigma level to increase their thickness
!               from 1 to 2 sigma levels; otherwise they remain thin 
!               (1 sigma level)
!     LTHICK_MID - logical variable = true -> allow possibility of raising
!               mid cloud tops one sigma level to increase their thickness
!               from 1 to 2 sigma levels; otherwise they remain thin 
!               (1 sigma level)
!     LTHICK_LOW - logical variable = true -> allow possibility of raising
!               low cloud tops one sigma level to increase their thickness
!               from 1 to 2 sigma levels; otherwise they remain thin 
!               (1 sigma level)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!-------------------------------------------------------------------

integer, intent(in), dimension (:,:,:) :: icld_k

!      ICLD_K     tentative merged cloud marker array  
!                   (dimensioned IDIM x JDIM x kx)
!===================================================================
! Arguments (intent out)

integer, intent(out), dimension(:,:,:) :: cldtop,cldbas,icld
integer, intent(out), dimension(:,:)  :: nclds

!      NCLDS       number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!                   (dimensioned IDIM x JDIM )
!      CLDTOP     index of cloud tops (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDBAS    index of cloud bottoms (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      ICLD          marker array of cloud types (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)



!=======================================================================
!  (Intent local)

  integer, dimension(SIZE(icld_k,1),SIZE(icld_k,2),SIZE(icld_k,3)) :: &  
                 ctop_work,cbas_work,ic_work

!      CTOP_WORK    cloud top work array (at model levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CBAS_WORK    cloud bsse work array (at model levels)
!                   (dimensioned IDIM x JDIM x kx)
!      IC_WORK    cloud marker work array 
!                   (dimensioned IDIM x JDIM x kx)
 integer k,kcbtop,i,j,idim, jdim, kx, lk, kp, kpmax, maxcld

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

  idim  = SIZE(icld_k,1)
  jdim  = SIZE(icld_k,2)
  kx  = SIZE(icld_k,3)


!  define lower limit of cloud bottom
      if (nofog) then
        lk = low_lev_cloud_index
      else
        lk = kx
      endif
!  define upper limit of cloud tops
      kcbtop = high_lev_cloud_index

!  Initialize output arrays

      nclds(:,:) = 0
      icld(:,:,:) = 0
      cldtop(:,:,:) = 0
      cldbas(:,:,:) = 0

!  Initialize work arrays

      ctop_work(:,:,:) = 0
      cbas_work(:,:,:) = 0
      ic_work(:,:,:) = mod(icld_k(:,:,:),100)


!  locate distinct cloud layers, tops and bases

      do k=kcbtop,lk

!  first locate tops and increment cloud layer counter, nclds

!  check for no clouds above any type of cloud layer 
      where ( ic_work(:,:,k).ge.1 .and. ic_work(:,:,k-1).eq.0)
        nclds(:,:) = nclds(:,:) + 1
        ctop_work(:,:,k) = k
      endwhere
!  check for stratiform cloud layer above convective cloud layer 
!  anvil and super anvil (types 6,7) are stratiform type clouds 
      where ( (ic_work(:,:,k).ge.4 .and. ic_work(:,:,k).le.5) .and. &
             (ic_work(:,:,k-1).ge.1 .and. ic_work(:,:,k-1).le.3) .or. &
             (ic_work(:,:,k-1).ge.6) )
        nclds(:,:) = nclds(:,:) + 1
        ctop_work(:,:,k) = k
      endwhere
!  check for convective cloud layer above stratiform cloud layer 
      where ( (ic_work(:,:,k-1).ge.4 .and. ic_work(:,:,k-1).le.5) .and. &
             (ic_work(:,:,k).ge.1 .and. ic_work(:,:,k).le.3) .or. &
             (ic_work(:,:,k).ge.6) )
        nclds(:,:) = nclds(:,:) + 1
        ctop_work(:,:,k) = k
      endwhere

        if (k.lt.lk) then

!  locate bases

!  check for no clouds above any type of cloud layer 
      where ( ic_work(:,:,k).ge.1 .and. ic_work(:,:,k+1).eq.0)
        cbas_work(:,:,k) = k
      endwhere
!  check for stratiform cloud layer above convective cloud layer 
!  anvil and super anvil (types 6,7) are stratiform type clouds 
      where ( (ic_work(:,:,k+1).ge.4 .and. ic_work(:,:,k+1).le.5) .and. &
             (ic_work(:,:,k).ge.1 .and. ic_work(:,:,k).le.3) .or. &
             (ic_work(:,:,k).ge.6) )
        cbas_work(:,:,k) = k
      endwhere
!  check for convective cloud layer above stratiform cloud layer 
      where ( (ic_work(:,:,k).ge.4 .and. ic_work(:,:,k).le.5) .and. &
             (ic_work(:,:,k+1).ge.1 .and. ic_work(:,:,k+1).le.3) .or. &
             (ic_work(:,:,k+1).ge.6) )
        cbas_work(:,:,k) = k
      endwhere

        endif


          do j = 1,jdim
            do i = 1,idim
        if (k.eq.lk .and. ic_work(i,j,k).ge.1) then

          cbas_work(i,j,k) = lk

        endif
            end do
          end do

      end do

!-----------------------------------------------------------------------

!  compress output cloud tops, bases and cloud markers to cloud levels

      do j = 1,jdim
        do i = 1,idim

          if (nclds(i,j) .ge.1) then

          kpmax = nclds(i,j)
          kp = 1
            do k = kcbtop,lk

              if (ctop_work(i,j,k).ne. 0) then
                cldtop(i,j,kp) = ctop_work(i,j,k)
                icld(i,j,kp) = icld_k(i,j,k)
              endif

              if (cbas_work(i,j,k).ne. 0) then
                cldbas(i,j,kp) = cbas_work(i,j,k)
                kp = kp + 1 
              endif

              if (kp .gt. kpmax) go to 999              

            end do
   
999     continue
     
        endif

        end do
      end do


!-----------------------------------------------------------------------

!  error check for too many cloud layers

! find maximum number of cloud layers
      maxcld  = maxval(nclds(:,:))
                   if (maxcld .gt. kx/2) then
     print *,'pe, NCLDS =', mpp_pe(),nclds
                 call error_mesg ('diag_cloud, layr_top_base',  &
                   'NCLDS too large', FATAL)
                    endif


!-----------------------------------------------------------------------

end subroutine LAYR_TOP_BASE

!#######################################################################


subroutine CLDAMT_MN (nclds,cldtop,cldbas,phalf,camt,cldamt)



!-------------------------------------------------------------------
!  This subroutine computes mass-weighted vertical mean cloud amount 
!  for each distinct cloud layer
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!-------------------------------------------------------------------

 integer, intent(out), dimension(:,:,:) :: cldtop,cldbas
 integer, intent(out), dimension(:,:)  :: nclds
 real, intent(in), dimension (:,:,:) ::  phalf

!      NCLDS       number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!                   (dimensioned IDIM x JDIM )
!      CLDTOP     index of cloud tops (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDBAS    index of cloud bottoms (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!===================================================================
! Arguments (intent inout)

 real, intent(inout), dimension (:,:,:) :: camt

!      CAMT     tentative merged cloud amounts  
!                   (dimensioned IDIM x JDIM x kx)
!=======================================================================
 real, intent(out), dimension(:,:,:) :: cldamt

!      CLDAMT   cloud amount (fraction) (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)

!=======================================================================
!  (Intent local)


  real, dimension(SIZE(camt,1),SIZE(camt,2),SIZE(camt,3)) :: delp,c_work,weight

!      DELP       pressure thickness of model layers 
!                   (dimensioned IDIM x JDIM x kx)
!      C_WORK     cloud amount work array (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      WEIGHT     vertical sum of press thickness over model levels for each
!                 cloud level (dimensioned IDIM x JDIM x kx)

! loop limits and indices
 integer idim,jdim,kx, kpr, lk, i, j, k
 integer maxcld

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

  idim  = SIZE(camt,1)
  jdim  = SIZE(camt,2)
  kx  = SIZE(camt,3)


!  define lower limitfor stratiform clouds
      if (nofog) then
        lk = low_lev_cloud_index 
      else
        lk = kx
      endif

! find maximum number of cloud layers
      maxcld  = maxval(nclds(:,:))

!-----------------------------------------------------------------------
 ! initialize output and work cloud amount arrays 

      cldamt(:,:,:) = 0.0
      c_work(:,:,:) = 0.0
      weight(:,:,:) = 0.0
!-----------------------------------------------------------------------

! calculate pressure thickness of model layers, for vertcal averaging
      do k=1,kx
        delp (:,:,k) = phalf(:,:,k+1)-phalf(:,:,k)
      end do
!-----------------------------------------------------------------------

! calculate mass weighted vertical mean cloud amount
      do kpr=1,maxcld
        do j=1,jdim
          do i=1,idim 
  
             if (cldtop(i,j,kpr) .lt. cldbas(i,j,kpr)) then

               do k=cldtop(i,j,kpr),cldbas(i,j,kpr) 
                 c_work(i,j,kpr) = c_work(i,j,kpr) + &
                 delp(i,j,k)*camt(i,j,k)
                 weight(i,j,kpr) = weight(i,j,kpr) + delp(i,j,k)
               end do
               cldamt(i,j,kpr) = c_work(i,j,kpr)/weight(i,j,kpr)
! reset cloud amounts at model sigma levels to mass weighted for the layer
               do k=cldtop(i,j,kpr),cldbas(i,j,kpr) 
                 camt(i,j,k) = cldamt(i,j,kpr)
               end do

             else if ( (cldtop(i,j,kpr) .eq. cldbas(i,j,kpr)) .and. &
             (cldtop(i,j,kpr).gt.0 .and. cldtop(i,j,kpr).le.kx)) then
 
               k = cldtop(i,j,kpr)
               cldamt(i,j,kpr) = camt(i,j,k)

             else if ( (cldtop(i,j,kpr) .gt. cldbas(i,j,kpr)) .or. &
             (cldtop(i,j,kpr).lt.0) .or. (cldbas(i,j,kpr).lt.0)) then

     print *,'pe, i,j,kpr, cldtop,cldbas =', mpp_pe(),i,j,kpr, &
         cldtop(i,j,kpr),cldbas(i,j,kpr),cldtop(i,j,kpr),cldbas(i,j,kpr)
                 call error_mesg ('diag_cloud, cldamt_mn',  &
                   'invalid cldtop and/or cldbas', FATAL)

             endif
          end do
        end do
      end do


end subroutine CLDAMT_MN 

!#############################################################################      
 
subroutine ANVIL_CIRRUS (lhighb,lmidb,nclds,cldtop,cldbas,cnvcntq,lgscldelq,  &
                   pfull,phalf,icld)
                                  


!------------------------------------------------------------------------
!  This subroutine calculates anvil and super anvil cirrus cloud amounts
!------------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

!-------------------------------------------------------------------
! Namelist variables used in this routine (defined at top of module)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  parameters used in anvil_cirrus

 real,  parameter :: cnvdelqmn = 0.0,lgscldelqmn = 1.0e-9 
 real,  parameter :: lcldbas_prc = .55, lcldtop_prc = .225

!      CNVDELQMN - min threshold value of accumulated count of mixing ratio 
!                  change due to convection above which convective clouds are 
!                  allowed
!                  ( It is set = 0.0 as a parameter, because it not anticipated
!                    that it would be changed.)
!      LGSCLDELQMN - min threshold value of averaged mixing ratio rate of
!                  change due to large scale condensation
!      LCLDBAS_PRC - Threshold sigma value for base of an "anvil cirrus 
!                    indicator" layer
!      LCLDBAS_PRC - Threshold sigma value for top of an "anvil cirrus 
!                    indicator" layer
!-------------------------------------------------------------------

 integer, intent(out), dimension(:,:,:) :: cldtop,cldbas
 integer, intent(out), dimension(:,:)  ::  nclds,lhighb,lmidb
 real, intent(in), dimension (:,:,:) ::  lgscldelq,cnvcntq,pfull,phalf

!-------------------------------------------------------------------
!       LHIGHB        vertical level index lower limit for high cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       LMIDB         vertical level index lower limit for mid cloud bases
!                     a function of lon and latitude (dimensioned IDIMxJDIM)
!       NCLDS   number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!                   (dimensioned IDIM x JDIM )
!      CLDTOP   index of cloud tops (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDBAS   index of cloud bottoms (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      LGSCLDELQ  Averaged rate of change in mix ratio due to lg scale precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      CNVCNTQ  Accumulated count of change in mix ratio due to conv precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      PFULL    Pressure at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!===================================================================
! Arguments (intent inout)
 integer, intent(out), dimension (:,:,:) :: icld
!       ICLD          marker array of cloud types/heights (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!=======================================================================
!  (Intent local)

 integer, dimension (size(pfull,1),size(pfull,2),size(pfull,3)) :: ic_work
!-------------------------------------------------------------------
!      IC_WORK    cloud marker work array 
!                   (dimensioned IDIM x JDIM x kx)
!       LCLDT         Top of anvil cirrus 
!                     (model level index)
!       LCLDB         Base of anvil cirrus 
!                     (model level index)
!       LPRCTOP       Base of region in search for anvil cirrus markers
!                     (model level index)
!       LPRCBAS       Base of region in search for anvil cirrus markers
!                     (model level index)
!       SIG_TOP_BASE  Sigma value of top/base of region in search for 
!                      anvil cirrus markers
!                     

 real sig_top_base
 integer lcldt, lcldb, lprcbas, lprctop
 integer i, j, idim, jdim, kx
!-----------------------------------------------------------------------
!  type loop index variable
 integer k,kl 

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

      idim  = SIZE(pfull,1)
      jdim  = SIZE(pfull,2)
      kx = size(pfull,3)

! Initialize cloud type work array
      ic_work (:,:,:) = icld(:,:,:)


!-----------------------------------------------------------------------
! <><><><><><><><>   search for anvil cirrus  <><><><><><><><>
!-----------------------------------------------------------------------
      
      do j=1,jdim
      do i=1,idim
        do k=1,kx
          sig_top_base = pfull(i,j,k)/phalf(i,j,kx+1)
          if ( sig_top_base .gt. lcldtop_prc) then
             lprctop = k-1
             go to 100
          endif
        end do

100     continue

        do k=1,kx
          sig_top_base = pfull(i,j,k)/phalf(i,j,kx+1)
          if ( sig_top_base .gt. lcldbas_prc) then
             lprcbas = k-1
             go to 150
          endif
        end do

150     continue
           
        do k=1,nclds(i,j)
          lcldt = cldtop(i,j,k)
          lcldb = cldbas(i,j,k)


! Must have a high cloud for any anvil cirrus

                    if (icld(i,j,k) .ne. 101) go to 400

! First check whether super-anvil cirrus criteria is satisfied
! This criteria differs from v197, because calculation of convective precip for 
! high cloud region only is unreliable. Instead it is required that there has  
! been a change in mixing ratio due to convection at at least one time step during
! the time interval over which the clouds are being calculated, at ALL levels 
! between the base of the anvil cirrus indicator region (lprcbas- clculated from preset parameter)
! and the higher of either the actual top of the high cloud or the previoulsy computed top of the 
! Anvil Cirrus cloud indicator region.

           if (lcldt .lt. lprctop) then
              lprctop = lcldt
           endif
           do kl=lprcbas,lprctop,-1
             if (cnvcntq(i,j,kl) .lt. 1.0) then
               go to 200
             endif
           end do
           ic_work(i,j,k) = 107
! found super-anvil cirrus, no need to search for anvil cirrus
           go to 400

200        continue

! search for anvil cirrus using criteria that a change in mixing ratio due to 
! either convection or large scale condensation at any level within an actual high 
! cloud takes places during the time interval over which the clouds are being 
! calculated.

          do kl=lcldb,lcldt,-1
            if (cnvcntq(i,j,kl) .gt. 0.0) go to 300
            if (kl.le.lhighb(i,j) .and. lgscldelq(i,j,kl).gt.lgscldelqmn) &
                go to 300
          end do
          go to 400
300       continue
               ic_work(i,j,k) = 106
   
        end do

400   continue

!                    endif

      end do
      end do


!-----------------------------------------------------------------------
! <><><><><><><><>   update cloud marker array  <><><><><><><><>
!-----------------------------------------------------------------------
      
      icld(:,:,:) = ic_work(:,:,:)       


!-----------------------------------------------------------------------

end subroutine ANVIL_CIRRUS



!#######################################################################

subroutine CLD_LAYR_MN_TEMP_DELP &
                        (nclds,cldtop,cldbas,temp,phalf,tempcld,delp_true)



!-------------------------------------------------------------------
!  This subroutine computes the mass-weighted mean cloud temperature
!  and true cloud pressure thickness of distinct cloud layers.
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)

! Namelist variables used in this routine (defined at top of module)
!     HIGH_LEV_CLOUD_INDEX - level above which no clouds are allowed to form 
!              (model level index)
!     NOFOG - logical switch for not allowing rhum clouds (or fog)
!             to occur beneath a certain level (low_lev_cloud_index) -> 
!              nofog = true
!             to allow clouds at the lowest model level -> nofog = false
!     LOW_LEV_CLOUD_INDEX - level below which no clouds are allowed to occur 
!               when nofog = true (model level index)
!-------------------------------------------------------------------

! Arguments (intent in)

integer, intent(in), dimension(:,:)  :: nclds
integer, intent(in), dimension(:,:,:) :: cldtop,cldbas
real, intent(in), dimension(:,:,:) :: temp,phalf

!      NCLDS       number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!                   (dimensioned IDIM x JDIM )
!      CLDTOP     index of cloud tops (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      CLDBAS    index of cloud bottoms (at cloud levels)
!                   (dimensioned IDIM x JDIM x kx)
!      TEMP        Temperature (Deg K) at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x kx+1)
!===================================================================
! Arguments (intent out)

real, intent(out), dimension(:,:,:) :: tempcld,delp_true

!      TEMPCLD    cloud layer mean temperature (degrees Kelvin)
!                    (at cloud levels)
!      DELP_TRUE  true cloud pressure thickness of distinct cloud layers 
!                    (at cloud levels)



!=======================================================================
!  (Intent local)

 integer, dimension (size(cldtop,1),size(cldtop,2)) :: cldt,cldb

!      CLDT       cloud top index work array 
!                   (dimensioned IDIM x JDIM x kx)
!      CLDB       cloud base index work array 
!                   (dimensioned IDIM x JDIM x kx)
 integer i,j,k,kk,kx,idim,jdim, lk, kcbtop, maxcld

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

  idim  = SIZE(temp,1)
  jdim  = SIZE(temp,2)
  kx  = SIZE(temp,3)


!  define lower limit of cloud bottom
      if (nofog) then
        lk = low_lev_cloud_index
      else
        lk = kx
      endif
!  define upper limit of cloud tops
      kcbtop = high_lev_cloud_index

!  Initialize output arrays

      tempcld(:,:,:) = 0
      delp_true(:,:,:) = 0

! find maximum number of clouds
      maxcld  = maxval(nclds(:,:))

                   if (maxcld .ge. 1) then

!-----------------------------------------------------------------------
! <><><><><><><><>   calc pressure thickness <><><><><><><><>
!-----------------------------------------------------------------------

      do k = 1,maxcld

! Initialize internal arrays
      cldt = 0
      cldb = 0
         where (nclds(:,:) .ge. k)
           cldt(:,:) = cldtop(:,:,k)      
           cldb(:,:) = cldbas(:,:,k) 
         end where

         do j=1,jdim
         do i=1,idim
           if (k .le. nclds(i,j)) then
             delp_true(i,j,k) = phalf(i,j,cldb(i,j)+1)-phalf(i,j,cldt(i,j))
           endif
         end do
         end do
       end do



!-----------------------------------------------------------------------
! <><><><><><><><>   calc mass-weghted mean cloud temp <><><><><><><><>
!-----------------------------------------------------------------------

      do j=1,jdim
      do i=1,idim
        do kk= 1,nclds(i,j)
          do k=cldtop(i,j,kk),cldbas(i,j,kk)
            tempcld(i,j,kk) = tempcld(i,j,kk) + &
            (phalf(i,j,k+1)-phalf(i,j,k))*temp(i,j,k)/delp_true(i,j,kk)
          end do
        end do
      end do
      end do

                   endif


!-----------------------------------------------------------------------

end subroutine CLD_LAYR_MN_TEMP_DELP

!#######################################################################

  SUBROUTINE DIAG_CLOUD_INIT( ix,iy,kx, ierr )

!=======================================================================
! ***** INITIALIZE Predicted Cloud Scheme
!=======================================================================


!---------------------------------------------------------------------
! Arguments (Intent in)
!  parmameter mxband = max number of radiative bands to be considered for some
!              cloud properties (defined at top of module)
!---------------------------------------------------------------------
 integer, intent(in) :: ix, iy, kx
!      INPUT
!      ------

!      IX, IY, KX   Dimensions for global storage arrays (2- horiz, vert)
!---------------------------------------------------------------------
! Arguments (Intent out)
!---------------------------------------------------------------------
 integer, intent(out) :: ierr

!      OUTPUT
!      ------

!      IERR     Error flag

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
 integer  unit, io, ierrnml, logunit
 integer  id_restart
 character(len=32) :: fname

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


!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=diag_cloud_nml, iostat=io)
   ierr = check_nml_error(io,"diag_cloud_nml")
#else
  if( FILE_EXIST( 'input.nml' ) ) then
! -------------------------------------
    unit = open_namelist_file ('input.nml')
    ierrnml = 1
    do while( ierrnml .ne. 0 )
      READ ( unit,  nml = diag_cloud_nml, iostat = io, end = 10 ) 
      ierrnml = check_nml_error(io,'diag_cloud_nml')
    end do
10  call close_file (unit)
! -------------------------------------
  end if
#endif

!---------------------------------------------------------------------
! --- Output namelist
!---------------------------------------------------------------------

  logunit = stdlog()
  if ( mpp_pe() == mpp_root_pe() ) then
    call write_version_number(version, tagname)
    write (logunit, nml=diag_cloud_nml)
  endif     
  do_netcdf_restart = .true.
  call get_restart_io_mode(do_netcdf_restart)

!---------------------------------------------------------------------
! --- Allocate storage for global cloud quantities
!---------------------------------------------------------------------


  allocate( temp_sum(ix,iy,kx),qmix_sum(ix,iy,kx),rhum_sum(ix,iy,kx) )
  allocate( qmix_sum2(ix,iy) )
  allocate( omega_sum(ix,iy,kx),lgscldelq_sum(ix,iy,kx),cnvcntq_sum(ix,iy,kx) )
  allocate( convprc_sum(ix,iy),nsum(ix,iy), nsum2(ix,iy) )

! need to set up to account for first radiation step without having
! diag cloud info available (radiation called before diag_cloud, and
! diag_cloud being initiated (cold-started) in this job). 

      tot_pts = ix*iy
!---------------------------------------------------------------------
!---------- initialize for cloud averaging -------------------------
!---------------------------------------------------------------------

  fname = 'diag_cloud.res.nc'
  if(do_netcdf_restart) then  
     id_restart = register_restart_field(Dia_restart, fname, 'nsum', nsum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'temp_sum', temp_sum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'qmix_sum', qmix_sum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'rhum_sum', rhum_sum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'omega_sum', omega_sum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'lgscldelq_sum', lgscldelq_sum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'cnvcntq_sum', cnvcntq_sum, no_domain=.true.)
     id_restart = register_restart_field(Dia_restart, fname, 'convprc_sum', convprc_sum, no_domain=.true.)
  endif

  if( FILE_EXIST( 'INPUT/diag_cloud.res.nc' ) ) then
     if(mpp_pe() == mpp_root_pe() ) call error_mesg ('diag_cloud_mod', &
          'Reading netCDF formatted restart file: INPUT/diag_cloud.res.nc', NOTE)
     call restore_state(Dia_restart)
     nsum2 = nsum
     qmix_sum2(:,:) = qmix_sum(:,:,size(qmix_sum,3))
     ierr = 0
     num_pts = tot_pts
  else if( FILE_EXIST( 'INPUT/diag_cloud.res' ) ) then
           unit = open_restart_file ('INPUT/diag_cloud.res', action='read')

      call read_data (unit,nsum)
      nsum2 = nsum
      call read_data (unit,temp_sum)
      call read_data (unit,qmix_sum)
      qmix_sum2(:,:) = qmix_sum(:,:,size(qmix_sum,3))
      call read_data (unit,rhum_sum)
      call read_data (unit,omega_sum)
      call read_data (unit,lgscldelq_sum)
      call read_data (unit,cnvcntq_sum)
      call read_data (unit,convprc_sum)

      ierr = 0

      num_pts = tot_pts
  else

      ierr = 1
      if (mpp_pe() == mpp_root_pe() ) write (logunit,12)
  12  format ('*** WARNING *** No cloud_tg restart file found ***  ' )

      nsum = 0
      nsum2 = 0
      temp_sum = 0.0
      qmix_sum = 0.0
      qmix_sum2 = 0.0
      rhum_sum = 0.0
      omega_sum = 0.0
      lgscldelq_sum = 0.0
      cnvcntq_sum = 0.0
      convprc_sum = 0.0

      num_pts = 0

  end if





!-------------------------------------------------------------------
! initialize zonal cloud routine for climatological zonal mean cloud info
! Passing the number 5 as the argument to cloud_zonal_init initializes the 
! clim zonal clouds allowing seasonal variation

       call cloud_zonal_init (5)

! initialize shallow convection for shallow convective clouds
       call shallow_conv_init( kx )

! Initialize cloud optical and radiative properties scheme 
      if (.not. do_crad_init) then
         call diag_cloud_rad_init (do_crad_init)
      endif
  do_cpred_init = .true.
  module_is_initialized = .true.

 
!=====================================================================
  end SUBROUTINE DIAG_CLOUD_INIT

!#######################################################################

  SUBROUTINE DIAG_CLOUD_END

!=======================================================================
! local
  integer :: unit
!=======================================================================

  if( do_netcdf_restart) then
     if (mpp_pe() == mpp_root_pe()) then
        call error_mesg ('diag_cloud_mod', 'Writing netCDF formatted restart file: RESTART/diag_cloud.res.nc', NOTE)
     endif
     call diag_cloud_restart
  else
     if (mpp_pe() == mpp_root_pe()) then
        call error_mesg ('diag_cloud_mod', 'Writing native formatted restart file.', NOTE)
     endif
     unit = open_restart_file ('RESTART/diag_cloud.res', action='write')

     call write_data (unit, nsum)
     call write_data (unit, temp_sum)
     call write_data (unit, qmix_sum)
     call write_data (unit, rhum_sum)
     call write_data (unit, omega_sum)
     call write_data (unit, lgscldelq_sum)
     call write_data (unit, cnvcntq_sum)
     call write_data (unit, convprc_sum)

     call close_file (unit)
  endif

  module_is_initialized = .false.
 
!=====================================================================
  end SUBROUTINE DIAG_CLOUD_END

!#######################################################################
! <SUBROUTINE NAME="diag_cloud_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine diag_cloud_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

  if( do_netcdf_restart) then
    call save_restart(Dia_restart, timestamp)
  else
    call error_mesg ('diag_cloud_mod', &
         'Native intermediate restart files are not supported.', FATAL)
  endif  

end subroutine diag_cloud_restart
! </SUBROUTINE> NAME="diag_cloud_restart"

!#######################################################################

 function do_diag_cloud ( ) result (answer)
   logical :: answer

!  returns logical value for whether diag_cloud has been initialized
!  presumably if initialized then diag_cloud will be used

   answer = do_cpred_init

 end function do_diag_cloud

!#######################################################################

 SUBROUTINE DIAG_CLOUD_SUM (is,js, &
                    temp,qmix,rhum,omega,lgscldelq,cnvcntq,convprc,kbot)

!-----------------------------------------------------------------------
 integer, intent(in)                 :: is,js
 real, intent(in), dimension (:,:,:) ::  temp,qmix,rhum,omega
 real, intent(in), dimension (:,:,:) ::  lgscldelq,cnvcntq
 real, intent(in), dimension (:,:)   ::  convprc

 integer, intent(in), OPTIONAL, dimension(:,:) :: kbot

!      INPUT
!      ------

!      IS,JS    starting i,j indices from the full horizontal grid
!      TEMP     Temperature (Deg K) at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      QMIX     Mixing Ratio at full model levels 
!                   (dimensioned IDIM x JDIM x kx)
!      RHUM     Relative humidity fraction at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      OMEGA  Pressure vertical velocity at full model levels
!                   (dimensioned IDIM x JDIM x kx)
!      LGSCLDELQ  Averaged rate of change in mix ratio due to lg scale precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      CNVCNTQ  Accumulated count of change in mix ratio due to conv precip 
!               at full model levels  
!               (dimensioned IDIM x JDIM x kx)
!      convprc Accumulated conv precip rate summed over all
!               full model levels (mm/day )
!               (dimensioned IDIM x JDIM)
!      KBOT      OPTIONAL; lowest model level index array
!                   (dimensioned IDIM x JDIM)
! ******* kbot will be used to select only those qmix values that are really
! ******* needed (typically this will be the bottom level except for 
! ******* step mountains
!-----------------------------------------------------------------------
   integer :: ie, je

   ie = is + size(rhum,1) - 1
   je = js + size(rhum,2) - 1

!--------- use time-averaged or instantaneous clouds -----------

   if (do_average) then
      nsum(is:ie,js:je)   =  nsum(is:ie,js:je)   +  1
      nsum2(is:ie,js:je)   =  nsum2(is:ie,js:je)   +  1
      temp_sum(is:ie,js:je,:) = temp_sum(is:ie,js:je,:) + temp(:,:,:)
      qmix_sum(is:ie,js:je,:) = qmix_sum(is:ie,js:je,:) + qmix(:,:,:)
      qmix_sum2(is:ie,js:je) = qmix_sum2(is:ie,js:je) + qmix(:,:,size(qmix,3))
      rhum_sum(is:ie,js:je,:) = rhum_sum(is:ie,js:je,:) + rhum(:,:,:)
      omega_sum(is:ie,js:je,:) = omega_sum(is:ie,js:je,:) + omega(:,:,:)
      lgscldelq_sum(is:ie,js:je,:) = lgscldelq_sum(is:ie,js:je,:) &
                                   + lgscldelq(:,:,:)
      cnvcntq_sum(is:ie,js:je,:) = cnvcntq_sum(is:ie,js:je,:) + cnvcntq(:,:,:)
      convprc_sum(is:ie,js:je) = convprc_sum(is:ie,js:je) + convprc(:,:)
   else
      nsum(is:ie,js:je)   =  1
      nsum2(is:ie,js:je)   =  1
      temp_sum(is:ie,js:je,:) = temp(:,:,:)
      qmix_sum(is:ie,js:je,:) = qmix(:,:,:)
      qmix_sum2(is:ie,js:je) = qmix(:,:,size(qmix,3))
      rhum_sum(is:ie,js:je,:) = rhum(:,:,:)
      omega_sum(is:ie,js:je,:) = omega(:,:,:)
      lgscldelq_sum(is:ie,js:je,:) = lgscldelq(:,:,:)
      cnvcntq_sum(is:ie,js:je,:) = cnvcntq(:,:,:)
      convprc_sum(is:ie,js:je) = convprc(:,:)
   endif

!-----------------------------------------------------------------------

 end SUBROUTINE DIAG_CLOUD_SUM

!#######################################################################

 subroutine DIAG_CLOUD_AVG (is, js, temp,qmix,rhum,omega, &
                           lgscldelq,cnvcntq,convprc,      ierr)

!-----------------------------------------------------------------------
   integer, intent(in)                    :: is, js
      real, intent(inout), dimension(:,:,:) :: temp,qmix,rhum,omega
      real, intent(inout), dimension(:,:,:) :: lgscldelq,cnvcntq
      real, intent(inout), dimension(:,:)   :: convprc
   integer, intent(out)                   :: ierr
!-----------------------------------------------------------------------
   integer ::ie, je, num, k
!-----------------------------------------------------------------------

   if (size(rhum,3) .ne. size(rhum_sum,3)) call error_mesg ( &
                               'diag_cloud_avg in diag_cloud_mod',  &
                               'input argument has the wrong size',2)

   ie = is + size(rhum,1) - 1
   je = js + size(rhum,2) - 1
   num = count(nsum(is:ie,js:je) == 0)

   if (num > 0) then

!     ----- no average, return error flag -----

!!!    call error_mesg ('diag_cloud_avg in diag_cloud_mod',  &
!!!                     'dividing by a zero counter', 2)
       ierr = 1

   else

!      ----- compute average -----

       do k = 1, size(rhum,3)
          temp(:,:,k) = temp_sum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
          qmix(:,:,k) = qmix_sum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
          rhum(:,:,k) = rhum_sum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
          omega(:,:,k) = omega_sum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
          lgscldelq(:,:,k) = lgscldelq_sum(is:ie,js:je,k) / &
                             float(nsum(is:ie,js:je))
       enddo
          convprc(:,:) = convprc_sum(is:ie,js:je) / &
                             float(nsum(is:ie,js:je))

! The convective delta qmix count should be a sum, so no average is taken
          cnvcntq(:,:,:) = cnvcntq_sum(is:ie,js:je,:) 

       ierr = 0

   endif

    nsum(is:ie,js:je)   = 0
   temp_sum(is:ie,js:je,:) = 0.0
   qmix_sum(is:ie,js:je,:) = 0.0
   rhum_sum(is:ie,js:je,:) = 0.0
   omega_sum(is:ie,js:je,:) = 0.0
   lgscldelq_sum(is:ie,js:je,:) = 0.0
   cnvcntq_sum(is:ie,js:je,:) = 0.0
   convprc_sum(is:ie,js:je) = 0.0
     
!-----------------------------------------------------------------------

 end SUBROUTINE DIAG_CLOUD_AVG

!#######################################################################

 subroutine DIAG_CLOUD_AVG2 (is, js, qmix, ierr)

!-----------------------------------------------------------------------
   integer, intent(in)                    :: is, js
      real, intent(inout), dimension(:,:) :: qmix
   integer, intent(out)                   :: ierr
!-----------------------------------------------------------------------
   integer ::ie, je, num
!-----------------------------------------------------------------------

!  if (size(qmix,3) .ne. size(qmix_sum2,3)) call error_mesg ( &
!                              'diag_cloud_avg in diag_cloud_mod',  &
!                              'input argument has the wrong size',2)

   ie = is + size(qmix,1) - 1
   je = js + size(qmix,2) - 1
   num = count(nsum2(is:ie,js:je) == 0)

   if (num > 0) then

!     ----- no average, return error flag -----

!!!    call error_mesg ('diag_cloud_avg in diag_cloud_mod',  &
!!!                     'dividing by a zero counter', 2)
       ierr = 1

   else

!      ----- compute average -----

          qmix(:,:) = qmix_sum2(is:ie,js:je) / float(nsum2(is:ie,js:je))

       ierr = 0

   endif

    nsum2(is:ie,js:je)   = 0
   qmix_sum2(is:ie,js:je) = 0.0
     
!-----------------------------------------------------------------------

 end SUBROUTINE DIAG_CLOUD_AVG2

!#######################################################################


end MODULE DIAG_CLOUD_MOD


MODULE DIAG_CLOUD_RAD_MOD


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!CLOUD RADIATIVE PROPERTIES
!
!       May-Oct  1998 -> Sep 2000
!       Contact persons: Tony Gordon, Bill Stern (for modified code)
!                        Steve Klein for original Fotran 90 code)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!This module solves for the radiative properties of
!       every cloud.  In particular it uses either the
!       two stream approach or the delta-Eddington approach
!       to solve for the longwave emissivity, the ultra-violet-
!       visible reflectivities and absorptions, and the
!       near-infrared reflectivities and absorptions.
!
!       Modifications to Steve Klein's version have been made
!       to accomodate the empirical diagnostic cloud scheme of Tony Gordon,
!       frozen version v197 as discussed below.
!     
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!-------------------------------------------------------------------

use       mpp_mod, only: input_nml_file
use       fms_mod, only: error_mesg, FATAL, file_exist,    &
                         check_nml_error, open_namelist_file,       &
                         mpp_pe, mpp_root_pe, close_file, &
                         write_version_number, stdlog, open_restart_file

! Steve Klein's Cloud_Rad module
use Cloud_Rad_Mod, ONLY: CLOUD_RAD, CLOUD_RAD_INIT, cloud_rad_k_diag


!-------------------------------------------------------------------
 
  implicit none

!-------------------------------------------------------------------

!        The module contains the following:
!
!SUBROUTINES
!
!            CLOUD_TAU_DRIVER
!                        calls a sequence of suboutines to compute
! cloud optical and radiative properties, as detailed
!                        below -->
!            CLOUD_PRES_THICK_FOR_TAU
!                        computes cloud-type dependent set of pressure 
!                        thicknesses for each distinct cloud layer, which are  
!                        used to parameterize cloud optical depths
!            CLOUD_OPTICAL_DEPTHS
! Specify / crudely parameterize cloud optical depths
! for distinct cloud layers,incorporating a 
! parameterization scheme for non-anvil cirrus
!                        proposed by Harshvardhan, based upon observations by
!                        Platt and Harshvardhan
!            CLOUD_OPTICAL_PROP_tg
!                        for each cloud, it first establishes the standard
!                        values of cloud optical depths (tau) in the 
!                        vis+nir band for low, middle and high (anvil or non-
!                        anvil cirrus) clouds. Then, it calculates the 
!                        effective cloud liquid and cloud ice water paths, from
!                        the cloud optical depths, mass aborption coefficients
!                        for cloud water and cloud ice, and the temperature-
!                        dependent ratio of cloud ice to cloud water path.
!                        In the vis band, the single scattering albedo (wo), and
!                        the asymmetry parameter (g) are both specified as 
!                        constants (wo = 0.99999 and g = 0.85); 
!                        In the nir band, wo is specified as a constant, 0.9942
!                        (standard case), but is a function of zonal mean water 
!                        vapor mixing ratio at the model's lowest vertical level
!                        (anomalous absorption case). This subroutine also 
!                        computes the longwave emissivity of each cloud.
!         CLOUD_RAD   
! solves for the radiative properties of the
!                        every cloud.  In particular it uses either the
!                        two stream approach or the delta-Eddington approach
!                        to solve for the longwave emmissivity, the 
!                        ultra-violet - visible reflectivities and absorptions,
!                        and the near-infrared reflectivities and absorptions.
!                        ****    Note    ****  This subroutine is from
!                        the CLOUD_RAD_MOD module of Steve Klein .
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!     PARAMETERS OF THE SCHEME
!
!     taumin       minimum permissible tau
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
! 
!       PARAMETERS In Tony Gordon's v197 scheme only
!
!       k_lw_liq     liquid cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate).
!                       The diffusivity factor, 1.66 is incoporated into
!                       k_lw_liq.
!       k_lw_ice     ice cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate).
!                       The diffusivity factor, 1.66 is incoporated into
!                       k_lw_ice.
!       k_sw_liq     liquid cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate).
!       k_sw_ice     ice cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate).
!
!       tk_all_ice    minimum temperature at which cloud liquid water phase
!                       can exist (degrees Kelvin)
!       tk_all_liq    maximum temperature at which cloud ice can exist
!                       (degrees Kelvin)
!       wgt_liq       The ratio of liquid water path to total cloud water path,
!                        i.e., LWP / CWP
!       wgt_ice       The ratio of ice water path to total cloud water path,
!                        i.e., IWP / CWP
!
!       qsat_min      For zonal mean saturation water vapor mixing ratios
!                        less than this value entering into the variable 
!                        anomalous absorption calculations, the nir single 
!                        scattering albedo will asymptote to w0_anom2_nir
!                        where w0_anom2_nir is defined below.
!       qsat_trans    Transition value of zonal mean saturation mixing ratio
!                        between two branches of a piecewise continuous
!                        function entering into the variable anomalous
!                        absorption single scattering albedo calculations.
!       qsat_max      For zonal mean saturation water vapor mixing ratios
!                        greater than this value entering into the variable
!                        anomalous absorption calculations, the nir single
!                        scattering albedo will asymptote to w0_anom1_nir,
!                        where w0_anom1_nir is defined below.
!
!       w0_norm_uv    Normal, constant single scattering albedo in the uv-vis
!                        wavelength band of the radiation spectrum.
!       w0_norm_nir   Normal, constant single scattering albedo in the nir
!                        wavelength band of the radiation spectrum.
!       w0_anom1_nir  Asymptotic minimum value of single scattering albedo
!                        for variable anomalous absorption; also the
!                        low constant value, if L_anom_abs_g is set to TRUE.
!       w0_anom2_nir  Asymptotic maximum value of single scattering albedo
!                        for variable anomalous absorption,usually occurring
!                        at high latitudes.
! 
!       g_norm        Normal, constant asymmetry parameter used in Tony Gordon's
!                        v197 scheme. It is independent of wavelength.                                
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
!          

 private



!--------------------- version number ----------------------------------
 character(len=128) :: version = '$Id: diag_cloud_rad.F90,v 17.0.4.2 2010/08/30 20:39:46 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.
!-----------------------------------------------------------------------

! REAL, PARAMETER :: taumin = 1.E-06
! Allow optical depths = 0.0 to remain 0.0
REAL, PARAMETER :: taumin = 0.0
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!     PARAMETERS in Tony Gordon's v197 scheme only:

!       Absorption Coefficients
REAL, PARAMETER     :: k_lw_liq = 140., k_lw_ice = 100.
REAL, PARAMETER     :: k_sw_liq = 130., k_sw_ice =  74.

!       Single scattering albedo and asymmetry parameters
REAL, PARAMETER     :: w0_norm_uv   = 0.99999, w0_norm_nir  = 0.9942
REAL, PARAMETER     :: w0_anom1_nir = 0.9700,  w0_anom2_nir = 0.9980
REAL, PARAMETER     :: g_norm = 0.85

!       Parameters controlling the proportion of ice to liquid phase
REAL, PARAMETER     :: tk_all_ice = 258.16, tk_all_liq = 268.16
 
!       Mixing ratio parameters in dimensionless units.
!       (To convert these parameters to g/kg, one would multiply them by 1000).

REAL, PARAMETER  :: qsat_min = 0.0, qsat_trans = 0.01, qsat_max = 0.02


!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

!  An initialization subroutine, DIAG_CLOUD_RAD_INIT is called from 
!  clouds_tg_init do_crad_init will be reset to .false.

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 

!---------------------------------------------------------------------
! --- NAMELIST (clouds_rad_tg_nml)
!---------------------------------------------------------------------
!     l_har_anvil - logical variable = t -> anvil and super anvil cirrus
!                 clouds are treated as warm clouds.
!     l_har_coldcld - logical variable = t -> activates cold cloud portion
!                 of Harshvardhan scheme.
!                 Default value has been changed to .true., consistent with
!                 AMIP 2 run and preferred when employing RAS with no cap.
!                 l_har_coldcld = .false. would correspond to
!                 v197 frozen model runs.
!     l_anom_abs_g - logical variable = t -> anomalous absorption is
!                  specified as a constant value of single scattering albedo.
!     l_anom_abs_v - logical variable = t -> anomalous absorption is
!                  computed as a piecewise continuous function of zonal
!                  mean saturation mixing ratio.
!---------------------------------------------------------------------

 logical :: &
     & l_har_anvil = .true.,l_har_coldcld = .true., &
     & l_anom_abs_g = .false., l_anom_abs_v = .false.

  NAMELIST / diag_cloud_rad_nml /  &                          
     & l_har_anvil, l_har_coldcld, l_anom_abs_g, l_anom_abs_v

!  Need to create an initialization subroutine which reads this namelist.
!  Also, in that subroutine, check that L_anom_abs_g and L_anom_abs_v
!  are not both set to .true., after reading the namelist.
!  If they are, either code an ERROR EXIT, or else, allow L_anom_abs_v to take
!  precedence, i.e., reset L_anom_abs_g = .false. :

!     IF (L_anom_abs_v) THEN
!        L_anom_abs_g = .FALSE.
!    ENDIF   

!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!    ******    For Tony Gordon's v197 scheme only:    ****
!
!    The maximum number of distinct cloud layers in a vertical column,
!    max_cld = maxval(nclds), can be supplied by the cldtim driver in module
!    clouds_tg. Also, the cldtim driver can call a special subroutine to
!    compute the useful diagnostic total_cld_amt.
!
!    For efficiency, it is preferrable to work with the compressed vertical
!    index k'. Also, all of the argument calls in this module are presently
!    set up that way. Of course, that can be changed, by filling all levels
!    within a distinct cloud layer with the same values of data
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 public cloud_tau_driver,diag_cloud_rad_init, diag_cloud_rad_end, &
     cloud_pres_thick_for_tau, cloud_optical_depths,  &
     cloud_optical_depths2, &
     cloud_opt_prop_tg_lw, cloud_opt_prop_tg_sw, cloud_opt_prop_tg2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 contains


!########################################################################
!########################################################################

SUBROUTINE CLOUD_TAU_DRIVER (qmix_kx, tempcld, tau, coszen,  &
                             r_uv, r_nir, ab_uv, ab_nir, em_lw)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine returns the following radiative properties of clouds
!
!               1. r_uv:   cloud reflectance in uv band
!               2. r_nir:  cloud reflectance in nir band
!               3. ab_uv:  cloud absorption in uv band
!               4. ab_nir: cloud absorption in nir band
!               5. em_lw:  longwave cloud emissivity
!
!               Note: Our nir is split, later, into 3 smaller bands
!                     employed in a module created by Steve Klein.
!                     The radiative properties do not vary amongst
!                     those bands.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!
!      NCLDS       number of (random overlapping) clouds in column
!      ICLD          marker array of cloud types/heights (at cloud levels)
!      CLDTOP     indices of model levels where cloud tops of distinct cloud
!                    layers are located. 
!      CLDBAS     indices of model levels where cloud bases of distinct cloud
!                    layers are located.
!      CLDAMT       cloud amount fraction of distinct cloud layers
!      DELP_TRUE  true cloud pressure thickness of distinct cloud layers
!      TEMPCLD    cloud layer mean temperature (degrees Kelvin) of distinct
!                    cloud layers
!      PFULL        pressure at full levels (Pascals)
!      PHALF        pressure at half levels (Pascals)
!                     NOTE: it is assumed that phalf(j+1) > phalf(j)
!      PSFC       Surface pressure field
!      COSZEN     cosine of the zenith angle

! -----------------------------------------------------------------------------
! as of May 1999 these variables are internal to Steve Klein's routine

!      l2strem      logical variable indicating 2 stream operating or not
!                          l2strem = T  2 stream solution to the calculation
!                          of cloud raditive properties
!                          l2strem = F  Delta-Eddington solution to the
!                          calculation of cloud radiative properties.
!
!                            IF l2strem = T then the solution does not
!                            depend on solar zenith angle
!
!                    [ namelist variable in Steve Klein's Cloud_Rad module ]
!
!      taucrit      critical tau for switching direct beam to diffuse beam
!
!                    [ namelist variable in Steve Klein's Cloud_Rad module ]
! -----------------------------------------------------------------------------
!
!       -------------
!OUTPUT:
!       -------------
!
!       r_uv         cloud reflectance in uv band
!       r_nir        cloud reflectance in nir band
!       ab_uv        cloud absorption in uv band
!       ab_nir       cloud absorption in nir band
!       em_lw        longwave cloud emissivity
!
!       -------------
!       The following variables might be elevated to "OUTPUT" status later.
!          They are computed in subroutines called by this subroutine.
!          Perhaps they would be needed for diagnostics purposes.
!          If so, add w0 and gg to the argument list of CLOUD_TAU_DRIVER
!
!       -------------
!       w0           single scattering albedo for each band
!       gg           asymmetry parameter for each band
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       i,j,k,t        looping variable
!       IDIM         number of first dimension points
!       JDIM         number of second dimension points
!       KDIM         number of vertical levels
!       max_cld      maximum number of distinct cloud layers in whole array
!       LWP          cloud liquid water path (kg of condensate per square meter)
!       IWP          cloud ice water path (kg of condensate per squre meter)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
!      For Tony Gordon's v197 scheme only
!
!      L_anom_abs-g Logical namelist variable. If true, anomalous absorption
!                   is represented by a constant value of single scattering
!                   albedo. The default value and the v197 setting are
!                   both false.
!
!      L_anom_abs_v Logical namelist variable. If true, anomalous absorption
!                   is computed as a piecewise continuous function of zonal
!                   mean saturation water vapor mixing ratio at the model's
!                   vertical level closest to the earth's surface. The
!                   default value is false. The analogous namelist variable
!                   in v197, LWALBV is set to TRUE. 
!                   If both L_anom_abs_g and L_anom_abs_v are set to FALSE,
!                   then the single scattering albedo, w0,  assumes its normal
!                   constant value of 0.9942, in tg's version. w0 is a
!                   variable in Steve Klein's version.
!                   L_anom_abs_v takes precedence over L_anom_abs_g, if
!                   the former is TRUE and the latter is FALSE.
!
!     qmix_kx       water vapor mixing ratio at the
!                   model's vertical level closest to the earth's surface.
!                   It is more convenient to pass the zonal mean, in case
!                   single column tests are performed. Alternatively,
!                   the zonal mean could be computed within this subroutine. 
!
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

real, intent(in), dimension(:,:,:) ::    tempcld
real,    intent (in),dimension(:,:)   :: qmix_kx

real,    intent(in), dimension (:,:)  ::  coszen


! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

real,     intent (out),dimension(:,:,:), optional  :: r_uv,r_nir,  &
                           ab_uv,ab_nir,em_lw

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

real,     intent (in   ),dimension(:,:,:,:) :: tau

real, dimension(size(tau,1),size(tau,2),size(tau,3),size(tau,4)) :: w0,gg

real, dimension(size(tau,1),size(tau,2),size(tau,3)) :: lwp,iwp

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




!compute cloud radiative properties



if (present(em_lw)) then
          call cloud_opt_prop_tg(lwp,iwp,tau,w0,gg,tempcld,qmix_kx,  &
       em_lw=em_lw)
        else
          call cloud_opt_prop_tg(lwp,iwp,tau,w0,gg,tempcld,qmix_kx)
endif
 
!  From Steve Klein's cloud_rad_mod

        if (present(r_uv)) then
            call cloud_rad(tau,w0,gg,coszen,r_uv,r_nir,ab_uv,ab_nir)
        endif

!--------------------------------------------------------------------


END SUBROUTINE CLOUD_TAU_DRIVER





!########################################################################
subroutine cloud_pres_thick_for_tau (nclds,icld,cldtop,cldbas, &
     &          delp_true,lhight,lhighb, lmidt, lmidb, llowt,lk,delp, &
     &          phalf, psfc )

! This subroutine calculates a special cloud-type dependent set of 
! cloud pressure thicknesses that will be employed to compute cloud optical
! depths.

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

!  parameters used in this routine 
!
! standard optical pressure thickness quantities (hPa)
REAL, PARAMETER :: delp_high = 31.25, delp_mid = 75.0, delp_low = 112.5
REAL, PARAMETER :: delp_high_thk = 2.0*delp_high, delp_cnv = 112.5
REAL, PARAMETER :: delp_high_thk_anvil = 2.0*delp_high
! REAL, PARAMETER :: delp_strat = 112.5, delp_min = 25.0, delp_thk_crit = 125.0
! impose v197 value for delp_min
REAL, PARAMETER :: delp_strat = 112.5, delp_min = 9.0, delp_thk_crit = 125.0

! delp_high - standard specified pressure thickness for high (warm) clouds,
!             which is used to compute their optical depth.
! delp_mid -  standard specified pressure thickness for middle (warm) clouds,
!             which is used to compute their optical depth.
! delp_low -  standard specified pressure thickness for low (warm) clouds, 
!             which is used to compute their optical depth, 
!             provided that those clouds are not too close to the ground.
! delp_high_thk - specified pressure thickness  for high clouds (other than 
!             precipitating convective clouds), whose true cloud pressure
!             thickness exceeds delp_thk_crit, and 
!             which is used to compute their optical depth.
! delp_high_thk_anvil - specified pressure thickness  for anvil cirrus clouds 
!             whose true cloud pressure thickness exceeds delp_thk_crit, and
!             which is used to compute their optical depth.
! delp_cnv -  cloud optical depth for precipitating convective clouds with
!             bases in the "low" cloud region of the atmosphere,
!             which is used to compute their optical depth.
! delp_strat - standard specified pressure thickness for marine stratus clouds,
!             which is used to compute their optical depth.
!             They could be quite optically thick, in some regions, e.g.,
!             off the coast of Peru, based upon ISCCP obs.
! delp_min -  minimum pressure thickness of a cloud layer.
! delp_thk_crit - critical true cloud pressure thickness, which, if exceeded,
!             signifies a thick stratiform cloud.

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


! Arguments (intent in)

real,    intent(in), dimension(:,:,:) :: phalf, delp_true
integer, intent(in), dimension(:,:,:) :: cldtop,cldbas,icld
integer, intent(in), dimension(:,:)   ::  nclds
integer, intent(in), dimension(:,:)   :: lhight, lhighb, lmidt, lmidb, llowt
integer, intent(in)                   :: lk
real,    intent(in), dimension (:,:)  ::  psfc

!      INPUT
!      ------

!       PHALF        pressure at half levels (Pascals)
!                     NOTE: it is assumed that phalf(j+1) > phalf(j)
!       PSFC         Surface pressure field
!       NCLDS       number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!       ICLD          marker array of cloud types/heights (at cloud levels)
!       CLDTOP     index of cloud tops (at cloud levels)
!       CLDBAS     index of cloud bottoms (at cloud levels)
!       DELP_TRUE  true cloud pressure thickness of distinct cloud layers 
!                    (at cloud levels - in Pa)
!       LHIGHT        vertical level index upper limit for high cloud tops
!       LHIGHB        vertical level index lower limit for high cloud bases
!       LMIDT         vertical level index upper limit for mid cloud tops
!       LMIDB         vertical level index lower limit for mid cloud bases
!       LLOWT         vertical level index upper limit for low cloud tops
!       LK            vertical level below which no low cloud bases can exist

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

! Arguments (intent out)

real, intent(out), dimension(:,:,:) :: delp

!      OUTPUT
!      ------

!      DELP     cloud pressure thickness used to calculate cloud optical depths 
!                   of distinct cloud layers
!=======================================================================
!  (Intent local)

 integer, dimension (size(cldtop,1),size(cldtop,2)) :: cldt,cldb,icwork
 real, dimension (size(cldtop,1),size(cldtop,2)) :: delpstd,pwork

! scalars
 integer k, max_cld, idim, jdim, kmaxp

 integer i, j

!      DELP_STD     tentative cloud pressure thickness values 
!                   (at cloud levels)
!      CLDT, CLDB   work arrays for cloud top,base indices
!      ICWORK       cloud type marker work array at cloud levels 
!      PWORK        work array for pressure values at cloud levels (hPa)

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

! define horizontal dimensions

  idim = SIZE( cldtop, 1 )
  jdim = SIZE( cldtop, 2 )
  kmaxp = SIZE( phalf, 3 )


! Initialize cloud pressure thickness array
      delp = 0.0

! find maximum number of cloud levels
      max_cld  = maxval(nclds(:,:))
                   if (max_cld .ge. 1) then

!-----------------------------------------------------------------------
! <><><><><><><><>   calc cloud press thickness <><><><><><><><>
!-----------------------------------------------------------------------

      do k = 1,max_cld

! Initialize internal arrays
      cldt = kmaxp
      cldb = 0
      icwork = 0
      pwork = 0.0
      delpstd = 0.0
         where (nclds(:,:) .ge. k)
           cldt(:,:) = cldtop(:,:,k)      
           cldb(:,:) = cldbas(:,:,k) 
         end where

! separate cloud type marker from cloud height marker
         icwork(:,:) = mod(icld(:,:,k),100)

! fill array pwork with the pressure difference value of the half level 
! corresponding to the cloud top level cldt and the surface pressure
! also convert from Pa to hPa
         do j=1,jdim
         do i=1,idim
           pwork(i,j) = (psfc(i,j) - phalf(i,j,cldt(i,j)))*.01
         end do
         end do

         where (cldb(:,:) .ge. lhight(:,:) .and. cldb(:,:) .le. lhighb(:,:) )
           delpstd(:,:) = delp_high
         end where

         where (cldb(:,:) .ge. lmidt(:,:) .and. cldb(:,:) .le. lmidb(:,:) )
           delpstd(:,:) = delp_mid
         end where

         where ( (cldb(:,:) .ge. llowt(:,:) .and. cldb(:,:) .le. lk) .and. &
     &                 (pwork(:,:) .ge. delp_low) )
           delpstd(:,:) = delp_low
         end where

         where ( (cldb(:,:) .ge. llowt(:,:) .and. cldb(:,:) .le. lk) .and. &
     &                 (pwork(:,:) .lt. delp_low) )
           delpstd(:,:) = max(pwork(:,:), delp_min)
         end where


! tentative value of cloud pressure thickness used in cloud optical depth calc
         where (cldb(:,:) .ge. lhight(:,:) .and. cldb(:,:) .le. lk)
           delp(:,:,k) = delpstd(:,:)
         end where
! redefine cloud pressure thickness for precipitating convective clouds with
! low cloud bases so that a small value such as delp_min is not a possiblity
         where (cldb(:,:) .ge. llowt(:,:) .and. cldb(:,:) .le. (lk-1) .and. &
     &               icwork(:,:) .eq. 5)
           delp(:,:,k) = delp_cnv
         end where

! use pwork to store delp_true  converted from Pa to hPa
         pwork(:,:) = delp_true(:,:,k)*.01

! redefine cloud pressure thickness for thick, high stratiform clouds
         where ( (cldb(:,:) .ge. lhight(:,:) .and. &
     &            cldb(:,:) .le. lhighb(:,:)) .and. &
     &           (pwork(:,:) .gt. delp_thk_crit) .and. &
     &           (icwork(:,:) .eq. 1) )
           delp(:,:,k) = delp_high_thk
         end where
! redefine cloud pressure thickness for thick, anvil cirrus clouds
         where ( (cldb(:,:) .ge. lhight(:,:) .and. &
     &            cldb(:,:) .le. lhighb(:,:)) .and. &
     &           (pwork(:,:) .gt. delp_thk_crit) .and. &
     &           (icwork(:,:) .ge. 6) )
           delp(:,:,k) = delp_high_thk_anvil
         end where
! redefine cloud pressure thickness for marine stratus clouds
         where ( (cldb(:,:) .ge. llowt(:,:) .and. cldb(:,:) .le. lk) .and. &
     &           (cldb(:,:) .eq. cldt(:,:)) .and. (icwork(:,:) .eq. 3) )
           delp(:,:,k) = min(delpstd(:,:),delp_strat)
         end where

      end do

      
                   endif

end subroutine cloud_pres_thick_for_tau

!########################################################################

subroutine cloud_optical_depths2 (nclds,icld,cldtop,cldbas,tempcld,delp, &
     &          tau,phalf,           liq_frac )

! This subroutine specifies/crudely parameterizes cloud optical depths 
! of non-anvil cirrus clouds based upon a parameterization scheme 
! resembling that proposed by Harshvardhan,
! (which is based on observations by Platt and Harshvardhan).

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

!  namelist quantities used in this routine (defined in module intro above).

!     l_har_anvil - logical variable = t -> anvil and super anvil cirrus
!                 clouds are treated as warm clouds.
!     l_har_coldcld - logical variable = t -> activates cold cloud portion
!                 of Harshvardhan scheme.
!===================================================================

!  parameters used in this routine 

REAL, PARAMETER :: ctok = 273.16, t_ref = ctok - 82.5 
REAL, PARAMETER :: t_warm = ctok, t_cold = ctok-10.0
REAL, PARAMETER :: temp_dif_min = 1.0, inv_delta_t = 1./(t_warm-t_cold)
REAL, PARAMETER :: harshb_std = 0.08, harshb_cnv = 2.0*harshb_std
REAL, PARAMETER :: harshb_anvil = harshb_std, harshb_super_anvil = harshb_std
! The following value is 6 times larger than suggested by Platt-Harshvardan.
! The new value boosts the cold cloud emissivities in the tropics, giving
! closer agreement with ERBE.
REAL, PARAMETER :: harsha_cold = 12.8e-06

! ctok -      freezing point in deg. K..
! t_ref -     a reference minimum permitted cloud temperature in the
!             Harshvardan parameterization.
! t_warm -    the lowest temperature the cloud layer can have and still 
!             be considered warm.
! t_cold -    the highest temperature the cloud layer can have and still 
!             be considered cold. 
! temp_dif_min - the minimum temperature difference to be used in the 
!             computation of Platt-Harshvardhan cold cloud optical depths.
! inv_delta_t =  1./(t_warm-t_cold)
! harshb_std - Harshvardan coefficient for a "standard" cloud layer 
! harshb_cnv - Harshvardan coefficient for convective clouds treated as warm 
! harshb_anvil - Harshvardan coefficient for anvil cirrus clouds 
! harshb_super_anvil - Harshvardan coefficient for super anvil cirrus clouds 
! harsha_cold - Harshvardan coefficient for a cold high cloud 

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


! Arguments (intent in)

real, intent(in), dimension(:,:,:)    :: phalf, delp, tempcld
integer, intent(in), dimension(:,:,:) :: cldtop,cldbas,icld
integer, intent(in), dimension(:,:)   ::  nclds

!      INPUT
!      ------

!       PHALF        pressure at half levels (Pascals)
!                     NOTE: it is assumed that phalf(j+1) > phalf(j)
!       NCLDS       number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!      ICLD          marker array of cloud types (at cloud levels)
!      CLDTOP     index of cloud tops (at cloud levels)
!      CLDBAS     index of cloud bottoms (at cloud levels)
!      TEMPCLD    cloud layer mean temperature 
!                 (degrees Kelvin, at cloud levels)
!      DELP      cloud pressure thickness used for cloud optical depth 
!                   (at cloud levels)

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

! Arguments (intent out)

real, intent(inout), dimension(:,:,:,:) :: tau
real, intent(inout), dimension(:,:,:) ::           liq_frac

!      OUTPUT
!      ------

!      TAU     cloud optical depth (at cloud levels)

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

!  (Intent local)

 integer, dimension (size(cldtop,1),size(cldtop,2)) :: cldt,cldb,icwork
 real, dimension (size(cldtop,1),size(cldtop,2)) :: & 
                                          temp_dif,tau_cold,tau_warm,pwork
 real, dimension (size(tau,1),size(tau,2),size(tau,3) )  :: tau_vis

! scalars
 integer i, j, idim, jdim, kmaxp
 integer k, max_cld
 integer n, max_band

! real 

!      CLDT, CLDB   work arrays for cloud top,base indices
!      TAU_COLD     cloud optical depth work array for cold calculation in
!                   transition regime 
!      TAU_WARM     cloud optical depth work array for warm calculation in
!                   transition regime 
!      TEMP_DIF     work array for temperature diference of distinct cloud
!                   layers 
!      ICWORK       cloud type marker work array of distinct cloud layers
!      PWORK        work array for pressure values at cloud levels (hPa) 
!      TAU_VIS      work array for cloud optical depth in visible part
!                   of spectrum
!      MAX_BAND     maximum number of radiative bands for cloud optical depth
!      MAX_CLD      maximum number of distinct cloud layers within a 
!                   vertical column

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


! define horizontal dimensions

  idim = SIZE( cldtop, 1 )
  jdim = SIZE( cldtop, 2 )
  kmaxp = SIZE( phalf, 3 )


! find maximum number of cloud levels
      max_cld  = maxval(nclds(:,:))

! define maximum number of wave number bands for tau
      max_band = size(tau,4)


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

! Initialize working and final cloud optical depth arrays
      tau_vis = 0.0
      tau     = 0.0

! find maximum number of clouds
      max_cld  = maxval(nclds(:,:))
                   if (max_cld .ge. 1) then

!-----------------------------------------------------------------------
! <><><><><><><><>   calc cloud optical depths <><><><><><><><>
!-----------------------------------------------------------------------

      do k = 1,max_cld

! Initialize internal arrays
      cldt = kmaxp
      cldb = 0
      icwork = 0
         where (nclds(:,:) .ge. k)
           cldt(:,:) = cldtop(:,:,k)      
           cldb(:,:) = cldbas(:,:,k) 
         end where

! fill array pwork with pressure values at the half level corresponding
! to the cloud top level cldt and convert from Pa to hPa
         do j=1,jdim
         do i=1,idim
           pwork(i,j) = phalf(i,j,cldt(i,j))*.01
         end do
         end do

! separate cloud type marker from cloud height marker
         icwork(:,:) = mod(icld(:,:,k),100)

! Standard case: warm cloud treatment will be applied to warm and cold clouds.
! Later, the cold cloud cases will be re-computed, if namelist parameter
! l_har_coldcld is set to true.

! preliminary optical depths computed everywhere

         tau_vis(:,:,k) = harshb_std * delp(:,:,k)

! redefine tau_vis for convective clouds, which are always treated as warm
         where (icwork(:,:) .eq. 5)
           tau_vis(:,:,k) = harshb_anvil * delp(:,:,k)
         end where

                   if (l_har_anvil) then
! redefine tau_vis for high clouds that meet the anvil cirrus criterion
         where (icld(:,:,k) .eq. 106)
           tau_vis(:,:,k) = harshb_anvil * delp(:,:,k)
         end where

! redefine tau_vis for high clouds that meet the super anvil cirrus criterion
         where (icld(:,:,k) .eq. 107)
           tau_vis(:,:,k) = harshb_super_anvil * delp(:,:,k)
         end where
                   endif

                   if (l_har_coldcld .and. l_har_anvil ) then

! ordinary rhum cirrus clouds: redefine tau_vis for cold regime and
! transition regime
         where (icld(:,:,k) .eq. 101 .and. (tempcld(:,:,k).le.t_cold))
! compute Platt-Harshvardhan optical depths in cold cloud regime
           temp_dif(:,:) = max ( (tempcld(:,:,k)-t_ref), temp_dif_min)
           tau_vis(:,:,k) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
         end where

         where (icld(:,:,k) .eq. 101 .and.  &
     &             (tempcld(:,:,k).gt.t_cold .and. tempcld(:,:,k).lt.t_warm))
! compute Platt-Harshvardhan optical depths in the transition regime,
! by linearly interpolating solutions from the cold and warm regimes
! with respect to temperature
           temp_dif(:,:) = t_cold - t_ref
           tau_cold(:,:) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
           tau_warm(:,:) = harshb_std * delp(:,:,k)
           tau_vis(:,:,k) = tau_cold(:,:) + (tau_warm(:,:)-tau_cold(:,:)) * &
     &              (tempcld(:,:,k)-t_cold) * inv_delta_t 
         end where

                   endif

                   if (l_har_coldcld .and. (.not.l_har_anvil) ) then

! ordinary rhum cirrus clouds: redefine tau_vis for cold regime and
! transition regime
         where ( (icld(:,:,k) .eq. 101 .or. icld(:,:,k) .eq. 106 .or. &
     &            icld(:,:,k) .eq. 107) .and. &
     &              (tempcld(:,:,k).le.t_cold))
! compute Platt-Harshvardhan optical depths in cold cloud regime
           temp_dif(:,:) = max ( (tempcld(:,:,k)-t_ref), temp_dif_min)
           tau_vis(:,:,k) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
         end where

         where ( (icld(:,:,k) .eq. 101 .or. icld(:,:,k) .eq. 106 .or. &
     &            icld(:,:,k) .eq. 107) .and. &
     &             (tempcld(:,:,k).gt.t_cold .and. tempcld(:,:,k).lt.t_warm))
! compute Platt-Harshvardhan optical depths in the transition regime,
! by linearly interpolating solutions from the cold and warm regimes
! with respect to temperature
           temp_dif(:,:) = t_cold - t_ref
           tau_cold(:,:) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
           tau_warm(:,:) = harshb_std * delp(:,:,k)
           tau_vis(:,:,k) = tau_cold(:,:) + (tau_warm(:,:)-tau_cold(:,:)) * &
     &              (tempcld(:,:,k)-t_cold) * inv_delta_t 
         end where

                   endif


      end do


!  The cloud optical depths of all four wave number bands are set equal to 
!  tau_vis, i.e., the value in the visible band.

     do n=1,max_band
           tau(:,:,:,n) = tau_vis(:,:,:)
     end do

        WHERE (tau(:,:,:,:) .lt. taumin)
               tau(:,:,:,:) = taumin
        END WHERE

         call  CLOUD_OPT_PROP_tg2 (tau, tempcld,           liq_frac)

                   else
     liq_frac = 0.0
                   endif

end subroutine cloud_optical_depths2




subroutine cloud_optical_depths (nclds,icld,cldtop,cldbas,tempcld,delp, &
     &          tau,phalf )

! This subroutine specifies/crudely parameterizes cloud optical depths 
! of non-anvil cirrus clouds based upon a parameterization scheme 
! resembling that proposed by Harshvardhan,
! (which is based on observations by Platt and Harshvardhan).

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

!  namelist quantities used in this routine (defined in module intro above).

!     l_har_anvil - logical variable = t -> anvil and super anvil cirrus
!                 clouds are treated as warm clouds.
!     l_har_coldcld - logical variable = t -> activates cold cloud portion
!                 of Harshvardhan scheme.
!===================================================================

!  parameters used in this routine 

REAL, PARAMETER :: ctok = 273.16, t_ref = ctok - 82.5 
REAL, PARAMETER :: t_warm = ctok, t_cold = ctok-10.0
REAL, PARAMETER :: temp_dif_min = 1.0, inv_delta_t = 1./(t_warm-t_cold)
REAL, PARAMETER :: harshb_std = 0.08, harshb_cnv = 2.0*harshb_std
REAL, PARAMETER :: harshb_anvil = harshb_std, harshb_super_anvil = harshb_std
! The following value is 6 times larger than suggested by Platt-Harshvardan.
! The new value boosts the cold cloud emissivities in the tropics, giving
! closer agreement with ERBE.
REAL, PARAMETER :: harsha_cold = 12.8e-06

! ctok -      freezing point in deg. K..
! t_ref -     a reference minimum permitted cloud temperature in the
!             Harshvardan parameterization.
! t_warm -    the lowest temperature the cloud layer can have and still 
!             be considered warm.
! t_cold -    the highest temperature the cloud layer can have and still 
!             be considered cold. 
! temp_dif_min - the minimum temperature difference to be used in the 
!             computation of Platt-Harshvardhan cold cloud optical depths.
! inv_delta_t =  1./(t_warm-t_cold)
! harshb_std - Harshvardan coefficient for a "standard" cloud layer 
! harshb_cnv - Harshvardan coefficient for convective clouds treated as warm 
! harshb_anvil - Harshvardan coefficient for anvil cirrus clouds 
! harshb_super_anvil - Harshvardan coefficient for super anvil cirrus clouds 
! harsha_cold - Harshvardan coefficient for a cold high cloud 

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


! Arguments (intent in)

real, intent(in), dimension(:,:,:)    :: phalf, delp, tempcld
integer, intent(in), dimension(:,:,:) :: cldtop,cldbas,icld
integer, intent(in), dimension(:,:)   ::  nclds

!      INPUT
!      ------

!       PHALF        pressure at half levels (Pascals)
!                     NOTE: it is assumed that phalf(j+1) > phalf(j)
!       NCLDS       number of (random overlapping) clouds in column and also
!                     the current # for clouds to be operating on
!      ICLD          marker array of cloud types (at cloud levels)
!      CLDTOP     index of cloud tops (at cloud levels)
!      CLDBAS     index of cloud bottoms (at cloud levels)
!      TEMPCLD    cloud layer mean temperature 
!                 (degrees Kelvin, at cloud levels)
!      DELP      cloud pressure thickness used for cloud optical depth 
!                   (at cloud levels)

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

! Arguments (intent out)

real, intent(out), dimension(:,:,:,:) :: tau

!      OUTPUT
!      ------

!      TAU     cloud optical depth (at cloud levels)

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

!  (Intent local)

 integer, dimension (size(cldtop,1),size(cldtop,2)) :: cldt,cldb,icwork
 real, dimension (size(cldtop,1),size(cldtop,2)) :: & 
                                          temp_dif,tau_cold,tau_warm,pwork
 real, dimension (size(tau,1),size(tau,2),size(tau,3) )  :: tau_vis

! scalars
 integer i, j, idim, jdim, kmaxp
 integer k, max_cld
 integer n, max_band

! real 

!      CLDT, CLDB   work arrays for cloud top,base indices
!      TAU_COLD     cloud optical depth work array for cold calculation in
!                   transition regime 
!      TAU_WARM     cloud optical depth work array for warm calculation in
!                   transition regime 
!      TEMP_DIF     work array for temperature diference of distinct cloud
!                   layers 
!      ICWORK       cloud type marker work array of distinct cloud layers
!      PWORK        work array for pressure values at cloud levels (hPa) 
!      TAU_VIS      work array for cloud optical depth in visible part
!                   of spectrum
!      MAX_BAND     maximum number of radiative bands for cloud optical depth
!      MAX_CLD      maximum number of distinct cloud layers within a 
!                   vertical column

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


! define horizontal dimensions

  idim = SIZE( cldtop, 1 )
  jdim = SIZE( cldtop, 2 )
  kmaxp = SIZE( phalf, 3 )


! find maximum number of cloud levels
      max_cld  = maxval(nclds(:,:))

! define maximum number of wave number bands for tau
      max_band = size(tau,4)


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

! Initialize working and final cloud optical depth arrays
      tau_vis = 0.0
      tau     = 0.0

! find maximum number of clouds
      max_cld  = maxval(nclds(:,:))
                   if (max_cld .ge. 1) then

!-----------------------------------------------------------------------
! <><><><><><><><>   calc cloud optical depths <><><><><><><><>
!-----------------------------------------------------------------------

      do k = 1,max_cld

! Initialize internal arrays
      cldt = kmaxp
      cldb = 0
      icwork = 0
         where (nclds(:,:) .ge. k)
           cldt(:,:) = cldtop(:,:,k)      
           cldb(:,:) = cldbas(:,:,k) 
         end where

! fill array pwork with pressure values at the half level corresponding
! to the cloud top level cldt and convert from Pa to hPa
         do j=1,jdim
         do i=1,idim
           pwork(i,j) = phalf(i,j,cldt(i,j))*.01
         end do
         end do

! separate cloud type marker from cloud height marker
         icwork(:,:) = mod(icld(:,:,k),100)

! Standard case: warm cloud treatment will be applied to warm and cold clouds.
! Later, the cold cloud cases will be re-computed, if namelist parameter
! l_har_coldcld is set to true.

! preliminary optical depths computed everywhere

         tau_vis(:,:,k) = harshb_std * delp(:,:,k)

! redefine tau_vis for convective clouds, which are always treated as warm
         where (icwork(:,:) .eq. 5)
           tau_vis(:,:,k) = harshb_anvil * delp(:,:,k)
         end where

                   if (l_har_anvil) then
! redefine tau_vis for high clouds that meet the anvil cirrus criterion
         where (icld(:,:,k) .eq. 106)
           tau_vis(:,:,k) = harshb_anvil * delp(:,:,k)
         end where

! redefine tau_vis for high clouds that meet the super anvil cirrus criterion
         where (icld(:,:,k) .eq. 107)
           tau_vis(:,:,k) = harshb_super_anvil * delp(:,:,k)
         end where
                   endif

                   if (l_har_coldcld .and. l_har_anvil ) then

! ordinary rhum cirrus clouds: redefine tau_vis for cold regime and
! transition regime
         where (icld(:,:,k) .eq. 101 .and. (tempcld(:,:,k).le.t_cold))
! compute Platt-Harshvardhan optical depths in cold cloud regime
           temp_dif(:,:) = max ( (tempcld(:,:,k)-t_ref), temp_dif_min)
           tau_vis(:,:,k) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
         end where

         where (icld(:,:,k) .eq. 101 .and.  &
     &             (tempcld(:,:,k).gt.t_cold .and. tempcld(:,:,k).lt.t_warm))
! compute Platt-Harshvardhan optical depths in the transition regime,
! by linearly interpolating solutions from the cold and warm regimes
! with respect to temperature
           temp_dif(:,:) = t_cold - t_ref
           tau_cold(:,:) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
           tau_warm(:,:) = harshb_std * delp(:,:,k)
           tau_vis(:,:,k) = tau_cold(:,:) + (tau_warm(:,:)-tau_cold(:,:)) * &
     &              (tempcld(:,:,k)-t_cold) * inv_delta_t 
         end where

                   endif

                   if (l_har_coldcld .and. (.not.l_har_anvil) ) then

! ordinary rhum cirrus clouds: redefine tau_vis for cold regime and
! transition regime
         where ( (icld(:,:,k) .eq. 101 .or. icld(:,:,k) .eq. 106 .or. &
     &            icld(:,:,k) .eq. 107) .and. &
     &              (tempcld(:,:,k).le.t_cold))
! compute Platt-Harshvardhan optical depths in cold cloud regime
           temp_dif(:,:) = max ( (tempcld(:,:,k)-t_ref), temp_dif_min)
           tau_vis(:,:,k) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
         end where

         where ( (icld(:,:,k) .eq. 101 .or. icld(:,:,k) .eq. 106 .or. &
     &            icld(:,:,k) .eq. 107) .and. &
     &             (tempcld(:,:,k).gt.t_cold .and. tempcld(:,:,k).lt.t_warm))
! compute Platt-Harshvardhan optical depths in the transition regime,
! by linearly interpolating solutions from the cold and warm regimes
! with respect to temperature
           temp_dif(:,:) = t_cold - t_ref
           tau_cold(:,:) = harsha_cold * temp_dif(:,:)**2 * delp(:,:,k)
           tau_warm(:,:) = harshb_std * delp(:,:,k)
           tau_vis(:,:,k) = tau_cold(:,:) + (tau_warm(:,:)-tau_cold(:,:)) * &
     &              (tempcld(:,:,k)-t_cold) * inv_delta_t 
         end where

                   endif


      end do


!  The cloud optical depths of all four wave number bands are set equal to 
!  tau_vis, i.e., the value in the visible band.

     do n=1,max_band
           tau(:,:,:,n) = tau_vis(:,:,:)
     end do

        WHERE (tau(:,:,:,:) .lt. taumin)
               tau(:,:,:,:) = taumin
        END WHERE
                   endif


end subroutine cloud_optical_depths

!########################################################################

subroutine CLOUD_OPT_PROP_tg(LWP,IWP,       &
                        tau,w0,gg,          &
                        tempcld,qmix_kx, em_lw )

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following optical properties
!      for each cloud:
!
!               1. tau    :optical depth in each band
!               2. w0     :single scattering albedo for each band
!               3. gg     :asymmetry parameter for each band
!               4. em_lw  :longwave cloud emissivity
!
!   The formulas for optical depth come from Slingo (1989) for liquid
!   clouds and from Ebert and Curry (1992) for ice clouds.
!
!   Slingo (1989) is at J. Atmos. Sci., vol. 46, pp. 1419-1427
!   Ebert and Curry (1992) is at J. Geophys. Res., vol. 97, pp. 3831-3836
!
!                    IMPORTANT!!!
!
!    NOTE WE ARE CHEATING HERE BECAUSE WE ARE FORCING THE FIVE BAND
!    MODEL OF EBERT AND CURRY INTO THE FOUR BAND MODEL OF SLINGO
!
!    THIS IS DONE BY COMBINING BANDS 3 and 4 OF EBERT AND CURRY TOGETHER
!
!   EVEN SO THE EXACT BAND LIMITS DO NOT MATCH.  FOR COMPLETENESS
!   HERE ARE THE BAND LIMITS IN MICRONS
!
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!
! *************************    WARNING    *****************************
!
!   The above bands are used by Steve Klein.
!   We retain the scheme from the v197 frozen model,instead.
!   Nominally, our band 2 is expanded into bands 2 + 3 + 4 of Slingo.
!   The same cloud optical depth is specified in all 4 bands.
!   The same asymmetry parameter is specified in all 4 bands.
!   For single scattering albedo w0, the uv value is specified in band 1,
!   while the nir value is specified in bands 2, 3, and 4.

!   ****  WARNING    ****  The code is intended to be applied to 2 to 4 bands.
!   An error check to check that this condition is satisfied is advised.  

! *********************************************************************
!            BAND               v197     
!             1               0.25-0.70
!             2               0.70-4.00
! *********************************************************************
!
!

!
!   The mixed phase optical properties are based upon equation 14
!   of Rockel et al. 1991, Contributions to Atmospheric Physics,
!   volume 64, pp.1-12.   These equations are:
!
!   (1)    tau = tau_liq + tau_ice
!
!   (2)    w0  =   ( w0_liq * tau_liq  +  w0_ice * tau_ice ) /
!                  (          tau_liq  +           tau_ice )
!
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = 0.9942  (in v197 - standard)
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = F(Z.M. mixing ratio at lowest model level)
!                                    (in v197 - anomalous absorption)
!
!   (3)     g  = ( g_liq * w0_liq * tau_liq +  g_ice * w0_ice * tau_ice ) /
!                (         w0_liq * tau_liq +          w0_ice * tau_ice )
!
!           g(:,:,1:2) = 0.85 in v197
!   
!
!   (4) transmivvity_lw =   transmissivity_lw_ice * transmissivity_lw_liq
!
!    The last equation could be rewritten, after algebraic manipulation, as:
!
!   (5)  em_lw =  em_lw_liq + em_lw_ice -  (em_lw_liq * em_lw_ice )
!
!    However, the other form of the equation, i.e., 
!    1 - exp(tau_liq + tau_ice) will actually be solved.

! *******************************************************************
!
!
!   (6)  v197 only: Must first solve for LWP and IWP knowing
!                   tau, k_sw_liq, k_sw_ice, wgt_liq and wgt_ice.
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!


!      L_anom_abs-g Logical namelist variable. If true, anomalous absorption
!                   is represented by a constant value of single scattering
!                   albedo. The default value and the v197 setting are
!                   both false.
!
!      L_anom_abs_v Logical namelist variable. If true, anomalous absorption
!                   is computed as a piecewise continuous function of zonal
!                   mean saturation water vapor mixing ratio at the model's
!                   vertical level closest to the earth's surface. The
!                   default value is false. The analogous namelist variable
!                   in v197, LWALBV is set to TRUE. 
!                   If both L_anom_abs_g and L_anom_abs_v are set to FALSE,
!                   then the single scattering albedo, w0,  assumes its normal
!                   constant value of 0.9942, in tg's version. w0 is a
!                   variable in Steve Klein's version.
!                   L_anom_abs_v takes precedence over L_anom_abs_g, if
!                   the former is TRUE and the latter is FALSE.
!
!     qmix_kx    Zonal mean saturation water vapor mixing ratio at the
!                   model's vertical level closest to the earth's surface.
!                   It is more convenient to pass the zonal mean, in case
!                   single column tests are performed. Alternatively,
!                   the zonal mean could be computed within this subroutine. 
!
!      tempcld      cloud layer mean temperature (degrees Kelvin), with
!                   compressed cloud layer index.
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!       ------------
!INPUT/OUTPUT:
!       ------------
!
!      tau          optical depth in each band
!      w0           single scattering albedo for each band
!      gg           asymmetry parameter for each band
!      em_lw        longwave cloud emissivity

!            NOTE:  In tg's version, LWP and IWP are effective cloud
!                   water paths. They could be computed either in this
!                   subroutine or in subroutine cloud_water_path.

!      LWP          cloud liquid water path (kg of condensate per square meter)
!      IWP          cloud ice path (kg of condensate per square meter)
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       tau_liq      optical depth            at each band for cloud liquid
!       tau_ice      optical depth            at each band for cloud ice
!       w0_liq       single scattering albedo at each band for cloud liquid
!       w0_ice       single scattering albedo at each band for cloud ice
!       g_liq        asymmetry parameter      at each band for cloud liquid
!       g_ice        asymmetry parameter      at each band for cloud ice
!
!
!                   In Tony Gordon's v197 version only.
!
!       CWP           total cloud water path, i.e., cloud liquid plus
!                        cloud ice (kg of condensate per square meter)
!
!                    Parameters (defined above)
!
!       k_lw_liq     liquid cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_lw_ice     ice cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_liq     liquid cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_ice     ice cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!
!       tk_all_ice    minimum temperature at which cloud liquid water phase
!                       can exist (degrees Kelvin)
!       tk_all_liq    maximum temperature at which cloud ice can exist
!                       (degrees Kelvin)
!       wgt_liq       The ratio of liquid water path to total cloud water path,
!                        i.e., LWP / CWP
!       wgt_ice       The ratio of ice water path to total cloud water path,
!                        i.e., IWP / CWP
!
!       qsat_min      Minimum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!       qsat_trans    Transition value of zonal mean saturation mixing ratio
!                        between two branches of a piecewise continuous
!                        function entering into the variable anomalous
!                        absorption single scattering albedo calculations.
!       qsat_max      Maximum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!
!       w0_norm_uv    Normal, constant single scattering albedo in the uv-vis
!                        wavelength band of the radiation spectrum.
!       w0_norm_nir   Normal, constant single scattering albedo in the nir
!                        wavelength band of the radiation spectrum.
!       w0_anom1_nir  Asymptotic minimum value of single scattering albedo
!                        for variable anomalous absorption; also the
!                        low constant value, if L_anom_abs_g is set to TRUE.
!       w0_anom2_nir  Asymptotic maximum value of single scattering albedo
!                        for variable anomalous absorption,usually occurring
!                        at high latitudes.
! 
!       g_norm        Normal, constant asymmetry parameter used in Tony Gordon's
!                        v197 scheme. It is independent of wavelength.                                
!

!      MAX_BAND     maximum number of wave number bands for tau,etc.

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!  in tony gordon's v197 scheme only:
!
real,     intent (in),     dimension(:,:)      :: qmix_kx
real,     intent (in),     dimension(:,:,:)    :: tempcld


!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

real,     intent (in   ),dimension(:,:,:,:)   :: tau
real,     intent (out),dimension(:,:,:,:)   :: w0,gg
real,     intent (out),dimension(:,:,:), optional     :: em_lw

real,     intent (out)   ,dimension(:,:,:)  :: LWP,IWP


! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!  Internal variables
!  ------------------

real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: tau_liq, tau_ice
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: w0_liq, w0_ice
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: g_liq, g_ice
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3))   :: wgt_ice, wgt_liq
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3))   :: cwp
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3))   :: w0_anom_work
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3))   :: qmix_kx_work
integer                                                :: k, kmax
integer                                                :: n, max_band

!  Declare tau_chk to compare with tau, if code needs to be debugged.
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: tau_chk

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!
! Code
! ----

!  define maximum number of wave number bands for tau
      max_band = size(tau,4)

!  For tg v197, tau is previously computed in subroutine cloud_optical_depths,
!  while w0 and gg will be reinitialized.
!  Also, internal variables w0_liq, w0_ice, g_liq, and g_ice
!  will be re-initialized, while tau_liq and tau_ice will not be.

!  Therefore, the only output variable to be initialized is em_lw.
!  Comment out the other reinitialization commands.


!  These are Tony Gordon's reinitialized values.
        gg(:,:,:,:)    = 0.85
        w0(:,:,:,1)    = 0.99999
        w0(:,:,:,2:4)  = 0.9942
if (present (em_lw)) then
        em_lw(:,:,:)   = 0.
endif

        w0_liq(:,:,:,1)   = 0.99999
        w0_liq(:,:,:,2:4) = 0.9942
        w0_ice(:,:,:,1)   = 0.99999
        w0_ice(:,:,:,2:4) = 0.9942
        g_liq(:,:,:,:)    = 0.85
        g_ice(:,:,:,:)    = 0.85

! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

!       Comment out Steve Klein's reinitialized values.
!       tau(:,:,:,:) = 0.
!       gg(:,:,:,:)  = 0.85
!       w0(:,:,:,:)  = 0.95
!       em_lw(:,:,:) = 0.

!       w0_liq(:,:,:,:) = 0.95
!       w0_ice(:,:,:,:) = 0.95
!       tau_liq(:,:,:,:)= 0.
!       tau_ice(:,:,:,:)= 0.



    !---------------   COMPUTE OPTICAL DEPTH ---------------------------!



        ! compute uv cloud optical depths due to liquid
        ! and ice phase separately


!       by Tony Gordon's v197 scheme

        WHERE (tempcld(:,:,:) .le. tk_all_ice)
               wgt_liq(:,:,:) = 0.
               wgt_ice(:,:,:) = 1.
        END WHERE

        WHERE (tempcld(:,:,:) .ge. tk_all_liq)
               wgt_liq(:,:,:) = 1.
               wgt_ice(:,:,:) = 0.
        END WHERE

        WHERE (tempcld(:,:,:) .gt. tk_all_ice .and. tempcld(:,:,:) &
               .lt. tk_all_liq)
               wgt_liq(:,:,:) = (tempcld(:,:,:) - tk_all_ice) / &
                                (tk_all_liq - tk_all_ice)
               wgt_ice(:,:,:) = 1. - wgt_liq(:,:,:)
        END WHERE
                     
        CWP(:,:,:) = tau(:,:,:,1) / &
                     (k_sw_liq * wgt_liq(:,:,:) + &
                      k_sw_ice * wgt_ice(:,:,:) )

        LWP(:,:,:) = wgt_liq(:,:,:) * CWP(:,:,:)
        IWP(:,:,:) = wgt_ice(:,:,:) * CWP(:,:,:)

        tau_liq(:,:,:,1)   = k_sw_liq * LWP(:,:,:)
        tau_ice(:,:,:,1)   = k_sw_ice * IWP(:,:,:)

!  tau_liq and tau_ice are purely diagnostic, since tau is already known.
!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes.

             if (max_band .ge. 2) then
        do n=2,max_band
        tau_liq(:,:,:,n) = tau_liq(:,:,:,1)
        tau_ice(:,:,:,n) = tau_ice(:,:,:,1)
        end do
             endif

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

!  Compute total cloud optical depth, using same formula as Steve Klein.
!  Note:  Comment out the following command in Tony Gordon's v197 scheme.
!         tau should have the same as the input, except for roundoff error.

!         tau(:,:,:,:)     = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)

!  Define tau_chk to compare with tau, if code needs to be debugged.
          tau_chk(:,:,:,:) = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -



   !---------------   COMPUTE SINGLE SCATTERING ALBEDO ----------------!


!
        w0_liq(:,:,:,1) =  w0_norm_uv
        w0_ice(:,:,:,1) =  w0_norm_uv

     IF (.not. L_anom_abs_g .and. .not. L_anom_abs_v) THEN

!       Specify tg's normal single scattering albedos for NIR bands.

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
        w0_liq(:,:,:,n) =  w0_norm_nir
        w0_ice(:,:,:,n) =  w0_norm_nir
        end do
             endif

     ENDIF

     IF (L_anom_abs_g) THEN

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
        w0_liq(:,:,:,n) =  w0_anom1_nir
        w0_ice(:,:,:,n) =  w0_anom1_nir
        end do
             endif

     ENDIF

!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!    Broadcast qmix_kx to generate WHERE statements with correct syntax.

     kmax = SIZE(LWP,3)

     DO k = 1,kmax
        qmix_kx_work(:,:,k) = qmix_kx(:,:)
     END DO
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
! 
     IF (L_anom_abs_v) THEN

       WHERE (qmix_kx_work(:,:,:) .le. qsat_min)

!      Apply lower asymptotic limit to anomalously weak cloud absorption,
!      i.e., upper asymptotic limit of w0.

!      This situation should not occur for saturation mixing ratios. However,
!      negative mixing ratios are possible in the spectral AGCM,
!      especially in cold temperature, e.g., high latitude regions.
!      Retain this WHERE loop, in case parameterization is ever changed 
!      from saturation mixing ratio to mixing ratio.
      
              w0_anom_work(:,:,:) = w0_anom2_nir

       END WHERE 

       WHERE (qmix_kx_work(:,:,:) .gt. qsat_min .and.                  &
              qmix_kx_work(:,:,:) .lt. qsat_trans)

!      Anomalously weak cloud absorption relative to the reference value 
!      w0_norm_nir will tend to occur at higher latitudes for these values
!      of w0.

            w0_anom_work(:,:,:) = w0_anom2_nir -                    &
               (w0_anom2_nir - w0_norm_nir)    *                    &
               ( (qmix_kx_work(:,:,:) - qsat_min) / (qsat_trans - qsat_min))

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .eq. qsat_trans)

!      The reference value of nir single scattering albedo will be used.

           w0_anom_work(:,:,:) = w0_norm_nir

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .gt. qsat_trans .and.                &
              qmix_kx_work(:,:,:) .lt. qsat_max)

!      Anomalously high absorption relative to the reference value w0_norm_nir
!      will tend to occur at tropical and subtropical latitudes for 
!      these values of w0.

           w0_anom_work(:,:,:) = w0_norm_nir  -                    &
              (w0_norm_nir - w0_anom1_nir)    *                    &
              ( (qmix_kx_work(:,:,:) - qsat_trans) / (qsat_max - qsat_trans))

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .ge. qsat_max)

!      Apply upper asymptotic limit to the anomalous absorption, i.e.,
!      lower asymptotic limit of w0.

              w0_anom_work = w0_anom1_nir

       END WHERE

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
       w0_liq(:,:,:,n) = w0_anom_work(:,:,:)
       w0_ice(:,:,:,n) = w0_anom_work(:,:,:)
        end do
             endif

     ENDIF



! compute total single scattering albedo
        WHERE (tau(:,:,:,:) .gt. 0.)
               w0(:,:,:,:) = ( w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                               w0_ice(:,:,:,:) * tau_ice(:,:,:,:) ) / &
                             tau(:,:,:,:)
        END WHERE

   !---------------   COMPUTE ASYMMETRY PARAMETER --------------------!

        WHERE (tau(:,:,:,:) .gt. 0. )
              gg(:,:,:,:) = ( &
                 w0_liq(:,:,:,:) * g_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                 w0_ice(:,:,:,:) * g_ice(:,:,:,:) * tau_ice(:,:,:,:) ) &
                       /          (w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                                   w0_ice(:,:,:,:) * tau_ice(:,:,:,:) )
        END WHERE


   !---------------   COMPUTE LONGWAVE EMISSIVITY --------------------!


       if (present(em_lw)) then
!
!  In Tony Gordon's v197 scheme, k_lw-liq and k_lw_ice are parameters.
!        k_lw_liq(:,:,:) = 140.
!        k_lw_ice(:,:,:) = 100.

! compute combined emmisivity
        em_lw(:,:,:) =  1. - exp( -1. * ( k_lw_liq * LWP(:,:,:) + &
                                          k_lw_ice * IWP(:,:,:) ) )

     endif

   !--------------    RANGE LIMIT QUANTITIES --------------------------!

!       WHERE (tau(:,:,:,:) .lt. taumin)
!              tau(:,:,:,:) = taumin
!       END WHERE


end subroutine CLOUD_OPT_PROP_tg


subroutine CLOUD_OPT_PROP_tg3(LWP,IWP,       &
                        tau,w0,gg,          &
                        tempcld,qmix_kx, em_lw )

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following optical properties
!      for each cloud:
!
!               1. tau    :optical depth in each band
!               2. w0     :single scattering albedo for each band
!               3. gg     :asymmetry parameter for each band
!               4. em_lw  :longwave cloud emissivity
!
!   The formulas for optical depth come from Slingo (1989) for liquid
!   clouds and from Ebert and Curry (1992) for ice clouds.
!
!   Slingo (1989) is at J. Atmos. Sci., vol. 46, pp. 1419-1427
!   Ebert and Curry (1992) is at J. Geophys. Res., vol. 97, pp. 3831-3836
!
!                    IMPORTANT!!!
!
!    NOTE WE ARE CHEATING HERE BECAUSE WE ARE FORCING THE FIVE BAND
!    MODEL OF EBERT AND CURRY INTO THE FOUR BAND MODEL OF SLINGO
!
!    THIS IS DONE BY COMBINING BANDS 3 and 4 OF EBERT AND CURRY TOGETHER
!
!   EVEN SO THE EXACT BAND LIMITS DO NOT MATCH.  FOR COMPLETENESS
!   HERE ARE THE BAND LIMITS IN MICRONS
!
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!
! *************************    WARNING    *****************************
!
!   The above bands are used by Steve Klein.
!   We retain the scheme from the v197 frozen model,instead.
!   Nominally, our band 2 is expanded into bands 2 + 3 + 4 of Slingo.
!   The same cloud optical depth is specified in all 4 bands.
!   The same asymmetry parameter is specified in all 4 bands.
!   For single scattering albedo w0, the uv value is specified in band 1,
!   while the nir value is specified in bands 2, 3, and 4.

!   ****  WARNING    ****  The code is intended to be applied to 2 to 4 bands.
!   An error check to check that this condition is satisfied is advised.  

! *********************************************************************
!            BAND               v197     
!             1               0.25-0.70
!             2               0.70-4.00
! *********************************************************************
!
!

!
!   The mixed phase optical properties are based upon equation 14
!   of Rockel et al. 1991, Contributions to Atmospheric Physics,
!   volume 64, pp.1-12.   These equations are:
!
!   (1)    tau = tau_liq + tau_ice
!
!   (2)    w0  =   ( w0_liq * tau_liq  +  w0_ice * tau_ice ) /
!                  (          tau_liq  +           tau_ice )
!
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = 0.9942  (in v197 - standard)
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = F(Z.M. mixing ratio at lowest model level)
!                                    (in v197 - anomalous absorption)
!
!   (3)     g  = ( g_liq * w0_liq * tau_liq +  g_ice * w0_ice * tau_ice ) /
!                (         w0_liq * tau_liq +          w0_ice * tau_ice )
!
!           g(:,:,1:2) = 0.85 in v197
!   
!
!   (4) transmivvity_lw =   transmissivity_lw_ice * transmissivity_lw_liq
!
!    The last equation could be rewritten, after algebraic manipulation, as:
!
!   (5)  em_lw =  em_lw_liq + em_lw_ice -  (em_lw_liq * em_lw_ice )
!
!    However, the other form of the equation, i.e., 
!    1 - exp(tau_liq + tau_ice) will actually be solved.

! *******************************************************************
!
!
!   (6)  v197 only: Must first solve for LWP and IWP knowing
!                   tau, k_sw_liq, k_sw_ice, wgt_liq and wgt_ice.
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!


!      L_anom_abs-g Logical namelist variable. If true, anomalous absorption
!                   is represented by a constant value of single scattering
!                   albedo. The default value and the v197 setting are
!                   both false.
!
!      L_anom_abs_v Logical namelist variable. If true, anomalous absorption
!                   is computed as a piecewise continuous function of zonal
!                   mean saturation water vapor mixing ratio at the model's
!                   vertical level closest to the earth's surface. The
!                   default value is false. The analogous namelist variable
!                   in v197, LWALBV is set to TRUE. 
!                   If both L_anom_abs_g and L_anom_abs_v are set to FALSE,
!                   then the single scattering albedo, w0,  assumes its normal
!                   constant value of 0.9942, in tg's version. w0 is a
!                   variable in Steve Klein's version.
!                   L_anom_abs_v takes precedence over L_anom_abs_g, if
!                   the former is TRUE and the latter is FALSE.
!
!     qmix_kx    Zonal mean saturation water vapor mixing ratio at the
!                   model's vertical level closest to the earth's surface.
!                   It is more convenient to pass the zonal mean, in case
!                   single column tests are performed. Alternatively,
!                   the zonal mean could be computed within this subroutine. 
!
!      tempcld      cloud layer mean temperature (degrees Kelvin), with
!                   compressed cloud layer index.
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!       ------------
!INPUT/OUTPUT:
!       ------------
!
!      tau          optical depth in each band
!      w0           single scattering albedo for each band
!      gg           asymmetry parameter for each band
!      em_lw        longwave cloud emissivity

!            NOTE:  In tg's version, LWP and IWP are effective cloud
!                   water paths. They could be computed either in this
!                   subroutine or in subroutine cloud_water_path.

!      LWP          cloud liquid water path (kg of condensate per square meter)
!      IWP          cloud ice path (kg of condensate per square meter)
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       tau_liq      optical depth            at each band for cloud liquid
!       tau_ice      optical depth            at each band for cloud ice
!       w0_liq       single scattering albedo at each band for cloud liquid
!       w0_ice       single scattering albedo at each band for cloud ice
!       g_liq        asymmetry parameter      at each band for cloud liquid
!       g_ice        asymmetry parameter      at each band for cloud ice
!
!
!                   In Tony Gordon's v197 version only.
!
!       CWP           total cloud water path, i.e., cloud liquid plus
!                        cloud ice (kg of condensate per square meter)
!
!                    Parameters (defined above)
!
!       k_lw_liq     liquid cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_lw_ice     ice cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_liq     liquid cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_ice     ice cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!
!       tk_all_ice    minimum temperature at which cloud liquid water phase
!                       can exist (degrees Kelvin)
!       tk_all_liq    maximum temperature at which cloud ice can exist
!                       (degrees Kelvin)
!       wgt_liq       The ratio of liquid water path to total cloud water path,
!                        i.e., LWP / CWP
!       wgt_ice       The ratio of ice water path to total cloud water path,
!                        i.e., IWP / CWP
!
!       qsat_min      Minimum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!       qsat_trans    Transition value of zonal mean saturation mixing ratio
!                        between two branches of a piecewise continuous
!                        function entering into the variable anomalous
!                        absorption single scattering albedo calculations.
!       qsat_max      Maximum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!
!       w0_norm_uv    Normal, constant single scattering albedo in the uv-vis
!                        wavelength band of the radiation spectrum.
!       w0_norm_nir   Normal, constant single scattering albedo in the nir
!                        wavelength band of the radiation spectrum.
!       w0_anom1_nir  Asymptotic minimum value of single scattering albedo
!                        for variable anomalous absorption; also the
!                        low constant value, if L_anom_abs_g is set to TRUE.
!       w0_anom2_nir  Asymptotic maximum value of single scattering albedo
!                        for variable anomalous absorption,usually occurring
!                        at high latitudes.
! 
!       g_norm        Normal, constant asymmetry parameter used in Tony Gordon's
!                        v197 scheme. It is independent of wavelength.                                
!

!      MAX_BAND     maximum number of wave number bands for tau,etc.

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!  in tony gordon's v197 scheme only:
!
real,     intent (in),     dimension(:,:)      :: qmix_kx
real,     intent (in),     dimension(:,:,:)    :: tempcld


!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

real,     intent (in   ),dimension(:,:,:,:)   :: tau
real,     intent (out),dimension(:,:,:,:)   :: w0,gg
real,     intent (out),dimension(:,:,:), optional     :: em_lw

real,     intent ( in)   ,dimension(:,:,:)  :: LWP,IWP


! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!  Internal variables
!  ------------------

real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: tau_liq, tau_ice
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: w0_liq, w0_ice
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: g_liq, g_ice
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3))   :: w0_anom_work
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3))   :: qmix_kx_work
integer                                                :: k, kmax
integer                                                :: n, max_band

!  Declare tau_chk to compare with tau, if code needs to be debugged.
real, dimension(size(lwp,1),size(lwp,2),size(lwp,3),4) :: tau_chk

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!
! Code
! ----

!  define maximum number of wave number bands for tau
      max_band = size(tau,4)

!  For tg v197, tau is previously computed in subroutine cloud_optical_depths,
!  while w0 and gg will be reinitialized.
!  Also, internal variables w0_liq, w0_ice, g_liq, and g_ice
!  will be re-initialized, while tau_liq and tau_ice will not be.

!  Therefore, the only output variable to be initialized is em_lw.
!  Comment out the other reinitialization commands.


!  These are Tony Gordon's reinitialized values.
        gg(:,:,:,:)    = 0.85
        w0(:,:,:,1)    = 0.99999
        w0(:,:,:,2:4)  = 0.9942
if (present (em_lw)) then
        em_lw(:,:,:)   = 0.
endif

        w0_liq(:,:,:,1)   = 0.99999
        w0_liq(:,:,:,2:4) = 0.9942
        w0_ice(:,:,:,1)   = 0.99999
        w0_ice(:,:,:,2:4) = 0.9942
        g_liq(:,:,:,:)    = 0.85
        g_ice(:,:,:,:)    = 0.85

! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

!       Comment out Steve Klein's reinitialized values.
!       tau(:,:,:,:) = 0.
!       gg(:,:,:,:)  = 0.85
!       w0(:,:,:,:)  = 0.95
!       em_lw(:,:,:) = 0.

!       w0_liq(:,:,:,:) = 0.95
!       w0_ice(:,:,:,:) = 0.95
!       tau_liq(:,:,:,:)= 0.
!       tau_ice(:,:,:,:)= 0.



    !---------------   COMPUTE OPTICAL DEPTH ---------------------------!



        ! compute uv cloud optical depths due to liquid
        ! and ice phase separately


!       by Tony Gordon's v197 scheme


        tau_liq(:,:,:,1)   = k_sw_liq * LWP(:,:,:)
        tau_ice(:,:,:,1)   = k_sw_ice * IWP(:,:,:)

!  tau_liq and tau_ice are purely diagnostic, since tau is already known.
!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes.

             if (max_band .ge. 2) then
        do n=2,max_band
        tau_liq(:,:,:,n) = tau_liq(:,:,:,1)
        tau_ice(:,:,:,n) = tau_ice(:,:,:,1)
        end do
             endif

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

!  Compute total cloud optical depth, using same formula as Steve Klein.
!  Note:  Comment out the following command in Tony Gordon's v197 scheme.
!         tau should have the same as the input, except for roundoff error.

!         tau(:,:,:,:)     = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)

!  Define tau_chk to compare with tau, if code needs to be debugged.
          tau_chk(:,:,:,:) = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -



   !---------------   COMPUTE SINGLE SCATTERING ALBEDO ----------------!


!
        w0_liq(:,:,:,1) =  w0_norm_uv
        w0_ice(:,:,:,1) =  w0_norm_uv

     IF (.not. L_anom_abs_g .and. .not. L_anom_abs_v) THEN

!       Specify tg's normal single scattering albedos for NIR bands.

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
        w0_liq(:,:,:,n) =  w0_norm_nir
        w0_ice(:,:,:,n) =  w0_norm_nir
        end do
             endif

     ENDIF

     IF (L_anom_abs_g) THEN

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
        w0_liq(:,:,:,n) =  w0_anom1_nir
        w0_ice(:,:,:,n) =  w0_anom1_nir
        end do
             endif

     ENDIF

!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!    Broadcast qmix_kx to generate WHERE statements with correct syntax.

     kmax = SIZE(LWP,3)

     DO k = 1,kmax
        qmix_kx_work(:,:,k) = qmix_kx(:,:)
     END DO
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
! 
     IF (L_anom_abs_v) THEN

       WHERE (qmix_kx_work(:,:,:) .le. qsat_min)

!      Apply lower asymptotic limit to anomalously weak cloud absorption,
!      i.e., upper asymptotic limit of w0.

!      This situation should not occur for saturation mixing ratios. However,
!      negative mixing ratios are possible in the spectral AGCM,
!      especially in cold temperature, e.g., high latitude regions.
!      Retain this WHERE loop, in case parameterization is ever changed 
!      from saturation mixing ratio to mixing ratio.
      
              w0_anom_work(:,:,:) = w0_anom2_nir

       END WHERE 

       WHERE (qmix_kx_work(:,:,:) .gt. qsat_min .and.                  &
              qmix_kx_work(:,:,:) .lt. qsat_trans)

!      Anomalously weak cloud absorption relative to the reference value 
!      w0_norm_nir will tend to occur at higher latitudes for these values
!      of w0.

            w0_anom_work(:,:,:) = w0_anom2_nir -                    &
               (w0_anom2_nir - w0_norm_nir)    *                    &
               ( (qmix_kx_work(:,:,:) - qsat_min) / (qsat_trans - qsat_min))

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .eq. qsat_trans)

!      The reference value of nir single scattering albedo will be used.

           w0_anom_work(:,:,:) = w0_norm_nir

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .gt. qsat_trans .and.                &
              qmix_kx_work(:,:,:) .lt. qsat_max)

!      Anomalously high absorption relative to the reference value w0_norm_nir
!      will tend to occur at tropical and subtropical latitudes for 
!      these values of w0.

           w0_anom_work(:,:,:) = w0_norm_nir  -                    &
              (w0_norm_nir - w0_anom1_nir)    *                    &
              ( (qmix_kx_work(:,:,:) - qsat_trans) / (qsat_max - qsat_trans))

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .ge. qsat_max)

!      Apply upper asymptotic limit to the anomalous absorption, i.e.,
!      lower asymptotic limit of w0.

              w0_anom_work = w0_anom1_nir

       END WHERE

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
       w0_liq(:,:,:,n) = w0_anom_work(:,:,:)
       w0_ice(:,:,:,n) = w0_anom_work(:,:,:)
        end do
             endif

     ENDIF



! compute total single scattering albedo
        WHERE (tau(:,:,:,:) .gt. 0.)
               w0(:,:,:,:) = ( w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                               w0_ice(:,:,:,:) * tau_ice(:,:,:,:) ) / &
                             tau(:,:,:,:)
        END WHERE

   !---------------   COMPUTE ASYMMETRY PARAMETER --------------------!

        WHERE (tau(:,:,:,:) .gt. 0. )
              gg(:,:,:,:) = ( &
                 w0_liq(:,:,:,:) * g_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                 w0_ice(:,:,:,:) * g_ice(:,:,:,:) * tau_ice(:,:,:,:) ) &
                       /          (w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                                   w0_ice(:,:,:,:) * tau_ice(:,:,:,:) )
        END WHERE


   !---------------   COMPUTE LONGWAVE EMISSIVITY --------------------!


       if (present(em_lw)) then
!
!  In Tony Gordon's v197 scheme, k_lw-liq and k_lw_ice are parameters.
!        k_lw_liq(:,:,:) = 140.
!        k_lw_ice(:,:,:) = 100.

! compute combined emmisivity
        em_lw(:,:,:) =  1. - exp( -1. * ( k_lw_liq * LWP(:,:,:) + &
                                          k_lw_ice * IWP(:,:,:) ) )

     endif

   !--------------    RANGE LIMIT QUANTITIES --------------------------!

!       WHERE (tau(:,:,:,:) .lt. taumin)
!              tau(:,:,:,:) = taumin
!       END WHERE


end subroutine CLOUD_OPT_PROP_tg3

subroutine CLOUD_OPT_PROP_tg_lw(               tau, liq_frac, em_lw)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following optical properties
!      for each cloud:
!
!               1. tau    :optical depth in each band
!               2. w0     :single scattering albedo for each band
!               3. gg     :asymmetry parameter for each band
!               4. em_lw  :longwave cloud emissivity
!
!   The formulas for optical depth come from Slingo (1989) for liquid
!   clouds and from Ebert and Curry (1992) for ice clouds.
!
!   Slingo (1989) is at J. Atmos. Sci., vol. 46, pp. 1419-1427
!   Ebert and Curry (1992) is at J. Geophys. Res., vol. 97, pp. 3831-3836
!
!                    IMPORTANT!!!
!
!    NOTE WE ARE CHEATING HERE BECAUSE WE ARE FORCING THE FIVE BAND
!    MODEL OF EBERT AND CURRY INTO THE FOUR BAND MODEL OF SLINGO
!
!    THIS IS DONE BY COMBINING BANDS 3 and 4 OF EBERT AND CURRY TOGETHER
!
!   EVEN SO THE EXACT BAND LIMITS DO NOT MATCH.  FOR COMPLETENESS
!   HERE ARE THE BAND LIMITS IN MICRONS
!
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!
! *************************    WARNING    *****************************
!
!   The above bands are used by Steve Klein.
!   We retain the scheme from the v197 frozen model,instead.
!   Nominally, our band 2 is expanded into bands 2 + 3 + 4 of Slingo.
!   The same cloud optical depth is specified in all 4 bands.
!   The same asymmetry parameter is specified in all 4 bands.
!   For single scattering albedo w0, the uv value is specified in band 1,
!   while the nir value is specified in bands 2, 3, and 4.

!   ****  WARNING    ****  The code is intended to be applied to 2 to 4 bands.
!   An error check to check that this condition is satisfied is advised.  

! *********************************************************************
!            BAND               v197     
!             1               0.25-0.70
!             2               0.70-4.00
! *********************************************************************
!
!

!
!   The mixed phase optical properties are based upon equation 14
!   of Rockel et al. 1991, Contributions to Atmospheric Physics,
!   volume 64, pp.1-12.   These equations are:
!
!   (1)    tau = tau_liq + tau_ice
!
!   (2)    w0  =   ( w0_liq * tau_liq  +  w0_ice * tau_ice ) /
!                  (          tau_liq  +           tau_ice )
!
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = 0.9942  (in v197 - standard)
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = F(Z.M. mixing ratio at lowest model level)
!                                    (in v197 - anomalous absorption)
!
!   (3)     g  = ( g_liq * w0_liq * tau_liq +  g_ice * w0_ice * tau_ice ) /
!                (         w0_liq * tau_liq +          w0_ice * tau_ice )
!
!           g(:,:,1:2) = 0.85 in v197
!   
!
!   (4) transmivvity_lw =   transmissivity_lw_ice * transmissivity_lw_liq
!
!    The last equation could be rewritten, after algebraic manipulation, as:
!
!   (5)  em_lw =  em_lw_liq + em_lw_ice -  (em_lw_liq * em_lw_ice )
!
!    However, the other form of the equation, i.e., 
!    1 - exp(tau_liq + tau_ice) will actually be solved.

! *******************************************************************
!
!
!   (6)  v197 only: Must first solve for LWP and IWP knowing
!                   tau, k_sw_liq, k_sw_ice, wgt_liq and wgt_ice.
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!


!      L_anom_abs-g Logical namelist variable. If true, anomalous absorption
!                   is represented by a constant value of single scattering
!                   albedo. The default value and the v197 setting are
!                   both false.
!
!      L_anom_abs_v Logical namelist variable. If true, anomalous absorption
!                   is computed as a piecewise continuous function of zonal
!                   mean saturation water vapor mixing ratio at the model's
!                   vertical level closest to the earth's surface. The
!                   default value is false. The analogous namelist variable
!                   in v197, LWALBV is set to TRUE. 
!                   If both L_anom_abs_g and L_anom_abs_v are set to FALSE,
!                   then the single scattering albedo, w0,  assumes its normal
!                   constant value of 0.9942, in tg's version. w0 is a
!                   variable in Steve Klein's version.
!                   L_anom_abs_v takes precedence over L_anom_abs_g, if
!                   the former is TRUE and the latter is FALSE.
!
!     qmix_kx    Zonal mean saturation water vapor mixing ratio at the
!                   model's vertical level closest to the earth's surface.
!                   It is more convenient to pass the zonal mean, in case
!                   single column tests are performed. Alternatively,
!                   the zonal mean could be computed within this subroutine. 
!
!      tempcld      cloud layer mean temperature (degrees Kelvin), with
!                   compressed cloud layer index.
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!       ------------
!INPUT/OUTPUT:
!       ------------
!
!      tau          optical depth in each band
!      w0           single scattering albedo for each band
!      gg           asymmetry parameter for each band
!      em_lw        longwave cloud emissivity

!            NOTE:  In tg's version, LWP and IWP are effective cloud
!                   water paths. They could be computed either in this
!                   subroutine or in subroutine cloud_water_path.

!      LWP          cloud liquid water path (kg of condensate per square meter)
!      IWP          cloud ice path (kg of condensate per square meter)
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       tau_liq      optical depth            at each band for cloud liquid
!       tau_ice      optical depth            at each band for cloud ice
!       w0_liq       single scattering albedo at each band for cloud liquid
!       w0_ice       single scattering albedo at each band for cloud ice
!       g_liq        asymmetry parameter      at each band for cloud liquid
!       g_ice        asymmetry parameter      at each band for cloud ice
!
!
!                   In Tony Gordon's v197 version only.
!
!       CWP           total cloud water path, i.e., cloud liquid plus
!                        cloud ice (kg of condensate per square meter)
!
!                    Parameters (defined above)
!
!       k_lw_liq     liquid cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_lw_ice     ice cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_liq     liquid cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_ice     ice cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!
!       tk_all_ice    minimum temperature at which cloud liquid water phase
!                       can exist (degrees Kelvin)
!       tk_all_liq    maximum temperature at which cloud ice can exist
!                       (degrees Kelvin)
!       wgt_liq       The ratio of liquid water path to total cloud water path,
!                        i.e., LWP / CWP
!       wgt_ice       The ratio of ice water path to total cloud water path,
!                        i.e., IWP / CWP
!
!       qsat_min      Minimum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!       qsat_trans    Transition value of zonal mean saturation mixing ratio
!                        between two branches of a piecewise continuous
!                        function entering into the variable anomalous
!                        absorption single scattering albedo calculations.
!       qsat_max      Maximum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!
!       w0_norm_uv    Normal, constant single scattering albedo in the uv-vis
!                        wavelength band of the radiation spectrum.
!       w0_norm_nir   Normal, constant single scattering albedo in the nir
!                        wavelength band of the radiation spectrum.
!       w0_anom1_nir  Asymptotic minimum value of single scattering albedo
!                        for variable anomalous absorption; also the
!                        low constant value, if L_anom_abs_g is set to TRUE.
!       w0_anom2_nir  Asymptotic maximum value of single scattering albedo
!                        for variable anomalous absorption,usually occurring
!                        at high latitudes.
! 
!       g_norm        Normal, constant asymmetry parameter used in Tony Gordon's
!                        v197 scheme. It is independent of wavelength.                                
!

!      MAX_BAND     maximum number of wave number bands for tau,etc.

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!  in tony gordon's v197 scheme only:
!
!real,     intent (in),     dimension(:,:)      :: qmix_kx
!real,     intent (in),     dimension(:,:,:)    :: tempcld


!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

real,     intent (out),dimension(:,:,:)     :: em_lw
real,     intent ( in)   ,dimension(:,:,:)  ::                liq_frac
real,     intent ( in)   ,dimension(:,:,:,:)  :: tau                 


! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!  Internal variables
!  ------------------

real, dimension(size(tau   ,1),size(tau   ,2),size(tau   ,3))   :: cwp, lwp, iwp

!  Declare tau_chk to compare with tau, if code needs to be debugged.

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!
! Code
! ----

!  define maximum number of wave number bands for tau
!      max_band = size(tau,4)

!  For tg v197, tau is previously computed in subroutine cloud_optical_depths,
!  while w0 and gg will be reinitialized.
!  Also, internal variables w0_liq, w0_ice, g_liq, and g_ice
!  will be re-initialized, while tau_liq and tau_ice will not be.

!  Therefore, the only output variable to be initialized is em_lw.
!  Comment out the other reinitialization commands.


        em_lw(:,:,:)   = 0.


! compute combined emmisivity
        CWP(:,:,:) = tau(:,:,:,1) / &
                     (k_sw_liq * liq_frac(:,:,:) + &
                      k_sw_ice * (1.0-liq_frac(:,:,:)) )

        LWP(:,:,:) = liq_frac(:,:,:) * CWP(:,:,:)
        IWP(:,:,:) = (1.0-liq_frac(:,:,:)) * CWP(:,:,:)
        em_lw(:,:,:) =  1. - exp( -1. * ( k_lw_liq * LWP(:,:,:) + &
                                          k_lw_ice * IWP(:,:,:) ) )


   !--------------    RANGE LIMIT QUANTITIES --------------------------!



end subroutine CLOUD_OPT_PROP_tg_lw

subroutine CLOUD_OPT_PROP_tg_sw(         liq_frac,       &
                        tau, direct,              &
                                qmix_kx, cosz, cuvrf, cirrf, &
                        cuvab, cirab)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine calculates the following optical properties
!      for each cloud:
!
!               1. tau    :optical depth in each band
!               2. w0     :single scattering albedo for each band
!               3. gg     :asymmetry parameter for each band
!               4. em_lw  :longwave cloud emissivity
!
!   The formulas for optical depth come from Slingo (1989) for liquid
!   clouds and from Ebert and Curry (1992) for ice clouds.
!
!   Slingo (1989) is at J. Atmos. Sci., vol. 46, pp. 1419-1427
!   Ebert and Curry (1992) is at J. Geophys. Res., vol. 97, pp. 3831-3836
!
!                    IMPORTANT!!!
!
!    NOTE WE ARE CHEATING HERE BECAUSE WE ARE FORCING THE FIVE BAND
!    MODEL OF EBERT AND CURRY INTO THE FOUR BAND MODEL OF SLINGO
!
!    THIS IS DONE BY COMBINING BANDS 3 and 4 OF EBERT AND CURRY TOGETHER
!
!   EVEN SO THE EXACT BAND LIMITS DO NOT MATCH.  FOR COMPLETENESS
!   HERE ARE THE BAND LIMITS IN MICRONS
!
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!
! *************************    WARNING    *****************************
!
!   The above bands are used by Steve Klein.
!   We retain the scheme from the v197 frozen model,instead.
!   Nominally, our band 2 is expanded into bands 2 + 3 + 4 of Slingo.
!   The same cloud optical depth is specified in all 4 bands.
!   The same asymmetry parameter is specified in all 4 bands.
!   For single scattering albedo w0, the uv value is specified in band 1,
!   while the nir value is specified in bands 2, 3, and 4.

!   ****  WARNING    ****  The code is intended to be applied to 2 to 4 bands.
!   An error check to check that this condition is satisfied is advised.  

! *********************************************************************
!            BAND               v197     
!             1               0.25-0.70
!             2               0.70-4.00
! *********************************************************************
!
!

!
!   The mixed phase optical properties are based upon equation 14
!   of Rockel et al. 1991, Contributions to Atmospheric Physics,
!   volume 64, pp.1-12.   These equations are:
!
!   (1)    tau = tau_liq + tau_ice
!
!   (2)    w0  =   ( w0_liq * tau_liq  +  w0_ice * tau_ice ) /
!                  (          tau_liq  +           tau_ice )
!
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = 0.9942  (in v197 - standard)
!   w0(:,:,1) = 0.99999;  w0(:,:,2) = F(Z.M. mixing ratio at lowest model level)
!                                    (in v197 - anomalous absorption)
!
!   (3)     g  = ( g_liq * w0_liq * tau_liq +  g_ice * w0_ice * tau_ice ) /
!                (         w0_liq * tau_liq +          w0_ice * tau_ice )
!
!           g(:,:,1:2) = 0.85 in v197
!   
!
!   (4) transmivvity_lw =   transmissivity_lw_ice * transmissivity_lw_liq
!
!    The last equation could be rewritten, after algebraic manipulation, as:
!
!   (5)  em_lw =  em_lw_liq + em_lw_ice -  (em_lw_liq * em_lw_ice )
!
!    However, the other form of the equation, i.e., 
!    1 - exp(tau_liq + tau_ice) will actually be solved.

! *******************************************************************
!
!
!   (6)  v197 only: Must first solve for LWP and IWP knowing
!                   tau, k_sw_liq, k_sw_ice, wgt_liq and wgt_ice.
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!VARIABLES
!
!       ------
!INPUT:
!       ------
!


!      L_anom_abs-g Logical namelist variable. If true, anomalous absorption
!                   is represented by a constant value of single scattering
!                   albedo. The default value and the v197 setting are
!                   both false.
!
!      L_anom_abs_v Logical namelist variable. If true, anomalous absorption
!                   is computed as a piecewise continuous function of zonal
!                   mean saturation water vapor mixing ratio at the model's
!                   vertical level closest to the earth's surface. The
!                   default value is false. The analogous namelist variable
!                   in v197, LWALBV is set to TRUE. 
!                   If both L_anom_abs_g and L_anom_abs_v are set to FALSE,
!                   then the single scattering albedo, w0,  assumes its normal
!                   constant value of 0.9942, in tg's version. w0 is a
!                   variable in Steve Klein's version.
!                   L_anom_abs_v takes precedence over L_anom_abs_g, if
!                   the former is TRUE and the latter is FALSE.
!
!     qmix_kx    Zonal mean saturation water vapor mixing ratio at the
!                   model's vertical level closest to the earth's surface.
!                   It is more convenient to pass the zonal mean, in case
!                   single column tests are performed. Alternatively,
!                   the zonal mean could be computed within this subroutine. 
!
!      tempcld      cloud layer mean temperature (degrees Kelvin), with
!                   compressed cloud layer index.
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!       ------------
!INPUT/OUTPUT:
!       ------------
!
!      tau          optical depth in each band
!      w0           single scattering albedo for each band
!      gg           asymmetry parameter for each band
!      em_lw        longwave cloud emissivity

!            NOTE:  In tg's version, LWP and IWP are effective cloud
!                   water paths. They could be computed either in this
!                   subroutine or in subroutine cloud_water_path.

!      LWP          cloud liquid water path (kg of condensate per square meter)
!      IWP          cloud ice path (kg of condensate per square meter)
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       tau_liq      optical depth            at each band for cloud liquid
!       tau_ice      optical depth            at each band for cloud ice
!       w0_liq       single scattering albedo at each band for cloud liquid
!       w0_ice       single scattering albedo at each band for cloud ice
!       g_liq        asymmetry parameter      at each band for cloud liquid
!       g_ice        asymmetry parameter      at each band for cloud ice
!
!
!                   In Tony Gordon's v197 version only.
!
!       CWP           total cloud water path, i.e., cloud liquid plus
!                        cloud ice (kg of condensate per square meter)
!
!                    Parameters (defined above)
!
!       k_lw_liq     liquid cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_lw_ice     ice cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_liq     liquid cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_ice     ice cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!
!       tk_all_ice    minimum temperature at which cloud liquid water phase
!                       can exist (degrees Kelvin)
!       tk_all_liq    maximum temperature at which cloud ice can exist
!                       (degrees Kelvin)
!       wgt_liq       The ratio of liquid water path to total cloud water path,
!                        i.e., LWP / CWP
!       wgt_ice       The ratio of ice water path to total cloud water path,
!                        i.e., IWP / CWP
!
!       qsat_min      Minimum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!       qsat_trans    Transition value of zonal mean saturation mixing ratio
!                        between two branches of a piecewise continuous
!                        function entering into the variable anomalous
!                        absorption single scattering albedo calculations.
!       qsat_max      Maximum value of zonal mean saturation water vapor mixing
!                        ratio entering into the variable anomalous absorption
!                        single scattering albedo calculations.
!
!       w0_norm_uv    Normal, constant single scattering albedo in the uv-vis
!                        wavelength band of the radiation spectrum.
!       w0_norm_nir   Normal, constant single scattering albedo in the nir
!                        wavelength band of the radiation spectrum.
!       w0_anom1_nir  Asymptotic minimum value of single scattering albedo
!                        for variable anomalous absorption; also the
!                        low constant value, if L_anom_abs_g is set to TRUE.
!       w0_anom2_nir  Asymptotic maximum value of single scattering albedo
!                        for variable anomalous absorption,usually occurring
!                        at high latitudes.
! 
!       g_norm        Normal, constant asymmetry parameter used in Tony Gordon's
!                        v197 scheme. It is independent of wavelength.                                
!

!      MAX_BAND     maximum number of wave number bands for tau,etc.

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!  in tony gordon's v197 scheme only:
!
real,     intent (in),     dimension(:,:)      :: qmix_kx, cosz
logical,  intent (in),     dimension(:,:,:)    :: direct           


!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

real,     intent (in),dimension(:,:,:,:)   :: tau

real,     intent ( in)   ,dimension(:,:,:)  ::          liq_frac
real,     intent (out),     dimension(:,:,:)    :: cuvrf, cirrf,   &
                                                   cuvab, cirab


! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!  Internal variables
!  ------------------

real, dimension(size(tau,1),size(tau,2),size(tau,3),4) :: tau_liq, tau_ice
real, dimension(size(tau,1),size(tau,2),size(tau,3),4) :: w0_liq, w0_ice
real, dimension(size(tau,1),size(tau,2),size(tau,3),4) :: g_liq, g_ice
real, dimension(size(tau,1),size(tau,2),size(tau,3))   :: w0_anom_work
real, dimension(size(tau,1),size(tau,2),size(tau,3))   :: qmix_kx_work
real, dimension(size(tau,1),size(tau,2),size(tau,3))   :: lwp_new, iwp_new, cwp
integer                                                :: k, kmax
integer                                                :: n, max_band

!  Declare tau_chk to compare with tau, if code needs to be debugged.
real, dimension(size(tau,1),size(tau,2),size(tau,3),4) :: tau_chk
real, dimension(size(tau,1),size(tau,2),size(tau,3),   &
                size(tau,4)) :: w0, gg 

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!
! Code
! ----

!  define maximum number of wave number bands for tau
      max_band = size(tau,4)

!  For tg v197, tau is previously computed in subroutine cloud_optical_depths,
!  while w0 and gg will be reinitialized.
!  Also, internal variables w0_liq, w0_ice, g_liq, and g_ice
!  will be re-initialized, while tau_liq and tau_ice will not be.

!  Therefore, the only output variable to be initialized is em_lw.
!  Comment out the other reinitialization commands.


!  These are Tony Gordon's reinitialized values.
        gg(:,:,:,:)    = 0.85
        w0(:,:,:,1)    = 0.99999
        w0(:,:,:,2:4)  = 0.9942

        w0_liq(:,:,:,1)   = 0.99999
        w0_liq(:,:,:,2:4) = 0.9942
        w0_ice(:,:,:,1)   = 0.99999
        w0_ice(:,:,:,2:4) = 0.9942
        g_liq(:,:,:,:)    = 0.85
        g_ice(:,:,:,:)    = 0.85

! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

!       Comment out Steve Klein's reinitialized values.
!       tau(:,:,:,:) = 0.
!       gg(:,:,:,:)  = 0.85
!       w0(:,:,:,:)  = 0.95
!       em_lw(:,:,:) = 0.

!       w0_liq(:,:,:,:) = 0.95
!       w0_ice(:,:,:,:) = 0.95
!       tau_liq(:,:,:,:)= 0.
!       tau_ice(:,:,:,:)= 0.



    !---------------   COMPUTE OPTICAL DEPTH ---------------------------!



        ! compute uv cloud optical depths due to liquid
        ! and ice phase separately


                     
        CWP(:,:,:) = tau(:,:,:,1) / &
                     (k_sw_liq * liq_frac(:,:,:) + &
                      k_sw_ice * (1.-liq_frac(:,:,:)) )

        LWP_new(:,:,:) = liq_frac(:,:,:) * CWP(:,:,:)
        IWP_new(:,:,:) = (1.0-liq_frac(:,:,:)) * CWP(:,:,:)

        tau_liq(:,:,:,1)   = k_sw_liq * LWP_new(:,:,:)
        tau_ice(:,:,:,1)   = k_sw_ice * IWP_new(:,:,:)

!  tau_liq and tau_ice are purely diagnostic, since tau is already known.
!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes.

             if (max_band .ge. 2) then
        do n=2,max_band
        tau_liq(:,:,:,n) = tau_liq(:,:,:,1)
        tau_ice(:,:,:,n) = tau_ice(:,:,:,1)
        end do
             endif

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

!  Compute total cloud optical depth, using same formula as Steve Klein.
!  Note:  Comment out the following command in Tony Gordon's v197 scheme.
!         tau should have the same as the input, except for roundoff error.

!         tau(:,:,:,:)     = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)

!  Define tau_chk to compare with tau, if code needs to be debugged.
          tau_chk(:,:,:,:) = tau_liq(:,:,:,:) + tau_ice(:,:,:,:)

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -



   !---------------   COMPUTE SINGLE SCATTERING ALBEDO ----------------!


!
        w0_liq(:,:,:,1) =  w0_norm_uv
        w0_ice(:,:,:,1) =  w0_norm_uv

     IF (.not. L_anom_abs_g .and. .not. L_anom_abs_v) THEN

!       Specify tg's normal single scattering albedos for NIR bands.

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
        w0_liq(:,:,:,n) =  w0_norm_nir
        w0_ice(:,:,:,n) =  w0_norm_nir
        end do
             endif

     ENDIF

     IF (L_anom_abs_g) THEN

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
        w0_liq(:,:,:,n) =  w0_anom1_nir
        w0_ice(:,:,:,n) =  w0_anom1_nir
        end do
             endif

     ENDIF

!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!    Broadcast qmix_kx to generate WHERE statements with correct syntax.

     kmax = SIZE(tau,3)

     DO k = 1,kmax
        qmix_kx_work(:,:,k) = qmix_kx(:,:)
     END DO
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
! 
     IF (L_anom_abs_v) THEN

       WHERE (qmix_kx_work(:,:,:) .le. qsat_min)

!      Apply lower asymptotic limit to anomalously weak cloud absorption,
!      i.e., upper asymptotic limit of w0.

!      This situation should not occur for saturation mixing ratios. However,
!      negative mixing ratios are possible in the spectral AGCM,
!      especially in cold temperature, e.g., high latitude regions.
!      Retain this WHERE loop, in case parameterization is ever changed 
!      from saturation mixing ratio to mixing ratio.
      
              w0_anom_work(:,:,:) = w0_anom2_nir

       END WHERE 

       WHERE (qmix_kx_work(:,:,:) .gt. qsat_min .and.                  &
              qmix_kx_work(:,:,:) .lt. qsat_trans)

!      Anomalously weak cloud absorption relative to the reference value 
!      w0_norm_nir will tend to occur at higher latitudes for these values
!      of w0.

            w0_anom_work(:,:,:) = w0_anom2_nir -                    &
               (w0_anom2_nir - w0_norm_nir)    *                    &
               ( (qmix_kx_work(:,:,:) - qsat_min) / (qsat_trans - qsat_min))

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .eq. qsat_trans)

!      The reference value of nir single scattering albedo will be used.

           w0_anom_work(:,:,:) = w0_norm_nir

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .gt. qsat_trans .and.                &
              qmix_kx_work(:,:,:) .lt. qsat_max)

!      Anomalously high absorption relative to the reference value w0_norm_nir
!      will tend to occur at tropical and subtropical latitudes for 
!      these values of w0.

           w0_anom_work(:,:,:) = w0_norm_nir  -                    &
              (w0_norm_nir - w0_anom1_nir)    *                    &
              ( (qmix_kx_work(:,:,:) - qsat_trans) / (qsat_max - qsat_trans))

       END WHERE

       WHERE (qmix_kx_work(:,:,:) .ge. qsat_max)

!      Apply upper asymptotic limit to the anomalous absorption, i.e.,
!      lower asymptotic limit of w0.

              w0_anom_work = w0_anom1_nir

       END WHERE

!  Generalize code to n bands, though it may need to be revised,
!  if max_band changes

             if (max_band .ge. 2) then
        do n=2,max_band
       w0_liq(:,:,:,n) = w0_anom_work(:,:,:)
       w0_ice(:,:,:,n) = w0_anom_work(:,:,:)
        end do
             endif

     ENDIF



! compute total single scattering albedo
        WHERE (tau(:,:,:,:) .gt. 0.)
               w0(:,:,:,:) = ( w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                               w0_ice(:,:,:,:) * tau_ice(:,:,:,:) ) / &
                             tau(:,:,:,:)
        END WHERE

   !---------------   COMPUTE ASYMMETRY PARAMETER --------------------!

        WHERE (tau(:,:,:,:) .gt. 0. )
              gg(:,:,:,:) = ( &
                 w0_liq(:,:,:,:) * g_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                 w0_ice(:,:,:,:) * g_ice(:,:,:,:) * tau_ice(:,:,:,:) ) &
                       /          (w0_liq(:,:,:,:) * tau_liq(:,:,:,:) + &
                                   w0_ice(:,:,:,:) * tau_ice(:,:,:,:) )
        END WHERE



       call cloud_rad_k_diag(tau, direct, w0,gg,cosz,cuvrf,cirrf,cuvab,cirab )

end subroutine CLOUD_OPT_PROP_tg_sw




subroutine CLOUD_OPT_PROP_tg2 (tau, tempcld,           liq_frac)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!      tempcld      cloud layer mean temperature (degrees Kelvin), with
!                   compressed cloud layer index.
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!       ------------
!INPUT/OUTPUT:
!       ------------
!
!      tau          optical depth in each band

!            NOTE:  In tg's version, LWP and IWP are effective cloud
!                   water paths. They could be computed either in this
!                   subroutine or in subroutine cloud_water_path.

!      LWP          cloud liquid water path (kg of condensate per square meter)
!      IWP          cloud ice path (kg of condensate per square meter)
!
!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
!
!       -------------------
!INTERNAL VARIABLES:
!       -------------------
!
!       tau_liq      optical depth            at each band for cloud liquid
!       tau_ice      optical depth            at each band for cloud ice
!
!
!                   In Tony Gordon's v197 version only.
!
!       CWP           total cloud water path, i.e., cloud liquid plus
!                        cloud ice (kg of condensate per square meter)
!
!                    Parameters (defined above)
!
!       k_lw_liq     liquid cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_lw_ice     ice cloud mass absorption coefficient for longwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_liq     liquid cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!       k_sw_ice     ice cloud mass absorption coefficient for shortwave
!                       portion of the spectrum (meters**2./kg of condensate)
!
!       tk_all_ice    minimum temperature at which cloud liquid water phase
!                       can exist (degrees Kelvin)
!       tk_all_liq    maximum temperature at which cloud ice can exist
!                       (degrees Kelvin)
!       wgt_liq       The ratio of liquid water path to total cloud water path,
!                        i.e., LWP / CWP
!       wgt_ice       The ratio of ice water path to total cloud water path,
!                        i.e., IWP / CWP
!
!

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
!                   
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

real,     intent (in   ),dimension(:,:,:,:)   :: tau
real,     intent (in),     dimension(:,:,:)    :: tempcld


!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !


real,     intent (out)   ,dimension(:,:,:)  ::          liq_frac


! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!  Internal variables
!  ------------------

real, dimension(size(tau,1),size(tau,2),size(tau,3))   :: wgt_ice, wgt_liq
real, dimension(size(tau,1),size(tau,2),size(tau,3))   :: cwp, lwp, iwp

!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !

!



    !---------------   COMPUTE OPTICAL DEPTH ---------------------------!



        ! compute uv cloud optical depths due to liquid
        ! and ice phase separately


!       by Tony Gordon's v197 scheme

        WHERE (tempcld(:,:,:) .le. tk_all_ice)
               wgt_liq(:,:,:) = 0.
               wgt_ice(:,:,:) = 1.
        END WHERE

        WHERE (tempcld(:,:,:) .ge. tk_all_liq)
               wgt_liq(:,:,:) = 1.
               wgt_ice(:,:,:) = 0.
        END WHERE

        WHERE (tempcld(:,:,:) .gt. tk_all_ice .and. tempcld(:,:,:) &
               .lt. tk_all_liq)
               wgt_liq(:,:,:) = (tempcld(:,:,:) - tk_all_ice) / &
                                (tk_all_liq - tk_all_ice)
               wgt_ice(:,:,:) = 1. - wgt_liq(:,:,:)
        END WHERE
                     
        CWP(:,:,:) = tau(:,:,:,1) / &
                     (k_sw_liq * wgt_liq(:,:,:) + &
                      k_sw_ice * wgt_ice(:,:,:) )

        LWP(:,:,:) = wgt_liq(:,:,:) * CWP(:,:,:)
        IWP(:,:,:) = wgt_ice(:,:,:) * CWP(:,:,:)
liq_frac = wgt_liq



end subroutine CLOUD_OPT_PROP_tg2


!#######################################################################

  SUBROUTINE DIAG_CLOUD_RAD_INIT(do_crad_init)

!=======================================================================
! ***** INITIALIZE Predicted Cloud Scheme
!=======================================================================

!---------------------------------------------------------------------
! Argument (Intent inout)
!  do_crad_init - logical switch to be set = .true. after init is done
!---------------------------------------------------------------------
 logical, intent(inout) :: do_crad_init

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
 integer             :: unit, io, logunit, ierr

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

!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=diag_cloud_rad_nml, iostat=io)
  ierr = check_nml_error(io,"diag_cloud_rad_nml")
#else
  if( FILE_EXIST( 'input.nml' ) ) then
! -------------------------------------
         unit = open_namelist_file ()
   io = 1
   do while( io .ne. 0 )
      READ ( unit,  nml = diag_cloud_rad_nml, iostat = io, end = 10 ) 
      ierr = check_nml_error(io,'diag_cloud_rad_nml')
   end do
10 continue
   call close_file (unit)
! -------------------------------------
  end if
#endif

!   **** call cloud_rad_init to read namelist containing L2STREM  ****
       call cloud_rad_init()

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=diag_cloud_rad_nml)
      endif

!-------------------------------------------------------------------
  do_crad_init = .true.
  module_is_initialized = .true.
END SUBROUTINE DIAG_CLOUD_RAD_INIT

SUBROUTINE DIAG_CLOUD_RAD_END

  module_is_initialized = .false.

END SUBROUTINE DIAG_CLOUD_RAD_END


end MODULE DIAG_CLOUD_RAD_MOD





                     module diag_integral_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="">
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    diag_integral_mod computes and outputs global and / or 
!    hemispheric physics integrals.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!  shared modules:

use time_manager_mod, only:  time_type, get_time, set_time,  &
                             time_manager_init, &
                             operator(+),  operator(-),      &
                             operator(==), operator(>=),     &
                             operator(/=)
use mpp_mod,          only:  input_nml_file
use fms_mod,          only:  open_file, file_exist, error_mesg, &
                             open_namelist_file, check_nml_error, &
                             fms_init, &
                             mpp_pe, mpp_root_pe,&
                             FATAL, write_version_number, &
                             stdlog, close_file
use constants_mod,    only:  radius, constants_init
use mpp_mod,          only:  mpp_sum, mpp_init

!--------------------------------------------------------------------

implicit none
private

!----------------------------------------------------------------------
!    diag_integral_mod computes and outputs global and / or 
!    hemispheric physics integrals.
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128) :: version = '$Id: diag_integral.F90,v 17.0.8.1.2.1.2.1 2010/08/30 20:33:34 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!------ interfaces ------

public      &
          diag_integral_init, diag_integral_field_init, &
          sum_diag_integral_field, diag_integral_output,  &
          diag_integral_end  

interface sum_diag_integral_field
   module procedure sum_field_2d,   &
                    sum_field_2d_hemi, &
                    sum_field_3d,   &
                    sum_field_wght_3d
end interface

private         &

!   from diag_integral_init:
          set_axis_time,  &

!   from diag_integral_field_init and sum_diag_integral_field:
          get_field_index, &

!   from diag_integral_output and diag_integral_end:
          write_field_averages,  &           

!   from write_field_averages:
          format_text_init, format_data_init, &
          get_axis_time,     &

!   from diag_integral_output:
          diag_integral_alarm, &

!   from sum_diag_integral_field:
          vert_diag_integral

!---------------------------------------------------------------------
!------ namelist -------

integer, parameter  ::    &
                      mxch = 64    ! maximum number of characters in 
                                   ! the optional output file name
real                ::    &
         output_interval = -1.0    ! time interval at which integrals
                                   ! are to be output
character(len=8)    ::    &
            time_units = 'hours'   ! time units associated with
                                   ! output_interval
character(len=mxch) ::    &
                 file_name = ' '   ! optional integrals output file name
logical             ::    &
           print_header = .true.   ! print a header for the integrals
                                   ! file ?
integer             ::    &
       fields_per_print_line = 4   ! number of fields to write per line
                                   ! of output


namelist / diag_integral_nml /      &
                                output_interval, time_units,  &
                                file_name, print_header, &
                                fields_per_print_line

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------

!---------------------------------------------------------------------
!    variables associated with the determination of when integrals
!    are to be written.
!         Next_alarm_time  next time at which integrals are to be 
!                          written   
!         Alarm_interval   time interval between writing integrals
!         Zero_time        time_type variable set to (0,0); used as
!                          flag to indicate integrals are not being
!                          output
!         Time_init_save   initial time associated with experiment;
!                          used as a base for defining time
!---------------------------------------------------------------------
type (time_type) :: Next_alarm_time, Alarm_interval, Zero_time
type (time_type) :: Time_init_save

!---------------------------------------------------------------------
!    variables used in determining weights associated with each
!    contribution to the integrand.
!        area         area of each grid box
!        idim         x dimension of grid on local processor
!        jdim         y dimension of grid on local processor
!        field_size   number of columns on global domain
!        sum_area     surface area of globe
!---------------------------------------------------------------------
real, allocatable, dimension(:,:) :: area
integer                           :: idim, jdim, field_size
real                              :: sum_area

!---------------------------------------------------------------------
!    variables used to define the integral fields: 
!      max_len_name     maximum length of name associated with integral
!      max_num_field    maximum number of integrals allowed
!      num_field        number of integrals that have been activated
!      field_name(i)    name associated with integral i
!      field_format(i)  output format for integral i
!      field_sum(i)     integrand for integral i
!      field_count(i)   number of values in integrand i
!---------------------------------------------------------------------
integer, parameter          :: max_len_name   = 12
integer, parameter          :: max_num_field = 32    
integer                     :: num_field = 0
character(len=max_len_name) :: field_name   (max_num_field)
character(len=16)           :: field_format (max_num_field)
real                        :: field_sum    (max_num_field)
integer                     :: field_count  (max_num_field)

!---------------------------------------------------------------------
!    variables defining output formats.
!       format_text       format statement for header
!       format_data       format statement for data output
!       do_format_data    a data format needs to be generated ? 
!       nd                number of characters in data format statement
!       nt                number of characters in text format statement
!---------------------------------------------------------------------
character(len=160) :: format_text, format_data
logical            :: do_format_data = .true.
integer            :: nd, nt

!--------------------------------------------------------------------
!    miscellaneous variables.
!---------------------------------------------------------------------
integer :: diag_unit = 0             ! unit number for output file
logical :: module_is_initialized = .false.  
                                     ! module is initialized ?


!-----------------------------------------------------------------------
!-----------------------------------------------------------------------



                           contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!####################################################################
! <SUBROUTINE NAME="diag_integral_init">
!  <OVERVIEW>
!    diag_integral_init is the constructor for diag_integral_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_integral_init is the constructor for diag_integral_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_integral_init (Time_init, Time, blon, blat)
!  </TEMPLATE>
!  <IN NAME="Time_init" TYPE="time_type">
!   Initial time to start the integral
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="latb" TYPE="real">
!   array of model latitudes at cell boundaries [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   array of model longitudes at cell boundaries [radians]
!  </IN>
! </SUBROUTINE>
!
subroutine diag_integral_init (Time_init, Time, blon, blat, area_in)

!--------------------------------------------------------------------
!    diag_integral_init is the constructor for diag_integral_mod.
!--------------------------------------------------------------------

type (time_type),  intent(in), optional :: Time_init, Time
real,dimension(:,:), intent(in), optional :: blon, blat, area_in
      
!--------------------------------------------------------------------
!  intent(in),optional variables:
!
!     Time_init
!     Time
!     blon
!     blat
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real    :: rsize
      integer :: unit, io, ierr, nc, logunit
      integer :: field_size_local
      real    :: sum_area_local

!---------------------------------------------------------------------
!  local variables:
!
!       r2
!       rsize
!       unit
!       io
!       ierr
!       seconds
!       nc
!       i,j
!   
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call mpp_init
      call constants_init
      call time_manager_init 

!----------------------------------------------------------------------
!    if this is the initialization call, proceed. if this was simply
!    a verification of previous initialization, return.
!--------------------------------------------------------------------
      if (present(Time_init) .and. present(Time) .and. &
          present(blon) .and. present(blat) ) then

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=diag_integral_nml, iostat=io)
        ierr = check_nml_error(io,'diag_integral_nml')
#else   
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=diag_integral_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'diag_integral_nml')
        end do
10      call close_file (unit)
#endif
      endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                       write (logunit, nml=diag_integral_nml)

!--------------------------------------------------------------------
!    save the initial time to time-stamp the integrals which will be
!    calculated.
!---------------------------------------------------------------------
      Time_init_save = Time_init

!---------------------------------------------------------------------
!    define the model grid sizes and the total number of columns on
!    the processor. sum over all processors and store the global
!    number of columns in field_size.
!---------------------------------------------------------------------
      idim = size(blon,1) - 1
      jdim = size(blon,2) - 1
      field_size_local = idim*jdim
      rsize = real(field_size_local)
      call mpp_sum (rsize)
      field_size = nint(rsize)

!---------------------------------------------------------------------
!    define an array to hold the surface area of each grid column 
!    so that the integrals may be weighted properly. sum over the 
!    processor, and then over all processors, storing the total
!    global surface area in sum_area.
!---------------------------------------------------------------------
      allocate (area(idim,jdim))

      area = area_in

      sum_area_local = sum(area)
      sum_area = sum_area_local
      call mpp_sum (sum_area)

!--------------------------------------------------------------------
!    if integral output is  to go to a file, open the file on unit
!    diag_unit.
!--------------------------------------------------------------------
      if (file_name(1:1) /= ' ' ) then
        nc = len_trim(file_name)
        diag_unit = open_file (file_name(1:nc), action='write')
      endif

!---------------------------------------------------------------------
!    define the variables needed to control the time interval of
!    output. Zero time is a flag indicating that the alarm is not set,
!    i.e., integrals are not desired.  otherwise set the next time to
!    output integrals to be at the value of nml variable
!    output_interval from now.
!---------------------------------------------------------------------
      Zero_time = set_time (0,0)
      if (output_interval >= -0.01) then
        Alarm_interval = set_axis_time (output_interval, time_units)
        Next_alarm_time = Time + Alarm_interval
      else
        Alarm_interval = Zero_time
      endif
      Next_alarm_time = Time + Alarm_interval

!--------------------------------------------------------------------
!    deallocate the local array and mark the module as initialized.
!--------------------------------------------------------------------
      module_is_initialized = .true.
   endif  ! (present optional arguments)

!-----------------------------------------------------------------------


end subroutine diag_integral_init



!######################################################################
! <SUBROUTINE NAME="diag_integral_field_init">
!  <OVERVIEW>
!    diag_integral_field_init registers and intializes an integral field
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_integral_field_init registers and intializes an integral field
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_integral_field_init (name, format)
!  </TEMPLATE>
!  <IN NAME="name" TYPE="character">
!   Name of the field to be integrated
!  </IN>
!  <IN NAME="format" TYPE="character">
!   Output format of the field to be integrated
!  </IN>
! </SUBROUTINE>
!
 subroutine diag_integral_field_init (name, format)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

character(len=*), intent(in) :: name, format

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       name
!       format
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
 
      integer :: field   ! index assigned to the current integral

!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    note: no initialization is required for this interface. all needed
!    variables are initialized in the source.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    make sure the integral name is not too long.
!--------------------------------------------------------------------
      if (len(name) > max_len_name )  then
        call error_mesg ('diag_integral_mod',  &
                ' integral name too long', FATAL)
      endif

!---------------------------------------------------------------------
!    check to be sure the integral name has not already been 
!    initialized.
!---------------------------------------------------------------------
      field = get_field_index (name)
      if (field /= 0)   then
        call error_mesg ('diag_integral_mod', &
                             'integral name already exists', FATAL)
      endif

!-------------------------------------------------------------------
!    prepare to register the integral. make sure that there are not
!    more integrals registered than space was provided for; if so, exit.
!----------------------------------------------------------------------
      num_field = num_field + 1
      if (num_field > max_num_field)  then
        call error_mesg ('diag_integral_mod', &
                              'too many fields initialized', FATAL)
      endif

!--------------------------------------------------------------------
!    register the name and output format desired for the given integral.
!    initialize its value and the number of grid points that have been
!    counted to zero.
!--------------------------------------------------------------------
      field_name   (num_field) = name
      field_format (num_field) = format
      field_sum    (num_field) = 0.0
      field_count  (num_field) = 0

!----------------------------------------------------------------------


end subroutine diag_integral_field_init


!#####################################################################

!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                  INTERFACE SUM_DIAG_INTEGRAL_FIELD
!
!  call sum_diag_integral_field (name, data, is, js) 
!     or
!  call sum_diag_integral_field (name, data, wt, is, js) 
!     or
!  call sum_diag_integral_field (name, data, is, ie, js, je) 
!
!  in the first option data may be either
!     real,              intent(in) :: data(:,:)  [ sum_field_2d ]
!  or
!     real,              intent(in) :: data(:,:,:) [ sum_field_3d ]
!
!-------------------------------------------------------------------
! intent(in) arguments:
!
!  character(len=*),  intent(in) :: name
!  real,              intent(in) :: wt(:,:,:)
!  integer, optional, intent(in) :: is, ie, js, je
!
!--------------------------------------------------------------------
! intent(in) arguments:
!
!     name         name associated with integral
!     data         field of integrands to be summed over
!     wt           vertical weighting factor to be applied to integrands
!                  when summing
!     is,ie,js,je  starting/ending i,j indices over which summation is 
!                  to occur
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="sum_field_2d">
!  <OVERVIEW>
!    Perform a 2 dimensional summation of named field
!  </OVERVIEW>
!  <DESCRIPTION>
!    Perform a 2 dimensional summation of named field
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sum_field_2d (name, data, is, js)
!  </TEMPLATE>
!  <IN NAME="name" TYPE="character">
!   Name of the field to be integrated
!  </IN>
!  <IN NAME="data" TYPE="real">
!   field of integrands to be summed over
!  </IN>
!  <IN NAME="is, js" TYPE="integer">
!   starting i,j indices over which summation is 
!                  to occur
!  </IN>
! </SUBROUTINE>
!
subroutine sum_field_2d (name, data, is, js)

character(len=*),  intent(in) :: name
real,              intent(in) :: data(:,:)
integer, optional, intent(in) :: is, js

!---------------------------------------------------------------------
! local variables:

      integer :: field           ! index of desired integral
      integer :: i1, j1, i2, j2  ! location indices of current data in 
                                 ! processor-global coordinates

!----------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('diag_integral_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    obtain the index of the current integral. make certain it is valid.
!---------------------------------------------------------------------
      field = get_field_index (name)
      if (field == 0)  then
        call error_mesg ('diag_integral_mod', &
                                    'field does not exist', FATAL)
      endif

!---------------------------------------------------------------------
!   define the processor-global indices of the current data. use the 
!   value 1 for the initial grid points, if is and js are not input.
!---------------------------------------------------------------------
     i1 = 1;  if (present(is)) i1 = is
     j1 = 1;  if (present(js)) j1 = js
     i2 = i1 + size(data,1) - 1
     j2 = j1 + size(data,2) - 1

!---------------------------------------------------------------------
!    increment the count of points toward this integral and add the 
!    values at this set of grid points to the accumulation array.
!---------------------------------------------------------------------
!$OMP CRITICAL
      field_count (field) = field_count(field) +   &
                            size(data,1)*size(data,2)
      field_sum   (field) = field_sum   (field) +  &
                            sum (data * area(i1:i2,j1:j2))

!$OMP END CRITICAL
!--------------------------------------------------------------------

 end subroutine sum_field_2d


!#######################################################################
! <SUBROUTINE NAME="sum_field_3d">
!  <OVERVIEW>
!    Perform a 3 dimensional summation of named field
!  </OVERVIEW>
!  <DESCRIPTION>
!    Perform a 3 dimensional summation of named field
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sum_field_3d (name, data, is, js)
!  </TEMPLATE>
!  <IN NAME="name" TYPE="character">
!   Name of the field to be integrated
!  </IN>
!  <IN NAME="data" TYPE="real">
!   field of integrands to be summed over
!  </IN>
!  <IN NAME="is, js" TYPE="integer">
!   starting i,j indices over which summation is 
!                  to occur
!  </IN>
! </SUBROUTINE>
!
subroutine sum_field_3d (name, data, is, js)

character(len=*),  intent(in) :: name
real,              intent(in) :: data(:,:,:)
integer, optional, intent(in) :: is, js

!---------------------------------------------------------------------
! local variables:

      real, dimension (size(data,1),  &
                       size(data,2)) :: data2

      integer :: field           
      integer :: i1, j1, i2, j2  
                             
!---------------------------------------------------------------------
! local variables:
!
!     data2
!     field           ! index of desired integral
!     i1, j1, i2, j2  ! location indices of current data in 
!                       processor-global coordinates
!
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('diag_integral_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    obtain the index of the current integral. make certain it is valid.
!---------------------------------------------------------------------
      field = get_field_index (name)
      if (field == 0)   then
        call error_mesg ('diag_integral_mod', &
                               'field does not exist', FATAL)
      endif

!---------------------------------------------------------------------
!   define the processor-global indices of the current data. use the 
!   value 1 for the initial grid points, if is and js are not input.
!---------------------------------------------------------------------
      i1 = 1;  if (present(is)) i1 = is
      j1 = 1;  if (present(js)) j1 = js
      i2 = i1 + size(data,1) - 1
      j2 = j1 + size(data,2) - 1

!---------------------------------------------------------------------
!    increment the count of points toward this integral. sum first
!    in the vertical and then add the values at this set of grid points 
!    to the accumulation array.
!---------------------------------------------------------------------
!$OMP CRITICAL
      field_count (field) = field_count (field) +   &
                            size(data,1)*size(data,2)
      data2 = sum(data,3)
      field_sum   (field) = field_sum   (field) +  &
                            sum (data2 * area(i1:i2,j1:j2))

!$OMP END CRITICAL
!---------------------------------------------------------------------

end subroutine sum_field_3d


!#######################################################################
! <SUBROUTINE NAME="sum_field_wght_3d">
!  <OVERVIEW>
!    Perform a 3 dimensional weighted summation of named field
!  </OVERVIEW>
!  <DESCRIPTION>
!    Perform a 3 dimensional weighted summation of named field
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sum_field_wght_3d (name, data, wt, is, js)
!  </TEMPLATE>
!  <IN NAME="name" TYPE="character">
!   Name of the field to be integrated
!  </IN>
!  <IN NAME="data" TYPE="real">
!   field of integrands to be summed over
!  </IN>
!  <IN NAME="wt" TYPE="real">
!   the weight function to be evaluated at summation
!  </IN>
!  <IN NAME="is, js" TYPE="integer">
!   starting i,j indices over which summation is 
!                  to occur
!  </IN>
! </SUBROUTINE>
!
subroutine sum_field_wght_3d (name, data, wt, is, js)

character(len=*),  intent(in) :: name
real,              intent(in) :: data(:,:,:), wt(:,:,:)
integer, optional, intent(in) :: is, js

!---------------------------------------------------------------------
! local variables:

      real, dimension (size(data,1),size(data,2)) :: data2
      integer :: field, i1, j1, i2, j2

!---------------------------------------------------------------------
! local variables:
!
!     data2
!     field           ! index of desired integral
!     i1, j1, i2, j2  ! location indices of current data in 
!                       processor-global coordinates
!
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('diag_integral_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    obtain the index of the current integral. make certain it is valid.
!---------------------------------------------------------------------
      field = get_field_index (name)
      if (field == 0)   then
        call error_mesg ('diag_integral_mod', &
                               'field does not exist', FATAL)
      endif

!---------------------------------------------------------------------
!   define the processor-global indices of the current data. use the 
!   value 1 for the initial grid points, if is and js are not input.
!---------------------------------------------------------------------
      i1 = 1;  if (present(is)) i1 = is
      j1 = 1;  if (present(js)) j1 = js
      i2 = i1 + size(data,1) - 1
      j2 = j1 + size(data,2) - 1

!---------------------------------------------------------------------
!    increment the count of points toward this integral. sum first
!    in the vertical (including a vertical weighting factor) and then 
!    add the values at this set of grid points to the accumulation 
!    array.
!---------------------------------------------------------------------
!$OMP CRITICAL
      field_count (field) = field_count (field) +   &
                            size(data,1)*size(data,2)
      data2 = vert_diag_integral (data, wt) 
      field_sum(field) = field_sum   (field) +  &
                         sum (data2 * area(i1:i2,j1:j2))

!$OMP END CRITICAL
!----------------------------------------------------------------------


end subroutine sum_field_wght_3d

  
!#######################################################################
! <SUBROUTINE NAME="sum_field_2d_hemi">
!  <OVERVIEW>
!    Perform a 2 dimensional hemispherical summation of named field
!  </OVERVIEW>
!  <DESCRIPTION>
!    Perform a 2 dimensional hemispherical summation of named field
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sum_field_2d_hemi (name, data, is, ie, js, je)
!  </TEMPLATE>
!  <IN NAME="name" TYPE="character">
!   Name of the field to be integrated
!  </IN>
!  <IN NAME="data" TYPE="real">
!   field of integrands to be summed over
!  </IN>
!  <IN NAME="is, js, ie, je" TYPE="integer">
!   starting/ending i,j indices over which summation is 
!                  to occur
!  </IN>
! </SUBROUTINE>
!
subroutine sum_field_2d_hemi (name, data, is, ie, js, je)

character(len=*),  intent(in) :: name
real,              intent(in) :: data(:,:)
integer,           intent(in) :: is, js, ie, je

!---------------------------------------------------------------------
! local variables:
   integer :: field, i1, j1, i2, j2

!---------------------------------------------------------------------
! local variables:
!
!     field           ! index of desired integral
!     i1, j1, i2, j2  ! location indices of current data in 
!                       processor-global coordinates
!
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('diag_integral_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    obtain the index of the current integral. make certain it is valid.
!---------------------------------------------------------------------
      field = get_field_index (name)
      if (field == 0)    then
        call error_mesg ('diag_integral_mod', &
                               'field does not exist', FATAL)
      endif

!----------------------------------------------------------------------
!    define the processor-global indices of the current data. this form
!    is needed to handle case of 2d domain decomposition with physics 
!    window smaller than processor domain size.
!----------------------------------------------------------------------
      i1 = mod ( (is-1), size(data,1) ) + 1
      i2 = i1 + size(data,1) - 1

!--------------------------------------------------------------------
!    for a hemispheric sum, sum one jrow at a time in case a processor
!    has data from both hemispheres.
!--------------------------------------------------------------------
      j1 = mod ( (js-1) ,size(data,2) ) + 1
      j2 = j1

!----------------------------------------------------------------------
!    increment the count of points toward this integral. include hemi-
!    spheric factor of 2 in field_count. add the data values at this 
!    set of grid points to the accumulation array.
!----------------------------------------------------------------------
!$OMP CRITICAL
      field_count (field) = field_count (field) + 2* (i2-i1+1)*(j2-j1+1)
      field_sum   (field) = field_sum   (field) +  &
                            sum (data(i1:i2,j1:j2)*area(is:ie,js:je))

!$OMP END CRITICAL
!---------------------------------------------------------------------


 end subroutine sum_field_2d_hemi



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                  END INTERFACE SUM_DIAG_INTEGRAL_FIELD
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!##################################################################
! <SUBROUTINE NAME="diag_integral_output">
!  <OVERVIEW>
!    diag_integral_output determines if this is a timestep on which
!    integrals are to be written. if not, it returns; if so, it calls
!    write_field_averages.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_integral_output determines if this is a timestep on which
!    integrals are to be written. if not, it returns; if so, it calls
!    write_field_averages.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_integral_output (Time)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   integral time stamp at the current time 
!  </IN>
! </SUBROUTINE>
!
subroutine diag_integral_output (Time)

!---------------------------------------------------------------------
!    diag_integral_output determines if this is a timestep on which
!    integrals are to be written. if not, it returns; if so, it calls
!    write_field_averages.
!---------------------------------------------------------------------

type (time_type), intent(in) :: Time

!-----------------------------------------------------------------------
!  intent(in) variables:
!
!         Time     integral time stamp at the current time 
!                  [ time_type ]
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('diag_integral_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    see if integral output is desired at this time. 
!---------------------------------------------------------------------
      if ( diag_integral_alarm(Time) ) then   

!---------------------------------------------------------------------
!    write the integrals by calling write_field_averages. upon return 
!    reset the alarm to the next diagnostics time.
!---------------------------------------------------------------------
        call write_field_averages (Time)
        Next_alarm_time = Next_alarm_time + Alarm_interval
      endif

!-----------------------------------------------------------------------


end subroutine diag_integral_output


!#######################################################################
! <SUBROUTINE NAME="diag_integral_end">
!  <OVERVIEW>
!    diag_integral_end is the destructor for diag_integral_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_integral_end is the destructor for diag_integral_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_integral_end (Time)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   integral time stamp at the current time 
!  </IN>
! </SUBROUTINE>
!
subroutine diag_integral_end (Time)

!--------------------------------------------------------------------
!    diag_integral_end is the destructor for diag_integral_mod.
!--------------------------------------------------------------------

type (time_type), intent(in) :: Time

!----------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('diag_integral_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    if the alarm interval was set to Zero_time (meaning no integral 
!    output during the model run) call write_field_averages to output
!    the integrals valid over the entire period of integration. 
!---------------------------------------------------------------------
      if (Alarm_interval == Zero_time ) then  
!       if (Alarm_interval /= Zero_time ) then  
!       else
        call write_field_averages (Time)
      endif

!---------------------------------------------------------------------
!    deallocate module variables.
!---------------------------------------------------------------------
      deallocate (area)

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------

end subroutine diag_integral_end




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!#######################################################################
! <FUNCTION NAME="set_axis_time">
!  <OVERVIEW>
!    Function to convert input time to a time_type
!  </OVERVIEW>
!  <DESCRIPTION>
!    Function to convert input time to a time_type
!  </DESCRIPTION>
!  <TEMPLATE>
!   time = set_axis_time (atime, units)
!  </TEMPLATE>
!  <IN NAME="atime" TYPE="real">
!   integral time stamp at the current time 
!  </IN>
!  <IN NAME="units" TYPE="character">
!   input units, not used
!  </IN>
! </FUNCTION>
!
function set_axis_time (atime, units) result (Time)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

real,             intent(in) :: atime
character(len=*), intent(in) :: units
type(time_type)  :: Time

!---------------------------------------------------------------------
!  intent(in) variables:
!
!       atime
!       units
!
!  result:
!
!       Time
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      integer          :: sec     ! seconds corresponding to the input
                                  ! variable atime
      integer          :: day = 0 ! day component of time_type variable

!--------------------------------------------------------------------
!    convert the input time to seconds, regardless of input units.
!--------------------------------------------------------------------
      if (units(1:3) == 'sec') then
         sec = int(atime + 0.5)
      else if (units(1:3) == 'min') then
         sec = int(atime*60. + 0.5)
      else if (units(1:3) == 'hou') then
         sec = int(atime*3600. + 0.5)
      else if (units(1:3) == 'day') then
         sec = int(atime*86400. + 0.5)
      else
         call error_mesg('diag_integral_mod', &
                         'Invalid units sent to set_axis_time', FATAL)
      endif

!--------------------------------------------------------------------
!    convert the time in seconds to a time_type variable.
!--------------------------------------------------------------------
      Time = set_time (sec, day)


end function set_axis_time

!######################################################################
! <FUNCTION NAME="get_field_index">
!  <OVERVIEW>
!   get_field_index returns returns the index associated with an 
!   integral name.
!  </OVERVIEW>
!  <DESCRIPTION>
!   get_field_index returns returns the index associated with an 
!   integral name.
!  </DESCRIPTION>
!  <TEMPLATE>
!   index = get_field_index (name)
!  </TEMPLATE>
!  <IN NAME="name" TYPE="real">
!   Name associated with an integral
!  </IN>
! </FUNCTION>
!
function get_field_index (name) result (index)

!---------------------------------------------------------------------
!   get_field_index returns returns the index associated with an 
!   integral name.
!---------------------------------------------------------------------

character(len=*),  intent(in) :: name
integer                       :: index

!--------------------------------------------------------------------
!  intent(in) variables:
!
!       name
!
!   result:
!
!       index
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer :: nc
      integer :: i

!---------------------------------------------------------------------
!
!--------------------------------------------------------------------
      nc = len_trim (name)
      if (nc > max_len_name)  then
        call error_mesg ('diag_integral_mod',  &
                                        'name too long', FATAL)
      endif

!--------------------------------------------------------------------
!    search each field name for the current string. when found exit
!    with the index. if not found index will be 0 upon return, which
!    initiates error condition.
!--------------------------------------------------------------------
      index = 0
      do i = 1, num_field
        if (name(1:nc) ==     &
                       field_name(i) (1:len_trim(field_name(i))) ) then
          index = i
          exit
        endif
      end do

!---------------------------------------------------------------------



 end function get_field_index


!#####################################################################
! <SUBROUTINE NAME="write_field_averages">
!  <OVERVIEW>
!    Subroutine to sum multiple fields, average them and then write the result
!    to an output file.
!  </OVERVIEW>
!  <DESCRIPTION>
!    Subroutine to sum multiple fields, average them and then write the result
!    to an output file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  write_field_averages (Time)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   integral time stamp at the current time 
!  </IN>
! </SUBROUTINE>
!
subroutine write_field_averages (Time)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

type (time_type), intent(in) :: Time

!--------------------------------------------------------------------
!  intent(in) variables:
!
!      Time
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real    :: field_avg(max_num_field)
      real    :: xtime, rcount
      integer :: nn, ninc, nst, nend, fields_to_print
      integer :: i, kount

!--------------------------------------------------------------------
!   local variables:
!
!      field_avg
!      xtime
!      rcount
!      nn
!      ninc
!      nst
!      nend
!      fields_to_print
!      i
!      kount
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    each header and data format may be different and must be generated
!    as needed.
!---------------------------------------------------------------------- 
      fields_to_print = 0
      do i = 1, num_field

!--------------------------------------------------------------------
!    increment the fields_to_print counter.  sum the integrand and the
!    number of data points contributing to it over all processors. 
!--------------------------------------------------------------------
        fields_to_print = fields_to_print + 1
        rcount = real(field_count(i))
        call mpp_sum (rcount)
        call mpp_sum (field_sum(i))
        field_count(i) = nint(rcount)

!--------------------------------------------------------------------
!    verify that all the data expected for an integral has been 
!    obtained.
!--------------------------------------------------------------------
        if (field_count(i) == 0 ) call error_mesg &
                     ('diag_integral_mod',  &
                      'field_count equals zero for field_name ' //  &
                       field_name(i)(1:len_trim(field_name(i))), FATAL )
        kount = field_count(i)/field_size
        if ((field_size)*kount /= field_count(i)) &
          call error_mesg &
                 ('diag_integral_mod',  &
                  'field_count not a multiple of field_size', FATAL )

!----------------------------------------------------------------------
!    define the global integral for field i. reinitialize the point
!    and data accumulators.
!----------------------------------------------------------------------
        field_avg(fields_to_print) = field_sum(i)/  &
                                     (sum_area*float(kount))
        field_sum  (i) = 0.0
        field_count(i) = 0
      end do

!--------------------------------------------------------------------
!    only the root pe will write out data.
!--------------------------------------------------------------------
      if ( mpp_pe() /= mpp_root_pe() ) return

!---------------------------------------------------------------------
!    define the time associated with the integrals just calculated.
!---------------------------------------------------------------------
      xtime = get_axis_time (Time-Time_init_save, time_units)

!---------------------------------------------------------------------
!    generate the new header and data formats.
!---------------------------------------------------------------------
      nst = 1
      nend = fields_per_print_line
      ninc = (num_field-1)/fields_per_print_line + 1
      do nn=1, ninc
        nst = 1 + (nn-1)*fields_per_print_line
        nend = MIN (nn*fields_per_print_line, num_field)
        if (print_header)  call format_text_init (nst, nend)
        call format_data_init (nst, nend)
        if (diag_unit /= 0) then
          write (diag_unit,format_data(1:nd)) &
                 xtime, (field_avg(i),i=nst,nend)
        else
          write (*, format_data(1:nd)) &
                 xtime, (field_avg(i),i=nst,nend)
        endif
      end do

!-----------------------------------------------------------------------


end subroutine write_field_averages




!#######################################################################
! <SUBROUTINE NAME="format_text_init">
!  <OVERVIEW>
!    format_text_init generates the header records to be output in the
!    integrals file.
!  </OVERVIEW>
!  <DESCRIPTION>
!    format_text_init generates the header records to be output in the
!    integrals file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  format_text_init (nst_in, nend_in)
!  </TEMPLATE>
!  <IN NAME="nst_in, nend_in" TYPE="integer">
!    starting/ending integral index which will be included
!                    in this format statement
!  </IN>
! </SUBROUTINE>
!
subroutine format_text_init (nst_in, nend_in)

!----------------------------------------------------------------------
!    format_text_init generates the header records to be output in the
!    integrals file.
!----------------------------------------------------------------------

integer, intent(in), optional :: nst_in, nend_in

!---------------------------------------------------------------------
!  intent(in),optional variables:
!
!       nst_in       starting integral index which will be included
!                    in this format statement
!       nend_in      ending integral index which will be included
!                    in this format statement
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer :: i, nc, nst, nend

!--------------------------------------------------------------------
!   local variables:
!
!        i
!        nc
!        nst
!        nend
! 
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    only the root pe need execute this routine, since only it will 
!    be outputting integrals.
!---------------------------------------------------------------------
      if (mpp_pe() /= mpp_root_pe()) return

!----------------------------------------------------------------------
!    define the starting and ending integral indices that will be
!    included in this format statement.
!----------------------------------------------------------------------
      if (present (nst_in) ) then
        nst = nst_in
        nend = nend_in
      else
        nst = 1
        nend = num_field
      endif

!--------------------------------------------------------------------
!    define the first 11 characters in the format statement.
!--------------------------------------------------------------------
      nt = 11
      format_text(1:nt) = "('#    time"

!--------------------------------------------------------------------
!    generate the rest of the format statement, which will cover
!    integral indices nst to nend. if satndard printout is desired,
!    cycle through the loop.
!--------------------------------------------------------------------
      do i=nst,nend
        nc = len_trim(field_name(i))
        format_text(nt+1:nt+nc+5) =  '     ' // field_name(i)(1:nc)
        nt = nt+nc+5
      end do

!---------------------------------------------------------------------
!    include the end of the format statement.
!---------------------------------------------------------------------
      format_text(nt+1:nt+2) = "')"
      nt = nt+2

!--------------------------------------------------------------------
!    write the format statement to either an output file or to stdout.
!--------------------------------------------------------------------
      if (diag_unit /= 0) then
        write (diag_unit, format_text(1:nt))
      else
        write (*, format_text(1:nt))
      endif

!---------------------------------------------------------------------


end subroutine format_text_init



!#######################################################################
! <SUBROUTINE NAME="format_data_init">
!  <OVERVIEW>
!    format_text_init generates the format to be output in the
!    integrals file.
!  </OVERVIEW>
!  <DESCRIPTION>
!    format_text_init generates the format to be output in the
!    integrals file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  format_data_init (nst_in, nend_in)
!  </TEMPLATE>
!  <IN NAME="nst_in, nend_in" TYPE="integer">
!    starting/ending integral index which will be included
!                    in this format statement
!  </IN>
! </SUBROUTINE>
!
subroutine format_data_init (nst_in, nend_in)

!---------------------------------------------------------------------
!    format_data_init generates the format that will write out the
!    integral data.
!---------------------------------------------------------------------

integer, intent(in), optional :: nst_in, nend_in
   
!--------------------------------------------------------------------
!  intent(in),optional variables:
!
!       nst_in       starting integral index which will be included
!                    in this format statement
!       nend_in      ending integral index which will be included
!                    in this format statement
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer :: i, nc, nst, nend

!--------------------------------------------------------------------
!   local variables:
!
!        i
!        nc
!        nst
!        nend
! 
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the start of the format, which covers the time stamp of the
!    integrals. this section is 9 characters long.
!--------------------------------------------------------------------
      nd = 9
      format_data(1:nd) = '(1x,f10.2'

!--------------------------------------------------------------------
!    define the indices of the integrals that are to be written by this
!    format statement.
!--------------------------------------------------------------------
      if ( present (nst_in) ) then
        nst = nst_in
        nend = nend_in
      else
        nst = 1 
        nend = num_field
      endif

!-------------------------------------------------------------------
!    complete the data format. use the format defined for the 
!    particular integral in setting up the format statement.
!-------------------------------------------------------------------
      do i=nst,nend
         nc = len_trim(field_format(i))
         format_data(nd+1:nd+nc+5) =  ',1x,' // field_format(i)(1:nc)
         nd = nd+nc+5
      end do

!-------------------------------------------------------------------
!    close the format statement.
!-------------------------------------------------------------------
      format_data(nd+1:nd+1) = ')'
      nd = nd + 1

!-------------------------------------------------------------------



end subroutine format_data_init



!#######################################################################
! <FUNCTION NAME="get_axis_time">
!  <OVERVIEW>
!    Function to convert the time_type input variable into units of
!    units and returns it in atime.
!  </OVERVIEW>
!  <DESCRIPTION>
!    Function to convert the time_type input variable into units of
!    units and returns it in atime.
!  </DESCRIPTION>
!  <TEMPLATE>
!   atime = get_axis_time (Time, units)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   integral time stamp
!  </IN>
!  <IN NAME="units" TYPE="character">
!   input units of time_type
!  </IN>
! </FUNCTION>
!
function get_axis_time (Time, units) result (atime)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

type(time_type),  intent(in) :: Time
character(len=*), intent(in) :: units
real                         :: atime

!----------------------------------------------------------------------
!  intent(in) variables:
!
!      Time
!      units
!
!  result:
!
!      atime
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer      :: sec, day  ! components of time_type variable

!-------------------------------------------------------------------
!    get_axis_time converts the time_type input variable into units of
!    units and returns it in atime.
!-------------------------------------------------------------------
      call get_time (Time, sec, day)
      if (units(1:3) == 'sec') then
         atime = float(sec) + 86400.*float(day)
      else if (units(1:3) == 'min') then
         atime = float(sec)/60. + 1440.*float(day)
      else if (units(1:3) == 'hou') then
         atime = float(sec)/3600. + 24.*float(day)
      else if (units(1:3) == 'day') then
         atime = float(sec)/86400. + float(day)
      endif

!--------------------------------------------------------------------
 


end function get_axis_time



!#####################################################################
! <FUNCTION NAME="diag_integral_alarm">
!  <OVERVIEW>
!   Function to check if it is time to write integrals. 
!   if not writing integrals, return.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Function to check if it is time to write integrals. 
!   if not writing integrals, return.
!  </DESCRIPTION>
!  <TEMPLATE>
!   result = diag_integral_alarm (Time)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
! </FUNCTION>
!
 function diag_integral_alarm (Time) result (answer)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

type (time_type), intent(in) :: Time
logical                      :: answer

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      Time
!
!  result:
!
!      answer
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    check if it is time to write integrals. if not writing integrals,
!    return.
!--------------------------------------------------------------------
      answer = .false.
      if (Alarm_interval == Zero_time) return
      if (Time >= Next_alarm_time) answer = .true.

!--------------------------------------------------------------------


end function diag_integral_alarm



!#######################################################################
! <FUNCTION NAME="vert_diag_integral">
!  <OVERVIEW>
!   Function to perform a weighted integral in the vertical 
!    direction of a 3d data field
!  </OVERVIEW>
!  <DESCRIPTION>
!   Function to perform a weighted integral in the vertical 
!    direction of a 3d data field
!  </DESCRIPTION>
!  <TEMPLATE>
!   data2 = vert_diag_integral (data, wt)
!  </TEMPLATE>
!  <IN NAME="data" TYPE="real">
!   integral field data arrays
!  </IN>
!  <IN NAME="wt" TYPE="real">
!   integral field weighting functions
!  </IN>
! </FUNCTION>
!
function vert_diag_integral (data, wt) result (data2)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

real, dimension (:,:,:),         intent(in) :: data, wt
real, dimension (size(data,1),size(data,2)) :: data2

!---------------------------------------------------------------------
!  intent(in) variables;
!
!      data
!      wt
!
!  result:
!      data2
! 
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
 
      real, dimension(size(data,1),size(data,2)) :: wt2

!---------------------------------------------------------------------
!  local variables:
!
!       wt2
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
      wt2 = sum(wt,3)
      if (count(wt2 == 0.) > 0)  then
        call error_mesg ('diag_integral_mod',  &
                             'vert sum of weights equals zero', FATAL)
      endif
      data2 = sum(data*wt,3) / wt2

!---------------------------------------------------------------------


 end function vert_diag_integral




!#######################################################################




                    end module diag_integral_mod




module diffusivity_mod

!=======================================================================
!
!                          DIFFUSIVITY MODULE
!
!     Routines for computing atmospheric diffusivities in the 
!       planetary boundary layer and in the free atmosphere
!
!=======================================================================


use     constants_mod, only : grav, vonkarm, cp_air, rdgas, rvgas

use           mpp_mod, only : input_nml_file
use           fms_mod, only : error_mesg, FATAL, file_exist,   &
                              check_nml_error, open_namelist_file,      &
                              mpp_pe, mpp_root_pe, close_file, &
                              write_version_number, stdlog

use monin_obukhov_mod, only : mo_diff

implicit none
private

! public interfaces
!=======================================================================

 public diffusivity, pbl_depth, molecular_diff

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

! form of iterfaces

!=======================================================================
! subroutine diffusivity (t, q, u, v, p_full, p_half, z_full, z_half, 
!                         u_star, b_star, h, k_m, k_t)

! input:
  
!        t     : real, dimension(:,:,:) -- (:,:,pressure), third index running
!                          from top of atmosphere to bottom
!                 temperature (K)
!
!        q     : real, dimension(:,:,:)
!                 water vapor specific humidity (nondimensional)
!
!        u     : real, dimension(:,:)
!                 zonal wind (m/s)
!
!        v     : real, dimension(:,:,:) 
!                 meridional wind (m/s) 
!
!        z_full  : real, dimension(:,:,: 
!                 height of full levels (m)
!                 1 = top of atmosphere; size(p_half,3) = surface
!                 size(z_full,3) = size(t,3)
!
!        z_half  : real, dimension(:,:,:)
!                 height of  half levels (m)
!                 size(z_half,3) = size(t,3) +1
!              z_half(:,:,size(z_half,3)) must be height of surface!
!                                  (if you are not using eta-model)
!
!        u_star: real, dimension(:,:)
!                friction velocity (m/s)
!
!        b_star: real, dimension(:,:)
!                buoyancy scale (m/s**2)

!   (u_star and b_star can be obtained by calling 
!     mo_drag in monin_obukhov_mod)

! output:

!        h     : real, dimension(:,:,) 
!                 depth of planetary boundary layer (m)
!
!        k_m   : real, dimension(:,:,:)
!                diffusivity for momentum (m**2/s)
!
!                defined at half-levels
!                size(k_m,3) should be at least as large as size(t,3)
!                only the returned values at 
!                      levels 2 to size(t,3) are meaningful
!                other values will be returned as zero
!
!        k_t   : real, dimension(:,:,:)
!                diffusivity for temperature and scalars (m**2/s)
!
!
!=======================================================================


!--------------------- version number ----------------------------------

character(len=128) :: version = '$Id: diffusivity.F90,v 17.0.6.1 2010/08/30 20:39:47 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

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

!  DEFAULT VALUES OF NAMELIST PARAMETERS:

logical :: fixed_depth         = .false.
real    :: depth_0             =  5000.0
real    :: frac_inner          =  0.1
real    :: rich_crit_pbl       =  1.0
real    :: entr_ratio          =  0.2
real    :: parcel_buoy         =  2.0
real    :: znom                =  1000.0
logical :: free_atm_diff       = .false.
logical :: free_atm_skyhi_diff = .false.
logical :: pbl_mcm             = .false.
real    :: rich_crit_diff      =  0.25
real    :: mix_len             = 30.
real    :: rich_prandtl        =  1.00
real    :: background_m        =  0.0
real    :: background_t        =  0.0
logical :: ampns               = .false. ! include delta z factor in 
                                         ! defining ri ?
real    :: ampns_max           = 1.0E20  ! limit to reduction factor
                                         ! applied to ri due to delta z
                                         ! factor
logical :: do_entrain          =.true.
logical :: do_simple           =.false.

namelist /diffusivity_nml/ fixed_depth, depth_0, frac_inner,& 
                           rich_crit_pbl, entr_ratio, parcel_buoy,&
                           znom, free_atm_diff, free_atm_skyhi_diff,&
                           pbl_mcm, rich_crit_diff, mix_len, rich_prandtl,&
                           background_m, background_t, ampns, ampns_max, &
                           do_entrain, do_simple
                          
!=======================================================================

!  OTHER MODULE VARIABLES

real    :: small  = 1.e-04
real    :: gcp    = grav/cp_air
logical :: module_is_initialized   = .false.
real    :: beta   = 1.458e-06
real    :: rbop1  = 110.4
real    :: rbop2  = 1.405

real, parameter :: d608 = (rvgas-rdgas)/rdgas


contains

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

subroutine diffusivity_init

integer :: unit, ierr, io, logunit

!------------------- read namelist input -------------------------------

      if (file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
         read (input_nml_file, nml=diffusivity_nml, iostat=io)
         ierr = check_nml_error(io,"diffusivity_nml")
#else
         unit = open_namelist_file ()
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=diffusivity_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'diffusivity_nml')
         enddo
  10     call close_file (unit)
#endif

!------------------- dummy checks --------------------------------------
         if (frac_inner .le. 0. .or. frac_inner .ge. 1.) &
            call error_mesg ('diffusivity_init',  &
            'frac_inner must be between 0 and 1', FATAL) 
         if (rich_crit_pbl .lt. 0.) &
            call error_mesg ('diffusivity_init',  &
           'rich_crit_pbl must be greater than or equal to zero', FATAL)
         if (entr_ratio .lt. 0.) &
            call error_mesg ('diffusivity_init',  &
            'entr_ratio must be greater than or equal to zero', FATAL)
         if (znom .le. 0.) &
            call error_mesg ('diffusivity_init',  &
            'znom must be greater than zero', FATAL)
         if (.not.free_atm_diff .and. free_atm_skyhi_diff)&
            call error_mesg ('diffusivity_init',  &
            'free_atm_diff must be set to true if '//&
            'free_atm_skyhi_diff = .true.', FATAL) 
         if (rich_crit_diff .le. 0.) &
            call error_mesg ('diffusivity_init',  &
            'rich_crit_diff must be greater than zero', FATAL)
         if (mix_len .lt. 0.) &
            call error_mesg ('diffusivity_init',  &
            'mix_len must be greater than or equal to zero', FATAL)
         if (rich_prandtl .lt. 0.) &
            call error_mesg ('diffusivity_init',  &
            'rich_prandtl must be greater than or equal to zero', FATAL)
         if (background_m .lt. 0.) &
            call error_mesg ('diffusivity_init',  &
            'background_m must be greater than or equal to zero', FATAL)
         if (background_t .lt. 0.) &
            call error_mesg ('diffusivity_init',  &
            'background_t must be greater than or equal to zero', FATAL)
         if (ampns_max .lt. 1.) &
            call error_mesg ('diffusivity_init',  &
            'ampns_max must be greater than or equal to one', FATAL)
         if (ampns .and. .not. free_atm_skyhi_diff) &
            call error_mesg ('diffusivity_init',  &
            'ampns is only valid when free_atm_skyhi_diff is &
                   & also true', FATAL)
      
      endif  !end of reading input.nml

!---------- output namelist to log-------------------------------------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=diffusivity_nml)
      endif

      module_is_initialized = .true.

return
end subroutine diffusivity_init

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

subroutine diffusivity_end

      module_is_initialized = .false.

end subroutine diffusivity_end

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

subroutine diffusivity(t, q, u, v, p_full, p_half, z_full, z_half,  &
                       u_star, b_star, h, k_m, k_t, kbot)

real,    intent(in),           dimension(:,:,:) :: t, q, u, v
real,    intent(in),           dimension(:,:,:) :: p_full, p_half
real,    intent(in),           dimension(:,:,:) :: z_full, z_half
real,    intent(in),           dimension(:,:)   :: u_star, b_star
real,    intent(inout),        dimension(:,:,:) :: k_m, k_t
real,    intent(out),          dimension(:,:)   :: h
integer, intent(in), optional, dimension(:,:)   :: kbot

real, dimension(size(t,1),size(t,2),size(t,3))  :: svcp,z_full_ag, &
                                                   k_m_save, k_t_save
real, dimension(size(t,1),size(t,2),size(t,3)+1):: z_half_ag
real, dimension(size(t,1),size(t,2))            :: z_surf
integer                                         :: i,j,k,nlev,nlat,nlon

if(.not.module_is_initialized) call diffusivity_init

nlev = size(t,3)

k_m_save = k_m
k_t_save = k_t

!compute height of surface
if (present(kbot)) then
   nlat = size(t,2)
   nlon = size(t,1)
   do j=1,nlat
   do i=1,nlon
          z_surf(i,j) = z_half(i,j,kbot(i,j)+1)
   enddo
   enddo
else
   z_surf(:,:) = z_half(:,:,nlev+1)
end if


!compute density profile, and heights relative to surface
do k = 1, nlev
  z_full_ag(:,:,k) = z_full(:,:,k) - z_surf(:,:)
  z_half_ag(:,:,k) = z_half(:,:,k) - z_surf(:,:)
  
  if(do_simple) then
    svcp(:,:,k)  =   t(:,:,k) + gcp*(z_full_ag(:,:,k))
  else
    svcp(:,:,k)  =   t(:,:,k)*(1. + d608*q(:,:,k)) + gcp*(z_full_ag(:,:,k))
  endif
end do
z_half_ag(:,:,nlev+1) = z_half(:,:,nlev+1) - z_surf(:,:)


if(fixed_depth)  then
   h = depth_0
else 
   call pbl_depth(svcp,u,v,z_full_ag,u_star,b_star,h,kbot=kbot)
end if

if(pbl_mcm) then
   call diffusivity_pbl_mcm (u,v, t, p_full, p_half, &
                             z_full_ag, z_half_ag, h, k_m, k_t)
else
   call diffusivity_pbl  (svcp, u, v, z_half_ag, h, u_star, b_star,&
                       k_m, k_t, kbot=kbot)
end if

if(free_atm_diff) &
   call diffusivity_free (svcp, u, v, z_full_ag, z_half_ag, h, k_m, k_t)

k_m = k_m + k_m_save
k_t = k_t + k_t_save

!NOTE THAT THIS LINE MUST FOLLOW DIFFUSIVITY_FREE SO THAT ENTRAINMENT
!K's DO NOT GET OVERWRITTEN IN DIFFUSIVITY_FREE SUBROUTINE
if(entr_ratio .gt. 0. .and. .not. fixed_depth .and. do_entrain) &
    call diffusivity_entr(svcp,z_full_ag,h,u_star,b_star,k_m,k_t)

!set background diffusivities
if(background_m.gt.0.0) k_m = max(k_m,background_m)
if(background_t.gt.0.0) k_t = max(k_t,background_t)


return
end subroutine diffusivity

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

subroutine pbl_depth(t, u, v, z, u_star, b_star, h, kbot)


real,   intent(in) ,           dimension(:,:,:) :: t, u, v, z
real,   intent(in) ,           dimension(:,:)   :: u_star,b_star
real,   intent(out),           dimension(:,:)   :: h
integer,intent(in) , optional, dimension(:,:)   :: kbot

real,    dimension(size(t,1),size(t,2),size(t,3))  :: rich
real,    dimension(size(t,1),size(t,2))            :: ws,k_t_ref,&
                                                      h_inner,tbot
real                                               :: rich1, rich2,&
                                                      h1,h2,svp,t1,t2
integer, dimension(size(t,1),size(t,2))            :: ibot
integer                                            :: i,j,k,nlon,&
                                                      nlat, nlev

nlev = size(t,3)
nlat = size(t,2)
nlon = size(t,1)

!assign ibot, compute tbot (virtual temperature at lowest level)
if (present(kbot)) then
    ibot(:,:) = kbot
    do j = 1,nlat
    do i = 1,nlon
          tbot(i,j) = t(i,j,ibot(i,j))
    enddo
    enddo
else
    ibot(:,:) = nlev
    tbot(:,:) = t(:,:,nlev)
end if


!compute richardson number for use in pbl depth of neutral/stable side
do k = 1,nlev
  rich(:,:,k) =  z(:,:,k)*grav*(t(:,:,k)-tbot(:,:))/tbot(:,:)&
                /(u(:,:,k)*u(:,:,k) + v(:,:,k)*v(:,:,k) + small )
end do

!compute ws to be used in evaluating parcel buoyancy
!ws = u_star / phi(h_inner,u_star,b_star)  .  To find phi
!a call to mo_diff is made.

h_inner(:,:)=frac_inner*znom
call mo_diff(h_inner, u_star, b_star, ws, k_t_ref)
ws = max(small,ws/vonkarm/h_inner)


do j = 1, nlat
 do i = 1, nlon

        !do neutral or stable case 
        if (b_star(i,j).le.0. .or. do_simple) then    
              
              h1     = z(i,j,ibot(i,j))
              h(i,j) = h1
              rich1  = rich(i,j,ibot(i,j))
              do k = ibot(i,j)-1, 1, -1
                       rich2 = rich(i,j,k)
                       h2    = z(i,j,k)
                       if(rich2.gt.rich_crit_pbl) then
                             h(i,j) = h2 + (h1 - h2)*(rich2 - rich_crit_pbl)&
                                                    /(rich2 - rich1        )
                             go to 10
                       endif
                       rich1 = rich2
                       h1    = h2
              enddo 

        !do unstable case
        else

              svp    = tbot(i,j)*(1.+ &
                       (parcel_buoy*u_star(i,j)*b_star(i,j)/grav/ws(i,j)) )
              h1     = z(i,j,ibot(i,j))
              h(i,j) = h1
              t1     = tbot(i,j)
              do k = ibot(i,j)-1 , 1, -1
                       h2 = z(i,j,k)
                       t2 = t(i,j,k)
                       if (t2.gt.svp) then
                             h(i,j) = h2 + (h1 - h2)*(t2 - svp)/(t2 - t1 )
                             go to 10
                       end if
                       h1 = h2
                       t1 = t2
              enddo

        end if
10 continue
  enddo
enddo

return
end subroutine pbl_depth

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

subroutine diffusivity_pbl(t, u, v, z_half, h, u_star, b_star, &
                           k_m, k_t, kbot)

real,    intent(in)  ,           dimension(:,:,:) :: t, u, v, z_half
real,    intent(in)  ,           dimension(:,:)   :: h, u_star, b_star
real,    intent(inout) ,           dimension(:,:,:) :: k_m, k_t
integer, intent(in)  , optional, dimension(:,:)   :: kbot

real, dimension(size(t,1),size(t,2))              :: h_inner, k_m_ref,&
                                                     k_t_ref, factor
real, dimension(size(t,1),size(t,2),size(t,3)+1)  :: zm
real                                              :: h_inner_max
integer                                           :: k, kk, nlev


nlev = size(t,3)

!assign z_half to zm, and set to zero any values of zm < 0.
!the setting to zero is necessary so that when using eta model
!below ground half levels will have zero k_m and k_t
zm = z_half
if (present(kbot)) then
   where(zm < 0.)
        zm = 0.
   end where
end if

h_inner    = frac_inner*h
h_inner_max = maxval(h_inner)

kk = nlev
do k = 2, nlev
  if( minval(zm(:,:,k)) < h_inner_max) then
      kk = k
      exit
  end if
end do

k_m = 0.0
k_t = 0.0

call mo_diff(h_inner        , u_star, b_star, k_m_ref         , k_t_ref)
call mo_diff(zm(:,:,kk:nlev), u_star, b_star, k_m(:,:,kk:nlev), k_t(:,:,kk:nlev))

do k = 2, nlev
  where(zm(:,:,k) >= h_inner .and. zm(:,:,k) < h) 
    factor = (zm(:,:,k)/h_inner)* &
             (1.0 - (zm(:,:,k) - h_inner)/(h - h_inner))**2
    k_m(:,:,k) = k_m_ref*factor
    k_t(:,:,k) = k_t_ref*factor
  end where
end do

return
end subroutine diffusivity_pbl

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

subroutine diffusivity_pbl_mcm(u, v, t, p_full, p_half, z_full, z_half, &
                               h, k_m, k_t)

real, intent(in)  , dimension(:,:,:) :: u, v, t, z_full, z_half
real, intent(in)  , dimension(:,:,:) :: p_full, p_half
real, intent(in)  , dimension(:,:)   :: h
real, intent(inout) , dimension(:,:,:) :: k_m, k_t

integer                                        :: k, nlev
real, dimension(size(z_full,1),size(z_full,2)) :: delta_u, delta_v, delta_z

real :: htcrit_ss
real :: h_ss
real, dimension(size(z_full,1),size(z_full,2)) :: sig_half, z_half_ss, elmix_ss

!  htcrit_ss = height at which mixing length is a maximum (75m)
!  h_ss   = height at which mixing length vanishes (4900m)
!  elmix_ss   = mixing length 

! Define some constants:
!  salaps = standard atmospheric lapse rate (K/m)
!  tsfc   = idealized global mean surface temperature (15C)
real :: tsfc = 288.16
real :: salaps = -6.5e-3

nlev = size(z_full,3)

k_m = 0.

h_ss = depth_0
htcrit_ss = frac_inner*h_ss

do k = 2, nlev

! TK mods 8/13/01:  (code derived from SS)
! Compute the height of each half level assuming a constant
! standard lapse rate using the above procedure.
! WARNING: These should be used with caution.  They will
!  have large errors above the tropopause.

! In order to determine the height, the layer mean temperature
! from the surface to that level is required.  A surface 
! temperature of 15 deg Celsius and a standard lapse rate of 
! -6.5 deg/km will be used to estimate an average temperature 
! profile. 
 
   sig_half = p_half(:,:,k)/p_half(:,:,nlev+1)
   z_half_ss = -rdgas * .5*(tsfc+tsfc*(sig_half**(-rdgas*salaps/grav))) * alog(sig_half)/grav

   !compute mixing length as in SS (no geographical variation)
    elmix_ss = 0.
  
    where (z_half_ss < htcrit_ss .and. z_half_ss > 0.)
         elmix_ss = vonkarm*z_half_ss
    endwhere
    where (z_half_ss >= htcrit_ss .and. z_half_ss < h_ss)
         elmix_ss = vonkarm*htcrit_ss*(h_ss-z_half_ss)/(h_ss-htcrit_ss)
    endwhere

   delta_z = rdgas*0.5*(t(:,:,k)+t(:,:,k-1))*(p_full(:,:,k)-p_full(:,:,k-1))/&
             (grav*p_half(:,:,k))
   delta_u =      u(:,:,k-1) -      u(:,:,k)
   delta_v =      v(:,:,k-1) -      v(:,:,k)
   
   k_m(:,:,k) =   elmix_ss * elmix_ss *&
                  sqrt(delta_u*delta_u + delta_v*delta_v)/delta_z

end do

k_t = k_m

return
end subroutine diffusivity_pbl_mcm

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

subroutine diffusivity_free(t, u, v, z, zz, h, k_m, k_t)

real, intent(in)    , dimension(:,:,:) :: t, u, v, z, zz
real, intent(in)    , dimension(:,:)   :: h
real, intent(inout) , dimension(:,:,:) :: k_m, k_t

real, dimension(size(t,1),size(t,2))   :: dz, b, speed2, rich, fri, &
                                          alpz, fri2
integer                                :: k

do k = 2, size(t,3)

!----------------------------------------------------------------------
!  define the richardson number. set it to zero if it is negative. save
!  a copy of it for later use (rich2).
!----------------------------------------------------------------------
  dz     = z(:,:,k-1) - z(:,:,k)
  b      = grav*(t(:,:,k-1)-t(:,:,k))/t(:,:,k)
  speed2 = (u(:,:,k-1) - u(:,:,k))**2 + (v(:,:,k-1) - v(:,:,k))**2 
  rich= b*dz/(speed2+small)
  rich = max(rich, 0.0)

  if (free_atm_skyhi_diff) then
!---------------------------------------------------------------------
!   limit the standard richardson number to between 0 and the critical 
!   value (rich2). compute the richardson number factor needed in the 
!   eddy mixing coefficient using this standard richardson number.
!---------------------------------------------------------------------
    where (rich(:,:) >= rich_crit_diff) 
      fri2(:,:) = 0.0
    elsewhere
      fri2(:,:)  = (1.0 - rich/rich_crit_diff)**2
    endwhere
  endif

!---------------------------------------------------------------------
!  if ampns is activated, compute the delta z factor. define rich 
!  including this factor.
!---------------------------------------------------------------------
  if (ampns) then
    alpz(:,:) = MIN ( (1.  + 1.e-04*(dz(:,:)**1.5)), ampns_max)
    rich(:,:) = rich(:,:) / alpz(:,:)
  endif

!---------------------------------------------------------------------
!   compute the richardson number factor to be used in the eddy 
!   mixing coefficient. if ampns is on, this value includes it; other-
!   wise it does not.
!---------------------------------------------------------------------
  fri(:,:)   = (1.0 - rich/rich_crit_diff)**2

!---------------------------------------------------------------------
!   compute the eddy mixing coefficients in the free atmosphere ( zz 
!   > h). in the non-ampns case, values are obtained only when the 
!   standard richardson number is sub-critical; in the ampns case values
!   are obtained only when the richardson number computed with the 
!   ampns factor is sub critical. when the ampns factor is activated,
!   it is also included in the mixing coefficient. the value of mixing
!   for temperature, etc. is reduced dependent on the ri stability 
!   factor calculated without the ampns factor.
!---------------------------------------------------------------------
  if (free_atm_skyhi_diff) then

!---------------------------------------------------------------------
!   this is the skyhi-like formulation -- possible ampns factor, ratio
!   of k_m to k_t defined based on computed stability factor.
!---------------------------------------------------------------------
    if (ampns) then
      where (rich < rich_crit_diff .and. zz(:,:,k) > h) 
           k_m(:,:,k) = mix_len*mix_len*sqrt(speed2)*fri(:,:)* &
                        ( 1.  + 1.e-04*(dz(:,:)**1.5))/dz
           k_t(:,:,k) = k_m(:,:,k)* (0.1 + 0.9*fri2(:,:))
      end where
    else
      where (rich < rich_crit_diff .and. zz(:,:,k) > h)
        k_m(:,:,k) = mix_len*mix_len*sqrt(speed2)*fri(:,:)/dz
        k_t(:,:,k) = k_m(:,:,k)* (0.1 + 0.9*fri2(:,:))
      end where
    endif
  else

!---------------------------------------------------------------------
!   this is the non-skyhi-like formulation -- no ampns factor, ratio
!   of k_m to k_t defined by rich_prandtl.
!---------------------------------------------------------------------
    where (rich < rich_crit_diff .and. zz(:,:,k) > h) 
         k_t(:,:,k) = mix_len*mix_len*sqrt(speed2)*fri(:,:)/dz
         k_m(:,:,k) = k_t(:,:,k)*rich_prandtl
    end where
  end if
end do


end subroutine diffusivity_free

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

subroutine molecular_diff ( temp, press, k_m, k_t)

real, intent(in),    dimension (:,:,:)  ::  temp, press
real, intent(inout), dimension (:,:,:)  ::  k_m, k_t    

      real, dimension (size(temp,1), size(temp,2)) :: temp_half, &
                                                      rho_half, rbop2d
      integer      :: k

!---------------------------------------------------------------------

      do k=2,size(temp,3)
        temp_half(:,:) = 0.5*(temp(:,:,k) + temp(:,:,k-1))
        rho_half(:,:) = press(:,:,k)/(rdgas*temp_half(:,:) )
        rbop2d(:,:)  = beta*temp_half(:,:)*sqrt(temp_half(:,:))/  & 
                       (rho_half(:,:)*(temp_half(:,:)+rbop1))
        k_m(:,:,k) = rbop2d(:,:)
        k_t(:,:,k) = rbop2d(:,:)*rbop2
      end do

      k_m(:,:,1) = 0.0
      k_t(:,:,1) = 0.0



end subroutine molecular_diff 



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

subroutine diffusivity_entr(t, z,  h, u_star, b_star, k_m, k_t)

real, intent(in)    , dimension(:,:,:) :: t, z
real, intent(in)    , dimension(:,:)   :: h, u_star, b_star
real, intent(inout) , dimension(:,:,:) :: k_m, k_t

integer                                :: k, nlev

nlev=size(t,3)

do k = 2,nlev
    where (b_star .gt. 0. .and. z(:,:,k-1) .gt. h .and. &
                                z(:,:,k)   .le. h) 
        k_t(:,:,k) = (z(:,:,k-1)-z(:,:,k))*entr_ratio*t(:,:,k)* &
                      u_star*b_star/grav/max(small,t(:,:,k-1)-t(:,:,k))
        k_m(:,:,k) = k_t(:,:,k)
    end where
enddo
end subroutine diffusivity_entr

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

end module diffusivity_mod




!VERSION NUMBER:
!  $Id: cumulus_closure_k.F90,v 17.0.2.1.4.1 2010/03/17 20:27:07 wfc Exp $


!module cumulus_closure_inter_mod
!
!#include "cumulus_closure_interfaces.h"

!end module cumulus_closure_inter_mod

!######################################################################

subroutine cu_clo_cumulus_closure_k   &
         (nlev_hires, diag_unit, debug_ijt, Param, Initialized, &
          Nml, lofactor, dcape, cape_p, &
          qli0_v, qli1_v, qr_v, qt_v, env_r, ri_v, rl_v, parcel_r,   &
          env_t, parcel_t, a1, ermesg, error)

!---------------------------------------------------------------------
!    subroutine cumulus_closure calculates a_1(p_b) for closing the 
!    cumulus parameterization. see LJD notes, "Cu Closure D," 6/11/97
!---------------------------------------------------------------------
 
use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_initialized_type

implicit none

!---------------------------------------------------------------------
integer,                        intent(in)  :: nlev_hires
integer,                        intent(in)  :: diag_unit
logical,                        intent(in)  :: debug_ijt
type(donner_param_type),        intent(in)  :: Param
type(donner_initialized_type),  intent(in)  :: Initialized
type(donner_nml_type),          intent(in)  :: Nml    
real,                           intent(in)  :: lofactor, dcape
real,    dimension(nlev_hires), intent(in)  :: cape_p, qli0_v, qli1_v, &
                                               qr_v, qt_v, env_r, ri_v, &
                                               rl_v, parcel_r, env_t,   &
                                               parcel_t
real,                           intent(out) :: a1
character(len=*),               intent(out) :: ermesg
integer,                        intent(out) :: error

!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   intent(in) variables:
! 
!        cape_p        pressure on cape grid [ Pa ]
!        qli0_v        normalized component of cumulus condensate 
!                      forcing [ kg(h2o) / (kg(air) sec) ]
!                      defined in "Cu Closure D," p. 4.
!        qli1_v        un-normalized component of cumulus condensate
!                      forcing [ kg(h2o) / (kg(air) sec) ]
!                      defined in "Cu Closure D," p. 4.
!        qr_v          normalized cumulus moisture forcing 
!                      [ kg(h2o) / (kg(air) sec) ]
!                      defined in "Cu Closure D," p. 1.
!        qt_v          normalized cumulus thermal forcing 
!                      [ deg K / sec ]
!                      defined in "Cu Closure D," p. 1.
!        env_r         large-scale water-vapor mixing ratio 
!                      [ kg (h2o) / kg(air) ]
!        ri_v          large-scale ice mixing ratio 
!                      [ kg (h2o) / kg(air) ]
!        rl_v          large-scale liquid mixing ratio 
!                      [ kg (h2o) / kg(air) ]
!        parcel_r      parcel vapor mixing ratio  
!                      [ kg (h2o) / kg(air) ]
!        env_t         large-scale temperature [ deg K ]
!        parcel_t      parcel temperature [ deg K ]
!        dcape         rate of change of convective available potential
!                      energy due to large-scale processes 
!                      [ J / (kg s) ]
!        no_precip     logical array indicating columns in which there
!                      is no precip (and thus no deep convection)
!
!   intent(out) variables:
!
!        a1            fractional area of cumulus  ensemble
!        
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      real, dimension (nlev_hires)  :: rt, tden, tdena,  &
                                       dtpdta, pert_env_t, pert_env_r, &
                                       pert_parcel_t, pert_parcel_r, &
                                       parcel_r_clo, parcel_t_clo

      real     :: tau, cape_c
      logical  :: ctrig
      real     :: tdens, tdensa, ri1, ri2, rild, rile, rilf, ri2b,  &
                  sum2, rilak, rilbk, rilck, rilakm, rilbkm, rilckm, &
                  rila, rilb, rilc, ri2ak, ri2akm, ri2a, sum1, plcl, &
                  plfc, plzb, dumcoin, dumxcape
      integer  :: k     

!--------------------------------------------------------------------
!   local variables:
!
!      rt
!      ta
!      ra
!      tden
!      tdena
!      dtpdta
!      Cape_pert
!      tdens
!      tdensa
!      ri1
!      ri2
!      rild
!      rile
!      rilf
!      ri2d
!      sum2
!      rilak
!      rilbk
!      rilck
!      rilakm
!      rilbkm
!      rilckm
!      rila
!      rilb
!      rilc
!      ri2ak
!      ri2akm
!      ri2a
!      sum1
!      debug_ijt
!      perturbed
!      k       
!
!--------------------------------------------------------------------

      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    initialize the perturbed parcel profiles (pert_parcel_t,    
!    pert_parcel_r) and  the perturbed parcel environmental profiles to 
!    the actual parcel profiles.
!--------------------------------------------------------------------
      do k=1,nlev_hires
        pert_parcel_t(k) = env_t(k)
        pert_parcel_r(k) = env_r(k)
        pert_env_r(k)    = env_r(k)
        pert_env_t(k)    = env_t(k)
      end do

!--------------------------------------------------------------------
!    perturb lowest cape-model level mixing ratio and temperature so 
!    that one may calculate the derivative of parcel density temperature
!    w.r.t. surface large-scale density temperature. here the environ-
!    ment is made 1 deg K cooler and the mixing ratio is reduced to
!    99% of its unperturbed value.
!--------------------------------------------------------------------
      pert_env_r(1) = pert_env_r(1) - 0.01*pert_env_r(1)
      pert_env_r(1) = max(pert_env_r(1), 0.0)
      pert_env_t(1) = env_t(1) - 1.0

!---------------------------------------------------------------------
!    if this is a diagnostics column, output the environmental profiles
!    of temperature (pert_env_t) and vapor mixing ratio (pert_env_r) for 
!    the perturbed parcel, vertical profiles of pressure (cape_p), 
!    cumulus moisture forcing (qr_v), cumulus thermal forcing (qt_v), 
!    environmental moisture (env_r) and temperature (env_t) for the
!    unperturbed parcel, parcel temperature (parcel_t) and moisture 
!    (parcel_r) for the unperturbed parcel, cumulus condensate forcing 
!    (qli0 and qli1), ice condensate (ri_v) and liquid condensate (rl_v).
!---------------------------------------------------------------------
      if (debug_ijt) then 
        do k=1,nlev_hires
          write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)')   &
                    'press, temp, vapor in cape: k, p,t,r = ',  &
                           k, cape_p(k), pert_env_t(k), pert_env_r(k)
        end do
        do k=1,nlev_hires
          if (qr_v(k) /= 0.0 .or. qt_v(k) /= 0.0) then
            write (diag_unit, '(a, i4, f19.10, 3e20.12, f20.14)') &
                  'in cuclo: k,p,qr,qt,r,t  =', k,  &
                     cape_p(k), qr_v(k), qt_v(k), env_r(k), env_t(k)
          endif
        end do
        do k=1,nlev_hires
          write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)') &
                    'in cuclo: k,p,tpc, rpc   =', k,   &
                           cape_p(k), parcel_t(k), parcel_r(k)
        end do
        do k=1,nlev_hires
          if (qli0_v(k) /= 0.0 .or. qli1_v(k) /= 0.0 .or. &
              ri_v(k) /= 0.0 .or. rl_v(k) /= 0.0) then
              write (diag_unit, '(a, i4, f19.10, 4e20.12)')   &
                'in cuclo: k,p,qli0,qli1,ri,rl =', k,  &
                     cape_p(k), qli0_v(k), qli1_v(k), ri_v(k), rl_v(k)
          endif
        end do
      endif

      if (Nml%do_freezing_for_cape .NEQV. Nml%do_freezing_for_closure .or. &   ! kerr
          Nml%tfre_for_cape /= Nml%tfre_for_closure .or. &
          Nml%dfre_for_cape /= Nml%dfre_for_closure .or. &
          .not. (Initialized%use_constant_rmuz_for_closure) .or. &
          Nml%rmuz_for_cape /= Nml%rmuz_for_closure) then
           call don_c_displace_parcel_k   &
               (nlev_hires, diag_unit, debug_ijt, Param,  &
                Nml%do_freezing_for_closure, Nml%tfre_for_closure, &
                Nml%dfre_for_closure, Nml%rmuz_for_closure, &
                Initialized%use_constant_rmuz_for_closure,  &
                Nml%modify_closure_plume_condensate, &
                Nml%closure_plume_condensate, &
                env_t,  &
                env_r, cape_p, .false., plfc, plzb, plcl, dumcoin,  &
                dumxcape, parcel_r_clo,  parcel_t_clo, ermesg, error)
      else
        parcel_r_clo = parcel_r
        parcel_t_clo = parcel_t
      endif

!--------------------------------------------------------------------
!    call subroutine displace_parcel to determine the movement of a 
!    parcel from the lcl through the environment defined by (pert_env_t, 
!    pert_env_r).
!--------------------------------------------------------------------
      if (Nml%do_dcape) then

!--------------------------------------------------------------------
!    don't need to calculate cape when using Zhang closure 
!    (do_dcape is .true). 
!--------------------------------------------------------------------
      call don_c_displace_parcel_k   &
           (nlev_hires, diag_unit, debug_ijt, Param,   &
            Nml%do_freezing_for_closure, Nml%tfre_for_closure, &
            Nml%dfre_for_closure, Nml%rmuz_for_closure, &
            Initialized%use_constant_rmuz_for_closure, &
                Nml%modify_closure_plume_condensate, &
                Nml%closure_plume_condensate, &
            pert_env_t, &
            pert_env_r, cape_p, .false., plfc, plzb, plcl, dumcoin,  &
            dumxcape, pert_parcel_r,  pert_parcel_t, ermesg, error)
      else

!--------------------------------------------------------------------
!    if using cape relaxation closure then need to return cape value.
!--------------------------------------------------------------------
      call don_c_displace_parcel_k   &
           (nlev_hires, diag_unit, debug_ijt, Param,   &
            Nml%do_freezing_for_closure, Nml%tfre_for_closure, &
            Nml%dfre_for_closure, Nml%rmuz_for_closure, &
            Initialized%use_constant_rmuz_for_closure, &
                Nml%modify_closure_plume_condensate, &
                Nml%closure_plume_condensate, &
            pert_env_t, &
            pert_env_r, cape_p, .true., plfc, plzb, plcl, dumcoin,  &
            dumxcape, pert_parcel_r,  pert_parcel_t, ermesg, error)
     endif

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return


!---------------------------------------------------------------------
!    define quantities needed for cape relaxation closure option.
!---------------------------------------------------------------------
      if ( .not. Nml%do_dcape) then
        cape_c = Nml%cape0
        tau    = Nml%tau
        if (Nml%do_lands) then
          cape_c = Nml%cape0 * lofactor
          tau    = Nml%tau   * lofactor
        endif
      endif
      if (Nml%do_rh_trig) then
!  currently do_rh_trig forced to be .false.
!  no rh array available at current tiome in donner full.
!       rhavg=0.; dpsum=0.
!       do k = 1,sd%kmax
!         if (sd%p(k) .gt. Nml%plev0) then
!           rhavg  = rhavg + sd%rh(k)*sd%dp(k)
!           dpsum = dpsum + sd%dp(k)
!         end if
!       end do
!       rhavg = rhavg/dpsum
!       ctrig = rhavg > Nml%rhavg0
!! FOR NOW:
        ctrig= .true.
      else
        ctrig= .true.
      endif

!---------------------------------------------------------------------
!    if in a diagnostics column, output the path of the parcel (T, p
!    coordinates).
!---------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_hires
          write (diag_unit, '(a, i4, f20.14, e20.12)')  &
                    'in cuclo: k,tpca,rpca= ', k,    &
                                 pert_parcel_t(k), pert_parcel_r(k)
        end do
      endif

!---------------------------------------------------------------------
!    calculate the large-scale model profile of total-water mixing 
!    ratio. 
!---------------------------------------------------------------------
      do k=1,nlev_hires
        rt(k) = env_r(k) + ri_v(k) + rl_v(k)
      end do

!----------------------------------------------------------------------
!    calculate profiles of density temperatures, in the parcel (tden) 
!    and in the perturbed parcel (tdena). condensate is not included in
!    this definition of density temperature.
!----------------------------------------------------------------------
      do k=1,nlev_hires
        tden(k)  = parcel_t_clo(k)*(1. + (parcel_r_clo(k)/Param%d622)) 
        tdena(k) = pert_parcel_t(k)*(1. + (pert_parcel_r(k)/Param%d622))
      end do

!---------------------------------------------------------------------
!    define the values of density temperature in the environment at the
!    lowest level of the standard parcel displacement case (tdens) and 
!    for the displacement within the perturbed environment (tdensa).
!---------------------------------------------------------------------
      tdens  = env_t(1)*(1. + (env_r(1)/Param%d622))
      tdensa = pert_env_t(1)*(1. + (pert_env_r(1)/Param%d622))

!----------------------------------------------------------------------
!    evaluate derivative of parcel density temperature w.r.t. cloud-base
!    level environmental density temperature.
!----------------------------------------------------------------------
      do k=1,nlev_hires
        dtpdta(k) = (tdena(k) - tden(k))/(tdensa - tdens)
      end do

!---------------------------------------------------------------------
!    if this is a diagnostics column, output the profiles of unperturbed
!    parcel density temperature (tden) and the perturbed parcel density 
!    temperature (tdena) and the derivative of parcel density temper-
!    ature w.r.t. cloud-base large-scale density temperature (dtpdta).
!------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_hires
          write (diag_unit, '(a, i4, 2f20.14, e20.12)')  &
                   'in cuclo: k,tden(k),tdena(k),dtpdta(k)= ',   &
                          k,tden(k), tdena(k),dtpdta(k)
        end do
      endif

!--------------------------------------------------------------------
!    calculate the I1 and I2 integrals from p. 5 of "Cu Closure D" 
!    notes.
!--------------------------------------------------------------------
!--------------------------------------------------------------------
!    define values at the cloud-base level.
!--------------------------------------------------------------------
      rild = qt_v(1)*(Param%d622 + env_r(1))/(Param%d622*(1. + rt(1)))
      rile = env_t(1)*(1. + rl_v(1) + ri_v(1) - Param%d622)*qr_v(1)
      rile = rile/(Param%d622*((1. + rt(1))**2))
      rilf = -env_t(1)*(Param%d622 + env_r(1))*qli0_v(1)
      rilf = rilf/(Param%d622*((1. + rt(1))**2))
      ri2b = env_t(1)*(Param%d622 + env_r(1))/   &
             (Param%d622*((1. + rt(1))**2))
      ri2b = ri2b*qli1_v(1)
      if (Nml%do_freezing_for_closure .or. &
          NMl%rmuz_for_closure /= 0.0) then
        sum2 = rild + rile + rilf
      else
        sum2 = 0.
      endif


      ri1 = 0.
      ri2 = 0.
      do k=2,nlev_hires
        if (cape_p(k) == 0.) exit       
        rilak = -qt_v(k)*(Param%d622 + env_r(k))/   &
                                     (Param%d622*(1. + rt(k)))
        rilbk = -env_t(k)*  &
                   (1. + rl_v(k) + ri_v(k) - Param%d622)*qr_v(k)
        rilbk = rilbk/(Param%d622*((1. + rt(k))**2))
        rilck = env_t(k)*(Param%d622 + env_r(k))*qli0_v(k)
        rilck = rilck/(Param%d622*((1. + rt(k))**2))
        rilakm = -qt_v(k-1)*(Param%d622 + env_r(k-1))/   &
                                          (Param%d622*(1. + rt(k-1)))
        rilbkm = -env_t(k-1)*  &
                     (1. + rl_v(k-1) + ri_v(k-1) - Param%d622)*qr_v(k-1)
        rilbkm = rilbkm/(Param%d622*((1. + rt(k-1))**2))
        rilckm = env_t(k-1)*(Param%d622 + env_r(k-1))*qli0_v(k-1)
        rilckm  =rilckm/(Param%d622*((1. + rt(k-1))**2))
        rila = .5*(rilak + rilakm)
        rilb = .5*(rilbk + rilbkm)
        rilc = .5*(rilck + rilckm)
        ri2ak = env_t(k)*(Param%d622 + env_r(k))/  &
                                         (Param%d622*((1. + rt(k))**2))
        ri2ak = ri2ak*qli1_v(k)
        ri2akm = env_t(k-1)*(Param%d622 + env_r(k-1))/ &
                                  (Param%d622*((1. + rt(k-1))**2))
        ri2akm = ri2akm*qli1_v(k-1)
        ri2a = .5*(ri2ak + ri2akm)
        sum1 = rila + rilb + rilc
        ri1 = ri1 + (alog(cape_p(k-1)/cape_p(k)))*   &
                                     (sum1 + dtpdta(k)*sum2)
        ri2 = ri2 + (alog(cape_p(k-1)/cape_p(k)))*  &
                                      (ri2a - dtpdta(k)*ri2b)

!----------------------------------------------------------------------
!    if in diagnostics column, output the 
!----------------------------------------------------------------------
        if (debug_ijt) then
          write(diag_unit, '(a, i4, e20.12)')   &
                        'in cuclo: k,dtpdta(k)= ',k,dtpdta(k)
          write (diag_unit,   '(a, 3e20.12)')  &
                           'in cuclo: rila,rilb,rilc= ', rila,rilb,rilc
          write (diag_unit, '(a, 2e20.12)')  &
                         'in cuclo: ri1,ri2= ',ri1,ri2
          write (diag_unit, '(a, 2e20.12)')  &
                       'in cuclo: sum1,sum2= ',sum1,sum2
        endif
      end do

!----------------------------------------------------------------------
!    if in diagnostics column, output the 
!----------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                      'in cuclo: rild,rile,rilf= ', rild, rile, rilf
        if (dcape /= 0.0) then
          write (diag_unit, '(a, e20.12)')   &
                    'in cuclo:         dcape=',  dcape     
        endif
      endif

!----------------------------------------------------------------------
!----------------------------------------------------------------------
      if (ri1 >= 0) then
        a1  = 0.
      else
        ri1 = Param%rdgas*ri1
        ri2 = Param%rdgas*ri2
        if (Nml%do_dcape .and. ctrig) then
!   Zhang closure:
          a1  = -(ri2 + dcape)/ri1
        else
          if (dumxcape > cape_c .and. ctrig) then
!   cape relaxation closure:
            a1 = -(ri2 + (dumxcape - cape_c)/tau)/ri1
          else
            a1 = 0.
          endif
        endif
      endif

!--------------------------------------------------------------------


end subroutine cu_clo_cumulus_closure_k



!######################################################################







!VERSION NUMBER:
!  $Id: donner_cape_k.F90,v 17.0.4.1 2010/03/17 20:27:07 wfc Exp $

!module donner_cape_inter_mod

!#include "donner_cape_interfaces.h"

!end module donner_cape_inter_mod

!####################################################################

subroutine don_c_def_conv_env_k          &
         (isize, jsize, nlev_lsm, nlev_hires, Nml, Param, Initialized, &
          Col_diag,    &
          temp, mixing_ratio, pfull, lag_cape_temp, lag_cape_vapor,    &
          lag_cape_press, current_displ, cbmf, Don_cape, Don_conv, ermesg, error)

!---------------------------------------------------------------------
!   subroutine don_c_def_conv_env_k manages the 
!   determination of the stability of moist ascent in each model column,
!   calculating various quantities which define the movement of the 
!   parcel in the given column. 
!---------------------------------------------------------------------

use donner_types_mod, only : donner_nml_type, donner_param_type, &
                             donner_column_diag_type, donner_cape_type,&
                             donner_initialized_type, &
                             donner_conv_type
implicit none

!----------------------------------------------------------------------
integer,                       intent(in)    :: isize, jsize, nlev_lsm, &
                                                nlev_hires
type(donner_nml_type),         intent(in)    :: Nml      
type(donner_param_type),       intent(in)    :: Param
type(donner_initialized_type),       intent(in)    :: Initialized
type(donner_column_diag_type), intent(in)    :: Col_diag
real,    dimension(isize,jsize,nlev_lsm),                    &
                               intent(in)    :: temp, mixing_ratio,  &
                                                pfull, lag_cape_temp, &
                                                lag_cape_vapor, &
                                                lag_cape_press
real,    dimension(isize,jsize),                             &
                               intent(in)    :: current_displ, cbmf 
type(donner_cape_type),        intent(inout) :: Don_cape
type(donner_conv_type),        intent(inout) :: Don_conv
character(len=*),              intent(out)   :: ermesg
integer,                       intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     temp           temperature field at model levels [ deg K ]
!     mixing_ratio   vapor mixing ratio field at model levels 
!                    [ kg(h20) / kg(dry air) ]
!     pfull          pressure field on model full levels [ Pa ]
!     lag_cape_temp  temperature field used in lag-time cape 
!                    calculation [ deg K ]
!     lag_cape_vapor vapor mixing ratio field used in lag-time
!                    cape calculation [ kg(h2o) / kg(dry air) ]
!     lag_cape_press model full-level pressure field used in 
!                    lag-time cape calculation  [ Pa ]
!     current_displ  low-level parcel displacement to use in cape
!                    calculation on this step [ Pa ]
!     cbmf
!
!   intent(out) variables:
!
!     ermesg         character string containing any error message
!                    that is returned from a kernel subroutine
!
!   intent(inout) variables:
!
!     Don_cape       donner_cape type derived type variable containing 
!                    diagnostics and intermediate results related to 
!                    the cape calculation associated with the donner 
!                    convection parameterization
!     Don_conv       donner_conv_type derived type variable containing 
!                    diagnostics and intermediate results describing 
!                    the nature of the convection produced by the 
!                    donner parameterization
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      real,    dimension (isize, jsize, nlev_lsm) :: mid_cape_temp, &
                                                     mid_cape_vapor
      logical, dimension (isize, jsize)           :: no_convection
      integer                                     :: lowest_bl_index
      integer                                     :: i, j, k, n

!----------------------------------------------------------------------
!   local variables:
!     
!    mid_cape_temp       temperature field to be used in the cape 
!                        calculation using current time level values
!                        [ deg K ]
!    mid_cape_vapor      vapor mixing ratio field to be used in the cape
!                        calculation using current time level values
!                        [ kg(h2o) / kg (dry air) ]
!    no_convection       logical indicating columns in which cape calc-
!                        ulation may be skipped because low-level parcel
!                        displacement is downward 
!    lowest_bl_index     k index of topmost level within the surface 
!                        boundary layer (no local time variation of the
!                        temperature and moisture profiles is allowed 
!                        within the sbl) (index 1 at top of model) 
!    i, j, k, n          do-loop indices
!                        
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
       ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    define the vertical index of the highest level within the surface
!    boundary layer (lowest_bl_index).
!---------------------------------------------------------------------
      lowest_bl_index = nlev_lsm - Nml%model_levels_in_sfcbl + 1

!--------------------------------------------------------------------
!    if in diagnostics window, write message indicating lag-time cape
!    calculation is being done.
!--------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          write (Col_diag%unit_dc(n), ' (//, a)')  &
              '               CAPE calculation for LAG time profile'
        end do
      endif
        
!--------------------------------------------------------------------
!    define a flag array which will be .true. when deep convection is
!    precluded in the column due to downward motion at the lowest model
!    level at the current time (no_convection).
!--------------------------------------------------------------------
      if (Nml%use_llift_criteria) then
        no_convection(:,:) = (current_displ(:,:) >= 0.0)
      else
        no_convection(:,:) = (current_displ(:,:) >  0.0)
      end if
      do j=1,jsize
        do i=1,isize
          if (Initialized%using_unified_closure .and.    &
                                             cbmf(i,j) == 0.) then
            no_convection(i,j) = .true.
          endif
        end do
      end do

!---------------------------------------------------------------------
!    call don_c_cape_calculation_driver_k with the lag-time-based 
!    profiles to define the lcl, the moist adiabat, convective inhibition
!    and cape for a parcel displaced upwards from the lowest model level.
!---------------------------------------------------------------------
      call don_c_cape_calculation_driver_k  &
           (isize, jsize, nlev_lsm, nlev_hires, Col_diag, Param, Nml, &
            lag_cape_temp, lag_cape_vapor, lag_cape_press,  &
            no_convection, Don_cape, ermesg, error)
 
!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call don_c_cape_diagnostics_k to output the cape calculation 
!    diagnostics.
!---------------------------------------------------------------------
      call don_c_cape_diagnostics_k   &
           (isize, jsize, nlev_lsm, nlev_hires, Col_diag,  &
            Don_cape, no_convection, ermesg, error)
 
!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
  
!--------------------------------------------------------------------
!    save the values of cape and column integrated water vapor returned
!    from this calculation as the lag-time values of these quantities.
!    the convection parameterization requires the time-tendency of both
!    of these quantities.
!--------------------------------------------------------------------
      Don_cape%qint_lag (:,:) = Don_cape%qint(:,:)
      Don_cape%xcape_lag(:,:) = Don_cape%xcape(:,:)

!--------------------------------------------------------------------
!    if this is a diagnostics window, output a message indicating that 
!    the current-time cape calculation is beginning.
!--------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          write (Col_diag%unit_dc(n), ' (//,  a)')  &
              '               CAPE calculation for CURRENT time profile'
        end do
      endif     

!--------------------------------------------------------------------
!    define the temperature and mixing ratio fields to be used in de-
!    termining the current-time cape sounding values at all levels 
!    above the surface boundary layer. they are the model values as 
!    input from the calling routine.
!--------------------------------------------------------------------
      do k=1,lowest_bl_index-1         
        mid_cape_temp(:,:,k)  = temp(:,:,k)
        mid_cape_vapor(:,:,k) = mixing_ratio(:,:,k)
      end do

!--------------------------------------------------------------------
!    in the surface boundary layer, use the temperature and water vapor
!    values used in the lag-time calculation of cape (the catendb clo-
!    sure). this prevents the production of cape time tendencies  
!    resulting from temporal noise from the surface boundary layer. 
!--------------------------------------------------------------------
      do k=lowest_bl_index, nlev_lsm
        mid_cape_temp(:,:,k) = lag_cape_temp(:,:,k)
        mid_cape_vapor(:,:,k) = lag_cape_vapor(:,:,k)
      end do

!---------------------------------------------------------------------
!    call don_c_cape_calculation_driver_k with the current-time-
!    based profiles to define the lcl, the moist adiabat, convective 
!    inhibition and cape for a parcel displaced upwards from the lowest 
!    model level.
!---------------------------------------------------------------------
      call don_c_cape_calculation_driver_k  &
           (isize, jsize, nlev_lsm, nlev_hires, Col_diag, Param, Nml, &
            mid_cape_temp, mid_cape_vapor, pfull,  &
            no_convection, Don_cape, ermesg, error)
 
!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call don_c_cape_diagnostics_k to output the cape calculation 
!    diagnostics.
!---------------------------------------------------------------------
      call don_c_cape_diagnostics_k   &
           (isize, jsize, nlev_lsm, nlev_hires, Col_diag,  &
            Don_cape, no_convection, ermesg, error)
 
!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------


end subroutine don_c_def_conv_env_k



!#######################################################################

subroutine don_c_cape_calculation_driver_k  &
         (isize, jsize, nlev_lsm, nlev_hires, Col_diag, Param, Nml, &
          temperature, mixing_ratio, pfull, no_convection, Don_cape, &
          ermesg, error)

!--------------------------------------------------------------------
!    subroutine cape_calculation_driver defines high-resolution atmos-
!    pheric temperature and vapor mixing ratio profiles equivalent to 
!    those in the large-scale model, and determines the parameters 
!    defining parcel movement within this environment.
!--------------------------------------------------------------------

use donner_types_mod,only : donner_column_diag_type, donner_param_type,&
                            donner_cape_type, donner_nml_type

implicit none

!--------------------------------------------------------------------
integer,                               intent(in)    :: isize, jsize,  &
                                                        nlev_lsm, &
                                                        nlev_hires
type(donner_column_diag_type),         intent(in)    :: Col_diag
type(donner_param_type),               intent(in)    :: Param
type(donner_nml_type),                 intent(in)    :: Nml  
real, dimension(isize,jsize,nlev_lsm), intent(in)    :: temperature,  &
                                                        mixing_ratio, &
                                                        pfull
logical, dimension(isize,jsize),       intent(in)    :: no_convection
type(donner_cape_type),                intent(inout) ::  Don_cape
character(len=*),                      intent(out)   :: ermesg
integer,                               intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      temperature      temperature profile on large-scale model grid 
!                       that is to be used for the cape calculation 
!                       [ deg K ]
!      mixing_ratio     water vapor mixing ratio profile on the large-
!                       scale model grid that is to be used in the cape 
!                       calculation [ kg(h2o) / kg(dry air) ]
!      pfull            large-scale model full-level pressure profile 
!                       [ Pa ]
!      no_convection    logical indicating if convection is precluded 
!                       from column because of lowest-level downward 
!                       motion
!
!   intent(inout) variables:
!
!     Don_cape          donner_cape type derived type variable contain-
!                       ing diagnostics and intermediate results related
!                       to the cape calculation associated with the 
!                       donner convection parameterization
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

       logical :: debug_ijt     ! logical indicating if diagnostics are
                                ! desired in current column
       integer  :: diag_unit    ! unit number for diagnostic output for
                                ! current column
       integer  :: i, j, n      ! do-loop indices

      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    loop over columns in physics window.
!------------------------------------------------------------------
      do j=1,jsize
        do i=1,isize

!---------------------------------------------------------------------
!    if deep convection is not precluded in this column, continue the
!    calculation; if deep convection is precluded in this column, 
!    the variables contained in Don_cape will retain the values prev-
!    iously given them on initialization.
!---------------------------------------------------------------------
          if (.not. no_convection(i,j)) then

!---------------------------------------------------------------------
!    define a logical variable indicating if diagnostics are to be
!    produced for this column. if so, define the unit number for the
!    output file (diag_unit).
!---------------------------------------------------------------------
            debug_ijt = .false.
            if (Col_diag%in_diagnostics_window) then
               do n=1,Col_diag%ncols_in_window
                 if (j == Col_diag%j_dc(n) .and.     &
                     i == Col_diag%i_dc(n)) then
                   debug_ijt = .true.
                   diag_unit = Col_diag%unit_dc(n)
                   exit
                 endif
               end do
            endif

!--------------------------------------------------------------------
!    call generate_cape_sounding to produce a high-resolution atmos-
!    pheric sounding to be used to evaluate cape.
!--------------------------------------------------------------------
            call don_c_generate_cape_sounding_k &
                 (nlev_lsm, nlev_hires, temperature(i,j,:),   &
                  mixing_ratio(i,j,:), pfull(i,j,:),   &
                  Don_cape%model_t(i,j,:), Don_cape%model_r(i,j,:), &
                  Don_cape%model_p(i,j,:), Don_cape%cape_p(i,j,:), &
                  Don_cape%env_t(i,j,:), Don_cape%env_r(i,j,:), ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return

!--------------------------------------------------------------------
!    call displace_parcel to calculate the behavior of a parcel moving
!    upwards in the model column defined by Don_cape%cape_p, 
!    Don_cape%env_t and Don_cape%env_r.
!--------------------------------------------------------------------
            call don_c_displace_parcel_k   &
                 (nlev_hires, diag_unit, debug_ijt, Param,    &
                  Nml%do_freezing_for_cape, Nml%tfre_for_cape, &
                  Nml%dfre_for_cape, Nml%rmuz_for_cape, &
!      the following value of .true. corresponds to the dummy argument 
!      use_constant_rmuz. it currently must be .true. for this call to  
!      displace_parcel; it may be false when displace_parcel is called
!      for a closure calculation.
                  .true., &  ! (use_constant_rmuz)
!      the following value corresponds to dummy argument 
!      carry_condensate.  it currently must be set to .false. for cape
!      calculations used to determine the presence of convection; it 
!      may be set true in calls to displace_parcel used for closure
!      calculations.
                   .false., &  ! (carry_condensate)
                 Nml%closure_plume_condensate, & ! (is not used when 
                                                 ! carry_condensate
                                                 ! is .false.)
                  Don_cape%env_t(i,j,:), Don_cape%env_r(i,j,:), &
                  Don_cape%cape_p(i,j,:), .true.,  &
                  Don_cape%plfc(i,j), Don_cape%plzb(i,j),  &
                  Don_cape%plcl(i,j), Don_Cape%coin(i,j),   &
                  Don_cape%xcape(i,j), Don_cape%parcel_r(i,j,:), &
                  Don_cape%parcel_t(i,j,:), ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return

!---------------------------------------------------------------------
!   call integrate_vapor to produce the column integral of water vapor.
!--------------------------------------------------------------------
            call don_c_integrate_vapor_k  &
                 (nlev_hires, Param, Don_cape%env_r(i,j,:),  &
                  Don_cape%cape_p(i,j,:), Don_cape%qint(i,j), ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return
          endif
        end do
      end do

!--------------------------------------------------------------------



end subroutine don_c_cape_calculation_driver_k 


!###################################################################

subroutine don_c_displace_parcel_k   &
         (nlev_hires, diag_unit, debug_ijt, Param, do_freezing, &
          tfreezing, dfreezing, rmuz, use_constant_rmuz, &
          carry_condensate, condensate_carried, env_t, env_r,  &
          cape_p, coin_present, plfc, plzb, plcl, coin, xcape,       &
          parcel_r, parcel_t, ermesg, error)

!----------------------------------------------------------------------
!    displace_parcel moves a parcel upwards from the lowest model level
!    (istart) in an environment defined by env_t, env_r and cape_p, 
!    determining the critical transition levels during its ascent (plfc,
!    plzb, plcl), its temperature (parcel_t) and mixing ratio (parcel_r)
!    at each pressure level (cape_p) during its ascent, and if desired,
!    calculating the associated energy integrals for the parcel 
!    (xcape, coin).
!---------------------------------------------------------------------

use donner_types_mod, only:  donner_param_type 
implicit none

!---------------------------------------------------------------------
integer,                       intent(in)  :: nlev_hires
integer,                       intent(in)  :: diag_unit
logical,                       intent(in)  :: debug_ijt
type(donner_param_type),       intent(in)  :: Param
logical,                       intent(in)  :: do_freezing, &
                                              use_constant_rmuz, &
                                              carry_condensate
real,                          intent(in)  :: tfreezing, dfreezing, &
                                              rmuz, condensate_carried
real,   dimension(nlev_hires), intent(in)  :: env_t, env_r, cape_p
logical,                       intent(in)  :: coin_present
real,                          intent(out) :: plfc, plzb, plcl
real,                          intent(out) :: coin, xcape
real,   dimension(nlev_hires), intent(out) :: parcel_r, parcel_t   
character(len=*),              intent(out) :: ermesg
integer,                       intent(out) :: error

!--------------------------------------------------------------------
!  intent(in) variables:
!
!      debug_ijt    logical indicating if diagnostics are desired for
!                   current column
!      diag_unit    i/o unit number for diagnostics file
!      env_t        envirionmental temperature field, index 1 nearest
!                   the surface [ deg K ]
!      env_r        envirionmental vapor mixing ratio field, index 1 
!                   nearest the surface [ kg(h2o) / kg(dry air) ]
!      cape_p       pressure profile, index 1 nearest the surface  
!                   [ Pa ]
!
!   intent(out) variables:
!
!      plfc         pressure at level of free convection [ Pa ]
!      plzb         pressure at level of zero buoyancy [ Pa ]
!      plcl         pressure at lifting condensation level [ Pa ]
!      parcel_r     vapor mixing ratio in parcel. it is set to the
!                   environmental value below level ISTART. index 1 
!                   is level nearest earth's surface.
!      parcel_t     temperature in parcel. it is set to the environ-
!                   mental value below level ISTART. index 1 is level 
!                   nearest earth's surface.
!
!   intent(out), optional:
!
!      coin         convective inhibition -- energy required to lift 
!                   parcel from level ISTART to the level of free 
!                   convection. if parcel becomes buoyant below lcl, 
!                   coin can be < 0.  [ Joules / kg ]
!      xcape        convective available potential energy -- energy 
!                   released as parcel moves from level of free 
!                   convection to level of zero buoyancy [ Joules / kg ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_hires)     ::     env_tv, parcel_tv, dtdp, &
                                             delt, sum_xcape, &
                                             rc, fact1, fact2, fact3
      integer ::  klcl, klfc, klzb
      real    ::  tlcl, rlcl
      logical ::  cape_exit
      integer  :: k

      ermesg = ' ' ; error = 0


!--------------------------------------------------------------------
!  define parcel departure point values. convert mixing ratio to 
!  specific humidity.
!--------------------------------------------------------------------
      parcel_t(1:Param%istart) = env_t(1:Param%istart)
      parcel_r(1:Param%istart) = env_r(1:Param%istart)

      call don_c_calculate_lcl_k   &
           (nlev_hires, Param,             &
             parcel_t(Param%istart),   cape_p,   &
                          env_r, env_t, parcel_r, parcel_t, plcl,  &
                          tlcl, rlcl, klcl, cape_exit, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (.not. cape_exit) then

!--------------------------------------------------------------------
!   if in debug mode, print out info on lcl in debug column.
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, f19.10,i4, f20.14, e20.12)')  &
                           'in cape: plcl,klcl,tlcl,rlcl= ',   &
                             plcl    , klcl, tlcl, rlcl       
          write (diag_unit      , '(a, f19.10)')   &
                              'in cape: p(klcl)= ',  cape_p(klcl)
        endif
      else

!---------------------------------------------------------------------
!   if lcl not found, stop calculations in this column.
!---------------------------------------------------------------------
        plfc  = 0.0     
        plzb  = 0.0  
        coin  = 0.0
        xcape = 0.0
        return
      endif

!-------------------------------------------------------------------
!   calculate temperature along saturated adiabat, starting at p(klcl)
!   and a temperature tp to find the level of free convection and
!   the level of zero buoyancy. 
!--------------------------------------------------------------------
      call don_c_define_moist_adiabat_k  &
           (nlev_hires, klcl, Param, parcel_t(klcl), cape_p, env_r, &
            env_t, do_freezing, tfreezing, dfreezing, rmuz,  &
            use_constant_rmuz, carry_condensate, condensate_carried, &
            parcel_t, parcel_r, plfc, plzb, klfc, klzb,  &
            parcel_tv, env_tv, dtdp, rc, fact1, fact2, fact3, cape_exit,&
            ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return


      if (debug_ijt) then
        do k=klcl, klzb+1
          if (.not. (cape_exit)) then
            if  (k == klzb+1) then
            else
              write (diag_unit, '(a, i4, 2f20.14)')  &
                        'in cape: k,tv,tve= ',k,parcel_tv(k), env_tv(k)          
            endif
          else
            write (diag_unit, '(a, i4, 2f20.14)')  &
                        'in cape: k,tv,tve= ',k,parcel_tv(k), env_tv(k)          
          endif
          if (.not. cape_exit) then
            if (k == klzb ) then
              write (diag_unit, '(a, i4, 2f19.10)')  &
                                  'in cape: klzb,plzb,p(klzb)= ',  &
                                   klzb, plzb, cape_p(klzb)
            endif
          endif
          if (k /= klzb+1 .or. cape_exit) then
            if ( k == klzb .and. .not. cape_exit) then 
            else
              write (diag_unit, '(a, 3f17.10)')  &
                   'in cape: fact1,fact2,rc= ',fact1(k), fact2(k),rc(k)
              write (diag_unit, '(a, 2f17.10)') &
                           'in cape: fact1,fact3= ',fact1(k),fact3(k)
              write (diag_unit, '(a, f17.10)')  &
                            'in cape: dtdp= ',dtdp(k)
              write (diag_unit, '(a,  2f20.14)') &
                             'in cape: tc,t= ',parcel_t(k+1), env_t(k+1)
              write (diag_unit, '(a, f19.10, 2e20.12)') &
                   'in cape: p,r,rs= ',cape_p(k+1), env_r(k+1),   &
                                                         parcel_r(k+1)  
            endif
          endif
        end do
      endif
      if (cape_exit)  then
        coin  = 0.0
        xcape = 0.0
        return
      endif

!--------------------------------------------------------------------
!   if this was a call to calculate perturbed profile, bypass cape and
!   cin calculation, since only the tpc and rpc profiles are needed.
!--------------------------------------------------------------------
      if (coin_present) then

!-------------------------------------------------------------------
!   calculate convective inhibition.
!--------------------------------------------------------------------
        call don_c_calculate_cin_k   &
             (nlev_hires, diag_unit, debug_ijt, Param,  cape_p,  &
              parcel_r, env_r, parcel_t, env_t, plfc, cape_exit,   &
              coin, env_tv, parcel_tv, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

        if (.not. cape_exit) then
          if (debug_ijt) then
            do k=Param%istart,nlev_hires  
              if (parcel_tv(k) /= 0.0) then
                write (diag_unit, '(a, i4, 2f20.14)')  &
                            'in cape: k,tvc,tve= ', k,  &
                         parcel_tv(k), env_tv(k)
              endif
            end do
          endif
        else
          xcape = 0.
          return
        endif

!-------------------------------------------------------------------
!   if desired, print out lfc k index and pressure.
!-------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, f19.10)')  &
                    'in cape: klfc, p(klfc)= ', klfc, cape_p(klfc)
        endif

        call don_c_calculate_cape_k   &
             (nlev_hires, klfc, Param, plzb, cape_p, parcel_r, env_r,   &
              parcel_t, env_t, xcape, delt, sum_xcape, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

!---------------------------------------------------------------------
!   print out cape and cape contribution from this level.
!---------------------------------------------------------------------
        if (debug_ijt) then
          do k=1, size(parcel_t(:))
            if (delt(k) /= 0.0) then
              write (diag_unit, '(a,i4, 2f12.8)')  &
                    'in cape: k,delt,xcape= ',k, delt(k), sum_xcape(k)  
            endif
          end do
        endif

!--------------------------------------------------------------------
!  print out diagnostics (cape, cin, tot), if desired.
!--------------------------------------------------------------------
        if (debug_ijt) then
          if (coin /= 0.0 .or. &
              xcape /= 0.0) then
            write (diag_unit      , '(a, f12.6, a)')  &
                      'in cape: cin= ',coin                ,' J/kg'
            write (diag_unit      , '(a, f12.6, a)')  &
                      'in cape: xcape= ',xcape    ,  ' J/kg'
            write (diag_unit      , '(a, f12.6, a)')  &
                       'in cape: tot= ',xcape - coin     ,' J/kg'
          endif
        endif

!--------------------------------------------------------------------
!  check for error in cape calculation. stop execution if present.
!--------------------------------------------------------------------
        if (xcape        .lt. 0.) then            
          ermesg =  ' xcape error -- value < 0.0 '
          error  = 1
        endif
      endif  ! (present(coin))

!---------------------------------------------------------------------


end subroutine don_c_displace_parcel_k

!#####################################################################

subroutine don_c_define_moist_adiabat_k  &
         (nlev_hires, klcl, Param, starting_temp, press, env_r,  &
          env_t, do_freezing, tfreezing, dfreezing, rmuz_constant, &
          use_constant_rmuz, carry_condensate, condensate_carried, &
          parcel_t, parcel_r, plfc, plzb, klfc, &
          klzb, parcel_tv, env_tv, dtdp, rc, fact1, fact2, fact3, &
          cape_exit, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type 
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none 

!----------------------------------------------------------------------
integer,                      intent(in)    :: nlev_hires, klcl
type(donner_param_type),      intent(in)    :: Param
real,                         intent(in)    :: starting_temp
real, dimension(nlev_hires),  intent(in)    :: press, env_r, env_t
logical,                      intent(in)    :: do_freezing,  &
                                               use_constant_rmuz, &
                                               carry_condensate
real,                         intent(in)    :: tfreezing, dfreezing, &
                                               rmuz_constant, &
                                               condensate_carried
real, dimension(nlev_hires),  intent(inout) :: parcel_t, parcel_r     
real,                         intent(out)   :: plfc, plzb 
integer,                      intent(out)   :: klfc, klzb
real, dimension(nlev_hires),  intent(out)   :: parcel_tv, env_tv, dtdp, &
                                               rc, fact1, fact2, fact3
logical,                      intent(out)   :: cape_exit
character(len=*),             intent(out)   :: ermesg
integer,                      intent(out)   :: error

      real     :: es_v_s, qe_v_s, rs_v_s, qs_v_s, pb, tp_s
      real,dimension(nlev_hires)     :: rmuz, z, fact7
      real     :: dz
      real     :: hlvls
      logical  :: capepos_s 
      integer  :: ieqv_s
      integer  :: k, nbad
      logical  :: not_all_frozen    
      real     :: cumulative_freezing, prev_cufr
      real     :: available_cd, r_at_cb, condensate_to_freeze
      logical  :: first_freezing_level

      ermesg = ' ' ; error = 0

      plfc = 0.0     
      plzb = 0.0  
      klfc = nlev_hires - 1
      klzb = nlev_hires - 1
      capepos_s = .false.
      cape_exit = .false.
      tp_s = starting_temp
      z = 0.

      first_freezing_level = .true.
      fact7 = 0.
      not_all_frozen = .true.
      prev_cufr = 0.
      if (carry_condensate .and. do_freezing) then
        do k=klcl,nlev_hires-1
          if (env_t(k) < tfreezing .and. not_all_frozen) then
            cumulative_freezing = (tfreezing-env_t(k))/dfreezing
            if (cumulative_freezing >= 1.0) then
              cumulative_freezing = 1.0         
              not_all_frozen = .false.
            endif
            fact7(k) = cumulative_freezing - prev_cufr  
            prev_cufr = cumulative_freezing
            if (.not. not_all_frozen) exit
          endif
        end do
      endif
          
!-------------------------------------------------------------------
!    calculate temperature along saturated adiabat, starting at p(klcl)
!    and a temperature tp to find the level of free convection and
!    the level of zero buoyancy. 
!--------------------------------------------------------------------
      do k=klcl,nlev_hires-1

!--------------------------------------------------------------------
!    if pressure has gone below the minimum at which deep convection 
!    is allowed, set flag to end calculation in this column.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    define saturation vapor pressure for the parcel.
!--------------------------------------------------------------------
        call compute_mrs_k (tp_s, press(k), Param%D622, Param%D608, &
                            rs_v_s, nbad,  esat = es_v_s)

!---------------------------------------------------------------------
!    save the cloud base r so that the condensate available when 
!    reaching the level where freezing begins may be determined. 
!---------------------------------------------------------------------
        if (k == klcl) then
          r_at_cb = rs_v_s
        endif
        if ( first_freezing_level) then
          available_cd = r_at_cb - rs_v_s
        endif
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_c_define_moist_adiabat_k: Temperatures out of range of esat table'
          error  = 1
          return
        endif

!--------------------------------------------------------------------
!    define the environmental and parcel virtual temperature and specific
!    humidity.
!--------------------------------------------------------------------
        qe_v_s = env_r(k)/(1. + env_r(k))
        env_tv(k) = env_t(k)*(1.+ Param%D608*qe_v_s   )
        qs_v_s = rs_v_s/(1. + rs_v_s)
        parcel_tv(k) = tp_s*(1. + Param%D608*qs_v_s   )

!--------------------------------------------------------------------
!    determine whether the parcel temperature is cooler or warmer than 
!    the environment.
!--------------------------------------------------------------------
        call don_u_numbers_are_equal_k  &
             (parcel_tv(k), env_tv(k), ermesg, error, ieqv_s)
   
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

!---------------------------------------------------------------------
!    integrate parcel upward, finding level of free convection and 
!    level of zero buoyancy.
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    determine if the level of free convection has been reached. 
!-------------------------------------------------------------------
        if ((ieqv_s >= 0) .and. (.not. capepos_s)) then
          capepos_s    = .true.
          plfc = press(k)  
          klfc = k
        endif

!-------------------------------------------------------------------
!   determine if the level of zero buoyancy has been reached.  if so,
!   set flag so that calculation will be ended in this column.
!-------------------------------------------------------------------
        if ((ieqv_s < 0) .and. (capepos_s)) then
          klzb = k
          plzb = (press(k) + press(k-1))/2.
          parcel_t(k+1:nlev_hires) = env_t(k+1:nlev_hires)
          parcel_r(k+1:nlev_hires) = env_r(k+1:nlev_hires)
          exit

!---------------------------------------------------------------------
!   if not, continue moving parcel up pseudo-adiabat to next cape-
!   calculation pressure level. define new parcel temperature and
!   mixing ratio at this level; if temperature is colder than allowed,
!   end integration.
!-------------------------------------------------------------------
        else   !  (cape is pos, parcel warmer than env)
          klzb    = 0
          if (do_freezing) then
            if (tp_s .gt. tfreezing) then
              hlvls = Param%hlv
            else if (tp_s .le. (tfreezing - dfreezing)) then
              hlvls = Param%hls
            else
              hlvls = (tfreezing - tp_s)*Param%hls + &
                      (tp_s - (tfreezing -dfreezing))*Param%hlv
              hlvls = hlvls/dfreezing 
            endif
          else
            hlvls = Param%hlv
          endif
          rc(k) = (1. - qs_v_s)*Param%rdgas + qs_v_s*Param%rvgas
          pb = 0.5*(press(k) + press(k+1))

!---------------------------------------------------------------------
!     define the entrainment coefficient (rmuz) [ m (-1) ] .
!     z is the height above cloud base [ m ] .
!     dz is the height increment for the current layer.
!---------------------------------------------------------------------
          if (use_constant_rmuz) then
            rmuz(k) = rmuz_constant
          else
            if (k == klcl)  then
              rmuz(klcl) = rmuz_constant
              z(klcl) = 0.  
            else
              dz = - alog((press(k)/press(k-1)))*Param%rdgas*  &
                    parcel_tv(k)/Param%grav
              z(k) = z(k-1) + dz
              rmuz(k) = rmuz_constant/( 1.0 + rmuz_constant*z(k))
            endif
          endif

          fact1(k) = Param%rdgas/Param%cp_air
          fact2(k) = parcel_tv(k) + (hlvls*rs_v_s/rc(k))
          fact1(k) = fact1(k)*fact2(k) +                  &
                     Param%rdgas*env_tv(k)*rmuz(k)*(tp_s-env_t(k)   &
                    + (hlvls*(rs_v_s-env_r(k))/Param%cp_air))/Param%grav
          fact3(k) = Param%d622*(hlvls**2)*es_v_s/    &
                     (Param%cp_air*pb*Param%rvgas*(parcel_tv(k)**2))
          fact3(k) = 1. + fact3(k)

!---------------------------------------------------------------------
!    calculate the term associated with the freezing of condensate 
!    carried along in the plume (fact7).  condensate_to_freeze is the
!    amount of condensate present at the level where freezing begins.
!    it is proportionately frozen over the specified range of freezing. 
!    term may be optionally included when cape is 
!    computed for cumulus closure determination.
!---------------------------------------------------------------------
          if (fact7(k) /= 0.0 .and. first_freezing_level) then
            condensate_to_freeze =    &
                                 MIN(available_cd, condensate_carried)
            first_freezing_level = .false.
          endif
          fact7(k) = Param%hlf*fact7(k)*condensate_to_freeze/  &
                    (Param%cp_air*alog(press(k+1)/press(k)))
          dtdp(k) = (fact1(k) + fact7(k))/fact3(k)
          tp_s    = tp_s + dtdp(k)*alog(press(k+1)/press(k))
          if (tp_s < Param%tmin)  then
            cape_exit = .true.
            parcel_t(k+1) = tp_s
            parcel_r(k+1) = rs_v_s
            parcel_t(k+2:nlev_hires) = env_t(k+2:nlev_hires)
            parcel_r(k+2:nlev_hires) = env_r(k+2:nlev_hires)
            exit  ! exit k loop
          else
            parcel_t(k+1) = tp_s   
            parcel_r(k+1) = rs_v_s   
          endif
        endif   !  (ieq < 0, capepos)
      end do   ! k loop


!-------------------------------------------------------------------


end subroutine don_c_define_moist_adiabat_k



!####################################################################

subroutine don_c_calculate_cin_k    &
         (nlev_hires, diag_unit, debug_ijt, Param, press, parcel_r,   &
          env_r, parcel_t, env_t, plfc, cape_exit, coin,   &
          env_tv, parcel_tv, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none

!----------------------------------------------------------------------
integer,                     intent(in)  :: nlev_hires
integer,                     intent(in)  :: diag_unit
logical,                     intent(in)  :: debug_ijt            
type(donner_param_type),     intent(in)  :: Param
real, dimension(nlev_hires), intent(in)  :: press, parcel_r, env_r,   &
                                            parcel_t, env_t
real,                        intent(in)  :: plfc
logical,                     intent(out) :: cape_exit
real,                        intent(out) :: coin
real,dimension(nlev_hires),  intent(out) :: env_tv, parcel_tv
character(len=*),            intent(out) :: ermesg
integer,                     intent(out) :: error

      real      ::   rbc, rbe, qc, qe, tvc_v_s, tve_v_s, delt
      integer   ::   ieqv_s
      integer   ::   k

!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0
      coin = 0.
      cape_exit = .false.

      parcel_tv(1:Param%istart) = 0.
      env_tv(1:Param%istart) = 0.

!-------------------------------------------------------------------
!   calculate convective inhibition.
!--------------------------------------------------------------------
      do k=Param%istart,nlev_hires-1

!------------------------------------------------------------------
!   determine if sounding fails to produce a level of free convection.
!   if so, set flag to avoid cape calculation. If desired, print out
!   columns where lcl exists, but no lfc. No cin exists above the lfc,
!   and the lfc if it exists must be below UPPER_LIMIT_FOR_LFC.
!------------------------------------------------------------------
        if (press(k+1) <= Param%upper_limit_for_lfc) then
          cape_exit    = .true.
          exit   ! exit k loop
        endif

!--------------------------------------------------------------------
!    define the specific humidity and virtual temperature of the
!    parcel and environment.
!--------------------------------------------------------------------
        rbc = (parcel_r(k) + parcel_r(k+1))/2.
        rbe = (env_r(k) + env_r(k+1))/2.
        qc = rbc/(1. + rbc)
        qe = rbe/(1. + rbe)
        tvc_v_s  = (parcel_t(k) + parcel_t(k+1))/2.
        tve_v_s  = (env_t(k) + env_t(k+1))/2.
        tvc_v_s  = tvc_v_s*(1. + Param%d608*qc)
        tve_v_s  = tve_v_s*(1. + Param%d608*qe)

        env_tv(k) = tve_v_s
        parcel_tv(k) = tvc_v_s

!---------------------------------------------------------------------
!   determine whether the parcel temperature is cooler or warmer than 
!   the environment.
!--------------------------------------------------------------------
        call don_u_numbers_are_equal_k   &
             (tvc_v_s, tve_v_s, ermesg, error, ieqv_s )
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

!---------------------------------------------------------------------
!   add the contribution to cin from this pressure layer.
!---------------------------------------------------------------------
        if ((ieqv_s < 0) .or.      &
            (press(k) > plfc))  then
          delt  = Param%rdgas*(tvc_v_s - tve_v_s)*   &
                      alog(press(k)/press(k+1))
          coin = coin - delt   
        else

!------------------------------------------------------------------
!   determine if sounding fails to produce a level of free convection.
!   if so, set flag to avoid cape calculation. If desired, print out
!   columns where lcl exists, but no lfc.
!------------------------------------------------------------------
          parcel_tv(k+1:nlev_hires) = 0.0
          env_tv(k+1:nlev_hires) = 0.0
          exit
        endif
      end do  ! k loop

!--------------------------------------------------------------------


end subroutine don_c_calculate_cin_k



!######################################################################

subroutine don_c_calculate_cape_k  &
         (nlev_hires, klfc, Param,plzb, press, parcel_r, env_r, &
          parcel_t, env_t, xcape, delt, sum_xcape, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none 

!----------------------------------------------------------------------
integer,                     intent(in)  :: nlev_hires, klfc
type(donner_param_type),     intent(in)  :: Param
real,                        intent(in)  :: plzb
real, dimension(nlev_hires), intent(in)  :: press, parcel_r, env_r,   &
                                            parcel_t, env_t
real,                        intent(out) :: xcape
real, dimension(nlev_hires), intent(out) :: delt, sum_xcape      
character(len=*),            intent(out) :: ermesg
integer,                     intent(out) :: error

      real    :: rbc, rbe, qc, qe, tvc_v_s, tve_v_s
      integer :: ieqv_s
      integer :: k

      ermesg = ' ' ; error = 0

      xcape = 0.
      delt(1:klfc) = 0.0
      sum_xcape(1:klfc) = 0.0

!--------------------------------------------------------------------
!  calculate convective available potential energy.
!--------------------------------------------------------------------
      do k=klfc,nlev_hires-1

!--------------------------------------------------------------------
!  define flag to indicate which columns are actively computing cape.
!-------------------------------------------------------------------
        if (press(k+1) > plzb) then

!--------------------------------------------------------------------
!  define virtual temperature and specific humidity of parcel and 
!  environment.
!-------------------------------------------------------------------
          rbc = (parcel_r(k)+parcel_r(k+1))/2.
          rbe = (env_r(k)+env_r(k+1))/2.
          qc = rbc/(1. + rbc)
          qe = rbe/(1. + rbe)
          tvc_v_s = (parcel_t(k)+parcel_t(k+1))/2.
          tve_v_s = (env_t(k)+env_t(k+1))/2.
          tvc_v_s = tvc_v_s*(1. + Param%d608*qc)
          tve_v_s = tve_v_s*(1. + Param%d608*qe)

!--------------------------------------------------------------------
!   determine whether the parcel temperature is cooler or warmer than 
!   the environment.
!--------------------------------------------------------------------
          call don_u_numbers_are_equal_k   &
               (tvc_v_s, tve_v_s, ermesg, error, ieqv_s)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return


!---------------------------------------------------------------------
!   add the contribution to column cape from this pressure layer.
!---------------------------------------------------------------------
          if (ieqv_s >= 0) then
            delt(k) = Param%rdgas*(tvc_v_s - tve_v_s)*    &
                      alog(press(k)/press(k+1))
            sum_xcape(k) = sum_xcape(k-1) + delt(k)   
          endif

!---------------------------------------------------------------------
!   print out cape and cape contribution from this level.
!---------------------------------------------------------------------
        else
          delt(k:nlev_hires) = 0.0
          sum_xcape(k:nlev_hires) = sum_xcape(k-1)
          xcape = sum_xcape(k-1)
          exit
        endif
      end do  ! end of k loop

!-----------------------------------------------------------------------


end subroutine don_c_calculate_cape_k



!######################################################################

subroutine don_c_generate_cape_sounding_k   &
         (nlev_lsm, nlev_hires, temp, mixing_ratio, pfull, model_t, &
          model_r, model_p, cape_p, env_t, env_r, ermesg, error)  

implicit none

!-------------------------------------------------------------------
!    subroutine generate_cape_sounding reverses the vertical index and
!    saves the input temperature (temp) and vapor mixing ratio 
!    (mixing_ratio) fields on the large-scale model pressure grid 
!    (pfull) as model_t, model_r and model_p. these output variables
!    have index 1 nearest the surface, while the input fields have index
!    1 nearest the upper boundary. after reversal, the fields are 
!    interpolated onto an enhanced vertical grid defined by cape_p, 
!    producing output fields of temperature (env_t) and mixing ratio 
!    (env_r) on the enhanced grid. these fields also have index 1 near-
!    est the surface.
!-------------------------------------------------------------------

integer,                     intent(in)  :: nlev_lsm, nlev_hires
real, dimension(nlev_lsm),   intent(in)  :: temp, mixing_ratio, pfull
real, dimension(nlev_lsm),   intent(out) :: model_t, model_r, model_p
real, dimension(nlev_hires), intent(out) :: cape_p, env_t, env_r
character(len=*),            intent(out) :: ermesg
integer,                     intent(out) :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      temperature      temperature profile on large-scale model grid 
!                       that is to be used for the cape calculation 
!                       [ deg K ]
!      mixing_ratio     water vapor mixing ratio profile on the large-
!                       scale model grid that is to be used in the cape 
!                       calculation [ kg(h2o) / kg(dry air) ]
!      pfull            large-scale model full-level pressure profile 
!                       [ Pa ]
!
!   intent(out) variables:
!
!      model_t          large-scale model temperature field with vert-
!                       ical index 1 nearest the surface [ deg K ]
!      model_r          large-scale model vapor mixing ratio field with
!                       vertical index 1 nearest the surface 
!                       [ kg(h2o) /kg(dry air) ]
!      model_p          large-scale model pressure field with vertical
!                       index 1 nearest the surface [ Pa ]
!      cape_p           high-resolution pressure profile used for cape 
!                       calculation. index 1 nearest surface.  [ Pa ]
!      env_t            high-resolution temperature profile used for 
!                       cape calculation. index 1 nearest surface. 
!                       [ deg K ]
!      env_r            high-resolution vapor mixing ratio profile used
!                       for cape calculation. index 1 nearest thea
!                       surface. [ kg(h2o) / kg(dry air) ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real     :: dp     ! pressure difference between levels in 
                         ! high-resolution model [ Pa ]
      integer  :: k      ! do-loop indices


      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    create arrays of moisture, temperature and pressure having vertical
!    index 1 being closest to the surface. require that the mixing ratio
!    be non-negative.
!--------------------------------------------------------------------
      do k=1,nlev_lsm
        model_r(nlev_lsm+1-k) = amax1 (mixing_ratio(k), 0.0e00)
        model_t(nlev_lsm+1-k) = temp (k)
        model_p(nlev_lsm+1-k) = pfull(k)
      end do

!-------------------------------------------------------------------
!   define the vertical resolution of the convection parameterization
!   grid. define the top level pressure in that grid to be zero.
!   interpolate to define the pressure levels of that grid.
!-------------------------------------------------------------------
      dp = (model_p(1) - model_p(nlev_lsm))/(nlev_hires-1)
      cape_p(nlev_hires) = 0.
      do k=1,nlev_hires-1
        cape_p(k) = model_p(1) - (k-1)*dp     
      end do

!--------------------------------------------------------------------
!   call map_lo_res_col_to_hi_res_col to interpolate the large-scale
!   model grid values of temperature and vapor mixing ratio to the vert-
!   ical grid to be used for the cape calculation. ensure that the 
!   vapor mixing ratio field is positive-definite.
!--------------------------------------------------------------------
      call don_u_lo1d_to_hi1d_k    &
           (nlev_lsm, nlev_hires, model_t, model_p, cape_p,   &
            env_t, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      call don_u_lo1d_to_hi1d_k    &
           (nlev_lsm, nlev_hires, model_r, model_p, cape_p,    &
            env_r, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      do k=1,nlev_hires
         env_r(k) = MAX(env_r(k), 0.0)
      end do

!--------------------------------------------------------------------


end subroutine don_c_generate_cape_sounding_k

!#####################################################################

subroutine don_c_integrate_vapor_k   &
           (nlev_hires, Param, env_r, cape_p, qint, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
use donner_types_mod, only : donner_param_type

implicit none

!----------------------------------------------------------------------
integer,                      intent(in)  :: nlev_hires
type(donner_param_type),      intent(in)  :: Param
real, dimension(nlev_hires),  intent(in)  :: env_r, cape_p
real,                         intent(out) :: qint            
character(len=*),             intent(out) :: ermesg
integer,                      intent(out) :: error

      integer  ::  k
      real     ::  sum

      ermesg= ' ' ; error = 0

      sum  = env_r(1)*(cape_p(1) - cape_p(2))
      do k=2,nlev_hires-1
        sum = sum + env_r(k)*0.5*(cape_p(k-1) - cape_p(k+1))
      end do
      sum = sum + env_r(nlev_hires)*    &
                             (cape_p(nlev_hires-1) - cape_p(nlev_hires))
      qint = sum/Param%grav 

!---------------------------------------------------------------------


end subroutine don_c_integrate_vapor_k



!#####################################################################


subroutine don_c_cape_diagnostics_k   &
         (isize, jsize, nlev_lsm, nlev_hires, Col_diag, Don_cape,  &
          exit_flag, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_column_diag_type, donner_cape_type

implicit none

!----------------------------------------------------------------------
integer,                         intent(in)    :: isize, jsize,   &
                                                  nlev_lsm, nlev_hires
type(donner_column_diag_type),   intent(in)    :: Col_diag
type(donner_cape_type),          intent(inout) :: Don_cape
logical, dimension(isize,jsize), intent(in)    :: exit_flag
character(len=*),                intent(out)   :: ermesg
integer,                         intent(out)   :: error


      integer  :: idiag, jdiag, unitdiag
      integer  :: n, k

      ermesg= ' ' ; error = 0

      
!---------------------------------------------------------------------
!    if desired, print out debug quantities.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          idiag = Col_diag%i_dc(n)
          jdiag = Col_diag%j_dc(n)
          unitdiag = Col_diag%unit_dc(n)
          if ( .not. exit_flag(idiag, jdiag)) then
            if (Don_cape%plfc(idiag,jdiag) /= 0.0 .and.  &
                Don_cape%plzb(idiag,jdiag) /= 0.0 ) then
              do k=1,nlev_lsm - Col_diag%kstart+1 
                write (unitdiag, '(a, i4, f20.14, e20.12, e15.5)') &
                       'calculate_cape input profiles:&
                        & k,temp, mixing ratio, pressure',  k,  &
                        Don_cape%model_t(idiag,jdiag,k), &
                        Don_cape%model_r(idiag,jdiag,k), &
                        Don_cape%model_p(idiag,jdiag,k)
               end do
               write (Col_diag%unit_dc(n), '(a, 2f19.10)')  &
                         'in donner_deep: plfc,plzb= ',  &
                          Don_cape%plfc(idiag,jdiag),  & 
                          Don_cape%plzb(idiag,jdiag)
            endif 
            write (unitdiag, '(a, 3f19.10)')  &
                     'in donner_deep: plcl,coin,xcape= ',   &
                     Don_cape%plcl(idiag,jdiag),  &
                     Don_cape%coin(idiag,jdiag),   &
                     Don_cape%xcape(idiag,jdiag)
            if (Don_cape%plfc(idiag,jdiag) /= 0.0 .and.  &
                Don_cape%plzb(idiag,jdiag) /= 0.0 ) then
              do k=1,nlev_hires              
                write (unitdiag, '(a, i4, f19.10)') &
                  'in donner_deep: k,cape_p= ',k,  &
                      Don_cape%cape_p(idiag,jdiag,k)
                write (unitdiag, '(a, i4, 2f20.14)')  &
                   'in donner_deep: k,tcape,tpca= ',k,   &
                    Don_cape%env_t(idiag,jdiag,k),   &
                    Don_cape%parcel_t(idiag,jdiag,k)
                write (unitdiag, '(a, i4, 2e20.12)')  &
                    'in donner_deep: k,rcape,rpca= ',k,   &
                    Don_cape%env_r(idiag,jdiag,k),    &
                    Don_cape%parcel_r(idiag,jdiag,k)
                if (Don_cape%cape_p(idiag,jdiag,k) <     &
                    Don_cape%plzb(idiag,jdiag))  exit
              end do
            endif
            write (unitdiag, '(a, f20.10)')  &
               'integrate_vapor: qint= ',    &
                   Don_cape%qint(idiag,jdiag)  
          endif 
        end do  ! (n loop)
      endif

!---------------------------------------------------------------------



end subroutine don_c_cape_diagnostics_k 


!####################################################################

subroutine don_c_calculate_lcl_k    &
         (nlev_hires, Param, starting_temp, press, env_r, env_t, &
          parcel_r, parcel_t, plcl, tlcl, rlcl, klcl, cape_exit, ermesg, error)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

use donner_types_mod, only :  donner_param_type
use sat_vapor_pres_k_mod, only: compute_qs_k

implicit none

!---------------------------------------------------------------------
integer,                     intent(in)    :: nlev_hires
type(donner_param_type),     intent(in)    :: Param
real,                        intent(in)    :: starting_temp
real, dimension(nlev_hires), intent(in)    :: press, env_r, env_t 
real, dimension(nlev_hires), intent(inout) :: parcel_r, parcel_t      
real,                        intent(out)   :: plcl, tlcl, rlcl
integer,                     intent(out)   :: klcl
logical,                     intent(out)   :: cape_exit
character(len=*),            intent(out)   :: ermesg
integer,                     intent(out)   :: error

      real     :: qs_v_s, dtdp_v_s, dt_v_s, cp_v_s, q_ve_s, tp_s
      integer  :: ieqv_s       
      integer  :: k, nbad
      
!----------------------------------------------------------------------
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!----------------------------------------------------------------------
!----------------------------------------------------------------------
      q_ve_s    = parcel_r(Param%istart)/( 1. + parcel_r(Param%istart))
      cp_v_s    = Param%cp_air*(1. +             &
                             ((Param%cp_vapor/Param%cp_air) - 1.)*q_ve_s)
      plcl = 0.0     
      klcl = nlev_hires - 1
      cape_exit = .false.
      tp_s = starting_temp

!--------------------------------------------------------------------
!  move the parcel upwards to find the lcl in the column.
!--------------------------------------------------------------------
      do k=Param%istart,nlev_hires  ! k loop to find lcl

!--------------------------------------------------------------------
!  if the temperature and pressure are still within limits, continue 
!  parcel movement. determine saturation specific humidity for parcels 
!  at this level.
!---------------------------------------------------------------------
        if (tp_s >= Param%tmin .and.      &
            press(k) >= Param%upper_limit_for_lcl) then
          call compute_qs_k (tp_s, press(k), Param%d622, Param%d608, &
                             qs_v_s, nbad, q = q_ve_s)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_c_calculate_lcl_k: Temperatures out of range of esat table'
            error  = 1
          endif

!--------------------------------------------------------------------
!  check if the parcel is now saturated.
!---------------------------------------------------------------------
          call don_u_numbers_are_equal_k  &
               (qs_v_s, q_ve_s, ermesg, error, ieqv_s)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

!--------------------------------------------------------------------
!   if saturation is exact or if parcel is super-saturated at its 
!   starting level, save pressure, temp, mixing ratio and cloud base 
!   level. exit vertical loop.
!--------------------------------------------------------------------
          if ( (ieqv_s ==  0) .or. &
               (ieqv_s < 0 .and. k == Param%istart)) then
            plcl = press(k)  
            rlcl = env_r(k)
            tlcl = env_t(k)
            klcl = k
            exit
          endif

!--------------------------------------------------------------------
!   if parcel is super-saturated, define cloud-base pressure, temp 
!   and mixing ratio as the average value between the current level
!   and the next lower level, and this level as the cloud base level.
!   exit the column.
!--------------------------------------------------------------------
          if (ieqv_s < 0) then
            plcl = (press(k) + press(k-1))/2.
            tlcl = (env_t(k) + env_t(k-1))/2.
            rlcl = (env_r(k) + env_r(k-1))/2.
            klcl = k
            exit

!---------------------------------------------------------------------
!    if the parcel remains unsaturated at this level and the top of the 
!    model has not been reached, move parcel along dry adiabat to next 
!    pressure level. define temperature at this level; verify that it 
!    is warmer than tmin. save parcel temperature and mixing ratio at 
!    this next higher level.
!---------------------------------------------------------------------
          else  ! (ieqv_s < 0) 
            if (k < nlev_hires) then
              dtdp_v_s = Param%rdgas*tp_s/cp_v_s   
              dt_v_s = dtdp_v_s*alog( press(k+1)/press(k))
              tp_s = tp_s + dt_v_s    
              if (tp_s < Param%tmin)  then
                cape_exit = .true.
                parcel_t(k+1:nlev_hires) = env_t(k+1:nlev_hires)
                parcel_r(k+1:nlev_hires) = env_r(k+1:nlev_hires)
                exit
              else  
                parcel_t(k+1) = tp_s   
                parcel_r(k+1) = parcel_r(Param%istart)
              endif

!-------------------------------------------------------------------
!    if have reached top of model, set flag to stop integration in this
!    column.
!-------------------------------------------------------------------
            else
              cape_exit    = .true.
            endif
          endif ! (ieqv_s < 0)

!--------------------------------------------------------------------
!    if either parcel temperature or pressure is below cutoff values,
!    set remainder of parcel sounding to the environment and stop 
!    searching in this column.
!--------------------------------------------------------------------
        else
          parcel_t(k+1:nlev_hires) = env_t(k+1:nlev_hires)
          parcel_r(k+1:nlev_hires) = env_r(k+1:nlev_hires)
          cape_exit = .true.
        endif
      end do   ! k loop to find lcl

!------------------------------------------------------------------


end subroutine don_c_calculate_lcl_k



!#####################################################################





!VERSION NUMBER:
!  $Id: donner_cloud_model_k.F90,v 17.0.4.2 2010/09/08 21:25:48 wfc Exp $

!module donner_cloud_model_inter_mod

!#include "donner_cloud_model_interfaces.h"

!end module donner_cloud_model_inter_mod



!#####################################################################

subroutine don_cm_cloud_model_k   &
         (nlev_lsm, nlev_hires, ntr, kou, diag_unit, debug_ijt, Param, &
!++lwh
          Col_diag, Initialized, tb, pb, alpp, cld_press, temp_c, &
!--lwh
          mixing_ratio_c, pfull_c, phalf_c, tracers_c, pcsave, &
          exit_flag_c, wv, rcl, dpf, dpftr, qlw, dfr, flux, pt_kou,  &
          dint, cu, cell_precip, apt, cell_melt, pmelt_lsm, summel, &
          efchr, emfhr, cfracice, etfhr, ncc_kou, tcc, ermesg, error)

!--------------------------------------------------------------------
!
!                ONE-DIMENSIONAL CLOUD MODEL 
!                L. DONNER     NCAR     3 OCT 1984
!
!    subroutine cloud_model receives as input cloud base temperature 
!    (tb), pressure (pb), large-scale model vertical profiles of temper-
!    ature (temp_c), mixing ratio (mixing_ratio_c), pressure (pfull_c and
!    phalf_c), and tracer concentrations (tracers_c) for ensemble member
!    kou and produces as output the in-cloud profiles of temperature 
!    (tcc), vertical velocity (wv), cloud radius (rcl), liquid water 
!    (qlw), condensation rate (dpf), wet-deposition rate (dpftr), 
!    freezing rate (dfr), mass flux
!    (flux), tracer concentrations (xclo), the environmental profiles of 
!    temperature (te), mixing ratio (mre) and tracer concentrations 
!    (xtrae), cloud top pressure (pt_kou), and column integrals of pre-
!    cipitation rate (precip), condensation rate (conint) and freezing 
!    rate (dint). if the current column is a column for which diagnostics
!    is desired (debug_ijt = .true.), then output is written to the diag-
!    nostics file (diag_unit).
!--------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_column_diag_type, &
!++lwh
                             donner_initialized_type
!--lwh

implicit none

!--------------------------------------------------------------------
integer,                            intent(in)     :: nlev_lsm,  &
                                                      nlev_hires, ntr, &
                                                      kou, diag_unit
logical,                            intent(in)     :: debug_ijt
type(donner_param_type),            intent(in)     :: Param
type(donner_column_diag_type),      intent(in)     :: Col_diag
!++lwh
type(donner_initialized_type),      intent(in)     :: Initialized
!--lwh
real,                               intent(in)     :: tb, pb, alpp
real,    dimension(nlev_hires),     intent(in)     :: cld_press
real,    dimension(nlev_lsm),       intent(in)     :: temp_c,   &
                                                      mixing_ratio_c, &
                                                      pfull_c
real,    dimension(nlev_lsm+1),     intent(in)     :: phalf_c 
real,    dimension(nlev_lsm,ntr),   intent(in)     :: tracers_c
real,                               intent(inout)  :: pcsave
logical,                            intent(inout)  :: exit_flag_c     
real,    dimension(nlev_hires),     intent(out)    :: wv, rcl, dpf, &
                                                      qlw, dfr, flux, &
                                                      tcc 
real,                               intent(out)    :: pt_kou, dint, cu,&
                                                      cell_precip,  &
                                                             apt
real,    dimension(nlev_lsm),       intent(out)    :: cell_melt
real,    dimension(nlev_hires),     intent(out)    :: efchr, emfhr,   &
                                                      cfracice
real,    dimension(nlev_hires,ntr), intent(out)    :: etfhr, dpftr
integer,                            intent(out)    :: ncc_kou
real,                               intent( in)    :: pmelt_lsm
real,                               intent(out)    :: summel
character(len=*),                   intent(out)    :: ermesg
integer,                            intent(out)    :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     tb             cloud base temperature [ deg K ]
!     pb             cloud base pressure [ Pa ]             
!     temp_c         large-scale model temperature profile (index 1 
!                    nearest the surface) [ deg K ]
!     mixing_ratio_c large-scale model mixing ratio profile (index 1 
!                    nearest the surface) [ kg(h2o)/ kg(air) ]
!     sig            sigma coordinate of large-scale model levels
!                    index 1 nearest the surface) [ dimensionless ]
!     tracers_c      large-scale model tracer concentration profiles 
!                    (index 1 nearest the surface) [ kg/ kg ]  ???
!     kou            current ensemble member index i
!     diag_unit      output unit number for this diagnostics column
!     debug_ijt      is this a diagnostics column ?
!
!   intent(out) variables:
!
!     tcc            in-cloud temperature profile (index 1 at physical 
!                    base of cloud)  [ deg K ]
!     wv             in-cloud vertical velocity profile (index 1 at 
!                    physical base of cloud)  [ m / sec ]
!     rcl            cloud radius profile (index 1 at physical 
!                    base of cloud)  [ m ]
!     dpf            cloud-area-weighted condensation rate profile
!                    (index 1 at physical base of cloud) 
!                    [ (m**2) * kg(h2o) / kg(air) / sec ]
!     dpftr          wet-deposition rate profile,
!                    weighted by ratio of fractional area to
!                    fractional area at base 
!                    (index 1 at physical base of cloud)
!                    [  [units of xclo] /(sec) ]
!     qlw            cloud liquid water content profile (index 1 at
!                    physical base of cloud) [ kg(h2o) / kg(air) ]
!     dfr            cloud-area-weighted freezing rate profile in 
!                    convective updraft (index 1 at physical base of 
!                    cloud) [ (m**2) *g(h2o) / (kg(air) /  day ]
!     flux           upward mass flux profile in cloud (index 1 at 
!                    physical base of cloud) [ kg(air) / sec ]
!     xclo           in-cloud tracer concentration profiles (index 1 at 
!                    physical base of cloud)  [ kg / kg ] ???
!     te             environmental temperature profile on cloud-model 
!                    grid (index 1 at physical base of cloud) [ deg K ]
!     mre            environmental mixing ratio profile on cloud-model 
!                    grid (index 1 at physical base of cloud) 
!                    [ kg(air) / kg(h2o) ]
!     cell_melt      in-cloud melting of condensate associated with 
!                    convective cells. made up of two parts, 1) that 
!                    due to the freezing of liquid carried upwards 
!                    in the cell updraft, 2) that due to the melting of
!                    condensed ice that precipitates out. if meso 
!                    circulation is present, this component is zero; 
!                    melting will be determined in subroutine mesub.
!     xtrae          environmental tracer profiles on cloud-model 
!                    grid (index 1 at physical base of cloud) 
!                    [ kg / kg ]  ?????
!     pt_kou         pressure at cloud top for this ensemble member[ Pa ]
!     precip         total precipitation rate [ kg(h2o) / sec ]
!     conint         total condensation rate [ kg(h2o) / sec ]
!     dint           total freezing rate in convective updraft 
!                    [ kg(h20) / sec ]
!     cu
!     rc
!     lfc_not_reached      level of free convection was reached ?
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real, dimension (nlev_hires)         ::  pf, te, mre
      real, dimension (nlev_hires,ntr)     ::  xclo, xtrae, pftr 
      real        :: precip, conint,                 pmel
      integer     :: k, kc
      real        :: accond, acpre
      real        :: sumfrea, sumlhr
      logical     :: lfc_not_reached, do_donner_tracer
      integer     ::  cldtop_indx

!--------------------------------------------------------------------
!   local variables:
!
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    if in diagnostic column, output the ensemble member index which
!    is being integrated.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, i4)')    &
            'PROCESSING CLOUD ENSEMBLE MEMBER # ', kou
      endif

!-------------------------------------------------------------------
!    define  or initialize an array to hold any in-cloud tracer sources.
!-------------------------------------------------------------------
      call don_cm_gen_incloud_profs_k  &
           (nlev_lsm, nlev_hires, ntr, kou, diag_unit, debug_ijt, &
            Col_diag, Param, Initialized, tb, pb, alpp, cld_press,  &
            temp_c, mixing_ratio_c, pfull_c, phalf_c, tracers_c,  &
            pcsave,tcc, wv, rcl, qlw, dfr, flux, pf, pftr, te, mre, &
            xclo, xtrae, dint, accond, acpre, sumfrea, cldtop_indx, &
            do_donner_tracer, lfc_not_reached, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    define the cloud top pressure for the current ensemble member.
!--------------------------------------------------------------------
      pt_kou = pb + cldtop_indx*Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    if in diagnostics column, output the ensemble member number and
!    the level of free convection of the most-entraining (first)
!    ensemble member.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, i4, f19.10)') &
                        'in cloudm: kou,pcsave= ',kou,pcsave
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      call don_cm_process_condensate_k     &
         (nlev_lsm, nlev_hires, ntr, cldtop_indx, diag_unit, debug_ijt,&
          Param, acpre, accond, pb, pt_kou, pf, pftr, tcc, rcl,  &
          cld_press, phalf_c, conint, dint, pmel, pmelt_lsm, precip, &
          cu, cell_precip, sumlhr, summel, dpf, dpftr, dfr, cell_melt, &
          ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    if the level of free convection was never reached for this ensemble
!    member, set exit_flag_c so that calculations will cease in this 
!    column, and exit the ensemble members loop. if this is a diag-
!    nostics column, print a message.
!----------------------------------------------------------------------
      if (lfc_not_reached) then
        if (debug_ijt) then
          write (diag_unit, '(a)')  &
                           'in mulsub: lfc never reached'     
        endif
        exit_flag_c = .true.
        return
      endif

!----------------------------------------------------------------------
!    if no precipitation was produced by the ensemble member, set 
!    exit_flag_c so that calculations will cease in this column, and exit
!    the ensemble members loop. if this is a diagnostics column, print 
!    a message.
!----------------------------------------------------------------------
      if (precip == 0.) then
        if (debug_ijt) then
          write (diag_unit, '(a)') &
                       'in mulsub: PRECIP=0 AFTER CLOUD MODEL'
        endif
        exit_flag_c   = .true.
        return
      endif

!---------------------------------------------------------------------
!    if condensate is being evaporated at any level within the cloud, 
!    set exit_flag_c so that calculations will cease in this 
!    column, and exit the ensemble members loop. if this is a diag-
!    nostics column, print a message.
!---------------------------------------------------------------------
      do kc=1,nlev_hires-1           
        if (dpf(kc) > 0.) then 
          if (debug_ijt) then
            write (diag_unit, '(a)') 'in mulsub: dpf  .GT. 0.'
          endif
          exit_flag_c   = .true.
          return   
        endif 
      end do
      if (exit_flag_c) return

!--------------------------------------------------------------------
!    define the cloud model vertical index that is just above cloud top
!    (ncc_kou). this index may be used to limit calculations on the cloud
!    model dimensioned arrays.
!--------------------------------------------------------------------
      do k=1,nlev_hires
        if (cld_press(k) < pt_kou) then
          ncc_kou = k 
          exit
        endif
      end do

!--------------------------------------------------------------------
!    call compute_vertical_fluxes to calculate cumulus thermal forcing 
!    and moisture forcing on the cloud-model grid associated with this
!    ensemble member. 
!--------------------------------------------------------------------
      call don_cm_compute_vert_fluxes_k   &
           (nlev_hires, ntr, ncc_kou, kou, diag_unit, debug_ijt, &
            do_donner_tracer, Param, pt_kou, cld_press, rcl, te, mre, &
            wv, tcc, dpf, xclo, xtrae, apt, efchr, emfhr, etfhr, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    define the fraction of condensation that is ice (cfraci) and that
!    which is liquid (cfracl). at temps above tfre, all condensate is
!    liquid;at temps below (tfre-dfre) all condensate is ice; in between
!    the condensate is partitioned linearly with the temperature depart-
!    ure between these two limits.
!----------------------------------------------------------------------
      cfracice = 0.
      do k=1,ncc_kou
        if (qlw(k) > 0.0) then
          if (tcc(k) > Param%tfre) then
            cfracice(k) = 0.
          else if (tcc(k) < (Param%tfre - Param%dfre)) then
            cfracice(k) = 1.
          else
            cfracice(k) = (Param%tfre - tcc(k))/Param%dfre
          endif
        endif
      end do

!---------------------------------------------------------------------


end subroutine don_cm_cloud_model_k



!#####################################################################

subroutine don_cm_gen_incloud_profs_k  &
         (nlev_lsm, nlev_hires, ntr, kou, diag_unit, debug_ijt, &
          Col_diag,  Param, Initialized, tb, pb, alpp, cld_press, &
          temp_c, mixing_ratio_c, pfull_c, phalf_c, tracers_c, pcsave, &
          tcc, wv, rcl, qlwa, dfr, flux, pf, pftr, te, mre, xclo, &
          xtrae, dint, accond, acpre, sumfrea, cldtop_indx,  &
          do_donner_tracer, lfc_not_reached, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

!  modified by Leo Donner, GFDL, 5 February 2007
!
use donner_types_mod, only : donner_param_type, &
                             donner_column_diag_type, &
                             donner_initialized_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none 

!----------------------------------------------------------------------
integer,                            intent(in)    :: nlev_lsm,   &
                                                     nlev_hires,&
                                                     ntr, kou, diag_unit
logical,                            intent(in)    :: debug_ijt
type(donner_column_diag_type),      intent(in)    :: Col_diag
type(donner_param_type),            intent(in)    :: Param      
!++lwh
type(donner_initialized_type),      intent(in)    :: Initialized
!--lwh
real,                               intent(in)    :: tb, pb, alpp
real,    dimension(nlev_hires),     intent(in)    :: cld_press
real,    dimension(nlev_lsm),       intent(in)    :: temp_c,   &
                                                     mixing_ratio_c,  &
                                                     pfull_c
real,    dimension(nlev_lsm+1),     intent(in)    :: phalf_c    
real,    dimension(nlev_lsm,ntr),   intent(in)    :: tracers_c
real,                               intent(inout) :: pcsave         
real,    dimension(nlev_hires),     intent(out)   :: tcc, wv, rcl, qlwa,&
                                                     dfr, flux, pf
real,    dimension(nlev_hires),     intent(out)   :: te, mre
real,    dimension(nlev_hires,ntr), intent(out)   :: xclo, xtrae, pftr
real,                               intent(out)   :: dint, accond, acpre
real,                               intent(out)  :: sumfrea
integer,                            intent(out)   :: cldtop_indx
logical,                            intent(out)   :: do_donner_tracer, &
                                                     lfc_not_reached
character(len=*),                   intent(out)   :: ermesg
integer,                            intent(out)   :: error

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!   intent(in) variables:
!
!     psfc           surface pressure [ Pa ]
!     tb             cloud base temperature [ deg K ]
!     pb             cloud base pressure [ Pa ]             
!     temp_c         large-scale model temperature profile (index 1 
!                    nearest the surface) [ deg K ]
!     mixing_ratio_c large-scale model mixing ratio profile (index 1 
!                    nearest the surface) [ kg(h2o)/ kg(air) ]
!     sig            sigma coordinate of large-scale model levels
!                    index 1 nearest the surface) [ dimensionless ]
!     tracers_c      large-scale model tracer concentration profiles 
!                    (index 1 nearest the surface) [ kg/ kg ]  ???
!     kou            current ensemble member index i
!     diag_unit      output unit number for this diagnostics column
!     debug_ijt      is this a diagnostics column ?
!
!   intent(out) variables:
!
!     tcc            in-cloud temperature profile (index 1 at physical 
!                    base of cloud)  [ deg K ]
!     wv             in-cloud vertical velocity profile (index 1 at 
!                    physical base of cloud)  [ m / sec ]
!     rcl            cloud radius profile (index 1 at physical 
!                    base of cloud)  [ m ]
!     pf             cloud-area-weighted condensation rate profile
!                    (index 1 at physical base of cloud) 
!                    [ (m**2) * kg(h2o) / kg(air) / sec ]
!     pftr           cloud-area-weighted wet-deposition profile
!                    (index 1 at physical base of cloud)
!                    [ (m**2) * [xlco units] /sec ]
!     qlwa           cloud liquid water content profile (index 1 at
!                    physical base of cloud) [ kg(h2o) / kg(air) ]
!     dfr            cloud-area-weighted freezing rate profile in 
!                    convective updraft (index 1 at physical base of 
!                    cloud) [ (m**2) *g(h2o) / (kg(air) /  day ]
!     flux           upward mass flux profile in cloud (index 1 at 
!                    physical base of cloud) [ kg(air) / sec ]
!     xclo           in-cloud tracer concentration profiles (index 1 at 
!                    physical base of cloud)  [ kg / kg ] ???
!     te             environmental temperature profile on cloud-model 
!                    grid (index 1 at physical base of cloud) [ deg K ]
!     mre            environmental mixing ratio profile on cloud-model 
!                    grid (index 1 at physical base of cloud) 
!                    [ kg(air) / kg(h2o) ]
!     cell_melt      in-cloud melting of condensate associated with 
!                    convective cells. made up of two parts, 1) that 
!                    due to the freezing of liquid carried upwards 
!                    in the cell updraft, 2) that due to the melting of
!                    condensed ice that precipitates out. if meso 
!                    circulation is present, this component is zero; 
!                    melting will be determined in subroutine mesub.
!     xtrae          environmental tracer profiles on cloud-model 
!                    grid (index 1 at physical base of cloud) 
!                    [ kg / kg ]  ?????
!     pt             pressure at cloud top [ Pa ]
!     precip         total precipitation rate [ kg(h2o) / sec ]
!     conint         total condensation rate [ kg(h2o) / sec ]
!     dint           total freezing rate in convective updraft 
!                    [ kg(h20) / sec ]
!     rc
!     lfc_not_reached      level of free convection was reached ?
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real,   dimension(nlev_lsm)         :: sig
      real,   dimension(nlev_hires)       :: dis, rsc
      real,   dimension (nlev_hires,ntr)  ::   clsou
      real     :: qlw, qcw, qrw, dtfr, dtupa, dfrac, rmu,  &
                  rhodt_inv, psfc, actot, dt_micro,          dcw1,  &
                  dqrw3, rbar, rmub, density, densityp, d1, d2, dztr, &
                  entrain, dt_inv
      logical  :: flag
      integer  :: max_cloud_level, ktr
      integer  :: k, nbad
!++lwh
      real, parameter :: g_2_kg = 1.e-3 ! kg/g
      real :: qlw_save, t_avg
      real, dimension( size(xclo,2) ) :: delta_xclo0, delta_xclo1, dwet
      integer :: n
!--lwh

!--------------------------------------------------------------------
!   local variables:
!
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = '  ' ; error = 0

      psfc = phalf_c(1)
      if (ntr /= 0) then
        do_donner_tracer = .true.
      else
        do_donner_tracer = .false.
      endif

!--------------------------------------------------------------------
!    provide appropriate initialization for the output fields. 
!    NOTE: input tracer fields of all zeroes are currently provided if 
!    do_donner_tracer is .false.. one could make the tracer fields
!    optional and define output only when present.
!--------------------------------------------------------------------
      tcc(:)  = 0.
      wv(:)   = 0.
      rcl(:)  = 0.
      qlwa(:) = 0.
      dfr(:)  = 0.
      te(:)   = 0.
      mre(:)  = 0.
      xclo(:,:)  = 0.
      xtrae(:,:) = 0.
      pftr(:,:) = 0.
      flux(:) = 0.
      dint   = 0. 
      lfc_not_reached = .true.

!-------------------------------------------------------------------
!    initialize local variables.
!-------------------------------------------------------------------
      do k=1,nlev_hires
        dis(k)=0.
        pf(k)=0.
      end do

      rsc(:) = 0.
      sig(:) = pfull_c(:)/psfc

!--------------------------------------------------------------------
!    if in diagnostics column, output the cloud base radius, pressure
!    and temperature, and the large-scale model sigma levels.
!--------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_lsm-Col_diag%kstart+1
          write (diag_unit, '(a, i4, e20.12)')  &
                        'in cloudm: k,sig   = ',k, sig(k)    
        end do
      endif

!---------------------------------------------------------------------
!    initialize various integrals.
!---------------------------------------------------------------------

      qcw = 0.
      qlw = 0.
      qrw = 0.

!---------------------------------------------------------------------
!    initialize various integrals.
!---------------------------------------------------------------------
      accond  = 0.
      acpre   = 0.
      dtupa   = 0.
      dfrac   = 0.
      dtfr    = 0.
      sumfrea = 0.

!---------------------------------------------------------------------
!    initialize various conditionals.
!---------------------------------------------------------------------
      cldtop_indx = 0
  
!--------------------------------------------------------------------
!    define the cloud model pressure levels. 
!--------------------------------------------------------------------
      max_cloud_level = nlev_hires + 2
      do k=1,nlev_hires
        if (cld_press(k) < Param%pstop) then
          max_cloud_level = k - 1 
        endif
      end do

!--------------------------------------------------------------------
!    define cloud base (k = 1) values of vertical velocity (wv),
!    temperature (tcc), mixing ratio (rsc), cloud radius (rcl) and
!    tracer concentrations (xclo).
!--------------------------------------------------------------------
      wv(1) = Param%cld_base_vert_vel
      rcl(1) = Param%cloud_base_radius
      tcc(1) = tb
      xclo(1,:) = tracers_c(1,:)
      call compute_mrs_k (tb, pb, Param%D622, Param%D608, rsc(1), nbad)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (nbad /= 0) then
        ermesg = 'subroutine don_cm_gen_incloud_profs_k: '// &
                 'temperatures out of range of esat table'
        error = 1
        return
      endif

!--------------------------------------------------------------------
!    call gcm_to_cm to obtain the large-scale model moisture, temper-
!    ature, and tracer field values at the cloud base pressure to be
!    used as the environmental values in the cloud model.
!--------------------------------------------------------------------
      call don_u_lo1d_to_hi0d_log_k             &
           (nlev_lsm, mixing_ratio_c, sig, psfc, pb, mre(1), ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      call don_u_lo1d_to_hi0d_log_k             &
           (nlev_lsm, temp_c, sig, psfc, pb, te(1), ermesg, error )
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return


      if (do_donner_tracer) then
        do ktr=1,ntr          
          call don_u_lo1d_to_hi0d_log_k             &
               (nlev_lsm, tracers_c(:,ktr), sig, psfc, pb,   &
                xtrae(1,ktr), ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return
        end do
      endif

!--------------------------------------------------------------------
!    if in diagnostics column, output the cloud base radius, pressure
!    and temperature, and the large-scale model sigma levels.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, f19.10, f20.14)')  &
                'in cloudm: RR,PB,TB= ',Param%cloud_base_radius, pb, tb
      endif

!--------------------------------------------------------------------
!    if in diagnostics column, output cloud base values of environ-
!    mental moisture (mre) and temperature (te), and the in-cloud 
!    temperature (tcc).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12,f20.14)')  &
                       'in cloudm: QE,TE,TCC= ',mre(1), te(1), tcc(1)
      endif
      
!---------------------------------------------------------------------
!    loop over cloud model levels, generating the desired in-cloud and 
!    environmental profiles. under no circumstances extend the cal-
!    culation above max_cloud_level (the level above which cloud is not
!    allowed).
!---------------------------------------------------------------------
      do k=1,max_cloud_level-1

!----------------------------------------------------------------------
!    exit the loop if the pressure is lower than the upper limit allowed
!    for the level of free convection and free convection has not yet 
!    been achieved.
!----------------------------------------------------------------------
        if ((cld_press(k+1) <= Param%upper_limit_for_lfc) .and. &
            (lfc_not_reached)) then
          cldtop_indx = 0
          exit
        endif 

!--------------------------------------------------------------------
!    call gcm_to_cm to obtain the large-scale model moisture, temper-
!    ature, and tracer field values at cloud model pressure level to be
!    used as the environmental values in the cloud model.
!--------------------------------------------------------------------
        call don_u_lo1d_to_hi0d_log_k             &
             (nlev_lsm, mixing_ratio_c, sig, psfc, cld_press(k+1),  &
              mre(k+1), ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

        call don_u_lo1d_to_hi0d_log_k             &
             (nlev_lsm, temp_c, sig, psfc, cld_press(k+1),   &
              te(k+1), ermesg, error )

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

        if (do_donner_tracer) then
          do ktr=1, ntr           
            call don_u_lo1d_to_hi0d_log_k             &
                 (nlev_lsm, tracers_c(:,ktr), sig, psfc,   &
                  cld_press(k+1), xtrae(k+1,ktr), ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return
          end do
        endif

!--------------------------------------------------------------------
!    if in diagnostics column, output level k values of vertical
!    velocity, pressure, environmental temperature (te) and moisture 
!    (mre), the in-cloud temperature (tcc) and liquid water (qlw).
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 3e20.12)')  &
                      'in cloudm: WV,PP,TE= ',wv(k), cld_press(k), te(k)
          write (diag_unit, '(a,f20.14, 2e20.12)')  &
                     'in cloudm: TCC(k),qe(k),QLW= ',tcc(k), wv(k), qlw
        endif

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!++lwh
        qlw_save = qlw
!--lwh

        call don_cm_move_parcel_k    &
             (k, kou, diag_unit, debug_ijt, cld_press(k),  &
              cld_press(k+1), alpp, Param, pcsave, qlw, sumfrea, qrw, &
              qcw, dcw1, dqrw3, wv(k), tcc(k), rcl(k), te(k), mre(k), &
              rcl(k+1), wv(k+1), tcc(k+1), rsc(k+1), te(k+1), mre(k+1),&
              qlwa(k+1), dfr(k+1), rmu, rbar, dfrac, dtfr, dtupa,  &
              lfc_not_reached, flag, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

        if (flag) exit

!---------------------------------------------------------------------
!    define the in-cloud  density at levels k and k+1 
!    (density, densityp).
!---------------------------------------------------------------------
        density  = cld_press(k)/(Param%rdgas*(tcc(k)*  &
                               (1. + Param%D608*(rsc(k)/(1.0+rsc(k))))))
        densityp = cld_press(k+1)/(Param%rdgas*(tcc(k+1)*  &
                           (1. + Param%D608*(rsc(k+1)/(1.0+rsc(k+1))))))
 
!--------------------------------------------------------------------
!    calculate in-cloud tracer distribution.
!--------------------------------------------------------------------
        if (do_donner_tracer) then
          clsou(k,:) = 0.0
          clsou(k+1,:) = 0.0
          d1 = Param%rdgas*(1.+Param%virt_mass_co)*tcc(k)*te(k)/  &
               (Param%grav*cld_press(k)*(Param%virt_mass_co*te(k) +  &
                                                                tcc(k)))
          d2 = Param%rdgas*(1.+Param%virt_mass_co)*tcc(k+1)*te(k+1)/ &
               (Param%grav*cld_press(k+1)*      &
                                (Param%virt_mass_co*te(k+1) + tcc(k+1)))
          dztr = ((d1 + d2)*(cld_press(k) - cld_press(k+1))/2.)
          rmub = 2.*alpp/rbar
          entrain = dztr*rmub
          dt_micro = dztr/(0.5*(wv(k) + wv(k+1)))
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12)')   &
                 'in clotr: d1,d2,dz= ',d1,d2,dztr
            write (diag_unit, '(a, e20.12)')   &
                 'in clotr: ent= ',rmub
          endif

!++lwh
!--------------------------------------------------------------------
!    Call tracer wet deposition
!    
!    Convert dqrw3 from g/m3 to kg/m3
!    from g(h2o) per m**3 to kg(h2o) per kg(air).
!--------------------------------------------------------------------
          t_avg = 0.5*(tcc(k)+tcc(k+1))
          do n = 1,size(xclo,2)
             if (Initialized%wetdep(n)%Lwetdep) then
                call wet_deposition_0D    &
                           (Initialized%wetdep(n)%Henry_constant, &
                            Initialized%wetdep(n)%Henry_variable, &
                            Initialized%wetdep(n)%frac_in_cloud, &
                            Initialized%wetdep(n)%alpha_r, &
                            Initialized%wetdep(n)%alpha_s, &
                            t_avg, cld_press(k), cld_press(k+1), &
                            0.5*(density+densityp), &
                            qlw_save, dqrw3*g_2_kg, 0., &
                            xclo(k,n), &
                            Initialized%wetdep(n)%Lgas, &
                            Initialized%wetdep(n)%Laerosol, &
                            Initialized%wetdep(n)%Lice, &
                            delta_xclo0(n) )
             end if
          end do
!--lwh          
          call don_cm_clotr_k    &
               (ntr, diag_unit, debug_ijt, Param, clsou(k,:),  &
                clsou(k+1,:), xtrae(k,:), xtrae(k+1,:), xclo(k,:), &
                entrain, dt_micro, xclo(k+1,:), ermesg, error)
!++lwh
          do n = 1,size(xclo,2)
             if (Initialized%wetdep(n)%Lwetdep) then
                call wet_deposition_0D   &
                           (Initialized%wetdep(n)%Henry_constant, &
                            Initialized%wetdep(n)%Henry_variable, &
                            Initialized%wetdep(n)%frac_in_cloud, &
                            Initialized%wetdep(n)%alpha_r, &
                            Initialized%wetdep(n)%alpha_s, &
                            t_avg, cld_press(k), cld_press(k+1), &
                            0.5*(density+densityp), &
                            qlw, dqrw3*g_2_kg, 0., &
                            xclo(k+1,n), &
                            Initialized%wetdep(n)%Lgas, &
                            Initialized%wetdep(n)%Laerosol, &
                            Initialized%wetdep(n)%Lice, &
                            delta_xclo1(n) )
                dwet(n) = - 0.5*(delta_xclo0(n)+delta_xclo1(n))
                xclo(k+1,n) = xclo(k+1,n) + dwet(n)
             else
                dwet(n) = 0.
             end if
          end do
!--lwh          
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return
        endif

!--------------------------------------------------------------------
!    define cloud-area-weighted precip removal from the layer (dis) in 
!    units of  m**2 * kg(h2o) per kg(air) per day. define rhodt_inv 
!    (10e-03*g*w/delta p) to be used to convert units of dqrw3 and dcw1
!    from g(h2o) per m**3 to kg(h2o) per kg(air).
!--------------------------------------------------------------------
        rhodt_inv = 1.0e-03*(0.5*(wv(k) + wv(k+1)))*Param%GRAV  /   &
                    Param%dp_of_cloud_model
        dis(k) = dqrw3*(rbar**2)*rhodt_inv
        pf(k)  = dcw1*(rbar**2)*rhodt_inv

!---------------------------------------------------------------------
!     define the removal by wet deposition between levels k and k+1
!---------------------------------------------------------------------
        dt_inv = -.25*(wv(k)+wv(k+1))*(density+densityp)*Param%grav  / &
                 Param%dp_of_cloud_model
        do n = 1,size(xclo,2)
          pftr(k,n) = dwet(n) *(rbar**2)*dt_inv
        end do

!---------------------------------------------------------------------
!    calculate moisture subject to freezing in units of g(h2o) per 
!    kg(air) per day, weighted by the cloud area (dfr). add this layer's
!    contribution to the integrated water mass frozen in the updraft 
!    in units of kg(h2o)/sec (dint). 
!---------------------------------------------------------------------
        if (dfr(k+1) /= 0.) then
          dfr(k+1) = dfr(k+1)*densityp*wv(k+1)*(rcl(k+1)**2)*   &
                                      Param%grav/Param%dp_of_cloud_model 
          dfr(k+1) = -dfr(k+1)*Param%cp_air/Param%hlf   
          dint = dint - dfr(k+1)*Param%dp_of_cloud_model/Param%grav  
          dfr(k+1) = dfr(k+1)*8.64E07
        endif 
 
!---------------------------------------------------------------------
!    add this layer's contribution to the integrals accumulating total
!    condensation (accond), precipitation (acpre) and  total liquid
!    water (actot).
!---------------------------------------------------------------------
        accond = accond + dcw1
        acpre  = acpre  + dqrw3
        actot =  accond + acpre

!--------------------------------------------------------------------
!    if in diagnostics column, output the values of accumulated conden-
!    sation, precipitation and total liquid water at this level.
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                        'in cloudm: k,ACCOND,ACPRE= ',k, accond, acpre
          write (diag_unit, '(a, i4, e20.12)')  &
                        'in cloudm:  k,ACTOT= ',k, actot
        endif

!--------------------------------------------------------------------
!    define the mass flux at level k+1 (flux).
!--------------------------------------------------------------------
        if (k == 1) flux(k) = (rcl(k)**2)*wv(k)*density 
        flux(k+1) = (rcl(k+1)**2)*wv(k+1)*densityp

!--------------------------------------------------------------------
!    if in diagnostics column, output the values of cloud radius and
!    entrainment coefficient at this level.
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                     'in cloudm: k,rcl,RMU= ',k, rcl(k), rmu
        endif

!---------------------------------------------------------------------
!    if non-negative water is present, save the current k index as the
!    index of the last cloud model level containing cloud (cldtop_indx).
!---------------------------------------------------------------------
        if (qlwa(k+1) >= 0.) then    
          cldtop_indx = k
        endif  ! (qlwa(k+1) >= 0.0)

!---------------------------------------------------------------------
!    end of loop over cloud model levels. upon leaving loop, in-cloud
!    profiles of model variables have been generated.
!---------------------------------------------------------------------
      end do   ! (do 1 loop)


!--------------------------------------------------------------------
!    if in diagnostics column, output the water mass frozen in the
!    updraft in units of cloud area*kg(h2o) / sec (dint) and the 
!    resultant temperature change (sumfrea).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                'in cloudm: DINT IN CLOUDM,sumfrea= ', dint, sumfrea
      endif

!--------------------------------------------------------------------
!    normalize the column integral of water mass frozen in the updraft
!    by the cloud base area of ensemble member #1.
!--------------------------------------------------------------------
      dint = dint/(Param%cloud_base_radius**2)

!--------------------------------------------------------------------
!    if an acceptable cloud was found for this ensemble member, obtain
!    the needed diagnostic / integral output.
!--------------------------------------------------------------------
      if (cldtop_indx /= 0) then

!--------------------------------------------------------------------
!    if in diagnostics column, output the topmost cloud level and
!    the mixing ratios at and one level above cloud top.  
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                      'in cloudm: n,rsc(n+2),rsc(n)= ',cldtop_indx,   &
                             rsc(cldtop_indx+1),rsc(cldtop_indx)
        endif
      endif ! (cldtop_indx /= 0)

!--------------------------------------------------------------------
!    if in diagnostics column, output the values of cloud-area-
!    weighted layer-mean condensation and  fallout.
!--------------------------------------------------------------------
        do k = 1, cldtop_indx
          if (debug_ijt) then
            write (diag_unit, '(a, i4, 2e20.12)')   &
                       'in cloudm: K,PF,DIS= ', k, pf(k), dis(k)
          endif
        end do


end subroutine don_cm_gen_incloud_profs_k


!#####################################################################

subroutine don_cm_move_parcel_k    &
              (k, kou, diag_unit, debug_ijt, pbot, ptop, alpp, Param,  &
               pcsave, qlw, sumfrea, qrw, qcw, dcw1, dqrw3, wvbot,  &
               tccbot, rclbot, tebot, mrebot, rcltop, wvtop, tcctop, &
               rsctop, tetop, mretop, qlwatop, dfrtop, rmu, rbar, &
               dfrac, dtfr,  dtupa, lfc_not_reached, flag, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!----------------------------------------------------------------------
integer,                 intent(in)    :: k, kou, diag_unit
logical,                 intent(in)    :: debug_ijt
real,                    intent(in)    :: pbot, ptop, alpp
type(donner_param_type), intent(in)    :: Param
real,                    intent(inout) :: pcsave, qlw, sumfrea, qrw, &
                                          qcw, dcw1, dqrw3, wvbot,  &
                                          tccbot, rclbot, tebot, &
                                          mrebot, rcltop, wvtop, &
                                          tcctop, rsctop,&
                                          tetop, mretop, qlwatop,  &
                                          dfrtop, rmu, rbar, dfrac,  &
                                          dtfr, dtupa
logical,                 intent(inout) :: lfc_not_reached
logical,                 intent(out)   :: flag
character(len=*),        intent(out)   :: ermesg
integer,                 intent(out)   :: error

!----------------------------------------------------------------------
      real    ::  dtdp, drdp, dwdp, tcest, west, &
                  rest, qcwest,  qlwest, dtdp2, drdp2, dwdp2, qrwest
      integer :: nbad

!---------------------------------------------------------------------
      flag = .false.

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    define the entrainment coefficient (rmu). 
!    pcsave    = p at which ensemble member 1 becomes buoyant.
!    lfc_not_reached = T below level where vert vel starts to increase 
!    with height 
!    THUS:
!    rmu = 0 when above buoyancy level for member 1, above level where 
!            vert vel starts to increase for this member, AND vert vel
!            is so small that are detraining. Thus rmu = 0. when
!            detraining after having been through a convective tower.
!---------------------------------------------------------------------
      if ((pbot    <= pcsave) .and. (.not. lfc_not_reached) .and. &
          (wvbot <= Param%wdet)) then
        rmu = 0.
      else
        rmu = 2.*alpp/rclbot
      end if 

!--------------------------------------------------------------------
!    call simult to solve for the in-cloud derivatives dT/dp (dtdp), 
!    dw/dp (dwdp) and dr/dp (drdp) for a parcel in motion from cloud 
!    model level k (pressure pp) to pressure level pp + delta p.
!--------------------------------------------------------------------
      call don_cm_simult_k   &
           (diag_unit, debug_ijt, lfc_not_reached, Param, pcsave, rmu, &
            tccbot, rclbot, wvbot, pbot, qlw, tebot, mrebot,   &
            dtdp, drdp, dwdp, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    if in diagnostics column, output cloud base values of environ-
!    mental moisture (mre), liquid water (qlw) and initial cloud
!    radius (cloud_base_radius), and the cloud radius and vertical vel-
!    ocity tendencies returned from subroutine simult.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')   &
             'in cloudm: QE,QLW,RR= ',mrebot,QLW,Param%cloud_base_radius
        write (diag_unit, '(a, 2e20.12)')  &
                                'in cloudm: DPD,DWDP= ',drdp, dwdp
      endif

!--------------------------------------------------------------------
!    define estimated values for t, w and cloud radius based on the
!    derivatives returned from subroutine simult. define the average of
!    the original cloud radius and the new estimate (rbar).
!--------------------------------------------------------------------
      tcest = tccbot + dtdp*Param%dp_of_cloud_model
      west  = wvbot  + dwdp*Param%dp_of_cloud_model
      rest  = rclbot + drdp*Param%dp_of_cloud_model
      rbar  = 0.5*(rest + rclbot)

!--------------------------------------------------------------------
!    if in diagnostics column, output the newly estimated values of 
!    cloud radius (rest) and vertical velocity (west).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                         'in cloudm: rest,west= ',rest, west
      endif

!--------------------------------------------------------------------
!    if any of these estimated values are incompatible with the exist-
!    ence of deep convection at this level, exit this vertical loop --
!    cloud does not extend any higher.
!--------------------------------------------------------------------
      if (rbar <= Param%rbound .or. &    
          west <= Param%wbound .or. &     
          rest <= Param%rbound) then
        flag = .true.
        return
      endif

!---------------------------------------------------------------------
!    define estimated values of the liquid water components to be passed
!    to subroutine micro to hold first pass values.
!---------------------------------------------------------------------
      qrwest = qrw
      qcwest = qcw
      qlwest = qlw

!---------------------------------------------------------------------
!    call micro to calculate the microphysical terms which occur during
!    the parcel movement from cld_press(k) to cld_press(k+1).
!---------------------------------------------------------------------
      call don_cm_micro_k   &
           (diag_unit, debug_ijt, Param, tccbot, tcest, pbot, ptop,  &
            tebot, tetop, mrebot, mretop, wvbot, west, rbar, rmu,  &
            qrwest, qcwest, qlwest, dcw1, dqrw3, ermesg, error)  
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    if in diagnostics column, output the newly estimated values of 
!    environmental pressure (cld_press(k+1)), temperature (te) and 
!    mixing ratio (mre), and cloud temperature (tcest), cloud radius 
!    (rest) and liquid water (qlwest)
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, f19.10, f20.14, e20.12)') &
             'in cloudm: P,TEST,QEST= ',ptop     ,TEtop  ,mretop  
        write (diag_unit, '(a, f20.14, 2e20.12)')   &
                   'in cloudm: TCEST,rest,QLWT= ',TCEST,REST,qlwest
      endif

!----------------------------------------------------------------------
!    define the entrainment coefficient (rmu). it is set to 0.0 if the
!    parcel is above the lcl of ensemble member #1, and above the cur-
!    rent ensemble member's cloud base, and if the vertical velocity
!    is below the detrainment threshold; i.e., the current cloud is in
!    its detraining region. if it is not in its detraining zone, set the
!    entrainment coefficient to be the specified entrainment coefficient
!    divided by current cloud radius.
!----------------------------------------------------------------------
      if ((ptop <= pcsave) .and. (.not. lfc_not_reached) .and. &
          (west <= Param%wdet)) then
        rmu = 0.
      else
        rmu = 2.*alpp/rest
      endif 

!----------------------------------------------------------------------
!    call simult to solve for the in-cloud derivatives dT/dp (dtdp2), 
!    dw/dp (dwdp2) and dr/dp (drdp2) using the previously estimated
!    values at p + delta p, including the microphysical contributions.
!----------------------------------------------------------------------
      call don_cm_simult_k   &
           (diag_unit, debug_ijt, lfc_not_reached, Param, pcsave, rmu, &
            tcest, rest, west, ptop, qlwest, tetop, mretop, dtdp2,  &
            drdp2, dwdp2, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    if in diagnostics column, output the lfc flag (lfc_not_reached), and
!    the temperature, cloud radius and vertical velocity tendencies 
!    returned from subroutine simult.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, l4, 2e20.12)')  &
            'in cloudm: TESTLC,DTDP2,DPD2= ',lfc_not_reached,DTDP2,drdp2
        write (diag_unit, '(a, e20.12)')  'in cloudm: DWDP2= ',DWDP2
      endif

!--------------------------------------------------------------------
!    define new values of cloud radius and vertical velocity at level
!    k+1 using the values at level k and the vertical derivatives
!    returned from subroutine simult. if either of these values is below
!    its acceptable bound, set both values to 0.0 and exit the loop -- 
!    the cloud top has been reached.
!--------------------------------------------------------------------
      rcltop   = rclbot + drdp2*Param%dp_of_cloud_model
      wvtop    = wvbot  + dwdp2*Param%dp_of_cloud_model
      if ((wvtop <= Param%wbound) .or. (rcltop   <= Param%rbound)) then 
        rcltop   = 0.0
        wvtop    = 0.
        flag = .true.
        return
      endif

!--------------------------------------------------------------------
!    average the two derivatives calculated for temperature, vertical
!    velocity and cloud radius. define the cloud temperature at the
!    k+1 level as the value at k + the  effect of the calculated deriv-
!    ative.
!--------------------------------------------------------------------
      dtdp = 0.5*(dtdp + dtdp2)
      dwdp = 0.5*(dwdp2 + dwdp)
      drdp = 0.5*(drdp + drdp2)
      tcctop   = tccbot + dtdp*Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    call subroutine freeze_liquid to define the amount of liquid in 
!    the updraft is frozen in the current layer.
!--------------------------------------------------------------------
      call don_cm_freeze_liquid_k   &
           (k, diag_unit, debug_ijt, Param, tccbot, tcctop, qlwest, &
            dfrac, dtfr, dtupa, dfrtop, sumfrea, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    add the effect of droplet freezing to the cloud temperature.
!--------------------------------------------------------------------
      tcctop   = tcctop   + dfrtop  

!--------------------------------------------------------------------
!    define the values of vertical velocity and cloud radius at level 
!    k+1 using the averaged values of dw/dp and dr/dp. if either of 
!    these values is below its acceptable bound, set both values to 0.0
!    and exit the loop -- the cloud top has been reached.
!--------------------------------------------------------------------
      wvtop    = wvbot  + dwdp*Param%dp_of_cloud_model
      rcltop   = rclbot + drdp*Param%dp_of_cloud_model
      if ((wvtop <= Param%wbound) .or. (rcltop <= Param%rbound)) then 
        rcltop   = 0.0
        wvtop    = 0.
        flag = .true.
        return
      endif
 
!--------------------------------------------------------------------
!    define the pressure at which nsemble member #l becomes buoyant (its
!    level of free convection). all ensemble members must have their 
!    cloud top pressure lower than this value.
!--------------------------------------------------------------------
      if (kou == 1) then
        if ((lfc_not_reached) .and. (wvtop > wvbot))  then
          pcsave = ptop     
        endif
      endif

!--------------------------------------------------------------------
!    check to see if the level of free convection has been reached. if
!    so, set the logical variable indicating such (lfc_not_reached) to  
!    be .false..
!--------------------------------------------------------------------
      if (wvtop   > wvbot)  then
        lfc_not_reached = .false.
      endif

!--------------------------------------------------------------------
!    define the vapor mixing ratio for the new cloud temperature at
!    level k+1.
!--------------------------------------------------------------------
      call compute_mrs_k (tcctop, ptop, Param%D622, Param%D608,  &
                          rsctop, nbad)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (nbad /= 0) then
        ermesg = 'subroutine don_cm_move_parcel_k: '// &
                 'temperatures out of range of esat table'
        error = 1
        return
      endif

!--------------------------------------------------------------------
!    if in diagnostics column, output the values of environmental 
!    temperature (te) and mixing ratio (mre) and in-cloud mixing ratio 
!    (rsc) at level k+1.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, f20.14, 2e20.12)')  &
                   'in cloudm: TE,QE,RSC= ',tetop  , mretop  , rsctop  
      endif

!--------------------------------------------------------------------
!    define the layer-mean cloud radius (rbar) and entrainment coef-
!    ficient (rmub).  if the cloud radius is less than the lower bound,
!    exit the loop -- the cloud top has been reached.
!--------------------------------------------------------------------
      rbar = 0.5*(rclbot + rcltop  )
      if (rbar <= Param%rbound) then
        flag = .true.
        return   
      endif

!---------------------------------------------------------------------
!    call micro to calculate the microphysical terms which occur during
!    the parcel movement from p to p + delta p using the second itera-
!    tion values for the cloud conditions at level k + 1.
!---------------------------------------------------------------------
      call don_cm_micro_k   &
           (diag_unit, debug_ijt, Param, tccbot, tcctop, pbot, ptop, &
            tebot, tetop, mrebot, mretop, wvbot, wvtop, rbar, rmu,  &
            qrw, qcw, qlw, dcw1, dqrw3, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    save the final values of cloud water, rainwater and total liquid
!    that are found at level k+1 in arrays disc, disd and qlwa.
!---------------------------------------------------------------------
      qlwatop = qlw

!--------------------------------------------------------------------
!    if in diagnostics column, output the values of in-cloud temperature
!    (tcc), vertical velocity (wv), liquid water (qlw), condensation
!    (dcw1) and precipitation (dqrw3) at level k+1.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, f20.14, 2e20.12)') &
                     'in cloudm: TCC(k+1),WV(k+1),QLW= ',tcctop  ,  &
                      wvtop  , qlw
        write (diag_unit, '(a, 2e20.12)')  &
                        'in cloudm: DCW1,DQRW3= ',dcw1, dqrw3
      endif

!---------------------------------------------------------------------


end subroutine don_cm_move_parcel_k




!######################################################################

subroutine don_cm_lcl_k    &
         (Param, t_init, p_init, mr_init, t_lcl, p_lcl, mr_lcl,  &
          lcl_reached, ermesg, error)

!---------------------------------------------------------------------
!    subroutine don_cm_lcl_k computes the lifting conden-
!    sation level by raising a parcel with temperature t_init and vapor 
!    mixing ratio mr_init adiabatically from pressure p_init until satur-
!    ation is reached at pressure p_lcl, temperature t_lcl and vapor 
!    mixing ratio mr_lcl. a flag lcl_reached is set to .true. to indicate
!    that the lcl was successfully reached.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!-----------------------------------------------------------------------
type(donner_param_type), intent(in)   :: Param
real,                    intent(in)   :: t_init, p_init, mr_init
real,                    intent(out)  :: t_lcl, p_lcl, mr_lcl
logical,                 intent(out)  :: lcl_reached
character(len=*),        intent(out)  :: ermesg
integer,                 intent(out)  :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      t_init         temperature of parcel at its launch point
!                     [ deg K ]
!      p_init         pressure of the parcel at its launch point [ Pa ]
!      mr_init        mixing ratio of the parcel at its launch point
!                     [ kg(h2o) / kg(air) ]
!
!   intent(out) variables:
!
!      t_lcl          temperature at lifting condensation level 
!                     [ deg K ]
!      p_lcl          pressure at lifting condensation level [ Pa ]
!      mr_lcl         mixing ratio of parcel at lifting condensation
!                     level [ kg(h2o) / kg(air) ]
!      lcl_reached    lcl was reached for this parcel ?
!
!----------------------------------------------------------------------


!---------------------------------------------------------------------
!   local variables:

      real    ::  t_parcel, p_start, p_end, gamma, rs, kappa_moist
      integer ::  max_levels
      integer ::  k, nbad

!---------------------------------------------------------------------
!   local variables:
!
!      t_parcel     temperature of parcel at current level
!      p_start      pressure at start of current iteration [ Pa ]
!      p_end        pressure at end of current iteration [ Pa ]
!      gamma        adiabatic lapse rate for moist air at current 
!                   location [ deg K / Pa ] 
!      es           saturation vapor pressure at temperature t_parcel 
!                   [ Pa ]
!      rs           saturation mixing ratio at t_parcel and p_end 
!                   [ kg(h2o) / kg(air) ]
!      kappa_moist  exponent in expression for moist potential 
!                   temperature [ dimensionless ]
!      max_levels   maximum number of iterations of parcel movement
!                   which must be taken before knowing that the
!                   parcel will not undergo deep convection
!      k            do-loop index
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' '  ; error = 0

!---------------------------------------------------------------------
!    define an approximation for kappa (R/Cp) for moist air 
!    (kappa_moist). 
!---------------------------------------------------------------------
      kappa_moist = (Param%RDGAS/Param%CP_AIR)*(1. +    &
                    (Param%RVGAS/Param%RDGAS -     &
                     Param%CP_VAPOR/Param%CP_AIR)*mr_init)
      
!---------------------------------------------------------------------
!    define the initial values for t_parcel (the parcel temperature) 
!    and p_start and p_end, which define the pressure increment through
!    which the parcel rises during the first iteration.
!---------------------------------------------------------------------
      t_parcel = t_init
      p_start  = p_init
      p_end    = p_start + Param%parcel_dp

!---------------------------------------------------------------------
!    initialize the output variables.
!---------------------------------------------------------------------
      p_lcl  = 0.
      t_lcl  = 0.
      mr_lcl = 0.
      lcl_reached = .false.

!---------------------------------------------------------------------
!    define the maximum number of increments (max_levels) that the 
!    parcel may be raised without reaching condensation before it is 
!    no longer viable as a deep convection parcel.
!---------------------------------------------------------------------
      max_levels = int( (p_init - Param%upper_limit_for_lfc)/  &
                        abs(Param%parcel_dp) ) + 1

!----------------------------------------------------------------------
!    raise the parcel in increments of parcel_dp, following the adia-
!    batic lapse rate for moist air, until either the lcl is reached
!    or the parcel is no longer capable of undergoing deep convection. 
!----------------------------------------------------------------------
      do k=1,max_levels

!---------------------------------------------------------------------
!    exit the loop if the parcel has risen beyond where deep convection
!    is possible.
!---------------------------------------------------------------------
        if (p_end < Param%upper_limit_for_lfc) exit

!---------------------------------------------------------------------
!    define the lapse rate of temp with respect to pressure for moist
!    air (gamma). update the parcel temperature to the value at the
!    top of this layer.
!---------------------------------------------------------------------
        gamma = kappa_moist*t_parcel/p_start
        t_parcel = t_parcel + gamma*Param%parcel_dp 

!---------------------------------------------------------------------
!    determine the saturation mixing ratio for this temperature and
!    pressure. 
!---------------------------------------------------------------------
        call compute_mrs_k (t_parcel, p_end,                  &
                            Param%d622 , Param%d608 , rs, nbad, &
                            mr = mr_init)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_cm_lcl_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

!---------------------------------------------------------------------
!   determine if the parcel is saturated. if it is, define the lcl 
!   values of temperature (t_lcl), mixing ratio (mr_lcl) and pressure 
!   (p_lcl), and return to the calling routine.
!---------------------------------------------------------------------
        if (rs <= mr_init) then
          p_lcl = p_end
          t_lcl = t_parcel
          mr_lcl = mr_init                     
          lcl_reached = .true.
          exit
        endif

!---------------------------------------------------------------------
!    define the starting and ending pressures for the next iteration.
!---------------------------------------------------------------------
        p_start = p_end
        p_end   = p_end + Param%parcel_dp
      end do

!---------------------------------------------------------------------


 end subroutine don_cm_lcl_k  


!#####################################################################


subroutine don_cm_mesub_k     &
         (Nml, pfull_c, nlev_lsm, me, diag_unit, debug_ijt, Param, cu,           &
          ci_liq_cond, ci_ice_cond, pmelt_lsm, cell_precip, &
          dint, plzb_c, pb, pt_kou, temp_c, phalf_c,   &
          ca_liq, ca_ice, ecd, ecd_liq, ecd_ice, ecei_liq,   &
          ece, ece_liq, ece_ice, meso_freeze, meso_melt, ermesg, error)

!----------------------------------------------------------------------
!    subroutine mesub calculates mesoscale heat and moisture sources,
!    using a variation on the Leary and Houze (JAS, 1980) procedure.
!    the defined fields are condensate transferred from cell to anvil
!    (ca), condensate evaporated in convective downdrafts (ecd), conden-
!    sate evaporated in convective updrafts (ece), the condensate 
!    entering the anvil which has not yet been frozen (meso_freeze), and 
!    the amount of condensate which must be melted in the mesoscale down-
!    draft to assure ice conservation (meso_melt). the subroutine is 
!    called separately for each ensemble member. for notation, see 
!    "Cu Closure A notes," 2/97.
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type

implicit none

!----------------------------------------------------------------------
type(donner_nml_type),         intent(in)    :: Nml
integer,                       intent(in)    :: nlev_lsm, me, diag_unit
logical,                       intent(in)    :: debug_ijt
type(donner_param_type),       intent(in)    :: Param
real,                          intent(in)    :: cu, cell_precip, dint, &
                                                plzb_c, pb, pt_kou
real,   dimension(nlev_lsm),   intent(in)    :: temp_c, pfull_c
real,   dimension(nlev_lsm+1), intent(in)    :: phalf_c
real,                          intent(out)   :: ca_liq, ca_ice
real,                          intent(in)    :: pmelt_lsm, &
                                                ci_liq_cond, ci_ice_cond
real,   dimension(nlev_lsm),   intent(out)   :: ecd, ece, meso_freeze, &
                                                meso_melt, &
                                                ecd_liq, ecd_ice, &
                                                ece_liq, ece_ice
real,                          intent(out)   :: ecei_liq
character(len=*),              intent(out)   :: ermesg
integer,                       intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       cu           column integrated condensation integral
!                    [ mm / day ]
!       cell_precip  column integrated precipitation integral
!                    [ mm / day ]
!       dint???      water mass frozen in convective updraft
!            ??????  plus ice deposited convective updraft
!                    [ kg(h2o) /( (m**2) sec) ]
!                    weighted as cu,cell_precip
!       plzb_c       pressure at level of zero buoyancy [ Pa ]
!       ps           surface pressure [ Pa ]
!       pb           cloud-base pressure [ Pa ]
!       pt_kou       cloud-top pressure [ Pa ]
!       pmelt_lsm    pressure at bottom of layer in which melting 
!                    begins   [ Pa ]
!       phalf_c      large-scale model pressure half-levels (Pa)
!       debug_ijt    is this a diagnostics column ?
!       diag_unit    output unit number for this diagnostics column
!
!   intent(out) variables:
!
!       ca           total condensate transfered from cells to anvil 
!                    by this ensemble member [ mm/day ]
!       ecd          profile of condensate evaporated in convective
!                    downdraft on large-scale model grid 
!                    [ g(h2o) / kg(air) / day ] 
!       ece          profile of condensate evaporated in convective 
!                    updraft on large-scale model grid 
!                    [ g(h2o) / kg(air) / day ] 
!       meso_freeze  profile of condensate which is frozen upon enter-
!                    ing the anvil on the large-scale grid
!                    [ g(h2o) / kg(air) / day ] 
!       meso_melt    profile of condensate which is melted in mesoscale
!                    downdraft on large-scale model grid
!                    [ g(h2o) / kg(air) / day ] 
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
 
      integer ::     k
      real    ::  avail_meso_cd     ! fraction of column integrated
                                    ! condensation available to meso-
                                    ! scale circulation (1. - gnu)
                                    ! [ dimensionless ]
      real    ::  caa               ! amount of condensate which must
                                    ! be frozen when it enters the anvil
                                    ! [ g(h2o) / kg(air) / day ]
      real    ::  dint2             ! amount of condensate which has
                                    ! been frozen in the cumulus updraft
                                    ! before entering the anvil
                                    ! [ g(h2o) / kg(air) / day ]
      real    ::  ecda              ! amount of condensate evaporated 
                                    ! in cumulus downdrafts
                                    ! [ g(h2o) / kg(air) / day ]
      real :: ecda_liq, ecda_ice
      real    ::  ecdi              ! amount of condensate evaporated 
                                    ! in cumulus downdrafts [ mm / day ]
      real :: ecdi_liq, ecdi_ice
      real    ::  ecea              ! amount of condensate evaporated 
                                    ! in cumulus updrafts 
                                    ! [ g(h2o) / kg(air) / day ]
      real :: ecea_liq, ecea_ice
      real    ::  ecei              ! amount of condensate evaporated 
                                    ! in cumulus updrafts [ mm / day ]
      real ::           ecei_ice
      real    ::  elta              ! amount of condensate which must
                                    ! be melted in the mesoscale down-
                                    ! draft to conserve ice mass
                                    ! [ g(h2o) / kg(air) / day ]
      real    ::  gnu               ! fraction of column integrated 
                                    ! condensation which precipitates
                                    ! out [ dimensionless ]
      real    ::  ptt               ! pressure one cloud model delta p 
                                    ! above cloud top [ Pa ]
      real    ::  pzm               ! pressure at base of mesoscale 
                                    ! circulation [ Pa ]
      real    ::  pztm              ! pressure at top of mesoscale cir-
                                    ! culation [ Pa ]
      real    ::  p1                ! lower pressure limit for the layer
                                    ! in which one of the physical
                                    ! processes is occurring [ Pa ]
      real    ::  p2                ! upper pressure limit for the layer
                                    ! in which one of the physical
                                    ! processes is occurring [ Pa ]
      integer :: itrop
      real    :: ptrop

!---------------------------------------------------------------------
!   local variables:
!
!      
      ermesg = '  ' ; error = 0

!---------------------------------------------------------------------
!    define pressure one cloud-model level above cloud top (ptt). 
!    define the pressure at top of mesoscale updraft (pztm, 300 hPa 
!    plus one model-layer pressure thickness above cloud top).
!---------------------------------------------------------------------
      ptt = pt_kou + Param%dp_of_cloud_model
      pztm = ptt - 300.E02

!---------------------------------------------------------------------
!    restrict pztm to >= 100 hPa, cf Ackerman et al (JAS,1988), unless 
!    pt_kou <= 100 hPa. it was found in AM2p9 that the stratospheric 
!    water vapor was excessive with this pztm restriction, so pztm is now
!    set to be no higher than the level of zero buoyancy, or if the
!    cloud top is above the level of zero buoyancy, it is set to one 
!    model layer above the level of zero buoyancy. 
!---------------------------------------------------------------------
      if (pztm < plzb_c) pztm = plzb_c
      if (ptt < plzb_c)  pztm = plzb_c + Param%dp_of_cloud_model

      if (Nml%limit_pztm_to_tropo) then
        call find_tropopause (nlev_lsm, temp_c, pfull_c, ptrop, itrop)
        pztm = MAX (pztm, ptrop)
      endif

!---------------------------------------------------------------------
!    define the base of the mesoscale updraft (pzm), as the layer imm-
!    ediately above cloud top, or, if the top of the mesoscale updraft
!    has been redefined to be at or just above the level of zero 
!    buoyancy, to be one layer below the mesoscale updraft top. 
!---------------------------------------------------------------------
      pzm = ptt
      if (pzm <= pztm) pzm = pztm - Param%dp_of_cloud_model

!---------------------------------------------------------------------
!    if in a diagnostics column, output the convective rain 
!    (cell_precip), convective updraft condensation (cu), and the pres-
!    sure at the level of zero buoyancy (plzb_c).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)') 'in mesub: rc,cu= ',  &
                                                    cell_precip, cu
        write (diag_unit, '(a,  e20.12)') 'in mesub: plzb = ',plzb_c
      endif

!----------------------------------------------------------------------
!    define the ratio of precipitation to condensation for the current
!    ensemble member (gnu). define the remaining fraction of condens-
!    ation 1 - gnu as the condensate available to the mesoscale circ-
!    ulation (avail_meso_cd). define the mass of this available conden-
!    sate which is evaporated in convective downdrafts (ecdi), the mass
!    evaporated into the cell environment (ecei) and the portion incor-
!    porated into the mesoscale region (ca). this partitioning is 
!    defined by the parameters evap_in_downdraft, evap_in_environ and 
!    entrained_into_meso, taken from the work of Leary and Houze 
!    (JAS, 1980).
!----------------------------------------------------------------------
      gnu = cell_precip/cu
      avail_meso_cd = 1. - gnu
      ecdi  = (Param%evap_in_downdrafts*avail_meso_cd)*cu
      ecdi_liq  = (Param%evap_in_downdrafts*avail_meso_cd)* &
                         (Param%seconds_per_day*ci_liq_cond)
      ecdi_ice  = (Param%evap_in_downdrafts*avail_meso_cd)*     &
                         (Param%seconds_per_day*ci_ice_cond)
      ecei  = (Param%evap_in_environ*avail_meso_cd)*cu
      ecei_liq  = (Param%evap_in_environ*avail_meso_cd)*    &
                         (Param%seconds_per_day*ci_liq_cond)
      ecei_ice  = (Param%evap_in_environ*avail_meso_cd)*     &
                         (Param%seconds_per_day*ci_ice_cond)
      ca_liq    = (Param%entrained_into_meso*avail_meso_cd)*   &
                         (Param%seconds_per_day*ci_liq_cond)
      ca_ice    = (Param%entrained_into_meso*avail_meso_cd)*   &
                         (Param%seconds_per_day*ci_ice_cond)
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
               'in mesub: cu, h1_liqintg, h1_iceintg= ',  &
            cu, ci_liq_cond*Param%seconds_per_day      ,  &
                 ci_ice_cond*Param%seconds_per_day      
      endif

!---------------------------------------------------------------------
!    if in a diagnostics column, output the ratio of convective rain 
!    to convective updraft condensation (gnu) and the mass entrained
!    into the mesoscale region (ca).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)')  'in mesub: gnu= ',gnu
        write (diag_unit, '(a, e20.12)') 'in mesub: ca= ',  &
                                                       ca_liq + ca_ice
        write (diag_unit, '(a, 2e20.12)') 'in mesub: ca_liq,ca_ice= ', &
                                                ca_liq, ca_ice
      endif

!--------------------------------------------------------------------
!    calculate the mass of water which must be frozen as it enters the
!    mesoscale anvil (caa). if no freezing has occurred in the cumulus
!    updraft (i.e., dint2 = 0) then this will be ca, the total mass 
!    available to the anvil. if freezing has occurred, (ie, 
!    dint2 /= 0.), then the amount to be frozen is the total amount 
!    available (ca) plus additional vapor mass deposited on the ice in 
!    the updraft (ecei), less that which has already frozen (dints). 
!    dints and caa are expressed in units of g(h2o) per kg(air) per day.
!--------------------------------------------------------------------
!9/15/07, 1037AM:
      dint2 = avail_meso_cd*(dint                               )*  &
               8.64e07*Param%grav/(pzm - pztm)

      if (dint2 /= 0.)  then 
       caa = ((ca_liq + ecei_liq)*Param%grav*1000./(pzm - pztm)) - dint2
      else
        caa = ca_liq*Param%grav*1000./(pzm - pztm)
      endif

!---------------------------------------------------------------------
!    if in a diagnostics column, output the previously frozen condensate
!    (dint2), the additional amount to be frozen (caa) and the pressure
!    range over which the freezing will occur (pzm, pztm). if 
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a,  e20.12)')  &
                         'in mesub:     dint           =',    dint 
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub:     dint2, ecei_liq=',    dint2, &
                                                          ecei_liq
        write (diag_unit, '(a, 3e20.12)')  &
                           'in mesub: caa,pzm,pztm= ',caa,pzm,pztm
      endif

!---------------------------------------------------------------------
!    if there is additional condensate which must be frozen upon enter-
!    ing the anvil, call map_hi_res_intgl_to_lo_res_col to spread this 
!    additional freezing uniformly over the region between anvil base 
!    (pzm) and anvil top (pztm) in the large-scale model. store the out-
!    put in array meso_freeze. if no additional freezing is needed, set 
!    meso_freeze to be 0.0.
!---------------------------------------------------------------------
      if (caa > 0.)  then 
        if (debug_ijt) then
          write (diag_unit, '(a, e20.12, 2f19.10)')  &
                      'in cm_intgl_to_gcm_col: xav,p1,p2= ',caa, pzm, &
                                                  pztm
        endif
        call don_u_map_hires_i_to_lores_c_k   &
             (nlev_lsm, caa, pzm, pztm, phalf_c, meso_freeze, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
        if (debug_ijt) then
          do k=1,nlev_lsm       
            if (meso_freeze(k) /= 0.0) then
              write (diag_unit, '(a, i4, e20.12)') &
                    'in cm_intgl_to_gcm_col: k,x= ',k, meso_freeze   (k)
            endif
          end do
        endif
      else
        meso_freeze = 0.
      endif

!---------------------------------------------------------------------
!    define the evaporation which occurs in the convective downdraft.
!    the convective downdraft is assumed to originate one layer above
!    the cloud top (ptt) and extend to the surface (phalf_c(1)). 
!    convert the convective downdraft evaporation to units of
!    g(h20) / kg(air) per day.
!---------------------------------------------------------------------
      ecda = ecdi*Param%grav*1000./(phalf_c(1) - ptt)
      ecda_liq = ecdi_liq*Param%grav*1000./(phalf_c(1) - ptt)
      ecda_ice = ecdi_ice*Param%grav*1000./(phalf_c(1) - ptt)

!---------------------------------------------------------------------
!    if in a diagnostics column, output the convective downdraft evap-
!    oration (ecda) and the large-scale model pressure limits over which
!    this evaporation occurs (phalf_c(1), ptt).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                         'in mesub: ecda,p1,pz0= ',ecda,phalf_c(1),ptt
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub: ecda_liq, ecda_ice= ',  &
                                ecda_liq, ecda_ice
      endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to spread the integrated evap-
!    oration in convective downdrafts uniformly over the region between
!    the surface (phalf_c(1)) and the anvil base (pzm) and the top of 
!    cloud (ptt). output field is ecd.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
             'in cm_intgl_to_gcm_col: xav,p1,p2= ',ecda, phalf_c(1) , &
                                                  ptt 
      endif
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecda, phalf_c(1), ptt, phalf_c, ecd, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
         (nlev_lsm, ecda_liq, phalf_c(1), ptt, phalf_c, ecd_liq, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
         (nlev_lsm, ecda_ice, phalf_c(1), ptt, phalf_c, ecd_ice, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      if (debug_ijt) then
        do k=1,nlev_lsm       
          if (ecd(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                'in cm_intgl_to_gcm_col: k,ecd= ',k, ecd   (k)
            write (diag_unit, '(a, i4, 2e20.12)') &
              'in cm_intgl_to_gcm_col: k,ecdliq,ecdice= ',k, &
                       ecd_liq(k), ecd_ice(k)
          endif
        end do
      endif

!---------------------------------------------------------------------
!    be sure that the melting level in the large-scale model (pmelt_lsm)
!    is below the top of the mesoscale circulation (pztm),and above
!    cloud base (pb). if not, no melting will occur; set p2 to be 0.0.
!---------------------------------------------------------------------
      elta = 0.
      if (pmelt_lsm  < pztm                    )  then
        meso_melt = 0.
      if (debug_ijt) then
        write (diag_unit, '(a, 2f19.10)') &
                 ' NO MELTING DONE: melting level above top of &
                    &mesoscale circulation : pmelt_lsm,pztm',     &
                                                pmelt_lsm, pztm      
      endif

!---------------------------------------------------------------------
!    if pmelt_lsm is within the region of the cloud and mesoscale circ-
!    ulation, calculate any melting that must occur in the mesoscale
!    downdraft in order to conserve ice mass; ie, if the amount to be
!    frozen was calculated as more than the available condensate, then
!    the excess must be melted, and is done so in the mesoscale down-
!    draft between the melting level and cloud base.
!---------------------------------------------------------------------
      else if (pmelt_lsm >= pztm .and. pmelt_lsm <= pb) then
        p2 = pmelt_lsm
        p1 = pb
        if (caa <= 0.) then 
          caa = -caa*(pzm - pztm)/(pb - p2)
          elta = caa
        endif
      if (debug_ijt) then
        write (diag_unit, '(a, 3f19.10)') &
                   'MELTING DONE: pmelt_lsm,pb,caa  ',pmelt_lsm, pb, &
                                                            caa  
      endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the melting (elta) and the 
!    pressures defining the layer in which it occurs (pb, p2)
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, 2f19.10)') &
                           'in mesub: elta,p1,p2= ',elta,p1,p2
      endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to spread the required melting
!    resulting from excessive freezing over the layer between cloud base
!    and the melting level. output field is meso_melt.
!---------------------------------------------------------------------
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, elta, p1, p2, phalf_c, meso_melt, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      if (debug_ijt) then
        do k=1,nlev_lsm       
          if (meso_melt(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                 'in cm_intgl_to_gcm_col: k,meso_melt= ',k, meso_melt(k)
          endif
        end do
      endif

      else if (pmelt_lsm > pb) then
        meso_melt = 0.
        if (pmelt_lsm == phalf_c(1)) then
          if (debug_ijt) then
             write (diag_unit, '(a)') &
                   'NO MELTING LEVEL PRESENT IN COLUMN'
          endif
        else
! melt below cloud base 
      if (debug_ijt) then
        write (diag_unit, '(a, 2f19.10)') &
            ' NO MELTING DONE: melting level below PB: pmelt_lsm,pb', &
                                                      pmelt_lsm, pb
      endif
      endif
      endif ! (pmelt<pztm or pmelt > pb)

!---------------------------------------------------------------------
!    calculate the evaporation which occurs in the convective 
!    updraft.
!    this is spread between 50 hPa below cloud top and 10 hPa above 
!    cloud top.
!---------------------------------------------------------------------
      p1 = pt_kou + 50.0e02
      p2 = ptt
      ecea = ecei*Param%grav*1000./(p1-p2)
      ecea_liq = ecei_liq*Param%grav*1000./(p1-p2)
      ecea_ice = ecei_ice*Param%grav*1000./(p1-p2)

!---------------------------------------------------------------------
!    if in diagnostics column, output the convective updraft evaporation
!    (ecea, ecei) and the large-scale model pressure layer limits over 
!    which it occurs (p1, p2).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub: ecea,ecei= ',ecea, ecei
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub: LIQecea,ecei= ',ecea_liq, ecei_liq
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub: ICEecea,ecei= ',ecea_ice, ecei_ice
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
                         'in mesub: ecea,p1,p2= ',ecea, p1, p2
      endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to spread the integrated evap-
!    oration in convective updrafts uniformly over the designated 
!    region.  output field is ece.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
                      'in cm_intgl_to_gcm_col: xav,p1,p2= ',ecea, p1, &
                                                  p2
      endif
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecea, p1, p2, phalf_c, ece, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecea_liq, p1, p2, phalf_c, ece_liq, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecea_ice, p1, p2, phalf_c, ece_ice, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      if (debug_ijt) then
        do k=1,nlev_lsm     
          if (ece(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                           'in cm_intgl_to_gcm_col: k,x= ',k, ece   (k)
          endif
        end do
      endif

!---------------------------------------------------------------------


end subroutine don_cm_mesub_k



!######################################################################

subroutine don_cm_compute_vert_fluxes_k   &
         (nlev_hires, ntr, ncc_kou, kou, diag_unit, debug_ijt, &
          do_donner_tracer, Param, pt_kou, cld_press, rcl, te, mre, wv, &
          tcc, dpf, xclo, xtrae, apt, efchr, emfhr, etfhr, ermesg, error)

!---------------------------------------------------------------------
!    subroutine compute_vertical_fluxes computes vertical flux conver-
!    gence terms and their column integrals for temperature, entropy, 
!    moisture and tracers within the cloud. 
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_qs_k

implicit none 

!---------------------------------------------------------------------
integer,                            intent(in)     :: nlev_hires, ntr,  &
                                                      ncc_kou, kou,  &
                                                      diag_unit
logical,                            intent(in)     :: debug_ijt,   &
                                                      do_donner_tracer
type(donner_param_type),            intent(in)     :: Param
real,                               intent(in)     :: pt_kou
real,    dimension(nlev_hires),     intent(in)     :: cld_press, rcl,  &
                                                      te, mre, wv, tcc, &
                                                      dpf
real,    dimension(nlev_hires,ntr), intent(in)     :: xclo, xtrae      
real,                               intent(out)    :: apt               
real,    dimension(nlev_hires),     intent(out)    :: efchr, emfhr    
real,    dimension(nlev_hires,ntr), intent(out)    :: etfhr            
character(len=*),                   intent(out)    :: ermesg
integer,                            intent(out)    :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      pt_kou      pressure at cloud top [ Pa ]
!      cld_press   pressure at full levels in cloud model [ Pa ]
!      rcl         vertical profile of cloud radius [ m ]
!      te          environmental temperature profile [ deg K ]
!      mre         environmental vapor mixing ratio profile 
!                  [ kg(h2o) / kg (dry air) ]
!      wv          in-cloud vertical velocity profile [ m / sec ]
!      tcc         in-cloud temperature profile [ deg K ] 
!      xclo        in-cloud tracer profiles 
!                  [ kg(tracer) / kg (dry air) ]
!      xtrae       environmental tracer profiles 
!                  [ kg(tracer) / kg (dry air) ]
!      debug_ijt   logical indicating whether diagnostics are desired
!                  for column
!      ncc_kou     cloud model level index of level at or above 
!                  cloud top
!      kou         index of current ensemble member 
!      diag_unit   output unit for diagnostics for this column
!
!   intent(out) variables:
!
!      apt         ratio of cloud area at cloud top to that at cloud 
!                  base [ dimensionless ]
!      efchr       vertical entropy flux convergence [ deg K / sec ]
!      emfhr       vertical moisture flux convergence 
!                  [ kg(h2o) / ( kg(dry air) sec ] 
!      etfhr       vertical tracer flux convergence 
!                  [ kg(tracer) / ( kg(dry air) sec ] 
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_hires)       ::  dpdz, q_sat, ehf, emf
      real, dimension(nlev_hires,ntr) ::  etf                      
      real, dimension(ntr)      ::  sumetf
      real                        ::  p, pl, ph, dpp, ptt, exf, &
                                      thetf, tv_env, tv_cld,  &
                                      dpdz_cb, sumemf, sumefc, sumthet
      integer                     ::  kcl, kch
      integer                     ::  kc, kcont, nbad


!---------------------------------------------------------------------
!   local variables:
!
!        dpdz            value of dp/dz, evaluated from hydrostatic
!                        equation, with virtual mass coefficient to
!                        account for non-hydrostatic effects. see
!                        Donner, 1986, j. atmos. sci., 43, p 2288.
!                        [ kg(air) / (sec**2 m**2) ]
!        q_sat           saturation specific humidity 
!                        [ kg(h2o) / kg (air) ]
!        ehf             vertical temperature flux 
!                        [ ( kg(air) deg K ) / (m sec**3) ]
!        emf             vertical moisture flux
!                        [ kg (h2o) / (m sec**3) ]
!        etf             vertical tracer flux
!                        [  kg(tracer) / (m sec**3) ]
!        sumetf          column integral of vertical tracer flux 
!                        convergence [  kg(tracer) / (m sec**3) ]
!        p               pressure  at level where subgrid scale temper-
!                        ature flux is calculated [ Pa ]
!        pl              pressure at lower flux interface [ Pa ]
!        ph              pressure at upper flux interface [ Pa ]
!        dpp             pressure depth over which flux is being 
!                        calculated [ Pa ]
!        ptt             pressure one level above cloud top [ Pa ]
!        exf             perturbation vertical subgrid scale temp-
!                        erature flux [ ( kg(air) deg K ) / (m sec**3) ]
!        thetf           vertical flux of potential temperature at
!                        cloud base [ ( kg(air) deg K ) / (m sec**3) ]
!        esat            saturation vapor pressure [ Pa ]
!        tv_env          environmental virtual temperature [ deg K ]
!        tv_clda         in-cloud virtual temperature [ deg K ]
!        dpdz_cb         value of dp/dz over the lowest cloud model
!                        pressure layer [ kg(air) / (sec**2 m**2) ]
!        sumemf          column integral of vertical moisture flux 
!                        convergence [ kg (h2o) / (m sec**3) ]
!        sumefc          column integral of vertical entropy flux 
!                        convergence [ ( kg(air) deg K ) / (m sec**3) ]
!        sumthet         column integral of vertical potential temper-
!                        ature flux convergence 
!                        [ ( kg(air) deg K ) / (m sec**3) ]
!        kcl             k index of lower interface level
!        kch             k index of upper interface level
!        kc, kcont       do-loop indices
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    initialize the output arrays.
!--------------------------------------------------------------------
      do kc=1,nlev_hires
        do kcont=1,ntr
          etfhr(kc,kcont) = 0.
        end do
        efchr(kc) = 0.
        emfhr(kc) = 0.
      end do

!---------------------------------------------------------------------
!    initialize variables which will collect column sums.
!---------------------------------------------------------------------
      sumemf    = 0.
      sumefc    = 0.
      sumthet   = 0.
      sumetf(1:ntr) = 0.

!--------------------------------------------------------------------
!    initialize the ratio of cloud area at cloud top to cloud area at 
!    cloud base. 
!--------------------------------------------------------------------
      apt = 0.

!---------------------------------------------------------------------
!    loop over the cloud model levels from cloud base (kc=1) to the 
!    level just below cloud top (ncc_kou-1), defining variables needed 
!    for the flux convergence calculations.
!---------------------------------------------------------------------
      do kc=1,ncc_kou-1 

!---------------------------------------------------------------------
!    define the environmental and in-cloud virtual temperatures. NOTE: 
!    q_sat is correctly a specific humidity; mre(kc) is incorrectly a 
!    mixing ratio.
!---------------------------------------------------------------------
        call compute_qs_k (tcc(kc), cld_press(kc), Param%D622,  &
                           Param%D608, q_sat(kc), nbad)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_cm_compute_vert_fluxes_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif
        tv_env     = te(kc)* (1. + Param%d608*(mre(kc)/(1. + mre(kc))))
        tv_cld     = tcc(kc)*(1. + Param%d608*q_sat(kc))

!---------------------------------------------------------------------
!    compute dp/dz (dpdz) as in equation (B3) in Donner (1986), 
!    j. atm. sci., 43, pp 2277-2288.  here the expression uses the 
!    pressure mid-way between cloud base and level 2. compute vertical 
!    eddy transport of temperature (ehf), moisture (emf) and tracers
!    (etf), using equation (3) from Donner et al (1982), j. atm. sci.,
!    39, pp 2159-2181. multiply by dpdz to put flux in pressure (omega) 
!    units. note (1 - a) is approximated as 1. note that q_sat is a 
!    specific humidity while mre is a mixing ratio.
!---------------------------------------------------------------------
        if (kc == 1) then

!--------------------------------------------------------------------
!    at cloud base level, calculate dpdz valid over the interval between
!    level 1 and level 2 (dpdz_cb). this term is needed to determine 
!    the subgrid scale vertical temperature flux valid in the first 
!    cloud layer.
!--------------------------------------------------------------------
          dpdz_cb = -Param%grav*(0.5*(cld_press(1) + cld_press(2)))* &
                    (Param%virt_mass_co*tv_env + tv_cld)/(Param%rdgas*  &
                    (1. + Param%virt_mass_co)*tv_env*tv_cld)

!----------------------------------------------------------------------
!    when at cloud top, calculate dpdz and the cloud perturbation flux 
!    terms that are valid for the model layer including cloud top. save
!    these values as index ncc_kou of the various arrays.
!--------------------------------------------------------------------
        else if (kc == ncc_kou-1) then
          dpdz(ncc_kou) = -Param%grav*pt_kou*(    &
                          Param%virt_mass_co*tv_env + tv_cld)/   &
                          (Param%rdgas*(1. + Param%virt_mass_co)*  &
                          tv_env*tv_cld)
          ehf(ncc_kou) = ((rcl(ncc_kou-1)/Param%cloud_base_radius)**2)* &
                         wv(ncc_kou-1)*dpdz(ncc_kou)*   &
                         (tcc(ncc_kou-1) - te(ncc_kou-1))
          emf(ncc_kou) = ((rcl(ncc_kou-1)/Param%cloud_base_radius)**2)* &
                         wv(ncc_kou-1)*dpdz(ncc_kou)*    &
                         (q_sat(ncc_kou-1)/(1. - q_sat(ncc_kou-1)) - &
                                                         mre(ncc_kou-1))
          do kcont=1,ntr
            etf(ncc_kou,kcont) = ((rcl(ncc_kou-1)/  &
                                 Param%cloud_base_radius)**2)* &
                                 wv(ncc_kou-1)*dpdz(ncc_kou)*  &
                                 (xclo(ncc_kou-1,kcont) -   &
                                                  xtrae(ncc_kou-1,kcont))
          end do
        endif

!---------------------------------------------------------------------
!    compute dpdz and the vertical eddy flux terms at interior cloud
!    levels.
!---------------------------------------------------------------------
        dpdz(kc) = -Param%grav*cld_press(kc)*  &
                   (Param%virt_mass_co*tv_env + tv_cld)/&
                   (Param%rdgas*(1. + Param%virt_mass_co)*tv_env*tv_cld)
        ehf(kc) = ((rcl(kc)/Param%cloud_base_radius)**2)*wv(kc)*  &
                  dpdz(kc)*(tcc(kc) - te(kc))
        emf(kc) = ((rcl(kc)/Param%cloud_base_radius)**2)*wv(kc)*   &
                  dpdz(kc)*(q_sat(kc)/(1. - q_sat(kc)) - mre(kc))
        do kcont=1,ntr
          etf(kc,kcont) = ((rcl(kc)/Param%cloud_base_radius)**2)*  &
                            wv(kc)*dpdz(kc)*  &
                            (xclo(kc,kcont) - xtrae(kc,kcont))
        end do
      end do

!--------------------------------------------------------------------
!    loop over levels from cloud base to the highest level within
!    the cloud to compute the eddy flux convergence profiles.
!--------------------------------------------------------------------
      do kc=1,ncc_kou-1  

!--------------------------------------------------------------------
!    define the lower interface index (kcl) to be one less than 
!    the current level. at cloud base, define the lower interface index
!    to be the current index. define the lower interface pressure (pl).
!    if the lower interface is at or above cloud top, calculation is
!    complete in this column, so return. define the upper interface 
!    pressure (ph) to be the pressure one level above the current index.
!    define the delta p between the interface pressures (dpp).
!--------------------------------------------------------------------
        kcl = MAX (1, kc-1)
        pl = cld_press(kcl)
        if (pl <= pt_kou) return
        ph = cld_press(kc+1)
        dpp = (ph - pl)/2.0

!---------------------------------------------------------------------
!     if the upper interface pressure is not above cloud top, set the 
!     upper interface index (kch) to be one above the current index. set
!     the current level pressure p to be the average value of the higher
!     and lower level pressures, which will be the current level value,
!     except at the lowest level. 
!---------------------------------------------------------------------
        if (ph >= pt_kou) then
          kch = kc + 1
          p = (pl + ph)/2.0

!---------------------------------------------------------------------
!     if the upper interface pressure is above cloud top, set the 
!     upper interface index (kch) to be the current value (kc), and set
!     the upper interface and current level pressures to be the cloud 
!     top pressure.  define the ratio of cloud-top cloud area to cloud-
!     base cloud area (apt).
!---------------------------------------------------------------------
        else
          kch = kc
          ph = pt_kou
          p = pt_kou
          apt = (rcl(kc)/rcl(1))**2
        endif

!!$$^%S^&A^^^**
!!    SHOULDN'T dpp be defined here, after any adjustnment to ph has 
!     BEEN MADE ???? Problem would be at topmost layer.
!!$$^%S^&A^^^**

!---------------------------------------------------------------------
!    if in a debug column, output values of cloud-level indices and 
!    cloud temperature, along with environmental mixing ratio and
!    temperature at these levels.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 3i4)')  &
                             'in mulsub: kc,kcl,kch= ',kc,kcl,kch
          write (diag_unit, '(a, 3e20.14)')  &
                         'in mulsub: TCC = ',TCC(kc),TCC(kcl),TCC(kch)
          write (diag_unit, '(a, 3e20.12)')  &
                              'in mulsub: QE= ',mrE(kc),mrE(kcl),mrE(kch)
          write (diag_unit, '(a, 3e20.12)')   &
                              'in mulsub: TE= ',TE(kc),TE(kcl),TE(kch)
        endif

!----------------------------------------------------------------------
!    define the perturbation vertical subgrid scale temperature flux 
!    associated with the cloud (exf). note the special definitions at
!    cloud bottom and top.
!----------------------------------------------------------------------
        if (kc == 1) then
          exf = Param%rdgas*wv(kc)*dpdz_cb*(tcc(kc) - te(kc))*  &
                ((rcl(kc)/Param%cloud_base_radius)**2)/(Param%cp_air*p)
        else if (kc == kch) then
          exf = Param%rdgas*wv(kc)*dpdz(ncc_kou)*(tcc(kc) - te(kc))*  &
                ((rcl(kc)/Param%cloud_base_radius)**2)/(Param%cp_air*p)
        else             
          exf = Param%rdgas*wv(kc)*dpdz(kc)*(tcc(kc) - te(kc))*   &
                ((rcl(kc)/Param%cloud_base_radius)**2)/(Param%cp_air*p)
        endif

!----------------------------------------------------------------------
!    at the cloud top, define the cumulus vertical-flux convergence of 
!    temperature, moisture and tracers as the flux transport entering 
!    the layer which contains cloud top. this "through the top" trans-
!    port is assumed to be all deposited in this layer which includes 
!    cloud top. set the vertical eddy transports of temperature, moist-
!    ure and tracer at the uppermost interior cloud level to zero.
!----------------------------------------------------------------------
        if (kc == kch) then
          efchr(ncc_kou ) = ehf(ncc_kou)/Param%dp_of_cloud_model
          emfhr(ncc_kou ) = emf(ncc_kou)/Param%dp_of_cloud_model
          ehf(ncc_kou-1) = 0.
          emf(ncc_kou-1) = 0.

!##$%$%$%^&^&!!&&*** 
!!!???? is this correct ? shouldn't the flux across the upper interface
!!! of this layer be accounted for ?  I..e., 

!!!!     efchr(ncc-1) = exf +  (ehf(ncc-2) - ehf(ncc))/(2.*dpp)

!!   As it stands, it appears that all the flux into the ncc-1 layer 
!!   (ehf(ncc-2)) remains. however, some (ehf(ncc)) is exported 
!    into the ncc layer (above cloud top), suggesting a non-conservation
!!!   condition.
!##$%$%$%^&^&!!&&*** 

          efchr(ncc_kou-1) = exf + (ehf(ncc_kou-2))/(2.*dpp)
          emfhr(ncc_kou-1) = emf(ncc_kou-2)/(2.*dpp)
          do kcont=1,ntr
            etfhr(ncc_kou,kcont) = etf(ncc_kou,kcont)/Param%dp_of_cloud_model
            etf(ncc_kou-1,kcont) = 0.
            etfhr(ncc_kou-1,kcont) = etf(ncc_kou-2,kcont)/(2.*dpp)
          end do

!----------------------------------------------------------------------
!    add the appropriately pressure-weighted contributions from the
!    layer containing cloud top to the integrals of the in-cloud vert-
!    ical-flux convergence of entropy, (sumefc) potential temperature
!    (sumthet), moisture (sumemf) and tracers (sumetf).
!----------------------------------------------------------------------
          sumefc = sumefc + efchr(ncc_kou)*Param%dp_of_cloud_model/2.
          ptt = pt_kou + Param%dp_of_cloud_model
          sumthet = sumthet + efchr(ncc_kou)*    &
                                   ((1.0e05/ptt)**Param%kappa)* &
                                               Param%dp_of_cloud_model/2.
          sumemf = sumemf + emfhr(ncc_kou)*Param%dp_of_cloud_model/2.
          do kcont=1,ntr
            sumetf(kcont) = sumetf(kcont) + etfhr(ncc_kou,kcont)*  &
                            Param%dp_of_cloud_model/2.
          end do

!----------------------------------------------------------------------
!    if in diagnostic column, output the entropy and moisture flux 
!    convergence in the layer containing cloud top.
!----------------------------------------------------------------------
          if (debug_ijt) then 
            write (diag_unit, '(a, e20.12)')  &
                      'in mulsub: EFCHR(kc+1)= ',efchr(ncc_kou)
            write (diag_unit, '(a, e20.12)')  &
                          'in mulsub: EMFHRIT=kch ',emfhr(ncc_kou)
          endif

!---------------------------------------------------------------------
!    for all but the topmost layer, define the layer flux convergences
!    of entropy (efchr), moisture (emfhr) and tracers (etfhr). the ver-
!    tical flux convergence of entropy (efchr) is defined as the sum of
!    the in-cloud perturbation vertical subgrid scale temperature flux 
!    (exf) and the eddy flux convergence of temperature across 
!    the layer.
!---------------------------------------------------------------------
        else
          efchr(kc) = exf + (ehf(kcl) - ehf(kch))/(2.*dpp)
          emfhr(kc) = (emf(kcl) - emf(kch))/(2.*dpp)
          do kcont=1,ntr
            etfhr(kc,kcont) = (etf(kcl,kcont) - etf(kch,kcont))/(2.*dpp)
          end do
        endif

!----------------------------------------------------------------------
!    add the appropriately pressure-weighted contributions from the
!    current layer to the integrals of the in-cloud vertical-flux con-
!    vergence of entropy, (sumefc) potential temperature (sumthet), 
!    moisture (sumemf) and tracers (sumetf).
!----------------------------------------------------------------------
        sumefc  = sumefc  + (efchr(kc)*dpp)
        sumthet = sumthet + efchr(kc)*((1.0e05/p)**Param%kappa)*dpp
        sumemf  = sumemf  + (emfhr(kc)*dpp)
        do kcont=1,ntr
          sumetf(kcont) = sumetf(kcont) + etfhr(kc,kcont)*dpp
        end do

!---------------------------------------------------------------------
!    if in diagnostic column, write out the current vertical sum of 
!    the entropy and potential temperature flux convergence. output the
!    vertical flux of theta (thetf) and moisture (emf) at cloud base.
!    output the in-cloud (xclo) and environmental (xtrae) tracer 
!    mixing ratios.  if this is the 4th cumulus subensemble, output 
!    some fluxes, flux convergences, dpdz and other terms related to 
!    the flux calculation.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 2e20.12)')  &
                    'in mulsub: SUMTHET,SUMEFC= ',sumthet, sumefc
          do kcont=1,ntr
            write (diag_unit, '(a, e20.12)')'in mulsub: SUMETF=', &
                                           sumetf(kcont)
          end do
          if (kc == 1) then
            thetf = ehf(kcl)*((1.0e05/pl)**Param%kappa)
            write (diag_unit, '(a, 2e20.12)')  &
                             'in mulsub: THETF,EMFF= ',thetf,emf(kcl)
          endif
          do kcont=1,ntr
            write (diag_unit, '(a, 3i4, 2e20.12)')  &
                   'in muls:kou,k,kcont,xclo,xtrae=' &
                    ,kou,kc,kcont,xclo(kc,kcont),xtrae(kc,kcont)
          end do
          if (kou == 4) then
            write (diag_unit, '(a, i4, 2f19.10)') &
                                  'in mulsub: kc,PL,PH= ',kc, pl, ph
            write (diag_unit, '(a, 4e20.12)')  &
                'in mulsub: EHFH,EHFL,EXF,efchr(kc)= ', &
                        ehf(kch), ehf(kcl), exf, efchr(kc)
            write (diag_unit, '(a, 3e20.12)')   &
                          'in mulsub: EMFH,EMFL,EMF= ',  &
                         emf(kch), emf(kcl), emfhr(kc)
            if (do_donner_tracer) then
              write (diag_unit, '(a, 3e20.12)')   &
                       'in mulsub: ETFH,ETFL,ETF=         ', &
                     etf(kch,ntr), etf(kcl,ntr), etfhr(kc,ntr)
            endif
            write (diag_unit, '(a, 3e20.12)')   &
                               'etfh diag: rcl,wv,dpdzh=         ', &
                                    rcl(kch), wv(kch), dpdz(kch)
            write (diag_unit, '(a, 3e20.12)')   &
                                'etfl diag: rcl,wv,dpdzl=         ', &
                                    rcl(kcl), wv(kcl), dpdz(kcl)
            do kcont=1,ntr
              write (diag_unit, '(a, 3e20.12)')  &
                                   'etfh diag: xclo,xtrae= ',         &
                                   xclo(kch,kcont), xtrae(kch,kcont)
              write (diag_unit, '(a, 3e20.12)')  &
                                 'etfl diag: xclo,xtrae= ',         &
                                   xclo(kcl,kcont), xtrae(kcl,kcont)
            end do
            write (diag_unit, '(a, 3e20.12)')   &
                            'in mulsub: WV,RH,QE= ',  &
                                     wv(kch), q_sat(kch), mre(kch)
            write (diag_unit, '(a, 3e20.12)')   &
                            'in mulsub: WV,RL,QE= ',   &
                                     wv(kcl), q_sat(kcl), mre(kcl)
          endif 
        endif
      end do  ! (end of kc loop)

!----------------------------------------------------------------------
!    if this is a debug column, output the moisture and temperature 
!    tendency profiles produced by this ensemble member.
!----------------------------------------------------------------------
      if (debug_ijt) then
        call don_cm_output_member_tends_k  &
             (nlev_hires, ncc_kou, diag_unit, Param, tcc, dpf,  &
              efchr, emfhr, cld_press, ermesg, error) 
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
      endif

!------------------------------------------------------------------


end subroutine don_cm_compute_vert_fluxes_k



!#####################################################################

subroutine don_cm_output_member_tends_k    &
         (nlev_hires, ncc_kou, diag_unit, Param, tcc, dpf,   &
          efchr, emfhr, cld_press, ermesg, error) 

!----------------------------------------------------------------------
!    subroutine don_cm_output_member_tends_k prints out
!    the temperature (ctfhr) and moisture (cmfhr) tendency profiles 
!    produced by the current ensemble member.
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none 

!----------------------------------------------------------------------
integer,                     intent(in)  :: nlev_hires, ncc_kou,  &
                                            diag_unit
type(donner_param_type),     intent(in)  :: Param
real, dimension(nlev_hires), intent(in)  :: tcc, dpf, efchr, emfhr, &
                                            cld_press
character(len=*),            intent(out) :: ermesg
integer,                     intent(out) :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     ncc_kou        vertical index on cloud model grid of the level
!                    above cloud top (maximum number of vertical
!                    levels affected by current cloud)
!     diag_unit      unit number for column diagnostics output, if 
!                    diagnostics are requested for the current column
!     tcc            temperature field at cloud model levels
!                    [ degrees K ]
!     dpf            condensation rate profile 
!                    [ kg(h2o) / ( kg(air) sec) ]
!     efchr          profile of entropy tendency due to flux 
!                    convergence [ deg K / sec ]
!     emfhr          profile of moisture tendency due to flux 
!                    convergence [ kg(h2o) / (kg(air) sec) ]
!     cld_press      pressure at cloud model levels [ Pa ]
!     
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_hires)     :: cmfhr, ctfhr
      real                            :: convrat
      integer                         :: k

!---------------------------------------------------------------------
!   local variables:
!
!      cmfhr     moisture tendency due to flux convergence and 
!                condensation [ kg(h2o) / (kg(air) sec) ]
!      ctfhr     entropy tendency due to flux convergence and 
!                condensation [ deg K / sec ]
!      convrat   latent heat factor used with condensation term in 
!                entropy equation [ deg K ]
!      k         do-loop index
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    define the tendency terms at the levels within the cloud.
!---------------------------------------------------------------------
      do k=1,ncc_kou

!---------------------------------------------------------------------
!    define the appropriate latent heat to be used at the current 
!    cloud level. use the latent heat of vaporization for temperatures
!    at or above the freezing point (Param%tfre) and the latent heat of 
!    sublimation at temperatures lower than the freezing point. 
!---------------------------------------------------------------------
        if (tcc(k) >= Param%tfre) then
          convrat = Param%hlv/Param%cp_air   
        else
          convrat = Param%hls/Param%cp_air   
        endif

!---------------------------------------------------------------------
!    define the entropy tendency as the sum of the vertical flux conver-
!    gence of entropy (efchr) and the latent heat release.
!---------------------------------------------------------------------
        ctfhr(k) = -dpf(k)*convrat + efchr(k)

!---------------------------------------------------------------------
!     define the moisture tendency as the sum of vertical flux conver-
!     gence and total condensation. 
!---------------------------------------------------------------------
        cmfhr(k) = dpf(k) + emfhr(k)
      end do

!---------------------------------------------------------------------
!    set the values at layers above cloud top to 0.0.
!---------------------------------------------------------------------
      cmfhr(ncc_kou+1:nlev_hires) = 0.
      ctfhr(ncc_kou+1:nlev_hires) = 0.

!---------------------------------------------------------------------
!  ctfhr : cloud ensemble entropy tendency due to flux convergence and
!          condensation       
!          [ deg K / sec ]
!---------------------------------------------------------------------
      do k=1,nlev_hires       
        if (ctfhr(k) /= 0.0) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                    'in mulsub: k, P & cond/efc              =',    &
                     k, cld_press(k),ctfhr(k)
        endif
      end do

!---------------------------------------------------------------------
!  cmfhr : cloud ensemble moisture tendency due to flux convergence and
!          condensation       
!          [ kg(h2o) / (kg(air) sec) ]
!---------------------------------------------------------------------
      do k=1,nlev_hires       
        if (cmfhr(k) /= 0.0) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                   'in mulsub: k, P & cond/mfc              =',    &
                     k, cld_press(k),cmfhr(k)
        endif
      end do

!---------------------------------------------------------------------


end subroutine don_cm_output_member_tends_k


!#####################################################################


subroutine don_cm_process_condensate_k     &
       (nlev_lsm, nlev_hires, ntr, cldtop_indx, diag_unit, debug_ijt, &
        Param, acpre, accond, pb, pt_kou, pf, pftr, tcc, rcl, &
        cld_press, phalf_c, conint, dint, pmel, pmelt_lsm, precip, cu,&
        cell_precip, sumlhr, summel, dpf, dpftr, dfr, cell_melt, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none

!----------------------------------------------------------------------
integer,                      intent(in)    :: nlev_lsm, nlev_hires, &
                                               ntr, &
                                               cldtop_indx, diag_unit
logical,                      intent(in)    :: debug_ijt  
type(donner_param_type),      intent(in)    :: Param
real,                         intent(in)    :: acpre, accond, pb, pt_kou
real, dimension(nlev_hires),  intent(in)    :: pf, tcc, rcl, cld_press
real, dimension(nlev_hires,ntr), intent(in) :: pftr
real, dimension(nlev_lsm+1),  intent(in)    :: phalf_c
real,                         intent(inout) :: conint, dint,         &
                                               pmel, precip, cu, &
                                               cell_precip, sumlhr, &
                                               summel
real,                          intent(in) :: pmelt_lsm
real, dimension(nlev_hires),  intent(inout) :: dfr
real, dimension(nlev_hires),  intent(out)   :: dpf
real, dimension(nlev_hires,ntr),  intent(out)   :: dpftr
real, dimension(nlev_lsm),    intent(out)   :: cell_melt
character(len=*),             intent(out)   :: ermesg
integer,                      intent(out)   :: error
              

      real    :: dmela
      integer  :: k, kc, n
 
!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      dpf(1:nlev_hires) = 0.
      dpftr(:,:) = 0.
      precip = 0.
      conint = 0.


      if (cldtop_indx /= 0) then
!--------------------------------------------------------------------
!    loop over the cloud levels to adjust various outputs as needed.
!--------------------------------------------------------------------
        do k=1,cldtop_indx

!--------------------------------------------------------------------
!    convert the layer-mean values of cloud-area-weighted condensation 
!    (pf) and wet deposition (pftr)
!    to values at cloud model interfaces (dpf and dpftr).
!--------------------------------------------------------------------
          if (k == 1) then
            dpf(1) =     pf(1)
            do n=1,ntr
              dpftr(1,n) =     pftr(1,n)
            end do
          else 
            dpf(k) = 0.5*(pf(k) + pf(k-1))
            do n=1,ntr
              dpftr(k,n) = 0.5*(pftr(k,n) + pftr(k-1,n))
            end do
          endif 
          if (k == cldtop_indx) then
            dpf(cldtop_indx+1) = 0.5*pf(cldtop_indx)
            do n=1,ntr
              dpftr(cldtop_indx+1,n) = 0.5*pftr(cldtop_indx,n)
            end do
          endif
        end do
      endif ! (cldtop_indx /= 0)

!--------------------------------------------------------------------
!    if in a diagnostics column, output the freezing (dfr) and conden-
!    sation (dpf) rates and cloud radius (rcl) at each cloud model
!    level, before normalization by the cloud base area.
!----------------------------------------------------------------------
      do k=1,cldtop_indx + 2
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3e20.12)')  &
                'in mulsub: k,dfr,dpr,rcl= ', k, dfr(k) ,dpf(k), rcl(k)
        endif
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3e20.12)')  &
                'in mulsub: k,dpf,pf,pfavg= ', k, dpf(k) ,pf(k),  &
! note pf(k-1) when k=1 is garbage !
                                  0.5*(pf(k) + pf(k-1))
        endif
 
!--------------------------------------------------------------------
!    normalize the freezing rate and condensation rate profiles by the
!    cloud base area of ensemble member #1.
!--------------------------------------------------------------------
        dfr(k) = dfr(k)/(Param%cloud_base_radius**2)
        dpf(k) = dpf(k)/(Param%cloud_base_radius**2)
        do n=1,ntr
          dpftr(k,n) = dpftr(k,n)/(Param%cloud_base_radius**2)
        end do
 
!----------------------------------------------------------------------
!    if in a diagnostics column, output the freezing (dfr) and conden-
!    sation (dpf) rates and cloud radius (rcl) at each cloud model
!    level, after normalization by the cloud base area.
!----------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3e20.12)')  &
               'in mulsub: k,dfr,dpr,rcl= ', k, dfr(k), dpf(k), rcl(k)
          do n=1,ntr
            write (diag_unit, '(a, i4, e20.12)')  &
                'in mulsub: k,dpftr= ', k, dpftr(k,n)
          end do
        endif
      end do

      if (cldtop_indx /= 0) then
        do k=1,cldtop_indx
          conint = conint + pf(k)*Param%dp_of_cloud_model/Param%grav  
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                          'in mulsub: kc, PF,coninT= ',k, pf(k)*  &
                                Param%dp_of_cloud_model/Param%grav, &
                                                            conint  
        endif
        end do

!--------------------------------------------------------------------
!    if in diagnostics column, output the ensemble member number (kou), 
!    moisture convergence integral (sub1sum),  and condensation 
!    integral (conint).
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, e20.12, a)')  &
                   'in cloudm: CONINT= ',CONINT,' KG/(M**2)/SEC'
        endif

!--------------------------------------------------------------------
!    normalize the column integral of condensate by the cloud base area
!    of ensemble member #1. 
!--------------------------------------------------------------------
        conint = conint/(Param%cloud_base_radius**2)

!--------------------------------------------------------------------
!    define the precipitation generated by this ensemble member.
!--------------------------------------------------------------------
        precip = conint*acpre/accond
      endif ! (cldtop_indx /= 0)

!--------------------------------------------------------------------
!    define the condensation (cu) and precipitation rates (cell_precip) 
!    in units of mm(h2o) per day. add this ensemble member's contribution
!    to the total precipitation (ensmbl_precip) and condensation
!    (ensmbl_cond), normalized by the ensemble member's cloud base area.
!--------------------------------------------------------------------
      cu  = conint*Param%seconds_per_day
      cell_precip  = precip*Param%seconds_per_day
 
!----------------------------------------------------------------------
!    if in a diagnostics column, output the condensation (conint),
!    precipitataion (precip) and freezing (dint) rates for this ensemble
!    member, in both kg per m**2 per second and in mm per day.
!----------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12, a)')  &
                   'in mulsub: CONPRE, CPRE,DINT= ', conint, precip, &
                      dint, ' KG/(M**2)/SEC'
        write (diag_unit, '(a, e20.12, a)')   &
                    'in mulsub: CONDENSATION PRE= ', cu, ' MM/DAY'
        write (diag_unit, '(a, e20.12, a)')  &
                 'in mulsub: CLOUD MODEL PRE= ', cell_precip, ' MM/DAY'
      endif

!---------------------------------------------------------------------
!    compute the contribution to the column integrals of total conden-
!    sation (sumlhr) and frozen condensate from the lowest cloud layer.
!    units are kg(h2o) per square meter per second.
!---------------------------------------------------------------------
      sumlhr = (dpf(1)*((Param%dp_of_cloud_model/2.)/Param%grav))
      if (tcc(1) <= Param%tfre) then
        summel = (Param%dp_of_cloud_model/2.)*dpf(1)/Param%grav  
      else
        summel = 0.
      endif

!---------------------------------------------------------------------
!    if in a diagnostics window, output the condensation rate and
!    accumulated condensate integral at level 1.
!---------------------------------------------------------------------
      if (debug_ijt) then
        kc = 1
        write (diag_unit, '(a, i4, 2e20.12)')  &
                               'in mulsub: kc,DPF, SUMLHR= ',kc, &
               dpf(1)*((Param%dp_of_cloud_model/2.)/Param%grav),   &
                                                sumlhr
      endif

!--------------------------------------------------------------------
!    add the contributions from the remaining cloud layers to the 
!    integrals.
!--------------------------------------------------------------------
      do kc = 2,cldtop_indx+1

!---------------------------------------------------------------------
!    add the density weighted increment of column condensate to the 
!    array accumulating it (sumlhr). if in diagnostic column, write
!    out the condensate at the level and the current vertical sum of 
!    the column condensate.
!---------------------------------------------------------------------
        sumlhr = sumlhr + (dpf(kc)*(Param%dp_of_cloud_model/Param%grav))
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                         'in mulsub: kc,DPF,SUMLHR= ',kc,   &
               dpf(kc)*(Param%dp_of_cloud_model/Param%grav),   &
                                                               sumlhr
        endif

!---------------------------------------------------------------------
!    if the temperature is at or below the freezing level, add the 
!    current-level's density-weighted condensation to the array accum-
!    ulating the total frozen condensate in the column (summel).
!---------------------------------------------------------------------
        if (tcc(kc) <= Param%tfre) then
          summel = summel +  Param%dp_of_cloud_model*dpf(kc) /Param%grav 
        endif
      end do

!---------------------------------------------------------------------
!    if in diagnostics column, output the column integral of frozen 
!    condensate (summel). determine the amount of this condensate which
!    precipitates out by multiplying by the factor (cell_precip/cu).  add
!    this amount to the amount frozen in the updraft (dint) to obtain the
!    total amount which must be melted in the column (dints).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)')  'summel= ',summel
      endif

!--------------------------------------------------------------------
!    define the cloud model pressure at the level where melting occurs 
!    (pmel). 
!---------------------------------------------------------------------
      pmel = pb             
      do kc=1,cldtop_indx
        if ((tcc(kc) >= Param%kelvin) .and.   &
            (tcc(kc+1) <= Param%kelvin))  pmel = cld_press(kc)
      end do
      if (tcc(cldtop_indx+1) == Param%kelvin) pmel = pt_kou 
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12 )')  &
             'pmelt_lsm, pmel from hi-res, pb   = ', pmelt_lsm, pmel, pb
          endif

!---------------------------------------------------------------------
!    if there has been no freezing in the column, then there will be
!    no melting.
!---------------------------------------------------------------------
      dmela = 0.
      if (dint == 0.) then
        cell_melt(1:nlev_lsm) = 0.
      else

!--------------------------------------------------------------------
!    if the melting level is above cloud base, partition the integrated
!    ice melt from the cloud model within the appropriate large-scale 
!    model layers.
!--------------------------------------------------------------------
        if (pb > pmelt_lsm) then

!--------------------------------------------------------------------
!    define the rate of ice melt (dmela) in units of g(h2o) per 
!    kg(air) per day. 
!--------------------------------------------------------------------
          if (cu /= 0.0) then
! melt ice precip plus frozen liq precip
            dmela = -((summel*cell_precip/cu + dint*cell_precip/cu)*  &
                                  Param%grav/(pmelt_lsm - pb))*8.64E07
         endif

!--------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to distribute this integrated 
!    column melting over the appropriate pressure interval on the 
!    large-scale model grid. if in a diagnostic column, output the 
!    melting rates as mapped to the large-scale grid.
!--------------------------------------------------------------------
          if (debug_ijt) then
            write (diag_unit, '(a, e20.12, 2f19.10)')  &
              'in cm_intgl_to_gcm_col: dmela,pb,pmelt_lsm= ',  &
                                                 dmela, pb, pmelt_lsm
          endif
          call don_u_map_hires_i_to_lores_c_k  &
            (nlev_lsm, dmela, pb, pmelt_lsm, phalf_c, cell_melt, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
          if (debug_ijt) then
            do k=1,nlev_lsm              
              if (cell_melt(k) /= 0.0) then
                write (diag_unit, '(a, i4, e20.12)') &
                 'in cm_intgl_to_gcm_col: k,cell_melt= ',k,cell_melt(k)
              endif
            end do
          endif

!---------------------------------------------------------------------
!    if the melting level is at or below cloud base, then there is no
!    in-cloud melting of frozen condensate.
!---------------------------------------------------------------------
        else
          cell_melt(1:nlev_lsm) = 0.
        endif  ! ( pb > pmel)
      endif  !  (dint == 0.0)


!---------------------------------------------------------------------
!    change the sign of the integral and convert to units of kg(h2o)
!    per square meter per day (or mm per day). if in diagnostics col-
!    umn, output the column integrated melting (summel), precipitation 
!    (cell_precip) and condensation rates (cu) in units of mm per day.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12,a)')   &
             'in mulsub: summel,rc,cu= ',    &
        -(summel*cell_precip/cu)*Param%seconds_per_day,cell_precip,cu, &
                                            'mm/day'
      endif

!---------------------------------------------------------------------


end subroutine don_cm_process_condensate_k



!#####################################################################


subroutine don_cm_simult_k   &
         (diag_unit, debug_ijt, lfc_not_reached, Param, pcsave, rmu,  &
          cloud_temp, cloud_radius, w_vel, cloud_p, liq_wat, env_temp, &
          env_mixing_ratio, dtdp,  drdp, dwdp, ermesg, error)

!--------------------------------------------------------------------
!    subroutine simult returns the vertical derivatives of temperature
!    (dtdp), cloud radius (drdp) and vertical velocity (dwdp) in the
!    cloud.
!    Reference: Donner, JAS, 1986, v43, pp.2277-2288.
!    See LJD "Cloud Model 89" notes on Generalized mu (10/1/89)
!    and dwdz (10/2/89). The value of epsilon is taken as 1.
!    Version where cloud properties independent of cloud area.
!--------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_qs_k

implicit none

!--------------------------------------------------------------------
integer,                 intent(in)    ::  diag_unit
logical,                 intent(in)    ::  debug_ijt, lfc_not_reached
type(donner_param_type), intent(in)    ::  Param
real,                    intent(in)    ::  pcsave, rmu, cloud_temp,  &
                                           cloud_radius, w_vel,   &
                                           cloud_p, liq_wat, env_temp, &
                                           env_mixing_ratio
real,                    intent(out)   ::  dtdp, drdp, dwdp
character(len=*),        intent(out)   ::  ermesg
integer,                 intent(out)   ::  error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!        cloud_temp  cloud temperature [ deg K ]
!        cloud_radius 
!                    cloud radius  [ m ]
!        w_vel       cloud vertical velocity [ m / s ] 
!        cloud_p     pressure at current level [ Pa ]
!        env_temp    environmental temperature [ deg K ]
!        env_mixing_ratio
!                    environmental mixing ratio [ kg / kg ]
!        liq_wat     liquid water [ kg / kg ]
!        pcsave      pressure at which cloud ensemble member 1 becomes
!                    buoyant [ Pa ]
!        rmu         entrainment coefficient [ m**(-1) ]
!        lfc_not_reached   if true, have not yet reached buoyant part of 
!                    cloud (vertical velocity has not yet begun to
!                    increase)
!        debug_ijt   is this a diagnostics column ?
!        diag_unit   output unit number for this diagnostics column
!
!   intent(out) variables:
!
!        dtdp        temperature derivative [ deg K / Pa ]
!        drdp        cloud radius derivative [ m / Pa ]
!        dwdp        vertical velocity derivative [ m / (sec Pa) ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real  ::  areap, c2, c3, c4, dadp, dw2dz, dwdz, dzdp, dz, es,  &
                entrain_co, htv, htve, lat, rhoaw, rhoawp, &
                rstar, sphum, tcae, teae, test, west, w2test, wtest
      integer :: nbad

!---------------------------------------------------------------------
!   local variables:
!
!         areap             updated cloud area [ m**2 ]
!         c2                term in dt/dz eqn (eqn 5, Donner, JAS, 1993)
!         c3                term in dt/dz eqn (eqn 5, Donner, JAS, 1993)
!         c4                term in dt/dz eqn (eqn 5, Donner, JAS, 1993)
!         dadp              derivative of cloud area with respect to
!                           pressure [ m**2 / Pa ]
!         dw2dz             vertical derivative of vertical velocity
!                           squared with respect to height 
!                           [ m / sec**2 ]
!         dwdz              vertical derivative of vertical velocity
!                           with respect to height [ sec**(-1) ]
!         dzdp              dz/dp when virtual mass coefficient is
!                           used [ m / Pa ]
!         dz                delta z corresponding to dp_of_cloud_model
!                           [ m ]
!         es                saturation vapor pressure [ Pa ]
!         entrain_co        entrainment coefficient [ m**(-1) ]
!         htv               virtual temperature of cloud       [ deg K ]
!         htve              virtual temperature of environment [ deg K ]
!         lat               latent heat relevant at input temperature
!                           cloud_temp [ J/kg ]
!         rhoaw             rho * cloudarea * vertical velocity for
!                           input values [ kg / sec ]
!         rhoawp            rho * cloudarea * vertical velocity for
!                           updated values [ kg / sec ]
!         rstar             gas constant for moist air [ J / (kg degK) ]
!         sphum             saturation specific humidity [ kg / kg ]   
!         tcae              equivalent potential temperature in cloud
!                           [ deg K ]
!         teae              equivalent potential temperature in env-
!                           ironment [ deg K ]
!         test              updated temperature [ deg K ]
!         west              updated vetical velocity [ m / sec ]
!         w2test            updated vertical velocity squared (without
!                           entrainment term) [ m**2 / sec**2 ]
!         wtest             updated vertical velocity  (without
!                           entrainment term) [ m / sec ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!   define appropriate latent heat for the given cloud temperature.
!---------------------------------------------------------------------
      if (cloud_temp < Param%tfre) then
        lat = Param%hls    
      else
        lat = Param%hlv   
      endif
 
!---------------------------------------------------------------------
!    define the specific humidity at the cloud temperature (sphum) and
!    the gas constant for moist air (rstar).
!---------------------------------------------------------------------
      call compute_qs_k (cloud_temp, cloud_p, Param%D622,  &
                           Param%D608, sphum, nbad, esat = es)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (nbad /= 0) then
        ermesg = 'subroutine don_cm_simult_k: '// &
                 'temperatures out of range of esat table'
        error = 1
        return
      endif

      rstar = Param%rdgas*(1. + Param%d608*sphum)

!---------------------------------------------------------------------
!    define the in-cloud (htv) and environmental (htve) virtual 
!    temperature.                                                       
!---------------------------------------------------------------------
      htv  = cloud_temp*(1. + Param%d608*sphum)
      htve = env_temp*(1. + Param%d608*(env_mixing_ratio/   &
                                                (1.0+env_mixing_ratio)))

!---------------------------------------------------------------------
!    if in diagnostics window, output the in-cloud and environmmental
!    virtual temperatures.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                      'in simult: htve,htv= ',htve, htv
      endif

!---------------------------------------------------------------------
!    define one of the terms present in the dt/dz eqn (Eqn 5) in 
!    Donner, JAS, 1993, v50, pp.890-906.
!---------------------------------------------------------------------
      c2 = (htv + (lat*sphum/rstar))*Param%grav/(Param%cp_air*cloud_temp)

!---------------------------------------------------------------------
!    if in diagnostics window, output the c2 term in the dt/dz equation
!    and the environmmental temperature, moisture and pressure at this
!    level. 
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)')  'in simult: c2= ',c2
        write (diag_unit, '(a, f20.14, f19.10, e20.12)')  &
              'in simult: te,p,qe= ',env_temp, cloud_p ,env_mixing_ratio
      endif

!--------------------------------------------------------------------
!    call tae to calculate environmental adiabatic equivalent 
!    temperature (teae).
!--------------------------------------------------------------------
      call don_cm_tae_k    &
           (Param, env_temp, cloud_p, env_mixing_ratio, lat, teae,  &
            ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    if in diagnostics window, output the environmental adiabatic 
!    equivalent temperature.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, f20.14)') 'in simult: teae= ',teae
      endif

!--------------------------------------------------------------------
!    calculate in-cloud adiabatic equivalent temperature (tcae).
!--------------------------------------------------------------------
      tcae = cloud_temp*exp(lat*sphum/(Param%cp_air*cloud_temp))

!----------------------------------------------------------------------
!    define dz/dp in the presence of a virtual mass coefficient (used
!    to roughly account for non-hydrostatic effects). define the cor-
!    resonding dz for the cloud model pressure increment dp.
!    Reference: Donner, JAS, 1986, v43, pp.2277-2288.
!----------------------------------------------------------------------
      dzdp = -Param%rdgas*(1. + Param%virt_mass_co)*htv*htve/    &
                                (Param%grav*cloud_p*  &
                                      (Param%virt_mass_co*htve + htv))
      dz   = Param%dp_of_cloud_model*dzdp

!---------------------------------------------------------------------
!    define the remaining terms (c3, c4) in the dt/dz equation (eqn (5)
!    in the reference cited below).
!    note : the entrainment coefficient (dln(rho*a*w)/dz) is given by 
!    (exp(rmu*dz) - 1.)/(exp(rmu*dz)*dz), with assumption that 
!    rhoaw(z) = rhoaw(0)*exp(rmu*dz)
!    Reference: Donner, JAS, 1993, v50, pp.890-906.
!---------------------------------------------------------------------
      entrain_co = (exp(rmu*dz) - 1.0)/(exp(rmu*dz)*dz)
      c3 = (tcae - teae)/exp(lat*sphum/(Param%cp_air*cloud_temp))*  &
                                                               entrain_co
      c4 = 1. + (Param%d622*lat*(Param%hlv*es/     &
                   (Param%rvgas*(cloud_temp**2)))/(Param%cp_air*cloud_p))

!---------------------------------------------------------------------
!    if in diagnostics window, output the c3 and c4 terms in the dt/dz 
!    equation.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  'in simult: c3,c4= ',c3,c4
      endif

!---------------------------------------------------------------------
!    define the dt/dp tendency by combining the component terms 
!    in the dt/dz equation and multiplying by dz/dp. define an 
!    updated estimated value of in-cloud temperature (test).
!---------------------------------------------------------------------
      dtdp = -((c2 + c3)/c4)*dzdp
      test = cloud_temp + dtdp*Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    define the buoyancy and drag terms in the d(w**2)/dz equation. 
!    Reference: Donner, JAS, 1993, v50, pp.890-906.
!--------------------------------------------------------------------
      dw2dz = 2.0*((Param%grav*(htv - htve)/      &
                                  (htve*(1. + Param%virt_mass_co))) -  &
                                                      Param%grav*liq_wat)

!-------------------------------------------------------------------
!    produce an updated vertical velocity squared (wtest) by adding this
!    tendency term to the input value. be sure w**2 is positive; then 
!    define the vertical velocity.
!-------------------------------------------------------------------
      w2test = (w_vel**2) + dw2dz*dz
      if (w2test < 0.) then
        wtest = 0.
      else
        wtest = sqrt(w2test)
      endif

!---------------------------------------------------------------------
!    if in diagnostics window, output the updated vertical velocity.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, l4, e20.12)')  &
                     'in simult: testlc,wtest= ',lfc_not_reached, wtest
      endif

!----------------------------------------------------------------------
!    define the dw/dp derivative from this updated value, ignoring the 
!    entrainment term.
!----------------------------------------------------------------------
      dwdp = (wtest - w_vel)/Param%dp_of_cloud_model

!----------------------------------------------------------------------
!    determine if the necessary conditions for entrainment are present.
!    allow entrainment to change vertical velocity if parcel has 
!       (1) previously achieved initial acceleration 
!           (.not. lfc_not_reached) 
!           and it has ascended above the level where the most entrain-
!           ing parcel (ensemble member #1) initially accelerates or,
!       (2) the parcel is currently accelerating. 
!    the first condition ensures that a shallow, lower-entrainment cloud
!    will not develop below the pressure where the most entraining
!    parcel initially accelerates.
!----------------------------------------------------------------------
      if ( ((.not. lfc_not_reached) .and. (cloud_p <= pcsave)) .or.   &
           (dwdp <= 0.) ) then
        dwdz = -w_vel*entrain_co
        dwdp = (dwdz*dzdp) + dwdp
      endif

!----------------------------------------------------------------------
!    if the parcel has not reached the level of free convection, do
!    not allow its vertical velocity to decrease. BL turbulence or 
!    other sub-grid mechanisms are assumed present to sustain its
!    upward motion.
!----------------------------------------------------------------------
      if ((lfc_not_reached) .and. (dwdp > 0.) )  then
        dwdp = 0.
      endif

!----------------------------------------------------------------------
!    if the parcel is above its level of free convection  but below
!    the pressure level at which the ensemble member #1 initially 
!    accelerates, do not allow its vertical velocity to decrease. this
!    ensures that less entraining clouds will not develop between the
!    ground and the pressure at which the most entraining parcel 
!    initally accelerates. BL turbulence or some other sub-grid 
!    mechanism is assumed to sustain its upward motion.
!----------------------------------------------------------------------
      if ( (.not. lfc_not_reached) .and. (cloud_p > pcsave) .and.    &
           (dwdp > 0.) )  then
        dwdp = 0.
      endif

!---------------------------------------------------------------------
!    if in diagnostics window, output the updated vertical velocity.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a,l4,  2e20.12)')  &
          'in simult: testlc,dwdp,test= ',lfc_not_reached,dwdp,test
      endif

!---------------------------------------------------------------------
!    produce an updated vertical velocity (eqn (6) of reference).
!---------------------------------------------------------------------
      west = w_vel + dwdp*Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    calculate the terms in the cloud area tendency equation.
!    Reference: Donner, JAS, 1993, v50, pp.890-906.
!--------------------------------------------------------------------
      if (west < Param%wdet) then

!--------------------------------------------------------------------
!    if the updated vertical velocity is weaker than the detrainment
!    velocity, set the cloud radius tendency to 0.0,maintaining the
!    input value.
!--------------------------------------------------------------------
        drdp = 0.
      else

!--------------------------------------------------------------------
!    define the value of rho*cloudarea*vertical velocity (rhoaw) for 
!    the input values of these variables. define the same quantity at 
!    a level dz higher (rhoawp), assuming rhoaw(z) = 
!    rhoaw(0)*exp(rmu*dz).
!--------------------------------------------------------------------
        rhoaw = cloud_p*(cloud_radius**2)*w_vel/(Param%rdgas*htv)
        rhoawp = rhoaw*exp((dzdp*rmu)*Param%dp_of_cloud_model)

!---------------------------------------------------------------------
!    if in diagnostics window, output rho*cloudarea*w obtained from
!    input values and at a height dz higher.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, f19.10, 2e20.12)')  &
                       'in simult: p,fm,fmp= ', cloud_p, rhoaw, rhoawp
        endif

!---------------------------------------------------------------------
!    define the virtual temperature (htv) corresponding to the updated 
!    temperature test.
!----------------------------------------------------------------------
        call compute_qs_k (test, cloud_p, Param%D622,  &
                           Param%D608, sphum, nbad)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_cm_simult_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif
        htv = test*(1. + Param%d608*sphum)

!----------------------------------------------------------------------
!    define the updated cloud area (areap). define the area tendency 
!    (dadp) and then the cloud radius tendency (drdp).
!----------------------------------------------------------------------
        areap = rhoawp*Param%rdgas*htv/  &
                               ((cloud_p + Param%dp_of_cloud_model)*west)
        dadp = (areap - (cloud_radius**2))/Param%dp_of_cloud_model
        drdp = dadp/(2.*cloud_radius)
      endif

!--------------------------------------------------------------------



end subroutine don_cm_simult_k




!####################################################################

subroutine don_cm_tae_k    &
         (Param, init_temp, init_pr, parcel_mixing_ratio, latent_heat,  &
          equivalent_temp, ermesg, error)

!--------------------------------------------------------------------
!    subroutine tae determines the saturation temperature of an init-
!    ially non-saturated parcel ( defined by init_temp, 
!    parcel_mixing_ratio, init_pr) by incrementally moving the parcel 
!    upward dry adiabatically until it reaches the temperature at which 
!    saturation would occur for the initial pressure init_pr.  using this
!    saturation temperature (te) and the parcel moisture 
!    parcel_mixing_ratio and pressure init_pr, the equivalent temperature
!    is calculated (the temperature attained if all vapor were condensed 
!    out by moist adiabatic ascent, followed by dry adiabatic descent to
!    the initial pressure level init_pr.
!--------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!--------------------------------------------------------------------
type(donner_param_type), intent(in)    :: Param
real,                    intent(in)    :: init_temp, init_pr,   &
                                          parcel_mixing_ratio,  &
                                          latent_heat
real,                    intent(out)   :: equivalent_temp
character(len=*),        intent(out)   :: ermesg
integer,                 intent(out)   :: error

!--------------------------------------------------------------------
!   intent(in) variables:
!
!        init_temp              temperature   [ deg K ]
!        init_pr                pressure      [ Pa ]
!        parcel_mixing_ratio    mixing ratio [kg(H2O)/kg (dry air) ]
!        latent_heat            applicable latent heat constant  [ J/kg ]
!
!   intent(out) variables:
!
!        equivalent_temp        adiabatic equivalent temperature 
!                               [ deg K ]
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real      ::   pr, te, mre
      integer   ::   nbad

!--------------------------------------------------------------------
!   local variables:
!
!        pr   pressure at current level  [ Pa ]
!        te   temperature of parcel move dry adiabatically from
!             pressure p to pressure pr
!        es   stauration vapor pressure at temperature te
!        mre  saturation mixing ratio at temperature te and pressure p
!        k    do-loop index
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutinE.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    initialize the output variable equivalent_temp and the pressure at 
!    current level (pr).
!---------------------------------------------------------------------
      equivalent_temp = init_temp
      pr = init_pr

!---------------------------------------------------------------------
!    vertical loop. if the pressure  pr is less than pstop (absolute 
!    lowest pressure for cloud) exit the loop.
!---------------------------------------------------------------------
      do while (pr >= Param%pstop) 

!--------------------------------------------------------------------
!    define the temperature (te) at pressure pr assuming dry adiabatic
!    ascent from initial pressure p. determine the saturation vapor
!    pressure (es) for this temperature. define the saturation mixing
!    ratio for a parcel of this temperature at the initial pressure
!    level (mre).
!--------------------------------------------------------------------
        te = init_temp*((pr/init_pr)**Param%kappa)
        call compute_mrs_k (te, init_pr,                               &
                            Param%d622 , Param%d608 , mre, nbad, &
                            mr = parcel_mixing_ratio)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_cm_tae_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

!--------------------------------------------------------------------
!    determine if saturation at the initial pressure level would occur
!    for this temperature.
!--------------------------------------------------------------------
        if (parcel_mixing_ratio >= mre) then

!--------------------------------------------------------------------
!    if saturation would occur for this temperature (te) at the initial
!    pressure init_pr (i.e., parcel_mixing_ratio >= mre), then use te to
!    calculate the equivalent temperature. exit the loop. otherwise,
!    increment the current pressure and continue within the loop.
!--------------------------------------------------------------------
          equivalent_temp = init_temp*exp(latent_heat*  &
                                   parcel_mixing_ratio/(te*Param%cp_air))
          exit
        endif
        pr = pr + Param%dp_of_cloud_model
      end do

!---------------------------------------------------------------------



end subroutine don_cm_tae_k

!####################################################################

subroutine don_cm_micro_k   &
         (diag_unit, debug_ijt, Param, tc1, tc2, p1, p2, te1, te2,  &
          qe1, qe2, w1, w2, rr, rmu, qrw, qcw, qlw, dcw1, dqrw3, ermesg, error)

!----------------------------------------------------------------------
!    subroutine micro calculates microphysical tendencies (kessler
!    microphysics) of the cloud parcel defined by (tc, w, qrw, qcw, 
!    qlw, rr) in an environment defined by (te, qe, rmu) during the 
!    movement of the parcel from pressure level p1 to level p2.
!--------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!--------------------------------------------------------------------
integer,                  intent(in)    :: diag_unit
logical,                  intent(in)    :: debug_ijt
type(donner_param_type),  intent(in)    :: Param
real,                     intent(in)    :: tc1, tc2, p1, p2, te1, te2, &
                                           qe1, qe2, w1, w2, rr, rmu
real,                     intent(inout) :: qrw, qcw, qlw, dcw1, dqrw3
character(len=*),         intent(out)   :: ermesg
integer,                  intent(out)   :: error

!--------------------------------------------------------------------
!  intent(in) variables:
!
!        tc1       cloud temperature at starting point [ deg K ]
!        tc2       cloud temperature at ending point [ deg K ]
!        p1        pressure at starting point [ Pa ]
!        p2        pressure at ending point [ Pa ]
!        te1       environmental temperature at starting point [ deg K ]
!        te2       environmental temperature at ending point [ deg K ]
!        qe1       environmental mixing ratio at starting point  
!                  [ kg(H2O) / kg(air) ] 
!        qe2       environmental mixing ratio at ending point  
!                  [ kg(H2O) / kg(air) ] 
!        w1        cloud vertical velocity at starting point [ m / sec ]
!        w2        cloud vertical velocity at ending point [ m / sec ]
!        rr        cloud radius [ m ]
!        rmu       entrainment coefficient [ m**(-1) ]
!        debug_ijt is this a diagnostics column ?
!        diag_unit output unit number for this diagnostics column
!
!   intent(inout) variables:
!
!        qrw    rain water              [ g(h2o) / m**3 ]
!        qcw    cloud water             [ g(h2o) / m**3 ]
!        qlw    total liquid water      [ kg(h2o) / kg(air) ]
!        dcw1   condensation increment  [ g(h2o) / m**3 ]
!        dqrw3  precipitation increment [ g(h2o) / m**3 ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:
  
      real :: cond, d1, d2, dcw2, dqcw3, dt_micro, dz, ent, pav,  &
              rb, qcwa, qeb, qrwa, red, rho, rs1, rs2, tcb, wav
      integer :: nbad

!--------------------------------------------------------------------
!   local variables:
!
!     cond      condensation in the layer [ kg(h2o) / kg(air) ]
!     d1        dz/dp at the starting level [ m / Pa ]  
!     d2        dz/dp at the ending level [ m / Pa ]  
!     dcw2      change in cloudwater due to autoconversion 
!               [ g (h2o) / m**3 ]
!     dqcw3     change in cloudwater content due to accretion     
!               [ g (h2o) / m**3 ]
!     dt_micro  microphysical time step [ sec ]
!     dz        average delta z in the layer [ m ]
!     ent       ratio of parcel mass after entrainment to mass
!               before entrainment [ dimensionless ]
!     es1       saturation vapor pressure at level p1 [ Pa ]
!     es2       saturation vapor pressure at level p2 [ Pa ]
!     pav       average pressure in the layer [ Pa ]
!     rb        average in-cloud mixing ratio in the layer 
!               [ kg(h2o) / kg(air) ]
!     qcwa      initial value of cloudwater after microphysical term
!               updates; it is then adjusted to avoid negative values
!               [ g(h2o) / m**3 ]
!     qeb       average environmental mixing ratio in the layer 
!               [ kg(h2o) / kg(air) ]
!     qrwa      initial value of rainwater after microphysical term
!               updates; it is then adjusted to avoid negative values
!               [ g(h2o) / m**3 ]
!     red       reducing factor applied to the microphysical loss terms
!               in the cloud and rain equations to avoid creation of
!               negative cloud and rain water [ dimensionless ]
!     rho       atmospheric density [ kg / m**3 ]
!     rs1       saturation mixing ratio in cloud at level p1
!     rs2       saturation mixing ratio in cloud at level p2
!     tcb       mean in-cloud temperature in the layer [ deg K ]
!     teb       mean environmental temperature in the layer [ deg K ]
!     wav       mean vertical velocity in the layer [ m / sec ]
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    define the saturation mixing ratio (rs1) at level p1.
!--------------------------------------------------------------------
      call compute_mrs_k (tc1, p1, Param%d622 , Param%d608 , rs1, nbad)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (nbad /= 0) then
        ermesg = 'subroutine don_cm_micro_k: '// &
                 'temperatures out of range of esat table'
        error = 1
        return
      endif

!--------------------------------------------------------------------
!    define the saturation mixing ratio (rs2) at level p2.
!--------------------------------------------------------------------
      call compute_mrs_k (tc2, p2, Param%d622 , Param%d608 , rs2, nbad)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (nbad /= 0) then
        ermesg = 'subroutine don_cm_micro_k: '// &
                 'temperatures out of range of esat table'
        error = 1
        return
      endif

!--------------------------------------------------------------------
!    if in diagnostic column, output the relevant atmospheric fields 
!    at the two pressure levels.
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')   &
                         'in micro: qrw,qcw= ',qrw,qcw
        write (diag_unit, '(a, e20.12)')  'in micro: rr= ',rr
        write (diag_unit, '(a, 2e20.12, 2f19.10)') &
                         'in micro: rs1,rs2,p1,p2= ',rs1,rs2,p1,p2
        write (diag_unit, '(a, 2e20.12, 2f20.14)')  &
!                        'in micro: es1,es2,tc1,tc2= ',es1,es2,tc1,tc2
                         'in micro: tc1,tc2= ',tc1,tc2
        write (diag_unit, '(a, 2f20.14)')  &
                          'in micro: te1,te2= ',te1,te2
      endif

!--------------------------------------------------------------------
!    define the layer-mean cloud temperature (tcb) and mixing ratio 
!    (rb), environmental mixing ratio (qeb), vertical velocity (wav), 
!    pressure (pav) and density (rho). define a layer-mean dz, as the  
!    average of the values of dz/dp (when using a virtual mass coeffic-
!    ient) at the two input levels. define the ratio of post-entrainment
!    mass to the pre-entrainment mass (ent).
!--------------------------------------------------------------------
      tcb = 0.5*(tc1 + tc2)
      rb  = 0.5*(rs1 + rs2)
      qeb = 0.5*(qe1 + qe2)
      wav = 0.5*(w1  +  w2)
      pav = 0.5*(p1  +  p2)
      rho = pav/(Param%rdgas*tcb*(1. + Param%d608*(rb/(1.0+rb))))
      d1  = Param%rdgas*(1. + Param%virt_mass_co)*tc1*te1/  &
            (Param%grav*p1*(Param%virt_mass_co*te1 + tc1))
      d2  = Param%rdgas*(1. + Param%virt_mass_co)*tc2*te2/  &
            (Param%grav *p2*(Param%virt_mass_co*te2 + tc2))
      dz  = -0.5*(d1 + d2)*Param%dp_of_cloud_model
      ent = exp(rmu*dz)

!--------------------------------------------------------------------
!    if in diagnostic column, output the entrainment coefficient (rmu)
!    and the environmental mixing ratio (qeb).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                   'in micro: qeb,rmu= ', qeb, rmu
      endif

!----------------------------------------------------------------------
!    calculate the condensation (cond). the condensation is made up of
!    that which would occur due to adiabatic expansion (rs2 - rs1)
!    less the vapor which must be evaporated to saturate the environ-
!    mental air entrained into the cloud ((ent-1.)*(rs2-qeb)).  cond is
!    further modified to allow the condensation to be added to the
!    parcel at any point during the timestep through the variable
!    tr_insert_time. if the condensate is assumed to be added to the 
!    parcel while at mass m (its initial size), tr_insert_time = 0; 
!    if assumed to be added at end of step when parcel mass is ent 
!    times larger than its initial value, tr_insert_time is 1.  force 
!    the condensation to be non-negative.
!----------------------------------------------------------------------
      cond = (rs2 - rs1) + (ent - 1.)*(rs2 - qeb)
      cond = -cond/(1. - Param%tr_insert_time +    &
                         Param%tr_insert_time*ent)
      cond  = max (cond, 0.0)

!--------------------------------------------------------------------
!    if in diagnostic column, output the condensation (cond).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)') 'in micro: cond= ', cond
      endif

!--------------------------------------------------------------------
!    convert the condensation from units of kg(h2o)/ kg(air) to units
!    of (g(h2o) / m**3) by multiplying by rho*1000. define the timestep
!    for microphysical processes (dt_micro).
!--------------------------------------------------------------------
      dcw1 = cond*rho*1000.
      dt_micro = dz/wav

!--------------------------------------------------------------------
!    calculate the amount of cloud autoconverted to rain (dcw2). 
!--------------------------------------------------------------------
      if (qcw >= Param%autoconv_threshold)  then
        dcw2 = Param%autoconv_rate*(qcw - Param%autoconv_threshold)* &
                                                                dt_micro 
      else
        dcw2 = 0.0
      endif

!--------------------------------------------------------------------
!    calculate the cloud accretion by rainwater (dqcw3).
!--------------------------------------------------------------------
      if (qcw /= 0.0 .and. qrw /= 0.0) then
        dqcw3 = 5.26e-03*qcw*(qrw**.875)*dt_micro 
      else
        dqcw3 = 0.
      endif

!--------------------------------------------------------------------
!    calculate effect of entrainment on cloud water.
!--------------------------------------------------------------------
      qcw = qcw/ent

!---------------------------------------------------------------------
!    add the microphysical terms to the cloud water equation. if neces-
!    sary adjust the magnitudes of the loss terms so that negative
!    values of cloud water are not created. define the final value of
!    qcw.
!---------------------------------------------------------------------
      qcwa = qcw + dcw1 - dcw2 - dqcw3
      if (qcwa < 0.) then
        red = (qcw + dcw1)/(dcw2 + dqcw3)
        dcw2 = dcw2*red
        dqcw3 = dqcw3*red
      endif
      qcw = qcw + dcw1 - dcw2 - dqcw3

!--------------------------------------------------------------------
!    if in diagnostic column, output the cloud water entrainment  
!    factor (ent), the updated cloud water (qcw) and the condensation 
!    term (dcw1).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                             'in micro: ent,qcw,dcw1= ',ent,qcw,dcw1
      endif

!--------------------------------------------------------------------
!    calculate the flux of rainwater due to fallout.
!--------------------------------------------------------------------
      if (qrw /= 0.0) then
        dqrw3 = (qrw**1.125)*5.1*dt_micro/rr
      else
        dqrw3 = 0.  
      endif
 
!--------------------------------------------------------------------
!     calculate effect of entrainment on rain water
!--------------------------------------------------------------------
      qrw = qrw/ent

!---------------------------------------------------------------------
!    add the microphysical terms to the rain water equation. if neces-
!    sary adjust the magnitudes of the loss term so that negative
!    values of rain water are not created. define the final value of
!    qrw.
!---------------------------------------------------------------------
      qrwa = qrw + dcw2 + dqcw3 - dqrw3
      if (qrwa < 0.) then
        red   = (qrw + dcw2 + dqcw3)/dqrw3
        dqrw3 = red*dqrw3
      endif
      qrw = qrw + dcw2 + dqcw3 - dqrw3

!--------------------------------------------------------------------
!    if in diagnostic column, output the rainwater entrainment effect
!    (ent) and the updated value of rainwater. (qrw).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)') &
                               'in micro: ent,qrw= ',ent,qrw
      endif

!--------------------------------------------------------------------
!    apply realizability consitions to qcw and qrw. define total liquid
!    water qlw.
!--------------------------------------------------------------------
      qcw = max (qcw, 0.0)
      qrw = max (qrw, 0.0)
      qlw = qrw + qcw

!--------------------------------------------------------------------
!    if in diagnostic column, output the condensation (dcw1), the 
!    rainwater fallout (dqrw3) and the total liquid remaining (qlw).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')   &
                      'in micro: exit micro dcw1,dqrw3,qlw= ',   &
                       dcw1,dqrw3,qlw
      endif

!--------------------------------------------------------------------
!    convert the liquid water from g / m**3 to kg / kg.
!--------------------------------------------------------------------
      qlw = 1.0E-03*qlw/rho

!-------------------------------------------------------------------




end subroutine don_cm_micro_k


!######################################################################

subroutine don_cm_freeze_liquid_k    &
         (k, diag_unit, debug_ijt, Param, tbot, ttop, qlwest, dfrac, &
          dtfr, dtupa, dfrtop, sumfrea, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none

!----------------------------------------------------------------------
integer,                  intent(in)    :: k, diag_unit
logical,                  intent(in)    :: debug_ijt 
type(donner_param_type),  intent(in)    :: Param
real,                     intent(in)    :: tbot, ttop, qlwest
real,                     intent(inout) :: dfrac, dtfr, dtupa, sumfrea
real,                     intent(inout) :: dfrtop
character(len=*),         intent(out)   :: ermesg
integer,                  intent(out)   :: error


      real ::  dfraca, dtupb

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    define the amount of liquid in the updraft which may be frozen.
!    multiply by a factor (freeze_fraction) to take account that not all
!    this water will freeze before falling out. use Leary and Houze
!    (JAS,1980) cell_precip/cu ratio to estimate this ratio.
!--------------------------------------------------------------------
      if ((tbot >= Param%tfre) .and. (ttop <= Param%tfre) .and.    &
          (dtfr == 0.)) then
        dtfr = qlwest*Param%hlf/Param%cp_air
        dtfr = Param%freeze_fraction*dtfr
      endif

!---------------------------------------------------------------------
!    define the fraction of liquid which is to be frozen at this level. 
!    freezing is assumed to occur linearly between 258 K and 248 K 
!    (dfre), with all liquid being frozen at 248 K. the fraction is not
!    allowed to decrease from its previous value if the temperature 
!    starts to increase with height within this temperature range. the 
!    fraction of the total which is frozen at the current level is 
!    dtupb; the amount frozen at this level (dfr(k+1) is the difference
!    between this amount and the amount frozen at the previous level 
!    (dtupa). cumulative total of frozen liquid is kept in sumfrea.
!---------------------------------------------------------------------
      if (dtfr > 0.0 .and. dtfr /= dtupa) then 
        dfraca = MIN ((Param%tfre - ttop)/Param%dfre, 1.0)
        dfrac = AMAX1 (dfrac, dfraca)
        dtupb = dtfr*dfrac 
        dfrtop   = dtupb - dtupa
        sumfrea = sumfrea + dfrtop   
        dtupa = dtupb

!--------------------------------------------------------------------
!    if in diagnostics column, output the values of available liquid
!    from freezing (dtfr), the amount frozen at level k+1 (dfr) and the 
!    constants hlf    and cp_air at this level.
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(4(a, e20.12),a, i4)') &
             'in cloudm: DTFR=',DTFR,' dfr=',dfrtop  ,   &
               'LATICE=',Param%hlf, 'CPAIR=',Param%cp_air,'k= ',k
        endif
      endif



end subroutine don_cm_freeze_liquid_k 


!#####################################################################



!######################################################################

subroutine don_cm_clotr_k    &
         (ntr, diag_unit, debug_ijt, Param, sou1, sou2, xe1, xe2, &
          xc1, entrain, dt_micro, xc2, ermesg, error)

!----------------------------------------------------------------------
!    subroutine clotr calculates the in-cloud tracer profiles for 
!    all of the travcers being transported by the donner convection
!    scheme.
!    author :  Leo Donner,  GFDL, 14 Jan 2000
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none

!----------------------------------------------------------------------
integer,                  intent(in)  ::  ntr
integer,                  intent(in)  ::  diag_unit
logical,                  intent(in)  ::  debug_ijt
type(donner_param_type),  intent(in)  ::  Param
real,   dimension(ntr),   intent(in)  ::  sou1 
real,   dimension(ntr),   intent(in)  ::  sou2 
real,   dimension(ntr),   intent(in)  ::  xe1  
real,   dimension(ntr),   intent(in)  ::  xe2  
real,   dimension(ntr),   intent(in)  ::  xc1  
real,                     intent(in)  ::  entrain, dt_micro
real,   dimension(ntr),   intent(out) ::  xc2  
character(len=*),         intent(out) ::  ermesg
integer,                  intent(out) ::  error

!----------------------------------------------------------------------
!   intent(in) variables:
!
!        sou1          in-cloud source of tracer at bottom of layer 
!                      [ kg / kg(air) / sec ]  
!        sou2          in-cloud source of tracer at top of layer 
!                      [ kg / kg(air) / sec ]  
!        xe1           environmental tracer concentration at bottom of
!                      layer [ kg / kg(air) ]
!        xe2           environmental tracer concentration at top of
!                      layer [ kg / kg(air) ]
!        xc1           in-cloud tracer concentration at bottom of
!                      layer [ kg / kg(air) ]
!        entrain       entrainment factor [ dimensionless ]
!        dt_micro      microphysics time step
!        debug_ijt     is this a diagnostics column ?
!        diag_unit     output unit number for this diagnostics column
!
!   intent(out) variables:
!
!        xc2           in-cloud tracer concentration at top of
!                      layer [ kg / kg(air) ]
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real    ::  xeb        ! layer-average environmental value of 
                             ! tracer n  [ kg / kg(air) ]
      real    ::  seb        ! layer-average source for tracer n
                             ! [ kg / kg(air) / sec ]
      real    ::  mass_ratio ! ratio of entraining parcel mass at top
                             ! of layer to that at bottom 
                             ! [ dimensionless ]
      real    ::  delta_m    ! fractional amount of mass added to 
                             ! parcel in current model layer 
                             ! [ dimensionless ]
      integer ::  n          ! do-loop index

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!-----------------------------------------------------------------------
!    if in diagnostics column, print out an entry message.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a)') 'in clotr: entering clotr'
      endif

!---------------------------------------------------------------------
!    define ratio of parcel mass at top of layer to that at bottom 
!    (mass_ratio) and the increase in parcel mass across the layer.
!---------------------------------------------------------------------
      mass_ratio = exp(entrain)
      delta_m = mass_ratio - 1.0

!----------------------------------------------------------------------
!    loop over the tracers transported by donner convection.
!----------------------------------------------------------------------
      do n=1,ntr             

!---------------------------------------------------------------------
!    define layer-mean environmental tracer (xeb) and the tracer source 
!    (seb).
!---------------------------------------------------------------------
        xeb = 0.5*(xe1(n) + xe2(n))
        seb = 0.5*(sou1(n) + sou2(n))

!--------------------------------------------------------------------
!    define in-cloud tracer amount at top of layer (xc2) as the sum of 
!    the value at bottom of layer (xc1) plus the amount of environ-
!    mental tracer entrained into the parcel plus the amount produced
!    by the internal source (seb). the time of insertion of the internal
!    source is given by tr_insert_time (in terms of parcel's mass 
!    increase during its traversal of the layer). if source is assumed
!    to be made available at bottom of layer (tr_insert_time = 0), then
!    seb is unmodified; if not available until completion of traversal,
!    then tr_insert_time is 1.0, and amount supplied is reduced by the
!    ratio of parcel mass between layer top and bottom. renormalize the
!    mixing ratio by the total parcel mass at the top of the layer.
!!! BUG :: seb must be multiplied by dt (perhaps as wv/dz ???)
!!!  BUG FIXED 6/2/05
!!!! BUG :: shouldn't the 1 + epm*(   ) be divided into seb  ????
!--------------------------------------------------------------------
        xc2(n) = (xc1(n) + delta_m*xeb + seb*dt_micro*   &
                              (1. + Param%tr_insert_time*delta_m))/mass_ratio 

!--------------------------------------------------------------------
!    assure that the in-cloud tracer mixing ratio is non-negative.
!--------------------------------------------------------------------
        if (xc2(n) < 0.) xc2(n) = 0.

!--------------------------------------------------------------------
!    if in diagnostics column, output the tracer mixing ratio at top
!    of layer (xc2), the layer-mean environmental tracer mixing ratio
!    (xeb) and the layer-mean tracer source (seb).
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, e20.12)')   &
           'in clotr: xc= ',xc2(n)
          write (diag_unit, '(a, e20.12)')   &
               'in clotr: xeb= ',xeb
          write (diag_unit, '(a, e20.12)')   &
               'in clotr: seb= ',seb
        endif
      end do

!--------------------------------------------------------------------


end subroutine don_cm_clotr_k

!#######################################################################



                       module donner_deep_mod

use donner_types_mod,       only: donner_initialized_type, &
                                  donner_save_type, donner_rad_type, &
                                  donner_nml_type, donner_param_type, &
                                  donner_budgets_type, &
                                  donner_column_diag_type, &
                                  MAXMAG, MAXVAL, MINMAG, MINVAL, &
                                  DET_MASS_FLUX, MASS_FLUX,  &
                                  CELL_UPWARD_MASS_FLUX, TEMP_FORCING, &
                                  MOIST_FORCING, PRECIP,  FREEZING, &
                                  RADON_TEND, &
                                  donner_conv_type, donner_cape_type, &
                                  donner_cem_type
use  conv_utilities_k_mod,  only: sd_init_k, sd_end_k, ac_init_k,  &
                                  ac_end_k, uw_params_init_k, &
                                  exn_init_k, exn_end_k, findt_init_k, &
                                  findt_end_k, &
                                  adicloud, sounding, uw_params
use  conv_plumes_k_mod,     only: cp_init_k, cp_end_k, ct_init_k,  &
                                  ct_end_k, cplume, ctend
use fms_donner_mod,         only: fms_donner_process_nml,   &
                                  fms_donner_process_tracers, &
                                  fms_donner_activate_diagnostics, &
                                  fms_donner_col_diag, &
                                  fms_donner_column_control, &
                                  fms_donner_read_restart, &
                                  fms_donner_write_restart, &
                                  fms_donner_deep_netcdf, &
                                  fms_get_pe_number, &
                                  fms_sat_vapor_pres, &
                                  fms_error_mesg, fms_constants, &
                                  fms_close_col_diag_units, &
                                  fms_deallocate_variables, &
                                  fms_donner_process_monitors
use nonfms_donner_mod,      only: nonfms_donner_process_nml,   &
                                  nonfms_donner_process_tracers, &
                                  nonfms_donner_activate_diag, &
                                  nonfms_donner_col_diag, &
                                  nonfms_donner_column_control, &
                                  nonfms_donner_read_restart, &
                                  nonfms_donner_write_restart, &
                                  nonfms_donner_deep_netcdf, &
                                  nonfms_get_pe_number, &
                                  nonfms_sat_vapor_pres, &
                                  nonfms_error_mesg, nonfms_constants,&
                                  nonfms_deallocate_variables, &
                                  nonfms_donner_process_monitors, &
                                  nonfms_close_col_diag_units

implicit none
private

!--------------------------------------------------------------------
!        donner_deep_mod diagnoses the location and computes the 
!        effects of deep convection on the model atmosphere
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------


character(len=128)  :: version =  '$Id: donner_deep.F90,v 17.0.2.1.2.1.2.1.2.1 2010/03/17 20:27:07 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!--------------------------------------------------------------------
!---interfaces------

public   &
        donner_deep_init, donner_deep, donner_deep_end,  &
        donner_deep_restart, donner_deep_time_vary, donner_deep_endts

private   & 
        deallocate_variables


!---------------------------------------------------------------------
!---namelist----



!--------------------------------------------------------------------
!--- public data ----------




!--------------------------------------------------------------------
!----private data-----------



!---------------------------------------------------------------------
!  parameters stored in the donner_param derived type variable to facili-
!  tate passage to kernel subroutines:
!

integer,                   &
  parameter                  &
             ::  KPAR=7         
                        ! number of members in cumulus ensemble
integer,                   &
  parameter                  &
             ::  NLEV_HIRES=100       
                        ! number of levels in cloud model
real,                       &
  parameter                 &
             ::  PDEEP_CV = 500.e02 
                        ! minimum pressure difference between level of 
                        ! free convection and level of zero buoyancy 
                        ! needed for deep convection to occur [ Pa ].
real,                       &
  parameter                 &
             ::  MAX_ENTRAINMENT_CONSTANT_GATE = 0.0915
                        ! entrainment constant based on gate data for 
                        ! most entraining ensemble member
real,                       &
  parameter                 &
             ::  MAX_ENTRAINMENT_CONSTANT_KEP  = 0.0915
                        ! entrainment constant based on kep data for most
                        ! entraining ensemble member
real,                       &
  parameter,                 &
  dimension(KPAR)              &
             ::  ENSEMBLE_ENTRAIN_FACTORS_KEP  = (/ 1.0, 1.22, 1.56,  &
                                                    2.05, 2.6, 3.21,   &
                                                    7.84 /)
                        ! ratio of entrainment constant between ensemble
                        ! member 1 and ensemble member i for kep-based
                        ! ensemble
real,                       &
  parameter                 &
             ::  CLD_BASE_VERT_VEL = 0.5                          
                        ! vertical velocity assumed present at cloud base
                        ! [ m / sec ]
real,                       &
  parameter                 &
             ::  PSTOP = 40.0e02   
                        ! lowest possible pressure to which a cloud may 
                        ! extend in the cloud model [ Pa ]
real,                       &
  parameter                 &
             ::  PARCEL_DP = -1.0e02
                        ! pressure increment used for parcel calculations
                        ! [ Pa ]
real,                       &
  parameter                 &
             ::  UPPER_LIMIT_FOR_LFC = 500.e02 
                        ! lowest pressure allowed for level of free conv-
                        ! ection [ Pa ]
real,                       &
  parameter                 &
             ::  DP_OF_CLOUD_MODEL = -10.e02
                        ! pressure thickness (Pa) of the layers in the
                        ! donner parameterization's cloud model.
real,                       &
  parameter                 &
             ::  CLOUD_BASE_RADIUS = 1000.
                        ! radius assumed for cloud ensemble member #1 at
                        ! cloud base [ m ]
real,                       &
  parameter                 &
             ::  WDET = .1   
                        ! vertical velocity at which detrainment from the
                        ! clouds begins [ m/s ]
real,                       &
  parameter                 &
             ::  RBOUND = 0.01    
                        ! value of cumulus radius at which cloud effect-
                        ! ively disappears and cloud model calculation 
                        ! stops [ m ]
real,                       &
  parameter                 &
             ::  WBOUND = 0.01  
                        ! value of cumulus vertical velocity at which 
                        ! cloud model calculation stops [ m / sec ]
real,                       &
  parameter                 &
             ::  FREEZE_FRACTION = 0.52
                        ! fraction of liquid in cloud updraft which may 
                        ! be frozen. (Leary and Houze (JAS,1980)) 
                        ! [ dimensionless ]
real,                       &
  parameter                 &
             ::  VIRT_MASS_CO = 0.5
                        ! virtual mass coefficient [ dimensionless ]
real,                       &
  parameter                 &
             ::  PDEEP_MC = 200.e02 
                        ! pressure thickness [ Pa ] required for meso-
                        ! scale circulation. It refers to the least
                        ! penetrative ensemble member. For this check 
                        ! to function properly, the entrainment coeffic-
                        ! ient in cloud_model for kou=1 must be the 
                        ! largest entrainment coefficient.
real,                       &
  parameter                 &
             ::  TR_INSERT_TIME = 0.0
                        ! fractional point (based on mass increase) 
                        ! during a timestep at which an entraining parcel
                        ! takes on internally-generated tracer 
                        ! [ dimensionless, value between 0.0 and 1.0 ]
real,                       &
  parameter                 &
             ::  AUTOCONV_RATE = 1.0e-03
                        ! rate of autoconversion of cloud to rainwater 
                        ! [ sec**(-1) ]
real,                       &
  parameter                 &
             ::  AUTOCONV_THRESHOLD =  0.5    
                        ! threshold of cloud water at which autoconver-
                        ! sion of cloud to rainwater begins  [ g / m**3 ]
real,                       &
  parameter                 &
             ::  TFRE = 258.  
                        ! temperature at which cloud liquid begins to 
                        ! freeze [ deg K ]
real,                       &
  parameter                 &
             ::  DFRE = 10.   
                        ! range of temperature between the onset and 
                        ! completion of freezing  [ deg K ]
real,                       &
  parameter                 &
             ::  UPPER_LIMIT_FOR_LCL = 500.0E02
                        ! lowest pressure allowable for lifting condens-
                        ! ation level; deep convection will not be pres-
                        ! ent if lcl not reached before this pressure 
                        ! [ Pa ]
integer,                   &
  parameter         &
             ::  ISTART = 1    
                        ! index of level in cape grid from which the 
                        ! parcel originates for the cape calculations
real,                       &
  parameter                 &
             ::  TMIN = 154.       
                        ! cape calculations are terminated when parcel 
                        ! temperature goes below TMIN [ deg K ]
real,                       &
  parameter                 &
             ::  MESO_LIFETIME = 64800.
                        ! assumed lifetime of mesoscale circulation 
                        ! (from Leary and Louze, 1980) [ sec ]
real,                       &
  parameter                 &
             ::  MESO_REF_OMEGA = -0.463
                        ! assumed reference omega for mesoscale updraft 
                        ! (from Leary and Louze, 1980) [ Pa / sec ]
real,                       &
  parameter                 &
             ::  TPRIME_MESO_UPDRFT = 1.0    
                        ! assumed temperature excess of mesoscale updraft
                        ! over its environment [ deg K ]
real,                       &
  parameter                 &
             ::  MESO_SEP = 200.0E+02
                        ! pressure separation between base of mesoscale
                        ! updraft and top of mesoscale downdraft [ Pa ]
real,                       &
  parameter                 &
             ::  REF_PRESS = 1.0E05
                        ! reference pressure used in calculation of exner
                        ! fumction [ Pa ]
real,                       &
  parameter                 &
             ::  R_CONV_LAND  = 10.0    
                        ! assumed convective cloud droplet radius over 
                        ! land [ microns ]   
real,                       &
  parameter                 &
             ::  R_CONV_OCEAN = 16.0  
                        ! assumed convective cloud droplet radius over 
                        ! ocean [ microns ]   
real,                       &
  parameter                 &
             ::  N_LAND = 600*1.0e6 
                        ! assumed droplet number conc over land (m**-3)
real,                       &
  parameter                 &
             ::  N_OCEAN = 150*1.0e6 
                        ! assumed droplet number conc over ocean (m**-3)
real,                       &
  parameter                 &
             ::  DELZ_LAND = 500.0   
                        ! assumed cloud depth over land (m) 
real,                       &
  parameter                 &
             ::  DELZ_OCEAN = 1500.0   
                        ! assumed cloud depth over ocean (m)
real,                       &
  parameter                 &
             ::  CELL_LIQUID_EFF_DIAM_DEF = 15.0    
                        ! default cell liquid eff diameter [ microns ]
real,                       &
  parameter                 &
             ::  CELL_ICE_GENEFF_DIAM_DEF = 18.6   
                        ! default cell ice generalized effective diameter
                        ! [ microns ]
integer,                   &
  parameter         &
             ::  ANVIL_LEVELS = 6  
                        ! number of levels assumed to be in anvil clouds
real,                       &
  parameter,                &
  dimension(ANVIL_LEVELS)   &
             ::  DGEICE  = (/ 38.5, 30.72, 28.28, 25.62, 24.8, 13.3 /)
                        ! generalized effective size of hexagonal ice 
                        ! crystals, defined as in Fu (1996, J. Clim.) 
                        ! values from Table 2 of McFarquhar et al. 
                        ! (1999, JGR) are averaged over all grid boxes 
                        ! for which D_ge is defined for all altitudes 
                        ! between 9.9 and 13.2 km. index 1 at bottom of 
                        ! anvil
real,                       &
  parameter,                &
  dimension(ANVIL_LEVELS)   &
             ::  RELHT  =  (/0.0, 0.3, 0.45, 0.64, 0.76, 1.0/)
                        ! distance from anvil base, normalized by total 
                        ! anvil thickness. from Table 2 of McFarquhar et
                        ! al. (1999, JGR) for grid boxes with data 
                        ! between 9.9 and 13.2 km. index 1 at anvil 
                        ! bottom

integer,                      &
  parameter                   &
             ::  N_WATER_BUDGET = 9
                        ! number of terms in vapor budget

integer,                      &
  parameter                   &
             ::  N_ENTHALPY_BUDGET =  19 
                        ! number of terms in enthalpy budget

integer,               &
  parameter            &
             ::  N_PRECIP_PATHS = 5
                        ! number of paths precip may take from 
                        ! condensing until it reaches the ground
                        ! (liquid; liquid which freezes; liquid which
                        ! freezes and then remelts; ice; ice which 
                        ! melts)

integer,               &
  parameter            &
             ::  N_PRECIP_TYPES = 3
                        ! number of precip types (cell, cell condensate
                        ! tranmsferred to mesoscale circulation,
                        ! mesoscale condensation and deposition)





!---------------------------------------------------------------------
!    derived type variables present for duration of job:
!    (see donner_types.h for documentation of their contents)
!

type(donner_param_type),       save :: Param
type(donner_column_diag_type), save :: Col_diag
type(donner_nml_type),         save :: Nml
type(donner_save_type),        save :: Don_save
type(donner_initialized_type), save :: Initialized
 
type(uw_params),               save :: Uw_p

logical                             :: calc_conv_on_this_step

!-----------------------------------------------------------------------
!   miscellaneous variables
!
!     module_is_initialized       module has been initialized ?
!

logical :: module_is_initialized = .false. 


logical :: running_in_fms = .true.

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------


                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                   PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#####################################################################

subroutine donner_deep_init (lonb, latb, pref, axes, secs, days, &
                             tracers_in_donner, do_conservation_checks,&
                             using_unified_closure, using_fms_code)

!---------------------------------------------------------------------
!    donner_deep_init is the constructor for donner_deep_mod.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
real,            dimension(:,:), intent(in)   :: lonb, latb
real,            dimension(:),   intent(in)   :: pref
integer,         dimension(4),   intent(in)   :: axes
integer,                         intent(in)   :: secs, days
logical,         dimension(:),   intent(in)   :: tracers_in_donner
logical,                         intent(in)   :: do_conservation_checks
logical,                         intent(in)   :: using_unified_closure
logical,                         intent(in), optional :: &
                                                 using_fms_code

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      lonb         array of model longitudes on cell corners     
!                   [ radians ]
!      latb         array of model latitudes on cell corners   
!                   [ radians ]
!      pref         array of reference pressures at full levels (plus 
!                   surface value at nlev+1), based on 1013.25 hPa pstar
!                   [ Pa ]
!      axes         data axes for diagnostics
!      Time         current time [ time_type ]
!      tracers_in_donner 
!                   logical array indicating which of the activated 
!                   tracers are to be transported by donner_deep_mod
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

      integer                             :: idf, jdf, nlev, ntracers
      character(len=200)                  :: ermesg
      integer                             :: erflag
      integer                             :: me, root_pe
  
!-------------------------------------------------------------------
!  local variables:
!
!     idf                    number of columns in the x dimension on the
!                            processors domain
!     jdf                    number of columns in the y dimension on the
!                            processors domain
!     nlev                   number of model layers 
!     ntracers               number of tracers to be transported by
!                            the donner deep convection parameterization
!                         
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!    initialize error message and error flag.
!-------------------------------------------------------------------
      ermesg = '  '
      erflag = 0

!---------------------------------------------------------------------
!    define variable to indicated whether this module is being executed
!    within the FMS infrastructure. by default it is.
!---------------------------------------------------------------------
      if (present (using_fms_code)) then
        if ( .not. using_fms_code) then
          running_in_fms = .false.
        endif
      endif

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    1. READ NAMELIST AND WRITE IT TO LOG FILE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      if (running_in_fms) then
        call fms_donner_process_nml (Nml, kpar)
      else 

!---------------------------------------------------------------------
!    for the nonfms case, appropriate code to read the namelist should 
!    be included in nonfms_process_nml.  the current routine (without 
!    such code) modifies nml values with source assignment statements,
!    as needed.
!---------------------------------------------------------------------
        call nonfms_donner_process_nml (Nml, kpar)
      endif 

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    2. DO CONSISTENCY / VALIDITY TESTS ON NML AND PARAMETER VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      if (Nml%do_donner_plume) then
        Nml%do_hires_cape_for_closure = .true.
      endif
 
      if (.not. Nml%do_donner_cape .and. &
           Nml%rmuz_for_cape /= 0.0) then
        erflag = 1
        ermesg =  'donner_deep_init: &
            &  a non-zero rmuz_for_cape is allowed only when &
            & do_donner_cape is true'
      endif

      if (Nml%do_donner_cape .and.     &
           .not. Nml%do_hires_cape_for_closure) then
        erflag = 1
        ermesg =  'donner_deep_init: &
            & do_hires_cape_for_closure must be .true. when &
            & do_donner_cape is true'
      endif

      if (.not. (Nml%do_donner_cape) .and.  &
           .not. (Nml%do_hires_cape_for_closure)) then

        if (Nml%rmuz_for_closure /= 0.0) then
          erflag = 1
          ermesg =  'donner_deep_init: &
          &  a non-zero rmuz_for_closure is currently implemented &
          & only for the hi-res cape closure calculation'
        endif
 
        if (trim(Nml%entrainment_scheme_for_closure) /= 'none') then
          erflag = 1
          ermesg =  'donner_deep_init: &
          &  entrainment in the closure calculation is currently &
           & implemented only for the hi-res cape closure calculation'
        endif
              
        if (Nml%modify_closure_plume_condensate ) then
          erflag = 1
          ermesg =  'donner_deep_init: &
          &  condensate modification in the closure calculation is &
          & currently implemented only for the hi-res cape closure &
          & calculation'
        endif
              
        if (Nml%closure_plume_condensate /= -999. ) then
          erflag = 1
          ermesg =  'donner_deep_init: &
          &  condensate modification in the closure calculation is &
          & currently implemented only for the hi-res cape closure &
          & calculation'
        endif
      endif
              
      if (Nml%do_donner_cape .and. Nml%gama /= 0.0) then
        erflag = 1
        ermesg =  'donner_deep_init: &
            & gama must be 0.0 if do_donner_cape is .true.; code for &
            & gama /=  0.0 not yet implemented'
      endif
      if (Nml%deep_closure /= 0 .and. Nml%deep_closure /= 1 ) then
        erflag = 1
        ermesg =  'donner_deep_init: &
              & deep_closure must be 0 or 1; code for &
              & cu_clo_miz not yet implemented'
      endif
      if (Nml%do_rh_trig .and. Nml%do_donner_closure) then
        erflag = 1
        ermesg =  'donner_deep_init: &
             & do_rh_trig must be .false. for donner full  &
               &parameterization; its use not yet implemented'
      endif

!---------------------------------------------------------------------
!    check for a valid value of donner_deep_freq. 
!---------------------------------------------------------------------
      if (Nml%donner_deep_freq > 86400) then
        erflag = 1
        ermesg = 'donner_deep_init: &
         & donner convection must be called at least once per day'
      else if (Nml%donner_deep_freq <= 0) then
        erflag = 1
        ermesg = 'donner_deep_init: &
          & a positive value must be assigned to donner_deep_freq'
      endif

!---------------------------------------------------------------------
!    check for valid value of entrainment_constant_source.
!---------------------------------------------------------------------
      if (trim(Nml%entrainment_constant_source) == 'gate' .or. &
          trim(Nml%entrainment_constant_source) == 'kep' ) then
      else
        erflag = 1
        ermesg = 'donner_deep_init: &
         & invalid string for nml variable entrainment_constant_source'
      endif

!---------------------------------------------------------------------
!    test that PSTOP is smaller than UPPER_LIMIT_FOR_LFC.
!---------------------------------------------------------------------
      if (pstop > upper_limit_for_lfc) then
        erflag = 1
        ermesg = 'donner_deep_init: &
           & pstop must be above the upper limit of &
                                &the level of free convection'
      endif

!---------------------------------------------------------------------
!    test that cell_liquid_size_type has been validly specified, and if
!    it is specified as 'input', an appropriate input value has been
!    supplied.
!---------------------------------------------------------------------
      if (trim(Nml%cell_liquid_size_type) == 'input') then
        Initialized%do_input_cell_liquid_size = .true.
        Initialized%do_bower_cell_liquid_size = .false.
        if (Nml%cell_liquid_eff_diam_input < 0.0) then
          erflag = 1
          ermesg = 'donner_deep_init: &
            & cell liquid size must be input, but no value supplied'
        endif
      else if (trim(Nml%cell_liquid_size_type) == 'bower') then
        Initialized%do_input_cell_liquid_size = .false.
        Initialized%do_bower_cell_liquid_size = .true.
      else
        erflag = 1
        ermesg = 'donner_deep_init: &
           & cell_liquid_size_type must be either input or bower'
      endif

!---------------------------------------------------------------------
!    test that cell_ice_size_type has been validly specified, and if
!    specified as 'input', that cell_ice_geneff_diam_input has also 
!    been appropriately defined.
!---------------------------------------------------------------------
      if (trim(Nml%cell_ice_size_type) == 'input') then
        Initialized%do_input_cell_ice_size = .true.
        Initialized%do_default_cell_ice_size = .false.
        if (Nml%cell_ice_geneff_diam_input <= 0.0) then
          erflag = 1
          ermesg  =  'donner_deep_init: must define a '// &
                     'nonnegative generalized effective'// &
                     'diameter for ice when cell_ice_size_type is input'
        endif
      else if (trim(Nml%cell_ice_size_type) == 'default') then
        Initialized%do_input_cell_ice_size = .false.
        Initialized%do_default_cell_ice_size = .true.
      else
        erflag = 1
        ermesg =  'donner_deep_init: cell_ice_size_type must ' //  &
                  'be input or default'
      endif

!---------------------------------------------------------------------
!    check for consistency between entrainment used in closure 
!    calculation. define logical indicating whether entrainment
!    coefficient is to be constant or ht-dependent.
!---------------------------------------------------------------------
      if (trim(Nml%entrainment_scheme_for_closure) == 'none' .and. &
                               Nml%rmuz_for_closure /= 0.0) then 
        erflag = 1
        ermesg = 'donner_deep_init: do not specify a non-zero ' // &
                  'rmuz_for_closure when no entrainment is desired'
      endif
      if (trim(Nml%entrainment_scheme_for_closure) ==    &
                                                 'ht-dependent' .and. &
                               Nml%rmuz_for_closure == 0.0) then 
        erflag = 1
        ermesg = 'donner_deep_init: must specify rmuz_for_closure ' // &
                  'when ht-dependent entrainment is desired'
      endif
      if (trim(Nml%entrainment_scheme_for_closure) ==    &
                                                 'ht-dependent' ) then
        Initialized%use_constant_rmuz_for_closure = .false.
      else
        Initialized%use_constant_rmuz_for_closure = .true.
      endif

!---------------------------------------------------------------------
!    check that if the closure plume condensate is to be modified that
!    a value is given.
!---------------------------------------------------------------------
      if (Nml%modify_closure_plume_condensate .and. &
          Nml%closure_plume_condensate == -999.) then
        erflag = 1
        ermesg = 'donner_deep_init: must specify ' // &
              'closure_plume_condensate when modification is requested'
      endif
        
!---------------------------------------------------------------------
!    if any errors were encountered, process them.
!---------------------------------------------------------------------
      if (erflag /= 0) then
        if (running_in_fms) then
          call fms_error_mesg (ermesg) 
        else

!---------------------------------------------------------------------
!    appropriate error processing code should be added in subroutine
!    nonfms_error_mesg. currently an error message is printed and a 
!    stop command issued (dangerous on parallel machines!).
!---------------------------------------------------------------------
          call nonfms_error_mesg (ermesg) 
        endif
      endif

!---------------------------------------------------------------------
!    place the logical input argument indicating whether the cloud 
!    base mass flux calculated by uw_conv_mod is also to be used 
!    in defining the closure for donner deep convection in the 
!    donner_initialized_type variable Initialized.
!    place the conservation check flag in the Initialized variable.
!---------------------------------------------------------------------
      Initialized%using_unified_closure = using_unified_closure
      Initialized%do_conservation_checks = do_conservation_checks

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    3. PROCESS TRACERS THAT ARE TO BE TRANSPORTED BY THE DONNER DEEP
!       CONVECTION PARAMETERIZATION.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!---------------------------------------------------------------------
!    determine how many tracers are to be transported by donner_deep 
!    convection. allocate arrays to contain their names and units for use
!    with diagnostics and restarts. define a logical variable indicating
!    if any tracers are to be so transported. obtain the tracer names and
!    units.
!---------------------------------------------------------------------
      ntracers = count(tracers_in_donner)
      allocate ( Don_save%tracername   (ntracers) )
      allocate ( Don_save%tracer_units (ntracers) )
      allocate ( Initialized%wetdep(ntracers) )
      if (ntracers > 0) then
        if (running_in_fms) then
          call fms_donner_process_tracers (Initialized,  &
                                           tracers_in_donner, Don_save)
        else 

!----------------------------------------------------------------------
!    currently tracers are not supported in the nonfms case. if it is
!    desired to transport tracers with donner convection, then the
!    subroutine nonfms_donner_process_tracers should be set up to mimic
!    the functionality of fms_donner_process_tracers for each tracer
!    thus transported (see subroutine fms_donner_process_tracers in 
!    fms_donner.F90).
!----------------------------------------------------------------------
          call nonfms_donner_process_tracers 
        endif 
      else
        Initialized%do_donner_tracer = .false.
      endif
      

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    4. DEFINE PROCESSOR DIMENSIONS AND ALLOCATE SPACE FOR MODULE 
!       VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!-------------------------------------------------------------------
!    define the grid dimensions. idf and jdf are the (i,j) dimensions of
!    the domain on this processor, nlev is the number of model layers.
!-------------------------------------------------------------------
      nlev = size(pref(:)) - 1
      idf  = size(lonb,1) - 1
      jdf  = size(latb,2) - 1

!--------------------------------------------------------------------
!    allocate module variables that will be saved across timesteps.
!    these are stored in the derived-type variable Don_save. see 
!    donner_types.h for description of these variables.
!--------------------------------------------------------------------
      allocate ( Don_save%cemetf             (idf, jdf, nlev ) )
      allocate ( Don_save%lag_temp           (idf, jdf, nlev ) )
      allocate ( Don_save%lag_vapor          (idf, jdf, nlev ) )
      allocate ( Don_save%lag_press          (idf, jdf, nlev ) )
      allocate ( Don_save%cememf             (idf, jdf, nlev ) )
      allocate ( Don_save%mass_flux          (idf, jdf, nlev ) )
      allocate ( Don_save%mflux_up           (idf, jdf, nlev ) )
      allocate ( Don_save%cell_up_mass_flux  (idf, jdf, nlev+1 ) )
      allocate ( Don_save%det_mass_flux      (idf, jdf, nlev ) )
      allocate ( Don_save%dql_strat          (idf, jdf, nlev ) )
      allocate ( Don_save%dqi_strat          (idf, jdf, nlev ) )
      allocate ( Don_save%dqa_strat          (idf, jdf, nlev ) )
      allocate ( Don_save%humidity_area      (idf, jdf, nlev ) )
      allocate ( Don_save%humidity_factor    (idf, jdf, nlev ) )
      allocate ( Don_save%tracer_tends       (idf, jdf, nlev, ntracers))
      allocate ( Don_save%parcel_disp        (idf, jdf ) )
      allocate ( Don_save%tprea1             (idf, jdf ) )

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    4. INITIALIZE THE NETCDF OUTPUT VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!--------------------------------------------------------------------
!    activate the netcdf diagnostic fields.
!-------------------------------------------------------------------
      if (running_in_fms) then
        call fms_donner_activate_diagnostics (secs, days, axes, &
                  Don_save, Nml, n_water_budget, n_enthalpy_budget, &
                  n_precip_paths, n_precip_types, nlev_hires, kpar)
      else

!---------------------------------------------------------------------
!    subroutine  nonfms_donner_activate_diagnostics should be set up
!    to initialize the procedure needed to output netcdf variable
!    fields in the nonFMS model. by default, it currently does nothing.
!---------------------------------------------------------------------
        call nonfms_donner_activate_diag (secs, days, axes, &
                  Don_save, Nml, n_water_budget, n_enthalpy_budget, &
                  n_precip_paths, n_precip_types, nlev_hires, kpar)
      endif

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    5. PROCESS THE RESTART FILE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      if (running_in_fms) then
        call fms_donner_read_restart (Initialized, ntracers,   &
                                      secs, days, Don_save, Nml)
      else

!---------------------------------------------------------------------
!    subroutine nonfms_donner_read_restart should be set up to handle 
!    the reading of the donner_deep.res.nc file in the nonFMS framework.
!    by default, it begins the model run from a coldstart.
!---------------------------------------------------------------------
        call nonfms_donner_read_restart (Initialized, ntracers,   &
                                      secs, days, Don_save, Nml)
      endif

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    6. INITIALIZE VARIABLES NEEDED FOR COLUMN_DIAGNOSTICS_MOD OUTPUT.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      if (running_in_fms) then
        call fms_donner_col_diag     (lonb, latb, Col_diag, pref)    
      else

!---------------------------------------------------------------------
!    subroutine nonfms_donner_col_diag should be set up to process
!    the column diagnostic output available from donner_deep_mod in 
!    the nonFMS framework. by default, it currently sets variables to
!    disallow that option; if that option is desired, the functionality
!    of fms_donner_col_diag needs to be added to that subroutine.
!---------------------------------------------------------------------
        call nonfms_donner_col_diag     (lonb, latb, Col_diag, pref)   
      endif

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    7. FILL THE DONNER_PARAM_TYPE VARIABLE WITH VALUES THAT HAVE BEEN 
!       DEFINED HERE.                  
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!----------------------------------------------------------------------
!    define the components of Param that come from constants_mod. see 
!    donner_types.h for their definitions.
!----------------------------------------------------------------------
      if (running_in_fms) then
        call fms_constants (Param)
      else

!---------------------------------------------------------------------
!    subroutine nonfms_constants is designed to obtain model constants
!    and place them in the donner_param_type variable Param. currently
!    values are assigned to them in this subroutine; this process should
!    be modified so that these constants are obtained from their natural
!    location in the nonFMS model.
!---------------------------------------------------------------------
        call nonfms_constants (Param)
      endif


!----------------------------------------------------------------------
!    store the parameters defined in this module into the 
!    donner_parameter_type variables Param. these variables are defined
!    above.
!----------------------------------------------------------------------
      Param%cp_vapor                = 4.0*Param%rvgas
      Param%parcel_dp               = PARCEL_DP
      Param%upper_limit_for_lfc     = UPPER_LIMIT_FOR_LFC
      Param%pstop                   = PSTOP
      Param%cld_base_vert_vel       = CLD_BASE_VERT_VEL
      Param%dp_of_cloud_model       = DP_OF_CLOUD_MODEL
      Param%cloud_base_radius       = CLOUD_BASE_RADIUS
      Param%wdet                    = WDET
      Param%rbound                  = RBOUND
      Param%wbound                  = WBOUND
      Param%freeze_fraction         = FREEZE_FRACTION
      Param%virt_mass_co            = VIRT_MASS_CO
      Param%pdeep_mc                = PDEEP_MC
      Param%tr_insert_time          = TR_INSERT_TIME
      Param%autoconv_rate           = AUTOCONV_RATE
      Param%autoconv_threshold      = AUTOCONV_THRESHOLD
      Param%tfre                    = TFRE
      Param%dfre                    = DFRE
      Param%evap_in_downdrafts      = Nml%EVAP_IN_DOWNDRAFTS
      Param%evap_in_environ         = Nml%EVAP_IN_ENVIRON      
      Param%entrained_into_meso     = Nml%ENTRAINED_INTO_MESO
      Param%d622                    = Param%rdgas/Param%rvgas
      Param%d608                    = Param%rvgas/Param%rdgas - 1.0
      Param%upper_limit_for_lcl     = UPPER_LIMIT_FOR_LCL
      Param%tmin                    = TMIN
      Param%anvil_precip_efficiency = Nml%ANVIL_PRECIP_EFFICIENCY
      Param%meso_lifetime           = MESO_LIFETIME
      Param%meso_ref_omega          = MESO_REF_OMEGA
      Param%tprime_meso_updrft      = TPRIME_MESO_UPDRFT
      Param%meso_sep                = MESO_SEP
      Param%ref_press               = REF_PRESS
      Param%meso_down_evap_fraction = Nml%MESO_DOWN_EVAP_FRACTION
      Param%meso_up_evap_fraction   = Nml%MESO_UP_EVAP_FRACTION
      Param%istart                  = ISTART

      Param%max_entrainment_constant_gate =   &
                                           MAX_ENTRAINMENT_CONSTANT_GATE
      Param%max_entrainment_constant_kep  = MAX_ENTRAINMENT_CONSTANT_KEP
      Param%pdeep_cv                      = PDEEP_CV
      Param%cdeep_cv                      = Nml%CDEEP_CV
      Param%kpar                          = KPAR
      Param%r_conv_land                   = R_CONV_LAND
      Param%r_conv_ocean                  = R_CONV_OCEAN 
      Param%n_land                        = N_LAND
      Param%n_ocean                       = N_OCEAN
      Param%delz_land                     = DELZ_LAND
      Param%delz_ocean                    = DELZ_OCEAN
      Param%cell_liquid_eff_diam_def      = CELL_LIQUID_EFF_DIAM_DEF 
      Param%cell_ice_geneff_diam_def      = CELL_ICE_GENEFF_DIAM_DEF
      Param%anvil_levels                  = ANVIL_LEVELS 

      allocate (Param%arat(kpar))
      allocate (Param%ensemble_entrain_factors_gate(kpar))
      allocate (Param%ensemble_entrain_factors_kep(kpar))
      Param%arat                          = Nml%ARAT
      Param%ensemble_entrain_factors_gate =   &
                                       Nml%ensemble_entrain_factors_gate
      Param%ensemble_entrain_factors_kep  = ENSEMBLE_ENTRAIN_FACTORS_KEP

      allocate (Param%dgeice (ANVIL_LEVELS))
      allocate (Param%relht  (ANVIL_LEVELS))
      Param%dgeice  = DGEICE               
      Param%relht   = RELHT                

!---------------------------------------------------------------------
!    initialize the kernelized modules needed outside of the donner 
!    directory.
!---------------------------------------------------------------------
      if (running_in_fms) then
        call fms_sat_vapor_pres
      else

!--------------------------------------------------------------------
!    this routine is reserved for any initialization involved with the
!    saturation vapor pressure calculation in the nonFMS model. For
!    test purposes, this routine currently uses the FMS routines, but
!    this should be changed to use the nonFMS model's procedures.
!--------------------------------------------------------------------
        call nonfms_sat_vapor_pres
      endif

      if (running_in_fms) then
        call fms_get_pe_number(me, root_pe)
      else

!---------------------------------------------------------------------
!    subroutine nonfms_get_pe_number should be set up to return the
!    current pe's number, if column daignostics are activated in the
!    nonFMS model. By default, the subroutine returns 0 for all pes.
!---------------------------------------------------------------------
        call nonfms_get_pe_number(me, root_pe)
      endif

      call uw_params_init_k (Param%hlv, Param%hls, Param%hlf, &
          Param%cp_air, Param%grav, Param%kappa, Param%rdgas,  &
          Param%ref_press, Param%d622,Param%d608, Param%kelvin -160., & 
          Param%kelvin + 100. , me, root_pe, Uw_p)


      call exn_init_k (Uw_p)
      call findt_init_k (Uw_p)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    9. SET UP CODE TO MONITOR SELECTED OUTPUT VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      if (running_in_fms) then
        call fms_donner_process_monitors (idf, jdf, nlev, ntracers, &
                               axes, secs, days, Initialized, Don_save)
      else

!---------------------------------------------------------------------
!    subroutine nonfms_donner_process_monitors should be set up to 
!    handle the processing of variable monitopr output, if that capa-
!    bility is desired. Currently the subroutine does nothing; see 
!    subroutine fms_donner_process_monitors in fms_donner.F90 for the
!    functionality required to activate this option.
!---------------------------------------------------------------------
        call nonfms_donner_process_monitors 
      endif

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!   10. END OF SUBROUTINE.

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!--------------------------------------------------------------------
!    set flag to indicate that donner_deep_mod has been initialized.
!--------------------------------------------------------------------
      module_is_initialized = .true.

!------------------------------------------------------------------



end subroutine donner_deep_init

!###################################################################
         
subroutine donner_deep_time_vary (dt)  
                                  
real, intent(in) :: dt

!--------------------------------------------------------------------
!    decrement the time remaining before the convection calculations. 
!    save the current model physics timestep.
!--------------------------------------------------------------------
      Initialized%conv_alarm  = Initialized%conv_alarm - int(dt)
      Initialized%physics_dt = int(dt)
 
!--------------------------------------------------------------------
!    set a flag to indicate whether the convection calculation is to be 
!    done on this timestep. if this is the first call to donner_deep 
!    (i.e., coldstart), convection cannot be calculated because the
!    lag profiles needed to calculate cape are unavailable, and so
!    a time tendency of cape can not be obtained. otherwise, it is a
!    calculation step or not dependent on whether the convection "alarm"
!    has gone off. 
!---------------------------------------------------------------------
      if (Initialized%coldstart) then
        calc_conv_on_this_step = .false.
      else
        if (Initialized%conv_alarm <= 0) then
          calc_conv_on_this_step = .true.
        else
          calc_conv_on_this_step = .false.
        endif
      endif

!--------------------------------------------------------------------


end subroutine donner_deep_time_vary



!###################################################################
 
subroutine donner_deep_endts

!---------------------------------------------------------------------
!    if this was the first time through the parameterization, set
!    the flag so indicating (coldstart) to be .false.. if this was a 
!    calculation step, set the alarm to define the next time at which 
!    donner convection is to be executed.
!----------------------------------------------------------------------
      if (Initialized%coldstart) Initialized%coldstart = .false.
      if (calc_conv_on_this_step) then
        Initialized%conv_alarm = Initialized%conv_alarm +    &
                                                 Nml%donner_deep_freq
      endif

!--------------------------------------------------------------------


end subroutine donner_deep_endts




!###################################################################

subroutine donner_deep (is, ie, js, je, dt, temp, mixing_ratio, pfull, &
                        phalf, zfull, zhalf, omega, pblht, tkemiz, &
                        qstar, cush, coldT, land, sfc_sh_flux,  &
                        sfc_vapor_flux, tr_flux, tracers, secs, days, &
                        cbmf, cell_cld_frac,  &
                        cell_liq_amt, cell_liq_size, cell_ice_amt,   &
                        cell_ice_size, cell_droplet_number, &
                        meso_cld_frac, meso_liq_amt, &
                        meso_liq_size, meso_ice_amt, meso_ice_size,  &
                        meso_droplet_number, &
                        nsum, precip, delta_temp, delta_vapor, detf, &
                        uceml_inter, mtot, mfluxup, mhalf_3d, &
                        donner_humidity_area,    &
                        donner_humidity_factor, qtrtnd, donner_wetdep,&
                        lheat_precip, vert_motion,        &
                        total_precip, liquid_precip, frozen_precip, &
                        frz_meso, liq_meso, frz_cell, liq_cell, &
                        qlin, qiin, qain,              &      ! optional
                        delta_ql, delta_qi, delta_qa)         ! optional
                        
!-------------------------------------------------------------------
!    donner_deep is the prognostic driver subroutine of donner_deep_mod.
!    it takes as input the temperature (temp), vapor mixing ratio 
!    (mixing_ratio), pressure at full and half-levels (pfull, phalf),
!    vertical velocity at full levels (omega), the large scale cloud 
!    variables (qlin, qiin, qain), the land fraction (land),  the heat 
!    (sfc_sh_flux) , moisture (sfc_vapor_flux) and tracer (tr_flux) 
!    fluxes across the surface that are to be seen by this parameter-
!    ization, the tracers to be transported by the donner convection
!    parameterization (tracers), and the current time (as time_type 
!    variable Time). the routine returns the precipitation (precip),
!    increments to the temperature (delta_temp) and mixing ratio 
!    (delta_vapor), the detrained mass flux (detf), upward cell mass 
!    flux at interface levels  (uceml_inter) and total mass flux at full
!    levels (mtot), two arrays needed to connect the donner convection 
!    and strat cloud parameterizations (donner_humidity_area, 
!    donner_humidity_ratio), increments to the cloudwater (delta_ql), 
!    cloudice (delta_qi) and cloud area (delta_qa) fields and tendencies
!    for those tracers that are to be transported by the donner convect-
!    ion parameterization (qtrtnd). there are an additional eleven arrays
!    defining the donner scheme cloud characteristics needed by the rad-
!    iation package, which are passed in and updated on donner calcul-
!    ation steps.
!-------------------------------------------------------------------

!--------------------------------------------------------------------
integer,                      intent(in)    :: is, ie, js, je
real,                         intent(in)    :: dt
real, dimension(:,:,:),       intent(in)    :: temp, mixing_ratio, &
                                               pfull, phalf, zfull, zhalf, omega
real, dimension(:,:),         intent(in)    :: pblht, tkemiz, qstar,cush
real, dimension(:,:),         intent(in)    :: land
logical, dimension(:,:),      intent(in)    :: coldT
real, dimension(:,:),         intent(in)    :: sfc_sh_flux, &
                                               sfc_vapor_flux
real, dimension(:,:,:),       intent(in)    :: tr_flux 
real, dimension(:,:,:,:),     intent(in)    :: tracers 
integer,                      intent(in)    :: secs, days
real, dimension(:,:),         intent(inout) :: cbmf              
real, dimension(:,:,:),       intent(inout) :: cell_cld_frac,  &
                                               cell_liq_amt,  &
                                               cell_liq_size, &
                                               cell_ice_amt,  &
                                               cell_ice_size, &
                                           cell_droplet_number, &
                                               meso_cld_frac,  &
                                               meso_liq_amt, &
                                               meso_liq_size, &
                                               meso_ice_amt,   &
                                               meso_ice_size, &
                                           meso_droplet_number
integer, dimension(:,:),      intent(inout) :: nsum
real, dimension(:,:),         intent(out)   :: precip, &
                                               lheat_precip, &
                                               vert_motion, &
                                               total_precip
real, dimension(:,:,:),       intent(out)   :: delta_temp, delta_vapor,&
                                               detf, uceml_inter, &
                                               mtot, mfluxup, &
                                               mhalf_3d, &
                                               donner_humidity_area,&
                                               donner_humidity_factor, &
                                               liquid_precip, &
                                               frozen_precip, frz_meso,&
                                            liq_meso, frz_cell, liq_cell
real, dimension(:,:,:,:),     intent(out)   :: qtrtnd 
real, dimension(:,:,:),       intent(out)   :: donner_wetdep
real, dimension(:,:,:),       intent(in),                &
                                   optional :: qlin, qiin, qain
real, dimension(:,:,:),       intent(out),               &
                                   optional :: delta_ql, delta_qi, &
                                               delta_qa

!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie         first and last values of i index values of points 
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points 
!                    in this physics window (processor coordinates)
!     dt             physics time step [ sec ]
!     temp           temperature field at model levels [ deg K ]
!     mixing_ratio   vapor mixing ratio field at model levels 
!                    [ kg(h20) / kg(dry air) ]
!     pfull          pressure field on model full levels [ Pa ]
!     phalf          pressure field at half-levels 1:nlev+1  [ Pa ]
!     omega          model omega field at model full levels [ Pa / sec ]
!     qlin           large-scale cloud liquid specific humidity 
!                    [ kg(h2o) / kg (moist air) ]
!     qiin           large-scale cloud ice specific humidity 
!                    [ kg(h2o) / kg (moist air) ]
!     qain           large-scale cloud fraction  
!                    [ fraction ]
!     land           fraction of grid box covered by land
!                    [ fraction ]
!     sfc_sh_flux    sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_vapor_flux water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     tr_flux        surface flux of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     tracers        tracer mixing ratios
!                    [ kg(tracer) / kg (dry air) ]
!     Time           current time (time_type)
!
!   intent(out) variables:
!
!     precip         precipitation generated by deep convection
!                    [ kg(h2o) / m**2 ]
!     delta_temp     temperature increment due to deep convection 
!                    [ deg K ]
!     delta_vapor    water vapor mixing ratio increment due to deep 
!                    convection [ kg(h2o) / kg (dry air) ]
!     detf           detrained cell mass flux at model levels 
!                    [ (kg / (m**2 sec) ) ]
!     uceml_inter    upward cell mass flux at interface levels 
!                    [ (kg / (m**2 sec) ) ]
!     mtot           mass flux at model full levels, convective plus 
!                    mesoscale, due to donner_deep_mod 
!                    [ (kg / (m**2 sec) ) ]
!     mfluxup        upward mass flux at model full levels, convective 
!                    plus mesoscale, due to donner_deep_mod 
!                    [ (kg / (m**2 sec) ) ]
!     donner_humidity_area
!                    fraction of grid box in which humidity is affected
!                    by the deep convection, defined as 0.0 below cloud
!                    base and above the mesoscale updraft, and as the
!                    sum of the cell and mesoscale cloud areas in 
!                    between. it is used in strat_cloud_mod to determine
!                    the large-scale specific humidity field for the
!                    grid box. DO NOT use for radiation calculation,
!                    since not all of this area includes condensate.
!                    [ fraction ]
!     donner_humidity_ratio
!                    ratio of large-scale specific humidity to specific 
!                    humidity in environment outside convective system
!                    [ dimensionless ]
!     delta_ql       cloud water specific humidity increment due to 
!                    deep convection over the timestep
!                    [ kg (h2o) / kg (moist air) ]
!     delta_qi       cloud ice specific humidity increment due to deep 
!                    convection over the timestep 
!                    [ kg (h2o) / kg (moist air) ]
!     delta_qa       cloud area increment due to deep convection
!                    over the time step [ fraction ]
!     qtrtnd         tracer time tendencies due to deep convection
!                    during the time step
!                    [ kg(tracer) / (kg (dry air) sec) ]
!
!   intent(inout) variables:
!
!     cell_cld_frac  fractional coverage of convective cells in
!                    grid box [ dimensionless ]
!     cell_liq_amt   liquid water content of convective cells
!                    [ kg(h2o) / kg(air) ]
!     cell_liq_size  assumed effective size of cell liquid drops
!                    [ microns ]
!     cell_ice_amt   ice water content of cells
!                    [ kg(h2o) / kg(air) ]
!     cell_ice_size  generalized effective diameter for ice in
!                    convective cells [ microns ]
!     meso_cld_frac  fractional area of mesoscale clouds in grid
!                    box [ dimensionless ]
!     meso_liq_amt   liquid water content in mesoscale clouds
!                    [ kg(h2o) / kg(air) ]
!     meso_liq_size  assumed effective size of mesoscale drops
!                    [ microns ]
!     meso_ice_amt   ice water content of mesoscale elements
!                    [ kg(h2o) / kg(air) ]
!     meso_ice_size  generalized ice effective size for anvil ice
!                    [ microns ]
!     nsum           number of time levels over which the above variables
!                    have so far been summed
!
!--------------------------------------------------------------------


!--------------------------------------------------------------------
!    local variables:

      real,    dimension (size(temp,1), size(temp,2), size(temp,3)) :: &
                       temperature_forcing, moisture_forcing, pmass, &
                       qlin_arg, qiin_arg, qain_arg, delta_ql_arg, & 
                       delta_qi_arg, delta_qa_arg

      real,    dimension (size(temp,1), size(temp,2)) :: parcel_rise, &
                                                         summa

      type(donner_conv_type)            :: Don_conv
      type(donner_budgets_type)         :: Don_budgets
      type(donner_cape_type)            :: Don_cape
      type(donner_rad_type)             :: Don_rad
      type(donner_cem_type)             :: Don_cem
      type(sounding)                    :: sd
      type(adicloud)                    :: ac
      type(cplume)                      :: cp
      type(ctend )                      :: ct
      character(len=128)                :: ermesg
      integer                           :: error
      integer                           :: isize, jsize, nlev_lsm
      integer                           :: ntr, me, root_pe
      logical                           :: cloud_tracers_present
      integer                           :: num_cld_tracers
      integer                           :: k, n   

!--------------------------------------------------------------------
!   local variables:
!
!     temperature_forcing  temperature tendency due to donner convection
!                          [ deg K / sec ]
!     moisture_forcing     vapor mixing ratio tendency due to donner 
!                          convection [ kg(h2o) / (kg(dry air) sec ) ]
!     pmass                mass per unit area within the grid box
!                          [ kg (air) / (m**2) ]
!     parcel_rise          accumulated vertical displacement of a 
!                          near-surface parcel as a result of the lowest
!                          model level omega field [ Pa ]
!     total_precip         total precipitation rate produced by the
!                          donner parameterization [ mm / day ]
!     exit_flag            logical array indicating whether deep conv-
!                          ection exists in a column
!     Don_conv             donner_convection_type derived type variable 
!                          containing diagnostics and intermediate
!                          results describing the nature of the convec-
!                          tion produced by the donner parameterization
!     Don_cape             donner_cape type derived type variable con-
!                          taining diagnostics and intermediate results
!                          related to the cape calculation associated 
!                          with the donner convection parameterization
!     Don_rad              donner_rad_type derived type variable used
!                          to hold those fields needed to connect the
!                          donner deep convection parameterization and
!                          the model radiation package
!     Don_cem              donner_cem_type derived type variable 
!                          containing Donner cumulus ensemble member 
!                          diagnostics
!     ermesg               character string containing any error message
!                          that is returned from a kernel subroutine
!     isize                x-direction size of the current physics window
!     isize, jsize         y-direction size of the current physics window
!     nlev_lsm             number of model layers in large-scale model
!     ntr                  number of tracers to be transported by donner
!                          convection 
!     me                   local pe number
!     calc_conv_on_this_step 
!                          is this a step on which to calculate 
!                          convection ?
!     k                    do-loop index
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    check that the module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized) then
         ermesg = 'donner_deep: &
             &donner_deep_init was not called before subroutine   &
                                                  &donner_deep'
        if (running_in_fms) then
          call fms_error_mesg (ermesg) 
        else

!---------------------------------------------------------------------
!    appropriate error processing code should be added in subroutine
!    nonfms_error_mesg. currently an error message is printed and a 
!    stop command issued (dangerous on parallel machines!).
!---------------------------------------------------------------------
          call nonfms_error_mesg (ermesg) 
        endif
      endif

!----------------------------------------------------------------------
!    determine if the arguments needed when run with the strat_cloud_mod 
!    are present; set cloud_tracers_present appropriately.
!----------------------------------------------------------------------
      num_cld_tracers = count( (/present(qlin), present(qiin),   &
                                 present(qain), present(delta_ql), &
                                 present(delta_qi),present(delta_qa)/) )
      if (num_cld_tracers == 0) then
        cloud_tracers_present = .false.
        qlin_arg = 0.
        qiin_arg = 0.
        qain_arg = 0.
      else if (num_cld_tracers == 6) then
        cloud_tracers_present = .true.
        qlin_arg = qlin 
        qiin_arg = qiin
        qain_arg = qain
      else
        ermesg = 'donner_deep: &
                        &Either none or all of the cloud tracers '// &
                         'and their tendencies must be present'
        if (running_in_fms) then
          call fms_error_mesg (ermesg) 
        else

!---------------------------------------------------------------------
!    appropriate error processing code should be added in subroutine
!    nonfms_error_mesg. currently an error message is printed and a 
!    stop command issued (dangerous on parallel machines!).
!---------------------------------------------------------------------
          call nonfms_error_mesg (ermesg) 
        endif
      endif

!--------------------------------------------------------------------
!    if column diagnostics have been requested for any column, call 
!    donner_column_control to define the components of the 
!    donner_column_diag_type variable for the diagnostic columns in this 
!    window. if column diagnostics have not been requested, the needed
!    variables so indicating have already been set.
!--------------------------------------------------------------------
      if (running_in_fms) then
        if (Col_diag%num_diag_pts > 0) then
          call fms_donner_column_control (is, ie, js, je, secs, days, &
                                          Col_diag)
        endif
      else

!---------------------------------------------------------------------
!    if column diagnostics are desired in the nonFMS model, subroutine
!    nonfms_donner_column_control must be modified to provide the
!    functionality of fms_donner_column_control. by default, column
!    diagnostics are not available with the nonFMS model.
!---------------------------------------------------------------------
        if (Col_diag%num_diag_pts > 0) then
          call nonfms_donner_column_control (is, ie, js, je, secs,  &
                                             days, Col_diag)
        endif
      endif

!-------------------------------------------------------------------
!    define the dimensions for the variables in this physics window.
!    define the pe number of the current pe.
!-------------------------------------------------------------------
      isize     = ie - is + 1
      jsize     = je - js + 1
      nlev_lsm  = size(temp,3)
      ntr       = size(tracers,4) 

      if (running_in_fms) then
        call fms_get_pe_number(me, root_pe)
      else

!---------------------------------------------------------------------
!    subroutine nonfms_get_pe_number should be set up to return the
!    current pe's number, if column daignostics are activated in the
!    nonFMS model. By default, the subroutine returns 0 for all pes.
!---------------------------------------------------------------------
        call nonfms_get_pe_number(me, root_pe)
      endif

      Don_budgets%n_water_budget      = N_WATER_BUDGET
      Don_budgets%n_enthalpy_budget   = N_ENTHALPY_BUDGET
      Don_budgets%n_precip_paths      = N_PRECIP_PATHS     
      Don_budgets%n_precip_types      = N_PRECIP_TYPES     

!-----------------------------------------------------------------------
!    call the kernel subroutine don_d_donner_deep_k to obtain the
!    output fields resulting from the donner deep convection parameter-
!    ization.
!-----------------------------------------------------------------------
      call don_d_donner_deep_k   &
           (is, ie, js, je, isize, jsize, nlev_lsm, NLEV_HIRES, ntr, me,&
            cloud_tracers_present,  cbmf,    &
            dt, Param, Nml, temp, mixing_ratio, pfull,    &
            phalf, zfull, zhalf, omega, pblht, tkemiz, qstar, cush, coldT,&
            qlin_arg, qiin_arg, qain_arg, land, sfc_sh_flux,  &
            sfc_vapor_flux,    &
            tr_flux, tracers, cell_cld_frac, cell_liq_amt,      &
            cell_liq_size, cell_ice_amt, cell_ice_size,   &
            cell_droplet_number, meso_cld_frac,  &
            meso_liq_amt, meso_liq_size, meso_ice_amt, meso_ice_size,  &
            meso_droplet_number, &
            nsum, precip, delta_temp, delta_vapor, detf, uceml_inter,  &
            mtot, mfluxup, donner_humidity_area,  &
            donner_humidity_factor, &
            total_precip, temperature_forcing, moisture_forcing,    &
            parcel_rise, delta_ql_arg, delta_qi_arg, delta_qa_arg,   &
            qtrtnd,         &
            calc_conv_on_this_step, mhalf_3d, ermesg, error, Initialized, Col_diag,   &
            Don_rad, Don_conv, Don_cape, Don_cem, Don_save, &!miz
            sd, Uw_p, ac, cp, ct,  Don_budgets)

!----------------------------------------------------------------------
!    if strat_cloud is active, move the output arguments into the proper
!    locations.
!----------------------------------------------------------------------
      if (cloud_tracers_present) then
        delta_ql = delta_ql_arg
        delta_qi = delta_qi_arg
        delta_qa = delta_qa_arg
      endif

      if (Initialized%do_conservation_checks .or.   &
                                          Nml%do_budget_analysis) then
        lheat_precip = Don_budgets%lheat_precip
        vert_motion = Don_budgets%vert_motion
      else
        lheat_precip = 0.
        vert_motion = 0.
      endif
      liquid_precip = Don_budgets%liq_prcp
      frozen_precip = Don_budgets%frz_prcp

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, process the error message.
!!!  HOW TO DISTINGUISH FATAL, WARNING, NOTE ??
!    FOR NOW, ALL messages considered FATAL.
!----------------------------------------------------------------------
      if (error /= 0) then
        if (running_in_fms) then
          call fms_error_mesg (ermesg) 
        else

!---------------------------------------------------------------------
!    appropriate error processing code should be added in subroutine
!    nonfms_error_mesg. currently an error message is printed and a 
!    stop command issued (dangerous on parallel machines!).
!---------------------------------------------------------------------
          call nonfms_error_mesg (ermesg) 
        endif
      endif

!---------------------------------------------------------------------
!    if this is a calculation step for donner_deep, define a mass
!    weighting factor (mass per unit area) needed for some of the netcdf
!    diagnostics (pmass). call donner_deep_netcdf to send the requested 
!    diagnostic data to the diag_manager for output.
!---------------------------------------------------------------------
      if (calc_conv_on_this_step) then
        do k=1,nlev_lsm
          pmass(:,:,k) = (phalf(:,:,k+1) - phalf(:,:,k))/Param%GRAV   
        end do

!---------------------------------------------------------------------
!   define the column integrated tracer wet deposition associated with 
!   donner convection so that it may be returned to moist_processes.
!---------------------------------------------------------------------

        donner_wetdep = 0.
        do n=1, ntr
          summa = 0.
          do k=1,nlev_lsm
            summa(:,:) = summa(:,:) + &
                                 Don_conv%wetdept(:,:,k,n)*pmass(:,:,k)
          end do
          donner_wetdep(:,:,n) = summa(:,:)
        end do
        if (running_in_fms) then
          call fms_donner_deep_netcdf (is, ie, js, je, Nml, secs, days,&
                                 Param, Initialized, Don_conv,  &
                                 Don_cape, Don_cem,parcel_rise, pmass, &
                                 total_precip,  Don_budgets, &
                                 temperature_forcing, &
                                 moisture_forcing)
        else

!---------------------------------------------------------------------
!    subroutine nonfms_donner_deep_netcdf should be set up to output 
!    the netcdf diagnostic fields. By default, it does nothing.
!---------------------------------------------------------------------
          call nonfms_donner_deep_netcdf 
        endif

!----------------------------------------------------------------------
!    on calculation steps, update the values of the cell and
!    mesoscale cloud variables to be returned to moist_processes_mod. 
!    (on non-calculation steps, the values that were passed in are 
!    simply passed back.)
!----------------------------------------------------------------------
        cell_cld_frac = Don_rad%cell_cloud_frac
        cell_liq_amt  = Don_rad%cell_liquid_amt
        cell_liq_size = Don_rad%cell_liquid_size
        cell_ice_amt  = Don_rad%cell_ice_amt
        cell_ice_size = Don_rad%cell_ice_size
        cell_droplet_number = Don_rad%cell_droplet_number
        meso_cld_frac = Don_rad%meso_cloud_frac
        meso_liq_amt  = Don_rad%meso_liquid_amt
        meso_liq_size = Don_rad%meso_liquid_size
        meso_ice_amt  = Don_rad%meso_ice_amt
        meso_ice_size = Don_rad%meso_ice_size
        meso_droplet_number = Don_rad%meso_droplet_number
        nsum          = Don_rad%nsum

!--------------------------------------------------------------------
!    define the precip fields at each model level for liq and frozen 
!    precip associated with the cell and meso circulations.
!    UNITS KG / KG/ DAY 
!--------------------------------------------------------------------
        do k=1,nlev_lsm
          frz_meso(:,:,k) = (Don_budgets%precip_budget(:,:,k,2,2) + &
                   Don_budgets%precip_budget(:,:,k,2,3) + &
                   Don_budgets%precip_budget(:,:,k,4,2) + &
                   Don_budgets%precip_budget(:,:,k,4,3))*  &
                                                     Don_conv%a1(:,:)
          liq_meso(:,:,k) = (Don_budgets%precip_budget(:,:,k,1,2) + &
                   Don_budgets%precip_budget(:,:,k,1,3) + &
                   Don_budgets%precip_budget(:,:,k,3,2) + &
                   Don_budgets%precip_budget(:,:,k,3,3) + &
                   Don_budgets%precip_budget(:,:,k,5,2) + &
                   Don_budgets%precip_budget(:,:,k,5,3))*  &
                                                     Don_conv%a1(:,:)
          frz_cell(:,:,k) = (Don_budgets%precip_budget(:,:,k,2,1) + &
                   Don_budgets%precip_budget(:,:,k,4,1))*   &
                                                     Don_conv%a1(:,:)
          liq_cell(:,:,k) = (Don_budgets%precip_budget(:,:,k,1,1) + &
                   Don_budgets%precip_budget(:,:,k,3,1) + &
                   Don_budgets%precip_budget(:,:,k,5,1))*  &
                                                     Don_conv%a1(:,:)
        end do

!--------------------------------------------------------------------
!    call deallocate_local_variables to deallocate space used by the
!    local derived-type variables.
!--------------------------------------------------------------------
        call don_d_dealloc_loc_vars_k   &
               (Don_conv, Don_cape, Don_rad, Don_cem,Don_budgets, Nml, &
                          Initialized, sd, ac, cp, ct, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, process the error message.
!----------------------------------------------------------------------
        if (error /= 0) then
          if (running_in_fms) then
            call fms_error_mesg (ermesg) 
          else

!---------------------------------------------------------------------
!    appropriate error processing code should be added in subroutine
!    nonfms_error_mesg. currently an error message is printed and a 
!    stop command issued (dangerous on parallel machines!).
!---------------------------------------------------------------------
            call nonfms_error_mesg (ermesg) 
          endif
        endif
      endif  ! (calc_conv_on_this_step)

!--------------------------------------------------------------------


end subroutine donner_deep


!#######################################################################
! <SUBROUTINE NAME="donner_deep_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine donner_deep_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp
  integer                                :: ntracers

  if (running_in_fms) then
     call fms_donner_write_restart (Initialized, timestamp)
  else 

     !---------------------------------------------------------------------
     !    subroutine nonfms_donner_write_restart should be configured to
     !    write a netcdf restart file in the nonFMS framework (see subroutine
     !    fms_donner_write_restart for the variables which must be included).
     !    by default, the subroutine does nothing.
     !---------------------------------------------------------------------
     if(present(timestamp)) then
        call nonfms_error_mesg('donner_deep_mod: when running_in_fms is false, '// &
             'timestamp should not passed in donner_deep_restart')
     endif
     ntracers = size(Don_save%tracername(:))
     call nonfms_donner_write_restart (ntracers, Don_save, &
          Initialized, Nml)
  endif

end subroutine donner_deep_restart
! </SUBROUTINE> NAME="donner_deep_restart"


!####################################################################

subroutine donner_deep_end

!---------------------------------------------------------------------
!   donner_deep_end is the destructor for donner_deep_mod.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variable

      integer  :: ntracers     ! number of tracers transported by the
                               ! donner deep convection parameterization

!-------------------------------------------------------------------
!    if module has not been initialized, return.
!-------------------------------------------------------------------
      if (.not. module_is_initialized) return

!-------------------------------------------------------------------
!    define the number of tracers that have been transported by the 
!    donner deep convection parameterization.
!-------------------------------------------------------------------
      ntracers = size(Don_save%tracername(:))

!-------------------------------------------------------------------
!    call subroutine to write restart file. NOTE: only the netcdf 
!    restart file is currently supported.
!-------------------------------------------------------------------
      if (running_in_fms) then
        call donner_deep_restart
      else 

!---------------------------------------------------------------------
!    subroutine nonfms_donner_write_restart should be configured to
!    write a netcdf restart file in the nonFMS framework (see subroutine
!    fms_donner_write_restart for the variables which must be included).
!    by default, the subroutine does nothing.
!---------------------------------------------------------------------
        call nonfms_donner_write_restart (ntracers, Don_save, &
                                       Initialized, Nml)
      endif 


!-------------------------------------------------------------------
!    close any column diagnostics units which are open.
!------------------------------------------------------------------
      if (Col_diag%num_diag_pts > 0) then
        if (running_in_fms) then
          call fms_close_col_diag_units 
        else

!--------------------------------------------------------------------
!    subroutine nonfms_close_column_diagnostics_units should be used
!    to close the outpuit units activated for column duiagnostics.
!    by default, column diagnostics are not available in the nonFMS
!    model, and this subroutine does nothing.
!--------------------------------------------------------------------
          call nonfms_close_col_diag_units 
        endif
      endif

!----------------------------------------------------------------------
!    call deallocate_variables to deallocate the module variables.
!----------------------------------------------------------------------
      call deallocate_variables 

      if (running_in_fms) then
        call fms_deallocate_variables (Col_diag)
      else

!---------------------------------------------------------------------
!    subroutine nonfms_deallocate_variables should be used to deallocate
!    local arrays associated with the column diagnostics option,
!    the variable monitoring option, and netcdf output. Currently the 
!    subroutine does nothing, since these features are not available 
!    in the nonFMS model.
!---------------------------------------------------------------------
        call nonfms_deallocate_variables
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.


!---------------------------------------------------------------------

end subroutine donner_deep_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                   PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!      1. ROUTINES CALLED BY DONNER_DEEP_INIT
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
 



!####################################################################


!#####################################################################








!#####################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!      2. ROUTINES CALLED BY DONNER_DEEP
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!######################################################################



!######################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!      3. ROUTINES CALLED BY DONNER_DEEP_END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%





!######################################################################

subroutine deallocate_variables 

!---------------------------------------------------------------------
!    subroutine deallocate_variables deallocates the space used by the
!    module variables.
!---------------------------------------------------------------------
 
      deallocate ( Don_save%cemetf              )
      deallocate ( Don_save%lag_temp            )
      deallocate ( Don_save%lag_vapor           )
      deallocate ( Don_save%lag_press           )
      deallocate ( Don_save%cememf              )
      deallocate ( Don_save%mass_flux           )
      deallocate ( Don_save%mflux_up            )
      deallocate ( Don_save%cell_up_mass_flux   )
      deallocate ( Don_save%det_mass_flux       )
      deallocate ( Don_save%dql_strat           )
      deallocate ( Don_save%dqi_strat           )
      deallocate ( Don_save%dqa_strat           )
      deallocate ( Don_save%humidity_area       )
      deallocate ( Don_save%humidity_factor     )
      deallocate ( Don_save%tracer_tends        )
      deallocate ( Don_save%parcel_disp         )
      deallocate ( Don_save%tprea1              )
      deallocate ( Don_save%tracername          )
      deallocate ( Don_save%tracer_units        )

      deallocate (Param%arat)
      deallocate (Param%ensemble_entrain_factors_gate)
      deallocate (Param%ensemble_entrain_factors_kep )
      deallocate (Param%dgeice)
      deallocate (Param%relht )

      call exn_end_k
      call findt_end_k


!----------------------------------------------------------------------


end subroutine deallocate_variables 




!######################################################################



                     end module donner_deep_mod




!#VERSION NUMBER:
!  $Name: hiram_20101115_bw $
!  $Id: donner_deep_k.F90,v 17.0.2.1.2.1.2.1.2.1.2.2 2010/09/08 21:29:57 wfc Exp $

!module donner_deep_inter_mod

!#include "donner_deep_interfaces.h"

!end module donner_deep_inter_mod


!######################################################################

subroutine don_d_donner_deep_k   &
         (is, ie, js, je, isize, jsize, nlev_lsm, nlev_hires, ntr, me, &
          cloud_tracers_present, cbmf,  &
          dt, Param, Nml, temp, mixing_ratio, pfull, phalf,   &
          zfull, zhalf, omega, pblht, tkemiz, qstar, cush, coldT, qlin,&!miz
          qiin, qain, land, sfc_sh_flux, sfc_vapor_flux, tr_flux,  &
          tracers, cell_cld_frac, cell_liq_amt, cell_liq_size,  &
          cell_ice_amt, cell_ice_size, cell_droplet_number, &
          meso_cld_frac, meso_liq_amt,  &
          meso_liq_size, meso_ice_amt, meso_ice_size,    &
          meso_droplet_number, nsum, & 
          precip, delta_temp, delta_vapor, detf, uceml_inter, mtot,   &
          mfluxup, &
          donner_humidity_area, donner_humidity_factor, total_precip,  &
          temperature_forcing, moisture_forcing, parcel_rise, &
          delta_ql, delta_qi, delta_qa, qtrtnd, calc_conv_on_this_step, &
          mhalf_3d, &
          ermesg, error, Initialized, Col_diag, Don_rad, Don_conv, Don_cape, &
          Don_cem, Don_save, sd, Uw_p, ac, cp, ct, Don_budgets)
                        
!-------------------------------------------------------------------
!    subroutine don_d_donner_deep_k is the primary kernel sub-
!    routine of the donner deep convection parameterization. it receives
!    all input needed from donner_deep_mod and controls the generation
!    of output that is returned to donner_deep_mod, from which it is made
!    accessible to the rest of the model parameterizations, as needed.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_initialized_type, donner_save_type,&
                             donner_rad_type, donner_nml_type, &
                             donner_param_type, donner_conv_type, &
                             donner_budgets_type, &
                             donner_column_diag_type, donner_cape_type, &
                             donner_cem_type
use  conv_utilities_k_mod,only : adicloud, sounding, uw_params
use  conv_plumes_k_mod,   only : cplume, ctend

implicit none

!--------------------------------------------------------------------
integer,                 intent(in)     :: is, ie, js, je, isize, jsize,&
                                           nlev_lsm, nlev_hires, ntr, me
logical,                 intent(in)     :: cloud_tracers_present
real, dimension(isize,jsize),    intent(inout)     :: cbmf
real,                    intent(in)     :: dt
type(donner_param_type), intent(in)     :: Param
type(donner_nml_type),   intent(inout)     :: Nml
real, dimension(isize,jsize,nlev_lsm),                                  &
                         intent(in)     :: temp, mixing_ratio, pfull,   zfull, &
                                           omega, qlin, qiin, qain, &
                                           cell_cld_frac,  cell_liq_amt,&
                                           cell_liq_size, cell_ice_amt, &
                                           cell_ice_size,  &
                                           cell_droplet_number, &
                                           meso_cld_frac,&
                                           meso_liq_amt, meso_liq_size, &
                                           meso_ice_amt, meso_ice_size,&
                                           meso_droplet_number
real,    dimension(isize,jsize,nlev_lsm+1),                            &
                         intent(in)     :: phalf, zhalf
real,    dimension(isize,jsize),                                      &
                         intent(in)     :: pblht, tkemiz, qstar, cush, land, &
                                           sfc_sh_flux, sfc_vapor_flux
logical, dimension(isize,jsize), intent(in) :: coldT    
real,    dimension(isize,jsize,ntr),                                 &
                         intent(in)     :: tr_flux 
real,    dimension(isize,jsize,nlev_lsm,ntr),                         &
                         intent(in)     :: tracers 
integer, dimension(isize,jsize),                                     &
                         intent(in)     :: nsum      
real,    dimension(isize,jsize),                                     & 
                         intent(out)    :: precip      
real, dimension(isize,jsize,nlev_lsm),                                 &
                         intent(out)    :: delta_temp, delta_vapor,&
                                           detf,  mtot, mfluxup, &
                                           donner_humidity_area,&
                                           donner_humidity_factor, &
                                           temperature_forcing,   &
                                           moisture_forcing, &
                                           delta_ql, delta_qi, &
                                           delta_qa
real, dimension(isize,jsize,nlev_lsm+1),                               &
                         intent(out)    :: uceml_inter
real, dimension(isize,jsize),                                         &
                         intent(out)    :: total_precip, parcel_rise
real,    dimension(isize,jsize,nlev_lsm,ntr),                        &
                         intent(out)    :: qtrtnd 
logical,                 intent(in)     :: calc_conv_on_this_step
real, dimension(isize,jsize,nlev_lsm+1),                               &
                         intent(out)    :: mhalf_3d
character(len=*),        intent(out)    :: ermesg
integer,                 intent(out)    :: error
type(donner_initialized_type),                            &
                         intent(inout)  :: Initialized
type(donner_column_diag_type),                               &
                         intent(inout)  :: Col_diag
type(donner_rad_type),   intent(inout)  :: Don_rad
type(donner_conv_type),  intent(inout)  :: Don_conv
type(donner_budgets_type),  intent(inout)  :: Don_budgets
type(donner_cape_type),  intent(inout)  :: Don_cape
type(donner_cem_type),   intent(inout)  :: Don_cem
type(donner_save_type),  intent(inout)  :: Don_save

type(sounding),          intent(inout)  :: sd
type(uw_params),          intent(inout)  :: Uw_p
type(adicloud),          intent(inout)  :: ac
type(cplume),            intent(inout)  :: cp
type(ctend),             intent(inout)  :: ct

!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie         first and last values of i index values of points 
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points 
!                    in this physics window (processor coordinates)
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     ntr            number of tracers to be transported by donner
!                    convection
!     me             local pe number
!     dt             physics time step [ sec ]
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     temp           temperature field at model levels [ deg K ]
!     mixing_ratio   vapor mixing ratio field at model levels 
!                    [ kg(h20) / kg(dry air) ]
!     pfull          pressure field on model full levels [ Pa ]
!     omega          model omega field at model full levels [ Pa / sec ]
!     qlin           large-scale cloud liquid specific humidity 
!                    [ kg(h2o) / kg (moist air) ]
!     qiin           large-scale cloud ice specific humidity 
!                    [ kg(h2o) / kg (moist air) ]
!     qain           large-scale cloud fraction  
!                    [ fraction ]
!     cell_cld_frac  fractional coverage of convective cells in
!                    grid box [ dimensionless ]
!     cell_liq_amt   liquid water content of convective cells
!                    [ kg(h2o) / kg(air) ]
!     cell_liq_size  assumed effective size of cell liquid drops
!                    [ microns ]
!     cell_ice_amt   ice water content of cells
!                    [ kg(h2o) / kg(air) ]
!     cell_ice_size  generalized effective diameter for ice in
!                    convective cells [ microns ]
!     meso_cld_frac  fractional area of mesoscale clouds in grid
!                    box [ dimensionless ]
!     meso_liq_amt   liquid water content in mesoscale clouds
!                    [ kg(h2o) / kg(air) ]
!     meso_liq_size  assumed effective size of mesoscale drops
!                    [ microns ]
!     meso_ice_amt   ice water content of mesoscale elements
!                    [ kg(h2o) / kg(air) ]
!     meso_ice_size  generalized ice effective size for anvil ice
!                    [ microns ]
!     phalf          pressure field at half-levels 1:nlev_lsm+1  [ Pa ]
!     land           fraction of grid box covered by land
!                    [ fraction ]
!     sfc_sh_flux   sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_vapor_flux water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     tr_flux        surface flux of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     tracers        tracer mixing ratios
!                    [ kg(tracer) / kg (dry air) ]
!     nsum           number of time levels over which the above variables
!                    have so far been summed
!
!   intent(out) variables:
!
!     precip         precipitation generated by deep convection
!                    [ kg(h2o) / m**2 ]
!     delta_temp     temperature increment due to deep convection 
!                    [ deg K ]
!     delta_vapor    water vapor mixing ratio increment due to deep 
!                    convection [ kg(h2o) / kg (dry air) ]
!     detf           detrained cell mass flux at model levels 
!                    [ (kg / (m**2 sec) ) ]
!     mtot           mass flux at model full levels, convective plus 
!                    mesoscale, due to donner_deep_mod 
!                    [ (kg / (m**2 sec) ) ]
!     mfluxup        upward mass flux at model full levels, convective 
!                    plus mesoscale, due to donner_deep_mod 
!                    [ (kg / (m**2 sec) ) ]
!     donner_humidity_area
!                    fraction of grid box in which humidity is affected
!                    by the deep convection, defined as 0.0 below cloud
!                    base and above the mesoscale updraft, and as the
!                    sum of the cell and mesoscale cloud areas in 
!                    between. it is used in strat_cloud_mod to determine
!                    the large-scale specific humidity field for the
!                    grid box. DO NOT use for radiation calculation,
!                    since not all of this area includes condensate.
!                    [ fraction ]
!     donner_humidity_ratio
!                    ratio of large-scale specific humidity to specific 
!                    humidity in environment outside convective system
!                    [ dimensionless ]
!     temperature_forcing  
!                    temperature tendency due to donner convection
!                    [ deg K / sec ]
!     moisture_forcing 
!                    vapor mixing ratio tendency due to donner
!                    convection [ kg(h2o) / (kg(dry air) sec ) ]
!     delta_ql       cloud water specific humidity increment due to 
!                    deep convection over the timestep
!                    [ kg (h2o) / kg (moist air) ]
!     delta_qi       cloud ice specific humidity increment due to deep 
!                    convection over the timestep 
!                    [ kg (h2o) / kg (moist air) ]
!     delta_qa       cloud area increment due to deep convection
!                    over the time step [ fraction ]
!     uceml_inter    upward cell mass flux at interface levels 
!                    [ (kg / (m**2 sec) ) ]
!     total_precip   total precipitation rate produced by the
!                    donner parameterization [ mm / day ]
!     parcel_rise    accumulated vertical displacement of a
!                    near-surface parcel as a result of the lowest
!                    model level omega field [ Pa ]
!     qtrtnd         tracer time tendencies due to deep convection
!                    during the time step
!                    [ kg(tracer) / (kg (dry air) sec) ]
!     calc_conv_on_this_step
!                    is this a step on which to calculate
!                    donner convection ?
!     ermesg         character string containing any error message
!                    that is returned from a kernel subroutine
!
!   intent(inout) variables:
!
!     Initialized    donner_initialized_type variable containing
!                    variables which are defiuned during initialization.
!                    these values may be changed during model execution.
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     Don_rad        donner_rad_type derived type variable used to hold 
!                    those fields needed to connect the donner deep 
!                    convection parameterization and the model radiation 
!                    package
!     Don_conv       donner_convection_type derived type variable
!                    containing diagnostics and intermediate results 
!                    describing the nature of the convection produced by
!                    the donner parameterization
!     Don_cape       donner_cape type derived type variable containing 
!                    diagnostics and intermediate results related to the
!                    cape calculation associated with the donner convec-
!                    tion parameterization
!     Don_save       donner_save_type derived type variable containing
!                    those variables which must be preserved across
!                    timesteps
!     Don_cem        donner_cem_type derived type variable containing
!                    Donner cumulus ensemble member diagnostics
!     
!-----------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real,                                                      &
         dimension (isize, jsize, nlev_lsm) ::  lag_cape_temp,        &
                                                lag_cape_vapor,      &
                                                lag_cape_press, &
                                                dql, dqi, dqa
      real,                                                      &
         dimension (isize, jsize, nlev_lsm+1) ::  mhalf_3d_local  
      real,    dimension (isize, jsize)     ::  current_displ
      logical, dimension (isize, jsize)     ::  exit_flag
      integer                               ::  idiag, jdiag, unitdiag

      integer  :: i, j, k, n   

!--------------------------------------------------------------------
!   local variables:
!
!     lag_cape_temp        temperature field used in lag-time cape 
!                          calculation [ deg K ]
!     lag_cape_vapor       vapor mixing ratio field used in lag-time
!                          cape calculation [ kg(h2o) / kg(dry air) ]
!     lag_cape_press       model full-level pressure field used in 
!                          lag-time cape calculation 
!                          [ kg(h2o) / kg(dry air) ]
!     dql                  tendency of cloud liquid specific humidity
!                          due to donner convection 
!                          [ kg(h2o) / kg(moist air) / sec ]
!     dqi                  tendency of cloud ice specific humidity
!                          due to donner convection 
!                          [ kg(h2o) / kg(moist air) / sec ]
!     dqa                  tendency of large-scale cloud area
!                          due to donner convection 
!                          [ fraction / sec ]
!     current_displ        low-level parcel displacement to use in cape
!                          calculation on this step [ Pa ]
!     exit_flag            logical array indicating whether deep conv-
!                          ection exists in a column
!     idiag                physics window i index of current diagnostic
!                          column
!     jdiag                physics window j index of current diagnostic
!                          column
!     unitdiag             i/o unit assigned to current diagnostic
!                          column
!     i, j, k, n           do-loop indices
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!-------------------------------------------------------------------
!    verify that donner_deep_freq is an integral multiple of the model
!    physics time step.
!--------------------------------------------------------------------
      if (MOD (Nml%donner_deep_freq, int(dt)) /= 0) then
        ermesg = 'donner_deep_donner_deep_k: donner_deep timestep NOT &
            &an integral multiple of physics timestep'
        error = 1
        return
      endif

!---------------------------------------------------------------------
!    perform the following calculations only if this is a step upon
!    which donner convection is to be calculated.
!---------------------------------------------------------------------
      if (calc_conv_on_this_step) then
 
!-------------------------------------------------------------------
!    call initialize_local_variables_k to allocate and initialize the
!    elements of the donner_conv, donner_cape and donner_rad derived type
!    variables.
!-------------------------------------------------------------------
        call don_d_init_loc_vars_k       &
             (isize, jsize, nlev_lsm, ntr, nlev_hires, cell_cld_frac, &
              cell_liq_amt, cell_liq_size, cell_ice_amt, cell_ice_size, &
              cell_droplet_number, &
              meso_cld_frac, meso_liq_amt, meso_liq_size, meso_ice_amt, &
              meso_ice_size, meso_droplet_number, nsum, Don_conv,   &
              Don_cape, Don_rad, Don_cem, Param, Don_budgets, Nml, &
              Initialized, sd, ac, cp, ct, ermesg, error) 

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
      endif !(calc_conv_on_this_step)

!---------------------------------------------------------------------
!    allocate and initialize the components of the donner_budgets_type 
!    variable Don_budgets. definitions of these arrays are found in 
!    donner_types.h.
!---------------------------------------------------------------------
      allocate ( Don_budgets%liq_prcp     (isize, jsize, nlev_lsm) )
      allocate ( Don_budgets%frz_prcp     (isize, jsize, nlev_lsm) )
      Don_budgets%liq_prcp     = 0.
      Don_budgets%frz_prcp     = 0.
   if (Initialized%do_conservation_checks .or.   &
                                          Nml%do_budget_analysis) then
      allocate ( Don_budgets%lheat_precip (isize, jsize) )
      allocate ( Don_budgets%vert_motion  (isize, jsize) )
      Don_budgets%lheat_precip = 0.
      Don_budgets%vert_motion  = 0.
      allocate ( Don_budgets%water_budget (isize, jsize, nlev_lsm, &
                                        Don_budgets%n_water_budget) )
      allocate ( Don_budgets%enthalpy_budget (isize, jsize, nlev_lsm, &
                                     Don_budgets%n_enthalpy_budget) )
      allocate ( Don_budgets%precip_budget (isize, jsize, nlev_lsm, &
                                       Don_budgets%n_precip_paths, &
                                       Don_budgets%n_precip_types)  )
      Don_budgets%water_budget = 0.
      Don_budgets%enthalpy_budget = 0.
      Don_budgets%precip_budget = 0.
   endif

!---------------------------------------------------------------------
!    add the vertical displacement resulting from the current omega
!    field to the accumulated displacement of a parcel which originated
!    at the lowest model full level. prevent the parcel from moving 
!    below its starting point or going out the top of the atmosphere. 
!---------------------------------------------------------------------
      do j=1,jsize       
        do i=1,isize        
          parcel_rise(i,j) = Don_save%parcel_disp(i+is-1,j+js-1) +  &
                             omega(i,j,nlev_lsm)*dt
          parcel_rise(i,j) = MIN (0.0, parcel_rise(i,j))
          parcel_rise(i,j) = MAX (-phalf(i,j,nlev_lsm+1),    &
                                  parcel_rise(i,j))
        end do
      end do

!---------------------------------------------------------------------
!    if there are one or more diagnostic columns in the current physics
!    window, set a flag to so indicate. call don_d_column_input_fields
!    to print out the relevant input fields, location and control 
!    information for these diagnostics columns.   
!---------------------------------------------------------------------
      if (Col_diag%num_diag_pts > 0) then
        if (Col_diag%ncols_in_window > 0) then
          Col_diag%in_diagnostics_window = .true.
          call don_d_column_input_fields_k    &
               (isize, jsize, nlev_lsm, dt, calc_conv_on_this_step, &
                Col_diag, temp, mixing_ratio, pfull, omega, phalf,   &
                parcel_rise, ermesg, error) 

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

!---------------------------------------------------------------------
!    if there are no diagnostic columns in the current physics
!    window, set a flag to so indicate. 
!---------------------------------------------------------------------
        else
          Col_diag%in_diagnostics_window = .false.
        endif

!---------------------------------------------------------------------
!    if column diagnostics are not desired in any model columns, set a 
!    flag to so indicate. 
!---------------------------------------------------------------------
      else
        Col_diag%in_diagnostics_window = .false.
      endif

!---------------------------------------------------------------------
!    perform the following calculations only if this is a step upon 
!    which donner convection is to be calculated.
!---------------------------------------------------------------------
      if (calc_conv_on_this_step) then 

!---------------------------------------------------------------------
!    define the low-level displacement to be used on this step 
!    (current_displ). it is the current time-integrated value, unless 
!    the current lowest-level vertical velocity is downward, in which 
!    case the displacement to be used on the current step is set to 
!    zero, precluding deep convection on this step.
!---------------------------------------------------------------------
        do j=1,jsize       
          do i=1,isize        
            if (omega(i,j,nlev_lsm) > 0.)   then
              current_displ(i,j) = 0. 
            else
              current_displ(i,j) = parcel_rise(i,j)
            endif
          end do
        end do

!---------------------------------------------------------------------
!    define the temperature, vapor mixing ratio and pressure fields to
!    be used in calculating the lag values of cape so that a cape tend-
!    ency due to large-scale forcing may be computed.
!---------------------------------------------------------------------
        lag_cape_temp (:,:,:) = Don_save%lag_temp (is:ie,js:je,:)
        lag_cape_vapor(:,:,:) = Don_save%lag_vapor(is:ie,js:je,:)
        lag_cape_press(:,:,:) = Don_save%lag_press(is:ie,js:je,:)

!---------------------------------------------------------------------
!    call donner_convection_driver to calculate the effects of deep 
!    convection.  
!--------------------------------------------------------------------- 
        call don_d_convection_driver_k   &
             (isize, jsize, nlev_lsm, nlev_hires, ntr, me, &
              cloud_tracers_present, cbmf, dt, Nml, &
              Initialized, Param, Col_diag, temp, mixing_ratio,  &
              pfull, zfull, zhalf, pblht, tkemiz, qstar, cush, coldT,  &!miz
              qlin, qiin, qain, lag_cape_temp, lag_cape_vapor,    &
              lag_cape_press, phalf, current_displ, land, sfc_sh_flux, &
              sfc_vapor_flux, tr_flux, tracers, Don_cape, Don_conv, &
              Don_rad, Don_cem, temperature_forcing, moisture_forcing,  &
              total_precip, donner_humidity_factor, donner_humidity_area,&
              dql, dqi, dqa, mhalf_3d_local, exit_flag, ermesg, error, sd, Uw_p, ac, cp, ct, &
              Don_budgets)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

!--------------------------------------------------------------------- 
!    define the module variables used to preserve output fields across
!    physics timesteps, needed when the donner parameterization is not
!    executed on every physics step.
!
!    1) the variables defining the humidity disturbance caused by
!       donner convection. these variables are needed so that the large-
!       scale humidity may be properly adjusted in strat_cloud_mod.
!--------------------------------------------------------------------- 
        Don_save%humidity_area (is:ie,js:je,:) =    &
                                            donner_humidity_area (:,:,:)
        Don_save%humidity_factor(is:ie,js:je,:) =    &
                                           donner_humidity_factor(:,:,:)
 
!--------------------------------------------------------------------- 
!    2) the total precipitation produced by the donner parameter-
!       ization.
!--------------------------------------------------------------------- 
        Don_save%tprea1(is:ie,js:je) = total_precip(:,:)

!---------------------------------------------------------------------
!    3) the vapor and temperature forcing resulting from the donner
!       deep parameterization that will be output to the calling 
!       routine. NOTE: these values of cemetf and cememf have the terms
!       related to flux convergence of condensate and mesoscale 
!       detrainment removed when parameterization is run in a model 
!       using strat_cloud_mod, since in that case those terms will be 
!       calculated within that module.
!---------------------------------------------------------------------
        Don_save%cememf(is:ie,js:je,:) = moisture_forcing(:,:,:) 
        Don_save%cemetf(is:ie,js:je,:) = temperature_forcing(:,:,:)

!----------------------------------------------------------------------
!    4) the increments which must be applied to the strat_cloud vari-
!       ables as a result of donner convection. the returned tendencies 
!       are converted to increments. 
!----------------------------------------------------------------------
        if (cloud_tracers_present) then
        Don_save%dql_strat(is:ie,js:je,:) = dql(:,:,:)*dt
        Don_save%dqi_strat(is:ie,js:je,:) = dqi(:,:,:)*dt
        Don_save%dqa_strat(is:ie,js:je,:) = dqa(:,:,:)*dt
        endif

!--------------------------------------------------------------------
!    5) the net mass flux and detrained cell mass flux at model full 
!       levels that is associated with the donner deep parameterization. 
!       the net mass flux is needed as input to strat_cloud_mod, while
!       the detrained cell mass flux is needed by cu_mo_trans_mod. 
!--------------------------------------------------------------------
        do k=1,nlev_lsm
          do j=1,jsize
            do i=1,isize
              if ((Don_conv%uceml(i,j,k) <= 1.0e-10) .and.   &
                  (Don_conv%umeml(i,j,k) <= 1.0e-10) .and.   &
                  (Don_conv%dmeml(i,j,k) <= 1.0e-10) ) then
                Don_save%mass_flux(i+is-1,j+js-1,k) = 0.
              else
                Don_save%mass_flux(i+is-1,j+js-1,k) =   &
                                        Don_conv%uceml(i,j,k) + &
                                        Don_conv%umeml(i,j,k) + &
                                        Don_conv%dmeml(i,j,k)
              endif
              if ((Don_conv%uceml(i,j,k) <= 1.0e-10) .and.   &
                  (Don_conv%umeml(i,j,k) <= 1.0e-10) ) then
                Don_save%mflux_up(i+is-1,j+js-1,k) = 0.
              else
                Don_save%mflux_up(i+is-1,j+js-1,k) =   &
                                        Don_conv%uceml(i,j,k) + &
                                        Don_conv%umeml(i,j,k)
              endif
              if (Don_conv%detmfl(i,j,k) <= 1.0e-10) then
                Don_save%det_mass_flux(i+is-1,j+js-1,k) = 0.
              else
                Don_save%det_mass_flux(i+is-1,j+js-1,k) =      &
                                                  Don_conv%detmfl(i,j,k)
              endif
            end do
          end do
        end do

!--------------------------------------------------------------------
!    6) the upward mass flux at model interface levels that is 
!       associated with the convective cells present in the donner deep 
!       convction parameterization. this is needed by cu_mo_trans_mod.
!       define values at upper and lower boundary to be 0.0.
!--------------------------------------------------------------------
        Don_save%cell_up_mass_flux(:,:,1) = 0.
        Don_save%cell_up_mass_flux(:,:,nlev_lsm+1) = 0.
        do k=2,nlev_lsm
          do j=1,jsize
            do i=1,isize
              Don_save%cell_up_mass_flux(i+is-1,j+js-1,k) =  &
                                    0.5*(Don_Conv%uceml(i,j,k) + &
                                         Don_conv%uceml(i,j,k-1))
            end do
          end do
        end do
        
!--------------------------------------------------------------------
!    7) the tracer time tendencies resulting from the donner param-
!       eterization. 
!--------------------------------------------------------------------
        if (Initialized%do_donner_tracer) then
          Don_save%tracer_tends(is:ie,js:je,:,:) =      &
                   Don_conv%qtceme(:,:,:,:) + Don_conv%wetdept(:,:,:,:)
        endif
      else  ! (calc_conv_on_this_step)
        total_precip(:,:) = 0.0

!---------------------------------------------------------------------
!    end of if loop for code executed only on steps for which the donner
!    parameterization is requested.
!---------------------------------------------------------------------
      endif ! (calc_conv_on_this_step)

!--------------------------------------------------------------------- 
!    update the module variable containing the total low-level parcel 
!    displacement. this field is updated on every model physics step, 
!    regardless of whether donner convective tendencies are calculated 
!    or not.
!--------------------------------------------------------------------- 
      Don_save%parcel_disp(is:ie,js:je) = parcel_rise(:,:)

!----------------------------------------------------------------------
!    define the output fields to be passed back to the calling routine.
!    these fields are returned on every physics step, regardless of
!    whether or not the donner calculation is done, and so must be 
!    defined from module variables.
!
!    1) the temperature increment due to deep convection
!----------------------------------------------------------------------
      delta_temp(:,:,:) = Don_save%cemetf(is:ie,js:je,:)*dt

!----------------------------------------------------------------------
!    2) the moisture increment due to deep convection. if the moisture
!       tendency results in the production of a negative value, reduce 
!       the tendency to avoid producing the negative mixing ratio.
!----------------------------------------------------------------------
      do k=1,nlev_lsm
        do j=1,jsize      
          do i=1,isize       
            delta_vapor(i,j,k) = Don_save%cememf(i+is-1,j+js-1,k)*dt
!           if ((mixing_ratio(i,j,k) + delta_vapor(i,j,k)) < 0.) then
!             if (mixing_ratio(i,j,k) > 0.) then
!               delta_vapor (i,j,k) = -mixing_ratio(i,j,k)
!             else 
!               delta_vapor(i,j,k) = 0.0
!             endif
!           endif
          end do
        end do
      end do

!-------------------------------------------------------------------
!    3) the net mass flux, detrained cell mass flux and upward mass 
!       flux due to convective cells at interface levels resulting from
!       donner convection.
!-------------------------------------------------------------------
      mtot(:,:,:)        = Don_save%mass_flux(is:ie, js:je,:)
      mfluxup(:,:,:)     = Don_save%mflux_up(is:ie, js:je,:)
      detf(:,:,:)        = Don_save%det_mass_flux(is:ie,js:je,:)
      uceml_inter(:,:,:) = Don_save%cell_up_mass_flux(is:ie,js:je,:)
      mhalf_3d(:,:,:) = mhalf_3d_local

!-------------------------------------------------------------------
!    4) the increments of the large-scale cloud variables due to deep
!       convection and the variables describing the specific humidity
!       disturbance associated with donner convection.
!-------------------------------------------------------------------
      if (cloud_tracers_present) then
      delta_ql(:,:,:) = Don_save%dql_strat (is:ie, js:je,:)
      delta_qi(:,:,:) = Don_save%dqi_strat (is:ie, js:je,:)
      delta_qa(:,:,:) = Don_save%dqa_strat (is:ie, js:je,:)
      endif
      donner_humidity_area(:,:,:)  =             &
                                   Don_save%humidity_area(is:ie,js:je,:)
      donner_humidity_factor(:,:,:) =             &
                                 Don_save%humidity_factor(is:ie,js:je,:)

!----------------------------------------------------------------------
!    5) the precipitation accrued on the current timestep from deep
!       convection. 
!       note: precip    [mm/day] * 1/86400 [day/sec] * 1/1000 [ m/mm] * 
!                  1000 [kg(h2o)/m**3] * dt [sec] = kg/m2, as desired. 
!----------------------------------------------------------------------
      precip(:,:) = Don_save%tprea1(is:ie,js:je)*dt/Param%seconds_per_day

!--------------------------------------------------------------------
!    6) time tendencies of any tracers being transported by donner 
!       convection. if none have been defined, fill the output array
!       with zeroes.
!--------------------------------------------------------------------
      if (Initialized%do_donner_tracer) then
        qtrtnd(:,:,:,:) = Don_save%tracer_tends(is:ie,js:je,:,:)
      else
        qtrtnd(:,:,:,:) = 0.0                            
      endif

!---------------------------------------------------------------------
!    if this is a diagnostics window, output the increments to temper-
!    ature and vapor mixing ratio at levels where donner convection
!    has produced a modification.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          idiag = Col_diag%i_dc(n)
          jdiag = Col_diag%j_dc(n)
          unitdiag = Col_diag%unit_dc(n)
          do k=Col_diag%kstart,nlev_lsm
            if (delta_temp(idiag,jdiag,k) /= 0.0) then
              write (unitdiag, '(a, i4, f20.14, e20.12)') &
                   'in donner_deep: k,ttnd,qtnd',  k,  &
                   delta_temp(idiag,jdiag,k), delta_vapor(idiag,jdiag,k)
            endif
          end do
        end do
      endif

!---------------------------------------------------------------------
!    define the module variables containing the temperature, pressure 
!    and vapor fields that are to be used on the next time step to 
!    calculate a lag-time cape so that the time tendency of cape due
!    to large-scale forcing may be obtained. this field is updated on 
!    every model physics step, so that values are present in case the 
!    next step is a donner calculation step.
!--------------------------------------------------------------------- 
      Don_save%lag_temp (is:ie, js:je,:) = temp + delta_temp
      Don_save%lag_vapor(is:ie, js:je,:) = mixing_ratio + delta_vapor 
      Don_save%lag_press(is:ie, js:je,:) = pfull
  
!-------------------------------------------------------------------
!    perform the following calculations only if this is a step upon 
!    which donner convection is to be calculated.
!-------------------------------------------------------------------
      if (calc_conv_on_this_step) then

!---------------------------------------------------------------------
!    define the revised moisture tendency produced by donner convection
!    after it has been adjusted to prevent the generation of negative 
!    vapor mixing ratio.
!---------------------------------------------------------------------
        Don_conv%cememf_mod(:,:,:) = delta_vapor(:,:,:)/dt

!---------------------------------------------------------------------
!    if this is a diagnostics window, call donner_column_end_of_step
!    to output various diagnostic fields in the specified diagnostic
!    columns.
!---------------------------------------------------------------------
        if (Col_diag%in_diagnostics_window) then
          call don_d_column_end_of_step_k   &
               (isize, jsize, nlev_lsm, ntr, Col_diag, exit_flag,   &
                total_precip, parcel_rise, temperature_forcing,   &
                moisture_forcing, tracers, Don_cape,   &
                Don_conv, ermesg, error) 

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return
        endif
      endif !(calc_conv_on_this_step) 

!--------------------------------------------------------------------


end subroutine don_d_donner_deep_k




!####################################################################

subroutine don_d_init_loc_vars_k      &
         (isize, jsize, nlev_lsm, ntr, nlev_hires, cell_cld_frac,  &
          cell_liq_amt, cell_liq_size, cell_ice_amt, cell_ice_size,   &
          cell_droplet_number, &
          meso_cld_frac, meso_liq_amt, meso_liq_size, meso_ice_amt,   &
          meso_ice_size, meso_droplet_number, nsum, Don_conv,   &
          Don_cape, Don_rad, Don_cem, Param, Don_budgets, Nml, &
          Initialized, sd, ac, cp, ct, ermesg, error)

use donner_types_mod, only : donner_rad_type, donner_conv_type, &
                             donner_budgets_type, &
                             donner_initialized_type, &
                             donner_cape_type, donner_nml_type, &
                             donner_param_type, donner_cem_type
use  conv_utilities_k_mod,only : adicloud, sounding, ac_init_k, &
                                 sd_init_k
use  conv_plumes_k_mod,only    : cplume, ctend, cp_init_k, ct_init_k
implicit none

!--------------------------------------------------------------------
!   subroutine don_d_init_loc_vars_k allocates space 
!   for and initializes the array components of the donner_conv_type 
!   variable Don_conv, the donner_cape_type variable Don_cape, the 
!   donner_rad_type variable Don_rad, and the donner_cem_type 
!   variable Don_cem.
!--------------------------------------------------------------------

integer,                         intent(in)    :: isize, jsize,    &
                                                  nlev_lsm, ntr, &
                                                  nlev_hires
real,dimension(isize,jsize,nlev_lsm),                              &
                                 intent(in)    :: cell_cld_frac,  &
                                                  cell_liq_amt,   &
                                                  cell_liq_size, &
                                                  cell_ice_amt,   &
                                                  cell_ice_size, &
                                            cell_droplet_number, &
                                                  meso_cld_frac,    &
                                                  meso_liq_amt, &
                                                  meso_liq_size, &
                                                  meso_ice_amt,     &
                                                  meso_ice_size,  &
                                            meso_droplet_number 
integer, dimension(isize,jsize), intent(in)    :: nsum
type(donner_conv_type),          intent(inout) :: Don_conv
type(donner_cape_type),          intent(inout) :: Don_cape
type(donner_rad_type),           intent(inout) :: Don_rad
type(donner_cem_type),           intent(inout) :: Don_cem
type(donner_param_type),         intent(in)    :: Param
type(donner_budgets_type),       intent(inout) :: Don_budgets
type(donner_nml_type),           intent(in)    :: Nml
type(donner_initialized_type),   intent(in)    :: Initialized
type(sounding),               intent(inout) :: sd
type(adicloud),               intent(inout) :: ac
type(cplume),                 intent(inout) :: cp
type(ctend),                  intent(inout) :: ct
character(len=*),                intent(out)   :: ermesg
integer,                         intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize         size of x-dimension of physics window
!     jsize         size of y-dimension of physics window
!     nlev_lsm      number of layers in large-scale model
!     ntr           number of tracers to be transported by donner
!                   convection
!     nlev_hires    number of model layers in hi-res cloud model
!                   of the donner deep convection parameterization
!     cell_cld_frac fractional coverage of convective cells in
!                   grid box [ dimensionless ]
!     cell_liq_amt  liquid water content of convective cells
!                   [ kg(h2o) / kg(air) ]
!     cell_liq_size assumed effective size of cell liquid drops
!                   [ microns ]
!     cell_ice_amt  ice water content of cells
!                   [ kg(h2o) / kg(air) ]
!     cell_ice_size generalized effective diameter for ice in
!                   convective cells [ microns ]
!     meso_cld_frac fractional area of mesoscale clouds in grid
!                   box [ dimensionless ]
!     meso_liq_amt  liquid water content in mesoscale clouds
!                   [ kg(h2o) / kg(air) ]
!     meso_liq_size assumed effective size of mesoscale drops
!                   [ microns ]
!     meso_ice_amt  ice water content of mesoscale elements
!                   [ kg(h2o) / kg(air) ]
!     meso_ice_size generalized ice effective size for anvil ice
!                   [ microns ]
!     nsum          number of time levels over which the above variables
!                   have so far been summed
!
!   intent(inout) variables:
!
!     Don_conv     donner_conv_type derived type variable containing 
!                  diagnostics and intermediate results describing the 
!                  nature of the convection produced by the donner 
!                  parameterization
!     Don_cape     donner_cape type derived type variable containing 
!                  diagnostics and intermediate results related to the 
!                  cape calculation associated with the donner 
!                  convection parameterization
!     Don_rad      donner_rad_type derived type variable used to hold 
!                  those fields needed to connect the donner deep 
!                  convection parameterization and the model radiation 
!                  package
!     Don_cem      donner_cem_type derived type variable containing
!                  Donner cumulus ensemble member diagnostics
!     Param        donner_param_type variable containingthe parameters
!                  of the donner deep convection parameterization

!
!   intent(out) variables:
!
!     ermesg        character string containing any error message
!                   that is returned from a kernel subroutine
!
!---------------------------------------------------------------------
     integer :: ncem   ! Param%kpar, number of cumulus ensemble members

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg= ' ' ; error = 0

      call sd_init_k (nlev_lsm, ntr, sd)
      call ac_init_k (nlev_lsm, ac)
      call cp_init_k (nlev_lsm, ntr, cp)
      call ct_init_k (nlev_lsm, ntr, ct)

!---------------------------------------------------------------------
!    allocate the components of the donner_conv_type variable Don_conv.
!    definitions of these arrays are found in donner_types.h.
!---------------------------------------------------------------------
      allocate (Don_conv%cecon              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%ceefc              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cell_liquid_eff_diam     &
                                            (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cell_ice_geneff_diam     &
                                            (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cememf_mod         (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cemfc              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cmus               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%conv_temp_forcing  (isize, jsize, nlev_lsm) )
      allocate (Don_conv%conv_moist_forcing (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cual               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cuqi               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%cuql               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%detmfl             (isize, jsize, nlev_lsm) )
      allocate (Don_conv%dgeice             (isize, jsize, nlev_lsm) )
      allocate (Don_conv%dmeml              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%ecds               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%eces               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%elt                (isize, jsize, nlev_lsm) )
      allocate (Don_conv%emds               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%emes               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%fre                (isize, jsize, nlev_lsm) )
      allocate (Don_conv%mrmes              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%tmes               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%uceml              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%umeml              (isize, jsize, nlev_lsm) )
      allocate (Don_conv%wmms               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%wmps               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%xice               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%xliq               (isize, jsize, nlev_lsm) )
      allocate (Don_conv%a1                 (isize, jsize) )
      allocate (Don_conv%amax               (isize, jsize) )
      allocate (Don_conv%amos               (isize, jsize) )
      allocate (Don_conv%ampta1             (isize, jsize) )
      allocate (Don_conv%cell_precip        (isize, jsize) )
      allocate (Don_conv%dcape              (isize, jsize) )
      allocate (Don_conv%emdi_v             (isize, jsize) )
      allocate (Don_conv%meso_precip        (isize, jsize) )
      allocate (Don_conv%pb_v               (isize, jsize) )
      allocate (Don_conv%pmd_v              (isize, jsize) )
      allocate (Don_conv%przm               (isize, jsize) )
      allocate (Don_conv%prztm              (isize, jsize) )
      allocate (Don_conv%pzm_v              (isize, jsize) )
      allocate (Don_conv%pztm_v             (isize, jsize) )

      allocate (Don_conv%qtceme        (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%qtmes1        (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%qtren1        (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%temptr        (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%wtp1          (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%wetdepc       (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%wetdepm       (isize, jsize, nlev_lsm, ntr) )
      allocate (Don_conv%wetdept       (isize, jsize, nlev_lsm, ntr) )

!---------------------------------------------------------------------
!    initialize the components of the donner_conv_type variable Don_conv.
!---------------------------------------------------------------------
      Don_conv%cecon                = 0.0
      Don_conv%ceefc                = 0.0
      Don_conv%cell_liquid_eff_diam = 0.0
      Don_conv%cell_ice_geneff_diam = 0.0
      Don_conv%cememf_mod           = 0.0
      Don_conv%cemfc                = 0.0
      Don_conv%cmus                 = 0.0
      Don_conv%conv_temp_forcing    = 0.0
      Don_conv%conv_moist_forcing   = 0.0
      Don_conv%cual                 = 0.0
      Don_conv%cuqi                 = 0.0
      Don_conv%cuql                 = 0.0
      Don_conv%detmfl               = 0.0
      Don_conv%dgeice               = 0.0
      Don_conv%dmeml                = 0.0
      Don_conv%ecds                 = 0.0
      Don_conv%eces                 = 0.0
      Don_conv%elt                  = 0.0
      Don_conv%emds                 = 0.0
      Don_conv%emes                 = 0.0
      Don_conv%fre                  = 0.0
      Don_conv%mrmes                = 0.0
      Don_conv%tmes                 = 0.0
      Don_conv%uceml                = 0.0
      Don_conv%umeml                = 0.0
      Don_conv%wmms                 = 0.0
      Don_conv%wmps                 = 0.0
      Don_conv%xice                 = 0.0
      Don_conv%xliq                 = 0.0
      Don_conv%a1                   = 0.0
      Don_conv%amax                 = 0.0
      Don_conv%amos                 = 0.0
      Don_conv%ampta1               = 0.0
      Don_conv%cell_precip          = 0.0
      Don_conv%dcape                = 0.0
      Don_conv%emdi_v               = 0.0
      Don_conv%meso_precip          = 0.0
      Don_conv%pb_v                 = 0.0
      Don_conv%pmd_v                = 0.0
      Don_conv%przm                 = 0.0
      Don_conv%prztm                = 0.0
      Don_conv%pzm_v                = 0.0
      Don_conv%pztm_v               = 0.0
      Don_conv%qtceme               = 0.0
      Don_conv%qtmes1               = 0.0
      Don_conv%qtren1               = 0.0
      Don_conv%temptr               = 0.0
      Don_conv%wtp1                 = 0.0
      Don_conv%wetdepc              = 0.0
      Don_conv%wetdepm              = 0.0
      Don_conv%wetdept              = 0.0

!---------------------------------------------------------------------
!    allocate the components of the donner_cape_type variable Don_cape.
!    definitions of these arrays are found in donner_types.h.
!---------------------------------------------------------------------
      allocate (Don_cape%coin       (isize, jsize) )
      allocate (Don_cape%plcl       (isize, jsize) )
      allocate (Don_cape%plfc       (isize, jsize) )
      allocate (Don_cape%plzb       (isize, jsize) )
      allocate (Don_cape%qint_lag   (isize, jsize) )
      allocate (Don_cape%qint       (isize, jsize) )
      allocate (Don_cape%xcape_lag  (isize, jsize) )
      allocate (Don_cape%xcape      (isize, jsize) )
      if (Nml%do_donner_cape) then
        allocate (Don_cape%cape_p     (isize, jsize, nlev_hires) )
        allocate (Don_cape%env_r      (isize, jsize, nlev_hires) )
        allocate (Don_cape%env_t      (isize, jsize, nlev_hires) )
        allocate (Don_cape%parcel_r   (isize, jsize, nlev_hires) )
        allocate (Don_cape%parcel_t   (isize, jsize, nlev_hires) )
      else
        allocate (Don_cape%cape_p     (isize, jsize, nlev_lsm) )!miz
        allocate (Don_cape%env_r      (isize, jsize, nlev_lsm) )!miz
        allocate (Don_cape%env_t      (isize, jsize, nlev_lsm) )!miz
        allocate (Don_cape%parcel_r   (isize, jsize, nlev_lsm) )!miz
        allocate (Don_cape%parcel_t   (isize, jsize, nlev_lsm) )!miz
      end if
      allocate (Don_cape%model_p    (isize, jsize, nlev_lsm) )
      allocate (Don_cape%model_r    (isize, jsize, nlev_lsm) )
      allocate (Don_cape%model_t    (isize, jsize, nlev_lsm) )

!---------------------------------------------------------------------
!    initialize the components of the donner_cape_type variable Don_cape.
!---------------------------------------------------------------------
      Don_cape%coin        = 0.0
      Don_cape%plcl        = 0.0
      Don_cape%plfc        = 0.0
      Don_cape%plzb        = 0.0   
      Don_cape%qint_lag    = 0.0
      Don_cape%qint        = 0.0
      Don_cape%xcape_lag   = 0.0 
      Don_cape%xcape       = 0.0 
      Don_cape%cape_p      = 0.0
      Don_cape%env_r       = 0.0
      Don_cape%env_t       = 0.0
      Don_cape%parcel_r    = 0.0
      Don_cape%parcel_t    = 0.0
      Don_cape%model_p     = 0.0
      Don_cape%model_r     = 0.0
      Don_cape%model_t     = 0.0

!---------------------------------------------------------------------
!    allocate the components of the donner_rad_type variable Don_rad.
!    definitions of these arrays are found in donner_types.h.
!---------------------------------------------------------------------
      allocate (Don_rad%cell_cloud_frac  (isize, jsize, nlev_lsm) )
      allocate (Don_rad%cell_ice_amt     (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%cell_ice_size    (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%cell_liquid_amt  (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%cell_liquid_size (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%cell_droplet_number (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%meso_cloud_frac  (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%meso_ice_amt     (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%meso_ice_size    (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%meso_liquid_amt  (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%meso_liquid_size (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%meso_droplet_number (isize, jsize, nlev_lsm ) )
      allocate (Don_rad%nsum             (isize, jsize) )

!---------------------------------------------------------------------
!    initialize the components of the donner_rad_type variable Don_rad 
!    using the input variables supplied.
!---------------------------------------------------------------------
      Don_rad%cell_cloud_frac  = cell_cld_frac
      Don_rad%cell_ice_amt     = cell_ice_amt
      Don_rad%cell_ice_size    = cell_ice_size
      Don_rad%cell_liquid_amt  = cell_liq_amt
      Don_rad%cell_liquid_size = cell_liq_size
      Don_rad%cell_droplet_number = cell_droplet_number
      Don_rad%meso_cloud_frac  = meso_cld_frac
      Don_rad%meso_ice_amt     = meso_ice_amt
      Don_rad%meso_ice_size    = meso_ice_size
      Don_rad%meso_liquid_amt  = meso_liq_amt
      Don_rad%meso_liquid_size = meso_liq_size
      Don_rad%meso_droplet_number = meso_droplet_number
      Don_rad%nsum             = nsum

  if (Nml%do_ensemble_diagnostics) then
!--------------------------------------------------------------------
!    allocate module variables for Donner cumulus ensemble member
!    diagnostics.  These are stored in the derived-type variable
!    Don_cem; see donner_types.h for description of these variables.
!    "ncem" is the number of cumulus ensemble members
!--------------------------------------------------------------------
      ncem = Param%kpar
      allocate ( Don_cem%pfull               (isize, jsize, nlev_lsm ) )
      allocate ( Don_cem%phalf               (isize, jsize, nlev_lsm+1 ) )
      allocate ( Don_cem%zfull               (isize, jsize, nlev_lsm ) )
      allocate ( Don_cem%zhalf               (isize, jsize, nlev_lsm+1 ) )
      allocate ( Don_cem%temp                (isize, jsize, nlev_lsm ) )
      allocate ( Don_cem%mixing_ratio        (isize, jsize, nlev_lsm ) )
      allocate ( Don_cem%cell_precip         (isize, jsize, ncem ) )
      allocate ( Don_cem%pb                  (isize, jsize, ncem ) )
      allocate ( Don_cem%ptma                (isize, jsize, ncem ) )
      allocate ( Don_cem%h1                  (isize, jsize, nlev_lsm, ncem ) )
      if (Nml%do_donner_plume) then
        allocate ( Don_cem%qlw                 (isize, jsize, nlev_hires, ncem ) )
        allocate ( Don_cem%cfracice            (isize, jsize, nlev_hires, ncem ) )
        allocate ( Don_cem%wv                  (isize, jsize, nlev_hires, ncem ) )
        allocate ( Don_cem%rcl                 (isize, jsize, nlev_hires, ncem ) )
      else
        allocate ( Don_cem%qlw                 (isize, jsize, nlev_lsm, ncem ) )
        allocate ( Don_cem%cfracice            (isize, jsize, nlev_lsm, ncem ) )
        allocate ( Don_cem%wv                  (isize, jsize, nlev_lsm, ncem ) )
        allocate ( Don_cem%rcl                 (isize, jsize, nlev_lsm, ncem ) )
      endif
      allocate ( Don_cem%a1                  (isize, jsize ) )
      allocate ( Don_cem%meso_precip         (isize, jsize ) )
      allocate ( Don_cem%cual                (isize, jsize, nlev_lsm ) )
      allocate ( Don_cem%temperature_forcing (isize, jsize, nlev_lsm ) )

!--------------------------------------------------------------------
!    initialize variables for Donner cumulus ensemble member
!    diagnostics.
!--------------------------------------------------------------------
      Don_cem%pfull               = 0.
      Don_cem%phalf               = 0.
      Don_cem%zfull               = 0.
      Don_cem%zhalf               = 0.
      Don_cem%temp                = 0.
      Don_cem%mixing_ratio        = 0.
      Don_cem%cell_precip         = 0.
      Don_cem%meso_precip         = 0.
      Don_cem%pb                  = 0.
      Don_cem%ptma                = 0.
      Don_cem%h1                  = 0.
      Don_cem%qlw                 = 0.
      Don_cem%cfracice            = 0.
      Don_cem%wv                  = 0.
      Don_cem%rcl                 = 0.
      Don_cem%a1                  = 0.
      Don_cem%cual                = 0.
      Don_cem%temperature_forcing = 0.

  endif ! (do_ensemble_diagnostics)

!----------------------------------------------------------------------


end subroutine don_d_init_loc_vars_k



!####################################################################

subroutine don_d_column_input_fields_k  &
         (isize, jsize, nlev_lsm, dt, calc_conv_on_this_step, Col_diag, &
          temp, mixing_ratio, pfull, omega, phalf, parcel_rise, ermesg, error)

use donner_types_mod, only : donner_column_diag_type     

implicit none

!---------------------------------------------------------------------
!    subroutine don_d_column_input_fields_k outputs the 
!    basic profile information for any diagnostic columns.
!---------------------------------------------------------------------

integer,                            intent(in)  :: isize, jsize, nlev_lsm
real,                               intent(in)  :: dt
logical,                            intent(in)  :: calc_conv_on_this_step
type(donner_column_diag_type),      intent(in)  :: Col_diag
real, dimension(isize,jsize,nlev_lsm),                            &
                                    intent(in)  :: temp, mixing_ratio, &
                                                   pfull, omega
real, dimension(isize,jsize,nlev_lsm+1),                            &
                                    intent(in)  :: phalf
real, dimension(isize,jsize),       intent(in)  :: parcel_rise              
character(len=*),                   intent(out) :: ermesg
integer,                            intent(out) :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize         size of x-dimension of physics window
!     jsize         size of y-dimension of physics window
!     nlev_lsm      number of layers in large-scale model
!     dt            physics time step [ sec ]
!     calc_conv_on_this_step
!                   logical indicating whether the deep convection
!                   calculation is to be done on this timestep
!     Col_diag      donner_column_diagtype variable containing the
!                   information defining the columns fro which diagnos-
!                   tics are desired.
!     temp          temperature field at model levels [ deg K ]
!     mixing_ratio  vapor mixing ratio field at model levels 
!                   [ kg(h20) / kg(dry air) ]
!     pfull         pressure field at full-levels 1:nlev_lsm    [ Pa ]
!     omega         model omega field at model full levels 
!                   [ Pa / sec ]
!     phalf         pressure field at half-levels 1:nlev_lsm+1  [ Pa ]
!     parcel_rise   accumulated vertical displacement of a near-surface 
!                   parcel as a result of the lowest model level omega 
!                   field [ Pa ]
!
!   intent(out) variables:
!
!     ermesg        character string containing any error message
!                   that is returned from a kernel subroutine
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      integer :: idiag, jdiag, unitdiag
      integer :: n, k       

!----------------------------------------------------------------------
!   local variables:
!
!     idiag         physics window i index of current diagnostic column
!     jdiag         physics window j index of current diagnostic column
!     unitdiag      i/o unit assigned to current diagnostic column
!     n, k          do-loop indices
!
!-----------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    loop over the diagnostic columns in this physics window. output
!    the physics timestep and the window coordinates, and whether the 
!    convection calculation is to be done on this timestep.
!---------------------------------------------------------------------
      do n=1,Col_diag%ncols_in_window
        idiag = Col_diag%i_dc(n)
        jdiag = Col_diag%j_dc(n)
        unitdiag = Col_diag%unit_dc(n)
        write (unitdiag, '(a,f8.1, 2i4)')  &
                ' physics timestep, window i, window j= ',  &
                  dt, idiag, jdiag                         
        write (unitdiag,'(a,l4 )' )  ' conv_calc_on_this_step = ',   &
                  calc_conv_on_this_step

!----------------------------------------------------------------------
!    if the calculation is to be done on this timestep, and convection
!    in the column is not precluded by downward motion at the lowest 
!    level, output the column temperature and mixing ratio profiles
!    over the levels at which output has been requested.
!----------------------------------------------------------------------
        if (calc_conv_on_this_step) then
          if (omega(idiag,jdiag,nlev_lsm) < 0.0) then
            write (unitdiag, '(a)')  & 
                       '                      input profiles'
            write (unitdiag, '(a)')  &
                       '   k   press      temp           mixing ratio '
            write (unitdiag, '(a)')  &
                  '        hPa       deg K    g(h2o) / kg (dry air)  '
            do k=Col_diag%kstart,nlev_lsm
              write (unitdiag, '(i4, 2f10.4, 7x, 1pe13.5)')  &
                   k, 1.0E-02*pfull(idiag,jdiag,k), temp(idiag,jdiag,k),&
                   1.0e03*mixing_ratio(idiag,jdiag,k)
            end do
          endif 
        endif 

!---------------------------------------------------------------------
!    output the surface pressure, omega at the lowest level, and the 
!    accumulated parcel displacement.
!---------------------------------------------------------------------
        write (unitdiag,'(a,f13.4,1pe13.5)')  &
                  ' sfcprs (hPa),  omega_btm (Pa/sec)= ',   &
                  1.0E-02*phalf(idiag,jdiag,nlev_lsm+1),   &
                  omega(idiag,jdiag,nlev_lsm) 
        write (unitdiag,'(a,f13.6)')  ' omint (hPa)= ',   &
                  1.0E-02*parcel_rise(idiag,jdiag)
      end do

!---------------------------------------------------------------------


end subroutine don_d_column_input_fields_k 



!####################################################################

subroutine don_d_convection_driver_k    &
         (isize, jsize, nlev_lsm, nlev_hires, ntr, me,  &
          cloud_tracers_present, cbmf, dt, Nml,    &
          Initialized, Param, Col_diag, temp, mixing_ratio,  &
          pfull, zfull, zhalf, pblht, tkemiz, qstar, cush, coldT,  &!miz
          qlin, qiin, qain, lag_cape_temp, lag_cape_vapor,  &
          lag_cape_press, phalf, current_displ, land, sfc_sh_flux,  &
          sfc_vapor_flux, tr_flux, tracers, Don_cape, Don_conv, &
          Don_rad, Don_cem, temperature_forcing, moisture_forcing, &
          total_precip, &
          donner_humidity_factor, donner_humidity_area, dql, dqi, dqa, &
          mhalf_3d, &
          exit_flag, ermesg, error, sd, Uw_p, ac, cp, ct, Don_budgets)

use donner_types_mod, only : donner_initialized_type, donner_rad_type, &
                             donner_param_type, donner_conv_type, &
                             donner_nml_type, donner_budgets_type, &
                             donner_cem_type, &
                             donner_column_diag_type, donner_cape_type

use  conv_utilities_k_mod,only : adicloud, sounding, uw_params
use  conv_plumes_k_mod,only    : cplume, ctend
implicit none

!---------------------------------------------------------------------
!    subroutine don_d_convection_driver_k manages the cal-
!    culation of the effects of deep convection on atmospheric fields 
!    by calling routines to lift a parcel, determine if deep convection 
!    results and, if so, obtain the temperature and moisture forcing and 
!    precipitation produced, and the fields needed to assess the effects
!    of the deep convection on the radiative fluxes and heating and 
!    the large-scale cloud fields of the model.
!---------------------------------------------------------------------

integer,                         intent(in) :: isize, jsize, nlev_lsm,  &
                                               nlev_hires,    ntr, me
logical,                         intent(in) :: cloud_tracers_present
real, dimension(isize,jsize),    intent(inout) :: cbmf
real,                            intent(in) :: dt 
type(donner_nml_type),           intent(inout) :: Nml
type(donner_initialized_type),   intent(inout) :: Initialized
type(donner_param_type),         intent(in) :: Param
type(donner_column_diag_type),   intent(in) :: Col_diag
real,    dimension(isize,jsize,nlev_lsm),              &
                              intent(in)    :: temp, mixing_ratio,  &
                                               pfull, zfull, qlin, &
                                               qiin, qain,   &
                                               lag_cape_temp, &
                                               lag_cape_vapor, &
                                               lag_cape_press
real,    dimension(isize,jsize,nlev_lsm+1),                       &
                              intent(in)    ::  phalf, zhalf                  
real,    dimension(isize,jsize),                                     &
                              intent(in)    :: current_displ, pblht, &
                                               tkemiz, qstar, cush, land, &
                                               sfc_sh_flux,   &
                                               sfc_vapor_flux
logical, dimension(isize,jsize), intent(in) :: coldT
real,    dimension(isize,jsize,ntr),                             &
                              intent(in)    :: tr_flux        
real,    dimension(isize,jsize,nlev_lsm,ntr),                      &
                              intent(in)    :: tracers        
type(donner_cape_type),       intent(inout) :: Don_cape
type(donner_conv_type),       intent(inout) :: Don_conv
type(donner_budgets_type),       intent(inout) :: Don_budgets
type(donner_rad_type),        intent(inout) :: Don_rad
type(donner_cem_type),        intent(inout) :: Don_cem
real,    dimension(isize,jsize,nlev_lsm),                           &
                              intent(out)   :: temperature_forcing,&
                                               moisture_forcing
real,    dimension(isize,jsize),                                  &
                              intent(out)   :: total_precip
real,    dimension(isize,jsize,nlev_lsm),                              &
                              intent(out)   :: donner_humidity_factor, &
                                               donner_humidity_area, &
                                               dql, dqi, dqa
real,    dimension(isize,jsize,nlev_lsm+1),                          &
                              intent(out)   :: mhalf_3d  
character(len=*),             intent(out)   :: ermesg
integer,                      intent(out)   :: error
logical, dimension(isize,jsize),                                &
                              intent(out)   :: exit_flag
type(sounding),               intent(inout) :: sd
type(uw_params),               intent(inout) :: Uw_p
type(adicloud),               intent(inout) :: ac
type(cplume),                 intent(inout) :: cp
type(ctend),                  intent(inout) :: ct

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     ntr            number of tracers to be transported by donner
!                    convection
!     me             local pe number
!     dt             physics time step [ sec ]
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     Initialized    donner_initialized_type variable containing
!                    variables which are defiuned during initialization.
!                    these values may be changed during model execution.
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!                    tion parameterization
!     temp           temperature field at model levels [ deg K ]
!     mixing_ratio   vapor mixing ratio field at model levels 
!                    [ kg(h20) / kg(dry air) ]
!     pfull          pressure field on model full levels [ Pa ]
!     qlin           large-scale cloud liquid specific humidity 
!                    [ kg(h2o) / kg (moist air) ]
!     qiin           large-scale cloud ice specific humidity 
!                    [ kg(h2o) / kg (moist air) ]
!     qain           large-scale cloud fraction  
!                    [ fraction ]
!     lag_cape_temp  temperature field used in lag-time cape 
!                    calculation [ deg K ]
!     lag_cape_vapor vapor mixing ratio field used in lag-time
!                    cape calculation [ kg(h2o) / kg(dry air) ]
!     lag_cape_press model full-level pressure field used in 
!                    lag-time cape calculation  [ Pa ]
!     phalf          pressure field at half-levels 1:nlev_lsm+1  [ Pa ]
!     current_displ  low-level parcel displacement to use in cape
!                    calculation on this step [ Pa ]
!     land           fraction of grid box covered by land
!                    [ fraction ]
!     sfc_sh_flux    sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_vapor_flux water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     tr_flux        surface flux of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     tracers        tracer mixing ratios of tracers transported by the
!                    donner deep convection parameterization
!                    [ kg(tracer) / kg (dry air) ]
!
!   intent(inout) variables:
!
!     Don_cape       donner_cape type derived type variable containing 
!                    diagnostics and intermediate results related to the
!                    cape calculation associated with the donner convec-
!     Don_conv       donner_convection_type derived type variable
!                    containing diagnostics and intermediate results 
!                    describing the nature of the convection produced by
!                    the donner parameterization
!     Don_rad        donner_rad_type derived type variable used to hold 
!                    those fields needed to connect the donner deep 
!                    convection parameterization and the model radiation 
!                    package
!     Don_cem        donner_cem_type derived type variable containing
!                    Donner cumulus ensemble member diagnostics
!
!   intent(out) variables:
!
!     temperature_forcing  
!                    temperature tendency due to donner convection
!                    [ deg K / sec ]
!     moisture_forcing  
!                    vapor mixing ratio tendency due to donner 
!                    convection [ kg(h2o) / (kg(dry air) sec ) ]
!     total_precip   total precipitation rate produced by the
!                    donner parameterization [ mm / day ]
!     donner_humidity_ratio
!                    ratio of large-scale specific humidity to specific 
!                    humidity in environment outside convective system
!                    [ dimensionless ]
!     donner_humidity_area
!                    fraction of grid box in which humidity is affected
!                    by the deep convection, defined as 0.0 below cloud
!                    base and above the mesoscale updraft, and as the
!                    sum of the cell and mesoscale cloud areas in 
!                    between. it is used in strat_cloud_mod to determine
!                    the large-scale specific humidity field for the
!                    grid box. DO NOT use for radiation calculation,
!                    since not all of this area includes condensate.
!                    [ fraction ]
!     dql            tendency of cloud liquid specific humidity
!                    due to donner convection 
!                    [ kg(h2o) / kg(moist air) / sec ]
!     dqi            tendency of cloud ice specific humidity
!                    due to donner convection 
!                    [ kg(h2o) / kg(moist air) / sec ]
!     dqa            tendency of large-scale cloud area
!                    due to donner convection 
!                    [ fraction / sec ]
!     exit_flag      logical array indicating whether deep convection 
!                    exists in a column
!     ermesg         character string containing any error message
!                    that is returned from a kernel subroutine
!
!----------------------------------------------------------------------
!   local variables:
 
     integer :: i, j, k, n
!    real, dimension(isize, jsize, nlev_lsm) :: alpha
     real    :: press0, press1, qlw_wd, qrw_wd, qrw_col_wd, delta_tracer, air_density_wd, tv_wd
 
!---------------------------------------------------------------------
!   local variables:
!
!      i, j, k, n       do-loop indices
!      press0, press1   pressure levels
!      qlw_wd           cloud ice (kg/kg)
!      qrw_wd           mesoscale precip per timestep (kg/m3)
!      qrw_col_wd       mesoscale precip per timestep (kg/kg)
!      delta_tracer     tracer change from mesoscale wet deposition (tracer units)
!      air_density_wd   air density (kg/m3)
!      tv_wd            virtual temperature (K)
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    call don_c_def_conv_env_k to determine how 
!    a parcel will behave with respect to deep convection in each model
!    column.
!---------------------------------------------------------------------
      if (Nml%do_donner_cape) then
        call don_c_def_conv_env_k          &
            (isize, jsize, nlev_lsm, nlev_hires, Nml, Param,  &
             Initialized, Col_diag, &
             temp, mixing_ratio, pfull, lag_cape_temp, lag_cape_vapor,  &
             lag_cape_press, current_displ, cbmf, Don_cape, Don_conv, ermesg, error)
      else
        call don_c_def_conv_env_miz   &
           (isize, jsize, nlev_lsm, ntr, dt, Nml, Param, Initialized, &
            Col_diag, tracers, pblht, tkemiz, qstar, cush, land, coldT,     &
           temp, mixing_ratio, pfull, phalf, zfull, zhalf,   &
           lag_cape_temp, lag_cape_vapor, current_displ, cbmf, Don_cape,  &
           Don_conv, sd, Uw_p, ac)
      endif

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call don_d_cupar to calculate the normalized deep convective 
!    forcing.
!---------------------------------------------------------------------
      call don_d_cupar_k     &
           (isize, jsize, nlev_lsm, nlev_hires, ntr, me, dt, Col_diag, &
            Param, Nml, Initialized, cbmf, current_displ, sfc_sh_flux, &
            sfc_vapor_flux, temp, mixing_ratio, pblht, tkemiz, qstar, &
            cush, land, coldT, pfull, phalf,&
            zfull, zhalf, sd, Uw_p, ac, cp, ct, tr_flux, tracers,    &
            Don_conv, Don_cape, Don_cem, temperature_forcing, &
            moisture_forcing, &
            total_precip, Don_budgets, ermesg, error, exit_flag)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    call define_donner_anvil_ice to define the ice content profile
!    (Don_conv%xice) and the pressures at top and bottom of mesoscale
!    anvil (Don_conv%prztm, Don_conv%przm).
!----------------------------------------------------------------------
      call don_m_define_anvil_ice_k   &
           (isize, jsize, nlev_lsm, Param, Col_diag, pfull, temp,    &
            exit_flag, Don_conv, ermesg, error)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!   Calculate wet deposition in mesoscale updraft here. Use:
!   Don_conv%meso_precip(isize,jsize): grid average (mm/day)
!   Don_conv%temptr(isize,jsize,nlev_lsm,ntr): tracer concentration in
!   mesoscale updraft (kg(tracer)/kg) This quantity is meaningful
!   only for pressure values p in the mesoscale updraft 
!   (pzm <= p <= pztm). It is defined on the pfull pressure surfaces.
!   pfull(isize,jsize,nlev_lsm): pressures (Pa) on full levels
!   phalf(isize,jsize,nlev_lsm+1): pressures (Pa) on half levels
!   Index convention for pressure levels:
!      -----  phalf(1)  (top of GCM grid)
!      -----  pfull(1)
!      -----  phalf(2)
!       ...
!      -----  pfull(k-1)
!      -----  phalf(k)
!      -----  pfull(k)
!      -----  phalf(k+1)
!       ...
!      -----  pfull(nlev_lsm)
!      -----  phalf(nlev_lsm+1)  (bottom of GCM grid)
!   Don_conv%pztm_v(isize,jsize): pressure at top of mesoscale updraft 
!                                 (Pa)
!   Don_conv%pzm_v(isize,jsize): pressure at base of mesoscale updraft 
!                                (Pa)
!   Don_conv%ampta1(isize,jsize): fractional area of mesoscale updraft
!   Don_conv%qtmes1(isize,jsize,nlev_lsm,ntr): grid-average tracer 
!                                              tendency
!   due to mesoscale updraft (kg(tracer)/(kg sec))
!   Don_conv%xice(isize,jsize,nlev_lsm): ice mass mixing ratio in
!   mesocale updfraft  (kg(ice)/kg)
!----------------------------------------------------------------------
      do j=1,jsize
      do i=1,isize
        if (Don_conv%meso_precip(i,j) > 1.e-20 .and. &
            Don_conv%ampta1(i,j) > 1.e-20) then
! convert precip from mm/day to kg/kg/timestep to kg/m3/timestep
           qrw_col_wd = Don_conv%meso_precip(i,j)*dt/Param%seconds_per_day * 1.e-3*Param%dens_h2o ! kg/m2/timestep
           qrw_col_wd = qrw_col_wd * Param%grav / ( Don_conv%pzm_v(i,j)-Don_conv%pztm_v(i,j) )    ! kg/kg/timestep
! convert precip from large-scale average to in-cloud rain amount
           qrw_col_wd = qrw_col_wd / Don_conv%ampta1(i,j)
           do k=1,nlev_lsm
             if (phalf(i,j,k) >= Don_conv%pzm_v(i,j)) then
               exit
             elseif (phalf(i,j,k+1) > Don_conv%pztm_v(i,j)) then
               press0 = MIN(phalf(i,j,k+1),Don_conv%pztm_v(i,j))
               press1 = MAX(phalf(i,j,k),Don_conv%pzm_v(i,j))
               qlw_wd = Don_conv%xice(i,j,k)
! convert precip from kg/kg/timestep to kg/m3/timestep
               tv_wd = temp(i,j,k) &
                       * ( 1 + Param%D608*mixing_ratio(i,j,k)/(1+mixing_ratio(i,j,k)) )
               air_density_wd = 0.5*(press0+press1)/(Param%rdgas*tv_wd)
               qrw_wd = qrw_col_wd * air_density_wd
               do n = 1,size(Don_conv%temptr,4)
                  if (Initialized%wetdep(n)%Lwetdep) then
                     call wet_deposition_0D( Initialized%wetdep(n)%Henry_constant, &
                                             Initialized%wetdep(n)%Henry_variable, &
                                             Initialized%wetdep(n)%frac_in_cloud, &
                                             Initialized%wetdep(n)%alpha_r, &
                                             Initialized%wetdep(n)%alpha_s, &
                                             temp(i,j,k), &
                                             press0, press1, air_density_wd, &
                                             qlw_wd, 0., qrw_wd, &
                                             Don_conv%temptr(i,j,k,n), &
                                             Initialized%wetdep(n)%Lgas, &
                                             Initialized%wetdep(n)%Laerosol, &
                                             Initialized%wetdep(n)%Lice, &
                                             delta_tracer )
                     Don_conv%wetdepm(i,j,k,n) = -Don_conv%ampta1(i,j)* delta_tracer/dt
                     Don_conv%wetdept(i,j,k,n) = Don_conv%wetdept(i,j,k,n) &
                                               + Don_conv%wetdepm(i,j,k,n)
                  end if
               end do
             end if
           end do
        end if
      end do
      end do

!---------------------------------------------------------------------
!    check for tracer realizability, and limit convective tendencies
!    if necessary.
!---------------------------------------------------------------------
      call don_d_check_trc_rlzbility( isize, jsize, nlev_lsm, ntr, dt, &
                                              tracers, Don_conv )

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call donner_rad_driver to define the cloud ice, cloud liquid and
!    cloud areas of the cell and mesoscale clouds associated with 
!    donner convection so as to make them available to the radiation
!    code.
!---------------------------------------------------------------------
      call don_r_donner_rad_driver_k   &
           (isize, jsize, nlev_lsm, Param, Col_diag, Initialized, &
            pfull, temp, land, exit_flag, Don_conv, Don_rad, Nml, ermesg, error)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call donner_lscloud_driver to provide the connection between 
!    donner convection and the large-scale cloud scheme. 
!---------------------------------------------------------------------
      if (Nml%do_donner_lscloud) then
      call don_l_lscloud_driver_k   &
           (isize, jsize, nlev_lsm, cloud_tracers_present, Param,  &
            Col_diag, pfull, temp, exit_flag,  &
            mixing_ratio, qlin, qiin, qain, phalf, Don_conv, &
            donner_humidity_factor, donner_humidity_area, dql, dqi,  &
            dqa, mhalf_3d, ermesg, error)
      else
       call don_l_lscloud_driver_miz   &
            (isize, jsize, nlev_lsm, cloud_tracers_present, Param,  &
             Col_diag, pfull, temp, exit_flag,  &
             mixing_ratio, qlin, qiin, qain, phalf, Don_conv, &
             donner_humidity_factor, donner_humidity_area, dql, dqi,  &
!            dqa,ermesg, error)
             dqa,mhalf_3d, ermesg, error)
      end if

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!!!  QUESTION 3:
!!     A BETTER COMMENT IS NEEDED HERE --
!!     WHY IS THIS REMOVAL NECESSARY ??
!    save the vapor and temperature forcing resulting from the donner
!    deep parameterization. remove from them the contributions due to  
!    vertical transport by the donner mass flux and the mesoscale flux.
!    also remove vapor and temperature tendencies
!    corresponding to these increments from the Donner cumulus
!    thermal forcing and moisture forcing, which included
!    them as evaporatation and/or sublimation in mulsub.
!    assumptions used in strat_cloud_donner_tend to relate detrainment
!    to net mass fluxes differ from those in mulsub, so the
!    increments here do not balance those in mulsub. the difference
!    remains as a phase change.
!    mulsub allowed ice and liquid from convective system to evaporate
!    and/or sublimate as part of thermal and moisture forcing terms
!    remove those tendencies here. different assumptions used to
!    calculate these increments/tendencies here and in mulsub, so
!    some residual phase change will generally remain.
!---------------------------------------------------------------------
      Don_conv%conv_temp_forcing(:,:,:)  = temperature_forcing(:,:,:)
      Don_conv%conv_moist_forcing(:,:,:) = moisture_forcing(:,:,:)

      if (cloud_tracers_present) then
        
        moisture_forcing(:,:,:) = moisture_forcing(:,:,:) - &
                       dql(:,:,:) - dqi(:,:,:)
        temperature_forcing(:,:,:) = temperature_forcing(:,:,:) +   &
                      (dql(:,:,:)*Param%hlv + dqi(:,:,:)*Param%hls)/  &
                                                          (Param%cp_air)
      endif
       
!---------------------------------------------------------------------


end subroutine don_d_convection_driver_k

!######################################################################

subroutine don_d_cupar_k     &
         (isize, jsize, nlev_lsm, nlev_hires, ntr, me, dt, Col_diag, &
          Param, Nml, Initialized, cbmf, current_displ, sfc_sh_flux,   &
          sfc_vapor_flux,                                        &
          temp, mixing_ratio, pblht, tkemiz, qstar, cush, land, coldT, & !miz 
          pfull, phalf, zfull, zhalf,  &
          sd, Uw_p, ac,cp, ct, & !miz
          tr_flux, tracers, &
          Don_conv, Don_cape, Don_cem, temperature_forcing, &
          moisture_forcing,  &
          total_precip, Don_budgets, &
          ermesg, error, exit_flag)

!----------------------------------------------------------------------
!    subroutine cupar drives the parameterization for deep cumulus 
!    convection. it returns the temperature and moisture forcing assoc-
!    iated with deep convection, the total convective precipitation
!    and various diagnostics contained in Don_conv and Don_cape to the 
!    calling routine. it is based on (Donner, 1993, J.Atmos.Sci.).
!---------------------------------------------------------------------

use donner_types_mod, only : donner_initialized_type, donner_nml_type, &
                             donner_param_type, donner_conv_type, &
                             donner_budgets_type, donner_cem_type, &
                             donner_column_diag_type, donner_cape_type
use conv_utilities_k_mod, only : sounding, adicloud, uw_params
use  conv_plumes_k_mod,   only    : cplume, ctend
implicit none

!--------------------------------------------------------------------- 
integer,                           intent(in)    :: isize, jsize,    &
                                                    nlev_lsm,    &
                                                    nlev_hires,&
                                                    ntr, me
real,                              intent(in)    :: dt
type(donner_column_diag_type),     intent(in)    :: Col_diag
type(donner_param_type),           intent(in)    :: Param
type(donner_nml_type),             intent(in)    :: Nml
type(donner_initialized_type),     intent(inout) :: Initialized
type(sounding),                    intent(inout) :: sd
type(uw_params),                   intent(inout) :: Uw_p
type(adicloud),                    intent(inout) :: ac
type(cplume),                      intent(inout) :: cp
type(ctend),                       intent(inout) :: ct
real,    dimension(isize,jsize),   intent(in)    :: pblht, tkemiz, &
                                                    qstar, cush, land
logical, dimension(isize,jsize),   intent(in)    :: coldT

real,    dimension(isize,jsize),   intent(inout)    :: cbmf
real,    dimension(isize,jsize),   intent(in)    :: current_displ, &
                                                    sfc_sh_flux,  &
                                                    sfc_vapor_flux
real,    dimension(isize,jsize,nlev_lsm),                      &
                                   intent(in)    :: pfull, temp, &
                                                    mixing_ratio, zfull
real,    dimension(isize,jsize,nlev_lsm+1),                    &  
                                   intent(in)    :: phalf, zhalf
real,    dimension(isize,jsize,ntr),                           &
                                   intent(in)    :: tr_flux
real,    dimension(isize,jsize,nlev_lsm,ntr),               &
                                   intent(in)    :: tracers
type(donner_conv_type),            intent(inout) :: Don_conv
type(donner_budgets_type),            intent(inout) :: Don_budgets
type(donner_cape_type),            intent(inout) :: Don_cape
type(donner_cem_type),             intent(inout) :: Don_cem
real,    dimension(isize,jsize,nlev_lsm),                      &
                                   intent(out)   :: temperature_forcing,&
                                                    moisture_forcing
real,    dimension(isize,jsize),   intent(out)   :: total_precip
character(len=*),                  intent(out)   :: ermesg
integer,                           intent(out)   :: error
logical, dimension(isize,jsize),   intent(out)   :: exit_flag

!-----------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     ntr            number of tracers to be transported by donner
!                    convection
!     me             local pe number
!     dt             physics time step [ sec ]
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!                    tion parameterization
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     Initialized    donner_initialized_type variable containing
!                    variables which are defiuned during initialization.
!                    these values may be changed during model execution.
!     current_displ  low-level parcel displacement to use in cape
!                    calculation on this step [ Pa ]
!     sfc_sh_flux    sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_vapor_flux water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     pfull          pressure field at model full levels [ Pa ]
!     temp           temperature field at model full levels [ deg K ]
!     phalf          pressure field at half-levels 1:nlev_lsm+1  [ Pa ]
!     tr_flux        flux across the surface of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     tracers        tracer fields that are to be transported by donner
!                    convection [ kg (tracer) / kg (dry air) ]
!
!   intent(out) variables:
!    
!     temperature_forcing
!                    time tendency of temperature due to deep 
!                    convection [ deg K / sec ]
!     moisture_forcing
!                    time tendency of vapor mixing ratio due to deep 
!                    convection [ kg(h2o) / kg(dry air) / sec ]
!     total_precip   precipitation generated by deep convection
!                    [ kg / m**2 ]
!     exit_flag      logical array indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    each model column 
!     ermesg         character string containing any error message
!                    that is returned from a kernel subroutine
!
!   intent(inout) variables:
!
!     Don_conv       donner_convection_type derived type variable 
!                    containing fields produced by the donner_deep
!                    convection mod 
!     Don_cape       donner_cape_type derived type variable containing
!                    fields associated with the calculation of
!                    convective available potential energy (cape).
!     Don_cem        donner_cem_type derived type variable containing
!                    Donner cumulus ensemble member diagnostics
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:


      real, dimension (isize, jsize, nlev_lsm, ntr) :: xgcm_v
      real, dimension (isize, jsize, ntr)           :: sfc_tracer_flux
      integer                                       :: i, j, k, n 
      integer                                       :: kcb

!---------------------------------------------------------------------
!   local variables:
!
!      xgcm_v              tracer mixing ratio fields transported by 
!                          donner convection, index 1 nearest surface
!                          [ kg(tracer) / kg (dry air) ]
!      sfc_tracer_flux     tracer flux across the surface
!                          [ kg(tracer) / (m**2 sec) ]
!      i, j, k, n          do-loop indices
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    write a message to the output file for each diagnostic column in 
!    this window.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          write (Col_diag%unit_dc(n), '(a, 2i4)')  &
           'cupar: entering cupar with i_dc, j_dc:',    &
                           Col_diag%i_dc(n), Col_diag%j_dc(n)
        end do
      endif

!----------------------------------------------------------------------
!    call donner_deep_check_for_deep_convection_k to determine if deep 
!    convection may at this time be precluded in any of the columns of 
!    this physics window. logical array exit_flag is returned, with a 
!    value of .false. if donner convection is still allowed, a value of 
!    .true. if deep convection is precluded in a particular coluumn.
!----------------------------------------------------------------------
      call don_d_check_for_deep_conv_k   &
           (isize, jsize, nlev_lsm, dt, Param, Nml, Col_diag, &
             Initialized, &
            current_displ, cbmf, Don_cape, Don_conv, exit_flag, ermesg, error)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!-------------------------------------------------------------------
!    for the tracers that are to be transported by donner_deep_mod,
!    define the tracer input fields that will be needed by the donner
!    cloud model.
!-------------------------------------------------------------------
      if (Initialized%do_donner_tracer) then

!-------------------------------------------------------------------
!    define the tracer fluxes across the surface.
!-------------------------------------------------------------------
        sfc_tracer_flux(:,:,:) = tr_flux(:,:,:)

!-------------------------------------------------------------------
!    define an inverted tracer profile (index 1 nearest ground) for use
!    in the cloud and convection routines.
!------------------------------------------------------------------
        do k=1,nlev_lsm
          xgcm_v(:,:,k,:) = tracers(:,:,nlev_lsm-k+1,:)
        end do

!--------------------------------------------------------------------
!    if tracers are not to be transported by donner_deep_mod, define
!    these tracer input fields to be 0.0.
!--------------------------------------------------------------------
      else
        xgcm_v = 0.
        sfc_tracer_flux = 0.0
      endif 

      if (Nml%do_ensemble_diagnostics) then
!--------------------------------------------------------------------
!    save "Don_cem" diagnostics
!--------------------------------------------------------------------
        Don_cem%pfull = pfull
        Don_cem%phalf = phalf
        Don_cem%zfull = zfull
        Don_cem%zhalf = zhalf
        Don_cem%temp = temp
        Don_cem%mixing_ratio = mixing_ratio
      endif
      
!---------------------------------------------------------------------
!    call subroutine mulsub to calculate normalized (in-cloud) cumulus 
!    forcings, one column at a time. the forcings are normalized by the 
!    cloud area at cloud base level a_1(p_b).
!---------------------------------------------------------------------
      call don_d_mulsub_k   &
           (isize, jsize, nlev_lsm, nlev_hires, ntr, me, dt, Param,   &
!++lwh
            Nml, Col_diag,   &
            Initialized,   &
            temp, mixing_ratio, pblht, tkemiz, qstar, cush, cbmf, land, coldT,  &
            phalf, pfull, zhalf, zfull,  &
            sd, Uw_p, ac, cp, ct, &
           sfc_vapor_flux, sfc_sh_flux, &
!--lwh
            sfc_tracer_flux, xgcm_v, Don_cape, Don_conv, Don_cem, exit_flag,  &
            total_precip, temperature_forcing, moisture_forcing, &
            Don_budgets, ermesg, error)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    if using cloud base mass flux calculated by uw_conv_mod in donner
!    deep parameterization closure, modify the cloud fractional area
!    to avoid exceeding this limit.
!---------------------------------------------------------------------
     if (Initialized%using_unified_closure) then
       
!---------------------------------------------------------------------
!    define the cbmf associated with the donner convection.
!---------------------------------------------------------------------
       do j=1,jsize
         do i=1,isize
           if ( .not. exit_flag(i,j)) then
!--------------------------------------------------------------------
!    if there is no cloud base mass flux, there will be no deep 
!    convection in this column.
!--------------------------------------------------------------------
!            if (cbmf(i,j) == 0.0) then
!              exit_flag(i,j) = .true.
!              Don_conv%a1(i,j) = 0.
!              cycle
!            endif

!---------------------------------------------------------------------
!    determine the cloud base level kcb.
!---------------------------------------------------------------------
             kcb = -6
             do k=1, nlev_lsm
               if (Don_conv%uceml(i,j,nlev_lsm-k+1) > 0.0) then
                 kcb = nlev_lsm -k + 1
                 exit
               endif
             end do
             if (kcb == -6) then
               ermesg = 'no cloud base level found'
               error = 1
               return
             endif

!--------------------------------------------------------------------
!    if the cloud base mass flux predicted by donner is more than is
!    available, reduce the donner cloud fraction so that only the
!    available mass flux is used by donner clouds. set the cbmf to be
!    returned and made available for uw shallow convection to 0.0.
!--------------------------------------------------------------------
             if (Don_conv%uceml(i,j,kcb)*Don_conv%a1(i,j) >=    &
                                                       cbmf(i,j)) then
               Don_conv%a1(i,j) = cbmf(i,j)/Don_conv%uceml(i,j,kcb)
               cbmf(i,j) = 0.0

!--------------------------------------------------------------------
!    if the cloud base mass flux predicted by donner is less than what
!    is available, reduce the available cbmf by the amount used by the
!    donner clouds. the remainder will be made available for uw shallow 
!    convection.
!--------------------------------------------------------------------
             else
               cbmf(i,j) = cbmf(i,j) -    &
                               Don_conv%uceml(i,j,kcb)*Don_conv%a1(i,j)
             endif
           endif
         end do
       end do
     endif

!---------------------------------------------------------------------
!    call remove_normalization to remove the normalization from the 
!    deep convection diagnostics and forcing terms by multiplying them 
!    by the fractional cloud area. the values thus become grid-box 
!    averages, rather than averages over the cloudy area, and so are 
!    ready to use in the large-scale model equations. all columns in
!    which exit_flag is .true. are given zero values for total_precip,
!    temperature_forcing and moisture_forcing.
!---------------------------------------------------------------------
      if (Nml%do_donner_plume) then
        call don_d_remove_normalization_k   &
              (isize, jsize, nlev_lsm, ntr, exit_flag, Don_conv, total_precip, &
              Initialized, &
              temperature_forcing, moisture_forcing, ermesg, error)
      else
        call don_d_remove_normalization_miz &
              (isize, jsize, nlev_lsm, ntr, exit_flag, Nml, Don_conv, total_precip, &
               Initialized, &
               temperature_forcing, moisture_forcing, ermesg, error)
      end if

      if (Nml%do_ensemble_diagnostics) then
!
!    save "Don_cem" diagnostics.
!
        Don_cem%a1 = Don_conv%a1
        Don_cem%cual = Don_conv%cual
        Don_cem%temperature_forcing = temperature_forcing
      endif

      do k=1,nlev_lsm
        Don_budgets%liq_prcp(:,:,k) =    &
                    Don_budgets%liq_prcp(:,:,k)*Don_conv%a1(:,:)
        Don_budgets%frz_prcp(:,:,k) =    &
                    Don_budgets%frz_prcp(:,:,k)*Don_conv%a1(:,:)
      end do
      if (Initialized%do_conservation_checks) then
        Don_budgets%vert_motion(:,:) =    &
                     Don_budgets%vert_motion(:,:)*Don_conv%a1(:,:)
        Don_budgets%lheat_precip(:,:) =   &
                    Don_budgets%lheat_precip(:,:)*Don_conv%a1(:,:)
      endif

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    in a diagnostics window, output various desired quantities.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          call don_d_output_cupar_diags_k    &
               (isize, jsize, nlev_lsm, Col_diag, n, exit_flag,   &
                total_precip, temperature_forcing, Don_conv, Don_cape, &
                ermesg, error)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return
        end do
      endif  ! (in_diagnostics_window)

!---------------------------------------------------------------------


end subroutine don_d_cupar_k


!#####################################################################


subroutine don_d_check_for_deep_conv_k   &
           (isize, jsize, nlev_lsm, dt, Param, Nml, Col_diag, &
             Initialized, &
            current_displ, cbmf, Don_cape, Don_conv, exit_flag, ermesg, error)

!---------------------------------------------------------------------
!    subroutine don_d_check_for_deep_conv_k tests for the 
!    sounding- and upward-motion-based criteria which will prevent deep 
!    convection from occurring in a column. if convection is precluded, 
!    the logical variable exit_flag is set to .true. and additional cal-
!    culations in that column will be skipped. if convection is deter-
!    mined to be possible, exit_flag is set to .false., and additional 
!    calculations in the column will be done.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_conv_type, &
                             donner_initialized_type, &
                             donner_column_diag_type, donner_cape_type,&
                             donner_nml_type

implicit none

!---------------------------------------------------------------------
integer,                          intent(in)    :: isize, jsize, nlev_lsm
real,                             intent(in)    :: dt
type(donner_param_type),          intent(in)    :: Param
type(donner_nml_type),            intent(in)    :: Nml
type(donner_column_diag_type),    intent(in)    :: Col_diag
type(donner_initialized_type),    intent(in)    :: Initialized
real,    dimension(isize,jsize),  intent(in)    :: current_displ, cbmf
type(donner_cape_type),           intent(inout) :: Don_cape
type(donner_conv_type),           intent(inout) :: Don_conv
logical, dimension (isize,jsize), intent(out)   :: exit_flag 
character(len=*),                 intent(out)   :: ermesg
integer,                          intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     dt             physics time step [ sec ]
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!                    tion parameterization
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     current_displ  low-level parcel displacement to use in cape
!                    calculation on this step [ Pa ]
!     cbmf
!
!   intent(inout) variables:
!
!     Don_cape       donner_cape_type derived type variable containing
!                    fields associated with the calculation of
!                    convective available potential energy (cape).
!     Don_conv       donner_convection_type derived type variable 
!                    containing fields produced by the donner_deep
!                    convection mod 
!
!   intent(out) variables:
!
!     ermesg         character string containing any error message
!                    that is returned from a kernel subroutine
!     exit_flag      logical array indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    each model column 
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
 
      real, dimension (isize, jsize)  ::  pdeet1, pdeet2
      integer                         :: idiag, jdiag, unitdiag
      integer                         :: i, j, k, n 

!---------------------------------------------------------------------
!   local variables:
!
!     pdeet1              pressure depth between the level of free 
!                         convection and the level of zero buoyancy 
!                         [ Pa ]
!     pdeet2              pressure depth between the level of free 
!                         convection and the pressure at lowest 
!                         large-scale model grid level 
!                         [ Pa ]
!     idiag               physics window i index of current diagnostic
!                         column
!     jdiag               physics window j index of current diagnostic
!                         column
!     unitdiag            i/o unit assigned to current diagnostic
!                         column
!     i, j, k, n          do-loop indices
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    process each column in the physics window.
!---------------------------------------------------------------------
      do j=1,jsize     
        do i=1,isize     

!---------------------------------------------------------------------
!    define the time rates of change of column convective available 
!    potential energy (Don_conv%dcape_v). 
!---------------------------------------------------------------------
          Don_conv%dcape(i,j) = (Don_cape%xcape(i,j) -          &
                                 Don_cape%xcape_lag(i,j))/dt

!---------------------------------------------------------------------
!    define the pressure depth between the level of free convection
!    and the level of zero buoyancy (pdeet1) and the pressure depth 
!    between the level of free convection and the pressure at lowest 
!    large-scale model grid level (pdeet2).
!---------------------------------------------------------------------
          pdeet1(i,j) = Don_cape%plfc(i,j) - Don_cape%plzb(i,j)
          pdeet2(i,j) = Don_cape%plfc(i,j) - Don_cape%model_p(i,j,1)

!---------------------------------------------------------------------
!    check that all criteria for deep convection are satisfied; if so,
!    set exit_flag to be .false., if any of the criteria are not sat-
!    isfied, set exit_flag to .true. the criteria which can be evaluated
!    at this time are:
!       1) cape (Don_Cape%xcape) must be positive;
!       2) cape must be increasing with time (Don_conv%dcape > 0);
!       3) pressure depth between lfc and lzb (pdeet1) must be greater 
!          than pdeep_cv;
!       4) the time-integrated upward displacement of a parcel from the
!          lowest model level (current_displ) must be sufficient to 
!          allow the parcel to have reached the lfc;
!       5) convective inhibition must be less than cdeep_cv.
!---------------------------------------------------------------------
          if ((Don_cape%xcape(i,j) <= 0.)        .or.  &
              (Don_conv%dcape(i,j) <= 0. .and. Nml%do_dcape)   .or. &
              (pdeet1(i,j) < Param%pdeep_cv.and. Nml%use_pdeep_cv) .or.&
       (Initialized%using_unified_closure .and. cbmf(i,j) == 0.) .or. &
  ((pdeet2(i,j)<current_displ(i,j)) .and. Nml%use_llift_criteria) .or. &
              (Don_cape%coin(i,j) > Param%cdeep_cv) )   then
            exit_flag(i,j) = .true.
          else
            exit_flag(i,j) = .false.
          endif
        end do
      end do

!--------------------------------------------------------------------
!    if in diagnostics window, output info concerning the status of
!    deep convection in this column.
!--------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          idiag = Col_diag%i_dc(n)
          jdiag = Col_diag%j_dc(n)
          unitdiag = Col_diag%unit_dc(n)

!--------------------------------------------------------------------
!    for any diagnostic columns in the window for which deep convection
!    is possible, output the integrated upward displacement 
!    (current_displ), the value of cape (Don_Cape%xcape), the time rate
!    of change of cape (Don_conv%dcape) and the logical variable 
!    indicating whether deep convection is precluded in this column 
!    (exit_flag).
!--------------------------------------------------------------------
          if (.not. exit_flag(idiag,jdiag)) then
            write (unitdiag, '(a, f20.12, f20.12, e20.12, l4)')   &
                  'in cupar: omint,cape,dcape, exit_flag',    &
                         current_displ  (idiag,jdiag),   &
                         Don_Cape%xcape (idiag,jdiag),       &
                         Don_conv%dcape (idiag,jdiag),       &
                         exit_flag      (idiag,jdiag)  

!--------------------------------------------------------------------
!    output various thermodynamic parameters (cp_air, cp_vapor, d622,  &
!    rdgas, hlv, rvgas), various sounding levels and features (cape, 
!    convective inhibition, level of zero buoyancy, level of free 
!    convection and the model soundings (p, t, mixing ratio).
!--------------------------------------------------------------------
            write (unitdiag, '(a, 2f12.4)')   &
                   'in cupar: cpi,cpv= ',Param%cp_air, Param%cp_vapor
            write (unitdiag, '(a, 2f12.6, f12.2)')  &
                   'in cupar: rocp,rair,latvap= ',Param%d622, &
                                       Param%rdgas, Param%hlv   
            write (unitdiag, '(a, f12.7)') 'in cupar: rvap= ',Param%rvgas
            write (unitdiag, '(a, 2f14.7, f19.10)')  &
                    'in cupar: cape,cin,plzb= ',  &
                  Don_cape%xcape(idiag,jdiag), &
                  Don_cape%coin(idiag,jdiag), &
                  Don_cape%plzb(idiag,jdiag)
            write (unitdiag, '(a, f19.10)') 'in cupar: plfc= ', &
                  Don_cape%plfc(idiag,jdiag)
            do k=1,nlev_lsm-Col_diag%kstart+1
              write (unitdiag, '(a, i4, f19.10, f20.14, e20.12)') &
                                   'in cupar: k,pr,t,q= ',k,   &
                    Don_cape%model_p(idiag,jdiag,k),   &
                    Don_cape%model_t(idiag,jdiag,k),   &
                    Don_cape%model_r(idiag,jdiag,k)
            end do

!----------------------------------------------------------------------
!    if convection is precluded, output information indicating why.
!----------------------------------------------------------------------
          else
            write (unitdiag, '(a)')   &
               'in cupar: exit_flag is .true., no further calculations&
                              & in this column at this time'
            write (unitdiag, '(a)')   &
                'in cupar: reason(s) for no deep convection:'

!----------------------------------------------------------------------
!    case of no upward motion at lowest level:    
!----------------------------------------------------------------------
            if (current_displ(idiag,jdiag) == 0) then
              write (unitdiag, '(a)')   &
                    'no upward motion at lowest level'
            else 

!----------------------------------------------------------------------
!    case of non-positive cape:    
!----------------------------------------------------------------------
              if (Don_cape%xcape(idiag,jdiag) <= 0.) then      
                write (unitdiag, '(a, f20.12)')   &
                       'non-positive cape, cape = ', &
                           Don_Cape%xcape(idiag,jdiag)      
              endif

!----------------------------------------------------------------------
!    case of non-positive cape time tendency:    
!----------------------------------------------------------------------
              if (Don_conv%dcape(idiag,jdiag) <= 0.) then      
                write (unitdiag, '(a, f20.12)')   &
                      'non-positive cape time tendency, dcape = ', &
                            Don_conv%dcape(idiag,jdiag)      
              endif

              if (Don_cape%plfc(idiag,jdiag) == 0.0 .or.   &
                  Don_cape%plzb(idiag,jdiag) == 0.0) then

!----------------------------------------------------------------------
!    case of sounding not having a level of free convection for 
!    specified parcel:    
!----------------------------------------------------------------------
                if (Don_cape%plfc(idiag,jdiag) == 0.0 ) then
                  write (unitdiag, '(a)')   &
                    'lfc is not definable for parcel used in cape &
                        &calculation'
                endif

!----------------------------------------------------------------------
!    case of sounding not having a level of zero buoyancy for 
!    specified parcel:    
!----------------------------------------------------------------------
                if (Don_cape%plzb(idiag,jdiag) == 0.0) then
                  write (unitdiag, '(a)')   &
                    'lzb is not definable for parcel used in cape &
                        &calculation'
                endif
              else 


!----------------------------------------------------------------------
!    case of sounding not providing a deep enough layer of positive
!    buoyancy:    
!----------------------------------------------------------------------
                if (pdeet1(idiag,jdiag) < Param%pdeep_cv) then      
                  write (unitdiag, '(a, f20.12, a, f20.12,a)')   &
                       'depth of positive buoyancy too shallow, &
                         &plfc - plzb = ',    &
                           pdeet1(idiag,jdiag)*1.0e-02, ' hPa, &
                         & needed depth =', Param%pdeep_cv*1.0e-02, ' hPa'
                endif
                if (Don_cape%plfc(idiag,jdiag) ==  0.0) then 

!----------------------------------------------------------------------
!    case of parcel having insufficient displacement to reach the level
!    of free convection:
!----------------------------------------------------------------------
                else if        &
                  (pdeet2(idiag,jdiag) < current_displ(idiag,jdiag)) then
                  write (unitdiag, '(a, f20.12, a, f20.12, a)')   &
                      'parcel displacement insufficient to reach lfc, &
                       &displacement =',    &
                           current_displ(idiag,jdiag)*1.0e-02, ' hPa, &
                       &needed displacement = ',  &
                            pdeet2(idiag,jdiag)*1.0e-02, ' hPa'
                endif
              endif

!----------------------------------------------------------------------
!    case of sounding having too much convective inhibition:
!----------------------------------------------------------------------
              if (Don_cape%coin(idiag,jdiag) > Param%cdeep_cv) then      
                write (unitdiag, '(a, f20.12, a, f20.12)')   &
                       'convective inhibition too large, cin   = ', &
                             Don_cape%coin(idiag,jdiag), &
                            'max allowable =', Param%cdeep_cv
              endif
            endif
          endif  ! (not exit_flag)
        end do
      endif

!--------------------------------------------------------------------


end subroutine don_d_check_for_deep_conv_k



!#####################################################################

subroutine don_d_mulsub_k   &
         (isize, jsize, nlev_lsm, nlev_hires, ntr, me, dt, Param, Nml, &
!++lwh
          Col_diag, Initialized,   &
          temp, mixing_ratio, pblht, tkemiz, qstar, cush, cbmf, land, coldT, & !miz
          phalf, pfull, zhalf, zfull, sd,  &
           Uw_p, ac,         cp, ct, &
          sfc_vapor_flux, sfc_sh_flux, &
!--lwh
          sfc_tracer_flux, xgcm_v, Don_cape, Don_conv, Don_cem, exit_flag, &
          total_precip, temperature_forcing, moisture_forcing,  &
          Don_budgets, ermesg, error)

!--------------------------------------------------------------------
!    subroutine don_d_mulsub_k calculates the thermal and moisture
!    forcing produced by an ensemble of cumulus elements and any meso-
!    scale circulation which the ensemble induces, following Donner 
!    (1993, JAS). See also LJD notes, "Cu Closure A," 2/97. calculations
!    at and below this subroutine level are done a column at a time, in 
!    only those columns for which the possibility of deep convection has
!    not yet been ruled out.
!
!                L. Donner  GFDL 27 Apr 97
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_conv_type, &
                             donner_nml_type, donner_column_diag_type, &
                             donner_budgets_type, donner_cem_type, &
!++lwh
                             donner_cape_type, donner_initialized_type
!--lwh
use  conv_utilities_k_mod,only : pack_sd_lsm_k, extend_sd_k,  &
                                adicloud, sounding, uw_params
use  conv_plumes_k_mod,only    : cplume, ctend

implicit none

!---------------------------------------------------------------------
integer,                      intent(in)     ::  isize, jsize, nlev_lsm,&
                                                 nlev_hires, ntr, me
real,                         intent(in)     ::  dt
type(donner_param_type),      intent(in)     ::  Param
type(donner_nml_type),        intent(in)     ::  Nml  
type(donner_column_diag_type),                           &
                              intent(in)     ::  Col_diag
!++lwh
type(donner_initialized_type), intent(in)    :: Initialized
!--lwh
real,    dimension(isize,jsize,nlev_lsm+1),                    &
                              intent(in)     ::  phalf, zhalf
real,    dimension(isize,jsize,nlev_lsm),                      &
                              intent(in)     ::  pfull, zfull, temp, mixing_ratio
type(sounding),               intent(inout)  ::  sd
type(uw_params),               intent(inout)  ::  Uw_p
type(adicloud),               intent(inout)  ::  ac
type(cplume),                 intent(inout)  ::  cp
type(ctend),                  intent(inout)  ::  ct
real, dimension(isize,jsize), intent(in)     ::  pblht, tkemiz, qstar, &
                                                 cush, cbmf, land
logical, dimension(isize,jsize), intent(in)  ::  coldT
real,    dimension(isize,jsize),                                &
                              intent(in)     ::  sfc_vapor_flux,  &
                                                 sfc_sh_flux
real,    dimension(isize,jsize,ntr),                              &
                              intent(in)     ::  sfc_tracer_flux       
real,    dimension(isize,jsize,nlev_lsm,ntr),               &
                              intent(in)     ::  xgcm_v
type(donner_cape_type),       intent(inout)  ::  Don_cape
type(donner_conv_type),       intent(inout)  ::  Don_conv
type(donner_cem_type),        intent(inout)  ::  Don_cem
type(donner_budgets_type),       intent(inout)  ::  Don_budgets
logical, dimension(isize,jsize),                            &
                              intent(inout)  ::  exit_flag
real,    dimension(isize,jsize),                          &
                              intent(out)    ::  total_precip        
real,    dimension(isize,jsize,nlev_lsm),                        &
                              intent(out)    ::  temperature_forcing, &
                                                 moisture_forcing
character(len=*),             intent(out)    ::  ermesg
integer,                      intent(out)    ::  error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     ntr            number of tracers to be transported by donner
!                    convection
!     me             local pe number
!     dt             physics time step [ sec ]
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     phalf          pressure field at half-levels 1:nlev_lsm+1  [ Pa ]
!     sfc_vapor_flux water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     sfc_sh_flux    sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_tracer_flux 
!                    flux across the surface of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     xgcm_v         tracer fields that are to be transported by donner
!                    convection. index 1 nearest the ground.
!                    [ kg (tracer) / kg (dry air) ]
!
!   intent(inout) variables:
!
!     Don_conv       donner_convection_type derived type variable 
!                    containing fields produced by the donner_deep
!                    convection mod 
!     Don_cape       donner_cape_type derived type variable containing
!                    fields associated with the calculation of
!                    convective available potential energy (cape).
!     Don_cem        donner_cem_type derived type variable containing
!                    Donner cumulus ensemble member diagnostics
!     exit_flag      logical array indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    each model column 
!
!   intent(out) variables:
!    
!     total_precip   precipitation generated by deep convection
!                    [ kg / m**2 ]
!     temperature_forcing
!                    time tendency of temperature due to deep 
!                    convection [ deg K / sec ]
!     moisture_forcing
!                    time tendency of vapor mixing ratio due to deep 
!                    convection [ kg(h2o) / kg(dry air) / sec ]
!     ermesg         character string containing any error message
!                    that is returned from a kernel subroutine
!
!---------------------------------------------------------------------

!
!     On Output:
!     
!     ampt             mesoscale cloud fraction, normalized by a(1,p_b)
!     contot           ratio of convective to total precipitation
!     cmui             normalized vertical integral of mesoscale-updraft
!                      deposition (kg(H2O)/((m**2) sec)
!     cmus(nlev)       normalized mesoscale-updraft deposition
!                      (kg(H2O)/kg/sec)
!     cual(nlev)       cloud fraction, cells+meso, normalized by a(1,p_b)
!     cuq(nlev)        ice content in cells, weighted by cell area,
!                      (kg(H2O)/kg)
!                      index 1 at model bottom
!     cuqll(nlev)      liquid content in cells, weighted by cell area,
!                      (kg(H2O)/kg)
!                      index 1 at model bottom
!     ecds(nlev)       normalized convective downdraft evaporation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     eces(nlev)       normalzed convective-updraft evporation/sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     emds(nlev)       normalized mesoscale-downdraft sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     emei             normalized vertical integral of mesoscale-updraft
!                      sublimation (kg(h2O)/((m**2) sec)
!     emes(nlev)       normalized mesoscale-updraft sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     disa(nlev)       normalized thermal forcing, cells+meso (K/sec)
!                      (excludes convergence of surface heat flux)
!                      index 1 at ground. Cumulus thermal forcing defined
!                      as in Fig. 3 of Donner (1993, JAS).
!     disb(nlev)       normalized cell entropy-flux convergence (K/sec)
!                      (excludes convergence of surface flux)
!                      index 1 at ground. Entropy-flux convergence divided
!                      by (p0/p)**(rd/cp).
!     disc(nlev)       normalized cell condensation/deposition
!                      (K/sec)
!                      index 1 at ground.
!     disd(nlev)       normalized cell moisture-flux convergence
!                      (excludes convergence of surface moisture flux)
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     dise(nlev)       normalized moisture forcing, cells+meso (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     dmeml(nlev)      mass flux in mesoscale downdraft (kg/((m**2) s))
!                      (normalized by a(1,p_b)) (index 1 at atmosphere
!                      bottom)
!     elt(nlev)        normalized melting (K/sec)
!                      index 1 at ground.
!     fre(nlev)        normalized freezing (K/sec)
!                      index 1 at ground.
!     pb               pressure at base of cumulus updrafts (Pa)
!     pmd              pressure at top of mesoscale downdraft (Pa)
!     pztm             pressure at top of mesoscale updraft (Pa)
!     mrmes(nlev)       normalized mesoscale moisture-flux convergence
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     qtmes(nlev,ncont)  tracer tendency due to mesoscale tracer-flux
!                        convergence (kg/kg/s) (normalized by a(1,p_b))
!                        index 1 at ground 
!     qtren_v          normalized tracer tendency due to cells...
!                      (lon,lat,vert,tracer index)
!                      Vertical index increases as height increases.
!     sfcq(nlev)       boundary-layer mixing-ratio tendency due to surface
!                      moisture flux (kg(H2O)/kg/sec)
!     sfch(nlev)       boundary-layer heating due to surface heat flux
!                      (K/sec)
!     tmes(nlev)       normalized mesoscale entropy-flux convergence
!                      (K/sec)
!                      Entropy-flux convergence is mesoscale component
!                      of second term in expression for cumulus thermal
!                      forcing in Fig. 3 of Donner (1993, JAS).
!                      index 1 at ground.
!     tpre_v           total normalized precipitation (mm/day)
!     detmfl(nlev)     normalized detrained mass flux from cell
!                      updrafts (kg/((m**2)*s)
!                      (index 1 at atmosphere bottom)
!     uceml(nlev)      normalized mass fluxes in cell updrafts
!                      (kg/((m**2)*s) 
!     umeml(nlev)      mass flux in mesoscale updraft (kg/((m**2) s))
!                      (normalized by a(1,p_b)) (index 1 at atmosphere
!                      bottom)
!                      index 1 at ground.
!     wmms(nlev)       normalized mesoscale deposition of water vapor from
!                      cells (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     wmps(nlev)       normalized mesoscale redistribution of water vapor
!                      from cells (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     wtp_v            tracer redistributed by mesoscale processes
!                      (kg/kg/s) (normalized by a(1,p_b))
!                      vertical index increases with increasing height
!                      (lon,lat,vert,tracer index)
!--------------------------------------------------------------------



!!  UNITS
!!     ensmbl_anvil_cond  ! [mm / day ]
!!    ucemh  [kg /sec / m**2 ]
!!    detmfh [kg /sec / m**2 ]
!!    conint [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    precip [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    q1     [ kg(h2o) / kg(air) / sec ]
!!    h1     [ kg(h2o) / kg(air) / sec ]
!!    cmf    [ g(h2o) / kg(air) /day ]
!!    rlh    [ kg(h2o) / kg(air) / day ]  * [ L / Cp ] = [ deg K / day ]
!!    h1_2   [ deg K / sec ]
!!    efc    [ deg K / day ]
!!    efchr  [ deg K / sec ]
!!    ehfh   [ kg(air) (deg K) / (sec**3 m)
!!    ctf    [ deg K / day ]
!!    disb_v [ deg K / day ]
!!    disc_v [ deg K / day ] 
!!    disn   [ deg K / day ] 
!!    ecd    [ g(h2o) / kg(air) / day ]
!!    ece    [ g(h2o) / kg(air) / day ]
!!    ecds_v [ g(h2o) / kg(air) / day ]
!!    eces_v [ g(h2o) / kg(air) / day ]
!!    enctf  [ deg K / day ]
!!    encmf  [ g(h2o) / kg(air) /day ]
!!    pf     [ (m**2 kg(h2o)) / (kg(air) sec) ]
!!    dpf    [ (m**2 kg(h2o)) / (kg(air) sec) ] ==>   
!!                                          [ kg(h2o)) / (kg(air) sec) ]
!!    qlw2   [ kg(h2o)) / (kg(air) sec) ]
!!    qlw    [ kg(h2o)) / kg(air) ]
!!    evap   [ kg(h2o)) / kg(air) ]
!!    evap_rate [ kg(h2o)) / (kg(air) sec) ]
!!    disg   [ deg K / day ]


!        cape     convective available potential energy (J/kg)
!        cin      convective inhibtion (J/kg)
!        cpd      specific heat of dry air at constant pressure (J/(kg K))
!        cpv      specific heat of water vapor [J/(kg K)]
!        dcape    local rate of CAPE change by all processes
!                 other than deep convection [J/(kg s)]
!        dqls     local rate of change in column-integrated vapor
!                 by all processes other than deep convection
!                 {kg(H2O)/[(m**2) s]}
!        epsilo   ratio of molecular weights of water vapor to dry air
!        gravm    gravity constant [m/(s**2)]
!        ilon     longitude index
!        jlat     latitude index
!        mcu      frequency (in time steps) of deep cumulus
!        current_displ  integrated low-level displacement (Pa)
!        cape_p   pressure at Cape.F resolution (Pa)
!                 Index 1 at bottom of model.
!        plfc     pressure at level of free convection (Pa)
!        plzb     pressure at level of zero buoyancy (Pa)
!        pr       pressure at Skyhi vertical resolution (Pa)
!                 Index 1 nearest ground  
!        q        large-scale vapor mixing ratio at Skyhi vertical resolution
!                 [kg(h2O)/kg]
!                 Index 1 nearest ground 
!        qlsd     column-integrated vapor divided by timestep for cumulus
!                 parameterization {kg(H2O)/[(m**2) s]}
!        r        large-scale vapor mixing ratio at Cape.F resolution
!                 [kg(h2O)/kg]
!                 Index 1 at bottom of model.
!        rpc      parcel vapor mixing ratio from Cape.F [kg(h2O)/kg]
!                 Index 1 at bottom of model.
!        rd       gas constant for dry air (J/(kg K))
!        rlat     latent heat of vaporization (J/kg)
!        rv       gas constant for water vapor (J/(kg K))
!        t        large-scale temperature at Skyhi vertical resolution (K)
!                 Index 1 nearest ground
!        tcape    large-scale temperature at Cape.F resolution (K)
!                 Index 1 at bottom of model.
!        tpc      parcel temperature from from Cape.F (K)
!                 Index 1 at bottom of model.
!
!     On Input as Parameters:
!
!        kmax     number of vertical levels at Skyhi resolution
!        kpar     number of cumulus sub-ensembles
!        ncap     number of vertical levels in Cape.F resolution
!




!      disa_v              thermal forcing due to deep convection
!                          index 1 nearest surface, normalized by 
!                          cloud area  [ deg K / sec ]
!      dise_v              moisture forcing due to deep convection
!                          index 1 nearest surface, normalized by 
!                          cloud area  [ kg(h2o) / (kg(dry air) *sec ) ]

!----------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_lsm,Don_budgets%n_water_budget) ::  wat_budg
      real, dimension(nlev_lsm,Don_budgets%n_enthalpy_budget) :: &
                                                               ent_budg
      real, dimension(nlev_lsm,Don_budgets%n_precip_paths,   &
                               Don_budgets%n_precip_types)  :: &
                                                               prc_budg
      real, dimension(nlev_lsm)               ::        &
              ensmbl_cloud_area, cutotal, cmus_tot, cuq, cuql_v, disa, &
              disb, disd, disv, dise, dmeml, uceml, umeml, &
              ecds_liq, ecds_ice, eces_liq, eces_ice,  &
              disc_liq, disc_ice, dism_liq, dism_liq_frz, &
              dism_liq_remelt, dism_ice, dism_ice_melted, &
              disp_liq, disp_ice, disz, disz_remelt, disp_melted, &
              disze1, disze2, disze3,                               &
              emds_liq, emds_ice, emes_liq, emes_ice, &
              mrmes, mrmes_up, mrmes_dn, tmes, tmes_up, tmes_dn, &
              wmms, wmps, detmfl, meso_cloud_area, disf,            &
              disn, enctf, encmf, disg_liq, disg_ice, &
              enev, ensmbl_melt, ensmbl_melt_meso, anvil_precip_melt, &
              ensmbl_freeze, ensmbl_freeze_meso, temp_tend_melt,  &
              liq_prcp, frz_prcp

      real, dimension(isize, jsize, nlev_lsm) :: disa_v, dise_v
      real, dimension (nlev_lsm)              :: rlsm_miz, emsm_miz, &
                                                 cld_press_miz
      real, dimension (nlev_hires)            :: rlsm, emsm, cld_press
      real, dimension( nlev_lsm,ntr)          :: ensmbl_wetc
      real, dimension( nlev_lsm,ntr)          :: qtmes, qtren, wtp, &
                                                 temptr
      real, dimension (nlev_hires,ntr)        :: etsm
      real, dimension (nlev_lsm+1)            :: phalf_c               

      real, dimension (nlev_lsm)       :: model_tx, model_rx, model_px
      real, dimension (nlev_hires)     :: env_r, env_t, cape_p, &
                                          parcel_r, parcel_t
      real         ::  lofactor
      real         ::  ampta1, ensmbl_cond, pb, ensmbl_precip,  &
                       pt_ens, max_depletion_rate, dqls_v,  &
                       ensmbl_anvil_cond_liq, ensmbl_anvil_cond_ice, &
                       ensmbl_anvil_cond_liq_frz, &
                       qlsd_v, frz_frac, lprcp, vrt_mot
      logical      ::  meso_frz_intg_sum, melting_in_cloud, lmeso, &
                                      debug_ijt
      integer      ::  diag_unit
      integer      ::  kinv,  kcont
      integer      ::  i, j, k, n, kk


!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!----------------------------------------------------------------------
!    initialize the output arrays.
!----------------------------------------------------------------------
      temperature_forcing = 0.
      moisture_forcing    = 0.
      total_precip        = 0.

!---------------------------------------------------------------------
!    output a message to all diagnostic files indicating entry into
!    subroutine don_d_mulsub_k.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          write(Col_diag%unit_dc(n), '(a, 2i4)')    &
            'in mulsub: i_dc,j_dc= ', Col_diag%i_dc(n), Col_diag%j_dc(n)
        end do
      endif

!--------------------------------------------------------------------
!    LOOP OVER COLUMNS IN CURRENT PHYSICS WINDOW:
!--------------------------------------------------------------------
      do j=1,jsize               
        do i=1,isize                 

!--------------------------------------------------------------------
!    if it is already known that convection is not possible in this 
!    column, cycle to end of this loop and process the next column.
!--------------------------------------------------------------------
          if (exit_flag(i,j)) cycle

!--------------------------------------------------------------------
!    determine if column diagnostics are requested for this column.
!    define the output unit and set debug_ijt to .true. if it is.
!--------------------------------------------------------------------
          debug_ijt = .false.
          diag_unit = -99
          if (Col_diag%in_diagnostics_window ) then
            do n=1,Col_diag%ncols_in_window
              if (j == Col_diag%j_dc(n) .and.      &
                  i == Col_diag%i_dc(n)) then
                debug_ijt = .true.
                diag_unit = Col_diag%unit_dc(n)
                exit
              endif
            end do
          endif

!---------------------------------------------------------------------
!    define an inverted interface level pressure profile phalf_c 
!    (level 1 at the surface).
!---------------------------------------------------------------------
          do k=1,nlev_lsm+1
            phalf_c(k) = phalf(i,j,nlev_lsm+2-k)
          end do

          if (.not. Nml%do_donner_closure .or. &
              .not. Nml%do_donner_plume)  then
            call pack_sd_lsm_k (Nml%do_lands, land(i,j), coldT(i,j), &
                                dt, pfull(i,j,:), phalf(i,j,:),  &
                                zfull(i,j,:), zhalf(i,j,:), &
                                temp(i,j,:), mixing_ratio(i,j,:),  &
                                xgcm_v(i,j,:,:), sd)
            call extend_sd_k (sd, pblht(i,j), .false., Uw_p) 
          endif

!--------------------------------------------------------------------
!    define factor to modify entrainment coefficients if option is
!    activated.
!--------------------------------------------------------------------
   if (Nml%do_donner_closure .or. Nml%do_donner_plume) then
     if (Nml%lochoice == 0) then
       lofactor = 1. - land(i,j) *(1.0 - Nml%lofactor0)
     else if (Nml%lochoice == 1) then
       lofactor = Nml%pblht0/max (pblht(i,j), Nml%pblht0)
     else if (Nml%lochoice == 2) then
       lofactor = Nml%tke0/max (tkemiz(i,j), Nml%tke0)
     else if (Nml%lochoice == 3) then
       lofactor = Nml%tke0/max (tkemiz(i,j), Nml%tke0)
       lofactor = sqrt (lofactor)
     else
       lofactor = 1.0
     endif
   else
     lofactor = 1.0
   endif

!--------------------------------------------------------------------
!    call don_d_integ_cu_ensemble_k to determine the 
!    characteristics of the clouds in the cumulus ensemble defined in 
!    the current column.
!--------------------------------------------------------------------
          if (Nml%do_donner_plume) then
            call don_d_integ_cu_ensemble_k             &
                (nlev_lsm, nlev_hires, ntr, me, diag_unit, debug_ijt, &
                 lofactor, Param, Col_diag, Nml, Initialized,  &
                 Don_cape%model_t(i,j,:), Don_cape%model_r(i,j,:), &
                 Don_cape%model_p(i,j,:), phalf_c, xgcm_v(i,j,:,:), &
                 sfc_sh_flux(i,j), sfc_vapor_flux(i,j), &
                 sfc_tracer_flux(i,j,:), Don_cape%plzb(i,j), &
                 exit_flag(i,j),  ensmbl_precip, ensmbl_cond,       &
                 ensmbl_anvil_cond_liq, ensmbl_anvil_cond_liq_frz, &
                 ensmbl_anvil_cond_ice, pb,  &
                 pt_ens, ampta1, Don_conv%amax(i,j), emsm, rlsm,  &
                 cld_press, ensmbl_melt, ensmbl_melt_meso, &
                 ensmbl_freeze, ensmbl_freeze_meso, ensmbl_wetc, &
                 disb, disc_liq, disc_ice, dism_liq, dism_liq_frz, &
                 dism_liq_remelt, dism_ice, dism_ice_melted, &
                 disp_liq, disp_ice, disz, disz_remelt, disp_melted, &
                 disze1, disze2, disze3,                           &
                 disd, disv, disg_liq, disg_ice, enctf, encmf, enev,  &
                 ecds_liq, ecds_ice, eces_liq, eces_ice, &
                 ensmbl_cloud_area, cuq, cuql_v, detmfl, uceml, &
                 qtren, etsm, lmeso,                frz_frac,&
                 meso_frz_intg_sum, ermesg, error, melting_in_cloud, &
                 i, j, Don_cem)
          else
            call don_d_integ_cu_ensemble_miz             &
                (nlev_lsm, nlev_hires, ntr, me, diag_unit, debug_ijt, &
                 Param, Col_diag, Nml, Initialized, &
                 Don_cape%model_t(i,j, :), Don_cape%model_r(i,j,:), &
                 Don_cape%model_p(i,j,:), phalf_c, pblht(i,j),  &
                 tkemiz(i,j), qstar(i,j), cush(i,j), land(i,j), coldT(i,j), &
                 dt, sd, Uw_p, ac, cp, ct,  &
                 xgcm_v(i,j,:,:), sfc_sh_flux(i,j),                 &
                 sfc_vapor_flux(i,j), sfc_tracer_flux(i,j,:),   &
                 Don_cape%plzb(i,j), exit_flag(i,j),                &
                 ensmbl_precip, ensmbl_cond,                      &
                 ensmbl_anvil_cond_liq, ensmbl_anvil_cond_liq_frz, &
                 ensmbl_anvil_cond_ice, pb,  &
                 pt_ens, ampta1, Don_conv%amax(i,j), emsm_miz, &
                 rlsm_miz, cld_press_miz, ensmbl_melt,  &
                 ensmbl_melt_meso, ensmbl_freeze, ensmbl_freeze_meso, &
                 ensmbl_wetc, disb, disc_liq, disc_ice, dism_liq, &
                 dism_liq_frz, dism_liq_remelt, dism_ice, &
                 dism_ice_melted, disp_liq, disp_ice, disz, &
                 disz_remelt, disp_melted, disze1, disze2, disze3, &
                 disd, disv, disg_liq, disg_ice, &
                 enctf, encmf, enev, ecds_liq, ecds_ice,   &
                 eces_liq, eces_ice, ensmbl_cloud_area,  &
                 cuq, cuql_v, detmfl, uceml, qtren, etsm, lmeso, &
                 frz_frac, meso_frz_intg_sum, ermesg, error, melting_in_cloud, &
                 i, j, Don_cem)
          endif

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

!--------------------------------------------------------------------
!    if the exit_flag was set within integrate_cumulus_ensemble (due to
!    an ensemble member either a) not reaching an acceptable level of 
!    free convection, b) not producing precipitation, c) having con-
!    densate evaporation within the cloud, or d) not having a net column
!    non-zero moisture forcing (the "moisture constraint") stop the 
!    calculations for this column -- deep convection is turned off here,
!    output fields will reflect the absence of the effects of deep 
!    convection in this column.
!--------------------------------------------------------------------
          if (exit_flag(i,j)) cycle

!--------------------------------------------------------------------
!    if mesoscale circulation is present, call subroutine meso_effects 
!    to obtain full ensemble output fields to be applied to large-scale
!    model fields.
!--------------------------------------------------------------------
          if (lmeso) then
            if (Nml%do_donner_plume) then
              call don_m_meso_effects_k  &
                 (me, nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, &
                  Param, Nml, Don_cape%model_p(i,j,:),   &
                  Don_cape%model_t(i,j,:), Don_cape%model_r(i,j,:),  &
                  phalf_c, rlsm, emsm, etsm, xgcm_v(i,j,:,:),   &
                  ensmbl_cond, ensmbl_precip, pb, Don_cape%plzb(i,j), &
                  pt_ens, ampta1,                     &
                  ensmbl_anvil_cond_liq, ensmbl_anvil_cond_liq_frz, &
                  ensmbl_anvil_cond_ice,  &
                  wtp, qtmes,  meso_frz_intg_sum,   &
                  anvil_precip_melt, meso_cloud_area, cmus_tot, dmeml, &
                  emds_liq, emds_ice, emes_liq, emes_ice, &
                  wmms, wmps, umeml, temptr, tmes,tmes_up,  &
                  tmes_dn,  mrmes, mrmes_up, mrmes_dn,  &
                  Don_conv%emdi_v(i,j), Don_conv%pmd_v(i,j),   &
                  Don_conv%pztm_v(i,j), Don_conv%pzm_v(i,j),    &
                  Don_conv%meso_precip(i,j), ermesg, error)
            else
              call don_m_meso_effects_miz  &
                 (me, nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, &
                  Param, Nml, Don_cape%model_p(i,j,:),   &
                  Don_cape%model_t(i,j,:), Don_cape%model_r(i,j,:),  &
                  phalf_c, rlsm_miz, emsm_miz, etsm, xgcm_v(i,j,:,:),  &
                  ensmbl_cond, ensmbl_precip, pb, Don_cape%plzb(i,j), &
                  pt_ens, ampta1,                     &
                  ensmbl_anvil_cond_liq, ensmbl_anvil_cond_liq_frz, &
                  ensmbl_anvil_cond_ice,  &
                  wtp, qtmes, meso_frz_intg_sum,    &
                  anvil_precip_melt, meso_cloud_area, cmus_tot, dmeml, &
                  emds_liq, emds_ice, emes_liq, emes_ice, &
                  wmms, wmps, umeml, temptr, tmes, tmes_up, tmes_dn, &
                  mrmes, mrmes_up, mrmes_dn, Don_conv%emdi_v(i,j),    &
                  Don_conv%pmd_v(i,j), Don_conv%pztm_v(i,j), &
                  Don_conv%pzm_v(i,j), Don_conv%meso_precip(i,j), &
                  ermesg, error)
            endif


!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return

!--------------------------------------------------------------------
!    define cmus_tot   as the profile of total condensate source to the
!    large-scale flow from the mesoscale circulation; the sum of the 
!    water mass condensed in the mesoscale updraft plus the vapor 
!    transferred from cell to mesoscale and then condensed. 
!--------------------------------------------------------------------
          else
            qtmes = 0.
            wtp = 0.
            umeml = 0.
            dmeml = 0.
            cmus_tot = 0.
            tmes = 0.
            tmes_up = 0.
            tmes_dn = 0.
            wmms = 0.
            wmps = 0.
            mrmes = 0.
            mrmes_up = 0.
            mrmes_dn = 0.
            emds_liq = 0.
            emds_ice = 0.
            emes_liq = 0.
            emes_ice = 0.
            anvil_precip_melt = 0.
            meso_cloud_area = 0.
            meso_frz_intg_sum = .false.
          endif

        if (Nml%do_ensemble_diagnostics) then
           Don_cem%meso_precip = Don_conv%meso_precip
        endif

!---------------------------------------------------------------------
!    if in a diagnostics column, output the profiles of cell-scale 
!    tracer flux convergence (qtren). 
!---------------------------------------------------------------------
          if (debug_ijt) then
            do k=1,nlev_lsm
              do kcont=1,ntr  
                if (qtren(k,kcont) /= 0.00) then
                  write (diag_unit, '(a, 2i4, f19.10, e20.12)')  &
                  'in mulsub: jk, pr,qtren= ', k, kcont,              &
                            Don_cape%model_p(i,j,k), qtren(k,kcont)
                endif
              end do
            end do
          endif

!--------------------------------------------------------------------
!    if in diagnostics column, output the rate of condensate transfer 
!    from cells to anvil (ensmbl_anvil_cond), and the ratio of
!    convective precipitation to total precipitation (contotxx_v).
!--------------------------------------------------------------------
          if (debug_ijt) then
            write (diag_unit, '(a,e20.12, a, e20.12)')  &
              'in mulsub: CATOT= ',ensmbl_anvil_cond_liq + &
               ensmbl_anvil_cond_liq_frz + ensmbl_anvil_cond_ice,   &
                               ' contot=',  &
                       ensmbl_precip/(ensmbl_precip +    &
                                              Don_conv%meso_precip(i,j))
          endif

!----------------------------------------------------------------------
!    call subroutine define_convective_forcing to combine the cell and
!    mesoscale contributions to the output fields and the time tendency
!    terms that will be returned to the large-scale model. it also
!    call subroutine output_diagnostic_profiles to print various 
!    output fields from the donner_deep parameterization in those 
!    columns for which diagnostics have been requested.
!----------------------------------------------------------------------
          call don_d_def_conv_forcing_k   &
              (nlev_lsm, diag_unit, debug_ijt, lmeso, Initialized,  &
               pb, Param, Nml, ensmbl_precip, &
               Don_conv%meso_precip(i,j), meso_cloud_area, &
               anvil_precip_melt, phalf_c, enev,  encmf, ensmbl_freeze,&
               ensmbl_freeze_meso, enctf, disg_liq, disg_ice, &
               ecds_liq, ecds_ice, eces_liq, eces_ice,  &
               emds_liq, emds_ice, emes_liq, emes_ice, mrmes, mrmes_up,&
               mrmes_dn, tmes, tmes_up, tmes_dn, wmps, &
               ensmbl_cloud_area, ensmbl_melt, ensmbl_melt_meso,&
               Don_cape%model_p(i,j,:), Don_cape%model_t(i,j,:),  &
               cmus_tot, wmms, disc_liq, disc_ice, dism_liq, &
               dism_liq_frz, dism_liq_remelt, dism_ice, &
               dism_ice_melted, meso_frz_intg_sum, &
               disp_liq, disp_ice, disb, disd, disv, total_precip(i,j),&
               disz, disz_remelt, disp_melted, disze1,disze2, disze3,&
                                         disf, disn, dise, disa, &
               cutotal, temp_tend_melt, lprcp, liq_prcp, frz_prcp, &
               vrt_mot, wat_budg, &
               Don_budgets%n_water_budget, ent_budg,   &
               Don_budgets%n_enthalpy_budget, prc_budg, &
               Don_budgets%n_precip_paths, Don_budgets%n_precip_types, &
               ermesg, error, melting_in_cloud)

          do k=1, nlev_lsm
            kk = nlev_lsm - k + 1
            Don_budgets%liq_prcp(i,j,k) = liq_prcp(kk)
            Don_budgets%frz_prcp(i,j,k) = frz_prcp(kk)
          end do
          if (Initialized%do_conservation_checks) then
            Don_budgets%lheat_precip(i,j) = lprcp
            Don_budgets%vert_motion(i,j)  = vrt_mot
          
          endif
          if (Initialized%do_conservation_checks .or.   &
                                          Nml%do_budget_analysis) then
            Don_budgets%water_budget(i,j,:,:) = wat_budg
            Don_budgets%enthalpy_budget(i,j,:,:) = ent_budg
            Don_budgets%precip_budget(i,j,:,:,:) = prc_budg
          endif

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

!----------------------------------------------------------------------
!    call finalize_output_fields to convert to mks units and then store
!    profile arrays into the various components of the donner_conv type
!    derived-type variable Don_conv.
!----------------------------------------------------------------------
          call don_d_finalize_output_fields_k  &
               (nlev_lsm, ntr, i, j, Param, disb, disc_liq, disc_ice, &
                ensmbl_freeze, ensmbl_freeze_meso, &
                temp_tend_melt,  tmes, disd, cmus_tot, &
                ecds_liq, ecds_ice, eces_liq, eces_ice, emds_liq, &
                emds_ice, emes_liq, emes_ice, wmms, wmps, mrmes, &
                cutotal, dmeml, detmfl, temptr, uceml, umeml, cuq, &
                cuql_v, qtren, qtmes, wtp, ensmbl_wetc, Don_conv, &
                ermesg, error)

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

!--------------------------------------------------------------------
!    store some additional output fields in the donner_conv type 
!    variable for later use.
!--------------------------------------------------------------------
          Don_conv%cell_precip(i,j) = ensmbl_precip
          Don_conv%pb_v(i,j) = pb
          Don_conv%ampta1(i,j) = ampta1
          dise_v(i,j,:) = dise(:)/(1.0E03*Param%SECONDS_PER_DAY)
          disa_v(i,j,:) = disa(:)/Param%SECONDS_PER_DAY

          do k=1,nlev_lsm
            kinv = nlev_lsm + 1 - k
            temperature_forcing(i,j,kinv) = disa(k)/ &
                                                Param%SECONDS_PER_DAY
            moisture_forcing(i,j,kinv) = dise(k)/    &
                                          (1.0e03*Param%SECONDS_PER_DAY)
          end do

!--------------------------------------------------------------------
!    for any diagnostic columns in the window in which deep convection
!    occurred, output the cloud anvil area (Don_conv%ampta1) and the
!    total precipitation produced (total_precip). also output the vert-
!    ical profile of total cloud fraction (Don_conv%cual).
!--------------------------------------------------------------------
          if (debug_ijt) then
            write  (diag_unit, '(a, 2e20.12)')   &
                  'in cupar:  ampt,tpre= ',  &
                            Don_conv%ampta1(i,j), total_precip(i,j)      
            do k=1,nlev_lsm-Col_diag%kstart+1    
              write (diag_unit, '(a, i4, e20.12)')  &
                   'in cupar: k,cual= ',k,  &
                                Don_conv%cual(i,j,nlev_lsm-k+1)
            end do
          endif

!---------------------------------------------------------------------
!    define the time rates of change of column-integrated water vapor
!    (dqls_v) and the time rate of change needed to deplete the column
!    water vapor in a single donner timestep (qlsd_v).
!---------------------------------------------------------------------
          dqls_v = (Don_cape%qint(i,j) - Don_cape%qint_lag(i,j))/dt
          qlsd_v = Don_cape%qint(i,j)/Nml%donner_deep_freq
          max_depletion_rate = dqls_v + qlsd_v

!--------------------------------------------------------------------
!    if in a diagnostic column, output these moisture tendency 
!    variables.
!--------------------------------------------------------------------
          if (debug_ijt) then
            write (diag_unit, '(a, 2e20.12)')   &
                  'in cupar: dqls,qlsd= ', dqls_v, qlsd_v     
          endif

!---------------------------------------------------------------------
!    call determine_cloud_area to define the cloud area of the convect-
!    ive clouds and so close the parameterization. note that exit_flag
!    may be set to .true. within determine_cloud_area, so that the 
!    if (exit_flag) loop must be closed after this call.
!---------------------------------------------------------------------
          if (.not. exit_flag(i,j)) then
            if (Nml%do_donner_closure) then
! this path used by donner_full parameterization:
              call don_d_determine_cloud_area_k  &
                (me, nlev_lsm, nlev_hires, diag_unit, debug_ijt, Param,&
                 Initialized, &
                 Nml, lofactor, max_depletion_rate, Don_conv%dcape(i,j),   &
                 Don_conv%amax(i,j), dise_v(i,j,:), disa_v(i,j,:),    &
                 Don_cape%model_p(i,j,:), Don_cape%model_t(i,j,:), &
                 Don_cape%model_r(i,j,:), Don_cape%env_t(i,j,:), &
                 Don_cape%env_r(i,j,:), Don_cape%parcel_t(i,j,:), &
                 Don_cape%parcel_r(i,j,:), Don_cape%cape_p(i,j,:), &
                 exit_flag(i,j), Don_conv%amos(i,j), Don_conv%a1(i,j),&
                 ermesg, error)
            else  ! (do_donner_closure)
! these paths used by donner_lite parameterization:

              if (Nml%do_donner_cape) then
! if not do_donner_closure but do_donner_cape, then previous parcel cape
!  calculation will have used hires vertical grid.
                 call don_d_determine_cloud_area_miz  &
                (me, nlev_lsm, ntr, dt, nlev_hires, diag_unit,&
                 debug_ijt, Param, Initialized, Nml, xgcm_v(i,j,:,:), &
                 pfull(i,j,:), zfull(i,j,:), phalf(i,j,:),  &
                 zhalf(i,j,:), pblht(i,j), tkemiz(i,j), qstar(i,j), &
                 cush(i,j), cbmf(i,j), land(i,j),  coldT(i,j), sd, Uw_p, ac, &
                 max_depletion_rate, Don_cape%xcape(i,j), &
                 Don_conv%dcape(i,j),   &
                 Don_conv%amax(i,j), dise_v(i,j,:), disa_v(i,j,:),    &
                 Don_cape%model_p(i,j,:), Don_cape%model_t(i,j,:), &
                 Don_cape%model_r(i,j,:), Don_cape%env_t(i,j,:), &
                 Don_cape%env_r(i,j,:), Don_cape%parcel_t(i,j,:), &
                 Don_cape%parcel_r(i,j,:), Don_cape%cape_p(i,j,:), &
                 exit_flag(i,j), Don_conv%amos(i,j), Don_conv%a1(i,j),&
                 ermesg, error)
              else ! (do_donner_cape)
                if (Nml%do_hires_cape_for_closure) then
!  if not do_donner_cape (lo res cape calc for convection), but desire 
!  to use hires cape calc for closure:

!--------------------------------------------------------------------
!    call generate_cape_sounding to produce a high-resolution atmos-
!    pheric sounding to be used to evaluate cape.
!--------------------------------------------------------------------
                   call don_c_generate_cape_sounding_k &
                        (nlev_lsm, nlev_hires, temp(i,j,:),   &
                         mixing_ratio(i,j,:), pfull(i,j,:),   &
                         model_tx, model_rx, model_px, cape_p, &
                         env_t, env_r, ermesg,  error)

                   call don_d_determine_cloud_area_miz  &
                (me, nlev_lsm, ntr, dt, nlev_hires, diag_unit,&
                 debug_ijt, Param, Initialized, Nml, xgcm_v(i,j,:,:), &
                 pfull(i,j,:), zfull(i,j,:), phalf(i,j,:),  &
                 zhalf(i,j,:), pblht(i,j), tkemiz(i,j), qstar(i,j), &
                 cush(i,j), cbmf(i,j), land(i,j),  coldT(i,j), sd, Uw_p, ac, &
                 max_depletion_rate, Don_cape%xcape(i,j), &
                 Don_conv%dcape(i,j),   &
                 Don_conv%amax(i,j), dise_v(i,j,:), disa_v(i,j,:),    &
                 Don_cape%model_p(i,j,:), Don_cape%model_t(i,j,:), &
                 Don_cape%model_r(i,j,:), &

                 env_t, env_r, parcel_t, parcel_r, cape_p, & 

                 exit_flag(i,j), Don_conv%amos(i,j), Don_conv%a1(i,j),&
                 ermesg, error)

              else  ! (do_hires_cape)
!  lo res calc for cape in convection and in closure; standard 
!  donner_lite configuration
                 call don_d_determine_cloud_area_miz  &
!               (me, nlev_lsm, ntr, dt, nlev_hires, diag_unit,&
                (me, nlev_lsm, ntr, dt, nlev_lsm  , diag_unit,&
                 debug_ijt, Param, Initialized, Nml, xgcm_v(i,j,:,:), &
                 pfull(i,j,:), zfull(i,j,:), phalf(i,j,:),  &
                 zhalf(i,j,:), pblht(i,j), tkemiz(i,j), qstar(i,j), &
                 cush(i,j), cbmf(i,j), land(i,j),  coldT(i,j), sd, Uw_p, ac, &
                 max_depletion_rate, Don_cape%xcape(i,j), &
                 Don_conv%dcape(i,j),   &
                 Don_conv%amax(i,j), dise_v(i,j,:), disa_v(i,j,:),    &
                 Don_cape%model_p(i,j,:), Don_cape%model_t(i,j,:), &
                 Don_cape%model_r(i,j,:), Don_cape%env_t(i,j,:), &
                 Don_cape%env_r(i,j,:), Don_cape%parcel_t(i,j,:), &
                 Don_cape%parcel_r(i,j,:), Don_cape%cape_p(i,j,:), &
                 exit_flag(i,j), Don_conv%amos(i,j), Don_conv%a1(i,j),&
                 ermesg, error)
              endif
            endif
            endif

!             Don_budgets%liq_prcp(i,j,:) =    &
!                         Don_budgets%liq_prcp(i,j,:)*Don_conv%a1(i,j)
!             Don_budgets%frz_prcp(i,j,:) =    &
!                         Don_budgets%frz_prcp(i,j,:)*Don_conv%a1(i,j)
!           if (Initialized%do_conservation_checks) then
!             Don_budgets%vert_motion(i,j) =    &
!                          Don_budgets%vert_motion(i,j)*Don_conv%a1(i,j)
!             Don_budgets%lheat_precip(i,j) =   &
!                         Don_budgets%lheat_precip(i,j)*Don_conv%a1(i,j)
!           endif

!----------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return
          endif

          if (.not.Nml%do_donner_lscloud) then 
             Don_conv%ecds(i,j,:) = Don_conv%ecds(i,j,:)*  &
                                        (1.0E03*Param%seconds_per_day)
             Don_conv%eces(i,j,:) = Don_conv%eces(i,j,:)*  &
                                        (1.0E03*Param%seconds_per_day)
            do k=1,nlev_lsm
              Don_conv%fre(i,j,nlev_lsm+1-k)=enev(k)
            end do
          endif

!--------------------------------------------------------------------
!    if the exit_flag was set within determine_cloud_area (due to
!    not having a net column non-zero moisture forcing (the "moisture 
!    constraint") set a flag to indicate that deep convection is turned
!    off; output fields will be made to reflect the absence of the 
!    effects of deep convection in this column. 
!--------------------------------------------------------------------
        end do
      end do

!--------------------------------------------------------------------



end subroutine don_d_mulsub_k



!######################################################################

subroutine don_d_integ_cu_ensemble_k             &
         (nlev_lsm, nlev_hires, ntr, me, diag_unit, debug_ijt, &
          lofactor, Param, Col_diag, Nml, Initialized, temp_c, &
          mixing_ratio_c, pfull_c, phalf_c,   &
          tracers_c, sfc_sh_flux_c, sfc_vapor_flux_c,   &
          sfc_tracer_flux_c, plzb_c, exit_flag_c, ensmbl_precip,    &
          ensmbl_cond, ensmbl_anvil_cond_liq,  &
          ensmbl_anvil_cond_liq_frz, &
          ensmbl_anvil_cond_ice, pb, pt_ens, ampta1, amax, &
          emsm, rlsm, cld_press, ensmbl_melt, ensmbl_melt_meso, &
          ensmbl_freeze, ensmbl_freeze_meso, ensmbl_wetc, &
          disb, disc_liq, disc_ice, dism_liq, dism_liq_frz, &
          dism_liq_remelt, dism_ice, dism_ice_melted, &
          disp_liq, disp_ice, disz, disz_remelt, disp_melted,        &
          disze1, disze2,disze3,                                      &
          disd, disv, disg_liq, disg_ice, enctf, encmf, enev,  &
          ecds_liq, ecds_ice, eces_liq, eces_ice, ensmbl_cloud_area,&
          cuq, cuql_v, detmfl, uceml, qtren, etsm, lmeso, &
          frz_frac, meso_frz_intg_sum,  ermesg, error, melting_in_cloud, &
          i, j, Don_cem)

!----------------------------------------------------------------------
!    subroutine integrate_cumulus_ensemble works on a single model 
!    column. all profile arrays used in this subroutine and below have 
!    index 1 nearest the surface. it first determines the lifting conden-
!    sation level (if one exists) of a parcel moving from the specified 
!    parcel_launch_level. if an lcl is found, subroutine 
!    donner_cloud_model_cloud_model is called to determine the behavior
!    of each of kpar cloud ensemble mem-
!    bers assumed present in the column (each ensemble member is ass-
!    umed to have a different entrainment rate). if all ensemble members
!    produce deep convection, the ensemble statistics are produced for 
!    use in the large-scale model; otherwise deep convection is not seen
!    in the large-scale model in this grid column. if the ensemble will 
!    support a mesoscale circulation, its impact on the large-scale model
!    fields is also determined. upon completion, the appropriate output 
!    fields needed by the large-scale model are returned to the calling 
!    routine.
!----------------------------------------------------------------------
use donner_types_mod, only : donner_param_type, &
                             donner_nml_type, donner_column_diag_type, &
                             donner_initialized_type, donner_cem_type

implicit none 

!----------------------------------------------------------------------
integer,                           intent(in)    :: nlev_lsm,    &
                                                    nlev_hires, ntr, &
                                                    me, diag_unit
logical,                           intent(in)    :: debug_ijt
type(donner_param_type),           intent(in)    :: Param
type(donner_column_diag_type),     intent(in)    :: Col_diag
type(donner_nml_type),             intent(in)    :: Nml   
type(donner_initialized_type),     intent(in)    :: Initialized
real,    dimension(nlev_lsm),      intent(in)    :: temp_c,   &
                                                    mixing_ratio_c,   &
                                                    pfull_c
real,    dimension(nlev_lsm+1),    intent(in)    :: phalf_c
real,    dimension(nlev_lsm,ntr),  intent(in)    :: tracers_c           
real,                              intent(in)    :: sfc_sh_flux_c,   &
                                                    sfc_vapor_flux_c 
real,    dimension(ntr),           intent(in)    :: sfc_tracer_flux_c 
real,                              intent(in)    :: plzb_c
real,                              intent(in)    :: lofactor
logical,                           intent(inout) :: exit_flag_c  
real,                              intent(out)   ::    &
                     ensmbl_precip, ensmbl_cond,                    &
                     ensmbl_anvil_cond_liq, ensmbl_anvil_cond_liq_frz, &
                     ensmbl_anvil_cond_ice, pb, pt_ens, ampta1, amax
real,    dimension(nlev_hires),    intent(out)   :: emsm, rlsm,  &
                                                    cld_press
real,    dimension(nlev_lsm),      intent(out)   :: ensmbl_melt,   &
                                                    ensmbl_melt_meso,&
                                                    ensmbl_freeze,&
                                                    ensmbl_freeze_meso,&
                                                    disb,       disd, &
                                                    disv, &
                                                    disc_liq, disc_ice,&
                                                    dism_liq, dism_ice,&
                                                    dism_ice_melted, &
                                                    dism_liq_frz, &
                                                    dism_liq_remelt, &
                                                    disp_liq, disp_ice,&
                                                    disp_melted, &
                                                    disz_remelt, &
                                                    disz, disze1,  &
                                                    disze2, disze3,&
                                                    enctf, encmf, &
                                                    disg_liq, disg_ice,&
                                                    enev,             &
                                                    ecds_liq, ecds_ice,&
                                                    eces_liq, eces_ice,&
                                                    ensmbl_cloud_area, &
                                                    cuq, cuql_v, &
                                                    detmfl, uceml
real,    dimension(nlev_lsm,ntr),  intent(out)   :: qtren, ensmbl_wetc
real,    dimension(nlev_hires,ntr),intent(out)   :: etsm
logical,                           intent(out)   :: lmeso       
real   ,                           intent(out)   :: frz_frac
logical,                           intent(out)   :: meso_frz_intg_sum 
character(len=*),                  intent(out)   :: ermesg
integer,                           intent(out)   :: error
logical ,                          intent(out)   :: melting_in_cloud
integer,                           intent(in)    :: i, j
type(donner_cem_type),             intent(inout) :: Don_cem

!---------------------------------------------------------------------
!   intent(in) variables:
! 
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     ntr            number of tracers to be transported by donner
!                    convection
!     me             local pe number
!     diag_unit      unit number for column diagnostics output, if 
!                    diagnostics are requested for the current column
!     debug_ijt      logical indicating whether current column requested
!                    column diagnostics
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     temp_c         temperature field at model full levels 
!                    index 1 nearest the surface [ deg K ]
!     mixing_ratio_c        vapor mixing ratio at model full levels 
!                    index 1 nearest the surface
!                    [ kg(h2o) / kg(dry air) ]
!     pfull_c         pressure field at large-scale model full levels 
!                    index 1 nearest the surface [ Pa ]
!     phalf_c        pressure field at large-scale model half-levels 
!                    index 1 nearest the surface [ Pa ]
!     tracers_c      tracer fields that are to be transported by donner
!                    convection.  index 1 nearest the surface 
!                    [ kg (tracer) / kg (dry air) ]
!     sfc_sh_flux_c  sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_vapor_flux_c water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     sfc_tracer_flux_c  
!                    flux across the surface of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     plzb_c         level of zero buoyancy for a parcel lifted from
!                    the parcel_launch_level.  [ Pa ]
!
!     cumulus ensemble member fields (see also donner_types.h):
!
!     --- single level ---
!
!     Don_cem_cell_precip 
!                    area weighted convective precipitation rate
!                    [ mm/day ]
!     Don_cem_pb     pressure at cloud base for ensemble (currently,
!                    all ensemble members have same base) [ Pa ]
!     Don_cem_ptma   pressure at cloud top for ensemble [ Pa ]
!
!     --- lo-res multi-level ---
! 
!     Don_cem_h1     condensation rate profile on lo-res grid
!                    for the current ensemble member
!                    [ ( kg(h2o) ) / ( kg( dry air) sec ) ] 
!
!     --- hi-res multi-level ---
!
!     Don_cem_qlw    profile of cloud water for the current ensemble
!                    member [ kg(h2o) / kg(air) ]
!     Don_cem_cfracice
!                    fraction of condensate that is ice [ fraction ]
!     Don_cem_wv     vertical velocity profile [ m / s ]
!     Don_cem_rcl    cloud radius profile [ m ]
!
!   intent(inout) variables:
!
!     exit_flag_c    logical indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    current model column 
!
!   intent(out) variables:
!    
!     ensmbl_precip      sum of precipitation rate over ensemble members,
!                        # 1 to the current, weighted by the area at 
!                        cloud base of each member
!                        [ mm / day ]
!     ensmbl_cond        sum of condensation rate over ensemble members,
!                        # 1 to the current, weighted by the area at 
!                        cloud base of each member
!                        [ mm / day ]
!     ensmbl_anvil_cond  sum of rate of transfer of condensate from cell 
!                        to anvil over ensemble members, # 1 to the c
!                        current, weighted by the area at cloud base of 
!                        each member [ mm / day ]
!     ensmbl_wetc        sum of wet-deposition rates from ensemble
!                        member #1 to current, weighted by the ratio
!                        of the member area to the area of member #1
!                        at cloud base
!                        [kg(tracer)/kg/sec]
!                        vertical index 1 at cloud base
!     pb                 pressure at cloud base for ensemble (all ensem-
!                        ble members have same base) [ Pa ]
!     pt_ens             pressure at cloud top for the ensemble (top 
!                        pressure of deepest ensemble member) [ Pa ]
!     ampta1             cloudtop anvil area (assumed to be five times
!                        larger than the sum of the cloud top areas of 
!                        the ensemble members, as in Leary and Houze 
!                        (1980).  [ fraction ]
!     amax               maximum allowable area of cloud base that is
!                        allowed; if cloud base area is larger than 
!                        amax, the cloud fractional area somewhere in
!                        the grid box would be greater than one, which 
!                        is non-physical.
!     emsm               vertical profile on the hi-res grid of vertical
!                        moisture flux convergence, summed over ensemble 
!                        members # 1 to the current, each member's cont-
!                        ribution being weighted by its cloud area at 
!                        level k relative to the cloud base area of 
!                        ensemble member #1  
!                        [ kg (h2o) / ( kg(dry air) sec ) ]
!     rlsm               vertical profile on the hi-res grid of conden-
!                        sation rate, summed over ensemble members # 1 to
!                        the current, each member's contribution being 
!                        weighted by its cloud area at level k relative 
!                        to the cloud base area of ensemble member #1
!                        [ ( kg(h2o) ) / ( kg( dry air) sec ) ] 
!     cld_press          pressures at hi-res model levels [ Pa ]
!     ensmbl_melt        vertical profile on the lo-res grid of ice melt,
!                        both from the cells and any mesoscale circul-
!                        ation, summed over ensemble members # 1 to the 
!                        current, each member's contribution being 
!                        weighted by its cloud area at level k relative !
!                        to the cloud base area of ensemble member #1
!                        [ kg(h2o) / kg (dry air) ]
!     ensmbl_freeze      vertical profile on the lo-res grid of freezing,
!                        both from the cells and any mesoscale circul-
!                        ation, summed over ensemble members # 1 to the 
!                        current, each member's contribution being 
!                        weighted by its cloud area at level k relative !
!                        to the cloud base area of ensemble member #1
!                        [ kg(h2o) / kg (dry air) ]
!     disg               vertical profile on the lo-res grid of the      
!                        latent heat term in the temperature equation
!                        associated with the evaporation of condensate
!                        in the convective downdraft and updraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ deg K / day ] 
!     enev               vertical profile on the lo-res grid of the      
!                        cloud-area-weighted profile of the potential
!                        cloud water evaporation, summed over ensemble 
!                        members # 1 to the current, each member's con-
!                        tribution being weighted by its cloud area at !
!                        level k relative to the cloud base area of 
!                        ensemble member #1.  this amount of water
!                        must be evaporated if it turns out that there is
!                        no mesoscale circulation generated in the 
!                        column.
!                        [ ( kg(h2o) ) / ( kg(dry air) sec ) ] 
!     enctf              vertical profile on the lo-res grid of the entr-
!                        opy forcing, consisting of the sum of the
!                        vertical entropy flux convergence and the latent
!                        heat release, summed over 
!                        ensemble members # 1 to the current, each mem-
!                        ber's contribution being weighted by its cloud 
!                        area at level k relative to the cloud base area
!                        of ensemble member #1
!                        [ deg K / day ]                        
!     encmf              vertical profile on the lo-res grid of the      
!                        moisture forcing, consisting of the sum of the
!                        vertical moisture flux convergence and the cond-
!                        ensation, summed over ensemble members # 1 to 
!                        the current, each member's contribution being 
!                        weighted by its cloud area at level k relative 
!                        to the cloud base area of ensemble member #1
!                        [ ( kg(h2o) ) / ( kg( dry air) day ) ] 
!     disb               vertical profile on the lo-res grid of the      
!                        temperature flux convergence, summed over 
!                        ensemble members # 1 to the current, each mem-
!                        ber's contribution being weighted by its cloud 
!                        area at level k relative to the cloud base area 
!                        of ensemble member #1.  
!                        [ deg K / day ] 
!     disc               vertical profile on the lo-res grid of the      
!                        latent heat term in the temperature equation, 
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ deg K / day ] 
!     disd               vertical profile on the lo-res grid of the      
!                        vertical moisture flux convergence,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        lo-res grid for the current ensemble member 
!                        [  g(h2o) / ( kg(dry air) day ) ]
!     ecds               vertical profile on the lo-res grid of the      
!                        condensate evaporated in convective downdraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ g(h2o) / kg(air) / day ]
!     eces               vertical profile on the lo-res grid of the      
!                        condensate evaporated in convective updraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ g(h2o) / kg(air) / day ]
!     ensmbl_cloud_area  total cloud area profile over all ensemble
!                        members on large_scale model grid [ fraction ]
!     cuq                ice water profile on large-scale model grid, 
!                        normalized by ensemble cloud area.
!     cuql_v             liquid water profile on large-scale model grid, 
!                        normalized by ensemble cloud area.
!     uceml              upward mass flux on large_scale model grid     
!                        [ kg (air) / (sec m**2) ]
!     detmfl             detrained mass flux on large-scale model grid
!                        normalized by ensemble cloud area
!                        [ kg (air) / (sec m**2) ]
!     etsm               vertical profile on the hi-res grid of vertical
!                        tracer flux convergence, summed over ensemble 
!                        members # 1 to the current, each member's con-
!                        tribution being weighted by its cloud area at i
!                        level k relative to the cloud base area of 
!                        ensemble member #1 
!                        [ kg (tracer) / ( kg(dry air) sec ) ]
!     qtren              vertical profile on the lo-res grid of the      
!                        vertical tracer flux convergence,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!     lmeso              logical variable; if .false., then it has been
!                        determined that a mesoscale circulation cannot
!                        exist in the current column. final value not
!                        determined until all ensemble members have been
!                        integrated. 
!     ermesg             character string containing any error message
!                        that is returned from a kernel subroutine
!
!---------------------------------------------------------------------

!     cmui             normalized vertical integral of mesoscale-updraft
!                      deposition (kg(H2O)/((m**2) sec)
!     cmus(nlev)       normalized mesoscale-updraft deposition
!                      (kg(H2O)/kg/sec)
!     emds(nlev)       normalized mesoscale-downdraft sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     emei             normalized vertical integral of mesoscale-updraft
!                      sublimation (kg(h2O)/((m**2) sec)
!     emes(nlev)       normalized mesoscale-updraft sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     disa(nlev)       normalized thermal forcing, cells+meso (K/sec)
!                      (excludes convergence of surface heat flux)
!                      index 1 at ground. Cumulus thermal forcing defined
!                      as in Fig. 3 of Donner (1993, JAS).
!     disb(nlev)       normalized cell entropy-flux convergence (K/sec)
!                      (excludes convergence of surface flux)
!                      index 1 at ground. Entropy-flux convergence divided
!                      by (p0/p)**(rd/cp).
!     disc(nlev)       normalized cell condensation/deposition
!                      (K/sec)
!                      index 1 at ground.
!     disd(nlev)       normalized cell moisture-flux convergence
!                      (excludes convergence of surface moisture flux)
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     dise(nlev)       normalized moisture forcing, cells+meso (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     dmeml(nlev)      mass flux in mesoscale downdraft (kg/((m**2) s))
!                      (normalized by a(1,p_b)) (index 1 at atmosphere
!                      bottom)
!     elt(nlev)        normalized melting (K/sec)
!                      index 1 at ground.
!     fre(nlev)        normalized freezing (K/sec)
!                      index 1 at ground.
!     pb               pressure at base of cumulus updrafts (Pa)
!     pmd              pressure at top of mesoscale downdraft (Pa)
!     pztm             pressure at top of mesoscale updraft (Pa)
!     mrmes(nlev)       normalized mesoscale moisture-flux convergence
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     qtmes(nlev,ncont)  tracer tendency due to mesoscale tracer-flux
!                        convergence (kg/kg/s) (normalized by a(1,p_b))
!                        index 1 at ground 
!     qtren_v          normalized tracer tendency due to cells...
!                      (lon,lat,vert,tracer index)
!                      Vertical index increases as height increases.
!     sfcq(nlev)       boundary-layer mixing-ratio tendency due to surface
!                      moisture flux (kg(H2O)/kg/sec)
!     sfch(nlev)       boundary-layer heating due to surface heat flux
!                      (K/sec)
!     tmes(nlev)       normalized mesoscale entropy-flux convergence
!                      (K/sec)
!                      Entropy-flux convergence is mesoscale component
!                      of second term in expression for cumulus thermal
!                      forcing in Fig. 3 of Donner (1993, JAS).
!                      index 1 at ground.
!     tpre_v           total normalized precipitation (mm/day)
!     detmfl(nlev)     detrained mass flux from cell updrafts
!                      (normalized by a(1,p_b))
!                      (index 1 near atmosphere bottom)
!                      (kg/((m**2)*s)
!     uceml(nlev)      normalized mass fluxes in cell updrafts
!                      (kg/((m**2)*s) 
!     umeml(nlev)      mass flux in mesoscale updraft (kg/((m**2) s))
!                      (normalized by a(1,p_b)) (index 1 at atmosphere
!                      bottom)
!                      index 1 at ground.
!     wmms(nlev)       normalized mesoscale deposition of water vapor from
!                      cells (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     wmps(nlev)       normalized mesoscale redistribution of water vapor
!                      from cells (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     wtp_v            tracer redistributed by mesoscale processes
!                      (kg/kg/s) (normalized by a(1,p_b))
!                      vertical index increases with increasing height
!                      (lon,lat,vert,tracer index)
!--------------------------------------------------------------------


!!  UNITS
!!    ucemh  [kg /sec / m**2 ]
!!    detmfh [kg /sec / m**2 ]
!!    conint [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    precip [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    q1     [ kg(h2o) / kg(air) / sec ]
!!    h1     [ kg(h2o) / kg(air) / sec ]
!!    cmf    [ g(h2o) / kg(air) /day ]
!!    rlh    [ kg(h2o) / kg(air) / day ]  * [ L / Cp ] = [ deg K / day ]
!!    h1_2   [ deg K / sec ]
!!    efc    [ deg K / day ]
!!    efchr  [ deg K / sec ]
!!    ehfh   [ kg(air) (deg K) / (sec**3 m)
!!    ctf    [ deg K / day ]
!!    disb_v [ deg K / day ]
!!    disc_v [ deg K / day ] 
!!    disn   [ deg K / day ] 
!!    ecd    [ g(h2o) / kg(air) / day ]
!!    ece    [ g(h2o) / kg(air) / day ]
!!    ecds_v [ g(h2o) / kg(air) / day ]
!!    eces_v [ g(h2o) / kg(air) / day ]
!!    pf     [ (m**2 kg(h2o)) / (kg(air) sec) ]
!!    dpf    [ (m**2 kg(h2o)) / (kg(air) sec) ] ==>   
!!                                          [ kg(h2o)) / (kg(air) sec) ]
!!    dpftr    [ (m**2 kg(tracer)) / (kg(air) sec) ] ==>   
!!                                          [ kg(tracer)) / (kg(air) sec) ]
!!    qlw2   [ kg(h2o)) / (kg(air) sec) ]
!!    qlw    [ kg(h2o)) / kg(air) ]
!!    evap   [ kg(h2o)) / kg(air) ]
!!    evap_rate [ kg(h2o)) / (kg(air) sec) ]




!        cape     convective available potential energy (J/kg)
!        cin      convective inhibtion (J/kg)
!        cpd      specific heat of dry air at constant pressure (J/(kg K))
!        cpv      specific heat of water vapor [J/(kg K)]
!        dcape    local rate of CAPE change by all processes
!                 other than deep convection [J/(kg s)]
!        dqls     local rate of change in column-integrated vapor
!                 by all processes other than deep convection
!                 {kg(H2O)/[(m**2) s]}
!        epsilo   ratio of molecular weights of water vapor to dry air
!        gravm    gravity constant [m/(s**2)]
!        ilon     longitude index
!        jlat     latitude index
!        mcu      frequency (in time steps) of deep cumulus
!        current_displ  integrated low-level displacement (Pa)
!        cape_p   pressure at Cape.F resolution (Pa)
!                 Index 1 at bottom of model.
!        plfc     pressure at level of free convection (Pa)
!        plzb_c   pressure at level of zero buoyancy (Pa)
!        pr       pressure at Skyhi vertical resolution (Pa)
!                 Index 1 nearest ground  
!        q        large-scale vapor mixing ratio at Skyhi vertical resolution
!                 [kg(h2O)/kg]
!                 Index 1 nearest ground 
!        qlsd     column-integrated vapor divided by timestep for cumulus
!                 parameterization {kg(H2O)/[(m**2) s]}
!        r        large-scale vapor mixing ratio at Cape.F resolution
!                 [kg(h2O)/kg]
!                 Index 1 at bottom of model.
!        rpc      parcel vapor mixing ratio from Cape.F [kg(h2O)/kg]
!                 Index 1 at bottom of model.
!        rd       gas constant for dry air (J/(kg K))
!        rlat     latent heat of vaporization (J/kg)
!        rv       gas constant for water vapor (J/(kg K))
!        t        large-scale temperature at Skyhi vertical resolution (K)
!                 Index 1 nearest ground
!        tcape    large-scale temperature at Cape.F resolution (K)
!                 Index 1 at bottom of model.
!        tpc      parcel temperature from from Cape.F (K)
!                 Index 1 at bottom of model.
!

!----------------------------------------------------------------------
!   local variables:

      real,    dimension (nlev_hires)     ::                &
              efchr, emfhr, rcl, dpf, qlw, dfr, cfracice, &
              alp, cld_evap, flux, ucemh, cuql, cuqli, detmfh, tcc, wv

      real,    dimension (nlev_lsm)       ::           &
                  q1, cell_freeze, cell_melt,   &
              h1_liq, h1_ice, meso_melt, meso_freeze, h1_2, &
              evap_rate, ecd, ecd_liq, ecd_ice, &
              ece, ece_liq, ece_ice, sfcq, sfch
      real, dimension (nlev_lsm,ntr)  :: wetdepl

      real,    dimension (nlev_hires,ntr) :: etfhr, dpftr
      real,    dimension (nlev_lsm,ntr)   :: qtr
      real,    dimension (Param%kpar)     :: cuto, preto, ptma
      integer, dimension (Param%kpar)     :: ncca

      logical ::   lcl_reached                  
      integer ::   ncc_kou, ncc_ens
      integer ::   k,    kou
      integer ::   kk
      logical ::   meso_frz_intg                 
      real    ::   al, dp, mrb,  &
                   summel, ptt,   &
                   sbl, psmx, dint, cu, cell_precip,&
                   ca_liq, ca_ice, apt, &
                   tb, alpp,   &
                   pcsave, ensmbl_cld_top_area  
      real     ::  meso_frac, precip_frac, frz_frac_non_precip,  &
                   bak, meso_frz_frac, pmelt_lsm, precip_melt_frac, &
                   ecei_liq,  ci_liq_cond, ci_ice_cond
     

!----------------------------------------------------------------------
!   local variables:
!
!      ensmbl_cld_top_area  
!                       sum of the cloud top areas over ensemble members 
!                       # 1 to the current, normalized by the cloud base
!                       area of ensemble member # 1 [ dimensionless ]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the character string which will contain any error mes-
!    sages returned through this subroutine.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    if in diagnostics column, output the large-scale model temperature,
!    vapor mixing ratio and full-level pressure profiles (index 1 near-
!    est the surface).
!---------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_lsm-Col_diag%kstart+1
          write (diag_unit, '(a, i4, f20.14, e20.12, f19.10)')&
                'in mulsub: k,T,Q,P= ',k, temp_c(k),  &
                                      mixing_ratio_c(k), pfull_c(k)
        end do
      endif

!--------------------------------------------------------------------
!    call don_cm_lcl_k to calculate the temperature (tb), a
!    pressure (pb) and mixing ratio (mrb) at the lifting condensation 
!    level for a parcel starting from the parcel_launch_level. if a sat-
!    isfactory lcl is not reached for this parcel, the logical variable 
!    lcl_reached will be set to .false..
!--------------------------------------------------------------------
      call don_cm_lcl_k    &
           (Param, temp_c (Nml%parcel_launch_level),    &
            pfull_c       (Nml%parcel_launch_level),    &
            mixing_ratio_c(Nml%parcel_launch_level),   &
            tb, pb, mrb, lcl_reached, ermesg, error)     

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    if in diagnostics column and an lcl was defined, output the lcl 
!    temperature, pressure and mixing ratio. if an acceptble lcl was 
!    not reached, print a message.
!--------------------------------------------------------------------
      if (debug_ijt) then
        if (lcl_reached) then
          write (diag_unit, '(a, f20.14, f19.10, e20.12)') &
                                'in mulsub: tb,pb,qb= ',tb, pb, mrb  
        else
          write (diag_unit, '(a)') 'in mulsub: lcl not reached'
        endif
      endif

!--------------------------------------------------------------------
!    if an acceptable lcl was not reached, set exit_flag_c so that the
!    remaining computations for this column are bypassed, and return to
!    calling routine. 
!--------------------------------------------------------------------
      if (.not. lcl_reached) then
        exit_flag_c = .true.
        return
      endif
 
!---------------------------------------------------------------------
!    if calculations are continuing, initialize needed variables.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize variables which will accumulate scalar sums over all 
!    ensemble members.
!---------------------------------------------------------------------
      ensmbl_precip       = 0.
      ensmbl_cond         = 0.
      ensmbl_anvil_cond_liq   = 0.
      ensmbl_anvil_cond_liq_frz   = 0.
      ensmbl_anvil_cond_ice   = 0.
      ensmbl_cld_top_area = 0.

!---------------------------------------------------------------------
!    initialize the variables which will contain the sum over the 
!    ensemble members of the vertical profiles of various quantities 
!    on the cloud-model grid.
!---------------------------------------------------------------------
      do k=1,nlev_hires
        cuql(k)   = 0.
        cuqli(k)  = 0.
        ucemh(k)  = 0.
        detmfh(k) = 0.
        alp(k)    = 0.
        rlsm(k)   = 0.
        emsm(k)   = 0.
        etsm(k,:) = 0.
      end do

!---------------------------------------------------------------------
!    initialize the variables which will contain the sum over the 
!    ensemble members of the vertical profiles of various quantities 
!    on the large-scale model grid.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        ensmbl_freeze(k)    = 0.
        ensmbl_freeze_meso(k)    = 0.
        ensmbl_melt(k)    = 0.
        ensmbl_melt_meso(k)    = 0.
        disb(k)    = 0.
        disc_liq(k) = 0.
        disc_ice(k) = 0.
        dism_liq(k) = 0.
        dism_liq_frz(k) = 0.
        dism_liq_remelt(k) = 0.
        dism_ice(k) = 0.
        dism_ice_melted(k) = 0.
        disp_liq(k) = 0.
        disp_ice(k) = 0.
        disp_melted(k) = 0.
        disd(k)    = 0.
        disv(k)    = 0.
        disz(k) = 0.
        disz_remelt(k) = 0.
        disze1(k) = 0.
        disze2(k) = 0.
        disze3(k) = 0.
        ecds_liq(k)    = 0.
        ecds_ice(k)    = 0.
        eces_liq(k)    = 0.
        eces_ice(k)    = 0.
        enctf(k)   = 0.
        encmf(k)   = 0.
        disg_liq(k)    = 0.
        disg_ice(k)    = 0.
        enev(k)    = 0.
        qtren(k,:) = 0.
        ensmbl_wetc(k,:)  = 0.
      end do

      evap_rate = 0.

!--------------------------------------------------------------------
!    initialize a logical variable which will indicate whether a
!    mesoscale circulation is present in this column. this may be 
!    precluded via the nml variable allow_mesoscale_circulation. if any
!    ensemble members are unable to support a mesoscale circulation, 
!    lmeso will be set to .false. within the following loop over the kpar
!    ensemble members. if the first member of the ensemble (the most 
!    entraining) can, then it is likely (but not guaranteed) that the 
!    ensemble will be able to.
!--------------------------------------------------------------------
      if (Nml%allow_mesoscale_circulation) then
        lmeso = .true.
      else
        lmeso = .false.
      endif

!--------------------------------------------------------------------
!    define the array of cloud model pressure levels (cld_press).
!--------------------------------------------------------------------
      do k=1,nlev_hires
        cld_press(k) = pb + (k-1)*Param%dp_of_cloud_model
      end do

!--------------------------------------------------------------------
!    if this is the first ensemble member, initialize the variables
!    which are defined on this call and will be used by the other
!    ensemble members.
!--------------------------------------------------------------------
      pcsave = phalf_c(1)

!--------------------------------------------------------------------
!    loop over the KPAR members of the cumulus ensemble.
!--------------------------------------------------------------------
      meso_frz_intg_sum = .false.
      do kou=1,Param%kpar

!-------------------------------------------------------------------
!    define the appropriate entrainment factor (alpp) for this ensemble
!    member using values based on observations either obtained from
!    the GATE or KEP studies.
!-------------------------------------------------------------------
        if (trim(Nml%entrainment_constant_source) == 'gate') then
          alpp = Param%max_entrainment_constant_gate/  &
                           Param%ensemble_entrain_factors_gate(kou)
        else if (trim(Nml%entrainment_constant_source) == 'kep') then
          alpp = Param%max_entrainment_constant_kep/  &
                           Param%ensemble_entrain_factors_kep(kou)
        else
          ermesg = 'invalid entrainment_constant_source'
          error = 1
          return
        endif

        if (Nml%do_lands) then
          alpp = alpp*lofactor     
        endif

        if (debug_ijt) then
          write (diag_unit, '(a)')    &
                     'in mulsub: phalf, temp= :'
          do k=1,nlev_lsm 
          write (diag_unit, '(i4, 2f19.10)')    &
                      k, phalf_c(k), temp_c(k)
          end do
        endif

       pmelt_lsm = 2.0e05
       do k=1,nlev_lsm-1
        if ((temp_c(k) >= Param%KELVIN) .and.    &
           (temp_c(k+1) <= Param%KELVIN)) then
          pmelt_lsm = phalf_c(k+1)
          exit
        endif
       end do

       if (debug_ijt) then
         write (diag_unit, '(a, 2f19.10)')    &
         'before cm_cloud_model call pb,  pmelt_lsm    = ', &
                                    pb, pmelt_lsm
       endif
!--------------------------------------------------------------------
!    call cloud_model to obtain the in-cloud and environmental profiles
!    and fluxes and column integrals associated with this ensemble 
!    member.
!--------------------------------------------------------------------
        call don_cm_cloud_model_k   &
             (nlev_lsm, nlev_hires, ntr, kou, diag_unit, debug_ijt,   &
              Param, Col_diag, Initialized, tb, pb, alpp, cld_press, &
              temp_c, mixing_ratio_c, pfull_c, phalf_c, tracers_c, &
              pcsave,  exit_flag_c, wv, rcl, dpf, dpftr, qlw, dfr, flux, &
              ptma(kou), dint, cu, cell_precip, apt, cell_melt, &
              pmelt_lsm, summel, efchr, emfhr, cfracice, etfhr, &
              ncc_kou, tcc, ermesg, error)

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return


!--------------------------------------------------------------------
!    if the cloud thickness is less than pdeep_mc, it will not
!    support a mesoscale circulation. set a logical flag to indicate
!    the absence of a mesoscale component for this column's cloud
!    ensemble.
!--------------------------------------------------------------------
        if (lmeso) then
          if ((pb - ptma(kou)) < Param%pdeep_mc)  then
            lmeso = .false.
          endif
        endif


        if (exit_flag_c) then
          if (lmeso) then
            cell_melt(:) = 0.0
          endif
           return
        endif

!--------------------------------------------------------------------
!    if calculations are continuing, 
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    if in diagnostics column, output the cloud base (pb) and cloud top
!    (ptma) pressures, and the mesoscale circulation logical variable
!    (lmeso).
!----------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 2f19.10,1l4)')    &
         'in mulsub: PB,PT, lmeso= ', pb, ptma(kou), lmeso
        endif

!---------------------------------------------------------------------
!    define the cloud water from this ensemble member which must be 
!    evaporated if it turns out that there is no mesoscale circulation 
!    associated with the ensemble.
!---------------------------------------------------------------------
        cld_evap(:) = -dpf(:)*(1. - (cell_precip/cu))

!---------------------------------------------------------------------
!    define the pressure one cloud model level above cloud top (ptt).
!---------------------------------------------------------------------
        ptt = ptma(kou) + Param%dp_of_cloud_model

!----------------------------------------------------------------------
!    call define_lo_res_model_profiles to map profiles generated on the
!    cloud model grid to the vertical grid of the large-scale model for
!    this ensemble member.
!----------------------------------------------------------------------
        call don_d_def_lores_model_profs_k        &
             (nlev_lsm, nlev_hires, ntr, ncc_kou, diag_unit, debug_ijt,&
              Nml, Param, pb, ptt, sfc_vapor_flux_c, sfc_sh_flux_c,  &
              sfc_tracer_flux_c, pfull_c, phalf_c, cld_press, tcc, dpf,&
              dpftr, dfr, cld_evap, qlw, emfhr, efchr, etfhr, &
              cell_freeze, evap_rate,     h1_liq, h1_ice, ci_liq_cond, &
              ci_ice_cond, h1_2, q1, qtr, wetdepl, ermesg, error)

        if (cu /= 0.0) then
          precip_frac = cell_precip/cu
        else 
          precip_frac = 0.
        endif

      if (Nml%do_ensemble_diagnostics) then
!----------------------------------------------------------------------
!    save "Don_cem" diagnostics for this ensemble member.
!----------------------------------------------------------------------
        Don_cem%cell_precip(i,j,kou) = cell_precip
        Don_cem%pb(i,j,kou) = pb
        Don_cem%ptma(i,j,kou) = ptma(kou)
! reverse index order
        do k=1,nlev_lsm
          Don_cem%h1(i,j,k,kou) = h1_liq(nlev_lsm-k + 1)  + &
                              h1_ice(nlev_lsm-k + 1)  
        end do
        do k=1,nlev_hires
          Don_cem%qlw(i,j,k,kou) = qlw(k)
          Don_cem%cfracice(i,j,k,kou) = cfracice(k)
          Don_cem%wv(i,j,k,kou) = wv(k)
          Don_cem%rcl(i,j,k,kou) = rcl(k)
        end do
     endif

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return

!---------------------------------------------------------------------
!    if this member of the ensemble supports a mesoscale circulation,
!    call mesub to obtain various terms related to moving condensate
!    from the convective tower into the mesoscale anvil for this member.
!---------------------------------------------------------------------
        if (lmeso) then
          call don_cm_mesub_k     &
               (Nml, pfull_c, nlev_lsm, me, diag_unit, debug_ijt, Param, cu,   &
                ci_liq_cond, ci_ice_cond, pmelt_lsm, cell_precip, &
                dint, plzb_c, pb, ptma(kou), temp_c, phalf_c,     &
                ca_liq, ca_ice,  ecd, ecd_liq, ecd_ice, ecei_liq, &
                ece, ece_liq, ece_ice, meso_freeze, meso_melt, ermesg, error)
        else
          ca_liq = 0.
          ca_ice = 0.
          meso_freeze = 0.
          meso_melt   = 0.
        endif

       if (pmelt_lsm < pb) then
         melting_in_cloud = .true.
       else
         melting_in_cloud = .false.
       endif

         if (ci_ice_cond /= 0.0) then
           if (melting_in_cloud) then
             precip_melt_frac = summel/ci_ice_cond
           else
             precip_melt_frac = 0.
           endif  
         else
           precip_melt_frac = 0.
         endif

       if (debug_ijt) then
         write (diag_unit, '(a, 3e20.12)')  &
            'in mulsub: h1_ice intg, summel, precip_melt_frac', &
                       ci_ice_cond, summel, precip_melt_frac
       endif

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
       if (error /= 0 ) return

!---------------------------------------------------------------------
!    call don_d_add_to_ensmbl_sum_hires_k to add this member's 
!    contribution to those fields on the cloud model grid that are being
!    summed over all ensemble members.
!---------------------------------------------------------------------
       call don_d_add_to_ensmbl_sum_hires_k    &
             (nlev_hires, ntr, ncc_kou, diag_unit, debug_ijt, &
              Param%arat(kou), cfracice, rcl, flux, emfhr, dpf, &
              qlw, etfhr, cuql, cuqli, ucemh, alp, rlsm, emsm, detmfh, &
              etsm, ermesg, error)

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return

!----------------------------------------------------------------------
!    define the fraction of total condensate which is transferred to
!    the mesoscale circulation.
!----------------------------------------------------------------------
        if (cu /= 0.0) then
          meso_frac = (ca_liq + ca_ice)/cu
        else
          meso_frac = 0.
        endif

!----------------------------------------------------------------------
!    if there is a mesoscale circulation, define the fraction of total 
!    liquid condensate transferred to the mesoscale circulation that was
!    frozen (meso_frz_frac). define a logical indicating whether any 
!    such condensate exists (meso_frz_intg). 
!----------------------------------------------------------------------
        if (lmeso) then
          bak = 0.
          do kk=1,nlev_lsm
            dp = phalf_c(kk) - phalf_c(kk+1)
            bak = bak + meso_freeze(kk)*dp
          end do
          bak = bak/(Param%grav)
          bak = bak/(Param%seconds_per_day*1.0e3)
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12)')  &
                  'in mulsub: column meso_freeze', bak
          endif
          if (bak > 0.0) then
             meso_frz_intg = .true.
          else
             meso_frz_intg = .false.
          endif
          if (ci_liq_cond /= 0.0) then
            meso_frz_frac = bak/ci_liq_cond
          else
            meso_frz_frac = 0.
          endif
        else
          meso_frz_intg = .false.
          meso_frz_frac = 0.        
        endif

!---------------------------------------------------------------------
!    if there has been liquid condensate, define the fraction of liquid
!    condensate which froze (frz_frac). define the fraction of
!    liquid condensate which froze but did not precipitate out and so
!    is available for evaporation and transfer to the mesoscale 
!    circulation (frz_frac_non_precip). 
!---------------------------------------------------------------------
        if (ci_liq_cond /= 0.0) then
          frz_frac = dint/ci_liq_cond    
          frz_frac_non_precip = frz_frac*(1.-precip_frac)   

!---------------------------------------------------------------------
!    deal with the case when the liquid condensate defined to be frozen
!    is more than the liquid condensate remaining after the appropriate
!    cell precipitation. in this case, limit the amount frozen to that 
!    which is still present in the atmosphere, and modify the 
!    cell_freeze profile and dint integral, and the frz_frac and 
!    frz_frac_non_precip ratios.
!--------------------------------------------------------------------- 
          if (.not. melting_in_cloud) then
            if (meso_frz_frac == 0. .and.  meso_frac > 0.) then
              if (meso_frac < frz_frac_non_precip) then
                do k=1,nlev_lsm
                  cell_freeze(k) = cell_freeze(k)*meso_frac/  &
                                    frz_frac_non_precip
                end do  
                dint = dint *meso_frac/frz_frac_non_precip
                frz_frac = meso_frac/(1.-precip_frac)
                frz_frac_non_precip = meso_frac
              endif
            endif
          endif
        else

!---------------------------------------------------------------------
!    if there is no liquid condensate in the column, then there is no
!    frozen liquid condensate in the column.
!---------------------------------------------------------------------
          frz_frac_non_precip = 0.
          frz_frac = 0.
        endif

        if (debug_ijt) then
          write (diag_unit, '(a, 3e20.12)')  &
                   'in mulsub pre anvil_cond_frz: h1_liq intg, dint,&
                       & frz_frac_non_precip           ', &
                   ci_liq_cond, dint, frz_frac_non_precip
          write (diag_unit, '(a, 1e20.12)')  &
                                 'in mulsub : frz_frac', &
                                    frz_frac

!----------------------------------------------------------------------
!    if there is a mesoscale circulation, define the fraction of total 
!    liquid condensate transferred to the mesoscale circulation which 
!    is frozen (meso_frz_frac). define a logical indicating whether any 
!    such condensate exists (meso_frz_intg). 
!----------------------------------------------------------------------
              write (diag_unit, '(a, i4, 2e20.12)')  &
           'in mulsub : kou,  meso_frz_frac, precip_melt_frac', &
                                 kou,  meso_frz_frac, precip_melt_frac
          endif

!---------------------------------------------------------------------
!    call don_d_add_to_ensmbl_sum_intgl_k to add this member's 
!    contribution to those integrals that are being summed over all 
!    ensemble members.
!---------------------------------------------------------------------
        call don_d_add_to_ensmbl_sum_intgl_k    &
             (diag_unit, debug_ijt, lmeso,                   &
                      Param%arat(kou),      &
              ca_liq, ca_ice, frz_frac_non_precip, meso_frac,  &
              cell_precip, cu, apt, ensmbl_precip, ensmbl_cond,   &
                                 ensmbl_anvil_cond_liq, &
              ensmbl_anvil_cond_liq_frz, meso_frz_intg, meso_frz_frac,&
              ensmbl_anvil_cond_ice, ensmbl_cld_top_area, ermesg, error)

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return

        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3f19.10)')    &
                     'in mulsub: meso_frac, precip_frac,frz_frac_non_precip:', &  
                     kou, meso_frac, precip_frac, frz_frac_non_precip
          write (diag_unit, '(a, i4, 4f19.10)')    &
                     'in mulsub: cu, ca, cell_precip, dint   :', &  
                         kou, cu, ca_liq + ca_ice, cell_precip,   &
                         dint*Param%seconds_per_day
          write (diag_unit, '(a, 3f19.10)')    &
                     'in mulsub: pmelt_lsm, pb, summel   :', &  
                         pmelt_lsm, pb,  summel          
        endif

!---------------------------------------------------------------------
!    call don_d_add_to_ensmbl_sum_lores_k to add this member's 
!    contribution to those fields on the lrge-scale model grid that are 
!    being summed over all ensemble members.
!---------------------------------------------------------------------

        call don_d_add_to_ensmbl_sum_lores_k    &
             (nlev_lsm, ntr, diag_unit, debug_ijt, lmeso, &
                             frz_frac, Param, Nml,  &
              Param%arat(kou), dint, cell_freeze,         cell_melt, &
              wetdepl, temp_c,   &
              h1_2, ecd, ecd_liq, ecd_ice, ece, ece_liq, ece_ice, &
              evap_rate, q1,     h1_liq, h1_ice, pfull_c, meso_melt, &
              meso_freeze, phalf_c, qtr, ensmbl_melt, ensmbl_melt_meso,&
              ensmbl_freeze, ensmbl_freeze_meso, ensmbl_wetc, &
              meso_frac, precip_frac, frz_frac_non_precip, &
              disz, disz_remelt, disp_melted, disze1, disze2, disze3,  &
              disp_liq, disp_ice, enctf, encmf, enev, disg_liq,  &
              disg_ice, disb, disc_liq, disc_ice, dism_liq,  &
              dism_liq_frz, dism_liq_remelt, dism_ice, dism_ice_melted,&
              ecds_liq, ecds_ice, eces_liq, eces_ice, disd, disv, &
              qtren, ermesg, error, meso_frz_intg, melting_in_cloud, &
              precip_melt_frac, meso_frz_frac)

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return

!--------------------------------------------------------------------
!    save the cloud top (ptma) pressures, the total condensation (cuto),
!    total precpitation (preto) and cloud top index (ncca) from this !
!    ensemble member.
!--------------------------------------------------------------------
         if (meso_frz_intg) meso_frz_intg_sum = .true.
        cuto(kou)  = cu
        preto(kou) = cell_precip
        ncca(kou)  = ncc_kou
      end do   ! (kou loop over ensemble members)

!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! 31   CONTINUE
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$


!--------------------------------------------------------------------
!    if calculations are continuing: 
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    define ensemble cloud top pressure (pt_ens) to be the cloud top of 
!    the most penetrative ensemble member. this is frequently, but not 
!    always, the ensemble member with the lowest entrainment rate. 
!    cloud base pressure (pb) is the same for all ensemble members. 
!    define the cloud top index(ncc_ens)  as the highest of any ensemble 
!    member.
!----------------------------------------------------------------------
      pt_ens  = MINVAL (ptma)
      ncc_ens = MAXVAL (ncca)

!----------------------------------------------------------------------
!    divide the ensemble mean ice and liquid condensate terms by the 
!    total cloud area to define the average cloud water and cloud ice 
!    concentrations within the cloudy area, as opposed to averaged over 
!    the entire grid box.
!----------------------------------------------------------------------
      do k=1,ncc_ens
        if (alp(k) > 0.) then
          cuql(k)  = cuql(k)/alp(k)
          cuqli(k) = cuqli(k)/alp(k)
        endif
      end do

!---------------------------------------------------------------------
!    define the cloudtop anvil area (ampta1), assumed to be five times 
!    larger than the sum of the cloud top areas of the ensemble members,
!    as in Leary and Houze (1980), 
!---------------------------------------------------------------------
      ampta1 = 5.*ensmbl_cld_top_area

!---------------------------------------------------------------------
!    if there is no precipitation production in this column, set the 
!    inverse of the max cloud area at any layer in the column to be 0.0.
!---------------------------------------------------------------------
      if (ensmbl_precip == 0.0) then
        amax      = 0.0
      else

!---------------------------------------------------------------------
!    if there is precip in the column, determine the maximum convective 
!    cell area at any level in the column (al). the total normalized 
!    cloud area in the column (cell area + mesoscale area) cannot be 
!    greater than 1.0. this constraint imposes a limit on the cloud area
!    at cloud base (amax). this limit will be imposed in subroutine
!    determine_cloud_area. see "a bounds notes" (7/6/97).
!---------------------------------------------------------------------
        al = MAXVAL (alp)
        amax = 1./(al + ampta1)
      endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the total ensemble condensation,
!    (ensmbl_cond), precipitation (ensmbl_precip), and condensate 
!    transferred into the anvil (ensmbl_anvil_cond). also output 
!    surface pressure (phalf_c(1)), ensemble cloud base nd cloud top 
!    pressures (pb, pt_ens), the flag indicating if a mesoscale circul-
!    ation is present in the grid column (lmeso), and the cloud top anvil
!    area (ampta1).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, a, e20.12)')  &
                      'in mulsub: CUTOT=', ensmbl_cond, ' PRETOT=', &
                                      ensmbl_precip
        write (diag_unit, '(a, 4e20.12)') &
               'in mulsub: CATOT, (sum, liq, frzliq,ice)=', &
              ensmbl_anvil_cond_liq  + ensmbl_anvil_cond_liq_frz  +  &
                                   ensmbl_anvil_cond_ice, &
                                     ensmbl_anvil_cond_liq, &
                                     ensmbl_anvil_cond_liq_frz, &
                                     ensmbl_anvil_cond_ice
        write (diag_unit, '(a, 3f19.10, 1l4)')  &
              'in mulsub: ps,pb,pt,lmeso= ',   &
                     phalf_c(1), pb, pt_ens, lmeso
        write (diag_unit, '(a, e20.12)')  &
                                 'in mulsub: ampt= ',ampta1     
      endif

!----------------------------------------------------------------------
!    define the pressure one level above cloud top (ptt).
!----------------------------------------------------------------------
      ptt = pt_ens + Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    call define_ensemble_profiles to produce vertical profiles 
!    representing the ensemble-total cloud area (ensmbl_cloud_area), 
!    cloud liquid (cuql_v), cloud ice (cuq), mass flux(uceml) and
!    detrained mass flux (detmfl).
!--------------------------------------------------------------------
      call don_d_def_ensemble_profs_k    &
           (nlev_lsm, nlev_hires, ncc_ens, diag_unit, debug_ijt, ptt, &
            cld_press, alp, detmfh, ucemh, cuql, cuqli, phalf_c,  &
            ensmbl_cloud_area, cuql_v, cuq, detmfl, uceml, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, call error_mesg.
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    execute the following code if in a diagnostics column.
!---------------------------------------------------------------------
      if (debug_ijt) then

!----------------------------------------------------------------------
!    define the pressure at the large-scale model interface level at or 
!    just above cloud base (psmx).
!----------------------------------------------------------------------
        do k=1,nlev_lsm
          if ((phalf_c(k+1) <= pb) .and. (phalf_c(k) >= pb)) then
            psmx = phalf_c(k+1)
            exit
          endif
        end do

!----------------------------------------------------------------------
!    define the integrated boundary layer heating rate (sbl) due to the 
!    surface heat flux (sfcsf_v). it is defined in units of (deg K)/sec.
!    call don_u_map_hires_i_to_lores_c_k to distribute
!    this heating over the boundary layer.
!---------------------------------------------------------------------
       sbl = Param%grav*sfc_sh_flux_c/((phalf_c(1) - psmx)*Param%cp_air)
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
             'in cm_intgl_to_gcm_col: xav,p1,p2= ',sbl, phalf_c(1), psmx 
        call don_u_map_hires_i_to_lores_c_k   &
             (nlev_lsm, sbl, phalf_c(1), psmx, phalf_c, sfch, ermesg, error)

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return

        do k=1,size(sfch(:))
          if (sfch(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                            'in cm_intgl_to_gcm_col: k,x= ',k,sfch(k)
          endif
        end do

!----------------------------------------------------------------------
!    define the integrated boundary layer moistening rate (sbl) due to 
!    the surface moisture flux (sfcqf_v), which is defined in units of 
!    kg(h2o) per m**2 per sec. call 
!    don_u_map_hires_i_to_lores_c_k to distribute 
!    this moistening over the boundary layer.
!---------------------------------------------------------------------
        sbl = (sfc_vapor_flux_c*Param%grav)/(phalf_c(1) - psmx)
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
             'in cm_intgl_to_gcm_col: xav,p1,p2= ',sbl, phalf_c(1), psmx 
        call don_u_map_hires_i_to_lores_c_k   &
             (nlev_lsm, sbl, phalf_c(1), psmx, phalf_c, sfcq, ermesg, error)

!---------------------------------------------------------------------
!    if an error message was returned from the kernel routine, return
!    to the calling program where it will be processed.
!---------------------------------------------------------------------
        if (error /= 0 ) return

        do k=1,size(sfcq(:))
          if (sfcq(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                            'in cm_intgl_to_gcm_col: k,x= ',k,sfcq(k)
          endif
        end do
      endif ! (debug_ijt)

!---------------------------------------------------------------------



end subroutine don_d_integ_cu_ensemble_k 

!#######################################################################

subroutine don_d_column_end_of_step_k  &
         (isize, jsize, nlev_lsm, ntr, Col_diag, exit_flag,   &
          total_precip, parcel_rise, temperature_forcing,&
          moisture_forcing, tracers, Don_cape, Don_conv, ermesg, error)       

!----------------------------------------------------------------------
!    subroutine don_d_column_end_of_step outputs the final values of
!    significant fields generated by donner_deep_mod in any columns
!    for which column diagnostics were requested, and in which deep
!    convection is present.
!----------------------------------------------------------------------

use donner_types_mod, only : donner_cape_type, donner_conv_type, &
                             donner_column_diag_type

implicit none

!----------------------------------------------------------------------
integer,                          intent(in)    :: isize, jsize,  &
                                                   nlev_lsm, ntr
type(donner_column_diag_type),    intent(in)    :: Col_diag
logical, dimension(isize,jsize),  intent(in)    :: exit_flag
real,    dimension(isize,jsize),  intent(in)    :: total_precip,  &
                                                   parcel_rise
real,    dimension(isize,jsize,nlev_lsm),             &
                                  intent(in)    :: temperature_forcing, &
                                                   moisture_forcing
real,    dimension(isize,jsize,nlev_lsm,ntr),        &
                                  intent(in)    :: tracers
type(donner_cape_type),           intent(inout) :: Don_cape
type(donner_conv_type),           intent(inout) :: Don_conv
character(len=*),                 intent(out)   :: ermesg
integer,                          intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     exit_flag      logical variable indicating whether deep convection
!                    is present or not in each column
!     total_precip   precipitation generated by deep convection
!                    [ kg / m**2 ]
!     parcel_rise    accumulated vertical displacement of a 
!                    near-surface parcel as a result of the lowest
!                    model level omega field [ Pa ]
!     temperature_forcing
!                    time tendency of temperature due to deep 
!                    convection [ deg K / sec ]
!     moisture_forcing
!                    time tendency of vapor mixing ratio due to deep 
!                    convection [ kg(h2o) / kg(dry air) / sec ]
!     tracers        tracer mixing ratios
!                    [ kg(tracer) / kg (dry air) ]
!
!   intent(inout) variables:
!
!     Don_cape       donner_cape type derived type variable containing
!                    diagnostics related to the cape calculation assoc-
!                    iated with the donner convection parameterization
!     Don_conv       donner_convection_type derived type variable con-
!                    taining diagnostics describing the nature of the 
!                    convection produced by the donner parameterization
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer :: k, n, kcont      ! do-loop indices
      integer :: i, j, unit

      ermesg= ' ' ; error = 0

!--------------------------------------------------------------------
!    determine if deep convection exists in any of the columns in the 
!    window for which column diagnostics were requested.
!--------------------------------------------------------------------
      do n=1,Col_diag%ncols_in_window

!--------------------------------------------------------------------
!    determine if deep convection exists in any of the columns in the 
!    window for which column diagnostics were requested. if deep
!    convection is present, output a multitude of values; if deep con-
!    vection is not present, cycle to check the next diagnostics 
!    column in the window.
!--------------------------------------------------------------------
        if (.not. exit_flag(Col_diag%i_dc(n), Col_diag%j_dc(n))) then
          i = Col_diag%i_dc(n)
          j = Col_diag%j_dc(n)
          unit = Col_diag%unit_dc(n)

!---------------------------------------------------------------------
!    output the pressures at lifting condensation level (plcl), at the
!    level of free convection (plfc), and at the level of zero buoyancy
!    (plzb).
!---------------------------------------------------------------------
          write (unit, '(a, e20.12)')  & 
                'in donner_deep: plcl ', Don_cape%plcl(i,j)
          write (unit, '(a, e20.12)')  & 
                 'in donner_deep: plfc ', Don_cape%plfc(i,j)
          write (unit, '(a, e20.12)')  & 
              'in donner_deep: plzb ', Don_cape%plzb(i,j)

!---------------------------------------------------------------------
!    output the lag time value of cape (xcape_lag), the convective 
!    inhibition (coin), the time tendency of cape (dcape) and the lag
!    time column integrated water vapor (qint_lag).
!---------------------------------------------------------------------
          write (unit, '(a, e20.12)')  & 
               'in donner_deep: xcape ',   &
                              Don_cape%xcape_lag(i,j)
          write (unit, '(a, e20.12)')  & 
               'in donner_deep: coin ', Don_cape%coin(i,j)
          write (unit, '(a, e20.12)')  & 
              'in donner_deep: dcape ', Don_conv%dcape(i,j)
          write (unit, '(a, e20.12)')  & 
              'in donner_deep: qint ',  Don_cape%qint_lag(i,j)

!---------------------------------------------------------------------
!    output the total cloud fractional area (a1), the maximum allowed
!    value for a1 (amax), the maximum cloud fractional area based on the
!    moisture constraint (amos), the total precipitation from the col-
!    umn (total_precip), the mesoscale cloud fractional area (ampta1),
!    the displacement of a parcel from its initial location due to 
!    accrued upward motion at the current time (parcel_rise), and the
!    convective precipitation rate (cell_precip).
!---------------------------------------------------------------------
          write (unit, '(a, e20.12)')  & 
               'in donner_deep: a1   ', Don_conv%a1(i,j)
          write (unit, '(a, e20.12)')  & 
            'in donner_deep: amax ', Don_conv%amax(i,j)
          write (unit, '(a, e20.12)')  & 
            'in donner_deep: amos ', Don_conv%amos(i,j)
          write (unit, '(a, e20.12)')  & 
            'in donner_deep: tprea1 ', total_precip(i,j)
          write (unit, '(a, e20.12)')  & 
             'in donner_deep: ampta1 ', Don_conv%ampta1(i,j)
          write (unit, '(a, e20.12)')  & 
              'in donner_deep: omint', parcel_rise(i,j)
          write (unit, '(a, e20.12)')  & 
               'in donner_deep: rcoa1 ', Don_conv%cell_precip(i,j)

!---------------------------------------------------------------------
!    output various 3d fields between the specified highest index at
!    which diagnostics are to be output (kstart) and the nearest 
!    level to the surface (nlev_lsm), provided there has been some effect 
!    of deep convection at the level.
!---------------------------------------------------------------------
          do k=Col_diag%kstart,nlev_lsm
            if (temperature_forcing (i,j,k) == 0.0) cycle
            write (unit, '(a, i4)')'in donner_deep: k = ', k
            write (unit, '(a, e20.12)')  &
                 'in donner_deep: cemetf output to calling routine',  &
                     temperature_forcing(i,j,k)             
            write (unit, '(a, e20.12)')  &
                    'in donner_deep:TOTAL convective cemetf',  &
                     Don_conv%conv_temp_forcing(i,j,k)            
            write (unit, '(a, e20.12)')  &
                      'in donner_deep: ceefc ',     &
                               Don_conv%ceefc(i,j,k)             
            write (unit, '(a, e20.12)')  &
                      'in donner_deep: cecon ',  &
                                Don_conv%cecon(i,j,k)
            write (unit, '(a, e20.12)')  &
                     'in donner_deep: cemfc ',   &
                               Don_conv%cemfc(i,j,k)
            write (unit, '(a, e20.12)')  &
                 'in donner_deep: cememf output to calling routine',  &
                        moisture_forcing(i,j,k)               
            write (unit, '(a, e20.12)')  &
                     'in donner_deep: TOTAL convective cememf',  &
                        Don_conv%conv_moist_forcing (i,j,k)            
            write (unit, '(a, e20.12)')  &
                      'in donner_deep: cememf_mod',  &
                                Don_conv%cememf_mod(i,j,k)            
            write (unit, '(a, e20.12)')  &
                       'in donner_deep: cual  ',  &
                                  Don_conv%cual(i,j,k)              
            write (unit, '(a, e20.12)')  &
                       'in donner_deep: fre   ',   &
                                  Don_conv%fre(i,j,k)             
            write (unit, '(a, e20.12)')  &
                        'in donner_deep: elt   ',  &
                                     Don_conv%elt(i,j,k)            
            write (unit, '(a, e20.12)')  &
                         'in donner_deep: cmus  ',    &
                                     Don_conv%cmus(i,j,k)            
            write (unit, '(a, e20.12)')  &
                         'in donner_deep: ecds ',   &
                                    Don_conv%ecds(i,j,k)             
            write (unit, '(a, e20.12)')  &
                         'in donner_deep: eces  ', &
                                     Don_conv%eces(i,j,k)            
            write (unit, '(a, e20.12)')  &
                         'in donner_deep: emds  ',  &
                                     Don_conv%emds(i,j,k)             
            write (unit, '(a, e20.12)')  &
                          'in donner_deep: emes  ',  &
                                     Don_conv%emes(i,j,k)              
            write (unit, '(a, e20.12)')  &
                          'in donner_deep: qmes  ',  &
                                    Don_conv%mrmes(i,j,k)            
            write (unit, '(a, e20.12)')  &
                          'in donner_deep: wmps  ', &
                                      Don_conv%wmps(i,j,k)            
            write (unit, '(a, e20.12)')  &
                          'in donner_deep: wmms  ',  &
                                       Don_conv%wmms(i,j,k)            
            write (unit, '(a, e20.12)')  &
                           'in donner_deep: tmes  ',  &
                                        Don_conv%tmes(i,j,k)            
            write (unit, '(a, e20.12)')  &
                             'in donner_deep: dmeml ',   &
                                       Don_conv%dmeml(i,j,k)            
            write (unit, '(a, e20.12)')  &
                              'in donner_deep: uceml ',  &
                                       Don_conv%uceml(i,j,k)            
            write (unit, '(a, e20.12)')  &
                              'in donner_deep: detmfl ',  &
                                      Don_conv%detmfl(i,j,k)            
            write (unit, '(a, e20.12)')  &
                               'in donner_deep: umeml ',   &
                                      Don_conv%umeml(i,j,k)            

!---------------------------------------------------------------------
!    output various tracer-related fields for each tracer transported
!    by donner_deep_mod.
!---------------------------------------------------------------------
            do kcont=1,ntr     
              write (unit, '(a, e20.12)')  &
                              'in donner_deep: xgcm1 ',   &
                            tracers(i,j,k,kcont)                 
              write (unit, '(a, e20.12)')  &
                               'in donner_deep: qtren1 ',  &
                              Don_conv%qtren1(i,j,k,kcont)             
              write (unit, '(a, e20.12)')  &
                                'in donner_deep: qtmes1 ',  &
                              Don_conv%qtmes1(i,j,k,kcont)             
              write (unit, '(a, e20.12)')  &
                                'in donner_deep: temptr',  &
                              Don_conv%temptr(i,j,k,kcont)
              write (unit, '(a, e20.12)')  &
                                   'in donner_deep: qtceme ',   &
                               Don_conv%qtceme(i,j,k,kcont)             
              write (unit, '(a, e20.12)')  &
                                  'in donner_deep: wtp1 ',   &
                                Don_conv%wtp1(i,j,k,kcont)            
            end do
          end do  ! (k loop)
        endif
      end do    ! (n loop)

!--------------------------------------------------------------------


end subroutine don_d_column_end_of_step_k
 



!#####################################################################

subroutine don_d_convert_profile_k     &
         (name_hi, name_lo, n_lo, n_hi, ncc, profile_hi, press_hi, ptop,&
          include_set_value, include_sbl, include_conservation_factor, &
          set_value, sbl, conservation_factor, press_lo, diag_unit,  & 
          debug_ijt, profile_lo, ermesg, error)

!----------------------------------------------------------------------
!    subroutine don_d_convert_profile_k takes an input profile 
!    (profile_hi) associated with a character string name_hi on the 
!    hi-res model grid (press_hi) containing ncc_ens levels and extending
!    to a pressure level ptop and maps it to variable profile_lo assoc-
!    iated with character string name_lo on the lo-res model grid defined
!    by press_lo.
!    additonally, if desired, the integral of the profile on the lo-res
!    grid multiplied by conservation_factor may be set to set_value by 
!    modifying the profile below cloud base, or a specified sub-cloud 
!    source (sbl) may be added to the lo-res profile.
!    if column diagnostics are desired (debug_ijt), they are output to
!    diag_unit.
!-----------------------------------------------------------------------

implicit none

character(len=*),      intent(in)  :: name_hi, name_lo
integer,               intent(in)  :: n_lo, n_hi, ncc
real, dimension(n_hi), intent(in)  :: profile_hi, press_hi
real,                  intent(in)  :: ptop
logical,               intent(in)  :: include_set_value, include_sbl, &
                                      include_conservation_factor
real,                  intent(in)  :: set_value, sbl
real, dimension(n_lo), intent(in)  :: conservation_factor, press_lo
integer,               intent(in)  :: diag_unit
logical,               intent(in)  :: debug_ijt
real, dimension(n_lo), intent(out) :: profile_lo
character(len=*),      intent(out) :: ermesg
integer,               intent(out) :: error

!----------------------------------------------------------------------
!   intent(in) variables:
!
!       name_hi       character string associated with input profile
!       name_lo       character string associated with output profile
!       n_lo          number of levels on lo-res grid
!       n_hi          number of levels on hi_res grid
!       ncc           number of layers in input profile that are affected
!                     by presence of cloud; it may be called with 
!                     ncc_kou for each ensemble member 
!                     (from define_lo_res_model_profiles or 
!                     add_to_ensemble_sum_hires), or with ncc_ens
!                     (from define_ensemble_profiles).
!       profile_hi    vertical profile on hi-res model grid
!       press_hi      full pressure levels of hi-res model [ Pa ]
!       ptop          pressure one level above cloud top  [ Pa ]
!       include_set_value
!                     it is desired to force the column integral to a
!                     specified value on the lo-res grid ?
!       include_sbl   it is desired to add a specified value to the
!                     profile in the layers below cloud base ?
!       include_conservation_factor
!                     the integrand which is to be set to set_value 
!                     includes a non-unity factor which multiplies the 
!                     profile ?
!       set_value     value desired for the integral of the
!                     output profile times conservation_factor      
!       sbl           value to be added to the profile in all layers
!                     below cloud base
!       conservation_factor
!                     the column integral of the product of the profile 
!                     and conservation_factor arrays is required to equal
!                     set_value
!       press_lo      interface pressure levels of lo-res model [ Pa ]
!       diag_unit     unit number for column diagnostics file
!       debug_ijt     column diagnostics are desired for this column ?
!
!   intent(out) variables:
!
!       profile_lo    vertical profile on lo-res model grid
!       ermesg        error message produced by any kernel routines
!                     called by this subroutine 
!
!-----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:
  
      real, dimension(n_lo) :: out       ! intermediate lo-res profile 
                                         ! after either setting column
                                         ! integral or adding boundary 
                                         ! layer source
      real, dimension(n_lo) :: conservation_factor_used                
                                         ! conservation_factor array 
                                         ! used in calculation; is array
                                         ! of 1.0 when 
                                         ! include_conservation_factor
                                         ! is .false.
      real                  :: intgl_hi  ! column integral of profile_hi 
      real                  :: intgl_lo  ! column integral of profile_lo
      integer               :: k         ! do-loop index

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!---------------------------------------------------------------------
!    if column diagnostics are desired, output a diagnostic message 
!    indicating the variable that is being processed.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a)')  &
           'in mulsub: map_hi_res_col_to_lo_res_col: ' // trim(name_hi)
      endif

!----------------------------------------------------------------------
!   call don_u_map_hires_c_to_lores_c_k to map the 
!   profile from the hi-res model grid to the lo-res model grid.
!----------------------------------------------------------------------
      call don_u_map_hires_c_to_lores_c_k     &
          (n_lo, ncc+1, profile_hi(1:ncc+1), press_hi(1:ncc+1),  &
           ptop, press_lo, profile_lo, intgl_hi, intgl_lo, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
       if (error /= 0 ) then
        return
      endif

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals of the
!    profiles on both the hi- and lo-res grids.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
             'in mulsub: rintsum(' // trim(name_lo) // ' ) =',  &
                                              intgl_hi, intgl_lo

!---------------------------------------------------------------------
!    call don_u_compare_integrals_k to assess if the integrals
!    from the two grids are "equal", as they should be.
!---------------------------------------------------------------------
        call don_u_compare_integrals_k    &
                         (intgl_hi, intgl_lo, diag_unit, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) then
          return
        endif
      endif

!----------------------------------------------------------------------
!    if it is desired to set the integral value for the profile (i.e.,
!    set_value does not equal dummy_set_value), execute the following
!    code.
!----------------------------------------------------------------------
      if (include_set_value) then
        if (include_conservation_factor) then
          conservation_factor_used(:) = conservation_factor(:)
        else
          conservation_factor_used(:) = 1.0                   
        endif
        
!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrands at each
!    level on the lo-res grid.
!---------------------------------------------------------------------
        if (debug_ijt) then
          do k=1,n_lo                   
            if (profile_lo(k) /= 0.0) then
              write (diag_unit, '(a, i4, e20.12)') &
                 'in set_col_integral: k,phr,phr+= ', k, profile_lo(k)* &
                              conservation_factor_used(k)
            endif
          end do
        endif

!-----------------------------------------------------------------------
!    call don_u_set_column_integral_k to adjust the output
!    profile below cloud base so that the desired integral value is
!    obtained.
!-----------------------------------------------------------------------
        call don_u_set_column_integral_k    &
               (n_lo, profile_lo*conservation_factor_used, press_hi(1), &
                press_lo(1), set_value, press_lo, intgl_hi,     &
                intgl_lo, out, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) then
          return
        endif

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals and 
!    profiles, both before and after the adjustment to the desired value.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, e20.12)')  &
                           'in set_col_integral: column(in)= ',intgl_hi
          write (diag_unit, '(a, e20.12)')  &
                          'in set_col_integral: column(out)= ',intgl_lo 
          do k=1,n_lo                 
            if (profile_lo(k)*conservation_factor_used(k) /= out(k)) then
              write (diag_unit, '(a, i4, 2e20.12)') &
               'in set_col_integral: k,qtr(in), qtr(out)= ', k,  &
                      profile_lo(k)*conservation_factor_used(k), out(k)
            endif
          end do
        endif

!---------------------------------------------------------------------
!    define the adjusted output profile by removing conservation_factor.
!---------------------------------------------------------------------
        profile_lo(:) = out(:)/conservation_factor_used(:)
      endif !(set_value /= dummy_set_value)

!----------------------------------------------------------------------
!    if a boundary layer source is to be added to the profile, execute
!    the following code.
!----------------------------------------------------------------------
      if (include_sbl .and. sbl /= 0.0) then

!----------------------------------------------------------------------
!    call don_u_apply_integral_source_k to apply the imposed 
!    subcloud source (sbl) to the input profile profile_out, resulting 
!    in the output profile out.  also returned are the column integrals
!    of the input profile (intgl_in) and the integral of the output
!    profile (intgl_out).
!    NOTE: in the original code, the subcloud source was not applied in 
!    the non-entropy case anywhere, and in the entropy case only to the 
!    model layer containing cloud base. 
!    I have MODIFIED THE CODE so that the value is APPLIED FROM SFC TO
!    TOP OF SPECIFIED REGION (CLOUD BASE) IS THIS CORRECT AND WHAT WAS
!    INTENDED ?
!----------------------------------------------------------------------
        call don_u_apply_integral_source_k     &
             (n_lo, profile_lo, press_hi(1), press_lo(1), sbl,  &
              press_lo, intgl_hi, intgl_lo, out, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) then
          return
        endif

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals and 
!    profiles, both before and after adding the boundary layer source.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 3e20.12)')  &
             'after apply_subcloud: column(in)= ',   &
                             intgl_hi, press_lo(1), press_hi(1)
          write (diag_unit, '(a, e20.12)')  &
                           'after apply_subcloud: column(out)= ',  &
                                                       intgl_lo 
          do k=1,n_lo                  
            if (profile_lo(k) /= out(k)) then
              write (diag_unit, '(a, i4, 2e20.12)') &
               'in set_col_integral: k,qtr(in), qtr(out)= ', k,  &
                                       profile_lo(k), out(k)
            endif
          end do
        endif

!----------------------------------------------------------------------
!    define the output profile on the lo-res model grid to be returned to
!    the calling routine.
!----------------------------------------------------------------------
        profile_lo(:) = out(:)
      endif  !(sbl /= 0.0)

!---------------------------------------------------------------------


end subroutine don_d_convert_profile_k



!#####################################################################

subroutine don_d_def_ensemble_profs_k    &
         (nlev_lsm, nlev_hires, ncc_ens, diag_unit, debug_ijt, ptt,  &
          cld_press, alp, detmfh, ucemh, cuql, cuqli, phalf_c,  &
          ensmbl_cloud_area, cuql_v, cuq, detmfl, uceml, ermesg, error)


!---------------------------------------------------------------------
!    subroutine don_d_def_ensemble_profs_k defines vertical 
!    profiles of cloud area, cloud ice, cloud liquid, vertical mass flux
!    and detrained vertical mass flux produced by the entire cumulus 
!    ensemble on the lo-res grid. 
!---------------------------------------------------------------------

implicit none

!---------------------------------------------------------------------
integer,                        intent(in)   :: nlev_lsm, nlev_hires,&
                                                ncc_ens, diag_unit
logical,                        intent(in)   :: debug_ijt
real,                           intent(in)   :: ptt
real,    dimension(nlev_hires), intent(in)   :: cld_press, alp,  &
                                                detmfh, ucemh, cuql,  &
                                                cuqli
real,    dimension(nlev_lsm+1), intent(in)   :: phalf_c
real,    dimension(nlev_lsm),   intent(out)  :: ensmbl_cloud_area,  &
                                                cuql_v, cuq, detmfl, &
                                                uceml     
character(len=*),               intent(out)  :: ermesg
integer,                        intent(out)  :: error

!--------------------------------------------------------------------
!   intent(in) variables:
!
!        ptt        pressure one cloud model level above the ensemble
!                   cloud top [ Pa ]
!        nlev_lsm   number of levels in the low resolution grid
!        nlev_hires       number of levels in the high resolution grid
!        ncc_ens    cloud top index for the ensemble on the hi-res grid
!        cld_press  pressures at hi-res model levels [ Pa ]
!        alp        cloud area profile on hi-res model grid
!                   [ fraction ]
!        detmfh     detrained mass flux (layer above index level)
!                   (on cloud-model grid) (index 1 at cloud base)
!                   [ kg (air) / (sec m**2) ]
!        ucemh      upward mass flux on cloud model grid            
!                   [ kg (air) / (sec m**2) ]
!        cuql       ice water profile on cloud model grid; on input is
!                   normalized by total grid box area, on output is
!                   normalized by ensemble cloud area.
!        cuqli      liquid water profile on cloud model grid; on input 
!                   is normalized by total grid box area, on output is
!                   normalized by ensemble cloud area.
!        phalf_c    pressure at lo-res model half levels [ Pa ]
!        diag_unit  unit for column diagnostics output
!        debug_ijt  are column diagnostics desired in this column ?
!
!   intent(out) variables:
!
!        ensmbl_cloud_area  
!                   total cloud area profile over all ensemble members
!                   on large_scale model grid [ fraction ]
!        cuql_v     liquid water profile on large-scale model grid, 
!                   normalized by ensemble cloud area.
!        cuq        ice water profile on large-scale model grid, 
!                   normalized by ensemble cloud area.
!        detmfl     detrained mass flux on large-scale model grid
!                   normalized by ensemble cloud area
!                   index 1 near large-scale model base
!                   [ kg (air) / (sec m**2) ]
!        uceml      upward mass flux on large_scale model grid       
!                   [ kg (air) / (sec m**2) ]
!        ermesg     error message produced by any kernel routines
!                   called by this subroutine 
!
!--------------------------------------------------------------------

      real, dimension (nlev_lsm) :: conv_fact

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      conv_fact = 0.0

!----------------------------------------------------------------------
!    call don_d_convert_profile_k to map the ensemble-total cloud 
!    area profile from the cloud model grid (alp) to the large-scale 
!    model grid (ensmbl_cloud_area).
!----------------------------------------------------------------------
      call don_d_convert_profile_k    &
         ('alp', 'cual', nlev_lsm, nlev_hires, ncc_ens, alp, cld_press, &
          ptt, .false., .false., .false.,  0.0, 0.0, conv_fact, &
          phalf_c, diag_unit, debug_ijt, ensmbl_cloud_area, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    call convert_profile to map the ensemble-total condensed ice 
!    profile from the cloud model grid (cuql) to the large-scale model 
!    grid (cuq).
!----------------------------------------------------------------------
      call don_d_convert_profile_k    &
         ('cuql', 'cuq', nlev_lsm, nlev_hires, ncc_ens, cuql, cld_press,&
          ptt, .false., .false., .false.,  0.0, 0.0, conv_fact, &
          phalf_c, diag_unit, debug_ijt, cuq, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    call convert_profile to map the ensemble-total condensed liquid
!    profile from the cloud model grid (cuql) to the large-scale model 
!    grid (cuq).
!----------------------------------------------------------------------
      call don_d_convert_profile_k    &
         ('cuqli', 'cuql_v', nlev_lsm, nlev_hires, ncc_ens, cuqli, &
          cld_press, ptt, .false., .false., .false.,  0.0, 0.0,  &
          conv_fact, phalf_c, diag_unit, debug_ijt, cuql_v, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    call convert_profile to map the ensemble-total upward mass flux
!    profile from the cloud model grid (ucemh) to the large-scale model 
!    grid (uceml).
!----------------------------------------------------------------------
      call don_d_convert_profile_k    &
         ('ucemh', 'uceml', nlev_lsm, nlev_hires, ncc_ens, ucemh, &
          cld_press, ptt, .false., .false., .false.,  0.0, 0.0,   &
          conv_fact, phalf_c, diag_unit, debug_ijt, uceml, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call convert_profile to map the ensemble-total detrained mass flux
!    profile from the cloud model grid (detmfh) to the large-scale model 
!    grid (detmfl).
!----------------------------------------------------------------------
      call don_d_convert_profile_k    &
         ('detmfh', 'detmfl', nlev_lsm, nlev_hires, ncc_ens, detmfh, &
          cld_press, ptt, .false., .false., .false.,  0.0, 0.0,  &
          conv_fact, phalf_c, diag_unit, debug_ijt, detmfl, ermesg, error)
 
!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------

end subroutine don_d_def_ensemble_profs_k
    

!#####################################################################

subroutine don_d_def_lores_model_profs_k               &
         (nlev_lsm, nlev_hires, ntr, ncc_kou, diag_unit, debug_ijt,  &
          Nml, Param, pb, ptt, sfc_vapor_flux_c, sfc_sh_flux_c,   &
          sfc_tracer_flux_c, pfull_c, phalf_c, cld_press, tcc, dpf,  &
          dpftr, dfr, cld_evap, qlw, emfhr, efchr, etfhr, cell_freeze, &
          evap_rate, h1_liq, h1_ice,  ci_liq_cond, ci_ice_cond, h1_2, &
          q1, qtr, wetdepl, ermesg, error)
 
!---------------------------------------------------------------------
!    subroutine don_d_def_lores_model_profs_k maps vertical
!    profiles of various fields from the cloud-model grid to the large-
!    scale model grid. also, if desired, the sub-cloud base model levels
!    of the lo-res profiles may be modified so that the column integral 
!    equals a prescribed value (set_value), and / or a given value may
!    be assigned to the sub-cloud base levels.
!    this routine is called for each ensemble member individually, so 
!    that the input and output profiles are weighted by the cloud area 
!    of the ensemble member.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type

implicit none

!---------------------------------------------------------------------
integer,                            intent(in)    :: nlev_lsm,   &
                                                     nlev_hires,  &
                                                     ntr, ncc_kou, &
                                                     diag_unit
logical,                            intent(in)    :: debug_ijt
type(donner_param_type),            intent(in)    :: Param
type(donner_nml_type),              intent(in)    :: Nml
real,                               intent(in)    :: pb, ptt,  &
                                                     sfc_vapor_flux_c, &
                                                     sfc_sh_flux_c
real,    dimension(ntr),            intent(in)    :: sfc_tracer_flux_c
real,    dimension(nlev_lsm),       intent(in)    :: pfull_c
real,    dimension(nlev_lsm+1),     intent(in)    :: phalf_c
real,    dimension(nlev_hires),     intent(in)    :: cld_press, tcc,  &
                                                     dpf, &
                                                     dfr, cld_evap, qlw,&
                                                     emfhr, efchr
real,    dimension(nlev_hires,ntr), intent(in)    :: etfhr, dpftr
real,    dimension(nlev_lsm),       intent(out)   :: cell_freeze, &
                                                     evap_rate,      &
                                                     h1_liq, h1_ice, &
                                                     h1_2, q1
real,                               intent(out)   :: ci_liq_cond, &
                                                     ci_ice_cond
real,    dimension(nlev_lsm,ntr),   intent(out)   :: qtr, wetdepl
character(len=*),                   intent(out)   :: ermesg
integer,                            intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       nlev_lsm         number of levels on lo-res grid
!       nlev_hires             number of levels on hi_res grid
!       ntr              number of tracers being transported by the 
!                        donner deep convection parameterization
!       ncc_kou          number of layers in hi-res profile that are 
!                        affected by the presence of cloud
!       pb               pressure at cloud base [ Pa ]
!       ptt              pressure one model level above cloud top [ Pa ]
!       sfc_vapor_flux_c flux of water vapor from the surface into the 
!                        sub cloud layer [ kg(h2o) / (m**2 sec) ]
!       sfc_sh_flux_c    flux of sensible heat from the surface into the
!                        sub cloud layer [ W / m**2, or kg / m**3 ] 
!       sfc_tracer_flux_c  flux of tracer from the surface into the sub-
!                        cloud layer  [ kg(tracer) / (m**2 sec) ]
!       pfull_c           pressure at lo-res model full levels [ Pa ]
!       phalf_c         pressure at lo-res model half levels [ Pa ]
!       cld_press        pressure at hi-res model full levels [ Pa ]
!       dpf              condensation rate profile
!                        on hi-res grid  for the current ensemble member
!                        [ ( kg(h2o) ) / ( kg( dry air) sec ) ] 
!      dpftr            wet-deposition rate profile
!                        on hi-res grid  for the current ensemble member        ,
!                        weighted by ratio of area to area at cloud base
!                        [ ( kg(tracer) ) / ( kg( dry air) sec ) ] 
!                        index 1 at physical base of cloud
!       dfr              profile of                     moisture tendency
!                        due to freezing in the convective updraft 
!                        on hi-res grid  for the current ensemble member
!                        [ (      g(h2o) ) / ( kg(dry air) sec ) ] 
!!!!!!!!======>>>>>>>    NOTE UNITS OF g(h2o). (Verify and change.)
!       cld_evap                             profile of the potential
!                        cloud water evaporation for the curent ensemble
!                        member on th ehi-res grid. this amount of water!
!                        must be evaporated if it turns out that there is
!                        no mesoscale circulation generated in the 
!                        column.
!                        [ (      kg(h2o) ) / ( kg(dry air) sec ) ] 
!       qlw              profile of cloud water for the current ensemble
!                        member [ kg(h2o) / kg(air) ]
!       emfhr            vertical moisture flux convergence profile on 
!                        hi-res grid for the current ensemble member 
!                        [ kg(h2o) / ( kg(dry air) sec ) ]
!       efchr            vertical entropy flux convergence profile on
!                        hi-res grid for the current ensemble member 
!                        [ deg K / sec ]                        
!       etfhr            vertical tracer flux convergence profile on
!                        hi-res grid for the current ensemble member 
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!       diag_unit        unit number of column diagnostics output file
!       debug_ijt        logical indicating whether diagnostics are 
!                        requested for this column 
!
!   intent(out) variables:
!
!       cell_freeze      profile of cloud-area-weighted moisture tendency
!                        due to freezing in the convective updraft 
!                        on lo-res grid for the current ensemble member
!                        [ (      g(h2o) ) / ( kg(dry air) sec ) ] 
!!!!!!!!======>>>>>>>    NOTE UNITS OF g(h2o). (Verify and change.)
!       evap_rate        cloud-area-weighted profile of the potential
!                        cloud water evaporation for the current ensemble
!                        member on the lo-res grid. this amount of water
!                        must be evaporated if it turns out that there is
!                        no mesoscale circulation generated in the 
!                        column.
!                        [ (      kg(h2o) ) / ( kg(dry air) sec ) ] 
!       h1                                   condensation rate profile
!                        on lo-res grid for the current ensemble member
!                        [ (      kg(h2o) ) / ( kg( dry air) sec ) ] 
!       h1_2             vertical entropy flux convergence profile on
!                        lo-res grid for the current ensemble member 
!                        [ deg K / sec ]                        
!       q1               vertical moisture flux convergence profile on 
!                        lo-res grid for the current ensemble member 
!                        [ kg(h2o) / ( kg(dry air) sec ) ]
!       qtr              vertical tracer flux convergence profile on
!                        lo-res grid for the current ensemble member 
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!       wetdepl          wet-deposition rate on lo-res grid for the
!                        current ensemble member,
!                        weighted by ratio of area to area at cloud base
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!                        vertical index 1 at base of model
!       ermesg           error message produced by any kernel routines
!                        called by this subroutine 
!
!---------------------------------------------------------------------


!-----------------------------------------------------------------------
!   local variables:

      real, dimension (nlev_lsm)  ::   pi     ! inverse exner function
                                              ! used for setting column
                                              ! integral value (conserv-
                                              ! ation of theta)
      real, dimension (nlev_lsm)  ::   condensate ! liquid water profile on 
      real, dimension (nlev_lsm)  ::   conv_fact  
      real, dimension (nlev_hires) ::  dpftra
      real, dimension (nlev_hires) ::  dpf_warm, dpf_cold
      real, dimension (nlev_lsm)  ::   wetdepa
      integer                 ::   kcont, k,n ! do-loop indices
      real                    ::   sbl        ! value to be used for
                                              ! the profile at levels
                                              ! below cloud base
      real                    ::   set_value  ! desired column integral
                                              ! value 
      real  :: aak, dp

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      conv_fact = 0.0
      dpf_cold = 0.
      dpf_warm = 0.

!--------------------------------------------------------------------
!    call don_d_convert_profile_k to map the tracer tendency due
!    to wet deposition from the cloud-model grid (dpftr) to the
!    large-scale model grid (wetdep) 
!--------------------------------------------------------------------
      do n=1,ntr
        dpftra(:) = dpftr(:,n)
        call don_d_convert_profile_k  &
             ('dpftra', 'wetdepa', nlev_lsm, nlev_hires, ncc_kou,   &
              dpftra(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt,   &
              .false., .false., .false., 0.0, 0.0, conv_fact,   &
              phalf_c, diag_unit, debug_ijt, wetdepa, ermesg, error)
        wetdepl(:,n) = wetdepa(:)
      end do

!--------------------------------------------------------------------
!    call don_d_convert_profile_k to map the moisture tendency due
!    to freezing from the cloud model grid (dfr) to the large-scale model
!    grid (cell_freeze).
!--------------------------------------------------------------------
      call don_d_convert_profile_k   &
           ('DFR', 'frea', nlev_lsm, nlev_hires, ncc_kou,   &
            dfr(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt,   &
            .false., .false., .false., 0.0, 0.0, conv_fact,   &
            phalf_c, diag_unit, debug_ijt, cell_freeze, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    map the cloud condensate (qlw) from the cloud model to the large-
!    scale model (condensate). this field is only used for diagnostic 
!    purposes.
!----------------------------------------------------------------------
      if (debug_ijt) then
        call don_d_convert_profile_k    &
             ('QLW', 'evap', nlev_lsm, nlev_hires, ncc_kou,   &
              qlw(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt, & 
              .false., .false., .false., 0.0, 0.0, conv_fact,&
              phalf_c, diag_unit, debug_ijt, condensate, ermesg, error)
      endif
      
!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    map the rate at which condensate which has not precipitated out
!    must evaporate from the cloud model grid (cld_evap) to the lo-res
!    model grid (evap_rate).
!---------------------------------------------------------------------
      call don_d_convert_profile_k    &
           ('QLW', 'evap_rate', nlev_lsm, nlev_hires, ncc_kou,   &
            cld_evap(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt, &
            .false., .false., .false., 0.0, 0.0, conv_fact,&
            phalf_c,   diag_unit,  debug_ijt, evap_rate, ermesg, error)

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    if in diagnostics column, output profiles of the cloud evaporation
!    rate (cld_evap) and evaporation(qlw) on the hi-res model grid. 
!    cld_evap will be the actual evaporation rate if there turns out to 
!    be  no mesoscale circulation in the column, while qlw is the profile
!    of liquid water produced by the given ensemble member.
!----------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a)') 'in mulsub: P & CLD_EVAP'
        do k=1,ncc_kou-1
            write (diag_unit, '(a, i4, 2e20.12)')  &
                 'in mulsub: k, P & QLW', k, cld_press(k), cld_evap (k)
        end do
        write (diag_unit, '(a)') 'in mulsub: P & QLW'
        do k=1,ncc_kou-1
            write (diag_unit, '(a, i4, 2e20.12)')  &
                 'in mulsub: k, P & QLW', k, cld_press(k), qlw      (k)
        end do
      endif
      
      do k=1, nlev_hires
        if (tcc(k) > Param%tfre) then
          dpf_warm(k) = dpf(k)
        else
          dpf_cold(k) = dpf(k)
        endif
      end do

!----------------------------------------------------------------------
!    map the condensation rate from the cloud model (-dpf) to the 
!    large-scale model (h1). h1 is a term appropriate for use in the
!    water vapor equation; i.e., condensation is a loss term.
!----------------------------------------------------------------------
      call don_d_convert_profile_k                 &
           ('RLHR_warm', 'h1_liq', nlev_lsm, nlev_hires, ncc_kou,    &
            -dpf_warm(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt,  &
            .false., .false., .false., 0.0, 0.0, conv_fact,&
            phalf_c, diag_unit, debug_ijt, h1_liq, ermesg, error)

      if (debug_ijt) then
          dp = cld_press(1) - cld_press(2)
        aak = -dpf_warm(1)*0.5*dp
        do k=2,ncc_kou 
          dp = cld_press(k) - cld_press(k+1)
          aak = aak - dpf_warm(k)*dp
        end do
        aak = aak/(Param%grav*1000.)
            write (diag_unit, '(a, e20.12, i6)')  &
                                 'in mulsub: dpf_warm intg, ncc_kou',  &
                                           aak, ncc_kou
      endif

        ci_liq_cond = 0.
        do k=1,nlev_lsm
          dp = phalf_c(k) - phalf_c(k+1)
          ci_liq_cond = ci_liq_cond + h1_liq(k)*dp
        end do
        ci_liq_cond = ci_liq_cond/(Param%grav      )
      if (debug_ijt) then
            write (diag_unit, '(a, e20.12)')  &
                                 'in mulsub: h1_liq intg', ci_liq_cond
      endif

!----------------------------------------------------------------------
!    map the condensation rate from the cloud model (-dpf) to the 
!    large-scale model (h1). h1 is a term appropriate for use in the
!    water vapor equation; i.e., condensation is a loss term.
!----------------------------------------------------------------------
      call don_d_convert_profile_k                 &
           ('RLHR_cold', 'h1_ice', nlev_lsm, nlev_hires, ncc_kou,    &
            -dpf_cold(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt,  &
            .false., .false., .false., 0.0, 0.0, conv_fact,&
            phalf_c, diag_unit, debug_ijt, h1_ice, ermesg, error)

      if (debug_ijt) then
          dp = cld_press(1) - cld_press(2)
        aak = -dpf_cold(1)*0.5*dp
        do k=2,ncc_kou 
          dp = cld_press(k) - cld_press(k+1)
          aak = aak - dpf_cold(k)*dp
        end do
        aak = aak/(Param%grav*1000.)
            write (diag_unit, '(a, e20.12, i6)')  &
                                 'in mulsub: dpf_cold intg, ncc_kou',  &
                                           aak, ncc_kou
      endif
        ci_ice_cond = 0.
        do k=1,nlev_lsm
          dp = phalf_c(k) - phalf_c(k+1)
          ci_ice_cond = ci_ice_cond + h1_ice(k)*dp
        end do
        ci_ice_cond = ci_ice_cond/(Param%grav      )
      if (debug_ijt) then
            write (diag_unit, '(a, e20.12)')  &
                                 'in mulsub: h1_ice intg', ci_ice_cond
      endif

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    determine the vertical flux convergence of each tracer.
!---------------------------------------------------------------------
      do kcont=1,ntr  

!----------------------------------------------------------------------
!    calculate the imposed subcloud tracer-flux convergence (sbl) in 
!    units of kg(tracer) per kg(dry air) per sec. define set_value so
!    that the column integrated tracer flux convergence will be set to
!    zero.
!----------------------------------------------------------------------
        sbl = (sfc_tracer_flux_c(kcont)*Param%grav)/(phalf_c(1) - pb)
        set_value = 0.0

!----------------------------------------------------------------------
!    call convert_profile to map the vertical tracer flux convergence 
!    from the cloud model (etfhr) to the large-scale model grid (qtr). 
!    force the column integral of the flux convergence to be 0.0; then 
!    add the imposed sub-cloud convergence.
!----------------------------------------------------------------------
        call don_d_convert_profile_k     &
             ('qtrv', 'qtr', nlev_lsm, nlev_hires, ncc_kou,    &
              etfhr(1:ncc_kou+1,kcont), cld_press(1:ncc_kou+1), ptt,   & 
              .true., .true., .false., set_value, sbl, conv_fact, &
              phalf_c, diag_unit, debug_ijt, qtr(:,kcont),ermesg, error)
      end do

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    define the subcloud moisture flux convergence (sbl) in units of
!    kg(h2o) per kg(air) per sec. sfc_vapor_flux_c is the imposed bound-
!    ary layer moisture source in units of kg(h2o) per m**2 per sec. 
!----------------------------------------------------------------------
      sbl = (sfc_vapor_flux_c*Param%grav)/(phalf_c(1) - pb)
      set_value = 0.0

!----------------------------------------------------------------------
!    call don_d_convert_profile_k to map the vertical moisture 
!    flux convergence from the cloud model (emfhr) to the lo-res model 
!    grid (q1). force the column integral of the flux convergence to be 
!    0.0; then add the imposed sub-cloud convergence.
!----------------------------------------------------------------------
      call don_d_convert_profile_k       &
           ('EMFHR', 'q1', nlev_lsm, nlev_hires, ncc_kou,    &
            emfhr(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt,   &
            .true., .true., .false., set_value, sbl, conv_fact, &
            phalf_c, diag_unit,  debug_ijt, q1, ermesg, error)
      if (debug_ijt) then
        aak = 0.
        do k=1,nlev_lsm
          dp = phalf_c(k) - phalf_c(k+1)
          aak = aak + q1(k)*dp
        end do
        aak = aak/(Param%grav*1000.)
            write (diag_unit, '(a, e20.12)')  &
                                 'in mulsub: q1 intg', aak
      endif
        

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    calculate the subcloud entropy flux convergence (sbl) in units of
!    deg K per sec. sfc_sh_flux_c is the imposed boundary layer sensible
!    heat source in units of watts per square meter. define the inverse
!    exner function so that an integral constraint on theta may be
!    applied.
!----------------------------------------------------------------------
      sbl = Param%grav*sfc_sh_flux_c/((phalf_c(1) - pb)*Param%cp_air)
      set_value = 0.0
      do k=1,nlev_lsm               
        pi(k) = (1.0e05/pfull_c(k))**Param%kappa
      end do

!----------------------------------------------------------------------
!    map the temperature change due to vertical entropy flux convergence
!    from the cloud model (efchr) to the large-scale model grid (h1_2). 
!    force the column integral of the temperature change to be 0.0, thus
!    conserving enthalpy; then add any imposed sub-cloud convergence.
!----------------------------------------------------------------------
   if (Nml%frc_internal_enthalpy_conserv) then
      call don_d_convert_profile_k       &
           ('EFCHR', 'h1_2', nlev_lsm, nlev_hires, ncc_kou,   &
            efchr(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt, &
            .true., .true., .false., set_value, sbl, conv_fact, &
            phalf_c, diag_unit,  debug_ijt, h1_2, ermesg, error)
   else

!----------------------------------------------------------------------
!    map the temperature change due to vertical entropy flux convergence
!    from the cloud model (efchr) to the large-scale model grid (h1_2). 
!    force the column integral of the flux convergence times inverse 
!    exner function (i.e., theta) to be 0.0, thus conserving entropy;
!    then add any imposed sub-cloud convergence.
!----------------------------------------------------------------------

      call don_d_convert_profile_k       &
           ('EFCHR', 'h1_2', nlev_lsm, nlev_hires, ncc_kou,   &
            efchr(1:ncc_kou+1), cld_press(1:ncc_kou+1), ptt, &
            .true., .true., .true., set_value, sbl, pi, &
            phalf_c, diag_unit,  debug_ijt, h1_2, ermesg, error)
   endif

!---------------------------------------------------------------------
!    determine if an error message was returned from the kernel
!    routines. if so, return to calling routine.
!---------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    if in diagnostics column, output the profile of the entropy flux
!    convergence on the lo-res grid, at levels where it is non-zero.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (debug_ijt) then
          if (h1_2(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)')  &
                                 'in mulsub: JK,H1= ', k, h1_2(k)
          endif
        endif
      end do

!----------------------------------------------------------------------



end subroutine don_d_def_lores_model_profs_k


!#####################################################################

subroutine don_d_add_to_ensmbl_sum_hires_k     &
         (nlev_hires, ntr, ncc_kou, diag_unit, debug_ijt, area_ratio,  &
          cfracice, rcl, flux, emfhr, dpf, qlw, etfhr, cuql, cuqli, &
          ucemh, alp, rlsm, emsm, detmfh, etsm, ermesg, error)

!-----------------------------------------------------------------------
!    subroutine don_d_add_to_ensmbl_sum_hires_k adds the contrib-
!    utions from this ensemble member to various profiles on the hi-res
!    grid that are being summed over the ensemble.
!-----------------------------------------------------------------------

implicit none

!-----------------------------------------------------------------------
integer,                         intent(in   )  :: nlev_hires, ntr, ncc_kou,&
                                                   diag_unit
logical,                         intent(in   )  :: debug_ijt
real,                            intent(in   )  :: area_ratio
real, dimension(nlev_hires),     intent(in   )  :: cfracice, rcl, flux, &
                                                   emfhr, dpf, qlw     
real, dimension(nlev_hires,ntr), intent(in   )  :: etfhr
real, dimension(nlev_hires),     intent(inout)  :: cuql, cuqli, ucemh, &
                                                   alp, rlsm, emsm,  &
                                                   detmfh
real, dimension(nlev_hires,ntr), intent(inout)  :: etsm         
character(len=*),                intent(  out)  :: ermesg
integer,                         intent(  out)  :: error
!---------------------------------------------------------------------
!   intent(in) variables:
!
!      nlev_hires            number of levels on hi_res grid
!      ntr             number of tracers being transported by the 
!                      donner deep convection parameterization
!      ncc_kou         number of layers in hi-res profile that are 
!                      affected by the presence of cloud
!      area_ratio      ratio of cloud base area of this ensemble member
!                      to that of ensemble member # 1. (ensemble member
!                      # 1 assumed to have largest cloud base area)
!                      [ dimensionless ]
!      cfracice        fraction of condensate that is ice [ fraction ]
!      rcl             profile of cloud radius for this ensemble member
!                      [ m ]
!      flux            upward mass flux profile in cloud for this
!                      ensemble member [ kg (air) / sec ]
!      emfhr           vertical moisture flux convergence for this
!                      ensemble member [ kg (h2o) / ( kg(dry air) sec ) ]
!      dpf             condensation rate profile on hi-res grid for the 
!                      current ensemble member
!                      [ kg(h2o) / ( kg( dry air) sec ) ] 
!      qlw             profile of cloud water for the current ensemble
!                      member [ kg(h2o) / kg(air) ]
!      etfhr           vertical tracer flux convergence profile on
!                      hi-res grid for the current ensemble member 
!                      [ kg(tracer) / ( kg(dry air) sec ) ]
!      debug_ijt       logical indicating whether diagnostics are 
!                      requested for this column 
!      diag_unit       unit number of column diagnostics output file
!
!   intent(inout) variables:
!
!      cuql            vertical profile on the hi-res grid of condensed 
!                      ice, summed over ensemble members # 1 to the cur-
!                      rent, each member's contribution being weighted by
!                      its cloud area at level k relative to the cloud 
!                      base area of ensemble member #1
!                      [ kg(h2o) / kg (dry air) ]
!      cuqli           vertical profile on the hi-res grid of condensed 
!                      liquid, summed over ensemble members # 1 to the 
!                      current, each member's contribution being weighted
!                      by its cloud area at level k relative to the cloud
!                      base area of ensemble member #1
!                      [ kg(h2o) / kg (dry air) ]
!      ucemh           vertical profile on the hi-res grid of cell upward
!                      mass flux, summed over ensemble members # 1 to the
!                      current, each member's contribution being weighted
!                      by its cloud area at level k relative to the cloud
!                      base area of ensemble member #1
!                      [ kg (dry air) / ( m**2 sec ) ]
!      alp             vertical profile on the hi-res grid of cloud area
!                      summed over ensemble members # 1 to the current, 
!                      each member's contribution being weighted
!                      by its cloud area at level k relative to the cloud
!                      base area of ensemble member #1
!                      as a result, the cloud area profile is expressed
!                      relative to the cloud base area of ensemble member
!                      # 1. [ dimensionless ]
!      rlsm            vertical profile on the hi-res grid of conden-
!                      sation rate, summed over ensemble members # 1 to
!                      the current, each member's contribution being 
!                      weighted by its cloud area at level k relative to 
!                      the cloud base area of ensemble member #1
!                      [ ( kg(h2o) ) / ( kg( dry air) sec ) ] 
!      emsm            vertical profile on the hi-res grid of vertical
!                      moisture flux convergence, summed over ensemble 
!                      members # 1 to the current, each member's contrib-
!                      ution being weighted by its cloud area at level k
!                      relative to the cloud base area of ensemble 
!                      member #1  [ kg (h2o) / ( kg(dry air) sec ) ]
!      detmfh          vertical profile on the hi-res grid of detrained
!                      mass flux in the layer above indexed level, summed
!                      over ensemble members # 1 to the current, each 
!                      member's contribution being weighted by its cloud 
!                      area at level k relative to the cloud base area of
!                      ensemble member #1 [ kg (dry air) / ( m**2 sec ) ]
!      etsm            vertical profile on the hi-res grid of vertical
!                      tracer flux convergence, summed over ensemble 
!                      members # 1 to the current, each member's contrib-
!                      ution being weighted by its cloud area at level k
!                      relative to the cloud base area of ensemble 
!                      member #1  [ kg (tracer) / ( kg(dry air) sec ) ]
!
!   intent(out) variables:
!
!      ermesg          error message produced by this subroutine or any
!                      kernel routines called by this subroutine 
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real       :: wt_factor   ! cloud area at level k for current 
                                ! ensemble member, relative to cloud
                                ! base area of ensemble member # 1
     integer     :: k, ktr      ! do-loop indices     

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!--------------------------------------------------------------------
!    add the contributions from this ensemble member to the arrays 
!    accumulating ensemble sums on the cloud model levels.
!--------------------------------------------------------------------
      do k=1,ncc_kou 

!----------------------------------------------------------------------
!    define the factor needed to normalize each ensemble member's con-
!    tribution by the cloud base area of ensemble member #1. wt_factor
!    is the cloud area at level k for ensemble member kou, relative to
!    the cloud area at cloud base (k=1) for ensemble member #1.
!-----------------------------------------------------------------------
        wt_factor = area_ratio*(rcl(k)/rcl(1))**2
        
!----------------------------------------------------------------------
!    add this ensemble member's appropriately weighted contribution to
!    the ensemble-total cloud area (alp), condensed ice (cuql), condensed
!    liquid (cuqli), cell upward mass flux (ucemh), cell detrained mass 
!    flux (detmfh), condensation rate (rlsm), vertical moisture flux 
!    convergence (emsm) and vertical tracer flux convergence (etsm). the
!    weighting factor area_ratio*(rcl(k)/rcl(1))**2 allows the contrib-
!    utions from each member to be added by normalizing each member's 
!    contribution by the cloud base area of ensemble member #1.
!    NOTE: several of the arrays already have some of the normalizing
!    factors already included and so here need only to be multiplied by 
!    a portion of wt_factor.
!----------------------------------------------------------------------
        alp(k)   = alp(k)   + wt_factor                      
        cuql(k)  = cuql(k)  + wt_factor*(cfracice(k)*qlw(k))
        cuqli(k) = cuqli(k) + wt_factor*((1.0 - cfracice(k))*qlw(k))
        ucemh(k) = ucemh(k) + area_ratio*flux(k)/(rcl(1)**2)
        if (k < ncc_kou) then
          if (flux(k+1) < flux(k)) then
            detmfh(k) = detmfh(k) + area_ratio*   &
                        ((flux(k)-flux(k+1))/(rcl(1)**2))
          endif
        endif
        rlsm(k)   = rlsm(k)   - area_ratio*dpf (k) 
        emsm(k)   = emsm(k)   + area_ratio*emfhr(k)

!----------------------------------------------------------------------
!    if in a diagnostics column, output the total cell upward mass flux 
!    (ucemh) and the cloud area at each level ( alp).
!----------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                    'in mulsub: k,ucemh, alp= ',k,ucemh(k), alp(k)
        endif
      end do

!----------------------------------------------------------------------
!    add this ensemble member's appropriately weighted contribution to
!    the vertical tracer flux convergence (etsm). the weighting factor 
!    area_ratio allows the contributions from each member to be added by
!    normalizing each member's contribution by the cloud base area of 
!    ensemble member #1.
!----------------------------------------------------------------------
      do ktr=1,ntr
        do k=1,ncc_kou 
          etsm(k,ktr) = etsm(k,ktr) + area_ratio*etfhr(k,ktr)
        end do
      end do
      
!---------------------------------------------------------------------


end subroutine don_d_add_to_ensmbl_sum_hires_k   
 



!#####################################################################

subroutine don_d_add_to_ensmbl_sum_lores_k      &
         (nlev_lsm, ntr, diag_unit, debug_ijt, lmeso, &
                          frz_frac, Param, Nml,   &
          area_ratio, dint, cell_freeze,         cell_melt, wetdepl, &
          temp_c, h1_2, ecd, ecd_liq, ecd_ice, &
          ece, ece_liq, ece_ice, evap_rate, q1,     h1_liq, h1_ice, &
          pfull_c, meso_melt, meso_freeze, &
          phalf_c, qtr, ensmbl_melt, ensmbl_melt_meso, ensmbl_freeze,&
          ensmbl_freeze_meso, ensmbl_wetc,  &
          meso_frac, precip_frac, frz_frac_non_precip, disz, &
          disz_remelt, disp_melted, disze1, disze2, disze3,  &
          disp_liq, disp_ice, enctf, encmf, enev, disg_liq, disg_ice, &
          disb, disc_liq, disc_ice, dism_liq, dism_liq_frz, &
          dism_liq_remelt, dism_ice, dism_ice_melted, &
          ecds_liq, ecds_ice, eces_liq, eces_ice, disd, &
          disv, qtren, ermesg, error, meso_frz_intg, melting_in_cloud, &
          precip_melt_frac, meso_frz_frac)

!-----------------------------------------------------------------------
!    subroutine don_d_add_to_ensmbl_sum_lores_k adds the contrib-
!    utions from this ensemble member to various profiles on the lo-res
!    grid that are being summed over the ensemble.
!-----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type

implicit none

!-----------------------------------------------------------------------
integer,                       intent(in   ) :: nlev_lsm, ntr, diag_unit
logical,                       intent(in   ) :: debug_ijt, lmeso
real,                          intent(in)   :: frz_frac
type(donner_param_type),       intent(in)    :: Param
type(donner_nml_type),       intent(in)    :: Nml  
real,                          intent(in   ) :: area_ratio, dint
real, dimension(nlev_lsm),     intent(in   ) :: cell_freeze, cell_melt, &
                                                temp_c, h1_2, ecd, ece, &
                                            ecd_liq, ecd_ice, ece_liq,&
                                              ece_ice, &
                                                evap_rate, q1,     &
                                                h1_liq, h1_ice, &
                                                pfull_c, meso_melt,   &
                                                meso_freeze
real, dimension(nlev_lsm+1),   intent(in   ) :: phalf_c  
real, dimension(nlev_lsm,ntr), intent(in   ) :: qtr, wetdepl
real,                          intent(in)    :: meso_frac, precip_frac
real,        intent(inout) ::                    frz_frac_non_precip
real, dimension(nlev_lsm),     intent(inout) :: ensmbl_melt,   &
                                                ensmbl_melt_meso, &
                                                ensmbl_freeze, enctf, &
                                                ensmbl_freeze_meso, &
                                                encmf, enev,       &
                                                disz_remelt, &
                                                disz,               &
                                                 disze1, disze2, &
                                                disze3,   &
                                                disg_liq, disg_ice, &
                                               disb,                   &
                                                ecds_liq, ecds_ice, &
                                                eces_liq, eces_ice, &
                                                disc_liq, disc_ice, &
                                                dism_liq, dism_ice, &
                                                dism_ice_melted, &
                                                dism_liq_frz, &
                                                dism_liq_remelt, &
                                                disp_liq, disp_ice, &
                                                disp_melted, &
                                                disd, disv
real, dimension(nlev_lsm,ntr), intent(inout) :: qtren, ensmbl_wetc
character(len=*),              intent(  out) :: ermesg
integer,                       intent(  out) :: error
logical,                       intent( in)   :: meso_frz_intg   
real,                          intent( in)   ::                &
                                                 meso_frz_frac
logical, intent(in) :: melting_in_cloud
real   , intent(in) ::            precip_melt_frac          

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     
!       nlev_lsm         number of levels on lo-res grid
!       ntr              number of tracers being transported by the 
!                        donner deep convection parameterization
!       area_ratio       ratio of cloud base area of this ensemble 
!                        member to that of ensemble member # 1. 
!                        (ensemble member # 1 assumed to have largest 
!                        cloud base area) [ dimensionless ]
!       dint             column sum of moisture tendency due to freezing
!                        in the convective updraft on hi-res grid for the
!                        current ensemble member
!!!!  CHECK ON THESE UNITS !!!!!
!                        [ (      g(h2o) ) / ( kg(dry air) sec ) ] 
!       cell_freeze      profile of cloud-area-weighted moisture tendency
!                        due to freezing in the convective updraft 
!                        on lo-res grid for the current ensemble member
!                        [ (      g(h2o) ) / ( kg(dry air) sec ) ] 
!!!!!!!!======>>>>>>>    NOTE UNITS OF g(h2o). (Verify and change.)
!       cell_melt        in-cloud melting of condensate associated with
!                        convective cells. made up of two parts, 1) that
!                        due to the freezing of liquid carried upwards
!                        in the cell updraft, 2) that due to the melting 
!                        of condensed ice that precipitates out. if meso
!                        circulation is present, this component is zero;
!                        melting will be determined in subroutine mesub.
!                        [ (      g(h2o) ) / ( kg(dry air) day ) ] 
!!   CHECK UNITS HERE !!!!
!!!!!!!!======>>>>>>>    NOTE UNITS OF g(h2o). (Verify and change.)
!       temp_c           temperature at model levels [ deg K ]
!       h1_2             vertical entropy flux convergence profile on
!                        lo-res grid for the current ensemble member 
!                        [ deg K / sec ]                        
!       ecd              profile of condensate evaporated in convective
!                        downdraft on large-scale model grid
!                        [ g(h2o) / kg(air) / day ]
!       ece              profile of condensate evaporated in convective
!                        updraft on large-scale model grid
!                        [ g(h2o) / kg(air) / day ]
!       evap_rate        cloud-area-weighted profile of the potential
!                        cloud water evaporation for the current ensemble
!                        member on the lo-res grid. this amount of water
!                        must be evaporated if it turns out that there is
!                        no mesoscale circulation generated in the 
!                        column.
!                        [ (      kg(h2o) ) / ( kg(dry air) sec ) ] 
!       phalf_c          pressure at lo-res model interface levels [ Pa ]
!       q1               vertical moisture flux convergence profile on 
!                        lo-res grid for the current ensemble member 
!                        [ kg(h2o) / ( kg(dry air) sec ) ]
!       h1                                   condensation rate profile
!                        on lo-res grid for the current ensemble member
!                        [ (      kg(h2o) ) / ( kg( dry air) sec ) ] 
!       pfull_c          pressure on lo-res model full levels [ Pa ]
!       meso_melt        profile of condensate which is melted in meso-
!                        scale downdraft on large-scale model grid
!                        [ g(h2o) / kg(air) / day ]
!       meso_freeze      profile of condensate which is frozen upon 
!                        entering the anvil on the large-scale grid
!                        [ g(h2o) / kg(air) / day ]
!       qtr              vertical tracer flux convergence profile on
!                        lo-res grid for the current ensemble member 
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!       lmeso            a mesoscale circulation exists in the current
!                        grid box ?
!       wetdepl          wet deposition for current ensemble member,
!                        weighted by ratio of area to area at cloud base
!                        [ kg(tracer)/ ( kg sec) ]
!                        vertical index 1 at base of model
!       debug_ijt        logical indicating whether diagnostics are 
!                        requested for this column 
!       diag_unit        unit number of column diagnostics output file
!
!   intent(inout) variables:
!
!       ensmbl_melt      vertical profile on the lo-res grid of ice melt,
!                        both from the cells and any mesoscale circul-
!                        ation, summed over ensemble members # 1 to the 
!                        current, each member's contribution being 
!                        weighted by its cloud area at level k relative !
!                        to the cloud base area of ensemble member #1
!                        [ kg(h2o) / kg (dry air) ]
!       ensmbl_freeze    vertical profile on the lo-res grid of freezing,
!                        both from the cells and any mesoscale circul-
!                        ation, summed over ensemble members # 1 to the 
!                        current, each member's contribution being 
!                        weighted by its cloud area at level k relative !
!                        to the cloud base area of ensemble member #1
!                        [ kg(h2o) / kg (dry air) ]
!       ensmbl_wetc      vertical profile on the lo-res grid of wet
!                        deposition from cells, summed over ensemble
!                        members #1 to current, each members contributio        n
!                        weighted by the ratio of its area 
!                        to the area of ensemble member #1 at cloud base
!                        [ kg(tracer) / kg s ]
!                        vertical index 1 at model base
!       enctf            vertical profile on the lo-res grid of the entr-
!                        opy forcing, consisting of the sum of the
!                        vertical entropy flux convergence and the latent
!                        heat release, summed over 
!                        ensemble members # 1 to the current, each mem-
!                        ber's contribution being weighted by its cloud 
!                        area at level k relative to the cloud base area
!                        of ensemble member #1
!                        [ deg K / day ]                        
!       encmf            vertical profile on the lo-res grid of the      
!                        moisture forcing, consisting of the sum of the
!                        vertical moisture flux convergence and the cond-
!                        ensation, summed over ensemble members # 1 to 
!                        the current, each member's contribution being 
!                        weighted by its cloud area at level k relative 
!                        to the cloud base area of ensemble member #1
!                        [ (      kg(h2o) ) / ( kg( dry air) day ) ] 
!       enev             vertical profile on the lo-res grid of the      
!                        cloud-area-weighted profile of the potential
!                        cloud water evaporation, summed over ensemble 
!                        members # 1 to the current, each member's con-
!                        tribution being weighted by its cloud area at !
!                        level k relative to the cloud base area of 
!                        ensemble member #1.  this amount of water
!                        must be evaporated if it turns out that there is
!                        no mesoscale circulation generated in the 
!                        column.
!                        [ (      kg(h2o) ) / ( kg(dry air) sec ) ] 
!       disg             vertical profile on the lo-res grid of the      
!                        latent heat term in the temperature equation
!                        associated with the evaporation of condensate
!                        in the convective downdraft and updraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ deg K / day ] 
!       disb             vertical profile on the lo-res grid of the      
!                        temperature flux convergence, summed over 
!                        ensemble members # 1 to the current, each mem-
!                        ber's contribution being weighted by its cloud 
!                        area at level k relative to the cloud base area 
!                        of ensemble member #1.  
!                        [ deg K / day ] 
!       disc             vertical profile on the lo-res grid of the      
!                        latent heat term in the temperature equation, 
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ deg K / day ] 
!       ecds             vertical profile on the lo-res grid of the      
!                        condensate evaporated in convective downdraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ g(h2o) / kg(air) / day ]
!       eces             vertical profile on the lo-res grid of the      
!                        condensate evaporated in convective updraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ g(h2o) / kg(air) / day ]
!       disd             vertical profile on the lo-res grid of the      
!                        vertical moisture flux convergence,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        lo-res grid for the current ensemble member 
!                        [  g(h2o) / ( kg(dry air) day ) ]
!       qtren            vertical profile on the lo-res grid of the      
!                        vertical tracer flux convergence,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!
!    intent(out) variables:
!
!       ermesg           error message produced by any kernel routines
!                        called by this subroutine 
!
!---------------------------------------------------------------------- 

!--------------------------------------------------------------------
!   local variables:


      real, dimension (nlev_lsm) :: rlh  
                                     !  condensation term in temperature
                                     !  equation on lo-res grid for cur-
                                     !  rent ensemble member 
                                     !  [ deg K / day ]
      real, dimension (nlev_lsm) :: cmf 
                                     !  forcing term for moisture 
                                     !  equation on lo-res grid for
                                     !  current ensemble member; sum 
                                     !  of vertical flux convergence 
                                     !  and condensation terms 
                                     !  [ g(h2o) / ( kg(air) day ) ]

     real     :: convrat   !  latent heat factor, appropriate for the 
                           !  temperature at a given model level 
                           !  ( = L / cp ) [ deg K ]
     real     :: qtrsum    !  sum of tracer flux convergence over all 
                           !  tracers and all levels and all ensemble 
                           !  members up to the current. used as a diag-
                           !  nostic; sum should be 0.0, if no boundary 
                           !  source term.
                           !  [ kg(tracer) / ( kg(dry air) sec ) ]
     integer  :: k, kcont  !  do-loop indices

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!--------------------------------------------------------------------
!    sum up various cloud-base-area weighted contributions to vertical
!    profiles on the large-scale grid that are being summed over the 
!    ensemble.
!--------------------------------------------------------------------
      do k=1,nlev_lsm       

!---------------------------------------------------------------------
!    define the moisture forcing term (sum of condensation h1 and 
!    vertical flux convergence q1) on the large-scale grid. convert to
!    units of g(h20) per kg(air) per day, requiring multiplication by
!    1.0e3 g(h2o) /kg(h2o) times SECONDS_PER_DAY. add this member's 
!    contribution to the sum over the ensemble (encmf). 
!----------------------------------------------------------------------
        cmf(k) = (-(h1_liq(k) + h1_ice(k)) + q1(k))*  &
                                     (Param%SECONDS_PER_DAY*1.0e03)
        encmf(k) = encmf(k) + area_ratio*cmf(k)

!----------------------------------------------------------------------
!   define the cell precipitation forms.
!   disz : frozen liquid condensate
!   disz_remelt: frozen liquid condensate which then melts
!   disp_liq: liquid condensate
!   disp_ice: frozen condensate
!   disp_melted: frozen condensate which melts
!----------------------------------------------------------------------
        if (.not. melting_in_cloud) then
          disz(k) = disz(k) + area_ratio*h1_liq(k)* &
                    Param%seconds_per_day*     frz_frac*precip_frac
        else  ! (not melting in cloud)
          disz_remelt(k) = disz_remelt(k) + area_ratio*h1_liq(k)*  &
                           Param%seconds_per_day*frz_frac*precip_frac
        endif  ! (not melting in cloud)

        disp_liq(k) = disp_liq(k) + area_ratio*h1_liq(k)*   &
                      Param%seconds_per_day*(1.0-frz_frac)* &
                      precip_frac              
        disp_ice(k) = disp_ice(k) + area_ratio*h1_ice(k)*  &
                      Param%seconds_per_day*           &
                      (1.0-precip_melt_frac)*precip_frac
        disp_melted(k) = disp_melted(k) + area_ratio*h1_ice(k)*  &
                         Param%seconds_per_day*           &
                         (precip_melt_frac)*precip_frac

!---------------------------------------------------------------------
!    define the heating rate due to liquid and ice condensation.
!---------------------------------------------------------------------
        disc_liq(k) = disc_liq(k) + area_ratio*h1_liq(k)* &
                      Param%seconds_per_day*Param%hlv/Param%cp_air
        disc_ice(k) = disc_ice(k) + area_ratio*h1_ice(k)* &
                      Param%seconds_per_day*Param%hls/Param%cp_air

!---------------------------------------------------------------------
!    define the  heating rates associated with the evaporation of
!    non-precipitating condensate. these terms are used when a meso-
!    scale circulation is not present; the _chgd variables are used
!    when the mesoscale circulation is present for the initial ensemble
!    member, but is not sustainable by one of the remaining members.
!---------------------------------------------------------------------
        disze1(k) = disze1(k) + area_ratio*h1_liq(k)*  &
                    Param%seconds_per_day*Param%hls*  &
                    frz_frac           *(1.-precip_frac)/Param%cp_air
        disze2(k) = disze2(k) + area_ratio*h1_liq(k)*  &
                    Param%seconds_per_day*Param%hlv*  &
                 (1.0-frz_frac           )*(1.-precip_frac)/Param%cp_air
        disze3(k) = disze3(k) - area_ratio*h1_ice(k)* &
                    Param%seconds_per_day*Param%hls*   &
                    (1.-precip_frac)/Param%cp_air

!----------------------------------------------------------------------
!    define the components of precipitation from the cell condensate 
!    that was transferred to the mesoscale circulation.
!    dism_liq: precip from liquid condensate that does not freeze
!              occurs when no melting and no freezing in cloud OR 
!              is the liquid condensate which does not freeze when 
!              there is melting in the cloud
!    dism_liq_frz: precip from liquid condensate that freezes
!              occurs when there is no melting but is freezing
!    dism_ice:  precip from frozen condensate
!               occurs when there is no melting
!    dism_ice_melted: precip from frozen condensate that melts
!               occurs when there is melting
!    dism_liq_remelt: precip from liquid condensate that freezes and 
!                     then melts
!               occurs when there is both melting and freezing 
!----------------------------------------------------------------------
        if (.not. melting_in_cloud) then
          if (.not. (meso_frz_intg) .and. frz_frac_non_precip == 0.) then
            dism_liq(k) = dism_liq(k) + area_ratio*h1_liq(k)*  &
                          meso_frac*Param%seconds_per_day                          
          else
            dism_liq_frz(k) = dism_liq_frz(k) + area_ratio*h1_liq(k)* &
                          meso_frac*Param%seconds_per_day
          endif
          dism_ice(k) = dism_ice(k) + area_ratio*h1_ice(k)*  &
                        meso_frac*Param%seconds_per_day
        else   ! (not melting in cloud)
          dism_liq(k) = dism_liq(k) + area_ratio*h1_liq(k)* &
                meso_frac*(1.-frz_frac_non_precip)*Param%seconds_per_day
          dism_ice_melted(k) = dism_ice_melted(k) +  &
                                    area_ratio*h1_ice(k)*  &
                        meso_frac*Param%seconds_per_day
          dism_liq_remelt(k) = dism_liq_remelt(k) +      &
                               area_ratio*h1_liq(k)*  &
                 meso_frac*frz_frac_non_precip*Param%seconds_per_day
        endif

        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3e20.12)')  &
                              'in mulsub: precip profiles', &
                               k, disp_liq(k)*Param%hlv/Param%cp_air, &
                             Param%hls/Param%cp_air*disp_ice(k), &
                             Param%hls/Param%cp_air*disz(k)
          write (diag_unit, '(a, i4, 2e20.12)')  &
                           'in mulsub: remelt, melt precip profiles', &
                           k, Param%hlv/Param%cp_air*disz_remelt(k), &
                                  Param%hlv/Param%cp_air*disp_melted(k)
          write (diag_unit, '(a, i4, 3e20.12)')  &
                              'in mulsub: evap   profiles', &
                               k, disze1(k), disze2(k),  -disze3(k)     
          write (diag_unit, '(a, i4, 2e20.12)')  &
                              'in mulsub: cd     profiles', &
                               k, disc_liq(k), disc_ice(k)
        endif

!--------------------------------------------------------------------
!    add this member's weighted contribution to the ensemble's temper-
!    ature flux convergence (disb), the ensemble's water vapor flux 
!    convergence (disd) and the ensemble's entropy flux convergence 
!    (enctf). convert the rates to units of per day, and for disd from
!    kg(h2o) per kg(air) to g(h2o) per kg(air).
!--------------------------------------------------------------------
        disb(k) = disb(k) + area_ratio*(h1_2(k)*Param%SECONDS_PER_DAY)
        disd(k) = disd(k) + area_ratio*(q1(k)*  &
                             (Param%SECONDS_PER_DAY*1.0e3))
        disv(k) = disv(k) + area_ratio*((h1_liq(k) + h1_ice(k))* &
                             (Param%SECONDS_PER_DAY*1.0e3))
!   change enctf to reflect need for both ice and liq cd in layer of
!   tfre
        enctf(k) = enctf(k) + area_ratio*    &
                       (h1_2(k)*Param%SECONDS_PER_DAY + &
                       (h1_liq(k)*Param%hlv + h1_ice(k)*Param%hls)*  &
                           Param%seconds_per_day/ Param%cp_air )

!--------------------------------------------------------------------
!    if a mesoscale circulation exists, add this member's contribution
!    to the mesoscale condensate's evaporation associated with convect-
!    ive downdrafts (ecds) and that associated with evaporation into 
!    the environment (eces). if there has been no freezing associated
!    with the mesoscale condensate, define the condensation term for
!    the temperature equation using the latent heat of vaporization
!    (disg). if there has been freezing, then the convective downdraft 
!    heating uses the latent heat of vaporization, whereas the entrain-
!    ment evaporation is of ice and so uses the latent heat of 
!    sublimation.
!--------------------------------------------------------------------
        if (lmeso) then
          ecds_liq(k) = ecds_liq(k) + area_ratio*ecd_liq(k)
          ecds_ice(k) = ecds_ice(k) + area_ratio*ecd_ice(k)
          eces_liq(k) = eces_liq(k) + area_ratio*ece_liq(k)
          eces_ice(k) = eces_ice(k) + area_ratio*ece_ice(k)

!---------------------------------------------------------------------
!    evaporation of the frozen condensate removes hls.
!---------------------------------------------------------------------
          disg_ice(k) = disg_ice(k) - area_ratio* &
                          ((ecd_ice(k) + ece_ice(k))*  &
                                Param%hls/(Param%CP_AIR*1000.))

!---------------------------------------------------------------------
!    if there has been cell freezing and either melting or meso 
!    freezing, then the liquid condensate evaporated in the environment 
!    would have previously frozen and so removes hls. the liquid con-
!    densate evaporated in the downdraft would not have been frozen and
!    so removes hlv.
!---------------------------------------------------------------------
          if (dint /= 0. .and. &       
                (melting_in_cloud .or. meso_frz_intg)) then
            disg_liq(k) = disg_liq(k) - area_ratio*  &
                    ((ecd_liq(k)*Param%HLV + ece_liq(k)*Param%hls)/   &
                                           (Param%CP_AIR*1000.))

          else

!---------------------------------------------------------------------
!    if there has been no freezing in the cells or freezing in the 
!    cells only and no melting, then the evaporation of liquid conden-
!    sate in both environment and downdraft removes hlv.
!---------------------------------------------------------------------
            disg_liq(k) = disg_liq(k) - area_ratio*  &
                          ((ecd_liq(k) + ece_liq(k))*  &
                                Param%hlv/(Param%CP_AIR*1000.))
          endif
        endif    ! (lmeso)

!---------------------------------------------------------------------
!    add this member's cloud water evaporation rate to the sum over 
!    the ensemble (enev).
!---------------------------------------------------------------------
        enev(k) = enev(k) + area_ratio*evap_rate(k)

!--------------------------------------------------------------------
!    if a mesoscale circulation exists, add the appropriately-weighted
!    anvil freezing and melting terms to the arrays accumulating their 
!    sums over the ensemble (ensmbl_melt, ensmbl_freeze). if in a diag-
!    nostic column, output the anvil (meso_freeze) and ensemble-sum
!    (ensmbl_freeze) freezing profiles.
!--------------------------------------------------------------------
        if (lmeso) then
          ensmbl_melt_meso(k) = ensmbl_melt_meso(k) - area_ratio*  &
                           meso_melt(k)
          ensmbl_freeze_meso(k) = ensmbl_freeze_meso(k) + area_ratio* &
                                  meso_freeze(k)
          if (debug_ijt) then
            if (meso_freeze(k) /= 0.0) then
              write (diag_unit, '(a, i4, 2e20.12)')  &
                              'in mulsub: jk,fres,fre= ',   &
                               k, ensmbl_freeze_meso(k), meso_freeze(k)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    add the appropriately-weighted convective cell freezing and 
!    melting terms to the arrays accumulating vertical profiles of 
!    total cloud melting (ensmbl_melt) and freezing (ensmbl_freeze) 
!    over the entire ensemble.  if in diagnostic column, output the 
!    convective cell (cell_freeze) and accumulated (ensmbl_freeze) 
!    freezing profiles.
!--------------------------------------------------------------------
        ensmbl_freeze(k) = ensmbl_freeze(k) + area_ratio*cell_freeze(k)
        ensmbl_melt(k) = ensmbl_melt(k) - area_ratio*cell_melt(k)
        if (debug_ijt) then
          if (cell_freeze(k) /= 0.0) then
            write (diag_unit, '(a, i4, 2e20.12)')  &
                     'in mulsub: jk,fres,frea= ',    &
                                     k, ensmbl_freeze(k), cell_freeze(k)
          endif
        endif
      end do

!---------------------------------------------------------------------
!    if in a diagnostics column, initialize a variable to sum the 
!    pressure-weighted tracer flux convergence, summed over all tracers
!    and all levels, for this ensemble member. upon completion of the 
!    loop, qtrsum should be 0.0, if there are no imposed tracer sources 
!    or sinks.
!---------------------------------------------------------------------
      if (debug_ijt) then
        qtrsum = 0.
        do k=1,nlev_lsm       
          do kcont=1,ntr  
            write (diag_unit, '(a,  i4, 2e20.12)')  &
                      'in mulsub: jk,    qtr,qtren=         ', &
                              k,    qtr(k,kcont),qtren(k,kcont)
            qtrsum = qtrsum + qtr(k,kcont)*(phalf_c(k) - phalf_c(k+1))
            write (diag_unit, '(a,  i4, e20.12)')  &
                         'in mulsub: jk,    qtrsum= ', k,    qtrsum
          end do
        end do
      endif 

!--------------------------------------------------------------------
!   add this ensemble member's appropriately-weighted contributions 
!   to the tracer flux convergence profiles being summed over the 
!   ensemble. 
!--------------------------------------------------------------------
      do k=1,nlev_lsm        
        ensmbl_wetc(k,:) = ensmbl_wetc(k,:) + area_ratio*wetdepl(k,:)
        qtren(k,:) = qtren(k,:) + area_ratio*qtr(k,:)
      end do

!----------------------------------------------------------------------
!    if in diagnostics column, output the profiles of the amount of
!    cloud  water evaporated (if lmeso is true) or the cloud water evap-
!    oration rate (if lmeso is false),  the array ctf (forcing for 
!    entropy eqn) and cmf (forcing for moisture equation) for this 
!    ensemble member.
!----------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_lsm        
          if (h1_liq(k) /= 0.0  .or. h1_ice(k) /= 0.0 .or.  &
              h1_2(k) /= 0.0) then
            if (temp_c(k) >= Param%tfre) then
              convrat = Param%HLV/Param%CP_AIR
              rlh(k) = (h1_liq(k) + h1_ice(k))*Param%SECONDS_PER_DAY* &
                                                                convrat
            else
              convrat = Param%HLS/Param%CP_AIR
              rlh(k) = (h1_liq(k) + h1_ice(k))*Param%SECONDS_PER_DAY*  &
                                                                convrat
            endif
            write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                      'in mulsub: k, p & ctf', k, pfull_c(    k),  &
                                               h1_2(k)*86400. + rlh(k)
          endif
        end do
        do k=1,nlev_lsm        
          if (cmf(k) /= 0.0) then
            write (diag_unit, '(a, i4, f19.10, e20.12)') &
                       'in mulsub: k, p & cmf', k, pfull_c(k), cmf(k)
          endif
        end do
      endif

!---------------------------------------------------------------------


end subroutine don_d_add_to_ensmbl_sum_lores_k 




!#####################################################################

subroutine don_d_add_to_ensmbl_sum_intgl_k        &
         (diag_unit, debug_ijt, lmeso,  area_ratio,  ca_liq, ca_ice,&
          frz_frac_non_precip, meso_frac, cell_precip, cu, &
          apt, ensmbl_precip, ensmbl_cond,                     &  
          ensmbl_anvil_cond_liq, ensmbl_anvil_cond_liq_frz, &
          meso_frz_intg, meso_frz_frac, ensmbl_anvil_cond_ice, &
          ensmbl_cld_top_area, ermesg, error)

!----------------------------------------------------------------------
!    subroutine don_d_add_to_ensmbl_sum_intgl_k adds the contrib-
!    utions from this ensemble member to various global integrals.
!----------------------------------------------------------------------

implicit none

!----------------------------------------------------------------------
integer,          intent(in   ) :: diag_unit
logical,          intent(in   ) :: debug_ijt, lmeso
real,             intent(in   ) :: area_ratio,     ca_liq, ca_ice, &
                                   frz_frac_non_precip, meso_frac, &
                                   cell_precip, cu, apt
real,             intent(inout) :: ensmbl_precip, ensmbl_cond, &
                                   ensmbl_cld_top_area, &
                                   ensmbl_anvil_cond_liq,  &
                                   ensmbl_anvil_cond_liq_frz,  &
                                   ensmbl_anvil_cond_ice
real,             intent(in   ) :: meso_frz_frac
logical,          intent(in   ) :: meso_frz_intg               
character(len=*), intent(  out) :: ermesg
integer,          intent(  out) :: error 
!----------------------------------------------------------------------
!   intent(in) variables:
!
!      area_ratio       ratio of cloud base area of this ensemble member
!                       to that of ensemble member # 1. (ensemble member
!                       # 1 assumed to have largest cloud base area)
!                       [ dimensionless ]
!      ca               rate of transfer of condensate from cell to 
!                       anvil for this ensemble member 
!                       [ mm / day ]
!      cell_precip      precipitation rate for this ensemble member
!                       [ mm / day ]
!      cu               condensation rate for this ensemble member
!                       [ mm / day ]
!      apt              ratio of cloud top area to cloud base area
!                       for this ensemble member [ dimensionless ]
!      lmeso            logical indicating if mesoscale circulation 
!                       is present
!      debug_ijt        logical indicating whether diagnostics are 
!                       requested for this column 
!      diag_unit        unit number of column diagnostics output file
! 
!   intent(inout) variables:
!
!      ensmbl_precip    sum of precipitation rate over ensemble members,
!                       # 1 to the current, weighted by the area at 
!                       cloud base of each member
!                       [ mm / day ]
!      ensmbl_cond      sum of condensation rate over ensemble members,
!                       # 1 to the current, weighted by the area at 
!                       cloud base of each member
!                       [ mm / day ]
!      ensmbl_anvil_cond 
!                       sum of rate of transfer of condensate from cell 
!                       to anvil over ensemble members, # 1 to the c
!                       current, weighted by the area at cloud base of 
!                       each member [ mm / day ]
!      ensmbl_cld_top_area  
!                       sum of the cloud top areas over ensemble members 
!                       # 1 to the current, normalized by the cloud base
!                       area of ensemble member # 1 [ dimensionless ]
!
!   intent(out) variables:
!
!      ermesg           error message produced by this subroutine or any
!                       kernel routines called by this subroutine 
!
!---------------------------------------------------------------------

      real :: local_frz_frac

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!--------------------------------------------------------------------
!    if a mesoscale circulation is present, add this member's cloud-
!    base_area-weighted contribution of condensate transferred to the 
!    anvil (ensmbl_anvil_cond) and cloud top cloud fraction 
!    (ensmbl_cld_top_area) to the arrays accumulating the ensemble sums.
!--------------------------------------------------------------------
      if (lmeso) then
        if (meso_frac /= 0.0) then
          local_frz_frac = (frz_frac_non_precip + meso_frz_frac)/  &
                                                              meso_frac
        else
          local_frz_frac = 0.0
        endif
        ensmbl_anvil_cond_liq   = ensmbl_anvil_cond_liq   +   &
                                  area_ratio*ca_liq*(1.-local_frz_frac)
        ensmbl_anvil_cond_liq_frz   = ensmbl_anvil_cond_liq_frz   +   &
                                        area_ratio*ca_liq*local_frz_frac
        ensmbl_anvil_cond_ice   = ensmbl_anvil_cond_ice   +  &
                                                   area_ratio*ca_ice
        ensmbl_cld_top_area = ensmbl_cld_top_area + area_ratio*apt
      endif

!--------------------------------------------------------------------
!    add this ensemble member's weighted contribution to the total 
!    precipitation (ensmbl_precip) and condensation (ensmbl_cond). 
!--------------------------------------------------------------------
      ensmbl_precip = ensmbl_precip + area_ratio*cell_precip
      ensmbl_cond   = ensmbl_cond   + area_ratio*cu

!---------------------------------------------------------------------



end subroutine don_d_add_to_ensmbl_sum_intgl_k 

!#####################################################################


!######################################################################

subroutine don_d_output_diag_profs_k    &
         (nlev_lsm, diag_unit, pfull_c, disc_liq, disc_ice, disb,  &
          disd, disn, encmf, temp_tend_freeze, temp_tend_freeze_meso, &
          temp_tend_melt, cmus_tot, emds_liq, &
          emds_ice,  emes_liq, emes_ice, wmms, &
          wmps, tmes, mrmes, eces_liq, eces_ice, ecds_liq, ecds_ice, &
          disa, dise, disg_2liq, disg_2ice, disf, &
          ermesg, error)

!---------------------------------------------------------------------
!    subroutine output_diagnostic_profiles prints out vertical profiles
!    of various donner_deep variables in those columns for which 
!    diagnostics have been requested.
!---------------------------------------------------------------------

implicit none

!---------------------------------------------------------------------
integer,                      intent(in)   :: nlev_lsm, diag_unit
real,    dimension(nlev_lsm), intent(in)   :: pfull_c, disc_liq, &
                                              disc_ice, disb, disd,&
                                              disn, encmf,  &
                                              temp_tend_freeze,    &
                                              temp_tend_freeze_meso,  &
                                              temp_tend_melt, cmus_tot,&
                                                          wmms, wmps, &
                                              emds_liq, emds_ice, &
                                              emes_liq, emes_ice, &
                                              tmes, mrmes,             &
                                              ecds_liq, ecds_ice, &
                                              eces_liq, eces_ice, &
                                              disa, dise, disg_2liq,  &
                                              disg_2ice, disf 
character(len=*),              intent(out) :: ermesg
integer,                       intent(out) :: error

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     diag_unit
!     pfull_c
!     disc
!     disb
!     disd
!     disn
!     encmf
!     temp_tend_freeze
!     temp_tend_melt
!     cmus_tot
!     emds
!     emes
!     wmms
!     wmps
!     tmes
!     mrmes
!     eces
!     ecds
!     disa
!     dise
!     disg_2
!     disf
!
!----------------------------------------------------------------------

!!  UNITS
!!    ucemh  [kg /sec / m**2 ]
!!    conint [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    precip [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    q1     [ kg(h2o) / kg(air) / sec ]
!!    h1     [ kg(h2o) / kg(air) / sec ]
!!    cmf    [ g(h2o) / kg(air) /day ]
!!    rlh    [ kg(h2o) / kg(air) / day ]  * [ L / Cp ] = [ deg K / day ]
!!    efc    [ deg K / day ]
!!    efchr  [ deg K / sec ]
!!    ehfh   [ kg(air) (deg K) / (sec**3 m)
!!    ctf    [ deg K / day ]
!!    disb_v [ deg K / day ]
!!    disc_v [ deg K / day ] 
!!    disn   [ deg K / day ] 
!!    ecd    [ g(h2o) / kg(air) / day ]
!!    ece    [ g(h2o) / kg(air) / day ]
!!    ecds_v [ g(h2o) / kg(air) / day ]
!!    eces_v [ g(h2o) / kg(air) / day ]
!!    enctf  [ deg K / day ]
!!    encmf  [ g(h2o) / kg(air) /day ]
!!    pf     [ (m**2 kg(h2o)) / (kg(air) sec) ]
!!    dpf    [ (m**2 kg(h2o)) / (kg(air) sec) ] ==>   
!!                                          [ kg(h2o)) / (kg(air) sec) ]
!!    qlw2   [ kg(h2o)) / (kg(air) sec) ]
!!    qlw    [ kg(h2o)) / kg(air) ]
!!    evap   [ kg(h2o)) / kg(air) ]
!!    evap_rate [ kg(h2o)) / (kg(air) sec) ]
!!    disg   [ deg K / day ]



!-------------------------------------------------------------------
!   local variables:

      integer  ::  k      ! do-loop index
     
!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!  disc: cloud ensemble cell condensation heating rate [ deg K / day ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ( (disc_liq(k)+ disc_ice(k))  /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, 2e20.12)')  &
              'in mulsub: k, P & liq/ice =',  k, pfull_c(k),disc_liq(k), &
                                                        disc_ice(k)
        endif
      end do

!---------------------------------------------------------------------
!  disb  : cloud ensemble cell vertical entropy flux convergence 
!          [ deg K / day ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (disb(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)') &
              'in mulsub: k, P & EFC =',  k, pfull_c(k),disb(k)
        endif
      end do

!---------------------------------------------------------------------
!  disd: cloud ensemble cell vertical moisture flux convergence 
!        [ kg(h2o)/ (kg(air) sec) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (disd(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
               'in mulsub: k, P & EMF =',  k, pfull_c(k),disd(k)
        endif
      end do

!---------------------------------------------------------------------
!  disn : cloud ensemble cell thermal forcing 
!         [ deg K / sec ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (disn(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                       'in mulsub: k, P & cell thermal forcing =',    &
                        k, pfull_c(k),disn(k)
        endif
      end do

!---------------------------------------------------------------------
!  encmf : cloud ensemble cell moisture forcing 
!          [ kg(h2o) / (kg(air) sec) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (encmf(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                      'in mulsub: k, P & cell moisture forcing =',    &
                        k, pfull_c(k),encmf(k)
        endif
      end do

!---------------------------------------------------------------------
!  temp_tend_freeze  : cloud ensemble temperature tendency due to   
!                      freezing [ deg K / sec ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((temp_tend_freeze(k) +   &
                          temp_tend_freeze_meso(k))/= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)') &
                      'in mulsub: k, P & meso up freeze        =',    &
           k, pfull_c(k),temp_tend_freeze(k) + temp_tend_freeze_meso(k)
        endif
      end do

!---------------------------------------------------------------------
!  temp_tend_melt  : cloud ensemble plus mesoscale temperature 
!                    tendency due to melting [ deg K / sec ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (temp_tend_melt(k)  /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                     'in mulsub: k, P & meso down melt        =',    &
                       k, pfull_c(k),temp_tend_melt(k) 
        endif
      end do

!---------------------------------------------------------------------
!  cmus_tot : water mass condensed in mesoscale updraft
!             [ kg(h2o) / (kg(air) sec) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (cmus_tot(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)') &
                      'in mulsub: k, P & meso up con           =',    &
                         k, pfull_c(k),cmus_tot  (    k)
        endif
      end do

!---------------------------------------------------------------------
!  emds : evaporation in mesoscale downdrafts.
!         [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((emds_liq(k) + emds_ice(k)) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                     'in mulsub: k, P & meso down evap        =',    &
                       k, pfull_c(k), emds_liq(k) + emds_ice(k)
        endif
      end do

!---------------------------------------------------------------------
!  emes : evaporation in mesoscale updrafts.
!         [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((emes_liq(k) + emes_ice(k)) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                        'in mulsub: k, P & meso up evap        =',    &
                          k, pfull_c(k),emes_liq(k) + emes_ice(k)
        endif
      end do

!---------------------------------------------------------------------
!  wmms : vapor transferred from cell to mesoscale circulation and 
!         then condensed [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (wmms(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                      'in mulsub: k, P & meso cell con       =',    &
                       k, pfull_c(k),wmms(k)
        endif
      end do

!---------------------------------------------------------------------
!  wmps : vapor transferred from cell to mesoscale circulation  
!         [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (wmps(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                       'in mulsub: k, P & meso vap redist     =',    &
                          k, pfull_c(k),wmps(k)
        endif
      end do

!---------------------------------------------------------------------
!  tmes   : mesoscale temperature flux convergence                
!           [ deg K / day ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (tmes(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                       'in mulsub: k, P & meso efc            =',    &
                        k, pfull_c(k),tmes(k)
        endif
      end do

!---------------------------------------------------------------------
!  mrmes   : mesoscale moisture flux convergence                
!            [ kg(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
!! WAS ORIGINALLY    :    if (tmes  (    k) /= 0.00 ) then
        if (mrmes(k) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)') &
                        'in mulsub: k, P & meso mfc            =',    &
                         k, pfull_c(k),mrmes(k)
        endif
      end do

!---------------------------------------------------------------------
!  eces   : sublimation in mesoscale updrafts               
!           [ kg(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((eces_liq(k) + eces_ice(k)) /= 0.00 ) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                      'in mulsub: k, P & up con evap         =',    &
                          k, pfull_c(k), eces_liq(k) + eces_ice(k)
        endif
      end do

!---------------------------------------------------------------------
!  ecds_v : sublimation in mesoscale downdrafts             
!           [ kg(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((ecds_liq(k) + ecds_ice(k)) /= 0.00 ) then
           write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                      'in mulsub: k, P & down con evap         =',    &
                       k, pfull_c(k), ecds_liq(k) + ecds_ice(k)
        endif
      end do

!---------------------------------------------------------------------
!  disa   : total temperature tendency due to deep convection
!           [ deg K / day ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (disa(k) /= 0.0) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                           'in mulsub: k, p & ens thermal forc', &
                              k, pfull_c(k), disa(k)
         endif
       end do

!---------------------------------------------------------------------
!  dise : total moisture tendency due to deep convection
!         [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (dise(k) /= 0.0) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                          'in mulsub: k, p & ens moisture forc', &
                           k, pfull_c(k), dise(k)
        endif
      end do

!---------------------------------------------------------------------
!  disg2_v : total moisture tendency due to remaining cell condensate
!            [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((disg_2liq(k) + disg_2ice(k)) /= 0.0) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                         'in mulsub: k, p & thermal modifications', &
                          k, pfull_c(k), disg_2liq(k) + disg_2ice(k)+ &
                         temp_tend_freeze(k) + temp_tend_melt(k)
          write (diag_unit, '(a, i4, f19.10, 2e20.12)')  &
            'in mulsub: k, p & thermal modifications -- liq, ice', &
                          k, pfull_c(k), disg_2liq(k),  disg_2ice(k)
        endif
      end do

!---------------------------------------------------------------------
!  disf_v : total moisture tendency due to evaporation in cell updrafts
!           [ g(h2o) / (kg(air) day) ]
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (disf(k) /= 0.0) then
          write (diag_unit, '(a, i4, f19.10, e20.12)')  &
                      'in mulsub: k, p & moisture modifications', &
                       k, pfull_c(k), disf(k)
        endif
      end do

!---------------------------------------------------------------------



end subroutine don_d_output_diag_profs_k


!#####################################################################

subroutine don_d_def_conv_forcing_k  &
         (nlev_lsm, diag_unit, debug_ijt, lmeso, Initialized,   &
          pb, Param, Nml, ensmbl_precip, meso_precip, meso_cloud_area, &
          anvil_precip_melt, phalf_c, enev, encmf, ensmbl_freeze, &
          ensmbl_freeze_meso, enctf, disg_liq, disg_ice, ecds_liq, &
          ecds_ice, eces_liq, eces_ice, emds_liq, emds_ice, emes_liq,&
          emes_ice, mrmes, mrmes_up, mrmes_dn, tmes, tmes_up, tmes_dn, &
          wmps, ensmbl_cloud_area, ensmbl_melt, ensmbl_melt_meso, &
          pfull_c, temp_c, cmus_tot, wmms, disc_liq, disc_ice, &
          dism_liq, dism_liq_frz, dism_liq_remelt, dism_ice, &
          dism_ice_melted, meso_frz_intg_sum, disp_liq, disp_ice, &
          disb, disd, disv, total_precip_c, disz, disz_remelt, &
          disp_melted, disze1, disze2, disze3,              &
          disf, disn, dise, disa, cutotal, temp_tend_melt,&
          lprcp, liq_prcp, frz_prcp, vrt_mot, water_budget,  &
          n_water_budget, &
          enthalpy_budget, n_enthalpy_budget, precip_budget, &
          n_precip_paths, n_precip_types, ermesg, error, melting_in_cloud)

!---------------------------------------------------------------------
!    subroutine define_convective_forcing produces the effects of
!    the donner_deep parameterization on the large-scale flow, defining
!    the time tendency terms and integral quantities resulting from the
!    parameterization.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_budgets_type,  &
                             donner_initialized_type

implicit none

!---------------------------------------------------------------------
integer,                      intent(in)  :: nlev_lsm, diag_unit
logical,                      intent(in)  :: debug_ijt, lmeso 
type(donner_param_type),      intent(in)  :: Param
type(donner_initialized_type), intent(in)  :: Initialized
type(donner_nml_type),        intent(in)  :: Nml    
real,                         intent(in)  :: ensmbl_precip, meso_precip
real,                         intent(in)  :: pb                        
logical,                      intent(in)  :: meso_frz_intg_sum         
real,    dimension(nlev_lsm), intent(inout)  :: ensmbl_melt,      &
                                                ensmbl_melt_meso, &
                                                anvil_precip_melt, &
                                                ensmbl_freeze, &
                                                ensmbl_freeze_meso
real,    dimension(nlev_lsm + 1), intent(in)  :: phalf_c
real,    dimension(nlev_lsm), intent(in)  :: meso_cloud_area,  &
                                             enev, encmf, &
                                             disz_remelt, disz,       &
                                             disze1, disze2, disze3, &
                                             enctf, ecds_liq, ecds_ice,&
                                             eces_liq, eces_ice, &
                                             disg_liq, disg_ice, &
                                             mrmes,  &
                                             emds_liq, emds_ice, &
                                             emes_liq, emes_ice, &
                                             mrmes_up, mrmes_dn, tmes, &
                                             tmes_up, tmes_dn, &
                                             wmps, ensmbl_cloud_area,  &
                                             pfull_c,   &
                                             temp_c, cmus_tot, wmms,   &
                                             disb, disd, disv, &
                                             disc_liq, disc_ice, &
                                             dism_liq, dism_ice, &
                                             dism_ice_melted, &
                                             dism_liq_frz, &
                                             dism_liq_remelt, &
                                             disp_liq, disp_ice, &
                                             disp_melted
real,                         intent(out) :: total_precip_c
real,    dimension(nlev_lsm), intent(out) :: disf,         &
                                             disn, dise,  &
                                             disa, cutotal,   &
                                             temp_tend_melt, &
                                             liq_prcp, frz_prcp
real,                         intent(out) :: lprcp, vrt_mot
integer, intent(in) :: n_water_budget, n_enthalpy_budget, &
                       n_precip_paths, n_precip_types
real, dimension(nlev_lsm,n_water_budget), intent(out) :: &
                                                           water_budget
real, dimension(nlev_lsm,n_enthalpy_budget), intent(out) ::&
                                                       enthalpy_budget
real, dimension(nlev_lsm,n_precip_paths, n_precip_types),  &
                                              intent(out) ::&
                                                       precip_budget
character(len=*),             intent(out) :: ermesg
integer,                      intent(out) :: error
logical,                      intent( in) :: melting_in_cloud

!---------------------------------------------------------------------
!   intent(in) variables:
!
!        diag_unit         i/o unit for column diagnostics output
!        ensmbl_precip
!        meso_precip       
!        lmeso              a mesoscale circulation is present in this
!                           column ?     
!        debug_ijt          column diagnostics are desired in this 
!                           column ?
!        meso_cloud_area
!        anvil_precip_melt
!        phalf_c            pressure at large-scale model half levels 
!                           [ Pa ]
!        enev
!        encmf
!        ensmbl_freeze
!        enctf
!        disg
!        ecds
!        eces
!        emds
!        emes
!        mrmes
!        tmes
!        wmps
!        ensmbl_cloud_area
!        ensmbl_melt         
!        pfull_c
!        temp_c
!        cmus_tot
!
!    intent(out) variables:
!
!        total_precip_c
!        disf
!        disg_2
!        disn
!        dise
!        disa
!        cutotal
!        temp_tend_melt
!        temp_tend_freeze
!
!---------------------------------------------------------------------



!!  UNITS
!!    ucemh  [kg /sec / m**2 ]
!!    conint [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    precip [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    q1     [ kg(h2o) / kg(air) / sec ]
!!    h1     [ kg(h2o) / kg(air) / sec ]
!!    cmf    [ g(h2o) / kg(air) /day ]
!!    rlh    [ kg(h2o) / kg(air) / day ]  * [ L / Cp ] = [ deg K / day ]
!!    h1_2   [ deg K / sec ]
!!    efc    [ deg K / day ]
!!    efchr  [ deg K / sec ]
!!    ehfh   [ kg(air) (deg K) / (sec**3 m)
!!    ctf    [ deg K / day ]
!!    disb_v [ deg K / day ]
!!    disc_v [ deg K / day ] 
!!    disn   [ deg K / day ] 
!!    ecd    [ g(h2o) / kg(air) / day ]
!!    ece    [ g(h2o) / kg(air) / day ]
!!    ecds_v [ g(h2o) / kg(air) / day ]
!!    eces_v [ g(h2o) / kg(air) / day ]
!!    enctf  [ deg K / day ]
!!    encmf  [ g(h2o) / kg(air) /day ]
!!    pf     [ (m**2 kg(h2o)) / (kg(air) sec) ]
!!    dpf    [ (m**2 kg(h2o)) / (kg(air) sec) ] ==>   
!!                                          [ kg(h2o)) / (kg(air) sec) ]
!!    qlw2   [ kg(h2o)) / (kg(air) sec) ]
!!    qlw    [ kg(h2o)) / kg(air) ]
!!    evap   [ kg(h2o)) / kg(air) ]
!!    evap_rate [ kg(h2o)) / (kg(air) sec) ]
!!    disg   [ deg K / day ]


!--------------------------------------------------------------------
!   local variables:

      real,    dimension(nlev_lsm) :: disl_liq, &
                                      disl_ice, disl_ice_melted, &
                                      disl_liq_depo, disl_liq_cd, &
                                      disl_ice_depo, disl_ice_cd, &
                                      disga_liq_up, disga_liq_dn, &
                                      disga_ice_up, disga_ice_dn, &
                                      disg_2liq, disg_2ice, &
                                      cell_evap, meso_cd, meso_depo, &
                                      meso_evap
      real    ::   vsuma, vsumb, vsumc, vsumd, vsumd1, vsumd2, vsume, &
                   vsumf, vsumg, vsumg1, vsumg2, vsumh, vsumi, vsumi1,&
                   vsumi2
      real    ::   tsuma, tsumb, tsumiup, tsumidn 
      real    ::   tsumj, tsumj1, tsumk1, tsumk2, tsumk3
      real    ::   tsummliq, tsummice, tsummfliq
      real    ::   tsumaliq, tsumcliq, tsumdliq, tsumeliq,   &
                   tsumfliq, tsumg1liq, tsumg2liq
      real    ::   tsumaice, tsumcice, tsumdice, tsumeice,  &
                   tsumfice, tsumg1ice, tsumg2ice
      real    ::   liq_ice
      real    ::   esumc, sumf, summ, sumn
      real    ::   dp
      real    ::                   x7, x8
      real    ::       x8a, x5a, x5b, x5c, x5d, x6a, x6b, x6c, x6d
      real    ::      v5,     v6
      integer ::  k

!--------------------------------------------------------------------
!   local variables:
!
!         esum
!         esuma
!         esumc
!         sumf
!         summ
!         sumqme
!         sumg
!         sumn
!         sumelt
!         sumfre
!         summes
!         disl
!         disga
!         nlev            number of layers in large-scale model
!         k               do-loop index
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = '  ' ; error = 0
      lprcp = 0.
      vrt_mot = 0.
      liq_ice = 0.

!--------------------------------------------------------------------
!    define the total precipitation (total_precip_c) from the parameter-
!    ization as the sum of the convective (ensmbl_precip) and mesoscale
!    (meso_precip) precipitation. 
!--------------------------------------------------------------------
      total_precip_c = ensmbl_precip + meso_precip    

!----------------------------------------------------------------------
!    add the mesoscale cloud area to the cell-ensemble cloud area to
!    obtain the total cloud area profile.    
!----------------------------------------------------------------------
      do k=1,nlev_lsm
        cutotal (k) = ensmbl_cloud_area(k) + meso_cloud_area(k)
      end do

!---------------------------------------------------------------------
!    if in a diagnostics column, output the profiles of ensemble-total 
!    cloud area (ensmbl_cloud_area) and mesoscale cloud area 
!    (meso_cloud_area), total cloud area (cu_total), deposition in 
!    mesoscale updrafts (cmus), evaporation in mesoscale downdrafts 
!    (emds), evaporation from mesoscale updrafts (emes), water vapor 
!    supplied to mesoscale circulation (wmps), melted anvil precip-
!    itation ( anvil_precip_melt), mesoscale temperature flux
!    convergence (tmes) and mesoscale vapor-flux convergence (mrmes).
!---------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_lsm
          write (diag_unit, '(a, i4, f19.10, 3e20.12)') &
                 'in mulsub: jk, pr,cual,cuml, cutot= ', k, pfull_c(k),&
                  ensmbl_cloud_area (k), meso_cloud_area(k), cutotal(k)
          write (diag_unit, '(a, i4, 3e20.12)')  &
                     'in mulsub: jk,cmu,emd,eme= ', k, cmus_tot(k), &
                   emds_liq(k) + emds_ice(k), emes_liq(k) + emes_ice(k)
          write (diag_unit, '(a, i4, 2e20.12)') &
                     'in mulsub: jk,wmm,wmp,elt= ', k,           &
                      wmps(k),  -anvil_precip_melt(k)
          write (diag_unit, '(a, i4, f20.14, e20.12)')  &
                      'in mulsub: jk,tmes,qmes= ', k, tmes(k), mrmes(k)
        end do
      endif

!---------------------------------------------------------------------
!    define terms which will appear in the large-scale model equations.
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!----------------------------------------------------------------------
!    combine several of the moisture tendency terms associated with the
!    donner_deep parameterization (disf). if a mesoscale circulation is
!    present, the following terms are included : 1) transfer of vapor 
!    from mesoscale to large-scale flow ( the sum of the water mass 
!    condensed in the mesoscale updraft plus the vapor transferred from
!    cell to mesoscale and then condensed -- cmus_tot), 2) evaporation 
!    in cumulus downdrafts (ecds), 3) evaporation from cumulus updrafts 
!    (eces), 4)  vapor transferred from cells to mesoscale (wmps), 5) 
!    evaporation from mesoscale updrafts (emes), 6) evaporation from 
!    mesoscale downdrafts (emds), and 7) mesoscale moisture-flux 
!    convergence (mrmes). 
!----------------------------------------------------------------------
        if (lmeso) then
          cell_evap(k) = (ecds_liq(k) + ecds_ice(k)) +  &
                         (eces_liq(k) + eces_ice(k))
          meso_cd(k) =  wmms(k)
          meso_depo(k) = -cmus_tot(k) - wmms(k)
          meso_evap(k) = emes_liq(k) + emds_liq(k) + &
                         emes_ice(k) + emds_ice(k)

!----------------------------------------------------------------------
!    if a mesoscale circulation is not present, disf is simply the 
!    moisture tendency associated with the evaporation of the condensed
!    cloud water that did not precipitate out (enev). convert to units 
!    of g(h2o) per kg(air) per day.
!----------------------------------------------------------------------
        else
          cell_evap(k) = enev(k)*(1.0E03*Param%seconds_per_day)
          meso_cd(k) = 0.
          meso_depo(k) = 0.
          meso_evap(k) = 0.
        endif

        disf(k) = meso_depo(k) + meso_cd(k) + cell_evap(k) +    &
                  wmps(k) + meso_evap(k)  + mrmes_up(k) + mrmes_dn(k)

!---------------------------------------------------------------------
!    define the sum of disf and the term containing the tendency due 
!    to cell-scale vertical moisture-flux convergence and associated
!    condensation (encmf), and store in array dise.
!---------------------------------------------------------------------
        if (Nml%do_donner_lscloud) then
          dise(k) = encmf(k) + disf(k)
        else
          dise(k) = encmf(k)
        endif

!----------------------------------------------------------------------
!    define the temperature tendencies associated with the freezing
!    of updraft liquid (temp_tend_freeze) and the melting of ice
!    falling from the anvil (temp_tend_melt). combine several of the 
!    temperature tendencies associated with the cell component of the
!    donner_deep parameterization (disn). disn is composed of 1) a term
!    combining the vertical flux convergence of temperature and cloud 
!    condensation (enctf), 2) evaporation of liquid in the cell updraft
!    and downdraft (disg), 3) the freezing of updraft liquid 
!    (temp_tend_freeze) and 4) the melting of ice (temp_tend_melt). 
!    separately define the temperature tendency resulting from the 
!    latent heat release associated with sublimation occurring in the 
!    mesoscale updraft and downdraft (disga).
!----------------------------------------------------------------------
        ensmbl_freeze (k) = ensmbl_freeze(k)*Param%hlf/     &
                               (Param%cp_air*1000.)
        ensmbl_freeze_meso (k) = ensmbl_freeze_meso(k)*Param%hlf/  &
                               (Param%cp_air*1000.)
        anvil_precip_melt(k) =  (anvil_precip_melt(k))*  &
                                          Param%hlf/(Param%cp_air*1000.)
        ensmbl_melt(k) =  ensmbl_melt(k)*  &
                                          Param%hlf/(Param%cp_air*1000.)
        ensmbl_melt_meso(k) =  ensmbl_melt_meso(k)* &
                                          Param%hlf/(Param%cp_air*1000.)
        if (lmeso) then
          disga_ice_up(k) =  -(emes_ice(k) )*  &
                                    Param%hls/(Param%cp_air*1000.)
          disga_ice_dn(k) =  -( emds_ice(k))*  &
                                    Param%hls/(Param%cp_air*1000.)
          if (melting_in_cloud) then
            disl_ice_depo(k) =     &
                           -meso_depo(k)*Param%hls/(Param%cp_air*1000.)
            disl_ice_cd(k) =       &
                          -( meso_cd(k))*Param%hls/(Param%cp_air*1000.)
            disl_liq_depo(k) = 0.
            disl_liq_cd(k) = 0.
            disga_liq_up(k) =  -(emes_liq(k) )*  &
                                    Param%hls/(Param%cp_air*1000.)
            disga_liq_dn(k) =  -(emds_liq(k))*  &
                                    Param%hls/(Param%cp_air*1000.)
          else
            disga_liq_up(k) =  -emes_liq(k) * &
                                    Param%hlv/(Param%cp_air*1000.)
            disga_liq_dn(k) =  -emds_liq(k) * &
                                     Param%hlv/(Param%cp_air*1000.)
            if (.not. meso_frz_intg_sum      ) then
              disl_liq_depo(k) = -(meso_depo(k))*    &
                                     Param%hlv/(Param%cp_air*1000.)
              disl_liq_cd(k) = -( meso_cd(k))*    &
                                     Param%hlv/(Param%cp_air*1000.)
              disl_ice_depo(k) = 0.
              disl_ice_cd(k) = 0.
            else
! if no melting but freezing, then hls carried out
              disl_ice_depo(k) = -meso_depo(k)*  &
                                      Param%hls/(Param%cp_air*1000.)
              disl_ice_cd(k) = -( meso_cd(k))*     &
                                      Param%hls/(Param%cp_air*1000.)
              disl_liq_depo(k) = 0.
              disl_liq_cd(k) = 0.
            endif
          endif
        else ! (lmeso)
          disl_liq_depo(k) = 0.
          disl_liq_cd(k) = 0.
          disl_ice_depo(k) = 0.
          disl_ice_cd(k) = 0.
          disga_liq_up(k) = 0.
          disga_liq_dn(k) = 0.
          disga_ice_up(k) = 0.
          disga_ice_dn(k) = 0.
        endif

!--------------------------------------------------------------------
!    if in a diagnostics column, output the profile of temperature 
!    change associated with evaporation in the mesoscale circulation 
!    (disga).
!--------------------------------------------------------------------
        if (debug_ijt) then
          if ( (disga_liq_up(k) + disga_liq_dn(k) +   &
                disga_ice_up(k) + disga_ice_dn(k)) /= 0.0) then
            write (diag_unit, '(a, i4, f19.10,  e20.12)')  &
                    'in mulsub: jk,pr,disga= ', k, pfull_c(k),  &
                      -(disga_liq_up(k) + disga_liq_dn(k) +   &
                      disga_ice_up(k) + disga_ice_dn(k))
            write (diag_unit, '(a, i4, f19.10,  2e20.12)')  &
                    'in mulsub: jk,pr,disgal, disgai= ', k,   &
            pfull_c(k), -(disga_liq_up(k) + disga_liq_dn(k)),  &
                    -(disga_ice_up(k) + disga_ice_dn(k))
          endif
        endif

!--------------------------------------------------------------------
!    if a mesoscale circulation is present, define the heating terms
!    equivalent to the disf array (disg_2). included in disg_2 are 
!    terms associated with 1) transfer of vapor from mesoscale to 
!    large-scale flow (disl), 2) evaporation in cumulus updrafts and 
!    downdrafts (disg), 3) freezing of liquid in the updraft 
!    (temp_tend_freeze), 4) melting of ice (temp_tend_melt), 5) evap-
!    oration in the mesoscale circulation (disga), and 6) mesoscale 
!    temperature flux convergence (tmes).
!--------------------------------------------------------------------
        if (lmeso) then
          disg_2liq(k) = disl_liq_depo(k)  + disl_liq_cd(k) +    &
                         disg_liq(k) + disga_liq_up(k) + disga_liq_dn(k)
          disg_2ice(k) = disl_ice_depo(k) + disl_ice_cd(k) +   &
                         disg_ice(k) + disga_ice_up(k) +disga_ice_dn(k)

!---------------------------------------------------------------------
!    define the sum of disg_2 and the term containing the tendency due 
!    to cell-scale vertical temperature-flux convergence and associated
!    condensation (enctf), and store in array disa.
!---------------------------------------------------------------------
          disn(k) = enctf(k) + disg_liq(k) + disg_ice(k) +  &
                     ensmbl_freeze_meso(k) + &
                    ensmbl_freeze(k) + ensmbl_melt(k)  + &
                    ensmbl_melt_meso(k)                         
          if (Nml%do_donner_lscloud) then
            disa(k) = enctf(k) + (disl_liq_depo(k)  + disl_liq_cd(k) + &
                    disl_ice_depo(k) + disl_ice_cd(k)) +   &
                    disg_liq(k) + disga_liq_up(k) + disga_liq_dn(k) + &
                    disg_ice(k) + disga_ice_up(k) +disga_ice_dn(k) + &
                    ensmbl_freeze_meso(k) + &
                    ensmbl_freeze(k) + ensmbl_melt(k) +  &
                    ensmbl_melt_meso(k) + &
                    anvil_precip_melt(k) + tmes_up(k) + tmes_dn(k)
          else
            disa(k) = enctf(k)
          endif
        else ! (lmeso)
          disg_2liq(k) = -disze2(k)         
          disg_2ice(k) = -disze1(k)

!---------------------------------------------------------------------
!    define the sum of disg_2 and the term containing the tendency due 
!    to cell-scale vertical temperature-flux convergence and associated
!    condensation (enctf), and store in array disa.
!---------------------------------------------------------------------
          if (Nml%do_donner_lscloud) then
            disa(k) = enctf(k) + disg_2liq(k) + disg_2ice(k) + &
                     disze3(k) + ensmbl_freeze(k) + ensmbl_melt(k) 
          else
            disa(k) = enctf(k)
          endif

          disn(k) = disa(k)
        endif

        temp_tend_melt(k) = ensmbl_melt(k) +   &
                              ensmbl_melt_meso(k) + &
                                               anvil_precip_melt(k)

!--------------------------------------------------------------------
!    define precip types.
!--------------------------------------------------------------------
        if (lmeso) then
          if (melting_in_cloud) then 
            disl_ice_melted(k) = -(meso_depo(k) + meso_cd(k))/(1000.)
            disl_liq(k) = 0.
            disl_ice(k) = 0.
          else
            if (.not. meso_frz_intg_sum      ) then
              disl_liq(k) = -(meso_depo(k) + meso_cd(k))/(1000.)
              disl_ice(k) = 0.
              disl_ice_melted(k) = 0.
            else
! if no melting but freezing, then hls carried out
              disl_ice    (k) = -(meso_depo(k) + meso_cd(k))/(1000.)
              disl_ice_melted(k) = 0.
              disl_liq(k) = 0.
            endif
          endif
        else ! (lmeso)
          disl_liq(k) = 0.
          disl_ice(k) = 0.
          disl_ice_melted(k) = 0.
        endif
        if (lmeso) then
            liq_prcp(k) = Param%anvil_precip_efficiency*(dism_liq(k) + &
                          disl_liq(k) +    &
                          dism_liq_remelt(k) + dism_ice_melted(k) + &
                          disl_ice_melted(k)) + disp_liq(k) + &
                          disp_melted(k) + disz_remelt(k)
            frz_prcp(k) = Param%anvil_precip_efficiency*  &
                          (dism_liq_frz(k) + dism_ice(k) +   &
                          disl_ice(k)) + disp_ice(k) + disz(k)
          else
            liq_prcp(k) = disp_liq(k) + disp_melted(k) + disz_remelt(k)
            frz_prcp(k) = disp_ice(k) + disz(k)
          endif
     end do

      if (Nml%do_budget_analysis .or.    &
                             Initialized%do_conservation_checks) then
        tsumb = 0.
        tsumiup = 0.
        tsumidn = 0.
        do k=1,nlev_lsm
          dp = Param%cp_air*(phalf_c(k) - phalf_c(k+1))/Param%grav
          tsumb = tsumb + disb(k)*dp
          tsumiup  = tsumiup  + tmes_up(k)*dp
          tsumidn  = tsumidn  + tmes_dn(k)*dp
        end do

        if (lmeso) then
          vrt_mot = tsumiup + tsumidn + tsumb
        else
          vrt_mot = tsumb
        endif

        x5a = 0.
        x5b = 0.
        x5c = 0.
        x5d = 0.
        x6a = 0.
        x6b = 0.
        x6c = 0.
        x6d = 0.
        x7 = 0.
        x8 = 0.
        x8a = 0.
        v5 = 0.
        v6 = 0.

        do k=1,nlev_lsm
          dp = (phalf_c(k) - phalf_c(k+1))/Param%grav
          v5 = v5 + disz (k)*dp
          v6 = v6 + disz_remelt (k)*dp
          if (lmeso) then
          x5a = x5a + (dism_liq(k)                     )*dp
          x5b = x5b + (disl_liq(k) )*dp
          x5c = x5c + (dism_liq_frz(k) )*dp
          x5d = x5d + (dism_liq_remelt(k) )*dp
          x6a = x6a + (dism_ice(k)                     )*dp
          x6b = x6b + (disl_ice(k))*dp
          x6c = x6c + (dism_ice_melted(k) )*dp
          x6d = x6d + (disl_ice_melted(k))*dp
          endif
          x7 = x7 + disp_liq(k)*dp
          x8 = x8 + disp_ice(k)*dp
          x8a = x8a + disp_melted(k)*dp
        end do
        x5a = x5a*Param%anvil_precip_efficiency
        x5b = x5b*Param%anvil_precip_efficiency
        x5c = x5c*Param%anvil_precip_efficiency
        x5d = x5d*Param%anvil_precip_efficiency
        x6a = x6a*Param%anvil_precip_efficiency
        x6b = x6b*Param%anvil_precip_efficiency
        x6c = x6c*Param%anvil_precip_efficiency
        x6d = x6d*Param%anvil_precip_efficiency

      if (debug_ijt) then
         
      do k=1, nlev_lsm 
         write (diag_unit, '(1(a, i4, 2e20.12))') &
          
             'total precip-- k, liq, frz', k, liq_prcp(k), frz_prcp(k) 
      end do
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')   '***************************'
         write (diag_unit, '(1(a))')  &
            'PRECIPITATION SOURCES  --  UNITS OF  mm / day'
         write (diag_unit, '(1(a))')   '***************************'
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a, e20.12))')  &
           'TOTAL PRECIPITATION: ', x5a + x5b + x5c + x5d + x6a + &
                                     x6b + x6c + x6d + x7 +  &
                                     x8 + v5 + x8a + v6
         write (diag_unit, '(1(a, e20.12))')  &
           'MESO  PRECIPITATION: ', x5a + x5b + x5c + x5d + x6a + &
                                     x6b + x6c + x6d 
         write (diag_unit, '(1(a, e20.12))')  &
           'CELL  PRECIPITATION: ', x7 + x8 + x8a + v5 + v6
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a, e20.12))')  &
           'cell liquid condensate precipitated out as liquid', x7 
         write (diag_unit, '(1(a, e20.12))')  &
          'cell liquid condensate precipitated out as frozen liquid', v5
         write (diag_unit, '(1(a, e20.12))')  &
           'cell liquid condensate which froze, remelted and  &
               &precipitated out as liquid', v6 
         write (diag_unit, '(1(a, e20.12))')  &
           'cell liquid condensate transferred to the mesoscale &
                &circulation and precipitated out as liquid', x5a
         write (diag_unit, '(1(a, e20.12))')  &
           'cell liquid condensate transferred to the mesoscale &
                  &circulation, then frozen and precipitated out &
                  &as frozen liquid', x5c
         write (diag_unit, '(1(a, e20.12))')  &
           'cell liquid condensate transferred to the mesoscale &
              &circulation, frozen, remelted and precipitated &
                                       &out as liquid', x5d
         write (diag_unit, '(1(a, e20.12))')  &
           'mesoscale liquid condensate precipitated out as liquid', x5b
         write (diag_unit, '(1(a, e20.12))')  &
           'cell ice    condensate precipitated out as ice   ', x8 
         write (diag_unit, '(1(a, e20.12))')  &
           'cell ice    condensate which melted and  precipitated &
                             &out as liquid', x8a
         write (diag_unit, '(1(a, e20.12))')  &
           'cell ice transferred to mesoscale and precipitated &
                        &out as ice   ', x6a
         write (diag_unit, '(1(a, e20.12))')  &
           'cell ice transferred to mesoscale which melted and &
                      & precipitated out as liquid', x6c
         write (diag_unit, '(1(a, e20.12))')  &
           'mesoscale ice condensate  precipitated out as ice   ', x6b
         write (diag_unit, '(1(a, e20.12))')  &
           'mesoscale ice condensate which melted and  &
                    &precipitated out as liquid', x6d
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
       
   endif

        v5 = v5*Param%hls   
        v6 = v6*Param%hlv    
        x5a = x5a*Param%hlv
        x5b = x5b*Param%hlv
        x5c = x5c*Param%hls
        x5d = x5d*Param%hlv
        x6a = x6a*Param%hls
        x6b = x6b*Param%hls
        x6c = x6c*Param%hlv
        x6d = x6d*Param%hlv
        x7 = x7*Param%hlv   
        x8 = x8*Param%hls   
        x8a = x8a*Param%hlv      
        lprcp = x5a + x5b + x5c + x5d + x6a + x6b + x6c + x6d + x7 +  &
                x8 + v5 + x8a + v6

      if (debug_ijt) then
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')   '***************************'
         write (diag_unit, '(1(a))')  &
            'LATENT HEAT REMOVED BY THE PRECIPITATION SOURCES  --&
                           &  UNITS OF  J / (m**2 day)'
         write (diag_unit, '(1(a))')   '***************************'
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a, e20.12))')  &
           'TOTAL PRECIPITATION: ', x5a + x5b + x5c + x5d + x6a + &
                                     x6b + x6c + x6d + x7 +  &
                                     x8 + v5 + x8a + v6
         write (diag_unit, '(1(a, e20.12))')  &
           'MESO  PRECIPITATION: ', x5a + x5b + x5c + x5d + x6a + &
                                     x6b + x6c + x6d 
         write (diag_unit, '(1(a, e20.12))')  &
           'CELL  PRECIPITATION: ', x7 + x8 + x8a + v5 + v6
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell liquid condensate precipitated &
                             &out as liquid', x7 
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell liquid condensate precipitated &
                             &out as frozen liquid', v5 
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell liquid condensate which froze, &
                       &remelted and precipitated out as liquid', v6 
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell liquid condensate transferred to &
                &the mesoscale circulation and precipitated out&
                & as liquid', x5a
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell liquid condensate transferred to &
             &the mesoscale circulation, then frozen and precipitated &
               &out as frozen liquid', x5c
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell liquid condensate transferred &
               &to the mesoscale circulation, frozen, remelted &
                 &and precipitated out as liquid', x5d
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by mesoscale liquid condensate &
                          &precipitated out as liquid', x5b
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell ice condensate precipitated &
                     &out as ice   ', x8 
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell ice    condensate which melted &
                  &and  precipitated out as liquid', x8a
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell ice transferred to mesoscale and &
                      &precipitated out as ice   ', x6a
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by cell ice transferred to mesoscale &
                &which melted and  precipitated out as liquid', x6c
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by mesoscale ice condensate  precipitated &
                       &out as ice   ', x6b
         write (diag_unit, '(1(a, e20.12))')  &
           'heat removed by mesoscale ice condensate which melted &
                        &and  precipitated out as liquid', x6d
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
       
   endif
      endif

      if (Initialized%do_conservation_checks .or.   &
                                         Nml%do_budget_analysis) then
! units of water budget: g(h20) / kg(air) / day
        do k=1,nlev_lsm
          water_budget(k,1) = dise(nlev_lsm-k+1)
          water_budget(k,2) = encmf(nlev_lsm-k+1)
          water_budget(k,3) = meso_depo(nlev_lsm-k+1)
          water_budget(k,4) = meso_cd(nlev_lsm-k+1)
          water_budget(k,5) = cell_evap(nlev_lsm-k+1)
          water_budget(k,6) = wmps (nlev_lsm-k+1)
          water_budget(k,7) = meso_evap(nlev_lsm-k+1)
          water_budget(k,8) = mrmes_up(nlev_lsm-k+1)
          water_budget(k,9) = mrmes_dn(nlev_lsm-k+1)

!  enthalpy_budget terms are in units of deg K / day.
          if (lmeso) then
            enthalpy_budget(k,1) = disa(nlev_lsm-k+1)
            enthalpy_budget(k,2) = enctf(nlev_lsm-k+1)
            enthalpy_budget(k,3) = disl_liq_depo(nlev_lsm-k+1)
            enthalpy_budget(k,4) = disl_liq_cd(nlev_lsm-k+1)
            enthalpy_budget(k,5) = disg_liq(nlev_lsm-k+1)
            enthalpy_budget(k,6) = disga_liq_up(nlev_lsm-k+1)
            enthalpy_budget(k,7) = disga_liq_dn(nlev_lsm-k+1)
            enthalpy_budget(k,8) = disl_ice_depo(nlev_lsm-k+1)
            enthalpy_budget(k,9) = disl_ice_cd  (nlev_lsm-k+1)
            enthalpy_budget(k,10) = disg_ice(nlev_lsm-k+1)
            enthalpy_budget(k,11) = disga_ice_up(nlev_lsm-k+1)
            enthalpy_budget(k,12) = disga_ice_dn(nlev_lsm-k+1)
            enthalpy_budget(k,13) = ensmbl_freeze_meso(nlev_lsm-k+1)
            enthalpy_budget(k,14) = ensmbl_freeze(nlev_lsm-k+1)
            enthalpy_budget(k,15) = ensmbl_melt(nlev_lsm-k+1)
            enthalpy_budget(k,16) = ensmbl_melt_meso(nlev_lsm-k+1)
            enthalpy_budget(k,17) = anvil_precip_melt(nlev_lsm-k+1)
            enthalpy_budget(k,18) = tmes_up(nlev_lsm-k+1)
            enthalpy_budget(k,19) = tmes_dn(nlev_lsm-k+1)
          else
            enthalpy_budget(k,1) = disa(nlev_lsm-k+1)
            enthalpy_budget(k,2) = enctf(nlev_lsm-k+1)
            enthalpy_budget(k,5) = disg_2liq(nlev_lsm-k+1) +  &
                                               disg_2ice(nlev_lsm-k+1)
            enthalpy_budget(k,10) = disze3   (nlev_lsm-k+1)
            enthalpy_budget(k,14) = ensmbl_freeze(nlev_lsm-k+1)
            enthalpy_budget(k,15) = ensmbl_melt(nlev_lsm-k+1)
          endif
        end do

!--------------------------------------------------------------------
!    compute the column integrals of the various tendency terms for 
!    the vapor equation. 
!   vsuma  : total vapor tendency from donner_deep parameterization
!    sumf  : total vapor tendency less the vertical flux convergence and
!            condensation      
!    summ  : vapor tendency due to vertical flux convergence and
!            condensation 
!    sumqme: mesoscale moisture flux convergence
!--------------------------------------------------------------------

        sumf   = 0.
        summ   = 0.
        vsuma  = 0.
        vsumb  = 0.
        vsumc  = 0.
        vsumd  = 0.
        vsumd1 = 0.
        vsumd2 = 0.
        vsume  = 0.
        vsumf  = 0.
        vsumg  = 0.
        vsumg1 = 0.
        vsumg2 = 0.
        vsumh  = 0.
        vsumi  = 0.
        vsumi1 = 0.
        vsumi2 = 0.
         
        do k=1,nlev_lsm
          dp = (phalf_c(k) - phalf_c(k+1))/Param%grav
          sumf   = sumf   + disf(k)*dp
          summ   = summ   + encmf(k)*dp
          vsuma = vsuma + dise(k)*dp
          vsumb = vsumb + disd(k)*dp
          vsumc = vsumc - disv(k)*dp
          vsumd = vsumd + cell_evap(k)*dp
          vsumd1 = vsumd1 + (ecds_liq(k) + ecds_ice(k))*dp
          vsumd2 = vsumd2 + (eces_liq(k) + eces_ice(k))*dp
          vsume  = vsume + meso_cd(k)*dp
          vsumf = vsumf + meso_depo(k)*dp
          vsumg = vsumg + meso_evap(k)*dp
          vsumg1 = vsumg1 + (emes_liq(k) + emes_ice(k))*dp
          vsumg2 = vsumg2 + (emds_liq(k) + emds_ice(k))*dp
          vsumh = vsumh + wmps(k)*dp
          vsumi1 = vsumi1 + mrmes_up(k)*dp
          vsumi2 = vsumi2 + mrmes_dn(k)*dp
        end do
!---------------------------------------------------------------------
!    convert the moisture terms to units of mm(h2o) per day.
!---------------------------------------------------------------------
        sumf   = sumf/(1000.)
        summ   = summ/(1000.)
        vsuma   = vsuma/(1000.)
        vsumb   = vsumb/(1000.)
        vsumc   = vsumc/(1000.)
        vsumd   = vsumd/(1000.)
        vsumd1  = vsumd1/(1000.)
        vsumd2  = vsumd2/(1000.)
        vsume   = vsume/(1000.)
        vsumf   = vsumf/(1000.)
        vsumg   = vsumg/(1000.)
        vsumg1  = vsumg1/(1000.)
        vsumg2  = vsumg2/(1000.)
        vsumh   = vsumh/(1000.)
        vsumi1  = vsumi1/(1000.)
        vsumi2  = vsumi2/(1000.)
        vsumi = vsumi1 + vsumi2


! units for precip_budget: (kg(h2o) / kg (air) / day
       do k=1,nlev_lsm
         precip_budget(k,1,1) = disp_liq(nlev_lsm-k+1)
         precip_budget(k,2,1) = disz(nlev_lsm-k+1)
         precip_budget(k,3,1) = disz_remelt(nlev_lsm-k+1)
         precip_budget(k,4,1) = disp_ice(nlev_lsm-k+1)           
         precip_budget(k,5,1) = disp_melted(nlev_lsm-k+1)            

         precip_budget(k,1,2) = dism_liq(nlev_lsm-k+1)
         precip_budget(k,2,2) = dism_liq_frz(nlev_lsm-k+1)
         precip_budget(k,3,2) = dism_liq_remelt(nlev_lsm-k+1)
         precip_budget(k,4,2) = dism_ice(nlev_lsm-k+1)
         precip_budget(k,5,2) = dism_ice_melted(nlev_lsm-k+1)

         precip_budget(k,1,3) = disl_liq(nlev_lsm-k+1)
         precip_budget(k,2,3) = 0.0  
         precip_budget(k,3,3) = 0.0
         precip_budget(k,4,3) = disl_ice(nlev_lsm-k+1)
         precip_budget(k,5,3) = disl_ice_melted(nlev_lsm-k+1)
       end do
         precip_budget(:,:,2) = precip_budget(:,:,2)*   &
                                Param%anvil_precip_efficiency
         precip_budget(:,:,3) = precip_budget(:,:,3)*   &
                                Param%anvil_precip_efficiency
!--------------------------------------------------------------------
!    output the various column integrals.
!--------------------------------------------------------------------
       if (debug_ijt) then
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(a, e20.12, a)') &
              'in mulsub: CELL MOISTURE FORCING= ', summ, ' MM/DAY'
         write (diag_unit, '(a, e20.12, a)') &
          'in mulsub: TOTAL TENDENCY LESS CELL MOISTURE FORCING= ', &
                                                       sumf, ' MM/DAY'
         write (diag_unit, '(a, e20.12, a)') &
          'in mulsub: TOTAL CELL MOISTURE TENDENCY= ', &
                             summ + vsumd, ' MM/DAY'
         if (lmeso) then
           write (diag_unit, '(a, e20.12, a)') &
            'in mulsub: TOTAL MESO MOISTURE TENDENCY= ', &
                             vsuma - summ - vsumd, ' MM/DAY'
         endif
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')   '***************************'
         write (diag_unit, '(1(a))')  &
            'COLUMN INTEGRAL VAPOR BUDGET TERMS --  &
                                           &UNITS OF  mm / day'
         write (diag_unit, '(1(a))')   '***************************'
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(a, e20.12)') &
             'TOTAL VAPOR TENDENCY=', vsuma 
         write (diag_unit, '(a, e20.12)') &
              '    DYNAMICAL TENDENCY=', vsumb + vsumh + vsumi
         write (diag_unit, '(a, e20.12)') &
             '         VAPOR CONVERGENCE IN CELLS=', vsumb 
         if (lmeso) then
           write (diag_unit, '(a, e20.12)') &
             '         TRANSFER FROM CELL UPDRAFTS TO MESO=', vsumh 
           write (diag_unit, '(a, e20.12)') &
             '         TRANSFER BY MESOSCALE EDDY FLUXES= ', vsumi
           write (diag_unit, '(a, e20.12)') &
             '              TRANSFER BY UPWARD EDDIES= ', vsumi1
           write (diag_unit, '(a, e20.12)') &
             '              TRANSFER BY DOWNWARD EDDIES= ', vsumi2
         endif
         write (diag_unit, '(a, e20.12)') &
             '    CONDENSATION IN CELLS=', vsumc 
         write (diag_unit, '(a, e20.12)') &
             '    EVAPORATION IN CELLS= ', vsumd

         if (lmeso) then
           write (diag_unit, '(a, e20.12)') &
             '         CELL DOWNDRAFT EVAP=', vsumd1  
           write (diag_unit, '(a, e20.12)') &
             '         CELL UPDRAFT EVAP=', vsumd2  
           write (diag_unit, '(a, e20.12)') &
             '    MESOSCALE CONDENSATION  =', vsume
           write (diag_unit, '(a, e20.12)') &
             '    MESOSCALE DEPOSITION=', vsumf 
           write (diag_unit, '(a, e20.12)') &
             '    MESOSCALE EVAPORATION=', vsumg  
           write (diag_unit, '(a, e20.12)') &
             '         MESO EVAPORATION IN UPDRAFTS =', vsumg1
           write (diag_unit, '(a, e20.12)') &
             '         MESO EVAPORATION IN DOWNDRAFTS=', vsumg2  
         endif

         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a))')  
         write (diag_unit, '(1(a,3l4         ))')  &
                  'in mulsub:  lmeso, anvil melts?, meso freezes?', &
                  lmeso, melting_in_cloud, meso_frz_intg_sum  


       endif ! (debug_ijt)

!--------------------------------------------------------------------
!    compute the column integrals of the various tendency terms for 
!    the temperature equation. 
!    tsuma : total temperature tendency from donner_deep parameter-
!            ization
!    sumg  : total temperature tendency less the vertical flux conver-
!            gence and condensation
!    esumc : temperature tendency due to vertical flux convergence and
!            condensation  
!    summes: temperature tendency due to mesoscale temperature flux
!            convergence
!    sumelt: temperature tendency due to melting within column
!    sumfre: temperature tendency due to freezing within the column
!    sumn  : temperature tendency associated with the cell component of
!            the donner_deep parameterization
!--------------------------------------------------------------------

       esumc  = 0.
       sumn = 0.
       tsumj = 0.
       tsumj1 = 0.
       tsumk1 = 0.
       tsumk2 = 0.
       tsumk3 = 0.
       tsumcliq = 0.
       tsumdliq = 0.
       tsumeliq = 0.
       tsumfliq = 0.
       tsumg1liq = 0.
       tsumg2liq = 0.
       tsumcice = 0.
       tsumdice = 0.
       tsumeice = 0.
       tsumfice = 0.
       tsumg1ice = 0.
       tsumg2ice = 0.
       tsummliq = 0.
       tsummfliq = 0.
       tsummice = 0.

       do k=1,nlev_lsm
         dp = Param%cp_air*(phalf_c(k) - phalf_c(k+1))/Param%grav
         esumc  = esumc  + enctf(k)*dp        
         sumn   = sumn   + disn(k)*dp

         tsumcliq = tsumcliq + disc_liq(k)*dp
         tsumdliq = tsumdliq + disg_liq(k)*dp
         tsumeliq = tsumeliq + disl_liq_cd(k)*dp
         tsumfliq = tsumfliq + disl_liq_depo(k)*dp
         tsumg1liq = tsumg1liq + disga_liq_up(k)*dp
         tsumg2liq = tsumg2liq + disga_liq_dn(k)*dp
         tsumcice = tsumcice + disc_ice(k)*dp
         tsumdice = tsumdice + disg_ice(k)*dp
         tsumeice = tsumeice + disl_ice_cd(k)*dp
         tsumfice = tsumfice + disl_ice_depo(k)*dp
         tsumg1ice = tsumg1ice + disga_ice_up(k)*dp
         tsumg2ice = tsumg2ice + disga_ice_dn(k)*dp
         if (.not. lmeso) then
           tsummliq = tsummliq + disg_2liq(k)*dp
           tsummfliq = tsummfliq + disg_2ice(k)*dp
           tsummice = tsummice +  disze3(k)*dp
         endif
          
         tsumj    = tsumj    + ensmbl_freeze(k)*dp
         tsumj1   = tsumj1   + ensmbl_freeze_meso(k)*dp
         tsumk1   = tsumk1   + ensmbl_melt(k)*dp
         tsumk3   = tsumk3   + ensmbl_melt_meso(k)*dp
         tsumk2   = tsumk2 +  anvil_precip_melt(k) *dp
       end do

       if (lmeso) then
         tsumaliq = tsumcliq + tsumdliq + tsumeliq + tsumfliq +  &
                    tsumg1liq + tsumg2liq               
         tsumaice = tsumcice + tsumeice + tsumfice + tsumdice +  &
                    tsumg1ice + tsumg2ice
         liq_ice = tsumj + tsumj1 + tsumk1 + tsumk2 + tsumk3
       else
         tsumaliq = tsumcliq + tsummliq 
         tsumaice = tsumcice + tsummice  + tsummfliq
         liq_ice = tsumj + tsumk1
       endif

       tsuma = tsumaliq + tsumaice + vrt_mot + liq_ice     


       if (debug_ijt) then
        write (diag_unit, '(1(a))')  
        write (diag_unit, '(1(a))')  
        write (diag_unit, '(a, e20.12, a)') &
             'in mulsub: CELL TEMPERATURE FORCING= ', esumc,   &
                                               ' Joules / (m**2 * DAY)'
        write (diag_unit, '(a, e20.12, a)') &
             'in mulsub: CELL TENDENCY LESS FORCING ', sumn - esumc,   &
                                               ' Joules / (m**2 * DAY)'
        write (diag_unit, '(a, e20.12, a)') &
             'in mulsub: TOTAL CELL TEMPERATURE TENDENCY ', sumn,   &
                                               ' Joules / (m**2 * DAY)'
        if (lmeso) then
        write (diag_unit, '(a, e20.12, a)') &
             'in mulsub: TOTAL MESO TEMPERATURE TENDENCY ', &
                                         tsuma - sumn,  &
                                               ' Joules / (m**2 * DAY)'
        endif
        write (diag_unit, '(1(a))')  
        write (diag_unit, '(1(a))')   '***************************'
        write (diag_unit, '(1(a))')  &
            'COLUMN INTEGRAL TEMPERATURE BUDGET TERMS --  &
                                &UNITS OF (Joules / (m**2 * day)'
        write (diag_unit, '(1(a))')   '***************************'
        write (diag_unit, '(1(a))')  
        write (diag_unit, '(1(a,e20.12))')  &
            'TOTAL TEMPERATURE TENDENCY=',tsuma

        if (lmeso) then
        write (diag_unit, '(1(a,e20.12))')  &
            '    DYNAMICAL TENDENCY=', vrt_mot
        write (diag_unit, '(1(a,e20.12))')  &
            '       CELL ENTROPY CONVERGENCE=', tsumb 
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESO ENTROPY CONVERGENCE=', tsumiup + tsumidn
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO UP ENTROPY CONVERGENCE=', tsumiup
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO DOWN ENTROPY CONVERGENCE=', tsumidn
        write (diag_unit, '(1(a,e20.12))')  &
            '    LATENT HEATING: VAPOR/LIQUID=', tsumaliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       CONDENSATION IN CELLS=', tsumcliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       EVAPORATION IN CELLS=', tsumdliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESOSCALE CONDENSATION=', tsumeliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESOSCALE DEPOSITION=', tsumfliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESO EVAPORATION=', tsumg1liq + tsumg2liq
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO EVAPORATION UPDRAFT=', tsumg1liq
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO EVAPORATION DOWNDRAFT=', tsumg2liq
        write (diag_unit, '(1(a,e20.12))')  &
            '    LATENT HEATING: VAPOR/ICE=',tsumaice
        write (diag_unit, '(1(a,e20.12))')  &
            '       CELL CONDENSATION=', tsumcice
        write (diag_unit, '(1(a,e20.12))')  &
            '       CELL UPDRAFT   EVAPORATION=', tsumdice
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESOSCALE CONDENSATION=', tsumeice
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESOSCALE DEPOSITION=', tsumfice
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESOSCALE EVAPORATION=', tsumg1ice + tsumg2ice
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO EVAPORATION IN UPDRAFTS=', tsumg1ice
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO EVAPORATION IN DOWNDRAFTS=', tsumg2ice
        write (diag_unit, '(1(a,e20.12,a))')  &
            '    LATENT HEATING: LIQUID/ICE=', liq_ice
        write (diag_unit, '(1(a,e20.12))')  &
            '       CELL FREEZING',   tsumj      
        write (diag_unit, '(1(a,e20.12))')  &
            '       MESO FREEZING',   tsumj1      
        write (diag_unit, '(1(a,e20.12))')  &
            '       TOTAL MELTING',   tsumk1 + tsumk2 + tsumk3      
        write (diag_unit, '(1(a,e20.12))')  &
            '             CELL MELTING',   tsumk1     
        write (diag_unit, '(1(a,e20.12))')  &
            '             MESO MELTING (FOR CONSRV OF ICE)',   tsumk3 
        write (diag_unit, '(1(a,e20.12))')  &
            '             ANVIL PRECIP MELTING',   tsumk2      
        write (diag_unit, '(1(a))')  
        write (diag_unit, '(1(a))')  



        else ! (lmeso)
        write (diag_unit, '(1(a,e20.12))')  &
            '    DYNAMICAL TENDENCY=', vrt_mot
        write (diag_unit, '(1(a,e20.12))')  &
            '       CONVERGENCE FROM CELL-SCALE MOTIONS=', tsumb 
        write (diag_unit, '(1(a,e20.12))')  &
            '    LATENT HEATING: VAPOR/LIQUID=', tsumaliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       LIQUID CONDENSATION IN CELLS=', tsumcliq
        write (diag_unit, '(1(a,e20.12))')  &
            '       LIQUID EVAPORATION IN CELLS=', tsummliq
        write (diag_unit, '(1(a,e20.12))')  &
            '    LATENT HEATING: VAPOR/ICE=',tsumaice
        write (diag_unit, '(1(a,e20.12))')  &
            '       ICE CONDENSATION IN CELLS=', tsumcice
        write (diag_unit, '(1(a,e20.12))')  &
            '       ICE EVAPORATION IN CELLS=', tsummice
        write (diag_unit, '(1(a,e20.12))')  &
            '       FROZEN LIQUID EVAPORATION IN CELLS=', tsummfliq
        write (diag_unit, '(1(a,e20.12,a))')  &
            '    LATENT HEATING: LIQUID/ICE=', liq_ice
        write (diag_unit, '(1(a,e20.12))')  &
            '       FREEZING IN CELLS',   tsumj      
        write (diag_unit, '(1(a,e20.12))')  &
            '       MELTING IN CELLS',   tsumk1     
        write (diag_unit, '(1(a))')  
        write (diag_unit, '(1(a))')  
        endif   ! (lmeso)

      endif ! (debug_ijt)

   endif ! (do_budget_analysis)

!---------------------------------------------------------------------
!    call subroutine output_diagnostic_profiles to print various 
!    output fields from the donner_deep parameterization in those 
!    columns for which diagnostics have been requested.
!---------------------------------------------------------------------
      if (debug_ijt) then
         call don_d_output_diag_profs_k    &
              (nlev_lsm, diag_unit, pfull_c,  disc_liq, disc_ice,  &
               disb, disd, disn,  &
              encmf, ensmbl_freeze, ensmbl_freeze_meso, &
              temp_tend_melt,  cmus_tot,  &
               emds_liq, emds_ice, &
               emes_liq, emes_ice, wmms, wmps, tmes, mrmes,  &
               eces_liq, eces_ice, ecds_liq, ecds_ice, disa, &
               dise, disg_2liq, disg_2ice, disf, ermesg, error)
      endif

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------


end subroutine don_d_def_conv_forcing_k



!#####################################################################

subroutine don_d_finalize_output_fields_k   &
         (nlev_lsm, ntr, i, j, Param, disb, disc_liq, disc_ice,  &
          ensmbl_freeze, ensmbl_freeze_meso, &
        temp_tend_melt,  tmes, disd, cmus_tot, ecds_liq, ecds_ice, &
         eces_liq, eces_ice, emds_liq, emds_ice, emes_liq, emes_ice, &
          wmms, wmps, mrmes, cutotal, dmeml, detmfl, temptr, uceml, &
          umeml, cuq, cuql_v, qtren, qtmes, wtp, ensmbl_wetc,   &
          Don_conv, ermesg, error)

!----------------------------------------------------------------------
!    subroutine finalize_output_fields stores output variables from 
!    columns with active deep convection into the appropriate elements 
!    of the donner_conv_type variable Don_conv.
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_conv_type 

implicit none

!---------------------------------------------------------------------
integer,                          intent(in)    :: nlev_lsm, ntr
integer,                          intent(in)    :: i, j
type(donner_param_type),          intent(in)    :: Param
real,    dimension(nlev_lsm),     intent(in)    :: disb, disc_liq, disc_ice,   &
                                                   ensmbl_freeze, &
                                                   ensmbl_freeze_meso, &
                                                   temp_tend_melt,  &
                                                   tmes, disd, cmus_tot,&
                                                   emds_liq, emds_ice, &
                                                   ecds_liq, ecds_ice, &
                                                   eces_liq, eces_ice, &
                                                         wmms, wmps,  &
                                                   emes_liq, emes_ice, &
                                                   mrmes, cutotal, &
                                                   dmeml, detmfl, uceml,&
                                                   umeml, cuq, cuql_v
real,    dimension(nlev_lsm,ntr), intent(in)    :: qtren, qtmes, wtp, &
                                                   temptr, ensmbl_wetc
type(donner_conv_type),           intent(inout) :: Don_conv
character(len=*),                 intent(out)   :: ermesg
integer,                          intent(out)   :: error
!---------------------------------------------------------------------
!   intent(in) variables:
!
!       i, j           i, j indices of the current grid column
!       wmms
!       wmps
!       mrmes
!       emds
!       emes
!       ecds
!       eces
!       disd
!       cmus_tot
!       disb
!       disc
!       temp_tend_melt
!       temp_tend_freeze
!       tmes
!       cutotal
!       cuq
!       cuql_v
!       dmeml
!       detmfl
!       uceml
!       umeml
!       exit_flag
!       total_precip
!       meso_precip
!       qtren
!       qtmes
!       wtp
!
!   intent(inout) variables:
!
!       Don_conv       donner_convection_type derived type variable 
!                      containing fields produced by the donner_deep
!                      convection mod 
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer  :: k, kinv    ! do-loop indices

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    if deep convection occurred in this column, save various output
!    fields. if it did not, then these components of the Don_conv
!    derived-type variable will retain their default values.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    save the following arrays as elements of the donner_conv type 
!    variable Don_Conv. make sure all arrays are in mks units, requiring
!    conversion of some arrays from per day to per second, g(h2o) to 
!    kg(h2o) and / or mm to m. reverse the vertical index, making these
!    profile arrays compatible with the large-scale model grid ( index 1
!    nearest upper boundary) rather than the cloud model grid (index 1 
!    nearest sfc).
!---------------------------------------------------------------------
      do k=1,nlev_lsm            
        kinv = nlev_lsm + 1 - k
        Don_conv%ceefc (i,j,kinv)   = disb(k)/Param%seconds_per_day
        Don_conv%cecon (i,j,kinv)   = (disc_liq(k) + disc_ice(k))/Param%seconds_per_day
        Don_conv%tmes  (i,j,kinv)   = tmes(k)/Param%seconds_per_day
        Don_conv%fre   (i,j,kinv)   = (ensmbl_freeze(k) +  &
                                        ensmbl_freeze_meso(k))/  &
                                                 Param%seconds_per_day
        Don_conv%elt   (i,j,kinv)   = temp_tend_melt(k) / &
                                                   Param%seconds_per_day
        Don_conv%cmus  (i,j,kinv)   = cmus_tot(k)/       &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%ecds  (i,j,kinv)   = (ecds_liq(k) + ecds_ice(k))/    &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%eces  (i,j,kinv)   = (eces_liq(k) + eces_ice(k))/    &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%emds  (i,j,kinv)   = (emds_liq(k) + emds_ice(k))/    &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%emes  (i,j,kinv)   = (emes_liq(k) + emes_ice(k))/    &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%mrmes  (i,j,kinv)   = mrmes(k)/          &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%wmps  (i,j,kinv)   = wmps(k)/             &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%wmms  (i,j,kinv)   = wmms(k)/                 &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%cemfc (i,j,kinv)   = disd(k)/                 &
                                           (1.0E03*Param%seconds_per_day)
        Don_conv%cual  (i,j,kinv)   = cutotal(k)
        Don_conv%dmeml (i,j,kinv)   = dmeml(k)
        Don_conv%uceml (i,j,kinv)   = uceml(k)
        if (detmfl(k) <= 1.0e-10) then
          Don_conv%detmfl(i,j,kinv) = 0.
        else
          Don_conv%detmfl(i,j,kinv)   = detmfl(k)
        endif
        Don_conv%umeml (i,j,kinv)   = umeml(k)
        Don_conv%cuqi  (i,j,kinv)   = cuq(k)
        Don_conv%cuql  (i,j,kinv)   = cuql_v(k)
        Don_conv%qtren1(i,j,kinv,:) = qtren(k,:)
        Don_conv%qtmes1(i,j,kinv,:) = qtmes(k,:)
        Don_conv%temptr(i,j,kinv,:) = temptr(k,:)
        Don_conv%wtp1  (i,j,kinv,:) = wtp(k,:)
        Don_conv%wetdepc(i,j,kinv,:)= ensmbl_wetc(k,:)
      end do
        

!--------------------------------------------------------------------


end subroutine don_d_finalize_output_fields_k 



!#####################################################################

!#####################################################################

subroutine don_d_determine_cloud_area_k            &
         (me, nlev_lsm, nlev_hires, diag_unit, debug_ijt, Param,  &
          Initialized, Nml, lofactor, &
          max_depletion_rate, dcape, amax, dise_v, disa_v, pfull_c,  &
          temp_c, mixing_ratio_c, env_t, env_r, parcel_t, parcel_r, &
          cape_p, exit_flag, amos, a1, ermesg, error)

!---------------------------------------------------------------------
!    subroutine determine_cloud_area defines the convective cloud area
!    and so closes the donner_deep parameterization. The arrays 
!    Don_conv%a1 and Don_conv%amos are output by this routine.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_initialized_type
use conv_utilities_k_mod, only : sounding, adicloud 

implicit none

!-----------------------------------------------------------------------
integer,                      intent(in)    :: me, nlev_lsm,     &
                                               nlev_hires, diag_unit
logical,                      intent(in)    :: debug_ijt
type(donner_param_type),      intent(in)    :: Param
type(donner_initialized_type),intent(in)    :: Initialized
type(donner_nml_type),        intent(in)    :: Nml      
real,                         intent(in)    :: max_depletion_rate,   &
                                               lofactor, &
                                               dcape, amax
real, dimension(nlev_lsm),    intent(in)    :: dise_v, disa_v, &
                                               pfull_c, temp_c,  &
                                               mixing_ratio_c 
real, dimension(nlev_hires),  intent(in)    :: env_t, env_r, parcel_t,  &
                                               parcel_r, cape_p
logical,                      intent(inout) :: exit_flag
real,                         intent(out)   :: amos, a1
character(len=*),             intent(out)   :: ermesg
integer,                      intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       diag_unit          unit number for column diagnostics file
!       debug_ijt          column_diagnostics are requested in 
!                          current column  ?
!       max_depletion_rate rate of moisture depletion due to convection
!                          that would result in a column without vapor
!                          [ kg(h2o) / ( kg(air) sec ) ]      
!       dcape              time tendency of cape
!       amax
!       dise_v
!       disa_v
!       pfull_c
!       temp_c 
!       mixing_ratio_c
!       env_t
!       env_r
!       parcel_t
!       parcel_r
!       cape_p
!
!   intent(inout) variables:
!
!       exit_flag
!
!   intent(out) variables:
!
!       amos
!       a1
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:
 
      real, dimension (nlev_lsm)         :: a1_vk              
      real, dimension(nlev_hires)        :: qli0_v, qli1_v, qt_v,  &
                                            qr_v, rl_v, ri_v
      real                               :: qtest, tfint, disbar
      integer                            :: k
!----------------------------------------------------------------------
!   local variables:
!
!         a1_vk
!         qli0      normalized component of cumulus condensate forcing
!         qli1      un-normalized component of condensate forcing
!         qt_v      temperature tendency due to deep convection on
!                   cape grid [ deg K / sec ]
!         qr_v      vapor mixing ratio tendency due to deep convection
!                   on cape grid [ kg(h2o) / ( kg(air) sec ]
!         rl_v      large-scale liquid mixing ratio
!         ri_v      large-scale ice mixing ratio 
!         qtest
!         tfint     column integral of moisture time tendency due to
!                   convection  [ mm / sec , or  kg / (m**2 sec ) ]
!         disbar    water vapor time tendency due to deep convection at 
!                   large-scale model interface levels
!                   [ kg(h2o) / ( kg(air) sec ) ]
!         nlev      number of layers in large-scale model
!         k         do-loop index

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    call map_lo_res_col_to_hi_res_col to interpolate moisture and
!    temperature forcings from large-scale model grid (dise_v, disa_v)
!    to the vertical grid used in the cape calculation (qr_v, qt_v). 
!--------------------------------------------------------------------
      call don_u_lo1d_to_hi1d_k   &
            (nlev_lsm, nlev_hires, disa_v, pfull_c, cape_p, qt_v, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      call don_u_lo1d_to_hi1d_k   &
            (nlev_lsm, nlev_hires, dise_v, pfull_c, cape_p, qr_v, ermesg, error)


!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    if in a diagnostic column, output the temperature and moisture 
!    forcings on both the cape grid (qt_v, qr_v) and the large-scale
!    model grid (disa_v, dise_v).
!--------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_hires
          if (qr_v(k) /= 0.0 .or. qt_v(k) /= 0.0) then 
            write (diag_unit, '(a, i4, e20.12, f20.14)')  &
                     'in cupar: k,qr,qt= ',k, qr_v(k), qt_v(k)
          endif
        end do
        do k=1,nlev_lsm
          if (dise_v(k) /= 0.0 .or. disa_v(k) /= 0.0) then 
            write (diag_unit, '(a, i4, 2e20.12)')  &
                    'in cupar: k,dise,disa= ',k, dise_v(k), disa_v(k)
          endif
        end do
      endif

!--------------------------------------------------------------------
!   define condensate variables on the cape grid (qli0, qli1, rl_v, 
!   ri_v). these variables are not used in the current version of the
!   cumulus closure scheme implemented in subroutine cumulus_closure, 
!   so they are given values of 0.0.
!--------------------------------------------------------------------
      do k=1,nlev_hires
        qli0_v(k) = 0.
        qli1_v(k) = 0.
        rl_v(k)   = 0.
        ri_v(k)   = 0.
      end do

!--------------------------------------------------------------------
!    call subroutine cumulus_closure to determine cloud base cloud
!    fraction and so close the deep-cumulus parameterization.
!--------------------------------------------------------------------
      call cu_clo_cumulus_closure_k   &
           (nlev_hires, diag_unit, debug_ijt, Param, Initialized, &
            Nml, lofactor, dcape, &
            cape_p, qli0_v, qli1_v, qr_v, qt_v, env_r, ri_v, &
            rl_v, parcel_r, env_t, parcel_t, a1, ermesg, error)     

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine. 
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    calculate the vertical integral of normalized moisture forcing 
!    in the column (tfint) in units of kg (h2o) per m**2 per second, or
!    mm (h2o) per second.
!-------------------------------------------------------------------
      tfint = 0.0
      do k=2,nlev_lsm
        disbar = 0.5*(dise_v(k-1) + dise_v(k))
        tfint = tfint - disbar*(pfull_c(k-1) - pfull_c(k))
      end do
      tfint = tfint/Param%grav

!--------------------------------------------------------------------
!    restrict the cloud-base area fraction produced by subroutine
!    cumulus_closure to be no larger than the cloud base area that 
!    results in total grid box coverage at some higher level (amax). 
!--------------------------------------------------------------------
      a1 = MIN (amax, a1)

!---------------------------------------------------------------------
!    set the cloud-base area fraction to be 0.0 if there is no net
!    column integral of moisture forcing in the column. this is 
!    referred to as the moisture constraint. see "Moisture Constraint",
!    8/8/97. set the exit_flag to .true., turning off convection in
!    this column, output a message, and return to calling subprogram.
!---------------------------------------------------------------------
      if (tfint == 0.) then      
        a1 = 0.
        exit_flag      = .true.
        if (debug_ijt) then
          write (diag_unit, '(a)')  &
                 'convection turned off in column because of moist&
                  &ure constraint; cloud area being set to 0.0'
        endif
        return
      endif

!---------------------------------------------------------------------
!    if in a diagnostic column, output the column integral of the 
!    moisture forcing (tfint) and the fractional cloud area (a1) after
!    assuring that moisture forcing is present in the column.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)')  &
                      'in cupar: tfint= ',tfint       
        write (diag_unit, '(a, e20.12)')  &
                      'in cupar: a1_v = ',a1       
      endif

!---------------------------------------------------------------------
!    restrict cloud fractional area by the moisture constraint. this
!    requirement limits the cloud area so that the moisture tendency 
!    due to the deep convection (tfint - which occurs only within the 
!    cloud fractional area) will not remove more vapor from the column 
!    than is available. here amos is the cloud area over which applic-
!    ation of the convective moisture tendency will result in total
!    vapor depletion in the column.
!---------------------------------------------------------------------
      amos = max_depletion_rate/tfint     
      if (a1 > amos)  then    
        a1 = max(amos, 0.)
      endif 

!---------------------------------------------------------------------
!    for any diagnostic columns in the window in which deep convection
!    was possible, output the column integral of the moisture forcing 
!    (tfint), the max cloud area allowed by the moisture constraint 
!    (amos) and the fractional cloud area after applying the moisture
!    constraint (a1).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                   'in cupar: tfint,amos,a1= ',  &
                                       tfint, amos, a1  
      endif

!---------------------------------------------------------------------
!    verify that the current value of a1 will not produce negative
!    value of vapor mixing ratio at any level in the column when the
!    convective moisture tendency is applied. determine the large-scale
!    model mixing ratio for the current value of a1 (qtest). if qtest
!    is negative at any level for this value of a1, reset the value 
!    of a1, so that no negative mixing ratios will be produced.
!--------------------------------------------------------------------
      do k=1,nlev_lsm
        qtest = mixing_ratio_c(k) + a1*Nml%donner_deep_freq*dise_v(k)
        if (qtest < 0.) then
          a1_vk(k) = -mixing_ratio_c(k)/(dise_v(k)*Nml%donner_deep_freq)
        else
          a1_vk(k) = a1     
        endif
      end do

!--------------------------------------------------------------------
!    define the a1 for the column as the smallest of those defined
!    in the column. 
!--------------------------------------------------------------------
      a1 = MINVAL (a1_vk)

!---------------------------------------------------------------------
!    if in a diagnostic column, output the final value of a1, after 
!    all necessary constraints have been applied.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)') 'in cupar: a1= ',a1        
      endif


!--------------------------------------------------------------------


end subroutine don_d_determine_cloud_area_k 





!####################################################################

!######################################################################



!######################################################################

subroutine don_d_remove_normalization_k   &
      (isize, jsize, nlev_lsm, ntr, exit_flag, Don_conv, total_precip, &
       Initialized, &
       temperature_forcing, moisture_forcing, ermesg, error)

!---------------------------------------------------------------------
!    subroutine remove_normalization removes the normalization by the
!    cloud base fractional area from the various convective diagnostics
!    and output fields so that they are ready fro use in the large-scale
!    model equations.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_nml_type, &
                              donner_initialized_type, DET_MASS_FLUX, &
                              MASS_FLUX, CELL_UPWARD_MASS_FLUX, &
                              TEMP_FORCING, MOIST_FORCING, PRECIP, &
                              FREEZING, RADON_TEND

implicit none 

!---------------------------------------------------------------------
integer,                          intent(in)    :: isize, jsize, nlev_lsm, ntr
logical, dimension(isize,jsize),  intent(in)    :: exit_flag
type(donner_conv_type),           intent(inout) :: Don_conv
real   , dimension(isize,jsize),  intent(inout) :: total_precip
type(donner_initialized_type),    intent(inout) :: Initialized
real   , dimension(isize,jsize,nlev_lsm),                 &
                                  intent(inout) :: temperature_forcing, &
                                                   moisture_forcing
character(len=*),                 intent(out)   :: ermesg
integer,                          intent(out)   :: error
!----------------------------------------------------------------------
!   intent(in) variables:
!
!     exit_flag      logical array indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    each model column 
!
!   intent(inout) variables:
!    
!     Don_conv       donner_convection_type derived type variable 
!                    containing fields produced by the donner_deep
!                    convection mod 
!     total_precip   precipitation generated by deep convection
!                    [ kg / m**2 ]
!     moisture_forcing
!                    time tendency of vapor mixing ratio due to deep 
!                    convection [ kg(h2o) / kg(dry air) / sec ]
!     temperature_forcing
!                    time tendency of temperature due to deep 
!                    convection [ deg K / sec ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_lsm) :: variable
      integer :: i, j, k, n    ! do-loop indices

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    remove normalization from the cumulus diagnostics and forcing terms
!    by multiplying them by the fractional cloud base area. these values
!    thus become grid-box averages, rather than averages over the cloudy
!    area, and so are appropriate to use in the large-scale model
!    equations. 
!---------------------------------------------------------------------
      do j=1,jsize                          
        do i=1,isize

!---------------------------------------------------------------------
!    if deep convection is present in the column, denormalize the 
!    convective fields.
!---------------------------------------------------------------------
          if (.not. exit_flag(i,j)) then
            if (Initialized%monitor_output) then
              do n=1, size(Initialized%Don_monitor, 1)
                select case (Initialized%Don_monitor(n)%index)
                  case (DET_MASS_FLUX)
                     variable(:) = Don_conv%detmfl(i,j,:)*   &
                                                       Don_conv%a1(i,j)
                     call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (MASS_FLUX)
                     variable(:) =   &
                      (Don_conv%umeml(i,j,:) + Don_conv%dmeml(i,j,:) + &
                        Don_conv%uceml(i,j,:))*Don_conv%a1(i,j)
                     call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (CELL_UPWARD_MASS_FLUX)
                    variable(:) = Don_conv%uceml(i,j,:)*Don_conv%a1(i,j)
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (TEMP_FORCING)
                    variable(:) =   &
                           temperature_forcing(i,j,:)*Don_conv%a1(i,j)
                     call don_u_process_monitor_k (variable, i, j,  &
                             nlev_lsm, Initialized%Don_monitor(n))
                  case (MOIST_FORCING)
                     variable(:) =   &
                              moisture_forcing(i,j,:)*Don_conv%a1(i,j)
                     call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (PRECIP)
                    variable(:) = total_precip(i,j)*Don_conv%a1(i,j)
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (FREEZING)
                    variable(:) = Don_conv%fre(i,j,:)*Don_conv%a1(i,j)
                    call don_u_process_monitor_k (variable, i, j,  &
                                 nlev_lsm, Initialized%Don_monitor(n))
                end select
             end do
          endif
         total_precip(i,j) =  total_precip(i,j)*Don_conv%a1(i,j)
            Don_conv%ampta1(i,j) =  Don_conv%ampta1(i,j)*Don_conv%a1(i,j)
            Don_conv%cell_precip(i,j) =              &
                             Don_conv%cell_precip (i,j)*Don_conv%a1(i,j)
            Don_conv%meso_precip(i,j) =              &
                             Don_conv%meso_precip (i,j)*Don_conv%a1(i,j)
            Don_conv%emdi_v(i,j) = Don_conv%emdi_v(i,j)*Don_conv%a1(i,j)
            do k=1,nlev_lsm                           
               Don_conv%wetdepc(i,j,k,:) = &
                              Don_conv%wetdepc(i,j,k,:)*Don_conv%a1(i,j)
               Don_conv%wetdept(i,j,k,:) = &
                               Don_conv%wetdepc(i,j,k,:)
              temperature_forcing(i,j,k) =   &
                             temperature_forcing(i,j,k)*Don_conv%a1(i,j)
              Don_conv%ceefc(i,j,k) =   &
                                  Don_conv%ceefc(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cecon(i,j,k) =        &
                                  Don_conv%cecon(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cemfc(i,j,k) =      &
                                  Don_conv%cemfc(i,j,k)*Don_conv%a1(i,j)
              moisture_forcing(i,j,k) =      &
                                moisture_forcing(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cual (i,j,k) =       &
                                   Don_conv%cual(i,j,k)*Don_conv%a1(i,j)
              Don_conv%fre(i,j,k) = Don_conv%fre(i,j,k)*Don_conv%a1(i,j)
              Don_conv%elt(i,j,k) = Don_conv%elt(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cmus(i,j,k) =      &
                                   Don_conv%cmus(i,j,k)*Don_conv%a1(i,j)
              Don_conv%ecds(i,j,k) =      &
                                   Don_conv%ecds(i,j,k)*Don_conv%a1(i,j)
              Don_conv%eces(i,j,k) =      &
                                   Don_conv%eces(i,j,k)*Don_conv%a1(i,j)
              Don_conv%emds(i,j,k) =       &
                                   Don_conv%emds(i,j,k)*Don_conv%a1(i,j)
              Don_conv%emes(i,j,k) =       &
                                   Don_conv%emes(i,j,k)*Don_conv%a1(i,j)
              Don_conv%mrmes(i,j,k) =       &
                                   Don_conv%mrmes(i,j,k)*Don_conv%a1(i,j)
              Don_conv%wmps(i,j,k) =       &
                                   Don_conv%wmps(i,j,k)*Don_conv%a1(i,j)
              Don_conv%wmms(i,j,k) =      &
                                   Don_conv%wmms(i,j,k)*Don_conv%a1(i,j)
              Don_conv%tmes(i,j,k) =      &
                                   Don_conv%tmes(i,j,k)*Don_conv%a1(i,j)
              Don_conv%dmeml(i,j,k) =      &
                                  Don_conv%dmeml(i,j,k)*Don_conv%a1(i,j)
              Don_conv%uceml(i,j,k) =      &
                                  Don_conv%uceml(i,j,k)*Don_conv%a1(i,j)
              Don_conv%detmfl(i,j,k) =      &
                                  Don_conv%detmfl(i,j,k)*Don_conv%a1(i,j)
              Don_conv%umeml(i,j,k) =      &
                                  Don_conv%umeml(i,j,k)*Don_conv%a1(i,j)
              Don_conv%qtren1(i,j,k,:) =     &
                               Don_conv%qtren1(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%qtmes1(i,j,k,:) =     &
                               Don_conv%qtmes1(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%wtp1(i,j,k,:) =       &
                                 Don_conv%wtp1(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%qtceme(i,j,k,:) =   &
                     Don_conv%qtmes1(i,j,k,:) + Don_conv%qtren1(i,j,k,:)
            end do
        if (Initialized%monitor_output) then
              do n=1, size(Initialized%Don_monitor, 1)
                select case (Initialized%Don_monitor(n)%index)
                  case (RADON_TEND)
                    variable(:) = Don_conv%qtceme   &
                         (i,j,:,Initialized%Don_monitor(n)%tracer_index)
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
 
                 end select
               end do
            endif

!---------------------------------------------------------------------
!    if deep convection is not present in the column, define the output
!    fields appropriately.
!---------------------------------------------------------------------
          else
            total_precip(i,j) = 0.
            do k=1,nlev_lsm
              temperature_forcing(i,j,k) = 0.
              moisture_forcing(i,j,k) = 0.
            end do
          endif

        end do
      end do

!---------------------------------------------------------------------


end subroutine don_d_remove_normalization_k



!######################################################################

subroutine don_d_output_cupar_diags_k    &
         (isize, jsize, nlev_lsm, Col_diag, n, exit_flag, &
          total_precip, temperature_forcing, Don_conv, Don_cape, ermesg, error)

!----------------------------------------------------------------------
!----------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_cape_type, &
                             donner_column_diag_type

implicit none

!----------------------------------------------------------------------
integer,                          intent(in)    :: isize, jsize,  &
                                                   nlev_lsm
type(donner_column_diag_type),    intent(in)    :: Col_diag
integer,                          intent(in)    :: n
logical, dimension(isize,jsize),  intent(in)    :: exit_flag
real, dimension (isize,jsize),    intent(in)    :: total_precip
real, dimension (isize,jsize,nlev_lsm),                      &
                                  intent(in)    :: temperature_forcing
type(donner_conv_type),           intent(inout) :: Don_conv
type(donner_cape_type),           intent(inout) :: Don_cape
character(len=*),                 intent(out)   :: ermesg
integer,                          intent(out)   :: error

      integer  :: idiag, jdiag, unitdiag
      integer  :: i,j,k


!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0
      idiag = Col_diag%i_dc(n)
      jdiag = Col_diag%j_dc(n)
      unitdiag = Col_diag%unit_dc(n)

!---------------------------------------------------------------------
!    find any other columns in the current physics window in which deep
!    convection has produced a precipitation rate of over 1 mm/day. 
!    output the precipitation rate and cloud areas for each of these 
!    columns.
!---------------------------------------------------------------------
      do j=1,jsize
        do i=1,isize       
          if (.not. exit_flag(i,j) ) then
            if (Don_conv%cell_precip(i,j) > 1.) then
              write (unitdiag, '(a)')  &
                     ' the following columns in the current physics&
                         & window contain deep convection producing&
                         & rainfall rates of over 1mm per day '
              write (unitdiag, '(a, 2i4, 3e20.12)')  &
                        'in cupar: i,j, precip rate, cloud area, &
                                      &anvil area = ,',  &
                               i, j, Don_conv%cell_precip(i,j),    &
                               Don_conv%a1(i,j), Don_conv%ampta1(i,j)
            endif
          endif
        end do
      end do

!---------------------------------------------------------------------
!    if in a diagnostic window, output convection-related upper tropo-
!    spheric heating rates if there is convective precipitation in any
!    of the diagnostic columns.
!---------------------------------------------------------------------
      if (total_precip(idiag,jdiag) /= 0.) then
        do k=Col_diag%kstart,nlev_lsm
          if ((Don_cape%model_p(idiag,jdiag,k) > 100.e02) .and.&
              (Don_cape%model_p(idiag,jdiag,k) < 500.e02)) then 
            if (temperature_forcing(idiag,jdiag,nlev_lsm-k+1) /= 0.) then
              write (unitdiag, '(a, 3i4, f20.14)')    &
                     'in cupar: j_dc,i_dc,k,t= ',  &
                               jdiag, idiag, k,    &
                                    Don_cape%model_t(idiag,jdiag,k)
              write (unitdiag, '(a, e20.12, i4, 2e20.12)')&
                     'in cupar: tprea1,k,pr,cemetf= ',  &
                            total_precip(idiag,jdiag), k,    &
                            Don_cape%model_p(idiag,jdiag,k),   &
                       temperature_forcing(idiag,jdiag,nlev_lsm-k+1 )
            endif
          endif
        end do
      endif

!----------------------------------------------------------------------
!    if in a diagnostic window, output values of convective and total 
!    precipitation and cloud areas,
!----------------------------------------------------------------------
      if (.not. exit_flag(idiag,jdiag) ) then
        write (unitdiag, '(a, 2e20.12)')  &
                     'in cupar: contot,tpre=', &
                 Don_conv%cell_precip(idiag,jdiag) /  &
                                           (total_precip(idiag,jdiag)),&
                        total_precip(idiag,jdiag)
        write (unitdiag, '(a, 2e20.12)') 'in cupar: a1,ampt =',  &
                         Don_conv%a1 (idiag,jdiag), &
                         Don_conv%ampta1(idiag,jdiag)
        write (unitdiag, '(a, e20.12)')  'in cupar: amax= ', &
                          Don_conv%amax(idiag,jdiag)

!----------------------------------------------------------------------
!    if in a diagnostic window, output values of mesoscale and 
!    cell-scale mass fluxes.
!----------------------------------------------------------------------
        do k=Col_diag%kstart,nlev_lsm
          write (unitdiag, '(a, i4, f19.10, 3e20.12)')  &
                 'in cupar: k,pr,uceml,dmeml,umeml= ',  &
                     k,  Don_cape%model_p(idiag,jdiag,nlev_lsm-k+1),  &
                         Don_conv%uceml(idiag,jdiag,k), &
                         Don_conv%dmeml(idiag,jdiag,k),  &
                         Don_conv%umeml(idiag,jdiag,k)
        end do

!----------------------------------------------------------------------
!    if in a diagnostic window, output values of cloud liquid (cuql).
!    at any levels at which heating associated with the donner deep
!    convection is greater than 0.002 deg K / sec, output heating rate,
!    cloud area, cape, cape tendency, and cloud area.
!----------------------------------------------------------------------
        do k=Col_diag%kstart,nlev_lsm
          write (unitdiag, '(a, i4, e20.12)')  &
                              'in donner_deep: k,cuql', &
                              k,Don_conv%cuql (idiag,jdiag    ,k)
          if (ABS(temperature_forcing(idiag,jdiag,k)) > 0.002) then
            write (unitdiag, '(a, i4, e20.12)')  &
                             'in donner_deep: k, cemetf= ',k,   &
                                 temperature_forcing(idiag,jdiag,k)
            write (unitdiag, '(a, i4, e20.12)')  &
                              'in donner_deep: k, cual= ',k,    &
                                    Don_conv%cual(idiag,jdiag,k )
            write (unitdiag, '(a, i4, e20.12)')  &
                            'in donner_deep: k, xcape= ',k,    &
                                  Don_cape%xcape_lag(idiag,jdiag) 
            write (unitdiag, '(a, i4, e20.12)')   &
                              'in donner_deep: k, dcape = ',k,    &
                                  Don_conv%dcape(idiag,jdiag)
            write (unitdiag, '(a, i4, e20.12)')  &
                              'in donner_deep: k,a1    = ',k,    &
                                  Don_conv%a1 (idiag,jdiag)
            write (unitdiag, '(a, i4, e20.12)')   &
                              'in donner_deep: k, amax  = ',k,   &
                                  Don_conv%amax(idiag,jdiag)
          endif
        end do
      endif   ! (not exit_flag)

!--------------------------------------------------------------------



end subroutine don_d_output_cupar_diags_k



!####################################################################

subroutine don_d_dealloc_loc_vars_k   &
         (Don_conv, Don_cape, Don_rad, Don_cem, Don_budgets, Nml,   &
          Initialized, sd, ac, cp, ct, ermesg, error)

!----------------------------------------------------------------------
!    subroutine don_d_dealloc_loc_vars_k deallocates the
!    local variables found in subroutine donner_deep of donner_deep_mod.
!    these are limited to the pointer components of the donner_conv_type,
!    donner_cape_type, donner_rad_type and donner_cem_type arrays 
!    resident there.
!----------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_cape_type, &
                             donner_rad_type, donner_budgets_type, &
                             donner_cem_type, &
                             donner_nml_type, donner_initialized_type
use  conv_utilities_k_mod,only : adicloud, sounding, ac_end_k, &
                                 sd_end_k
use  conv_plumes_k_mod,only    : cplume, ctend, cp_end_k, ct_end_k

implicit none

!----------------------------------------------------------------------
type(donner_conv_type),         intent(inout) :: Don_conv
type(donner_cape_type),         intent(inout) :: Don_cape
type(donner_rad_type),          intent(inout) :: Don_rad 
type(donner_cem_type),          intent(inout) :: Don_cem
type(donner_budgets_type),      intent(inout) :: Don_budgets
type(donner_nml_type),          intent(inout) :: Nml         
type(donner_initialized_type),  intent(inout) :: Initialized 
type(sounding),                 intent(inout) ::  sd
type(adicloud),                 intent(inout) ::  ac
type(cplume),                   intent(inout) ::  cp
type(ctend),                    intent(inout) ::  ct
character(len=*),               intent(out)   :: ermesg
integer,                        intent(out)   :: error
!----------------------------------------------------------------------
!   intent(inout) variables:
!
!     Don_conv             donner_convection_type derived type variable
!                          containing diagnostics and intermediate
!                          results describing the nature of the convec-
!                          tion produced by the donner parameterization
!     Don_cape             donner_cape type derived type variable con-
!                          taining diagnostics and intermediate results
!                          related to the cape calculation associated
!                          with the donner convection parameterization
!     Don_rad              donner_rad_type derived type variable used
!                          to hold those fields needed to connect the
!                          donner deep convection parameterization and
!                          the model radiation package
!     Don_cem              donner_cem_type derived type variable 
!                          containing Donner cumulus ensemble member 
!                          diagnostics
!
!  intent(out) variables:
! 
!     ermesg               character string containing any error message
!                          to be returned to calling routine
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    initialize the error message string.
!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    deallocate the components of the donner lite derived types.  
!------------------------------------------------------------------
      call sd_end_k(sd)
      call ac_end_k(ac)
      call cp_end_k(cp)
      call ct_end_k(ct)
!----------------------------------------------------------------------
!    deallocate the components of the donner_conv_type variable.
!----------------------------------------------------------------------
      deallocate (Don_conv%conv_temp_forcing    )
      deallocate (Don_conv%conv_moist_forcing   )
      deallocate (Don_conv%ceefc                )
      deallocate (Don_conv%cecon                )
      deallocate (Don_conv%cemfc                )
      deallocate (Don_conv%cememf_mod           )
      deallocate (Don_conv%cual                 )
      deallocate (Don_conv%fre                  )
      deallocate (Don_conv%elt                  )
      deallocate (Don_conv%cmus                 )
      deallocate (Don_conv%ecds                 )
      deallocate (Don_conv%eces                 )
      deallocate (Don_conv%emds                 )
      deallocate (Don_conv%emes                 )
      deallocate (Don_conv%mrmes                )
      deallocate (Don_conv%wmps                 )
      deallocate (Don_conv%wmms                 )
      deallocate (Don_conv%tmes                 )
      deallocate (Don_conv%dmeml                )
      deallocate (Don_conv%uceml                )
      deallocate (Don_conv%detmfl               )
      deallocate (Don_conv%umeml                )
      deallocate (Don_conv%xice                 ) 
      deallocate (Don_conv%xliq                 )
      deallocate (Don_conv%qtren1               )
      deallocate (Don_conv%qtceme               )
      deallocate (Don_conv%qtmes1               )
      deallocate (Don_conv%temptr               )
      deallocate (Don_conv%wtp1                 )
      deallocate (Don_conv%wetdepc              )
      deallocate (Don_conv%wetdepm              )
      deallocate (Don_conv%wetdept              )
      deallocate (Don_conv%dgeice               )
      deallocate (Don_conv%cuqi                 )
      deallocate (Don_conv%cuql                 )
      deallocate (Don_conv%cell_liquid_eff_diam )
      deallocate (Don_conv%cell_ice_geneff_diam )
      deallocate (Don_conv%dcape                )  
      deallocate (Don_conv%a1                   )
      deallocate (Don_conv%amax                 )
      deallocate (Don_conv%amos                 )
      deallocate (Don_conv%ampta1               )
      deallocate (Don_conv%cell_precip          )
      deallocate (Don_conv%meso_precip          )
      deallocate (Don_conv%emdi_v               )
      deallocate (Don_conv%prztm                )
      deallocate (Don_conv%przm                 )
      deallocate (Don_conv%pb_v                 )
      deallocate (Don_conv%pmd_v                )
      deallocate (Don_conv%pztm_v               )
      deallocate (Don_conv%pzm_v                )

!----------------------------------------------------------------------
!    deallocate the components of the donner_cape_type variable.
!----------------------------------------------------------------------
      deallocate (Don_cape%coin       )
      deallocate (Don_cape%plcl       )
      deallocate (Don_cape%plfc       )
      deallocate (Don_cape%plzb       )
      deallocate (Don_cape%xcape      )
      deallocate (Don_cape%xcape_lag  )
      deallocate (Don_cape%parcel_r   )
      deallocate (Don_cape%parcel_t   )
      deallocate (Don_cape%cape_p     )
      deallocate (Don_cape%env_r      )
      deallocate (Don_cape%env_t      )
      deallocate (Don_cape%model_p    )
      deallocate (Don_cape%model_r    )
      deallocate (Don_cape%model_t    )
      deallocate (Don_cape%qint       )     
      deallocate (Don_cape%qint_lag   ) 

!----------------------------------------------------------------------
!    deallocate the components of the donner_rad_type variable.
!----------------------------------------------------------------------
      deallocate (Don_rad%cell_cloud_frac  )
      deallocate (Don_rad%cell_liquid_amt  )
      deallocate (Don_rad%cell_liquid_size )
      deallocate (Don_rad%cell_ice_amt     )
      deallocate (Don_rad%cell_ice_size    )
      deallocate (Don_rad%cell_droplet_number )
      deallocate (Don_rad%meso_cloud_frac  )
      deallocate (Don_rad%meso_liquid_amt  )
      deallocate (Don_rad%meso_liquid_size )
      deallocate (Don_rad%meso_ice_amt     )
      deallocate (Don_rad%meso_ice_size    )
      deallocate (Don_rad%meso_droplet_number )
      deallocate (Don_rad%nsum             )        

   if (Nml%do_ensemble_diagnostics) then
!--------------------------------------------------------------------
!    deallocate the components of the donner_cem_type variable.
!--------------------------------------------------------------------
      deallocate (Don_cem%pfull       )
      deallocate (Don_cem%phalf       )
      deallocate (Don_cem%zfull       )
      deallocate (Don_cem%zhalf       )
      deallocate (Don_cem%temp        )
      deallocate (Don_cem%mixing_ratio )
      deallocate (Don_cem%cell_precip )
      deallocate (Don_cem%meso_precip )
      deallocate (Don_cem%pb          )
      deallocate (Don_cem%ptma        )
      deallocate (Don_cem%h1          )
      deallocate (Don_cem%qlw         )
      deallocate (Don_cem%cfracice    )
      deallocate (Don_cem%wv          )
      deallocate (Don_cem%rcl         )
      deallocate (Don_cem%a1          )
      deallocate (Don_cem%cual        )
      deallocate (Don_cem%temperature_forcing )
   endif

!----------------------------------------------------------------------
!    deallocate the components of the donner_budgets_type variable.
!----------------------------------------------------------------------
      deallocate (Don_budgets%liq_prcp    )
      deallocate (Don_budgets%frz_prcp    )
   if (Initialized%do_conservation_checks .or.    &
                                           Nml%do_budget_analysis) then
      deallocate (Don_budgets%lheat_precip)
      deallocate (Don_budgets%vert_motion )
      deallocate (Don_budgets%water_budget)
      deallocate (Don_budgets%enthalpy_budget)
      deallocate (Don_budgets%precip_budget)
   endif

!----------------------------------------------------------------------


end subroutine don_d_dealloc_loc_vars_k 


!######################################################################

!++lwh
subroutine don_d_check_trc_rlzbility( isize, jsize, nlev_lsm, ntr, dt, &
                                             tracers, Don_conv )
!---------------------------------------------------------------------
!  Check for tracer realizability. If convective tendencies would
!  produce negative tracer mixing ratios, scale down tracer tendency
!  terms uniformly for this tracer throughout convective column. This is
!  equivalent to limiting the cell areas.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type

!---------------------------------------------------------------------
!  Dummy arguments
!---------------------------------------------------------------------
integer,                 intent(in)     :: isize, jsize, nlev_lsm, ntr
real,                    intent(in)     :: dt 
real, dimension(isize,jsize,nlev_lsm,ntr), &
                         intent(in)     :: tracers        
type(donner_conv_type),  intent(inout)  :: Don_conv

!---------------------------------------------------------------------
!   intent(in) variables:
!     tracers        tracer mixing ratios
!                    [ kg(tracer) / kg (dry air) ]
!     isize          x-direction size of the current physics window
!     jsize          y-direction size of the current physics window
!     nlev_lsm       number of model layers in large-scale model
!     dt             physics time step [ sec ]
!
!   intent(inout) variables:
!     Don_conv       donner_convection_type derived type variable
!                    containing diagnostics and intermediate results 
!                    describing the nature of the convection produced by
!                    the donner parameterization
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  Local variables
!---------------------------------------------------------------------

   integer :: i,j,n,k
   real, dimension(nlev_lsm) :: tracer0, trtend, trtendw, tracer1,  &
                                tracer1w
   real :: ratio, tracer_max, tracer_min

!---------------------------------------------------------------------
!   local variables:
!
!     tracers        tracer mixing ratios of tracers transported by the
!                    donner deep convection parameterization
!                    [ tracer units, e.g., kg(tracer) / kg (dry air) ]
!     tracer0        column tracer mixing ratios before convection
!     trtend         column tracer mixing ratio tendencies due to convective transport [ (tracer units) / s ]
!     trtendw        column tracer mixing ratio tendencies due to convective transport + wetdep [ (tracer units) / s ]
!     tracer1        column tracer mixing ratios after convective transport only
!     tracer1w       column tracer mixing ratios after convective transport + wet deposition
!     i, j, k, n     do-loop indices
!     ratio          ratio by which tracer convective tendencies need to 
!                    be reduced to permit realizability (i.e., to prevent
!                    negative tracer mixing ratios)
!
!---------------------------------------------------------------------

   do n = 1,ntr
   do i = 1,isize
   do j = 1,jsize
      
      tracer0(:)  = tracers(i,j,:,n)
      trtend(:)   = Don_conv%qtceme(i,j,:,n)
      trtendw(:)  = trtend(:) + Don_conv%wetdept(i,j,:,n)
      tracer1(:)  = tracer0 + dt * trtend(:)
      tracer1w(:) = tracer0 + dt * trtendw(:)
 
      tracer_min = 1.e20
      tracer_max = -1.e20

      do k = 1,nlev_lsm
         if (trtend(k) /= 0.) then
            tracer_max = max(tracer0(k),tracer_max)
            tracer_min = min(tracer0(k),tracer_min)
         end if
      end do
       
      ratio = 1.
      do k = 1,nlev_lsm
         if (tracer0(k) > 0. .and. tracer1w(k)<0.) then
            ratio = MIN( ratio,tracer0(k)/(-trtendw(k)*dt) )
         end if
         if (tracer1(k)<tracer_min .and. trtend(k) /= 0.0 ) then
           ratio = MIN( ratio,(tracer0(k)-tracer_min)/(-trtend(k)*dt) )
         end if
         if (tracer1(k)>tracer_max  .and. trtend(k) /= 0.0 ) then
            ratio = MIN( ratio,(tracer_max-tracer0(k))/(trtend(k)*dt) )
         end if
      end do
      ratio = MAX(0.,MIN(1.,ratio))
      if (ratio /= 1.) then
         Don_conv%qtceme(i,j,:,n)  = Don_conv%qtceme(i,j,:,n)  * ratio
         Don_conv%qtren1(i,j,:,n)  = Don_conv%qtren1(i,j,:,n)  * ratio
         Don_conv%qtmes1(i,j,:,n)  = Don_conv%qtmes1(i,j,:,n)  * ratio
         Don_conv%wtp1(i,j,:,n)    = Don_conv%wtp1(i,j,:,n)    * ratio
         Don_conv%wetdepc(i,j,:,n) = Don_conv%wetdepc(i,j,:,n) * ratio
         Don_conv%wetdepm(i,j,:,n) = Don_conv%wetdepm(i,j,:,n) * ratio
         Don_conv%wetdept(i,j,:,n) = Don_conv%wetdept(i,j,:,n) * ratio
      end if
   end do
   end do
   end do


end subroutine don_d_check_trc_rlzbility
!--lwh



!VERSION NUMBER:
!   $Id: donner_deep_miz.F90,v 16.0 2008/07/30 22:06:51 fms Exp $

module null_donner_deep_miz
end module  


!VERSION NUMBER:
!   $Id: donner_lite_k.F90,v 18.0.4.4 2010/09/03 22:17:08 wfc Exp $

!######################################################################
!######################################################################


subroutine don_c_def_conv_env_miz    &
         (isize, jsize, nlev_lsm, ntr, dt, Nml, Param, Initialized, &
           Col_diag,  &
          tracers, pblht, tkemiz, qstar, cush, land, coldT,       &!miz
          temp, mixing_ratio, pfull, phalf, zfull, &
          zhalf, lag_cape_temp, lag_cape_vapor, current_displ,   &
          cbmf, Don_cape, Don_conv, sd, Uw_p, ac)

use donner_types_mod,      only : donner_nml_type, donner_param_type, &
                                  donner_column_diag_type,   &
                                  donner_initialized_type, &
                                  donner_cape_type, donner_conv_type
use  conv_utilities_k_mod, only : pack_sd_lsm_k, extend_sd_k,   &
                                  adi_cloud_k, adicloud, sounding, &
                                  uw_params, qt_parcel_k

implicit none

integer,                                    intent(in)    ::   &
                                             isize, jsize, nlev_lsm, ntr
real,                                     intent(in)    :: dt
type(donner_nml_type),                    intent(in)    :: Nml      
type(donner_param_type),                  intent(in)    :: Param
type(donner_initialized_type), intent(in)             :: Initialized
type(donner_column_diag_type), intent(in)    :: Col_diag
real, dimension(isize,jsize,nlev_lsm),    intent(in)    ::    &
                                             temp, mixing_ratio,  &
                                             pfull, zfull,  &
                                             lag_cape_temp,&
                                             lag_cape_vapor
real, dimension(isize,jsize,nlev_lsm,ntr),intent(in)    :: tracers
real, dimension(isize,jsize,nlev_lsm+1),  intent(in)    :: phalf,  &
                                                            zhalf
real, dimension(isize,jsize),             intent(in)    ::   &
                                             current_displ, cbmf, &
                                             pblht, tkemiz, qstar, cush,land
logical, dimension(isize,jsize),          intent(in)    :: coldT
type(donner_cape_type),                   intent(inout) :: Don_cape
type(donner_conv_type),                   intent(inout) :: Don_conv
type(sounding),                           intent(inout) :: sd
type(adicloud),                           intent(inout) :: ac
type(uw_params),                           intent(inout) :: Uw_p

      real, dimension (nlev_lsm) :: mid_cape_temp, mid_cape_vapor
      real, dimension (isize,jsize,nlev_lsm, ntr) :: xgcm_v
      real         :: zsrc, psrc, hlsrc, thcsrc, qctsrc, &
                      lofactor
      integer      :: i, j, k, n

      do n=1,ntr
      do k=1,nlev_lsm
        xgcm_v(:,:,k,n) = tracers(:,:,nlev_lsm-k+1,n)
      end do
      enddo

!--------------------------------------------------------------------
!    if in diagnostics window, write message indicating lag-time cape
!    calculation is being done.
!--------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          write (Col_diag%unit_dc(n), ' (//, a)')  &
         '               CAPE calculation for LAG and MID time profile'
        end do
      endif


      do j=1,jsize
        do i=1,isize
           if (Initialized%using_unified_closure .and.   &
                                          cbmf(i,j) == 0.0) cycle
          if ((current_displ(i,j) .lt. 0) .or.   &
              (.not.Nml%use_llift_criteria)) then
            call pack_sd_lsm_k (Nml%do_lands, land(i,j), coldT(i,j), &
                                dt, pfull(i,j,:), phalf(i,j,:), &
                                zfull(i,j,:), zhalf(i,j,:), &
                                lag_cape_temp(i,j,:),  &
                                lag_cape_vapor(i,j,:),   &
                                xgcm_v(i,j,:,:), sd)
            call extend_sd_k(sd, pblht(i,j), .false., Uw_p)         
            zsrc  =sd%zs (1)
            psrc  =sd%ps (1)
            thcsrc=sd%thc(1)
            qctsrc=sd%qct(1)
            hlsrc =sd%hl (1)
            if (Nml%do_lands) then
               call qt_parcel_k (sd%qs(1), qstar(i,j), pblht(i,j), &
                                 tkemiz(i,j), sd%land, &
                       Nml%gama,Nml%pblht0,Nml%tke0,Nml%lofactor0, &
                                      Nml%lochoice,qctsrc,lofactor)
            end if
            call adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd,  &
                              Uw_p, .false., Nml%do_freezing_for_cape, &
                              ac)                
            zsrc  =sd%zs (1)
            Don_cape%xcape_lag(i,j) = ac%cape
            Don_cape%qint_lag (i,j) = sd%qint
!  additional column diagnostics should be added here
          
            mid_cape_temp (:) = temp(i,j,:)
            mid_cape_vapor(:) = mixing_ratio(i,j,:)
!            mid_cape_vapor(:) = mixing_ratio(i,j,:)/  &
!                                                (1.+mixing_ratio(i,j,:))
        
            do k=nlev_lsm - Nml%model_levels_in_sfcbl + 1, nlev_lsm
              mid_cape_temp (k) = lag_cape_temp(i,j,k)
              mid_cape_vapor(k) = lag_cape_vapor(i,j,k)
            end do
        
            call pack_sd_lsm_k (Nml%do_lands, land(i,j), coldT(i,j), &
                                dt, pfull(i,j,:), phalf(i,j,:),   &
                                zfull(i,j,:), zhalf(i,j,:), &
                                mid_cape_temp(:), mid_cape_vapor(:), &
                                xgcm_v(i,j,:,:), sd)
        
            sd%ql(:)=0.; !max(qlin(i,j,:),0.);
            sd%qi(:)=0.; !max(qiin(i,j,:),0.);

            call extend_sd_k (sd, pblht(i,j), .false., Uw_p)
            zsrc  =sd%zs (1)
            psrc  =sd%ps (1)
            thcsrc=sd%thc(1)
            qctsrc=sd%qct(1)
            hlsrc =sd%hl (1)
            if (Nml%do_lands) then
               call qt_parcel_k (sd%qs(1), qstar(i,j), pblht(i,j), &
                                 tkemiz(i,j), sd%land, &
                       Nml%gama,Nml%pblht0,Nml%tke0,Nml%lofactor0, &
                                      Nml%lochoice,qctsrc,lofactor)
            end if

            call adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, &
                              Uw_p, &
                              .false., Nml%do_freezing_for_cape, ac)
            Don_cape%plfc(i,j) = ac%plfc
            Don_cape%plzb(i,j) = ac%plnb
            Don_cape%plcl(i,j) = ac%plcl
!           Don_cape%parcel_r(i,j,:) = ac%qv(:)
            Don_cape%parcel_r(i,j,:) = ac%qv(:)/(1. - ac%qv(:))
            Don_cape%parcel_t(i,j,:) = ac%t (:)
            Don_cape%coin (i,j) = ac%cin
            Don_cape%xcape(i,j) = ac%cape
            Don_cape%qint (i,j) = sd%qint
!           Don_cape%model_r(i,j,:) = sd%qv(:)
            Don_cape%model_r(i,j,:) = sd%qv(:)/(1. - sd%qv(:))
            Don_cape%model_t(i,j,:) = sd%t (:)
            Don_cape%model_p(i,j,:) = sd%p (:)
!           Don_cape%env_r  (i,j,:) = sd%qv(:)
            Don_cape%env_r  (i,j,:) = sd%qv(:)/ (1. - sd%qv(:))
            Don_cape%env_t  (i,j,:) = sd%t (:)
            Don_cape%cape_p (i,j,:) = sd%p (:)
!  additional column diagnostics should be added here
          endif
        end do
      end do

!----------------------------------------------------------------------


end subroutine don_c_def_conv_env_miz


!######################################################################
!######################################################################


subroutine don_d_integ_cu_ensemble_miz             &
        (nlev_lsm, nlev_hires, ntr, me, diag_unit, debug_ijt, Param,   &
         Col_diag, Nml, Initialized, temp_c, mixing_ratio_c, pfull_c, & 
         phalf_c, pblht, tkemiz, qstar, cush, land, coldT, delt, &
         sd, Uw_p, ac, cp, ct, tracers_c, sfc_sh_flux_c,   &
         sfc_vapor_flux_c, sfc_tracer_flux_c, plzb_c, exit_flag_c, &
         ensmbl_precip, ensmbl_cond, ensmbl_anvil_cond_liq,  &
         ensmbl_anvil_cond_liq_frz, ensmbl_anvil_cond_ice, pb, pt_ens, &
         ampta1, amax, emsm, rlsm, cld_press, ensmbl_melt,  &
         ensmbl_melt_meso,  ensmbl_freeze, ensmbl_freeze_meso, &
         ensmbl_wetc, disb, disc_liq, disc_ice, dism_liq,  &
         dism_liq_frz, dism_liq_remelt, dism_ice, dism_ice_melted, &
         disp_liq, disp_ice, disz, disz_remelt, disp_melted, disze1, &
         disze2, disze3, disd, disv, disg_liq, disg_ice, &
         enctf, encmf, enev, ecds_liq, ecds_ice, eces_liq, &
         eces_ice, ensmbl_cloud_area, cuq, cuql_v, &
         detmfl, uceml, qtren, etsm, lmeso, frz_frac, &
         meso_frz_intg_sum, ermesg, error, melting_in_cloud, &
         i, j, Don_cem)

!----------------------------------------------------------------------
!    subroutine integrate_cumulus_ensemble works on a single model 
!    column. all profile arrays used in this subroutine and below have 
!    index 1 nearest the surface. it first determines the lifting con-
!    densation level (if one exists) of a parcel moving from the 
!    specified parcel_launch_level. if an lcl is found, subroutine 
!    donner_cloud_model_cloud_model is called to determine the behavior
!    of each of kpar cloud ensemble members assumed present in the 
!    column (each ensemble member is assumed to have a different en-
!    trainment rate). if all ensemble members produce deep convection, 
!    the ensemble statistics are produced for use in the large-scale 
!    model; otherwise deep convection is not seen in the large-scale 
!    model in this grid column. if the ensemble will support a mesoscale
!    circulation, its impact on the large-scale model fields is also 
!    determined. upon completion, the appropriate output fields needed 
!    by the large-scale model are returned to the calling routine.
!----------------------------------------------------------------------
use donner_types_mod,     only : donner_initialized_type,   &
                                 donner_param_type, donner_nml_type, &
                                 donner_column_diag_type, donner_cem_type
use  conv_utilities_k_mod,only : qsat_k, exn_k, adi_cloud_k, adicloud, &
                                 sounding, uw_params, qt_parcel_k
use  conv_plumes_k_mod,   only : cumulus_plume_k, cumulus_tend_k, &
                                 cplume, ctend, cpnlist, cwetdep_type

implicit none 

!----------------------------------------------------------------------
integer,                           intent(in)    :: nlev_lsm,    &
                                                    nlev_hires, ntr, &
                                                    me, diag_unit
logical,                           intent(in)    :: debug_ijt
type(donner_param_type),           intent(in)    :: Param
type(donner_column_diag_type),     intent(in)    :: Col_diag
type(donner_nml_type),             intent(in)    :: Nml   
type(donner_initialized_type),     intent(in)    :: Initialized
real,    dimension(nlev_lsm),      intent(in)    :: temp_c,   &
                                                    mixing_ratio_c,   &
                                                    pfull_c
real,    dimension(nlev_lsm+1),    intent(in)    :: phalf_c
real,                              intent(in)    :: pblht, tkemiz,  &
                                                    qstar, cush, land, delt
logical,                           intent(in)    :: coldT
type(sounding),                    intent(inout) :: sd
type(uw_params),                    intent(inout) :: Uw_p
type(adicloud),                    intent(inout) :: ac
type(cplume),                      intent(inout) :: cp
type(ctend),                       intent(inout) :: ct
real,    dimension(nlev_lsm,ntr),  intent(in)    :: tracers_c           
real,                              intent(in)    :: sfc_sh_flux_c,   &
                                                    sfc_vapor_flux_c 
real,    dimension(ntr),           intent(in)    :: sfc_tracer_flux_c 
real,                              intent(in)    :: plzb_c
logical,                           intent(inout) :: exit_flag_c  
real,                              intent(out)   ::  &
                                      ensmbl_precip, ensmbl_cond,&
                                      ensmbl_anvil_cond_liq, &
                                      ensmbl_anvil_cond_liq_frz, &
                                      ensmbl_anvil_cond_ice, &
                                      pb, pt_ens, ampta1, amax
real,    dimension(nlev_lsm),      intent(out)   :: emsm, rlsm,  &
                                                    cld_press 
real,    dimension(nlev_lsm),      intent(out)   ::   &
                                      ensmbl_melt, ensmbl_melt_meso,&
                                      ensmbl_freeze,   &
                                      ensmbl_freeze_meso, disb, disd, &
                                      disv, disc_liq, disc_ice,&
                                      dism_liq, dism_ice,  &
                                      dism_ice_melted, dism_liq_frz, &
                                      dism_liq_remelt, disp_liq,  &
                                      disp_ice,disp_melted, &
                                      disz_remelt, disz, disze1,  &
                                      disze2, disze3, enctf, encmf,&
                                      disg_liq, disg_ice, enev,    &
                                      ecds_liq, ecds_ice,&
                                      eces_liq, eces_ice,&
                                      ensmbl_cloud_area, cuq, cuql_v, &
                                      detmfl, uceml
real,    dimension(nlev_lsm,ntr),  intent(out)   :: qtren, ensmbl_wetc
real,    dimension(nlev_lsm,ntr),intent(out)     :: etsm 
logical,                           intent(out)   :: lmeso       
integer,                           intent(in)    :: i, j
type(donner_cem_type),             intent(inout) :: Don_cem
real   ,                           intent(out)   :: frz_frac
logical,                           intent(out)   :: meso_frz_intg_sum
logical ,                          intent(out)    :: melting_in_cloud

character(len=*),                  intent(out)   :: ermesg
integer,                           intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
! 
!     nlev_lsm       number of model layers in large-scale model
!     nlev_hires     number of model layers in hi-res cloud model
!                    of the donner deep convection parameterization
!     ntr            number of tracers to be transported by donner
!                    convection
!     me             local pe number
!     diag_unit      unit number for column diagnostics output, if 
!                    diagnostics are requested for the current column
!     debug_ijt      logical indicating whether current column requested
!                    column diagnostics
!     Param          donner_param_type variable containingthe parameters
!                    of the donner deep convection parameterization
!     Col_diag       donner_column_diagtype variable containing the
!                    information defining the columns fro which diagnos-
!                    tics are desired.
!     Nml            donner_nml_type variable containing the donner_nml
!                    variables that are needed outsied of donner_deep_mod
!     temp_c         temperature field at model full levels 
!                    index 1 nearest the surface [ deg K ]
!     mixing_ratio_c        vapor mixing ratio at model full levels 
!                    index 1 nearest the surface
!                    [ kg(h2o) / kg(dry air) ]
!     pfull_c         pressure field at large-scale model full levels 
!                    index 1 nearest the surface [ Pa ]
!     phalf_c        pressure field at large-scale model half-levels 
!                    index 1 nearest the surface [ Pa ]
!     tracers_c      tracer fields that are to be transported by donner
!                    convection.  index 1 nearest the surface 
!                    [ kg (tracer) / kg (dry air) ]
!     sfc_sh_flux_c  sensible heat flux across the surface
!                    [ watts / m**2 ]
!     sfc_vapor_flux_c water vapor flux across the surface
!                    [ kg(h2o) / (m**2 sec) ]
!     sfc_tracer_flux_c  
!                    flux across the surface of tracers transported by
!                    donner_deep_mod [ kg(tracer) / (m**2 sec) ]
!     plzb_c         level of zero buoyancy for a parcel lifted from
!                    the parcel_launch_level.  [ Pa ]
!
!   intent(inout) variables:
!
!     exit_flag_c    logical indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    current model column 
!
!     cumulus ensemble member fields (see also donner_types.h):
!
!     --- single level ---
!
!     Don_cem_cell_precip 
!                    area weighted convective precipitation rate
!                    [ mm/day ]
!     Don_cem_pb     pressure at cloud base for ensemble (currently,
!                    all ensemble members have same base) [ Pa ]
!     Don_cem_ptma   pressure at cloud top for ensemble [ Pa ]
!
!     --- lo-res multi-level ---
! 
!     Don_cem_h1     condensation rate profile on lo-res grid
!                    for the current ensemble member
!                    [ ( kg(h2o) ) / ( kg( dry air) sec ) ] 
!
!     --- lo-res multi-level ---
!
!     Don_cem_qlw    profile of cloud water for the current ensemble
!                    member [ kg(h2o) / kg(air) ]
!     Don_cem_cfracice
!                    fraction of condensate that is ice [ fraction ]
!     Don_cem_wv     vertical velocity profile [ m / s ]
!     Don_cem_rcl    cloud radius profile [ m ]
!
!   intent(out) variables:
!    
!     ensmbl_precip      sum of precipitation rate over ensemble members,
!                        # 1 to the current, weighted by the area at 
!                        cloud base of each member
!                        [ mm / day ]
!     ensmbl_cond        sum of condensation rate over ensemble members,
!                        # 1 to the current, weighted by the area at 
!                        cloud base of each member
!                        [ mm / day ]
!     ensmbl_anvil_cond  sum of rate of transfer of condensate from cell 
!                        to anvil over ensemble members, # 1 to the c
!                        current, weighted by the area at cloud base of 
!                        each member [ mm / day ]
!     pb                 pressure at cloud base for ensemble (all ensem-
!                        ble members have same base) [ Pa ]
!     pt_ens             pressure at cloud top for the ensemble (top 
!                        pressure of deepest ensemble member) [ Pa ]
!     ampta1             cloudtop anvil area (assumed to be five times
!                        larger than the sum of the cloud top areas of 
!                        the ensemble members, as in Leary and Houze 
!                        (1980).  [ fraction ]
!     amax               maximum allowable area of cloud base that is
!                        allowed; if cloud base area is larger than 
!                        amax, the cloud fractional area somewhere in
!                        the grid box would be greater than one, which 
!                        is non-physical.
!     emsm               vertical profile on the hi-res grid of vertical
!                        moisture flux convergence, summed over ensemble 
!                        members # 1 to the current, each member's cont-
!                        ribution being weighted by its cloud area at 
!                        level k relative to the cloud base area of 
!                        ensemble member #1  
!                        [ kg (h2o) / ( kg(dry air) sec ) ]
!     rlsm               vertical profile on the hi-res grid of conden-
!                        sation rate, summed over ensemble members # 1 to
!                        the current, each member's contribution being 
!                        weighted by its cloud area at level k relative 
!                        to the cloud base area of ensemble member #1
!                        [ ( kg(h2o) ) / ( kg( dry air) sec ) ] 
!     cld_press          pressures at hi-res model levels [ Pa ]
!     ensmbl_melt        vertical profile on the lo-res grid of ice melt,
!                        both from the cells and any mesoscale circul-
!                        ation, summed over ensemble members # 1 to the 
!                        current, each member's contribution being 
!                        weighted by its cloud area at level k relative !
!                        to the cloud base area of ensemble member #1
!                        [ kg(h2o) / kg (dry air) ]
!     ensmbl_freeze      vertical profile on the lo-res grid of freezing,
!                        both from the cells and any mesoscale circul-
!                        ation, summed over ensemble members # 1 to the 
!                        current, each member's contribution being 
!                        weighted by its cloud area at level k relative !
!                        to the cloud base area of ensemble member #1
!                        [ kg(h2o) / kg (dry air) ]
!     disg               vertical profile on the lo-res grid of the      
!                        latent heat term in the temperature equation
!                        associated with the evaporation of condensate
!                        in the convective downdraft and updraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ deg K / day ] 
!     enev               vertical profile on the lo-res grid of the      
!                        cloud-area-weighted profile of the potential
!                        cloud water evaporation, summed over ensemble 
!                        members # 1 to the current, each member's con-
!                        tribution being weighted by its cloud area at !
!                        level k relative to the cloud base area of 
!                        ensemble member #1.  this amount of water
!                        must be evaporated if it turns out that there is
!                        no mesoscale circulation generated in the 
!                        column.
!                        [ ( kg(h2o) ) / ( kg(dry air) sec ) ] 
!     enctf              vertical profile on the lo-res grid of the entr-
!                        opy forcing, consisting of the sum of the
!                        vertical entropy flux convergence and the latent
!                        heat release, summed over 
!                        ensemble members # 1 to the current, each mem-
!                        ber's contribution being weighted by its cloud 
!                        area at level k relative to the cloud base area
!                        of ensemble member #1
!                        [ deg K / day ]                        
!     encmf              vertical profile on the lo-res grid of the      
!                        moisture forcing, consisting of the sum of the
!                        vertical moisture flux convergence and the cond-
!                        ensation, summed over ensemble members # 1 to 
!                        the current, each member's contribution being 
!                        weighted by its cloud area at level k relative 
!                        to the cloud base area of ensemble member #1
!                        [ ( kg(h2o) ) / ( kg( dry air) day ) ] 
!     disb               vertical profile on the lo-res grid of the      
!                        temperature flux convergence, summed over 
!                        ensemble members # 1 to the current, each mem-
!                        ber's contribution being weighted by its cloud 
!                        area at level k relative to the cloud base area 
!                        of ensemble member #1.  
!                        [ deg K / day ] 
!     disc               vertical profile on the lo-res grid of the      
!                        latent heat term in the temperature equation, 
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ deg K / day ] 
!     disd               vertical profile on the lo-res grid of the      
!                        vertical moisture flux convergence,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        lo-res grid for the current ensemble member 
!                        [  g(h2o) / ( kg(dry air) day ) ]
!     ecds               vertical profile on the lo-res grid of the      
!                        condensate evaporated in convective downdraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ g(h2o) / kg(air) / day ]
!     eces               vertical profile on the lo-res grid of the      
!                        condensate evaporated in convective updraft,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ g(h2o) / kg(air) / day ]
!     ensmbl_cloud_area  total cloud area profile over all ensemble
!                        members on large_scale model grid [ fraction ]
!     cuq                ice water profile on large-scale model grid, 
!                        normalized by ensemble cloud area.
!     cuql_v             liquid water profile on large-scale model grid, 
!                        normalized by ensemble cloud area.
!     uceml              upward mass flux on large_scale model grid     
!                        [ kg (air) / (sec m**2) ]
!     detmfl             detrained mass flux on large-scale model grid
!                        normalized by ensemble cloud area
!                        [ kg (air) / (sec m**2) ]
!     etsm               vertical profile on the hi-res grid of vertical
!                        tracer flux convergence, summed over ensemble 
!                        members # 1 to the current, each member's con-
!                        tribution being weighted by its cloud area at i
!                        level k relative to the cloud base area of 
!                        ensemble member #1 
!                        [ kg (tracer) / ( kg(dry air) sec ) ]
!     qtren              vertical profile on the lo-res grid of the      
!                        vertical tracer flux convergence,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!     ensmbl_wetc        vertical profile on the lo-res grid of the              
!                        tracer wet deposition,
!                        summed over ensemble members # 1 to the current,
!                        each member's contribution being weighted by its
!                        cloud area at level k relative to the cloud base
!                        area of ensemble member #1.  
!                        [ kg(tracer) / ( kg(dry air) sec ) ]
!     lmeso              logical variable; if .false., then it has been
!                        determined that a mesoscale circulation cannot
!                        exist in the current column. final value not
!                        determined until all ensemble members have been
!                        integrated. 
!     ermesg             character string containing any error message
!                        that is returned from a kernel subroutine
!
!---------------------------------------------------------------------

!     cmui             normalized vertical integral of mesoscale-updraft
!                      deposition (kg(H2O)/((m**2) sec)
!     cmus(nlev)       normalized mesoscale-updraft deposition
!                      (kg(H2O)/kg/sec)
!     emds(nlev)       normalized mesoscale-downdraft sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     emei             normalized vertical integral of mesoscale-updraft
!                      sublimation (kg(h2O)/((m**2) sec)
!     emes(nlev)       normalized mesoscale-updraft sublimation
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     disa(nlev)       normalized thermal forcing, cells+meso (K/sec)
!                      (excludes convergence of surface heat flux)
!                      index 1 at ground. Cumulus thermal forcing defined
!                      as in Fig. 3 of Donner (1993, JAS).
!     disb(nlev)       normalized cell entropy-flux convergence (K/sec)
!                      (excludes convergence of surface flux)
!                      index 1 at ground. Entropy-flux convergence divided
!                      by (p0/p)**(rd/cp).
!     disc(nlev)       normalized cell condensation/deposition
!                      (K/sec)
!                      index 1 at ground.
!     disd(nlev)       normalized cell moisture-flux convergence
!                      (excludes convergence of surface moisture flux)
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     dise(nlev)       normalized moisture forcing, cells+meso (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     dmeml(nlev)      mass flux in mesoscale downdraft (kg/((m**2) s))
!                      (normalized by a(1,p_b)) (index 1 at atmosphere
!                      bottom)
!     elt(nlev)        normalized melting (K/sec)
!                      index 1 at ground.
!     fre(nlev)        normalized freezing (K/sec)
!                      index 1 at ground.
!     pb               pressure at base of cumulus updrafts (Pa)
!     pmd              pressure at top of mesoscale downdraft (Pa)
!     pztm             pressure at top of mesoscale updraft (Pa)
!     mrmes(nlev)       normalized mesoscale moisture-flux convergence
!                      (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     qtmes(nlev,ncont)  tracer tendency due to mesoscale tracer-flux
!                        convergence (kg/kg/s) (normalized by a(1,p_b))
!                        index 1 at ground 
!     qtren_v          normalized tracer tendency due to cells...
!                      (lon,lat,vert,tracer index)
!                      Vertical index increases as height increases.
!     sfcq(nlev)       boundary-layer mixing-ratio tendency due to surface
!                      moisture flux (kg(H2O)/kg/sec)
!     sfch(nlev)       boundary-layer heating due to surface heat flux
!                      (K/sec)
!     tmes(nlev)       normalized mesoscale entropy-flux convergence
!                      (K/sec)
!                      Entropy-flux convergence is mesoscale component
!                      of second term in expression for cumulus thermal
!                      forcing in Fig. 3 of Donner (1993, JAS).
!                      index 1 at ground.
!     tpre_v           total normalized precipitation (mm/day)
!     detmfl(nlev)     detrained mass flux from cell updrafts
!                      (normalized by a(1,p_b))
!                      (index 1 near atmosphere bottom)
!                      (kg/((m**2)*s)
!     uceml(nlev)      normalized mass fluxes in cell updrafts
!                      (kg/((m**2)*s) 
!     umeml(nlev)      mass flux in mesoscale updraft (kg/((m**2) s))
!                      (normalized by a(1,p_b)) (index 1 at atmosphere
!                      bottom)
!                      index 1 at ground.
!     wmms(nlev)       normalized mesoscale deposition of water vapor from
!                      cells (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     wmps(nlev)       normalized mesoscale redistribution of water vapor
!                      from cells (kg(H2O)/kg/sec)
!                      index 1 at ground.
!     wtp_v            tracer redistributed by mesoscale processes
!                      (kg/kg/s) (normalized by a(1,p_b))
!                      vertical index increases with increasing height
!                      (lon,lat,vert,tracer index)
!--------------------------------------------------------------------


!!  UNITS
!!    ucemh  [kg /sec / m**2 ]
!!    detmfh [kg /sec / m**2 ]
!!    conint [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    precip [ kg / sec ] ===> [ kg / sec / m**2 ]
!!    q1     [ kg(h2o) / kg(air) / sec ]
!!    h1     [ kg(h2o) / kg(air) / sec ]
!!    cmf    [ g(h2o) / kg(air) /day ]
!!    rlh    [ kg(h2o) / kg(air) / day ]  * [ L / Cp ] = [ deg K / day ]
!!    h1_2   [ deg K / sec ]
!!    efc    [ deg K / day ]
!!    efchr  [ deg K / sec ]
!!    ehfh   [ kg(air) (deg K) / (sec**3 m)
!!    ctf    [ deg K / day ]
!!    disb_v [ deg K / day ]
!!    disc_v [ deg K / day ] 
!!    disn   [ deg K / day ] 
!!    ecd    [ g(h2o) / kg(air) / day ]
!!    ece    [ g(h2o) / kg(air) / day ]
!!    ecds_v [ g(h2o) / kg(air) / day ]
!!    eces_v [ g(h2o) / kg(air) / day ]
!!    pf     [ (m**2 kg(h2o)) / (kg(air) sec) ]
!!    dpf    [ (m**2 kg(h2o)) / (kg(air) sec) ] ==>   
!!                                          [ kg(h2o)) / (kg(air) sec) ]
!!    qlw2   [ kg(h2o)) / (kg(air) sec) ]
!!    qlw    [ kg(h2o)) / kg(air) ]
!!    evap   [ kg(h2o)) / kg(air) ]
!!    evap_rate [ kg(h2o)) / (kg(air) sec) ]




!        cape     convective available potential energy (J/kg)
!        cin      convective inhibtion (J/kg)
!        cpd      specific heat of dry air at constant pressure (J/(kg K))
!        cpv      specific heat of water vapor [J/(kg K)]
!        dcape    local rate of CAPE change by all processes
!                 other than deep convection [J/(kg s)]
!        dqls     local rate of change in column-integrated vapor
!                 by all processes other than deep convection
!                 {kg(H2O)/[(m**2) s]}
!        epsilo   ratio of molecular weights of water vapor to dry air
!        gravm    gravity constant [m/(s**2)]
!        ilon     longitude index
!        jlat     latitude index
!        mcu      frequency (in time steps) of deep cumulus
!        current_displ  integrated low-level displacement (Pa)
!        cape_p   pressure at Cape.F resolution (Pa)
!                 Index 1 at bottom of model.
!        plfc     pressure at level of free convection (Pa)
!        plzb_c   pressure at level of zero buoyancy (Pa)
!        pr       pressure at Skyhi vertical resolution (Pa)
!                 Index 1 nearest ground  
!        q        large-scale vapor mixing ratio at Skyhi vertical resolution
!                 [kg(h2O)/kg]
!                 Index 1 nearest ground 
!        qlsd     column-integrated vapor divided by timestep for cumulus
!                 parameterization {kg(H2O)/[(m**2) s]}
!        r        large-scale vapor mixing ratio at Cape.F resolution
!                 [kg(h2O)/kg]
!                 Index 1 at bottom of model.
!        rpc      parcel vapor mixing ratio from Cape.F [kg(h2O)/kg]
!                 Index 1 at bottom of model.
!        rd       gas constant for dry air (J/(kg K))
!        rlat     latent heat of vaporization (J/kg)
!        rv       gas constant for water vapor (J/(kg K))
!        t        large-scale temperature at Skyhi vertical resolution (K)
!                 Index 1 nearest ground
!        tcape    large-scale temperature at Cape.F resolution (K)
!                 Index 1 at bottom of model.
!        tpc      parcel temperature from from Cape.F (K)
!                 Index 1 at bottom of model.
!

!----------------------------------------------------------------------
!   local variables:

      real,    dimension (nlev_hires)     ::                &
              alp, ucemh, cuql, cuqli, detmfh, tcc

      real,    dimension (nlev_lsm)       ::           &
              q1, cmf, cell_freeze, cell_melt, &
              h1_liq, h1_ice, meso_melt, meso_freeze, h1_2, &
              evap_rate, ecd, ecd_liq, ecd_ice, ece, ece_liq, ece_ice
      real,   dimension (nlev_lsm) :: rcl_miz, dpf_miz, qlw_miz,  &
                                      dfr_miz, flux_miz, efchr_miz, &
                                      emfhr_miz, cfracice_miz, alp_miz,&
                                      cuql_miz, &
                                      cuqli_miz, ucemh_miz, detmfh_miz,&
                                      rlsm_miz, emsm_miz, qvfm_miz,&
                                      qvfm_tot
      real,   dimension (nlev_lsm,ntr) :: etsm_miz, etfhr_miz, dpftr_miz

      real    :: dint_miz, cu_miz, cell_precip_miz,              &
                 apt_miz
      real    :: wt_factor
      integer :: krel, ncc_kou_miz
      real,    dimension (nlev_lsm,ntr)   :: qtr
      real,    dimension (Param%kpar)     :: ptma_miz
      integer, dimension (Param%kpar)     :: ncca

      logical ::   lcl_reached                  
      integer ::   ncc_ens
      integer ::   k,    kou, n
      integer   :: kk
      real    ::   al, dp, mrb, summel, &
                   dmela, ca_liq, ca_ice, &
                   tb, alpp, pcsave, ensmbl_cld_top_area

      real    :: qs, tp, qp, pp, chi, rhtmp, frac0, lofactor !miz
      real    ::   meso_frac, precip_frac
     real    ::            frz_frac_non_precip
     real    ::        bak
     real   ::                meso_frz_frac
     logical   :: meso_frz_intg               
     real :: pmelt_lsm,                 precip_melt_frac
      real :: ecei_liq
      real   :: ci_liq_cond, ci_ice_cond
     real :: local_frz_frac

      real            :: zsrc, psrc, hlsrc, thcsrc, qctsrc
      real            :: rkm, cbmf, wrel, scaleh
      real, dimension (nlev_lsm  ) ::  dpf_warm, dpf_cold
      type(cpnlist)   :: cpn

!----------------------------------------------------------------------
!   local variables:
!
!      ensmbl_cld_top_area  
!                       sum of the cloud top areas over ensemble members 
!                       # 1 to the current, normalized by the cloud base
!                       area of ensemble member # 1 [ dimensionless ]
!
!----------------------------------------------------------------------

      ermesg = ' ' ; error = 0
!---------------------------------------------------------------------
!    if in diagnostics column, output the large-scale model temperature,
!    vapor mixing ratio and full-level pressure profiles (index 1 near-
!    est the surface).
!---------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_lsm-Col_diag%kstart+1
          write (diag_unit, '(a, i4, f20.14, e20.12, f19.10)')&
                 'in mulsub: k,T,Q,P= ',k, temp_c(k),  &
                                       mixing_ratio_c(k),pfull_c(k)
        end do
      endif

!!$!--------------------------------------------------------------------
!!$!    call don_cm_lcl_k to calculate the temperature (tb), a
!!$!    pressure (pb) and mixing ratio (mrb) at the lifting condensation 
!!$!    level for a parcel starting from the parcel_launch_level. if a sat-
!!$!    isfactory lcl is not reached for this parcel, the logical variable 
!!$!    lcl_reached will be set to .false..
!!$!--------------------------------------------------------------------
!!$      call don_cm_lcl_k    &
!!$           (Param, temp_c (Nml%parcel_launch_level),    &
!!$            pfull_c       (Nml%parcel_launch_level),    &
!!$            mixing_ratio_c(Nml%parcel_launch_level),   &
!!$            tb, pb, mrb, lcl_reached, ermesg)     
!!$      if (trim(ermesg) /= ' ') return

!miz
      tp=temp_c(Nml%parcel_launch_level)
      qp=mixing_ratio_c(Nml%parcel_launch_level)/  &
                           (1.+mixing_ratio_c(Nml%parcel_launch_level))
      pp=pfull_c(Nml%parcel_launch_level)
      qs=qsat_k(tp, pp,Uw_p)
      rhtmp=min(qp/qs,1.)
      chi=tp/(1669.0-122.0*rhtmp-tp)
      pb =pp*(rhtmp**chi); !Emanuel's calculation, results nearly identical to RAS
      mrb=mixing_ratio_c(Nml%parcel_launch_level)
      tb =tp/exn_k(pp,Uw_p)*exn_k(pb,Uw_p)
!miz

!--------------------------------------------------------------------
!    if an acceptable lcl was not reached, set exit_flag_c so that the
!    remaining computations for this column are bypassed, and return to
!    calling routine. 
!--------------------------------------------------------------------
      if (pb > 50000.) then
         lcl_reached=.true.
      else
         lcl_reached=.false.
      end if

!--------------------------------------------------------------------
!    if in diagnostics column and an lcl was defined, output the lcl 
!    temperature, pressure and mixing ratio. if an acceptble lcl was 
!    not reached, print a message.
!--------------------------------------------------------------------
      if (debug_ijt) then
        if (lcl_reached) then
          write (diag_unit, '(a, f20.14, f19.10, e20.12)') &
                                 'in mulsub: tb,pb,qb= ',tb, pb, mrb
        else
          write (diag_unit, '(a)') 'in mulsub: lcl not reached'
        endif
      endif

      if (.not. lcl_reached) then
         exit_flag_c = .true.
         return
      endif

!---------------------------------------------------------------------
!    initialize variables which will accumulate scalar sums over all 
!    ensemble members.
!---------------------------------------------------------------------
      ensmbl_precip       = 0.
      ensmbl_cond         = 0.
      ensmbl_anvil_cond_liq   = 0.
      ensmbl_anvil_cond_liq_frz   = 0.
      ensmbl_anvil_cond_ice   = 0.
      ensmbl_cld_top_area = 0.

!---------------------------------------------------------------------
!    initialize the variables which will contain the sum over the 
!    ensemble members of the vertical profiles of various quantities 
!    on the cloud-model grid.
!---------------------------------------------------------------------
      do k=1,nlev_hires
        cuql(k)   = 0.
        cuqli(k)  = 0.
        ucemh(k)  = 0.
        detmfh(k) = 0.
        alp(k)    = 0.
      end do

      do k=1,nlev_lsm
         rlsm(k)   = 0.
         emsm(k)   = 0.
      end do
      do n=1,ntr
      do k=1,nlev_lsm
         etsm(k,n) = 0.
      end do
      end do


!---------------------------------------------------------------------
!    initialize the variables which will contain the sum over the 
!    ensemble members of the vertical profiles of various quantities 
!    on the large-scale model grid.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        ensmbl_freeze(k)    = 0.
        ensmbl_freeze_meso(k)    = 0.
        ensmbl_melt(k)    = 0.
        ensmbl_melt_meso(k)    = 0.
        disb(k)    = 0.
        disc_liq(k) = 0.
        disc_ice(k) = 0.
        dism_liq(k) = 0.
        dism_liq_frz(k) = 0.
        dism_liq_remelt(k) = 0.
        dism_ice(k) = 0.
        dism_ice_melted(k) = 0.
        disp_liq(k) = 0.
        disp_ice(k) = 0.
        disp_melted(k) = 0.       
        disd(k)    = 0.
        disv(k)    = 0.
        disz(k) = 0.
        disz_remelt(k) = 0.
        disze1(k) = 0.
        disze2(k) = 0.
        disze3(k) = 0.
        ecds_liq(k)    = 0.
        ecds_ice(k)    = 0.
        eces_liq(k)    = 0.
        eces_ice(k)    = 0.
        enctf(k)   = 0.
        encmf(k)   = 0.
        disg_liq(k)    = 0.
        disg_ice(k)    = 0.
        enev(k)    = 0.
      end do
      do n=1,ntr
      do k=1,nlev_lsm
        qtren(k,n) = 0.
        ensmbl_wetc(k,n) = 0.
      end do
      end do

      alp_miz   = 0.
      cuql_miz  = 0.
      cuqli_miz = 0. 
      ucemh_miz = 0.
      detmfh_miz= 0.
      rlsm_miz  = 0.
      emsm_miz  = 0.
      qvfm_miz  = 0.
      qvfm_tot  = 0.
      etsm_miz  = 0.
      etfhr_miz = 0.
      dpftr_miz = 0.
      ptma_miz  = 200000.
      ncca      = 0.

      ensmbl_cloud_area = 0.
      cuq               = 0.
      cuql_v            = 0.
      uceml             = 0.
      detmfl            = 0.

      ece=0.
      ecd=0.
      evap_rate = 0.
      ampta1 = 0.

      if (Nml%allow_mesoscale_circulation) then
        lmeso = .true.
      else
        lmeso = .false.
      endif

!!$      do k=1,nlev_hires
!!$        cld_press(k) = pb + (k-1)*Param%dp_of_cloud_model
!!$      end do

      pcsave = phalf_c(1)

      k=Nml%parcel_launch_level
      zsrc  =sd%zs (k)
      psrc  =sd%ps (k)
      thcsrc=sd%thc(k)
      qctsrc=sd%qct(k)
      hlsrc =sd%hl (k)
      frac0 = Nml%frac
      if (Nml%do_lands) then
         !frac0 = Nml%frac * ( 1.- 0.5 * sd%land) 
         !frac0 = Nml%frac * ( Nml%pblht0 / max(pblht,  Nml%pblht0))
         !frac0 = Nml%frac * ( Nml%tke0   / max(tkemiz, Nml%tke0  ))
         call qt_parcel_k (sd%qs(k), qstar, pblht, tkemiz, sd%land, &
              Nml%gama, Nml%pblht0, Nml%tke0, Nml%lofactor0, Nml%lochoice, qctsrc, lofactor)          
         frac0 = Nml%frac * lofactor
      endif
      call adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd,   &
                        Uw_p, &
                        .false., Nml%do_freezing_for_cape, ac)

       meso_frz_intg_sum = .false.
!--------------------------------------------------------------------
!    loop over the KPAR members of the cumulus ensemble.
!--------------------------------------------------------------------
      do kou=1,Param%kpar

        meso_frz_intg     = .false.
        if (trim(Nml%entrainment_constant_source) == 'gate') then
          alpp = Param%max_entrainment_constant_gate/  &
                           Param%ensemble_entrain_factors_gate(kou)
        else if (trim(Nml%entrainment_constant_source) == 'kep') then
          alpp = Param%max_entrainment_constant_kep/  &
                           Param%ensemble_entrain_factors_kep(kou)
        else
          ermesg = 'invalid entrainment_constant_source'
          error = 1
          return
        endif

         if (debug_ijt) then
           write (diag_unit, '(a)')    &
                     'in mulsub: phalf, temp= :'
           do k=1,nlev_lsm
           write (diag_unit, '(i4, 2f19.10)')    &
                       k, phalf_c(k), temp_c(k)
           end do
        endif
 
        pmelt_lsm = 2.0e05
        do k=1,nlev_lsm-1
         if ((temp_c(k) >= Param%KELVIN) .and.    &
            (temp_c(k+1) <= Param%KELVIN)) then
           pmelt_lsm = phalf_c(k+1)
           exit
        endif
      end do
 
     if (debug_ijt) then
         write (diag_unit, '(a, 2f19.10)')    &
           'before cm_cloud_model call pb,  pmelt_lsm    = ', &
                                   pb, pmelt_lsm
     endif

!!$!test donner_plumes
!!$        call don_cm_cloud_model_k   &
!!$             (nlev_lsm, nlev_hires, ntr, kou, diag_unit, debug_ijt,   &
!!$              Param, Col_diag, tb, pb, alpp, cld_press, temp_c,   &
!!$              mixing_ratio_c, pfull_c, phalf_c, tracers_c, pcsave,  &
!!$              exit_flag_c, rcl, dpf, qlw, dfr, flux, ptma(kou), &
!!$              dint, cu, cell_precip, dints, apt, cell_melt, efchr, &
!!$              emfhr, cfracice, etfhr, ncc_kou, tcc, wv, ermesg) !miz
!!$        if (trim(ermesg) /= ' ') return
!!$        if (exit_flag_c) return
!!$
!!$!---------------------------------------------------------------------
!!$!    define the cloud water from this ensemble member which must be 
!!$!    evaporated if it turns out that there is no mesoscale circulation 
!!$!    associated with the ensemble.
!!$!---------------------------------------------------------------------
!!$        cld_evap(:) = -dpf(:)*(1. - (cell_precip/cu))
!!$        ptt = ptma(kou) + Param%dp_of_cloud_model
!!$        call don_d_def_lores_model_profs_k        &
!!$             (nlev_lsm, nlev_hires, ntr, ncc_kou, diag_unit, debug_ijt, &
!!$              Param, pb, ptt, sfc_vapor_flux_c, sfc_sh_flux_c,  &
!!$              sfc_tracer_flux_c, pfull_c, phalf_c, cld_press, dpf, dfr, &
!!$              cld_evap, qlw, emfhr, efchr, etfhr, cell_freeze,     &
!!$              evap_rate, h1, h1_2, q1, qtr, ermesg)
!!$        if (trim(ermesg) /= ' ') return
!!$
!!$        call don_d_add_to_ensmbl_sum_lores_k    &
!!$             (nlev_lsm, ntr, diag_unit, debug_ijt, lmeso, Param,   &
!!$              Param%arat(kou), dint, cell_freeze, cell_melt, temp_c,   &
!!$              h1_2, ecd, ece, evap_rate, q1, h1, pfull_c, meso_melt, &
!!$              meso_freeze, phalf_c, qtr, ensmbl_melt, ensmbl_freeze, &
!!$              enctf, encmf, enev, disg, disb, disc, ecds, eces, disd, &
!!$              qtren, ermesg)
!!$!test donner_plumes


       tcc = 0.
       dmela = 0.

!begin: testing unified plume
!!! SHOULD ADD SOME COLUMN DIAGNOSTICS WITHIN THIS CODE SEGMENT
        cpn % rle       = 0.1
        cpn % rpen      = 5
        cpn % rmaxfrac  = 5000000000000000.
        cpn % wmin      = 0.0 
        cpn % rbuoy     = 2./3.
        cpn % rdrag     = 3.0
        cpn % frac_drs  = 1.0
        cpn % bigc      = 0.7
        cpn % tcrit     = -45
        cpn % cldhgt_max= 40.e3
        cpn % auto_th0  = Nml%auto_th
        cpn % auto_rate = Nml%auto_rate
        cpn % atopevap  = Nml%atopevap
        cpn % do_ice    = Nml%do_ice
        cpn % do_ppen   = .false.
!!5 miz replaces do_edplume with mixing_assumption
        cpn % mixing_assumption = 1
!       cpn % do_edplume = .false.
!       cpn % do_edplume= .false.
!       cpn % do_micro  = .true.
        cpn % mp_choice = 0
        cpn % do_forcedlifting  = .true.
        cpn % wtwmin_ratio = Nml%wmin_ratio*Nml%wmin_ratio
! Values for cpn for the following variables are not actually used in the donner_lite routine but 
! they should be initialized in order to pass debug tests where NaNs are trapped.
        cpn % rad_crit        = 14
        cpn % deltaqc0        = 0.0005
        cpn % emfrac_max      = 1
        cpn % wrel_min        = 1
        cpn % Nl_land         = 300000000
        cpn % Nl_ocean        = 100000000
        cpn % r_thresh        = 1.2e-05
        cpn % qi_thresh       = 0.0001
        cpn % peff            = 1
        cpn % rh0             = 0.8
        cpn % cfrac           = 0.05
        cpn % hcevap          = 0.8
        cpn % weffect         = 0.5
        cpn % t00             = 295

        cp%maxcldfrac =  cpn%rmaxfrac

        if (ntr>0) then
           allocate(cpn%wetdep(ntr))
           call don_d_copy_wetdep_miz (Initialized%wetdep(:), &
                                       cpn%wetdep(:), &
                                       size(Initialized%wetdep(:)) )
        endif

        rkm = 2.*alpp*frac0; scaleh = 1000.; wrel = 0.5
        if(ac % plcl .gt. sd % pinv)then
           krel    = sd % kinv
        else
           krel    = ac % klcl
        endif
        cbmf  =sd%rho(krel-1)*(Param%cloud_base_radius**2)*wrel
        call cumulus_plume_k     &
               (cpn, sd, ac, cp, rkm, cbmf, wrel, scaleh, Uw_p, error, ermesg)
        call cumulus_tend_k   &
                (cpn, sd, Uw_p, cp, ct, .true.)

        if (ntr>0) then
           deallocate(cpn%wetdep)
        end if

        if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
           exit_flag_c = .true.
           return
        end if

        rcl_miz  (:)=sqrt(cp%ufrc(:))
        dpf_miz  (:)=(ct%qldiv(:)+ct%qidiv(:))/  &
                                          (Param%cloud_base_radius**2)
        dpf_warm (:)=(ct%qldiv(:))/  &
                                          (Param%cloud_base_radius**2)
        dpf_cold (:)=(ct%qidiv(:))/  &
                                          (Param%cloud_base_radius**2)

!BUGFIX 10/27/07
!       qlw_miz  (:)=cp%qlu(:) + cp%qiu(:)
        qlw_miz  (:)=cp%qlu(1:) + cp%qiu(1:)
        dfr_miz  (:)=0. !ct%qidiv (:)/(Param%cloud_base_radius**2)
!BUGFIX 10/27/07
!       flux_miz (:)=cp%umf
        flux_miz (:)=cp%umf(1:)
        efchr_miz(:)=ct%thcten(:)/(Param%cloud_base_radius**2)
        emfhr_miz(:)=ct%qvdiv (:)/(Param%cloud_base_radius**2)
!++++yim
        etfhr_miz   = ct%trten(:,:)/(Param%cloud_base_radius**2)
        dpftr_miz   = ct%trwet(:,:)/(Param%cloud_base_radius**2)

        ptma_miz (kou) = cp%ps(cp%ltop-1)
        dint_miz       = 0.
        cu_miz         = -(ct%conint+ct%freint)/  &
                               (Param%cloud_base_radius**2)*86400.
        cell_precip_miz=(ct%rain+ct%snow)/  &
                               (Param%cloud_base_radius**2)*86400.
        apt_miz        = rcl_miz(cp%ltop-1)/rcl_miz(krel-1)

        if (cu_miz == 0.0 .or. cell_precip_miz == 0.0) then
          exit_flag_c = .true.
          return
        end if

       summel = 0.
        do k=1,nlev_lsm
          dp = phalf_c(k) - phalf_c(k+1)
          summel = summel + (-1.0*dpf_cold(k))*dp/Param%grav
        end do
        if (debug_ijt) then
           write (diag_unit, '(a, f19.10)')    &
          'in mulsub: summel= ', summel
        endif
          
      if (pb > pmelt_lsm) then
          dmela = - ((summel*cell_precip_miz/cu_miz)*  &
                                Param%grav/(pmelt_lsm - pb))*8.64e07
          if (debug_ijt) then
           write (diag_unit, '(a, 3f19.10)')    &
                      'in mulsub: dmela, pmelt_lsm, pb= ', dmela , &
                                                pmelt_lsm, pb
          endif
            
        call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, dmela, pb, pmelt_lsm, phalf_c, cell_melt, ermesg, error)

          if (debug_ijt) then
            do k=1,nlev_lsm
              if (cell_melt(k) /= 0.0) then
                write (diag_unit, '(a, i4,  f19.10)')    &
                      'in mulsub: k, cell_melt= ', k, cell_melt(k)
              endif
            end do
          endif
    else
        cell_melt      = 0.
     endif

        where (qlw_miz(:) == 0.0)
          cfracice_miz   = 0.
        elsewhere
!BUGFIX 10/27/07
!         cfracice_miz(:) = cp%qiu(:)/qlw_miz(:)
          cfracice_miz(:) = cp%qiu(1:)/qlw_miz(:)
        end where
        ncc_kou_miz    = cp%ltop + 1

        cell_freeze= dfr_miz

        if (Nml%do_donner_lscloud) then
          if (cu_miz > 0.0) then
            evap_rate  =-dpf_miz*(1. - (cell_precip_miz/cu_miz))
          else
            evap_rate = 0.0
          endif
        else
           ecd        =ct%qlten/(Param%cloud_base_radius**2)
           ece        =ct%qiten/(Param%cloud_base_radius**2)
           evap_rate  =ct%qaten/(Param%cloud_base_radius**2)
           meso_melt  =ct%tten /(Param%cloud_base_radius**2)
           meso_freeze=ct%qvten/(Param%cloud_base_radius**2) 
        end if

!100 DEDFINE h1_liq, h1_ice
        h1_liq = -dpf_warm
        h1_ice = -dpf_cold
        h1_2       = efchr_miz
        q1         = emfhr_miz
        qtr        = 0.

!end: testing unified plume

    if (Nml%do_ensemble_diagnostics) then
!----------------------------------------------------------------------
!    save "Don_cem" diagnostics for this ensemble member.
!----------------------------------------------------------------------
       Don_cem%cell_precip(i,j,kou) = cell_precip_miz
       Don_cem%pb(i,j,kou) = pb
       Don_cem%ptma(i,j,kou) = ptma_miz(kou)
!  reverse index order
       do k=1,nlev_lsm
         Don_cem%h1(i,j,k,kou) = h1_liq(nlev_lsm-k + 1) +  &
                             h1_ice(nlev_lsm-k + 1)
         Don_cem%qlw(i,j,k,kou) = qlw_miz(nlev_lsm-k+1)
         Don_cem%cfracice(i,j,k,kou) = cfracice_miz(nlev_lsm-k+1)
         Don_cem%wv(i,j,k,kou) = cp%wu(nlev_lsm-k+1)
         Don_cem%rcl(i,j,k,kou) = rcl_miz(nlev_lsm-k+1)
       end do
    endif

!!!  BUGFIX: applies only when allow_mesoscale_circulation is set to
!!!         .false.; in such cases, bug turned off cell melting.
! Will change answers in runs with allow_mesoscale_circulation = .false.
        if (lmeso) then
         if ((pb - ptma_miz(kou)) < Param%pdeep_mc)  then
           lmeso = .false.
         endif
        endif

!----------------------------------------------------------------------
!    if in diagnostics column, output the cloud base (pb) and cloud top
!    (ptma) pressures, and the mesoscale circulation logical variable
!    (lmeso).
!----------------------------------------------------------------------
         if (debug_ijt) then
           write (diag_unit, '(a, 2f19.10,1l4)')    &
                'in mulsub: PB,PT, lmeso= ', pb, ptma_miz(kou), lmeso
        endif

         if (cu_miz /= 0.0) then
          precip_frac = cell_precip_miz/cu_miz
         else
           precip_frac = 0.
        endif
        ci_ice_cond = 0.
        do kk=1,nlev_lsm
          dp = phalf_c(kk) - phalf_c(kk+1)
          ci_ice_cond = ci_ice_cond + h1_ice(kk)*dp
!RSHfix for "s" release:  
!     replace the above line with the following; also comment out line
!     noted below. This fix will eliminate the occurrence of roundoff
!     "snow" falling from donner (~10e-22, + and -) that results from 
!     difference in this calc and that of "summel" above 
!NOTE THAT THE SAME CHANGE NEEDS TO BE MADE IN THE DONNER-FULL CODE.>>>
!         ci_ice_cond = ci_ice_cond + h1_ice(kk)*dp/Param%grav
        end do
       if (pmelt_lsm < pb) then
         melting_in_cloud = .true.
      else
        melting_in_cloud = .false.
     endif
!RSHfix  for "s" release -- comment out this line:
        ci_ice_cond = ci_ice_cond/(Param%grav)
        if (ci_ice_cond /= 0.0) then
          if (melting_in_cloud) then
         precip_melt_frac = summel/ci_ice_cond
           else
               precip_melt_frac = 0.
           endif
       else
         precip_melt_frac = 0.
       endif
       if (debug_ijt) then
         write (diag_unit, '(a, 3e20.12)')  &
            'in mulsub: h1_ice intg, summel, precip_melt_frac', &
                       ci_ice_cond, summel*cell_precip_miz/cu_miz, &
                                                    precip_melt_frac
          endif
       ci_liq_cond = 0.
       do kk=1,nlev_lsm
         dp = phalf_c(kk) - phalf_c(kk+1)
         ci_liq_cond = ci_liq_cond + h1_liq(kk)*dp
       end do
        ci_liq_cond = ci_liq_cond/(Param%grav)

!---------------------------------------------------------------------
!    if this member of the ensemble supports a mesoscale circulation,
!    call mesub to obtain various terms related to moving condensate
!    from the convective tower into the mesoscale anvil for this member.
!---------------------------------------------------------------------
        if (lmeso) then
          call don_cm_mesub_miz     &
               (Nml, pfull_c,nlev_lsm, me, diag_unit, debug_ijt, Param, cu_miz,   &
                ci_liq_cond, ci_ice_cond, pmelt_lsm, &
                cell_precip_miz, dint_miz, plzb_c, pb, ptma_miz(kou), &
                temp_c, phalf_c,     ca_liq, ca_ice, ecd, ecd_liq, &
                ecd_ice, ecei_liq, ece, ece_liq, ece_ice, meso_freeze, &
                meso_melt, ermesg, error)
          if (error /= 0 ) return
        else
          ca_liq = 0.
          ca_ice = 0.
          meso_freeze = 0.
          meso_melt   = 0.
        endif

        if (ci_liq_cond /= 0.0) then
          frz_frac = dint_miz/ci_liq_cond
          frz_frac_non_precip = dint_miz*(1.-precip_frac)/ci_liq_cond
        else
          frz_frac_non_precip = 0.
          frz_frac = 0.
        endif

        if (debug_ijt) then
          write (diag_unit, '(a, 3e20.12)')  &
           'in mulsub pre anvil_cond_frz: h1_liq intg, dint_miz, frz_frac',&
                         ci_liq_cond, dint_miz, frz_frac_non_precip
        endif
        if (debug_ijt) then
          write (diag_unit, '(a, 1e20.12)')  &
                                 'in mulsub : frz_frac', &
                                   frz_frac
        endif

        if (cu_miz /= 0.0) then
          meso_frac = (ca_liq + ca_ice)/cu_miz
        else
          meso_frac = 0.
        endif

        if (lmeso) then
          bak = 0.
          do kk=1,nlev_lsm
            dp = phalf_c(kk) - phalf_c(kk+1)
            bak = bak + meso_freeze(kk)*dp
          end do
          bak = bak/(Param%grav)
          bak = bak/(Param%seconds_per_day*1.0e3)
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12)')  &
             'in mulsub: column meso_freeze', bak
          endif
          if (bak > 0.0) meso_frz_intg = .true.
          if (ci_liq_cond /= 0.0) then
            meso_frz_frac = bak/ci_liq_cond
          else
            meso_frz_frac = 0.
          endif
          if (debug_ijt) then
            write (diag_unit, '(a, i4, 2e20.12)')  &
             'in mulsub : kou, frz_frac, meso_frz_frac', &
                                 kou, frz_frac_non_precip, meso_frz_frac
          endif
        else
          meso_frz_intg = .false.
          meso_frz_frac = 0.
       endif

     if (meso_frz_frac == 0. .and.  .not. melting_in_cloud) then
         if (meso_frac < frz_frac_non_precip .and. meso_frac > 0.) then
             do k=1,nlev_lsm
          cell_freeze(k) = cell_freeze(k)*meso_frac/frz_frac_non_precip
             end do
             dint_miz = dint_miz *meso_frac/frz_frac_non_precip
             frz_frac = frz_frac*meso_frac/frz_frac_non_precip
            frz_frac_non_precip = meso_frac
           endif
        endif
 
         if (debug_ijt) then
           write (diag_unit, '(a, i4, 3e20.12)')  &
                'in mulsub : kou, ADJUSTEDfrz_frac, meso_frz_frac, &
                   &precip_melt_frac', &
                         kou, frz_frac_non_precip, meso_frz_frac,  &
                                                      precip_melt_frac
        endif
        
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3f19.10)')    &
                      'in mulsub: meso_frac, precip_frac,frz_frac:', &
                        kou, meso_frac, precip_frac, frz_frac_non_precip
          write (diag_unit, '(a, i4, 4f19.10)')    &
                      'in mulsub: cu, ca, cell_precip, dint_miz   :', &
                          kou, cu_miz, ca_liq + ca_ice,   &
                             cell_precip_miz, dint_miz*Param%seconds_per_day
        endif

         if (lmeso) then
           summel = 0.
         endif
       if (debug_ijt) then
          write (diag_unit, '(a, 4f19.10)')    &
                      'in mulsub: pmelt_lsm, pb, summel   :', &
                          pmelt_lsm, pb, summel*cell_precip_miz/cu_miz
       endif
        
         do k=1,ncc_kou_miz
!----------------------------------------------------------------------
!    define the factor needed to normalize each ensemble member's con-
!    tribution by the cloud base area of ensemble member #1. wt_factor
!    is the cloud area at level k for ensemble member kou, relative to
!    the cloud area at cloud base (k=1) for ensemble member #1.
!-----------------------------------------------------------------------
        wt_factor = Param%arat(kou)*(rcl_miz(k)/rcl_miz(krel-1))**2
        
!----------------------------------------------------------------------
!    add this ensemble member's appropriately weighted contribution to
!    the ensemble-total cloud area (alp), condensed ice (cuql), condensed
!    liquid (cuqli), cell upward mass flux (ucemh), cell detrained mass 
!    flux (detmfh), condensation rate (rlsm), vertical moisture flux 
!    convergence (emsm) and vertical tracer flux convergence (etsm). the
!    weighting factor area_ratio*(rcl(k)/rcl(1))**2 allows the contrib-
!    utions from each member to be added by normalizing each member's 
!    contribution by the cloud base area of ensemble member #1.
!    NOTE: several of the arrays already have some of the normalizing
!    factors already included and so here need only to be multiplied by 
!    a portion of wt_factor.
!----------------------------------------------------------------------
        alp_miz  (k) = alp_miz  (k) + wt_factor                      
        cuql_miz (k) = cuql_miz (k) + wt_factor*  &
                             (cfracice_miz(k)*qlw_miz(k))
        cuqli_miz(k) = cuqli_miz(k) + wt_factor*  &
                             ((1.0 - cfracice_miz(k))*qlw_miz(k))
        ucemh_miz(k) = ucemh_miz(k) + Param%arat(kou)*flux_miz(k)/ &
                                                    (rcl_miz(krel-1)**2)
        if (k < ncc_kou_miz) then
          if (flux_miz(k+1) < flux_miz(k)) then
            detmfh_miz(k) = detmfh_miz(k) + Param%arat(kou)*   &
                        ((flux_miz(k)-flux_miz(k+1))/(rcl_miz(krel-1)**2))
          endif
        endif
        rlsm_miz(k)   = rlsm_miz(k)   - Param%arat(kou)*dpf_miz (k) 
        emsm_miz(k)   = emsm_miz(k)   + Param%arat(kou)*emfhr_miz(k)
        qvfm_miz(k)   = Param%arat(kou)*(dpf_miz (k) + emfhr_miz(k))
        qvfm_tot(k)   = qvfm_tot(k) + qvfm_miz(k)

        etsm_miz(k,:) = etsm_miz(k,:) + Param%arat(kou)*etfhr_miz(k,:)
     enddo

     do n=1,ntr
     do k=1,ncc_kou_miz
!        etsm_miz(k,n) = etsm_miz(k,n) + (Param%arat(kou)*etfhr_miz(k,n))
        qtren(k,n)    = qtren(k,n) + (Param%arat(kou)*etfhr_miz(k,n))
        ensmbl_wetc(k,n) = ensmbl_wetc(k,n) +  &
                                   (Param%arat(kou)*dpftr_miz(k,n))
     end do
     end do

!--------------------------------------------------------------------
!    if a mesoscale circulation is present, add this member's cloud-
!    base_area-weighted contribution of condensate transferred to the 
!    anvil (ensmbl_anvil_cond) and cloud top cloud fraction 
!    (ensmbl_cld_top_area) to the arrays accumulating the ensemble sums.
!--------------------------------------------------------------------
      if (lmeso) then
        if (meso_frac /= 0.0) then
          local_frz_frac = (frz_frac_non_precip + meso_frz_frac)/  &
                                                              meso_frac
        else
          local_frz_frac = 0.0
        endif
        ensmbl_anvil_cond_liq   = ensmbl_anvil_cond_liq   +   &
                          Param%arat(kou)*ca_liq*(1.-local_frz_frac)
        ensmbl_anvil_cond_liq_frz   = ensmbl_anvil_cond_liq_frz   +   &
                               Param%arat(kou)*ca_liq*local_frz_frac
        ensmbl_anvil_cond_ice   = ensmbl_anvil_cond_ice   +  &
                                            Param%arat(kou)*ca_ice
        ensmbl_cld_top_area = ensmbl_cld_top_area +   &
                                               Param%arat(kou)*apt_miz
      endif

!--------------------------------------------------------------------
!    add this ensemble member's weighted contribution to the total 
!    precipitation (ensmbl_precip) and condensation (ensmbl_cond). 
!--------------------------------------------------------------------
      ensmbl_precip = ensmbl_precip + Param%arat(kou)*cell_precip_miz
      ensmbl_cond   = ensmbl_cond   + Param%arat(kou)*cu_miz

!---------------------------------------------------------------------

!!$        call don_d_add_to_ensmbl_sum_lores_k    &
!!$             (nlev_lsm, ntr, diag_unit, debug_ijt, lmeso, Param,   &
!!$              Param%arat(kou), dint, cell_freeze, cell_melt, temp_c,   &
!!$              h1_2, ecd, ece, evap_rate, q1, h1, pfull_c, meso_melt, &
!!$              meso_freeze, phalf_c, qtr, ensmbl_melt, ensmbl_freeze, &
!!$              enctf, encmf, enev, disg, disb, disc, ecds, eces, disd, &
!!$              qtren, ermesg)
!!$        if (trim(ermesg) /= ' ') return



      do k=1,nlev_lsm       

!---------------------------------------------------------------------
!    define the moisture forcing term (sum of condensation h1 and 
!    vertical flux convergence q1) on the large-scale grid. convert to
!    units of g(h20) per kg(air) per day, requiring multiplication by
!    1.0e3 g(h2o) /kg(h2o) times SECONDS_PER_DAY. add this member's 
!    contribution to the sum over the ensemble (encmf). 
!----------------------------------------------------------------------
        cmf(k) = (-(h1_liq(k) + h1_ice(k)) + q1(k))*  &
                                         (Param%SECONDS_PER_DAY*1.0e03)
        encmf(k) = encmf(k) + Param%arat(kou)*cmf(k)

!----------------------------------------------------------------------
!    define the condensation term in the temperature equation on the 
!    large-scale grid (rlh), using the latent heat of vaporization when 
!    the ambient temperature is above freezing, and the latent heat of 
!    sublimation when ice may be present. add this member's contribution
!    to the sum over the ensemble (disc).
!----------------------------------------------------------------------
        if (.not. melting_in_cloud) then
          disz(k) = disz(k) + Param%arat(kou)*h1_liq(k)*   &
                             Param%seconds_per_day*frz_frac*precip_frac
        else
          disz_remelt(k) = disz_remelt(k) + Param%arat(kou)*h1_liq(k)* &
                             Param%seconds_per_day*frz_frac*precip_frac
        endif
 
        disp_liq(k) = disp_liq(k) + Param%arat(kou)*h1_liq(k)*   &
                      Param%seconds_per_day*(1.0-frz_frac)* precip_frac
        disze1(k) = disze1(k) + Param%arat(kou)*h1_liq(k)*  &
                        Param%seconds_per_day*Param%hls*frz_frac* &  
                                       (1.-precip_frac)/Param%cp_air
        disze2(k) = disze2(k) + Param%arat(kou)*h1_liq(k)*  &
                         Param%seconds_per_day*Param%hlv*  &
                          (1.0-frz_frac)*(1.-precip_frac)/Param%cp_air
        disze3(k) = disze3(k) - Param%arat(kou)*h1_ice(k)*  &
                        Param%seconds_per_day*Param%hls*  &
                                         (1.-precip_frac)/Param%cp_air
        disp_ice(k) = disp_ice(k) + Param%arat(kou)*h1_ice(k)*  &
                         Param%seconds_per_day*(1.0-precip_melt_frac)* &
                                                         precip_frac   
        disp_melted(k) = disp_melted(k) + Param%arat(kou)*h1_ice(k)*  &
                          Param%seconds_per_day* precip_melt_frac * &
                                                           precip_frac
        disc_liq(k) = disc_liq(k) + Param%arat(kou)*h1_liq(k)* &
                        Param%seconds_per_day*Param%hlv/ Param%cp_air
!  if no melting, the frozen liquid stays frozen and carries out hls;
!  if melting, the frozen liquid melts and carries out hlv.

        if (.not. melting_in_cloud) then
!55 should be if meso and cell freezing both 0.0; if cell freezing
!55  non-zero, then all meso entrained liq will have frozen
!         if (meso_frz_intg <= 0. .and. frz_frac == 0.) then
!         if (.not. meso_frz_intg       .and. frz_frac == 0.) then
          if (.not. meso_frz_intg .and. frz_frac_non_precip == 0.) then
            dism_liq(k) = dism_liq(k) + Param%arat(kou)*h1_liq(k)* &
                                      meso_frac*Param%seconds_per_day                          
          else
!! NOT ALL LIQUID FREEZES; only frz_frac + meso_frz_frac
!53  when no melting and freezing, then all condensate is frozen when
!53   it precipitates 
            dism_liq_frz(k) = dism_liq_frz(k) + Param%arat(kou)*  &
                               h1_liq(k)*meso_frac*Param%seconds_per_day
          endif
          dism_ice(k) = dism_ice(k) + Param%arat(kou)*h1_ice(k)*  &
                                     meso_frac*Param%seconds_per_day
        else
          dism_liq_remelt(k) = dism_liq_remelt(k) + Param%arat(kou)*  &
                               h1_liq(k)*meso_frac*Param%seconds_per_day
          dism_ice_melted(k) = dism_ice_melted(k) +   &
                                  Param%arat(kou)*h1_ice(k)*meso_frac* &
                                                  Param%seconds_per_day
        endif
        disc_ice(k) = disc_ice(k) + Param%arat(kou)*h1_ice(k)* &
                   Param%seconds_per_day*Param%hls/ Param%cp_air

         if (debug_ijt) then
              write (diag_unit, '(a, i4, 3e20.12)')  &
                             'in mulsub: precip profiles', &
                                k, disp_liq(k)*Param%hlv/Param%cp_air,&
                        Param%hls/Param%cp_air*disp_ice(k), &
                         Param%hls/Param%cp_air*disz(k)
              write (diag_unit, '(a, i4, 2e20.12)')  &
                            'in mulsub: remelt, melt precip profiles', &
                    k, Param%hlv/Param%cp_air*disz_remelt(k), &
                                  Param%hlv/Param%cp_air*disp_melted(k)
              write (diag_unit, '(a, i4, 3e20.12)')  &
                             'in mulsub: evap   profiles', &
                              k, disze1(k)                       , &
                           disze2(k)                       , &
                         -disze3(k)                       
              write (diag_unit, '(a, i4, 2e20.12)')  &
                              'in mulsub: cd     profiles', &
                                k, disc_liq(k), disc_ice(k)
       endif


!--------------------------------------------------------------------
!    add this member's weighted contribution to the ensemble's temper-
!    ature flux convergence (disb), the ensemble's water vapor flux 
!    convergence (disd) and the ensemble's entropy flux convergence 
!    (enctf). convert the rates to units of per day, and for disd from
!    kg(h2o) per kg(air) to g(h2o) per kg(air).
!--------------------------------------------------------------------
        disb(k) = disb(k) + Param%arat(kou)*(h1_2(k)*  &
                                              Param%SECONDS_PER_DAY)
        disd(k) = disd(k) + Param%arat(kou)*(q1(k)*   &
                                       (Param%SECONDS_PER_DAY*1.0e3))
        disv(k) = disv(k) + Param%arat(kou)*((h1_liq(k) + h1_ice(k))*  &
                             (Param%SECONDS_PER_DAY*1.0e3))
!   change enctf to reflect need for both ice and liq cd in layer of
!   tfre
       enctf(k) = enctf(k) + Param%arat(kou)*    &
                      (h1_2(k)*Param%SECONDS_PER_DAY + &
                        (h1_liq(k)*Param%hlv + h1_ice(k)*Param%hls)*  &
                           Param%seconds_per_day/ Param%cp_air )

!--------------------------------------------------------------------
!    if a mesoscale circulation exists, add this member's contribution
!    to the mesoscale condensate's evaporation associated with convect-
!    ive downdrafts (ecds) and that associated with evaporation into 
!    the environment (eces). if there has been no freezing associated
!    with the mesoscale condensate, define the condensation term for
!    the temperature equation using the latent heat of vaporization
!    (disg). if there has been freezing, then the convective downdraft 
!    heating uses the latent heat of vaporization, whereas the entrain-
!    ment evaporation is of ice and so uses the latent heat of 
!    sublimation.
!--------------------------------------------------------------------
        if (lmeso) then
          ecds_liq(k) = ecds_liq(k) + Param%arat(kou)*ecd_liq(k)
          ecds_ice(k) = ecds_ice(k) + Param%arat(kou)*ecd_ice(k)
          eces_liq(k) = eces_liq(k) + Param%arat(kou)*ece_liq(k)
          eces_ice(k) = eces_ice(k) + Param%arat(kou)*ece_ice(k)
          disg_ice(k) = disg_ice(k) - Param%arat(kou)*((ecd_ice(k) + &
                                         ece_ice(k))*  &
                                Param%hls/(Param%CP_AIR*1000.))
!         if (dint_miz == 0.) then
!           disg_liq(k) = disg_liq(k) - Param%arat(kou)*((ecd_liq(k) + &
!                                      ece_liq(k))*  &
!                               Param%hlv/(Param%CP_AIR*1000.))
!         else
!          if (melting_in_cloud) then
!            disg_liq(k) = disg_liq(k) - Param%arat(kou)*  &
!                       ((ece_liq(k)                          )*  &
!                             Param%HLS/(Param%CP_AIR*1000.))
!          else
!            if (.not. meso_frz_intg       ) then
!               disg_liq(k) = disg_liq(k) - Param%arat(kou)*  &
!                          (((ece_liq(k)*Param%hlv)  )/ &
!                                       (Param%CP_AIR*1000.))
!            else
!               disg_liq(k) = disg_liq(k) - Param%arat(kou)*  &
!                      ((            ece_liq(k)*Param%hls  )/ &
!                                       (Param%CP_AIR*1000.))
!            endif
!          endif

!          disg_liq(k) = disg_liq(k) - Param%arat(kou)*  &
!                              (ecd_liq(k)*Param%HLV/  &
!                      (Param%CP_AIR*1000.))
!        endif
          if (dint_miz /= 0. .and. &
               (melting_in_cloud .or. meso_frz_intg) ) then
            disg_liq(k) = disg_liq(k) - Param%arat(kou)*  &
                   ((ecd_liq(k)*Param%hlv + &
                     ece_liq(k)*Param%hls)/(Param%CP_AIR*1000.))
          else
            disg_liq(k) = disg_liq(k) - Param%arat(kou)*((ecd_liq(k) + &
                                       ece_liq(k))*  &
                                Param%hlv/(Param%CP_AIR*1000.))
          endif
      endif  ! (lmeso)

!---------------------------------------------------------------------
!    add this member's cloud water evaporation rate to the sum over 
!    the ensemble (enev).
!---------------------------------------------------------------------

        if (Nml%do_donner_lscloud) then
           enev(k) = enev(k) + Param%arat(kou)*evap_rate(k)
        else
           enev(k) = enev(k) + Param%arat(kou)*evap_rate(k) !miz for qa detrainment
           ecds_liq(k) = ecds_liq(k) + Param%arat(kou)*ecd_liq(k) !miz: add temporarily for ql detrainment
           ecds_ice(k) = ecds_ice(k) + Param%arat(kou)*ecd_ice(k) !miz: add temporarily for ql detrainment
           eces_liq(k) = eces_liq(k) + Param%arat(kou)*ece_liq(k) !miz: add temporarily for qi detrainment
           eces_ice(k) = eces_ice(k) + Param%arat(kou)*ece_ice(k) !miz: add temporarily for qi detrainment
        end if

!--------------------------------------------------------------------
!    if a mesoscale circulation exists, add the appropriately-weighted
!    anvil freezing and melting terms to the arrays accumulating their 
!    sums over the ensemble (ensmbl_melt, ensmbl_freeze). if in a diag-
!    nostic column, output the anvil (meso_freeze) and ensemble-sum
!    (ensmbl_freeze) freezing profiles.
!--------------------------------------------------------------------
        if (lmeso) then
          ensmbl_melt_meso(k) = ensmbl_melt_meso(k) - Param%arat(kou)*&
                         meso_melt(k)
          ensmbl_freeze_meso(k) = ensmbl_freeze_meso(k) +  &
                                  Param%arat(kou)*meso_freeze(k)
         if (debug_ijt) then
           if (meso_freeze(k) /= 0.0) then
             write (diag_unit, '(a, i4, 2e20.12)')  &
                              'in mulsub: jk,fres,fre= ',   &
                              k, ensmbl_freeze_meso(k), meso_freeze(k)
            endif
         endif

        endif

!--------------------------------------------------------------------
!    add the appropriately-weighted convective cell freezing and 
!    melting terms to the arrays accumulating vertical profiles of 
!    total cloud melting (ensmbl_melt) and freezing (ensmbl_freeze) 
!    over the entire ensemble.  if in diagnostic column, output the 
!    convective cell (cell_freeze) and accumulated (ensmbl_freeze) 
!    freezing profiles.
!--------------------------------------------------------------------
        ensmbl_freeze(k) = ensmbl_freeze(k) +    &
                                        Param%arat(kou)*cell_freeze(k)
        ensmbl_melt(k) = ensmbl_melt(k) - Param%arat(kou)*cell_melt(k)
        if (debug_ijt) then
          if (cell_freeze(k) /= 0.0) then
            write (diag_unit, '(a, i4, 2e20.12)')  &
                     'in mulsub: jk,fres,frea= ',    &
                                    k, ensmbl_freeze(k), cell_freeze(k)
         endif
       endif
      end do

!--------------------------------------------------------------------
!    save the cloud top (ptma) pressures, the total condensation (cuto),
!    total precpitation (preto) and cloud top index (ncca) from this !
!    ensemble member.
!--------------------------------------------------------------------
        if (meso_frz_intg) meso_frz_intg_sum = .true.
        ncca(kou)  = ncc_kou_miz

      end do   ! (kou loop over ensemble members)

!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! 31   CONTINUE
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$


!----------------------------------------------------------------------
!    define ensemble cloud top pressure (pt_ens) to be the cloud top of 
!    the most penetrative ensemble member. this is frequently, but not 
!    always, the ensemble member with the lowest entrainment rate. 
!    cloud base pressure (pb) is the same for all ensemble members. 
!    define the cloud top index(ncc_ens)  as the highest of any ensemble 
!    member.
!----------------------------------------------------------------------
      pt_ens  = MINVAL (ptma_miz)
      ncc_ens = MAXVAL (ncca)

!----------------------------------------------------------------------
!    divide the ensemble mean ice and liquid condensate terms by the 
!    total cloud area to define the average cloud water and cloud ice 
!    concentrations within the cloudy area, as opposed to averaged over 
!    the entire grid box.
!----------------------------------------------------------------------
      do k=1,ncc_ens
        if (alp_miz(k) > 0.) then
          cuql_miz (k) = cuql_miz (k)/alp_miz(k)
          cuqli_miz(k) = cuqli_miz(k)/alp_miz(k)
        endif
      end do

!---------------------------------------------------------------------
!    define the cloudtop anvil area (ampta1), assumed to be mesofactor
!    (default = 5) times larger than the sum of the cloud top areas of 
!    the ensemble members, as in Leary and Houze (1980), 
!---------------------------------------------------------------------
      ampta1 = Nml%mesofactor*ensmbl_cld_top_area

!---------------------------------------------------------------------
!    if there is no precipitation production in this column, set the 
!    inverse of the max cloud area at any layer in the column to be 0.0.
!---------------------------------------------------------------------
      if (ensmbl_precip == 0.0) then
        amax      = 0.0
      else

!---------------------------------------------------------------------
!    if there is precip in the column, determine the maximum convective 
!    cell area at any level in the column (al). the total normalized 
!    cloud area in the column (cell area + mesoscale area) cannot be 
!    greater than 1.0. this constraint imposes a limit on the cloud area
!    at cloud base (amax). this limit will be imposed in subroutine
!    determine_cloud_area. see "a bounds notes" (7/6/97).
!---------------------------------------------------------------------
        al = MAXVAL (alp_miz)
        amax = 1./(al + ampta1)
      endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the total ensemble condensation,
!    (ensmbl_cond), precipitation (ensmbl_precip), and condensate 
!    transferred into the anvil (ensmbl_anvil_cond). also output 
!    surface pressure (phalf_c(1)), ensemble cloud base nd cloud top 
!    pressures (pb, pt_ens), the flag indicating if a mesoscale circul-
!   ation is present in the grid column (lmeso), and the cloud top anvil
!---------------------------------------------------------------------
       if (debug_ijt) then
         write (diag_unit, '(a, e20.12, a, e20.12)')  &
                       'in mulsub: CUTOT=', ensmbl_cond, ' PRETOT=', &
                                      ensmbl_precip
        write (diag_unit, '(a, 4e20.12)') &
               'in mulsub: CATOT, (sum,liq, frzliq, ice)=', &
                 ensmbl_anvil_cond_liq + ensmbl_anvil_cond_liq_frz +   &
                                               ensmbl_anvil_cond_ice, &
                                     ensmbl_anvil_cond_liq, &
                                      ensmbl_anvil_cond_liq_frz, &
                                     ensmbl_anvil_cond_ice
        write (diag_unit, '(a, 3f19.10, 1l4)')  &
                       'in mulsub: ps,pb,pt,lmeso= ',   &
                                       phalf_c(1), pb, pt_ens, lmeso
        write (diag_unit, '(a, e20.12)')  &
                                 'in mulsub: ampt= ',ampta1
     endif



!!$      ptt = pt_ens + Param%dp_of_cloud_model
!!$!--------------------------------------------------------------------
!!$!    call define_ensemble_profiles to produce vertical profiles 
!!$!    representing the ensemble-total cloud area (ensmbl_cloud_area), 
!!$!    cloud liquid (cuql_v), cloud ice (cuq), mass flux(uceml) and
!!$!    detrained mass flux (detmfl).
!!$!--------------------------------------------------------------------
!!$      call don_d_def_ensemble_profs_k    &
!!$           (nlev_lsm, nlev_hires, ncc_ens, diag_unit, debug_ijt, ptt, &
!!$            cld_press, alp, detmfh, ucemh, cuql, cuqli, phalf_c,  &
!!$            ensmbl_cloud_area, cuql_v, cuq, detmfl, uceml, ermesg)
!!$      if (trim(ermesg) /= ' ') return

      
      ensmbl_cloud_area = alp_miz
      cuq               = cuql_miz
      cuql_v            = cuqli_miz
      uceml             = ucemh_miz
      detmfl            = detmfh_miz

      rlsm              =rlsm_miz
      emsm              =emsm_miz
      etsm              =etsm_miz
      cld_press         =sd%p


    end subroutine don_d_integ_cu_ensemble_miz


!######################################################################
!######################################################################


subroutine don_d_determine_cloud_area_miz            &
        (me, nlev_model, ntr, dt, nlev_parcel, diag_unit, debug_ijt,  &
          Param, Initialized,Nml, tracers, pfull, zfull, phalf, zhalf, &
          pblht, tkemiz, qstar, cush, cbmf, land, coldT, sd, Uw_p, &
          ac, max_depletion_rate, cape, dcape, amax, dise_v, disa_v,  &
          pfull_c, temp_c, mixing_ratio_c, env_t, env_r, parcel_t,  &
          parcel_r, cape_p, exit_flag, amos, a1, ermesg, error)

!---------------------------------------------------------------------
!    subroutine determine_cloud_area defines the convective cloud area
!    and so closes the donner_deep parameterization. The arrays 
!    Don_conv%a1 and Don_conv%amos are output by this routine.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_initialized_type
use conv_utilities_k_mod, only : sounding, adicloud, uw_params !miz

implicit none

!-----------------------------------------------------------------------
!++++yim
integer,                      intent(in)    :: me, nlev_model,nlev_parcel, ntr, diag_unit
real,                         intent(in)    :: dt
logical,                      intent(in)    :: debug_ijt
type(donner_param_type),      intent(in)    :: Param
type(donner_initialized_type),intent(in)    :: Initialized
type(donner_nml_type),        intent(in)    :: Nml      
real,                         intent(in)    :: max_depletion_rate,  &
                                               cape, dcape, amax
real, dimension(nlev_model),    intent(in)    :: dise_v, disa_v, pfull_c, temp_c, mixing_ratio_c 
real, dimension(nlev_model),  intent(in)    :: pfull, zfull
real, dimension(nlev_model+1),  intent(in)    :: phalf, zhalf !miz
real,                         intent(in)    :: pblht, tkemiz,  &
                                               qstar, cush, cbmf, land !miz
logical,                      intent(in)    :: coldT !miz
!++++yim
real, dimension(nlev_model,ntr),    intent(in)    :: tracers
type(sounding),               intent(inout) :: sd !miz
type(uw_params),               intent(inout) :: Uw_p !miz
type(adicloud),               intent(inout) :: ac !miz
real, dimension(nlev_parcel),    intent(in)    :: env_t, env_r, parcel_t, parcel_r, cape_p
logical,                      intent(inout) :: exit_flag
real,                         intent(out)   :: amos, a1
character(len=*),             intent(out)   :: ermesg
integer,                      intent(out)   :: error
 
real, dimension (nlev_model)  :: a1_vk              
real, dimension(nlev_parcel)   :: qli0_v, qli1_v, qt_v, qr_v, rl_v, ri_v
real                        :: qtest, tfint, disbar
integer                     :: k
!----------------------------------------------------------------------
!   local variables:
!
!         a1_vk
!         qli0      normalized component of cumulus condensate forcing
!         qli1      un-normalized component of condensate forcing
!         qt_v      temperature tendency due to deep convection on
!                   cape grid [ deg K / sec ]
!         qr_v      vapor mixing ratio tendency due to deep convection
!                   on cape grid [ kg(h2o) / ( kg(air) sec ]
!         rl_v      large-scale liquid mixing ratio
!         ri_v      large-scale ice mixing ratio 
!         qtest
!         tfint     column integral of moisture time tendency due to
!                   convection  [ mm / sec , or  kg / (m**2 sec ) ]
!         disbar    water vapor time tendency due to deep convection at 
!                   large-scale model interface levels
!                   [ kg(h2o) / ( kg(air) sec ) ]
!         nlev      number of layers in large-scale model
!         k         do-loop index

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

       if (Nml%do_hires_cape_for_closure) then
 
!---------------------------------------------------------------------
!    call map_lo_res_col_to_hi_res_col to interpolate moisture and
!    temperature forcings from large-scale model grid (dise_v, disa_v)
!    to the vertical grid used in the cape calculation (qr_v, qt_v). 
!--------------------------------------------------------------------
        call don_u_lo1d_to_hi1d_k   &
            (nlev_model, nlev_parcel, disa_v, pfull_c, cape_p, qt_v,  &
             ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
       if (error /= 0 ) return

       call don_u_lo1d_to_hi1d_k   &
         (nlev_model, nlev_parcel, dise_v, pfull_c, cape_p, qr_v, &
           ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
       if (error /= 0 ) return

    else ! (do_hires_cape_for_closure)
      qt_v=disa_v!miz
      qr_v=dise_v!miz
    endif ! (do_hires_cape_for_closure)

!--------------------------------------------------------------------
!    if in a diagnostic column, output the temperature and moisture 
!    forcings on both the cape grid (qt_v, qr_v) and the large-scale
!    model grid (disa_v, dise_v).
!--------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_parcel
          if (qr_v(k) /= 0.0 .or. qt_v(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12, f20.14)')  &
                      'in cupar: k,qr,qt= ',k, qr_v(k), qt_v(k)
          endif
        end do
        do k=1,nlev_model
          if (dise_v(k) /= 0.0 .or. disa_v(k) /= 0.0) then
            write (diag_unit, '(a, i4, 2e20.12)')  &
                     'in cupar: k,dise,disa= ',k, dise_v(k), disa_v(k)
          endif
        end do
      endif

!--------------------------------------------------------------------
!   define condensate variables on the cape grid (qli0, qli1, rl_v, 
!   ri_v). these variables are not used in the current version of the
!   cumulus closure scheme implemented in subroutine cumulus_closure, 
!   so they are given values of 0.0.
!--------------------------------------------------------------------
      do k=1,nlev_parcel !miz nlev_hires
        qli0_v(k) = 0.
        qli1_v(k) = 0.
        rl_v(k)   = 0.
        ri_v(k)   = 0.
      end do

!--------------------------------------------------------------------
!    call subroutine cumulus_closure to determine cloud base cloud
!    fraction and so close the deep-cumulus parameterization.
!--------------------------------------------------------------------
    if (Nml%deep_closure .eq. 0) then
      call cu_clo_cumulus_closure_miz   &
           (nlev_model, nlev_parcel, ntr, dt, diag_unit, debug_ijt, &
            Initialized, Param, tracers, &
            dcape, pfull, zfull, phalf, zhalf, pblht, tkemiz, qstar, &
            cush, land, &
            coldT, sd, Uw_p, ac, Nml,        &!miz
            cape_p, qli0_v, qli1_v, qr_v, qt_v, env_r, ri_v, &
            rl_v, parcel_r, env_t, parcel_t, a1, ermesg, error)     
     else if (Nml%deep_closure .eq. 1) then
       call cu_clo_cjg    &
            (me, nlev_model, nlev_parcel, ntr, dt, diag_unit, &
             debug_ijt, Initialized, Param, Nml, amax, cape, dcape, cape_p, env_t, &
             env_r, qt_v, qr_v, pfull, zfull, phalf, zhalf, tracers, &
             land, pblht, tkemiz, qstar, coldT, sd, Uw_p, ac, &
             a1, ermesg, error )
     else
        call  cu_clo_miz   &
             (nlev_model, ntr, dt, Initialized, Param, tracers, &
              pfull, zfull, phalf, zhalf, pblht, tkemiz, qstar, cush, cbmf, land,  &
              coldT, sd, Uw_p, ac, Nml, env_r, env_t, a1, ermesg, error)
     endif

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    calculate the vertical integral of normalized moisture forcing 
!    in the column (tfint) in units of kg (h2o) per m**2 per second, or
!    mm (h2o) per second.
!-------------------------------------------------------------------
      tfint = 0.0
      do k=2,nlev_model
        disbar = 0.5*(dise_v(k-1) + dise_v(k))
        tfint = tfint - disbar*(pfull_c(k-1) - pfull_c(k))
      end do
      tfint = tfint/Param%grav

!--------------------------------------------------------------------
!    restrict the cloud-base area fraction produced by subroutine
!    cumulus_closure to be no larger than the cloud base area that 
!    results in total grid box coverage at some higher level (amax). 
!--------------------------------------------------------------------
    if (Nml%deep_closure .eq. 0 .or. Nml%deep_closure .eq. 1) then
      a1 = MIN (amax, a1)
     else
      a1 = MIN (0.25, a1)
    end if

!---------------------------------------------------------------------
!    set the cloud-base area fraction to be 0.0 if there is no net
!    column integral of moisture forcing in the column. this is 
!    referred to as the moisture constraint. see "Moisture Constraint",
!    8/8/97. set the exit_flag to .true., turning off convection in
!    this column, output a message, and return to calling subprogram.
!---------------------------------------------------------------------
      if (tfint == 0.) then      
        a1 = 0.
        exit_flag      = .true.
        if (debug_ijt) then
          write (diag_unit, '(a)')  &
                 'convection turned off in column because of moist&
                  &ure constraint; cloud area being set to 0.0'
        endif
        return
      endif

!---------------------------------------------------------------------
!    if in a diagnostic column, output the column integral of the 
!    moisture forcing (tfint) and the fractional cloud area (a1) after
!    assuring that moisture forcing is present in the column.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)')  &
                       'in cupar: tfint= ',tfint
        write (diag_unit, '(a, e20.12)')  &
                       'in cupar: a1_v = ',a1
      endif


!---------------------------------------------------------------------
!    restrict cloud fractional area by the moisture constraint. this
!    requirement limits the cloud area so that the moisture tendency 
!    due to the deep convection (tfint - which occurs only within the 
!    cloud fractional area) will not remove more vapor from the column 
!    than is available. here amos is the cloud area over which applic-
!    ation of the convective moisture tendency will result in total
!    vapor depletion in the column.
!---------------------------------------------------------------------
      amos = max_depletion_rate/tfint     
      if (a1 > amos)  then    
        a1 = max(amos, 0.)
      endif 

!---------------------------------------------------------------------
!    for any diagnostic columns in the window in which deep convection
!    was possible, output the column integral of the moisture forcing 
!    (tfint), the max cloud area allowed by the moisture constraint 
!    (amos) and the fractional cloud area after applying the moisture
!    constraint (a1).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                    'in cupar: tfint,amos,a1= ',  &
                                     tfint, amos, a1
      endif

!---------------------------------------------------------------------
!    verify that the current value of a1 will not produce negative
!    value of vapor mixing ratio at any level in the column when the
!    convective moisture tendency is applied. determine the large-scale
!    model mixing ratio for the current value of a1 (qtest). if qtest
!    is negative at any level for this value of a1, reset the value 
!    of a1, so that no negative mixing ratios will be produced.
!--------------------------------------------------------------------
      do k=1,nlev_model
        qtest = mixing_ratio_c(k) + a1*Nml%donner_deep_freq*dise_v(k)
        if (qtest < 0.) then
          a1_vk(k) = -mixing_ratio_c(k)/(dise_v(k)*Nml%donner_deep_freq)
        else
          a1_vk(k) = a1     
        endif
      end do

!--------------------------------------------------------------------
!    define the a1 for the column as the smallest of those defined
!    in the column. 
!--------------------------------------------------------------------
      a1 = MINVAL (a1_vk)

!---------------------------------------------------------------------
!    if in a diagnostic column, output the final value of a1, after 
!    all necessary constraints have been applied.
!---------------------------------------------------------------------
     if (debug_ijt) then
       write (diag_unit, '(a, e20.12)') 'in cupar: a1= ',a1
     endif

!--------------------------------------------------------------------


    end subroutine don_d_determine_cloud_area_miz



!######################################################################


subroutine cu_clo_cumulus_closure_miz   &
         (nlev_model, nlev_parcel, ntr, dt, diag_unit, debug_ijt, &
          Initialized, Param, tracers, &
          dcape, pfull, zfull, phalf, zhalf, pblht, tkemiz, qstar, cush, land,  &
          coldT, sd, Uw_p, ac, Nml, cape_p, &!miz
          qli0_v, qli1_v, qr_v, qt_v, env_r, ri_v, rl_v, parcel_r,   &
          env_t, parcel_t, a1, ermesg, error)

!---------------------------------------------------------------------
!    subroutine cumulus_closure calculates a_1(p_b) for closing the 
!    cumulus parameterization. see LJD notes, "Cu Closure D," 6/11/97
!---------------------------------------------------------------------
 
use donner_types_mod,     only : donner_param_type, donner_nml_type, &
                                 donner_initialized_type
use conv_utilities_k_mod, only : pack_sd_lsm_k, extend_sd_k,  &
                                 adi_cloud_k, sounding, adicloud, &
                                 uw_params, qt_parcel_k

implicit none

!---------------------------------------------------------------------
!++++yim
integer,                        intent(in)  :: nlev_model,nlev_parcel,  ntr
real,                           intent(in)  :: dt
integer,                        intent(in)  :: diag_unit
logical,                        intent(in)  :: debug_ijt
type(donner_param_type),        intent(in)  :: Param
type(donner_initialized_type),  intent(in)  :: Initialized
type(donner_nml_type),          intent(in)  :: Nml
real,                           intent(in)  :: dcape
real,                           intent(in)  :: pblht, tkemiz, qstar,  cush, land
logical,                        intent(in)  :: coldT

real, dimension(nlev_model),      intent(in)    :: pfull, zfull !miz
!++++yim
real, dimension(nlev_model,ntr),      intent(in)    :: tracers

real, dimension(nlev_model+1),    intent(in)    :: phalf, zhalf !miz
type(sounding),                 intent(inout) :: sd           !miz
type(uw_params),                 intent(inout) :: Uw_p         !miz
type(adicloud),                 intent(inout) :: ac

real,    dimension(nlev_parcel), intent(in)  :: cape_p, qli0_v, qli1_v, &
                                               qr_v, qt_v, env_r, ri_v, &
                                               rl_v, parcel_r, env_t,   &
                                               parcel_t
real,                           intent(out) :: a1
character(len=*),               intent(out) :: ermesg
integer,                        intent(out) :: error
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   intent(in) variables:
! 
!        cape_p        pressure on cape grid [ Pa ]
!        qli0_v        normalized component of cumulus condensate 
!                      forcing [ kg(h2o) / (kg(air) sec) ]
!                      defined in "Cu Closure D," p. 4.
!        qli1_v        un-normalized component of cumulus condensate
!                      forcing [ kg(h2o) / (kg(air) sec) ]
!                      defined in "Cu Closure D," p. 4.
!        qr_v          normalized cumulus moisture forcing 
!                      [ kg(h2o) / (kg(air) sec) ]
!                      defined in "Cu Closure D," p. 1.
!        qt_v          normalized cumulus thermal forcing 
!                      [ deg K / sec ]
!                      defined in "Cu Closure D," p. 1.
!        env_r         large-scale water-vapor mixing ratio 
!                      [ kg (h2o) / kg(air) ]
!        ri_v          large-scale ice mixing ratio 
!                      [ kg (h2o) / kg(air) ]
!        rl_v          large-scale liquid mixing ratio 
!                      [ kg (h2o) / kg(air) ]
!        parcel_r      parcel vapor mixing ratio  
!                      [ kg (h2o) / kg(air) ]
!        env_t         large-scale temperature [ deg K ]
!        parcel_t      parcel temperature [ deg K ]
!        dcape         rate of change of convective available potential
!                      energy due to large-scale processes 
!                      [ J / (kg s) ]
!        no_precip     logical array indicating columns in which there
!                      is no precip (and thus no deep convection)
!
!   intent(out) variables:
!
!        a1            fractional area of cumulus  ensemble
!        
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      real, dimension (nlev_parcel)  :: rt, tden, tdena,  &
                                     dtpdta, pert_env_t, pert_env_r, &
                                     pert_parcel_t, pert_parcel_r,  &
                                     parcel_r_clo, parcel_t_clo, &
                                     ttt, rrr !miz

      real     :: tdens, tdensa, ri1, ri2, rild, rile, rilf, ri2b,  &
                  sum2, rilak, rilbk, rilck, rilakm, rilbkm, rilckm, &
                  rila, rilb, rilc, ri2ak, ri2akm, ri2a, sum1, plcl, &
                  plfc, plzb, dumcoin, dumxcape
       real     :: zsrc, psrc, hlsrc, thcsrc, qctsrc, cape_c, lofactor,&
                   tau, rhavg, dpsum
      integer  :: k     
      logical  :: ctrig, return_cape

      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    initialize the perturbed parcel profiles (pert_parcel_t,    
!    pert_parcel_r) and  the perturbed parcel environmental profiles to 
!    the actual parcel profiles.
!--------------------------------------------------------------------
      do k=1,nlev_parcel
        pert_parcel_t(k) = env_t(k)
        pert_parcel_r(k) = env_r(k)
        pert_env_r(k)    = env_r(k)
        pert_env_t(k)    = env_t(k)
!       ttt (k)          = env_t(nlev_model-k+1)
!       rrr (k)          = env_r(nlev_model-k+1)/(1.-env_r(nlev_model-k+1))
        ttt (k)          = env_t(nlev_parcel-k+1)
        rrr (k)          = env_r(nlev_parcel-k+1)
      end do

!--------------------------------------------------------------------
!    perturb lowest cape-model level mixing ratio and temperature so 
!    that one may calculate the derivative of parcel density temperature
!    w.r.t. surface large-scale density temperature. here the environ-
!    ment is made 1 deg K cooler and the mixing ratio is reduced to
!    99% of its unperturbed value.
!--------------------------------------------------------------------
      pert_env_r(1) = pert_env_r(1) - 0.01*pert_env_r(1)
      pert_env_r(1) = max(pert_env_r(1), 0.0)
      pert_env_t(1) = env_t(1) - 1.0

!---------------------------------------------------------------------
!    if this is a diagnostics column, output the environmental profiles
!    of temperature (pert_env_t) and vapor mixing ratio (pert_env_r) for         
!    the perturbed parcel, vertical profiles of pressure (cape_p), 
!    cumulus moisture forcing (qr_v), cumulus thermal forcing (qt_v), 
!    environmental moisture (env_r) and temperature (env_t) for the
!    unperturbed parcel, parcel temperature (parcel_t) and moisture 
!    (parcel_r) for the unperturbed parcel, cumulus condensate forcing 
!    (qli0 and qli1), ice condensate (ri_v) and liquid condensate (rl_v).
!---------------------------------------------------------------------
     if (debug_ijt) then
       do k=1,nlev_parcel
         write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)')   &
                     'press, temp, vapor in cape: k, p,t,r = ',  &
                           k, cape_p(k), pert_env_t(k), pert_env_r(k)
       end do
       do k=1,nlev_parcel
         if (qr_v(k) /= 0.0 .or. qt_v(k) /= 0.0) then
             write (diag_unit, '(a, i4, f19.10, 3e20.12, f20.14)') &
                   'in cuclo: k,p,qr,qt,r,t  =', k,  &
                     cape_p(k), qr_v(k), qt_v(k), env_r(k), env_t(k)
         endif
       end do
       do k=1,nlev_parcel
         write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)') &
                     'in cuclo: k,p,tpc, rpc   =', k,   &
                          cape_p(k), parcel_t(k), parcel_r(k)
       end do
       do k=1,nlev_parcel
         if (qli0_v(k) /= 0.0 .or. qli1_v(k) /= 0.0 .or. &
                ri_v(k) /= 0.0 .or. rl_v(k) /= 0.0) then
           write (diag_unit, '(a, i4, f19.10, 4e20.12)')   &
                  'in cuclo: k,p,qli0,qli1,ri,rl =', k,  &
                      cape_p(k), qli0_v(k), qli1_v(k), ri_v(k), rl_v(k)
         endif
       end do
     endif

     if (Nml%do_hires_cape_for_closure) then
 
      if (Nml%do_donner_cape) then
!  there is an existing parcel profiles; it should be same if these 
!  conditions all met so it need not be recalculated.
      if (Nml%do_freezing_for_cape .NEQV. Nml%do_freezing_for_closure .or. &
          Nml%tfre_for_cape /= Nml%tfre_for_closure .or. &
          Nml%dfre_for_cape /= Nml%dfre_for_closure .or. &
          .not. (Initialized%use_constant_rmuz_for_closure) .or.  &
          Nml%rmuz_for_cape /= Nml%rmuz_for_closure) then
           call don_c_displace_parcel_k   &
               (nlev_parcel, diag_unit, debug_ijt, Param,  &
                Nml%do_freezing_for_closure, Nml%tfre_for_closure, &
                Nml%dfre_for_closure, Nml%rmuz_for_closure,  &
                Initialized%use_constant_rmuz_for_closure,  &
                Nml%modify_closure_plume_condensate, &
                Nml%closure_plume_condensate, &
                env_t,  &
                env_r, cape_p, .false., plfc, plzb, plcl, dumcoin,  &
                dumxcape, parcel_r_clo,  parcel_t_clo, ermesg, error)
     else
      parcel_r_clo = parcel_r
       parcel_t_clo = parcel_t
     endif

  else  ! (do_donner_cape)
!   no existing parcel profiles
!    want to use hires cape calc for closure, but used lores cape calc 
!    for convection
          call don_c_displace_parcel_k   &
                (nlev_parcel, diag_unit, debug_ijt, Param,  &
                 Nml%do_freezing_for_closure, Nml%tfre_for_closure, &
                 Nml%dfre_for_closure, Nml%rmuz_for_closure,   &
                 Initialized%use_constant_rmuz_for_closure,  &
                 Nml%modify_closure_plume_condensate, &
                 Nml%closure_plume_condensate, &
                 env_t,  &
                 env_r, cape_p, .false., plfc, plzb, plcl, dumcoin,  &
                 dumxcape, parcel_r_clo,  parcel_t_clo, ermesg, error)
  endif  ! (do_donner_cape)

!--------------------------------------------------------------------
!    call subroutine displace_parcel to determine the movement of a 
!    parcel from the lcl through the environment defined by 
!    (pert_env_t, pert_env_r). set return_cape to indicate if cape
!    value is to be returned.
!    don't need to calculate cape when using Zhang closure 
!    (do_dcape is .true). 
!    if using cape relaxation closure then need to return cape value.
!--------------------------------------------------------------------
      return_cape = .not. (Nml%do_dcape)
      call don_c_displace_parcel_k   &
             (nlev_parcel, diag_unit, debug_ijt, Param,   &
             Nml%do_freezing_for_closure, Nml%tfre_for_closure, &
             Nml%dfre_for_closure, Nml%rmuz_for_closure, &
             Initialized%use_constant_rmuz_for_closure,   &
             Nml%modify_closure_plume_condensate, &
             Nml%closure_plume_condensate, &
             pert_env_t, pert_env_r, cape_p, return_cape, &
             plfc, plzb, plcl, dumcoin,  &
             dumxcape, pert_parcel_r,  pert_parcel_t, ermesg, error)
      if (return_cape) ac%cape = dumxcape
  
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
     if (error /= 0 ) return


!---------------------------------------------------------------------
!    define quantities needed for cape relaxation closure option.
!---------------------------------------------------------------------
     if ( .not. Nml%do_dcape) then
       cape_c = Nml%cape0
       tau    = Nml%tau
       if (Nml%do_lands) then
         
        if (Nml%do_capetau_land) then
         !cape_c = Nml%cape0 * (1. - sd%land * (1. - Nml%lofactor0))
         if (Nml%lochoice > 3) then
           lofactor = 1.
         else
           error = 1
           ermesg = 'unsupported value of lofactor for do_hires_cape'
           return
         endif
         cape_c = Nml%cape0 * lofactor
         tau    = Nml%tau   * lofactor
       endif
     endif
     if (Nml%do_rh_trig) then
         error = 2
         ermesg = 'do_rh_trig not currently supported for do_hires_cape'
         return
!       rhavg=0.; dpsum=0.
!       do k = 1,sd%kmax
!         if (sd%p(k) .gt. Nml%plev0) then
!           rhavg  = rhavg + sd%rh(k)*sd%dp(k)
!           dpsum = dpsum + sd%dp(k)
!         end if
!       end do
!       rhavg = rhavg/dpsum
!       ctrig = rhavg > Nml%rhavg0
     else
       ctrig= .true.
     endif
     endif

   else  ! (do_hires_cape)
 
!  no hires cape calculation for closure; standard donner_lite path
 
!--------------------------------------------------------------------
!    call subroutine displace_parcel to determine the movement of a 
!    parcel from the lcl through the environment defined by 
!    (pert_env_t, pert_env_r).
!--------------------------------------------------------------------
     call pack_sd_lsm_k      &
               (Nml%do_lands, land, coldT, dt, pfull, phalf, zfull,  &
                zhalf, ttt, rrr, tracers, sd)
      call extend_sd_k (sd, pblht, .false., Uw_p)
      zsrc  =sd%zs (1)
      psrc  =sd%ps (1)
      thcsrc=sd%thc(1)
      qctsrc=sd%qct(1)
      hlsrc =sd%hl (1)
      cape_c = Nml%cape0 
      tau    = Nml%tau
      if (Nml%do_lands) then
        call qt_parcel_k (sd%qs(1), qstar, pblht, tkemiz, sd%land, &
             Nml%gama, Nml%pblht0, Nml%tke0, Nml%lofactor0, Nml%lochoice, qctsrc, lofactor)      
        if (Nml%do_capetau_land) then
          !cape_c = Nml%cape0 * (1. - sd%land * (1. - Nml%lofactor0))
          cape_c = Nml%cape0 * lofactor
          tau    = Nml%tau   * lofactor
        end if
      endif
      if (Nml%do_rh_trig) then
        rhavg=0.; dpsum=0.
        do k = 1,sd%kmax
          if (sd%p(k) .gt. Nml%plev0) then
            rhavg  = rhavg + sd%rh(k)*sd%dp(k)
            dpsum = dpsum + sd%dp(k)
          end if
        end do
        rhavg = rhavg/dpsum
        ctrig= rhavg .gt. Nml%rhavg0
      else
        ctrig=.true.
      end if

      call adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, Uw_p, &
                       .false., Nml%do_freezing_for_closure, ac)
     parcel_r_clo=ac%qv(:)/(1.-ac%qv(:))
     parcel_t_clo=ac%t (:)

     sd%t(1) =sd%t (1)-1.0
     sd%qv(1)=0.99*(sd%qv(1)/(1. - sd%qv(1)))

     call adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, Uw_p, &
                       .false., Nml%do_freezing_for_closure, ac) 
      pert_parcel_r=ac%qv(:)/(1.-ac%qv(:))
      pert_parcel_t=ac%t (:)
!miz

  endif ! (hires cape)
 

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    if in a diagnostics column, output the path of the parcel (T, p
!    coordinates).
!---------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_parcel
          write (diag_unit, '(a, i4, f20.14, e20.12)')  &
                      'in cuclo: k,tpca,rpca= ', k,    &
                                 pert_parcel_t(k), pert_parcel_r(k)
        end do
      endif

!---------------------------------------------------------------------
!    calculate the large-scale model profile of total-water mixing 
!    ratio. 
!---------------------------------------------------------------------
        do k=1,nlev_parcel
        rt(k) = env_r(k) + ri_v(k) + rl_v(k)
      end do

!----------------------------------------------------------------------
!    calculate profiles of density temperatures, in the parcel (tden) 
!    and in the perturbed parcel (tdena). condensate is not included in
!    this definition of density temperature.
!----------------------------------------------------------------------
      do k=1,nlev_parcel
        tden(k)  = parcel_t_clo(k)*(1. + (parcel_r_clo(k)/Param%d622)) 
        tdena(k) = pert_parcel_t(k)*(1. + (pert_parcel_r(k)/Param%d622))
      end do

!---------------------------------------------------------------------
!    define the values of density temperature in the environment at the
!    lowest level of the standard parcel displacement case (tdens) and 
!    for the displacement within the perturbed environment (tdensa).
!---------------------------------------------------------------------
      tdens  = env_t(1)*(1. + (env_r(1)/Param%d622))
      tdensa = pert_env_t(1)*(1. + (pert_env_r(1)/Param%d622))

!----------------------------------------------------------------------
!    evaluate derivative of parcel density temperature w.r.t. cloud-base
!    level environmental density temperature.
!----------------------------------------------------------------------
      do k=1,nlev_parcel
        dtpdta(k) = (tdena(k) - tden(k))/(tdensa - tdens)
      end do

!---------------------------------------------------------------------
!    if this is a diagnostics column, output the profiles of unperturbed
!    parcel density temperature (tden) and the perturbed parcel density 
!    temperature (tdena) and the derivative of parcel density temper-
!    ature w.r.t. cloud-base large-scale density temperature (dtpdta).
!------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_parcel
          write (diag_unit, '(a, i4, 2f20.14, e20.12)')  &
                    'in cuclo: k,tden(k),tdena(k),dtpdta(k)= ',   &
                          k,tden(k), tdena(k),dtpdta(k)
        end do
     endif

!--------------------------------------------------------------------
!    calculate the I1 and I2 integrals from p. 5 of "Cu Closure D" 
!    notes.
!--------------------------------------------------------------------
!--------------------------------------------------------------------
!    define values at the cloud-base level.
!--------------------------------------------------------------------
      rild = qt_v(1)*(Param%d622 + env_r(1))/(Param%d622*(1. + rt(1)))
      rile = env_t(1)*(1. + rl_v(1) + ri_v(1) - Param%d622)*qr_v(1)
      rile = rile/(Param%d622*((1. + rt(1))**2))
      rilf = -env_t(1)*(Param%d622 + env_r(1))*qli0_v(1)
      rilf = rilf/(Param%d622*((1. + rt(1))**2))
      ri2b = env_t(1)*(Param%d622 + env_r(1))/   &
             (Param%d622*((1. + rt(1))**2))
      ri2b = ri2b*qli1_v(1)

      if (Nml%model_levels_in_sfcbl == 0) then
        sum2 = rild + rile + rilf
      else
        sum2 = 0.
      endif


      ri1 = 0.
      ri2 = 0.
      do k=2,nlev_parcel
        if (cape_p(k) == 0.) exit       
        rilak = -qt_v(k)*(Param%d622 + env_r(k))/   &
                                     (Param%d622*(1. + rt(k)))
        rilbk = -env_t(k)*  &
                   (1. + rl_v(k) + ri_v(k) - Param%d622)*qr_v(k)
        rilbk = rilbk/(Param%d622*((1. + rt(k))**2))
        rilck = env_t(k)*(Param%d622 + env_r(k))*qli0_v(k)
        rilck = rilck/(Param%d622*((1. + rt(k))**2))
        rilakm = -qt_v(k-1)*(Param%d622 + env_r(k-1))/   &
                                          (Param%d622*(1. + rt(k-1)))
        rilbkm = -env_t(k-1)*  &
                     (1. + rl_v(k-1) + ri_v(k-1) - Param%d622)*qr_v(k-1)
        rilbkm = rilbkm/(Param%d622*((1. + rt(k-1))**2))
        rilckm = env_t(k-1)*(Param%d622 + env_r(k-1))*qli0_v(k-1)
        rilckm  =rilckm/(Param%d622*((1. + rt(k-1))**2))
        rila = .5*(rilak + rilakm)
        rilb = .5*(rilbk + rilbkm)
        rilc = .5*(rilck + rilckm)
        ri2ak = env_t(k)*(Param%d622 + env_r(k))/  &
                                         (Param%d622*((1. + rt(k))**2))
        ri2ak = ri2ak*qli1_v(k)
        ri2akm = env_t(k-1)*(Param%d622 + env_r(k-1))/ &
                                  (Param%d622*((1. + rt(k-1))**2))
        ri2akm = ri2akm*qli1_v(k-1)
        ri2a = .5*(ri2ak + ri2akm)
        sum1 = rila + rilb + rilc
        ri1 = ri1 + (alog(cape_p(k-1)/cape_p(k)))*   &
                                     (sum1 + dtpdta(k)*sum2)
        ri2 = ri2 + (alog(cape_p(k-1)/cape_p(k)))*  &
                                      (ri2a - dtpdta(k)*ri2b)

!----------------------------------------------------------------------
!    if in diagnostics column, output the 
!----------------------------------------------------------------------
        if (debug_ijt) then
          write(diag_unit, '(a, i4, e20.12)')   &
                         'in cuclo: k,dtpdta(k)= ',k,dtpdta(k)
          write (diag_unit,   '(a, 3e20.12)')  &
                          'in cuclo: rila,rilb,rilc= ', rila,rilb,rilc
          write (diag_unit, '(a, 2e20.12)')  &
                          'in cuclo: ri1,ri2= ',ri1,ri2
          write (diag_unit, '(a, 2e20.12)')  &
                        'in cuclo: sum1,sum2= ',sum1,sum2
        endif
      end do
 
!----------------------------------------------------------------------
!    if in diagnostics column, output the 
!----------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                      'in cuclo: rild,rile,rilf= ', rild, rile, rilf
        if (dcape /= 0.0) then
          write (diag_unit, '(a, e20.12)')   &
                     'in cuclo:         dcape=',  dcape
        endif
      endif

!----------------------------------------------------------------------
!----------------------------------------------------------------------
      if (ri1 >= 0) then
        a1  = 0.
      else
        ri1 = Param%rdgas*ri1
        ri2 = Param%rdgas*ri2
	  if (Nml%do_dcape .and. ctrig) then
          a1  = -(ri2 + dcape)/ri1
        else
          if (ac%cape .gt. cape_c .and. ctrig) then
            a1  = -(ri2 + (ac%cape-cape_c)/tau)/ri1
          else
            a1  = 0.
          end if
        end if
      endif

!--------------------------------------------------------------------


    end subroutine cu_clo_cumulus_closure_miz


!######################################################################
!######################################################################






subroutine don_cm_mesub_miz     &
         (Nml, pfull_c, nlev_lsm, me, diag_unit, debug_ijt, Param, cu, &
          ci_liq_cond, ci_ice_cond, pmelt_lsm, cell_precip, &
          dint, plzb_c, pb, pt_kou, temp_c, phalf_c,   &
          ca_liq, ca_ice, ecd, ecd_liq, ecd_ice, ecei_liq, &
          ece, ece_liq, ece_ice, meso_freeze, meso_melt, ermesg, error)

!----------------------------------------------------------------------
!    subroutine mesub calculates mesoscale heat and moisture sources,
!    using a variation on the Leary and Houze (JAS, 1980) procedure.
!    the defined fields are condensate transferred from cell to anvil
!    (ca), condensate evaporated in convective downdrafts (ecd), conden-
!    sate evaporated in convective updrafts (ece), the condensate 
!    entering the anvil which has not yet been frozen (meso_freeze), and 
!    the amount of condensate which must be melted in the mesoscale down-
!    draft to assure ice conservation (meso_melt). the subroutine is 
!    called separately for each ensemble member. for notation, see 
!    "Cu Closure A notes," 2/97.
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type

implicit none

!----------------------------------------------------------------------
type(donner_nml_type),         intent(in)    :: Nml
integer,                       intent(in)    :: nlev_lsm, me, diag_unit
logical,                       intent(in)    :: debug_ijt
type(donner_param_type),       intent(in)    :: Param
real,                          intent(in)    :: cu, cell_precip, dint, &
                                                plzb_c, pb, pt_kou
real,   dimension(nlev_lsm),   intent(in)    :: temp_c, pfull_c
real,   dimension(nlev_lsm+1), intent(in)    :: phalf_c
real,                          intent(out)   :: ca_liq, ca_ice
real,                          intent(in)    :: pmelt_lsm
real,                          intent(in)    :: ci_liq_cond, &
                                                ci_ice_cond
real,   dimension(nlev_lsm),   intent(out)   :: ecd, ece, meso_freeze, &
                                                meso_melt, &
                                                ecd_liq, ecd_ice, &
                                                ece_liq, ece_ice
real,                          intent(out)   :: ecei_liq
character(len=*),              intent(out)   :: ermesg
integer,                       intent(out)   :: error
!---------------------------------------------------------------------
!   intent(in) variables:
!
!       cu           column integrated condensation integral
!                    [ mm / day ]
!       cell_precip  column integrated precipitation integral
!                    [ mm / day ]
!       dint??       water mass frozen in convective updraft
!            ??????  plus ice deposited convective updraft
!                    [ kg(h2o) /( (m**2) sec) ]
!                    weighted as cu,cell_precip
!       plzb_c       pressure at level of zero buoyancy [ Pa ]
!       ps           surface pressure [ Pa ]
!       pb           cloud-base pressure [ Pa ]
!       pt_kou       cloud-top pressure [ Pa ]
!       pmelt_lsm    pressure at bottom of layer in which melting 
!                    begins   [ Pa ]
!       phalf_c      large-scale model pressure half-levels (Pa)
!       debug_ijt    is this a diagnostics column ?
!       diag_unit    output unit number for this diagnostics column
!
!   intent(out) variables:
!
!       ca           total condensate transfered from cells to anvil 
!                    by this ensemble member [ mm/day ]
!       ecd          profile of condensate evaporated in convective
!                    downdraft on large-scale model grid 
!                    [ g(h2o) / kg(air) / day ] 
!       ece          profile of condensate evaporated in convective 
!                    updraft on large-scale model grid 
!                    [ g(h2o) / kg(air) / day ] 
!       meso_freeze  profile of condensate which is frozen upon enter-
!                    ing the anvil on the large-scale grid
!                    [ g(h2o) / kg(air) / day ] 
!       meso_melt    profile of condensate which is melted in mesoscale
!                    downdraft on large-scale model grid
!                    [ g(h2o) / kg(air) / day ] 
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
 
      integer ::     k
      real    ::  avail_meso_cd     ! fraction of column integrated
                                    ! condensation available to meso-
                                    ! scale circulation (1. - gnu)
                                    ! [ dimensionless ]
      real    ::  caa               ! amount of condensate which must
                                    ! be frozen when it enters the anvil
                                    ! [ g(h2o) / kg(air) / day ]
      real    ::  dint2             ! amount of condensate which has
                                    ! been frozen in the cumulus updraft
                                    ! before entering the anvil
                                    ! [ g(h2o) / kg(air) / day ]
      real    ::  ecda              ! amount of condensate evaporated 
                                    ! in cumulus downdrafts
                                    ! [ g(h2o) / kg(air) / day ]
      real :: ecda_liq, ecda_ice
      real    ::  ecdi              ! amount of condensate evaporated 
                                    ! in cumulus downdrafts [ mm / day ]
      real :: ecdi_liq, ecdi_ice
      real    ::  ecea              ! amount of condensate evaporated 
                                    ! in cumulus updrafts 
                                    ! [ g(h2o) / kg(air) / day ]
      real :: ecea_liq, ecea_ice
      real    ::  ecei              ! amount of condensate evaporated 
                                    ! in cumulus updrafts [ mm / day ]
      real ::           ecei_ice
      real    ::  elta              ! amount of condensate which must
                                    ! be melted in the mesoscale down-
                                    ! draft to conserve ice mass
                                    ! [ g(h2o) / kg(air) / day ]
      real    ::  gnu               ! fraction of column integrated 
                                    ! condensation which precipitates
                                    ! out [ dimensionless ]
      real    ::  ptt               ! pressure one cloud model delta p 
                                    ! above cloud top [ Pa ]
      real    ::  pzm               ! pressure at base of mesoscale 
                                    ! circulation [ Pa ]
      real    ::  pztm              ! pressure at top of mesoscale cir-
                                    ! culation [ Pa ]
      real    ::  p1                ! lower pressure limit for the layer
                                    ! in which one of the physical
                                    ! processes is occurring [ Pa ]
      real    ::  p2                ! upper pressure limit for the layer
                                    ! in which one of the physical
                                    ! processes is occurring [ Pa ]
      integer  :: itrop
      real :: ptrop

!---------------------------------------------------------------------
!   local variables:
!
!      
      ermesg = '  ' ; error = 0

!---------------------------------------------------------------------
!    define pressure one cloud-model level above cloud top (ptt). 
!    define the pressure at top of mesoscale updraft (pztm, 300 hPa 
!    plus one model-layer pressure thickness above cloud top).
!---------------------------------------------------------------------
      ptt = pt_kou + Param%dp_of_cloud_model
      pztm = ptt - 300.E02

!---------------------------------------------------------------------
!    restrict pztm to >= 100 hPa, cf Ackerman et al (JAS,1988), unless 
!    pt_kou <= 100 hPa. it was found in AM2p9 that the stratospheric 
!    water vapor was excessive with this pztm restriction, so pztm is now
!    set to be no higher than the level of zero buoyancy, or if the
!    cloud top is above the level of zero buoyancy, it is set to one 
!    model layer above the level of zero buoyancy. 
!---------------------------------------------------------------------
      if (pztm < plzb_c) pztm = plzb_c
      if (ptt < plzb_c)  pztm = plzb_c + Param%dp_of_cloud_model

      if (Nml%limit_pztm_to_tropo) then
        call find_tropopause (nlev_lsm, temp_c, pfull_c, ptrop, itrop)
        pztm = MAX (pztm, ptrop)
      endif

!---------------------------------------------------------------------
!    define the base of the mesoscale updraft (pzm), as the layer imm-
!    ediately above cloud top, or, if the top of the mesoscale updraft
!    has been redefined to be at or just above the level of zero 
!    buoyancy, to be one layer below the mesoscale updraft top. 
!---------------------------------------------------------------------
      pzm = ptt
      if (pzm <= pztm) pzm = pztm - Param%dp_of_cloud_model

!---------------------------------------------------------------------
!    if in a diagnostics column, output the convective rain 
!    (cell_precip), convective updraft condensation (cu), and the pres-
!    sure at the level of zero buoyancy (plzb_c).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)') 'in mesub: rc,cu= ',  &
                                                     cell_precip, cu
        write (diag_unit, '(a,  e20.12)') 'in mesub: plzb = ',plzb_c
      endif

!----------------------------------------------------------------------
!    define the ratio of precipitation to condensation for the current
!    ensemble member (gnu). define the remaining fraction of condens-
!    ation 1 - gnu as the condensate available to the mesoscale circ-
!    ulation (avail_meso_cd). define the mass of this available conden-
!    sate which is evaporated in convective downdrafts (ecdi), the mass
!    evaporated into the cell environment (ecei) and the portion incor-
!    porated into the mesoscale region (ca). this partitioning is 
!    defined by the parameters evap_in_downdraft, evap_in_environ and 
!    entrained_into_meso, taken from the work of Leary and Houze 
!    (JAS, 1980).
!----------------------------------------------------------------------
      gnu = cell_precip/cu
      avail_meso_cd = 1. - gnu
      ecdi  = (Param%evap_in_downdrafts*avail_meso_cd)*cu
      ecdi_liq  = (Param%evap_in_downdrafts*avail_meso_cd)*  &
                       (Param%seconds_per_day*ci_liq_cond)
      ecdi_ice  = (Param%evap_in_downdrafts*avail_meso_cd)* &
                       (Param%seconds_per_day*ci_ice_cond)
      ecei  = (Param%evap_in_environ*avail_meso_cd)*cu
      ecei_liq  = (Param%evap_in_environ*avail_meso_cd)*  &
                       (Param%seconds_per_day*ci_liq_cond)
      ecei_ice  = (Param%evap_in_environ*avail_meso_cd)*   &
                       (Param%seconds_per_day*ci_ice_cond)
      ca_liq    = (Param%entrained_into_meso*avail_meso_cd)*  &
                       (Param%seconds_per_day*ci_liq_cond)
      ca_ice    = (Param%entrained_into_meso*avail_meso_cd)*  &
                       (Param%seconds_per_day*ci_ice_cond)
     if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
             'in mesub: cu, h1_liqintg, h1_iceintg= ', &
             cu, ci_liq_cond*Param%seconds_per_day, &
                 ci_ice_cond*Param%seconds_per_day
      endif

!---------------------------------------------------------------------
!    if in a diagnostics column, output the ratio of convective rain 
!    to convective updraft condensation (gnu) and the mass entrained
!    into the mesoscale region (ca).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12)')  'in mesub: gnu= ',gnu
      write (diag_unit, '(a, e20.12)') 'in mesub: ca= ',ca_liq + ca_ice 
        write (diag_unit, '(a, 2e20.12)') 'in mesub: ca_liq,ca_ice= ', &
                                                ca_liq, ca_ice
      endif

!--------------------------------------------------------------------
!    calculate the mass of water which must be frozen as it enters the
!    mesoscale anvil (caa). if no freezing has occurred in the cumulus
!    updraft (i.e., dint2 = 0) then this will be ca, the total mass 
!    available to the anvil. if freezing has occurred, (ie, 
!    dint2 /= 0.), then the amount to be frozen is the total amount 
!    available (ca) plus additional vapor mass deposited on the ice in 
!    the updraft (ecei), less that which has already frozen (dints). 
!    dints and caa are expressed in units of g(h2o) per kg(air) per day.
!--------------------------------------------------------------------
      dint2 = avail_meso_cd*(dint)*8.64e07*Param%grav/(pzm - pztm)
 
     if (dint2 /= 0.)  then
       caa = ((ca_liq + ecei_liq)*Param%grav*1000./(pzm - pztm)) - dint2
     else
       caa = ca_liq*Param%grav*1000./(pzm - pztm)
     endif


!---------------------------------------------------------------------
!    if in a diagnostics column, output the previously frozen condensate
!    (dint2), the additional amount to be frozen (caa) and the pressure
!    range over which the freezing will occur (pzm, pztm). if 
!---------------------------------------------------------------------
       if (debug_ijt) then
         write (diag_unit, '(a,  e20.12)')  &
                         'in mesub:     dint           =',    dint 
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub:     dint2, ecei_liq=',    dint2, &
                                                         ecei_liq
        write (diag_unit, '(a, 3e20.12)')  &
                           'in mesub: caa,pzm,pztm= ',caa,pzm,pztm
    endif

!---------------------------------------------------------------------
!    if there is additional condensate which must be frozen upon enter-
!    ing the anvil, call map_hi_res_intgl_to_lo_res_col to spread this 
!    additional freezing uniformly over the region between anvil base 
!    (pzm) and anvil top (pztm) in the large-scale model. store the out-
!    put in array meso_freeze. if no additional freezing is needed, set 
!    meso_freeze to be 0.0.
!---------------------------------------------------------------------
      if (caa > 0.)  then 
        if (debug_ijt) then
          write (diag_unit, '(a, e20.12, 2f19.10)')  &
                       'in cm_intgl_to_gcm_col: xav,p1,p2= ',caa, pzm, &
                                                    pztm
        endif
        call don_u_map_hires_i_to_lores_c_k   &
             (nlev_lsm, caa, pzm, pztm, phalf_c, meso_freeze, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
        if (debug_ijt) then
          do k=1,nlev_lsm
            if (meso_freeze(k) /= 0.0) then
              write (diag_unit, '(a, i4, e20.12)') &
                    'in cm_intgl_to_gcm_col: k,x= ',k, meso_freeze   (k)
            endif
          end do
        endif
      else
        meso_freeze = 0.
      endif

!---------------------------------------------------------------------
!    define the evaporation which occurs in the convective downdraft.
!    the convective downdraft is assumed to originate one layer above
!    the cloud top (ptt) and extend to the surface (phalf_c(1)). 
!    convert the convective downdraft evaporation to units of
!    g(h20) / kg(air) per day.
!---------------------------------------------------------------------
      ecda = ecdi*Param%grav*1000./(phalf_c(1) - ptt)
      ecda_liq = ecdi_liq*Param%grav*1000./(phalf_c(1) - ptt)
      ecda_ice = ecdi_ice*Param%grav*1000./(phalf_c(1) - ptt)

!---------------------------------------------------------------------
!    if in a diagnostics column, output the convective downdraft evap-
!    oration (ecda) and the large-scale model pressure limits over which
!    this evaporation occurs (phalf_c(1), ptt).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 3e20.12)')  &
                          'in mesub: ecda,p1,pz0= ',ecda,phalf_c(1),ptt
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub: ecda_liq, ecda_ice= ',  &
                                 ecda_liq, ecda_ice
     endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to spread the integrated evap-
!    oration in convective downdrafts uniformly over the region between
!    the surface (phalf_c(1)) and the anvil base (pzm) and the top of 
!    cloud (ptt). output field is ecd.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
             'in cm_intgl_to_gcm_col: xav,p1,p2= ',ecda, phalf_c(1) , &
                                                   ptt
      endif
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecda, phalf_c(1), ptt, phalf_c, ecd, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
         (nlev_lsm, ecda_liq, phalf_c(1), ptt, phalf_c, ecd_liq, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
         (nlev_lsm, ecda_ice, phalf_c(1), ptt, phalf_c, ecd_ice, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      if (debug_ijt) then
        do k=1,nlev_lsm
          if (ecd(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                           'in cm_intgl_to_gcm_col: k,x= ',k, ecd   (k)
            write (diag_unit, '(a, i4, 2e20.12)') &
              'in cm_intgl_to_gcm_col: k,ecdliq,ecdice= ',k, &
                       ecd_liq(k), ecd_ice(k)
          endif
        end do
      endif

!---------------------------------------------------------------------
!    be sure that the melting level in the large-scale model (pmelt_lsm)
!    is below the top of the mesoscale circulation (pztm),and above
!    cloud base (pb). if not, no melting will occur; set p2 to be 0.0.
!---------------------------------------------------------------------
      elta = 0.
      if (pmelt_lsm  < pztm                    )  then
        meso_melt = 0.
        if (debug_ijt) then
          write (diag_unit, '(a, 2f19.10)') &
                 ' NO MELTING DONE: melting level above top of &
                    &mesoscale circulation : pmelt_lsm,pztm',     &
                                                pmelt_lsm, pztm      
        endif

!---------------------------------------------------------------------
!    if pmelt_lsm is within the region of the cloud and mesoscale circ-
!    ulation, calculate any melting that must occur in the mesoscale
!    downdraft in order to conserve ice mass; ie, if the amount to be
!    frozen was calculated as more than the available condensate, then
!    the excess must be melted, and is done so in the mesoscale down-
!    draft between the melting level and cloud base.
!---------------------------------------------------------------------
      else if (pmelt_lsm >= pztm .and. pmelt_lsm <= pb) then
        p2 = pmelt_lsm
        p1 = pb
        if (caa <= 0.) then 
          caa = -caa*(pzm - pztm)/(pb - p2)
          elta = caa
        endif
      if (debug_ijt) then
        write (diag_unit, '(a, 3f19.10)') &
                   'MELTING DONE: pmelt_lsm,pb,caa',pmelt_lsm, pb, &
                                                            caa  
      endif
!---------------------------------------------------------------------
!    if in diagnostics column, output the melting (elta) and the 
!    pressures defining the layer in which it occurs (pb, p2)
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, 2f19.10)') &
                           'in mesub: elta,p1,p2= ',elta,p1,p2
      endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to spread the required melting
!    resulting from excessive freezing over the layer between cloud base
!    and the melting level. output field is meso_melt.
!---------------------------------------------------------------------
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, elta, p1, p2, phalf_c, meso_melt, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      if (debug_ijt) then
        do k=1,nlev_lsm       
          if (meso_melt(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                 'in cm_intgl_to_gcm_col: k,meso_melt= ',k, meso_melt(k)
          endif
        end do
      endif

      else if (pmelt_lsm > pb) then
        meso_melt = 0.
        if (pmelt_lsm == phalf_c(1)) then
          if (debug_ijt) then
             write (diag_unit, '(a)') &
                   'NO MELTING LEVEL PRESENT IN COLUMN'
          endif
        else
! melt below cloud base 
          if (debug_ijt) then
            write (diag_unit, '(a, 2f19.10)') &
            ' NO MELTING DONE: melting level below PB: pmelt_lsm,pb', &
                                                      pmelt_lsm, pb
      endif
      endif
      endif ! (pmelt<pztm or pmelt > pb)


!---------------------------------------------------------------------
!    calculate the evaporation which occurs in the convective 
!    updraft.
!    this is spread between 50 hPa below cloud top and 10 hPa above 
!    cloud top.
!---------------------------------------------------------------------
      p1 = pt_kou + 50.0e02
      p2 = ptt
      ecea = ecei*Param%grav*1000./(p1-p2)
      ecea_liq = ecei_liq*Param%grav*1000./(p1-p2)
      ecea_ice = ecei_ice*Param%grav*1000./(p1-p2)

!---------------------------------------------------------------------
!    if in diagnostics column, output the convective updraft evaporation
!    (ecea, ecei) and the large-scale model pressure layer limits over 
!    which it occurs (p1, p2).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                           'in mesub: ecea,ecei= ',ecea, ecei
        write (diag_unit, '(a, 2e20.12)')  &
                         'in mesub: LIQecea,ecei= ',ecea_liq, ecei_liq
         write (diag_unit, '(a, 2e20.12)')  &
                          'in mesub: ICEecea,ecei= ',ecea_ice, ecei_ice
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
                           'in mesub: ecea,p1,p2= ',ecea, p1, p2
     endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to spread the integrated evap-
!    oration in convective updrafts uniformly over the designated 
!    region.  output field is ece.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, 2f19.10)')  &
                       'in cm_intgl_to_gcm_col: xav,p1,p2= ',ecea, p1, &
                                                  p2
      endif
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecea, p1, p2, phalf_c, ece, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecea_liq, p1, p2, phalf_c, ece_liq, ermesg, error)
     call don_u_map_hires_i_to_lores_c_k   &
           (nlev_lsm, ecea_ice, p1, p2, phalf_c, ece_ice, ermesg, error)

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      if (debug_ijt) then
        do k=1,nlev_lsm
          if (ece(k) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                           'in cm_intgl_to_gcm_col: k,x= ',k, ece   (k)
          endif
        end do
      endif

!---------------------------------------------------------------------


end subroutine don_cm_mesub_miz

!#######################################################################
!#######################################################################

subroutine don_m_meso_effects_miz    &
         (me, nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, Param, Nml,&
          pfull_c, temp_c, mixing_ratio_c, phalf_c, rlsm, emsm, etsm, &
          tracers_c, ensembl_cond, ensmbl_precip, pb, plzb_c, pt_ens, &
          ampta1, ensembl_anvil_cond_liq, ensembl_anvil_cond_liq_frz, &
          ensembl_anvil_cond_ice,  &
          wtp, qtmes, meso_frz_intg_sum, anvil_precip_melt, &
          meso_cloud_area, cmus_tot, dmeml, emds_liq, emds_ice, &
          emes_liq, emes_ice, wmms, wmps, &
          umeml, temptr, tmes, tmes_up, tmes_dn, mrmes, mrmes_up, &
          mrmes_dn, emdi, pmd, pztm, pzm, meso_precip, ermesg, error)

!-------------------------------------------------------------------
!    subroutine don_m_meso_effects_k obtains the mesoscale effects
!    of the composited cloud ensemble on the heat, moisture and tracer 
!    budgets, producing tendency terms which are to be applied to the 
!    large-scale model equations. the scheme employed here is a variation
!    on the procedure of Leary and Houze (JAS, 1980). for more details 
!    on notation, see "Cu Closure A notes," 2/97.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type

implicit none

!-------------------------------------------------------------------
integer,                           intent(in)  :: me, nlev_lsm, nlev_hires, &
                                                  ntr, diag_unit
logical,                           intent(in)  :: debug_ijt        
type(donner_param_type),           intent(in)  :: Param
type(donner_nml_type),             intent(in)  :: Nml  
real,   dimension(nlev_lsm),       intent(in)  :: pfull_c, temp_c, &
                                                  mixing_ratio_c
real,   dimension(nlev_lsm+1),     intent(in)  :: phalf_c, rlsm,  &
                                                  emsm, etsm !miz
real,   dimension(nlev_lsm,ntr),   intent(in)  :: tracers_c
logical,                           intent(in)  :: meso_frz_intg_sum 
real,                              intent(in)  :: ensembl_cond,   &
                                                  ensmbl_precip, pb, &
                                                  plzb_c, pt_ens,   &
                                                  ampta1, &
                                            ensembl_anvil_cond_liq, &
                                        ensembl_anvil_cond_liq_frz, &
                                                  ensembl_anvil_cond_ice
real,   dimension(nlev_lsm,ntr),   intent(out) :: wtp, qtmes, temptr
real,   dimension(nlev_lsm),       intent(out) :: anvil_precip_melt, &
                                                  meso_cloud_area,    &
                                                  cmus_tot, dmeml,  &
                                                  emds_liq, emds_ice, &
                                                  emes_liq, emes_ice, &
                                                  mrmes_up, mrmes_dn, &
                                                   tmes_up, tmes_dn, &
                                                        wmms, wmps,   &
                                                  umeml, tmes, mrmes
real,                              intent(out) ::  emdi,pmd, pztm, pzm,&
                                                  meso_precip
character(len=*),                  intent(out) :: ermesg
integer,                           intent(out) :: error
!----------------------------------------------------------------------
!   intent(in) variables:
!
!       pfull_c      large-scale model pressure full levels [ Pa ]
!       phalf_c      large-scale model pressure half levels [ Pa ]
!       temp_c       large-scale model temperature profile [ deg K ]
!       mixing_ratio_c  
!                    large-scale model mixing ratio profile
!                    [ kg(h2o) / kg(air) ]
!       rlsm         cloud model condensation profile summed over
!                    cloud ensemble
!                    [ kg(h2o) / kg(air) / sec ]
!       emsm         cloud model moisture flux convergence summed over 
!                    the cloud ensemble
!                    [ kg(h2o) / kg(air) / sec ]
!       etsm         cloud model tracer flux convergence summed over
!                    the cloud ensemble 
!                    [ kg(tracer) / kg(air) / sec ]
!       tracers_c    large-scale model tracer mixing ratio profiles
!                    [ kg(tracer) /kg(air) ]
!       ensmbl_cond  total ensemble condensation integral
!                    [ mm / day ]
!       ensmbl_precip   total ensemble precipitation integral
!                    [ mm / day ]
!       ps           surface pressure [ Pa ]
!       pb           cloud-base pressure [ Pa ]
!       plzb_c       level of zero buoyancy [ Pa ]
!       pt_ens       cloud-top pressure [ Pa ]
!       ampta1       fractional area of mesoscale anvil
!                    [ dimensionless ]
!       ensembl_anvil_cond 
!                    condensed water transferred from cells to anvil 
!                    [ mm / day ]
!       debug_ijt    is this a diagnostics column ?
!       diag_unit    output unit number for this diagnostics column
!
!  output variables:
! 
!       meso_cloud_area 
!               fractional mesoscale area, normalized by
!               a(1,p_b) at resolution of GCM
!       meso_precip
!       cmu     water mass condensed in mesoscale updraft
!               (g/kg/day) (normalized by a(1,p_b))
!       cmui    vertical integral of mesoscale-updraft deposition
!               (kg(H2O)/((m**2)*sec) 
!       dmeml   mass flux in mesoscale downdraft (kg/((m**2) s))
!               (normalized by a(1,p_b)) (index 1 at atmosphere bottom)
!               (resolution of GCM)
!       emds    water mass evaporated in mesoscale
!               downdraft (g/kg/day) (normalized by a(1,p_b))
!       emdi    vertical integral of mesoscale-downdraft sublimation
!               (mm/d)
!       emes    water mass evaporated from mesoscale
!               updraft (g/kg/day) (normalized by a(1,p_b))
!       emei    vertical integral of mesoscale-updraft sublimation
!               (kg(h2O)/((m**2)*sec)
!       pmd     pressure at top of mesoscale downdraft (Pa)
!       pztm    pressure at top of mesoscale updraft (Pa)
!       wmms    water vapor removal by condensation of
!               cell vapor source (g/kg/day) (normalized by a(1,p_b))
!       wmps    water vapor redistributed from cell vapor source
!               (g/kg/day) (normalized by a(1,p_b))
!       wtp     tracer redistributed by mesoscale processes
!               (kg/kg/s) (normalized by a(1,p_b))
!       anvil_precip_melt     melting of ice in mesoscale updraft-
!               equivalent (g/kg/day)-which falls as meso sfc precip
!               (normalized by a(1,p_b))
!       tmes    temperature tendency due to mesoscale entropy-flux-
!               convergence (K/day) (normalized by a(1,p_b))
!       mrmes    moisture tendency due to mesoscale moisture-flux
!               convergence (g/kg/day) (normalized by a(1,p_b))
!       qtmes   tracer tendency due to mesoscale tracer-flux
!               convergence (kg/kg/s) (normalized by a(1,p_b))
!       umeml   mass flux in mesoscale updraft (kg/((m**2) s))
!               (normalized by a(1,p_b)) (index 1 at atmosphere bottom)
!               (resolution of GCM)
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (nlev_lsm)     ::  cmu                    
      real, dimension (nlev_lsm)     ::  out                    
      real, dimension (nlev_hires)   ::  p_hires
      real                           ::  alp, hfmin, cmui, qtmesum, dp,&
                                         available_condensate, &
                                         available_condensate_liq, &
                                         available_condensate_ice
      real  :: emdi_liq, emdi_ice
      real  :: intgl_lo, intgl_hi
      integer                        ::  k, kcont, itrop
      real          :: p2, ptrop

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      emes_liq = 0.
      emes_ice = 0.
      emdi_liq = 0.
      emdi_ice = 0.
      dp = Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    define the pressure at the melting level (p2).
!--------------------------------------------------------------------
      p2 = -10.
      do k=1,nlev_lsm-1
         if ((temp_c(k) >= Param%kelvin) .and.   &
              (temp_c(k+1) <= Param%kelvin))  then
           p2 = phalf_c(k+1)
           exit
        end if
      end do

!---------------------------------------------------------------------
!    if in diagnostics column, output message indicating that sub-
!    routine meso_effects has been entered.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a)') 'in meens: entering meens'
      endif

!--------------------------------------------------------------------
!    define the pressure at the top of the mesoscale updraft (pztm) to 
!    be the pressure at the zero buyancy level, unless the cloud top is
!    above 100 hPa, in which case pztm is set to be one level above the 
!    level of zero buoyancy.  previously pztm was restricted to be  >=
!    100 hPa, cf Ackerman et al (JAS,1988), unless pt_ens <= 10kPa. 
!    result was that stratospheric water vapor was transported too high 
!    in AM2p9 with this pztm, so the constraint was changed to pztm >= 
!    plzb_c + dp
!--------------------------------------------------------------------
      if ((pt_ens + dp) >= 10.e03)  then
        pztm = plzb_c
      else
        pztm = plzb_c + dp
      endif

      if (Nml%limit_pztm_to_tropo) then
        call find_tropopause (nlev_lsm, temp_c, pfull_c, ptrop, itrop)
        pztm = MAX (pztm, ptrop)
      endif
!---------------------------------------------------------------------
!    if in diagnostics column, output the pressure at top of meso-
!    scale circulation (pztm) and the precipitation efficiency 
!    (ensmbl_precip/ensembl_cond).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a,  e20.12)') 'in meens: pztm = ',pztm
        write (diag_unit, '(a, e20.12)') 'in meens: gnu= ',   &
                                            ensmbl_precip/ensembl_cond
      endif

!---------------------------------------------------------------------
!    define the pressure at the vertical grid levels of the cloud model
!    grid.
!---------------------------------------------------------------------
      do k=1,nlev_hires        
        p_hires(k) = pb + (k-1)*dp
      end do

!---------------------------------------------------------------------
!    call subroutine meso_updraft to define the needed output fields 
!    associated with the mesoscale updraft.
!---------------------------------------------------------------------
      call don_m_meso_updraft_miz   &
           (nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, Param, &
            pfull_c, rlsm, emsm, etsm, pfull_c,  &
             temp_c, mixing_ratio_c, phalf_c, tracers_c,  &
              pb, pt_ens, ampta1, dp, pztm,  wtp, &
                  qtmes, cmu, wmms, wmps, temptr, tmes_up, mrmes_up,   &
                  meso_cloud_area, umeml,&
                  alp, pzm, hfmin, cmui, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (Nml%frc_internal_enthalpy_conserv) then
!-----------------------------------------------------------------------
!    call don_u_set_column_integral_k to adjust the tmes_up
!    profile below cloud base so that the desired integral value is
!    obtained.
!-----------------------------------------------------------------------

         call don_u_set_column_integral_k    &
              (nlev_lsm, tmes_up   , pb, &
               phalf_c(1), 0.0, phalf_c , intgl_hi,     &
               intgl_lo, out, ermesg, error)

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals and 
!    profiles, both before and after the adjustment to the desired value        .
!---------------------------------------------------------------------
        if (debug_ijt) then
           write (diag_unit, '(a, e20.12)')  &
                   'in set_col_integral: tmes_up column(in)= ',intgl_hi
           write (diag_unit, '(a, e20.12)')  &
                   'in set_col_integral: tmes_up column(out)= ',intgl_lo
           do k=1,nlev_lsm
            if (tmes_up(k)       /= out(k)) then
               write (diag_unit, '(a, i4, 2e20.12)') &
               'in set_col_integral: k,tmesup(in), tmesup(out)= ', k,  &
                     tmes_up(k)      , out(k)
            endif
          end do
        endif
 
!---------------------------------------------------------------------
!    define the adjusted output profile by removing conservation_factor.
!---------------------------------------------------------------------
       tmes_up(:) = out(:)       
    endif

!---------------------------------------------------------------------
!    call subroutine meso_downdraft to define the needed output fields 
!    associated with the mesoscale downdraft.
!---------------------------------------------------------------------
      call don_m_meso_downdraft_miz  &
          (nlev_lsm, nlev_hires, diag_unit, debug_ijt, Param, pfull_c,&
           pfull_c, temp_c, mixing_ratio_c, phalf_c, pb, ampta1, dp,  &
           pztm, pzm, alp, hfmin, pmd, tmes_dn, mrmes_dn, dmeml, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (Nml%frc_internal_enthalpy_conserv) then
!-----------------------------------------------------------------------
!    call don_u_set_column_integral_k to adjust the tmes_dn
!    profile below cloud base so that the desired integral value is
!    obtained.
!-----------------------------------------------------------------------
         call don_u_set_column_integral_k    &
              (nlev_lsm, tmes_dn   , pb, &
               phalf_c(1), 0.0, phalf_c , intgl_hi,     &
               intgl_lo, out, ermesg, error)

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals and 
!    profiles, both before and after the adjustment to the desired value        .
!---------------------------------------------------------------------
        if (debug_ijt) then
           write (diag_unit, '(a, e20.12)')  &
                    'in set_col_integral: tmes_dn column(in)= ',intgl_hi
           write (diag_unit, '(a, e20.12)')  &
                  'in set_col_integral: tmes_dn column(out)= ',intgl_lo
           do k=1,nlev_lsm
            if (tmes_dn(k) /= out(k)) then
               write (diag_unit, '(a, i4, 2e20.12)') &
               'in set_col_integral: k,tmesdn(in), tmesdn(out)= ', k,  &
                     tmes_dn(k)      , out(k)
            endif
          end do
        endif
 
!---------------------------------------------------------------------
!    define the adjusted output profile by removing conservation_factor.
!---------------------------------------------------------------------
       tmes_dn(:) = out(:)       
     endif

!---------------------------------------------------------------------
!    combine the heating and moistening effects from the updraft and
!    downdraft to obtain the total mesoscale effect on the large-scale
!    model temperature and water vapor mixing ratio(?) equations.
!---------------------------------------------------------------------
      tmes = (tmes_up + tmes_dn)*86400.
      tmes_up = tmes_up*86400.
      tmes_dn = tmes_dn*86400.
      mrmes = (mrmes_up + mrmes_dn)*8.64e07
      mrmes_up = mrmes_up*8.64e07
      mrmes_dn = mrmes_dn*8.64e07

!---------------------------------------------------------------------
!    if in a diagnostics column, output the entropy (tmes) and
!    mixing ratio (mrmes) tendencies due to the mesoscale
!    updraft and downdraft.
!---------------------------------------------------------------------
     do k=1,nlev_lsm
       if (debug_ijt) then
         if (tmes(k) /= 0.0) then
           write (diag_unit, '(a, i4, f19.10, f20.14, 2e20.12)')   &
                   'in meens: jk,pr,tmes,tmes_u, tmes_d,= ', &
                     k, pfull_c(k), tmes(k)/86400., tmes_up(k)/86400., &
                      tmes_dn(k)/86400.
             write (diag_unit, '(a, i4, f19.10, f20.14, 3e20.12)')   &
                     'in meens: jk,pr,mrmes,mrmes_u, mrmes_d= ', &
                     k, pfull_c(k), mrmes(k)/8.64e07,  &
                     mrmes_up(k)/8.64e07, mrmes_dn(k)/8.64e07
         endif
       endif
     end do

!---------------------------------------------------------------------
!    define the column anvil precip (meso_precip) as the precipitation
!    efficiency times the available condensate in the anvil, which is 
!    made up of the deposition in the updraft (cmui) and the condensate
!    transferred from the cells to the anvil (ensembl_anvil_cond). 
!---------------------------------------------------------------------
       available_condensate = cmui + ensembl_anvil_cond_liq + &
                                ensembl_anvil_cond_liq_frz + &
                              ensembl_anvil_cond_ice
! precip from _liq takes hlv with it; precip from _ice takes hls
! with it
     if ( p2 == -10. .or. p2 > pb .or. p2 < pt_ens) then
        if (.not. meso_frz_intg_sum ) then
!   this implies no melting of precip; cmui and _liq don't freeze.
          available_condensate_liq =  cmui + ensembl_anvil_cond_liq
          available_condensate_ice =         &
                                 ensembl_anvil_cond_liq_frz + &
                              ensembl_anvil_cond_ice
        else
          available_condensate_liq =  0.0
         available_condensate_ice =    cmui + ensembl_anvil_cond_liq + &        
                                 ensembl_anvil_cond_liq_frz + &
                              ensembl_anvil_cond_ice
        endif
     else
!    all condensate will melt before leaving
       available_condensate_ice = 0.0
       available_condensate_liq = cmui + ensembl_anvil_cond_liq + &
                                 ensembl_anvil_cond_liq_frz + &
                              ensembl_anvil_cond_ice
    endif

      meso_precip = Param%anvil_precip_efficiency*available_condensate

!---------------------------------------------------------------------
!    if in a diagnostics column, output the total mesoscale-supplied
!    condensate (condensation plus deposition), the cell provided 
!    condensate (ensembl_anvil_cond),  the mesoscale precipitation 
!    (meso_precip) and the cell-scale precipitation (ensmbl_precip).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 5e20.12)')  &
                     'in meens: cmui,ca (sum,liq,frzliq,ice)=',  cmui, &
           ensembl_anvil_cond_liq + ensembl_anvil_cond_liq_frz + &
                              ensembl_anvil_cond_ice, &
                                         ensembl_anvil_cond_liq,  &
                                 ensembl_anvil_cond_liq_frz,  &
                              ensembl_anvil_cond_ice
        write (diag_unit, '(a, e20.12, a, e20.12)')  &
                     'in meens: rm= ',meso_precip,  'rc= ',ensmbl_precip
      endif

!----------------------------------------------------------------------
!    call subroutine meso_evap to define the amount of condensate that
!    is evaporated in the mesoscale updraft (emes) and mesoscale 
!    downdraft (emds).
!----------------------------------------------------------------------
      call don_m_meso_evap_k  &
           (nlev_lsm, diag_unit, debug_ijt, Param,    &
            available_condensate, available_condensate_liq,  &
            available_condensate_ice, pzm, pztm, phalf_c,       &
            emdi_liq, emdi_ice,       &
            emds_liq, emds_ice, &
                  emes_liq, emes_ice, ermesg, error)

       emdi = emdi_liq + emdi_ice

 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call subroutine meso_melt to distribute the melting of precipitat-
!    ing anvil ice within the column (anvil_precip_melt).
!---------------------------------------------------------------------
      call don_m_meso_melt_k   &
           (nlev_lsm, diag_unit, debug_ijt, Param, temp_c, phalf_c, &
            pztm, meso_precip, pb, anvil_precip_melt, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    define cmus_tot   as the profile of total condensate source to the
!    large-scale flow from the mesoscale circulation; the sum of the
!    water mass condensed in the mesoscale updraft plus the vapor
!    transferred from cell to mesoscale and then condensed.
!--------------------------------------------------------------------
      do k=1,nlev_lsm            
        cmus_tot(k) = cmu(k) - wmms(k)
      end do

!---------------------------------------------------------------------
!    if in a diagnostics column, output the profiles of tracer tranfer-
!    red from cells to mesoscale circulation (wtp), mesoscale tracer-
!    flux convergence (qtmes), and cell-scale tracer flux convergence 
!    (qtren). also output the  column integral of the mesoscale 
!    tracer-flux convergence (qtmesum).
!---------------------------------------------------------------------
      if (debug_ijt) then
        qtmesum = 0.
        do k=1,nlev_lsm
          do kcont=1,ntr
            write (diag_unit, '(a, 2i4, f19.10, e20.12)')  &
                         'in mulsub: jk, pr,wtp= ',k, kcont,  &
                            pfull_c(k), wtp(k,kcont)
            write (diag_unit, '(a, 2i4, f19.10, e20.12)')  &
                       'in mulsub: jk, pr,qtmes= ', k, kcont,         &
                              pfull_c(k),  qtmes(k,kcont)
            qtmesum = qtmesum + qtmes(k,kcont)*  &
                      (phalf_c(k) - phalf_c(k+1))
            write (diag_unit, '(a, i4, e20.12)')  &
                           'in mulsub: jk,qtmesum= ', k, qtmesum
          end do
        end do
      endif

!--------------------------------------------------------------------


    end subroutine don_m_meso_effects_miz

!#######################################################################
!#######################################################################



!#######################################################################

subroutine don_m_meso_updraft_miz    &
         (nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, Param,  &
          p_hires, rlsm, emsm, etsm, pfull_c, temp_c, mixing_ratio_c, &
          phalf_c, tracers_c, pb, pt_ens, ampta1, dp, pztm, wtp, &
          qtmes, cmu, wmms, wmps, temptr, tmes_up, mrmes_up,   &
          meso_cloud_area, umeml, alp, pzm, hfmin, cmui, ermesg, error)

!-------------------------------------------------------------------
!    subroutine meens computes the mesoscale effects of the composited
!    cloud ensemble on the heat, moisture and tracer budgets, producing
!    tendency terms which are to be applied to the large-scale model.
!    scheme employed here is a variation on procedure of Leary and 
!    Houze (JAS, 1980). for more details on notation, see 
!    "Cu Closure A notes," 2/97.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!-------------------------------------------------------------------
integer,                         intent(in)  :: nlev_lsm, nlev_hires, ntr
integer,                         intent(in)  :: diag_unit
logical,                         intent(in)  :: debug_ijt
type(donner_param_type),         intent(in)  :: Param
real,   dimension(nlev_lsm),     intent(in)  :: p_hires, rlsm, emsm !miz
real,   dimension(nlev_lsm,ntr), intent(in)  :: etsm !miz
real,   dimension(nlev_lsm),     intent(in)  :: pfull_c, temp_c,    &
                                                mixing_ratio_c
real,   dimension(nlev_lsm+1),   intent(in)  :: phalf_c
real,   dimension(nlev_lsm,ntr), intent(in)  :: tracers_c
real,                            intent(in)  :: pb, pt_ens, ampta1,   &
                                                dp, pztm
real,   dimension(nlev_lsm,ntr), intent(out) :: wtp, qtmes, temptr
real,   dimension(nlev_lsm),     intent(out) :: cmu, wmms, wmps, &
                                                tmes_up, mrmes_up, &
                                                meso_cloud_area, umeml
real,                            intent(out) :: alp, pzm, hfmin, cmui
character(len=128),              intent(out) :: ermesg
integer,                         intent(out) :: error

!---------------------------------------------------------------------
!   local variables:



      real, dimension (nlev_lsm)         :: wmhr, cumh !miz
      real, dimension (nlev_lsm)         :: omv, tempq, owm, tempqa
      real, dimension(nlev_lsm,ntr)      :: otm
      real, dimension(nlev_lsm, ntr)     :: wthr !miz
      real, dimension(ntr)               :: q1t


      real      ::  cmfhr, pc1, pc2, omer, pctm, q1, q4, mrsat, &
                    q3, anv, qref, pp, pm, qprip, qprim, eqfp, eqfm, &
                    qmu, hflux, pfmin, owms, wpc, wmc, ta, te, tep, tmu,&
                    qtprip, qtprim, eqtfp, eqtfm
      logical   :: do_donner_tracer
      integer   :: ncc
      integer   :: kcont, kk
      integer   :: jk, jsave, jkm, jkp, k, nbad

!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      if (ntr > 0) then
        do_donner_tracer = .true.
      else
        do_donner_tracer = .false.
      endif
!miz
!!$      do i=1,nlev_hires
!!$        if (p_hires(i) < pt_ens) then
!!$          ncc = i
!!$          exit
!!$        endif
!!$      end do
!!$      do i=1,nlev_hires
!!$        if (p_hires(i) < pztm) then
!!$          ncztm = i + 1
!!$          exit
!!$        endif
!!$      end do

      do kcont=1,ntr
        wtp(:,kcont) = 0.
        qtmes(:,kcont) = 0.
        temptr(:,kcont) = tracers_c(:,kcont)
      end do
      tmes_up(:) = 0.
      mrmes_up(:) = 0.
      cmu = 0.
      wmms = 0.
      wmps = 0.
      tempq(:) = mixing_ratio_c(:)
      tempqa(:) = mixing_ratio_c(:)

!----------------------------------------------------------------------
!    initialize the pressure at the base of the mesoscale circulation
!    (pzm).
!----------------------------------------------------------------------
      pzm = 0.

!----------------------------------------------------------------------
!    define the vertical profile of the rate at which water vapor is
!    made available to the mesoscale circulation by the convective 
!    updrafts on the cloud model grid (wmhr). if vapor is being made 
!    available, determine if there is also a vertical flux convergence 
!    of tracer; if so, define the rate at which tracer is being made
!    available to the mesoscale circulation (wthr). define the pressure
!    at the base of the mesoscale circulation (pzm) as the pressure at 
!    the lowest cloud model level where the convective updrafts are 
!    supplying condensate to the mesoscale circulation.
!----------------------------------------------------------------------
      do k=1,nlev_lsm !miz
        cmfhr = -rlsm(k) + emsm(k)
        if (cmfhr > 0.) then
          wmhr(k) = -cmfhr
          if (do_donner_tracer) then
            do kcont=1,ntr
              if (etsm(k,kcont) > 0.) then
                wthr(k,kcont) = -etsm(k,kcont)
              else
                wthr(k,kcont) = 0.0               
              endif
            end do
          else
            wthr(k,:) = 0.0               
          endif
          if (pzm == 0.) then
            pzm = pfull_c(k) !miz
          endif
        else
          wmhr(k) = 0.0   
          wthr(k,:) = 0.0               
        endif
      end do

!---------------------------------------------------------------------
!    if in diagnostics column, output the profiles of condensation rate
!    (rlsm), water vapor flux convergence (emsm) and water vapor 
!    supplied to the mesoscale (wmhr) on the cloud model grid.
!---------------------------------------------------------------------
      do k=1,nlev_lsm  
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                       'in meens: i,rlhr,emfhr= ',k,rlsm(k),emsm(k)
          write (diag_unit, '(a, i4, e20.12)')  &
                       'in meens: i,wmhr= ',k,wmhr(k)
       endif
     end do
 
     if (debug_ijt) then
       write (diag_unit, '(a, i4, e20.12)')  &
                        'in meens: ncc+1, pt', ncc+1, pt_ens
       do k=1,ncc+1
         write (diag_unit, '(a, i4, e20.12)')  &
                          'in meens: k,p_hi= ', k, p_hires(k)
       end do
       do k=1,nlev_lsm+1
         write (diag_unit, '(a, i4, e20.12)')  &
                       'in meens: k,p_lo= ', k, phalf_c(k)
       end do
     endif

!!$!---------------------------------------------------------------------
!!$!    convert the vertical profile of vapor made available to the meso-
!!$!    scale from the updraft to the large-scale model grid (output var-
!!$!    iable is owm). if tracers are being transported by donner conv-
!!$!    ection, convert the vertical profile of tracer made available to 
!!$!    the mesoscale from the updraft to the large-scale model grid 
!!$!    (output variable is otm). 
!!$!---------------------------------------------------------------------
!!$      call don_u_map_hires_c_to_lores_c_k &
!!$           (nlev_lsm, nlev_hires, wmhr, p_hires, pt_ens + dp, phalf_c,&
!!$            owm, rintsum, rintsum2, ermesg)
!!$      if (trim(ermesg) /= ' ') return

      owm=wmhr
!mizdelete

      if (do_donner_tracer) then
!!$        do kcont=1,ntr
!!$          call don_u_map_hires_c_to_lores_c_k  &
!!$               (nlev_lsm, nlev_hires, wthr (:,kcont), p_hires,  &
!!$                pt_ens + dp, phalf_c, otm(:,kcont), rintsum,   &
!!$                rintsum2, ermesg) 
!!$          if (trim(ermesg) /= ' ') return
!!$!mizdelete
!!$        end do
         otm=wthr
      endif

!----------------------------------------------------------------------
!    adjust the value for pressure at base of mesocscale circulation,
!    if necessary.
!----------------------------------------------------------------------
      if (pzm == 0.) pzm = pt_ens
      if (pzm <= pztm - dp) pzm = pztm - dp

!---------------------------------------------------------------------
!    if in diagnostics column, output the pressure at the base of the
!    mesoscale circulation (pzm), and the vertical profile of vapor 
!    supplied to the mesoscale by the updraft on the large-scale model
!    grid (owm).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, f19.10)') 'in meens: pzm= ',pzm
        do k=1,nlev_lsm
          write (diag_unit, '(a, i4, e20.12)')  &
                                    'in meens: jk,owm= ',k,owm(k)
        end do
      endif

!---------------------------------------------------------------------
!    march up the column, determining the redistribution of the cumulus-
!    updraft-supplied vapor by the mesoscale updraft.
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!---------------------------------------------------------------------
!    if there is  vapor being supplied to the mesoscale by the cumulus
!    updraft at this level, determine the pressure depth over which the
!    mesoscale updraft will distribute that vapor over the lifetime of
!    the mesoscale circulation.
!---------------------------------------------------------------------
        if (owm(k) < 0.) then     

!---------------------------------------------------------------------
!    define the bottom (pc1) and top (pc2) of the current layer. deter-
!    mine the pressure level to which air in this layer will reach when
!    moving at the appropriate mesoscale updraft velocity for the dur-
!    ation of the mesoscale circulation (pctm). this level is limited to
!    be no higher than the top of the mesoscale circulation; if it is 
!    calculated to be higher, redefine the mesoscale updraft velocity 
!    for this layer so that the air in this layer will reach only to
!    the mesoscale circulation top, and no higher.
!---------------------------------------------------------------------
          pc1 = phalf_c(k)
          pc2 = phalf_c(k+1)
          pctm = pc2 + Param%meso_ref_omega*Param%meso_lifetime
          if (pctm <= pztm) then
            omer = (pztm - pc2)/Param%meso_lifetime
            pctm = pc2 + omer*Param%meso_lifetime
          else
            omer = Param%meso_ref_omega
          endif
 
!---------------------------------------------------------------------
!    define the amount of water vapor from this layer (owm(k)* 
!    (pc2 - pc1)*MESO_LIFETIME) which is to be distributed
!    uniformly between pc1 and pctm (q1).
!--------------------------------------------------------------------  
          q1 = owm(k)*(pc2 - pc1)*Param%meso_lifetime/(pc1 - pctm)
          q4 = 0.5*q1

!---------------------------------------------------------------------
!    define the amount of tracer from this layer (otm(k,kcont)* 
!    (pc2 - pc1)*meso_Lifetime) which is to be distributed
!    uniformly between pc1 and pctm (q1t).
!--------------------------------------------------------------------  
          if (do_donner_tracer) then
            do kcont=1,ntr
             q1t(kcont) = otm(k,kcont)*(pc2 - pc1)*Param%meso_lifetime/&
                           (pc1 - pctm)                     
            end do
          endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the topmost pressure reached by
!    the mesoscale updraft from this layer (pctm), the top of the meso-
!    scale circulation (pztm) and the amount of water vapor supplied to
!    each layer between the current vertical level and the top of the 
!    mesoscale updraft originating here (q4).
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 3e20.12)')  &
                          'in meens: pctm,pztm,q4= ', pctm, pztm, q4
        endif


!---------------------------------------------------------------------
!    distribute the vapor supplied in the current layer to all layers
!    between the current location and the top of the mesoscale updraft.
!---------------------------------------------------------------------
          do kk=k,nlev_lsm

!--------------------------------------------------------------------
!    exit the loop when above the top of the mesoscale updraft. if still
!    within the mesoscale updraft originating from level k, add the 
!    contribution of water vapor being supplied to the mesoscale circ-
!    ulation at this level (kk) from the current source level (k), 
!    normalized by the anvil fractional area, to the arrays accumulating
!    these moisture sources (tempq, tempqa). these arrays will be used 
!    in the calculation of deposition in the mesoscale updraft.
!--------------------------------------------------------------------
            if (phalf_c(kk) < pctm) exit
            tempq(kk) = tempq(kk) + (q1/ampta1)
            tempqa(kk) = tempqa(kk) + (q4/ampta1)

!--------------------------------------------------------------------
!    add the rate of moisture input to the current layer kk from 
!    the current source layer k to the accumulation array (wmps). if the
!    current model layer extends beyond the top of the mesoscale 
!    updraft, pro-rate the contribution by the ratio of pressure depths.
!--------------------------------------------------------------------
            if (phalf_c(kk+1) <= pctm)  then
              wmps(kk) = wmps(kk) + (q1/Param%meso_lifetime)*  &
                        (phalf_c(kk) - pctm)/  &
                                          (phalf_c(kk) - phalf_c(kk+1))
            else
              wmps(kk) = wmps(kk) + q1/Param%meso_lifetime
            endif

!--------------------------------------------------------------------
!    add the contribution of tracer being supplied to the mesoscale 
!    circulation at this level (kk) from the current source level (k), 
!    normalized by the anvil fractional area, to the array accumulating
!    this tracer source (temptr). this array will be used in the 
!    calculation of tracer deposition in the mesoscale updraft.
!    add the rate of tracer input to the current layer kk from 
!    the current source layer k to the accumulation array (wtp). if the
!    current model layer extends beyond the top of the mesoscale 
!    updraft, pro-rate the contribution by the ratio of pressure depths.
!--------------------------------------------------------------------
            if (do_donner_tracer) then
              do kcont=1,ntr
                temptr(kk,kcont) = temptr(kk,kcont) + (q1t(kcont)/  &
                                   (2.* ampta1))
                if (phalf_c(kk+1) <= pctm) then
                  wtp(kk,kcont) = wtp(kk,kcont) +   &
                                  (q1t(kcont)/Param%meso_lifetime)*  &
                                  (phalf_c(kk)-pctm)/   &
                                            (phalf_c(kk)-phalf_c(kk+1))
                else
                  wtp(kk,kcont) = wtp(kk,kcont) +   &
                                  (q1t(kcont)/Param%meso_lifetime)
                endif
              end do
            endif
          end do

!--------------------------------------------------------------------
!    if in diagnostics column, output the moisture and tracer sources
!    to the mesoscale from the convective scale.
!--------------------------------------------------------------------
          if (debug_ijt) then
            do kk=k,nlev_lsm
              if (phalf_c(kk) < pctm) exit
               write (diag_unit, '(a, i4, f19.10)') &
                             'in meens: jj,pr= ',kk,pfull_c(kk)
               write (diag_unit, '(a, i4, 3e20.12)')  &
                  'in meens: jj,q1,tempq,wmm= ',kk,q1,tempq(kk),wmms(kk)
               write (diag_unit, '(a, e20.12)')  &
                 'in meens: wmp= ',wmps(kk)
               write (diag_unit, '(a, i4, e20.12)')  &
                   'in meens: jj,tempqa= ',kk,tempqa(kk)
             end do
             write (diag_unit, '(a, i4, 3e20.12)')  &
                   'in meens: jk,q1,tempq,wmm= ',k,q1,tempq(k),wmms(k)
             write (diag_unit, '(a, i4, 2e20.12)')  &
                    'in meens: jk,wmp,owm= ',k,wmps(k),owm(k)
          endif

        endif ! (owm(k) < 0.)

!----------------------------------------------------------------------
!    if in diagnostics column, output the profile of moisture made
!    available to the mesoscale circulation by the cumulus updraft (owm)
!    and the amount deposited in each level (wmps).
!----------------------------------------------------------------------
       if (debug_ijt) then
         write (diag_unit, '(a, i4, 2e20.12)')  &
                         'in meens: jk,wmp,owm= ',k,wmps(k),owm(k)
      endif

!----------------------------------------------------------------------
!    add the  source level value to the array accumulating the  profile
!    of total updraft source at each level (wmps). the if loop prevents
!    the inclusion of moisture which is available but above the top of 
!    the mesoscale updraft (the level of zero bupoyancy usually).  wmps
!    will only be non-zero at layers within the mesoscale updraft, but 
!    owm may be non-zero in layers above the updraft.
!--------------------------------------------------------------------
      if (wmps(k) /= 0.0) then
        wmps(k) = wmps(k) + owm(k)
        if (do_donner_tracer) then
          wtp(k,:) = wtp(k,:) + otm(k,:)
        endif
      endif
      end do   ! (end of k loop)

!--------------------------------------------------------------------
!    convert various moisture rates from kg(h2o) / kg(air) / sec to
!    g(h2o) / kg(air) / day.
!--------------------------------------------------------------------
      owm(:)  = owm(:)*8.64e07

!---------------------------------------------------------------------
!     calculate the portion of redistributed water vapor that condenses.
!     cycle until lowest level within the region of mesoscale circ-
!     ulation is reached. exit the loop when have marched past top of 
!     the mesoscale circulation.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (phalf_c(k+1) > pzm) cycle
        if (phalf_c(k) < pztm) exit

!---------------------------------------------------------------------
!    determine if the current level is within the region of the meso-
!    scale circulation (between pzm and pztm).
!---------------------------------------------------------------------
        if ((phalf_c(k+1) <= pzm) .and. (phalf_c(k) >= pztm)) then

!---------------------------------------------------------------------
!    if so, define the top (pc2) of the current layer. deter-
!    mine the pressure level to which air in this layer will reach when
!    moving at the appropriate mesoscale updraft velocity for the dur-
!    ation of the mesoscale circulation (pctm). this level is limited to
!    be no higher than the top of the mesoscale circulation; if it is 
!    calculated to be higher, redefine the mesoscale updraft velocity 
!    for this layer so that the air in this layer will reach only to
!    the mesoscale circulation top, and no higher.
!---------------------------------------------------------------------
          pc2 = phalf_c(k+1)
          pctm = pc2 +Param%meso_ref_omega*Param%meso_lifetime
          if (pctm <= pztm)  then
            omer = (pztm - pc2)/Param%meso_lifetime
          else
            omer = Param%meso_ref_omega
          endif
          pctm = pc2 + omer*Param%meso_lifetime

!---------------------------------------------------------------------
!    define the temperature of the mesoscale updraft at this level.
!    determine its saturation vapor pressure and saturation mixing  
!    ratio. define saturation deficit
!    or excess relative to tempq(k), which is the mixing ratio in the 
!    mesoscale region (environmental mixing ratio plus source from 
!    cumulus updrafts). if there is a moisture excess (and thus conden-
!    sation must occur), define the condensation rate in the mesoscale
!    region, normalized over the mesoscale lifetime and its areal cover-
!    age. if only a portion of the layer is within the mesoscale updraft
!    region, adjust the mesoscale condensation rate appropriately.
!    if tempqa is greater than the saturation specific humidity (ERROR-
!    should be mixing ratio), reset it to the saturation value.
!---------------------------------------------------------------------
          ta = temp_c(k) + Param%tprime_meso_updrft
          call compute_mrs_k (ta, pfull_c(k), Param%d622 , Param%d608 ,&
                             mrsat, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_updraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          q3 = mrsat - tempq(k)
          if (q3 <= 0.) then
            if (phalf_c(k+1) <= pctm)  then
              wmms(k) = (q3*ampta1/Param%meso_lifetime)*    &
                       (phalf_c(k) - pctm)/(phalf_c(k) - phalf_c(k+1))
            else
              wmms(k) = q3*ampta1/Param%meso_lifetime
            endif
          endif
          tempqa(k) = MIN (tempqa(k), mrsat)
        endif
      end do

!---------------------------------------------------------------------
!    determine the large-scale model full level at which parcel contain-
!    ing the water vapor at the base of the mesoscale updraft will reach
!    saturation and begin to condense (jsave).
!---------------------------------------------------------------------
      anv = 0.
      do k=1,nlev_lsm

!---------------------------------------------------------------------
!    determine the water vapor mixing ratio at the base of the mesoscale
!    updraft (qref).
!---------------------------------------------------------------------
        if (pfull_c(k) > pzm) cycle       
        if (anv == 0.) qref = tempqa(k)
        anv = 1.
        if (pfull_c(k) < pztm) exit        

!---------------------------------------------------------------------
!    define the temperature of the mesoscale updraft at this level.
!    determine its saturation vapor pressure and saturation specific
!    humidity. NOTE: should be mixing RATIO. define the level at which
!    mesoscale updraft condensation begins as the current level, in 
!    case the loop will be exited.
!---------------------------------------------------------------------
        te = temp_c(k) + Param%tprime_meso_updrft
         call compute_mrs_k (te, pfull_c(k), Param%d622 , Param%d608 ,&
                             mrsat, nbad , mr = qref)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_updraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1 
          return
        endif

        jsave = k

!---------------------------------------------------------------------
!    if in diagnostics column, output the values of saturation mixing  
!    ratio (mrsat) and mixing ratio in the mesoscale region (tempqa).
!---------------------------------------------------------------------
       if (debug_ijt) then
         write (diag_unit, '(a, 2e20.12)')  &
                          'in meens: qs,tempqa= ',mrsat,tempqa(k)
       endif

!---------------------------------------------------------------------
!    if there is a saturation excess at this level then exit, saving the
!    level index as jsave. this is the level at which condensation  in
!    the mesoscale updraft will begin.
!---------------------------------------------------------------------
        if (qref >= mrsat) exit      
      end do

!---------------------------------------------------------------------
!    define the  ???????
!!    What is the 6 ?? how is it related to the 8 below in the omd
!!    definition ???
!---------------------------------------------------------------------
      alp = 6.*Param%meso_ref_omega/((pzm - pztm)**2)

      omv = 0.

!---------------------------------------------------------------------
!    define the forcing terms associated with mesoscale updrafts.
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!-------------------------------------------------------------------
!    if the current level is below the base of the mesoscale updraft,
!    cycle. if the current level is above the top of the mesoscale 
!    updraft, exit the loop.
!-------------------------------------------------------------------
        if (pfull_c(k) .gt. pzm) cycle       
        if (pfull_c(k) .lt. pztm) exit

!--------------------------------------------------------------------
!    define the limits of the current layer, modified from the large-
!    scale model levels when the mesoscale updraft region starts or ends
!    within the layer.
!--------------------------------------------------------------------
        pp = phalf_c(k+1)
        pm = phalf_c(k)
        if (phalf_c(k+1) < pztm) pp = pztm
        if (phalf_c(k) > pzm) pm = pzm

!---------------------------------------------------------------------
!    calculate mesoscale vertical velocity profile.
!---------------------------------------------------------------------
        omv(k) = (pzm + pztm)*((pp**2) - (pm**2))/2.
        omv(k) =  omv(k) - (((pp**3) - (pm**3))/3.)
        omv(k) = omv(k) - pztm*pzm*(pp - pm)
        omv(k) = omv(k)/(phalf_c(k+1) - phalf_c(k))
        omv(k) = omv(k)*alp

!---------------------------------------------------------------------
!    calculate mesoscale entropy-flux convergence. analytic integration
!    used, possible only because mesoscale temperature perturbation is 
!    not function of pressure. see "Vertical Velocity in Mesoscale 
!    Cloud" notes, 11/12/91.
!---------------------------------------------------------------------
        tmes_up(k) = (pzm + pztm)*(Param%rdgas - Param%cp_air)*  &
                     (pp - pm)/Param%cp_air
        tmes_up(k) = tmes_up(k) + ((2.*Param%cp_air - Param%rdgas)*  &
                     ((pp**2) - (pm**2))/(2.*Param%cp_air))
        tmes_up(k) = tmes_up(k) - (Param%rdgas*pztm*pzm/Param%cp_air)* &
                     alog(pp/pm)
        tmes_up(k) = tmes_up(k)/(phalf_c(k+1) - phalf_c(k))
        tmes_up(k) = tmes_up(k)*ampta1*Param%tprime_meso_updrft*alp

!--------------------------------------------------------------------
!    if currently below the level at which condensation in the meso-
!    scale updraft begins, cycle until that level is reached.
!--------------------------------------------------------------------
        if (k < jsave) cycle      

!--------------------------------------------------------------------
!    if into the region where deposition occurs, define the appropriate
!    above and below indices for boundary levels.
!--------------------------------------------------------------------
        if (k == 1) then
          jkm = k
        else
          jkm = k - 1
        endif
        if (k == nlev_lsm) then
          jkp = k
        else
          jkp = k + 1
        endif

!--------------------------------------------------------------------
!    define the temperature of the mesoscale updraft (te). define the
!    associated saturation vapor pressure and specific humidity (ERROR 
!    !!!).
!--------------------------------------------------------------------
        te = temp_c(k) + Param%tprime_meso_updrft
        call compute_mrs_k (te, pfull_c(k), Param%d622 , Param%d608 ,&
                             tempqa(k), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_updraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif


!--------------------------------------------------------------------
!    if an excess of vapor is present and deposition should occur, 
!    define the mesoscale updraft temperature at the next higher level 
!    (tep). 
!--------------------------------------------------------------------
        if (qref >= tempqa(k)) then
          tep = temp_c(jkp) + Param%tprime_meso_updrft

!--------------------------------------------------------------------
!    if the next higher level is no longer in the mesoscale updraft 
!    layer, define the deposition rate in the mesoscale updraft at 
!    level k as the vapor flux divergence between layer k-1 and layer k.
!--------------------------------------------------------------------
          if (pfull_c(jkp) <= pztm) then
            cmu(k) = -omv(k)*(tempqa(k) - tempqa(jkm))/ &
                     (pfull_c(k) - pfull_c(jkm))

!--------------------------------------------------------------------
!     if level k is the lowest level within the condensation region,
!     determine the saturation specific humidity (ERROR !!!) at the
!     next higher level. define the deposition rate in the mesoscale  
!     updraft at level k as the vapor flux divergence between level k 
!     and level k+1. redefine qref as the amount of vapor remaining
!     in the parcel at the jkp level.
!--------------------------------------------------------------------
          else if (k == jsave) then
            call compute_mrs_k (tep, pfull_c(jkp), Param%d622 ,  &
                                Param%d608 , tempqa(jkp), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (nbad /= 0) then
              ermesg = 'subroutine don_m_meso_updraft_k: '// &
                       'temperatures out of range of esat table'
              error = 1
              return
            endif

            cmu(k) = -omv(k)*(tempqa(jkp) - tempqa(k))/  &
                     (pfull_c(jkp) - pfull_c(k))
            qref = tempqa(jkp)

!--------------------------------------------------------------------
!     if level k is within the condensation region, determine the  
!     saturation specific humidity (ERROR !!!) at the next higher level.
!     define the deposition rate in the mesoscale updraft at level k as
!     the vapor flux divergence between level k-1 and level k+1. 
!     redefine qref as the amount of vapor remaining in the parcel at 
!     the jkp level.
!--------------------------------------------------------------------
          else
            call compute_mrs_k (tep, pfull_c(jkp), Param%d622 ,  &
                                Param%d608 , tempqa(jkp), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (nbad /= 0) then
              ermesg = 'subroutine don_m_meso_updraft_k: '// &
                       'temperatures out of range of esat table'
              error = 1
              return
            endif

            cmu(k) = -omv(k)*(tempqa(jkp) - tempqa(jkm))/ &
                     (pfull_c(jkp) - pfull_c(jkm))
            qref = tempqa(jkp)
          endif

!---------------------------------------------------------------------
!    make certain that the deposition rate is non-negative.
!---------------------------------------------------------------------
          if (cmu(k) < 0.) cmu(k) = 0.

!---------------------------------------------------------------------
!    if there is insufficient moisture for deposition, set the depo-
!    sition rate to 0.0.
!---------------------------------------------------------------------
        else
          cmu(k) = 0.
        endif

!---------------------------------------------------------------------
!    convert the deposition rate to g(h2o) / kg(air) / day. multiply
!    by the anvil area (ampta1) to obtain a grid-box-mean value of the
!    deposition rate.
!---------------------------------------------------------------------
        cmu(k) = cmu(k)*ampta1*8.64e07

!--------------------------------------------------------------------
!    if in diagnostics column, output the environmental temperature
!    (temp_c) and the mesoscale vertical velocity (omv).
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, f20.14, e20.12)') &
                     'in meens: jk,t,omv= ', k, temp_c(k), omv(k)
        endif
      end do

!---------------------------------------------------------------------
!    calculate the mesoscale moisture-flux and tracer-flux convergence.
!---------------------------------------------------------------------
      do k=1,nlev_lsm 

!---------------------------------------------------------------------
!    if the current level is above the mesoscale updraft, exit the loop.
!    if the next level is still below the base of the mesoscale updraft,
!    cycle to the end of the loop.
!---------------------------------------------------------------------
        if (phalf_c(k) .lt. pztm) exit       
        if (phalf_c(k+1) .gt. pzm) cycle      

!--------------------------------------------------------------------
!    define the appropriate above and below indices for boundary levels.
!--------------------------------------------------------------------
        if (k == 1) then
          jkm = k
        else
          jkm = k - 1
        endif
        if (k == nlev_lsm) then
          jkp = k
        else
          jkp = k + 1
        endif

!---------------------------------------------------------------------
!    define the difference between the environmental vapor mixing ratio 
!    and that in the mesoscale updraft at the two half-levels bracketing
!    the current level.
!---------------------------------------------------------------------
        qprip = (tempqa(jkp) + tempqa(k) -    &
                             mixing_ratio_c(jkp) - mixing_ratio_c(k))/2.
        qprim = (tempqa(k) + tempqa(jkm) -    &
                             mixing_ratio_c(k) - mixing_ratio_c(jkm))/2.

!---------------------------------------------------------------------
!    define the difference between the environmental tracer mixing 
!    ratios and those in the mesoscale updraft at the two half-levels 
!    bracketing the current level.
!---------------------------------------------------------------------
        if (do_donner_tracer) then
          do kcont=1,ntr
            qtprip = (temptr(jkp,kcont) + temptr(k,kcont) - &
                      tracers_c(jkp,kcont) - tracers_c(k,kcont))/2.
            qtprim = (temptr(k,kcont) + temptr(jkm,kcont) -  &
                      tracers_c(k,kcont) - tracers_c(jkm,kcont))/2.
            eqtfp = ampta1*qtprip*alp*(phalf_c(k+1) - pztm)*  &
                    (pzm - phalf_c(k+1))
            eqtfm = ampta1*qtprim*alp*(phalf_c(k) - pztm)*  &
                    (pzm - phalf_c(k))
            if ((phalf_c(k) <= pzm) .and. (phalf_c(k+1) >= pztm)) then
              qtmes(k,kcont) = (eqtfm - eqtfp)/   &
                                             (phalf_c(k+1) - phalf_c(k))
            endif
            if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
              qtmes(k,kcont) = eqtfp/(phalf_c(k) - phalf_c(k+1))
            endif
            if ((pztm >= phalf_c(k+1)) .and. (pztm <= phalf_c(k))) then
              qtmes(k,kcont) = eqtfm/(phalf_c(k+1) - phalf_c(k))
              if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
                qtmes(k,kcont) = 0.
              endif
            endif ! ((pztm >= phalf_c(k+1)) .and. (pztm <= phalf_c(k)))
          end do
        endif

!-------------------------------------------------------------------
!    define the
!-------------------------------------------------------------------
        eqfp = ampta1*qprip*alp*(phalf_c(k+1) - pztm)*   &
                                                    (pzm - phalf_c(k+1))
        eqfm = ampta1*qprim*alp*(phalf_c(k) - pztm)*(pzm - phalf_c(k))
        if ((phalf_c(k) <= pzm) .and. (phalf_c(k+1) >= pztm)) then
          mrmes_up(k) = (eqfm - eqfp)/(phalf_c(k+1) - phalf_c(k))
        endif
        if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
          mrmes_up(k) = eqfp/(phalf_c(k) - phalf_c(k+1))
        endif
        if ((pztm >= phalf_c(k+1)) .and. (pztm <= phalf_c(k))) then
          mrmes_up(k) = eqfm/(phalf_c(k+1) - phalf_c(k))
          if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
            mrmes_up(k) = 0.
          endif
        endif ! ((pztm .ge. phalf_c(k+1)) .and. (pztm .le. phalf_c(k)))

!---------------------------------------------------------------------
!    if in diagnostics column,  output the entropy     (tmes) and
!    specific humidity (?)(mrmes) tendencies due to the mesoscale
!    updraft.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)')   &
                   'in meens: jk,pr,tmes,qmes= ', k, pfull_c(k),  &
                    tmes_up(k), mrmes_up(k)
        endif
      end do

!---------------------------------------------------------------------
!    calculate the eddy flux of moist static energy in mesoscale
!    updraft (hflux) and identify its minimum (hfmin).
!---------------------------------------------------------------------
      hfmin = 0.
      do jk=1,nlev_lsm
!---------------------------------------------------------------------
!    if the current level is above the mesoscale updraft, exit the loop.
!    if the next level is still below the base of the mesoscale updraft,
!    cycle to the end of the loop.
!---------------------------------------------------------------------
        if (pfull_c(jk) .lt. pztm) exit      
        if (pfull_c(jk) .gt. pzm) cycle      

!--------------------------------------------------------------------
!    define the temperature of the mesoscale updraft (tmu). define the
!    associated saturation vapor pressure and specific humidity (ERROR 
!    !!!).
!--------------------------------------------------------------------
        tmu = temp_c(jk) + Param%TPRIME_MESO_UPDRFT
        call compute_mrs_k (tmu, pfull_c(jk), Param%d622 ,  &
                                Param%d608 , qmu, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_updraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

!---------------------------------------------------------------------
!    define the eddy flux of moist static energy in the mesoscale 
!    updraft (hflux). retain the minimum value in the profile (hfmin)
!    and its pressure level (pfmin).
!---------------------------------------------------------------------
        hflux = omv(jk)*(((Param%cp_air*Param%tprime_meso_updrft ) + &
                                 Param%hlv*(qmu - mixing_ratio_c(jk))))
        if (hflux < hfmin) then
          hfmin = hflux      
          pfmin = pfull_c(jk)
        endif
      end do

!---------------------------------------------------------------------
!    if in a diagnostics column, output the minimum of the eddy moist 
!    static energy flux and its level.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                      'in meens: hfmin,pfmin= ', hfmin, pfmin
     endif

!---------------------------------------------------------------------
!    define the mesoscale fractional area (cumh) in the region of the 
!    mesoscale updraft. 
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((p_hires(k) <= pzm) .and. (p_hires(k) >= pztm))  then
          cumh(k) = ampta1
        else
          cumh(k) = 0.0 
        endif
      end do

!!$      call don_u_map_hires_c_to_lores_c_k  &
!!$           (nlev_lsm, nlev_hires, cumh, p_hires, pztm + dp, phalf_c, &
!!$            meso_cloud_area, rintsum, rintsum2, ermesg) 
!!$       if (trim(ermesg) /= ' ') return

       meso_cloud_area=cumh

!mizdelete

!---------------------------------------------------------------------
!    define the upward mass flux associated with the mesoscale 
!    circulation. 
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        umeml(k) = -omv(k)*ampta1/Param%grav  
        wmms(k)  = wmms(k)*8.64e07
        wmps(k)  = wmps(k)*8.64e07
      end do

!---------------------------------------------------------------------
!    obtain column integrals of deposition rate in the mesoscale (cmui),
!    convective updraft condensation (wmc), cell to mesoscale moisture
!    transfer (wpc), and the moisture made available to the mesoscale
!    by the cumulus updraft (owms). convert to units of mm / day.
!---------------------------------------------------------------------
      cmui = 0.
      wmc  = 0.
      wpc  = 0.
      owms = 0.
      do k=1,nlev_lsm
        wmc  = wmc  + wmms(k)*(phalf_c(k) - phalf_c(k+1))
        owms = owms + owm(k)*(phalf_c(k) - phalf_c(k+1))
        wpc  = wpc  + wmps(k)*(phalf_c(k) - phalf_c(k+1))
        cmui = cmui + cmu(k)*(phalf_c(k) - phalf_c(k+1))
      end do
      wmc  = wmc/(Param%grav*1000.)
      wpc  = wpc/(Param%grav*1000.)
      owms = owms/(Param%grav*1000.)
      cmui = cmui/(Param%grav*1000.)

!---------------------------------------------------------------------
!    if in diagnostics column, output the column-integral moisture 
!    conversion rates (wmc, wpc, owms, cmui). 
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12,a,a,e20.12,a)')  &
               'in meens: wmc=', wmc, ' mm/day', ' wpc=', wpc, 'mm/day'
        write (diag_unit, '(a, e20.12, a, a, e20.12, a)')  &
               'in meens: owms= ', owms, ' mm/day', ' cmui= ',   &
                         cmui, 'mm/day'
     endif

!---------------------------------------------------------------------
!    calculate precipitation resulting from the mesoscale circulation.
!    define the total additional condensate supplied to the column
!    by the mesoscale circulation, the sum of the deposition (wmc) and
!    additional condensation (cmui). 
!---------------------------------------------------------------------
      cmui = cmui - wmc

!--------------------------------------------------------------------


    end subroutine don_m_meso_updraft_miz



!#####################################################################

subroutine don_m_meso_downdraft_miz    &
         (nlev_lsm, nlev_hires, diag_unit, debug_ijt,  Param, p_hires, &
          pfull_c, temp_c, mixing_ratio_c, phalf_c, pb, ampta1, dp,  &
          pztm, pzm, alp, hfmin, pmd, tmes_dn, mrmes_dn, dmeml, ermesg, error)

!-------------------------------------------------------------------
!    subroutine meens computes the mesoscale effects of the composited
!    cloud ensemble on the heat, moisture and tracer budgets, producing
!    tendency terms which are to be applied to the large-scale model.
!    scheme employed here is a variation on procedure of Leary and 
!    Houze (JAS, 1980). for more details on notation, see 
!    "Cu Closure A notes," 2/97.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!-------------------------------------------------------------------
integer,                       intent(in)   :: nlev_lsm, nlev_hires, &
                                               diag_unit
logical,                       intent(in)   :: debug_ijt        
type(donner_param_type),       intent(in)   :: Param
real,   dimension(nlev_lsm),   intent(in)   :: p_hires !miz
real,   dimension(nlev_lsm),   intent(in)   :: pfull_c, temp_c,  &
                                               mixing_ratio_c
real,   dimension(nlev_lsm+1), intent(in)   :: phalf_c
real,                          intent(in)   :: pb, ampta1, dp, pztm, &
                                               pzm, alp, hfmin 
real,                          intent(out)  :: pmd
real,   dimension(nlev_lsm),   intent(out)  :: tmes_dn, mrmes_dn, dmeml
character(len=*),              intent(out)  :: ermesg
integer,                       intent(out)  :: error

!---------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_lsm)       :: dmemh !miz
      real, dimension(nlev_lsm)       :: tempt, tempqa
      real, dimension(nlev_lsm+1)     :: emt, emq

     real    ::  es, mrsat, c2, c3, c1, fjk, fjkm, qb, fjkb, qbm, qmd, &
                  qsmd, fjkmd, qmmd, pi, psa,  &
                        targ, tprimd, tb, qten, tten, omd, mrsb, wa,   &
                  wb, tmd, rin
      integer :: jksave, k, nbad

!----------------------------------------------------------------------

      ermesg = ' ' ; error = 0

      tmes_dn = 0.
      mrmes_dn = 0.
      tempt(:) = temp_c(:)
      emt(:) = 0.
      emq(:) = 0.
      tempqa(:) = mixing_ratio_c(:)

!---------------------------------------------------------------------
!    define the top of the mesoscale downdraft (pmd). it is assumed to 
!    be meso_sep Pa below the base of the mesoscale updraft. (no meso-
!    scale motion is assumed between the base of the mesoscale updraft 
!    and the top of the mesoscale downdraft.) make certain it is not 
!    below the surface.
!---------------------------------------------------------------------
      pmd = MIN(pzm + Param%meso_sep, phalf_c(1))
!miz
!!$      ncmd = 1
!!$      do k=1,nlev_hires         
!!$        if (p_hires(k) < pmd ) then
!!$          ncmd = k + 1
!!$          exit
!!$        endif
!!$      end do

!---------------------------------------------------------------------
!    calculate mesoscale downdraft speed (omd) at top of mesoscale 
!    downdraft (pmd). follow Leary and Houze (1980,JAS) and set 
!    magnitude to half that in mesoscale updraft; this vertical pressure
!    velocity assumed constant with ht between pzm and cloud base (pb). 
!---------------------------------------------------------------------
      omd = -alp*((pzm-pztm)**2)/8.
      omd = omd/2.

!--------------------------------------------------------------------
!    calculate temperature and specific humidity in mesoscale
!    downdraft. 
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!---------------------------------------------------------------------
!    if the current level is above the top of the mesoscale downdraft, 
!    exit the loop. if the level is below cloud base, cycle to the end
!    of the loop.
!---------------------------------------------------------------------
        if (pfull_c(k) < pmd) exit      
        if (pfull_c(k) > pb) cycle      

!---------------------------------------------------------------------
!    calculate c2, the relative humidity in the mesoscale downdraft,
!    after Table 3 of Leary and Houze (1980, JAS).
!---------------------------------------------------------------------
        c2 = 1. - (.3*(pfull_c(k) - pmd)/(pb - pmd))

!---------------------------------------------------------------------
!    calculate c3, the factor which yields the eddy flux of moist
!    static energy when multiplied by the minimum of moist static
!    energy in the mesoscale updraft. Multiply by 1.3 to take account
!    of convective downdrafts. See Fig. 7 of Leary and Houze
!    (1980,JAS).
!---------------------------------------------------------------------
        c3 = (pfull_c(k) - pmd)/(pb - pmd)
        c3 = 1.3*c3

!---------------------------------------------------------------------
!    see "Moist Static Energy A, 1/26/91" notes.
!---------------------------------------------------------------------
        targ = temp_c(k)
        call compute_mrs_k (targ, pfull_c(k), Param%d622 ,  &
                                Param%d608 , mrsat, nbad, esat=es)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

        c1 = Param%d622*Param%hlv*es/   &
                                 (pfull_c(k)*Param%rvgas*(temp_c(k)**2))
        tprimd = c3*hfmin/omd
        tprimd = tprimd - Param%hlv*(c2*mrsat - mixing_ratio_c(k))
        tprimd = tprimd/(Param%cp_air + Param%hlv*c1*c2)
        tempt(k) = temp_c(k) + tprimd
        targ = tempt(k)
        call compute_mrs_k (targ, pfull_c(k), Param%d622 ,  &
                                Param%d608 , tempqa(k), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

        tempqa(k) = c2*tempqa(k)                                

!---------------------------------------------------------------------
!    if in diagnostics column, output 
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 4e20.12)')  &
                     'in meens: tprimd,tempqa,q,qs= ',tprimd,   &
                     tempqa(k), mixing_ratio_c(k), mrsat
          write (diag_unit, '(a, f19.10, 2e20.12)')  &
                    'in meens: pr,rh,factr= ', pfull_c(k), c2, c3
        endif
      end do

!---------------------------------------------------------------------
!    calculate eddy fluxes of potential temperature and specific
!    humidity in mesoscale downdraft.
!---------------------------------------------------------------------
      do k=2,nlev_lsm-1

!---------------------------------------------------------------------
!    if the current level is above the top of the mesoscale downdraft, 
!    exit the loop. if the level is below cloud base, cycle to the end
!    of the loop.
!---------------------------------------------------------------------
        if (phalf_c(k) .lt. pmd) exit
        if (phalf_c(k) .gt. pb) cycle        

!---------------------------------------------------------------------
!    calculate potential temperature and specific humidity (?) fluxes
!    for pressure levels between cloud base and top of mesoscale down-
!    draft.
!---------------------------------------------------------------------
        if ((pfull_c(k-1) <= pb) .and. (pfull_c(k) >= pmd)) then
          fjk = ampta1*omd*((Param%ref_press/pfull_c(k))**     &
                   (Param%rdgas/Param%cp_air))*(tempt(k) - temp_c(k))    
          fjkm = ampta1*omd*((Param%ref_press/pfull_c(k-1))**  &
                  (Param%rdgas/Param%cp_air))*(tempt(k-1) - temp_c(k-1))
          emt(k) = (fjk + fjkm)/2.
          fjk = ampta1*omd*(tempqa(k) - mixing_ratio_c(k))
          fjkm = ampta1*omd*(tempqa(k-1) - mixing_ratio_c(k-1))
          emq(k) = (fjk + fjkm)/2.
        endif

!---------------------------------------------------------------------
!    calculate potential temperature and specific humidity (?) fluxes
!    for pressure levels below cloud base.
!---------------------------------------------------------------------
        if (pfull_c(k-1) >= pb) then
          fjk = ampta1*omd*((Param%ref_press/pfull_c(k))**   &
                 (Param%rdgas/Param%cp_air))*(tempt(k) - temp_c(k))
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, mixing_ratio_c, pfull_c, pb, qb, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt   ) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                            'in polat: k,p,x=', k, pb, qb
          endif
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, temp_c, pfull_c, pb, tb, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt   ) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                    'in polat: k,p,x=', k, pb, tb
          endif
        call compute_mrs_k (tb, pb, Param%d622 ,  &
                                Param%d608 , mrsb, nbad, esat=es)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          tprimd = hfmin/omd
          tprimd = tprimd - Param%hlv*(.7*mrsb - qb)
          c1 = Param%D622  *Param%hlv*es/(pb*Param%rvgas*(tb**2))
          tprimd = tprimd/(Param%cp_air + .7*Param%hlv*c1)
          fjkb = ampta1*omd*((Param%ref_press/pb)**      &
                                    (Param%rdgas/Param%cp_air))*tprimd
          wa = (phalf_c(k) - pfull_c(k))/(pb - pfull_c(k))
          wb = (pb - phalf_c(k))/(pb - pfull_c(k))
          emt(k) = wa*fjkb + wb*fjk
          fjk = ampta1*omd*(tempqa(k) - mixing_ratio_C(k))
          targ = tb + tprimd
          call compute_mrs_k (targ, pb, Param%d622 ,  &
                                Param%d608 , qbm, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          qbm = .7*qbm                            
          fjkb = ampta1*omd*(qbm - qb)
          emq(k) = wa*fjkb + wb*fjk
        endif

!---------------------------------------------------------------------
!    calculate potential temperature and specific humidity (?) fluxes
!    for pressure levels at or above the top of the mesoscale downdraft.
!---------------------------------------------------------------------
        if (pfull_c(k) <= pmd) then
          fjkm = ampta1*omd*((Param%ref_press/pfull_c(k-1))**    &
                 (Param%rdgas/Param%cp_air))*(tempt(k-1) - temp_c(k-1))
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, mixing_ratio_c, pfull_c, pmd, qmd, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                       'in polat: k,p,x=', k, pmd, qmd
          endif
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, temp_c, pfull_c, pmd, tmd, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt   ) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                      'in polat: k,p,x=', k, pmd, tmd
          endif
          call compute_mrs_k (tmd, pmd, Param%d622 ,  &
                                Param%d608 , qsmd, nbad, esat=es)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          c1 = Param%d622*Param%hlv*es/(pmd*Param%rvgas*(tmd**2))
          tprimd = -Param%hlv*(qsmd - qmd)/(Param%cp_air + Param%hlv*c1)
          fjkmd = ampta1*omd*((Param%ref_press/pmd)**   &
                                     (Param%rdgas/Param%cp_air))*tprimd
          wa = (pfull_c(k-1) - phalf_c(k))/(pfull_c(k-1) - pmd)
          wb = (phalf_c(k) - pmd)/(pfull_c(k-1) - pmd)
          emt(k) = fjkmd*wa + fjkm*wb
          targ = tmd + tprimd
          call compute_mrs_k (targ, pmd, Param%d622 ,  &
                                Param%d608 , qmmd, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          fjkm = ampta1*omd*(tempqa(k-1) - mixing_ratio_c(k-1))
          fjkmd = ampta1*omd*(qmmd - qmd)
          emq(k) = fjkmd*wa + fjkm*wb
        endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the potential temprature and
!    specific humidity fluxes associated with the mesoscale downdrafts.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3e20.12)')  &
                       'in meens: jk,phr,emt,emq= ', k ,phalf_c(k),   &
                         emt(k), emq(k)
        endif

!---------------------------------------------------------------------
!    convert the potential temperature flux to a temperature flux.
!---------------------------------------------------------------------
! RSH : unneeded, causes error
!       emt(k) = ((Param%ref_press/pfull_c(k))**     &
!                                    (Param%rdgas/Param%cp_air))*emt(k)
      end do  ! (end of k loop)

!---------------------------------------------------------------------
!    calculate temperature and specific humidity tendencies due
!    to eddy-flux convergences in mesoscale downdraft.
!---------------------------------------------------------------------
      rin = 0.
      do k=nlev_lsm,1, -1

!---------------------------------------------------------------------
!    define the index of the base of the mesoscale updraft (jksave).
!---------------------------------------------------------------------
        if ((phalf_c(k+1) <= pzm) .and. (phalf_c(k) >= pzm))   &
                                                         jksave = k + 1
        pi = (Param%ref_press/pfull_c(k))**(Param%rdgas/Param%cp_air)
        if ((emt(k+1) /= 0.) .and. (emt(k) == 0.) .and.    &
            (rin == 0.)) then
          tten = -emt(k+1)/(phalf_c(k+1) - phalf_c(1))
          qten = -emq(k+1)/(phalf_c(k+1) - phalf_c(1))
          rin = 1.
        endif
        if (rin == 1.) then
          tmes_dn(k) = tmes_dn(k) + (tten/pi)
          mrmes_dn(k) = mrmes_dn(k) + qten
        endif
        if ((rin == 0.) .and. (emt(k+1) /= 0.) .and.   &
            (emt(k) /= 0.)) then
          tten = (emt(k+1) - emt(k))/(phalf_c(k+1) - phalf_c(k))
          tten = -tten/pi
          qten = (emq(k+1) - emq(k))/(phalf_c(k+1) - phalf_c(k))
          qten = -qten
          tmes_dn(k) = tmes_dn(k) + tten
          mrmes_dn(k) = mrmes_dn(k) + qten
        endif

!---------------------------------------------------------------------
!    if in diagnostics column,  output the entropy     (tmes) and
!    specific humidity (?)(mrmes) tendencies due to the mesoscale
!    downdraft.
!---------------------------------------------------------------------
       if (debug_ijt) then
         write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)')   &
                   'in meens: jk,pr,tmes,qmes= ', k, pfull_c(k),  &
                      tmes_dn(k), mrmes_dn(k)
       endif
      end do

!---------------------------------------------------------------------
!    define the temperature (tten)and moisture (qten) tendencies result-
!    ing from the mesoscale downdraft that are to be applied to the 
!    layers between the top of mesoscale downdraft (where emt is 
!    non-zero, saved as psa), and the base of the mesoscale updraft 
!    given by phalf_c(jksave).
!---------------------------------------------------------------------
      psa = 0.
      do k=1,nlev_lsm
        if ((emt(k) /= 0.) .and. (emt(k+1) == 0.)) then
          tten = emt(k)/(phalf_c(jksave) - phalf_c(k))
          qten = emq(k)/(phalf_c(jksave) - phalf_c(k))
          psa = phalf_c(k)
        endif
      end do

!---------------------------------------------------------------------
!    if in diagnostcs column, output the pressures at the top of the
!    mesoscale downdraft (pmd) and at cloud base (pb).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2f19.10)')  &
                                  'in meens: pmd,pb= ', pmd, pb
      endif

!--------------------------------------------------------------------
!    apply these tendencies to the levels between top of mesoscale
!    downdraft and base of mesoscale updraft.
!--------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((pfull_c(k) <= psa) .and.    &
            (pfull_c(k) >= phalf_c(jksave))) then

!---------------------------------------------------------------------
!    if in diagnostcs column, output the pressure bounds of this region
!    (psa, phalf_c(jksave), the tendencies applied (qten, tten), and the         
!    large-scale model entropy     and moisture tendencies 
!    (mrmes, tmes) prior to the addition of these terms. 
!---------------------------------------------------------------------
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12)')  &
                    'in meens: po,psa,phr(jksave)= ',  &
                            Param%REF_PRESS, psa, phalf_c(jksave)
            write (diag_unit, '(a, i4, 2e20.12)')  &
                       'in meens: jk,qmes,qten= ', k, mrmes_dn(k), qten
            write (diag_unit, '(a, i4, 2e20.12)')  &
                 'in meens: jk,tmes,tten= ', k, tmes_dn(k), tten
          endif

!---------------------------------------------------------------------
!    update the moisture and entropy tendencies.
!---------------------------------------------------------------------
          mrmes_dn(k) = mrmes_dn(k) + qten
!!! ISN't emt (and therefore tten) already temperature tendency rather 
!   than theta, and so the conversion here is unnecessary ??
          pi=(Param%ref_press/pfull_c(k))**(Param%rdgas/Param%cp_air)
          tmes_dn(k) = tmes_dn(k) + (tten/pi)
        endif
      end do

!---------------------------------------------------------------------
!    define the mass flux of the mesoscale down-
!    draft (dmemh) in the region of the mesoscale downdraft.
!---------------------------------------------------------------------
      do k=1,nlev_lsm !miz
        if ((p_hires(k) <= pb) .and. (p_hires(k) >= pmd))  then
          dmemh(k) = -omd*ampta1/Param%grav  
        else
          dmemh(k) = 0.
        endif
      end do

!!$!---------------------------------------------------------------------
!!$!    call map_hi_res_col_to_lo_res_col to map the 
!!$!    mesoscale downdraft flux from the cloud model to the large-scale 
!!$!    model.
!!$!---------------------------------------------------------------------
!!$      call don_u_map_hires_c_to_lores_c_k  &
!!$           (nlev_lsm, nlev_hires, dmemh, p_hires, pmd + dp, phalf_c, &
!!$            dmeml, rintsum, rintsum2, ermesg) 
!!$      if (trim(ermesg) /= ' ') return

      dmeml=dmemh

    end subroutine don_m_meso_downdraft_miz

!######################################################################
!######################################################################


subroutine don_l_lscloud_driver_miz   &
         (isize, jsize, nlev_lsm, cloud_tracers_present, Param,  &
          Col_diag, pfull, temp,  exit_flag,  &
          mixing_ratio, qlin, qiin, qain, phalf, Don_conv, &
          donner_humidity_factor, donner_humidity_area,  &
           dql, dqi, dqa, mhalf_3d, &
          ermesg, error) 

!---------------------------------------------------------------------
!    subroutine don_l_lscloud_driver obtains variables needed by 
!    strat_cloud_mod that are dependent on the donner_deep parameter-
!    ization. specifically, the convective cell plus mesoscale anvil
!    cloud fraction (donner_humidity_area), the ratio of the large-scale 
!    specific humidity to the specific humidity in the environment out-
!    side of the convective system (donner_humidity_ratio), and the 
!    changes in cloud liquid, cloud ice and cloud area due to the con-
!    vective-system vertical mass flux and detrainment from the mesoscale
!    anvil to the large scale (dql, dqi, dqa) are passed out for use in 
!    strat_cloud_mod.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_param_type, &
                             donner_column_diag_type

implicit none

!---------------------------------------------------------------------
integer,                    intent(in)    :: isize, jsize, nlev_lsm
logical,                    intent(in)    :: cloud_tracers_present
type(donner_param_type),    intent(in)    :: Param
type(donner_column_diag_type),                    &
                            intent(in)    :: Col_diag
real, dimension(isize,jsize,nlev_lsm),         &
                            intent(in)    :: pfull, temp, mixing_ratio, &
                                             qlin, qiin, qain
logical, dimension(isize, jsize), intent(in) :: exit_flag
real, dimension(isize,jsize,nlev_lsm+1),        &
                            intent(in)    :: phalf 
type(donner_conv_type),     intent(inout) :: Don_conv
real, dimension(isize,jsize,nlev_lsm),           &
                            intent(out)   :: donner_humidity_factor,  &
                                             donner_humidity_area, dql, &
                                             dqi, dqa
real, dimension   (isize, jsize, nlev_lsm+1), &
                            intent(out)   :: mhalf_3d
character(len=*),           intent(out)   :: ermesg
integer,                    intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     pfull          pressure field on model full levels [ Pa ]
!     phalf          pressure field on model half levels [ Pa ]
!     temp           temperature field at model full levels [ deg K ]
!     mixing_ratio   water vapor specific humidity at model full 
!                    levels [ kg(h2o) / kg(air) ]
!     qlin           large-scale cloud liquid specific humidity
!                    [ kg(h2o) / kg(air) ]
!     qiin           large-scale cloud ice specific humidity
!                    [ kg(h2o) / kg(air) ]
!     qain           large-scale cloud fraction [ fraction ]
!
!   intent(inout) variables:
!
!     Don_conv
!
!
!   intent(out) variables:
!
!     donner_humidity_ratio
!                    ratio of large-scale specific humidity to the
!                    specific humidity in the environment outside
!                    of the convective system [ dimensionless ]
!     donner_humidity_area
!                    fractional area of cell plus meso circulation
!                    associated with donner_deep_mod [ fraction ]
!     dql            increment to large-scale cloud liquid field from
!                    donner_deep_mod [ kg(h2o) / kg (air) ]
!     dqi            increment to large-scale cloud ice field from
!                    donner_deep_mod [ kg(h2o) / kg (air) ]
!     dqa            increment to large-scale cloud area field from
!                    donner_deep_mod [ fraction ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:


      real, dimension (isize, jsize,nlev_lsm) ::  mass  
      integer     :: k, n, i, j

      real, dimension   &
            (isize, jsize, nlev_lsm  ) :: dmeso_3d

!---------------------------------------------------------------------
!   local variables:
!
!     dmeso_3d       detrainment rate from convective system 
!                    [ sec**(-1) ]
!     mhalf_3d       mass flux at model half-levels 
!                    [ kg / (m**2 sec) ]
!---------------------------------------------------------------------

      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    call define_donner_mass_flux to define the convective system 
!    detrainment rate (dmeso_3d) and the mass flux at model interface 
!    levels (mhalf_3d) that is associated with deep convection.
!---------------------------------------------------------------------
      call don_l_define_mass_flux_k    &
           (isize, jsize, nlev_lsm, pfull, phalf, Don_conv,   &
            dmeso_3d, mhalf_3d, exit_flag, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

 
!---------------------------------------------------------------------
!    call adjust_tiedtke_inputs to obtain the convective cloud area 
!    (donner_humidity_area) and the ratio of large-scale specific humid-
!    ity to the humidity in the environment of the convective system 
!    (donner_humidity_ratio).
!---------------------------------------------------------------------
      call don_l_adjust_tiedtke_inputs_k    &
           (isize, jsize, nlev_lsm, Param, Col_diag, pfull,temp,   &
            mixing_ratio, phalf, Don_conv, donner_humidity_factor, &
            donner_humidity_area, exit_flag, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
 
!---------------------------------------------------------------------
!    when strat_cloud is active, call strat_cloud_donner_tend to
!    define increments to cloudice, cloudwater and cloud area associated
!    with deep convective vertical mass flux and detrainment from the
!    mesoscale to the large-scale. 
!---------------------------------------------------------------------
      if (cloud_tracers_present) then
!!$        call don_l_strat_cloud_donner_tend_k   &
!!$             (isize, jsize, nlev_lsm, Param, Col_diag, dmeso_3d,   &
!!$              Don_conv%xliq, Don_conv%xice, qlin, qiin, qain, mhalf_3d, &
!!$              phalf, dql, dqi, dqa, ermesg)
      do k=1,nlev_lsm
        mass(:,:,k) = (phalf(:,:,k+1) - phalf(:,:,k))/Param%grav 
      end do

!---------------------------------------------------------------------
!    define the large scale cloud increments at level 1 to be 0.0.
!---------------------------------------------------------------------
      dql (:,:,1) = 0.
      dqi (:,:,1) = 0.
      dqa (:,:,1) = 0.
    
!---------------------------------------------------------------------
!    define the tendencies of cloud liquid, cloud ice and cloud area
!    due to the vertical mass flux associated with donner_deep con-
!    vection.
!---------------------------------------------------------------------
!---------------------------------------------------------------------
!    add the effects of detrainment from the mesoscale region.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        dql (:,:,k) = Don_conv%ecds(:,:,k)
        dqi (:,:,k) = Don_conv%eces(:,:,k)
        dqa (:,:,k) = Don_conv%fre (:,:,k)
      end do

      do i=1,isize  
         do j=1,jsize  
            do k=1,nlev_lsm
               if ( (pfull(i,j,k) .le. Don_conv%pzm_v (i,j)) .and. &
                    (pfull(i,j,k) .ge. Don_conv%pztm_v(i,j)) ) then
!                  meso_area_miz(i,j,k)=Don_conv%ampta1(i,j)
!                  meso_updt_miz(i,j,k)=Param%meso_ref_omega
               else
!                  meso_area_miz(i,j,k)=0.
!                  meso_updt_miz(i,j,k)=0.
               end if
            end do
         end do
      end do

 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
      endif

!---------------------------------------------------------------------


    end subroutine don_l_lscloud_driver_miz

!#####################################################################
!######################################################################

subroutine don_d_remove_normalization_miz   &
      (isize, jsize, nlev_lsm, ntr, exit_flag, Nml, Don_conv,  &
       total_precip, Initialized, temperature_forcing,  &
       moisture_forcing, ermesg, error)

!---------------------------------------------------------------------
!    subroutine remove_normalization removes the normalization by the
!    cloud base fractional area from the various convective diagnostics
!    and output fields so that they are ready fro use in the large-scale
!    model equations.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_nml_type, &
                             donner_initialized_type, DET_MASS_FLUX, &
                             MASS_FLUX, CELL_UPWARD_MASS_FLUX, &
                             TEMP_FORCING, MOIST_FORCING, PRECIP, &
                             FREEZING, RADON_TEND

implicit none 

!---------------------------------------------------------------------
integer,                          intent(in)    :: isize, jsize, &
                                                   nlev_lsm, ntr
logical, dimension(isize,jsize),  intent(in)    :: exit_flag
type(donner_nml_type),            intent(in)    :: Nml      
type(donner_conv_type),           intent(inout) :: Don_conv
type(donner_initialized_type),    intent(inout) :: Initialized
real   , dimension(isize,jsize),  intent(inout) :: total_precip
real   , dimension(isize,jsize,nlev_lsm),                 &
                                  intent(inout) :: temperature_forcing, &
                                                   moisture_forcing
character(len=*),                 intent(out)   :: ermesg
integer,                          intent(out)   :: error
!----------------------------------------------------------------------
!   intent(in) variables:
!
!     exit_flag      logical array indicating whether donner convection
!                    is not active (.true.) or is active (.false.) in
!                    each model column 
!
!   intent(inout) variables:
!    
!     Don_conv       donner_convection_type derived type variable 
!                    containing fields produced by the donner_deep
!                    convection mod 
!     total_precip   precipitation generated by deep convection
!                    [ kg / m**2 ]
!     moisture_forcing
!                    time tendency of vapor mixing ratio due to deep 
!                    convection [ kg(h2o) / kg(dry air) / sec ]
!     temperature_forcing
!                    time tendency of temperature due to deep 
!                    convection [ deg K / sec ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer :: i, j, k, n    ! do-loop indices
      real    :: ttend_max
      real, dimension(nlev_lsm) :: variable

!-----------------------------------------------------------------------
!    initialize the error message character string.
!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    remove normalization from the cumulus diagnostics and forcing terms
!    by multiplying them by the fractional cloud base area. these values
!    thus become grid-box averages, rather than averages over the cloudy
!    area, and so are appropriate to use in the large-scale model
!    equations. 
!---------------------------------------------------------------------
      do j=1,jsize                          
        do i=1,isize

!---------------------------------------------------------------------
!    if deep convection is present in the column, denormalize the 
!    convective fields.
!--------------------------------------------------------------------
          if (.not. exit_flag(i,j)) then
            if (Initialized%monitor_output) then
              do n=1, size(Initialized%Don_monitor, 1)
                select case (Initialized%Don_monitor(n)%index)
                  case (DET_MASS_FLUX)
                    variable(:) = Don_conv%detmfl(i,j,:)*   &
                                                       Don_conv%a1(i,j)
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (MASS_FLUX)
                    variable(:) =   &
                      (Don_conv%umeml(i,j,:) + Don_conv%dmeml(i,j,:) + &
                       Don_conv%uceml(i,j,:))*Don_conv%a1(i,j) 
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                     
                  case (CELL_UPWARD_MASS_FLUX)
                    variable(:) = Don_conv%uceml(i,j,:)*Don_conv%a1(i,j)
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (TEMP_FORCING)
                    variable(:) =   &
                           temperature_forcing(i,j,:)*Don_conv%a1(i,j) 
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))

                  case (MOIST_FORCING)
                    variable(:) =   &
                               moisture_forcing(i,j,:)*Don_conv%a1(i,j) 
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (PRECIP)
                    variable(:) = total_precip(i,j)*Don_conv%a1(i,j) 
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                  case (FREEZING)
                    variable(:) = Don_conv%fre(i,j,:)*Don_conv%a1(i,j) 
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))
                end select
              end do
            endif 
                     
!miz
             ttend_max=0;
             do k=1,nlev_lsm 
                ttend_max=max(ttend_max, abs(temperature_forcing(i,j,k))*Don_conv%a1(i,j))
             end do
             if (ttend_max > Nml%ttend_max) then
                Don_conv%a1(i,j)=Don_conv%a1(i,j)*(Nml%ttend_max/ttend_max)
             end if
!miz

            total_precip(i,j) =  total_precip(i,j)*Don_conv%a1(i,j)
            Don_conv%meso_precip(i,j) = Don_conv%meso_precip(i,j)* &
                 Don_conv%a1(i,j)
            Don_conv%ampta1(i,j) = Don_conv%ampta1(i,j)*Don_conv%a1(i,j)
            Don_conv%cell_precip(i,j) =              &
                             Don_conv%cell_precip (i,j)*Don_conv%a1(i,j)
            Don_conv%emdi_v(i,j) = Don_conv%emdi_v(i,j)*Don_conv%a1(i,j)
            do k=1,nlev_lsm                           
              Don_conv%wetdepc(i,j,k,:) = &
                              Don_conv%wetdepc(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%wetdept(i,j,k,:) = &
                              Don_conv%wetdepc(i,j,k,:)
              temperature_forcing(i,j,k) =   &
                             temperature_forcing(i,j,k)*Don_conv%a1(i,j)
              Don_conv%ceefc(i,j,k) =   &
                                  Don_conv%ceefc(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cecon(i,j,k) =        &
                                  Don_conv%cecon(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cemfc(i,j,k) =      &
                                  Don_conv%cemfc(i,j,k)*Don_conv%a1(i,j)
              moisture_forcing(i,j,k) =      &
                                moisture_forcing(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cual (i,j,k) =       &
                                   Don_conv%cual(i,j,k)*Don_conv%a1(i,j)
              Don_conv%fre(i,j,k) = Don_conv%fre(i,j,k)*Don_conv%a1(i,j)
              Don_conv%elt(i,j,k) = Don_conv%elt(i,j,k)*Don_conv%a1(i,j)
              Don_conv%cmus(i,j,k) =      &
                                   Don_conv%cmus(i,j,k)*Don_conv%a1(i,j)
              Don_conv%ecds(i,j,k) =      &
                                   Don_conv%ecds(i,j,k)*Don_conv%a1(i,j)
              Don_conv%eces(i,j,k) =      &
                                   Don_conv%eces(i,j,k)*Don_conv%a1(i,j)
              Don_conv%emds(i,j,k) =       &
                                   Don_conv%emds(i,j,k)*Don_conv%a1(i,j)
              Don_conv%emes(i,j,k) =       &
                                   Don_conv%emes(i,j,k)*Don_conv%a1(i,j)
              Don_conv%mrmes(i,j,k) =       &
                                  Don_conv%mrmes(i,j,k)*Don_conv%a1(i,j)
              Don_conv%wmps(i,j,k) =       &
                                   Don_conv%wmps(i,j,k)*Don_conv%a1(i,j)
              Don_conv%wmms(i,j,k) =      &
                                   Don_conv%wmms(i,j,k)*Don_conv%a1(i,j)
              Don_conv%tmes(i,j,k) =      &
                                   Don_conv%tmes(i,j,k)*Don_conv%a1(i,j)
              Don_conv%dmeml(i,j,k) =      &
                                  Don_conv%dmeml(i,j,k)*Don_conv%a1(i,j)
              Don_conv%uceml(i,j,k) =      &
                                  Don_conv%uceml(i,j,k)*Don_conv%a1(i,j)
              Don_conv%detmfl(i,j,k) =      &
                                 Don_conv%detmfl(i,j,k)*Don_conv%a1(i,j)
              Don_conv%umeml(i,j,k) =      &
                                  Don_conv%umeml(i,j,k)*Don_conv%a1(i,j)
              Don_conv%qtren1(i,j,k,:) =     &
                               Don_conv%qtren1(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%qtmes1(i,j,k,:) =     &
                               Don_conv%qtmes1(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%wtp1(i,j,k,:) =       &
                                 Don_conv%wtp1(i,j,k,:)*Don_conv%a1(i,j)
              Don_conv%qtceme(i,j,k,:) =   &
                     Don_conv%qtmes1(i,j,k,:) + Don_conv%qtren1(i,j,k,:)
            end do
            if (Initialized%monitor_output) then
              do n=1, size(Initialized%Don_monitor, 1)
                select case (Initialized%Don_monitor(n)%index)
                  case (RADON_TEND)
                    variable(:) = Don_conv%qtceme   &
                        (i,j,:,Initialized%Don_monitor(n)%tracer_index) 
                    call don_u_process_monitor_k (variable, i, j,  &
                                   nlev_lsm, Initialized%Don_monitor(n))

                end select
              end do
            endif 
!---------------------------------------------------------------------
!    if deep convection is not present in the column, define the output
!    fields appropriately.
!---------------------------------------------------------------------
          else
            total_precip(i,j) = 0.
            do k=1,nlev_lsm
              temperature_forcing(i,j,k) = 0.
              moisture_forcing(i,j,k) = 0.
            end do
          endif
        end do
      end do

!---------------------------------------------------------------------

    end subroutine don_d_remove_normalization_miz

!#####################################################################


    subroutine don_d_copy_wetdep_miz( wetdep_donner, wetdep_plume, nspecies )
 
   use  conv_plumes_k_mod, only : cwetdep_type
   use donner_types_mod, only : donner_wetdep_type
 
   implicit none
 
   type(donner_wetdep_type), intent(in) :: wetdep_donner(nspecies)
   type(cwetdep_type), intent(inout)    :: wetdep_plume(nspecies)
   integer, intent(in)                  :: nspecies

   integer :: n

   do n = 1,nspecies
      wetdep_plume(n)%scheme = wetdep_donner(n)%scheme
      wetdep_plume(n)%Henry_constant = wetdep_donner(n)%Henry_constant
      wetdep_plume(n)%Henry_variable = wetdep_donner(n)%Henry_variable
      wetdep_plume(n)%frac_in_cloud = wetdep_donner(n)%frac_in_cloud
      wetdep_plume(n)%alpha_r = wetdep_donner(n)%alpha_r
      wetdep_plume(n)%alpha_s = wetdep_donner(n)%alpha_s
      wetdep_plume(n)%Lwetdep = wetdep_donner(n)%Lwetdep
      wetdep_plume(n)%Lgas = wetdep_donner(n)%Lgas
      wetdep_plume(n)%Laerosol = wetdep_donner(n)%Laerosol
      wetdep_plume(n)%Lice = wetdep_donner(n)%Lice
   end do

   end subroutine don_d_copy_wetdep_miz



!####################################################################
!######################################################################


subroutine cu_clo_miz   &
         (nlev_lsm, ntr, dt, Initialized, Param, tracers, &
          pfull, zfull, phalf, zhalf, pblht, tkemiz, qstar, cush, cbmf, land,  &
          coldT, sd, Uw_p, ac, Nml, env_r, env_t, a1, ermesg, error)

use donner_types_mod,     only : donner_param_type, donner_nml_type, &
                                 donner_initialized_type
use conv_utilities_k_mod, only : pack_sd_lsm_k, extend_sd_k,  &
                                 adi_cloud_k, sounding, adicloud, &
                                 uw_params, qt_parcel_k

implicit none

integer,                        intent(in)  :: nlev_lsm, ntr
real,                           intent(in)  :: dt
type(donner_param_type),        intent(in)  :: Param
type(donner_initialized_type),  intent(in)  :: Initialized
type(donner_nml_type),          intent(in)  :: Nml
real,                           intent(in)  :: pblht, tkemiz, qstar, cush, cbmf, land
logical,                        intent(in)  :: coldT
real, dimension(nlev_lsm),      intent(in)    :: pfull, zfull 
real, dimension(nlev_lsm,ntr),  intent(in)    :: tracers
real, dimension(nlev_lsm+1),    intent(in)    :: phalf, zhalf 
type(sounding),                 intent(inout) :: sd           
type(uw_params),                intent(inout) :: Uw_p         
type(adicloud),                 intent(inout) :: ac

real,    dimension(nlev_lsm),   intent(in)  :: env_r, env_t
real,                           intent(out) :: a1
character(len=*),               intent(out) :: ermesg
integer,                        intent(out) :: error

real, dimension (nlev_lsm)  :: ttt, rrr
real    :: zsrc, psrc, hlsrc, thcsrc, qctsrc, cape_c, lofactor
integer :: k
real    :: sigmaw, wcrit, cbmf1, rbuoy, rkfre, wcrit_min, rmaxfrac

   ermesg = ' '; error = 0

   do k=1,nlev_lsm
      ttt (k) = env_t(nlev_lsm-k+1)
      rrr (k) = env_r(nlev_lsm-k+1)/(1.-env_r(nlev_lsm-k+1))
   end do

   call pack_sd_lsm_k      &
        (Nml%do_lands, land, coldT, dt, pfull, phalf, zfull,  &
        zhalf, ttt, rrr, tracers, sd)
   call extend_sd_k (sd, pblht, .false., Uw_p)
   zsrc  =sd%zs (1)
   psrc  =sd%ps (1)
   thcsrc=sd%thc(1)
   qctsrc=sd%qct(1)
   hlsrc =sd%hl (1)
   cape_c=Nml%cape0
   if (Nml%do_lands) then
      call qt_parcel_k (sd%qs(1), qstar, pblht, tkemiz, sd%land, &
           Nml%gama, Nml%pblht0, Nml%tke0, Nml%lofactor0, Nml%lochoice, qctsrc, lofactor)
      cape_c = Nml%cape0 * (1. - sd%land * (1. - Nml%lofactor0))
   endif
   call adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, Uw_p, &
                        .false., Nml%do_freezing_for_closure, ac)

   rbuoy     = 1.0
   rkfre     = 0.05
   wcrit_min = 0.5
   rmaxfrac  = 0.05

   wcrit  = sqrt(2. * ac % cin * rbuoy)
   sigmaw = sqrt(rkfre * tkemiz)
   wcrit  = max(wcrit, wcrit_min*sigmaw)
   cbmf1   = ac % rho0lcl * sigmaw / 2.5066 * exp(-0.5*((wcrit/sigmaw)**2.))
   cbmf1   = min(cbmf, ( sd%ps(0) - ac%plcl ) * 0.25 / sd%delt / Uw_p%GRAV)

   if (cush > Nml%deephgt0) then  
      a1=cbmf/0.5
   else
      a1=0
   end if

!   erfarg=wcrit / (1.4142 * sigmaw)
!   if(erfarg.lt.20.)then
!      ufrc = min(rmaxfrac, 0.5*erfccc(erfarg))
!   else
!      ufrc = 0.
!   endif

 end subroutine cu_clo_miz



!######################################################################
!######################################################################
!
! Alternative closure for Donner lite convection. This subroutine
! closes convective cloud base area using numerical approximations.
! It attempts to find the cloud base area (a1) that will produce
! the desired change in CAPE after the convective tendencies are
! applied.
!
! This subroutine works for both CAPE relaxation (do_dcape = .false.)
! and instanteneous CAPE adjustment (do_dcape = .true.) closures,
! as well as all available options for CAPE calculations routines
! controlled using namelist parameters do_donner_cape and
! do_hires_cape_for_closure
!
! do_donner_cape  do_hires_cape_for_closure  CAPE algorithm
! .false.         .false.                    UW
! .true.          .true.                     High-res Donner routine 
!                                             for trigger and closure
! .false.         .true.                     High-res Donner routine 
!                                             for closure only
! 
! The numerical algorithm for determining a1 can be best described
! as a "guided" bissection search. It is a bissection search except
! for the first three "guided" steps:
!
! Step 1:  If needed, compute environmental CAPE.
! Step 2:  Compute CAPE for an arbitrary small cloud base area 0.001.
!          Compute approximate cloud base area using linear approximation
!          and CAPE values from steps 1 and 2.
! Step 3:  Compute CAPE for linearly interpolated approximate cloud area.
!          Identify two values of cloud base areas that bracket the target
!          CAPE value.
! Step 4+: Continue using standard bissection algorithm.
!
! The algorithm will often converge during step 3, thus requiring
! only two CAPE computations.
!
! Parameters for evaluating convergence are described below.
!

subroutine cu_clo_cjg   &
           (me, nlev_model, nlev_parcel, ntr, dt, diag_unit, debug_ijt, &
            Initialized, &
            Param, Nml, amax, cape, dcape, cape_p, env_t, env_r, qt_v, qr_v, &
            pfull, zfull, phalf, zhalf, tracers, &
            land, pblht, tkemiz, qstar, coldT, sd, Uw_p, ac, &
            a1, ermesg, error )

use donner_types_mod,     only : donner_param_type, donner_nml_type, &
                                 donner_initialized_type
use conv_utilities_k_mod, only : pack_sd_lsm_k, extend_sd_k,  &
                                 adi_cloud_k, qt_parcel_k, sounding, & 
                                 adicloud, uw_params

implicit none

!----------------------------------------------------------------------
!   calling arguments

! Input

integer,                          intent(in) :: me            ! pe number
integer,                          intent(in) :: nlev_model    ! # model levels
integer,                          intent(in) :: nlev_parcel   ! # levels for CAPE
integer,                          intent(in) :: ntr           ! number of tracers
real,                             intent(in) :: dt            ! time step
integer,                          intent(in) :: diag_unit     ! column diagnostics
logical,                          intent(in) :: debug_ijt

type(donner_initialized_type),    intent(in) :: Initialized   ! Donner parameters
type(donner_param_type),          intent(in) :: Param         ! Donner parameters
type(donner_nml_type),            intent(in) :: Nml           ! Donner namelist
real,                             intent(in) :: amax          ! Max allowable cloud base
real,                             intent(in) :: cape          ! Environment CAPE
real,                             intent(in) :: dcape         ! CAPE change for dcape closure
real,  dimension(nlev_parcel),    intent(in) :: cape_p        ! p levels of CAPE profiles
real,  dimension(nlev_parcel),    intent(in) :: env_t, env_r  ! T, r CAPE profiles
real,  dimension(nlev_parcel),    intent(in) :: qt_v,  qr_v   ! Normalized cu tendencies

real, dimension(nlev_model),      intent(in) :: pfull, zfull  ! Full model levels (p and z)
real, dimension(nlev_model+1),    intent(in) :: phalf, zhalf  ! Half model levels (p and z)
real, dimension(nlev_model,ntr),  intent(in) :: tracers       ! Tracer array

! Variables needed for computing CAPE using UW formulation
real,                             intent(in) :: land, pblht, tkemiz, qstar
logical,                          intent(in) :: coldT
type(sounding),                intent(inout) :: sd
type(uw_params),               intent(inout) :: Uw_p
type(adicloud),                intent(inout) :: ac

! Output

real,                            intent(out) :: a1             ! Output cloud base area
character(len=*),                intent(out) :: ermesg         ! Output error status
integer,                         intent(out) :: error

!----------------------------------------------------------------------
! Parameters controlling iterations
!
! - nitermax is the maximum number of iterations allowed (i.e. the 
!   maximum number of CAPE calculations to be performed)
! - accuracy on a1 is controlled by a1_abs_acc. The bissection
!   algorithm will stop once the bracket interval becomes smaller
!   than a1_abs_acc
! - accuracy of the final CAPE value is controlled by cape_rel_acc,
!   which is the relative accuracy desired.
!

integer, parameter           :: nitermax = 10          ! max number of iterations
real, parameter              :: a1_abs_acc = 0.0001    ! absolute a1 accuracy
real, parameter              :: cape_rel_acc = 0.01    ! relative CAPE accuracy 

!----------------------------------------------------------------------
!   local variables

real, dimension(nitermax+1)  :: xa1, xcape

real                         :: x1, x2, xnew
real                         :: f1, f2, fnew
real                         :: tmp

real                         :: cape_target
real                         :: cape_target_acc

integer                      :: k, n, niter, nfirst, exit_flag
real                         :: plfc, plzb, plcl, coin
real, dimension(nlev_parcel) :: parcel_t, parcel_r

real, dimension(nlev_model)  :: tmp_t, tmp_r
real, dimension(nlev_parcel) :: updated_t, updated_r

real                         :: lofactor

    ermesg = ' '; error = 0

! ------------------------------------------------------------------------------
! Initialization

    exit_flag = 0
    xa1   = -999.0
    xcape = -999.0

!   The first iteration has zero cloud base area and corresponds to 
!   the environmental CAPE.

    xa1(1) = 0.0

!   Input calling argument 'cape' contains CAPE value of the environment.
!   We don't need to recompute it except when
!    the conditions in the if statement apply
!   because in that case, CAPE of the environment has been computed using
!   a different algorithm.


    if ( (Nml%do_donner_cape .EQV. .false.  &                        
         .and. Nml%do_hires_cape_for_closure .EQV. .true. ) .or.  &
    Nml%do_freezing_for_cape .NEQV. Nml%do_freezing_for_closure .or. &
           Nml%tfre_for_cape /=     Nml%tfre_for_closure .or. &
           Nml%dfre_for_cape /=     Nml%dfre_for_closure .or. &
           .not. (Initialized%use_constant_rmuz_for_closure) .or.  &
          Nml%rmuz_for_cape /= Nml%rmuz_for_closure) then
      nfirst = 1

    else

!     Environmental CAPE is known
      nfirst = 2
      xcape(1) = cape

!     Target CAPE value and accuracy for closure
      if (Nml%do_dcape) then
        cape_target = xcape(1) - dcape * dt
      else
        cape_target = xcape(1) - (xcape(1)-Nml%cape0)/Nml%tau * dt
      end if
      cape_target_acc = cape_rel_acc * cape_target

!     Next iteration
      xa1(2) = 0.001

    end if

    do n=nfirst,nitermax
      
      xnew = xa1(n)

!     Update profile and compute its CAPE

      updated_t = env_t + xnew * qt_v * dt
      updated_r = env_r + xnew * qr_v * dt

      if ( Nml%do_donner_cape .or. Nml%do_hires_cape_for_closure ) then

!       Using Donner subroutine

        call don_c_displace_parcel_k  &
             ( nlev_parcel, diag_unit, debug_ijt, Param, &
               Nml%do_freezing_for_closure, Nml%tfre_for_closure, Nml%dfre_for_closure, &
               Nml%rmuz_for_closure, &
               Initialized%use_constant_rmuz_for_closure, &
               Nml%modify_closure_plume_condensate, &
               Nml%closure_plume_condensate, &
               updated_t, updated_r, &
               cape_p, .true., plfc, plzb, plcl, coin, fnew, &
               parcel_r, parcel_t, ermesg, error )
  
        if (error /= 0 ) return

      else

!       Using UW code

        do k=1,nlev_model
          tmp_t(k) = updated_t(nlev_model-k+1)
          tmp_r(k) = updated_r(nlev_model-k+1)
        end do
        call pack_sd_lsm_k &
             ( Nml%do_lands, land, coldT, dt, pfull, phalf, zfull, zhalf, &
               tmp_t, tmp_r, tracers, sd )
        call extend_sd_k (sd, pblht, .false., Uw_p) 
        if (Nml%do_lands) then
           call qt_parcel_k (sd%qs(1), qstar, pblht, &
                             tkemiz, sd%land, &
                             Nml%gama, Nml%pblht0, Nml%tke0, Nml%lofactor0, &
                             Nml%lochoice, sd%qct(1), lofactor)
        end if
        call adi_cloud_k (sd%zs(1), sd%ps(1), sd%hl(1), sd%thc(1), sd%qct(1), sd, &
                          Uw_p, .false., Nml%do_freezing_for_cape, ac)
        fnew=ac%cape

      end if

!     Check for convergence and/or select value for next iteration

      xcape(n) = fnew

      if ( n == 1 ) then       ! First iteration

!       Target CAPE value and accuracy for closure
        if (Nml%do_dcape) then
          cape_target = xcape(1) - dcape * dt
        else
          cape_target = xcape(1) - (xcape(1)-Nml%cape0)/Nml%tau * dt
        end if
        cape_target_acc = cape_rel_acc * cape_target

!       Environmental CAPE already below target
        if ( xcape(1) <= cape_target ) then
          exit_flag = 1
          exit
        end if

!       Next iteration
        xa1(2) = 0.001

      else if ( n == 2 ) then  ! Second iteration

!       Re-order 1 and 2 to ensure xcape(1) >= xcape(2)
        if ( xcape(1) < xcape(2) ) then

          tmp = xa1(2)
          xa1(2) = xa1(1)
          xa1(1) = tmp

          tmp = xcape(2)
          xcape(2) = xcape(1)
          xcape(1) = tmp

        end if

!       Linear approximation for next iteration
        xa1(3)  &
        = max( 0.0,  &
               min( xa1(1) + (cape_target-xcape(1))/(xcape(2)-xcape(1))*(xa1(2)-xa1(1)) &
                  , amax ) &
             )

      else if ( n == 3 ) then  ! Third iteration

!       Exit iteration if convergence criteria for CAPE is met
        if ( abs(fnew-cape_target) .lt. cape_target_acc ) then
          exit_flag = 2
          exit
        end if

!       Exit iteration if desired CAPE value cannot be reached without
!       exceeding maximum cloud base area
        if ( xnew >= amax .and. fnew >= cape_target ) then
          exit_flag = 3
          exit
        end if

!       Re-order 2 and 3 so that xcape(1) >= xcape(2) >= xcape(3)
        if ( xcape(2) < xcape(3) ) then

          tmp = xa1(3)
          xa1(3) = xa1(2)
          xa1(2) = tmp

          tmp = xcape(3)
          xcape(3) = xcape(2)
          xcape(2) = tmp

        end if

!       Find where cape_target falls and decide what to do
        if ( cape_target >= xcape(2) ) then
           x1 = xa1(1)
           x2 = xa1(2)
           f1 = xcape(1)
           f2 = xcape(2)
        else if ( cape_target >= xcape(3) ) then
           x1 = xa1(2)
           x2 = xa1(3)
           f1 = xcape(2)
           f2 = xcape(3)
        else
           x1 = xa1(3)
           x2 = 2*amax - x1
           f1 = xcape(3)
           f2 = 0.0
        end if
        
        xa1(n+1) = 0.5*(x1+x2)

      else    ! Beyond third iteration, continue using bissection algorithm

!       Exit iteration if convergence criteria for CAPE is met
        if ( abs(fnew-cape_target) < cape_target_acc ) then
          exit_flag = 4
          exit
        end if

!       Exit iteration if desired CAPE value cannot be reached without
!       exceeding maximum cloud base area
        if ( xnew >= amax .and. fnew >= cape_target ) then
          exit_flag = 5
          exit
        end if

!       Select bracket for next iteration
        if ( fnew < cape_target ) then
          x2 = xnew
          f2 = fnew
        else
          x1 = xnew
          f1 = fnew
        end if

!       If bracket (x1,x2) is smaller than target, choose best point
!       between x1 and x2 and exit
        if ( abs(x1-x2) < a1_abs_acc ) then
          exit_flag = 6
          exit
        end if

!       Continue to next iteration
        xa1(n+1) = 0.5*(x1+x2)

      end if

    end do
    niter = min( n, nitermax )

!   If iteration exited because bracket became smaller than 
!   threshold or because maximum number of iterations was reached,
!   select the best solution between f1 and f2
    if ( exit_flag == 0 .or. exit_flag == 6 ) then

      if ( abs(f1-cape_target) < abs(f2-cape_target) ) then
        xnew = x1
        fnew = f1
      else
        xnew = x2
        fnew = f2
      end if

    end if

!   Copy result into output variable
    a1 = xnew

! ------------------------------------------------------------------------------
! Output debugging information

    if (debug_ijt) then

      write (diag_unit, '(a)' ) &
        ' --- begin cu_clo_cjg debug info ---------------------------------------'
!     write (diag_unit, '(a)')  & 
!       '                      cu_clo_cjg input profile'
!     write (diag_unit, '(a)')  &
!       '   k   press      temp           mixing ratio '
!     write (diag_unit, '(a)')  &
!       '        hPa       deg K    g(h2o) / kg (dry air)  '
!     do k=1,nlev_parcel
!       write (diag_unit, '(i4, 2f10.4, 7x, 1pe13.5)')  &
!            k, 1.0E-02*cape_p(k), env_t(k), 1.0e03*env_r(k)
!     end do

!     write (diag_unit, '(a)')  &
!       '    k, tmp_t(k), 1.0e3*tmp_r(k)'
!     do k=1,nlev_model
!       write (diag_unit, '(i4, 2f10.4)')  &
!            k, tmp_t(k), 1.0e3*tmp_r(k)
!     end do

!     write (diag_unit, '(a)') '  '
!     write (diag_unit, '(a, f20.12)') &
!       'cjg: xcape0a = ',xcape0a
!     write (diag_unit, '(a, f20.12)') &
!       'cjg: xcape0b = ',xcape0b

!     write (diag_unit, '(a)') '  '
!     write (diag_unit, '(a)')  & 
!       '                      cu_clo_cjg updated profile'
!     write (diag_unit, '(a)')  &
!       '   k   press      temp           mixing ratio '
!     write (diag_unit, '(a)')  &
!       '        hPa       deg K    g(h2o) / kg (dry air)  '
!     do k=1,nlev_parcel
!       write (diag_unit, '(i4, 2f10.4, 7x, 1pe13.5)')  &
!            k, 1.0E-02*cape_p(k), updated_t(k), 1.0e03*updated_r(k)
!     end do

!     write (diag_unit, '(a)') '  '
!     write (diag_unit, '(a, f20.12)') &
!       'cjg: xcape1a = ',xcape1a
!     write (diag_unit, '(a, f20.12)') &
!       'cjg: xcape1b = ',xcape1b

      write (diag_unit, '(a)') '  '
      write (diag_unit, '(a, f10.4)') &
        'cjg: amax = ',amax
      write (diag_unit, '(a, f10.4)') &
        'cjg: cape = ',cape
      write (diag_unit, '(a, f10.4)') &
        'cjg: cape_target = ',cape_target
      do n=1,nitermax
        write (diag_unit, '(a, i4, 2f10.4)')  &
             'cjg: ', n, xa1(n), xcape(n)
      end do
      write (diag_unit, '(a)' ) &
        ' --- end cu_clo_cjg debug info -----------------------------------------'

    end if

!RSH   debug_unit = 1000+mpp_pe()
!   debug_unit = 1000+me
!   write (debug_unit, '(a)') '  '
!   write (debug_unit, '(a, f10.4)') &
!     'cjg: amax = ',amax
!   write (debug_unit, '(a, f10.4)') &
!     'cjg: cape = ',cape
!   write (debug_unit, '(a, f10.4)') &
!     'cjg: cape_target = ',cape_target
!   do n=1,nitermax
!     write (debug_unit, '(a, i4, 2f10.4)')  &
!          'cjg: ', n, xa1(n), xcape(n)
!   end do
!   write (debug_unit, '(a, 2f10.4)') &
!     'cjg: final a1, cape = ',xnew,fnew
!   write (debug_unit, '(a, i4)') 'cjg: iterations = ',niter
!   write (debug_unit, '(a, i4)') 'cjg: exit_flag = ',exit_flag
!   do n=nfirst,niter
!     write (debug_unit, '(a)') 'cjg: niter'
!   end do

end subroutine cu_clo_cjg

!######################################################################
!######################################################################






!VERSION NUMBER:
!  $Id: donner_lscloud_k.F90,v 17.0.2.1.2.1 2010/03/17 20:27:07 wfc Exp $

!module donner_lscloud_inter_mod

!#include "donner_types.h"

!end module donner_lscloud_inter_mod


!#####################################################################

subroutine don_l_lscloud_driver_k   &
         (isize, jsize, nlev_lsm, cloud_tracers_present, Param,  &
          Col_diag, pfull, temp, exit_flag,   &
          mixing_ratio, qlin, qiin, qain, phalf, Don_conv, &
          donner_humidity_factor, donner_humidity_area, dql, dqi, dqa, &
          mhalf_3d, &
          ermesg, error) 

!---------------------------------------------------------------------
!    subroutine don_l_lscloud_driver obtains variables needed by 
!    strat_cloud_mod that are dependent on the donner_deep parameter-
!    ization. specifically, the convective cell plus mesoscale anvil
!    cloud fraction (donner_humidity_area), the ratio of the large-scale 
!    specific humidity to the specific humidity in the environment out-
!    side of the convective system (donner_humidity_ratio), and the 
!    changes in cloud liquid, cloud ice and cloud area due to the con-
!    vective-system vertical mass flux and detrainment from the mesoscale
!    anvil to the large scale (dql, dqi, dqa) are passed out for use in 
!    strat_cloud_mod.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_param_type, &
                             donner_column_diag_type

implicit none

!---------------------------------------------------------------------
integer,                    intent(in)    :: isize, jsize, nlev_lsm
logical,                    intent(in)    :: cloud_tracers_present
type(donner_param_type),    intent(in)    :: Param
type(donner_column_diag_type),                    &
                            intent(in)    :: Col_diag
logical, dimension(isize,jsize), intent(in) :: exit_flag
real, dimension(isize,jsize,nlev_lsm),         &
                            intent(in)    :: pfull, temp, mixing_ratio, &
                                             qlin, qiin, qain
real, dimension(isize,jsize,nlev_lsm+1),        &
                            intent(in)    :: phalf 
type(donner_conv_type),     intent(inout) :: Don_conv
real, dimension(isize,jsize,nlev_lsm),           &
                            intent(out)   :: donner_humidity_factor,  &
                                             donner_humidity_area, dql, &
                                             dqi, dqa
real, dimension(isize, jsize, nlev_lsm+1),   &
                            intent(out)   :: mhalf_3d
character(len=*),           intent(out)   :: ermesg
integer,                    intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     pfull          pressure field on model full levels [ Pa ]
!     phalf          pressure field on model half levels [ Pa ]
!     temp           temperature field at model full levels [ deg K ]
!     mixing_ratio   water vapor specific humidity at model full 
!                    levels [ kg(h2o) / kg(air) ]
!     qlin           large-scale cloud liquid specific humidity
!                    [ kg(h2o) / kg(air) ]
!     qiin           large-scale cloud ice specific humidity
!                    [ kg(h2o) / kg(air) ]
!     qain           large-scale cloud fraction [ fraction ]
!
!   intent(inout) variables:
!
!     Don_conv
!
!
!   intent(out) variables:
!
!     donner_humidity_ratio
!                    ratio of large-scale specific humidity to the
!                    specific humidity in the environment outside
!                    of the convective system [ dimensionless ]
!     donner_humidity_area
!                    fractional area of cell plus meso circulation
!                    associated with donner_deep_mod [ fraction ]
!     dql            increment to large-scale cloud liquid field from
!                    donner_deep_mod [ kg(h2o) / kg (air) ]
!     dqi            increment to large-scale cloud ice field from
!                    donner_deep_mod [ kg(h2o) / kg (air) ]
!     dqa            increment to large-scale cloud area field from
!                    donner_deep_mod [ fraction ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:


      real, dimension   &
            (isize, jsize, nlev_lsm  ) :: dmeso_3d

!---------------------------------------------------------------------
!   local variables:
!
!     dmeso_3d       detrainment rate from convective system 
!                    [ sec**(-1) ]
!     mhalf_3d       mass flux at model half-levels 
!                    [ kg / (m**2 sec) ]
!---------------------------------------------------------------------

      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    call define_donner_mass_flux to define the convective system 
!    detrainment rate (dmeso_3d) and the mass flux at model interface 
!    levels (mhalf_3d) that is associated with deep convection.
!---------------------------------------------------------------------
      call don_l_define_mass_flux_k    &
           (isize, jsize, nlev_lsm, pfull, phalf, Don_conv,   &
            dmeso_3d, mhalf_3d, exit_flag, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

 
!---------------------------------------------------------------------
!    call adjust_tiedtke_inputs to obtain the convective cloud area 
!    (donner_humidity_area) and the ratio of large-scale specific humid-
!    ity to the humidity in the environment of the convective system 
!    (donner_humidity_ratio).
!---------------------------------------------------------------------
      call don_l_adjust_tiedtke_inputs_k    &
           (isize, jsize, nlev_lsm, Param, Col_diag, pfull,temp,   &
            mixing_ratio, phalf, Don_conv, donner_humidity_factor, &
            donner_humidity_area,exit_flag,  ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
 
!---------------------------------------------------------------------
!    when strat_cloud is active, call strat_cloud_donner_tend to
!    define increments to cloudice, cloudwater and cloud area associated
!    with deep convective vertical mass flux and detrainment from the
!    mesoscale to the large-scale. 
!---------------------------------------------------------------------
      if (cloud_tracers_present) then
        call don_l_strat_cloud_donner_tend_k   &
             (isize, jsize, nlev_lsm, Param, Col_diag, dmeso_3d,   &
              Don_conv%xliq, Don_conv%xice, qlin, qiin, qain, mhalf_3d, &
              phalf, dql, dqi, dqa, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
      endif

!---------------------------------------------------------------------


end subroutine don_l_lscloud_driver_k



!#####################################################################

subroutine don_l_define_mass_flux_k   &
         (isize, jsize, nlev_lsm, pfull, phalf, Don_conv, dmeso_3d,   &
          mhalf_3d, exit_flag, ermesg, error)

!---------------------------------------------------------------------
!    subroutine define_donner_mass_flux calculates the detrainment rate
!    of the mesoscale to the large-scale and the mass flux associated 
!    with the donner deep convection parameterization.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type

implicit none

!---------------------------------------------------------------------
integer,                                 intent(in)    :: isize, jsize, &
                                                          nlev_lsm
real, dimension(isize,jsize,nlev_lsm),   intent(in)    :: pfull
real, dimension(isize,jsize,nlev_lsm+1), intent(in)    :: phalf
type(donner_conv_type),                  intent(inout) :: Don_conv
real, dimension(isize,jsize,nlev_lsm),   intent(out)   :: dmeso_3d
real, dimension(isize,jsize,nlev_lsm+1), intent(out)   :: mhalf_3d
logical, dimension(isize, jsize),        intent(in)    :: exit_flag
character(len=*),                        intent(out)   :: ermesg
integer,                                 intent(out)   :: error
!----------------------------------------------------------------------
!   intent(in) variables:
!
!     pfull          pressure field on model full levels [ Pa ]
!     phalf          pressure field at half-levels 1:nlev_lsm+1  [ Pa ]
!
!   intent(inout) variables:
!     Don_conv
!
!   intent(out) variables:
!
!     dmeso_3d       detrainment rate from convective system 
!                    [ sec**(-1) ]
!     mhalf_3d       mass flux at model half-levels 
!                    [ kg / (m**2 sec) ]
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:

      real      :: dnna, dnnb    ! weights for averaging full-level 
                                 ! mass fluxes to half levels
                                 ! [ dimensionless ]
      integer   :: i,j,k         ! do-loop indices

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!----------------------------------------------------------------------
!    calculate the detrainment rate from the convective system 
!    (dmeso_3d). dmeso_3d is (1/rho) dM/dz [ sec**(-1) ], where M is 
!    the detraining mass flux of the convective system (kg/(m**2 s)).
!----------------------------------------------------------------------
      do k=1,nlev_lsm
        do j=1,jsize
          do i=1,isize
            if ( .not. exit_flag(i,j) .and. &
                 Don_conv%xice(i,j,k) >= 1.0e-10) then
              dmeso_3d(i,j,k) = Don_conv%emes(i,j,k)/ &
                                Don_conv%xice(i,j,k)
            else
              dmeso_3d(i,j,k) = 0.
            end if
          end do
        end do
      end do

!---------------------------------------------------------------------
!    define the donner parameterization mass flux at model half-levels.
!    include both mesoscale and cell scale fluxes.
!---------------------------------------------------------------------
      do k=1,nlev_lsm-1
        do j=1,jsize
          do i=1,isize
            if (((Don_conv%uceml(i,j,k) <= 1.0e-10)  .and.   &
                (Don_conv%umeml(i,j,k) <= 1.0e-10) .and. &
                (Don_conv%dmeml(i,j,k) <= 1.0e-10)) .or. &
                  exit_flag(i,j)        ) then
              mhalf_3d(i,j,k)   = 0.
              mhalf_3d(i,j,k+1) = 0.
            else
              dnna = phalf(i,j,k+1) - pfull(i,j,k)
              dnnb = pfull(i,j,k+1) - phalf(i,j,k+1)
              mhalf_3d(i,j,k+1) =  &
                                 (dnnb*Don_conv%uceml(i,j,k) + &
                                  dnna*Don_conv%uceml(i,j,k+1) +  &
                                  dnnb*Don_conv%umeml(i,j,k) +   &
                                  dnna*Don_conv%umeml(i,j,k+1) +  &
                                  dnnb*Don_conv%dmeml(i,j,k) +   &
                                  dnna*Don_conv%dmeml(i,j,k+1))/ &
                                  (dnna + dnnb)
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------
!    define the donner parameterization mass fluxes at model top and
!    bottom to be 0.0.
!---------------------------------------------------------------------
      do j=1,jsize
        do i=1,isize
          mhalf_3d(i,j,nlev_lsm+1) = 0.
          mhalf_3d(i,j,1)      = 0.
        end do
      end do


!---------------------------------------------------------------------



end subroutine don_l_define_mass_flux_k 


!######################################################################

subroutine don_l_adjust_tiedtke_inputs_k   &
         (isize, jsize, nlev_lsm, Param, Col_diag, pfull, temp, &
          mixing_ratio, phalf, Don_conv, donner_humidity_factor, &
          donner_humidity_area, exit_flag, ermesg, error) 

!---------------------------------------------------------------------
!    subroutine adjust_tiedtke_inputs calculates the adjustments to 
!    the relative humidity used as a threshold for cloud formation in 
!    the Tiedtke stratiform cloud parameterization (u00), needed as a 
!    consequence of donner_deep_mod being active. see "Tiedtke u00 
!    adjustment" notes, 11/22/02.
!--------------------------------------------------------------------

use donner_types_mod, only : donner_conv_type, donner_param_type, &
                             donner_column_diag_type
use sat_vapor_pres_k_mod, only: lookup_es_k

implicit none

!--------------------------------------------------------------------
integer,                     intent(in)     :: isize, jsize, nlev_lsm
type(donner_param_type),     intent(in)     :: Param
type(donner_column_diag_type),                                      &
                             intent(in)     :: Col_diag
logical, dimension(isize,jsize), intent(in) :: exit_flag   
real, dimension(isize,jsize,nlev_lsm),                              &
                             intent(in)     :: pfull, temp, mixing_ratio
real, dimension(isize,jsize,nlev_lsm+1),                            &
                             intent(in)     :: phalf
type(donner_conv_type),      intent(inout)  :: Don_conv
real, dimension(isize,jsize,nlev_lsm),                               &
                             intent(out)    :: donner_humidity_factor, &
                                               donner_humidity_area
character(len=*),            intent(out)    :: ermesg
integer,                     intent(out)    :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     pfull          pressure field on model full levels [ Pa ]
!     phalf          pressure field on model half levels [ Pa ]
!     temp           temperature field at model full levels [ deg K ]
!     mixing_ratio   water vapor specific humidity at model full 
!                    levels [ kg(h2o) / kg(air) ]
!
!   intent(inout) variables:
!
!     Don_conv
!
!   intent(out) variables:
!
!     donner_humidity_ratio    
!                    ratio of large-scale specific humidity to the
!                    specific humidity in the environment outside
!                    of the convective system [ dimensionless ]
!     donner_humidity_area    
!                    fractional area of cell plus meso circulation
!                    associated with donner_deep_mod [ fraction ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:
 
     real                       :: acell, pzm, rfun
     integer                    :: i, j, k, n

!--------------------------------------------------------------------
!   local variables:
!
!     qrf           vapor specific humidity at model full levels 
!                   [ kg (h2o) /kg(air) ]
!     acell         fractional area of cells in grid box
!                   [ fraction ]
!     pzm           pressure level 200 hPa above top of mesoscale
!                   downdraft [ Pa ]
!     rfun          ratio of specific humidity to saturation specific
!                   humidity assumed in the region between the top of
!                   the mesoscale downdraft and the cloud base
!                   [ fraction ]
!     qsat          saturation specific humidity [ kg(h2o) / kg(air) ]
!     esat          saturation vapor pressure [ Pa ]
!     i,j,k,n       do-loop indices
!---------------------------------------------------------------------

      ermesg = ' ' ; error = 0

      do k=1,nlev_lsm           
        do j=1,jsize
          do i=1,isize

!---------------------------------------------------------------------
!    the output fields are given non-default values only in grid boxes
!    where donner_deep_mod has produced either cell or mesoscale cloud.
!---------------------------------------------------------------------
            if ( .not. exit_flag(i,j) .and. &
                 (Don_conv%cual(i,j,k)  > 0.0 .or. &
                  Don_conv%ampta1(i,j) > 0.0)) then

!-------------------------------------------------------------------
!    define the pressure at the base of the mesoscale updraft (pzm), 
!-------------------------------------------------------------------
              pzm = Don_conv%pzm_v(i,j) 

!--------------------------------------------------------------------
!    define the area of the convective cells in each grid box (acell).
!    if in the region of mesoscale updraft, the cell area is defined as
!    the difference between the total cloud area (Don_conv%cual) and 
!    the mesoscale area (Don_conv%ampta1). above and below this region 
!    it is defined as the total cloud area, since no mesoscale cloud is
!    present. be sure that the cell area is non-negative.
!--------------------------------------------------------------------
              if ((pfull(i,j,k) <= Don_conv%pzm_v(i,j)) .and.   &
                  (pfull(i,j,k) >= Don_conv%pztm_v(i,j))) then
                acell = Don_conv%cual(i,j,k) - Don_conv%ampta1(i,j)
              else
                acell = Don_conv%cual(i,j,k)
              endif
              acell = MAX (acell, 0.0)

!--------------------------------------------------------------------
!    define the fractional area of the grid box where the humidity
!    is affected by the deep convection in the mesoscale updraft region 
!    (donner_humidity_area). it is assumed to be the sum of the cell and
!    meso cloud areas. previously, below cloud base and above the top 
!    of the mesoscale updraft, there was no moisture-enhanced area due 
!    to deep convection.      
!      this is no longer the case after mods during AM2p9 -- in current
!      formulation there may be cell cloud above top of mesoscale
!      updraft (when cloud top exceeds plzb), and in grid box containing
!      cloud base level.
!--------------------------------------------------------------------
              donner_humidity_area(i,j,k) = Don_conv%cual(i,j,k)

!----------------------------------------------------------------------
!     between cloud base and the base of the mesoscale updraft, the
!     humidity in an area the size of the sum of the cell and meso 
!     cloud areas is assumed to be affected by the deep convection.
!----------------------------------------------------------------------
              if ((pfull(i,j,k) >  Don_conv%pzm_v(i,j)) .and.  &
                  (pfull(i,j,k) <= Don_conv%pb_v(i,j)) ) then
                donner_humidity_area(i,j,k) = Don_conv%cual(i,j,k) +   &
                                              Don_conv%ampta1(i,j)
              endif

!---------------------------------------------------------------------
!      limit the fractional area to be less than 1.0.
!---------------------------------------------------------------------
              donner_humidity_area(i,j,k) =     &
                                  MIN (donner_humidity_area(i,j,k), 1.0)

!---------------------------------------------------------------------
!    define the variable rfun, which serves as the ratio of specific
!    humidity to saturation specific humidity assumed to be present in
!    the part of the grid box with a mesoscale circulation. saturation 
!    is assumed in the cell portion and in the region from the top of 
!    the mesoscale downdraft to the top of the mesoscale updraft. from 
!    top of mesoscale downdraft to cloud base, the relative humidity 
!    goes from 100% to 70%, as a function of relative pressure distance
!    between the two end points.  
!---------------------------------------------------------------------
              if ((pfull(i,j,k) >= Don_conv%pztm_v(i,j)) .and. &
                  (pfull(i,j,k) <= Don_conv%pmd_v(i,j))) then
                rfun = 1.
              else if ((pfull(i,j,k) >= Don_conv%pmd_v(i,j)) .and.  &
                       (pfull(i,j,k) <= Don_conv%pb_v(i,j))) then
                rfun = 1. - 0.3*(Don_conv%pmd_v(i,j) - pfull(i,j,k))/ &
                                (Don_conv%pmd_v(i,j) -   &
                                                     Don_conv%pb_v(i,j))
              else if (pfull(i,j,k) < Don_conv%pztm_v(i,j)) then
                rfun = 0.
              else if (pfull(i,j,k) > Don_conv%pztm_v(i,j)) then
                rfun = 0.
              endif

              donner_humidity_factor(i,j,k) = Don_conv%ampta1(i,j)*rfun

!---------------------------------------------------------------------
!    if in diagnostics column, output the profiles of cell and mesoscale
!    cloud area, the pressure, temperature and specific humidity prof-
!    iles,  the saturation specific humidity, the large-scale and 
!    convective environment specific humidities.
!---------------------------------------------------------------------
              if (Col_diag%in_diagnostics_window) then
                do n=1, Col_diag%ncols_in_window
                  if (j == Col_diag%j_dc(n) .and.    &
                      i == Col_diag%i_dc(n)) then
                    if (pfull(i,j,k) .le. Don_conv%pb_v(i,j)) then
                      if (Don_conv%ampta1(i,j) .ne. 0.) then
                        write (Col_diag%unit_dc(n), '(a, i5, 2f20.10)') &
                           'k,cual,ampt= ', &
                            k, Don_conv%cual(i,j,k), Don_conv%ampta1(i,j)
                        write (Col_diag%unit_dc(n), '(a, i5, 4f20.10)') &
                                     'pb,prinp,trf, acell= ',  k, &
                                   Don_conv%pb_v(i,j), pfull(i,j,k),   &
                                    temp(i,j,k),acell
                        write (Col_diag%unit_dc(n), '(a, i5, f20.10)') &
                               'rfun,= ', k,  rfun
                      endif
                    endif
                  endif
                end do
              endif

!---------------------------------------------------------------------
!    if there is no cell or meso cloud in the grid box, set 
!    donner_humidity_ratio to 1.0 and donner_humidity_area to 0.0
!---------------------------------------------------------------------
            else
              donner_humidity_factor(i,j,k) = 0.0
              donner_humidity_area(i,j,k) = 0.0
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------


end subroutine don_l_adjust_tiedtke_inputs_k 



!#######################################################################

 subroutine don_l_strat_cloud_donner_tend_k    &
          (isize, jsize, nlev_lsm, Param, Col_diag, dmeso_3d, qlmeso, &
           qimeso, qlin, qiin, qain, mhalf_3d, phalf, dql, dqi, dqa,  &
           ermesg, error)

!--------------------------------------------------------------------
!    subroutine strat_cloud_donner is part of the linkage between
!    the deep convection parameterization of donner_deep_mod and the 
!    tiedtke/rotstayn cloud fraction/microphysics parameterization of 
!    strat_cloud_mod.
!-----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_column_diag_type

implicit none

!-----------------------------------------------------------------------
integer,                       intent(in)   :: isize, jsize, nlev_lsm
type(donner_param_type),       intent(in)   :: Param
type(donner_column_diag_type), intent(in)   :: Col_diag
real, dimension(isize,jsize,nlev_lsm),          &
                               intent(in)   :: dmeso_3d, qlmeso, qimeso,&
                                               qlin, qiin, qain
real, dimension(isize,jsize,nlev_lsm+1),         &
                               intent(in)   :: mhalf_3d, phalf
real, dimension(isize,jsize,nlev_lsm),           &
                               intent(out)  :: dql, dqi, dqa
character(len=*),              intent(out)  :: ermesg
integer,                       intent(out)  :: error
!---------------------------------------------------------------------
!   intent(in) variables:
!
!     dmeso_3d       mass detrainment rate from mesoscale region to 
!                    large-scale region [ sec**(-1) ]
!     qlmeso         mesoscale cloud liquid specific humidity   
!                    [ (kg (h2o) /kg air) ]
!     qimeso         mesoscale cloud ice specific humidity 
!                    [ (kg (h2o) /kg air) ]
!     mhalf_3d       total donner-related mass flux = 
!                    mesoscale_mass_flux + convective_mass_flux,
!                    on model interface levels [ kg / ((m**2) s) ]
!                    NOTE: mhalf_3d(:,:,1) and mhalf_3d(:,:,kdim+1) are 
!                    assumed to be 0.0 in this subroutine.
!     phalf          pressure at model half-levels [ Pa ]
!     qlin           large-scale cloud liquid specific humidity
!                    [ kg(h2o) / kg(air) ]
!     qiin           large-scale cloud ice specific humidity
!                    [ kg(h2o) / kg(air) ]
!     qain           large-scale cloud fraction [ fraction ]
!
!   intent(out) variables:
!
!     dql            increment to large-scale cloud liquid field from
!                    donner_deep_mod [ kg(h2o) / kg (air) ]
!     dqi            increment to large-scale cloud ice field from
!                    donner_deep_mod [ kg(h2o) / kg (air) ]
!     dqi            increment to large-scale cloud area field from
!                    donner_deep_mod [ fraction ]
!
!----------------------------------------------------------------------

!-----------------------------------------------------------------------
!   local variables:
      real, dimension (isize, jsize,nlev_lsm) ::  mass  
      integer     :: k, n

!---------------------------------------------------------------------
!   local variables:
!
!         mass     mass of air per square meter in the given layer
!                  [ kg / m**2 ]
!         kdim     number of model layers
!         k,n      do-loop indices
!
!---------------------------------------------------------------------

      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    define the number of model layers (kdim) and the mass per unit area
!    contained in each layer (mass).
!---------------------------------------------------------------------
!     kdim = nlev_lsm
      do k=1,nlev_lsm
        mass(:,:,k) = (phalf(:,:,k+1) - phalf(:,:,k))/Param%grav 
      end do

!---------------------------------------------------------------------
!    define the large scale cloud increments at level 1 to be 0.0.
!---------------------------------------------------------------------
      dql (:,:,1) = 0.
      dqi (:,:,1) = 0.
      dqa (:,:,1) = 0.
    
!---------------------------------------------------------------------
!    define the tendencies of cloud liquid, cloud ice and cloud area
!    due to the vertical mass flux associated with donner_deep con-
!    vection.
!---------------------------------------------------------------------
      do k=2,nlev_lsm

!---------------------------------------------------------------------
!    define the tendencies due to flux through the top interface of the
!    layer.
!---------------------------------------------------------------------
        dql(:,:,k) = mhalf_3d(:,:,k)*0.5*(qlin(:,:,k) + qlin(:,:,k-1))/ &
                                                           mass(:,:,k)
        dqi(:,:,k) = mhalf_3d(:,:,k)*0.5*(qiin(:,:,k) + qiin(:,:,k-1))/ &
                                                           mass(:,:,k)
        dqa(:,:,k) = mhalf_3d(:,:,k)*0.5*(qain(:,:,k) + qain(:,:,k-1))/ &
                                                           mass(:,:,k)

!---------------------------------------------------------------------
!    add the tendencies due to flux through the bottom interface of 
!    the layer.
!---------------------------------------------------------------------
        dql(:,:,k-1) = dql(:,:,k-1) - mhalf_3d(:,:,k)*0.5*     &
                            (qlin(:,:,k-1) + qlin(:,:,k))/mass(:,:,k-1)
        dqi(:,:,k-1) = dqi(:,:,k-1) - mhalf_3d(:,:,k)*0.5*      &
                            (qiin(:,:,k-1) + qiin(:,:,k))/mass(:,:,k-1)
        dqa(:,:,k-1) = dqa(:,:,k-1) - mhalf_3d(:,:,k)*0.5*       &
                            (qain(:,:,k-1) + qain(:,:,k))/mass(:,:,k-1)
      end do

!---------------------------------------------------------------------
!    add the effects of detrainment from the mesoscale region.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        dql (:,:,k) = dql (:,:,k) + dmeso_3d(:,:,k)*qlmeso(:,:,k)
        dqi (:,:,k) = dqi (:,:,k) + dmeso_3d(:,:,k)*qimeso(:,:,k)
        where (qlmeso(:,:,k) + qimeso(:,:,k) >= 1.e-10) 
          dqa (:,:,k) = dqa (:,:,k) + dmeso_3d(:,:,k)
        end where
      end do

!--------------------------------------------------------------------
!    if in diagnostics window, output values of the cloud variables and
!    the tendencies due to donner_deep convection.
!--------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          do k=1, nlev_lsm     
            if (dql(Col_diag%i_dc(n),Col_diag%j_dc(n), k) /= 0.0 .or. &
                dqi(Col_diag%i_dc(n),Col_diag%j_dc(n), k) /= 0.0 ) then 
              write (Col_diag%unit_dc(n), '(a, i5, 3f20.10)') &
                  'donner_deep,strat_cloud_donner_tend', k, &
                   qlin(Col_diag%i_dc(n),Col_diag%j_dc(n), k), &
                   qiin(Col_diag%i_dc(n),Col_diag%j_dc(n), k), &
                   qain(Col_diag%i_dc(n),Col_diag%j_dc(n), k)
              write (Col_diag%unit_dc(n), '(a, i5, 3f20.10)') &
                  'donner_deep,strat_cloud_donner_tend', k, &
                   dql(Col_diag%i_dc(n),Col_diag%j_dc(n), k), &
                   dqi(Col_diag%i_dc(n),Col_diag%j_dc(n), k), &
                   dqa(Col_diag%i_dc(n),Col_diag%j_dc(n), k)
            endif
          end do
        end do
      endif 

!-----------------------------------------------------------------------


end subroutine don_l_strat_cloud_donner_tend_k


!###################################################################





!VERSION NUMBER:
!  $Id: donner_meso_k.F90,v 17.0.4.1 2010/03/17 20:27:07 wfc Exp $

!module donner_meso_inter_mod

!#include "donner_meso_interfaces.h"

!end module donner_meso_inter_mod

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

subroutine don_m_meso_effects_k    &
         (me, nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, Param, Nml,&
          pfull_c, temp_c, mixing_ratio_c, phalf_c, rlsm, emsm, etsm, &
          tracers_c, ensembl_cond, ensmbl_precip, pb, plzb_c, pt_ens, &
          ampta1, ensembl_anvil_cond_liq, ensembl_anvil_cond_liq_frz, &
          ensembl_anvil_cond_ice,  wtp, qtmes, meso_frz_intg_sum,  &
          anvil_precip_melt, meso_cloud_area, cmus_tot, dmeml,  &
          emds_liq, emds_ice, emes_liq, emes_ice,  wmms, wmps, &
          umeml, temptr, tmes, tmes_up, tmes_dn, mrmes, mrmes_up, &
          mrmes_dn, emdi, pmd, pztm, pzm, meso_precip, ermesg, error)

!-------------------------------------------------------------------
!    subroutine don_m_meso_effects_k obtains the mesoscale effects
!    of the composited cloud ensemble on the heat, moisture and tracer 
!    budgets, producing tendency terms which are to be applied to the 
!    large-scale model equations. the scheme employed here is a variation
!    on the procedure of Leary and Houze (JAS, 1980). for more details 
!    on notation, see "Cu Closure A notes," 2/97.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type

implicit none

!-------------------------------------------------------------------
integer,                           intent(in)  :: me, nlev_lsm, nlev_hires, &
                                                  ntr, diag_unit
logical,                           intent(in)  :: debug_ijt        
type(donner_param_type),           intent(in)  :: Param
type(donner_nml_type),             intent(in)  :: Nml  
real,   dimension(nlev_lsm),       intent(in)  :: pfull_c, temp_c, &
                                                  mixing_ratio_c
real,   dimension(nlev_lsm+1),     intent(in)  :: phalf_c
real,   dimension(nlev_hires),     intent(in)  :: rlsm, emsm
real,   dimension(nlev_hires,ntr), intent(in)  :: etsm
real,   dimension(nlev_lsm,ntr),   intent(in)  :: tracers_c
logical,                           intent(in)  :: meso_frz_intg_sum
real,                              intent(in)  :: ensembl_cond,   &
                                                  ensmbl_precip, pb, &
                                                  plzb_c, pt_ens,   &
                                                  ampta1, &
                                              ensembl_anvil_cond_liq, &
                                       ensembl_anvil_cond_liq_frz, &
                                                  ensembl_anvil_cond_ice
real,   dimension(nlev_lsm,ntr),   intent(out) :: wtp, qtmes, temptr
real,   dimension(nlev_lsm),       intent(out) :: anvil_precip_melt, &
                                                  meso_cloud_area,    &
                                                  cmus_tot, dmeml, &
                                                  emds_liq, emds_ice, &
                                                        wmms, wmps,   &
                                                  emes_liq, emes_ice, &
                                                  umeml, tmes, mrmes, &
                                                  mrmes_up, mrmes_dn, &
                                                  tmes_up, tmes_dn
real,                              intent(out) :: emdi,           &
                                                  pmd, pztm, pzm, &
                                                  meso_precip
character(len=*),                  intent(out) :: ermesg
integer,                           intent(out) :: error

!----------------------------------------------------------------------
!   intent(in) variables:
!
!       pfull_c      large-scale model pressure full levels [ Pa ]
!       phalf_c      large-scale model pressure half levels [ Pa ]
!       temp_c       large-scale model temperature profile [ deg K ]
!       mixing_ratio_c  
!                    large-scale model mixing ratio profile
!                    [ kg(h2o) / kg(air) ]
!       rlsm         cloud model condensation profile summed over
!                    cloud ensemble
!                    [ kg(h2o) / kg(air) / sec ]
!       emsm         cloud model moisture flux convergence summed over 
!                    the cloud ensemble
!                    [ kg(h2o) / kg(air) / sec ]
!       etsm         cloud model tracer flux convergence summed over
!                    the cloud ensemble 
!                    [ kg(tracer) / kg(air) / sec ]
!       tracers_c    large-scale model tracer mixing ratio profiles
!                    [ kg(tracer) /kg(air) ]
!       ensmbl_cond  total ensemble condensation integral
!                    [ mm / day ]
!       ensmbl_precip   total ensemble precipitation integral
!                    [ mm / day ]
!       ps           surface pressure [ Pa ]
!       pb           cloud-base pressure [ Pa ]
!       plzb_c       level of zero buoyancy [ Pa ]
!       pt_ens       cloud-top pressure [ Pa ]
!       ampta1       fractional area of mesoscale anvil
!                    [ dimensionless ]
!       ensembl_anvil_cond 
!                    condensed water transferred from cells to anvil 
!                    [ mm / day ]
!       debug_ijt    is this a diagnostics column ?
!       diag_unit    output unit number for this diagnostics column
!
!  output variables:
! 
!       meso_cloud_area 
!               fractional mesoscale area, normalized by
!               a(1,p_b) at resolution of GCM
!       meso_precip
!       cmu     water mass condensed in mesoscale updraft
!               (g/kg/day) (normalized by a(1,p_b))
!       cmui    vertical integral of mesoscale-updraft deposition
!               (kg(H2O)/((m**2)*sec) 
!       dmeml   mass flux in mesoscale downdraft (kg/((m**2) s))
!               (normalized by a(1,p_b)) (index 1 at atmosphere bottom)
!               (resolution of GCM)
!       emds    water mass evaporated in mesoscale
!               downdraft (g/kg/day) (normalized by a(1,p_b))
!       emdi    vertical integral of mesoscale-downdraft sublimation
!               (mm/d)
!       emes    water mass evaporated from mesoscale
!               updraft (g/kg/day) (normalized by a(1,p_b))
!       emei    vertical integral of mesoscale-updraft sublimation
!               (kg(h2O)/((m**2)*sec)
!       pmd     pressure at top of mesoscale downdraft (Pa)
!       pztm    pressure at top of mesoscale updraft (Pa)
!       wmms    water vapor removal by condensation of
!               cell vapor source (g/kg/day) (normalized by a(1,p_b))
!       wmps    water vapor redistributed from cell vapor source
!               (g/kg/day) (normalized by a(1,p_b))
!       wtp     tracer redistributed by mesoscale processes
!               (kg/kg/s) (normalized by a(1,p_b))
!       anvil_precip_melt     melting of ice in mesoscale updraft-
!               equivalent (g/kg/day)-which falls as meso sfc precip
!               (normalized by a(1,p_b))
!       tmes    temperature tendency due to mesoscale entropy-flux-
!               convergence (K/day) (normalized by a(1,p_b))
!       mrmes    moisture tendency due to mesoscale moisture-flux
!               convergence (g/kg/day) (normalized by a(1,p_b))
!       qtmes   tracer tendency due to mesoscale tracer-flux
!               convergence (kg/kg/s) (normalized by a(1,p_b))
!       umeml   mass flux in mesoscale updraft (kg/((m**2) s))
!               (normalized by a(1,p_b)) (index 1 at atmosphere bottom)
!               (resolution of GCM)
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (nlev_lsm)     ::  cmu
      real, dimension (nlev_lsm)     ::  out
      real, dimension (nlev_hires)   ::  p_hires
      real                           ::  alp, hfmin, cmui, qtmesum, dp,&
                                         available_condensate, &
                                         available_condensate_liq, &
                                         available_condensate_ice
      real                           ::  emdi_liq, emdi_ice
      integer                        ::  k, kcont, itrop
      real  :: intgl_lo, intgl_hi
      real          :: p2, ptrop

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      dp = Param%dp_of_cloud_model

!--------------------------------------------------------------------
!    define the pressure at the melting level (p2).
!--------------------------------------------------------------------
      p2 = -10.
      do k=1,nlev_lsm-1
        if ((temp_c(k) >= Param%kelvin) .and.   &
             (temp_c(k+1) <= Param%kelvin))  then
          p2 = phalf_c(k+1)
          exit
        end if
      end do

!---------------------------------------------------------------------
!    if in diagnostics column, output message indicating that sub-
!    routine meso_effects has been entered.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a)') 'in meens: entering meens'
      endif

!--------------------------------------------------------------------
!    define the pressure at the top of the mesoscale updraft (pztm) to 
!    be the pressure at the zero buyancy level, unless the cloud top is
!    above 100 hPa, in which case pztm is set to be one level above the 
!    level of zero buoyancy.  previously pztm was restricted to be  >=
!    100 hPa, cf Ackerman et al (JAS,1988), unless pt_ens <= 10kPa. 
!    result was that stratospheric water vapor was transported too high 
!    in AM2p9 with this pztm, so the constraint was changed to pztm >= 
!    plzb_c + dp
!--------------------------------------------------------------------
      if ((pt_ens + dp) >= 10.e03)  then
        pztm = plzb_c
      else
        pztm = plzb_c + dp
      endif

      if (Nml%limit_pztm_to_tropo) then
        call find_tropopause (nlev_lsm, temp_c, pfull_c, ptrop, itrop)
        pztm = MAX (pztm, ptrop)
      endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the pressure at top of meso-
!    scale circulation (pztm) and the precipitation efficiency 
!    (ensmbl_precip/ensembl_cond).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a,  e20.12)') 'in meens: pztm = ',pztm 
        write (diag_unit, '(a, e20.12)') 'in meens: gnu= ',   &
                                             ensmbl_precip/ensembl_cond
      endif

!---------------------------------------------------------------------
!    define the pressure at the vertical grid levels of the cloud model
!    grid.
!---------------------------------------------------------------------
      do k=1,nlev_hires        
        p_hires(k) = pb + (k-1)*dp
      end do

!---------------------------------------------------------------------
!    call subroutine meso_updraft to define the needed output fields 
!    associated with the mesoscale updraft.
!---------------------------------------------------------------------
      call don_m_meso_updraft_k   &
           (nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, Param, &
            p_hires, rlsm, emsm, etsm, pfull_c,  &
             temp_c, mixing_ratio_c, phalf_c, tracers_c,  &
              pb, pt_ens, ampta1, dp, pztm,  wtp, &
                  qtmes, cmu, wmms, wmps, temptr, tmes_up, mrmes_up,   &
                  meso_cloud_area, umeml,&
                  alp, pzm, hfmin, cmui, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (Nml%frc_internal_enthalpy_conserv) then
!-----------------------------------------------------------------------
!    call don_u_set_column_integral_k to adjust the tmes_up
!    profile below cloud base so that the desired integral value is
!    obtained.
!-----------------------------------------------------------------------
         call don_u_set_column_integral_k    &
              (nlev_lsm, tmes_up   , pb, &
               phalf_c(1), 0.0, phalf_c , intgl_hi,     &
               intgl_lo, out, ermesg, error)

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals and 
!    profiles, both before and after the adjustment to the desired value        .
!---------------------------------------------------------------------
        if (debug_ijt) then
           write (diag_unit, '(a, e20.12)')  &
                   'in set_col_integral: tmes_up column(in)= ',intgl_hi
           write (diag_unit, '(a, e20.12)')  &
                   'in set_col_integral: tmes_up column(out)= ',intgl_lo
           do k=1,nlev_lsm
            if (tmes_up(k)       /= out(k)) then
               write (diag_unit, '(a, i4, 2e20.12)') &
               'in set_col_integral: k,tmesup(in), tmesup(out)= ', k,  &
                     tmes_up(k)      , out(k)
            endif
          end do
        endif
 
!---------------------------------------------------------------------
!    define the adjusted output profile by removing conservation_factor.
!---------------------------------------------------------------------
       tmes_up(:) = out(:)       
    endif

!---------------------------------------------------------------------
!    call subroutine meso_downdraft to define the needed output fields 
!    associated with the mesoscale downdraft.
!---------------------------------------------------------------------
      call don_m_meso_downdraft_k  &
           (nlev_lsm, nlev_hires, diag_unit, debug_ijt, Param, Nml,  &
            p_hires, pfull_c, temp_c, mixing_ratio_c, phalf_c, pb, &
            ampta1, dp, pztm, pzm, alp, hfmin, pmd, tmes_dn,  &
            mrmes_dn, dmeml, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (Nml%frc_internal_enthalpy_conserv) then
!-----------------------------------------------------------------------
!    call don_u_set_column_integral_k to adjust the tmes_dn
!    profile below cloud base so that the desired integral value is
!    obtained.
!-----------------------------------------------------------------------
         call don_u_set_column_integral_k    &
              (nlev_lsm, tmes_dn   , pb, &
               phalf_c(1), 0.0, phalf_c , intgl_hi,     &
               intgl_lo, out, ermesg, error)

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the integrals and 
!    profiles, both before and after the adjustment to the desired value        .
!---------------------------------------------------------------------
        if (debug_ijt) then
           write (diag_unit, '(a, e20.12)')  &
                    'in set_col_integral: tmes_dn column(in)= ',intgl_hi
           write (diag_unit, '(a, e20.12)')  &
                  'in set_col_integral: tmes_dn column(out)= ',intgl_lo
           do k=1,nlev_lsm
            if (tmes_dn(k) /= out(k)) then
               write (diag_unit, '(a, i4, 2e20.12)') &
               'in set_col_integral: k,tmesdn(in), tmesdn(out)= ', k,  &
                     tmes_dn(k)      , out(k)
            endif
          end do
        endif
 
!---------------------------------------------------------------------
!    define the adjusted output profile by removing conservation_factor.
!---------------------------------------------------------------------
       tmes_dn(:) = out(:)       
     endif

!---------------------------------------------------------------------
!    combine the heating and moistening effects from the updraft and
!    downdraft to obtain the total mesoscale effect on the large-scale
!    model temperature and water vapor mixing ratio(?) equations.
!---------------------------------------------------------------------
      tmes = (tmes_up + tmes_dn)*86400.
      tmes_up = tmes_up*86400.
      tmes_dn = tmes_dn*86400.
      mrmes = (mrmes_up + mrmes_dn)*8.64e07
      mrmes_up = mrmes_up*8.64e07
      mrmes_dn = mrmes_dn*8.64e07

!---------------------------------------------------------------------
!    if in a diagnostics column, output the entropy (tmes) and
!    mixing ratio (mrmes) tendencies due to the mesoscale
!    updraft and downdraft.
!---------------------------------------------------------------------
      do k=1,nlev_lsm              
        if (debug_ijt) then
          if (tmes(k) /= 0.0) then
            write (diag_unit, '(a, i4, f19.10, f20.14, 2e20.12)')   &
                    'in meens: jk,pr,tmes,tmes_u, tmes_d,= ', &
                     k, pfull_c(k), tmes(k)/86400., tmes_up(k)/86400., &
                     tmes_dn(k)/86400.
            write (diag_unit, '(a, i4, f19.10, f20.14, 3e20.12)')   &
                    'in meens: jk,pr,mrmes,mrmes_u, mrmes_d= ', &
                     k, pfull_c(k), mrmes(k)/8.64e07,  &
                      mrmes_up(k)/8.64e07, mrmes_dn(k)/8.64e07
          endif
        endif
      end do

!---------------------------------------------------------------------
!    define the column anvil precip (meso_precip) as the precipitation
!    efficiency times the available condensate in the anvil, which is 
!    made up of the deposition in the updraft (cmui) and the condensate
!    transferred from the cells to the anvil (ensembl_anvil_cond). 
!---------------------------------------------------------------------
      available_condensate = cmui + ensembl_anvil_cond_liq + &
                                ensembl_anvil_cond_liq_frz + &
                             ensembl_anvil_cond_ice
! precip from _liq takes hlv with it; precip from _ice takes hls
! with it
      if ( p2 == -10. .or. p2 > pb .or. p2 < pt_ens) then
        if ( .not. meso_frz_intg_sum ) then
!   this implies no melting of precip; cmui and _liq don't freeze.
         available_condensate_liq =  cmui + ensembl_anvil_cond_liq 
         available_condensate_ice =         &
                                ensembl_anvil_cond_liq_frz + &
                             ensembl_anvil_cond_ice
        else
         available_condensate_liq =  0.0                           
         available_condensate_ice =    cmui + ensembl_anvil_cond_liq + & 
                                ensembl_anvil_cond_liq_frz + &
                             ensembl_anvil_cond_ice
        endif
      else
!    all condensate will melt before leaving
      available_condensate_ice = 0.0                               
      available_condensate_liq = cmui + ensembl_anvil_cond_liq + &
                                ensembl_anvil_cond_liq_frz + &
                             ensembl_anvil_cond_ice
      endif

      meso_precip = Param%anvil_precip_efficiency*available_condensate

!---------------------------------------------------------------------
!    if in a diagnostics column, output the total mesoscale-supplied
!    condensate (condensation plus deposition), the cell provided 
!    condensate (ensembl_anvil_cond),  the mesoscale precipitation 
!    (meso_precip) and the cell-scale precipitation (ensmbl_precip).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 4e20.12)')  &
                     'in meens: cmui,ca (liq,frxliq,ice)=', cmui, &
                 ensembl_anvil_cond_liq, ensembl_anvil_cond_liq_frz,  &
                             ensembl_anvil_cond_ice
        write (diag_unit, '(a, e20.12, a, e20.12)')  &
                     'in meens: rm= ',meso_precip,  'rc= ',ensmbl_precip
      endif

!----------------------------------------------------------------------
!    call subroutine meso_evap to define the amount of condensate that
!    is evaporated in the mesoscale updraft (emes) and mesoscale 
!    downdraft (emds).
!----------------------------------------------------------------------
      call don_m_meso_evap_k  &
           (nlev_lsm, diag_unit, debug_ijt, Param,  &
            available_condensate, available_condensate_liq,  &
            available_condensate_ice, pzm, pztm, phalf_c, emdi_liq, &
            emdi_ice, emds_liq, emds_ice, emes_liq, emes_ice, ermesg, error)
 
      emdi = emdi_liq + emdi_ice

!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!---------------------------------------------------------------------
!    call subroutine meso_melt to distribute the melting of precipitat-
!    ing anvil ice within the column (anvil_precip_melt).
!---------------------------------------------------------------------
      call don_m_meso_melt_k   &
           (nlev_lsm, diag_unit, debug_ijt, Param, temp_c, phalf_c, &
            pztm, meso_precip, pb, anvil_precip_melt, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    define cmus_tot   as the profile of total condensate source to the
!    large-scale flow from the mesoscale circulation; the sum of the
!    water mass condensed in the mesoscale updraft plus the vapor
!    transferred from cell to mesoscale and then condensed.
!--------------------------------------------------------------------
      do k=1,nlev_lsm            
        cmus_tot(k) = cmu(k) - wmms(k)
      end do

!---------------------------------------------------------------------
!    if in a diagnostics column, output the profiles of tracer tranfer-
!    red from cells to mesoscale circulation (wtp), mesoscale tracer-
!    flux convergence (qtmes), and cell-scale tracer flux convergence 
!    (qtren). also output the  column integral of the mesoscale 
!    tracer-flux convergence (qtmesum).
!---------------------------------------------------------------------
      if (debug_ijt) then
        qtmesum = 0.
        do k=1,nlev_lsm             
          do kcont=1,ntr           
            write (diag_unit, '(a, 2i4, f19.10, e20.12)')  &
                      'in mulsub: jk, pr,wtp= ',k, kcont,  &
                          pfull_c(k), wtp(k,kcont)
            write (diag_unit, '(a, 2i4, f19.10, e20.12)')  &
                     'in mulsub: jk, pr,qtmes= ', k, kcont,         &
                            pfull_c(k),  qtmes(k,kcont)
            qtmesum = qtmesum + qtmes(k,kcont)*  &
                      (phalf_c(k) - phalf_c(k+1))
            write (diag_unit, '(a, i4, e20.12)')  &
                        'in mulsub: jk,qtmesum= ', k, qtmesum
          end do
        end do
      endif

!--------------------------------------------------------------------


end subroutine don_m_meso_effects_k 


!#######################################################################

subroutine don_m_meso_updraft_k    &
         (nlev_lsm, nlev_hires, ntr, diag_unit, debug_ijt, Param,  &
          p_hires, rlsm, emsm, etsm, pfull_c, temp_c, mixing_ratio_c, &
          phalf_c, tracers_c, pb, pt_ens, ampta1, dp, pztm, wtp, &
          qtmes, cmu, wmms, wmps, temptr, tmes_up, mrmes_up,  &
          meso_cloud_area, umeml, alp, pzm, hfmin, cmui, ermesg, error)

!-------------------------------------------------------------------
!    subroutine meens computes the mesoscale effects of the composited
!    cloud ensemble on the heat, moisture and tracer budgets, producing
!    tendency terms which are to be applied to the large-scale model.
!    scheme employed here is a variation on procedure of Leary and 
!    Houze (JAS, 1980). for more details on notation, see 
!    "Cu Closure A notes," 2/97.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_param_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!-------------------------------------------------------------------
integer,                         intent(in)  :: nlev_lsm, nlev_hires, ntr
integer,                         intent(in)  :: diag_unit
logical,                         intent(in)  :: debug_ijt
type(donner_param_type),         intent(in)  :: Param
real,   dimension(nlev_hires),   intent(in)  :: p_hires, rlsm, emsm
real,   dimension(nlev_hires,ntr),                          &
                                 intent(in)  :: etsm
real,   dimension(nlev_lsm),     intent(in)  :: pfull_c, temp_c,    &
                                                mixing_ratio_c
real,   dimension(nlev_lsm+1),   intent(in)  :: phalf_c
real,   dimension(nlev_lsm,ntr), intent(in)  :: tracers_c
real,                            intent(in)  :: pb, pt_ens, ampta1,   &
                                                dp, pztm
real,   dimension(nlev_lsm,ntr), intent(out) :: wtp, qtmes, temptr
real,   dimension(nlev_lsm),     intent(out) :: cmu, wmms, wmps, &
                                                tmes_up, mrmes_up, &
                                                meso_cloud_area, umeml
real,                            intent(out) :: alp, pzm, hfmin, cmui
character(len=128),              intent(out) :: ermesg
integer,                         intent(out) :: error

!---------------------------------------------------------------------
!   local variables:



      real, dimension (nlev_hires)       :: wmhr, cumh
      real, dimension (nlev_lsm)         :: omv, tempq, owm, tempqa
      real, dimension(nlev_lsm,ntr)      :: otm
      real, dimension(nlev_hires, ntr)   :: wthr
      real, dimension(ntr)               :: q1t


      real      ::  cmfhr, pc1, pc2, omer, pctm, q1, q4, mrsat, &
                    q3, anv, qref, pp, pm, qprip, qprim, eqfp, eqfm, &
                    qmu, hflux, pfmin, owms, wpc, wmc, ta, te, tep, tmu,&
                    qtprip, qtprim, eqtfp, eqtfm, rintsum, rintsum2
      logical   :: do_donner_tracer
      integer   :: ncc, ncztm
      integer   :: kcont, kk
      integer   :: jk, i, jsave, jkm, jkp, k, nbad

!-----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

      if (ntr > 0) then
        do_donner_tracer = .true.
      else
        do_donner_tracer = .false.
      endif

      do i=1,nlev_hires
        if (p_hires(i) < pt_ens) then
          ncc = i
          exit
        endif
      end do
      do i=1,nlev_hires
        if (p_hires(i) < pztm) then
          ncztm = i + 1
          exit
        endif
      end do

      do kcont=1,ntr
        wtp(:,kcont) = 0.
        qtmes(:,kcont) = 0.
        temptr(:,kcont) = tracers_c(:,kcont)
      end do
      tmes_up(:) = 0.
      mrmes_up(:) = 0.
      cmu = 0.
      wmms = 0.
      wmps = 0.
      tempq(:) = mixing_ratio_c(:)
      tempqa(:) = mixing_ratio_c(:)

!----------------------------------------------------------------------
!    initialize the pressure at the base of the mesoscale circulation
!    (pzm).
!----------------------------------------------------------------------
      pzm = 0.

!----------------------------------------------------------------------
!    define the vertical profile of the rate at which water vapor is
!    made available to the mesoscale circulation by the convective 
!    updrafts on the cloud model grid (wmhr). if vapor is being made 
!    available, determine if there is also a vertical flux convergence 
!    of tracer; if so, define the rate at which tracer is being made
!    available to the mesoscale circulation (wthr). define the pressure
!    at the base of the mesoscale circulation (pzm) as the pressure at 
!    the lowest cloud model level where the convective updrafts are 
!    supplying condensate to the mesoscale circulation.
!----------------------------------------------------------------------
      do k=1,nlev_hires
        cmfhr = -rlsm(k) + emsm(k)
        if (cmfhr > 0.) then
          wmhr(k) = -cmfhr
          if (do_donner_tracer) then
            do kcont=1,ntr
              if (etsm(k,kcont) > 0.) then
                wthr(k,kcont) = -etsm(k,kcont)
              else
                wthr(k,kcont) = 0.0               
              endif
            end do
          else
            wthr(k,:) = 0.0               
          endif
          if (pzm == 0.) then
            pzm = p_hires(k)
          endif
        else
          wmhr(k) = 0.0   
          wthr(k,:) = 0.0               
        endif
      end do

!---------------------------------------------------------------------
!    if in diagnostics column, output the profiles of condensation rate
!    (rlsm), water vapor flux convergence (emsm) and water vapor 
!    supplied to the mesoscale (wmhr) on the cloud model grid.
!---------------------------------------------------------------------
      do k=1,nlev_hires
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                     'in meens: i,rlhr,emfhr= ',k,rlsm(k),emsm(k)
          write (diag_unit, '(a, i4, e20.12)')  &
                      'in meens: i,wmhr= ',k,wmhr(k)
        endif
      end do

      if (debug_ijt) then
        write (diag_unit, '(a, i4, e20.12)')  &
                        'in meens: ncc+1, pt', ncc+1, pt_ens
        do k=1,ncc+1
          write (diag_unit, '(a, i4, e20.12)')  &
                         'in meens: k,p_hi= ', k, p_hires(k)
        end do
        do k=1,nlev_lsm+1         
          write (diag_unit, '(a, i4, e20.12)')  &
                      'in meens: k,p_lo= ', k, phalf_c(k)
        end do
      endif

!---------------------------------------------------------------------
!    convert the vertical profile of vapor made available to the meso-
!    scale from the updraft to the large-scale model grid (output var-
!    iable is owm). if tracers are being transported by donner conv-
!    ection, convert the vertical profile of tracer made available to 
!    the mesoscale from the updraft to the large-scale model grid 
!    (output variable is otm). 
!---------------------------------------------------------------------
      call don_u_map_hires_c_to_lores_c_k &
           (nlev_lsm, nlev_hires, wmhr, p_hires, pt_ens + dp, phalf_c,&
            owm, rintsum, rintsum2, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
            'in meens: rintsum(owm) =', rintsum, rintsum2
        call don_u_compare_integrals_k  &
             (rintsum, rintsum2, diag_unit, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
      endif

      if (do_donner_tracer) then
        do kcont=1,ntr
          call don_u_map_hires_c_to_lores_c_k  &
               (nlev_lsm, nlev_hires, wthr (:,kcont), p_hires,  &
                pt_ens + dp, phalf_c, otm(:,kcont), rintsum,   &
                rintsum2, ermesg, error) 
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt) then
            write (diag_unit, '(a, 2e20.12)')  &
                 'in meens: rintsum(otm) =', rintsum, rintsum2
            call don_u_compare_integrals_k  &
                 (rintsum, rintsum2, diag_unit, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (error /= 0 ) return
          endif
        end do
      endif

!----------------------------------------------------------------------
!    adjust the value for pressure at base of mesocscale circulation,
!    if necessary.
!----------------------------------------------------------------------
      if (pzm == 0.) pzm = pt_ens
      if (pzm <= pztm - dp) pzm = pztm - dp

!---------------------------------------------------------------------
!    if in diagnostics column, output the pressure at the base of the
!    mesoscale circulation (pzm), and the vertical profile of vapor 
!    supplied to the mesoscale by the updraft on the large-scale model
!    grid (owm).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, f19.10)') 'in meens: pzm= ',pzm
        do k=1,nlev_lsm
          write (diag_unit, '(a, i4, e20.12)')  &
                                 'in meens: jk,owm= ',k,owm(k)
        end do
      endif

!---------------------------------------------------------------------
!    march up the column, determining the redistribution of the cumulus-
!    updraft-supplied vapor by the mesoscale updraft.
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!---------------------------------------------------------------------
!    if there is  vapor being supplied to the mesoscale by the cumulus
!    updraft at this level, determine the pressure depth over which the
!    mesoscale updraft will distribute that vapor over the lifetime of
!    the mesoscale circulation.
!---------------------------------------------------------------------
        if (owm(k) < 0.) then     

!---------------------------------------------------------------------
!    define the bottom (pc1) and top (pc2) of the current layer. deter-
!    mine the pressure level to which air in this layer will reach when
!    moving at the appropriate mesoscale updraft velocity for the dur-
!    ation of the mesoscale circulation (pctm). this level is limited to
!    be no higher than the top of the mesoscale circulation; if it is 
!    calculated to be higher, redefine the mesoscale updraft velocity 
!    for this layer so that the air in this layer will reach only to
!    the mesoscale circulation top, and no higher.
!---------------------------------------------------------------------
          pc1 = phalf_c(k)
          pc2 = phalf_c(k+1)
          pctm = pc2 + Param%meso_ref_omega*Param%meso_lifetime
          if (pctm <= pztm) then
            omer = (pztm - pc2)/Param%meso_lifetime
            pctm = pc2 + omer*Param%meso_lifetime
          else
            omer = Param%meso_ref_omega
          endif
 
!---------------------------------------------------------------------
!    define the amount of water vapor from this layer (owm(k)* 
!    (pc2 - pc1)*MESO_LIFETIME) which is to be distributed
!    uniformly between pc1 and pctm (q1).
!--------------------------------------------------------------------  
          q1 = owm(k)*(pc2 - pc1)*Param%meso_lifetime/(pc1 - pctm)
          q4 = 0.5*q1

!---------------------------------------------------------------------
!    define the amount of tracer from this layer (otm(k,kcont)* 
!    (pc2 - pc1)*meso_Lifetime) which is to be distributed
!    uniformly between pc1 and pctm (q1t).
!--------------------------------------------------------------------  
          if (do_donner_tracer) then
            do kcont=1,ntr
              q1t(kcont) = otm(k,kcont)*(pc2 - pc1)*Param%meso_lifetime/&
                           (pc1 - pctm)                     
            end do
          endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the topmost pressure reached by
!    the mesoscale updraft from this layer (pctm), the top of the meso-
!    scale circulation (pztm) and the amount of water vapor supplied to
!    each layer between the current vertical level and the top of the 
!    mesoscale updraft originating here (q4).
!---------------------------------------------------------------------
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12)')  &
                         'in meens: pctm,pztm,q4= ', pctm, pztm, q4
          endif

!---------------------------------------------------------------------
!    distribute the vapor supplied in the current layer to all layers
!    between the current location and the top of the mesoscale updraft.
!---------------------------------------------------------------------
          do kk=k,nlev_lsm

!--------------------------------------------------------------------
!    exit the loop when above the top of the mesoscale updraft. if still
!    within the mesoscale updraft originating from level k, add the 
!    contribution of water vapor being supplied to the mesoscale circ-
!    ulation at this level (kk) from the current source level (k), 
!    normalized by the anvil fractional area, to the arrays accumulating
!    these moisture sources (tempq, tempqa). these arrays will be used 
!    in the calculation of deposition in the mesoscale updraft.
!--------------------------------------------------------------------
            if (phalf_c(kk) < pctm) exit
            tempq(kk) = tempq(kk) + (q1/ampta1)
            tempqa(kk) = tempqa(kk) + (q4/ampta1)

!--------------------------------------------------------------------
!    add the rate of moisture input to the current layer kk from 
!    the current source layer k to the accumulation array (wmps). if the
!    current model layer extends beyond the top of the mesoscale 
!    updraft, pro-rate the contribution by the ratio of pressure depths.
!--------------------------------------------------------------------
            if (phalf_c(kk+1) <= pctm)  then
              wmps(kk) = wmps(kk) + (q1/Param%meso_lifetime)*  &
                        (phalf_c(kk) - pctm)/  &
                                            (phalf_c(kk) - phalf_c(kk+1))
            else
              wmps(kk) = wmps(kk) + q1/Param%meso_lifetime
            endif

!--------------------------------------------------------------------
!    add the contribution of tracer being supplied to the mesoscale 
!    circulation at this level (kk) from the current source level (k), 
!    normalized by the anvil fractional area, to the array accumulating
!    this tracer source (temptr). this array will be used in the 
!    calculation of tracer deposition in the mesoscale updraft.
!    add the rate of tracer input to the current layer kk from 
!    the current source layer k to the accumulation array (wtp). if the
!    current model layer extends beyond the top of the mesoscale 
!    updraft, pro-rate the contribution by the ratio of pressure depths.
!--------------------------------------------------------------------
            if (do_donner_tracer) then
              do kcont=1,ntr
                temptr(kk,kcont) = temptr(kk,kcont) + (q1t(kcont)/  &
                                   (2.* ampta1))
                if (phalf_c(kk+1) <= pctm) then
                  wtp(kk,kcont) = wtp(kk,kcont) +   &
                                  (q1t(kcont)/Param%meso_lifetime)*  &
                                  (phalf_c(kk)-pctm)/   &
                                              (phalf_c(kk)-phalf_c(kk+1))
                else
                  wtp(kk,kcont) = wtp(kk,kcont) +   &
                                  (q1t(kcont)/Param%meso_lifetime)
                endif
              end do
            endif
          end do

!--------------------------------------------------------------------
!    if in diagnostics column, output the moisture and tracer sources
!    to the mesoscale from the convective scale.
!--------------------------------------------------------------------
          if (debug_ijt) then
            do kk=k,nlev_lsm
              if (phalf_c(kk) < pctm) exit        
              write (diag_unit, '(a, i4, f19.10)') &
                            'in meens: jj,pr= ',kk,pfull_c(kk)
              write (diag_unit, '(a, i4, 3e20.12)')  &
                  'in meens: jj,q1,tempq,wmm= ',kk,q1,tempq(kk),wmms(kk)
              write (diag_unit, '(a, e20.12)')  &
                   'in meens: wmp= ',wmps(kk)
              write (diag_unit, '(a, i4, e20.12)')  &
                   'in meens: jj,tempqa= ',kk,tempqa(kk)
            end do
            write (diag_unit, '(a, i4, 3e20.12)')  &
                  'in meens: jk,q1,tempq,wmm= ',k,q1,tempq(k),wmms(k)
            write (diag_unit, '(a, i4, 2e20.12)')  &
                   'in meens: jk,wmp,owm= ',k,wmps(k),owm(k)
          endif
        endif ! (owm(k) < 0.)

!----------------------------------------------------------------------
!    if in diagnostics column, output the profile of moisture made
!    available to the mesoscale circulation by the cumulus updraft (owm)
!    and the amount deposited in each level (wmps).
!----------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
                        'in meens: jk,wmp,owm= ',k,wmps(k),owm(k)
        endif

!----------------------------------------------------------------------
!    add the  source level value to the array accumulating the  profile
!    of total updraft source at each level (wmps). the if loop prevents
!    the inclusion of moisture which is available but above the top of 
!    the mesoscale updraft (the level of zero bupoyancy usually).  wmps
!    will only be non-zero at layers within the mesoscale updraft, 
!    but owm may be non-zero in layers above the updraft.
!--------------------------------------------------------------------
        if (wmps(k) /= 0.0) then
          wmps(k) = wmps(k) + owm(k)
          if (do_donner_tracer) then
            wtp(k,:) = wtp(k,:) + otm(k,:)
          endif
        endif
      end do   ! (end of k loop)

!--------------------------------------------------------------------
!    convert various moisture rates from kg(h2o) / kg(air) / sec to
!    g(h2o) / kg(air) / day.
!--------------------------------------------------------------------
      owm(:)  = owm(:)*8.64e07

!---------------------------------------------------------------------
!     calculate the portion of redistributed water vapor that condenses.
!     cycle until lowest level within the region of mesoscale circ-
!     ulation is reached. exit the loop when have marched past top of 
!     the mesoscale circulation.
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        if (phalf_c(k+1) > pzm) cycle
        if (phalf_c(k) < pztm) exit

!---------------------------------------------------------------------
!    determine if the current level is within the region of the meso-
!    scale circulation (between pzm and pztm).
!---------------------------------------------------------------------
        if ((phalf_c(k+1) <= pzm) .and. (phalf_c(k) >= pztm)) then

!---------------------------------------------------------------------
!    if so, define the top (pc2) of the current layer. deter-
!    mine the pressure level to which air in this layer will reach when
!    moving at the appropriate mesoscale updraft velocity for the dur-
!    ation of the mesoscale circulation (pctm). this level is limited to
!    be no higher than the top of the mesoscale circulation; if it is 
!    calculated to be higher, redefine the mesoscale updraft velocity 
!    for this layer so that the air in this layer will reach only to
!    the mesoscale circulation top, and no higher.
!---------------------------------------------------------------------
          pc2 = phalf_c(k+1)
          pctm = pc2 +Param%meso_ref_omega*Param%meso_lifetime
          if (pctm <= pztm)  then
            omer = (pztm - pc2)/Param%meso_lifetime
          else
            omer = Param%meso_ref_omega
          endif
          pctm = pc2 + omer*Param%meso_lifetime

!---------------------------------------------------------------------
!    define the temperature of the mesoscale updraft at this level.
!    determine its saturation vapor pressure and saturation mixing  
!    ratio. define saturation deficit
!    or excess relative to tempq(k), which is the mixing ratio in the 
!    mesoscale region (environmental mixing ratio plus source from 
!    cumulus updrafts). if there is a moisture excess (and thus conden-
!    sation must occur), define the condensation rate in the mesoscale
!    region, normalized over the mesoscale lifetime and its areal cover-
!    age. if only a portion of the layer is within the mesoscale updraft
!    region, adjust the mesoscale condensation rate appropriately.
!    if tempqa is greater than the saturation specific humidity (ERROR-
!    should be mixing ratio), reset it to the saturation value.
!---------------------------------------------------------------------
          ta = temp_c(k) + Param%tprime_meso_updrft
          call compute_mrs_k (ta, pfull_c(k), Param%d622 , Param%d608 ,&
                              mrsat, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_updraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          q3 = mrsat - tempq(k)
          if (q3 <= 0.) then
            if (phalf_c(k+1) <= pctm)  then
              wmms(k) = (q3*ampta1/Param%meso_lifetime)*    &
                       (phalf_c(k) - pctm)/(phalf_c(k) - phalf_c(k+1))
            else
              wmms(k) = q3*ampta1/Param%meso_lifetime
            endif
          endif
          tempqa(k) = MIN (tempqa(k), mrsat)
        endif
      end do

!---------------------------------------------------------------------
!    determine the large-scale model full level at which parcel contain-
!    ing the water vapor at the base of the mesoscale updraft will reach
!    saturation and begin to condense (jsave).
!---------------------------------------------------------------------
      anv = 0.
      do k=1,nlev_lsm

!---------------------------------------------------------------------
!    determine the water vapor mixing ratio at the base of the mesoscale
!    updraft (qref).
!---------------------------------------------------------------------
        if (pfull_c(k) > pzm) cycle       
        if (anv == 0.) qref = tempqa(k)
        anv = 1.
        if (pfull_c(k) < pztm) exit        

!---------------------------------------------------------------------
!    define the temperature of the mesoscale updraft at this level.
!    determine its saturation vapor pressure and saturation specific
!    humidity. NOTE: should be mixing RATIO. define the level at which
!    mesoscale updraft condensation begins as the current level, in 
!    case the loop will be exited.
!---------------------------------------------------------------------
        te = temp_c(k) + Param%tprime_meso_updrft
        call compute_mrs_k (te, pfull_c(k), Param%d622 , Param%d608 , &
                            mrsat, nbad, mr = qref)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_updraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

        jsave = k

!---------------------------------------------------------------------
!    if in diagnostics column, output the values of saturation mixing  
!    ratio (mrsat) and mixing ratio in the mesoscale region (tempqa).
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 2e20.12)')  &
                          'in meens: qs,tempqa= ',mrsat,tempqa(k)
        endif

!---------------------------------------------------------------------
!    if there is a saturation excess at this level then exit, saving the
!    level index as jsave. this is the level at which condensation  in
!    the mesoscale updraft will begin.
!---------------------------------------------------------------------
        if (qref >= mrsat) exit      
      end do

!---------------------------------------------------------------------
!    define the  ???????
!!    What is the 6 ?? how is it related to the 8 below in the omd
!!    definition ???
!---------------------------------------------------------------------
      alp = 6.*Param%meso_ref_omega/((pzm - pztm)**2)

      omv = 0.

!---------------------------------------------------------------------
!    define the forcing terms associated with mesoscale updrafts.
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!-------------------------------------------------------------------
!    if the current level is below the base of the mesoscale updraft,
!    cycle. if the current level is above the top of the mesoscale 
!    updraft, exit the loop.
!-------------------------------------------------------------------
        if (pfull_c(k) .gt. pzm) cycle       
        if (pfull_c(k) .lt. pztm) exit

!--------------------------------------------------------------------
!    define the limits of the current layer, modified from the large-
!    scale model levels when the mesoscale updraft region starts or ends
!    within the layer.
!--------------------------------------------------------------------
        pp = phalf_c(k+1)
        pm = phalf_c(k)
        if (phalf_c(k+1) < pztm) pp = pztm
        if (phalf_c(k) > pzm) pm = pzm

!---------------------------------------------------------------------
!    calculate mesoscale vertical velocity profile.
!---------------------------------------------------------------------
        omv(k) = (pzm + pztm)*((pp**2) - (pm**2))/2.
        omv(k) =  omv(k) - (((pp**3) - (pm**3))/3.)
        omv(k) = omv(k) - pztm*pzm*(pp - pm)
        omv(k) = omv(k)/(phalf_c(k+1) - phalf_c(k))
        omv(k) = omv(k)*alp

!---------------------------------------------------------------------
!    calculate mesoscale entropy-flux convergence. analytic integration
!    used, possible only because mesoscale temperature perturbation is 
!    not function of pressure. see "Vertical Velocity in Mesoscale 
!    Cloud" notes, 11/12/91.
!---------------------------------------------------------------------
        tmes_up(k) = (pzm + pztm)*(Param%rdgas - Param%cp_air)*  &
                     (pp - pm)/Param%cp_air
        tmes_up(k) = tmes_up(k) + ((2.*Param%cp_air - Param%rdgas)*  &
                     ((pp**2) - (pm**2))/(2.*Param%cp_air))
        tmes_up(k) = tmes_up(k) - (Param%rdgas*pztm*pzm/Param%cp_air)* &
                     alog(pp/pm)
        tmes_up(k) = tmes_up(k)/(phalf_c(k+1) - phalf_c(k))
        tmes_up(k) = tmes_up(k)*ampta1*Param%tprime_meso_updrft*alp

!--------------------------------------------------------------------
!    if currently below the level at which condensation in the meso-
!    scale updraft begins, cycle until that level is reached.
!--------------------------------------------------------------------
        if (k < jsave) cycle      

!--------------------------------------------------------------------
!    if into the region where deposition occurs, define the appropriate
!    above and below indices for boundary levels.
!--------------------------------------------------------------------
        if (k == 1) then
          jkm = k
        else
          jkm = k - 1
        endif
        if (k == nlev_lsm) then
          jkp = k
        else
          jkp = k + 1
        endif

!--------------------------------------------------------------------
!    define the temperature of the mesoscale updraft (te). define the
!    associated saturation vapor pressure and specific humidity (ERROR 
!    !!!).
!--------------------------------------------------------------------
        te = temp_c(k) + Param%tprime_meso_updrft
        call compute_mrs_k (te, pfull_c(k), Param%d622 , Param%d608 ,&
                              tempqa(k), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_updraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

!--------------------------------------------------------------------
!    if an excess of vapor is present and deposition should occur, 
!    define the mesoscale updraft temperature at the next higher level 
!    (tep). 
!--------------------------------------------------------------------
        if (qref >= tempqa(k)) then
          tep = temp_c(jkp) + Param%tprime_meso_updrft

!--------------------------------------------------------------------
!    if the next higher level is no longer in the mesoscale updraft 
!    layer, define the deposition rate in the mesoscale updraft at 
!    level k as the vapor flux divergence between layer k-1 and layer k.
!--------------------------------------------------------------------
          if (pfull_c(jkp) <= pztm) then
            cmu(k) = -omv(k)*(tempqa(k) - tempqa(jkm))/ &
                     (pfull_c(k) - pfull_c(jkm))

!--------------------------------------------------------------------
!     if level k is the lowest level within the condensation region,
!     determine the saturation specific humidity (ERROR !!!) at the
!     next higher level. define the deposition rate in the mesoscale  
!     updraft at level k as the vapor flux divergence between level k 
!     and level k+1. redefine qref as the amount of vapor remaining
!     in the parcel at the jkp level.
!--------------------------------------------------------------------
          else if (k == jsave) then
            call compute_mrs_k (tep, pfull_c(jkp), Param%d622 , &
                                Param%d608 , tempqa(jkp), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (nbad /= 0) then
              ermesg = 'subroutine don_m_meso_updraft_k: '// &
                       'temperatures out of range of esat table'
              error = 1
              return
            endif

            cmu(k) = -omv(k)*(tempqa(jkp) - tempqa(k))/  &
                     (pfull_c(jkp) - pfull_c(k))
            qref = tempqa(jkp)

!--------------------------------------------------------------------
!     if level k is within the condensation region, determine the  
!     saturation specific humidity (ERROR !!!) at the next higher level.
!     define the deposition rate in the mesoscale updraft at level k as
!     the vapor flux divergence between level k-1 and level k+1. 
!     redefine qref as the amount of vapor remaining in the parcel at 
!     the jkp level.
!--------------------------------------------------------------------
          else
            call compute_mrs_k (tep, pfull_c(jkp), Param%d622 , &
                                Param%d608 , tempqa(jkp), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
            if (nbad /= 0) then
              ermesg = 'subroutine don_m_meso_updraft_k: '// &
                       'temperatures out of range of esat table'
              error = 1
              return
            endif

            cmu(k) = -omv(k)*(tempqa(jkp) - tempqa(jkm))/ &
                     (pfull_c(jkp) - pfull_c(jkm))
            qref = tempqa(jkp)
          endif

!---------------------------------------------------------------------
!    make certain that the deposition rate is non-negative.
!---------------------------------------------------------------------
          if (cmu(k) < 0.) cmu(k) = 0.

!---------------------------------------------------------------------
!    if there is insufficient moisture for deposition, set the depo-
!    sition rate to 0.0.
!---------------------------------------------------------------------
        else
          cmu(k) = 0.
        endif

!---------------------------------------------------------------------
!    convert the deposition rate to g(h2o) / kg(air) / day. multiply
!    by the anvil area (ampta1) to obtain a grid-box-mean value of the
!    deposition rate.
!---------------------------------------------------------------------
        cmu(k) = cmu(k)*ampta1*8.64e07

!--------------------------------------------------------------------
!    if in diagnostics column, output the environmental temperature
!    (temp_c) and the mesoscale vertical velocity (omv).
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, f20.14, e20.12)') &
                      'in meens: jk,t,omv= ', k, temp_c(k), omv(k)
        endif
      end do

!---------------------------------------------------------------------
!    calculate the mesoscale moisture-flux and tracer-flux convergence.
!---------------------------------------------------------------------
      do k=1,nlev_lsm 

!---------------------------------------------------------------------
!    if the current level is above the mesoscale updraft, exit the loop.
!    if the next level is still below the base of the mesoscale updraft,
!    cycle to the end of the loop.
!---------------------------------------------------------------------
        if (phalf_c(k) .lt. pztm) exit       
        if (phalf_c(k+1) .gt. pzm) cycle      

!--------------------------------------------------------------------
!    define the appropriate above and below indices for boundary levels.
!--------------------------------------------------------------------
        if (k == 1) then
          jkm = k
        else
          jkm = k - 1
        endif
        if (k == nlev_lsm) then
          jkp = k
        else
          jkp = k + 1
        endif

!---------------------------------------------------------------------
!    define the difference between the environmental vapor mixing ratio 
!    and that in the mesoscale updraft at the two half-levels bracketing
!    the current level.
!---------------------------------------------------------------------
        qprip = (tempqa(jkp) + tempqa(k) -    &
                             mixing_ratio_c(jkp) - mixing_ratio_c(k))/2.
        qprim = (tempqa(k) + tempqa(jkm) -    &
                             mixing_ratio_c(k) - mixing_ratio_c(jkm))/2.

!---------------------------------------------------------------------
!    define the difference between the environmental tracer mixing 
!    ratios and those in the mesoscale updraft at the two half-levels 
!    bracketing the current level.
!---------------------------------------------------------------------
        if (do_donner_tracer) then
          do kcont=1,ntr
            qtprip = (temptr(jkp,kcont) + temptr(k,kcont) - &
                      tracers_c(jkp,kcont) - tracers_c(k,kcont))/2.
            qtprim = (temptr(k,kcont) + temptr(jkm,kcont) -  &
                      tracers_c(k,kcont) - tracers_c(jkm,kcont))/2.
            eqtfp = ampta1*qtprip*alp*(phalf_c(k+1) - pztm)*  &
                    (pzm - phalf_c(k+1))
            eqtfm = ampta1*qtprim*alp*(phalf_c(k) - pztm)*  &
                    (pzm - phalf_c(k))
            if ((phalf_c(k) <= pzm) .and. (phalf_c(k+1) >= pztm)) then
              qtmes(k,kcont) = (eqtfm - eqtfp)/   &
                                              (phalf_c(k+1) - phalf_c(k))
            endif
            if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
              qtmes(k,kcont) = eqtfp/(phalf_c(k) - phalf_c(k+1))
            endif
            if ((pztm >= phalf_c(k+1)) .and. (pztm <= phalf_c(k))) then
              qtmes(k,kcont) = eqtfm/(phalf_c(k+1) - phalf_c(k))
              if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
                qtmes(k,kcont) = 0.
              endif
            endif ! ((pztm >= phalf_c(k+1)) .and. (pztm <= phalf_c(k)))
          end do
        endif

!-------------------------------------------------------------------
!    define the
!-------------------------------------------------------------------
        eqfp = ampta1*qprip*alp*(phalf_c(k+1) - pztm)*   &
                                                    (pzm - phalf_c(k+1))
        eqfm = ampta1*qprim*alp*(phalf_c(k) - pztm)*(pzm - phalf_c(k))
        if ((phalf_c(k) <= pzm) .and. (phalf_c(k+1) >= pztm)) then
          mrmes_up(k) = (eqfm - eqfp)/(phalf_c(k+1) - phalf_c(k))
        endif
        if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
          mrmes_up(k) = eqfp/(phalf_c(k) - phalf_c(k+1))
        endif
        if ((pztm >= phalf_c(k+1)) .and. (pztm <= phalf_c(k))) then
          mrmes_up(k) = eqfm/(phalf_c(k+1) - phalf_c(k))
          if ((pzm <= phalf_c(k)) .and. (pzm >= phalf_c(k+1))) then
            mrmes_up(k) = 0.
          endif
        endif ! ((pztm .ge. phalf_c(k+1)) .and. (pztm .le. phalf_c(k)))

!---------------------------------------------------------------------
!    if in diagnostics column,  output the entropy     (tmes) and
!    specific humidity (?)(mrmes) tendencies due to the mesoscale
!    updraft.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)')   &
                  'in meens: jk,pr,tmes,qmes= ', k, pfull_c(k),  &
                   tmes_up(k), mrmes_up(k)
        endif
      end do

!---------------------------------------------------------------------
!    calculate the eddy flux of moist static energy in mesoscale
!    updraft (hflux) and identify its minimum (hfmin).
!---------------------------------------------------------------------
      hfmin = 0.
      do jk=1,nlev_lsm
!---------------------------------------------------------------------
!    if the current level is above the mesoscale updraft, exit the loop.
!    if the next level is still below the base of the mesoscale updraft,
!    cycle to the end of the loop.
!---------------------------------------------------------------------
        if (pfull_c(jk) .lt. pztm) exit      
        if (pfull_c(jk) .gt. pzm) cycle      

!--------------------------------------------------------------------
!    define the temperature of the mesoscale updraft (tmu). define the
!    associated saturation vapor pressure and specific humidity (ERROR 
!    !!!).
!--------------------------------------------------------------------
        tmu = temp_c(jk) + Param%TPRIME_MESO_UPDRFT
        call compute_mrs_k (tmu, pfull_c(jk), Param%d622 , &
                                Param%d608 , qmu, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_updraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

!---------------------------------------------------------------------
!    define the eddy flux of moist static energy in the mesoscale 
!    updraft (hflux). retain the minimum value in the profile (hfmin)
!    and its pressure level (pfmin).
!---------------------------------------------------------------------
        hflux = omv(jk)*(((Param%cp_air*Param%tprime_meso_updrft ) + &
                                 Param%hlv*(qmu - mixing_ratio_c(jk))))
        if (hflux < hfmin) then
          hfmin = hflux      
          pfmin = pfull_c(jk)
        endif
      end do

!---------------------------------------------------------------------
!    if in a diagnostics column, output the minimum of the eddy moist 
!    static energy flux and its level.
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                        'in meens: hfmin,pfmin= ', hfmin, pfmin
      endif

!---------------------------------------------------------------------
!    define the mesoscale fractional area (cumh) in the region of the 
!    mesoscale updraft. 
!---------------------------------------------------------------------
      do k=1,nlev_hires
        if ((p_hires(k) <= pzm) .and. (p_hires(k) >= pztm))  then
          cumh(k) = ampta1
        else
          cumh(k) = 0.0 
        endif
      end do

!---------------------------------------------------------------------
!    call map_hi_res_col_to_lo_res_col to map the mesoscale anvil area 
!    from the cloud model to the large-scale 
!    model.
!---------------------------------------------------------------------
      call don_u_map_hires_c_to_lores_c_k  &
           (nlev_lsm, nlev_hires, cumh, p_hires, pztm + dp, phalf_c, &
            meso_cloud_area, rintsum, rintsum2, ermesg, error) 
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
            'in meens: rintsum(cuml) =', rintsum, rintsum2
        call don_u_compare_integrals_k   &
             (rintsum, rintsum2, diag_unit, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return
      endif

!---------------------------------------------------------------------
!    define the upward mass flux associated with the mesoscale 
!    circulation. 
!---------------------------------------------------------------------
      do k=1,nlev_lsm
        umeml(k) = -omv(k)*ampta1/Param%grav  
        wmms(k)  = wmms(k)*8.64e07
        wmps(k)  = wmps(k)*8.64e07
      end do

!---------------------------------------------------------------------
!    obtain column integrals of deposition rate in the mesoscale (cmui),
!    convective updraft condensation (wmc), cell to mesoscale moisture
!    transfer (wpc), and the moisture made available to the mesoscale
!    by the cumulus updraft (owms). convert to units of mm / day.
!---------------------------------------------------------------------
      cmui = 0.
      wmc  = 0.
      wpc  = 0.
      owms = 0.
      do k=1,nlev_lsm
        wmc  = wmc  + wmms(k)*(phalf_c(k) - phalf_c(k+1))
        owms = owms + owm(k)*(phalf_c(k) - phalf_c(k+1))
        wpc  = wpc  + wmps(k)*(phalf_c(k) - phalf_c(k+1))
        cmui = cmui + cmu(k)*(phalf_c(k) - phalf_c(k+1))
      end do
      wmc  = wmc/(Param%grav*1000.)
      wpc  = wpc/(Param%grav*1000.)
      owms = owms/(Param%grav*1000.)
      cmui = cmui/(Param%grav*1000.)

!---------------------------------------------------------------------
!    if in diagnostics column, output the column-integral moisture 
!    conversion rates (wmc, wpc, owms, cmui). 
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12,a,a,e20.12,a)')  &
               'in meens: wmc=', wmc, ' mm/day', ' wpc=', wpc, 'mm/day'
        write (diag_unit, '(a, e20.12, a, a, e20.12, a)')  &
               'in meens: owms= ', owms, ' mm/day', ' cmui= ',   &
                        cmui, 'mm/day'
      endif

!---------------------------------------------------------------------
!    calculate precipitation resulting from the mesoscale circulation.
!    define the total additional condensate supplied to the column
!    by the mesoscale circulation, the sum of the deposition (wmc) and
!    additional condensation (cmui). 
!---------------------------------------------------------------------
      cmui = cmui - wmc

!--------------------------------------------------------------------


end subroutine don_m_meso_updraft_k



!#####################################################################

subroutine don_m_meso_downdraft_k    &
         (nlev_lsm, nlev_hires, diag_unit, debug_ijt, Param, Nml, &
          p_hires, pfull_c, temp_c, mixing_ratio_c, phalf_c, pb, &
          ampta1, dp, pztm, pzm, alp, hfmin, pmd, tmes_dn, mrmes_dn, &
          dmeml, ermesg, error)

!-------------------------------------------------------------------
!    subroutine meens computes the mesoscale effects of the composited
!    cloud ensemble on the heat, moisture and tracer budgets, producing
!    tendency terms which are to be applied to the large-scale model.
!    scheme employed here is a variation on procedure of Leary and 
!    Houze (JAS, 1980). for more details on notation, see 
!    "Cu Closure A notes," 2/97.
!-------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type
use sat_vapor_pres_k_mod, only: compute_mrs_k

implicit none

!-------------------------------------------------------------------
integer,                       intent(in)   :: nlev_lsm, nlev_hires, &
                                               diag_unit
logical,                       intent(in)   :: debug_ijt        
type(donner_param_type),       intent(in)   :: Param
type(donner_nml_type),         intent(in)   :: Nml  
real,   dimension(nlev_hires), intent(in)   :: p_hires
real,   dimension(nlev_lsm),   intent(in)   :: pfull_c, temp_c,  &
                                               mixing_ratio_c
real,   dimension(nlev_lsm+1), intent(in)   :: phalf_c
real,                          intent(in)   :: pb, ampta1, dp, pztm, &
                                               pzm, alp, hfmin 
real,                          intent(out)  :: pmd
real,   dimension(nlev_lsm),   intent(out)  :: tmes_dn, mrmes_dn, dmeml
character(len=*),              intent(out)  :: ermesg
integer,                       intent(out)  :: error

!---------------------------------------------------------------------
!   local variables:

      real, dimension(nlev_hires)     :: dmemh
      real, dimension(nlev_lsm)       :: tempt, tempqa
      real, dimension(nlev_lsm+1)     :: emt, emq

!     real :: qlo
      real    ::  es, mrsat, c2, c3, c1, fjk, fjkm, qb, fjkb, qbm, qmd, &
                  qsmd, fjkmd, qmmd, pi, psa, targ, tprimd, tb, qten, tten, &
                  omd, mrsb, wa, wb, tmd, rin, rintsum, rintsum2
      integer :: ncmd
      integer :: jksave, k, nbad

!----------------------------------------------------------------------

      ermesg = ' ' ; error = 0

      tmes_dn = 0.
      mrmes_dn = 0.
      tempt(:) = temp_c(:)
      emt(:) = 0.
      emq(:) = 0.
      tempqa(:) = mixing_ratio_c(:)

!---------------------------------------------------------------------
!    define the top of the mesoscale downdraft (pmd). it is assumed to 
!    be meso_sep Pa below the base of the mesoscale updraft. (no meso-
!    scale motion is assumed between the base of the mesoscale updraft 
!    and the top of the mesoscale downdraft.) make certain it is not 
!    below the surface.
!---------------------------------------------------------------------
      pmd = MIN(pzm + Param%meso_sep, phalf_c(1))
      ncmd = 1
      do k=1,nlev_hires         
        if (p_hires(k) < pmd ) then
          ncmd = k + 1
          exit
        endif
      end do

!---------------------------------------------------------------------
!    calculate mesoscale downdraft speed (omd) at top of mesoscale 
!    downdraft (pmd). follow Leary and Houze (1980,JAS) and set 
!    magnitude to half that in mesoscale updraft; this vertical pressure
!    velocity assumed constant with ht between pzm and cloud base (pb). 
!---------------------------------------------------------------------
      omd = -alp*((pzm-pztm)**2)/8.
      omd = omd/2.

!--------------------------------------------------------------------
!    calculate temperature and specific humidity in mesoscale
!    downdraft. 
!---------------------------------------------------------------------
      do k=1,nlev_lsm

!---------------------------------------------------------------------
!    if the current level is above the top of the mesoscale downdraft, 
!    exit the loop. if the level is below cloud base, cycle to the end
!    of the loop.
!---------------------------------------------------------------------
        if (pfull_c(k) < pmd) exit      
        if (pfull_c(k) > pb) cycle      

!---------------------------------------------------------------------
!    calculate c2, the relative humidity in the mesoscale downdraft,
!    after Table 3 of Leary and Houze (1980, JAS).
!---------------------------------------------------------------------
        c2 = 1. - (.3*(pfull_c(k) - pmd)/(pb - pmd))

!---------------------------------------------------------------------
!    calculate c3, the factor which yields the eddy flux of moist
!    static energy when multiplied by the minimum of moist static
!    energy in the mesoscale updraft. Multiply by 1.3 to take account
!    of convective downdrafts. See Fig. 7 of Leary and Houze
!    (1980,JAS).
!---------------------------------------------------------------------
        c3 = (pfull_c(k) - pmd)/(pb - pmd)
        c3 = 1.3*c3

!---------------------------------------------------------------------
!    see "Moist Static Energy A, 1/26/91" notes.
!---------------------------------------------------------------------
        targ = temp_c(k)
        call compute_mrs_k (targ, pfull_c(k), Param%d622 , &
                                Param%d608 , mrsat, nbad, esat=es)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

        c1 = Param%d622*Param%hlv*es/   &
                                 (pfull_c(k)*Param%rvgas*(temp_c(k)**2))
        tprimd = c3*hfmin/omd
        tprimd = tprimd - Param%hlv*(c2*mrsat - mixing_ratio_c(k))
        tprimd = tprimd/(Param%cp_air + Param%hlv*c1*c2)
        tempt(k) = temp_c(k) + tprimd
        targ = tempt(k)
        call compute_mrs_k (targ, pfull_c(k), Param%d622 , &
                                Param%d608 , tempqa(k), nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (nbad /= 0) then
          ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                   'temperatures out of range of esat table'
          error = 1
          return
        endif

        tempqa(k) = c2*tempqa(k)

!---------------------------------------------------------------------
!    if in diagnostics column, output 
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, 4e20.12)')  &
                    'in meens: tprimd,tempqa,q,qs= ',tprimd,   &
                    tempqa(k), mixing_ratio_c(k), mrsat
          write (diag_unit, '(a, f19.10, 2e20.12)')  &
                    'in meens: pr,rh,factr= ', pfull_c(k), c2, c3
        endif
      end do

!---------------------------------------------------------------------
!    calculate eddy fluxes of potential temperature and specific
!    humidity in mesoscale downdraft.
!---------------------------------------------------------------------
      do k=2,nlev_lsm-1

!---------------------------------------------------------------------
!    if the current level is above the top of the mesoscale downdraft, 
!    exit the loop. if the level is below cloud base, cycle to the end
!    of the loop.
!---------------------------------------------------------------------
        if (phalf_c(k) .lt. pmd) exit
        if (phalf_c(k) .gt. pb) cycle        

!---------------------------------------------------------------------
!    calculate potential temperature and specific humidity (?) fluxes
!    for pressure levels between cloud base and top of mesoscale down-
!    draft.
!---------------------------------------------------------------------
        if ((pfull_c(k-1) <= pb) .and. (pfull_c(k) >= pmd)) then
          fjk = ampta1*omd*((Param%ref_press/pfull_c(k))**     &
                   (Param%rdgas/Param%cp_air))*(tempt(k) - temp_c(k))    
          fjkm = ampta1*omd*((Param%ref_press/pfull_c(k-1))**  &
                   (Param%rdgas/Param%cp_air))*(tempt(k-1) - temp_c(k-1))
          emt(k) = (fjk + fjkm)/2.
          fjk = ampta1*omd*(tempqa(k) - mixing_ratio_c(k))
          fjkm = ampta1*omd*(tempqa(k-1) - mixing_ratio_c(k-1))
          emq(k) = (fjk + fjkm)/2.
        endif

!---------------------------------------------------------------------
!    calculate potential temperature and specific humidity (?) fluxes
!    for pressure levels below cloud base.
!---------------------------------------------------------------------
        if (pfull_c(k-1) >= pb) then
          fjk = ampta1*omd*((Param%ref_press/pfull_c(k))**   &
                 (Param%rdgas/Param%cp_air))*(tempt(k) - temp_c(k))
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, mixing_ratio_c, pfull_c, pb, qb, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt   ) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                           'in polat: k,p,x=', k, pb, qb
          endif
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, temp_c, pfull_c, pb, tb, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt   ) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                      'in polat: k,p,x=', k, pb, tb
          endif
        call compute_mrs_k (tb, pb, Param%d622 , &
                                Param%d608 , mrsb, nbad, esat=es)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          tprimd = hfmin/omd
          tprimd = tprimd - Param%hlv*(.7*mrsb - qb)
          c1 = Param%D622  *Param%hlv*es/(pb*Param%rvgas*(tb**2))
          tprimd = tprimd/(Param%cp_air + .7*Param%hlv*c1)
          fjkb = ampta1*omd*((Param%ref_press/pb)**      &
                                    (Param%rdgas/Param%cp_air))*tprimd
          wa = (phalf_c(k) - pfull_c(k))/(pb - pfull_c(k))
          wb = (pb - phalf_c(k))/(pb - pfull_c(k))
          emt(k) = wa*fjkb + wb*fjk
          fjk = ampta1*omd*(tempqa(k) - mixing_ratio_C(k))
          targ = tb + tprimd
          call compute_mrs_k (targ, pb, Param%d622 , &
                                Param%d608 , qbm, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          qbm = .7*qbm   
          fjkb = ampta1*omd*(qbm - qb)
          emq(k) = wa*fjkb + wb*fjk
        endif

!---------------------------------------------------------------------
!    calculate potential temperature and specific humidity (?) fluxes
!    for pressure levels at or above the top of the mesoscale downdraft.
!---------------------------------------------------------------------
        if (pfull_c(k) <= pmd) then
          fjkm = ampta1*omd*((Param%ref_press/pfull_c(k-1))**    &
                 (Param%rdgas/Param%cp_air))*(tempt(k-1) - temp_c(k-1))
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, mixing_ratio_c, pfull_c, pmd, qmd, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                      'in polat: k,p,x=', k, pmd, qmd
          endif
          call don_u_lo1d_to_hi0d_linear_k  &
               (nlev_lsm, temp_c, pfull_c, pmd, tmd, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (error /= 0 ) return

          if (debug_ijt   ) then
            write (diag_unit, '(a, i4, f19.10, f20.14)')  &
                      'in polat: k,p,x=', k, pmd, tmd
          endif
          call compute_mrs_k (tmd, pmd, Param%d622 , &
                                Param%d608 , qsmd, nbad, esat=es)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          c1 = Param%d622*Param%hlv*es/(pmd*Param%rvgas*(tmd**2))
          tprimd = -Param%hlv*(qsmd - qmd)/(Param%cp_air + Param%hlv*c1)
          fjkmd = ampta1*omd*((Param%ref_press/pmd)**   &
                                     (Param%rdgas/Param%cp_air))*tprimd
          wa = (pfull_c(k-1) - phalf_c(k))/(pfull_c(k-1) - pmd)
          wb = (phalf_c(k) - pmd)/(pfull_c(k-1) - pmd)
          emt(k) = fjkmd*wa + fjkm*wb
          targ = tmd + tprimd
          call compute_mrs_k (targ, pmd, Param%d622 , &
                                Param%d608 , qmmd, nbad)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
          if (nbad /= 0) then
            ermesg = 'subroutine don_m_meso_downdraft_k: '// &
                     'temperatures out of range of esat table'
            error = 1
            return
          endif

          fjkm = ampta1*omd*(tempqa(k-1) - mixing_ratio_c(k-1))
          fjkmd = ampta1*omd*(qmmd - qmd)
          emq(k) = fjkmd*wa + fjkm*wb
        endif

!---------------------------------------------------------------------
!    if in diagnostics column, output the potential temprature and
!    specific humidity fluxes associated with the mesoscale downdrafts.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 3e20.12)')  &
                        'in meens: jk,phr,emt,emq= ', k ,phalf_c(k),   &
                         emt(k), emq(k)
        endif

!---------------------------------------------------------------------
!    convert the potential temperature flux to a temperature flux.
!---------------------------------------------------------------------
! RSH : unneeded, causes error
!       emt(k) = ((Param%ref_press/pfull_c(k))**     &
!                                    (Param%rdgas/Param%cp_air))*emt(k)
      end do  ! (end of k loop)

!---------------------------------------------------------------------
!    calculate temperature and specific humidity tendencies due
!    to eddy-flux convergences in mesoscale downdraft.
!---------------------------------------------------------------------
      rin = 0.
      do k=nlev_lsm,1, -1

!---------------------------------------------------------------------
!    define the index of the base of the mesoscale updraft (jksave).
!---------------------------------------------------------------------
        if ((phalf_c(k+1) <= pzm) .and. (phalf_c(k) >= pzm))   &
                                                         jksave = k + 1
        pi = (Param%ref_press/pfull_c(k))**(Param%rdgas/Param%cp_air)
        if ((emt(k+1) /= 0.) .and. (emt(k) == 0.) .and.    &
            (rin == 0.)) then
          tten = -emt(k+1)/(phalf_c(k+1) - phalf_c(1))
          qten = -emq(k+1)/(phalf_c(k+1) - phalf_c(1))
          rin = 1.
        endif
        if (rin == 1.) then
          
          if (.not. Nml%frc_internal_enthalpy_conserv) then
            tmes_dn(k) = tmes_dn(k) + (tten/pi)
          endif
          mrmes_dn(k) = mrmes_dn(k) + qten
        endif
        if ((rin == 0.) .and. (emt(k+1) /= 0.) .and.   &
            (emt(k) /= 0.)) then
          tten = (emt(k+1) - emt(k))/(phalf_c(k+1) - phalf_c(k))
          tten = -tten/pi
          qten = (emq(k+1) - emq(k))/(phalf_c(k+1) - phalf_c(k))
          qten = -qten
          tmes_dn(k) = tmes_dn(k) + tten
          mrmes_dn(k) = mrmes_dn(k) + qten
        endif

!---------------------------------------------------------------------
!    if in diagnostics column,  output the entropy     (tmes) and
!    specific humidity (?)(mrmes) tendencies due to the mesoscale
!    downdraft.
!---------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, f19.10, f20.14, e20.12)')   &
                    'in meens: jk,pr,tmes,qmes= ', k, pfull_c(k),  &
                     tmes_dn(k), mrmes_dn(k)
        endif
      end do

!---------------------------------------------------------------------
!    define the temperature (tten)and moisture (qten) tendencies result-
!    ing from the mesoscale downdraft that are to be applied to the 
!    layers between the top of mesoscale downdraft (where emt is 
!    non-zero, saved as psa), and the base of the mesoscale updraft 
!    given by phalf_c(jksave).
!---------------------------------------------------------------------
      psa = 0.
      do k=1,nlev_lsm
        if ((emt(k) /= 0.) .and. (emt(k+1) == 0.)) then
          tten = emt(k)/(phalf_c(jksave) - phalf_c(k))
          qten = emq(k)/(phalf_c(jksave) - phalf_c(k))
          psa = phalf_c(k)
        endif
      end do

!---------------------------------------------------------------------
!    if in diagnostcs column, output the pressures at the top of the
!    mesoscale downdraft (pmd) and at cloud base (pb).
!---------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2f19.10)')  &
                                 'in meens: pmd,pb= ', pmd, pb
      endif

!--------------------------------------------------------------------
!    apply these tendencies to the levels between top of mesoscale
!    downdraft and base of mesoscale updraft.
!--------------------------------------------------------------------
      do k=1,nlev_lsm
        if ((pfull_c(k) <= psa) .and.    &
            (pfull_c(k) >= phalf_c(jksave))) then

!---------------------------------------------------------------------
!    if in diagnostcs column, output the pressure bounds of this region
!    (psa, phalf_c(jksave), the tendencies applied (qten, tten), and the 
!    large-scale model entropy     and moisture tendencies 
!    (mrmes, tmes) prior to the addition of these terms. 
!---------------------------------------------------------------------
          if (debug_ijt) then
            write (diag_unit, '(a, 3e20.12)')  &
                   'in meens: po,psa,phr(jksave)= ',  &
                           Param%REF_PRESS, psa, phalf_c(jksave)
            write (diag_unit, '(a, i4, 2e20.12)')  &
                       'in meens: jk,qmes,qten= ', k, mrmes_dn(k), qten
            write (diag_unit, '(a, i4, 2e20.12)')  &
                           'in meens: jk,tmes,tten= ', k, tmes_dn(k), tten
          endif

!---------------------------------------------------------------------
!    update the moisture and entropy tendencies.
!---------------------------------------------------------------------
          mrmes_dn(k) = mrmes_dn(k) + qten
!!! ISN't emt (and therefore tten) already temperature tendency rather 
!   than theta, and so the conversion here is unnecessary ??
          pi=(Param%ref_press/pfull_c(k))**(Param%rdgas/Param%cp_air)
          tmes_dn(k) = tmes_dn(k) + (tten/pi)
        endif
      end do

!---------------------------------------------------------------------
!    define the mass flux of the mesoscale down-
!    draft (dmemh) in the region of the mesoscale downdraft.
!---------------------------------------------------------------------
      do k=1,nlev_hires
        if ((p_hires(k) <= pb) .and. (p_hires(k) >= pmd))  then
          dmemh(k) = -omd*ampta1/Param%grav  
        else
          dmemh(k) = 0.
        endif
      end do

!---------------------------------------------------------------------
!    call map_hi_res_col_to_lo_res_col to map the 
!    mesoscale downdraft flux from the cloud model to the large-scale 
!    model.
!---------------------------------------------------------------------
      call don_u_map_hires_c_to_lores_c_k  &
           (nlev_lsm, nlev_hires, dmemh, p_hires, pmd + dp, phalf_c, &
            dmeml, rintsum, rintsum2, ermesg, error) 
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
            'in meens: rintsum(dmeml) =', rintsum , rintsum2
        call don_u_compare_integrals_k  &
             (rintsum, rintsum2, diag_unit, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return
      endif

!---------------------------------------------------------------------


end subroutine don_m_meso_downdraft_k



!####################################################################

subroutine don_m_meso_evap_k    &
         (nlev_lsm, diag_unit, debug_ijt, Param, available_condensate,&
          available_condensate_liq, available_condensate_ice, &
          pzm, pztm, phalf_c, emdi_liq, emdi_ice,      &
          emds_liq, emds_ice, emes_liq, emes_ice, ermesg, error)

!---------------------------------------------------------------------
!    subroutine meso_evap calculates the sublimation associated with
!    the mesoscale circulation and partitions both the updraft- and
!    downdraft-induced sublimation within the column.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none

!---------------------------------------------------------------------
integer,                     intent(in)  :: nlev_lsm
integer ,                    intent(in)  :: diag_unit
logical ,                    intent(in)  :: debug_ijt 
type(donner_param_type),     intent(in)  :: Param
real,                        intent(in)  :: available_condensate,  &
                                            available_condensate_liq,  &
                                            available_condensate_ice,  &
                                            pzm, pztm
real, dimension(nlev_lsm+1), intent(in)  :: phalf_c
real,                        intent(out) ::       emdi_liq, emdi_ice
real, dimension(nlev_lsm),   intent(out) :: emds_liq, emds_ice
real, dimension(nlev_lsm),   intent(out) :: emes_liq, emes_ice
character(len=128),          intent(out) :: ermesg
integer,                     intent(out) :: error

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       available_condensate      total condensate available in the
!                                 anvil [ mm(h2o) / day ]
!       pzm                       pressure at base of mesoscale updraft
!                                 [ Pa ]
!       pztm                      pressure at top of mesoscale updraft
!                                 [ Pa ]
!       phalf_c                   pressures at large-scale model inter-
!                                 face levels [ Pa ]
!       diag_unit                 output unit number for this 
!                                 diagnostics column
!       debug_ijt                 is this a diagnostics column ?
!
!   intent(out) variables:
!
!       emdi                      vertical integral of mesoscale down-
!                                 draft sublimation [ mm (h2o) / day ]
!       emds                      water mass sublimated in mesoscale
!                                 downdraft [ g(h2o) / (kg(air) day) ] 
!       emes                      water mass sublimated in mesoscale
!                                 updraft [ g(h2o) / (kg(air) day) ] 
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!       emei                      vertical integral of mesoscale updraft
!                                 sublimation [ mm (h2o) / day ]
!       emea                      vertical integral of mesoscale updraft
!                                 sublimation [ g(h2o) / (kg(air) day) ]




     real    ::                   pm, pp, pbot_meso_sub
     real  :: emei_liq, emei_ice, emea_liq, emea_ice
     real  :: emda_liq, emda_ice
     integer :: k


      ermesg = ' ' ; error = 0
      emes_liq = 0.
      emes_ice = 0.

!---------------------------------------------------------------------
!    define the rate of total water sublimation in the mesoscale updraft
!    (emei) using the Leary and Houze coefficient.
!---------------------------------------------------------------------
      emei_liq = Param%meso_up_evap_fraction*available_condensate_liq
      emei_ice = Param%meso_up_evap_fraction*available_condensate_ice

!----------------------------------------------------------------------
!    convert the integral of mesoscale updraft evaporation from mm (h20)
!    per day to g(h2o) / (kg(air) / day (emea). updraft evaporation is 
!    assumed to occur between base of mesoscale updraft (pzm) and the 
!    top of mesoscale updraft (pztm) at a uniform rate. 
!---------------------------------------------------------------------- 
      emea_liq = emei_liq*Param%grav*1000./(pzm - pztm)
      emea_ice = emei_ice*Param%grav*1000./(pzm - pztm)

!--------------------------------------------------------------------
!    if in diagnostics column, output the column integral mesoscale
!    updraft evaporation, in units of both mm / day (emei) and 
!    g(h2o) / kg(air) / day (emea), and the pressures defining the
!    mesoscale updraft region (pzm, pztm).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, 2e20.12)')  &
                         'in meens: emea,emei= ',emea_liq + emea_ice, &
                                                  emei_liq + emei_ice
        write (diag_unit, '(a, 2e20.12)')  &
                         'in meens: LIQemea,emei= ',emea_liq, emei_liq
        write (diag_unit, '(a, 2e20.12)')  &
                         'in meens: ICEemea,emei= ',emea_ice, emei_ice
        write (diag_unit, '(a, 2f19.10)')  &
                         'in meens: pzm, pztm= ',pzm, pztm
      endif

!---------------------------------------------------------------------
!    call map_hi_res_intgl_to_lo_res_col to distribute the integrated 
!    mesoscale updraft sublimation (emea) within the mesoscale updraft
!    region (pzm -> pztm) of the large-scale model column whose layers
!    are defined by interface pressure array phalf_c.
!---------------------------------------------------------------------
      call don_u_map_hires_i_to_lores_c_k &
           (nlev_lsm, emea_liq, pzm, pztm, phalf_c, emes_liq, ermesg, error)
      call don_u_map_hires_i_to_lores_c_k &
           (nlev_lsm, emea_ice, pzm, pztm, phalf_c, emes_ice, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!----------------------------------------------------------------------
!    if in a diagnostics column, output the mesoscale updraft sublim-
!    ation profile (emes) at those levels where it is non-zero.
!----------------------------------------------------------------------
      if (debug_ijt) then
        do k=1,nlev_lsm           
          if ((emes_liq(k) + emes_ice(k)) /= 0.0) then
            write (diag_unit, '(a, i4, e20.12)') &
                   'in cm_intgl_to_gcm_col: k,x= ',k,emes_liq(k) + &
                                                       emes_ice(k)
          endif
        end do
      endif

!---------------------------------------------------------------------
!    define the rate of total water sublimation in the mesoscale down-
!    draft (emdi) using the Leary and Houze coefficient.
!---------------------------------------------------------------------
      emdi_liq = Param%meso_down_evap_fraction*available_condensate_liq
      emdi_ice = Param%meso_down_evap_fraction*available_condensate_ice

!----------------------------------------------------------------------
!    convert the integral of mesoscale downdraft sublimation from mm 
!    (h20) per day to g(h2o) / (kg(air) / day (emda). downdraft sublim- 
!    ation is assumed to occur between base of mesoscale updraft (pzm)
!    and pressure pbot_meso_sub at a uniform rate.
!---------------------------------------------------------------------- 
      pbot_meso_sub = phalf_c(1)
      emda_liq = emdi_liq*Param%grav*1000./(pbot_meso_sub - pzm)
      emda_ice = emdi_ice*Param%grav*1000./(pbot_meso_sub - pzm)

!----------------------------------------------------------------------
!    distribute the integrated downdraft sublimation over the approp-
!    riate large-scale model layers.
!----------------------------------------------------------------------
      emds_liq = 0.
      emds_ice = 0.
      do k=1,nlev_lsm            

!---------------------------------------------------------------------
!    if the current level is above the base of the mesoscale updraft, 
!    exit the loop. if the level is below the surface, cycle to the end
!    of the loop.
!---------------------------------------------------------------------
        if (phalf_c(k) < pzm) exit
        if (phalf_c(k+1) > pbot_meso_sub ) cycle
        pm = phalf_c(k)
        pp = phalf_c(k+1)
        if ((phalf_c(k) >= pbot_meso_sub) .and.    &
            (phalf_c(k+1) <= pbot_meso_sub ) )  then
          pm = phalf_c(1) 
        endif
        if ((phalf_c(k) >= pzm) .and. (phalf_c(k+1) <= pzm))  pp = pzm
        emds_liq(k) = emda_liq*(pm - pp)*(pm + pp - 2.*pbot_meso_sub)
        emds_ice(k) = emda_ice*(pm - pp)*(pm + pp - 2.*pbot_meso_sub)

!--------------------------------------------------------------------
!    if in diagnostics column, output the column integral mesoscale
!    downdraft evaporation (emda) and the amount assigned to each layer
!    (emds), in units of g(h2o) / kg(air) / day.
!--------------------------------------------------------------------
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
               'in meens: jk,emda,emd= ', k, emda_liq + emda_ice,  &
                                          emds_liq(k) + emds_ice(k)
          write (diag_unit, '(a, i4, 2e20.12)')  &
                  'in meens: jk,LIQemda,emd= ', k, emda_liq, emds_liq(k)
          write (diag_unit, '(a, i4, 2e20.12)')  &
                 'in meens: jk,ICEemda,emd= ', k, emda_ice, emds_ice(k)
        endif

!---------------------------------------------------------------------
!    
!---------------------------------------------------------------------
        emds_liq(k) = emds_liq(k)/((phalf_c(k) - phalf_c(k+1))*    &
                  (pzm - pbot_meso_sub))
        emds_ice(k) = emds_ice(k)/((phalf_c(k) - phalf_c(k+1))*    &
                  (pzm - pbot_meso_sub))
        if (debug_ijt) then
          write (diag_unit, '(a, i4, 2e20.12)')  &
            'in meens: FINALjk,emda,emd= ', k, emda_liq + emda_ice,   &
                                             emds_liq(k) + emds_ice(k)
        endif
      end do

!--------------------------------------------------------------------
!    if in diagnostics column, output the column integral mesoscale
!    downdraft evaporation in units of mm / day (emdi) and the surface
!    pressure (ps).
!--------------------------------------------------------------------
      if (debug_ijt) then
        write (diag_unit, '(a, e20.12, f19.10)')  &
              'in meens: emdi,ps= ', emdi_liq + emdi_ice, pbot_meso_sub
        write (diag_unit, '(a, e20.12, f19.10)')  &
                    'in meens: LIQemdi,ps= ', emdi_liq, pbot_meso_sub
        write (diag_unit, '(a, e20.12, f19.10)')  &
                    'in meens: ICEemdi,ps= ', emdi_ice, pbot_meso_sub
      endif

!---------------------------------------------------------------------


end subroutine don_m_meso_evap_k



!######################################################################

subroutine don_m_meso_melt_k   &
         (nlev_lsm, diag_unit, debug_ijt, Param, temp_c, phalf_c,  &
          pztm, meso_precip, pb, anvil_precip_melt, ermesg, error)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type

implicit none

!----------------------------------------------------------------------
integer,                     intent(in)  :: nlev_lsm
integer,                     intent(in)  :: diag_unit
logical,                     intent(in)  :: debug_ijt 
type(donner_param_type),     intent(in)  :: Param
real, dimension(nlev_lsm),   intent(in)  :: temp_c
real, dimension(nlev_lsm+1), intent(in)  :: phalf_c
real,                        intent(in)  :: pztm, meso_precip, pb
real, dimension(nlev_lsm),   intent(out) :: anvil_precip_melt
character(len=*),            intent(out) :: ermesg
integer,                     intent(out) :: error

  
      real  ::  p2, rma
      integer :: k

      anvil_precip_melt = 0.
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    define the pressure at the melting level (p2).
!--------------------------------------------------------------------
      p2 = -10.
      do k=1,nlev_lsm-1
        if (phalf_c(k+1) < pztm ) exit
        if ((temp_c(k) >= Param%kelvin) .and.   &
             (temp_c(k+1) <= Param%kelvin))  then
          p2 = phalf_c(k+1)
          exit
        end if
      end do

!---------------------------------------------------------------------
!    define the rate of melting (mm/day)of anvil precipitation as it 
!    falls between the melting level (p2) and cloud base (pb). if there
!    is a melting level, all anvil precip is assumed to melt.
!---------------------------------------------------------------------
      if (p2 .ne. -10.) then
        rma = meso_precip
      else
        rma = 0.
      endif

!---------------------------------------------------------------------
!    convert the melting rate in mm / day (rm) to g(h2o) / kg(air) /day
!    (rma).
!---------------------------------------------------------------------
      rma = -rma*Param%grav*1000./(pb - p2)

!--------------------------------------------------------------------
!    if there is a melting level, map the melting rate uniformly across
!    the region of melting (melting level to cloud base). if there is
!    no melting level in the cloud, anvil_precip_melt is set to 0.0.
!--------------------------------------------------------------------
      if (pb > p2) then
        if (debug_ijt) then
          write (diag_unit, '(a, e20.12, 2f19.10)')  &
                     'in cm_intgl_to_gcm_col: xav,p1,p2= ',-rma, pb, p2
        endif
        call don_u_map_hires_i_to_lores_c_k  &
             (nlev_lsm, rma, pb, p2, phalf_c, anvil_precip_melt, ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
        if (error /= 0 ) return

        if (debug_ijt) then
          do k=1,nlev_lsm               
            if (anvil_precip_melt(k) /= 0.0) then
              write (diag_unit, '(a, i4, e20.12)') &
                'in cm_intgl_to_gcm_col: k,x= ',k,-anvil_precip_melt(k)
            endif
          end do
        endif
      else                           
        anvil_precip_melt = 0.0
      endif

!---------------------------------------------------------------------

end subroutine don_m_meso_melt_k 



!#####################################################################

subroutine don_m_define_anvil_ice_k   &
         (isize, jsize, nlev_lsm, Param, Col_diag, pfull, temp,       &
          exit_flag, Don_conv, ermesg, error)

!----------------------------------------------------------------------
!    subroutine define_anvil_ice obtains the anvil ice profile
!    (Don_conv%xice) and the corresponding effective ice crystal size 
!    profile (Don_conv%dgeice).
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_conv_type, &
                             donner_column_diag_type

implicit none

!-----------------------------------------------------------------------
integer,                               intent(in)    :: isize, jsize,   &
                                                        nlev_lsm
type(donner_param_type),               intent(in)    :: Param
type(donner_column_diag_type),         intent(in)    :: Col_diag
real, dimension(isize,jsize,nlev_lsm), intent(in)    :: pfull, temp
logical, dimension(isize,jsize),       intent(in)    :: exit_flag      
type(donner_conv_type),                intent(inout) :: Don_conv
character(len=*),                      intent(out)   :: ermesg
integer,                               intent(out)   :: error
            
!---------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie         first and last values of i index values of points 
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points 
!                    in this physics window (processor coordinates)
!     pfull          pressure at model full levels [ Pa ]
!     temp           temperature at model full levels [ deg K ]
!     total_precip   total convective-system precipitation [ mm / day ]
!
!   intent(inout) variables:
!
!     Don_conv
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:
  
     integer :: anvil_top_indx ! vertical index of highest model level
                               ! containing anvil ice 
     integer :: anvil_bot_indx ! vertical index of lowest model level
                               ! containing anvil ice 
     integer :: i, j, k, n     ! do-loop indices


!--------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    if column diagnostics are desired and there is mesoscale cloud 
!    present, output the mesoscale cloud area (ampta1), the mesoscale
!    downdraft sublimation integral (emdi), 
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          if (Don_conv%ampta1(Col_diag%i_dc(n),   &
                              Col_diag%j_dc(n)) /= 0.0) then
            write (Col_diag%unit_dc(n), '(a, 2e20.12)')   &
                     'pre prean: ampta1, emdi, contot, tprei', &
                  Don_conv%ampta1 (Col_diag%i_dc(n),Col_diag%j_dc(n)), &
                  Don_conv%emdi_v    (Col_diag%i_dc(n),Col_diag%j_dc(n))
          endif
        end do
      endif

!--------------------------------------------------------------------
!    determine the vertical ice distribution and the effective ice 
!    size at each level.
!--------------------------------------------------------------------
      do j=1,jsize
        do i=1,isize
          if (.not. exit_flag(i,j)) then
!---------------------------------------------------------------------
!    call subroutine prean to assign the anvil ice content to the 
!    appropriate model layers. if there is no anvil in the column
!    (i.e., no mesoscale area, no mesoscale precip, no mesoscale down-
!    draft sublimation, no total precip), set the ice profile to be 0.0 
!    throughout the column.
!---------------------------------------------------------------------
            if (Don_conv%ampta1(i,j) > 0.0 .and.  &
                Don_conv%emdi_v(i,j) > 0.0 .and.  &
                Don_conv%meso_precip(i,j) > 0.0) then
              call don_m_prean_k   &
                   (i, j, nlev_lsm, Param, Col_diag, &
                    Don_conv%ampta1(i,j), Don_conv%meso_precip(i,j),&
                    Don_conv%emdi_v(i,j), pfull(i,j,:),  &
                    Don_conv%umeml(i,j,:), temp(i,j,:),   &
                    Don_conv%xice(i,j,:), ermesg, error)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
              if (error /= 0 ) return
            else
              Don_conv%xice(i,j,:) = 0.0      
            endif

!!! ANVIL ICE EXTENDS WELL BELOW FREEZING LEVEL  ?????
!!! BEGINS AT BASE OF MESOSCALE UPDRAFT WHICH IS NOT CONSTRAINED TO 
!!! BE AT OR BELOW FREEZING ??
           
!--------------------------------------------------------------------
!    determine the pressure at the top of the anvil (prztm). this will 
!    be the lowest model level pressure at which ice is present. at 
!    levels above this, set the effective ice size to 0.0.
!--------------------------------------------------------------------
            do k=1,nlev_lsm
              anvil_top_indx  = k 
              if ((Don_conv%xice(i,j,k) >= 1.0E-10)) then 
                Don_conv%prztm(i,j) = pfull(i,j,k)
                exit 
              endif
            end do

!--------------------------------------------------------------------
!    determine the pressure at the bottom of the anvil (przm). this 
!    will be the highest model level pressure at which ice is present.
!--------------------------------------------------------------------
            do k=anvil_top_indx+1,nlev_lsm
              if ((Don_conv%xice(i,j,k) < 1.0E-11) ) then
                Don_conv%przm(i,j) = pfull(i,j,k-1)
                anvil_bot_indx = k-1
                exit
              endif
            end do
          else
            Don_conv%xice(i,j,:) = 0.0      
            Don_conv%przm(i,j) = 0.0              
            Don_conv%prztm(i,j) = 0.0            
          endif
        end do
      end do

!---------------------------------------------------------------------
!    if column diagnostics are desired, output the level index, the 
!    pressure and the amount of ice at those levels at which ice is
!    present.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          do k=1,nlev_lsm
            if (Don_conv%xice(Col_diag%i_dc(n),  &
                              Col_diag%j_dc(n),k) > 0.0) then
              write (Col_diag%unit_dc(n), '(a, i4, e10.3, e20.12)')  &
                    'post prean: pressure, xice', &
                    k, pfull(Col_diag%i_dc(n), Col_diag%j_dc(n),k),    &
                    Don_conv%xice(Col_diag%i_dc(n), Col_diag%j_dc(n),k) 
            endif
          end do
        end do
      endif

!---------------------------------------------------------------------



end subroutine don_m_define_anvil_ice_k

!#####################################################################

subroutine don_m_prean_k     &
         (i, j, nlev_lsm, Param, Col_diag, ampta1_s, meso_precip_s,  &
          emdi_s, pfull_c, umeml_c, temp_c, xice_c, ermesg, error)

!---------------------------------------------------------------------
!    subroutine prean calculates the ice content assigned to the model
!    layers with an upward mesoscale mass flux.
!     Leo Donner
!     GFDL
!     17 May 2001
!---------------------------------------------------------------------
 
use donner_types_mod, only : donner_param_type, donner_column_diag_type

implicit none

!---------------------------------------------------------------------
integer,                       intent(in)  :: i, j, nlev_lsm
type(donner_param_type),       intent(in)  :: Param
type(donner_column_diag_type), intent(in)  :: Col_diag
real,                          intent(in)  :: ampta1_s, meso_precip_s, &
                                              emdi_s
real, dimension(nlev_lsm),     intent(in)  :: pfull_c, umeml_c, temp_c
real, dimension(nlev_lsm),     intent(out) :: xice_c 
character(len=*),              intent(out) :: ermesg
integer,                       intent(out) :: error

!-------------------------------------------------------------------
!   intent(in) variables:
!
!      i, j        horizontal coordinates of current column
!      ampta1_s    fractional area of mesoscale circulation
!                  [ fraction ]
!      emdi_s      vertical integral of  mesoscale-downdraft 
!                  sublimation [ mm / day ]
!      tprei       total convective-system precipitation [ mm / day ]
!      pfull_c     pressure at full model levels [ Pa ]
!      umeml_c     mesoscale updraft mass flux  [ kg / (m**2 sec) ]
!      temp_c      temperature at model full levels [ deg K ]
!
!   intent(out) variables:
!
!      xice_c      anvil ice [ kg(ice) / kg(air) ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
 
      real      :: rho       !  height-averaged anvil air density 
                             !  [ kg/ (m**3) ]
      real      :: xicet     !  anvil ice work variable 
                             !  [ kg(ice) / kg (air) ]
      integer   :: kou       !  counter
      integer   :: k, kk, n  !  do-loop indices

!---------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    sum up the air density in the anvil layers.
!---------------------------------------------------------------------
      rho = 0.
      kou = 0
      do k=1,nlev_lsm             
        if (umeml_c(k) /= 0.) then
          kou = kou + 1
!  SHOULD virtual temp be used in defining this density ??
          rho = rho + pfull_c(k)/(Param%rdgas*temp_c(k))
        endif
      end do

!--------------------------------------------------------------------
!    if an anvil exists, determine the ice content of its layers.
!--------------------------------------------------------------------
      if (kou /= 0) then  

!--------------------------------------------------------------------
!    define the mean air density in the anvil region.
!--------------------------------------------------------------------
        rho = rho/kou

!----------------------------------------------------------------------
!    calculate the mesoscale ice content by balancing the fallout at 
!    anvil base with the mesoscale precipitation and the sublimation 
!    in the mesoscale downdraft.
!---------------------------------------------------------------------
!----------------------------------------------------------------------
!    sum up the anvil precipitation and the mesoscale downdraft sub-
!    limation (xicet).
!----------------------------------------------------------------------
        xicet = (meso_precip_s/86400.) + (emdi_s/86400.)
!!!???????????   DON'T KNOW THIS EXPRESSION ????
        xicet=xicet/(3.29*ampta1_s)
        xicet=xicet**.862
        xicet=xicet/rho

!----------------------------------------------------------------------
!    assign anvil ice to all layers with postive mesoscale updraft mass
!    flux.
!---------------------------------------------------------------------
        do k=1,nlev_lsm            
          if (umeml_c(k) > 0.) then
            xice_c(k) = xicet
          else
            xice_c(k) = 0.
          endif
        end do

!---------------------------------------------------------------------
!   if in diagnostics column, output the variables related to the
!   mesoscale ice content.
!---------------------------------------------------------------------
        if (Col_diag%in_diagnostics_window) then
          do n=1,Col_diag%ncols_in_window
            if (j == Col_diag%j_dc(n) .and. i == Col_diag%i_dc(n)) then
              do k=1, nlev_lsm            
                if (xice_c(k) > 0.00) then
                  write (Col_diag%unit_dc(n), '(a, 2e22.12)') &
                        'prean ampu,contot,emdi=', ampta1_s,  emdi_s
                  write (Col_diag%unit_dc(n), '(a, 1e22.12, i5)') &
                              'rho,     kou= ',rho,     kou
                  do kk=1,nlev_lsm           
                    if (xice_c(kk) > 0.00) then
                      write (Col_diag%unit_dc(n), '(a, i5, 2e22.12)') &
                                'k,prf,xice= ',kk,pfull_c(kk),xice_c(kk)
                      write (Col_diag%unit_dc(n), '(a, i5, 2e22.12)') &
                                 'k,prf,trf= ',kk,pfull_c(kk),temp_c(kk)
                      write (Col_diag%unit_dc(n), '(a, i5, 2e22.12)') &
                                   'k,prf,rmuf= ',kk,pfull_c(kk),umeml_c(kk)
                       write (Col_diag%unit_dc(n), '(a, i5, 2e22.12)') &
                     'k, grid box mean meso_precip_s, emdi_s = ', &
                        kk, meso_precip_s, emdi_s
                       write (Col_diag%unit_dc(n), '(a, i5, 2e22.12)') &
  'k,meso_precip_s, cloud area normalized xice in cloud (g / m**3) = ',&
                   kk, meso_precip_s,     &
        xice_c(kk)*ampta1_s*1.0e03*pfull_c(kk)/(temp_c(kk)*Param%rdgas)
                    endif
                  end do
                  exit
                endif
              end do
            endif
          end do
        endif

!---------------------------------------------------------------------
!    if there are no layers with positive mesoscale mass flux, set the
!    ice content at all levels to be 0.0.
!---------------------------------------------------------------------
      else
        xice_c(:) = 0.0
      endif

!--------------------------------------------------------------------


end subroutine don_m_prean_k



!######################################################################




!VERSION NUMBER:
!  $Id: donner_rad_k.F90,v 16.0 2008/07/30 22:07:00 fms Exp $

!module donner_rad_inter_mod

!#include "donner_rad_interfaces.h"

!end module donner_rad_inter_mod


!###################################################################

subroutine don_r_donner_rad_driver_k   &
         (isize, jsize, nlev_lsm, Param, Col_diag, Initialized,   &
          pfull, temp, land, exit_flag, Don_conv, Don_rad, Nml, ermesg, error)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_initialized_type, donner_conv_type,&
                             donner_column_diag_type, donner_rad_type

implicit none

!----------------------------------------------------------------------
integer,                               intent(in)    :: isize, jsize,   &
                                                        nlev_lsm
type(donner_param_type),               intent(in)    :: Param
type(donner_column_diag_type),         intent(in)    :: Col_diag
type(donner_initialized_type),         intent(in)    :: Initialized
real, dimension(isize,jsize,nlev_lsm), intent(in)    :: pfull, temp
real, dimension(isize,jsize),          intent(in)    :: land
logical, dimension(isize,jsize),       intent(in)    :: exit_flag
type(donner_conv_type),                intent(inout) :: Don_conv
type(donner_rad_type),                 intent(inout) :: Don_rad
type(donner_nml_type),                 intent(inout) :: Nml       
character(len=*),                      intent(out)   :: ermesg
integer,                               intent(out)   :: error

      ermesg= ' ' ; error = 0

!---------------------------------------------------------------------
!    call define_ice_size to define the ice particle size distribution 
!    within the anvil (Don_conv%dgeice).
!---------------------------------------------------------------------
      call don_r_define_ice_size_k    &
           (isize, jsize, nlev_lsm, Param, Col_diag, pfull, &
            Don_conv%xice, Don_conv%przm, Don_conv%prztm,    &
            Don_conv%dgeice, ermesg, error)

!---------------------------------------------------------------------
!    call define_cell_liquid_size to compute the cell liquid effective
!    droplet diameter (Don_conv%cell_liquid_eff_diam) and the number of
!    cell droplets (Don_rad%cell_droplet_number).
!---------------------------------------------------------------------
      call don_r_define_cell_liquid_size_k   &
           (isize, jsize, nlev_lsm, Param, Nml, Col_diag, pfull, temp, &
            Don_conv%cuql, Don_conv%cual, land, exit_flag,    &
            Don_conv%cell_liquid_eff_diam, Don_rad%cell_droplet_number,&
            ermesg, error)
 
!---------------------------------------------------------------------
!    since liquid is not allowed in anvil currently, set the droplet
!    number there to be 0.0.
!---------------------------------------------------------------------
      Don_rad%meso_droplet_number = 0.0

!---------------------------------------------------------------------
!    save  variables needed by the radiation package.
!---------------------------------------------------------------------
      call don_r_donner_deep_sum_k  &
           (isize, jsize, nlev_lsm, Param, Nml, Initialized, &
            Don_conv%xliq, Don_conv%xice, Don_conv%cual,  &
            Don_conv%ampta1, Don_conv%cuql, Don_conv%cuqi, &
            Don_conv%dgeice, Don_conv%cell_liquid_eff_diam, &
            Don_rad, ermesg, error)

!--------------------------------------------------------------------


end subroutine don_r_donner_rad_driver_k

!######################################################################

subroutine don_r_define_ice_size_k    &
         (isize, jsize, nlev_lsm, Param, Col_diag, pfull, xice, przm, &
          prztm, dgeice, ermesg, error)
  
!----------------------------------------------------------------------
!    subroutine define_ice_size obtains the effective ice crystal size 
!    profile (dgeice).
!----------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_column_diag_type

implicit none

!----------------------------------------------------------------------
integer,                               intent(in)  :: isize, jsize,  &
                                                      nlev_lsm
type(donner_param_type),               intent(in)  :: Param
type(donner_column_diag_type),         intent(in)  :: Col_diag
real, dimension(isize,jsize,nlev_lsm), intent(in)  :: pfull, xice
real, dimension(isize,jsize),          intent(in)  :: przm, prztm
real, dimension(isize,jsize,nlev_lsm), intent(out) :: dgeice
character(len=*),                      intent(out) :: ermesg
integer,                               intent(out) :: error
            
!---------------------------------------------------------------------
!   intent(in) variables:
!
!     pfull          pressure at model full levels [ Pa ]
!     xice           mesoscale ice content [ kg(ice) / kg(air ]
!     przm           pressure at anvil base [ Pa ]
!     prztm          pressure at anvil top [ Pa ]
!
!   intent(out) variables:
!
!     dgeice         effective ice crystal size [ microns ]
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:
  
      integer :: i, j, k        ! do-loop indices

      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    call subroutine andge to assign effective sizes (dgeice) to the 
!    ice in the model layers of the anvil.
!    make sure the ice size is within the limits acceptable to the 
!    radiative properties parameterizations.
!---------------------------------------------------------------------
      do k=1,nlev_lsm                           
        do j=1,jsize
          do i=1,isize
            if (xice(i,j,k) > 0.0) then
              call don_r_andge_k   &
                   (i, j, Param, Col_diag, pfull(i,j,k), przm(i,j),  &
                    prztm(i,j), dgeice(i,j,k), ermesg, error)
            else
              dgeice(i,j,k) = 0.
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------


end subroutine don_r_define_ice_size_k


!######################################################################

subroutine don_r_andge_k   &
         (i, j, Param, Col_diag, press, pzm, pztm, dgeicer, ermesg, error)
  
!---------------------------------------------------------------------
!    subroutine andge defines the generalized effective ice crystal size
!    for the mesoscale anvil layers.
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_column_diag_type

implicit none

!---------------------------------------------------------------------
integer,                       intent(in)  :: i,j 
type(donner_param_type),       intent(in)  :: Param
type(donner_column_diag_type), intent(in)  :: Col_diag
real,                          intent(in)  :: press, pzm, pztm       
real,                          intent(out) :: dgeicer    
character(len=*),              intent(out) :: ermesg
integer,                       intent(out) :: error
 
!---------------------------------------------------------------------
!   intent(in) variables:
!
!     i, j      physics window indices of the current column
!     press     pressure at model full levels [ Pa ]
!     pzm       pressure at base of mesoscale anvil [ Pa ]
!     pztm      pressure at top of mesoscale anvil [ Pa ]
!
!   intent(out) variables:
! 
!     dgeicer   generalized effective size of ice crystals in anvil 
!               defined as in Fu (1996, J. Clim.). [ microns ]
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real     :: znor    ! normalized distance from anvil base
                          ! [ dimensionless ]
      integer  :: k, n    ! do-loop indices

      ermesg = ' ' ; error = 0

!-------------------------------------------------------------------
!    be sure that anvil base has higher pressure than anvil top. 
!-------------------------------------------------------------------
      if (pzm < pztm) then
        ermesg = ' andge: pzm is < pztm'
        error = 1
        return
      endif

!-------------------------------------------------------------------
!    define the relative displacement of the current pressure between
!    the anvil top and bottom. avoid calculation if anvil depth is 0.0
!    (implying a one-layer thick anvil).
!-------------------------------------------------------------------
      if (pzm == pztm) then
        znor = 0.5
      else
        znor = (pzm - press)/(pzm - pztm)
      endif

!--------------------------------------------------------------------
!    define the value of dgeice at the appropriate relative displacement
!    from anvil base (dgeicer).
!--------------------------------------------------------------------
      do k=2,Param%anvil_levels
        if ((znor >= Param%relht(k-1)) .and.   &
            (znor <= Param%relht(k))) then
          dgeicer = Param%dgeice(k-1) + ((znor - Param%relht(k-1))*  &
                   (Param%dgeice(k) - Param%dgeice(k-1))/  &
                   (Param%relht(k) - Param%relht(k-1)))
          exit
        endif
      end do

!---------------------------------------------------------------------
!   if in diagnostics column, output relevant variables related to the 
!   effective ice size calculation.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          if (j == Col_diag%j_dc(n) .and. i == Col_diag%i_dc(n)) then
            write (Col_diag%unit_dc(n), '(a, e22.12)')  'znor= ',znor
            write (Col_diag%unit_dc(n), '(a, 2e22.12)') &
                            'relhts= ',Param%relht(k-1),Param%relht(k)
            write (Col_diag%unit_dc(n), '(a, e22.12)') &
                             'dgeicer= ',dgeicer
          endif
        end do
      endif

!--------------------------------------------------------------------


end subroutine don_r_andge_k


!###################################################################

subroutine don_r_define_cell_liquid_size_k   &
         (isize, jsize, nlev_lsm, Param, Nml, Col_diag, pfull, temp, &
          cuql, cual, land, exit_flag, cell_liquid_eff_diam,  &
          cell_droplet_number, ermesg, error)

!--------------------------------------------------------------------
!    subroutine define_cell_liquid_size calculates the effective radii 
!    of liquid cloud drops in cumulus clouds following the prescription
!    of Bower et al (JAS, 1994).
!---------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_column_diag_type

implicit none

!---------------------------------------------------------------------
integer,                         intent(in)  :: isize, jsize, nlev_lsm
type(donner_param_type),         intent(in)  :: Param
type(donner_nml_type),           intent(in)  :: Nml

type(donner_column_diag_type),   intent(in)  :: Col_diag
real, dimension(isize,jsize,nlev_lsm),                 &
                                 intent(in)  :: pfull, temp, cuql, cual
real, dimension(isize,jsize),    intent(in)  :: land
logical,dimension(isize,jsize),  intent(in)  :: exit_flag
real, dimension(isize,jsize,nlev_lsm),                  &
                                 intent(out) :: cell_liquid_eff_diam, &
                                                cell_droplet_number
character(len=*),                intent(out) :: ermesg
integer,                         intent(out) :: error
   
!--------------------------------------------------------------------
!   intent(in) variables:
!
!     pfull          pressure at model full levels [ Pa ]
!     temp           temperature at model full levels [ deg K ]
!     cuql           cell liquid content [ kg(h2o) / kg(air) ]
!     land           fraction of land in grid box [ fraction ]
!     cell_liquid_eff_diam
!                    effective diameter of liquid cloud drops 
!                    [ microns ]
!     cell_droplet_number
!                    droplet number in cells [ # / kg(air) ]
!
!------------------------------------------------------------------
! local variables
  
      real, dimension (isize,jsize) ::   &
                                cell_pbase, temp_cell_pbase, &
                                cell_land_ref_delp, cell_ocean_ref_delp
                                       
      real, dimension (isize,jsize,nlev_lsm)          ::   &
                               cell_delp, cell_liquid_eff_diam_land,  &
                               cell_liquid_eff_diam_ocean, &
                               cell_droplet_number_land,   &
                               cell_droplet_number_ocean
      integer   :: i, j, k, n

!------------------------------------------------------------------
! local variables
!
!        cell_pbase                      pressure at cloud base [ Pa ]
!        temp_cell_pbase                 temperature at cloud base
!                                        [ deg K ]
!        cell_land_ref_delp              pressure difference between
!                                        cloud base and a point 
!                                        delz_land meters above cloud 
!                                        base
!        cell_ocean_ref_delp             pressure difference between
!                                        cloud base and a point 
!                                        delz_ocean meters above cloud 
!                                        base
!        cell_delp                       pressure difference between 
!                                        level k and the pressure at
!                                        cloud base (lowest level with
!                                        liquid condensate) [ Pa ]
!        cell_liquid_eff_diam_land       droplet effective diameter when
!                                        over a land surface
!                                        [ microns ]
!        cell_liquid_eff_diam_ocean      droplet effective diameter when
!                                        over an ocean surface 
!                                        [ microns ]
!        cell_droplet_number_land
!        cell_droplet_number_ocean
!        i,j,k,n                         do-loop indices
!
!-------------------------------------------------------------------

      ermesg= ' ' ; error = 0

!--------------------------------------------------------------------
!    define the pressure (cell_pbase) and temperature (temp_cell_pbase)
!    at the cell cloud base (lowest level with liquid water present).
!--------------------------------------------------------------------
      cell_pbase = pfull(:,:,1)
      temp_cell_pbase = temp(:,:,1)
      do j=1,jsize
        do i=1,isize
          do k=nlev_lsm,1,-1
            if (cuql(i,j,k) >= 1.0e-11 )  then
              cell_pbase(i,j) = pfull(i,j,k)
              temp_cell_pbase(i,j) = temp(i,j,k)
              exit
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------
!    define the pressure distance between the cell cloud base and each
!    model pressure level.
!---------------------------------------------------------------------
      do k=1,nlev_lsm             
        cell_delp(:,:,k) = cell_pbase(:,:) - pfull(:,:,k)
      end do

!--------------------------------------------------------------------
!    define the pressure distance between the cell cloud base and points
!    delz_land meters and delz_ocean meters above cloud base. between
!    cloud base and this distance above cloud base, cloud drop size 
!    will be computed; for greater distances above cloud base, the 
!    appropriate drop radii existing as parameters in this module will
!    be used.
!--------------------------------------------------------------------
      cell_land_ref_delp =      &
               cell_pbase*(1.0 - EXP( -(Param%delz_land*Param%grav/   &
                                       (Param%rdgas*temp_cell_pbase))))
      cell_ocean_ref_delp =      &
               cell_pbase*(1.0 - EXP( -(Param%delz_ocean*Param%grav/  &
                                       (Param%rdgas*temp_cell_pbase))))

!---------------------------------------------------------------------
!    if in a diagnostics column, output the vertical profiles of cloud 
!    liquid (cuql), cloud base separation (cell_delp) and pressure 
!    (pfull), along with the column values of land and ocean reference
!    pressure deltas, cell cloud base and land fraction.
!---------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          do j=1,jsize
            do i=1,isize
              if (j == Col_diag%j_dc(n) .and. i == Col_diag%i_dc(n)) then
                if (.not. exit_flag(i,j)) then
                  do k=1,nlev_lsm             
                    if (cuql(i,j,k) > 0.0) then
                      write (Col_diag%unit_dc(n), '(a, e22.12)') &
                           ' Don_conv%cuql', cuql(i,j,k)
                      write (Col_diag%unit_dc(n), '(a, e22.12)') & 
                           ' cell_delp', cell_delp(i,j,k)
                      write (Col_diag%unit_dc(n), '(a, e22.12)') & 
                              ' pfull',  pfull(i,j,k)
                    endif
                  end do
                  write (Col_diag%unit_dc(n), '(a, e22.12)') &
                      ' cell_land_ref_delp',  cell_land_ref_delp(i,j)
                  write (Col_diag%unit_dc(n), '(a, e22.12)') &
                      ' cell_ocean_ref_delp', cell_ocean_ref_delp(i,j)
                  write (Col_diag%unit_dc(n), '(a, e22.12)') &
                                  ' land', land(i,j)
                  write (Col_diag%unit_dc(n), '(a, e22.12)') &
                                 ' cell_pbase', cell_pbase(i,j)
                endif
              endif
            end do
          end do
        end do
      endif

!--------------------------------------------------------------------
!    compute the drop diameters for the land and ocean portions of the 
!    grid box, when liquid water is present.
!--------------------------------------------------------------------
      do k=1,nlev_lsm             
        do j=1,jsize
          do i=1,isize
            if (cuql(i,j,k) >= 1.0e-11 .and. &
                cual(i,j,k) > 0.0) then

!---------------------------------------------------------------------
!    if land is present in the box and the box is more than delz_land 
!    meters from cloud base, define the cloud drop diameter as the
!    value of r_conv_land.
!---------------------------------------------------------------------
              if (land(i,j) > 0.0) then
                if (cell_delp(i,j,k) >= cell_land_ref_delp(i,j)) then 
                  cell_liquid_eff_diam_land(i,j,k) =      &
                                                  2.0*Param%r_conv_land
                  cell_droplet_number_land(i,j,k) =  3.0*cuql(i,j,k)/  &
                                     (4.0*Param%pie*Param%dens_h2o*    &
                                         (Param%r_conv_land*1.0e-06)**3)
                  cell_droplet_number_land(i,j,k) =  &
                       cell_droplet_number_land(i,j,k)*pfull(i,j,k)/&
                          (Param%rdgas*temp(i,j,k))

!---------------------------------------------------------------------
!    if the box is less than delz_land meters from cloud base, calculate
!    the cloud drop diameter.
!---------------------------------------------------------------------
                else
                  cell_liquid_eff_diam_land(i,j,k) = 2.0*(1.0e6)*  &
                                 (3.0*(pfull(i,j,k)/    &
                            (Param%rdgas*temp(i,j,k)))*cuql(i,j,k)/   &
                     (4*Param%pie*Param%dens_h2o*Param%n_land))**(1./3.) 
                  cell_droplet_number_land(i,j,k) = Param%n_land/  &
                                (pfull(i,j,k)/(Param%rdgas*temp(i,j,k)))
                endif
              else
                cell_liquid_eff_diam_land(i,j,k) = 0.0
                cell_droplet_number_land(i,j,k) = 0.0
              endif

!---------------------------------------------------------------------
!    if any fraction of the grid box is over the ocean and the grid
!    point is more than delz_ocean above cloud base, define the 
!    effective cloud drop diameter for that portion of the box in terms
!    of r_conv_ocean.
!---------------------------------------------------------------------
              if (land(i,j) < 1.0) then
                if (cell_delp(i,j,k) >= cell_ocean_ref_delp(i,j)) then 
                  cell_liquid_eff_diam_ocean(i,j,k) =     &
                                                 2.0*Param%r_conv_ocean
                  cell_droplet_number_ocean(i,j,k) =  3.0*cuql(i,j,k)/ &
                                   (4.0*Param%pie*Param%dens_h2o*    &
                                       (Param%r_conv_ocean*1.0e-06)**3)
                  cell_droplet_number_ocean(i,j,k) =  &
                        cell_droplet_number_ocean(i,j,k)*pfull(i,j,k)/&
                              (Param%rdgas*temp(i,j,k))
                else
                  cell_liquid_eff_diam_ocean(i,j,k) = 2.0*(1.0e6)*  &
                         (3.0*(pfull(i,j,k)/     &
                               (Param%rdgas*temp(i,j,k)))*cuql(i,j,k)/  &
                    (4*Param%pie*Param%DENS_H2O*Param%n_ocean))**(1./3.)
                  cell_droplet_number_ocean(i,j,k) = Param%n_ocean/  &
                               (pfull(i,j,k)/(Param%rdgas*temp(i,j,k)))
                endif
              else
                cell_liquid_eff_diam_ocean(i,j,k) = 0.0
                cell_droplet_number_ocean(i,j,k) = 0.0
              endif

!---------------------------------------------------------------------
!    define the effective diameter for the grid box as the weighted av-
!    erage of the diameters over the land and ocean portions of the box.
!---------------------------------------------------------------------
              cell_liquid_eff_diam(i,j,k) =                    &
                       land(i,j) *cell_liquid_eff_diam_land(i,j,k)   + &
                (1.0 - land(i,j))*cell_liquid_eff_diam_ocean(i,j,k) 
              cell_droplet_number (i,j,k) =                    &
                       land(i,j) *cell_droplet_number_land(i,j,k)   + &
                (1.0 - land(i,j))*cell_droplet_number_ocean(i,j,k) 

!---------------------------------------------------------------------
!    when there is no liquid in the box, set the effective diameter to
!    10 microns.
!---------------------------------------------------------------------
            else
              cell_liquid_eff_diam(i,j,k) = 10.0
              cell_droplet_number(i,j,k) = 0.
            endif  ! (cuql > 1.0e-11)
          end do
        end do
      end do

!--------------------------------------------------------------------
!    limit the liquid droplet sizes to be between 8.401 and 33.199
!    microns, the limits for which the slingo parameterization for
!    radiative properties of cloud drops is applicable.
!--------------------------------------------------------------------
      if (Nml%use_memphis_size_limits) then
        cell_liquid_eff_diam = MAX(8.401, cell_liquid_eff_diam)
        cell_liquid_eff_diam = MIN(33.199, cell_liquid_eff_diam)
      endif

!--------------------------------------------------------------------
!    if this is a diagnostics column, output the grid box effective
!    size, as well as the over land and over ocean values which were
!    used to define it.
!--------------------------------------------------------------------
      if (Col_diag%in_diagnostics_window) then
        do n=1,Col_diag%ncols_in_window
          do j=1,jsize
            do i=1,isize
              if (j == Col_diag%j_dc(n) .and. i == Col_diag%i_dc(n)) then
                do k=1,nlev_lsm            
                  if (cuql(i,j,k) > 0.0) then
                    write (Col_diag%unit_dc(n), '(a, i5    )') &
                         'k', k
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                            ' cell_liquid_eff_diam',  &
                                 cell_liquid_eff_diam(i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                            ' cell_liquid_eff_diam_land',  &
                                 cell_liquid_eff_diam_land(i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                           ' cell_liquid_eff_diam_ocean',  &
                                 cell_liquid_eff_diam_ocean(i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                            ' cell_droplet_number',  &
                                 cell_droplet_number (i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                            ' cell_droplet_number_land',  &
                                 cell_droplet_number_land(i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                           ' cell_droplet_number_ocean',  &
                                 cell_droplet_number_ocean(i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                           ' cuql     ',  &
                                 cuql     (i,j,k)
                    write (Col_diag%unit_dc(n), '(a, e22.12)') &
                           ' cual     ',  &
                                    cual     (i,j,k)
                  endif
                end do
              endif
            end do
          end do
        end do
      endif

!--------------------------------------------------------------------


end subroutine don_r_define_cell_liquid_size_k


!#####################################################################

subroutine don_r_donner_deep_sum_k  &
         (isize, jsize, nlev_lsm, Param, Nml, Initialized, xliq, &
          xice, cual, ampta1, cuql, cuqi, dgeice,   &
          cell_liquid_eff_diam, Don_rad, ermesg, error)

!------------------------------------------------------------------
!    subroutine donner_deep_sum stores the cloud amount and particle 
!    size fields for the convective cells and the mesoscale anvil clouds
!    associated with the donner_deep convection parameterization. 
!------------------------------------------------------------------

use donner_types_mod, only : donner_param_type, donner_nml_type, &
                             donner_initialized_type, donner_rad_type

implicit none

!------------------------------------------------------------------
integer,                      intent(in)    :: isize, jsize, nlev_lsm
type(donner_param_type),      intent(in)    :: Param
type(donner_nml_type),        intent(in)    :: Nml      
type(donner_initialized_type),                     &
                              intent(in)    :: Initialized
real, dimension(isize,jsize,nlev_lsm),              &
                              intent(in)    :: xliq, xice, cual, cuql, &
                                               cuqi, dgeice,  &
                                               cell_liquid_eff_diam
real, dimension(isize,jsize), intent(in)    :: ampta1
type(donner_rad_type),        intent(inout) :: Don_rad
character(len=*),             intent(out)   :: ermesg
integer,                      intent(out)   :: error
                                                            
!------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie        first and last values of i index values of points 
!                   in this physics window (processor coordinates)
!     js, je        first and last values of j index values of points 
!                   in this physics window (processor coordinates)
!     xliq          mesoscale liquid water content [ kg(h2o) / kg(air) ]
!     xice          mesoscale ice content [ kg(h2o) / kg(air) ]
!     cual          cloud fractional area of convective system
!                   (vclouds plus anvil) [ fraction ]
!     ampta1        mesoscale cloud fraction (anvil) [ fraction ]
!     cuql          cell liquid water content [ kg(h2o) / kg(air) ]
!     cuqi          cell ice content [ kg(h2o) / kg(air) ]
!     cell_liquid_eff_diam
!                   cell liquid droplet effective diameter [ microns ]
!     dgeice        ice crystal generalized effective size [ microns ]
!
!--------------------------------------------------------------------


!--------------------------------------------------------------------
!   local variables:

      real, dimension(isize, jsize, nlev_lsm)  ::   meso_area
      integer :: i, j, k

!--------------------------------------------------------------------
!   local variables:
!
!        meso_area      fractional area of anvil [ fraction ]
!        i,j,k          do-loop indices
!
!--------------------------------------------------------------------

       ermesg= ' ' ; error = 0

!--------------------------------------------------------------------
!    if the cloud data from donner_deep_mod that is to be passed to
!    the radiation package is to be time-averaged, increment the counter
!    of the number of time levels that are included in the sum. if the
!    data is not time averaged, set the counter to 1.
!--------------------------------------------------------------------
      if (Nml%do_average) then
        Don_rad%nsum(:,:) = Don_rad%nsum(:,:) + 1
      else
        Don_rad%nsum(:,:) = 1
      endif
 
!--------------------------------------------------------------------
!    define mesoscale anvil area at each level.
!--------------------------------------------------------------------
      do k=1,nlev_lsm            
        do j=1,jsize
          do i=1,isize
            if (xice(i,j,k) == 0.0) then
              meso_area(i,j,k) = 0.0
            else
             meso_area(i,j,k) = MAX (0.0, ampta1(i,j))
            endif
            if (xliq(i,j,k) /= 0.0) then
              ermesg = ' liquid water present in anvil -- not&
                                           & currently allowed'
              error = 1
              return
            endif
          end do
        end do
      end do

!----------------------------------------------------------------------
!    define the mesoscale anvil properties needed by the radiation 
!    package (cloud fraction, liquid amount, ice amount, liquid droplet 
!    size, ice effective size) for the case where the fields are to 
!    be time-averaged.
!----------------------------------------------------------------------
      if (Nml%do_average) then
        Don_rad%meso_cloud_frac(:,:,:) =         &
                        Don_rad%meso_cloud_frac(:,:,:) + meso_area(:,:,:)
        Don_rad%meso_liquid_amt(:,:,:) = &
                             Don_rad%meso_liquid_amt(:,:,:) + xliq(:,:,:)
        Don_rad%meso_ice_amt(:,:,:)         =   &
                                Don_rad%meso_ice_amt(:,:,:) + xice(:,:,:)
        Don_rad%meso_liquid_size(:,:,:) = &
                                    Don_rad%meso_liquid_size(:,:,:) + &
                                          Nml%meso_liquid_eff_diam_input
        Don_rad%meso_ice_size(:,:,:) = &
                         Don_rad%meso_ice_size(:,:,:) + dgeice(:,:,:)

!----------------------------------------------------------------------
!    define the mesoscale anvil properties needed by the radiation 
!    package (cloud fraction, liquid amount, ice amount, liquid droplet
!    size, ice effective size) for the case where the fields are 
!    not time-averaged.
!----------------------------------------------------------------------
      else
        Don_rad%meso_cloud_frac(:,:,:)  = meso_area(:,:,:)
        Don_rad%meso_liquid_amt(:,:,:)  = xliq(:,:,:)
        Don_rad%meso_ice_amt(:,:,:)     = xice(:,:,:)
        Don_rad%meso_liquid_size(:,:,:) = Nml%meso_liquid_eff_diam_input
        Don_rad%meso_ice_size(:,:,:)    = dgeice(:,:,:)
      endif

!----------------------------------------------------------------------
!    define the cell properties needed by the radiation package (cloud 
!    fraction, liquid amount, ice amount, liquid droplet size, ice eff- 
!    ective size) for the case where the fields are to be time-averaged.
!----------------------------------------------------------------------
      if (Nml%do_average) then
        Don_rad%cell_cloud_frac(:,:,:) = &
                       Don_rad%cell_cloud_frac(:,:,:) + &
                             MAX (0.0, cual(:,:,:) - meso_area(:,:,:) )
        Don_rad%cell_liquid_amt(:,:,:) = &
                   Don_rad%cell_liquid_amt(:,:,:) + cuql(:,:,:)
        Don_rad%cell_ice_amt(:,:,:) = &
                            Don_rad%cell_ice_amt(:,:,:) + cuqi(:,:,:)

!----------------------------------------------------------------------
!     cell liquid size may be either specified via a namelist variable
!     or defined based on the bower parameterization.
!----------------------------------------------------------------------
        if (Initialized%do_input_cell_liquid_size) then
          Don_rad%cell_liquid_size(:,:,:) = &
                              Don_rad%cell_liquid_size(:,:,:) +      &
                                           Nml%cell_liquid_eff_diam_input
        else if (Initialized%do_bower_cell_liquid_size) then
          Don_rad%cell_liquid_size(:,:,:) = &
                 Don_rad%cell_liquid_size(:,:,:) + cell_liquid_eff_diam
        endif

!----------------------------------------------------------------------
!     cell ice size may be either specified using a default value or
!     an input value supplied via the namelist.
!----------------------------------------------------------------------
        if (Initialized%do_default_cell_ice_size) then
          Don_rad%cell_ice_size(:,:,:) = &
                                Don_rad%cell_ice_size(:,:,:) +    &
                                          Param%cell_ice_geneff_diam_def
        else if (Initialized%do_input_cell_ice_size) then
          Don_rad%cell_ice_size(:,:,:) = &
                              Don_rad%cell_ice_size(:,:,:) +      &
                                           Nml%cell_ice_geneff_diam_input
        endif

!----------------------------------------------------------------------
!    define the cell properties needed by the radiation package (cloud 
!    fraction, liquid amount, ice amount, liquid droplet size, ice eff- 
!    ective size) for the case where the fields are not time-averaged.
!----------------------------------------------------------------------
      else
        Don_rad%cell_cloud_frac(:,:,:) = &
                             MAX (0.0, cual(:,:,:) - meso_area(:,:,:) )
        Don_rad%cell_liquid_amt(:,:,:) = cuql(:,:,:)
        Don_rad%cell_ice_amt(:,:,:)    = cuqi(:,:,:)

!----------------------------------------------------------------------
!     cell liquid size may be either specified via a namelist variable
!     or defined based on the bower parameterization.
!----------------------------------------------------------------------
        if (Initialized%do_input_cell_liquid_size) then
          Don_rad%cell_liquid_size(:,:,:) =       &
                                          Nml%cell_liquid_eff_diam_input
        else if (Initialized%do_bower_cell_liquid_size) then
          Don_rad%cell_liquid_size(:,:,:) = cell_liquid_eff_diam
        endif

!----------------------------------------------------------------------
!     cell ice size may be either specified using a default value or
!     an input value supplied via the namelist.
!----------------------------------------------------------------------
        if (Initialized%do_default_cell_ice_size) then
          Don_rad%cell_ice_size(:,:,:)  = Param%cell_ice_geneff_diam_def
        else if (Initialized%do_input_cell_ice_size) then
          Don_rad%cell_ice_size(:,:,:) = Nml%cell_ice_geneff_diam_input
        endif
      endif

!--------------------------------------------------------------------


end subroutine don_r_donner_deep_sum_k






              module donner_types_mod

character(len=128)   :: version = '$Id: donner_types.F90,v 13.0 2006/03/28 21:08:57 fms Exp $'
public

# include "donner_types.h"






            end module donner_types_mod



!VERSION NUMBER:
!  $Id: donner_utilities_k.F90,v 17.0.4.1 2010/03/17 20:27:08 wfc Exp $

!module donner_utilities_inter_mod

!#include "donner_utilities_interfaces.h"

!end module donner_utilities_inter_mod



!module donner_types_mod

!#include "donner_types.h"

!end module donner_types_inter_mod


!#####################################################################

subroutine don_u_set_column_integral_k   &
         (nk, x_in, ptop, pbot, int_value, p_in, intgl_in, intgl_out, &
          x_out, ermesg, error)

!--------------------------------------------------------------------
!    subroutine don_u_set_column_integral_k modifies the input
!    profile x_in of size nk with column integral intgl_in to produce an
!    output profile x_out, also of size nk, whose column integral 
!    intgl_out has the specified value int_value. 
!    the integral constraint is satisfied by defining a constant cont-
!    ribution to the column integral between pbot and ptop, which 
!    balances the contribution from the rest of the profile. currently
!    the x_in profile has non-zero values only above ptop; if x_in has
!    non-zero values below ptop, the algorithm must be changed in order
!    to work properly.
!    NOTE: currently pbot is by default the surface pressure. this needs
!    to be generalized.
!    any error message is returned in ermesg.
!    "Verav notes 1/7/04" (available from Leo Donner) explain this 
!    routine in more detail, especially the procedures used to enforce 
!    the integral constraint.
!--------------------------------------------------------------------

implicit none

integer,               intent(in)    ::  nk
real, dimension(nk),   intent(in)    ::  x_in
real,                  intent(in)    ::  ptop, pbot, int_value        
real, dimension(nk+1), intent(in)    ::  p_in
real,                  intent(out)   ::  intgl_in, intgl_out
real, dimension(nk),   intent(out)   ::  x_out
character(len=*),      intent(out)   ::  ermesg
integer,               intent(out)   ::  error

!--------------------------------------------------------------------
!  intent(in) variables:
!  
!     nk        size of input profile
!     x_in      profile on lo-res model grid whose column integral 
!               is adjusted
!     ptop      pressure at top of region where integrand is 
!               adjusted [ Pa ] 
!     pbot      pressure at bottom of region where integrand is
!               adjusted[ Pa ]
!     int_value value desired for column integral of output field
!     p_in      lo-res model interface pressure levels [ Pa ]
!
!  intent(out) variables:
!
!     intgl_in  column integral of input field x_in [ units of x_in ]
!     intgl_out column integral of output field x_out [ units of x_in ]
!     x_out     vertical profile of x_in, after adjustment of values
!               at levels between pbot and ptop to produce column 
!               integral with value of int_value 
!     ermesg    error message, if error is encountered
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

     real    :: int_above !  contribution to column integral from layers
                          !  fully above adjustment region
     real    :: int_needed_below 
                          !  integrand contribution from the adjustment
                          !  layer that is required to balance the 
                          !  remainder of the profile
     real    :: int_below !  contribution to column integral after 
                          !  adjustment that comes from layers fully 
                          !  within the adjustment layer
     integer :: k         !  do-loop index


!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!----------------------------------------------------------------------
!    obtain the total column integrand (column) and the partial integ-
!    rand from layers completely above the adjustment layer (int_above) 
!    of the input quantity (x_in). 
!----------------------------------------------------------------------
      intgl_in = 0.
      int_above = 0.
      do k=1,nk              
        intgl_in = intgl_in + x_in(k)*(p_in(k) - p_in(k+1))
        if (p_in(k) <= ptop)  then
          int_above = int_above + x_in(k)*(p_in(k) - p_in(k+1))
        endif
      end do

!----------------------------------------------------------------------
!    define the value of the integrand needed from the adjustment layer
!    (int_needed_below). it is the negative of the column sum divided 
!    by the total delta p between pbot and ptop.
!----------------------------------------------------------------------
      int_needed_below = int_value - intgl_in/(pbot - ptop)

!----------------------------------------------------------------------
!    begin loop assigning new value to output variable in layers
!    completely or partially in the adjustment layer.
!----------------------------------------------------------------------
      do k=1,nk              

!---------------------------------------------------------------------
!    case of layer being completely in adjustment layer. define the 
!    output variable value as int_needed_below.
!---------------------------------------------------------------------
        if (p_in(k+1) >= ptop) then
          x_out(k) = int_needed_below
         
!---------------------------------------------------------------------
!    case of layer straddling top of adjustment layer.
!---------------------------------------------------------------------
        else if (p_in(k+1) < ptop )  then

!----------------------------------------------------------------------
!    define the amount of the needed adjustment layer value that has 
!    been assigned to the layers fully in the adjustment layer 
!    (int_below).
!----------------------------------------------------------------------
          int_below = int_needed_below*(pbot - p_in(k))

!----------------------------------------------------------------------
!    define the portion of the column sum which must be assigned to 
!    this layer straddling the top of the adjustment layer in order
!    to obtain a value of int_value for the column integral; ie, that 
!    which is needed to balance the contributions from above (int_above)
!    and from below (int_below) this layer.
!----------------------------------------------------------------------
          x_out(k) = (int_value -int_above - int_below)/  &
                                                  (p_in(k) - p_in(k+1)) 

!---------------------------------------------------------------------
!    case of layer completely above adjustment layer. define the output
!    field as equal to the input field at this and all higher levels; 
!    then exit the loop. 
!---------------------------------------------------------------------
          x_out(k+1:) = x_in(k+1:)
          exit
        endif
      end do

!---------------------------------------------------------------------
!    recalculate the column sum of the conservative quantity. it should
!    now be of order machine roundoff. return value to calling routine.
!---------------------------------------------------------------------
      intgl_out = 0.
      do k=1,nk              
        intgl_out = intgl_out + x_out(k)*(p_in(k) - p_in(k+1))
      end do

!----------------------------------------------------------------------


end subroutine don_u_set_column_integral_k

!#####################################################################

subroutine don_u_map_hires_c_to_lores_c_k   &
         (n_gcm, n_clo, x_clo, p_clo, ptop, p_gcm, x_gcm, intgl_clo,  &
          intgl_gcm, ermesg, error)

!--------------------------------------------------------------------
!    subroutine don_u_map_hires_c_to_lores_c_k maps the vertical
!    profile between cloud base and and a specified upper pressure level
!    (ptop) of a variable (x_clo) of size n_clo on the cloud-model 
!    vertical grid (p_clo) to a GCM vertical grid (p_gcm) of size 
!    n_gcm. the output profile is x_gcm.
!    vertical integrals on the cloud grid (intgl_clo) and on the 
!    GCM grid (intgl_gcm) are also returned, so that the profile 
!    mapping may be shown to be conservative.
!    any error message is returned in ermesg.
!    "Verav notes 1/7/04" (available from Leo Donner) explain this 
!    routine in more detail. 
!    The routine can handle grid thicknesses of arbitrary size for
!    both the cloud grid and GCM grid. there is no restriction as
!    to the relative sizes of the grids.
!--------------------------------------------------------------------
!    GCM grid:
!     
!     -------------- p_gcm(n_gcm+1)
!     -------------- x_gcm(n_gcm)
!     -------------- p_gcm(n_gcm-1)
!           ...
!     -------------- p_gcm(k+1)
!     -------------- p_gcm(k)
!     -------------- p_gcm(k-1)
!           ...
!     -------------- p_gcm(2)
!     -------------- x_gcm(1)
!     -------------- p_gcm(1)
!
!     Cloud-Model grid:
!
!     -------------- p_clo(n_clo)=pcloha(n_clo) (cloud top)
!     -------------- p_cloha(n_clo-1)
!     -------------- p_clo(n_clo-1)
!           ...   
!     -------------- p_clo(k2)
!     -------------- p_cloha(k2-1)
!     -------------- p_clo(k2-1)
!           ...
!     -------------- p_clo(2)
!     -------------- p_cloha(1)
!     -------------- p_clo(1)  (cloud base)
!--------------------------------------------------------------------   


implicit none

integer,                  intent(in)  :: n_gcm, n_clo
real, dimension(n_clo),   intent(in)  :: x_clo, p_clo
real,                     intent(in)  :: ptop
real, dimension(n_gcm+1), intent(in)  :: p_gcm
real, dimension(n_gcm),   intent(out) :: x_gcm
real,                     intent(out) :: intgl_clo, intgl_gcm
character(len=*),         intent(out) :: ermesg
integer,                  intent(out) :: error

!--------------------------------------------------------------------
!   intent(in) variables:
!
!        n_gcm        number of layers in GCM 
!        n_clo        number of layers in cloud model
!        x_clo        vertical profile of variable on cloud-model grid
!        p_clo        cloud-model pressure profile
!        ptop         pressure denoting top of region of interest [ Pa ]
!        p_gcm        pressure half levels in GCM [ Pa ]
!
!    intent(out) variables:
!
!        x_gcm        vertical profile of variable on GCM vertical grid
!        intgl_clo    vertical integral of variable on cloud-model grid
!        intgl_gcm    vertical integral of variable on GCM grid
!        ermesg       error message, if error is encountered
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:

      real, dimension(n_clo)  ::  pcloha
      real                    ::  rint, p_upper, p_lower, ptopa 
      integer                 ::  k2start
      integer                 ::  k, k2

!----------------------------------------------------------------------
!  local variables:
!
!     pcloha           pressures at mid-layers in cloud grid [ Pa ]
!     rint             accumulates pressure-weighted sum of input 
!                      variable over the cloud-model layers which over-
!                      lap a given GCM grid layer
!     p_upper          pressure at upper limit (farthest from ground) 
!                      of the current sub-layer [ Pa ]
!     p_lower          pressure at lower limit (closest to ground) of
!                      the current sub-layer [ Pa ]
!     ptopa            uppermost (farthest from ground) pressure value 
!                      on cloud grid
!     k2start          cloud-model vertical index of lowest cloud-model
!                      layer overlapping the current or next gcm layer
!     k, k2            do-loop indices
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    define the lowest k index of the cloud model which overlaps the
!    first gcm layer (k2start). initialize the integral over pressure 
!    of the output field on the gcm grid (intgl_gcm). define the lowest
!    pressure at which the fields will have non-zero values as the 
!    pressure at the top of the cloud model (ptopa). define the 
!    bottommost pressure at which cloud is present (p_lower) as the 
!    pressure at cloud base.
!--------------------------------------------------------------------

      k2start  = 1
      intgl_gcm = 0.
      ptopa = MAX (p_clo(n_clo), ptop)
      p_lower = p_clo(1) 

!--------------------------------------------------------------------
!    define the interface pressures on the cloud grid. cloud base is 
!    defined to be at the midpoint of a cloud layer.
!--------------------------------------------------------------------
      do k2=1,n_clo-1
        pcloha(k2) = 0.5*(p_clo(k2) + p_clo(k2+1))
      end do
      pcloha(n_clo) = p_clo(n_clo)

!--------------------------------------------------------------------
!    march upward through gcm model layers until cloud base is found. 
!    calculate the output profile on the gcm grid. 
!--------------------------------------------------------------------
      do k=1,n_gcm

!--------------------------------------------------------------------
!    check if this gcm layer has any overlap with the cloud. if it does,
!    initialize the output field in this layer to be 0.0.
!--------------------------------------------------------------------
        if (p_gcm(k) > ptopa .and. p_lower > p_gcm(k+1)) then
          rint = 0.

!--------------------------------------------------------------------
!    march through the cloud model layers which overlap this gcm
!    layer.
!--------------------------------------------------------------------
          do k2=k2start,n_clo-1

!---------------------------------------------------------------------
!    define the topmost pressure in this gcm layer for which the 
!    current cloud model layer value will apply (p_upper). it will be 
!    the larger of the cloud top pressure, the pressure at the top of
!    the gcm layer, or the pressure at the top interface of the current
!    cloud layer.
!---------------------------------------------------------------------
            p_upper = MAX (ptopa, p_gcm(k+1), pcloha(k2))

!---------------------------------------------------------------------
!    define the contribution to the current gcm layer from this cloud 
!    layer, weighted by the pressure depth over which it applies.     
!---------------------------------------------------------------------
            rint = rint + x_clo(k2)*(p_lower - p_upper)

!--------------------------------------------------------------------
!    define the pressure at the bottom of the next layer to be 
!    processed as the pressure at the top of the current layer. if 
!    either the next gcm layer or cloud top has been reached, save the 
!    cloud model layer index and exit this loop. otherwise, there are
!    additional cloud model layer(s) contributing to the integral at
!    this GCM level. Cycle through the loop, adding the remaining
!    contributions.
!--------------------------------------------------------------------
            p_lower = p_upper
            if (p_upper /= pcloha(k2)) then
              k2start = k2
              exit
            endif
          end do

!--------------------------------------------------------------------
!    define the output variable at this gcm level and add the contrib-
!    ution to the integral from this layer to the integrand.
!--------------------------------------------------------------------
          x_gcm(k) = rint/(p_gcm(k) - p_gcm(k+1))
          intgl_gcm = intgl_gcm + rint

!---------------------------------------------------------------------
!    if this gcm layer does not overlap the cloud, define its value to
!    be 0.0.
!---------------------------------------------------------------------
        else
          x_gcm(k) = 0.
        endif   
      end do

!--------------------------------------------------------------------
!    evaluate integral over pressure at cloud-model resolution.
!--------------------------------------------------------------------
      p_upper = max (pcloha(1), ptopa)
      intgl_clo = x_clo(1)*(p_clo(1) - p_upper)
      do k2=1,n_clo 
        p_upper = max (pcloha(k2+1), ptopa)
        intgl_clo = intgl_clo + x_clo(k2+1)*(pcloha(k2) - p_upper)
        if (pcloha(k2+1) <= ptopa) exit
      end do

!--------------------------------------------------------------------


end subroutine don_u_map_hires_c_to_lores_c_k



!#####################################################################

subroutine don_u_compare_integrals_k    &
         (hi_res_intgl, lo_res_intgl, diag_unit, ermesg, error)

!---------------------------------------------------------------------
!    subroutine don_u_compare_integrals_k determines if two 
!    input vertical integrals, computed on different grids may be 
!    considered equal, after allowing for the roundoff differences 
!    inherent in their calculation.
!    any error message is returned in ermesg.
!---------------------------------------------------------------------

implicit none

real,               intent(in)  :: hi_res_intgl, lo_res_intgl
integer,            intent(in)  :: diag_unit 
character(len=*),   intent(out) :: ermesg
integer,            intent(out) :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!        hi_res_intgl    integral calculated on higher resolution 
!                        vertical grid
!        lo_res_intgl    integral calculated on lower resolution 
!                        vertical grid
!        diag_unit       unit number of column diagnostics file to 
!                        which output message is written
!
!   intent(out) variables:
!
!        ermesg          error message, if error is encountered
!
!----------------------------------------------------------------------
      
!---------------------------------------------------------------------
!   local variables:

      integer    :: inteq  ! flag indicating status of integral equality

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!---------------------------------------------------------------------
!    call don_u_integrals_are_equal_k to determine the 
!    equality of hi_res_intgl and lo_res_intgl. the return flag inteq
!    will be 0 if the integrals may be considered equal. if it is 
!    non-zero, then it may indicate that the mapping of vertical 
!    integrals between the hi- and lo-resolution grids should be exam-
!    ined, or that the roundoff in the offending integral may simply be 
!    slightly larger than the current tolerance, perhaps due to the 
!    nature of the integral.
!---------------------------------------------------------------------
      call don_u_integrals_are_equal_k    &
                      (hi_res_intgl, lo_res_intgl, ermesg, error, inteq)
 
!----------------------------------------------------------------------
!    determine if an error message was returned from the kernel routine.
!    if so, return to calling program where it will be processed.
!----------------------------------------------------------------------
      if (error /= 0 ) return

!-----------------------------------------------------------------------
!    output a warning message to the column diagnostics output file if
!    the integral equality test produces suspicious results.
!-----------------------------------------------------------------------
      if (inteq /= 0) then
        write (diag_unit, '(a)')  &
           'WARNING: cloud model and ls model intgls differ &
                     &non-trivially  -- perhaps significantally ?'
      endif

!---------------------------------------------------------------------


end subroutine don_u_compare_integrals_k 


!######################################################################

subroutine don_u_apply_integral_source_k      &
         (nk, x_in, ptop, pbot, src, p_in, i_in, i_out, x_out, ermesg, error)

!----------------------------------------------------------------------
!    subroutine don_u_apply_integral_source_k adds a specified
!    value src to the input field x_in of size nk on a pressure grid 
!    p_in between pressure levels pbot and ptop, resulting in a change 
!    of column integral of the field from i_in to i_out, and producing 
!    the output field x_out.
!    NOTE: currently pbot is by default the surface pressure. this needs
!    to be generalized.
!    any error message is returned in ermesg.
!----------------------------------------------------------------------

implicit none

integer,               intent(in)    :: nk
real, dimension(nk),   intent(in)    :: x_in
real,                  intent(in)    :: ptop, pbot, src
real, dimension(nk+1), intent(in)    :: p_in
real,                  intent(out)   :: i_in, i_out
real, dimension(nk),   intent(out)   :: x_out
character(len=*),      intent(out)   :: ermesg
integer,               intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      nk        size of input profile
!      x_in      variable to which the integral source src is to
!                be applied [ units of x_in ]
!      ptop      topmost pressure at which src is applied [ Pa ] 
!      pbot      bottommost pressure at which src is applied [ Pa ] 
!      src       integral source to be applied to variable x_in
!      p_in      interface pressure levels of grid of x_in [ Pa ]
!
!   intent(out) variables:
!
!      i_in      column integral of input variable x_in 
!                [ units of x_in * Pa ]
!      i_out     column integral of output variable x_out
!                [ units of x_in * Pa ]
!      x_out     variable field after the source integral is applied
!                [ units of x_in ]
!      ermesg    error message, if error is encountered
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
      integer   :: k      ! do_loop index

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    compute the column integral (i_in) of the input field x_in.
!---------------------------------------------------------------------
      i_in = 0.
      do k=1,nk              
        i_in = i_in + x_in(k)*(p_in(k) - p_in(k+1))
      end do

!----------------------------------------------------------------------
!    apply the integral source src to each layer in the specified 
!    region. for layers fully included, add src to the existing value. 
!    for the layer containing the top of the specified region, add the 
!    value of src appropriately pressure-weighted. NOTE: this source WAS
!    applied ONLY to the layer straddling the top of the region; it was
!    not applied below cloud base. I HAVE MODIFIED THIS CODE SO THAT THE
!    VALUE IS APPLIED FROM SFC TO TOP OF SPECIFIED REGION (CLOUD BASE)
!    IS THIS CORRECT AND WHAT WAS INTENDED ?? 
!----------------------------------------------------------------------
      do k=1,nk              
        if (p_in(k+1) >= ptop ) then                   
          x_out(k) = x_in(k) + src
        else if (p_in(k+1) < ptop .and. p_in(k) > ptop)  then
          x_out(k) = x_in(k) + (src/(p_in(k) - p_in(k+1))*  &
                                           (p_in(k) - ptop))
          x_out(k+1:) = x_in(k+1:)
          exit
        endif
      end do

!---------------------------------------------------------------------
!    compute the column integral (i_out) of the output field x_out.
!---------------------------------------------------------------------
      i_out = 0.
      do k=1,nk              
        i_out = i_out + x_out(k)*(p_in(k) - p_in(k+1))
      end do

!--------------------------------------------------------------------



end subroutine don_u_apply_integral_source_k


!#####################################################################

subroutine don_u_integrals_are_equal_k    &
         (x, y, ermesg, error, inteq)

!--------------------------------------------------------------------
!    subroutine don_u_integrals_are_equal_k determines if two 
!    integrals x and y are within a roundoff tolerance eps_i of one 
!    another. it computes the difference x - y, and returns inteq, which
!    is given a value of -10 if (x - y) < -eps_i, a value of 10 if 
!    (x - y) > eps_i, and a value of 0 if ABS (x - y) < eps_i. 
!    any error message is returned in ermesg.
!--------------------------------------------------------------------

implicit none

real,               intent(in)   :: x, y
character(len=*),   intent(out)  :: ermesg
integer,            intent(out)  :: error, inteq

!---------------------------------------------------------------------
!   intent (in) variables:
!
!          x        first variable
!          y        second variable
!
!   intent(out) variables:
!
!          ermesg    error message, if error is encountered
!          inteq      ==   0 if x = y, within a tolerance of eps_i
!                     ==  10 if x > y by at least eps_i
!                     == -10 if x < y by at least eps_i
!
!---------------------------------------------------------------------
      
real, PARAMETER  :: eps_i = 1.0e-12 ! roundoff tolerance for equality of
                                    ! two vertical integrals; if the 
                                    ! magnitude of the numerical differ-
                                    ! ence between two integrals is 
                                    ! smaller than eps_i, they are 
                                    ! assumed equal by function 
                                    ! integrals_are_equal.

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    if the integral values are "large", then compare the ratio of
!    integral difference to integral value to the tolerance eps_i, 
!    since the difference itself could be much larger than the toler-
!    ance and still be roundoff. 
!--------------------------------------------------------------------
      if (ABS(x) > 1.0) then

!--------------------------------------------------------------------
!    define integrals_are_equal dependent on the relationship between 
!    (x - y) and eps_i.
!--------------------------------------------------------------------
        if ( (x - y)/ ABS(x) > eps_i) then
          inteq = 10
        else if ( (x - y)/ABS(x) < -eps_i) then
          inteq = -10
        else
          inteq = 0
        endif

!--------------------------------------------------------------------
!    if the integral values are "small", simply compare their difference
!    to the tolerance, since as the integral magnitudes approach zero,
!    the ratio of difference / magnitude could become quite large and 
!    still only represent roundoff error. 
!--------------------------------------------------------------------
      else

!--------------------------------------------------------------------
!    define integrals_are_equal dependent on the relationship between 
!    (x - y) and eps_i.
!--------------------------------------------------------------------
        if ( (x - y) > eps_i) then
          inteq = 10
        else if ( (x - y) < -eps_i) then
          inteq = -10
        else
          inteq = 0
        endif
      endif

!-------------------------------------------------------------------


end subroutine don_u_integrals_are_equal_k





!#####################################################################



!######################################################################

subroutine don_u_map_hires_i_to_lores_c_k    &
         (n_lo, intgl_hi, pbot, ptop, p_lo, x_lo, ermesg, error)

!------------------------------------------------------------------
!    subroutine don_u_map_hires_i_to_lores_c_k assigns
!    an integral quantity defined on a high-res grid (intgl_hi), valid 
!    over a specified pressure depth (pbot, ptop), to the elements of an 
!    array (x_lo) of size n_lo on a lower resolution grid (p_lo).
!    any error message is returned in ermesg.
!------------------------------------------------------------------

implicit none

integer,                  intent(in)     :: n_lo
real,                     intent(in)     :: intgl_hi, pbot, ptop
real, dimension(n_lo+1),  intent(in)     :: p_lo
real, dimension(n_lo),    intent(out)    :: x_lo
character(len=*),         intent(out)    :: ermesg
integer,                  intent(out)    :: error

!------------------------------------------------------------------
!   intent(in) variables:
!
!       n_lo       size of output profile x_lo
!       intgl_hi   input integral from hi-res model
!                  [ units of intgl_hi ]
!       pbot       pressure at bottom of integral's extent [ Pa ]
!       ptop       pressure at top of integral's extent  [ Pa ]
!       p_lo       lo-res model interface pressure levels [ Pa ]
!
!   intent(out) variables:
!
!       x_lo       values of integrand at lo-res model levels
!                  [ units of intgl_hi ]
!       ermesg     error message, if error is encountered
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!   local variables:
!
      integer :: k    ! do-loop index

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!---------------------------------------------------------------------
!    verify that the specified pressure limits are reasonable. if not,
!    define an error message and return.
!---------------------------------------------------------------------
      if ( pbot < ptop ) then
        ermesg = ' input pressure pbot is less than input pressure ptop'
        error = 1
        return
      endif

!---------------------------------------------------------------------
!    assign the proper value to each large-scale model level.
!---------------------------------------------------------------------
      do k=1,n_lo            

!---------------------------------------------------------------------
!    case of bottom of lo-res model layer being within the integral's 
!    specified region.
!---------------------------------------------------------------------
        if (pbot > p_lo(k))  then 

!---------------------------------------------------------------------
!    case of top of lo-res model layer being above the integral's
!    specfied topmost pressure. in such case all lo-res model levels 
!    above are assigned values of 0.0 and the loop exited.
!---------------------------------------------------------------------
          if (ptop >= p_lo(k))  then
            x_lo(k:) = 0.
            exit

!---------------------------------------------------------------------
!    case of lo-res model layer being completely within the integral's
!    specified region.
!---------------------------------------------------------------------
          else if ( ptop <  p_lo(k+1) )  then 
            x_lo(k) = intgl_hi

!---------------------------------------------------------------------
!    case of lo-res model layer extending above the top of the integ-
!    ral's specified region. in such case, only the portion of the
!    integral contained within the appropriate pressure fraction of
!    the lo-res model layer is assigned to the output field.
!---------------------------------------------------------------------
          else
            x_lo(k) = intgl_hi*(p_lo(k) - ptop)/(p_lo(k) - p_lo(k+1))
          endif

!---------------------------------------------------------------------
!    case of bottom of lo-res model layer being below the integral's
!    specified region.
!---------------------------------------------------------------------
        else

!---------------------------------------------------------------------
!    case of top of lo-res model layer being below the integral's
!    specified region. in this case, lo-res model layer is completely
!    outside the integral's range and is assigned a value of 0.0.
!---------------------------------------------------------------------
          if (pbot <= p_lo(k+1)) then
            x_lo(k) = 0.

!---------------------------------------------------------------------
!    case of bottom of lo-res model layer being below and top of lo-res
!    model layer being above integral's specified region. in such case,
!    only the portion of the integral contained within the appropriate 
!    pressure fraction of the lo-res model layer is assigned to the 
!    output field. values at levels above this are assigned values of
!    0.0 and the loop exited.
!---------------------------------------------------------------------
          else if (ptop >  p_lo(k+1))  then
            x_lo(k) = intgl_hi*(pbot - ptop)/(p_lo(k) - p_lo(k+1))
            x_lo(k+1:) = 0.
            exit

!---------------------------------------------------------------------
!    case of bottom of lo-res model layer being below bottom of 
!    integral's specified region and top of lo-res model layer being
!    below top of integral's specified region. in such case, only the 
!    portion of the integral contained within the appropriate pressure 
!    fraction of the lo-res model layer is assigned to the output field.
!---------------------------------------------------------------------
          else if (ptop <= p_lo(k+1) )  then
            x_lo(k) = intgl_hi*(pbot - p_lo(k+1))/(p_lo(k) - p_lo(k+1))
          endif
        endif
      end do

!--------------------------------------------------------------------



end subroutine don_u_map_hires_i_to_lores_c_k



!######################################################################


subroutine don_u_numbers_are_equal_k                    &
         (x, y, ermesg, error, numeq)

!--------------------------------------------------------------------
!    subroutine don_u_numbers_are_equal_k determines if two 
!    numbers x and y are within a roundoff tolerance eps_n of one 
!    another. it computes the difference x - y, and returns a value numeq
!    which is -10 if (x - y) < -eps_n, 10 if (x - y) > eps_n, and 0 if 
!    ABS (x - y) < eps_n. 
!    any error message is returned in ermesg.
!--------------------------------------------------------------------

implicit none

real,               intent(in)  :: x, y
character(len=*),   intent(out) :: ermesg
integer,            intent(out) :: error, numeq

!---------------------------------------------------------------------
!   intent (in) variables:
!
!          x       first variable
!          y       second variable
!
!   intent (out) variables:
!
!          ermesg  error message, if error is encountered
!          numeq   ==   0 if x = y, within a tolerance of eps_n
!                  ==  10 if x > y by at least eps_n
!                  == -10 if x < y by at least eps_n
!
!---------------------------------------------------------------------
      
real, PARAMETER  :: eps_n = 1.0e-13 ! roundoff tolerance for equality 
                                    ! of two real numbers; if the mag-
                                    ! nitude of the numerical difference
                                    ! between two numbers is smaller than
                                    ! eps_n, they are assumed equal by 
                                    ! function numbers_are_equal.


!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = '  ' ; error = 0

!--------------------------------------------------------------------
!    define numbers_are_equal based on the relationship between 
!    (x - y) and eps_n.
!--------------------------------------------------------------------
      if ( (x - y) > eps_n) then
        numeq = 10
      else if ( (x - y) < -eps_n) then
        numeq = -10
      else
        numeq = 0
      endif

!-------------------------------------------------------------------


end subroutine don_u_numbers_are_equal_k


!#####################################################################




!interface donner_utilities_map_lo_res_col_to_hi_res_col_k

!     subroutine donner_utilities_lo1d_to_hi1d_k     
!     subroutine donner_utilities_lo1d_to_hi0d_linear_k 
!     subroutine donner_utilities_lo1d_to_hi0d_log_k    

!end interface donner_utilities_map_lo_res_col_to_hi_res_col_k

subroutine don_u_lo1d_to_hi1d_k     &
         (n_lo, n_hi, x_lo, p_lo, p_hi, x_hi, ermesg, error)                

!------------------------------------------------------------------
!    subroutine don_u_lo1d_to_hi1d_k interpolates the input 
!    field x_lo of size n_lo on pressure grid p_lo to produce an output 
!    field x_hi of size n_hi on a pressure grid p_hi. 
!    NOTE: vertical index 1 is closest to the ground in all arrays
!    used here.
!    any error message is returned in ermesg.
!------------------------------------------------------------------
 
implicit none

integer,                  intent(in)    :: n_lo, n_hi
real, dimension(n_lo),    intent(in)    :: x_lo
real, dimension(n_lo+1),  intent(in)    :: p_lo
real, dimension(n_hi),    intent(in)    :: p_hi
real, dimension(n_hi),    intent(out)   :: x_hi
character(len=*),         intent(out)   :: ermesg
integer,                  intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     n_lo          size of lo-res profile
!     n_hi          size of hi-res profile
!     x_lo          field to be interpolated on lo-res pressure grid
!                   [ units of x_lo ]
!     p_lo          lo-res pressure grid [ Pa ]
!     p_hi          hi-res pressure grid [ Pa ]
!     
!  intent(out) variables:
!
!     x_hi          value of field at pressure p_hi
!                   [ units of x_lo ]
!     ermesg        error message, if error is encountered
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer :: kkstart            !  k index at which to start search
                                    !  for input field value
      integer :: k, kk              !  do-loop indices

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    define the k index in the low resolution grid (index 1 nearest
!    surface) at which to begin searching for the cape model pressure 
!    value.
!--------------------------------------------------------------------
      kkstart = 1

!-------------------------------------------------------------------
!    for each pressure level of the high resolution grid, find the low 
!    resolution pressure levels that bracket it. when found, use linear
!    interpolation to define the field value at the high resolution grid
!    pressure level. if it is beyond either end of the low resolution
!    grid, obtain a value at the high resolution pressure value by 
!    extrapolating the gradient at the low level grid boundary.
!----------------------------------------------------------------------
      do k=1,n_hi           

!--------------------------------------------------------------------
!    if the requested hi-res model pressure is greater than the lowest 
!    lo-res model pressure, obtain the field value at the hi-res pres-
!    sure by extrapolating the lo-res model gradient.
!---------------------------------------------------------------------
        if (p_hi(k) > p_lo(1)) then
          x_hi(k) = x_lo(1) + (p_hi(k) - p_lo(1))* &
                          ((x_lo(2) - x_lo(1))/(p_lo(2) - p_lo(1)))

!---------------------------------------------------------------------
!    if the requested hi-res model pressure is less than the highest 
!    lo-res model pressure, obtain the field value at the hi-res pres-
!    sure by extrapolating the lo-res model gradient.
!---------------------------------------------------------------------
        else if (p_hi(k) < p_lo(n_lo)) then
            x_hi(k) =  x_lo(n_lo) + (p_hi(k) - p_lo(n_lo))*   &
                            ((x_lo(n_lo) - x_lo(n_lo-1))/  &
                             (p_lo(n_lo) - p_lo(n_lo-1)))

!---------------------------------------------------------------------
!    if the requested hi-res model pressure level lies within the bounds
!    of the lo-res model pressure profile, march through the  lo-res
!    profile until the desired hi-res model pressure is reached. define
!    the hi-res field value by interpolating to the hi-res model pres-
!    sure. define the lo-res model starting level index to be used in
!    the search for the next desired hi-res pressure (kkstart), and 
!    exit the vertical loop.
!---------------------------------------------------------------------
        else
          do kk=kkstart,n_lo-1
            if (p_hi(k) >= p_lo(kk+1)) then
              x_hi(k) = x_lo(kk+1) + (p_hi(k) - p_lo(kk+1))* &
                             ((x_lo(kk+1) - x_lo(kk))/  &
                              (p_lo(kk+1) - p_lo(kk)))
              kkstart = kk
              exit
            endif
          end do
        endif
      end do

!---------------------------------------------------------------------


end subroutine don_u_lo1d_to_hi1d_k  


!#####################################################################

subroutine don_u_lo1d_to_hi0d_linear_k  &
         (n_lo, x_lo, p_lo, p_hi, x_hi, ermesg, error)


!--------------------------------------------------------------------
!    subroutine lo1d_to_hi0d linearly interpolates within the 1d input 
!    field x_lo on 1d pressure grid p_lo to determine a scalar output 
!    variable x_hi at pressure p_hi. 
!    NOTE: vertical index 1 is closest to the ground in all arrays
!    used here.
!------------------------------------------------------------------

integer,                 intent(in)    :: n_lo
real, dimension(n_lo),   intent(in)    :: x_lo
real, dimension(n_lo+1), intent(in)    ::  p_lo
real,                    intent(in)    :: p_hi
real,                    intent(out)   :: x_hi
character(len=*),        intent(out)   :: ermesg
integer,                 intent(out)   :: error

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     x_lo          field to be interpolated on lo-res pressure grid
!                   [ units of x_lo ]
!     p_lo          lo-res pressure grid [ Pa ]
!     p_hi          hi-res pressure grid [ Pa ]
!     
!  intent(out) variables:
!
!     x_hi          value of field at pressure p_hi
!                   [ units of x_lo ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real, dimension (1)          :: x_hi_1d, p_hi_1d
      integer                      :: n_hi


!--------------------------------------------------------------------
!   local variables:
!    
!          x_hi_1d    1d array containing the output field x_hi
!          p_hi_1d    1d array containing the input field p_hi
!          ermesg     character string containing any error message
!                     generated in the kernel subroutines accessed from
!                     here
!          n_lo       vertical size of lo_res model profile           
!          n_hi       vertical size of array containing output profile  
!
!---------------------------------------------------------------------

      ermesg = ' ' ; error = 0

!----------------------------------------------------------------------
!    define the dimensions of input and output arrays. 
!----------------------------------------------------------------------
      n_hi = 1

!---------------------------------------------------------------------
!    define an array containing the hi-res pressure at which a variable
!    value is desired.
!---------------------------------------------------------------------
      p_hi_1d(1) = p_hi

!--------------------------------------------------------------------
!    call don_u_lo1d_to_hi1d_k to obtain the desired field 
!    value.
!--------------------------------------------------------------------
      call don_u_lo1d_to_hi1d_k     & 
           (n_lo, n_hi, x_lo, p_lo, p_hi_1d, x_hi_1d, ermesg, error)

!---------------------------------------------------------------------
!    check to be sure no errors were encountered in the kernel routine. 
!---------------------------------------------------------------------
      if (error /= 0 ) return

!--------------------------------------------------------------------
!    move the returned value from the output array to the scalar output 
!    argument to be returned to the calling routine.
!--------------------------------------------------------------------
       x_hi = x_hi_1d(1)        

!--------------------------------------------------------------------


end subroutine don_u_lo1d_to_hi0d_linear_k


!#####################################################################

subroutine don_u_lo1d_to_hi0d_log_k     &
         (n_lo, x_lo, sig_lo, ps, p_hi, x_hi, ermesg, error)

!--------------------------------------------------------------------
!    subroutine don_u_lo1d_to_hi0d_log_k uses logarithmic 
!    interpolation to define the scalar output variable x_hi at pressure
!    p_hi from the input profile x_lo of size n_lo on sigma grid sig_lo 
!    (with associated surface pressure ps).
!    NOTE: vertical index 1 is closest to the ground in all arrays
!    used here.
!    any error message is returned in ermesg.
!------------------------------------------------------------------

implicit none

integer,               intent(in)   :: n_lo
real, dimension(n_lo), intent(in)   :: x_lo, sig_lo 
real,                  intent(in)   :: ps
real,                  intent(in)   :: p_hi
real,                  intent(out)  :: x_hi     
character(len=*),      intent(out)  :: ermesg
integer,               intent(out)  :: error

!--------------------------------------------------------------------
!   intent(in) variables:
!
!     n_lo     size of input profile on lo-res grid
!     x_lo     field to be interpolated [ units of x_lo ]
!     sig_lo   sigma profile defining the specified grid [ fraction ]
!     ps       surface pressure defining the specified grid [ Pa ]
!     p_hi     pressure whose location on the specified grid is desired 
!              [ Pa ]
!
!   intent(out) variables:
!
!     x_hi     output variable value at pressure p_hi [ units of x_lo ] 
!     ermesg   error message, if error is encountered
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer  :: indx  ! nearest vertical grid index on specified grid 
                        ! surfaceward of the desired pressure
      real     :: displ ! logarithmic displacement of desired pressure 
                        ! from the indx grid level
      integer  :: k     ! do-loop index

!----------------------------------------------------------------------
!    initialize the error message character string.
!----------------------------------------------------------------------
      ermesg = ' ' ; error = 0

!--------------------------------------------------------------------
!    define an initial value for indx which can be checked to verify
!    if the search was successful.
!--------------------------------------------------------------------
      indx = 0

!--------------------------------------------------------------------
!    march through the vertical grid until the desired pressure is 
!    bracketed. define the lower index (indx) and calculate the logar-
!    ithmic displacement of the desired pressure between the two sur-
!    rounding grid levels.
!--------------------------------------------------------------------
      do k=1,n_lo-1
        if ((ps*sig_lo(k) >= p_hi) .and.   &
            (ps*sig_lo(k+1) <= p_hi) ) then 
          indx = k
          displ = alog(p_hi/(ps*sig_lo(k)))/alog(sig_lo(k+1)/sig_lo(k)) 
          x_hi = x_lo(indx) + (x_lo(indx+1) - x_lo(indx))*displ
          exit
        endif
      end do

!---------------------------------------------------------------------
!    if pressure was outside the limits of the input profile, write 
!    error message.
!---------------------------------------------------------------------
      if (indx == 0) then
        ermesg = 'unable to bracket the input pressure within the input &
                                           &pressure profile'
        error = 1
        return
      endif

!--------------------------------------------------------------------


end subroutine don_u_lo1d_to_hi0d_log_k

!#####################################################################

subroutine don_u_process_monitor_k (variable, i,j,nlev_lsm, Monitor)
 
use donner_types_mod, only : donner_monitor_type, MAXVAL, MAXMAG, &
                             MINMAG, MINVAL

implicit none

real, dimension(nlev_lsm),  intent(in)    :: variable
integer,                    intent(in)    :: i, j, nlev_lsm
type(donner_monitor_type),  intent(inout) :: Monitor

 
      integer :: k

      select case (Monitor%limit_type)
        case (MAXMAG)              
          do k=1,nlev_lsm 
            if (abs(variable(k)) > Monitor%threshold) then
              Monitor%hits(i,j,k) = Monitor%hits(i,j,k) + 1.0
            endif 
            if (abs(variable(k)) > Monitor%extrema(i,j,k))  then
              Monitor%extrema(i,j,k) = abs(variable(k)) 
            endif 
          end do
        case (MINMAG)              
          do k=1,nlev_lsm 
            if (abs(variable(k)) < Monitor%threshold) then
              Monitor%hits(i,j,k) = Monitor%hits(i,j,k) + 1.0
            endif 
            if (abs(variable(k)) < Monitor%extrema(i,j,k))  then
              Monitor%extrema(i,j,k) = abs(variable(k)) 
            endif 
          end do
        case (MAXVAL)              
          do k=1,nlev_lsm 
            if (variable(k) > Monitor%threshold) then
              Monitor%hits(i,j,k) = Monitor%hits(i,j,k) + 1.0
            endif 
            if (variable(k) > Monitor%extrema(i,j,k))  then
              Monitor%extrema(i,j,k) = variable(k) 
            endif 
          end do
        case (MINVAL)              
          do k=1,nlev_lsm 
            if (variable(k) < Monitor%threshold) then
              Monitor%hits(i,j,k) = Monitor%hits(i,j,k) + 1.0
            endif 
            if (variable(k) < Monitor%extrema(i,j,k))  then
              Monitor%extrema(i,j,k) = variable(k)
            endif 
          end do
      end select

end subroutine don_u_process_monitor_k


!######################################################################

subroutine find_tropopause (nlev, temp, pfull, ptrop, itrop)

integer,                intent(in) :: nlev
real, dimension (nlev), intent(in) :: temp, pfull
real,                   intent(out) :: ptrop
integer,                intent(out) :: itrop

!---------------------------------------------------------------------
!    find lowest temperature in the column between 50 and 400 hPa. the 
!    corresponding pressure is returned as the tropopause pressure.
!    temp and pfull have index 1 closest to the ground.
!---------------------------------------------------------------------

     real      :: ttrop
     integer   :: k


     ttrop = 400.0
     itrop = 1
     ptrop = 1.0

     do k=nlev,1,-1  
       if (pfull(k) < 400.e+02) then
         if (pfull(k) > 50.e+02 .and. temp(k) < ttrop) then 
           ttrop = temp(k)
           itrop = k
           ptrop = pfull(k)
         endif
       else
         exit
       endif
     end do

!---------------------------------------------------------------------
     
end subroutine find_tropopause 


!######################################################################

subroutine define_arat_erat (option, kpar, eratb, erat0, erat_min, &
                             erat_max, erat, arat)

integer, intent(in) :: option, kpar
real, dimension(kpar), intent(in) :: eratb
real, intent(in) :: erat0, erat_min, erat_max
real, dimension(kpar), intent(out) :: erat, arat

     integer :: i
     real    :: x 
     real, dimension(kpar) :: eratb_loc

     if (option == 1) then
 
       do i=1,kpar
! eq (5):
         arat(i) = (exp(-eratb(i)/erat0) - exp(-eratb(i+1)/erat0))  /  &
                   (exp(-eratb(1)/erat0) - exp(-eratb(kpar+1)/erat0)) 
! eq (6):
         erat(i) = 0.5*(eratb(i+1) + eratb(i))   
       end do

     else if (option == 2) then
 
       eratb_loc(1) = erat_min
       do i=2,kpar+1
! eq (7):
         x = exp(-eratb_loc(i-1)/erat0) -     &
              (exp(-erat_min/erat0) - exp(-erat_max/erat0))/kpar
         eratb_loc(i) = -erat0*log(x)    
       end do
       do i=1,kpar
! eq (5):
         arat(i) =    &
            (exp(-eratb_loc(i)/erat0) - exp(-eratb_loc(i+1)/erat0))/ &
            (exp(-eratb_loc(1)/erat0) - exp(-eratb_loc(kpar+1)/erat0)) 
! eq (6):
         erat(i) = 0.5*(eratb_loc(i+1) + eratb_loc(i)) 
       end do
 
     end if



end subroutine define_arat_erat 


!######################################################################


             module fms_donner_mod

use time_manager_mod,       only: time_type, set_time, &
                                  set_date, get_time,   &
                                  get_calendar_type, &
                                  operator(-), &
                                  operator(>=), operator (<)
use diag_manager_mod,       only: register_diag_field, send_data, &
                                  diag_axis_init
use field_manager_mod,      only: MODEL_ATMOS, field_manager_init, &
                                  fm_query_method, get_field_info, &
                                  parse
use tracer_manager_mod,     only: get_tracer_names,get_number_tracers, &
                                  get_tracer_indices, &
!++lwh
                                  query_method
use atmos_tracer_utilities_mod, only : get_wetdep_param
use  sat_vapor_pres_mod,only : sat_vapor_pres_init
!--lwh
use fms_mod,                only: mpp_pe, mpp_root_pe,  &
                                  file_exist,  check_nml_error,  &
                                  error_mesg, FATAL, WARNING, NOTE,  &
                                  close_file, open_namelist_file,    &
                                  stdlog, write_version_number,  &
                                  field_size, &
                                  read_data, write_data, lowercase,    &
                                  open_restart_file
use fms_io_mod,             only: register_restart_field, restart_file_type, &
                                  save_restart, get_mosaic_tile_file
use mpp_mod,                only: input_nml_file
use mpp_io_mod,             only: mpp_open, mpp_close, fieldtype,  &
                                  mpp_read_meta, mpp_get_info, &
                                  mpp_get_fields, mpp_read, &
                                  MPP_NETCDF, MPP_SINGLE,   &
                                  MPP_SEQUENTIAL, MPP_RDONLY, MPP_NATIVE, &
                                  mpp_get_field_name
use constants_mod,          only: DENS_H2O, RDGAS, GRAV, CP_AIR,  &
                                  pie=>PI, KAPPA, RVGAS, &
                                  SECONDS_PER_DAY, HLV, HLF, HLS, KELVIN
use column_diagnostics_mod, only: initialize_diagnostic_columns, &
                                  column_diagnostics_header, &
                                  close_column_diagnostics_units
use donner_types_mod,       only: donner_initialized_type, &
                                  donner_save_type, donner_rad_type, &
                                  donner_nml_type, donner_param_type, &
                                  donner_budgets_type, &
                                  donner_column_diag_type, &
                                  MAXMAG, MAXVAL, MINMAG, MINVAL, &
                                  DET_MASS_FLUX, MASS_FLUX,  &
                                  CELL_UPWARD_MASS_FLUX, TEMP_FORCING, &
                                  MOIST_FORCING, PRECIP,  FREEZING, &
                                  RADON_TEND, &
                                  donner_conv_type, donner_cape_type, &
                                  donner_cem_type

implicit none
private

!--------------------------------------------------------------------
!        donner_deep_mod diagnoses the location and computes the 
!        effects of deep convection on the model atmosphere
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------


character(len=128)  :: version =  '$Id: fms_donner.F90,v 17.0.2.1.2.1.2.1.4.2.2.1 2010/08/30 20:33:34 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!--------------------------------------------------------------------
!---interfaces------

public   &
        fms_donner_process_nml,                             &
        fms_donner_process_tracers, &
        fms_donner_activate_diagnostics, fms_donner_read_restart, &
        fms_donner_col_diag, fms_donner_write_restart, &
        fms_donner_column_control, &
        fms_sat_vapor_pres, &
        fms_get_pe_number,  fms_error_mesg,  fms_constants, & 
        fms_close_col_diag_units, &
        fms_deallocate_variables, &
        fms_donner_deep_netcdf, fms_donner_process_monitors

private   &
!  module subroutines called by donner_deep_init:
        register_fields, read_restart, read_restart_nc,  &
        process_coldstart,&
!  module subroutines called by donner_deep:
        donner_deep_netcdf, donner_column_control,     &
!  module subroutines called from donner_deep_end:
        write_restart


!---------------------------------------------------------------------
!---namelist----

# include "donner_nml.h"

!--------------------------------------------------------------------
!--- public data ----------




!--------------------------------------------------------------------
!----private data-----------

!--- for restart file
type(restart_file_type), pointer, save :: Don_restart => NULL()
type(restart_file_type), pointer, save :: Til_restart => NULL()
logical                                :: in_different_file = .false.
!---------------------------------------------------------------------
!  parameters stored in the donner_param derived type variable to facili-
!  tate passage to kernel subroutines:
!


!--------------------------------------------------------------------
!   list of native mode restart versions usable by this module:
!
!   NOTE: none of the earlier versions of restart files can be used to
!         initiate an experiment with this code version due to a change 
!         in the calculation algorithm. experiments begun with this code
!         must be coldstarted, or use a native mode restart file gener-
!         ated by an experiment using this code version (restart version
!         #8), or a netcdf restart file.
!          
!   version 8 has the lag temp, vapor and pressure fields needed to cal-
!             culate the lag time value of cape. tempbl and ratpbl
!             removed. 
!
!   version 9 is reserved for the native mode restart file version cor-
!             responding to the current netcdf restart file. it is up to 
!             the user to generate the code needed to read and write this
!             version, if needed, using the subroutines read_restart and 
!             write_restart that are provided as starting points, since 
!             only netcdf restarts are currently supported.
!
!   version 10 contains donner_humidity_factor rather than 
!             donner_humidity_ratio, a change necessitated by the intro-
!             duction of the uw_conv shallow convection scheme.

integer, dimension(3)  :: restart_versions = (/ 8, 9, 10 /)


!--------------------------------------------------------------------
!   variables associated with netcdf diagnostic output from this module:
!
!   id_xxxx         indices associated with each potential netcdf 
!                   diagnostic field:
!   missing value   value used by netcdf routines if data not present
!   mod_name        module name associated with these diagnostics; used
!                   to connect these diagnostics to the diag_table
!

integer    :: id_leff
integer    :: id_cemetf_deep, id_ceefc_deep, id_cecon_deep, &
              id_cemfc_deep, id_cememf_deep, id_cememf_mod_deep, &
              id_cual_deep, id_fre_deep, id_elt_deep, &
              id_cmus_deep, id_ecds_deep, id_eces_deep, &
              id_emds_deep, id_emes_deep, id_qmes_deep,&
              id_wmps_deep, id_wmms_deep, id_tmes_deep,&
              id_dmeml_deep, id_uceml_deep, id_umeml_deep, &
              id_xice_deep,  id_dgeice_deep, id_dgeliq_deep,  &
              id_xliq_deep,    &
              id_cuqi_deep, id_cuql_deep, &
              id_plcl_deep, id_plfc_deep, id_plzb_deep, &
              id_xcape_deep, id_coin_deep,  &
              id_dcape_deep, id_qint_deep, id_a1_deep, &
              id_amax_deep, id_amos_deep, &
              id_tprea1_deep, id_ampta1_deep, &
              id_omint_deep, id_rcoa1_deep, id_detmfl_deep
integer                  :: id_pfull_cem, id_phalf_cem, &
                            id_zfull_cem, id_zhalf_cem, &
                            id_temp_cem, id_mixing_ratio_cem
integer, dimension(:), allocatable :: id_cpre_cem, id_pb_cem, id_ptma_cem, &
                            id_h1_cem, id_qlw_cem, id_cfi_cem, &
                            id_wv_cem, id_rcl_cem
integer                  :: id_a1_cem, id_cual_cem, id_tfrc_cem, &
                            id_mpre_cem

integer, dimension(:), allocatable :: id_qtren1, id_qtmes1, &
                                      id_wtp1, id_qtceme, &
                                      id_total_wet_dep, &
                                      id_meso_wet_dep, id_cell_wet_dep
integer, dimension(:), allocatable :: id_qtren1_col, id_qtmes1_col, &
                                      id_wtp1_col, id_qtceme_col, &
                                      id_total_wet_dep_col, &
                                      id_meso_wet_dep_col,   &
                                      id_cell_wet_dep_col
integer, dimension(:), allocatable :: id_extremes, id_hits

integer, dimension(:), allocatable    :: id_water_budget, &
                                         id_ci_water_budget        
integer, dimension(:), allocatable    :: id_enthalpy_budget,   &
                                         id_ci_enthalpy_budget
integer, dimension (:,:), allocatable ::            &
                                         id_precip_budget, &
                                         id_ci_precip_budget

integer   :: id_ci_prcp_heat_liq_cell, id_ci_prcp_heat_frz_cell, &
             id_ci_prcp_heat_liq_meso, id_ci_prcp_heat_frz_meso, &
             id_ci_prcp_heat_total, id_ci_prcp_total

real              :: missing_value = -999.
character(len=16) :: mod_name = 'donner_deep'
integer           :: donner_axes(5)

!--------------------------------------------------------------------
!   variables for column diagnostics option
!
!   arrays containing information for all requested diagnostic columns
!   (1:num_diag_pts):
!    col_diag_unit         unit numbers for each column's output file 
!    col_diag_lon          each column's longitude 
!                          [ degrees, 0 < lon < 360 ]
!    col_diag_lat          each column's latitude 
!                          [degrees, -90 < lat < 90 ]
!    col_diag_j            each column's j index (processor coordinates)
!    col_diag_i            each column's i index (processor coordinates) 
!
!    Time_col_diagnostics  time in model simulation at which to activate
!                          column diagnostics 
!

integer, dimension(:), allocatable :: col_diag_unit
real   , dimension(:), allocatable :: col_diag_lon, col_diag_lat   
integer, dimension(:), allocatable :: col_diag_j, col_diag_i        
type(time_type)                    :: Time_col_diagnostics  


!-----------------------------------------------------------------------
!   miscellaneous variables
!


!-----------------------------------------------------------------------
!-----------------------------------------------------------------------


                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                   PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################

subroutine fms_donner_process_nml  (Nml, kpar)

!---------------------------------------------------------------------
!    fms_donner_process_nml processes the donner_deep_nml file. 
!---------------------------------------------------------------------

!--------------------------------------------------------------------
type(donner_nml_type), intent(inout)    :: Nml
integer,               intent(in)       :: kpar

!---------------------------------------------------------------------
!  intent(in) variables:
!
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

      integer                             :: unit, ierr, io, logunit
  
!-------------------------------------------------------------------
!  local variables:
!
!     unit                   unit number for nml file
!     ierr                   error return flag
!     io                     error return code
!                         
!-------------------------------------------------------------------

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    1. READ NAMELIST AND WRITE IT TO LOG FILE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=donner_deep_nml, iostat=io)
      ierr = check_nml_error(io,'donner_deep_nml')
#else   
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=donner_deep_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'donner_deep_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                                 write (logunit, nml=donner_deep_nml)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    8. STORE THE NAMELIST VARIABLES THAT NEED TO BE MADE AVAILABLE 
!       OUTSIDE OF THIS MODULE INTO THE DONNER_NML_TYPE VARIABLE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      Nml%parcel_launch_level         = parcel_launch_level
      Nml%allow_mesoscale_circulation = allow_mesoscale_circulation
      Nml%do_hires_cape_for_closure =   do_hires_cape_for_closure
      Nml%do_donner_cape              = do_donner_cape    !miz
      Nml%do_donner_plume             = do_donner_plume   !miz
      Nml%do_donner_closure           = do_donner_closure !miz
      Nml%do_dcape                    = do_dcape          !miz
      Nml%do_lands                    = do_lands          !miz
      Nml%tau                         = tau               !miz
      Nml%cape0                       = cape0             !miz
      Nml%rhavg0                      = rhavg0            !miz
      Nml%plev0                       = plev0             !miz
      Nml%do_rh_trig                  = do_rh_trig        !miz
      Nml%do_capetau_land             = do_capetau_land   !miz
      Nml%pblht0                      = pblht0            !miz
      Nml%tke0                        = tke0              !miz
      Nml%lofactor0                   = lofactor0         !miz
      Nml%deephgt0                    = deephgt0          !miz
      Nml%lochoice                    = lochoice          !miz
      Nml%deep_closure                = deep_closure      !miz
      Nml%gama                        = gama              !miz
      Nml%do_ice                      = do_ice            !miz
      Nml%atopevap                    = atopevap          !miz
      Nml%do_donner_lscloud           = do_donner_lscloud !miz
      Nml%auto_rate                   = auto_rate         !miz
      Nml%auto_th                     = auto_th           !miz
      Nml%frac                        = frac              !miz
      Nml%ttend_max                   = ttend_max         !miz
      Nml%mesofactor                  = mesofactor        !miz
      Nml%use_llift_criteria          = use_llift_criteria
      Nml%use_pdeep_cv                = use_pdeep_cv
      Nml%entrainment_constant_source = entrainment_constant_source
      Nml%donner_deep_freq            = donner_deep_freq             
      Nml%model_levels_in_sfcbl       = model_levels_in_sfcbl        
      Nml%cell_liquid_size_type       = cell_liquid_size_type 
      Nml%cell_ice_size_type          = cell_ice_size_type
      Nml%cell_liquid_eff_diam_input  = cell_liquid_eff_diam_input
      Nml%cell_ice_geneff_diam_input  = cell_ice_geneff_diam_input
      Nml%meso_liquid_eff_diam_input  = meso_liquid_eff_diam_input
      Nml%do_average                  = do_average
      Nml%use_memphis_size_limits     = use_memphis_size_limits
      Nml%wmin_ratio                  = wmin_ratio
      Nml%do_freezing_for_cape         = do_freezing_for_cape
      Nml%tfre_for_cape               = tfre_for_cape
      Nml%dfre_for_cape               = dfre_for_cape
      Nml%rmuz_for_cape               = rmuz_for_cape
      Nml%do_freezing_for_closure     = do_freezing_for_closure
      Nml%tfre_for_closure            = tfre_for_closure
      Nml%dfre_for_closure            = dfre_for_closure
      Nml%rmuz_for_closure            = rmuz_for_closure
      Nml%do_budget_analysis          = do_budget_analysis
      Nml%frc_internal_enthalpy_conserv =  &
                                 frc_internal_enthalpy_conserv
      Nml%do_ensemble_diagnostics     = do_ensemble_diagnostics
      Nml%limit_pztm_to_tropo = limit_pztm_to_tropo
      Nml%entrainment_scheme_for_closure =    &
                                       entrainment_scheme_for_closure
      Nml%modify_closure_plume_condensate =   &
                                       modify_closure_plume_condensate
      Nml%closure_plume_condensate = closure_plume_condensate

     Nml%evap_in_downdrafts = evap_in_downdrafts
     Nml%evap_in_environ  = evap_in_environ
     Nml%entrained_into_meso = entrained_into_meso
     Nml%anvil_precip_efficiency = anvil_precip_efficiency
     Nml%meso_down_evap_fraction = meso_down_evap_fraction
     Nml%meso_up_evap_fraction = meso_up_evap_fraction
     Nml%cdeep_cv = cdeep_cv

     allocate (Nml%arat(kpar))
     allocate (Nml%ensemble_entrain_factors_gate(kpar)) 

     if ( arat_erat_option /= 0 ) then
 
       call define_arat_erat (arat_erat_option, kpar, eratb, erat0, &
                              erat_min, erat_max, erat, arat)
       if (mpp_pe() == mpp_root_pe() ) then
         print *,'donner_deep_nml: redefined arat and erat using &
                        &arat_erat_option == ', arat_erat_option
         print *,'donner_deep_nml: arat = ',arat
         print *,'donner_deep_nml: erat = ',erat
       end if
     endif

     Nml%arat = arat
     Nml%ensemble_entrain_factors_gate = erat

end subroutine fms_donner_process_nml


!#####################################################################

subroutine fms_donner_process_tracers (Initialized, tracers_in_donner,&
                                       Don_save)

type(donner_initialized_type),   intent(inout) :: Initialized
logical, dimension(:),          intent(in) :: tracers_in_donner
type(donner_save_type), intent(inout)      :: Don_save



        integer :: nn, n
      logical                             :: flag
      character(len=200)                  :: method_name, method_control
      real                                :: frac_junk

        Initialized%do_donner_tracer = .true.
        nn = 1
        do n=1,size(tracers_in_donner(:))
          if (tracers_in_donner(n)) then
            call get_tracer_names (MODEL_ATMOS, n,  &
                                   name = Don_save%tracername(nn), &
                                   units = Don_save%tracer_units(nn))
!++lwh
            Initialized%wetdep(nn)%units = Don_save%tracer_units(nn)
            flag = query_method( 'wet_deposition', MODEL_ATMOS, n, &
                                 method_name, method_control )
            call get_wetdep_param( method_name, method_control, &
                                   Initialized%wetdep(nn)%scheme, &
                                   Initialized%wetdep(nn)%Henry_constant, &
                                   Initialized%wetdep(nn)%Henry_variable, &
                                   frac_junk, &
                                   Initialized%wetdep(nn)%alpha_r, &
                                   Initialized%wetdep(nn)%alpha_s , &
                                   Initialized%wetdep(nn)%Lwetdep, &
                                   Initialized%wetdep(nn)%Lgas, &
                                   Initialized%wetdep(nn)%Laerosol, &
                                   Initialized%wetdep(nn)%Lice, &
                                   frac_in_cloud_donner=Initialized%wetdep(nn)%frac_in_cloud)
            Initialized%wetdep(nn)%scheme = lowercase( Initialized%wetdep(nn)%scheme )
!-lwh
            nn = nn + 1
          endif
        end do

end subroutine fms_donner_process_tracers




!#####################################################################

subroutine fms_donner_activate_diagnostics (secs, days, axes, &
                             Don_save, Nml, n_water_budget, &
                             n_enthalpy_budget, n_precip_paths, &
                             n_precip_types, nlev_hires, kpar)

integer, intent(in) :: secs, days, n_water_budget, &
                             n_enthalpy_budget, n_precip_paths, &
                             n_precip_types, nlev_hires, kpar
                      
integer,         dimension(4),   intent(in)   :: axes
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml       

      type(time_type)    :: Time

      Time = set_time (secs, days)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    4. INITIALIZE THE NETCDF OUTPUT VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!--------------------------------------------------------------------
!    activate the netcdf diagnostic fields.
!-------------------------------------------------------------------
      call register_fields (Time, axes, Don_save, Nml, &
                              n_water_budget, &
                             n_enthalpy_budget, n_precip_paths, &
                             n_precip_types, nlev_hires, kpar)


end subroutine fms_donner_activate_diagnostics 


!#####################################################################

subroutine fms_donner_read_restart (Initialized, ntracers,   &
                                    secs, days, Don_save, Nml)

type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     
integer, intent(in) :: secs, days, ntracers

      type(time_type) :: Time

     Time = set_time (secs, days)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    5. PROCESS THE RESTART FILE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!--------------------------------------------------------------------
!    if a netcdf restart file is present, call read_restart_nc to read 
!    it.
!--------------------------------------------------------------------
      if (file_exist ('INPUT/donner_deep.res.nc') ) then
        Initialized%coldstart= .false.
        call read_restart_nc (ntracers, Initialized,Nml, Don_save)

!--------------------------------------------------------------------
!    if a native mode restart file is present, call read_restart 
!    to read it.
!--------------------------------------------------------------------
      else if (file_exist ('INPUT/donner_deep.res') ) then
        Initialized%coldstart= .false.
        call read_restart (ntracers, Time, Initialized, Nml, Don_save)

!--------------------------------------------------------------------
!    if no restart file is present, call subroutine process_coldstart
!    to define the needed variables.
!--------------------------------------------------------------------
      else
        call process_coldstart (Time, Initialized, Nml, Don_save)
      endif

      !--- register restart field to be ready to be written out.
      call fms_donner_register_restart('donner_deep.res.nc', Initialized, ntracers, Don_save, Nml)

end subroutine fms_donner_read_restart 


!#####################################################################

subroutine fms_donner_col_diag (lonb, latb, Col_diag, pref) 

real, dimension(:,:), intent(in) :: lonb, latb
type(donner_column_diag_type), intent(inout) :: Col_diag
real, dimension(:), intent(in) :: pref

    logical, dimension(size(latb,1)-1, size(latb,2)-1) ::    &
                                                  do_column_diagnostics
    integer :: k, n

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    6. INITIALIZE VARIABLES NEEDED FOR COLUMN_DIAGNOSTICS_MOD OUTPUT.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!---------------------------------------------------------------------
!    define the total number of columns for which diagnostics
!    are desired.
!---------------------------------------------------------------------
      Col_diag%num_diag_pts = num_diag_pts_ij + num_diag_pts_latlon

!---------------------------------------------------------------------
!    initialize the value of the k index associated with diagnostics
!    cutoff.
!---------------------------------------------------------------------
      Col_diag%kstart = -99

!---------------------------------------------------------------------
!    if any diagnostics are requested, perform various consistency
!    checks.
!---------------------------------------------------------------------
      if (Col_diag%num_diag_pts > 0) then

!---------------------------------------------------------------------
!    check that array dimensions are sufficiently large for the number 
!    of columns requested.
!---------------------------------------------------------------------
        if (Col_diag%num_diag_pts > MAX_PTS) then
          call error_mesg ('donner_deep_mod', 'donner_deep_init: &
         &must reset MAX_PTS or reduce number of diagnostic points', &
                                                           FATAL)  
        endif

!---------------------------------------------------------------------
!    check that the specified time at which diagnostics are to be 
!    activated has been specified.
!---------------------------------------------------------------------
        do n=1,3
          if (diagnostics_start_time(n) == 0) then
            call error_mesg ('donner_deep_mod', 'donner_deep_init:&
             &year, month and/or day invalidly specified for column '//&
                  'diagnostics starting time', FATAL)
          endif
        end do

!---------------------------------------------------------------------
!    define a time_type variable indicating the requested time to begin
!    outputting diagnostics.
!---------------------------------------------------------------------
        Time_col_diagnostics = set_date (diagnostics_start_time(1), &
                                         diagnostics_start_time(2), &   
                                         diagnostics_start_time(3), &   
                                         diagnostics_start_time(4), &   
                                         diagnostics_start_time(5), &   
                                         diagnostics_start_time(6) )    

!---------------------------------------------------------------------
!    allocate space for the arrays used to specify the diagnostics 
!    columns and the output units. initialize the arrays with bogus
!    values.
!---------------------------------------------------------------------
        allocate (col_diag_unit    (Col_diag%num_diag_pts) )
        allocate (col_diag_lon     (Col_diag%num_diag_pts) )
        allocate (col_diag_lat     (Col_diag%num_diag_pts) )
        allocate (col_diag_i       (Col_diag%num_diag_pts) )
        allocate (col_diag_j       (Col_diag%num_diag_pts) )
        col_diag_unit  = -1
        col_diag_lon   = -1.0
        col_diag_lat   = -1.0
        col_diag_i     = -1
        col_diag_j     = -1

!---------------------------------------------------------------------
!    call initialize_diagnostic_columns to determine the locations 
!    (i,j,lat and lon) of any diagnostic columns in this processor's
!    space and to open output files for the diagnostics.
!---------------------------------------------------------------------
        call initialize_diagnostic_columns   &
                     (mod_name, num_diag_pts_latlon, num_diag_pts_ij, &
                      i_coords_gl, j_coords_gl, lat_coords_gl, &
                      lon_coords_gl, lonb(:,:), latb(:,:),  &
                      do_column_diagnostics, &
                      col_diag_lon, col_diag_lat, col_diag_i,  &
                      col_diag_j, col_diag_unit)

!---------------------------------------------------------------------
!    verify that requested pressure cutoff for column diagnostics output
!    is valid. define the model k index which corresponds (kstart).
!---------------------------------------------------------------------
        do k=1,size(pref(:))
          if (pref(k) >= diagnostics_pressure_cutoff) then
            Col_diag%kstart = k
            exit
          endif
        end do

!----------------------------------------------------------------------
!    if the specified pressure is larger than any pressure level in the
!    model grid, write an error message.
!----------------------------------------------------------------------
        if (Col_diag%kstart == -99) then
          call error_mesg ( 'donner_deep_mod', 'donner_deep_init: &
           &diagnostics_pressure_cutoff is higher than pressure at '//&
                                     'any model level', FATAL)
        endif

!----------------------------------------------------------------------
!   if column diagnostics is not requested, define the components of
!   Col_diag that will be needed.
!----------------------------------------------------------------------
      else
        Col_diag%in_diagnostics_window = .false.
        Col_diag%ncols_in_window = 0
      endif

!----------------------------------------------------------------------
!    allocate space for the array elements of the donner_column_diag_type
!    variable Col_diag. These arrays remain for the life of the job and
!    will be defined for each physics window as it is entered.
!----------------------------------------------------------------------
      allocate (Col_diag%i_dc(Col_diag%num_diag_pts))
      allocate (Col_diag%j_dc(Col_diag%num_diag_pts))
      allocate (Col_diag%unit_dc(Col_diag%num_diag_pts))
      allocate (Col_diag%igl_dc(Col_diag%num_diag_pts))
      allocate (Col_diag%jgl_dc(Col_diag%num_diag_pts))


end subroutine fms_donner_col_diag 




!#####################################################################
! <SUBROUTINE NAME="fms_donner_write_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine fms_donner_write_restart (Initialized, timestamp)
  type(donner_initialized_type), intent(in) :: Initialized
  character(len=*), intent(in), optional :: timestamp

!-------------------------------------------------------------------
!    call subroutine to write restart file. NOTE: only the netcdf 
!    restart file is currently supported.
!-------------------------------------------------------------------
      if (.NOT. do_netcdf_restart) then
          call error_mesg ('fms_donner_mod', 'fms_donner_write_restart: &
          &writing a netcdf restart despite request for native &
           &format (not currently supported); if you must have native &
           &mode, then you must update the source code and remove &
                                               &this if loop.', NOTE)
      endif
      if (mpp_pe() == mpp_root_pe() ) then
        if (.not. (write_reduced_restart_file) ) then
          call error_mesg ('donner_deep_mod', 'write_restart_nc: &
            &Writing FULL netCDF formatted restart file as requested: &
                 &RESTART/donner_deep.res.nc', NOTE)
        else
          if (Initialized%conv_alarm >= Initialized%physics_dt)  then
            call error_mesg ('donner_deep_mod', 'write_restart_nc: &
            &Writing FULL netCDF formatted restart file; it is needed &
             &to allow seamless restart because next step is not a &
             &donner calculation step: RESTART/donner_deep.res.nc', NOTE)
          else
            call error_mesg ('donner_deep_mod', 'write_restart_nc: &
              &Writing REDUCED netCDF formatted restart file as  &
                &requested: RESTART/donner_deep.res.nc', NOTE)
          endif
        endif
      endif
      call save_restart(Don_restart, timestamp)
      if(in_different_file) call save_restart(Til_restart, timestamp)

end subroutine fms_donner_write_restart 


!#####################################################################

subroutine fms_get_pe_number (me, root_pe)

integer, intent(out) :: me, root_pe

    me = mpp_pe()
    root_pe = mpp_root_pe()

end subroutine fms_get_pe_number



!#####################################################################

subroutine fms_close_col_diag_units


      call close_column_diagnostics_units (col_diag_unit)


end subroutine fms_close_col_diag_units 


!#####################################################################

subroutine fms_deallocate_variables (Col_diag)

type(donner_column_diag_type), intent(inout) :: Col_diag

      if (Col_diag%num_diag_pts > 0) then
        deallocate (Col_diag%i_dc    )
        deallocate (Col_diag%j_dc    ) 
        deallocate (Col_diag%unit_dc )
        deallocate (Col_diag%igl_dc  )
        deallocate (Col_diag%jgl_dc  )
      endif

      if (allocated(col_diag_unit)) then
        deallocate (col_diag_unit  )
        deallocate (col_diag_lon   )
        deallocate (col_diag_lat   )
        deallocate (col_diag_i     )
        deallocate (col_diag_j     )
      endif
     
      if (allocated (id_qtren1)) then
        deallocate (id_qtren1)
        deallocate (id_qtmes1)
        deallocate (id_wtp1  )
        deallocate (id_qtceme)
        deallocate (id_total_wet_dep)
        deallocate (id_meso_wet_dep)
        deallocate (id_cell_wet_dep)
        deallocate (id_qtren1_col)
        deallocate (id_qtmes1_col)
        deallocate (id_wtp1_col  )
        deallocate (id_qtceme_col)
        deallocate (id_total_wet_dep_col)
        deallocate (id_meso_wet_dep_col)
        deallocate (id_cell_wet_dep_col)
      endif


      if (allocated (id_extremes)) then
        deallocate (id_extremes)
        deallocate (id_hits)
      endif


end subroutine fms_deallocate_variables



!#####################################################################

subroutine fms_sat_vapor_pres


      call sat_vapor_pres_init


end subroutine fms_sat_vapor_pres


!#####################################################################

subroutine fms_error_mesg (ermesg)

character(len=*), intent(in) :: ermesg


      call error_mesg ('donner_deep_mod', ermesg, FATAL)



end subroutine fms_error_mesg 


!######################################################################

subroutine fms_donner_deep_netcdf (is, ie, js, je, Nml, secs, days, &
                               Param, Initialized, Don_conv, Don_cape,&
                               Don_cem,parcel_rise, pmass, total_precip, &
                               Don_budgets, &
                               temperature_forcing, moisture_forcing)  

!---------------------------------------------------------------------
!    subroutine donner_deep_netcdf sends the fields requested in the
!    diag_table to diag_manager_mod so that they may be appropriately
!    processed for output.
!---------------------------------------------------------------------

integer,                intent(in) :: is, ie, js, je
integer,                intent(in) :: secs, days
type(donner_nml_type), intent(in) :: Nml   
type(donner_param_type), intent(in) :: Param 
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_conv_type), intent(in) :: Don_conv
type(donner_budgets_type), intent(in) :: Don_budgets
type(donner_cape_type), intent(in) :: Don_cape
type(donner_cem_type),  intent(in) :: Don_cem
real, dimension(:,:,:), intent(in) :: pmass, temperature_forcing,&
                                      moisture_forcing
real, dimension(:,:),   intent(in) :: parcel_rise, total_precip

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie         first and last values of i index values of points 
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points 
!                    in this physics window (processor coordinates)
!     Time           current time (time_type)
!     Don_conv       donner_convection_type derived type variable con-
!                    taining diagnostics describing the nature of the 
!                    convection produced by the donner parameterization
!     Don_cape       donner_cape type derived type variable containing
!                    diagnostics related to the cape calculation assoc-
!                    iated with the donner convection parameterization
!     Don_cem        donner_cem_type derived type variable containing
!                    Donner cumulus ensemble member diagnostics
!     temperature_forcing  
!                    temperature tendency due to donner convection
!                    [ deg K / sec ]
!     moisture_forcing  
!                    vapor mixing ratio tendency due to donner 
!                    convection [ kg(h2o) / (kg(dry air) sec ) ]
!     pmass          mass per unit area within the grid box
!                    [ kg (air) / (m**2) ]
!     parcel_rise    accumulated vertical displacement of a near-surface
!                    parcel as a result of the lowest model level omega 
!                    field [ Pa ]
!     total_precip   total precipitation rate produced by the
!                    donner parameterization [ mm / day ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      type(time_type)  :: Time

      Time = set_time (secs, days)

      call donner_deep_netcdf (is, ie, js, je, Nml, Time,  Param, &
                               Initialized, Don_conv, Don_cape,&
                               Don_cem,parcel_rise, pmass, total_precip, &
                               Don_budgets, &
                               temperature_forcing, moisture_forcing)  


!----------------------------------------------------------------------


end subroutine fms_donner_deep_netcdf



!###################################################################

subroutine fms_donner_process_monitors (idf, jdf, nlev,  &
                              ntracers, axes, secs, days, Initialized,&
                              Don_save)

integer, intent(in)  :: idf, jdf, nlev, ntracers, secs, days
integer, dimension(4), intent(in) :: axes
type(donner_save_type), intent(inout) :: Don_save
type(donner_initialized_type), intent(inout) :: Initialized


   type(time_type)  :: Time

    Time = set_time (secs,days)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    9. SET UP CODE TO MONITOR SELECTED OUTPUT VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

       call process_monitors (idf, jdf, nlev, ntracers, axes, Time, &
                              Initialized, Don_save)


end subroutine fms_donner_process_monitors

!###################################################################

subroutine fms_donner_column_control (is, ie, js, je, secs, days, Col_diag)          

!---------------------------------------------------------------------
!    subroutine fms_donner_column_control returns the number, location
!    (processor and window indices) and output units associated with 
!    any diagnostic columns requested within the current physics window.
!---------------------------------------------------------------------

integer,                       intent(in)   :: is, ie, js, je
integer,                       intent(in) :: secs, days
type(donner_column_diag_type), intent(inout) :: Col_diag


     type(time_type)                             :: Time

      Time = set_time(secs, days)

      call donner_column_control (is, ie, js, je, Time, Col_diag)                


end subroutine fms_donner_column_control 


!####################################################################


subroutine fms_constants (Param)

type(donner_param_type), intent(inout)  :: Param


!----------------------------------------------------------------------
!    define the components of Param that come from constants_mod. see 
!    donner_types.h for their definitions.
!----------------------------------------------------------------------
      Param%dens_h2o        = DENS_H2O
      Param%rdgas           = RDGAS
      Param%grav            = GRAV
      Param%cp_air          = CP_AIR  
      Param%pie             = PIE
      Param%kappa           = KAPPA
      Param%rvgas           = RVGAS
      Param%seconds_per_day = SECONDS_PER_DAY
      Param%hlv             = HLV
      Param%hlf             = HLF
      Param%hls             = HLS
      Param%kelvin          = KELVIN

!----------------------------------------------------------------------

end subroutine fms_constants 

!####################################################################





!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                   PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!      1. ROUTINES CALLED BY DONNER_DEEP_INIT
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
 
subroutine register_fields (Time, axes, Don_save, Nml, &
                              n_water_budget, &
                             n_enthalpy_budget, n_precip_paths, &
                             n_precip_types, nlev_hires, kpar)

!----------------------------------------------------------------------
!    subroutine register_fields registers all of the potential diagnos-
!    tics written by this module with diag_manager_mod.
!----------------------------------------------------------------------

type(time_type),               intent(in)   :: Time
integer, intent(in) :: n_water_budget, &
                             n_enthalpy_budget, n_precip_paths, &
                             n_precip_types, nlev_hires, kpar
integer,         dimension(4), intent(in)   :: axes
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml       

!----------------------------------------------------------------------
!   intent(in) variables:
!
!      Time         current time [ time_type ]
!      axes         data axes for diagnostics
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer  :: ntracers     ! number of tracers transported by the
                               ! donner deep convection parameterization
      integer :: nn            ! do-loop index
      integer :: ncem          ! number of cumulus ensemble members in
                               ! the donner deep convection parameter-
                               ! ization
      character(len=2) :: chvers ! character representation of cumulus 
                                 ! ensemble  member number

!  define a variable for telling "register_fields" to put output on
!  "half-levels" (Reference:  Chris Golaz's subroutine "diag_field_init"
!  in /home/cjg/FMS/nalanda/nnew3/m45_am2p14_nnew3/src/atmos_param/
!                                 moist_processes/moist_processes.F90)
 
      integer, dimension(3) :: half = (/1,2,4/)
      integer, dimension(3) :: cldindices = (/1,2,5/)
      integer               :: id_cldmodel
      real                  :: cldvindx(NLEV_HIRES)
      integer               :: k

      ncem = kpar

!---------------------------------------------------------------------  
!    define the axes for the donner cloud model.
!---------------------------------------------------------------------
      donner_axes(1:4) = axes(1:4)     
      if (Nml%do_donner_plume) then
        do k=1, NLEV_HIRES
          cldvindx(k) = real(k)
        end do
        id_cldmodel = diag_axis_init('cldvindx', cldvindx, 'level#', &
                                     'z', 'cld model vertical index', &
                                     set_name=mod_name )
        donner_axes(5) = id_cldmodel
      endif

!----------------------------------------------------------------------
!    define the number of tracers that are to be transported by the 
!    donner deep convection parameterization.
!-------------------------------------------------------------------
      ntracers = size(Don_save%tracername(:))

!---------------------------------------------------------------------
!    register the various diagnostic fields.
!---------------------------------------------------------------------

    if (Nml%do_budget_analysis) then
      allocate (id_water_budget (n_water_budget))
      allocate (id_ci_water_budget (n_water_budget))
      allocate (id_enthalpy_budget (n_water_budget))
      allocate (id_ci_enthalpy_budget (n_water_budget))
      allocate (id_precip_budget (n_precip_paths, n_precip_types))
      allocate (id_ci_precip_budget (n_precip_paths, n_precip_types))
      id_water_budget(1)    = register_diag_field    &
            (mod_name, 'vapor_net_tend', axes(1:3),   &
             Time, 'net water vapor tendency', &
             'g(h2o) / kg(air) / day',    &
             missing_value=missing_value)
      
      id_water_budget(2)    = register_diag_field    &
            (mod_name, 'vapor_cell_dynam', axes(1:3),   &
             Time, 'vapor tendency due to cell dynamics', &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(3)    = register_diag_field    &
            (mod_name, 'vapor_meso_depo', axes(1:3),   &
             Time, 'vapor tendency from mesoscale deposition', &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(4)    = register_diag_field    &
            (mod_name, 'vapor_meso_cd', axes(1:3),   &
             Time, 'vapor tendency from mesoscale condensation',  &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(5)    = register_diag_field    &
            (mod_name, 'vapor_cell_evap', axes(1:3),   &
             Time, 'vapor tendency from cell evaporation',  &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(6)    = register_diag_field    &
            (mod_name, 'vapor_cell_meso_trans', axes(1:3),   &
             Time, 'vapor tendency from cell to mesoscale transfer',  &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(7)    = register_diag_field    &
            (mod_name, 'vapor_meso_evap', axes(1:3),   &
             Time, 'vapor tendency from mesoscale evaporation', &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(8)    = register_diag_field    &
            (mod_name, 'vapor_meso_dynam_up', axes(1:3),   &
             Time, 'vapor tendency from mesoscale updrafts',  &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_water_budget(9)    = register_diag_field    &
            (mod_name, 'vapor_meso_dynam_dn',  axes(1:3),   &
             Time, 'vapor tendency from mesoscale downdrafts',  &
             ' g(h2o) / kg(air) / day', &
             missing_value=missing_value)
      
      id_enthalpy_budget(1)    = register_diag_field    &
            (mod_name, 'enth_net_tend', axes(1:3),   &
             Time, 'net temp tendency', 'deg K  /day',    &
             missing_value=missing_value)

      id_enthalpy_budget(2)    = register_diag_field    &
            (mod_name, 'enth_cell_dynam', axes(1:3),   &
             Time, 'temp tendency due to cell dynamics', &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(3)    = register_diag_field    &
            (mod_name, 'enth_meso_depo_liq', axes(1:3), Time, &
             'temp tendency from mesoscale deposition on liquid&
                    & condensate',  'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(4)    = register_diag_field    &
            (mod_name, 'enth_meso_cd_liq', axes(1:3), Time, &
             ' temp tendency from mesoscale liquid condensation', &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(5)    = register_diag_field    &
            (mod_name, 'enth_cell_evap_liq', axes(1:3),   &
             Time, 'temp tendency from evap of liquid condensate', &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(6)    = register_diag_field    &
            (mod_name, 'enth_meso_evap_liq_up', axes(1:3),   &
             Time, 'temp tendency from evaporation of liquid &
              &condensate in mesoscale updrafts',  &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(7)    = register_diag_field    &
            (mod_name, 'enth_meso_evap_liq_dn', axes(1:3),   &
             Time, 'temp tendency from evaporation of liquid &
              &condensate in mesoscale downdrafts',  &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(8)    = register_diag_field    &
            (mod_name, 'enth_meso_depo_ice', axes(1:3),   &
             Time, ' temp tendency from mesoscale deposition on &
              &ice condensate',  'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(9)    = register_diag_field    &
            (mod_name, 'enth_meso_cd_ice', axes(1:3),   &
             Time, 'temp tendency from mesoscale ice condensation', &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(10)    = register_diag_field    &
            (mod_name, 'enth_cell_evap_ice', axes(1:3),   &
             Time, 'temp tendency from evap of ice condensate', &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(11)    = register_diag_field    &
            (mod_name, 'enth_meso_evap_ice_up', axes(1:3),   &
             Time, 'temp tendency from evaporation of ice condensate &
              &in mesoscale updrafts',  'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(12)    = register_diag_field    &
            (mod_name, 'enth_meso_evap_ice_dn', axes(1:3),   &
             Time, 'temp tendency from evaporation of ice &
               &condensate in mesoscale downdrafts',  'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(13)    = register_diag_field    &
            (mod_name, 'enth_meso_freeze', axes(1:3),   &
             Time, 'temp tendency from the freezing of liquid &
              &condensate when it enters the mesoscale circulation',  &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(14)    = register_diag_field    &
            (mod_name, 'enth_cell_freeze', axes(1:3),   &
             Time, 'temp tendency from the freezing of liquid &
                &cell condensate',  'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(15)    = register_diag_field    &
            (mod_name, 'enth_cell_precip_melt', axes(1:3),   &
             Time, 'temp tendency from the melting of cell frozen &
             &liquid and ice that is precipitating out', 'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(16)    = register_diag_field    &
            (mod_name, 'enth_meso_melt', axes(1:3), Time, &
             'temp tendency from melting bogus frozen condensate',  &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(17)    = register_diag_field    &
            (mod_name, 'enth_meso_precip_melt', axes(1:3),   &
             Time, 'temp tendency from the melting of frozen &
               &mesoscale precipitation',  'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(18)    = register_diag_field    &
            (mod_name, 'enth_meso_dynam_up', axes(1:3),   &
             Time, 'temp tendency from mesoscale updraft', &
             'deg K / day', &
             missing_value=missing_value)

      id_enthalpy_budget(19)    = register_diag_field    &
            (mod_name, 'enth_meso_dynam_dn', axes(1:3),   &
             Time, 'temp tendency from mesoscale downdraft', &
             'deg K / day', &
             missing_value=missing_value)

      id_precip_budget(1,1)    = register_diag_field    &
            (mod_name, 'precip_cell_liq', axes(1:3),   &
             Time, 'precip from cell liquid condensate', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(2,1)    = register_diag_field    &
            (mod_name, 'precip_cell_liq_frz', axes(1:3),   &
             Time, 'precip from cell liquid condensate which froze', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(3,1)    = register_diag_field    &
            (mod_name, 'precip_cell_liq_frz_melt', axes(1:3), Time, &
              'precip from cell liquid condensate which froze &
               &and remelted', 'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(4,1)    = register_diag_field    &
            (mod_name, 'precip_cell_ice', axes(1:3),   &
             Time, 'precip from cell ice condensate', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(5,1)    = register_diag_field    &
            (mod_name, 'precip_cell_ice_melt', axes(1:3),   &
             Time, 'precip from cell ice condensate which melted', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(1,2)    = register_diag_field    &
            (mod_name, 'precip_trans_liq', axes(1:3),   &
             Time, 'precip from cell liquid transferred to meso', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(2,2)    = register_diag_field    &
            (mod_name, 'precip_trans_liq_frz', axes(1:3),   &
             Time, 'precip from cell liquid transferred to meso &
              &which froze', 'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(3,2)    = register_diag_field    &
            (mod_name, 'precip_trans_liq_frz_melt', axes(1:3), Time, &
             'precip from cell liquid transferred to meso which &
              &froze and remelted', 'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(4,2)    = register_diag_field    &
            (mod_name, 'precip_trans_ice', axes(1:3),   &
             Time, 'precip from cell ice transferred to meso', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(5,2)    = register_diag_field    &
            (mod_name, 'precip_trans_ice_melt', axes(1:3),   &
             Time, 'precip from cell ice transferred to meso &
              &which melted', 'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(1,3)    = register_diag_field    &
            (mod_name, 'precip_meso_liq', axes(1:3),   &
             Time, 'precip from meso liq condensate', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(2,3)    = register_diag_field    &
            (mod_name, 'precip_meso_liq_frz', axes(1:3),   &
             Time, 'precip from meso liq  condensate which froze', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(3,3)    = register_diag_field    &
            (mod_name, 'precip_meso_liq_frz_melt', axes(1:3), Time, &
            'precip from meso condensate liq which froze and &
             &remelted', 'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(4,3)    = register_diag_field    &
            (mod_name, 'precip_meso_ice', axes(1:3),   &
             Time, 'precip from meso ice condensate', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_precip_budget(5,3)    = register_diag_field    &
            (mod_name, 'precip_meso_ice_melt', axes(1:3),   &
             Time, 'precip from meso ice condensate which melted', &
              'kg(h2o) / kg(air) / day', &
             missing_value=missing_value)

      id_ci_precip_budget(1,1)    = register_diag_field    &
            (mod_name, 'ci_precip_cell_liq', axes(1:2),   &
             Time, 'col intg precip from cell liquid condensate', &
             'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(2,1)    = register_diag_field    &
            (mod_name, 'ci_precip_cell_liq_frz', axes(1:2),   &
             Time, 'col intg precip from cell liquid condensate &
             &which froze',  'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(3,1)    = register_diag_field    &
            (mod_name, 'ci_precip_cell_liq_frz_melt', axes(1:2), Time, &
             'col intg precip from cell liquid condensate which &
              &froze and remelted',  'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(4,1)    = register_diag_field    &
            (mod_name, 'ci_precip_cell_ice', axes(1:2),   &
             Time, 'col intg precip from cell ice condensate', &
             'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(5,1)    = register_diag_field    &
            (mod_name, 'ci_precip_cell_ice_melt', axes(1:2),   &
             Time, 'col intg precip from cell ice condensate &
             &which melted',  'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(1,2)    = register_diag_field    &
            (mod_name, 'ci_precip_trans_liq', axes(1:2),   &
             Time, 'col intg precip from cell liquid transferred &
             &to meso',  'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(2,2)    = register_diag_field    &
            (mod_name, 'ci_precip_trans_liq_frz', axes(1:2),   &
             Time, 'col intg precip from cell liquid transferred &
              &to meso  which froze', 'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(3,2)    = register_diag_field    &
            (mod_name, 'ci_precip_trans_liq_frz_melt', axes(1:2), &
             Time, 'col intg precip from cell liquid transferred &
             &to meso which froze and remelted', 'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(4,2)    = register_diag_field    &
            (mod_name, 'ci_precip_trans_ice', axes(1:2),   &
             Time, 'col intg precip from cell ice transferred &
              &to meso', 'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(5,2)    = register_diag_field    &
            (mod_name, 'ci_precip_trans_ice_melt', axes(1:2),   &
             Time, 'col intg precip from cell ice transferred to &
             &meso which melted', 'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(1,3)    = register_diag_field    &
            (mod_name, 'ci_precip_meso_liq', axes(1:2),   &
             Time, 'col intg precip from meso liq condensate', &
             'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(2,3)    = register_diag_field    &
            (mod_name, 'ci_precip_meso_liq_frz', axes(1:2),   &
             Time, 'col intg precip from meso liq  condensate &
             &which froze',  'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(3,3)    = register_diag_field    &
            (mod_name, 'ci_precip_meso_liq_frz_melt', axes(1:2), Time, &
             'col intg precip from meso condensate liq which froze &
               &and remelted', 'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(4,3)    = register_diag_field    &
            (mod_name, 'ci_precip_meso_ice', axes(1:2),   &
             Time, 'col intg precip from meso ice condensate', &
             'mm / day', &
             missing_value=missing_value)

      id_ci_precip_budget(5,3)    = register_diag_field    &
            (mod_name, 'ci_precip_meso_ice_melt', axes(1:2),   &
             Time, 'col intg precip from meso ice condensate &
              &which melted', 'mm / day', &
             missing_value=missing_value)

      id_ci_water_budget(1)    = register_diag_field    &
            (mod_name, 'ci_vapor_net_tend', axes(1:2),   &
             Time, 'col intg net water vapor tendency', 'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(2)    = register_diag_field    &
            (mod_name, 'ci_vapor_cell_dynam', axes(1:2),   &
             Time, 'col intg vapor tendency due to cell dynamics', &
              'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(3)    = register_diag_field    &
            (mod_name, 'ci_vapor_meso_depo', axes(1:2),   &
             Time, 'col intg vapor tendency from mesoscale deposition',&
              'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(4)    = register_diag_field    &
            (mod_name, 'ci_vapor_meso_cd', axes(1:2),   &
             Time, 'col intg vapor tendency from mesoscale &
              &condensation',  'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(5)    = register_diag_field    &
            (mod_name, 'ci_vapor_cell_evap', axes(1:2),   &
             Time, 'col intg vapor tendency from cell evaporation', &
              'mm / day', missing_value=missing_value)
      
      id_ci_water_budget(6)    = register_diag_field    &
            (mod_name, 'ci_vapor_cell_meso_trans', axes(1:2),   &
             Time, 'col intg vapor tendency from cell to mesoscale &
              &transfer',  'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(7)    = register_diag_field    &
            (mod_name, 'ci_vapor_meso_evap', axes(1:2),   &
             Time, 'col intg vapor tendency from mesoscale &
              &evaporation', 'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(8)    = register_diag_field    &
            (mod_name, 'ci_vapor_meso_dynam_up', axes(1:2),   &
             Time, 'col intg vapor tendency from mesoscale updrafts',  &
              'mm / day',    &
             missing_value=missing_value)
      
      id_ci_water_budget(9)    = register_diag_field    &
            (mod_name, 'ci_vapor_meso_dynam_dn',  axes(1:2),   &
             Time, 'col intg vapor tendency from mesoscale downdrafts',&
              'mm / day',    &
             missing_value=missing_value)
      
      id_ci_enthalpy_budget(1)    = register_diag_field    &
            (mod_name, 'ci_enth_net_tend', axes(1:2),   &
             Time, 'col intg net enthalpy tendency', 'J/m**2 / day',   &
             missing_value=missing_value)

      id_ci_enthalpy_budget(2)    = register_diag_field    &
            (mod_name, 'ci_enth_cell_dynam', axes(1:2),   &
             Time, 'col intg enthalpy tendency due to cell dynamics', &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(3)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_depo_liq', axes(1:2),   &
             Time, 'col intg enthalpy tendency from mesoscale &
             &deposition on liquid condensate',  'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(4)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_cd_liq', axes(1:2),   &
             Time, 'col intg enthalpy tendency from mesoscale &
             &liquid condensation', 'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(5)    = register_diag_field    &
            (mod_name, 'ci_enth_cell_evap_liq', axes(1:2),   &
             Time, 'col intg enthalpy tendency from evap of liquid &
             &condensate',  'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(6)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_evap_liq_up', axes(1:2),   &
             Time, 'col intg enthalpy tendency from evaporation of &
             &liquid condensate in mesoscale updrafts',  &
             'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(7)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_evap_liq_dn', axes(1:2),   &
             Time, 'col intg enthalpy tendency from evaporation &
             &of liquid condensate in mesoscale downdrafts',  &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(8)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_depo_ice', axes(1:2),   &
             Time, 'col intg enthalpy tendency from mesoscale &
              &deposition on ice condensate',  &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(9)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_cd_ice', axes(1:2),   &
             Time, 'col intg enthalpy tendency from mesoscale ice &
             &condensation', 'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(10)    = register_diag_field    &
            (mod_name, 'ci_enth_cell_evap_ice', axes(1:2),   &
             Time, 'col intg enthalpy tendency from evap of ice &
              &condensate', 'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(11)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_evap_ice_up', axes(1:2),   &
             Time, 'col intg enthalpy tendency from evaporation of &
             &ice condensate in mesoscale updrafts',  'J/m**2 / day',  &
             missing_value=missing_value)

      id_ci_enthalpy_budget(12)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_evap_ice_dn', axes(1:2),   &
             Time, 'col intg enthalpy tendency from evaporation of &
             &ice condensate in mesoscale downdrafts',  &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(13)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_freeze', axes(1:2),   &
             Time, 'col intg enthalpy tendency from the freezing of &
             &liquid condensate when it enters the mesoscale &
             &circulation',  'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(14)    = register_diag_field    &
            (mod_name, 'ci_enth_cell_freeze', axes(1:2),   &
             Time, 'col intg enthalpy tendency from the freezing of &
             &liquid cell condensate', 'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(15)    = register_diag_field    &
            (mod_name, 'ci_enth_cell_precip_melt', axes(1:2),   &
             Time, 'col intg enthalpy tendency from the melting of &
             &cell frozen liquid and ice that is precipitating out',  &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(16)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_melt', axes(1:2),   &
             Time, 'col intg enthalpy tendency from melting bogus &
              &frozen condensate',  'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(17)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_precip_melt', axes(1:2),   &
             Time, 'col intg enthalpy tendency from the melting of &
              &frozen mesoscale precipitation',  &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(18)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_dynam_up', axes(1:2),   &
             Time, 'col intg enthalpy tendency from mesoscale updraft',&
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_enthalpy_budget(19)    = register_diag_field    &
            (mod_name, 'ci_enth_meso_dynam_dn', axes(1:2),   &
             Time, 'col intg enthalpy tendency from mesoscale &
             &downdraft',  'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_prcp_heat_frz_cell =  register_diag_field & 
            (mod_name, 'ci_prcp_heat_frz_cell', axes(1:2),   &
             Time, 'col intg heat removed by frozen cell precip', &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_prcp_heat_liq_cell =  register_diag_field & 
            (mod_name, 'ci_prcp_heat_liq_cell', axes(1:2),   &
             Time, 'col intg heat removed by liquid cell precip', &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_prcp_heat_frz_meso =  register_diag_field & 
            (mod_name, 'ci_prcp_heat_frz_meso', axes(1:2),   &
             Time, 'col intg heat removed by frozen meso precip', &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_prcp_heat_liq_meso =  register_diag_field & 
            (mod_name, 'ci_prcp_heat_liq_meso', axes(1:2),   &
             Time, 'col intg heat removed by liquid meso precip', &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_prcp_heat_total =  register_diag_field & 
            (mod_name, 'ci_prcp_heat_total', axes(1:2),   &
             Time, 'col intg total heat removed by precip', &
              'J/m**2 / day',    &
             missing_value=missing_value)

      id_ci_prcp_total =  register_diag_field & 
            (mod_name, 'ci_prcp_total', axes(1:2),   &
             Time, 'col intg total precip', &
              'mm / day',    &
             missing_value=missing_value)

    endif

      id_leff          = register_diag_field    &
            (mod_name, 'leff_don', axes(1:2),   &
             Time, 'effective latent heat with donner precip ',  &
             'J/kg(h2o)',  missing_value=missing_value)

!    heating rate:
      id_cemetf_deep = register_diag_field    &
            (mod_name, 'cemetf_deep', axes(1:3),   &
             Time, 'heating rate, c + m ', 'K/s',   &
             missing_value=missing_value)

!    cell entropy flux convergence:
      id_ceefc_deep = register_diag_field   &
            (mod_name, 'ceefc_deep', axes(1:3),   &
             Time, 'cell entrpy flx cnvrgnc', 'K/s',   &
             missing_value=missing_value)

!    cell condensation / evaporation:
      id_cecon_deep = register_diag_field      &
            (mod_name, 'cecon_deep', axes(1:3),   &
             Time, 'cell cond/evap ', 'K/s',   &
             missing_value=missing_value)

!    cell moisture flux convergence:
      id_cemfc_deep = register_diag_field       &
            (mod_name, 'cemfc_deep', axes(1:3),   &
             Time, 'cell moist flx cnvgnc', 'kg(h2o)/kg/s',   &
             missing_value=missing_value)

!    moistening rate:
      id_cememf_deep = register_diag_field        &
            (mod_name, 'cememf_deep', axes(1:3),   &
             Time, 'moistening rate, c + m ', 'kg(h2o)/kg/s',   &
             missing_value=missing_value)

!    moistening rate after adjustment for negative vapor mixing ratio:
      id_cememf_mod_deep = register_diag_field       &
            (mod_name, 'cememf_mod_deep', axes(1:3),&
             Time, 'mod cememf due to negative q ', 'kg(h2o)/kg/s',   &
             missing_value=missing_value)

!    cell + mesoscale cloud fraction:
      id_cual_deep = register_diag_field      &
            (mod_name, 'cual_deep', axes(1:3),   &
             Time, 'c + m cld frac ', 'percent',   &
             missing_value=missing_value)

!    heating rate due to freezing:
      id_fre_deep = register_diag_field     &
            (mod_name, 'fre_deep', axes(1:3),   &
             Time, 'freezing ', 'K/sec',   &
             missing_value=missing_value)

!    heating rate due to melting:
      id_elt_deep = register_diag_field         &
            (mod_name, 'elt_deep', axes(1:3),   &
             Time, 'melting', 'K/sec',   &
             missing_value=missing_value)

!    deposition in mesoscale updraft:
      id_cmus_deep = register_diag_field        &
            (mod_name, 'cmus_deep', axes(1:3),   &
             Time, 'meso-up deposition', 'kg(h2o)/kg/sec)',   &
             missing_value=missing_value)

!    evaporation in convective downdraft:
      id_ecds_deep = register_diag_field    &
            (mod_name, 'ecds_deep', axes(1:3),   &
             Time, 'convective dwndrft evap ', 'kg(h2o)/kg/sec', &
             missing_value=missing_value)

!    evaporation / sublimation in convective updraft:
      id_eces_deep = register_diag_field       &
            (mod_name, 'eces_deep', axes(1:3),   &
             Time, 'convective updrft evap/subl ', 'kg(h2o)/kg/sec',  &
             missing_value=missing_value)

!    sublimation in mesoscale downdraft:
      id_emds_deep = register_diag_field     &
            (mod_name, 'emds_deep', axes(1:3),   &
             Time, 'meso-dwn subl ', 'kg(h2o)/kg/sec',   &
             missing_value=missing_value)

!    sublimation in mesoscale updraft:
      id_emes_deep = register_diag_field        &
            (mod_name, 'emes_deep', axes(1:3),   &
             Time, 'meso-up subl ', 'kg(h2o)/kg/sec',   &
             missing_value=missing_value)

!    mesoscale moisture flux convergence:
      id_qmes_deep = register_diag_field     &
             (mod_name, 'qmes_deep', axes(1:3),   &
              Time, 'meso moist flux conv', 'kg(h2o)/kg/sec',   &
              missing_value=missing_value)

!    transfer of vapor from cells to mesoscale:
      id_wmps_deep = register_diag_field      &
             (mod_name, 'wmps_deep', axes(1:3),   &
              Time, 'meso redistrib of vapor from cells',  &
              'kg(h2o)/kg/sec', missing_value=missing_value)

!    deposition of vapor from cells to mesoscale:
      id_wmms_deep = register_diag_field         &
             (mod_name, 'wmms_deep', axes(1:3),   &
              Time, 'meso depo of vapor from cells',    &
              'kg(h2o)/kg/sec',  missing_value=missing_value)

!    mesoscale entropy flux convergesnce:
      id_tmes_deep = register_diag_field         &
            (mod_name, 'tmes_deep', axes(1:3),   &
             Time, 'meso entropy flux conv',  'K/sec',   &
              missing_value=missing_value)
 
!    mass flux in mesoscale downdrafts:    
      id_dmeml_deep = register_diag_field      &
            (mod_name, 'dmeml_deep', axes(1:3), &  
             Time, 'mass flux meso dwndrfts', 'kg/((m**2) s)',   &
             missing_value=missing_value)

!    mass flux in cell updrafts:
      id_uceml_deep = register_diag_field     &
            (mod_name, 'uceml_deep', axes(1:3), &
             Time, 'mass flux cell updrfts', 'kg/((m**2) s)',   &
             missing_value=missing_value)

!    mass flux in mesoscale updrafts:
      id_umeml_deep = register_diag_field       &
            (mod_name, 'umeml_deep', axes(1:3), &
             Time, 'mass flux meso updrfts', 'kg/((m**2) s)',   &
             missing_value=missing_value)

!    mesoscale ice mass mixing ratio:
      id_xice_deep = register_diag_field     &
            (mod_name, 'xice_deep', axes(1:3),  &
             Time, 'meso ice mass mixing ratio ', 'kg(ice)/kg',   &
             missing_value=missing_value)

!    mesoscale liquid mass mixing ratio:
      id_xliq_deep = register_diag_field       &
            (mod_name, 'xliq_deep', axes(1:3),  &
             Time, 'meso liq mass mixing ratio ', 'kg(liq)/kg',   &
             missing_value=missing_value)

!    detrained mass flux:
      id_detmfl_deep = register_diag_field       &
            (mod_name, 'detmfl_deep', axes(1:3),  &
             Time, 'detrained mass flux ', 'kg/((m**2) s)',   &
             missing_value=missing_value)

!---------------------------------------------------------------------
!    if tracers are being transported by donner_deep_mod, allocate diag-
!    nostic indices for each tracer and register their diagnostics.
!---------------------------------------------------------------------
      if (ntracers > 0) then
        allocate (id_qtren1 (ntracers))
        allocate (id_qtmes1 (ntracers))
        allocate (id_wtp1   (ntracers))
        allocate (id_qtceme (ntracers))
        allocate (id_total_wet_dep (ntracers))
        allocate (id_meso_wet_dep (ntracers))
        allocate (id_cell_wet_dep (ntracers))
        allocate (id_qtren1_col (ntracers))
        allocate (id_qtmes1_col (ntracers))
        allocate (id_wtp1_col   (ntracers))
        allocate (id_qtceme_col (ntracers))
        allocate (id_total_wet_dep_col (ntracers))
        allocate (id_meso_wet_dep_col (ntracers))
        allocate (id_cell_wet_dep_col (ntracers))
        do nn=1,ntracers

!    tracer tendency due to cells:
          id_qtren1(nn) = register_diag_field     &
                (mod_name, trim(Don_save%tracername(nn)) // '_qtren1',  &
                 axes(1:3), Time,  &
                 trim(Don_save%tracername(nn)) // ' cell tendency ', &
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

!    tracer tendency due to mesoscale circulation:
          id_qtmes1(nn) = register_diag_field    &
                (mod_name, trim(Don_save%tracername(nn)) // '_qtmes1', &
                 axes(1:3), Time,   &
                 trim(Don_save%tracername(nn)) //' mesoscale tendency',&
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

!    tracer tendency due to mesoscale redistribution:
          id_wtp1(nn) = register_diag_field         &
                (mod_name, trim(Don_save%tracername(nn)) // '_wtp1',  &
                 axes(1:3), Time,  &
                 trim(Don_save%tracername(nn)) //' mesoscale redist',&
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

 !    tracer tendency due to deep convective wet deposition:
          id_total_wet_dep(nn) = register_diag_field         &
              (mod_name, trim(Don_save%tracername(nn)) // '_totwdep',  &
                 axes(1:3), Time,  &
                 trim(Don_save%tracername(nn)) //' deep conv wet depo',&
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

!    tracer tendency due to wet deposition in mesoscale updrafts:
         id_meso_wet_dep(nn) = register_diag_field         &
                 (mod_name, trim(Don_save%tracername(nn)) // '_mwdep', &
                  axes(1:3), Time,   &
                 trim(Don_save%tracername(nn)) //' mesoscale wet depo',&
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

!    tracer tendency due to wet deposition in cells:
          id_cell_wet_dep(nn) = register_diag_field         &
                (mod_name, trim(Don_save%tracername(nn)) // '_cwdep', &
                 axes(1:3), Time,  &
                 trim(Don_save%tracername(nn)) //' cell wet depo',&
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

!    total tracer tendency:
          id_qtceme(nn) = register_diag_field     &
                (mod_name, trim(Don_save%tracername(nn)) // '_qtceme', &
                 axes(1:3), Time,  &
                 trim(Don_save%tracername(nn)) // ' total tendency ',&
                 trim(Don_save%tracer_units(nn))//'/s', &
                 missing_value=missing_value)

!    column-integrated tracer tendency due to cells:
          id_qtren1_col(nn) = register_diag_field      &
                (mod_name,       &
                 trim(Don_save%tracername(nn)) // '_qtren1_col',  &
                 axes(1:2), Time,  & 
                 'column integrated ' //trim(Don_save%tracername(nn)) //&
                 ' cell tendency ', &
                 trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                 missing_value=missing_value)

!    column-integrated tracer tendency due to mesoscale circulation:
          id_qtmes1_col(nn) = register_diag_field    &
                (mod_name,          &
                 trim(Don_save%tracername(nn)) // '_qtmes1_col',  &
                 axes(1:2), Time,   &
                 'column integrated ' //trim(Don_save%tracername(nn)) //&
                 ' mesoscale tendency',&
                trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                 missing_value=missing_value)

!    column-integrated tracer tendency due to mesoscale redistribution:
          id_wtp1_col(nn) = register_diag_field     &
                (mod_name,  &
                 trim(Don_save%tracername(nn)) // '_wtp1_col',   &
                 axes(1:2), Time,  &
                 'column integrated '//trim(Don_save%tracername(nn)) // &
                 ' mesoscale redist',&
               trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                missing_value=missing_value)

!    column-integrated tracer tendency due to deep convective wet 
!    deposition: 
          id_total_wet_dep_col(nn) = register_diag_field     &
                 (mod_name,  &
                  trim(Don_save%tracername(nn)) // '_totwdep_col',   &
                  axes(1:2), Time,  &
                'column integrated '//trim(Don_save%tracername(nn)) // &
                ' deep convective wet depo',&
                 trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                 missing_value=missing_value)

!    column-integrated tracer tendency due to mesocscale updraft  wet 
!    deposition: 
          id_meso_wet_dep_col(nn) = register_diag_field     &
                (mod_name,  &
                  trim(Don_save%tracername(nn)) // '_mwdep_col',   &
                  axes(1:2), Time,  &
                'column integrated '//trim(Don_save%tracername(nn)) // &
                 ' meso updraft wet depo',&
                  trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                 missing_value=missing_value)

!    column-integrated tracer tendency due to wet deposition in cells:
          id_cell_wet_dep_col(nn) = register_diag_field     &
                (mod_name,  &
                 trim(Don_save%tracername(nn)) // '_cwdep_col',   &
                  axes(1:2), Time,  &
                'column integrated '//trim(Don_save%tracername(nn)) // &
                  ' cell wet depo',&
                 trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                  missing_value=missing_value)

!    column-integrated total tracer tendency:
          id_qtceme_col(nn) = register_diag_field     &
                (mod_name,  &
                 trim(Don_save%tracername(nn)) // '_qtceme_col',  &
                 axes(1:2), Time,  &
                 'column integrated ' //trim(Don_save%tracername(nn)) //&
                 ' total tendency ', &
                  trim(Don_save%tracer_units(nn)) // '* kg/(m**2 s) ', &
                 missing_value=missing_value)
        end do
      endif

!    mesoscale ice generalized effective size:
      id_dgeice_deep = register_diag_field    &
            (mod_name, 'dgeice_deep', axes(1:3), &
             Time, 'meso ice gen eff size ', 'micrometers',   &
             missing_value=missing_value)

!    cell ice mixing ratio:
      id_cuqi_deep = register_diag_field         &
            (mod_name, 'cuqi_deep', axes(1:3),  &
             Time, 'cell ice ', 'kg(H2O)/kg',   &
             missing_value=missing_value)

!    cell liquid mixing ratio:
      id_cuql_deep = register_diag_field     &
            (mod_name, 'cuql_deep', axes(1:3),  &
             Time, 'cell liquid ', 'kg(H2O)/kg',   &
             missing_value=missing_value)

!    cell liquid generalized effective size:
      id_dgeliq_deep = register_diag_field    &
            (mod_name, 'dgeliq_deep', axes(1:3), &
             Time, 'cell liq gen eff size ', 'micrometers',   &
             missing_value=missing_value)

!    pressure at lifting condensation level:
      id_plcl_deep = register_diag_field       &
            (mod_name, 'plcl_deep', axes(1:2),   &
             Time, 'pressure at lcl ', 'Pa ',   &
             missing_value=missing_value)

!    pressure at level of free convection:
      id_plfc_deep = register_diag_field     &
            (mod_name, 'plfc_deep', axes(1:2),   &
             Time, 'pressure at lfc ', 'Pa ',   &
             missing_value=missing_value)

!    pressure at level of zero buoyancy:  
      id_plzb_deep = register_diag_field      &
            (mod_name, 'plzb_deep', axes(1:2),   &
             Time, 'pressure at lzb ', 'Pa ',   &
             missing_value=missing_value)

!    convective available potential energy (cape):
      id_xcape_deep = register_diag_field      &
            (mod_name, 'xcape_deep', axes(1:2),  &
             Time, 'cape', 'J/kg',   &
             missing_value=missing_value)

!    convective inhibition:
      id_coin_deep = register_diag_field      &
            (mod_name, 'coin_deep', axes(1:2),   &
             Time, 'convective inhibition ', 'J/kg',   &
             missing_value=missing_value)

!    time tendency of cape:
      id_dcape_deep = register_diag_field      &
            (mod_name, 'dcape_deep', axes(1:2), &
             Time, 'time tendency of cape ', 'J/kg/sec',   &
             missing_value=missing_value)

!    column integrated water vapor:
      id_qint_deep = register_diag_field    &
            (mod_name, 'qint_deep', axes(1:2),   &
             Time, 'column moisture ', 'kg(h2o)/m**2',   &
             missing_value=missing_value)

!    fractional area of cumulus ensemble member:
      id_a1_deep = register_diag_field           &
            (mod_name, 'a1_deep', axes(1:2),   &
             Time, 'fractional area of cu subensemble ', 'percent',   &
             missing_value=missing_value)

!    fractional area of largest cumulus ensemble member:
      id_amax_deep = register_diag_field      &
            (mod_name, 'amax_deep', axes(1:2),   &
             Time, 'fractional area of largest cu subensemble ',  &
             'percent',  missing_value=missing_value)

!    upper limit onfractional area based on moisture constraint:
      id_amos_deep = register_diag_field      &
            (mod_name, 'amos_deep', axes(1:2),   &
             Time, 'uppr lmt on frac area from moisture', 'percent', &
             missing_value=missing_value)

!    area-weighted total precipitation:
      id_tprea1_deep = register_diag_field         &
            (mod_name, 'tprea1_deep', axes(1:2), &
             Time, 'area wtd total precip ', 'mm/day',   &
             missing_value=missing_value)

!    mesoscale cloud fraction:
      id_ampta1_deep = register_diag_field       &
            (mod_name, 'ampta1_deep', axes(1:2), &
             Time, 'meso cld frac', 'percent',   &
             missing_value=missing_value)

!    accumulated low-level vertical displacement:
      id_omint_deep = register_diag_field      &
            (mod_name, 'omint_deep', axes(1:2), &
             Time, 'accumulated low-lvl displ', 'Pa ',   &
             missing_value=missing_value)

!    area-weighted convective precipitation:
      id_rcoa1_deep = register_diag_field     &
            (mod_name, 'rcoa1_deep', axes(1:2),  &
             Time, 'area wtd cnvctv precip ', 'mm/day',   &
             missing_value=missing_value)

!----------------------------------------------------------------------

    if (do_ensemble_diagnostics) then
!
      allocate ( id_cpre_cem(ncem))
      allocate ( id_pb_cem(ncem))
      allocate ( id_ptma_cem(ncem))
      allocate ( id_h1_cem(ncem))
      allocate ( id_qlw_cem(ncem))
      allocate ( id_cfi_cem(ncem))
      allocate ( id_wv_cem(ncem))
      allocate ( id_rcl_cem(ncem))
!  Donner cumulus ensemble member diagnostics
!
!    GCM model pressure field on full levels:
      id_pfull_cem = register_diag_field  &
            (mod_name, 'p_full', axes(1:3), &
             Time, 'GCM model pressure on full levels (lo-res)', 'Pa', &
             missing_value=missing_value)

!    GCM model pressure field on half levels:
      id_phalf_cem = register_diag_field  &
            (mod_name, 'p_half', axes(half), &
             Time, 'GCM model pressure on half levels (lo-res)', 'Pa', &
             missing_value=missing_value)

!    GCM model height field on full levels:
      id_zfull_cem = register_diag_field  &
            (mod_name, 'z_full', axes(1:3), &
             Time, 'GCM model height on full levels (lo-res)', 'm', &
             missing_value=missing_value)

!    GCM model height field on half levels:
      id_zhalf_cem = register_diag_field  &
            (mod_name, 'z_half', axes(half), &
             Time, 'GCM model height on half levels (lo-res)', 'm', &
             missing_value=missing_value)

!    GCM model temperature field on full levels:
      id_temp_cem = register_diag_field  &
            (mod_name, 'temp', axes(1:3), &
             Time, 'GCM model temperature on full levels (lo-res)', 'K', &
             missing_value=missing_value)

!    GCM model mixing ratio field on full levels:
      id_mixing_ratio_cem = register_diag_field  &
            (mod_name, 'mixing_ratio', axes(1:3), &
             Time, 'GCM model mixing ratio on full levels (lo-res)', &
             'kg(h2o)/kg(dry air)', &
             missing_value=missing_value)

      do nn=1,ncem

        if( nn <= 9 )then
          write( chvers, '(i1)' ) nn
        else if( nn <= 99 )then
          write( chvers, '(i2)' ) nn
        else
          print *, 'Error in subroutine register_fields:'
          print *, '  number of specified cumulus ensemble members = ',ncem
          print *, '  is more than current limit of 99.'
!          stop
        call error_mesg ('fms_donner_mod', 'register_fields: & 
         &Error in subroutine register_fields : number of specified &
         &cumulus ensemble members is more than current limit of 99.',&
                                                                  FATAL) 
        endif

!    area-weighted convective precipitation rate:
        id_cpre_cem(nn) = register_diag_field  &
            (mod_name, 'cpre_cem'//TRIM(chvers), axes(1:2), &
             Time, 'area wtd cnvctv precip rate - member '//TRIM(chvers), &
             'mm/day', &
             missing_value=missing_value)

!    pressure at cloud base:
        id_pb_cem(nn) = register_diag_field  &
            (mod_name, 'pb_cem'//TRIM(chvers), axes(1:2), &
             Time, 'pressure at cloud base - member '//TRIM(chvers), &
             'Pa', &
             missing_value=missing_value)

!    pressure at cloud top:
        id_ptma_cem(nn) = register_diag_field  &
            (mod_name, 'ptma_cem'//TRIM(chvers), axes(1:2), &
             Time, 'pressure at cloud top - member '//TRIM(chvers), &
             'Pa', &
             missing_value=missing_value)

!    condensation rate profile on lo-res grid:
        id_h1_cem(nn) = register_diag_field  &
            (mod_name, 'h1_cem'//TRIM(chvers), axes(1:3), &
             Time, 'condensation rate profile - member '//TRIM(chvers), &
             'kg(h2o)/(kg(dry air) sec)', &
             missing_value=missing_value)
        
! IF LOOP HERE:
       if (.not. do_donner_plume) then
!    cloud water profile on lo-res grid:
        id_qlw_cem(nn) = register_diag_field  &
            (mod_name, 'qlw_cem'//TRIM(chvers), axes(1:3), &
             Time, 'cloud water profile - member '//TRIM(chvers), &
            'kg(h2o)/kg(air)', &
             missing_value=missing_value)

!    fraction of condensate that is ice on lo-res grid:
        id_cfi_cem(nn) = register_diag_field  &
            (mod_name, 'cfi_cem'//TRIM(chvers), axes(1:3), &
             Time, 'condensate ice fraction - member '//TRIM(chvers), &
             'fraction', &
             missing_value=missing_value)

!    vertical velocity profile in plume on lo-res grid:
        id_wv_cem(nn) = register_diag_field  &
            (mod_name, 'wv_cem'//TRIM(chvers), axes(1:3), &
             Time, 'plume vertical velocity - member '//TRIM(chvers), &
             'm / s', &
             missing_value=missing_value)

!    cloud radius profile in plume on lo-res grid:
        id_rcl_cem(nn) = register_diag_field  &
            (mod_name, 'rcl_cem'//TRIM(chvers), axes(1:3), &
             Time, 'plume cloud radius - member '//TRIM(chvers), &
             'm', &
             missing_value=missing_value)

        else
!    cloud water profile on hi-res grid:
        id_qlw_cem(nn) = register_diag_field  &
            (mod_name, 'qlw_cem'//TRIM(chvers), donner_axes(cldindices), &
             Time, 'cloud water profile - member '//TRIM(chvers), &
            'kg(h2o)/kg(air)', &
             missing_value=missing_value)

!    fraction of condensate that is ice on hi-res grid:
        id_cfi_cem(nn) = register_diag_field  &
            (mod_name, 'cfi_cem'//TRIM(chvers), donner_axes(cldindices), &
             Time, 'condensate ice fraction - member '//TRIM(chvers), &
             'fraction', &
             missing_value=missing_value)

!    vertical velocity profile in plume on hi-res grid:
        id_wv_cem(nn) = register_diag_field  &
            (mod_name, 'wv_cem'//TRIM(chvers), donner_axes(cldindices), &
             Time, 'plume vertical velocity - member '//TRIM(chvers), &
             'm / s', &
             missing_value=missing_value)

!    cloud radius profile in plume on hi-res grid:
        id_rcl_cem(nn) = register_diag_field  &
            (mod_name, 'rcl_cem'//TRIM(chvers), donner_axes(cldindices), &
             Time, 'plume cloud radius - member '//TRIM(chvers), &
             'm', &
             missing_value=missing_value)

        endif
      enddo

!    area-weighted mesoscale precipitation rate:
        id_mpre_cem = register_diag_field  &
            (mod_name, 'mpre_cem', axes(1:2), &
             Time, 'area wtd mesoscale precip rate ', &
             'mm/day', &
             missing_value=missing_value)

!    fractional area sum:
      id_a1_cem = register_diag_field  &
            (mod_name, 'a1_cem', axes(1:2), &
             Time, 'fractional area sum', 'fraction', &
             missing_value=missing_value)

!    cloud fraction, cells+meso, normalized by a(1,p_b) on lo-res grid:
      id_cual_cem = register_diag_field  &
            (mod_name, 'cual_cem', axes(1:3), &
             Time, 'cloud fraction, cells+meso, normalized by a(1,p_b)', &
             'fraction', &
             missing_value=missing_value)

!    time tendency of temperature due to deep convection on lo-res grid:
      id_tfrc_cem = register_diag_field  &
            (mod_name, 'tfrc_cem', axes(1:3), &
             Time, 'temperature tendency due to deep convection (lo-res)', &
             'K/sec', missing_value=missing_value)

    endif ! (do_ensemble_diagnostics)

end subroutine register_fields 



!####################################################################

subroutine read_restart (ntracers, Time, Initialized, Nml, Don_save)

!---------------------------------------------------------------------
!    subroutine read_restart reads a native mode restart file, which are
!    not written by this code version. currently only restart version #8 
!    may be read to provide initial conditions for an experiment run with
!    this code version. this routine remains as a template for any user 
!    who is unable to process the current standard netcdf restart file, 
!    and must modify the current code to write a native mode file. 
!---------------------------------------------------------------------

integer, intent(in)         :: ntracers
type(time_type), intent(in) :: Time
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     

!----------------------------------------------------------------------
!   intent(in) variables:
!
!     ntracers               number of tracers to be transported by
!                            the donner deep convection parameterization
!     Time                   current time [ time_type ]
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!   local variables:

      logical, dimension(ntracers)  :: success
      integer                       :: old_freq
      integer                       :: unit, vers
      character(len=8)              :: chvers
      character(len=32)             :: tracername_in
      integer                       :: ntracers_in
      integer                       :: n, nn

!-----------------------------------------------------------------------
!   local variables:
!
!     success      logical array indicating whether data for each trans-
!                  ported tracer is present in restart file
!     old_freq     donner_Deep_freq used in job which wrote the restart
!                  file, used in versions 5 and higher [ seconds ]
!     unit         io unit number assigned to restart file
!     vers         restart version number of file being read
!     chvers       character representation of restart version of file
!                  being read
!     tracername_in
!                  tracer name read from restart file, used in versions
!                  6, 7 and 8
!     ntracers_in  number of tracers contained in restart file, used in
!                  versions 6, 7 and 8.
!     n, nn, k     do-loop indices
!
!--------------------------------------------------------------------


!-------------------------------------------------------------------- 
!    open the restart file.
!--------------------------------------------------------------------- 
      unit = open_restart_file ('INPUT/donner_deep.res', 'read')

!--------------------------------------------------------------------- 
!    read and check restart version number. 
!-------------------------------------------------------------------- 
      read (unit) vers 
      if ( .not. any(vers == restart_versions) ) then 
        write (chvers,'(i4)') vers 
        call error_mesg ('donner_deep_mod', 'read_restart: &  
            &restart version '//chvers//' cannot be used'//& 
            'as a restart file for the current code release; &
            & a COLDSTART will be initiated', NOTE)
         call process_coldstart (Time, Initialized, Nml, Don_save)
         return
      endif 
      if (vers >= 9) then 
        call error_mesg ('donner_deep_mod', 'read_restart: & 
         &native mode restart versions above #8 are totally the &
         &responsibility of the user; be sure you process it properly!',&
                                                                   NOTE) 
      endif 

!-------------------------------------------------------------------- 
!    read the time remaining before the next calculation call ( which
!    becomes Initialized%conv_alarm, in seconds) and the donner deep 
!    frequency used in the job writing the file, also in seconds 
!    (old_freq).
!---------------------------------------------------------------------
      read (unit) Initialized%conv_alarm, old_freq

!--------------------------------------------------------------------
!    determine if it is desired to change the donner_deep_freq from that
!    used in the previous job. if so, modify the alarm as read from the 
!    restart file.
!--------------------------------------------------------------------
      if (Nml%donner_deep_freq /= old_freq ) then
        Initialized%conv_alarm = Initialized%conv_alarm - old_freq + &
                                 Nml%donner_deep_freq
        if (mpp_pe() == mpp_root_pe()) then
          call error_mesg ('donner_deep_mod', 'read_restart:  &
            &donner_deep time step has changed', NOTE)
        endif
      endif

!---------------------------------------------------------------------
!    read the total heating and moistening rates produced by the donner
!    deep convection parameterization from the restart file.
!---------------------------------------------------------------------
      call read_data (unit, Don_save%cemetf)
      call read_data (unit, Don_save%cememf)

!----------------------------------------------------------------------
!    read the mass flux and large-scale cloud tendencies needed by 
!    strat_cloud_mod. if this is an earlier file, set these values to 
!    0.0.
!----------------------------------------------------------------------
      call read_data (unit, Don_save%mass_flux)
      call read_data (unit, Don_save%dql_strat )
      call read_data (unit, Don_save%dqi_strat )
      call read_data (unit, Don_save%dqa_strat )

!----------------------------------------------------------------------
!    read the accumulated vertical displacement of a boundary layer 
!    parcel.
!----------------------------------------------------------------------
      call read_data (unit, Don_save%parcel_disp)

!----------------------------------------------------------------------
!    read the total precipitation produced by the donner parameteriz-
!    ation.
!----------------------------------------------------------------------
      call read_data (unit, Don_save%tprea1)

!----------------------------------------------------------------------
!    read the temperature, mixing ratio and pressure fields at the lag 
!    time step from the restart file.        
!----------------------------------------------------------------------
      call read_data (unit, Don_save%lag_temp)
      call read_data (unit, Don_save%lag_vapor)
      call read_data (unit, Don_save%lag_press)

!----------------------------------------------------------------------
!    two fields which are needed by strat_cloud_mod are available and 
!    are read in. 
!----------------------------------------------------------------------
      call read_data (unit, Don_save%humidity_area)
      if (vers == 9) then
        call error_mesg ('donner_deep_mod', &
          'version 9 not acceptable restart -- needs to have humidity_factor&
            & rather than humidity_ratio', FATAL)
      else
        call read_data (unit, Don_save%humidity_factor)
      endif

!------------------------------------------------------------------
!    if tracers are to be transported by the donner parameterization,
!    determine if the current tendencies are available on the restart.
!------------------------------------------------------------------
      if (Initialized%do_donner_tracer) then

!------------------------------------------------------------------
!    read the number of tracers whose tendencies are included in 
!    this file. tracer tendencies are available only in version #6 and
!    higher.
!-------------------------------------------------------------------
        success = .false.
        read (unit) ntracers_in 

!--------------------------------------------------------------------
!    read each restart file tracer's name and see if it is to be 
!    transported in the current job.
!--------------------------------------------------------------------
        do n=1,ntracers_in
          read (unit) tracername_in
          do nn=1,ntracers

!--------------------------------------------------------------------
!    if the tracer is needed in the current job, read its data and
!    store it in the appropriate array. write a note indicating that 
!    the data has bben found and set a logical variable to also 
!    indicate such. exit this loop and process the next tracer present
!    in the restart file.
!--------------------------------------------------------------------
            if (trim(tracername_in) ==     &
                trim(Don_save%tracername(nn))) then
              call read_data(unit, Don_save%tracer_tends(:,:,:,nn))
              if (mpp_pe() == mpp_root_pe() ) then
                call error_mesg ('donner_deep_mod', 'read_restart: &
                         &found tracer restart data for ' // &
                         trim(Don_save%tracername(nn)), NOTE)
              endif
              success(nn) = .true.
              exit 

!---------------------------------------------------------------------
!    if the tracer in the restart file is not needed by the current
!    job, do a dummy read to get to the next record.
!---------------------------------------------------------------------
            else 
              if (nn == ntracers) then
                read (unit)
              endif
            endif
          end do
        end do

!---------------------------------------------------------------------
!    after having completely read the file, initialize the time ten-
!    dencies to 0.0 for any tracers whose tinme tendencies were not
!    found on the restart file and enter a message in the output file.
!---------------------------------------------------------------------
        do nn=1,ntracers
          if (success(nn) ) then
          else
            call error_mesg ('donner_deep_mod', 'read_restart: &
                  &did not find tracer restart data for ' //  &
                  trim(Don_save%tracername(nn)) //  &
                  '; am initializing tendency to 0.0', NOTE)
            Don_save%tracer_tends(:,:,:,nn) = 0.0
          endif   
        end do
      endif  ! (do_donner_tracer)

!-------------------------------------------------------------------- 
!    close the restart file.
!--------------------------------------------------------------------- 
      call close_file (unit)

!--------------------------------------------------------------------- 



end subroutine read_restart

!#####################################################################

subroutine process_coldstart (Time, Initialized, Nml, Don_save)

!-----------------------------------------------------------------------
!    subroutine process_coldstart provides initialization that is needed
!    when the job is a donner_deep coldstart, or if the user-supplied 
!    restart file is not usable for a restart with the current code 
!    version.
!-----------------------------------------------------------------------

type(time_type), intent(in) :: Time
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     

!---------------------------------------------------------------------
!   intent(in) variables:
!
!        Time      current time [ time_type, secs and days ]
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      integer  :: days, secs   ! components of current time

!---------------------------------------------------------------------
!    set the coldstart flag to .true.. set the time until the first cal-
!    culation call to donner_deep_mod, donner_deep calculation calls will
!    be every donner_deep_freq seconds after the start of the day.
!---------------------------------------------------------------------
      Initialized%coldstart = .true.
      call get_time (Time, secs, days)
      if (secs == 0) then    ! i.e., 00Z
        Initialized%conv_alarm = Nml%donner_deep_freq
      else 
        Initialized%conv_alarm = Nml%donner_deep_freq -   &
                                 MOD (secs, Nml%donner_deep_freq)
      endif

!----------------------------------------------------------------------
!    initialize the variables which must be returned from donner_deep_mod
!    on the first step when coldstarting.
!----------------------------------------------------------------------
      Don_save%cemetf            = 0.
      Don_save%cememf            = 0.
      Don_save%tracer_tends      = 0.
      Don_save%mass_flux         = 0.
      Don_save%mflux_up          = 0.
      Don_save%cell_up_mass_flux = 0.
      Don_save%det_mass_flux     = 0.
      Don_save%dql_strat         = 0.
      Don_save%dqi_strat         = 0.
      Don_save%dqa_strat         = 0.
      Don_save%humidity_area     = 0.
      Don_save%humidity_factor   = 0.
      Don_save%tprea1            = 0.
      Don_save%parcel_disp       = 0.

!----------------------------------------------------------------------


end subroutine process_coldstart

!#####################################################################
! register restart field to be written to restart file.
subroutine fms_donner_register_restart(fname, Initialized, ntracers, Don_save, Nml)
  character(len=*),                 intent(in) :: fname
  type(donner_initialized_type), intent(inout) :: Initialized
  integer,                          intent(in) :: ntracers
  type(donner_save_type),        intent(inout) :: Don_save
  type(donner_nml_type),         intent(inout) :: Nml
  character(len=64)                            :: fname2
  integer :: id_restart, n

   call get_mosaic_tile_file(fname, fname2, .false. ) 
   allocate(Don_restart)
   if(trim(fname2) == trim(fname)) then
      Til_restart => Don_restart
      in_different_file = .false.
   else
      in_different_file = .true.
      allocate(Til_restart)
   endif

   id_restart = register_restart_field(Don_restart, fname, 'conv_alarm', Initialized%conv_alarm, no_domain = .true.)
   id_restart = register_restart_field(Don_restart, fname, 'donner_deep_freq', Nml%donner_deep_freq, no_domain = .true.)

   if (.not. (write_reduced_restart_file) .or. &
        Initialized%conv_alarm >  Initialized%physics_dt)  then
      id_restart = register_restart_field(Til_restart, fname, 'cemetf', Don_save%cemetf)
      id_restart = register_restart_field(Til_restart, fname, 'cememf', Don_save%cememf)
      id_restart = register_restart_field(Til_restart, fname, 'mass_flux', Don_save%mass_flux)
      id_restart = register_restart_field(Til_restart, fname, 'cell_up_mass_flux', Don_save%cell_up_mass_flux)
      id_restart = register_restart_field(Til_restart, fname, 'det_mass_flux', Don_save%det_mass_flux)
      id_restart = register_restart_field(Til_restart, fname, 'dql_strat', Don_save%dql_strat)
      id_restart = register_restart_field(Til_restart, fname, 'dqi_strat', Don_save%dqi_strat)
      id_restart = register_restart_field(Til_restart, fname, 'dqa_strat', Don_save%dqa_strat)
      id_restart = register_restart_field(Til_restart, fname, 'tprea1', Don_save%tprea1)
      id_restart = register_restart_field(Til_restart, fname, 'humidity_area', Don_save%humidity_area)
      id_restart = register_restart_field(Til_restart, fname, 'humidity_factor', Don_save%humidity_factor)
      if (Initialized%do_donner_tracer) then
         do n=1,ntracers
            id_restart = register_restart_field(Til_restart, fname, 'tracer_tends_'// trim(Don_save%tracername(n)), &
                 Don_save%tracer_tends(:,:,:,n))
         end do
      endif
   endif
   id_restart = register_restart_field(Til_restart, fname, 'parcel_disp', Don_save%parcel_disp)
   id_restart = register_restart_field(Til_restart, fname, 'lag_temp', Don_save%lag_temp)
   id_restart = register_restart_field(Til_restart, fname, 'lag_vapor', Don_save%lag_vapor)
   id_restart = register_restart_field(Til_restart, fname, 'lag_press', Don_save%lag_press)

end subroutine fms_donner_register_restart


!#####################################################################
! <SUBROUTINE NAME="read_restart_nc">
!  <OVERVIEW>
!    read_restart_nc reads a netcdf restart file containing donner_deep
!    restart information.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_restart_nc reads a netcdf restart file containing donner_deep
!    restart information.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_restart_nc
!  </TEMPLATE>
! </SUBROUTINE>
!


subroutine read_restart_nc (ntracers, Initialized, Nml, Don_save)

!-----------------------------------------------------------------------
!    subroutine read_restart_nc reads a netcdf restart file to obtain 
!    the variables needed upon experiment restart. 
!-----------------------------------------------------------------------

integer, intent(in) :: ntracers
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     

!----------------------------------------------------------------------
!   intent(in) variables:
!
!      ntracers    number of tracers being transported by the
!                  donner deep convection parameterization in this job
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      logical,         dimension(ntracers)  :: success
      integer,         dimension(:), allocatable :: ntindices
      type(fieldtype), dimension(:), allocatable :: tracer_fields

      character(len=64)     :: fname2='INPUT/donner_deep.res.tile1'
      character(len=64)     :: fname='INPUT/donner_deep.res.nc'
      character(len=128)    :: tname
      integer               :: ndim, natt, nvar, ntime
      integer               :: old_freq
      integer               :: n_alltracers, iuic
      logical               :: is_tracer_in_restart_file
      integer, dimension(4) :: siz
      logical               :: field_found, field_found2, &
                               field_found4
      integer               :: it, jn, nn

!---------------------------------------------------------------------
!   local variables:
!
!        success          logical indicating if needed data for tracer n 
!                         was obtained from restart file
!        ntindices        array of all tracer indices
!        tracer_fields    field_type variable containing information on
!                         all restart file variables
!        fname2           restart file name without ".nc" appended, 
!                         needed as argument in call to mpp_open
!        fname            restart file name
!        tname            contains successive variable names from 
!                         restart file
!        ndim             number of dimensions in restart file
!        natt             number of attributes in restart file
!        nvar             number of variables in restart file
!        ntime            number of time levels in restart file
!        old_freq         donner_deep_freq as read from restart file;
!                         value used during previous job
!        n_alltracers     number of tracers registered with 
!                         tracer_manager_mod
!        iuic             unit number assigned to restart file
!        is_tracer_in_restart_file  
!                         should we stop searching the restart file 
!                         for the current tracer name because it has 
!                         been found ?
!        siz              sizes (each dimension) of netcdf variable 
!        field_found      is the requested variable in the restart file ?
!                         if it is not, then this is a reduced restart
!                         file
!        field_found2     is the requested variable in the restart file ?
!                         if it is not, then Don_save%det_mass_flux and
!                         Don_save%cell_up_mass_flux must be initialized
!        it, jn, nn       do-loop indices
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!    output a message indicating entrance into this routine.
!--------------------------------------------------------------------
      if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('donner_deep_mod',  'read_restart_nc:&
             &Reading netCDF formatted restart file: &
                                 &INPUT/donner_deep.res.nc', NOTE)
      endif

!-------------------------------------------------------------------
!    read the values of conv_alarm when the restart file was written and
!    the frequency of calculating donner deep convection effects in the
!    job which wrote the file.
!-------------------------------------------------------------------
      call read_data(fname, 'conv_alarm', Initialized%conv_alarm,   &
                                                       no_domain=.true.)
      call read_data(fname, 'donner_deep_freq', old_freq,   &
                                                       no_domain=.true.)
  
!----------------------------------------------------------------------
!    call field_size to determine if variable cemetf is present in the
!    restart file.
!----------------------------------------------------------------------
      call field_size(fname, 'cemetf', siz, field_found=field_found)

!---------------------------------------------------------------------
!    if the frequency of calculating deep convection has changed, 
!    redefine the time remaining until the next calculation.
!---------------------------------------------------------------------
      if (Nml%donner_deep_freq /= old_freq) then
        Initialized%conv_alarm = Initialized%conv_alarm - old_freq +  &
                                 Nml%donner_deep_freq
        if (mpp_pe() == mpp_root_pe()) then
          call error_mesg ('donner_deep_mod', 'read_restart_nc:  &
                   &donner_deep time step has changed', NOTE)
        endif

!----------------------------------------------------------------------
!    if cemetf is not present, then this is a reduced restart file. it 
!    is not safe to change the frequency of calculating donner 
!    effects when reading a reduced restart file, so a fatal error is
!    generated.
!----------------------------------------------------------------------
        if (.not. field_found) then
          call error_mesg ('donner_deep_mod', 'read_restart_nc: &
           & cannot use reduced restart file and change donner_deep_freq&
           & within experiment and guarantee restart reproducibility', &
                                                                  FATAL)
        endif
      endif  !(donner_deep_freq /= old_freq)

!---------------------------------------------------------------------
!    read the restart data that is present in a full restart but absent
!    in a reduced restart.
!---------------------------------------------------------------------
      if (field_found) then
        call read_data (fname, 'cemetf',  Don_save%cemetf)
        call read_data (fname, 'cememf',  Don_save%cememf)            
        call read_data (fname, 'mass_flux', Don_save%mass_flux)
        call read_data (fname, 'dql_strat', Don_save%dql_strat)
        call read_data (fname, 'dqi_strat', Don_save%dqi_strat)
        call read_data (fname, 'dqa_strat', Don_save%dqa_strat)
        call read_data (fname, 'tprea1', Don_save%tprea1)       
        call read_data (fname, 'humidity_area', Don_save%humidity_area) 

!---------------------------------------------------------------------
!  determine if humidity_factor is in file. if it is, read the values 
!  into Don_Save%humidity_factor. if it is not (it is an older file), 
!  it is only required if donner_deep will not be called on the first 
!  step of this job.
!  if that is the case, stop with a fatal error; otherwise, continue on,
!  since humidity_factor will be calculated before it is used.
!---------------------------------------------------------------------
        call field_size(fname, 'humidity_factor', siz,   &
                                              field_found=field_found4)
        if (field_found4) then
          call read_data (fname, 'humidity_factor',  &
                                              Don_save%humidity_factor)
        else if (Initialized%conv_alarm > 0.0) then
          call error_mesg ('donner_deep_mod', &
             'cannot restart with this restart file unless donner_deep &
                &calculated on first step', FATAL)
        endif

!----------------------------------------------------------------------
!    determine if det_mass_flux is present in the file.
!----------------------------------------------------------------------
        call field_size(fname, 'det_mass_flux', siz,    &
                                               field_found=field_found2)

!----------------------------------------------------------------------
!    if it is present, then read det_mass_flux and cell_up_mass_flux.
!----------------------------------------------------------------------
        if (field_found2) then
          call read_data (fname, 'det_mass_flux', Don_save%det_mass_flux)
          call read_data (fname, 'cell_up_mass_flux',    &
                                              Don_save%cell_up_mass_flux)

!----------------------------------------------------------------------
!    if it is not present (an earlier version of this file), set 
!    det_mass_flux and cell_up_mass_flux to default values.
!----------------------------------------------------------------------
        else
          Don_save%det_mass_flux     = 0.0
          Don_save%cell_up_mass_flux = 0.0
        endif

!------------------------------------------------------------------
!    if tracers are to be transported, see if tendencies are available
!    in the restart file.
!------------------------------------------------------------------
        if (Initialized%do_donner_tracer) then

!---------------------------------------------------------------------
!    initialize a logical array indicating whether the data for each
!    tracer is available.
!---------------------------------------------------------------------
          success = .false.

!---------------------------------------------------------------------
!    open the restart file with mpp_open so that the unit number is 
!    available. obtain needed file characteristics by calling 
!    mpp_read_meta and  mpp_get_info. 
!---------------------------------------------------------------------
          call mpp_open(iuic, fname2, &
               action=MPP_RDONLY, form=MPP_NETCDF, threading=MPP_SINGLE )
          call mpp_read_meta (iuic)
          call mpp_get_info (iuic, ndim, nvar, natt, ntime)

!---------------------------------------------------------------------
!    obtain information on the file variables by calling mpp_get_fields.
!    it is returned in a field_type variable tracer_fields; the specific
!    information needed is the variable name.
!---------------------------------------------------------------------
          allocate (tracer_fields(nvar))
          if (mpp_pe() == mpp_root_pe()) then
            call mpp_get_fields (iuic, tracer_fields)
          endif

!---------------------------------------------------------------------
!    call get_number_tracers to determine how many tracers are registered
!    with tracer manager. allocate an array to hold their tracer indices.
!    call get_tracer_indices to retrieve the tracer indices. 
!---------------------------------------------------------------------
          call get_number_tracers (MODEL_ATMOS, num_tracers=n_alltracers)
          allocate (ntindices(n_alltracers))
          call get_tracer_indices (MODEL_ATMOS, ind=ntindices)

!----------------------------------------------------------------------
!    loop over the tracers, obtaining their names via a call to
!    get_tracer_names. bypass those tracers known to not be transported
!    by donner convection.
!----------------------------------------------------------------------
          do it=1,n_alltracers
            call get_tracer_names (MODEL_ATMOS, ntindices(it), tname)
            if (tname == "sphum"  ) cycle
            if (tname == "liq_wat") cycle
            if (tname == "ice_wat") cycle
            if (tname == "cld_amt") cycle

!--------------------------------------------------------------------
!    initialize a logical indicating whether this tracer is in the 
!    restart file.
!--------------------------------------------------------------------
            is_tracer_in_restart_file = .FALSE.

!---------------------------------------------------------------------
!    loop over the variables in the restart file to determine if the
!    current tracer's time tendency field is present.
!---------------------------------------------------------------------
            do jn=1,nvar 
              if (lowercase (trim(mpp_get_field_name(tracer_fields(jn)))) ==   &
                  lowercase ('tracer_tends_' // trim(tname)) ) then 

!---------------------------------------------------------------------
!    if tracer tendency is in restart file, write a message. set the 
!    logical flag indicating such to .true..
!---------------------------------------------------------------------
                if (mpp_pe() == mpp_root_pe() )  then
                  print *,'tracer_tends_' // trim(tname), ' found!'
                endif
                is_tracer_in_restart_file = .TRUE.

!---------------------------------------------------------------------
!    loop over the tracers being transported by donner convection in this
!    job to determine if this tracer is one of those being transported.
!    determine the tracer index in tracername array corresponding to 
!    this tracer.
!---------------------------------------------------------------------
                do nn=1,ntracers
                  if (lowercase( 'tracer_tends_' // trim(tname) ) == &
                      'tracer_tends_' // Don_save%tracername(nn) )  then
                  
!---------------------------------------------------------------------
!    if data for this tracer is needed, read data into proper section of
!    array tracer_tends. set the logical flag for this tracer indicating 
!    successful retrieval. exit this loop.
!---------------------------------------------------------------------
                    call read_data (fname,   &
                                  'tracer_tends_' // trim(tname),   &
                                   Don_save%tracer_tends(:,:,:,nn))
                    success(nn) = .true.
                    exit
                  endif 
                end do  ! (nn)
              endif

!---------------------------------------------------------------------
!    if desired tracer has been found, stop searching the restart file
!    variables for this tracer and cycle to begin searching the restart
!    file for the next field_table tracer.
!---------------------------------------------------------------------
              if (is_tracer_in_restart_file) exit
            end do !  (jn)
          end do ! (it)

!---------------------------------------------------------------------
!    initialize the time tendencies to 0.0 for any tracers that are to
!    be transported and whose time tendencies were not found on the 
!    restart file.  enter a message in the output file.
!---------------------------------------------------------------------
          do nn=1,ntracers
            if (success(nn) ) then
            else
              call error_mesg ('donner_deep_mod', 'read_restart_nc: &
                  &did not find tracer restart data for ' //  &
                  trim(Don_save%tracername(nn)) //  &
                  '; am initializing tendency to 0.0', NOTE)
              Don_save%tracer_tends(:,:,:,nn) = 0.0
            endif   
          end do

!----------------------------------------------------------------------
!    deallocate local variables.
!----------------------------------------------------------------------
          deallocate (ntindices)
          deallocate (tracer_fields)
        endif  ! (do_donner_tracer)
      endif  ! (field_found)

!---------------------------------------------------------------------
!    read the restart data that is present in both full and reduced
!    restart files.
!---------------------------------------------------------------------
      call read_data (fname, 'parcel_disp', Don_save%parcel_disp)
      call read_data (fname, 'lag_temp',    Don_save%lag_temp)     
      call read_data (fname, 'lag_vapor',   Don_save%lag_vapor)     
      call read_data (fname, 'lag_press',   Don_save%lag_press)     

!---------------------------------------------------------------------




end subroutine read_restart_nc



!#####################################################################

subroutine process_monitors (idf, jdf, nlev, ntracers, axes, Time, &
                              Initialized, Don_save)

integer,                       intent(in)  :: idf, jdf, nlev, ntracers
integer,         dimension(4), intent(in)  :: axes
type(time_type),               intent(in)  :: Time
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save

!-------------------------------------------------------------------
!  local variables:

      integer             :: n, nx, nc
      logical             :: flag, success
      integer             :: nfields, model, num_methods
      character(len=200)  :: method_name, field_type, method_control,&
                             field_name, list_name
      character(len=32)   :: path_name = '/atmos_mod/don_deep_monitor/'

!---------------------------------------------------------------------
!    determine if and how many output variables are to be monitored. 
!    set a flag indicating if monitoring is activated.
!---------------------------------------------------------------------
      call field_manager_init (nfields)
      nx = 0
      do n=1,nfields
        call get_field_info (n, field_type, field_name, model, &
                             num_methods)
        if (trim(field_type) == 'don_deep_monitor') then
          nx = nx + 1
        endif
      end do
      if (nx > 0) then
        Initialized%monitor_output = .true.
      else
        Initialized%monitor_output = .false.
      endif

!---------------------------------------------------------------------
!    allocate arrays needed for each monitored variable. 
!---------------------------------------------------------------------
      if (Initialized%monitor_output) then
        allocate (Initialized%Don_monitor(nx))
        allocate (id_extremes(nx))
        allocate (id_hits(nx))

!---------------------------------------------------------------------
!    read the field_table to determine the nature of the monitors
!    requested.
!---------------------------------------------------------------------
        nx = 1
        do n = 1,nfields
          call get_field_info (n, field_type, field_name, model, &
                               num_methods)

!---------------------------------------------------------------------
!    define the list name used by field_manager_mod to point to 
!    monitored variables.
!---------------------------------------------------------------------
          if (trim(field_type) == 'don_deep_monitor') then
            list_name = trim(path_name) // trim(field_name) // '/'

!--------------------------------------------------------------------
!    place name of field in don_monitor_type variable.
!--------------------------------------------------------------------
            Initialized%Don_monitor(nx)%name = trim(field_name)

!--------------------------------------------------------------------
!    map the field name to the list of acceptable field names. store
!    the index of this field name in the don_monitor_type variable.
!    note that any tracer variables need to have 'tr_' as the first
!    three characters in their name to allow proper processing. store
!    the appropriate tracer index for any tracer arrays.
!--------------------------------------------------------------------
            if (trim(field_name(1:3)) == 'tr_') then
              select case (trim(field_name(4:9)))
                case ('rn_ten')
                  Initialized%Don_monitor(nx)%index = RADON_TEND
                  success = .false.
                  do nc=1,ntracers
                    if (trim(Don_save%tracername(nc)) == 'radon') then
                      Initialized%Don_monitor(nx)%tracer_index = nc
                      success = .true.
                      exit
                    endif
                  end do
                  if (.not. success) then
                    call error_mesg ('donner_deep_mod', &
                     'not able to find "radon" tracer index', FATAL)
                  endif
                case default
                  call error_mesg ('donner_deep_mod', &
                 'tracer variable name in field_table don_deep_monitor &
                                             &type is invalid', FATAL)
              end select

!---------------------------------------------------------------------
!    for non-tracer variables, set the tracer index to an arbitrary 
!    value.
!---------------------------------------------------------------------
            else
              Initialized%Don_monitor(nx)%tracer_index = 0
              select case (trim(field_name(1:6)))
                case ('det_ma')
                  Initialized%Don_monitor(nx)%index = DET_MASS_FLUX
                case ('mass_f')
                  Initialized%Don_monitor(nx)%index = MASS_FLUX
                case ('cell_u')
                  Initialized%Don_monitor(nx)%index =   &
                                                  CELL_UPWARD_MASS_FLUX
                case ('temp_f')
                  Initialized%Don_monitor(nx)%index = TEMP_FORCING
                case ('moistu')
                  Initialized%Don_monitor(nx)%index = MOIST_FORCING
                case ('precip')
                  Initialized%Don_monitor(nx)%index = PRECIP
                case ('freeze')
                  Initialized%Don_monitor(nx)%index = FREEZING
                case default
                  call error_mesg ('donner_deep_mod', &
                      'variable name in field_table don_deep_monitor &
                                              &type is invalid', FATAL)
              end select
            endif

!---------------------------------------------------------------------
!    read the units for this variable from the field_table entry.
!    if the units method is missing, set units to be 'missing'.
!---------------------------------------------------------------------
            flag = fm_query_method (trim(list_name) //  'units',    &
                                    method_name, method_control)
            if (flag) then
              Initialized%Don_monitor(nx)%units = trim(method_name)
            else
              Initialized%Don_monitor(nx)%units = 'missing'
            endif

!---------------------------------------------------------------------
!    determine the type of limit being imposed for this variable from 
!    the field_table entry.
!---------------------------------------------------------------------
            flag = fm_query_method (trim(list_name) // 'limit_type',  &
                                    method_name, method_control)

!----------------------------------------------------------------------
!    include the limit_type for this variable in its don_monitor type
!    variable.
!    register diagnostics associated with the monitored output fields
!    (extreme values and number of times threshold was exceeeded).
!----------------------------------------------------------------------
            if ( flag) then
              if (trim(method_name) == 'maxmag') then
                Initialized%Don_monitor(nx)%initial_value = 0.0
                Initialized%Don_monitor(nx)%limit_type =   MAXMAG
                id_extremes(nx) = register_diag_field (mod_name,   &
                  'maxmag_'// trim(Initialized%Don_monitor(nx)%name),  &
                   axes(1:3),  Time,  'maxmag values of ' // &
                            trim(Initialized%Don_monitor(nx)%name),  &
                   Initialized%Don_monitor(nx)%units,   &
                   mask_variant = .true., missing_value=missing_value)
                id_hits(nx) = register_diag_field (mod_name,   &
                  'num_maxmag_'// &
                              trim(Initialized%Don_monitor(nx)%name) , &
                   axes(1:3),  Time,    &
                   '# of times that magnitude of '&
                     // trim(Initialized%Don_monitor(nx)%name) //  &
                 ' > ' // trim(method_control(2:)) // ' ' // &
                    trim(Initialized%Don_monitor(nx)%units) ,  &
                   'number', mask_variant = .true., & 
                   missing_value=missing_value)
              else if (trim(method_name) == 'minmag') then
                Initialized%Don_monitor(nx)%initial_value = 1.0e30
                Initialized%Don_monitor(nx)%limit_type =   MINMAG
                id_extremes(nx) = register_diag_field (mod_name,   &
                  'minmag_'// trim(Initialized%Don_monitor(nx)%name),  &
                   axes(1:3),  Time,  'minmag values of ' // &
                            trim(Initialized%Don_monitor(nx)%name),  &
                   Initialized%Don_monitor(nx)%units,   &
                   mask_variant = .true., missing_value=missing_value)
                id_hits(nx) = register_diag_field (mod_name,   &
                  'num_minmag_'//     &
                             trim(Initialized%Don_monitor(nx)%name) , &
                  axes(1:3),  Time,    &
                   '# of times that magnitude of '&
                     // trim(Initialized%Don_monitor(nx)%name) //  &
                ' < ' // trim(method_control(2:)) // ' ' // &
                    trim(Initialized%Don_monitor(nx)%units) ,  &
                  'number', mask_variant = .true., & 
                  missing_value=missing_value)
              else if (trim(method_name) == 'minval') then
                Initialized%Don_monitor(nx)%initial_value = 1.0e30
                Initialized%Don_monitor(nx)%limit_type =   MINVAL
                id_extremes(nx) = register_diag_field (mod_name,   &
                  'minval_'// trim(Initialized%Don_monitor(nx)%name),  &
                   axes(1:3),  Time,  'minimum values of ' // &
                            trim(Initialized%Don_monitor(nx)%name),  &
                  Initialized%Don_monitor(nx)%units,   &
                  mask_variant = .true., missing_value=missing_value)
                id_hits(nx) = register_diag_field (mod_name,   &
                  'num_minval_'//   &
                             trim(Initialized%Don_monitor(nx)%name) , &
                   axes(1:3),  Time,    &
                   '# of times that value of '&
                     // trim(Initialized%Don_monitor(nx)%name) //  &
                ' < ' // trim(method_control(2:)) // ' ' // &
                    trim(Initialized%Don_monitor(nx)%units) ,  &
                  'number', mask_variant = .true., & 
                  missing_value=missing_value)
              else if (trim(method_name) == 'maxval') then
                Initialized%Don_monitor(nx)%initial_value = -1.0e30
                Initialized%Don_monitor(nx)%limit_type = MAXVAL 
                id_extremes(nx) = register_diag_field (mod_name,   &
                  'maxval_'// trim(Initialized%Don_monitor(nx)%name),  &
                  axes(1:3),  Time,  'maximum values of ' // &
                            trim(Initialized%Don_monitor(nx)%name),  &
                  Initialized%Don_monitor(nx)%units,  &
                  mask_variant = .true., missing_value=missing_value)
                id_hits(nx) = register_diag_field (mod_name,   &
                  'num_maxval_'//    &
                             trim(Initialized%Don_monitor(nx)%name) , &
                  axes(1:3),  Time,    &
                   '# of times that value of '&
                     // trim(Initialized%Don_monitor(nx)%name) //  &
                    ' > ' // trim(method_control(2:)) // ' ' // &
                    trim(Initialized%Don_monitor(nx)%units) ,  &
                  'number', mask_variant = .true., & 
                  missing_value=missing_value)
              else
                call error_mesg ('donner_deep_mod', &
                    'invalid limit_type for monitored variable', FATAL)
              endif

!----------------------------------------------------------------------
!    if limit_type not in field_table, set it to look for maximum
!    magnitude.
!----------------------------------------------------------------------
            else
              Initialized%Don_monitor(nx)%initial_value = 0.0
              Initialized%Don_monitor(nx)%limit_type =   MAXMAG
              id_extremes(nx) = register_diag_field (mod_name,   &
                  'maxmag_'// trim(Initialized%Don_monitor(nx)%name),  &
                   axes(1:3),  Time,  'maxmag values of ' // &
                            trim(Initialized%Don_monitor(nx)%name),  &
                   Initialized%Don_monitor(nx)%units,   &
                   mask_variant = .true., missing_value=missing_value)
              id_hits(nx) = register_diag_field (mod_name,   &
                  'num_maxmag_'// &
                              trim(Initialized%Don_monitor(nx)%name) , &
                   axes(1:3),  Time,    &
                   '# of times that magnitude of '&
                     // trim(Initialized%Don_monitor(nx)%name) //  &
                ' > ' // trim(method_control(2:)) // ' ' // &
                    trim(Initialized%Don_monitor(nx)%units) ,  &
                   'number', mask_variant = .true., & 
                   missing_value=missing_value)
            endif

!----------------------------------------------------------------------
!    obtain the magnitude of the limit being monitored for this 
!    variable from the field_table. 
!----------------------------------------------------------------------
            flag = parse (method_control, 'value',   &
                            Initialized%Don_monitor(nx)%threshold ) > 0

!----------------------------------------------------------------------
!    if no limit_type and / or value has been given, the
!    field will be flagged for magnitudes  > 0.0, i.e., if deep 
!    convection has affected the point.
!----------------------------------------------------------------------
            if ( .not. flag) then
              Initialized%Don_monitor(nx)%threshold = 0.0
            endif

!-------------------------------------------------------------------
!    allocate and initialize arrays to hold the extrema and a count of 
!    times the threshold was exceeded at each point.
!-------------------------------------------------------------------
            allocate (Initialized%Don_monitor(nx)%extrema(idf,jdf,nlev))
            Initialized%Don_monitor(nx)%extrema(:,:,:) =  &
                         Initialized%Don_monitor(nx)%initial_value
            allocate (Initialized%Don_monitor(nx)%hits(idf,jdf,nlev))
            Initialized%Don_monitor(nx)%hits(:,:,:) = 0.0
            nx = nx + 1
          endif
        end do
      endif 

end subroutine process_monitors



!#####################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!      2. ROUTINES CALLED BY DONNER_DEEP
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#######################################################################

subroutine donner_column_control (is, ie, js, je, Time, Col_diag)                

!---------------------------------------------------------------------
!    subroutine donner_column_control returns the number, location
!    (processor and window indices) and output units associated with 
!    any diagnostic columns requested within the current physics window.
!---------------------------------------------------------------------

integer,                       intent(in)   :: is, ie, js, je
type(time_type),               intent(in)   :: Time
type (donner_column_diag_type), intent(inout) :: Col_diag

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie         first and last values of i index values of points
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points
!                    in this physics window (processor coordinates)
!     Time           current model time [ time_type, days, seconds ]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer  :: isize      !   i-dimension of physics window
      integer  :: jsize      !   j-dimension of physics window
      integer  :: nn, j, i   !   do-loop indices

!--------------------------------------------------------------------
!    define the sizes of the current physics window's horizontal
!    dimensions.
!--------------------------------------------------------------------
      isize = ie - is + 1
      jsize = je - js + 1

!-------------------------------------------------------------------
!    initialize the output variables.
!-------------------------------------------------------------------
      Col_diag%i_dc(:) = -99
      Col_diag%j_dc(:) = -99
      Col_diag%unit_dc(:) = -1
      Col_diag%jgl_dc(:) = -99
      Col_diag%igl_dc(:) = -99
      Col_diag%ncols_in_window = 0

!--------------------------------------------------------------------
!    if any requested diagnostic columns are present within the current
!    physics window, and if it is at or past the time to start output-
!    ting column diagnostics, save the relevant variables describing
!    those diagnostic columns in arrays to be returned to the calling
!    routine. call column_diagnostics_header to write the file header
!    for the diagnostic columns in this window. 
!--------------------------------------------------------------------
      if (Col_diag%num_diag_pts > 0) then
        if (Time >= Time_col_diagnostics) then
          do nn=1,Col_diag%num_diag_pts
            do j=1,jsize      
              if (js + j - 1 == col_diag_j(nn)) then
                do i=1,isize       
                  if (is + i - 1 == col_diag_i(nn)) then
                    Col_diag%ncols_in_window =   &
                                           Col_diag%ncols_in_window + 1
                    Col_diag%i_dc(Col_diag%ncols_in_window) = i
                    Col_diag%j_dc(Col_diag%ncols_in_window) = j
                    Col_diag%igl_dc(COl_diag%ncols_in_window) =  &
                                                          col_diag_i(nn)
                    Col_diag%jgl_dc(Col_diag%ncols_in_window) =   &
                                                           col_diag_j(nn)
                    Col_diag%unit_dc(Col_diag%ncols_in_window) =   &
                                                        col_diag_unit(nn)
                    call column_diagnostics_header &
                            (mod_name, col_diag_unit(nn), Time, nn,  &
                             col_diag_lon, col_diag_lat, col_diag_i,  &
                             col_diag_j)
                  endif
                end do  ! (i loop)
              endif
            end do  ! (j loop) 
          end do  ! (num_diag_pts loop)
        endif  ! (Time >= starting time)
      endif ! (num_diag_pts > 0)

!---------------------------------------------------------------------

end subroutine donner_column_control



!######################################################################

subroutine donner_deep_netcdf (is, ie, js, je, Nml, Time,  Param, &
                               Initialized, Don_conv, Don_cape,&
                               Don_cem,parcel_rise, pmass, total_precip, &
                               Don_budgets, &
                               temperature_forcing, moisture_forcing)  

!---------------------------------------------------------------------
!    subroutine donner_deep_netcdf sends the fields requested in the
!    diag_table to diag_manager_mod so that they may be appropriately
!    processed for output.
!---------------------------------------------------------------------

integer,                intent(in) :: is, ie, js, je
type(time_type),        intent(in) :: Time
type(donner_param_type), intent(in) :: Param
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_nml_type), intent(in) :: Nml   
type(donner_conv_type), intent(in) :: Don_conv
type(donner_budgets_type), intent(in) :: Don_budgets
type(donner_cape_type), intent(in) :: Don_cape
type(donner_cem_type),  intent(in) :: Don_cem
real, dimension(:,:,:), intent(in) :: pmass, temperature_forcing,&
                                      moisture_forcing
real, dimension(:,:),   intent(in) :: parcel_rise, total_precip

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     is, ie         first and last values of i index values of points 
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points 
!                    in this physics window (processor coordinates)
!     Time           current time (time_type)
!     Don_conv       donner_convection_type derived type variable con-
!                    taining diagnostics describing the nature of the 
!                    convection produced by the donner parameterization
!     Don_cape       donner_cape type derived type variable containing
!                    diagnostics related to the cape calculation assoc-
!                    iated with the donner convection parameterization
!     Don_cem        donner_cem_type derived type variable containing
!                    Donner cumulus ensemble member diagnostics
!     temperature_forcing  
!                    temperature tendency due to donner convection
!                    [ deg K / sec ]
!     moisture_forcing  
!                    vapor mixing ratio tendency due to donner 
!                    convection [ kg(h2o) / (kg(dry air) sec ) ]
!     pmass          mass per unit area within the grid box
!                    [ kg (air) / (m**2) ]
!     parcel_rise    accumulated vertical displacement of a near-surface
!                    parcel as a result of the lowest model level omega 
!                    field [ Pa ]
!     total_precip   total precipitation rate produced by the
!                    donner parameterization [ mm / day ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (ie-is+1, je-js+1)  :: tempdiag, tempdiag2, tempdiag3  
                           ! array used to hold various data fields being
                           ! sent to diag_manager_mod
      logical :: used      ! logical indicating data has been received 
                           ! by diag_manager_mod 
      integer :: nlev      ! number of large-scale model layers
      integer :: ntr       ! number of tracers transported by the
                           ! donner deep convection parameterization
      integer :: k, n, nn  ! do-loop indices
      integer :: ncem      ! number of cumulus ensemble members in the
                           ! donner deep convection parameterization

!----------------------------------------------------------------------
!    define the number of model layers (nlev) and number of transported
!    tracers (ntr).
!----------------------------------------------------------------------
      nlev = size (pmass,3)
      ntr  = size (Don_conv%qtren1,4)

!----------------------------------------------------------------------
!    define the number of cumulus ensemble members in the
!    donner deep convection parameterization.
!----------------------------------------------------------------------
      ncem = size (Don_cem%cell_precip,3)

!---------------------------------------------------------------------
!    send the 3D convective output variables to diag_manager_mod.
!!   NOTE: effective with code mod lima_donnermod3_rsh (7-19-05) the
!!         temperature and moisture forcing fields passed to diag_manager
!!         (id_cemetf_deep, id_cememf_deep) are the total convective
!!         forcings calculated by the donner parameterization. Previous
!!         code versions run in models in which strat_cloud_mod was 
!!         activated output the forcing fields less the terms related to 
!!         the flux convergence of the large-scale condensate and the 
!!         mesoscale detrainment.
!---------------------------------------------------------------------

!   total convective temperature forcing:
      used = send_data (id_cemetf_deep, Don_conv%conv_temp_forcing,  &
                        Time, is, js, 1)

!   cell entropy flux convergence:
      used = send_data (id_ceefc_deep, Don_conv%ceefc, Time, is, js, 1)

!   cell condensation / evaporation:
      used = send_data (id_cecon_deep, Don_conv%cecon, Time, is, js, 1)

!   cell moisture flux convergence:
      used = send_data (id_cemfc_deep, Don_conv%cemfc, Time, is, js, 1)

!   total convective moistening forcing:
      used = send_data (id_cememf_deep, Don_conv%conv_moist_forcing,  &
                        Time, is, js, 1)

!   total convective moistening rate after adjustnment for negative 
!   vapor mixing ratio:
      used = send_data (id_cememf_mod_deep, Don_conv%cememf_mod,   &
                        Time, is, js, 1)

!   cell + mesoscale cloud fraction:
      used = send_data (id_cual_deep, Don_conv%cual, Time, is, js, 1)

!   heating rate due to freezing:
      used = send_data (id_fre_deep, Don_conv%fre, Time, is, js, 1)

!   heating rate due to melting:
      used = send_data (id_elt_deep, Don_conv%elt, Time, is, js, 1)

!   deposition in mesoscale updraft:
      used = send_data (id_cmus_deep, Don_conv%cmus, Time, is, js, 1)

!   evaporation in convective downdrafts:
      used = send_data (id_ecds_deep, Don_conv%ecds, Time, is, js, 1)

!   evaporation / sublimation in convective updrafts:
      used = send_data (id_eces_deep, Don_conv%eces, Time, is, js, 1)

!   sublimation in mesoscale downdrafts:
      used = send_data (id_emds_deep, Don_conv%emds, Time, is, js, 1)

!   sublimation in mesoscale updrafts:
      used = send_data (id_emes_deep, Don_conv%emes, Time, is, js, 1)

!   mesoscale moisture flux convergence:
      used = send_data (id_qmes_deep, Don_conv%mrmes, Time, is, js, 1)

!   transfer of vapor from cells to mesoscale:
      used = send_data (id_wmps_deep, Don_conv%wmps, Time, is, js, 1)

!   deposition of vapor from cells to mesoscale:
      used = send_data (id_wmms_deep, Don_conv%wmms, Time, is, js, 1)

!   mesoscale entropy flux convergence:
      used = send_data (id_tmes_deep, Don_conv%tmes, Time, is, js, 1)

!   mass flux in mesoscale downdrafts:
      used = send_data (id_dmeml_deep, Don_conv%dmeml, Time, is, js, 1)

!   mass flux in cell updrafts:
      used = send_data (id_uceml_deep, Don_conv%uceml, Time, is, js, 1)

!   detrained mass flux:
      used = send_data (id_detmfl_deep, Don_conv%detmfl, Time, is, js, 1)

!   mass flux in mesoscale updrafts:
      used = send_data (id_umeml_deep, Don_conv%umeml, Time, is, js, 1)

!   mesoscale ice mixing ratio:
      used = send_data (id_xice_deep, Don_conv%xice, Time, is, js, 1)

!   mesoscale liquid mass mixing ratio
      used = send_data (id_xliq_deep, Don_conv%xliq, Time, is, js, 1)

!   mesoscale ice generalized effective size:
      used = send_data (id_dgeice_deep, Don_conv%dgeice,      &
                        Time, is, js, 1)

!   cell ice mixing ratio:
      used = send_data (id_cuqi_deep, Don_conv%cuqi, Time, is, js, 1)

!   cell liquid mixing ratio:
      used = send_data (id_cuql_deep, Don_conv%cuql, Time, is, js, 1)

!   cell liquid generalized effective size:
      used = send_data (id_dgeliq_deep, Don_conv%cell_liquid_eff_diam, &
                        Time, is, js, 1)

     if (Nml%do_budget_analysis) then
       do n=1,Don_budgets%N_WATER_BUDGET
         if (id_water_budget(n) > 0) then
            used = send_data (id_water_budget(n), &
                              Don_budgets%water_budget(:,:,:,n), &
                              Time, is, js, 1)
         endif
       end do
       do n=1,Don_budgets%N_PRECIP_TYPES
         do nn=1,Don_budgets%N_PRECIP_PATHS
           if (id_precip_budget(nn,n) > 0) then
             used = send_data (id_precip_budget(nn,n), &
                               Don_budgets%precip_budget(:,:,:,nn,n), &
                               Time, is, js, 1)
           endif
         end do
       end do
       do n=1,Don_budgets%N_ENTHALPY_BUDGET
         if (id_enthalpy_budget(n) > 0) then
           used = send_data (id_enthalpy_budget(n),   &
                             Don_budgets%enthalpy_budget(:,:,:,n), &
                             Time, is, js, 1)
         endif
       end do
       do n=1,Don_budgets%N_WATER_BUDGET
         tempdiag(:,:) = 0.
         do k=1,nlev
           tempdiag(:,:) = tempdiag(:,:) + &
                           Don_budgets%water_budget(:,:,k,n)* &
                                                     pmass(:,:,k)/1000.
         end do
         if (id_ci_water_budget(n) > 0) then
           used = send_data (id_ci_water_budget(n), tempdiag, &
                             Time, is, js)
         endif
       end do
       tempdiag3(:,:) = 0.
       do n=1,Don_budgets%N_PRECIP_TYPES
         do nn=1,Don_budgets%N_PRECIP_PATHS
           tempdiag(:,:) = 0.
           do k=1,nlev
             tempdiag(:,:) = tempdiag(:,:) + &
                             Don_budgets%precip_budget(:,:,k,nn,n)* &
                                                           pmass(:,:,k)
           end do
           if (id_ci_precip_budget(nn,n) > 0) then
             used = send_data (id_ci_precip_budget(nn,n), tempdiag, &
                               Time, is, js)
           endif
           tempdiag3(:,:) = tempdiag3(:,:) + tempdiag(:,:)
         end do
       end do
       do n=1,Don_budgets%N_ENTHALPY_BUDGET
         tempdiag(:,:) = 0.
         do k=1,nlev
           tempdiag(:,:) = tempdiag(:,:) +  &
                           Don_budgets%enthalpy_budget(:,:,k,n)* &
                                                    pmass(:,:,k)*CP_AIR
         end do
         if (id_ci_enthalpy_budget(n) > 0) then
           used = send_data (id_ci_enthalpy_budget(n), tempdiag, &
                             Time, is, js)
         endif
       end do
           
        
       tempdiag2(:,:) = 0.
       tempdiag(:,:) = 0.
       do k=1,nlev
         tempdiag(:,:) = tempdiag(:,:) +  &
                         (Don_budgets%precip_budget(:,:,k,2,1) +  &
                          Don_budgets%precip_budget(:,:,k,4,1))* &
                                                 Param%hls*pmass(:,:,k)
       end do
       if (id_ci_prcp_heat_frz_cell > 0) then
         used = send_data (id_ci_prcp_heat_frz_cell, tempdiag, &
                           Time, is, js)
       endif
       tempdiag2 = tempdiag2 + tempdiag
           
       tempdiag(:,:) = 0.
       do k=1,nlev
         tempdiag(:,:) = tempdiag(:,:) +  &
                         (Don_budgets%precip_budget(:,:,k,1,1) +   &
                          Don_budgets%precip_budget(:,:,k,3,1) + &
                          Don_budgets%precip_budget(:,:,k,5,1))* &
                                                 Param%hlv*pmass(:,:,k)
       end do
       if (id_ci_prcp_heat_liq_cell > 0) then
         used = send_data (id_ci_prcp_heat_liq_cell, tempdiag, &
                           Time, is, js)
       endif
       tempdiag2 = tempdiag2 + tempdiag
           
       tempdiag(:,:) = 0.
       do k=1,nlev
         tempdiag(:,:) = tempdiag(:,:) +  &
                         (Don_budgets%precip_budget(:,:,k,2,2) + &
                          Don_budgets%precip_budget(:,:,k,4,2) + &
                          Don_budgets%precip_budget(:,:,k,2,3) + &
                          Don_budgets%precip_budget(:,:,k,4,3))* &
                                                 Param%hls*pmass(:,:,k)
       end do
       if (id_ci_prcp_heat_frz_meso > 0) then
         used = send_data (id_ci_prcp_heat_frz_meso, tempdiag, &
                           Time, is, js)
       endif
       tempdiag2 = tempdiag2 + tempdiag
           
       tempdiag(:,:) = 0.
       do k=1,nlev
         tempdiag(:,:) = tempdiag(:,:) +  &
                         (Don_budgets%precip_budget(:,:,k,1,2) +   &
                          Don_budgets%precip_budget(:,:,k,3,2) +  &
                          Don_budgets%precip_budget(:,:,k,5,2) + &
                          Don_budgets%precip_budget(:,:,k,1,3) +   &
                          Don_budgets%precip_budget(:,:,k,3,3) +  &
                          Don_budgets%precip_budget(:,:,k,5,3))* &
                                                  Param%hlv*pmass(:,:,k)
       end do
       if (id_ci_prcp_heat_liq_meso > 0) then
         used = send_data (id_ci_prcp_heat_liq_meso, tempdiag, &
                           Time, is, js)
       endif
       tempdiag2 = tempdiag2 + tempdiag
       if ( id_ci_prcp_heat_total > 0) then
         used = send_data (id_ci_prcp_heat_total, tempdiag2, &
                           Time, is, js)
       endif
       if (id_ci_prcp_total > 0) then
         used = send_data (id_ci_prcp_total, tempdiag3, &
                           Time, is, js)
       endif
       if ( id_leff > 0) then
         used = send_data(id_leff, tempdiag2/(tempdiag3+1.0e-40), &
                           Time, is, js)
       endif
           
     endif

!--------------------------------------------------------------------
!    send the tracer-related arrays to diag_manager_mod.
!--------------------------------------------------------------------
      do n=1,ntr    

!   tracer tendency due to cells:
        if (id_qtren1(n) > 0) then
        used = send_data (id_qtren1(n), Don_conv%qtren1(:,:,:,n), &
                          Time, is, js, 1)
        endif

!   tracer tendency due to mesoscale:
         if (id_qtmes1(n) > 0) then
        used = send_data (id_qtmes1(n), Don_conv%qtmes1(:,:,:,n),   &
                          Time, is, js, 1)
        endif

!   tracer tendency due to mesoscale redistribution:
        if (id_wtp1(n) > 0) then
        used = send_data (id_wtp1(n), Don_conv%wtp1(:,:,:,n),     &
                          Time, is, js, 1)
        endif

!   tracer tendency due to deep convective wet deposition:
       if (id_total_wet_dep(n) > 0) then
     used = send_data (id_total_wet_dep(n), Don_conv%wetdept(:,:,:,n), &
                            Time, is, js, 1)
        endif
!   tracer tendency due to wet deposition in mesoscale updrafts:
       if ( id_meso_wet_dep(n) > 0) then
     used = send_data (id_meso_wet_dep(n), Don_conv%wetdepm(:,:,:,n), &
                            Time, is, js, 1)
      endif
 
!   tracer tendency due to wet deposition in cells:
      if (id_cell_wet_dep(n) > 0) then
     used = send_data (id_cell_wet_dep(n), Don_conv%wetdepc(:,:,:,n), &
                           Time, is, js, 1)
      endif

!   total tracer tendency:
      if (id_qtceme(n) > 0) then
        used = send_data (id_qtceme(n), Don_conv%qtceme(:,:,:,n), &
                          Time, is, js, 1)
      endif

!---------------------------------------------------------------------
!    define the column-integrated tracer tendency due to convective
!    cells, in units of kg (tracer) / (m**2 sec). send it to 
!    diag_manager_mod.
!---------------------------------------------------------------------
        tempdiag = 0.0
        do k=1,nlev
          tempdiag(:,:) = tempdiag(:,:) + Don_conv%qtren1(:,:,k,n)* &
                          pmass(:,:,k)
        end do
        if (id_qtren1_col(n) > 0) then
        used = send_data (id_qtren1_col(n), tempdiag, Time, is, js)
        endif

!---------------------------------------------------------------------
!    define the column-integrated tracer tendency due to mesoscale circ-
!    ulation, in units of kg (tracer) / (m**2 sec). send it to 
!    diag_manager_mod.
!---------------------------------------------------------------------
        tempdiag = 0.0
        do k=1,nlev
          tempdiag(:,:) = tempdiag(:,:) + Don_conv%qtmes1(:,:,k,n)* &
                          pmass(:,:,k)
        end do
        if (id_qtmes1_col(n) > 0) then
        used = send_data (id_qtmes1_col(n), tempdiag, Time, is, js)
        endif

!---------------------------------------------------------------------
!    define the column-integrated tracer redistribution due to meso-
!    scale circulation, in units of kg (tracer) / (m**2 sec). send it 
!    to diag_manager_mod.
!---------------------------------------------------------------------
        tempdiag = 0.0
        do k=1,nlev
          tempdiag(:,:) = tempdiag(:,:) + Don_conv%wtp1(:,:,k,n)*   &
                          pmass(:,:,k)
        end do
        if (id_wtp1_col(n) > 0) then
        used = send_data (id_wtp1_col(n), tempdiag, Time, is, js)
        endif

!---------------------------------------------------------------------
!    define the column-integrated tracer change due to wet deposition in
!    deep convection (cells and mesoscale) in units of kg (tracer) / 
!    (m**2 sec). send it to diag_manager_mod.
!---------------------------------------------------------------------
        tempdiag = 0.0
        do k=1,nlev
          tempdiag(:,:) = tempdiag(:,:) + Don_conv%wetdept(:,:,k,n)*   &
                          pmass(:,:,k)
        end do
        if (id_total_wet_dep_col(n) > 0) then
        used = send_data (id_total_wet_dep_col(n), tempdiag, Time,  &
                                                                 is, js)
        endif

!---------------------------------------------------------------------
!    define the column-integrated tracer change due to wet deposition in
!    mesoscale updrafts, in units of kg (tracer) / (m**2 sec). send it 
!    to diag_manager_mod.
!---------------------------------------------------------------------
       tempdiag = 0.0
       do k=1,nlev
         tempdiag(:,:) = tempdiag(:,:) + Don_conv%wetdepm(:,:,k,n)*   &
                         pmass(:,:,k)
       end do
       if (id_meso_wet_dep_col(n) > 0) then
       used = send_data (id_meso_wet_dep_col(n), tempdiag, Time,  &
                                                                 is, js)
       endif

!---------------------------------------------------------------------
!    define the column-integrated tracer change due to wet deposition 
!    by convective cells, in units of kg (tracer) / (m**2 sec). send it 
!    to diag_manager_mod.
!---------------------------------------------------------------------
       tempdiag = 0.0
       do k=1,nlev
         tempdiag(:,:) = tempdiag(:,:) + Don_conv%wetdepc(:,:,k,n)*   &
                         pmass(:,:,k)
       end do
        if (id_cell_wet_dep_col(n) > 0) then
       used = send_data (id_cell_wet_dep_col(n), tempdiag, Time,  &
                                                                 is, js)
        endif

!-----------------------------------------------------------------
!    define the column-integrated total tracer tendency, in units of 
!    kg (tracer) / (m**2 sec). send it to diag_manager_mod.
!---------------------------------------------------------------------
        tempdiag = 0.0
        do k=1,nlev
          tempdiag(:,:) = tempdiag(:,:) + Don_conv%qtceme(:,:,k,n)* &
                          pmass(:,:,k)
        end do
         if (id_qtceme_col(n) > 0) then
        used = send_data (id_qtceme_col(n), tempdiag, Time, is, js)
        endif
      end do

!---------------------------------------------------------------------
!    send the 2D convection-related diagnostics to diag_manager_mod.
!---------------------------------------------------------------------

!   pressure at lifting condensation level:
       if (id_plcl_deep > 0) then
      used = send_data (id_plcl_deep, Don_cape%plcl, Time, is, js)
       endif

!   pressure at level of free convection:
       if (id_plfc_deep > 0) then
      used = send_data (id_plfc_deep, Don_cape%plfc, Time, is, js)
       endif

!   pressure at level of zero buoyancy:
       if (id_plzb_deep > 0) then
      used = send_data (id_plzb_deep, Don_cape%plzb, Time, is, js)
       endif

!   convective available potential energy:
      if (id_xcape_deep > 0) then
      used = send_data (id_xcape_deep, Don_cape%xcape_lag, Time, is, js)
       endif

!   convective inhibition:
      if (id_coin_deep > 0) then
      used = send_data (id_coin_deep, Don_cape%coin, Time, is, js)
       endif

!   time tendency of cape:
      if (id_dcape_deep > 0) then
      used = send_data (id_dcape_deep, Don_conv%dcape, Time, is, js)
       endif

!   column integrated water vapor:
      if (id_qint_deep > 0) then
      used = send_data (id_qint_deep, Don_cape%qint_lag, Time, is, js)
       endif

!   fractional area of cumulus ensemble members:
      if (id_a1_deep > 0) then
      used = send_data (id_a1_deep, Don_conv%a1, Time, is, js)
       endif

!   fractional area of largest cumulus ensemble member:
      if (id_amax_deep > 0) then
      used = send_data (id_amax_deep, Don_conv%amax, Time, is, js)
       endif

!   upper limit of fractional area based on moisture constraint:
      if (id_amos_deep > 0) then
      used = send_data (id_amos_deep, Don_conv%amos, Time, is, js)
       endif

!   area-weighted total precipitation:
      if (id_tprea1_deep > 0) then
      used = send_data (id_tprea1_deep, total_precip, Time, is, js)
       endif

!   mesoscale cloud fraction:
       if (id_ampta1_deep > 0) then
      used = send_data (id_ampta1_deep, Don_conv%ampta1, Time, is, js)
       endif

!   accumulated low-level parcel displacement:
       if (id_omint_deep > 0) then
         used = send_data (id_omint_deep, parcel_rise, Time, is, js)
       endif

!   area weighted convective precipitation:
       if (id_rcoa1_deep > 0) then
      used = send_data (id_rcoa1_deep, Don_conv%cell_precip,    &
                        Time, is, js)
       endif

   if (Nml%do_ensemble_diagnostics) then

!---------------------------------------------------------------------
!  Donner cumulus ensemble member diagnostics
!---------------------------------------------------------------------

!    GCM model pressure field on full levels:
      used = send_data (id_pfull_cem, Don_cem%pfull, &
                        Time, is, js, 1)

!    GCM model pressure field on half levels:
      used = send_data (id_phalf_cem, Don_cem%phalf, &
                        Time, is, js, 1)

!    GCM model height field on full levels:
      used = send_data (id_zfull_cem, Don_cem%zfull, &
                        Time, is, js, 1)

!    GCM model height field on half levels:
      used = send_data (id_zhalf_cem, Don_cem%zhalf, &
                        Time, is, js, 1)

!    GCM model temperature field on full levels:
      used = send_data (id_temp_cem, Don_cem%temp, &
                        Time, is, js, 1)

!    GCM model mixing ratio field on full levels:
      used = send_data (id_mixing_ratio_cem, Don_cem%mixing_ratio, &
                        Time, is, js, 1)

      do n=1,ncem     ! ensemble member number

!    area-weighted convective precipitation rate:
        used = send_data (id_cpre_cem(n), Don_cem%cell_precip(:,:,n), &
                          Time, is, js)

!    pressure at cloud base:
        used = send_data (id_pb_cem(n), Don_cem%pb(:,:,n), &
                          Time, is, js)

!    pressure at cloud top:
        used = send_data (id_ptma_cem(n), Don_cem%ptma(:,:,n), &
                          Time, is, js)

!    condensation rate profile on lo-res grid:
        used = send_data (id_h1_cem(n), Don_cem%h1(:,:,:,n), &
                          Time, is, js, 1)

!    cloud water profile on lo- or hi-res grid:
        used = send_data (id_qlw_cem(n), Don_cem%qlw(:,:,:,n), &
                          Time, is, js, 1)

!    fraction of condensate that is ice on lo- or hi-res grid:
        used = send_data (id_cfi_cem(n), Don_cem%cfracice(:,:,:,n), &
                          Time, is, js, 1)

!    plume vertical velocity profile on lo- or hi-res grid:
        used = send_data (id_wv_cem(n), Don_cem%wv(:,:,:,n), &
                          Time, is, js, 1)

!    plume cloud radius profile on lo- or hi-res grid:
        used = send_data (id_rcl_cem(n), Don_cem%rcl(:,:,:,n), &
                          Time, is, js, 1)
      enddo

!    fractional area sum:
      used = send_data (id_a1_cem, Don_cem%a1, &
                        Time, is, js)

!    area-weighted mesoscale precipitation rate:
        used = send_data (id_mpre_cem, Don_cem%meso_precip, &
                          Time, is, js)

!    cloud fraction, cells+meso, normalized by a(1,p_b) on lo-res grid:
      used = send_data (id_cual_cem, Don_cem%cual, &
                        Time, is, js, 1)

!    time tendency of temperature due to deep convection on lo-res grid:
      used = send_data (id_tfrc_cem, Don_cem%temperature_forcing, &
                        Time, is, js, 1)
   endif  ! (do_ensemble_diagnostics)

!----------------------------------------------------------------------
!    send diagnostics associated with the monitored output fields.
!----------------------------------------------------------------------
      if (Initialized%monitor_output) then
        do n=1,size(Initialized%Don_monitor,1)
          if (id_extremes(n) > 0) then
            used = send_data (id_extremes(n),   &
                    Initialized%Don_monitor(n)%extrema(is:ie,js:je,:), &
                    Time, is, js,1, mask =    &
                  Initialized%Don_monitor(n)%extrema(is:ie,js:je,:) /= &
                              Initialized%Don_monitor(n)%initial_value )
          endif
          if (id_hits(n) > 0) then
            used = send_data (id_hits(n),  &
                       Initialized%Don_monitor(n)%hits(is:ie,js:je,:), &
                       Time, is, js,1, mask =   &
                 Initialized%Don_monitor(n)%extrema(is:ie,js:je,:) /= &
                              Initialized%Don_monitor(n)%initial_value )
          endif
        end do
      endif

!----------------------------------------------------------------------


end subroutine donner_deep_netcdf


!######################################################################


!#####################################################################

subroutine write_restart (ntracers, Don_save, Initialized, Nml)          

!--------------------------------------------------------------------
!    subroutine write_restart is a template to be used if a native mode
!    restart file MUST be generated. currently, if a native mode file is
!    requested, a netcdf file will be witten instead, and an informative
!    message provided.
!--------------------------------------------------------------------
 
integer, intent(in) :: ntracers
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     

!----------------------------------------------------------------------
!   intent(in) variables:
!
!     ntracers               number of tracers to be transported by
!                            the donner deep convection parameterization
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

!     integer :: unit          ! unit number for restart file
!     integer :: n             ! do-loop index

!-------------------------------------------------------------------
!    currently code is provided only for writing netcdf restart files.
!    if a non-netcdf restart file has been requested, this routine will 
!    issue a message, and then call the routine to write the netcdf file.
!    if the user is insistent on a native mode restart file, the code to
!    read and write such files (subroutines write_restart and 
!    read_restart_file) must be updated to be compatible with  the cur-
!    rent versions of write_restart_nc and read_restart_nc, and the 
!    code immediately below eliminated. the commented code below repres-
!    ents a starting point for the write_restart routine; it is not 
!    kept up-to-date as far as the variables which must be written.
!-------------------------------------------------------------------
      call error_mesg ('donner_deep_mod', 'write_restart: &
          &writing a netcdf restart despite request for native &
           &format (not currently supported); if you must have native &
           &mode, then you must update the source code and remove &
                                               &this if loop.', NOTE)
!      call write_restart_nc (ntracers, Don_save, Initialized, Nml) 

!-------------------------------------------------------------------
!    open unit for restart file.
!-------------------------------------------------------------------
!      unit = open_restart_file ('RESTART/donner_deep.res', 'write')

!-------------------------------------------------------------------
!    file writing is currently single-threaded. write out restart
!    version, time remaining until next call to donner_deep_mod and
!    the frequency of calculating donner_deep convection.
!-------------------------------------------------------------------
!     if (mpp_pe() == mpp_root_pe()) then
!       write (unit) restart_versions(size(restart_versions(:)))
!       write (unit) Initialized%conv_alarm, donner_deep_freq
!     endif

!-------------------------------------------------------------------
!    write out the donner_deep restart variables.
!    cemetf    - heating rate due to donner_deep
!    cememf    - moistening rate due to donner_deep
!    xcape_lag - cape value which will be used on next step in
!                calculation od dcape/dt
!-------------------------------------------------------------------
!     call write_data (unit, Don_save%cemetf)
!     call write_data (unit, Don_save%cememf)
      
!--------------------------------------------------------------------
!    the following variables are needed when a prognostic cloud scheme
!    is being used. they are always present in the restart file, having
!    been initialized to zero, if prognostic clouds are not active.
!--------------------------------------------------------------------
!     call write_data (unit, Don_save%mass_flux)
!     call write_data (unit, Don_save%dql_strat )
!     call write_data (unit, Don_save%dqi_strat )
!     call write_data (unit, Don_save%dqa_strat )

!----------------------------------------------------------------------
!    
!-------------------------------------------------------------------
!    write out more donner_deep restart variables.
!    qint_lag   - column integrated water vapor mixing ratio
!    parcel_disp  - time-integrated low-level vertical displacement
!    tprea1     - precipitation due to donner_deep_mod
!----------------------------------------------------------------------
!     call write_data (unit, Don_save%parcel_disp)
!     call write_data (unit, Don_save%tprea1)
!     call write_data (unit, Don_save%lag_temp)
!     call write_data (unit, Don_save%lag_vapor)
!     call write_data (unit, Don_save%lag_press)
!     call write_data (unit, Don_save%humidity_area)
!     call write_data (unit, Don_save%humidity_ratio)

!---------------------------------------------------------------------
!    write out the number of tracers that are being transported by
!    donner_deep_mod.
!---------------------------------------------------------------------
!     if (mpp_pe() == mpp_root_pe()) then
!       write (unit) ntracers
!     endif

!----------------------------------------------------------------------
!    if tracers are being transported, write out their names and 
!    current time tendencies.
!----------------------------------------------------------------------
!     if (Initialized%do_donner_tracer) then
!       do n=1,ntracers
!         if (mpp_pe() == mpp_root_pe()) then
!           write (unit) Don_save%tracername(n)         
!         endif
!         call write_data(unit, Don_save%tracer_tends(:,:,:,n))
!       end do
!     endif

!-------------------------------------------------------------------
!    close restart file unit.
!------------------------------------------------------------------
!     call close_file (unit)

!---------------------------------------------------------------------


end subroutine write_restart




!######################################################################





!######################################################################



                     end module fms_donner_mod



                       module nonfms_donner_mod

use  sat_vapor_pres_k_mod, only: sat_vapor_pres_init_k ! replace with 
                                                     ! non-FMS interface
use donner_types_mod,       only: donner_initialized_type, &
                                  donner_save_type, donner_rad_type, &
                                  donner_nml_type, donner_param_type, &
                                  donner_budgets_type, &
                                  donner_column_diag_type, &
                                  MAXMAG, MAXVAL, MINMAG, MINVAL, &
                                  DET_MASS_FLUX, MASS_FLUX,  &
                                  CELL_UPWARD_MASS_FLUX, TEMP_FORCING, &
                                  MOIST_FORCING, PRECIP,  FREEZING, &
                                  RADON_TEND, &
                                  donner_conv_type, donner_cape_type, &
                                  donner_cem_type

implicit none
private

!--------------------------------------------------------------------
!        donner_deep_mod diagnoses the location and computes the 
!        effects of deep convection on the model atmosphere
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------


character(len=128)  :: version =  '$Id: nonfms_donner.F90,v 18.0.2.1 2010/08/30 20:33:34 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!--------------------------------------------------------------------
!---interfaces------

public   &
        nonfms_donner_process_nml,  nonfms_donner_process_tracers, &
        nonfms_donner_process_monitors, &
        nonfms_donner_activate_diag, nonfms_donner_read_restart,&
        nonfms_donner_col_diag, nonfms_donner_write_restart, &
        nonfms_donner_column_control, nonfms_donner_deep_netcdf,    &
        nonfms_sat_vapor_pres, nonfms_get_pe_number, nonfms_error_mesg,&
        nonfms_close_col_diag_units, &
        nonfms_deallocate_variables, nonfms_constants

private   &
!  module subroutines called during initialization:
        process_coldstart


!---------------------------------------------------------------------
!---namelist----

# include "donner_nml.h"


!--------------------------------------------------------------------
!--- public data ----------




!--------------------------------------------------------------------
!----private data-----------








!-----------------------------------------------------------------------
!   miscellaneous variables
!


!-----------------------------------------------------------------------
!-----------------------------------------------------------------------


                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                   PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################

subroutine nonfms_donner_process_nml  (Nml, kpar)

!---------------------------------------------------------------------
!    nonfms_donner_process_nml si intended to process the 
!    donner_deep_nml file, using the procedure of the nonFMS model.
!    for now, default values are reset here within the Fortran source
!    and no nml read is done.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
type(donner_nml_type), intent(inout)    :: Nml
integer,               intent(in)       :: kpar

!---------------------------------------------------------------------
!  intent(in) variables:
!
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

     real, dimension(:), allocatable :: erat_loc, arat_loc
  
!-------------------------------------------------------------------
!  local variables:
!
!                         
!-------------------------------------------------------------------

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    1. READ NAMELIST AND WRITE IT TO LOG FILE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!--------------------------------------------------------------------
!    here non-default values are reset (as desired) within the Fortran 
!    source. note that changes to arat / erat are handled at the end of
!    this subroutine.
!--------------------------------------------------------------------
!  THESE SETTINGS MAY BE USED FOR DONNER_LITE:
!    SETTINGS USED IN DATABASE EXPT C48L24_AM3p5-gamma-B6:
       parcel_launch_level = 2
       model_levels_in_sfcbl = 0
       donner_deep_freq = 1800
       allow_mesoscale_circulation = .true.
       do_donner_cape    = .false.
       do_donner_plume   = .false.
       do_donner_closure = .false.
       do_donner_lscloud = .true.
       do_dcape          = .false.
       do_lands          = .false.
       do_freezing_for_cape = .true.
       do_freezing_for_closure = .true.
       gama              = 0.0
       tau               = 28800.
       tke0              = 0.5
       cape0             = 1000.
       lochoice          = 10
       do_capetau_land   = .false.
       use_llift_criteria= .false.
       do_ice            = .true.
       atopevap  = 0.1
       auto_rate = 1.e-3
       auto_th   = 0.5e-3
       frac      = 1.65
       ttend_max = 0.005

       EVAP_IN_DOWNDRAFTS  = 0.00
       EVAP_IN_ENVIRON     = 0.00
       ENTRAINED_INTO_MESO = 1.00

       ANVIL_PRECIP_EFFICIENCY = 0.85
       MESO_DOWN_EVAP_FRACTION = 0.1
       MESO_UP_EVAP_FRACTION   = 0.05

       wmin_ratio      = 0.05
       arat(1:7) =  (/ 1.0, 0.26, 0.35, 0.32, 0.3, 0.54, 0.66 /)
       erat(1:7) =  (/ 1.0, 1.30, 1.80, 2.50, 3.3, 4.50, 10.0 /)
       frc_internal_enthalpy_conserv = .true.
       limit_pztm_to_tropo = .true.
 
!  THESE SETTINGS MAY BE USED FOR DONNER_FULL:
!      parcel_launch_level = 2
!      donner_deep_freq = 1800
!      allow_mesoscale_circulation = .true.
!      do_donner_cape    = .true.
!      do_donner_plume   = .true.
!      do_donner_closure = .true.
!      do_donner_lscloud = .true.
!      do_dcape          = .true.
!      do_freezing_for_cape = .false.
!      do_freezing_for_closure = .false.
!      gama              = 0.0
!      lochoice          = 10
!      use_llift_criteria= .true.
!      EVAP_IN_DOWNDRAFTS  = 0.25
!      EVAP_IN_ENVIRON     = 0.13
!      ENTRAINED_INTO_MESO = 0.62

!      ANVIL_PRECIP_EFFICIENCY = 0.5
!      MESO_DOWN_EVAP_FRACTION = 0.4
!      MESO_UP_EVAP_FRACTION   = 0.1 

!      wmin_ratio      = 0.05
!      arat(1:7) =  (/ 1.0, 0.26, 0.35, 0.32, 0.3, 0.54, 0.3 /)
!      erat(1:7) =  (/ 1.0, 1.30, 1.80, 2.50, 3.3, 4.50, 6.5 /)
!      frc_internal_enthalpy_conserv = .true.
!      limit_pztm_to_tropo = .true.

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    8. STORE THE NAMELIST VARIABLES THAT NEED TO BE MADE AVAILABLE 
!       OUTSIDE OF THIS MODULE INTO THE DONNER_NML_TYPE VARIABLE.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      Nml%parcel_launch_level         = parcel_launch_level
      Nml%allow_mesoscale_circulation = allow_mesoscale_circulation
      Nml%do_hires_cape_for_closure   = do_hires_cape_for_closure
      Nml%do_donner_cape              = do_donner_cape    !miz
      Nml%do_donner_plume             = do_donner_plume   !miz
      Nml%do_donner_closure           = do_donner_closure !miz
      Nml%do_dcape                    = do_dcape          !miz
      Nml%do_lands                    = do_lands          !miz
      Nml%tau                         = tau               !miz
      Nml%cape0                       = cape0             !miz
      Nml%rhavg0                      = rhavg0            !miz
      Nml%plev0                       = plev0             !miz
      Nml%do_rh_trig                  = do_rh_trig        !miz
      Nml%do_capetau_land             = do_capetau_land   !miz
      Nml%pblht0                      = pblht0            !miz
      Nml%tke0                        = tke0              !miz
      Nml%lofactor0                   = lofactor0         !miz
      Nml%deephgt0                    = deephgt0          !miz
      Nml%lochoice                    = lochoice          !miz
      Nml%deep_closure                = deep_closure      !miz
      Nml%gama                        = gama              !miz
      Nml%do_ice                      = do_ice            !miz
      Nml%atopevap                    = atopevap          !miz
      Nml%do_donner_lscloud           = do_donner_lscloud !miz
      Nml%auto_rate                   = auto_rate         !miz
      Nml%auto_th                     = auto_th           !miz
      Nml%frac                        = frac              !miz
      Nml%ttend_max                   = ttend_max         !miz
      Nml%mesofactor                  = mesofactor        !miz
      Nml%use_llift_criteria          = use_llift_criteria
      Nml%use_pdeep_cv                = use_pdeep_cv
      Nml%entrainment_constant_source = entrainment_constant_source
      Nml%donner_deep_freq            = donner_deep_freq             
      Nml%model_levels_in_sfcbl       = model_levels_in_sfcbl        
      Nml%cell_liquid_size_type       = cell_liquid_size_type 
      Nml%cell_ice_size_type          = cell_ice_size_type
      Nml%cell_liquid_eff_diam_input  = cell_liquid_eff_diam_input
      Nml%cell_ice_geneff_diam_input  = cell_ice_geneff_diam_input
      Nml%meso_liquid_eff_diam_input  = meso_liquid_eff_diam_input
      Nml%do_average                  = do_average
      Nml%use_memphis_size_limits     = use_memphis_size_limits
      Nml%wmin_ratio                  = wmin_ratio
      Nml%do_freezing_for_cape         = do_freezing_for_cape
      Nml%tfre_for_cape               = tfre_for_cape
      Nml%dfre_for_cape               = dfre_for_cape
      Nml%rmuz_for_cape               = rmuz_for_cape
      Nml%do_freezing_for_closure     = do_freezing_for_closure
      Nml%tfre_for_closure            = tfre_for_closure
      Nml%dfre_for_closure            = dfre_for_closure
      Nml%rmuz_for_closure            = rmuz_for_closure
      Nml%do_budget_analysis          = do_budget_analysis
      Nml%frc_internal_enthalpy_conserv =  &
                                 frc_internal_enthalpy_conserv
      Nml%do_ensemble_diagnostics     = do_ensemble_diagnostics
      Nml%limit_pztm_to_tropo = limit_pztm_to_tropo
      Nml%entrainment_scheme_for_closure =   &
                                        entrainment_scheme_for_closure
      Nml%modify_closure_plume_condensate =   &
                                       modify_closure_plume_condensate
      Nml%closure_plume_condensate = closure_plume_condensate

      Nml%evap_in_downdrafts = evap_in_downdrafts
      Nml%evap_in_environ  = evap_in_environ
      Nml%entrained_into_meso = entrained_into_meso
      Nml%anvil_precip_efficiency = anvil_precip_efficiency
      Nml%meso_down_evap_fraction = meso_down_evap_fraction
      Nml%meso_up_evap_fraction = meso_up_evap_fraction
      Nml%cdeep_cv = cdeep_cv

!---------------------------------------------------------------------
!  if mods are desired for arat / erat when these values are being
!  specified (option = 0), make them to arat_loc / erat_loc. these
!  will be transferred to arat / erat later. if arat / erat come from
!  optional formulae, they will be calculated here used nml-supplied
!  input values.
!---------------------------------------------------------------------
      allocate (arat_loc(kpar))
      allocate (erat_loc(kpar))
 
      if (arat_erat_option == 0) then
        arat_loc = arat
        erat_loc = erat
      else
        call define_arat_erat (arat_erat_option, kpar, eratb, erat0, &
                               erat_min, erat_max,erat_loc,arat_loc)
        print *,'donner_deep_nml: redefined arat and erat using &
                          &arat_erat_option == ', arat_erat_option
        print *,'donner_deep_nml: arat = ',arat_loc
        print *,'donner_deep_nml: erat = ',erat_loc
      endif
      allocate (Nml%arat(kpar))
      allocate (Nml%ensemble_entrain_factors_gate(kpar)) 

      Nml%arat = arat_loc
      Nml%ensemble_entrain_factors_gate = erat_loc

      deallocate (arat_loc, erat_loc)

end subroutine nonfms_donner_process_nml



!#####################################################################

subroutine nonfms_donner_process_tracers 


      return



end subroutine nonfms_donner_process_tracers



!#####################################################################

subroutine nonfms_donner_process_monitors


      return



end subroutine nonfms_donner_process_monitors


!#####################################################################

subroutine nonfms_donner_activate_diag (secs, days, axes, &
                     Don_save, Nml, n_water_budget, n_enthalpy_budget, &
                   n_precip_paths, n_precip_types, nlev_hires, kpar)

integer, intent(in) :: secs, days, n_water_budget,  &
                   n_enthalpy_budget, n_precip_paths, n_precip_types, &
                   nlev_hires, kpar
integer,         dimension(4),   intent(in)   :: axes
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml       


!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    4. INITIALIZE THE NETCDF OUTPUT VARIABLES.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!--------------------------------------------------------------------
!    activate the netcdf diagnostic fields.
!-------------------------------------------------------------------
!     call register_fields (secs, days, axes, Don_save, Nml)


end subroutine nonfms_donner_activate_diag 


!#####################################################################

subroutine nonfms_donner_read_restart (Initialized, ntracers,   &
                                    secs, days, Don_save, Nml)

type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     
integer, intent(in) :: secs, days, ntracers



!--------------------------------------------------------------------
!    if no restart file is present, call subroutine process_coldstart
!    to define the needed variables.
!--------------------------------------------------------------------
      call process_coldstart (secs, days, Initialized, Nml, Don_save)


end subroutine nonfms_donner_read_restart 


!#####################################################################

subroutine nonfms_donner_col_diag (lonb, latb, Col_diag, pref) 

real, dimension(:,:), intent(in) :: lonb, latb
type(donner_column_diag_type), intent(inout) :: Col_diag
real, dimension(:), intent(in) :: pref


!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!    6. INITIALIZE VARIABLES NEEDED FOR COLUMN_DIAGNOSTICS_MOD OUTPUT.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!---------------------------------------------------------------------
!    define the total number of columns for which diagnostics
!    are desired.
!---------------------------------------------------------------------
      Col_diag%num_diag_pts = num_diag_pts_ij + num_diag_pts_latlon

!---------------------------------------------------------------------
!    initialize the value of the k index associated with diagnostics
!    cutoff.
!---------------------------------------------------------------------
      Col_diag%kstart = -99



end subroutine nonfms_donner_col_diag 




!#####################################################################

subroutine nonfms_donner_write_restart (ntracers, Don_save,  &
                                        Initialized, Nml)

integer, intent(in) :: ntracers
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     

!-------------------------------------------------------------------
!    call subroutine to write restart file. 
!-------------------------------------------------------------------

      return


end subroutine nonfms_donner_write_restart 


!#####################################################################

subroutine nonfms_get_pe_number (me, root_pe)
 
!--------------------------------------------------------------------
!    define pe number (needed for column diagnostics and as dummy arg-
!    ument for donner_lite diagnostics). For now, column
!    diagnostics are unavailable outside of FMS, so the value is set 
!    to 0 for all pes. 
!--------------------------------------------------------------------

integer, intent(out) :: me, root_pe
   
      me = 0
      root_pe = 0

end subroutine nonfms_get_pe_number




!#####################################################################

subroutine nonfms_error_mesg (ermesg)   
                             
character(len=*), intent(in) :: ermesg     

 
!    call error_mesg ('donner_deep_mod', ermesg, FATAL)
!!  NOTE POTENTIAL HANG HERE : USE APPROPRIATE ERROR EXIT ON NONFMS
!!  SYSTEM RATHER THAN 'STOP'
    print *, 'STOPPING DUE TO ERROR:', ermesg
    stop 

 

 
end subroutine nonfms_error_mesg




!#####################################################################

subroutine nonfms_close_col_diag_units 

      return

end subroutine nonfms_close_col_diag_units 



!#####################################################################

subroutine nonfms_deallocate_variables

      return 




end subroutine nonfms_deallocate_variables

!######################################################################

subroutine nonfms_sat_vapor_pres
 
!---------------------------------------------------------------------
!    should contain needed calls to initialize nonfms saturation
!    vapor pressure calculation. currently uses fms interface to allow
!    testing.
!---------------------------------------------------------------------

integer, parameter :: TCMIN = -160
integer, parameter :: TCMAX = 100
integer, parameter :: ESRES = 10
real,    parameter :: HLV = 2.500e6   
real,    parameter :: ES0 = 1.0 
real,    parameter :: RVGAS = 461.50 
integer, parameter :: NSIZE = (TCMAX-TCMIN)*esres + 1
integer, parameter :: NLIM = NSIZE - 1
real, parameter :: TFREEZE = 273.16
logical, parameter :: use_exact_qs_input = .true.
logical, parameter :: do_simple = .false.
logical, parameter :: construct_table_wrt_liq = .false.
logical, parameter :: construct_table_wrt_liq_and_ice = .false.

      real  :: teps, tmin, dtinv
      character(len=128) :: err_msg
!     logical :: dum = .false.

      call sat_vapor_pres_init_k (NSIZE, REAL(TCMIN), REAL(TCMAX), &
                             TFREEZE, HLV, RVGAS, ES0, err_msg,  &
                             use_exact_qs_input, do_simple,  &
                             construct_table_wrt_liq, &
                             construct_table_wrt_liq_and_ice, &
                             teps, tmin, dtinv)
 

end subroutine nonfms_sat_vapor_pres




!######################################################################

subroutine nonfms_constants (Param)

type(donner_param_type), intent(inout)  :: Param


!----------------------------------------------------------------------
!    define the components of Param that come from the fms module
!    constants_mod. see donner_types.h for their definitions.
!----------------------------------------------------------------------
      Param%dens_h2o        = 1000.    
      Param%rdgas           = 287.04
      Param%kappa           = 2. / 7.
      Param%grav            = 9.80 
      Param%cp_air          = Param%rdgas/ Param%kappa
      Param%pie             = 3.14159265358979323846
      Param%rvgas           = 461.5
      Param%seconds_per_day = 86400.          
      Param%hlv             = 2.500e+06
      Param%hlf             = 3.34e+05
      Param%hls             = Param%hlv + Param%hlf
      Param%kelvin          = 273.15 

!----------------------------------------------------------------------


end subroutine nonfms_constants


!######################################################################


 subroutine nonfms_donner_column_control (is, ie, js, je, secs,  &
                                          days, Col_diag)               

!---------------------------------------------------------------------
!    subroutine fms_donner_column_control returns the number, location
!    (processor and window indices) and output units associated with 
!    any diagnostic columns requested within the current physics window.
!---------------------------------------------------------------------

integer,                       intent(in)   :: is, ie, js, je
integer,                       intent(in) :: secs, days
type(donner_column_diag_type), intent(inout) :: Col_diag
      
      return     
 
end subroutine nonfms_donner_column_control



subroutine nonfms_donner_deep_netcdf 



      return



end subroutine nonfms_donner_deep_netcdf 


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                   PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!      1. ROUTINES CALLED BY DONNER_DEEP_INIT
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
 



!####################################################################


!#####################################################################

subroutine process_coldstart (secs, days, Initialized, Nml, Don_save)

!-----------------------------------------------------------------------
!    subroutine process_coldstart provides initialization that is needed
!    when the job is a donner_deep coldstart, or if the user-supplied 
!    restart file is not usable for a restart with the current code 
!    version.
!-----------------------------------------------------------------------

integer, intent(in) :: secs, days
type(donner_initialized_type), intent(inout) :: Initialized
type(donner_save_type), intent(inout) :: Don_save
type(donner_nml_type), intent(inout) :: Nml     

!---------------------------------------------------------------------
!   intent(in) variables:
!
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:


!---------------------------------------------------------------------
!    set the coldstart flag to .true.. set the time until the first cal-
!    culation call to donner_deep_mod, donner_deep calculation calls will
!    be every donner_deep_freq seconds after the start of the day.
!---------------------------------------------------------------------
      Initialized%coldstart = .true.
      if (secs == 0) then    ! i.e., 00Z
        Initialized%conv_alarm = Nml%donner_deep_freq
      else 
        Initialized%conv_alarm = Nml%donner_deep_freq -   &
                                 MOD (secs, Nml%donner_deep_freq)
      endif

!----------------------------------------------------------------------
!    initialize the variables which must be returned from donner_deep_mod
!    on the first step when coldstarting.
!----------------------------------------------------------------------
      Don_save%cemetf            = 0.
      Don_save%cememf            = 0.
      Don_save%tracer_tends      = 0.
      Don_save%mass_flux         = 0.
      Don_save%mflux_up          = 0.
      Don_save%cell_up_mass_flux = 0.
      Don_save%det_mass_flux     = 0.
      Don_save%dql_strat         = 0.
      Don_save%dqi_strat         = 0.
      Don_save%dqa_strat         = 0.
      Don_save%humidity_area     = 0.
      Don_save%humidity_factor   = 0.
      Don_save%tprea1            = 0.
      Don_save%parcel_disp       = 0.

!----------------------------------------------------------------------


end subroutine process_coldstart






!#####################################################################





                     end module nonfms_donner_mod



 
!VERSION NUMBER:
!  $Name: hiram_20101115_bw $
!  $Id: wet_deposition_0D.F90,v 17.0.2.1.4.1 2010/03/17 20:27:08 wfc Exp $

!<SUBROUTINE NAME = "wet_deposition_0D">
!<TEMPLATE>
!CALL wet_deposition_0D( Henry_constant, Henry_variable, &
!                        frac_in_cloud, alpha_r, alpha_s, &
!                        T, p0, p1, rho_air, &
!                        cloud, precip, &
!                        tracer, Lgas, Laerosol, Lice, &
!                        delta_tracer )
!</TEMPLATE>
subroutine wet_deposition_0D( Henry_constant, Henry_variable, &
                              frac_in_cloud, alpha_r, alpha_s, &
                              T, p0, p1, rho_air, &
                              cloud, rain, snow, &
                              tracer, Lgas, Laerosol, Lice, &
                              delta_tracer )
implicit none
!      
!<OVERVIEW>
! Routine to calculate the fraction of tracer removed by wet deposition
!</OVERVIEW>
!
!<IN NAME="T" TYPE="real">
!   Temperature (K)
!</IN>
!<IN NAME="p0" TYPE="real">
!   Pressure (Pa) at layer closer to surface
!</IN>
!<IN NAME="p1" TYPE="real">
!   Pressure (Pa) at layer farther from surface
!</IN>
!<IN NAME="rho_air" TYPE="real">
!   Air density (kg/m3)
!</IN>
!<IN NAME="cloud" TYPE="real">
!   Cloud amount (liquid+ice) (kg/kg)
!</IN>
!<IN NAME="rain" TYPE="real">
!   Precipitation increment (rain) (kg/m3)
!</IN>
!<IN NAME="snow" TYPE="real">
!   Precipitation increment (snow) (kg/m3)
!</IN>
!<IN NAME="tracer" TYPE="real">
!   The tracer field (tracer units)
!</IN>
!<IN NAME="Lgas" TYPE="logical">
!   Is tracer a gas?
!</IN>
!<IN NAME="Laerosol" TYPE="logical">
!   Is tracer an aerosol?
!</IN>
!<IN NAME="Lice" TYPE="logical">
!   Is tracer removed by snow (or only by rain)?
!</IN>
!<OUT NAME="delta_tracer" TYPE="real">
!   The change (increment) of the tracer field due to wet deposition (tracer units)
!/OUT>
!<DESCRIPTION>
! Schemes allowed here are:
!
! 1) Removal according to Henry's Law. This law states that the ratio of the concentation in 
!    cloud water and the partial pressure in the interstitial air is a constant. In this 
!    instance, the units for Henry's constant are kg/L/Pa (normally it is M/L/Pa)
!    Parameters for a large number of species can be found at
!    http://www.mpch-mainz.mpg.de/~sander/res/henry.html
!
! 2) Aerosol removal, using specified in-cloud tracer fraction

! To utilize this section of code add one of the following lines as 
! a method for the tracer of interest in the field table.
!<PRE>
! "wet_deposition","henry","henry=XXX, dependence=YYY"
! "wet_deposition","henry_below","henry=XXX, dependence=YYY"
!     where XXX is the Henry's constant for the tracer in question
!       and YYY is the temperature dependence of the Henry's Law constant.
!
! "wet_deposition","aerosol","frac_incloud=XXX"
! "wet_deposition","aerosol_below","frac_incloud=XXX"
!     where XXX is the in-cloud fraction of the aerosol tracer
!</PRE>

!</DESCRIPTION>

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
real,             intent(in)                     :: Henry_constant, Henry_variable, &
                                                    frac_in_cloud, alpha_r, alpha_s
real,             intent(in)                     :: T, p0, p1, rho_air
real,             intent(in)                     :: cloud, rain, snow
real,             intent(in)                     :: tracer
logical,          intent(in)                     :: Lgas, Laerosol, Lice
real,             intent(out)                    :: delta_tracer

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
real :: &
      Htemp, xliq, n_air, pwt, pmid, precip
real :: &
      temp_factor, scav_factor, &
      w_h2o, beta, f_a, in_temp
real, parameter :: &
      GRAV = 9.80,              &  ! acceleration due to gravity [m/s2]
      RDGAS = 287.04,           &  ! gas constant for dry air [J/kg/deg]
      AVOGNO = 6.023000E+23,    &  ! Avogadro's number
      inv298p15 = 1./298.15,    &  ! 1/K
      cm3_2_m3 = 1.e-6             ! m3/cm3
real, parameter :: mw_air = 28.96440E-03 ! molar mass of air (kg/mole)
real, parameter :: mw_h2o = 18.0E-03  ! molar mass of H2O (kg/mole)

!-----------------------------------------------------------------------

delta_tracer = 0.

pmid = 0.5 * (p0+p1)         ! Pa
pwt     = ( p0 - p1 )/GRAV   ! kg/m2

if( Lgas .or. Laerosol ) then
!++lwh
! units = VMR
!
! Henry_constant (mole/L/Pa) = [X](aq) / Px(g) 
! where [X](aq) is the concentration of tracer X in precipitation (mole/L)
!       Px(g) is the partial pressure of the tracer in the air (Pa)
!
! VMR (total) = VMR (gas) + VMR (aq)
!             = VMR (gas) + [X] * L
!
! where L = cloud liquid amount (kg H2O/mole air)
!
! Using Henry's Law, [X] = H * Px = H * VMR(gas) * Pfull
!
! So, VMR (total) =  VMR(gas) * [ 1 + H * Pfull * L ]
! 
! VMR(gas) = VMR(total) / [1 + H * Pfull * L]
!
! [X] = H * Pfull * VMR(total) / [ 1 + H * Pfull * L]
!
! Following Giorgi and Chameides, JGR, 90(D5), 1985, the first-order loss
! rate constant (s^-1) of X due to wet deposition equals:
!
! k = W_X / n_X
!
! where W_x = the loss rate (molec/cm3/s), and n_X = the number density (molec/cm3)
! 
! W_X = [X] * W_H2O / (55 mole/L)
! n_x = VMR(total) * n_air (molec/cm3) = VMR(total) * P/(kT) * 1E-6 m3/cm3
! 
! where P = atmospheric pressure (Pa)
!       k = Boltzmann's constant = 1.38E-23 J/K
!       T = temperature (K)
!       W_H2O = removal increment of water (molec/cm3)
! 
!             [X] * W_H2O / 55         
! So, k = ------------------------------
!         VMR(total) * P/(kT) * 1E-6
! 
!         W_H2O    H * VMR(total) * P / [ 1 + H * P *L ]
!       = ----- * ---------------------------------------
!          55          VMR(total) * P/(kT) * 1E-6
! 
!         W_H2O     H * kT * 1E6
!       = ----- *  -------------    
!          55      1 + H * P * L 
!
!         W_H2O     1     1     H * P * L
!       = ----- * ----- * - * -------------
!          55     n_air   L   1 + H * P * L
!
! where W_H2O = precip (kg/m3) * (AVOGNO/mw_h2o) (molec/kg) * 1E-6 m3/cm3
!
   if( (Lgas .and. Henry_constant > 0.) .or. Laerosol ) then
      if (Lice) then
         precip = rain+snow
      else
         precip = rain
      end if
      in_temp = 0.

      scav_factor = 0.0
      xliq = MAX( cloud * mw_air, 0. ) ! (kg H2O)/(mole air)
      n_air = rho_air * (AVOGNO/mw_air) * cm3_2_m3 ! molec/cm3
      if (Lgas) then
! Calculate the temperature dependent Henry's Law constant
         temp_factor = 1/T-inv298p15
         Htemp = Henry_constant * exp( Henry_variable*temp_factor )
         f_a = Htemp * pmid * xliq
         scav_factor = f_a / ( 1.+f_a )
      else if (Laerosol) then
         scav_factor = frac_in_cloud
      end if
      if (precip > 0. .and. xliq > 0.) then
         w_h2o = precip * (AVOGNO/mw_h2o) * cm3_2_m3 ! molec/cm3
         beta = w_h2o * mw_h2o  / (n_air * xliq)   ! fraction of condensed water removed
         beta = MAX(MIN(beta,1.),0.)
         in_temp = beta * scav_factor              ! fraction of tracer removed
      end if

!     wdep_in = - in_temp*tracer*pwt
!     dt_temp = 1. - exp( -in_temp*dt ) ! fractional loss/timestep
!     tracer_dt = dt_temp / dt !+ve loss frequency (1/sec)
      delta_tracer = in_temp ! fraction of tracer removed
!--lwh
   endif 

end if

! Now multiply by the tracer mixing ratio to get the actual tendency.
! tracer_dt = MIN( MAX(tracer_dt, 0.0E+00), 0.5/dt)
if (tracer > 0.) then
   delta_tracer = delta_tracer*tracer
else
   delta_tracer = 0.
end if

! Output diagnostics in kg/m2/s (if MMR) or mole/m2/s (if VMR)
! if(trim(units) .eq. 'mmr') then
!    diag_scale = 1.
! else if(trim(units) .eq. 'vmr') then
!    diag_scale = mw_air ! kg/mole
! else
!    write(*,*) ' Tracer number =',n,' tracer_name=',tracer_name
!    write(*,*) ' scheme=',text_in_scheme
!    write(*,*) ' control=',control
!    write(*,*) ' scheme=',scheme
!    write(*,*) 'Please check field table'
!    write(*,*) 'tracers units =',trim(units),'it should be either  mmr or vmr!'
!  <ERROR MSG="Unsupported tracer units" STATUS="FATAL">
!     Tracer units must be either VMR or MMR
!  </ERROR>
!    call error_mesg('wet_deposition', 'Unsupported tracer units.', FATAL )
! end if

! if(trim(cloud_param) == 'donner') then
!    if (id_tracer_wdep_donin(n) > 0 ) then
!        used = send_data ( id_tracer_wdep_donin(n), wdep_in/diag_scale, Time, is_in=is, js_in=js)
!    endif
!    if(id_tracer_wdep_donin_dt(n) > 0) then
!       used = send_data ( id_tracer_wdep_donin_dt(n), in_temp, Time, is_in=is, js_in=js, ks_in=1)
!    endif
!    if(id_tracer_wdep_don_dt(n) > 0) then
!       used = send_data ( id_tracer_wdep_don_dt(n), dt_temp/dt, Time, is_in=is, js_in=js, ks_in=1)
!    endif
! endif

end subroutine wet_deposition_0D
!</SUBROUTINE>


  MODULE DRY_ADJ_MOD

!=======================================================================
!          DRY ADIABATIC ADJUSTMENT       
!=======================================================================

 use       mpp_mod, only: input_nml_file
 use       Fms_Mod, ONLY: FILE_EXIST, ERROR_MESG, OPEN_NAMELIST_FILE, &
                          CHECK_NML_ERROR,                   &
                          mpp_pe, mpp_root_pe, FATAL, WARNING, CLOSE_FILE, &
                          stdlog, write_version_number
 use Constants_Mod, ONLY: Grav, Kappa
!---------------------------------------------------------------------
 implicit none
 private

 public :: dry_adj, dry_adj_init, dry_adj_end, dry_adj_bdgt

!---------------------------------------------------------------------

 character(len=128) :: version = '$Id: dry_adj.F90,v 17.0.4.1 2010/08/30 20:33:34 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.

!---------------------------------------------------------------------

  real,    parameter :: p00     = 1000.0E2

!---------------------------------------------------------------------
! --- NAMELIST
!---------------------------------------------------------------------
!     itermax - Max number of iterations
!---------------------------------------------------------------------

  integer :: itermax = 5
  real    :: small = 0.001
  logical :: do_mcm_dry_adj = .false.
    
  NAMELIST / dry_adj_nml / itermax, small, do_mcm_dry_adj

!---------------------------------------------------------------------

  contains

!#######################################################################
!#######################################################################

  SUBROUTINE DRY_ADJ ( temp0, pres, pres_int, dtemp, mask )

!=======================================================================
!  DRY ADIABATIC ADJUSTMENT
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!     temp0    - Temperature
!     pres     - Pressure
!     pres_int - Pressure at layer interface
!     mask     -  OPTIONAL; floating point mask (0. or 1.) designating 
!                 where data is present
!---------------------------------------------------------------------
  real, intent(in), dimension(:,:,:) :: temp0, pres, pres_int

  real, intent(in), OPTIONAL, dimension(:,:,:) :: mask

!---------------------------------------------------------------------
! Arguments (Intent out)
!     dtemp - Change in temperature
!---------------------------------------------------------------------
  real, intent(out), dimension(:,:,:) :: dtemp

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
 
  real, dimension(size(temp0,1),size(temp0,2),size(temp0,3)) ::     &
        temp, pi, theta, pixdp, dpres, ppp
 
  real,    dimension(size(temp0,1),size(temp0,2)) :: store, xxx
  logical, dimension(size(temp0,1),size(temp0,2)) :: do_daa
 
  integer :: kmax, iter, k
  logical :: do_any, did_adj

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

! --- Check to see if dry_adj has been initialized
  if(.not. module_is_initialized ) CALL ERROR_MESG( 'DRY_ADJ', &
                           'dry_adj_init has not been called', FATAL )

! --- Set dimensions
  kmax  = size( temp0, 3 )

! --- Compute pressure thickness of layers
  dpres(:,:,1:kmax) = pres_int(:,:,2:kmax+1) - pres_int(:,:,1:kmax)

! --- Copy input temperature
  temp = temp0

! --- Compute exner function
  pi = ( pres / p00 ) ** Kappa                                   

! --- Compute product of pi and dpres
  pixdp = pi * dpres

! --- Compute potential temperature
  theta = temp / pi                  

  if(do_mcm_dry_adj) then
    do k = 2,kmax
      xxx = 0.5*kappa*(pres(:,:,k) - pres(:,:,k-1))/pres_int(:,:,k)
      ppp(:,:,k) = (1.0 + xxx)/(1.0 - xxx)
    enddo
  endif
    
!-----------------------------------------------------------------
! iteration loop starts           
!-----------------------------------------------------------------
  do iter = 1,itermax
!-----------------------------------------------------------------           

  did_adj = .false.

  do k = 1,kmax - 1
! ----------------------------------------------

! --- Flag layers needing adjustment
  if(do_mcm_dry_adj) then
    do_daa(:,:) = temp(:,:,k+1) > ( temp(:,:,k)*ppp(:,:,k+1) + small )
  else
    do_daa(:,:) = ( theta(:,:,k+1) - theta(:,:,k) ) > small
  endif
  
  if( PRESENT( mask ) ) then
  do_daa(:,:) = do_daa(:,:) .and. ( mask(:,:,k+1) > 0.5 )
  endif
  do_any = ANY( do_daa(:,:) )

! --- Do adjustment
 if ( do_any ) then
   if(do_mcm_dry_adj) then
     where ( do_daa )
       temp(:,:,k) = (temp(:,:,k)  * dpres(:,:,k  )   + &
                      temp(:,:,k+1)* dpres(:,:,k+1) )   &
                   /(dpres(:,:,k) + ppp(:,:,k+1)*dpres(:,:,k+1))
       temp(:,:,k+1) = temp(:,:,k)*ppp(:,:,k+1)
     end where
     did_adj = .true.
   else
     where ( do_daa )
       store(:,:) = ( theta(:,:,k  ) * pixdp(:,:,k  )     &
                   +  theta(:,:,k+1) * pixdp(:,:,k+1) )   &
                  / ( pixdp(:,:,k  ) + pixdp(:,:,k+1) )
       theta(:,:,k  ) = store(:,:)
       theta(:,:,k+1) = store(:,:)
        temp(:,:,k  ) = pi(:,:,k  ) * theta(:,:,k  ) 
        temp(:,:,k+1) = pi(:,:,k+1) * theta(:,:,k+1)
     end where
     did_adj = .true.
   endif
 end if

! ----------------------------------------------
  end do

! --- If no adjusment made this pass, exit iteration loop.
  if ( .not. did_adj ) go to 900

!-----------------------------------------------------------------
  end do
!-----------------------------------------------------------------
! iteration loop ends           
!-----------------------------------------------------------------
 if(.not.do_mcm_dry_adj) then
     call error_mesg ('DRY_ADJ', 'Non-convergence in dry_adj', WARNING)
 endif
 900 continue
    
! --- Compute change in temperature
  dtemp = temp - temp0
    
!=======================================================================
  end SUBROUTINE DRY_ADJ

!#####################################################################
!#####################################################################

  SUBROUTINE DRY_ADJ_INIT()

!=======================================================================
! ***** INITIALIZE RAS
!=======================================================================

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

  integer :: unit, io, ierr, logunit

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

!---------------------------------------------------------------------
! --- READ NAMELIST
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=dry_adj_nml, iostat=io)
  ierr = check_nml_error(io,"dry_adj_nml")
#else
  if( FILE_EXIST( 'input.nml' ) ) then
      unit = OPEN_NAMELIST_FILE ()
      ierr = 1
  do while ( ierr /= 0 )
      READ( unit, nml = dry_adj_nml, iostat = io, end = 10 )
      ierr = check_nml_error(io,'dry_adj_nml')
  end do
  10  CALL CLOSE_FILE ( unit )
  end if
#endif

!------- write version number and namelist ---------

  if ( mpp_pe() == mpp_root_pe() ) then
       call write_version_number(version, tagname)
       logunit = stdlog()
       write (logunit, nml = dry_adj_nml ) 
  endif

!-------------------------------------------------------------------

  module_is_initialized = .true.

!=====================================================================
  end SUBROUTINE DRY_ADJ_INIT


!#######################################################################
!#######################################################################

  SUBROUTINE DRY_ADJ_END

!-------------------------------------------------------------------

  module_is_initialized = .true.

!=====================================================================
  end SUBROUTINE DRY_ADJ_END


!#######################################################################
!#######################################################################

  SUBROUTINE DRY_ADJ_BDGT ( dtemp, pres_int )

!=======================================================================
! Budget check for dry adiabatic adjustment - a debugging tool
!=======================================================================

!---------------------------------------------------------------------
! Arguments (Intent in)
!     dtemp    - Temperature change 
!     pres_int - Pressure at layer interface
!---------------------------------------------------------------------
  real, intent(in), dimension(:,:,:) :: dtemp, pres_int

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

 real, dimension(size(dtemp,1),size(dtemp,2),size(dtemp,3)) ::  dpres
 real    :: sum_dtemp
 integer :: imax, jmax, kmax, i, j, k

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

  imax = size ( dtemp, 1 )
  jmax = size ( dtemp, 2 )
  kmax = size ( dtemp, 3 )

! --- Compute pressure thickness of layers
  dpres(:,:,1:kmax) = pres_int(:,:,2:kmax+1) - pres_int(:,:,1:kmax)

! --- Check budget

  do j = 1,jmax
  do i = 1,imax

    sum_dtemp = 0.                                                          

  do k = 1,kmax
    sum_dtemp = sum_dtemp + dtemp(i,j,k)*dpres(i,j,k) / Grav                                   
  end do

  if ( abs( sum_dtemp ) > 1.0e-4 ) then
    print *
    print *, ' DRY ADIABATIC ADJUSTMENT BUDGET CHECK AT i,j = ', i,j
    print *, ' sum_dtemp  = ',  sum_dtemp                                                                  
    print *, 'STOP'
!    STOP
  endif

  end do
  end do

!=======================================================================
  end SUBROUTINE DRY_ADJ_BDGT

!#######################################################################
!#######################################################################
  end MODULE DRY_ADJ_MOD


module edt_mod

!=======================================================================
!
!
!
!      EDT (Entrainment and Diagnostic Turbulence) MODULE
!
!
!      February 2002
!      Contact person: Steve Klein
!
!
!      These routines calculate the diffusivity coefficients for
!      momentum and temperature-moisture-scalars using the moist
!      thermodynamcs modules based on:
!
!      H. Grenier and C. Bretherton, 2001: A moist PBL parameterization
!      for large-scale models and its application to subtropical
!      cloud-topped marine boundary layers. Mon. Wea. Rev., 129,
!      357-377.
!
!      The actual routine is not described in this paper but is
!      a simplified extension of the parameterization discussed
!      here.  The original code, given to Steve Klein from 
!      Chris Bretherton in May 2001, was tested in the NCAR 
!      atmospheric model, formerly known as CCM. The code has 
!      been adapted for the FMS system by Steve Klein and Paul
!      Kushner.
!
!
!      To quote the Bretherton and Grenier description:
!
!      Driver routine to compute eddy diffusion coefficients for 
!      momentum, moisture, trace constituents and static energy.  Uses 
!      first order closure for stable turbulent layers. For convective 
!      layers, an entrainment closure is used, coupled to a diagnosis 
!      of layer-average TKE from the instantaneous thermodynamic and 
!      velocity profiles. Convective layers are diagnosed by extending 
!      layers of moist static instability into adjacent weakly stably 
!      stratified interfaces, stopping if the stability is too strong.  
!      This allows a realistic depiction of dry convective boundary 
!      layers with a downgradient approach."
! 
!      Authors:  Herve Grenier, 06/2000, Chris Bretherton 09/2000
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! outside modules used
!

use      constants_mod, only: grav,vonkarm,cp_air,rdgas,rvgas,hlv,hls, &
                              tfreeze,radian

use            mpp_mod, only: input_nml_file
use            fms_mod, only: file_exist, open_namelist_file, error_mesg, FATAL,&
                              NOTE, mpp_pe, mpp_root_pe, close_file, read_data, &
                              write_data, write_version_number, stdlog, &
                              open_restart_file, open_file, check_nml_error

use   diag_manager_mod, only: register_diag_field, send_data
        
use   time_manager_mod, only: time_type, get_date, month_name
 
use  monin_obukhov_mod, only: mo_diff

use sat_vapor_pres_mod, only: compute_qs

implicit none
private

!-----------------------------------------------------------------------
!
!      public interfaces

public edt, edt_init, edt_end, edt_on, qaturb, qcturb,tblyrtau

!-----------------------------------------------------------------------
!
!      global storage variable
!

real, allocatable, dimension(:,:,:) :: qaturb ! cloud fraction diagnosed
                                              ! from turbulence model
      ! (fraction)
real, allocatable, dimension(:,:,:) :: qcturb ! cloud condensate 
                                              ! diagnosed from turb.
      ! model (kg liq/kg air)
real, allocatable, dimension(:,:,:) :: tblyrtau  ! turbulent layer
                                                 ! time scale
 ! (seconds)
real, allocatable, dimension(:,:,:) :: sigmas ! standard deviation of 
                                              ! water perturbation
                                              ! (kg water/kg air)     

!-----------------------------------------------------------------------
!
!      set default values to namelist parameters       
!

character :: sftype  = "z"           ! method for calculating sat frac
real      :: qcminfrac = 1.e-3       ! Min condensate counted as cloud
                                     ! as a fraction of qsat.
logical   :: use_qcmin = .true.      ! Use qcminfrac as indicator of
                                     ! of cloud top.
logical   :: use_extrapolated_ql  = .false.  ! should the layer top
                                             ! liquid water be used to
     ! estimate the evaporative
     ! enhancement
integer   :: n_print_levels = 14     ! how many of the lowest levels 
                                     ! should be printed out
integer, dimension(2) :: edt_pts = 0 ! the global indices for i,j
                                     ! at which diagnostics will 
                                     ! print out
logical   :: do_print = .false.      ! should selected variables 
                                     ! be sent to logfile
logical   :: column_match = .false.  ! should this column be printed 
                                     ! out?
integer   :: dpu = 0                 ! unit # for do_print output
 
real      :: min_adj_time = 0.25     ! minimum adjustment time of
                                     ! turbulent layer for thermo-
                                     ! dynamics, as a fraction of
                                     ! the physics time step. 
! 
! the following quantities only deal with the gaussian cloud model 
!
 
logical   :: do_gaussian_cloud = .false.  

real      :: kappa   = 0.5       ! absolute value of the correlation
                                 ! coefficient between sli and qt 
 ! fluctions
real      :: mesovar = 0.02      ! amplitude to mesoscale fluctuations
                                 ! in sigma-s as a fraction of the 
 ! saturation specific humidity
         

integer, parameter                 :: MAX_PTS = 20
integer, dimension (MAX_PTS)       :: i_edtprt_gl=0, j_edtprt_gl=0
real, dimension(MAX_PTS)           :: lat_edtprt=999., lon_edtprt=999.
integer                            :: num_pts_ij = 0
integer                            :: num_pts_latlon = 0



namelist /edt_nml/sftype,qcminfrac,use_qcmin,kappa,mesovar,edt_pts,    &
              do_gaussian_cloud,n_print_levels,use_extrapolated_ql, &
                                  min_adj_time, &
                                  i_edtprt_gl, j_edtprt_gl, &
                                  num_pts_ij, num_pts_latlon,       &
                                  lat_edtprt, lon_edtprt
  
 
integer     :: num_pts           !  total number of columns in which
                                 !  diagnostics are desired

!---------------------------------------------------------------------
!    deglon1 and deglat1 are the longitude and latitude of the columns
!    at which diagnostics will be calculated (degrees).
!---------------------------------------------------------------------
real,    dimension(:), allocatable  :: deglon1, deglat1
 
!---------------------------------------------------------------------
!    iradprt and jradprt are the processor-based i and j coordinates 
!    of the desired diagnostics columns.
!---------------------------------------------------------------------
integer, dimension(:), allocatable  :: j_edtprt, i_edtprt

!---------------------------------------------------------------------
!    do_raddg is an array of logicals indicating which latitude rows
!    belonging to the processor contain diagnostics columns.
!---------------------------------------------------------------------
logical, dimension(:), allocatable  :: do_edt_dg

!-----------------------------------------------------------------------
!
!      diagnostic fields       
!

character(len=10) :: mod_name = 'edt'
real              :: missing_value = -999.
integer           :: id_fq_cv_int,    id_fq_cv_top,      id_fq_cv_bot, &
                     id_fq_st,   id_n2,      id_s2,      id_ri,        &
     id_leng,    id_bprod,   id_sprod,   id_trans,     &
     id_diss,    id_qaedt,   id_qcedt,   id_tauinv,    &
     id_eddytau, id_fq_turb, id_sigmas,  id_radf,      &
     id_sh,      id_sm,      id_gh,      id_evhc
       
      
!-----------------------------------------------------------------------
!
!      set default values to parameters       
!

logical         :: edt_on = .false.
logical         :: init = .false.
real, parameter :: small  = 1.e-8      
real, parameter :: fpi  = 3.14159     ! pi
real, parameter :: d608 = (rvgas-rdgas)/rdgas
real, parameter :: d622 = rdgas/rvgas
real, parameter :: d378 = 1. - d622
real, parameter :: frac_sfclyr = 0.1  ! height of surface layer top as a 
                                      ! fraction of the pbl height

!-----------------------------------------------------------------------
!
!      the following parameters are those defined only in the routines
!      provided by Chris Bretherton and Herve Grenier
!

real, parameter :: ntzero  = 1.e-10   ! not zero, used to set min value
                                      ! to s2, shear-squared.
real, parameter :: zvir    = d608  

real, parameter :: b1      =   5.8    ! TKE dissipation = e^3/(b1*leng)
real            :: b123    =   3.2281 ! b1**(2/3)
real, parameter :: tunl    =   0.085  ! Asympt leng = 
                                      !       tunl*(turb lyr depth)
real, parameter :: alph1   =   0.5562 ! Galperin stability fn params
real, parameter :: alph2   =  -4.3640
real, parameter :: alph3   = -34.6764
real, parameter :: alph4   =  -6.1272
real, parameter :: alph5   =   0.6986
real, parameter :: ricrit  =   0.19   ! Critical Richardson # for turb.
real, parameter :: mu      =  70.     ! used in finding e/ebar in 
                                      ! convective layers (CLs)
real, parameter :: rinc    =  -0.5    ! Min W/<W> for incorp into CL

! params governing entr. effic. A=a1l*evhc, evhc=1+a2l*a3l*L*ql/jt2slv
! where ql is cloud-top liq. water and jt2slv is the jump in slv across
! the cloud-top entrainment zone.

real, parameter :: a1l       =  0.10  ! Dry entrainment efficiency param
                                      ! Herve set to 0.05 due to excess 
      ! TKE but a1l = 0.10 = 0.2*tunl*
      ! erat^-1.5 should be the "real" 
      ! value, where erat = <e>/wstar^2 
      ! for dry CBL = 0.3
real, parameter :: a2l       = 15.    ! Moist entrainment enhancement 
                                      ! param Herve's SCCM value was 15
real, parameter :: a3l       =  0.8   ! 
real, parameter :: jbumin    =  0.001 ! Min buoyancy jump at an entrain-
                                      ! ment interface (m/s2)
      ! (~ jump in K/30)
real, parameter :: evhcmax   = 10.    ! Max entrainment efficiency
real, parameter :: rimaxentr =  0.    ! Limiting Ri for entraining turb
                                      ! layer
      
!  parameters affecting TKE

real, parameter :: rmin    =   0.1    ! Min allowable e/<e> in a CL
real, parameter :: rmax    =   2.0    ! Max allowable e/<e> in a CL
real, parameter :: tkemax  =  20.     ! tke capped at tkemax (m2/s2)
real, parameter :: tkemin  =   1.e-6  ! tke minimum (m2/s2)

!-----------------------------------------------------------------------
!
! declare version number 
!

character(len=128) :: Version = '$Id: edt.F90,v 17.0.6.2 2010/09/07 14:16:07 wfc Exp $'
character(len=128) :: Tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized = .false.
!-----------------------------------------------------------------------
!
! fms module subroutines include:
!
!      edt         main driver program of the module
!
!      edt_init    initialization routine       
!
!      edt_tend    adds in the longwave heating rate to the 
!                         global storage variable
!
!      edt_end     ending routine
!
!
!      Grenier-Bretherton subroutines are described after the 
!      subroutines listed above.
!


      integer, dimension(1) :: restart_versions = (/ 1 /)

contains




!======================================================================= 
!
!      subroutine edt_init 
!        
!
!      this subroutine reads the namelist file and restart data
!      and initializes some constants.
!        

subroutine edt_init(lonb, latb, axes,time,idim,jdim,kdim)

!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
! 
!      idim,jdim,kdim    size of the first 3 dimensions 
!      axes, time        variables needed for netcdf diagnostics
!      latb, lonb        latitudes and longitudes at grid box corners
!
!
!      --------
!      internal
!      --------
! 
!      unit              unit number for namelist and restart file
!      io                internal variable for reading of namelist file
!      full              indices for full level axes coordinates
!      half              indices for half level axes coordinates
!
!-----------------------------------------------------------------------

integer,         intent(in) :: idim,jdim,kdim,axes(4)
type(time_type), intent(in) :: time
real, dimension(:,:),intent(in) :: lonb, latb

integer                     :: unit,io, logunit, ierr
integer :: vers, vers2
character(len=4) :: chvers
integer, dimension(3)       :: full = (/1,2,3/), half = (/1,2,4/)
integer     :: nn, i, j
real         :: dellat, dellon

!-----------------------------------------------------------------------
!
!      namelist functions

#ifdef INTERNAL_FILE_NML
       read (input_nml_file, nml=edt_nml, iostat=io)
       ierr = check_nml_error(io,'edt_nml')
#else   
       if (file_exist('input.nml')) then
          unit = open_namelist_file ()
          ierr=1 ; Do While (ierr .ne. 0)
            Read  (unit, nml=edt_nml, iostat=io, End=10)
            ierr = check_nml_error(io,'edt_nml')
          enddo
10        Call Close_File (unit)
       endif
#endif

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=edt_nml)
       endif


!      if (edt_pts(1) > 0 .and.edt_pts (2) >0) do_print = .true.

!      if (do_print) then
!!RSH  unit = Open_File ('edt.out', action='write')
!      dpu  = Open_File ('edt.out', threading='multi', action='write')
!      if ( get_my_pe() == 0 ) then
!           Write (unit,'(/,80("="),/(a))') trim(Version), trim(Tag)
!           Write (unit,nml=edt_nml)
!      endif
!!     Call Close_File (unit)
!      end if
       
!---------------------------------------------------------------------
!    allocate and initialize a flag array which indicates the latitudes
!    containing columns where radiation diagnostics are desired.
!---------------------------------------------------------------------
      allocate (do_edt_dg (size(latb,2)-1) )
      do_edt_dg(:) = .false.

!-------------------------------------------------------------------
!    define the total number of points at which diagnostics are desired.
!    points may be specified either by lat-lon pairs or by global index
!    pairs. 
!-------------------------------------------------------------------
      num_pts = num_pts_latlon + num_pts_ij

!-------------------------------------------------------------------
!    continue on only if diagnostics are desired in at least one column.
!-------------------------------------------------------------------
      if (num_pts > 0) then

!-------------------------------------------------------------------
!    if more points are desired than space has been reserved for, print 
!    a message.
!-------------------------------------------------------------------
        if (num_pts > MAX_PTS) then
          call error_mesg ( 'edt_mod', &
         'must reset MAX_PTS or reduce number of diagnostics points', &
                                                             FATAL)
        endif

!-------------------------------------------------------------------
!    allocate space for arrays which will contain the lat and lon and
!    processor-local i and j indices.
!-------------------------------------------------------------------
        allocate ( deglon1 (num_pts))
        allocate ( deglat1 (num_pts))
        allocate ( j_edtprt (num_pts))
        allocate ( i_edtprt (num_pts))

!---------------------------------------------------------------------
!    if any points for diagnostics are specified by (i,j) global 
!    indices, determine their lat-lon coordinates. assumption is made 
!    that the deltas of latitude and longitude are uniform over 
!    the globe.
!---------------------------------------------------------------------
        do nn=1,num_pts_ij
          dellat = latb(1,2) - latb(1,1)
          dellon = lonb(2,1) - lonb(1,1)
          lat_edtprt(nn + num_pts_latlon) =     &
                      (-0.5*acos(-1.0) + (j_edtprt_gl(nn) - 0.5)*  &
                                           dellat) * radian
          lon_edtprt(nn + num_pts_latlon) =                & 
                       (i_edtprt_gl(nn) - 0.5)*dellon*radian
        end do

!--------------------------------------------------------------------
!    determine if the lat/lon values are within the global grid,
!    latitude between -90 and 90 degrees and longitude between 0 and
!    360 degrees.
!--------------------------------------------------------------------
        do nn=1,num_pts
          j_edtprt(nn) = 0
          i_edtprt(nn) = 0
          deglat1(nn) = 0.0
          deglon1(nn) = 0.0
          if (lat_edtprt(nn) .ge. -90. .and. &
              lat_edtprt(nn) .le.  90.) then
          else
            call error_mesg ('edt_mod', &
                ' invalid latitude for edt diagnostics ', FATAL)
          endif

          if (lon_edtprt(nn) .ge. 0. .and. &
              lon_edtprt(nn) .le. 360.) then
          else
            call error_mesg ('edt_mod', &
                ' invalid longitude for edt diagnostics ', FATAL)
          endif

!--------------------------------------------------------------------
!    determine if the diagnostics column is within the current 
!    processor's domain. if so, set a logical flag indicating the
!    presence of a diagnostic column on the particular row, define the 
!    i and j processor-coordinates and the latitude and longitude of 
!    the diagnostics column.
!--------------------------------------------------------------------
          do j=1,size(latb,2) - 1
            if (lat_edtprt(nn) .ge. latb(1,j)*radian .and.  &
                lat_edtprt(nn) .lt. latb(1,j+1)*radian) then
              do i=1,size(lonb,1) - 1
                if (lon_edtprt(nn) .ge. lonb(i,1)*radian   &
                                  .and.&
                    lon_edtprt(nn) .lt. lonb(i+1,1)*radian)  &
                                   then
                  do_edt_dg(j) = .true.
                  j_edtprt(nn) = j
                  i_edtprt(nn) = i
                  deglon1(nn) = 0.5*(lonb(i,1) + lonb(i+1,1))*radian
                  deglat1(nn) = 0.5*(latb(1,j) + latb(1,j+1))*radian
                  exit
                endif
              end do
              exit
            endif
          end do
        end do

!----------------------------------------------------------------------
!    open a unit for the radiation diagnostics output.
!---------------------------------------------------------------------
        dpu = open_file ('edt.out', action='write', &
                                 threading='multi', form='formatted')
       do_print = .true.

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           write (dpu ,nml=edt_nml)
       endif
      endif     ! (num_pts > 0)

!-----------------------------------------------------------------------
!
!      initialize edt_on

       edt_on = .TRUE.
       module_is_initialized = .true.
!-----------------------------------------------------------------------
!
!      initialize b123 = b1**(2/3)

       b123 = b1**(2./3.)
       
!-----------------------------------------------------------------------
!
!      handle global storage
        
       if (allocated(qaturb)) deallocate (qaturb)
       allocate(qaturb(idim,jdim,kdim))
       if (allocated(qcturb)) deallocate (qcturb)
       allocate(qcturb(idim,jdim,kdim))
       if (allocated(tblyrtau)) deallocate (tblyrtau)
       allocate(tblyrtau(idim,jdim,kdim))
       if (allocated(sigmas)) deallocate (sigmas)
       allocate(sigmas(idim,jdim,kdim+1))
              
       if (File_Exist('INPUT/edt.res')) then
         unit = Open_restart_File (FILE='INPUT/edt.res', ACTION='read')
         read (unit, iostat=io, err=142) vers, vers2
142      continue
 
!--------------------------------------------------------------------
!    if eor is not encountered, then the file includes tdtlw as the
!    first record (which this read statement read). that data is not 
!    needed; note this and continue by reading next record.
!--------------------------------------------------------------------
         if (io == 0) then
           call error_mesg ('edt_mod',  &
              'reading pre-version number edt.res file, '//&
                'ignoring tdtlw', NOTE)

!--------------------------------------------------------------------
!    if the first record was only one word long, then the file is a 
!    newer one, and that record was the version number, read into vers. 
!    if it is not a valid version, stop execution with a message.
!--------------------------------------------------------------------
         else
           if (.not. any(vers == restart_versions) ) then
             write (chvers, '(i4)') vers
             call error_mesg ('edt_mod',  &
                   'restart version ' // chvers//' cannot be read '//&
                    'by this version of edt_mod.', FATAL)
           endif
         endif

!---------------------------------------------------------------------
            call read_data (unit, qaturb)
            call read_data (unit, qcturb)
    call read_data (unit, tblyrtau)
    call read_data (unit, sigmas)
    call Close_File (unit)
       else
    qaturb  (:,:,:) = 0.
    qcturb  (:,:,:) = 0.
    tblyrtau(:,:,:) = 0.
    sigmas  (:,:,:) = 0.
       endif

!-----------------------------------------------------------------------
!
! register diagnostic fields       

       id_fq_cv_int = register_diag_field (mod_name, 'fq_cv_int',      &
            axes(half), time, 'Frequency that the interface is in '//  &
    'the interior of a convective layer from EDT',             &
    'none', missing_value=missing_value )

       id_fq_cv_top = register_diag_field (mod_name, 'fq_cv_top',      &
            axes(half), time, 'Frequency that the interface is at '//  &
    'the top of a convective layer from EDT',                  &
    'none', missing_value=missing_value )

       id_fq_cv_bot = register_diag_field (mod_name, 'fq_cv_bot',      &
            axes(half), time, 'Frequency that the interface is at '//  &
    'the bottom of a convective layer from EDT',               &
    'none', missing_value=missing_value )

       id_fq_st = register_diag_field (mod_name, 'fq_st', axes(half),  &
           time, 'Frequency of stable turbulence from EDT',            &
    'none', missing_value=missing_value )

       id_fq_turb = register_diag_field (mod_name, 'fq_turb',          &
            axes(full), time, 'Frequency that the layer is fully '//   &
    'turbulent from EDT','none', missing_value=missing_value )

       id_n2 = register_diag_field (mod_name, 'n2', axes(half),        &
    time,'Moist Vaisala Frequency from EDT',                   &
    '(1/sec)**2', missing_value=missing_value )
       
       id_s2 = register_diag_field (mod_name, 's2', axes(half),        &
    time,'Shear vector magnitude squared from EDT',            &
    '(1/sec)**2', missing_value=missing_value )
       
       id_ri = register_diag_field (mod_name, 'ri', axes(half),        &
    time, 'Moist Richardson number from EDT',                  &
    'none', missing_value=missing_value )

       id_leng = register_diag_field (mod_name, 'leng', axes(half),    &
    time, 'Turbulent Length Scale from EDT',                   &
    'meters', missing_value=missing_value )
       
       id_bprod = register_diag_field (mod_name, 'bprod', axes(half),  &
    time, 'Buoyancy production of TKE from EDT',               &
    '(meters**2)/(sec**3)', missing_value=missing_value )

       id_sprod = register_diag_field (mod_name, 'sprod', axes(half),  &
    time, 'Shear production of TKE from EDT',                  &
    '(meters**2)/(sec**3)', missing_value=missing_value )
       
       id_trans = register_diag_field (mod_name, 'trans', axes(half),  &
    time, 'TKE transport from EDT',                            &
    '(meters**2)/(sec**3)', missing_value=missing_value )
       
       id_diss = register_diag_field (mod_name, 'diss', axes(half),    &
    time, 'TKE dissipation from EDT',                          &
    '(meters**2)/(sec**3)', missing_value=missing_value )

       id_radf  = register_diag_field (mod_name, 'radf', axes(half),   &
    time, 'TKE radiative forcing from EDT',                    &
    '(meters**2)/(sec**3)', missing_value=missing_value )
       
       id_sh  = register_diag_field (mod_name, 'sh', axes(half),       &
    time, 'Galperin heat stability coefficient from EDT',      &
    'none', missing_value=missing_value )
 
       id_sm  = register_diag_field (mod_name, 'sm', axes(half),       &
    time, 'Galperin momentum stability coefficient from EDT',  &
    'none', missing_value=missing_value )
 
       id_gh  = register_diag_field (mod_name, 'gh', axes(half),       &
    time, 'Galperin stability ratio from EDT',                 &
    'none', missing_value=missing_value )
 
       id_evhc  = register_diag_field (mod_name, 'evhc', axes(half),   &
    time, 'Evaporative cooling enhancement factor from EDT',   &
    'none', missing_value=missing_value )
 
       id_sigmas = register_diag_field (mod_name, 'sigmas', axes(half),&
    time, 'Std. dev. of water perturbation from EDT',          &
    '(kg water)/(kg air)', missing_value=missing_value )
       
       id_qaedt = register_diag_field (mod_name, 'qaedt', axes(full),  &
    time, 'statistical cloud fraction from EDT',               &
    'fraction', missing_value=missing_value )
       
       id_qcedt = register_diag_field (mod_name, 'qcedt', axes(full),  &
    time, 'statistical cloud condensate from EDT',             &
    'kg condensate/kg air', missing_value=missing_value )
       
       id_tauinv = register_diag_field (mod_name, 'tauinv', axes(half),&
    time, 'inverse large-eddy turnover time from EDT',         &
    '1/second', missing_value=missing_value )
       
       id_eddytau = register_diag_field (mod_name, 'eddytau',          &
            axes(full),time, 'large-eddy turnover time from EDT',      &
    'seconds', missing_value=missing_value )
                          
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine edt_init

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




!======================================================================= 
!
!      subroutine edt
!        
!
!       this subroutine is the main driver program to the routines
!       provided by Chris Bretherton
!        

subroutine edt(is,ie,js,je,dt,time,tdtlw_in, u_star,b_star,q_star,t,qv,ql,qi,qa, &
!              u,v,z_full,p_full,z_half,p_half,stbltop,k_m,k_t,kbot,   &
!       pblh,tke)
               u,v,z_full,p_full,z_half,p_half,stbltop,k_m,k_t,pblh,  &
       kbot,tke)

!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
!
!      is,ie,js,je  i,j indices marking the slab of model working on
!      dt        physics time step (seconds)
!      time      variable needed for netcdf diagnostics
!      u_star    friction velocity (m/s)
!      b_star    buoyancy scale (m/(s**2))
!      q_star    moisture scale (kg vapor/kg air)
!
!      three dimensional fields on model full levels, reals dimensioned
!      (:,:,pressure), third index running from top of atmosphere to 
!      bottom
!          
!      t         temperature (K)
!      qv        water vapor specific humidity (kg vapor/kg air)
!      ql        liquid water specific humidity (kg cond/kg air)
!      qi        ice water specific humidity (kg cond/kg air)
!      qa        cloud fraction 
!      u         zonal wind (m/s)
!      v         meridional wind (m/s) 
!      z_full    height of full levels (m)
!      p_full    pressure (Pa)
!
!      the following two fields are on the model half levels, with
!      size(z_half,3) = size(t,3) +1, z_half(:,:,size(z_half,3)) 
!      must be height of surface (if you are not using eta-model)
!
!      z_half    height at half levels (m)
!      p_half    pressure at half levels (Pa)
!        
!      ------
!      output
!      ------
!
!      stbltop   maximum altitude the very stable boundary layer
!                is permitted to operate
!
!      The following variables are defined at half levels and are
!      dimensions 1:nlev+1.
!
!      k_m       diffusivity for momentum (m**2/s)
!      k_t       diffusivity for temperature and scalars (m**2/s)
!
!      k_m and k_t are defined at half-levels so that size(k_m,3) 
!      should be at least as large as size(t,3). Note, however, that 
!      only the returned values at levels 2 to size(t,3) are 
!      meaningful; other values will be returned as zero.
!
!      --------------
!      optional input
!      --------------
!
!      kbot      integer indicating the lowest true layer of atmosphere
!
!      ---------------
!      optional output
!      ---------------
!
!      pblh      depth of planetary boundary layer (m)
!      tke       turbulent kinetic energy (m*m)/(s*s)
!
!      --------
!      internal
!      --------
!
!      z_surf    height of surface (m)
!      z_full_ag height of full model levels above the surface (m)
!      qt        total water specific humidity (kg water/kg air)
!      qc        cloud condensate spec. hum. (kg condensate/kg air)
!      qsl       saturation specific humidity at the midpoint pressure
!                and liquid-ice water temperature (kg water/kg air)
!      dqsldtl   temperature derivative of qsl (kg H20/kg air/Kelvin)
!      hleff     effective latent heat of vaporization (J/kg)
!      sli       ice-liq water static energy (J/kg) 
!      sliv      ice-liq water virtual static energy (J/kg)                                      
!      khfs      surface kinematic heat flux (K*(m/s)) 
!      kqfs      surface kinematic vapor flux (kg/kg)*(m/s)
!      slislope  sli slope wrt pressure in thermo layer (J/kg/Pa)
!      qtslope   qt slope wrt pressure in thermo layer (kg/kg/Pa)
!      qxtop     saturation excess at the top of the layer 
!                (kg wat/kg air)
!      qxbot     saturation excess at the bottom of the layer 
!                (kg wat/kg air)
!      sfuh      saturated fraction in upper half-layer
!      sflh      sflh saturated fraction in lower half-layer
!      sfclyr_h  height of the surface layer top (m)
!      ql_new    new value of cloud liquid  (kg cond/kg air)
!      qi_new    new value of cloud ice     (kg cond/kg air)
!      qa_new    new value of cloud fraction
!      mask      real array indicating the point is above the surface  &
!                if equal to 1.0 and indicating the point is below the &
!                surface if equal to 0.
!
!      mineddytau  minimum value to adjustment time (1/sec)
!
!
!      the following variables are defined on model half levels
!      (1:kdim+1)
!
!      z_half_ag height of half model levels above the surface (m)
!      chu       heat var. coef for dry states (1/m)
!      chs       heat var. coef for sat states (1/m)
!      cmu       moisture var. coef for dry states (kg/kg)*(m/s*s)
!      cms       moisture var. coef for sat states (kg/kg)*(m/s*s)
!      n2        moist squared buoyancy freq (1/s*s)
!      s2        squared deformation, or shear vector mag. (1/s*s)
!      ri        gradient Richardson number
!
!      formulas for selected internal variables
!      ----------------------------------------
!
!      qt   = qv + ql + qi                 qc   = ql + qi
!      sli  = cp*T + g*z - hleff*qc        sliv = sli*(1.+d608*qt)
!      khfs = mean of (w'T')               kqfs = mean of (w'q')
!
!-----------------------------------------------------------------------

integer,         intent(in)                            :: is,ie,js,je
real,            intent(in)                            :: dt
type(time_type), intent(in)                            :: time
real,            intent(in),  dimension(:,:,:)         :: tdtlw_in
real,            intent(in),  dimension(:,:)           :: u_star,b_star
real,            intent(in),  dimension(:,:)           :: q_star
real,            intent(in),  dimension(:,:,:)         :: t,qv,ql,qi,qa
real,            intent(in),  dimension(:,:,:)         :: u, v
real,            intent(in),  dimension(:,:,:)         :: z_full, p_full
real,            intent(in),  dimension(:,:,:)         :: z_half, p_half
real,            intent(out), dimension(:,:)           :: stbltop
real,            intent(out), dimension(:,:,:)         :: k_m,k_t
integer,         intent(in),  dimension(:,:), optional :: kbot
!real,            intent(out), dimension(:,:), optional :: pblh
real,            intent(out), dimension(:,:)           :: pblh
real,            intent(out), dimension(:,:,:),optional:: tke

integer                                         :: i,j,k,kk,ibot
integer                                         :: ipt,jpt
integer                                         :: nlev,nlat,nlon
integer, dimension(4,size(t,1),size(t,2),size(t,3)+1):: turbtype

real                                            :: khfs,kqfs
real                                            :: sfclyr_h_max
real                                            :: mineddytau
real, dimension(size(t,1),size(t,2))            :: z_surf, sfclyr_h
real, dimension(size(t,1),size(t,2),size(t,3))  :: z_full_ag
real, dimension(size(t,1),size(t,2),size(t,3))  :: qt,sli,sliv
real, dimension(size(t,1),size(t,2),size(t,3))  :: esl, qsl, dqsldtl
real, dimension(size(t,1),size(t,2),size(t,3))  :: hleff,density
real, dimension(size(t,1),size(t,2),size(t,3))  :: slislope, qtslope
real, dimension(size(t,1),size(t,2),size(t,3))  :: qxtop, qxbot
real, dimension(size(t,1),size(t,2),size(t,3))  :: qa_new, qc_new
real, dimension(size(t,1),size(t,2),size(t,3))  :: mask, isturb
real, dimension(size(t,1),size(t,2),size(t,3))  :: eddytau,tauinvtmp

real, dimension(size(t,1),size(t,2),size(t,3)+1):: z_half_ag
real, dimension(size(t,1),size(t,2),size(t,3)+1):: n2, s2, ri, tauinv
real, dimension(size(t,1),size(t,2),size(t,3)+1):: leng, bprod, sprod
real, dimension(size(t,1),size(t,2),size(t,3)+1):: trans, diss, evhc
real, dimension(size(t,1),size(t,2),size(t,3)+1):: radf, sh, sm, gh
real, dimension(size(t,1),size(t,2),size(t,3)+1):: mask3, tmpdat
real, dimension(size(t,1),size(t,2),size(t,3)+1):: k_t_mo, k_m_mo

integer, dimension(4,size(t,3)+1) :: gb_turbtype

real                        :: gb_pblh,     gb_u_star
real, dimension(size(t,3))  :: gb_t,        gb_u,        gb_v
real, dimension(size(t,3))  :: gb_qv
real, dimension(size(t,3))  :: gb_dqsldtl,  gb_qa_new,   gb_qc_new
real, dimension(size(t,3))  :: gb_sli,      gb_qt
real, dimension(size(t,3))  :: gb_qc,       gb_sliv,     gb_sflh
real, dimension(size(t,3))  :: gb_slisl,    gb_qtsl,     gb_sfuh
real, dimension(size(t,3))  :: gb_tdtlw,    gb_hleff
real, dimension(size(t,3))  :: gb_qsl,      gb_esl,      gb_qxtop
real, dimension(size(t,3))  :: gb_qxbot,    gb_density,  gb_z_full
real, dimension(size(t,3))  :: gb_p_full,   gb_isturb,   gb_qltop
real, dimension(size(t,3)+1):: gb_cmu,      gb_chu
real, dimension(size(t,3)+1):: gb_chs,      gb_cms
real, dimension(size(t,3)+1):: gb_k_m,      gb_k_t,      gb_tke
real, dimension(size(t,3)+1):: gb_n2,       gb_s2,       gb_ri
real, dimension(size(t,3)+1):: gb_leng,     gb_bprod,    gb_sprod
real, dimension(size(t,3)+1):: gb_diss,     gb_trans,    gb_tauinv
real, dimension(size(t,3)+1):: gb_z_half,   gb_sigmas,   gb_p_half
real, dimension(size(t,3)+1):: gb_radf,     gb_sh,       gb_sm
real, dimension(size(t,3)+1):: gb_gh,       gb_evhc
logical :: used, topfound
 
   integer, dimension(MAX_PTS) :: nsave
   integer :: iloc(MAX_PTS), jloc(MAX_PTS), nn, npts, nnsave
   integer :: year, month, day, hour, minute, second
   character(len=16) :: mon

!-----------------------------------------------------------------------
!
!      open ascii edt.out file if do_print

!      if (do_print) then
!           if ( edt_pts(1) >= is .and. edt_pts(1) <= ie  .and.        &
!                edt_pts(2) >= js .and. edt_pts(2) <= je) then
!                ipt=edt_pts(1)-is+1
! jpt=edt_pts(2)-js+1
!!RSH            dpu = open_file ('edt.out', action='append')
!           else
!         ipt = 0
! jpt = 0
!           endif
!      endif

                    
!-----------------------------------------------------------------------
!
!      initialize variables

       pblh   = 0.0       
       
       k_t    = 0.0
       k_m    = 0.0
       tke    = 0.0
       
       turbtype = 0
       isturb = 0.0
       
       n2     = 0.0
       s2     = 0.0
       ri     = 0.0
       tauinv = 0.0
       leng   = 0.0
       bprod  = 0.0
       sprod  = 0.0
       trans  = 0.0
       diss   = 0.0
       radf   = 0.0
       sh     = 0.0
       sm     = 0.0
       evhc   = 0.0
       gh     = 0.0
    
       slislope = 0.0
       qtslope  = 0.0
       
       qxbot  = 0.0
       qxtop  = 0.0
       
       qc_new = 0.0
       qa_new = 0.0

       mineddytau =  min_adj_time * dt
       
!-----------------------------------------------------------------------
!
!      compute height above surface
!

       nlev = size(t,3)
       nlat = size(t,2)
       nlon = size(t,1)

       mask = 1.0
                   
       if (present(kbot)) then
            do j=1,nlat
            do i=1,nlon
                 z_surf(i,j) = z_half(i,j,kbot(i,j)+1)
            enddo
            enddo
       else
            z_surf(:,:) = z_half(:,:,nlev+1)
       end if

       do k = 1, nlev
            z_full_ag(:,:,k) = z_full(:,:,k) - z_surf(:,:)
            z_half_ag(:,:,k) = z_half(:,:,k) - z_surf(:,:)
       end do
       z_half_ag(:,:,nlev+1) = z_half(:,:,nlev+1) - z_surf(:,:)
       
       if (present(kbot)) then
            where (z_full_ag < 0)
               mask = 0.0
            endwhere
       end if
      
!-----------------------------------------------------------------------
!
!      Calculate saturation specific humidity and its temperature 
!      derivative, the effective latent heat
!
!      These are calculated according to the formulas:
!
!      qsl  = d622*esl/ [p_full  -  (1.-d622)*esl]
!
!      dqsldtl = d622*p_full*(desat/dT)/[p_full-(1.-d622)*esl]**2.
!
!       
!      where d622 = rdgas/rvgas; esl = saturation vapor pressure;
!      and desat/dT is the temperature derivative of esl. Note that: 
!
!              {             hlv          for t > tfreeze             }
!      hleff = { 0.05*(t-tfreeze+20.)*hlv + 0.05*(tfreeze-t)*hls      }
!              {                          for tfreeze-20.< t < tfreeze}
!              {             hls          for t < tfreeze-20.         }
!
!      This linear form is chosen because at Tfreeze-20. es = esi, and
!      at Tfreeze, es = esl, with linear interpolation in between.
!
!

       !calculate effective latent heat
       hleff = (min(1.,max(0.,0.05*(t       -tfreeze+20.)))*hlv + &
                min(1.,max(0.,0.05*(tfreeze -t          )))*hls)
     
       !calculate qsl and dqsldtl. return es for diagnostic use.
       call compute_qs (t-(hleff*(ql+qi)/cp_air), p_full, qsl, &
                                             esat = esl, dqsdT=dqsldtl)

!-----------------------------------------------------------------------
!
!      set up specific humidities and static energies  
!      compute airdensity

       qt      = qv + ql + qi
       
       sli     = cp_air*t + grav*z_full_ag - hleff*(ql + qi)
       sliv    = sli*(1+zvir*qt)
       density = p_full/rdgas/(t *(1.+d608*qv-ql-qi))              

!-----------------------------------------------------------------------
! 
!      big loop over points
!

       ibot = nlev

       do j=1,nlat
 npts = 0
       if (do_edt_dg(j+js-1) ) then       
 do nn=1,num_pts
         if (                          &
       js == j_edtprt(nn) .and.  &
                 i_edtprt(nn) >= is .and. i_edtprt(nn) <= ie) then
      iloc(npts+1) = i_edtprt(nn) - is + 1
      jloc(npts+1) = j_edtprt(nn) - js + 1
      nsave(npts+1) = nn
      npts = npts + 1
         endif
        end do    ! (num_points)
       else
          ipt = 0
           jpt = 0
   column_match = .false.
       endif
       do i=1,nlon
 if (npts > 0) then
   do nn=1,npts

   ipt = iloc(nn)
   jpt = jloc(nn)
!                  if (i == ipt .and. j == jpt) then
                   if (i == ipt ) then
! if (i == ipt .and. j == jpt .and.  &
!     js == j_edtprt(nn) ) then
         column_match = .true.
! nnsave = nn
 nnsave = nsave(nn)
 exit
 else
         column_match = .false.
 endif
               end do
       nn = nnsave
       else 
         column_match = .false.
 nn = 0
       endif
            !-----------------------------------------------------------
    !
            ! should diagnostics be printed out for this column
            !
    
!    if (i .eq. ipt .and. j .eq. jpt) then
!         column_match = .true.
!           else
!         column_match = .false. 
!           end if

            !-----------------------------------------------------------
    !
            ! extract column data to pass to caleddy
            !
    
            if (present(kbot)) ibot = kbot(i,j)
    
            gb_t      (1:ibot  ) = t         (i,j,1:ibot  )
!           gb_qv     (1:ibot  ) = qv        (i,j,1:ibot  )
!           gb_qc     (1:ibot  ) = ql        (i,j,1:ibot  ) +          &
!                           qi        (i,j,1:ibot  )
!           gb_qt     (1:ibot  ) = qt        (i,j,1:ibot  )
            gb_qv     (1:ibot  ) = max(0., qv(i,j,1:ibot  ) )
            gb_qc     (1:ibot  ) = max(0., ql(i,j,1:ibot  ) +          &
                                          qi(i,j,1:ibot  ) )
            gb_qt     (1:ibot  ) = max(0., qt(i,j,1:ibot  ) )
            gb_sli    (1:ibot  ) = sli       (i,j,1:ibot  )
            gb_sliv   (1:ibot  ) = sliv      (i,j,1:ibot  )
            gb_u      (1:ibot  ) = u         (i,j,1:ibot  )
            gb_v      (1:ibot  ) = v         (i,j,1:ibot  )
            gb_z_half (1:ibot+1) = z_half_ag (i,j,1:ibot+1)
            gb_z_full (1:ibot  ) = z_full_ag (i,j,1:ibot  )
            gb_p_half (1:ibot+1) = p_half    (i,j,1:ibot+1)
            gb_p_full (1:ibot  ) = p_full    (i,j,1:ibot  )
            gb_qsl    (1:ibot  ) = qsl       (i,j,1:ibot  )
    gb_esl    (1:ibot  ) = esl       (i,j,1:ibot  )
    gb_hleff  (1:ibot  ) = hleff     (i,j,1:ibot  )
    gb_density(1:ibot  ) = density   (i,j,1:ibot  )
    gb_dqsldtl(1:ibot  ) = dqsldtl   (i,j,1:ibot  )
            gb_tdtlw  (1:ibot  ) = tdtlw_in (i,j,1:ibot)
            gb_sigmas (1:ibot+1) = sigmas(is-1+i,js-1+j,1:ibot+1)
    kqfs                 = u_star(i,j)*q_star(i,j)
            khfs                 = u_star(i,j)*b_star(i,j)*gb_t(ibot)/ &
                           grav
            gb_u_star            = u_star(i,j)          

!      if (get_my_pe() == 40  .and. js == 6  .and. i == 9) then
!       print *, 'edt pointf', gb_qt(26), gb_qc(26), gb_qv(26)
!      endif
            !compute sigmas at surface
    gb_sigmas(ibot+1) =  ((mesovar*gb_qsl(ibot))**2.0) +       &
         ((q_star(i,j)-gb_dqsldtl(ibot)*b_star(i,j)*gb_t(ibot)/&
         grav)**2.0)
            gb_sigmas(ibot+1) = sqrt( gb_sigmas(ibot+1) ) / ( 1. +     &
         gb_hleff(ibot)*gb_dqsldtl(ibot)/cp_air )

            if (column_match) then
    call get_date(Time, year, month, day, hour, minute, second)
    mon = month_name (month)
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  '===================================='//&
         '=================='
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  '               ENTERING EDT    '
            write (dpu,'(a)')  ' '
            write (dpu,'(a, i6,a,i4,i4,i4,i4)')  ' time stamp:',   &
                                       year, trim(mon), day, &
                                       hour, minute, second
            write (dpu,'(a)')  '  DIAGNOSTIC POINT COORDINATES :'
            write (dpu,'(a)')  ' '
    write (dpu,'(a,f8.3,a,f8.3)') ' longitude = ', deglon1(nn),&
                                  ' latitude  = ', deglat1(nn)
    write (dpu,'(a,i6,a,i6)')    &
                                   ' global i =', i_edtprt_gl(nn), &
                                   ' global j = ', j_edtprt_gl(nn)
    write (dpu,'(a,i6,a,i6)')    &
                                   ' processor i =', i_edtprt(nn),     &
                                   ' processor j = ',j_edtprt(nn)
    write (dpu,'(a,i6,a,i6)')     &
                                   ' window    i =', ipt,          &
                                   ' window    j = ',jpt
            write (dpu,'(a)')  ' '
    write (dpu,'(a)')  ' sigmas at the surface .... '
            write (dpu,'(a)')  ' ' 
    write (dpu,'(a,f14.7,a)')  ' sigmas = ',1000.*             &
         gb_sigmas(ibot+1), ' g/kg'
            write (dpu,'(a,f14.7)  ')  ' acoef = ', 1./( 1.+           &
         gb_hleff(ibot)* gb_dqsldtl(ibot)/cp_air )            
    write (dpu,'(a,f14.7,a)')  ' sigmas/a = ', 1000.*          &
         gb_sigmas(ibot+1)*( 1. + gb_hleff(ibot)*              &
 gb_dqsldtl(ibot)/cp_air ), ' g/kg'
            write (dpu,'(a,f14.7)'  )  ' mesovar = ', mesovar
            write (dpu,'(a,f14.7,a)')  ' mesovar*qsl = ',mesovar*      &
         gb_qsl(ibot)*1000.,' g/kg'
            write (dpu,'(a,f14.7,a)')  ' turb.fluct = ',1000.*         &
         (q_star(i,j)-gb_dqsldtl(ibot)*b_star(i,j)*gb_t(ibot)/ &
 grav),' g/kg'
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k      T         u         v       '//&
         '  qv        qt ' 
            write (dpu,'(a)')  '       (K)      (m/s)     (m/s)     '//&
         '(g/kg)    (g/kg)'
            write (dpu,'(a)')  '------------------------------------'//&
         '-----------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,18) kk,gb_t(kk),gb_u(kk),gb_v(kk),1000.*    &
              gb_qv(kk), 1000.*gb_qt(kk)
            end do
18          format(1X,i2,1X,5(f9.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k      qa        qc      sli/cp_air    '//&
         'sliv/cp_air    tdtlw'
            write (dpu,'(a)')  '                (g/kg)     (K)      '//&
         ' (K)      (K/day)'
            write (dpu,'(a)')  '------------------------------------'//&
         '-----------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,19) kk,qa(i,j,kk),1000.*gb_qc(kk),          &
      gb_sli(kk)/cp_air,gb_sliv(kk)/cp_air,gb_tdtlw(kk)*86400.
            enddo    
19          format(1X,i2,1X,5(f9.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k   z_full    z_half    p_full    p'//&
         '_half    sigmas'
            write (dpu,'(a)')  '      (m)      (m)        (mb)      '//&
         '(mb)     (g/kg)'
            write (dpu,'(a)')  '------------------------------------'//&
         '-----------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,19) kk,gb_z_full(kk),gb_z_half(kk+1),       &
              gb_p_full(kk)/100.,gb_p_half(kk+1)/100.,1000.*   &
                      gb_sigmas(kk+1)
            enddo
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k     esl       qsl      dqsldtl   '//&
         ' hleff '
            write (dpu,'(a)')  '       (mb)    (g/kg)     (g/kg/K)  '//&
         '(MJ/kg)' 
            write (dpu,'(a)')  '------------------------------------'//&
         '-------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,19) kk, gb_esl(kk)/100.,gb_qsl(kk)*1000.,   &
              gb_dqsldtl(kk)*1000.,gb_hleff(kk)/1.0e+06
            enddo
            write (dpu,'(a)')  ' '
            end if
       
            ! call the initialization routine for variables needed 
    ! by caleddy
         
            call trbintd(gb_t,       gb_qv,     gb_qt,     gb_qc,      &
                 gb_sli,     gb_sliv,   gb_u,      gb_v,       &
                 gb_z_full,  gb_z_half, gb_p_full, gb_p_half,  &
                         gb_sigmas,  gb_qsl,    gb_esl,    gb_hleff,   &
 gb_dqsldtl, gb_slisl,  gb_qtsl,   gb_qxtop,   &
 gb_qxbot,   gb_qltop,  gb_sfuh,   gb_sflh,    &
 gb_qc_new,  gb_qa_new, gb_chu,    gb_chs,     &
 gb_cmu,     gb_cms,    gb_n2,     gb_s2,      &
 gb_ri    )
            
            !-----------------------------------------------------------
            !
            ! call caleddy
            !

            
            call caleddy(gb_u_star, kqfs,      khfs,      gb_sli,      &
                 gb_qt,     gb_qc_new, gb_qa_new, gb_sliv,     &
 gb_u,      gb_v,      gb_p_full, gb_z_full,   &
 gb_sfuh,   gb_sflh,   gb_slisl,  gb_qtsl,     &
 gb_tdtlw,  gb_hleff,  gb_density,gb_qsl,      &
 gb_dqsldtl,gb_qltop,  gb_p_half, gb_z_half,   &
 gb_chu,    gb_chs,    gb_cmu,    gb_cms,      &
 gb_n2,     gb_s2,     gb_ri,     gb_pblh,     &
 gb_turbtype,gb_k_t,   gb_k_m,    gb_tke,      &
 gb_leng,   gb_bprod,  gb_sprod,  gb_trans,    &
 gb_diss,   gb_isturb, gb_tauinv, gb_sigmas,   &
 gb_radf,   gb_sh,     gb_sm,     gb_gh,       &
 gb_evhc)
 
            !-----------------------------------------------------------
            !
            ! paste back outputs
            !

            pblh(i,j)              = gb_pblh
            k_t(i,j,1:ibot)        = gb_k_t(1:ibot)
            k_m(i,j,1:ibot)        = gb_k_m(1:ibot)
            tke(i,j,1:ibot+1)      = gb_tke(1:ibot+1)
    
    turbtype(:,i,j,1:ibot+1) = gb_turbtype(:,1:ibot+1)
    isturb(i,j,1:ibot)       = gb_isturb(1:ibot)
    n2(i,j,1:ibot+1)         = gb_n2(1:ibot+1)
    s2(i,j,1:ibot+1)         = gb_s2(1:ibot+1)
    ri(i,j,1:ibot+1)         = gb_ri(1:ibot+1)    
    tauinv(i,j,1:ibot+1)     = gb_tauinv(1:ibot+1)
    leng(i,j,1:ibot+1)       = gb_leng(1:ibot+1)
    bprod(i,j,1:ibot+1)      = gb_bprod(1:ibot+1)
    sprod(i,j,1:ibot+1)      = gb_sprod(1:ibot+1)
            trans(i,j,1:ibot+1)      = gb_trans(1:ibot+1)
    diss(i,j,1:ibot+1)       = gb_diss(1:ibot+1)
            radf(i,j,1:ibot+1)       = gb_radf(1:ibot+1)
            sh(i,j,1:ibot+1)         = gb_sh(1:ibot+1)
            sm(i,j,1:ibot+1)         = gb_sm(1:ibot+1)
    gh(i,j,1:ibot+1)         = gb_gh(1:ibot+1)
            evhc(i,j,1:ibot+1)       = gb_evhc(1:ibot+1)
                                                    
            slislope(i,j,1:ibot  )   = gb_slisl(1:ibot  )
    qtslope (i,j,1:ibot  )   = gb_qtsl (1:ibot  )
    qxtop   (i,j,1:ibot  )   = gb_qxtop(1:ibot  )
    qxbot   (i,j,1:ibot  )   = gb_qxbot(1:ibot  )
    qc_new  (i,j,1:ibot  )   = gb_qc_new(1:ibot  )
    qa_new  (i,j,1:ibot  )   = gb_qa_new(1:ibot  )
    
    sigmas(is-1+i,js-1+j,1:ibot+1) = gb_sigmas (1:ibot+1) 
    
            !determine maximum altitude that the very stable pbl
    !is permitted to operate.  this is set to the half
    !level altitude just beneath the first turbulent
    !level
            stbltop(i,j) = 0.
            topfound = .false.
     
            kk = ibot + 1
            do while (.not.topfound.and.kk.gt.1)
                 kk = kk - 1
                 if (gb_isturb(kk).gt.0.5) topfound = .true.
            enddo 
            stbltop(i,j) = gb_z_half(kk+1)
       
            if (column_match) then
    write (dpu,'(a)') ' '
    write (dpu,'(a,f14.7,a)') ' stbltop = ',stbltop(i,j),      &
         ' meters'
    write (dpu,'(a)') ' '
    end if
    
       enddo
       enddo

!-----------------------------------------------------------------------
! 
!      diagnose cloud fraction and condensate tendencies
!
      
       !----------------------------------------------------------------
       ! If the interface at the top or the bottom of the layer is part
       ! of a turbulent layer then set the eddytau to the minimum 
       ! timescale of the two.
       !
       
       do k = 1, nlev
            tauinvtmp(:,:,k) = max(tauinv(:,:,k),tauinv(:,:,k+1))
       enddo
       
       where (tauinvtmp .gt. 1.e-10 .and. isturb .gt. 0.5)
    eddytau = max ( 1./tauinvtmp, mineddytau )
       elsewhere
    eddytau = missing_value
       endwhere
       
       qaturb(is:ie,js:je,:)   = qa_new
       qcturb(is:ie,js:je,:)   = qc_new
       tblyrtau(is:ie,js:je,:) = eddytau
             
!-----------------------------------------------------------------------
! 
!      blend in monin-obukhov similarity theory mixing coefficients at 
!      interface levels which are inside the surface layer
!

       sfclyr_h     = frac_sfclyr*pblh
       sfclyr_h_max = maxval(sfclyr_h)

       kk = nlev
       do k = 2, nlev
            if (minval(z_half_ag(:,:,k)) < sfclyr_h_max) then
                 kk = k
                 exit
            end if
       end do
       k_m_mo = 0.0
       k_t_mo = 0.0
       call mo_diff(z_half_ag(:,:,kk:nlev), u_star, b_star, &
            k_m_mo(:,:,kk:nlev), k_t_mo(:,:,kk:nlev))

       do k = kk, nlev
            where(z_half_ag(:,:,k) < sfclyr_h(:,:) .and. &
                  z_half_ag(:,:,k) > 0.)
                  k_t(:,:,k) = k_t_mo(:,:,k)
                  k_m(:,:,k) = k_m_mo(:,:,k)
            endwhere
       enddo

!-----------------------------------------------------------------------
! 
!      Diagnostics
!

       if ( id_fq_cv_int > 0 .or. id_fq_cv_top > 0 .or. id_n2 > 0 .or. & 
            id_fq_turb   > 0 .or. id_diss      > 0 .or. id_s2 > 0 .or. &
            id_fq_cv_bot > 0 .or. id_fq_st     > 0 .or. id_ri > 0 .or. &
    id_eddytau   > 0 .or. id_tauinv    > 0 .or.                &
            id_leng      > 0 .or. id_qaedt     > 0 .or.                &
    id_bprod     > 0 .or. id_sprod     > 0 .or.                &
    id_trans     > 0 .or. id_qcedt     > 0 .or.                &
    id_sigmas    > 0 ) then  
      
            mask3(:,:,1:(nlev+1)) = 1.
            if (present(kbot)) then
                 where (z_half_ag < 0.)
                      mask3(:,:,:) = 0.
                 end where
            endif
        
            if ( id_fq_cv_int > 0 ) then
         where (turbtype(2,:,:,:) .eq. 1) 
     tmpdat = 1.
 elsewhere
     tmpdat = 0.
 end where
                 used = send_data (id_fq_cv_int,tmpdat,time, is, js, 1,&
                   rmask=mask3 )
            end if

            if ( id_fq_cv_top > 0 ) then
         where (turbtype(4,:,:,:) .eq. 1) 
     tmpdat = 1.
 elsewhere
     tmpdat = 0.
 end where
                 used = send_data (id_fq_cv_top,tmpdat,time, is, js, 1,&
                   rmask=mask3 )
            end if
            
    if ( id_fq_cv_bot > 0 ) then
         where (turbtype(3,:,:,:) .eq. 1) 
     tmpdat = 1.
 elsewhere
     tmpdat = 0.
 end where
                 used = send_data (id_fq_cv_bot,tmpdat,time, is, js, 1,&
                   rmask=mask3 )
            end if
         
    if ( id_fq_st > 0 ) then
         where (turbtype(1,:,:,:) .eq. 1) 
     tmpdat = 1.
 elsewhere
     tmpdat = 0.
 end where                 
                 used = send_data ( id_fq_st, tmpdat, time, is, js, 1, &
                    rmask=mask3 )
            end if

            if ( id_fq_turb > 0 ) then
                 used = send_data ( id_fq_turb, isturb, time, is, js,1,&
                    rmask=mask )
            end if
                     
    if ( id_n2 > 0 ) then
                 used = send_data ( id_n2, n2, time, is, js, 1,        &
                    rmask=mask3 )
            end if
         
    if ( id_s2 > 0 ) then
                 used = send_data ( id_s2, s2, time, is, js, 1,        &
                    rmask=mask3 )
            end if
         
    if ( id_ri > 0 ) then
                 used = send_data ( id_ri, ri, time, is, js, 1,        &
                    rmask=mask3 )
            end if
         
    if ( id_leng > 0 ) then
                 used = send_data ( id_leng, leng, time, is, js, 1,    &
                    rmask=mask3 )
            end if
            
    if ( id_bprod > 0 ) then
                 used = send_data ( id_bprod, bprod, time, is, js, 1,  &
                    rmask=mask3 )
            end if
         
    if ( id_sprod > 0 ) then
                 used = send_data ( id_sprod, sprod, time, is, js, 1,  &
                    rmask=mask3 )            
            end if
    
            if ( id_trans > 0 ) then
                 used = send_data ( id_trans, trans, time, is, js, 1,  &
                    rmask=mask3 )            
            end if
    
            if ( id_diss > 0 ) then
                 used = send_data ( id_diss, diss, time, is, js, 1,    &
                    rmask=mask3 )            
            end if
    
            if ( id_radf > 0 ) then
                 used = send_data ( id_radf, radf, time, is, js, 1,    &
                    rmask=mask3 )            
            end if
    
            if ( id_sh > 0 ) then
                 used = send_data ( id_sh, sh, time, is, js, 1,        &
                    rmask=mask3 )            
            end if
    
            if ( id_sm > 0 ) then
                 used = send_data ( id_sm, sm, time, is, js, 1,        & 
                    rmask=mask3 )            
            end if
    
            if ( id_gh > 0 ) then
                 used = send_data ( id_gh, gh, time, is, js, 1,        &
                    rmask=mask3 )            
            end if
    
            if ( id_evhc > 0 ) then
                 used = send_data ( id_evhc, evhc, time, is, js, 1,    &
                    rmask=mask3 )            
            end if
    
            if ( id_tauinv > 0 ) then
                 used = send_data ( id_tauinv, tauinv, time, is, js, 1,&
                    rmask=mask3 )
            end if
            
            if ( id_eddytau > 0 ) then
                 used = send_data ( id_eddytau, eddytau, time, is, js, &
                    1, rmask=mask )
            end if
            
            if ( id_sigmas > 0 ) then
                 used = send_data ( id_sigmas, sigmas(is:ie,js:je,:),  &
                    time, is, js, 1, rmask=mask3 )
            end if
            
            if (id_qaedt > 0) then
         tmpdat = 0.0
 do k = 1, nlev   
      tmpdat(:,:,k) = isturb(:,:,k)*qa_new(:,:,k)
                 enddo
 used = send_data ( id_qaedt, tmpdat(:,:,1:nlev),      &
                    time, is, js, 1, rmask=mask )                 
            end if
            
    if (id_qcedt > 0) then
         tmpdat = 0.0
 do k = 1, nlev   
              tmpdat(:,:,k) = isturb(:,:,k)*qc_new(:,:,k)
 enddo
 used = send_data ( id_qcedt, tmpdat(:,:,1:nlev),      &
                    time, is, js, 1, rmask=mask )      
            end if
 
       end if  ! do diagnostics if


!-----------------------------------------------------------------------
! 
!      close edt output file if data was written for this window

!!RSH  if (ipt .gt. 0 .and. jpt .gt. 0) call Close_File (dpu)
       
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine edt

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





!======================================================================= 
!
!      subroutine edt_end
!        
!
!      this subroutine writes out the restart field
!        

subroutine edt_end()

!-----------------------------------------------------------------------
!
!      variables
!
!      --------
!      internal
!      --------
!
!      unit              unit number for namelist and restart file
!
!-----------------------------------------------------------------------

integer :: unit

!-----------------------------------------------------------------------
!
!      write out restart file
!
       unit = Open_restart_File ('RESTART/edt.res', ACTION='write')

      if (mpp_pe() == mpp_root_pe()) then
        write (unit) restart_versions(size(restart_versions(:)))
       endif

       call write_data (unit, qaturb)
       call write_data (unit, qcturb)
       call write_data (unit, tblyrtau)
       call write_data (unit, sigmas)
       Call Close_File (unit)

!! RSH ADDS HERE (MOVED FROM EDT) 
!-----------------------------------------------------------------------
! 
!      close edt output file if data was written for this window

       if (do_print ) call Close_File (dpu)
       
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! 
!      subroutine end
!
       module_is_initialized = .false.
end subroutine edt_end

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




!======================================================================= 
!======================================================================= 
!
!
!      Grenier-Bretherton turbulence subroutines follow. These include:
!
!
!      sfdiag             diagnoses the fraction of each interval
!                         between layer midpoints which is saturated;
!                         this fraction is used to calculate the 
!                         proper buoyancy frequency, n2.
!
!      trbintd            calculates the subgrid vertical variability
!                         to sl, the liquid water static energy, and
!                         qt, the total water specific humidity.
!
!                         also calculates the richardson number ri 
!                         from n2:
!
!                         n2 = ch*dslidz +  cm*dqtdz
!
!                         where
!
!                         dslidz and dqtdz are the vertical slopes
!                         of sl and qt in the interior of the grid
!                         box and ch and cm are thermodynamic 
!                         coefficients which are solely functions of 
!                         temperature and pressure, but have very 
!                         different values in saturated and unsaturated 
!                         air.
!                          
!      caleddy            main subroutine which calculates diffusivity
!                         coefficients
!
!      exacol          determines whether the column has adjacent 
!                         regions where Ri < 0 (unstable layers or ULs) 
!                         and determine the indices kbase, ktop which 
!                         delimit these unstable layers : 
!
!                         ri(kbase) > 0 and ri(ktop) > 0, 
!                         but ri(k)     < 0 for ktop < k < kbase. 
!
!      zisocl             solves for mean tke <e>, W, Sh, and Sm for 
!                         each convective layer.  here,
!
!                         W = leng**2 * (-Sh*n2 + Sm*s2), where
!
!                         leng = mixing length,
!                         s2   = shear vector magnitude
!                         Sh   = Galperin stab. function for buoyancy
!                         Sm   = Galperin stab. function for momentum
!
!                         in addition, it merges adjacent convective 
!                         layers when the intervening stable layers 
!                         would not consume too much tke for the 
!                         combined convective layer
!
!
!======================================================================= 
!======================================================================= 




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

subroutine sfdiag (qsl, esl, dqsldtl, hleff, qt, qtslope,sli, slislope,&
                   p_full, z_full, p_half, z_half, sdevs, qxtop, qxbot,&
   qltop, sfuh, sflh, qc_new, qa_new, sfi)
   
!----------------------------------------------------------------------- 
! 
!      Purpose: 
!      Interface for computing cloud variables for use by turb. scheme
! 
!      Authors: B. Stevens and C. Bretherton (August 2000)
! 
!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
!      field 1-d arrays on model full levels, reals dimensioned
!      (1:nlev), index running from top of atmosphere to bottom
!      
!      qsl         saturation spec. humidity at the liquid-ice
!                  water temperature (kg water/kg air)
!      esl         saturation vapor pressure at the liquid-ice 
!                  water temperature (Pa)
!      dqsldtl     temperature derivative of qsl (kg water/kg air/K)
!      hleff       effective latent heat of vaporization (J/kg)        
!      qt          total water specific humidity (kg water/kg air)
!      qtslope     qt slope wrt pressure in thermo layer (kg/kg/Pa)
!      sli         ice-liq water static energy (J/kg) 
!      slislope    sli slope wrt pressure in thermo layer (J/kg/Pa)
!      p_full      pressure (Pa)
!      z_full      height of full level above the surface (m)
!
!      the following fields are on the model half levels, 
!      dimension(1:nlev+1)
!
!      p_half      pressure at half levels (Pa)
!      z_half      height of half model levels above the surface (m)
!      sdevs       standard deviation of water perturbation
!                  (kg water/kg air)
!
!      ------
!      output
!      ------
!
!      qxtop       saturation excess at top of layer (kg wat/kg air)
!      qxbot       saturation excess at bottom of layer (kg wat/kg air)
!      qltop       cloud liquid at top of layer (kg wat/kg air)
!      sfuh        saturated fraction in upper half-layer
!      sflh        sflh saturated fraction in lower half-layer
!      qc_new      thermodynamically diagnosed condensate value
!      qa_new      thermodynamically diagnosed cloud fraction
!
!      the following fields are on the model half levels, 
!      dimension(1:nlev+1)
!
!      sfi         interfacial saturated fraction
!


real, intent(in) , dimension(:) :: qsl, esl, dqsldtl, hleff
real, intent(in) , dimension(:) :: qt, qtslope, sli, slislope
real, intent(in) , dimension(:) :: p_full, z_full
real, intent(in) , dimension(:) :: p_half, z_half, sdevs 
real, intent(out), dimension(:) :: qxtop, qxbot, qltop, sfuh, sflh
real, intent(out), dimension(:) :: qc_new, qa_new
real, intent(out), dimension(:) :: sfi

integer :: k                      ! vertical index
integer :: nlev                   ! number of vertical levels
real    :: slitop, slibot         ! sli at top/bot of layer
real    :: qttop , qtbot          ! qt  at top/bot of layer
real    :: qsltop, qslbot         ! qsl at top/bot of layer
real    :: tlitop, tlibot         ! liq wat temp at top/bot of layer          
real    :: qxm                    ! sat excess at midpoint
real    :: qlm, qlbot             ! liq wat at midpoint, and bottom
real    :: tlim                   ! tli at midpoint
real    :: dqsldp                 ! pressure derivative of qsl
real    :: sigmasf                ! sdevs on full model levels
real    :: acoef                  ! 1./(1+L*dqsldT/cp_air)

!----------------------------------------------------------------------- 
!
!      code
!

       nlev   = size(p_full,1)
       sfi    = 0.0
       sfuh   = 0.0
       sflh   = 0.0    
       qc_new = 0.0
       qa_new = 0.0
       qltop  = 0.0
       
       if (column_match) then
       write (dpu,'(a)')  '-----------------------------------------'//&
            '-------------'
       write (dpu,'(a)')  '        ENTERING SFDIAG                     '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k  tlim   dqsldp slitop tlitop  qttop  q'//&
            'sltop  qxtop  qltop   qxm    qlm'
       write (dpu,'(a)')  '    (K)(g/kg/100mb)(K)    (K)    (g/kg) ('//&
            'g/kg)  (g/kg) (g/kg) (g/kg) (g/kg)'
       write (dpu,'(a)')  '-----------------------------------------'//&
            '----------------------------------'
       write (dpu,'(a)')  ' '       
21     format(1X,i2,1X,f6.2,1X,f7.2,1X,8(f6.2,1X))
       end if
         
       do k = 2,nlev

            !-----------------------------------------------------------
    ! calculate midpoint liquid-ice water temperature
    tlim = (sli(k) - grav*z_full(k))/cp_air

            !-----------------------------------------------------------
    ! calculate dqsl/dp
    dqsldp = -1.*qsl(k)*qsl(k)/d622/esl(k)
            
            !-----------------------------------------------------------
            ! Compute saturation excess at top and bottom of layer k

            !extrapolation to layer top
            slitop = sli(k) + slislope(k) * (p_half(k) - p_full(k))
            qttop  = qt (k) + qtslope (k) * (p_half(k) - p_full(k))
            slitop = min ( max ( 0.25*sli(k), slitop), 4.*sli(k))
            qttop  = min ( max ( 0.25* qt(k), qttop ), 4.* qt(k))
            tlitop = (slitop - grav*z_half(k))/cp_air   
    qsltop  = qsl(k) + dqsldp      * (p_half(k) - p_full(k)) + &
                       dqsldtl (k) * (tlitop    - tlim     )
    qsltop  = min ( max ( 0.25*qsl(k), qsltop ) , 4.*qsl(k) )
            qxtop(k) = qttop  - qsltop
            qltop(k)  = max( 0., qxtop(k)/( 1.+ hleff(k)*dqsldtl(k)/cp_air))

            !extrapolation to layer bottom
            slibot = sli(k) + slislope(k) * (p_half(k+1) - p_full(k))
            qtbot  = qt (k) + qtslope (k) * (p_half(k+1) - p_full(k))
    slibot = min ( max ( 0.25*sli(k), slibot), 4.*sli(k))
            qtbot  = min ( max ( 0.25* qt(k), qtbot ), 4.* qt(k))
            tlibot = (slibot - grav*z_half(k+1))/cp_air
    qslbot = qsl(k) + dqsldp      * (p_half(k+1) - p_full(k))+ &
                      dqsldtl (k) * (tlibot      - tlim     ) 
    qslbot  = min ( max ( 0.25*qsl(k), qslbot ) ,4.*qsl(k) )     
    qxbot(k) = qtbot  - qslbot
            qlbot  = max( 0., qxbot(k)/( 1.+hleff(k)*dqsldtl(k)/cp_air ) )

            !-----------------------------------------------------------
            ! Compute saturation excess at midpoint of layer k           
            qxm    = qxtop(k) + (qxbot(k)-qxtop(k))*                   &
                 (p_full(k)-p_half(k))/(p_half(k+1) - p_half(k))
            qlm  = max( 0., qxm / ( 1. +  hleff(k)*dqsldtl(k)/cp_air ) )

            if (column_match) then
    write(dpu,21) k,tlim,1000.*dqsldp*100.*100.,slitop/cp_air,     &
         tlitop,1000.*qttop,1000.*qsltop,1000.*qxtop(k),       &
1000.*qltop(k),1000.*qxm,   1000.*qlm
            write(dpu,21) k,tlim,1000.*dqsldp*100.*100.,slibot/cp_air,     &
         tlibot,1000.*qtbot,1000.*qslbot,1000.*qxbot(k),       &
1000.*qlbot,1000.*qxm,   1000.*qlm
    write (dpu,'(a)')  ' '
            end if


            !-----------------------------------------------------------
    !
    ! TWO WAYS OF CALCULATING SATURATION FRACTION AND QA AND QC
    !
    !
    !          FIRST WAY:  USE GAUSSIAN CLOUD MODEL
    !
    !

            if (do_gaussian_cloud) then
   
         !calculate sigmas on model full levels
 sigmasf = 0.5 * (sdevs(k) + sdevs(k+1))
         acoef = 1. / ( 1. + hleff(k)*dqsldtl(k)/cp_air )
 !sigmasf = max ( sigmasf, acoef*mesovar*qsl(k) )
 sigmasf = acoef*mesovar*qsl(k)
         call gaussian_cloud(qxtop(k), qxm,      qxbot(k),     &
                     acoef,    sigmasf,  qa_new(k),    &
     qc_new(k),sfuh(k),  sflh(k))
     
                 !------------------------------------------------------
                 ! Combine with sflh (still for layer k-1) to get 
 ! interface layer saturation fraction
         !
         ! N.B.:
                 !
         ! if sfuh(k)>sflh(k-1),sfi(k) = sflh(k-1)
         ! if sfuh(k)<sflh(k-1),sfi(k) = mean(sfuh(k),sflh(k-1))
                 !
                 sfi(k) =  0.5 * ( sflh(k-1) + min(sflh(k-1),sfuh(k)) )
 
            else
    
            !
    !
    !          SECOND WAY:  ORIGINAL BRETHERTON-GRENIER WAY
    !
    !

                 !------------------------------------------------------
                 ! Compute saturation fraction sfuh(k) of the upper half 
 ! of layer k.

                 if      ( (qxtop(k).lt.0.) .and. (qxm.lt.0.) ) then
                      sfuh(k) = 0.  ! Upper half-layer unsaturated
                 else if ( (qxtop(k).gt.0.) .and. (qxm.gt.0.) ) then
                      sfuh(k) = 1.  ! Upper half-layer fully saturated
                 else               ! Either qxm < 0 and qxtop > 0 
                            ! or vice versa
                      sfuh(k) = max(qxtop(k),qxm) / abs(qxtop(k) - qxm)
                 end if

                 !------------------------------------------------------
                 ! Combine with sflh (still for layer k-1) to get      
 ! interfac layer sat frac
         !
         ! N.B.:
                 !
         ! if sfuh(k)>sflh(k-1),sfi(k) = sflh(k-1)
         ! if sfuh(k)<sflh(k-1),sfi(k) = mean(sfuh(k),sflh(k-1))
                 !
         sfi(k) =  0.5 * ( sflh(k-1) + min( sflh(k-1), sfuh(k)))
      
                 !------------------------------------------------------
                 ! Update sflh to be for the lower half of layer k.             
     
                 if      ( (qxbot(k).lt.0.) .and. (qxm.lt.0.) ) then
                      sflh(k) = 0.  ! Upper half-layer unsaturated
                 else if ( (qxbot(k).gt.0.) .and. (qxm.gt.0.) ) then
                      sflh(k) = 1.  ! Upper half-layer fully saturated
                 else            ! Either qxm < 0 and qxbot > 0 or vice
                 ! versa
                      sflh(k) = max(qxbot(k),qxm) / abs(qxbot(k) - qxm)
                 end if
         
         !------------------------------------------------------
           !Compute grid volume mean condensate and cloud fraction
           qc_new(k) = 0.5 * ( sfuh(k) * 0.5 * (qltop(k) + qlm) )&
           + 0.5 * ( sflh(k) * 0.5 * (qlbot    + qlm) )
                 qa_new(k) = 0.5 * ( sfuh(k) + sflh(k) )
   
    end if
    
       end do

       
       !set surface saturated fraction equal to sflh(nlev)
       sfi(nlev+1)  = sflh(nlev)! Sat frac in lowest half-layer. 

       if (column_match) then
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k     sfuh       sflh      sfi      qc_n'//&
            'ew    qa_new'
       write (dpu,'(a)')  '                                     (g/kg)'
       write (dpu,'(a)')  '-----------------------------------------'//&
            '------------'
       write (dpu,'(a)')  ' '
       do k = nlev-n_print_levels,nlev
            write(dpu,22) k,sfuh(k),sflh(k),sfi(k),1000.*qc_new(k),    &
                                                 qa_new(k)
       enddo    
22     format(1X,i2,1X,5(f9.4,1X))
       write (dpu,'(a)')  ' '
       end if
     
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine sfdiag

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




!======================================================================= 
!
!      subroutine trbintd
!

 subroutine trbintd (t, qv, qt, qc, sli, sliv, u, v, z_full, z_half,   &
                     p_full, p_half, sdevs, qsl, esl, hleff, dqsldtl,  &
     slislope, qtslope, qxtop, qxbot, qltop, sfuh,sflh,&
     qc_new, qa_new, chu, chs, cmu, cms, n2, s2, ri)

!----------------------------------------------------------------------- 
! 
! Purpose: 
!  time dependent initialization
! 
! Method: 
!  Diagnosis of variables that do not depend on mixing assumptions or
!  PBL depth.
!
! Authors: B. Stevens (extracted from pbldiff, August, 2000)
!          C. Bretherton (Dec. 2000)
! 
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
!       variables
!
!       -----
!       input
!       -----
!       field 1-d arrays on model full levels, reals dimensioned
!       (1:nlev), index running from top of atmosphere to 
!       bottom
!           
!       t           temperature (K)
!       qv          water vapor spec. humidity (kg vapor/kg air)
!       qt          total water specific humidity (kg water/kg air)
!       qc          condensed water spec. humidity (kg cond/kg air)
!       sli         ice-liq water static energy (J/kg) 
!       sliv        ice-liq water virtual static energy (J/kg) 
!       u           zonal wind (m/s)
!       v           meridional wind (m/s) 
!       z_full      height of full level above the surface (m)
!       p_full      pressure (Pa)
!       sdevs       standard deviation of water perturbation s
!                   (kg water/kg air)
!       qsl         saturation spec. humidity at the liquid-ice
!                   water temperature (kg water/kg air)
!       esl         saturation vapor pressure at the liquid-ice 
!                   water temperature (Pa)
!       hleff       effective latent heat (J/kg condensate)
!       dqsldtl     temperature derivative of qsl (kg water/kg air/K)
!
!       the following fields are on the model half levels, 
!       dimension(1:nlev+1)
!       p_half      pressure at half levels (Pa)
!       z_half      height of half model levels above the surface (m)
!
!       ------
!       output
!       ------
!
!       slislope    sli slope wrt pressure in thermo layer (J/kg/Pa)
!       qtslope     qt slope wrt pressure in thermo layer (kg/kg/Pa)
!       qxtop       saturation excess at the top of the layer 
!                   (kg wat/kg air)
!       qxbot       saturation excess at the bottom of the layer 
!                   (kg wat/kg air)
!       qltop       liquid water at top of thermo layer (kg condensate/
!                   kg air)
!       sfuh        saturated fraction in upper half-layer
!       sflh        sflh saturated fraction in lower half-layer
!       qc_new      thermodynamically defined cloud condensate (kg/kg)
!       qa_new      thermodynamically defined cloud fraction 
!
!       the following fields are defined on model half levels,
!       dimension(1:nlev+1)
!
!       chu         heat var. coef for dry states (1/m)
!       chs         heat var. coef for sat states (1/m)
!       cmu         moisture var. coef for dry states (kg/kg)*(m/s*s)
!       cms         moisture var. coef for sat states (kg/kg)*(m/s*s)
!       n2          moist squared buoyancy freq (1/s*s)
!       s2          squared deformation, or shear vector mag. (1/s*s)
!       ri          gradient Richardson number
!
!

real, intent(in),    dimension (:) :: t, qv, qt, qc, sli, sliv, u, v
real, intent(in),    dimension (:) :: z_full, p_full, qsl, esl, hleff
real, intent(in),    dimension (:) :: dqsldtl, sdevs
real, intent(in),    dimension (:) :: z_half, p_half
real, intent(out),   dimension (:) :: slislope, qtslope, qxtop, qxbot
real, intent(out),   dimension (:) :: sfuh, sflh, qc_new, qa_new, qltop
real, intent(out),   dimension (:) :: chu, chs, cmu, cms
real, intent(out),   dimension (:) :: n2, s2, ri
  
! internal variables

integer            :: kdim        ! # of levels in the vertical
integer            :: k, km1, kp  ! level indexes
real               :: rdz         ! 1 / (delta z) between midpoints
real               :: dslidz      ! delta sli / delta z at interface
real               :: dqtdz       ! delta qt  / delta z at interface
real               :: ch          ! sfi weighted ch at the interface
real               :: cm          ! sfi weighted cm at the interface
real               :: product     ! temporary variable
real               :: dslidp_a    ! sli slope across interface above
real               :: dqtdp_a     ! qt  slope across interface above
real               :: dslidp_b    ! sli slope across interface below
real               :: dqtdp_b     ! qt  slope across interface below
real, dimension(size(t,1)) :: bfact ! buoyancy factor in n2 calculation
real, dimension(size(t,1)+1) :: sfi ! saturated fraction at interfaces

!----------------------------------------------------------------------- 
!
!      code
!

       kdim = size(t,1)

!-----------------------------------------------------------------------
! 
!      Thermodynamic coefficients for buoyancy flux - these
!      are calculated at midpoints; they will be averaged to interfaces,
!      where they will ultimately be used. At the surface, the coeff-
!      icients are taken from the lowest midpoint.
!
!      These formulas come from the following expression
!
!      grav* tv' / tv = ch * sli'   + cm * qt'
!
!      chu and cmu are the values for unsaturated air, whereas
!      chs and cms are the values for   saturated air.

       bfact       = grav/(t*(1.+zvir*qv - qc))
       chu(1:kdim) = (1. + zvir*qt)*bfact/cp_air
       chs(1:kdim) = ( (1. + (1. + zvir)*dqsldtl*t) / &
                       (1. + (hleff*dqsldtl/cp_air)   ) ) * bfact/cp_air
       cmu(1:kdim) = zvir  * bfact * t
       cms(1:kdim) = hleff * chs(1:kdim)  -  bfact * t

       chu(kdim+1) = chu(kdim)
       chs(kdim+1) = chs(kdim)
       cmu(kdim+1) = cmu(kdim)
       cms(kdim+1) = cms(kdim)
    
       if (column_match) then
       write (dpu,'(a)')  '--------------------------------------------'
       write (dpu,'(a)')  '        ENTERING TRBINTD                    '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k     Tv       bfact '
       write (dpu,'(a)')  '       (K)    (m/K/s**2)' 
       write (dpu,'(a)')  '------------------------'
       write (dpu,'(a)')  ' '
       do k = kdim-n_print_levels,kdim
            write(dpu,17) k,t(k)*(1.+zvir*qv(k) - qc(k)),bfact(k)
       end do
17     format(1X,i2,1X,2(f9.4,1X))
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k     cp_air*chu    cp_air*chs      cmu      cms'
       write (dpu,'(a)')  '     (m/K/s**2)(m/K/s**2) (m/s**2) (m/s**2)'
       write (dpu,'(a)')  '-------------------------------------------'
       write (dpu,'(a)')  ' '
       do k = kdim+1-n_print_levels,kdim+1
            write(dpu,20) k,cp_air*chu(k),cp_air*chs(k),cmu(k),cms(k)
       enddo    
20     format(1X,i2,1X,4(f9.4,1X))
       write (dpu,'(a)')  ' '
       end if
       
!-----------------------------------------------------------------------
!     
!      Compute slopes in conserved variab. sl, qt within thermo layer k. 
!      a indicates the 'above' gradient from layer k-1 to layer k and 
!      b indicates the 'below' gradient from layer k   to layer k+1.
!      We take the smaller (in absolute value) of these gradients
!      as the slope within layer k. If they have opposite sign, gradient
!      in layer k is taken to be zero.
!
!      Slopes at endpoints determined by extrapolation

       slislope(kdim) = (sli   (kdim) - sli   (kdim-1))/ &
                        (p_full(kdim) - p_full(kdim-1))
       qtslope (kdim) = (qt    (kdim) - qt    (kdim-1))/ &
                        (p_full(kdim) - p_full(kdim-1))
       slislope(1)    = (sli   (2)    - sli   (2)     )/ &
                        (p_full(2)    - p_full(1)     )     
       qtslope (1)    = (qt    (2)    - qt    (2)     )/ &
                        (p_full(2)    - p_full(1)     ) 
       dslidp_b        = slislope(1)
       dqtdp_b         = qtslope (1)
        
       do k = 2, kdim-1
   
            kp = k + 1
            dslidp_a  = dslidp_b
            dqtdp_a   = dqtdp_b
            dslidp_b  = (sli(kp)-sli(k))/(p_full(kp)-p_full(k))
            dqtdp_b   = (qt (kp)-qt (k))/(p_full(kp)-p_full(k))
            product   = dslidp_a*dslidp_b
            if (product .le. 0.) then 
                 slislope(k) = 0.
            else if (product.gt.0. .and. dslidp_a.lt.0.) then 
                 slislope(k) = max(dslidp_a,dslidp_b)
            else if (product.gt.0. .and. dslidp_a.gt.0.) then 
                 slislope(k) = min(dslidp_a,dslidp_b)
            end if
 
            product   = dqtdp_a*dqtdp_b
            if (product .le. 0.) then 
                 qtslope (k) = 0.
            else if (product.gt.0. .and. dqtdp_a.lt.0.) then 
                 qtslope (k) = max(dqtdp_a,dqtdp_b)
            else if (product.gt.0. .and. dqtdp_a.gt.0.) then 
                 qtslope (k) = min(dqtdp_a,dqtdp_b)
            end if
       
       end do ! loop over k


       if (column_match) then
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k   slislope   qtslope  '
       write (dpu,'(a)')  '    (K/100mb)(g/kg/100mb)'
       write (dpu,'(a)')  '-------------------------'
       write (dpu,'(a)')  ' '
       do k = kdim-n_print_levels,kdim
            write(dpu,17) k,slislope(k)*100.*100./cp_air,                  &
               1000.*qtslope(k)*100.*100.
       enddo
       write (dpu,'(a)')  ' '
       end if

!-----------------------------------------------------------------------
!     
!      Compute saturation fraction in the interfacial layers for use in
!      buoyancy flux computation.

       call sfdiag(qsl, esl, dqsldtl, hleff, qt, qtslope,sli, slislope,&
                   p_full, z_full, p_half, z_half, sdevs, qxtop, qxbot,&
   qltop, sfuh, sflh, qc_new, qa_new, sfi)

!-----------------------------------------------------------------------
!     
!      Compute shear squared (s2), squared buoyancy frequency (n2) and 
!      Ri.  For the n2 calculation use gradients of sl and qt, weighted 
!      according to sfi, the fraction of the interfacial layer that is 
!      saturated.
!
!      This loop has to be done in increasing levels to avoid over-
!      writing chu, etc. arrays to interface values before we are done 
!      with their midpoint values.
!
!      Note that n2,s2,ri are set to zero at interfaces k = 1 and
!      k = kdim + 1, where they are not used.

       n2(kdim+1) = 0.
       s2(kdim+1) = 0.
       ri(kdim+1) = 0.

       if (column_match) then
       write (dpu,'(a)')  '---------------------------------------------'
       write (dpu,'(a)')  '                 IN TRBINTD'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k    rdz   dslidz   dqtdz    chu     chs'//&
            '     ch       cmu    cms      cm'
       write (dpu,'(a)')  '     (1/km) (K/km) (g/kg/km)       (m/K/s'//&
            '**2)              (m/s**2)'
       write (dpu,'(a)')  '-----------------------------------------'//&
            '----------------------------------'
       write (dpu,'(a)')  ' '       
22     format(1X,i2,1X,9(f7.3,1X))
       end if
      
       do k = kdim, 2, -1
            km1     = k - 1
            rdz     = 1. / (z_full(km1) - z_full(k))
            dslidz  = (sli(km1) - sli(k)) * rdz
            dqtdz   = (qt (km1) - qt (k)) * rdz 
            chu(k)  = (chu(km1) + chu(k))*0.5
            chs(k)  = (chs(km1) + chs(k))*0.5
            cmu(k)  = (cmu(km1) + cmu(k))*0.5
            cms(k)  = (cms(km1) + cms(k))*0.5
            ch      = chu(k)*(1.-sfi(k)) + chs(k)*sfi(k)
            cm      = cmu(k)*(1.-sfi(k)) + cms(k)*sfi(k)
            n2(k)   = ch*dslidz +  cm*dqtdz
            s2(k)   = ((u(km1)-u(k))**2 + (v(km1)-v(k))**2)*(rdz**2)
            s2(k)   = max(ntzero,s2(k))
            ri(k)   = n2(k) / s2(k)
    
    if (column_match) then
         write(dpu,22) k,1000.*rdz,1000.*dslidz/cp_air,            &
      1000.*1000.*dqtdz,cp_air*chu(k),cp_air*chs(k),cp_air*ch,     &
      cmu(k),cms(k),cm
            end if
    
       end do
       n2(1) = 0.
       s2(1) = 0.
       ri(1) = 0.
      
       if (column_match) then
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k    sqrt(n2)  sqrt(s2)    ri'
       write (dpu,'(a)')  '      (1/hr)    (1/hr) '
       write (dpu,'(a)')  '---------------------------------'
       write (dpu,'(a)')  ' '
       do k = kdim-n_print_levels,kdim
            write(dpu,23) k,n2(k)*sqrt(abs(n2(k)))*3600./max(small,    &
                abs(n2(k))),sqrt(s2(k))*3600.,ri(k)
       enddo
23     format(1X,i2,1X,3(f9.3,1X))
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '--------------------------------------------'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       end if

!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine trbintd

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




!======================================================================= 
!
!      subroutine exacol
!        
     
subroutine exacol(ri, bflxs, ktop, kbase, ncvfin) 

!----------------------------------------------------------------------- 
!
! object : determine whether the column has adjacent regions where 
!          Ri < 0 (unstable layers or ULs) and determine the indices 
!          kbase, ktop which delimit these unstable layers : 
!          ri(kbase) > 0 and ri(ktop) > 0, but 
!          ri(k) < 0 for ktop < k < kbase. 
!
! author : H. Grenier    05/2000, 
!          C. Bretherton 08/2000
!
!----------------------------------------------------------------------- 
!----------------------------------------------------------------------- 
!
!

real,    intent(in),  dimension(:) :: ri     ! Moist gradient Ri. #
real,    intent(in)                :: bflxs  ! Surface buoyancy flux 
                                             ! (m*m)/(s*s*s)
integer, intent(out), dimension(:) :: kbase  ! vertical index of UL base
integer, intent(out), dimension(:) :: ktop   ! vertical index of UL top
integer, intent(out)               :: ncvfin ! number of ULs

!
! internal variables
!
      
integer :: k, kdim, ncv         
real    :: riex(size(ri,1)) ! Column Ri profile extended to surface
                            ! by taking riex > rimaxentr for bflxs < 0
    !           riex < rimaxentr for bflxs > 0.


!-----------------------------------------------------------------------
!
!      Initialize variables

       ncvfin    = 0
       kdim      = size(ri,1) - 1
       ktop(:)   = 0
       kbase(:)  = 0
       
       riex(1:kdim) = ri(1:kdim)
       riex(kdim+1) = rimaxentr-bflxs ! Allows consistent treatment
                                      ! of surface with other intrfcs.
       ncv = 0

!-----------------------------------------------------------------------
!
!      Work upward from surf interface

       k = kdim+1
                       
       do while ( k.gt.2 )
       
            if (riex(k) .lt. rimaxentr) then 
                 
 !------------------------------------------------------
 !
                 ! A new convective layer has been found.
 ! Define kbase as interface below first unstable one
 ! then decrement k until top unstable level is found.
 ! Set ktop to the first interface above unstable layer. 
 
                 ncv = ncv + 1
                 kbase(ncv) = min(k+1,kdim+1)
                 do while (riex(k) .lt. rimaxentr .and. k.gt.2)
                      k = k-1
                 end do  
                 ktop(ncv) = k
            else
                 
 !------------------------------------------------------
                 !
 ! Keep on looking for a CL.
              
         k = k-1
       
            end if
       
       end do
       
       !--------------------------
       !
       ! Set total number of CLs
       
       ncvfin = ncv   

       if (column_match) then
       write (dpu,'(a)')  '--------------------------------------------'
       write (dpu,'(a)')  '                 IN EXACOL'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '  k     riex'
       write (dpu,'(a)')  '-------------'
       write (dpu,'(a)')  ' '
       do k = kdim+1-n_print_levels,kdim+1
            write(dpu,28) k,riex(k)
       enddo
28     format(1X,i2,1X,f9.3)
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a,i3)')  ' ncvfin = ',ncvfin
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  'ncv  ktop  kbase'
       write (dpu,'(a)')  '--------------------'
       write (dpu,'(a)')  ' '
       do ncv = 1, ncvfin
            write(dpu,29) ncv, ktop(ncv), kbase(ncv)
       enddo
29     format(1X,i2,3X,i2,5X,i2)
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       end if

!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine exacol

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

!=======================================================================
!
!      subroutine zisocl
!        
     
subroutine zisocl(u_star, bflxs, tkes, zm, ql, zi, n2, s2, ri, ncvfin, &
                  kbase, ktop, belongcv, ebrk, wbrk, ghcl, shcl, smcl, &
  lbrk)

!-----------------------------------------------------------------------
!
! object : find <e>, <W>, <Sh>, <Sm>, ktop(ncv), accounting for the 
!          presence of stably stratified layers inside the convective 
!          layer(CL, to be defined) but with r2 > ratinv.
!
!          Re-arrange the indexing of arrays kbase/ktop if some CLs are 
!          found to be coupled such that ncv defines the index of each 
!          CL increasing with height.
!
! author : H. Grenier 05/08/2000
!
!----------------------------------------------------------------------- 
!----------------------------------------------------------------------- 
!
!
   
real, intent(in)               :: u_star ! friction velocity (m/s)   
real, intent(in)               :: bflxs  ! Surface buoyancy flux 
                                         ! (m*m*m)/(s*s)
real, intent(in)               :: tkes   ! TKE at the surface (m2/s2)
real, intent(in), dimension(:) :: zm ! Layer midpoint height (m)
real, intent(in), dimension(:) :: ql ! condensate spec. hum. (kg/kg)
real, intent(in), dimension(:) :: zi ! Interface height (m)
real, intent(in), dimension(:) :: n2 ! Moist squared buoy freq (s-2)
real, intent(in), dimension(:) :: s2 ! Shear deformation (s-2)
real, intent(in), dimension(:) :: ri ! Gradient Richardson number
    
integer, intent(inout)               :: ncvfin ! Total number of CLs
integer, intent(inout), dimension(:) :: kbase  ! Vert index of CL base
integer, intent(inout), dimension(:) :: ktop   ! Vert index of CL top

logical, intent(out), dimension(:) :: belongcv ! = T if flux level in CL
real,    intent(out), dimension(:) :: ebrk  ! vert ave. of TKE  in CL
real,    intent(out), dimension(:) :: wbrk  !   "       of W^2  "
real,    intent(out), dimension(:) :: ghcl  !   "       of Gh   "
real,    intent(out), dimension(:) :: shcl  !   "       of Sh   "
real,    intent(out), dimension(:) :: smcl  !   "       of Sm   "
real,    intent(out), dimension(:) :: lbrk  ! CL depth not within entr
                                            ! layers
  
! internal variables

logical :: extend       ! True if CL is extended in zisocl
logical :: bottom       ! True if CL base at surface(kb = kdim+1)
integer :: ncv          ! Index enumerating convective layers in col
integer :: incv
integer :: k
integer :: kdim         ! number of full vertical levels
integer :: kb           ! Local index for kbase
integer :: kt           ! Local index for ktop
integer :: ncvinit      ! Value of ncv at routine entrance 
integer :: cntu         ! counts upward no. of merged CLs
integer :: cntd         ! counts downward  "          "
integer :: kbinc        ! Index for incorporating underlying CL
integer :: ktinc        ! Index for incorporating  overlying CL
real    :: ebar
real    :: wint
real    :: dwinc
real    :: dzinc
real    :: dwsurf
real    :: gh
real    :: sh
real    :: sm
real    :: l2n2         ! Vert. integral of l^2N^2 over CL
real    :: l2s2         ! Vert. integral of l^2S^2 over CL
real    :: dl2n2        ! Vert. int. of l^2N^2 over incorp. layer
real    :: dl2s2        ! Vert. int. of l^2S^2 over incorp. layer
real    :: lint         ! CL depth excluding entrainment layers
real    :: lbulk        ! Depth of the convective layer
real    :: lz           ! Turbulent length scale
real    :: ricl         ! Ri Number for the whole convective layer
real    :: zbot         ! Height of CL base
real    :: l2rat        ! Square of ratio of actual to initial CL depth
real    :: tmpr

!-----------------------------------------------------------------------
!
!      Initialize variables

       kdim = size(ql,1)
       ncv = 1 

       if (column_match) then
       write (dpu,'(a)')  '-------------------------------------------'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '        ENTERING ZISOCL               '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '  k    lint      lz      l2n2         l2s'//&
            '2' 
       write (dpu,'(a)')  '       (m)       (m)    (m3/s2)      (m3/'//&
            's2)'
       write (dpu,'(a)')  '-----------------------------------------'//&
            '------'
       end if       
      
!-----------------------------------------------------------------------
!
!      Loop over convective layers to see if they need to be extended


       

       do while ( ncv .le. ncvfin )
       
            ncvinit = ncv
            cntu    = 0
            cntd    = 0
            kb      = kbase(ncv) 
            kt      = ktop(ncv)
            lbulk   = zi(kt)-zi(kb)
            
    if (column_match) then
    write (dpu,'(a)')  ' '
    write (dpu,'(a,i3)')  ' ncv    = ', ncv
    write (dpu,'(a,i3)')  ' kb     = ', kb
    write (dpu,'(a,i3)')  ' kt     = ', kt
    write (dpu,'(a,f14.7,a)')  ' zi(kt) = ', zi(kt), ' meters'
    write (dpu,'(a,f14.7,a)')  ' zi(kb) = ', zi(kb), ' meters'
    write (dpu,'(a,f14.7,a)')  ' lbulk  = ', lbulk, ' meters'
    write (dpu,'(a)')  ' '
    end if
    
            !-----------------------------------------------------------
            !            
            ! Add contribution (if any) from surface interfacial layer 
    ! to turbulent production and lengthscales.  If there is 
    ! positive surface buoyancy flux, the CL extends to the 
    ! surface and there is a surface interfacial layer contri-
    ! bution to W and the CL interior depth. If there is neg-
    ! ative buoyancy flux, the surface interfacial layer is 
    ! treated as energetically isolated from the rest of the CL
    ! and does not contribute to the layer-interior W or depth.
    ! This case also requires a redefinition of lbulk.

            bottom = kb .eq. kdim+1
            if (bottom .and. (bflxs .ge. 0.)) then
                 lint = zm(kdim)
                 dwsurf = (tkes/b1)*zm(kdim)
            else if (bottom .and. (bflxs .lt. 0.)) then
                 lint = 0.
                 dwsurf = 0.
                 lbulk = zi(kt)-zm(kdim)
            else
                 lint = 0.
                 dwsurf = 0.
            end if
            l2n2 = 0.
            l2s2 = 0.
            
    if (column_match .and. bottom) then
         write(dpu,30) kdim+1,lint,lz,l2n2,l2s2
30               format(1X,i2,1X,2(f8.4,1X),2(f12.9,1X))
            end if
    
            !-----------------------------------------------------------
            !            
            ! Turbulence contribution from conv layer (CL) interior 
    ! kt < k < kb, which at this point contains only unstable 
    ! interfaces. Based on the CL interior stratification, 
    ! initial guesses at the stability functions are made. If 
    ! there is no CL interior interface, neutral stability is 
    ! assumed for now.

            if (kt .lt. kb-1) then 
            
         do k = kb-1, kt+1, -1
                      lz   = lengthscale(zi(k),lbulk)
                      l2n2 = l2n2 + lz*lz*n2(k)*(zm(k-1)-zm(k))
                      l2s2 = l2s2 + lz*lz*s2(k)*(zm(k-1)-zm(k))
                      lint = lint + (zm(k-1)-zm(k))      
      if (column_match) write(dpu,30) k,lint,lz,l2n2,  &
           l2s2
                 enddo

                 !------------------------------------------------------
 !
                 ! Solve for bulk Sh, Sm, and wint over the CL interior
 
                 ricl = min(l2n2/l2s2,ricrit) ! actually we should have 
                              ! ricl < 0 
                 call galperin(ricl,gh,sh,sm)
                 wint = -sh*l2n2 + sm*l2s2 + dwsurf 
                 ebar = b1*wint/lint

            else

            !-----------------------------------------------------------
            !            
            ! There is no CL interior interface. The only way that 
    ! should happen at this point is if there is upward surface 
    ! buoy flux but no unstable interior interfaces. In that 
    ! case, the surface interface turbulent production terms are
    ! used as its CL 'interior'.

                 if (bottom) then
                      wint = dwsurf
                      ebar = tkes     
      
      !use neutral stability fns for layer extension
                      call galperin(0.,gh,sh,sm) 
      
                 else
                      call error_mesg ('edt_mod', &
   'no convective layers found although ncv <= ncvfin',&
                        FATAL)
                 endif
 
            endif
    
    if(column_match) then
            write (dpu,'(a)')  ' '
    write (dpu,'(a,f14.7)')  ' ricrit = ',ricrit
    write (dpu,'(a,f14.7)')  ' ricl   = ', ricl
    write (dpu,'(a,f14.7)')  ' gh     = ', gh
    write (dpu,'(a,f14.7)')  ' sh     = ', sh
    write (dpu,'(a,f14.7)')  ' sm     = ', sm
    write (dpu,'(a,f14.7,a)')  ' lbulk  = ', lbulk,  ' meters'
    write (dpu,'(a,f14.7,a)')  ' wint   = ', wint,   ' m3/s2'
    write (dpu,'(a,f14.7,a)')  ' dwsurf = ', dwsurf, ' m3/s2'
    write (dpu,'(a,f14.7,a)')  ' ebar   = ', ebar,   ' m2/s2' 
    write (dpu,'(a)')  ' '
    end if
    
            !-----------------------------------------------------------
            !            
            ! Try to extend the top of the convective layer. Compute 
    ! possible contributions to TKE production and lengthscale 
    ! were the CL top interfacial layer found by exacol incor-
    ! porated into the CL interior.

            extend = .false.    ! will become true if CL top is extended
            dzinc  = zm(kt-1)-zm(kt)
            lz     = lengthscale(zi(kt),lbulk)
            dl2n2  = lz*lz*n2(kt)*dzinc
            dl2s2  = lz*lz*s2(kt)*dzinc
            dwinc  = -sh*dl2n2 + sm*dl2s2

            if (column_match) then 
    write (dpu,'(a)')  '------------------------------------'//&
                 '-------'
    write (dpu,'(a)')  ' '
            write (dpu,'(a)')  '  trying to extend a layer upwards     '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k    dzinc      lz      dl2n2      '//&
                 '  dl2s2        dwinc' 
            write (dpu,'(a)')  '       (m)       (m)    (m3/s2)     '//&
                 ' (m3/s2)      (m3/s2)'
            write (dpu,'(a)')  '------------------------------------'//&
                 '----------------------'
            write (dpu,'(a)')  ' '
    write(dpu,31) kt,dzinc,lz,dl2n2,dl2s2,dwinc
31          format(1X,i2,1X,2(f8.4,1X),3(f12.9,1X))
            end if
    
            !-----------------------------------------------------------
            !            
            ! Test for incorporation of top layer kt into CL interior. 
    ! If true, extend CL by incorporating top layers until test 
    ! fails.
      
            l2n2 = -max(min(-l2n2,tkemax*lint/(b1*sh)),tkemin*lint/    &
         (b1*sh))
    tmpr = -rinc*dzinc*l2n2/(lint+(1-rinc)*dzinc)
    
    if (column_match) then
            write (dpu,'(a)')  ' '
    write (dpu,'(a,f14.7,a)')  '-dl2n2 = ', -1.*dl2n2, ' m3/s2'
    write (dpu,'(a,f14.7,a)')  '  l2n2 = ',      l2n2, ' m3/s2'
    write (dpu,'(a,f14.7)')    '  rinc = ',      rinc
    write (dpu,'(a,f14.7,a)')  '  tmpr = ',      tmpr, ' m3/s2'
    !write (dpu,'(a,f14.7)')  ' will layer be extended (-dl2'//&
            !    'n2 .gt. tmpr)? ', real( -dl2n2 .gt. tmpr )
    write (dpu,'(a)')  ' '
    end if
    
            do while (-dl2n2 .gt. tmpr)

                 !------------------------------------------------------
 ! Add contributions from layer kt to interior length-
 ! scale/TKE prod

                 lint = lint + dzinc
                 wint = wint + dwinc
                 l2n2 = l2n2 + dl2n2
                 l2n2 = -max(min(-l2n2,tkemax*lint/(b1*sh)),tkemin*lint&
      /(b1*sh))
                 l2s2 = l2s2 + dl2s2
                 kt = kt-1
                 extend = .true.
                 if (kt .eq. 1) then
      call error_mesg ('edt_mod', &
      'trying to extend convective layer at model top',&
                        FATAL)
                 end if
               
                 !------------------------------------------------------
 ! Check for existence of an overlying CL which might 
 ! be merged. If such exists (ktinc > 1), check for 
 ! merging by testing for incorporation of its top 
 ! interior interface into current CL. If no such layer 
 ! exists, ktop(ncv+cntu+1) will equal its default value
 ! of zero, so ktinc will be 1 and the test kt=ktinc
                 ! will fail.

                 ktinc = ktop(ncv+cntu+1)+1
                 if (kt .eq. ktinc) then
                      ncvfin = ncvfin - 1
                      cntu   = cntu   + 1 
                 end if

                 !------------------------------------------------------
 ! Compute possible lengthscale and TKE production
                 ! contributions were layer kt incorporated into CL 
 ! interior. Then go back to top of loop to test for 
 ! incorporation.
            
                 dzinc = zm(kt-1)-zm(kt)
                 lz    = lengthscale(zi(kt),lbulk)
                 dl2n2 = lz*lz*n2(kt)*dzinc
                 dl2s2 = lz*lz*s2(kt)*dzinc
                 dwinc = -sh*dl2n2 + sm*dl2s2
    
         if (column_match) write(dpu,31) kt,dzinc,lz,dl2n2,    &
      dl2s2,dwinc
    
 !------------------------------------------------------
 ! Recalculate tmpr
      
 tmpr  = -rinc*dzinc*l2n2/(lint+(1-rinc)*dzinc)
            
         if (column_match) then
 write (dpu,'(a)')  ' '
 write (dpu,'(a,f14.7,a)')  '-dl2n2 = ', -1.*dl2n2,    &
      ' m3/s2'
         write (dpu,'(a,f14.7,a)')  '  l2n2 = ',      l2n2,    &
      ' m3/s2'
         write (dpu,'(a,f14.7)')    '  rinc = ',      rinc
         write (dpu,'(a,f14.7,a)')  '  tmpr = ',      tmpr,    &
      ' m3/s2'
         !write (dpu,'(a,f14.7,a)')  ' will layer be extende'//&
                 !     'd (-dl2n2 .gt. tmpr)? ', real(-dl2n2 .gt. tmpr)
         write (dpu,'(a)')  ' '
     end if
    
            end do   ! Done with top extension of CL

            !-----------------------------------------------------------
            ! Shift indices appropriately if layers have been merged

            if (cntu .gt. 0) then
                 do incv = 1, ncvfin - ncv
                      kbase(ncv+incv) = kbase(ncv+cntu+incv)
                      ktop(ncv+incv) = ktop(ncv+cntu+incv)
                 end do
            end if

            !-----------------------------------------------------------
            !            
            ! Extend the CL base if possible.

            if (column_match .and. .not. bottom) then 
    write (dpu,'(a)')  '------------------------------------'//&
                 '-------'
    write (dpu,'(a)')  ' '
            write (dpu,'(a)')  '  trying to extend a layer downwards'
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  'k     dzinc       lz       dl2n2    '//&
                 '       dl2s2          dwinc' 
            write (dpu,'(a)')  '       (m)        (m)     (m3/s2)   '//&
                 '     (m3/s2)        (m3/s2)'
            write (dpu,'(a)')  '------------------------------------'//&
                 '---------------------------'
            write (dpu,'(a)')  ' '
    end if
    
            if (.not. bottom) then

                 !------------------------------------------------------
 ! Compute possible contributions to TKE production and 
 ! lengthscale, were the CL base interfacial layer found 
 ! by exacol incorporated into the CL interior.

                 dzinc = zm(kb-1)-zm(kb)
                 lz    = lengthscale(zi(kb),lbulk)
                 dl2n2 = lz*lz*n2(kb)*dzinc
                 dl2s2 = lz*lz*s2(kb)*dzinc
                 dwinc = -sh*dl2n2 + sm*dl2s2

                 if (column_match) write(dpu,31) kb,dzinc,lz,dl2n2,    &
      dl2s2,dwinc

                 !------------------------------------------------------
 ! Test for incorporation of base layer kb into CL 
 ! interior. If true, extend CL by incorporating base 
 ! layers until test fails.

                 tmpr = -rinc*dzinc*l2n2/(lint+(1-rinc)*dzinc)
 
                 if (column_match) then
                 write (dpu,'(a)')  ' '
 write (dpu,'(a,f14.7,a)')  '-dl2n2 = ', -1.*dl2n2,    &
      ' m3/s2'
         write (dpu,'(a,f14.7,a)')  '  l2n2 = ',      l2n2,    &
      ' m3/s2'
         write (dpu,'(a,f14.7)')    '  rinc = ',      rinc
         write (dpu,'(a,f14.7,a)')  '  tmpr = ',      tmpr,    &
      ' m3/s2'
         !write (dpu,'(a,f14.7,a)')  ' will layer be extende'//&
                 !     'd (-dl2n2 .gt. tmpr)? ', real(-dl2n2 .gt. tmpr)
         write (dpu,'(a)')  ' '
     end if

                 do while((-dl2n2.gt. tmpr) .and. (.not. bottom) )

                      !-------------------------------------------------
      ! Add contributions from layer kb to interior 
      ! lengthscale/TKE prod
 
                      lint = lint + dzinc
                      wint = wint + dwinc
                      l2n2 = l2n2 + dl2n2
                      l2n2 = -max(min(-l2n2,tkemax*lint/(b1*sh)),tkemin&
           *lint/(b1*sh))
                      l2s2 = l2s2 + dl2s2

                      !-------------------------------------------------
      ! Extend base of CL downward a layer

                      kb = kb+1
                      extend = .true.

                      !-------------------------------------------------
      ! Check for existence of an underlying CL which 
      ! might be merged. If such exists (kbinc > 1), 
      ! check for merging by testing for incorporation 
      ! of its top interior interface into current CL.
                      ! Note that this top 'interior' interface could be
      ! the surface.

                      kbinc = 0
                      if (ncv .gt. 1) kbinc = ktop(ncv-1)+1
                      if (kb .eq. kbinc) then

                           !--------------------------------------------
           ! We are incorporating interior of CL ncv-1, 
   ! so merge this CL into the current CL.

                           ncv    = ncv    - 1
                           ncvfin = ncvfin - 1
                           cntd   = cntd   + 1 
                      
      end if

                      !-------------------------------------------------
      ! If CL would now reach the surface, check sign of
      ! surface buoyancy flux. If positive, add contri-
      ! butions of surface interfacial layer to TKE 
      ! production and lengthscale. If negative, we 
      ! regard the surface layer as stable and do not
                      ! add surface interfacial layer contributions to 
      ! the CL. In either case the surface interface is 
      ! classified as part of the CL for bookkeeping 
      ! purposes (to ensure no base entrainment calcula-
      ! tion is done). If we are merging with a surface-
      ! driven CL with no interior unstable interfaces, 
      ! the above code will already have handled the 
      ! merging book-keeping.

                      bottom = kb .eq. kdim+1
                      if (bottom) then 
                           if (bflxs .gt. 0.) then 
                                dwsurf = (tkes/b1)*zm(kdim)
                                lint = lint + zm(kdim)
                           end if
                      else

                           !--------------------------------------------
           ! Compute possible lengthscale and TKE prod-
   ! uction contributions were layer kb incor-
   ! porated into CL interior,then go back to 
   ! top of loop to test for incorporation
            
                           dzinc = zm(kb-1) - zm(kb)
                           lz    = lengthscale(zi(kb),lbulk)
                           dl2n2 = lz*lz*n2(kb)*dzinc
                           dl2s2 = lz*lz*s2(kb)*dzinc
                           dwinc = -sh*dl2n2 + sm*dl2s2
                        
      end if

                      if (column_match) write(dpu,31) kb,dzinc,lz,     &
           dl2n2,dl2s2,dwinc
    
                      !-------------------------------------------------
      ! Recalculate tmpr
      
      tmpr = -rinc*dzinc*l2n2/(lint+(1-rinc)*dzinc)

                      if (column_match) then
      write (dpu,'(a)')  ' '
      write (dpu,'(a,f14.7,a)')  '-dl2n2 = ',-1.*dl2n2,&
           ' m3/s2'
              write (dpu,'(a,f14.7,a)')  '  l2n2 = ',     l2n2,&
           ' m3/s2'
              write (dpu,'(a,f14.7)')    '  rinc = ',     rinc
              write (dpu,'(a,f14.7,a)')  '  tmpr = ',     tmpr,&
           ' m3/s2'
              !write (dpu,'(a,f14.7,a)')  ' will layer be ex'//&
                      !     'tended (-dl2n2 .gt. tmpr)? ', real(-dl2n2 &
      !     .gt. tmpr)
              write (dpu,'(a)')  ' '
          end if
    
                 end do ! for downward extension
 
                 if (bottom .and. ncv .ne. 1) then 
                       call error_mesg ('edt_mod', &
               'bottom convective layer not indexed 1',&
                 FATAL)
                 end if

            end if   ! Done with bottom extension of CL 

            !-----------------------------------------------------------
            ! Shift indices if some layers with N2 < 0 have been found

            if (cntd .gt. 0) then
                 do incv = 1, ncvfin - ncv
                      kbase(ncv+incv) = kbase(ncvinit+incv)
                      ktop(ncv+incv) = ktop(ncvinit+incv)
                 end do
            end if

            !-----------------------------------------------------------
            ! Sanity check for positive wint.
            if (wint .lt. 0.) then
                 call error_mesg ('edt_mod', &
                  'interior avg TKE < 0', FATAL)
            end if

            !-----------------------------------------------------------
            ! Recompute base and top indices, Ri_cl, Sh, Sm, and <W> 
    ! after layer extension if necessary. Ideally, we would 
    ! recompute l2n2 and l2s2 to account for the incorrect lbulk
    ! used in the computation of lz, but we take the simpler 
    ! approach of simply multiplying the lz's by the ratio of 
    ! the actual PBL depth to lbulk.
    
            if (extend) then

                 ktop (ncv) = kt
                 kbase(ncv) = kb
                 zbot       = zi(kb)
                 if (bottom .and. (bflxs.lt.0)) zbot = zm(kdim)
                 l2rat      = ((zi(kt) - zbot)/lbulk)**2
                 l2n2       = l2n2*l2rat
                 l2s2       = l2s2*l2rat
                 ricl = min(l2n2/l2s2,ricrit)
 call galperin(ricl,gh,sh,sm)
                 
 !------------------------------------------------------
 ! It is conceivable that even though the original wint 
 ! was positive, it will be negative after correction. 
 ! In this case, correct wint to be a small positive 
 ! number
                 wint = max(dwsurf + (-sh*l2n2 + sm*l2s2),0.01*wint)

            end if  ! for extend if

            lbrk(ncv) = lint
            wbrk(ncv) = wint/lint
            ebrk(ncv) = b1*wbrk(ncv)
            ebrk(ncv) = max(min(ebrk(ncv),tkemax),tkemin)
            ghcl(ncv) = gh 
            shcl(ncv) = sh
            smcl(ncv) = sm
           
    if (column_match) then
    write (dpu,'(a)')  ' '
    write (dpu,'(a,i4)') ' FINAL RESULTS FOR CONVECTIVE LAYER',&
                 ncv
    write (dpu,'(a)')  ' '
    write (dpu,'(a,i4,i4)')   ' ktop(ncv), kbase(ncv) = ',     &
         ktop(ncv), kbase(ncv)
    write (dpu,'(a,f14.7,a)') ' lbrk(ncv) = ', lbrk(ncv),' m'
    write (dpu,'(a,f14.7,a)') ' wbrk(ncv) = ', wbrk(ncv),      &
         ' m2/s2'
            write (dpu,'(a,f14.7,a)') ' sqrt(ebrk(ncv)) = ',           &
         sqrt(ebrk(ncv)), ' m/s'
    write (dpu,'(a,f14.7)')   ' ghcl(ncv) = ', ghcl(ncv)
    write (dpu,'(a,f14.7)')   ' shcl(ncv) = ', shcl(ncv)
    write (dpu,'(a,f14.7)')   ' smcl(ncv) = ', smcl(ncv)
    end if

            !-----------------------------------------------------------
    ! Increment counter for next CL

            ncv = ncv + 1

       end do     ! Loop over convective layers


       !----------------------------------------------------------------
       ! 
       ! set belongcv 

       belongcv(:) = .false.
       do ncv = 1, ncvfin
            do k = ktop(ncv), kbase(ncv)
                 belongcv(k) = .true.
            enddo
       enddo
       
       if (column_match) then
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '                  END OF ZISOCL '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '-------------------------------------------'
       end if
              
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine zisocl

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




!======================================================================= 
!
!      subroutine caleddy
!        
!
!      this is the main program provided by Chris Bretherton and Herve
!      Grenier
!        

subroutine caleddy( u_star,       kqfs,         khfs,         sl,      &
                    qt,           ql,           qa,           slv,     &
    u,            v,            pm,           zm,      &
    sfuh,         sflh,         slslope,      qtslope, &
    qrl,          hleff,        density,      qsl,     &
    dqsldtl,      qltop,        pi,           zi,      &
    chu,          chs,          cmu,          cms,     &
    n2,           s2,           ri,           pblh,    &
    turbtype,     kvh,          kvm,          tke,     &
    leng,         bprod,        sprod,        trans,   &
    diss,         isturb,       adj_time_inv, sdevs,   &
    radfvec,      shvec,        smvec,        ghvec,   &
    evhcvec)


!-----------------------------------------------------------------------
!
!      Driver routine to compute eddy diffusion coefficients for 
!      momentum, moisture, trace constituents and static energy.  Uses 
!      first order closure for stable turbulent layers. For convective 
!      layers, an entrainment closure is used, coupled to a diagnosis 
!      of layer-average TKE from the instantaneous thermodynamic and 
!      velocity profiles. Convective layers are diagnosed by extending 
!      layers of moist static instability into adjacent weakly stably 
!      stratified interfaces, stopping if the stability is too strong.  
!      This allows a realistic depiction of dry convective boundary 
!      layers with a downgradient approach.
! 
!      Authors:  Herve Grenier, 06/2000, Chris Bretherton 09/2000
!
!-----------------------------------------------------------------------
! 
! Variable declarations
!
! Inputs
!

real, intent(in)               :: u_star  ! surface friction velocity
real, intent(in)               :: kqfs    ! kinematic surf constituent
                                          ! flux (kg/kg)*(m/s)
real, intent(in)               :: khfs    ! kinematic surface heat flux
                                          ! (K*m/s)

!
!       the following fields are defined on model full
!       levels with dimension (1:nlev)
!

real, intent(in), dimension(:) :: sl      ! liq water static energy 
                                          !  cp*T+g*z-L*ql (J/kg)
real, intent(in), dimension(:) :: qt      ! total water spec. hum.
                                          ! (kg water/kg air) 
real, intent(in), dimension(:) :: ql      ! liq water spec. hum.
                                          ! (kg condensate/kg air)
real, intent(in), dimension(:) :: qa      ! cloud fraction (fraction)
real, intent(in), dimension(:) :: slv     ! liq water virtual static
                                          ! energy (J/kg)
                                          !  sl*(1 + .608*qt)
real, intent(in), dimension(:) :: u       ! u wind input (m/s)
real, intent(in), dimension(:) :: v       ! v wind input (m/s)
real, intent(in), dimension(:) :: pm      ! midpoint pressures (Pa)
real, intent(in), dimension(:) :: zm      ! layer midpoint height 
                                          ! above sfc (m)
real, intent(in), dimension(:) :: sfuh    ! sat frac in upper half-lyr
real, intent(in), dimension(:) :: sflh    ! sat frac in lower half-lyr    
real, intent(in), dimension(:) :: slslope ! sl slope with respect to
                                          ! pressure in thermo lyr
  ! (J/kg/Pa)
real, intent(in), dimension(:) :: qtslope ! qt slope with respect to
                                          ! pressure in thermo lyr
                                          ! (kg water/kg air/Pa)
real, intent(in), dimension(:) :: qrl     ! LW heating rate (K/s)
real, intent(in), dimension(:) :: hleff   ! effective latent heat of 
                                          ! condensation (J/kg)
real, intent(in), dimension(:) :: density ! air density (kg/m3)
real, intent(in), dimension(:) :: qsl     ! saturation specific hum.
                                          ! (kg water/kg air)
real, intent(in), dimension(:) :: dqsldtl ! temperature derivative of
                                          ! qsl (kg water/kg air/K)
real, intent(in), dimension(:) :: qltop   ! cloud liquid at the top
                                          ! of the thermo layer
  
!
!       the following fields are defined on model half levels,
!       dimension(1:nlev+1)
!

real, intent(in), dimension(:) :: pi      ! interface pressures (Pa)
real, intent(in), dimension(:) :: zi      ! interface height above
                                          ! sfc (m)
real, intent(in), dimension(:) :: chu     ! Unsat sl (heat) coef (1/m)
real, intent(in), dimension(:) :: chs     ! Sat sl (heat) coef (1/m)
real, intent(in), dimension(:) :: cmu     ! Unsat qt (moisture) coef 
                                          ! (kg/kg)*(m/s*s)
real, intent(in), dimension(:) :: cms     ! Sat qt (moisture) coef 
                                          ! (kg/kg)*(m/s*s)
real, intent(in), dimension(:) :: n2      ! Moist squared buoy freq 
                                          ! (1/sec**2)
real, intent(in), dimension(:) :: s2      ! Squared deformation (s-2)
                                          ! (1/sec**2)
real, intent(in), dimension(:) :: ri      ! gradient Richardson number

!
! Outputs
!

real,    intent(out)   :: pblh     ! planetary boundary layer height (m)


!
!       the following field is defined on model full levels,
!       dimension(1:nlev)
!

real,    intent(out), dimension(:) :: isturb ! is full layer part of a 
     ! turbulent layer?

!
!       the following fields are defined on model half levels,
!       dimension(1:nlev+1)
!

integer, intent(out), dimension(:,:) :: turbtype! Interface turb. type
                                                ! 1 = stable turb 
          ! 2 = CL interior
                                                ! 3 = bottom entr intfc 
                                                ! 4 = upper entr intfc 
real,    intent(out), dimension(:) :: kvh       ! diffusivity for heat 
                                                ! and tracers (m*m/s)
real,    intent(out), dimension(:) :: kvm       ! diffusivity for mom.
                                                ! (m*m/s)
real,    intent(out), dimension(:) :: tke       ! turb. kin. energy 
                                                ! (m*m)/(s*s)
real,    intent(out), dimension(:) :: leng      ! turbulent length scale
                                                ! (m)
real,    intent(out), dimension(:) :: bprod     ! Buoyancy production
                                                ! (m*m)/(s*s*s)
real,    intent(out), dimension(:) :: sprod     ! shear production
                                                ! (m*m)/(s*s*s)
real,    intent(out), dimension(:) :: trans     ! TKE transport
                                                ! (m*m)/(s*s*s)
real,    intent(out), dimension(:) :: diss      ! TKE dissipation
                                                ! (m*m)/(s*s*s)
real,    intent(out), dimension(:) :: adj_time_inv  ! inverse adjustment 
                                                    ! time for turbulent
    ! layer (1/sec)
real,    intent(out), dimension(:) :: sdevs     ! std. dev. of water
                                                ! perturbation
        ! (kg water/kg air)
        ! defined on model half
        ! levels
real,    intent(out), dimension(:) :: radfvec   ! Buoyancy production
                                                ! from lw radiation
                                                ! (m*m)/(s*s*s)
real,    intent(out), dimension(:) :: shvec     ! Galperin heat stab. 
                                                ! fn. (none)
real,    intent(out), dimension(:) :: smvec     ! Galperin mom. stab. 
                                                ! fn. (none)
real,    intent(out), dimension(:) :: ghvec     ! Galperin stability
                                                ! ratio (none)
real,    intent(out), dimension(:) :: evhcvec   ! Evaporative cooling
                                                ! entrainment factor
! (none)


!
! Internal variables
!

logical :: in_CL                             ! True if interfaces k,k+1
                                             ! both in same CL
logical :: any_stable                        ! Are there any stable 
                                             ! turbulent layers?
logical :: cloudtop                          ! Is the interface at 
                                             ! cloudtop?
logical, dimension(size(sl,1)+1) :: belongcv ! True for interfaces 
                                             ! interior to convective
     ! layer (CL)
logical, dimension(size(sl,1)+1) :: belongst ! True for interfaces 
                                             ! interior to a stable
     ! turbulent layer
integer :: k                    ! vertical index
integer :: ks                   ! vertical index
integer :: kk                   ! vertical index
integer :: kdim                 ! number of full vertical levels
integer :: ncvfin               ! Total number of CL in column
integer :: ncvf                 ! Total number of CL in column prior to
                                ! addition of one layer rad-driven CLs
integer :: ncv                  ! index of current CL
integer :: ncvnew               ! index of added one layer rad-driven CL
integer :: ncvsurf              ! if nonzero, index of CL including 
                                ! surface
integer :: kb, kt               ! kbase and ktop for current CL


integer, dimension(size(sl,1)+1) :: kbase     ! vert. index for base
                                              ! interface of CL
integer, dimension(size(sl,1)+1) :: ktop      ! vert. index for top 
                                              ! interface of CL

real    :: bflxs    ! Surface buoyancy flux (m2/s3)
real    :: tkes     ! Surface TKE
real    :: jtzm     ! Interface layer thickness atop conv layer (CL) ncv
real    :: jtsl     ! Jump in s_l               atop       "
real    :: jtqt     ! Jump in q_t               atop       "
real    :: jtbu     ! Jump in buoyancy          atop       "
real    :: jtu      ! Jump in zonal wind        atop       "
real    :: jtv      ! Jump in meridional wind   atop       "
real    :: jt2slv   ! 2-layer Jump in s_lv              atop       "
real    :: radf     ! buoy flx jump at cloudtop from lw rad flx div
real    :: jbzm     ! Interface layer thickness at base of CL ncv
real    :: jbsl     ! Jump in s_l               at base    "
real    :: jbqt     ! Jump in qt                at base    "
real    :: jbbu     ! Jump in buoyancy          at base    "
real    :: jbu      ! Jump in zonal wind        at base    "
real    :: jbv      ! Jump in merid. wind       at base    "
real    :: ch       ! buoy flux coefs for sl, qt in a half-layer 
real    :: cm       ! 
real    :: n2h      ! Moist squared buoy freq for a half-layer (s-2)
real    :: ckh      ! Galperin stability function for heat
real    :: ckm      ! Galperin stability function for momentum
real    :: gh       ! Normalised buoyancy production (m*m*m)/(s*s)
real    :: lbulk    ! Depth of turbulent layer (m)
real    :: trma     ! intermediate variables
real    :: vus
real    :: vub
real    :: trmp
real    :: trmq
real    :: angle
real    :: qq
real    :: rootp             
real    :: evhc          ! (1+E) with E = evap. cool. efficiency [nd]
real    :: vys           ! n2h/n2 at upper inversion [nd]
real    :: vyb           ! Same at lower inversion [nd]
real    :: kentr         ! effective entrainment diffusivity we*dz (m*m/s)
real    :: lwp           ! liquid water path in layer kt (kg cond/m2)
real    :: opt_depth     ! optical depth of layer kt
real    :: radinvfrac    ! frac of lw cooling in layer kt put at inv.
real    :: qtsltmp       ! dqt/dz (kg/kg/m)
real    :: slsltmp       ! dsl/dz (J/kg/m)
real    :: qsltmp        ! qsl (kg water/kg air)
real    :: dqsldtltmp    ! dqsldtl (kg water/kg air/K)
real    :: hlefftmp      ! effective latent heat (J/kg water)
real    :: qstartmp      ! q* at upper/lower inversion (kg water/kg air)
real    :: bstartmp      ! b* at upper/lower inversion (m/s2)
real    :: temperature   ! actual temperature (K)
real    :: tmpfrac       ! fraction of cloud at top of convective layer
                         ! exposed to clear air above using maximum 
 ! overlap assumption
real, dimension(size(sl,1)+1) :: ebrk,wbrk,lbrk,ghcl,shcl,smcl
real, dimension(size(sl,1)+1) :: wcap          ! W (m2/s2)
real, dimension(size(sl,1)+1) :: rcap          ! e/<e> 

!-----------------------------------------------------------------------
!
!      Initialize to zero outputs needed at all interfaces, but
!      calculated only at turbulent interfaces. Only kvh and kvm are 
!      outputs, the other arrays are zeroed for plotting or diagnostic 
!      purposes. 

       kdim             = size(sl,1)
       kvh(:)           = 0.0
       kvm(:)           = 0.0
       wcap(:)          = 0.0
       leng(:)          = 0.0
       rcap(:)          = 0.0
       bprod(:)         = 0.0
       sprod(:)         = 0.0
       trans(:)         = 0.0
       diss(:)          = 0.0
       tke(:)           = 0.0
       turbtype(:,:)    = 0
       adj_time_inv(:)  = missing_value
       isturb(:)        = 0.0
       sdevs(:)         = missing_value
       radfvec(:)       = 0.0
       shvec(:)         = missing_value
       smvec(:)         = missing_value
       ghvec(:)         = missing_value
       evhcvec(:)       = missing_value
       
!-----------------------------------------------------------------------
!
!      Optional printout
        
       if (column_match) then
       write (dpu,'(a)')  '--------------------------------------------'
       write (dpu,'(a)')  '        ENTERING CALEDDY                '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  'checking inputs: '
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)') ' u_star             = ',u_star, ' m/s'
       write (dpu,'(a,f14.7,a)') ' latent   heat flux = ',density(kdim)&
            *hleff(kdim)*kqfs,' W/m2'
       write (dpu,'(a,f14.7,a)') ' sensible heat flux = ',density(kdim)&
            *cp_air*khfs,' W/m2'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k     sl/cp_air        qt        qc        q'//&
            'a     slv/cp_air' 
       write (dpu,'(a)')  '        (K)       (g/kg)    (g/kg)       '//&
            '       (K)  '
       write (dpu,'(a)')  '-----------------------------------------'//&
            '------------'
       write (dpu,'(a)')  ' '
       do kk = kdim-n_print_levels,kdim
            write(dpu,224) kk,sl (kk)/cp_air,1000.*qt(kk),1000.*ql(kk),    &
         qa(kk),slv(kk)/cp_air
       end do
224    format(1X,i2,1X,5(f9.4,1X))
24     format(1X,i2,1X,4(f9.4,1X))
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k      u          v      z_full     p_full'
       write (dpu,'(a)')  '      (m/s)      (m/s)     (m)        (mb) '
       write (dpu,'(a)')  '-------------------------------------------'
       write (dpu,'(a)')  ' '
       do kk = kdim-n_print_levels,kdim
            write(dpu,24) kk,u(kk),v(kk),zm(kk),pm(kk)/100.
       enddo    
       write (dpu,'(a)') ' '
       write (dpu,'(a)') ' '
       write (dpu,'(a)') ' k     sfuh      sflh     slslope   qtslope'
       write (dpu,'(a)') '                        (K/100mb)(g/kg/100mb)'              
       write (dpu,'(a)') '---------------------------------------------'
       write (dpu,'(a)') ' '
       do kk = kdim-n_print_levels,kdim
            write(dpu,24) kk,sfuh(kk),sflh(kk),slslope(kk)*100.*100./cp_air&
    ,1000.*qtslope(kk)*100.*100.
       enddo
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  'k       rho       qrl      hleff'
       write (dpu,'(a)')  '      (kg/m3)   (K/day)   (MJ/kg)'
       write (dpu,'(a)')  '---------------------------------'
       write (dpu,'(a)')  ' '
       do kk = kdim-n_print_levels,kdim
            write(dpu,124) kk,density(kk),qrl(kk)*86400,hleff(kk)/1.e+06
124    format(1X,i2,1X,3(f9.4,1X))
       enddo
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' k   p_half  z_half  chu    chs     cmu  '//&
            '   cms   sqrt(n2)  sqrt(s2)     ri'
       write (dpu,'(a)')  '     (mb)    (m)    (m/K/s**2)      (m/s*'//&
            '*2)      (1/hr)    (1/hr) '
       write (dpu,'(a)')  '-----------------------------------------'//&
            '--------------------------------------'
       write (dpu,'(a)')  ' '
       do kk = kdim+1-n_print_levels,kdim+1
            write(dpu,26) kk,pi(kk)/100.,zi(kk),cp_air*chu(kk),cp_air*chs(kk), &
                cmu(kk),cms(kk),n2(kk)*sqrt(abs(n2(kk)))*3600./&
max(small,abs(n2(kk))),sqrt(s2(kk))*3600.,ri(kk)
       enddo
26     format(1X,i2,1X,f7.2,1X,f7.1,1X,2(f7.4,1X),2(f6.3,1X),3(f9.3,1X))
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  '-----------------------------------------'//&
            '-------------------------------------'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       end if
       
!-----------------------------------------------------------------------
!
!      calculate 'surface' (actually lowest half-layer) buoyancy flux.
!
!      Note that sensible heat flux in W/m2 = density_air * cp * khfs
!                  latent heat flux in W/m2 = density_air * L  * kqfs
!
!      units of bflxs below is m2/s3
!
!      Buoyancy flux in W/m2 = rho * bflxs / ch
!
       ch = chu(kdim+1)*(1-sflh(kdim)) + chs(kdim+1)*sflh(kdim)   
       cm = cmu(kdim+1)*(1-sflh(kdim)) + cms(kdim+1)*sflh(kdim)   
       bflxs  = ch*cp_air*khfs + cm*kqfs
       bprod(kdim+1) = bflxs       
             
!-----------------------------------------------------------------------
!
!      Diagnostic surface TKE used in calculating layer-average TKE.
!
!      Chris B. note:
!
!      Originally tkes was computed from the commented out line below.
!      This commented-out line can make tkes small or even negative. 
!      The replacement has at least equal justifiability, trying to 
!      represent tke at the surface rather than at zm(kdim).  Near the
!      surface is where averaging W to get <e> is not really just-
!      ifiable.
!
!      tkes = (b1*(ustar**3+vonkarm*zm(kdim)*bflxs))**2./3.
!  
!      [Steve Klein note:
!
!      The replacement line appears to create an inconsistency in the 
!      sense that the buoyancy flux in the lower half of level one does
!      not effectively contribute to dwsurf, the contribution to W,
!      in the lower half of level one. Hence diagnosing shear production
!      and dissipation at the surface is a bit of a ruse.]

       tkes          = max(min(b123*u_star**2,tkemax),tkemin)
       tke(kdim+1)   = tkes
       diss(kdim+1)  = tkes**(3/2)/b1/zm(kdim)              
       sprod(kdim+1) = tkes**(3/2)/b1/zm(kdim)

       if (column_match) then       
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)')  ' ch (surface)  = ',cp_air*ch,' m/K/s**2'
       write (dpu,'(a,f14.7,a)')  ' cm (surface)  = ',cm,' m/s**2'
       write (dpu,'(a,f14.7,a)')  ' bflxs         = ',bflxs,' m2/s3'
       write (dpu,'(a,f14.7,a)')  ' buoyancy flux = ',density(kdim)*   &
            bflxs/ch,' W/m2'
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)')  ' u_star           = ', u_star,' m/s'
       write (dpu,'(a,f14.7,a)')  ' surface tke sqrt = ',sqrt(tkes),   &
            ' m/s'
       write (dpu,'(a)')  ' '
       end if        

!-----------------------------------------------------------------------
!
!      Examine each column and determine whether it is convective.

       call exacol(ri, bflxs, ktop, kbase, ncvfin)

!-----------------------------------------------------------------------
!
!      CONVECTIVE LAYER (CL) computations
!
!      If some convective layers have been found, determine their bulk 
!      properties (<e>, <Sh>, <Sm>, and indices ktop/bkase for upper/
!      lower inversion ).

       ncvsurf = 0  
       
       if (ncvfin .gt. 0) then
       
          call zisocl(u_star, bflxs, tkes, zm, ql, zi, n2, s2, ri,     &
              ncvfin, kbase, ktop, belongcv, ebrk, wbrk, ghcl, &
      shcl, smcl, lbrk)
 
          !-------------------------------------------------------------
          ! CLs found by zisocl are in order of height, so if any CL 
  ! contains the surface, it will be CL1.
         
          if (kbase(1) .eq. kdim+1) ncvsurf = 1
  
       else
       
          belongcv(:) = .false.
       
       end if

       if (column_match) write (dpu,'(a,i3)')  ' ncvsurf = ', ncvsurf

!-----------------------------------------------------------------------
!
!      Find single-level radiatively-driven cloud-topped convective 
!      layers (SRCLs). SRCLs extend through a single thermo layer k, 
!      with entrainment at interfaces k and k+1 (unless k+1 is the 
!      surface, in which case surface shear generation contributes to 
!      the layer-averaged energy). The conditions for an SRCL are:
!          1. cloud at level k
!          2. no cloud at level k+1 (else assuming that some fraction 
!             of the longwave flux div in layer k is concentrated at 
!             the top interface is invalid.
!          3. Longwave radiative cooling (shortwave heating is assumed
!             uniformly distributed through layer k, so not relevant to
!             buoyancy production of TKE)
!          4. Internal stratification n2h of half-layer from level k to
!             interface k is unstable using similar method as in sfdiag,
!             but applied to internal slopes of sl, qt in layer k.
!          5. Interfaces k, k+1 not both in the same existing convective
!             layer.
!          6. k >= 2 
!          7. Ri at interface k > ricrit, otherwise stable turb mixing 
!             will broadly distribute the cloud top in the vertical, 
!             preventing localized radiative radiative destabilization 
!             at the interface height.

       ncv = 1
       ncvf = ncvfin
       
       do k = kdim, 2, -1
             
    cloudtop  = .false. 
    if (ql(k)  .gt. qcminfrac*qsl(k)   .and. use_qcmin .and.   &
        ql(k-1).lt. qcminfrac*qsl(k-1))        cloudtop = .true.
    if (.not.use_qcmin .and. qa(k).gt.qa(k-1)) cloudtop = .true.
     
            if (qrl(k).lt. 0. .and. ri(k).gt.ricrit .and. cloudtop) then

                 ch  = (1 -sfuh(k))*chu(k) + sfuh(k)*chs(k)
                 cm  = (1 -sfuh(k))*cmu(k) + sfuh(k)*cms(k)
                 n2h = ch*slslope(k) + cm*qtslope(k)
             
         if (n2h.le.0.) then

                      !-------------------------------------------------
      ! Test if k and k+1 are part of the same preexist-
      ! ing CL. If not, find appropriate index for new 
      ! SRCL. Note that this calculation makes use of 
      ! ncv set from prior passes through the k do loop
 
                      in_CL = .false.
                
      do while (ncv .le. ncvf)
                           
   if (ktop(ncv) .le. k) then

                                !---------------------------------------
                ! If kbase > k, k and k+1 are part of 
! same prior CL
                                if (kbase(ncv) .gt. k) in_CL = .true.

                                !---------------------------------------
                ! exit from do-loop once CL top at/above
! intfc k.
exit  
                      
           else                                

!---------------------------------------
                !  Go up one CL
ncv = ncv + 1  
                      
           end if
                      
      end do ! ncv

                      !-------------------------------------------------
      ! Add a new SRCL
                
      if (.not.in_CL) then

                           ncvfin        = ncvfin+1
                           ncvnew        = ncvfin
                           ktop(ncvnew)  = k
                           kbase(ncvnew) = k+1
                           belongcv(k)   = .true.
                           belongcv(k+1) = .true.
                   

                           if (k.lt.kdim) then
                                
ebrk(ncvnew) = 0.
                                lbrk(ncvnew) = 0.
                                shcl(ncvnew) = 0.
                                smcl(ncvnew) = 0.

                           else 
   
        !---------------------------------------
                ! surface radiatively driven fog
                                if (bflxs.gt.0.) then 

     !----------------------------------
                     ! unstable surface layer 
     ! incorporate surface TKE into
                                     ebrk(ncvnew) = tkes
                                     lbrk(ncvnew) = zm(k)
                                     adj_time_inv(kdim+1) = sqrt(tkes)/&
          zm(k)
        else   

     !----------------------------------
                     ! stable surface layer 
     ! don't incorporate surface TKE 
                                     ebrk(ncvnew) = 0.
                                     lbrk(ncvnew) = 0.
                                
end if
                                shcl(ncvnew) = 0.
                                smcl(ncvnew) = 0.
                                ncvsurf = ncvnew
                      
                           end if    ! k < kdim  
                      
      end if    ! new SRCL
             
         end if    ! n2h < 0 
                  
          end if ! qrl < 0, ri(k) > ricrit and cloudtop
 
       end do ! k do loop, end of SRCL section

!-----------------------------------------------------------------------
!
!      For each CL, compute length scale, r^2, e, Kh and Km

       if (column_match) then
       write (dpu,'(a)') ' '
       write (dpu,'(a)') ' '
       write (dpu,'(a)') ' IN CALEDDY CALCULATION OF L, R2, e, Kh, a'//&
            'nd Km'
       write (dpu,'(a)') ' '       
       end if

       do ncv = 1, ncvfin
            
    kt    = ktop(ncv)
            kb    = kbase(ncv)
            lbulk = zi(kt)-zi(kb)          
    
    if (column_match) then
    write (dpu,'(a,i3)')  ' convective layer #',ncv
    write (dpu,'(a,i4,i4)')  ' kt, kb = ', kt,kb
    write (dpu,'(a,f14.7,a)')  ' lbulk = ', lbulk, ' m'
    write (dpu,'(a)')  ' '
            end if
    
    do k = min(kb,kdim), kt, -1             
         leng(k) = lengthscale(zi(k),lbulk)
                 wcap(k) = (leng(k)**2)*(-shcl(ncv)*n2(k)+ &
                          smcl(ncv)*s2(k))
            end do    ! k do loop

            if (column_match) then
    write (dpu,'(a)')  ' '
    write (dpu,'(a)')  ' k     leng          wcap '
            write (dpu,'(a)')  '       (m)          (m2/s2)'
            write (dpu,'(a)')  '----------------------------'
            write (dpu,'(a)')  ' '
            do k = min(kb,kdim),kt,-1
            write(dpu,33) k,leng(k),wcap(k)
            enddo
33          format(1X,i2,1X,f9.4,1X,f14.9)    
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            end if
    
            !-----------------------------------------------------------
            ! Calculate jumps at the lower inversion 
  
            if (kb .lt. kdim+1) then 
   
                 jbzm = zm(kb-1) - zm(kb)
                 jbsl = sl(kb-1) - sl(kb)
                 jbqt = qt(kb-1) - qt(kb)
                 jbbu = n2(kb)   * jbzm
                 jbbu = max(jbbu,jbumin)
                 jbu  = u(kb-1)  - u(kb)
                 jbv  = v(kb-1)  - v(kb)
                 ch   = (1 -sflh(kb-1))*chu(kb) + sflh(kb-1)*chs(kb)
                 cm   = (1 -sflh(kb-1))*cmu(kb) + sflh(kb-1)*cms(kb)
                 n2h  = (ch*jbsl + cm*jbqt)/jbzm
                 vyb  = n2h*jbzm/jbbu
                 vub  = min(1.,(jbu**2+jbv**2)/(jbbu*jbzm) )
          
    else  
    
         !------------------------------------------------------
 ! Zero bottom entrainment contribution for CL extending
 ! down to sfc
            
         vyb = 0.
                 vub = 0.
          
    end if
            
    if (column_match .and. kb .lt. kdim+1) then
    write (dpu,'(a)')  ' '
    write (dpu,'(a)')  ' jumps at lower inversion '
    write (dpu,'(a)')  ' ------------------------ '
    write (dpu,'(a)')  ' '
    write (dpu,'(a,i3)')  ' inversion half level = ',kb
    write (dpu,'(a,f14.7,a)')  ' jbzm = ',jbzm,' m'
    write (dpu,'(a,f14.7,a)')  ' jbsl = ',jbsl/cp_air,' K'
    write (dpu,'(a,f14.7,a)')  ' jbqt = ',jbqt*1000.,' g/kg'
    write (dpu,'(a,f14.7,a)')  ' jbbu = ',jbbu,' m/s2'
    write (dpu,'(a,f14.7,a)')  ' jbumin = ',jbumin,' m/s2'
    write (dpu,'(a,f14.7,a)')  ' jbu = ',jbu,' m/s'
    write (dpu,'(a,f14.7,a)')  ' jbv = ',jbv,' m/s'
    write (dpu,'(a,f14.7,a)')  ' ch  = ',ch*cp_air, ' m/K/s2'
    write (dpu,'(a,f14.7,a)')  ' cm  = ',cm, ' m/s2'
    write (dpu,'(a,f14.7,a)')  ' sqrt(n2h) = ',n2h*            &
         sqrt(abs(n2h))*3600./abs(n2h),' 1/sec'
            write (dpu,'(a,f14.7,a)')  ' vyb = ', vyb
    write (dpu,'(a,f14.7,a)')  ' vub = ', vub
    write (dpu,'(a)')  ' '
    end if
    
            !-----------------------------------------------------------
            ! Calculate jumps at the upper inversion
            ! Note the check to force jtbu to be greater than or equal
    ! to jbumin.

            jtzm = zm(kt-1) - zm(kt)
            jtsl = sl(kt-1) - sl(kt)
            jtqt = qt(kt-1) - qt(kt)
            jtbu = n2(kt)   * jtzm 
    jtbu = max(jtbu,jbumin)
    jtu  = u(kt-1) - u(kt)
            jtv  = v(kt-1) - v(kt)
            ch   = (1 -sfuh(kt))*chu(kt) + sfuh(kt)*chs(kt)
            cm   = (1 -sfuh(kt))*cmu(kt) + sfuh(kt)*cms(kt)
            n2h  = (ch*jtsl + cm*jtqt)/jtzm
            
    ! Ratio of buoy flux to w'(b_l)'
            vys  = n2h*jtzm/jtbu 
            
    ! Inverse of shear prodution divided by buoyancy production
            vus  = min(1.,(jtu**2+jtv**2)/(jtbu*jtzm)) 
            
    if (column_match) then
    write (dpu,'(a)')  ' '
    write (dpu,'(a)')  ' jumps at upper inversion '
    write (dpu,'(a)')  ' ------------------------ '
    write (dpu,'(a)')  ' '
    write (dpu,'(a,i3)')  ' inversion half level = ',kt
    write (dpu,'(a,f14.7,a)')  ' jtzm = ',jtzm,' m'
    write (dpu,'(a,f14.7,a)')  ' jtsl = ',jtsl/cp_air,' K'
    write (dpu,'(a,f14.7,a)')  ' jtqt = ',jtqt*1000.,' g/kg'
    write (dpu,'(a,f14.7,a)')  ' jtbu = ',jtbu,' m/s2'
    write (dpu,'(a,f14.7,a)')  ' jbumin = ',jbumin,' m/s2'
    write (dpu,'(a,f14.7,a)')  ' jtu = ',jtu,' m/s'
    write (dpu,'(a,f14.7,a)')  ' jtv = ',jtv,' m/s'
    write (dpu,'(a,f14.7,a)')  ' ch  = ',ch*cp_air, ' m/K/s2'
    write (dpu,'(a,f14.7,a)')  ' cm  = ',cm, ' m/s2'
    write (dpu,'(a,f14.7,a)')  ' sqrt(n2h) = ',n2h*            &
         sqrt(abs(n2h))*3600./abs(n2h),' 1/sec'
            write (dpu,'(a,f14.7,a)')  ' vys = ', vys
    write (dpu,'(a,f14.7,a)')  ' vus = ', vus
    write (dpu,'(a)')  ' '
    end if
        
            !-----------------------------------------------------------
    ! 
            ! Calculate evaporative entrainment enhancement factor evhc. 
            ! We take the full inversion strength to be jt2slv, where
    ! jt2slv = slv(kt-2)  - slv(kt), and kt - 1 is in the 
    ! ambiguous layer.  However, for a cloud-topped CL overlain
            ! by another convective layer, it is possible that 
    ! slv(kt-2) < slv(kt). To avoid negative or excessive evhc, 
    ! we lower-bound jt2slv and upper-bound evhc.

            evhc = 1.
    cloudtop  = .false. 
    if (ql(kt)  .gt. qcminfrac*qsl(kt)   .and. use_qcmin .and. &
        ql(kt-1).lt. qcminfrac*qsl(kt-1))       cloudtop= .true.
    if (.not.use_qcmin .and. qa(kt).gt.qa(kt-1))cloudtop= .true.
    
    if (cloudtop) then 
         if (use_qcmin) then
      tmpfrac = 1.
 else
      tmpfrac = 1. - (qa(kt-1)/qa(kt))
 end if     
                 jt2slv = slv(max(kt-2,1)) - slv(kt)
                 jt2slv = max(jt2slv, jbumin*slv(kt-1)/grav)
 if (use_extrapolated_ql) then
      evhc = 1.+tmpfrac*a2l*a3l*hleff(kt)*qltop(kt)/ &
           jt2slv
 else
                      evhc = 1.+tmpfrac*a2l*a3l*hleff(kt)*ql(kt)   / &
           jt2slv
                 end if
 evhc   = min(evhc,evhcmax)
 evhcvec(kt) = evhc
            end if

            if (column_match) then
         write (dpu,'(a)')  ' '
 write (dpu,'(a)')  ' computing entrainment enhancem'//&
                      'ent factor '
 write (dpu,'(a)')  ' '
 write (dpu,'(a)')  ' ' 
 write (dpu,'(a,f14.7,a)')  ' slv(max(kt-2,1))/cp_air =  ',&
                              slv(max(kt-2,1))/cp_air,' K'
 write (dpu,'(a,f14.7,a)')  ' slv(kt)/cp_air =  ', slv(kt)/&
      cp_air,' K'
 write (dpu,'(a,f14.7,a)')  ' jt2slv(kt)/cp_air =  ',jt2slv&
      /cp_air,' K'
 write (dpu,'(a,f14.7,a)')  ' ql(kt-1) = ',ql(kt-1)*   &
      1000.,' g/kg'
 write (dpu,'(a,f14.7,a)')  ' ql(kt) = ',ql(kt)*1000., &
      ' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' qltop(kt) = ',qltop(kt)* &
      1000.,' g/kg'
 write (dpu,'(a,f14.7,a)')  ' qa(kt-1) = ',qa(kt-1)
 write (dpu,'(a,f14.7,a)')  ' qa(kt) = ',  qa(kt)                    
 write (dpu,'(a,f14.7,a)')  ' evhc = ',evhc
            end if
    
            !-----------------------------------------------------------
    ! 
            ! Radiative forcing at the upper inversion if at a cloud top

            if (cloudtop) then
     
         !------------------------------------------------------
 !  estimate longwave opt depth in layer kt
                 
 lwp = ql(kt) * (pi(kt+1) - pi(kt)) / grav
         opt_depth = 156*lwp

                 !------------------------------------------------------
 ! Approximation to LW cooling frac at inversion
                 ! The following formula is a polynomial approximation
 ! to exact solution which is
 ! radinvfrac = 1 - 2/opt_depth + 2/(exp(opt_depth)-1))
 
                 radinvfrac  = opt_depth*(4.+opt_depth) / &
                               (6.*(4.+opt_depth) + opt_depth**2)

                 !------------------------------------------------------
 ! units of radf = (m*m)/(s*s*s)
                 radf = max(-radinvfrac*qrl(kt)*(zi(kt)-zi(kt+1)),0.)* &
                        cp_air * chs(kt)

            else
      lwp        = 0.
              opt_depth  = 0.
              radinvfrac = 0.
              radf       = 0.
            end if

            !-----------------------------------------------------------
    ! 
            ! Solve cubic equation
            !   r^3 + trmp*r + trmq = 0,   r = sqrt<e>
            ! to estimate <e> for multilayer convection. Note, that if 
    ! the CL goes to the surface, vyb and vub are zero, and ebrk
    ! and lbrk have already incorporated the surface interfacial
            ! layer, so the formulas below still apply.  For a SRCL, 
    ! there are no interior interfaces so ebrk = lbrk = 0.
            ! The cases are:
            !    (1) no cloudtop cooling (radf=0) -- trmq = 0, 
    !        r = sqrt(-trmp)
            !    (2) radf > 0 but no interior CL interface -- trmp = 0, 
    !        trmq < 0
            !    (3) radf > 0 and interior CL interface(s) -- trmp < 0, 
    !        trmq < 0

            trma = 1. - (b1*a1l/lbulk)*(evhc*(-vys+vus)*(zi(kt)-zm(kt))& 
              +  (-vyb+vub)*(zm(kb-1)-zi(kb)) )
            trma = max(trma,0.5)  ! Prevents runaway entrainment instab.
            trmp = -ebrk(ncv) *(lbrk(ncv)/lbulk)/trma
            trmq = -b1*radf*(leng(kt)/lbulk)*(zi(kt)-zm(kt))/trma

            qq = (trmp/3.)**3+(trmq/2.)**2
            if (trmq .lt. 0.) then
                 if (qq .gt. 0.) then 
                      rootp = (-trmq/2.+sqrt(qq))**(1./3.)
                      if (trmp .lt. 0.) then       
           !--------------------------------------------
           ! case 3 (in case 2, added term is zero)
                           rootp = rootp  + (-trmq/2.-sqrt(qq))**(1./3.)
                      end if
                 else  
      !-------------------------------------------------
      ! also part of case 3
                      angle = acos(-trmq/2./sqrt(-(trmp/3)**3))
                      rootp = 2.*sqrt(-trmp/3.)*cos(angle/3.)
                 end if
            else
         !------------------------------------------------------
 !  case 1: radf = 0, so trmq = 0
                 rootp = sqrt(-trmp)
            endif
          
            if (column_match) then
         write (dpu,'(a,f14.7)')  ' trma = ',trma
 write (dpu,'(a,f14.7,a)')  ' trmp = ',trmp,' m2/s2'
 write (dpu,'(a,f14.7,a)')  ' trmq = ',trmq,' m3/s3'
         write (dpu,'(a,f14.7,a)')  ' qq   = ',  qq,' m6/s6'
                 write (dpu,'(a,f14.7)')  ' b1   = ', b1
 write (dpu,'(a,f14.7)')  ' a1l  = ', a1l
 write (dpu,'(a,f14.7)')  ' vys  = ', vys
 write (dpu,'(a,f14.7)')  ' vus  = ', vus
 write (dpu,'(a,f14.7)')  ' vyb  = ', vyb
 write (dpu,'(a,f14.7)')  ' vub  = ', vub
 write (dpu,'(a,f14.7,a)') ' cwp  = ', 1000.*lwp,     &
       ' g/m2'
 write (dpu,'(a,f14.7)')  ' opt_depth  = ', opt_depth
 write (dpu,'(a,f14.7)')  ' radinvfrac = ',radinvfrac
 write (dpu,'(a,f14.7,a)')  ' radf = ', radf,' m2/s3' 
            end if
    
            !-----------------------------------------------------------
            ! limit CL-avg TKE used for entrainment
    
           ebrk(ncv) = rootp**2    
            ebrk(ncv) = max(min(ebrk(ncv),tkemax),tkemin) 
            wbrk(ncv) = ebrk(ncv)/b1

            if (column_match) then
         write (dpu,'(a,f14.7,a)')  ' rootp**2 = ',  rootp**2, &
      ' m2/s2'
 write (dpu,'(a,f14.7,a)')  ' ebrk     = ', ebrk(ncv), &
      ' m2/s2'
 write (dpu,'(a,f14.7,a)')  ' wbrk     = ', wbrk(ncv), &
      ' m2/s2'
            end if
     
            !-----------------------------------------------------------
    ! ebrk should be greater than zero so if it is not a FATAL
    ! call is implemented

            if (ebrk(ncv) .eq. 0.) then
         call error_mesg ('edt_mod', &
                  'convective layer average tke = 0',  &
   FATAL)
            end if
    
            !-----------------------------------------------------------
    ! Compute adjustment time for layer equal to lbulk / <e>
    ! Should this be divided by "c" = b1/mu, which for
    ! default value = 5.8/70 = 0.083
    
    do k = kb, kt, -1
                 adj_time_inv(k) = sqrt(ebrk(ncv))/lbulk
    enddo
    
    !-----------------------------------------------------------
    ! We approximate TKE = <e> at entrainment interfaces con-
    ! sistent with entrainment closure.
            
    rcap(kt) = 1.   
            rcap(kb) = 1.   

            !-----------------------------------------------------------
    ! Calculate ratio rcap = e/<e> in convective layer interior. 
    ! Bound it by limits rmin = 0.1 to rmax = 2.0 to take care 
    ! of some pathological cases.

            if ((kb-kt).gt.1) then
            do k = kb-1, kt+1, -1
                 rcap(k) = (mu*leng(k)/lbulk + wcap(k)/wbrk(ncv)) /    &
           (mu*leng(k)/lbulk + 1.               )
                 rcap(k) = min(max(rcap(k),rmin), rmax)
            end do
    end if
    
            !-----------------------------------------------------------
    ! Compute TKE throughout CL, and bound by tkemin & tkemax.
            !
    ! Question by Steve Klein:
    !
    ! Does tke(kb) properly account if kb is the top interface
    ! of another convective layer? 
    !
    
            do k = kb, kt, -1
                 tke(k) = max(min(ebrk(ncv)*rcap(k),tkemax),tkemin) 
            end do 
                        
            !-----------------------------------------------------------
    ! Compute CL interior diffusivities, buoyancy and shear 
    ! production
    
    if ((kb-kt).gt.1) then
    
                 do k = kb-1, kt+1, -1
            
              kvh(k)        = leng(k)*sqrt(tke(k))*shcl(ncv)
                      kvm(k)        = leng(k)*sqrt(tke(k))*smcl(ncv)
                      bprod(k)      = - kvh(k)*n2(k)
                      sprod(k)      =   kvm(k)*s2(k)
                      trans(k)      = mu*(ebrk(ncv)-tke(k))*           &
                      adj_time_inv(k)/b1 
                      diss(k)       = sqrt(tke(k)*tke(k)*tke(k))/b1/   &
                      leng(k)
                      shvec(k)      = shcl(ncv)
      smvec(k)      = smcl(ncv)
      ghvec(k)      = ghcl(ncv)
      
                      turbtype(2,k) = 1
      isturb(k)     = 1.
      isturb(k-1)   = 1.
  
                      !-------------------------------------------------
      ! compute sdevs
      ! 
      ! The approximation used is that qt and qs(Tl) are 
      ! correlated with strength kappa. The sign of the 
      ! correlation is positive if the vertical 
      ! gradients to qt and sli are of the same sign, 
      ! and negative otherwise.
 
      if (k .eq. kdim+1) call error_mesg ('edt_mod',   &
           'trying to compute sdevs at the surface',   &
                           FATAL)
      if (k .eq. 1)  call error_mesg ('edt_mod',       &
           'trying to compute sdevs at the model top', &
                           FATAL)
     
      qtsltmp    = (qt(k-1) - qt(k))/(zm(k-1) - zm(k))
      slsltmp    = (sl(k-1) - sl(k))/(zm(k-1) - zm(k))  
      qsltmp     = 0.5 * ( qsl    (k-1) + qsl    (k) )
      dqsldtltmp = 0.5 * ( dqsldtl(k-1) + dqsldtl(k) )   
      hlefftmp   = 0.5 * ( hleff  (k-1) + hleff  (k) )
     
                      sdevs(k) = ( (mesovar*qsltmp)**2.0) +            &
           ( ( (kvh(k)/sqrt(tke(k))) *                 &
  (qtsltmp-(kappa*slsltmp*dqsldtltmp/cp_air)))**2.0) 
                      sdevs(k) = sqrt(sdevs(k)) /                      &
                 (1.+hlefftmp*dqsldtltmp/cp_air)   
     
                      if (column_match) then
      write (dpu,'(a)')  ' ' 
              write (dpu,'(a)')  ' ' 
              write (dpu,'(a,i4)')  ' sigmas for level ',k
                      write (dpu,'(a)')  ' ' 
              write (dpu,'(a,f14.7,a)')  ' sigmas = ', 1000.*  &
           sdevs(k), ' g/kg'
                      write (dpu,'(a,f14.7)')  ' acoef = ', 1. /       &
           ( 1. + hlefftmp*dqsldtltmp/cp_air )
                      write (dpu,'(a,f14.7,a)')  ' sigmas/a = ',       &
           1000.*sdevs(k)*(1. +hlefftmp*dqsldtltmp/cp_air),&
   ' g/kg'
                      write (dpu,'(a,f14.7)'  )  ' mesovar = ', mesovar
                      write (dpu,'(a,f14.7,a)')  ' mesovar*qsl = ',    &
           mesovar*qsltmp*1000.,' g/kg'
                      write (dpu,'(a,f14.7,a)')  ' turb.fluct = ',1000.&
           *(kvh(k)/sqrt(tke(k)))*(qtsltmp-            &
   (kappa*slsltmp*dqsldtltmp/cp_air)) ,' g/kg'
                      write (dpu,'(a,f14.7,a)')  ' (kvh/sqrt(tke))* '//&
                           ' qtsltmp = ',1000.*(kvh(k)/sqrt(tke(k)))*  &
   qtsltmp ,' g/kg'
                      write (dpu,'(a,f14.7,a)')  ' (kvh/sqrt(tke))* '//&
                           ' (kappa*slsltmp*dqsldtltmp/cp_air) = ',1000.*  &
           (kvh(k)/sqrt(tke(k)))*(kappa*slsltmp*       &
   dqsldtltmp/cp_air) ,' g/kg'
                      write (dpu,'(a)')  ' '
                      write (dpu,'(a)')  ' '
                      end if
 
                 end do
    
    
         !------------------------------------------------------
         !
         ! set sdevs at kt and kb equal to kt+1 and kb-1 values 
         ! respectively
         !
   
         sdevs(kt) = sdevs(kt+1)
         sdevs(kb) = sdevs(kb-1)
    
    end if

            !-----------------------------------------------------------
    ! Compute diffusivity we*dz and some diagnostics at the 
    ! upper inversion. Limit entrainment rate below the free 
    ! entrainment limit a1l * sqrt(e)

            kentr          = jtzm * a1l * sqrt(ebrk(ncv)) * &
                             min(evhc * ebrk(ncv)/(jtbu*leng(kt)),1.)
            kvh(kt)        = kentr
            kvm(kt)        = kentr
            bprod(kt)      = -kentr*n2h+radf
            sprod(kt)      =  kentr*s2(kt)
            trans(kt)      = mu*(ebrk(ncv)-tke(kt))*adj_time_inv(kt)/b1
            diss(kt)       = sqrt(tke(kt)*tke(kt)*tke(kt))/b1/leng(kt)
    radfvec(kt)    = radf
            turbtype(4,kt) = 1
            isturb(kt)     = 1.
    
    !-----------------------------------------------------------
    ! set isturb to 1 in the ambiguous layer
    
    isturb(kt-1) = 1.

    if (column_match) then
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' at upper inversion: '
    write (dpu,'(a,f14.7,a)')  ' kentr = ', kentr, ' m2/s'
    write (dpu,'(a,f14.7)')  ' mu    = ', mu
            write (dpu,'(a,f14.7,a)')  ' 1/adj_time_inv = ',           &
         1./adj_time_inv(kt), ' sec'
            write (dpu,'(a)')  ' '
            end if
      
    !-----------------------------------------------------------
            ! compute sdevs at CL top
    !
    ! FOR SOME REASON THIS DERIVATION DOES NOT WORK
    !
    ! note that a water perturbation q* and buoyancy 
    ! perturbation b* are computed from the below equations:
    !
    !      q*   =    (w'qt') / sqrt(tke)
    !           =   - kentr * (dqt/dz) / sqrt(tke)
    !
    !      b*   =    (w'b')  / sqrt(tke)
    !           =    bprod   / sqrt(tke)
    !
            !
            
    qtsltmp     = (qt(kt-1) - qt(kt))/(zm(kt-1) - zm(kt)) 
            qstartmp    =  - kentr * qtsltmp / sqrt(tke(kt))
            bstartmp    =    bprod(kt)       / sqrt(tke(kt)) 
    temperature = pm(kt)/density(kt)/rdgas
    
    !sdevs(kt)   =  ((mesovar*qsl(kt))**2.0) +       &
    !     ((qstartmp-dqsldtl(kt)*bstartmp*temperature/grav)**2.0)
            !sdevs(kt) = sqrt(sdevs(kt))/(1.+hleff(kt)*dqsldtl(kt)/cp_air)
    
    
            if ((kb-kt).le.1) sdevs(kt) = mesovar*qsl(kt)/             &
                          (1.+hleff(kt)*dqsldtl(kt)/cp_air)
   

            if (column_match) then
            write (dpu,'(a)')  ' ' 
    write (dpu,'(a)')  ' ' 
    write (dpu,'(a,i4)')  ' sigmas at kt level # ',kt
            write (dpu,'(a)')  ' ' 
    write (dpu,'(a,f14.7,a)')  ' sigmas = ', 1000.*sdevs(kt),  &
         ' g/kg'
            write (dpu,'(a,f14.7)')    ' acoef = ', 1. /(1.+hleff(kt)* &
         dqsldtl(kt)/cp_air )                      
    write (dpu,'(a,f14.7,a)')  ' sigmas/a = ', 1000.*sdevs(kt)*&
 ( 1. + hleff(kt)*dqsldtl(kt)/cp_air ), ' g/kg'
            write (dpu,'(a,f14.7)'  )  ' mesovar = ', mesovar
            write (dpu,'(a,f14.7,a)')  ' mesovar*qsl = ',mesovar*      &
         qsl(kt)*1000.,' g/kg'
            write (dpu,'(a,f14.7,a)')  ' turb.fluct = ',1000.* &
 (qstartmp-dqsldtl(kt)*bstartmp*temperature/grav) ,    &
 ' g/kg'
            write (dpu,'(a,f14.7,a)')  ' temperature = ',temperature,  &
         ' K'
            write (dpu,'(a,f14.7,a)')  ' qstartmp = ',1000.*qstartmp , &
         ' g/kg'
            write (dpu,'(a,f14.7,a)')  ' bstartmp = ',bstartmp ,' m/s2'
            write (dpu,'(a,f14.7,a)')  ' jtbu = ',jtbu ,' m/s2'
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            end if
                          
            !-----------------------------------------------------------
    ! Compute Kh, Km and some diagnostics at the lower inversion

            if (kb .lt. kdim+1) then 
          
         kentr        = jbzm * a1l * sqrt(ebrk(ncv)) * &
                                min(ebrk(ncv)/(jbbu*leng(kb)),1.)

 !------------------------------------------------------
         ! The addition of the previous value of kvh and khm 
 ! handles the case of 2 CLs entraining into each other
                 kvh(kb)      = kentr + kvh(kb)   
                 kvm(kb)      = kentr + kvm(kb)   
 
                 bprod(kb)    = bprod(kb) - kvh(kb)*n2(kb)
                 sprod(kb)    = sprod(kb) + kvm(kb)*s2(kb)
                 trans(kb)    = trans(kb) + mu*(ebrk(ncv)-tke(kb))*    &
                adj_time_inv(kb)/b1
 diss(kb)     = diss(kb)+sqrt(tke(kb)*tke(kb)*tke(kb)) &
                /b1/leng(kb)
                             
 turbtype(3,kb) = 1
                 isturb(kb-1)   = 1.

                 !------------------------------------------------------
         ! set isturb to 1 in the ambiguous layer
         
 isturb(kb) = 1.

         if (column_match) then
                 write (dpu,'(a)')  ' '
                 write (dpu,'(a)')  ' at lower inversion: '
         write (dpu,'(a,f14.7,a)')  ' kentr = ', kentr, ' m2/s'
         write (dpu,'(a,f14.7)')  ' mu    = ', mu
                 write (dpu,'(a,f14.7,a)')  ' adj_time_inv = ',        &
      1./adj_time_inv(kb), ' sec'
                 write (dpu,'(a)')  ' '
                 end if
    
         !------------------------------------------------------
                 ! compute sdevs at CL bottom
         !
 ! note that same formulas are used here as for CL top
   
                 qtsltmp     = (qt(kb-1) - qt(kb))/(zm(kb-1) - zm(kb)) 
                 qstartmp    =  - kentr * qtsltmp / sqrt(tke(kb))
                 bstartmp    =    bprod(kb)       / sqrt(tke(kb)) 
         temperature = pm(kb-1)/density(kb-1)/rdgas
 
         !sdevs(kb)   = ((mesovar*qsl(kb-1))**2.0) + ((qstartmp-&
 !              dqsldtl(kb-1)*bstartmp*temperature/grav)&
 !       **2.0)
                 !sdevs(kb)   = sqrt(sdevs(kb))/(1.+hleff(kb-1)*        &
 !                               dqsldtl(kb-1)/cp_air)
                         
                 if ((kb-kt).le.1) sdevs(kb) = mesovar*qsl(kb-1)/       &
                        (1.+hleff(kb-1)*dqsldtl(kb-1)/cp_air)

                 if (column_match) then
                 write (dpu,'(a)')  ' ' 
         write (dpu,'(a)')  ' ' 
         write (dpu,'(a,i5)')  ' sigmas at lower inversion l'//&
                      'evel # ',kb
                 write (dpu,'(a)')  ' ' 
 write (dpu,'(a,f14.7,a)')  ' sigmas = ', 1000.*       &
      sdevs(kb), ' g/kg'
                 write (dpu,'(a,f14.7)  ')  ' acoef = ', 1. /(1.+      &
      hleff(kb-1)*dqsldtl(kb-1)/cp_air )                         
         write (dpu,'(a,f14.7,a)')  ' sigmas/a = ', 1000.*     &
      sdevs(kb)*( 1. + hleff(kb-1)*dqsldtl(kb-1)/cp_air ), &
      ' g/kg'
                 write (dpu,'(a,f14.7)'  )  ' mesovar = ', mesovar
                 write (dpu,'(a,f14.7,a)')  ' mesovar*qsl = ',mesovar* &
      qsl(kb-1)*1000.,' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' turb.fluct = ',1000.*    &
      (qstartmp-dqsldtl(kb-1)*bstartmp*temperature/    &
      grav) , ' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' temperature = ',         &
      temperature,' K'
                 write (dpu,'(a,f14.7,a)')  ' qstartmp = ',1000.*      &
      qstartmp ,' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' bstartmp = ',bstartmp ,  &
      ' m/s2'
                 write (dpu,'(a,f14.7,a)')  ' jbbu = ',jbbu ,' m/s2'
                 write (dpu,'(a)')  ' '
                 write (dpu,'(a)')  ' '
                 end if

    end if

            !-----------------------------------------------------------
    ! put minimum threshold on TKE to prevent possible division 
    ! by zero.

            if (kb .lt. kdim+1) then
                 wcap(kb) = bprod(kb)*leng(kb)/sqrt(max(tke(kb),tkemin))
            else
                 wcap(kb) = tkes / b1
            end if
            wcap(kt) = bprod(kt)*leng(kt) / sqrt(max(tke(kt),tkemin))

            if (column_match) then
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  'k     leng     rcap     wcap      tk'//&
                 'e'
            write (dpu,'(a)')  '      (m)              (m2/s2)   (m2'//&
                 '/s2)'
            write (dpu,'(a)')  '------------------------------------'//&
                 '----'
            write (dpu,'(a)')  ' '
            do k = kb,kt,-1
            write(dpu,34) k,leng(k),rcap(k),wcap(k),tke(k)
            enddo  
34          format(1X,i2,1X,4(f8.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k     kvh      kvm      bprod      '//&
                 '  sprod         trans         diss'
            write (dpu,'(a)')  '      (m2/s)   (m2/s)   (m2/s3)     '//&
                 ' (m2/s3)       (m2/s3)      (m2/s3)'
            write (dpu,'(a)')  '------------------------------------'//&
                 '-------------------------------------'
            write (dpu,'(a)')  ' '
            do k = kb,kt,-1
            write(dpu,35) k,kvh(k),kvm(k),bprod(k),sprod(k),trans(k),  &
         diss(k)
            enddo  
35          format(1X,i2,1X,2(f8.4,1X),4(f12.9,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            end if
                 
       !----------------------------------------------------------------
       ! End big loop over ncv
 
       end do      

!-----------------------------------------------------------------------
!
!      If the lowest CL reaches the surface, define the PBL 
!      depth as the CL top.
!
       if (ncvsurf .gt. 0) then
            pblh   = zi(ktop(ncvsurf))
    if(bflxs.ge.0.) then
                 turbtype(2,kdim+1) = 1
            else
                 turbtype(3,kdim+1) = 1
            end if
       else
            pblh = 0.
       end if
                        
       
!-----------------------------------------------------------------------
!
!      STABLE TURBULENT LAYERS
!

       !----------------------------------------------------------------
       ! find turbulent lengthscales in all stable turbulent layers

       belongst(1) = .false.   ! k = 1 assumed nonturbulent
       
       any_stable  = .false.
       
       do k = 2, kdim
         
  belongst(k)  = (ri(k) .lt. ricrit) .and. (.not. belongcv(k))
  if (belongst(k)) any_stable = .true.
          if (belongst(k) .and. (.not.belongst(k-1)) ) then
                 kt    = k     ! Top of stable turb layer
          else if (.not. belongst(k) .and. belongst(k-1)) then
                 kb    = k-1   ! Base of stable turb layer
                 lbulk = zm(kt-1) - zm(kb)
                 do ks = kt, kb
                      leng(ks)=lengthscale(zi(ks),lbulk)
      adj_time_inv(ks) = 1. / lbulk
                 end do
          end if
  
       end do ! k

       !----------------------------------------------------------------
       ! Now look whether stable turb layer extends to ground. Note that 
       ! interface kdim+1 is assumed to always be stable-turbulent if it 
       ! is not convective. Note that if it is convective, kdim will 
       ! also be convective, so the above loop will have finished 
       ! finding all elevated turbulent layers.

       belongst(kdim+1) = .not. belongcv(kdim+1)
       
       if (belongst(kdim+1)) then  
      
            turbtype(1,kdim+1) = 1
    if (belongst(kdim)) then
 !------------------------------------------------------
         ! surface stable layer includes interior stable turb-
 ! ulent interface kt already defined above. Note that
 ! zm(kb) = 0.
                 lbulk = zm(kt-1)     
            else                     
         !------------------------------------------------------
         ! surface stable BL with no interior turbulence            
         kt = kdim+1 
    end if
    lbulk  = zm(kt-1)
            pblh   = lbulk   ! PBL Height <-> lowest stable turb. layer            
    do ks = kt,kdim+1
                 leng(ks) = lengthscale(zi(ks),lbulk)
 adj_time_inv(ks) = 1./ lbulk
            end do 
            adj_time_inv(kdim+1) = adj_time_inv(kdim+1)*sqrt(tkes)
       end if  ! for belongst if

       !----------------------------------------------------------------
       ! Calculate tke, kvh, kvm

       if (column_match .and. any_stable) then
            write (dpu,'(a)')  ' '
    write (dpu,'(a)')  ' STABLE LAYERS '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k     kvh      kvm      leng      t'//&
                 'ke      bprod        sprod        diss'
            write (dpu,'(a)')  '      (m2/s)    (m2/s)    (m)    (m2'//&
                 '/s2)   (m2/s3)      (m2/s3)      (m2/s3) '
            write (dpu,'(a)')  '------------------------------------'//&
                 '-----------------------------------------'
            write (dpu,'(a)')  ' '            
       end if

       do k = 2, kdim
       
            if (belongst(k)) then    
                 
                 turbtype(1,k) = 1
 isturb(k)     = 1.
 isturb(k-1)   = 1.
 
 call galperin(ri(k),gh,ckh,ckm)
 
 ! note that original cb code did not limit the maximum
 ! gh to 0.0233 so that we should check that if the  
 ! limiter was invoked
!!RSH drop this fail for now (maybe ok during early spinup ?? )
!                  if (gh .eq. 0.0233) call error_mesg ('edt_mod',&
!                    'galperin stability fn = 0.0233',&
!                                      FATAL)
       
                 ! ri(k) should be less than ricrit     
 if (ri(k) .gt. ricrit) call error_mesg ('edt_mod',&
      'ri(k) > ricrit, but belongst(k) = T',FATAL)
 
         tke(k) = b1*(leng(k)**2)*(-ckh*n2(k)+ckm*s2(k))
                 tke(k) = max(min(tke(k),tkemax),tkemin)
                 kvh(k) = leng(k) * sqrt(tke(k)) * ckh
                 kvm(k) = leng(k) * sqrt(tke(k)) * ckm
                 bprod(k)  = - kvh(k)*n2(k)
                 sprod(k)  =   kvm(k)*s2(k)
                 diss (k)  = sqrt(tke(k)*tke(k)*tke(k))/b1/leng(k)
 adj_time_inv(k) = adj_time_inv(k)*sqrt(tke(k))
                 shvec(k)  = ckh
 smvec(k)  = ckm
                 ghvec(k)  = gh
   
                 if (column_match) then         
                 write(dpu,37) k,kvh(k),kvm(k),leng(k),tke(k),bprod(k),&
                sprod(k),diss(k)
37               format(1X,i2,1X,3(f8.4,1X),4(f12.9,1X))
                 end if

                 !------------------------------------------------------
 ! compute sdevs 
 ! (note same formulas as used in CL calculations)
 ! 
 
 if (k .eq. kdim+1)  call error_mesg ('edt_mod',       &
      'trying to compute sdevs at the surface', FATAL)
 if (k .eq. 1)       call error_mesg ('edt_mod',       &
      'trying to compute sdevs at the model top', FATAL)
     
 qtsltmp    = (qt(k-1) - qt(k))/(zm(k-1) - zm(k))
 slsltmp    = (sl(k-1) - sl(k))/(zm(k-1) - zm(k))  
 qsltmp     = 0.5 * ( qsl    (k-1) + qsl    (k) )
 dqsldtltmp = 0.5 * ( dqsldtl(k-1) + dqsldtl(k) )   
 hlefftmp   = 0.5 * ( hleff  (k-1) + hleff  (k) )
     
                 sdevs(k) = ( (mesovar*qsltmp)**2.0) +                 &
            ( (  (kvh(k)/sqrt(tke(k))) *               &
      (qtsltmp-(kappa*slsltmp*dqsldtltmp/cp_air)) )&
    **2.0) 
                 sdevs(k) = sqrt(sdevs(k)) / (1.+hlefftmp*dqsldtltmp/cp_air)   

                 if (column_match) then
 write (dpu,'(a)')  ' ' 
         write (dpu,'(a)')  ' ' 
         write (dpu,'(a)')  ' sigmas  .... '
                 write (dpu,'(a)')  ' ' 
         write (dpu,'(a,f14.7,a)')  ' sigmas = ',1000.*sdevs(k)&
      , ' g/kg'
                 write (dpu,'(a,f14.7)  ')  ' acoef = ', 1. / ( 1. +   &
      hlefftmp*dqsldtltmp/cp_air )
                 write (dpu,'(a,f14.7,a)')  ' sigmas/a = ', 1000.*     &
      sdevs(k)* ( 1. + hlefftmp*dqsldtltmp/cp_air ), ' g/kg'
                 write (dpu,'(a,f14.7)'  )  ' mesovar = ', mesovar
                 write (dpu,'(a,f14.7,a)')  ' mesovar*qsl = ',mesovar* &
      qsltmp*1000.,' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' turb.fluct = ',1000.*    &
      (kvh(k)/sqrt(tke(k)))*(qtsltmp-(kappa*slsltmp*   &
      dqsldtltmp/cp_air)) ,' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' (kvh/sqrt(tke))*qtsltm'//&
                      'p = ',1000.*(kvh(k)/sqrt(tke(k)))*qtsltmp ,     &
      ' g/kg'
                 write (dpu,'(a,f14.7,a)')  ' (kvh/sqrt(tke))*(kappa'//&
                      '*slsltmp*dqsldtltmp/cp_air) = ',1000.*(kvh(k)/sqrt  &
      (tke(k)))*(kappa*slsltmp*dqsldtltmp/cp_air),' g/kg'
                 write (dpu,'(a)')  ' '
                 write (dpu,'(a)')  ' '
                 end if
  

            end if  ! belongs to stable layer
            
       end do  ! k loop

!-----------------------------------------------------------------------
! 
!      set tke at surface equal to diagnostic variable tkes

       tke(kdim+1) = tkes

       if (column_match) then
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)')  ' pblh = ', pblh, ' m'
       write (dpu,'(a,f14.7,a)')  ' tkes = ', tkes, ' m2/s2'
       write (dpu,'(a)')  ' '
       do k = kdim-n_print_levels,kdim
            write (dpu,'(a,i4,a,f14.7)') 'k = ',k,'; isturb =',isturb(k)
       enddo
       write (dpu,'(a)')  ' '
       end if
       
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine caleddy

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


!======================================================================= 
!
!      subroutine galperin
!        
      
subroutine galperin(ricl,gh,sh,sm)
        
!
!-----------------------------------------------------------------------
!
!      Given a Richardson number ricl, return the stability functions
!      sh and sm calculated according Galperin (1982).
!
!----------------------------------------------------------------------- 
!----------------------------------------------------------------------- 
!
!
  
real, intent(in)  :: ricl
real, intent(out) :: gh, sh, sm
  
! internal variables

real              :: ri, trma, trmb, trmc, det

!-----------------------------------------------------------------------
!
!      code
!

       ri   = min(ricl,0.163)
       trma = alph3*alph4*ri+2.*b1*(alph2-alph4*alph5*ri)
       trmb = ri*(alph3+alph4)+2.*b1*(-alph5*ri+alph1)
       trmc = ri
       det = max(trmb*trmb-4.*trma*trmc,0.)
       gh = (-trmb + sqrt(det))/2./trma
       gh = max(gh,-0.28)
       gh = min(gh,0.0233)
       sh = alph5 / (1.+alph3*gh)
       sm = (alph1 + alph2*gh)/(1.+alph3*gh)/(1.+alph4*gh)
          
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine galperin

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


!======================================================================= 
!
!      function lengthscale
!        
      
function lengthscale(height,depth)
        
!
!-----------------------------------------------------------------------
!
!      Calculate the turbulent length scale given the depth of the
!      turbulent layer.  Near the surface, the lengthscale asymptotes
!      to vonkarm*height.
!
!----------------------------------------------------------------------- 
!----------------------------------------------------------------------- 
!
!
 
real              :: lengthscale 
real, intent(in)  :: height,depth

!-----------------------------------------------------------------------
!
!      code
!

       lengthscale = vonkarm*height/(1.+(vonkarm*height/(tunl*depth)))       
          
!-----------------------------------------------------------------------
! 
!      function end
!

end function lengthscale

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

!======================================================================= 
!
!      subroutine gaussian_cloud
!        
!
!      this subroutine computes a new cloud fraction and cloud conden-
!      sate using the Gaussian cloud modell of Mellor (1977) and
!      Sommeria and Deardorff (1977). 
!        
!      In this derivation a background mesoscale variability to total
!      water variability equivalent to a fraction, mesovar, of qsl is 
!      assumed.
!

subroutine gaussian_cloud (qxtop, qxmid, qxbot, acoef, sigmasf, qalyr, &
                           qclyr, sfuh,  sflh)
 
!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
!
!      qxtop      saturation excess at the top of the layer 
!                 (kg wat/kg air)
!      qxmid      saturation excess at the midpoint of the layer 
!                 (kg wat/kg air)
!      qxbot      saturation excess at the bottom of the layer 
!                 (kg wat/kg air)
!      sigmasf    standardard devations of water perturbation s
!                 (kg water / kg air)
!      acoef      thermo coefficient = 1./(1.+ L*dqsdT/cp)
!
!      ------
!      output
!      ------
!
!      qalyr      layer mean cloud fraction  (fraction)
!      qclyr      layer mean cloud condensate (kg condensate/kg air)
!      sfuh       saturated fraction of the upper half of the layer
!      sflh       saturated fraction of the lower half of the layer                  
!
!      --------
!      internal
!      --------
!
!
!-----------------------------------------------------------------------

real,    intent(in) :: qxtop, qxmid, qxbot, acoef, sigmasf
real,    intent(out):: qalyr, qclyr, sfuh, sflh

real :: q1top,q1mid,q1bot,cftop,cfmid,cfbot,qctop,qcmid,qcbot
real :: qcuh,qclh

!-----------------------------------------------------------------------
!
!      initialize variables


       qalyr    = 0.0
       qclyr    = 0.0
       sfuh     = 0.0
       sflh     = 0.0
       q1top    = 0.0
       q1mid    = 0.0
       q1bot    = 0.0
       cftop    = 0.0
       cfmid    = 0.0
       cfbot    = 0.0
       qctop    = 0.0
       qcmid    = 0.0
       qcbot    = 0.0
       qcuh     = 0.0
       qclh     = 0.0
               
       
!-----------------------------------------------------------------------
!
!      compute cloud fraction and cloud condensate at layer top, 
!      midpoint and bottom

       q1top = acoef * qxtop / sigmasf 
       cftop = max ( 0.5 * ( 2. -  erfcc( q1top / sqrt(2.) ) ) , 0.0 )
       qctop = cftop * q1top + ( exp(-0.5*q1top*q1top) / sqrt(2*fpi) )
       qctop = sigmasf * max ( qctop, 0. )  
     
       q1mid = acoef * qxmid / sigmasf  
       cfmid = max ( 0.5 * ( 2. -  erfcc( q1mid / sqrt(2.) ) ) , 0.0 )
       qcmid = cfmid * q1mid + ( exp(-0.5*q1mid*q1mid) / sqrt(2*fpi) )
       qcmid = sigmasf * max ( qcmid, 0. )   
       
       q1bot = acoef * qxbot / sigmasf  
       cfbot = max ( 0.5 * ( 2. -  erfcc( q1bot / sqrt(2.) ) ) , 0.0 )
       qcbot = cfbot * q1bot + ( exp(-0.5*q1bot*q1bot) / sqrt(2*fpi) )
       qcbot = sigmasf * max ( qcbot, 0. ) 
       
       sfuh  = 0.5 * (cftop + cfmid)
       sflh  = 0.5 * (cfmid + cfbot)
       qcuh  = 0.5 * (qctop + qcmid)
       qclh  = 0.5 * (qcmid + qcbot)
       qalyr = 0.5 * ( sfuh + sflh )
       qclyr = 0.5 * ( qcuh + qclh )

       if (qalyr .lt. qcminfrac) then
            qalyr = 0.
    qclyr = 0.
       end if

       if (column_match) then

       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' ========================================'//&
            '======= '
       write (dpu,'(a)')  '             GAUSSIAN CLOUD MODEL         '
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)')  ' sigmas = ', 1000.*sigmasf, ' g/kg'
       write (dpu,'(a,f14.7)'  )  ' acoef  = ', acoef
       write (dpu,'(a,f14.7,a)')  ' qxtop = ', qxtop*1000.,' g/kg'
       write (dpu,'(a,f14.7)')    ' q1top = ', q1top
       write (dpu,'(a,f14.7)')    ' cftop = ', cftop
       write (dpu,'(a,f14.7,a)')  ' qctop = ', 1000.*qctop,' g/kg'
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)')  ' qxmid = ', qxmid*1000.,' g/kg'
       write (dpu,'(a,f14.7)')    ' q1mid = ', q1mid
       write (dpu,'(a,f14.7)')    ' cfmid = ', cfmid
       write (dpu,'(a,f14.7,a)')  ' qcmid = ', 1000.*qcmid,' g/kg'
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7,a)')  ' qxbot = ', qxbot*1000.,' g/kg'
       write (dpu,'(a,f14.7)')    ' q1bot = ', q1bot
       write (dpu,'(a,f14.7)')    ' cfbot = ', cfbot
       write (dpu,'(a,f14.7,a)')  ' qcbot = ', 1000.*qcbot,' g/kg'
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7)')    ' sfuh = ', sfuh
       write (dpu,'(a,f14.7)')    ' sflh = ', sflh
       write (dpu,'(a,f14.7,a)')  ' qcuh = ', 1000.*qcuh, ' g/kg'
       write (dpu,'(a,f14.7,a)')  ' qclh = ', 1000.*qclh, ' g/kg'
       write (dpu,'(a)')  ' '
       write (dpu,'(a,f14.7)')    ' qalyr = ', qalyr
       write (dpu,'(a,f14.7,a)')  ' qclyr = ', 1000.*qclyr, ' g/kg'
       write (dpu,'(a)')  ' '
       write (dpu,'(a)')  ' '
       end if    
      
       
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine gaussian_cloud

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


!======================================================================= 
!
!      function erfcc
!        
      
function erfcc(x)
        
!
!-----------------------------------------------------------------------
!
!      This numerical recipes routine calculates the complementary
!      error function.
!
!----------------------------------------------------------------------- 
!----------------------------------------------------------------------- 
!
!
 
real :: erfcc
real, intent(in) :: x 
real :: t,z


!-----------------------------------------------------------------------
!
!      code
!

       z=abs(x)      
       t=1./(1.+0.5*z)
      
       erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t*       &
            (.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t*    &
            (1.48851587+t*(-.82215223+t*.17087277)))))))))
  
       if (x.lt.0.) erfcc=2.-erfcc
      
!-----------------------------------------------------------------------
! 
!      function end
!

end function erfcc

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

end module edt_mod


!FDOC_TAG_GFDL
module entrain_mod
! <CONTACT EMAIL="Stephen.Klein@noaa.gov">
!   Stephen Klein
! </CONTACT>
! <REVIEWER EMAIL="reviewer_email@gfdl.noaa.gov">
!   none
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!
!      K-PROFILE BOUNDARY LAYER SCHEME WITH CLOUD TOP ENTRAINMENT
!
!
!      This routine calculates diffusivity coefficients for vertical
!      diffusion using a K-profile approach.  This scheme is modelled
!      after:
!
!      Lock, A.P., A.R. Brown, M.R. Bush, G.M. Martin, and R.N.B. Smith, 
!          2000: A new boundary layer mixing scheme. Part I: Scheme 
!          description and single-column modeling tests. Mon. Wea. Rev.,
!          128, 3187-3199.
!
!   
! </OVERVIEW>
! <DESCRIPTION>
!
!      The key part is the parameterization of entrainment at the top
!      convective layers. For an entrainment interface from surface
!      driven mixing, the entrainment rate, we, is parameterized as:
!
!                      
!      we, surf =  A / B
!
!      where A = ( beta_surf * (V_surf**3 + V_shear**3) / zsml )
!        and B = ( delta_b   + ((V_surf**3 + V_shear**3)**(2/3))/zsml )
!
!
!      In this formula,
!
!           zsml     =  depth of surface mixed layer
!
!           V_surf   =  surface driven scaling velocity
!                    =  (u_star*b_star*zsml)**(1/3)
!
!           V_shear  =  surface driven shear velocity,
!                    =  (Ashear**(1/3))*u_star
!
!           delta_b  =  buoyancy jump at the entrainment interface(m/s2)
!                    =  grav * delta_slv / slv
!
!      If an entrainment interface is associated only with cloud top
!      radiative cooling, the entrainment rate is parameterized as:
!
!
!                     
!      we, rad  =  ( A / B)
!
!            where A = beta_rad  *  V_rad**3 /  zradml
!              and B = delta_b   +  V_rad**2 /  zradml
!
!      where
!
!           zradml   =  depth of radiatively driven layer
!
!           V_rad    =  radiatively driven scaling velocity
!                    =  (grav*delta-F*zradml/(rho*cp_air*T)) **(1/3)
!                 
!
!      Note that the source of entrainment from cloud top buoyancy
!      reversal has been omitted in this implementation.
!  
!      If the entrainment interface for surface driven mixing coincides
!      with that for cloud top radiatively driven convection then the
!      following full entrainment rate:
!
!                          
!      we, full =   A / B
!
!            where A =   V_full**3 / zsml
!              and B =  delta_b+((V_surf**3+V_shear**3+V_rad**3)**(2/3))/zsml
!              and V_full**3 = beta_surf*(V_surf**3+V_shear**3) + beta_rad*V_rad**3
!   
! </DESCRIPTION>
!

!-----------------------------------------------------------------------
!
! outside modules used
!

use      constants_mod, only: grav,vonkarm,cp_air,rdgas,rvgas,hlv,hls, &
                              tfreeze, radian 

use            mpp_mod, only: input_nml_file
use            fms_mod, only: open_file, file_exist, open_namelist_file, &
                              error_mesg, FATAL, check_nml_error, &
                              mpp_pe, mpp_root_pe, close_file,           &
                              stdlog, write_version_number

use   diag_manager_mod, only: register_diag_field, send_data
        
use   time_manager_mod, only: time_type, get_date, month_name
 
use sat_vapor_pres_mod, only: lookup_es, lookup_des

use  monin_obukhov_mod, only: mo_diff

implicit none
private

!-----------------------------------------------------------------------
!
!      public interfaces

public entrain, entrain_init, entrain_end, entrain_on

!-----------------------------------------------------------------------
!
!      set default values to namelist parameters       
!
real :: akmax       =  1.e4 ! maximum value for a diffusion coefficient 
                            ! (m2/s)
real :: wentrmax    =  0.05 ! maximum entrainment rate (m/s)
real :: parcel_buoy =  1.0  ! scaling factor for surface parcel buoyancy
real :: frac_inner  =  0.1  ! surface layer height divided by pbl height
real :: beta_surf   =  0.23 ! scaling of surface buoyancy flux for 
                            ! convective pbl entrainment
real :: Ashear      = 25.0  ! scaling of surface shear contribution to
                            ! entrainment
real :: beta_rad    =  0.23 ! entrainment scaling factor for radiative
                            ! cooling (from Lock et al. 2000)
real :: radfmin     = 30.   ! minimum radiative forcing for entrainment 
                            ! to be effective (W/m2)
real :: qdotmin     = 10.   ! minimum longwave cooling rate (K/day) for
                            ! entrainment to be effective, used only if
                            ! no layers were found using radfmin    
real :: radperturb  =  0.3  ! parcel perturbation looking for depth of
                            ! radiatively driven layer (K)
real :: critjump    =  0.3  ! critical jump for finding stable inter-
                            ! faces to bound convective layers, or to 
                            ! identify ambigous layers (K)
integer :: parcel_option = 1! Should the cloud top parcel property
                            ! be limited to the value of the level
                            ! below minus radperturb (option = 1) or 
                            ! the value of level below (option = 2)    
real :: zcldtopmax  =  3.e3 ! maximum altitude for cloud top of 
                            ! radiatively driven convection (m)    
real :: pr          =  0.75 ! prandtl # (k_m/k_t) for radiatively driven 
                            ! convection 
real :: qamin       =  0.3  ! minimum cloud fraction for cloud top 
                            ! radiative cooling entrainment and kprofile
                            ! from radiative cooling to occur
logical :: do_jump_exit = .true.
                            ! should an internal stable layer limit
                            ! the depth of the radiatively driven
                            ! convection?
logical :: apply_entrain = .true. 
                            ! logical controlling whether results of
                            ! of entrainment module are applied:
                            ! if F, then no diffusion coefficients 
                            ! from entrain_mod will be applied to
                            ! the actual diffusion coefficients;
                            ! i.e. the module is purely diagnostic
logical :: convect_shutoff = .false.
                            ! if surface based moist convection is   
                            ! occurring in the grid box, set entrainment
                            ! at top of surface mixed layer to zero

!-----------------------------------------------------------------------   
!
!  Stuff needed to write out extradiagnostics from a single point
!
    
integer, dimension(2) :: ent_pts = 0 ! the global indices for i,j
                                     ! at which diagnostics will 
                                     ! print out
logical   :: do_print = .false.      ! should selected variables 
                                     ! be sent to logfile
logical   :: column_match = .false.  ! should this column be printed 
                                     ! out?
integer   :: dpu = 0                 ! unit # for do_print output
integer   :: n_print_levels = 14     ! how many of the lowest levels 
                                     ! should be printed out
 

integer, parameter                 :: MAX_PTS = 20
integer, dimension (MAX_PTS)       :: i_entprt_gl=0, j_entprt_gl=0
real, dimension(MAX_PTS)           :: lat_entprt=999., lon_entprt=999.
integer                            :: num_pts_ij = 0
integer                            :: num_pts_latlon = 0

     
namelist /entrain_nml/ wentrmax, parcel_buoy, frac_inner, beta_surf,   &
                       Ashear, beta_rad, radfmin, qdotmin, radperturb, &
                       critjump, zcldtopmax, pr, qamin, parcel_option, &
                       do_jump_exit, convect_shutoff, apply_entrain,   &
                       ent_pts,  i_entprt_gl, j_entprt_gl, num_pts_ij, &
                       num_pts_latlon, lat_entprt, lon_entprt

integer     :: num_pts           !  total number of columns in which
                                 !  diagnostics are desired
       
!-----------------------------------------------------------------------
!    deglon1 and deglat1 are the longitude and latitude of the columns
!    at which diagnostics will be calculated (degrees).
!-----------------------------------------------------------------------
real,    dimension(:), allocatable  :: deglon1, deglat1
 
!-----------------------------------------------------------------------
!    iradprt and jradprt are the processor-based i and j coordinates 
!    of the desired diagnostics columns.
!-----------------------------------------------------------------------
integer, dimension(:), allocatable  :: j_entprt, i_entprt

!-----------------------------------------------------------------------
!    do_raddg is an array of logicals indicating which latitude rows
!    belonging to the processor contain diagnostics columns.
!-----------------------------------------------------------------------
logical, dimension(:), allocatable  :: do_ent_dg

!-----------------------------------------------------------------------
!
!      diagnostic fields       
!

character(len=10) :: mod_name = 'entrain'
real              :: missing_value = 0.
integer           :: id_wentr_rad, id_wentr_pbl, id_radf,id_parcelkick,&
                     id_k_t_entr,  id_k_m_entr,  id_k_rad,  id_zsml,   &             
                     id_vsurf,     id_vshear,    id_vrad,   id_zradml, &
                     id_k_t_troen, id_k_m_troen, id_radfq,  id_pblfq,  &
                     id_zradbase,  id_zradtop,   id_convpbl,id_radpbl, &
                     id_svpcp,     id_zinv,      id_fqinv,  id_invstr
     
!-----------------------------------------------------------------------
!
!      set default values to parameters       
!

logical         :: entrain_on = .false.
real, parameter :: small  = 1.e-4      
real, parameter :: d608 = (rvgas-rdgas)/rdgas

!-----------------------------------------------------------------------
!
! declare version number 
!

character(len=128) :: Version = '$Id: entrain.F90,v 18.0.2.2 2010/09/07 14:23:51 wfc Exp $'
character(len=128) :: Tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized = .false.      
!-----------------------------------------------------------------------
!
! Subroutines include:
!
!      entrain         main driver program of the module
!
!      entrain_init    initialization routine       
!
!      entrain_tend    adds in the longwave heating rate to the 
!                      global storage variable
!
!      entrain_end     ending routine
!
!      pbl_depth       routine to calculate the depth of surface driven
!                      mixed layer
!
!      radml_depth     subroutine to calculate the depth of the cloud
!                      topped radiatively driven mixed layer
!     
!      diffusivity_pbl subroutine to calculate diffusivity coefficients
!                      for surface driven mixed layer


contains



!======================================================================= 
!
! <SUBROUTINE NAME="entrain_init">
!  <OVERVIEW>
!
!      
!           
!  </OVERVIEW>
!  <DESCRIPTION>
!     This subroutine reads the namelist file, sets up individual 
!     points diagnostics if desired, and initializes netcdf output.
!  </DESCRIPTION>
!  <TEMPLATE>
!
!   call entrain_init(lonb, latb, axes,time,idim,jdim,kdim)
!
!  </TEMPLATE>
!  <IN NAME="lonb" TYPE="real">
!       2D array of model longitudes at cell corners (radians) 
!  </IN>
!  <IN NAME="latb" TYPE="real">
!       2D array of model latitudes at cell corners (radians)
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!       Integer arrary for axes used needed for netcdf diagnostics
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!       Time type variable used for netcdf diagnostics
!  </IN>
!  <IN NAME="idim" TYPE="integer">
!       Size of first (longitude) array dimension 
!  </IN>
!  <IN NAME="jdim" TYPE="integer">
!       Size of second (latitude) array dimension
!  </IN>
!  <IN NAME="kdim" TYPE="integer">
!       Size of third (vertical, full levels) array dimension
!  </IN>
! </SUBROUTINE>
!
subroutine entrain_init(lonb, latb, axes,time,idim,jdim,kdim)

!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
! 
!      idim,jdim,kdim    size of the first 3 dimensions 
!      axes, time        variables needed for netcdf diagnostics
!      latb, lonb        latitudes and longitudes at grid box corners
!
!
!      --------
!      internal
!      --------
! 
!      unit              unit number for namelist and restart file
!      io                internal variable for reading of namelist file
!      full              indices for full level axes coordinates
!      half              indices for half level axes coordinates
!
!-----------------------------------------------------------------------

integer,              intent(in) :: idim,jdim,kdim,axes(4)
type(time_type),      intent(in) :: time
real, dimension(:,:), intent(in) :: lonb, latb

integer                        :: unit,io,ierr
integer, dimension(3)          :: half = (/1,2,4/)
integer                        :: nn, i, j
real                           :: dellat, dellon

!-----------------------------------------------------------------------
!
!      namelist functions

#ifdef INTERNAL_FILE_NML
       read (input_nml_file, nml=entrain_nml, iostat=io)
       ierr = check_nml_error(io,"entrain_nml")
#else
       If (File_Exist('input.nml')) Then
            unit = Open_namelist_File ()
            ierr=1
            Do While (ierr .ne. 0)
                 Read  (unit, nml=entrain_nml, iostat=io, End=10)
                 ierr = check_nml_error (io, 'entrain_nml')
            EndDo
  10        Call Close_File (unit)
       EndIf
#endif

       if ( mpp_pe() == mpp_root_pe() ) then
            call write_version_number(Version, Tagname)
            unit = stdlog()
            Write (unit,nml=entrain_nml)
       endif

       
!-----------------------------------------------------------------------
!    allocate and initialize a flag array which indicates the latitudes
!    containing columns where radiation diagnostics are desired.
!-----------------------------------------------------------------------
      allocate (do_ent_dg (size(latb,2)-1) )
      do_ent_dg(:) = .false.

!-----------------------------------------------------------------------
!    define the total number of points at which diagnostics are desired.
!    points may be specified either by lat-lon pairs or by global index
!    pairs. 
!-----------------------------------------------------------------------
      num_pts = num_pts_latlon + num_pts_ij

!-----------------------------------------------------------------------
!    continue on only if diagnostics are desired in at least one column.
!-----------------------------------------------------------------------
      if (num_pts > 0) then

!-----------------------------------------------------------------------
!    if more points are desired than space has been reserved for, print 
!    a message.
!-----------------------------------------------------------------------
        if (num_pts > MAX_PTS) then
          call error_mesg ( 'entrain_mod', &
         'must reset MAX_PTS or reduce number of diagnostics points',  &
                                                             FATAL)
        endif

!-----------------------------------------------------------------------
!    allocate space for arrays which will contain the lat and lon and
!    processor-local i and j indices.
!-----------------------------------------------------------------------
        allocate ( deglon1 (num_pts))
        allocate ( deglat1 (num_pts))
        allocate ( j_entprt (num_pts))
        allocate ( i_entprt (num_pts))

!-----------------------------------------------------------------------
!    if any points for diagnostics are specified by (i,j) global 
!    indices, determine their lat-lon coordinates. assumption is made 
!    that the deltas of latitude and longitude are uniform over 
!    the globe.
!-----------------------------------------------------------------------
        do nn=1,num_pts_ij
          dellat = latb(1,2) - latb(1,1)
          dellon = lonb(2,1) - lonb(1,1)
          lat_entprt(nn + num_pts_latlon) =     &
                      (-0.5*acos(-1.0) + (j_entprt_gl(nn) - 0.5)*  &
                                           dellat) * radian
          lon_entprt(nn + num_pts_latlon) =                & 
                       (i_entprt_gl(nn) - 0.5)*dellon*radian
        end do

!-----------------------------------------------------------------------
!    determine if the lat/lon values are within the global grid,
!    latitude between -90 and 90 degrees and longitude between 0 and
!    360 degrees.
!-----------------------------------------------------------------------
        do nn=1,num_pts
          j_entprt(nn) = 0
          i_entprt(nn) = 0
          deglat1(nn) = 0.0
          deglon1(nn) = 0.0
          if (lat_entprt(nn) .ge. -90. .and. &
              lat_entprt(nn) .le.  90.) then
          else
            call error_mesg ('entrain_mod', &
                ' invalid latitude for entrain diagnostics ', FATAL)
          endif

          if (lon_entprt(nn) .ge. 0. .and. &
              lon_entprt(nn) .le. 360.) then
          else
            call error_mesg ('entrain_mod', &
                ' invalid longitude for entrain diagnostics ', FATAL)
          endif

!-----------------------------------------------------------------------
!    determine if the diagnostics column is within the current 
!    processor's domain. if so, set a logical flag indicating the
!    presence of a diagnostic column on the particular row, define the 
!    i and j processor-coordinates and the latitude and longitude of 
!    the diagnostics column.
!-----------------------------------------------------------------------
          do j=1,size(latb,2) - 1
            if (lat_entprt(nn) .ge. latb(1,j)*radian .and.   &
                lat_entprt(nn) .lt. latb(1,j+1)*radian) then
              do i=1,size(lonb,1) - 1
                if (lon_entprt(nn) .ge. lonb(i,1)*radian     &
                                  .and.&
                    lon_entprt(nn) .lt. lonb(i+1,1)*radian)  &
                                   then
                  do_ent_dg(j) = .true.
                  j_entprt(nn) = j
                  i_entprt(nn) = i
                  deglon1(nn) = 0.5*(lonb(1,i) + lonb(i+1,1))*  &
                                radian
                  deglat1(nn) = 0.5*(latb(1,j) + latb(j+1,1))*   &
                                radian
                  exit
                endif
              end do
              exit
            endif
          end do
        end do

!-----------------------------------------------------------------------
!    open a unit for the entrain diagnostics output.
!-----------------------------------------------------------------------
        dpu = open_file ('entrain.out', action='write', &
                                 threading='multi', form='formatted')
       do_print = .true.
       if ( mpp_pe() == mpp_root_pe() ) then
            call write_version_number(Version, Tagname, dpu)
            Write (dpu ,nml=entrain_nml)
       endif
      endif     ! (num_pts > 0)

!-----------------------------------------------------------------------
!
!      initialize entrain_on

       entrain_on = .TRUE.
       module_is_initialized = .true.

       
!-----------------------------------------------------------------------
!
! register diagnostic fields       

       id_zsml = register_diag_field (mod_name, 'zsml', axes(1:2),     &
            time, 'depth of surface well-mixed layer', 'meters',       &
            missing_value=missing_value )

       id_vsurf = register_diag_field (mod_name, 'vsurf',              &
            axes(1:2), time,                                           &
            'surface buoyancy velocity scale', 'meters per second',    &
            missing_value=missing_value )

       id_vshear = register_diag_field (mod_name, 'vshear',            &
            axes(1:2), time,                                           &
            'surface shear driven velocity scale', 'meters per second',&
             missing_value=missing_value )

       id_parcelkick = register_diag_field (mod_name, 'parcelkick',    &
            axes(1:2),time, 'surface parcel excess', 'K',              &
            missing_value=missing_value )

       id_wentr_pbl = register_diag_field (mod_name,'wentr_pbl',       &
            axes(1:2), time,                                           &
            'Entrainment velocity from surface buoyancy flux',         &
            'meters per second', missing_value=missing_value )
       
       id_wentr_rad = register_diag_field (mod_name, 'wentr_rad',      &
            axes(1:2), time,                                           &
            'Entrainment velocity from cloud top radiative cooling',   &
            'meters per second', missing_value=missing_value )
       
       id_convpbl = register_diag_field (mod_name, 'convpbl_fq',       &
            axes(1:2), time, 'Frequency of convective boundary layer', &
            'none')
       
       id_pblfq = register_diag_field (mod_name,'entr_pbl_fq',         &
            axes(half), time,                                          &
            'Frequency of surface driven entrainment turbulent layer', &
            'none')
       
       id_radfq = register_diag_field (mod_name, 'entr_rad_fq',        &
            axes(half), time,                                          &
           'Frequency of radiative driven entrainment turbulent layer',&
            'none')
       
       id_k_t_troen = register_diag_field (mod_name, 'k_t_troen',      &
            axes(half), time, 'Heat entrainment diffusivity from PBL', &
            'meters squared per second', missing_value=missing_value )
       
       id_k_m_troen = register_diag_field (mod_name, 'k_m_troen',      &
            axes(half), time,                                          &
            'Momentum entrainment diffusivity from PBL',               &
            'meters squared per second', missing_value=missing_value )
       
       id_svpcp = register_diag_field (mod_name, 'svpcp',              &
            axes(1:2), time,                                           &
            'Liquid water virtual potential temperature at cloud top', &
            'K',missing_value=missing_value )

       id_zradbase = register_diag_field (mod_name, 'zradbase',        &
            axes(1:2), time,                                           &
            'base of radiatively driven well-mixed layer', 'm',        &
            missing_value=missing_value )

       id_zradtop = register_diag_field (mod_name, 'zradtop',          &
            axes(1:2), time,                                           &
            'top of radiatively driven well-mixed layer', 'm',         &
            missing_value=missing_value )

       id_zradml = register_diag_field (mod_name, 'zradml',            &
            axes(1:2), time,                                           &
            'depth of radiatively driven well-mixed layer', 'm',       &
            missing_value=missing_value )

       id_radpbl = register_diag_field (mod_name, 'radpbl_fq',         &
            axes(1:2), time,                                           &
            'Frequency of radiatively driven turbulent layer',         &
            'none' )
       
       id_vrad = register_diag_field (mod_name, 'vrad',                &
            axes(1:2), time,                                           &
            'radiatively driven layer velocity scale',                 &
            'meters per second', missing_value=missing_value )

       id_k_rad = register_diag_field (mod_name, 'k_rad',              &
            axes(half), time,                                          &
            'diffusivity from cloud top radiative cooling',            &
            'meters squared per second', missing_value=missing_value )
       
       id_radf  = register_diag_field (mod_name, 'radf', axes(1:2),    &
            time, 'Longwave jump in cloud top radiation',              &
            'Watts/m**2', missing_value=missing_value )
 
       id_k_t_entr = register_diag_field (mod_name, 'k_t_entr',        &
            axes(half), time,                                          &
            'Heat diffusivity from entrainment module',                &
            'meters squared per second')
       
       id_k_m_entr = register_diag_field (mod_name, 'k_m_entr',        &
            axes(half), time,                                          &
            'Momentum diffusivity from entrainment module',            &
            'meters squared per second' )

       id_zinv = register_diag_field (mod_name, 'zinv',                &
            axes(1:2), time,                                           &
            'Altitude of strongest inversion at altitudes less '//     &
            'than 3000 m',   'm', missing_value=missing_value )

       id_invstr = register_diag_field (mod_name, 'invstr',            &
            axes(1:2), time,                                           &
            'Strength of strongest inversion at altitudes less '//     &
            'than 3000 m',   'K', missing_value=missing_value )

       id_fqinv = register_diag_field (mod_name, 'fqinv',              &
            axes(1:2), time,                                           &
            'Frequency of inversions at altitudes less than 3000 m',   &
            'fraction', missing_value=missing_value )
              
                        
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine entrain_init

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




!======================================================================= 
!
!      subroutine entrain
!        

! <SUBROUTINE NAME="entrain">
!  <OVERVIEW>
!   
!      
!  </OVERVIEW>
!  <DESCRIPTION>
!      This is the main subroutine which takes in the state of the
!      atmosphere and returns vertical diffusion coefficients for
!      convective turbulent layers.  (Stable turbulent layers are
!      handled by stable_bl_turb.f90 in AM2)
!
!  </DESCRIPTION>
!  <TEMPLATE>
!   call entrain(is,ie,js,je,time, tdtlw_in, convect,u_star,b_star,             &
!               t,qv,ql,qi,qa,u,v,zfull,pfull,zhalf,phalf,          
!               diff_m,diff_t,k_m_entr,k_t_entr,use_entr,zsml,      
!               vspblcap,kbot)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      Indice of starting point in the longitude direction of the slab being passed to entrain
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!      Indice of ending point in the longitude direction of the slab being passed to entrain  
!  </IN>
!  <IN NAME="js" TYPE="integer">
!      Indice of starting point in the latitude direction of the slab being passed to entrain
!  </IN>
!  <IN NAME="je" TYPE="integer">
!      Indice of ending point in the latitude direction of the slab being passed to entrain 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!      Time of the model: used for netcdf diagnostics
!  </IN>
!  <IN NAME="tdtlw_in" TYPE="real">
!      Longwave cooling rate (from the radiation scheme) (K/sec)
!  </IN>
!  <IN NAME="convect" TYPE="logical">
!      Is surface based convection occurring in this grid box at this time? (from convection scheme (or schemes))
!  </IN>
!  <IN NAME="u_star" TYPE="real">
!      Friction velocity (m/s) 
!  </IN>
!  <IN NAME="b_star" TYPE="real">
!      Buoyancy scale (m/s2)
!  </IN>
!  <IN NAME="t" TYPE="time_type">
!      Temperature (3d array) (K)
!  </IN>
!  <IN NAME="qv" TYPE="real">
!      Water vapor specific humidity (3d array) (kg/kg)
!  </IN>
!  <IN NAME="ql" TYPE="real">
!      Liquid water specific humidity (3d array) (kg/kg)
!  </IN>
!  <IN NAME="qi" TYPE="real">
!      Ice water specific humidity (3d array) (kg/kg)
!  </IN>
!  <IN NAME="qa" TYPE="real">
!      Cloud fraction (3d array) (fraction)
!  </IN>
!  <IN NAME="u" TYPE="real">
!      Zonal wind velocity (3d array) (m/s)
!  </IN>
!  <IN NAME="v" TYPE="logical">
!      Meridional wind velocity (3d array) (m/s) 
!  </IN>
!  <IN NAME="zfull" TYPE="real">
!      Geopotential height of full model levels (3d array) (m)
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!      Pressure of full model levels (3d array) (Pa)
!  </IN>
!  <IN NAME="zhalf" TYPE="real">
!      Geopotential height of half model levels (3d array) (m)
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!      Pressure of half model levels (3d array) (Pa)
!  </IN>
!  <INOUT NAME="diff_m" TYPE="real">
!      Vertical momentum diffusion coefficient (3d array) (m2/s)
!
!      Note that if apply_entrain = .true. then the output will be 
!      the diffusion coefficient diagnosed by entrain_mod (k_m_entr). 
!      If apply_entrain = .false. then the output will be identical to 
!      the input.  This permits one to run entrain_mod as a diagnostic 
!      module without using the diffusion coefficients determined by it. 
!  </INOUT>
!  <INOUT NAME="diff_t" TYPE="real">
!      Vertical heat and tracer diffusion coefficient (3d array) (m2/s) 
!
!      The note for diff_m also applies here.
!  </INOUT>
!  <OUT NAME="k_m_entr" TYPE="real">
!      Vertical momentum diffusion coefficient diagnosed by entrain_mod (3d array) (m2/s)
!  </OUT>
!  <OUT NAME="k_t_entr" TYPE="real">
!      Vertical heat and tracer diffusion coefficient diagnosed by entrain_mod (3d array) (m2/s)
!  </OUT>
!  <OUT NAME="use_entr" TYPE="real">
!      Was a diffusion coefficient calculated for this level by entrain_mod?  (1.0 = yes, 0.0 = no)
!  </OUT>
!  <OUT NAME="zsml" TYPE="real">
!      Height of surface based convective mixed layer (m)
!      This may be used by other routines, e.g. Steve Garner's gravity wave drag
!  </OUT>
!  <OUT NAME="vspblcap" TYPE="real">
!      Lowest height level for which entrain module calculated at diffusion coefficient (meters) 
!      (i.e. where use_entr = 1.0)
!      This is used by stable_bl_turb.f90 to limit the height of enhanced mixing in stable conditions.
!  </OUT>
!  <IN NAME="kbot" TYPE="integer">
!      Optional input integer indicating the lowest true layer of atmosphere (counting down from the top of the atmosphere).
!      This is used only for eta coordinate model.
!  </IN>
! </SUBROUTINE>
!
subroutine entrain(is,ie,js,je,time, tdtlw_in, convect,u_star,b_star,             &
                   t,qv,ql,qi,qa,u,v,zfull,pfull,zhalf,phalf,          &
                   diff_m,diff_t,k_m_entr,k_t_entr,use_entr,zsml,      &
                   vspblcap,kbot)

!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
!
!      is,ie,js,je  i,j indices marking the slab of model working on
!      time      variable needed for netcdf diagnostics
!
!      convect   is surface based moist convection occurring in this
!                grid box?
!      u_star    friction velocity (m/s)
!      b_star    buoyancy scale (m/s**2)
!
!      three dimensional fields on model full levels, reals dimensioned
!      (:,:,pressure), third index running from top of atmosphere to 
!      bottom
!          
!      t         temperature (K)
!      qv        water vapor specific humidity (kg vapor/kg air)
!      ql        liquid water specific humidity (kg cond/kg air)
!      qi        ice water specific humidity (kg cond/kg air)
!      qa        cloud fraction 
!      zfull     height of full levels (m)
!      pfull     pressure (Pa)
!      u         zonal wind (m/s)
!      v         meridional wind (m/s)
!
!      the following two fields are on the model half levels, with
!      size(zhalf,3) = size(t,3) +1, zhalf(:,:,size(zhalf,3)) 
!      must be height of surface (if you are not using eta-model)
!
!      zhalf     height at half levels (m)
!      phalf     pressure at half levels (Pa)
!
!      ------------
!      input/output
!      ------------
!
!      the following variables are defined at half levels and are
!      dimensions 1:nlev
!
!      diff_t   input and output heat diffusivity (m2/sec)
!      diff_m   input and output momentum diffusivity (m2/sec)
!
!      The diffusivity coefficient output from the routine includes
!      the modifications to use the internally calculated diffusivity
!      coefficients should apply_entrain = .true.  Otherwise, the
!      input and output values of the diffusivity coefficients will
!      be the same.
!
!      ------
!      output
!      ------
!
!      The following variables are defined at half levels and are
!      dimensions 1:nlev.
!
!      k_t_entr  heat diffusivity coefficient (m**2/s)
!      k_m_entr  momentum diffusivity coefficient (m**2/s)
!      use_entr  Was a diffusion coefficient calculated for this
!                level?  (1.0 = yes, 0.0 = no)
!      zsml      height of surface driven mixed layer (m)
!      vspblcap  lowest height level for which entrain module calculated
!                at diffusion coefficient (meters) (i.e. where 
!                use_entr = 1.0)
!
!      --------------
!      optional input
!      --------------
!
!      kbot      integer indicating the lowest true layer of atmosphere
!                this is used only for eta coordinate model
!
!      --------
!      internal
!      --------
!
!
!      General variables
!      -----------------
!
!      zsurf       height of surface (m)
!      zfull_ag    height of full model levels above the surface (m)
!      slv         virtual static energy (J/kg)      
!      density     air density (kg/m3)
!      hleff       effective latent heat of vaporization/sublimation 
!                  (J/kg)
!      mask        real array indicating the point is above the surface
!                  if equal to 1.0 and indicating the point is below 
!                  the surface if equal to 0. (used for eta coordinate 
!                  model)
!      zhalf_ag    height of half model levels above the surface (m)
!
!
!
!      Variables related to surface driven convective layers
!      -----------------------------------------------------
!
!      vsurf       surface driven buoyancy velocity scale (m/s)
!      vshear      surface driven shear velocity scale (m/s)
!      parcelkick  buoyancy kick to surface parcel (K)
!      wentr_pbl   surface driven entrainment rate (m/s)
!      convpbl     1 is surface driven convective layer present
!                  0 otherwise
!      pblfq       1 if the half level is part of a surface driven
!                  layer, 0 otherwise
!      k_m_troen   momentum diffusion coefficient (m2/s)
!      k_t_troen   heat diffusion coefficient (m2/s)
!
!
!      Variables related to cloud top driven radiatively driven layers
!      ---------------------------------------------------------------
!
!      zradbase    height of base of radiatively driven mixed layer (m)
!      zradtop     height of top of radiatively driven mixed layer (m)
!      zradml      depth of radiatively driven mixed layer (m)
!      vrad        radiatively driven velocity scale (m/s)
!      radf        longwave jump at cloud top (W/m2) -- the radiative 
!                  forcing for cloud top driven mixing.
!      wentr_rad   cloud top driven entrainment (m/s)
!      svpcp       cloud top value of liquid water virtual static energy 
!                  divided by cp (K)
!      radpbl      1 if cloud top radiatively driven layer is present
!                  0 otherwise
!      radfq       1 if the half level is part of a radiatively driven
!                  layer, 0 otherwise
!      k_rad       radiatively driven diffusion coefficient (m2/s)
!
!      Diagnostic variables
!      --------------------
!
!      fqinv       1 if an inversion occurs at altitudes less 
!                    than 3000 m, 0 otherwise
!      zinv        altitude of inversion base (m)
!      invstr      strength of inversion in slv/cp (K)
!
!-----------------------------------------------------------------------

integer,         intent(in)                      :: is,ie,js,je
type(time_type), intent(in)                      :: time
real,            intent(in),    dimension(:,:,:) :: tdtlw_in       
logical,         intent(in),    dimension(:,:)   :: convect
real,            intent(in),    dimension(:,:)   :: u_star,b_star
real,            intent(in),    dimension(:,:,:) :: t,qv,ql,qi,qa
real,            intent(in),    dimension(:,:,:) :: u,v,zfull,pfull
real,            intent(in),    dimension(:,:,:) :: zhalf, phalf
real,            intent(inout), dimension(:,:,:) :: diff_m,diff_t
real,            intent(out),   dimension(:,:,:) :: k_m_entr,k_t_entr
real,            intent(out),   dimension(:,:,:) :: use_entr
real,            intent(out),   dimension(:,:)   :: zsml,vspblcap
integer,  intent(in),   dimension(:,:), optional :: kbot


integer                                         :: i,j,k,ibot
integer                                         :: nlev,nlat,nlon,ipbl
integer                                         :: kmax,kcldtop
logical                                         :: used
real                                            :: maxradf, tmpradf
real                                            :: maxqdot, tmpqdot
real                                            :: maxinv
real                                            :: wentr_tmp
real                                            :: k_entr_tmp,tmpjump
real                                            :: tmp1, tmp2
real                                            :: vsurf3, vshear3,vrad3
real                                            :: ztmp
real, dimension(size(t,1),size(t,2))            :: zsurf,parcelkick
real, dimension(size(t,1),size(t,2))            :: zradbase,zradtop
real, dimension(size(t,1),size(t,2))            :: vrad,radf,svpcp
real, dimension(size(t,1),size(t,2))            :: zradml, vsurf, vshear
real, dimension(size(t,1),size(t,2))            :: wentr_rad,wentr_pbl
real, dimension(size(t,1),size(t,2))            :: convpbl, radpbl
real, dimension(size(t,1),size(t,2))            :: zinv, fqinv, invstr
real, dimension(size(t,1),size(t,2),size(t,3))  :: slv, density
real, dimension(size(t,1),size(t,2),size(t,3))  :: mask,hleff
real, dimension(size(t,1),size(t,2),size(t,3))  :: zfull_ag
real, dimension(size(t,1),size(t,2),size(t,3)+1):: zhalf_ag
real, dimension(size(t,1),size(t,2),size(t,3))  :: radfq,pblfq
real, dimension(size(t,1),size(t,2),size(t,3)+1):: mask3,rtmp
real, dimension(size(t,1),size(t,2),size(t,3))  :: k_m_troen,k_t_troen
real, dimension(size(t,1),size(t,2),size(t,3))  :: k_rad

! temp 1-d arrays
real, dimension(size(t,3)+1)                    :: zhalf_ag_1
real, dimension(size(t,3)+1)                    :: k_m_troen_1, k_t_troen_1

integer                                         :: ipt,jpt
integer, dimension(MAX_PTS) :: nsave
integer :: iloc(MAX_PTS), jloc(MAX_PTS), nn, kk, npts, nnsave
integer :: year, month, day, hour, minute, second
character(len=16) :: mon
                    
!-----------------------------------------------------------------------
!
!      initialize variables

       convpbl    = 0.0
       wentr_pbl  = missing_value
       vsurf      = missing_value
       vshear     = missing_value
       pblfq      = 0.0
       parcelkick = missing_value
       k_t_troen  = missing_value
       k_m_troen  = missing_value
       radpbl     = 0.0
       svpcp      = missing_value
       zradbase   = missing_value
       zradtop    = missing_value
       zradml     = missing_value
       vrad       = missing_value
       radf       = missing_value
       radfq      = 0.0
       wentr_rad  = missing_value
       k_rad      = missing_value
       k_t_entr   = 0.0
       k_m_entr   = 0.0
       use_entr   = 0.0
       vspblcap   = 0.0
       fqinv      = 0.0
       zinv       = missing_value
       invstr     = missing_value
       zsml       = 0.0   ! note that this must be zero as this is 
                          ! indicates stable surface layer and this
                          ! value is output for use in gravity
                          ! wave drag scheme
                             
!-----------------------------------------------------------------------
!
!      compute height above surface
!

       nlev = size(t,3)
       nlat = size(t,2)
       nlon = size(t,1)
       
       mask = 1.0
                   
       if (present(kbot)) then
            do j=1,nlat
            do i=1,nlon
                 zsurf(i,j) = zhalf(i,j,kbot(i,j)+1)
            enddo
            enddo
       else
            zsurf(:,:) = zhalf(:,:,nlev+1)
       end if

       do k = 1, nlev
            zfull_ag(:,:,k) = zfull(:,:,k) - zsurf(:,:)
            zhalf_ag(:,:,k) = zhalf(:,:,k) - zsurf(:,:)
       end do
       zhalf_ag(:,:,nlev+1) = zhalf(:,:,nlev+1) - zsurf(:,:)
       
     
!-----------------------------------------------------------------------
!
!      set up specific humidities and static energies  
!      compute airdensity
!

       hleff   = (min(1.,max(0.,0.05*(t       -tfreeze+20.)))*hlv + &
                  min(1.,max(0.,0.05*(tfreeze -t          )))*hls)
     
       slv     = cp_air*t + grav*zfull_ag - hleff*(ql + qi)
       slv     = slv*(1+d608*(qv+ql+qi))
       density = pfull/rdgas/(t *(1.+d608*qv-ql-qi))              
    
!-----------------------------------------------------------------------
! 
!      big loop over points
!
       
       ibot = nlev
              
       do j=1,nlat
         npts = 0
       if (do_ent_dg(j+js-1) ) then       
       do nn=1,num_pts
         if (                          &
       js == j_entprt(nn) .and.  &
                 i_entprt(nn) >= is .and. i_entprt(nn) <= ie) then
      iloc(npts+1) = i_entprt(nn) - is + 1
      jloc(npts+1) = j_entprt(nn) - js + 1
      nsave(npts+1) = nn
      npts = npts + 1
         endif
        end do    ! (num_points)
       else
          ipt = 0
           jpt = 0
          column_match = .false.
       endif
       do i=1,nlon
         if (npts > 0) then
           do nn=1,npts
             ipt = iloc(nn)
             jpt = jloc(nn)
             if (i == ipt ) then
               column_match = .true.
               nnsave = nsave(nn)
               exit
             else
               column_match = .false.
             endif
           end do
           nn = nnsave
         else 
           column_match = .false.
           nn = 0
         endif

            !-----------------------------------------------------------
            !
            ! should diagnostics be printed out for this column
            !
    
            if (column_match) then
            call get_date(Time, year, month, day, hour, minute, second)
            mon = month_name (month)
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  '===================================='//&
                               '=================='
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  '               ENTERING ENTRAIN    '
            write (dpu,'(a)')  ' '
            write (dpu,'(a, i6,a,i4,i4,i4,i4)')  ' time stamp:',   &
                                       year, trim(mon), day, &
                                       hour, minute, second
            write (dpu,'(a)')  '  DIAGNOSTIC POINT COORDINATES :'
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f8.3,a,f8.3)') ' longitude = ', deglon1(nn),&
                                          ' latitude  = ', deglat1(nn)
            write (dpu,'(a,i6,a,i6)')    &
                                       ' global i =', i_entprt_gl(nn), &
                                       ' global j = ', j_entprt_gl(nn)
            write (dpu,'(a,i6,a,i6)')    &
                                   ' processor i =', i_entprt(nn),     &
                                   ' processor j = ',j_entprt(nn)
            write (dpu,'(a,i6,a,i6)')     &
                                       ' window    i =', ipt,          &
                                       ' window    j = ',jpt
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k      T         u         v       '//&
                               '  qv        qt ' 
            write (dpu,'(a)')  '       (K)      (m/s)     (m/s)     '//&
                               '(g/kg)    (g/kg)'
            write (dpu,'(a)')  '------------------------------------'//&
                               '-----------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,18) kk,t(i,j,kk),u(i,j,kk),v(i,j,kk),       &
                      1000.*qv(i,j,kk), 1000.*(qv(i,j,kk)+ql(i,j,kk)+  &
                      qi(i,j,kk))
            end do
18          format(1X,i2,1X,5(f9.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k      qa        qc      sliv/cp   '//&
                               'density    tdtlw'
            write (dpu,'(a)')  '                (g/kg)     (K)      '//&
                               ' (kg/m3)   (K/day)'
            write (dpu,'(a)')  '------------------------------------'//&
                               '-------------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,19) kk,qa(i,j,kk),1000.*                    &
                   (ql(i,j,kk)+qi(i,j,kk)),slv(i,j,kk)/cp_air,         &
                   density(i,j,kk),tdtlw_in(i,j,kk)*86400.
            enddo    
19          format(1X,i2,1X,5(f9.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k   z_full    z_half    p_full    p'//&
                               '_half  '
            write (dpu,'(a)')  '      (m)      (m)        (mb)      '//&
                               '(mb)'
            write (dpu,'(a)')  '------------------------------------'//&
                               '--------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,619) kk,zfull_ag(i,j,kk),zhalf_ag(i,j,kk+1),&
                                pfull(i,j,kk)/100.,phalf(i,j,kk+1)/100.
            enddo
619         format(1X,i2,1X,4(f9.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            end if
    
    !-----------------------------------------------------------
    !  BEGIN BASIC CODE
    
    if (present(kbot)) ibot = kbot(i,j)
    
    !---------------
    ! reset indices
    ipbl    = -1
    kcldtop = -1
      
    !-----------------------------------------------------------
    !
    ! SURFACE DRIVEN CONVECTIVE LAYERS
    !
    ! Note this part is done only if b_star > 0., that is,
    ! upward surface buoyancy flux
 
    
    if (b_star(i,j) .gt. 0.) then
    
         !------------------------------------------------------
         ! Find depth of surface driven mixing by raising a 
         ! parcel from the surface with some excess buoyancy
         ! to its level of neutral buoyancy.  Note the use
         ! slv as the density variable permits one to goes
         ! through phase changes to find parcel top
 
         call pbl_depth(slv(i,j,1:ibot)/cp_air, &
              zfull_ag(i,j,1:ibot),u_star(i,j),b_star(i,j),    &
              ipbl,zsml(i,j),parcelkick(i,j))
            
                 
         !------------------------------------------------------
         ! Define velocity scales vsurf and vshear
         !           
         ! vsurf   =  (u_star*b_star*zsml)**(1/3)
         ! vshear  =  (Ashear**(1/3))*u_star
               
         vsurf3   = u_star(i,j)*b_star(i,j)*zsml(i,j)
         vshear3  = Ashear*u_star(i,j)*u_star(i,j)*u_star(i,j)
 
         if (id_vsurf  > 0) vsurf(i,j)  = vsurf3 **(1./3.)
         if (id_vshear > 0) vshear(i,j) = vshear3**(1./3.) 
 
         !------------------------------------------------------
         ! Following Lock et al. 2000, limit height of surface
         ! well mixed layer if interior stable interface is
         ! found.  An interior stable interface is diagnosed if
         ! the slope between 2 full levels is greater than
         ! the namelist parameter critjump
  
         if (ipbl .lt. ibot) then 
              do k = ibot, ipbl+1, -1
                   tmpjump =(slv(i,j,k-1)-slv(i,j,k))/cp_air 
                   if (tmpjump .gt. critjump) then
                         ipbl = k
                         zsml(i,j) = zhalf_ag(i,j,ipbl)
                         exit
                   end if
             enddo
         end if         

         !-------------------------------------
         ! compute entrainment rate
         !
 
         tmp1 = grav*max(0.1,(slv(i,j,ipbl-1)-slv(i,j,ipbl))/   &
                cp_air)/(slv(i,j,ipbl)/cp_air)
         tmp2 = ((vsurf3+vshear3)**(2./3.)) / zsml(i,j)
                  
         wentr_tmp= min( wentrmax,  max(0., (beta_surf *        &
                         (vsurf3 + vshear3)/zsml(i,j))/         &
                         (tmp1+tmp2) ) )
                                   
         k_entr_tmp = wentr_tmp*(zfull_ag(i,j,ipbl-1)-          &
                 zfull_ag(i,j,ipbl))  
         k_entr_tmp = min ( k_entr_tmp, akmax )

         pblfq(i,j,ipbl:ibot) = 1.
         convpbl(i,j)         = 1.
         use_entr(i,j,ipbl:ibot) = 1.
         wentr_pbl(i,j)       = wentr_tmp
         k_t_troen(i,j,ipbl)  = k_entr_tmp
         k_m_troen(i,j,ipbl)  = k_entr_tmp
         k_t_entr (i,j,ipbl)  = k_t_entr(i,j,ipbl) + k_entr_tmp
         k_m_entr (i,j,ipbl)  = k_m_entr(i,j,ipbl) + k_entr_tmp
         
         !------------------------------------------------------
         ! if surface based moist convection is occurring in the
         ! grid box set the entrainment rate to zero
         
         if (convect(i,j).and.convect_shutoff) then
                 
              wentr_pbl(i,j)      = 0.
              pblfq(i,j,ipbl)     = 0.
              k_t_entr (i,j,ipbl) = k_t_entr (i,j,ipbl) -      &
                                    k_t_troen(i,j,ipbl)
              k_m_entr (i,j,ipbl) = k_m_entr (i,j,ipbl) -      &
                                    k_m_troen(i,j,ipbl)          
              k_t_troen(i,j,ipbl)  = 0.
              k_m_troen(i,j,ipbl)  = 0. 
                 
         end if

         !------------------------------------------------------
         ! compute diffusion coefficients in the interior of
         ! the PBL
 
         if (ipbl .lt. ibot) then
      
              ! copy array slices into contigous arrays (pletzer)
              zhalf_ag_1 ((ipbl+1):ibot) = zhalf_ag (i,j,(ipbl+1):ibot)
              k_m_troen_1((ipbl+1):ibot) = k_m_troen(i,j,(ipbl+1):ibot)
              k_t_troen_1((ipbl+1):ibot) = k_t_troen(i,j,(ipbl+1):ibot)

              call diffusivity_pbl(zsml(i,j),u_star(i,j),      &
                   b_star(i,j), slv(i,j,(ipbl+1):ibot)/cp_air, &
                          zhalf_ag_1((ipbl+1):ibot),         &
                          k_m_troen_1((ipbl+1):ibot),        &
                          k_t_troen_1((ipbl+1):ibot))

              ! copy back
              k_m_troen(i,j,(ipbl+1):ibot) = k_m_troen_1((ipbl+1):ibot)
              k_t_troen(i,j,(ipbl+1):ibot) = k_t_troen_1((ipbl+1):ibot)
                      
              k_t_entr(i,j,(ipbl+1):ibot) =                    & 
                   k_t_entr(i,j,(ipbl+1):ibot) +               &
                   k_t_troen(i,j,(ipbl+1):ibot)
     
              k_m_entr(i,j,(ipbl+1):ibot) =                    & 
                   k_m_entr(i,j,(ipbl+1):ibot) +               &
                   k_m_troen(i,j,(ipbl+1):ibot)
         
         end if
         
    end if      
    
    
    !-----------------------------------------------------------
    !
    ! LW RADIATIVELY DRIVEN CONVECTIVE LAYERS
    !
    ! This part is done only if a level can be found with
    ! greater than radfmin (typically 30 W/m2) longwave
    ! divergence and if the level is at a lower altitude
    ! than zcldtopmax (typically 3000 m).
    !
    ! Note that if no layer is found with radiative divergence
    ! greater than radfmin, a check is made on the heating rates
    ! themselves and compared to qdotmin (10 K/day)

    !--------------------------
    ! find level of zcldtopmax
    
    kmax = ibot+1
    do k = 1, ibot
          if( zhalf_ag(i,j,k) < zcldtopmax) then
               kmax = k
               exit
          end if
    end do
       
    !-----------------------------------------------------------
    ! compute radiative driving
    !
    ! look at heating rate itself if no levels with radiative 
    ! forcing greater than radfmin are found.
    
    kcldtop = ibot+1
    maxradf = radfmin
    do k = kmax, ibot
         tmpradf = -1.*tdtlw_in(i,j,k)*cp_air*          &
                   ((phalf(i,j,k+1)-phalf(i,j,k))/grav)
         if (tmpradf .gt. maxradf) then
              kcldtop = k
              maxradf = tmpradf
         end if          
    enddo              
    
    !-----------------------------------------------------------
    ! Second try to find a radiatively driven level
    !
    ! exit if no levels with longwave cooling rate greater than
    ! qdotmin are found.
    
    if (kcldtop .eq. ibot+1) then
    
         kcldtop = ibot+1
         maxradf = radfmin
         maxqdot = qdotmin
                 
         do k = kmax, ibot
              tmpqdot = -1.*86400*tdtlw_in(i,j,k)
              tmpradf = -1.*tdtlw_in(i,j,k)*cp_air*     &
                           ((phalf(i,j,k+1)-phalf(i,j,k))/grav)
              if (tmpqdot .gt. maxqdot) then
                   kcldtop = k
                   maxradf = tmpradf
                   maxqdot = tmpqdot
              end if          
         enddo              
                 
         if (kcldtop .eq. ibot+1) go to 55
   
    end if

    !-----------------------------------------------------------
    ! following Lock for stable layer one level down;
    ! move cld top there if it exists
        
    !if (kcldtop .lt. ibot) then
    !    tmpjump =(slv(i,j,kcldtop)-slv(i,j,kcldtop+1))/cp_air
    !    if (tmpjump .gt. critjump) kcldtop = kcldtop+1           
    !end if    
    
    !-----------------------------------------------------------
    ! if layer is unstable move up a layer
    ! if that layer is also unstable exit
    
    if (slv(i,j,kcldtop-1) .lt. slv(i,j,kcldtop)) then  
         kcldtop = kcldtop - 1
         if (slv(i,j,kcldtop-1) .lt. slv(i,j,kcldtop)) then
              go to 55
         end if     
    end if
     
    !-----------------------------------------------------------
    ! exit if no cloud is present

    if ( qa(i,j,kcldtop-1)           .lt. qamin .and.          &
         qa(i,j,kcldtop  )           .lt. qamin .and.          &
         qa(i,j,min(kcldtop+1,ibot)) .lt. qamin ) go to 55
       
    !-----------------------------------------------------------
    ! compute cloud top temperature, svpcp. Ensure that
    ! that the cloud top parcel temperature, equal to
    ! svpcp minus radperturb, is no greater than
    ! the temperature of level kcldtop+1 minus radperturb if 
    ! parcel_option equals 1, and the temperature of level
    ! kcldtop+1 if parcel_option does not equal 1. This is
    ! done so that if kcldtop is in an ambiguous layer
    ! then there will not be a sudden jump in cloud top
    ! properties
    !
    ! Also assign radiative forcing at height of radiatively
    ! driven mixed layer.

    if (parcel_option .eq. 1) then
       svpcp(i,j) =min((slv(i,j,kcldtop  )/cp_air),            &
             (slv(i,j,min(kcldtop+1,ibot))/cp_air)             ) 
    else
       svpcp(i,j) =min((slv(i,j,kcldtop  )/cp_air),            &
             (slv(i,j,min(kcldtop+1,ibot))/cp_air) + radperturb) 
    end if
    
    radf(i,j) = maxradf
    zradtop(i,j) = zhalf_ag(i,j,kcldtop)
                 
    !-----------------------------------------------------------
    ! find depth of radiatively driven convection 
 
    if (kcldtop .lt. ibot) then 
         call radml_depth(svpcp(i,j),zradtop(i,j),             &
              slv(i,j,kcldtop:ibot)/cp_air,                    &
              zfull_ag(i,j,kcldtop:ibot),                      &
              zhalf_ag(i,j,kcldtop:ibot),zradbase(i,j),        &
              zradml(i,j))      
    else
         zradbase(i,j) = 0.0
         zradml(i,j)   = zradtop(i,j)  
    end if                   
                 
    !-----------------------------------------------------------
    ! compute radiation driven scale
    !
    ! Vrad**3 = g*zradml*radf/density/slv
    
    vrad3 = grav*zradml(i,j)*maxradf/density(i,j,kcldtop)/ &
            slv(i,j,kcldtop)   
    vrad(i,j) = vrad3 ** (1./3.)    
            
    !-----------------------------------------------------------
    ! compute entrainment rate
    !


    tmp1 = grav*max(0.1,((slv(i,j,kcldtop-1)/cp_air)-          &
            svpcp(i,j)))/(slv(i,j,kcldtop)/cp_air)
    
    tmp2 = (vrad(i,j)**2.) / zradml(i,j)
    wentr_rad(i,j) = min(wentrmax,beta_rad*vrad3/zradml(i,j)/  &
                     (tmp1+tmp2)) 
    k_entr_tmp = min ( akmax, wentr_rad(i,j)*                  &
               (zfull_ag(i,j,kcldtop-1)-zfull_ag(i,j,kcldtop)) )
             
    radfq(i,j,kcldtop)     = 1.
    radpbl(i,j)            = 1.
    use_entr(i,j,kcldtop)  = 1.
    k_rad(i,j,kcldtop)     = k_entr_tmp
    k_t_entr (i,j,kcldtop) = k_t_entr(i,j,kcldtop) + k_entr_tmp
    k_m_entr (i,j,kcldtop) = k_m_entr(i,j,kcldtop) + k_entr_tmp
    
    !-----------------------------------------------------------
    ! handle case of radiatively driven top being the same top
    ! as surface driven top
    
    if (ipbl .eq. kcldtop .and. ipbl .gt. 0) then

         tmp2 = ((vrad3+vsurf3+vshear3)**(2./3.)) / zradml(i,j)
 
         wentr_rad(i,j) = min( wentrmax,  max(0.,              &
              ((beta_surf *(vsurf3 + vshear3)+beta_rad*vrad3)/ &
              zradml(i,j))/(tmp1+tmp2) ) )
      
         wentr_pbl(i,j)       = wentr_rad(i,j)
                 
         k_entr_tmp = min ( akmax, wentr_rad(i,j)*             &
               (zfull_ag(i,j,kcldtop-1)-zfull_ag(i,j,kcldtop)) )
                 
         pblfq(i,j,ipbl)        = 1.
         radfq(i,j,kcldtop)     = 1.
         radpbl(i,j)            = 1.
         use_entr(i,j,kcldtop)  = 1.
         k_rad(i,j,kcldtop)     = k_entr_tmp
         k_t_troen(i,j,ipbl)    = k_entr_tmp
         k_m_troen(i,j,ipbl)    = k_entr_tmp
         k_t_entr (i,j,kcldtop) = k_entr_tmp
         k_m_entr (i,j,kcldtop) = k_entr_tmp
                                    
    end if
                                    
    !-----------------------------------------------------------
    ! if there are any interior layers to calculate diffusivity
      
    if ( kcldtop .lt. ibot ) then   

         do k = kcldtop+1,ibot
 
             ztmp = max(0.,(zhalf_ag(i,j,k)-zradbase(i,j))/    &
                    zradml(i,j) )
             
             if (ztmp.gt.0.) then
     
                  radfq(i,j,k) = 1.
                  use_entr(i,j,k) = 1.
                  k_entr_tmp = 0.85*vonkarm*vrad(i,j)*ztmp*    &
                  zradml(i,j)*ztmp*((1.-ztmp)**0.5)
                  k_entr_tmp = min ( k_entr_tmp, akmax )
                  k_rad(i,j,k) = k_entr_tmp
                  k_t_entr (i,j,k) = k_t_entr(i,j,k)           &
                                   + k_entr_tmp
                  k_m_entr (i,j,k) = k_m_entr(i,j,k)           &
                                   + pr*k_entr_tmp
             
             end if                   
         enddo  
 
    end if
           
    !-----------------------------------------------------------
    ! handle special case of zradbase < zsml
    !
    ! in this case there should be no entrainment from the 
    ! surface.
    
    if (zradbase(i,j) .lt. zsml(i,j) .and. convpbl(i,j) .eq. 1. &
        .and. ipbl .gt. kcldtop) then
         wentr_pbl(i,j)      = 0.
         pblfq(i,j,ipbl)     = 0.
         k_t_entr (i,j,ipbl) = k_t_entr (i,j,ipbl) -            &
                               k_t_troen(i,j,ipbl)
         k_m_entr (i,j,ipbl) = k_m_entr (i,j,ipbl) -            &
                               k_m_troen(i,j,ipbl)          
         k_t_troen(i,j,ipbl)  = 0.
         k_m_troen(i,j,ipbl)  = 0. 
    end if

55  continue
    
    !-----------------------------------------------------------
    !
    ! Modify diffusivity coefficients if apply_entrain = T
        
    if (apply_entrain) then
         do k = 2, ibot     
              if (use_entr(i,j,k).eq.1.) then   
                   diff_t(i,j,k) = k_t_entr(i,j,k)
                   diff_m(i,j,k) = k_m_entr(i,j,k)
              end if
         enddo      
    end if
           
    !-----------------------------------------------------------
    !
    ! compute maximum height to apply very stable mixing 
    ! coefficients (see stable_bl_turb.f90)
    
    vspblcap(i,j) = zhalf_ag(i,j,2)   
    if ( radpbl(i,j).eq.1.) vspblcap(i,j) = zradbase(i,j)  
    if (convpbl(i,j).eq.1.) vspblcap(i,j) = 0.

    !-----------------------------------------------------------
    !
    ! Diagnostic code for inversions
    
    if (id_fqinv > 0 .or. id_zinv > 0 .or. id_invstr > 0) then
       maxinv = 0.0
       do k = ibot,2,-1
            if ( t(i,j,k)            .lt. t(i,j,k-1) .and.     &
                (t(i,j,k-1)-t(i,j,k)).gt. maxinv     .and.     &
                 zhalf_ag(i,j,k)     .lt. 3000. ) then
                 maxinv      = t(i,j,k-1)-t(i,j,k)
                 invstr(i,j) = (slv(i,j,k-1)-slv(i,j,k))/cp_air
                 fqinv(i,j)  = 1.
                 zinv(i,j)   = zhalf_ag(i,j,k)   
            end if
        enddo                   
    end if 

    !-----------------------------------------------------------
    !
    ! Selected points printout
    

    if (column_match) then
    
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' u_star = ', u_star(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' b_star = ', b_star(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' convpbl = ', convpbl(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,i3)')  ' ipbl = ', ipbl
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' parcelkick = ', parcelkick(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' zsml = ', zsml(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' vsurf = ', vsurf(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' vshear = ', vshear(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' wentr_pbl = ', wentr_pbl(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' radpbl = ', radpbl(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,i3)')  ' kcldtop = ', kcldtop
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' svpcp = ', svpcp(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' zradtop = ', zradtop(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' zradbase = ', zradbase(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' wentr_rad = ', wentr_rad(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' vrad = ', vrad(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' radf = ', radf(i,j)
            write (dpu,'(a)')  ' '
            write (dpu,'(a,f10.4)')  ' vspblcap = ', vspblcap(i,j)
            write (dpu,'(a)')  ' '
       
       
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k  use_entr    diff_t    diff_m  '//  &
                               '  k_t_entr  k_m_entr' 
            write (dpu,'(a)')  '                (m2/s)    (m2/s)    '//&
                               '(m2/s)    (m2/s)'
            write (dpu,'(a)')  '------------------------------------'//&
                               '------------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
             write(dpu,947) kk,use_entr(i,j,kk), diff_t(i,j,kk),       &
                      diff_m(i,j,kk), k_t_entr(i,j,kk), k_m_entr(i,j,kk)
            end do
947         format(1X,i2,3X,f4.1,4X,4(f9.4,1X))
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' '
            write (dpu,'(a)')  ' k   pblfq  radfq     '//&
                               'k_t_troen k_m_troen   k_rad' 
            write (dpu,'(a)')  '                       (m2/s)'//   &
                               '    (m2/s)     (m2/s) '
            write (dpu,'(a)')  '------------------------------------'//&
                               '------------------------------------'
            write (dpu,'(a)')  ' '
            do kk = nlev-n_print_levels,nlev
                 write(dpu,949) kk,pblfq(i,j,kk),radfq(i,j,kk),        &
                       k_t_troen(i,j,kk),k_m_troen(i,j,kk),k_rad(i,j,kk)
            end do
949         format(1X,i2,3X,2(f4.1,4X),3(f9.4,1X))

      end if

      enddo
      enddo
    
!-----------------------------------------------------------------------
! 
!      Diagnostics
!

       if ( id_convpbl    > 0 .or. id_wentr_pbl > 0 .or.               &
            id_k_m_entr   > 0 .or. id_wentr_rad > 0 .or.               &
            id_zsml       > 0 .or. id_k_t_entr  > 0 .or.               &
            id_pblfq      > 0 .or. id_radfq     > 0 .or.               &
            id_parcelkick > 0 .or. id_k_t_troen > 0 .or.               &
            id_k_rad      > 0 .or. id_k_m_troen > 0 .or.               &
            id_radf       > 0 .or. id_vrad      > 0 .or.               &
            id_zradbase   > 0 .or. id_radpbl    > 0 .or.               &
            id_zradtop    > 0 .or. id_zradml    > 0 .or.               &
            id_svpcp      > 0 .or. id_vsurf     > 0 .or.               &
            id_vshear     > 0  ) then 

          mask3(:,:,1:(nlev+1)) = 1.
          if (present(kbot)) then
               where (zhalf_ag < 0.)
                     mask3(:,:,:) = 0.
               end where
          endif
            
          !----------------------------------------------
          !
          ! Convective PBL diagnostics
          !
    
          if ( id_convpbl > 0 ) then
                 used = send_data ( id_convpbl, convpbl, time, is, js )
          end if
    
          if ( id_zsml > 0 ) then
                 used = send_data ( id_zsml, zsml, time, is, js )
          end if
    
          if ( id_vsurf > 0 ) then
                 used = send_data ( id_vsurf, vsurf, time, is, js )
          end if
    
          if ( id_vshear > 0 ) then
                 used = send_data ( id_vshear, vshear, time, is, js )
          end if
    
          if ( id_parcelkick > 0 ) then
                 used = send_data ( id_parcelkick, parcelkick, time,   &
                    is, js )
          end if
    
          if ( id_wentr_pbl > 0 ) then
               used = send_data ( id_wentr_pbl, wentr_pbl, time,     &
                          is, js)
          end if
            
          if ( id_pblfq > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = pblfq
               used = send_data ( id_pblfq, rtmp, time, is, js,      &
                          1, rmask=mask3 )
          end if
            
          if ( id_k_t_troen > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = k_t_troen
               used = send_data ( id_k_t_troen, rtmp, time, is, js,  &
                          1, rmask=mask3 )
          end if
            
          if ( id_k_m_troen > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = k_m_troen
               used = send_data ( id_k_m_troen, rtmp, time, is, js,  &
                          1, rmask=mask3 )
          end if
            
          !----------------------------------------------
          !
          ! Cloud top radiative cooling diagnostics
          !
    
          if ( id_radpbl > 0 ) then
                 used = send_data ( id_radpbl, radpbl, time, is, js )
          end if
    
          if ( id_vrad > 0 ) then
                 used = send_data ( id_vrad, vrad, time, is, js )
          end if
    
          if ( id_zradml > 0 ) then
                 used = send_data ( id_zradml, zradml, time, is, js )
          end if
    
          if ( id_svpcp > 0 ) then
                 used = send_data ( id_svpcp, svpcp, time, is, js )
          end if
    
          if ( id_zradtop > 0 ) then
                 used = send_data ( id_zradtop, zradtop, time, is, js )
          end if
    
          if ( id_zradbase > 0 ) then
                 used = send_data ( id_zradbase, zradbase, time, is, js)
          end if
    
          if ( id_radf > 0 ) then
                 used = send_data ( id_radf, radf, time, is, js )            
          end if
            
          if ( id_wentr_rad > 0 ) then
                 used = send_data ( id_wentr_rad, wentr_rad, time, is, &
                                      js)
          end if
            
          if ( id_radfq > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = radfq
               used = send_data ( id_radfq, rtmp, time, is, js,      &
                          1, rmask=mask3 )
          end if
            
          if ( id_k_rad > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = k_rad
               used = send_data ( id_k_rad, rtmp, time, is, js, 1,   &
                          rmask=mask3 )
          end if
            
          !----------------------------------------------
          !
          ! Total diffusivity coefficients
          !
    
          if ( id_k_t_entr > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = k_t_entr
               used = send_data ( id_k_t_entr, rtmp, time, is, js,   &
                          1, rmask=mask3 )
          end if
            
          if ( id_k_m_entr > 0 ) then
               rtmp = 0.
               rtmp(:,:,1:nlev) = k_m_entr
               used = send_data ( id_k_m_entr, rtmp, time, is, js,   &
                          1, rmask=mask3 )
          end if


          !----------------------------------------------
          !
          ! Inversion diagnostics
          !

          if ( id_fqinv > 0 ) then
                 used = send_data ( id_fqinv, fqinv, time, is, js )
          end if
    
          if ( id_zinv > 0 ) then
                 used = send_data ( id_zinv, zinv, time, is, js )
          end if
    
          if ( id_invstr > 0 ) then
                 used = send_data ( id_invstr, invstr, time, is, js )
          end if
              
       end if  ! do diagnostics if
       
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine entrain

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

!======================================================================= 
!
!  Subroutine to calculate pbl depth
!

! <SUBROUTINE NAME="pbl_depth">
!  <OVERVIEW>
!    
!  </OVERVIEW>
!  <DESCRIPTION>
!
!      Calculates the depth of the surface based convective layer
!  </DESCRIPTION>
!  <TEMPLATE>
!   call pbl_depth(t, z, u_star, b_star, ipbl, h, parcelkick)
!
!  </TEMPLATE>
!  <IN NAME="t" TYPE="real">
!       Liquid water virtual static energy divided by cp (K)
!  </IN>
!  <IN NAME="z" TYPE="real">
!       Geopoential height of levels t is defined on (m)       
!  </IN>
!  <IN NAME="u_star" TYPE="real">
!       Friction velocity (m/s)
!  </IN>
!  <IN NAME="b_star" TYPE="real">
!       Buoyancy scale (m/s2)
!  </IN>
!  <OUT NAME="ipbl" TYPE="integer">
!       Integer indicating the half model level which is the PBL top
!  </OUT>
!  <OUT NAME="h" TYPE="real">
!       PBL height (m)
!  </OUT>
!  <OUT NAME="parcelkick" TYPE="real">
!       Surface parcel excess (K)
!  </OUT>
! </SUBROUTINE>
!
subroutine pbl_depth(t, z, u_star, b_star, ipbl, h, parcelkick)

!
!  -----
!  INPUT
!  -----
!
!  t (= slv/cp)  liquid water virtual static energy divided by cp (K)
!  u_star        friction velocity (m/s)
!  b_star        buoyancy scale (m/s**2)
!       
!  ------
!  OUTPUT
!  ------
!
!  ipbl          half level containing pbl height
!  h             pbl height (m)
!  parcelkick    surface parcel excess (K)

real,    intent(in) ,  dimension(:) :: t, z
real,    intent(in)                 :: u_star, b_star
integer, intent(out)                :: ipbl
real,    intent(out)                :: h,parcelkick

real     :: svp,h1,h2,t1,t2
real     :: ws,k_t_ref
integer  :: k,nlev

!initialize zsml
h = 0.

!compute # of levels
nlev = size(t,1)

!calculate surface parcel properties
svp  = t(nlev)
h1   = z(nlev)
call mo_diff(h1, u_star, b_star, ws, k_t_ref)
ws = max(small,ws/vonkarm/h1)
svp  = svp*(1.+(parcel_buoy*u_star*b_star/grav/ws) )
parcelkick = svp*parcel_buoy*u_star*b_star/grav/ws

!search for level where this is exceeded              
h    = h1
t1   = t(nlev)
do k = nlev-1 , 2, -1
     h2 = z(k)
     t2 = t(k)
     if (t2.gt.svp) then
          h = h2 + (h1 - h2)*(t2 - svp)/(t2 - t1 )
          ipbl = k+1
          return
     end if
     h1 = h2
     t1 = t2
enddo

!one shouldn't end up here but nonetheless for safety this is put here
h = h2
ipbl = k+1

return

end subroutine pbl_depth

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

!======================================================================= 
!
!  Subroutine to do profile reconstuction
!

! <SUBROUTINE NAME="prof_recon">
!  <OVERVIEW>
!      
!  </OVERVIEW>
!  <DESCRIPTION>
!
!      Subroutine to do profile reconstruction
!
!      This is not turned on in the default version as I suspect there is a 
!      bug in this subroutine.
!
!  </DESCRIPTION>
!  <TEMPLATE>
!   call prof_recon(rho,t,pf,ph,zt,dt)
!
!  </TEMPLATE>
!  <IN NAME="rho" TYPE="real">
!       Air density (kg/m3)
!  </IN>
!  <IN NAME="t" TYPE="real">
!       Liquid water virtual static energy divided by cp (K)
!  </IN>
!  <IN NAME="pf" TYPE="real">
!       Full level pressures (Pa)
!  </IN>
!  <IN NAME="ph" TYPE="real">
!       Half level pressures (pa)
!  </IN>
!  <OUT NAME="zt" TYPE="real">
!       Top of radiatively driven layer in distance relative to boundary between cloud top layer and the level below (m)
!  </OUT>
!  <OUT NAME="dt" TYPE="real">
!       Cloud top jump in liquid water virtual static energy divided by cp (K)
!  </OUT>
! </SUBROUTINE>
!
subroutine prof_recon(rho,t,pf,ph,zt,dt)

!
!  -----
!  INPUT
!  -----
!
!  rho    air density (kg/m3)
!  t      liquid water virtual static energy divided by cp (K)
!  pf     full level pressure (Pa)
!  ph     half level pressure (Pa)
!       
!  ------
!  OUTPUT
!  ------
!
!  zt     top of radiatively driven layer in distance relative to
!         boundary between cloud top layer and the level below (m)
!  dt     cloud top jump in liquid water virtual static energy divided 
!         by cp (K)
!
 
real,   intent(in)                    :: rho
real,   intent(in) ,  dimension(-2:1) :: t, pf
real,   intent(in) ,  dimension( 0:1) :: ph
real,   intent(out)                   :: zt, dt

real, dimension(-2:1) :: pfp
real, dimension( 0:1) :: php

real                         :: slope,textrap
real                         :: a,b,c,det,pinv,ttop

!-----------------------------------------
! calculate all pressure relative to ph(0)
!
! pfp = full level relative pressures
! php = half level relative pressures
!
!  pfp(-2) < pfp(-1) < php(0) < pfp(0) < php(1) < pfp(1)
! 
! Note the following coordinate system
!
!            - - - - - - - - - - - - - -    
!
!                       *                   pfp(-2)
!
!            - - - - - - - - - - - - - - 
!
!                       *                   pfp(-1)
!
!            - - - - - - - - - - - - - -    php(0)
!
!  ambiguous layer ---> *                   pfp(0)
!
!            - - - - - - - - - - - - - -    php(1)
!
!                       *                   pfp(1)
!
!            - - - - - - - - - - - - - -
!

pfp = pf - ph(0)
php = ph - ph(0)

!----------------
! determine slope

slope = min ( (t(-2)-t(-1))/(pfp(-2)-pfp(-1)) , 0. )

! if this slope is such that the mean temperature of level 0 would
! exceed its actual temperature then assume a minimum protusion of
! mixed layer into ambiguous layer
!
! otherwise compute height of inversion using normal method


textrap = t(-1)+slope*(pfp(0)-pfp(-1))

if (textrap .lt. t(0)) then

     zt = 0.1*php(1)/rho/grav
     dt = t(0)-t(1)

else

     a = 0.5*slope
     b = t(-1)-t(1)-slope*pfp(-1)
     c = - php(1)*(t(0)-t(1))

     det = b*b - 4*a*c

     if (a.lt.0.) then
          pinv = (-b+sqrt(det))/(2*a)
     else
          pinv = c/b
     end if
     
     zt = (php(1)-pinv)/rho/grav
     ttop = t(-1) + slope*(pinv-pfp(-1))
     
     dt = ttop - t(1)
            
end if
 
return

end subroutine prof_recon

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

!======================================================================= 
!
!  Subroutine to calculate bottom and depth of radiatively driven mixed
!  layer
!
! <SUBROUTINE NAME="radml_depth">
!  <OVERVIEW>
!       
!  </OVERVIEW>
!  <DESCRIPTION>
!       Subroutine to calculate the depth of the the radiatively driven 
!       (i.e. stratocumulus) mixed layer 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radml_depth(svp, zt, t, zf, zh, zb, zml)
!
!  </TEMPLATE>
!  <IN NAME="svp" TYPE="real">
!       Cloud top value of the liquid water virtual static energy divided by cp (K)
!  </IN>
!  <IN NAME="zt" TYPE="real">
!       Top of radiatively driven layer (m)
!  </IN>
!  <IN NAME="t" TYPE="real">
!       Liquid water virtual static energy divided by cp (vertical profile) (K)
!  </IN>
!  <IN NAME="zf" TYPE="real">
!       Full level geopotential height relative to ground (vertical profile) (m)
!  </IN>
!  <IN NAME="zh" TYPE="real">
!       Half level geopotential height relative to ground (vertical profile) (m)
!  </IN>
!  <OUT NAME="zb" TYPE="real">
!       Base of radiatively driven mixed layer (m) 
!  </OUT>
!  <OUT NAME="zml" TYPE="real">
!       Depth of radiatively driven mixed layer (m) (equals zt minus zb)
!  </OUT>
! </SUBROUTINE>
!
subroutine radml_depth(svp, zt, t, zf, zh, zb, zml)

!
!  -----
!  INPUT
!  -----
!
!  svp    cloud top liquid water virtual static energy divided by cp (K)
!  zt     top of radiatively driven layer (m)
!  t      liquid water virtual static energy divided by cp (K)
!  zf     full level height above ground (m)
!  zh     half level height above ground (m)
!       
!  ------
!  OUTPUT
!  ------
!
!  zb      base height of radiatively driven mixed layer (m)
!  zml     depth of radiatively driven mixed layer (m)


real,   intent(in)                 :: svp, zt
real,   intent(in) ,  dimension(:) :: t, zf, zh
real,   intent(out)                :: zb, zml

real    :: svpar,h1,h2,t1,t2
integer :: k,nlev

!initialize zml
zml = 0.

!compute # of levels
nlev = size(t,1)

!calculate cloud top parcel properties
svpar  = svp - radperturb
h1   = zf(1)
t1   = t(1)

!search for level where this is exceeded              
do k = 2,nlev
     h2 = zf(k)
     t2 = t(k)
     
     if (t2.lt.svpar) then
          zb = h2 + (h1 - h2)*(svpar - t2)/(t1 - t2)
          zml = zt - zb
          return
     end if
     
     if (do_jump_exit .and. (t1-t2) .gt. critjump .and. k .gt. 2) then
          zb = zh(k)
          zml = zt - zb
          return
     end if
     
     h1 = h2
     t1 = t2
enddo

zb = 0.
zml = zt
  
return
end subroutine radml_depth

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


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

! <SUBROUTINE NAME="diffusivity_pbl">
!  <OVERVIEW>
!         
!  </OVERVIEW>
!  <DESCRIPTION>
!       Subroutine to return the vertical K-profile of diffusion 
!       coefficients for the surface driven convective mixed layer    
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diffusivity_pbl(h, u_star, b_star, t, zm, k_m, k_t)
!
!  </TEMPLATE>
!  <IN NAME="h" TYPE="real">
!      Depth of surface driven mixed layer (m) 
!  </IN>
!  <IN NAME="u_star" TYPE="real">
!      Friction velocity (m/s)
!  </IN>
!  <IN NAME="b_star" TYPE="real">
!      Buoyancy scale (m/s2)
!  </IN>
!  <IN NAME="t" TYPE="real">
!      Liquid water virtual static energy divided by cp (K)
!  </IN>
!  <IN NAME="zm" TYPE="real">
!      Half level heights relative to the ground (m)
!  </IN>
!  <OUT NAME="k_m" TYPE="real">
!      Momentum diffusion coefficient (m2/s)
!  </OUT>
!  <OUT NAME="k_t" TYPE="real">
!      Heat and tracer diffusion coefficient (m2/s)
!  </OUT>
! </SUBROUTINE>
!
subroutine diffusivity_pbl(h, u_star, b_star, t, zm, k_m, k_t)
 
real,    intent(in)                :: h, u_star, b_star
real,    intent(in),  dimension(:) :: t,zm
real,    intent(out), dimension(:) :: k_m, k_t

real    :: k_m_ref, k_t_ref, factor, hinner
integer :: k, kk, nlev

nlev = size(t,1)

k_m = 0.0
k_t = 0.0

hinner = frac_inner*h
kk = nlev+1
do k = 1, nlev
  if( zm(k) < hinner) then
      kk = k
      exit
  end if
end do

call mo_diff(hinner, u_star, b_star, k_m_ref, k_t_ref)

if (kk .lt. nlev+1) then 
     call mo_diff(zm(kk:nlev), u_star, b_star, k_m(kk:nlev),           &
                                               k_t(kk:nlev))
end if

if (kk .gt. 1) then
     do k = 1,kk-1
        factor = (zm(k)/hinner)* (1.0 -(zm(k)-hinner)/(h-hinner))**2
        k_m(k) = min( k_m_ref*factor, akmax )
        k_t(k) = min( k_t_ref*factor, akmax )
     end do
end if

return
end subroutine diffusivity_pbl

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

!======================================================================= 
!
!      subroutine entrain_tend
!        
!
!      this subroutine takes the longwave heating rate and assigns it
!      to tdtlw
!        

!subroutine entrain_tend(is,ie,js,je,tend)

!-----------------------------------------------------------------------
!
!      variables
!
!      -----
!      input
!      -----
!
!      is,ie,js,je       i,j indices marking the slab of model 
!      tend              longwave heating rate (deg K/sec)
!
!-----------------------------------------------------------------------

!integer, intent(in)                   :: is,ie,js,je
!real,    intent(in), dimension(:,:,:) :: tend

!-----------------------------------------------------------------------
!
!      assign tendency
!

!      if (.not. entrain_on) return
!      tdtlw(is:ie,js:je,:)=tend(:,:,:)

!-----------------------------------------------------------------------
! 
!      subroutine end
!

!end subroutine entrain_tend

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




!======================================================================= 
!
!      subroutine entrain_end
!        
!
!      this subroutine writes out the restart field
!        

! <SUBROUTINE NAME="entrain_end">
!  <OVERVIEW>
!      
!  </OVERVIEW>
!  <DESCRIPTION>
!      All this module does is to set "module_is_initialized" to false.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call entrain_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine entrain_end()

!-----------------------------------------------------------------------
!
!      variables
!
!      --------
!      internal
!      --------
!
!      unit              unit number for namelist and restart file
!
!-----------------------------------------------------------------------

!integer :: unit

!-----------------------------------------------------------------------
!
!      write out restart file
!
!      unit = Open_File ('RESTART/entrain.res', &
!           FORM='native', ACTION='write')
!      call write_data (unit, tdtlw)
!      Call Close_File (unit)
      module_is_initialized = .false.
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! 
!      subroutine end
!

end subroutine entrain_end

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

end module entrain_mod



      Module co2int_mod

!-----------------------------------------------------------------------
!
!       CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
!  FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
!  HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
!  USER.
!
!        METHOD: 
!
!      CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
!  SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
!  2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
!  OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
!  THE DIAGRAM AND DISCUSSION BELOW.
!      CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
!
!     LET P BE AN ARRAY OF USER-DEFINED PRESSURES
!     AND PD BE USER-DEFINED PRESSURE LAYERS.
!
!       - - - - - - - - -   PD(I-1) ---
!                                     !
!       -----------------   P(I)      !  PRESSURE LAYER I  (PLM(I))
!                                     !
!       - - - - - - - - -   PD(I)  ---
!                                     !
!       -----------------   P(I+1)    !  PRESSURE LAYER I+1 (PLM(I+1))
!                                     !
!       - - - - - - - - -   PD(I+1)---
!            ...                          (THE NOTATION USED IS
!            ...                          CONSISTENT WITH THE CODE)
!            ...
!      - - - - - - - - -    PD(J-1)
!
!      -----------------    P(J)
!
!      - - - - - - - - -    PD(J)
!
!      PURPOSE 1:   THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
!      P(I) AND P(J) ,TAU(P(I),P(J))  IS COMPUTED BY THIS PROGRAM.
!      IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
!      (PD,PLM ARE NOT INPUTTED).
!
!      PURPOSE 2:   THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
!      MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
!         TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
!
!                           PD(I)
!                           ----
!             1             !
!        -------------  *   !   TAU ( P',PLM(J) )  DP'
!        PD(I)-PD(I-1)      !
!                        ----
!                        PD(I-1)
!
!           THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
!        FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
!        PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
!           FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
!        A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
!        ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
!        DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
!        INPUTTED).
!
!            THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
!       CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
!       PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
!       FOR LAYER-MEAN TRANSMISSIVITIES.
!
!          FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
!      PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
!     OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
!      THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
!     STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
!     SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
!     TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
!     BY 25 DEGREES.
!         THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
!     AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
!     MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I)'S AND P(J)'S.
!     A LOGARITHMIC INTERPOLATION SCHEME IS USED.
!         THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
!     GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
!     OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
!     THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
!     LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
!     DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
!     USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
!
!     MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES: 
!          THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
!     AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
!     (TAU(P',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
!     DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
!     PLM(J) SIMPSON'S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
!     (THE "NEARBY LAYER" CASE) A 49-POINT QUADRATURE IS USED FOR
!     GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
!        NOTE: 
!     TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
!     TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
!     DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
!     (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
!     THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
!     THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAGE
!     PRESSURE OF PLM(2).
!         ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
!     BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
!     TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
!
!
!             REFERENCE: 
!         S.B.FELS AND M.D.SCHWARZKOPF,"AN EFFICIENT,ACCURATE
!     ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES",JOURNAL
!     OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
!        MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
!     CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
!     IS PLANNED TO DOCUMENT THESE CHANGES.
!
!            AUTHOR:    M.DANIEL SCHWARZKOPF
!
!            DATE:      14 JULY 1983
!
!            ADDRESS: 
!
!                      G.F.D.L.
!                      P.O.BOX 308
!                      PRINCETON,N.J.08540
!                      U.S.A.
!            TELEPHONE:  (609) 452-6521
!
!            INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
!        ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
!        MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
!        CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
!        1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS: 
!          FILE 2   1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
!          FILE 3   1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
!          FILE 4   2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
!          FILE 5   2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
!          FILE 6   4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
!          FILE 7   4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
!            FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
!        TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
!        COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
!        DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
!        TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
!        CALCULATIONS.
!
!            PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
!        AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
!        CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
!        ADAPTATIONS TO OTHER MACHINES.
!
!
!            PARAMETER INPUTS: 
!     A) NLEVLS    : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
!        THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
!        OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
!        SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
!        GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
!        IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
!        PRESSURE LAYERS=2,SO NLEVLS=2
!           IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
!        CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
!     B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
!        NLP2=NLEVLS+2.
!           SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
!        STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
!
!            INPUTS: 
!
!     A) TRANSA    : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
!            TRANSA IS A  REAL ARRAY.
!
!           TRANSA  IS READ FROM FILE 20. THIS FILE CONTAINS 3
!     RECORDS,AS FOLLOWS: 
!        1)   TRANSA, STANDARD TEMPERATURE PROFILE
!        3)   TRANSA, STANDARD TEMPERATURES + 25 DEG
!        5)   TRANSA, STANDARD TEMPERATURES - 25 DEG
!
!     B)   NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
!       TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
!       PURPOSE 2).
!
!     C)     P,PD,PLM : 
!          P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
!       GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
!       PURPOSE 1.THE DIMENSION  OF P IS  IN MILLIBARS.THE
!       FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
!       IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
!       LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
!         PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
!       LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
!       TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
!       FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
!       LIMITATIONS.
!         PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
!       PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
!       FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
!       LIMITATIONS.PD IS READ IN BEFORE PLM.
!
!          NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
!       PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
!
!
!
!
!           LIMITATIONS: 
!     1)       P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
!       MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
!       THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
!       QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
!       NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
!       ONE MUST INCLUDE SUCH A LEVEL.
!     2)      PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
!       EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
!     3)      IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
!       SIMPLY DELETE THE LINE.
!     4)      IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING: 
!            1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
!            2) AT THE POINT WHERE NMETHOD IS READ IN,ADD: 
!                READ (5,202) NLEVLS
!                NLP1=NLEVLS+1
!                NLP2=NLEVLS+2
!            3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
!              ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
!              THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
!              IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
!              P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
!              IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
!      5)    PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
!       STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
!       SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
!       PARAMETER   NLEVLS=40
!      6) "REAL(KIND=8)" IS USED INSTEAD OF "DOUBLE PRECISION" OR 
!           "REAL*8" FOR CODE PORTABILITY.
!       REQUIREMENTS OF CDC FORTAN.
!      7) THE STATEMENT "DO 400 KKK=1,3" CONTROLS THE NUMBER OF
!       TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
!       PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
!
!-----------------------------------------------------------------------

      Use fs_profile_mod, ONLY:  pd1013,plm1013,pd810,plm810
      Use        fms_mod, ONLY:  ERROR_MESG, FATAL, WARNING, &
                                 mpp_pe, mpp_root_pe, write_version_number


implicit none
private
      Integer,Parameter :: kind_type = selected_real_kind(15,307)

      Real, Allocatable, Dimension(:,:,:,:) :: TRNS

      Real,Private, Dimension(109)     :: PA
      Real,Private, Dimension(109,109) :: TRANSA
      Real(kind_type),Private, Dimension(109)   :: XA,CA,ETA,SEXPV
      Real(kind_type),Private                   :: CORE,UEXP,SEXP

      Real(kind_type),Private :: ZERO=0.0, ONE=1.0, TWO=2.0
!-----------------------------------------------------------------------

      Public   co2int, co2int_init, co2int_end, TRNS
      Private  RCTRNS,COEINT,QUADSR,SINTR2,Qintrp,PATH

!------------ VERSION NUMBER ----------------

 character(len=128) :: version = '$Id: co2int.F90,v 13.0 2006/03/28 21:09:25 fms Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.
!-----------------------------------------------------------------------

      CONTAINS

!#######################################################################

      Subroutine co2int (nlev,ir,npurp,nkkk,unit1,unit2,ratio)

      Implicit None
!-----------------------------------------------------------------------
!
!      ------------   FUNCTION INTERPOLATER ROUTINE  ------------
!
!-----------------------------------------------------------------------
      Integer, Intent(IN) :: nlev,ir,npurp,nkkk,unit1,unit2
      Real,    Intent(IN) :: ratio
!-----------------------------------------------------------------------

      Real, Dimension(nlev+1) :: p,pd

      Real     P1,P2,TRNSLO,FACT15,FACT30,ratsm,ratstd
      Integer  i,j,kk,kkk,N,NLP1,NLP2,nmeth,ncalcs
!-----------------------------------------------------------------------

      NLP1=nlev+1
      NLP2=nlev+2

!-----------------------------------------------------------------------

!------ THE FOLLOWING ARE THE INPUT FORMATS -----

 100  FORMAT (4F20.14)

!-----------------------------------------------------------------------

!     CALCULATION OF PA -THE "TABLE" OF 109 GRID PRESSURES
!     NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER!!!!!!!!!

      PA(1)=0.
      FACT15=10.**(1./15.)
      FACT30=10.**(1./30.)
      PA(2)=1.0E-3
      Do i=2,76
         PA(i+1)=PA(i)*FACT15
      EndDo
      Do i=77,108
         PA(i+1)=PA(i)*FACT30
      EndDo

      If (npurp == 1) Then
         ncalcs=4
      Else If (npurp == 2) Then
         ncalcs=2
      Else If (npurp == 3) Then
         ncalcs=2
      EndIf

!-------- allocate output transmission function arrays --------
      If (Allocated(TRNS)) DeAllocate (TRNS)
                             Allocate (TRNS(NLP1,NLP1,ncalcs,nkkk))

!=======================================================================
!***do loop on no. of temp profiles for each output calc (controlled
!   by nkkk,a function of freq. range)

      Do 410 kkk=1,nkkk
!-----------------------------------------------------------------------

!***read input lbl transmission fctn tapes (the no. depends on the
!   co2 amount and is controlled by unit1, unit2, a function of ratio)

      If (unit2 == 0) Then
         read (unit1,100) ((transa(i,j),i=1,109),j=1,109)
      Else
         If (ratio > 0.5 .and. ratio < 1.0) Then
             ratsm=0.5
             ratstd=1.0
         EndIf
         If (ratio > 1.0 .and. ratio < 2.0) Then
             ratsm=1.0
             ratstd=2.0
         EndIf
         If (ratio > 2.0 .and. ratio < 4.0) Then
             ratsm=2.0
             ratstd=4.0
         EndIf
         CALL RCTRNS (unit1,unit2,RATSTD,RATSM,RATIO,IR)
      EndIf

!***define interpolation coefficients in coeint

      Do i=1,109
         TRANSA(i,i)=1.0
      EndDo
      CALL COEINT (RATIO,IR)

!=======================================================================
!***do loop on number of output calculations (controlled by ncalcs,
!   a function of calculation purpose)

      Do 400 kk=1,ncalcs
!-----------------------------------------------------------------------

!---initialize transmission fctn array  

      Do i=1,NLP1
      Do j=1,NLP1
         TRNS(j,i,kk,kkk)=1.00
      EndDo
      EndDo

!***define pressure arrays pd,p according to the calc. no. kk and
!   npurp.define nmeth (interp method to be used)

      If (kk == 1) Then
         If (npurp == 1 .or. npurp == 3) Then
            pd=pd1013; p=plm1013
            nmeth=2 
         Else
            p=plm1013
            nmeth=1
         EndIf
      EndIf 

      If (kk == 2) Then
         If (npurp == 1) Then
            p=plm1013
            nmeth=1
         EndIf
         If (npurp == 2) Then
            p=plm810
            nmeth=1
         EndIf
         If (npurp == 3) Then
            pd=pd810; p=plm810
            nmeth=2
         EndIf
      EndIf

      If (kk == 3) Then
         pd=pd810; p=plm810
         nmeth=2
      EndIf

      If (kk == 4) Then
         p=plm810
         nmeth=1
      EndIf

      If (nmeth == 1) Then
         Do i=1,NLP1
         Do j=1,i
            IF (i == j) CYCLE
            P1=P(j)
            P2=P(i)
            CALL SINTR2 (P1,P2,TRNSLO)
            TRNS(j,i,kk,kkk)=TRNSLO
         EndDo
         EndDo
         Do i=1,NLP1
         Do j=i,NLP1
            TRNS(j,i,kk,kkk)=TRNS(i,j,kk,kkk)
         EndDo
         EndDo
      Else

!   perform method 1(point) calculations for (1,i) array elements. this
!   element will be used for cts calculations and is unneeded for other
!   aspects of radiation calcs, since we assume isothermal conditions
!   above the top pressure level.

         TRNS(1,1,kk,kkk)=1.00
         Do j=2,NLP1
            P1=0.
            P2=P(j)
            CALL SINTR2 (P1,P2,TRNSLO)
            TRNS(1,j,kk,kkk)=TRNSLO
         EndDo
         Do j=1,NLP1
         Do i=2,NLP1
            N=25
            IF (i /= j) N=3
            call quadsr (N,p(j),pd(i),pd(i-1),TRNS(i,j,kk,kkk))
         EndDo
         EndDo
      EndIf

!-----------------------------------------------------------------------
 400  Continue
 410  Continue
!=======================================================================

      End Subroutine co2int

!#######################################################################

      Subroutine co2int_init
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      End Subroutine co2int_init

!#######################################################################

      Subroutine co2int_end

      module_is_initialized = .false.
!---------------------------------------------------------------------

      End Subroutine co2int_end

!#######################################################################

      SUBROUTINE COEINT (RAT,IR)

      Implicit None
!-----------------------------------------------------------------------
!
!
!      THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO  HAVE
!  THE FUNCTIONAL FORM
!               TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
!         WHERE
!               PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
!                           (ETA*(P1+P2+CORE)+(P1-P2))
!
!
!  THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETERMINED,
!  WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE THEIR
!  PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL THESE
!  VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
!      SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACTUAL
!  VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOUS
!  ITERATION VALUE OF ETA.
!       DEFINE: 
!         PATHA=PATH(P(I),P(I-2),CORE,ETA)
!          PATHB=PATH(P(I),P(I-1),CORE,ETA);
!  THEN
!          R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
!           = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
!  SO THAT
!          R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
!  THIS EQUATION CAN BE SOLVED BY NEWTON'S METHOD FOR X AND THEN THE
!  RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GREATER
!  THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
!       NEWTON'S METHOD FOR SOLVING THE EQUATION
!           F(X)=0
!  MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/F'(XOLD).
!  THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
!  THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
!  BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 TIMES
!  (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA TO BE
!  USED FOR INTERPOLATION.
!     THERE ARE SEVERAL POSSIBLE PITFALLS: 
!        1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH MAKES
!           1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOPPED,
!           AND AN ERROR MESSAGE IS PRINTED OUT.
!        2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT X MAY
!           BE NEGATIVE AND LARGE ENOUGH TO MAKE
!           1+X*PATH(P(I),0,CORE,ETA) NEGATIVE. THIS IS CHECKED
!           FOR IN A FINAL LOOP, AND IF TRUE, A WARNING IS PRINTED OUT.
!
!-----------------------------------------------------------------------
      Real,    Intent(IN)  :: RAT
      Integer, Intent(IN)  :: IR
!-----------------------------------------------------------------------

      Real  PA2

      Real(kind_type) :: padi,padim,padim2,PATHA,PATHB,P0,R,REXP,XX,  &
                      ftest1,ftest2,xxlog,F1,F2,F,FPRIME,CHECK,drat
      Real(kind_type) :: PATH0(109),ETAP(109)
      Real(kind_type) :: SINV(4)
      Real(kind_type) :: small

      Integer  i,NP,LL

      Character(len=40) :: err_string

      DATA SINV /2.74992,2.12731,4.38111,.0832926/

!-----------------------------------------------------------------------

      CORE=5.000
      UEXP=0.90
      P0=0.7
      small = epsilon(CORE)

      Do i=1,109
         PA2=PA(i)*PA(i)
         SEXPV(i)=.505+2.0e-5*PA(i)+.035*(PA2-.25)/(PA2+.25)
      EndDo

      Do i=1,109
         ETA(i)=3.2e-4*EXP(-PA(i)/500.)
         ETAP(i)=ETA(i)
      EndDo

      Do NP=1,10

         Do i=3,109
            padi=pa(i)
            padim=pa(i-1)
            padim2=pa(i-2)
            SEXP=SEXPV(i)
            R=(one-TRANSA(i,i-2))/(one-TRANSA(i,i-1))
            REXP=R**(UEXP/SEXP)
            PATHA=(PATH(padi,padim2,CORE,ETA(i)))**UEXP
            PATHB=(PATH(padi,padim,CORE,ETA(i)))**UEXP
            XX=two*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
            Do LL=1,20
               ftest1=xx*patha
               ftest2=xx*pathb
!*** end iteration and solve if ftest1 is small or ftest2 is large
               If (ftest1 <= small) Then
                  xx=one
                  xa(i)=xx
                  ca(i)=(ONE-transa(i,i-2))**(uexp/sexp)/patha
                  GoTo 1011
               EndIf
               If (ftest2 >= 1.0e8) Then
                  xxlog=(Log(patha)-rexp*Log(pathb))/(rexp-ONE)
                  xx=Log(xxlog)
                  xa(i)=xx
                  ca(i)=(ONE-transa(i,i-2))**(uexp/sexp)/(xxlog+Log(patha))
                  GoTo 1011
               EndIf
               F1=Log(ONE+XX*PATHA)
               F2=Log(ONE+XX*PATHB)
               F=F1/F2-REXP
               FPRIME=(F2*PATHA/(ONE+XX*PATHA)-F1*PATHB/(ONE+XX*PATHB))/  &
                          (F2*F2)
               XX=XX-F/FPRIME
               CHECK=ONE+XX*PATHA
               If (CHECK <= 0.0) Then
                  Write  (err_string(1:37),360) i,LL,CHECK
  360             Format ('i=',i3,'LL=',i3,'CHECK=',f20.10)
                  CALL ERROR_MESG ('COEINT in CO2INT_MOD', &
                                    err_string(1:37), FATAL)
               EndIf
            EndDo

            CA(i)=(ONE-TRANSA(i,i-2))**(UEXP/SEXP)/  &
                    (Log(ONE+XX*PATHA)+small)
            XA(i)=XX
 1011    continue
         EndDo

         XA(2)=XA(3)
         XA(1)=XA(3)
         CA(2)=CA(3)
         CA(1)=CA(3)

         Do i=3,109
            padi=pa(i)
            PATH0(i)=(PATH(padi,ZERO,CORE,ETA(i)))**UEXP
            PATH0(i)=ONE+XA(i)*PATH0(i)
            If (PATH0(i) < 0.) then
               Write  (err_string(1:37),361) i
               CALL ERROR_MESG ('COEINT in CO2INT_MOD',   &
                                 err_string(1:37), WARNING)
            Endif
!del        If (PATH0(i) < 0.) Write (*,361) i,PATH0(i),XA(i)
         EndDo

         Do i=1,109
            drat=rat
            SEXP=SEXPV(i)
            ETAP(i)=ETA(i)
            ETA(i)=(SINV(IR)/drat)**(1./SEXP)*(CA(i)*XA(i))**(1./UEXP)
         EndDo

!-----------------------------------------------------------------------
!     THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
!        THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
!      IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
!      S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
!       ALSO,THE DENOMINATOR IS MULTIPLIED BY
!      1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
!        S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
!      ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
!      1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
!      FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
!      (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
!      FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
!      FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
!      FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
!      SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
!        RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
!      LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
!-----------------------------------------------------------------------

!        Write  (*,366) (NP,i,CA(i),XA(i),ETA(i),SEXPV(i),i=1,109)
!366     Format (2i4,4e20.12)

      EndDo

 361  Format ('1+XA*PATH(PA(i),0) IS NEGATIVE,i= ',i3)
!361  Format (' **WARNING:** 1+XA*PATH(PA(i),0) IS NEGATIVE,i= ',i3,  &
!               /,20X,'PATH0(i)=',f16.6,' XA(i)=',f16.6)
!-----------------------------------------------------------------------

      END SUBROUTINE COEINT

!#######################################################################

      SUBROUTINE RCTRNS (ITAP1,ITAP2,RATSTD,RATSM,RATIO,IR)

      Implicit None
!-----------------------------------------------------------------------
!      RATSTD=VALUE OF HIGHER STD CO2 CONCENTRATION
!      RATSM=VALUE OF LOWER STD CO2 CONCENTRATION
!      RATIO=ACTUAL CO2 CONCENTRATION
!      THE 3 ABOVE QUANTITIES ARE IN UNITS OF 330 PPMV.
!-----------------------------------------------------------------------
      Integer, Intent(IN)  :: ITAP1,ITAP2
      Real,    Intent(IN)  :: RATSTD,RATSM,RATIO
      Integer, Intent(IN)  :: IR
!-----------------------------------------------------------------------

      Real :: TRNS1(109,109),TRNS2(109,109)

      Real      P1,P2,TRNSLO,TRNSPR,TRNSPM
      Integer   i,j
!-----------------------------------------------------------------------

!   READ IN TFS OF LOWER STD CO2 CONCENTRATION

      READ   (ITAP1,100) ((TRNS1(i,j),i=1,109),j=1,109)
100   FORMAT (4F20.14)

!   READ IN TFS OF HIGHER STD CO2 CONCENTRATION

      READ (ITAP2,100) ((TRANSA(i,j),i=1,109),j=1,109)

!-----------------------------------------------------------------------

!     CALL COEINT (RATSTD)
      CALL COEINT (RATSTD,IR)

      Do i=1,109
      Do j=1,i
         If (j == i) CYCLE

!  USING HIGHER CO2 CONCENTRATION,COMPUTE 1ST GUESS CO2 TFS FOR
!  ACTUAL CO2 CONCENTRATION.

         P2=(RATIO+RATSTD)*PA(i)/(2.*RATSTD) +  &
            (RATSTD-RATIO)*PA(j)/(2.*RATSTD)
         P1=(RATSTD-RATIO)*PA(i)/(2.*RATSTD) +  &
            (RATIO+RATSTD)*PA(j)/(2.*RATSTD)
         CALL SINTR2 (P1,P2,TRNSLO)
         TRNSPR=TRNSLO

!  USING HIGHER CO2 CONCENTRATION,COMPUTE 1ST GUESS CO2 TFS FOR
!  LOWER STD CO2 CONCENTRATION

         P2=(RATSM+RATSTD)*PA(i)/(2.*RATSTD) +  &
            (RATSTD-RATSM)*PA(j)/(2.*RATSTD)
         P1=(RATSTD-RATSM)*PA(i)/(2.*RATSTD) +  &
            (RATSM+RATSTD)*PA(j)/(2.*RATSTD)
         CALL SINTR2 (P1,P2,TRNSLO)
         TRNSPM=TRNSLO

!  COMPUTE TFS FOR CO2 CONCENTRATION GIVEN BY (RATIO).
!   STORE TEMPORARILY IN (TRNS2)

         TRNS2(j,i)=TRNSPR+(RATSTD-RATIO)*(TRNS1(j,i)-  &
          TRNSPM)/(RATSTD-RATSM)
         TRNS2(i,j)=TRNS2(j,i)

! WE NOW CAN OVERWRITE (TRNS1) AND STORE IN (TRNS1) THE 1ST GUESS
!  CO2 TFS FOR LOWER STD CO2 CONCENTRATION

         TRNS1(j,i)=TRNSLO
         TRNS1(i,j)=TRNSLO

      EndDo
      EndDo

!  SET DIAGONAL VALUES OF CO2 TFS TO UNITY

      Do i=1,109
         TRNS1(i,i)=1.0
         TRNS2(i,i)=1.0
      EndDo

!  NOW OUTPUT THE COMPUTED CO2 TFS FOR (RATIO) CO2 CONC. IN (TRANSA)

      Do i=1,109
      Do j=1,109
         TRANSA(j,i)=TRNS2(j,i)
      EndDo
      EndDo

!-----------------------------------------------------------------------

      END SUBROUTINE RCTRNS

!#######################################################################

      SUBROUTINE QUADSR (N,P,PD1,PD2,TRNS)

      Implicit None
!-----------------------------------------------------------------------
      Integer, Intent(IN)  :: N
      Real,    Intent(IN)  :: P,PD1,PD2
      Real,    Intent(OUT) :: TRNS
!-----------------------------------------------------------------------
!  Note:  PD1=PD(IA), PD2=PD(IA-1), P=P(JA)

      Real     WT(101)
      Real     TRNSNB,DP,PFIX,PVARY,P1,P2,TRNSLO
      Integer  i,kk,N2,N2P

      N2=2*N
      N2P=2*N+1

!------- WEIGHTS ARE CALCULATED ------
      WT(1)=1.
      Do i=1,N
         WT(2*i)=4.
         WT(2*i+1)=1.
      EndDo

      If (N > 1) Then
         Do i=2,N
            WT(2*i-1)=2.
         EndDo
      EndIf

      TRNSNB=0.
!!!!  DP=(PD(IA)-PD(IA-1))/N2
      DP=(PD1-PD2)/N2
      PFIX=P

      Do kk=1,N2P
!!!!     PVARY=PD(IA-1)+(kk-1)*DP
         PVARY=PD2+(kk-1)*DP
         IF (PVARY >= PFIX) P2=PVARY
         IF (PVARY >= PFIX) P1=PFIX
         IF (PVARY <  PFIX) P1=PVARY
         IF (PVARY <  PFIX) P2=PFIX
         CALL SINTR2 (P1,P2,TRNSLO)
         TRNSNB=TRNSNB+TRNSLO*WT(kk)
      EndDo

!!!!  TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
      TRNS       =TRNSNB*DP/(3.*(PD1-PD2))

!-----------------------------------------------------------------------

      END SUBROUTINE QUADSR

!#######################################################################

      SUBROUTINE SINTR2 (P1,P2,TRNSLO)

      Implicit None
!-----------------------------------------------------------------------
      Real,Intent(IN)  :: P1,P2
      Real,Intent(OUT) :: TRNSLO
!-----------------------------------------------------------------------

      Real(kind_type) :: &
      p1d,p2d,padi,padip,padj,padjp,padip2,padjp2,PETA,paieta,         &
      paiet1,ETAP,PIPMPI,UP2P1,suexp,TRIP,TRI,TIJ,TIPJ,TIJP,TIPJP,     &
      UIJ,UIPJ,UIJP,UIPJP,PRODI,PRODIP,PROD,XINT,CINT,AIJ,AIJP,AIPJ,   &
      AIPJP,EIJ,EIPJ,EIJP,EIPJP,DTDJ,DTDPJ,EPIP1,EPIPP1,EPP2P1,TIP2J,  &
      TIP2JP,TI2J2,TIJP2,TIPJP2,UIP2J,UIJP2,UIPJP2,UI2J2,UIP2JP,       &
      AIJP2,AIPJP2,AIP2J,AIP2JP,AI2J2,EIP2J,EIP2JP,EIJP2,EIPJP2,       &
      EI2J2,EI,EP,EP2,EPSIL

      Integer   i,j,k,ieta

!---find indices for pa corresponding to p1 and p2 (to use for 
!   pressure interpolation

      If (p2 <= pa(1)) Then
         i=1
      EndIf

      Do k=1,108
        If (p2 > pa(k).and.p2 <= pa(k+1)) Then
           i=k
        EndIf
      EndDo

      If (p2 > pa(109)) Then
        i=108
      EndIf

      If (p1 <= pa(1)) Then
         j=1
      EndIf

      Do k=1,108
        If (p1 > pa(k) .and. p1 <= pa(k+1)) Then
           j=k
        EndIf
      EndDo

      If (p1 > pa(109)) Then
        j=108
      EndIf

!--define real(kind_type) quantities for pressures used in calc.

      p1d=p1
      p2d=p2
      padi=pa(i)
      padip=pa(i+1)
      padj=pa(j)
      padjp=pa(j+1)
      If (i < 108) padip2=pa(i+2)
      If (j < 108) padjp2=pa(j+2)

!  DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
!    FOR PETA(=0.5*(P1+P2))
      PETA=p2d 

!---if peta=p2d,ieta will equal i
      ieta=i
      paieta=pa(ieta)
      paiet1=pa(ieta+1)
      ETAP=ETA(IETA)+(p2d-paieta)*(ETA(ieta+1)-ETA(IETA))/  &
             (paiet1-paieta)
      SEXP=SEXPV(IETA)+(p2d-paieta)*(SEXPV(ieta+1)-SEXPV(IETA))/  &
             (paiet1-paieta)
      PIPMPI=padip-padi
      UP2P1=(PATH(p2d,p1d,CORE,ETAP))**UEXP
      suexp=sexp/uexp

      If (i <= j) Then
        TRIP=(CA(i+1)*Log(ONE+XA(i+1)*UP2P1))**suexp
        TRI=(CA(i)*Log(ONE+XA(i)*UP2P1))**suexp
        TRNSLO=ONE-((padip-p2d)*TRI+(p2d-padi)*TRIP)/PIPMPI
      EndIf

      If (i > j) Then
         TIJ=TRANSA(i,j)
         TIPJ=TRANSA(i+1,j)
         TIJP=TRANSA(i,j+1)
         TIPJP=TRANSA(i+1,j+1)
         UIJ=(PATH(padi,padj,CORE,ETAP))**UEXP
         UIPJ=(PATH(padip,padj,CORE,ETAP))**UEXP
         UIJP=(PATH(padi,padjp,CORE,ETAP))**UEXP
         UIPJP=(PATH(padip,padjp,CORE,ETAP))**UEXP
         PRODI=CA(i)*XA(i)
         PRODIP=CA(i+1)*XA(i+1)
         PROD=((padip-p2d)*PRODI+(p2d-padi)*PRODIP)/PIPMPI
         XINT=((padip-p2d)*XA(i)+(p2d-padi)*XA(i+1))/PIPMPI
         CINT=PROD/XINT
         AIJ=(CINT*Log(ONE+XINT*UIJ))**suexp
         AIJP=(CINT*Log(ONE+XINT*UIJP))**suexp
         AIPJ=(CINT*Log(ONE+XINT*UIPJ))**suexp
         AIPJP=(CINT*Log(ONE+XINT*UIPJP))**suexp
         EIJ=TIJ+AIJ
         EIPJ=TIPJ+AIPJ
         EIJP=TIJP+AIJP
         EIPJP=TIPJP+AIPJP
         DTDJ=(EIJP-EIJ)/(padjp-padj)
         DTDPJ=(EIPJP-EIPJ)/(padjp-padj)
         EPIP1=EIJ+DTDJ*(p1d-padj)
         EPIPP1=EIPJ+DTDPJ*(p1d-padj)
         EPP2P1=((padip-p2d)*EPIP1+(p2d-padi)*EPIPP1)/PIPMPI
         TRNSLO=EPP2P1-(CINT*Log(ONE+XINT*UP2P1))**suexp
      EndIf

      If (i < 108 .and. j < 108 .and. i > j+2) Then
         TIP2J=TRANSA(i+2,j)
         TIP2JP=TRANSA(i+2,j+1)
         TI2J2=TRANSA(i+2,j+2)
         TIJP2=TRANSA(i,j+2)
         TIPJP2=TRANSA(i+1,j+2)
         UIP2J=(PATH(padip2,padj,CORE,ETAP))**UEXP
         UIJP2=(PATH(padi,padjp2,CORE,ETAP))**UEXP
         UIPJP2=(PATH(padip,padjp2,CORE,ETAP))**UEXP
         UI2J2=(PATH(padip2,padjp2,CORE,ETAP))**UEXP
         UIP2JP=(PATH(padip2,padjp,CORE,ETAP))**UEXP
         AIJP2=(CINT*Log(ONE+XINT*UIJP2))**suexp
         AIPJP2=(CINT*Log(ONE+XINT*UIPJP2))**suexp
         AIP2J=(CINT*Log(ONE+XINT*UIP2J))**suexp
         AIP2JP=(CINT*Log(ONE+XINT*UIP2JP))**suexp
         AI2J2=(CINT*Log(ONE+XINT*UI2J2))**suexp
         EIP2J=TIP2J+AIP2J
         EIP2JP=TIP2JP+AIP2JP
         EIJP2=TIJP2+AIJP2
         EIPJP2=TIPJP2+AIPJP2
         EI2J2=TI2J2+AI2J2
         CALL QINTRP(padj,padjp,padjp2,EIJ,EIJP,EIJP2,p1d,EI)
         CALL QINTRP(padj,padjp,padjp2,EIPJ,EIPJP,EIPJP2,p1d,EP)
         CALL QINTRP(padj,padjp,padjp2,EIP2J,EIP2JP,EI2J2,p1d,EP2)
         CALL QINTRP(padi,padip,padip2,EI,EP,EP2,p2d,EPSIL)
         TRNSLO=EPSIL-(CINT*Log(ONE+XINT*UP2P1))**suexp
      EndIf

!-----------------------------------------------------------------------

      END SUBROUTINE SINTR2

!#######################################################################

      Subroutine Qintrp (XM,X0,XP,FM,F0,FP,X,F)

      Implicit None
!-----------------------------------------------------------------------
      Real(kind_type), Intent(IN)  :: XM,X0,XP,FM,F0,FP,X
      Real(kind_type), Intent(OUT) :: F
!-----------------------------------------------------------------------
      Real(kind_type) :: D1,D2,B,A,DEL

      D1=(FP-F0)/(XP-X0)
      D2=(FM-F0)/(XM-X0)
      B=(D1-D2)/(XP-XM)
      A=D1-B*(XP-X0)
      DEL=(X-X0)
      F=F0+DEL*(A+DEL*B)

!-----------------------------------------------------------------------

      End Subroutine Qintrp

!#######################################################################

      FUNCTION PATH (A,B,C,E)

      Implicit None
      Real(kind_type), Intent(IN) :: A,B,C,E

      Real(kind_type) :: PEXP
      Real(kind_type) :: PATH

      PEXP=1./SEXP
      PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))

      END FUNCTION PATH

!#######################################################################

      End Module co2int_mod




      Module CO2_Data_Mod

!-----------------------------------------------------------------------

      use fs_profile_mod, ONLY:  fs_profile
      Use     co2int_mod, ONLY:  co2int, TRNS
      Use        fms_mod, ONLY:  open_namelist_file, mpp_pe,  &
                                 Error_Mesg, FATAL, close_file,  &
                                 write_version_number, mpp_root_pe, open_file

implicit none
private

!-----------------------------------------------------------------------
!
!   Pretabulated co2 transmission functions, evaluated using the
!   methods of Fels and Schwarzkopf (1981) and Schwarzkopf and
!   Fels (1985). 
!
!-----------------------------------------------------------------------
!
!   co2 transmission functions and temperature and pressure
!   derivatives for the 560-800 cm-1 band. also included are the
!   standard temperatures and the weighting function.
!   This data was formally in COMMON /CO2BD3/.
!
!       CO251    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                     WITH P(SFC)=1013.25 MB
!       CO258    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) 
!                     WITH P(SFC)= ^810 MB
!       CDT51    =  FIRST TEMPERATURE DERIVATIVE OF CO251 
!       CDT58    =  FIRST TEMPERATURE DERIVATIVE OF CO258 
!       C2D51    =  SECOND TEMPERATURE DERIVATIVE OF CO251
!       C2D58    =  SECOND TEMPERATURE DERIVATIVE OF CO251
!       CO2M51   =  TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE 
!                      LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
!                      NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB 
!       CO2M58   =  SAME AS CO2M51,WITH P(SFC)= ^810 MB 
!       CDTM51   =  FIRST TEMPERATURE DERIVATIVE OF CO2M51
!       CDTM58   =  FIRST TEMPERATURE DERIVATIVE OF CO2M58
!       C2DM51   =  SECOND TEMPERATURE DERIVATIVE OF CO2M51 
!       C2DM58   =  SECOND TEMPERATURE DERIVATIVE OF CO2M58 
!       STEMP    =  STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
!                      STRUCTURE WITH P(SFC)=1013.25 MB 
!       GTEMP    =  WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL 
!                      STRUCTURE WITH P(SFC)=1013.25 MB.
!       B0       =  TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN. 
!                      CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
!       B1       =  TEMP. COEFFICIENT, USED ALONG WITH B0 
!       B2       =  TEMP. COEFFICIENT, USED ALONG WITH B0 
!       B3       =  TEMP. COEFFICIENT, USED ALONG WITH B0 

      Real, Allocatable, Dimension(:,:) :: CO251,CO258,CDT51,CDT58
      Real, Allocatable, Dimension(:,:) :: C2D51,C2D58
      Real, Allocatable, Dimension(:)   :: CO2M51,CO2M58,CDTM51,CDTM58
      Real, Allocatable, Dimension(:)   :: C2DM51,C2DM58
      Real, Allocatable, Dimension(:)   :: STEMP,GTEMP
      Real                              :: B0,B1,B2,B3

!-----------------------------------------------------------------------
!
!   co2 transmission functions and temperature and pressure
!   derivatives for the 560-670 cm-1 part of the 15 um co2 band. 
!   This data was formally in COMMON /CO2BD2/.
!
!       CO231    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                     WITH P(SFC)=1013.25 MB
!       CO238    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                     WITH P(SFC)= ^810 MB
!       CDT31    =  FIRST TEMPERATURE DERIVATIVE OF CO231
!       CDT38    =  FIRST TEMPERATURE DERIVATIVE OF CO238
!       C2D31    =  SECOND TEMPERATURE DERIVATIVE OF CO231
!       C2D38    =  SECOND TEMPERATURE DERIVATIVE OF CO231

      Real, Allocatable, Dimension(:) :: CO231,CO238,CDT31,CDT38
      Real, Allocatable, Dimension(:) :: C2D31,C2D38

!-----------------------------------------------------------------------
!
!   co2 transmission functions and temperature and pressure
!   derivatives for the 670-800 part of the 15 um co2 band.
!   This data was formally in COMMON /CO2BD4/.
!
!       CO271    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                     WITH P(SFC)=1013.25 MB
!       CO278    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                     WITH P(SFC)= ^810 MB
!       CDT71    =  FIRST TEMPERATURE DERIVATIVE OF CO271
!       CDT78    =  FIRST TEMPERATURE DERIVATIVE OF CO278
!       C2D71    =  SECOND TEMPERATURE DERIVATIVE OF CO271
!       C2D78    =  SECOND TEMPERATURE DERIVATIVE OF CO271

      Real, Allocatable, Dimension(:) :: CO271,CO278,CDT71,CDT78
      Real, Allocatable, Dimension(:) :: C2D71,C2D78

!-----------------------------------------------------------------------
!
!   co2 transmission functions for the 2270-2380 part of the
!   4.3 um co2 band. THis data was formally in COMMON /CO2BD5/.
!
!       CO211    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                     WITH P(SFC)=1013.25 MB
!       CO218    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                     WITH P(SFC)= ^810 MB

      Real, Allocatable, Dimension(:) :: CO211,CO218

! 
!-----------------------------------------------------------------------

      Integer, Private :: LP1=0,LMAX=0

!-----------------------------------------------------------------------
!------------ VERSION NUMBER ----------------

 character(len=128) :: version = '$Id: co2_data.F90,v 13.0 2006/03/28 21:09:22 fms Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.

!-----------------------------------------------------------------------

      Public   CO2_Data, Write_CO2_Data, Read_CO2_Data, &
               co2_data_init, co2_data_end

      Public   CO251,  CO258,  CDT51,  CDT58,  C2D51,  C2D58,  &
               CO2M51, CO2M58, CDTM51, CDTM58, C2DM51, C2DM58, &
               STEMP,  GTEMP,  B0,     B1,     B2,     B3,     &
               CO231,  CO238,  CDT31,  CDT38,  C2D31,  C2D38,  &
               CO271,  CO278,  CDT71,  CDT78,  C2D71,  C2D78,  &
               CO211,  CO218

      CONTAINS

!#######################################################################

      Subroutine CO2_Data (co2std, ratio, Pref)

      Implicit None
!-----------------------------------------------------------------------
      Real, Intent(IN) :: co2std, ratio
      Real, Intent(IN) :: Pref(:,:)
!-----------------------------------------------------------------------
!   CO2STD = standard co2 vol. mixing ratio (either 300 or 330 ppmv)
!   RATIO  = co2 vol. mixing ratio in units of the standard vol. 
!            mixing ratio (must lie between 0.5 and 4.0)
!   PREF   = reference pressure levels
!-----------------------------------------------------------------------
      Integer    ir,iq,npurp,nkkk,unit1,unit2,m,n,ntap
      Real       co2mix,ccomp
      Real, Dimension(4) :: cstd = (/ 0.5, 1.0, 2.0, 4.0 /)
!-----------------------------------------------------------------------
      Character(len=14), Dimension(3) :: files =  &
         (/ 'INPUT/cns_300_', 'INPUT/cns_330_', 'INPUT/cns_600_' /)
      Character(len=6), Dimension(4) :: bands =  &
        (/ '490850', '490670', '670850', '43um  ' /)
!-----------------------------------------------------------------------


!----- check input values -----

      If (ratio < 0.5 .or. ratio > 4.0)  Call Error_Mesg  &
       ('CO2_Data', 'ratio > 4.0 or ratio < 0.5', FATAL)

      co2mix=co2std*ratio

!-----------------------------------------------------------------------

      B0 = -.51926410E-4
      B1 = -.18113332E-3
      B2 = -.10680132E-5
      B3 = -.67303519E-7

!-----------------------------------------------------------------------
!---------- has this data been previously allocated ? ------------------

      If (Size(Pref,1) .ne. LP1) Then
         LP1=Size(Pref,1); LMAX=LP1-1

         If (Allocated(CDT51)) Then
            DeAllocate (CDT51, CO251, C2D51, CDT58, CO258, C2D58)
            DeAllocate (CDT31, CO231, C2D31, CDT38, CO238, C2D38)
            DeAllocate (CDT71, CO271, C2D71, CDT78, CO278, C2D78)
            DeAllocate (CO211, CO218, STEMP, GTEMP)
            DeAllocate (CDTM51, CO2M51, C2DM51, CDTM58, CO2M58, C2DM58)
         EndIf

!  ----- For the 560-800 cm-1 bandwidth -----

         Allocate (CDT51(LP1,LP1), CO251(LP1,LP1), C2D51(LP1,LP1),  &
                   CDT58(LP1,LP1), CO258(LP1,LP1), C2D58(LP1,LP1))

!  ----- For the 560-670 cm-1 bandwidth -----

         Allocate (CDT31(LP1), CO231(LP1), C2D31(LP1),  &
                   CDT38(LP1), CO238(LP1), C2D38(LP1))

!  ----- For the 670-800 cm-1 bandwidth -----

         Allocate (CDT71(LP1), CO271(LP1), C2D71(LP1),  &
                   CDT78(LP1), CO278(LP1), C2D78(LP1))

!  ----- For the 2270-2380 cm-1 bandwidth -----

         Allocate (CO211(LP1), CO218(LP1))

! ----- For the 560-800 cm-1 bandwidth -----

         Allocate (CDTM51(LMAX), CO2M51(LMAX), C2DM51(LMAX),  &
                   CDTM58(LMAX), CO2M58(LMAX), C2DM58(LMAX))

!  STEMP IS THE US STANDARD ATMOSPHERES,1976,AT N18 PRESSURES
!  WHERE PSTAR=1013.25 MB
!  THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
!  1013250.,WHERE P(K)=PRESSURE,N18 DATA LEVELS FOR PSTAR=
!  1013250.

         Allocate (STEMP(LP1), GTEMP(LP1))

      EndIf

!-----------------------------------------------------------------------
!---- compute profiles -----

      Call fs_profile (Pref,STEMP,GTEMP)

!-----------------------------------------------------------------------
!
!   Use one tape (no interpolation) if the mixing ratio is
!   sufficiently close to the standard value, also do not interpolate
!   if the mixing ratio is sufficiently close to multiples
!   (0.5,2.0,4.0) of the standard value
!
!-----------------------------------------------------------------------

      If (co2std <= 310.) Then
          m=1
      Else if (co2std >  310. .and. co2std <= 350.) Then
          m=2
      Else
          m=3
      EndIf

      Do n=1,4
         ccomp=abs(co2mix-cstd(n)*co2std)
         if (ccomp <= 1.0e-4) then
            ntap=1
            EXIT
         else
            ntap=2
         endif
      EndDo

!-----------------------------------------------------------------------
!        ir=1:  lbl transmissions over 490-850 cm-1
!        ir=2:  lbl transmissions over 490-670 cm-1
!        ir=3:  lbl transmissions over 670-850 cm-1
!        ir=4:  lbl transmissions over 2270-2380 cm-1
!-----------------------------------------------------------------------

      Do ir = 1,4

!-----------------------------------------------------------------------
!
!   read in indices npurp and nkkk.
!   for GCM radiation codes, the values to be used for
!   npurp and nkkk vary with ir as follows:
!     ir=1:   npurp=1,nkkk=3
!     ir=2:   npurp=3,nkkk=3
!     ir=3:   npurp=3,nkkk=3
!     ir=4:   npurp=3,nkkk=1
!
!   read in npurp, an index giving the kinds of interps
!   desired, according to the following values:
!     npurp=1: purpose 1 and purpose 2 calcs. for p(sfc)
!              of 1013.25 and 810.6 mb.
!     npurp=2: purpose 1 calcs. only
!     npurp=3: purpose 2 calcs. only
!   purposes 1 and 2 are explained in comments for subroutine co2int
!
!   read in nkkk, an index giving the no. of temp.'
!   profiles to be calculated. use the following values:'
!     nkkk=1: calculate only the (T0) profile'
!     nkkk=3: calculate the (T0,T+ and T-) profiles'
!             (normal case).'
!      note: if ir=4, nkkk must be 1'
!
!-----------------------------------------------------------------------

         Select Case (ir)
            Case (1)
               npurp=1; nkkk=3
            Case (2:3)
               npurp=3; nkkk=3
            Case (4)
               npurp=3; nkkk=1
         End Select

!-----------------------------------------------------------------------
!
!***open lbl co2 transmission functions pior to executing the interpol-
!   ation pgm. this will be user-dependent. additionally, it depends
!   on ir (freq. range) and on ratio (co2 amt). the files below 
!   assume that ratio lies between 1 and 2, and that the file and
!   directory names are as specified below.
!
!-----------------------------------------------------------------------

         If (ntap == 1) Then
            unit1 = open_file (file=files(m)//bands(ir), action='read')
            unit2 = 0
         EndIf

         If (ntap == 2) Then
            unit1 = open_file (file=files(1)//bands(ir), action='read')
            unit2 = open_file (file=files(3)//bands(ir), action='read')
         EndIf

!-----------------------------------------------------------------------
!----- interpolate co2 transmission fctns -----

         Call co2int (LMAX,ir,npurp,nkkk,unit1,unit2,ratio)  

!RSH     call close_file (unit1, status='keep') 
!RSH     If (ntap == 2) call close_file (unit2, status='keep')
         call close_file (unit1               ) 
         If (ntap == 2) call close_file (unit2               )

!-----------------------------------------------------------------------
!     Load transmission functions into data arrays


         If (ir == 1) Then
            iq=ir
            Call co2ins (LMAX,1,3,iq)
            Call co2in1 (LMAX,2,4,iq)
         Else
            iq=ir
            If (ir == 4) iq=5
            Call co2ins(LMAX,1,2,iq)
         EndIf

!-----------------------------------------------------------------------
      EndDo
!-----------------------------------------------------------------------

      End Subroutine CO2_Data

!#######################################################################

      Subroutine co2ins (nlev,itin,itin1,iq)

      Implicit None
!-----------------------------------------------------------------------
      Integer, Intent(IN) :: nlev,itin,itin1,iq

      Real, Dimension(nlev+1,nlev+1) :: DCDT8,DCDT10,CO2PO,CO2800,  &
                                        CO2PO1,CO2801,CO2PO2,CO2802,  &
                                        D2CT8,D2CT10

      Integer   i,j,L,LP1,JMAX
      Real      C1,C2
!-----------------------------------------------------------------------

      L=nlev
      LP1=L+1

      CO2PO (:,:)=TRNS(:,:,itin ,1)
      CO2800(:,:)=TRNS(:,:,itin1,1)
      If (iq >= 1 .and. iq <= 4) Then
         CO2PO1(:,:)=TRNS(:,:,itin ,2)
         CO2801(:,:)=TRNS(:,:,itin1,2)
         CO2PO2(:,:)=TRNS(:,:,itin ,3)
         CO2802(:,:)=TRNS(:,:,itin1,3)
      EndIf

!-----------------------------------------------------------------------
!   THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS ARE: 
!
!        iq=1    560-800     (CONSOL.=490-850)
!        iq=2    560-670     (CONSOL.=490-670)
!        iq=3    670-800     (CONSOL.=670-850)
!        iq=4    560-760 (ORIGINAL CODE)   (CONSOL.=490-850)
!        iq=5   2270-2380     CONSOL=2270-2380
!
!  THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
!  USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
!  WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF'S.
!      NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
!  COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
!  ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
!  (iq=1,4).  IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
!  WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
!  CALCULATIONS.  ALSO, FOR THE 4.3 UM BAND (iq=5) THE TEMP.
!  DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
!-----------------------------------------------------------------------

      If (iq == 1) Then
         C1=1.5
         C2=0.5
         JMAX=LP1
      EndIf
      If (iq == 2) Then
        C1=18./11.
        C2=7./11.
        JMAX=1
      EndIf
      If (iq == 3) Then
        C1=18./13.
        C2=5./13.
        JMAX=1
      EndIf
      If (iq == 4) Then
        C1=1.8
        C2=0.8
        JMAX=LP1
      EndIf
      If (iq == 5) Then
        C1=1.0
        C2=0.0
        JMAX=1
      EndIf

      Do i=1,LP1
      Do j=1,LP1
         CO2PO(j,i)=C1*CO2PO(j,i)-C2
         CO2800(j,i)=C1*CO2800(j,i)-C2
      EndDo
      EndDo

      If (iq >= 1 .and. iq <= 4) Then
        Do i=1,LP1
        Do j=1,LP1
          CO2PO1(j,i)=C1*CO2PO1(j,i)-C2
          CO2801(j,i)=C1*CO2801(j,i)-C2
          CO2PO2(j,i)=C1*CO2PO2(j,i)-C2
          CO2802(j,i)=C1*CO2802(j,i)-C2
        EndDo
        EndDo
        Do j=1,LP1
        Do i=1,LP1
         DCDT8(i,j)=.02*(CO2801(i,j)-CO2802(i,j))*100.
         DCDT10(i,j)=.02*(CO2PO1(i,j)-CO2PO2(i,j))*100.
         D2CT8(i,j)=.0016*(CO2801(i,j)+CO2802(i,j)-2.*CO2800(i,j))*1000.
         D2CT10(i,j)=.0016*(CO2PO1(i,j)+CO2PO2(i,j)-2.*CO2PO(i,j))*1000.
        EndDo
        EndDo
      EndIf

!-----------------------------------------------------------------------
      If (iq == 1) Then
         CDT51=DCDT10
         CO251=CO2PO
         C2D51=D2CT10
         CDT58=DCDT8
         CO258=CO2800
         C2D58=D2CT8
      EndIf
!-----------------------------------------------------------------------
      If (iq == 2) Then
         CDT31=DCDT10(1,:)
         CO231=CO2PO (1,:)
         C2D31=D2CT10(1,:)
         CDT38=DCDT8 (1,:)
         CO238=CO2800(1,:)
         C2D38=D2CT8 (1,:)
      EndIf
!-----------------------------------------------------------------------
      If (iq == 3) Then
         CDT71=DCDT10(1,:)
         CO271=CO2PO (1,:)
         C2D71=D2CT10(1,:)
         CDT78=DCDT8 (1,:)
         CO278=CO2800(1,:)
         C2D78=D2CT8 (1,:)
      EndIf
!-----------------------------------------------------------------------
      If (iq == 4) Then
         Call Error_Mesg ('co2ins', 'iq cannot equal 4', FATAL)
      EndIf
!-----------------------------------------------------------------------
      If (iq == 5) Then
         CO211=CO2PO (1,:)
         CO218=CO2800(1,:)
      EndIf
!-----------------------------------------------------------------------

      End Subroutine co2ins

!#######################################################################

      Subroutine co2in1 (nlev,itin,itin1,iq)

      Implicit None
!-----------------------------------------------------------------------
!
!                       CO2INS FOR METHOD 1
!
!-----------------------------------------------------------------------

      Integer, Intent(IN)    :: nlev,itin,itin1,iq

      Real,   Dimension(nlev+1,nlev+1) :: DCDT8,DCDT10,CO2PO,CO2800,   &
                                          CO2PO1,CO2801,CO2PO2,CO2802, &
                                          D2CT8,D2CT10

      Integer  L,LP1,i,j
      Real     C1,C2
!-----------------------------------------------------------------------

      L=nlev
      LP1=L+1

      CO2PO (:,:)=TRNS(:,:,itin ,1)
      CO2800(:,:)=TRNS(:,:,itin1,1)
      If (IQ >= 1 .and. IQ <= 4) Then
         CO2PO1(:,:)=TRNS(:,:,itin ,2)
         CO2801(:,:)=TRNS(:,:,itin1,2)
         CO2PO2(:,:)=TRNS(:,:,itin ,3)
         CO2802(:,:)=TRNS(:,:,itin1,3)
      EndIf

!-----------------------------------------------------------------------
!   THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS ARE:
!
!        iq=1    560-800     (CONSOL.=490-850)
!        iq=2    560-670     (CONSOL.=490-670)
!        iq=3    670-800     (CONSOL.=670-850)
!        iq=4    560-760 (ORIGINAL CODE)   (CONSOL.=490-850)
!        iq=5   2270-2380     CONSOL=2270-2380
!
!  THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
!  USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
!  WIDTHS KEPT FROM THE ORIGRNAL CONSOLIDATED CO2 TF'S.
!-----------------------------------------------------------------------

      If (iq == 1) Then
         C1=1.5
         C2=0.5
      EndIf
      If (iq == 2) Then
        C1=18./11.
        C2=7./11.
      EndIf
      If (iq == 3) Then
        C1=18./13.
        C2=5./13.
      EndIf
      If (iq == 4) Then
        C1=1.8
        C2=0.8
      EndIf
      If (iq == 5) Then
        C1=1.0
        C2=0.0
      EndIf

      Do i=1,LP1
      Do j=1,LP1
         CO2PO(j,i)=C1*CO2PO(j,i)-C2
         CO2800(j,i)=C1*CO2800(j,i)-C2
      EndDo
      EndDo

      If (iq >= 1 .and. iq <= 4) Then
        Do i=1,LP1
        Do j=1,LP1
         CO2PO1(j,i)=C1*CO2PO1(j,i)-C2
         CO2801(j,i)=C1*CO2801(j,i)-C2
         CO2PO2(j,i)=C1*CO2PO2(j,i)-C2
         CO2802(j,i)=C1*CO2802(j,i)-C2
        EndDo
        EndDo

        Do j=1,LP1
        Do i=1,LP1
         DCDT8(i,j)=.02*(CO2801(i,j)-CO2802(i,j))*100.
         DCDT10(i,j)=.02*(CO2PO1(i,j)-CO2PO2(i,j))*100.
         D2CT8(i,j)=.0016*(CO2801(i,j)+CO2802(i,j)-2.*CO2800(i,j))*1000.
         D2CT10(i,j)=.0016*(CO2PO1(i,j)+CO2PO2(i,j)-2.*CO2PO(i,j))*1000.
        EndDo
        EndDo
      EndIf

!-----------------------------------------------------------------------
      If (iq == 1) Then
         Do i=1,nlev
            CDTM51(i)=DCDT10(i,i+1)
            CO2M51(i)=CO2PO (i,i+1)
            C2DM51(i)=D2CT10(i,i+1)
            CDTM58(i)=DCDT8 (i,i+1)
            CO2M58(i)=CO2800(i,i+1)
            C2DM58(i)=D2CT8 (i,i+1)
         EndDo
      EndIf
!-----------------------------------------------------------------------

      End Subroutine co2in1

!#######################################################################

      Subroutine Write_CO2_Data

      Implicit None
!-----------------------------------------------------------------------
      Integer  i,k,nlev,nlevp1,unit
!-----------------------------------------------------------------------

      nlevp1=Size(CDT51,1); nlev=nlevp1-1

      unit = open_file (file='co2data', action='write')

      Do k=1,nlevp1; Write (unit,101) (CDT51(i,k),i=1,nlevp1); EndDo
      Do k=1,nlevp1; Write (unit,101) (CO251(i,k),i=1,nlevp1); EndDo
      Do k=1,nlevp1; Write (unit,101) (C2D51(i,k),i=1,nlevp1); EndDo
      Do k=1,nlevp1; Write (unit,101) (CDT58(i,k),i=1,nlevp1); EndDo
      Do k=1,nlevp1; Write (unit,101) (CO258(i,k),i=1,nlevp1); EndDo
      Do k=1,nlevp1; Write (unit,101) (C2D58(i,k),i=1,nlevp1); EndDo

                     Write (unit,101) (CDT31(i),i=1,nlevp1)
                     Write (unit,101) (CO231(i),i=1,nlevp1)
                     Write (unit,101) (C2D31(i),i=1,nlevp1)
                     Write (unit,101) (CDT38(i),i=1,nlevp1)
                     Write (unit,101) (CO238(i),i=1,nlevp1)
                     Write (unit,101) (C2D38(i),i=1,nlevp1)

                     Write (unit,101) (CDT71(i),i=1,nlevp1)
                     Write (unit,101) (CO271(i),i=1,nlevp1)
                     Write (unit,101) (C2D71(i),i=1,nlevp1)
                     Write (unit,101) (CDT78(i),i=1,nlevp1)
                     Write (unit,101) (CO278(i),i=1,nlevp1)
                     Write (unit,101) (C2D78(i),i=1,nlevp1)

                     Write (unit,101) (CO211(i),i=1,nlevp1)
                     Write (unit,101) (CO218(i),i=1,nlevp1)

                     Write (unit,101) (CDTM51(i),i=1,nlev)
                     Write (unit,101) (CO2M51(i),i=1,nlev)
                     Write (unit,101) (C2DM51(i),i=1,nlev)
                     Write (unit,101) (CDTM58(i),i=1,nlev)
                     Write (unit,101) (CO2M58(i),i=1,nlev)
                     Write (unit,101) (C2DM58(i),i=1,nlev)

                     Write (unit,102) (STEMP(i),i=1,nlevp1)
                     Write (unit,103) (GTEMP(i),i=1,nlevp1)

                     call close_file (unit)

 101  Format (6F12.8)
 102  Format (5F13.6)
 103  Format (4E16.9)
!-----------------------------------------------------------------------

      End Subroutine Write_CO2_Data

!#######################################################################

      Subroutine Read_CO2_Data (nlev)

      Implicit None
!-----------------------------------------------------------------------
!     Reads co2 transmission functions from file = INPUT/CO2.data
!-----------------------------------------------------------------------
      Integer, Intent(IN) :: nlev
      Integer  unit,nlevp1,i,k
!-----------------------------------------------------------------------

      If (Allocated(CDT51)) Call Error_Mesg ('Read_CO2_Data',  &
                          'CO2 data has already been allocated.', FATAL)

      nlevp1=nlev+1
      unit = open_file (file='INPUT/CO2.data', action='read')

!   B0,B1,B2,B3 ARE COEFFICIENTS USED TO CORRECT FOR THE USE OF 250K IN
!   THE PLANCK FUNCTION USED IN EVALUATING PLANCK-WEIGHTED CO2
!   TRANSMISSION FUNCTIONS. 


      B0 = -.51926410E-4
      B1 = -.18113332E-3
      B2 = -.10680132E-5
      B3 = -.67303519E-7

 101  Format (6f12.8)
 102  Format (5f13.6)
 103  Format (4f16.9)

!  ----- For the 560-800 cm-1 bandwidth -----

      Allocate (CDT51(nlevp1,nlevp1))
      Allocate (CO251(nlevp1,nlevp1))
      Allocate (C2D51(nlevp1,nlevp1))
      Allocate (CDT58(nlevp1,nlevp1))
      Allocate (CO258(nlevp1,nlevp1))
      Allocate (C2D58(nlevp1,nlevp1))

      Do k=1,nlevp1
        Read (unit,101) (CDT51(i,k),i=1,nlevp1)
      EndDo

      Do k=1,nlevp1
        Read (unit,101) (CO251(i,k),i=1,nlevp1)
      EndDo

      Do k=1,nlevp1
        Read (unit,101) (C2D51(i,k),i=1,nlevp1)
      EndDo

      Do k=1,nlevp1
        Read (unit,101) (CDT58(i,k),i=1,nlevp1)
      EndDo

      Do k=1,nlevp1
        Read (unit,101) (CO258(i,k),i=1,nlevp1)
      EndDo

      Do k=1,nlevp1
        Read (unit,101) (C2D58(i,k),i=1,nlevp1)
      EndDo


!  ----- For the 560-670 cm-1 bandwidth -----

      Allocate (CDT31(nlevp1))
      Allocate (CO231(nlevp1))
      Allocate (C2D31(nlevp1))
      Allocate (CDT38(nlevp1))
      Allocate (CO238(nlevp1))
      Allocate (C2D38(nlevp1))

      Read (unit,101) (CDT31(i),i=1,nlevp1)
      Read (unit,101) (CO231(i),i=1,nlevp1)
      Read (unit,101) (C2D31(i),i=1,nlevp1)
      Read (unit,101) (CDT38(i),i=1,nlevp1)
      Read (unit,101) (CO238(i),i=1,nlevp1)
      Read (unit,101) (C2D38(i),i=1,nlevp1)


!  ----- For the 670-800 cm-1 bandwidth -----

      Allocate (CDT71(nlevp1))
      Allocate (CO271(nlevp1))
      Allocate (C2D71(nlevp1))
      Allocate (CDT78(nlevp1))
      Allocate (CO278(nlevp1))
      Allocate (C2D78(nlevp1))

      Read (unit,101) (CDT71(i),i=1,nlevp1)
      Read (unit,101) (CO271(i),i=1,nlevp1)
      Read (unit,101) (C2D71(i),i=1,nlevp1)
      Read (unit,101) (CDT78(i),i=1,nlevp1)
      Read (unit,101) (CO278(i),i=1,nlevp1)
      Read (unit,101) (C2D78(i),i=1,nlevp1)


!  ----- For the 2270-2380 cm-1 bandwidth -----

      Allocate (CO211(nlevp1))
      Allocate (CO218(nlevp1))

      Read (unit,101) (CO211(i),i=1,nlevp1)
      Read (unit,101) (CO218(i),i=1,nlevp1)


! ----- For the 560-800 cm-1 bandwidth -----

      Allocate (CDTM51(nlev))
      Allocate (CO2M51(nlev))
      Allocate (C2DM51(nlev))
      Allocate (CDTM58(nlev))
      Allocate (CO2M58(nlev))
      Allocate (C2DM58(nlev))

      Read (unit,101) (CDTM51(i),i=1,nlev)
      Read (unit,101) (CO2M51(i),i=1,nlev)
      Read (unit,101) (C2DM51(i),i=1,nlev)
      Read (unit,101) (CDTM58(i),i=1,nlev)
      Read (unit,101) (CO2M58(i),i=1,nlev)
      Read (unit,101) (C2DM58(i),i=1,nlev)


!  STEMP IS THE US STANDARD ATMOSPHERES,1976,AT N18 PRESSURES
!  WHERE PSTAR=1013.25 MB

      Allocate (STEMP(nlevp1))

      Read (unit,102) (STEMP(i),i=1,nlevp1)


!  THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
!  1013250.,WHERE P(K)=PRESSURE,N18 DATA LEVELS FOR PSTAR=
!  1013250.

      Allocate (GTEMP(nlevp1))

      Read (unit,103) (GTEMP(i),i=1,nlevp1)


      call close_file (unit)

!-----------------------------------------------------------------------

      End Subroutine Read_CO2_Data

!#######################################################################

      Subroutine co2_data_init
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------
      End Subroutine co2_data_init

!#######################################################################

      Subroutine co2_data_end

      module_is_initialized = .false.

!---------------------------------------------------------------------

      End Subroutine co2_data_end

!#######################################################################


      End Module CO2_Data_Mod



                         Module FSrad_Mod

!-----------------------------------------------------------------------
!-------------------- PUBLIC Radiation routines ------------------------

      Use        MCM_LW_Mod, ONLY: MCM_LW_Rad
      Use MCM_SW_Driver_Mod, ONLY: mcm_shortwave_driver

      Use   ShortWave_Mod, ONLY: SWRad
      Use    LongWave_Mod, ONLY: LWRad, Rad_DeAlloc
      Use      RdParm_Mod, ONLY: RdParm_Init
      Use    Rad_Diag_Mod, ONLY: Radiag
      Use    CO2_Data_Mod, ONLY: CO2_Data

      Use         Fms_Mod, ONLY: mpp_pe, mpp_root_pe, write_version_number, &
                                 error_mesg, FATAL
      Use   Constants_Mod, ONLY: stefan

      implicit none
      private

      public  FSrad, RdParm_Init, CO2_Data, fsrad_init, fsrad_end
!-----------------------------------------------------------------------

      character(len=128) :: version = '$Id: fsrad.F90,v 14.0 2007/03/15 22:03:19 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical            :: module_is_initialized = .false.

      real, parameter :: Day_Length=86400.
      real, parameter :: RATco2MW=1.519449738
      real, parameter :: PerSec=1./Day_Length

!-----------------------------------------------------------------------

CONTAINS

!#######################################################################

      Subroutine FSrad (ip,jp,Press,Temp,Rh2o,Qo3,              &
                        phalf,do_mcm_radiation,             &
                        Nclds,KtopSW,KbtmSW,Ktop,Kbtm,CldAmt,   &
                        EmCld,CUVRF,CIRRF,CIRAB,Albedo,RVco2,   &
                        CosZ,Solar,                             &
                        SWin,SWout,OLR,SWupS,SWdnS,LWupS,LWdnS, &
                        TdtSW,TdtLW, Ksfc,Psfc)

!-----------------------------------------------------------------------
Integer, Intent(IN)                    :: ip,jp
   Real, Intent(IN), Dimension(:,:,:)  :: Press,Temp,Rh2o,Qo3
   Real, Intent(IN), Dimension(:,:,:)  :: phalf
Logical, Intent(IN)                    :: do_mcm_radiation
Integer, Intent(IN), Dimension(:,:)    :: Nclds
Integer, Intent(IN), Dimension(:,:,:)  :: KtopSW,KbtmSW,Ktop,Kbtm
   Real, Intent(IN), Dimension(:,:,:)  :: CldAmt,EmCld,CUVRF,CIRRF,CIRAB
   Real, Intent(IN), Dimension(:,:)    :: Albedo,CosZ,Solar
   Real, Intent(IN)                    :: RVco2

   Real, Intent(OUT), Dimension(:,:)   :: SWin,SWout,OLR,SWupS,SWdnS,  &
                                                       LWupS,LWdnS
   Real, Intent(OUT), Dimension(:,:,:) :: TdtSW,TdtLW

Integer, Intent(IN), Dimension(:,:), Optional :: Ksfc
   Real, Intent(IN), Dimension(:,:), Optional :: Psfc
!-----------------------------------------------------------------------
   Real, Dimension(Size(Rh2o,1),Size(Rh2o,2),Size(Rh2o,3)+1) ::  &
                                    FSW,DFSW,UFSW
   Real, Dimension(Size(Rh2o,1),Size(Rh2o,2)) :: SSolar,GrnFlux,TopFlux
   Real  Rco2
Logical  SunUp
Integer  i,j,IX,JX,KX
!-----------------------------------------------------------------------


      IX=Size(Rh2o,1)
      JX=Size(Rh2o,2)
      KX=Size(Rh2o,3)

      SunUp=.false.
      Do j=1,JX
      Do i=1,IX
         If (CosZ(i,j) > 0.0) Then
            SunUp=.true.
            EXIT
         EndIf
      EndDo
      EndDo

!-----------------------------------------------------------------------
!----- convert solar constant from W/m2 to ly/min ------

      SSolar = Solar * (6./4186.)

!-----------------------------------------------------------------------
!----------------------- Shortwave Radiation ---------------------------

      If (SunUp) Then
         Rco2=RVco2*RATco2MW

        if ( do_mcm_radiation ) then
         Call mcm_shortwave_driver &
                    (Nclds, KtopSW, KbtmSW, Press, Rh2o, Qo3, CldAmt, &
                     CUVRF, CIRRF, CIRAB, Rco2, CosZ, SSolar,         &
                     Albedo, FSW, DFSW, UFSW, TdtSW, phalf )
        else
         Call SWRad (Nclds, KtopSW, KbtmSW, Press, Rh2o, Qo3, CldAmt, &
                     CUVRF, CIRRF, CIRAB, Rco2, CosZ, SSolar,         &
                     Albedo, FSW, DFSW, UFSW, TdtSW, Ksfc, Psfc       )
        endif

      Else
         FSW=0.0; DFSW=0.0; UFSW=0.0; TdtSW=0.0
      EndIf


!-----------------------------------------------------------------------
!----------------------- Longwave Radiation ----------------------------

      if ( do_mcm_radiation ) then
        Call MCM_LW_Rad (Ktop, Kbtm, Nclds, EmCld, Press, Temp, Rh2o, Qo3,&
                    CldAmt, RVco2, TdtLW, GrnFlux, TopFlux, phalf )
      else
        Call LWRad (Ktop, Kbtm, Nclds, EmCld, Press, Temp, Rh2o, Qo3,  &
                    CldAmt, RVco2, TdtLW, GrnFlux, TopFlux, Ksfc, Psfc )
      endif

!-----------------------------------------------------------------------
!----------------------- Radiation Diagnostics -------------------------
      If (ip > 0 .and. jp > 0) Then
         Call Radiag (Press,Temp,Rh2o,Rco2,Qo3,CldAmt,Ktop,Kbtm,Nclds, &
                      TdtLW,GrnFlux,  FSW,DFSW,UFSW,TdtSW,  &
                      KtopSW,KbtmSW,EmCld,CUVRF,CIRRF,CIRAB,  &
                      Albedo,CosZ,SSolar,   ip,jp)
      EndIf
!-----------------------------------------------------------------------
      if(.not.do_mcm_radiation ) then
        Call Rad_DeAlloc
      endif
!-----------------------------------------------------------------------
!    **** Output fluxes at the top and bottom of atmosphere ****
!            **** convert ergs/cm2/s to watts/m2 ****

!  --- TOA ---
          SWin (:,:)=DFSW(:,:,1)  *1.E-3
          SWout(:,:)=UFSW(:,:,1)  *1.E-3
          OLR  (:,:)=TopFlux(:,:) *1.E-3

!  --- SFC ---
   If (Present(Ksfc) .and. Present(Psfc)) Then
       Do j=1,JX
       Do i=1,IX
          SWupS(i,j)=UFSW(i,j,Ksfc(i,j)+1)*1.E-3
          SWdnS(i,j)=DFSW(i,j,Ksfc(i,j)+1)*1.E-3
          LWupS(i,j)=stefan*Temp(i,j,Ksfc(i,j)+1)**4
       EndDo
       EndDo
   Else
          SWupS(:,:)=UFSW(:,:,KX+1)*1.E-3
          SWdnS(:,:)=DFSW(:,:,KX+1)*1.E-3
          LWupS(:,:)=stefan*Temp(:,:,KX+1)**4
   EndIf
          LWdnS(:,:)=LWupS(:,:)-GrnFlux(:,:)*1.E-3


!-----------------------------------------------------------------------

      TdtSW=TdtSW*PerSec
      TdtLW=TdtLW*PerSec

!-----------------------------------------------------------------------

      End Subroutine FSrad

!#######################################################################

      Subroutine fsrad_init
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      End Subroutine fsrad_init

!#######################################################################

      Subroutine fsrad_end

      module_is_initialized = .false.
!---------------------------------------------------------------------

      End Subroutine fsrad_end

!#######################################################################



                     End Module FSrad_Mod




module fs_profile_mod

use fms_mod, only : mpp_pe, mpp_root_pe, write_version_number, &
                    error_mesg, FATAL

implicit none
private

!-----------------------------------------------------------------------
! **      THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS     **
! **      AND O3 MIXING RATIOS BY USING AN ANALYTICAL                 **
! **      FUNCTION WHICH APPROXIMATES                                 **
! **      THE US STANDARD (1976).  THIS IS                            **
! **      CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE     **
! **      MAIN PROGRAM.  THE FORM OF THE ANALYTICAL FUNCTION WAS      **
! **      SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.              **
!
!*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
!     QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
!     TIONAL RADIATION CODES
!
!    definitions:       
!    -----------
!      pd,pd8: pressures (mb) for data levels. pd is for the case where
!              p(sfc)=1013.25 mb; pd8 applies when p(sfc)=810.6 mb.
!              in either case, index (nlev+1) is at the sfc.
!      press:  same as pd, but with indices reversed,index 1 at the
!              surface, and index (nlev+1) at the top (nonzero) data
!              level.
!-----------------------------------------------------------------------

 Public   fs_profile, fs_profile_init, fs_profile_end

 Real, Public, Allocatable, Dimension(:) :: pd1013,plm1013,pd810,plm810

!------------ VERSION NUMBER ----------------

 character(len=128) :: version = '$Id: fs_profile.F90,v 10.0 2003/10/24 22:00:30 fms Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.

CONTAINS

!#######################################################################

  subroutine fs_profile (Pref,stemp,gtemp)

!-----------------------------------------------------------------------
  Real, Intent(IN) , Dimension(:,:) :: Pref
  Real, Intent(OUT), Dimension(:)   :: stemp,gtemp
!-----------------------------------------------------------------------

  Real,Dimension(Size(Pref,1)) :: press

  Real :: PSMAX = 1013.250

  Real     DELZAP,R,G0,ZMASS,HT,DZ,ZNINT,HTA,RK1,RK2,RK3,RK4,  &
           DLOGP,PSTAR
  Integer  n,m,nlev,NINT
!-----------------------------------------------------------------------

      nlev=Size(Pref,1)-1

      DELZAP=0.5
      R=8.31432
      G0=9.80665
      ZMASS=28.9644

      stemp(nlev+1)=ANTEMP(6,0.0)

!*******DETERMINE THE PRESSURES (press)
      PSTAR=PSMAX

      CALL SIGP (Pref,gtemp)    

!----- convert to mb -----
      Do n=1,nlev+1
         press(n)=Pref(nlev+2-n,1)*0.01
      EndDo
         press(1)=PSTAR

!    *** CALCULATE TEMPS ***

         HTA=0.0

         Do n=1,nlev

! **      ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT     **
! **      INTERVALS OF APPROXIMATELY 'DELZAP' KM.                     **

            DLOGP=7.0*LOG(press(n)/press(n+1))
            NINT=DLOGP/DELZAP
            NINT=NINT+1
            ZNINT=NINT
            DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
            HT=HTA

! **      CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF             **
! **                RUNGE-KUTTA INTEGRATION.                          **

            Do m=1,NINT
               RK1=ANTEMP(6,HT)*DZ
               RK2=ANTEMP(6,HT+0.5*RK1)*DZ
               RK3=ANTEMP(6,HT+0.5*RK2)*DZ
               RK4=ANTEMP(6,HT+RK3)*DZ
               HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
            EndDo
            HTA=HT
            stemp(nlev+1-n)=ANTEMP(6,HT)

         EndDo

!-----------------------------------------------------------------------

  end subroutine fs_profile

!#######################################################################

  Subroutine SigP (Pref,gtemp)

!-----------------------------------------------------------------------
  Real, Intent(IN) , Dimension(:,:) :: Pref
  Real, Intent(OUT), Dimension(:)   :: gtemp
!-----------------------------------------------------------------------

  Real, Dimension(Size(Pref,1)) :: pd, pd8, plm, plm8
  REAL     PSS
  Integer  k,nlev

!     PSS = surface pressure (specified)
!-----------------------------------------------------------------------

      nlev = Size(Pref,1)-1

      If (Allocated(pd1013)) DeAllocate (pd1013, plm1013, pd810, plm810)

      Allocate (pd1013(nlev+1), plm1013(nlev+1),  &
                pd810 (nlev+1), plm810 (nlev+1))

!-----------------------------------------------------------------------
!-------- first pass: PSS=1013.25 MB --------

      PSS = 1013250.

      pd(:)=Pref(:,1)*10.
      pd(nlev+1)=PSS

      plm(1)=0.
      Do k=1,nlev-1
         plm(k+1)=0.5*(pd(k)+pd(k+1))
      EndDo
      plm(nlev+1)=PSS

      Do k=1,nlev
         gtemp(k)=pd(k)**0.2*(1.+pd(k)/30000.)**0.8/1013250.
      EndDo
      gtemp(nlev+1)=0.

!--- pd1013, plm1013 are used by the co2 interpolation prgm (PS=1013mb)
!    THE FOLLOWING PUTS P-DATA INTO MB

       pd1013(:)= pd(:)*1.e-3
      plm1013(:)=plm(:)*1.e-3

!-----------------------------------------------------------------------
!-------- second pass: PSS=810MB, gtemp NOT COMPUTED --------

      PSS=0.8*1013250.

      pd8(:)=Pref(:,2)*10.
      pd8(nlev+1)=PSS

      plm8(1)=0.
      Do k=1,nlev-1
         plm8(k+1)=0.5*(pd8(k)+pd8(k+1))
      EndDo
      plm8(nlev+1)=PSS

!--- pd810, plm810 are used by the co2 interpolation prgm (PS=810mb)
!    THE FOLLOWING PUTS P-DATA INTO MB

       pd810(:)= pd8(:)*1.e-3
      plm810(:)=plm8(:)*1.e-3

!-----------------------------------------------------------------------

  End Subroutine SigP

!#######################################################################

  FUNCTION ANTEMP (L,Z)

!-----------------------------------------------------------------------
  Integer, Intent(IN)  :: L
  Real,    Intent(IN)  :: Z
  Real                 :: ANTEMP
!-----------------------------------------------------------------------
  Real    ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
  Real    temp,expo,x,y,zlog,expp,faclog
  Integer nlast,n

!--------------- TROPICAL SOUNDING -------------------------------------
      Data (ZB(n,1),n=1,10)/   2.0,   3.0,   16.5,  21.5,  45., &
                              51.0,  70.0,  100.,  200.,  300.  /
      Data (C(n,1),n=1,11)/   -6.0,  -4.0,  -6.7,   4.0,   2.2,  &
                               1.0,  -2.8,  -.27,   0.0,   0.0,  0.0 /
      Data (DELTA(n,1),n=1,10)/ .5,    .5,    .3,    .5,   1.0,  &
                               1.0,   1.0,   1.0,   1.0,   1.0   /
!--------------- SUB-TROPICAL SUMMER -----------------------------------
      Data (ZB(n,2),n=1,10)/  1.5,   6.5,  13.0,  18.0,  26.0,  &
                             36.0,  48.0,  50.0, 70.0,  100./
      Data (C(n,2),n=1,11)/  -4.0,  -6.0,  -6.5,   0.0,   1.2,  &
                              2.2,   2.5,   0.0,  -3.0,  -0.25,  0.0/
      Data (DELTA(n,2),n=1,10)/ .5,  1.0,    .5,    .5,   1.0,  &
                               1.0,  2.5,    .5,   1.0,   1.0/
!--------------- SUB-TROPICAL WINTER -----------------------------------
      Data (ZB(n,3),n=1,10)/ 3.0,  10.0,  19.0,  25.0,  32.0,  &
                              44.5, 50.0,  71.0,  98.0,  200.0/
      Data (C(n,3),n=1,11)/  -3.5,  -6.0,  -0.5,  0.0,   0.4,  &
                              3.2,   1.6,  -1.8, -0.7,   0.0,   0.0/
      Data (DELTA(n,3),n=1,10)/ .5,   .5,  1.0,   1.0,   1.0,  &
                               1.0,  1.0,  1.0,   1.0,   1.0/
!--------------- SUB-ARCTIC SUMMER -------------------------------------
      Data (ZB(n,4),n=1,10)/ 4.7, 10.0,  23.0,  31.8,  44.0,  &
                              50.2, 69.2, 100.0, 102.0, 103.0/
      Data (C(n,4),n=1,11)/  -5.3, -7.0,   0.0,  1.4,   3.0,  &
                              0.7, -3.3,  -0.2,  0.0,   0.0,  0.0/
      Data (DELTA(n,4),n=1,10)/ .5,   .3,  1.0,   1.0,   2.0,  &
                               1.0,  1.5,  1.0,   1.0,   1.0/
!------------- SUB-ARCTIC WINTER ---------------------------------------
      Data (ZB(n,5),n=1,10)/ 1.0,   3.2,   8.5,   15.5,   25.0,  &
                              30.0,  35.0,  50.0,  70.0,  100.0/
      Data (C(n,5),n=1,11)/  3.0,  -3.2,  -6.8,  0.0,  -0.6,  &
                             1.0,   1.2,   2.5, -0.7,  -1.2,  0.0/
      Data (DELTA(n,5),n=1,10)/ .4,   1.5,    .3 ,   .5,   1.0,  &
                               1.0,   1.0,   1.0,   1.0,   1.0/
!------------- US STANDARD 1976 ----------------------------------------
      Data (ZB(n,6),n=1,10)/ 11.0,  20.0,  32.0,  47.0,  51.0,  &
                             71.0,  84.8520,  90.0,  91.0,  92.0/
      Data (C(n,6),n=1,11)/ -6.5,   0.0,   1.0,   2.80,  0.0,  &
                            -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
      Data (DELTA(n,6),n=1,10)/ 0.3,   1.0,   1.0,   1.0,   1.0,  &
                                1.0,   1.0,   1.0,   1.0,   1.0/

!------------- ENLARGED US STANDARD 1976 -------------------------------
      Data (ZB(n,7),n=1,10)/ 11.0,  20.0,  32.0,  47.0,  51.0,  &
                             71.0,  84.8520,  90.0,  91.0,  92.0/
      Data (C(n,7),n=1,11)/ -6.5,   0.0,   1.0,   2.80,  0.0,  &
                            -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
      Data (DELTA(n,7),n=1,10)/ 0.3,   1.0,   1.0,   1.0,   1.0,  &
                                1.0,   1.0,   1.0,   1.0,   1.0/


      Data TSTAR / 300.0,  294.0,  272.2,  287.0,  257.1, 2*288.15/

!-----------------------------------------------------------------------

      nlast=10
      temp=TSTAR(L)+C(1,L)*Z

      Do n=1,nlast
         expo=(Z-ZB(n,L))/DELTA(n,L)
         If (abs(expo) <= 60.) Then
            x=exp(expo)
            y=x+1.0/x
            zlog=log(y)
         Else
            zlog=abs(expo)
         EndIf
         expp=ZB(n,L)/DELTA(n,L)
         If (abs(expp) <= 60.) Then
            x=exp(expp)
            y=x+1.0/x
            faclog=log(y)
         Else
            faclog=abs(expp)
         EndIf
         temp=temp+(C(n+1,L)-C(n,L))*0.5*(Z+DELTA(n,L)*(zlog-faclog))
      EndDo

      ANTEMP=temp

!-----------------------------------------------------------------------

  END FUNCTION ANTEMP

!#######################################################################

      Subroutine fs_profile_init
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      End Subroutine fs_profile_init

!#######################################################################

      Subroutine fs_profile_end

      module_is_initialized = .false.
!---------------------------------------------------------------------

      End Subroutine fs_profile_end

!#######################################################################

end module fs_profile_mod




                   MODULE HCONST_MOD

!-----------------------------------------------------------------------
!     ----- The following are physical constants -----

           REAL,PARAMETER :: AMOLWT   = 28.9644
           REAL,PARAMETER :: CSUBP    = 1.00484E7 
           REAL,PARAMETER :: DIFFCTR  = 1.66
           REAL,PARAMETER :: GRAV     = 980.665 
           REAL,PARAMETER :: GINV     = 1./GRAV 
           REAL,PARAMETER :: GRAVDR   = 980.0
           REAL,PARAMETER :: O3DIFCTR = 1.90 
           REAL,PARAMETER :: P0       = 1013250. 
           REAL,PARAMETER :: P0INV    = 1./P0 
           REAL,PARAMETER :: GP0INV   = GINV*P0INV 
           REAL,PARAMETER :: P0XZP2   = 202649.902 
           REAL,PARAMETER :: P0XZP8   = 810600.098 
           REAL,PARAMETER :: P0X2     = 2.*1013250.
           REAL,PARAMETER :: RADCON   = 8.427
           REAL,PARAMETER :: RADCON1  = 1./8.427
           REAL,PARAMETER :: RATCO2MW = 1.519449738
           REAL,PARAMETER :: RATH2OMW = 0.622 
           REAL,PARAMETER :: RGAS     = 8.3142E7 
           REAL,PARAMETER :: RGASSP   = 8.31432E7
           REAL,PARAMETER :: SECPDA   = 8.64E4 

!-----------------------------------------------------------------------

                  END MODULE HCONST_MOD




                        MODULE LONGWAVE_MOD

!-----------------------------------------------------------------------

      USE RDPARM_MOD, ONLY: LMAX
      USE RDPARM_MOD, ONLY: LM1,LP1,LP2,LL,LLP1,LLM1,LP1M,LP1V,LL3P
      USE RDPARM_MOD, ONLY: NBLW,NBLX,NBLY,NBLM,INLTE,INLTEP,NNLTE

      USE HCONST_MOD, ONLY: DIFFCTR,GINV,P0,P0INV,GP0INV,P0XZP2,P0XZP8
      USE HCONST_MOD, ONLY: RADCON,RADCON1,RATH2OMW,SECPDA

      Use    FMS_Mod, ONLY:  Error_Mesg, FATAL, NOTE, mpp_pe, &
                             mpp_root_pe, write_version_number

      Use CO2_Data_Mod, ONLY:  CO251,CO258,CDT51,CDT58,C2D51,C2D58, &
                               CO2M51,CO2M58,CDTM51,CDTM58,C2DM51,  &
                               C2DM58, STEMP,GTEMP, B0,B1,B2,B3
      Use CO2_Data_Mod, ONLY:  CO231,CO238,CDT31,CDT38,C2D31,C2D38
      Use CO2_Data_Mod, ONLY:  CO271,CO278,CDT71,CDT78,C2D71,C2D78
      Use CO2_Data_Mod, ONLY:  CO211,CO218


!     -----------------------------------------------------------
implicit none
private

!-----------------------------------------------------------------------
!--------------------- G L O B A L   D A T A ---------------------------
!-----------------------------------------------------------------------
!
!    Random band parameters for the longwave calcualtions using
!    10 cm-1 wide bands. The 15 um co2 complex is 2 bands,
!    560-670 and 670-800 cm-1. Ozone coefficients are in 3 bands,
!    670-800 (14.1 um), 990-1070 and 1070-1200 (9.6 um).
!    The (NBLW) bands now include: 
!
!                56 BANDS, 10  CM-1 WIDE    0  -   560  CM-1
!                 2 BANDS, 15 UM COMPLEX  560  -   670  CM-1
!                                         670  -   800  CM-1
!                 3 "CONTINUUM" BANDS     800  -   900  CM-1
!                                         900  -   990  CM-1
!                                        1070  -   1200 CM-1
!                 1 BAND FOR 9.6 UM BAND  990  -   1070 CM-1
!               100 BANDS, 10 CM-1 WIDE  1200  -   2200 CM-1
!                 1 BAND FOR 4.3 UM SRC  2270  -   2380 CM-1
!
!    Thus NBLW presently equals    163
!    All bands are arranged in order of increasing wavenumbers.
! 
!      ARNDM   =   RANDOM "A" PARAMETER FOR (NBLW) BANDS
!      BRNDM   =   RANDOM "B" PARAMETER FOR (NBLW) BANDS
!      BETAD   =   CONTINUUM COEFFICIENTS FOR (NBLW) BANDS
!      AP,BP   =   CAPPHI COEFFICIENTS FOR (NBLW) BANDS 
!      ATP,BTP =   CAPPSI COEFFICIENTS FOR (NBLW) BANDS 
!      BANDLO  =   LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS 
!      BANDHI  =   HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS
!      AO3RND  =   RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE
!                  BANDS.
!      BO3RND  =   RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE
!                  BANDS
!      AB15    =   THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS
!                  REPRESENTING THE 15 UM BAND COMPLEX OF CO2 
!
!     Data for ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND are obtained
!     by using the AFGL 1982 catalog. Continuum coefficients are from
!     Roberts (1976). This data was formerly in COMMON /BANDTA/.

      REAL  ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), &
            BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW),    &
            BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2)

!     ----------------------------------------------------------
!     The following data statements are band parameters obtained
!     using the 1982 AFGL catalog on the specified bands.
!     ----------------------------------------------------------

      DATA AO3RND /0.543368E+02,  0.234676E+04,  0.384881E+02/
      DATA BO3RND /0.526064E+01,  0.922424E+01,  0.496515E+01/

      integer :: i
      DATA (ARNDM(i),i=1,64) /                                      &
         0.354693E+00,  0.269857E+03,  0.167062E+03,  0.201314E+04, &
         0.964533E+03,  0.547971E+04,  0.152933E+04,  0.599429E+04, &
         0.699329E+04,  0.856721E+04,  0.962489E+04,  0.233348E+04, &
         0.127091E+05,  0.104383E+05,  0.504249E+04,  0.181227E+05, &
         0.856480E+03,  0.136354E+05,  0.288635E+04,  0.170200E+04, &
         0.209761E+05,  0.126797E+04,  0.110096E+05,  0.336436E+03, &
         0.491663E+04,  0.863701E+04,  0.540389E+03,  0.439786E+04, &
         0.347836E+04,  0.130557E+03,  0.465332E+04,  0.253086E+03, &
         0.257387E+04,  0.488041E+03,  0.892991E+03,  0.117148E+04, &
         0.125880E+03,  0.458852E+03,  0.142975E+03,  0.446355E+03, &
         0.302887E+02,  0.394451E+03,  0.438112E+02,  0.348811E+02, &
         0.615503E+02,  0.143165E+03,  0.103958E+02,  0.725108E+02, &
         0.316628E+02,  0.946456E+01,  0.542675E+02,  0.351557E+02, &
         0.301797E+02,  0.381010E+01,  0.126319E+02,  0.548010E+01, &
         0.600199E+01,  0.640803E+00,  0.501549E-01,  0.167961E-01, &
         0.178110E-01,  0.170166E+00,  0.273514E-01,  0.983767E+00/
      DATA (ARNDM(i),i=65,128)  /                                   &
         0.753946E+00,  0.941763E-01,  0.970547E+00,  0.268862E+00, &
         0.564373E+01,  0.389794E+01,  0.310955E+01,  0.128235E+01, &
         0.196414E+01,  0.247113E+02,  0.593435E+01,  0.377552E+02, &
         0.305173E+02,  0.852479E+01,  0.116780E+03,  0.101490E+03, &
         0.138939E+03,  0.324228E+03,  0.683729E+02,  0.471304E+03, &
         0.159684E+03,  0.427101E+03,  0.114716E+03,  0.106190E+04, &
         0.294607E+03,  0.762948E+03,  0.333199E+03,  0.830645E+03, &
         0.162512E+04,  0.525676E+03,  0.137739E+04,  0.136252E+04, &
         0.147164E+04,  0.187196E+04,  0.131118E+04,  0.103975E+04, &
         0.621637E+01,  0.399459E+02,  0.950648E+02,  0.943161E+03, &
         0.526821E+03,  0.104150E+04,  0.905610E+03,  0.228142E+04, &
         0.806270E+03,  0.691845E+03,  0.155237E+04,  0.192241E+04, &
         0.991871E+03,  0.123907E+04,  0.457289E+02,  0.146146E+04, &
         0.319382E+03,  0.436074E+03,  0.374214E+03,  0.778217E+03, &
         0.140227E+03,  0.562540E+03,  0.682685E+02,  0.820292E+02, &
         0.178779E+03,  0.186150E+03,  0.383864E+03,  0.567416E+01/
      DATA (ARNDM(i),i=129,163)  /                                  &
         0.225129E+03,  0.473099E+01,  0.753149E+02,  0.233689E+02, &
         0.339802E+02,  0.108855E+03,  0.380016E+02,  0.151039E+01, &
         0.660346E+02,  0.370165E+01,  0.234169E+02,  0.440206E+00, &
         0.615283E+01,  0.304077E+02,  0.117769E+01,  0.125248E+02, &
         0.142652E+01,  0.241831E+00,  0.483721E+01,  0.226357E-01, &
         0.549835E+01,  0.597067E+00,  0.404553E+00,  0.143584E+01, &
         0.294291E+00,  0.466273E+00,  0.156048E+00,  0.656185E+00, &
         0.172727E+00,  0.118349E+00,  0.141598E+00,  0.588581E-01, &
         0.919409E-01,  0.155521E-01,  0.537083E-02/

      DATA (BRNDM(i),i=1,64)  /                                     &
         0.789571E-01,  0.920256E-01,  0.696960E-01,  0.245544E+00, &
         0.188503E+00,  0.266127E+00,  0.271371E+00,  0.330917E+00, &
         0.190424E+00,  0.224498E+00,  0.282517E+00,  0.130675E+00, &
         0.212579E+00,  0.227298E+00,  0.138585E+00,  0.187106E+00, &
         0.194527E+00,  0.177034E+00,  0.115902E+00,  0.118499E+00, &
         0.142848E+00,  0.216869E+00,  0.149848E+00,  0.971585E-01, &
         0.151532E+00,  0.865628E-01,  0.764246E-01,  0.100035E+00, &
         0.171133E+00,  0.134737E+00,  0.105173E+00,  0.860832E-01, &
         0.148921E+00,  0.869234E-01,  0.106018E+00,  0.184865E+00, &
         0.767454E-01,  0.108981E+00,  0.123094E+00,  0.177287E+00, &
         0.848146E-01,  0.119356E+00,  0.133829E+00,  0.954505E-01, &
         0.155405E+00,  0.164167E+00,  0.161390E+00,  0.113287E+00, &
         0.714720E-01,  0.741598E-01,  0.719590E-01,  0.140616E+00, &
         0.355356E-01,  0.832779E-01,  0.128680E+00,  0.983013E-01, &
         0.629660E-01,  0.643346E-01,  0.717082E-01,  0.629730E-01, &
         0.875182E-01,  0.857907E-01,  0.358808E+00,  0.178840E+00/
      DATA (BRNDM(i),i=65,128)  /                                   &
         0.254265E+00,  0.297901E+00,  0.153916E+00,  0.537774E+00, &
         0.267906E+00,  0.104254E+00,  0.400723E+00,  0.389670E+00, &
         0.263701E+00,  0.338116E+00,  0.351528E+00,  0.267764E+00, &
         0.186419E+00,  0.238237E+00,  0.210408E+00,  0.176869E+00, &
         0.114715E+00,  0.173299E+00,  0.967770E-01,  0.172565E+00, &
         0.162085E+00,  0.157782E+00,  0.886832E-01,  0.242999E+00, &
         0.760298E-01,  0.164248E+00,  0.221428E+00,  0.166799E+00, &
         0.312514E+00,  0.380600E+00,  0.353828E+00,  0.269500E+00, &
         0.254759E+00,  0.285408E+00,  0.159764E+00,  0.721058E-01, &
         0.170528E+00,  0.231595E+00,  0.307184E+00,  0.564136E-01, &
         0.159884E+00,  0.147907E+00,  0.185666E+00,  0.183567E+00, &
         0.182482E+00,  0.230650E+00,  0.175348E+00,  0.195978E+00, &
         0.255323E+00,  0.198517E+00,  0.195500E+00,  0.208356E+00, &
         0.309603E+00,  0.112011E+00,  0.102570E+00,  0.128276E+00, &
         0.168100E+00,  0.177836E+00,  0.105533E+00,  0.903330E-01, &
         0.126036E+00,  0.101430E+00,  0.124546E+00,  0.221406E+00/
      DATA (BRNDM(i),i=129,163)  /                                  &
         0.137509E+00,  0.911365E-01,  0.724508E-01,  0.795788E-01, &
         0.137411E+00,  0.549175E-01,  0.787714E-01,  0.165544E+00, &
         0.136484E+00,  0.146729E+00,  0.820496E-01,  0.846211E-01, &
         0.785821E-01,  0.122527E+00,  0.125359E+00,  0.101589E+00, &
         0.155756E+00,  0.189239E+00,  0.999086E-01,  0.480993E+00, &
         0.100233E+00,  0.153754E+00,  0.130780E+00,  0.136136E+00, &
         0.159353E+00,  0.156634E+00,  0.272265E+00,  0.186874E+00, &
         0.192090E+00,  0.135397E+00,  0.131497E+00,  0.127463E+00, &
         0.227233E+00,  0.190562E+00,  0.214005E+00/

      DATA (BANDLO(i),i=1,64)  /                                    &
         0.000000E+00,  0.100000E+02,  0.200000E+02,  0.300000E+02, &
         0.400000E+02,  0.500000E+02,  0.600000E+02,  0.700000E+02, &
         0.800000E+02,  0.900000E+02,  0.100000E+03,  0.110000E+03, &
         0.120000E+03,  0.130000E+03,  0.140000E+03,  0.150000E+03, &
         0.160000E+03,  0.170000E+03,  0.180000E+03,  0.190000E+03, &
         0.200000E+03,  0.210000E+03,  0.220000E+03,  0.230000E+03, &
         0.240000E+03,  0.250000E+03,  0.260000E+03,  0.270000E+03, &
         0.280000E+03,  0.290000E+03,  0.300000E+03,  0.310000E+03, &
         0.320000E+03,  0.330000E+03,  0.340000E+03,  0.350000E+03, &
         0.360000E+03,  0.370000E+03,  0.380000E+03,  0.390000E+03, &
         0.400000E+03,  0.410000E+03,  0.420000E+03,  0.430000E+03, &
         0.440000E+03,  0.450000E+03,  0.460000E+03,  0.470000E+03, &
         0.480000E+03,  0.490000E+03,  0.500000E+03,  0.510000E+03, &
         0.520000E+03,  0.530000E+03,  0.540000E+03,  0.550000E+03, &
         0.560000E+03,  0.670000E+03,  0.800000E+03,  0.900000E+03, &
         0.990000E+03,  0.107000E+04,  0.120000E+04,  0.121000E+04/
      DATA (BANDLO(i),i=65,128)  /                                  &
         0.122000E+04,  0.123000E+04,  0.124000E+04,  0.125000E+04, &
         0.126000E+04,  0.127000E+04,  0.128000E+04,  0.129000E+04, &
         0.130000E+04,  0.131000E+04,  0.132000E+04,  0.133000E+04, &
         0.134000E+04,  0.135000E+04,  0.136000E+04,  0.137000E+04, &
         0.138000E+04,  0.139000E+04,  0.140000E+04,  0.141000E+04, &
         0.142000E+04,  0.143000E+04,  0.144000E+04,  0.145000E+04, &
         0.146000E+04,  0.147000E+04,  0.148000E+04,  0.149000E+04, &
         0.150000E+04,  0.151000E+04,  0.152000E+04,  0.153000E+04, &
         0.154000E+04,  0.155000E+04,  0.156000E+04,  0.157000E+04, &
         0.158000E+04,  0.159000E+04,  0.160000E+04,  0.161000E+04, &
         0.162000E+04,  0.163000E+04,  0.164000E+04,  0.165000E+04, &
         0.166000E+04,  0.167000E+04,  0.168000E+04,  0.169000E+04, &
         0.170000E+04,  0.171000E+04,  0.172000E+04,  0.173000E+04, &
         0.174000E+04,  0.175000E+04,  0.176000E+04,  0.177000E+04, &
         0.178000E+04,  0.179000E+04,  0.180000E+04,  0.181000E+04, &
         0.182000E+04,  0.183000E+04,  0.184000E+04,  0.185000E+04/
      DATA (BANDLO(i),i=129,163)  /                                 &
         0.186000E+04,  0.187000E+04,  0.188000E+04,  0.189000E+04, &
         0.190000E+04,  0.191000E+04,  0.192000E+04,  0.193000E+04, &
         0.194000E+04,  0.195000E+04,  0.196000E+04,  0.197000E+04, &
         0.198000E+04,  0.199000E+04,  0.200000E+04,  0.201000E+04, &
         0.202000E+04,  0.203000E+04,  0.204000E+04,  0.205000E+04, &
         0.206000E+04,  0.207000E+04,  0.208000E+04,  0.209000E+04, &
         0.210000E+04,  0.211000E+04,  0.212000E+04,  0.213000E+04, &
         0.214000E+04,  0.215000E+04,  0.216000E+04,  0.217000E+04, &
         0.218000E+04,  0.219000E+04,  0.227000E+04/

      DATA (BANDHI(i),i=1,64)  /                                    &
         0.100000E+02,  0.200000E+02,  0.300000E+02,  0.400000E+02, &
         0.500000E+02,  0.600000E+02,  0.700000E+02,  0.800000E+02, &
         0.900000E+02,  0.100000E+03,  0.110000E+03,  0.120000E+03, &
         0.130000E+03,  0.140000E+03,  0.150000E+03,  0.160000E+03, &
         0.170000E+03,  0.180000E+03,  0.190000E+03,  0.200000E+03, &
         0.210000E+03,  0.220000E+03,  0.230000E+03,  0.240000E+03, &
         0.250000E+03,  0.260000E+03,  0.270000E+03,  0.280000E+03, &
         0.290000E+03,  0.300000E+03,  0.310000E+03,  0.320000E+03, &
         0.330000E+03,  0.340000E+03,  0.350000E+03,  0.360000E+03, &
         0.370000E+03,  0.380000E+03,  0.390000E+03,  0.400000E+03, &
         0.410000E+03,  0.420000E+03,  0.430000E+03,  0.440000E+03, &
         0.450000E+03,  0.460000E+03,  0.470000E+03,  0.480000E+03, &
         0.490000E+03,  0.500000E+03,  0.510000E+03,  0.520000E+03, &
         0.530000E+03,  0.540000E+03,  0.550000E+03,  0.560000E+03, &
         0.670000E+03,  0.800000E+03,  0.900000E+03,  0.990000E+03, &
         0.107000E+04,  0.120000E+04,  0.121000E+04,  0.122000E+04/
      DATA (BANDHI(i),i=65,128)  /                                  &
         0.123000E+04,  0.124000E+04,  0.125000E+04,  0.126000E+04, &
         0.127000E+04,  0.128000E+04,  0.129000E+04,  0.130000E+04, &
         0.131000E+04,  0.132000E+04,  0.133000E+04,  0.134000E+04, &
         0.135000E+04,  0.136000E+04,  0.137000E+04,  0.138000E+04, &
         0.139000E+04,  0.140000E+04,  0.141000E+04,  0.142000E+04, &
         0.143000E+04,  0.144000E+04,  0.145000E+04,  0.146000E+04, &
         0.147000E+04,  0.148000E+04,  0.149000E+04,  0.150000E+04, &
         0.151000E+04,  0.152000E+04,  0.153000E+04,  0.154000E+04, &
         0.155000E+04,  0.156000E+04,  0.157000E+04,  0.158000E+04, &
         0.159000E+04,  0.160000E+04,  0.161000E+04,  0.162000E+04, &
         0.163000E+04,  0.164000E+04,  0.165000E+04,  0.166000E+04, &
         0.167000E+04,  0.168000E+04,  0.169000E+04,  0.170000E+04, &
         0.171000E+04,  0.172000E+04,  0.173000E+04,  0.174000E+04, &
         0.175000E+04,  0.176000E+04,  0.177000E+04,  0.178000E+04, &
         0.179000E+04,  0.180000E+04,  0.181000E+04,  0.182000E+04, &
         0.183000E+04,  0.184000E+04,  0.185000E+04,  0.186000E+04/
      DATA (BANDHI(i),i=129,163)  /                                 &
         0.187000E+04,  0.188000E+04,  0.189000E+04,  0.190000E+04, &
         0.191000E+04,  0.192000E+04,  0.193000E+04,  0.194000E+04, &
         0.195000E+04,  0.196000E+04,  0.197000E+04,  0.198000E+04, &
         0.199000E+04,  0.200000E+04,  0.201000E+04,  0.202000E+04, &
         0.203000E+04,  0.204000E+04,  0.205000E+04,  0.206000E+04, &
         0.207000E+04,  0.208000E+04,  0.209000E+04,  0.210000E+04, &
         0.211000E+04,  0.212000E+04,  0.213000E+04,  0.214000E+04, &
         0.215000E+04,  0.216000E+04,  0.217000E+04,  0.218000E+04, &
         0.219000E+04,  0.220000E+04,  0.238000E+04/

      DATA (AP(i),i=1,64)  /                                        &
        -0.675950E-02, -0.909459E-02, -0.800214E-02, -0.658673E-02, &
        -0.245580E-02, -0.710464E-02, -0.205565E-02, -0.446529E-02, &
        -0.440265E-02, -0.593625E-02, -0.201913E-02, -0.349169E-02, &
        -0.209324E-02, -0.127980E-02, -0.388007E-02, -0.140542E-02, &
         0.518346E-02, -0.159375E-02,  0.250508E-02,  0.132182E-01, &
        -0.903779E-03,  0.110959E-01,  0.924528E-03,  0.207428E-01, &
         0.364166E-02,  0.365229E-02,  0.884367E-02,  0.617260E-02, &
         0.701340E-02,  0.184265E-01,  0.992822E-02,  0.908582E-02, &
         0.106581E-01,  0.276268E-02,  0.158414E-01,  0.145747E-01, &
         0.453080E-02,  0.214767E-01,  0.553895E-02,  0.195031E-01, &
         0.237016E-01,  0.112371E-01,  0.275977E-01,  0.188833E-01, &
         0.131079E-01,  0.130019E-01,  0.385122E-01,  0.111768E-01, &
         0.622620E-02,  0.194397E-01,  0.134360E-01,  0.207829E-01, &
         0.147960E-01,  0.744479E-02,  0.107564E-01,  0.181562E-01, &
         0.170062E-01,  0.233303E-01,  0.256735E-01,  0.274745E-01, &
         0.279259E-01,  0.197002E-01,  0.140268E-01,  0.185933E-01/
      DATA (AP(i),i=65,128)  /                                      &
         0.169525E-01,  0.214410E-01,  0.136577E-01,  0.169510E-01, &
         0.173025E-01,  0.958346E-02,  0.255024E-01,  0.308943E-01, &
         0.196031E-01,  0.183608E-01,  0.149419E-01,  0.206358E-01, &
         0.140654E-01,  0.172797E-01,  0.145470E-01,  0.982987E-02, &
         0.116695E-01,  0.811333E-02,  0.965823E-02,  0.649977E-02, &
         0.462192E-02,  0.545929E-02,  0.680407E-02,  0.291235E-02, &
        -0.974773E-03,  0.341591E-02,  0.376198E-02,  0.770610E-03, &
        -0.940864E-04,  0.514532E-02,  0.232371E-02, -0.177741E-02, &
        -0.374892E-03, -0.370485E-03, -0.221435E-02, -0.490000E-02, &
         0.588664E-02,  0.931411E-03, -0.456043E-03, -0.545576E-02, &
        -0.421136E-02, -0.353742E-02, -0.174276E-02, -0.361246E-02, &
        -0.337822E-02, -0.867030E-03, -0.118001E-02, -0.222405E-02, &
        -0.725144E-03,  0.118483E-02,  0.995087E-02,  0.273812E-03, &
         0.417298E-02,  0.764294E-02,  0.631568E-02, -0.213528E-02, &
         0.746130E-02,  0.110337E-02,  0.153157E-01,  0.504532E-02, &
         0.406047E-02,  0.192895E-02,  0.202058E-02,  0.126420E-01/
      DATA (AP(i),i=129,163)  /                                     &
         0.310028E-02,  0.214779E-01,  0.560165E-02,  0.661070E-02, &
         0.694966E-02,  0.539194E-02,  0.103745E-01,  0.180150E-01, &
         0.747133E-02,  0.114927E-01,  0.115213E-01,  0.160709E-02, &
         0.154278E-01,  0.112067E-01,  0.148690E-01,  0.154442E-01, &
         0.123977E-01,  0.237539E-01,  0.162820E-01,  0.269484E-01, &
         0.178081E-01,  0.143221E-01,  0.262468E-01,  0.217065E-01, &
         0.107083E-01,  0.281220E-01,  0.115565E-01,  0.231244E-01, &
         0.225197E-01,  0.178624E-01,  0.327708E-01,  0.116657E-01, &
         0.277452E-01,  0.301647E-01,  0.349782E-01/

      DATA (BP(i),i=1,64)  /                                        &
         0.717848E-05,  0.169280E-04,  0.126710E-04,  0.758397E-05, &
        -0.533900E-05,  0.143490E-04, -0.595854E-05,  0.296465E-05, &
         0.323446E-05,  0.115359E-04, -0.692861E-05,  0.131477E-04, &
        -0.624945E-05, -0.756955E-06,  0.107458E-05, -0.159796E-05, &
        -0.290529E-04, -0.170918E-05, -0.193934E-04, -0.707209E-04, &
        -0.148154E-04, -0.383162E-04, -0.186050E-04, -0.951796E-04, &
        -0.210944E-04, -0.330590E-04, -0.373087E-04, -0.408972E-04, &
        -0.396759E-04, -0.827756E-04, -0.573773E-04, -0.325384E-04, &
        -0.449411E-04, -0.271450E-04, -0.752791E-04, -0.549699E-04, &
        -0.225655E-04, -0.102034E-03, -0.740322E-05, -0.668846E-04, &
        -0.106063E-03, -0.304840E-04, -0.796023E-04,  0.504880E-04, &
         0.486384E-04, -0.531946E-04, -0.147771E-03, -0.406785E-04, &
         0.615750E-05, -0.486264E-04, -0.419335E-04, -0.819467E-04, &
        -0.709498E-04,  0.326984E-05, -0.369743E-04, -0.526848E-04, &
        -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
        -0.982953E-04, -0.772497E-04, -0.119430E-05, -0.655187E-04/
      DATA (BP(i),i=65,128)  /                                      &
        -0.339078E-04,  0.716657E-04, -0.335893E-04,  0.220239E-04, &
        -0.491012E-04, -0.393325E-04, -0.626461E-04, -0.795479E-04, &
        -0.599181E-04, -0.578153E-04, -0.597559E-05, -0.866750E-04, &
        -0.486783E-04, -0.580912E-04, -0.647368E-04, -0.350643E-04, &
        -0.566635E-04, -0.385738E-04, -0.463782E-04, -0.321485E-04, &
        -0.177300E-04, -0.250201E-04, -0.365492E-04, -0.165218E-04, &
        -0.649177E-05, -0.218458E-04, -0.984604E-05, -0.120034E-04, &
        -0.110119E-06, -0.164405E-04, -0.141396E-04,  0.315347E-05, &
        -0.141544E-05, -0.297320E-05, -0.216248E-05,  0.839264E-05, &
        -0.178197E-04, -0.106225E-04, -0.468195E-05,  0.997043E-05, &
         0.679709E-05,  0.324610E-05, -0.367325E-05,  0.671058E-05, &
         0.509293E-05, -0.437392E-05, -0.787922E-06, -0.271503E-06, &
        -0.437940E-05, -0.128205E-04, -0.417830E-04, -0.561134E-05, &
        -0.209940E-04, -0.414366E-04, -0.289765E-04,  0.680406E-06, &
        -0.558644E-05, -0.530395E-05, -0.622242E-04, -0.159979E-05, &
        -0.140286E-04, -0.128463E-04, -0.929499E-05, -0.327886E-04/
      DATA (BP(i),i=129,163)  /                                     &
        -0.189353E-04, -0.737589E-04, -0.323471E-04, -0.272502E-04, &
        -0.321731E-04, -0.326958E-04, -0.509157E-04, -0.681890E-04, &
        -0.362182E-04, -0.354405E-04, -0.578392E-04,  0.238627E-05, &
        -0.709028E-04, -0.518717E-04, -0.491859E-04, -0.718017E-04, &
        -0.418978E-05, -0.940819E-04, -0.630375E-04, -0.478469E-04, &
        -0.751896E-04, -0.267113E-04, -0.109019E-03, -0.890983E-04, &
        -0.177301E-04, -0.120216E-03,  0.220464E-04, -0.734277E-04, &
        -0.868068E-04, -0.652319E-04, -0.136982E-03, -0.279933E-06, &
        -0.791824E-04, -0.111781E-03, -0.748263E-04/

      DATA (ATP(i),i=1,64)  /                                       &
        -0.722782E-02, -0.901531E-02, -0.821263E-02, -0.808024E-02, &
        -0.320169E-02, -0.661305E-02, -0.287272E-02, -0.486143E-02, &
        -0.242857E-02, -0.530288E-02, -0.146813E-02, -0.566474E-03, &
        -0.102192E-02,  0.300643E-03, -0.331655E-02,  0.648220E-03, &
         0.552446E-02, -0.933046E-03,  0.205703E-02,  0.130638E-01, &
        -0.229828E-02,  0.715648E-02,  0.444446E-03,  0.193500E-01, &
         0.364119E-02,  0.252713E-02,  0.102420E-01,  0.494224E-02, &
         0.584934E-02,  0.146255E-01,  0.921986E-02,  0.768012E-02, &
         0.916105E-02,  0.276223E-02,  0.125245E-01,  0.131146E-01, &
         0.793016E-02,  0.201536E-01,  0.658631E-02,  0.171711E-01, &
         0.228470E-01,  0.131306E-01,  0.226658E-01,  0.176086E-01, &
         0.149987E-01,  0.143060E-01,  0.313189E-01,  0.117070E-01, &
         0.133522E-01,  0.244259E-01,  0.148393E-01,  0.223982E-01, &
         0.151792E-01,  0.180474E-01,  0.106299E-01,  0.191016E-01, &
         0.171776E-01,  0.229724E-01,  0.275530E-01,  0.302731E-01, &
         0.281662E-01,  0.199525E-01,  0.192588E-01,  0.173220E-01/
      DATA (ATP(i),i=65,128)  /                                     &
         0.195220E-01,  0.169371E-01,  0.193212E-01,  0.145558E-01, &
         0.189654E-01,  0.122030E-01,  0.186206E-01,  0.228842E-01, &
         0.139343E-01,  0.164006E-01,  0.137276E-01,  0.154005E-01, &
         0.114575E-01,  0.129956E-01,  0.115305E-01,  0.929260E-02, &
         0.106359E-01,  0.771623E-02,  0.106075E-01,  0.597630E-02, &
         0.493960E-02,  0.532554E-02,  0.646175E-02,  0.302693E-02, &
         0.150899E-02,  0.310333E-02,  0.533734E-02,  0.239094E-03, &
         0.356782E-02,  0.707574E-02,  0.215758E-02, -0.527589E-03, &
         0.643893E-03, -0.101916E-02, -0.383336E-02, -0.445966E-02, &
         0.880190E-02,  0.245662E-02, -0.560923E-03, -0.582201E-02, &
        -0.323233E-02, -0.454197E-02, -0.240905E-02, -0.343160E-02, &
        -0.335156E-02, -0.623846E-03,  0.393633E-03, -0.271593E-02, &
        -0.675874E-03,  0.920642E-03,  0.102168E-01, -0.250663E-03, &
         0.437126E-02,  0.767434E-02,  0.569931E-02, -0.929326E-03, &
         0.659414E-02,  0.280687E-02,  0.127614E-01,  0.780789E-02, &
         0.374807E-02,  0.274288E-02,  0.534940E-02,  0.104349E-01/
      DATA (ATP(i),i=129,163)  /                                    &
         0.294379E-02,  0.177846E-01,  0.523249E-02,  0.125339E-01, &
         0.548538E-02,  0.577403E-02,  0.101532E-01,  0.170375E-01, &
         0.758396E-02,  0.113402E-01,  0.106960E-01,  0.107782E-01, &
         0.136148E-01,  0.992064E-02,  0.167276E-01,  0.149603E-01, &
         0.136259E-01,  0.234521E-01,  0.166806E-01,  0.298505E-01, &
         0.167592E-01,  0.186679E-01,  0.233062E-01,  0.228467E-01, &
         0.128947E-01,  0.293979E-01,  0.219815E-01,  0.220663E-01, &
         0.272710E-01,  0.237139E-01,  0.331743E-01,  0.208799E-01, &
         0.281472E-01,  0.318440E-01,  0.370962E-01/

      DATA (BTP(i),i=1,64)  /                                       &
         0.149748E-04,  0.188007E-04,  0.196530E-04,  0.124747E-04, &
        -0.215751E-07,  0.128357E-04, -0.265798E-05,  0.606262E-05, &
         0.287668E-05,  0.974612E-05, -0.833451E-05,  0.584410E-05, &
        -0.452879E-05, -0.782537E-05,  0.786165E-05, -0.768351E-05, &
        -0.196168E-04,  0.177297E-06, -0.129258E-04, -0.642798E-04, &
        -0.986297E-05, -0.257145E-04, -0.141996E-04, -0.865089E-04, &
        -0.141691E-04, -0.272578E-04, -0.295198E-04, -0.308878E-04, &
        -0.313193E-04, -0.669272E-04, -0.475777E-04, -0.221332E-04, &
        -0.419930E-04, -0.102519E-04, -0.590184E-04, -0.574771E-04, &
        -0.240809E-04, -0.913994E-04, -0.908886E-05, -0.721074E-04, &
        -0.902837E-04, -0.447582E-04, -0.664544E-04, -0.143150E-04, &
        -0.511866E-05, -0.559352E-04, -0.104734E-03, -0.305206E-04, &
         0.103303E-04, -0.613019E-04, -0.320040E-04, -0.738909E-04, &
        -0.388263E-04,  0.306515E-04, -0.352214E-04, -0.253940E-04, &
        -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
        -0.933645E-04, -0.664045E-04, -0.570712E-05, -0.566312E-04/
      DATA (BTP(i),i=65,128)  /                                     &
        -0.364967E-04,  0.393501E-06, -0.234050E-04, -0.141317E-04, &
        -0.525480E-04, -0.172241E-04, -0.410843E-04, -0.358348E-04, &
        -0.256168E-04, -0.509482E-04, -0.180570E-04, -0.555356E-04, &
        -0.271464E-04, -0.274040E-04, -0.480889E-04, -0.275751E-04, &
        -0.415681E-04, -0.383770E-04, -0.280139E-04, -0.287919E-04, &
        -0.125865E-04, -0.265467E-04, -0.172765E-04, -0.164611E-04, &
         0.189183E-04, -0.171219E-04, -0.132766E-04, -0.344611E-05, &
        -0.442832E-05, -0.185779E-04, -0.139755E-04,  0.168083E-05, &
        -0.395287E-05, -0.297871E-05,  0.434383E-05,  0.131741E-04, &
        -0.192637E-04, -0.549551E-05,  0.122553E-05,  0.204627E-04, &
         0.154027E-04,  0.953462E-05,  0.131125E-05,  0.732839E-05, &
         0.755405E-05, -0.305552E-05, -0.434858E-05,  0.308409E-05, &
        -0.164787E-05, -0.818533E-05, -0.355041E-04, -0.504696E-05, &
        -0.229022E-04, -0.356891E-04, -0.230346E-04,  0.518835E-05, &
        -0.160187E-04, -0.104617E-04, -0.464754E-04, -0.115807E-04, &
        -0.130230E-04, -0.603491E-05, -0.125324E-04, -0.165516E-04/
      DATA (BTP(i),i=129,163)  /                                    &
        -0.991679E-05, -0.529432E-04, -0.200199E-04, -0.181977E-04, &
        -0.220940E-04, -0.204483E-04, -0.432584E-04, -0.449109E-04, &
        -0.247305E-04, -0.174253E-04, -0.484446E-04,  0.354150E-04, &
        -0.425581E-04, -0.406562E-04, -0.505495E-04, -0.651856E-04, &
        -0.153953E-04, -0.894294E-04, -0.616551E-04, -0.846504E-04, &
        -0.699414E-04, -0.376203E-04, -0.940985E-04, -0.753050E-04, &
        -0.183710E-04, -0.123907E-03, -0.279347E-04, -0.736381E-04, &
        -0.103588E-03, -0.754117E-04, -0.140991E-03, -0.366687E-04, &
        -0.927785E-04, -0.125321E-03, -0.115290E-03/

      DATA (BETAD(i),i=1,64)  /                                     &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.234879E+03,  0.217419E+03,  0.201281E+03,  0.186364E+03, &
         0.172576E+03,  0.159831E+03,  0.148051E+03,  0.137163E+03, &
         0.127099E+03,  0.117796E+03,  0.109197E+03,  0.101249E+03, &
         0.939031E+02,  0.871127E+02,  0.808363E+02,  0.750349E+02, &
         0.497489E+02,  0.221212E+02,  0.113124E+02,  0.754174E+01, &
         0.589554E+01,  0.495227E+01,  0.000000E+00,  0.000000E+00/
      DATA (BETAD(i),i=65,128)  /                                   &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00/
      DATA (BETAD(i),i=129,163)  /                                  &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00/

!-----------------------------------------------------------------------
!
!    Random band parameters for the longwave calculations using
!    comboned wide frequency bands between 160 and 1200 cm-1, 
!    as well as the 2270-2380 band for source calculations.
!
!        BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1
!        BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS)
!                    FOR 560-1200 CM-1
!        BAND  15:  FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE 
!                   CALCULATION ONLY
!
!        Thus NBLY presently equals   15
! 
!        Bands are arranged in order of increasing wavenumber.
!
!      ACOMB       =   RANDOM "A" PARAMETER FOR (NBLY) BANDS
!      BCOMB       =   RANDOM "B" PARAMETER FOR (NBLY) BANDS
!      BETACM      =   CONTINUUM COEFFICIENTS FOR (NBLY) BANDS
!      APCM,BPCM   =   CAPPHI COEFFICIENTS FOR (NBLY) BANDS 
!      ATPCM,BTPCM =   CAPPSI COEFFICIENTS FOR (NBLY) BANDS 
!      BDLOCM      =   LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS 
!      BDHICM      =   HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS
!      AO3CM       =   RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE
!                      BANDS.
!      BO3CM       =   RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE
!                      BANDS
!      AB15CM      =   THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS
!                      REPRESENTING THE 15 UM BAND COMPLEX OF CO2 
!      BETINC      =   CONT.COEFFICIENT FOR A SPECIFIED WIDE
!                      FREQ.BAND (800-990 AND 1070-1200 CM-1).
!      IBAND       =   INDEX NO OF THE 40 WIDE BANDS USED IN
!                      COMBINED WIDE BAND CALCULATIONS. IN OTHER
!                      WORDS,INDEX TELLING WHICH OF THE 40 WIDE 
!                      BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN 
!                      EACH OF THE FIRST 8 COMBINED WIDE BANDS
!
!     Data for ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM are
!     obtained by using the AFGL 1982 catalog. Continuum coefficients 
!     are from Roberts (1976). IBAND index values are obtained by 
!     experimentation. This data was formerly in COMMON /BDCOMB/.

      INTEGER  IBAND(40)
      REAL  ACOMB(NBLY),BCOMB(NBLY),                        &
            BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), &
            BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC,   &
            AO3CM(3),BO3CM(3),AB15CM(2) 

      DATA ACOMB  /                                                 &
         0.152070E+05,  0.332194E+04,  0.527177E+03,  0.163124E+03, &
         0.268808E+03,  0.534591E+02,  0.268071E+02,  0.123133E+02, &
         0.600199E+01,  0.640803E+00,  0.501549E-01,  0.167961E-01, &
         0.178110E-01,  0.170166E+00,  0.537083E-02/
      DATA BCOMB  /                                                 &
         0.152538E+00,  0.118677E+00,  0.103660E+00,  0.100119E+00, &
         0.127518E+00,  0.118409E+00,  0.904061E-01,  0.642011E-01, &
         0.629660E-01,  0.643346E-01,  0.717082E-01,  0.629730E-01, &
         0.875182E-01,  0.857907E-01,  0.214005E+00/
      DATA APCM   /                                                 &
        -0.671879E-03,  0.654345E-02,  0.143657E-01,  0.923593E-02, &
         0.117022E-01,  0.159596E-01,  0.181600E-01,  0.145013E-01, &
         0.170062E-01,  0.233303E-01,  0.256735E-01,  0.274745E-01, &
         0.279259E-01,  0.197002E-01,  0.349782E-01/
      DATA BPCM   /                                                 &
        -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
        -0.361981E-04, -0.145117E-04,  0.198349E-04, -0.486529E-04, &
        -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
        -0.982953E-04, -0.772497E-04, -0.748263E-04/
      DATA ATPCM  /                                                 &
        -0.106346E-02,  0.641531E-02,  0.137362E-01,  0.922513E-02, &
         0.136162E-01,  0.169791E-01,  0.206959E-01,  0.166223E-01, &
         0.171776E-01,  0.229724E-01,  0.275530E-01,  0.302731E-01, &
         0.281662E-01,  0.199525E-01,  0.370962E-01/
      DATA BTPCM  /                                                 &
        -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
        -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
        -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
        -0.933645E-04, -0.664045E-04, -0.115290E-03/
      DATA BETACM /                                                 &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.188625E+03,  0.144293E+03,  0.174098E+03,  0.909366E+02, &
         0.497489E+02,  0.221212E+02,  0.113124E+02,  0.754174E+01, &
         0.589554E+01,  0.495227E+01,  0.000000E+00/
      DATA IBAND  /                                                 &
          2,   1,   2,   2,   1,   2,   1,   3,   2,   2,           &
          3,   2,   2,   4,   2,   4,   2,   3,   3,   2,           &
          4,   3,   4,   3,   7,   5,   6,   7,   6,   5,           &
          7,   6,   7,   8,   6,   6,   8,   8,   8,   8/

!-----------------------------------------------------------------------
!
!    Random band parameters for specific wide bands. At present,
!    the information consists of:  1) random model parameters for
!    the 15 um band, 560-800 cm-1; 2) the continuum coefficient for
!    the 800-990, 1070-1200 cm-1 band.
!
!    specifically:  
!      AWIDE       =   RANDOM "A" PARAMETER FOR  BAND 
!      BWIDE       =   RANDOM "B" PARAMETER FOR  BAND 
!      BETAWD      =   CONTINUUM COEFFICIENTS FOR BAND
!      APWD,BPWD   =   CAPPHI COEFFICIENTS FOR  BAND
!      ATPWD,BTPWD =   CAPPSI COEFFICIENTS FOR BAND 
!      BDLOWD      =   LOWEST FREQUENCY IN EACH  FREQ  BAND 
!      BDHIWD      =   HIGHEST FREQUENCY IN EACH FREQ  BAND 
!      AB15WD      =   THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND 
!                      REPRESENTING THE 15 UM BAND COMPLEX OF CO2 
!      BETINW      =   CONT.COEFFICIENT FOR A SPECIFIED WIDE
!                      FREQ.BAND (800-990 AND 1070-1200 CM-1).
!      SKO2D       =   1./BETINW, USED IN SPA88 FOR CONT. COEFFS
!      SKC1R       =   BETAWD/BETINW, USED FOR CONT. COEFF. FOR 
!                      15 UM BAND IN FST88
!      SKO3R       =   RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO 
!                        BETINW, USED FOR 9.6 UM CONT COEFF IN FST88
!
!     Data for AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD are
!     obtained by using the AFGL 1982 catalog. Continuum coefficients 
!     are from Roberts (1976). This data was formerly in
!     COMMON /BDWIDE/.

      REAL  AWIDE,BWIDE,BETAWD,    &
            APWD,BPWD,ATPWD,BTPWD, &
            BDLOWD,BDHIWD,BETINW,  &
            AB15WD,SKO2D,SKC1R,SKO3R

      DATA AWIDE  / 0.309801E+01/
      DATA BWIDE  / 0.495357E-01/
      DATA APWD   / 0.177115E-01/
      DATA BPWD   /-0.545226E-04/
      DATA ATPWD  / 0.187967E-01/
      DATA BTPWD  /-0.567449E-04/
      DATA BETAWD / 0.347839E+02/
      DATA BETINW / 0.766811E+01/
      DATA BDLOWD / 0.560000E+03/
      DATA BDHIWD / 0.800000E+03/

!-----------------------------------------------------------------------
!
!       CLDFAC     =  CLOUD TRANSMISSION FUNCTION,ASSUMING RANDOM
!                       OVERLAP

      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CLDFAC

!-----------------------------------------------------------------------
!
!     Basic quantities computed in SUBROUTINE LWRAD and used in
!     the remaining longwave routines (formally COMMON /KDACOM/):
!
!       QH2O     =  H2O MASS MIXING RATIO,MULTIPLIED BY THE 
!                     DIFFUSIVITY FACTOR (DIFFCTR)
!       P        =  PRESSURE AT FLUX LEVELS OF MODEL
!       DELP2    =  PRESSURE DIFFERENCE BETWEEN FLUX LEVELS 
!       DELP     =  INVERSE OF DELP2
!       TTTT     =  TEMPERATURE ASSIGNED TO MODEL FLUX LEVELS 
!       VAR1     =  H2O OPTICAL PATH IN MODEL LAYERS (BETWEEN 
!                     FLUX LEVELS)
!       VAR2     =  PRESSURE-WEIGHTED H2O OPTICAL PATH IN MODEL LAYERS
!       VAR3     =  O3 OPTICAL PATH IN MODEL LAYERS 
!       VAR4     =  PRESSURE-WEIGHTED O3 OPTICAL PATH IN MODEL LAYERS 
!       CNTVAL   =  H2O CONTINUUM PATH IN MODEL LAYERS FOR THE
!                     800-990 AND 1070-1200 CM-1 COMBINED BAND

      REAL, ALLOCATABLE, DIMENSION(:,:) :: QH2O,P,DELP2,DELP,TTTT
      REAL, ALLOCATABLE, DIMENSION(:,:) :: VAR1,VAR2,VAR3,VAR4,CNTVAL

!-----------------------------------------------------------------------
!
!     Flux quantities computed by the radiation code, used for
!     diagnostic purposes (formally COMMON /RDFLUX/): 
!
!       FLX1E1     =  FLUX AT TOP FOR 0-160,1200-2200 CM-1 RANGE
!       GXCTS      =  FLUX AT TOP FOR 160-1200 CM-1 RANGE 
!       FCTSG      =  CTS FLUX AT GROUND. USED TO OBTAIN GXCTS
!                              BY BANDS.

      REAL, ALLOCATABLE, DIMENSION(:)   :: FLX1E1,GXCTS
      REAL, ALLOCATABLE, DIMENSION(:,:) :: FCTSG

!-----------------------------------------------------------------------
!
!     Planck function values used for the radiative calculations
!     (formally COMMON /SRCCOM/):
!
!       SORC     =  PLANCK FCTN, AT MODEL TEMPERATURES, FOR ALL BANDS 
!                     USED IN CTS CALCULATIONS
!       CSOUR1   =  PLANCK FCTN FOR 560-670 CM-1 BAND 
!       CSOUR2   =  PLANCK FCTN FOR 670-800 CM-1 BAND 
!       CSOUR    =  PLANCK FCTN FOR 560-800 CM-1 BANDS
!       OSOUR    =  PLANCK FCTN FOR 990-1070 CM-1 BAND
!       SS1      =  PLANCK FCTN FOR 800-990,1070-1200 CM-1 BANDS

      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SORC
      REAL, ALLOCATABLE, DIMENSION(:,:) :: CSOUR1,CSOUR2,OSOUR,CSOUR,SS1

!-----------------------------------------------------------------------
!
!     Quantities precomputed in subroutine TABLE for use in
!     the longwave radiation module (formally COMMON /TABCOM/):
!
!        EM1     =  E1 FUNCTION, EVALUATED OVER THE 0-560 AND 
!                   1200-2200 CM-1 INTERVALS
!        EM1WDE  =  E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1
!                   INTERVAL
!        TABLE1  =  E2 FUNCTION, EVALUATED OVER THE 0-560 AND 
!                   1200-2200 CM-1 INTERVALS
!        TABLE2  =  TEMPERATURE DERIVATIVE OF TABLE1
!        TABLE3  =  MASS DERIVATIVE OF TABLE1 
!        EM3     =  E3 FUNCTION, EVALUATED OVER THE 0-560 AND 
!                   1200-2200 CM-1 INTERVALS
!        SOURCE  =  PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR
!                   BANDS USED IN CTS CALCULATIONS
!        DSRCE   =  TEMPERATURE DERIVATIVE OF SOURCE
!        INDX2   =  INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" 
!                   ELEMENTS OF AVEPHI,ETC.,IN FST88
!        KMAXV   =  INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" 
!                   ELEMENTS OF AVEPHI,ETC.,IN FST88
!        KMAXVM  =  KMAXV(LMAX),USED FOR DO LOOP INDICES 

      INTEGER, ALLOCATABLE, DIMENSION(:) :: INDX1,INDX2,KMAXV

      INTEGER :: KMAXVM
      INTEGER, PRIVATE :: IMAXold=0,LMAXold=0
      INTEGER, PRIVATE :: IMAX

      REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE

!     REAL  EM1   (28,180),EM1WDE(28,180),TABLE1(28,180),
!     COMMON /TABCOM/  EM1   (28,180),EM1WDE(28,180),TABLE1(28,180),
!    &                 TABLE2(28,180),TABLE3(28,180),EM3   (28,180)
      
!-----------------------------------------------------------------------
!
!     Transmission functions used for radiative computations, and
!     output heating rates and fluxes, except those needed out of
!     the radiative module (formally COMMON /TFCOM/): 
!
!       TO3      =  TRANSMISSION FCTN FOR THE 990-1070 CM-1 BAND
!                     O3(9.6 UM) + H2O CONTINUUM (NO LINES) 
!       CO21     =  TRANSMISSION FCTN FOR THE 560-800 CM-1 BAND 
!                     (AS 1 BAND). INCLUDES CO2 (IN LWRAD) AND
!                      H2O(L+C) AFTER MULTIPLICATION WITH "OVER"
!                      IN FST88 
!       EMISS    =  E2 EMISSIVITYY FCTN FOR H2O LINES (0-560,1200-2200
!                      CM-1). OBTAINED IN E1E288. 
!       EMISS2   =  TRANSMISSION FCTN FOR H2O CONTINUUM IN THE 800-990
!                      AND 1070-1200 CM-1 REGION, TAKEN AS 1 BAND 
!       AVEPHI   =  H2O OPTICAL PATHS BET. FLUX PRESSURES: INPUT TO 
!                      EMISSIVITY CALCULATIONS. 
!       TTEMP    =  TEMPERATURES USED AS INPUT FOR EMISSIVITY CALCS.
!       CTS      =  APPROX CTS HEATING RATES FOR 160-560 AND 800-990, 
!                      1070-1200 CM-1 RANGES
!       CTSO3    =  APPROX CTS HEATING RATES FOR 560-800,990-1070 CM-1
!                      RANGES 
!       EXCTS    =  EXACT CTS HEATING RATES FOR 160-1200 CM-1 RANGE 
!       EXCTSN   =  EXACT CTS HEATING RATES, BY BANDS 
!       E1FLX    =  E1 EMISSIVITY FCTN FOR H2O LINES (0-560,1200-CM-1)
!       CO2NBL   =  CO2 TRANS. FCTNS. (NOT PRESSURE-INTEGRATED) FOR 
!                      ADJACENT LEVELS,OVER THE 560-800 CM-1 RANGE. 
!       CO2SP1   =  CO2 TRANS. FCTNS. (NOT PRESSURE-INTEGRATED) BET.
!                      A FLUX LEVEL AND SPACE, FOR THE 560-670 CM-1 
!                      RANGE. USED FOR EXACT CTS CALCS. 
!       CO2SP2   =  SAME AS CO2SP1, BUT FOR THE 670-800 CM-1 RANGE. 
!       CO2SP    =  SAME AS CO2SP1, BUT FOR THE 560-800 CM-1 BAND.
!                      USED FOR APPROX CTS CALCS. 
!       TO3SPC   =  O3 OPTICAL DEPTHS BET. A LEVEL AND SPACE. USED FOR
!                      EXACT CTS CALCS. 
!       TOTVO2   =  H2O CONTINUUM OPTICAL PATHS BET. SPACE AND A
!                      LEVEL, USING THE CNT. COEFFICIENT FOR THE
!                      1-BAND 800-990,1070-1200 CM-1 BAND. USED FOR 
!                      CTS CALCS. 

      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: TO3,CO21,EMISS,EMISS2,AVEPHI
      REAL,ALLOCATABLE,DIMENSION(:,:)   :: CTS,CTSO3,EXCTS
      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: EXCTSN
      REAL,ALLOCATABLE,DIMENSION(:,:)   :: E1FLX,CO2NBL,CO2SP1,CO2SP2
      REAL,ALLOCATABLE,DIMENSION(:,:)   :: CO2SP,TO3SPC,TOTVO2

!------------ VERSION NUMBER ----------------

 character(len=128) :: version = '$Id: longwave.F90,v 13.0 2006/03/28 21:09:33 fms Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.

!-----------------------------------------------------------------------

public LWRad, Rad_DeAlloc, longwave_init, longwave_end
public OSOUR, CSOUR, SS1, FLX1E1, GXCTS, FCTSG, CLDFAC, DELP2, DELP, &
       TO3, CO21, EMISS, EMISS2, CTS, EXCTS, EXCTSN, E1FLX, CO2SP,   &
       IBAND, BANDLO, BANDHI


      CONTAINS

!#######################################################################
!#######################################################################
      Subroutine longwave_init
!------- write version number  ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      End Subroutine longwave_init

!#######################################################################
!#######################################################################

      Subroutine longwave_end

      module_is_initialized = .false.
!---------------------------------------------------------------------

      End Subroutine longwave_end

!#######################################################################
!#######################################################################

      SUBROUTINE LWRAD (KTOP,KBTM,NCLDS,EMCLD,PRES,TEMP,RH2O,QO3,CAMT, &
                        RRVCO2,  HEATRA,GRNFLX,TOPFLX, LSFC,PSFC)

      INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:,:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: EMCLD
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: PRES,TEMP,RH2O,QO3,CAMT
      REAL,    INTENT(IN)                   :: RRVCO2

      REAL,   INTENT(OUT), DIMENSION(:,:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:,:)   :: GRNFLX,TOPFLX

      INTEGER, INTENT(IN),OPTIONAL, DIMENSION(:,:)   :: LSFC
      REAL   , INTENT(IN),OPTIONAL, DIMENSION(:,:)   :: PSFC

      INTEGER  J

      IMAX=SIZE(PRES,1)
      CALL RAD_ALLOC (IMAX)

      DO j=1,SIZE(PRES,2)

        CALL CLO88 (KTOP(:,j,:),KBTM(:,j,:),NCLDS(:,j), &
                    CAMT(:,j,:),EMCLD(:,j,:))

      IF (PRESENT(LSFC) .and. PRESENT(PSFC)) THEN
        CALL LWRAD2 (KTOP(:,j,:),KBTM(:,j,:),NCLDS(:,j),EMCLD(:,j,:), &
                     PRES(:,j,:),TEMP(:,j,:),RH2O(:,j,:),QO3(:,j,:),  &
                     CAMT(:,j,:), RRVCO2,                             &
                     HEATRA(:,j,:),GRNFLX(:,j),TOPFLX(:,j),           &
                     LSFC(:,j),PSFC(:,j))
      ELSE
        CALL LWRAD2 (KTOP(:,j,:),KBTM(:,j,:),NCLDS(:,j),EMCLD(:,j,:), &
                     PRES(:,j,:),TEMP(:,j,:),RH2O(:,j,:),QO3(:,j,:),  &
                     CAMT(:,j,:), RRVCO2,                             &
                     HEATRA(:,j,:),GRNFLX(:,j),TOPFLX(:,j))
      ENDIF

      ENDDO

!del  CALL RAD_DEALLOC

      END SUBROUTINE LWRAD

!#######################################################################
!#######################################################################

      SUBROUTINE LWRAD2  (KTOP,KBTM,NCLDS,EMCLD,PRES,TEMP,RH2O,QO3,CAMT, &
                          RRVCO2,  HEATRA,GRNFLX,TOPFLX, LSFC,PSFC)

!-----------------------------------------------------------------------
!                    LONG WAVE RADIATION CODE
!                    ------------------------
!   SUBROUTINE LWRAD (formally LWR88) COMPUTES TEMPERATURE-CORRECTED
!   CO2 TRANSMISSION FUNCTIONS AND ALSO COMPUTES THE PRESSURE GRID
!   AND LAYER OPTICAL PATHS.
!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      KTOP    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD TOP,USED
!                    IN THE LONGWAVE PROGRAM
!      KBTM    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD BOTTOM, 
!                    USED IN THE LONGWAVE PROGRAM 
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT.
!      EMCLD   =  CLOUD EMISSIVITY. SET TO ONE BY DEFAULT, BUT MAY
!                    BE MODIFIED FOR USE IN LONGWAVE PROGRAM. 
!      PRES    =  PRESSURE (CGS UNITS) AT DATA LEVELS OF MODEL
!      TEMP    =  TEMPERATURE (K) AT DATA LEVELS OF MODEL
!      RH2O    =  MASS MIXING RATIO (G/G) OF H2O AT MODEL DATA LVLS.
!      QO3     =  MASS MIXING RATIO (G/G) OF O3 AT MODEL DATA LVLS. 
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                 SPECIFIED IN THE KTOP/KBTM INDICES)
!      RRVCO2  =  THE VOLUME MIXING RATIO OF CO2 (SCALAR)
!                 (used in NLTE, passed by argument list)
!
!      PSFC    =  Surface pressure, dimensioned by IMAX.
!      TSFC    =  Surface temperature, dimensioned by IMAX.
!      LSFC    =  Vertical index of the lowest model level,
!                    dimensioned by IMAX.
!
!-----------------------------------------------------------------------
!                        OUTPUT PARAMETERS
!                        -----------------
!
!      HEATRA     =  HEATING RATE AT DATA LEVELS (K/DAY) 
!      GRNFLX     =  NET LONGWAVE FLUX AT THE GROUND (CGS UNITS) 
!      TOPFLX     =  NET LONGWAVE FLUX AT THE TOP    (CGS UNITS)
!
!
!-----------------------------------------------------------------------
!         OTHER INPUTS (FROM COMMON BLOCKS):
!         ----------------------------------
!      CO251,CO258,CDT51,CDT58         CO2BD3 
!      C2D51,C2D58,CO2M51,CO2M58       CO2BD3 
!      CDTM51,CDTM58,C2DM51,C2DM58     CO2BD3 
!      STEMP,GTEMP                     CO2BD3 
!      CO231,CO238,CDT31,CDT38         CO2BD2 
!      C2D31,C2D38                     CO2BD2 
!      CO271,CO278,CDT71,CDT78         CO2BD4 
!      C2D71,C2D78                     CO2BD4 
!      BETINW                          BDWIDE 
!
!          OUTPUTS: 
!      CO21,CO2NBL,CO2SP1,CO2SP2       TFCOM
!      VAR1,VAR2,VAR3,VAR4,CNTVAL      KDACOM 
!      QH2O,P,DELP,DELP2,T             KDACOM 
!
!          CALLS: 
!      FST88
!-----------------------------------------------------------------------
!----------------INPUT ARGUMENTS----------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMCLD
      REAL,    INTENT(IN), DIMENSION(:,:) :: PRES,TEMP,RH2O,QO3,CAMT
      REAL,    INTENT(IN)                 :: RRVCO2
      INTEGER, INTENT(IN),OPTIONAL, DIMENSION(:)   :: LSFC
      REAL   , INTENT(IN),OPTIONAL, DIMENSION(:)   :: PSFC

!                         D I M E N S I O N
!    &  KTOP(IMAX,LP1),KBTM(IMAX,LP1),NCLDS(IMAX),EMCLD(IMAX,LP1),
!    &  TEMP(IMAX,LP1),PRES(IMAX,LP1),RH2O(IMAX,LMAX),QO3(IMAX,LMAX),
!    &  CAMT(IMAX,LP1),LSFC(IMAX),PSFC(IMAX)
!----------------OUTPUT ARGUMENTS---------------------------------------

      REAL,   INTENT(OUT), DIMENSION(:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:)   :: GRNFLX,TOPFLX

!-----------------------------------------------------------------------
!----------------LOCAL ARRAY STORAGE------------------------------------

      integer :: k, kp
      real    :: diftt
      real, dimension(IMAX,LP1)  :: &
                    PRESS, CO2R1, DCO2D1, D2CD21, D2CD22, &
                    CO2R2 , DCO2D2, TDAV, TSTDAV, VSUM3, TEXPSL, TLSQU
      
      real, dimension(IMAX,LMAX)  :: &
                    VV, CO2MR, CO2MD, CO2M2D, VSUM4

      real, dimension(IMAX)  :: &
                    VSUM1, VSUM2, A1, A2
!      DIMENSION  :: PRESS(IMAX,LP1)

!     DIMENSION  CO2R(IMAX,LP1,LP1),DIFT(IMAX,LP1,LP1)
!     DIMENSION                     DIFT(IMAX,LP1,LP1)
!      DIMENSION  CO2R1 (IMAX,LP1), DCO2D1(IMAX,LP1) 
!      DIMENSION  D2CD21(IMAX,LP1), D2CD22(IMAX,LP1)
!      DIMENSION  CO2R2 (IMAX,LP1), DCO2D2(IMAX,LP1) 
!      DIMENSION  TDAV(IMAX,LP1),TSTDAV(IMAX,LP1), &
!                 VV(IMAX,LMAX),VSUM3(IMAX,LP1),VSUM1(IMAX),VSUM2(IMAX) 
!      DIMENSION  CO2MR (IMAX,LMAX),CO2MD (IMAX,LMAX),CO2M2D(IMAX,LMAX) 
!      DIMENSION  A1(IMAX),A2(IMAX)
!-----------------------------------------------------------------------
!     DIMENSION  DIFTD(IMAX,LP1,LP1) 
!     DIMENSION  DCO2DT(IMAX,LP1,LP1),D2CDT2(IMAX,LP1,LP1) 
!      DIMENSION  TEXPSL(IMAX,LP1),TLSQU(IMAX,LP1)
!      DIMENSION  VSUM4(IMAX,LMAX) 
!      DIMENSION  DIFT1D(IMAX,LP1M) 
!-----------------------------------------------------------------------
!     EQUIVALENCE (DIFTD,CO2R)
!     EQUIVALENCE (DCO2DT,D2CDT2,CO2R)
!     EQUIVALENCE (VSUM3,TLSQU,TEXPSL)
!     EQUIVALENCE (VV,VSUM4)
!     EQUIVALENCE (DIFT1D,DIFT) 
!-----------------------------------------------------------------------
!----------- check presence of optional arguments ----------------------

      IF ((     PRESENT(LSFC) .and. .not.PRESENT(PSFC)) .or. &
          (.not.PRESENT(LSFC) .and.      PRESENT(PSFC))) THEN
         Call Error_Mesg ('LWRAD in LONGWAVE_MOD', &
                          'LSFC and PSFC must be used together.', FATAL)
      ENDIF
!-----------------------------------------------------------------------
!--- NOTE: convert input pressure (PRES) from MKS to CGS units

      DO K=1,LP1
      DO I=1,IMAX 
         PRESS(I,K)=10.*PRES(I,K)
      ENDDO
      ENDDO

!****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)

      DO K=2,LMAX
      DO I=1,IMAX 
         P(I,K)=0.50*(PRESS(I,K-1)+PRESS(I,K))
      ENDDO
      ENDDO

      IF (.not.PRESENT(LSFC)) THEN
         DO I=1,IMAX 
            P(I,1)=0.0 
            P(I,LP1)=PRESS(I,LP1) 
         ENDDO
      ELSE
         DO I=1,IMAX 
            P(I,1)=0.0 
            P(I,LP1)=PRESS(I,LP1) 
!--- note: convert from MKS to CGS units
            P(I,LSFC(I)+1)=10.*PSFC(I) 
         ENDDO
      ENDIF

      DO K=1,LMAX
      DO I=1,IMAX 
         DELP2(I,K)=P(I,K+1)-P(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         DELP(I,K)=1.0/DELP2(I,K)
      ENDDO
      ENDDO


!****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
!    CORRECTIONS (TEXPSL) 

      DO K=2,LMAX
      DO I=1,IMAX 
         TTTT(I,K)=0.50*(TEMP(I,K-1)+TEMP(I,K))
      ENDDO
      ENDDO

      IF (.not.PRESENT(LSFC)) THEN
         DO I=1,IMAX 
            TTTT(I,1)=TEMP(I,1)
            TTTT(I,LP1)=TEMP(I,LP1)
         ENDDO
      ELSE
         DO I=1,IMAX 
            TTTT(I,1)=TEMP(I,1)
            TTTT(I,LP1)=TEMP(I,LP1)
            TTTT(I,LSFC(I)+1)=TEMP(I,LP1)
         ENDDO
      ENDIF


!****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
!    (THIS IS 1800.(1./TEMP-1./296.)) 

      DO K=1,LP1
      DO I=1,IMAX 
         TEXPSL(I,K)=1800./TEMP(I,K)-6.081081081
      ENDDO
      ENDDO

!...THEN TAKE EXPONENTIAL 

      DO K=1,LP1
      DO I=1,IMAX
         TEXPSL(I,K)=EXP(TEXPSL(I,K))
      ENDDO
      ENDDO
!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS 
!-----------------------------------------------------------------------
!***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY 
!   APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE
!   UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4).
!   THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND 
!   VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND
!   O3,RESPECTIVELY.
! 
      DO K=1,LMAX
      DO I=1,IMAX 
         QH2O(I,K)=RH2O(I,K)*DIFFCTR 
      ENDDO
      ENDDO

!---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS 
!   THE LEVEL PRESSURE (PRESS)

      DO K=1,LMAX
      DO I=1,IMAX 
         VV(I,K)=0.50*(P(I,K+1)+P(I,K))*P0INV 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV
         VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV
         VAR2(I,K)=VAR1(I,K)*(VV(I,K)+0.0003)
         VAR4(I,K)=VAR3(I,K)*(VV(I,K)+0.003)
      ENDDO
      ENDDO


!  COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS.
!  (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR 
!  (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE
!  USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT 
!  SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF
!  AN ANGULAR INTEGRATION IS SEVERE.

      DO K=1,LMAX
      DO I=1,IMAX 
         CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
                  (RH2O(I,K)+RATH2OMW)
      ENDDO
      ENDDO
      

!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS 
!   FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
!   TEMP. SOUNDING (DIFT) 

      DO I=1,IMAX 
         TSTDAV(I,1)=0.0
         TDAV(I,1)=0.0
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         VSUM3(I,K)=TEMP(I,K)-STEMP(K) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         VSUM2(I)=GTEMP(K)*DELP2(I,K)
         VSUM1(I)=VSUM2(I)*VSUM3(I,K)
         TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I)
         TDAV(I,K+1)=TDAV(I,K)+VSUM1(I)
      ENDDO
      ENDDO

!***COMPUTE DIFT
!2    DO K=1,LP1
!2    DO KP=1,LP1 
!2    DO I=1,IMAX 
!        DIFTD(I,KP,K)=TSTDAV(I,KP)-TSTDAV(I,K)
!2       DIFT (I,KP,K)=TSTDAV(I,KP)-TSTDAV(I,K)
!2    ENDDO
!2    ENDDO
!     ENDDO

!2    DO K=1,LP1
!2    DO KP=1,LP1 
!2    DO I=1,IMAX 
!        DIFTD(I,KP,K)=1.0/(DIFTD(I,KP,K)+1.E-20) 
!2       DIFT (I,KP,K)=1.0/(DIFT (I,KP,K)+1.E-20) 
!2    ENDDO
!2    ENDDO
!2    ENDDO

!9    DO K=1,LP1
!9    DO KP=1,LP1 
!9    DO I=1,IMAX 
!        DIFT(I,KP,K)=TDAV(I,KP)-TDAV(I,K) 
!d       DIFT(I,KP,K)=(TDAV(I,KP)-TDAV(I,K))*DIFT(i,kp,k) 
!9       DIFT(I,KP,K)=(TDAV(I,KP)-TDAV(I,K))*(1.0/(tstdav(i,kp)-
!9   &                 tstdav(i,k) + 1.E-20))
!9    ENDDO
!9    ENDDO
!9    ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        DIFT(I,KP,K)=DIFT(I,KP,K)*DIFTD(I,KP,K) 
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         VSUM4(I,K)=0.50*(VSUM3(I,K+1)+VSUM3(I,K))
      ENDDO
      ENDDO

!9    DO K=2,LP1
!9    DO I=1,IMAX 
!9       DIFT(I,K,K)=VSUM4(I,K-1)
!9    ENDDO
!9    ENDDO

!****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2) 
! ---- NOTE: PRESS converted from MKS to CGS

      DO I=1,IMAX 
         A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
         A2(I)=(P0-PRESS(I,LP1))/P0XZP2
      ENDDO

!***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION 
!   FUNCTIONS AND TEMP. DERIVATIVES 
!---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE 
!   STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME)

      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 
!        CO2R(I,KP,K)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
         CO21(I,KP,K)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
         D2CD21(I,K)=A1(I)*C2D31(K)+A2(I)*C2D38(K) 
         DCO2D1(I,K)=A1(I)*CDT31(K)+A2(I)*CDT38(K) 
         CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
         D2CD22(I,K)=A1(I)*C2D71(K)+A2(I)*C2D78(K) 
         DCO2D2(I,K)=A1(I)*CDT71(K)+A2(I)*CDT78(K) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         D2CD21(I,K)=1.E-3*D2CD21(I,K)
         DCO2D1(I,K)=1.E-2*DCO2D1(I,K)
         D2CD22(I,K)=1.E-3*D2CD22(I,K)
         DCO2D2(I,K)=1.E-2*DCO2D2(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
         CO2MD(I,K)=A1(I)*CDTM51(K)+A2(I)*CDTM58(K)
         CO2M2D(I,K)=A1(I)*C2DM51(K)+A2(I)*C2DM58(K) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CO2MD(I,K)=1.E-2*CO2MD(I,K)
         CO2M2D(I,K)=1.E-3*CO2M2D(I,K)
      ENDDO
      ENDDO

!***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT 

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        CO21(I,KP,K)=CO2R(I,KP,K) 
!     ENDDO
!     ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        DCO2DT(I,KP,K)=A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K)
!     ENDDO
!     ENDDO
!     ENDDO
!
!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        DCO2DT(I,KP,K)=1.E-2*DCO2DT(I,KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 

!        CO21(I,KP,K)=CO21(I,KP,K)+DIFT(I,KP,K)*DCO2DT(I,KP,K) 
!5       CO21(I,KP,K)=CO21(I,KP,K)+DIFT(I,KP,K)*(1.0E-2*(a1(I)*
!5   &                CDT51(KP,K)+A2(i)*CDT58(KP,K))) 
        if ( (kp .ne. k) .or. k .eq. 1) then
         CO21(I,KP,K)=CO21(I,KP,K)+                              &
                (Tdav(i,kp) - tdav(i,k))*(1.0/ (tstdav(i,kp) -   &
                                         tstdav(i,k) + 1.E-20))* &
                       (1.0E-2*(a1(I)* &
                      CDT51(KP,K)+A2(i)*CDT58(KP,K))) 
        else if ( (kp .eq. k)  .and. (k .ge. 2) ) then
         CO21(I,KP,K)=CO21(I,KP,K)+ &
              vsum4(i,k-1)*         &
                 (1.0E-2*(a1(I)*    &
                      CDT51(KP,K)+A2(i)*CDT58(KP,K))) 
         endif
      ENDDO
      ENDDO
      ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        D2CDT2(I,KP,K)=A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        D2CDT2(I,KP,K)=1.E-3*D2CDT2(I,KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 

!        CO21(I,KP,K)=CO21(I,KP,K)+0.50*
!                     DIFT(I,KP,K)* 
!    &                DIFT(I,KP,K)*D2CDT2(I,KP,K) 
!7       CO21(I,KP,K)=CO21(I,KP,K)+0.50*
!7   &                DIFT(I,KP,K)* 
!7   &                DIFT(I,KP,K)*(1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*
!7   &                c2D58(KP,K))) 

        if ( (kp .ne. k) .or. k .eq. 1) then
         DIFTT      =(TDAV(I,KP)-TDAV(I,K))*(1.0/(tstdav(i,kp)- &
                       tstdav(i,k) + 1.E-20))
!        CO21(I,KP,K)=CO21(I,KP,K)+0.50*
         CO21(I,KP,K)=CO21(I,KP,K)+0.50*                        &
            diftt*diftt*                                        &
!8   &                DIFT(I,KP,K)* 
!8   &                DIFT(I,KP,K)* 
!    &          (0.5*((Tdav(i,kp) - tdav(i,k))*(1.0/ (tstdav(i,kp) - 
!    &                         tstdav(i,k) + 1.E-20)) *
!    &          (Tdav(i,kp) - tdav(i,k))* (1.0/ (tstdav(i,kp) - 
!    &                        tstdav(i,k) + 1.E-20)) ) )*
               ((1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*c2D58(KP,K)))) 
!    &              (1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*c2D58(KP,K))) 
        else if ( (kp .eq. k)  .and. (k .ge. 2) ) then
         CO21(I,KP,K)=CO21(I,KP,K)+0.50*                        &
              vsum4(i,k-1)*                                     &
              vsum4(i,k-1)*                                     &
                    (1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*c2D58(KP,K))) 
        endif
      ENDDO
      ENDDO
      ENDDO

!***COMPUTE TRANSMISSION FCTNS USED IN SPA88
!---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS 
!    INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1)) 

      DO K=1,LP1
      DO I=1,IMAX 
!6       CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K,1)*
!6   &               (DCO2D1(I,K)+0.50*DIFT(I,K,1)*D2CD21(I,K)) 
!6       CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K,1)*
!6   &               (DCO2D2(I,K)+0.50*DIFT(I,K,1)*D2CD22(I,K)) 
         CO2SP1(I,K)=CO2R1(I,K)+                                &
                ((Tdav(i,k) - tdav(i,1))*(1.0/ (tstdav(i,k) -   &
                     tstdav(i,1)   + 1.E-20))) *                &
                     (DCO2D1(I,K)+0.50*                         &
                ((Tdav(i,k ) - tdav(i,1))*(1.0/ (tstdav(i,k ) - &
                        tstdav(i,1)  + 1.E-20)))*               &
                        D2CD21(I,K)) 
         CO2SP2(I,K)=CO2R2(I,K)+                                &
                ((Tdav(i,k) - tdav(i,1)) *(1.0/ (tstdav(i,k ) - &
                           tstdav(i,1)  + 1.E-20)))*            &
                     (DCO2D2(I,K)+0.50*                         &
                ((Tdav(i,k) - tdav(i,1))*(1.0/ (tstdav(i,k ) -  &
                         tstdav(i,1) + 1.E-20)))*               &
              D2CD22(I,K)) 
      ENDDO
      ENDDO

!--- WE AREN''T DOING NBL TFS ON THE 100 CM-1 BANDS .
      DO K=1,LMAX
      DO I=1,IMAX 
!7       CO2NBL(I,K)=CO2MR(I,K)+DIFT(I,K,K+1)*(CO2MD(I,K)+0.50* 
!7   &                      DIFT(I,K,K+1)*CO2M2D(I,K)) 
         CO2NBL(I,K)=CO2MR(I,K)+                               &
             ((Tdav(i,k ) - tdav(i,k+1))*(1.0/ (tstdav(i,k ) - &
                        tstdav(i,k+1) + 1.E-20)))*             &
       (CO2MD(I,K)+0.50*                                       &
            ((Tdav(i,k ) - tdav(i,k+1))*(1.0/ (tstdav(i,k ) -  &
                      tstdav(i,k+1) + 1.E-20)))*               &
                CO2M2D(I,K)) 
      ENDDO
      ENDDO

!***COMPUTE TEMP. COEFFICIENT BASED ON TTTT(K) (SEE REF.2) 
      DO K=1,LP1
      DO I=1,IMAX
         IF (TTTT(I,K) <= 250.) THEN
              TLSQU(I,K)=B0+(TTTT(I,K)-250.)*      &
                            (B1+(TTTT(I,K)-250.)*  &
                         (B2+B3*(TTTT(I,K)-250.))) 
         ELSE 
            TLSQU(I,K)=B0 
         ENDIF
      ENDDO
      ENDDO

!***APPLY TO ALL CO2 TFS
      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 
         CO21(I,KP,K)=CO21(I,KP,K)*(1.0-TLSQU(I,KP))+TLSQU(I,KP) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CO2SP1(I,K)=CO2SP1(I,K)*(1.0-TLSQU(I,1))+TLSQU(I,1) 
         CO2SP2(I,K)=CO2SP2(I,K)*(1.0-TLSQU(I,1))+TLSQU(I,1) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CO2NBL(I,K)=CO2NBL(I,K)*(1.0-TLSQU(I,K))+TLSQU(I,K) 
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      IF (Present(LSFC)) THEN
         CALL FST88 (KTOP,KBTM,NCLDS,EMCLD,PRESS,TEMP,CAMT,RRVCO2, &
                     HEATRA,GRNFLX,TOPFLX, LSFC)
      ELSE
         CALL FST88 (KTOP,KBTM,NCLDS,EMCLD,PRESS,TEMP,CAMT,RRVCO2, &
                     HEATRA,GRNFLX,TOPFLX)
      ENDIF
!-----------------------------------------------------------------------
      END SUBROUTINE LWRAD2

!#######################################################################
!#######################################################################

      SUBROUTINE FST88 (KTOP,KBTM,NCLDS,EMCLD,PRESS,TEMP,CAMT,RRVCO2, &
                         HEATRA,GRNFLX,TOPFLX, LSFC)

!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      KTOP    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD TOP,USED
!                    IN THE LONGWAVE PROGRAM
!      KBTM    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD BOTTOM,
!                    USED IN THE LONGWAVE PROGRAM
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT.
!      EMCLD   =  CLOUD EMISSIVITY. SET TO ONE BY DEFAULT, BUT MAY
!                    BE MODIFIED FOR USE IN LONGWAVE PROGRAM.
!      PRESS   =  PRESSURE (CGS UNITS) AT DATA LEVELS OF MODEL
!      TEMP    =  TEMPERATURE (K) AT DATA LEVELS OF MODEL
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                 SPECIFIED IN THE KTOP/KBTM INDICES)
!      RRVCO2  =  THE VOLUME MIXING RATIO OF CO2 (SCALAR)
!                 (used in NLTE, passed by argument list)
!
!      LSFC    =  Vertical index of the lowest model level,
!                    dimensioned by IMAX. (For eta coordinate)
!
!-----------------------------------------------------------------------
!                        OUTPUT PARAMETERS
!                        -----------------
!
!      HEATRA     =  HEATING RATE AT DATA LEVELS (K/DAY)
!      GRNFLX     =  NET LONGWAVE FLUX AT THE GROUND (CGS UNITS)
!      TOPFLX     =  NET LONGWAVE FLUX AT THE TOP    (CGS UNITS)
!
!
!-----------------------------------------------------------------------
!     ***************************************************************** 
!          SUBROUTINE FST88 IS THE MAIN COMPUTATION MODULE OF THE 
!     LONG-WAVE RADIATION CODE. IN IT ALL "EMISSIVITY" CALCULATIONS,
!     INCLUDING CALLS TO TABLE LOOKUP SUBROUTINES. ALSO,AFTER CALLING 
!     SUBROUTINE "SPA88", FINAL COMBINED HEATING RATES AND GROUND 
!     FLUX ARE OBTAINED.
!     ***************************************************************** 
!-----------------------------------------------------------------------
!              OTHER INPUTS:  
!              -------------
!        BETINW,BETAWD,AB15WD              BDWIDE 
!        BETAD,BO3RND,AO3RND               BANDTA 
!        QH2O,P,DELP2,DELP,T,VAR1,VAR2,    KDACOM 
!        VAR3,VAR4,CNTVAL                  KDACOM 
!        BCLDS                             RDBITS 
!        INDX2,KMAXV,SOURCE,DSRCE          TABCOM 
!        SKC1R,SKC3R,KMAXVM,NREP1,NREP2    TABCOM 
!        CO2NBL,CO2SP,CO21                 TFCOM
!
!              OUTPUTS: 
!        FLX1E1                            RDFLUX 
! 
!          CALLED BY  :    LWR88
!
!          CALLS      :    CLO88,E1E288,E3V88,SPA88,NLTE
!
!
!              PASSED VARIABLES:  
!              
!              IN E3V88:  
!        EMD     =  E3 FUNCTION FOR H2O LINES (0-560,1200-2200 CM-1)
!                     COMPUTED IN E3V88 
!        TPL     =  TEMPERATURE INPUT FOR E3 CALCULATION IN E3V88 
!        EMPL    =  H2O AMOUNT,INPUT FOR E3 CALCULATION IN E3V88
!
!              IN E1E288: 
!        E1CTS1  =  E1 FUNCTION FOR THE (I+1)TH LEVEL USING THE 
!                   TEMPERATURE OF THE ITH DATA LEVEL,COMPUTED OVER 
!                   THE FREQUENCY RANGE 0-560,1200-2200 CM-1. (E1CTS1-
!                   E1CTW1) IS USED IN OBTAINING THE FLUX AT THE TOP
!                   IN THE 0-160,1200-2200 CM-1 RANGE (FLX1E1). 
!        E1CTS2  =  E1 FUNCTION FOR THE ITH LEVEL, USING THE TEMP. OF 
!                   THE ITH DATA LEVEL,COMPUTED OVER THE FREQUENCY RANGE
!                   0-560,1200-2200 CM-1. (E1CTS2-E1CTW2) IS ALSO USED
!                   IN OBTAINING THE FLUX AT THE TOP IN THE 0-160,. 
!                   1200-2200 CM-1 RANGE. 
!        E1FLX   =  E1 FCTN. FOR THE ITH LEVEL,USING THE TEMPERATURE AT 
!                   THE TOP OF THE ATMOSPHERE. COMPUTED OVER THE FREQ.
!                   RANGE 0-560,1200-2200 CM-1. USED FOR Q(APPROX) TERM.
!                   (IN COMMON BLOCK TFCOM) 
!        E1CTW1  =  LIKE E1CTS1,BUT COMPUTED OVER THE 160-560 CM-1 RANGE
!                   AND USED FOR Q(APPROX,CTS) CALCULATION
!        E1CTW2  =  LIKE E1CTS2,BUT COMPUTED OVER THE 160-560 CM-1 RANGE
!                   AND USED FOR Q(APPROX,CTS) CALCULATION
!        FXO     =  TEMPERATURE INDEX USED FOR E1 FUNCTION AND ALSO 
!                   USED FOR SOURCE FUNCTION CALC. IN FST88.
!        DT      =  TEMP. DIFF.BETWEEN MODEL TEMPS. AND TEMPS. AT 
!                   TABULAR VALUES OF E1 AND SOURCE FCTNS. USED IN
!                   FST88 AND IN E1 FUNCTION CALC.
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
!#include "bdwide.h"
!-----------------------------------------------------------------------
!#include "bdcomb.h"
!-----------------------------------------------------------------------
!----------------INPUT ARGUMENTS----------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMCLD,PRESS,TEMP,CAMT
      REAL,    INTENT(IN)                 :: RRVCO2
      INTEGER, INTENT(IN), DIMENSION(:), OPTIONAL :: LSFC

!                         D I M E N S I O N
!    &  KTOP(IMAX,LP1),KBTM(IMAX,LP1),NCLDS(IMAX),EMCLD(IMAX,LP1),
!    &  TEMP(IMAX,LP1),PRESS(IMAX,LP1),CAMT(IMAX,LP1),LSFC(IMAX)
!----------------OUTPUT ARGUMENTS---------------------------------------

      REAL,   INTENT(OUT), DIMENSION(:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:)   :: GRNFLX,TOPFLX

!----------------OUTPUT ARGUMENTS---------------------------------------
!     DIMENSION   HEATRA(IMAX,LMAX),GRNFLX(IMAX),TOPFLX(IMAX)
!-----------------------------------------------------------------------
!----------------LOCAL ARRAY STORAGE------------------------------------
      integer :: i, k, n, klen, kmaxs, kk, kp, icnt, nc
      real    :: hm5
      integer :: IXO(IMAX,LP1),ITOP(IMAX),IBOT(IMAX)
      real    :: VTMP1(IMAX,LP1M),VTMP2(IMAX,LP1V),VTMP3(IMAX,LP1),   &
                 C(IMAX,LLP1),ALP(IMAX,LLP1),DSORC(IMAX,LP1),         &
                 TOTPHI(IMAX,LP1),TOTO3(IMAX,LP1),TPHIO3(IMAX,LP1),   &
                 RLOG(IMAX,LMAX),DELPTC(IMAX),PTOP(IMAX),PBOT(IMAX),  &
                 FTOP(IMAX),FBOT(IMAX) 
!-----------------------------------------------------------------------
!  ------DIMENSION OF VARIABLES EQUIVALENCED TO THOSE ABOVE------
      real    :: TVAL(IMAX,LP1),VSUM1(IMAX,LP1),HEATEM(IMAX,LP1) 
      real    :: EMXX(IMAX,LMAX)
      real    :: CSUB(IMAX,LLP1) 
      real    :: FLX(IMAX,LP1)
      real    :: OSS(IMAX,LP1),CSS(IMAX,LP1),SS2(IMAX,LP1),TC(IMAX,LP1), &
                DTC(IMAX,LP1)
      real    :: ALPSQ1(IMAX,LP1),ALPSQ2(IMAX,LP1) 
      real    :: DELPR1(IMAX,LP1),DELPR2(IMAX,LP1) 
      real    :: FLXNET(IMAX,LP1),FLXTHK(IMAX,LP1) 
      real    :: Z1(IMAX,LP1),CEVAL(IMAX,LP1)
      real    :: TOTEVV(IMAX,LP1)
      real    :: AVMO3(IMAX,LP1M),AVPHO3(IMAX,LP1V),FAC1(IMAX,LP1V)
      real    :: FAC2(IMAX,LP1M),AVVO2(IMAX,LP1M),AVEPHJ(IMAX,LP1V)
!1    DIMENSION OVER(IMAX,LP1,LP1)
!     DIMENSION OVER1D(IMAX,LP1M)
!1    DIMENSION EMISST(IMAX,LP1,LP1)
!---DIMENSION OF VARIABLES EQUIVALENCED TO THOSE IN OTHER COMMON BLKS-- 
!     DIMENSION TO31D(IMAX,LP1M),EMI21D(IMAX,LP1M)
!     DIMENSION CO21D(IMAX,LP1M),EMIS1D(IMAX,LP1M)
!     DIMENSION AVEP1D(IMAX,LP1M),AVEP1(IMAX*LP1M)
!---DIMENSION OF VARIABLES PASSED TO OTHER SUBROUTINES--- 
      real    :: E1CTS1(IMAX,LP1),E1CTS2(IMAX,LMAX) 
      real    :: E1CTW1(IMAX,LP1),E1CTW2(IMAX,LMAX) 
      real    :: FXO(IMAX,LP1),DT(IMAX,LP1)
      real    :: EMD(IMAX,LLP1),TPL(IMAX,LLP1),EMPL(IMAX,LLP1) 
!---EMX1 IS A LOCAL VARIABLE USED AS INPUT AND OUTPUT TO E1E288--
      real    :: EMX1(IMAX)

!     EQUIVALENCE (VTMP3,TVAL,VSUM1,EMXX,TC,HEATEM) 
!     EQUIVALENCE (VTMP2,VTMP21,AVPHO3,FAC1,AVEPHJ) 
!     EQUIVALENCE (VTMP1,AVMO3,FAC2,AVVO2,OVER,EMISST)
!     EQUIVALENCE (DSORC,TOTEVV,DELPR1,OSS,SUM,FLXNET)
!     EQUIVALENCE (TOTPHI,DELPR2,CSS,FLX,Z1)
!     EQUIVALENCE (TOTO3,ALPSQ1,DTC,FLXTHK) 
!     EQUIVALENCE (TPHIO3,ALPSQ2,SS2,CEVAL) 
!     EQUIVALENCE (AVEPHI,AVEP1D,AVEP1),(EMI21D,EMISS2) 
!     EQUIVALENCE (OVER1D,OVER),(TO31D,TO3),(EMIS1D,EMISS)
!     EQUIVALENCE (CO21D,CO21)
!     EQUIVALENCE (ALP,CSUB)
!-----------------------------------------------------------------------

!          FIRST SECTION IS TABLE LOOKUP FOR SOURCE FUNCTION AND
!     DERIVATIVE (B AND DB/DT).ALSO,THE NLTE CO2 SOURCE FUNCTION
!     IS OBTAINED 

      DO K=1,LP1
      DO I=1,IMAX 
         FXO(I,K)=AINT((TEMP(I,K)-100.)*0.10+1.0)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         TVAL(I,K)=90.+10.*FXO(I,K)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         DT(I,K)=TEMP(I,K)-TVAL(I,K) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         IXO(I,K)=FXO(I,K) 
         SS1(I,K)=0.0 
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      DO 110 N=1,NBLY 

      DO K=1,LP1
      DO I=1,IMAX 
         SORC(I,K,N)=SOURCE(IXO(I,K),N) 
         DSORC(I,K)=DSRCE(IXO(I,K),N) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         SORC(I,K,N)=SORC(I,K,N)+DT(I,K)*DSORC(I,K)
      ENDDO
      ENDDO

      IF (N == 11 .or. N == 12 .or. N == 14) THEN 
         DO K=1,LP1
         DO I=1,IMAX 
            SS1(I,K)=SS1(I,K)+SORC(I,K,N) 
         ENDDO
         ENDDO
      ENDIF 

 110  CONTINUE
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         CSOUR1(I,K)=SORC(I,K,9) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CSOUR2(I,K)=SORC(I,K,10)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         OSOUR(I,K)=SORC(I,K,13) 
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
!
!     THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
! 
!     CALL NLTE (PRESS,RRVCO2)
!     DO 141 K=1,INLTE
!     DO 141 I=1,IMAX 
!     CSOUR1(I,K)=SORC(I,K,9) 
!     CSOUR2(I,K)=SORC(I,K,10)
!141  CONTINUE
! 
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         CSOUR(I,K)=CSOUR1(I,K)+CSOUR2(I,K)
      ENDDO
      ENDDO
 
!-----------------------------------------------------------------------
!     SECOND SECTION PRODUCES 4 MATRICES FOR LATER USE IN PROGRAM:  
!     1) AVEPHI(I,J) IS THE SCALED WATER MASS FOR USE IN TABLES (THIS 
!     IS U(P,P'') IN REF.(4);
!     2) OVER (I,J) IS THE WATER TRANSMISSION FUNCTION (USING 
!     "EMISSIVITY" APPROXIMATION) IN THE 560-800 CM-1  BAND;
!     3) TO3(I,J) IS THE EXACT OZONE TRANSMISSION FUNCTION (USING 
!     PARAMETERS FOR THE 990-1070 CM-1 BAND FROM THE 1982 AFGL CATALOG) 
!     4)EMISS2(I,J) IS THE EMISSIVITY H20 TRANSMISSION FUNCTION DUE 
!     TO THE 10 UM CONTINUUM,TREATED AS ONE BAND. 

      DO I=1,IMAX 
         TOTPHI(I,1)=0.0
         TOTO3(I,1)=0.0 
         TPHIO3(I,1)=0.0
         TOTVO2(I,1)=0.0
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1) 
      ENDDO
      ENDDO


!     THE CALCULATIONAL PROCEDURE USED HERE IS: 
!       1) FROM THE 1-D VECTORS (TOTPHI,TOTO3,ETC) CONSTRUCT A 1-D
!  ARRAYS INCLUDING ALL INFORMATION FOR THE UPPER (I>J) TRIANGLE
!  OF THE SYMMETRIC MATRICES(LP1,LP1);
!       2)PERFORM COMPUTATIONS ON THESE ARRAYS TO OBTAIN TO3,OVER,
!  AVEPHJ: UPPER TRIANGLE OF THE SYMMETRIC MATRICES IN 1-D FORM 
!       3) LOAD NUMBERS INTO THE UPPER TRIANGLE OF THE 2-D
!  MATRICES TO3,OVER,AVEPHI,USING THE CDC Q8MERG FUNCTION 
!       4) FILL UP THE LOWER TRIANGLE,USING THE CDC "SCATTER" FUNCTION
!     THE DIAGRAM BELOW ILLUSTRATES THE RELATIONSHIP BETWEEN THE 1-D
!  ARRAY AND THE 2-D SYMMETRIC MATRIX FOR A 4X4 MATRIX. 
! 
!                    I
!             1      2       3       4
!           --------------------------
!        1           1       2       3     THE NOS. ARE THE 
!    J   2                   4       5     POSITIONS IN THE 
!        3                           6     1-D ARRAY
!        4
! 
!***IN ORDER TO USE A MINIMUM OF STORAGE SPACE, THE CALCULATIONS HAVE 
!   BEEN ORDERED AS FOLLOWS:  
! 
!     ---------------------------------------
!     STAGE 1...COMPUTE O3 TRANSMISSION FCTNS
!     ---------------------------------------

      DO K=1,LMAX
         KLEN=LP1-K
         KMAXS=KMAXV(K)
         DO KK=1,KLEN
            DO I=1,IMAX 
               AVMO3(I,KMAXS+KK-1)=TOTO3(I,KK+K)-TOTO3(I,K)
               AVPHO3(I,KMAXS+KK-1)=TPHIO3(I,KK+K)-TPHIO3(I,K) 
            ENDDO
         ENDDO
      ENDDO

!---SOME OF THE CALCS. BELOW ARE "STRIP-MINED" SO THAT VECTOR CALCS.
!   ARE RESTRICTED TO A LENGTH OF 65535.  THIS IS A CYBER 205 LIMIT.
!   (THE COMPILER HANDLES STRIP-MINING  OF FORTRAN 77 CODE).

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         FAC1(I,KK)=BO3RND(2)*AVPHO3(I,KK)/AVMO3(I,KK)
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         FAC2(I,KK)=4.0*AO3RND(2)*AVMO3(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP1(I,KK)=1.0+FAC2(I,KK)/FAC1(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP1(I,KK)=SQRT(VTMP1(I,KK)) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=0.50*(FAC1(I,KK)*(VTMP1(I,KK)-1.0))
      ENDDO
      ENDDO

      DO K=1,LMAX
         KLEN=LP1-K
         KMAXS=KMAXV(K)
         DO KK=1,KLEN
            DO I=1,IMAX 
               AVVO2(I,KMAXS+KK-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
            ENDDO
         ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         TO3SPC(I,K)=VTMP2(I,K)
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=VTMP2(I,KK)+SKO3R*AVVO2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=-1.0*VTMP2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=EXP(VTMP2(I,KK))
      ENDDO
      ENDDO

      DO K=1,LMAX
         KMAXS=KMAXV(K)
         DO KP=K+1,LP1 
            DO I=1,IMAX 
               TO3(I,KP,K)=VTMP2(I,KMAXS-(K+1)+KP) 
            ENDDO
         ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         TO3(I,K,K)=1.0
      ENDDO
      ENDDO

      DO K=1,KMAXVM 
      DO I=1,IMAX
         TO3(I,INDX1(K),INDX2(K))=VTMP2(I,K)
      ENDDO
      ENDDO

! 
!     -------------------------
!     STAGE 2... COMPUTE AVEPHI 
!     -------------------------
! 
      DO 401 K=1,LMAX
         KLEN=LP1-K
         KMAXS=KMAXV(K)

         DO KK=1,KLEN
         DO I=1,IMAX 
            AVEPHJ(I,KMAXS+KK-1)=TOTPHI(I,KK+K)-TOTPHI(I,K) 
         ENDDO
         ENDDO
 
         DO KP=K+1,LP1 
         DO I=1,IMAX 
            AVEPHI(I,KP,K)=AVEPHJ(I,KMAXS-(K+1)+KP) 
         ENDDO
         ENDDO

 401  CONTINUE


      DO K=1,LP1
      DO I=1,IMAX 
         AVEPHI(I,K,K)=1.01E-16 
      ENDDO
      ENDDO

      DO K=1,KMAXVM 
      DO I=1,IMAX
         AVEPHI(I,INDX1(K),INDX2(K))=AVEPHJ(I,K)
      ENDDO
      ENDDO


!     ----------------------
!     STAGE 3...COMPUTE OVER 
!     ----------------------

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=AB15WD*AVEPHJ(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=SQRT(VTMP2(I,KK)) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=VTMP2(I,KK)+SKC1R*AVVO2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=-1.0*VTMP2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=EXP(VTMP2(I,KK))
      ENDDO
      ENDDO

!     DO K=1,LMAX
!        KMAXS=KMAXV(K)
!        DO KP=K+1,LP1 
!        DO I=1,IMAX 
!           OVER(I,KP,K)=VTMP2(I,KMAXS-(K+1)+KP)
!        ENDDO
!        ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO I=1,IMAX 
!        OVER(I,K,K)=1.0 
!     ENDDO
!     ENDDO

!     DO K=1,KMAXVM 
!     DO I=1,IMAX
!        OVER(I,INDX1(K),INDX2(K))=VTMP2(I,K)
!     ENDDO
!     ENDDO


!     ------------------------
!     STAGE 4...COMPUTE EMISS2
!     ------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         VTMP3(I,K)=TOTVO2(I,K)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         VTMP3(I,K)=-1.0*VTMP3(I,K) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX
         VTMP3(I,K)=EXP(VTMP3(I,K))
      ENDDO
      ENDDO

!   COMPUTE 1-BAND CONTINUUM TRANSMISSIVITIES (EMISS2)

      DO K=1,LP1
      DO I=1,IMAX 
         TOTEVV(I,K)=1.0/VTMP3(I,K)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO KP=1,K 
      DO I=1,IMAX 
         EMISS2(I,KP,K)=VTMP3(I,K)*TOTEVV(I,KP)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO KP=K+1,LP1 
      DO I=1,IMAX 
         EMISS2(I,KP,K)=VTMP3(I,KP)*TOTEVV(I,K)
      ENDDO
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
!         THE THIRD SECTION CALCULATES BOUNDARY LAYER AND NEARBY LAYER
!     CORRECTIONS TO THE TRANSMISSION FUNCTIONS OBTAINED ABOVE. METHODS 
!     ARE GIVEN IN REF. (4).
!-----------------------------------------------------------------------
!     THE FOLLOWING RATIOS ARE USED IN VARIOUS NBL CALCULATIONS: 

      DO K=2,LMAX
      DO I=1,IMAX 
         DELPR1(I,K)=DELP(I,K)*(PRESS(I,K)-P(I,K)) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         DELPR2(I,K)=DELP(I,K-1)*(P(I,K)-PRESS(I,K-1)) 
      ENDDO
      ENDDO


!        THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE H2O 
!     TRANS. FCTN (OVER) COMBINED WITH THE CO2 FCTN (CO21). 
! 
!       COMBINE CO21,OVER INTO CO21; BEFORE MAKING NBL CORRECTIONS, 
!     LOAD (1,K) VALUES FOR USE IN EXACT CTS CALCULATIONS IN SPA88. 

      DO K=1,LMAX
         KMAXS=KMAXV(K)
         DO KP=K+1,LP1 
         DO I=1,IMAX 
         CO21(I,KP,K)=CO21(I,KP,K)*VTMP2(I,KMAXS-(K+1)+KP)
         ENDDO
         ENDDO
      ENDDO

!     DO K=1,LP1
!     DO I=1,IMAX 
!        OVER(I,K,K)=1.0 
!     ENDDO
!     ENDDO

      DO K=1,KMAXVM 
      DO I=1,IMAX
!        CO21(I,KP,K)=CO21(I,KP,K)*
         CO21(I,indx1(k), indx2(k))=CO21(I,indx1(k), indx2(k))* &
                                       VTMP2(I,K)
      ENDDO
      ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        CO21(I,KP,K)=CO21(I,KP,K)*OVER(I,KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CO2SP(I,K)=CO21(I,1,K)
      ENDDO
      ENDDO


!       PERFORM NBL COMPUTATIONS FOR THE CO2 15 UM BAND 

      DO K=2,LMAX
      DO I=1,IMAX 
         ALPSQ1(I,K)=SQRT(DELPR1(I,K)) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         ALPSQ2(I,K)=SQRT(DELPR2(I,K)) 
      ENDDO
      ENDDO


!     DO K=1,LMAX
!        KMAXS=KMAXV(K)
!        DO KP=K+1,LP1 
!        DO I=1,IMAX 
!           OVER(I,KP,K)=VTMP2(I,KMAXS-(K+1)+KP)
!        ENDDO
!        ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO I=1,IMAX 
!        OVER(I,K,K)=1.0 
!     ENDDO
!     ENDDO

!     DO K=1,KMAXVM 
!     DO I=1,IMAX
!        OVER(I,INDX1(K),INDX2(K))=VTMP2(I,K)
!     ENDDO
!     ENDDO

!     DO K=1,LMAX
!     DO I=1,IMAX 
!        RLOG(I,K)=OVER(I,K,K+1) 
!     ENDDO
!     ENDDO

      do k=1,LMAX
      do i=1,IMAX
      do kk=1,KMAXVM
        if (indx1(kk) .eq. k .and. indx2(kk) .eq. (k+1) ) then
          rlog(i,k) = vtmp2(i,kk)
          cycle
        endif
      end do
      end do
      end do


      DO K=1,LMAX
      DO I=1,IMAX 
         RLOG(I,K)=RLOG(I,K)*CO2NBL(I,K) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         RLOG(I,K)=LOG(RLOG(I,K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         ALP(I,LM1+K)=-ALPSQ1(I,K)*RLOG(I,K) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         ALP(I,K-1)=-ALPSQ2(I,K)*RLOG(I,K-1) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         ALP(I,LL)=-RLOG(I,LMAX)
         ALP(I,LLP1)=-RLOG(I,LMAX)* &
                         SQRT(DELP(I,LMAX)*(P(I,LP1)-PRESS(I,LM1)))
      ENDDO


!***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY 
!   EVALUATED.

      DO K=1,LLP1 
      DO I=1,IMAX 
         C(I,K)=ALP(I,K)*(-0.66667+ALP(I,K)*(0.25+ALP(I,K)*(-0.066667)))
      ENDDO
      ENDDO

      DO I=1,IMAX 
         CO21(I,LP1,LP1)=1.0+C(I,LMAX)
         CO21(I,LP1,LMAX)=1.0+(DELP2(I,LMAX)*C(I,LL)-(PRESS(I,LMAX)- &
                      P(I,LMAX))*C(I,LLM1))/(P(I,LP1)-PRESS(I,LMAX)) 
         CO21(I,LMAX,LP1)=1.0+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)-    &
                           (P(I,LP1)-PRESS(I,LMAX))*C(I,LMAX))/      &
                           (PRESS(I,LMAX)-PRESS(I,LM1))
      ENDDO


!***  THE K INDICES IN THE FOLLOWING LOOP RUN FROM 21 TO 40 IN THE
!     L40 SKYHI CODE VERSION

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=1.0+0.50*(C(I,LM1+K)+C(I,K-1))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CO21(I,K,K)=CEVAL(I,K-1)
      ENDDO
      ENDDO


!    COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
!    ONE-BAND CONTINUUM BAND (EMISS2 AND TO3). THE SF2 FUNCTION IS
!    USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).

      DO K=2,LMAX
      DO I=1,IMAX 
         CSUB(I,K)=CNTVAL(I,K)*DELPR1(I,K) 
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CSUB(I,K+LM1)=CNTVAL(I,K-1)*DELPR2(I,K) 
      ENDDO
      ENDDO


!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED

      HM5=-0.50
      DO K=2,LLM1 
      DO I=1,IMAX 
!        C(I,K)=CSUB(I,K)*(HM5+CSUB(I,K)*
!    &                               (0.166666-CSUB(I,K)*0.0416666))
         C(I,K)= 0.166666-CSUB(I,K)*0.0416666
         C(I,K)= CSUB(I,K)*(CSUB(I,K)*C(I,K)-0.50)
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMISS2(I,LP1,LP1)=1.0+C(I,LLM1) 
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=1.0+0.50*(C(I,K)+C(I,LM1+K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         EMISS2(I,K,K)=CEVAL(I,K-1)
      ENDDO
      ENDDO

      DO K=2,LLM1 
      DO I=1,IMAX 
         CSUB(I,K)=CSUB(I,K)*SKO3R 
      ENDDO
      ENDDO

!
!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED

      DO K=2,LLM1 
      DO I=1,IMAX 
         C(I,K)=CSUB(I,K)*(-0.50+CSUB(I,K)* &
                                     (0.166666-CSUB(I,K)*0.0416666))
      ENDDO
      ENDDO

      DO I=1,IMAX 
         TO3(I,LP1,LP1)=1.0+C(I,LLM1)
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=1.0+0.50*(C(I,K)+C(I,LM1+K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         TO3(I,K,K)=CEVAL(I,K-1) 
      ENDDO
      ENDDO


!-----------------------------------------------------------------------
!          FOURTH SECTION OBTAINS WATER TRANSMISSION FUNCTIONS
!     USED IN Q(APPROX) CALCULATIONS AND ALSO MAKES NBL CORRECTIONS:  
!     1) EMISS (I,J) IS THE TRANSMISSION FUNCTION MATRIX OBTAINED 
!     BY CALLING SUBROUTINE E1E288; 
!     2) "NEARBY LAYER" CORRECTIONS (EMISS(I,I)) ARE OBTAINED 
!     USING SUBROUTINE E3V88; 
!     3) SPECIAL VALUES AT THE SURFACE (EMISS(LMAX,LP1),EMISS(LP1,L),
!     EMISS(LP1,LP1)) ARE CALCULATED. 
! 
!     EMXX,AV1,AND EMPL ARE COMPUTED BEFORE AVEPHI IS MODIFIED
! 
!      OBTAIN ARGUMENTS FOR E1E288 AND E3V88: 
!-----------------------------------------------------------------------
! 
      DO I=1,IMAX 
         EMX1(I)=QH2O(I,LMAX)*PRESS(I,LMAX)*(PRESS(I,LMAX)-P(I,LMAX))* &
                                                             GP0INV
      ENDDO

      DO K=1,LM1
      DO I=1,IMAX 
         EMXX(I,K)=AVEPHI(I,K,LMAX)+EMX1(I) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMPL(I,1)=AVEPHI(I,LMAX,LP1) 
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         EMPL(I,K)=QH2O(I,K-1)*P(I,K)*(P(I,K)-PRESS(I,K-1))*GP0INV
      ENDDO
      ENDDO

      DO K=LP2,LL 
      DO I=1,IMAX 
         EMPL(I,K)=QH2O(I,K-LMAX)*P(I,K-LMAX)* &
                   (PRESS(I,K-LMAX)-P(I,K-LMAX))*GP0INV
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMPL(I,LLP1)=EMPL(I,LL) 
      ENDDO

      DO I=1,IMAX 
         TPL(I,1)=TEMP(I,LMAX)
         TPL(I,LP1)=0.50*(TTTT(I,LP1)+TEMP(I,LMAX)) 
         TPL(I,LLP1)=0.50*(TTTT(I,LMAX)+TEMP(I,LMAX))
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         TPL(I,K)=TTTT(I,K) 
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         TPL(I,K+LMAX)=TTTT(I,K) 
      ENDDO
      ENDDO


!---THE CALCULATION OF TTEMP HAS BEEN MOVED TO E1E288 TO SAVE STORAGE 

      DO K=2,LMAX
      DO I=1,IMAX 
         AVEPHI(I,K,K)=EMXX(I,K-1) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         AVEPHI(I,LP1,LMAX)=AVEPHI(I,LP1,LMAX)+EMPL(I,LMAX) 
      ENDDO


!     COMPUTE LOGS OF WATER MASS ARGUMENTS FOR  E1E288; 
!     THE CORRESPONDING QUANTITY FOR E3V88 (EMPL) MUST BE OBTAINED
!     WITHIN THAT SUBROUTINE, AS EMPL IS USED AFTER E3V88 IS CALLED.

      DO KK=1,LP1 
      DO K=1,LP1 
      DO I=1,IMAX
         AVEPHI(I,K,KK)=LOG10(AVEPHI(I,K,KK))
      ENDDO
      ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
!     CALL E1E288 FOR EMISSIVITY TRANSMISSION FCTNS FOR H2O 
!     -----------------------------------------------------
           CALL E1E288 (E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,FXO,DT,TEMP)
! 
!-----------------------------------------------------------------------
!
!     CALL E3V88 FOR NBL H2O TRANSMISSIVITIES 
!     ---------------------------------------
           CALL E3V88 (EMD,TPL,EMPL) 
!
!-----------------------------------------------------------------------
! 
!   COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
!    USING METHODS FOR H2O GIVEN IN REF. (4)

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=EMD(I,K+LMAX)+EMD(I,K)
      ENDDO
      ENDDO

      DO K=1,LM1
      DO I=1,IMAX 
         EMISS(I,LP1,K)=0.50*(EMISS(I,K+1,K+1)+EMISS(I,LP1,K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         EMISS(I,K,K)=CEVAL(I,K-1) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMISS(I,LMAX,LP1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
          EMX1(I) + 0.25*(EMISS(I,LMAX,LP1)+EMISS(I,LP1,LMAX)) 
         EMISS(I,LP1,LP1)=2.0*EMD(I,LP1) 
         EMISS(I,LP1,LMAX)=2.0*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*    &
                        EMPL(I,LLP1))/(QH2O(I,LMAX)*PRESS(I,LMAX)* &
                        (P(I,LP1)-PRESS(I,LMAX))*GP0INV) 
      ENDDO


!-----------------------------------------------------------------------
!     SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER,
!     CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
! 
                         CALL SPA88 (PRESS,TEMP)
!
!-----------------------------------------------------------------------
! 
!          THIS SECTION PERFORMS THE CALCULATION OF "EMISSIVITY"
!     FLUXES FOR THE 4 COMPONENTS COMPRISING THE LW FREQUENCY REGION. 
!     (EMISS = THE 0-160,1200-2200 CM-1 BAND; EMISS2 THE 800-990, 
!     1070-1200 CM-1 BAND; TO3 THE 990-1070 CM-1 BAND; CO21 THE 560-800 
!     CM-1 BAND).  EMISST IS THE COMBINED EXCHANGE TERM AND FLX THE 
!     COMBINED NET FLUX.
!
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         OSS(I,K)=OSOUR(I,K)-OSOUR(I,K-1)
         CSS(I,K)=CSOUR(I,K)-CSOUR(I,K-1)
         DTC(I,K)=TC(I,K)-TC(I,K-1)
         SS2(I,K)=SS1(I,K)-SS1(I,K-1)
      ENDDO
      ENDDO

!1    DO K=1,LP1
!1    DO I=1,IMAX 
!1       EMISST(I,1,K)=TC(I,1)*E1FLX(I,K)+SS1(I,1)*EMISS2(I,K,1)+
!1   &                 OSOUR(I,1)*TO3(I,K,1)+CSOUR(I,1)*CO2SP(I,K)
!1    ENDDO
!1    ENDDO

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

!1    DO K=1,LP1
!1    DO KP=2,LP1 
!1    DO I=1,IMAX 
!1       EMISST(I,KP,K)=DTC(I,KP)*EMISS(I,KP,K)+
!1   &                  SS2(I,KP)*EMISS2(I,KP,K)+OSS(I,KP)*TO3(I,KP,K)+
!1   &                  CSS(I,KP)*CO21(I,KP,K) 
!1    ENDDO
!1    ENDDO
!1    ENDDO

!1    DO K=1,LP1
!1    DO KP=1,LP1 
!1    DO I=1,IMAX 
!1       EMISST(I,KP,K)=EMISST(I,KP,K)*CLDFAC(I,KP,K)
!1    ENDDO
!1    ENDDO
!1    ENDDO


!---THE ORDER OF THE 911 LOOPS IS TO MINIMIZE "MEMORY CONFLICTS"
!   ON THE CYBER 205

      DO K=1,LP1
      DO I=1,IMAX 
!f       FLX(I,K)=0.0 
         FLX(I,K)=                                                     &
         (TC(I,1)*E1FLX(I,K)+SS1(I,1)*EMISS2(I,K,1)+                   &
                       OSOUR(I,1)*TO3(I,K,1)+CSOUR(I,1)*CO2SP(I,K)) *  &
           cldfac(i,1,k) 
      ENDDO
      ENDDO

!f    DO KP=1,LP1 
      DO KP=2,LP1 
      DO K=1,LP1
      DO I=1,IMAX 
!f       FLX(I,K)=FLX(I,K)+EMISST(I,KP,K)
         FLX(I,K)=FLX(I,K)+                                             &
                       ( DTC(I,KP)*EMISS(I,KP,K)+                       &
                        SS2(I,KP)*EMISS2(I,KP,K)+OSS(I,KP)*TO3(I,KP,K)+ &
                        CSS(I,KP)*CO21(I,KP,K) ) *cldfac(i,kp,k)
      ENDDO
      ENDDO
      ENDDO


!-----------------------------------------------------------------------
!    THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2 
!    EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800- 
!    990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE 
!    CONTAINED IN CTSO3, COMPUTED IN SPA88. 
!-----------------------------------------------------------------------

      DO K=1,LMAX 
      DO I=1,IMAX
      CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)*                              &
             (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + &
              SS1(I,K)*(EMISS2(I,K+1,1)*CLDFAC(I,K+1,1)-               &
                        EMISS2(I,K,1)*CLDFAC(I,K,1))) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         CEVAL(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - &
                           CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K)))
      ENDDO
      ENDDO

      DO I=1,IMAX
         FLX1E1(I)=0.0
      ENDDO

      DO K=1,LMAX 
      DO I=1,IMAX
         FLX1E1(I)=FLX1E1(I)+CEVAL(I,K)
      ENDDO
      ENDDO

      DO I=1,IMAX
         FLX1E1(I)=FLX1E1(I)+TC(I,LP1)*CLDFAC(I,LP1,1)* &
                   (E1CTS1(I,LP1)-E1CTW1(I,LP1))
      ENDDO


!-----------------------------------------------------------------------
!     FINAL SECTION OBTAINS EMISSIVITY HEATING RATES, 
!     TOTAL HEATING RATES AND THE FLUX AT THE GROUND
!-----------------------------------------------------------------------

!     .....CALCULATE THE EMISSIVITY HEATING RATES 

      DO K=1,LMAX 
      DO I=1,IMAX
         HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
      ENDDO
      ENDDO

!     .....CALCULATE THE TOTAL HEATING RATES

      DO K=1,LMAX 
      DO I=1,IMAX
         HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
      ENDDO
      ENDDO

!     .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
!    TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) 

      DO K=1,LMAX 
      DO I=1,IMAX
         VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1 
      ENDDO
      ENDDO

      DO I=1,IMAX
         TOPFLX(I)=FLX1E1(I)+GXCTS(I)
      ENDDO


!---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
!    THE THICK CLOUD SECTION IS INVOKED.

      DO I=1,IMAX
         FLXNET(I,1)=TOPFLX(I) 
      ENDDO

      DO K=2,LP1 
      DO I=1,IMAX
         FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
      ENDDO
      ENDDO

      IF (Present(LSFC)) THEN
         DO I=1,IMAX
            GRNFLX(I)=FLXNET(I,LSFC(I)+1) 
         ENDDO
      ELSE
         DO I=1,IMAX
            GRNFLX(I)=FLXNET(I,LP1) 
         ENDDO
      ENDIF


!-----------------------------------------------------------------------
!     THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD 
!     FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT,
!     FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED.
!***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE 
!   ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS.
!-----------------------------------------------------------------------

      ICNT=0
      DO I=1,IMAX
         ICNT=ICNT+NCLDS(I)
      ENDDO

      IF (ICNT == 0) GO TO 6999


!***THE OUTER LOOP IS ON THE NO. OF CLOUDS( BEGINNING AT NC=2,AS NC=1 IS
!   A DUMMY LAYER)

!    **************************************
              DO 6001 NC=2,LP1
!    **************************************

!***OBTAIN THE LARGEST NO. OF CLOUDS IN THE LAT. ROW. IF THE CLOUD
!   INDEX (NC) IS GREATER THAT THIS NO.,TERMINATE THE CLOUD LOOP

      ICNT=0
      DO I=1,IMAX
         IF (NCLDS(I) >= NC-1) THEN
            ICNT=ICNT+1
         ENDIF
      ENDDO
      IF (ICNT == 0) GO TO 6999 

!***FOR THE NC''TH CLOUD LEVEL,OBTAIN THE TOP AND BOTTOM INDEX,AND 
!   COUNT THE NO. OF THICK CLOUDS (DEFINED AS A NONZERO DIFFERENCE
!   BET. THE TOP AND BOTTOM INDICES). SKIP TO THE NEXT CLOUD INDEX
!   (INCREMENT NC) IF THIS NO. IS ZERO. 

      DO I=1,IMAX
         ITOP(I)=KTOP(I,NC)
         IBOT(I)=KBTM(I,NC)
      ENDDO

      ICNT=0
      DO I=1,IMAX
         IF (ITOP(I) < IBOT(I)) THEN
            ICNT=ICNT+1
         ENDIF
      ENDDO
      IF (ICNT == 0) GO TO 6001 

!***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF
!   THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE
!   BEEN DEFINED!). 

      DO I=1,IMAX
         PTOP(I)=P(I,ITOP(I))
         FTOP(I)=FLXNET(I,ITOP(I))
         PBOT(I)=P(I,IBOT(I)+1)
         FBOT(I)=FLXNET(I,IBOT(I)+1)
      ENDDO

!***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC) 

      DO I=1,IMAX
         DELPTC(I)=(FBOT(I)-FTOP(I))/(PBOT(I)-PTOP(I)) 
      ENDDO

!***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR 
!   ALL LEVELS. THIS QUANTITY WILL BE USED ONLY IN THE THICK CLOUD
!   LEVELS, BUT, FOR EFFICIENCY, IS COMPUTED FOR ALL LEVELS.

      DO K=1,LP1 
      DO I=1,IMAX
         Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
      ENDDO
      ENDDO

!***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN 
!   THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY 
!    THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED.

      DO K=1,LP1 
      DO I=1,IMAX
         FLXTHK(I,K)=FLXNET(I,K)*(1.0-CAMT(I,NC)*EMCLD(I,NC)) + &
                     Z1(I,K)*CAMT(I,NC)*EMCLD(I,NC)
      ENDDO
      ENDDO

!***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS. 

      DO K=1,LP1
      DO I=1,IMAX
         IF (K > ITOP(I) .and. K <= IBOT(I)  &
                          .and.  (NC-1) <= NCLDS(I))  THEN
              FLXNET(I,K)=FLXTHK(I,K)
         ENDIF
      ENDDO
      ENDDO

!                   ******END OF CLOUD LOOP***** 
 6001                        CONTINUE
!                   ***************************

!-----------------------------------------------------------------------
!                THE THICK CLOUD SECTION ENDS HERE.
!-----------------------------------------------------------------------

 6999                        CONTINUE

!-----------------------------------------------------------------------

!***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE 
!   REVISED FLUXES: 

      DO K=1,LMAX 
      DO I=1,IMAX
         HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
      ENDDO
      ENDDO

!---------------------------------------------------------------------**
      END SUBROUTINE FST88

!#######################################################################
!#######################################################################

      SUBROUTINE E1E288 (G1,G2,G3,G4,G5,FXOE1,DTE1,TEMP)

!-----------------------------------------------------------------------
!     SUBROUTINE E1E288 COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION
!  FOR LONGWAVE RADIATION FOR ALL TERMS EXCEPT THE EXCHANGE WITH THE
!  TOP OF THE ATMOSPHERE. THE METHOD IS A TABLE LOOKUP ON A PRE-
!  COMPUTED E2 FUNCTION (DEFINED IN REF. (4)).
!      THE E1 FUNCTION  CALCULATIONS (FORMERLY DONE IN SUBROUTINE 
!  E1V88 COMPUTE THE FLUX RESULTING FROM THE EXCHANGE OF PHOTONS
!  BETWEEN A LAYER AND THE TOP OF THE ATMOSPHERE.  THE METHOD IS A
!  TABLE LOOKUP ON A PRE-COMPUTED E1 FUNCTION.
!     CALCULATIONS ARE DONE IN TWO FREQUENCY RANGES:  
!       1) 0-560,1200-2200 CM-1   FOR Q(APPROX) 
!       2) 160-560 CM-1           FOR Q(APPROX,CTS).
!  MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4).
!-----------------------------------------------------------------------
!       INPUTS:                    (COMMON BLOCKS)
!     TABLE1,TABLE2,TABLE,EM1,EM1WDE   TABCOM 
!     AVEPHI                           TFCOM
!     TEMP                      ARGUMENT LIST 
!     T                                KDACOM 
!     FXOE1,DTE1                ARGUMENT LIST 
!
!       OUTPUTS:  
!     EMISS                            TFCOM
!     G1,G2,G3                  ARGUMENT LIST,FOR 1ST FREQ. RANGE 
!     G4,G5                     ARGUMENT LIST,FOR 2ND FREQ. RANGE 
! 
!        CALLED BY :     FST88
!        CALLS     :  
! 
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "tabcom.h"
real :: EM1   (28,180),EM1WDE(28,180),EM3   (28,180),  &
     &                 TABLE1(28,180),TABLE2(28,180),TABLE3(28,180)
      COMMON /TABCOM/  EM1   , EM1WDE, EM3   ,  &
     &                 TABLE1, TABLE2, TABLE3
!-----------------------------------------------------------------------
      REAL,  INTENT(OUT), DIMENSION(:,:) :: G1,G2,G3,G4,G5
      REAL,  INTENT(IN) , DIMENSION(:,:) :: FXOE1,DTE1,TEMP

!**** I/O ARGUMENTS
!CC   DIMENSION FXOE1(IMAX,LP1),DTE1(IMAX,LP1),G1(IMAX,LP1),
!CC  &          G2(IMAX,LMAX),G3(IMAX,LP1),G4(IMAX,LP1),G5(IMAX,LMAX) 
!CC   DIMENSION  TEMP(IMAX,LP1)
!-----------------------------------------------------------------------
      integer :: kk, k, i, kp
      integer :: IT1(IMAX,LL3P) 
      real    :: TTEMP(IMAX,LP1,LP1)
      real    :: FIT1(IMAX,LL3P),DTOT1(IMAX,LL3P),                    &
                 DTOT2(IMAX,LL3P),DTOT3(IMAX,LL3P),DTOT4(IMAX,LL3P),  &
                 WW1(IMAX,LP1),WW2(IMAX,LP1)
      real    :: FYO(IMAX,LP1),DU(IMAX,LP1),F1(IMAX,LP1)
!-----------------------------------------------------------------------
      real    :: FXO(IMAX,LP1),FIVAL(IMAX,LP1),  &
                    DT(IMAX,LP1),F2(IMAX,LP1),F3(IMAX,LP1)
      integer :: IVAL(IMAX,LP1)
      real    :: T1(5040),T2(5040),T4(5040)
      real    :: EM1V(5040),EM1VW(5040)
!     DIMENSION TTMP1D(IMAX,LP1M) 

      CHARACTER(LEN=40) :: err_string
!-----------------------------------------------------------------------
      EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) 
!     EQUIVALENCE (TTMP1D,TTEMP)
!     EQUIVALENCE (IVAL,IT1),(FIVAL,FIT1),(DT,WW1)
!     EQUIVALENCE (FXO,WW2),(F2,DTOT2),(F3,DTOT3) 
      EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)),  &
                  (T4(1),TABLE3(1,1))
!-----------------------------------------------------------------------

      DO KK=1,LP1
      DO K=1,LP1
      DO I=1,IMAX 
         TTEMP(I,K,KK)=TTTT(I,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LM1
      DO I=1,IMAX 
         TTEMP(I,K+1,K+1)=TEMP(I,LMAX)
      ENDDO
      ENDDO

      DO I=1,IMAX 
         TTEMP(I,LP1,LMAX)=TEMP(I,LM1)
      ENDDO


!-----------------------------------------------------------------------
!---THE REST OF THE SUBROUTINE IS CARRIED OUT WITHIN A K-LOOP (121) 
!    PRIMARILY TO CONSERVE STORAGE. SOME LOSS OF SPEED OCCURS.
!-----------------------------------------------------------------------
                         DO 121 K=1,LP1
!-----------------------------------------------------------------------
! 
      DO KP=1,LP1 
      DO I=1,IMAX 
         FXO(I,KP)=AINT((TTEMP(I,KP,K)-100.)*0.10+1.0) 
         FYO(I,KP)=AINT((AVEPHI(I,KP,K)+16.)*10.)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         DU(I,KP)=AVEPHI(I,KP,K)-0.10*(FYO(I,KP)+1.0)+16.1
         DT(I,KP)=TTEMP(I,KP,K)-10.*FXO(I,KP)-90.
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         FYO(I,KP)=28.*FYO(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         FIVAL(I,KP)=FYO(I,KP)+FXO(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         IVAL(I,KP)=FIVAL(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1
      DO I=1,IMAX
         IF (IVAL(I,KP) > 5040) THEN
            Write (err_string(1:32),800) i,kp,ival(i,kp)
 800        Format ('i,kp,ival=',2i6,i10)
            CALL Error_Mesg ('E1E288 in LONGWAVE_MOD', &
                             err_string(1:32), NOTE)
         ENDIF
         F1(I,KP)=T1(IVAL(I,KP)) 
         F2(I,KP)=T2(IVAL(I,KP)) 
         F3(I,KP)=T4(IVAL(I,KP)) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         EMISS(I,KP,K)=F1(I,KP)+DU(I,KP)*F2(I,KP)+DT(I,KP)*F3(I,KP)
      ENDDO
      ENDDO


!***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY
!    DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE 
!    SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE
!    BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED 
!    IN THE E2 CALCS.,WITH K=1).
! 
!                      ----------------
                       IF (K == 1) THEN
!                      ----------------

      DO KP=1,LP1 
      DO I=1,IMAX 
         FIT1(I,KP)=FYO(I,KP)+FXOE1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LMAX 
      DO I=1,IMAX 
         FIT1(I,LP1+KP)=FYO(I,KP+1)+FXOE1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         FIT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
      ENDDO
      ENDDO

      DO KP=1,LL3P
      DO I=1,IMAX 
         IT1(I,KP)=FIT1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         WW1(I,KP)=10.-DTE1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         WW2(I,KP)=0.10-DU(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LL3P 
      DO I=1,IMAX
         DTOT1(I,KP)=EM1V(IT1(I,KP)) 
         DTOT2(I,KP)=EM1V(IT1(I,KP)+1) 
         DTOT3(I,KP)=EM1V(IT1(I,KP)+28)
         DTOT4(I,KP)=EM1V(IT1(I,KP)+29)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
      G1(I,KP)=WW1(I,KP)*WW2(I,KP)*DTOT1(I,KP)+  &
               WW2(I,KP)*DTE1(I,KP)*DTOT2(I,KP)+ &
               WW1(I,KP)*DU(I,KP)*DTOT3(I,KP)+   &
               DTE1(I,KP)*DU(I,KP)*DTOT4(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LMAX 
      DO I=1,IMAX 
      G2(I,KP)=WW1(I,KP)*WW2(I,KP+1)*DTOT1(I,KP+LP1)+  &
               WW2(I,KP+1)*DTE1(I,KP)*DTOT2(I,KP+LP1)+ &
               WW1(I,KP)*DU(I,KP+1)*DTOT3(I,KP+LP1)+   &
               DTE1(I,KP)*DU(I,KP+1)*DTOT4(I,KP+LP1) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
      G3(I,KP)=WW1(I,1)*WW2(I,KP)*DTOT1(I,KP+LLP1)+   &
               WW2(I,KP)*DTE1(I,1)*DTOT2(I,KP+LLP1)+  &
               WW1(I,1)*DU(I,KP)*DTOT3(I,KP+LLP1)+    &
               DTE1(I,1)*DU(I,KP)*DTOT4(I,KP+LLP1) 
      ENDDO
      ENDDO


!...REPEAT FOR WIDE-BAND COMPUTATIONS OF G4,G5

      DO KP=1,LLP1 
      DO I=1,IMAX
         DTOT1(I,KP)=EM1VW(IT1(I,KP))
         DTOT2(I,KP)=EM1VW(IT1(I,KP)+1)
         DTOT3(I,KP)=EM1VW(IT1(I,KP)+28) 
         DTOT4(I,KP)=EM1VW(IT1(I,KP)+29) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         G4(I,KP)=WW1(I,KP)*WW2(I,KP)*DTOT1(I,KP)+   &
                  WW2(I,KP)*DTE1(I,KP)*DTOT2(I,KP)+  &
                  WW1(I,KP)*DU(I,KP)*DTOT3(I,KP)+    &
                  DTE1(I,KP)*DU(I,KP)*DTOT4(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LMAX 
      DO I=1,IMAX 
         G5(I,KP)=WW1(I,KP)*WW2(I,KP+1)*DTOT1(I,KP+LP1)+   &
                  WW2(I,KP+1)*DTE1(I,KP)*DTOT2(I,KP+LP1)+  &
                  WW1(I,KP)*DU(I,KP+1)*DTOT3(I,KP+LP1)+    &
                  DTE1(I,KP)*DU(I,KP+1)*DTOT4(I,KP+LP1) 
      ENDDO
      ENDDO

!                       -------------
                            ENDIF 
!-----------------------------------------------------------------------
 121                       CONTINUE
!-----------------------------------------------------------------------
      END SUBROUTINE E1E288

!#######################################################################
!#######################################################################

      SUBROUTINE E3V88 (EMV,TV,AV) 

!C    IMPLICIT NONE
!-----------------------------------------------------------------------
!     SUBROUTINE E3V88 COMPUTES NEARBY LAYER TRANSMISSIVITIES FOR 
!  H2O USING A TABLE LOOKUP OF THE PRE-COMPUTED E3 FUNCTION 
! ( DESCRIBED IN REF. (4)). 
!-----------------------------------------------------------------------
!         INPUTS:                 (COMMON BLOCKS,ARGS.) 
!       TV,AV                      ARGUMENT LIST
!       EM3                        TABCOM 
!
!          OUTPUTS: 
!       EMV                        ARGUMENT LIST
! 
!       CALLED BY  :    FST88 
! 
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "tabcom.h"
      real ::          EM1   (28,180),EM1WDE(28,180),EM3   (28,180), &
                       TABLE1(28,180),TABLE2(28,180),TABLE3(28,180)
      COMMON /TABCOM/  EM1    ,EM1WDE ,EM3   , &
                       TABLE1 ,TABLE2 ,TABLE3
!-----------------------------------------------------------------------
      REAL, INTENT(OUT), DIMENSION(:,:) :: EMV
      REAL, INTENT(IN),  DIMENSION(:,:) :: TV,AV

      INTEGER, DIMENSION(SIZE(TV,1),SIZE(TV,2)) ::  IT
      REAL, DIMENSION(SIZE(TV,1),SIZE(TV,2)) ::  FXO,FYO,FIT,WW1, &
                            AV1LOG,D1,D2,D3,D4,TVAL,DT,WW2,UVAL,DU
!-----------------------------------------------------------------------
      REAL :: EM3V(5040)
      INTEGER I,K
!-----------------------------------------------------------------------
      EQUIVALENCE (EM3V(1),EM3(1,1))
!-----------------------------------------------------------------------

         AV1LOG(:,:)=LOG10(AV(:,:))

         FXO(:,:)=AINT((TV(:,:)-100.)*0.10+1.0)

         TVAL(:,:)=90.+10.*FXO(:,:)

         DT(:,:)=TV(:,:)-TVAL(:,:) 

         FYO(:,:)=AINT((AV1LOG(:,:)+16.)*10.)

         UVAL(:,:)=-16.1+0.10*(FYO(:,:)+1.0)

         DU(:,:)=AV1LOG(:,:)-UVAL(:,:) 

         FIT(:,:)=FXO(:,:)+FYO(:,:)*28.

         IT(:,:)=FIT(:,:)

      DO K=1,SIZE(TV,2)
      DO I=1,SIZE(TV,1)
         D1(I,K)=EM3V(IT(I,K)) 
         D2(I,K)=EM3V(IT(I,K)+1) 
         D3(I,K)=EM3V(IT(I,K)+28)
         D4(I,K)=EM3V(IT(I,K)+29)
      ENDDO
      ENDDO

         WW1(:,:)=10.-DT(:,:)
         WW2(:,:)=0.10-DU(:,:)

         EMV(:,:)=WW1(:,:)*WW2(:,:)*D1(:,:)+WW2(:,:)*DT(:,:)*D2(:,:)+ &
                  WW1(:,:)*DU(:,:)*D3(:,:)+DT(:,:)*DU(:,:)*D4(:,:) 

!-----------------------------------------------------------------------
      END SUBROUTINE E3V88

!#######################################################################
!#######################################################################

      SUBROUTINE SPA88 (PRESS,TEMP)

!-----------------------------------------------------------------------
!     SUBROUTINE SPA88 COMPUTES EXACT CTS HEATING RATES AND FLUXES AND
!  CORRESPONDING CTS EMISSIVITY QUANTITIES FOR H2O,CO2 AND O3.
!
!          INPUTS:                (COMMON BLOCKS) 
!       ACOMB,BCOMB,APCM,BPCM                  BDCOMB 
!       ATPCM,BTPCM,BETACM                     BDCOMB 
!       BETINW                                 BDWIDE 
!       VAR1,VAR2,P,DELP,DELP2                 KDACOM 
!       TOTVO2,TO3SPC,CO2SP1,CO2SP2,CO2SP      TFCOM
!       CLDFAC                                 CLDCOM 
!       SKO2D                                  TABCOM 
!       SORC,CSOUR,OSOUR                       SRCCOM 
!           OUTPUTS:  
!       EXCTS,EXCTSN,CTSO3                     TFCOM
!        GXCTS,FCTSG                           RDFLUX 
!           CALLED BY:  
!       FST88 
! 
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
!#include "bdwide.h"
!-----------------------------------------------------------------------
!#include "bdcomb.h"
!-----------------------------------------------------------------------
      REAL,  INTENT(IN), DIMENSION(:,:) :: PRESS,TEMP

!     DIMENSION  PRESS(IMAX,LP1),TEMP(IMAX,LP1)
!-----------------------------------------------------------------------
      integer :: k, n
      real ::    CAPPHI(IMAX,LP1),CAPPSI(IMAX,LP1),TT(IMAX,LMAX), &
                 FAC1(IMAX,LMAX),FAC2(IMAX,LMAX),                 &
                 CTMP(IMAX,LP1),CDIF(IMAX,LMAX),                  &
                 TOPM(IMAX,LMAX),TOPPHI(IMAX,LMAX),               &
                 BOT(IMAX),                                       &
                 X(IMAX,LMAX),Y(IMAX,LMAX),VFLUX(IMAX,LMAX)
!-----------------------------------------------------------------------
      real :: F(IMAX,LMAX),FF(IMAX,LMAX),AG(IMAX,LMAX),AGG(IMAX,LMAX), &
       AH(IMAX,LMAX),AHH(IMAX,LMAX),AI(IMAX,LMAX),AII(IMAX,LMAX),        &
       AJ(IMAX,LMAX),AJJ(IMAX,LMAX),FELSX(IMAX,LMAX),                    &
       PHITMP(IMAX,LMAX),PSITMP(IMAX,LMAX)
!-----------------------------------------------------------------------
!     EQUIVALENCE (CAPPHI,AJ,AI,AH,AG,F,PHITMP) 
!     EQUIVALENCE (CAPPSI,AJJ,AII,AHH,AGG,FF,PSITMP)
!-----------------------------------------------------------------------

!     COMPUTE TEMP. TEMPEDENCE OF LINE INTENSITIES (CAPPHI,CAPPSI)

      DO K=1,LMAX
      DO I=1,IMAX 
         X(I,K)=TEMP(I,K)-250.
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         Y(I,K)=X(I,K)*X(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         EXCTS(I,K)=0.0 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         GXCTS(I)=0.0 
      ENDDO

!*************BEGIN LOOP ON FREQUENCY BANDS (N)*************************

                       DO 200 N=1,NBLM 

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

      DO K=1,LMAX
      DO I=1,IMAX 
         F(I,K)=0.044194*(APCM(N)*X(I,K)+BPCM(N)*Y(I,K)) 
         FF(I,K)=0.044194*(ATPCM(N)*X(I,K)+BTPCM(N)*Y(I,K))
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AG(I,K)=(1.418191+F(I,K))*F(I,K)+1.0
         AGG(I,K)=(1.418191+FF(I,K))*FF(I,K)+1.0 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AH(I,K)=AG(I,K)*AG(I,K) 
         AHH(I,K)=AGG(I,K)*AGG(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AI(I,K)=AH(I,K)*AH(I,K) 
         AII(I,K)=AHH(I,K)*AHH(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AJ(I,K)=AI(I,K)*AI(I,K) 
         AJJ(I,K)=AII(I,K)*AII(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CAPPHI(I,K)=AJ(I,K)*AJ(I,K) 
         CAPPSI(I,K)=AJJ(I,K)*AJJ(I,K) 
      ENDDO
      ENDDO


!   OBTAIN WEIGHED OPTICAL PATH AND MEAN PRESSURE (TOPM,TOPPHI) 

      DO K=1,LMAX
      DO I=1,IMAX 
         PHITMP(I,K)=VAR1(I,K)*CAPPHI(I,K) 
         PSITMP(I,K)=VAR2(I,K)*CAPPSI(I,K) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         TOPM(I,1)=PHITMP(I,1) 
         TOPPHI(I,1)=PSITMP(I,1) 
      ENDDO

      DO K=2,LMAX
!     DO I=1,IMAX 
         TOPM(:,K)=TOPM(:,K-1)+PHITMP(:,K) 
         TOPPHI(:,K)=TOPPHI(:,K-1)+PSITMP(:,K) 
!     ENDDO
      ENDDO

!***COMPUTE CTS TRANSMISSION FCTNS FOR ALL BANDS (TT) 

      DO K=1,LMAX
      DO I=1,IMAX 
         FAC1(I,K)=ACOMB(N)*TOPM(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(N)*TOPPHI(I,K))
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         FELSX(I,K)=FAC1(I,K)/SQRT(1.0+FAC2(I,K))
      ENDDO
      ENDDO


!***ADD H2O CONTINUUM PATHS FOR FREQ. BANDS 5-14

      IF (N >= 5 .and. N <= 14) THEN
         DO K=1,LMAX
         DO I=1,IMAX 
            FELSX(I,K)=FELSX(I,K)+BETACM(N)*TOTVO2(I,K+1)*SKO2D 
         ENDDO
         ENDDO
      ENDIF 

!***ADD O3 PATHS FOR BAND 13:990-1070 BAND

      IF (N == 13) THEN 
         DO K=1,LMAX
         DO I=1,IMAX 
            FELSX(I,K)=FELSX(I,K)+TO3SPC(I,K) 
         ENDDO
         ENDDO
      ENDIF 

      DO K=1,LMAX
      DO I=1,IMAX 
         FELSX(I,K)=-1.0*FELSX(I,K) 
      ENDDO
      ENDDO


!***COMPUTE EXPONENTIAL (TT)

      DO K=1,LMAX
      DO I=1,IMAX
         TT(I,K)=EXP(FELSX(I,K))
      ENDDO
      ENDDO

!***ADD THE CO2 TRANSMISSIVITIES FOR BANDS 9 AND 10 (15 UM BAND)

      IF (N == 9) THEN
         DO K=1,LMAX
         DO I=1,IMAX 
            TT(I,K)=TT(I,K)*CO2SP1(I,K+1) 
         ENDDO
         ENDDO
      ENDIF 

      IF (N == 10) THEN 
         DO K=1,LMAX
         DO I=1,IMAX 
            TT(I,K)=TT(I,K)*CO2SP2(I,K+1) 
         ENDDO
         ENDDO
      ENDIF 

!*** COMPUTE EXACT CTS HEATING RATES (EXCTS,EXCTSN) 

      DO I=1,IMAX 
         CTMP(I,1)=1.0 
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         CTMP(I,K)=TT(I,K-1)*CLDFAC(I,K,1) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CDIF(I,K)=SORC(I,K,N)*(CTMP(I,K+1)-CTMP(I,K)) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         EXCTSN(I,K,N)=RADCON*DELP(I,K)*CDIF(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         EXCTS(I,K)=EXCTS(I,K)+EXCTSN(I,K,N) 
      ENDDO
      ENDDO


!    OBTAIN EXACT CTS FLUXES (GXCTS,FCTSG) AND APPROX CTS HEATING 
!     RATES (CTSO3) 

      DO I=1,IMAX 
         BOT(I)=0.50*DELP(I,LMAX)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,LMAX)) + &
                   TT(I,LMAX)*(P(I,LP1)+PRESS(I,LMAX)-2.0*P(I,LMAX)))
      ENDDO

      DO I=1,IMAX 
         FCTSG(I,N)=CLDFAC(I,LP1,1)*(TT(I,LMAX)*SORC(I,LMAX,N)+  &
                    BOT(I)*(SORC(I,LP1,N)-SORC(I,LMAX,N)))
      ENDDO

      DO I=1,IMAX 
         GXCTS(I)=GXCTS(I)+FCTSG(I,N)
      ENDDO


!**************END LOOP ON FREQUENCY BANDS******************************

 200                   CONTINUE

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

      DO K=1,LMAX
      DO I=1,IMAX 
         VFLUX(I,K)=EXCTS(I,K)*DELP2(I,K)*RADCON1
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         GXCTS(I)=GXCTS(I)-VFLUX(I,K)
      ENDDO
      ENDDO

!*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
!     (CTSO3) 

      DO K=1,LMAX
      DO I=1,IMAX 
         CTSO3(I,K)=RADCON*DELP(I,K)*                          &
                    (CSOUR(I,K)*(CO2SP(I,K+1)*CLDFAC(I,K+1,1)- &
                                 CO2SP(I,K)*CLDFAC(I,K,1))  +  &
                     OSOUR(I,K)*(TO3(I,K+1,1)*CLDFAC(I,K+1,1)- &
                                 TO3(I,K,1)*CLDFAC(I,K,1)))
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      END SUBROUTINE SPA88

!#######################################################################
!#######################################################################

!         CO21                            TFCOM 
      SUBROUTINE NLTE (PRESS,RRVCO2)

!-----------------------------------------------------------------------
!     SUBROUTINE NLTE IS THE PRESENT FORMULATION OF AN NLTE 
!     CALCULATION OF THE SOURCE FCTN IN THE 15 UM REGION (2 BANDS)
!-----------------------------------------------------------------------
!
!     RRVCO2 IS THE VOLUME MIXING RATIO OF CO2 (SCALAR)
!
!-----------------------------------------------------------------------
!
!           INPUTS                       (COMMON BLOCKS)
!         BANDLO,BANDHI                   BANDTA
!         DELP                            KDACOM
!         CO21                            TFCOM 
!         CSOUR1,CSOUR2                   SRCCOM
!           OUTPUTS:  
!         SORC                            SRCCOM
!-----------------------------------------------------------------------
      REAL, INTENT(IN), DIMENSION(:,:) :: PRESS
      REAL, INTENT(IN)                 :: RRVCO2
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
      integer :: n, k, i, KP, IITER
      real ::      CMTRX(IMAX,LMAX,INLTE),VNL(IMAX,LMAX,INLTE),     &
            VSUM(IMAX,INLTE),BDENOM(IMAX,INLTE),CDIAG(IMAX,INLTE),    &
            TCOLL(IMAX,INLTE),FNLTE(IMAX,INLTE),                      &
            AZ(IMAX,INLTE),AG(IMAX,INLTE),                            &
            C1B7(2),C2B7(2),CENT(2),DEL(2) 
!-----------------------------------------------------------------------
!*****DEGENERACY FACTOR=0.5*****
      real DEGEN
      DATA DEGEN /0.5/ 
!-----------------------------------------------------------------------

      DO N=1,2
         CENT(N)=0.50*(BANDLO(N+NNLTE)+BANDHI(N+NNLTE)) 
         DEL(N)=BANDHI(N+NNLTE)-BANDLO(N+NNLTE)
         C1B7(N)=3.7412E-5*CENT(N)*CENT(N)*CENT(N)*DEL(N) 
         C2B7(N)=1.4387*CENT(N) 
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         TCOLL(I,K)=DEGEN*1.5E-5*PRESS(I,LP1)/(SECPDA*PRESS(I,K)) 
         FNLTE(I,K)=3.5*TCOLL(I,K)*C1B7(1)/(RRVCO2*C2B7(1)) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LM1 
      DO I=1,IMAX 
         CMTRX(I,KP,K)=RADCON*DELP(I,K)*(CO21(I,KP,K+1)-CO21(I,KP+1,K+1)  &
                       -CO21(I,KP,K)+CO21(I,KP+1,K)) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CMTRX(I,LMAX,K)=DELP(I,K)*(CO21(I,LMAX,K+1)-CO21(I,LMAX,K))* &
                         RADCON
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CDIAG(I,K)=CMTRX(I,K,K) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         BDENOM(I,K)=1.0/(1.0-FNLTE(I,K)*CDIAG(I,K)) 
         SORC(I,K,9)=CSOUR1(I,K) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LMAX 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*CSOUR1(I,KP)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=INLTEP,LMAX
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AZ(I,K)=CSOUR1(I,K)+FNLTE(I,K)*VSUM(I,K)
      ENDDO
      ENDDO

!              **** ITERATION BEGINS HERE ****

                       DO IITER=1,2
!                      ------------

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*SORC(I,KP,9)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AG(I,K)=FNLTE(I,K)*(VSUM(I,K)-CDIAG(I,K)*SORC(I,K,9)) 
         SORC(I,K,9)=BDENOM(I,K)*(AZ(I,K)+AG(I,K)) 
      ENDDO
      ENDDO

!                      -----------
                          ENDDO
!                      -----------

      DO K=1,INLTE
      DO I=1,IMAX 
         TCOLL(I,K)=DEGEN*1.5E-5*PRESS(I,LP1)/(SECPDA*PRESS(I,K)) 
         FNLTE(I,K)=3.5*TCOLL(I,K)*C1B7(2)/(RRVCO2*C2B7(2)) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LM1 
      DO I=1,IMAX 
         CMTRX(I,KP,K)=RADCON*DELP(I,K)*(CO21(I,KP,K+1)-CO21(I,KP+1,K+1) &
                       -CO21(I,KP,K)+CO21(I,KP+1,K)) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CMTRX(I,LMAX,K)=DELP(I,K)*(CO21(I,LMAX,K+1)-CO21(I,LMAX,K))* &
                         RADCON
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CDIAG(I,K)=CMTRX(I,K,K) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         BDENOM(I,K)=1.0/(1.0-FNLTE(I,K)*CDIAG(I,K)) 
         SORC(I,K,10)=CSOUR2(I,K)
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LMAX 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*CSOUR2(I,KP)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=INLTEP,LMAX
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AZ(I,K)=CSOUR2(I,K)+FNLTE(I,K)*VSUM(I,K)
      ENDDO
      ENDDO

!             **** ITERATION BEGINS HERE ****

                       DO IITER=1,2
!                      ------------

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*SORC(I,KP,10) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AG(I,K)=FNLTE(I,K)*(VSUM(I,K)-CDIAG(I,K)*SORC(I,K,10))
         SORC(I,K,10)=BDENOM(I,K)*(AZ(I,K)+AG(I,K))
      ENDDO
      ENDDO

!                      -----------
                          ENDDO
!                      -----------

      END SUBROUTINE NLTE

!#######################################################################
!#######################################################################

      SUBROUTINE CLO88 (KTOP,KBTM,NCLDS,CAMT,EMCLD)

!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!     SUBROUTINE CLO88 COMPUTES CLOUD TRANSMISSION FUNCTIONS FOR THE
!  LONGWAVE CODE,USING CODE WRITTEN BY BERT KATZ (301-763-8161).
!  AND MODIFIED BY DAN SCHWARZKOPF IN DECEMBER,1988.
!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      KTOP    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD TOP,USED
!                    IN THE LONGWAVE PROGRAM
!      KBTM    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD BOTTOM,
!                    USED IN THE LONGWAVE PROGRAM
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT.
!      EMCLD   =  CLOUD EMISSIVITY. SET TO ONE BY DEFAULT, BUT MAY
!                    BE MODIFIED FOR USE IN LONGWAVE PROGRAM.
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                 SPECIFIED IN THE KTOP/KBTM INDICES)
!
!-----------------------------------------------------------------------
!
!                OUTPUT:  
!      CLDFAC                       CLDCOM
! 
!----------------INPUT ARGUMENTS----------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMCLD,CAMT

!                         D I M E N S I O N
!    &  KTOP(IMAX,LP1),KBTM(IMAX,LP1),NCLDS(IMAX),EMCLD(IMAX,LP1),
!    &  CAMT(IMAX,LP1)
!-----------------------------------------------------------------------
!     DIMENSION        V1(IMAX,LP1,LP1),
      integer :: k, kp, nc, icnt
      real ::        CAMTV(IMAX),V11D(IMAX,LP1) 
!-----------------------------------------------------------------------
      LOGICAL BCLDUD,BCLDSA,BCLDSB,BCLDSC
      DIMENSION BCLDUD(2*IMAX,LP1),BCLDSA(IMAX,LP1), &
                BCLDSB(IMAX,LP1),BCLDSC(IMAX,LP1)
!-----------------------------------------------------------------------
!                      ***LOGICAL ARRAY DEFINITIONS***
!
!   BCLDUD  =  T  IF (AT GRID POINT I) :1) VERTICAL LEVEL K IS BELOW
!                 THE TOP OF CLOUD (NC);2) VERTICAL LEVEL K IS NOT
!                 BELOW THE BOTTOM OF CLOUD (NC). FOR EACH VERTICAL
!                 LEVEL K,THE FIRST (IMAX) PTS. IS FOR TEST (1);
!                 THE SECOND (IMAX) PTS. IS FOR TEST (2).
!   BCLDSA  =  T  IF (AT GRID POINT I)  EITHER VERTICAL LEVEL K OR
!                 VERTICAL LEVEL KP IS BELOW THE TOP OF CLOUD (NC).
!   BCLDSB  =  T  IF (AT GRID POINT I) EITHER VERTICAL LEVEL K OR
!                 VERTICAL LEVEL KP IS NOT BELOW THE BOTTOM OF
!                 CLOUD (NC).
!   BCLDSC  = T  IF (AT GRID POINT I) :1)VERTICAL LEVEL K IS ABOVE CLOUD
!                (NC) AND VERTICAL LEVEL KP IS BELOW CLOUD (NC), OR VICE
!                VERSA; 2) VERTICAL LEVELS K,KP ARE BOTH BELOW THE TOP
!                OF CLOUD (NC) AND ABOVE THE BOTTOM OF CLOUD (NC)
!                BELOW THE TOP OF CLOUD (NC).
!-----------------------------------------------------------------------

! *** Initialize CLDFAC ***
! *** Note: If the user wants to initialize this quantity
! ***       then it must be passed as an argument (in & out)

      DO K =1,LP1
      DO KP=1,LP1
      DO I =1,IMAX
         CLDFAC(I,KP,K)=1.0
      ENDDO
      ENDDO
      ENDDO

!               ******* LOOP ON CLOUDS *******

                       DO 1 NC=1,LMAX

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

!         *** IF NO GRID PT HAS AN (NCTH) CLOUD, ***
!         *** THE CLOUD CALCULATION IS COMPLETE  ***

                      ICNT=0
                      DO I=1,IMAX
                         IF (NC <= NCLDS(I)) THEN
                            ICNT=ICNT+1
                         ENDIF
                      ENDDO

                   IF (ICNT == 0) then
                      RETURN
                   endif

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

!***COMPUTE BCLDUD***
      DO K=1,LP1
      DO I=1,IMAX
         BCLDUD(I,K)=K.GT.KTOP(I,NC+1)
         BCLDUD(IMAX+I,K)=K.LE.KBTM(I,NC+1)
      ENDDO
      ENDDO

!***INITIALIZE THE CLOUD TF FOR THE (NCTH) CLOUD TO UNITY.
!     DO K=1,LP1
!     DO KP=1,LP1
!     DO I=1,IMAX
!        V1(I,KP,K)=1.0
!     ENDDO
!     ENDDO
!     ENDDO

!***DEFINE THE CLOUD TRANSMISSIVITY.  THE TRANSMISSIVITY IS TAKEN AS
!  (1-CLOUD EMISSIVITY) FOR THE FRACTION OF THE GRID BOX WITH THE NCTH
!  LAYER OF CLOUD, AND ONE OTHERWISE. ( NOTE THAT IF AT POINT I, THE
!  NCTH CLOUD DOES NOT EXIST, ITS AMOUNT IS TAKEN AS ZERO). AS A RESULT,
!  THE CLOUD TRANSMISSIVITY MAY BE DEFINED AS THOUGH THE EMISSIVITY
!  WERE UNITY AND THE CLOUD AMOUNT WERE MULTIPLIED BY THE EMISSIVITY.

      DO I=1,IMAX
         IF (NC <= NCLDS(I)) THEN
            CAMTV(I)=1.0-CAMT(I,NC+1)*EMCLD(I,NC+1)
         ELSE
            CAMTV(I)=1.0
         ENDIF
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX
         V11D(I,K)=CAMTV(I)
      ENDDO
      ENDDO

!***THE 221 LOOP IS THE K-LOOP. WE USED SUCH A LOOP PRIMARILY TO REDUCE
!    SPACE***

                              DO 221 K=1,LP1

      DO KP=1,LP1
      DO I=1,IMAX
         BCLDSA(I,KP)=BCLDUD(I,KP).or.BCLDUD(I,K)
         BCLDSB(I,KP)=BCLDUD(IMAX+I,KP).or.BCLDUD(IMAX+I,K)
      ENDDO
      ENDDO

!---COMBINE BCLDSA AND BCLDSB INTO BCLDSC
      DO KP=1,LP1
      DO I=1,IMAX
         BCLDSC(I,KP)=BCLDSA(I,KP).and.BCLDSB(I,KP)
      ENDDO
      ENDDO

!***DEFINE TRANSMISSION FUNCTION FOR LEVELS WHERE LOGICAL ARRAY BCLDSC
!   INDICATES THAT A CLOUD IS PRESENT

!     DO KP=1,LP1
!     DO I=1,IMAX
!        IF (BCLDSC(I,KP)) THEN
!           V1(I,KP,K)=V11D(I,KP)
!        ENDIF
!     ENDDO
!     ENDDO

!221                            CONTINUE


!***RANDOM OVERLAP OF CLOUD IS ASSUMED IS OBTAINING THE TOTAL CLOUD TF**
!     DO K=1,LP1
      DO KP=1,LP1
      DO I=1,IMAX
!        CLDFAC(I,KP,K)=CLDFAC(I,KP,K)*V1(I,KP,K)
      if (bcldsc(i,kp) ) then
         CLDFAC(I,KP,K)=CLDFAC(I,KP,K)*V11d(I,KP)
      else
      endif
      ENDDO
      ENDDO
!      ENDDO
221                            CONTINUE


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

   1                      CONTINUE

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

!-----------------------------------------------------------------------
      END SUBROUTINE CLO88

!#######################################################################
!#######################################################################

      SUBROUTINE TABLE
!-----------------------------------------------------------------------
!     SUBROUTINE TABLE COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA
!     PROGRAM. ALSO CALCULATED ARE INDICES USED IN STRIP-MINING AND FOR 
!     SOME PRE-COMPUTABLE FUNCTIONS.
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
!#include "bdwide.h"
!-----------------------------------------------------------------------
!#include "bdcomb.h"
!-----------------------------------------------------------------------
!#include "tabcom.h"
      integer :: i1, i2e, i2, indx, jp, n, icnt, j, ia, nsubds, nsb
      real    :: cent, del, bdlo, bdhi, c1, anu
      real ::          EM1   (28,180),EM1WDE(28,180),EM3   (28,180), &
                       TABLE1(28,180),TABLE2(28,180),TABLE3(28,180)
      COMMON /TABCOM/  EM1    ,EM1WDE ,EM3    , &
                       TABLE1 ,TABLE2 ,TABLE3
!-----------------------------------------------------------------------
      real ::    SUM(28,180),PERTSM(28,180),SUM3(28,180),SUMWDE(28,180), &
                 SRCWD(28,NBLX),SRC1NB(28,NBLW),DBDTNB(28,NBLW)
      real ::    ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28),         &
                 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28),     &
                 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28),         &
                 R1(28),R2(28),S2(28),T3(28),R1WD(28) 
      real ::    EXPO(180),FAC(180) 
      real ::    CNUSB(30),DNUSB(30) 
      real ::    ALFANB(NBLW),AROTNB(NBLW)
      real ::    ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW),   &
                 BETANB(NBLW)
!
!*** NOTE: THE DATA,EQUIVALENCE AND DIMENSION STATEMENTS FOR QUANTITIES 
!    EQUIVALENCED TO COMMON BLOCK BANDTA DEPEND ON THE VALUE OF THE 
!    PARAMETER NBLW.
! 
!-----------------------------------------------------------------------
!***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
!....FOR NARROW-BANDS...
      DO N=1,NBLW
         ANB(N)=ARNDM(N)
         BNB(N)=BRNDM(N)
         CENTNB(N)=0.50*(BANDLO(N)+BANDHI(N))
         DELNB(N)=BANDHI(N)-BANDLO(N)
         BETANB(N)=BETAD(N)
      ENDDO
         AB15(1)=ANB(57)*BNB(57)
         AB15(2)=ANB(58)*BNB(58)
!....FOR WIDE BANDS...
         AB15WD=AWIDE*BWIDE

!***COMPUTE INDICES: INDX2,KMAXV

      ICNT=0
      DO I1=1,LMAX
         I2E=LP1-I1
         DO I2=1,I2E
            ICNT=ICNT+1
            INDX=LP1*(I2-1)+LP2*I1
            INDX1(ICNT)=MOD(INDX,LP1)
            IF (INDX1(ICNT) == 0) INDX1(ICNT)=LP1
            INDX2(ICNT)=(INDX+LMAX)/LP1
         ENDDO
      ENDDO

         KMAXV(1)=1
      DO I=2,LMAX
         KMAXV(I)=KMAXV(I-1)+(LP2-I)
      ENDDO
         KMAXVM=KMAXV(LMAX)

!***COMPUTE RATIOS OF CONT. COEFFS
      SKC1R=BETAWD/BETINW
      SKO3R=BETAD(61)/BETINW
      SKO2D=1.0/BETINW
!
!****BEGIN TABLE COMPUTATIONS HERE***
!***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
!---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
!   WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
!   100K TO 370K.
!---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
!   180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
!   ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.

      ZMASS(1)=1.0E-16
      DO J=1,180
         JP=J+1
         ZROOT(J)=SQRT(ZMASS(J))
         ZMASS(JP)=ZMASS(J)*1.258925411
      ENDDO

      DO I=1,28
         XTEMV(I)=90.+10.*I
         TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
         FORTCU(I)=4.0*XTEMV(I)*XTEMV(I)*XTEMV(I)
      ENDDO

!******THE COMPUTATION OF SOURCE,DSRCE IS  NEEDED ONLY
!   FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
!   MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
!   THEN COMBINED (USING IBAND) INTO SOURCE.

      DO N=1,NBLY
      DO I=1,28
         SOURCE(I,N)=0.0
      ENDDO
      ENDDO

      DO N=1,NBLX
      DO I=1,28
         SRCWD(I,N)=0.0
      ENDDO
      ENDDO

!---BEGIN FREQ. LOOP (ON N)
      DO 211 N=1,NBLX

!***THE 160-1200 BAND CASES
        IF (N <= 46) THEN
          CENT=CENTNB(N+16)
          DEL=DELNB(N+16)
          BDLO=BANDLO(N+16)
          BDHI=BANDHI(N+16)
        ENDIF

!***THE 2270-2380 BAND CASE
        IF (N == NBLX) THEN
          CENT=CENTNB(NBLW)
          DEL=DELNB(NBLW)
          BDLO=BANDLO(NBLW)
          BDHI=BANDHI(NBLW)
        ENDIF

!***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
!  ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.

      NSUBDS=(DEL-1.0E-1)/10+1
      DO 213 NSB=1,NSUBDS
        IF (NSB .ne. NSUBDS) THEN
          CNUSB(NSB)=10.*(NSB-1)+BDLO+5.0
          DNUSB(NSB)=10.
        ELSE
          CNUSB(NSB)=0.50*(10.*(NSB-1)+BDLO+BDHI)
          DNUSB(NSB)=BDHI-(10.*(NSB-1)+BDLO)
        ENDIF
        C1=(3.7412E-5)*CNUSB(NSB)**3

!---BEGIN TEMP. LOOP (ON I)

        DO I=1,28
          X(I)=1.4387*CNUSB(NSB)/XTEMV(I)
          X1(I)=EXP(X(I))
          SRCS(I)=C1/(X1(I)-1.0)
          SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
        ENDDO

213   CONTINUE
211   CONTINUE

!***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
!   AND DSRCE

      DO N=1,40
      DO I=1,28
         SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
      ENDDO
      ENDDO

      DO N=9,NBLY
      DO I=1,28
         SOURCE(I,N)=SRCWD(I,N+32)
      ENDDO
      ENDDO

      DO N=1,NBLY
      DO I=1,27
         DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*0.10
      ENDDO
      ENDDO

      DO N=1,NBLW
         ALFANB(N)=BNB(N)*ANB(N)
         AROTNB(N)=SQRT(ALFANB(N))
      ENDDO

!***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
!   USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
!   BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
!   RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
!
      DO 301 N=1,NBLW
      CENT=CENTNB(N)
      DEL=DELNB(N)

!---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
!   IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
!   THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.

      DO IA=1,3
         ANU=CENT+0.50*(IA-2)*DEL
         C1=(3.7412E-5)*ANU*ANU*ANU+1.E-20

!---TEMPERATURE LOOP---
         DO I=1,28
            X(I)=1.4387*ANU/XTEMV(I)
            X1(I)=EXP(X(I))
            SC(I)=C1/((X1(I)-1.0)+1.E-20)
            DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
         ENDDO
         IF (IA == 2) THEN
            DO I=1,28
               SRC1NB(I,N)=DEL*SC(I)
               DBDTNB(I,N)=DEL*DSC(I)
            ENDDO
         ENDIF
      ENDDO

301   CONTINUE

!***NEXT COMPUTE R1,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
!   WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
!   DIFFERENT DEPENDENCE ON (ZMASS).
!---ALSO OBTAIN R1WD, WHICH IS R1 SUMMED OVER THE 160-560 CM-1 RANGE

      DO I=1,28
         SUM4(I)=0.0
         SUM6(I)=0.0
         SUM7(I)=0.0
         SUM8(I)=0.0
         SUM4WD(I)=0.0
      ENDDO

      DO N=1,NBLW
         CENT=CENTNB(N)

!***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
!   SUM6,SUM7,SUM8
         IF (CENT < 560. .or. CENT > 1200. .and. CENT <= 2200.) THEN
            DO I=1,28
               SUM4(I)=SUM4(I)+SRC1NB(I,N)
               SUM6(I)=SUM6(I)+DBDTNB(I,N)
               SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
               SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
            ENDDO
         ENDIF
!***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
         IF (CENT > 160. .and. CENT < 560.) THEN
            DO I=1,28
               SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
            ENDDO
         ENDIF

      ENDDO

      DO I=1,28
         R1(I)=SUM4(I)/TFOUR(I)
         R2(I)=SUM6(I)/FORTCU(I)
         S2(I)=SUM7(I)/FORTCU(I)
         T3(I)=SUM8(I)/FORTCU(I)
         R1WD(I)=SUM4WD(I)/TFOUR(I)
      ENDDO

      DO J=1,180
      DO I=1,28
         SUM(I,J)=0.0
         PERTSM(I,J)=0.0
         SUM3(I,J)=0.0
         SUMWDE(I,J)=0.0
      ENDDO
      ENDDO

!------- FREQUENCY LOOP BEGINS -----------------------------------------
      DO 411 N=1,NBLW
         CENT=CENTNB(N)

!***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
         IF (CENT < 560. .or. CENT > 1200. .and. CENT <= 2200.) THEN
            DO J=1,180
               X2(J)=AROTNB(N)*ZROOT(J)
               EXPO(J)=EXP(-X2(J))
            ENDDO

            DO J=1,180
               IF (X2(J) >= 100.) THEN
                  EXPO(J)=0.0
               ENDIF
            ENDDO

            DO J=121,180
               FAC(J)=ZMASS(J)*(1.0-(1.0+X2(J))*EXPO(J))/(X2(J)*X2(J))
            ENDDO

            DO J=1,180
            DO I=1,28
            SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
               PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
            ENDDO
            ENDDO

            DO J=121,180
            DO I=1,28
               SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
            ENDDO
            ENDDO
         ENDIF

!---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
         IF (CENT > 160. .and. CENT < 560.) THEN
            DO J=1,180
            DO I=1,28
               SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
            ENDDO
            ENDDO
         ENDIF

 411  CONTINUE
!-----------------------------------------------------------------------

      DO J=1,180
      DO I=1,28
         EM1(I,J)=SUM(I,J)/TFOUR(I)
         TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
      ENDDO
      ENDDO

      DO J=121,180
      DO I=1,28
         EM3(I,J)=SUM3(I,J)/FORTCU(I)
      ENDDO
      ENDDO

      DO J=1,179
      DO I=1,28
         TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*10.
      ENDDO
      ENDDO

      DO J=1,180
      DO I=1,27
         TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*0.10
      ENDDO
      ENDDO

      DO I=1,28
         TABLE2(I,180)=0.0
      ENDDO

      DO J=1,180
         TABLE3(28,J)=0.0
      ENDDO

      DO J=1,2
      DO I=1,28
         EM1(I,J)=R1(I)
      ENDDO
      ENDDO

      DO J=1,120
      DO I=1,28
         EM3(I,J)=R2(I)/2.0-S2(I)*SQRT(ZMASS(J))/3.0+T3(I)*ZMASS(J)/8.0
      ENDDO
      ENDDO

      DO J=121,180
      DO I=1,28
         EM3(I,J)=EM3(I,J)/ZMASS(J)
      ENDDO
      ENDDO


!***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
!   WE USE R1WD AND SUMWDE OBTAINED ABOVE.
      DO J=1,180
      DO I=1,28
         EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
      ENDDO
      ENDDO

      DO J=1,2
      DO I=1,28
         EM1WDE(I,J)=R1WD(I)
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      END SUBROUTINE TABLE

!#######################################################################

      SUBROUTINE RAD_ALLOC (IMAX)

      INTEGER,INTENT(IN) :: IMAX

!-----------------------------------------------------------------------
!   Allocates temporary space for longwave code
!-----------------------------------------------------------------------

!-------------- SRCCOM -----------------
      ALLOCATE (SORC(IMAX,LP1,NBLY))
      ALLOCATE (CSOUR1(IMAX,LP1))
      ALLOCATE (CSOUR2(IMAX,LP1))
      ALLOCATE (OSOUR(IMAX,LP1))
      ALLOCATE (CSOUR(IMAX,LP1))
      ALLOCATE (SS1(IMAX,LP1))

!-------------- KDACOM -----------------
      ALLOCATE (QH2O(IMAX,LP1))
      ALLOCATE (P(IMAX,LP1))
      ALLOCATE (DELP2(IMAX,LMAX))
      ALLOCATE (DELP(IMAX,LMAX))
      ALLOCATE (TTTT(IMAX,LP1))
      ALLOCATE (VAR1(IMAX,LMAX))
      ALLOCATE (VAR2(IMAX,LMAX))
      ALLOCATE (VAR3(IMAX,LMAX))
      ALLOCATE (VAR4(IMAX,LMAX))
      ALLOCATE (CNTVAL(IMAX,LP1))

!-------------- RDFLUX -----------------
      ALLOCATE (FLX1E1(IMAX))
      ALLOCATE (GXCTS(IMAX))
      ALLOCATE (FCTSG(IMAX,NBLY))

!-------------- CLDCOM -----------------
      ALLOCATE (CLDFAC(IMAX,LP1,LP1))

!-------------- TFCOM -----------------
      ALLOCATE (TO3   (IMAX,LP1,LP1))
      ALLOCATE (CO21  (IMAX,LP1,LP1))
      ALLOCATE (EMISS (IMAX,LP1,LP1))
      ALLOCATE (EMISS2(IMAX,LP1,LP1))
      ALLOCATE (AVEPHI(IMAX,LP1,LP1))

      ALLOCATE (CTS  (IMAX,LMAX))
      ALLOCATE (CTSO3(IMAX,LMAX))
      ALLOCATE (EXCTS(IMAX,LMAX))

      ALLOCATE (EXCTSN(IMAX,LMAX,NBLY))

      ALLOCATE (E1FLX (IMAX,LP1))
      ALLOCATE (CO2NBL(IMAX,LMAX))
      ALLOCATE (CO2SP1(IMAX,LP1))
      ALLOCATE (CO2SP2(IMAX,LP1))
      ALLOCATE (CO2SP (IMAX,LP1))
      ALLOCATE (TO3SPC(IMAX,LMAX))
      ALLOCATE (TOTVO2(IMAX,LP1))

!-----------------------------------------------------------------------
!-------------- TABCOM + Initialize tables for longwave ----------------

      IF (IMAX .ne. IMAXold .or. LMAX .ne. LMAXold) THEN
           IF (Allocated(INDX1)) DeAllocate (INDX1)
           IF (Allocated(INDX2)) DeAllocate (INDX2)
           IF (Allocated(KMAXV)) DeAllocate (KMAXV)
                                   Allocate (INDX1(LP1V))
                                   Allocate (INDX2(LP1V))
                                   Allocate (KMAXV(LP1))
           CALL TABLE
           IMAXold=IMAX
           LMAXold=LMAX
      ENDIF

!-----------------------------------------------------------------------

      END SUBROUTINE RAD_ALLOC

!#######################################################################

      SUBROUTINE RAD_DEALLOC

!-----------------------------------------------------------------------

!     ----- SRCCOM -----
      DEALLOCATE (SORC)
      DEALLOCATE (CSOUR1)
      DEALLOCATE (CSOUR2)
      DEALLOCATE (OSOUR)
      DEALLOCATE (CSOUR)
      DEALLOCATE (SS1)

!     ----- KDACOM -----
      DEALLOCATE (QH2O)
      DEALLOCATE (P)
      DEALLOCATE (DELP2)
      DEALLOCATE (DELP)
      DEALLOCATE (TTTT)
      DEALLOCATE (VAR1)
      DEALLOCATE (VAR2)
      DEALLOCATE (VAR3)
      DEALLOCATE (VAR4)
      DEALLOCATE (CNTVAL)

!     ----- RDFLUX -----
      DEALLOCATE (FLX1E1)
      DEALLOCATE (GXCTS)
      DEALLOCATE (FCTSG)

!     ----- CLDCOM -----
      DEALLOCATE (CLDFAC)

!-------------- TABCOM -----------------
!     DEALLOCATE (INDX1)
!     DEALLOCATE (INDX2)
!     DEALLOCATE (KMAXV)

!-------------- TFCOM -----------------
      DEALLOCATE (TO3   )
      DEALLOCATE (CO21  )
      DEALLOCATE (EMISS )
      DEALLOCATE (EMISS2)
      DEALLOCATE (AVEPHI)

      DEALLOCATE (CTS  )
      DEALLOCATE (CTSO3)
      DEALLOCATE (EXCTS)

      DEALLOCATE (EXCTSN)

      DEALLOCATE (E1FLX )
      DEALLOCATE (CO2NBL)
      DEALLOCATE (CO2SP1)
      DEALLOCATE (CO2SP2)
      DEALLOCATE (CO2SP )
      DEALLOCATE (TO3SPC)
      DEALLOCATE (TOTVO2)

!-----------------------------------------------------------------------

      END SUBROUTINE RAD_DEALLOC

!#######################################################################

                     END MODULE LONGWAVE_MOD



      module mcm_lw_mod

!   TK modified from ajb code 
!     /net/ajb/radiation_code/updates/v4.3/lw_mod.F 

!   Added interface routine (lw_rad_ss) which is called by
!     fsrad and which calls lwcool in this
!     module after constructing the appropriate inputs.

      USE   Constants_Mod, ONLY: grav, tfreeze

      Use       Fms_Mod, ONLY: Error_Mesg, FATAL, &
                               write_version_number, mpp_pe, mpp_root_pe

      implicit none
      private

      integer, parameter :: nb_lw=19, ng=3, ngp=ng+1
      integer :: ix, jx, kx, kp, km
!------------ VERSION NUMBER ----------------

      character(len=128) :: version = '$Id: mcm_lw.F90,v 13.0 2006/03/28 21:09:36 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical :: module_is_initialized = .false.

      public :: MCM_LW_RAD, mcm_lw_init, mcm_lw_end

!     -------------------------------------------------
! TK NOTE: not ready for this yet...      implicit none

!-----------------------------------------------------------------------
!--------------------- G L O B A L   D A T A ---------------------------
!-----------------------------------------------------------------------

! #include "parm.h"

! TK note: (ix,jx are set up below -- depend on domain decomposition)
!      integer, parameter :: ix = 96
!      integer, parameter :: jx = 80

! TK note: (kx,kp,km defined in rdparm)
!      integer, parameter :: kx = 14
!      integer, parameter :: kp = kx + 1
!      integer, parameter :: km = kx - 1

! TK note: (nb,ng,ngp are defined in rdparm)
!      integer, parameter :: nb=19
!      integer, parameter :: ng=3
!      integer, parameter :: ngp=ng +1

!   nb=number of spectral bands
!   ng=number of absorbing gases

!    TK: This is a name change to avoid having to change nb locally:
      INTEGER, PARAMETER :: nb = nb_lw

      INTEGER :: LMAX, i

      real :: grav_accel
      real :: pi_alpha

      real :: co2_mixrat
      real :: t_freeze

      real :: h2o_line_width(nb)
      real :: h2o_line_strength(nb)
      real :: h2o_corr_a(nb,2)
      real :: h2o_corr_b(nb,2)
      real :: absorp_table(30,12)
      real :: d_absorp_dt(7,12)

      data h2o_line_width/ &
         .93000e-01,  .18200e-00,  .94000e-01,  .79700e-01,  .73300e-01, &
         .52000e-01,  .67000e-01,  .45900e-01,  .10000e+01,  .10000e+01, &
         .89000e-01,  .23000e-00,  .32000e-00,  .29600e-00,  .45200e-00, &
         .35900e+00,  .16500e+00,  .10400e+00,  .11600e+00 /

      data h2o_line_strength/ &
         .57975e+03,  .72103e+04,  .60248e+04,  .14039e+04,  .78952e+02, &
         .42700e+01,  .71500e-01,  .27500e-01,  .00000e+00,  .00000e+00, &
         .12650e+02,  .13440e+03,  .63290e+03,  .33120e+03,  .43410e+03, &
         .13600e+03,  .35650e+02,  .90150e+01,  .15290e+01 /

      data (h2o_corr_a(i,1),i=1,19)/ &
        -.87600e-02, -.26800e-02,  .20300e-02,  .96100e-02,  .15820e-01, &
         .01705e+00,  .02620e+00,  .02918e+00,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0         /
      data (h2o_corr_a(i,2),i=1,19)/ &
        -.67500e-02, -.29300e-02,  .14300e-02,  .98400e-02,  .13710e-01, &
         .01579e+00,  .02410e+00,  .02596e+00,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0         /

      data (h2o_corr_b(i,1),i=1,19)/ &
         .14150e-04,  .15700e-05, -.10300e-04, -.43140e-04, -.37440e-04, &
        -.51440e-04, -.74100e-04, -.80760e-04,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0         /
      data (h2o_corr_b(i,2),i=1,19)/ &
         .85500e-05,  .20100e-05, -.13000e-04, -.40810e-04, -.16150e-04, &
        -.44510e-04, -.40300e-04, -.66720e-04,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0        ,  .0        , &
         .0        ,  .0        ,  .0        ,  .0         /

      data (absorp_table(i,12),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0004,.0006,.0011,.0020,.0034,.0058, &
      .0097,.0156,.0248,.0386,.0586,.0861,.1205,.1607,.2040,.2480, &
      .2918,.3362,.3812,.4250,.4665,.5045,.5386,.5707,.6037,.6395/
      data (absorp_table(i,11),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0004,.0006,.0011,.0020,.0034,.0057, &
      .0093,.0149,.0231,.0351,.0520,.0744,.1032,.1388,.1803,.2255, &
      .2715,.3157,.3580,.3993,.4404,.4812,.5200,.5558,.5899,.6248/
      data (absorp_table(i,10),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0004,.0006,.0011,.0019,.0033,.0054, &
      .0086,.0131,.0194,.0280,.0398,.0557,.0771,.1047,.1385,.1777, &
      .2206,.2648,.3080,.3497,.3910,.4328,.4748,.5155,.5535,.5886/
      data (absorp_table(i,9),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0004,.0006,.0011,.0019,.0031,.0049, &
      .0075,.0110,.0157,.0221,.0309,.0430,.0591,.0798,.1056,.1366, &
      .1728,.2133,.2565,.3004,.3436,.3856,.4271,.4680,.5079,.5456/
      data (absorp_table(i,8),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0004,.0006,.0010,.0017,.0027,.0041, &
      .0060,.0086,.0122,.0170,.0236,.0323,.0437,.0585,.0772,.1005, &
      .1287,.1622,.2005,.2426,.2865,.3301,.3721,.4127,.4525,.4915/
      data (absorp_table(i,7),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0003,.0006,.0009,.0015,.0023,.0034, &
      .0049,.0070,.0099,.0138,.0189,.0256,.0342,.0454,.0597,.0778, &
      .1003,.1278,.1603,.1977,.2390,.2824,.3257,.3673,.4073,.4466/
      data (absorp_table(i,6),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0003,.0005,.0008,.0013,.0019,.0027, &
      .0039,.0056,.0079,.0109,.0149,.0200,.0265,.0349,.0457,.0595, &
      .0769,.0986,.1250,.1565,.1928,.2331,.2758,.3187,.3603,.4003/
      data (absorp_table(i,5),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0003,.0005,.0007,.0010,.0014,.0021, &
      .0029,.0042,.0058,.0079,.0107,.0143,.0189,.0247,.0321,.0415, &
      .0535,.0688,.0879,.1113,.1395,.1727,.2104,.2515,.2943,.3366/
      data (absorp_table(i,4),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0003,.0004,.0006,.0008,.0011,.0015, &
      .0021,.0029,.0039,.0052,.0069,.0091,.0118,.0152,.0194,.0248, &
      .0316,.0402,.0510,.0647,.0819,.1031,.1290,.1598,.1954,.2351/
      data (absorp_table(i,3),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0003,.0004,.0005,.0007,.0010,.0013, &
      .0018,.0024,.0032,.0042,.0054,.0069,.0087,.0109,.0137,.0171, &
      .0214,.0267,.0333,.0416,.0520,.0652,.0818,.1025,.1277,.1579/
      data (absorp_table(i,2),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0002,.0004,.0005,.0007,.0009,.0013, &
      .0017,.0022,.0029,.0037,.0046,.0058,.0071,.0086,.0105,.0127, &
      .0154,.0186,.0225,.0273,.0331,.0404,.0496,.0613,.0762,.0949/
      data (absorp_table(i,1),i=1,30)/ &
      .0000,.0001,.0001,.0002,.0002,.0004,.0005,.0007,.0009,.0013, &
      .0017,.0022,.0028,.0036,.0044,.0054,.0066,.0079,.0094,.0111, &
      .0131,.0154,.0180,.0212,.0249,.0295,.0351,.0421,.0511,.0627/

      data d_absorp_dt/ &
      0.,.0006,.0017,.0036,.0061,.0092,.0158,0.,.0006,.0017,.0035,.0065, &
      .0114,.0230,0.,.0005,.0016,.0038,.0081,.0169,.0376,0.,.0005,.0017, &
      .0045,.0111,.0256,.0568,0.,.0004,.0021,.0065,.0178,.0421,.0864,    &
      0.,.0004,.0011,.0088,.0248,.0579,.1046,0.,.0004,.0032,.0112,.0316, &
      .0725,.1160,0.,.0004,.0036,.0141,.0392,.0880,.1256,0.,.0004,.0038, &
      .0187,.0508,.1045,.1345,0.,.0003,.0036,.0220,.0650,.1138,.1380,0., &
      .0002,.0028,.0234,.0859,.1180,.1410,0.,.0001,.0022,.0257,.0936,    &
      .1183,.1444/

      contains

!#######################################################################
      subroutine mcm_lw_init(ix_in, jx_in, kx_in)
      integer, intent(in) :: ix_in, jx_in, kx_in

      ix = ix_in
      jx = jx_in
      kx = kx_in
      kp = kx + 1
      km = kx -1

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

      return
      end subroutine mcm_lw_init
!#######################################################################

subroutine mcm_lw_end

      module_is_initialized = .false.

!---------------------------------------------------------------------

end subroutine mcm_lw_end

!#######################################################################

      SUBROUTINE MCM_LW_RAD (KTOP,KBTM,NCLDS,EMCLD, &
                      PRES,TEMP,RH2O,QO3,CAMT, &
                      RRVCO2,  HEATRA,GRNFLX,TOPFLX, phalf)

!   This illustrates the intended sizes of arrays:
!      INTEGER, INTENT(IN), DIMENSION(ix,jx,kp) :: KTOP,KBTM
!      INTEGER, INTENT(IN), DIMENSION(ix,jx)    :: NCLDS
!      REAL,    INTENT(IN), DIMENSION(ix,jx,kp) :: EMCLD
!      REAL,    INTENT(IN), DIMENSION(ix,jx,kp) :: PRES,TEMP
!      REAL,    INTENT(IN), DIMENSION(ix,jx,kx) :: RH2O,QO3
!      REAL,    INTENT(IN), DIMENSION(ix,jx,kp) :: CAMT
!      REAL,    INTENT(IN)                      :: RRVCO2

!      REAL,   INTENT(OUT), DIMENSION(ix,jx,kx) :: HEATRA
!      REAL,   INTENT(OUT), DIMENSION(ix,jx)    :: GRNFLX,TOPFLX

!     TK mod:
!      REAL,    INTENT(IN), DIMENSION(ix,jx,kp) :: phalf

      INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:,:)    :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: EMCLD
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: PRES,TEMP
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: RH2O,QO3
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: CAMT
      REAL,    INTENT(IN)                      :: RRVCO2
 
      REAL,   INTENT(OUT), DIMENSION(:,:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:,:)    :: GRNFLX,TOPFLX

!     TK mod:
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: phalf

!----------------LOCAL ARRAY STORAGE------------------------------------
      real, dimension(SIZE(PRES,1)) :: dummy
      REAL, DIMENSION(SIZE(PRES,1),SIZE(PRES,1),0:kp) :: cloud_cover

      REAL, DIMENSION(ix,jx,1:kx) :: sigma_level
      REAL, DIMENSION(ix,jx,0:kx) :: sigma_half_level
      REAL, DIMENSION(ix,jx,1:kx) :: sigma_thick
      REAL, DIMENSION(kx) :: o3_mixrat
 
      INTEGER :: i,j, n, ipr

!     TK mods:
      integer :: iindex, jindex, klev, kpr

      real :: pi

      if(.not.module_is_initialized) then
        call error_mesg('MCM_LW_RAD','module is not initialized.',FATAL)
      endif

!     ix = SIZE(PRES,1)
!     jx = SIZE(PRES,2)
      lmax = ix * (kx + 1)

!     Gather/calculate other needed parameters for ss longwave code:

!     Convert grav to grav_accel in cgs units:
      grav_accel = grav * 100.

      pi = 4. * atan(1.)
      pi_alpha = 0.28 * pi

      t_freeze = tfreeze

!     Multiply CO2 volume mixing ratio by 1.5194 to convert to mass mixing
!     ratio... TK -- need to check accuracy of this...

      co2_mixrat = RRVCO2 * 1.5194

!     Compute sigma levels, which are needed by ss routine:
!     This can be done on any x,y point in the domain.
      do klev = 1, kx
        do j=1,jx
          do i=1,ix
            sigma_level(i,j,klev) = pres(i,j,klev) / phalf(i,j,kp)
          enddo
        enddo
      enddo

!     Compute half sigma levels, which are needed by ss routine:
      do klev = 1, kp
        do j=1,jx
         do i=1,ix
          sigma_half_level(i,j,klev-1) = phalf(i,j,klev) / phalf(i,j,kp)
         enddo
        enddo
      enddo

!     Compute delta sigma of layers, which are needed by ss routine:
      do klev = 1, kx
        do j=1,jx
          do i=1,ix
            sigma_thick(i,j,klev) = sigma_half_level(i,j,klev) - &
                                    sigma_half_level(i,j,klev-1) 
          enddo
        enddo
      enddo

!     Create cloud_cover input field for ss longwave code:

!     Expand_cloud routine creates a Manabe Climate Model cloud_cover
!     field from the FMS arrays: nclds, ktop, kbtm, camt, and emcld.

!     This is patterned after the expand_cloud subroutine in
!      the clouds.f90 module.  See also the supersource code
!      in impt.f 
!     Accounts for cloud emmissivity...

      cloud_cover = 0.0
      do jindex=1,size(nclds,2)
      do iindex=1,size(nclds,1)
         do n=2,nclds(iindex,jindex)+1
            cloud_cover(iindex,jindex,  &
                ktop(iindex,jindex,n):kbtm(iindex,jindex,n)) =   &
                camt(iindex,jindex,n) * emcld(iindex,jindex,n)
         enddo
      enddo
      enddo
      
!     TK Mod to mimic supersource.  This is a temporary patch
!     which needs to be cleaned up.  A search is made for locations
!     where the LW cloud emissivity has been set to 0.6.
!     If that location is an isolated cloud with the layer above
!     and below being cloud free, the cloud_cover value is left
!     as 0.6, otherwise it is set to 1.0.   This is the
!     cirrus1L test.   7/09/01

      do jindex=1,size(nclds,2)
      do iindex=1,size(nclds,1)
!        For supersource runs, there should not be any cloud
!        at the top model level (k=1), nor should the high cloud
!        issue come into play the bottom level (k=kx).      

         do klev = 2, kx-1
            if (abs(cloud_cover(iindex,jindex,klev)-0.6) .lt. 0.001) then
 
!             The cloud at level klev has been previously reset to 0.6
 
               if ((cloud_cover(iindex,jindex,klev-1) .gt. 0.0) .or. &
                   (cloud_cover(iindex,jindex,klev+1) .gt. 0.0)) then
!             The cloud with 0.6 LW emiss has a neighboring cloud
!              so reset the LW emiss (cloud_cover) to 1.0 as follows:
                  cloud_cover(iindex,jindex,klev) = 1.0
               end if
 
            end if
         enddo
      enddo
      enddo

!     TK  Can Artificially set cloud_cover to 1 at the test point:
!         This method of doing this is now obsolete.  See radiation_driver.
!      print *, '***** TK Artificially set cloud_cover(49,27,14) = 1 ***'
!      cloud_cover(49,27,14) = 1.0

      DO j=1,jx

!        Specify ozone for the latitude (zonal mean used):
         do klev=1,kx
            o3_mixrat(klev) = QO3(1,j,klev)
         end do
 
!        TK Printout diagnostics:
        if ((j .eq. 27)) then
!        if ((j .eq. 27) .or. (j .eq. 69)) then
!        if ((j .eq. 10000) .or. (j .eq. 10000)) then

           ipr = 48

           print *
           print *, 'TK chkpt 1 in mcm_lw_mod.f.  Trap input to '
           print *, '  lwcool for i,j = ', ipr, j

           print *, 'k     cloud_cover     PRESSURE'
           do kpr = 1, 14
              write (6, 120) kpr, cloud_cover (ipr,j,kpr), &
                    PRES(ipr,j,kpr) 
120           format (i2, 2x, e10.3, 3x, e10.3)
           end do
           print *
           print *, 'Surface pressure = ', PRES(ipr,j,15)
        
           print *
           print *, 'k   TEMP        RH2O        QO3         CAMT', &
           '      RRVCO2'
           do kpr = 1, 14
              write (6, 125) kpr, TEMP(ipr,j,kpr),RH2O(ipr,j,kpr), &
                  QO3(ipr,j,kpr), CAMT(ipr,j,kpr), RRVCO2 
125           format (i2, 2x, f10.6, 2x, 2(e10.5,2x), 2(e8.3,2x))
           end do
           print *
           print *, 'Surface temperature = ', TEMP(ipr,j,15)
           print *
        end if
        
!       TK note that lw_down_sfc is just a throwaway variable in fms, 
!           so a dummy variable is used.  Some extra input
!           arguments are sent to lwcool.  Send i=1 values of 
!           ozone since zonally symmetric.
!           Use air temps in deg C as input parameter.
!           Convert surface pressures from Pa to dynes/cm2 for
!           input to the SS-derived routine...
!           The extra parameter j is for debugging only...

         call lwcool ( cloud_cover(:,j,:), temp(:,j,1:kx)-t_freeze, &
            RH2O(:,j,1:kx), phalf(:,j,kp)*10., temp(:,j,kp), &
            dummy, HEATRA(:,j,:), TOPFLX(:,j), GRNFLX(:,j), j, &
            sigma_level(:,j,:), sigma_half_level(:,j,:),  &
            sigma_thick(:,j,:), o3_mixrat)

!        TK Printout diagnostics:
         if ((j .eq. 27) ) then
!         if ((j .eq. 27) .or. (j .eq. 69)) then
!         if ((j .eq. 10000) .or. (j .eq. 10000)) then

           ipr = 48

           print *
           print *, 'TK chkpt 2b in mcm_lw_mod.f.  Trap output from '
           print *, '  lwcool for i,j =  ', ipr, j

!          Convert from ly/min to W/m2:
           print *, 'k    HEATRA(K/d)   GRNFLX      TOPFLX  (W/m2) '
           do kpr = 1, 14
              write (6, 130) kpr, HEATRA(ipr,j,kpr)*24*3600,  &
                 GRNFLX(ipr,j)*697., TOPFLX(ipr,j)*697. 
130           format (i2, 2x, f10.6, 3x, f10.6, 3x, f10.6)
           end do
           print *
         end if
      ENDDO

!      Convert top of atm and sfc fluxes into units FMS is
!      expecting as output: (milliWatts/m2, K/day).
!      TK mod 5/14/01: use identical conversion factor to SS: 697.496.
!      Note that 4186/6 = 697.66667.

       GRNFLX = GRNFLX * 1.0E3 * 697.496
       TOPFLX = TOPFLX * 1.0E3 * 697.496

!       GRNFLX = GRNFLX * 1.0E3 * 4186/6.
!       TOPFLX = TOPFLX * 1.0E3 * 4186/6.

       HEATRA = HEATRA * 24 * 3600


      END SUBROUTINE MCM_LW_RAD

!#######################################################################

      subroutine lwcool(cloud_cover, tj, rj, psj, t_sfc, &
       lw_down_sfc, lw_cooling_rate, lw_up_toa, lw_net_sfc, jrow_flag, &
       sigma_level, sigma_half_level, sigma_thick, o3_mixrat)
 

!  compute net longwave cooling rates

! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!  routine :   lwcool
!  called by : impt
!  calls :     lwtran
!  purpose :   compute net longwave cooling rates

!  inputs:
!     tj(i,k)             temperature (deg C) at each grid point
!     rj(i,k)             mixing ratio of h2o (g/g) at each grid point
!     psj(i)              surface pressure (dynes/cm**2) at each grid point
!     t_sfc(i)            surface temperature (deg K) at each grid point
!     cloud_cover(i,k)    fractional cloud cover

!  outputs:
!     lw_up_toa(i)           upward flux at top of atmosphere (ly/min)
!     lw_net_sfc(i)          net flux at ground (ly/min)
!     lw_down_sfc(i)         downward flux at ground (ly/min)
!     lw_cooling_rate(i,k)   cooling rate at each grid point (deg/s)

!  procedure:
!     the temperature at each grid point is converted from celsius to
!     absolute (kelvin); from the temperatures planck blackbody
!     radiances are computed for each grid point.  the longwave
!     transmission coefficients (recomputed every ldisk timesteps) are
!     then combined with the blackbody radiances to determine clear
!     fluxes (i.e., the flux which would occur in the absence of
!     clouds) between all pairs of levels.  dqx(i,k,l), for example, is
!     the clear-path downward flux from vertical level l to level k.
!     then, from the known distribution of clouds, the actual upward and
!     downward fluxes at each level are computed.  these are used to
!     compute cooling rates as well as some diagnostic quantities.

! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


      real, parameter :: sigma = 5.673e-5, c1 = 3.740e-5, c2 = 1.4385 
      real, parameter :: cp1 = 0.24, cp2 = 4.1867e7 * cp1 

      real,    intent(in)  :: cloud_cover(ix,0:kp)
      real,    intent(in)  :: tj(ix,kx), rj(ix,kx), psj(ix)
      real,    intent(in)  :: t_sfc(ix)
      real,    intent(in)  :: sigma_level(ix,kx), sigma_half_level(ix,0:kx)
      real,    intent(in)  :: sigma_thick(ix,kx), o3_mixrat(kx)
      integer, intent(in)  :: jrow_flag

      real,    intent(out) :: lw_up_toa(ix)
      real,    intent(out) :: lw_net_sfc(ix)
      real,    intent(out) :: lw_cooling_rate(ix,kx)
      real,    intent(out) :: lw_down_sfc(ix)


!----------------LOCAL ARRAY STORAGE------------------------------------
      real :: dqx (ix,0:kp,0:kp), uqx (ix,0:kp,0:kp)
      real :: dfxc(ix,0:kp),      ufxc(ix,0:kp)
      real :: psigl(ix,2:kx)

      integer kloud (ix,0:kp)
      integer kldtop(ix,2:kx), kldmid(ix,2:kx), kldbot(ix,2:kx)

      integer :: numtop(2:kx), nummid(2:kx), numbot (2:kx)
      real :: ufxkb (ix),   uqxkt (ix),   ufxb(ix,2:kx)
      real :: dfxkt (ix),   dqxkb (ix),   dqxb(ix,2:kx)
      real :: ppfkb (ix),   ppfkt (ix),   ppfb(ix,2:kx)

      real :: cdxa  (kx),   cuxa(0:kx)
      real :: dfx(ix,0:kp), ufx(ix,0:kp)

      real temp_kelvin(ix,0:kp)
      real planck_func(ix,0:kp)
      real lw_trans_coeff(ix,0:kx,0:kx), lw_toa_correct(ix,0:kx)
      real lw_abs_quarter(ix,0:kx,2)
      real dpbb(ix,0:kx)
      integer :: k, l, kb, kt
      real :: cof

!    TK: I took out these equivalences but needed to modify the
!         code below so that dfx and ufx were initialized properly.
!         Printout answers for test points reproduced.  5/03/01 
!       equivalence (dfx, dqx(1,0,0))
!       equivalence (ufx, uqx(1,0,kp))


!      data cdxa / km * 0.5, 1.0 /, cuxa / -1.0, kx * -0.5 /

      do k=1,km
        cdxa(k) = 0.5
      end do
      cdxa(kx) = 1.0

      cuxa(0) = -1.0
      do k=1,kx
        cuxa(k) = -0.5
      end do

! ----------------------------------------------------------------------
!  compute clear (cloud-free) fluxes between all pairs of levels
! ----------------------------------------------------------------------

! ****** compute pbb (planck blackbody radiance), and d(pbb)/dk

      do 5 k=1,kx
        do 5 i=1,ix
          temp_kelvin(i,k) = tj(i,k) + t_freeze
    5 continue

      do 6 i=1,ix
        temp_kelvin(i, 0) = temp_kelvin(i,1)
        temp_kelvin(i,kp) = t_sfc(i)
    6 continue

      do 7 k=0,kp
        do 7 i=1,ix
          planck_func(i,k) = sigma*temp_kelvin(i,k)**4
    7 continue

      do 8 k=0,kx
        do 8 i=1,ix
          dpbb(i,k) = planck_func(i,k+1) - planck_func(i,k)
    8 continue

! ----------------------------------------------------------------------
!  Obtain transmission functions
! ----------------------------------------------------------------------
      call lwtran (planck_func, temp_kelvin, rj, psj,  &
        lw_trans_coeff, lw_toa_correct, lw_abs_quarter, jrow_flag,  &
        sigma_level, sigma_half_level, sigma_thick, o3_mixrat)

! ****** compute upward and downward fluxes at "flux" levels

      do 11 i=1,ix
        dqx(i,0,0) = 0.0
   11 continue

      do 12 k=1,kx
        do 12 i=1,ix
          dqx(i,k,k) = cdxa(k) * dpbb(i,k) * lw_abs_quarter(i,k,2) + planck_func(i,k)
   12 continue

      do 13 l=kx-1,0,-1
        do 13 k=l+1,kx
          do 13 i=1,ix
            dqx(i,k,l) = dqx(i,k,l+1) - lw_trans_coeff(i,k,l)*dpbb(i,l)
   13 continue

      do 14 k=1,kx
        do 14 i=1,ix
          dqx(i,k,0) = dqx(i,k,0) - lw_toa_correct(i,k) * planck_func(i,0)
   14 continue

      do 15 k=0,kx
        do 15 i=1,ix
          uqx(i,k,k+1) = cuxa(k) * dpbb(i,k) * lw_abs_quarter(i,k,1) + planck_func(i,k+1)
   15 continue

      do 16 l=2,kp
        do 16 k=0,l-2
          do 16 i=1,ix
            uqx(i,k,l) = uqx(i,k,l-1) + lw_trans_coeff(i,k,l-1) * dpbb(i,l-1)
   16 continue

!  TK Add code to initialize ufx to take place of equivalence:
      do 17 k = 0, kp
         do 17 i = 1, ix
            ufx(i,k) = uqx(i,k,kp)
17    continue 

!  TK Add code to initialize dfx to take place of equivalence:
      do 18 k = 0, kp
         do 18 i = 1, ix
            dfx(i,k) = dqx(i,k,0)
18    continue 

! ----------------------------------------------------------------------
!  compute actual fluxes from cloud distribution
! ----------------------------------------------------------------------

      do 105 k=0,kp
       do 105 i=1,ix
        if (cloud_cover(i,k) .ne. 0) then
          kloud(i,k) = 1
        else
          kloud(i,k) = 0
        endif
  105 continue
      do 110 k=2,kx
       do 110 i=1,ix
        kldtop(i,k) = kloud(i,k) * (1 - kloud(i,k-1))
        kldmid(i,k) = kloud(i,k) *      kloud(i,k+1)
        kldbot(i,k) = kloud(i,k) * (1 - kloud(i,k+1))
  110 continue

      do 20 kb=2,kx
        do 20 k=kb,kx
         do 20 i=1,ix
          if (kldbot(i,kb) .eq. 1) &
            dfx(i,k) = dfx(i,k) * (1.0-cloud_cover(i,kb)) &
                     + dqx(i,k,kb) * cloud_cover(i,kb)
   20 continue

      do 30 kt=kx,2,-1
        do 30 k=0,kt-1
         do 30 i=1,ix
          if (kldtop(i,kt) .eq. 1) &
            ufx(i,k) = ufx(i,k) * (1.0-cloud_cover(i,kt)) &
                     + uqx(i,k,kt) * cloud_cover(i,kt)
   30 continue

      do 35 k=2,kx
        numtop(k) = 0
        numbot(k) = 0
        nummid(k) = 0
   35 continue
      do 36 k=2,kx
       do 36 i=1,ix
        numtop(k) = numtop(k) + kldtop(i,k)
        numbot(k) = numbot(k) + kldbot(i,k)
        nummid(k) = nummid(k) + kldmid(i,k)
   36 continue

      do 40 k=kx,2,-1
       do 115 i=1,ix
        if (kldbot(i,k) .eq. 1) then
          ufxkb(i) = ufx(i,k)
          dqxkb(i) = dqx(i,k,k)
          ppfkb(i) = sigma_half_level(i,k)
        endif
  115  continue
        if (nummid(k) .eq. 0) goto 40
       do 120 i=1,ix
        if (kldmid(i,k) .eq. 1) then
          ufxb(i,k) = ufxkb(i)
          dqxb(i,k) = dqxkb(i)
          ppfb(i,k) = ppfkb(i)
        endif
  120  continue
  40  continue

      do 50 k=2,kx
       if (nummid(k) .eq. 0) goto 50
         do 125 i=1,ix
          if (kldtop(i,k) .eq. 1) then
            dfxkt(i) = dfx(i,k-1)
            uqxkt(i) = uqx(i,k-1,k)
            ppfkt(i) = sigma_half_level(i,k-1)
          endif
  125    continue
         do 130 i=1,ix
          if (kldmid(i,k) .eq. 1) then
            psigl(i,k) = (sigma_half_level(i,k) - ppfkt(i)) / &
                            (ppfb(i,k) - ppfkt(i))
            dfxc (i,k) = dfxkt(i) + psigl(i,k)*(dqxb(i,k) - dfxkt(i))
            ufxc (i,k) = uqxkt(i) + psigl(i,k)*(ufxb(i,k) - uqxkt(i))
          endif
  130    continue
   50 continue

      do 135 k=2,kx
       do 135 i=1,ix
        if (kldmid(i,k) .eq. 1) then
          dfx(i,k) = dfx(i,k)*(1.0-cloud_cover(i,k)) + dfxc(i,k)*cloud_cover(i,k)
          ufx(i,k) = ufx(i,k)*(1.0-cloud_cover(i,k)) + ufxc(i,k)*cloud_cover(i,k)
        endif
  135 continue

! ----------------------------------------------------------------------
!  compute net cooling rates from fluxes
! ----------------------------------------------------------------------

! 1.43306e-6 converts ergs / (cm**2*sec) to ly/min

   80 continue

        do 85 i=1,ix
         lw_up_toa(i)     = ufx(i,0) * 1.43306e-06
         lw_net_sfc(i)     = (ufx(i,kx) - dfx(i,kx)) * 1.43306e-06
         lw_down_sfc(i) = -dfx(i,kx) * 1.43306e-6
   85   continue

! 1.1574e-5 = 1.0 / 86400.0

        cof = grav_accel * 86400.0 / cp2
        cof = cof * 1.1574e-5

        do 90 k=1,kx
         do 90 i=1,ix
          lw_cooling_rate(i,k) = cof/(sigma_thick(i,k)*psj(i))
   90   continue

        do 95 k=1,kx
         do 95 i=1,ix
          lw_cooling_rate(i,k) = lw_cooling_rate(i,k) &
             * (ufx(i,k) - ufx(i,k-1) + dfx(i,k-1) - dfx(i,k))
   95   continue

      return
      end subroutine lwcool

function  expx(x)
real, intent(in) :: x
real :: expx

! ----------------------------------------------------------------------
!  statement function
! ----------------------------------------------------------------------

!  the approximation to exp(x) which follows is appropriate only given
!  the following assumptions:
!    1) since the correction coefficients (h2o_corr_a & h2o_corr_b) 
!       are known only to about four digits of accuracy, 6-7 digits 
!       of accuracy for the approximation is ample.
!    2) the input range for x is [-6.735,2.289].  this depends on:
!       a) the valid temperature range, now [-173.16,102] (celsius)
!       b) the values of the coefficients h2o_corr_a & h2o_corr_b
!

      real, parameter :: c0e = 9.999999810120017e-1 
      real, parameter :: c1e = 9.999999599140620e-1/16.**1 
      real, parameter :: c2e = 5.000056658124412e-1/16.**2 
      real, parameter :: c3e = 1.666837874572320e-1/16.**3 
      real, parameter :: c4e = 4.146341773620255e-2/16.**4 
      real, parameter :: c5e = 7.279860860195404e-3/16.**5 

      expx = ((( (((((c5e*x+c4e)*x+c3e)*x+c2e)*x+c1e)*x+c0e) &
                   **2)**2)**2)**2
end function expx


      subroutine lwtran (planck_func, temp_kelvin, rj, psj, &
        lw_trans_coeff, lw_toa_correct, lw_abs_quarter, jrow_flag, &
        sigma_level, sigma_half_level, sigma_thick, o3_mixrat)

!  compute longwave atmospheric transmission coefficients

! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!  routine :   lwtran
!  called by : lwcool
!  calls :     lwco2
!  purpose :   compute longwave atmospheric transmission coefficients

!  inputs:
!     rj(i,k)             mixing ratio of h2o at each grid point (g/g)
!     psj(i,k)            surface presure at each ground point (dynes/cm**2)
!     temp_kelvin(i,k)    temperature (deg K)
!     planck_func(i,k)    blackbody function (total radiance; ergs/(cm**2)*s)

!  outputs:
!     lw_trans_coeff         longwave transmission coefficient (dimensionless)
!     lw_toa_correct         correction to above for top level (dimensionless)
!     lw_abs_quarter         quarter-level absorption (dimensionless)

!  procedure:
!     the main purpose of this routine is to compute the band-integrated
!     transmission coefficients transm(i,k,l) for radiation passing from
!     flux level l to flux level k.  in addition, it computes two
!     corrections. the first, transz(i,k), is for radiation from the top
!     level (split off from transm to improve code efficiency, i think).
!     the second, absrbx(i,k,kq), is a half-layer (flux level to data-
!     input level, or vice versa) absorption correction; kq=1 is the
!     correction for upward flux and kq=2 is for downward flux.

!     this routine splits the longwave radiation spectrum into nb bands,
!     ranging from about 20 to 2000 cm-1.  transmission coefficients are
!     computed for each absorber contributing to absorption in that
!     band.  the single-absorber transmission coefficients are
!     multiplied together to produce the total single-band transmission,
!     and then subtracted from 1 to produce an absorption.  the single-
!     band absorptions are weighted by the relative fraction of
!     blackbody radiation in that band (for a particular temperature),
!     and summed to produce the total band-integrated absorption
!     coefficient, which is converted back to a transmission.

!     transmissions for h2o are computed using a goody random model.
!     the function form and coefficients come from a paper by rogers and
!     walshaw (rogers, c.d. and c.d. walshaw, the computation of infra-
!     red cooling in planetary atmospheres, quart. j. royal meteorol.
!     soc., v.92, pp.67-92, 1966).

!        the water vapor continuum is now computed by using the
!     formulation given in roberts(first fit). reference:
!     roberts,r.e.,et al,applied optics,v. 15,pp 2085-2090,1976.

!     the co2 transmission table was generated by a program obtained
!     privately from s.r. drayson, university of michigan.  this program
!     assumed a homogeneous path between flux levels; a version which
!     did not assume homogeneous paths was later published by drayson
!     (drayson, s.r., atmospheric transmission in the co2 bands between
!     12 microns and 18 microns, appl. opt., v.5, pp.385-391, 1973).

!     the o3 transmission computation, changed from a table lookup in
!     the original longwave radiation code, also uses a goody random
!     model.  the functional form and coefficients were published by
!     rogers (rogers, c.d., some extensions and applications of the new
!     random model for molecular band transmission, q.j.r.m.s, v.94,
!     pp.99-102, 1968).

! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      real, intent(in) :: planck_func(ix,0:kp)
      real, intent(in) :: temp_kelvin(ix,0:kp)
      real, intent(in) :: rj(ix,kx)
      real, intent(in) :: psj(ix)

      real, intent(in) :: sigma_level(ix,kx), sigma_half_level(ix,0:kx)
      real, intent(in) :: sigma_thick(ix,kx), o3_mixrat(kx)
      integer, intent(in)  :: jrow_flag

      real, intent(out) :: lw_trans_coeff(ix,0:kx,0:kx)
      real, intent(out) :: lw_toa_correct(ix,0:kx)
      real, intent(out) :: lw_abs_quarter(ix,0:kx,2)

      real, parameter :: sigma = 5.673e-5, c1 = 3.740e-5, c2 = 1.4385 
      real, parameter :: po = 1013.25e3, opo = 1.0 / po, o2po = 0.5 * opo 
!     parameter ( opo = 9.8692271e-7, o2po = 4.9346136e-7 )
      real, parameter :: ak1 = 223.0, ak2=10.0 
!     parameter ( alpha = 0.28 )
!     parameter ( pi = 3.1415926535898 )
!     parameter ( pialph = pi * alpha )
      real, parameter :: ak1x4 = 4.0 * ak1 
      real, parameter :: ak2x4 = 4.0 * ak2 
!     parameter ( pialph = 0.8796459, ak1x4 = 892.0, ak2x4 = 40.0 )
      real, parameter ::            azint = 1.66                 
!     parameter ( g = 980.6, azint = 1.66, g1 = azint / g )
!     parameter ( g1h = 0.5 * g1 )
!     parameter ( g1 = 1.6938774e-3, g1h = 0.5 * g1 )
      real, parameter :: c3 = 1.0 / 120.0, a1 = 75.48, a2 = 23.44 
!     parameter ( c3 = 8.333333e-3, a1 = 75.48, a2 = 23.44 )
      real, parameter :: c3a1 = c3 * a1, c3a2 = c3 * a2 
      real, parameter :: c0e = 9.999999810120017e-1 
      real, parameter :: c1e = 9.999999599140620e-1/16.**1 
      real, parameter :: c2e = 5.000056658124412e-1/16.**2 
      real, parameter :: c3e = 1.666837874572320e-1/16.**3 
      real, parameter :: c4e = 4.146341773620255e-2/16.**4 
      real, parameter :: c5e = 7.279860860195404e-3/16.**5 

      real :: bw(ix,0:kx,nb), bwz(ix,nb), expzs(ix,nb)
      real :: trans(ix,0:kx,0:kx), dbbdt(ix,0:kx)

      real :: vcube(nb), c(nb), v(nb), dv(nb)
      real :: pdi   (ix,0:kp), pfl   (ix,0:kx), dpdi (ix,  kx)
      real :: rh2o  (ix,0:kp), ro3   (ix,0:kp), qdi  (ix,  kx)
      real :: duh2o (ix,  kx), duco2 (ix,  kx), duo3 (ix,  kx)
      real :: duqh2o(ix,  kx), duqfac(ix,  kx), dufac(ix,  kx)
      real :: fbignl(ix,  kx), bignel(ix,0:kx), bign (ix,  kx)
      real :: tdpfac(ix,  kx), tfac  (ix,  kx), teff (ix,  kx)
      real :: sfac  (ix,0:kx), pfac  (ix,0:kx), peff (ix,0:kx)
      real :: tcof  (ix,0:kx), fac1  (ix,0:kx), fac2 (ix,0:kx)
      real :: t260  (ix,0:kx), tadj  (ix,0:kx,2)
      real :: ulog  (ix,0:kx), plog  (ix,0:kx)


!  quarter-layer variables

      real :: txdegk(ix,0:kx), qx    (ix,0:kx), dpfac(ix,0:kx)
      real :: duxh2o(ix,0:kx), duxco2(ix,0:kx), duxo3(ix,0:kx)
      real :: g1, g1h, bc,  bandc1, bandc2, cco2, asodsq, diag, &
              factr1, factr2, diago3
      integer :: lb, k, l, len, kq

!c  TK: Removed unnecessary equivalences:
!      equivalence (ulog,  fac1  ), (plog,  fac2 ), (teff, peff )
!      equivalence (txdegk,dpdi  ), (qx,    qdi  )
!      equivalence (duxh2o,duh2o ), (duxco2,duco2), (duxo3,duo3 )
!      equivalence (tadj,  duqfac), (tadj(1,0,2),dufac,tdpfac,dpfac)

!  constants for h2o bignell continuum absorption

!        these are the roberts continuum coefficients
      data  c / 4*0.0, 149.566, 38.103, 11.312, 7.9193, 6.0741, 4.9179, 9*0.0 /

!  longwave frequency bands and band widths (inverse cm)

      data v /   20.0,  100.0,  220.0,  340.0,  470.0, &
                670.0,  850.0,  930.0, 1020.0, 1140.0, &
               1275.0, 1400.0, 1500.0, 1600.0, 1700.0, &
               1800.0, 1900.0, 2000.0, 2125.0 /
      data dv /  40.0, 120.0, 120.0, 120.0, 140.0, &
                260.0, 100.0,  60.0, 120.0, 120.0, &
                150.0, 100.0, 100.0, 100.0, 100.0, &
                100.0, 100.0, 100.0, 150.0 /

! ----------------------------------------------------------------------
!  description of variables and constants used in lwtran
! ----------------------------------------------------------------------

!  variables centered on data input levels:
!     sigma_level             1-d "sigma" (pressure/po) 
!     sigma_thick             d(sigma)/dk
!                             (not to be confused with planck bb sigma)
!     pdi, dpdi, qdi          pressure, d(pdi)/dk, and pdi/po
!     rh2o, co2_mixrat, ro3         mixing ratios for the various absorbers
!     duh2o, duco2, duo3      absorber amounts from top of atmosphere
!        (gm/cm**2)           (also called unadjusted optical depth)
!     temp_kelvin                   temperature (kelvin)

!  variables centered on flux levels (see last paragraph, below):
!     sigma_half_level, pfl                1-d "sigma", 2-d pressure

!  assorted additional variables and constants:
!     po, opo, o2po           average pressure at sea level, 1/po, 2/po
!     planck_func             planck blackbody function
!     dbbdt                   d(planck_func)/dt
!     sigma, c1, c2           constants in planck blackbody equation
!     v, dv                   frequencies and band widths (1/cm)
!                             (wavelength range is 5-500 microns)
!     bw, bwz                 weights for freq. bands derived from planck_func
!     alpha, c3, a1, a2,      empirical constants used in computing
!       ak1, ak2                ozone absorption
!     h2o_line_width, 
!     h2o_line_strength       empirical band constants for water lines
!       h2o_line_width          coefficient for h2o line width
!       h2o_line_strength       coefficient for h2o line strength
!     sfac, pfac, tfac        intensity, pressure, temperature factors
!     peff, teff              effective pressure, temperature
!     ulog, plog              logs of co2 amount, effective pressure
!     tadj                    temperature adjustments for h2o lines
!     fbignl, bignel, bign    factors associated with bignell continuum
!     tcof                    transmission coefficient, single absorber
!     trans                   transmission matrix, single frequency band

!  output variables:
!     transm, transz          band-integrated transmission coefficients
!     absrbx                  quarter-layer correction to above (absrp.)

!  quarter layer variables (x usually indicates quarter-layer):
!     txdegk, qx              quarter-layer temperature, "sigma"
!     duxh2o, duxco2, duxo3   quarter-layer absorber amounts

!  miscellaneous constants:
!     azint                   azimuthal integral factor for diffuse rad.
!     g1, g1h                 convert dp*mix-ratio to absorber amount

!  miscellaneous temporaries:
!     expzs, vcube, bc, bandc1, bandc2
!     t260, fac1, fac2, dufac, dpfac, duqfac, duqh2o, cco2

!     vertical levels in the model are numbered from the top of the
!  atmosphere to the bottom; thus vertical level 1 is in the
!  stratosphere and level kx is just above the ground.  in the
!  radiation code, additional "pseudo-levels" are tacked onto the top
!  (level 0) and the bottom (level kp).  these levels make it easier
!  to handle incoming solar radiation and longwave radiation emanating
!  from the ground.

!     an additional complication to the level numbering system for the
!  radiation code is the use of "flux" levels and "data-input" levels.
!  the simplest numbering scheme for radiation calculations focuses
!  on even and odd levels: the grid variables (pressure, temperature,
!  etc.) reside at even levels, and flux is computed across them, i.e.,
!  from odd level to odd level.  this a pedagogically sound approach,
!  but it poses problems for computers, particularly vector types.
!  thus this code numbers what would be odd and even levels separately.
!  "data-input" levels are normal model vertical levels; "flux" levels
!  are halfway between them.  flux level k is one-half level closer to
!  the ground than data-input level k.  in the diagram below, data-input
!  levels are shown as "++++++" and flux levels are shown as "------".

!           description          level  index
!    incoming solar radiation      0      0   +++++++
!                                 1/2     0   -------
!             top model level      1      1   +++++++
!                                  .
!                                  .
!                                  .
!          bottom model level     kx     kx   +++++++
!                               kx+1/2   kx   -------
!                ground level     kp     kp   +++++++

! ----------------------------------------------------------------------
!  Compute various constants involving gravity.
! ----------------------------------------------------------------------
      g1  = azint / grav_accel
      g1h = 0.5 * g1

! ----------------------------------------------------------------------
!  compute band weights
! ----------------------------------------------------------------------

      do 50 lb=1,nb
        vcube(lb) = v(lb) * v(lb) ** 2
   50 continue

      do 52 lb=1,nb
        do 52 i=1,ix
          expzs(i,lb) = exp(c2 / temp_kelvin(i,0) * v(lb)) - 1.0
   52 continue

      do 54 lb=1,nb
        bc = c1 * vcube(lb) * dv(lb)
        do 54 i=1,ix
          bwz(i,lb) = bc / (expzs(i,lb) * planck_func(i,0))
   54 continue

      do 56 k=0,kx
        do 56 i=1,ix
          dbbdt(i,k) = 4.0 * sigma * temp_kelvin(i,k)**3
   56 continue

      do 58 lb=1,nb
        bandc1 = c1 * vcube(lb)
        bandc2 = c2 * v(lb)
        bc     = bandc1 * bandc2 * dv(lb)
        do 58 k=0,kx
          do 58 i=1,ix
            bw(i,k,lb) = exp(bandc2 / temp_kelvin(i,k))
            bw(i,k,lb) = bc * bw(i,k,lb) &
                         / ((bw(i,k,lb) - 1.0) * temp_kelvin(i,k))**2
            bw(i,k,lb) = bw(i,k,lb) / dbbdt(i,k)
   58 continue

! ----------------------------------------------------------------------
!  compute field arrays needed for trans calculation
!    (note that temp_kelvin has already been computed and stored in flux)
! ----------------------------------------------------------------------

      do 70 i=1,ix
        pdi(i, 0) = 0.0
        pfl(i, 0) = 0.0
        pdi(i,kp) = psj(i)
   70 continue

      do 72 k=1,kx
        do 72 i=1,ix
          pdi (i,k) = psj(i) * sigma_level(i,k)
          pfl (i,k) = psj(i) * sigma_half_level(i,k)
          dpdi(i,k) = psj(i) * sigma_thick(i,k)
          ro3 (i,k) = o3_mixrat(k)
   72 continue

      do 74 k=1,kx
        do 74 i=1,ix
          rh2o  (i,k) = rj(i,k)
          qdi   (i,k) = (pfl(i,k) + pfl(i,k-1)) * o2po
          t260  (i,k) = temp_kelvin(i,k) - 260.0
          fbignl(i,k) = exp(1800.0/temp_kelvin(i,k)-6.081081081)
!        the kernel is      1800.0*(1.0/temp-1.0/296.0)
   74 continue

      do 76 i=1,ix
        rh2o(i, 0) = 0.0
        ro3 (i, 0) = 0.0
        rh2o(i,kp) = rh2o(i,kx)
        ro3 (i,kp) = ro3 (i,kx)
   76 continue

      do 77 k=1,kp
       do 77 i=1,ix
         rh2o(i,k) = max(rh2o(i,k),3.0e-6)
   77 continue

      cco2 = co2_mixrat * g1
      do 78 k=1,kx
        do 78 i=1,ix
          duh2o (i,k) = dpdi  (i,k) * rh2o  (i,k) * g1
          duco2 (i,k) = dpdi  (i,k) * cco2
          duo3  (i,k) = dpdi  (i,k) * ro3   (i,k) * g1
          duqh2o(i,k) = duh2o (i,k) * qdi   (i,k)
          bignel(i,k) = (fbignl(i,k)*duqh2o(i,k)*rh2o(i,k)) / (0.622+rh2o(i,k))
   78 continue

! ----------------------------------------------------------------------
!  compute transm and transz

!  transm(i,k,l) is the transmission coefficient for longwave radiation
!    passing from vertical level l to level k
!  transz is a correction for radiation from the top of the atmosphere
! ----------------------------------------------------------------------

      do 80 l=0,kx
       do 80 k=0,kx
        do 80 i=1,ix
         trans (i,k,l) = 0.0
         lw_trans_coeff(i,k,l) = 0.0
   80 continue
      do 82 k=0,kx
       do 82 i=1,ix
        lw_toa_correct(i,k) = 0.0
   82 continue

!  ***** begin loop on longwave frequency bands *****

      do 2890 lb= 1, nb

! ****** h2o contribution

! ******  compute temperature adjustment to line strength and line width

        do 1300 l=1,2
          do 1300 k=1,kx
            do 1300 i=1,ix
              tadj(i,k,l) = (h2o_corr_a(lb,l) + h2o_corr_b(lb,l) * t260(i,k)) * t260(i,k)
              tadj(i,k,l) = expx(tadj(i,k,l))
 1300   continue

        do 1310 k=0,kx
         do 1310 i=1,ix
          sfac(i,k) = 0.0
          pfac(i,k) = 0.0
 1310   continue
        do 1320 k=1,kx
         do 1320 i=1,ix
          bign(i,k) = 0.0
 1320   continue

!     compute h2o contribution to lower triangular half of trans matrix
!     note that a non-physical factor of sod has been folded into duqfac
!     to cancel the factor that arises when sfac is squared in 1550 loop

        asodsq = h2o_line_strength(lb) * h2o_line_width(lb)
        if (h2o_line_strength(lb) .eq. 0.0) asodsq = h2o_line_width(lb)
        do 1400 k=1,kx
          do 1400 i=1,ix
            dufac (i,k) = h2o_line_strength(lb) * duh2o (i,k) * tadj(i,k,2)
            duqfac(i,k) = asodsq  * duqh2o(i,k) * tadj(i,k,1)
 1400   continue

        do 1550 l=kx-1,0,-1
          do 1500 k=l+1,kx
            do 1500 i=1,ix
              sfac(i,k) = sfac(i,k) + dufac (i,l+1)
              pfac(i,k) = pfac(i,k) + duqfac(i,l+1)
              bign(i,k) = bign(i,k) + bignel(i,l+1)
 1500     continue

          do 1550 k=l+1,kx
            do 1550 i=1,ix
              trans(i,k,l) = exp(-c(lb) * bign(i,k) - sfac(i,k) / sqrt(1.0 + sfac(i,k)**2 / pfac(i,k)))
 1550   continue

! ****** compute h2o contribution to diagonal elements of trans matrix

        diag = exp(-c(lb) - h2o_line_strength(lb)/sqrt(1.0 + h2o_line_strength(lb)/h2o_line_width(lb)))

! ****** co2 contribution

        if (lb .ne. 6) goto 2500

        do 2005 k=0,kx
         do 2005 i=1,ix
          sfac(i,k) = 0.0
          pfac(i,k) = 0.0
 2005   continue
        do 2007 k=1,kx
         do 2007 i=1,ix
          tfac(i,k) = 0.0
 2007   continue

! **** compute co2 contribution to lower triangular half of trans matrix

        do 2010 k=1,kx
          do 2010 i=1,ix
            duqfac(i,k) = duco2(i,k) * qdi (i,k)
            tdpfac(i,k) = temp_kelvin(i,k) * dpdi(i,k)
 2010   continue

        do 2050 l=kx-1,0,-1
          do 2020 k=l+1,kx
            do 2020 i=1,ix
              sfac(i,k) = sfac(i,k) + duco2 (i,l+1)
              pfac(i,k) = pfac(i,k) + duqfac(i,l+1)
              tfac(i,k) = tfac(i,k) + tdpfac(i,l+1)
              teff(i,k) = tfac(i,k) / (pfl(i,k) - pfl(i,l))
 2020     continue
          do 2030 k=l+1,kx
            do 2030 i=1,ix
              ulog(i,k) = alog10(sfac(i,k))
              plog(i,k) = alog10(pfac(i,k)) - ulog(i,k)
              ulog(i,k) = ulog(i,k) + 2.70668
 2030     continue

!   ------ ORIGINAL CODE ------------------------
!          if (l .eq. kx-1) then
!            i = 0
!            ulog(i,kx) = 2.70668
!            plog(i,kx) = 0.0
!            teff(i,kx) = 0.0
!            len = ix + 1
!          else
!            i = 1
!            len = ix * (kx - l)
!          endif

! ****** call lwco2 to compute tcof values

!          call lwco2(ulog(i,l+1),  plog(i,l+1), teff(i,l+1), len, tcof(i,l+1))

! ****** compute co2 contribution to diagonal elements of trans matrix

!          if (l .eq. kx-1) diag = tcof(i,kx) * diag
!  ---------END OF ORIGINAL CODE -----------------------
!  ---------BEGIN TK MODIFICATIONS

          if (l .eq. kx-1) then
            i = ix
            ulog(i,kx-1) = 2.70668
            plog(i,kx-1) = 0.0
            teff(i,kx-1) = 0.0
            len = ix + 1

! ******    call lwco2 to compute tcof values

            call lwco2(ulog(i,kx-1),  plog(i,kx-1), teff(i,kx-1), &
                       len, tcof(i,kx-1))

! ******    compute co2 contribution to diagonal elements of trans matrix

            diag = tcof(i,kx-1) * diag

           else
             i = 1
             len = ix * (kx - l)

! ******    call lwco2 to compute tcof values

            call lwco2(ulog(i,l+1),  plog(i,l+1), teff(i,l+1), &
                       len, tcof(i,l+1))
          endif

!  -----------END OF TK MODIFICATIONS -------------------

! ****** accumulate co2 tcof into trans (lower triangular half)

          do 2040 k=l+1,kx
            do 2040 i=1,ix
              trans(i,k,l) = tcof(i,k) * trans(i,k,l)
 2040     continue
 2050   continue

! ****** ozone contribution

 2500   if (lb .ne. 9) go to 2855

        do 2555 k=0,kx
         do 2555 i=1,ix
          sfac(i,k) = 0.0
          pfac(i,k) = 0.0
 2555   continue
!       sfac = 0.0
!       pfac = 0.0

! **** compute o3 contribution to lower triangular half of trans matrix

        do 2600 k=1,kx
          do 2600 i=1,ix
            duqfac(i,k) = pi_alpha * duo3(i,k) * qdi(i,k)
 2600   continue

        do 2700 l=kx-1,0,-1
          do 2650 k=l+1,kx
            do 2650 i=1,ix
              sfac(i,k) = sfac(i,k) + duo3  (i,l+1)
              pfac(i,k) = pfac(i,k) + duqfac(i,l+1)
 2650     continue
          do 2700 k=l+1,kx
            do 2700 i=1,ix
              peff (i,k  ) = pfac(i,k) / sfac(i,k)
              fac1 (i,k  ) = sfac(i,k) / peff(i,k)
              fac2 (i,k  ) = 1.0 - exp(-5.0 * peff(i,k) * (sqrt(1.0 + ak2x4 * fac1(i,k)) - 1.0))
              fac1 (i,k  ) = 1.0 - exp(-5.0 * peff(i,k) * (sqrt(1.0 + ak1x4 * fac1(i,k)) - 1.0))
              tcof (i,k  ) = 1.0 - (c3a1 * fac1(i,k) + c3a2 * fac2(i,k))
              trans(i,k,l) = tcof(i,k) * trans(i,k,l)
 2700   continue

! ****** compute o3 contribution to diagonal elements of trans matrix

        factr1 = 1.0 - exp(-5.0 * pi_alpha * (sqrt(1.0 + ak1x4 / pi_alpha) - 1.0))
        factr2 = 1.0 - exp(-5.0 * pi_alpha * (sqrt(1.0 + ak2x4 / pi_alpha) - 1.0))
        diago3 = 1.0 - (c3a1 * factr1 + c3a2 * factr2)
        diag   = diago3 * diag

! ****** apply band weights to trans; accumulate
! ****** as absorp. in transm & transz

! ****** first convert trans and diag to absorption

 2855   continue
        do 2857 l=0,kx
         do 2857 k=0,kx
          do 2857 i=1,ix
           trans(i,k,l) = 1.0 - trans(i,k,l)
 2857   continue
        diag  = 1.0 - diag

        do 2860 l=0,kx-1
          do 2860 k=l+1,kx
            do 2860 i=1,ix
              lw_trans_coeff(i,k,l) = lw_trans_coeff(i,k,l) + trans(i,k,l) * bw(i,l,lb)
 2860   continue

        do 2865 l=1,kx
          do 2865 k=0,l-1
            do 2865 i=1,ix
              lw_trans_coeff(i,k,l) = lw_trans_coeff(i,k,l) + trans(i,l,k) * bw(i,l,lb)
 2865   continue

        do 2870 l=0,kx
          do 2870 i=1,ix
            lw_trans_coeff(i,l,l) = lw_trans_coeff(i,l,l) + diag * bw(i,l,lb)
 2870   continue

        do 2875 l=1,kx
          do 2875 i=1,ix
            lw_toa_correct(i,l) = lw_toa_correct(i,l) + trans(i,l,0) * bwz(i,lb)
 2875   continue

        do 2880 i=1,ix
          lw_toa_correct(i,0) = lw_toa_correct(i,0) + diag * bwz(i,lb)
 2880   continue

 2890 continue

!  ***** end loop on longwave frequency bands *****

!  convert transm & transz from absorption to transmission coefficients

      do 2897 l=0,kx
       do 2897 k=0,kx
        do 2897 i=1,ix
         lw_trans_coeff(i,k,l) = 1.0 - lw_trans_coeff(i,k,l)
 2897 continue
       do 2898 k=0,kx
        do 2898 i=1,ix
         lw_toa_correct(i,k) = 1.0 - lw_toa_correct(i,k)
 2898 continue

! ----------------------------------------------------------------------
!  compute absrbx

!  absrbx is a correction for the finite thickness of the vertical
!    levels, and represents within-layer absorption of radiation
! ----------------------------------------------------------------------

!     absrbx = 0.0
      do 2899 l=1,2
       do 2899 k=0,kx
        do 2899 i=1,ix
         lw_abs_quarter(i,k,l) = 0.0
 2899 continue

!  kq=1 is the upward-flux correction; kq=2 is for downward flux

      do 5000 kq=1,2

!  compute coefficients needed for quarter-layer correction

        if (kq.eq.2) goto 3050

        do 3010 k=1,kx-1
          do 3010 i=1,ix
            dpfac(i,k) = (pdi(i,k+1) - pfl(i,k)) * g1h
 3010   continue

        do 3020 k=1,kx-1
          do 3020 i=1,ix
            txdegk(i,k) = 0.375 * temp_kelvin(i,k) + 0.625 * temp_kelvin(i,k+1)
            qx    (i,k) = (0.75 * pfl(i,k) + 0.25 * pdi(i,k+1)) * opo
            duxh2o(i,k) = (0.375 * rh2o(i,k) + 0.625 * rh2o(i,k+1)) * dpfac(i,k)
            duxco2(i,k) = co2_mixrat * dpfac(i,k)
            duxo3 (i,k) = (0.375 * ro3(i,k) + 0.625 * ro3(i,k+1)) * dpfac(i,k)
            bignel(i,k) = (0.375 * rh2o(i,k) + 0.625 * rh2o(i,k+1))**2 &
                          * dpfac(i,k) * fbignl(i,k+1) / &
                          (0.622 + 0.375*rh2o(i,k) + 0.625*rh2o(i,k+1))
 3020   continue

        do 3030 i=1,ix
          txdegk(i, 0) = 0.75 * temp_kelvin(i,0) + 0.25 * temp_kelvin(i,1)
          txdegk(i,kx) = temp_kelvin(i,kp)
          qx    (i, 0) = (0.75 * pdi(i,0) + 0.25 * pdi(i,1)) * opo
          qx    (i,kx) = psj(i) * opo
          duxh2o(i, 0) = (0.25 * rh2o(i,0) + 0.75 * rh2o(i,1)) * (pdi(i,1) - pdi(i,0)) * g1h
          duxh2o(i,kx) = 0.0
          duxco2(i, 0) = co2_mixrat * (pdi(i,1) - pdi(i,0)) * g1h
          duxco2(i,kx) = 0.0
          duxo3 (i, 0) = (0.25 * ro3(i,0) + 0.75 * ro3(i,1)) * (pdi(i,1) - pdi(i,0)) * g1h
          duxo3 (i,kx) = 0.0
          bignel(i, 0) = (0.75 * rh2o(i,0) + 0.25 * rh2o(i,1))**2 &
                       * (pdi(i,1)-pdi(i,0)) * g1h * fbignl(i,1) / &
                         (0.622 + 0.75*rh2o(i,0) + 0.25*rh2o(i,1))
          bignel(i,kx) = 0.0
 3030   continue

        do 3040 k=0,kx
          do 3040 i=1,ix
            t260(i,k) = txdegk(i,k) - 260.0
 3040   continue

        go to 3100

 3050   do 3060 k=1,kx-1
          do 3060 i=1,ix
            dpfac(i,k) = (pfl(i,k) - pdi(i,k)) * g1h
 3060   continue

        do 3070 k=1,kx-1
          do 3070 i=1,ix
            txdegk(i,k) = 0.625 * temp_kelvin(i,k) + 0.375 * temp_kelvin(i,k+1)
            qx    (i,k) = (0.75 * pfl(i,k) + 0.25 * pdi(i,k)) * opo
            duxh2o(i,k) = (0.625 * rh2o(i,k) + 0.375 * rh2o(i,k+1)) * dpfac(i,k)
            duxco2(i,k) = co2_mixrat * dpfac(i,k)
            duxo3 (i,k) = (0.625 * ro3(i,k) + 0.375 * ro3(i,k+1)) * dpfac(i,k)
            bignel(i,k) = (0.625*rh2o(i,k) + 0.375*rh2o(i,k+1))**2 &
                          * dpfac(i,k) * fbignl(i,k) / &
                          (0.622 + 0.625*rh2o(i,k) + 0.375*rh2o(i,k+1))
 3070   continue

        do 3080 i=1,ix
          txdegk(i, 0) = temp_kelvin(i,0)
          txdegk(i,kx) = 0.75 * temp_kelvin(i,kp) + 0.25 * temp_kelvin(i,kx)
          qx    (i, 0) = 1.0
          qx    (i,kx) = (0.75 * pdi(i,kp) + 0.25 * pdi(i,kx)) * opo
          duxh2o(i, 0) = 0.0
          duxh2o(i,kx) = (0.75 * rh2o(i,kp) + 0.25 * rh2o(i,kx)) * (pdi(i,kp) - pdi(i,kx)) * g1h
          duxco2(i, 0) = 0.0
          duxco2(i,kx) = co2_mixrat * (pdi(i,kp) - pdi(i,kx)) * g1h
          duxo3 (i, 0) = 0.0
          duxo3 (i,kx) = (0.75 * ro3(i,kp) + 0.25 * ro3(i,kx)) * (pdi(i,kp) - pdi(i,kx)) * g1h
          bignel(i, 0) = 0.
          bignel(i,kx) = (0.75 * rh2o(i,kp) + 0.25 * rh2o(i,kx))**2 &
                       * (pdi(i,kp)-pdi(i,kx)) * g1h * fbignl(i,kx) / &
                         (0.622 + 0.75*rh2o(i,kp) + 0.25*rh2o(i,kx))
 3080   continue

        do 3090 k=0,kx
          do 3090 i=1,ix
            t260(i,k) = txdegk(i,k) - 260.0
 3090   continue

!  ***** begin loop on longwave frequency bands *****

 3100   do 4000 lb=1,nb

! ****** quarter-layer h2o absorption

! ****** compute temperature adjustment to line strength and line width

          do 3150 k=0,kx
            do 3150 i=1,ix
              tadj(i,k,1) = (h2o_corr_a(lb,1) + h2o_corr_b(lb,1) * t260(i,k)) * t260(i,k)
              tadj(i,k,2) = (h2o_corr_a(lb,2) + h2o_corr_b(lb,2) * t260(i,k)) * t260(i,k)
              tadj(i,k,1) = tadj(i,k,1) - tadj(i,k,2)
 3150     continue

          do 3200 l=1,2
            do 3200 k=0,kx
              do 3200 i=1,ix
                tadj(i,k,l) = expx(tadj(i,k,l))
 3200     continue

! ****** compute h2o contribution to quarter-layer absorption matrix

          do 3300 k=0,kx
            do 3300 i=1,ix
              sfac (i,k   ) = h2o_line_strength(lb) * duxh2o(i,k) * tadj(i,k,2)
              pfac (i,k   ) = h2o_line_width(lb) * qx(i,k) * tadj(i,k,1)
              trans(i,k,kq) = exp(-c(lb) * bignel(i,k) -sfac(i,k)/sqrt(1.0+sfac(i,k)/pfac(i,k)))
 3300     continue

! ****** quarter-layer co2 absorption

          if (lb .ne. 6) go to 3700

! ****** compute co2 contribution to quarter-layer absorption matrix

          len = ix * kp
          do 3410 k=0,kx
           do 3410 i=1,ix
            sfac(i,k) = duxco2(i,k)
 3410     continue
          do 3420 k=0,kx
           do 3420 i=1,ix
            duxco2(i,k) = max(duxco2(i,k),1.0e-6)
 3420     continue
          do 3500 k=0,kx
            do 3500 i=1,ix
              ulog(i,k) = alog10(duxco2(i,k)) + 2.70668
              plog(i,k) = alog10(qx(i,k))
 3500     continue

! ****** call lwco2 to compute tcof values

          call lwco2(ulog(1,0), plog(1,0), txdegk(1,0), len, tcof(1,0))

! ****** accumulate co2 ccp into trans

          do 3600 k=0,kx
            do 3600 i=1,ix
              tcof(i,k) = tcof(i,k) * trans(i,k,kq)
 3600     continue
          do 3610 k=0,kx
           do 3610 i=1,ix
            if(sfac(i,k) .gt. 0.0) then
              trans(i,k,kq) = tcof(i,k)
            endif
 3610     continue

! ****** quarter-layer o3 absorption

 3700     if (lb .ne. 9) go to 3900

          do 3800 k=0,kx
            do 3800 i=1,ix
              peff (i,k   ) = pi_alpha * qx(i,k)
              fac2 (i,k   ) = duxo3(i,k) / peff(i,k)
              fac1 (i,k   ) = 1.0 - exp(-5.0 * peff(i,k) * (sqrt(1.0 + ak1x4 * fac2(i,k)) - 1.0))
              fac2 (i,k   ) = 1.0 - exp(-5.0 * peff(i,k) * (sqrt(1.0 + ak2x4 * fac2(i,k)) - 1.0))
              tcof (i,k   ) = 1.0 - (c3a1 * fac1(i,k) + c3a2 *fac2(i,k))
              trans(i,k,kq) = tcof(i,k) * trans(i,k,kq)
 3800     continue
 
! ****** total quarter-layer absorption
 
 3900     do 4000 k=0,kx
            do 4000 i=1,ix
              lw_abs_quarter(i,k,kq) = lw_abs_quarter(i,k,kq) + (1.0 - trans(i,k,kq)) * bw(i,k,lb)
 4000 continue
 
 5000 continue
 
!  ***** end of principal quarter-layer loop *****
 
      return
        end subroutine lwtran
 
      subroutine lwco2 (ulog,plog,teff,ln,tco2)

!  table lookup routine for co2 transmission
 
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
!  routine:   lwco2
!  called by: lwtran
!  calls:     none
!  purpose:   compute longwave co2 transmission
 
!  inputs:
!     ulog           log of co2 amount
!     plog           log of effective pressure
!     teff           effective temperature
!     ln             length of call-argument arrays
 
!  output:
!     tco2           co2 transmission coefficient
 
!  side effects:
!     none
!     (i.e., no input variables or common blocks modified, etc.)
 
!  procedure:
!     a 2d table lookup of co2 absorption is performed.  the axes are
!     log of the co2 amount and log of the effective pressure.  an
!     effective temperature of 300k is assumed for this first step.
!     a correction for temperatures in the range 200k-300k is made by
!     multiplying a temperature correction factor by the difference
!     between the effective temperature and 300k, and adding the
!     result to the previously calculated absorption.  the temperature
!     correction factor is found by 2d table lookup, using the same
!     axes as were used to obtain the 300k absorption.  no temperature
!     correction is applied if the temperature exceeds 300k; if the
!     temperature falls below 200k, the 200k correction is applied.
!     if the co2 concentration is too low, no temperature correction
!     is made.
 
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
!  TK Mod:  set up in parent routine:
!      parameter ( lmax = ix * (kx + 1) )
 
      integer, intent(in) :: ln
      real, intent(in) :: ulog(ln) 
      real, intent(in) :: plog(ln) 
      real, intent(in) :: teff(ln)
 
      real, intent(out) :: tco2(ln) 
 
      real :: ahi   (lmax), alo   (lmax), cct   (lmax), cdt   (lmax), fulog (lmax)
      integer :: nplog (lmax), iulog (lmax), index (lmax)
      real :: plnum (lmax), plden (lmax), plfac (lmax), tcor  (lmax)
      real :: alogoo(lmax), alogpo(lmax), alogop(lmax), alogpp(lmax)
      real :: pltab (  12)
      integer :: iu, l, n
 
!c TK: Removed unnecessary equivalences:
!c TK:      equivalence (alogoo, plnum), (alogpo, plden, alo, tcor)
!c TK:      equivalence (alogop, iulog), (alogpp, index, ahi, cdt )
 
      data pltab / &
           -4.50000, -4.00000, -3.40000, -2.88081, -2.27875, -1.88081, &
           -1.57978, -1.27875, -0.88081, -0.48287,  0.     ,  0.29528 /

! ****** check for out-of-range ulog input values

      iu = 0
      do 25 l=1,ln
        if ( ulog(l).lt.-4.25 ) iu=iu+1
   25 continue
      if ( iu.ne.0 ) go to 1200

! ****** compute pressure range for tables,
! ****** and pressure interpolation factor

      do 50 l=1,ln
        nplog(l) = 1
   50 continue

      do 100  n=2,11
        do 100  l=1,ln
          if ( plog(l).gt.pltab(n) ) then
            nplog(l) = n
            plnum(l) = plog(l) - pltab(n)
            plden(l) = pltab(n+1) - pltab(n)
          endif
  100 continue

      do 200 l=1,ln
        plfac(l) = plnum(l) / plden(l)
  200 continue

! ****** compute co2 absorption for an effective temperature of 300k

      do 500 l=1,ln
        fulog(l) = 4 * ulog(l) + 18
        iulog(l) = int(fulog(l))

!        TK diagnostic printout:
!        print *, 'TK chkpt 1 in lwco2:  l, ulog(l), fulog(l), ', &
!                   'int(fulog(l)), iulog(l) = ', &
!                  l, ulog(l), fulog(l), int(fulog(l)), iulog(l)

        if ( iulog(l).gt.29 ) iulog(l) = 29
        fulog(l) = fulog(l) - real(iulog(l))
  500 continue

      do 600 l = 1, ln
        index(l) = iulog(l) + 30 * (nplog(l) - 1)
  600 continue

      do 620 l=1,ln
        alogoo(l) = absorp_table(index(l),1)
  620 continue
      do 640 l=1,ln
        index (l) = index(l) + 1
        alogpo(l) = absorp_table(index(l),1)
  640 continue
      do 660 l=1,ln
        index (l) = index(l) + (30 - 1)
        alogop(l) = absorp_table(index(l),1)
  660 continue
      do 680 l=1,ln
        index (l) = index(l) + 1
        alogpp(l) = absorp_table(index(l),1)
  680 continue

      do 700  l = 1, ln
        ahi(l) = alogop(l) + fulog(l) * (alogpp(l) - alogop(l))
        alo(l) = alogoo(l) + fulog(l) * (alogpo(l) - alogoo(l))
        cct(l) = alo   (l) + plfac(l) * (ahi   (l) - alo   (l))
  700 continue

! ****** compute temperature correction coefficient for co2 absorption

      do 750 l=1,ln
        fulog(l) = ulog(l) + 4
        iulog(l) = int(fulog(l))
        if ( iulog(l).gt.6 ) iulog(l) = 6
        fulog(l) = fulog(l) - real(iulog(l))
  750 continue

      do 800 l = 1, ln
        index(l) = iulog(l) + 7 * (nplog(l) - 1)
  800 continue

      do 820 l=1,ln
        alogoo(l) = d_absorp_dt(index(l),1)
  820 continue
      do 840 l=1,ln
        index (l) = index(l) + 1
        alogpo(l) = d_absorp_dt(index(l),1)
  840 continue
      do 860 l=1,ln
        index (l) = index(l) + (7 - 1)
        alogop(l) = d_absorp_dt(index(l),1)
  860 continue
      do 880 l=1,ln
        index (l) = index(l) + 1
        alogpp(l) = d_absorp_dt(index(l),1)
  880 continue

      do 900 i = 1, ln
        ahi(i) = alogop(i) + fulog(i) * (alogpp(i) - alogop(i))
        alo(i) = alogoo(i) + fulog(i) * (alogpo(i) - alogoo(i))
        cdt(i) = alo   (i) + plfac(i) * (ahi   (i) - alo   (i))
  900 continue

! ****** restrict effective temperature input values to proper range

      do 950 l=1,ln
        tcor(l) = teff(l)
        if ( tcor(l).gt.320.0 ) tcor(l) = 320
        if ( tcor(l).lt.180.0 ) tcor(l) = 180
  950 continue

! ****** apply temperature correction to co2
! ****** absorption if ulog is in range

      do 1000  l=1,ln
        cdt (l) = cct(l) + 0.01 * (cdt(l) * (tcor(l) - 300))
        tco2(l) = 1 - 1.3077 * cdt(l)
 1000 continue

      do 1100 l=1,ln
        if ( ulog(l).lt.-3 ) tco2(l) = 1 - 1.3077 * cct(l)
 1100 continue

      return

! ****** fatal error: ulog out-of-range

 1200 write(6,1201) ulog
      call Error_Mesg ( 'lwco2 in MCM_LW_MOD','ulog out of range.', FATAL)

 1201 format('1ulog > 3. or < -4.25; execution terminated' / ' the ulog vector is:' / (8e16.8))

        end subroutine lwco2

      end module mcm_lw_mod


      module mcm_swnew_mod

      use mcm_swtbls_mod, only: aaa, aab
      Use       Fms_Mod, ONLY: write_version_number, mpp_pe, mpp_root_pe, &
                               error_mesg, FATAL

!implicit none 
private 

      character(len=128) :: version = '$Id: mcm_swnew.F90,v 10.0 2003/10/24 22:00:32 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical            :: module_is_initialized = .false.

public mcm_swnew, mcm_swnew_init, mcm_swnew_end

      contains

      subroutine mcm_swnew( cosz, rco2, rh2o, ro3, pp, &
              cwca, cwcb, coca, cloudy, kthsw, kbhsw, ssolar, pr2, &
              flx, heat, grdflx, ncv, kx, UF, DF)

!          TK Original array parameters:
!              cosz, tauda, rco2, rh2o, ro3, pp, &
!              cwca, cwcb, coca, cloudy, kthsw, kbhsw, solrsw, pr2, &
!              flx, heat, grdflx, ncv, kx)

!     TK Modified from Kerr's re-write of SS shortwave routine
!     swnew.F.  FMS developmental version 5/29/01.

!     This routine performs SS shortwave radiation on a single
!     column (of dimension kx).  For kx use RDPARM_MOD.

!     rh2o and ro3 have been modified to have dimension kx, rather
!     than kx+1.

!     New output arrays UF, DF have been added as needed by FMS.

!     cosz, tauda, solrsw  trio of input variables replaced by
!     cosz and ssolar as in FMS.  Code modified below.


      parameter (nbsw=9)

! TK      real   , intent (in)  :: cosz, tauda, rco2, solrsw
      real   , intent (in)  :: cosz, rco2, Ssolar

! TK      real   , intent (in), dimension(kx+1)      :: rh2o, ro3
      real   , intent (in), dimension(kx)        :: rh2o, ro3
      real   , intent (in), dimension(0:kx)      :: pp
      real   , intent (in), dimension(1:kx+2)    :: cwca, cwcb, coca, cloudy
      real   , intent (in), dimension(1:kx+1)    :: pr2

      integer, intent (in), dimension(1:kx+2)    :: kthsw, kbhsw
      integer, intent (in)                       :: ncv, kx

      real   , intent (out)                      :: grdflx
! TK      real   , intent (out), dimension(1:kx+1)   :: flx, heat
      real   , intent (out), dimension(1:kx+1)   :: flx, heat, UF, DF

      dimension abcff (nbsw)
      dimension absdo3(kx+1)
      dimension absuo3(kx+1)
      dimension aco2  ((kx+1)*2)
      dimension adco2 (kx+1)
      dimension alfa  (nbsw)
      dimension alfat (nbsw,kx+1)
      dimension alfau (nbsw,kx+1)
      dimension ao3   ((kx+1)*2)
      dimension auco2 (kx+1)
      dimension axx   ((kx+1)*2)
      dimension ayy   ((kx+1)*2)
      dimension azz   ((kx+1)*2)
      dimension cca   (nbsw,kx+2)
      dimension ccb   (nbsw,kx+2)
      dimension cr    (nbsw,kx+2)
      dimension cro3  (kx+2)
      dimension ct    (nbsw,kx+2)
      dimension cto3  (kx+2)
      dimension ddrv  (nbsw,kx)
! TK      dimension df    (kx+1)
      dimension dfn   (nbsw,kx+1)
      dimension dpcld (kx)
      dimension dpsw  (kx+1)
      dimension duco2 (kx+1)
      dimension duo3  (kx+1)
      dimension dusw  (kx+1)
      dimension ff    (kx+1)
      dimension ffco2 (kx+1)
      dimension ffo3  (kx+1)
      dimension in    ((kx+1)*2)
      dimension ixx   ((kx+1)*2)
      dimension ppress(kx+1)
      dimension pwts  (nbsw)
      dimension t1    (nbsw,kx+1)
      dimension t2    (nbsw,kx+1)
      dimension tcld  (nbsw,kx+1)
      dimension tclu  (nbsw,kx+1)
      dimension tdh2o (nbsw,kx+1)
      dimension ttd   (nbsw,kx+1)
      dimension ttu   (nbsw,kx+1)
      dimension tuh2o (nbsw,kx+1)
      dimension uco2  ((kx+1)*2)
      dimension ud    (kx+1)
      dimension udco2 (kx+1)
      dimension udo3  (kx+1)
      dimension udrv  (nbsw,kx)
! TK      dimension uf    (kx+1)
      dimension ufn   (nbsw,kx+1)
      dimension uo3   ((kx+1)*2)
      dimension ur    (kx+1)
      dimension urco2 (kx+1)
      dimension uro3  (kx+1)
      dimension vv    (nbsw)
      dimension vvd   (nbsw)
      dimension vvu   (nbsw)

      data abcff/2*4.0e-5,.002,.035,.377,1.95,9.40,44.6,190./
      data pwts/.5000,.1470,.0698,.1443,.0584,.0335,.0225,.0158,.0087/
      data cfco2,cfo3/508.96,466.64/
      data reflo3/1.9/
      data rrayav/0.144/
      data g1/1.020408e-3/

      kp    = kx + 1
      kpx2  = kp*2
      kpx2m = kpx2-1
      nc0   = ncv - 2
      nc1   = nc0 + 1
      nc2   = nc0 + 2
      nc3   = nc0 + 3

      ppress(1:kp) = pp(0:kx)

      do 351 i=1,kp
      ff(i)=1.66
      ffco2(i)=1.66
      ffo3(i)=1.90
351   continue
      do 339 k=1,nc2
      cro3(k)=coca(k)*cloudy(k)
339   continue
      do 334 kk=1,nc2
      cto3(kk)=1.-cro3(kk)
334   continue
      do 335 n=2,nbsw
      do 335 k=1,nc2
      cca(n,k)=cwca(k)
      ccb(n,k)=cwcb(k)
335   continue
      do 336 n=2,nbsw
      do 333 kk=1,nc2
      cr(n,kk)=cca(n,kk)*cloudy(kk)
      ct(n,kk)=cloudy(kk)*(1.-(cca(n,kk)+ccb(n,kk)))+1.-cloudy(kk)
333   continue
336   continue
      do 337 kk=1,nc2
      cr(1,kk)=cro3(kk)
      ct(1,kk)=cto3(kk)
337   continue
!     kbhsw,kthsw are cloud level indices for bottom and top of cloud
!     cr,ct are cloud reflectivity,transmissivity with index 2
!     representing the topmost cloud
!     ***********************************************************
!     calculate initial ozone reflectivity
      rray=0.219/(1.+0.816*cosz)
      rg=cro3(nc2)
      refl=rray+(1.-rray)*(1.-rrayav)*rg/(1.-rg*rrayav)
      cr(1,nc2)=refl
      ltop=kthsw(2)
      secz=1./cosz
      do 2 i=1,kx
2     dpsw(i)=ppress(i+1)-ppress(i)
      do 3 i=1,kx
      duo3(i)=ro3(i)*dpsw(i)*g1
      duco2(i)=rco2*dpsw(i)*g1
3     dusw(i)=rh2o(i)*dpsw(i)*g1
      do 131 i=1,ltop
      ffo3(i)=secz
      ffco2(i)=secz
      ff(i)=secz
131   continue
!     calculate pressure-weighted optical paths in units of g/cm2.
!     pressure weighting is by p**0.5
!     ud is the downward path,ur the upward path,
!     and the calculation is made by taking a path with an angle
!     of (secz) from the top of the atmosphere to the topmost cloud,
!     then using the diffusivity factor (1.66) to the surface and for
!     reflected radiation. the code below reflects this.
      ud(1)=0.
      udco2(1)=0.
      udo3(1)=0.
      do 4 i=2,kp
      ud(i)=ud(i-1)+dusw(i-1)*pr2(i-1)*ff(i)
      udco2(i)=udco2(i-1)+duco2(i-1)*pr2(i-1)*ffco2(i)*cfco2
      udo3(i)=udo3(i-1)+duo3(i-1)*ffo3(i)*cfo3
4     continue
!     udo3,uro3 are in units of cm. cfco2,cfo3 is the conversion
!     factor from gm/cm2 to cm.
      ur(kp)=ud(kp)
      urco2(kp)=udco2(kp)
      uro3(kp)=udo3(kp)
      do 5 i=1,kx
      ur(i)=ud(kp)+1.66*(ud(kp)/ff(kp)-ud(i)/ff(i+1)) &
                +ud(ltop)*(ff(kp)-ff(i+1))/ff(i+1)
      urco2(i)=urco2(kp)+1.66*(udco2(kp)/ffco2(kp)-udco2(i)/ffco2(i+1)) &
         +udco2(ltop)*(ffco2(kp)-ffco2(i+1))/ffco2(i+1)
      uro3(i)=uro3(kp)+reflo3*(udo3(kp)/ffo3(kp)-udo3(i)/ffo3(i+1)) &
           +udo3(ltop)*(ffo3(kp)-ffo3(i+1))/ffo3(i+1)
5     continue
 
!     maximize the size of o3 and co2 path lengths to avoid going
!     off tables

      uo3(1:kp)    = udo3(1:kp)
      uo3(kx+2:kp*2) = uro3(1:kp)

      uco2(1:kp)    = udco2(1:kp)
      uco2(kx+2:kp*2) = urco2(1:kp)

      do 621 k=1,kpx2
       uco2(k) =amin1(uco2(k),998.9)
       uo3(k) =amin1(uo3(k),3.998)
621   continue
 
!     calculate entering flux at the top
      do 6 n=1,nbsw
! TK      dfn(n,1)=solrsw*6.97667e5*cosz*tauda*pwts(n)
! TK      Replace 
      dfn(n,1)=Ssolar*6.97667e5*pwts(n)
6     continue
!     calculate water vapor transmission functions for bands 2-9;
!     t.f. for band 1= t.f for band 2
      do 7 k=1,kp
      do 7 n=2,nbsw
      t1(n,k)=amin1(abcff(n)*ud(k),50.)
      t2(n,k)=amin1(abcff(n)*ur(k),50.)
7     continue
      do 8 n=2,nbsw
      tdh2o(n,1)=1.
8     continue
      do 9 n=2,nbsw
      do 9 k=2,kp
      tdh2o(n,k)=exp(-t1(n,k))
9     continue
      do 10 n=2,nbsw
      tuh2o(n,kp)=tdh2o(n,kp)
10    continue
      do 11 n=2,nbsw
      do 11 k=1,kx
      tuh2o(n,k)=exp(-t2(n,k))
11    continue
      do 12 k=1,kp
      tdh2o(1,k)=tdh2o(2,k)
      tuh2o(1,k)=tuh2o(2,k)
12    continue
!     calculate co2 absorptions . they will be used in bands 2-9.
!     since these occupy 50 percent of the solar spectrum the
!     absorptions will be multiplied by 2.
!     the absorptions are obtained by table lookup in array aab,
!     common block swtabl,and then interpolation.
      do 614 k=1,kpx2
      ixx(k)=uco2(k)+1.
614   continue
      do 615 k=1,kpx2
      axx(k)=uco2(k)-ifix(uco2(k))
615   continue
      call mcm_sif1d ( ixx, kpx2m, ayy, azz )
      do 617 k=1,kpx2
      aco2(k)=ayy(k)+axx(k)*(azz(k)-ayy(k))
617   continue

      adco2(1:kp) = aco2(1:kp)
      auco2(1:kp) = aco2(kx+2:kp*2)

      do 26 k=1,kp
      adco2(k)=2.*adco2(k)
      auco2(k)=2.*auco2(k)
26    continue
!     now calculate ozone absorptions. these will be used in
!     band 1. as this occupies 50 percent of the solar spectrum
!     the ozone absorptions will be multiplied by 2.
!     the ozone absorptions are obtained by table lookup from
!     array aaa, common block swtabl. no interpolation is done.
      do 603 k=1,kpx2
      in(k)=500.*uo3(k)+1
603   continue
      call mcm_sif1 ( in, kpx2m, ao3 )

      absdo3(1:kp) = ao3(1:kp)
      absuo3(1:kp) = ao3(kx+2:kp*2)

      do 33 k=1,kp
      absdo3(k)=2.*absdo3(k)
      absuo3(k)=2.*absuo3(k)
33    continue
!     combine absorptions and transmissions to obtain a
!     transmission function for each of the 9 bands.
      do 41 n=1,nbsw
      ttd(n,1)=1.
41    continue
      do 42 k=2,kp
      ttd(1,k)=tdh2o(1,k)*(1.-absdo3(k))
42    continue
      do 43 k=1,kx
      ttu(1,k)=tuh2o(1,k)*(1.-absuo3(k))
43    continue
      do 44 n=2,nbsw
      do 44 k=2,kp
      ttd(n,k)=tdh2o(n,k)*(1.-adco2(k))
44    continue
      do 45 n=1,nbsw
      ttu(n,kp)=ttd(n,kp)
45    continue
      do 46 n=2,nbsw
      do 46 k=1,kx
      ttu(n,k)=tuh2o(n,k)*(1.-auco2(k))
46    continue
!     the following calculation is for alfat: the ratio between
!     the downward flux at the top of the highest cloud (if
!     present) or the ground to the upward flux at the same
!     level, taking into account multiple reflections from
!     clouds, if present
      do 53 n=1,nbsw
      do 53 nn=1,nc1
      alfat(n,nn)=cr(n,nc3-nn)
53    continue
      do 55 nn=1,nc1
      do 55 n=1,nbsw
      alfau(n,nn)=0.
55    continue
      if ( nc0 .eq. 0 )  go to 58
      do 51 ll=1,nc1
      kt1=kthsw(nc3-ll)
      kt2=kthsw(nc2-ll)
      kt3=kbhsw(nc2-ll)
!     tclu(ll) is transmission function from top of next lower
!     cloud to top of upper cloud. tcld(ll) is t.f. from top
!     of next lower cloud to bottom of upper cloud. ll=1 is
!     the lowest bottom cloud (the ground) ; ll=nc1 is the
!     highest upper cloud. this calculation is used for the
!     alfat calculation only if cloud is present.
      do 52 n=1,nbsw
      tclu(n,ll)=ttd(n,kt1)/ttd(n,kt2)
      tcld(n,ll)=ttd(n,kt1)/ttd(n,kt3)
52    continue
51    continue
      do 56 nn=1,nc0
      do 57 n=1,nbsw
      alfau(n,nn+1)=(cr(n,nc3-nn)+alfau(n,nn))*ct(n,nc2-nn)* &
           ct(n,nc2-nn)*tclu(n,nn)*tclu(n,nn)/ &
           (1.-(cr(n,nc3-nn)+alfau(n,nn))*cr(n,nc2-nn)* &
           tcld(n,nn)*tcld(n,nn))
57    continue
56    continue
58    continue
      do 59 n=1,nbsw
      alfa(n)=alfat(n,nc1)+alfau(n,nc1)
59    continue
!     downward flux above topmost cloud
      do 61 n=1,nbsw
      vv(n)=dfn(n,1)
61    continue
      do 62 n=1,nbsw
      do 62 k=2,ltop
      dfn(n,k)=vv(n)*ttd(n,k)
62    continue
!     upward flux above topmost cloud
      ltopm=ltop-1
      do 63 n=1,nbsw
      ufn(n,ltop)=alfa(n)*dfn(n,ltop)
63    continue
      do 64 n=1,nbsw
      vv(n)=ufn(n,ltop)/ttu(n,ltop)
64    continue
      do 65 n=1,nbsw
      do 65 k=1,ltopm
      ufn(n,k)=vv(n)*ttu(n,k)
65    continue
      if ( nc0 .eq. 0 )  go to 91
!     calculate ufn at cloud tops and dfn at cloud bottoms
      do 71 ll=2,nc1
      do 72 n=1,nbsw
      ufn(n,kthsw(ll+1))=alfau(n,nc3-ll)*dfn(n,kbhsw(ll-1))* &
           tcld(n,nc3-ll)/(tclu(n,nc2-ll)*ct(n,ll))
72    continue
      do 73 n=1,nbsw
      dfn(n,kbhsw(ll))=dfn(n,kbhsw(ll-1))*tcld(n,nc3-ll)*tclu(n,nc2-ll)* &
           ct(n,ll)/tcld(n,nc2-ll)+ufn(n,kthsw(ll+1))*tcld(n,nc2-ll)* &
           cr(n,ll)
73    continue
71    continue
!     now obtain dfn and ufn for levels between the clouds
      do 74 ll=1,nc0
      ltop=kbhsw(ll+1)
      ltopp=ltop+1
      lbot=kthsw(ll+2)
      lbotm=lbot-1
      if (ltop.eq.lbot) go to 74
      do 75 n=1,nbsw
      vvu(n)=ufn(n,lbot)/ttu(n,lbot)
      vvd(n)=dfn(n,ltop)/ttd(n,ltop)
75    continue
      do 76 k=ltop,lbotm
      do 76 n=1,nbsw
      ufn(n,k)=vvu(n)*ttu(n,k)
76    continue
      do 77 k=ltopp,lbot
      do 77 n=1,nbsw
      dfn(n,k)=vvd(n)*ttd(n,k)
77    continue
74    continue
!     now obtain downward and upward fluxes for levels,if any,
!     between the tops and bottoms of clouds. the assumption of
!     constant heating rate in these regions is used.
      do 78 ll=1,nc0
      ltop=kthsw(ll+1)
      lbot=kbhsw(ll+1)
      if((lbot-ltop).le.1) go to 78
      ltopp=ltop+1
      lbotm=lbot-1
      dpcld(ll)=ppress(ltop)-ppress(lbot)
      do 79 n=1,nbsw
      udrv(n,ll)=(ufn(n,ltop)-ufn(n,lbot))/dpcld(ll)
      ddrv(n,ll)=(dfn(n,ltop)-dfn(n,lbot))/dpcld(ll)
79    continue
      do 80 n=1,nbsw
      vvu(n)=ufn(n,ltop)
      vvd(n)=dfn(n,ltop)
80    continue
      do 81 k=ltopp,lbotm
      do 81 n=1,nbsw
      ufn(n,k)=vvu(n)+udrv(n,ll)*(ppress(k)-ppress(ltop))
      dfn(n,k)=vvd(n)+ddrv(n,ll)*(ppress(k)-ppress(ltop))
81    continue
78    continue
91    continue
!     sum over bands
 
      do 14 k=1,kp
      df(k)=0.
      uf(k)=0.
      do 15 n=1,nbsw
      df(k)=df(k)+dfn(n,k)
      uf(k)=uf(k)+ufn(n,k)
15    continue
14    continue
      do 16 k=1,kp
      flx(k)=uf(k)-df(k)
16    continue
! TK REMOVE: cdir$ novector
      do 17 k=1,kx
      heat(k)=8.42668*(flx(k+1)-flx(k))/dpsw(k)
17    continue
! TK REMOVE: cdir$ vector
!     8.42668=g(cgs units)*(no.sec/da)/cp(cgs units)
      grdflx=(1.-refl)*dfn(1,kp)
      do 19 n=2,nbsw
      grdflx=grdflx+ct(1,nc2)*dfn(n,kp)
19    continue
      return
      end subroutine mcm_swnew
! --------------------------------------------
      subroutine mcm_sif1(ndx,len,tgt)
      dimension ndx(1),tgt(1)
      leng=len+1
      do 10 j=1,leng
        jj=ndx(j)
        tgt(j)=aaa(jj)
  10  continue
      return
      end subroutine mcm_sif1
! --------------------------------------------
      subroutine mcm_sif1d(ndx,len,tgt1,tgt2)
      dimension ndx(1),tgt1(1),tgt2(1)
      leng=len+1
      do 10 j=1,leng
        jj=ndx(j)
        tgt1(j)=aab(jj)
        tgt2(j)=aab(jj+1)
  10  continue
      return
      end subroutine mcm_sif1d

! ---------------------------------------------------------------------------------------
      subroutine mcm_swnew_init
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      end subroutine mcm_swnew_init
! ---------------------------------------------------------------------------------------
      subroutine mcm_swnew_end

      module_is_initialized = .false.

!---------------------------------------------------------------------
      end subroutine mcm_swnew_end


      end module mcm_swnew_mod


module mcm_swtbls_mod

implicit none
private

public :: aaa, aab

real :: aaa(2000), aab(1000)

data aaa(1:250) / &
.000000e+00,.194992e-02, .336486e-02, .443380e-02, .525235e-02, .589609e-02, .642575e-02, .688126e-02, .728566e-02, .765206e-02, &
.798843e-02,.830006e-02, .859077e-02, .886349e-02, .912056e-02, .936389e-02, .959504e-02, .981537e-02, .100260e-01, .102279e-01, &
.104219e-01,.106088e-01, .107891e-01, .109635e-01, .111324e-01, .112963e-01, .114556e-01, .116105e-01, .117614e-01, .119086e-01, &
.120523e-01,.121928e-01, .123303e-01, .124649e-01, .125968e-01, .127262e-01, .128532e-01, .129779e-01, .131005e-01, .132211e-01, &
.133398e-01,.134566e-01, .135718e-01, .136852e-01, .137971e-01, .139075e-01, .140165e-01, .141240e-01, .142303e-01, .143353e-01, &
.144390e-01,.145417e-01, .146431e-01, .147436e-01, .148429e-01, .149413e-01, .150388e-01, .151352e-01, .152308e-01, .153256e-01, &
.154195e-01,.155125e-01, .156048e-01, .156964e-01, .157872e-01, .158773e-01, .159667e-01, .160555e-01, .161436e-01, .162310e-01, &
.163179e-01,.164041e-01, .164898e-01, .165749e-01, .166595e-01, .167435e-01, .168270e-01, .169100e-01, .169925e-01, .170746e-01, &
.171561e-01,.172372e-01, .173179e-01, .173981e-01, .174779e-01, .175573e-01, .176362e-01, .177148e-01, .177930e-01, .178708e-01, &
.179483e-01,.180253e-01, .181020e-01, .181784e-01, .182544e-01, .183301e-01, .184055e-01, .184805e-01, .185553e-01, .186297e-01, &
.187038e-01,.187776e-01, .188511e-01, .189244e-01, .189974e-01, .190701e-01, .191425e-01, .192146e-01, .192865e-01, .193582e-01, &
.194295e-01,.195007e-01, .195716e-01, .196422e-01, .197127e-01, .197828e-01, .198528e-01, .199226e-01, .199921e-01, .200614e-01, &
.201305e-01,.201994e-01, .202680e-01, .203365e-01, .204048e-01, .204729e-01, .205407e-01, .206084e-01, .206759e-01, .207433e-01, &
.208104e-01,.208774e-01, .209441e-01, .210107e-01, .210772e-01, .211434e-01, .212095e-01, .212754e-01, .213412e-01, .214068e-01, &
.214722e-01,.215375e-01, .216026e-01, .216676e-01, .217325e-01, .217971e-01, .218617e-01, .219261e-01, .219903e-01, .220544e-01, &
.221184e-01,.221822e-01, .222459e-01, .223094e-01, .223729e-01, .224361e-01, .224993e-01, .225623e-01, .226252e-01, .226880e-01, &
.227507e-01,.228132e-01, .228756e-01, .229379e-01, .230001e-01, .230621e-01, .231240e-01, .231858e-01, .232476e-01, .233091e-01, &
.233706e-01,.234320e-01, .234933e-01, .235544e-01, .236155e-01, .236764e-01, .237373e-01, .237980e-01, .238586e-01, .239192e-01, &
.239796e-01,.240400e-01, .241002e-01, .241603e-01, .242204e-01, .242803e-01, .243402e-01, .243999e-01, .244596e-01, .245192e-01, &
.245787e-01,.246381e-01, .246974e-01, .247566e-01, .248157e-01, .248748e-01, .249337e-01, .249926e-01, .250514e-01, .251101e-01, &
.251687e-01,.252272e-01, .252857e-01, .253440e-01, .254023e-01, .254605e-01, .255187e-01, .255767e-01, .256347e-01, .256926e-01, &
.257505e-01,.258082e-01, .258659e-01, .259235e-01, .259810e-01, .260385e-01, .260959e-01, .261531e-01, .262104e-01, .262676e-01, &
.263247e-01,.263817e-01, .264387e-01, .264955e-01, .265524e-01, .266091e-01, .266658e-01, .267224e-01, .267790e-01, .268355e-01, &
.268919e-01,.269483e-01, .270046e-01, .270608e-01, .271169e-01, .271730e-01, .272291e-01, .272851e-01, .273410e-01, .273969e-01, &
.274527e-01,.275084e-01, .275641e-01, .276197e-01, .276753e-01, .277308e-01, .277862e-01, .278416e-01, .278969e-01, .279522e-01/
data aaa(251:500) / &
.280074e-01,.280626e-01, .281177e-01, .281727e-01, .282277e-01, .282826e-01, .283375e-01, .283924e-01, .284471e-01, .285018e-01, &
.285565e-01,.286111e-01, .286657e-01, .287202e-01, .287747e-01, .288291e-01, .288835e-01, .289378e-01, .289920e-01, .290462e-01, &
.291004e-01,.291545e-01, .292086e-01, .292626e-01, .293166e-01, .293704e-01, .294243e-01, .294781e-01, .295319e-01, .295856e-01, &
.296393e-01,.296929e-01, .297465e-01, .298001e-01, .298536e-01, .299070e-01, .299604e-01, .300138e-01, .300671e-01, .301203e-01, &
.301736e-01,.302267e-01, .302799e-01, .303330e-01, .303860e-01, .304390e-01, .304920e-01, .305449e-01, .305978e-01, .306506e-01, &
.307034e-01,.307562e-01, .308089e-01, .308615e-01, .309141e-01, .309668e-01, .310193e-01, .310718e-01, .311243e-01, .311767e-01, &
.312291e-01,.312814e-01, .313337e-01, .313860e-01, .314382e-01, .314904e-01, .315426e-01, .315947e-01, .316468e-01, .316988e-01, &
.317508e-01,.318028e-01, .318547e-01, .319066e-01, .319584e-01, .320102e-01, .320620e-01, .321137e-01, .321654e-01, .322171e-01, &
.322687e-01,.323203e-01, .323719e-01, .324234e-01, .324749e-01, .325264e-01, .325778e-01, .326292e-01, .326805e-01, .327318e-01, &
.327831e-01,.328343e-01, .328855e-01, .329367e-01, .329879e-01, .330390e-01, .330901e-01, .331411e-01, .331921e-01, .332431e-01, &
.332940e-01,.333449e-01, .333958e-01, .334466e-01, .334975e-01, .335482e-01, .335990e-01, .336497e-01, .337004e-01, .337510e-01, &
.338016e-01,.338522e-01, .339028e-01, .339533e-01, .340038e-01, .340543e-01, .341047e-01, .341551e-01, .342055e-01, .342558e-01, &
.343061e-01,.343564e-01, .344066e-01, .344569e-01, .345071e-01, .345572e-01, .346073e-01, .346574e-01, .347075e-01, .347576e-01, &
.348076e-01,.348576e-01, .349075e-01, .349574e-01, .350073e-01, .350572e-01, .351071e-01, .351569e-01, .352067e-01, .352564e-01, &
.353061e-01,.353558e-01, .354055e-01, .354551e-01, .355048e-01, .355543e-01, .356039e-01, .356534e-01, .357030e-01, .357524e-01, &
.358019e-01,.358513e-01, .359007e-01, .359501e-01, .359994e-01, .360487e-01, .360980e-01, .361473e-01, .361965e-01, .362457e-01, &
.362949e-01,.363441e-01, .363932e-01, .364423e-01, .364914e-01, .365405e-01, .365895e-01, .366385e-01, .366875e-01, .367364e-01, &
.367854e-01,.368343e-01, .368832e-01, .369320e-01, .369808e-01, .370296e-01, .370784e-01, .371272e-01, .371759e-01, .372246e-01, &
.372733e-01,.373219e-01, .373706e-01, .374192e-01, .374678e-01, .375163e-01, .375648e-01, .376134e-01, .376619e-01, .377103e-01, &
.377588e-01,.378072e-01, .378556e-01, .379040e-01, .379523e-01, .380006e-01, .380489e-01, .380972e-01, .381455e-01, .381937e-01, &
.382419e-01,.382901e-01, .383382e-01, .383864e-01, .384345e-01, .384826e-01, .385307e-01, .385787e-01, .386267e-01, .386747e-01, &
.387227e-01,.387707e-01, .388186e-01, .388665e-01, .389144e-01, .389623e-01, .390101e-01, .390580e-01, .391058e-01, .391536e-01, &
.392013e-01,.392491e-01, .392968e-01, .393445e-01, .393922e-01, .394398e-01, .394875e-01, .395351e-01, .395827e-01, .396302e-01, &
.396778e-01,.397253e-01, .397728e-01, .398203e-01, .398678e-01, .399152e-01, .399626e-01, .400101e-01, .400574e-01, .401048e-01, &
.401521e-01,.401995e-01, .402468e-01, .402940e-01, .403413e-01, .403885e-01, .404358e-01, .404829e-01, .405301e-01, .405773e-01/
data aaa(501:750) / &
.406244e-01,.406715e-01, .407186e-01, .407657e-01, .408127e-01, .408598e-01, .409068e-01, .409538e-01, .410008e-01, .410478e-01, &
.410947e-01,.411416e-01, .411885e-01, .412354e-01, .412823e-01, .413291e-01, .413759e-01, .414227e-01, .414695e-01, .415163e-01, &
.415630e-01,.416098e-01, .416565e-01, .417032e-01, .417498e-01, .417965e-01, .418431e-01, .418898e-01, .419363e-01, .419829e-01, &
.420295e-01,.420760e-01, .421226e-01, .421691e-01, .422155e-01, .422620e-01, .423084e-01, .423549e-01, .424013e-01, .424477e-01, &
.424941e-01,.425404e-01, .425868e-01, .426331e-01, .426794e-01, .427257e-01, .427720e-01, .428182e-01, .428644e-01, .429106e-01, &
.429568e-01,.430030e-01, .430492e-01, .430954e-01, .431415e-01, .431876e-01, .432337e-01, .432797e-01, .433258e-01, .433718e-01, &
.434179e-01,.434639e-01, .435099e-01, .435559e-01, .436018e-01, .436477e-01, .436936e-01, .437395e-01, .437854e-01, .438313e-01, &
.438772e-01,.439230e-01, .439688e-01, .440146e-01, .440604e-01, .441062e-01, .441519e-01, .441976e-01, .442434e-01, .442890e-01, &
.443347e-01,.443804e-01, .444261e-01, .444717e-01, .445173e-01, .445629e-01, .446085e-01, .446541e-01, .446996e-01, .447452e-01, &
.447907e-01,.448362e-01, .448817e-01, .449272e-01, .449726e-01, .450180e-01, .450635e-01, .451089e-01, .451543e-01, .451996e-01, &
.452450e-01,.452903e-01, .453357e-01, .453810e-01, .454263e-01, .454715e-01, .455168e-01, .455620e-01, .456073e-01, .456525e-01, &
.456977e-01,.457429e-01, .457880e-01, .458332e-01, .458784e-01, .459235e-01, .459686e-01, .460137e-01, .460588e-01, .461038e-01, &
.461489e-01,.461939e-01, .462389e-01, .462839e-01, .463289e-01, .463738e-01, .464188e-01, .464638e-01, .465087e-01, .465536e-01, &
.465985e-01,.466433e-01, .466882e-01, .467331e-01, .467779e-01, .468227e-01, .468675e-01, .469123e-01, .469571e-01, .470019e-01, &
.470466e-01,.470913e-01, .471360e-01, .471807e-01, .472254e-01, .472701e-01, .473148e-01, .473594e-01, .474040e-01, .474486e-01, &
.474932e-01,.475378e-01, .475824e-01, .476269e-01, .476714e-01, .477160e-01, .477605e-01, .478050e-01, .478495e-01, .478940e-01, &
.479384e-01,.479828e-01, .480273e-01, .480717e-01, .481161e-01, .481605e-01, .482048e-01, .482492e-01, .482935e-01, .483378e-01, &
.483821e-01,.484264e-01, .484707e-01, .485150e-01, .485592e-01, .486035e-01, .486477e-01, .486919e-01, .487361e-01, .487803e-01, &
.488245e-01,.488686e-01, .489128e-01, .489569e-01, .490010e-01, .490451e-01, .490892e-01, .491333e-01, .491774e-01, .492214e-01, &
.492654e-01,.493095e-01, .493535e-01, .493974e-01, .494414e-01, .494854e-01, .495293e-01, .495733e-01, .496172e-01, .496611e-01, &
.497050e-01,.497489e-01, .497928e-01, .498366e-01, .498805e-01, .499243e-01, .499681e-01, .500119e-01, .500557e-01, .500995e-01, &
.501433e-01,.501870e-01, .502308e-01, .502745e-01, .503182e-01, .503619e-01, .504056e-01, .504492e-01, .504929e-01, .505365e-01, &
.505802e-01,.506238e-01, .506674e-01, .507110e-01, .507546e-01, .507982e-01, .508417e-01, .508853e-01, .509288e-01, .509723e-01, &
.510158e-01,.510593e-01, .511028e-01, .511463e-01, .511897e-01, .512332e-01, .512766e-01, .513200e-01, .513634e-01, .514068e-01, &
.514501e-01,.514935e-01, .515369e-01, .515802e-01, .516235e-01, .516669e-01, .517102e-01, .517534e-01, .517967e-01, .518400e-01/
data aaa(751:1000) / &
.518832e-01,.519265e-01, .519697e-01, .520129e-01, .520561e-01, .520993e-01, .521425e-01, .521856e-01, .522288e-01, .522719e-01, &
.523150e-01,.523582e-01, .524013e-01, .524443e-01, .524874e-01, .525305e-01, .525735e-01, .526166e-01, .526596e-01, .527027e-01, &
.527456e-01,.527886e-01, .528316e-01, .528746e-01, .529175e-01, .529605e-01, .530034e-01, .530463e-01, .530892e-01, .531321e-01, &
.531750e-01,.532179e-01, .532607e-01, .533036e-01, .533464e-01, .533892e-01, .534321e-01, .534748e-01, .535176e-01, .535604e-01, &
.536031e-01,.536459e-01, .536887e-01, .537314e-01, .537741e-01, .538168e-01, .538595e-01, .539022e-01, .539448e-01, .539875e-01, &
.540301e-01,.540728e-01, .541154e-01, .541580e-01, .542006e-01, .542432e-01, .542858e-01, .543283e-01, .543709e-01, .544134e-01, &
.544559e-01,.544985e-01, .545410e-01, .545835e-01, .546260e-01, .546684e-01, .547109e-01, .547533e-01, .547958e-01, .548382e-01, &
.548806e-01,.549230e-01, .549654e-01, .550077e-01, .550501e-01, .550925e-01, .551348e-01, .551771e-01, .552195e-01, .552618e-01, &
.553041e-01,.553464e-01, .553887e-01, .554309e-01, .554732e-01, .555154e-01, .555576e-01, .555999e-01, .556421e-01, .556843e-01, &
.557265e-01,.557686e-01, .558108e-01, .558529e-01, .558951e-01, .559372e-01, .559794e-01, .560214e-01, .560635e-01, .561056e-01, &
.561477e-01,.561898e-01, .562318e-01, .562739e-01, .563159e-01, .563579e-01, .563999e-01, .564420e-01, .564839e-01, .565259e-01, &
.565678e-01,.566098e-01, .566518e-01, .566937e-01, .567356e-01, .567775e-01, .568194e-01, .568613e-01, .569032e-01, .569450e-01, &
.569869e-01,.570288e-01, .570706e-01, .571124e-01, .571542e-01, .571960e-01, .572378e-01, .572796e-01, .573214e-01, .573631e-01, &
.574049e-01,.574466e-01, .574884e-01, .575300e-01, .575718e-01, .576134e-01, .576551e-01, .576968e-01, .577385e-01, .577801e-01, &
.578218e-01,.578634e-01, .579050e-01, .579466e-01, .579882e-01, .580298e-01, .580714e-01, .581130e-01, .581545e-01, .581961e-01, &
.582376e-01,.582791e-01, .583206e-01, .583621e-01, .584036e-01, .584451e-01, .584866e-01, .585281e-01, .585695e-01, .586109e-01, &
.586524e-01,.586938e-01, .587352e-01, .587766e-01, .588180e-01, .588594e-01, .589007e-01, .589421e-01, .589834e-01, .590248e-01, &
.590661e-01,.591075e-01, .591487e-01, .591900e-01, .592313e-01, .592726e-01, .593139e-01, .593551e-01, .593964e-01, .594376e-01, &
.594788e-01,.595200e-01, .595612e-01, .596025e-01, .596436e-01, .596848e-01, .597260e-01, .597671e-01, .598083e-01, .598494e-01, &
.598905e-01,.599317e-01, .599727e-01, .600138e-01, .600549e-01, .600960e-01, .601370e-01, .601781e-01, .602191e-01, .602602e-01, &
.603012e-01,.603422e-01, .603832e-01, .604242e-01, .604652e-01, .605062e-01, .605471e-01, .605881e-01, .606290e-01, .606699e-01, &
.607109e-01,.607518e-01, .607927e-01, .608336e-01, .608745e-01, .609153e-01, .609562e-01, .609971e-01, .610379e-01, .610787e-01, &
.611196e-01,.611604e-01, .612012e-01, .612420e-01, .612828e-01, .613235e-01, .613643e-01, .614051e-01, .614458e-01, .614865e-01, &
.615272e-01,.615680e-01, .616087e-01, .616494e-01, .616901e-01, .617307e-01, .617714e-01, .618121e-01, .618527e-01, .618934e-01, &
.619340e-01,.619746e-01, .620152e-01, .620558e-01, .620964e-01, .621370e-01, .621775e-01, .622181e-01, .622587e-01, .622992e-01/
data aaa(1001:1250) / &
.623397e-01,.623802e-01, .624208e-01, .624613e-01, .625017e-01, .625422e-01, .625827e-01, .626232e-01, .626636e-01, .627041e-01, &
.627445e-01,.627849e-01, .628254e-01, .628657e-01, .629061e-01, .629465e-01, .629869e-01, .630273e-01, .630677e-01, .631080e-01, &
.631483e-01,.631887e-01, .632290e-01, .632693e-01, .633096e-01, .633499e-01, .633902e-01, .634305e-01, .634707e-01, .635110e-01, &
.635512e-01,.635915e-01, .636317e-01, .636719e-01, .637121e-01, .637524e-01, .637925e-01, .638327e-01, .638729e-01, .639131e-01, &
.639532e-01,.639934e-01, .640335e-01, .640736e-01, .641137e-01, .641539e-01, .641940e-01, .642340e-01, .642741e-01, .643142e-01, &
.643542e-01,.643943e-01, .644343e-01, .644744e-01, .645144e-01, .645544e-01, .645944e-01, .646344e-01, .646744e-01, .647144e-01, &
.647544e-01,.647943e-01, .648342e-01, .648742e-01, .649142e-01, .649541e-01, .649940e-01, .650339e-01, .650738e-01, .651137e-01, &
.651536e-01,.651934e-01, .652333e-01, .652732e-01, .653130e-01, .653529e-01, .653927e-01, .654325e-01, .654723e-01, .655121e-01, &
.655519e-01,.655916e-01, .656314e-01, .656712e-01, .657110e-01, .657507e-01, .657904e-01, .658302e-01, .658699e-01, .659096e-01, &
.659493e-01,.659890e-01, .660287e-01, .660684e-01, .661080e-01, .661476e-01, .661873e-01, .662270e-01, .662665e-01, .663061e-01, &
.663458e-01,.663853e-01, .664250e-01, .664645e-01, .665041e-01, .665437e-01, .665833e-01, .666228e-01, .666623e-01, .667018e-01, &
.667414e-01,.667809e-01, .668204e-01, .668598e-01, .668994e-01, .669389e-01, .669783e-01, .670178e-01, .670573e-01, .670967e-01, &
.671361e-01,.671756e-01, .672150e-01, .672543e-01, .672938e-01, .673331e-01, .673725e-01, .674119e-01, .674513e-01, .674906e-01, &
.675300e-01,.675693e-01, .676086e-01, .676480e-01, .676873e-01, .677266e-01, .677659e-01, .678052e-01, .678444e-01, .678837e-01, &
.679229e-01,.679622e-01, .680014e-01, .680407e-01, .680799e-01, .681191e-01, .681583e-01, .681975e-01, .682368e-01, .682759e-01, &
.683151e-01,.683542e-01, .683934e-01, .684326e-01, .684717e-01, .685108e-01, .685499e-01, .685891e-01, .686282e-01, .686672e-01, &
.687063e-01,.687454e-01, .687845e-01, .688236e-01, .688626e-01, .689017e-01, .689407e-01, .689797e-01, .690187e-01, .690578e-01, &
.690967e-01,.691358e-01, .691748e-01, .692137e-01, .692527e-01, .692917e-01, .693306e-01, .693696e-01, .694085e-01, .694475e-01, &
.694863e-01,.695252e-01, .695642e-01, .696031e-01, .696419e-01, .696808e-01, .697197e-01, .697585e-01, .697974e-01, .698363e-01, &
.698751e-01,.699139e-01, .699527e-01, .699915e-01, .700303e-01, .700691e-01, .701079e-01, .701467e-01, .701854e-01, .702242e-01, &
.702630e-01,.703017e-01, .703405e-01, .703791e-01, .704179e-01, .704566e-01, .704953e-01, .705340e-01, .705727e-01, .706114e-01, &
.706500e-01,.706887e-01, .707273e-01, .707660e-01, .708047e-01, .708432e-01, .708819e-01, .709205e-01, .709591e-01, .709977e-01, &
.710363e-01,.710749e-01, .711134e-01, .711520e-01, .711905e-01, .712290e-01, .712676e-01, .713062e-01, .713447e-01, .713832e-01, &
.714217e-01,.714602e-01, .714987e-01, .715371e-01, .715756e-01, .716141e-01, .716525e-01, .716910e-01, .717294e-01, .717679e-01, &
.718063e-01,.718447e-01, .718831e-01, .719215e-01, .719599e-01, .719983e-01, .720367e-01, .720750e-01, .721134e-01, .721518e-01/
data aaa(1251:1500) / &
.721901e-01,.722284e-01, .722668e-01, .723050e-01, .723434e-01, .723817e-01, .724200e-01, .724583e-01, .724965e-01, .725348e-01, &
.725731e-01,.726113e-01, .726495e-01, .726879e-01, .727261e-01, .727643e-01, .728025e-01, .728407e-01, .728789e-01, .729171e-01, &
.729553e-01,.729934e-01, .730316e-01, .730698e-01, .731079e-01, .731460e-01, .731842e-01, .732223e-01, .732605e-01, .732985e-01, &
.733367e-01,.733747e-01, .734129e-01, .734509e-01, .734890e-01, .735271e-01, .735651e-01, .736032e-01, .736412e-01, .736793e-01, &
.737172e-01,.737553e-01, .737933e-01, .738313e-01, .738693e-01, .739073e-01, .739452e-01, .739832e-01, .740212e-01, .740591e-01, &
.740970e-01,.741351e-01, .741729e-01, .742109e-01, .742488e-01, .742867e-01, .743246e-01, .743625e-01, .744004e-01, .744383e-01, &
.744761e-01,.745140e-01, .745518e-01, .745897e-01, .746275e-01, .746653e-01, .747032e-01, .747410e-01, .747788e-01, .748166e-01, &
.748544e-01,.748921e-01, .749300e-01, .749677e-01, .750055e-01, .750433e-01, .750809e-01, .751187e-01, .751565e-01, .751942e-01, &
.752319e-01,.752696e-01, .753073e-01, .753449e-01, .753826e-01, .754203e-01, .754580e-01, .754956e-01, .755333e-01, .755709e-01, &
.756086e-01,.756462e-01, .756838e-01, .757214e-01, .757591e-01, .757967e-01, .758342e-01, .758718e-01, .759094e-01, .759469e-01, &
.759845e-01,.760220e-01, .760596e-01, .760971e-01, .761346e-01, .761722e-01, .762097e-01, .762472e-01, .762847e-01, .763222e-01, &
.763597e-01,.763972e-01, .764346e-01, .764720e-01, .765096e-01, .765470e-01, .765845e-01, .766218e-01, .766593e-01, .766968e-01, &
.767341e-01,.767715e-01, .768089e-01, .768463e-01, .768837e-01, .769210e-01, .769584e-01, .769957e-01, .770331e-01, .770705e-01, &
.771078e-01,.771451e-01, .771824e-01, .772198e-01, .772570e-01, .772943e-01, .773316e-01, .773689e-01, .774062e-01, .774435e-01, &
.774807e-01,.775180e-01, .775552e-01, .775924e-01, .776296e-01, .776669e-01, .777041e-01, .777413e-01, .777785e-01, .778157e-01, &
.778528e-01,.778900e-01, .779272e-01, .779644e-01, .780016e-01, .780387e-01, .780758e-01, .781130e-01, .781500e-01, .781872e-01, &
.782243e-01,.782614e-01, .782985e-01, .783356e-01, .783727e-01, .784097e-01, .784468e-01, .784839e-01, .785209e-01, .785579e-01, &
.785950e-01,.786320e-01, .786691e-01, .787061e-01, .787431e-01, .787801e-01, .788171e-01, .788540e-01, .788910e-01, .789280e-01, &
.789649e-01,.790019e-01, .790389e-01, .790758e-01, .791127e-01, .791497e-01, .791866e-01, .792235e-01, .792604e-01, .792973e-01, &
.793342e-01,.793710e-01, .794079e-01, .794448e-01, .794817e-01, .795185e-01, .795553e-01, .795922e-01, .796291e-01, .796658e-01, &
.797027e-01,.797395e-01, .797763e-01, .798131e-01, .798498e-01, .798866e-01, .799234e-01, .799602e-01, .799969e-01, .800337e-01, &
.800704e-01,.801072e-01, .801439e-01, .801806e-01, .802174e-01, .802541e-01, .802907e-01, .803275e-01, .803641e-01, .804008e-01, &
.804375e-01,.804742e-01, .805108e-01, .805475e-01, .805841e-01, .806208e-01, .806574e-01, .806940e-01, .807306e-01, .807672e-01, &
.808038e-01,.808404e-01, .808770e-01, .809136e-01, .809502e-01, .809867e-01, .810233e-01, .810599e-01, .810964e-01, .811329e-01, &
.811694e-01,.812060e-01, .812425e-01, .812790e-01, .813155e-01, .813520e-01, .813885e-01, .814250e-01, .814614e-01, .814979e-01/
data aaa(1501:1750) / &
.815343e-01,.815708e-01, .816073e-01, .816437e-01, .816801e-01, .817165e-01, .817530e-01, .817894e-01, .818258e-01, .818622e-01, &
.818985e-01,.819349e-01, .819713e-01, .820076e-01, .820441e-01, .820804e-01, .821167e-01, .821531e-01, .821894e-01, .822257e-01, &
.822621e-01,.822983e-01, .823346e-01, .823709e-01, .824072e-01, .824435e-01, .824798e-01, .825161e-01, .825523e-01, .825886e-01, &
.826249e-01,.826611e-01, .826973e-01, .827335e-01, .827698e-01, .828060e-01, .828422e-01, .828784e-01, .829146e-01, .829508e-01, &
.829869e-01,.830231e-01, .830593e-01, .830954e-01, .831316e-01, .831677e-01, .832039e-01, .832400e-01, .832761e-01, .833122e-01, &
.833483e-01,.833844e-01, .834205e-01, .834566e-01, .834927e-01, .835288e-01, .835648e-01, .836009e-01, .836369e-01, .836729e-01, &
.837090e-01,.837451e-01, .837811e-01, .838171e-01, .838531e-01, .838891e-01, .839251e-01, .839611e-01, .839971e-01, .840331e-01, &
.840691e-01,.841050e-01, .841410e-01, .841769e-01, .842128e-01, .842488e-01, .842847e-01, .843206e-01, .843565e-01, .843925e-01, &
.844284e-01,.844643e-01, .845001e-01, .845360e-01, .845719e-01, .846078e-01, .846436e-01, .846795e-01, .847153e-01, .847511e-01, &
.847870e-01,.848228e-01, .848587e-01, .848944e-01, .849302e-01, .849661e-01, .850019e-01, .850376e-01, .850734e-01, .851092e-01, &
.851449e-01,.851807e-01, .852165e-01, .852522e-01, .852880e-01, .853237e-01, .853594e-01, .853952e-01, .854308e-01, .854666e-01, &
.855022e-01,.855379e-01, .855736e-01, .856093e-01, .856450e-01, .856806e-01, .857163e-01, .857520e-01, .857876e-01, .858232e-01, &
.858589e-01,.858944e-01, .859300e-01, .859657e-01, .860013e-01, .860369e-01, .860725e-01, .861081e-01, .861436e-01, .861793e-01, &
.862148e-01,.862503e-01, .862858e-01, .863214e-01, .863569e-01, .863925e-01, .864280e-01, .864635e-01, .864990e-01, .865346e-01, &
.865700e-01,.866055e-01, .866410e-01, .866765e-01, .867119e-01, .867474e-01, .867829e-01, .868183e-01, .868537e-01, .868892e-01, &
.869246e-01,.869600e-01, .869955e-01, .870309e-01, .870663e-01, .871017e-01, .871371e-01, .871724e-01, .872078e-01, .872432e-01, &
.872785e-01,.873139e-01, .873492e-01, .873846e-01, .874199e-01, .874553e-01, .874906e-01, .875259e-01, .875612e-01, .875965e-01, &
.876318e-01,.876671e-01, .877024e-01, .877377e-01, .877730e-01, .878082e-01, .878435e-01, .878787e-01, .879140e-01, .879492e-01, &
.879844e-01,.880197e-01, .880548e-01, .880901e-01, .881253e-01, .881605e-01, .881957e-01, .882308e-01, .882660e-01, .883012e-01, &
.883363e-01,.883715e-01, .884067e-01, .884418e-01, .884769e-01, .885121e-01, .885472e-01, .885823e-01, .886174e-01, .886526e-01, &
.886876e-01,.887228e-01, .887578e-01, .887929e-01, .888280e-01, .888630e-01, .888981e-01, .889331e-01, .889682e-01, .890033e-01, &
.890383e-01,.890734e-01, .891083e-01, .891433e-01, .891783e-01, .892133e-01, .892484e-01, .892833e-01, .893183e-01, .893533e-01, &
.893883e-01,.894232e-01, .894582e-01, .894932e-01, .895281e-01, .895630e-01, .895980e-01, .896329e-01, .896678e-01, .897027e-01, &
.897377e-01,.897725e-01, .898074e-01, .898423e-01, .898772e-01, .899120e-01, .899469e-01, .899817e-01, .900166e-01, .900515e-01, &
.900863e-01,.901212e-01, .901560e-01, .901908e-01, .902256e-01, .902604e-01, .902953e-01, .903300e-01, .903649e-01, .903996e-01/
data aaa(1751:2000) / &
.904344e-01,.904691e-01, .905039e-01, .905386e-01, .905734e-01, .906082e-01, .906429e-01, .906776e-01, .907124e-01, .907471e-01, &
.907817e-01,.908166e-01, .908512e-01, .908859e-01, .909206e-01, .909553e-01, .909899e-01, .910246e-01, .910593e-01, .910940e-01, &
.911286e-01,.911632e-01, .911978e-01, .912325e-01, .912671e-01, .913017e-01, .913363e-01, .913709e-01, .914056e-01, .914401e-01, &
.914747e-01,.915093e-01, .915439e-01, .915785e-01, .916131e-01, .916476e-01, .916821e-01, .917166e-01, .917512e-01, .917857e-01, &
.918202e-01,.918547e-01, .918892e-01, .919237e-01, .919582e-01, .919927e-01, .920272e-01, .920618e-01, .920962e-01, .921307e-01, &
.921651e-01,.921996e-01, .922340e-01, .922685e-01, .923029e-01, .923374e-01, .923718e-01, .924062e-01, .924405e-01, .924750e-01, &
.925094e-01,.925437e-01, .925781e-01, .926125e-01, .926468e-01, .926812e-01, .927156e-01, .927500e-01, .927843e-01, .928186e-01, &
.928530e-01,.928873e-01, .929216e-01, .929560e-01, .929903e-01, .930246e-01, .930589e-01, .930932e-01, .931274e-01, .931617e-01, &
.931960e-01,.932303e-01, .932645e-01, .932988e-01, .933330e-01, .933673e-01, .934015e-01, .934358e-01, .934700e-01, .935041e-01, &
.935383e-01,.935725e-01, .936068e-01, .936410e-01, .936751e-01, .937093e-01, .937435e-01, .937777e-01, .938119e-01, .938460e-01, &
.938802e-01,.939143e-01, .939484e-01, .939826e-01, .940166e-01, .940508e-01, .940849e-01, .941190e-01, .941530e-01, .941872e-01, &
.942213e-01,.942553e-01, .942894e-01, .943235e-01, .943576e-01, .943916e-01, .944257e-01, .944597e-01, .944937e-01, .945278e-01, &
.945619e-01,.945958e-01, .946298e-01, .946639e-01, .946979e-01, .947319e-01, .947658e-01, .947998e-01, .948338e-01, .948678e-01, &
.949017e-01,.949357e-01, .949696e-01, .950036e-01, .950375e-01, .950714e-01, .951054e-01, .951393e-01, .951732e-01, .952071e-01, &
.952410e-01,.952749e-01, .953088e-01, .953427e-01, .953766e-01, .954104e-01, .954443e-01, .954782e-01, .955120e-01, .955459e-01, &
.955797e-01,.956136e-01, .956474e-01, .956811e-01, .957150e-01, .957488e-01, .957826e-01, .958164e-01, .958502e-01, .958840e-01, &
.959178e-01,.959516e-01, .959853e-01, .960191e-01, .960529e-01, .960866e-01, .961204e-01, .961542e-01, .961878e-01, .962216e-01, &
.962552e-01,.962890e-01, .963227e-01, .963563e-01, .963901e-01, .964238e-01, .964575e-01, .964912e-01, .965248e-01, .965585e-01, &
.965922e-01,.966259e-01, .966595e-01, .966931e-01, .967268e-01, .967604e-01, .967939e-01, .968276e-01, .968612e-01, .968948e-01, &
.969285e-01,.969620e-01, .969956e-01, .970292e-01, .970628e-01, .970963e-01, .971299e-01, .971635e-01, .971970e-01, .972306e-01, &
.972641e-01,.972976e-01, .973312e-01, .973647e-01, .973982e-01, .974318e-01, .974652e-01, .974987e-01, .975323e-01, .975657e-01, &
.975992e-01,.976328e-01, .976661e-01, .976996e-01, .977330e-01, .977665e-01, .978000e-01, .978333e-01, .978668e-01, .979003e-01, &
.979337e-01,.979671e-01, .980005e-01, .980339e-01, .980673e-01, .981007e-01, .981341e-01, .981675e-01, .982009e-01, .982342e-01, &
.982676e-01,.983009e-01, .983343e-01, .983676e-01, .984010e-01, .984343e-01, .984676e-01, .985010e-01, .985343e-01, .985676e-01, &
.986009e-01,.986342e-01, .986674e-01, .987008e-01, .987340e-01, .987673e-01, .988005e-01, .988338e-01, .988671e-01, .989004e-01/

data aab(1:250) / &
.826595e-05,.160784e-02, .206878e-02, .238043e-02, .262262e-02, .282348e-02, .299653e-02, .314943e-02, .328694e-02, .341229e-02, &
.352772e-02,.363492e-02, .373514e-02, .382936e-02, .391836e-02, .400278e-02, .408314e-02, .415986e-02, .423332e-02, .430382e-02, &
.437162e-02,.443697e-02, .450005e-02, .456104e-02, .462010e-02, .467737e-02, .473297e-02, .478701e-02, .483960e-02, .489080e-02, &
.494072e-02,.498942e-02, .503698e-02, .508344e-02, .512888e-02, .517334e-02, .521687e-02, .525951e-02, .530131e-02, .534230e-02, &
.538252e-02,.542200e-02, .546079e-02, .549889e-02, .553634e-02, .557317e-02, .560940e-02, .564504e-02, .568014e-02, .571469e-02, &
.574872e-02,.578227e-02, .581532e-02, .584791e-02, .588004e-02, .591175e-02, .594302e-02, .597388e-02, .600435e-02, .603443e-02, &
.606414e-02,.609348e-02, .612246e-02, .615111e-02, .617942e-02, .620740e-02, .623506e-02, .626243e-02, .628948e-02, .631625e-02, &
.634273e-02,.636893e-02, .639486e-02, .642053e-02, .644593e-02, .647109e-02, .649599e-02, .652066e-02, .654509e-02, .656928e-02, &
.659326e-02,.661701e-02, .664055e-02, .666387e-02, .668699e-02, .670990e-02, .673262e-02, .675514e-02, .677748e-02, .679962e-02, &
.682157e-02,.684335e-02, .686496e-02, .688639e-02, .690766e-02, .692875e-02, .694968e-02, .697045e-02, .699107e-02, .701152e-02, &
.703183e-02,.705198e-02, .707199e-02, .709185e-02, .711158e-02, .713116e-02, .715061e-02, .716991e-02, .718909e-02, .720814e-02, &
.722705e-02,.724584e-02, .726451e-02, .728305e-02, .730147e-02, .731977e-02, .733796e-02, .735603e-02, .737398e-02, .739182e-02, &
.740955e-02,.742718e-02, .744469e-02, .746210e-02, .747941e-02, .749660e-02, .751371e-02, .753071e-02, .754761e-02, .756441e-02, &
.758112e-02,.759774e-02, .761425e-02, .763068e-02, .764702e-02, .766326e-02, .767942e-02, .769550e-02, .771148e-02, .772738e-02, &
.774319e-02,.775891e-02, .777457e-02, .779013e-02, .780562e-02, .782102e-02, .783635e-02, .785161e-02, .786678e-02, .788188e-02, &
.789690e-02,.791185e-02, .792673e-02, .794153e-02, .795626e-02, .797093e-02, .798552e-02, .800005e-02, .801449e-02, .802889e-02, &
.804321e-02,.805746e-02, .807165e-02, .808578e-02, .809984e-02, .811384e-02, .812777e-02, .814164e-02, .815545e-02, .816921e-02, &
.818290e-02,.819652e-02, .821010e-02, .822362e-02, .823707e-02, .825047e-02, .826382e-02, .827711e-02, .829033e-02, .830352e-02, &
.831663e-02,.832971e-02, .834272e-02, .835568e-02, .836859e-02, .838145e-02, .839425e-02, .840701e-02, .841972e-02, .843237e-02, &
.844498e-02,.845753e-02, .847004e-02, .848250e-02, .849491e-02, .850729e-02, .851960e-02, .853188e-02, .854410e-02, .855628e-02, &
.856842e-02,.858051e-02, .859256e-02, .860456e-02, .861651e-02, .862843e-02, .864030e-02, .865213e-02, .866392e-02, .867568e-02, &
.868737e-02,.869904e-02, .871066e-02, .872224e-02, .873378e-02, .874529e-02, .875674e-02, .876817e-02, .877955e-02, .879090e-02, &
.880221e-02,.881347e-02, .882471e-02, .883590e-02, .884706e-02, .885818e-02, .886926e-02, .888031e-02, .889132e-02, .890229e-02, &
.891323e-02,.892415e-02, .893501e-02, .894585e-02, .895665e-02, .896742e-02, .897815e-02, .898885e-02, .899952e-02, .901015e-02, &
.902075e-02,.903132e-02, .904186e-02, .905236e-02, .906283e-02, .907327e-02, .908368e-02, .909406e-02, .910440e-02, .911472e-02/
data aab(251:500) / &
.912501e-02,.913526e-02, .914548e-02, .915568e-02, .916584e-02, .917597e-02, .918607e-02, .919615e-02, .920621e-02, .921622e-02, &
.922621e-02,.923617e-02, .924610e-02, .925601e-02, .926589e-02, .927574e-02, .928557e-02, .929535e-02, .930513e-02, .931486e-02, &
.932458e-02,.933426e-02, .934393e-02, .935357e-02, .936317e-02, .937276e-02, .938231e-02, .939184e-02, .940135e-02, .941084e-02, &
.942029e-02,.942972e-02, .943912e-02, .944850e-02, .945786e-02, .946719e-02, .947651e-02, .948579e-02, .949505e-02, .950428e-02, &
.951349e-02,.952269e-02, .953186e-02, .954099e-02, .955012e-02, .955921e-02, .956829e-02, .957735e-02, .958637e-02, .959538e-02, &
.960436e-02,.961332e-02, .962227e-02, .963118e-02, .964008e-02, .964896e-02, .965781e-02, .966665e-02, .967545e-02, .968424e-02, &
.969301e-02,.970176e-02, .971049e-02, .971919e-02, .972788e-02, .973655e-02, .974519e-02, .975381e-02, .976242e-02, .977100e-02, &
.977957e-02,.978811e-02, .979665e-02, .980514e-02, .981363e-02, .982210e-02, .983054e-02, .983897e-02, .984739e-02, .985578e-02, &
.986414e-02,.987250e-02, .988083e-02, .988915e-02, .989745e-02, .990573e-02, .991398e-02, .992223e-02, .993045e-02, .993866e-02, &
.994685e-02,.995502e-02, .996317e-02, .997130e-02, .997943e-02, .998752e-02, .999560e-02, .100037e-01, .100117e-01, .100197e-01, &
.100278e-01,.100358e-01, .100437e-01, .100517e-01, .100597e-01, .100676e-01, .100755e-01, .100834e-01, .100913e-01, .100992e-01, &
.101070e-01,.101148e-01, .101226e-01, .101304e-01, .101382e-01, .101460e-01, .101537e-01, .101615e-01, .101692e-01, .101769e-01, &
.101846e-01,.101923e-01, .101999e-01, .102076e-01, .102152e-01, .102228e-01, .102304e-01, .102380e-01, .102456e-01, .102531e-01, &
.102607e-01,.102682e-01, .102757e-01, .102832e-01, .102907e-01, .102982e-01, .103056e-01, .103131e-01, .103205e-01, .103279e-01, &
.103353e-01,.103427e-01, .103501e-01, .103574e-01, .103647e-01, .103721e-01, .103794e-01, .103867e-01, .103940e-01, .104012e-01, &
.104085e-01,.104158e-01, .104230e-01, .104302e-01, .104374e-01, .104446e-01, .104518e-01, .104590e-01, .104661e-01, .104732e-01, &
.104804e-01,.104875e-01, .104946e-01, .105017e-01, .105088e-01, .105158e-01, .105229e-01, .105299e-01, .105369e-01, .105440e-01, &
.105510e-01,.105579e-01, .105649e-01, .105719e-01, .105788e-01, .105858e-01, .105927e-01, .105996e-01, .106065e-01, .106134e-01, &
.106203e-01,.106272e-01, .106340e-01, .106409e-01, .106477e-01, .106545e-01, .106613e-01, .106681e-01, .106749e-01, .106817e-01, &
.106885e-01,.106952e-01, .107020e-01, .107087e-01, .107154e-01, .107221e-01, .107288e-01, .107355e-01, .107422e-01, .107488e-01, &
.107555e-01,.107621e-01, .107688e-01, .107754e-01, .107820e-01, .107886e-01, .107952e-01, .108018e-01, .108083e-01, .108149e-01, &
.108214e-01,.108280e-01, .108345e-01, .108410e-01, .108475e-01, .108540e-01, .108605e-01, .108670e-01, .108734e-01, .108799e-01, &
.108863e-01,.108927e-01, .108992e-01, .109056e-01, .109120e-01, .109184e-01, .109248e-01, .109311e-01, .109375e-01, .109438e-01, &
.109502e-01,.109565e-01, .109628e-01, .109692e-01, .109755e-01, .109817e-01, .109880e-01, .109943e-01, .110006e-01, .110068e-01, &
.110131e-01,.110193e-01, .110255e-01, .110318e-01, .110380e-01, .110442e-01, .110503e-01, .110565e-01, .110627e-01, .110689e-01/
data aab(501:750) / &
.110750e-01,.110812e-01, .110873e-01, .110934e-01, .110996e-01, .111057e-01, .111118e-01, .111178e-01, .111239e-01, .111300e-01, &
.111361e-01,.111421e-01, .111482e-01, .111542e-01, .111602e-01, .111663e-01, .111723e-01, .111783e-01, .111843e-01, .111902e-01, &
.111962e-01,.112022e-01, .112082e-01, .112141e-01, .112200e-01, .112260e-01, .112319e-01, .112378e-01, .112437e-01, .112496e-01, &
.112555e-01,.112614e-01, .112673e-01, .112732e-01, .112790e-01, .112849e-01, .112907e-01, .112966e-01, .113024e-01, .113082e-01, &
.113140e-01,.113198e-01, .113256e-01, .113314e-01, .113372e-01, .113430e-01, .113487e-01, .113545e-01, .113602e-01, .113660e-01, &
.113717e-01,.113774e-01, .113832e-01, .113889e-01, .113946e-01, .114003e-01, .114060e-01, .114116e-01, .114173e-01, .114230e-01, &
.114286e-01,.114343e-01, .114399e-01, .114456e-01, .114512e-01, .114568e-01, .114624e-01, .114680e-01, .114736e-01, .114792e-01, &
.114848e-01,.114904e-01, .114959e-01, .115015e-01, .115071e-01, .115126e-01, .115182e-01, .115237e-01, .115292e-01, .115347e-01, &
.115403e-01,.115458e-01, .115513e-01, .115567e-01, .115622e-01, .115677e-01, .115732e-01, .115787e-01, .115841e-01, .115896e-01, &
.115950e-01,.116004e-01, .116059e-01, .116113e-01, .116167e-01, .116221e-01, .116275e-01, .116329e-01, .116383e-01, .116437e-01, &
.116491e-01,.116544e-01, .116598e-01, .116651e-01, .116705e-01, .116758e-01, .116812e-01, .116865e-01, .116918e-01, .116971e-01, &
.117025e-01,.117078e-01, .117131e-01, .117184e-01, .117236e-01, .117289e-01, .117342e-01, .117395e-01, .117447e-01, .117500e-01, &
.117552e-01,.117605e-01, .117657e-01, .117709e-01, .117761e-01, .117814e-01, .117866e-01, .117918e-01, .117970e-01, .118022e-01, &
.118074e-01,.118125e-01, .118177e-01, .118229e-01, .118280e-01, .118332e-01, .118383e-01, .118435e-01, .118486e-01, .118537e-01, &
.118589e-01,.118640e-01, .118691e-01, .118742e-01, .118793e-01, .118844e-01, .118895e-01, .118946e-01, .118997e-01, .119047e-01, &
.119098e-01,.119149e-01, .119199e-01, .119250e-01, .119300e-01, .119350e-01, .119401e-01, .119451e-01, .119501e-01, .119551e-01, &
.119601e-01,.119652e-01, .119701e-01, .119751e-01, .119801e-01, .119851e-01, .119901e-01, .119951e-01, .120000e-01, .120050e-01, &
.120099e-01,.120149e-01, .120198e-01, .120248e-01, .120297e-01, .120346e-01, .120395e-01, .120445e-01, .120494e-01, .120543e-01, &
.120592e-01,.120641e-01, .120690e-01, .120738e-01, .120787e-01, .120836e-01, .120885e-01, .120933e-01, .120982e-01, .121030e-01, &
.121079e-01,.121127e-01, .121176e-01, .121224e-01, .121272e-01, .121320e-01, .121369e-01, .121417e-01, .121465e-01, .121513e-01, &
.121561e-01,.121609e-01, .121657e-01, .121705e-01, .121752e-01, .121800e-01, .121848e-01, .121895e-01, .121943e-01, .121990e-01, &
.122038e-01,.122085e-01, .122133e-01, .122180e-01, .122227e-01, .122274e-01, .122321e-01, .122368e-01, .122416e-01, .122463e-01, &
.122510e-01,.122557e-01, .122603e-01, .122650e-01, .122697e-01, .122744e-01, .122790e-01, .122837e-01, .122884e-01, .122930e-01, &
.122977e-01,.123023e-01, .123070e-01, .123116e-01, .123162e-01, .123208e-01, .123255e-01, .123301e-01, .123347e-01, .123393e-01, &
.123439e-01,.123485e-01, .123531e-01, .123577e-01, .123623e-01, .123668e-01, .123714e-01, .123760e-01, .123806e-01, .123851e-01/
data aab(751:1000) / &
.123897e-01,.123942e-01, .123988e-01, .124033e-01, .124079e-01, .124124e-01, .124169e-01, .124215e-01, .124260e-01, .124305e-01, &
.124350e-01,.124395e-01, .124440e-01, .124485e-01, .124530e-01, .124575e-01, .124620e-01, .124665e-01, .124710e-01, .124754e-01, &
.124799e-01,.124844e-01, .124888e-01, .124933e-01, .124977e-01, .125022e-01, .125066e-01, .125111e-01, .125155e-01, .125199e-01, &
.125244e-01,.125288e-01, .125332e-01, .125376e-01, .125420e-01, .125464e-01, .125508e-01, .125552e-01, .125596e-01, .125640e-01, &
.125684e-01,.125728e-01, .125772e-01, .125815e-01, .125859e-01, .125903e-01, .125946e-01, .125990e-01, .126033e-01, .126077e-01, &
.126120e-01,.126164e-01, .126207e-01, .126250e-01, .126294e-01, .126337e-01, .126380e-01, .126423e-01, .126466e-01, .126510e-01, &
.126553e-01,.126596e-01, .126639e-01, .126681e-01, .126724e-01, .126767e-01, .126810e-01, .126853e-01, .126896e-01, .126938e-01, &
.126981e-01,.127023e-01, .127066e-01, .127109e-01, .127151e-01, .127194e-01, .127236e-01, .127278e-01, .127321e-01, .127363e-01, &
.127405e-01,.127448e-01, .127490e-01, .127532e-01, .127574e-01, .127616e-01, .127658e-01, .127700e-01, .127742e-01, .127784e-01, &
.127826e-01,.127868e-01, .127910e-01, .127952e-01, .127993e-01, .128035e-01, .128077e-01, .128118e-01, .128160e-01, .128202e-01, &
.128243e-01,.128285e-01, .128326e-01, .128367e-01, .128409e-01, .128450e-01, .128492e-01, .128533e-01, .128574e-01, .128615e-01, &
.128656e-01,.128698e-01, .128739e-01, .128780e-01, .128821e-01, .128862e-01, .128903e-01, .128944e-01, .128985e-01, .129026e-01, &
.129066e-01,.129107e-01, .129148e-01, .129189e-01, .129229e-01, .129270e-01, .129311e-01, .129351e-01, .129392e-01, .129432e-01, &
.129473e-01,.129513e-01, .129554e-01, .129594e-01, .129634e-01, .129675e-01, .129715e-01, .129755e-01, .129795e-01, .129836e-01, &
.129876e-01,.129916e-01, .129956e-01, .129996e-01, .130036e-01, .130076e-01, .130116e-01, .130156e-01, .130196e-01, .130236e-01, &
.130275e-01,.130315e-01, .130355e-01, .130395e-01, .130434e-01, .130474e-01, .130514e-01, .130553e-01, .130593e-01, .130632e-01, &
.130672e-01,.130711e-01, .130751e-01, .130790e-01, .130830e-01, .130869e-01, .130908e-01, .130947e-01, .130987e-01, .131026e-01, &
.131065e-01,.131104e-01, .131143e-01, .131182e-01, .131221e-01, .131260e-01, .131299e-01, .131338e-01, .131377e-01, .131416e-01, &
.131455e-01,.131494e-01, .131533e-01, .131571e-01, .131610e-01, .131649e-01, .131688e-01, .131726e-01, .131765e-01, .131803e-01, &
.131842e-01,.131880e-01, .131919e-01, .131957e-01, .131996e-01, .132034e-01, .132073e-01, .132111e-01, .132149e-01, .132188e-01, &
.132226e-01,.132264e-01, .132302e-01, .132340e-01, .132379e-01, .132417e-01, .132455e-01, .132493e-01, .132531e-01, .132569e-01, &
.132607e-01,.132645e-01, .132683e-01, .132721e-01, .132758e-01, .132796e-01, .132834e-01, .132872e-01, .132909e-01, .132947e-01, &
.132985e-01,.133022e-01, .133060e-01, .133098e-01, .133135e-01, .133173e-01, .133210e-01, .133248e-01, .133285e-01, .133322e-01, &
.133360e-01,.133397e-01, .133434e-01, .133472e-01, .133509e-01, .133546e-01, .133584e-01, .133621e-01, .133658e-01, .133695e-01, &
.133732e-01,.133769e-01, .133806e-01, .133843e-01, .133880e-01, .133917e-01, .133954e-01, .133991e-01, .134028e-01, .134065e-01/

end module mcm_swtbls_mod


      MODULE MCM_SW_DRIVER_MOD
!
!
!   TK modified from Kerr code 
!     /t90/tk/climatemodel/r30/atm_leg1/atm5a/atmlib_mods/no_ifdefs
!
!   Added interface routine (mcm_shortwave_driver) which is called by
!     fsrad and which calls mcm_swnew in this
!     module after constructing the appropriate inputs.
!
!   TK mod (6/01/01) added test to make sure CosZ is greater than
!     zero, otherwise skip sw calculation and set output to zero
!     for that point...
!!
!
!

!      USE   Constants_Mod, ONLY: grav, tfreeze

      Use       Fms_Mod, ONLY: Error_Mesg, FATAL, &
                               write_version_number, mpp_pe, mpp_root_pe

      use mcm_swnew_mod, only: mcm_swnew

implicit none
      private

      integer :: kx, kp
      character(len=128) :: version = '$Id: mcm_sw_driver.F90,v 10.0 2003/10/24 22:00:31 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical :: module_is_initialized = .false.

      public :: mcm_shortwave_driver, mcm_sw_driver_init, &
                mcm_sw_driver_end

!     -------------------------------------------------
! TK NOTE: not ready for this yet...      implicit none




contains

      subroutine mcm_shortwave_driver(                                 &
                     Nclds, KtopSW, KbtmSW, Press, Rh2o, Qo3, CldAmt, &
                     CUVRF, CIRRF, CIRAB, Rco2, CosZ, SSolar,         &
                     Albedo, FSW, DFSW, UFSW, TdtSW, Phalf)


!     TK Original calling parameters in Kerr code:
!     &     ccosz, ttauda, rco2, solc, p, pp, qmh,
!     &     etabl, gvbrps, gqmix, grad, slwdp, rclim, dduo3n, r, 
!     &     flx, heat,
!     &     radian, radang,
!     &     zsnit, zsnitc, zsng, zsngc, zplalb, zplalbc, icf,
!
!     &     q, calb, iflg, ncv,
!
!     &     ipower, kflags,
!
!     &     tfra, alb, ts, zin, ca, oas,
!     &     snwdpt,
!     &     pkice,
!
!     &     kp, kx, ng, lx, nc, il, ix, jrow, iy, ls, ih, nhem)


      integer, intent (in), dimension(:,:)     :: Nclds
      integer, intent (in), dimension(:,:,:)      :: KtopSW, KbtmSW
      real, intent (in)   , dimension(:,:,:)      :: Press, Phalf
      real, intent (in)   , dimension(:,:,:)      :: CldAmt, CUVRF,&
                                                  &  CIRRF, CIRAB
      real, intent (in)   , dimension(:,:,:)      :: Rh2o, Qo3

      real, intent (in)                           :: Rco2
      real, intent (in)   , dimension(:,:)        :: CosZ
      real, intent (in)   , dimension(:,:)        :: SSolar
      real, intent (in)   , dimension(:,:)        :: Albedo

      REAL,   INTENT(OUT), DIMENSION(:,:,:)       :: FSW, DFSW, UFSW
      REAL,   INTENT(OUT), DIMENSION(:,:,:)       :: TdtSW


!----------------LOCAL ARRAY STORAGE------------------------------------

      INTEGER, DIMENSION(kx+2)   :: kthsw, kbhsw
      REAL,    DIMENSION(kx+2)   :: cwca, cwcb, coca, cloudy
      REAL,    DIMENSION(kx+1)   :: flx, heat, UF, DF
      REAL                       :: grdflx
      real,   dimension(0:kx)   :: pp
      real,   dimension(1:kx+1) :: pr2
      real,   dimension(size(press,1), size(press,2), kx) :: sigma_level

      integer ncv
      real pchg

      INTEGER :: ix, jx
      integer :: ipt, jrow, k

      if(.not.module_is_initialized) then
        call error_mesg('mcm_shortwave_driver', &
                        'shortwave_driver_mod is not initialized',FATAL)
      endif

      ix = SIZE(Press,1)
      jx = SIZE(Press,2)

!     Compute sigma levels, which are needed for an mcm_swnew routine input:
      do k=1,kx
        sigma_level(:,:,k) = Press(:,:,k) / Phalf(:,:,kp)
      enddo

!     Loop over all points in the horizontal array, computing
!       radiation for one column at a time in mcm_swnew...

      do jrow = 1, jx

         do ipt = 1, ix

!           Create necessary column input arrays for mcm_swnew routine:

            do k = 1, kp

               kthsw (k) = KtopSW (ipt,jrow,k)
               kbhsw (k) = KbtmSW (ipt,jrow,k)

               cwca (k) = CIRRF (ipt,jrow,k)
               cwcb (k) = CIRAB (ipt,jrow,k)
               coca (k) = CUVRF (ipt,jrow,k)
               cloudy(k) = CldAmt (ipt,jrow,k)

            end do

            ncv = Nclds(ipt,jrow) + 2

!           Load surface albedo into 2 input arrays in location ncv:
            cwca (ncv) = Albedo (ipt,jrow)           
            coca (ncv) = Albedo (ipt,jrow) 

!           Set ncv element of cloudy to 1.0 to match supersource:
            cloudy(ncv) = 1.0

!           Also initialize ncv+1 element of the cloud arrays (not
!            sure if this is actually done in SS but trying to
!            match the input arrays for the sample point -- TK):

            cwca (ncv+1) = Albedo (ipt,jrow)           
            coca (ncv+1) = Albedo (ipt,jrow) 
            cloudy(ncv+1) = 1.0
            cwcb(ncv+1) = 0.0

!          Initialize element 1 of the following arrays exactly as
!           in supersource:

            kbhsw (  1) = 1
            cwca  (  1) = 0.0
            cwcb  (  1) = 0.0
            coca  (  1) = 0.0
            cloudy(  1) = 0.0


!           Compute pp, pr2 input arrays for mcm_swnew:

            do k = 0, kx
               pp(k) = Phalf(ipt,jrow,k+1) * 10
            end do

            pchg = sqrt (Phalf(ipt,jrow,kp)/101325.0)
            do k = 1, kx
               pr2(k) = sqrt(sigma_level(ipt,jrow,k)) * pchg
            end do  

!!           TK Print diagnostics for auxilary inputs:
!            if ((ipt .eq. 49) .and. (jrow .eq. 27)) then
!               print *
!               print *, 'TK chkpt 1 in mcm_sw_mod.F.i=49,j= ', jrow
!               print *
!               print *, ' Cosz (FMS computed) = ', Cosz(ipt,jrow)
!
!               print *, ' rco2 = ', rco2
!               print *, ' rh2o = ', Rh2o(ipt,jrow,:)
!               print *, ' ro3 = ', Qo3(ipt,jrow,:)
!               print *, ' pp[0:kx] = ', pp
!               print *, ' Ssolar (calculated) = ', Ssolar(ipt,jrow)
!               print *, ' pr2[1:kx+1] = ', pr2
!               print *, ' kx = ', kx
!               print *
!               print *, ' Cloud data for shortwave: '
!               print *, '      (use only k = 2 to nc1 for clouds)'
!               print *, '      (use k = ncv for surface albedo)'
!               print *, ' ncv = ', ncv  
!               print *, ' k cloudy kthsw kbhsw      cwca ',       &
!     &             '             cwcb               coca    '
!               print *
!               do 325 k = 1, kx
!                  write(6,323) k, cloudy(k), kthsw(k), kbhsw(k),  &
!     &               cwca(k), cwcb(k), coca(k)
!323               format (i3, 2x, f4.2, 2x, i3, 2x, i3, 3(2x, e15.6))
!325            continue
!               print *
!               do k = 0, kx
!                  print *, ' k, pp(k) = ', k, pp(k)
!               end do
!               do k = 1, kx
!                  print *, ' k, pr2(k) = ', k, pr2(k)
!               end do
!               print *
!            end if

!         Only call shortwave routine if CosZ is greater than 0.0

            if (CosZ(ipt,jrow) > 0.0) then       

               call mcm_swnew (CosZ(ipt,jrow),                &
                 rco2, Rh2o(ipt,jrow,:), Qo3(ipt,jrow,:), pp, &
                 cwca, cwcb, coca, cloudy, kthsw, kbhsw,      &
                 Ssolar(ipt,jrow), pr2,                       &
                 flx, heat, grdflx, ncv, kx, UF, DF)

!              Fill the appropriate output arrays with the column output:

               do k = 1, kp
                  FSW(ipt,jrow,k) = flx(k)
                  DFSW(ipt,jrow,k) = DF(k)
                  UFSW(ipt,jrow,k) = UF(k)
               end do

               do k = 1, kx
                  TdtSw(ipt,jrow,k) = heat(k)
               end do

            else
!              CosZ is  0.0, so zero sw output arrays at that point:
                  
               do k = 1, kp
                  FSW(ipt,jrow,k) = 0.
                  DFSW(ipt,jrow,k) = 0.
                  UFSW(ipt,jrow,k) = 0.
               end do

               do k = 1, kx
                  TdtSw(ipt,jrow,k) = 0.
               end do

            end if

!!           TK Print diagnostics:
!            if ((ipt .eq. 49) .and. (jrow .eq. 27)) then
!               print *
!               print *, ' mcm_swnew output arrays, etc: '
!               print *
!               print *, ' k      flx (ergs/cm2/sec)      heat (K/day) '
!               do 328 k = 1, kx+1
!                  write(6,327) k, flx(k), heat(k)
!327               format (i3, 7x, f14.6, 3x, f15.9)
!328            continue
!               print *
!               print *, ' grdflx [ergs/cm2/sec] = ', grdflx
!               print *
!            end if

         end do
      end do

      end subroutine mcm_shortwave_driver
! ---------------------------------------------------------------------------------------
      subroutine mcm_sw_driver_init(kx_in)
      integer, intent(in) :: kx_in

      kx = kx_in
      kp = kx + 1
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

      return
      end subroutine mcm_sw_driver_init
! ---------------------------------------------------------------------------------------

      subroutine mcm_sw_driver_end

      module_is_initialized = .false.
!---------------------------------------------------------------------

      end subroutine mcm_sw_driver_end
! ---------------------------------------------------------------------------------------
      end module MCM_SW_DRIVER_MOD



                     MODULE RAD_DIAG_MOD

!-----------------------------------------------------------------------

!!!   USE   RDPARM_MOD, ONLY:  IMAX, LMAX, LP1, NBLW, NBLY, NBLM
      USE   RDPARM_MOD, ONLY:  LMAX, LP1, NBLW, NBLY, NBLM

      USE   HCONST_MOD, ONLY:  RADCON, RADCON1

      USE LONGWAVE_MOD, ONLY: OSOUR, CSOUR, SS1
      USE LONGWAVE_MOD, ONLY: FLX1E1, GXCTS, FCTSG
      USE LONGWAVE_MOD, ONLY: CLDFAC
      USE LONGWAVE_MOD, ONLY: DELP2, DELP
      USE LONGWAVE_MOD, ONLY: TO3, CO21, EMISS, EMISS2, CTS, EXCTS,  &
                              EXCTSN, E1FLX, CO2SP
      USE LONGWAVE_MOD, ONLY: IBAND, BANDLO, BANDHI

      Use       Fms_Mod, ONLY: write_version_number, mpp_pe, mpp_root_pe, &
                               error_mesg, FATAL


implicit none
private

!-----------------------------------------------------------------------
      character(len=128) :: version = '$Id: rad_diag.F90,v 10.0 2003/10/24 22:00:32 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical            :: module_is_initialized = .false.

public RADIAG, RAD_DIAG_init, RAD_DIAG_end


      CONTAINS

!#######################################################################
!#######################################################################

      SUBROUTINE RADIAG  &
          ( PRESS,TEMP,RH2O,RRVCO2,QO3,CAMT,KTOP,KBTM,NCLDS,  &
            HEATRA,GRNFLX,  &
            FSW,DFSW,UFSW,HSW,  &
            KTOPSW,KBTMSW,EMCLD,CUVRF,CIRRF,CIRAB,  &
            SALB,COSZRO,SSOLAR,   ip,jp)

!-----------------------------------------------------------------------
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: PRESS,TEMP,RH2O
      REAL,    INTENT(IN)                   :: RRVCO2
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: QO3,CAMT
      INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:,:)   :: NCLDS

      REAL,    INTENT(IN), DIMENSION(:,:,:) :: HEATRA
      REAL,    INTENT(IN), DIMENSION(:,:)   :: GRNFLX

      REAL,    INTENT(IN), DIMENSION(:,:,:) :: FSW,DFSW,UFSW,HSW

      INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOPSW,KBTMSW
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: EMCLD,CUVRF,CIRRF,CIRAB

      REAL,    INTENT(IN), DIMENSION(:,:)   :: SALB,COSZRO,SSOLAR
      INTEGER, INTENT(IN)                 :: ip,jp
!-----------------------------------------------------------------------

      CALL RADPRT (PRESS(ip,jp,:),TEMP(ip,jp,:),RH2O(ip,jp,:),RRVCO2,QO3(ip,jp,:), &
                   CAMT(ip,jp,:),KTOP(ip,jp,:),KBTM(ip,jp,:),NCLDS(ip,jp),         &
                   HEATRA(ip,jp,:),GRNFLX(ip,jp),  &
                   CTS(ip,:),EXCTS(ip,:),    &
                   EMISS(ip,:,:),CLDFAC(ip,:,:),E1FLX(ip,:),        &
                   DELP(ip,:),DELP2(ip,:),EMISS2(ip,:,:),           &
                   SS1(ip,:),TO3(ip,:,:),OSOUR(ip,:),CO21(ip,:,:),  &
                   CSOUR(ip,:),CO2SP(ip,:),     &
                   GXCTS(ip),FLX1E1(ip),        &
                   FCTSG(ip,:),EXCTSN(ip,:,:),  &
                   FSW(ip,jp,:),DFSW(ip,jp,:),UFSW(ip,jp,:),HSW(ip,jp,:),  &
                   KTOPSW(ip,jp,:),KBTMSW(ip,jp,:),EMCLD(ip,jp,:),      &
                   CUVRF(ip,jp,:),CIRRF(ip,jp,:),CIRAB(ip,jp,:),        &
                   SALB(ip,jp),COSZRO(ip,jp),SSOLAR(ip,jp),   ip,jp)

!-----------------------------------------------------------------------

      END SUBROUTINE RADIAG

!#######################################################################
!#######################################################################

      subroutine RAD_DIAG_init
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      end subroutine RAD_DIAG_init

!#######################################################################
!#######################################################################

      subroutine RAD_DIAG_end

      module_is_initialized = .false.

!---------------------------------------------------------------------

      end subroutine RAD_DIAG_end
!#######################################################################
!#######################################################################

      SUBROUTINE RADPRT (PRESS,TEMP,RH2O,RRVCO2,QO3,  &
                         CAMT,KTOP,KBTM,NCLDS,        &
                         HEATRA,GRNFLX,  &
                         CTS,EXCTS,      &
                         EMISS,CLDFAC,E1FLX,DELP,DELP2,          &
                         EMISS2,SS1,TO3,OSOUR,CO21,CSOUR,CO2SP,  &
                         GXCTS,FLX1E1,       &
                         FCTSG,EXCTSN,       &
                         FSW,DFSW,UFSW,HSW,  &
                         KTOPSW,KBTMSW,EMCLD,CUVRF,CIRRF,CIRAB,  &
                         SALB,COSZRO,SSOLAR,              &
                         IP,JP)

      IMPLICIT NONE
!-----------------------------------------------------------------------
!      Subroutine RADPRT prints out all diagnostic quantities
!      required for diagnosos of radiation quantities.
!-----------------------------------------------------------------------
      REAL,    INTENT(IN), DIMENSION(:) :: PRESS,TEMP,RH2O
      REAL,    INTENT(IN)               :: RRVCO2
      REAL,    INTENT(IN), DIMENSION(:) :: QO3,CAMT
      INTEGER, INTENT(IN), DIMENSION(:) :: KTOP,KBTM
      INTEGER, INTENT(IN)               :: NCLDS

      REAL,    INTENT(IN), DIMENSION(:) :: HEATRA
      REAL,    INTENT(IN)               :: GRNFLX

      REAL,    INTENT(IN), DIMENSION(:)   :: CTS,EXCTS,E1FLX,DELP,DELP2
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMISS,CLDFAC,EMISS2,TO3
      REAL,    INTENT(IN), DIMENSION(:,:) :: CO21
      REAL,    INTENT(IN), DIMENSION(:)   :: SS1,OSOUR,CSOUR,CO2SP

      REAL,    INTENT(IN)                 :: GXCTS,FLX1E1
      REAL,    INTENT(INOUT), DIMENSION(:)   :: FCTSG
      REAL,    INTENT(INOUT), DIMENSION(:,:) :: EXCTSN

      REAL,    INTENT(IN), DIMENSION(:) :: FSW,DFSW,UFSW,HSW

      INTEGER, INTENT(IN), DIMENSION(:) :: KTOPSW,KBTMSW
      REAL,    INTENT(IN), DIMENSION(:) :: EMCLD,CUVRF,CIRRF,CIRAB

      REAL,    INTENT(IN)                 :: SALB,COSZRO,SSOLAR
      INTEGER, INTENT(IN)                 :: IP,JP
!-----------------------------------------------------------------------
!    ----- DIMENSION FOR LOCAL VARIABLES -----

      REAL  VSUM1(LP1),SUM(LP1),FLXDG(LP1),HTEM(LMAX),HTEM1(LMAX),  &
            HTEM2(LMAX),HTEM3(LMAX),HTEM4(LMAX),FLXNET(LP1),  &
            FTOPN(NBLY),FTOPAC(NBLY),VSUMAC(NBLY),PFLUX(LP1),  &
            CTS1(LMAX),CTS2(LMAX),CTST(LMAX),  &
            OSS(LP1),CSS(LP1),TC(LP1),DTC(LP1),SS2(LP1),  &
            HLWSW(LMAX),FLWSW(LP1),  &
            FSWD(LP1),DFSWD(LP1),UFSWD(LP1)
!-----------------------------------------------------------------------
      INTEGER  K,KP,N,NX,NY,NPRT
      REAL     FTOPC,FTOPE,FTOP,FGRD,FDIFF,SOLARW,QSUM
!-----------------------------------------------------------------------
!****COMPUTE LOCAL VARIABLES TC,DTC,OSS,CSS,SS2

      DO K=1,LP1
         TC(K)=TEMP(K)*TEMP(K)*TEMP(K)*TEMP(K)
      ENDDO

      DO K=2,LP1
         DTC(K)=TC(K)-TC(K-1)
         SS2(K)=SS1(K)-SS1(K-1)
         CSS(K)=CSOUR(K)-CSOUR(K-1)
         OSS(K)=OSOUR(K)-OSOUR(K-1)
      ENDDO

!***HTEM1 = EMISSIVITY HEATING RATE FOR 0-160,1200-2200 CM-1 BAND

      DO K=1,LP1
         SUM(K)=0.
         DO KP=1,LMAX
            VSUM1(KP)=DTC(KP+1)*EMISS(KP+1,K)*CLDFAC(KP+1,K)
         ENDDO
         DO KP=1,LMAX
            SUM(K)=SUM(K)+VSUM1(KP)
         ENDDO
      ENDDO

      DO K=1,LP1
         FLXDG(K)=SUM(K)+TC(1)*E1FLX(K)*CLDFAC(K,1)
      ENDDO

      DO K=1,LMAX
         HTEM1(K)=RADCON*(FLXDG(K+1)-FLXDG(K))*DELP(K)
      ENDDO

!***HTEM2 = EMISSIVITY HEATING RATE FOR 800-990,1070-1200 CM-1 BAND

      DO K=1,LP1
         SUM(K)=0.
         DO KP=1,LMAX
            VSUM1(KP)=SS2(KP+1)*EMISS2(KP+1,K)*CLDFAC(KP+1,K)
         ENDDO
         DO KP=1,LMAX
            SUM(K)=SUM(K)+VSUM1(KP)
         ENDDO
      ENDDO

      DO K=1,LP1
         FLXDG(K)=SUM(K)+SS1(1)*EMISS2(K,1)*CLDFAC(K,1)
      ENDDO

      DO K=1,LMAX
         HTEM2(K)=RADCON*(FLXDG(K+1)-FLXDG(K))*DELP(K)
      ENDDO

!***HTEM3 = EMISSIVITY HEATING RATE FOR 990-1070 CM-1 BAND

      DO K=1,LP1
         SUM(K)=0.
         DO KP=1,LMAX
            VSUM1(KP)=OSS(KP+1)*TO3(KP+1,K)*CLDFAC(KP+1,K)
         ENDDO
         DO KP=1,LMAX
            SUM(K)=SUM(K)+VSUM1(KP)
         ENDDO
      ENDDO

      DO K=1,LP1
         FLXDG(K)=SUM(K)+OSOUR(1)*TO3(K,1)*CLDFAC(K,1)
      ENDDO

      DO K=1,LMAX
         HTEM3(K)=RADCON*(FLXDG(K+1)-FLXDG(K))*DELP(K)
      ENDDO

!***HTEM4 = EMISSIVITY HEATING RATE FOR 560-800 CM-1 BAND

      DO K=1,LP1
         SUM(K)=0.
         DO KP=1,LMAX
            VSUM1(KP)=CSS(KP+1)*CO21(KP+1,K)*CLDFAC(KP+1,K)
         ENDDO
         DO KP=1,LMAX
            SUM(K)=SUM(K)+VSUM1(KP)
         ENDDO
      ENDDO

      DO K=1,LP1
         FLXDG(K)=SUM(K)+CSOUR(1)*CO2SP(K)*CLDFAC(K,1)
      ENDDO

      DO K=1,LMAX
         HTEM4(K)=RADCON*(FLXDG(K+1)-FLXDG(K))*DELP(K)
      ENDDO

!***HTEM = TOTAL APPROXIMATE HEATING RATE  (Q (APPROX))

      DO K=1,LMAX
         HTEM(K)=HTEM1(K)+HTEM2(K)+HTEM3(K)+HTEM4(K)
      ENDDO

!***COMPUTE FLUX PRESSURE LEVELS

      PFLUX(1)=0.
      DO K=2,LMAX
!!cgs   IF (PRESS(K-1).LT.100.) THEN
        IF (PRESS(K-1).LT.10.) THEN
           PFLUX(K)=2.0*PRESS(K-1)-PFLUX(K-1)
        ELSE
           PFLUX(K)=0.50*(PRESS(K)+PRESS(K-1))
        END IF
      ENDDO
      PFLUX(LP1)=PRESS(LP1)

!***COMPUTE FLUXES AT TOP, GROUND AND NET FLUX AT ALL LEVELS

      FTOPC=GXCTS*1.E-3
      FTOPE=FLX1E1*1.E-3
      FTOP=FTOPC+FTOPE
      FGRD=GRNFLX*1.E-3
      FDIFF=FTOP-FGRD
      FLXNET(1)=FTOP

      DO K=2,LP1
         FLXNET(K)=FLXNET(K-1)+HEATRA(K-1)*DELP2(K-1)*RADCON1*1.E-3
      ENDDO

      DO K=1,LP1
         FSWD(K)=FSW(K)*1.E-3
         DFSWD(K)=DFSW(K)*1.E-3
         UFSWD(K)=UFSW(K)*1.E-3
      ENDDO

!***COMPUTE NET RADIATIVE HEATING AND NET FLUX (UP-DOWN)

      SOLARW=SSOLAR*6.97667E5*1.E-3
      DO K=1,LP1
         FLWSW(K)=FLXNET(K)+FSWD(K)
      ENDDO
      DO K=1,LMAX
         HLWSW(K)=HSW(K)+HEATRA(K)
      ENDDO

!***THE CODE BELOW IS FOR DIAGNOSIS OF CTS QUANTITIES***

      DO N=1,NBLM
         QSUM=0.
         DO K=1,LMAX
            QSUM=QSUM+EXCTSN(K,N)/(DELP(K)*RADCON)
         ENDDO
         FTOPN(N)=FCTSG(N)-QSUM
      ENDDO

!***THIS STMT. ACCOUNTS FOR 4.3 UM BAND CONTRIB.

         FTOPN(NBLY)=0.
      DO N=1,NBLY
         FTOPN(N)=FTOPN(N)*1.E-3
      ENDDO

         FTOPAC(1)=FTOPN(1)
      DO N=2,NBLY
         FTOPAC(N)=FTOPAC(N-1)+FTOPN(N)
      ENDDO

!***THIS STMT. ACCOUNTS FOR 4.3 UM BAND CONTRIB.
      FCTSG(NBLY)=0.
!***THIS LOOP SETS EXCTS CONTRIB. OF BAND 15 (4.3UM) TO ZERO

      DO K=1,LMAX
         EXCTSN(K,NBLY)=0.
      ENDDO

      DO N=1,NBLY
         FCTSG(N)=FCTSG(N)*1.E-3
      ENDDO

         VSUMAC(1)=FCTSG(1)
      DO N=2,NBLY
         VSUMAC(N)=VSUMAC(N-1)+FCTSG(N)
      ENDDO

!***APPROXIMATE CTS HEATING RATES***

      DO K=1,LMAX
         CTS1(K)=RADCON*DELP(K)*(CSOUR(K)*  &
            (CO2SP(K+1)*CLDFAC(K+1,1)-CO2SP(K)*CLDFAC(K,1)))
         CTS2(K)=RADCON*DELP(K)*(OSOUR(K)*  &
          (TO3(K+1,1)*CLDFAC(K+1,1)-TO3(K,1)*CLDFAC(K,1)))
         CTST(K)=CTS1(K)+CTS2(K)+CTS(K)
      ENDDO

!-----------------------------------------------------------------------
!****PRINT STATEMENTS FOLLOW***
!***PRINT LAT. POINT AND CLOUD DATA (IF ANY) AND SFC ALBEDO

      PRINT 5650,IP,JP
 5650 FORMAT (//,'  RADIATION RESULTS FOR IP,JP= ',2I5)

      PRINT 5651,NCLDS
 5651 FORMAT (/,' NO. CLOUDS= ',I2)

      IF (NCLDS .ne. 0) THEN
         PRINT 5652
 5652    FORMAT (37X,' LW CLOUD DATA'/,' CLD. NO',8X,'CLD. AMT.',2X,  &
                 'CLD. EMISS',4X,'CLD TOP INDEX',2X,'CLD BOT INDEX')
         PRINT 5653,(N,CAMT(N+1),EMCLD(N+1),KTOP(N+1),  &
                     KBTM(N+1),N=1,NCLDS)
 5653    FORMAT (I5,7X,F12.6,F12.6,I10,I15)
         PRINT 6652
 6652    FORMAT (37X,' SW CLOUD DATA'/,' CLD. NO',8X,'CLD. AMT.',2X,  &
               'CLD TOP INDEX',2X,'CLD BOT INDEX',2X,'VIS. REFL',3X,  &
               ' IR REFL',4X,' IR ABS.')
         PRINT 6653,(N,CAMT(N+1),KTOPSW(N+1),KBTMSW(N+1),  &
                     CUVRF(N+1),CIRRF(N+1),CIRAB(N+1),N=1,NCLDS)
 6653    FORMAT (I5,7X,F12.6,I8,I15,6X,3F12.6)
      ENDIF

!!    NN=NCLDS+2
!!    PRINT 7653, CUVRF(NN),CIRRF(NN)
      PRINT 7653, SALB,SALB
 7653 FORMAT (/,10X,'VIS. SFC. ALBEDO=',F12.6,' IR SFC. ALBEDO=',F12.6)

!***PRINT CO2 AMOUNT***

      PRINT 5654, RRVCO2
 5654 FORMAT (/,' CO2 VOL. MIXING RATIO= ',F14.6,/)

!***PRINT SOLAR INPUT,ZENITH ANGLE***

      PRINT 6654, SOLARW,COSZRO
 6654 FORMAT (/,' INCOMING SOLAR FLUX =',F12.6,' W/M**2',/,  &
                ' COS(AZIMUTH)=',F12.6)

!***PRINT SOLAR INPUT,ZENITH ANGLE,DAY FRACTION***
!     PRINT 6654, SOLARW,COSZRO,TAUDAR
!6654 FORMAT (/,' INCOMING SOLAR FLUX =',F12.6,' W/M**2',/,  &
!               ' COS(AZIMUTH)=',F12.6,10X,' FRACTION SUNUP=',F12.6)

!***PRINT INPUT DATA AND OVERALL HEATING RATES AND FLUXES

      PRINT 5755
 5755 FORMAT (/,20X,' LW HEATING RATES AND FLUXES',/)

      PRINT 5655
 5655 FORMAT ('  LVL',' PRESSURE   ',4X,' TEMP.     ','H2O MMR',5X,  &
              'O3 MMR',7X,'HEAT RATE',2X,'NET FLUX',3X,'FLUX PRESS.')

      PRINT 5555, (K,PRESS(K),TEMP(K),RH2O(K),QO3(K),  &
                     HEATRA(K),FLXNET(K),PFLUX(K),K=1,LMAX)
      PRINT 5556, PRESS(LP1),TEMP(LP1),FLXNET(LP1),PFLUX(LP1)
 5555 FORMAT (I4,E13.6,F12.4,2E12.5,2F12.6,E13.6)
 5556 FORMAT (4X,E13.6,F12.4,36X,F12.6,E13.6)

      PRINT 6755
      PRINT 6655
      PRINT 6555, (K,PRESS(K),HSW(K),FSWD(K),DFSWD(K),  &
                     UFSWD(K),PFLUX(K),K=1,LMAX)
      PRINT 6556, PRESS(LP1),FSWD(LP1),DFSWD(LP1),  &
                  UFSWD(LP1),PFLUX(LP1)
 6755 FORMAT (/,20X,' SW HEATING RATES AND FLUXES',/)
 6655 FORMAT ('  LVL',' PRESSURE    ',3X,'HEAT RATE',2X,'NET FLUX',  &
                4X,'DN FLUX',6X,'UP FLUX',3X,'FLUX PRESS.')
 6556 FORMAT (4X,E13.6,12X,3F12.6,E13.6)
 6555 FORMAT (I4,E13.6,4F12.6,E13.6)

      PRINT 7755
      PRINT 7655
      PRINT 7555, (K,PRESS(K),HLWSW(K),FLWSW(K),PFLUX(K),K=1,LMAX)
      PRINT 7556,    PRESS(LP1),FLWSW(LP1),PFLUX(LP1)
 7755 FORMAT (/,20X,' COMBINED HEATING RATES AND FLUXES',/)
 7655 FORMAT ('  LVL',' PRESSURE    ',4X,'HEAT RATE',2X,'NET FLUX',  &
               3X,'FLUX PRESS.')
 7556 FORMAT (4X,E13.6,12X,F12.6,E13.6)
 7555 FORMAT (I4,E13.6,2F12.6,E13.6)

!***PRINT APPROXIMATE HEATING RATES

      PRINT 5659
 5659 FORMAT (/,37X,'APPROXIMATE HEATING RATES        (Q(APPROX))'/  &
                '  LVL',' PRESSURE   ',5X,'  0-160,1200-2200 ',      &
                ' 800-990,1070-1200','     990-1070     ',           &
                '      560-800     ','       TOTAL')

      PRINT 5559, (K,PRESS(K),HTEM1(K),HTEM2(K),HTEM3(K),HTEM4(K),  &
                     HTEM(K),K=1,LMAX)
 5559 FORMAT (I4,E13.6,5F18.6)

      PRINT 5561
 5561 FORMAT (/,37X,'APPROXIMATE CTS HEATING RATES',  &
              /,'  LVL',' PRESSURE',7X,' H2O BANDS    ',  &
                ' 15 UM BAND   ',' 9.6 UM BAND  ',' TOTAL')

      PRINT 5562, (K,PRESS(K),CTS(K),CTS1(K),CTS2(K),CTST(K),K=1,LMAX)
 5562 FORMAT (I4,E13.6,4F14.6)

      PRINT 5570
 5570 FORMAT (/,37X,'EXACT CTS HEATING RATES, BY BAND',  &
              /,'  LVL',' PRESSURE   ','    TOTAL    ',  &
              5X,'1',11X,'2',11X,'3',11X,'4',11X,'5',11X,'6',11X,'7',/)

      PRINT 5573, (K,PRESS(K),EXCTS(K),EXCTSN(K,1),EXCTSN(K,2),  &
                     EXCTSN(K,3),EXCTSN(K,4),EXCTSN(K,5),  &
                     EXCTSN(K,6),EXCTSN(K,7),K=1,LMAX)
 5573 FORMAT (I4,E13.6,8F12.6)

      PRINT 5572
 5572 FORMAT ('  LVL',' PRESSURE   ',7X,'8',11X,'9',10X,'10',10X,  &
                '11',10X,'12',10X,'13',10X,'14',10X,'15')

      PRINT 5573, (K,PRESS(K),EXCTSN(K,8),EXCTSN(K,9),EXCTSN(K,10),  &
                     EXCTSN(K,11),EXCTSN(K,12),EXCTSN(K,13),  &
                     EXCTSN(K,14),EXCTSN(K,15),K=1,LMAX)

!***PRINT FLUXES

      PRINT 5558, FTOPC,FTOPE,FTOP,FGRD,FDIFF
 5558 FORMAT ( 40X,'   FLUXES',  &
             /,' FLUX AT TOP,160-1200 CM-1       =',F14.6,' W/M**2',  &
             /,' FLUX AT TOP,0-160,1200-2200 CM-1=',F14.6,' W/M**2',  &
             /,' FLUX AT TOP,0-2200 CM-1         =',F14.6,' W/M**2',  &
             /,' NET FLUX AT GROUND,0-2200 CM-1  =',F14.6,' W/M**2',  &
             /,' NET FLUX DIFFERENCE,0-2200 CM-1 =',F14.6,' W/M**2')

      PRINT 5633
 5633 FORMAT (40X,'CTS FLUXES',  &
             /,1X,'BAND NO',8X,'LOFREQ',9X,'HIFREQ',9X,'F(1)',11X,  &
                  'ACCUM. F(1)',4X,'CTS F(GRD)',5X,'ACCUM. CTS F(GRD)')

!***PRINTOUT FOR 8 COMBINED BANDS,160-560 CM-1

      DO 767 NY=1,8
      NPRT=1
        DO 768 NX=1,40
         IF (IBAND(NX).EQ.NY) THEN
           IF (NPRT.EQ.1) THEN
              PRINT 5644,NY,BANDLO(NX+16),BANDHI(NX+16),  &
                         FTOPN(NY),FTOPAC(NY),FCTSG(NY),VSUMAC(NY)
              NPRT=0
           ELSE
              PRINT 5646,BANDLO(NX+16),BANDHI(NX+16)
           ENDIF
         ENDIF
768   CONTINUE
767   CONTINUE

!***PRINTOUT FOR REMAINING BANDS

      DO 769 NY=9,NBLM
        PRINT 5644, NY,BANDLO(NY+48),BANDHI(NY+48),FTOPN(NY),  &
                       FTOPAC(NY),FCTSG(NY),VSUMAC(NY)
769   CONTINUE
      NY=NBLY
        PRINT 5644, NY,BANDLO(NBLW),BANDHI(NBLW),FTOPN(NY),  &
                       FTOPAC(NY),FCTSG(NY),VSUMAC(NY)
5644  FORMAT (I11,6F15.6)
5646  FORMAT (11X,2F15.6)

!-----------------------------------------------------------------------

      END SUBROUTINE RADPRT

!#######################################################################
!#######################################################################

                 END MODULE RAD_DIAG_MOD




                        MODULE RDPARM_MOD

!-----------------------------------------------------------------------
!
!   PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: 
!   ----------------------------------------------------------------- 
!
!          IMAX   =  NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS.
!          JMAX   =  NO. POINTS ALONG THE MERIDIONAL AXIS
!          LMAX   =  NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL 
!
!      *** NOTE: THE USER NORMALLY WILL MODIFY ONLY THE
!                IMAX AND LMAX VARIABLES 
!
!          NBLW   =  NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE 
!                      BANDTA FOR DEFINITION
!          NBLX   =  NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS 
!          NBLY   =  NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE
!                      BDCOMB FOR DEFINITION
!          INLTE  =  NO. LEVELS USED FOR NLTE CALCS.
!          NNLTE  =  INDEX NO. OF FREQ. BAND IN NLTE CALCS. 
!
!          NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE
!                    DERIVED FROM THE ABOVE PARAMETERS. 
!
!-----------------------------------------------------------------------

      Use       Fms_Mod, ONLY: write_version_number, mpp_pe, mpp_root_pe, &
                               error_mesg, FATAL

implicit none
private


!!!!  INTEGER, PUBLIC, SAVE :: IMAX,JMAX,LMAX
      INTEGER, PUBLIC, SAVE :: LMAX=0
      INTEGER, PUBLIC, SAVE :: LP1,LP2,LP3,LM1,LM2,LM3
      INTEGER, PUBLIC, SAVE :: LL,LLP1,LLP2,LLP3,LLM1,LLM2,LLM3
      INTEGER, PUBLIC, SAVE :: LP1M,LP1M1,LP1V,LP121,LL3P
      INTEGER, PUBLIC, SAVE :: LP1I,LLP1I,LL3PI

      INTEGER, PUBLIC, PARAMETER :: NBLW=163,NBLX=47,NBLY=15,NBLM=NBLY-1
      INTEGER, PUBLIC, PARAMETER :: NB=9,NB1=NB-1
      INTEGER, PUBLIC, PARAMETER :: INLTE=3,INLTEP=INLTE+1
      INTEGER, PUBLIC, PARAMETER :: NNLTE=56
      INTEGER, PARAMETER :: KO2=12,KO21=KO2+1,KO2M=KO2-1

      character(len=128) :: version = '$Id: rdparm.F90,v 10.0 2003/10/24 22:00:32 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical            :: module_is_initialized = .false.

public RDPARM_INIT, RDPARM_END

      CONTAINS

!#######################################################################

      SUBROUTINE RDPARM_INIT (KDIM)

      IMPLICIT NONE
      INTEGER,INTENT(IN) :: KDIM

         LMAX=KDIM

         LP1=LMAX+1; LP2=LMAX+2; LP3=LMAX+3 
         LM1=LMAX-1; LM2=LMAX-2; LM3=LMAX-3 
         LL=2*LMAX; LLP1=LL+1; LLP2=LL+2; LLP3=LL+3
         LLM1=LL-1; LLM2=LL-2; LLM3=LL-3 
         LP1M=LP1*LP1; LP1M1=LP1M-1 
         LP1V=LP1*(1+2*LMAX/2)
         LP121=LP1*NBLY
         LL3P=3*LMAX+2

!!!!  Not Used ?????
!!!!     LP1I=IMAX*LP1; LLP1I=IMAX*LLP1; LL3PI=IMAX*LL3P 
!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

      END SUBROUTINE RDPARM_INIT

!#######################################################################
      SUBROUTINE RDPARM_END

      module_is_initialized = .false.

!---------------------------------------------------------------------
      END SUBROUTINE RDPARM_END

!#######################################################################

                        END MODULE RDPARM_MOD




                        MODULE SHORTWAVE_MOD

!-----------------------------------------------------------------------

      USE  RDPARM_MOD, ONLY: LMAX,LP1,LLP1,LP2,LLP2,NB
      USE  HCONST_MOD, ONLY: DIFFCTR,GINV,O3DIFCTR,RADCON

      Use       Fms_Mod, ONLY: Error_Mesg, FATAL, &
                               write_version_number, mpp_pe, mpp_root_pe

!implicit none
private

!------- interfaces -------
      PUBLIC  SWRAD, SHORTWAVE_INIT, SHORTWAVE_END

      character(len=128) :: version = '$Id: shortwave.F90,v 10.0 2003/10/24 22:00:32 fms Exp $'
      character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
      logical            :: module_is_initialized = .false.

      integer :: IMAX
      CONTAINS

!#######################################################################

      SUBROUTINE SWRAD (NCLDS,KTOPSW,KBTMSW,PRESS,RH2O,QO3,CAMT, &
                        CUVRF,CIRRF,CIRAB,RRCO2,COSZRO,SSOLAR, &
                        SALB, FSW,DFSW,UFSW,HSW, LSFC,PSFC)

!-----------------------------------------------------------------------
!              WRAPPER FOR  SHORT WAVE RADIATION CODE
!     inserts surface albedo into appropriate cloud property arrays
!-----------------------------------------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:)   :: NCLDS
      INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOPSW,KBTMSW
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: PRESS,RH2O,QO3
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: CAMT,CUVRF,CIRRF,CIRAB
      REAL,    INTENT(IN)                   :: RRCO2
      REAL,    INTENT(IN), DIMENSION(:,:)   :: COSZRO,SSOLAR
      REAL,    INTENT(IN), DIMENSION(:,:)   :: SALB

      REAL,   INTENT(OUT), DIMENSION(:,:,:) :: FSW,DFSW,UFSW,HSW

      INTEGER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   :: LSFC
         REAL, INTENT(IN), OPTIONAL, DIMENSION(:,:)   :: PSFC

!-----------------------------------------------------------------------
      REAL,DIMENSION(SIZE(CUVRF,1),SIZE(CUVRF,3)) :: CUVRF2,CIRRF2
      REAL,DIMENSION(SIZE(CAMT ,1),SIZE(CAMT ,3)) :: CAMT2

      INTEGER  i,j
!-----------------------------------------------------------------------

      IMAX=SIZE(PRESS,1)

      DO j=1,SIZE(PRESS,2)

      CUVRF2(:,:)=CUVRF(:,j,:)
      CIRRF2(:,:)=CIRRF(:,j,:)
      CAMT2 (:,:)=CAMT (:,j,:)

      DO i=1,IMAX
         IF (COSZRO(i,j) > 0.0) THEN
            CUVRF2(i,NCLDS(i,j)+2)=SALB(i,j)
            CIRRF2(i,NCLDS(i,j)+2)=SALB(i,j)
            CAMT2 (i,NCLDS(i,j)+2)=1.0
         ENDIF
      ENDDO

!----- check usage of optional arguments -------
      IOPT=0
      IF (PRESENT(LSFC)) IOPT=IOPT+1
      IF (PRESENT(PSFC)) IOPT=IOPT+2

!     ------------------
      SELECT CASE (IOPT)
!     ------------------
          CASE (0)
!     ------------------
      CALL SWRAD_ORIG (NCLDS(:,j),KTOPSW(:,j,:),KBTMSW(:,j,:), &
                       PRESS(:,j,:),RH2O(:,j,:),QO3(:,j,:),CAMT2(:,:), &
                       CUVRF2,CIRRF2,CIRAB(:,j,:),RRCO2, &
                       COSZRO(:,j),SSOLAR(:,j), &
                       FSW(:,j,:),DFSW(:,j,:),UFSW(:,j,:),HSW(:,j,:))
!     ------------------
          CASE (3)
!     ------------------
      CALL SWRAD_ORIG (NCLDS(:,j),KTOPSW(:,j,:),KBTMSW(:,j,:), &
                       PRESS(:,j,:),RH2O(:,j,:),QO3(:,j,:),CAMT2(:,:), &
                       CUVRF2,CIRRF2,CIRAB(:,j,:),RRCO2, &
                       COSZRO(:,j),SSOLAR(:,j), &
                       FSW(:,j,:),DFSW(:,j,:),UFSW(:,j,:),HSW(:,j,:), &
                       LSFC(:,j),PSFC(:,j))
!     ------------------
          CASE DEFAULT
!     ------------------
             Call Error_Mesg ('SWRAD in SHORTWAVE_MOD', &
                          'LSFC and PSFC must be used together.', FATAL)
!     ------------------
      END SELECT
!     ------------------

      ENDDO
!-----------------------------------------------------------------------

      END SUBROUTINE SWRAD
      
!#######################################################################

      SUBROUTINE SWRAD_ORIG (NCLDS,KTOPSW,KBTMSW,PRESS,RH2O,QO3,CAMT, &
                        CUVRF,CIRRF,CIRAB,RRCO2,COSZRO,SSOLAR, &
                        FSW,DFSW,UFSW,HSW,LSFC,PSFC)

!***********************************************************************
!                    SHORT WAVE RADIATION CODE
!***********************************************************************
!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT. 
!      KTOPSW  =  INDEX OF (FLUX LEVEL) PRESSURE OF CLOUD TOP, USED 
!                    IN THE SHORTWAVE PROGRAM 
!      KBTMSW  =  INDEX OF (FLUX LEVEL) PRESSURE OF CLOUD BOTTOM, 
!                    USED IN THE SHORTWAVE PROGRAM
!      PRESS   =  PRESSURE (CGS UNITS) AT DATA LEVELS OF MODEL
!      RH2O    =  MASS MIXING RATIO (G/G) OF H2O AT MODEL DATA LVLS.
!      QO3     =  MASS MIXING RATIO (G/G) OF O3 AT MODEL DATA LVLS. 
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                    SPECIFIED IN THE KTOP/KBTM INDICES)
!      CUVRF   =  REFLECTIVITY OF CLOUDS IN THE VISIBLE FREQ. BAND
!                    USED IN SHORTWAVE CALCS. ONLY
!      CIRRF   =  REFLECTIVITY OF CLOUDS IN THE INFRARED FREQ. BAND 
!                    USED IN SHORTWAVE CALCS. ONLY
!      CIRAB   =  ABSORPTIVITY OF CLOUDS IN THE INFRARED FREQ. BAND 
!                    USED IN SHORTWAVE CALCS. ONLY
!      RRCO2   =  MASS MIXING RATIO (G/G) OF CO2,USED IN SHORTWAVE
!                    CALCS. ONLY (scalar)
!      COSZRO  =  ZENITH ANGLE AT GRID PT. USED ON SHORTWAVE CALCS. 
!      SSOLAR  =  TOTAL SOLAR FLUX EITHER FOR THE TIMESTEP OR AVERAGED
!                 OVER THE DAY OR YEAR,
!                 EQUALS THE SOLAR CONSTANT x NORMALIZED SOLAR FLUX
!                 (INCLUDES THE COS ZENITH ANGLE AND DAY FRACTION)
!                 (AT PRESENT,IN LY/MIN).
!
!      LSFC    =  Vertical index of the lowest model level,
!                    dimensioned by IMAX.
!      PSFC    =  Surface pressure
!
!-----------------------------------------------------------------------
!                        OUTPUT PARAMETERS
!                        -----------------
!
!      FSW     = NET RADIATION (UP-DOWN) IN CGS UNITS AT ALL
!                PRESSURE LEVELS
!     DFSW     = DOWNWARD RADIATION AT ALL PRESSURE LEVELS
!     UFSW     = UPWARD RADIATION AT ALL PRESSURE LEVELS
!      HSW     = SHORTWAVE HEATING RATES IN K/DAY FOR PRESSURE
!                LAYERS.
!
!-----------------------------------------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOPSW,KBTMSW
      REAL,    INTENT(IN), DIMENSION(:,:) :: PRESS,RH2O,QO3
      REAL,    INTENT(IN), DIMENSION(:,:) :: CAMT,CUVRF,CIRRF,CIRAB
      REAL,    INTENT(IN)                 :: RRCO2
      REAL,    INTENT(IN), DIMENSION(:)   :: COSZRO,SSOLAR

      REAL,   INTENT(OUT), DIMENSION(:,:) :: FSW,DFSW,UFSW,HSW

      INTEGER, INTENT(IN), OPTIONAL, DIMENSION(:)   :: LSFC
      REAL,    INTENT(IN), OPTIONAL, DIMENSION(:)   :: PSFC
       
!-----------------------------------------------------------------------
!                        D I M E N S I O N
!    &  NCLDS(IMAX),KTOPSW(IMAX,LP1),KBTMSW(IMAX,LP1)
!    2 ,PRESS(IMAX,LP1),RH2O(IMAX,LMAX),QO3(IMAX,LMAX)
!    3 ,CAMT(IMAX,LP1),CUVRF(IMAX,LP1),CIRRF(IMAX,LP1),CIRAB(IMAX,LP1)
!    4 ,COSZRO(IMAX),SSOLAR(IMAX),LSFC(IMAX),PSFC(IMAX)
!                        D I M E N S I O N
!    &  FSW(IMAX,LP1),DFSW(IMAX,LP1),UFSW(IMAX,LP1),HSW(IMAX,LMAX)
!-----------------------------------------------------------------------
!***********************************************************************
      LOGICAL BCLDS,BJTOP
!-----------------------------------------------------------------------
                         DIMENSION &
        BCLDS(IMAX,LP1),BJTOP(IMAX,LP1), &
        ICNT(LP1),ICNT1(LP1),IINCL(LP1),INDX4(IMAX,LP1),INDXK(IMAX), &
        IBETCL(LP1) 
!-----------------------------------------------------------------------
                         DIMENSION &
        DFN(IMAX,LP1,NB),UFN(IMAX,LP1,NB), &
        TTD(IMAX,LP1,NB),TTU(IMAX,LP1,NB), &
        PP    (IMAX,LP1),PPTOP (IMAX,LP1), &
        DP    (IMAX,LP1),DPCLD (IMAX,LP1), &
        CR    (IMAX,LP1),CT    (IMAX,LP1), &
        TDCL1 (IMAX,LP1),TDCL2 (IMAX,LP1),TUCL1 (IMAX,LP1), &
        TUCL1I(IMAX,LP1),TDCL1I(IMAX,LP1),TDCL2I(IMAX,LP1), &
        TCLU  (IMAX,LP1),TCLD  (IMAX,LP1),ALFAU (IMAX,LP1), &
        UFNCLU(IMAX,LP1),UFNCLD(IMAX,LP1), &
        DFNCLU(IMAX,LP1),DFNCLD(IMAX,LP1), &
        TEMP1(IMAX),TEMP2(IMAX),TEMP3(IMAX),TEMP4(IMAX), &
        TEMP5(IMAX),TEMP6(IMAX),ALFA (IMAX), &
        VV   (IMAX),REFL (IMAX),SECZ (IMAX),RRAY (IMAX)
!***********************************************************************
!-------DIMENSION OF VARIABLES EQUIVALENCED TO THOSE PREVIOUSLY---------
!***********************************************************************
!-----------------------------------------------------------------------
!                        D I M E N S I O N
      DIMENSION PPBOT(IMAX,LP1)
      DIMENSION DFNTOP(IMAX,NB)
      DIMENSION UD(IMAX,LP1),UR(IMAX,LP1)
!     DIMENSION UCO2(IMAX,LLP2),UO3(IMAX,LLP2),ACO2(IMAX,LLP2)
!     DIMENSION AO3(IMAX,LLP2)
      DIMENSION VTROW1(IMAX,LP1)
      DIMENSION VTROW2(IMAX,LP1),VTROW3(IMAX,LP1)
      DIMENSION FF(IMAX,LP1),FFCO2(IMAX,LP1),FFO3(IMAX,LP1)
      DIMENSION PR2(IMAX,LP1)
      DIMENSION DU(IMAX,LP1),DUCO2(IMAX,LP1),DUO3(IMAX,LP1)
      DIMENSION ADCO2(IMAX,LP1),AUCO2(IMAX,LP1),UDCO2(IMAX,LP1), URCO2(IMAX,LP1)
      DIMENSION ABSDO3(IMAX,LP1),ABSUO3(IMAX,LP1),UDO3(IMAX,LP1), URO3(IMAX,LP1)
      DIMENSION CR1D(IMAX*LP1),ALFU1D(IMAX*LP1),TCLU1D(IMAX*LP1), TCLD1D(IMAX*LP1)
!--DIMENSIONS OF LOCAL DATA VARIABLES---
      DIMENSION ABCFF(NB),PWTS(NB)
!***********************************************************************
!-----------------------------------------------------------------------
!     EQUIVALENCE (ADCO2(1,1),ACO2(1,1)),(AUCO2(1,1),ACO2(1,LP2))
!     EQUIVALENCE (UDCO2(1,1),UCO2(1,1)),(URCO2(1,1),UCO2(1,LP2))
!     EQUIVALENCE (ABSDO3(1,1),AO3(1,1)),(ABSUO3(1,1),AO3(1,LP2))
!     EQUIVALENCE (UDO3(1,1),UO3(1,1)),(URO3(1,1),UO3(1,LP2))

!     EQUIVALENCE (CR,UD),(CT,UR)
!     EQUIVALENCE (TDCL1I,ABSDO3,PPBOT),(TDCL2I,ABSUO3)
!     EQUIVALENCE (UFNCLU,UDO3),(UFNCLD,URO3)
!     EQUIVALENCE (DFNCLU,UDCO2),(DFNCLD,URCO2)
!     EQUIVALENCE (TCLU,ADCO2),(TCLD,AUCO2)
!     EQUIVALENCE (TTD(1,1,1),FF(1,1))
!     EQUIVALENCE (TTD(1,1,2),FFCO2(1,1))
!     EQUIVALENCE (TTD(1,1,3),PR2(1,1))
!     EQUIVALENCE (TTD(1,1,4),DU(1,1))
!     EQUIVALENCE (TTD(1,1,5),DUCO2(1,1))
!     EQUIVALENCE (TTD(1,1,6),DUO3(1,1))
!     EQUIVALENCE (TTD(1,1,7),VTROW1(1,1))
!     EQUIVALENCE (TTD(1,1,8),VTROW2(1,1))
!     EQUIVALENCE (TTD(1,1,9),VTROW3(1,1))
!     EQUIVALENCE (TTU(1,1,1),DFNTOP(1,1))
!     EQUIVALENCE (CR1D,CR),(ALFU1D,ALFAU),(TCLD1D,TCLD),(TCLU1D,TCLU)
!-----------------------------------------------------------------------
      DATA ABCFF /2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190./
      DATA PWTS /.5000,.1470,.0698,.1443,.0584,.0335,.0225,.0158,.0087/
      DATA CFCO2,CFO3 /508.96,466.64/
      DATA REFLO3 /1.9/
      DATA RRAYAV /0.144/
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX
         FF   (I,K)=DIFFCTR
         FFCO2(I,K)=DIFFCTR
         FFO3 (I,K)=O3DIFCTR
      ENDDO
      ENDDO

!------ NOTE: converting pressures (PRESS) to CGS units -------

      DO K=2,LMAX
      DO I=1,IMAX
!CCC     PP(I,K)=0.50*(PRESS(I,K)+PRESS(I,K-1))
         PP(I,K)=5.0*(PRESS(I,K)+PRESS(I,K-1))
      ENDDO
      ENDDO

      DO I=1,IMAX
         SECZ(I)=35./SQRT(1224.*COSZRO(I)*COSZRO(I)+1.0)
!        SECZ(I)=1./COSZRO(I)
      ENDDO

      IF (.not.PRESENT(LSFC)) THEN
         DO I=1,IMAX
            PP(I,1)=0.00
            PP(I,LP1)=10.*PRESS(I,LP1)
         ENDDO
      ELSE
         DO I=1,IMAX
            PP(I,1)=0.00
            PP(I,LP1)=10.*PRESS(I,LP1)
            PP(I,LSFC(I)+1)=10.*PSFC(I)
         ENDDO
      ENDIF

      DO K=1,LMAX
      DO I=1,IMAX
         DP(I,K)=PP(I,K+1)-PP(I,K)
      ENDDO
      ENDDO

      IF (.not.PRESENT(LSFC)) THEN
         DO K=1,LMAX
         DO I=1,IMAX
!CCC        PR2(I,K)=0.50*(PP(I,K)+PP(I,K+1))/PRESS(I,LP1)
            PR2(I,K)=0.050*(PP(I,K)+PP(I,K+1))/PRESS(I,LP1)
         ENDDO
         ENDDO
      ELSE
         DO K=1,LMAX
         DO I=1,IMAX
!CCC        PR2(I,K)=0.50*(PP(I,K)+PP(I,K+1))/PSFC(I)
            PR2(I,K)=0.050*(PP(I,K)+PP(I,K+1))/PSFC(I)
         ENDDO
         ENDDO
      ENDIF

      DO K=1,LMAX
      DO I=1,IMAX
         DUO3 (I,K)=QO3 (I,K)*DP(I,K)*GINV
         DUCO2(I,K)=RRCO2    *DP(I,K)*GINV
         DU   (I,K)=RH2O(I,K)*DP(I,K)*GINV
      ENDDO
      ENDDO

      DO I=1,IMAX
         JTOP=KTOPSW(I,2) 
         DO K=1,JTOP 
            FFO3 (I,K)=SECZ(I) 
            FFCO2(I,K)=SECZ(I)
            FF   (I,K)=SECZ(I) 
         ENDDO
      ENDDO

!-----------------------------------------------------------------------
!     CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS IN UNITS OF G/CM2.
!     PRESSURE WEIGHTING IS BY P**0.5 
!     UD IS THE DOWNWARD PATH,UR THE UPWARD PATH, 
!     AND THE CALCULATION IS MADE BY TAKING A PATH WITH AN ANGLE
!     OF (SECZ) FROM THE TOP OF THE ATMOSPHERE TO THE TOPMOST CLOUD,
!     THEN USING THE DIFFUSIVITY FACTOR (1.66) TO THE SURFACE AND FOR 
!     REFLECTED RADIATION. THE CODE BELOW REFLECTS THIS.
!-----------------------------------------------------------------------
!*****************************************
      IF (.not.PRESENT(LSFC)) THEN
         DO K=1,LMAX
         DO I=1,IMAX
            VTROW1(I,K)=DU   (I,K)*PR2(I,K)
            VTROW2(I,K)=DUCO2(I,K)*PR2(I,K)*CFCO2
            VTROW3(I,K)=DUO3 (I,K)*CFO3
         ENDDO
         ENDDO
      ELSE
         DO K=1,LMAX
         DO I=1,IMAX
            VTROW1(I,K)=0.00
            VTROW2(I,K)=0.00
            VTROW3(I,K)=0.00
         ENDDO
         ENDDO
         DO I=1,IMAX
            LMA=LSFC(I)
            DO K=1,LMA
               VTROW1(I,K)=DU   (I,K)*PR2(I,K)
               VTROW2(I,K)=DUCO2(I,K)*PR2(I,K)*CFCO2
               VTROW3(I,K)=DUO3 (I,K)*CFO3
            ENDDO
         ENDDO
      ENDIF
!*****************************************

      DO I=1,IMAX
         UD   (I,1)=0.00 
         UDCO2(I,1)=0.00
         UDO3 (I,1)=0.00 
      ENDDO

      DO K=2,LP1
!     DO I=1,IMAX
         UD   (:,K)=UD   (:,K-1)+VTROW1(:,K-1)*FF   (:,K) 
         UDCO2(:,K)=UDCO2(:,K-1)+VTROW2(:,K-1)*FFCO2(:,K)
         UDO3 (:,K)=UDO3 (:,K-1)+VTROW3(:,K-1)*FFO3 (:,K) 
!     ENDDO
      ENDDO

!   UDO3,URO3 ARE IN UNITS OF CM 
!   CFCO2,CFO3 IS THE CONVERSION FACTOR FROM GM/CM2 TO CM

      DO I=1,IMAX
         UR   (I,LP1)=UD   (I,LP1) 
         URCO2(I,LP1)=UDCO2(I,LP1) 
         URO3 (I,LP1)=UDO3 (I,LP1) 
      ENDDO

      DO K=LMAX,1,-1 
      DO I=1,IMAX
         UR   (I,K)=UR   (I,K+1)+VTROW1(I,K)*DIFFCTR
         URCO2(I,K)=URCO2(I,K+1)+VTROW2(I,K)*DIFFCTR
         URO3 (I,K)=URO3 (I,K+1)+VTROW3(I,K)*REFLO3 
      ENDDO
      ENDDO

!   CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR BANDS 2-9;
!   T.F. FOR BAND 1= T.F FOR BAND 2

      DO N=2,NB 
      DO K=1,LP1
      DO I=1,IMAX
         TTD(I,K,N)=ABCFF(N)*UD(I,K) 
         TTU(I,K,N)=ABCFF(N)*UR(I,K) 
      ENDDO
      ENDDO
      ENDDO

      DO N=2,NB
      DO K=1,LP1
      DO I=1,IMAX
         IF (TTD(I,K,N).GE.50.)  TTD(I,K,N)=50.
         IF (TTU(I,K,N).GE.50.)  TTU(I,K,N)=50.
      ENDDO
      ENDDO
      ENDDO

      DO N=2,NB
      DO K=1,LP1
      DO I=1,IMAX
         TTD(I,K,N)=-1.0*TTD(I,K,N)
         TTU(I,K,N)=-1.0*TTU(I,K,N)
      ENDDO
      ENDDO
      ENDDO

      DO N=2,NB
      DO K=1,LP1
      DO I=1,IMAX
         TTD(I,K,N)=EXP(TTD(I,K,N))
         TTU(I,K,N)=EXP(TTU(I,K,N))
      ENDDO
      ENDDO
      ENDDO

!   CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN BANDS 2-9. 
!   SINCE THESE OCCUPY 50 PERCENT OF THE SOLAR SPECTRUM THE 
!   ABSORPTIONS WILL BE MULTIPLIED BY 2 

      DO I=1,IMAX
         ADCO2(I,1)=0.00
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX
         ADCO2(I,K)=UDCO2(I,K)+0.0129
         ADCO2(I,K)=0.26*LOG(ADCO2(I,K))
         ADCO2(I,K)=EXP(ADCO2(I,K))
         ADCO2(I,K)=2.35E-3*ADCO2(I,K)-7.58265E-4 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         AUCO2(I,K)=URCO2(I,K)+0.0129
         AUCO2(I,K)=0.26*LOG(AUCO2(I,K))
         AUCO2(I,K)=EXP(AUCO2(I,K))
         AUCO2(I,K)=2.35E-3*AUCO2(I,K)-7.58265E-4 
      ENDDO
      ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        ACO2(I,K)=UCO2(I,K)+0.0129
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        ACO2(I,K)=LOG(ACO2(I,K))
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        ACO2(I,K)=0.26*ACO2(I,K)
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        ACO2(I,K)=EXP(ACO2(I,K))
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        ACO2(I,K)=2.35E-3*ACO2(I,K)-7.58265E-4 
!     ENDDO
!     ENDDO

      DO I=1,IMAX
         AUCO2(I,LP1)=ADCO2(I,LP1) 
      ENDDO

      DO K=1,LP1 
      DO I=1,IMAX 
         ADCO2(I,K)=2.0*ADCO2(I,K) 
         AUCO2(I,K)=2.0*AUCO2(I,K) 
      ENDDO
      ENDDO

!   NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN
!   BAND 1. AS THIS OCCUPIES 50 PERCENT OF THE SOLAR SPECTRUM 
!   THE OZONE ABSORPTIONS WILL BE MULTIPLIED BY 2

      DO I=1,IMAX
         ABSDO3(I,1)=0.00 
      ENDDO

      H103P6=103.6*103.6*103.6

      DO K=2,LP1
      DO I=1,IMAX
         ABSDO3(I,K)=1.0+138.6*UDO3(I,K) 
         ABSDO3(I,K)=-0.805*LOG(ABSDO3(I,K))
         ABSDO3(I,K)=EXP(ABSDO3(I,K))
         ABSDO3(I,K)=1.082*UDO3(I,K)*ABSDO3(I,K)+ &
            0.0658*UDO3(I,K)/(1.0+H103P6*UDO3(I,K)*UDO3(I,K)*UDO3(I,K))+ &
            0.02118*UDO3(I,K)/(1.0+0.042*UDO3(I,K)+ &
            0.000323*UDO3(I,K)*UDO3(I,K))
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         ABSUO3(I,K)=1.0+138.6*URO3(I,K) 
         ABSUO3(I,K)=-0.805*LOG(ABSUO3(I,K))
         ABSUO3(I,K)=EXP(ABSUO3(I,K))
         ABSUO3(I,K)=1.082*URO3(I,K)*ABSUO3(I,K)+ &
            0.0658*URO3(I,K)/(1.0+H103P6*URO3(I,K)*URO3(I,K)*URO3(I,K))+ &
            0.02118*URO3(I,K)/(1.0+0.042*URO3(I,K)+ &
            0.000323*URO3(I,K)*URO3(I,K))
      ENDDO
      ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        AO3(I,K)=1.0+138.6*UO3(I,K) 
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        AO3(I,K)=LOG(AO3(I,K))
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        AO3(I,K)=-0.805*AO3(I,K)
!     ENDDO
!     ENDDO

!     DO K=2,LLP1
!     DO I=1,IMAX
!        AO3(I,K)=EXP(AO3(I,K)) 
!     ENDDO
!     ENDDO

!     H103P6=103.6*103.6*103.6
!     DO K=2,LLP1
!     DO I=1,IMAX 
!        AO3(I,K)=1.082*UO3(I,K)*AO3(I,K)+ 
!    &        0.0658*UO3(I,K)/(1.0+H103P6*UO3(I,K)*UO3(I,K)*UO3(I,K))+
!    &        0.02118*UO3(I,K)/(1.0+0.042*UO3(I,K)+ 
!    &        0.000323*UO3(I,K)*UO3(I,K))
!     ENDDO
!     ENDDO

      DO I=1,IMAX
         ABSUO3(I,LP1)=ABSDO3(I,LP1) 
      ENDDO

!     DO K=1,LLP2
      DO K=1,LP1
      DO I=1,IMAX 
!        AO3(I,K)=2.0*AO3(I,K)
         ABSDO3(I,K)=2.0*ABSDO3(I,K) 
         ABSUO3(I,K)=2.0*ABSUO3(I,K) 
      ENDDO
      ENDDO

!     WRITE (*,101) ((K,UD(IP,K),UR(IP,K),K=1,LP1),IP=1,IMAX) 
!     WRITE (*,105) ((K,UDO3(IP,K),URO3(IP,K),ABSDO3(IP,K), 
!    1 ABSUO3(IP,K),K=1,LP1),IP=1,IMAX) 
!     WRITE (*,105) ((K,UDCO2(IP,K),URCO2(IP,K),ADCO2(IP,K),
!    1 AUCO2(IP,K),K=1,LP1),IP=1,IMAX)

!   COMBINE ABSORPTIONS AND TRANSMISSIONS TO OBTAIN A 
!   TRANSMISSION FUNCTION FOR EACH OF THE 9 BANDS.

      DO K=1,LP1 
      DO I=1,IMAX 
         TTD(I,K,1)=TTD(I,K,2)*(1.0-ABSDO3(I,K))
      ENDDO
      ENDDO

      DO K=1,LMAX 
      DO I=1,IMAX 
         TTU(I,K,1)=TTU(I,K,2)*(1.0-ABSUO3(I,K))
      ENDDO
      ENDDO

      DO N=2,NB
      DO K=1,LP1 
      DO I=1,IMAX 
         TTD(I,K,N)=TTD(I,K,N)*(1.0-ADCO2(I,K)) 
      ENDDO
      ENDDO
      ENDDO

      DO N=1,NB
      DO I=1,IMAX 
         TTU(I,LP1,N)=TTD(I,LP1,N) 
      ENDDO
      ENDDO

      DO N=2,NB
      DO K=1,LMAX 
      DO I=1,IMAX 
         TTU(I,K,N)=TTU(I,K,N)*(1.0-AUCO2(I,K)) 
      ENDDO
      ENDDO
      ENDDO

!   IN THE 850 LOOP BELOW AND THE 855 LOOP,WE WILL SCALE DFN(IP,1,N)
!   TO UNITY. AFTER THE 850 LOOP,WE MULTIPLY BY DFN(IP,1,N) FROM THE
!   6 LOOP TO GET THE ACTUAL DFN'S AND UFN'S.
!   THE 855 LOOP=SCALED DOWNWARD FLUX ADOVE TOPMOST CLOUD(REDUN-
!   DANTLY OBTAINED TO THE GROUND) .ALSO,UFN IS INITIALIZED TO 0

      DO N=1,NB
      DO K=1,LP1
      DO I=1,IMAX
         DFN(I,K,N)=TTD(I,K,N)
         UFN(I,K,N)=0.00
      ENDDO
      ENDDO
      ENDDO
 
!***EVALUATE LOGICAL ARRAYS USED FOR CLOUD CALCULATIONS
!----BCLDS : TRUE IF KK IS < OR = TO NCLDS (NO. CLOUDS AT GRID PT I)
!----BJTOP : TRUE IF K IS < OR = TO KTOPSW(I,2) (INDEX OF TOP CLOUD,
!                    IF ANY; LP1 IS NO CLOUD AT GRID PT)
 
      DO KK=1,LP1
      DO I=1,IMAX
         BCLDS(I,KK)=KK.LE.NCLDS(I)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX
         BJTOP(I,K)=K.LE.KTOPSW(I,2)
      ENDDO
      ENDDO

!---COUNT NO. OF PTS IN EACH ROW FOR WHICH BCLDS IS TRUE (ICNT)
!   AND FOR WHICH BJTOP IS TRUE (ICNT1)
 
      DO K=1,LP1
         ICNT(K)=0
         ICNT1(K)=0
         DO I=1,IMAX
            IF (BCLDS(I,K)) THEN
               ICNT(K)=ICNT(K)+1
            ENDIF
            IF (BJTOP(I,K)) THEN
               ICNT1(K)=ICNT1(K)+1
            ENDIF
         ENDDO
      ENDDO

!---FIND NO. OF CLOUD LEVELS WITH NONZERO VALUES OF ICNT
!---FIND NO. OF PRESSURE LEVELS WITH NONZERO VALUES OF ICNT1
 
      KCLDS=0
      KJTOP=0
      DO K=1,LP1
         IF (ICNT(K).GT.0) THEN
            KCLDS=KCLDS+1 
         ENDIF
         IF (ICNT1(K).GT.0) THEN
            KJTOP=KJTOP+1
         ENDIF
      ENDDO

!***IF NO CLOUDS AT ALL EXIST IN THE ROW, THE CALCULATIONS ARE
!   DRASTICALLY SIMPLIFIED.

!MPP  IF (KCLDS.EQ.0) THEN
      IF (KCLDS.EQ.-1) THEN
         DO N=1,NB

            IF (N.EQ.1) THEN
               DO I=1,IMAX
                  REFL(I)=CUVRF(I,2)
!CCCC             REFL(I)=SALB(I)
                  RRAY(I)=0.219/(1.0+0.816*COSZRO(I))
                  REFL(I)=RRAY(I)+(1.0-RRAY(I))*(1.0-RRAYAV)*REFL(I)/ &
                          (1.0-REFL(I)*RRAYAV)
                  ALFA(I)=REFL(I)
               ENDDO
            ELSE
               DO I=1,IMAX
                  ALFA(I)=CIRRF(I,2)
!CCCC             ALFA(I)=SALB(I)
               ENDDO
            ENDIF

            DO I=1,IMAX
               VV(I)=ALFA(I)*DFN(I,LP1,N)/TTU(I,LP1,N)
            ENDDO

            DO K=1,LP1
            DO I=1,IMAX
               UFN(I,K,N)=VV(I)*TTU(I,K,N)
            ENDDO
            ENDDO

         ENDDO
      ENDIF

!***********************************************************************
!     ****** COMPUTE NORMAL CASE: AT LEAST 1 PT HAS A CLOUD ******

!MPP                  IF (KCLDS.NE.0) THEN
                      IF (KCLDS.GE.0) THEN

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

!---FIND  HIGHEST PRESSURE LEVEL WITH AT LEAST 1 PT BELOW TOP CLOUD
      KCLDS2=0
      DO K=1,LP1
         IF (ICNT1(K).EQ.IMAX) THEN
            KCLDS2=KCLDS2+1
         ENDIF
      ENDDO
      KCLDS2=KCLDS2+1

!    -------------------
      DO 2105 KK=1,KCLDS
!    -------------------
!---DETERMINE WHETHER A CLOUD LAYER KK HAS AT LEAST 1 GRID PT WITH A
!   "THICK CLOUD"
!---DETERMINE WHETHER THERE IS AT LEAST 1 GRID PT WHERE THE BOTTOM
!  OF CLOUD LAYER KK DOES NOT COINCIDE WITH THE TOP OF CLOUD LAYER
!  KK+1

      IINCL(KK)=0
      IBETCL(KK)=0
      DO K=KCLDS2,LP1
      DO I=1,IMAX
         IF (BCLDS(I,KK) .AND. &
           (K.GT.KTOPSW(I,KK+1) .AND. K.LT.KBTMSW(I,KK+1))) THEN
               IINCL(KK)=IINCL(KK)+1
         ENDIF
         IF (BCLDS(I,KK) .AND. &
           (K.GE.KBTMSW(I,KK+1) .AND. K.LE.KTOPSW(I,KK+2))) THEN
               IBETCL(KK)=IBETCL(KK)+1
         ENDIF
      ENDDO
      ENDDO
!    -------------------
2105  CONTINUE
!    -------------------

!***COMPUTE VISIBLE BAND GROUND REFLECTIVITY USING LACIS-HANSEN 
!   PARAMETERIZATION

      DO I=1,IMAX
         REFL(I)=CUVRF(I,NCLDS(I)+2)
!CCCC    REFL(I)=SALB(I)
      ENDDO

      DO IP=1,IMAX
         RRAY(IP)=0.219/(1.0+0.816*COSZRO(IP))
         REFL(IP)=RRAY(IP)+(1.0-RRAY(IP))*(1.0-RRAYAV)*REFL(IP)/ &
                           (1.0-REFL(IP)*RRAYAV)
      ENDDO

      DO KK=1,KCLDS
      DO I=1,IMAX
         PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1)) 
         PPBOT(I,KK)=PP(I,KBTMSW(I,KK+1))
      ENDDO
      ENDDO

      DO KK=1,KCLDS
      DO I=1,IMAX
         IF (PPTOP(I,KK).NE.PPBOT(I,KK)) THEN
            DPCLD(I,KK)=1.0/(PPTOP(I,KK)-PPBOT(I,KK))
         ELSE
            DPCLD(I,KK)=0.00
         ENDIF
      ENDDO
      ENDDO

!***WE NOW OBTAIN AN INDEX FOR (I,NCLDS(I)+1-KK).WE FORCE THIS
!   INDEX TO HAVE A MINIMUM VALUE IN THE (0,IMAX) RANGE.

      DO KK=1,KCLDS+1
      DO I=1,IMAX
         IF (BCLDS(I,KK)) THEN
            INDXK(I)=KK
         ELSE
            INDXK(I)=NCLDS(I)
         ENDIF
         INDX4(I,KK)=(NCLDS(I)-INDXK(I))*IMAX+I
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
!   THE REST OF THE CLOUD CALCULATION IS PERFORMED INSIDE A
!   BAND (FREQUENCY) LOOP OVER N, RUNNING FROM 1 TO NB
!-----------------------------------------------------------------------

                         DO 2301 N=1,NB

!     print *, 'NB,N=',NB,N
!-----------------------------------------------------------------------

!***INITIALIZE CR TO ZERO AND CT TO ONE***
      DO K=1,LP1
      DO I=1,IMAX
         CR(I,K)=0.00
         CT(I,K)=1.0
      ENDDO
      ENDDO

!***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS, FIRST FOR
!   VISIBLE BAND (N=1) THEN FOR NEAR IR BANDS (N=2-NB) 
!---FIRST, THE VISIBLE BAND:

!               ----------------
                IF (N == 1) THEN
!               ----------------

      DO KK=1,KCLDS
      DO I=1,IMAX
         IF (BCLDS(I,KK)) THEN
            CR(I,KK+1)=CUVRF(I,KK+1)*CAMT(I,KK+1)
            CT(I,KK+1)=1.0-CR(I,KK+1)
         ENDIF
      ENDDO
      ENDDO

!---USE THIS INDEX FOR SPECIFYING VISIBLE BAND GROUND ALBEDO 
!   AS REFL(I):

      DO I=1,IMAX
         CR(I,NCLDS(I)+2)=REFL(I)
      ENDDO

!               ----------------
                     ENDIF
!               ----------------

!---NOW, THE NEAR IR BANDS; HERE THE GROUND CAN BE HANDLED AS PART
!   OF THE CLOUD LOOP

!               ----------------
                IF (N > 1) THEN
!               ----------------

      DO I=1,IMAX 
          CR(I,2)=CIRRF(I,2)*CAMT(I,2)
          CT(I,2)=1.0-CAMT(I,2)*(CIRRF(I,2)+CIRAB(I,2))
      ENDDO

      DO KK=1,KCLDS
      DO I=1,IMAX
!       print *, 'I,KK,BCLDS,CIRRF,CAMT,CIRAB=',I,KK,
!    &           BCLDS(I,KK),CIRRF(I,KK+2),CAMT(I,KK+2),CIRAB(I,KK+2)
         IF (BCLDS(I,KK)) THEN
            CR(I,KK+2)=CIRRF(I,KK+2)*CAMT(I,KK+2)
            CT(I,KK+2)=1.0-CAMT(I,KK+2)*(CIRRF(I,KK+2)+CIRAB(I,KK+2))
         ENDIF
      ENDDO
      ENDDO

!               ----------------
                     ENDIF
!               ----------------

      DO K=1,LP1
      DO I=1,IMAX
         ALFAU(I,K)=0.00
      ENDDO
      ENDDO


!***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
!   TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
!   EACH BAND N. THE REQUIRED QUANTITIES ARE:
!      TTD(I,KTOPSW(I,K),N)  K RUNS FROM 2 TO NCLDS(I)+2: 
!      TTD(I,KBTMSW(I,K),N)  K RUNS FROM 2 TO NCLDS(I)+1: 
!      TTU(I,KTOPSW(I,K),N)  K RUNS FROM 2 TO NCLDS(I)+2:
!      AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED 
!      IN TDCL1,TDCL2,TUCL1,TDCL1I,TDCL2I,TUCLI,RESPECTIVELY, AS
!      THEY HAVE MULTIPLE USE IN THE PGM.

!---COMPUTE GATHERS
      DO KK=1,KCLDS+1
      DO I=1,IMAX
         TDCL1(I,KK)=TTD(I,KTOPSW(I,KK+1),N)
         TUCL1(I,KK)=TTU(I,KTOPSW(I,KK+1),N)
      ENDDO
      ENDDO

      DO KK=1,KCLDS
      DO I=1,IMAX
         TDCL2(I,KK)=TTD(I,KBTMSW(I,KK+1),N)
      ENDDO
      ENDDO

!---COMPUTE INVERSES
      DO KK=1,KCLDS
      DO I=1,IMAX
         TDCL2I(I,KK)=1.0/TDCL2(I,KK)
      ENDDO
      ENDDO

      DO KK=1,KCLDS+1
      DO I=1,IMAX
        TDCL1I(I,KK)=1.0/TDCL1(I,KK)
        TUCL1I(I,KK)=1.0/TUCL1(I,KK)
      ENDDO
      ENDDO


!   TCLU(LL) IS TRANSMISSION FUNCTION FROM TOP OF NEXT LOWER
!   CLOUD TO TOP OF UPPER CLOUD. TCLD(LL) IS T.F. FROM TOP
!   OF NEXT LOWER CLOUD TO BOTTOM OF UPPER CLOUD. LL=NC1 IS
!   THE LOWEST BOTTOM CLOUD (THE GROUND) ; LL=1 IS THE
!   HIGHEST UPPER CLOUD. 

         TCLU = 0.0
         TCLD = 0.0
      DO KK=1,KCLDS
      DO I=1,IMAX
         TCLU(I,KK+1)=TDCL1(I,KK+1)*TDCL1I(I,KK)*CT(I,KK+1)
         TCLD(I,KK+1)=TDCL1(I,KK+1)*TDCL2I(I,KK) 
      ENDDO
      ENDDO

!***WE DEFINE TCLD (I,1) AS TTD(I,KTOPSW(I,2),N)
      DO I=1,IMAX
         TCLD(I,1)=TDCL1(I,1)
      ENDDO

      DO I=1,IMAX
         DFNCLU(I,1)=TCLD(I,1)
      ENDDO


!   THE FOLLOWING CALCULATION IS FOR ALFAT: THE RATIO BETWEEN
!   THE DOWNWARD FLUX AT THE TOP OF THE HIGHEST CLOUD (IF
!   PRESENT) OR THE GROUND TO THE UPWARD FLUX AT THE SAME
!   LEVEL, TAKING INTO ACCOUNT MULTIPLE REFLECTIONS FROM
!   CLOUDS, IF PRESENT

!  --- Reshape 2-D arrays to 1-D ---
      DO K=1,LP1
      DO I=1,IMAX
        I1=(K-1)*IMAX+I
        CR1D(I1)=CR(I,K)
        ALFU1D(I1)=ALFAU(I,K)
        TCLD1D(I1)=TCLD(I,K)
        TCLU1D(I1)=TCLU(I,K)
      ENDDO
      ENDDO

!     print *, 'KCLDS=',KCLDS

      DO KK=1,KCLDS
!     -------------

      DO I=1,IMAX
         TEMP1(I)=CR1D(INDX4(I,KK)+2*IMAX)
         TEMP2(I)=ALFU1D(INDX4(I,KK)+IMAX)
         TEMP3(I)=TCLU1D(INDX4(I,KK)+IMAX)
         TEMP4(I)=CR1D(INDX4(I,KK)+IMAX)
         TEMP5(I)=TCLD1D(INDX4(I,KK)+IMAX)
      ENDDO
!     print *, 'TEMP1=',TEMP1

      DO I=1,IMAX
         TEMP6(I)=(TEMP1(I)+TEMP2(I))*TEMP3(I)*TEMP3(I) / &
                  (1.0-(TEMP1(I)+TEMP2(I))*TEMP4(I)*TEMP5(I)*TEMP5(I))
      ENDDO
!     print *, 'TEMP6=',TEMP6

      DO I=1,IMAX
         ALFU1D(INDX4(I,KK))=TEMP6(I)
      ENDDO

!  --- Reshape 1-D array into 2-D array -----
      DO K=1,LP1
      DO I=1,IMAX
         I1=(K-1)*IMAX+I
         ALFAU(I,K)=ALFU1D(I1)
      ENDDO
      ENDDO

!     print *, 'ALFAU=',ALFAU
!     -------------
      ENDDO

!***DEFINE ALFA FROM ALFAU(I,1) AND CR(I,2):
!***ALFA IS THE SYSTEM REFLECTION COEFFICIENT ABOVE THE TOP CLOUD
!    (OR GROUND, IF NO CLOUD AT GRID PT I )

      DO I=1,IMAX
         ALFA(I)=ALFAU(I,1)+CR(I,2)
      ENDDO

!     UPWARD FLUX ABOVE TOPMOST CLOUD
      DO I=1,IMAX
         UFNCLU(I,1)=TCLD(I,1)*ALFA(I)
      ENDDO

      DO I=1,IMAX
         TEMP2(I)=TUCL1I(I,1)*UFNCLU(I,1)
      ENDDO
!     print *, 'TEMP2=',TEMP2

      DO K=1,KJTOP      
      DO I=1,IMAX
         IF (BJTOP(I,K)) THEN
            UFN(I,K,N)=TEMP2(I)*TTU(I,K,N)
         ENDIF
      ENDDO
      ENDDO
!     print *, 'UFN=',UFN

!   CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS

      DO I=1,IMAX
         VV(I)=1.0
      ENDDO

      DO KK=1,KCLDS 
!     -------------
!     print *, 'KK,KCLDS=',KK,KCLDS
!     print *, 'TCLU=',TCLU

      DO I=1,IMAX
         IF (BCLDS(I,KK)) THEN
            UFNCLU(I,KK+1)=ALFAU(I,KK)*VV(I)*TCLD(I,KK)/TCLU(I,KK+1)
            DFNCLD(I,KK)=VV(I)*TCLD(I,KK)* &
                         TCLU(I,KK+1)*TDCL2(I,KK)*TDCL1I(I,KK+1) + &
                         UFNCLU(I,KK+1)*TCLD(I,KK+1)*CR(I,KK+1)
         ELSE
            UFNCLU(I,KK+1)=UFN(I,LP1,N)
            DFNCLD(I,KK)=DFN(I,LP1,N)
         ENDIF
      ENDDO
!     print *, 'UFNCLU=',UFNCLU
!     print *, 'DFNCLD=',DFNCLD

      DO I=1,IMAX
         VV(I)=DFNCLD(I,KK)
      ENDDO

!     print *, 'VV=',VV
!     print *, 'KTOPSW(KK+2)=',KTOPSW(:,KK+2)
!     print *, 'KBTMSW(KK+1)=',KBTMSW(:,KK+1)

      DO I=1,IMAX
         UFN(I,KTOPSW(I,KK+2),N)=UFNCLU(I,KK+1)
         DFN(I,KBTMSW(I,KK+1),N)=DFNCLD(I,KK)
      ENDDO

!     -------------
      ENDDO


!     NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS
      DO 2401 KK=1,KCLDS
!---SKIP IF THERE ARE NO SPACES BETWEEN CLOUD LAYERS KK AND KK+1,
!    FOR ANY GRID PT:
      IF (IBETCL(KK).EQ.0) GO TO 2401
         DO K=KCLDS2,LP1
         DO I=1,IMAX
            IF (BCLDS(I,KK) .AND. &
               (K.GE.KBTMSW(I,KK+1) .AND. K.LE.KTOPSW(I,KK+2))) THEN
                  UFN(I,K,N)=UFNCLU(I,KK+1)*TTU(I,K,N)*TUCL1I(I,KK+1)
                  DFN(I,K,N)=DFNCLD(I,KK)*TTD(I,K,N)*TDCL2I(I,KK)
            ENDIF
         ENDDO
         ENDDO
2401  CONTINUE


!     NOW OBTAIN DOWNWARD AND UPWARD FLUXES FOR LEVELS,IF ANY,
!     BETWEEN THE TOPS AND BOTTOMS OF CLOUDS. THE ASSUMPTION OF
!     CONSTANT HEATING RATE IN THESE REGIONS IS USED.

!***OBTAIN FLUXES AT TOP AND BOTTOM OF CLOUDS
      DO 2501 KK=1,KCLDS
!---SKIP IF THERE ARE NO "THICK CLOUDS" AT ALL IN CLOUD LEVEL KK
      IF (IINCL(KK).EQ.0) GO TO 2501
!
!***OBTAIN DOWNWARD FLUXES AT CLOUD TOPS AND UPWARD FLUXES AT
!   CLOUD BOTTOMS

      IF (KK.GT.1) THEN
         DO I=1,IMAX
            DFNCLU(I,KK)=DFN(I,KTOPSW(I,KK+1),N)
         ENDDO
      ENDIF

      DO I=1,IMAX
         UFNCLD(I,KK)=UFN(I,KBTMSW(I,KK+1),N)
      ENDDO

      DO I=1,IMAX
         TEMP1(I)=(UFNCLU(I,KK)-UFNCLD(I,KK))*DPCLD(I,KK)
         TEMP2(I)=(DFNCLU(I,KK)-DFNCLD(I,KK))*DPCLD(I,KK)
      ENDDO


      DO K=KCLDS2,LP1
      DO I=1,IMAX
         IF (BCLDS(I,KK) .AND. &
             (K.GT.KTOPSW(I,KK+1) .AND. K.LT.KBTMSW(I,KK+1))) THEN
                UFN(I,K,N)=UFNCLU(I,KK)+TEMP1(I)*(PP(I,K)-PPTOP(I,KK))
                DFN(I,K,N)=DFNCLU(I,KK)+TEMP2(I)*(PP(I,K)-PPTOP(I,KK))
         ENDIF
      ENDDO
      ENDDO

2501  CONTINUE

!-----------------------------------------------------------------------

2301                           CONTINUE

!-----------------------------------------------------------------------

                                ENDIF

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

!   CALCULATE ENTERING FLUX AT THE TOP
!   LOOP 860 SCALES THE DFN'S AND UFN'S TO THE CORRECT DFN(I,1,N)

      DO N=1,NB
      DO I=1,IMAX
         DFNTOP(I,N)=SSOLAR(I)*6.97667E5*PWTS(N)
!OLD     DFNTOP(I,N)=SSOLAR*6.97667E5*COSZRO(I)*TAUDAR(I)*PWTS(N)
      ENDDO
      ENDDO

      DO N=1,NB
      DO K=1,LP1
      DO I=1,IMAX
         DFN(I,K,N)=DFN(I,K,N)*DFNTOP(I,N)
         UFN(I,K,N)=UFN(I,K,N)*DFNTOP(I,N)
      ENDDO
      ENDDO
      ENDDO

!   SUM OVER BANDS

      DO K=1,LP1
      DO I=1,IMAX
         DFSW(I,K)=DFN(I,K,1)
         UFSW(I,K)=UFN(I,K,1)
      ENDDO
      ENDDO

      DO N=2,NB
      DO K=1,LP1
      DO I=1,IMAX
         DFSW(I,K)=DFSW(I,K)+DFN(I,K,N)
         UFSW(I,K)=UFSW(I,K)+UFN(I,K,N)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX
         FSW(I,K)=UFSW(I,K)-DFSW(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         HSW(I,K)=RADCON*(FSW(I,K+1)-FSW(I,K))/DP(I,K)
      ENDDO
      ENDDO

!-----------------------------------------------------------------------

      END SUBROUTINE SWRAD_ORIG

!#######################################################################
      SUBROUTINE SHORTWAVE_INIT

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

!---------------------------------------------------------------------

      END SUBROUTINE SHORTWAVE_INIT

!#######################################################################

      SUBROUTINE SHORTWAVE_END

      module_is_initialized = .false.

!---------------------------------------------------------------------

      END SUBROUTINE SHORTWAVE_END

!#######################################################################

      END MODULE SHORTWAVE_MOD


module grey_radiation_mod

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

!   use utilities_mod,         only: error_mesg, open_file, file_exist, &
!                                   check_nml_error, FATAL, get_my_pe, & 
!                                   close_file, set_domain, get_num_pes, &
!                                   read_data, write_data, &
!                                   check_system_clock, NOTE, &
!                                   get_domain_decomp, check_system_clock

   use             mpp_mod,   only: input_nml_file
   use             fms_mod,   only: open_namelist_file, check_nml_error,  &
                                    mpp_pe, mpp_root_pe, close_file, &
                                    write_version_number, stdlog, file_exist

   use       constants_mod,   only: stefan, cp_air, grav

   use       astronomy_mod,   only: astronomy_init, daily_mean_solar, diurnal_solar

   use    diag_manager_mod,   only: register_diag_field, send_data

   use    time_manager_mod,   only: time_type, set_date, set_time,  &
                                    get_time,    operator(+),       &
                                    operator(-), operator(/=), get_date
 
!==================================================================================
implicit none
private
!==================================================================================

! version information 

character(len=128), parameter :: version = &
'$Id: grey_radiation.F90,v 18.0.2.1 2010/08/30 20:39:47 wfc Exp $'

character(len=128), parameter :: tagname = '$Name: hiram_20101115_bw $'

logical                       :: module_is_initialized = .false.

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

! public interfaces

public :: grey_radiation_init, grey_radiation, grey_radiation_end              
!==================================================================================


! module variables
character (len=*),  parameter :: module='grey_radiation_mod'

logical :: initialized =.false.
real, parameter :: p00 = 1000.e2

real    :: solar_constant  = 1360.0
real    :: del_sol         = 0.0
! modif omp: winter/summer hemisphere
real    :: del_sw          = 0.0
real    :: ir_tau_eq       = 4.0
real    :: ir_tau_pole     = 4.0
real    :: atm_abs         = 0.2
real    :: sw_diff         = 0.0
real    :: long_pert       = 180.
real    :: del_long        =  30.
real    :: size_pert       =  0.
real    :: linear_tau      = 0.1

real    :: lat_pert        = 0.0
real    :: lon_pert        = 180.0
real    :: del_lat         = 30.0
real    :: del_lon         = 90.0
real    :: fcng_pert       = 0.0

real    :: wave_amp        = 0.0
real    :: wave_lon        = 180.0
real    :: wave_lat        = 0.0
real    :: wave_del_lon    = 30.0
real    :: wave_del_lat    = 20.0
real    :: wave_period     = 20.0
real    :: wave_env        = 80.0
logical :: wave_source     = .FALSE.
integer :: n_tau           = 4
! call to astronomy to include the Seasonal Cycle
logical :: do_season       = .false.


real, save :: pi, deg_to_rad , rad_to_deg

namelist/grey_radiation_nml/ solar_constant, del_sol, &
           ir_tau_eq, ir_tau_pole, atm_abs, sw_diff, long_pert, del_long, &
           size_pert, linear_tau, del_sw,                    &
           lat_pert, lon_pert, del_lat, del_lon, fcng_pert, &
           wave_amp, wave_lon, wave_lat, wave_del_lon,      &
           wave_del_lat, wave_period, wave_env, wave_source, do_season

!==================================================================================
!-------------------- diagnostics fields -------------------------------

integer :: id_olr, id_swdn_sfc, id_swdn_toa, id_lwdn_sfc, id_lwup_sfc, &
           id_tdt_rad, id_flux_rad, id_flux_lw, id_flux_sw, id_entrop_rad, & 
           id_tsurfgrey, id_tempgrey


character(len=14), parameter :: mod_name = 'grey_radiation'

real :: missing_value = -999.


contains



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


subroutine grey_radiation_init(axes, Time)

!-------------------------------------------------------------------------------------
integer, intent(in), dimension(4) :: axes
type(time_type), intent(in)       :: Time
!-------------------------------------------------------------------------------------
integer, dimension(3) :: half = (/1,2,4/)
integer :: ierr, io, unit, logunit
!-----------------------------------------------------------------------------------------
! read namelist and copy to logfile

#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=grey_radiation_nml, iostat=io)
    ierr = check_nml_error(io,'grey_radiation_nml')
#else   
    if ( file_exist('input.nml')) then
      unit = open_namelist_file ( )
      ierr=1
      do while (ierr /= 0)
        read  (unit, nml=grey_radiation_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'grey_radiation_nml')
      enddo
10    call close_file (unit)
    endif
#endif

call write_version_number ( version, tagname )
if ( mpp_pe() == mpp_root_pe() ) then
  logunit = stdlog()
  write (logunit, nml=grey_radiation_nml)
endif
call close_file (unit)

pi    = 4.0*atan(1.)
deg_to_rad = 2.*pi/360.
rad_to_deg = 360.0/2./pi

call astronomy_init 

initialized = .true.

!-----------------------------------------------------------------------
!------- initialize quantities for integral package -------

!       call diag_integral_field_init ('olr',    'f8.3')
!       call diag_integral_field_init ('abs_sw', 'f8.3')

!-----------------------------------------------------------------------
!------------ initialize diagnostic fields ---------------

    id_olr = &
    register_diag_field ( mod_name, 'olr', axes(1:2), Time, &
               'outgoing longwave radiation', &
               'watts/m2', missing_value=missing_value               )
    id_swdn_sfc = &
    register_diag_field ( mod_name, 'swdn_sfc', axes(1:2), Time, &
               'SW flux down at surface', &
               'watts/m2', missing_value=missing_value               )
    id_swdn_toa = &
    register_diag_field ( mod_name, 'swdn_toa', axes(1:2), Time, &
               'SW flux down at TOA', &
               'watts/m2', missing_value=missing_value               )
    id_lwup_sfc = &
    register_diag_field ( mod_name, 'lwup_sfc', axes(1:2), Time, &
               'LW flux up at surface', &
               'watts/m2', missing_value=missing_value               )

    id_lwdn_sfc = &
    register_diag_field ( mod_name, 'lwdn_sfc', axes(1:2), Time, &
               'LW flux down at surface', &
               'watts/m2', missing_value=missing_value               )

    id_tdt_rad = &
        register_diag_field ( mod_name, 'tdt_rad', axes(1:3), Time, &
               'Temperature tendency due to radiation', &
               'K/s', missing_value=missing_value               )

    id_flux_rad = &
        register_diag_field ( mod_name, 'flux_rad', axes(half), Time, &
               'Total radiative flux (positive up)', &
               'W/m^2', missing_value=missing_value               )
    id_flux_lw = &
        register_diag_field ( mod_name, 'flux_lw', axes(half), Time, &
               'Net longwave radiative flux (positive up)', &
               'W/m^2', missing_value=missing_value               )
    id_flux_sw = &
        register_diag_field ( mod_name, 'flux_sw', axes(half), Time, &
               'Net shortwave radiative flux (positive up)', &
               'W/m^2', missing_value=missing_value               )
    id_entrop_rad = &
            register_diag_field ( mod_name, 'entrop_rad', axes(1:3), Time, &
               'Entropy production by radiation', &
               '1/s', missing_value=missing_value               )

    ! rif:(09/09/09) New Diagnostics 
    id_tsurfgrey = &
    register_diag_field ( mod_name, 't_surf_rad', axes(1:2), Time, &
               'Temp surf from grey radiation', &
               'K', missing_value=missing_value               )

    id_tempgrey = &
        register_diag_field ( mod_name, 'temp_rad', axes(1:3), Time, &
               'Temperature from grey radiation', &
               'K', missing_value=missing_value               )



      module_is_initialized = .true.

return
end subroutine grey_radiation_init


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

subroutine grey_radiation (is, js, Time, Time_diag, lat, lon, phalfgrey, albedo, t_surf, t, tdt, net_surf_sw_down, surf_lw_down)

integer, intent(in)                 :: is, js
type(time_type), intent(in)         :: Time, Time_diag
real, intent(in) , dimension(:,:)   :: lat, lon, albedo
real, intent(in) , dimension(:,:)   :: t_surf
real, intent(in) , dimension(:,:,:) :: t
real, intent(in) , dimension(:,:,:) :: phalfgrey
real, intent(inout), dimension(:,:,:) :: tdt
real, intent(out), dimension(:,:)   :: net_surf_sw_down, surf_lw_down

real, dimension(size(t,2)) :: ss, ss2, solar, tau_0, solar_tau_0, p2
real, dimension(size(t,1), size(t,2))              :: b_surf
real, dimension(size(t,1), size(t,2), size(t,3))   :: b, tdt_rad, entrop_rad
real, dimension(size(t,1), size(t,2), size(t,3)+1) :: up, down, net, solar_down, flux_rad, flux_sw
real, dimension(size(t,2), size(t,3)  )   :: dtrans
real, dimension(size(t,2), size(t,3)+1)   :: tau, solar_tau
real, dimension(size(t,1), size(t,2))     :: long_forcing, olr, swin

real, dimension(size(t,1), size(t,2))     :: walker_forcing

integer :: i, j, k, n

real :: cosz1, fracday1, rrsun1
real :: dist
logical :: used

n = size(t,3)

do i=1,size(t,1)
   do j=1,size(t,2)
      long_forcing(i,j) = size_pert*exp(-(rad_to_deg*lon(i,j)-long_pert)**2./ &
                         del_long**2.)
   end do
end do

do i =  1,size(t,1)
  do j = 1,size(t,2)
    dist = SQRT(((rad_to_deg*lat(i,j) - lat_pert)/del_lat)**2                   &
         + ((rad_to_deg*lon(i,j) - lon_pert)/del_lon)**2)
    if (dist .lt. 1) then
        walker_forcing(i,j) = fcng_pert*cos(pi * dist*0.5)**2;
       else
        walker_forcing(i,j) = 0.0
     end if
  end do
end do

ss  = sin(lat(1,:))
ss2 = ss*ss
p2 = (1. - 3.*ss*ss)/4.  

solar = 0.25*solar_constant*(1.0 + del_sol*p2 + del_sw * ss)

tau_0 = ir_tau_eq +(ir_tau_pole - ir_tau_eq)*ss*ss

solar_tau_0 = (1.0 - sw_diff*ss*ss)*atm_abs

b = stefan*t*t*t*t
b_surf = stefan*t_surf*t_surf*t_surf*t_surf

do k = 1, n+1

! modif df  1-23-04: changing profile of IR absorber
! modif rif 9-05-08: changed p_half to phalf for Bgrid model 
   tau(:,k)       = tau_0(:) * (linear_tau * phalfgrey(1,1,k)/p00 + (1.0 - linear_tau) &
       * (phalfgrey(1,1,k)/p00)**4)

  solar_tau(:,k) = solar_tau_0(:)*(phalfgrey(1,1,k)/p00)**4
end do

do k = 1, n
  dtrans(:,k) = exp(-(tau(:,k+1)-tau(:,k)))
end do

up(:,:,n+1) = b_surf
do k = n,1,-1
  do j = 1, size(t,2)
    up(:,j,k) = up(:,j,k+1)*dtrans(j,k) + b(:,j,k)*(1.0 - dtrans(j,k))
  end do
end do

down(:,:,1) = 0.0
do k = 1,n
  do j =1, size(t,2)
    down(:,j,k+1) = down(:,j,k)*dtrans(j,k) + b(:,j,k)*(1.0 - dtrans(j,k))
  end do
end do

if (do_season) then !Seasonal Cycle

  do j=1,size(t,2)
    call daily_mean_solar(lat(1,j),time,cosz1,fracday1,rrsun1)
    do i=1,size(t,1)
    do k=1,n+1
      solar_down(i,j,k) = cosz1*fracday1*solar_constant*rrsun1
    end do
    end do
  end do
else 

do i = 1, size(t,1)
do j = 1, size(t,2)
  do k = 1,n+1
         solar_down(i,j,k) = (walker_forcing(i,j)+long_forcing(i,j)  &
               + solar(j))*exp(-solar_tau(j,k))
  end do
end do
end do

end if !if (do_season)

do k = 1,n+1
  net(:,:,k) = up(:,:,k)-down(:,:,k)
  flux_sw(:,:,k) = albedo(:,:)*solar_down(:,:,n+1) - solar_down(:,:,k)
  flux_rad(:,:,k) = net(:,:,k) + flux_sw(:,:,k)
end do

do k = 1,n
  tdt_rad(:,:,k) = (net(:,:,k+1) - net(:,:,k) - solar_down(:,:,k+1) + solar_down(:,:,k))  &
             *grav/(cp_air*(phalfgrey(1,1,k+1)-phalfgrey(1,1,k)))
  tdt(:,:,k) = tdt(:,:,k) + tdt_rad(:,:,k)
end do



surf_lw_down     = down(:,:,n+1)
net_surf_sw_down = solar_down(:,:,n+1)*(1. - albedo(:,:))
olr = up(:,:,1)
swin = solar_down(:,:,1)


!------- t_surf grey (t_surf_greyrad) -------
      if ( id_tsurfgrey > 0 ) then
          used = send_data ( id_tsurfgrey, t_surf, Time_diag, is, js )
      endif
!------- temp grey (temp_greyrad) -------
      if ( id_tempgrey > 0 ) then
          used = send_data ( id_tempgrey, t, Time_diag, is, js, 1 )
      endif

!------- outgoing lw flux toa (olr) -------
      if ( id_olr > 0 ) then
          used = send_data ( id_olr, olr, Time_diag, is, js )
      endif
!------- downward sw flux surface -------
      if ( id_swdn_sfc > 0 ) then
          used = send_data ( id_swdn_sfc, net_surf_sw_down, Time_diag, is, js )
      endif
!------- incoming sw flux toa -------
      if ( id_swdn_toa > 0 ) then
          used = send_data ( id_swdn_toa, swin, Time_diag, is, js )
      endif
!------- upward lw flux surface -------
      if ( id_lwup_sfc > 0 ) then
          used = send_data ( id_lwup_sfc, b_surf, Time_diag, is, js )
      endif

!------- downward lw flux surface -------
      if ( id_lwdn_sfc > 0 ) then
          used = send_data ( id_lwdn_sfc, surf_lw_down, Time_diag, is, js )
      endif
!------- temperature tendency due to radiation ------------
      if ( id_tdt_rad > 0 ) then
         used = send_data ( id_tdt_rad, tdt_rad, Time_diag, is, js, 1 )
      endif
!------- total radiative flux (at half levels) -----------
      if ( id_flux_rad > 0 ) then
         used = send_data ( id_flux_rad, flux_rad, Time_diag, is, js, 1 )
      endif
!------- longwave radiative flux (at half levels) --------
      if ( id_flux_lw > 0 ) then 
         used = send_data ( id_flux_lw, net, Time_diag, is, js, 1 )
      endif
      if ( id_flux_sw > 0 ) then
         used = send_data ( id_flux_sw, flux_sw, Time_diag, is, js, 1 )
      endif
      if ( id_entrop_rad > 0 ) then
         do k=1,n 
            entrop_rad(:,:,k) =tdt_rad(:,:,k)/t(:,:,k)*phalfgrey(1,1,n+1)/1.e5
         end do
         used = send_data ( id_entrop_rad, entrop_rad, Time_diag, is, js, 1 )
      endif

return
end subroutine grey_radiation

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

subroutine grey_radiation_end()

      module_is_initialized = .false.

end subroutine grey_radiation_end

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

end module grey_radiation_mod


!
! Cloud micro-physics package for GFDL global cloud resolving model
! The algorithms are originally based on Lin et al 1983. Many key 
! elements have been changed/improved based on several other publications
! Developer: Shian-Jiann Lin
!
module lin_cld_microphys_mod
 use mpp_mod,           only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, &
                              mpp_clock_begin, mpp_clock_end, CLOCK_ROUTINE, &
                              input_nml_file
 use diag_manager_mod,  only: register_diag_field, send_data
 use time_manager_mod,  only: time_type, get_date, get_time
 use constants_mod,     only: grav, rdgas, rvgas, cp_air, hlv, hlf, kappa
 use fms_mod,           only: write_version_number, open_namelist_file, &
                              check_nml_error, file_exist, close_file,  &
                              error_mesg, FATAL 

 implicit none
 private

 character(len=128) :: version = '$Id: lin_cloud_microphys.F90,v 17.0.4.3.2.1.4.4.2.2 2010/09/03 22:17:11 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

 public  lin_cld_microphys_driver, lin_cld_microphys_init, lin_cld_microphys_end, sg_conv
 public  qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d
 real             :: missing_value = -1.e10
 logical          :: module_is_initialized = .false.
 character(len=17) :: mod_name = 'lin_cld_microphys'

!==== fms constants ====================
!real :: rdgas = 287.04
!real :: rvgas = 461.50
 real, parameter :: cp    = cp_air          ! heat capacity at constant pressure (j/kg/k)
 real, parameter :: eps   = rdgas/rvgas     ! = 0.621971831
 real, parameter :: zvir  = rvgas/rdgas-1.  ! = 0.607789855
 real, parameter :: latv  = hlv             ! = 2.500e6
 real, parameter :: lati  = hlf             ! = 3.34e5
 real, parameter :: lats  = hlv+hlf         ! = 2.834E6
!==== fms constants ====================

 real, parameter :: qsmin  = 1.e-9       ! absolute min qstar for vapor saturation
 real, parameter :: qrmin  = 1.e-9
 real, parameter :: qvmin  = 1.e-20      ! min value for water vapor (treated as zero)
 real, parameter :: qcmin  = 1.e-12      ! min value for cloud condensates
 real, parameter :: sfcrho = 1.20        ! surface air density
 real, parameter :: vmin   = 1.e-2       ! minimum fall speed for rain/graupel
 real, parameter :: tice   = 273.16
 real, parameter :: tice2  = 275.16
 real, parameter :: rhor   = 1.0e3  ! LFO83

 real :: cracs, csacr, cgacr, cgacs, acco(3,4), csacw,          &
         craci, csaci, cgacw, cgaci, cracw, cssub(5), cgsub(5), &
         crevp(5), cgfr(2), csmlt(5), cgmlt(5)
 real :: rmi50, es0, ces0, c1brg, c2brg

 real, parameter:: dz_min = 1.e-2
! Derived variables:
!real :: ccn   = 150.     ! these variables have been made thread-private
!real :: c_praut
!real :: h_var = 0.

 real :: dts, rdts, pie  ! these variables have been left unchanged
 real :: lcp, icp, tcp, rgrav
 real :: fac_rc
 real :: mp_count = 0.

 logical :: do_setup=.true.
 logical :: master 
 logical :: g_sum_initialized
 real, allocatable, dimension(:,:) :: l_area

 real, allocatable:: vt_r(:,:,:), vt_s(:,:,:), vt_g(:,:,:), vt_i(:,:,:)
 real, allocatable:: prec0(:,:), rain0(:,:), snow0(:,:), ice0(:,:), graupel0(:,:)
 real, allocatable:: prec1(:,:), prec_mp(:,:), cond(:,:) 
 real, allocatable:: table(:), table2(:), table3(:), tablew(:), des(:), des2(:), des3(:), desw(:)

 integer:: isc, iec, jsc, jec
 integer:: id_vtr, id_vts,  id_vtg, id_vti, id_rain, id_snow, id_graupel, &
           id_ice, id_prec, id_cond

 real, parameter :: dt_fr = 5.      ! homogeneous freezing of all cloud water at t_wfr - dt_fr
 real, parameter :: t_wfr = tice-40.-dt_fr/2.  !  -42.5 deg C
!integer, parameter:: ng    = 3     ! Number of ghost zones required
 integer, parameter:: ng    = 0     ! NO ghost zones required as "area" is passed from the phys driver
 integer :: lin_cld_mp_clock   ! clock for timing of driver routine

 real :: t_water = 185.  ! Min temperature for super cooled cloud water evap-condensation
                         ! qs over water may be accurate only down to -80 C with ~10% uncertainty
!----------------------
! namelist  parameters:
!----------------------
 real :: t_min   = 175.  ! Min temperature for ice-phase micro phys
 real :: mp_time = 150.  ! maximum micro-physics time step (sec)

! The following 3 time scales are for terminal falls
 real :: tau_i  =   5.   ! (sec) cloud ice melt
 real :: tau_s  =  90.   ! snow melt
 real :: tau_g  = 180.   ! graupel melt

 real :: tau_l2v = 90.   ! cloud water evaporation time scale
 real :: tau_v2l = 90.   ! cloud water condensation time scale
 real :: tau_ice = 300.  ! ice initiation time-scale
 real :: tau_gra = 1800. ! Grapuel sub/dep -- make it a slow process 

! c90: dx~100km or coarser:  rh_adj = 0.75, dw_land = 0.20
! c2000: dx~5km :            rh_adj = 0.90, dw_land = 0.075; dw_ocean = 0.05
! c180-c360: dx~ 10-50 km:
 real :: rh_adj   = 0.75  ! RH threshold for the instant evaporation/sublimation
 real :: dw_land  = 0.15  ! subgrid deviation/variability over land 
 real :: dw_ocean = 0.15  ! for ocean
 real :: dw_high  = 0.10  ! limit on h_var for "high" clouds

 real :: ccn_o = 100.    
 real :: ccn_l = 270.    
 real :: rthresh = 8.4e-6     ! critical cloud drop radius (micro m)

!-------------------------------------------------------------
 real :: qi_gen  = 1.0E-6    ! ice initiation density (kg/m**3) threshold
 real :: qi0_crt = 8.0e-5    ! ice  --> snow autocon threshold density
 real :: qr0_crt = 2.0e-4    ! rain --> snow or graupel/hail density threshold
                             ! LFO used mixing ratio = 1.E-4 (hail in LFO)
! * pigen:   qimin = qi_init * exp( beta_init*(tice-t) )  ! general form
!real :: qi_init = 4.808E-7  ! 
!real :: beta_init = 0.133

 real :: c_psaut = 1.0e-3   ! autoconversion rate: cloud_ice -> snow
 real :: c_psaci = 0.1      ! accretion: cloud ice --> snow (was 0.1 in Zetac)
 real :: c_piacr = 0.1      ! accretion: rain --> ice:
 real :: c_cracw = 1.0      ! rain accretion efficiency

! Decreasing  clin to reduce csacw (so as to reduce cloud water ---> snow)
 real:: alin = 842.0
 real:: clin = 4.8

!-----------------
! Graupel control:
!-----------------
!real :: qs0_crt = 5.0e-3   ! ximing ratio: snow --> graupel threshold (6.0e-4 in Purdue Lin scheme)
 real :: qs0_crt = 6.0e-3   ! snow --> graupel denisty threshold 
 real :: c_pgacs = 1.0e-3   ! snow --> graupel "accretion" eff. (was 0.1 in Zetac)

! fall velocity tuning constants:
 real :: den_ref = sfcrho   ! Reference (surface) density for fall speed
                            ! Larger value produce larger fall speed
 real :: vr_fac = 1.
 real :: vs_fac = 1.
 real :: vg_fac = 1.
 real :: vi_fac = 1.

 logical :: use_deng_mace = .true.       ! Helmfield-Donner ice speed
 logical :: do_subgrid_z = .true.       ! 2X resolution sub-grid saturation/cloud scheme
 logical :: add_snow2iwt = .true.      
 logical :: use_ccn      = .true.
 logical :: use_ppm      = .true.
 logical :: mono_prof = .false.          ! perform terminal fall with mono ppm scheme
 logical :: mp_debug = .false.
 logical :: mp_print = .true.


 real :: p_crt   = 200.E2   ! 
 integer :: k_moist = 99

 namelist /lin_cld_microphys_nml/mp_time, t_min, tau_s, tau_i, tau_g, dw_land, dw_ocean,  &
                      dw_high, vr_fac, vs_fac, vg_fac, vi_fac,  qi_gen,       &
                      qs0_crt, qi0_crt, qr0_crt,   &
                      rh_adj, den_ref, use_deng_mace, use_ccn, do_subgrid_z,  &
                      rthresh, ccn_l, ccn_o,  &
                      c_piacr, tau_ice, tau_l2v, tau_v2l,     &
                      c_psaut, c_psaci, c_pgacs,  &
                      c_cracw, k_moist, p_crt, alin, clin,    &
                      add_snow2iwt, use_ppm, mono_prof, mp_debug, mp_print

 contains
 

  subroutine lin_cld_microphys_driver(qv,    ql,    qr,    qi,    qs,    qg,    qa,  &
                               qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt,      & 
                               pt_dt, pt, p3, dz,  delp, area, dt_in,                &
                               land,  rain, snow, ice, graupel,                      &
                               hydrostatic, phys_hydrostatic,                        &
                               iis,iie, jjs,jje, kks,kke, ktop, kbot, time)

  type(time_type), intent(in):: time
  logical,         intent(in):: hydrostatic, phys_hydrostatic
  integer,         intent(in):: iis,iie, jjs,jje  ! physics window
  integer,         intent(in):: kks,kke           ! vertical dimension
  integer,         intent(in):: ktop, kbot        ! vertical compute domain
  real,            intent(in):: dt_in

  real, intent(in   ), dimension(:,:)  :: area
  real, intent(in   ), dimension(:,:)  :: land  !land fraction
  real, intent(out  ), dimension(:,:)  :: rain, snow, ice, graupel
  real, intent(in   ), dimension(:,:,:):: p3, delp, dz    ! p3 not used
  real, intent(in   ), dimension(:,:,:):: pt, qv, ql, qr, qi, qs, qg, qa
  real, intent(inout), dimension(:,:,:):: pt_dt,  qa_dt
  real, intent(inout), dimension(:,:,:):: qv_dt, ql_dt, qr_dt, qi_dt,  &
                                          qs_dt, qg_dt


! local:
  logical used
  real    :: mpdt, rdt, convt, tot_prec
  integer :: i,j,k
  integer :: is,ie, js,je  ! physics window
  integer :: ks,ke         ! vertical dimension
  integer :: seconds, days, ntimes
  integer :: ioff, joff

  is = 1
  js = 1
  ks = 1
  ie = iie-iis+1
  je = jje-jjs+1
  ke = kke-kks+1
  ioff = iis - is
  joff = jjs - js

  call mpp_clock_begin (lin_cld_mp_clock)

! tendency zero out for am moist processes should be done outside the driver

     mpdt = min(dt_in, mp_time)
      rdt = 1. / dt_in
   ntimes = nint( dt_in/mpdt )
! small time step:
      dts = dt_in / real(ntimes)
     rdts = 1./dts

  call get_time (time, seconds, days)

!rab  if ( mp_debug ) then
!rab       call prt_maxmin('T_b_mp',    pt, is, ie, js, je, 0, kbot, 1., master)
!rab       call prt_maxmin('qg_dt_b_mp',  qg_dt, is, ie, js, je, 0, kbot, 1., master)
!rab  endif


  do j=js, je
     do i=is, ie
        graupel(i,j) = 0.
           rain(i,j) = 0.
           snow(i,j) = 0.
            ice(i,j) = 0.
     enddo
  enddo
  cond(iis:iie, jjs: jje) = 0

  do j=js,je
     call mpdrv( delp, pt, qv, ql, qr, qi, qs, qg, qa, dz,  &
                 is, ie, js, je, ks, ke, ktop, kbot, j, dt_in,  & 
                 ntimes, rain(:,j), snow(:,j), graupel(:,j), &
                 ice(:,j), cond(iis:iie,j+joff), land(:,j),  &
                 pt_dt, qv_dt, ql_dt, qr_dt, qi_dt,    &
                 qs_dt, qg_dt, qa_dt )
  enddo

! no clouds allowed above ktop
   if ( ks < ktop ) then
      do k=ks, ktop
         do j=js,je
            do i=is,ie
!              qa(i,j,k) = 0.
               qa_dt(i,j,k) = -qa(i,j,k) * rdt
            enddo
         enddo
      enddo
   endif

#ifdef SIM_PHYS
   if ( id_vtr> 0 ) used=send_data(id_vtr, vt_r, time)
   if ( id_vts> 0 ) used=send_data(id_vts, vt_s, time)
   if ( id_vtg> 0 ) used=send_data(id_vtg, vt_g, time)
   if ( id_vts> 0 ) used=send_data(id_vti, vt_i, time)
#else
   if ( id_vtr> 0 ) used=send_data(id_vtr, vt_r(iis:iie,jjs:jje,:), time, iis, jjs)
   if ( id_vts> 0 ) used=send_data(id_vts, vt_s(iis:iie,jjs:jje,:), time, iis, jjs)
   if ( id_vtg> 0 ) used=send_data(id_vtg, vt_g(iis:iie,jjs:jje,:), time, iis, jjs)
   if ( id_vts> 0 ) used=send_data(id_vti, vt_i(iis:iie,jjs:jje,:), time, iis, jjs)
#endif

! Convert to mm/day
   convt = 86400.*rdt*rgrav
   do j=js,je
      do i=is,ie
            rain(i,j) =    rain(i,j) * convt
            snow(i,j) =    snow(i,j) * convt
             ice(i,j) =     ice(i,j) * convt
         graupel(i,j) = graupel(i,j) * convt
         prec_mp(i,j) =    rain(i,j) + snow(i,j) + ice(i,j) + graupel(i,j)
      enddo
   enddo
   prec_mp(iis:iie,jjs:jje) = rain(is:ie,js:je) + snow(is:ie,js:je) + &
                              ice(is:ie,js:je) + graupel(is:ie,js:je)

   if ( id_cond>0 ) then
        
        do j=jjs,jje
           do i=iis,iie
              cond(i,j) = cond(i,j)*rgrav
           enddo
        enddo
#ifdef SIM_PHYS
        used=send_data(id_cond, cond, time)
#else
        used=send_data(id_cond, cond(iis:iie,jjs:jje), time, iis, jjs)
#endif
   endif

   if ( id_snow>0 ) then
#ifdef SIM_PHYS
        used=send_data(id_snow,    snow,    time)
#else
        used=send_data(id_snow,    snow,    time, iis, jjs)
#endif
        if ( seconds==0 .and. mp_print ) then
             tot_prec = g_sum(snow, is, ie, js, je, ng, area, 1) 
             if(master) write(*,*) 'mean snow=', tot_prec

        endif
        snow0(:,:) = snow0(:,:) + snow(:,:)
   endif

   if ( id_graupel>0 ) then
#ifdef SIM_PHYS
        used=send_data(id_graupel, graupel, time)
#else
        used=send_data(id_graupel, graupel, time, iis, jjs)
#endif
        if ( seconds==0 .and. mp_print ) then
             tot_prec = g_sum(graupel, is, ie, js, je, ng, area, 1) 
             if(master) write(*,*) 'mean graupel=', tot_prec
        endif
        graupel0(:,:) = graupel0(:,:) + graupel(:,:)
   endif

   if ( id_ice>0 ) then
#ifdef SIM_PHYS
        used=send_data(id_ice, ice, time)
#else
        used=send_data(id_ice, ice, time, iis, jjs)
#endif
        if ( seconds==0 .and. mp_print ) then
             tot_prec = g_sum(ice, is, ie, js, je, ng, area, 1) 
             if(master) write(*,*) 'mean ice_mp=', tot_prec
        endif
        ice0(:,:) = ice0(:,:) + ice(:,:)
   endif

   if ( id_rain>0 ) then
#ifdef SIM_PHYS
        used=send_data(id_rain,    rain,    time)
#else
        used=send_data(id_rain,    rain,    time, iis, jjs)
#endif
        if ( seconds==0 .and. mp_print ) then
             tot_prec = g_sum(rain, is, ie, js, je, ng, area, 1) 
             if(master) write(*,*) 'mean rain=', tot_prec
        endif
        rain0(:,:) = rain0(:,:) + rain(:,:)
   endif
   

   if ( id_prec>0 ) then
#ifdef SIM_PHYS
        used=send_data(id_prec, prec_mp, time)
#else
        used=send_data(id_prec, prec_mp(iis:iie,jjs:jje), time, iis, jjs)        ! kerr
#endif
   endif

!----------------------------------------------------------------------------
        do j=jjs,jje
           do i=iis,iie        
              prec0(i,j) = prec0(i,j) + prec_mp(i,j)
              prec1(i,j) = prec1(i,j) + prec_mp(i,j)
           enddo
        enddo
        mp_count = mp_count + 1.

        if ( seconds==0 .and. mp_print ) then
             tot_prec = g_sum(prec1*dt_in/86400., is, ie, js, je, ng, area, 1) 
             if(master) write(*,*) 'Daily prec_mp=', tot_prec
!            call prt_maxmin('prec_mp', prec1*dt_in/86400., is, ie, js, je, 0, 1, 1., master)
             prec1(:,:) = 0.
        endif
!----------------------------------------------------------------------------


!rab  if ( mp_debug ) then
!rab       call prt_maxmin('T_a_mp',    pt, is, ie, js, je, 0, kbot, 1., master)
!rab       call prt_maxmin('qg_dt_a_mp',  qg_dt, is, ie, js, je, 0, kbot, 1., master)
!rab       call prt_maxmin('prec', prec_mp, is, ie, js, je, 0,    1, 1., master)
!rab  endif

   call mpp_clock_end (lin_cld_mp_clock)

 end subroutine lin_cld_microphys_driver



 subroutine mpdrv( delp, pt, qv, ql, qr, qi, qs, qg, qa, dz,     &
                   is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes,  & 
                   rain, snow, graupel, ice, &
                   cond, land, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt,    &
                   qs_dt, qg_dt, qa_dt )

!-------------------------------------------------------------------
!  lin et al., 1983, jam, 1065-1092, and
!  rutledge and hobbs, 1984, jas, 2949-2972
!-------------------------------------------------------------------
! terminal fall is handled lagrangianly by conservative fv algorithm
!
! pt: temperature (k)
! 6 water species:
! 1) qv: water vapor (kg/kg)
! 2) ql: cloud water (kg/kg)
! 3) qr: rain        (kg/kg)
! 4) qi: cloud ice   (kg/kg)
! 5) qs: snow        (kg/kg)
! 6) qg: graupel     (kg/kg)

  integer,         intent(in):: j, is,ie, js,je, ks,ke
  integer,         intent(in):: ntimes, ktop, kbot
  real,            intent(in):: dt_in

  real, intent(in), dimension(is:ie,js:je,ks:ke) :: delp
  real, intent(in), dimension(is:ie):: land  !land fraction
  real, intent(in   ), dimension(is:ie,js:je,ks:ke):: pt, qv, ql, qr, qi, qs, qg, qa, dz
  real, intent(inout), dimension(is:ie,js:je,ks:ke):: pt_dt,  qa_dt,  &
                                            qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt
  real, intent(out), dimension(is:ie):: rain, snow, ice, graupel, cond
!----------
! local var
!----------
  real, dimension(ktop:kbot):: qvz, qlz, qrz, qiz, qsz, qgz, qaz, &
                               vtiz, vtsz, vtgz, vtrz, &
                               dp1, qv0, ql0, qr0, qi0, qs0, qg0, qa0, t0, den, &
                               den0, tz, p1, dz0, dz1, denfac

  real :: r1, s1, i1, g1, rdt, omq
  real :: cpaut, ccn, c_praut
  real :: dt_rain
  real :: h_var
  integer :: i,k,n
! real:: x, pexp
! pexp(x) = 1.+x*(1.+x*(0.5+x/6.*(1.+x*(0.25+0.05*x))))

   dt_rain = dts * 0.5

   rdt = 1. / dt_in

   cpaut = 0.55*0.104*grav/1.717e-5

   do 2000 i=is, ie

   do k=ktop, kbot
       t0(k) = pt(i,j,k)
       tz(k) = t0(k) 
!-----------------------------------
      qvz(k) = max(qvmin, qv(i,j,k))
!-----------------------------------
      qlz(k) = ql(i,j,k)
      qrz(k) = qr(i,j,k)
      qiz(k) = qi(i,j,k)
      qsz(k) = qs(i,j,k)
      qgz(k) = qg(i,j,k)
      qa0(k) = qa(i,j,k)
      qaz(k) = 0.  
      dz0(k) = dz(i,j,k)
!--------------------------
         omq = 1. - (qvz(k)+qlz(k)+qrz(k)+qiz(k)+qsz(k)+qgz(k))
      dp1(k) = delp(i,j,k) * omq         ! dry air mass * grav
     den0(k) = -dp1(k)/(grav*dz0(k))     ! density of dry air
       p1(k) = den0(k)*rdgas*t0(k)       ! dry pressure
!------------------------------
! convert to dry mixing ratios:
!------------------------------
         omq = 1. / omq
      qvz(k) = qvz(k)*omq
      qv0(k) = qvz(k)
      qlz(k) = qlz(k)*omq
      ql0(k) = qlz(k)
      qrz(k) = qrz(k)*omq
      qr0(k) = qrz(k)
      qiz(k) = qiz(k)*omq
      qi0(k) = qiz(k)
      qsz(k) = qsz(k)*omq
      qs0(k) = qsz(k)
      qgz(k) = qgz(k)*omq
      qg0(k) = qgz(k)
   enddo

! Compute dry pressure for non-hydrostatic case
!-----------------------------------------------
!  if ( .not. phys_hydrostatic ) then
!      do k=ktop, kbot
!         p1(k) = den0(k)*rdgas*t0(k)
!      enddo
!  endif
!-----------------------------------------------

! Based on Klein Eq. 15
   ccn = (ccn_l*land(i) + ccn_o*(1.-land(i))) * 1.e6
   if ( use_ccn ) then
       ccn = ccn * rdgas*tz(kbot)/p1(kbot)
   endif
   c_praut = cpaut * (ccn*rhor)**(-1./3.)

! Total water subgrid deviation in horizontal direction
   h_var = dw_land*land(i) + dw_ocean*(1.-land(i))

!-------------------------
! * fix all negatives
!-------------------------

 call neg_adj(ktop, kbot, p1, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz)

 do 1000 n=1,ntimes

   do k=ktop, kbot
         dz1(k) = dz0(k)*tz(k)/t0(k) 
         den(k) = den0(k)*dz0(k)/dz1(k)
      denfac(k) = sqrt(sfcrho/den(k))
   enddo

!-------------------------------------------
! Time-split warm rain processes: first pass
!-------------------------------------------
!                                       call timing_on (" warm_rain")
   call warm_rain(dt_rain, ktop, kbot, p1, dp1, dz1, tz, qvz, qlz, qrz, p1, den, denfac, ccn, c_praut, h_var, vtrz, r1)
!                                       call timing_off(" warm_rain")
   rain(i) = rain(i) + r1

!------------------------------------------------
! * sedimentation of cloud ice, snow, and graupel
!------------------------------------------------
!                                       call timing_on (" terminal_fall")
   call fall_speed(ktop, kbot, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz)

   call terminal_fall ( dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, p1, &
                        dz1, dp1, den, vtgz, vtsz, vtiz,    &
                        r1, g1, s1, i1 )
!                                       call timing_off(" terminal_fall")

      rain(i) = rain(i)    + r1  ! from melted snow & ice that reached the ground
      snow(i) = snow(i)    + s1
   graupel(i) = graupel(i) + g1
       ice(i) = ice(i)     + i1

!-------------------------------------------
! Time-split warm rain processes: 2nd pass
!-------------------------------------------
!                                       call timing_on (" warm_rain")
   call warm_rain(dt_rain, ktop, kbot, p1, dp1, dz1, tz, qvz, qlz, qrz, p1, den, denfac, ccn, c_praut, h_var, vtrz, r1)
!                                       call timing_off(" warm_rain")
   rain(i) = rain(i) + r1

!-------------------------
! * ice-phase microphysics
!-------------------------

!                                       call timing_on (" icloud")
   call icloud( ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz,  &
                dp1, den, denfac, vtsz, vtgz, vtrz, qaz, h_var )
!                                       call timing_off(" icloud")
1000  continue  ! sub-cycle

   do k = ktop, kbot
               omq = dp1(k) / delp(i,j,k)
      pt_dt(i,j,k) = pt_dt(i,j,k) + rdt*(tz(k)- t0(k)) *omq
      qv_dt(i,j,k) = qv_dt(i,j,k) + rdt*(qvz(k)-qv0(k))*omq
      ql_dt(i,j,k) = ql_dt(i,j,k) + rdt*(qlz(k)-ql0(k))*omq
      qr_dt(i,j,k) = qr_dt(i,j,k) + rdt*(qrz(k)-qr0(k))*omq
      qi_dt(i,j,k) = qi_dt(i,j,k) + rdt*(qiz(k)-qi0(k))*omq
      qs_dt(i,j,k) = qs_dt(i,j,k) + rdt*(qsz(k)-qs0(k))*omq
      qg_dt(i,j,k) = qg_dt(i,j,k) + rdt*(qgz(k)-qg0(k))*omq
      qa_dt(i,j,k) = qa_dt(i,j,k) + rdt*( qaz(k)/real(ntimes)-qa0(k))
!        dz(i,j,k) = dz1(k)
   enddo

!-----------------
! fms diagnostics:
!-----------------
   if ( id_cond>0 ) then
     do k=ktop,kbot                   ! total condensate
        cond(i) = cond(i) + dp1(k)*(qlz(k)+qrz(k)+qsz(k)+qiz(k)+qgz(k))
     enddo
   endif

   if ( id_vtr> 0 ) then
        do k=ktop, kbot
           vt_r(i,j,k) = vtrz(k)
        enddo
   endif
   if ( id_vts> 0 ) then
        do k=ktop, kbot
           vt_s(i,j,k) = vtsz(k)
        enddo
   endif
   if ( id_vtg> 0 ) then
        do k=ktop, kbot
           vt_g(i,j,k) = vtgz(k)
        enddo
   endif
   if ( id_vts> 0 ) then
        do k=ktop, kbot
           vt_i(i,j,k) = vtiz(k)
        enddo
   endif

2000  continue

 end subroutine mpdrv



 subroutine warm_rain( dt, ktop, kbot, p1, dp, dz, tz, qv, ql, qr, pm,  &
                       den, denfac, ccn, c_praut, h_var, vtr, r1)

 integer, intent(in):: ktop, kbot
 real,    intent(in):: dt                    ! time step (s)
 real,    intent(in), dimension(ktop:kbot):: p1, dp, dz, pm, den, denfac
 real,    intent(in):: ccn, c_praut, h_var
 real, intent(inout), dimension(ktop:kbot):: tz, qv, ql, qr, vtr
 real, intent(out):: r1
 
! local:
 real, parameter:: so3 = 7./3.
 real, dimension(ktop:kbot):: dl
 real, dimension(ktop:kbot+1):: ze, zt
 real:: sink, dq, qc, q_plus, q_minus
 real:: rho0, qden
 real:: zs = 0.
 real:: dt5
 integer k
!-----------------------------------------------------------------------
! fall velocity constants:
!-----------------------------------------------------------------------
 real, parameter :: vconr = 2503.23638966667
 real, parameter :: normr = 25132741228.7183
 real, parameter :: thr=1.e-10
 logical no_fall

!---------------------
! warm-rain processes:
!---------------------

  dt5 = 0.5*dt

!------------------------
! Terminal speed of rain:
!------------------------

  call check_column(ktop, kbot, qr, no_fall)
  if ( no_fall ) then
       vtr(:) = vmin
       r1 = 0.
       go to 999   ! jump to auto-conversion
  endif

  if ( den_ref < 0. ) then
       rho0 = -den_ref*den(kbot) 
  else
       rho0 = den_ref   ! default=1.2
  endif

  do k=ktop, kbot
     qden = qr(k)*den(k)
     if ( qr(k) < thr ) then
         vtr(k) = vmin
     else
         vtr(k) = max(vmin, vr_fac*vconr*sqrt(min(10., rho0/den(k)))*exp(0.2*log(qden/normr)))
     endif
  enddo

  ze(kbot+1) = zs
  do k=kbot, ktop, -1
     ze(k) = ze(k+1) - dz(k)  ! dz<0
  enddo
  zt(ktop) = ze(ktop)


 do k=ktop+1,kbot
    zt(k) = ze(k) - dt5*(vtr(k-1)+vtr(k))
 enddo
 zt(kbot+1) = zs - dt*vtr(kbot)

 do k=ktop,kbot
    if( zt(k+1)>=zt(k) ) zt(k+1) = zt(k) - dz_min
 enddo

! Evap_acc of rain for 1/2 time step
  call revap_racc( ktop, kbot, dt5, tz, qv, ql, qr, pm, den, denfac, h_var )

  if ( use_ppm ) then
       call lagrangian_fall_ppm(ktop, kbot, zs, ze, zt, dp, qr, r1, mono_prof)
  else
       call lagrangian_fall_pcm(ktop, kbot, zs, ze, zt, dp, qr, r1)
  endif

! Finish the remaing 1/2 time step
  call revap_racc( ktop, kbot, dt5, tz, qv, ql, qr, pm, den, denfac, h_var )

999  continue

!-------------------
! * auto-conversion
!-------------------
! Assuming linear subgrid vertical distribution of cloud water
! following Lin et al. 1994, MWR

  call linear0_prof( kbot-ktop+1, p1(ktop), ql(ktop), dl(ktop), .true., h_var )

  qc = fac_rc*ccn

! * Auto conversion

  do k=ktop,kbot
    if ( tz(k) > t_wfr ) then
!----------------------------------------------------------------
!    As in Klein's GFDL AM2 stratiform scheme.
!    But CCN is formulted as CCN = CCN_surface * (den/den_surface)
!----------------------------------------------------------------
      q_plus = ql(k) + dl(k)
      if ( q_plus > qc ) then
              sink =  dt*c_praut*den(k)
           q_minus = ql(k) - dl(k)
           if ( qc > q_minus ) then
                dq = 0.25*(q_plus-qc)**2 / (dl(k) + qrmin)
! autoconversion rate computed using average of qc and q_plus
               sink = min(dq, sink*(q_plus-qc)/(2.*dl(k)+qrmin)*(0.5*(qc+q_plus))**so3)
           else                                         ! qc < q_minus
               sink = min(ql(k)-qc, sink*ql(k)**so3)
           endif
           ql(k) = ql(k) - sink
           qr(k) = qr(k) + sink
      endif
    endif
  enddo


 end subroutine warm_rain


 subroutine revap_racc( ktop, kbot, dt, tz, qv, ql, qr, pm, den, denfac, h_var )
 integer, intent(in):: ktop, kbot
 real,    intent(in):: dt                 ! time step (s)
 real,    intent(in), dimension(ktop:kbot):: pm, den, denfac
 real,    intent(in)                      :: h_var
 real, intent(inout), dimension(ktop:kbot):: tz, qv, qr, ql
! local:
 real:: qsat, dqsdt, evap, tsq, qden, q_plus, q_minus, sink
 real:: qpz, dq, dqh, tin
 integer k

! Using only the assumed horizontal variance; vertical is too temperature dependent (not random)
! to be suitable for using a "constant" qsat
  do k=ktop,kbot
   if ( tz(k) > t_wfr ) then
     if ( qr(k) > qrmin ) then
            qden = qr(k)*den(k)
             tin = tz(k) - lcp*ql(k) ! presence of clouds suppresses the rain evap
            qsat = ws1d(tin, pm(k), dqsdt)
             qpz = qv(k) + ql(k)
             dqh = h_var*max(qpz, qvmin)
         q_minus = qpz - dqh
         q_plus  = qpz + dqh

! qsat must be > q_minus to activate evaporation
! qsat must be < q_plus  to activate accretion

!-------------------
! * Rain evaporation
!-------------------
         if ( qsat > q_minus ) then
              if ( qsat > q_plus ) then
                   dq = qsat - qpz
              else
! q_minus < qsat < q_plus
! dq == dqh if qsat == q_minus
                  dq = 0.25*(q_minus-qsat)**2 / dqh
              endif
               tsq = tin**2
              evap =  crevp(1)*tsq*dq*(crevp(2)*sqrt(qden)+crevp(3)*exp(0.725*log(qden)))   & 
                   / (crevp(4)*tsq + crevp(5)*qsat*den(k))
              evap = min( qr(k), dt*evap, dq/(1.+lcp*dqsdt) )
             qr(k) = qr(k) - evap
             qv(k) = qv(k) + evap
             tz(k) = tz(k) - evap*lcp
         endif

!-------------------
! * Accretion: pracc
!-------------------
         if ( ql(k)>qrmin  .and.  qsat<q_plus ) then
               sink = dt*denfac(k)*cracw*qden**0.95
               sink = sink/(1.+sink)*ql(k)
              ql(k) = ql(k) - sink
              qr(k) = qr(k) + sink
         endif

     endif   ! rain existed
   endif   ! warm region
  enddo

 end subroutine revap_racc



 subroutine linear0_prof(km, p1,  q, dm, b_var, h_var)
 integer, intent(in):: km
 real, intent(in ):: p1(km),  q(km)
 real, intent(out):: dm(km)
 logical, intent(in):: b_var
 real, intent(in):: h_var
!
 real :: dq(km)
 integer:: k

! Construct *positive definite* linear vertical profile for "PDF" like computation
! e.g., auto conversion
! Edges: qE = q +/- dm

 do k=2,km
    dq(k) = 0.5*(q(k) - q(k-1))
 enddo

! Top:
 dm(1) = dq(2)

! Interior:
 do k=2,km-1
                            dm(k) = 0.5*(dq(k) + dq(k+1))
! local extrema:
    if(dq(k)*dq(k+1) <= 0.) dm(k) = min(abs(dm(k)), abs(dq(k)), abs(dq(k+1)))
 enddo

! Bottom:
 dm(km) = dq(km)

 do k=1,km
! Apply positive definite limiter:
! also taking absolute value (since this is not for transport)
    dm(k) = min( abs(dm(k)), q(k) )
 enddo

 if ( b_var ) then
! impose a presumed background horizontal variability that is proportional to the value itself
 do k=1,km
    dm(k) = max( dm(k), h_var*q(k) )
 enddo
 endif

 end subroutine linear0_prof


 subroutine linear_prof(km, q, dm, id)
 integer, intent(in):: km, id
 real, intent(in )::  q(km)
 real, intent(out):: dm(km)
!
 real :: dq(km)
 integer:: k

! Construct *positive definite* linear profile
! upper edge:   qL = q - dm
! lower edge:   qR = q + dm

 do k=2,km
    dq(k) = q(k) - q(k-1)
 enddo

 dm(1) = 0.5*dq(2)
 if ( dm(1) > 0. ) dm(1) = min( dm(1), q(1) )

 do k=2,km-1
    if ( dq(k)*dq(k+1) <= 0. ) then
!        dm(k) = 0.
         dm(k) = 0.5*(dq(k) + dq(k+1))
         dm(k) = 0.5*sign( min(abs(dm(k)), abs(dq(k)), abs(dq(k+1))), dm(k) )
    else
       dm(k) = 0.25*(dq(k) + dq(k+1))
       if ( dm(k) > 0. ) then 
            dm(k) = min( dm(k),  q(k) )
       else  
            dm(k) = max( dm(k), -q(k) )
       endif
    endif
 enddo

 dm(km) = 0.5*dq(km)
 if ( dm(km) < 0. ) dm(km) = max( dm(km), -q(km) )

 if ( id==0 ) then
! Take absolute value; to be used for subgrid auto conversion computation
! (vertically symmetrical)
      do k=1,km
         dm(k) = abs(dm(k))
      enddo
 endif


 end subroutine linear_prof


 subroutine icloud(ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, &
                   den, denfac, vts, vtg, vtr, qak, h_var)

!----------------------------------------------------
! Bulk cloud micro-physics; processes splitting
! with some un-split sub-grouping
! Time implicit (when possible) accretion and autoconversion
! Author: Shian-Jiann Lin, GFDL
!-------------------------------------------------------

 integer, intent(in) :: ktop, kbot
 real, intent(in),    dimension(ktop:kbot):: p1, dp1, den, denfac, vts, vtg, vtr
 real, intent(inout), dimension(ktop:kbot):: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak
 real, intent(in) :: h_var
! local:
 real, parameter:: rhos = 0.1e3    ! snow density (1/10 of water)
 real, dimension(2*(kbot-ktop-1)):: p2, den2, tz2, qv2, ql2, qs2, qi2, qa2 
 real, dimension(ktop:kbot) :: lcpk, icpk, tcpk, di, melt
 real :: tz, qv, ql, qr, qi, qs, qg
 real :: pracs, psacw, pgacw, pgmlt,   &
         psmlt, psacr, pgacr, pgfr,    &
         pgaci, praci, psaut, psaci, pssub,   &
         pgsub, piacr
 real :: tc, tsq, dqs0, qden, qim, qsm
 real :: factor, sink, fac_gra
 real :: tmp1, qsi, dqsdt, dq
 real :: n0s, lamda
 real :: q_plus
 integer :: km, kn
 integer :: k, k1
! Taylor series expansion of A**B
!------------------------------------------------------------------------
!  A**B = 1 +  x + (1/2!)*x**2 + (1/3!)*x**3 + (1/4!)*x**4 + (1/5!)*x**5
!  where x = B*log(A)   this is useful if x << 1
!------------------------------------------------------------------------

 fac_gra = 1. - exp( -dts/tau_gra )        !

 do k=ktop,kbot
!--------------------------------------
!      tmp1 = cp - rdgas*ptop/p1(k)
!   lcpk(k) =  latv / tmp1
!   icpk(k) =  lati / tmp1
!   tcpk(k) = lcpk(k) + icpk(k)
!--------------------------------------
    lcpk(k) = lcp
    icpk(k) = icp
    tcpk(k) = tcp
    melt(k) = 0.
 enddo

 

! Sources of cloud ice: pihom, cold rain, Biggs-proc (off), and the sat_adj
! (initiation plus deposition)

! Sources of snow: cold rain, Bergeron proc (off), auto conversion + accretion (from cloud ice)
! sat_adj (deposition; requires pre-existing snow); initial snow comes from either
! Bergeron or auto conversion

 do k=ktop, kbot
!--------------------------------------
! * pimlt: instant melting of cloud ice
!--------------------------------------
    if( tzk(k) > tice .and. qik(k) > qcmin ) then
        melt(k) = min( qik(k), (tzk(k)-tice)/icpk(k) )
            qim = qi0_crt / den(k)
! min rain due to melted snow autoconversion
           tmp1 = min( melt(k),      dim(qik(k),qim) )
! limit max ql amount to no greater than snow autocon threshold
           tmp1 = min( melt(k)-tmp1, dim(qim, qlk(k)) )
         qlk(k) = qlk(k) + tmp1
         qrk(k) = qrk(k) + melt(k) - tmp1
         qik(k) = qik(k) - melt(k)
         tzk(k) = tzk(k) - melt(k)*icpk(k)
    endif
 enddo

 call linear0_prof( kbot-ktop+1, p1(ktop), qik(ktop), di(ktop), .true., h_var )

 do 3000 k=ktop, kbot

   if( tzk(k) < t_min ) goto 3000

   tz = tzk(k)
   qv = qvk(k)
   ql = qlk(k)
   qi = qik(k)
   qr = qrk(k)
   qs = qsk(k)
   qg = qgk(k)

!--------------------------------------
! *** Split-micro_physics_processes ***
!--------------------------------------
! Zetac: excluded (from LFO83) term: psdep
! pgwet and realidw  removed by SJL

   pgacr = 0.
   pgacw = 0.
   tc = tz-tice

if ( tc > 1.0 ) then

!---------------------------------------------
! * Melting of snow (> 1 C) and graupel (> 2C)
!---------------------------------------------

     dqs0 = ces0/p1(k) - qv

     if( qs>qrmin ) then ! melting of snow into rain
! * accretion: cloud water --> snow
! only rate is used (for snow melt) since tc > 0.
        if( ql>qrmin ) then
!           factor = denfac(k)*csacw*(qs*den(k))**0.8125
            factor = denfac(k)*csacw*exp(0.8125*log(qs*den(k)))
             psacw = factor/(1.+dts*factor)*ql     ! rate
        else
             psacw = 0.
        endif

        if ( qr>qrmin ) then
! * accretion: melted snow --> rain:
             psacr = min(acr3d(vts(k), vtr(k), qr, qs, csacr, acco(1,2), den(k)), qr*rdts)
! * accretion: snow --> rain
             pracs = acr3d(vtr(k), vts(k), qs, qr, cracs, acco(1,1), den(k))
        else
             psacr = 0.
             pracs = 0.
        endif

! * Snow melt (due to rain accretion): snow --> rain
        psmlt = max(0., smlt(tc, dqs0, qs*den(k), psacw, psacr, csmlt, den(k), denfac(k)))

! Total snow sink:
        sink = min(qs, dts*(psmlt+pracs), tc/icpk(k))
          qs = qs - sink
          qr = qr + sink
          tz = tz - sink*icpk(k)    ! cooling due to snow melting
     endif   ! snow existed

     tc = tz-tice
     if ( qg>qrmin .and. tc>2. ) then
         if ( qr>qrmin ) then
! * accretion: rain --> graupel
              pgacr = min(acr3d(vtg(k), vtr(k), qr, qg, cgacr, acco(1,3), den(k)), rdts*qr)
         endif

         qden = qg*den(k)
         if( ql>qrmin ) then
! * accretion: cloud water --> graupel
!            factor = cgacw/sqrt(den(k))*(qg*den(k))**0.875
             factor = cgacw*qden/sqrt(den(k)*sqrt(sqrt(qden)))
              pgacw = factor/(1.+dts*factor) * ql  ! rate
         endif

! * melting: graupel --> rain
         pgmlt = dts*gmlt(tc, dqs0, qden, pgacw, pgacr, cgmlt, den(k))
         pgmlt = min( max(0., pgmlt), qg, tc/icpk(k) )
            qg = qg - pgmlt 
            qr = qr + pgmlt 
            tz = tz - pgmlt*icpk(k)
     endif   ! graupel existed


! Nothing is done within icloud if 0.0 <= tc <= 1.0

elseif( tc < 0.0 ) then 

!------------------
! Cloud water sink:
!------------------

  if( ql>qrmin ) then
! cloud water --> Snow
      if( qs>qrmin ) then
!         factor = dts*denfac(k)*csacw*(qs*den(k))**0.8125
          factor = dts*denfac(k)*csacw*exp(0.8125*log(qs*den(k)))
          psacw = min( factor/(1.+factor)*ql, -tc/icpk(k) )
          qs = qs + psacw
          ql = ql - psacw
          tz = tz + psacw*icpk(k)
          tc = tz - tice
      endif
  endif  ! (significant) cloud water existed

!------------------
! Cloud ice proc:
!------------------

  if ( qi>qrmin ) then

!----------------------------------------
! * accretion (pacr): cloud ice --> snow
!----------------------------------------
     if ( qs>qrmin )  then
#ifdef ZETAC_PSACI
! check Lin Eq. 22 has temperature dependency
! The following is from the "Lin Micro-physics" in Zetac
          factor = dts*denfac(k)*csaci*(qs*den(k))**0.8125
#else
! Eq(10) in HDC 2004, MWR
!  Gamma(3.41) = 3.0133  (combined into the constant: 27.737)
! Optimized form:
            n0s = 2.e6*exp(-0.12*tc)
          lamda = (qs*den(k))/(pie*rhos*n0s)
!        factor = dts*denfac(k)*27.737*n0s*exp(0.05*tc)*lamda**0.8525
         factor = dts*denfac(k)*27.737*n0s*exp(0.05*tc + 0.8525*log(lamda))
#endif
          psaci = factor/(1.+factor) * qi
     else
          psaci = 0.
     endif

!-------------------------------------
! * autoconversion: cloud ice --> snow
!-------------------------------------
! Similar to LFO 1983: Eq. 21 solved implicitly
! Threshold from WSM6 scheme, Hong et al 2004, Eq(13) : qi0_crt ~8.0E-5
    qim = qi0_crt / den(k)

! Assuming linear subgrid vertical distribution of cloud ice
! The mismatch computation following Lin et al. 1994, MWR
! c_psaut = 0.001
    q_plus = qi + di(k)
    if ( q_plus > (qim+qrmin) ) then
         if ( qim > (qi - di(k)) ) then
              dq = 0.25*(q_plus-qim)**2 / (di(k)+qrmin)
         else
              dq = qi - qim
         endif
         factor = dts*c_psaut*exp(0.025*tc)
         psaut  = factor/(1.+factor) * dq
    else
         psaut = 0.
    endif

    sink = min( qi, psaci+psaut )
      qi = qi - sink
      qs = qs + sink

    if ( (.not.add_snow2iwt) .and. qs>qrmin ) then
!----------------------------------
! * sublimation/deposition of snow:
!----------------------------------
           qsi = qs1d(tz, p1(k), dqsdt)
          qden = qs*den(k)
          tmp1 = exp(0.65625*log(qden))
           tsq = tz**2
         pssub =  cssub(1)*tsq*(cssub(2)*sqrt(qden) + cssub(3)*tmp1*sqrt(denfac(k)))  &
               / (cssub(4)*tsq+cssub(5)*qsi*den(k))
         pssub = (qsi-qv)*min(dts*pssub, 0.8/(1.+tcpk(k)*dqsdt))
         if ( pssub > 0. ) then
              pssub = min(pssub, qs)
         else
              pssub = max(pssub, (tz-tice)/tcpk(k))
         endif
         qs = qs - pssub 
         qv = qv + pssub 
         tz = tz - pssub*tcpk(k)
    endif

!-----------------------------------
! * accretion: cloud ice --> graupel
!-----------------------------------
    if ( qg>qrmin .and. qi>qrmin ) then
!        factor = dts*cgaci/sqrt(den(k))*(qg*den(k))**0.875
! The above is optimized as
           qden = qg*den(k)
         factor = dts*cgaci*qden/sqrt(den(k)*sqrt(sqrt(qden)))
          pgaci = factor/(1.+factor)*qi
             qi = qi - pgaci
             qg = qg + pgaci
    endif

  endif  ! cloud ice existed
 

!----------------
! Cold-Rain proc:
!----------------
! rain to ice, snow, graupel processes:
! Note: praci is processed first

  tc = tz-tice

  if ( qr>qrmin .and. tc < 0. ) then

! * accretion: accretion of cloud ice by rain to produce snow or graupel
! (LFO: produces snow or graupel; cloud ice sink.. via psacr & pgfr)
! ice --> snow OR graupel (due to falling rain)
! No change to qr and  tz
         if ( qi > qrmin ) then
            factor = dts*denfac(k)*craci*exp(0.95*log(qr*den(k)))
             praci = factor/(1.+factor)*qi
             if ( qr > qr0_crt/den(k) ) then
                  qg = qg + praci
             else
                  qs = qs + praci
             endif
             qi = qi - praci
         endif

! *sink* terms to qr: psacr + piacr + pgfr
! source terms to qs: psacr
! source terms to qi: piacr
! source terms to qg: pgfr

! * accretion of rain by snow
      if ( qs > qrmin ) then   ! if snow exists
           psacr = dts*acr3d(vts(k), vtr(k), qr, qs, csacr, acco(1,2), den(k))
      else
           psacr = 0.
      endif

! The following added by SJL (missing from Zetac)
! * piacr: accretion of rain by cloud ice [simplified from lfo 26]
! The value of c_piacr needs to be near order(1) to have significant effect
!-------------------------------------------------------------------
! rain --> ice 
      if ( qi > qrmin ) then
         factor = dts*denfac(k)*qi * c_piacr
          piacr = factor/(1.+factor)*qr
      else
          piacr = 0.
      endif

!-------------------------------------------------------------------
! * rain freezing --> graupel
!-----------------------------------------------------------------------------------
       pgfr = dts*cgfr(1)*(exp(-cgfr(2)*tc)-1.)*(qr*den(k))**1.75/den(k)
       qden = qr*den(k)
       pgfr = dts*cgfr(1)*(exp(-cgfr(2)*tc)-1.)*qden*qden/(sqrt(sqrt(qden))*den(k))
!-----------------------------------------------------------------------------------

!--- Total sink to qr
       sink = psacr + piacr + pgfr
     factor = min( sink, qr, -tc/icpk(k) ) / max( sink, qrmin )

      psacr = factor * psacr
      piacr = factor * piacr
      pgfr  = factor * pgfr

      sink = psacr + piacr + pgfr
        tz = tz + sink*icpk(k)
        qr = qr - sink
        qs = qs + psacr
        qi = qi + piacr
        qg = qg + pgfr
  endif

!--------------------------
! Graupel production terms:
!--------------------------

  if( qs > qrmin ) then
! * accretion: snow --> graupel
      if ( qg > qrmin ) then
           sink = dts*acr3d(vtg(k), vts(k), qs, qg, cgacs, acco(1,4), den(k))
      else
           sink = 0.
      endif

      qsm = qs0_crt / den(k)
      if ( qs > qsm ) then
! * Autoconversion Snow --> graupel
           factor = dts*1.e-3*exp(0.09*(tz-tice))
             sink = sink + factor/(1.+factor)*(qs-qsm)
      endif
      sink = min( qs, sink )
        qs = qs - sink
        qg = qg + sink

  endif   ! snow existed

  if ( qg>qrmin .and. tz < tice ) then
! * accretion: rain --> graupel
     if ( qr>qrmin ) then 
          pgacr = min(dts*acr3d(vtg(k), vtr(k), qr, qg, cgacr, acco(1,3), den(k)), qr)
     else
          pgacr = 0.
     endif

! * accretion: cloud water --> graupel
     if( ql>qrmin ) then
!        factor = dts*cgacw/sqrt(den(k))*(qg*den(k))**0.875
           qden = qg*den(k)
         factor = dts*cgacw*qden/sqrt(den(k)*sqrt(sqrt(qden)))
          pgacw = factor/(1.+factor)*ql
     else
          pgacw = 0.
     endif

       sink = pgacr + pgacw
! Total graupel source limited  by freezing point: factor 0.5 added 
     factor = min( sink, 0.5*(tice-tz)/icpk(k) ) / max( sink, qrmin )
      pgacr = factor * pgacr
      pgacw = factor * pgacw

     sink = pgacr + pgacw
       tz = tz + sink*icpk(k)
       qg = qg + sink
       qr = qr - pgacr
       ql = ql - pgacw

!------------------------------------------------------------
! * Simplified 2-way grapuel sublimation-deposition mechanism
!------------------------------------------------------------
         qsi = qs1d(tz, p1(k), dqsdt)
          dq = 0.5*(qv-qsi) / (1.+tcpk(k)*dqsdt)
       pgsub = fac_gra * (qv/qsi-1.) * min(qg, 1.E-3)
       if ( pgsub > 0. ) then        ! deposition
            pgsub = min( pgsub, dq, 0.5*(tice-tz)/tcpk(k) )
       else                          ! submilation
            pgsub = max( pgsub, dq )
       endif
       qg = qg + pgsub
       qv = qv - pgsub 
       tz = tz + pgsub*tcpk(k)

 endif    ! graupel existed

endif   ! end ice-physics 

     tzk(k) = tz
     qvk(k) = qv
     qlk(k) = ql
     qik(k) = qi
     qrk(k) = qr
     qsk(k) = qs
     qgk(k) = qg

3000 continue   ! k-loop

 if ( do_subgrid_z ) then

! Except top 2 and bottom 2 layers (4 layers total), using subgrid PPM distribution
! to perform saturation adjustment at 2X the vertical resolution
! Adjusted fields: temperature, vapor, cloud ice, cloud water, and cloud cover (0/1)

   kn = kbot - ktop + 1
   km = 2*(kbot-ktop-1)

   p2(1) =  p1(ktop  )
   p2(2) =  p1(ktop+1)
   do k=3,km-3,2
           k1 = ktop+1 + k/2
      p2(k  ) = p1(k1) - 0.25*dp1(k1) 
      p2(k+1) = p1(k1) + 0.25*dp1(k1) 
   enddo

   if ( mp_debug ) then
     if (k1 /= (kbot-2))  then
         write(*,*) 'FATAL: k1=', k1
         call error_mesg ('MP_LIN:', 'DO_MAP2_SAT', FATAL) 
     endif
   endif

   p2(km-1) = p1(kbot-1)
   p2(km  ) = p1(kbot)

   call remap2(ktop, kbot, kn, km, dp1, tzk, tz2, 1)
   call remap2(ktop, kbot, kn, km, dp1, qvk, qv2, 1)
   call remap2(ktop, kbot, kn, km, dp1, qlk, ql2, 1)
   call remap2(ktop, kbot, kn, km, dp1, qik, qi2, 1)
   if ( add_snow2iwt )                                &
   call remap2(ktop, kbot, kn, km, dp1, qsk, qs2, 1)

   do k=1,km
      den2(k) = p2(k)/(rdgas*tz2(k))
       qa2(k) = 0.
   enddo

   call subgrid_z_proc(1, km, p2, den2, h_var, tz2, qv2, ql2, qi2, qs2, qa2)
 
! Remap back to original larger volumes:
   qak(ktop  ) = qak(ktop  ) + qa2(1)
   qak(ktop+1) = qak(ktop+1) + qa2(2)
  
   tzk(ktop  ) = tz2(1)
   tzk(ktop+1) = tz2(2)

   qvk(ktop  ) = qv2(1)
   qvk(ktop+1) = qv2(2)

   qlk(ktop  ) = ql2(1)
   qlk(ktop+1) = ql2(2)

   qik(ktop  ) = qi2(1)
   qik(ktop+1) = qi2(2)

   if ( add_snow2iwt ) then
        qsk(ktop  ) = qs2(1)
        qsk(ktop+1) = qs2(2)
   endif

   do k=3,km-3,2
          k1  = ktop+1 + k/2
      qak(k1) = qak(k1) + max(qa2(k), qa2(k+1))  ! Maximum only
! Subgrid overlap schemes: max and random parts weighted by subgrid horizontal deviation
!-------------------------------------------------------------------------------------
! Random cloud fraction = 1 - (1-a1)*(1-a2) = a1 + a2 - a1*a2
! RAND_CLOUD
!     qak(k1) = qak(k1) + (1.-h_var)*max(qa2(k), qa2(k+1))     &  ! Maximum fraction
!                       + h_var*(qa2(k)+qa2(k+1)-qa2(k)*qa2(k+1)) ! Random  fraction
!-------------------------------------------------------------------------------------
      tzk(k1) = 0.5*(tz2(k) + tz2(k+1))
      qvk(k1) = 0.5*(qv2(k) + qv2(k+1))
      qlk(k1) = 0.5*(ql2(k) + ql2(k+1))
      qik(k1) = 0.5*(qi2(k) + qi2(k+1))
      if ( add_snow2iwt) qsk(k1) = 0.5*(qs2(k) + qs2(k+1))
   enddo

   qak(kbot-1) = qak(kbot-1) + qa2(km-1)
   qak(kbot  ) = qak(kbot  ) + qa2(km  )

   tzk(kbot-1) = tz2(km-1)
   tzk(kbot  ) = tz2(km  )

   qvk(kbot-1) = qv2(km-1)
   qvk(kbot  ) = qv2(km  )

   qlk(kbot-1) = ql2(km-1)
   qlk(kbot  ) = ql2(km  )

   qik(kbot-1) = qi2(km-1)
   qik(kbot  ) = qi2(km  )

   if ( add_snow2iwt ) then
        qsk(kbot-1) = qs2(km-1)
        qsk(kbot  ) = qs2(km  )
   endif
 else
   call subgrid_z_proc(ktop, kbot, p1, den, h_var, tzk, qvk, qlk, qik, qsk, qak)
 endif

 end subroutine icloud


 subroutine remap2(ktop, kbot, kn, km, dp, q1, q2, id)
 integer, intent(in):: ktop, kbot, kn, km , id
! constant distribution if id ==0
 real, intent(in), dimension(ktop:kbot):: q1, dp
 real, intent(out):: q2(km)
! local
 real:: a4(4,ktop:kbot)
 integer:: k, k1

  q2(1) = q1(ktop  )
  q2(2) = q1(ktop+1)

  if ( id==1 ) then

      do k=ktop,kbot
         a4(1,k) = q1(k)
      enddo
      call cs_profile( a4(1,ktop), dp(ktop), kn, mono_prof )  ! non-monotonic

      do k=3,km-3,2
              k1 = ktop+1 + k/2
         q2(k  ) = min( 2.*q1(k1), max( qvmin, a4(1,k1) + 0.25*(a4(2,k1)-a4(3,k1)) ) )
         q2(k+1) = 2.*q1(k1) - q2(k)
      enddo

  else
      do k=3,km-3,2
              k1 = ktop+1 + k/2
         q2(k  ) = q1(k1)
         q2(k+1) = q1(k1)
      enddo
  endif

  q2(km-1) = q1(kbot-1)
  q2(km  ) = q1(kbot)

 end subroutine remap2



 subroutine subgrid_z_proc(ktop, kbot, p1, den, h_var, tz, qv, ql, qi, qs, qa)

! Temperature sentive high vertical resolution processes:

 integer, intent(in):: ktop, kbot
 real, intent(in),    dimension(ktop:kbot):: p1, den
 real, intent(in)                         :: h_var
 real, intent(inout), dimension(ktop:kbot):: tz, qv, ql, qi, qs, qa
! local:
 real:: qc_crt = 5.0e-8  ! minimum condensate mixing ratio to allow partial cloudiness
                         ! must not be too large to allow PSC
 real:: denf, rh, clouds, tmp1, rqi, tin, qsw, qsi, qpz, qstar
 real:: dqsdt, dwsdt, dq, pidep, factor
 real:: q_plus, q_minus, qi_crt
 real:: pcond, sink, qden, tsq, pssub, fac_l2v, fac_v2l, fac_ice,  iwt
 integer :: k

  fac_l2v = 1. - exp( -dts/tau_l2v )        ! exact-in-time integration
  fac_v2l = 1. - exp( -dts/tau_v2l )        ! exact-in-time integration
  fac_ice = 1. - exp( -dts/tau_ice )        ! 

 do 4000 k=ktop,kbot

! Quick pass check
!-----------------
   if ( tz(k) < t_min ) goto 4000

! Instant evaporation/sublimation of all clouds if RH<rh_adj --> cloud free
! This segment is the only true "saturation adjustment" in this code, and it
! operates only for low RH (set by rh_adj)

                        iwt = qi(k)
   if ( add_snow2iwt )  iwt = iwt + qs(k)

   clouds = ql(k) + iwt

   tin = tz(k) - ( lcp*clouds + icp*iwt )  ! minimum  temperature

   qpz = qv(k) + clouds                    ! conserved within subgrid_z_proc
    rh = qpz*p1(k)/(eps*es2_table(tin))    ! 2-phase (pure ice & water)

    if ( rh<rh_adj ) then  ! qpz / rh_adj < qs
         tz(k) = tin
         qv(k) = qpz
         ql(k) = 0.
         qi(k) = 0.
         if ( add_snow2iwt ) qs(k) = 0.
         goto 4000
    endif


! * Cloud water <---> water vapor

! Note: if qsi < qv < qsw then a Bergeron-like process can naturally happen
!---------------------------------------------------------------------------------------------------
! Evaporation of cloud water from EQ A12, Fowler, Randall, and Rutledge 1996, solved exactly in time
! since dq/qsw < 1 --> pcond < ql; therefore ql will never be completely evaporated within this step
! Complete evaporation happens in the pre-conditioner if conditions are met
!---------------------------------------------------------------------------------------------------
! Note: liquid phase is active for t>t_water; at extreme cold temp region, the condensed water
!       will be frozen immediately thus providing some nitial ice nucleation
   
   if ( tz(k) > t_water ) then
        qsw = ws1d(tz(k), p1(k), dwsdt)
         dq = qsw - qv(k)
      pcond = dq / (1.+lcp*dwsdt) ! maximum possible change amount to qv

      if ( dq > 0. ) then
           pcond = min( fac_l2v*(dq/qsw)*ql(k), pcond ) ! note: dq/qsw=(1-RH)  < 1
      else
           pcond = max( fac_v2l*dq, pcond )  ! condensation rate independent of ql amount
      endif
      qv(k) = qv(k) + pcond
      ql(k) = ql(k) - pcond
      tz(k) = tz(k) - pcond*lcp    ! This is THE main heating source !!!
   endif

! Note: Cloudsat observed peak of ice at -30 C (~ 300mb) in the tropics

  if ( tz(k)<tice ) then
!------------------------------------------------------------
! * pihtf homogeneous Freezing of cloud water into cloud ice:
!------------------------------------------------------------
    if( ql(k) > qcmin ) then

      if( tz(k) < t_wfr+dt_fr ) then   ! (-37 C)  <-- (-40) --> (-43 C)
!                              factor =     0           0.5       1
        factor = min( 1., (t_wfr+dt_fr-tz(k))/dt_fr )
          sink = min( factor*ql(k), (t_wfr+dt_fr-tz(k))/icp )
         ql(k) = ql(k) - sink
         qi(k) = qi(k) + sink
         tz(k) = tz(k) + sink*icp
      endif

! Biggs freezing mechanism for the mixed ice-liquid phase
      if( tz(k)>t_wfr ) then
!-------------------------
! Biggs 1953: The supercooling water. Proc. Phys. Soc. London, B66, 688-694.
! pihtf = dt*1.44e-12;  for tmp1 = 20, den=0.8 and ql = 1.e-4
! max ~ dt*1.e-6;  for tmp1 = 40, den=1.0 and ql = 1.e-3
! note: larger ql --> quicker freezing
          tmp1 = tice - tz(k)
          sink = dts*3.3333e-10*(exp(0.66*tmp1)-1.)*den(k)*ql(k)*ql(k) 
          sink = min(ql(k), tmp1/icp, sink)
         ql(k) = ql(k) - sink
         qi(k) = qi(k) + sink
         tz(k) = tz(k) + sink*icp
      endif

    endif ! significant ql existed

!------------------------------------------
! * pidep: sublimation/deposition of ice:
!------------------------------------------
! qv at this stage is near or below qsw
    qsi = qs1d(tz(k), p1(k), dqsdt)
     dq = qv(k) - qsi
   sink = 0.99*dq/(1.+tcp*dqsdt)
!         ^^^^ somewhat arbitrary factor < 1. to prevent overshoot
   qden = qi(k)*den(k)

    if ( qi(k) > qrmin ) then
! Eq 9, Hong et al. 2004, MWR
! For A and B, see Dudhia 1989: page 3103 Eq (B7) and (B8)
! Optimized form:
         pidep = dts*dq*349138.78*qden/sqrt(sqrt(sqrt(qden)))     &
               / (qsi*den(k)*lats*lats/(0.0243*rvgas*tz(k)**2) + 4.42478e4)
! Note: tcp*dqsdt is very small for T < -40. C
    else
         pidep = 0.
    endif

    if ( dq > 0. ) then
!-----------------------------------------------------------------------------
!      qi_crt = qi_gen
!      if ( qden < qi_crt ) then
! Hong et al 2004 form is equivalent to: qi_init = 4.808E-7, beta_init = 0.133
!          qimin = min( qi_crt, qi_init*exp(beta_init*(tice-tz(k))) ) / den(k)
!          pidep = max( qimin, qi(k)+pidep ) - qi(k)
!      endif
!-----------------------------------------------------------------------------
       qi_crt = qi_gen*min(1.0, (tice-tz(k))/5. )  ! critical density
! Take the larger of pidep and pi_gen; under warmer temp pidep should dorminate, and vice versa
        pidep = max( pidep, fac_ice*(qi_crt-qden)/den(k) )
!                           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^! ice initiation with time-scale=tau_ice
                                                        ! to make it less time step dependent
        sink  = min( pidep, sink, (tice-tz(k))/tcp ) ! vapor -> ice
    else
        sink  = max( pidep, sink, -qi(k) )           ! Ice --> Vapor
    endif
    qv(k) = qv(k) - sink
    qi(k) = qi(k) + sink
    tz(k) = tz(k) + sink*tcp
  endif   ! sub-freezing check

  if ( add_snow2iwt .and. tz(k)<tice-0.1 ) then

      if ( qs(k)>qrmin ) then
!----------------------------------
! * sublimation/deposition of snow:
!----------------------------------
! Note the sequence of ice adjustment then snow
! snow <--> vapor  two-way conversion; no snow --> no action

           qsi = qs1d(tz(k), p1(k), dqsdt)
          qden = qs(k)*den(k)
          tmp1 = exp(0.65625*log(qden))
           tsq = tz(k)**2
          denf = sqrt(sfcrho/den(k))
         pssub =  cssub(1)*tsq * (cssub(2)*sqrt(qden) + cssub(3)*tmp1*sqrt(denf))  &
               / (cssub(4)*tsq+cssub(5)*qsi*den(k))
         pssub = (qsi-qv(k)) * min(dts*pssub, 0.8/(1.+tcp*dqsdt))
         if ( pssub > 0. ) then
              pssub = min(pssub, qs(k))
         else
              pssub = max(pssub, (tz(k)-tice)/tcp)
         endif
         qs(k) = qs(k) - pssub 
         qv(k) = qv(k) + pssub 
         tz(k) = tz(k) - pssub*tcp
      endif

  endif   ! add_snow2iwt

! Update total cloud condensates; note total water (qpz) is conserved
! use cloud condensates at true temperature to determine the water/ice partition
   if ( add_snow2iwt ) then
        iwt = qi(k) + qs(k) 
   else
        iwt = qi(k)
   endif
   clouds = ql(k) + iwt

!--------------------
! * determine qstar 
!--------------------
! Using the "liquid-frozen water temperature": tin
   if( tin <= t_wfr ) then
       qstar = iqsat(tin, p1(k))
   elseif ( tin >= tice ) then
       qstar = wqsat(tin, p1(k))
   else
! mixed phase:
       qsi = iqsat(tin, p1(k))
       qsw = wqsat(tin, p1(k))
       if( clouds > 5.E-6 ) then
           rqi = iwt / clouds
       else
! Mostly liquid water clouds at initial cloud development stage
           rqi = (tice-tin)/(tice-t_wfr)
           rqi = rqi ** 2    ! biased towards water phase when little condensates exist
       endif
       qstar = rqi*qsi + (1.-rqi)*qsw
   endif

!-------------------------
! * cloud fraction
!-------------------------
! Assuming subgrid linear distribution in horizontal; this is effectively a smoother for the
! binary cloud scheme

   if ( qpz > qrmin ) then
! Partial cloudiness by PDF:
            dq = max(qcmin, h_var*qpz)
       q_plus  = qpz + dq        ! cloud free if qstar > q_plus
       q_minus = qpz - dq
       if ( qstar < q_minus ) then
            qa(k) = qa(k) + 1.       ! 100 % cloud cover
       elseif ( qstar<q_plus .and. clouds>qc_crt ) then
            qa(k) = qa(k) + (q_plus-qstar)/(dq+dq)
       endif
   endif

4000 continue

 end subroutine subgrid_z_proc



 subroutine terminal_fall(dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, pm, dz, dp,  &
                          den, vtg, vts, vti, r1, g1, s1, i1)

! lagrangian control-volume method:

 real,    intent(in):: dtm                    ! time step (s)
 integer, intent(in):: ktop, kbot
 real,    intent(in), dimension(ktop:kbot):: dp, vtg, vts, vti, pm, den
 real,    intent(inout), dimension(ktop:kbot):: dz, qv, ql, qr, qg, qs, qi, tz
 real,    intent(out):: r1, g1, s1, i1
! local:
 real, dimension(ktop:kbot+1):: ze, zt
 real:: dt5, melt, dtime
 real:: tmp1, qim
 real, dimension(ktop:kbot):: lcpk, icpk
 real:: zs = 0.
 integer k, k0, m
 logical no_fall

  do k=ktop,kbot
!       tmp1 = cp - rdgas*ptop/pm(k)
!    lcpk(k) = latv / tmp1
!    icpk(k) = lati / tmp1
     lcpk(k) = lcp
     icpk(k) = icp
  enddo

  dt5 = 0.5*dtm

! find melting level; tice+2.
  k0 = kbot
  do k=ktop, kbot-1
     if ( tz(k) > tice2 ) then
          k0 = k
          go to 11
     endif
  enddo
11  continue

!-----
! ice:
!-----

  ze(kbot+1) = zs
  do k=kbot, ktop, -1
     ze(k) = ze(k+1) - dz(k)  ! dz<0
  enddo

  zt(ktop) = ze(ktop)

  call check_column(ktop, kbot, qi, no_fall)

  if ( vi_fac < 1.e-5 .or. no_fall ) then
     i1 = 0.
  else

  do k=ktop+1,kbot
     zt(k) = ze(k) - dt5*(vti(k-1)+vti(k))
  enddo
  zt(kbot+1) = zs - dtm*vti(kbot)

  do k=ktop,kbot
     if( zt(k+1)>=zt(k) ) zt(k+1) = zt(k) - dz_min
  enddo

  if ( k0 < kbot ) then
  do k=kbot-1,k0,-1
     if ( qi(k) > qrmin ) then
          do m=k+1, kbot
             if ( zt(k+1)>=ze(m) ) exit
             if ( zt(k)<ze(m) .and. tz(m)>tice2 ) then
                  dtime = min( 1.0, (ze(m)-ze(m+1))/(max(vmin,vti(k))*tau_i) )
                   melt = min( qi(k)*dp(k)/dp(m), dtime*(tz(m)-tice2)/icpk(m) )
!
                    qim = qi0_crt / den(m)
                   tmp1 = min( melt, dim(qi(k), qim) )      ! min rain (snow autoconversion)
                   tmp1 = min( melt-tmp1, dim(qim, ql(m)) ) ! limit max ql amount
!
                  ql(m) = ql(m) + tmp1
                  qr(m) = qr(m) - tmp1 + melt
                  tz(m) = tz(m) - melt*icpk(m)
                  qi(k) = qi(k) - melt*dp(m)/dp(k)
!            elseif ( zt(k+1)<ze(m) .and. zt(k+1)>ze(m+1) ) then
!                  frac = (ze(m)-zt(k+1))/(zt(k)-zt(k+1))
!                  melt = min( frac*qi(k)*dp(k)/dp(m), dim(tz(m),tice2)/icpk(m) )
!                 ql(m) = ql(m) + melt          ! melt into cloud water
!                 tz(m) = tz(m) - melt*icpk(m)
!                 qi(k) = qi(k) - melt*dp(m)/dp(k)
             endif
          enddo
     endif
  enddo
  endif

  if ( use_ppm ) then
       call lagrangian_fall_ppm(ktop, kbot, zs, ze, zt, dp, qi, i1, mono_prof)
  else
       call lagrangian_fall_pcm(ktop, kbot, zs, ze, zt, dp, qi, i1)
  endif

  endif

!--------------------------------------------
! melting of falling snow (qs) into rain(qr)
!--------------------------------------------
  r1 = 0.

  call check_column(ktop, kbot, qs, no_fall)

  if ( no_fall ) then
       s1 = 0.
  else

  do k=ktop+1,kbot
     zt(k) = ze(k) - dt5*(vts(k-1)+vts(k))
  enddo
  zt(kbot+1) = zs - dtm*vts(kbot)

  do k=ktop,kbot
     if( zt(k+1)>=zt(k) ) zt(k+1) = zt(k) - dz_min
  enddo

  if ( k0 < kbot ) then
  do k=kbot-1,k0,-1
     if ( qs(k) > qrmin ) then
          do m=k+1, kbot
             if ( zt(k+1)>=ze(m) ) exit
             dtime = min( dtm, (ze(m)-ze(m+1))/(vmin+vts(k)) )
!            if ( zt(k)<ze(m) ) then    ! the top of the c-v is in the layer below
             if ( zt(k)<ze(m+1) .and. tz(m)>tice2 ) then
                  dtime = min(1., dtime/tau_s)
                   melt = min(qs(k)*dp(k)/dp(m), dtime*(tz(m)-tice2)/icpk(m))
                  tz(m) = tz(m) - melt*icpk(m)
                  qs(k) = qs(k) - melt*dp(m)/dp(k)
                  if ( zt(k)<zs ) then
                       r1 = r1 + melt*dp(m)   ! precip as rain
                  else
!                      qr source here will fall next time step (therefore, can evap)
                       qr(m) = qr(m) + melt
                  endif
             endif
             if ( qs(k) < qrmin ) exit
          enddo
     endif
  enddo
  endif

  if ( use_ppm ) then
       call lagrangian_fall_ppm(ktop, kbot, zs, ze, zt, dp, qs, s1, mono_prof)
  else
       call lagrangian_fall_pcm(ktop, kbot, zs, ze, zt, dp, qs, s1)
  endif
  endif

!----------------------------------------------
! melting of falling graupel (qg) into rain(qr)
!----------------------------------------------
  call check_column(ktop, kbot, qg, no_fall)

  if ( no_fall ) then
       g1 = 0.
  else
  do k=ktop+1,kbot
     zt(k) = ze(k) - dt5*(vtg(k-1)+vtg(k))
  enddo
  zt(kbot+1) = zs - dtm*vtg(kbot)

  do k=ktop,kbot
     if( zt(k+1)>=zt(k) ) zt(k+1) = zt(k) - dz_min
  enddo

  if ( k0 < kbot ) then
  do k=kbot-1,k0,-1
     if ( qg(k) > qrmin ) then
          do m=k+1, kbot
             if ( zt(k+1)>=ze(m) ) exit
             dtime = min( dtm, (ze(m)-ze(m+1))/vtg(k) )
             if ( zt(k)<ze(m+1) .and. tz(m)>tice2 ) then
                  dtime = min(1., dtime/tau_g)
                   melt = min(qg(k)*dp(k)/dp(m), dtime*(tz(m)-tice2)/icpk(m))
                  tz(m) = tz(m) - melt*icpk(m)
                  qg(k) = qg(k) -  melt*dp(m)/dp(k)
                  if ( zt(k)<zs ) then
                       r1 = r1 + melt*dp(m)
                  else
                       qr(m) = qr(m) + melt
                  endif
             endif
             if ( qg(k) < qrmin ) exit
           enddo
     endif
  enddo
  endif

  if ( use_ppm ) then
       call lagrangian_fall_ppm(ktop, kbot, zs, ze, zt, dp, qg, g1, mono_prof)
  else
       call lagrangian_fall_pcm(ktop, kbot, zs, ze, zt, dp, qg, g1)
  endif
  endif


 end subroutine terminal_fall


 subroutine check_column(ktop, kbot, q, no_fall)
 integer, intent(in):: ktop, kbot
 real,    intent(in):: q(ktop:kbot)
 logical, intent(out):: no_fall
! local:
 integer k

 no_fall = .true.
 do k=ktop, kbot
    if ( q(k) > qrmin ) then
         no_fall = .false.
         exit
    endif
 enddo

 end subroutine check_column


 subroutine lagrangian_fall_pcm(ktop, kbot, zs, ze, zt, dp, q, precip)
 real,    intent(in):: zs
 integer, intent(in):: ktop, kbot
 real,    intent(in), dimension(ktop:kbot):: dp
 real,    intent(in), dimension(ktop:kbot+1):: ze, zt
 real,    intent(inout), dimension(ktop:kbot):: q
 real,    intent(out):: precip
! local:
 real, dimension(ktop:kbot):: qm1, qm2
 integer k, k0, n, m

! density:
  do k=ktop,kbot
     qm1(k) = q(k)*dp(k) / (zt(k)-zt(k+1))
     qm2(k) = 0.
  enddo

   k0 = ktop
   do k=ktop,kbot
      do n=k0,kbot
      if(ze(k) <= zt(n) .and. ze(k) >= zt(n+1)) then
         if(ze(k+1) >= zt(n+1)) then
!                          entire new grid is within the original grid
            qm2(k) = qm1(n)*(ze(k)-ze(k+1))
            k0 = n
            goto 555
         else
            qm2(k) = qm1(n)*(ze(k)-zt(n+1))    ! fractional area
            do m=n+1,kbot
!                                        locate the bottom edge: ze(k+1)
               if(ze(k+1) < zt(m+1) ) then
                  qm2(k) = qm2(k) + q(m)*dp(m)
               else
                  qm2(k) = qm2(k) + qm1(m)*(zt(m)-ze(k+1))
                  k0 = m
                  goto 555
               endif
            enddo
            goto 555
         endif
      endif
      enddo
555 continue
   enddo

     precip = 0.
! direct algorithm (prevent small negatives)
     do k=ktop,kbot
        if ( zt(k+1) < zs ) then
             precip = qm1(k)*(zs-zt(k+1)) 
             if ( (k+1) > kbot ) goto 777
                  do m=k+1,kbot
                     precip = precip + q(m)*dp(m)
                  enddo
             goto 777
        endif
     enddo
777  continue

   do k=ktop,kbot
      q(k) = qm2(k) / dp(k)
   enddo

 end subroutine lagrangian_fall_pcm



 subroutine lagrangian_fall_ppm(ktop, kbot, zs, ze, zt, dp, q, precip, mono)
 integer, intent(in):: ktop, kbot
 real,    intent(in):: zs
 logical, intent(in):: mono
 real,    intent(in), dimension(ktop:kbot):: dp
 real,    intent(in), dimension(ktop:kbot+1):: ze, zt
 real,    intent(inout), dimension(ktop:kbot):: q
 real,    intent(out):: precip
! local:
 real, dimension(ktop:kbot):: qm0, qm1, qm2, dz
 real a4(4,ktop:kbot)
 real pl, pr, delz, esl
 integer k, k0, n, m
 real, parameter:: r3 = 1./3., r23 = 2./3.

! density:
  do k=ktop,kbot
      dz(k) = zt(k) - zt(k+1)      ! note: dz is positive
     qm0(k) = q(k)*dp(k)
     qm1(k) = qm0(k) / dz(k)
     qm2(k) = 0.
     a4(1,k) = qm1(k)
  enddo

! Construct qm1 profile with zt as coordinate

   call cs_profile(a4(1,ktop), dz(ktop), kbot-ktop+1, mono)

   k0 = ktop
   do k=ktop,kbot
      do n=k0,kbot
      if(ze(k) <= zt(n) .and. ze(k) >= zt(n+1)) then
         pl = (zt(n)-ze(k)) / dz(n)
         if( zt(n+1) <= ze(k+1) ) then
!                          entire new grid is within the original grid
                pr = (zt(n)-ze(k+1)) / dz(n)
            qm2(k) = a4(2,n) + 0.5*(a4(4,n)+a4(3,n)-a4(2,n))*(pr+pl) -  &
                     a4(4,n)*r3*(pr*(pr+pl)+pl**2)
            qm2(k) = qm2(k)*(ze(k)-ze(k+1))
            k0 = n
            goto 555
         else
            qm2(k) = (ze(k)-zt(n+1)) * (a4(2,n)+0.5*(a4(4,n)+   &
                      a4(3,n)-a4(2,n))*(1.+pl) - a4(4,n)*( r3*(1.+pl*(1.+pl))) )
            if ( n<kbot ) then
               do m=n+1,kbot
!                                        locate the bottom edge: ze(k+1)
                  if( ze(k+1) < zt(m+1) ) then
                     qm2(k) = qm2(k) + q(m)*dp(m)
                  else
                     delz = zt(m) - ze(k+1)
                      esl = delz / dz(m)
                     qm2(k) = qm2(k) + delz*( a4(2,m) + 0.5*esl*        &
                             (a4(3,m)-a4(2,m)+a4(4,m)*(1.-r23*esl)) )
                     k0 = m
                     goto 555
                  endif
               enddo
            endif
            goto 555
         endif
      endif
      enddo
555 continue
   enddo

   precip = 0.

   do k=ktop,kbot
      precip = precip + qm0(k) - qm2(k)
   enddo
!  precip = max(0., precip)

   do k=ktop,kbot
      q(k) = qm2(k) / dp(k)
   enddo

 end subroutine lagrangian_fall_ppm


 subroutine cs_profile(a4, del, km, do_mono)
 integer, intent(in):: km      ! vertical dimension
 real   , intent(in):: del(km)
 logical, intent(in):: do_mono
 real , intent(inout):: a4(4,km)
!-----------------------------------------------------------------------
 real  gam(km)
 real  q(km+1)
 real   d4, bet, a_bot, grat
 real   pmp_1, lac_1, pmp_2, lac_2
 real  da1, da2, a6da
 integer k
 logical extm(km)

     grat = del(2) / del(1)   ! grid ratio
      bet = grat*(grat+0.5)
     q(1) = (2.*grat*(grat+1.)*a4(1,1)+a4(1,2)) / bet
   gam(1) = ( 1. + grat*(grat+1.5) ) / bet

  do k=2,km
      d4 = del(k-1) / del(k)
     bet =  2. + 2.*d4 - gam(k-1)
     q(k) = (3.*(a4(1,k-1)+d4*a4(1,k))-q(k-1))/bet
     gam(k) = d4 / bet
  enddo
 
       a_bot = 1. + d4*(d4+1.5)
     q(km+1) = (2.*d4*(d4+1.)*a4(1,km)+a4(1,km-1)-a_bot*q(km))  &
             / ( d4*(d4+0.5) - a_bot*gam(km) )

  do k=km,1,-1
     q(k) = q(k) - gam(k)*q(k+1)
  enddo

!------------------
! Apply constraints
!------------------
  do k=2,km
     gam(k) = a4(1,k) - a4(1,k-1)
  enddo

! Apply large-scale constraints to ALL fields if not local max/min

! Top:
  q(1) = max( q(1), 0. )
  q(2) = min( q(2), max(a4(1,1), a4(1,2)) )
  q(2) = max( q(2), min(a4(1,1), a4(1,2)), 0. )

! Interior:
  do k=3,km-1
     if ( gam(k-1)*gam(k+1)>0. ) then
          q(k) = min( q(k), max(a4(1,k-1),a4(1,k)) )
          q(k) = max( q(k), min(a4(1,k-1),a4(1,k)) )
     else
          if ( gam(k-1) > 0. ) then
! There exists a local max                                                                             
               q(k) = max( q(k), min(a4(1,k-1),a4(1,k)) )     
          else
! There exists a local min
               q(k) = min( q(k), max(a4(1,k-1),a4(1,k)) )
               q(k) = max( q(k), 0.0 )
          endif
     endif
  enddo

  q(km  ) = min( q(km), max(a4(1,km-1), a4(1,km)) )
  q(km  ) = max( q(km), min(a4(1,km-1), a4(1,km)), 0. )
! q(km+1) = max( q(km+1), 0.)

!-----------------------------------------------------------
! f(s) = AL + s*[(AR-AL) + A6*(1-s)]         ( 0 <= s  <= 1 )
!-----------------------------------------------------------
  do k=1,km-1
     a4(2,k) = q(k  )
     a4(3,k) = q(k+1)
  enddo

  do k=2,km-1
     if ( gam(k)*gam(k+1) > 0.0 ) then
          extm(k) = .false.
     else
          extm(k) = .true.
     endif
  enddo

  if ( do_mono ) then
     do k=3,km-2
        if ( extm(k) ) then
! positive definite constraint ONLY if true local extrema
           if ( extm(k-1)  .or.  extm(k+1) ) then
               a4(2,k) = a4(1,k)
               a4(3,k) = a4(1,k)
           endif
        else
           a4(4,k) = 6.*a4(1,k) - 3.*(a4(2,k)+a4(3,k))
           if( abs(a4(4,k)) > abs(a4(2,k)-a4(3,k)) ) then
! Check within the smooth region if subgrid profile is non-monotonic
                pmp_1 = a4(1,k) - 2.0*gam(k+1)
                lac_1 = pmp_1   + 1.5*gam(k+2)
              a4(2,k) = min( max(a4(2,k), min(a4(1,k), pmp_1, lac_1)),  &
                                          max(a4(1,k), pmp_1, lac_1) )
                pmp_2 = a4(1,k) + 2.0*gam(k)
                lac_2 = pmp_2   - 1.5*gam(k-1)
              a4(3,k) = min( max(a4(3,k), min(a4(1,k), pmp_2, lac_2)),  &
                                          max(a4(1,k), pmp_2, lac_2) )
           endif
        endif
     enddo
  else
     do k=3,km-2
        if ( extm(k) .and. (extm(k-1) .or. extm(k+1)) ) then
             a4(2,k) = a4(1,k)
             a4(3,k) = a4(1,k)
        endif
     enddo
  endif

  do k=1,km-1
     a4(4,k) = 6.*a4(1,k) - 3.*(a4(2,k)+a4(3,k))
  enddo

  k = km-1
  if( extm(k) ) then
      a4(2,k) = a4(1,k)
      a4(3,k) = a4(1,k)
      a4(4,k) = 0.
  else
      da1  = a4(3,k) - a4(2,k)
      da2  = da1**2
      a6da = a4(4,k)*da1
      if(a6da < -da2) then
         a4(4,k) = 3.*(a4(2,k)-a4(1,k))
         a4(3,k) = a4(2,k) - a4(4,k)
      elseif(a6da > da2) then
         a4(4,k) = 3.*(a4(3,k)-a4(1,k))
         a4(2,k) = a4(3,k) - a4(4,k)
      endif
  endif

  call cs_limiters(km-1, a4)

! Bottom layer:
  a4(2,km) = a4(1,km)
  a4(3,km) = a4(1,km)
  a4(4,km) = 0.

 end subroutine cs_profile



 subroutine cs_limiters(km, a4)
 integer, intent(in) :: km
 real, intent(inout) :: a4(4,km)   ! PPM array
! !LOCAL VARIABLES:
 real, parameter:: r12 = 1./12.
 integer k

! Positive definite constraint

 do k=1,km
 if( abs(a4(3,k)-a4(2,k)) < -a4(4,k) ) then
     if( (a4(1,k)+0.25*(a4(3,k)-a4(2,k))**2/a4(4,k)+a4(4,k)*r12) < 0. ) then
         if( a4(1,k)<a4(3,k) .and. a4(1,k)<a4(2,k) ) then
             a4(3,k) = a4(1,k)
             a4(2,k) = a4(1,k)
             a4(4,k) = 0.
         elseif( a4(3,k) > a4(2,k) ) then
             a4(4,k) = 3.*(a4(2,k)-a4(1,k))
             a4(3,k) = a4(2,k) - a4(4,k)
         else
             a4(4,k) = 3.*(a4(3,k)-a4(1,k))
             a4(2,k) = a4(3,k) - a4(4,k)
         endif
     endif
 endif
 enddo

 end subroutine cs_limiters



 subroutine fall_speed(ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
 integer, intent(in)                     :: ktop, kbot
 real, intent(in ), dimension(ktop:kbot) :: den, qs, qi, qg, ql, tk
 real, intent(out), dimension(ktop:kbot) :: vts, vti, vtg
! fall velocity constants:
 real, parameter :: thi = 1.0e-9   ! cloud ice threshold for terminal fall
 real, parameter :: thg = 1.0e-9
 real, parameter :: ths = 1.0e-9
 real, parameter :: vf_min = 1.0E-6
!-----------------------------------------------------------------------
! marshall-palmer constants
!-----------------------------------------------------------------------
 real :: vcons = 6.6280504, vcong = 87.2382675, vconi = 3.29
 real :: norms = 942477796.076938, &
         normg =  5026548245.74367
 real, dimension(ktop:kbot) :: qden, tc
!real :: aa = -1.70704e-5, bb = -0.00319109, cc = -0.0169876, dd = 0.00410839, ee = 1.93644
 real :: aa = -4.14122e-5, bb = -0.00538922, cc = -0.0516344, dd = 0.00216078, ee = 1.9714 

 real :: rhof, rho0
 integer:: k
!-----------------------------------------------------------------------
! marshall-palmer formula
!-----------------------------------------------------------------------

! try the local air density -- for global model; the true value could be
! much smaller than sfcrho over high mountains

  if ( den_ref < 0. ) then
       rho0 = -den_ref*den(kbot) 
  else
       rho0 = den_ref   ! default=1.2
  endif

   do k=ktop, kbot
        rhof = sqrt( min(100., rho0/den(k)) )
! snow:
      if ( qs(k) < ths ) then
           vts(k) = vf_min
      else
           vts(k) = max(vf_min, vcons*rhof*exp(0.0625*log(qs(k)*den(k)/norms)))
!--------------------------------------------------------------------------------------
! What if ql == 0  (ri---> 0?)
!           ri(k) = 1./(1. + 6.e-5/(max(qcmin,ql(k)) * den(k)**1.235 * qs(k)**0.235))  !--- riming intensity
!          vts(k) = max(vf_min, vconi*rhof*exp( 0.16*log((1.0-ri(k))*qs(k)*den(k)) ) +   &
!                                19.3*rhof*exp( 0.37*log(     ri(k) *qs(k)*den(k)) ) )
!--------------------------------------------------------------------------------------
           vts(k) = vs_fac*vts(k)
      endif 

! graupel:
      if ( qg(k) < thg ) then
           vtg(k) = vf_min
      else
           vtg(k) = max(vf_min, max(vmin, vg_fac*vcong*rhof*sqrt(sqrt(sqrt(qg(k)*den(k)/normg)))))
      endif
   enddo

! ice:
   if ( use_deng_mace ) then
! ice use Deng and Mace (2008, GRL), which gives smaller fall speed than HD90 formula
       do k=ktop, kbot
          if ( qi(k) < thi ) then
               vti(k) = vf_min
          else
           qden(k) = log10( 1000.*qi(k)*den(k) )   !--- used in DM formula, in g/m^-3
             tc(k) = tk(k) - tice
            vti(k) = qden(k)*( tc(k)*(aa*tc(k) + bb) + cc ) + dd*tc(k) + ee
            vti(k) = max( vf_min, vi_fac*0.01*10.**vti(k) )
          endif
       enddo
   else
! HD90 ice speed:
       do k=ktop, kbot
          if ( qi(k) < thi ) then
               vti(k) = vf_min
          else
                 rhof = sqrt( min(100., rho0/den(k)) )
               vti(k) = max( vf_min, vconi*rhof*exp(0.16*log(qi(k)*den(k))) )
          endif
       enddo
   endif

 end subroutine fall_speed


 subroutine setupm

 real :: gcon, scm3, pisq, act(8), acc(3)
 real :: vdifu, tcond
 real :: visk
 real :: ch2o, hltf
 real ::  hlts, hltc, ri50

 real :: gam263, gam275, gam290,                                &
         gam325, gam350, gam380,                                &
         gam425, gam450, gam480,                                &
         gam625, gam680

 data  gam263/1.456943/,   gam275/1.608355/,  gam290/1.827363/  &
       gam325/2.54925/,    gam350/3.323363/,  gam380/4.694155/  &
       gam425/8.285063/,   gam450/11.631769/, gam480/17.837789/ &
       gam625/184.860962/, gam680/496.604067/
!
!     physical constants (mks)
!     lin's constants(mks) except rmi50,rmi40 (cgs)
!
 real :: rnzr, rnzs, rnzg, rhos, rhog
!data alin, clin  /842.0, 4.80/
 data rnzr /8.0e6/  ! lin83
 data rnzs /3.0e6/  ! lin83
 data rnzg /4.0e6/  ! rh84
 data rhos /0.1e3/  ! lin83    (snow density; 1/10 of water)
 data rhog /0.4e3/  ! rh84     (graupel density)
 data acc/5.0,2.0,0.5/

 real den_rc
 integer :: k, i

      pie = 4.*atan(1.0)

! S. Klein's formular (EQ 16) from AM2
      fac_rc = (4./3.)*pie*rhor*rthresh**3
      den_rc = fac_rc * ccn_o*1.e6
      if(master) write(*,*) 'MP: rthresh=', rthresh, 'vi_fac=', vi_fac
      if(master) write(*,*) 'MP: for ccn_o=', ccn_o, 'ql_rc=', den_rc
      den_rc = fac_rc * ccn_l*1.e6
      if(master) write(*,*) 'MP: for ccn_l=', ccn_l, 'ql_rc=', den_rc

      vdifu=2.11e-5
      tcond=2.36e-2

      visk=1.259e-5
      hlts=2.8336e6
      hltc=2.5e6
      hltf=3.336e5

      ch2o=4.1855e3
      rmi50=3.84e-6      ! Purdue Lin scheme 4.8e-7 [g]
!     rmi40=2.46e-7
      ri50=1.e-4

      pisq = pie*pie
      scm3 = (visk/vdifu)**(1./3.)
!
      cracs = pisq*rnzr*rnzs*rhos
      csacr = pisq*rnzr*rnzs*rhor
      cgacr = pisq*rnzr*rnzg*rhor
      cgacs = pisq*rnzg*rnzs*rhos
      cgacs = cgacs*c_pgacs
!
!     act:  1-2:racs(s-r); 3-4:sacr(r-s);
!           5-6:gacr(r-g); 7-8:gacs(s-g)
!
      act(1) = pie * rnzs * rhos
      act(2) = pie * rnzr * rhor
      act(6) = pie * rnzg * rhog
      act(3) = act(2)
      act(4) = act(1)
      act(5) = act(2)
      act(7) = act(1)
      act(8) = act(6)

      do i=1,3
         do k=1,4
            acco(i,k) = acc(i)/(act(2*k-1)**((7-i)*0.25)*act(2*k)**(i*0.25))
         enddo
      enddo
!
      gcon  = 40.74 * sqrt( sfcrho )   ! 44.628
!
      csacw = pie*rnzs*clin*gam325/(4.*act(1)**0.8125)
! Decreasing  csacw to reduce cloud water ---> snow

      craci = pie*rnzr*alin*gam380/(4.*act(2)**0.95)
      csaci = csacw * c_psaci
!
      cgacw = pie*rnzg*gam350*gcon/(4.*act(6)**0.875)
      cgaci = cgacw*0.1
!
      cracw = craci            ! cracw= 3.27206196043822
      cracw = c_cracw * cracw
!
!     subl and revp:  five constants for three separate processes
!
      cssub(1) = 2.*pie*vdifu*tcond*rvgas*rnzs
      cgsub(1) = 2.*pie*vdifu*tcond*rvgas*rnzg
      crevp(1) = 2.*pie*vdifu*tcond*rvgas*rnzr
      cssub(2) = 0.78/sqrt(act(1))
      cgsub(2) = 0.78/sqrt(act(6))
      crevp(2) = 0.78/sqrt(act(2))
      cssub(3) = 0.31*scm3*gam263*sqrt(clin/visk)/act(1)**0.65625
      cgsub(3) = 0.31*scm3*gam275*sqrt(gcon/visk)/act(6)**0.6875
      crevp(3) = 0.31*scm3*gam290*sqrt(alin/visk)/act(2)**0.725
      cssub(4) = tcond*rvgas
      cssub(5) = hlts**2*vdifu
      cgsub(4) = cssub(4)
      crevp(4) = cssub(4)
      cgsub(5) = cssub(5)
      crevp(5) = hltc**2*vdifu
!
      cgfr(1) = 20.e2*pisq*rnzr*rhor/act(2)**1.75
      cgfr(2) = 0.66
!
!sk ********************************************************************
!sk   smlt:  five constants ( lin et al. 1983 )
      csmlt(1) = 2.*pie*tcond*rnzs/hltf
      csmlt(2) = 2.*pie*vdifu*rnzs*hltc/hltf
      csmlt(3) = cssub(2)
      csmlt(4) = cssub(3)
      csmlt(5) = ch2o/hltf
!sk ********************************************************************
!     gmlt:  five constants
      cgmlt(1) = 2.*pie*tcond*rnzg/hltf
      cgmlt(2) = 2.*pie*vdifu*rnzg*hltc/hltf
      cgmlt(3) = cgsub(2)
      cgmlt(4) = cgsub(3)
      cgmlt(5) = ch2o/hltf
!sk ********************************************************************
      es0 = 6.107799961e2   ! ~6.1 mb
      ces0 = eps*es0
!
!     c2brg has conversion factor of 10**3
      c1brg = dts/rmi50
!lin  c2brg = ri50**2*1.e3 ! error
      c2brg = pie*ri50**2*1.e3

 end subroutine setupm


 subroutine lin_cld_microphys_init(id, jd, kd, axes, time)
 
    integer,         intent(in) :: id, jd, kd
    integer,         intent(in) :: axes(4)
    type(time_type), intent(in) :: time
    
    integer   :: unit, io, ierr, k, logunit
    integer   :: is, ie, js, je, ks, ke
    real :: tmp, q1, q2

    master = (mpp_pe().eq.mpp_root_pe())

#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=lin_cld_microphys_nml, iostat=io)
    ierr = check_nml_error(io,'lin_cld_microphys_nml')
#else   
    if( file_exist( 'input.nml' ) ) then
       unit = open_namelist_file ()
       io = 1
       do while ( io .ne. 0 )
          read( unit, nml = lin_cld_microphys_nml, iostat = io, end = 10 )
          ierr = check_nml_error(io,'lin_cld_microphys_nml')
       end do
10     call close_file ( unit )
    end if
#endif
    call write_version_number (version, tagname)
    logunit = stdlog()
    
    if ( do_setup ) then
      is = 1
      js = 1
      ks = 1
      ie = id
      je = jd
      ke = kd

      call setup_con (is, ie, js, je, ks, ke)
      call setupm
      do_setup = .false.
    endif

    if (master) write( logunit, nml = lin_cld_microphys_nml )
 
    id_vtr = register_diag_field ( mod_name, 'vt_r', axes(1:3), time,        &
         'rain fall speed', 'm/sec', missing_value=missing_value )
    id_vts = register_diag_field ( mod_name, 'vt_s', axes(1:3), time,        &
         'snow fall speed', 'm/sec', missing_value=missing_value )
    id_vtg = register_diag_field ( mod_name, 'vt_g', axes(1:3), time,        &
         'graupel fall speed', 'm/sec', missing_value=missing_value )
    id_vti = register_diag_field ( mod_name, 'vt_i', axes(1:3), time,        &
         'ice fall speed', 'm/sec', missing_value=missing_value )

    id_rain = register_diag_field ( mod_name, 'rain_lin', axes(1:2), time,        &
         'rain_lin', 'mm/day', missing_value=missing_value )
    id_snow = register_diag_field ( mod_name, 'snow_lin', axes(1:2), time,        &
         'snow_lin', 'mm/day', missing_value=missing_value )
    id_graupel = register_diag_field ( mod_name, 'graupel_lin', axes(1:2), time,  &
         'graupel_lin', 'mm/day', missing_value=missing_value )
    id_ice = register_diag_field ( mod_name, 'ice_lin', axes(1:2), time,        &
         'ice_lin', 'mm/day', missing_value=missing_value )
    id_prec = register_diag_field ( mod_name, 'prec_lin', axes(1:2), time,     &
         'prec_lin', 'mm/day', missing_value=missing_value )
!   if ( master ) write(*,*) 'prec_lin diagnostics initialized.', id_prec

    id_cond = register_diag_field ( mod_name, 'cond_lin', axes(1:2), time,     &
         'total condensate', 'kg/m**2', missing_value=missing_value )

    call qsmith_init

! TESTING the water vapor tables
   if ( mp_debug .and. master ) then
        write(*,*) 'TESTING water vapor tables in lin_cld_microphys'
        tmp = tice - 90.
   do k=1,25
      q1 = wqsat(tmp, 1.E5)
      q2 = iqsat(tmp, 1.E5)
      write(*,*) NINT(tmp-tice), q1, q2, 'dq=', q1-q2
      tmp = tmp + 5.
   enddo
   endif

   if ( master ) write(*,*) 'lin_cld_micrphys diagnostics initialized.'

   lin_cld_mp_clock = mpp_clock_id('Lin_cld_microphys', grain=CLOCK_ROUTINE)
   g_sum_initialized = .false.
   module_is_initialized = .true.
    
 end subroutine lin_cld_microphys_init



 subroutine lin_cld_microphys_end
   real gmp

  if ( mp_print ) then
! the g_sum call does not work if physics window is used *****
   if ( id_ice> 0 ) then
        gmp = g_sum(ice0, isc, iec, jsc, jec, ng, l_area, 1) 
        if(master) write(*,*) 'total ice=', gmp/mp_count
   endif
   if ( id_graupel> 0 ) then
        gmp = g_sum(graupel0, isc, iec, jsc, jec, ng, l_area, 1) 
        if(master) write(*,*) 'total graupel=', gmp/mp_count
   endif
   if ( id_snow> 0 ) then
        gmp = g_sum(snow0, isc, iec, jsc, jec, ng, l_area, 1) 
        if(master) write(*,*) 'total snow=', gmp/mp_count
   endif
   if ( id_rain> 0 ) then
        gmp = g_sum(rain0, isc, iec, jsc, jec, ng, l_area, 1) 
        if(master) write(*,*) 'total rain=', gmp/mp_count
   endif
!  if ( id_prec> 0 ) then
        gmp = g_sum(prec0, isc, iec, jsc, jec, ng, l_area, 1) 
        if(master) write(*,*) 'total prec=', gmp/mp_count
!  endif
  endif

   if ( id_vtr> 0 ) then
        deallocate ( vt_r )
   endif
   if ( id_vts> 0 ) then
        deallocate ( vt_s )
   endif
   if ( id_vti> 0 ) then
        deallocate ( vt_i )
   endif
   if ( id_vtg> 0 ) then
        deallocate ( vt_g )
   endif

   deallocate (  prec_mp  )
   deallocate (  prec0    )
   deallocate (  prec1    )
   deallocate (  rain0    )
   deallocate (  snow0    )
   deallocate (  ice0     )
   deallocate (  graupel0 )
   deallocate (  cond )

   deallocate ( table  )
   deallocate ( table2 )
   deallocate ( table3 )
   deallocate ( tablew )
   deallocate ( des )
   deallocate ( des2 )
   deallocate ( des3 )
   deallocate ( desw )
   module_is_initialized = .false.
   
 end subroutine lin_cld_microphys_end



 subroutine setup_con( is, ie, js, je, ks, ke )
 integer, intent(in) :: is,ie, js,je, ks, ke

  master = (mpp_pe().eq.mpp_root_pe())

  isc = is;   iec = ie
  jsc = js;   jec = je

  lcp = latv / cp
  icp = lati / cp
  tcp = (latv+lati) / cp

  rgrav = 1./ grav

  call qsmith_init

! fall speed diagnostics:
      if ( id_vtr> 0 ) then
           allocate ( vt_r(is:ie, js:je, ks:ke) )
           vt_r = 0.
      endif
      if ( id_vts> 0 ) then
           allocate ( vt_s(is:ie, js:je, ks:ke) )
           vt_s = 0.
      endif
      if ( id_vtg> 0 ) then
           allocate ( vt_g(is:ie, js:je, ks:ke) )
           vt_g = 0.
      endif
      if ( id_vti> 0 ) then
           allocate ( vt_i(is:ie, js:je, ks:ke) )
           vt_i = 0.
      endif

      allocate (     cond(is:ie, js:je) )
      allocate (  prec_mp(is:ie, js:je) )
      allocate (    prec0(is:ie, js:je) )
      allocate (    prec1(is:ie, js:je) )
      allocate (    rain0(is:ie, js:je) )
      allocate (    snow0(is:ie, js:je) )
      allocate (     ice0(is:ie, js:je) )
      allocate ( graupel0(is:ie, js:je) )

      prec0 = 0.
      prec1 = 0.
      rain0 = 0.
      snow0 = 0.
       ice0 = 0.
   graupel0 = 0.
 

 end subroutine setup_con



 real function acr3d(v1, v2, q1, q2, c, cac, rho)
 real, intent(in) :: v1, v2, c, rho
 real, intent(in) :: q1, q2    ! mixing ratio!!!
 real, intent(in) :: cac(3)
 real :: t1, s1, s2
!integer :: k
! real:: a
!     a=0.0
!     do k=1,3
!        a = a + cac(k)*( (q1*rho)**((7-k)*0.25) * (q2*rho)**(k*0.25) )
!     enddo
!     acr3d = c * abs(v1-v2) * a/rho
!----------
! Optimized
!----------
      t1 = sqrt(q1*rho)
      s1 = sqrt(q2*rho)
      s2 = sqrt(s1)       ! s1 = s2**2
      acr3d = c*abs(v1-v2)*q1*s2*(cac(1)*t1 + cac(2)*sqrt(t1)*s2 + cac(3)*s1)

 end function acr3d




 real function smlt(tc, dqs, qsrho,psacw,psacr,c,rho, rhofac)
 real, intent(in):: tc,dqs,qsrho,psacw,psacr,c(5),rho, rhofac
     
 smlt = (c(1)*tc/rho-c(2)*dqs) * (c(3)*sqrt(qsrho)+ &
         c(4)*qsrho**0.65625*sqrt(rhofac)) + c(5)*tc*(psacw+psacr)

 end function smlt
 

 real function gmlt(tc, dqs,qgrho,pgacw,pgacr,c, rho)
 real, intent(in)::  tc,dqs,qgrho,pgacw,pgacr,c(5),rho
     
!     note:  pgacw and pgacr must be calc before gmlt is called
!
 gmlt = (c(1)*tc/rho-c(2)*dqs) * (c(3)*sqrt(qgrho)+ &
         c(4)*qgrho**0.6875/rho**0.25) + c(5)*tc*(pgacw+pgacr)
 end function gmlt


 subroutine qsmith_init
  integer, parameter:: length=2621 
  integer i

  if( .not. allocated(table) ) then
!                            generate es table (dt = 0.1 deg. c)
       allocate ( table( length) )
       allocate ( table2(length) )
       allocate ( table3(length) )
       allocate ( tablew(length) )
       allocate (   des (length) )
       allocate (   des2(length) )
       allocate (   des3(length) )
       allocate (   desw(length) )

       call qs_table (length )
       call qs_table2(length )
       call qs_table3(length )
       call qs_tablew(length )

       do i=1,length-1
           des(i) = max(0.,  table(i+1) -  table(i))
          des2(i) = max(0., table2(i+1) - table2(i))
          des3(i) = max(0., table3(i+1) - table3(i))
          desw(i) = max(0., tablew(i+1) - tablew(i))
       enddo
        des(length) =  des(length-1)
       des2(length) = des2(length-1)
       des3(length) = des3(length-1)
       desw(length) = desw(length-1)
  endif
 
 end subroutine qsmith_init
 

 real function qs1d(ta, pa, dqdt)
! 2-phase tabel
  real, intent(in):: ta, pa
  real, intent(out):: dqdt
! local:
  real es, ap1
  real, parameter:: tmin=tice - 160.
  real, parameter:: eps10 = 10.*eps
  integer it

       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
        es = table2(it) + (ap1-it)*des2(it)
      qs1d = eps*es/pa
        it = ap1 - 0.5
      dqdt = eps10*(des2(it) + (ap1-it)*(des2(it+1)-des2(it)))/pa

 end function qs1d


 real function ws1d(ta, pa, dqdt)
! Pure water phase
  real, intent(in):: ta, pa
  real, intent(out):: dqdt
! local:
  real es, ap1
  real, parameter:: tmin=tice - 160.
  real, parameter:: eps10 = 10.*eps
  integer it

       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
        es = tablew(it) + (ap1-it)*desw(it)
      ws1d = eps*es/pa
        it = ap1 - 0.5
      dqdt = eps10*(desw(it) + (ap1-it)*(desw(it+1)-desw(it)))/pa

 end function ws1d


 real function wqsat(ta, pa)
! Pure water phase
  real, intent(in):: ta, pa
! local:
  real es, ap1
  real, parameter:: tmin=tice - 160.
  integer it

       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
        es = tablew(it) + (ap1-it)*desw(it)
     wqsat = eps*es/pa

 end function wqsat

 real function iqsat(ta, pa)
  real, intent(in):: ta, pa
! local:
  real es, ap1
  real, parameter:: tmin=tice - 160.
  integer it

       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
        es = table2(it) + (ap1-it)*des2(it)
     iqsat = eps*es/pa

 end function iqsat

 real function d_sat(ta)
! Computes the difference in saturation vapor *density* between water and ice
  real, intent(in):: ta
  real, parameter:: tmin=tice - 160.
  real es_w, es_i, ap1
  integer it

       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
! over Water:
       es_w = tablew(it) + (ap1-it)*desw(it)
! over Ice:
       es_i = table2(it) + (ap1-it)*des2(it)
      d_sat = dim(es_w, es_i)/(rvgas*ta)  ! Take positive difference

 end function d_sat


 real function esw_table(ta)
! pure water phase table
  real, intent(in):: ta
  real, parameter:: tmin=tice - 160.
  real  ap1
  integer it
       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
      esw_table = tablew(it) + (ap1-it)*desw(it)
 end function esw_table


 real function es2_table(ta)
! two-phase table
  real, intent(in):: ta
  real, parameter:: tmin=tice - 160.
  real  ap1
  integer it
       ap1 = 10.*dim(ta, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
      es2_table = table2(it) + (ap1-it)*des2(it)
 end function es2_table


 subroutine esw_table1d(ta, es, n)
  integer, intent(in):: n
! For waterphase only
  real, intent(in)::  ta(n)
  real, intent(out):: es(n)
  real, parameter:: tmin=tice - 160.
  real  ap1
  integer i, it

  do i=1, n
       ap1 = 10.*dim(ta(i), tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
     es(i) = tablew(it) + (ap1-it)*desw(it)
  enddo
 end subroutine esw_table1d



 subroutine es2_table1d(ta, es, n)
  integer, intent(in):: n
! two-phase table with -2C as the transition point for ice-water phase
! For sea ice model
  real, intent(in)::  ta(n)
  real, intent(out):: es(n)
  real, parameter:: tmin=tice - 160.
  real  ap1
  integer i, it

  do i=1, n
       ap1 = 10.*dim(ta(i), tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
     es(i) = table2(it) + (ap1-it)*des2(it)
  enddo
 end subroutine es2_table1d


 subroutine es3_table1d(ta, es, n)
  integer, intent(in):: n
! two-phase table with -2C as the transition point for ice-water phase
  real, intent(in)::  ta(n)
  real, intent(out):: es(n)
  real, parameter:: tmin=tice - 160.
  real  ap1
  integer i, it

  do i=1, n
       ap1 = 10.*dim(ta(i), tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
     es(i) = table3(it) + (ap1-it)*des3(it)
  enddo
 end subroutine es3_table1d



 subroutine qs_tablew(n)
! 2-phase table
      integer, intent(in):: n
      real:: delt=0.1
      real esbasw, tbasw, esbasi, tbasi, tmin, tem, aa, b, c, d, e
      integer i

! constants
      esbasw = 1013246.0
       tbasw =     373.16
      esbasi =    6107.1
       tbasi =     273.16
        tmin = tbasi - 160.

     do i=1,n
        tem = tmin+delt*real(i-1)
!  compute es over water
!  see smithsonian meteorological tables page 350.
        aa  = -7.90298*(tbasw/tem-1.)
        b   =  5.02808*alog10(tbasw/tem)
        c   = -1.3816e-07*(10**((1.-tem/tbasw)*11.344)-1.)
        d   =  8.1328e-03*(10**((tbasw/tem-1.)*(-3.49149))-1.)
        e   = alog10(esbasw)
        tablew(i) = 0.1 * 10**(aa+b+c+d+e)
     enddo

 end subroutine qs_tablew


 subroutine qs_table2(n)
! 2-phase table
  integer, intent(in):: n
  real:: delt=0.1
  real esbasw, tbasw, esbasi, tbasi, tmin, tem, aa, b, c, d, e
  integer :: i0, i1
  real :: tem0, tem1
  integer i

! constants
      esbasw = 1013246.0
       tbasw =     373.16
      esbasi =    6107.1
       tbasi =     273.16
      tmin = tbasi - 160.

     do i=1,n
        tem = tmin+delt*real(i-1)
        if ( i<= 1600 ) then
!  compute es over ice between -160c and 0 c.
!  see smithsonian meteorological tables page 350.
              aa  = -9.09718 *(tbasi/tem-1.)
              b   = -3.56654 *alog10(tbasi/tem)
              c   =  0.876793*(1.-tem/tbasi)
              e   = alog10(esbasi)
             table2(i) = 0.1 * 10**(aa+b+c+e)
        else
!  compute es over water between 0c and 102c.
!  see smithsonian meteorological tables page 350.
             aa  = -7.90298*(tbasw/tem-1.)
             b   =  5.02808*alog10(tbasw/tem)
             c   = -1.3816e-07*(10**((1.-tem/tbasw)*11.344)-1.)
             d   =  8.1328e-03*(10**((tbasw/tem-1.)*(-3.49149))-1.)
             e   = alog10(esbasw)
             table2(i) = 0.1 * 10**(aa+b+c+d+e)
        endif
     enddo

!----------
! smoother
!----------
      i0 = 1600;  i1 = 1601
      tem0 = 0.25*(table2(i0-1) + 2.*table(i0) + table2(i0+1))
      tem1 = 0.25*(table2(i1-1) + 2.*table(i1) + table2(i1+1))
      table2(i0) = tem0
      table2(i1) = tem1

 end subroutine qs_table2



 subroutine qs_table3(n)
! 2-phase table with "-2 C" as the transition point
  integer, intent(in):: n
  real:: delt=0.1
  real esbasw, tbasw, esbasi, tbasi, tmin, tem, aa, b, c, d, e
  integer :: i0, i1
  real :: tem0, tem1
  integer i

! constants
      esbasw = 1013246.0
       tbasw =     373.16
      esbasi =    6107.1
       tbasi =     273.16
      tmin = tbasi - 160.

     do i=1,n
        tem = tmin+delt*real(i-1)
!       if ( i<= 1600 ) then
        if ( i<= 1580 ) then  ! to -2 C
!  compute es over ice between -160c and 0 c.
!  see smithsonian meteorological tables page 350.
              aa  = -9.09718 *(tbasi/tem-1.)
              b   = -3.56654 *alog10(tbasi/tem)
              c   =  0.876793*(1.-tem/tbasi)
              e   = alog10(esbasi)
             table3(i) = 0.1 * 10**(aa+b+c+e)
        else
!  compute es over water between -2c and 102c.
!  see smithsonian meteorological tables page 350.
             aa  = -7.90298*(tbasw/tem-1.)
             b   =  5.02808*alog10(tbasw/tem)
             c   = -1.3816e-07*(10**((1.-tem/tbasw)*11.344)-1.)
             d   =  8.1328e-03*(10**((tbasw/tem-1.)*(-3.49149))-1.)
             e   = alog10(esbasw)
             table3(i) = 0.1 * 10**(aa+b+c+d+e)
        endif
     enddo

!----------
! smoother
!----------
      i0 = 1580
      tem0 = 0.25*(table3(i0-1) + 2.*table(i0) + table3(i0+1))
      i1 = 1581
      tem1 = 0.25*(table3(i1-1) + 2.*table(i1) + table3(i1+1))
      table3(i0) = tem0
      table3(i1) = tem1

 end subroutine qs_table3


 real function qs1d_blend(t, p, q)
! Note: this routine is based on "moist" mixing ratio
! Blended mixed phase table
  real, intent(in):: t, p, q
  real es, ap1
  real, parameter:: tmin=tice - 160.
  integer it

       ap1 = 10.*dim(t, tmin) + 1.
       ap1 = min(2621., ap1)
        it = ap1
        es = table(it) + (ap1-it)*des(it)
      qs1d_blend = eps*es*(1.+zvir*q)/p

 end function qs1d_blend

 subroutine qs_table(n)
      integer, intent(in):: n
      real esupc(200)
      real:: delt=0.1
      real esbasw, tbasw, esbasi, tbasi, tmin, tem, aa, b, c, d, e, esh20 
      real wice, wh2o
      integer i

! constants
      esbasw = 1013246.0
       tbasw =     373.16
      esbasi =    6107.1
       tbasi =     273.16

!  compute es over ice between -160c and 0 c.
      tmin = tbasi - 160.
!  see smithsonian meteorological tables page 350.
      do i=1,1600
         tem = tmin+delt*real(i-1)
         aa  = -9.09718 *(tbasi/tem-1.)
         b   = -3.56654 *alog10(tbasi/tem)
         c   =  0.876793*(1.-tem/tbasi)
         e   = alog10(esbasi)
         table(i)=10**(aa+b+c+e)
      enddo

!  compute es over water between -20c and 102c.
!  see smithsonian meteorological tables page 350.
      do  i=1,1221
          tem = 253.16+delt*real(i-1)
          aa  = -7.90298*(tbasw/tem-1.)
          b   =  5.02808*alog10(tbasw/tem)
          c   = -1.3816e-07*(10**((1.-tem/tbasw)*11.344)-1.)
          d   =  8.1328e-03*(10**((tbasw/tem-1.)*(-3.49149))-1.)
          e   = alog10(esbasw)
          esh20  = 10**(aa+b+c+d+e)
          if (i <= 200) then
              esupc(i) = esh20
          else
              table(i+1400) = esh20
          endif
      enddo

!  derive blended es over ice and supercooled water between -20c and 0c
      do i=1,200
         tem  = 253.16+delt*real(i-1)
         wice = 0.05*(273.16-tem)
         wh2o = 0.05*(tem-253.16)
         table(i+1400) = wice*table(i+1400)+wh2o*esupc(i)
      enddo

      do i=1,n
         table(i) = table(i)*0.1
      enddo

 end subroutine qs_table


 subroutine qsmith(im, km, ks, t, p, q, qs, dqdt)
! input t in deg k; p (pa) : moist pressure
  integer, intent(in):: im, km, ks
  real, intent(in),dimension(im,km):: t, p, q
  real, intent(out),dimension(im,km):: qs
  real, intent(out), optional:: dqdt(im,km)
! local:
  real, parameter:: eps10 = 10.*eps
  real es(im,km)
  real ap1
  real tmin
  integer i, k, it

  tmin = tice-160.

  if( .not. allocated(table) ) then
       call  qsmith_init
  endif
 
      do k=ks,km
         do i=1,im
            ap1 = 10.*dim(t(i,k), tmin) + 1.
            ap1 = min(2621., ap1)
            it = ap1
            es(i,k) = table(it) + (ap1-it)*des(it)
            qs(i,k) = eps*es(i,k)*(1.+zvir*q(i,k))/p(i,k)
         enddo
      enddo

      if ( present(dqdt) ) then
      do k=ks,km
           do i=1,im
              ap1 = 10.*dim(t(i,k), tmin) + 1.
              ap1 = min(2621., ap1) - 0.5
              it  = ap1
              dqdt(i,k) = eps10*(des(it)+(ap1-it)*(des(it+1)-des(it)))*(1.+zvir*q(i,k))/p(i,k)
           enddo
      enddo
      endif
 
 end subroutine qsmith


 subroutine neg_adj(ktop, kbot, p1, pt, dp, qv, ql, qr, qi, qs, qg)
! 1d version:
! this is designed for 6-class micro-physics schemes
 integer, intent(in):: ktop, kbot
 real, intent(in):: dp(ktop:kbot), p1(ktop:kbot)
 real, intent(inout), dimension(ktop:kbot)::    &
                                pt, qv, ql, qr, qi, qs, qg
! local:
 real lcpk(ktop:kbot), icpk(ktop:kbot)
 real dq
 integer k

 do k=ktop,kbot
!      tmp1 = cp - rdgas*ptop/p1(k)
!   lcpk(k) = latv / tmp1
!   icpk(k) = lati / tmp1
    lcpk(k) = latv / cp
    icpk(k) = lati / cp
 enddo

 do k=ktop, kbot
!-----------
! ice-phase:
!-----------
! if ice<0 borrow from snow
          if( qi(k) < 0. ) then
              qs(k) = qs(k) + qi(k)
              qi(k) = 0.
          endif
! if snow<0 borrow from graupel
          if( qs(k) < 0. ) then
              qg(k) = qg(k) + qs(k)
              qs(k) = 0.
          endif
! if graupel < 0 then borrow from rain
          if ( qg(k) < 0. ) then
               qr(k) = qr(k) + qg(k)
               pt(k) = pt(k) - qg(k)*icpk(k)   ! heating
               qg(k) = 0.
          endif

! liquid phase:
! fix negative rain by borrowing from cloud water
          if ( qr(k) < 0. ) then
               ql(k) = ql(k) + qr(k)
               qr(k) = 0.
          endif
! fix negative cloud water with vapor
          if ( ql(k) < 0. ) then
               qv(k) = qv(k) + ql(k)
               pt(k) = pt(k) - ql(k)*lcpk(k)
               ql(k) = 0.
          endif
 enddo

!-----------------------------------
! fix water vapor; borrow from below
!-----------------------------------
 do k=ktop,kbot-1
    if( qv(k) < 0. ) then
        qv(k+1) = qv(k+1) + qv(k)*dp(k)/dp(k+1)
        qv(k  ) = 0.
    endif
 enddo
 
! bottom layer; borrow from above
 if( qv(kbot) < 0. .and. qv(kbot-1)>0.) then
             dq = min(-qv(kbot)*dp(kbot), qv(kbot-1)*dp(kbot-1))
     qv(kbot-1) = qv(kbot-1) - dq/dp(kbot-1) 
     qv(kbot  ) = qv(kbot  ) + dq/dp(kbot  ) 
 endif
! if qv is still < 0

 end subroutine neg_adj




 subroutine sg_conv(is, ie, js, je, isd, ied, jsd, jed,               &
                    isc, iec, jsc, jec,  km, nq, dt, tau,             &
                    delp, phalf, pm, zfull, zhalf, ta, qa, ua, va, w, &
                    u_dt, v_dt, t_dt, q_dt, mcond, land, pblht, nqv, nql, nqi, &
                    hydrostatic, phys_hydrostatic)
! Non-precipitating sub-grid scale convective adjustment-mixing
!-------------------------------------------
      logical, intent(in):: hydrostatic, phys_hydrostatic
      integer, intent(in):: is, ie, js, je, km, nq
      integer, intent(in):: mcond
      integer, intent(in):: isc, iec, jsc, jec
      integer, intent(in):: isd, ied, jsd, jed
      integer, intent(in):: tau            ! Relaxation time scale
      integer, intent(in):: nqv, nql, nqi  ! vapor, liquid, ice
      real, intent(in):: dt             ! model time step
      real, intent(in):: phalf(is:ie,js:je,km+1) 
      real, intent(in):: pm(is:ie,js:je,km)
      real, intent(in):: zfull(is:ie,js:je,km)
      real, intent(in):: zhalf(is:ie,js:je,km+1)
      real, intent(in):: delp(isd:ied,jsd:jed,km)      ! Delta p at each model level
      real, intent(in)::   ta(isd:ied,jsd:jed,km)      ! Temperature
      real, intent(in)::   qa(isd:ied,jsd:jed,km,nq)   ! Specific humidity & tracers
      real, intent(in)::   ua(isd:ied,jsd:jed,km)
      real, intent(in)::   va(isd:ied,jsd:jed,km)
      real, intent(inout):: w(isd:ied,jsd:jed,km)
      real, intent(in)::  land(is:ie,js:je)
      real, intent(in):: pblht(is:ie,js:je)     ! depth (m) of the PBL
! Output:
! Updated fields:
      real, intent(out):: u_dt(isd:ied,jsd:jed,km)   ! updated u-wind field
      real, intent(out):: v_dt(isd:ied,jsd:jed,km)   !         v-wind
      real, intent(out):: t_dt(isc:iec,jsc:jec,km)   !         temperature
      real, intent(out):: q_dt(isc:iec,jsc:jec,km,nq) !
!---------------------------Local variables-----------------------------
      real, dimension(is:ie,km):: tvm, u0, v0, w0, t0, gz, hd, pkz
      real, dimension(is:ie,km+1):: pk, peln
      real q0(is:ie,km,nq) 
      real gzh(is:ie)
      real ri, pt1, pt2, lf, ratio
      real rdt, dh, dh0, dhs, tv, h0, mc, fra, rk, rz, rcp
      real qs1
      real clouds, rqi
      integer kcond
      integer i, j, k, n, m, iq, kk
      real, parameter:: ustar2 = 1.E-8
      real, parameter:: dh_min = 1.E-4

      if ( nqv /= 1 .or. nql/=2 ) then
           call error_mesg ('sg_conv', 'Tracer indexing error', FATAL) 
      endif

!     call prt_maxmin('PBL_HT', pblht, is, ie, js, je, 0, 1, 1., master)


    rz = rvgas - rdgas          ! rz = zvir * rdgas
    rk = cp_air/rdgas + 1.
   rcp = 1./cp_air

    m = 4
    rdt = 1. / dt
    fra = dt/real(tau)

!------------
! Compute gz: center 
!------------
  do 1000 j=js,je       ! this main loop can be OpneMPed in j

    do k=mcond,km+1
       do i=is,ie
          peln(i,k) = log(phalf(i,j,k))
!           pk(i,k) = phalf(i,j,k)**kappa
            pk(i,k) = exp(kappa*peln(i,k))
       enddo
    enddo

    do k=mcond,km
       do i=is,ie
          u0(i,k) = ua(i,j,k)
          v0(i,k) = va(i,j,k)
          t0(i,k) = ta(i,j,k)
         pkz(i,k) = (pk(i,k+1)-pk(i,k))/(kappa*(peln(i,k+1)-peln(i,k)))
       enddo
    enddo

    if ( .not.hydrostatic ) then
       do k=mcond,km
          do i=is,ie
             w0(i,k) = w(i,j,k)
          enddo
       enddo
    endif

    do iq=1,nq
       do k=mcond,km
          do i=is,ie
             q0(i,k,iq) = qa(i,j,k,iq)
          enddo
       enddo
    enddo


!-----------------
! K-H instability:
!-----------------
   kcond = mcond

   do n=1,m
      ratio = real(n)/real(m)

    if( phys_hydrostatic ) then
       do i=is,ie
          gzh(i) = 0.
       enddo
       do k=km, mcond,-1
          do i=is,ie
           tvm(i,k) = t0(i,k)*(1.+zvir*q0(i,k,nqv))
                tv  = rdgas*tvm(i,k)
            gz(i,k) = gzh(i) + tv*(1.-phalf(i,j,k)/pm(i,j,k))
            hd(i,k) = cp_air*tvm(i,k)+gz(i,k)+0.5*(u0(i,k)**2+v0(i,k)**2)
             gzh(i) = gzh(i) + tv*(peln(i,k+1)-peln(i,k))
          enddo
       enddo
       do i=is,ie
          gzh(i) = 0.
       enddo
    else
       do k=mcond,km
          do i=is,ie
             gz(i,k) = grav*zfull(i,j,k)
             hd(i,k) = cp_air*t0(i,k)+gz(i,k)+0.5*(u0(i,k)**2+v0(i,k)**2+w0(i,k)**2)
          enddo
       enddo
    endif

      do k=km,kcond+1,-1
         do i=is,ie
! Richardson number at interface: g*delz * (del_theta/theta) / (del_u**2 + del_v**2)
            pt1 = t0(i,k-1)/pkz(i,k-1)
            pt2 = t0(i,k  )/pkz(i,k  )
             ri = (gz(i,k-1)-gz(i,k))*(pt1-pt2)/( 0.5*(pt1+pt2)*        &
                 ((u0(i,k-1)-u0(i,k))**2+(v0(i,k-1)-v0(i,k))**2+ustar2) )
! Dry convective mixing for K-H instability & CAT (Clear Air Turbulence):
! Compute equivalent mass flux: mc
#ifndef USE_RIP1  
            if ( ri < 0.25 ) then
                 mc = ratio * (1.-max(0.0, 4.*ri)) ** 2
#else
            if ( ri < 1. ) then
                 mc = ratio * (1.-max(0.0, ri)) ** 2
#endif 
                 mc = mc*delp(i,j,k-1)*delp(i,j,k)/(delp(i,j,k-1)+delp(i,j,k))
                 do iq=1,nq
                              h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                    q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                    q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                 enddo
! u:
                        h0 = mc*(u0(i,k)-u0(i,k-1))
                 u0(i,k-1) = u0(i,k-1) + h0/delp(i,j,k-1)
                 u0(i,k  ) = u0(i,k  ) - h0/delp(i,j,k  )
! v:
                        h0 = mc*(v0(i,k)-v0(i,k-1))
                 v0(i,k-1) = v0(i,k-1) + h0/delp(i,j,k-1)
                 v0(i,k  ) = v0(i,k  ) - h0/delp(i,j,k  )
! h:
                          h0 = mc*(hd(i,k)-hd(i,k-1))
                   hd(i,k-1) = hd(i,k-1) + h0/delp(i,j,k-1)
                   hd(i,k  ) = hd(i,k  ) - h0/delp(i,j,k  )
                if ( .not.hydrostatic ) then
                           h0 = mc*(w0(i,k)-w0(i,k-1))
                    w0(i,k-1) = w0(i,k-1) + h0/delp(i,j,k-1)
                    w0(i,k  ) = w0(i,k  ) - h0/delp(i,j,k  )
                endif
            endif
         enddo
!--------------
! Retrive Temp:
!--------------
      if ( phys_hydrostatic ) then
         kk = k
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ( rk - phalf(i,j,kk)/pm(i,j,kk) )
              gzh(i) = gzh(i) + t0(i,kk)*(peln(i,kk+1)-peln(i,kk))
            t0(i,kk) = t0(i,kk) / ( rdgas + rz*q0(i,kk,nqv) )
         enddo
         kk = k-1
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ((rk-phalf(i,j,kk)/pm(i,j,kk))*(rdgas+rz*q0(i,kk,nqv)))
         enddo
      else
! Non-hydrostatic under constant volume heating/cooling
         do kk=k-1,k
            do i=is,ie
               t0(i,kk) = rcp*(hd(i,kk)-gz(i,kk)-0.5*(u0(i,kk)**2+v0(i,kk)**2+w0(i,kk)**2))
            enddo
         enddo
      endif
      enddo
   enddo       ! n-loop


!-------------------------
! Moist adjustment/mixing:
!-------------------------
 m = 4

 if( km>k_moist+1 ) then
   do n=1,m

    ratio = real(n)/real(m)

    if ( phys_hydrostatic ) then
       do i=is,ie
          gzh(i) = 0.
       enddo
    endif

    do k=km,max(kcond,k_moist)+1,-1
       do i=is,ie
          if ( phalf(i,j,k) > p_crt ) then
!--------------------------------------------------------------------
!           qs1 = qs1d_blend(t0(i,k-1), pm(i,j,k-1), q0(i,k-1,nqv))
!            lf = hlv + hlf*min(1.0, max(0.0, (tice-t0(i,k-1))/30.))
!--------------------------------------------------------------------
            clouds = q0(i,k-1,nql) + q0(i,k-1,nqi)
            if( clouds > 1.e-5 ) then
                rqi = q0(i,k-1,nqi) / clouds
            else
                rqi = max(0., min(1., (tice-t0(i,k-1))/30.))
            end if
            qs1 = rqi*es2_table(t0(i,k-1)) + (1.-rqi)*esw_table(t0(i,k-1))
            qs1 = eps*qs1*(1.+zvir*q0(i,k-1,nqv))/pm(i,j,k-1)
             lf = hlv + rqi*hlf

              dh0 = hd(i,k) - hd(i,k-1)
              dhs = dh0 + lf*(q0(i,k,nqv)-qs1        )
              dh  = dh0 + lf*(q0(i,k,nqv)-q0(i,k-1,nqv))
!             if ( dhs>0.0 .and. dh>dh_min ) then
              if ( dhs>0.0 .and. dh>dh_min .and. q0(i,k,nqv)>q0(i,k-1,nqv) ) then
                   mc = ratio*min(1.0, 0.5*dhs/dh)*    &
                        delp(i,j,k-1)*delp(i,j,k)/(delp(i,j,k-1)+delp(i,j,k))
                          h0 = mc*dh0
                   hd(i,k-1) = hd(i,k-1) + h0/delp(i,j,k-1)
                   hd(i,k  ) = hd(i,k  ) - h0/delp(i,j,k  )
! Perform local mixing of all advected tracers:
#ifdef DET_CON
!                if ( zhalf(i,j,k) > (pblht(i,j)+zhalf(i,j,km+1)) ) then
                 if ( zhalf(i,j,k) > (1.E3+zhalf(i,j,km+1)) ) then
                      detn = min(1., zhalf(i,j,k)/7.e3)
! specific humidity:
                              h0 = mc*(q0(i,k,nqv)-q0(i,k-1,nqv))
                              dq = h0/delp(i,j,k-1)
                   q0(i,k-1,nqv) = q0(i,k-1,nqv) + dq*(1.-detn)
                   q0(i,k  ,nqv) = q0(i,k  ,nqv) - h0/delp(i,j,k  )
                   do iq=2,nq
                                h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                      q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                      q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                   enddo
!--------------
! Condensation:
!--------------
                   dq = dq * detn
                   q0(i,k-1,nql) = q0(i,k-1,nql) + dq*(1.-rqi)
                   q0(i,k-1,nqi) = q0(i,k-1,nqi) + dq*rqi
                   hd(i,k-1) = hd(i,k-1) + dq*lf

                 else
                   do iq=1,nq
                                h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                      q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                      q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                   enddo
                 endif
#else
                   do iq=1,nq
                                h0 = mc*(q0(i,k,iq)-q0(i,k-1,iq))
                      q0(i,k-1,iq) = q0(i,k-1,iq) + h0/delp(i,j,k-1)
                      q0(i,k  ,iq) = q0(i,k  ,iq) - h0/delp(i,j,k  )
                   enddo
#endif
! u:
                          h0 = mc*(u0(i,k)-u0(i,k-1))
                   u0(i,k-1) = u0(i,k-1) + h0/delp(i,j,k-1)
                   u0(i,k  ) = u0(i,k  ) - h0/delp(i,j,k  )
! v:
                          h0 = mc*(v0(i,k)-v0(i,k-1))
                   v0(i,k-1) = v0(i,k-1) + h0/delp(i,j,k-1)
                   v0(i,k  ) = v0(i,k  ) - h0/delp(i,j,k  )
! *** Non-hydrostatic:
                  if ( .not.hydrostatic ) then
                          h0 = mc*(w0(i,k)-w0(i,k-1))
                   w0(i,k-1) = w0(i,k-1) + h0/delp(i,j,k-1)
                   w0(i,k  ) = w0(i,k  ) - h0/delp(i,j,k  )
                  endif
! ***
              endif  ! dh check
            endif    ! p_crt check
         enddo
!--------------
! Retrive Temp:
!--------------
       if ( phys_hydrostatic ) then
         kk = k
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ( rk - phalf(i,j,kk)/pm(i,j,kk) )
              gzh(i) = gzh(i) + t0(i,kk)*(peln(i,kk+1)-peln(i,kk))
            t0(i,kk) = t0(i,kk) / ( rdgas + rz*q0(i,kk,nqv) )
         enddo
         kk = k-1
         do i=is,ie
            t0(i,kk) = (hd(i,kk)-gzh(i)-0.5*(u0(i,kk)**2+v0(i,kk)**2))  &
                     / ((rk-phalf(i,j,kk)/pm(i,j,kk))*(rdgas+rz*q0(i,kk,nqv)))
         enddo
       else
! Non-hydrostatic under constant volume heating/cooling
         do kk=k-1,k
            do i=is,ie
               t0(i,kk) = rcp*(hd(i,kk)-gz(i,kk)-0.5*(u0(i,kk)**2+v0(i,kk)**2+w0(i,kk)**2))
            enddo
         enddo
       endif
      enddo
   enddo       ! n-loop
 endif      ! k_moist check

   if ( fra < 1. ) then
      do k=mcond,km
         do i=is,ie
            t0(i,k) = ta(i,j,k) + (t0(i,k) - ta(i,j,k))*fra
            u0(i,k) = ua(i,j,k) + (u0(i,k) - ua(i,j,k))*fra
            v0(i,k) = va(i,j,k) + (v0(i,k) - va(i,j,k))*fra
         enddo
      enddo

      if ( .not.hydrostatic ) then
      do k=mcond,km
         do i=is,ie
            w0(i,k) = w(i,j,k) + (w0(i,k) - w(i,j,k))*fra
         enddo
      enddo
      endif

      do iq=1,nq
         do k=mcond,km
            do i=is,ie
               q0(i,k,iq) = qa(i,j,k,iq) + (q0(i,k,iq) - qa(i,j,k,iq))*fra
            enddo
         enddo
      enddo
   endif

!--------------------
! Update fields:
!--------------------
   do k=1,mcond-1
      do i=is,ie
         u_dt(i,j,k) = ua(i,j,k)
         v_dt(i,j,k) = va(i,j,k)
         t_dt(i,j,k) = ta(i,j,k)
      enddo
   enddo
   do k=mcond,km
      do i=is,ie
         u_dt(i,j,k) = u0(i,k)
         v_dt(i,j,k) = v0(i,k)
         t_dt(i,j,k) = t0(i,k)
      enddo
   enddo

   if ( .not.hydrostatic ) then
      do k=mcond,km
         do i=is,ie
            w(i,j,k) = w0(i,k)
         enddo
      enddo
   endif

   do iq=1,nq
      do k=1,mcond-1
         do i=is,ie
            q_dt(i,j,k,iq) = qa(i,j,k,iq)
         enddo
      enddo
      do k=mcond,km
         do i=is,ie
            q_dt(i,j,k,iq) = q0(i,k,iq)
         enddo
      enddo
   enddo

1000 continue


 end subroutine sg_conv


 real function g_sum(p, ifirst, ilast, jfirst, jlast, ngc, area, mode)
      use mpp_mod,           only: mpp_sum
      real, save :: global_area

! Fast version of globalsum
      integer, intent(IN) :: ifirst, ilast
      integer, intent(IN) :: jfirst, jlast, ngc
      integer, intent(IN) :: mode  ! if ==1 divided by area
      real, intent(IN) :: p(ifirst:ilast,jfirst:jlast)      ! field to be summed
      real, intent(IN) :: area(ifirst-ngc:ilast+ngc,jfirst-ngc:jlast+ngc)
      integer :: i,j
      real gsum

!-------------------------
! Quick local sum algorithm
!-------------------------
      if ( .not. g_sum_initialized ) then
         allocate (l_area(ifirst:ilast,jfirst:jlast))
         global_area = 0.
         do j=jfirst,jlast
           do i=ifirst,ilast
             global_area = global_area + area(i,j)
             l_area(i,j) = area(i,j)
           enddo
         enddo
         call mpp_sum(global_area)
         if ( mpp_pe().eq.mpp_root_pe() ) write(*,*) 'Global Area=',global_area
         g_sum_initialized = .true.
      end if

      gsum = 0.
      do j=jfirst,jlast
        do i=ifirst,ilast
          gsum = gsum + p(i,j)*l_area(i,j)
        enddo
      enddo
      call mpp_sum(gsum)

      if ( mode==1 ) then
        g_sum = gsum / global_area
      else
        g_sum = gsum
      endif

 end function g_sum

end module lin_cld_microphys_mod



module lscale_cond_mod

!-----------------------------------------------------------------------
use            mpp_mod, only:  input_nml_file
use            fms_mod, only:  file_exist, error_mesg, open_namelist_file,  &
                               check_nml_error, mpp_pe, mpp_root_pe, FATAL,  &
                               close_file, write_version_number, stdlog
use sat_vapor_pres_mod, only:  compute_qs
use      constants_mod, only:  HLv,HLs,Cp_Air,Grav,rdgas,rvgas

implicit none
private
!-----------------------------------------------------------------------
!  ---- public interfaces ----

   public  lscale_cond, lscale_cond_init, lscale_cond_end

!-----------------------------------------------------------------------
!   ---- version number ----

 character(len=128) :: version = '$Id: lscale_cond.F90,v 17.0.6.1 2010/08/30 20:39:47 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized=.false.

!-----------------------------------------------------------------------
!   ---- local/private data ----

    real, parameter :: d622 = rdgas/rvgas
    real, parameter :: d378 = 1.-d622


!-----------------------------------------------------------------------
!   --- namelist ----

real    :: hc=1.00
logical :: do_evap=.false.
logical :: do_simple =.false.

namelist /lscale_cond_nml/  hc, do_evap, do_simple


!-----------------------------------------------------------------------
!           description of namelist variables
!
!  hc        =  relative humidity at which large scale condensation
!               occurs, where 0 <= hc <= 1 (default: hc=1.)
!
!  do_evap   =  flag for the re-evaporation of moisture in
!               sub-saturated layers below, if do_evap=.true. then
!               re-evaporation is performed (default: do_evap=.false.)
!
!-----------------------------------------------------------------------

contains

!#######################################################################

   subroutine lscale_cond (tin, qin, pfull, phalf, coldT, &
                           rain, snow, tdel, qdel, mask, conv)

!-----------------------------------------------------------------------
!
!                      large scale condensation
!
!-----------------------------------------------------------------------
!
!   input:  tin      temperature at full model levels
!           qin      specific humidity of water vapor at full
!                      model levels
!           pfull    pressure at full model levels
!           phalf    pressure at half (interface) model levels
!           coldT    should precipitation be snow at this point?
!   optional:
!           mask     optional mask (0 or 1.) 
!           conv     logical flag; if true then no large-scale
!                       adjustment is performed at that grid-point or
!                       model level
!
!  output:  rain     liquid precipitation (kg/m2)
!           snow     frozen precipitation (kg/m2)
!           tdel     temperature tendency at full model levels
!           qdel     specific humidity tendency (of water vapor) at
!                      full model levels
!
!-----------------------------------------------------------------------
!--------------------- interface arguments -----------------------------

   real   , intent(in) , dimension(:,:,:) :: tin, qin, pfull, phalf
   logical   , intent(in) , dimension(:,:):: coldT
   real   , intent(out), dimension(:,:)   :: rain,snow
   real   , intent(out), dimension(:,:,:) :: tdel, qdel
   real   , intent(in) , dimension(:,:,:), optional :: mask
   logical, intent(in) , dimension(:,:,:), optional :: conv
!-----------------------------------------------------------------------
!---------------------- local data -------------------------------------

logical,dimension(size(tin,1),size(tin,2),size(tin,3)) :: do_adjust
   real,dimension(size(tin,1),size(tin,2),size(tin,3)) ::  &
                             qsat, dqsat, pmass
   real,dimension(size(tin,1),size(tin,2))             :: hlcp, precip
integer  k, kx
!-----------------------------------------------------------------------
!     computation of precipitation by condensation processes
!-----------------------------------------------------------------------

      if (.not. module_is_initialized) call error_mesg ('lscale_cond',  &
                         'lscale_cond_init has not been called.', FATAL)

      kx=size(tin,3)

!----- compute proper latent heat --------------------------------------
      if(do_simple) then
             hlcp = HLv/Cp_Air
      else
        WHERE (coldT)
             hlcp = HLs/Cp_Air
        ELSEWHERE
             hlcp = HLv/Cp_Air
        END WHERE
      endif

!--- saturation specific humidity (qsat) and deriv wrt temp (dqsat) ---

     call compute_qs (tin, pfull,qsat, hc = hc, dqsdT=dqsat) 

!--------- do adjustment where greater than saturated value ------------

   if (present(conv)) then
!!!!  do_adjust(:,:,:)=(.not.conv(:,:,:) .and. qin(:,:,:) > qsat(:,:,:))
      do_adjust(:,:,:)=(.not.conv(:,:,:) .and.   &
                         (qin(:,:,:) - qsat(:,:,:))*qsat(:,:,:) > 0.0)
   else
!!!!  do_adjust(:,:,:)=(qin(:,:,:) > qsat(:,:,:))
      do_adjust(:,:,:)=( (qin(:,:,:) - qsat(:,:,:))*qsat(:,:,:) > 0.0)
   endif

   if (present(mask)) then
      do_adjust(:,:,:)=do_adjust(:,:,:) .and. (mask(:,:,:) > 0.5)
   end if

!----------- compute adjustments to temp and spec humidity -------------
   do k = 1,kx
   where (do_adjust(:,:,k))
      qdel(:,:,k)=(qsat(:,:,k)-qin(:,:,k))/(1.0+hlcp(:,:)*dqsat(:,:,k))
      tdel(:,:,k)=-hlcp(:,:)*qdel(:,:,k)
   elsewhere
      qdel(:,:,k)=0.0
      tdel(:,:,k)=0.0
   endwhere
   end do
!------------ pressure mass of each layer ------------------------------

   do k=1,kx
      pmass(:,:,k)=(phalf(:,:,k+1)-phalf(:,:,k))/Grav
   enddo

!------------ re-evaporation of precipitation in dry layer below -------

   if (do_evap) then
      if (present(mask)) then
         call precip_evap (pmass,tin,qin,qsat,dqsat,hlcp,tdel,qdel,mask)
      else
         call precip_evap (pmass,tin,qin,qsat,dqsat,hlcp,tdel,qdel)
      endif
   endif

!------------ integrate precip -----------------------------------------

      precip(:,:)=0.0
   do k=1,kx
      precip(:,:)=precip(:,:)-pmass(:,:,k)*qdel(:,:,k)
   enddo
      precip(:,:)=max(precip(:,:),0.0)

   !assign precip to snow or rain
   if(do_simple) then !no snow!
        rain = precip
        snow = 0.
   else
     WHERE (coldT)
        snow = precip
        rain = 0.
     ELSEWHERE
        rain = precip
        snow = 0.
     END WHERE
   endif

!-----------------------------------------------------------------------

   end subroutine lscale_cond

!#######################################################################

subroutine precip_evap (pmass, tin, qin, qsat, dqsat, hlcp, &
                        tdel, qdel, mask)

!-----------------------------------------------------------------------
!        performs re-evaporation of falling precipitation
!-----------------------------------------------------------------------
   real, intent(in),    dimension(:,:,:) :: pmass, tin, qin, qsat, dqsat
   real, intent(in),    dimension(:,:)   :: hlcp
   real, intent(inout), dimension(:,:,:) :: tdel, qdel
   real, intent(in), dimension(:,:,:), optional :: mask
!-----------------------------------------------------------------------
   real, dimension(size(tin,1),size(tin,2)) :: exq, def

   integer  k
!-----------------------------------------------------------------------
    exq(:,:)=0.0

    do k=1,size(tin,3)

        where (qdel(:,:,k) < 0.0)  exq(:,:) = exq(:,:) -  &
                                               qdel(:,:,k)*pmass(:,:,k)

        if (present(mask)) exq(:,:) = exq(:,:)*mask(:,:,k)

!  ---- evaporate precip where needed ------

        where ( (qdel(:,:,k) >= 0.0) .and. (exq(:,:) > 0.0) )
            exq(:,:) = exq(:,:) / pmass(:,:,k)
            def(:,:) = (qsat(:,:,k)-qin(:,:,k))/(1.+hlcp(:,:)*dqsat(:,:,k))
            def(:,:) = min(max(def(:,:),0.0),exq(:,:))
            qdel(:,:,k) = qdel(:,:,k) + def(:,:)
            tdel(:,:,k) = tdel(:,:,k) - def(:,:)*hlcp(:,:)
            exq(:,:) = (exq(:,:)-def(:,:))*pmass(:,:,k)
        endwhere

    enddo

!-----------------------------------------------------------------------

   end subroutine precip_evap

!#######################################################################

   subroutine lscale_cond_init ()

!-----------------------------------------------------------------------
!
!        initialization for large scale condensation
!
!-----------------------------------------------------------------------

  integer  unit,io,ierr, logunit

!----------- read namelist ---------------------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=lscale_cond_nml, iostat=io)
      ierr = check_nml_error(io,"lscale_cond_nml")
#else
      if (file_exist('input.nml')) then
         unit = open_namelist_file ()
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=lscale_cond_nml, iostat=io, end=10)
            ierr = check_nml_error (io,'lscale_cond_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist --------------------------------------------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit,nml=lscale_cond_nml)
      endif

      module_is_initialized=.true.

   end subroutine lscale_cond_init

!#######################################################################
   subroutine lscale_cond_end

      module_is_initialized=.false.

!---------------------------------------------------------------------

   end subroutine lscale_cond_end

!#######################################################################

end module lscale_cond_mod



module mg_drag_mod

!=======================================================================
!         MOUNTAIN GRAVITY WAVE DRAG - PIerrehumbert (1986)            !
!=======================================================================

!-------------------------------------------------------------------
!  Calculates partial tendencies for the zonal and meridional winds
!  due to the effect of mountain gravity wave drag 
!-------------------------------------------------------------------

 use  topography_mod, only: get_topog_stdev

 use         mpp_mod, only: input_nml_file
 use         fms_mod, only: mpp_npes, field_size, file_exist, write_version_number, stdlog, &
                            mpp_pe, mpp_root_pe, error_mesg, FATAL, NOTE, read_data, write_data,  &
                            open_namelist_file, close_file, check_nml_error, open_restart_file, mpp_error
 use      fms_io_mod, only: get_restart_io_mode
 use      fms_io_mod, only: register_restart_field, restart_file_type
 use      fms_io_mod, only: save_restart, restore_state
 use   constants_mod, only: Grav, Kappa, RDgas, cp_air

!-----------------------------------------------------------------------
 implicit none
!-----------------------------------------------------------------------

 private

 character(len=128) :: version = '$Id: mg_drag.F90,v 18.0.4.2 2010/09/07 16:17:18 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

 real, parameter :: p00 = 1.e5

!---------------------------------------------------------------------
!     Ghprime - array of sub-grid scale mountain height variance
!-----------------------------------------------------------------------

  real, allocatable, dimension(:,:) :: Ghprime
!-----------------------------------------------------------------------
!Contants
!     grav    value of gravity
!     rdgas    universal gas constant for dry air
!     kappa  2/7 (i.e., R/Cp)
!-----------------------------------------------------------------------

 logical :: module_is_initialized = .false.

!--- for netcdf restart
type(restart_file_type), save :: Mg_restart

!---------------------------------------------------------------------
! --- NAMELIST (mg_drag_nml)
!---------------------------------------------------------------------
!     xl_mtn      effective mountain length ( set currently to 100km)
!     acoef       order unity "tunable" parameter
!     gmax    order unity "tunable" parameter 
!             (may be enhanced to increase drag)
!     rho     stand value for density of the air at sea-level (1.13 KG/M**3)
!     low_lev_frac - fraction of atmosphere (from bottom up) considered
!              to be "low-level-layer for base flux calc. and where no
!              wave breaking is allowed.
!     flux_cut_level pressure level (Pa) above which flux divergence is set to zero 
!-----------------------------------------------------------------------

 real :: &
      xl_mtn=1.0e5 &
!     & ,gmax=1.0, acoef=1.0
!  v197 value of gmax = 2.0
      ,gmax=2.0, acoef=1.0, rho=1.13  &
!  v197 value for low-level-layer
      ,low_lev_frac = .23

real  ::  flux_cut_level= 0.0
logical :: do_netcdf_restart


logical :: do_conserve_energy = .false.
logical :: do_mcm_mg_drag = .false.
character(len=128) :: source_of_sgsmtn = 'input'

    namelist / mg_drag_nml / xl_mtn, gmax, acoef, rho, low_lev_frac, &
                             do_conserve_energy, do_mcm_mg_drag,     &
                             source_of_sgsmtn, flux_cut_level 

 public mg_drag, mg_drag_init, mg_drag_end, mg_drag_restart

 contains

!#############################################################################      

 subroutine mg_drag (is, js, delt, uwnd, vwnd, temp, pfull, phalf, &
                    zfull,zhalf,dtaux,dtauy,dtemp,taubx, tauby, tausf,&
                    kbot)
!===================================================================

! Arguments (intent in)

 integer, intent(in) :: is,js
 real, intent(in)    :: delt
 real, intent(in), dimension (:,:,:) :: &
     &             uwnd, vwnd, temp, pfull, phalf, zfull, zhalf
 integer, intent(in), optional, dimension(:,:)   :: kbot

!
!      INPUT
!      -----
!
!      is,js   - integers containing the starting
!                  i,j indices from the full horizontal grid
!      delt     time step in seconds
!      UWND     Zonal wind (dimensioned IDIM x JDIM x KDIM)
!      VWND     Meridional wind (dimensioned IDIM x JDIM x KDIM)
!      TEMP     Temperature at full model levels
!                   (dimensioned IDIM x JDIM x KDIM)
!      PFULL    Pressure at full model levels
!                   (dimensioned IDIM x JDIM x KDIM)
!      PHALF    Pressure at half model levels
!                   (dimensioned IDIM x JDIM x KDIM+1)
!      ZHALF    Height at half model levels
!                   (dimensioned IDIM x JDIM x KDIM+1)
!      ZFULL    Height at full model levels
!                   (dimensioned IDIM x JDIM x KDIM+1)
!      KBOT     optional;lowest model level index (integer)
!                   (dimensioned IDIM x JDIM)
!===================================================================
! Arguments (intent out)

 real, intent(out), dimension (:,:) :: taubx, tauby
 real, intent(out), dimension (:,:,:) :: dtaux, dtauy, dtemp, tausf

!      OUTPUT
!      ------

!       TAUBX, TAUBY  base momentum flux componenets - output for diagnostics
!                   (dimensioned IDIM x JDIM)-kg/m/s**2
!                   = -(RHO*U**3/(N*XL))*G(FR) FOR N**2 > 0
!                   =          0               FOR N**2 <=0
!      DTAUX    Tendency of the zonal wind component deceleration 
!                   (dimensioned IDIM x JDIM x KDIM)
!      DTAUY    Tendency of the meridional wind component deceleration 
!                   (dimensioned IDIM x JDIM x KDIM)
!      dtemp    Tendency of temperature due to dissipation of ke
!
!      TAUSF = "CLIPPED" SAT MOMENTUM FLUX ( AT HALF LEVELS below top)
!                  
!===================================================================

!-----------------------------------------------------------------------

!     LLA IS DEFINED AS THE NUMBER OF LEVELS UP FROM THE LOWEST USED
!     TO CALCULATE THE "LOW-LEVEL" AVERAGES.

!     THIS ROUTINE COMPUTES THE DECELERATION OF THE ZONAL WIND AND
!     MERIDIONAL WIND DUE TO MOUNTAIN GRAVITY WAVE DRAG.  THE
!     PARAMETERIZATION WAS DEVELOPED BY R. PIERREHUMBERT AND ADAPTED
!     TO THE SPECTRAL MODEL BY B. STERN.  THE SCHEME IS STRUCTURED TO
!     INCLUDE 4 MAIN (GENERALLY VALID) COMPONENTS
!              1)  CALCULATION OF A BASE MOMENTUM FLUX(TAUB) WHICH IS
!                  A FUNCTION OF LOW-LEVEL->  WINDS, BRUNT-VAISALA FREQ,
!                  AND DENSITY  AS WELL AS THE SUB-GRID SCALE MOUNTAIN
!                  HEIGHT AND EFFECTIVE MOUNTAIN LENGTH.
!              2)  CALCULATION OF A SATURATION MOMENTUM FLUX PROFILE
!                  (TAUS(P) ) - IN GENERAL THIS IS A FUNCTION OF THE
!                  VERTICAL PROFILES OF WINDS, BRUNT VAISALA FREQ AND
!                  DENSITY.
!              3)  DETERMINE THE ACTUAL MOMENTUM FLUX PROFILE.  IT IS
!                  EQUAL TO THE FLUX ENTERING THE LAYER FROM BELOW
!                  BUT CANNOT EXCEED THE SATURATION FLUX IN THAT LAYER.
!              4)  CALCULATE THE DE-CELERATION DUE TO THE DRAG.
!     SATURATION MOMENTUM FLUX PROFILES
!          SCHEME 1:  LINEAR DROP OFF (IN P OR SIGMA) FROM THE BASE
!                     FLUX AT THE BOTTOM OF THE MODEL TO ZERO AT SIGTOP
!                           (^4/86)
!          SCHEME 2:  FUNCTION OF DENSITY, WINDS AND BRUNT VAISALA FREQ.
!                     V SCALE OF WAVE(D)  -
!                       A. FROM WKB THEORY
!                           (^6/87)
!                       B. FROM EXTENSION TO WKB THEORY
!                           (^7/87)
!     THE DECELERATION  IS PROPORTIONAL TO DTAUP/DSIGMA -> MOMENTUM FLUX
!     ABSORPTION WILL TAKE PLACE ONLY IN THOSE REGIONS WHERE TAUP VARIES
!     IN THE VERTICAL - I.E. WAVE BREAKING LAYERS.

!=======================================================================
!  (Intent local)
 real , dimension(size(uwnd,1),size(uwnd,2)) ::  xn, yn, psurf,ptop,taub
 real , dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)) ::  theta 
 real , dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)+1) ::  taus
 real vsamp
integer, dimension (size(uwnd,1),size(uwnd,2)) :: ktop, kbtm
integer idim, jdim, kdim, kdimm1, kdimp1, ie, je

!              XN,YN  = PROJECTIONS OF "LOW LEVEL" WIND
!                       IN ZONAL & MERIDIONAL DIRECTIONS
!              TAUB = BASE MOMENTUM FLUX
!                   = -(RHO*U**3/(N*XL))*G(FR) FOR N**2 > 0
!                   =          0               FOR N**2 <=0
!              TAUS = SATURATION MOMENTUM FLUX ( AT HALF LEVELS)
!                   = (XN,XY)*(1-(AETA-1)/(SIGTOP-1))*TAUB  - SCHEME 1
!                   = -DENSITY(L)*UMAG(L)*D(L)*GMAX/XL       - SCHEME 2
!                   -> -AETA(L)*PS*UMAG(L)*D(L)*GMAX/XL
!      THETA    POTENTIAL temperature at full model levels
!                   (dimensioned IDIM x JDIM x KDIM)
!      PSURF    Surface pressure 
!                   (dimensioned IDIM x JDIM)
!      PTOP     Pressure at top of low-level layer
!                   (dimensioned IDIM x JDIM)
!      KTOP     Top model level index included in low-level layer
!                   (dimensioned IDIM x JDIM)
!      KBTM     Bottom model level index included in low-level layer
!                   usually the lowest level 
!                   (dimensioned IDIM x JDIM)
!-----------------------------------------------------------------------
!  type loop indicies
 integer i, j, k, kd
!-----------------------------------------------------------------------
!  Local variables needed only for code that
!  implements supersource-like gravity wave drag.

integer :: klast, kcrit
real    :: sigtop, small=1.e-10

real,    dimension(size(uwnd,1),size(uwnd,2))              :: ulow, vlow, tlow, thlow
real,    dimension(size(uwnd,1),size(uwnd,2))              :: rlow, zsvar, bvfreq, x
real,    dimension(size(uwnd,1),size(uwnd,2))              :: depth, ave_p
integer, dimension(size(uwnd,1),size(uwnd,2))              :: ntop 
real,    dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)) :: th, sh_ang, test
real,    dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)) :: sigma, del_sigma
!real,    dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)+1) :: sigma_half

!---------------------------------------------------------------------

  idim = size( uwnd, 1 )
  jdim = size( uwnd, 2 )
  kdim = size( uwnd, 3 )
  kdimm1 = kdim - 1
  kdimp1 = kdim + 1

!-----------------------------------------------------------------------

!        CODE VARIABLES     DESCRIPTION

!              XN,YN  = PROJECTIONS OF "LOW LEVEL" WIND
!                       IN ZONAL & MERIDIONAL DIRECTIONS
!              TAUB = BASE MOMENTUM FLUX
!                   = -(RHO*U**3/(N*XL))*G(FR) FOR N**2 > 0
!                   =          0               FOR N**2 <=0
!              TAUS = SATURATION MOMENTUM FLUX ( AT HALF LEVELS)
!                   = (XN,XY)*(1-(AETA-1)/(SIGTOP-1))*TAUB  - SCHEME 1
!                   = -DENSITY(L)*UMAG(L)*D(L)*GMAX/XL       - SCHEME 2
!                   -> -AETA(L)*PS*UMAG(L)*D(L)*GMAX/XL
!              TAUP = MOMENTUM FLUX ( AT HALF LEVELS)
!              TAUP(L) = MIN ( TAUP(L-1),TAUS(L))
!              ULOW = "LOW-LEVEL" WIND MAGNITUDE (M/S)   (= U )
!                    AVERAGE UP TO ^2KM ABOVE SURFACE(LOWEST 1/3 SIGMAS)
!              UMAG = V. PROFILE OF WIND MAGNITUDES-AT HALF LEVS (=U(L))
!              DUDZ = VERTICAL DERIVATIVE OF U(L) WITH RESPECT TO Z
!                     DEFINED AT FULL LEVELS
!              DU2DZ2 = 2ND DERIVATIVE OF U(L) WITH RESPECT TO Z
!                     DEFINED AT HALF LEVELS
!              D = CHARACTERISTI! V. LENGTH SCALE OF WAVES (=D(L))
!                  FOR WKB D(L) = U(L)/N(L)
!                  FOR EXTENDED WKB 1/D**2 = N(L)**2/U(L)**2
!                                            - D2UDZ2(L)/U(L)
!              BNV,BNVK = "LOW-LEVEL",V. PROFILE -  BRUNT VAISALA FREQ(1
!                                                                 (= N,N
!              BNV2,BNVK2 = N**2, N(L)**2
!              HPRIME = Sub-grid scale mountain height 
!                       over local domain (IDIM x JDIM)
!              XL = EFFECTIVE MOUNTAIN LENGTH = (100KM EVERYWHERE)
!              SIGTOP = HIGHEST LEVEL TO WHICH GRAVITY WAVE
!                         MOMENTUM FLUX WILL BE DISTRIBUTED.
!              G = GMAX*FR**2/(FR**2+A**2)
!                 GMAX = 1.0
!                 A = 1.0
!=======================================================================

if ( .not.do_mcm_mg_drag ) then

!--- export sub grid scale topography
  ie = is + idim - 1
  je = js + jdim - 1

!-----------------------------------------------------------------------
!     vsamp is a vertical sampling coefficient which serves to amplify
!     the windshear wkb extension term in the calculation of d.
!     it increases this term to adjust for the deficiency of coarse
!     vertical resolution properly resolving the vertical windshear.

!     vsamp = (kdim+63)/kdim
      vsamp = 1.0
!-----------------------------------------------------------------------
!  calculate bottom of low-level layer = lowest level unless kbot is present
    if (present(kbot)) then
       kbtm(:,:) = kbot(:,:)
    else
       kbtm(:,:) = kdim
    endif
!  calculate top of low-level layer, first get surface p from phalf
    if (present(kbot)) then
       do j=1,jdim
       do i=1,idim
         psurf(i,j) = phalf(i,j,kbtm(i,j)+1)
       end do
       end do
    else
       psurf(:,:) = phalf(:,:,kdimp1)
    endif
!     print *,'psurf=', psurf
!  Based on fraction of model atmosphere to be considered "low-level"
!  (input via namelist), find highest model level.

    ktop(:,:) = kdim
    ptop(:,:) = (1.-low_lev_frac)*psurf(:,:)
    do kd=kdim,1,-1 
         where (pfull(:,:,kd) .ge. ptop(:,:)) 
           ktop(:,:) = kd
         end where
    end do
!  Make sure that low-level layer is at least 2 layer thick
    ktop(:,:) = min(ktop(:,:),(kbtm(:,:)-1) )
!     print *,'ptop=', ptop
!     print *,'ktop=', ktop

!  calculate base flux
    call mgwd_base_flux (is,js,uwnd,vwnd,temp,pfull,phalf,ktop,kbtm,theta, &
         &               xn,yn,taub)

!  split taub in to x and y components
    taubx(:,:) = taub(:,:)*xn(:,:)
    tauby(:,:) = taub(:,:)*yn(:,:)

!  calculate saturation flux profile
    call mgwd_satur_flux (uwnd,vwnd,temp,theta,ktop,kbtm, &
         &                xn,yn,taub,pfull, phalf,zfull,zhalf,vsamp,taus)

!  calculate mountain gravity wave drag tendency contributions
    call mgwd_tend (is,js,xn,yn,taub,phalf,taus,dtaux,dtauy, tausf)

else if ( do_mcm_mg_drag ) then

    if(present(kbot)) then
      call error_mesg ('mg_drag','kbot cannot be present in the calling arguments when using the Manabe Climate Model option',FATAL)
    endif

    do k=1,kdim
      sigma(:,:,k) = pfull(:,:,k)/phalf(:,:,kdimp1)
      del_sigma(:,:,k) = (phalf(:,:,k+1) - phalf(:,:,k))/phalf(:,:,kdimp1)
!     sigma_half(:,:,k) = phalf(:,:,k)/phalf(:,:,kdimp1)
    enddo
!    sigma_half(:,:,kdimp1) = 1.0

    ie = is + idim - 1
    je = js + jdim - 1

    zsvar = (Ghprime(is:ie,js:je))**2

    do k = 1,kdim
      th(:,:,k) = temp(:,:,k) + grav*(zfull(:,:,k)-zhalf(:,:,kdimp1))*kappa/rdgas
    end do

    sigtop = 1.0 - low_lev_frac
    do j = 1,jdim
      do i = 1,idim
        do k = kdim,1,-1
          if (sigma(i,j,k) .lt. sigtop) then
              if ( (sigtop - sigma(i,j,k)) .le. (sigma(i,j,k+1)-sigtop) ) then
                ntop(i,j) = k
              else
                ntop(i,j) = k + 1
              endif
              go to 10
          endif
        end do
        10 continue
      enddo
    enddo

    ulow  = 0.0
    vlow  = 0.0
    tlow  = 0.0
    thlow = 0.0
    depth = 0.0

    do j = 1,jdim
      do i = 1,idim
        do k = ntop(i,j), kdim
           ulow(i,j)  = ulow(i,j)  + del_sigma(i,j,k)* uwnd(i,j,k) 
           vlow(i,j)  = vlow(i,j)  + del_sigma(i,j,k)* vwnd(i,j,k) 
           tlow(i,j)  = tlow(i,j)  + del_sigma(i,j,k)* temp(i,j,k)  
           thlow(i,j) = thlow(i,j) + del_sigma(i,j,k)*th(i,j,k)
           depth(i,j) = depth(i,j) + del_sigma(i,j,k)
        end do
      enddo
    enddo
    ulow  = ulow/depth
    vlow  = vlow/depth
    tlow  = tlow/depth
    thlow = thlow/depth

    do j = 1,jdim
      do i = 1,idim
        ave_p(i,j)  = (phalf(i,j,ntop(i,j)-1) + phalf(i,j,kdim))/2.
        bvfreq(i,j) = (th(i,j,kdim) - th(i,j,ntop(i,j)))/(pfull(i,j,kdim) - pfull(i,j,ntop(i,j)))
        bvfreq(i,j) = -grav*grav*ave_p(i,j)*bvfreq(i,j)/(rdgas*tlow(i,j)*thlow(i,j))  ! thlow should be tlow !IH
      enddo
    enddo

    where(bvfreq > 0.0)
      bvfreq = sqrt(bvfreq)
    elsewhere
      bvfreq = 0.0
    endwhere

!     TK mod: original had rk0*grav*bvfreq*zsvar*ulow .... etc..

    x = grav*bvfreq*zsvar/(rdgas*tlow*xl_mtn)

    rlow = 1.0/sqrt(ulow**2 + vlow**2 + small)
    do k = 1, kdim
      sh_ang(:,:,k) = rlow*(ulow*uwnd(:,:,k) + vlow*vwnd(:,:,k))/      &
                     sqrt(uwnd(:,:,k)**2 + vwnd(:,:,k)**2 + small)
    enddo
    sh_ang = min(sh_ang, 0.99999)
    sh_ang = max(sh_ang,-0.99999)
    sh_ang = acos(sh_ang)

    test = 1.0
    where (sh_ang > 2.*atan(1.0))
      test = 0.0
    endwhere
    do j = 1,jdim
      do i = 1,idim
        do k=ntop(i,j),kdim
          test(i,j,k) = 1.0
        enddo
      enddo
    enddo

    do j = 1,jdim
      do i = 1,idim
        do k = ntop(i,j) - 1, 1, -1
          klast = k
          if (test(i,j,k) /= 1.0 )  go to 20
        end do
        klast = 0
        20 continue
        if ( klast /= 0 )  test(i,j,1:klast) = 0.0
        kcrit = klast + 1
        x(i,j) = x(i,j)/(1.-sigma(i,j,kcrit))  
!       should be  x(i,j) = x(i,j)/(1 - sigma_half(klast)/sigma_half(kdim))
      end do
    end do

    do k = 1,kdim
      dtaux(:,:,k) = - x*ulow*test(:,:,k)
      dtauy(:,:,k) = - x*vlow*test(:,:,k)
    end do

    taub = 0.0
    taubx = 0.0
    tauby = 0.0
    tausf = 0.0

endif

!  calculate temperature tendency due to dissipation of kinetic energy
if (do_conserve_energy) then
  dtemp = -((uwnd+.5*delt*dtaux)*dtaux + (vwnd+.5*delt*dtauy)*dtauy)/cp_air
else
  dtemp = 0.0
endif

return
end subroutine mg_drag
!=======================================================================

!#############################################################################      
 
subroutine mgwd_base_flux (is,js,uwnd,vwnd,temp,pfull,phalf,ktop,kbtm,  &
                          theta,xn,yn,taub)
                                  


!-------------------------------------------------------------------
!  calculates base momentum flux  - taub
!-------------------------------------------------------------------

!===================================================================
! Arguments (intent in)
 real, intent(in), dimension (:,:,:) :: uwnd, vwnd, temp, pfull, phalf
 integer, intent(in), dimension (:,:) :: ktop, kbtm
 integer, intent(in)   :: is, js
!===================================================================
! Arguments (intent out)
 real, intent(out), dimension (:,:) :: xn, yn, taub
 real , intent(out), dimension (:,:,:) :: theta
!===================================================================
! Arguments (intent inout)
!=======================================================================
!  (Intent local)
real , dimension(size(uwnd,1),size(uwnd,2)) :: sumw, delp, ulow, bnv, &
     &  hprime, fr, g, ubar, vbar, bnv2 
real grav2, xli, a, small
 integer idim, jdim,kdim,ie, je
!-----------------------------------------------------------------------
!  type loop indicies
 integer i, j, k, kb, kt
!-----------------------------------------------------------------------
!===================================================================

!-------------------------------------------------------------------
! --- DEFINE CURRENT WINDOW & GET GLOBAL VARIABLES
!-------------------------------------------------------------------

  idim = size( uwnd, 1 )
  jdim = size( uwnd, 2 )
  kdim = size( uwnd, 3 )
  ie = is + idim - 1
  je = js + jdim - 1
  hprime(:,:) = Ghprime(is:ie,js:je)

! define local scalar variables
  xli=1.0/xl_mtn
  grav2=grav*grav
  a = acoef 


!-----------------------------------------------------------------------
!     <><><><><><><><>   base flux code   <><><><><><><><>
!-----------------------------------------------------------------------

!  initialize arrays
        sumw(:,:) = 0.0
        ubar(:,:) = 0.0
        vbar(:,:) = 0.0
        ulow(:,:) = 0.0
        taub(:,:) = 0.0
        xn  (:,:) = 0.0
        yn  (:,:) = 0.0


!     compute low-level averages
!     --------------------------

      do j=1,jdim
        do i=1,idim
          do k=ktop(i,j),kbtm(i,j)
            delp(i,j) = phalf(i,j,k+1)-phalf(i,j,k)
            sumw(i,j) = sumw(i,j) + delp(i,j)
            ubar(i,j) = ubar(i,j) + uwnd(i,j,k)*delp(i,j)
            vbar(i,j) = vbar(i,j) + vwnd(i,j,k)*delp(i,j)
          end do
        end do
      end do
!    print *, 'low-lev aves computed, ubar, vbar =', ubar, vbar

!     calculate projections of low level flow onto wind components (u&v)
!     ------------------------------------------------------------------
        sumw(:,:) = 1./sumw(:,:)
        ubar(:,:) = ubar(:,:) * sumw(:,:)
        vbar(:,:) = vbar(:,:) * sumw(:,:)
        ulow(:,:) =sqrt(ubar(:,:)*ubar(:,:) + vbar(:,:)*vbar(:,:))
        xn(:,:) = ubar(:,:)/(ulow(:,:) + 1.0e-20)
        yn(:,:) = vbar(:,:)/(ulow(:,:) + 1.0e-20)


!     calculate squared brunt vaisala freq
!     ------------------------------------

      theta(:,:,:)=temp(:,:,:)*(pfull(:,:,:)/p00)**(-kappa)
!  v197 uses p* as reference vlues for theta, in above 1000 hPa is used
!      theta(:,:,:)=temp(:,:,:)*(pfull(:,:,:)/ &
!     &             phalf(:,:,kdim+1))**(-kappa)
 
      do j=1,jdim
        do i=1,idim
          kt=ktop(i,j)
          kb=kbtm(i,j)
          bnv2(i,j) = grav2*(pfull(i,j,kt)+pfull(i,j,kb)) &
                 * (theta(i,j,kt)-theta(i,j,kb)) &
              / ( rdgas*(theta(i,j,kt)+theta(i,j,kb)) &
                 * (pfull(i,j,kb)-pfull(i,j,kt)) &
                 *.5*(temp(i,j,kt)+temp(i,j,kb)))
        end do
      end do

!      calculate bnv,fr,g,taub,xn,yn - if n**2>0
!      -----------------------------------------
           small = epsilon(ulow)

           where (bnv2(:,:) .gt. 0.0) 
             bnv(:,:) = sqrt(bnv2(:,:))
             fr (:,:) = bnv(:,:)*hprime(:,:)/(ulow(:,:) + small)
             g  (:,:) = gmax*fr(:,:)*fr(:,:)/(fr(:,:)*fr(:,:)+a*a)
             taub(:,:) = -rho*xli*ulow(:,:)*ulow(:,:)*ulow(:,:) &
     &                 / bnv(:,:)*g(:,:)
           elsewhere
             bnv(:,:) = 0.0
             fr (:,:) = 0.0
             g  (:,:) = 0.0
           endwhere

end subroutine mgwd_base_flux

!#############################################################################      

subroutine mgwd_satur_flux (uwnd,vwnd,temp,theta,ktop,kbtm, &
                           xn,yn,taub,pfull,phalf,zfull,zhalf,vsamp,taus)

!===================================================================
! Arguments (intent in)
 real, intent(in), dimension (:,:,:)  :: &
     &             uwnd, vwnd, temp, theta, pfull, phalf,zfull, zhalf
 real, intent(in), dimension (:,:)    :: xn, yn, taub
 real, intent(in)                     :: vsamp 
 integer, intent(in), dimension (:,:) :: ktop, kbtm
!===================================================================
! Arguments (intent out)
 real, intent(out), dimension (:,:,:) :: taus
!=======================================================================
!  (Intent local)
 real , dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)) ::  &
     &       dudz  
 real , dimension(size(uwnd,1),size(uwnd,2),size(uwnd,3)+1) ::  &
     &       umag, bnvk2, d,d2, d2i, d2udz2, extend
 real grav2, xli, small
 integer :: idim, jdim, kdim, kdimm1, kdimp1
!-----------------------------------------------------------------------
!  type loop indicies
 integer i, j, k, kb, kt, kbp1, ktm1 
!-----------------------------------------------------------------------
!  type flux cutoff 
 integer kcut
!=======================================================================


  idim = size( uwnd, 1 )
  jdim = size( uwnd, 2 )
  kdim = size( uwnd, 3 )
  kdimm1 = kdim - 1
  kdimp1 = kdim + 1

! define local scalar variables
  xli=1.0/xl_mtn
  grav2=grav*grav

!-----------------------------------------------------------------------
!     <><><><><><><><>   saturation flux code   <><><><><><><><>
!-----------------------------------------------------------------------

!     scheme 1 - linear profile
!     do 35 l=1,lp1
!     do 35 i=1,idim
!     taus(i,l) = taub(i) * (1-(eta(l)-1)/(sigtop-1) )
!35    continue

!-----------------------------------------------------------------------

!     ********** scheme 2 - wave breaking formulation  **********

!-----------------------------------------------------------------------


!     calculate wind magnitude at 1/2 levels
!     --------------------------------------------

      do k=2,kdim
        umag(:,:,k) =  (0.50*(uwnd(:,:,k-1)+uwnd(:,:,k))*xn(:,:) &
                     + 0.50*(vwnd(:,:,k-1)+vwnd(:,:,k))*yn(:,:))
        umag(:,:,k) = abs( umag(:,:,k) )
      end do


!     set wind magnitude at top of model = to magnitude at top full
!     level.

        umag(:,:,1) = uwnd(:,:,1)*xn(:,:) + vwnd(:,:,1)*yn(:,:)
        umag(:,:,1) = abs( umag(:,:,1) )

!     set wind magnitude at ground = 0.

      do j=1,jdim
        do i=1,idim
          kbp1=kbtm(i,j)+1
          do k=kbp1,kdimp1
            umag(i,j,k) = 0.0
          end do
        end do
      end do

!     set minimum wind magnitude

      small = epsilon (umag)
      where ( umag .lt. small ) umag = 0.0


!      print *, ' umag for sat flux =', umag

!-----------------------------------------------------------------------

!     calculate vertical derivatives of umag, to be used in
!     the extension to the wkb approach for determining d.
!     -- derivative of umag with respect to z is computed at
!        full levels and stored in dudz.
!     dudz(1) is defined using an uncentered difference

         dudz(:,:,1) = (umag(:,:,1)-umag(:,:,2)) &
     &                /(zfull(:,:,1)-zhalf(:,:,2))

      do k=2,kdim
         dudz(:,:,k) = (umag(:,:,k)-umag(:,:,k+1)) &
     &                /(zhalf(:,:,k)-zhalf(:,:,k+1))
      end do

!      print *, ' dudz for sat flux =', dudz



!     assume vertical derivative of umag at the boundaries=0 and
!     compute 2nd derivatives there using uncentered differencing

      do k=2,kdim
         d2udz2(:,:,k) = (dudz(:,:,k)-dudz(:,:,k-1)) &
     &                  /(zfull(:,:,k)-zfull(:,:,k-1))
      end do

!     set d2udz2 = 0 at the top of the atmosphere (original code)
!     set d2udz2 at the top of atm to level 2 value (new code)

!del    d2udz2(:,:,1) = 0.0
        d2udz2(:,:,1) = d2udz2(:,:,2)

      do  j=1,jdim
      do  i=1,idim
        kb=kbtm(i,j)
        kbp1=kb+1
        d2udz2(i,j,kbp1) = dudz(i,j,kb)/(zfull(i,j,kb)-zhalf(i,j,kbp1))
      end do
      end do

!      print *, ' d2udz2 for sat flux =', d2udz2


!-----------------------------------------------------------------------

!     compute wkb extension term for umag > 0
!     ---------------------------------------

         where (umag(:,:,:).gt.0.0) 
            extend(:,:,:) = vsamp*d2udz2(:,:,:)/umag(:,:,:)
         elsewhere
            extend(:,:,:) = 0.0
         endwhere

!      print *, ' wkb exten for sat flux =', extend


!     calculate brunt vaisala frequency at 1/2 levels
!     -----------------------------------------------------

      do k=2,kdim
        bnvk2(:,:,k) =  grav2*(pfull(:,:,k-1)+pfull(:,:,k)) &
     &          * (theta(:,:,k-1)-theta(:,:,k)) &
     &      /     ( rdgas*(theta(:,:,k-1)+theta(:,:,k)) &
     &  * (pfull(:,:,k)-pfull(:,:,k-1))*.5*(temp(:,:,k-1)+temp(:,:,k)) )
      end do


!     keep static stability constant in top & bottom layers of model
!     for taus calculations.

        bnvk2(:,:,1) = bnvk2(:,:,2)


      do j=1,jdim
      do i=1,idim
        kb=kbtm(i,j)
        kbp1=kb+1
        bnvk2(i,j,kbp1)   = bnvk2(i,j,kb)
        bnvk2(i,j,kdimp1) = bnvk2(i,j,kdim)
      end do
      end do

!      print *, ' brunt vaisala for sat flux =', bnvk2


!-----------------------------------------------------------------------

!     calculate d2i (=1/d**2) for umag .gt. 0
!     initialize d2i to a large number, which will result in a very
!     small vertical wavelength (d) where umag = 0.

         where (umag(:,:,:).gt.0.0) 
            d2i(:,:,:) = (bnvk2(:,:,:)/(umag(:,:,:)* &
     &                   umag(:,:,:)) - extend(:,:,:) )
         elsewhere
            d2i(:,:,:) = 1.0e+30
         endwhere

!      print *, ' 1/d**2 for sat flux =', d2i


!     for 1/d**2 approaching 0 calculate d by dividing by a
!     very small but finite number

         where (d2i(:,:,:) .lt. 1.e-30) 
            d(:,:,:) = 1.e+30
         elsewhere
            d2(:,:,:) = 1./d2i(:,:,:)
            d (:,:,:) = sqrt(d2(:,:,:))
         endwhere


!     set d=0 for umag=0.
         where (umag(:,:,:).eq.0.0) 
            d(:,:,:) = 0.0
         endwhere


!-----------------------------------------------------------------------

!      print *, 'd for sat flux =', d

!     calculation of the saturation flux profile for scheme 2
!     -------------------------------------------------------

      do j=1,jdim
        do i=1,idim
          kb=kbtm(i,j)
          kt=ktop(i,j)
          ktm1=kt-1

          do k=2,ktm1
            taus(i,j,k) = -phalf(i,j,k)*umag(i,j,k)*umag(i,j,k) &
     &                  *d(i,j,k)*xli*gmax &
     &                / (0.50*(temp(i,j,k-1)+temp(i,j,k))*rdgas)
          end do

          do k = kt,kdimp1
            taus(i,j,k) = taub(i,j)
          end do

        end do
      end do


!     keep taus profile constant across top model layer (original code)
!     calculate taus profile in top model layer (new code)
 
        taus(:,:,1) = taus(:,:,2)
!del        taus(:,:,1) = -phalf(:,:,1)*umag(:,:,1)*umag(:,:,1) &
!del     &                  *d(:,:,1)*xli*gmax / (temp(:,:,1)*rdgas)


!     do not allow wave breaking for unstable layers
 
       do k = 1,kdimp1
         where ( bnvk2(:,:,k) .lt. 0.0) 
           taus(:,:,k) =  taub(:,:)
         endwhere
       end do


! -------------------------------------------
!        tausat(:,:,1) = 0.             ! use all forcing
!         Instead,  let remaining flux escape above flux_cut_level
      if( flux_cut_level > 0.0 ) then 
         kcut= 1 
         do while( phalf(1,1,kcut) < flux_cut_level )
            kcut= kcut+1
         enddo

        do k= 1, kcut-1
            taus(:,:,k)= taus(:,:,kcut)
        enddo
      endif

end subroutine mgwd_satur_flux

!#############################################################################      

subroutine mgwd_tend (is,js,xn,yn,taub,phalf,taus,dtaux,dtauy,tausf)

!===================================================================
! Arguments (intent in)
 real, intent(in), dimension (:,:,:) :: phalf, taus
 real, intent(in), dimension (:,:) :: xn, yn, taub
 integer, intent(in)   :: is, js
!===================================================================
! Arguments (intent out)
 real, intent(out), dimension (:,:,:) :: dtaux, dtauy, tausf
!=======================================================================
!  (Intent local)
 real , dimension(size(phalf,1),size(phalf,2),size(phalf,3)) ::  dterm 
 real , dimension(size(phalf,1),size(phalf,2),size(phalf,3)+1) ::  taup
 integer kdim, kdimp1
!-----------------------------------------------------------------------
!  type loop indicies
 integer k, kd
!-----------------------------------------------------------------------
!=======================================================================


  kdim = size( dtaux, 3 )
  kdimp1 = kdim + 1


!-----------------------------------------------------------------------
!     <><><><><><><><>   MOMENTUM FLUX CODE   <><><><><><><><>
!-----------------------------------------------------------------------

!     CALCULATE FLUX FROM GROUND UP
!     -----------------------------

        taup (:,:,kdimp1) = taub(:,:)

      do kd=2,kdimp1
        k = kdimp1-kd+1
        tausf(:,:,k)=taup(:,:,k+1)
        taup(:,:,k) = max (taus(:,:,k),taup(:,:,k+1))
      end do

!     ALLOW FLUX TO ESCAPE THE TOP - DO NOT RE-DISTRIBUTE

!     <><><><><><><><><><><><><><><><><><><><><><><><><><><><>

!     <><><><><><><><>   DE-CELERATION CODE   <><><><><><><><>
 
!     CALCULATE DECELERATION TERMS - DTAUX,DTAUY
!     ------------------------------------------

       do k=1,kdim
          dterm(:,:,k) = grav*(taup (:,:,k+1)-taup (:,:,k)) &
     &                     /(phalf(:,:,k+1)-phalf(:,:,k))
 
        dtaux(:,:,k) = xn(:,:)*dterm(:,:,k)
        dtauy(:,:,k) = yn(:,:)*dterm(:,:,k)
       end do

!  print sample output
!            print*, ' mgdrag output for i,j=', is,js
!            print *,'taub = ', taub(is,js)     
!            print *,'taus = ', taus(is,js,:)     
!            print *,'taup = ', taup(is,js,:)     


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

end subroutine mgwd_tend

!#######################################################################

  subroutine mg_drag_init( lonb, latb, hprime )

!=======================================================================
! ***** INITIALIZE Mountain Gravity Wave Drag
!=======================================================================

!---------------------------------------------------------------------
! Arguments (Intent in)
!     lonb  = longitude in radians of the grid box corners
!     latb  = latitude  in radians of the grid box corners
!---------------------------------------------------------------------
 real, intent(in), dimension(:,:) :: lonb, latb
 
!---------------------------------------------------------------------
! Arguments (Intent out - optional)
!     hprime  = array of sub-grid scale mountain heights
!---------------------------------------------------------------------
 real, intent(out), dimension(:,:), optional :: hprime
 
!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
 integer  ::  ix, iy, unit, io, ierr, logunit
 logical  ::  answer
 integer  :: id_restart

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

if(module_is_initialized) return

!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------
  if( file_exist( 'input.nml' ) ) then
#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=mg_drag_nml, iostat=io)
   ierr = check_nml_error(io,'mg_drag_nml')
#else   
! -------------------------------------mg_drag_nml')
 
   unit = open_namelist_file()
   ierr = 1
   do while( ierr .ne. 0 )
   read ( unit,  nml = mg_drag_nml, iostat = io, end = 10 ) 
   ierr = check_nml_error(io,'mg_drag_nml')
   end do
10 continue
   call close_file ( unit )
#endif

   call get_restart_io_mode(do_netcdf_restart)
! -------------------------------------
  end if

!---------------------------------------------------------------------
! --- Output version
!---------------------------------------------------------------------

  call write_version_number(version, tagname)
  logunit = stdlog()
  if(mpp_pe() == mpp_root_pe()) write (logunit, nml=mg_drag_nml)

!---------------------------------------------------------------------
! --- Allocate storage for Ghprime
!---------------------------------------------------------------------

  ix = size(lonb,1) - 1
  iy = size(latb,2) - 1

  allocate( Ghprime(ix,iy) ) ; Ghprime = 0.0
  
!-------------------------------------------------------------------
  module_is_initialized = .true.
!---------------------------------------------------------------------
! --- Input hprime
!---------------------------------------------------------------------

  if(do_netcdf_restart) then
     id_restart = register_restart_field(Mg_restart, 'mg_drag.res.nc', 'ghprime', Ghprime)
  end if
  if ( trim(source_of_sgsmtn) == 'computed' ) then
    answer = get_topog_stdev ( lonb, latb, Ghprime )
    if ( .not.answer ) then
      call error_mesg('mg_drag_init','source_of_sgsmtn="'//trim(source_of_sgsmtn)//'"'// &
                      ', but topography data file does not exist', FATAL)
    endif
  else if ( trim(source_of_sgsmtn) == 'input' .or. trim(source_of_sgsmtn) == 'input/computed' ) then
    if ( file_exist('INPUT/mg_drag.res.nc') ) then
       if(.not. do_netcdf_restart) call mpp_error ('mg_drag_mod', &
         'netcdf format restart file INPUT/mg_drag.res.nc exist, but do_netcdf_restart is false.', FATAL)
       if (mpp_pe() == mpp_root_pe()) call mpp_error ('mg_drag_mod', &
            'Reading NetCDF formatted restart file: INPUT/mg_drag.res.nc', NOTE)
       call read_data ('INPUT/mg_drag.res.nc', 'ghprime', Ghprime)
    else if ( file_exist( 'INPUT/mg_drag.res' ) ) then
       if (mpp_pe() == mpp_root_pe()) call mpp_error ('mg_drag_mod', &
            'Reading native formatted restart file.', NOTE)
      unit = open_restart_file('INPUT/mg_drag.res','read')
      call read_data(unit, Ghprime)
      call close_file(unit)
    else
       if (trim(source_of_sgsmtn) == 'input') then
          call error_mesg ('mg_drag_init','source_of_sgsmtn="'//trim(source_of_sgsmtn)//'"'// &
                           ', but neither ./INPUT/mg_drag.res.nc  or  ./INPUT/mg_drag.res  exists', FATAL)
       else
          answer = get_topog_stdev ( lonb, latb, Ghprime )
          if ( .not.answer ) then
            call error_mesg('mg_drag_init','source_of_sgsmtn="'//trim(source_of_sgsmtn)//'"'// &
                            ', but topography data file does not exist', FATAL)
          endif
       endif
    endif
  else
    call error_mesg ('mg_drag_init','"'//trim(source_of_sgsmtn)//'"'// &
          ' is not a valid value for source_of_sgsmtn', FATAL)
  endif

! return sub-grid scale topography?
  if (present(hprime)) hprime = Ghprime
 
!=====================================================================
  end subroutine mg_drag_init

!#######################################################################

  subroutine mg_drag_end
  integer :: unit

  if(.not.module_is_initialized) return

  if(do_netcdf_restart) then
     if (mpp_pe() == mpp_root_pe()) call mpp_error ('mg_drag_mod', &
          'Writing NetCDF formatted restart file: RESTART/mg_drag.res.nc', NOTE)
     call mg_drag_restart
  else   
     if (mpp_pe() == mpp_root_pe()) call mpp_error ('mg_drag_mod', &
          'Writing native formatted restart file.', NOTE)
     unit = open_restart_file('RESTART/mg_drag.res','write')
     call write_data(unit, Ghprime)
     call close_file(unit)
  endif
  deallocate(ghprime)
  module_is_initialized = .false.

  end subroutine mg_drag_end


!#######################################################################
! <SUBROUTINE NAME="mg_drag_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine mg_drag_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

  if (do_netcdf_restart) then
    call save_restart(Mg_restart, timestamp)
  else
    call error_mesg ('mg_drag_restart', &
         'Native intermediate restart files are not supported.', FATAL)
  endif  

end subroutine mg_drag_restart
! </SUBROUTINE> NAME="mg_drag_restart"

!#######################################################################

end module mg_drag_mod



module moist_conv_mod

!-----------------------------------------------------------------------

 use           mpp_mod, only : mpp_pe,             &
                               mpp_root_pe,        &
                               stdlog
use   time_manager_mod, only : time_type
 use   Diag_Manager_Mod, ONLY: register_diag_field, send_data
use  sat_vapor_pres_mod, ONLY: lookup_es_des, compute_qs, descomp
use mpp_mod,             only: input_nml_file
use             fms_mod, ONLY:  error_mesg, file_exist, open_namelist_file,  &
                                check_nml_error, close_file,        &
                                FATAL, WARNING, NOTE, mpp_pe, mpp_root_pe, &
                                write_version_number, stdlog
use       constants_mod, ONLY: HLv, HLs, cp_air, grav, rdgas, rvgas

use           fms_mod, only : write_version_number, ERROR_MESG, FATAL
use field_manager_mod, only : MODEL_ATMOS
use tracer_manager_mod, only : get_tracer_index,   &
                               get_number_tracers, &
                               get_tracer_names,   &
                               get_tracer_indices, &
                               query_method,       &
                               NO_TRACER

implicit none
private

!------- interfaces in this module ------------

public :: moist_conv, moist_conv_Init, moist_conv_end

!-----------------------------------------------------------------------
!---- namelist ----

 real :: HC   = 1.00
 real :: beta = 0.0
 real :: TOLmin=.02, TOLmax=.10
 integer :: ITSMOD=30
 logical :: do_simple =.false.

!----- note beta is the fraction of convective condensation that is
!----- detrained into a stratiform cloud

 namelist /moist_conv_nml/  HC, beta, TOLmin, TOLmax, ITSMOD, do_simple

!-----------------------------------------------------------------------
!---- VERSION NUMBER -----

 character(len=128) :: version = '$Id: moist_conv.F90,v 18.0.2.1 2010/08/30 20:33:34 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.

!---------- initialize constants used by this module -------------------

 real, parameter :: d622 = rdgas/rvgas
 real, parameter :: d378 = 1.0-d622
 real, parameter :: grav_inv = 1.0/grav
 real, parameter :: rocp = rdgas/cp_air

real :: missing_value = -999.
integer :: nsphum, nql, nqi, nqa   ! tracer indices for stratiform clouds

integer :: id_tdt_conv, id_qdt_conv, id_prec_conv, id_snow_conv, &
           id_qldt_conv,   id_qidt_conv,   id_qadt_conv, &
           id_ql_conv_col, id_qi_conv_col, id_qa_conv_col,&
           id_q_conv_col, id_t_conv_col

character(len=3) :: mod_name = 'mca'

logical :: do_mca_tracer = .false.
integer :: num_mca_tracers = 0
integer               :: num_tracers
integer, allocatable, dimension(:) :: id_tracer_conv, id_tracer_conv_col

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

CONTAINS

!#######################################################################

 subroutine moist_conv ( Tin, Qin, Pfull, Phalf, coldT,        & ! required
                         Tdel, Qdel, Rain, Snow,               & ! required
                         dtinv, Time, is, js, tracers, qtrmca, & ! required
                         Lbot, mask, Conv,                     & ! optional
                         ql, qi, cf, qldel, qidel, cfdel)        ! optional

!-----------------------------------------------------------------------
!
!                       MOIST CONVECTIVE ADJUSTMENT
!
!-----------------------------------------------------------------------
!
!   INPUT:   Tin     temperature at full model levels
!            Qin     specific humidity of water vapor at full
!                      model levels
!            Pfull   pressure at full model levels
!            Phalf   pressure at half model levels
!            coldT   Should MCA produce snow in this column?
!
!   OUTPUT:  Tdel    temperature adjustment at full model levels (deg k)
!            Qdel    specific humidity adjustment of water vapor at
!                       full model levels
!            Rain    liquid precipitiation (in Kg m-2)
!            Snow    ice phase precipitation (kg m-2)
!  OPTIONAL
!
!   INPUT:   Lbot    integer index of the lowest model level,
!                      Lbot is always <= size(Tin,3)
!              ql    liquid water condensate
!              qi    ice condensate
!              cf    stratiform cloud fraction (used only when
!                    operating with stratiform cloud scheme) (fraction)
!
!  OUTPUT:   Conv    logical flag; TRUE then moist convective
!                       adjustment was performed at that model level.
!            cfdel   change in stratiform cloud fraction (fraction)
!            qldel   change in liquid water condensate due to
!                    convective detrainment (kg condensate /kg air)
!            qidel   change in ice condensate due to
!                    convective detrainment (kg condensate /kg air)
!
!-----------------------------------------------------------------------
!----------------------PUBLIC INTERFACE ARRAYS--------------------------
    real, intent(INOUT), dimension(:,:,:)           :: Tin, Qin
    real, intent(IN) ,   dimension(:,:,:)           :: Pfull, Phalf 
 logical, intent(IN) ,   dimension(:,:)             :: coldT
    real, intent(OUT),   dimension(:,:,:)           :: Tdel, Qdel
    real, intent(OUT),   dimension(:,:)             :: Rain, Snow
    real, intent(IN)                                :: dtinv
type(time_type), intent(in)                         :: Time
integer, intent(IN)                                :: is, js
    real, dimension(:,:,:,:), intent(in)            :: tracers
    real, dimension(:,:,:,:), intent(out)           :: qtrmca
 integer, intent(IN) ,   dimension(:,:),   optional :: Lbot
    real, intent(IN) ,   dimension(:,:,:), optional :: mask
 logical, intent(OUT),   dimension(:,:,:), optional :: Conv
    real, intent(INOUT), dimension(:,:,:), optional :: ql, qi, cf
    real, intent(OUT),   dimension(:,:,:), optional :: qldel, qidel, cfdel
         
!-----------------------------------------------------------------------
!----------------------PRIVATE (LOCAL) ARRAYS---------------------------
! logical, dimension(size(Tin,1),size(Tin,2),size(Tin,3)) :: DO_ADJUST
!    real, dimension(size(Tin,1),size(Tin,2),size(Tin,3)) ::  &
!-----------------------------------------------------------------------
!----------------------PRIVATE (LOCAL) ARRAYS---------------------------
integer, dimension(size(Tin,1),size(Tin,2)) :: ISMVF
integer, dimension(size(Tin,1),size(Tin,2),size(Tin,3)) :: IVF

real, dimension(size(Tin,1),size(Tin,2),size(Tin,3)) ::   &
  Qdif,Temp,Qmix,Esat,Qsat,Test1,Test2, &
   Esdiff_v

real, dimension(size(Tin,1),size(Tin,2),size(Tin,3)-1) ::   &
  Thalf,DelPoP,Esm,Esd,ALRM

real, dimension(size(Tin,3)) :: C,Ta,Qa
real, dimension(size(Tin,1),size(Tin,2)) :: HL

integer :: i,j,k,kk,KX,ITER,MXLEV,MXLEV1,kstart,KTOP,KBOT,KBOTM1
real    :: ALTOL,Sum0,Sum1,Sum2,EsDiff,EsVal,Thaf,Pdelta

logical  :: cloud_tracers_present
real, dimension(size(Phalf,1),size(Phalf,2),size(Phalf,3)) :: pmass
real, dimension(size(Phalf,1),size(Phalf,2)) :: tempdiag
integer  :: tr, num_cld_tracers
logical :: used
!-----------------------------------------------------------------------

      if (.not. module_is_initialized) call ERROR_MESG( 'MCA',  &
                                 'moist_conv_init has not been called', FATAL )

      num_cld_tracers = count( (/present(ql),present(qi),present(cf),present(qldel),present(qidel),present(cfdel)/) )
      if(num_cld_tracers == 0) then
        cloud_tracers_present = .false.
      else if(num_cld_tracers == 6) then
        cloud_tracers_present = .true.
      else
        call error_mesg('moist_conv','Either all or none of the cloud tracers and their tendencies must be present',FATAL)
      endif

        do k=1,size(Tin,3)
          pmass(:,:,k) = (Phalf(:,:,k+1)-Phalf(:,:,k))/GRAV
        end do

      KX=size(Tin,3)

!------ compute Proper HL
      if(do_simple) then
            HL = HLv
      else
        WHERE (coldT)
              HL = HLs
        ELSEWHERE
              HL = HLv
        END WHERE
      endif

!------ convert spec hum to mixing ratio ------
      Temp(:,:,:)=Tin(:,:,:)
      Qmix(:,:,:)=Qin(:,:,:)

      do k=1,KX-1
         DelPoP(:,:,k)=(Pfull(:,:,k+1)-Pfull(:,:,k))/Phalf(:,:,k+1)
      enddo

!-------------SATURATION VAPOR PRESSURE FROM ETABL----------------------
!  compute qs; also return dqsdT

      call compute_qs (Temp, Pfull, Qsat, dqsdT=Esdiff_v, hc = hc, &
                                                            esat=Esat)
      Qdif(:,:,:)=Max(0.0,Qmix(:,:,:)-Qsat(:,:,:))

!-----------------------------------------------------------------------
!                  MOIST CONVECTIVE ADJUSTMENT
!-----------------------------------------------------------------------

!  *** Set initial tolerance ***

           ALTOL = TOLmin

      do k=1,KX-1
         Thalf(:,:,k)=0.50*(Temp(:,:,k)+Temp(:,:,k+1))
      enddo

      call lookup_es_des (Thalf, Esm, Esd)

      do k=1,KX-1
         ALRM(:,:,k)=rocp*DelPoP(:,:,k)*Thalf(:,:,k)  &
         *(Phalf(:,:,k+1)+d622*HL(:,:)*Esm(:,:,k)/Thalf(:,:,k)/rdgas)  &
         /(Phalf(:,:,k+1)+d622*HL(:,:)*Esd(:,:,k)/cp_air)
      enddo

      IVF  (:,:,KX)=0
      Test1(:,:,KX)=0.0
      Test2(:,:,KX)=0.0

      do k=1,KX-1
         Test1(:,:,k)=Temp(:,:,k+1)-Temp(:,:,k)
         Test2(:,:,k)=ALRM(:,:,k)+ALTOL-Test1(:,:,k)
      enddo

!!!!! Test1(:,:,:)=0.0-Qdif(:,:,:)
      Test1(:,:,:)=(0.0-Qdif(:,:,:))*Qsat(:,:,:)

!-------IVF=1 in unstable layers where both levels are saturated--------

      do k=1,KX-1
         where (Test1(:,:,k) < 0.0 .and. Test1(:,:,k+1) < 0.0 .and. &
                Test2(:,:,k) < 0.0)
                         IVF(:,:,k)=1
         elsewhere
                         IVF(:,:,k)=0
         endwhere
      enddo

!  ------ Set convection flag (for optional output only) --------

      if (Present(Conv)) then
         Conv(:,:,1)=(IVF(:,:,1) == 1)
         do k=1,KX-1
            Conv(:,:,k+1)=(IVF(:,:,k) == 1 .or. IVF(:,:,k+1) == 1)
         enddo
      endif

!  ----- Set counter for each column -----

         ISMVF(:,:)=0
      do k=1,KX-1
         ISMVF(:,:)=ISMVF(:,:)+IVF(:,:,k)
      enddo

!-----------------------------------------------------------------------
!---------------LOOP OVER EACH VERTICAL COLUMN--------------------------
                       do j=1,size(Tin,2)
           OUTER_LOOP: do i=1,size(Tin,1)
!-----------------------------------------------------------------------
      if (ISMVF(i,j) == 0)  CYCLE

      if (Present(Lbot)) then
         MXLEV=Lbot(i,j)
      else
         MXLEV=KX
      endif
      MXLEV1=MXLEV-1

!  *** Re-set initial tolerance ***
           ALTOL = TOLmin

!----------(return here after increasing tolerance)--------------------
1450  CONTINUE

!--------------Iterations at the same tolerance-------------------------
                     do 1740 ITER=1,ITSMOD
!-----------------------------------------------------------------------
      kstart=1
 1500 CONTINUE
!-------------TEST TO DETERMINE UNSTABLE LAYER BLOCKS-------------------
!-------Find top (KTOP) and bottom (KBOT) of unstable layers------------
      do k=kstart,MXLEV1
          if (IVF(i,j,k) == 1)  GO TO 1505
      enddo
      CYCLE OUTER_LOOP
1505  KTOP=k

      do k=KTOP,MXLEV1
          if (IVF(i,j,k+1) == 0) then
             KBOT=k+1
             GO TO 1510
          endif
      enddo
      KBOT=MXLEV
1510  CONTINUE
!-----------------------------------------------------------------------

      KBOTM1=KBOT - 1
      Sum1=0.0
      Sum2=0.0
!-----------------------------------------------------------------------
                      do 1630 k=KTOP,KBOT
!-----------------------------------------------------------------------
      if(do_simple) then
        call DEsComp (Temp(i,j,k),EsDiff)
        C(k)=d622*HC*EsDiff/Pfull(i,j,k)
      else
        C(k)=Pfull(i,j,k)-d378*Esat(i,j,k)
        if (C(k) <= 0.0) then
          C(k)=0.0
        else
          C(k) = esdiff_v(i,j,k)
        endif
      endif  

      Sum0=0.0
      if (k == KBOT) GO TO 1625
      kk=k
1620  if (kk > KBOTM1) GO TO 1625
      Sum0=Sum0+ALRM(i,j,kk)
      kk=kk+1
      GO TO 1620

1625  CONTINUE
      Pdelta=Phalf(i,j,k+1)-Phalf(i,j,k)
      Sum1=Sum1 + Pdelta*((cp_air+HL(i,j)*C(k))*(Temp(i,j,k)+Sum0)+  &
                           HL(i,j)*(Qmix(i,j,k)-Qsat(i,j,k)))
      Sum2=Sum2 + Pdelta*(cp_air+HL(i,j)*C(k))
!-----------------------------------------------------------------------
1630                   CONTINUE
!-----------------------------------------------------------------------
      Ta(KBOT)=Sum1/Sum2
      k=KTOP
1645  if (k > KBOTM1) GO TO 1641
      Sum0=0.0
      kk=k
1640  if (kk > KBOTM1) GO TO 1642
      Sum0=Sum0+ALRM(i,j,kk)
      kk=kk+1
      GO TO 1640
1642  Ta(k)=Ta(KBOT)-Sum0
      k=k+1
      GO TO 1645

!---------UPDATE T,R,ES,Esm,Esd & Qsat FOR THE ADJUSTED POINTS----------

1641  do k=KTOP,KBOT
        Qa(k)=Qsat(i,j,k)+C(k)*(Ta(k)-Temp(i,j,k))
        Temp(i,j,k)=Ta(k)
        Qmix(i,j,k)=Qa(k)
        call compute_qs ( Temp(i,j,k), Pfull(i,j,k), Qsat(i,j,k), &
                     dqsdT = Esdiff_v(i,j,k), hc =hc, esat= Esat(i,j,k))
        Qdif(i,j,k)=Max(0.0,Qmix(i,j,k)-Qsat(i,j,k))
      enddo

      do k=KTOP,KBOTM1
        Thaf=0.50*(Temp(i,j,k)+Temp(i,j,k+1))
!DIR$ INLINE
        call lookup_es_des (Thaf, EsVal, Esdiff)
!DIR$ NOINLINE
        Esm (i,j,k)=HC*EsVal
        Esd (i,j,k)=HC*EsDiff
        ALRM(i,j,k)=rocp*DelPoP(i,j,k)*Thaf*  &
               (Phalf(i,j,k+1)+d622*HL(i,j)*Esm(i,j,k)/Thaf/rdgas)/  &
               (Phalf(i,j,k+1)+d622*HL(i,j)*Esd(i,j,k)/cp_air)
      enddo

!------------Is this the bottom of the current column ???---------------
      kstart=KBOT+1
      if (kstart <= MXLEV1) GO TO 1500
!-----------------------------------------------------------------------
                if (ITER == ITSMOD) GO TO 1740
!-----------------------------------------------------------------------

      do k=1,MXLEV1
        Thaf=0.50*(Temp(i,j,k)+Temp(i,j,k+1))
!DIR$ INLINE
        call lookup_es_des (Thaf, EsVal, EsDiff)
!DIR$ NOINLINE
        Esm (i,j,k)=HC*EsVal
        Esd (i,j,k)=HC*EsDiff
        ALRM(i,j,k)=rocp*DelPoP(i,j,k)*Thaf*  &
               (Phalf(i,j,k+1)+d622*HL(i,j)*Esm(i,j,k)/Thaf/rdgas)/  &
               (Phalf(i,j,k+1)+d622*HL(i,j)*Esd(i,j,k)/cp_air)
      enddo

      do k=1,MXLEV1
        IVF(i,j,k)=0
!!!!    if (Qdif(i,j,k) > 0.0 .and. Qdif(i,j,k+1) > 0.0 .and.  &
        if (Qdif(i,j,k)*Qsat(i,j,k) > 0.0 .and.     &
             Qdif(i,j,k+1)*Qsat(i,j,k+1) > 0.0 .and.  &
              (Temp(i,j,k+1)-Temp(i,j,k)) > (ALRM(i,j,k)+ALTOL)) then
                       IVF(i,j,k) = 1
        endif
      enddo

!   ------ reset optional convection flag ------

      if (Present(Conv)) then
         Conv(i,j,1)=(IVF(i,j,1) == 1)
         do k=1,MXLEV1
            Conv(i,j,k+1)=(IVF(i,j,k) == 1 .or. IVF(i,j,k+1) == 1)
         enddo
      endif

!   ------ Are all layers sufficiently stable ??? ------

              ISMVF(i,j)=0
           do k=1,MXLEV1
              ISMVF(i,j)=ISMVF(i,j)+IVF(i,j,k)
           enddo
              if (ISMVF(i,j) == 0) CYCLE OUTER_LOOP

!-----------------------------------------------------------------------
1740                       CONTINUE
!-----------------------------------------------------------------------

!---------Maximum iterations reached: Increase tolerance (ALTOL)--------
      ALTOL=2.0*ALTOL
!del  WRITE (*,9902) I,ALTOL
      call error_mesg ('moist_conv', 'Tolerence (ALTOL) doubled', NOTE)
      if (ALTOL <= TOLmax)  GO TO 1450

!     WRITE (*,9903)
!     WRITE (*,9904) (k,Temp(i,j,k),Qmix(i,j,k),Qsat(i,j,k),  &
!                       Qdif(i,j,k),ALRM(i,j,k),k=1,MXLEV1)
!     WRITE (*,9904) (k,Temp(i,j,k),Qmix(i,j,k),Qsat(i,j,k),  &
!                       Qdif(i,j,k)            ,k=MXLEV,MXLEV)

   call error_mesg ('moist_conv', 'maximum iterations reached', WARNING)
!-----------------------------------------------------------------------
                            enddo OUTER_LOOP
                            enddo
!-----------------------------------------------------------------------
!---------------------- END OF i,j LOOP --------------------------------
!-----------------------------------------------------------------------

!---- call Convective Detrainment subroutine -----

     if (cloud_tracers_present) then

          !reset quantities
          cfdel = 0.
          qldel = 0.
          qidel = 0.
     
          CALL CONV_DETR(Qmix,Qin,Phalf,Temp,cf,coldT,cfdel,qldel,qidel)
          
     endif

!----- compute adjustments to temp and spec hum ----

      Tdel(:,:,:)=Temp(:,:,:)-Tin(:,:,:)
      Qdel(:,:,:)=Qmix(:,:,:)-Qin(:,:,:)

!----- integrate precip -----

      Rain(:,:)=0.0
      Snow(:,:)=0.0
   do k =1,KX

     if(do_simple) then
       Rain(:,:)=Rain(:,:)+(Phalf(:,:,k)-Phalf(:,:,k+1))*  &
                               Qdel(:,:,k)*grav_inv
       if (cloud_tracers_present) then
          Rain(:,:)=Rain(:,:)+(Phalf(:,:,k)-Phalf(:,:,k+1))*  &
                                qldel(:,:,k)*grav_inv
       endif
     else
       WHERE(coldT(:,:)) 
         Snow(:,:)=Snow(:,:)+(Phalf(:,:,k)-Phalf(:,:,k+1))*  &
                               Qdel(:,:,k)*grav_inv
       ELSEWHERE
         Rain(:,:)=Rain(:,:)+(Phalf(:,:,k)-Phalf(:,:,k+1))*  &
                               Qdel(:,:,k)*grav_inv
       END WHERE

      !subtract off detrained condensate from surface precip
       if (cloud_tracers_present) then
         WHERE(coldT(:,:)) 
           Snow(:,:)=Snow(:,:)+(Phalf(:,:,k)-Phalf(:,:,k+1))*  &
                                qidel(:,:,k)*grav_inv
         ELSEWHERE
           Rain(:,:)=Rain(:,:)+(Phalf(:,:,k)-Phalf(:,:,k+1))*  &
                                qldel(:,:,k)*grav_inv
         END WHERE      
       end if
     endif

   enddo
      Rain(:,:)=Max(Rain(:,:),0.0)
      Snow(:,:)=Max(Snow(:,:),0.0)
!-----------------------------------------------------------------------
!-----------------   PRINT FORMATS   -----------------------------------

 9902 FORMAT(    ' *** ALTOL DOUBLED IN CONVAD AT I=',  &
                 I5,' ,ALTOL=', F10.4 )
 9903 FORMAT(/,' *** DIVERGENCE IN MOIST CONVECTIVE ADJUSTMENT ',/,  &
           4X,'K',14X,'T',14X,'R',13X,'Qsat',14X,'Qdif',12X,'ALRM',/)
 9904 FORMAT (I5,5E15.7)
!-----------------------------------------------------------------------


!------- update input values and compute tendency -------
                    
      Tin=Tin+Tdel;    Qin=Qin+Qdel
      
      Tdel=Tdel*dtinv; Qdel=Qdel*dtinv
      Rain=Rain*dtinv; Snow=Snow*dtinv
!------- update input values , compute and add on tendency -----------
!-------              in the case of strat                 -----------

      if (cloud_tracers_present) then
         ql(:,:,:)=ql(:,:,:)+qldel(:,:,:)
         qi(:,:,:)=qi(:,:,:)+qidel(:,:,:)
         cf(:,:,:)=cf(:,:,:)+cfdel(:,:,:)
 
         qldel(:,:,:)=qldel(:,:,:)*dtinv
         qidel(:,:,:)=qidel(:,:,:)*dtinv
         cfdel(:,:,:)=cfdel(:,:,:)*dtinv
      endif   
      
!---------------------------------------------------------------------
!   define the effect of moist convective adjustment on the tracer 
!   fields. code to do so does not currently exist.
!---------------------------------------------------------------------
      qtrmca = 0.
 

!------- diagnostics for dt/dt_ras -------
      if ( id_tdt_conv > 0 ) then
        used = send_data ( id_tdt_conv, Tdel, Time, is, js, 1, &
                           rmask=mask )
      endif
!------- diagnostics for dq/dt_ras -------
      if ( id_qdt_conv > 0 ) then
        used = send_data ( id_qdt_conv, Qdel, Time, is, js, 1, &
                           rmask=mask )
      endif
!------- diagnostics for precip_ras -------
      if ( id_prec_conv > 0 ) then
        used = send_data ( id_prec_conv, Rain+Snow, Time, is, js )
      endif
!------- diagnostics for snow_ras -------
      if ( id_snow_conv > 0 ) then
        used = send_data ( id_snow_conv, Snow, Time, is, js )
      endif

!------- diagnostics for water vapor path tendency ----------
      if ( id_q_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kx
          tempdiag(:,:) = tempdiag(:,:) + Qdel(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_q_conv_col, tempdiag, Time, is, js )
      end if
   
!------- diagnostics for dry static energy tendency ---------
      if ( id_t_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kx
          tempdiag(:,:) = tempdiag(:,:) + Tdel(:,:,k)*cp_air*pmass(:,:,k)
        end do
        used = send_data ( id_t_conv_col, tempdiag, Time, is, js )
      end if
   
   !------- stratiform cloud tendencies from cumulus convection ------------
   if (cloud_tracers_present) then

      !------- diagnostics for dql/dt from RAS or donner -------
      if ( id_qldt_conv > 0 ) then
        used = send_data ( id_qldt_conv, qldel(:,:,:), Time, is, js, 1, &
                           rmask=mask )
      endif
      
      !------- diagnostics for dqi/dt from RAS or donner -------
      if ( id_qidt_conv > 0 ) then
        used = send_data ( id_qidt_conv, qidel(:,:,:), Time, is, js, 1, &
                           rmask=mask )
      endif
      
      !------- diagnostics for dqa/dt from RAS or donner -------
      if ( id_qadt_conv > 0 ) then
        used = send_data ( id_qadt_conv, cfdel(:,:,:), Time, is, js, 1, &
                           rmask=mask )
      endif

      !------- diagnostics for liquid water path tendency ------
      if ( id_ql_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kx
          tempdiag(:,:) = tempdiag(:,:) + qldel(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_ql_conv_col, tempdiag, Time, is, js )
      end if
      
      !------- diagnostics for ice water path tendency ---------
      if ( id_qi_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kx
          tempdiag(:,:) = tempdiag(:,:) + qidel(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_qi_conv_col, tempdiag, Time, is, js )
      end if
      
      !---- diagnostics for column integrated cloud mass tendency ---
      if ( id_qa_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kx
          tempdiag(:,:) = tempdiag(:,:) + cfdel(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_qa_conv_col, tempdiag, Time, is, js )
      end if
         
   end if ! if ( cloud_tracers_present )

   do tr = 1, num_mca_tracers
!------- diagnostics for dtracer/dt from RAS -------------
     if ( id_tracer_conv(tr) > 0 ) then
       used = send_data ( id_tracer_conv(tr), qtrmca(:,:,:,tr), Time, is, js, 1, &
                          rmask=mask )
     endif
 
!------- diagnostics for column tracer path tendency -----
     if ( id_tracer_conv_col(tr) > 0 ) then
       tempdiag(:,:)=0.
       do k=1,kx
         tempdiag(:,:) = tempdiag(:,:) + qtrmca(:,:,k,tr)*pmass(:,:,k)
       end do
       used = send_data ( id_tracer_conv_col(tr), tempdiag, Time, is, js )
     end if

 
   enddo

 end subroutine moist_conv

!#######################################################################
!#######################################################################

SUBROUTINE CONV_DETR(qvout,qvin,phalf,T,cf,coldT,cfdel,qldel,qidel)


IMPLICIT NONE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      This subroutine takes a fraction of the water condensed
!      by the convection scheme and detrains in the top level
!      undergoing convective adjustment.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!       VARIABLES
!
!   ------
!   INPUT:
!   ------
!
!       qvout    water vapor specific humidity AFTER adjustment
!                (kg vapor/kg air)
!       qvin     water  vapor specific humidity BEFORE adjustment
!                (kg vapor/kg air)
!       phalf    pressure at model half levels (Pascals)
!       T        Temperature (Kelvin)
!       cf       cloud fraction (fraction)
!       coldT    is condensation of ice nature?
!
!   -------------
!   INPUT/OUTPUT:
!   -------------
!
!       cfdel    Change in cloud fraction due to detrainment (fraction)
!       qldel    Increase in liquid water due to detrainment
!                (kg condensate/kg air)
!       qidel    Increase in ice due to detrainment
!                (kg condensate/kg air)
!
!   -------------------
!       INTERNAL VARIABLES:
!   -------------------
!
!       precipsource  accumulated source of precipitation
!                     (kg condensate /meter/ (seconds*squared))
!       ktop          integer of top level undergoing convection
!       accum         logical variable indicating whether or not to
!                     add precip
!       fT            fraction of condensate that is liquid
!       i,j,k         looping variables
!       IDIM,JDIM,KDIM dimensions of input arrays
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  User Interface variables
!  ------------------------

REAL,     INTENT (IN), DIMENSION(:,:,:)  :: qvout,qvin,T,cf
REAL,     INTENT (IN), DIMENSION(:,:,:)  :: phalf
LOGICAL,  INTENT (IN), DIMENSION(:,:)    :: coldT
REAL,     INTENT (INOUT),DIMENSION(:,:,:):: cfdel,qldel,qidel

!  Internal variables
!  ------------------

INTEGER                                  :: i,j,k,IDIM,JDIM,KDIM,ktop
LOGICAL                                  :: accum
REAL                                     :: precipsource

!
! Code
! ----

        ! reinitialize variables
        cfdel(:,:,:)   = 0.
        qidel(:,:,:)   = 0.
        qldel(:,:,:)   = 0.
        IDIM           = SIZE(qvout,1)
        JDIM           = SIZE(qvout,2)
        KDIM           = SIZE(qvout,3)

        !---loop over grid columns----!
        DO i = 1, IDIM
        DO j = 1, JDIM

             !reset variables
             precipsource     = 0.
             accum            = .FALSE.

             DO k = 1, KDIM

                 !begin new convective event
                 IF ((qvout(i,j,k) .ne. qvin(i,j,k)) .and. &
                     (.NOT. accum)) THEN
                     ktop  = k
                     accum = .TRUE.
                 END IF

                 !if convective event is over compute detrainment
                 IF ( (accum) .and. (qvout(i,j,k) .eq. qvin(i,j,k)) &
                      .and. (precipsource .gt. 0.)) THEN                      
                      if (coldT(i,j)) then
                      qidel(i,j,ktop) = beta * precipsource / &
                                    (phalf(i,j,ktop+1)-phalf(i,j,ktop))
                      else
                      qldel(i,j,ktop) = beta * precipsource / &
                                    (phalf(i,j,ktop+1)-phalf(i,j,ktop))
                      end if
                      cfdel(i,j,ktop) = MAX(0.,HC-cf(i,j,ktop))
                      accum        = .FALSE.
                      precipsource = 0.
                 END IF

                 !accumulate precip
                 IF (accum) THEN
                      precipsource = precipsource + &
                                   ( qvin(i,j,k)  -qvout(i,j,k))* &
                                   (phalf(i,j,k+1)-phalf(i,j,k))
                 END IF

             END DO    !---end k loop over vertical column

            !---clear any remaining precip
            IF ( (precipsource .gt. 0.) .and. (accum) ) THEN
                 if (coldT(i,j)) then
                 qidel(i,j,ktop) = beta * precipsource / &
                                    (phalf(i,j,ktop+1)-phalf(i,j,ktop))
                 else
                 qldel(i,j,ktop) = beta * precipsource / &
                                    (phalf(i,j,ktop+1)-phalf(i,j,ktop))
                 end if
            END IF

        END DO    !---end j loop
        END DO    !---end i loop

END SUBROUTINE CONV_DETR

!#######################################################################

subroutine moist_conv_init (axes, Time, tracers_in_mca)

 integer,         intent(in) :: axes(4)
 type(time_type), intent(in) :: Time
 logical, dimension(:), intent(in), optional :: tracers_in_mca

!-----------------------------------------------------------------------
      
 integer :: unit, io, ierr, logunit
 integer :: nn, tr
 character(len=128) :: diagname, diaglname, tendunits, name, units


!-----------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=moist_conv_nml, iostat=io)
    ierr = check_nml_error(io,"moist_conv_nml")
#else
    if (file_exist('input.nml')) then
        unit = open_namelist_file ()
        ierr=1; do while (ierr /= 0)
            read  (unit, nml=moist_conv_nml, iostat=io, end=10)
            ierr = check_nml_error (io,'moist_conv_nml')
        enddo
 10     call close_file (unit)
    endif
#endif

!---------- output namelist --------------------------------------------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number (version, tagname)
           logunit = stdlog()
           write (logunit,nml=moist_conv_nml)
      endif

   id_tdt_conv = register_diag_field ( mod_name, &
     'tdt_conv', axes(1:3), Time, &
     'Temperature tendency from moist conv adj',     'deg_K/s',  &
                        missing_value=missing_value               )

   id_qdt_conv = register_diag_field ( mod_name, &
     'qdt_conv', axes(1:3), Time, &
     'Spec humidity tendency from moist conv adj',   'kg/kg/s',  &
                        missing_value=missing_value               )

   id_prec_conv = register_diag_field ( mod_name, &
     'prec_conv', axes(1:2), Time, &
    'Precipitation rate from moist conv adj',       'kg/m2/s' )

   id_snow_conv = register_diag_field ( mod_name, &
     'snow_conv', axes(1:2), Time, &
    'Frozen precip rate from moist conv adj',       'kg/m2/s' )

   id_q_conv_col = register_diag_field ( mod_name, &
     'q_conv_col', axes(1:2), Time, &
    'Water vapor path tendency from moist conv adj','kg/m2/s' )
   
   id_t_conv_col = register_diag_field ( mod_name, &
     't_conv_col', axes(1:2), Time, &
    'Column static energy tendency from moist conv adj','W/m2' )


!---------------------------------------------------------------------
! --- Find the tracer indices 
!---------------------------------------------------------------------
  call get_number_tracers (MODEL_ATMOS, num_prog= num_tracers)
  if ( num_tracers .gt. 0 ) then
  else
    call error_mesg('moist_conv_init', 'No atmospheric tracers found', FATAL)
  endif
    ! get tracer indices for stratiform cloud variables
      nsphum = get_tracer_index ( MODEL_ATMOS, 'sphum' )
      nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
      nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
      nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )

     
!----------------------------------------------------------------------
!    determine how many tracers are to be transported by moist_conv_mod.
!----------------------------------------------------------------------
      num_mca_tracers = count(tracers_in_mca)
      if (num_mca_tracers > 0) then
        do_mca_tracer = .true.
      else
        do_mca_tracer = .false.
      endif

!---------------------------------------------------------------------
!    allocate the arrays to hold the diagnostics for the moist_conv 
!    tracers.
!---------------------------------------------------------------------
      allocate(id_tracer_conv    (num_mca_tracers)) ; id_tracer_conv = 0
      allocate(id_tracer_conv_col(num_mca_tracers)) ; id_tracer_conv_col = 0
      nn = 1
      do tr = 1,num_tracers
        if (tracers_in_mca(tr)) then
          call get_tracer_names(MODEL_ATMOS, tr, name=name, units=units)
 
!----------------------------------------------------------------------
!    for the column tendencies, the name for the diagnostic will be 
!    the name of the tracer followed by 'dt_MCA'. the longname will be 
!    the name of the tracer followed by ' tendency from MCA'. units are
!    the supplied units of the tracer divided by seconds.
!----------------------------------------------------------------------
      diagname = trim(name)//'dt_MCA'
      diaglname = trim(name)//' tendency from MCA'
      tendunits = trim(units)//'/s'
      id_tracer_conv(nn) = register_diag_field ( mod_name, &
                             trim(diagname), axes(1:3), Time, &
                             trim(diaglname), trim(tendunits),  &
                             missing_value=missing_value        )

!----------------------------------------------------------------------
!    for the column integral  tendencies, the name for the diagnostic 
!    will be the name of the tracer followed by 'dt_MCA_col'. the long-
!    name will be the name of the tracer followed by ' path tendency 
!    from MCA'. units are the supplied units of the tracer multiplied
!    by m**2 /kg divided by seconds.
!----------------------------------------------------------------------
      diagname = trim(name)//'dt_MCA_col'
      diaglname = trim(name)//' path tendency from MCA'
      tendunits = trim(units)//'m2/kg/s'
      id_tracer_conv_col(nn) = register_diag_field ( mod_name, &
                                 trim(diagname), axes(1:2), Time, &
                                 trim(diaglname), trim(tendunits),  &
                                 missing_value=missing_value)
      nn = nn + 1
     endif
    end do




      module_is_initialized = .true.

!-----------------------------------------------------------------------

 end subroutine moist_conv_init


!#######################################################################
subroutine moist_conv_end

integer :: log_unit

if(.not.module_is_initialized) then
  return
else
  module_is_initialized = .FALSE.
endif

log_unit = stdlog()
if ( mpp_pe() == mpp_root_pe() ) then
   write (log_unit,'(/,(a))') 'Exiting moist_conv.'
endif

end subroutine moist_conv_end

!#######################################################################

end module moist_conv_mod



module moistproc_kernels_mod

use sat_vapor_pres_mod,         only: compute_qs
use time_manager_mod,           only: time_type
use diag_manager_mod,           only: send_data
use constants_mod,              only: CP_AIR, GRAV, HLV, HLS, HLF, &
                                      RDGAS, RVGAS, TFREEZE, &
                                      SECONDS_PER_DAY, KAPPA
use field_manager_mod,          only: MODEL_ATMOS
use tracer_manager_mod,         only: get_tracer_index
use betts_miller_mod,           only: betts_miller
use bm_massflux_mod,            only: bm_massflux
use bm_omp_mod,                 only: bm_omp
use diag_cloud_mod,             only: diag_cloud_sum
use donner_deep_mod,            only: donner_deep
use moist_conv_mod,             only: moist_conv
use lscale_cond_mod,            only: lscale_cond
use uw_conv_mod,                only: uw_conv
use lin_cld_microphys_mod,      only: lin_cld_microphys_driver
use ras_mod,                    only: ras
use strat_cloud_mod,            only: strat_cloud, strat_cloud_sum
use rh_clouds_mod,              only: rh_clouds_sum
use cu_mo_trans_mod,            only: cu_mo_trans
use atmos_tracer_utilities_mod, only: wet_deposition
use moz_hook_mod,               only: moz_hook
use rad_utilities_mod,          only: aerosol_type
use moist_proc_utils_mod,       only: rh_calc

implicit none
private
public  moistproc_init, moistproc_end, moistproc_mca, moistproc_ras, &
        moistproc_lscale_cond, moistproc_strat_cloud, moistproc_cmt, &
        moistproc_uw_conv, moistproc_scale_uw, moistproc_scale_donner


!--------------------- version number ----------------------------------
character(len=128) :: &
version = '$Id: moistproc_kernels.F90,v 18.0.4.2 2010/09/07 14:33:37 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
real, public, allocatable, dimension(:,:)     :: rain_uw, snow_uw
real, public, allocatable, dimension(:,:,:)   :: ttnd_uw, qtnd_uw,   &
                                                 utnd_uw, vtnd_uw,   &
                                                 qltnd_uw, qitnd_uw, &
                                                 qatnd_uw, qntnd_uw, &  
                                                 delta_ql, delta_qi, &
                                                 delta_qa,           &
                                                 qlin, qiin, qain
real, public, allocatable, dimension(:,:,:,:) :: qtruw

logical :: moistproc_initialized = .false.

contains


!#######################################################################
subroutine moistproc_init(ix, jx, kx, num_uw_tracers, do_strat)
  integer, intent(in) :: ix, jx, kx, num_uw_tracers
  logical, intent(in) :: do_strat

      if (moistproc_initialized) return

      allocate( rain_uw  (ix,jx) )                   ; rain_uw  = 0.0
      allocate( snow_uw  (ix,jx) )                   ; snow_uw  = 0.0
      allocate( ttnd_uw  (ix,jx,kx) )                ; ttnd_uw  = 0.0
      allocate( qtnd_uw  (ix,jx,kx) )                ; qtnd_uw  = 0.0
      allocate( utnd_uw  (ix,jx,kx) )                ; utnd_uw  = 0.0
      allocate( vtnd_uw  (ix,jx,kx) )                ; vtnd_uw  = 0.0
      allocate( qltnd_uw (ix,jx,kx) )                ; qltnd_uw = 0.0
      allocate( qitnd_uw (ix,jx,kx) )                ; qitnd_uw = 0.0
      allocate( qatnd_uw (ix,jx,kx) )                ; qatnd_uw = 0.0
      allocate( qntnd_uw (ix,jx,kx) )                ; qntnd_uw = 0.0
      allocate( qtruw    (ix,jx,kx,num_uw_tracers) ) ; qtruw    = 0.0
      if (do_strat) then
        allocate( delta_ql (ix,jx,kx) )              ; delta_ql = 0.0
        allocate( delta_qi (ix,jx,kx) )              ; delta_qi = 0.0
        allocate( delta_qa (ix,jx,kx) )              ; delta_qa = 0.0
        allocate( qlin     (ix,jx,kx) )              ; qlin     = 0.0
        allocate( qiin     (ix,jx,kx) )              ; qiin     = 0.0 
        allocate( qain     (ix,jx,kx) )              ; qain     = 0.0
      endif

      moistproc_initialized = .true.
end subroutine moistproc_init

!#######################################################################
subroutine moistproc_end(do_strat)
  logical, intent(in) :: do_strat

      if (moistproc_initialized .eqv. .false. ) return
      deallocate( rain_uw    )
      deallocate( snow_uw    )
      deallocate( ttnd_uw    )
      deallocate( qtnd_uw    )
      deallocate( utnd_uw    )
      deallocate( vtnd_uw    )
      deallocate( qltnd_uw   )
      deallocate( qitnd_uw   )
      deallocate( qatnd_uw   )
      deallocate( qntnd_uw   )
      deallocate( qtruw      )
      if (do_strat) then
        deallocate( delta_ql )
        deallocate( delta_qi )
        deallocate( delta_qa )
        deallocate( qlin     )
        deallocate( qiin     )
        deallocate( qain     )
      endif

      moistproc_initialized = .false.
end subroutine moistproc_end


!#######################################################################
subroutine moistproc_cmt ( Time, is, js, t, u, v, tracer, pfull, phalf, &
                           zfull, zhalf, pmass, tdt, udt, vdt, rdt,     &
                           ttnd_conv, dt, mc_cmt, det_cmt, diff_cu_mo,  &
                           num_tracers)
  type(time_type), intent(in)   :: Time
  integer, intent(in)           :: is, js, num_tracers
  real, intent(in)              :: dt
  real, intent(in),    dimension(:,:,:) :: pfull, phalf, zfull, zhalf, pmass, &
                                           mc_cmt, det_cmt
  real, intent(inout), dimension(:,:,:) :: t, u, v, tdt, udt, vdt, ttnd_conv, &
                                           diff_cu_mo
  real, intent(inout), dimension(:,:,:,:) :: rdt, tracer

  integer :: n
  real, dimension(size(t,1), size(t,2), size(t,3)) :: ttnd, utnd, vtnd
  real, dimension(size(rdt,1), size(rdt,2), size(rdt,3),num_tracers) :: qtr

      call cu_mo_trans (is, js, Time, mc_cmt, t, phalf, pfull, &
                        zhalf, zfull, dt, u, v, tracer,        &
                        pmass, det_cmt, utnd, vtnd, ttnd,      &
                        qtr, diff_cu_mo  )

!---------------------------------------------------------------------
!    update the current tracer tendencies with the contributions 
!    just obtained from cu_mo_trans.
!---------------------------------------------------------------------
      do n=1, num_tracers
        rdt(:,:,:,n) = rdt(:,:,:,n) + qtr(:,:,:,n)
      end do

!----------------------------------------------------------------------
!    add the temperature, specific humidity and momentum tendencies 
!    from ras (ttnd, qtnd, utnd, vtnd) to the arrays accumulating 
!    these tendencies from all physics processes (tdt, qdt, udt, vdt).
!----------------------------------------------------------------------
      tdt = tdt + ttnd 
      udt = udt + utnd
      vdt = vdt + vtnd
      ttnd_conv = ttnd_conv + ttnd


end subroutine moistproc_cmt


!#######################################################################
subroutine moistproc_lscale_cond (is, js, t, q, pfull, phalf, tdt, qdt, &
                                  ttnd, qtnd, qtnd_conv, lprec, fprec, precip,&
                                  rain, snow, dtinv, omega, do_rh_clouds, do_simple, &
                                  do_diag_clouds, coldT, kbot, mask)
  integer, intent(in)  :: is, js
  real, intent(in)     :: dtinv
  logical, intent(in)  :: do_rh_clouds, do_simple, do_diag_clouds
  logical, intent(in), dimension(:,:)   :: coldT
  real, intent(in),    dimension(:,:,:) :: pfull, phalf, omega
  real, intent(inout), dimension(:,:)   :: lprec, fprec, precip
  real, intent(inout), dimension(:,:,:) :: t, q, tdt, qdt, qtnd_conv, &
                                           ttnd, qtnd
  real, intent(out),   dimension(:,:)   :: rain, snow
  integer, intent(in) , dimension(:,:), optional :: kbot
  real, intent(in) , dimension(:,:,:),  optional :: mask

  real, dimension(size(t,1), size(t,2), size(t,3)) :: cnvcntq, rh

      call lscale_cond (t, q, pfull, phalf, coldT, rain, snow,  &
                        ttnd, qtnd, mask=mask)

!-----------------------------------------------------------------------
!    add the temperature and specific humidity increments to the updated
!    temperature and specific humidity fields (tin, qin). convert these
!    increments and the precipitation increments to rates and add to 
!    the arrays accumulating the total rates for all physical processes
!    (tdt, qdt, lprec, fprec).
!-----------------------------------------------------------------------
      t     = t   + ttnd 
      q     = q   + qtnd
      tdt   = tdt   + ttnd*dtinv 
      qdt   = qdt   + qtnd*dtinv
      lprec = lprec + rain*dtinv
      fprec = fprec + snow*dtinv

!--------------------------------------------------------------------
!    if rh_clouds is active, call rh_calc to determine the grid box
!    relative humidity. call rh_clouds_sum to pass this field to 
!    rh_clouds_mod so it may be used to determine the grid boxes which
!    will contain clouds for the radiation package.
!---------------------------------------------------------------------
      if (do_rh_clouds) then
        call rh_calc (pfull, t, q, rh, do_simple, mask)
        call rh_clouds_sum (is, js, rh)
      endif

!--------------------------------------------------------------------
!    if the gordon diagnostic cloud parameterization is active, set a 
!    flag to indicate those grid points where drying has resulted from 
!    convective activity (cnvcntq). call rh_calc to determine the grid 
!    box relative humidity. call diag_cloud_sum to define the cloud 
!    field that will be seen by the radiation package.
!---------------------------------------------------------------------
      if (do_diag_clouds) then
        cnvcntq (:,:,:) = 0.0
        where (qtnd_conv(:,:,:) < 0.0)
          cnvcntq (:,:,:) = 1.0
        end where
        call rh_calc (pfull, t, q, rh, do_simple, mask)
        call diag_cloud_sum (is, js, t, q, rh, omega, qtnd,  &
                             cnvcntq, precip, kbot)
      endif


end subroutine moistproc_lscale_cond


!#######################################################################
subroutine moistproc_mca( Time, is, js, t, q, tracer, pfull, phalf, coldT, dtinv, &
                          tdt, qdt, rdt, q_tnd, ttnd_conv, qtnd_conv,             &
                          lprec, fprec, do_strat, num_tracers, tracers_in_mca,    &
                          num_mca_tracers, kbot, mask)

  type(time_type), intent(in) :: Time
  integer, intent(in)         :: is, js, num_tracers, num_mca_tracers
  real, intent(in)            :: dtinv
  logical, intent(in)         :: do_strat
  logical, intent(in), dimension(:)       :: tracers_in_mca
  logical, intent(in), dimension(:,:)     :: coldT
  real, intent(in),    dimension(:,:,:)   :: pfull, phalf 
  real, intent(inout), dimension(:,:)     :: lprec, fprec
  real, intent(inout), dimension(:,:,:)   :: t, q, tdt, qdt, ttnd_conv, qtnd_conv
  real, intent(inout), dimension(:,:,:,:) :: rdt, q_tnd
  real, intent(out),   dimension(:,:,:,:) :: tracer
  integer, intent(in) , dimension(:,:), optional :: kbot
  real, intent(in) , dimension(:,:,:),  optional :: mask

  integer :: nn, n, nql, nqa, nqi, nqn
  real, dimension(size(t,1), size(t,2)) :: rain, snow
  real, dimension(size(t,1), size(t,2), size(t,3)) :: ttnd, qtnd
  real, dimension(size(rdt,1), size(rdt,2), size(rdt,3),num_mca_tracers) :: trcr, qtr


      nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
      nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
      nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
      nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )

!---------------------------------------------------------------------
!    check each active tracer to find any that are to be transported 
!    by moist convective adjustment and fill the mca_tracers array with
!    these fields.
!---------------------------------------------------------------------
      nn = 1
      do n=1, num_tracers
        if (tracers_in_mca(n)) then
          trcr(:,:,:,nn) = tracer(:,:,:,n)
          nn = nn + 1
        endif
      end do

!---------------------------------------------------------------------
!    call subroutine moist_conv to obtain the temperature, moisture
!    precipitation and tracer tendencies due to the moist convective
!    adjustment parameterization. currently there is no tracer tendency
!    due to this parameterization.
!---------------------------------------------------------------------
!++++yim Should also account for change in qn dut to moist convective adjustment.

      if (do_strat) then
        call moist_conv (t, q, pfull, phalf, coldT, ttnd, qtnd,          &
                         rain, snow, dtinv, Time, is, js,                &
                         trcr, qtr, Lbot= kbot, mask=mask,               &
                         ql=tracer(:,:,:,nql), qi=tracer(:,:,:,nqi),     &
                         cf=tracer(:,:,:,nqa), qldel=q_tnd(:,:,:,nql),   &
                         qidel=q_tnd(:,:,:,nqi), cfdel=q_tnd(:,:,:,nqa))
      else
        call moist_conv (t, q, pfull, phalf, coldT, ttnd, qtnd,          &
                         rain, snow, dtinv, Time, is, js,                &
                         trcr, qtr, Lbot=kbot, mask=mask)
      endif

!---------------------------------------------------------------------
!    update the current tracer tendencies with the contributions 
!    just obtained from moist convective adjustment. currently there
!    is no tracer transport by this process.
!    NOTE : the stratcloud tracers are updated within moist_conv.
!---------------------------------------------------------------------
      nn = 1
      do n=1, num_tracers
        if (tracers_in_mca(n)) then
          rdt(:,:,:,n) = rdt(:,:,:,n) + qtr(:,:,:,nn)
          nn = nn + 1
        endif
      end do

!----------------------------------------------------------------------
!    add the temperature and specific humidity tendencies from moist
!    convective adjustment (ttnd, qtnd) to the arrays accumulating 
!    these tendencies from all physics processes (tdt, qdt).
!----------------------------------------------------------------------
      tdt = tdt + ttnd 
      qdt = qdt + qtnd
      ttnd_conv = ttnd_conv + ttnd
      qtnd_conv = qtnd_conv + qtnd

!----------------------------------------------------------------------
!    increment the liquid, solid and total precipitation fields with 
!    the contribution from moist convective adjustment.
!----------------------------------------------------------------------
      lprec  = lprec  + rain
      fprec  = fprec  + snow

!----------------------------------------------------------------------
!    if strat_cloud_mod is activated, add the cloud liquid, ice and area
!    tendencies from moist convective adjustment to the 
!    arrays accumulating these tendencies from all physics processes 
!    (rdt).
!----------------------------------------------------------------------
      if (do_strat) then
        rdt(:,:,:,nql) = rdt(:,:,:,nql) + q_tnd(:,:,:,nql)
        rdt(:,:,:,nqi) = rdt(:,:,:,nqi) + q_tnd(:,:,:,nqi)
        rdt(:,:,:,nqa) = rdt(:,:,:,nqa) + q_tnd(:,:,:,nqa)
      endif


end subroutine moistproc_mca


!#######################################################################
subroutine moistproc_ras(Time, is, js, dt, coldT, t, q, u, v, tracer,       &
                         pfull, phalf, zhalf, tdt, qdt, udt, vdt, rdt,      &
                         q_tnd, ttnd, qtnd, ttnd_conv, qtnd_conv, mc, det0, &
                         lprec, fprec, rain, snow, rain3d, snow3d,          &
                         Aerosol, do_strat, do_liq_num, num_tracers,        &
                         tracers_in_ras, num_ras_tracers, kbot, mask)

  type(time_type), intent(in)   :: Time
  integer, intent(in)           :: is, js, num_tracers, num_ras_tracers
  logical, intent(in)           :: do_strat, do_liq_num
  real, intent(in)              :: dt
  logical, intent(in), dimension(:)     :: tracers_in_ras
  logical, intent(in), dimension(:,:)   :: coldT
  real, intent(in),    dimension(:,:,:) :: pfull, phalf, zhalf
  real, intent(inout), dimension(:,:)   :: lprec, fprec
  real, intent(inout), dimension(:,:,:) :: t, q, u, v, tdt, qdt, udt, vdt,   &
                                           ttnd, qtnd, ttnd_conv, qtnd_conv
  real, intent(inout), dimension(:,:,:,:) :: rdt, tracer, q_tnd
  real, intent(out),   dimension(:,:)     :: rain, snow
  real, intent(out),   dimension(:,:,:)   :: rain3d,  snow3d, mc, det0

  type(aerosol_type),intent(in), optional :: Aerosol
  integer, intent(in), dimension(:,:), optional :: kbot
  real, intent(in), dimension(:,:,:),  optional :: mask

  integer :: nn, n, nql, nqa, nqi, nqn
  real, dimension(size(t,1), size(t,2), size(t,3)) :: utnd, vtnd
  real, dimension(size(rdt,1), size(rdt,2), size(rdt,3),num_ras_tracers) :: trcr, qtr

      nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
      nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
      nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
      nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )
!----------------------------------------------------------------------
!    if any tracers are to be transported by ras convection, check each
!    active tracer to find those to be transported and fill the 
!    ras_tracers array with these fields.
!---------------------------------------------------------------------
     nn = 1
     do n=1, num_tracers
       if (tracers_in_ras(n)) then
         trcr(:,:,:,nn) = tracer(:,:,:,n)
         nn = nn + 1
       endif
     end do

!----------------------------------------------------------------------
!    call subroutine ras to obtain the temperature, specific humidity,
!    velocity, precipitation and tracer tendencies and mass flux 
!    associated with the relaxed arakawa-schubert parameterization.
!----------------------------------------------------------------------
     if (do_strat .and. (.not.do_liq_num)) then
       call ras (is,   js,     Time,     t,   q,          &
                 u,  v,    pfull,    phalf, zhalf, coldT, &
                 dt,   ttnd,   qtnd,     utnd,  vtnd,     &
                 rain3d, snow3d, rain, snow,              &
                 trcr, qtr, mask,  kbot, mc, det0,        &
                 tracer(:,:,:,nql), tracer(:,:,:,nqi),    &
                 tracer(:,:,:,nqa), q_tnd(:,:,:,nql),     &
                 q_tnd(:,:,:,nqi), q_tnd(:,:,:,nqa))       

     elseif (do_strat .and. do_liq_num) then
       call ras (is,   js,     Time,     t,   q,          &
                 u,  v,    pfull,    phalf, zhalf, coldT, &
                 dt,   ttnd,   qtnd,     utnd,  vtnd,     &
                 rain3d, snow3d, rain, snow,              &
                 trcr, qtr, mask,  kbot, mc, det0,        &
                 tracer(:,:,:,nql), tracer(:,:,:,nqi),    &
                 tracer(:,:,:,nqa), q_tnd(:,:,:,nql),     &
                 q_tnd(:,:,:,nqi), q_tnd(:,:,:,nqa),      &
                 tracer(:,:,:,nqn), q_tnd(:,:,:,nqn),     &
                 do_strat, Aerosol)
     else
       call ras (is,   js,     Time,     t,   q,          &
                 u,  v,    pfull,    phalf, zhalf, coldT, &
                 dt,   ttnd,   qtnd,     utnd,  vtnd,     &
                 rain3d, snow3d, rain, snow,              &
                 trcr, qtr, mask,  kbot,  mc, det0)
     endif

!---------------------------------------------------------------------
!    update the current tracer tendencies with the contributions 
!    just obtained from ras transport.
!    NOTE : the stratcloud tracers are updated within ras.        
!---------------------------------------------------------------------
     nn = 1
     do n=1, num_tracers
       if (tracers_in_ras(n)) then
         rdt(:,:,:,n) = rdt(:,:,:,n) + qtr (:,:,:,nn)
         nn = nn + 1
       endif
     end do
!----------------------------------------------------------------------
!    add the temperature, specific humidity and momentum tendencies 
!    from ras (ttnd, qtnd, utnd, vtnd) to the arrays accumulating 
!    these tendencies from all physics processes (tdt, qdt, udt, vdt).
!----------------------------------------------------------------------
     tdt = tdt + ttnd 
     qdt = qdt + qtnd
     udt = udt + utnd
     vdt = vdt + vtnd
!---------------------------------------------------------------------
!    if donner_deep_mod is also active, define the total time tendency 
!    due to all moist convective processes (donner (including its mca 
!    part), and ras) of temperature, specific humidity, rain, snow and,
!    if strat_cloud_mod is activated, the cloud liquid, cloud ice and 
!    cloud area. 
!---------------------------------------------------------------------
     ttnd_conv = ttnd_conv + ttnd
     qtnd_conv = qtnd_conv + qtnd

!----------------------------------------------------------------------
!    if strat_cloud_mod is activated, add the cloud liquid, ice and area
!    tendencies from ras to the arrays accumulating these tendencies 
!    from all physics processes (rdt).
!----------------------------------------------------------------------
     if (do_strat) then
       rdt(:,:,:,nql) = rdt(:,:,:,nql) + q_tnd(:,:,:,nql)
       rdt(:,:,:,nqi) = rdt(:,:,:,nqi) + q_tnd(:,:,:,nqi)
       rdt(:,:,:,nqa) = rdt(:,:,:,nqa) + q_tnd(:,:,:,nqa)
       if (do_liq_num) rdt(:,:,:,nqn) = rdt(:,:,:,nqn) + q_tnd(:,:,:,nqn)
     endif

!----------------------------------------------------------------------
!    increment the liquid, solid and total precipitation fields with 
!    the contribution from ras.
!----------------------------------------------------------------------
     lprec  = lprec  + rain
     fprec  = fprec  + snow

end subroutine moistproc_ras


!#######################################################################
subroutine moistproc_strat_cloud(Time, is, ie, js, je, ktop, dt, tm, t, q, tracer,&
                                 pfull, phalf, zhalf, omega, radturbten, mc_full, &
                                 diff_t, land, area, tdt, qdt, rdt, q_tnd, ttnd,  &
                                 qtnd, lprec, fprec, rain, snow, rain3d, snow3d,  &
                                 snowclr3d, &
                                 Aerosol, lsc_cloud_area, lsc_liquid, lsc_ice,    &
                                 lsc_droplet_number, donner_humidity_area,        &
                                 donner_humidity_factor, shallow_cloud_area,      &
                                 cell_cld_frac, meso_cld_frac,                    &
                                 do_uw_conv, do_donner_deep, do_liq_num,          &
                                 do_lin_cld_microphys, id_qvout, id_qlout,        &
                                 id_qaout, id_qiout, limit_conv_cloud_frac, mask, &
                                 hydrostatic, phys_hydrostatic)

  type(time_type), intent(in) :: Time
  integer, intent(in)         :: is, ie, js, je, ktop, id_qvout, id_qlout, &
                                 id_qaout, id_qiout
  real, intent(in)            :: dt
  logical, intent(in)         :: do_uw_conv, do_donner_deep, do_liq_num, &
                                 do_lin_cld_microphys, limit_conv_cloud_frac
  real, intent(in),    dimension(:,:)     :: land, area
  real, intent(in),    dimension(:,:,:)   :: tm, pfull, phalf, zhalf, omega,  &
                                             radturbten, mc_full, diff_t,     &
                                             donner_humidity_area, donner_humidity_factor
  real, intent(inout), dimension(:,:)     :: lprec, fprec
  real, intent(inout), dimension(:,:,:)   :: t, q, tdt, qdt, ttnd, qtnd
  real, intent(inout), dimension(:,:,:,:) :: rdt, tracer, q_tnd
  real, intent(out),   dimension(:,:)     :: rain, snow
  real, intent(out),   dimension(:,:,:)   :: rain3d, snow3d,  &
                                             snowclr3d, lsc_cloud_area,&
                                             lsc_liquid, lsc_ice, lsc_droplet_number

  type(aerosol_type),intent(in), optional :: Aerosol
  logical, intent(in), optional           :: hydrostatic, phys_hydrostatic
  real, intent(in) , dimension(:,:,:),  optional :: mask, cell_cld_frac, meso_cld_frac, &
                                                    shallow_cloud_area

  logical :: used
  integer :: i, j, k, ix, jx, kx, nql, nqi, nqa, nqn, nqg, nqr, nqs
  real :: qrf, env_fraction, env_qv, dtinv
  real, dimension(size(t,1), size(t,2)) :: ice_lin, graupel_lin
  real, dimension(size(t,1), size(t,2), size(t,3)) :: delp, delz, qsat, &
                                                      convective_humidity_area,     &
                                                      convective_humidity_ratio

      ix=size(t,1) 
      jx=size(t,2) 
      kx=size(t,3)
      dtinv = 1./dt

!----------------------------------------------------------------------
!    define the grid box specific humidity and saturation specific 
!    humidity.
!------------------------------------------------------------------
      call compute_qs (t, pfull, qsat)
 
!----------------------------------------------------------------------
!    define the grid box area whose humidity is affected by the 
!    convective clouds and the environmental fraction and environmental
!    rh.
!-------------------------------------------------------------------
      do k=1, kx
       do j=1, jx
        do i=1, ix
          qrf = MAX (q(i,j,k), 0.0)
          if (do_uw_conv .and. do_donner_deep) then
            convective_humidity_area(i,j,k) = donner_humidity_area(i,j,k) +  &
                           shallow_cloud_area(i,j,k)
            env_fraction = 1.0 - (cell_cld_frac(i,j,k) + meso_cld_frac(i,j,k) + &
                           shallow_cloud_area(i,j,k) )
            env_qv = qrf - qsat(i,j,k)*(cell_cld_frac(i,j,k) +   &
                           donner_humidity_factor(i,j,k) + shallow_cloud_area(i,j,k))
          else if (do_donner_deep) then
            convective_humidity_area = donner_humidity_area(i,j,k)
            env_fraction = 1.0 - (cell_cld_frac(i,j,k) + meso_cld_frac(i,j,k))        
            env_qv = qrf - qsat(i,j,k)*(cell_cld_frac(i,j,k) +   &
                           donner_humidity_factor(i,j,k))
          else if (do_uw_conv) then
            convective_humidity_area(i,j,k) = shallow_cloud_area(i,j,k)
            env_fraction = 1.0 - shallow_cloud_area(i,j,k)
            env_qv = qrf -  shallow_cloud_area(i,j,k)*qsat(i,j,k)
          else
            convective_humidity_area(i,j,k) = 0.0
            env_fraction = 1.0
            env_qv = qrf
          endif

!---------------------------------------------------------------------
!    define the ratio of the grid-box relative humidity to the humidity
!    in the environment of the convective clouds.
!----------------------------------------------------------------------
 
!----------------------------------------------------------------------
!    grid box has vapor and there is vapor outside of the convective a
!    clouds available for condensation.
!----------------------------------------------------------------
          if (qrf /= 0.0 .and. env_qv > 0.0) then
 
!--------------------------------------------------------------------
!    there is grid box area not filled with convective clouds
!--------------------------------------------------------------------  
            if (env_fraction > 0.0) then
              convective_humidity_ratio(i,j,k) =    &
                      MAX (qrf*env_fraction/env_qv, 1.0)
 
!---------------------------------------------------------------------
!    grid box is filled with convective clouds.
!----------------------------------------------------------------------
            else
              convective_humidity_ratio(i,j,k) = -10.0
            endif

!--------------------------------------------------------------------
!    either no vapor or all vapor taken up in convective clouds so 
!    none left for large-scale cd.
!---------------------------------------------------------------------
          else
            convective_humidity_ratio(i,j,k) = 1.0
          endif
        end do
       end do
      end do
        
!-----------------------------------------------------------------------
!    call strat_cloud to integrate the prognostic cloud equations. 
!-----------------------------------------------------------------------
      nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
      nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
      nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
      nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )
      if (do_liq_num) then 
        call strat_cloud (Time, is, ie, js, je, dt, pfull, phalf,             & 
                          radturbten, t, q, tracer(:,:,:,nql),            &
                          tracer(:,:,:,nqi), tracer(:,:,:,nqa),               &
                          omega, mc_full, diff_t, land, ttnd, qtnd,           &
                          q_tnd(:,:,:,nql), q_tnd(:,:,:,nqi),                 &
                          q_tnd(:,:,:,nqa), rain3d, snow3d, snowclr3d,rain, snow,       &
                          convective_humidity_ratio, convective_humidity_area,&
                          limit_conv_cloud_frac, mask=mask,                   &
                          qn=tracer(:,:,:,nqn), Aerosol=Aerosol,              &
                          SN=q_tnd(:,:,:,nqn))
      else if ( do_lin_cld_microphys ) then
        nqr = get_tracer_index (MODEL_ATMOS, 'rainwat')
        nqs = get_tracer_index (MODEL_ATMOS, 'snowwat')
        nqg = get_tracer_index (MODEL_ATMOS, 'graupel')
        do k=1,kx
          delp(:,:,k) =  phalf(:,:,k+1) - phalf(:,:,k)
          delz(:,:,k) = (zhalf(:,:,k+1)-zhalf(:,:,k))*t(:,:,k)/tm(:,:,k)
        enddo

        call lin_cld_microphys_driver(q, tracer(:,:,:,nql), tracer(:,:,:,nqr), &
                        tracer(:,:,:,nqi), tracer(:,:,:,nqs), tracer(:,:,:,nqg), &
                        tracer(:,:,:,nqa), qtnd, q_tnd(:,:,:,nql),               &
                        q_tnd(:,:,:,nqr), q_tnd(:,:,:,nqi),                      &
                        q_tnd(:,:,:,nqs), q_tnd(:,:,:,nqg), q_tnd(:,:,:,nqa),    &
                        ttnd, t,   pfull, delz, delp, area,                    &
                        dt, land, rain, snow, ice_lin, graupel_lin,              &
                        hydrostatic, phys_hydrostatic,                           &
                        is, ie, js, je, 1, kx, ktop, kx, Time)

! Add all "solid" form of precipitation into surf_snow
        snow = (snow + ice_lin + graupel_lin) * dt/86400.
        rain =  rain * dt/86400.

! Update tendencies:
        rdt(:,:,:,nqr) = rdt(:,:,:,nqr) + q_tnd(:,:,:,nqr)
        rdt(:,:,:,nqs) = rdt(:,:,:,nqs) + q_tnd(:,:,:,nqs)
        rdt(:,:,:,nqg) = rdt(:,:,:,nqg) + q_tnd(:,:,:,nqg)

        ttnd =  ttnd * dt
        qtnd =  qtnd * dt
        q_tnd(:,:,:,nql) = q_tnd(:,:,:,nql) * dt
        q_tnd(:,:,:,nqi) = q_tnd(:,:,:,nqi) * dt
        q_tnd(:,:,:,nqa) = q_tnd(:,:,:,nqa) * dt

! Update rain_wat, snow_wat, graupel_wat
        tracer(:,:,:,nqr) = tracer(:,:,:,nqr) + q_tnd(:,:,:,nqr)*dt
        tracer(:,:,:,nqs) = tracer(:,:,:,nqs) + q_tnd(:,:,:,nqs)*dt
        tracer(:,:,:,nqg) = tracer(:,:,:,nqg) + q_tnd(:,:,:,nqg)*dt
      else
 
        call strat_cloud (Time, is, ie, js, je, dt, pfull, phalf,              & 
                          radturbten, t, q, tracer(:,:,:,nql),             &
                          tracer(:,:,:,nqi), tracer(:,:,:,nqa),                &
                          omega, mc_full, diff_t, land, ttnd, qtnd,            &
                          q_tnd(:,:,:,nql), q_tnd(:,:,:,nqi), q_tnd(:,:,:,nqa),&
                          rain3d, snow3d, snowclr3d, rain, snow,               &
                          convective_humidity_ratio, convective_humidity_area, &
                          limit_conv_cloud_frac, mask=mask)
      endif
    
!----------------------------------------------------------------------
!    upon return from strat_cloud, update the cloud liquid, ice and area.
!    update the temperature and specific humidity fields.
!----------------------------------------------------------------------
      tracer(:,:,:,nql) = tracer(:,:,:,nql) + q_tnd(:,:,:,nql)              
      tracer(:,:,:,nqi) = tracer(:,:,:,nqi) + q_tnd(:,:,:,nqi)
      tracer(:,:,:,nqa) = tracer(:,:,:,nqa) + q_tnd(:,:,:,nqa)
      if (do_liq_num) tracer(:,:,:,nqn) = tracer(:,:,:,nqn) + q_tnd(:,:,:,nqn)

!   save the lsc fields for use in radiation package.
      lsc_cloud_area(:,:,:) = tracer(:,:,:,nqa)
      lsc_liquid(:,:,:)  =  tracer(:,:,:,nql)
      lsc_ice(:,:,:) =  tracer(:,:,:,nqi)
      if (do_liq_num) lsc_droplet_number(:,:,:) = tracer(:,:,:,nqn)

      t = t + ttnd 
      q = q + qtnd
        
      used = send_data (id_qvout, q, Time, is, js, 1, rmask=mask)
      used = send_data (id_qaout, tracer(:,:,:,nqa), Time, is, js, 1, rmask=mask)
      used = send_data (id_qlout, tracer(:,:,:,nql), Time, is, js, 1, rmask=mask)
      used = send_data (id_qiout, tracer(:,:,:,nqi), Time, is, js, 1, rmask=mask)

!----------------------------------------------------------------------
!    call strat_cloud_sum to make the cloud variables available for 
!    access by the radiation package. NOTE: this is no longer necessary,
!    and can be judiciously removed (provided other affiliated code 
!    and options are nullified).
!----------------------------------------------------------------------
      call strat_cloud_sum (is, js, tracer(:,:,:,nql),  &
                            tracer(:,:,:,nqi), tracer(:,:,:,nqa))

!----------------------------------------------------------------------
!    convert increments to tendencies.
!----------------------------------------------------------------------
      ttnd = ttnd*dtinv 
      qtnd = qtnd*dtinv
      rain = rain*dtinv 
      snow = snow*dtinv
      q_tnd(:,:,:,nql) = q_tnd(:,:,:,nql)*dtinv
      q_tnd(:,:,:,nqi) = q_tnd(:,:,:,nqi)*dtinv
      q_tnd(:,:,:,nqa) = q_tnd(:,:,:,nqa)*dtinv
      if (do_liq_num) q_tnd(:,:,:,nqn) = q_tnd(:,:,:,nqn)*dtinv
   
!----------------------------------------------------------------------
!    update the total tendency terms (temperature, vapor specific 
!    humidity, cloud liquid, cloud ice, cloud area, liquid precip,
!    frozen precip) with the contributions from the strat_cloud scheme.
!----------------------------------------------------------------------
      tdt = tdt + ttnd 
      qdt = qdt + qtnd
      rdt(:,:,:,nql) = rdt(:,:,:,nql) + q_tnd(:,:,:,nql)
      rdt(:,:,:,nqi) = rdt(:,:,:,nqi) + q_tnd(:,:,:,nqi)
      rdt(:,:,:,nqa) = rdt(:,:,:,nqa) + q_tnd(:,:,:,nqa)
      if (do_liq_num) rdt(:,:,:,nqn) = rdt(:,:,:,nqn) + q_tnd(:,:,:,nqn)
      lprec = lprec + rain
      fprec = fprec + snow

end subroutine moistproc_strat_cloud


!#######################################################################
subroutine moistproc_uw_conv(Time, is, ie, js, je, dt, t, q, u, v, tracer,            &
                             pfull, phalf, zfull, zhalf, omega, pblht,        &
                             ustar, bstar, qstar, land, coldT, Aerosol,       &
                             cush, cbmf, cmf, conv_calc_completed,            &
                             available_cf_for_uw, tdt, qdt, udt, vdt, rdt,    &
                             ttnd_conv, qtnd_conv, lprec, fprec, precip,      &
                             liq_precflx, ice_precflx,    &
                             do_strat, do_limit_uw, do_liq_num, num_tracers,  &
                             tracers_in_uw, num_uw_tracers, shallow_cloud_area,&
                             shallow_liquid, shallow_ice, shallow_droplet_number, uw_wetdep)

  type(time_type), intent(in)   :: Time
  type(aerosol_type),intent(in) :: Aerosol
  integer, intent(in)           :: is, ie,js, je, num_tracers, num_uw_tracers
  real, intent(in)              :: dt
  logical, intent(in)           :: do_strat, do_limit_uw, do_liq_num
  logical, intent(in), dimension(:)       :: tracers_in_uw
  logical, intent(in), dimension(:,:)     :: coldT, conv_calc_completed
  real, intent(in),    dimension(:,:)     :: land, ustar, bstar, qstar, pblht
  real, intent(in),    dimension(:,:,:)   :: pfull, phalf, zfull, zhalf, omega, &
                                             t, q, u, v, available_cf_for_uw
  real, intent(in),    dimension(:,:,:,:) :: tracer
  real, intent(inout), dimension(:,:)     :: lprec, fprec, precip, cush, cbmf
  real, intent(inout), dimension(:,:,:)   :: tdt, qdt, udt, vdt,   &
                                             ttnd_conv, qtnd_conv, cmf
  real, intent(inout), dimension(:,:,:,:) :: rdt
  real, intent(inout), dimension(:,:,:)   :: shallow_cloud_area, &
                                             shallow_liquid,     &
                                             shallow_ice,        &
                                             shallow_droplet_number
  real, intent(out),   dimension(:,:,:)   :: liq_precflx, ice_precflx
  real, intent(out),   dimension(:,:,:)   :: uw_wetdep

  integer :: n, nn, nql, nqi, nqa, nqn
  real, dimension(size(t,1), size(t,2), size(t,3)) :: thlflx, qtflx, precflx
  real, dimension(size(rdt,1), size(rdt,2), size(rdt,3), num_uw_tracers) :: trcr

      nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
      nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
      nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
      nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )

!----------------------------------------------------------------------
!    if any tracers are to be transported by UW convection, check each
!    active tracer to find those to be transported and fill the 
!    ras_tracers array with these fields.
!---------------------------------------------------------------------
      nn = 1
      do n=1, num_tracers
        if (tracers_in_uw(n)) then
          trcr(:,:,:,nn) = tracer(:,:,:,n)
          nn = nn + 1
        endif
      end do

      call uw_conv (is, js, Time, t, q, u, v, pfull, phalf, zfull, zhalf, &
                    tracer, omega, dt, pblht, ustar, bstar, qstar, land,  &
                    coldT, Aerosol, cush, do_strat,  conv_calc_completed, &
                    available_cf_for_uw, ttnd_uw(is:ie,js:je,:),          &
                    qtnd_uw(is:ie,js:je,:), qltnd_uw(is:ie,js:je,:),      &
                    qitnd_uw(is:ie,js:je,:), qatnd_uw(is:ie,js:je,:),     &
                    qntnd_uw(is:ie,js:je,:),                              &
                    utnd_uw(is:ie,js:je,:), vtnd_uw(is:ie,js:je,:),       &
                    rain_uw(is:ie,js:je), snow_uw(is:ie,js:je), cmf,      &
                    thlflx, qtflx, precflx, liq_precflx, ice_precflx,     &
                    shallow_liquid, shallow_ice, shallow_cloud_area,      &
                    shallow_droplet_number, cbmf, trcr,                   &
                    qtruw(is:ie,js:je,:,:), uw_wetdep)

      if (.not. do_limit_uw) then
        tdt=tdt+ttnd_uw(is:ie,js:je,:) 
        qdt=qdt+qtnd_uw(is:ie,js:je,:)
        udt=udt+utnd_uw(is:ie,js:je,:)
        vdt=vdt+vtnd_uw(is:ie,js:je,:)
        ttnd_conv = ttnd_conv + ttnd_uw(is:ie,js:je,:)
        qtnd_conv = qtnd_conv + qtnd_uw(is:ie,js:je,:)
        lprec=lprec+rain_uw(is:ie,js:je)
        fprec=fprec+snow_uw(is:ie,js:je)
        precip=precip+rain_uw(is:ie,js:je)+snow_uw(is:ie,js:je)

        if (do_strat) then
          rdt(:,:,:,nql) = rdt(:,:,:,nql) + qltnd_uw(is:ie,js:je,:)
          rdt(:,:,:,nqi) = rdt(:,:,:,nqi) + qitnd_uw(is:ie,js:je,:)
          rdt(:,:,:,nqa) = rdt(:,:,:,nqa) + qatnd_uw(is:ie,js:je,:)
          if (do_liq_num) rdt(:,:,:,nqn) = rdt(:,:,:,nqn) + qntnd_uw(is:ie,js:je,:)
        endif

!---------------------------------------------------------------------
!    update the current tracer tendencies with the contributions 
!    just obtained from uw transport.
!---------------------------------------------------------------------
        nn = 1
        do n=1, num_tracers
          if (tracers_in_uw(n)) then
            rdt(:,:,:,n) = rdt(:,:,:,n) + qtruw(is:ie,js:je,:,nn)
            nn = nn + 1
          endif
        end do
      endif  !(.not. do_limit_uw)

end subroutine moistproc_uw_conv


!#######################################################################
subroutine moistproc_scale_donner(is,ie,js,je,q, delta_temp, delta_q, precip_returned,      &
                                  total_precip, lheat_precip, liquid_precip,    &
                                  frozen_precip, num_tracers, tracers_in_donner,&
                                  qtr, scale)

  integer, intent(in) :: is, ie, js, je, num_tracers
  logical, intent(in), dimension(:)       :: tracers_in_donner
  real, intent(inout), dimension(:,:)     :: precip_returned, total_precip, &
                                             lheat_precip
  real, intent(inout), dimension(:,:,:)   :: q, delta_temp, delta_q,    &
                                             liquid_precip, frozen_precip
  real, intent(inout), dimension(:,:,:,:) :: qtr
  real, intent(out),   dimension(:,:)     :: scale

  integer :: n, nn, i, j, k, ix, jx, kx
  real    :: qvin, dqv
  real, dimension(size(q,1), size(q,2), size(q,3)) :: temp

      ix = size(q,1)
      jx = size(q,2)
      kx = size(q,3)

!     Tendencies coming out of Donner deep are adjusted to prevent
!     the formation of negative water vapor, liquid or ice.

!     (1) Prevent negative liquid and ice specific humidities after
!     tendencies are applied

      where ((qlin(is:ie,js:je,:)+delta_ql(is:ie,js:je,:)) .lt. 0.)
        delta_temp(:,:,:)  = delta_temp (:,:,:) - (qlin(is:ie,js:je,:)+delta_ql(is:ie,js:je,:))*HLV/CP_AIR
        delta_q(:,:,:)     = delta_q    (:,:,:) + (qlin(is:ie,js:je,:)+delta_ql(is:ie,js:je,:))
        delta_ql(is:ie,js:je,:)    = delta_ql   (is:ie,js:je,:) - (qlin(is:ie,js:je,:)+delta_ql(is:ie,js:je,:))
      end where

      where ((qiin(is:ie,js:je,:)+delta_qi(is:ie,js:je,:)) .lt. 0.)
        delta_temp(:,:,:)  = delta_temp (:,:,:) - (qiin(is:ie,js:je,:)+delta_qi(is:ie,js:je,:))*HLS/CP_AIR
        delta_q(:,:,:)     = delta_q    (:,:,:) + (qiin(is:ie,js:je,:)+delta_qi(is:ie,js:je,:))
        delta_qi(is:ie,js:je,:)    = delta_qi   (is:ie,js:je,:) - (qiin(is:ie,js:je,:)+delta_qi(is:ie,js:je,:))
      end where

      where (abs(delta_ql(is:ie,js:je,:) + delta_qi(is:ie,js:je,:)) .lt. 1.e-10 )
        delta_qa(is:ie,js:je,:) = 0.0
      end where

!     (2) Compute limit on Donner tendencies to prevent water vapor
!     from going below 1.e-10. The value of 1.e-10 is consistent with qmin
!      in strat_cloud.F90

!     scaling factor for each grid point
      temp = 1.0
      do k=1,kx
       do j=1,jx
        do i=1,ix
          qvin = q(i,j,k)
          dqv  = delta_q    (i,j,k)
          if ( dqv.lt.0 .and. qvin+dqv.lt.1.e-10 ) then
            temp(i,j,k) = max( 0.0, -(qvin-1.e-10)/dqv )
          endif
        end do
       end do
      end do

!     scaling factor for each column is the minimum value within that column
      scale = minval( temp, dim=3 )

!     scale tendencies
      do k=1,kx
        delta_temp(:,:,k)  = scale(:,:) * delta_temp(:,:,k)
        delta_q(:,:,k)     = scale(:,:) * delta_q    (:,:,k)
        delta_qa(is:ie,js:je,k)    = scale(:,:) * delta_qa(is:ie,js:je,k)
        delta_ql(is:ie,js:je,k)    = scale(:,:) * delta_ql(is:ie,js:je,k)
        delta_qi(is:ie,js:je,k)    = scale(:,:) * delta_qi(is:ie,js:je,k)
      end do

      nn = 1
      do n=1, num_tracers
        if (tracers_in_donner(n)) then
          do k=1,kx
            qtr(:,:,k,nn) = scale(:,:) * qtr(:,:,k,nn)
          end do
          nn = nn + 1
        endif
      end do

      precip_returned = scale*precip_returned

      total_precip = scale*total_precip
      lheat_precip = scale*lheat_precip
      do k=1, kx
        liquid_precip(:,:,k) = scale(:,:)*liquid_precip(:,:,k)
        frozen_precip(:,:,k) = scale(:,:)*frozen_precip(:,:,k)
      end do

end subroutine moistproc_scale_donner


!#######################################################################
subroutine moistproc_scale_uw(is,ie,js,je, dt, q, tracer, tdt, qdt, udt, vdt, rdt,    &
                              ttnd_conv, qtnd_conv, lprec, fprec, precip,&
                              do_strat, do_liq_num, num_tracers,         &
                              tracers_in_uw, scale)

  integer, intent(in)           :: is, ie, js, je, num_tracers
  real, intent(in)              :: dt
  logical, intent(in)           :: do_strat, do_liq_num
  logical, intent(in), dimension(:)       :: tracers_in_uw
  real, intent(in),    dimension(:,:,:)   :: q
  real, intent(in),    dimension(:,:,:,:) :: tracer
  real, intent(inout), dimension(:,:)     :: lprec, fprec, precip
  real, intent(inout), dimension(:,:,:)   :: tdt, qdt, udt, vdt,  &
                                             ttnd_conv, qtnd_conv
  real, intent(inout), dimension(:,:,:,:) :: rdt
  real, intent(out),   dimension(:,:)     :: scale

  integer :: n, nn, i, j, k, ix, jx, kx, nql, nqi, nqa, nqn
  real    :: qvin, dqv
  real, dimension(size(q,1), size(q,2), size(q,3)) :: temp

      ix = size(q,1)
      jx = size(q,2)
      kx = size(q,3)
      nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
      nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
      nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
      nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )

!----------------------------------------------------------------------

!      Tendencies coming out of UW shallow are adjusted to prevent
!      the formation of negative water vapor, liquid or ice.
 
!      (1) Prevent negative liquid and ice specific humidities after tendencies are applied
       temp = tracer(:,:,:,nql)/dt + qltnd_uw(is:ie,js:je,:)
       where (temp(:,:,:) .lt. 0.)
         ttnd_uw(is:ie,js:je,:)  = ttnd_uw(is:ie,js:je,:)  - temp(:,:,:)*HLV/CP_AIR
         qtnd_uw(is:ie,js:je,:)  = qtnd_uw(is:ie,js:je,:)  + temp(:,:,:)
         qltnd_uw(is:ie,js:je,:) = qltnd_uw(is:ie,js:je,:) - temp(:,:,:)
       end where

       temp = tracer(:,:,:,nqi)/dt + qitnd_uw(is:ie,js:je,:)
       where (temp .lt. 0.)
         ttnd_uw(is:ie,js:je,:)  = ttnd_uw(is:ie,js:je,:)  - temp(:,:,:)*HLS/CP_AIR
         qtnd_uw(is:ie,js:je,:)  = qtnd_uw(is:ie,js:je,:)  + temp(:,:,:)
         qitnd_uw(is:ie,js:je,:) = qitnd_uw(is:ie,js:je,:) - temp(:,:,:)
       end where

       where (abs(qltnd_uw(is:ie,js:je,:)+qitnd_uw(is:ie,js:je,:))*dt .lt. 1.e-10 )
         qatnd_uw(is:ie,js:je,:) = 0.0
       end where

!      (2) Compute limit on UW tendencies to prevent water vapor
!      from going below 1.e-10. The value of 1.e-10 is consistent with qmin
!      in strat_cloud.F90

!      scaling factor for each grid point

       temp = 1.0
       do k=1,kx
        do j=1,jx
         do i=1,ix
           qvin = q(i,j,k) + tracer(i,j,k,nql) + tracer(i,j,k,nqi)
           dqv  = ( qtnd_uw(i+is-1,j+js-1,k) + qltnd_uw(i+is-1,j+js-1,k) + qitnd_uw(i+is-1,j+js-1,k) )*dt
           if ( dqv.lt.0 .and. qvin+dqv.lt.1.e-10 ) then
             temp(i,j,k) = max( 0.0, -(qvin-1.e-10)/dqv )
           endif
         end do
        end do
       end do

!      scaling factor for each column is the minimum value within that column
       scale = minval( temp, dim=3 )

!      scale tendencies
       do k=1,kx
         utnd_uw(is:ie,js:je,k)  = scale(:,:) * utnd_uw(is:ie,js:je,k)
         vtnd_uw(is:ie,js:je,k)  = scale(:,:) * vtnd_uw(is:ie,js:je,k)
         ttnd_uw(is:ie,js:je,k)  = scale(:,:) * ttnd_uw(is:ie,js:je,k)
         qtnd_uw(is:ie,js:je,k)  = scale(:,:) * qtnd_uw(is:ie,js:je,k)
         qltnd_uw(is:ie,js:je,k) = scale(:,:) * qltnd_uw(is:ie,js:je,k)
         qitnd_uw(is:ie,js:je,k) = scale(:,:) * qitnd_uw(is:ie,js:je,k)
         qatnd_uw(is:ie,js:je,k) = scale(:,:) * qatnd_uw(is:ie,js:je,k)
       end do

       if (do_liq_num) then
         do k=1,kx
          qntnd_uw(is:ie,js:je,k) = scale(:,:) * qntnd_uw(is:ie,js:je,k)
         end do
       end if

       rain_uw(is:ie,js:je) = scale(:,:) * rain_uw(is:ie,js:je)
       snow_uw(is:ie,js:je) = scale(:,:) * snow_uw(is:ie,js:je)

!      update tendencies
       tdt=tdt+ttnd_uw(is:ie,js:je,:)
       qdt=qdt+qtnd_uw(is:ie,js:je,:)
       udt=udt+utnd_uw(is:ie,js:je,:)
       vdt=vdt+vtnd_uw(is:ie,js:je,:)
       ttnd_conv = ttnd_conv + ttnd_uw(is:ie,js:je,:)
       qtnd_conv = qtnd_conv + qtnd_uw(is:ie,js:je,:)

!      update precipitation
       lprec=lprec+rain_uw(is:ie,js:je)
       fprec=fprec+snow_uw(is:ie,js:je)
       precip=precip+rain_uw(is:ie,js:je)+snow_uw(is:ie,js:je)

       if (do_strat) then
         rdt(:,:,:,nql) = rdt(:,:,:,nql) + qltnd_uw(is:ie,js:je,:)
         rdt(:,:,:,nqi) = rdt(:,:,:,nqi) + qitnd_uw(is:ie,js:je,:)
         rdt(:,:,:,nqa) = rdt(:,:,:,nqa) + qatnd_uw(is:ie,js:je,:)
         if (do_liq_num) rdt(:,:,:,nqn) = rdt(:,:,:,nqn) + qntnd_uw(is:ie,js:je,:)
       endif

!      update the current tracer tendencies with the contributions 
!      obtained from uw transport.
       nn = 1
       do n=1, num_tracers
         if (tracers_in_uw(n)) then
           rdt(:,:,:,n) = rdt(:,:,:,n) + qtruw (is:ie,js:je,:,nn)
           nn = nn + 1
         endif
       end do
end subroutine moistproc_scale_uw

end module moistproc_kernels_mod



                    module moist_processes_mod

!-----------------------------------------------------------------------
!
!         interface module for moisture processes
!         ---------------------------------------
!             moist convective adjustment
!             relaxed arakawa-schubert
!             donner deep convection
!             large-scale condensation
!             stratiform prognostic cloud scheme 
!             rel humidity cloud scheme 
!             diagnostic cloud scheme 
!             lin cloud microphysics
!             betts-miller convective adjustment
!
!-----------------------------------------------------------------------

! fms modules
use sat_vapor_pres_mod,    only: compute_qs, lookup_es
use time_manager_mod,      only: time_type, get_time
use diag_manager_mod,      only: register_diag_field, send_data
use mpp_mod,               only: input_nml_file
use fms_mod,               only: error_mesg, FATAL, NOTE,        &
                                 file_exist, check_nml_error,    &
                                 open_namelist_file, close_file, &
                                 write_version_number,           &
                                 mpp_pe, mpp_root_pe, stdlog,    &
                                 mpp_clock_id, mpp_clock_begin,  &
                                 mpp_clock_end, CLOCK_MODULE,    &
                                 MPP_CLOCK_SYNC, read_data, write_data
use field_manager_mod,     only: MODEL_ATMOS
use tracer_manager_mod,    only: get_tracer_index,&
                                 get_number_tracers, &
                                 get_tracer_names, &
                                 query_method, &
                                 NO_TRACER
use constants_mod,         only: CP_AIR, GRAV, HLV, HLS, HLF, &
                                 RDGAS, RVGAS, TFREEZE, WTMAIR, &
                                 SECONDS_PER_DAY, KAPPA
! atmos_param modules
use betts_miller_mod,      only: betts_miller, betts_miller_init
use bm_massflux_mod,       only: bm_massflux, bm_massflux_init
use bm_omp_mod,            only: bm_omp, bm_omp_init
use donner_deep_mod,       only: donner_deep_init,               &
                                 donner_deep_time_vary,  &
                                 donner_deep_endts,         &
                                 donner_deep, donner_deep_end,   &
                                 donner_deep_restart
use moist_conv_mod,        only: moist_conv, moist_conv_init
use lscale_cond_mod,       only: lscale_cond_init
use uw_conv_mod,           only: uw_conv_end, uw_conv_init
use lin_cld_microphys_mod, only: lin_cld_microphys_init, &
                                 lin_cld_microphys_end
use ras_mod,               only: ras_end, ras_init
use dry_adj_mod,           only: dry_adj, dry_adj_init
use strat_cloud_mod,       only: strat_cloud_init, strat_cloud_end, &
                                 strat_cloud_restart
use rh_clouds_mod,         only: rh_clouds_init, rh_clouds_end, &
                                 rh_clouds_sum
use diag_cloud_mod,        only: diag_cloud_init, diag_cloud_end, &
                                 diag_cloud_restart
use diag_integral_mod,     only: diag_integral_field_init, &
                                 sum_diag_integral_field
use cu_mo_trans_mod,       only: cu_mo_trans_init, cu_mo_trans, cu_mo_trans_end
use moz_hook_mod,          only: moz_hook
use rad_utilities_mod,     only: aerosol_type
use moist_proc_utils_mod,  only: capecalcnew, tempavg, column_diag, rh_calc, pmass

use moistproc_kernels_mod, only: moistproc_init, moistproc_end, moistproc_mca, &
                                 moistproc_ras, moistproc_lscale_cond,         &
                                 moistproc_strat_cloud, moistproc_cmt,         &
                                 moistproc_uw_conv, moistproc_scale_uw,        &
                                 moistproc_scale_donner,                       &
                                 rain_uw, snow_uw, ttnd_uw, qtnd_uw, utnd_uw,  &
                                 vtnd_uw, qltnd_uw, qitnd_uw, qatnd_uw,        &
                                 qntnd_uw, qtruw, qlin, qiin, qain, delta_ql,  &
                                 delta_qi, delta_qa
! atmos_shared modules
use atmos_tracer_utilities_mod, only : wet_deposition

implicit none
private

!-----------------------------------------------------------------------
!-------------------- public data/interfaces ---------------------------

   public   moist_processes, moist_processes_init, moist_processes_end, &
            moist_alloc_init, moist_alloc_end, &
            moist_processes_time_vary, moist_processes_endts, &
            doing_strat, moist_processes_restart
  

!-----------------------------------------------------------------------
!-------------------- private data -------------------------------------

!--------------------- version number ----------------------------------
   character(len=128) :: &
   version = '$Id: moist_processes.F90,v 18.0.4.3.2.1.2.1 2010/09/05 12:51:18 pjp Exp $'
   character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

   character(len=5), private :: mod_name = 'moist'
   logical            :: moist_allocated = .false.
   logical            :: module_is_initialized = .false.

!-------------------- namelist data (private) --------------------------

!---------------- namelist variable definitions ------------------------
!
!   do_limit_donner = limit Donner deeo tendencies to prevent the
!                formation of grid points with negative water vapor,
!                liquid or ice.
!
!   do_limit_uw = limit UW shallow tendencies to prevent the formation
!                of grid points with negative total water specific 
!                humidities. This situation can occur because both
!                shallow and deep convection operate on the same
!                soundings without knowledge of what the other is doing
!
!   do_unified_convective_closure = use cloud base mass flux calculated
!                in uw_conv module as value for donner deep parameter-
!                ization; adjust cbmf available for uw shallow appropr-
!                iately. only available when uw shallow and donner deep
!                are the active convective schemes
!   do_mca   = switch to turn on/off moist convective adjustment;
!                [logical, default: do_mca=true ]
!   do_lsc   = switch to turn on/off large scale condensation
!                [logical, default: do_lsc=true ]
!   do_ras   = switch to turn on/off relaxed arakawa shubert
!                [logical, default: do_ras=false ]
!   do_donner_deep = switch to turn on/off donner deep convection scheme
!                [logical, default: do_donner_deep=false ]
!   do_strat = switch to turn on/off stratiform cloud scheme
!                [logical, default: do_strat=false ]
!   do_rh_clouds = switch to turn on/off simple relative humidity cloud scheme
!                [logical, default: do_rh_clouds=false ]
!   do_diag_clouds = switch to turn on/off (Gordon's) diagnostic cloud scheme
!                [logical, default: do_diag_clouds=false ]
!   do_dryadj = switch to turn on/off dry adjustment scheme
!                [logical, default: do_dryadj=false ]
!   do_lin_cld_microphys = switch to turn on/off the Lin Cloud Micro-Physics scheme
!                [logical, default: do_lin_cld_microphys=false ]
!   do_liq_num = switch to turn on/off the prognostic droplet number scheme.
!                [logical, default: do_liq_num=false ]
!   use_tau  = switch to determine whether current time level (tau)
!                will be used or else future time level (tau+1).
!                if use_tau = true then the input values for t,q, and r
!                are used; if use_tau = false then input values
!                tm+tdt*dt, etc. are used.
!                [logical, default: use_tau=false ]
!
!   pdepth   = boundary layer depth in pascals for determining mean
!                temperature tfreeze (used for snowfall determination)
!   tfreeze  = mean temperature used for snowfall determination (deg k)
!                [real, default: tfreeze=273.16]
!
!   do_gust_cv = switch to use convective gustiness (default = false)
!   gustmax    = maximum convective gustiness (m/s)
!   gustconst  = precip rate which defines precip rate which begins to
 !               matter for convective gustiness (kg/m2/sec)
!   cmt_mass_flux_source = parameterization(s) being used to supply the 
!                mass flux profiles seen by the cumulus momentum transport
!                module; currently either 'ras', 'donner', 'uw', 
!                'donner_and_ras', 'donner_and_uw', 'ras_and_uw', 
!                'donner_and_ras_and_uw' or 'all'
!
!   do_bm    = switch to turn on/off betts-miller scheme
!                [logical, default: do_bm=false ]
!   do_bmmass  = switch to turn on/off betts-miller massflux scheme
!                [logical, default: do_bmmass=false ]
!   do_bmomp  = switch to turn on/off olivier's version of the betts-miller 
!                scheme (with separated boundary layer)
!                [logical, default: do_bmomp=false ]
!   do_simple = switch to turn on alternative definition of specific humidity.
!                When true, specific humidity = (rdgas/rvgas)*esat/pressure
!
!   notes: 1) do_lsc and do_strat cannot both be true
!          2) pdepth and tfreeze are used to determine liquid vs. solid
!             precipitation for mca, lsc, and ras schemes, the 
!             stratiform scheme determines it's own precipitation type.
!          3) if do_strat=true then stratiform cloud tracers: liq_wat,
!             ice_wat, cld_amt must be present 
!          4) do_donner_deep and do_rh_clouds cannot both be true
!             (pending revision of code flow)
!
!-----------------------------------------------------------------------
! main convection/large-scale schemes
   logical :: do_bm=.false.
   logical :: do_bmmass =.false.
   logical :: do_bmomp  =.false.
   logical :: do_cmt=.false.
   logical :: do_diag_clouds=.false.
   logical :: do_donner_deep=.false.
   logical :: do_dryadj=.false.
   logical :: do_lin_cld_microphys=.false.
   logical :: do_lsc=.true.
   logical :: do_mca=.true. 
   logical :: do_ras=.false.
   logical :: do_rh_clouds=.false.
   logical :: do_strat=.false.
   logical :: do_uw_conv=.false.
! tracers 
   logical :: do_tracers_in_donner =.false.
   logical :: do_tracers_in_mca = .false.
   logical :: do_tracers_in_ras = .false.
   logical :: do_tracers_in_uw = .false.
! donner specific 
   logical :: do_donner_before_uw = .false.
   logical :: do_donner_mca=.true.
   logical :: do_donner_conservation_checks = .false.
   logical :: do_limit_donner = .false. ! .false. produces previous 
                                        ! behavior (cjg)
   logical :: force_donner_moist_conserv = .false.
! cmt specific
   logical :: cmt_uses_donner = .false.
   logical :: cmt_uses_ras = .false.
   logical :: cmt_uses_uw  = .false.
! others
   logical :: doing_diffusive
   logical :: use_updated_profiles_for_uw = .false.
   logical :: only_one_conv_scheme_per_column = .false.
   logical :: limit_conv_cloud_frac = .false.
   logical :: include_donmca_in_cosp = .true.
   logical :: use_tau=.false.
   logical :: do_gust_cv = .false.
   logical :: do_liq_num = .false.
   logical :: do_simple =.false.
   logical :: do_unified_convective_closure = .false.
   logical :: do_limit_uw = .false.     ! .false. produces previous
                                        ! behavior (cjg )
   logical :: using_fms = .true.
   character(len=64)  :: cmt_mass_flux_source = 'ras'

   integer :: tau_sg = 0
   integer :: k_sg = 2

   real :: pdepth = 150.e2
   real :: gustmax = 3.                    ! maximum gustiness wind (m/s)
   real :: gustconst = 10./SECONDS_PER_DAY ! constant in kg/m2/sec, default =
                                           ! 1 cm/day = 10 mm/day

namelist /moist_processes_nml/ do_mca, do_lsc, do_ras, do_uw_conv, do_strat,     &
                               do_donner_before_uw, use_updated_profiles_for_uw, &
                               only_one_conv_scheme_per_column, do_diag_clouds,  &
                               limit_conv_cloud_frac, do_dryadj, pdepth,         &
                               include_donmca_in_cosp, &
                               do_unified_convective_closure, tau_sg, k_sg,      &
                               do_lin_cld_microphys, use_tau, do_rh_clouds,      &
                               cmt_mass_flux_source, do_donner_deep, do_cmt,     &
                               do_gust_cv, cmt_mass_flux_source, gustmax,        &
                               gustconst, do_liq_num, force_donner_moist_conserv,&
                               do_donner_conservation_checks, do_donner_mca,     &
                               do_limit_uw, do_limit_donner, using_fms,          &
                               do_bm, do_bmmass, do_bmomp, do_simple

!-------------------- clock definitions --------------------------------

integer :: convection_clock, largescale_clock, donner_clock, mca_clock, ras_clock, &
           donner_mca_clock, bm_clock, cmt_clock, closure_clock, lscalecond_clock, &
           stratcloud_clock, shallowcu_clock

!-------------------- diagnostics fields -------------------------------

integer :: id_tdt_conv, id_qdt_conv, id_prec_conv, id_snow_conv, &
           id_snow_tot, id_tot_cld_amt, id_conv_freq, &
           id_tdt_ls  , id_qdt_ls  , id_prec_ls  , id_snow_ls  , &
           id_precip  , id_WVP, id_LWP, id_IWP, id_AWP, id_gust_conv, &

           id_tot_cloud_area,  id_tot_liq_amt,  id_tot_ice_amt,  &
           id_tot_h2o, id_tot_vapor, &
           id_lsc_cloud_area,  id_lsc_liq_amt,  id_lsc_ice_amt,  &
           id_conv_cloud_area, id_conv_liq_amt, id_conv_ice_amt, &
           id_LWP_all_clouds,  id_IWP_all_clouds, id_WP_all_clouds, &

           id_tdt_dadj, id_rh,  id_qs, id_mc, id_mc_donner, id_mc_full, &
           id_mc_donner_half, &
           id_rh_cmip, id_mc_conv_up, id_mc_half, &
           id_conv_cld_base, id_conv_cld_top, &
           id_tdt_deep_donner, id_qdt_deep_donner, &
           id_qadt_deep_donner, id_qldt_deep_donner, &
           id_qidt_deep_donner, &
           id_tdt_mca_donner, id_qdt_mca_donner, &
           id_prec_deep_donner, id_prec_mca_donner,&
           id_tdt_uw, id_qdt_uw, &
           id_qadt_uw, id_qldt_uw, id_qidt_uw, id_qndt_uw, &
           id_prec1_deep_donner, &
           id_snow_deep_donner, id_snow_mca_donner, &
           id_qadt_ls, id_qldt_ls, id_qndt_ls, id_qidt_ls, &
           id_qadt_conv, id_qldt_conv, id_qndt_conv, id_qidt_conv, &
           id_qa_ls_col, id_ql_ls_col, id_qn_ls_col, id_qi_ls_col, &
           id_qa_conv_col, id_ql_conv_col, id_qn_conv_col,  &
           id_qi_conv_col, &
           id_bmflag, id_klzbs, id_invtaubmt, id_invtaubmq, &
           id_massflux, id_entrop_ls, &
           id_cape, id_cin, id_tref, id_qref, &
           id_q_conv_col, id_q_ls_col, id_t_conv_col, id_t_ls_col, &
           id_enth_moist_col, id_wat_moist_col, &
           id_enth_ls_col, id_wat_ls_col, &
           id_enth_conv_col, id_wat_conv_col, &
           id_enth_donner_col, id_wat_donner_col, &
           id_enth_donner_col2,  &
           id_enth_donner_col3,  &
           id_enth_donner_col4,  &
           id_enth_donner_col5,  &
           id_enth_donner_col6,  &
           id_enth_donner_col7,  &
           id_enth_mca_donner_col, id_wat_mca_donner_col, &
           id_enth_uw_col, id_wat_uw_col, &
           id_scale_donner, id_scale_uw, &
           id_ras_precip, id_ras_freq, id_don_precip, id_don_freq, &
           id_lsc_precip, id_lsc_freq, id_uw_precip, id_uw_snow, &
           id_uw_freq, &
           id_prod_no, id_m_cdet_donner, id_m_cellup, &
           id_conv_rain3d, id_conv_snow3d, id_lscale_rain3d, id_lscale_snow3d
 
integer :: id_qvout, id_qaout, id_qlout, id_qiout

integer :: id_vaporint, id_condensint, id_precipint, id_diffint
integer :: id_vertmotion
integer :: id_max_enthalpy_imbal_don, id_max_water_imbal_don
integer :: id_max_enthalpy_imbal, id_max_water_imbal
integer :: id_enthint, id_lprcp, id_lcondensint, id_enthdiffint
integer :: id_wetdep_om, id_wetdep_SOA, id_wetdep_bc, &
           id_wetdep_so4, id_wetdep_so2, id_wetdep_DMS, &
           id_wetdep_NH4NO3, id_wetdep_salt, id_wetdep_dust

integer, dimension(:), allocatable :: id_tracerdt_conv,  &
                                      id_tracerdt_conv_col, &
                                      id_conv_tracer,  &
                                      id_conv_tracer_col, &
                                      id_tracerdt_mcadon, &
                                      id_tracerdt_mcadon_col, &
                                      id_wetdep, &
                                      id_wet_deposition
real :: missing_value = -999.

!-------------------- individual scheme tracers ------------------------
   logical, dimension(:), allocatable :: tracers_in_donner, tracers_in_uw, &
                                         tracers_in_mca, tracers_in_ras
   integer :: num_donner_tracers=0
   integer :: num_mca_tracers=0
   integer :: num_ras_tracers=0
   integer :: num_uw_tracers=0
   integer :: num_tracers=0

   integer :: nbcphobic =0
   integer :: nbcphilic =0
   integer :: nomphobic =0
   integer :: nomphilic =0
   integer :: nsalt1 =0
   integer :: nsalt2 =0
   integer :: nsalt3 =0
   integer :: nsalt4 =0
   integer :: nsalt5 =0
   integer :: ndust1    =0
   integer :: ndust2    =0
   integer :: ndust3    =0
   integer :: ndust4    =0
   integer :: ndust5    =0
   integer :: nDMS      =0
   integer :: nSO2      =0
   integer :: nSO4      =0
   integer :: nSOA      =0
   integer :: nNH4NO3   =0
   integer :: nNH4      =0
   

!------------------- other global variables and parameters -------------
   real, parameter :: epst=200.

   integer :: nsphum, nql, nqi, nqa, nqn   ! tracer indices for stratiform clouds
   integer :: nqr, nqs, nqg                ! additional tracer indices for Lin Micro-Physics
   integer :: ktop                         ! top layer index for Lin Micro-Physics
   logical :: do_cosp, donner_meso_is_largescale


!------------------ allocatable moist processes variables --------------

   real, allocatable, dimension(:,:)   :: max_enthalpy_imbal, max_water_imbal, &
                                          max_enthalpy_imbal_don, max_water_imbal_don
   real, allocatable, dimension(:,:,:) :: tin, qin, rin, uin, vin, &
                                          ttnd, qtnd, rtnd, utnd, vtnd, ttnd_don, qtnd_don, &
                                          delta_temp, delta_vapor, delta_q, &
                                          donner_humidity_area, donner_humidity_factor
   real, allocatable, dimension(:,:,:) :: tin_orig, qin_orig, tdt_init, qdt_init
   real, allocatable, dimension(:,:,:) :: qtnd_wet,  &         ! specific humidity tendency (kg/kg/s)
                                          cloud_wet, &         ! cloud liquid+ice (kg/kg)
                                          cloud_frac           ! cloud area fraction
   real, allocatable, dimension(:,:,:) :: liquid_precip, frozen_precip
   real, allocatable, dimension(:,:,:) :: frz_meso, liq_meso, frz_cell
   real, allocatable, dimension(:,:,:) :: liq_cell, mca_frz, mca_liq
   real, allocatable, dimension(:,:,:) :: frz_mesoh, liq_mesoh, frz_cellh, &
                                          liq_precflx, ice_precflx, &
                                          liq_cellh, mca_frzh, mca_liqh,&
                                          ice_precflxh, liq_precflxh
   real, allocatable, dimension(:,:,:) :: ttnd_conv, qtnd_conv
   real, allocatable, dimension(:,:,:) :: qsat, det0, det_cmt       
   real, allocatable, dimension(:,:,:) :: mc_full, mc_donner, m_cdet_donner, massflux, mc_donner_up, &
                                          mc_half, mc_donner_half
   real, allocatable, dimension(:,:,:) :: RH, wetdeptnd, q_ref, t_ref
   real, allocatable, dimension(:,:,:) :: cf, cmf
   real, allocatable, dimension(:,:,:,:) :: tracer,tracer_orig, rdt_init, &
                                            qtr, q_tnd, donner_tracer

   real, allocatable, dimension(:,:)   :: prec_intgl  
!-----------------------------------------------------------------------

                             contains

!#######################################################################
! used to allocate variables used throughout moist_processes
subroutine moist_alloc_init (ix, jx, kx, lx)
   integer, intent(in) :: ix,jx,kx,lx

   if (moist_allocated) return

   allocate( tin       (ix,jx,kx))
   allocate( qin       (ix,jx,kx))
   allocate( rin       (ix,jx,kx))
   allocate( uin       (ix,jx,kx))
   allocate( vin       (ix,jx,kx))
   allocate( tin_orig  (ix,jx,kx))
   allocate( qin_orig  (ix,jx,kx))
   allocate( t_ref     (ix,jx,kx))
   allocate( q_ref     (ix,jx,kx))
   allocate( ttnd      (ix,jx,kx))
   allocate( qtnd      (ix,jx,kx))
   allocate( rtnd      (ix,jx,kx))
   allocate( utnd      (ix,jx,kx))
   allocate( vtnd      (ix,jx,kx))
   allocate( ttnd_don  (ix,jx,kx))
   allocate( qtnd_don  (ix,jx,kx))
   allocate( ttnd_conv (ix,jx,kx))
   allocate( qtnd_conv (ix,jx,kx))
   allocate( qtnd_wet  (ix,jx,kx))
   allocate( tdt_init  (ix,jx,kx))
   allocate( qdt_init  (ix,jx,kx))
   allocate( cf        (ix,jx,kx))
   allocate( cmf       (ix,jx,kx))
   allocate( delta_temp(ix,jx,kx))
   allocate( delta_q   (ix,jx,kx))
   allocate( delta_vapor(ix,jx,kx))
   allocate( donner_humidity_area(ix,jx,kx))
   allocate( donner_humidity_factor(ix,jx,kx))
   allocate( cloud_wet  (ix,jx,kx))
   allocate( cloud_frac (ix,jx,kx))
   allocate( liquid_precip(ix,jx,kx))
   allocate( frozen_precip(ix,jx,kx))
   allocate( ice_precflx (ix,jx,kx))
   allocate( liq_precflx (ix,jx,kx))
   allocate( frz_meso  (ix,jx,kx))
   allocate( liq_meso  (ix,jx,kx))
   allocate( frz_cell  (ix,jx,kx))
   allocate( liq_cell  (ix,jx,kx))
   allocate( mca_frz   (ix,jx,kx))
   allocate( mca_liq   (ix,jx,kx))
   allocate( frz_mesoh (ix,jx,kx+1))
   allocate( liq_mesoh (ix,jx,kx+1))
   allocate( frz_cellh (ix,jx,kx+1))
   allocate( liq_cellh (ix,jx,kx+1))
   allocate( mca_liqh  (ix,jx,kx+1))
   allocate( mca_frzh  (ix,jx,kx+1))
   allocate( ice_precflxh(ix,jx,kx+1))
   allocate( liq_precflxh(ix,jx,kx+1))
   allocate( qsat      (ix,jx,kx))
   allocate( det0      (ix,jx,kx))
   allocate( det_cmt   (ix,jx,kx))
   allocate( mc_full   (ix,jx,kx))
   allocate( mc_donner (ix,jx,kx))
   allocate( mc_donner_up (ix,jx,kx))
   allocate( mc_half      (ix,jx,kx+1))
   allocate( mc_donner_half (ix,jx,kx+1))
   allocate( m_cdet_donner(ix,jx,kx))
   allocate( massflux  (ix,jx,kx))
   allocate( RH        (ix,jx,kx))
! pmass defined in moist_processes_utils
   allocate( pmass     (ix,jx,kx))
   allocate( wetdeptnd (ix,jx,kx))
   allocate(tracer     (ix,jx,kx,lx))
   allocate(tracer_orig(ix,jx,kx,lx))
   allocate(q_tnd      (ix,jx,kx,lx))
   allocate(rdt_init   (ix,jx,kx,lx))
   allocate(qtr          (ix,jx,kx,num_donner_tracers))
   allocate(donner_tracer(ix,jx,kx,num_donner_tracers))
   

   moist_allocated = .true.
  
end subroutine moist_alloc_init


!#######################################################################
! used to deallocate variables used throughout moist_processes
subroutine moist_alloc_end

   if (moist_allocated .eqv. .false. ) return
   deallocate( tin       )
   deallocate( qin       )
   deallocate( rin       )
   deallocate( uin       )
   deallocate( vin       )
   deallocate( tin_orig  )
   deallocate( qin_orig  )
   deallocate( t_ref     )
   deallocate( q_ref     )
   deallocate( ttnd      )
   deallocate( qtnd      )
   deallocate( rtnd      )
   deallocate( utnd      )
   deallocate( vtnd      )
   deallocate( ttnd_don  )
   deallocate( qtnd_don  )
   deallocate( ttnd_conv )
   deallocate( qtnd_conv )
   deallocate( qtnd_wet  )
   deallocate( tdt_init  )
   deallocate( qdt_init  )
   deallocate( cf        )
   deallocate( cmf       )
   deallocate( delta_temp)
   deallocate( delta_q   )
   deallocate( delta_vapor )
   deallocate( donner_humidity_area)
   deallocate( donner_humidity_factor)
   deallocate( cloud_wet  )
   deallocate( cloud_frac )
   deallocate( liquid_precip)
   deallocate( frozen_precip)
   deallocate( ice_precflx)
   deallocate( liq_precflx)
   deallocate( frz_meso  )
   deallocate( liq_meso  )
   deallocate( frz_cell  )
   deallocate( liq_cell  )
   deallocate( mca_frz   )
   deallocate( mca_liq   )
   deallocate( frz_mesoh )
   deallocate( liq_mesoh )
   deallocate( frz_cellh )
   deallocate( liq_cellh )
   deallocate( mca_frzh  )
   deallocate( mca_liqh  )
   deallocate( ice_precflxh)
   deallocate( liq_precflxh)
   deallocate( qsat      )
   deallocate( det0      )
   deallocate( det_cmt   )
   deallocate( mc_full   )
   deallocate( mc_donner )
   deallocate( mc_donner_up )
   deallocate( mc_half      )
   deallocate( mc_donner_half      )
   deallocate( m_cdet_donner)
   deallocate( massflux  )
   deallocate( RH        )
   deallocate( pmass     )
   deallocate( wetdeptnd )
   deallocate(tracer     )
   deallocate(tracer_orig)
   deallocate(q_tnd      )
   deallocate(rdt_init   )
   deallocate(qtr        )
   deallocate(donner_tracer)


   moist_allocated = .false.

end subroutine moist_alloc_end

!#######################################################################

subroutine moist_processes (is, ie, js, je, Time, dt, land,            &
                            phalf, pfull, zhalf, zfull, omega, diff_t, &
                            radturbten, cush, cbmf,                    &
                            pblht, ustar, bstar, qstar,                &
                            t, q, r, u, v, tm, qm, rm, um, vm,         &
                            tdt, qdt, rdt, udt, vdt, diff_cu_mo,       &
                            convect, lprec, fprec, fl_lsrain,          &
                            fl_lssnow, fl_ccrain, fl_ccsnow, &
                            fl_donmca_rain, fl_donmca_snow, gust_cv,  &
                            area, lat, lsc_cloud_area, lsc_liquid,     &
                            lsc_ice, lsc_droplet_number, &
                            Aerosol, mask, kbot, &
                            shallow_cloud_area, shallow_liquid,  &
                            shallow_ice, shallow_droplet_number, &
                            cell_cld_frac, cell_liq_amt, cell_liq_size, &
                            cell_ice_amt, cell_ice_size, &
                            cell_droplet_number, &
                            meso_cld_frac, meso_liq_amt, meso_liq_size, &
                            meso_ice_amt, meso_ice_size,  &
                            meso_droplet_number, nsum_out, &
                            hydrostatic, phys_hydrostatic)

!-----------------------------------------------------------------------
!
!    in:  is,ie      starting and ending i indices for window
!
!         js,je      starting and ending j indices for window
!
!         Time       time used for diagnostics [time_type]
!
!         dt         time step (from t(n-1) to t(n+1) if leapfrog)
!                    in seconds   [real]
!
!         land       fraction of surface covered by land
!                      [real, dimension(nlon,nlat)]
!
!         phalf      pressure at half levels in pascals
!                      [real, dimension(nlon,nlat,nlev+1)]
!
!         pfull      pressure at full levels in pascals
!                      [real, dimension(nlon,nlat,nlev)]
!
!         omega      omega (vertical velocity) at full levels
!                    in pascals per second
!                      [real, dimension(nlon,nlat,nlev)]
!
!         diff_t     vertical diffusion coefficient for temperature
!                    and tracer (m*m/sec) on half levels
!                      [real, dimension(nlon,nlat,nlev)]
!
!         t, q       temperature (t) [deg k] and specific humidity
!                    of water vapor (q) [kg/kg] at full model levels,
!                    at the current time step if leapfrog scheme
!                      [real, dimension(nlon,nlat,nlev)]
!
!         r          tracer fields at full model levels,
!                    at the current time step if leapfrog 
!                      [real, dimension(nlon,nlat,nlev,ntrace)]
!
!         u, v,      zonal and meridional wind [m/s] at full model levels,
!                    at the current time step if leapfrog scheme
!                      [real, dimension(nlon,nlat,nlev)]
! 
!         tm, qm     temperature (t) [deg k] and specific humidity
!                    of water vapor (q) [kg/kg] at full model levels,
!                    at the previous time step if leapfrog scheme
!                      [real, dimension(nlon,nlat,nlev)]
!
!         rm         tracer fields at full model levels,
!                    at the previous time step if leapfrog 
!                      [real, dimension(nlon,nlat,nlev,ntrace)]
!
!         um, vm     zonal and meridional wind [m/s] at full model levels,
!                    at the previous time step if leapfrog 
!                      [real, dimension(nlon,nlat,nlev)]
!
!         area       grid box area (in m2)
!                      [real, dimension(nlon,nlat)]
!
!         lat        latitude in radians
!                      [real, dimension(nlon,nlat)]
!  
! inout:  tdt, qdt   temperature (tdt) [deg k/sec] and specific
!                    humidity of water vapor (qdt) tendency [1/sec]
!                      [real, dimension(nlon,nlat,nlev)]
!
!         rdt        tracer tendencies 
!                      [real, dimension(nlon,nlat,nlev,ntrace)]
!
!         udt, vdt   zonal and meridional wind tendencies [m/s/s]
! 
!   out:  convect    is moist convection occurring in this grid box?
!                      [logical, dimension(nlon,nlat)]
!
!         lprec      liquid precipitiaton rate (rain) in kg/m2/s
!                      [real, dimension(nlon,nlat)]
!
!         fprec      frozen precipitation rate (snow) in kg/m2/s
!                      [real, dimension(nlon,nlat)]
! 
!         gust_cv    gustiness from convection  in m/s
!                      [real, dimension(nlon,nlat)]
!
!       optional
!  -----------------
! 
!    in:  mask       mask (1. or 0.) for grid boxes above or below
!                    the ground   [real, dimension(nlon,nlat,nlev)]
!
!         kbot       index of the lowest model level
!                      [integer, dimension(nlon,nlat)]
!
!
!-----------------------------------------------------------------------
   integer,         intent(in)           :: is,ie,js,je
   type(time_type), intent(in)           :: Time
   real, intent(in)                      :: dt
   real, intent(in) , dimension(:,:)     :: land, pblht, ustar, bstar, qstar
   real, intent(inout), dimension(:,:)   :: cush, cbmf
   real, intent(in) , dimension(:,:,:)   :: phalf, pfull, zhalf, zfull, omega, &
                                            diff_t, t, q, u, v, tm, qm, um, vm
   real, dimension(:,:,:), intent(in)    :: radturbten
   real, intent(in) , dimension(:,:,:,:) :: r, rm
   real, intent(inout),dimension(:,:,:)  :: tdt, qdt, udt, vdt
   real, intent(inout),dimension(:,:,:,:):: rdt
logical, intent(out), dimension(:,:)     :: convect
   real, intent(out), dimension(:,:)     :: lprec, fprec, gust_cv
   real, intent(out), dimension(:,:,:)   :: fl_lsrain, fl_lssnow, &
                                            fl_ccrain, fl_ccsnow, &
                                            fl_donmca_rain, fl_donmca_snow
   real, intent(out), dimension(:,:,:)   :: diff_cu_mo
   real, intent(in) , dimension(:,:)     :: area
   real, intent(in) , dimension(:,:)     :: lat

   real, intent(out) , dimension(:,:,:)  :: lsc_cloud_area, lsc_liquid,&
                                            lsc_ice, lsc_droplet_number

   type(aerosol_type),intent(in),       optional :: Aerosol
   real, intent(in) , dimension(:,:,:), optional :: mask
   integer, intent(in), dimension(:,:), optional :: kbot

   logical, intent(in), optional :: hydrostatic, phys_hydrostatic
   integer, intent(inout), dimension(:,:), optional ::  nsum_out
   real, intent(inout), dimension(:,:,:), optional :: &      
                                  shallow_cloud_area, shallow_liquid,   &
                                  shallow_ice, shallow_droplet_number, &
                                  cell_cld_frac, cell_liq_amt, cell_liq_size, &
                                  cell_ice_amt, cell_ice_size, &
                                  cell_droplet_number, &
                                  meso_cld_frac, meso_liq_amt, meso_liq_size, &
                                  meso_ice_amt, meso_ice_size, &
                                  meso_droplet_number

!-----------------------------------------------------------------------
   integer :: secs, days
   integer :: n, nn, i, j, k, ix, jx, kx, nt, tr
   integer :: m, mm
   logical :: used, avgbl
   real    :: sumneg
   real    :: dtinv

   real, dimension(size(t,1),size(t,2)) :: cape, cin
   real, dimension(size(t,1),size(t,2)) :: precip, total_precip, lheat_precip, &
                                           precip_returned, precip_adjustment, &
                                           vert_motion
   real, dimension(size(t,1),size(t,2)) :: rain, snow, &
                                           rain_don, snow_don, &
                                           rain_ras, snow_ras, &
                                           rain_donmca, snow_donmca
   real, dimension(size(t,1),size(t,2)) :: bmflag, klzbs, invtaubmt, invtaubmq
   real, dimension(size(t,1),size(t,2)) :: scale
   real, dimension(size(t,1),size(t,2)) :: freq_count
   real, dimension(size(t,1),size(t,2)) :: enthint, lcondensint, enthdiffint,  &
                                           vaporint, condensint, precipint, diffint

   real, dimension(size(t,1),size(t,2),size(phalf,3)) :: rain3d, snow3d
   real, dimension(size(t,1),size(t,2),size(phalf,3)) :: snowclr3d
   real, dimension(size(t,1),size(t,2),size(t,3)+1) :: mc, m_cellup, mc_cmt


!     sfc_sh_flux      sensible heat flux across the surface
!                      [ watts / m**2 ]
!     sfc_vapor_flux   water vapor flux across the surface
!                      [ kg(h2o) / (m**2 sec) ]
!     tr_flux          tracer fux across the surface
!                      [ kg(tracer) / (m**2 sec) ]
   real, dimension(size(t,1),size(t,2)) :: sfc_sh_flux, sfc_vapor_flux
   real, dimension(size(t,1),size(t,2),num_donner_tracers) :: tr_flux  
   real, dimension(size(t,1),size(t,2),num_donner_tracers) :: &
                                                          donner_wetdep
   real, dimension(size(t,1),size(t,2),num_uw_tracers) :: &
                                                          uw_wetdep
   real, dimension(size(t,1),size(t,2),size(rdt,4)   ) :: total_wetdep
   real, dimension(size(t,1),size(t,2),size(rdt,4)   ) ::  &
                                                       total_wetdep_uw
   real, dimension(size(t,1),size(t,2),size(rdt,4)   ) ::   &
                                                     total_wetdep_donner
   real, dimension(size(t,1),size(t,2),size(rdt,4)   ) :: ls_wetdep
   real, dimension(size(t,1),size(t,2),size(t,3) ) :: total_conv_cloud,&
                           conv_cld_frac, tot_conv_liq, tot_conv_ice

!chemistry start
   real, parameter :: boltz = 1.38044e-16
   integer, dimension(size(rdt,1),size(rdt,2)) :: cldtop, cldbot
   real, dimension(size(rdt,1),size(rdt,2),size(rdt,3)) :: prod_no
   real, dimension(size(rdt,1),size(rdt,2),size(rdt,3),size(rdt,4)) :: wet_data
!chemistry end

   real, dimension(size(t,1),size(t,2))           ::  adjust_frac      
   real, dimension(size(t,1),size(t,2),size(t,3)) ::  ttnd_adjustment
   real, dimension(size(t,1),size(t,2),size(t,3)) ::  available_cf_for_uw

   logical, dimension(size(t,1),size(t,2)) :: conv_calc_completed
   logical, dimension(size(t,1),size(t,2)) :: coldT

!temporary variables
   real :: temp
   logical, dimension(size(t,1),size(t,2)) :: ltemp
   real, dimension(size(t,1),size(t,2)) :: temp_2d
   real, dimension(size(t,1),size(t,2)) :: tca2
   real, dimension(size(t,1),size(t,2),size(t,3)) :: total_cloud_area
   real, dimension(size(t,1),size(t,2),size(t,3)) :: temp_3d1, temp_3d2, temp_3d3
       

!-------- input array size and position in global storage --------------
      ix=size(t,1); jx=size(t,2); kx=size(t,3); nt=size(rdt,4)

       
!---------------------------------------------------------------------
!    verify that the module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('moist_processes_mod',  &
                 'moist_processes_init has not been called.', FATAL)
      endif

      conv_calc_completed = .false.
      available_cf_for_uw = 1.0

!--------------------------------------------------------------------
!    define the inverse of the time step.
!--------------------------------------------------------------------
      dtinv = 1.0/dt

!--------------------------------------------------------------------
!    initialize the arrays which will be used in this subroutine.
!--------------------------------------------------------------------
      rain_don     = 0.0
      snow_don     = 0.0
      rain_donmca  = 0.0
      snow_donmca  = 0.0
      lprec        = 0.0  
      fprec        = 0.0
      fl_lsrain(:,:,:) = 0.
      fl_lssnow(:,:,:) = 0.
      fl_ccrain(:,:,:) = 0.
      fl_ccsnow(:,:,:) = 0.
      fl_donmca_rain(:,:,:) = 0.
      fl_donmca_snow(:,:,:) = 0.
      convect      = .false.
      gust_cv      = 0.0
      precip       = 0.0 
      rain3d       = 0.0
      snow3d       = 0.0

!---------------------------------------------------------------------
!    initialize local arrays which will hold sums.
!---------------------------------------------------------------------
      rdt_init(is:ie,js:je,:,:)  = rdt
      tdt_init(is:ie,js:je,:)  = tdt
      qdt_init(is:ie,js:je,:)  = qdt
      ttnd_conv(is:ie,js:je,:) = 0.
      qtnd_conv(is:ie,js:je,:) = 0.
      qtnd(is:ie,js:je,:)      = 0.
      q_tnd(is:ie,js:je,:,:)     = 0.

!---------------------------------------------------------------------
!    define input fields to be used, either the tau time level fields,
!    or the tau - 1 time level values updated with the time tendencies
!    thus far calculated on the current step. control is through nml
!    variable use_tau.
!---------------------------------------------------------------------
      if (use_tau) then
        tin(is:ie,js:je,:) = t
        qin(is:ie,js:je,:) = q
        uin(is:ie,js:je,:) = u
        vin(is:ie,js:je,:) = v
        do tr=1,size(r,4)
          tracer(is:ie,js:je,:,tr) = r(:,:,:,tr)
        end do  
      else
        tin(is:ie,js:je,:) = tm + tdt*dt
        qin(is:ie,js:je,:) = qm + qdt*dt
        uin(is:ie,js:je,:) = um + udt*dt
        vin(is:ie,js:je,:) = vm + vdt*dt
        do tr=1,size(rdt,4)
          tracer(is:ie,js:je,:,tr) = rm(:,:,:,tr) + rdt(:,:,:,tr)*dt
        end do  
        do tr=size(rdt,4) +1, size(r,4)
          tracer(is:ie,js:je,:,tr) = r(:,:,:,tr)
        end do  
      endif

!--------------------------------------------------------------------
!    if using eta vertical coordinate, define the appropriate values 
!    for any points located below the ground. values of 0.0 are given
!    to u, v and q, and a temperature value of EPST (=200. K) is given 
!    to sub-surface  points.
!--------------------------------------------------------------------
      if (present(mask) .and. present(kbot))  then
        tin(is:ie,js:je,:) = mask*tin(is:ie,js:je,:) + (1.0 - mask)*EPST 
        qin(is:ie,js:je,:) = mask*qin(is:ie,js:je,:)
        uin(is:ie,js:je,:) = mask*uin(is:ie,js:je,:)
        vin(is:ie,js:je,:) = mask*vin(is:ie,js:je,:)
        do tr=1,size(r,4)
          tracer(is:ie,js:je,:,tr) = mask(:,:,:)*tracer(is:ie,js:je,:,tr)
        end do  
      endif
   
!----------------------------------------------------------------------
!    compute the mass in each model layer.
!----------------------------------------------------------------------
      do k=1,kx
        pmass(is:ie,js:je,k) = (phalf(:,:,k+1) - phalf(:,:,k))/GRAV
      end do

!----------------------------------------------------------------------
!    output any requested convectively-transported tracer fields 
!    and / or their column sums before convective transport.
!----------------------------------------------------------------------
      do n=1,num_tracers
        used = send_data (id_conv_tracer(n), tracer(is:ie,js:je,:,n), Time, &
                          is, js, 1, rmask=mask)
        if (id_conv_tracer_col(n) > 0)  &
          call column_diag(id_conv_tracer_col(n), is, js, Time, &
                           tracer(is:ie,js:je,:,n), 1.0) 
      end do

!----------------------------------------------------------------------
!    compute the mean temperature in the lower atmosphere (the lowest
!    pdepth Pa), to be used to determine whether rain or snow reaches
!    the surface. define a logical variable coldT indicating whether
!    snow or rain falls in the column.
!    ????    SHOULD TIN BE USED RATHER THAN t ??
!----------------------------------------------------------------------
      call tempavg (pdepth, phalf, t, snow, mask)
      coldT = .false.
      where (snow(:,:) <= TFREEZE)
        coldT(:,:) = .true.
      endwhere
      
!---------------------------------------------------------------------
!    begin the clock timing the dry and moist convection parameter-
!    izations.
!---------------------------------------------------------------------
      call mpp_clock_begin (convection_clock)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                   DRY CONVECTION PARAMETERIZATION
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!---------------------------------------------------------------------
!    if dry adjustment is desired call subroutine dry_adj to obtain
!    the temperature tendencie swhich must be applied to adjust each
!    column to a non-superadiabatic lapse rate. 
!---------------------------------------------------------------------
      if (do_dryadj) then
        call dry_adj (tin(is:ie,js:je,:), pfull, phalf, delta_temp(is:ie,js:je,:), mask)

!-------------------------------------------------------------------
!    add the temperature change due to dry adjustment to the current
!    temperature. convert the temperature change to a heating rate and
!    add that to the temperature temndency array accumulating the ten-
!    dencies due to all physics processes.
!-------------------------------------------------------------------
        tin(is:ie,js:je,:)  = tin(is:ie,js:je,:) + delta_temp(is:ie,js:je,:)
        ttnd(is:ie,js:je,:) = delta_temp(is:ie,js:je,:)*dtinv
        tdt  = tdt + ttnd(is:ie,js:je,:)

!---------------------------------------------------------------------
!    output the temperature tendency from dry adjustment, if desired.
!---------------------------------------------------------------------
        used = send_data (id_tdt_dadj, ttnd(is:ie,js:je,:), Time, is, js, 1, rmask=mask )

!---------------------------------------------------------------------
!    add the temperature time tendency from dry adjustment to the array
!    accumulating the total temperature time tendency from convection.
!---------------------------------------------------------------------
        ttnd_conv(is:ie,js:je,:) = ttnd_conv(is:ie,js:je,:) + ttnd(is:ie,js:je,:)
      endif


!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                  MOIST CONVECTION PARAMETERIZATIONS
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@


!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                0. UW SHALLOW CONVECTION PARAMETERIZATION
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

  cmf(is:ie,js:je,:) = 0.
  tracer_orig(is:ie,js:je,:,:) = tracer(is:ie,js:je,:,:)
  if (.not. do_donner_before_uw) then
    call mpp_clock_begin (shallowcu_clock)
    if (do_uw_conv) then
!---------------------------------------------------------------------
!    be sure all optional arguments associated with the uw_conv param-
!    eterization are present.
!---------------------------------------------------------------------
      if    &
         (present (shallow_cloud_area) .and.   &
          present (shallow_liquid) .and.   &
          present (shallow_ice) .and.  &
          present ( shallow_droplet_number) ) then
      else
       call error_mesg ('moist_processes_mod', 'moist_processes: &
              &not all 4 optional arguments needed for uw_conv &
            &output are present', FATAL)
      endif

      call moistproc_uw_conv(Time, is, ie, js, je, dt, tin(is:ie,js:je,:), qin(is:ie,js:je,:), &
                             uin(is:ie,js:je,:), vin(is:ie,js:je,:), tracer(is:ie,js:je,:,:),    &
                             pfull, phalf, zfull, zhalf, omega, pblht,        &
                             ustar, bstar, qstar, land, coldT, Aerosol,       &
                             cush, cbmf, cmf(is:ie,js:je,:), conv_calc_completed,            &
                             available_cf_for_uw, tdt, qdt, udt, vdt, rdt,    &
                             ttnd_conv(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:), lprec, fprec, precip,      &
                             liq_precflx(is:ie,js:je,:),  &
                             ice_precflx(is:ie,js:je,:), &
                             do_strat, do_limit_uw, do_liq_num, num_tracers,  &
                             tracers_in_uw, num_uw_tracers, shallow_cloud_area,&
                             shallow_liquid, shallow_ice, shallow_droplet_number, uw_wetdep)
    endif  !(do_uw_conv)
    call mpp_clock_end   (shallowcu_clock)
  else
    tin_orig(is:ie,js:je,:) = tin(is:ie,js:je,:)
    qin_orig(is:ie,js:je,:) = qin(is:ie,js:je,:)
!   tracer_orig = tracer
  endif  ! (.not do_donner_before_uw)
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                A. DONNER DEEP CONVECTION PARAMETERIZATION
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!---------------------------------------------------------------------
!    if donner_deep convection is activated, execute the following code.
!---------------------------------------------------------------------
  if (do_donner_deep) then
    call mpp_clock_begin (donner_clock)
!---------------------------------------------------------------------
!    be sure all optional arguments associated with the donner param-
!    eterization are present.
!---------------------------------------------------------------------
    if    &
      (present (cell_cld_frac) .and.   &
      present (cell_liq_amt) .and. present ( cell_liq_size) .and. &
      present (cell_ice_amt) .and. present ( cell_ice_size) .and. &
      present (cell_droplet_number) .and. &
      present (meso_cld_frac) .and.   &
      present (meso_liq_amt) .and. present ( meso_liq_size) .and. &
      present (meso_ice_amt) .and. present ( meso_ice_size) .and. &
      present (meso_droplet_number) .and. &
      present (nsum_out) ) then
    else
      call error_mesg ('moist_processes_mod', 'moist_processes: &
              &not all 13 optional arguments needed for donner_deep &
              &output are present', FATAL)
    endif

!--------------------------------------------------------------------
!    if strat_cloud_mod is activated, define the cloud liquid and 
!    cloud ice specific humidities and cloud area associated with 
!    strat_cloud_mod, so that they may be input to donner_deep_mod. 
!    if strat_cloud_mod is not activated, define these arrays to be 
!    zero. 
!--------------------------------------------------------------------
    if (do_strat) then
      qlin(is:ie,js:je,:) = tracer(is:ie,js:je,:,nql)
      qiin(is:ie,js:je,:) = tracer(is:ie,js:je,:,nqi)
      qain(is:ie,js:je,:) = tracer(is:ie,js:je,:,nqa)
    endif

!--------------------------------------------------------------------
!    convert vapor specific humidity to vapor mixing ratio so it may
!    be input to donner_deep_mod.
!--------------------------------------------------------------------
    rin(is:ie,js:je,:) = qin(is:ie,js:je,:)/(1.0 - qin(is:ie,js:je,:))

!---------------------------------------------------------------------
!    if any tracers are to be transported by donner convection, 
!    check each active tracer to find those to be transported and fill 
!    the donner_tracers array with these fields.
!---------------------------------------------------------------------
    donner_tracer(is:ie,js:je,:,:) = 0.0
    nn = 1
    do n=1,num_tracers
      if (tracers_in_donner(n)) then
        donner_tracer(is:ie,js:je,:,nn) = tracer(is:ie,js:je,:,n)
        nn = nn + 1
      endif
    end do

!---------------------------------------------------------------------
!  NOTE 1: sfc_sh_flux, sfc_vapor_flux, tr_flux are the surface fluxes
!          that will have been obtained from the flux exchange module
!          and passed on to moist_processes and then to donner_deep.
!          FOR NOW, these values are defined herein, and given
!          values of 0.0
!---------------------------------------------------------------------
!   sfc_sh_flux    = INPUT_SFC_SH_FLUX_FROM_COUPLER
!   sfc_vapor_flux = INPUT_SFC_VAPOR_FLUX_FROM_COUPLER
    sfc_sh_flux    = 0.0
    sfc_vapor_flux = 0.0
    tr_flux        = 0.0
    nn = 1
    do n=1,num_tracers
      if (tracers_in_donner(n)) then
!       tr_flux(:,:,nn) = INPUT_SFC_FLUX_FROM_COUPLER(:,:,n)
        tr_flux(:,:,nn) = 0.0                                 
        nn = nn + 1
      endif
    end do
    temp_2d=pblht
    temp_2d=min(max(temp_2d, 0.0),5000.);
    temp_2d=ustar**3.+0.6*ustar*bstar*temp_2d
    where (temp_2d .gt. 0.)
      temp_2d = temp_2d**(2./3.)
    end where
    temp_2d = MAX (1.e-6, temp_2d)

!---------------------------------------------------------------------
!    call donner_deep to compute the effects of deep convection on the 
!    temperature, vapor mixing ratio, tracers, cloud liquid, cloud ice
!    cloud area and precipitation fields.
!---------------------------------------------------------------------
    call get_time (Time, secs, days)
    if (do_strat) then
      call donner_deep (is, ie, js, je, dt, tin(is:ie,js:je,:), rin(is:ie,js:je,:), pfull,        &
                        phalf, zfull, zhalf, omega, pblht, temp_2d, &
                        qstar, cush, coldT, land, sfc_sh_flux,      &!miz
                        sfc_vapor_flux, tr_flux,                    &
                        donner_tracer(is:ie,js:je,:,:), secs, days, cbmf,            &
                        cell_cld_frac, cell_liq_amt, cell_liq_size, &
                        cell_ice_amt, cell_ice_size,                &
                        cell_droplet_number,                        &
                        meso_cld_frac, meso_liq_amt, meso_liq_size, &
                        meso_ice_amt, meso_ice_size,                &
                        meso_droplet_number, nsum_out,              &
                        precip_returned, delta_temp(is:ie,js:je,:), delta_vapor(is:ie,js:je,:),   &
                        m_cdet_donner(is:ie,js:je,:), m_cellup, mc_donner(is:ie,js:je,:),         &
                        mc_donner_up(is:ie,js:je,:), mc_donner_half(is:ie,js:je,:), &
                        donner_humidity_area(is:ie,js:je,:), donner_humidity_factor(is:ie,js:je,:),&
                        qtr(is:ie,js:je,:,:),  &
                        donner_wetdep, &
                        lheat_precip, vert_motion,             &
                        total_precip, liquid_precip(is:ie,js:je,:), frozen_precip(is:ie,js:je,:), &
                     frz_meso(is:ie,js:je,:), liq_meso(is:ie,js:je,:), &
                  frz_cell(is:ie,js:je,:), liq_cell(is:ie,js:je,:), &
                        qlin(is:ie,js:je,:), qiin(is:ie,js:je,:), qain(is:ie,js:je,:), delta_ql(is:ie,js:je,:),                 &!optional
                        delta_qi(is:ie,js:je,:), delta_qa(is:ie,js:je,:))                          !optional
    else
      call donner_deep (is, ie, js, je, dt, tin(is:ie,js:je,:), rin(is:ie,js:je,:), pfull,        &
                        phalf, zfull, zhalf, omega, pblht, temp_2d, &
                        qstar, cush, coldT, land, sfc_sh_flux,      &!miz
                        sfc_vapor_flux, tr_flux,                    &
                        donner_tracer(is:ie,js:je,:,:), secs, days,  cbmf,           &
                        cell_cld_frac, cell_liq_amt, cell_liq_size, &
                        cell_ice_amt, cell_ice_size,                &
                        cell_droplet_number,                        &
                        meso_cld_frac, meso_liq_amt, meso_liq_size, &
                        meso_ice_amt, meso_ice_size,                &
                        meso_droplet_number, nsum_out,              &
                        precip_returned, delta_temp(is:ie,js:je,:), delta_vapor(is:ie,js:je,:),   &
                        m_cdet_donner(is:ie,js:je,:), m_cellup, mc_donner(is:ie,js:je,:),         &
                        mc_donner_up(is:ie,js:je,:), mc_donner_half(is:ie,js:je,:), &
                        donner_humidity_area(is:ie,js:je,:), donner_humidity_factor(is:ie,js:je,:),&
                        qtr(is:ie,js:je,:,:), donner_wetdep, &
                        lheat_precip, vert_motion,             &
                        total_precip, liquid_precip(is:ie,js:je,:), &
                        frozen_precip(is:ie,js:je,:), &
                frz_meso(is:ie,js:je,:), liq_meso(is:ie,js:je,:),  &
                frz_cell(is:ie,js:je,:), liq_cell(is:Ie,js:je,:))
    endif

!---------------------------------------------------------------------
!    update the current timestep tracer changes with the contributions 
!    just obtained from donner transport.
!---------------------------------------------------------------------
    nn = 1
    do n=1, num_tracers
      if (tracers_in_donner(n)) then
        rdt(:,:,:,n) = rdt(:,:,:,n) + qtr(is:ie,js:je,:,nn)
        nn = nn + 1
      endif
    end do

    if (do_donner_conservation_checks) then
      vaporint = 0.
      lcondensint = 0.
      condensint = 0.
      diffint = 0.
      enthint = 0.
      enthdiffint = 0.
    
      do k=1,kx
        vaporint(:,:) = vaporint(:,:) + pmass (is:ie,js:je,k)*delta_vapor(is:ie,js:je,k)
        enthint(:,:) = enthint(:,:) + CP_AIR*pmass(is:ie,js:je,k)*delta_temp(is:ie,js:je,k)
        condensint(:,:) = condensint(:,:) + pmass(is:ie,js:je,k) *  &
                         (delta_ql(is:ie,js:je,k) + delta_qi(is:ie,js:je,k))
        lcondensint(:,:) = lcondensint(:,:) + pmass(is:ie,js:je,k) *  &
                         (HLV*delta_ql(is:ie,js:je,k) + HLS*delta_qi(is:ie,js:je,k))
      end do
      precipint = total_precip/seconds_per_day
      diffint = (vaporint + condensint)*dtinv  + precipint
      enthdiffint = (enthint - lcondensint)*dtinv -    &
                   lheat_precip/seconds_per_day - vert_motion/seconds_per_day 
      do j=1,size(enthdiffint,2)
       do i=1,size(enthdiffint,1)
         max_enthalpy_imbal_don(i,j) = max( abs(enthdiffint(i,j)), &
                                         max_enthalpy_imbal_don(i,j) )
         max_water_imbal_don(i,j) = max( abs(diffint(i,j)), &
                                         max_water_imbal_don(i,j) )
       end do
      end do

      used = send_data(id_max_enthalpy_imbal_don, max_enthalpy_imbal_don, Time, is, js)
      used = send_data(id_max_water_imbal_don, max_water_imbal_don, Time, is, js)
      used = send_data(id_vaporint, vaporint*dtinv, Time, is, js)
      used = send_data(id_condensint, condensint*dtinv, Time, is, js)
      used = send_data(id_vertmotion, vert_motion/seconds_per_day, Time, is, js)
      used = send_data(id_precipint, precipint, Time, is, js)
      used = send_data(id_diffint, diffint, Time, is, js)
      used = send_data(id_enthint, enthint*dtinv, Time, is, js)
      used = send_data(id_lcondensint, lcondensint*dtinv, Time, is, js)
      used = send_data(id_lprcp, lheat_precip/seconds_per_day, Time, is, js)
      used = send_data(id_enthdiffint, enthdiffint, Time, is, js)
    endif

!--------------------------------------------------------------------
!    obtain updated vapor specific humidity (qnew) resulting from deep 
!    convection. define the vapor specific humidity change due to deep 
!    convection (qtnd).
!--------------------------------------------------------------------
    do k=1,kx
     do j=js,je
      do i=is,ie
        if (delta_vapor(i,j,k) /= 0.0) then
!was qnew... now temp
          temp = (rin(i,j,k) + delta_vapor(i,j,k))/   &
                 (1.0 + (rin(i,j,k) + delta_vapor(i,j,k)))
          delta_q(i,j,k) = temp - qin(i,j,k)
        else
          delta_q(i,j,k) = 0.
        endif
      enddo
     enddo
    end do

!---------------------------------------------------------------------
!    scale Donner tendencies to prevent the formation of negative
!    total water specific humidities
!---------------------------------------------------------------------
    if (do_strat .and. do_limit_donner) then
      call moistproc_scale_donner(is,ie,js,je,qin(is:ie,js:je,:), delta_temp(is:ie,js:je,:), delta_q(is:ie,js:je,:), &
                                  precip_returned, total_precip, lheat_precip, liquid_precip(is:ie,js:je,:),    &
                                  frozen_precip(is:ie,js:je,:), num_tracers, tracers_in_donner,&
                                  qtr(is:ie,js:je,:,:), scale)
      used = send_data (id_scale_donner, scale, Time, is, js )
    else
      scale = 1.0
      used = send_data (id_scale_donner, scale, Time, is, js )
    end if ! (do_strat and do_limit_donner)

!---------------------------------------------------------------------
!    recalculate the precip using the delta specific humidity tenden-
!    cies. define precip_adjustment as the change in precipitation 
!    resulting from the recalculation.
!---------------------------------------------------------------------
    if (force_donner_moist_conserv) then
!---------------------------------------------------------------------
!    calculate the precipitation needed to balance the change in water
!    content in the column.
!---------------------------------------------------------------------
      temp_2d = 0.
      do k=1,kx
        temp_2d (:,:) = temp_2d (:,:) + (-delta_q(is:ie,js:je,k) -  &
                        delta_ql(is:ie,js:je,k) -delta_qi(is:ie,js:je,k))*  &
                        pmass(is:ie,js:je,k)
      end do
      precip_adjustment = (temp_2d - precip_returned)
      do j=1,jx
       do i=1,ix
         if (ABS(precip_adjustment(i,j)) < 1.0e-10) then
           precip_adjustment (i,j) = 0.0
         endif
       end do
      end do
!----------------------------------------------------------------------
!    now adjust the temperature change to balance the precip adjustment
!    and so conserve enthalpy in the column.
!--------------------------------------------------------------------- 
      do j=1,jx
       do i=1,ix
         if (precip_returned(i,j) > 0.0) then
           adjust_frac(i,j) = precip_adjustment(i,j)/precip_returned(i,j)
         else
           adjust_frac(i,j) = 0.
         endif
       end do
      end do
      do k=1,kx
        ttnd_adjustment(:,:,k) = &
                      ((HLV*liquid_precip(is:ie,js:je,k)*adjust_frac(:,:) + &
                        HLS*frozen_precip(is:ie,js:je,k)*adjust_frac(:,:))  &
                       *dt/seconds_per_day)/CP_AIR
        liquid_precip(is:ie,js:je,k) = liquid_precip(is:ie,js:je,k) * (1.0+adjust_frac(:,:))
        frozen_precip(is:ie,js:je,k) = frozen_precip(is:ie,js:je,k) * (1.0+adjust_frac(:,:))
      end do
    else ! (force_donner_moist_conserv)
      precip_adjustment(:,:) = 0.0
      adjust_frac      (:,:) = 0.0
      ttnd_adjustment(:,:,:) = 0.
    endif  ! (force_donner_moist_conserv)

    do k=1,kx
      rain_don(:,:) = rain_don(:,:) + liquid_precip(is:ie,js:je,k)* pmass(is:ie,js:je,k)/seconds_per_day
      snow_don(:,:) = snow_don(:,:) + frozen_precip(is:ie,js:je,k)* pmass(is:ie,js:je,k)/seconds_per_day
    end do

!----------------------------------------------------------------------
!   modify each of the 3d precip fluxes returned from donner_deep, as
!   needed.
!----------------------------------------------------------------------
    if (do_cosp) then
      do k=1, size(t,3)
        do j=js,je 
          do i=is,ie 
            frz_meso(i,j,k) = frz_meso(i,j,k)*pmass(i,j,k)* &
                              scale(i-is+1,j-js+1)*(1.0+adjust_frac(i-is+1,j-js+1))/ &
                                                       SECONDS_PER_DAY
            liq_meso(i,j,k) = liq_meso(i,j,k)*pmass(i,j,k)* &
                              scale(i-is+1,j-js+1)*(1.0+adjust_frac(i-is+1,j-js+1))/ &
                                                       SECONDS_PER_DAY
            frz_cell(i,j,k) = frz_cell(i,j,k)*pmass(i,j,k)* &
                              scale(i-is+1,j-js+1)*(1.0+adjust_frac(i-is+1,j-js+1))/ &
                                                        SECONDS_PER_DAY
            liq_cell(i,j,k) = liq_cell(i,j,k)*pmass(i,j,k)* &
                              scale(i-is+1,j-js+1)*(1.0+adjust_frac(i-is+1,j-js+1))/ &
                                                        SECONDS_PER_DAY
          end do
        end do
      end do
    endif
    
    if (only_one_conv_scheme_per_column) then
      conv_calc_completed = (rain_don + snow_don) > 0.0
    endif
!---------------------------------------------------------------------
!    convert the changes in temperature, vapor specific humidity and 
!    precipitation resulting from deep convection to time tendencies 
!    of these quantities.
!---------------------------------------------------------------------
    ttnd_don(is:ie,js:je,:) = delta_temp(is:ie,js:je,:)*dtinv 
    ttnd_don(is:ie,js:je,:) = ttnd_don(is:ie,js:je,:) + ttnd_adjustment*dtinv
    qtnd_don(is:ie,js:je,:) = delta_q(is:ie,js:je,:)*dtinv

!--------------------------------------------------------------------
!    save the tendencies of temperature and specific humidity resulting
!    from the deep convection component of the donner parameterization. 
!--------------------------------------------------------------------
    ttnd_conv(is:ie,js:je,:) = ttnd_conv(is:ie,js:je,:) + ttnd_don(is:ie,js:je,:)
    qtnd_conv(is:ie,js:je,:) = qtnd_conv(is:ie,js:je,:) + qtnd_don(is:ie,js:je,:)

!--------------------------------------------------------------------
!    add the contributions to the temperature and vapor specific 
!    humidity tendencies from donner_deep mod to the arrays accumulating
!    the total tendencies due to all physics processes.
!--------------------------------------------------------------------
    tdt = tdt + ttnd_don(is:ie,js:je,:) 
    qdt = qdt + qtnd_don(is:ie,js:je,:)

!--------------------------------------------------------------------
!    add the liquid (rain) and frozen (snow) precipitation generated by
!    deep convection on this step to the arrays accumulating precip-
!    itation from all sources (lprec, fprec).
!--------------------------------------------------------------------
    lprec  = lprec + rain_don
    fprec  = fprec + snow_don

!--------------------------------------------------------------------
!    output the time tendencies of temperature, vapor specific humid-
!    ity, precipitation and mass flux due to deep convection.
!--------------------------------------------------------------------
    used = send_data (id_tdt_deep_donner, ttnd_don(is:ie,js:je,:), Time, is, js, 1, rmask=mask )
    used = send_data (id_qdt_deep_donner, qtnd_don(is:ie,js:je,:), Time, is, js, 1, rmask=mask )
    used = send_data (id_qadt_deep_donner, delta_qa(is:ie,js:je,:)*dtinv, Time, is, js, 1, rmask=mask )
    used = send_data (id_qldt_deep_donner, delta_ql(is:ie,js:je,:)*dtinv, Time, is, js, 1, rmask=mask )
    used = send_data (id_qidt_deep_donner, delta_qi(is:ie,js:je,:)*dtinv, Time, is, js, 1, rmask=mask )
    used = send_data (id_mc_donner, mc_donner(is:ie,js:je,:), Time, is, js, 1, rmask=mask )
    used = send_data (id_mc_donner_half, mc_donner_half(is:ie,js:je,:), Time, is, js, 1, rmask=mask )
    used = send_data (id_m_cdet_donner, m_cdet_donner(is:ie,js:je,:), Time,  is, js, 1, rmask=mask )
    used = send_data (id_m_cellup, m_cellup, Time, is, js, 1, rmask=mask )
    used = send_data (id_snow_deep_donner, snow_don, Time, is, js)
    used = send_data (id_prec_deep_donner, rain_don + snow_don, Time, is, js )
    used = send_data (id_prec1_deep_donner, precip_adjustment,  &
                         Time, is, js, mask = precip_returned > 0.0)

    if (do_donner_conservation_checks) then
      used = send_data (id_enth_donner_col2, -hlv*rain_don, Time, is, js)
      used = send_data (id_enth_donner_col3, -hls*snow_don, Time, is, js)
      if (id_enth_donner_col4 > 0) call column_diag(id_enth_donner_col4, is, js, Time, &
                                        ttnd_don(is:ie,js:je,:), CP_AIR)
      if (id_enth_donner_col5 > 0) call column_diag(id_enth_donner_col5, is, js, Time, &
                                        delta_ql(is:ie,js:je,:), -HLV*dtinv, delta_qi(is:ie,js:je,:), -HLS*dtinv)
      if (id_enth_donner_col6 > 0) call column_diag(id_enth_donner_col6, is, js, Time, &
                                        ttnd_adjustment, CP_AIR)
      used = send_data (id_enth_donner_col7, adjust_frac, Time, is, js)
       
      temp_2d = 0.
      do k=1,kx
        temp_2d(:,:) = temp_2d(:,:)  &
             + (-HLV*liquid_precip(is:ie,js:je,k)/seconds_per_day -  &
                hls*frozen_precip(is:ie,js:je,k)/seconds_per_day  + &
                CP_AIR*ttnd_don(is:ie,js:je,k)  &
             -  (HLV*delta_ql(is:ie,js:je,k)*dtinv + HLS*delta_qi(is:ie,js:je,k)*dtinv)  &
                )*pmass(is:ie,js:je,k)
      end do
      used = send_data (id_enth_donner_col, temp_2d, Time, is, js)

      if (id_wat_donner_col > 0) then
        temp_2d = rain_don + snow_don
        call column_diag(id_wat_donner_col, is, js, Time, qtnd_don(is:ie,js:je,:), 1.0, &
                         delta_ql(is:ie,js:je,:), dtinv, delta_qi(is:ie,js:je,:), dtinv, temp_2d)
      endif
    endif ! (donner_conservation_checks)

    call mpp_clock_end (donner_clock)

    if (do_donner_mca) then
      call mpp_clock_begin (donner_mca_clock)
!--------------------------------------------------------------------
!    call subroutine moist_conv to handle any shallow convection 
!    present in the grid. in this call do_strat is always set to .false.
!    so that no convective detrainment (and corresponding change in
!    large-scale cloud amount and area) from moist convective adjustment
!    is allowed, consistent with this call being constrained to handle
!    shallow convection.
!--------------------------------------------------------------------
      tin(is:ie,js:je,:) = tin(is:ie,js:je,:)+delta_temp(is:ie,js:je,:)
      qin(is:ie,js:je,:) = qin(is:ie,js:je,:)+delta_q(is:ie,js:je,:)
      call moist_conv (tin(is:ie,js:je,:), qin(is:ie,js:je,:), pfull, phalf, coldT, &
                       ttnd_don(is:ie,js:je,:), qtnd_don(is:ie,js:je,:), &
                       rain_donmca, snow_donmca, dtinv, Time, is, js,     &
                       donner_tracer(is:ie,js:je,:,:), qtr(is:ie,js:je,:,:), Lbot=kbot, mask=mask)           

      if (include_donmca_in_cosp) then
        do j=js,je
          do i=is,ie
            if (coldT(i-is+1,j-js+1)) then
              do k=1,kx
                mca_frz(i,j,k) = -1.0*qtnd_don(i,j,k)*pmass(i,j,k)
                mca_liq(i,j,k) = 0.
              end do
            else
              do k=1,kx
                mca_frz(i,j,k) = 0.
                mca_liq(i,j,k) = -1.0*qtnd_don(i,j,k)*pmass(i,j,k)
              end do
            endif
          end do
        end do
      else
        mca_frz(is:ie,js:je,:) = 0.
        mca_liq(is:ie,js:je,:) = 0.
      endif
!---------------------------------------------------------------------
!    update the current tracer tendencies with the contributions 
!    just obtained from moist convective adjustment. currently there
!    is no tracer transport by this process.
!---------------------------------------------------------------------
      nn = 1
      do n=1, num_tracers
        if (tracers_in_donner(n)) then
          rdt(:,:,:,n) = rdt(:,:,:,n) + qtr(is:ie,js:je,:,nn)
          nn = nn + 1
        endif
      end do

!--------------------------------------------------------------------
!    define the heating, moistening and precipitation rates as the sum 
!    of the contributions from the deep convection pass and the moist 
!    convective adjustment pass of the donner parameterization. if 
!    ras_mod is also activated, store these values in temporary arrays
!    until the contributions from ras_mod is calculated.
!--------------------------------------------------------------------
      ttnd_conv(is:ie,js:je,:) = ttnd_conv(is:ie,js:je,:) + ttnd_don(is:ie,js:je,:)
      qtnd_conv(is:ie,js:je,:) = qtnd_conv(is:ie,js:je,:) + qtnd_don(is:ie,js:je,:)

!--------------------------------------------------------------------
!    add the contributions to the temperature and vapor specific 
!    humidity tendencies from the moist convective adjustment pass of
!    donner_deep_mod to the arrays accumulating the total tendencies 
!    due to all physics processes.
!--------------------------------------------------------------------
      tdt = tdt + ttnd_don(is:ie,js:je,:)
      qdt = qdt + qtnd_don(is:ie,js:je,:)

!--------------------------------------------------------------------
!    add the liquid (rain) and frozen (snow) precipitation generated by
!    the moist convective adjustment pass of the donner parameterization
!    on this step to the arrays accumulating precipitation from all 
!    sources (lprec, fprec).
!--------------------------------------------------------------------
      lprec  = lprec + rain_donmca
      fprec  = fprec + snow_donmca

!--------------------------------------------------------------------
!    output the time tendencies of temperature, vapor specific humid-
!    ity, precipitation and snow due to the moist convective 
!    adjustment pass of the donner parameterization.
!--------------------------------------------------------------------
      used = send_data (id_tdt_mca_donner, ttnd_don(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
      used = send_data (id_qdt_mca_donner, qtnd_don(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
      used = send_data (id_prec_mca_donner, rain_donmca+snow_donmca, Time, is, js) 
      used = send_data (id_snow_mca_donner, snow_donmca, Time, is, js)

      if (id_enth_mca_donner_col > 0) then
        temp_2d = -HLV*rain_donmca -HLS*snow_donmca
        call column_diag(id_enth_mca_donner_col, is, js, Time, ttnd_don(is:ie,js:je,:), CP_AIR, temp_2d)
      endif

      if (id_wat_mca_donner_col > 0) then
        temp_2d = rain_donmca + snow_donmca
        call column_diag(id_wat_mca_donner_col, is, js, Time, qtnd_don(is:ie,js:je,:), 1.0, temp_2d)
      endif

!--------------------------------------------------------------------
!------- diagnostics for tracers from convection -------
!  allow any tracer to be activated here (allows control cases)
!--------------------------------------------------------------------
      do n=1,num_tracers
        used = send_data ( id_conv_tracer(n), tracer(is:ie,js:je,:,n), Time, is, js, 1, &
                           rmask=mask )
!------- diagnostics for tracers column integral tendency ------
        if ( id_conv_tracer_col(n) > 0 ) &
          call column_diag(id_conv_tracer_col(n), is, js, Time, tracer(is:ie,js:je,:,n), 1.0)
      enddo

!--------------------------------------------------------------------
!    output the time tendencies of tracer and of column tracer 
!    due to the moist convective adjustment pass of the donner 
!    parameterization. currently moist convective adjustment does not
!    affect the tracer fields, so these fields are always 0.0.
!--------------------------------------------------------------------
      do n = 1, num_donner_tracers
        if ( id_tracerdt_mcadon(n) > 0 ) &
          used = send_data(id_tracerdt_mcadon(n), qtr(is:ie,js:je,:,n), Time, is, js, 1, rmask=mask )
        if (id_tracerdt_mcadon_col(n) > 0 )  &
          call column_diag(id_tracerdt_mcadon_col(n), is, js, Time, qtr(is:ie,js:je,:,n), 1.0)
      enddo

      call mpp_clock_end (donner_mca_clock)
    endif !(do_donner_mca) 

!---------------------------------------------------------------------
!    if donner_deep_mod is not active, define input fields normally 
!    produced by donner_deep_mod and needed by strat_cloud_mod 
!    appropriately.
!---------------------------------------------------------------------
  else   ! (do_donner_deep)
    mc_donner(is:ie,js:je,:) = 0.0
    mc_donner_up(is:ie,js:je,:) = 0.0
    mc_donner_half(is:ie,js:je, : ) = 0.0
    m_cdet_donner(is:ie,js:je,:) = 0.0
    m_cellup = 0.0
    donner_humidity_area(is:ie,js:je,:) = 0.
    donner_humidity_factor(is:ie,js:je,:) = 0.
  endif  ! (do_donner_deep)
! ADD TENDENCIES HERE, IN SAME AORDER AS ORIGINAL:
  if (do_donner_deep) then
    if (limit_conv_cloud_frac) then
      ltemp = ANY(donner_humidity_area(is:ie,js:je,:) >= 0.999, dim = 3)
      where (ltemp(:,:)) conv_calc_completed(:,:) = .true.
      available_cf_for_uw = MAX(0.999 - donner_humidity_area(is:ie,js:je,:), 0.0)
    endif

    if (do_strat) then
      tracer(is:ie,js:je,:,nql) = qlin(is:ie,js:je,:) + delta_ql(is:ie,js:je,:)
      tracer(is:ie,js:je,:,nqi) = qiin(is:ie,js:je,:) + delta_qi(is:ie,js:je,:)
      tracer(is:ie,js:je,:,nqa) = qain(is:ie,js:je,:) + delta_qa(is:ie,js:je,:)
      rdt(:,:,:,nql) = rdt(:,:,:,nql) + delta_ql(is:ie,js:je,:)*dtinv
      rdt(:,:,:,nqi) = rdt(:,:,:,nqi) + delta_qi(is:ie,js:je,:)*dtinv
      rdt(:,:,:,nqa) = rdt(:,:,:,nqa) + delta_qa(is:ie,js:je,:)*dtinv
    endif

!---------------------------------------------------------------------
!    update the values of temperature and vapor specific humidity to
!    include the effects of deep convection.
!---------------------------------------------------------------------
    if (.not. do_donner_mca) then
      tin(is:ie,js:je,:) = tin(is:ie,js:je,:) + delta_temp(is:ie,js:je,:)
      qin(is:ie,js:je,:) = qin(is:ie,js:je,:) + delta_q(is:ie,js:je,:)
    endif
  endif !(do_donner_deep)

  if (do_donner_before_uw) then
    if (do_uw_conv) then
      call mpp_clock_begin (shallowcu_clock)
!---------------------------------------------------------------------
!    be sure all optional arguments associated with the uw_conv param-
!    eterization are present.
!---------------------------------------------------------------------
      if    &
        (present (shallow_cloud_area) .and.   &
         present (shallow_liquid) .and.   &
         present (shallow_ice) .and.  &
         present ( shallow_droplet_number) ) then
      else
        call error_mesg ('moist_processes_mod', 'moist_processes: &
               &not all 4 optional arguments needed for uw_conv &
               &output are present', FATAL)
      endif

      if (use_updated_profiles_for_uw) then 
!---------------------------------------------------------------------
!    update tracer fields with tendencies due to donner convection and 
!    wet deposition by donner deep precipitation.
!---------------------------------------------------------------------
        do n=1,size(rdt,4)
          if (n /= nsphum) then
            if (.not. do_strat .or. ( n /= nql .and. n /= nqi .and.   &
                 n /= nqa .and. n /= nqn) ) then
              tracer(is:ie,js:je,:,n) = tracer_orig(is:ie,js:je,:,n) +   &
                             (rdt(:,:,:,n) - rdt_init(is:ie,js:je,:,n)) *dt
            endif
          endif
        end do
        call moistproc_uw_conv(Time, is, ie, js, je, dt, tin(is:ie,js:je,:), qin(is:ie,js:je,:), &
                               uin(is:ie,js:je,:), vin(is:ie,js:je,:), tracer(is:ie,js:je,:,:),    &
                               pfull, phalf, zfull, zhalf, omega, pblht,        &
                               ustar, bstar, qstar, land, coldT, Aerosol,       &
                               cush, cbmf, cmf(is:ie,js:je,:), conv_calc_completed,            &
                               available_cf_for_uw, tdt, qdt, udt, vdt, rdt,    &
                               ttnd_conv(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:), lprec, fprec, precip,      &
                               liq_precflx(is:ie,js:je,:),  &
                               ice_precflx(is:ie,js:je,:), &
                               do_strat, do_limit_uw, do_liq_num, num_tracers,  &
                               tracers_in_uw, num_uw_tracers, shallow_cloud_area,&
                               shallow_liquid, shallow_ice, shallow_droplet_number, uw_wetdep)
      else ! (.not. use_updated_profiles_for_uw)
        call moistproc_uw_conv(Time, is, ie, js, je, dt, tin_orig(is:ie,js:je,:), qin_orig(is:ie,js:je,:), &
                               uin(is:ie,js:je,:), vin(is:ie,js:je,:), tracer_orig(is:ie,js:je,:,:),    &
                               pfull, phalf, zfull, zhalf, omega, pblht,        &
                               ustar, bstar, qstar, land, coldT, Aerosol,       &
                               cush, cbmf, cmf(is:ie,js:je,:), conv_calc_completed,            &
                               available_cf_for_uw, tdt, qdt, udt, vdt, rdt,    &
                               ttnd_conv(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:), lprec, fprec, precip,      &
                               liq_precflx(is:ie,js:je,:),  &
                               ice_precflx(is:ie,js:je,:), &
                               do_strat, do_limit_uw, do_liq_num, num_tracers,  &
                               tracers_in_uw, num_uw_tracers, shallow_cloud_area,&
                               shallow_liquid, shallow_ice, shallow_droplet_number, uw_wetdep)
      endif ! (use_updated_profiles_for_uw)
      call mpp_clock_end (shallowcu_clock)
    endif !(do_uw_conv)
  endif !(do_donner_before_uw)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                B. MOIST CONVECTIVE ADJUSTMENT             
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
   if (do_mca) then
     call mpp_clock_begin (mca_clock)
     call moistproc_mca(Time, is, js, tin(is:ie,js:je,:), qin(is:ie,js:je,:), tracer(is:ie,js:je,:,:), pfull, phalf, coldT, dtinv, &
                        tdt, qdt, rdt, q_tnd(is:ie,js:je,:,:), ttnd_conv(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:),                 &
                        lprec, fprec, do_strat, num_tracers, tracers_in_mca,        &
                        num_mca_tracers, kbot, mask)
     call mpp_clock_end (mca_clock)
   endif ! (do_mca)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!           X. BETTS-MILLER CONVECTION SCHEME 
!			
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

   if ( any((/do_bm,do_bmmass,do_bmomp/)) ) then
     call mpp_clock_begin (bm_clock)

     if (do_bm) then ! betts-miller cumulus param scheme
       call betts_miller (dt,tin(is:ie,js:je,:),qin(is:ie,js:je,:),pfull,phalf,coldT,rain,snow,&
                         ttnd(is:ie,js:je,:),qtnd(is:ie,js:je,:), &
                         q_ref(is:ie,js:je,:),bmflag,klzbs,cape,cin,t_ref(is:ie,js:je,:),invtaubmt,       &
                         invtaubmq, mask=mask)
     endif

     if (do_bmmass) then ! betts-miller-style massflux cumulus param scheme
       call bm_massflux (dt,tin(is:ie,js:je,:),qin(is:ie,js:je,:),pfull,phalf,coldT,rain,snow,&
                         ttnd(is:ie,js:je,:),qtnd(is:ie,js:je,:),  &
                         q_ref(is:ie,js:je,:),bmflag,klzbs,t_ref(is:ie,js:je,:),massflux(is:ie,js:je,:), mask=mask)
     endif

     if (do_bmomp) then ! olivier's betts-miller cumulus param scheme
       call bm_omp (dt,tin(is:ie,js:je,:),qin(is:ie,js:je,:),pfull,phalf,coldT,rain,snow,&
                    ttnd(is:ie,js:je,:),qtnd(is:ie,js:je,:),       &
                    q_ref(is:ie,js:je,:),bmflag,klzbs,t_ref(is:ie,js:je,:), mask=mask)
     endif

!------- (update input values and) compute tendency -----
     tin(is:ie,js:je,:)=tin(is:ie,js:je,:)+ttnd(is:ie,js:je,:)
     qin(is:ie,js:je,:)=qin(is:ie,js:je,:)+qtnd(is:ie,js:je,:)
     ttnd(is:ie,js:je,:)=ttnd(is:ie,js:je,:)*dtinv
     qtnd(is:ie,js:je,:)=qtnd(is:ie,js:je,:)*dtinv
     rain=rain*dtinv
     snow=snow*dtinv
                                                                                   
!-------- add on tendency ----------
     tdt=tdt+ttnd(is:ie,js:je,:) 
     qdt=qdt+qtnd(is:ie,js:je,:)

!------- save total precip and snow ---------
     lprec=lprec+rain
     fprec=fprec+snow
     precip=precip+rain+snow
                                                                         
!------- compute rh clouds if desired ------
     if (do_rh_clouds) then
!calculate relative humidity
       call rh_calc(pfull,tin(is:ie,js:je,:),qin(is:ie,js:je,:),RH(is:ie,js:je,:),do_simple,mask)
!pass RH to rh_clouds_sum
       call rh_clouds_sum (is, js, RH(is:ie,js:je,:)) ! XXX  RH is not relative humidity when do_simple=.true.
     end if

! betts-miller diags
     used = send_data (id_tref, t_ref(is:ie,js:je,:), Time, is, js, 1, rmask=mask )
     used = send_data (id_qref, q_ref(is:ie,js:je,:), Time, is, js, 1, rmask=mask )
     used = send_data (id_bmflag, bmflag, Time, is, js)
     used = send_data (id_klzbs, klzbs, Time, is, js)
     used = send_data (id_invtaubmt, invtaubmt, Time, is, js)
     used = send_data (id_invtaubmq, invtaubmq, Time, is, js)
     used = send_data (id_massflux, massflux(is:ie,js:je,:), Time, is, js, 1, rmask=mask)

     call mpp_clock_end (bm_clock)
   endif ! if ( any((/do_bm,do_bmmass,do_bmomp/)) )


!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!           C. RELAXED ARAKAWA-SCHUBERT PARAMETERIZATION
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!-----------------------------------------------------------------------
!    execute relaxed arakawa/schubert cumulus parameterization scheme,
!    if desired.
!-----------------------------------------------------------------------
   if (do_ras) then
     call mpp_clock_begin (ras_clock)
     call moistproc_ras(Time, is, js, dt, coldT, tin(is:ie,js:je,:), qin(is:ie,js:je,:), uin(is:ie,js:je,:), vin(is:ie,js:je,:), &
                        tracer(is:ie,js:je,:,:), pfull, phalf, zhalf, tdt, qdt, udt, vdt, rdt,       &
                        q_tnd(is:ie,js:je,:,:), ttnd(is:ie,js:je,:), qtnd(is:ie,js:je,:), &
                        ttnd_conv(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:), mc, det0(is:ie,js:je,:),  &
                        lprec, fprec, rain_ras, snow_ras, rain3d, snow3d,   &
                        Aerosol, do_strat, do_liq_num, num_tracers,         &
                        tracers_in_ras, num_ras_tracers, kbot, mask)
     call mpp_clock_end (ras_clock)
   else
!---------------------------------------------------------------------
!    if ras_mod is not activated, set the ras mass flux field to be 0.0.
!---------------------------------------------------------------------
     mc   = 0.0
     det0(is:ie,js:je,:) = 0.0
     rain_ras = 0.0
     snow_ras = 0.0
   endif  ! (do_ras)

!---------------------------------------------------------------------
!    call subroutine cu_mo_trans if diffusive cumulus momentum 
!    transport is desired. 
!---------------------------------------------------------------------
   if (do_cmt) then
     call mpp_clock_begin (cmt_clock)
     diff_cu_mo(:,:,:)  = 0.0

!  if doing nonlocal cmt, call cu_mo_trans for each convective scheme
!  separately
     if (.not. doing_diffusive) then
       if (cmt_uses_ras) then
!        mc_cmt = mc
!        det_cmt = det0
         call moistproc_cmt ( Time, is, js, tin(is:ie,js:je,:), uin(is:ie,js:je,:), vin(is:ie,js:je,:), &
                              tracer(is:ie,js:je,:,:), pfull, phalf, &
                              zfull, zhalf, pmass(is:ie,js:je,:), tdt, udt, vdt, rdt,           &
                              ttnd_conv(is:ie,js:je,:), dt, mc, det0(is:ie,js:je,:), diff_cu_mo,               &
                              num_tracers)
       endif !(cmt_uses_ras)
!
       if (cmt_uses_donner) then
!        mc_cmt = m_cellup 
!        det_cmt = m_cdet_donner 
         call moistproc_cmt ( Time, is, js, tin(is:ie,js:je,:), uin(is:ie,js:je,:), vin(is:ie,js:je,:), &
                              tracer(is:ie,js:je,:,:), pfull, phalf, &
                              zfull, zhalf, pmass(is:ie,js:je,:), tdt, udt, vdt, rdt,           &
                              ttnd_conv(is:ie,js:je,:), dt, m_cellup, M_cdet_donner(is:ie,js:je,:), diff_cu_mo,&
                              num_tracers)
       endif
!
       if (cmt_uses_uw) then
         mc_cmt(:,:,1) = 0.
         mc_cmt(:,:,kx+1) = 0.
         do k=2,kx
           mc_cmt(:,:,k) = cmf(is:ie,js:je,k-1)
         end do
!   CURRENTLY no detrained mass flux provided from uw_conv; should only
!   use with 'diffusive' cmt scheme, not the non-local. (attempt to
!   use non-local will cause FATAL in _init routine.)
         det_cmt(is:ie,js:je,:) = 0.0   
         call moistproc_cmt ( Time, is, js, tin(is:ie,js:je,:), uin(is:ie,js:je,:), vin(is:ie,js:je,:), &
                              tracer(is:ie,js:je,:,:), pfull, phalf, &
                              zfull, zhalf, pmass(is:ie,js:je,:), tdt, udt, vdt, rdt,           &
                              ttnd_conv(is:ie,js:je,:), dt, mc_cmt, det_cmt(is:ie,js:je,:), diff_cu_mo,        &
                              num_tracers)
       endif

     else ! (we are doing_diffusive)

!  if using diffusive cmt, call cu_mo_trans once with combined mass
!  fluxes from all desired convective schemes.
       mc_cmt = 0.
       det_cmt(is:ie,js:je,:) = 0.
       if (cmt_uses_ras) then
         mc_cmt = mc_cmt + mc
       endif
       if (cmt_uses_donner) then
         mc_cmt = mc_cmt + m_cellup 
       endif
       if (cmt_uses_uw) then
         do k=2,kx
           mc_cmt(:,:,k) = mc_cmt(:,:,k) + cmf(is:ie,js:je,k-1)
         end do
       endif
       call moistproc_cmt ( Time, is, js, tin(is:ie,js:je,:), uin(is:ie,js:je,:), vin(is:ie,js:je,:), &
                            tracer(is:ie,js:je,:,:), pfull, phalf, &
                            zfull, zhalf, pmass(is:ie,js:je,:), tdt, udt, vdt, rdt,           &
                            ttnd_conv(is:ie,js:je,:), dt, mc_cmt, det_cmt(is:ie,js:je,:), diff_cu_mo,        &
                            num_tracers)
     endif ! (.not. doing_diffusive)
     call mpp_clock_end (cmt_clock)
   else  !(do_cmt)
     diff_cu_mo(:,:,:)  = 0.0
   endif  ! (do_cmt)

!---------------------------------------------------------------------
!    calculate the tracer tendency due to wet deposition (wetdeptnd)
!    caused by the convectively generated precipitation (rain, snow) for
!    any tracers for which wet deposition has been activated. add this 
!    tendency to the tracer tendency due to all physics (rdt). save it 
!    also in an array which will be combined with any wet deposition 
!    resulting from large-scale precip producing the total wet deposition
!    for the tracer (wet_data).
!---------------------------------------------------------------------
   wet_data = 0.0
   qtnd_wet(is:ie,js:je,:) = qtnd(is:ie,js:je,:)
   if (do_strat) then
     qtnd_wet(is:ie,js:je,:) = qtnd_wet(is:ie,js:je,:) + q_tnd(is:ie,js:je,:,nql) + q_tnd(is:ie,js:je,:,nqi)
     cloud_wet(is:ie,js:je,:) = 1.e-3
   else
     cloud_wet(is:ie,js:je,:) = 1.e-3
   end if
   cloud_frac(is:ie,js:je,:) = 0.1
    do n=1,size(rdt,4)
     if ( n /= nsphum ) then
       if ( .not. do_strat .or. (n /= nql .and. n /= nqi .and. n /= nqa .and. n /= nqn) ) then
         wetdeptnd(is:ie,js:je,:) = 0.0
         call wet_deposition( n, t, pfull, phalf, zfull, zhalf, rain_ras, snow_ras, &
                              qtnd_wet(is:ie,js:je,:), cloud_wet(is:ie,js:je,:), cloud_frac(is:ie,js:je,:),                      &
                              rain3d, snow3d, tracer(is:ie,js:je,:,n), wetdeptnd(is:ie,js:je,:),           &
                              Time, 'convect', is, js, dt )
         rdt (:,:,:,n) = rdt(:,:,:,n) - wetdeptnd(is:ie,js:je,:)
         wet_data(:,:,:,n) = wetdeptnd(is:ie,js:je,:)
       endif
     endif  
   end do

   mc_full(is:ie,js:je,:)=0.; 
   mc_half(is:ie,js:je,:)=0.; 
   do k=2,kx   
     mc_full(is:ie,js:je,k) = 0.5*(mc(:,:,k) + mc(:,:,k+1)) +   &
                      0.5*(cmf(is:ie,js:je,k)+cmf(is:ie,js:je,k-1)) +   &
                           mc_donner(is:ie,js:je,k)
   end do
   do k=2,kx+1   
     mc_half(is:ie,js:je,k) = mc(:,:,k) +    &
                      cmf(is:ie,js:je,k-1)+   &
                           mc_donner_half(is:ie,js:je,k)
   end do

   if ( get_tracer_index(MODEL_ATMOS,'no') .ne. NO_TRACER &
       .or. id_conv_freq > 0 &
       .or. id_conv_cld_base > 0 &
       .or. id_conv_cld_top > 0 ) then

     cldbot = 0
     cldtop = 0
     do j = 1,jx
       do i = 1,ix
         do k = 1,kx
           if (mc_full(i+is-1,j+js-1,k) /= 0 ) then
             cldtop(i,j) = k
             exit
           endif
         enddo
         do k = size(r,3),1,-1
           if (mc_full(i+is-1,j+js-1,k) /= 0 ) then
             cldbot(i,j) = k
             exit
           endif
         enddo
       enddo
     enddo
   end if

   if ( id_conv_cld_base > 0 ) then
     temp_2d = missing_value
     do j = 1,jx
       do i = 1,ix
         if ( cldbot(i,j) > 0 ) temp_2d(i,j) = pfull(i,j,cldbot(i,j))
       end do
     end do
     used = send_data(id_conv_cld_base, temp_2d, Time, is_in=is,   &
                                           js_in=js,  mask = cldbot > 0)
   end if

   if ( id_conv_cld_top > 0 ) then
     temp_2d = missing_value
     do j = 1,jx
       do i = 1,ix
         if ( cldtop(i,j) > 0 ) temp_2d(i,j) = pfull(i,j,cldtop(i,j))
       end do
     end do
     used = send_data(id_conv_cld_top, temp_2d, Time, is_in=is, &
                                  js_in=js,  mask = cldtop > 0)
   end if

!-----------------------------------------------------------------------
! lightning NOx parameterization
!-----------------------------------------------------------------------
   if ( get_tracer_index(MODEL_ATMOS,'no') .ne. NO_TRACER ) then
     cldbot = 0
     cldtop = 0
     do i = 1,ix
      do j = 1,jx
       do k = 1,kx
         if (mc_full(i+is-1,j+js-1,k) /= 0 ) then
           cldtop(i,j) = k
           exit
         endif
       enddo
       do k = size(r,3),1,-1
         if (mc_full(i+is-1,j+js-1,k) /= 0 ) then
           cldbot(i,j) = k
           exit
         endif
       enddo
      enddo
     enddo
     call moz_hook(cldtop, cldbot, land, zfull, zhalf, t, prod_no, area, lat, &
                   Time, is, js)
     rdt(:,:,:,get_tracer_index(MODEL_ATMOS,'no')) =  &
              rdt(:,:,:,get_tracer_index(MODEL_ATMOS,'no')) + &
              prod_no* ((boltz * t) / (10. * pfull))                     !  conc_air
     used = send_data(id_prod_no,prod_no, Time, is_in=is, js_in=js)
   endif

!-----------------------------------------------------------------------
!    define the total precipitation rate (precip).
!-----------------------------------------------------------------------
   precip = lprec + fprec

!-----------------------------------------------------------------------
!    calculate convective gustiness, if desired.
!-----------------------------------------------------------------------
   if (do_gust_cv) then
     where((precip) > 0.0)
       gust_cv = gustmax*sqrt( precip/(gustconst + precip) )
     end where
   end if

!---------------------------------------------------------------------
!    save a diagnostic indicating whether or not convection has occurred
!    within the column.
!---------------------------------------------------------------------
   where (precip > 0.) convect = .true.

!---------------------------------------------------------------------
!    apply changes resulting from uw_conv
!---------------------------------------------------------------------
   if (do_uw_conv) then
     if (do_limit_uw) then
       call moistproc_scale_uw(is,ie,js,je,dt, qin(is:ie,js:je,:), tracer(is:ie,js:je,:,:), tdt, qdt, udt, vdt, rdt,  &
                               ttnd_conv(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:), lprec, fprec, precip,&
                               do_strat, do_liq_num, num_tracers,         &
                               tracers_in_uw, scale)
       used = send_data (id_scale_uw, scale, Time, is, js )
     else !(do_limit_uw) 
        scale = 1.0
        used = send_data (id_scale_uw, scale, Time, is, js )
     endif !(do_limit_uw)

!       update input fields with changes from uw_conv
     tin(is:ie,js:je,:) = tin(is:ie,js:je,:) + ttnd_uw(is:ie,js:je,:)*dt
     qin(is:ie,js:je,:) = qin(is:ie,js:je,:) + qtnd_uw(is:ie,js:je,:)*dt
     uin(is:ie,js:je,:) = uin(is:ie,js:je,:) + utnd_uw(is:ie,js:je,:)*dt
     vin(is:ie,js:je,:) = vin(is:ie,js:je,:) + vtnd_uw(is:ie,js:je,:)*dt
     tracer(is:ie,js:je,:,nql) = tracer(is:ie,js:je,:,nql) + qltnd_uw(is:ie,js:je,:)*dt
     tracer(is:ie,js:je,:,nqi) = tracer(is:ie,js:je,:,nqi) + qitnd_uw(is:ie,js:je,:)*dt
     tracer(is:ie,js:je,:,nqa) = tracer(is:ie,js:je,:,nqa) + qatnd_uw(is:ie,js:je,:)*dt
     if (do_liq_num) then
       tracer(is:ie,js:je,:,nqn) = tracer(is:ie,js:je,:,nqn) + qntnd_uw(is:ie,js:je,:)*dt
     endif
   endif !(uw_conv)
 
!---------------------------------------------------------------------
!    update tracer fields with tendencies due to convection and wet 
!    deposition by convective precipitation.
!---------------------------------------------------------------------
   do n=1,size(rdt,4)
     if (n /= nsphum) then
       if (.not. do_strat .or. ( n /= nql .and. n /= nqi .and.   &
            n /= nqa .and. n /= nqn) ) then
!        tracer(:,:,:,n) = tracer(:,:,:,n) +   &
         tracer(is:ie,js:je,:,n) = tracer_orig(is:ie,js:je,:,n) +   &
                           (rdt(:,:,:,n) - rdt_init(is:ie,js:je,:,n)) *dt
       endif
     endif
   end do

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                   CONVECTION DIAGNOSTICS      
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

   used = send_data (id_ras_precip, rain_ras+snow_ras, Time, is, js)
   used = send_data (id_don_precip, rain_don+snow_don+rain_donmca+snow_donmca, &
                     Time, is, js)
! uw_conv diags
   if ( id_uw_precip > 0 ) then
     used = send_data (id_uw_precip, rain_uw(is:ie,js:je) + snow_uw(is:ie,js:je), Time, is, js)
   endif
   used = send_data (id_uw_snow, snow_uw, Time, is, js)
   used = send_data (id_tdt_uw, ttnd_uw(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
   used = send_data (id_qdt_uw, qtnd_uw(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
   used = send_data (id_qadt_uw, qatnd_uw(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
   used = send_data (id_qldt_uw, qltnd_uw(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
   used = send_data (id_qidt_uw, qitnd_uw(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
   used = send_data (id_qndt_uw, qntnd_uw(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
        
   if (id_ras_freq > 0) then
     ltemp = rain_ras > 0. .or. snow_ras > 0.0
     temp_2d = 0.
     where (ltemp) 
       temp_2d = 1.
     end where
     used = send_data (id_ras_freq, temp_2d,Time, is, js)
   endif

   if (id_don_freq > 0) then
     ltemp = rain_don > 0. .or. snow_don > 0.0 .or. &
                rain_donmca > 0. .or. snow_donmca > 0.0
     temp_2d = 0.
     where (ltemp) 
       temp_2d = 1.
     end where
     used = send_data (id_don_freq, temp_2d, Time, is, js)
   endif

   if (id_uw_freq > 0) then
     ltemp = rain_uw(is:ie,js:je) > 0. .or. snow_uw(is:ie,js:je) > 0.0
     temp_2d = 0.
     where (ltemp) 
       temp_2d = 1.
     end where
     used = send_data (id_uw_freq, temp_2d, Time, is, js)
   endif

   if (id_enth_uw_col > 0) then
     temp_2d = -HLV*rain_uw(is:ie,js:je) -HLS*snow_uw(is:ie,js:je)
     call column_diag(id_enth_uw_col, is, js, Time, ttnd_uw(is:ie,js:je,:), CP_AIR, qltnd_uw(is:ie,js:je,:), -HLV, &
                      qitnd_uw(is:ie,js:je,:), -HLS, temp_2d)
   endif

   if (id_wat_uw_col > 0) then
     temp_2d = rain_uw(is:ie,js:je) + snow_uw(is:ie,js:je)
     call column_diag(id_wat_uw_col, is, js, Time, qtnd_uw(is:ie,js:je,:), 1.0, qltnd_uw(is:ie,js:je,:), 1.0, &
                      qitnd_uw(is:ie,js:je,:), 1.0, temp_2d)
   endif
        
!---------------------------------------------------------------------
!    temperature change due to dry and moist convection:
!---------------------------------------------------------------------
   used = send_data (id_tdt_conv, ttnd_conv(is:ie,js:je,:), Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    vapor specific humidity change due to convection:
!---------------------------------------------------------------------
   used = send_data (id_qdt_conv, qtnd_conv(is:ie,js:je,:), Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    total precipitation due to convection:
!---------------------------------------------------------------------
   used = send_data (id_prec_conv, precip, Time, is, js)

!---------------------------------------------------------------------
!    frozen precipitation (snow) due to convection:
!---------------------------------------------------------------------
   used = send_data (id_snow_conv, fprec, Time, is, js)

!---------------------------------------------------------------------
!    convective frequency
!---------------------------------------------------------------------
   if (id_conv_freq > 0) then
     ltemp = precip > 0. .or. cldtop > 0
     where (ltemp)
       freq_count = 1.
     elsewhere
       freq_count = 0.
     end where
     used = send_data (id_conv_freq, freq_count, Time, is, js )
   endif

!---------------------------------------------------------------------
!------- diagnostics for 3D precip_conv -------
!---------------------------------------------------------------------
   used = send_data ( id_conv_rain3d, rain3d, Time, is, js, 1 )

!---------------------------------------------------------------------
!------- diagnostics for 3D snow_conv -------
!---------------------------------------------------------------------
   used = send_data ( id_conv_snow3d, snow3d, Time, is, js, 1 )

!---------------------------------------------------------------------
!    surface wind gustiness due to convection:
!---------------------------------------------------------------------
   used = send_data (id_gust_conv, gust_cv, Time, is, js)

!---------------------------------------------------------------------
!    water vapor path tendency due to convection:
!---------------------------------------------------------------------
   if (id_q_conv_col > 0) call column_diag(id_q_conv_col, is, js, Time, qtnd_conv(is:ie,js:je,:), 1.0)
   
!---------------------------------------------------------------------
!    dry static energy tendency due to dry and moist convection:
!---------------------------------------------------------------------
   if (id_t_conv_col > 0) call column_diag(id_t_conv_col, is, js, Time, ttnd_conv(is:ie,js:je,:), CP_AIR)
   
!---------------------------------------------------------------------
!    cloud liquid, ice and area tendencies due to convection:
!---------------------------------------------------------------------
   if (do_strat) then

!---------------------------------------------------------------------
!    if cloud liquid diagnostics requested:
!---------------------------------------------------------------------
     if (id_qldt_conv > 0 .or. id_ql_conv_col > 0) then
       temp_3d1 = rdt(:,:,:,nql) - rdt_init(is:ie,js:je,:,nql)

!---------------------------------------------------------------------
!    cloud liquid tendency due to convection:
!---------------------------------------------------------------------
       used = send_data (id_qldt_conv, temp_3d1, Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    cloud liquid water path tendency due to convection:
!---------------------------------------------------------------------
       if (id_ql_conv_col > 0) call column_diag(id_ql_conv_col, is, js, Time, temp_3d1, 1.0)
     endif

!---------------------------------------------------------------------
!    if cloud drop diagnostics requested:
!---------------------------------------------------------------------
     if (id_qndt_conv > 0 .or. id_qn_conv_col > 0) then
       temp_3d1 = rdt(:,:,:,nqn) - rdt_init(is:ie,js:je,:,nqn)

!---------------------------------------------------------------------
!    cloud drop tendency due to convection:
!---------------------------------------------------------------------
       used = send_data (id_qndt_conv, temp_3d1, Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    cloud drop water path tendency due to convection:
!---------------------------------------------------------------------
       if (id_qn_conv_col > 0) call column_diag(id_qn_conv_col, is, js, Time, temp_3d1, 1.0)
     endif

!---------------------------------------------------------------------
!    if cloud ice diagnostics requested:
!---------------------------------------------------------------------
     if (id_qidt_conv > 0 .or. id_qi_conv_col > 0) then
       temp_3d1 = rdt(:,:,:,nqi) - rdt_init(is:ie,js:je,:,nqi)

!---------------------------------------------------------------------
!    cloud ice tendency due to convection:
!---------------------------------------------------------------------
       used = send_data (id_qidt_conv, temp_3d1, Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    cloud ice water path tendency due to convection:
!---------------------------------------------------------------------
       if (id_qi_conv_col > 0) call column_diag(id_qi_conv_col, is, js, Time, temp_3d1, 1.0)
     endif        

!---------------------------------------------------------------------
!    if cloud area diagnostics requested:
!---------------------------------------------------------------------
     if (id_qadt_conv > 0 .or.  id_qa_conv_col > 0 ) then
       temp_3d1 = rdt(:,:,:,nqa) - rdt_init(is:ie,js:je,:,nqa)

!---------------------------------------------------------------------
!    cloud area tendency due to convection:
!---------------------------------------------------------------------
       used = send_data (id_qadt_conv, temp_3d1, Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    column integrated cloud mass tendency due to convection:
!---------------------------------------------------------------------
       if (id_qa_conv_col > 0) call column_diag(id_qa_conv_col, is, js, Time, temp_3d1, 1.0)
     endif
   endif !(do_strat)
         
!---------------------------------------------------------------------
!    column integrated enthalpy and total water tendencies due to 
!    convection parameterization:
!---------------------------------------------------------------------
   if (id_enth_conv_col > 0 .or. id_wat_conv_col > 0) then
     temp_3d1 = rdt(:,:,:,nql) - rdt_init(is:ie,js:je,:,nql)
     temp_3d2 = rdt(:,:,:,nqi) - rdt_init(is:ie,js:je,:,nqi)

     if (id_enth_conv_col > 0) then
       temp_2d = -HLV*precip -HLF*fprec
       call column_diag(id_enth_conv_col, is, js, Time, ttnd_conv(is:ie,js:je,:), CP_AIR, temp_3d1, -HLV, temp_3d2, -HLS, temp_2d)
     endif

     if (id_wat_conv_col > 0) then
       temp_2d = precip
       call column_diag(id_wat_conv_col, is, js, Time, qtnd_conv(is:ie,js:je,:), 1.0, temp_3d1, 1.0, temp_3d2, 1.0, temp_2d)
     endif
   endif

!---------------------------------------------------------------------
!    tracer tendencies due to convection:
!---------------------------------------------------------------------
   do n=1,size(rdt,4)
     if (tracers_in_donner(n) .or.  tracers_in_ras(n) .or.  &
         tracers_in_mca(n)    .or.  tracers_in_uw(n))    then

       if (id_tracerdt_conv(n) > 0 .or. id_tracerdt_conv_col(n) > 0) then
         temp_3d1 = rdt(:,:,:,n) - rdt_init(is:ie,js:je,:,n)
         used = send_data (id_tracerdt_conv(n), temp_3d1, Time, is, js, 1, rmask=mask )

!---------------------------------------------------------------------
!    tracer column tendencies due to convection:
!---------------------------------------------------------------------
         if (id_tracerdt_conv_col(n) > 0) &
           call column_diag(id_tracerdt_conv_col(n), is, js, Time, temp_3d1, 1.0)
       endif        
     endif
   end do

!---------------------------------------------------------------------
!    total convective updraft mass flux (uw + donner cell up + 
!    donner meso up
!---------------------------------------------------------------------
    used = send_data (id_mc_conv_up, cmf + mc_donner_up, Time, is, js, 1, rmask=mask )

!---------------------------------------------------------------------
!    end the timing of the convection code section.
!---------------------------------------------------------------------
   call mpp_clock_end (convection_clock)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!              LARGE-SCALE CONDENSATION PARAMETERIZATIONS
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@


!---------------------------------------------------------------------
!    begin the timing of the large-scale condensation code section.
!---------------------------------------------------------------------


!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!         A. NON-PROGNOSTIC CONDENSATION PARAMETERIZATION
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@


!-----------------------------------------------------------------------
!    if a non-prognostic cloud scheme is active, then call lscale_cond 
!    to calculate the temperature and specific humidity tendencies 
!    related to the latent heat release associated with the large-scale 
!    supersaturation.
!-----------------------------------------------------------------------
    call mpp_clock_begin (largescale_clock)

!zero out arrays for large scale precipitation
    rain   = 0.
    snow   = 0.
    rain3d = 0.
    snow3d = 0.
    snowclr3d = 0.
    ttnd(is:ie,js:je,:)   = 0.
    qtnd(is:ie,js:je,:)   = 0.

    if (do_lsc) then
      call mpp_clock_begin (lscalecond_clock)
      call moistproc_lscale_cond (is, js, tin(is:ie,js:je,:), qin(is:ie,js:je,:), pfull, phalf, tdt, qdt, &
                                  ttnd(is:ie,js:je,:), qtnd(is:ie,js:je,:), qtnd_conv(is:ie,js:je,:), lprec, fprec, precip,    &
                                  rain, snow, dtinv, omega, do_rh_clouds, do_simple,&
                                  do_diag_clouds, coldT, kbot=kbot, mask=mask)
      call mpp_clock_end (lscalecond_clock)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!       B. TIEDTKE / ROTSTAYN / KLEIN PROGNOSTIC CLOUD SCHEME  
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

    else if (do_strat) then
      call mpp_clock_begin (stratcloud_clock)
      call moistproc_strat_cloud(Time, is, ie, js, je, ktop, dt, tm, tin(is:ie,js:je,:), qin(is:ie,js:je,:), &
                                 tracer(is:ie,js:je,:,:), pfull, phalf, zhalf, omega, radturbten, mc_full(is:ie,js:je,:), &
                                 diff_t, land, area, tdt, qdt, rdt, q_tnd(is:ie,js:je,:,:), ttnd(is:ie,js:je,:),  &
                                 qtnd(is:ie,js:je,:), lprec, fprec, rain, snow, rain3d, snow3d,  &
                                  snowclr3d, &
                                 Aerosol, lsc_cloud_area, lsc_liquid, lsc_ice,    &
                                 lsc_droplet_number, donner_humidity_area(is:ie,js:je,:),        &
                                 donner_humidity_factor(is:ie,js:je,:), shallow_cloud_area,      &
                                 cell_cld_frac, meso_cld_frac,                    &
                                 do_uw_conv, do_donner_deep, do_liq_num,          &
                                 do_lin_cld_microphys, id_qvout, id_qlout,        &
                                 id_qaout, id_qiout, limit_conv_cloud_frac, mask, &
                                 hydrostatic, phys_hydrostatic)
      call mpp_clock_end (stratcloud_clock)
    endif  ! (do_lsc)

!---------------------------------------------------------------------
!    calculate the wet deposition associated with the large scale 
!    condensation. 
!---------------------------------------------------------------------
    qtnd_wet(is:ie,js:je,:) = qtnd(is:ie,js:je,:)
    if (do_strat) then
      qtnd_wet(is:ie,js:je,:) = qtnd_wet(is:ie,js:je,:) + q_tnd(is:ie,js:je,:,nql) + q_tnd(is:ie,js:je,:,nqi)
! Count precipitation formed over timestep plus cloud amount at end of timestep
      if (do_lin_cld_microphys) then
        cloud_wet(is:ie,js:je,:) = tracer(is:ie,js:je,:,nqr) + tracer(is:ie,js:je,:,nqs) + tracer(is:ie,js:je,:,nqg)
      else
        cloud_wet(is:ie,js:je,:) = rain3d(:,:,2:kx+1) - rain3d(:,:,1:kx) &
                  + snow3d(:,:,2:kx+1) - snow3d(:,:,1:kx)
        cloud_wet(is:ie,js:je,:) = cloud_wet(is:ie,js:je,:) * dt / pmass(is:ie,js:je,:) ! convert from kg/m2/s to kg/kg
      endif
      cloud_wet(is:ie,js:je,:) = cloud_wet(is:ie,js:je,:) + tracer(is:ie,js:je,:,nql) + tracer(is:ie,js:je,:,nqi)
      cloud_frac(is:ie,js:je,:) = max( min( tracer(is:ie,js:je,:,nqa), 1. ), 0. )
    else
!     cloud_wet = qtnd_wet * dt
      cloud_wet(is:ie,js:je,:) = 0.5e-3
      cloud_frac(is:ie,js:je,:) = 1.
    end if
     ls_wetdep = 0.
    do n=1,size(rdt,4)
      if ( n /= nsphum ) then
        if ( .not. do_strat .or. (n /= nql .and. n /= nqi .and. n /= nqa .and. n /= nqn) ) then
          wetdeptnd(is:ie,js:je,:) = 0.0
          call wet_deposition( n, t, pfull, phalf, zfull, zhalf, rain, snow,   &
                               qtnd_wet(is:ie,js:je,:), cloud_wet(is:ie,js:je,:), cloud_frac(is:ie,js:je,:),rain3d, snow3d, &
                               tracer(is:ie,js:je,:,n), wetdeptnd(is:ie,js:je,:), Time, 'lscale',     &
                  is, js, dt, sum_wdep_out=ls_wetdep(:,:,n) )
          rdt (:,:,:,n) = rdt(:,:,:,n) - wetdeptnd(is:ie,js:je,:)
          wet_data(:,:,:,n) = wet_data(:,:,:,n) + wetdeptnd(is:ie,js:je,:)

          used = send_data( id_wet_deposition(n), wet_data(:,:,:,n), &
                            Time,is_in=is,js_in=js )
        end if
      end if
    end do

!---------------------------------------------------------------------
!    output diagnostics associated with the large-scale condensation
!    scheme.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    temperature change due to large-scale condensation:
!---------------------------------------------------------------------
    used = send_data (id_tdt_ls, ttnd(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
!---------------------------------------------------------------------
!    dry static energy tendency due to large-scale condensation:
!---------------------------------------------------------------------
    if (id_t_ls_col > 0) &
      call column_diag(id_t_ls_col, is, js, Time, ttnd(is:ie,js:je,:), CP_AIR) 
!---------------------------------------------------------------------
!    water vapor path tendency due to large-scale condensation:
!---------------------------------------------------------------------
    if (id_q_ls_col > 0) &
      call column_diag(id_q_ls_col, is, js, Time, qtnd(is:ie,js:je,:), 1.0) 

!---------------------------------------------------------------------
!    specific humidity change due to large-scale condensation:
!---------------------------------------------------------------------
    used = send_data (id_qdt_ls, qtnd(is:ie,js:je,:), Time, is, js, 1, rmask=mask)

    used = send_data (id_lsc_precip, rain + snow, Time, is, js)
        
    if (id_lsc_freq > 0) then
      ltemp = rain > 0. .or. snow > 0.0
      temp_2d = 0.
      where (ltemp) 
        temp_2d = 1.
      end where
      used = send_data (id_lsc_freq, temp_2d, Time, is, js)
    endif

!---------------------------------------------------------------------
!    total precipitation rate due to large-scale condensation:
!---------------------------------------------------------------------
    used = send_data (id_prec_ls, rain+snow, Time, is, js)

!---------------------------------------------------------------------
!    snowfall rate due to large-scale condensation:
!---------------------------------------------------------------------
    used = send_data (id_snow_ls, snow, Time, is, js)

!---------------------------------------------------------------------
!    define diagnostics specific to the strat_cloud formulation:
!---------------------------------------------------------------------
    if (do_strat) then

!---------------------------------------------------------------------
!    total cumulus mass flux due to strat_cloud parameterization:
!---------------------------------------------------------------------
      used = send_data (id_mc_full, mc_full(is:ie,js:je,:), Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    total cumulus mass flux on half levels:
!---------------------------------------------------------------------
      used = send_data (id_mc_half, mc_half(is:ie,js:je,:), Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    cloud liquid, ice and area tendencies due to strat_cloud 
!    parameterization:
!---------------------------------------------------------------------
      used = send_data (id_qldt_ls, q_tnd(is:ie,js:je,:,nql), Time, is, js, 1, rmask=mask)
      if (do_liq_num) used = send_data (id_qndt_ls, q_tnd(is:ie,js:je,:,nqn), Time, is, js, 1, rmask=mask)
      used = send_data (id_qidt_ls, q_tnd(is:ie,js:je,:,nqi), Time, is, js, 1, rmask=mask)
      used = send_data (id_qadt_ls, q_tnd(is:ie,js:je,:,nqa), Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    cloud liquid and ice water path tendencies due to strat_cloud 
!    parameterization:
!---------------------------------------------------------------------
      if (id_ql_ls_col > 0) &
        call column_diag(id_ql_ls_col, is, js, Time, q_tnd(is:ie,js:je,:,nql), 1.0) 
      if (id_qi_ls_col > 0) &
        call column_diag(id_qi_ls_col, is, js, Time, q_tnd(is:ie,js:je,:,nqi), 1.0) 
      if (do_liq_num .and. id_qn_ls_col > 0) &
        call column_diag(id_qn_ls_col, is, js, Time, q_tnd(is:ie,js:je,:,nqn), 1.0) 
      
!---------------------------------------------------------------------
!    column integrated enthalpy and total water tendencies due to 
!    strat_cloud  parameterization:
!---------------------------------------------------------------------
      if (id_enth_ls_col > 0) then
        temp_2d = -HLV*rain -HLS*snow
        call column_diag(id_enth_ls_col, is, js, Time, ttnd(is:ie,js:je,:), CP_AIR, &
                q_tnd(is:ie,js:je,:,nql), -HLV, q_tnd(is:ie,js:je,:,nqi), -HLS, temp_2d) 
      endif
 
      if (id_wat_ls_col > 0) then
        temp_2d = rain+snow
        call column_diag(id_wat_ls_col, is, js, Time, qtnd(is:ie,js:je,:), 1.0, &
                q_tnd(is:ie,js:je,:,nql), 1.0, q_tnd(is:ie,js:je,:,nqi), 1.0, temp_2d) 
      endif

!---------------------------------------------------------------------
!    stratiform cloud volume tendency due to strat_cloud 
!    parameterization:
!---------------------------------------------------------------------
      if (id_qa_ls_col > 0) &
        call column_diag(id_qa_ls_col, is, js, Time, q_tnd(is:ie,js:je,:,nqa), 1.0)

!---------------------------------------------------------------------
!---- diagnostics for large scale precip -----------
!---------------------------------------------------------------------
      used = send_data(id_lscale_rain3d, rain3d, Time, is, js, 1)

!---------------------------------------------------------------------
!---- diagnostics for large scale snow -------------
!---------------------------------------------------------------------
      used = send_data(id_lscale_snow3d, snow3d, Time, is, js, 1)

    endif ! (do_strat)

!---------------------------------------------------------------------
!    end the timing of the large-scale condensation code section.
!---------------------------------------------------------------------
    call mpp_clock_end (largescale_clock)
 
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!                  GENERAL MOISTURE DIAGNOSTICS 
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@


!--------------------------------------------------------------------
!    output diagnostics obtained from the combination of convective and
!    large-scale parameterizations.  
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    output diagnostics obtained from the combination of convective and
!    large-scale parameterizations.  
!--------------------------------------------------------------------

     total_wetdep(:,:,:) = 0.
     total_wetdep_donner(:,:,:) = 0.
     total_wetdep_uw    (:,:,:) = 0.
     m=1
     mm=1
     do n=1, size(rdt,4)
       if (tracers_in_donner(n)) then
         total_wetdep(:,:,n) = total_wetdep(:,:,n) +  &
                                                donner_wetdep(:,:,m)
         total_wetdep_donner(:,:,n) = donner_wetdep(:,:,m)
         m=m+1
       endif
       if (tracers_in_uw(n)) then
         total_wetdep(:,:,n) = total_wetdep(:,:,n) +  &
                                                    uw_wetdep(:,:,mm)
         total_wetdep_uw    (:,:,n) = uw_wetdep(:,:,mm)
         mm=mm+1
       endif
     end do
     if (do_strat) then
       total_wetdep = total_wetdep + ls_wetdep
     endif
     do n=1, size(rdt,4)
       if (id_wetdep(n) > 0) then
         used = send_data (id_wetdep(n), total_wetdep(:,:,n),  &
                                                          Time, is, js)
       endif
     end do
     if (id_wetdep_om > 0) then
       used = send_data (id_wetdep_om,  &
               total_wetdep       (:,:,nomphilic) + &
               total_wetdep       (:,:,nomphobic) , &
                                                Time, is,js)
     endif
     if (id_wetdep_SOA > 0) then
       used = send_data (id_wetdep_SOA,  &
               total_wetdep(:,:,nSOA) , Time, is,js)
     endif
     if (id_wetdep_bc > 0) then
       used = send_data (id_wetdep_bc,  &
               total_wetdep       (:,:,nbcphilic) + &
               total_wetdep       (:,:,nbcphobic) , &
                                                Time, is,js)
     endif
     if (id_wetdep_so4 > 0) then
       used = send_data (id_wetdep_so4,  &
          (96.0/WTMAIR)*(total_wetdep_donner(:,:,nso4     ) + &
               total_wetdep_uw    (:,:,nso4     )) + &
               0.096*ls_wetdep          (:,:,nso4     ) , &
                                                Time, is,js)
     endif
     if (id_wetdep_so2 > 0) then
       used = send_data (id_wetdep_so2,  &
          (64.0/WTMAIR)*(total_wetdep_donner(:,:,nso2     ) + &
               total_wetdep_uw    (:,:,nso2     )) + &
               0.064*ls_wetdep          (:,:,nso2     ) , &
                                                Time, is,js)
     endif
     if (id_wetdep_DMS > 0) then
       used = send_data (id_wetdep_DMS,  &
          (62.0/WTMAIR)*(total_wetdep_donner(:,:,nDMS     ) + &
               total_wetdep_uw    (:,:,nDMS     )) + &
               0.062*ls_wetdep          (:,:,nDMS     ) , &
                                                Time, is,js)
     endif
     if (id_wetdep_NH4NO3 > 0) then
       used = send_data (id_wetdep_NH4NO3,  &
           (18.0/WTMAIR)*(total_wetdep_donner(:,:,nnH4NO3  ) + &
               total_wetdep_donner(:,:,nNH4     ) + &
               total_wetdep_uw    (:,:,nNH4NO3  ) + &
               total_wetdep_uw    (:,:,nNH4     )) + &
            0.018*(ls_wetdep          (:,:,nNH4NO3  ) + &
                   ls_wetdep          (:,:,nNH4     )) , &
                                                Time, is,js)
     endif
     if (id_wetdep_salt   > 0) then
       used = send_data (id_wetdep_salt  ,  &
           (58.44/WTMAIR)*(total_wetdep_donner(:,:,nsalt1   ) + &
               total_wetdep_donner(:,:,nsalt2   ) + &
               total_wetdep_donner(:,:,nsalt3   ) + &
               total_wetdep_donner(:,:,nsalt4   ) + &
               total_wetdep_donner(:,:,nsalt5   ) + &
               total_wetdep_uw    (:,:,nsalt1   ) + &
               total_wetdep_uw    (:,:,nsalt2   ) + &
               total_wetdep_uw    (:,:,nsalt3   ) + &
               total_wetdep_uw    (:,:,nsalt4   ) + &
               total_wetdep_uw    (:,:,nsalt5   )) + &
            0.05844*(ls_wetdep          (:,:,nsalt1   ) + &
                   ls_wetdep          (:,:,nsalt2   ) + &
                   ls_wetdep          (:,:,nsalt3   ) + &
                   ls_wetdep          (:,:,nsalt4   ) + &
                   ls_wetdep          (:,:,nsalt5   )) , &
                                                Time, is,js)
     endif
     if (id_wetdep_dust   > 0) then
       used = send_data (id_wetdep_dust  ,  &
           (58.44/WTMAIR)*(total_wetdep_donner(:,:,ndust1   ) + &
               total_wetdep_donner(:,:,ndust2   ) + &
               total_wetdep_donner(:,:,ndust3   ) + &
               total_wetdep_donner(:,:,ndust4   ) + &
               total_wetdep_donner(:,:,ndust5   ) + &
               total_wetdep_uw    (:,:,ndust1   ) + &
               total_wetdep_uw    (:,:,ndust2   ) + &
               total_wetdep_uw    (:,:,ndust3   ) + &
               total_wetdep_uw    (:,:,ndust4   ) + &
               total_wetdep_uw    (:,:,ndust5   )) + &
            0.05844*(ls_wetdep          (:,:,ndust1   ) + &
                   ls_wetdep          (:,:,ndust2   ) + &
                   ls_wetdep          (:,:,ndust3   ) + &
                   ls_wetdep          (:,:,ndust4   ) + &
                   ls_wetdep          (:,:,ndust5   )) , &
                                                Time, is,js)
     endif

!---------------------------------------------------------------------
!    total precipitation (all sources):
!---------------------------------------------------------------------
    precip = fprec + lprec
    if (id_precip > 0) then
      used = send_data (id_precip, precip, Time, is, js)
    endif

!---------------------------------------------------------------------
!    snowfall rate due to all sources:
!---------------------------------------------------------------------
    used = send_data (id_snow_tot, fprec, Time, is, js)

!---------------------------------------------------------------------
!    column integrated enthalpy and total water tendencies due to 
!    moist processes:
!---------------------------------------------------------------------

    if (id_enth_moist_col > 0 .or. id_max_enthalpy_imbal > 0) then
      temp_3d1 = tdt - tdt_init(is:ie,js:je,:)
      temp_3d2 = rdt(:,:,:,nql) - rdt_init(is:ie,js:je,:,nql)
      temp_3d3 = rdt(:,:,:,nqi) - rdt_init(is:ie,js:je,:,nqi)
      temp_2d(:,:) = -HLV*precip -HLF*fprec
      call column_diag(id_enth_moist_col, is, js, Time, temp_3d1, CP_AIR, temp_3d2, -HLV, temp_3d3, -HLS, temp_2d)
      if (id_max_enthalpy_imbal > 0) then
        max_enthalpy_imbal = max( abs(temp_2d), max_enthalpy_imbal )
        used = send_data(id_max_enthalpy_imbal, max_enthalpy_imbal, Time, is, js)
      endif
    endif
  
    if (id_wat_moist_col > 0 .or. id_max_water_imbal > 0) then
      temp_3d1 = qdt - qdt_init(is:ie,js:je,:)
      temp_3d2 = rdt(:,:,:,nql) - rdt_init(is:ie,js:je,:,nql)
      temp_3d3 = rdt(:,:,:,nqi) - rdt_init(is:ie,js:je,:,nqi)
      temp_2d(:,:) = precip
      call column_diag(id_enth_moist_col, is, js, Time, temp_3d1, 1.0, temp_3d2, 1.0, temp_3d3, 1.0, temp_2d)
      if (id_max_water_imbal > 0) then
        max_water_imbal = max( abs(temp_2d), max_water_imbal )
        used = send_data(id_max_water_imbal, max_water_imbal, Time, is, js)
      endif
    endif

!---------------------------------------------------------------------
!    water vapor, liquid water and ice water column paths:
!---------------------------------------------------------------------
    if (id_WVP > 0) &
      call column_diag(id_WVP, is, js, Time, qin(is:ie,js:je,:), 1.0) 
    if (id_LWP > 0 .and. do_strat) &
      call column_diag(id_LWP, is, js, Time, tracer(is:ie,js:je,:,nql), 1.0) 
    if (id_IWP > 0 .and. do_strat) &
      call column_diag(id_IWP, is, js, Time, tracer(is:ie,js:je,:,nqi), 1.0) 

    if (id_lsc_cloud_area > 0 .and. do_strat ) then
      used = send_data (id_lsc_cloud_area, 100.*lsc_cloud_area, Time, is,  &
                        js, 1, rmask=mask)
    end if

!----------------------------------------------------------------------
!    define total convective cloud amount (grid-box mean).
!----------------------------------------------------------------------
    total_conv_cloud = 0.
    tot_conv_liq = 0.
    tot_conv_ice = 0.
    conv_cld_frac = 0.
    total_cloud_area = 0.
    if (do_strat) then
      total_cloud_area = total_cloud_area + lsc_cloud_area
    endif
    if (do_donner_deep) then
      total_conv_cloud = total_conv_cloud +   &
          cell_cld_frac*cell_ice_amt + meso_cld_frac*meso_ice_amt +  &
          cell_cld_frac*cell_liq_amt + meso_cld_frac*meso_liq_amt 
      conv_cld_frac = conv_cld_frac + cell_cld_frac + meso_cld_frac
      total_cloud_area = total_cloud_area + cell_cld_frac +  &
                                                         meso_cld_frac
      tot_conv_liq = tot_conv_liq + cell_cld_frac*cell_liq_amt + &
                                           meso_cld_frac*meso_liq_amt 
      tot_conv_ice = tot_conv_ice + cell_cld_frac*cell_ice_amt + &
                                           meso_cld_frac*meso_ice_amt 
    endif
    if (do_uw_conv) then
      total_conv_cloud = total_conv_cloud +   &
                          shallow_cloud_area*shallow_ice  +   &
                          shallow_cloud_area*shallow_liquid
      conv_cld_frac = conv_cld_frac + shallow_cloud_area
      total_cloud_area = total_cloud_area + shallow_cloud_area
      tot_conv_liq = tot_conv_liq + shallow_cloud_area*shallow_liquid
      tot_conv_ice = tot_conv_ice + shallow_cloud_area*shallow_ice     
    endif

    if (id_lsc_liq_amt > 0 .and. do_strat ) then
      used = send_data (id_lsc_liq_amt,  &
                        lsc_liquid/(1.0 + total_conv_cloud), &
                                          Time, is, js, 1, rmask=mask)
    end if

    if ( id_lsc_ice_amt  > 0 .and. do_strat ) then
       used = send_data (id_lsc_ice_amt,   &
                         lsc_ice/(1.0 + total_conv_cloud), &
                                         Time, is, js, 1, rmask=mask)
    end if


    used = send_data (id_tot_cloud_area, 100.*total_cloud_area,  &
                                          Time, is, js, 1, rmask=mask)

    used = send_data (id_conv_cloud_area, 100.*conv_cld_frac, &
                                           Time, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    define the total cloud area. 
!---------------------------------------------------------------------
    if (id_tot_cld_amt > 0 ) then
      tca2 = 1.0
      do k=1,kx
        tca2(:,:) = tca2(:,:)*(1.0 - total_cloud_area(:,:,k))
      end do
      tca2 = 100.*(1. - tca2)
      used = send_data (id_tot_cld_amt, tca2, Time, is, js)
    endif
 
!---------------------------------------------------------------------
!    define the total and convective liquid and liquid water path. 
!---------------------------------------------------------------------
    used = send_data (id_tot_liq_amt, &
                 (lsc_liquid + tot_conv_liq)/(1.0 + total_conv_cloud), &
                                           Time, is, js, 1, rmask=mask)

    used = send_data (id_conv_liq_amt, &
                   tot_conv_liq /(1.0 + total_conv_cloud), &
                                           Time, is, js, 1, rmask=mask)
 
    call column_diag (id_LWP_all_clouds, is, js, Time, &
                      lsc_liquid+tot_conv_liq, 1.0)

!---------------------------------------------------------------------
!    define the total and convective ice and ice water path. 
!---------------------------------------------------------------------

     used = send_data (id_tot_ice_amt, &
                 (lsc_ice + tot_conv_ice)/(1.0 + total_conv_cloud), &
                                            Time, is, js, 1, rmask=mask)

     used = send_data (id_conv_ice_amt, &
                  tot_conv_ice/(1.0 + total_conv_cloud), &
                                            Time, is, js, 1, rmask=mask)

     call column_diag (id_IWP_all_clouds, is, js, Time, &
                       lsc_ice+tot_conv_ice, 1.0)
 
!---------------------------------------------------------------------
!    define the total vapor, total water substance and condensate water
!    path. 
!---------------------------------------------------------------------
    used = send_data (id_tot_vapor, qin, Time, is, js, 1, rmask=mask)
    used = send_data (id_tot_h2o  , &
                     (qin(is:ie,js:je,:) + lsc_ice + tot_conv_ice + lsc_liquid +  &
                               tot_conv_liq)/(1.0 + total_conv_cloud), &
                                            Time, is, js, 1, rmask=mask)

    call column_diag(id_WP_all_clouds, is, js, Time, &
              lsc_ice + tot_conv_ice +  lsc_liquid + tot_conv_liq, 1.0)

!---------------------------------------------------------------------
!    column integrated cloud mass:
!---------------------------------------------------------------------
    if (id_AWP > 0 .and. do_strat) &
      call column_diag(id_AWP, is, js, Time, tracer(is:ie,js:je,:,nqa), 1.0) 

!---------------------------------------------------------------------
!    relative humidity:         
!---------------------------------------------------------------------
    if (id_rh > 0) then
      if (.not. (do_rh_clouds .or. do_diag_clouds)) then 
        call rh_calc (pfull, tin(is:ie,js:je,:), qin(is:ie,js:je,:), RH(is:ie,js:je,:), do_simple, mask)
      endif
      used = send_data (id_rh, rh(is:ie,js:je,:)*100., Time, is, js, 1, rmask=mask)
    endif

!---------------------------------------------------------------------
!    relative humidity (CMIP formulation):         
!---------------------------------------------------------------------
    if (id_rh_cmip > 0) then
      if (.not. (do_rh_clouds .or. do_diag_clouds)) then
        call rh_calc (pfull, tin(is:ie,js:je,:), qin(is:ie,js:je,:), &
                       RH(is:ie,js:je,:), do_simple, do_cmip=.true., &
                                                            mask=mask)
      endif
      used = send_data (id_rh_cmip, rh(is:ie,js:je,:)*100.,  &
                                         Time, is, js, 1, rmask=mask)
    endif

!---------------------------------------------------------------------
!    saturation specific humidity:         
!---------------------------------------------------------------------
    if (id_qs > 0) then
      call compute_qs (tin(is:ie,js:je,:), pfull, qsat(is:ie,js:je,:), q = qin(is:ie,js:je,:))
      used = send_data (id_qs, qsat(is:ie,js:je,:), Time, is, js, 1, rmask=mask)
    endif

!------- diagnostics for CAPE and CIN, 

!!-- compute and write out CAPE and CIN--
    if ( id_cape > 0 .or. id_cin > 0) then
!! calculate r
      rin(is:ie,js:je,:) = qin(is:ie,js:je,:)/(1.0 - qin(is:ie,js:je,:)) ! XXX rin is not mixing ratio when do_simple=.true.
      avgbl = .false.
      do j=js,je
       do i=is,ie
         call capecalcnew( kx, pfull(i,j,:), phalf(i,j,:), CP_AIR, RDGAS, RVGAS, &
                   HLV, KAPPA, tin(i,j,:), rin(i,j,:), avgbl, cape(i,j), cin(i,j))
       end do
      end do
      if (id_cape > 0) used = send_data ( id_cape, cape, Time, is, js )
      if ( id_cin > 0 ) used = send_data ( id_cin, cin, Time, is, js )
    end if

!---------------------------------------------------------------------
!    output the global integral of precipitation in units of mm/day.
!---------------------------------------------------------------------
    prec_intgl(is:ie,js:je) = precip(:,:)*SECONDS_PER_DAY

!----------------------------------------------------------------------
!    define the precip fluxes needed for input to the COSP simulator 
!    package.
!---------------------------------------------------------------------
      if (do_cosp) then

!---------------------------------------------------------------------
!    define precip fluxes from convective schemes at each layer 
!    interface.  (index 1 is model lid)
!---------------------------------------------------------------------
        liq_mesoh(is:ie,js:je,1) = 0.
        frz_mesoh(is:ie,js:je,1) = 0.
        liq_cellh(is:ie,js:je,1) = 0.
        frz_cellh(is:ie,js:je,1) = 0.
        ice_precflxh(is:ie,js:je,1) = 0.
        liq_precflxh(is:ie,js:je,1) = 0.
        mca_liqh(is:ie,js:je,1) = 0.
        mca_frzh(is:ie,js:je,1) = 0.
        do k=2, size(t,3)+1
          liq_mesoh(is:ie,js:je,k) =  liq_mesoh (is:ie,js:je,k-1) + &
                                      liq_meso (is:ie,js:je,k-1)
          frz_mesoh(is:ie,js:je,k) =  frz_mesoh (is:ie,js:je,k-1) + &
                                      frz_meso (is:ie,js:je,k-1)
          liq_cellh(is:ie,js:je,k) =  liq_cellh (is:ie,js:je,k-1) + &
                                      liq_cell (is:ie,js:je,k-1)
          frz_cellh(is:ie,js:je,k) =  frz_cellh (is:ie,js:je,k-1) + &
                                      frz_cell (is:ie,js:je,k-1)
          ice_precflxh(is:ie,js:je,k) =                  &
                               ice_precflxh(is:ie,js:je,k-1) +  &
                                           ice_precflx(is:ie,js:je,k-1)
          liq_precflxh(is:ie,js:je,k) =        &
                               liq_precflxh(is:ie,js:je,k-1) +   &
                                           liq_precflx(is:ie,js:je,k-1)
          if (include_donmca_in_cosp) then
            mca_liqh (is:ie,js:je,k) = mca_liqh (is:ie,js:je,k-1) + &
                                        mca_liq(is:ie,js:je,k-1)
            mca_frzh (is:ie,js:je,k) = mca_frzh (is:ie,js:je,k-1) + &
                                        mca_frz(is:ie,js:je,k-1)
          endif
        end do

!--------------------------------------------------------------------
!    adjust precip fluxes to account for any negative values produced.
!    precip contribution is determined as the negative of the moisture
!    tendency, so at top of clouds a positive moisture tendency some-
!    times results in a negative precipitation contribution. 
!--------------------------------------------------------------------
        sumneg = 0.
        do k=2, size(t,3)+1
        do j=js,je        
        do i=is,ie          
          if (liq_mesoh(i,j,k) > 0.0) then
            if (liq_mesoh(i,j,k) > ABS(sumneg)) then
              liq_mesoh(i,j,k) = liq_mesoh(i,j,k) + sumneg
              sumneg = 0.
            else
              sumneg = sumneg + liq_mesoh(i,j,k)
              liq_mesoh(i,j,k) = 0.                        
            endif
          else
            sumneg = sumneg + liq_mesoh(i,j,k)
            liq_mesoh(i,j,k) = 0.
          endif
        end do
        end do
        end do
        sumneg = 0.
        do k=2, size(t,3)+1
        do j=js,je            
        do i=is,ie          
          if (frz_mesoh(i,j,k) > 0.0) then
            if (frz_mesoh(i,j,k) > ABS(sumneg)) then
              frz_mesoh(i,j,k) = frz_mesoh(i,j,k) + sumneg
              sumneg = 0.
            else
              sumneg = sumneg + frz_mesoh(i,j,k)
              frz_mesoh(i,j,k) = 0.                        
            endif
          else
            sumneg = sumneg + frz_mesoh(i,j,k)
            frz_mesoh(i,j,k) = 0.
          endif
        end do
        end do
        end do
        sumneg = 0.
        do k=2, size(t,3)+1
        do j=js,je          
        do i=is,ie            
          if (liq_cellh(i,j,k) > 0.0) then
            if (liq_cellh(i,j,k) > ABS(sumneg)) then
              liq_cellh(i,j,k) = liq_cellh(i,j,k) + sumneg
              sumneg = 0.
            else
              sumneg = sumneg + liq_cellh(i,j,k)
              liq_cellh(i,j,k) = 0.                        
            endif
          else
            sumneg = sumneg + liq_cellh(i,j,k)
            liq_cellh(i,j,k) = 0.
          endif
        end do
        end do
        end do
        sumneg = 0.
        do k=2, size(t,3)+1
        do j=js,je            
        do i=is,ie             
          if (frz_cellh(i,j,k) > 0.0) then
            if (frz_cellh(i,j,k) > ABS(sumneg)) then
              frz_cellh(i,j,k) = frz_cellh(i,j,k) + sumneg
              sumneg = 0.
            else
              sumneg = sumneg + frz_cellh(i,j,k)
              frz_cellh(i,j,k) = 0.                        
            endif
          else
            sumneg = sumneg + frz_cellh(i,j,k)
            frz_cellh(i,j,k) = 0.
          endif
        end do
        end do
        end do
        sumneg = 0.
        do k=2, size(t,3)+1
        do j=js,je           
        do i=is,ie           
          if (ice_precflxh(i,j,k) > 0.0) then
            if (ice_precflxh(i,j,k) > ABS(sumneg)) then
              ice_precflxh(i,j,k) = ice_precflxh(i,j,k) + sumneg
              sumneg = 0.
            else
              sumneg = sumneg + ice_precflxh(i,j,k)
              ice_precflxh(i,j,k) = 0.                        
            endif
          else
            sumneg = sumneg + ice_precflxh(i,j,k)
            ice_precflxh(i,j,k) = 0.
          endif
        end do
        end do
        end do
        sumneg = 0.
        do k=2, size(t,3)+1
        do j=js,je          
        do i=is,ie              
          if (liq_precflxh(i,j,k) > 0.0) then
            if (liq_precflxh(i,j,k) > ABS(sumneg)) then
              liq_precflxh(i,j,k) = liq_precflxh(i,j,k) + sumneg
              sumneg = 0.
            else
              sumneg = sumneg + liq_precflxh(i,j,k)
              liq_precflxh(i,j,k) = 0.                        
            endif
          else
            sumneg = sumneg + liq_precflxh(i,j,k)
            liq_precflxh(i,j,k) = 0.
          endif
        end do
        end do
        end do
        if (include_donmca_in_cosp) then
          sumneg = 0.
          do k=2, size(t,3)+1
          do j=js,je          
          do i=is,ie             
            if (mca_liqh(i,j,k) > 0.0) then
              if (mca_liqh(i,j,k) > ABS(sumneg)) then
                mca_liqh(i,j,k) = mca_liqh(i,j,k) + sumneg
                sumneg = 0.
              else
                sumneg = sumneg + mca_liqh(i,j,k)
                mca_liqh(i,j,k) = 0.                        
              endif
            else
              sumneg = sumneg + mca_liqh(i,j,k)
              mca_liqh(i,j,k) = 0.
            endif
          end do
          end do
          end do
          sumneg = 0.
          do k=2, size(t,3)+1
          do j=js,je          
          do i=is,ie            
            if (mca_frzh(i,j,k) > 0.0) then
              if (mca_frzh(i,j,k) > ABS(sumneg)) then
                mca_frzh(i,j,k) = mca_frzh(i,j,k) + sumneg
                sumneg = 0.
              else
                sumneg = sumneg + mca_frzh(i,j,k)
                mca_frzh(i,j,k) = 0.                        
              endif
            else
              sumneg = sumneg + mca_frzh(i,j,k)
              mca_frzh(i,j,k) = 0.
            endif
          end do
          end do
          end do
        endif

!----------------------------------------------------------------------
!     define the grid-box precip flux as the average of the interface 
!     fluxes.
!----------------------------------------------------------------------
        do k=1, size(t,3)
          do j=1, size(t,2)
            do i=1, size(t,1)
              if (donner_meso_is_largescale) then
                fl_lsrain(i,j,k) =    &
                   0.5*(rain3d(i,j,k) + rain3d(i,j,k+1) + &
                        liq_mesoh(i+is-1,j+js-1,k) +  &
                        liq_mesoh(i+is-1,j+js-1,k+1))
                fl_lssnow(i,j,k) =    &
                   0.5*(snowclr3d(i,j,k) + snowclr3d(i,j,k+1) + &
                        frz_mesoh(i+is-1,j+js-1,k) +  &
                        frz_mesoh(i+is-1,j+js-1,k+1))
                fl_ccrain(i,j,k) =    &
                   0.5*(liq_cellh(i+is-1,j+js-1,k) +  &
                                     liq_cellh(i+is-1,j+js-1,k+1) +  &
                        liq_precflxh(i+is-1,j+js-1,k) +  &
                                     liq_precflxh(i+is-1,j+js-1,k+1))
                fl_ccsnow(i,j,k) =    &
                   0.5*(frz_cellh(i+is-1,j+js-1,k) +  &
                                     frz_cellh(i+is-1,j+js-1,k+1) +  &
                        ice_precflxh(i+is-1,j+js-1,k) +   &
                                     ice_precflxh(i+is-1,j+js-1,k+1))
              else
                fl_lsrain(i,j,k) =    &
                   0.5*(rain3d(i,j,k) + rain3d(i,j,k+1))
                fl_lssnow(i,j,k) =    &
                   0.5*(snowclr3d(i,j,k) + snowclr3d(i,j,k+1))
                fl_ccrain(i,j,k) =    &
                   0.5*(liq_mesoh(i+is-1,j+js-1,k) +    &
                                      liq_mesoh(i+is-1,j+js-1,k+1) +  &
                        liq_cellh(i+is-1,j+js-1,k) +    &
                                      liq_cellh(i+is-1,j+js-1,k+1) +  &
                        liq_precflxh(i+is-1,j+js-1,k) +    &
                                      liq_precflxh(i+is-1,j+js-1,k+1))
                fl_ccsnow(i,j,k) =   &
                   0.5*(frz_mesoh(i+is-1,j+js-1,k) +    &
                                      frz_mesoh(i+is-1,j+js-1,k+1) +  &
                        frz_cellh(i+is-1,j+js-1,k) +  &
                                      frz_cellh(i+is-1,j+js-1,k+1) +  &
                        ice_precflxh(i+is-1,j+js-1,k) +    &
                                      ice_precflxh(i+is-1,j+js-1,k+1))
              endif
              if (include_donmca_in_cosp) then
                fl_donmca_snow(i,j,k) = fl_donmca_snow(i,j,k) + 0.5*  &
                                   (mca_frzh(i+is-1,j+js-1,k) +   &
                                           mca_frzh(i+is-1,j+js-1,k+1))
                fl_donmca_rain(i,j,k) = fl_donmca_rain(i,j,k) + 0.5*  &
                                   (mca_liqh(i+is-1,j+js-1,k) +   &
                                           mca_liqh(i+is-1,j+js-1,k+1))
              endif
            end do
          end do
        end do

      endif ! (do_cosp)

!-----------------------------------------------------------------------
end subroutine moist_processes


!#####################################################################
 
subroutine moist_processes_time_vary (dt)

real, intent(in) :: dt


      if (do_donner_deep) then
        call donner_deep_time_vary (dt)
      endif

end subroutine moist_processes_time_vary


!#####################################################################

subroutine moist_processes_endts (is, js)
 
integer, intent(in) :: is,js

      if (do_donner_deep) then
        call donner_deep_endts
      endif 


      call sum_diag_integral_field ('prec', prec_intgl)
      prec_intgl = 0.0


end subroutine moist_processes_endts



!###################################################################

!#######################################################################

subroutine moist_processes_init ( id, jd, kd, lonb, latb, pref, &
                                  axes, Time, doing_donner, &
                                  doing_uw_conv, num_uw_tracers_out,&
                                  do_strat_out, do_cosp_in,  &
!                                 doing_uw_conv, &
!                                 do_cosp_in,  &
                                  donner_meso_is_largescale_in, &
                                  include_donmca_in_cosp_out)

!-----------------------------------------------------------------------
integer,              intent(in)  :: id, jd, kd, axes(4)
real, dimension(:,:), intent(in)  :: lonb, latb
real, dimension(:),   intent(in)  :: pref
type(time_type),      intent(in)  :: Time
 logical,              intent(out) :: doing_donner, doing_uw_conv,   &
                                      do_strat_out
!logical,              intent(out) :: doing_donner, doing_uw_conv
 integer,              intent(out) :: num_uw_tracers_out
logical,              intent(in), optional ::   &
                                     do_cosp_in, &
                                     donner_meso_is_largescale_in
logical,             intent(out), optional ::    &
                                     include_donmca_in_cosp_out
!-----------------------------------------------------------------------
!
!      input
!     --------
!
!      id, jd        number of horizontal grid points in the global
!                    fields along the x and y axis, repectively.
!                      [integer]
!
!      kd            number of vertical points in a column of atmosphere
!-----------------------------------------------------------------------

integer :: unit,io,ierr, n, logunit
character(len=80)  :: scheme
integer            :: secs, days
integer            :: k
!-----------------------------------------------------------------------

       if ( module_is_initialized ) return

       if (present(do_cosp_in)) then
         do_cosp = do_cosp_in
       else
         do_cosp = .false.
       endif
       if (present(donner_meso_is_largescale_in)) then
         donner_meso_is_largescale = donner_meso_is_largescale_in
       else
         donner_meso_is_largescale = .false.
       endif

       if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
         read (input_nml_file, nml=moist_processes_nml, iostat=io)
         ierr = check_nml_error(io,'moist_processes_nml')
#else   

         unit = open_namelist_file ( )
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=moist_processes_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'moist_processes_nml')
         enddo
  10     call close_file (unit)
#endif

!--------- write version and namelist to standard log ------------

      call write_version_number ( version, tagname )
      logunit = stdlog()
      if ( mpp_pe() == mpp_root_pe() ) &
        write ( logunit, nml=moist_processes_nml )

      if (present(include_donmca_in_cosp_out)) then
        include_donmca_in_cosp_out = include_donmca_in_cosp
      endif

!------------------- dummy checks --------------------------------------

         if ( do_cosp .and. .not. (do_donner_deep .and.  &
                                   do_strat .and. do_uw_conv)) &
           call error_mesg  ('moist_processes_init',  &
           'must activate do_donner_deep, do_strat and do_uw_conv &
                                          &when do_cosp is true', FATAL)

         if (include_donmca_in_cosp .and. (.not. do_donner_mca) ) &
           call error_mesg ('moist_processes_init', &
          'want to include donmca in COSP when donmca is inactive', &
                                                                  FATAL)

         if ( do_mca .and. do_ras ) call error_mesg   &
                   ('moist_processes_init',  &
                    'both do_mca and do_ras cannot be specified', FATAL)

         if ( do_mca .and. do_bm ) call error_mesg   &
                   ('moist_processes_init',  &
                    'both do_mca and do_bm cannot be specified', FATAL)
         if ( do_ras .and. do_bm ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bm and do_ras cannot be specified', FATAL)
         if ( do_bm .and. do_bmmass ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bm and do_bmmass cannot be specified', FATAL)
         if ( do_bm .and. do_bmomp ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bm and do_bmomp cannot be specified', FATAL)
         if ( do_bmomp .and. do_bmmass ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bmomp and do_bmmass cannot be specified', FATAL)
         if ( do_bmmass .and. do_mca ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bmmass and do_mca cannot be specified', FATAL)
         if ( do_bmmass .and. do_ras ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bmmass and do_ras cannot be specified', FATAL)
         if ( do_bmomp .and. do_mca ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bmomp and do_mca cannot be specified', FATAL)
         if ( do_bmomp .and. do_ras ) call error_mesg   &
                    ('moist_processes_init',  &
                     'both do_bmomp and do_ras cannot be specified', FATAL)

         if ( do_lsc .and. do_strat ) call error_mesg   &
                 ('moist_processes_init',  &
                  'both do_lsc and do_strat cannot be specified', FATAL)
         if (.not. do_lsc .and. .not. do_strat) then
           call error_mesg ('moist_processes_mod', &
              'must activate either do_lsc or do_strat in order to &
                             &include large-scale condensation', FATAL)
         endif

         if ( (do_rh_clouds.or.do_diag_clouds) .and. do_strat .and. &
             mpp_pe() == mpp_root_pe() ) call error_mesg ('moist_processes_init', &
     'do_rh_clouds or do_diag_clouds + do_strat should not be specified', NOTE)

         if ( do_rh_clouds .and. do_diag_clouds .and. mpp_pe() == mpp_root_pe() ) &
            call error_mesg ('moist_processes_init',  &
       'do_rh_clouds and do_diag_clouds should not be specified', NOTE)

         if (do_mca .and. do_donner_deep) call error_mesg &
                 ('moist_processes_init',  &
            'both do_donner_deep and do_mca cannot be specified', FATAL)

         if (do_donner_deep .and. do_rh_clouds) then
           call error_mesg ('moist_processes_init',  &
            'Cannot currently activate donner_deep_mod with rh_clouds', FATAL)
         endif   
         
         if (force_donner_moist_conserv .and. &
               .not. do_donner_conservation_checks) then
           call error_mesg ('moist_processes', &
              'when force_donner_moist_conserv is .true., &
                &do_donner_conservation_checks must be .true.', FATAL)
         endif

         if (use_updated_profiles_for_uw .and.   &
             .not. (do_donner_before_uw) ) then
           call error_mesg ('moist_processes_init', &
            'use_updated_profiles_for_uw is only meaningful when &
                               &do_donner_before_uw is true', FATAL)
         endif

         if (only_one_conv_scheme_per_column .and.   &
             .not. (do_donner_before_uw) ) then
           call error_mesg ('moist_processes_init', &
            'only_one_conv_scheme_per_column is only meaningful when &
                               &do_donner_before_uw is true', FATAL)
         endif

         if (limit_conv_cloud_frac .and.   &
                 .not. do_donner_before_uw) then
           call error_mesg ('moist_processes', &
              'when limit_conv_cloud_frac is .true., &
                 &do_donner_before_uw must be .true.', FATAL)
         endif

      endif

!---------------------------------------------------------------------
! --- Find the tracer indices 
!---------------------------------------------------------------------

      if (do_strat) then
        ! get tracer indices for stratiform cloud variables
        nsphum = get_tracer_index ( MODEL_ATMOS, 'sphum' )
        nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
        nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
        nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
        if (min(nql,nqi,nqa) <= 0) call error_mesg ('moist_processes', &
                                                    'stratiform cloud tracer(s) not found', FATAL)
        if (nql == nqi .or. nqa == nqi .or. nql == nqa) call error_mesg ('moist_processes',  &
                                 'tracers indices cannot be the same (i.e., nql=nqi=nqa).', FATAL)
        if (mpp_pe() == mpp_root_pe()) &
            write (logunit,'(a,3i4)') 'Stratiform cloud tracer indices: nql,nqi,nqa =',nql,nqi,nqa
      endif

      nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )
      if (nqn == NO_TRACER .and. do_liq_num ) &
        call error_mesg ('moist_processes', &
             'prognostic droplet number scheme requested but tracer not found', FATAL)

!------------ initialize various schemes ----------
      if (do_lsc) then
                     call lscale_cond_init ()
                     if (do_rh_clouds) call rh_clouds_init (id,jd,kd)
                     if (do_diag_clouds) call diag_cloud_init (id,jd,kd,ierr)
      endif
      if (do_strat)  call strat_cloud_init (axes,Time,id,jd,kd)
      if (do_dryadj) call     dry_adj_init ()
      if (do_cmt)    call cu_mo_trans_init (axes,Time, doing_diffusive)
      if (do_bm)     call betts_miller_init () 
      if (do_bmmass) call bm_massflux_init()
      if (do_bmomp)  call bm_omp_init () 

      if (do_cmt) then
        if ( .not. do_ras .and. .not. do_donner_deep  .and. &
             .not. do_uw_conv) then
          call error_mesg ( 'moist_processes_mod', &
                'do_cmt specified but no cumulus schemes activated', &
                                                              FATAL)
        endif
        if (trim(cmt_mass_flux_source) == 'ras') then
          cmt_uses_ras = .true.
          cmt_uses_donner = .false.
          cmt_uses_uw = .false.
          if (.not. do_ras) then
            call error_mesg ('moist_processes_mod', &
              'if cmt_uses_ras then ras_mod must be active', FATAL)
           endif

        else if (trim(cmt_mass_flux_source) == 'donner') then
          cmt_uses_ras = .false.
          cmt_uses_donner = .true.
          cmt_uses_uw = .false.
          if (.not. do_donner_deep)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_donner then donner_deep_mod must&
                                               & be active', FATAL)
           endif

        else if (trim(cmt_mass_flux_source) == 'uw') then
          cmt_uses_ras = .false.
          cmt_uses_donner = .false.
          cmt_uses_uw = .true.
          if (.not. do_uw_conv)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_uw then uw_conv_mod must&
                                               & be active', FATAL)
           endif

        else if (trim(cmt_mass_flux_source) == 'donner_and_ras') then
          cmt_uses_ras = .true.
          if (.not. do_ras) then
            call error_mesg ('moist_processes_mod', &
              'if cmt_uses_ras then ras_mod must be active', FATAL)
           endif
          cmt_uses_donner = .true.
          if (.not. do_donner_deep)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_donner then donner_deep_mod must&
                                               & be active', FATAL)
           endif
          cmt_uses_uw = .false.

        else if (trim(cmt_mass_flux_source) == 'donner_and_uw') then
          cmt_uses_uw = .true.
          if (.not. do_uw_conv) then
            call error_mesg ('moist_processes_mod', &
              'if cmt_uses_uw then uw_conv_mod must be active', FATAL)
           endif
          cmt_uses_donner = .true.
          if (.not. do_donner_deep)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_donner then donner_deep_mod must&
                                               & be active', FATAL)
           endif
          cmt_uses_ras = .false.

        else if (trim(cmt_mass_flux_source) == 'ras_and_uw') then
          cmt_uses_ras = .true.
          if (.not. do_ras) then
            call error_mesg ('moist_processes_mod', &
              'if cmt_uses_ras then ras_mod must be active', FATAL)
           endif
          cmt_uses_uw = .true.
          if (.not. do_uw_conv)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_uw then uw_conv_mod must&
                                               & be active', FATAL)
           endif
          cmt_uses_donner = .false.

        else if (trim(cmt_mass_flux_source) == 'donner_and_ras_and_uw') then
          cmt_uses_ras = .true.
          if (.not. do_ras) then
            call error_mesg ('moist_processes_mod', &
              'if cmt_uses_ras then ras_mod must be active', FATAL)
           endif
          cmt_uses_donner = .true.
          if (.not. do_donner_deep)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_donner then donner_deep_mod must&
                                               & be active', FATAL)
           endif
          cmt_uses_uw = .true.
          if (.not. do_uw_conv)  then
            call error_mesg ('moist_processes_mod', &
                'if cmt_uses_uw then uw_conv_mod must&
                                               & be active', FATAL)
           endif
        else if (trim(cmt_mass_flux_source) == 'all') then
          if (do_ras) then
            cmt_uses_ras = .true.
          else
            cmt_uses_ras = .false.
          endif
          if (do_donner_deep)  then
            cmt_uses_donner = .true.
          else
            cmt_uses_donner = .false.
          endif
          if (do_uw_conv)  then
            cmt_uses_uw = .true.
          else
            cmt_uses_uw = .false.
          endif
        else
          call error_mesg ('moist_processes_mod', &
             'invalid specification of cmt_mass_flux_source', FATAL)
        endif

        if (cmt_uses_uw .and. .not. doing_diffusive) then
          call error_mesg ('moist_processes_mod', &
             'currently cannot do non-local cmt with uw as mass &
                                                &flux_source', FATAL)
        endif
          

      endif

  
!----- initialize quantities for global integral package -----

   call diag_integral_field_init ('prec', 'f6.3')
   allocate (prec_intgl(id,jd))

!---------------------------------------------------------------------
!    define output variables indicating whether certain convection 
!    schemes have been activated.
!---------------------------------------------------------------------
     doing_donner = do_donner_deep
     doing_uw_conv = do_uw_conv

!----- initialize clocks -----
   convection_clock = mpp_clock_id( '   Physics_up: Moist Proc: Conv' , grain=CLOCK_MODULE )
   largescale_clock = mpp_clock_id( '   Physics_up: Moist Proc: LS'   , grain=CLOCK_MODULE )
   donner_clock     = mpp_clock_id( '   Moist Processes: Donner_deep' , grain=CLOCK_MODULE )
   mca_clock        = mpp_clock_id( '   Moist Processes: MCA'         , grain=CLOCK_MODULE )
   donner_mca_clock = mpp_clock_id( '   Moist Processes: Donner_MCA'  , grain=CLOCK_MODULE )
   ras_clock        = mpp_clock_id( '   Moist Processes: RAS'         , grain=CLOCK_MODULE )
   closure_clock    = mpp_clock_id( '   Moist Processes: conv_closure', grain=CLOCK_MODULE )
   shallowcu_clock  = mpp_clock_id( '   Moist Processes: Shallow_cu'  , grain=CLOCK_MODULE )
   cmt_clock        = mpp_clock_id( '   Moist Processes: CMT'         , grain=CLOCK_MODULE )
   lscalecond_clock = mpp_clock_id( '   Moist Processes: lscale_cond' , grain=CLOCK_MODULE )
   stratcloud_clock = mpp_clock_id( '   Moist Processes: Strat_cloud' , grain=CLOCK_MODULE )
   bm_clock         = mpp_clock_id( '   Moist Processes: Betts-Miller', grain=CLOCK_MODULE )

       
      nbcphobic = get_tracer_index(MODEL_ATMOS,'bcphob')
      nbcphilic = get_tracer_index(MODEL_ATMOS,'bcphil')
      nomphobic = get_tracer_index(MODEL_ATMOS,'omphob')
      nomphilic = get_tracer_index(MODEL_ATMOS,'omphil')
      ndust1    = get_tracer_index(MODEL_ATMOS,'dust1')
      ndust2    = get_tracer_index(MODEL_ATMOS,'dust2')
      ndust3    = get_tracer_index(MODEL_ATMOS,'dust3')
      ndust4    = get_tracer_index(MODEL_ATMOS,'dust4')
      ndust5    = get_tracer_index(MODEL_ATMOS,'dust5')
      nsalt1 = get_tracer_index(MODEL_ATMOS,'ssalt1')
      nsalt2 = get_tracer_index(MODEL_ATMOS,'ssalt2')
      nsalt3 = get_tracer_index(MODEL_ATMOS,'ssalt3')
      nsalt4 = get_tracer_index(MODEL_ATMOS,'ssalt4')
      nsalt5 = get_tracer_index(MODEL_ATMOS,'ssalt5')

      nDMS      = get_tracer_index(MODEL_ATMOS,'simpleDMS')
      if (nDMS == NO_TRACER) then
        nDMS      = get_tracer_index(MODEL_ATMOS,'dms')
      endif

      nSO2      = get_tracer_index(MODEL_ATMOS,'simpleSO2')
      if (nSO2 == NO_TRACER) then
        nSO2      = get_tracer_index(MODEL_ATMOS,'so2')
      endif

      nSO4      = get_tracer_index(MODEL_ATMOS,'simpleSO4')
      if (nSO4 == NO_TRACER) then
        nSO4      = get_tracer_index(MODEL_ATMOS,'so4')
      endif

      nSOA      = get_tracer_index(MODEL_ATMOS,'SOA')
      nNH4NO3   = get_tracer_index(MODEL_ATMOS,'nh4no3')
      nNH4      = get_tracer_index(MODEL_ATMOS,'nh4')
!---------------------------------------------------------------------
!    retrieve the number of registered tracers in order to determine 
!    which tracers are to be convectively transported.
!---------------------------------------------------------------------
      call get_number_tracers (MODEL_ATMOS, num_prog= num_tracers)
 
!---------------------------------------------------------------------
!    allocate logical arrays to indicate the tracers which are to be
!    transported by the various available convective schemes. 
!    initialize these arrays to .false..
!---------------------------------------------------------------------
      allocate (tracers_in_donner(num_tracers))
      allocate (tracers_in_mca(num_tracers))
      allocate (tracers_in_ras(num_tracers))
      allocate (tracers_in_uw(num_tracers))
      tracers_in_donner = .false.
      tracers_in_mca = .false.
      tracers_in_ras = .false.
      tracers_in_uw = .false.

!----------------------------------------------------------------------
!    for each tracer, determine if it is to be transported by convect-
!    ion, and the convection schemes that are to transport it. set a 
!    logical flag to .true. for each tracer that is to be transported by
!    each scheme and increment the count of tracers to be transported
!    by that scheme.
!----------------------------------------------------------------------
      do n=1, num_tracers
        if (query_method ('convection', MODEL_ATMOS, n, scheme)) then
          select case (scheme)
            case ("none")
            case ("donner")
               num_donner_tracers = num_donner_tracers + 1
               tracers_in_donner(n) = .true.
            case ("mca")
               num_mca_tracers = num_mca_tracers + 1
               tracers_in_mca(n) = .true.
            case ("ras")
               num_ras_tracers = num_ras_tracers + 1
               tracers_in_ras(n) = .true.
            case ("uw")
               num_uw_tracers = num_uw_tracers + 1
               tracers_in_uw(n) = .true.
            case ("donner_and_ras")
               num_donner_tracers = num_donner_tracers + 1
               tracers_in_donner(n) = .true.
               num_ras_tracers = num_ras_tracers + 1
               tracers_in_ras(n) = .true.
            case ("donner_and_mca")
               num_donner_tracers = num_donner_tracers + 1
               tracers_in_donner(n) = .true.
               num_mca_tracers = num_mca_tracers + 1
               tracers_in_mca(n) = .true.
            case ("mca_and_ras")
               num_mca_tracers = num_mca_tracers + 1
               tracers_in_mca(n) = .true.
               num_ras_tracers = num_ras_tracers + 1
               tracers_in_ras(n) = .true.
            case ("all")
               num_donner_tracers = num_donner_tracers + 1
               tracers_in_donner(n) = .true.
               num_mca_tracers = num_mca_tracers + 1
               tracers_in_mca(n) = .true.
               num_ras_tracers = num_ras_tracers + 1
               tracers_in_ras(n) = .true.
               num_uw_tracers = num_uw_tracers + 1
               tracers_in_uw(n) = .true.
            case default  ! corresponds to "none"
          end select
        endif
      end do

!--------------------------------------------------------------------
!    set a logical indicating if any tracers are to be transported by
!    each of the available convection parameterizations.
!--------------------------------------------------------------------
      if (num_donner_tracers > 0) then
        do_tracers_in_donner = .true.
      else
        do_tracers_in_donner = .false.
      endif
      if (num_mca_tracers > 0) then
        do_tracers_in_mca = .true.
      else
        do_tracers_in_mca = .false.
      endif
      if (num_ras_tracers > 0) then
        do_tracers_in_ras = .true.
      else
        do_tracers_in_ras = .false.
      endif
      if (num_uw_tracers > 0) then
        do_tracers_in_uw = .true.
      else
        do_tracers_in_uw = .false.
      endif     
     
!---------------------------------------------------------------------
!    check for proper use of do_unified_convective_closure.
!---------------------------------------------------------------------
      if (do_unified_convective_closure) then
        call error_mesg ('moist_processes_init', &
         'do_unified_convective_closure is currently not allowed &
               & - see rsh', FATAL)
      endif
      if (do_unified_convective_closure) then
        if (.not. (do_donner_deep) .or. .not. (do_uw_conv)   &
            .or. do_ras .or. do_mca ) then
          call error_mesg ('moist_processes_init',  &
             'must have only donner_deep and uw shallow activated &
                &when do_unified_convective_closure is .true.', FATAL)
         endif
      endif
        
!---------------------------------------------------------------------
!    allocate and initialize arrays to hold maximum enthalpy and water
!    imbalances in each column.
!---------------------------------------------------------------------
      allocate (max_enthalpy_imbal (id, jd))
      allocate (max_water_imbal (id, jd))
      max_enthalpy_imbal = 0.
      max_water_imbal = 0.


!--------------------------------------------------------------------
!    initialize the convection scheme modules.
!--------------------------------------------------------------------
      if (do_donner_deep) then
        call get_time (Time, secs, days)
        call donner_deep_init (lonb, latb, pref, axes, secs, days,  &
                               tracers_in_donner,  &
                               do_donner_conservation_checks, &
                               do_unified_convective_closure, using_fms)
        if (do_donner_conservation_checks) then
          allocate (max_enthalpy_imbal_don (id, jd))
          allocate (max_water_imbal_don (id, jd))
          max_enthalpy_imbal_don = 0.
          max_water_imbal_don = 0.
        endif
      endif ! (do_donner_deep)
 
      if (do_ras)  then
        call ras_init (do_strat, do_liq_num, axes,Time, tracers_in_ras)
      endif

      if (do_uw_conv) call uw_conv_init (do_strat, axes, Time, kd, &
                                          tracers_in_uw)

      if (do_mca .or. do_donner_deep)  then
        call  moist_conv_init (axes,Time, tracers_in_mca)
      endif
  
 
!----- initialize quantities for diagnostics output -----
 
      call diag_field_init ( axes, Time, num_tracers, num_donner_tracers )

      if (do_lin_cld_microphys) then
         if (.not. do_strat) call error_mesg ('moist_processes_init',  &
                    'must also activate do_strat when do_lin_cld_microphys is active', FATAL)
         if (do_liq_num) call error_mesg ('moist_processes_init',  &
                    'do_lin_cld_microphys cannot be active with prognostic droplet &
                   & scheme (do_liq_num)', FATAL)
         nqr = get_tracer_index (MODEL_ATMOS, 'rainwat')
         nqs = get_tracer_index (MODEL_ATMOS, 'snowwat')
         nqg = get_tracer_index (MODEL_ATMOS, 'graupel')
         call lin_cld_microphys_init (id, jd, kd, axes, Time)
         ktop = 1
         do k = 1, kd
            if (pref(k) > 10.E2) then
              ktop=k
              exit
            endif
         enddo
         if (mpp_pe() == mpp_root_pe()) &
               write(*,*) 'Top layer for lin_cld_microphys=', ktop, pref(ktop)
      endif

      num_uw_tracers_out = num_uw_tracers
      do_strat_out = do_strat
      module_is_initialized = .true.

!-----------------------------------------------------------------------

end subroutine moist_processes_init

!#######################################################################

subroutine moist_processes_end

      if( .not.module_is_initialized ) return


!----------------close various schemes-----------------

      if (do_strat)       call strat_cloud_end
      if (do_rh_clouds)   call   rh_clouds_end
      if (do_diag_clouds) call  diag_cloud_end
      if (do_donner_deep) call donner_deep_end
      if (do_cmt        ) call cu_mo_trans_end
      if (do_ras        ) call         ras_end
      if (do_uw_conv    ) call     uw_conv_end
      if (do_lin_cld_microphys) call lin_cld_microphys_end

      deallocate (max_water_imbal)
      deallocate (max_enthalpy_imbal)
      if (do_donner_conservation_checks) then
        deallocate (max_water_imbal_don)
        deallocate (max_enthalpy_imbal_don)
      endif

      module_is_initialized = .false.

!-----------------------------------------------------------------------

end subroutine moist_processes_end


!#######################################################################
! <SUBROUTINE NAME="moist_processes_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine moist_processes_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

  if (do_strat)       call strat_cloud_restart(timestamp)
  if (do_diag_clouds) call diag_cloud_restart(timestamp)
  if (do_donner_deep) call donner_deep_restart(timestamp)

end subroutine moist_processes_restart
! </SUBROUTINE> NAME="moist_processes_restart"


!#######################################################################

subroutine diag_field_init ( axes, Time, num_tracers, num_donner_tracers )

  integer,         intent(in) :: axes(4)
  type(time_type), intent(in) :: Time
  integer, intent(in) :: num_donner_tracers
  integer, intent(in) :: num_tracers

  character(len=32) :: tracer_units, tracer_name
  character(len=128) :: diaglname
  integer, dimension(3) :: half = (/1,2,4/)
  integer   :: n, nn

!------------ initializes diagnostic fields in this module -------------

   if ( any((/do_bm,do_bmmass,do_bmomp/)) ) then
      id_qref = register_diag_field ( mod_name, &
        'qref', axes(1:3), Time, &
        'Adjustment reference specific humidity profile', &
        'kg/kg',  missing_value=missing_value               )

      id_tref = register_diag_field ( mod_name, &
        'tref', axes(1:3), Time, &
        'Adjustment reference temperature profile', &
        'K',  missing_value=missing_value                   )

      id_bmflag = register_diag_field (mod_name, &
         'bmflag', axes(1:2), Time, &
         'Betts-Miller flag', &
         'no units', missing_value=missing_value            )

      id_klzbs  = register_diag_field  (mod_name, &
         'klzbs', axes(1:2), Time, &
         'klzb', &
         'no units', missing_value=missing_value            )

      id_cape = register_diag_field ( mod_name, & 
        'cape', axes(1:2), Time, &
        'Convectively available potential energy',      'J/Kg')

      id_cin = register_diag_field ( mod_name, &
        'cin', axes(1:2), Time, &
        'Convective inhibition',                        'J/Kg')
   endif

   if ( do_bm ) then
      id_invtaubmt  = register_diag_field  (mod_name, &
         'invtaubmt', axes(1:2), Time, &
         'Inverse temperature relaxation time', &
         '1/s', missing_value=missing_value            )

      id_invtaubmq = register_diag_field  (mod_name, &
         'invtaubmq', axes(1:2), Time, &
         'Inverse humidity relaxation time', &
         '1/s', missing_value=missing_value            )
   end if  ! if ( do_bm )

   if (do_bmmass) then
      id_massflux = register_diag_field (mod_name, &
         'massflux', axes(1:3), Time, &
         'Massflux implied by temperature adjustment', &
         'm/s', missing_value=missing_value                 )
   end if  ! if ( do_bmmass )

   id_ras_precip = register_diag_field ( mod_name, &
     'ras_precip', axes(1:2), Time, &
    'Precipitation rate from ras ',       'kg/m2/s' )

   id_ras_freq = register_diag_field ( mod_name, &
     'ras_freq', axes(1:2), Time, &
    'frequency of precip from ras ',       'number' , &
         missing_value = missing_value                       )

   id_don_precip = register_diag_field ( mod_name, &
     'don_precip', axes(1:2), Time, &
    'Precipitation rate from donner ',       'kg/m2/s' )

   id_don_freq = register_diag_field ( mod_name, &
     'don_freq', axes(1:2), Time, &
    'frequency of precip from donner ',       'number', &
         missing_value = missing_value                       )

   id_lsc_precip = register_diag_field ( mod_name, &
     'lsc_precip', axes(1:2), Time, &
    'Precipitation rate from lsc ',       'kg/m2/s' )

   id_lsc_freq = register_diag_field ( mod_name, &
     'lsc_freq', axes(1:2), Time, &
    'frequency of precip from lsc ',       'number' , &
         missing_value = missing_value                       )

   id_uw_precip = register_diag_field ( mod_name, &
     'uw_precip', axes(1:2), Time, &
    'Precipitation rate from uw shallow',       'kg/m2/s', &
     interp_method = "conserve_order1" )

   id_uw_snow = register_diag_field ( mod_name, &
     'uw_snow', axes(1:2), Time, &
    'Snow rate from uw shallow',       'kg/m2/s' , &
     interp_method = "conserve_order1" )

   id_uw_freq = register_diag_field ( mod_name, &
     'uw_freq', axes(1:2), Time, &
    'frequency of precip from uw shallow ',       'number' , &
         missing_value = missing_value                       )

   id_tdt_conv = register_diag_field ( mod_name, &
     'tdt_conv', axes(1:3), Time, &
     'Temperature tendency from convection ',    'deg_K/s',  &
                        missing_value=missing_value               )

   id_qdt_conv = register_diag_field ( mod_name, &
     'qdt_conv', axes(1:3), Time, &
     'Spec humidity tendency from convection ',  'kg/kg/s',  &
                        missing_value=missing_value               )

   id_q_conv_col = register_diag_field ( mod_name, &
     'q_conv_col', axes(1:2), Time, &
    'Water vapor path tendency from convection ',   'kg/m2/s' )
   
   id_t_conv_col = register_diag_field ( mod_name, &
     't_conv_col', axes(1:2), Time, &
    'Column static energy tendency from convection ','W/m2' )
   
   id_enth_conv_col = register_diag_field ( mod_name, &
     'enth_conv_col', axes(1:2), Time, &
     'Column enthalpy tendency from convection','W/m2' )
 
   id_wat_conv_col = register_diag_field ( mod_name, &
     'wat_conv_col', axes(1:2), Time, &
     'Column total water tendency from convection','kg(h2o)/m2/s' )

   id_enth_donner_col2 = register_diag_field ( mod_name, &
     'enth_donner_col2', axes(1:2), Time, &
     'column enthalpy tendency from Donner liq precip','W/m2' )
 
   id_enth_donner_col3 = register_diag_field ( mod_name, &
     'enth_donner_col3', axes(1:2), Time, &
      'Column enthalpy tendency from Donner frzn precip','W/m2' )
 
   id_enth_donner_col4 = register_diag_field ( mod_name, &
      'enth_donner_col4', axes(1:2), Time, &
     'Atmospheric column enthalpy tendency from Donner convection', &
                                                            'W/m2' )
 
   id_enth_donner_col5 = register_diag_field ( mod_name, &
      'enth_donner_col5', axes(1:2), Time, &
      'Column enthalpy tendency due to condensate xfer from Donner &
                                                &to lsc','W/m2' )

  id_enth_donner_col6 = register_diag_field ( mod_name, &
     'enth_donner_col6', axes(1:2), Time, &
      'Column enthalpy tendency from donner moisture  &
                     &conservation  adjustment','W/m2' )
 
   id_enth_donner_col7 = register_diag_field ( mod_name, &
      'enth_donner_col7', axes(1:2), Time, &
      'Precip adjustment needed to balance donner moisture  &
                                           &adjustment','kg(h2o)/m2/s' )

   id_enth_donner_col = register_diag_field ( mod_name, &
     'enth_donner_col', axes(1:2), Time, &
     'Column enthalpy imbalance from Donner convection','W/m2' )

   id_wat_donner_col = register_diag_field ( mod_name, &
     'wat_donner_col', axes(1:2), Time, &
  'Column total water tendency from Donner convection','kg(h2o)/m2/s' )

   id_enth_mca_donner_col = register_diag_field ( mod_name, &
     'enth_mca_donner_col', axes(1:2), Time, &
    'Column enthalpy imbalance from Donner MCA convection','W/m2' )

   id_wat_mca_donner_col = register_diag_field ( mod_name, &
     'wat_mca_donner_col', axes(1:2), Time, &
     'Column total water imbalance from Donner MCA convection', &
                                                'kg(h2o)/m2/s' )

   id_enth_uw_col = register_diag_field ( mod_name, &
     'enth_uw_col', axes(1:2), Time, &
     'Column enthalpy tendency from UW convection','W/m2' )
 
   id_wat_uw_col = register_diag_field ( mod_name, &
     'wat_uw_col', axes(1:2), Time, &
      'Column total water tendency from UW convection','kg(h2o)/m2/s' )

   id_scale_uw = register_diag_field ( mod_name, &
     'scale_uw', axes(1:2), Time, &
     'Scaling factor applied to UW convection tendencies','1' )
          
   id_scale_donner = register_diag_field ( mod_name, &
     'scale_donner', axes(1:2), Time, &
     'Scaling factor applied to UW convection tendencies','1' )

   id_prec_conv = register_diag_field ( mod_name, &
     'prec_conv', axes(1:2), Time, &
    'Precipitation rate from convection ',       'kg(h2o)/m2/s', &
     interp_method = "conserve_order1" )

   id_snow_conv = register_diag_field ( mod_name, &
     'snow_conv', axes(1:2), Time, &
    'Frozen precip rate from convection ',       'kg(h2o)/m2/s', &
     interp_method = "conserve_order1" )

   id_snow_tot  = register_diag_field ( mod_name, &
     'snow_tot ', axes(1:2), Time, &
     'Frozen precip rate from all sources',       'kg(h2o)/m2/s', &
      interp_method = "conserve_order1" )

   id_conv_freq = register_diag_field ( mod_name, &
     'conv_freq', axes(1:2), Time, &
    'frequency of convection ',       'number', &
     missing_value = missing_value                       )

   id_gust_conv = register_diag_field ( mod_name, &
     'gust_conv', axes(1:2), Time, &
    'Gustiness resulting from convection ',       'm/s' )

  id_conv_rain3d= register_diag_field ( mod_name, &
     'conv_rain3d', axes(half), Time, &
    'Rain fall rate from convection -3D ',       'kg(h2o)/m2/s' )

   id_conv_snow3d= register_diag_field ( mod_name, &
     'conv_snow3d', axes(half), Time, &
    'Snow fall rate from convection -3D',       'kg(h2o)/m2/s' )

   id_lscale_rain3d= register_diag_field ( mod_name, &
     'lscale_rain3d', axes(half), Time, &
    'Rain fall rate from lscale  -3D ',   'kg(h2o)/m2/s' )

   id_lscale_snow3d= register_diag_field ( mod_name, &
     'lscale_snow3d', axes(half), Time, &
    'Snow fall rate from lscale -3D',       'kg(h2o)/m2/s' )
   

    id_max_enthalpy_imbal    = register_diag_field    &
       (mod_name, 'max_enth_imbal', axes(1:2), Time,  &
        'max enthalpy  imbalance from moist_processes  ', 'W/m2',   &
              missing_value=missing_value)
    id_max_water_imbal    = register_diag_field    &
         (mod_name, 'max_water_imbal', axes(1:2), Time,   &
      'max water  imbalance from moist_processes  ', 'kg(h2o)/m2/s',  &
              missing_value=missing_value)

    id_enth_moist_col = register_diag_field ( mod_name, &
     'enth_moist_col', axes(1:2), Time, &
     'Column enthalpy imbalance from moist processes','W/m2' )
  
    id_wat_moist_col = register_diag_field ( mod_name, &
      'wat_moist_col', axes(1:2), Time, &
      'Column total water imbalance from moist processes','kg/m2/s' )

    if (do_donner_conservation_checks) then
      id_enthint    = register_diag_field    &
            (mod_name, 'enthint_don', axes(1:2), Time,  &
          'atmospheric column enthalpy change from donner', 'W/m2',  &
          missing_value=missing_value)
     id_lcondensint    = register_diag_field    &
         (mod_name, 'lcondensint_don', axes(1:2), Time, &
         'enthalpy transferred by condensate from donner to lscale', &
            'W/m2',  missing_value=missing_value)
     id_lprcp    = register_diag_field    &
             (mod_name, 'lprcpint_don', axes(1:2),   &
              Time, 'enthalpy removed by donner precip', 'W/m2',   &
             missing_value=missing_value)
      id_vertmotion    = register_diag_field    &
             (mod_name, 'vertmotion_don', axes(1:2), Time,  &
           'enthalpy change due to cell and meso motion in donner',  &
             'W/m2', missing_value=missing_value)
     id_enthdiffint    = register_diag_field    &
            (mod_name, 'enthdiffint_don', axes(1:2),   &
             Time, 'enthalpy  imbalance due to donner', 'W/m2',   &
             missing_value=missing_value)
     id_vaporint    = register_diag_field    &
           (mod_name, 'vaporint_don', axes(1:2),   &
            Time, 'column water vapor change', 'kg(h2o)/m2/s',   &
            missing_value=missing_value)
     id_max_enthalpy_imbal_don    = register_diag_field    &
            (mod_name, 'max_enth_imbal_don', axes(1:2),   &
              Time, 'max enthalpy  imbalance from donner', 'W/m**2',  &
              missing_value=missing_value)
     id_max_water_imbal_don    = register_diag_field    &
            (mod_name, 'max_water_imbal_don', axes(1:2),   &
              Time, 'max water imbalance from donner', 'kg(h2o)/m2/s', &
         missing_value=missing_value)
     id_condensint    = register_diag_field    &
           (mod_name, 'condensint_don', axes(1:2), Time,  &
         'column condensate exported from donner to lscale', &
                         'kg(h2o)/m2/s',  missing_value=missing_value )
     id_precipint    = register_diag_field    &
            (mod_name, 'precipint_don', axes(1:2),   &
             Time, 'column precip from donner', 'kg(h2o)/m2/s',   &
              missing_value=missing_value)
     id_diffint    = register_diag_field    &
          (mod_name, 'diffint_don', axes(1:2),   &
            Time, 'water imbalance due to donner', 'kg(h2o)/m2/s',   &
              missing_value=missing_value)
  endif



if (do_strat ) then

   id_qldt_conv = register_diag_field ( mod_name, &
     'qldt_conv', axes(1:3), Time, &
     'Liquid water tendency from convection',      'kg/kg/s',  &
                        missing_value=missing_value               )

   id_qndt_conv = register_diag_field ( mod_name, &
     'qndt_conv', axes(1:3), Time, &
     'Liquid drop tendency from convection',      '#/kg/s',  &
                         missing_value=missing_value               )

   id_qidt_conv = register_diag_field ( mod_name, &
     'qidt_conv', axes(1:3), Time, &
     'Ice water tendency from convection',         'kg/kg/s',  &
                        missing_value=missing_value               )

   id_qadt_conv = register_diag_field ( mod_name, &
     'qadt_conv', axes(1:3), Time, &
     'Cloud fraction tendency from convection',    '1/sec',    &
                        missing_value=missing_value               )

   id_ql_conv_col = register_diag_field ( mod_name, &
     'ql_conv_col', axes(1:2), Time, &
    'Liquid water path tendency from convection',  'kg/m2/s' )
   
   id_qn_conv_col = register_diag_field ( mod_name, &
     'qn_conv_col', axes(1:2), Time, &
     'Liquid drp tendency from convection',  'kg/m2/s' )
 
   id_qi_conv_col = register_diag_field ( mod_name, &
     'qi_conv_col', axes(1:2), Time, &
    'Ice water path tendency from convection',     'kg/m2/s' )
   
   id_qa_conv_col = register_diag_field ( mod_name, &
     'qa_conv_col', axes(1:2), Time, &
    'Cloud mass tendency from convection',         'kg/m2/s' )
      
endif

if ( do_lsc ) then

   id_tdt_ls = register_diag_field ( mod_name, &
     'tdt_ls', axes(1:3), Time, &
       'Temperature tendency from large-scale cond',   'deg_K/s',  &
                        missing_value=missing_value               )

   id_qdt_ls = register_diag_field ( mod_name, &
     'qdt_ls', axes(1:3), Time, &
     'Spec humidity tendency from large-scale cond', 'kg/kg/s',  &
                        missing_value=missing_value               )

   id_prec_ls = register_diag_field ( mod_name, &
     'prec_ls', axes(1:2), Time, &
    'Precipitation rate from large-scale cond',     'kg/m2/s', &
     interp_method = "conserve_order1" )

   id_snow_ls = register_diag_field ( mod_name, &
     'snow_ls', axes(1:2), Time, &
    'Frozen precip rate from large-scale cond',     'kg/m2/s', &
     interp_method = "conserve_order1" )

   id_q_ls_col = register_diag_field ( mod_name, &
     'q_ls_col', axes(1:2), Time, &
    'Water vapor path tendency from large-scale cond','kg/m2/s' )
   
   id_t_ls_col = register_diag_field ( mod_name, &
     't_ls_col', axes(1:2), Time, &
    'Column static energy tendency from large-scale cond','W/m2' )
   
 endif

   id_conv_cld_base = register_diag_field ( mod_name, &
     'conv_cld_base', axes(1:2), Time, &
     'pressure at convective cloud base',   'Pa', &
                       mask_variant = .true., &
                       missing_value=missing_value               )

   id_conv_cld_top = register_diag_field ( mod_name, &
     'conv_cld_top', axes(1:2), Time, &
     'pressure at convective cloud top',   'Pa', &
                       mask_variant = .true., &
                       missing_value=missing_value               )

if ( do_strat ) then

   id_mc_full = register_diag_field ( mod_name, &
     'mc_full', axes(1:3), Time, &
     'Net Mass Flux from convection',   'kg/m2/s', &
                       missing_value=missing_value               )
   
   id_mc_half = register_diag_field ( mod_name, &
     'mc_half', axes(half), Time, &
     'Net Mass Flux from convection on half levs',   'kg/m2/s', &
                       missing_value=missing_value               )
   
   id_tdt_ls = register_diag_field ( mod_name, &
     'tdt_ls', axes(1:3), Time, &
     'Temperature tendency from strat cloud',        'deg_K/s',  &
                        missing_value=missing_value               )

   id_qdt_ls = register_diag_field ( mod_name, &
     'qdt_ls', axes(1:3), Time, &
     'Spec humidity tendency from strat cloud',      'kg/kg/s',  &
                        missing_value=missing_value               )

   id_prec_ls = register_diag_field ( mod_name, &
     'prec_ls', axes(1:2), Time, &
    'Precipitation rate from strat cloud',          'kg/m2/s' )

   id_snow_ls = register_diag_field ( mod_name, &
     'snow_ls', axes(1:2), Time, &
    'Frozen precip rate from strat cloud',          'kg/m2/s' )

   id_q_ls_col = register_diag_field ( mod_name, &
     'q_ls_col', axes(1:2), Time, &
    'Water vapor path tendency from strat cloud',   'kg/m2/s' )
   
   id_t_ls_col = register_diag_field ( mod_name, &
     't_ls_col', axes(1:2), Time, &
    'Column static energy tendency from strat cloud','W/m2' )
   
   id_qldt_ls = register_diag_field ( mod_name, &
     'qldt_ls', axes(1:3), Time, &
     'Liquid water tendency from strat cloud',       'kg/kg/s',  &
                        missing_value=missing_value               )

   id_qndt_ls = register_diag_field ( mod_name, &
     'qndt_ls', axes(1:3), Time, &
     'Drop number tendency from strat cloud',        '#/kg/s',  &
                         missing_value=missing_value               )
   id_qidt_ls = register_diag_field ( mod_name, &
     'qidt_ls', axes(1:3), Time, &
     'Ice water tendency from strat cloud',          'kg/kg/s',  &
                        missing_value=missing_value               )

   id_qadt_ls = register_diag_field ( mod_name, &
     'qadt_ls', axes(1:3), Time, &
     'Cloud fraction tendency from strat cloud',     '1/sec',    &
                        missing_value=missing_value               )

   id_ql_ls_col = register_diag_field ( mod_name, &
     'ql_ls_col', axes(1:2), Time, &
    'Liquid water path tendency from strat cloud',   'kg/m2/s' )
   
   id_qn_ls_col = register_diag_field ( mod_name, &
     'qn_ls_col', axes(1:2), Time, &
     'Column drop number tendency from strat cloud',  '#/m2/s' )

   id_qi_ls_col = register_diag_field ( mod_name, &
     'qi_ls_col', axes(1:2), Time, &
    'Ice water path tendency from strat cloud',      'kg/m2/s' )
   
   id_qa_ls_col = register_diag_field ( mod_name, &
     'qa_ls_col', axes(1:2), Time, &
    'Cloud mass tendency from strat cloud',          'kg/m2/s' )
      
   id_enth_ls_col = register_diag_field ( mod_name, &
     'enth_ls_col', axes(1:2), Time, &
     'Column enthalpy tendency from strat cloud','W/m2' )
 
   id_wat_ls_col = register_diag_field ( mod_name, &
     'wat_ls_col', axes(1:2), Time, &
     'Column total water tendency from strat cloud','kg/m2/s' )

endif

   id_precip = register_diag_field ( mod_name, &
     'precip', axes(1:2), Time, &
     'Total precipitation rate',                     'kg/m2/s', &
      interp_method = "conserve_order1" )

   id_WVP = register_diag_field ( mod_name, &
     'WVP', axes(1:2), Time, &
        'Column integrated water vapor',                'kg/m2'  )

if ( do_strat ) then

   id_LWP = register_diag_field ( mod_name, &
     'LWP', axes(1:2), Time, &
        'Liquid water path',                            'kg/m2'   )

   id_IWP = register_diag_field ( mod_name, &
     'IWP', axes(1:2), Time, &
        'Ice water path',                               'kg/m2'   )

   id_AWP = register_diag_field ( mod_name, &
     'AWP', axes(1:2), Time, &
        'Column integrated cloud mass ',                'kg/m2'   )

    id_tot_cld_amt = register_diag_field    &
              (mod_name, 'cld_amt_2d', axes(1:2), Time, &
                'total cloud amount', 'percent')

    id_tot_cloud_area = register_diag_field ( mod_name, &
      'tot_cloud_area', axes(1:3), Time, &
      'Cloud area -- all clouds', 'percent', missing_value=missing_value )

    id_tot_h2o     = register_diag_field ( mod_name, &
      'tot_h2o', axes(1:3), Time, &
      'total h2o -- all phases', 'kg/kg', missing_value=missing_value)

    id_tot_vapor     = register_diag_field ( mod_name, &
       'tot_vapor', axes(1:3), Time, &
       'total vapor', 'kg/kg', missing_value=missing_value)

    id_tot_liq_amt = register_diag_field ( mod_name, &
      'tot_liq_amt', axes(1:3), Time, &
      'Liquid amount -- all clouds', 'kg/kg', missing_value=missing_value)

    id_tot_ice_amt = register_diag_field ( mod_name, &
      'tot_ice_amt', axes(1:3), Time, &
      'Ice amount -- all clouds', 'kg/kg', missing_value=missing_value )

    id_lsc_cloud_area = register_diag_field ( mod_name, &
      'lsc_cloud_area', axes(1:3), Time, &
      'Large-scale cloud area', 'percent', missing_value=missing_value )

    id_lsc_liq_amt = register_diag_field ( mod_name, &
      'lsc_liq_amt', axes(1:3), Time, &
      'Large-scale cloud liquid amount', 'kg/kg', missing_value=missing_value )

    id_lsc_ice_amt = register_diag_field ( mod_name, &
      'lsc_ice_amt', axes(1:3), Time, &
      'Large-scale cloud ice amount', 'kg/kg', missing_value=missing_value )

    id_conv_cloud_area = register_diag_field ( mod_name, &
      'conv_cloud_area', axes(1:3), Time, &
      'Convective cloud area', 'percent', missing_value=missing_value )

    id_conv_liq_amt = register_diag_field ( mod_name, &
      'conv_liq_amt', axes(1:3), Time, &
      'Convective cloud liquid amount', 'kg/kg', missing_value=missing_value )

    id_conv_ice_amt = register_diag_field ( mod_name, &
      'conv_ice_amt', axes(1:3), Time, &
      'Convective cloud ice amount', 'kg/kg', missing_value=missing_value)
 
    id_WP_all_clouds = register_diag_field ( mod_name, &
      'WP_all_clouds', axes(1:2), Time, &
      'Total  water path -- all clouds',              'kg/m2'   )

    id_LWP_all_clouds = register_diag_field ( mod_name, &
      'LWP_all_clouds', axes(1:2), Time, &
      'Liquid water path -- all clouds',              'kg/m2'   )

    id_IWP_all_clouds = register_diag_field ( mod_name, &
      'IWP_all_clouds', axes(1:2), Time, &
      'Ice water path -- all clouds',                 'kg/m2'   )

endif

   id_tdt_dadj = register_diag_field ( mod_name, &
     'tdt_dadj', axes(1:3), Time, &
   'Temperature tendency from dry conv adj',       'deg_K/s',  &
                        missing_value=missing_value               )

   id_rh = register_diag_field ( mod_name, &
     'rh', axes(1:3), Time, &
         'relative humidity',                            'percent',  & 
                        missing_value=missing_value               )

   id_rh_cmip = register_diag_field ( mod_name, &
     'rh_cmip', axes(1:3), Time, &
     'relative humidity',                            'percent',  &
                      missing_value=missing_value               )

   id_qs = register_diag_field ( mod_name, &
     'qs', axes(1:3), Time, &
         'saturation specific humidity',                 'kg/kg',    & 
                        missing_value=missing_value               )
   
if (do_donner_deep) then

   id_tdt_deep_donner= register_diag_field ( mod_name, &
           'tdt_deep_donner', axes(1:3), Time, &
           ' heating rate - deep portion', 'deg K/s', &
                        missing_value=missing_value               )

   id_qdt_deep_donner = register_diag_field ( mod_name, &
           'qdt_deep_donner', axes(1:3), Time, &
           ' moistening rate - deep portion', 'kg/kg/s', &
                        missing_value=missing_value               )

   id_qadt_deep_donner = register_diag_field ( mod_name, &
     'qadt_deep_donner', axes(1:3), Time, &
     ' cloud amount tendency - deep portion', '1/s', &
                        missing_value=missing_value               )

   id_qldt_deep_donner = register_diag_field ( mod_name, &
     'qldt_deep_donner', axes(1:3), Time, &
     ' cloud liquid tendency - deep portion', 'kg/kg/s', &
                        missing_value=missing_value               )

   id_qidt_deep_donner = register_diag_field ( mod_name, &
     'qidt_deep_donner', axes(1:3), Time, &
     ' ice water tendency - deep portion', 'kg/kg/s', &
                        missing_value=missing_value               )

   id_tdt_mca_donner = register_diag_field ( mod_name, &
     'tdt_mca_donner', axes(1:3), Time, &
     ' heating rate - mca  portion', 'deg K/s', &
                        missing_value=missing_value               )

   id_qdt_mca_donner = register_diag_field ( mod_name, &
           'qdt_mca_donner', axes(1:3), Time, &
           ' moistening rate - mca  portion', 'kg/kg/s', &
                        missing_value=missing_value               )

   id_prec_deep_donner = register_diag_field ( mod_name, &
           'prc_deep_donner', axes(1:2), Time, &
           ' total precip rate - deep portion', 'kg/m2/s', &
                        missing_value=missing_value, &
             interp_method = "conserve_order1"               )

   id_prec1_deep_donner = register_diag_field ( mod_name, &
           'prc1_deep_donner', axes(1:2), Time, &
           ' change in precip for conservation in donner', 'kg/m2/s ', &
              missing_value=missing_value, mask_variant = .true., &
             interp_method = "conserve_order1"  )

   id_prec_mca_donner = register_diag_field ( mod_name, &
           'prc_mca_donner', axes(1:2), Time, &
           ' total precip rate - mca  portion', 'kg/m2/s', &
                        missing_value=missing_value, &
             interp_method = "conserve_order1"               )

   id_snow_deep_donner = register_diag_field ( mod_name, &
           'snow_deep_donner', axes(1:2), Time, &
           ' frozen precip rate - deep portion', 'kg/m2/s', &
                        missing_value=missing_value, &
             interp_method = "conserve_order1"               )

   id_snow_mca_donner = register_diag_field ( mod_name, &
           'snow_mca_donner', axes(1:2), Time, &
           ' frozen precip rate -  mca portion', 'kg/m2/s', &
                        missing_value=missing_value, &
             interp_method = "conserve_order1"               )

   id_mc_donner = register_diag_field ( mod_name, &
           'mc_donner', axes(1:3), Time, &
           'Net Mass Flux from donner',   'kg/m2/s', &
                        missing_value=missing_value               )

   id_mc_donner_half = register_diag_field ( mod_name, &
           'mc_donner_half', axes(half), Time, &
           'Net Mass Flux from donner at half levs',   'kg/m2/s', &
                        missing_value=missing_value               )

   id_mc_conv_up = register_diag_field ( mod_name, &
           'mc_conv_up', axes(1:3), Time, &
          'Upward Mass Flux from convection',   'kg/m2/s', &
                       missing_value=missing_value               )

   id_m_cdet_donner = register_diag_field ( mod_name, &
           'm_cdet_donner', axes(1:3), Time, &
           'Detrained Cell Mass Flux from donner',   'kg/m2/s', &
                        missing_value=missing_value               )

   id_m_cellup = register_diag_field ( mod_name, &
           'm_cellup', axes(half), Time, &
           'Upward Cell Mass Flux from donner',   'kg/m2/s', &
                        missing_value=missing_value               )

endif


if (do_uw_conv) then

   id_tdt_uw = register_diag_field ( mod_name, &
           'tdt_uw', axes(1:3), Time, &
           'UW convection heating rate', 'deg K/s', &
                        missing_value=missing_value               )

   id_qdt_uw = register_diag_field ( mod_name, &
           'qdt_uw', axes(1:3), Time, &
           'UW convection moistening rate', 'kg/kg/s', &
                        missing_value=missing_value               )

   id_qadt_uw = register_diag_field ( mod_name, &
           'qadt_uw', axes(1:3), Time, &
           'UW convection cloud amount tendency', '1/s', &
                        missing_value=missing_value               )

   id_qldt_uw = register_diag_field ( mod_name, &
           'qldt_uw', axes(1:3), Time, &
           'UW convection cloud liquid tendency', 'kg/kg/s', &
                        missing_value=missing_value               )

   id_qidt_uw = register_diag_field ( mod_name, &
           'qidt_uw', axes(1:3), Time, &
           'UW convection ice water tendency', 'kg/kg/s', &
                        missing_value=missing_value               )

   if (do_liq_num) &
    id_qndt_uw = register_diag_field ( mod_name, &
           'qndt_uw', axes(1:3), Time, &
           'UW convection cloud drop tendency', '#/kg/s', &
                        missing_value=missing_value               )

endif

   id_qvout = register_diag_field ( mod_name, &
           'qvout', axes(1:3), Time, 'qv after strat_cloud', 'kg/kg', &
                        missing_value=missing_value               )

   id_qaout = register_diag_field ( mod_name, &
           'qaout', axes(1:3), Time, 'qa after strat_cloud', 'none', &
                        missing_value=missing_value               )

   id_qlout = register_diag_field ( mod_name, &
           'qlout', axes(1:3), Time, 'ql after strat_cloud', 'kg/kg', &
                        missing_value=missing_value               )

   id_qiout = register_diag_field ( mod_name, &
           'qiout', axes(1:3), Time, 'qi after strat_cloud', 'kg/kg', &
                        missing_value=missing_value               )

!---------------------------------------------------------------------
!    register diagnostics for lightning NOx
!---------------------------------------------------------------------

   if (get_tracer_index(MODEL_ATMOS,'no') > 0) &
     id_prod_no = register_diag_field ( 'tracers', &
             'hook_no', axes(1:3), Time, &
             'hook_no',   'molec/cm3/s')

!-----------------------------------------------------------------------
!---------------------------------------------------------------------
!    register the diagnostics associated with convective tracer 
!    transport.
!---------------------------------------------------------------------
      allocate (id_tracerdt_conv    (num_tracers))
      allocate (id_tracerdt_conv_col(num_tracers))
      allocate (id_wet_deposition(num_tracers))
      allocate (id_wetdep       (num_tracers))
      allocate (id_conv_tracer           (num_tracers))
      allocate (id_conv_tracer_col(num_tracers))

      id_tracerdt_conv = -1
      id_tracerdt_conv_col = -1
      id_wet_deposition = -1
      id_wetdep = -1
      id_conv_tracer = -1
      id_conv_tracer_col = -1
      
 
      id_wetdep_om = &
                         register_diag_field ( mod_name, &
                         'om_wet_dep',  &
                         axes(1:2), Time,  &
                         'total om wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_SOA = &
                         register_diag_field ( mod_name, &
                         'SOA_wet_dep',  &
                         axes(1:2), Time,  &
                         'total SOA wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_bc = &
                         register_diag_field ( mod_name, &
                         'bc_wet_dep',  &
                         axes(1:2), Time,  &
                         'total bc wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_so4 = &
                         register_diag_field ( mod_name, &
                         'so4_wet_dep',  &
                         axes(1:2), Time,  &
                         'total so4 wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_so2 = &
                         register_diag_field ( mod_name, &
                         'so2_wet_dep',  &
                         axes(1:2), Time,  &
                         'total so2 wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_DMS = &
                         register_diag_field ( mod_name, &
                         'DMS_wet_dep',  &
                         axes(1:2), Time,  &
                         'total DMS wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_NH4NO3 =  &
                         register_diag_field ( mod_name, &
                         'totNH4_wet_dep',  &
                         axes(1:2), Time,  &
                         'total NH4 + NH3 wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_salt   =  &
                         register_diag_field ( mod_name, &
                         'ssalt_wet_dep',  &
                         axes(1:2), Time,  &
                         'total seasalt wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      id_wetdep_dust   =  &
                         register_diag_field ( mod_name, &
                         'dust_wet_dep',  &
                         axes(1:2), Time,  &
                         'total dust wet deposition', &
                         'kg/m2/s',  &
                         missing_value=missing_value)

      do n = 1,num_tracers
        call get_tracer_names (MODEL_ATMOS, n, name = tracer_name,  &
                               units = tracer_units)
        if (tracers_in_donner(n) .or. &
            tracers_in_ras(n)      .or.  &
            tracers_in_mca(n)      .or.  &
            tracers_in_uw(n)) then

          diaglname = trim(tracer_name)//  &
                        ' wet deposition from all precip'
          id_wetdep(n) = &
                       register_diag_field ( mod_name, &
                          TRIM(tracer_name)//'_wet_depo',  &
                          axes(1:2), Time, trim(diaglname), &
                          TRIM(tracer_units)//'/s',  &
                          missing_value=missing_value)

          diaglname = trim(tracer_name)//  &
                        ' total tendency from moist convection'
          id_tracerdt_conv(n) =    &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'dt_conv',  &
                         axes(1:3), Time, trim(diaglname), &
                         TRIM(tracer_units)//'/s',  &
                         missing_value=missing_value)

          diaglname = trim(tracer_name)//  &
                       ' total path tendency from moist convection'
          id_tracerdt_conv_col(n) =  &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'dt_conv_col', &
                         axes(1:2), Time, trim(diaglname), &
                         TRIM(tracer_units)//'*(kg/m2)/s',   &
                         missing_value=missing_value)
         endif
 
         diaglname = trim(tracer_name)
         id_conv_tracer(n) =    &
                        register_diag_field ( mod_name, &
                        TRIM(tracer_name),  &
                        axes(1:3), Time, trim(diaglname), &
                        TRIM(tracer_units)      ,  &
                        missing_value=missing_value)
         diaglname =  ' column integrated' // trim(tracer_name)
         id_conv_tracer_col(n) =  &
                        register_diag_field ( mod_name, &
                        TRIM(tracer_name)//'_col', &
                        axes(1:2), Time, trim(diaglname), &
                        TRIM(tracer_units)      ,   &
                        missing_value=missing_value)
         id_wet_deposition(n) = register_diag_field( mod_name, &
           trim(tracer_name)//'_wetdep', axes(1:3), Time, &
           trim(tracer_name)//' tendency from wet deposition',TRIM(tracer_units)//'/sec', &
           missing_value=missing_value )
      end do

!------------------------------------------------------------------
!    register the variables associated with the mca component of 
!    donner_deep transport.
!------------------------------------------------------------------
     if (do_donner_deep) then
       allocate (id_tracerdt_mcadon  (num_donner_tracers))
       allocate (id_tracerdt_mcadon_col(num_donner_tracers))
 
       nn = 1
       do n = 1,num_tracers
         call get_tracer_names (MODEL_ATMOS, n, name = tracer_name,  &
                                units = tracer_units)
         if (tracers_in_donner(n) ) then
           diaglname = trim(tracer_name)//  &
                       ' tendency from donner-mca'
           id_tracerdt_mcadon(nn) =    &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'_donmca',  &
                         axes(1:3), Time, trim(diaglname), &
                         TRIM(tracer_units)//'/s',  &
                        missing_value=missing_value)

           diaglname = trim(tracer_name)//  &
                       ' total path tendency from donner-mca'
           id_tracerdt_mcadon_col(nn) =  &
                        register_diag_field ( mod_name, &
                        TRIM(tracer_name)//'_donmca_col', &
                        axes(1:2), Time, trim(diaglname), &
                          TRIM(tracer_units)//'*(kg/m2)/s',   &
                        missing_value=missing_value)
           nn = nn + 1
         endif
       end do
 

     endif

end subroutine diag_field_init


!#######################################################################
function doing_strat()
logical :: doing_strat

  if (.not. module_is_initialized) call error_mesg ('doing_strat',  &
                     'moist_processes_init has not been called.', FATAL)

  doing_strat = do_strat

end function doing_strat


end module moist_processes_mod

  



                    module moist_proc_utils_mod

!-----------------------------------------------------------------------
!
!         interface module for moisture processes
!         ---------------------------------------
!             moist convective adjustment
!             relaxed arakawa-schubert
!             donner deep convection
!             large-scale condensation
!             stratiform prognostic cloud scheme 
!             rel humidity cloud scheme 
!             diagnostic cloud scheme 
!             lin cloud microphysics
!             betts-miller convective adjustment
!
!-----------------------------------------------------------------------

use  sat_vapor_pres_mod, only: compute_qs, lookup_es
use    time_manager_mod, only: time_type
use    diag_manager_mod, only: send_data
use       constants_mod, only: RDGAS, RVGAS

implicit none
private

!------------------ private and public data/interfaces -----------------

public   capecalcnew, tempavg, column_diag, rh_calc

private  column_diag_1, column_diag_2, column_diag_3

interface column_diag
  module procedure column_diag_1, column_diag_2, column_diag_3
end interface column_diag


!--------------------- version number ----------------------------------
character(len=128) :: &
version = '$Id: moist_processes_utils.F90,v 17.0.2.1.2.1.4.1 2010/03/17 20:27:08 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------

real, public, allocatable, dimension(:,:,:) :: pmass

                             contains

!#######################################################################

      subroutine tempavg (pdepth,phalf,temp,tsnow,mask)

!-----------------------------------------------------------------------
!
!    computes a mean atmospheric temperature for the bottom
!    "pdepth" pascals of the atmosphere.
!
!   input:  pdepth     atmospheric layer in pa.
!           phalf      pressure at model layer interfaces
!           temp       temperature at model layers
!           mask       data mask at model layers (0.0 or 1.0)
!
!   output:  tsnow     mean model temperature in the lowest
!                      "pdepth" pascals of the atmosphere
!
!-----------------------------------------------------------------------
      real, intent(in)  :: pdepth
      real, intent(in) , dimension(:,:,:) :: phalf,temp
      real, intent(out), dimension(:,:)   :: tsnow
      real, intent(in) , dimension(:,:,:), optional :: mask
!-----------------------------------------------------------------------
 real, dimension(size(temp,1),size(temp,2)) :: prsum, done, pdel, pdep
 real  sumdone
 integer  k
!-----------------------------------------------------------------------

      tsnow=0.0; prsum=0.0; done=1.0; pdep=pdepth

      do k=size(temp,3),1,-1

         if (present(mask)) then
           pdel(:,:)=(phalf(:,:,k+1)-phalf(:,:,k))*mask(:,:,k)*done(:,:)
         else
           pdel(:,:)=(phalf(:,:,k+1)-phalf(:,:,k))*done(:,:)
         endif

         where ((prsum(:,:)+pdel(:,:))  >  pdep(:,:))
            pdel(:,:)=pdepth-prsum(:,:)
            done(:,:)=0.0
            pdep(:,:)=0.0
         endwhere

         tsnow(:,:)=tsnow(:,:)+pdel(:,:)*temp(:,:,k)
         prsum(:,:)=prsum(:,:)+pdel(:,:)

         sumdone=sum(done(:,:))
         if (sumdone < 1.e-4) exit

      enddo

         tsnow(:,:)=tsnow(:,:)/prsum(:,:)

!-----------------------------------------------------------------------

      end subroutine tempavg

!#######################################################################
!cape calculation.
                                                                                
subroutine capecalcnew(kx,p,phalf,cp,rdgas,rvgas,hlv,kappa,tin,rin,&
                                avgbl,cape,cin)
                                                                                
!
!    Input:
!
!    kx          number of levels
!    p           pressure (index 1 refers to TOA, index kx refers to surface)
!    phalf       pressure at half levels
!    cp          specific heat of dry air
!    rdgas       gas constant for dry air
!    rvgas       gas constant for water vapor (used in Clausius-Clapeyron,
!                not for virtual temperature effects, which are not considered)
!    hlv         latent heat of vaporization
!    kappa       the constant kappa
!    tin         temperature of the environment
!    rin         specific humidity of the environment
!    avgbl       if true, the parcel is averaged in theta and r up to its LCL
!
!    Output:
!    cape        Convective available potential energy
!    cin         Convective inhibition (if there's no LFC, then this is set
!                to zero)
!
!    Algorithm:
!    Start with surface parcel.
!    Calculate the lifting condensation level (uses an analytic formula and a
!       lookup table).
!    Average under the LCL if desired, if this is done, then a new LCL must
!       be calculated.
!    Calculate parcel ascent up to LZB.
!    Calculate CAPE and CIN.
      implicit none
      integer, intent(in)                    :: kx
      logical, intent(in)                    :: avgbl
      real, intent(in), dimension(:)         :: p, phalf, tin, rin
      real, intent(in)                       :: rdgas, rvgas, hlv, kappa, cp
      real, intent(out)                      :: cape, cin
                                                                                
      integer            :: k, klcl, klfc, klzb
      logical            :: nocape
      real, dimension(kx)   :: tp, rp
      real                  :: t0, r0, es, rs, theta0, pstar, value, tlcl, &
                               a, b, dtdlnp, &
                               plcl, plzb

      pstar = 1.e5
                                                                                
      nocape = .true.
      cape = 0.
      cin = 0.
      plcl = 0.
      plzb = 0.
      klfc = 0
      klcl = 0
      klzb = 0
      tp(1:kx) = tin(1:kx)
      rp(1:kx) = rin(1:kx)
                                                                                
! start with surface parcel
      t0 = tin(kx)
      r0 = rin(kx)
! calculate the lifting condensation level by the following:
! are you saturated to begin with?
      call lookup_es(t0,es)
      rs = rdgas/rvgas*es/p(kx)
      if (r0.ge.rs) then
! if you're already saturated, set lcl to be the surface value.
         plcl = p(kx)
! the first level where you're completely saturated.
         klcl = kx
! saturate out to get the parcel temp and humidity at this level
! first order (in delta T) accurate expression for change in temp
         tp(kx) = t0 + (r0 - rs)/(cp/hlv + hlv*rs/rvgas/t0**2.)
         call lookup_es(tp(kx),es)
         rp(kx) = rdgas/rvgas*es/p(kx)
      else
! if not saturated to begin with, use the analytic expression to calculate the
! exact pressure and temperature where you?re saturated.
         theta0 = tin(kx)*(pstar/p(kx))**kappa
! the expression that we utilize is 
! log(r/theta**(1/kappa)*pstar*rvgas/rdgas/es00) = log(es/T**(1/kappa))
! The right hand side of this is only a function of temperature, therefore
! this is put into a lookup table to solve for temperature.
         if (r0.gt.0.) then
            value = log(theta0**(-1/kappa)*r0*pstar*rvgas/rdgas) 
            call lcltabl(value,tlcl)
            plcl = pstar*(tlcl/theta0)**(1/kappa)
! just in case plcl is very high up
            if (plcl.lt.p(1)) then
               plcl = p(1)
               tlcl = theta0*(plcl/pstar)**kappa
               write (*,*) 'hi lcl'
            end if
            k = kx
         else
! if the parcel sp hum is zero or negative, set lcl to 2nd to top level
            plcl = p(2)
            tlcl = theta0*(plcl/pstar)**kappa
!            write (*,*) 'zero r0', r0
            do k=2,kx
               tp(k) = theta0*(p(k)/pstar)**kappa
               rp(k) = 0.
! this definition of CIN contains everything below the LCL
               cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            end do
            go to 11
         end if
! calculate the parcel temperature (adiabatic ascent) below the LCL.
! the mixing ratio stays the same
         do while (p(k).gt.plcl)
            tp(k) = theta0*(p(k)/pstar)**kappa
            call lookup_es(tp(k),es)
            rp(k) = rdgas/rvgas*es/p(k)
! this definition of CIN contains everything below the LCL
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
            k = k-1
         end do
! first level where you're saturated at the level
         klcl = k
         if (klcl.eq.1) klcl = 2
! do a saturated ascent to get the parcel temp at the LCL.
! use your 2nd order equation up to the pressure above.
! moist adaibat derivatives: (use the lcl values for temp, humid, and
! pressure)
         a = kappa*tlcl + hlv/cp*r0
         b = hlv**2.*r0/cp/rvgas/tlcl**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
! second order in p (RK2)
! first get temp halfway up
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)/2.
         if ((tp(klcl).lt.173.16).and.nocape) go to 11
         call lookup_es(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/(p(klcl) + plcl)*2.
         a = kappa*tp(klcl) + hlv/cp*rp(klcl)
         b = hlv**2./cp/rvgas*rp(klcl)/tp(klcl)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl)
!         d2tdlnp2 = (kappa + b - 1. - b/tlcl*(hlv/rvgas/tlcl - &
!                   2.)*dtdlnp)/ (1. + b)*dtdlnp - hlv*r0/cp/ &
!                   (1. + b)
! second order in p
!         tp(klcl) = tlcl + dtdlnp*log(p(klcl)/plcl) + .5*d2tdlnp2*(log(&
!             p(klcl)/plcl))**2.
         if ((tp(klcl).lt.173.16).and.nocape) go to 11
         call lookup_es(tp(klcl),es)
         rp(klcl) = rdgas/rvgas*es/p(klcl)
!         write (*,*) 'tp, rp klcl:kx, new', tp(klcl:kx), rp(klcl:kx)
! CAPE/CIN stuff
         if ((tp(klcl).lt.tin(klcl)).and.nocape) then
! if you're not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(klcl) - &
                 tp(klcl))*log(phalf(klcl+1)/phalf(klcl))
         else
! if you're buoyant, then add to cape
            cape = cape + rdgas*(tp(klcl) - &
                  tin(klcl))*log(phalf(klcl+1)/phalf(klcl))
! if it's the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = klcl
            endif
         end if
      end if
! then, start at the LCL, and do moist adiabatic ascent by the first order
! scheme -- 2nd order as well
      do k=klcl-1,1,-1
         a = kappa*tp(k+1) + hlv/cp*rp(k+1)
         b = hlv**2./cp/rvgas*rp(k+1)/tp(k+1)**2.
         dtdlnp = a/(1. + b)
! first order in p
!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
! second order in p (RK2)
! first get temp halfway up
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))/2.
         if ((tp(k).lt.173.16).and.nocape) go to 11
         call lookup_es(tp(k),es)
         rp(k) = rdgas/rvgas*es/(p(k) + p(k+1))*2.
         a = kappa*tp(k) + hlv/cp*rp(k)
         b = hlv**2./cp/rvgas*rp(k)/tp(k)**2.
         dtdlnp = a/(1. + b)
! second half of RK2
         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1))
!         d2tdlnp2 = (kappa + b - 1. - b/tp(k+1)*(hlv/rvgas/tp(k+1) - &
!               2.)*dtdlnp)/(1. + b)*dtdlnp - hlv/cp*rp(k+1)/(1. + b)
! second order in p

!         tp(k) = tp(k+1) + dtdlnp*log(p(k)/p(k+1)) + .5*d2tdlnp2*(log( &
!             p(k)/p(k+1)))**2.
! if you're below the lookup table value, just presume that there's no way
! you could have cape and call it quits
         if ((tp(k).lt.173.16).and.nocape) go to 11
         call lookup_es(tp(k),es)
         rp(k) = rdgas/rvgas*es/p(k)
         if ((tp(k).lt.tin(k)).and.nocape) then
! if you're not yet buoyant, then add to the CIN and continue
            cin = cin + rdgas*(tin(k) - tp(k))*log(phalf(k+1)/phalf(k))
         elseif((tp(k).lt.tin(k)).and.(.not.nocape)) then
! if you have CAPE, and it's your first time being negatively buoyant,
! then set the level of zero buoyancy to k+1, and stop the moist ascent
            klzb = k+1
            go to 11
         else
! if you're buoyant, then add to cape
            cape = cape + rdgas*(tp(k) - tin(k))*log(phalf(k+1)/phalf(k))
! if it's the first time buoyant, then set the level of free convection to k
            if (nocape) then
               nocape = .false.
               klfc = k
            endif
         end if
      end do
 11   if(nocape) then
! this is if you made it through without having a LZB
! set LZB to be the top level.
         plzb = p(1)
         klzb = 0
         klfc = 0
         cin = 0.
         tp(1:kx) = tin(1:kx)
         rp(1:kx) = rin(1:kx)
      end if
!      write (*,*) 'plcl, klcl, tlcl, r0 new', plcl, klcl, tlcl, r0
!      write (*,*) 'tp, rp new', tp, rp
!       write (*,*) 'tp, new', tp
!       write (*,*) 'tin new', tin
!       write (*,*) 'klcl, klfc, klzb new', klcl, klfc, klzb
      end subroutine capecalcnew


!#######################################################################
! lookup table for the analytic evaluation of LCL
      subroutine lcltabl(value,tlcl)
!
! Table of values used to compute the temperature of the lifting condensation
! level.
!
! the expression that we utilize is 
! log(r/theta**(1/kappa)*pstar*rvgas/rdgas/es00) = log(es/T**(1/kappa))
! the RHS is tabulated for the control amount of moisture, hence the 
! division by es00 on the LHS

! Gives the values of the temperature for the following range:
!   starts with -23, is uniformly distributed up to -10.4.  There are a
! total of 127 values, and the increment is .1.
!
      implicit none
      real, intent(in)     :: value
      real, intent(out)    :: tlcl
      integer              :: ival
      real, dimension(127) :: lcltable
      real                 :: v1, v2
                                                                                
      data lcltable/   1.7364512e+02,   1.7427449e+02,   1.7490874e+02, &
      1.7554791e+02,   1.7619208e+02,   1.7684130e+02,   1.7749563e+02, &
      1.7815514e+02,   1.7881989e+02,   1.7948995e+02,   1.8016539e+02, &
      1.8084626e+02,   1.8153265e+02,   1.8222461e+02,   1.8292223e+02, &
      1.8362557e+02,   1.8433471e+02,   1.8504972e+02,   1.8577068e+02, &
      1.8649767e+02,   1.8723077e+02,   1.8797006e+02,   1.8871561e+02, &
      1.8946752e+02,   1.9022587e+02,   1.9099074e+02,   1.9176222e+02, &
      1.9254042e+02,   1.9332540e+02,   1.9411728e+02,   1.9491614e+02, &
      1.9572209e+02,   1.9653521e+02,   1.9735562e+02,   1.9818341e+02, &
      1.9901870e+02,   1.9986158e+02,   2.0071216e+02,   2.0157057e+02, &
      2.0243690e+02,   2.0331128e+02,   2.0419383e+02,   2.0508466e+02, &
      2.0598391e+02,   2.0689168e+02,   2.0780812e+02,   2.0873335e+02, &
      2.0966751e+02,   2.1061074e+02,   2.1156316e+02,   2.1252493e+02, &
      2.1349619e+02,   2.1447709e+02,   2.1546778e+02,   2.1646842e+02, &
      2.1747916e+02,   2.1850016e+02,   2.1953160e+02,   2.2057364e+02, &
      2.2162645e+02,   2.2269022e+02,   2.2376511e+02,   2.2485133e+02, &
      2.2594905e+02,   2.2705847e+02,   2.2817979e+02,   2.2931322e+02, &
      2.3045895e+02,   2.3161721e+02,   2.3278821e+02,   2.3397218e+02, &
      2.3516935e+02,   2.3637994e+02,   2.3760420e+02,   2.3884238e+02, &
      2.4009473e+02,   2.4136150e+02,   2.4264297e+02,   2.4393941e+02, &
      2.4525110e+02,   2.4657831e+02,   2.4792136e+02,   2.4928053e+02, &
      2.5065615e+02,   2.5204853e+02,   2.5345799e+02,   2.5488487e+02, &
      2.5632953e+02,   2.5779231e+02,   2.5927358e+02,   2.6077372e+02, &
      2.6229310e+02,   2.6383214e+02,   2.6539124e+02,   2.6697081e+02, &
      2.6857130e+02,   2.7019315e+02,   2.7183682e+02,   2.7350278e+02, &
      2.7519152e+02,   2.7690354e+02,   2.7863937e+02,   2.8039954e+02, &
      2.8218459e+02,   2.8399511e+02,   2.8583167e+02,   2.8769489e+02, &
      2.8958539e+02,   2.9150383e+02,   2.9345086e+02,   2.9542719e+02, &
      2.9743353e+02,   2.9947061e+02,   3.0153922e+02,   3.0364014e+02, &
      3.0577420e+02,   3.0794224e+02,   3.1014515e+02,   3.1238386e+02, &
      3.1465930e+02,   3.1697246e+02,   3.1932437e+02,   3.2171609e+02, &
      3.2414873e+02,   3.2662343e+02,   3.2914139e+02,   3.3170385e+02 /
                                                                                
      v1 = value
      if (value.lt.-23.0) v1 = -23.0
      if (value.gt.-10.4) v1 = -10.4
      ival = floor(10.*(v1 + 23.0))
      v2 = -230. + ival
      v1 = 10.*v1
      tlcl = (v2 + 1.0 - v1)*lcltable(ival+1) + (v1 - v2)*lcltable(ival+2)
                                                                                
      end subroutine lcltabl


!#######################################################################
subroutine column_diag_1 (id_diag, is, js, Time, val1, c_val1, temp_in)
  integer, intent(in)                       :: id_diag, is, js
  real, intent(in)                          :: c_val1
  type(time_type), intent(in)               :: Time
  real, dimension(:,:,:), intent(in)        :: val1
  real, dimension(:,:), optional, intent(inout) :: temp_in
!local
  real, dimension(size(val1,1), size(val1,2)) :: temp
  integer :: k
  logical :: used
  integer :: ie, je

  if (present(temp_in)) then
    temp = temp_in
  else
    temp = 0.
  endif

  ie = is + size(val1,1) -1
  je = js + size(val1,2) -1

  do k = 1,size(val1,3)
    temp(:,:) = temp(:,:) + c_val1 * val1(:,:,k) * pmass(is:ie,js:je,k)
  enddo
  used = send_data (id_diag, temp, Time, is, js)

  if (present(temp_in)) temp_in=temp

end subroutine column_diag_1


!#######################################################################
subroutine column_diag_2 (id_diag, is, js, Time, val1, c_val1, val2, c_val2, temp_in)
  integer, intent(in)                       :: id_diag, is, js
  real, intent(in)                          :: c_val1, c_val2
  type(time_type), intent(in)               :: Time
  real, dimension(:,:,:), intent(in)        :: val1, val2
  real, dimension(:,:), optional, intent(inout) :: temp_in
!local
  real, dimension(size(val1,1), size(val1,2)) :: temp
  integer :: k
  logical :: used
  integer :: ie, je

  if (present(temp_in)) then
    temp = temp_in
  else
    temp = 0.
  endif

  ie = is + size(val1,1) -1
  je = js + size(val1,2) -1
  do k = 1,size(val1,3)
    temp(:,:) = temp(:,:) + (c_val1 * val1(:,:,k) + &
                             c_val2 * val2(:,:,k) ) * pmass(is:ie,js:je,k)
  enddo
  used = send_data (id_diag, temp, Time, is, js)

  if (present(temp_in)) temp_in=temp

end subroutine column_diag_2


!#######################################################################
subroutine column_diag_3 (id_diag, is, js, Time, val1, c_val1, val2, c_val2, val3, c_val3, temp_in)
  integer, intent(in)                       :: id_diag, is, js
  real, intent(in)                          :: c_val1, c_val2, c_val3
  type(time_type), intent(in)               :: Time
  real, dimension(:,:,:), intent(in)        :: val1, val2, val3
  real, dimension(:,:), optional, intent(inout) :: temp_in
!local
  real, dimension(size(val1,1), size(val1,2)) :: temp
  integer :: k
  logical :: used
  integer :: ie, je

  if (present(temp_in)) then
    temp = temp_in
  else
    temp = 0.
  endif

  ie = is + size(val1,1) -1
  je = js + size(val1,2) -1
  do k = 1,size(val1,3)
    temp(:,:) = temp(:,:) + (c_val1 * val1(:,:,k) + &
                             c_val2 * val2(:,:,k) + &
                             c_val3 * val3(:,:,k) ) * pmass(is:ie,js:je,k)
  enddo
  used = send_data (id_diag, temp, Time, is, js)

  if (present(temp_in)) temp_in=temp

end subroutine column_diag_3

  
!#######################################################################
subroutine rh_calc(pfull,T,qv,RH,do_simple,MASK, do_cmip)
  
!-----------------------------------------------------------------------
!       Calculate RELATIVE humidity. 
!       This is calculated according to the formula:
! 
!       RH   = qv / (epsilon*esat/ [pfull  -  (1.-epsilon)*esat])
!     
!       Where epsilon = RDGAS/RVGAS = d622
!     
!       and where 1- epsilon = d378
!     
!       Note that RH does not have its proper value 
!       until all of the following code has been executed.  That
!       is, RH is used to store intermediary results
!       in forming the full solution.

        IMPLICIT NONE
        
        REAL, INTENT (IN),    DIMENSION(:,:,:) :: pfull,T,qv
        REAL, INTENT (OUT),   DIMENSION(:,:,:) :: RH
        REAL, INTENT (IN), OPTIONAL, DIMENSION(:,:,:) :: MASK
        logical, intent(in), optional :: do_cmip
        logical, intent(in) :: do_simple
        REAL, DIMENSION(SIZE(T,1),SIZE(T,2),SIZE(T,3)) :: esat
      
        real, parameter :: d622 = RDGAS/RVGAS
        real, parameter :: d378 = 1.-d622

! because Betts-Miller uses a simplified scheme for calculating the relative humidity
        if (do_simple) then
          call lookup_es(T, esat)
          RH(:,:,:) = pfull(:,:,:)
          RH(:,:,:) = MAX(RH(:,:,:),esat(:,:,:))  !limit where pfull ~ esat
          RH(:,:,:)=qv(:,:,:)/(d622*esat(:,:,:)/RH(:,:,:))
        else
          if (present(do_cmip)) then
            call compute_qs (T, pfull, rh, q=qv,  &
                                          es_over_liq_and_ice = .true.)
             RH(:,:,:)=qv(:,:,:)/RH(:,:,:)
          else
            call compute_qs (T, pfull, rh, q=qv)
            RH(:,:,:)=qv(:,:,:)/RH(:,:,:)
          endif
        endif

        !IF MASK is present set RH to zero
        IF (present(MASK)) RH(:,:,:)=MASK(:,:,:)*RH(:,:,:)

END SUBROUTINE rh_calc


!#######################################################################

                 end module moist_proc_utils_mod




module monin_obukhov_mod


!=======================================================================
!
!                         MONIN-OBUKHOV MODULE
!
!          Routines for computing surface drag coefficients 
!                 from data at the lowest model level 
!              and for computing the profile of fields 
!           between the lowest model level and the ground
!                  using Monin-Obukhov scaling 
!
!=======================================================================


use constants_mod, only: grav, vonkarm
use mpp_mod,       only: input_nml_file
use fms_mod,       only: error_mesg, FATAL, file_exist,   &
                         check_nml_error, open_namelist_file,      &
                         mpp_pe, mpp_root_pe, close_file, stdlog, &
                         write_version_number

implicit none
private

!=======================================================================
 public monin_obukhov_init
 public monin_obukhov_end
 public mo_drag
 public mo_profile
 public mo_diff
 public stable_mix
!=======================================================================

interface mo_drag
    module procedure  mo_drag_0d, mo_drag_1d, mo_drag_2d
end interface


interface mo_profile
    module procedure  mo_profile_0d,   mo_profile_1d,   mo_profile_2d, &
                      mo_profile_0d_n, mo_profile_1d_n, mo_profile_2d_n
end interface

interface mo_diff
    module procedure  mo_diff_0d_n, mo_diff_0d_1, &
                      mo_diff_1d_n, mo_diff_1d_1, &
                      mo_diff_2d_n, mo_diff_2d_1
end interface

interface stable_mix
    module procedure  stable_mix_0d, stable_mix_1d, &
                      stable_mix_2d, stable_mix_3d
end interface


!--------------------- version number ---------------------------------

character(len=128) :: version = '$Id: monin_obukhov.F90,v 17.0.6.1 2010/08/30 20:33:35 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

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

!  DEFAULT VALUES OF NAMELIST PARAMETERS:

real    :: rich_crit      = 2.0
real    :: drag_min       = 1.e-05          
logical :: neutral        = .false.
integer :: stable_option  = 1
real    :: zeta_trans     = 0.5


namelist /monin_obukhov_nml/ rich_crit, neutral, drag_min, &
                             stable_option, zeta_trans

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

!  MODULE VARIABLES

real, parameter    :: small  = 1.e-04
real               :: b_stab, r_crit, sqrt_drag_min, lambda, rich_trans
logical            :: module_is_initialized = .false.


contains

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

subroutine monin_obukhov_init

integer :: unit, ierr, io, logunit

!------------------- read namelist input -------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=monin_obukhov_nml, iostat=io)
      ierr = check_nml_error(io,"monin_obukhov_nml")
#else
      if (file_exist('input.nml')) then
         unit = open_namelist_file ()
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=monin_obukhov_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'monin_obukhov_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist to log-------------------------------------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=monin_obukhov_nml)
      endif
      
!----------------------------------------------------------------------

if(rich_crit.le.0.25)  call error_mesg( &
        'MONIN_OBUKHOV_INIT in MONIN_OBUKHOV_MOD', &
        'rich_crit in monin_obukhov_mod must be > 0.25', FATAL)

if(drag_min.le.0.0)  call error_mesg( &
        'MONIN_OBUKHOV_INIT in MONIN_OBUKHOV_MOD', &
        'drag_min in monin_obukhov_mod must be >= 0.0', FATAL)

if(stable_option < 1 .or. stable_option > 2) call error_mesg( &
        'MONIN_OBUKHOV_INIT in MONIN_OBUKHOV_MOD', &
        'the only allowable values of stable_option are 1 and 2', FATAL)

if(stable_option == 2 .and. zeta_trans < 0) call error_mesg( &
        'MONIN_OBUKHOV_INIT in MONIN_OBUKHOV_MOD', &
        'zeta_trans must be positive', FATAL)

b_stab = 1.0/rich_crit
r_crit = 0.95*rich_crit  ! convergence can get slow if one is 
                         ! close to rich_crit

sqrt_drag_min = 0.0
if(drag_min.ne.0.0) sqrt_drag_min = sqrt(drag_min)

lambda     = 1.0 + (5.0 - b_stab)*zeta_trans   ! used only if stable_option = 2
rich_trans = zeta_trans/(1.0 + 5.0*zeta_trans) ! used only if stable_option = 2

module_is_initialized = .true.

return
end subroutine monin_obukhov_init

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

subroutine monin_obukhov_end

module_is_initialized = .false.

end subroutine monin_obukhov_end

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

subroutine mo_drag_1d &
         (pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t, drag_q, &
          u_star, b_star, avail)

real, intent(in)   , dimension(:) :: pt, pt0, z, z0, zt, zq, speed
real, intent(inout), dimension(:) :: drag_m, drag_t, drag_q, u_star, b_star
logical, intent(in), optional, dimension(:) :: avail

logical            :: lavail, avail_dummy(1)
integer            :: n, ier

integer, parameter :: max_iter = 20
real   , parameter :: error=1.e-04, zeta_min=1.e-06, small=1.e-04

! #include "monin_obukhov_interfaces.h"

if(.not.module_is_initialized) call monin_obukhov_init

n      = size(pt)
lavail = .false.
if(present(avail)) lavail = .true.


if(lavail) then 
   if (count(avail) .eq. 0) return
   call monin_obukhov_drag_1d(grav, vonkarm,               &
        & error, zeta_min, max_iter, small,                         &
        & neutral, stable_option, rich_crit, zeta_trans, drag_min,  &
        & n, pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t,         &
        & drag_q, u_star, b_star, lavail, avail, ier)
else
   call monin_obukhov_drag_1d(grav, vonkarm,               &
        & error, zeta_min, max_iter, small,                         &
        & neutral, stable_option, rich_crit, zeta_trans, drag_min,  &
        & n, pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t,         &
        & drag_q, u_star, b_star, lavail, avail_dummy, ier)
endif

end subroutine mo_drag_1d


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

subroutine mo_profile_1d(zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
                         del_m, del_t, del_q, avail)

real,    intent(in)                :: zref, zref_t
real,    intent(in) , dimension(:) :: z, z0, zt, zq, u_star, b_star, q_star
real,    intent(out), dimension(:) :: del_m, del_t, del_q
logical, intent(in) , optional, dimension(:) :: avail

logical                            :: dummy_avail(1)
integer                            :: n, ier

! #include "monin_obukhov_interfaces.h"

if(.not. module_is_initialized) call monin_obukhov_init

n = size(z)
if(present(avail)) then

   if (count(avail) .eq. 0) return

   call monin_obukhov_profile_1d(vonkarm, &
        & neutral, stable_option, rich_crit, zeta_trans, &
        & n, zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
        & del_m, del_t, del_q, .true., avail, ier)

else

   call monin_obukhov_profile_1d(vonkarm, &
        & neutral, stable_option, rich_crit, zeta_trans, &
        & n, zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
        & del_m, del_t, del_q, .false., dummy_avail, ier)

endif

end subroutine mo_profile_1d

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

subroutine stable_mix_3d(rich, mix)

real, intent(in) , dimension(:,:,:)  :: rich
real, intent(out), dimension(:,:,:)  :: mix

integer :: n, ier

if(.not. module_is_initialized) call monin_obukhov_init

n = size(rich,1)*size(rich,2)*size(rich,3)
call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, &
     & n, rich, mix, ier)


end subroutine stable_mix_3d

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

subroutine mo_diff_2d_n(z, u_star, b_star, k_m, k_h)

real, intent(in),  dimension(:,:,:) :: z
real, intent(in),  dimension(:,:)   :: u_star, b_star
real, intent(out), dimension(:,:,:) :: k_m, k_h

integer            :: ni, nj, nk, ier
real, parameter    :: ustar_min = 1.e-10

if(.not.module_is_initialized) call monin_obukhov_init

ni = size(z, 1); nj = size(z, 2); nk = size(z, 3)
call monin_obukhov_diff(vonkarm,                           &
          & ustar_min,                                     &
          & neutral, stable_option, rich_crit, zeta_trans, &
          & ni, nj, nk, z, u_star, b_star, k_m, k_h, ier)

end subroutine mo_diff_2d_n

!=======================================================================
! The following routines are used by the public interfaces above
!=======================================================================

subroutine solve_zeta(rich, z, z0, zt, zq, f_m, f_t, f_q, mask)

real   , intent(in) , dimension(:) :: rich, z, z0, zt, zq
logical, intent(in) , dimension(:) :: mask
real   , intent(out), dimension(:) :: f_m, f_t, f_q


real, parameter    :: error    = 1.e-04
real, parameter    :: zeta_min = 1.e-06
integer, parameter :: max_iter = 20

real    :: max_cor
integer :: iter

real, dimension(size(rich(:))) ::   &
          d_rich, rich_1, correction, corr, z_z0, z_zt, z_zq, &
          ln_z_z0, ln_z_zt, ln_z_zq, zeta,                    &
          phi_m, phi_m_0, phi_t, phi_t_0, rzeta,              &
          zeta_0, zeta_t, zeta_q, df_m, df_t
          
logical, dimension(size(rich(:))) :: mask_1


z_z0 = z/z0
z_zt = z/zt
z_zq = z/zq
ln_z_z0 = log(z_z0)
ln_z_zt = log(z_zt)
ln_z_zq = log(z_zq)

corr = 0.0
mask_1 = mask

! initial guess

where(mask_1) 
  zeta = rich*ln_z_z0*ln_z_z0/ln_z_zt
elsewhere
  zeta = 0.0
end where

where (mask_1 .and. rich >= 0.0)
  zeta = zeta/(1.0 - rich/rich_crit)
end where 

iter_loop: do iter = 1, max_iter

  where (mask_1 .and. abs(zeta).lt.zeta_min) 
    zeta = 0.0
    f_m = ln_z_z0
    f_t = ln_z_zt
    f_q = ln_z_zq
    mask_1 = .false.  ! don't do any more calculations at these pts
  end where
  
  where (mask_1)
    rzeta  = 1.0/zeta
    zeta_0 = zeta/z_z0
    zeta_t = zeta/z_zt
    zeta_q = zeta/z_zq
  elsewhere
    zeta_0 = 0.0
    zeta_t = 0.0
    zeta_q = 0.0
  end where

  call mo_derivative_m(phi_m  , zeta  , mask_1)
  call mo_derivative_m(phi_m_0, zeta_0, mask_1)
  call mo_derivative_t(phi_t  , zeta  , mask_1)
  call mo_derivative_t(phi_t_0, zeta_t, mask_1)
                   
  call mo_integral_m(f_m, zeta, zeta_0, ln_z_z0, mask_1)
  call mo_integral_tq(f_t, f_q, zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq, mask_1)

  where (mask_1)
    df_m  = (phi_m - phi_m_0)*rzeta
    df_t  = (phi_t - phi_t_0)*rzeta
    rich_1 = zeta*f_t/(f_m*f_m)
    d_rich = rich_1*( rzeta +  df_t/f_t - 2.0 *df_m/f_m) 
    correction = (rich - rich_1)/d_rich  
    corr = min(abs(correction),abs(correction/zeta)) 
      ! the criterion corr < error seems to work ok, but is a bit arbitrary
      !  when zeta is small the tolerance is reduced
  end where
  
  max_cor= maxval(corr)

  if(max_cor > error) then
    mask_1 = mask_1 .and. (corr > error)  
       ! change the mask so computation proceeds only on non-converged points
    where(mask_1) 
      zeta = zeta + correction
    end where
    cycle iter_loop
  else
    return
  end if

end do iter_loop

call error_mesg ('solve_zeta in monin_obukhov_mod',  &
                 'surface drag iteration did not converge', FATAL)

end subroutine solve_zeta

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

subroutine mo_derivative_m(phi_m, zeta, mask)

! the differential similarity function for momentum

real    , intent(out),  dimension(:) :: phi_m
real    , intent(in),   dimension(:) :: zeta
logical , intent(in),   dimension(:) :: mask

logical, dimension(size(zeta(:))) :: stable, unstable
real   , dimension(size(zeta(:))) :: x

stable   = mask .and. zeta >= 0.0
unstable = mask .and. zeta <  0.0

where (unstable) 
  x     = (1 - 16.0*zeta  )**(-0.5)
  phi_m = sqrt(x)  ! phi_m = (1 - 16.0*zeta)**(-0.25)
end where

if(stable_option == 1) then 

  where (stable) 
    phi_m = 1.0 + zeta  *(5.0 + b_stab*zeta)/(1.0 + zeta)
  end where
  
else if(stable_option == 2) then

  where (stable .and. zeta < zeta_trans)
    phi_m = 1 + 5.0*zeta
  end where
  where (stable .and. zeta >= zeta_trans)
    phi_m = lambda + b_stab*zeta
  end where

endif

return
end subroutine mo_derivative_m

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

subroutine mo_derivative_t(phi_t, zeta, mask)

! the differential similarity function for buoyancy and tracers

real    , intent(out),  dimension(:) :: phi_t
real    , intent(in),   dimension(:) :: zeta
logical , intent(in),   dimension(:) :: mask

logical, dimension(size(zeta(:))) :: stable, unstable

stable   = mask .and. zeta >= 0.0
unstable = mask .and. zeta <  0.0

where (unstable) 
  phi_t = (1 - 16.0*zeta)**(-0.5)
end where

if(stable_option == 1) then 

  where (stable) 
    phi_t = 1.0 + zeta*(5.0 + b_stab*zeta)/(1.0 + zeta)
  end where
  
else if(stable_option == 2) then

  where (stable .and. zeta < zeta_trans)
    phi_t = 1 + 5.0*zeta
  end where
  where (stable .and. zeta >= zeta_trans)
    phi_t = lambda + b_stab*zeta
  end where

endif

return
end subroutine mo_derivative_t

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

subroutine mo_integral_tq (psi_t, psi_q, zeta, zeta_t, zeta_q, &
                           ln_z_zt, ln_z_zq, mask)

! the integral similarity function for moisture and tracers

real    , intent(out), dimension(:) :: psi_t, psi_q
real    , intent(in),  dimension(:) :: zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq
logical , intent(in),  dimension(:) :: mask

real, dimension(size(zeta(:))) :: x, x_t, x_q
                               
logical, dimension(size(zeta(:))) :: stable, unstable, &
                                  weakly_stable, strongly_stable

stable   = mask .and. zeta >= 0.0
unstable = mask .and. zeta <  0.0

where(unstable) 

  x     = sqrt(1 - 16.0*zeta)
  x_t   = sqrt(1 - 16.0*zeta_t)
  x_q   = sqrt(1 - 16.0*zeta_q)
  
  psi_t = ln_z_zt - 2.0*log( (1.0 + x)/(1.0 + x_t) )
  psi_q = ln_z_zq - 2.0*log( (1.0 + x)/(1.0 + x_q) )

end where

if( stable_option == 1) then

  where (stable) 
  
    psi_t = ln_z_zt + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_t)) &
       + b_stab*(zeta - zeta_t) 
    psi_q = ln_z_zq + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_q)) &
       + b_stab*(zeta - zeta_q) 
       
  end where
  
else if (stable_option == 2) then

  weakly_stable   = stable .and. zeta <= zeta_trans
  strongly_stable = stable .and. zeta >  zeta_trans

  where (weakly_stable)
    psi_t = ln_z_zt + 5.0*(zeta - zeta_t) 
    psi_q = ln_z_zq + 5.0*(zeta - zeta_q) 
  end where
  
  where(strongly_stable)
    x = (lambda - 1.0)*log(zeta/zeta_trans) + b_stab*(zeta - zeta_trans)
  endwhere
  
  where (strongly_stable .and. zeta_t <= zeta_trans)
    psi_t = ln_z_zt + x + 5.0*(zeta_trans - zeta_t)
  end where
  where (strongly_stable .and. zeta_t > zeta_trans)
    psi_t = lambda*ln_z_zt + b_stab*(zeta  - zeta_t)
  endwhere
  
  where (strongly_stable .and. zeta_q <= zeta_trans)
    psi_q = ln_z_zq + x + 5.0*(zeta_trans - zeta_q)
  end where
  where (strongly_stable .and. zeta_q > zeta_trans)
    psi_q = lambda*ln_z_zq + b_stab*(zeta  - zeta_q)
  endwhere
  
end if

return
end subroutine mo_integral_tq

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

subroutine mo_integral_m (psi_m, zeta, zeta_0, ln_z_z0, mask)

!  the integral similarity function for momentum

real    , intent(out), dimension(:) :: psi_m
real    , intent(in),  dimension(:) :: zeta, zeta_0, ln_z_z0
logical , intent(in),  dimension(:) :: mask

real, dimension(size(zeta(:))) :: x, x_0, x1, x1_0, num, denom, y
                               
logical, dimension(size(zeta(:))) :: stable, unstable, &
                                  weakly_stable, strongly_stable

stable   = mask .and. zeta >= 0.0
unstable = mask .and. zeta <  0.0

where(unstable) 

  x     = sqrt(1 - 16.0*zeta)
  x_0   = sqrt(1 - 16.0*zeta_0)

  x      = sqrt(x)
  x_0    = sqrt(x_0)
  
  x1     = 1.0 + x
  x1_0   = 1.0 + x_0
  
  num    = x1*x1*(1.0 + x*x)
  denom  = x1_0*x1_0*(1.0 + x_0*x_0)
  y      = atan(x) - atan(x_0)
  psi_m  = ln_z_z0 - log(num/denom) + 2*y
  
end where

if( stable_option == 1) then

  where (stable) 
    psi_m = ln_z_z0 + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_0)) &
       + b_stab*(zeta - zeta_0) 
  end where
  
else if (stable_option == 2) then

  weakly_stable   = stable .and. zeta <= zeta_trans
  strongly_stable = stable .and. zeta >  zeta_trans

  where (weakly_stable)
    psi_m = ln_z_z0 + 5.0*(zeta - zeta_0) 
  end where
  
  where(strongly_stable)
    x = (lambda - 1.0)*log(zeta/zeta_trans) + b_stab*(zeta - zeta_trans)
  endwhere
  
  where (strongly_stable .and. zeta_0 <= zeta_trans)
    psi_m = ln_z_z0 + x + 5.0*(zeta_trans - zeta_0)
  end where
  where (strongly_stable .and. zeta_0 > zeta_trans)
    psi_m = lambda*ln_z_z0 + b_stab*(zeta  - zeta_0)
  endwhere
  
end if

return
end subroutine mo_integral_m


!=======================================================================
! The following routines allow the public interfaces to be used
! with different dimensions of the input and output
!
!=======================================================================


subroutine mo_drag_2d &
    (pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t, drag_q, u_star, b_star)

real, intent(in)   , dimension(:,:) :: z, speed, pt, pt0, z0, zt, zq
real, intent(out)  , dimension(:,:) :: drag_m, drag_t, drag_q
real, intent(inout), dimension(:,:) :: u_star, b_star

integer :: j

do j = 1, size(pt,2)
  call mo_drag_1d (pt(:,j), pt0(:,j), z(:,j), z0(:,j), zt(:,j), zq(:,j), &
                   speed(:,j), drag_m(:,j), drag_t(:,j), drag_q(:,j), &
                   u_star(:,j), b_star(:,j))
end do


return
end subroutine mo_drag_2d

!=======================================================================
subroutine mo_drag_0d &
    (pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t, drag_q, u_star, b_star)

real, intent(in)    :: z, speed, pt, pt0, z0, zt, zq
real, intent(out)   :: drag_m, drag_t, drag_q, u_star, b_star

real, dimension(1) :: pt_1, pt0_1, z_1, z0_1, zt_1, zq_1, speed_1, &
                      drag_m_1, drag_t_1, drag_q_1, u_star_1, b_star_1

pt_1   (1) = pt
pt0_1  (1) = pt0
z_1    (1) = z
z0_1   (1) = z0
zt_1   (1) = zt
zq_1   (1) = zq
speed_1(1) = speed

call mo_drag_1d (pt_1, pt0_1, z_1, z0_1, zt_1, zq_1, speed_1, &
                 drag_m_1, drag_t_1, drag_q_1, u_star_1, b_star_1)

drag_m = drag_m_1(1)
drag_t = drag_t_1(1)
drag_q = drag_q_1(1)
u_star = u_star_1(1)
b_star = b_star_1(1)

return
end subroutine mo_drag_0d
!=======================================================================

subroutine mo_profile_2d(zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
                         del_m, del_h, del_q)

real, intent(in)                  :: zref, zref_t
real, intent(in) , dimension(:,:) :: z, z0, zt, zq, u_star, b_star, q_star
real, intent(out), dimension(:,:) :: del_m, del_h, del_q

integer :: j

do j = 1, size(z,2)
  call mo_profile_1d (zref, zref_t, z(:,j), z0(:,j), zt(:,j),         &
                      zq(:,j), u_star(:,j), b_star(:,j), q_star(:,j), &
                      del_m(:,j), del_h (:,j), del_q (:,j))
enddo

return
end subroutine mo_profile_2d

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

subroutine mo_profile_0d(zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
                         del_m, del_h, del_q)

real, intent(in)  :: zref, zref_t
real, intent(in)  :: z, z0, zt, zq, u_star, b_star, q_star
real, intent(out) :: del_m, del_h, del_q

real, dimension(1) :: z_1, z0_1, zt_1, zq_1, u_star_1, b_star_1, q_star_1, &
                      del_m_1, del_h_1, del_q_1

z_1     (1) = z
z0_1    (1) = z0
zt_1    (1) = zt
zq_1    (1) = zq
u_star_1(1) = u_star
b_star_1(1) = b_star
q_star_1(1) = q_star

call mo_profile_1d (zref, zref_t, z_1, z0_1, zt_1, zq_1, &
                    u_star_1, b_star_1, q_star_1,        &
                    del_m_1, del_h_1, del_q_1)
                    
del_m = del_m_1(1)
del_h = del_h_1(1)
del_q = del_q_1(1)
                    

return
end subroutine mo_profile_0d

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

subroutine mo_profile_1d_n(zref, z, z0, zt, zq, u_star, b_star, q_star, &
                         del_m, del_t, del_q, avail)

real,    intent(in),  dimension(:)   :: zref
real,    intent(in) , dimension(:)   :: z, z0, zt, zq, u_star, b_star, q_star
real,    intent(out), dimension(:,:) :: del_m, del_t, del_q
logical, intent(in) , optional, dimension(:) :: avail

integer :: k

do k = 1, size(zref(:))
  if(present(avail)) then
    call mo_profile_1d (zref(k), zref(k), z, z0, zt, zq, &
       u_star, b_star, q_star, del_m(:,k), del_t(:,k), del_q(:,k), avail)
  else 
      call mo_profile_1d (zref(k), zref(k), z, z0, zt, zq, &
       u_star, b_star, q_star, del_m(:,k), del_t(:,k), del_q(:,k))
  endif
enddo

return
end subroutine mo_profile_1d_n

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

subroutine mo_profile_0d_n(zref, z, z0, zt, zq, u_star, b_star, q_star, &
                         del_m, del_t, del_q)

real,    intent(in),  dimension(:) :: zref
real,    intent(in)                :: z, z0, zt, zq, u_star, b_star, q_star
real,    intent(out), dimension(:) :: del_m, del_t, del_q

integer :: k

do k = 1, size(zref(:))
  call mo_profile_0d (zref(k), zref(k), z, z0, zt, zq, &
       u_star, b_star, q_star, del_m(k), del_t(k), del_q(k))
enddo

return
end subroutine mo_profile_0d_n

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

subroutine mo_profile_2d_n(zref, z, z0, zt, zq, u_star, b_star, q_star, &
                         del_m, del_t, del_q)

real,    intent(in),  dimension(:)     :: zref
real,    intent(in),  dimension(:,:)   :: z, z0, zt, zq, u_star, b_star, q_star
real,    intent(out), dimension(:,:,:) :: del_m, del_t, del_q

integer :: k

do k = 1, size(zref(:))
  call mo_profile_2d (zref(k), zref(k), z, z0, zt, zq, &
       u_star, b_star, q_star, del_m(:,:,k), del_t(:,:,k), del_q(:,:,k))
enddo

return
end subroutine mo_profile_2d_n

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

subroutine mo_diff_2d_1(z, u_star, b_star, k_m, k_h)

real, intent(in),  dimension(:,:) :: z, u_star, b_star
real, intent(out), dimension(:,:) :: k_m, k_h

real   , dimension(size(z,1),size(z,2),1) :: z_n, k_m_n, k_h_n

z_n(:,:,1) = z

call mo_diff_2d_n(z_n, u_star, b_star, k_m_n, k_h_n)

k_m = k_m_n(:,:,1)
k_h = k_h_n(:,:,1)

return
end subroutine mo_diff_2d_1


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

subroutine mo_diff_1d_1(z, u_star, b_star, k_m, k_h)

real, intent(in),  dimension(:) :: z, u_star, b_star
real, intent(out), dimension(:) :: k_m, k_h

real, dimension(size(z),1,1) :: z_n, k_m_n, k_h_n
real, dimension(size(z),1)   :: u_star_n, b_star_n

z_n   (:,1,1) = z
u_star_n(:,1) = u_star
b_star_n(:,1) = b_star

call mo_diff_2d_n(z_n, u_star_n, b_star_n, k_m_n, k_h_n)

k_m = k_m_n(:,1,1)
k_h = k_h_n(:,1,1)

return
end subroutine mo_diff_1d_1

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

subroutine mo_diff_1d_n(z, u_star, b_star, k_m, k_h)

real, intent(in),  dimension(:,:) :: z
real, intent(in),  dimension(:)   :: u_star, b_star
real, intent(out), dimension(:,:) :: k_m, k_h

real, dimension(size(z,1),1)            :: u_star2, b_star2
real, dimension(size(z,1),1, size(z,2)) :: z2, k_m2, k_h2

integer :: n

do n = 1, size(z,2)
  z2   (:,1,n) = z(:,n)
enddo
u_star2(:,1) = u_star
b_star2(:,1) = b_star

call mo_diff_2d_n(z2, u_star2, b_star2, k_m2, k_h2)

do n = 1, size(z,2)
  k_m(:,n) = k_m2(:,1,n)
  k_h(:,n) = k_h2(:,1,n)
enddo

return
end subroutine mo_diff_1d_n

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

subroutine mo_diff_0d_1(z, u_star, b_star, k_m, k_h)

real, intent(in)  :: z, u_star, b_star
real, intent(out) :: k_m, k_h

integer            :: ni, nj, nk, ier
real, parameter    :: ustar_min = 1.e-10

if(.not.module_is_initialized) call monin_obukhov_init

ni = 1; nj = 1; nk = 1
call monin_obukhov_diff(vonkarm,                           &
          & ustar_min,                                     &
          & neutral, stable_option, rich_crit, zeta_trans, &
          & ni, nj, nk, z, u_star, b_star, k_m, k_h, ier)

end subroutine mo_diff_0d_1

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

subroutine mo_diff_0d_n(z, u_star, b_star, k_m, k_h)

real, intent(in),  dimension(:) :: z
real, intent(in)                :: u_star, b_star
real, intent(out), dimension(:) :: k_m, k_h

integer            :: ni, nj, nk, ier
real, parameter    :: ustar_min = 1.e-10

if(.not.module_is_initialized) call monin_obukhov_init

ni = 1; nj = 1; nk = size(z(:))
call monin_obukhov_diff(vonkarm,                           &
          & ustar_min,                                     &
          & neutral, stable_option, rich_crit, zeta_trans, &
          & ni, nj, nk, z, u_star, b_star, k_m, k_h, ier)

end subroutine mo_diff_0d_n

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

subroutine stable_mix_2d(rich, mix)

real, intent(in) , dimension(:,:)  :: rich
real, intent(out), dimension(:,:)  :: mix

real, dimension(size(rich,1),size(rich,2),1) :: rich_3d, mix_3d

rich_3d(:,:,1) = rich

call stable_mix_3d(rich_3d, mix_3d)

mix = mix_3d(:,:,1)

return
end subroutine stable_mix_2d


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

subroutine stable_mix_1d(rich, mix)

real, intent(in) , dimension(:)  :: rich
real, intent(out), dimension(:)  :: mix

real, dimension(size(rich),1,1) :: rich_3d, mix_3d

rich_3d(:,1,1) = rich

call stable_mix_3d(rich_3d, mix_3d)

mix = mix_3d(:,1,1)

return
end subroutine stable_mix_1d

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

subroutine stable_mix_0d(rich, mix)

real, intent(in) :: rich
real, intent(out) :: mix

real, dimension(1,1,1) :: rich_3d, mix_3d

rich_3d(1,1,1) = rich

call stable_mix_3d(rich_3d, mix_3d)

mix = mix_3d(1,1,1)

return
end subroutine stable_mix_0d
!=======================================================================

end module monin_obukhov_mod



#include <fms_platform.h>

! -*-F90-*-
! $Id: monin_obukhov_kernel.F90,v 13.0 2006/03/28 21:10:33 fms Exp $

!==============================================================================
! Kernel routine interface
!==============================================================================

module monin_obukhov_inter

! explicit interface to all kernel routines
#include "monin_obukhov_interfaces.h"

end module monin_obukhov_inter

!==============================================================================
! Kernel routines
!==============================================================================

_PURE subroutine monin_obukhov_diff(vonkarm,                &
     & ustar_min,                                     &
     & neutral, stable_option, rich_crit, zeta_trans, &
     & ni, nj, nk, z, u_star, b_star, k_m, k_h, ier)

  implicit none

  real   , intent(in   )                        :: vonkarm
  real   , intent(in   )                        :: ustar_min ! = 1.e-10
  logical, intent(in   )                        :: neutral
  integer, intent(in   )                        :: stable_option
  real   , intent(in   )                        :: rich_crit, zeta_trans
  integer, intent(in   )                        :: ni, nj, nk
  real   , intent(in   ), dimension(ni, nj, nk) :: z
  real   , intent(in   ), dimension(ni, nj)     :: u_star, b_star
  real   , intent(  out), dimension(ni, nj, nk) :: k_m, k_h
  integer, intent(  out)                        :: ier

  real , dimension(ni, nj) :: phi_m, phi_h, zeta, uss
  integer :: j, k

  logical, dimension(ni) :: mask

  interface
     _PURE subroutine monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
          & n, phi_t, zeta, mask, ier)

       ! the differential similarity function for buoyancy and tracers
       ! Note: seems to be the same as monin_obukhov_derivative_m?

       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: phi_t
       real   , intent(in   ), dimension(n)  :: zeta
       logical, intent(in   ), dimension(n)  :: mask  
       integer, intent(  out)                :: ier
     end subroutine monin_obukhov_derivative_t

     _PURE subroutine monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
          & n, phi_m, zeta, mask, ier)

       ! the differential similarity function for momentum

       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: phi_m
       real   , intent(in   ), dimension(n)  :: zeta
       logical, intent(in   ), dimension(n)  :: mask
       integer, intent(out  )                :: ier
     end subroutine monin_obukhov_derivative_m
  end interface

  ier = 0

  mask = .true.
  uss = max(u_star, ustar_min)

  if(neutral) then
     do k = 1, size(z,3)
        k_m(:,:,k) = vonkarm *uss*z(:,:,k)
        k_h(:,:,k) = k_m(:,:,k)
     end do
  else
     do k = 1, size(z,3)
        zeta = - vonkarm * b_star*z(:,:,k)/(uss*uss)
        do j = 1, size(z,2)
           call monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
                & ni, phi_m(:,j), zeta(:,j), mask, ier)
           call monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
                & ni, phi_h(:,j), zeta(:,j), mask, ier)
        enddo
        k_m(:,:,k) = vonkarm * uss*z(:,:,k)/phi_m
        k_h(:,:,k) = vonkarm * uss*z(:,:,k)/phi_h
     end do
  endif

end subroutine monin_obukhov_diff
!==============================================================================
_PURE subroutine monin_obukhov_drag_1d(grav, vonkarm,               &
     & error, zeta_min, max_iter, small,                         &
     & neutral, stable_option, rich_crit, zeta_trans, drag_min,  &
     & n, pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t,         &
     & drag_q, u_star, b_star, lavail, avail, ier)

  implicit none

  real   , intent(in   )                :: grav     
  real   , intent(in   )                :: vonkarm   
  real   , intent(in   )                :: error    ! = 1.e-04
  real   , intent(in   )                :: zeta_min ! = 1.e-06
  integer, intent(in   )                :: max_iter ! = 20
  real   , intent(in   )                :: small    ! = 1.e-04
  logical, intent(in   )                :: neutral
  integer, intent(in   )                :: stable_option
  real   , intent(in   )                :: rich_crit, zeta_trans, drag_min
  integer, intent(in   )                :: n
  real   , intent(in   ), dimension(n)  :: pt, pt0, z, z0, zt, zq, speed
  real   , intent(inout), dimension(n)  :: drag_m, drag_t, drag_q, u_star, b_star
  logical, intent(in   )                :: lavail ! whether to use provided mask or not
  logical, intent(in   ), dimension(n)  :: avail  ! provided mask 
  integer, intent(out  )                :: ier

  real   , dimension(n) :: rich, fm, ft, fq, zz
  logical, dimension(n) :: mask, mask_1, mask_2
  real   , dimension(n) :: delta_b !!, us, bs, qs
  real                  :: r_crit, sqrt_drag_min
  real                  :: us, bs, qs
  integer               :: i

  interface
     _PURE subroutine monin_obukhov_solve_zeta(error, zeta_min, max_iter, small,  &
          & stable_option, rich_crit, zeta_trans,                           &
          & n, rich, z, z0, zt, zq, f_m, f_t, f_q, mask, ier)

       real   , intent(in   )                :: error    ! = 1.e-04
       real   , intent(in   )                :: zeta_min ! = 1.e-06
       integer, intent(in   )                :: max_iter ! = 20
       real   , intent(in   )                :: small    ! = 1.e-04
       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(in   ), dimension(n)  :: rich, z, z0, zt, zq
       logical, intent(in   ), dimension(n)  :: mask
       real   , intent(  out), dimension(n)  :: f_m, f_t, f_q
       integer, intent(  out)                :: ier
     end subroutine monin_obukhov_solve_zeta
  end interface

  ier = 0
  r_crit = 0.95*rich_crit  ! convergence can get slow if one is 
                           ! close to rich_crit
  sqrt_drag_min = 0.0
  if(drag_min.ne.0.0) sqrt_drag_min = sqrt(drag_min)

  mask = .true.
  if(lavail) mask = avail

  where(mask) 
     delta_b = grav*(pt0 - pt)/pt0
     rich    = - z*delta_b/(speed*speed + small)
     zz      = max(z,z0,zt,zq)
  elsewhere 
     rich = 0.0
  end where

  if(neutral) then

     do i = 1, n
        if(mask(i)) then
           fm(i)   = log(zz(i)/z0(i))
           ft(i)   = log(zz(i)/zt(i))
           fq(i)   = log(zz(i)/zq(i))
           us   = vonkarm/fm(i)
           bs   = vonkarm/ft(i)
           qs   = vonkarm/fq(i)
           drag_m(i)    = us*us
           drag_t(i)    = us*bs
           drag_q(i)    = us*qs
           u_star(i) = us*speed(i)
           b_star(i) = bs*delta_b(i)
        end if
     enddo

  else

     mask_1 = mask .and. rich <  r_crit
     mask_2 = mask .and. rich >= r_crit

     do i = 1, n
        if(mask_2(i)) then
           drag_m(i)   = drag_min
           drag_t(i)   = drag_min
           drag_q(i)   = drag_min
           us       = sqrt_drag_min
           bs       = sqrt_drag_min
           u_star(i)   = us*speed(i)
           b_star(i)   = bs*delta_b(i)
        end if
     enddo

     call monin_obukhov_solve_zeta (error, zeta_min, max_iter, small, &
          & stable_option, rich_crit, zeta_trans,                     &
          & n, rich, zz, z0, zt, zq, fm, ft, fq, mask_1, ier)

     do i = 1, n
        if(mask_1(i)) then
           us   = max(vonkarm/fm(i), sqrt_drag_min)
           bs   = max(vonkarm/ft(i), sqrt_drag_min)
           qs   = max(vonkarm/fq(i), sqrt_drag_min)
           drag_m(i)   = us*us
           drag_t(i)   = us*bs
           drag_q(i)   = us*qs
           u_star(i)   = us*speed(i)
           b_star(i)   = bs*delta_b(i)
        endif
     enddo

  end if

end subroutine monin_obukhov_drag_1d
!==============================================================================
_PURE subroutine monin_obukhov_solve_zeta(error, zeta_min, max_iter, small,  &
     & stable_option, rich_crit, zeta_trans,                           &
     & n, rich, z, z0, zt, zq, f_m, f_t, f_q, mask, ier)

  implicit none

  real   , intent(in   )                :: error    ! = 1.e-04
  real   , intent(in   )                :: zeta_min ! = 1.e-06
  integer, intent(in   )                :: max_iter ! = 20
  real   , intent(in   )                :: small    ! = 1.e-04
  integer, intent(in   )                :: stable_option
  real   , intent(in   )                :: rich_crit, zeta_trans
  integer, intent(in   )                :: n
  real   , intent(in   ), dimension(n)  :: rich, z, z0, zt, zq
  logical, intent(in   ), dimension(n)  :: mask
  real   , intent(  out), dimension(n)  :: f_m, f_t, f_q
  integer, intent(  out)                :: ier


  real    :: max_cor
  integer :: iter

  real, dimension(n) ::   &
       d_rich, rich_1, correction, corr, z_z0, z_zt, z_zq, &
       ln_z_z0, ln_z_zt, ln_z_zq, zeta,                    &
       phi_m, phi_m_0, phi_t, phi_t_0, rzeta,              &
       zeta_0, zeta_t, zeta_q, df_m, df_t

  logical, dimension(n) :: mask_1

  interface
     _PURE subroutine monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
          & n, phi_t, zeta, mask, ier)

       ! the differential similarity function for buoyancy and tracers
       ! Note: seems to be the same as monin_obukhov_derivative_m?

       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: phi_t
       real   , intent(in   ), dimension(n)  :: zeta
       logical, intent(in   ), dimension(n)  :: mask  
       integer, intent(  out)                :: ier
     end subroutine monin_obukhov_derivative_t
     _PURE subroutine monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
          & n, phi_m, zeta, mask, ier)

       ! the differential similarity function for momentum

       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: phi_m
       real   , intent(in   ), dimension(n)  :: zeta
       logical, intent(in   ), dimension(n)  :: mask
       integer, intent(out  )                :: ier
     end subroutine monin_obukhov_derivative_m
     _PURE subroutine monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
          & n, psi_t, psi_q, zeta, zeta_t, zeta_q, &
          & ln_z_zt, ln_z_zq, mask, ier)

       ! the integral similarity function for moisture and tracers

       integer, intent(in   )                :: stable_option
       real,    intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: psi_t, psi_q
       real   , intent(in)   , dimension(n)  :: zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq
       logical, intent(in)   , dimension(n)  :: mask
       integer, intent(  out)                :: ier
     end subroutine monin_obukhov_integral_tq

     _PURE subroutine monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
          & n, psi_m, zeta, zeta_0, ln_z_z0, mask, ier)

       !  the integral similarity function for momentum

       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: psi_m
       real   , intent(in)   , dimension(n)  :: zeta, zeta_0, ln_z_z0
       logical, intent(in)   , dimension(n)  :: mask
       integer, intent(out)                  :: ier
     end subroutine monin_obukhov_integral_m
     
  end interface


  ier = 0

  z_z0 = z/z0
  z_zt = z/zt
  z_zq = z/zq
  ln_z_z0 = log(z_z0)
  ln_z_zt = log(z_zt)
  ln_z_zq = log(z_zq)

  corr = 0.0
  mask_1 = mask

  ! initial guess

  zeta = 0.0
  where(mask_1) 
     zeta = rich*ln_z_z0*ln_z_z0/ln_z_zt
  end where

  where (mask_1 .and. rich >= 0.0)
     zeta = zeta/(1.0 - rich/rich_crit)
  end where

  iter_loop: do iter = 1, max_iter

     where (mask_1 .and. abs(zeta).lt.zeta_min) 
        zeta = 0.0
        f_m = ln_z_z0
        f_t = ln_z_zt
        f_q = ln_z_zq
        mask_1 = .false.  ! don't do any more calculations at these pts
     end where

     
     zeta_0 = 0.0
     zeta_t = 0.0
     zeta_q = 0.0
     where (mask_1)
        rzeta  = 1.0/zeta
        zeta_0 = zeta/z_z0
        zeta_t = zeta/z_zt
        zeta_q = zeta/z_zq
     end where

     call monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
          & n, phi_m  , zeta  , mask_1, ier)
     call monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
          & n, phi_m_0, zeta_0,  mask_1, ier)
     call monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
          & n, phi_t  , zeta  , mask_1, ier)
     call monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
          & n, phi_t_0, zeta_t, mask_1, ier)

     call monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
          & n, f_m, zeta, zeta_0, ln_z_z0, mask_1, ier)
     call monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
          & n, f_t, f_q, zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq, mask_1, ier)

     where (mask_1)
        df_m  = (phi_m - phi_m_0)*rzeta
        df_t  = (phi_t - phi_t_0)*rzeta
        rich_1 = zeta*f_t/(f_m*f_m)
        d_rich = rich_1*( rzeta +  df_t/f_t - 2.0 *df_m/f_m) 
        correction = (rich - rich_1)/d_rich  
        corr = min(abs(correction),abs(correction/zeta)) 
        ! the criterion corr < error seems to work ok, but is a bit arbitrary
        !  when zeta is small the tolerance is reduced
     end where

     max_cor= maxval(corr)

     if(max_cor > error) then
        mask_1 = mask_1 .and. (corr > error)  
        ! change the mask so computation proceeds only on non-converged points
        where(mask_1) 
           zeta = zeta + correction
        end where
        cycle iter_loop
     else
        return
     end if

  end do iter_loop

  ier = 1 ! surface drag iteration did not converge

end subroutine monin_obukhov_solve_zeta
!==============================================================================
_PURE subroutine monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
     & n, phi_t, zeta, mask, ier)

  ! the differential similarity function for buoyancy and tracers
  ! Note: seems to be the same as monin_obukhov_derivative_m?

  implicit none

  integer, intent(in   )                :: stable_option
  real   , intent(in   )                :: rich_crit, zeta_trans
  integer, intent(in   )                :: n
  real   , intent(  out), dimension(n)  :: phi_t
  real   , intent(in   ), dimension(n)  :: zeta
  logical, intent(in   ), dimension(n)  :: mask  
  integer, intent(  out)                :: ier

  logical, dimension(n) :: stable, unstable
  real                  :: b_stab, lambda

  ier = 0
  b_stab     = 1.0/rich_crit

  stable   = mask .and. zeta >= 0.0
  unstable = mask .and. zeta <  0.0

  where (unstable) 
     phi_t = (1 - 16.0*zeta)**(-0.5)
  end where

  if(stable_option == 1) then 

     where (stable) 
        phi_t = 1.0 + zeta*(5.0 + b_stab*zeta)/(1.0 + zeta)
     end where

  else if(stable_option == 2) then

     lambda = 1.0 + (5.0 - b_stab)*zeta_trans

     where (stable .and. zeta < zeta_trans)
        phi_t = 1 + 5.0*zeta
     end where
     where (stable .and. zeta >= zeta_trans)
        phi_t = lambda + b_stab*zeta
     end where

  endif

end subroutine monin_obukhov_derivative_t
!==============================================================================
_PURE subroutine monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
     & n, phi_m, zeta, mask, ier)

  ! the differential similarity function for momentum

  implicit none

  integer, intent(in   )                :: stable_option
  real   , intent(in   )                :: rich_crit, zeta_trans
  integer, intent(in   )                :: n
  real   , intent(  out), dimension(n)  :: phi_m
  real   , intent(in   ), dimension(n)  :: zeta
  logical, intent(in   ), dimension(n)  :: mask
  integer, intent(out  )                :: ier

  logical, dimension(n) :: stable, unstable
  real   , dimension(n) :: x
  real                  :: b_stab, lambda


  ier = 0
  b_stab     = 1.0/rich_crit

  stable   = mask .and. zeta >= 0.0
  unstable = mask .and. zeta <  0.0

  where (unstable) 
     x     = (1 - 16.0*zeta  )**(-0.5)
     phi_m = sqrt(x)  ! phi_m = (1 - 16.0*zeta)**(-0.25)
  end where

  if(stable_option == 1) then 

     where (stable) 
        phi_m = 1.0 + zeta  *(5.0 + b_stab*zeta)/(1.0 + zeta)
     end where

  else if(stable_option == 2) then

     lambda = 1.0 + (5.0 - b_stab)*zeta_trans

     where (stable .and. zeta < zeta_trans)
        phi_m = 1 + 5.0*zeta
     end where
     where (stable .and. zeta >= zeta_trans)
        phi_m = lambda + b_stab*zeta
     end where

  endif

end subroutine monin_obukhov_derivative_m
!==============================================================================
_PURE subroutine monin_obukhov_profile_1d(vonkarm, &
     & neutral, stable_option, rich_crit, zeta_trans, &
     & n, zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
     & del_m, del_t, del_q, lavail, avail, ier)

  implicit none

  real   , intent(in   )                :: vonkarm
  logical, intent(in   )                :: neutral
  integer, intent(in   )                :: stable_option
  real   , intent(in   )                :: rich_crit, zeta_trans
  integer, intent(in   )                :: n
  real,    intent(in   )                :: zref, zref_t
  real,    intent(in   ), dimension(n)  :: z, z0, zt, zq, u_star, b_star, q_star
  real,    intent(  out), dimension(n)  :: del_m, del_t, del_q
  logical, intent(in   )                :: lavail ! whether to use provided mask or not
  logical, intent(in   ), dimension(n)  :: avail  ! provided mask
  integer, intent(out  )                :: ier

  real, dimension(n) :: zeta, zeta_0, zeta_t, zeta_q, zeta_ref, zeta_ref_t, &
       ln_z_z0, ln_z_zt, ln_z_zq, ln_z_zref, ln_z_zref_t,  &
       f_m_ref, f_m, f_t_ref, f_t, f_q_ref, f_q,           &
       mo_length_inv

  logical, dimension(n) :: mask

  interface
     _PURE subroutine monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
          & n, psi_t, psi_q, zeta, zeta_t, zeta_q, &
          & ln_z_zt, ln_z_zq, mask, ier)

       ! the integral similarity function for moisture and tracers

       integer, intent(in   )                :: stable_option
       real,    intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: psi_t, psi_q
       real   , intent(in)   , dimension(n)  :: zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq
       logical, intent(in)   , dimension(n)  :: mask
       integer, intent(  out)                :: ier
     end subroutine monin_obukhov_integral_tq

     _PURE subroutine monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
          & n, psi_m, zeta, zeta_0, ln_z_z0, mask, ier)

       !  the integral similarity function for momentum

       integer, intent(in   )                :: stable_option
       real   , intent(in   )                :: rich_crit, zeta_trans
       integer, intent(in   )                :: n
       real   , intent(  out), dimension(n)  :: psi_m
       real   , intent(in)   , dimension(n)  :: zeta, zeta_0, ln_z_z0
       logical, intent(in)   , dimension(n)  :: mask
       integer, intent(out)                  :: ier
     end subroutine monin_obukhov_integral_m
  end interface

  ier = 0

  mask = .true.
  if(lavail) mask = avail

  del_m = 0.0  ! zero output arrays
  del_t = 0.0
  del_q = 0.0

  where(mask) 
     ln_z_z0     = log(z/z0)
     ln_z_zt     = log(z/zt)
     ln_z_zq     = log(z/zq)
     ln_z_zref   = log(z/zref)
     ln_z_zref_t = log(z/zref_t)
  endwhere

  if(neutral) then

     where(mask)
        del_m = 1.0 - ln_z_zref  /ln_z_z0
        del_t = 1.0 - ln_z_zref_t/ln_z_zt
        del_q = 1.0 - ln_z_zref_t/ln_z_zq
     endwhere

  else

     where(mask .and. u_star > 0.0) 
        mo_length_inv = - vonkarm * b_star/(u_star*u_star)
        zeta       = z     *mo_length_inv
        zeta_0     = z0    *mo_length_inv
        zeta_t     = zt    *mo_length_inv
        zeta_q     = zq    *mo_length_inv
        zeta_ref   = zref  *mo_length_inv
        zeta_ref_t = zref_t*mo_length_inv
     endwhere

     call monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
          & n, f_m,     zeta, zeta_0,   ln_z_z0,   mask, ier)
     call monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
          & n, f_m_ref, zeta, zeta_ref, ln_z_zref, mask, ier)

     call monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
          & n, f_t, f_q, zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq, mask, ier)
     call monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
          & n, f_t_ref, f_q_ref, zeta, zeta_ref_t, zeta_ref_t, ln_z_zref_t, ln_z_zref_t,  mask, ier)

     where(mask)
        del_m = 1.0 - f_m_ref/f_m
        del_t = 1.0 - f_t_ref/f_t
        del_q = 1.0 - f_q_ref/f_q
     endwhere

  end if


end subroutine monin_obukhov_profile_1d
!==============================================================================
_PURE subroutine monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
     & n, psi_m, zeta, zeta_0, ln_z_z0, mask, ier)

  !  the integral similarity function for momentum

  implicit none

  integer, intent(in   )                :: stable_option
  real   , intent(in   )                :: rich_crit, zeta_trans
  integer, intent(in   )                :: n
  real   , intent(  out), dimension(n)  :: psi_m
  real   , intent(in)   , dimension(n)  :: zeta, zeta_0, ln_z_z0
  logical, intent(in)   , dimension(n)  :: mask
  integer, intent(out)                  :: ier

  real                   :: b_stab, lambda

  real, dimension(n) :: x, x_0, x1, x1_0, num, denom, y
  logical, dimension(n) :: stable, unstable, &
       weakly_stable, strongly_stable

  ier = 0

  b_stab     = 1.0/rich_crit

  stable   = mask .and. zeta >= 0.0
  unstable = mask .and. zeta <  0.0

  where(unstable) 

     x     = sqrt(1 - 16.0*zeta)
     x_0   = sqrt(1 - 16.0*zeta_0)

     x      = sqrt(x)
     x_0    = sqrt(x_0)

     x1     = 1.0 + x
     x1_0   = 1.0 + x_0

     num    = x1*x1*(1.0 + x*x)
     denom  = x1_0*x1_0*(1.0 + x_0*x_0)
     y      = atan(x) - atan(x_0)
     psi_m  = ln_z_z0 - log(num/denom) + 2*y

  end where

  if( stable_option == 1) then

     where (stable) 
        psi_m = ln_z_z0 + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_0)) &
             + b_stab*(zeta - zeta_0) 
     end where

  else if (stable_option == 2) then

     lambda = 1.0 + (5.0 - b_stab)*zeta_trans

     weakly_stable   = stable .and. zeta <= zeta_trans
     strongly_stable = stable .and. zeta >  zeta_trans

     where (weakly_stable)
        psi_m = ln_z_z0 + 5.0*(zeta - zeta_0) 
     end where

     where(strongly_stable)
        x = (lambda - 1.0)*log(zeta/zeta_trans) + b_stab*(zeta - zeta_trans)
     endwhere

     where (strongly_stable .and. zeta_0 <= zeta_trans)
        psi_m = ln_z_z0 + x + 5.0*(zeta_trans - zeta_0)
     end where
     where (strongly_stable .and. zeta_0 > zeta_trans)
        psi_m = lambda*ln_z_z0 + b_stab*(zeta  - zeta_0)
     endwhere

  end if

end subroutine monin_obukhov_integral_m
!==============================================================================
_PURE subroutine monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
     & n, psi_t, psi_q, zeta, zeta_t, zeta_q, &
     & ln_z_zt, ln_z_zq, mask, ier)

  ! the integral similarity function for moisture and tracers

  implicit none

  integer, intent(in   )                :: stable_option
  real,    intent(in   )                :: rich_crit, zeta_trans
  integer, intent(in   )                :: n
  real   , intent(  out), dimension(n)  :: psi_t, psi_q
  real   , intent(in)   , dimension(n)  :: zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq
  logical, intent(in)   , dimension(n)  :: mask
  integer, intent(  out)                :: ier
  
  real, dimension(n)     :: x, x_t, x_q                              
  logical, dimension(n)  :: stable, unstable, &
                                  weakly_stable, strongly_stable
  real                   :: b_stab, lambda

  ier = 0
  
  b_stab     = 1.0/rich_crit

stable   = mask .and. zeta >= 0.0
unstable = mask .and. zeta <  0.0

where(unstable) 

  x     = sqrt(1 - 16.0*zeta)
  x_t   = sqrt(1 - 16.0*zeta_t)
  x_q   = sqrt(1 - 16.0*zeta_q)
  
  psi_t = ln_z_zt - 2.0*log( (1.0 + x)/(1.0 + x_t) )
  psi_q = ln_z_zq - 2.0*log( (1.0 + x)/(1.0 + x_q) )

end where

if( stable_option == 1) then

  where (stable) 
  
    psi_t = ln_z_zt + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_t)) &
       + b_stab*(zeta - zeta_t) 
    psi_q = ln_z_zq + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_q)) &
       + b_stab*(zeta - zeta_q) 
       
  end where
  
else if (stable_option == 2) then

   lambda = 1.0 + (5.0 - b_stab)*zeta_trans

  weakly_stable   = stable .and. zeta <= zeta_trans
  strongly_stable = stable .and. zeta >  zeta_trans

  where (weakly_stable)
    psi_t = ln_z_zt + 5.0*(zeta - zeta_t) 
    psi_q = ln_z_zq + 5.0*(zeta - zeta_q) 
  end where
  
  where(strongly_stable)
    x = (lambda - 1.0)*log(zeta/zeta_trans) + b_stab*(zeta - zeta_trans)
  endwhere
  
  where (strongly_stable .and. zeta_t <= zeta_trans)
    psi_t = ln_z_zt + x + 5.0*(zeta_trans - zeta_t)
  end where
  where (strongly_stable .and. zeta_t > zeta_trans)
    psi_t = lambda*ln_z_zt + b_stab*(zeta  - zeta_t)
  endwhere
  
  where (strongly_stable .and. zeta_q <= zeta_trans)
    psi_q = ln_z_zq + x + 5.0*(zeta_trans - zeta_q)
  end where
  where (strongly_stable .and. zeta_q > zeta_trans)
    psi_q = lambda*ln_z_zq + b_stab*(zeta  - zeta_q)
  endwhere
  
end if

end subroutine monin_obukhov_integral_tq
!==============================================================================
_PURE subroutine monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, &
     &                              n, rich, mix, ier)

  implicit none

  integer, intent(in   )                 :: stable_option
  real   , intent(in   )                 :: rich_crit, zeta_trans
  integer, intent(in   )                 :: n
  real   , intent(in   ), dimension(n)   :: rich
  real   , intent(  out), dimension(n)   :: mix  
  integer, intent(  out)                 :: ier

  real               :: r, a, b, c, zeta, phi
  real               :: b_stab, rich_trans, lambda
  integer            :: i

  ier = 0

mix = 0.0
b_stab     = 1.0/rich_crit
rich_trans = zeta_trans/(1.0 + 5.0*zeta_trans)

if(stable_option == 1) then

     c = - 1.0
     do i = 1, n
        if(rich(i) > 0.0 .and. rich(i) < rich_crit) then
           r = 1.0/rich(i)
           a = r - b_stab
           b = r - (1.0 + 5.0)
           zeta = (-b + sqrt(b*b - 4.0*a*c))/(2.0*a)
           phi = 1.0 + b_stab*zeta + (5.0 - b_stab)*zeta/(1.0 + zeta)
           mix(i) = 1./(phi*phi)
     endif
  end do
  
else if(stable_option == 2) then
 
  lambda = 1.0 + (5.0 - b_stab)*zeta_trans

  where(rich > 0.0 .and. rich <= rich_trans)
    mix = (1.0 - 5.0*rich)**2
  end where
  where(rich > rich_trans .and. rich < rich_crit)
    mix = ((1.0 - b_stab*rich)/lambda)**2
  end where
  
end if

end subroutine monin_obukhov_stable_mix


#ifdef _TEST_MONIN_OBUKHOV
!==============================================================================
! Unit test
!==============================================================================

program test

  use monin_obukhov_inter

  implicit none
  integer, parameter :: i8 = selected_int_kind(18)
  integer(i8)        :: ier_tot, ier

  real    :: grav, vonkarm, error, zeta_min, small, ustar_min
  real    :: zref, zref_t
  integer :: max_iter

  real    :: rich_crit, zeta_trans, drag_min
  logical :: neutral
  integer :: stable_option

  grav          = 9.80
  vonkarm       = 0.4
  error         = 1.0e-4
  zeta_min      = 1.0e-6
  max_iter      = 20
  small         = 1.0e-4
  neutral       = .false.
  stable_option = 1
  rich_crit     =10.0
  zeta_trans    = 0.5
  drag_min      = 1.0e-5
  ustar_min     = 1.e-10
  
  zref   = 10.
  zref_t = 2.
  

  ier_tot = 0
  call test_drag
  print *,'test_drag                    ier = ', ier
  ier_tot = ier_tot + ier

  call test_stable_mix
  print *,'test_stable_mix              ier = ', ier
  ier_tot = ier_tot + ier

  call test_diff
  print *,'test_diff                    ier = ', ier
  ier_tot = ier_tot + ier

  call test_profile
  print *,'test_profile                 ier = ', ier
  ier_tot = ier_tot + ier

  if(ier_tot/=0) then
     print *, ier_tot, '***ERRORS detected***'
  else
     print *,'No error detected.'
  endif

  CONTAINS

    subroutine test_drag

      integer(i8)        :: w

      integer :: i, ier_l
      integer, parameter :: n = 5
      logical :: avail(n), lavail

      real, dimension(n) :: pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t, drag_q, u_star, b_star

      ! potential temperature
      pt     = (/ 268.559120403867, 269.799228886728, 277.443023238556, 295.79192777341, 293.268717243262 /)
      pt0    = (/ 273.42369841804 , 272.551410044203, 278.638168565727, 298.133068766049, 292.898163706587/)
      z      = (/ 29.432779269303, 30.0497139076724, 31.6880000418153, 34.1873479240475, 33.2184943356517/)
      z0     = (/ 5.86144925739178e-05, 0.0001, 0.000641655193293549, 3.23383768877187e-05, 0.07/)
      zt     = (/ 3.69403636275411e-05, 0.0001, 1.01735489109205e-05, 7.63933834969505e-05, 0.00947346982656289/)
      zq     = (/ 5.72575636226887e-05, 0.0001, 5.72575636226887e-05, 5.72575636226887e-05, 5.72575636226887e-05/)
      speed  = (/ 2.9693638452068, 2.43308757772094, 5.69418282305367, 9.5608693754561, 4.35302260074334/)
      lavail = .true.
      avail  = (/.true., .true., .true., .true., .true. /)

      drag_m = 0
      drag_t = 0
      drag_q = 0
      u_star = 0
      b_star = 0

      call monin_obukhov_drag_1d(grav, vonkarm,               &
           & error, zeta_min, max_iter, small,                         &
           & neutral, stable_option, rich_crit, zeta_trans, drag_min,  &
           & n, pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t,         &
           & drag_q, u_star, b_star, lavail, avail, ier_l)

      ! check sum results
      w = 0
      w = w + transfer(sum(drag_m), w)
      w = w + transfer(sum(drag_t), w)
      w = w + transfer(sum(drag_q), w)
      w = w + transfer(sum(u_star), w)
      w = w + transfer(sum(b_star), w)

      ! plug in check sum here>>>
#if defined(__INTEL_COMPILER) || defined(_LF95)
#define CHKSUM_DRAG 4466746452959549648
#endif
#if defined(_PGF95)
#define CHKSUM_DRAG 4466746452959549650
#endif


      print *,'chksum test_drag      : ', w, ' ref ', CHKSUM_DRAG
      ier = CHKSUM_DRAG - w

    end subroutine test_drag

    subroutine test_stable_mix

      integer(i8)        :: w

      integer, parameter      :: n = 5
      real   , dimension(n)   :: rich
      real   , dimension(n)   :: mix
      integer                 :: ier_l


      stable_option = 1
      rich_crit     = 10.0
      zeta_trans    =  0.5

      rich = (/1650.92431853365, 1650.9256285137, 77.7636819036559, 1.92806556391324, 0.414767442012442/)


      call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, &
           &                              n, rich, mix, ier_l)

      w = transfer( sum(mix) , w)

      ! plug in check sum here>>>
#if defined(__INTEL_COMPILER) || defined(_LF95)
#define CHKSUM_STABLE_MIX 4590035772608644256
#endif
#if defined(_PGF95)
#define CHKSUM_STABLE_MIX 4590035772608644258
#endif

      print *,'chksum test_stable_mix: ', w, ' ref ', CHKSUM_STABLE_MIX
      ier = CHKSUM_STABLE_MIX - w

    end subroutine test_stable_mix

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

    subroutine test_diff

      integer(i8)        :: w

      integer, parameter             :: ni=1, nj=1, nk=1
      real   , dimension(ni, nj, nk) :: z
      real   , dimension(ni, nj)     :: u_star, b_star
      real   , dimension(ni, nj, nk) :: k_m, k_h
      integer                        :: ier_l

      z      = 19.9982554527751
      u_star = 0.129638955971075
      b_star = 0.000991799765557209

      call monin_obukhov_diff(vonkarm,                        &
           & ustar_min,                                     &
           & neutral, stable_option, rich_crit, zeta_trans, &
           & ni, nj, nk, z, u_star, b_star, k_m, k_h, ier_l)

      w = 0
      w = w + transfer( sum(k_m) , w)
      w = w + transfer( sum(k_h) , w)

      ! plug check sum in here>>>
#if defined(__INTEL_COMPILER) || defined(_LF95) || defined(_PGF95)
#define CHKSUM_DIFF -9222066590093362639
#endif

      print *,'chksum test_diff      : ', w, ' ref ', CHKSUM_DIFF

      ier = CHKSUM_DIFF - w  

    end subroutine test_diff

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

    subroutine test_profile

      integer(i8)        :: w

      integer, parameter :: n = 5
      integer            :: ier_l

      logical :: avail(n)

      real, dimension(n) :: z, z0, zt, zq, u_star, b_star, q_star
      real, dimension(n) :: del_m, del_t, del_q

      z      = (/ 29.432779269303, 30.0497139076724, 31.6880000418153, 34.1873479240475, 33.2184943356517 /)
      z0     = (/ 5.86144925739178e-05, 0.0001, 0.000641655193293549, 3.23383768877187e-05, 0.07/)
      zt     = (/ 3.69403636275411e-05, 0.0001, 1.01735489109205e-05, 7.63933834969505e-05, 0.00947346982656289/)
      zq     = (/ 5.72575636226887e-05, 0.0001, 5.72575636226887e-05, 5.72575636226887e-05, 5.72575636226887e-05/)
      u_star = (/ 0.109462510724615, 0.0932942802513508, 0.223232887323184, 0.290918439028557, 0.260087579361467/)
      b_star = (/ 0.00690834676781433, 0.00428178089592372, 0.00121229800895103, 0.00262353784027441, -0.000570314880866852/)
      q_star = (/ 0.000110861442197537, 9.44983279664197e-05, 4.17643828631936e-05, 0.000133135421415819, 9.36317815993945e-06/) 

      avail = (/ .true., .true.,.true.,.true.,.true. /)

      call monin_obukhov_profile_1d(vonkarm, &
           & neutral, stable_option, rich_crit, zeta_trans, &
           & n, zref, zref_t, z, z0, zt, zq, u_star, b_star, q_star, &
           & del_m, del_t, del_q, .true., avail, ier_l)

      ! check sum results
      w = 0
      w = w + transfer(sum(del_m), w)
      w = w + transfer(sum(del_t), w)
      w = w + transfer(sum(del_q), w)

      ! plug check sum in here>>>
#if defined(__INTEL_COMPILER) || defined(_LF95) 
#define CHKSUM_PROFILE -4596910845317820786
#endif
#if defined(_PGF95)
#define CHKSUM_PROFILE -4596910845317820785
#endif

      print *,'chksum test_profile   : ', w, ' ref ', CHKSUM_PROFILE

      ier = CHKSUM_PROFILE - w

    end subroutine test_profile


end program test

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

#endif 
! _TEST_MONIN_OBUKHOV


  MODULE MY25_TURB_MOD

!=======================================================================
!   MELLOR-YAMADA LEVEL 2.5 TURBULENCE CLOSURE SCHEME - GFDL VERSION   !
!=======================================================================

 use mpp_mod,           only : input_nml_file
 use fms_mod,           only : file_exist, open_namelist_file, error_mesg, &
                               FATAL, close_file, note, read_data,          &
                               check_nml_error, mpp_pe, mpp_root_pe, &
                               write_version_number, stdlog, open_restart_file
 use fms_io_mod,        only : register_restart_field, restart_file_type, &
                               save_restart, restore_state
 use tridiagonal_mod,   only : tri_invert, close_tridiagonal
 use constants_mod,     only : grav, vonkarm
 use monin_obukhov_mod, only : mo_diff

!---------------------------------------------------------------------
 implicit none
 private
!---------------------------------------------------------------------

 public :: MY25_TURB, MY25_TURB_INIT, MY25_TURB_END, TKE_SURF, get_tke
 public :: my25_turb_restart

!---------------------------------------------------------------------
! --- GLOBAL STORAGE
!---------------------------------------------------------------------

  real, allocatable, dimension(:,:,:) :: TKE

!---------------------------------------------------------------------

 character(len=128) :: version = '$Id: my25_turb.F90,v 18.0.2.1 2010/08/30 20:39:47 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .false.
 
 logical :: init_tke
 integer :: num_total_pts, pts_done

! for netcdf restart file.
 type(restart_file_type), save :: Tur_restart

!---------------------------------------------------------------------
! --- CONSTANTS
!---------------------------------------------------------------------

 real :: aa1,   aa2,   bb1,  bb2,  ccc
 real :: ckm1,  ckm2,  ckm3, ckm4, ckm5, ckm6, ckm7, ckm8
 real :: ckh1,  ckh2,  ckh3, ckh4
 real :: cvfq1, cvfq2, bcq

 real, parameter :: aa1_old =  0.78
 real, parameter :: aa2_old =  0.79
 real, parameter :: bb1_old = 15.0
 real, parameter :: bb2_old =  8.0
 real, parameter :: ccc_old =  0.056
 real, parameter :: aa1_new =  0.92
 real, parameter :: aa2_new =  0.74
 real, parameter :: bb1_new = 16.0
 real, parameter :: bb2_new = 10.0
 real, parameter :: ccc_new =  0.08
 real, parameter :: cc1     =  0.27
 real, parameter :: t00     =  2.7248e2 
 real, parameter :: small   =  1.0e-10

!---------------------------------------------------------------------
! --- NAMELIST
!---------------------------------------------------------------------

 real    :: TKEmax       =  5.0
 real    :: TKEmin       =  0.0
 real    :: el0max       =  1.0e6
 real    :: el0min       =  0.0
 real    :: alpha_land   =  0.10
 real    :: alpha_sea    =  0.10
 real    :: akmax        =  1.0e4
 real    :: akmin_land   =  5.0
 real    :: akmin_sea    =  0.0
 integer :: nk_lim       =  2
 integer :: init_iters   =  20
 logical :: do_thv_stab  = .true.
 logical :: use_old_cons = .false.
 real    :: kcrit        =  0.01

  NAMELIST / my25_turb_nml /                           &
         TKEmax,   TKEmin,   init_iters,               &
         akmax,    akmin_land, akmin_sea, nk_lim,      &
         el0max,   el0min,  alpha_land,  alpha_sea,    &
         do_thv_stab, use_old_cons,                    &
         kcrit      

!---------------------------------------------------------------------

 contains

!#######################################################################

 SUBROUTINE MY25_TURB( is, js, delt, fracland, phalf, pfull, theta, &   
                       um,   vm,       zhalf, zfull, z0,    &
                       el0,      el,    akm,   akh,   &
                       mask, kbot,     ustar, bstar, h    )

!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!       delt     -  Time step in seconds
!       fracland -  Fractional amount of land beneath a grid box
!       phalf    -  Pressure at half levels
!       pfull    -  Pressure at full levels
!       theta    -  Potential temperature
!       um, vm   -  Wind components
!       zhalf    -  Height at half levels
!       zfull    -  Height at full levels
!       z0       -  Roughness length
!       mask     -  OPTIONAL; floating point mask (0. or 1.) designating
!                   where data is present
!       kbot     -  OPTIONAL;lowest model level index (integer);
!                    at levels > kbot, mask = 0.
!       ustar    -  OPTIONAL:friction velocity (m/sec)
!       bstar    -  OPTIONAL:buoyancy scale (m/sec**2)
!---------------------------------------------------------------------
  integer, intent(in)                   :: is, js
  real,    intent(in)                   :: delt 
  real,    intent(in), dimension(:,:)   :: fracland, z0
  real,    intent(in), dimension(:,:,:) :: phalf, pfull, zhalf, zfull
  real,    intent(in), dimension(:,:,:) :: um, vm, theta

  integer, intent(in), OPTIONAL, dimension(:,:)   :: kbot
  real,    intent(in), OPTIONAL, dimension(:,:,:) :: mask
  real,    intent(in), OPTIONAL, dimension(:,:)   :: ustar, bstar

!---------------------------------------------------------------------
! Arguments (Intent out)
!       el0  -  characteristic length scale
!       el   -  master length scale
!       akm  -  mixing coefficient for momentum
!       akh  -  mixing coefficient for heat and moisture
!         h  -  OPTIONAL, diagnosed depth of planetary boundary 
!                         layer (m)
!---------------------------------------------------------------------
  real, intent(out), dimension(:,:)   :: el0
  real, intent(out), dimension(:,:,:) :: akm, akh, el
  real, intent(out), OPTIONAL, dimension(:,:) :: h

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
  integer :: ix, jx, kx, i, j, k, ism, jsm
  integer :: kxp, kxm, klim, it, itermax
  real    :: cvfqdt, dvfqdt

  real, dimension(SIZE(um,1),SIZE(um,2)) :: zsfc, x1, x2, akmin

  real, dimension(SIZE(um,1),SIZE(um,2),SIZE(um,3)-1) ::     &
        dsdzh, shear, buoync, qm2,  qm3, qm4, el2,           &
        aaa,   bbb,   ccc,    ddd,                           &
        xxm1,  xxm2,  xxm3,   xxm4, xxm5

  real, dimension(SIZE(um,1),SIZE(um,2),SIZE(um,3)) ::       &
        dsdz, qm,  xx1, xx2

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

! --- Check to see if MY25_TURB has been initialized
  if( .not. module_is_initialized ) CALL ERROR_MESG( ' MY25_TURB',     &
                                 ' MY25_TURB_INIT has not been called',&
                                   FATAL )

! --- Set dimensions etc
  ix  = SIZE( um, 1 )
  jx  = SIZE( um, 2 )
  kx  = SIZE( um, 3 )
  kxp = kx + 1
  kxm = kx - 1
  ism = is - 1
  jsm = js - 1

!====================================================================
! --- SURFACE HEIGHT     
!====================================================================

  if( PRESENT( kbot ) ) then
     do j = 1,jx
     do i = 1,ix
        k = kbot(i,j) + 1
       zsfc(i,j) = zhalf(i,j,k)
     end do
     end do
  else
       zsfc(:,:) = zhalf(:,:,kxp)
  endif

!====================================================================
! --- D( )/DZ OPERATORS: AT FULL LEVELS & AT HALF LEVELS          
!====================================================================

   dsdz(:,:,1:kx)  = 1.0 / ( zhalf(:,:,2:kxp) - zhalf(:,:,1:kx) )
  dsdzh(:,:,1:kxm) = 1.0 / ( zfull(:,:,2:kx)  - zfull(:,:,1:kxm) )

!====================================================================
! --- WIND SHEAR                 
!====================================================================

  xxm1(:,:,1:kxm) = dsdzh(:,:,1:kxm)*( um(:,:,2:kx) - um(:,:,1:kxm) )
  xxm2(:,:,1:kxm) = dsdzh(:,:,1:kxm)*( vm(:,:,2:kx) - vm(:,:,1:kxm) )

  shear = xxm1 * xxm1 + xxm2 * xxm2

!====================================================================
! --- BUOYANCY                 
!====================================================================

  xxm1(:,:,1:kxm) = theta(:,:,2:kx) - theta(:,:,1:kxm) 

  if( do_thv_stab ) then
     xxm2(:,:,1:kxm) = 0.5*( theta(:,:,2:kx) + theta(:,:,1:kxm) )
  else
     xxm2(:,:,1:kxm) = t00
  end if

  buoync = grav * dsdzh * xxm1 / xxm2

!====================================================================
! --- MASK OUT UNDERGROUND VALUES FOR ETA COORDINATE
!====================================================================

  if( PRESENT( mask ) ) then
    do k=2,kx
    do j=1,jx
    do i=1,ix
      if(mask(i,j,k) < 0.1) then
          TKE(ism+i,jsm+j,k+1) = 0.0
         dsdz(i,j,k  ) = 0.0
        dsdzh(i,j,k-1) = 0.0
        shear(i,j,k-1) = 0.0
       buoync(i,j,k-1) = 0.0
      endif
    enddo
    enddo
    enddo
  endif
  
!====================================================================
! --- SET ITERATION LOOP IF INITALIZING TKE
!====================================================================

            itermax = 1
     if (init_tke) then
            itermax = init_iters
            pts_done = pts_done + ix*jx
            if (pts_done >= num_total_pts) init_tke = .false.
     endif

! $$$$$$$$$$$$$$$$$
  do it = 1,itermax
! $$$$$$$$$$$$$$$$$

!====================================================================
! --- SOME TKE STUFF
!====================================================================

  do k=1,kx
  do j=1,jx
  do i=1,ix
    xx1(i,j,k) = 2*TKE(ism+i,jsm+j,k+1)
    if(xx1(i,j,k) > 0.0) then
      qm(i,j,k) = sqrt(xx1(i,j,k))
    else
      qm(i,j,k) = 0.0
    endif
  enddo
  enddo
  enddo

  qm2(:,:,1:kxm)  = xx1(:,:,1:kxm) 
  qm3(:,:,1:kxm)  =  qm(:,:,1:kxm) * qm2(:,:,1:kxm) 
  qm4(:,:,1:kxm)  = qm2(:,:,1:kxm) * qm2(:,:,1:kxm) 

!====================================================================
! --- CHARACTERISTIC LENGTH SCALE                         
!====================================================================

  xx1(:,:,1:kxm) = qm(:,:,1:kxm)*( pfull(:,:,2:kx) - pfull(:,:,1:kxm) )

  do k = 1, kxm
     xx2(:,:,k) = xx1(:,:,k)  * ( zhalf(:,:,k+1) - zsfc(:,:) )
  end do

  if( PRESENT( kbot ) ) then
       xx1(:,:,kx) = 0.0
       xx2(:,:,kx) = 0.0
     do j = 1,jx
     do i = 1,ix
        k = kbot(i,j) 
       xx1(i,j,k)  =  qm(i,j,k) * ( phalf(i,j,k+1) - pfull(i,j,k) )
       xx2(i,j,k)  = xx1(i,j,k) * z0(i,j)
     end do
     end do
  else
       xx1(:,:,kx) =  qm(:,:,kx) * ( phalf(:,:,kxp) - pfull(:,:,kx) )
       xx2(:,:,kx) = xx1(:,:,kx) * z0(:,:)
  endif

  if (PRESENT(mask)) then
    x1 = SUM( xx1, 3, mask=mask.gt.0.1 )
    x2 = SUM( xx2, 3, mask=mask.gt.0.1 )
  else
    x1 = SUM( xx1, 3 )
    x2 = SUM( xx2, 3 )
  endif

!---- should never be equal to zero ----
  if (count(x1 <= 0.0) > 0) CALL ERROR_MESG( ' MY25_TURB',  &
                             'divid by zero, x1 <= 0.0', FATAL)
  el0 = x2 / x1
  el0 = el0 * (alpha_land*fracland + alpha_sea*(1.-fracland))

  el0 = MIN( el0, el0max )
  el0 = MAX( el0, el0min )

!====================================================================
! --- MASTER LENGTH SCALE 
!====================================================================

  do k = 1, kxm
     xx1(:,:,k)  = vonkarm * ( zhalf(:,:,k+1) - zsfc(:,:) )
  end do

  x1(:,:) = vonkarm * z0(:,:) 

  if( PRESENT( kbot ) ) then
     do j = 1,jx
     do i = 1,ix
        do k = kbot(i,j), kx
          xx1(i,j,k) = x1(i,j)
        end do
     end do
     end do
  else
        xx1(:,:,kx) = x1(:,:)
  endif 

  do k = 1,kx
    el(:,:,k+1) = xx1(:,:,k) / ( 1.0 + xx1(:,:,k) / el0(:,:) )
  end do
    el(:,:,1)   = el0(:,:)

  el2(:,:,1:kxm) = el(:,:,2:kx) * el(:,:,2:kx)

!====================================================================
! --- MIXING COEFFICIENTS                     
!====================================================================

  xxm3(:,:,1:kxm) = el2(:,:,1:kxm)*buoync(:,:,1:kxm)
  xxm4(:,:,1:kxm) = el2(:,:,1:kxm)* shear(:,:,1:kxm)
  xxm5(:,:,1:kxm) =  el(:,:,2:kx )*   qm3(:,:,1:kxm)

!-------------------------------------------------------------------
! --- MOMENTUM 
!-------------------------------------------------------------------
 
  xxm1 = xxm5*( ckm1*qm2 + ckm2*xxm3 )
  xxm2 = qm4 + ckm5*qm2*xxm4 + xxm3*( ckm6*xxm4 + ckm7*qm2 + ckm8*xxm3 )

  xxm2 = MAX( xxm2, 0.2*qm4 )
  xxm2 = MAX( xxm2, small  )

  akm(:,:,1)    = 0.0
  akm(:,:,2:kx) = xxm1(:,:,1:kxm) / xxm2(:,:,1:kxm)

  akm = MAX( akm, 0.0 )

!-------------------------------------------------------------------
! --- HEAT AND MOISTURE 
!-------------------------------------------------------------------

  xxm1(:,:,1:kxm) = ckh1*xxm5(:,:,1:kxm) - ckh2*xxm4(:,:,1:kxm)*akm(:,:,2:kx)
  xxm2(:,:,1:kxm) = qm2(:,:,1:kxm) + ckh3*xxm3(:,:,1:kxm)

  xxm1 = MAX( xxm1, ckh4*xxm5 )
  xxm2 = MAX( xxm2, 0.4*qm2   )
  xxm2 = MAX( xxm2, small     )

  akh(:,:,1)    = 0.0
  akh(:,:,2:kx) = xxm1(:,:,1:kxm) / xxm2(:,:,1:kxm)

!-------------------------------------------------------------------
! --- BOUNDS 
!-------------------------------------------------------------------

! --- UPPER BOUND
  akm = MIN( akm, akmax )
  akh = MIN( akh, akmax )

! --- LOWER BOUND 
!  where( akm(:,:,1:klim) < small )  akm(:,:,1:klim) = 0.0 
!  where( akh(:,:,1:klim) < small )  akh(:,:,1:klim) = 0.0

! --- LOWER BOUND NEAR SURFACE

  akmin = akmin_land*fracland + akmin_sea*(1.-fracland)

  if( PRESENT( kbot ) ) then
     do j = 1,jx
     do i = 1,ix
             klim = kbot(i,j) - nk_lim + 1
     do  k = klim,kbot(i,j)
        akm(i,j,k) = MAX( akm(i,j,k), akmin(i,j) )
        akh(i,j,k) = MAX( akh(i,j,k), akmin(i,j) )
     end do
     end do
     end do
  else
             klim = kx - nk_lim + 1
     do  k = klim,kx
        akm(:,:,k) = MAX( akm(:,:,k), akmin(:,:) )
        akh(:,:,k) = MAX( akh(:,:,k), akmin(:,:) )
     end do
  endif

!-------------------------------------------------------------------
! --- MASK OUT UNDERGROUND VALUES FOR ETA COORDINATE
!-------------------------------------------------------------------

 if( PRESENT( mask ) ) then
     akm(:,:,1:kx) = akm(:,:,1:kx) * mask(:,:,1:kx) 
     akh(:,:,1:kx) = akh(:,:,1:kx) * mask(:,:,1:kx) 
 endif

!====================================================================
! --- PROGNOSTICATE TURBULENT KE 
!====================================================================

  cvfqdt = cvfq1 * delt
  dvfqdt = cvfq2 * delt * 2.0

!-------------------------------------------------------------------
! --- PART OF LINEARIZED ENERGY DISIIPATION TERM 
!-------------------------------------------------------------------

  xxm1(:,:,1:kxm) = dvfqdt * qm(:,:,1:kxm) / el(:,:,2:kx)

!-------------------------------------------------------------------
! --- PART OF LINEARIZED VERTICAL DIFFUSION TERM
!-------------------------------------------------------------------

  xx1(:,:,1:kx) = el(:,:,2:kxp) * qm(:,:,1:kx)

  xx2(:,:,1)    = 0.5*  xx1(:,:,1)
  xx2(:,:,2:kx) = 0.5*( xx1(:,:,2:kx) + xx1(:,:,1:kxm) )

  xx1 = xx2 * dsdz

!-------------------------------------------------------------------
! --- IMPLICIT TIME DIFFERENCING FOR VERTICAL DIFFUSION 
! --- AND ENERGY DISSIPATION TERM 
!-------------------------------------------------------------------
 
  do k=1,kxm
  do j=1,jx
  do i=1,ix
    aaa(i,j,k) = -cvfqdt * xx1(i,j,k+1) * dsdzh(i,j,k)
    ccc(i,j,k) = -cvfqdt * xx1(i,j,k  ) * dsdzh(i,j,k)
    bbb(i,j,k) =     1.0 - aaa(i,j,k  ) -   ccc(i,j,k) 
    bbb(i,j,k) =           bbb(i,j,k  ) +  xxm1(i,j,k)
    ddd(i,j,k) =           TKE(ism+i,jsm+j,k+1)
  enddo
  enddo
  enddo

! correction for vertical diffusion of TKE surface boundary condition

  if (present(kbot)) then
     do j = 1,jx
     do i = 1,ix
          k = kbot(i,j)
          ddd(i,j,k-1) = ddd(i,j,k-1) - aaa(i,j,k-1) * TKE(ism+i,jsm+j,k+1)
     enddo
     enddo
  else
     do j = 1,jx
     do i = 1,ix
          ddd(i,j,kxm) = ddd(i,j,kxm) - aaa(i,j,kxm) * TKE(ism+i,jsm+j,kxp)
     enddo
     enddo
  endif

! mask out terms below ground

  if (present(mask)) then
     where (mask(:,:,2:kx) < 0.1) ddd(:,:,1:kxm) = 0.0
  endif


  CALL TRI_INVERT( xxm1, ddd, aaa, bbb, ccc ) 
  CALL CLOSE_TRIDIAGONAL

!-------------------------------------------------------------------
! --- MASK OUT UNDERGROUND VALUES FOR ETA COORDINATE
!-------------------------------------------------------------------

 if( PRESENT( mask ) ) then
   do k=1,kxm
   do j=1,jx
   do i=1,ix
     if(mask(i,j,k+1) < 0.1) xxm1(i,j,k) = TKE(ism+i,jsm+j,k+1)
   enddo
   enddo
   enddo
 endif

!-------------------------------------------------------------------
! --- SHEAR AND BUOYANCY TERMS
!-------------------------------------------------------------------

  xxm2(:,:,1:kxm) =  delt*( akm(:,:,2:kx)* shear(:,:,1:kxm)    &
                          - akh(:,:,2:kx)*buoync(:,:,1:kxm) )

!-------------------------------------------------------------------
! --- UPDATE TURBULENT KINETIC ENERGY
!-------------------------------------------------------------------

  do j=1,jx
  do i=1,ix
    TKE(ism+i,jsm+j,1) = 0.0
    do k=2,kx
      TKE(ism+i,jsm+j,k) = xxm1(i,j,k-1) + xxm2(i,j,k-1)
    enddo
  enddo
  enddo

!====================================================================
! --- BOUND TURBULENT KINETIC ENERGY
!====================================================================

  TKE(is:ism+ix,js:jsm+jx,:) = MIN( TKE(is:ism+ix,js:jsm+jx,:), TKEmax )
  TKE(is:ism+ix,js:jsm+jx,:) = MAX( TKE(is:ism+ix,js:jsm+jx,:), TKEmin )

  if( PRESENT( mask ) ) then
    do k=1,kx
    do j=1,jx
    do i=1,ix
      if(mask(i,j,k) < 0.1) TKE(ism+i,jsm+j,k+1) = 0.0
    enddo
    enddo
    enddo
  endif

!====================================================================
! --- COMPUTE PBL DEPTH IF DESIRED
!====================================================================

  if (present(h)) then

      if (.not.present(ustar).or..not.present(bstar)) then
          CALL ERROR_MESG( ' MY25_TURB',     &
              'cannot request pbl depth diagnostic if ustar'// &
              ' and bstar are not also supplied', FATAL )
      end if
      if (present(kbot)) then
          call k_pbl_depth(ustar,bstar,akm,akh,zsfc,zfull,zhalf,&
                           h,kbot=kbot)
      else
          call k_pbl_depth(ustar,bstar,akm,akh,zsfc,zfull,zhalf,h)
      end if

  end if
!====================================================================

! $$$$$$$$$$$$$$$$$
  end do
! $$$$$$$$$$$$$$$$$

!====================================================================
  end SUBROUTINE MY25_TURB 

!#######################################################################
subroutine get_tke(is, ie, js, je, tke_out)
integer, intent(in) :: is, ie, js, je
real, intent(out), dimension(:,:,:) :: tke_out

if( .not. module_is_initialized ) then
  CALL ERROR_MESG(' MY25_TURB','MY25_TURB_INIT has not been called',FATAL)
endif

tke_out = TKE(is:ie,js:je,:)

end subroutine get_tke
!#######################################################################

  SUBROUTINE MY25_TURB_INIT( ix, jx, kx )

!=======================================================================
! ***** INITIALIZE MELLOR-YAMADA
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!     ix, jx  - Horizontal dimensions for global storage arrays
!     kx      - Number of vertical levels in model
!---------------------------------------------------------------------
 integer, intent(in) :: ix, jx, kx
!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
 integer             :: unit, io, ierr, logunit
 integer             :: id_restart

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

!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=my25_turb_nml, iostat=io)
   ierr = check_nml_error(io,'my25_turb_nml')
#else   
  if( FILE_EXIST( 'input.nml' ) ) then
! -------------------------------------
   unit = OPEN_NAMELIST_FILE ( )
   ierr = 1
   do while( ierr .ne. 0 )
   READ ( unit,  nml = my25_turb_nml, iostat = io, end = 10 ) 
   ierr = check_nml_error (io, 'my25_turb_nml')
   end do
10 continue
   CALL CLOSE_FILE( unit )
! -------------------------------------
  end if
#endif

!---------------------------------------------------------------------
! --- Output version
!---------------------------------------------------------------------

  if ( mpp_pe() == mpp_root_pe() ) then
       call write_version_number(version, tagname)
       logunit = stdlog()
       WRITE( logunit, nml = my25_turb_nml ) 
  endif

!---------------------------------------------------------------------
! --- Initialize constants
!---------------------------------------------------------------------

  if( use_old_cons ) then
      aa1 = aa1_old 
      aa2 = aa2_old  
      bb1 = bb1_old 
      bb2 = bb2_old  
      ccc = ccc_old  
  else
      aa1 = aa1_new 
      aa2 = aa2_new  
      bb1 = bb1_new 
      bb2 = bb2_new  
      ccc = ccc_new  
  end if

     ckm1 = ( 1.0 - 3.0*ccc )*aa1
     ckm3 =  3.0 * aa1*aa2*    ( bb2 - 3.0*aa2 )
     ckm4 =  9.0 * aa1*aa2*ccc*( bb2 + 4.0*aa1 )
     ckm5 =  6.0 * aa1*aa1
     ckm6 = 18.0 * aa1*aa1*aa2*( bb2 - 3.0*aa2 )
     ckm7 =  3.0 * aa2*        ( bb2 + 7.0*aa1 )
     ckm8 = 27.0 * aa1*aa2*aa2*( bb2 + 4.0*aa1 )
     ckm2 =  ckm3 - ckm4
     ckh1 =  aa2
     ckh2 =  6.0 * aa1*aa2
     ckh3 =  3.0 * aa2*( bb2 + 4.0*aa1 )
     ckh4 =  2.0e-6 * aa2
    cvfq1 = 5.0 * cc1 / 3.0
    cvfq2 = 1.0 / bb1
      bcq = 0.5 * ( bb1**(2.0/3.0) )

!---------------------------------------------------------------------
! --- Allocate storage for TKE
!---------------------------------------------------------------------

  if( ALLOCATED( TKE ) ) DEALLOCATE( TKE )
                           ALLOCATE( TKE(ix,jx,kx+1) ) ; TKE = TKEmin

!---------------------------------------------------------------------
! --- Input TKE
!---------------------------------------------------------------------

  id_restart = register_restart_field(Tur_restart, 'my25_turb.res', 'TKE', TKE)
  if (file_exist( 'INPUT/my25_turb.res.nc' )) then
      if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('my25_turb_mod',  'MY25_TURB_INIT:&
             &Reading netCDF formatted restart file: &
                                 &INPUT/my25_turb.res.nc', NOTE)
      endif
      call restore_state(Tur_restart)

  else if( FILE_EXIST( 'INPUT/my25_turb.res' ) ) then

      unit = OPEN_restart_FILE ( file = 'INPUT/my25_turb.res', action = 'read' )
      call read_data ( unit, TKE )
      CALL CLOSE_FILE( unit )

      init_tke = .false.
      
  else

      TKE  = TKEmin

      init_tke      = .true.
      num_total_pts = ix*jx
      pts_done      = 0

  endif

!-------------------------------------------------------------------
      module_is_initialized = .true.
!---------------------------------------------------------------------

 
!=====================================================================
  end SUBROUTINE MY25_TURB_INIT

!#######################################################################

  SUBROUTINE MY25_TURB_END
!=======================================================================
!=======================================================================
!--------------------------------------------------------------------
!  local variables:

      call my25_turb_restart
      module_is_initialized = .false.
 
!=====================================================================

  end SUBROUTINE MY25_TURB_END

!#######################################################################
! <SUBROUTINE NAME="my25_turb_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine my25_turb_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

  if(.not. present(timestamp)) then
      if (mpp_pe() == mpp_root_pe() ) &
            call error_mesg ('my25_turb_mod', 'my25_turb_end: &
              &Writing netCDF formatted restart file as  &
                &requested: RESTART/my25_turb.res.nc', NOTE)
  endif     

!----------------------------------------------------------------------
!    write out the restart data which is always needed, regardless of
!    when the first donner calculation step is after restart.
!----------------------------------------------------------------------
  call save_restart(Tur_restart, timestamp)

end subroutine my25_turb_restart
! </SUBROUTINE> NAME="my25_turb_restart"

!#######################################################################

  SUBROUTINE K_PBL_DEPTH(ustar,bstar,akm,akh,zsfc,zfull,zhalf,h,kbot)
!=======================================================================
 
  real,    intent(in), dimension(:,:)   :: ustar, bstar, zsfc
  real,    intent(in), dimension(:,:,:) :: zhalf, zfull
  real,    intent(in), dimension(:,:,:) :: akm, akh
  real,    intent(out),dimension(:,:)   :: h
  integer, intent(in), optional, dimension(:,:)   :: kbot

!=======================================================================
  real,    dimension(size(zfull,1),size(zfull,2)) :: km_surf, kh_surf
  real,    dimension(size(zfull,1),size(zfull,2)) :: zhalfhalf
  real, dimension(size(zfull,1),size(zfull,2),size(zfull,3))  :: zfull_ag
  real, dimension(size(zfull,1),size(zfull,2),size(zfull,3)+1):: zhalf_ag
  real, dimension(size(zfull,1),size(zfull,2),size(zfull,3)+1):: diff_tm
  integer, dimension(size(zfull,1),size(zfull,2))            :: ibot
  integer                                         :: i,j,k,nlev,nlat,nlon
  

nlev = size(zfull,3)
nlat = size(zfull,2)
nlon = size(zfull,1)
   
!compute height of surface
if (present(kbot)) then
   ibot=kbot
else
   ibot(:,:) = nlev
end if

!compute density profile, and heights relative to surface
do k = 1, nlev
  zfull_ag(:,:,k) = zfull(:,:,k) - zsfc(:,:)
  zhalf_ag(:,:,k) = zhalf(:,:,k) - zsfc(:,:)
  end do
zhalf_ag(:,:,nlev+1) = zhalf(:,:,nlev+1) - zsfc(:,:)


!compute height half way between surface and lowest model level
zhalfhalf=0.5*MINVAL(MAX(zfull_ag,0.0))
 
!compute k's there by a call to mo_diff
call mo_diff(zhalfhalf,ustar,bstar,km_surf,kh_surf)

!create combined surface k's and diffusivity matrix
diff_tm(:,:,nlev+1) = 0.
diff_tm(:,:,1:nlev) = 0.5*(akm+akh)
if (present(kbot)) then
do j=1,nlat
do i=1,nlon
   diff_tm(i,j,ibot(i,j)+1) = 0.5*(km_surf(i,j)+kh_surf(i,j))
   zhalf_ag(i,j,ibot(i,j)+1) = zhalfhalf(i,j)
enddo
enddo
else
   diff_tm(:,:,nlev+1) = 0.5*(km_surf(:,:)+kh_surf(:,:))
   zhalf_ag(:,:,nlev+1) = zhalfhalf(:,:)
end if


!determine pbl depth as the height above ground where diff_tm
!first falls beneath a critical value kcrit.  If the value between 
!ground and level 1 does not exceed kcrit set pbl depth equal to zero.
!kcrit is a namelist parameter.

do j = 1,nlat
do i = 1,nlon
             if (diff_tm(i,j,ibot(i,j)+1) .gt. kcrit) then
                       k=ibot(i,j)+1
                       do while (k.gt. 2 .and. &
                                 diff_tm(i,j,k-1).gt.kcrit)
                             k=k-1
                       enddo
                       h(i,j) = zhalf_ag(i,j,k) + &
                         (zhalf_ag(i,j,k-1)-zhalf_ag(i,j,k))* &
                         (diff_tm(i,j,k)-kcrit) / &
                         (diff_tm(i,j,k)-diff_tm(i,j,k-1))
             else
                       h(i,j) = 0.                      
             end if
enddo
enddo

!-----------------------------------------------------------------------


!=====================================================================
  end SUBROUTINE K_PBL_DEPTH

!#######################################################################

 SUBROUTINE TKE_SURF ( is, js, u_star, kbot )

!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!       u_star -  surface friction velocity (m/s)
!       kbot   -  OPTIONAL;lowest model level index (integer);
!                 at levels > Kbot, Mask = 0.
!---------------------------------------------------------------------
  integer, intent(in) :: is, js
  real, intent(in), dimension(:,:)   :: u_star

  integer, intent(in), OPTIONAL, dimension(:,:) :: kbot

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
  real, dimension(SIZE(u_star,1),SIZE(u_star,2)) :: x1
  integer  :: ix, jx, kxp, i, j, k

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

  ix  = SIZE( u_star, 1 )
  jx  = SIZE( u_star, 2 )
  kxp = SIZE( TKE,    3 )

!---------------------------------------------------------------------

  x1 = bcq * u_star * u_star

  if( PRESENT( kbot ) ) then
    do j = 1,jx
    do i = 1,ix
      k = kbot(i,j) + 1
      TKE(is+i-1,js+j-1,k) = x1(i,j) 
    end do
    end do
  else
    do j = 1,jx
    do i = 1,ix
      TKE(is+i-1,js+j-1,kxp) = x1(i,j) 
    end do
    end do
  endif

!=======================================================================
 end SUBROUTINE TKE_SURF 

!#######################################################################
  end MODULE MY25_TURB_MOD


                  module physics_driver_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="">
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!     Provides high level interfaces for calling the entire
!     FMS atmospheric physics package.
!
!    physics_driver_mod accesses the model's physics modules and
!    obtains tendencies and boundary fluxes due to the physical
!    processes that drive atmospheric time tendencies and supply 
!    boundary forcing to the surface models.
! </OVERVIEW>
! <DESCRIPTION>
!     This version of physics_driver_mod has been designed around the implicit
!     version diffusion scheme of the GCM. It requires two routines to advance
!     the model one time step into the future. These two routines
!     correspond to the down and up sweeps of the standard tridiagonal solver.
!     Radiation, Rayleigh damping, gravity wave drag, vertical diffusion of
!     momentum and tracers, and the downward pass of vertical diffusion for
!     temperature and specific humidity are performed in the down routine.
!     The up routine finishes the vertical diffusion and computes moisture
!     related terms (convection,large-scale condensation, and precipitation).
! </DESCRIPTION>
! <DIAGFIELDS>
! </DIAGFIELDS>
! <DATASET NAME="physics_driver.res">
! native format restart file
! </DATASET>
!
! <DATASET NAME="physics_driver.res.nc">
! netcdf format restart file
! </DATASET>


! <INFO>

!   <REFERENCE>            </REFERENCE>
!   <COMPILER NAME="">     </COMPILER>
!   <PRECOMP FLAG="">      </PRECOMP>
!   <LOADER FLAG="">       </LOADER>
!   <TESTPROGRAM NAME="">  </TESTPROGRAM>
!   <BUG>                  </BUG>
!   <NOTE> 
!   </NOTE>
!   <FUTURE> Deal with conservation of total energy?              </FUTURE>

! </INFO>
!   shared modules:

use time_manager_mod,        only: time_type, get_time, operator (-), &
                                   time_manager_init
use field_manager_mod,       only: field_manager_init, MODEL_ATMOS
use tracer_manager_mod,      only: tracer_manager_init, &
                                   get_number_tracers, &
                                   get_tracer_names

use atmos_tracer_driver_mod, only: atmos_tracer_driver_init,    &
                                   atmos_tracer_driver_time_vary, &
                                   atmos_tracer_driver_endts, &
                                   atmos_tracer_driver,  &
                                   atmos_tracer_driver_end
use mpp_mod,                 only: input_nml_file
use fms_mod,                 only: mpp_clock_id, mpp_clock_begin,   &
                                   mpp_clock_end, CLOCK_MODULE_DRIVER, &
                                   fms_init,  &
                                   open_namelist_file, stdlog, &
                                   write_version_number, field_size, &
                                   file_exist, error_mesg, FATAL,   &
                                   WARNING, NOTE, check_nml_error, &
                                   open_restart_file, read_data, &
                                   close_file, mpp_pe, mpp_root_pe, &
                                   write_data, mpp_error, mpp_chksum
use fms_io_mod,              only: get_restart_io_mode, &
                                   register_restart_field, restart_file_type, &
                                   save_restart, get_mosaic_tile_file
use constants_mod,           only: RDGAS

use diag_manager_mod,        only: register_diag_field, send_data

!    shared radiation package modules:

use rad_utilities_mod,       only: aerosol_type, radiative_gases_type, &
                                   rad_utilities_init, rad_output_type,&
                                   cld_specification_type,   &
                                   surface_type, &
                                   atmos_input_type, microphysics_type

!    component modules:

use cosp_driver_mod,         only: cosp_driver_init, cosp_driver, &
                                   cosp_driver_end
use  moist_processes_mod,    only: moist_processes,    &
                                   moist_processes_init,  &
                                   moist_processes_time_vary, &
                                   moist_processes_endts, &
                                   moist_processes_end,  &
                                   moist_alloc_init, &
                                   moist_alloc_end, &
                                   doing_strat!,          &
!                                   moist_processes_restart
use moistproc_kernels_mod,   only:  moistproc_init, moistproc_end

use vert_turb_driver_mod,    only: vert_turb_driver,  &
                                   vert_turb_driver_init,  &
                                   vert_turb_driver_end, &
                                   vert_turb_driver_restart

use vert_diff_driver_mod,    only: vert_diff_driver_down,  &
                                   vert_diff_driver_up,    &
                                   vert_diff_driver_init,  &
                                   vert_diff_driver_end,   &
                                   surf_diff_type

use radiation_driver_mod,    only: radiation_driver_init,    &
                                   define_rad_times, define_surface,   &
                                   define_atmos_input_fields, &
                                   radiation_driver_time_vary, &
                                   radiation_driver_endts, &
                                   radiation_driver,  &
                                   return_cosp_inputs, &
                                   atmos_input_dealloc,    &
                                   microphys_dealloc, &
                                   surface_dealloc, &
                                   radiation_driver_end, &
                                   radiation_driver_restart
  
use cloud_spec_mod,          only: cloud_spec_init, cloud_spec, &
                                   cloud_spec_dealloc, cloud_spec_end

use aerosol_mod,             only: aerosol_init, aerosol_driver, &
                                   aerosol_time_vary, &
                                   aerosol_endts, &
                                   aerosol_dealloc, aerosol_end
 
use radiative_gases_mod,     only: radiative_gases_init,   &
                                   radiative_gases_time_vary, &
                                   radiative_gases_endts, &
                                   define_radiative_gases, &
                                   radiative_gases_dealloc, &
                                   radiative_gases_end,     &
                                   radiative_gases_restart

use damping_driver_mod,      only: damping_driver,      &
                                   damping_driver_init, &
                                   damping_driver_time_vary,  &
                                   damping_driver_endts, &
                                   damping_driver_end,  &
                                   damping_driver_restart

use grey_radiation_mod,       only: grey_radiation_init, grey_radiation, &
                                    grey_radiation_end

#ifdef SCM
! Option to add SCM radiative tendencies from forcing to lw_tendency
! and radturbten

use scm_forc_mod,            only: use_scm_rad, add_scm_tdtlw, add_scm_tdtsw

#endif

!-----------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    physics_driver_mod accesses the model's physics modules and
!    obtains tendencies and boundary fluxes due to the physical
!    processes that drive atmospheric time tendencies and supply 
!    boundary forcing to the surface models.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128) :: version = '$Id: physics_driver.F90,v 17.0.2.1.6.1.2.1.2.1.2.2.2.1.2.1.4.1.2.1.2.1.2.1.2.2 2010/09/03 22:17:12 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public  physics_driver_init, physics_driver_down,   &
        physics_driver_down_time_vary, physics_driver_up_time_vary, &
        physics_driver_down_endts, physics_driver_up_endts, &
        physics_driver_moist_init, physics_driver_moist_end, &
        physics_driver_up, physics_driver_end, &
        do_moist_in_phys_up, get_diff_t, &
        get_radturbten, zero_radturbten, physics_driver_restart

private          &

!  called from physics_driver_init:
         read_restart_file, read_restart_nc,    &

!  called from physics_driver_down:
         check_args, &

!  called from check_args:
         check_dim

interface check_dim
     module procedure check_dim_2d, check_dim_3d, check_dim_4d
end interface


!---------------------------------------------------------------------
!------- namelist ------

logical :: do_moist_processes = .true.
                               ! call moist_processes routines
real    :: tau_diff = 3600.    ! time scale for smoothing diffusion 
                               ! coefficients
logical :: do_cosp = .false.   ! activate COSP simulator ?
logical :: do_modis_yim = .true. ! activate simple modis simulator ?
logical :: do_radiation = .true.
                               ! calculating radiative fluxes and
                               ! heating rates?
logical :: do_grey_radiation = .false. ! do grey radiation scheme?
real    :: R1 = 0.25           ! rif:(09/10/09) In Grey radiation we are computing just the total   
real    :: R2 = 0.25           ! SW radiation. We need to divide it into 4 components
real    :: R3 = 0.25           ! to go through the Coupler and Ice modules.
real    :: R4 = 0.25           ! 	Sum[R(i)*SW] = SW  


real    :: diff_min = 1.e-3    ! minimum value of a diffusion 
                               ! coefficient beneath which the
                               ! coefficient is reset to zero
logical :: diffusion_smooth = .true.
                               ! diffusion coefficients should be 
                               ! smoothed in time?
logical :: use_cloud_tracers_in_radiation = .true.
                               ! if true, use lsc cloud tracer fields
                               ! in radiation (these transported on
                               ! current step, will have non-realizable
                               ! total cloud areas at some points); if
                               ! false, then use balanced (realizable)
                               ! fields saved at end of last step
                               ! only an issue when both lsc and conv
                               ! clouds are active (AM3)
logical :: donner_meso_is_largescale = .true.
                               ! donner meso clouds are treated as 
                               ! largescale (rather than convective)
                               ! as far as the COSP simulator is 
                               ! concerned ?
logical :: allow_cosp_precip_wo_clouds = .true.
                               ! COSP will see {ls, cv} precip in grid-
                               ! boxes w/o {ls, cv} clouds ?

! <NAMELIST NAME="physics_driver_nml">
!  <DATA NAME="do_radiation" UNITS="" TYPE="logical" DIM="" DEFAULT=".true.">
!calculating radiative fluxes and
! heating rates?
!  </DATA>
!  <DATA NAME="do_moist_processes" UNITS="" TYPE="logical" DIM="" DEFAULT=".true.">
!call moist_processes routines
!  </DATA>
!  <DATA NAME="tau_diff" UNITS="" TYPE="real" DIM="" DEFAULT="3600.">
!time scale for smoothing diffusion 
! coefficients
!  </DATA>
!  <DATA NAME="diff_min" UNITS="" TYPE="real" DIM="" DEFAULT="1.e-3">
!minimum value of a diffusion 
! coefficient beneath which the
! coefficient is reset to zero
!  </DATA>
!  <DATA NAME="diffusion_smooth" UNITS="" TYPE="logical" DIM="" DEFAULT=".true.">
!diffusion coefficients should be 
! smoothed in time?
!  </DATA>
! </NAMELIST>
!
namelist / physics_driver_nml / do_radiation, &
                                do_cosp, &
                                do_modis_yim, &
                                donner_meso_is_largescale, &
                                allow_cosp_precip_wo_clouds, &
                                do_moist_processes, tau_diff,      &
                                diff_min, diffusion_smooth, &
                                use_cloud_tracers_in_radiation, &
                                do_grey_radiation, R1, R2, R3, R4 

!---------------------------------------------------------------------
!------- public data ------
! <DATA NAME="surf_diff_type" UNITS="" TYPE="surf_diff_type" DIM="" DEFAULT="">
! Defined in vert_diff_driver_mod, republished here. See vert_diff_mod for details.
! </DATA>

public  surf_diff_type   ! defined in  vert_diff_driver_mod, republished
                         ! here
 
!---------------------------------------------------------------------
!------- private data ------

!--------------------------------------------------------------------
! list of restart versions readable by this module:
!
! version 1: initial implementation 1/2003, contains diffusion coef-
!            ficient contribution from cu_mo_trans_mod. This variable
!            is generated in physics_driver_up (moist_processes) and
!            used on the next step in vert_diff_down, necessitating
!            its storage.
!
! version 2: adds pbltop as generated in vert_turb_driver_mod. This 
!            variable is then used on the next timestep by topo_drag
!            (called from damping_driver_mod), necessitating its 
!            storage.
!
! version 3: adds the diffusion coefficients which are passed to 
!            vert_diff_driver.  These diffusion are saved should
!            smoothing of vertical diffusion coefficients be turned
!            on.
!
! version 4: adds a logical variable, convect, which indicates whether
!            or not the grid column is convecting. This diagnostic is
!            needed by the entrain_module in vert_turb_driver.
!
! version 5: adds radturbten when strat_cloud_mod is active, adds 
!            lw_tendency when edt_mod or entrain_mod is active.
!
! version 6: adds donner cell and meso cloud variables when donner_deep
!            is activated.

! version 7: adds shallow convection cloud variables when uw_conv
!            is activated.

! version 8: adds lsc cloud props for radiation. only readable when in
!            netcdf mode.


!---------------------------------------------------------------------
integer, dimension(8) :: restart_versions = (/ 1, 2, 3, 4, 5, 6, 7, 8 /)

!--------------------------------------------------------------------
!    the following allocatable arrays are either used to hold physics 
!    data between timesteps when required, or hold physics data between
!    physics_down and physics_up.
!  
!    diff_cu_mo     contains contribution to difusion coefficient
!                   coming from cu_mo_trans_mod (called from 
!                   moist_processes in physics_driver_up) and then used 
!                   as input on the next time step to vert_diff_down 
!                   called in physics_driver_down.
!    diff_t         vertical diffusion coefficient for temperature
!                   which optionally may be time smoothed, meaning
!                   values must be saved between steps
!    diff_m         vertical diffusion coefficient for momentum
!                   which optionally may be time smoothed, meaning
!                   values must be saved between steps
!    radturbten     the sum of the radiational and turbulent heating,
!                   generated in both physics_driver_down (radiation)
!                   and physics_driver_up (turbulence) and then used
!                   in moist_processes
!    lw_tendency    longwave heating rate, generated in radiation and
!                   needed in vert_turb_driver when either edt_mod
!                   or entrain_mod is active. must be saved because
!                   radiation is not calculated on each step.
!    pbltop         top of boundary layer obtained from vert_turb_driver
!                   and then used on the next timestep in topo_drag_mod
!                   called from damping_driver_down        
!    convect        flag indicating whether convection is occurring in
!                   a grid column. generated in physics_driver_up and
!                   then used in vert_turb_driver called from 
!                   physics_driver_down on the next step.
!----------------------------------------------------------------------
real,    dimension(:,:,:), allocatable :: diff_cu_mo, diff_t, diff_m
real,    dimension(:,:,:), allocatable :: radturbten, lw_tendency
real,    dimension(:,:)  , allocatable :: pbltop, cush, cbmf
logical, dimension(:,:)  , allocatable :: convect
real,    dimension(:,:,:), allocatable ::       &
                           cell_cld_frac, cell_liq_amt, &
                           cell_liq_size, cell_ice_amt, cell_ice_size, &
                           cell_droplet_number, &
                           meso_cld_frac, meso_liq_amt, meso_liq_size, &
                           meso_ice_amt, meso_ice_size, &
                           meso_droplet_number, &
                           lsc_cloud_area, lsc_liquid, &
                           lsc_ice, lsc_droplet_number, &
                           shallow_cloud_area, shallow_liquid, &
                           shallow_ice, shallow_droplet_number, &
                           temp_last, q_last
real,    dimension(:,:,:,:), allocatable ::  tau_stoch, lwem_stoch, &
                           stoch_cloud_type, stoch_conc_drop, &
                           stoch_conc_ice, stoch_size_drop, &
                           stoch_size_ice
real,    dimension(:,:,:), allocatable ::  fl_lsrain, fl_lssnow, &
                                           fl_lsgrpl, &
                                           fl_donmca_rain, fl_donmca_snow,&
                                           fl_ccrain, fl_ccsnow, &
                                           mr_ozone
real,       dimension(:,:), allocatable  :: daytime
integer,    dimension(:,:)  , allocatable :: nsum_out
real   ,    dimension(:,:)  , allocatable :: tsurf_save
   
!--- for netcdf restart
type(restart_file_type), pointer, save :: Phy_restart => NULL()
type(restart_file_type), pointer, save :: Til_restart => NULL()
logical                                :: in_different_file = .false.
logical                                :: do_netcdf_restart = .true.              
integer                                :: vers
integer                                :: now_doing_strat  
integer                                :: now_doing_entrain
integer                                :: now_doing_edt
real, allocatable                      :: r_convect(:,:)

!---------------------------------------------------------------------
!    internal timing clock variables:
!---------------------------------------------------------------------
integer :: radiation_clock, damping_clock, turb_clock,   &
           tracer_clock, diff_up_clock, diff_down_clock, &
           moist_processes_clock, cosp_clock

!--------------------------------------------------------------------
!    miscellaneous control variables:
!---------------------------------------------------------------------
logical   :: do_check_args = .true.   ! argument dimensions should 
                                      ! be checked ?
logical   :: module_is_initialized = .false.
                                      ! module has been initialized ?
logical   :: doing_edt                ! edt_mod has been activated ?
logical   :: doing_entrain            ! entrain_mod has been activated ?
logical   :: doing_donner             ! donner_deep_mod has been 
                                      ! activated ?
logical   :: doing_uw_conv            ! uw_conv shallow cu mod has been 
                                      ! activated ?
logical   :: doing_liq_num = .false.  ! Prognostic cloud droplet number has 
                                      ! been activated?
integer   :: nt                       ! total no. of tracers
integer   :: ntp                      ! total no. of prognostic tracers
integer   :: ncol                     ! number of stochastic columns
 
type(radiative_gases_type)   :: Rad_gases_tv
type(time_type)  :: Rad_time
logical          ::    need_aerosols, need_clouds, need_gases,   &
                       need_basic
logical    :: do_strat
integer   :: num_uw_tracers


!---------------------------------------------------------------------
!---------------------------------------------------------------------

character(len=4)     :: mod_name = 'phys'
character(len=32)    :: tracer_units, tracer_name
  character(len=128) :: diaglname
real                 :: missing_value = -999.
logical              :: step_to_call_cosp = .false.
logical              :: include_donmca_in_cosp

integer                            :: id_tdt_phys, id_qdt_phys, &
                                      id_tdt_phys_vdif_dn, &
                                      id_tdt_phys_vdif_up, &
                                      id_tdt_phys_turb,    &
                                      id_tdt_phys_moist

integer, dimension(:), allocatable :: id_tracer_phys_vdif_dn, &
                                      id_tracer_phys_vdif_up, &
                                      id_tracer_phys_turb,    &
                                      id_tracer_phys_moist


                            contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="physics_driver_init">
!  <OVERVIEW>
!    physics_driver_init is the constructor for physics_driver_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    physics_driver_init is the constructor for physics_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call physics_driver_init (Time, lonb, latb, axes, pref, &
!                             trs, Surf_diff, phalf, mask, kbot  )
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="pref" TYPE="real">
!   reference prssure profiles
!  </IN>
!  <IN NAME="latb" TYPE="real">
!   array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   array of model longitudes at cell corners [radians]
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!   axis indices, (/x,y,pf,ph/)
!                (returned from diag axis manager)
!  </IN>
!  <INOUT NAME="trs" TYPE="real">
!   atmospheric tracer fields
!  </INOUT>
!  <INOUT NAME="Surf_diff" TYPE="surf_diff_type">
!   surface diffusion derived type
!  </INOUT>
!  <IN NAME="phalf" TYPE="real">
!   pressure at model interface levels
!  </IN>
!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! <ERROR MSG="physics_driver_init must be called first" STATUS="FATAL">
! </ERROR>
! </SUBROUTINE>
!
subroutine physics_driver_init (Time, lonb, latb, axes, pref, &
                                trs, Surf_diff, phalf, mask, kbot, &
                                diffm, difft  )

!---------------------------------------------------------------------
!    physics_driver_init is the constructor for physics_driver_mod.
!---------------------------------------------------------------------

type(time_type),         intent(in)              :: Time
real,dimension(:,:),     intent(in)              :: lonb, latb
integer,dimension(4),    intent(in)              :: axes
real,dimension(:,:),     intent(in)              :: pref
real,dimension(:,:,:,:), intent(inout)           :: trs
type(surf_diff_type),    intent(inout)           :: Surf_diff
real,dimension(:,:,:),   intent(in)              :: phalf
real,dimension(:,:,:),   intent(in),   optional  :: mask
integer,dimension(:,:),  intent(in),   optional  :: kbot
real, dimension(:,:,:),  intent(out),  optional  :: diffm, difft

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     Time       current time (time_type)
!     lonb       longitude of the grid box corners [ radians ]
!     latb       latitude of the grid box corners [ radians ]
!     axes       axis indices, (/x,y,pf,ph/)
!                (returned from diag axis manager)
!     pref       two reference profiles of pressure at nlev+1 levels
!                pref(nlev+1,1)=101325. and pref(nlev+1,2)=81060.
!     phalf      pressure at model interface levels
!                [ Pa ]
!
!   intent(inout) variables:
!
!     trs        atmosperic tracer fields
!     Surf_diff  surface diffusion derived type variable
!
!   intent(in), optional variables:
!
!        mask    present when running eta vertical coordinate,
!                mask to remove points below ground
!        kbot    present when running eta vertical coordinate,
!                index of lowest model level above ground
!   
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(lonb,1)-1, size(latb,2)-1) :: sgsmtn
      character(len=64), dimension(:), pointer :: aerosol_names => NULL()
      character(len=64), dimension(:), pointer :: aerosol_family_names => NULL()
      integer          ::  id, jd, kd, n
      integer          ::  ierr, io, unit, logunit
      integer          ::  ndum

      integer          ::  moist_processes_init_clock, damping_init_clock, &
                           turb_init_clock, diff_init_clock, &
                           cloud_spec_init_clock, aerosol_init_clock, &
                           grey_radiation_init_clock , radiative_gases_init_clock, &
                           radiation_init_clock, tracer_init_clock, &
                           cosp_init_clock

!---------------------------------------------------------------------
!  local variables:
!
!       sgsmtn        sgs orography obtained from mg_drag_mod;
!                     appears to not be currently used
!       aerosol_names names associated with the activated aerosols
!                     that will be seen by the radiation package
!       aerosol_family_names
!              names associated with the activated aerosol
!              families that will be seen by the radiation package
!       id,jd,kd      model dimensions on the processor  
!       ierr          error code
!       io            io status returned from an io call
!       unit          unit number used for an i/ operation

!---------------------------------------------------------------------
!    if routine has already been executed, return.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that the modules used by this module that are not called 
!    later in this subroutine have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call time_manager_init
      call tracer_manager_init
      call field_manager_init (ndum)
 
!--------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=physics_driver_nml, iostat=io)
      ierr = check_nml_error(io,"physics_driver_nml")
#else
!--------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit = open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=physics_driver_nml, iostat=io, end=10)
        ierr = check_nml_error(io, 'physics_driver_nml')
        enddo
10      call close_file (unit)
      endif
#endif

      if(do_radiation .and. do_grey_radiation) & 
        call error_mesg('physics_driver_init','do_radiation and do_grey_radiation cannot both be .true.',FATAL)

      call get_restart_io_mode(do_netcdf_restart)

!--------------------------------------------------------------------
!    write version number and namelist to log file.
!--------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
               write(logunit, nml=physics_driver_nml)
 
!---------------------------------------------------------------------
!    define the model dimensions on the local processor.
!---------------------------------------------------------------------
      id = size(lonb,1)-1 
      jd = size(latb,2)-1 
      kd = size(trs,3)
      call get_number_tracers (MODEL_ATMOS, num_tracers=nt, &
                               num_prog=ntp)

!---------------------------------------------------------------------
      radiation_clock       =       &
                mpp_clock_id( '   Physics_down: Radiation',    &
                   grain=CLOCK_MODULE_DRIVER )
      cosp_clock       =       &
                mpp_clock_id( '   Physics_down: COSP',    &
                   grain=CLOCK_MODULE_DRIVER )
      damping_clock         =     &
                mpp_clock_id( '   Physics_down: Damping',    &
                  grain=CLOCK_MODULE_DRIVER )
      turb_clock            =      &
                mpp_clock_id( '   Physics_down: Vert. Turb.', &
                  grain=CLOCK_MODULE_DRIVER )
      tracer_clock          =      &
                mpp_clock_id( '   Physics_down: Tracer',    &
                 grain=CLOCK_MODULE_DRIVER )
      diff_down_clock       =     &
                mpp_clock_id( '   Physics_down: Vert. Diff.',   &
                 grain=CLOCK_MODULE_DRIVER )
      diff_up_clock         =     &
                mpp_clock_id( '   Physics_up: Vert. Diff.',     &
                grain=CLOCK_MODULE_DRIVER )
      moist_processes_clock =      &
                mpp_clock_id( '   Physics_up: Moist Processes', &
                grain=CLOCK_MODULE_DRIVER )

      moist_processes_init_clock =      &
        mpp_clock_id( '   Physics_driver_init: Moist Processes: Initialization', &
                grain=CLOCK_MODULE_DRIVER )
      damping_init_clock         =     &
        mpp_clock_id( '   Physics_driver_init: Damping: Initialization',    &
                  grain=CLOCK_MODULE_DRIVER )
      turb_init_clock            =      &
        mpp_clock_id( '   Physics_driver_init: Vert. Turb.: Initialization', &
                  grain=CLOCK_MODULE_DRIVER )
      diff_init_clock       =     &
        mpp_clock_id( '   Physics_driver_init: Vert. Diff.: Initialization',   &
                 grain=CLOCK_MODULE_DRIVER )
      cloud_spec_init_clock       =       &
        mpp_clock_id( '   Physics_driver_init: Cloud spec: Initialization', &
                       grain=CLOCK_MODULE_DRIVER )
      cosp_init_clock       =       &
        mpp_clock_id( '   Physics_driver_init: COSP: Initialization', &
                       grain=CLOCK_MODULE_DRIVER )
      aerosol_init_clock       =       &
        mpp_clock_id( '   Physics_driver_init: Aerosol: Initialization', &
                       grain=CLOCK_MODULE_DRIVER )
      grey_radiation_init_clock       =       &
        mpp_clock_id( '   Physics_driver_init: Grey Radiation: Initialization', &
                       grain=CLOCK_MODULE_DRIVER )
      radiative_gases_init_clock       =       &
        mpp_clock_id( '   Physics_driver_init: Radiative gases: Initialization', &
                       grain=CLOCK_MODULE_DRIVER )
      radiation_init_clock       =       &
        mpp_clock_id( '   Physics_driver_init: Radiation: Initialization', &
                       grain=CLOCK_MODULE_DRIVER )
      tracer_init_clock          =      &
        mpp_clock_id( '   Physics_driver_init: Tracer: Initialization',    &
                 grain=CLOCK_MODULE_DRIVER )

!-----------------------------------------------------------------------
      call mpp_clock_begin ( moist_processes_init_clock )
      call  moist_processes_init (id, jd, kd, lonb, latb, pref(:,1),&
                                  axes, Time, doing_donner,  &
                                  doing_uw_conv,  &
                                  num_uw_tracers, do_strat, &
                                  do_cosp_in=do_cosp, &
                                  donner_meso_is_largescale_in= &
                                          donner_meso_is_largescale, &
                                  include_donmca_in_cosp_out = &
                                          include_donmca_in_cosp)

      call mpp_clock_end ( moist_processes_init_clock )
     
!-----------------------------------------------------------------------
!    initialize damping_driver_mod.
!-----------------------------------------------------------------------
      call mpp_clock_begin ( damping_init_clock )
      call damping_driver_init (lonb, latb, pref(:,1), axes, Time, &
                                sgsmtn)
      call mpp_clock_end ( damping_init_clock )

!-----------------------------------------------------------------------
!    initialize vert_turb_driver_mod.
!-----------------------------------------------------------------------
      call mpp_clock_begin ( turb_init_clock )
      call vert_turb_driver_init (lonb, latb, id, jd, kd, axes, Time, &
                                  doing_edt, doing_entrain)
      call mpp_clock_end ( turb_init_clock )

!-----------------------------------------------------------------------
!    initialize vert_diff_driver_mod.
!-----------------------------------------------------------------------
      call mpp_clock_begin ( diff_init_clock )
      call vert_diff_driver_init (Surf_diff, id, jd, kd, axes, Time )
      call mpp_clock_end ( diff_init_clock )

      if (do_radiation) then
!-----------------------------------------------------------------------
!    initialize cloud_spec_mod.
!-----------------------------------------------------------------------
        call mpp_clock_begin ( cloud_spec_init_clock )
        call cloud_spec_init (pref, lonb, latb, axes, Time)
        call mpp_clock_end ( cloud_spec_init_clock )
 
!-----------------------------------------------------------------------
!    initialize aerosol_mod.     
!-----------------------------------------------------------------------
        call mpp_clock_begin ( aerosol_init_clock )
        call aerosol_init (lonb, latb, aerosol_names, aerosol_family_names)
        call mpp_clock_end ( aerosol_init_clock )
!-----------------------------------------------------------------------
!    initialize radiative_gases_mod.
!-----------------------------------------------------------------------
        call mpp_clock_begin ( radiative_gases_init_clock )
        call radiative_gases_init (pref, latb, lonb)
        call mpp_clock_end ( radiative_gases_init_clock )
 
!-----------------------------------------------------------------------
!    initialize radiation_driver_mod.
!-----------------------------------------------------------------------
        call mpp_clock_begin ( radiation_init_clock )
        call radiation_driver_init (lonb, latb, pref, axes, time,  &
                                    aerosol_names, &
                                    aerosol_family_names, do_cosp, ncol)
        call mpp_clock_end ( radiation_init_clock )

!---------------------------------------------------------------------
!    deallocate space for local pointers.
!---------------------------------------------------------------------
        deallocate (aerosol_names, aerosol_family_names)

      else if (do_moist_processes) then
!-----------------------------------------------------------------------
!    initialize aerosol_mod.     
!-----------------------------------------------------------------------
        call mpp_clock_begin ( aerosol_init_clock )
        call aerosol_init (lonb, latb, aerosol_names, aerosol_family_names)
        call mpp_clock_end ( aerosol_init_clock )

      endif ! do_radiation

      if(do_grey_radiation) then
         call mpp_clock_begin ( grey_radiation_init_clock )
         call grey_radiation_init(axes, Time) 
         call mpp_clock_end ( grey_radiation_init_clock )
      endif
        
!-----------------------------------------------------------------------
!    initialize atmos_tracer_driver_mod.
!-----------------------------------------------------------------------
      call mpp_clock_begin ( tracer_init_clock )
      call atmos_tracer_driver_init (lonb, latb, trs, axes, time,  &
                                     phalf, mask)
      call mpp_clock_end ( tracer_init_clock )

!---------------------------------------------------------------------
!    allocate space for the module variables.
!---------------------------------------------------------------------
      allocate ( diff_t     (id, jd, kd) )
      allocate ( diff_m     (id, jd, kd) )
      allocate ( diff_cu_mo (id, jd, kd) ) 
      allocate ( pbltop     (id, jd) )
      allocate ( cush       (id, jd) ); cush=-1. !miz
      allocate ( cbmf       (id, jd) ); cbmf=0.0 !miz
      allocate ( convect    (id, jd) )
      allocate ( radturbten (id, jd, kd))
      allocate ( lw_tendency(id, jd, kd))
      allocate ( r_convect  (id, jd) )       
       
!--------------------------------------------------------------------
!    these variables needed to preserve rain fluxes, q and T from end 
!    of one step for use in COSP simulator on next step.
!--------------------------------------------------------------------
      allocate (fl_lsrain  (id, jd, kd))
      allocate (fl_lssnow  (id, jd, kd))
      allocate (fl_lsgrpl  (id, jd, kd))
      allocate (fl_ccrain  (id, jd, kd))
      allocate (fl_ccsnow  (id, jd, kd))
      allocate (fl_donmca_snow  (id, jd, kd))
      allocate (fl_donmca_rain  (id, jd, kd))
      allocate (mr_ozone   (id, jd, kd))
      allocate (daytime    (id, jd    ))
      allocate ( temp_last (id, jd, kd))
      allocate ( q_last    (id, jd, kd))
      fl_lsrain = 0.
      fl_lssnow = 0.
      fl_lsgrpl = 0.
      fl_ccrain = 0.
      fl_ccsnow = 0.
      fl_donmca_rain = 0.
      fl_donmca_snow = 0.
      mr_ozone  = 0.
      daytime =   0.
      temp_last = 0.
      q_last    = 0.

!--------------------------------------------------------------------
!    these variables needed to preserve radiative inputs to COSP from 
!    physics_driver_down to physics_driver_up.
!--------------------------------------------------------------------
      if (do_cosp .or. do_modis_yim) then
        allocate ( tau_stoch          (id, jd, kd,ncol))
        allocate ( lwem_stoch         (id, jd, kd,ncol))
        allocate ( stoch_cloud_type   (id, jd, kd,ncol))
        allocate ( stoch_conc_drop    (id, jd, kd,ncol))
        allocate ( stoch_conc_ice     (id, jd, kd,ncol))
        allocate ( stoch_size_drop    (id, jd, kd,ncol))
        allocate ( stoch_size_ice     (id, jd, kd,ncol))
        allocate ( tsurf_save         (id, jd)         )
 
        tau_stoch = 0.
        lwem_stoch = 0.
        stoch_cloud_type = 0.
        stoch_conc_drop = 0.
        stoch_conc_ice  = 0.
        stoch_size_drop = 0.
        stoch_size_ice  = 0.
        tsurf_save = 0.
      endif

      if (doing_donner) then

        allocate (cell_cld_frac (id, jd, kd) )
        allocate (cell_liq_amt  (id, jd, kd) )
        allocate (cell_liq_size (id, jd, kd) )
        allocate (cell_ice_amt  (id, jd, kd) )
        allocate (cell_ice_size (id, jd, kd) )
        allocate (cell_droplet_number (id, jd, kd) )
        allocate (meso_cld_frac (id, jd, kd) )
        allocate (meso_liq_amt  (id, jd, kd) )
        allocate (meso_liq_size (id, jd, kd) )
        allocate (meso_ice_amt  (id, jd, kd) )
        allocate (meso_ice_size (id, jd, kd) )
        allocate (meso_droplet_number (id, jd, kd) )
        allocate (nsum_out (id, jd) )
        cell_cld_frac = 0.
        cell_liq_amt  = 0.
        cell_liq_size = 0.
        cell_ice_amt  = 0.
        cell_ice_size = 0.
        cell_droplet_number = 0.
        meso_cld_frac = 0.
        meso_liq_amt  = 0.
        meso_liq_size = 0.
        meso_ice_amt  = 0.
        meso_ice_size = 0.
        meso_droplet_number = 0.
        nsum_out = 1
      endif

       allocate (lsc_cloud_area     (id, jd, kd) )
       allocate (lsc_liquid         (id, jd, kd) )
       allocate (lsc_ice            (id, jd, kd) )
       allocate (lsc_droplet_number (id, jd, kd) )
       lsc_cloud_area      = 0.
       lsc_liquid          = 0.
       lsc_ice             = 0.
       lsc_droplet_number  = 0.

       if (doing_uw_conv) then
 
         allocate (shallow_cloud_area     (id, jd, kd) )
         allocate (shallow_liquid         (id, jd, kd) )
         allocate (shallow_ice            (id, jd, kd) )
         allocate (shallow_droplet_number (id, jd, kd) )
         shallow_cloud_area      = 0.
         shallow_liquid          = 0.
         shallow_ice             = 0.
         shallow_droplet_number  = 0.
       endif

!--------------------------------------------------------------------
!    call physics_driver_read_restart to obtain initial values for the module
!    variables. Also register restart fields to be ready for intermediate restart if
!    do_netcdf_restart is true.
!--------------------------------------------------------------------
     
      if(do_netcdf_restart) call physics_driver_register_restart
      if(file_exist('INPUT/physics_driver.res.nc')) then
         call read_restart_nc
      else
         call read_restart_file
      endif
      vers = restart_versions(size(restart_versions(:)))

!---------------------------------------------------------------------
!    if desired, define variables to return diff_m and diff_t.
!---------------------------------------------------------------------
      if (present(difft)) then
        difft = diff_t
      endif
      if (present(diffm)) then
        diffm = diff_m
      endif

!---------------------------------------------------------------------
!    initialize module diagnostics
!---------------------------------------------------------------------

      id_tdt_phys_vdif_dn = register_diag_field ( mod_name,    &
         'tdt_phys_vdif_dn', axes(1:3), Time,                  &
         'temperature tendency from physics driver vdif down', &
         'K/s', missing_value=missing_value)

      id_tdt_phys_vdif_up = register_diag_field ( mod_name,    &
         'tdt_phys_vdif_up', axes(1:3), Time,                  &
         'temperature tendency from physics driver vdif up',   &
         'K/s', missing_value=missing_value)

      id_tdt_phys_turb = register_diag_field ( mod_name,       &
         'tdt_phys_turb', axes(1:3), Time,                     &
         'temperature tendency from physics driver vdif turb', &
         'K/s', missing_value=missing_value)

      id_tdt_phys_moist = register_diag_field ( mod_name,            &
         'tdt_phys_moist', axes(1:3), Time,                          &
         'temperature tendency from physics driver moist processes', &
         'K/s', missing_value=missing_value)

      id_tdt_phys = register_diag_field ( mod_name,            &
         'tdt_phys', axes(1:3), Time,                          &
         'temperature tendency from physics ', &
         'K/s', missing_value=missing_value)

      id_qdt_phys = register_diag_field ( mod_name,            &
         'qdt_phys', axes(1:3), Time,                          &
         'specific humidity tendency from physics ', &
         'kg/kg/s', missing_value=missing_value)
    
      allocate (id_tracer_phys_vdif_dn(nt))
      allocate (id_tracer_phys_vdif_up(nt))
      allocate (id_tracer_phys_turb(nt))
      allocate (id_tracer_phys_moist(nt))

      do n = 1,nt

        call get_tracer_names (MODEL_ATMOS, n, name = tracer_name,  &
                               units = tracer_units)
        
        diaglname = trim(tracer_name)//  &
                    ' tendency from physics driver vdif down'
        id_tracer_phys_vdif_dn(n) =    &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'_phys_vdif_dn',  &
                         axes(1:3), Time, trim(diaglname), &
                         TRIM(tracer_units)//'/s',  &
                         missing_value=missing_value)

        diaglname = trim(tracer_name)//  &
                    ' tendency from physics driver vdif up'
        id_tracer_phys_vdif_up(n) =    &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'_phys_vdif_up',  &
                         axes(1:3), Time, trim(diaglname), &
                         TRIM(tracer_units)//'/s',  &
                         missing_value=missing_value)

        diaglname = trim(tracer_name)//  &
                    ' tendency from physics driver vert turb'
        id_tracer_phys_turb(n) =    &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'_phys_turb',  &
                         axes(1:3), Time, trim(diaglname), &
                         TRIM(tracer_units)//'/s',  &
                         missing_value=missing_value)

        diaglname = trim(tracer_name)//  &
                    ' tendency from physics driver moist processes'
        id_tracer_phys_moist(n) =    &
                         register_diag_field ( mod_name, &
                         TRIM(tracer_name)//'_phys_moist',  &
                         axes(1:3), Time, trim(diaglname), &
                         TRIM(tracer_units)//'/s',  &
                         missing_value=missing_value)

      end do

!--------------------------------------------------------------------
!    if COSP is activated, call its initialization routine.
!--------------------------------------------------------------------
      if (do_cosp) then
        call mpp_clock_begin ( cosp_init_clock )
        call cosp_driver_init (lonb, latb, Time, axes, kd, ncol)
        call mpp_clock_end   ( cosp_init_clock )
      endif

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!-----------------------------------------------------------------------



 end subroutine physics_driver_init


!######################################################################
! <SUBROUTINE NAME="physics_driver_down_time_vary">
!  <OVERVIEW>
!    physics_driver_time_vary makes sure that all time-dependent, spacially-
!    independent calculations are completed before entering window or thread
!    loops. Resultant fields are usually saved as module variables in the
!    module where needed.
!  </OVERVIEW>
!  <DESCRIPTION>
!    physics_driver_time_vary makes sure that all time-dependent, spacially-
!    independent calculations are completed before entering window or thread
!    loops. Resultant fields are usually saved as module variables in the
!    module where needed.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call physics_driver_down_time_vary (Time, Time_next)
!
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   time of next time step
!  </IN>
! </SUBROUTINE>
!

subroutine physics_driver_down_time_vary (Time, Time_next, gavg_rrv, dt)

!---------------------------------------------------------------------
!    physics_driver_down_time_vary makes sure that all time-dependent, 
!    spacially-independent calculations are completed before entering window 
!    or thread loops. Resultant fields are usually saved as module variables in 
!    the module where needed.
!-----------------------------------------------------------------------

type(time_type),         intent(in)             :: Time, Time_next
real, dimension(:),      intent(in)             :: gavg_rrv
real,                    intent(in)             :: dt

!---------------------------------------------------------------------      
      if (do_radiation) then
!----------------------------------------------------------------------
!    call define_rad_times to obtain the time to be used in the rad-
!    iation calculation (Rad_time) and to determine which, if any, 
!    externally-supplied inputs to radiation_driver must be obtained on 
!    this timestep.  logical flags are returned indicating the need or 
!    lack of need for the aerosol fields, the cloud fields, the rad-
!    iative gas fields, and the basic atmospheric variable fields.
!----------------------------------------------------------------------
        call define_rad_times (Time, Time_next, Rad_time, &
                               need_aerosols, need_clouds, &
                               need_gases, need_basic)
        call aerosol_time_vary (Rad_time)
        call radiative_gases_time_vary (Rad_time, gavg_rrv,  &
                                                           Rad_gases_tv)
        call radiation_driver_time_vary (Rad_time, Rad_gases_tv)
        
!--------------------------------------------------------------------
!    define step_to_call_cosp to indicate that this is a radiation
!    step and therefore one on which COSP should be called in 
!    physics_driver_up.
!--------------------------------------------------------------------
        if (need_basic) then
          step_to_call_cosp = .true.
        else
          step_to_call_cosp = .false.
        endif

      endif
      call damping_driver_time_vary (dt)
      call atmos_tracer_driver_time_vary (Time)

!-------------------------------------------------------------------------      

end subroutine physics_driver_down_time_vary



!######################################################################

subroutine physics_driver_down_endts(is,js)

integer, intent(in)  :: is,js

      call damping_driver_endts
      call atmos_tracer_driver_endts

      IF (do_radiation) THEN
         CALL aerosol_endts
         CALL radiation_driver_endts  (is, js, Rad_gases_tv)
         CALL radiative_gases_endts
      END IF
   

!--------------------------------------------------------------------
!    set a flag to indicate that this check was done and need not be
!    done again.
!--------------------------------------------------------------------
      do_check_args = .false.


end subroutine physics_driver_down_endts




!###################################################################


subroutine physics_driver_up_time_vary (Time, dt)

!---------------------------------------------------------------------
!    physics_driver_up_time_vary makes sure that all time-dependent, 
!    spacially-independent calculations are completed before entering 
!    window or thread loops. Resultant fields are usually saved as 
!    module variables in the module where needed.
!-----------------------------------------------------------------------

type(time_type),         intent(in)             :: Time
real,                    intent(in)             :: dt

      call aerosol_time_vary (Time)
      call moist_processes_time_vary (dt)

!----------------------------------------------------------------------      

end subroutine physics_driver_up_time_vary


!######################################################################

subroutine physics_driver_up_endts (is,js)

integer, intent(in)  :: is,js

      call moist_processes_endts (is,js)
      call aerosol_endts

end subroutine physics_driver_up_endts


!#####################################################################

subroutine physics_driver_moist_init (ix,jx,kx,lx)


integer, intent(in) :: ix,jx, kx, lx 


      call moist_alloc_init (ix,jx,kx,lx)
      call moistproc_init (ix,jx,kx, num_uw_tracers, do_strat)

end subroutine physics_driver_moist_init 



!######################################################################

subroutine physics_driver_moist_end                  

      call moist_alloc_end
      call moistproc_end (do_strat)


end subroutine physics_driver_moist_end                  




!######################################################################
! <SUBROUTINE NAME="physics_driver_down">
!  <OVERVIEW>
!    physics_driver_down calculates "first pass" physics tendencies,
!    associated with radiation, damping and turbulence, and obtains
!    the vertical diffusion tendencies to be passed to the surface and
!    used in the semi-implicit vertical diffusion calculation.
!  </OVERVIEW>
!  <DESCRIPTION>
!    physics_driver_down calculates "first pass" physics tendencies,
!    associated with radiation, damping and turbulence, and obtains
!    the vertical diffusion tendencies to be passed to the surface and
!    used in the semi-implicit vertical diffusion calculation.    
!  </DESCRIPTION>
!  <TEMPLATE>
!   call physics_driver_down (is, ie, js, je,                       &
!                                Time_prev, Time, Time_next,           &
!                                lat, lon, area,                       &
!                                p_half, p_full, z_half, z_full,       &
!                                u, v, t, q, r, um, vm, tm, qm, rm,    &
!                                frac_land, rough_mom,                 &
!                                albedo,    t_surf_rad,                &
!                                u_star,    b_star, q_star,            &
!                                dtau_du,  dtau_dv,  tau_x,  tau_y,    &
!                                udt, vdt, tdt, qdt, rdt,              &
!                                flux_sw,  flux_lw,  coszen,  gust,    &
!                                Surf_diff, gavg_rrv,                  &
!                                mask, kbot
!  </TEMPLATE>
!  <IN NAME="Time_prev" TYPE="time_type">
!   previous time, for variable um, vm, tm, qm, rm
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   next time, used for diagnostics
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   array of model latitudes at model points [radians]
!  </IN>
!  <IN NAME="lon" TYPE="real">
!   array of model longitudes at model points [radians]
!  </IN>
!  <IN NAME="area" TYPE="real">
!   grid box area - current not used
!  </IN>
!  <IN NAME="p_half" TYPE="real">
!   pressure at model interface levels (offset from t,q,u,v,r)
!  </IN>
!  <IN NAME="p_full" TPYE="real">
!   pressure at full levels
!  </IN>
!  <IN NAME="z_half" TYPE="real">
!   height at model interface levels
!  </IN>
!  <IN NAME="z_full" TPYE="real">
!   height at full levels
!  </IN>
!  <IN NAME="u" TYPE="real">
!   zonal wind at current time step
!  </IN>
!  <IN NAME="v" TYPE="real">
!   meridional wind at current time step
!  </IN>
!  <IN NAME="t" TYPE="real">
!   temperature at current time step
!  </IN>
!  <IN NAME="q" TYPE="real">
!   specific humidity at current time step
!  </IN>
!  <IN NAME="r" TPYE="real">
!   multiple 3d tracer fields at current time step
!  </IN>
!  <IN NAME="um" TYPE="real">
!   zonal wind at previous time step
!  </IN>
!  <IN NAME="vm" TYPE="real">
!   meridional wind at previous time step
!  </IN>
!  <IN NAME="tm" TYPE="real">
!   temperature at previous time step
!  </IN>
!  <IN NAME="qm" TYPE="real">
!   specific humidity at previous time step
!  </IN>
!  <IN NAME="rm" TPYE="real">
!   multiple 3d tracer fields at previous time step
!  </IN>
!  <INOUT NAME="rd" TYPE="real">
!   multiple 3d diagnostic tracer fields 
!  </INOUT>
!  <IN NAME="frac_land" TYPE="real">
!   fraction of land coverage in a model grid point
!  </IN>
!  <IN NAME="rough_mom" TYPE="real">
!   boundary layer roughness
!  </IN>
!  <IN NAME="albedo" TYPE="real">
!   surface albedo
!  </IN>
!  <IN NAME="t_surf_rad" TYPE="real">
!   surface radiative temperature
!  </IN>
!  <IN NAME="u_star" TYPE="real">
!   boundary layer wind speed (frictional speed)
!  </IN>
!  <IN NAME="b_star" TYPE="real">
!   ???
!  </IN>
!  <IN NAME="q_star" TYPE="real">
!   boundary layer specific humidity
!  </IN>
!  <IN NAME="dtau_du" TYPE="real">
!   derivative of zonal surface stress w.r.t zonal wind speed
!  </IN>
!  <IN NAME="dtau_dv" TYPE="real">
!   derivative of meridional surface stress w.r.t meridional wind speed
!  </IN>
!  <INOUT NAME="tau_x" TYPE="real">
!   boundary layer meridional component of wind shear
!  </INOUT>
!  <INOUT NAME="tau_y" TYPE="real">
!   boundary layer zonal component of wind shear
!  </INOUT>
!  <INOUT NAME="udt" TYPE="real">
!   zonal wind tendency
!  </INOUT>
!  <INOUT NAME="vdt" TYPE="real">
!   meridional wind tendency
!  </INOUT>
!  <INOUT NAME="tdt" TYPE="real">
!   temperature tendency
!  </INOUT>
!  <INOUT NAME="qdt" TYPE="real">
!   moisture tracer tendencies
!  </INOUT>
!  <INOUT NAME="rdt" TYPE="real">
!   multiple tracer tendencies
!  </INOUT>
!  <OUT NAME="flux_sw" TYPE="real">
!   Shortwave flux from radiation package
!  </OUT>
!  <OUT NAME="flux_lw" TYPE="real">
!   Longwave flux from radiation package
!  </OUT>
!  <OUT NAME="coszen" TYPE="real">
!   cosine of zenith angle
!  </OUT>
!  <OUT NAME="gust" TYPE="real">
!  </OUT>
!  <INOUT NAME="Surf_diff" TYPE="surface_diffusion_type">
!   Surface diffusion 
!  </INOUT>
!  <IN NAME="gavg_rrv" TYPE="real">
!   array containing global average of tracer volume mixing ratio
!  </IN>
!!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
!
!  <IN NAME="diff_cum_mom" TYPE="real">
!   OPTIONAL: present when do_moist_processes=.false.
!    cu_mo_trans diffusion coefficients, which are passed through to vert_diff_down.
!    Should not be present when do_moist_processes=.true., since these
!    values are passed out from moist_processes.
!  </IN>
!
!  <IN NAME="moist_convect" TYPE="real">
!   OPTIONAL: present when do_moist_processes=.false.
!    Should not be present when do_moist_processes=.true., since these
!    values are passed out from moist_processes.
!  </IN>
! </SUBROUTINE>
!
subroutine physics_driver_down (is, ie, js, je,                       &
                                Time_prev, Time, Time_next,           &
                                lat, lon, area,                       &
                                p_half, p_full, z_half, z_full,       &
                                phalfgrey,                            &
                                u, v, t, q, r, um, vm, tm, qm, rm,    &
                                frac_land, rough_mom,                 &
                                albedo, albedo_vis_dir, albedo_nir_dir,&
                                albedo_vis_dif, albedo_nir_dif,       &
                                t_surf_rad,                           &
                                u_star,    b_star, q_star,            &
                                dtau_du, dtau_dv,  tau_x,  tau_y,     &
                                udt, vdt, tdt, qdt, rdt,              &
                                flux_sw,                              &
                                flux_sw_dir,                          &
                                flux_sw_dif,                          &
                                flux_sw_down_vis_dir,                 &
                                flux_sw_down_vis_dif,                 &
                                flux_sw_down_total_dir,               &
                                flux_sw_down_total_dif,               &
                                flux_sw_vis,                          &
                                flux_sw_vis_dir,                      &
                                flux_sw_vis_dif,                      &
                                flux_lw,  coszen,  gust,              &
                                Surf_diff, gavg_rrv,                  &
                                mask, kbot, diff_cum_mom,             &
                                moist_convect, diffm, difft  )

!---------------------------------------------------------------------
!    physics_driver_down calculates "first pass" physics tendencies,
!    associated with radiation, damping and turbulence, and obtains
!    the vertical diffusion tendencies to be passed to the surface and
!    used in the semi-implicit vertical diffusion calculation.
!-----------------------------------------------------------------------

integer,                 intent(in)             :: is, ie, js, je
type(time_type),         intent(in)             :: Time_prev, Time,  &
                                                   Time_next
real,dimension(:,:),     intent(in)             :: lat, lon, area
real,dimension(:,:,:),   intent(in)             :: p_half, p_full,   &
                                                   z_half, z_full,   &
                                                   u , v , t , q ,   &
                                                   um, vm, tm, qm,   &
                                                   phalfgrey
real,dimension(:,:,:,:), intent(inout)          :: r
real,dimension(:,:,:,:), intent(inout)          :: rm
real,dimension(:,:),     intent(in)             :: frac_land,   &
                                                   rough_mom, &
                                                   albedo, t_surf_rad, &
                                                   albedo_vis_dir, albedo_nir_dir, &
                                                   albedo_vis_dif, albedo_nir_dif, &
                                                   u_star, b_star,    &
                                                   q_star, dtau_du, dtau_dv
real,dimension(:,:),     intent(inout)          :: tau_x,  tau_y
real,dimension(:,:,:),   intent(inout)          :: udt,vdt,tdt,qdt
real,dimension(:,:,:,:), intent(inout)          :: rdt
real,dimension(:,:),     intent(out)            :: flux_sw,  &
                                                   flux_sw_dir, &
                                                   flux_sw_dif, flux_lw,  &
                                                   coszen,  gust, &
                                                   flux_sw_down_vis_dir, &
                                                   flux_sw_down_vis_dif, &
                                                   flux_sw_down_total_dir, &
                                                   flux_sw_down_total_dif, &
                                                   flux_sw_vis, &
                                                   flux_sw_vis_dir, & 
                                                   flux_sw_vis_dif 
type(surf_diff_type),    intent(inout)          :: Surf_diff
real,dimension(:),       intent(in)             :: gavg_rrv
real,dimension(:,:,:),   intent(in)   ,optional :: mask
integer, dimension(:,:), intent(in)   ,optional :: kbot
real,  dimension(:,:,:), intent(in)   ,optional :: diff_cum_mom
logical, dimension(:,:), intent(in)   ,optional :: moist_convect
real,  dimension(:,:,:), intent(out)  ,optional :: diffm, difft 

!-----------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                     the physics_window being integrated
!      Time_prev      previous time, for variables um,vm,tm,qm,rm 
!                     (time_type)
!      Time           current time, for variables u,v,t,q,r  (time_type)
!      Time_next      next time, used for diagnostics   (time_type)
!      lat            latitude of model points [ radians ]
!      lon            longitude of model points [ radians ]
!      area           grid box area - currently not used [ m**2 ]
!      p_half         pressure at half levels (offset from t,q,u,v,r)
!                     [ Pa ]
!      p_full         pressure at full levels [ Pa }
!      z_half         height at half levels [ m ]
!      z_full         height at full levels [ m ]
!      u              zonal wind at current time step [ m / s ]
!      v              meridional wind at current time step [ m / s ]
!      t              temperature at current time step [ deg k ]
!      q              specific humidity at current time step  kg / kg ]
!      r              multiple 3d tracer fields at current time step
!      um,vm          zonal and meridional wind at previous time step
!      tm,qm          temperature and specific humidity at previous 
!                     time step
!      rm             multiple 3d tracer fields at previous time step
!      frac_land
!      rough_mom
!      albedo
!      albedo_vis_dir surface visible direct albedo [ dimensionless ]
!      albedo_nir_dir surface nir direct albedo [ dimensionless ]
!      albedo_vis_dif surface visible diffuse albedo [ dimensionless ]
!      albedo_nir_dif surface nir diffuse albedo [ dimensionless ]
!      t_surf_rad
!      u_star
!      b_star
!      q_star
!      dtau_du
!      dtau_dv
!
!  intent(inout) variables:
!
!      tau_x
!      tau_y
!      udt            zonal wind tendency [ m / s**2 ]
!      vdt            meridional wind tendency [ m / s**2 ]
!      tdt            temperature tendency [ deg k / sec ]
!      qdt            specific humidity tendency 
!                     [  kg vapor / kg air / sec ]
!      rdt            multiple tracer tendencies [ unit / unit / sec ]
!      rd             multiple 3d diagnostic tracer fields 
!                     [ unit / unit / sec ]
!      Surf_diff      surface_diffusion_type variable
!
!   intent(out) variables:
!
!      flux_sw
!      flux_sw_dir            net shortwave surface flux (down-up) [ w / m^2 ]
!      flux_sw_dif            net shortwave surface flux (down-up) [ w / m^2 ]
!      flux_sw_down_vis_dir   downward shortwave surface flux in visible spectrum [ w / m^2 ]
!      flux_sw_down_vis_dif   downward shortwave surface flux in visible spectrum [ w / m^2 ]
!      flux_sw_down_total_dir total downward shortwave surface flux [ w / m^2 ]
!      flux_sw_down_total_dif total downward shortwave surface flux [ w / m^2 ]
!      flux_sw_vis            net downward shortwave surface flux in visible spectrum [ w / m^2 ]
!      flux_sw_vis_dir        net downward shortwave surface flux in visible spectrum [ w / m^2 ]
!      flux_sw_vis_dif        net downward shortwave surface flux in visible spectrum [ w / m^2 ]
!      flux_lw
!      coszen
!      gust
!
!   intent(in), optional variables:
!
!       mask        mask that designates which levels do not have data
!                   present (i.e., below ground); 0.=no data, 1.=data
!       kbot        lowest level which has data
!                   note:  both mask and kbot must be present together.
!
!-----------------------------------------------------------------------

!---------------------------------------------------------------------
!    local variables:

      real, dimension(size(u,1),size(u,2),size(u,3)) :: diff_t_vert, &
                                                        diff_m_vert
      real, dimension(size(u,1),size(u,2))           :: z_pbl 
      type(aerosol_type)                             :: Aerosol
      type(cld_specification_type)                   :: Cld_spec
      type(radiative_gases_type)                     :: Rad_gases
      type(atmos_input_type)                         :: Atmos_input
      type(surface_type)                             :: Surface
      type(rad_output_type)                          :: Radiation
      type(microphysics_type)                        :: Lsc_microphys, &
                                                        Meso_microphys,&
                                                        Cell_microphys,&
                                                    Shallow_microphys, &
                                                        Model_microphys
      integer          ::    sec, day, n
      real             ::    dt, alpha, dt2
      logical          ::    used

!---------------------------------------------------------------------
!   local variables:
!
!      diff_t_vert     vertical diffusion coefficient for temperature
!                      calculated on the current step
!      diff_m_vert     vertical diffusion coefficient for momentum   
!                      calculated on the current step
!      z_pbl           height of planetary boundary layer
!      Aerosol         aerosol_type variable describing the aerosol
!                      fields to be seen by the radiation package
!      Cld_spec        cld_specification_type variable describing the
!                      cloud field to be seen by the radiation package 
!      Rad_gases       radiative_gases_type variable describing the
!                      radiatively-active gas distribution to be seen 
!                      by the radiation package
!      Atmos_input     atmos_input_type variable describing the atmos-
!                      pheric state to be seen by the radiation package
!      Surface         surface_type variable describing the surface
!                      characteristics to be seen by the radiation 
!                      package
!      Radiation       rad_output_type variable containing the variables
!                      output from the radiation package, for passage
!                      to other modules
!      Rad_time        time at which the radiation calculation is to
!                      apply [ time_type ]
!      Lsc_microphys   microphysics_type variable containing the micro-
!                      physical characteristics of the large-scale
!                      clouds to be seen by the radiation package 
!      Meso_microphys  microphysics_type variable containing the micro-
!                      physical characteristics of the mesoscale
!                      clouds to be seen by the radiation package 
!      Cell_microphys  microphysics_type variable containing the micro-
!                      physical characteristics of the cell-scale
!                      clouds to be seen by the radiation package 
!      Shallow_microphys  
!                      microphysics_type variable containing the micro-
!                      physical characteristics of the cell-scale
!                      clouds to be seen by the radiation package
!      sec, day        second and day components of the time_type 
!                      variable
!      dt              model physics time step [ seconds ]
!      alpha           ratio of physics time step to diffusion-smoothing
!                      time scale
!      need_aerosols   need to obtain aerosol data on this time step
!                      to input to the radiation package ?
!      need_clouds     need to obtain cloud data on this time step
!                      to input to the radiation package ?
!      need_gases      need to obtain radiative gas data on this time 
!                      step to input to the radiation package ?
!      need_basic      need to obtain atmospheric state variables on
!                      this time step to input to the radiation package?
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    verify that the module is initialized.
!---------------------------------------------------------------------
      if ( .not. module_is_initialized) then
        call error_mesg ('physics_driver_mod',  &
                         'module has not been initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    if COSP is activated, save the surface (skin) temperature for
!    its use.
!---------------------------------------------------------------------
      if (do_cosp) then
        tsurf_save(is:ie,js:je) = t_surf_rad
      endif

!---------------------------------------------------------------------
!    check the size of the input arguments. this is only done on the
!    first call to physics_driver_down.
!---------------------------------------------------------------------
      if (do_check_args) call check_args  &
                   (lat, lon, area, p_half, p_full, z_half, z_full, &
                    u, v, t, q, r, um, vm, tm, qm, rm,              &
                    udt, vdt, tdt, qdt, rdt)

!---------------------------------------------------------------------
!    compute the physics time step (from tau-1 to tau+1).
!---------------------------------------------------------------------
      call get_time (Time_next - Time_prev, sec, day)
      dt = real(sec + day*86400)

     if (do_radiation) then
!----------------------------------------------------------------------
!    prepare to calculate radiative forcings. obtain the valid time
!    at which the radiation calculation is to apply, the needed atmos-
!    pheric fields, and any needed inputs from other physics modules.
!---------------------------------------------------------------------
      call mpp_clock_begin ( radiation_clock )
 
!---------------------------------------------------------------------
!    call define_surface to define a surface_type variable containing
!    the surface albedoes and land fractions for each grid box. this
!    variable must be provided on all timesteps for use in generating
!    netcdf output.
!---------------------------------------------------------------------
      call define_surface (is, ie, js, je, albedo, albedo_vis_dir,  &
                           albedo_nir_dir, albedo_vis_dif, &
                           albedo_nir_dif, frac_land, Surface)

!---------------------------------------------------------------------
!    if the basic atmospheric input variables to the radiation package
!    are needed, pass the model pressure (p_full, p_half), temperature 
!    (t, t_surf_rad) and specific humidity (q) to subroutine
!    define_atmos_input_fields, which will put these fields and some
!    additional auxiliary fields into the form desired by the radiation
!    package and store them as components of the derived-type variable 
!    Atmos_input.
!---------------------------------------------------------------------
      if (need_basic) then
        call define_atmos_input_fields     &
                              (is, ie, js, je, p_full, p_half, t, q,  &
                               t_surf_rad, r, gavg_rrv, Atmos_input, kbot=kbot)
      endif

!---------------------------------------------------------------------
!    if the aerosol fields are needed as input to the radiation_package,
!    call aerosol_driver to access the aerosol data and place it into 
!    an aerosol_type derived-type variable Aerosol.
!---------------------------------------------------------------------
      if (need_aerosols) then
        call aerosol_driver (is, js, Rad_time, r, &
                             Atmos_input%phalf, Atmos_input%pflux, &
                             Aerosol)
      endif
 
!---------------------------------------------------------------------
!    if the cloud fields are needed, call cloud_spec to retrieve bulk
!    cloud data and place it into a cld_specification_type derived-type 
!    variable Cld_spec and retrieve microphysical data which is returned
!    in microphysics_type variables Lsc_microphys, Meso_microphys and 
!    Cell_microphys and Shallow_microphys, when applicable.
!---------------------------------------------------------------------
      if (need_clouds) then
       if (use_cloud_tracers_in_radiation) then
       if (doing_donner .and. doing_uw_conv) then
           call cloud_spec (is, ie, js, je, lat,              &
                            z_half, z_full, Rad_time,   &
                            Atmos_input, Surface, Cld_spec,   &
                            Lsc_microphys, Meso_microphys,    &
                            Cell_microphys, Shallow_microphys, &
!             lsc_area_in = lsc_cloud_area,   &
!             lsc_liquid_in=lsc_liquid, lsc_ice_in=lsc_ice,  &
!             lsc_droplet_number_in=lsc_droplet_number,&
                           r=r(:,:,:,1:ntp), &
             shallow_cloud_area = shallow_cloud_area(is:ie,js:je,:), &
             shallow_liquid = shallow_liquid(is:ie,js:je,:), &
             shallow_ice = shallow_ice(is:ie,js:je,:), &
             shallow_droplet_number = shallow_droplet_number(is:ie,js:je,:), &
             cell_cld_frac= cell_cld_frac(is:ie,js:je,:),  &
             cell_liq_amt=cell_liq_amt(is:ie,js:je,:), &
             cell_liq_size=cell_liq_size(is:ie,js:je,:), &
             cell_ice_amt= cell_ice_amt(is:ie,js:je,:),   &
             cell_ice_size= cell_ice_size(is:ie,js:je,:), &
             cell_droplet_number= cell_droplet_number(is:ie,js:je,:), &
             meso_cld_frac= meso_cld_frac(is:ie,js:je,:),   &
             meso_liq_amt=meso_liq_amt(is:ie,js:je,:), &
             meso_liq_size=meso_liq_size(is:ie,js:je,:), &
             meso_ice_amt= meso_ice_amt(is:ie,js:je,:),  &
             meso_ice_size= meso_ice_size(is:ie,js:je,:), &
             meso_droplet_number= meso_droplet_number(is:ie,js:je,:), &
             nsum_out=nsum_out(is:ie,js:je)  )
      else  if (doing_donner) then
          call cloud_spec (is, ie, js, je, lat,              &
                           z_half, z_full, Rad_time,   &
                           Atmos_input, Surface, Cld_spec,   &
                           Lsc_microphys, Meso_microphys,    &
                           Cell_microphys, Shallow_microphys, &
!             lsc_area_in = lsc_cloud_area,   &
!             lsc_liquid_in=lsc_liquid, lsc_ice_in=lsc_ice,  &
!              lsc_droplet_number_in=lsc_droplet_number,&
                           r=r(:,:,:,1:ntp), &
             cell_cld_frac= cell_cld_frac(is:ie,js:je,:), &
             cell_liq_amt=cell_liq_amt(is:ie,js:je,:), &
             cell_liq_size=cell_liq_size(is:ie,js:je,:), &
             cell_ice_amt= cell_ice_amt(is:ie,js:je,:),   &
             cell_ice_size= cell_ice_size(is:ie,js:je,:), &
             cell_droplet_number= cell_droplet_number(is:ie,js:je,:), &
             meso_cld_frac= meso_cld_frac(is:ie,js:je,:),   &
             meso_liq_amt=meso_liq_amt(is:ie,js:je,:), &
             meso_liq_size=meso_liq_size(is:ie,js:je,:), &
             meso_ice_amt= meso_ice_amt(is:ie,js:je,:),  &
             meso_ice_size= meso_ice_size(is:ie,js:je,:), &
             meso_droplet_number= meso_droplet_number(is:ie,js:je,:), &
             nsum_out=nsum_out(is:ie,js:je)  )
      else if (doing_uw_conv) then
          call cloud_spec (is, ie, js, je, lat,              &
                           z_half, z_full, Rad_time,   &
                           Atmos_input, Surface, Cld_spec,   &
                           Lsc_microphys, Meso_microphys,    &
                           Cell_microphys, Shallow_microphys, &
!             lsc_area_in = lsc_cloud_area,   &
!             lsc_liquid_in=lsc_liquid, lsc_ice_in=lsc_ice,  &
!              lsc_droplet_number_in=lsc_droplet_number,&
                           r=r(:,:,:,1:ntp), &
             shallow_cloud_area = shallow_cloud_area(is:ie,js:je,:), &
             shallow_liquid = shallow_liquid(is:ie,js:je,:), &
             shallow_ice = shallow_ice(is:ie,js:je,:), &
             shallow_droplet_number = shallow_droplet_number(is:ie,js:je,:))
      else
          call cloud_spec (is, ie, js, je, lat,              &
                           z_half, z_full, Rad_time,   &
                           Atmos_input, Surface, Cld_spec,   &
                           Lsc_microphys, Meso_microphys,    &
                           Cell_microphys, Shallow_microphys, &
!             lsc_area_in = lsc_cloud_area,   &
!             lsc_liquid_in=lsc_liquid, lsc_ice_in=lsc_ice,  &
!              lsc_droplet_number_in=lsc_droplet_number,&
                           r=r(:,:,:,1:ntp))
      endif ! (doing_donner)
     else ! (use_cloud_tracers_in_radiation)
       if (doing_donner .and. doing_uw_conv) then
           call cloud_spec (is, ie, js, je, lat,              &
                            z_half, z_full, Rad_time,   &
                            Atmos_input, Surface, Cld_spec,   &
                            Lsc_microphys, Meso_microphys,    &
                            Cell_microphys, Shallow_microphys, &
              lsc_area_in = lsc_cloud_area(is:ie,js:je,:),   &
              lsc_liquid_in=lsc_liquid(is:ie,js:je,:),  &
              lsc_ice_in=lsc_ice(is:ie,js:je,:),  &
               lsc_droplet_number_in=lsc_droplet_number(is:ie,js:je,:),&
                            r=r(:,:,:,1:ntp), &
             shallow_cloud_area = shallow_cloud_area(is:ie,js:je,:), &
             shallow_liquid = shallow_liquid(is:ie,js:je,:), &
             shallow_ice = shallow_ice(is:ie,js:je,:), &
             shallow_droplet_number = shallow_droplet_number(is:ie,js:je,:), &
             cell_cld_frac= cell_cld_frac(is:ie,js:je,:),  &
             cell_liq_amt=cell_liq_amt(is:ie,js:je,:), &
             cell_liq_size=cell_liq_size(is:ie,js:je,:), &
             cell_ice_amt= cell_ice_amt(is:ie,js:je,:),   &
             cell_ice_size= cell_ice_size(is:ie,js:je,:), &
             cell_droplet_number= cell_droplet_number(is:ie,js:je,:), &
             meso_cld_frac= meso_cld_frac(is:ie,js:je,:),   &
             meso_liq_amt=meso_liq_amt(is:ie,js:je,:), &
             meso_liq_size=meso_liq_size(is:ie,js:je,:), &
             meso_ice_amt= meso_ice_amt(is:ie,js:je,:),  &
             meso_ice_size= meso_ice_size(is:ie,js:je,:), &
             meso_droplet_number= meso_droplet_number(is:ie,js:je,:), &
             nsum_out=nsum_out(is:ie,js:je)  )
      else  if (doing_donner) then
          call cloud_spec (is, ie, js, je, lat,              &
                           z_half, z_full, Rad_time,   &
                           Atmos_input, Surface, Cld_spec,   &
                           Lsc_microphys, Meso_microphys,    &
                           Cell_microphys, Shallow_microphys, &
                       lsc_area_in = lsc_cloud_area(is:ie,js:je,:),   &
                lsc_liquid_in=lsc_liquid(is:ie,js:je,:), &
                lsc_ice_in=lsc_ice(is:ie,js:je,:),  &
               lsc_droplet_number_in=lsc_droplet_number(is:ie,js:je,:),&
                           r=r(:,:,:,1:ntp), &
             cell_cld_frac= cell_cld_frac(is:ie,js:je,:), &
             cell_liq_amt=cell_liq_amt(is:ie,js:je,:), &
             cell_liq_size=cell_liq_size(is:ie,js:je,:), &
             cell_ice_amt= cell_ice_amt(is:ie,js:je,:),   &
             cell_ice_size= cell_ice_size(is:ie,js:je,:), &
             cell_droplet_number= cell_droplet_number(is:ie,js:je,:), &
             meso_cld_frac= meso_cld_frac(is:ie,js:je,:),   &
             meso_liq_amt=meso_liq_amt(is:ie,js:je,:), &
             meso_liq_size=meso_liq_size(is:ie,js:je,:), &
             meso_ice_amt= meso_ice_amt(is:ie,js:je,:),  &
             meso_ice_size= meso_ice_size(is:ie,js:je,:), &
             meso_droplet_number= meso_droplet_number(is:ie,js:je,:), &
             nsum_out=nsum_out(is:ie,js:je)  )
      else if (doing_uw_conv) then
          call cloud_spec (is, ie, js, je, lat,              &
                           z_half, z_full, Rad_time,   &
                           Atmos_input, Surface, Cld_spec,   &
                           Lsc_microphys, Meso_microphys,    &
                           Cell_microphys, Shallow_microphys, &
                lsc_area_in = lsc_cloud_area(is:ie,js:je,:),   &
              lsc_liquid_in=lsc_liquid(is:ie,js:je,:),  &
              lsc_ice_in=lsc_ice(is:ie,js:je,:),  &
              lsc_droplet_number_in=lsc_droplet_number(is:ie,js:je,:),&
                           r=r(:,:,:,1:ntp), &
             shallow_cloud_area = shallow_cloud_area(is:ie,js:je,:), &
             shallow_liquid = shallow_liquid(is:ie,js:je,:), &
             shallow_ice = shallow_ice(is:ie,js:je,:), &
             shallow_droplet_number = shallow_droplet_number(is:ie,js:je,:))
      else
          call cloud_spec (is, ie, js, je, lat,              &
                           z_half, z_full, Rad_time,   &
                           Atmos_input, Surface, Cld_spec,   &
                           Lsc_microphys, Meso_microphys,    &
                           Cell_microphys, Shallow_microphys, &
                       lsc_area_in = lsc_cloud_area(is:ie,js:je,:),   &
                     lsc_liquid_in=lsc_liquid(is:ie,js:je,:),  &
                     lsc_ice_in=lsc_ice(is:ie,js:je,:),  &
              lsc_droplet_number_in=lsc_droplet_number(is:ie,js:je,:),&
                           r=r(:,:,:,1:ntp))
      endif ! (doing_donner)
      endif ! (use_cloud_tracers_in_radiation)
      endif ! (need_clouds)

!---------------------------------------------------------------------
!    if the radiative gases are needed, call define_radiative_gases to 
!    obtain the values to be used for the radiatively-active gases and 
!    place them in radiative_gases_type derived-type variable Rad_gases.
!---------------------------------------------------------------------
      if (need_gases) then

!--------------------------------------------------------------------
!    fill the contents of the radiative_gases_type variable which
!    will be passed to the radiation package. 
!---------------------------------------------------------------------
        Rad_gases%ch4_tf_offset = Rad_gases_tv%ch4_tf_offset
        Rad_gases%n2o_tf_offset = Rad_gases_tv%n2o_tf_offset
        Rad_gases%co2_tf_offset = Rad_gases_tv%co2_tf_offset
        Rad_gases%ch4_for_next_tf_calc = Rad_gases_tv%ch4_for_next_tf_calc
        Rad_gases%n2o_for_next_tf_calc = Rad_gases_tv%n2o_for_next_tf_calc
        Rad_gases%co2_for_next_tf_calc = Rad_gases_tv%co2_for_next_tf_calc
        Rad_gases%rrvch4  = Rad_gases_tv%rrvch4
        Rad_gases%rrvn2o  = Rad_gases_tv%rrvn2o
        Rad_gases%rrvf11  = Rad_gases_tv%rrvf11
        Rad_gases%rrvf12  = Rad_gases_tv%rrvf12
        Rad_gases%rrvf113 = Rad_gases_tv%rrvf113
        Rad_gases%rrvf22  = Rad_gases_tv%rrvf22
        Rad_gases%rrvco2  = Rad_gases_tv%rrvco2
        Rad_gases%time_varying_co2  = Rad_gases_tv%time_varying_co2
        Rad_gases%time_varying_ch4  = Rad_gases_tv%time_varying_ch4
        Rad_gases%time_varying_n2o  = Rad_gases_tv%time_varying_n2o
        Rad_gases%time_varying_f11  = Rad_gases_tv%time_varying_f11
        Rad_gases%time_varying_f12  = Rad_gases_tv%time_varying_f12
        Rad_gases%time_varying_f113 = Rad_gases_tv%time_varying_f113
        Rad_gases%time_varying_f22  = Rad_gases_tv%time_varying_f22
        Rad_gases%Co2_time = Rad_gases_tv%Co2_time
        Rad_gases%Ch4_time = Rad_gases_tv%Ch4_time
        Rad_gases%N2o_time = Rad_gases_tv%N2o_time
        Rad_gases%use_model_supplied_co2 = Rad_gases_tv%use_model_supplied_co2
  
        Rad_gases%co2_for_last_tf_calc = Rad_gases_tv%co2_for_last_tf_calc
        Rad_gases%ch4_for_last_tf_calc = Rad_gases_tv%ch4_for_last_tf_calc
        Rad_gases%n2o_for_last_tf_calc = Rad_gases_tv%n2o_for_last_tf_calc

        call define_radiative_gases (is, ie, js, je, Rad_time, lat, &
                                     Atmos_input, r, Time_next, Rad_gases)
      endif

!---------------------------------------------------------------------
!    allocate the components of a rad_output_type variable which will
!    be used to return the output from radiation_driver_mod that is
!    needed by other modules.
!---------------------------------------------------------------------
      allocate (Radiation%tdt_rad               (size(q,1), size(q,2),size(q,3),1))
      allocate (Radiation%ufsw                  (size(q,1), size(q,2),size(q,3)+1,1))
      allocate (Radiation%dfsw                  (size(q,1), size(q,2),size(q,3)+1,1))
      allocate (Radiation%ufsw_clr              (size(q,1), size(q,2),size(q,3)+1,1))
      allocate (Radiation%dfsw_clr              (size(q,1), size(q,2),size(q,3)+1,1))
      allocate (Radiation%flux_sw_surf          (size(q,1), size(q,2),1 ))
      allocate (Radiation%flux_sw_surf_dir      (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_surf_dif      (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_down_vis_dir  (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_down_vis_dif  (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_down_total_dir(size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_down_total_dif(size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_vis           (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_vis_dir       (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_sw_vis_dif       (size(q,1), size(q,2),1          ))
      allocate (Radiation%flux_lw_surf          (size(q,1), size(q,2)          ))
      allocate (Radiation%coszen_angle          (size(q,1), size(q,2)          ))
      allocate (Radiation%tdtlw                 (size(q,1), size(q,2),size(q,3)))
      allocate (Radiation%flxnet                (size(q,1), size(q,2),size(q,3)+1))
      allocate (Radiation%flxnetcf              (size(q,1), size(q,2),size(q,3)+1))

!--------------------------------------------------------------------
!    call  radiation_driver to perform the radiation calculation.
!--------------------------------------------------------------------
      call radiation_driver (is, ie, js, je, Time, Time_next, lat,  &
                             lon, Surface, Atmos_input, Aerosol, r, &
                             Cld_spec, Rad_gases, Lsc_microphys, &
                             Meso_microphys, Cell_microphys,&
                             Shallow_microphys, Model_microphys, &
                             Radiation=Radiation, mask=mask, kbot=kbot)

!---------------------------------------------------------------------
!    if COSP is activated and this is a step upon which the cosp
!    simulator is to be called, verify that stochastic clouds are
!    also activated. if they are not, then exit, since COSP should only
!    be requested when stochastic clouds are active.
!---------------------------------------------------------------------
      if (do_cosp .or. do_modis_yim) then
        if (step_to_call_cosp) then
 
!---------------------------------------------------------------------
!    call return_cosp_inputs to retrieve the radiation inputs needed 
!    by COSP.
!---------------------------------------------------------------------
          call return_cosp_inputs        &
                (is, ie, js, je, donner_meso_is_largescale,  &
                 Time_next, Atmos_input, stoch_cloud_type, &
                 stoch_conc_drop, stoch_conc_ice, stoch_size_drop, &
                 stoch_size_ice, tau_stoch, lwem_stoch, &
                 Model_microphys, &
                 do_cosp, do_modis_yim, Lsc_microphys)
          mr_ozone(is:ie,js:je,:) = Rad_gases%qo3(:,:,:)
          where (Radiation%flux_sw_surf(:,:,1) > 0.0)
             daytime(is:ie,js:je) = 1.0
          elsewhere
             daytime(is:ie,js:je) = 0.0
          endwhere
!         daytime(is:ie,js:je) = 1.0
        endif ! (step_to_call_cosp)
      endif ! (do_cosp)

!-------------------------------------------------------------------
!    process the variables returned from radiation_driver_mod. the 
!    radiative heating rate is added to the accumulated physics heating
!    rate (tdt). net surface lw and sw fluxes and the cosine of the 
!    zenith angle are placed in locations where they can be exported
!    for use in other component models. the lw heating rate is stored
!    in a module variable for potential use in other physics modules.
!    the radiative heating rate is also added to a variable which is
!    accumulating the radiative and turbulent heating rates, and which
!    is needed by strat_cloud_mod.
!-------------------------------------------------------------------
      tdt     = tdt + Radiation%tdt_rad(:,:,:,1)
      flux_sw = Radiation%flux_sw_surf(:,:,1)
      flux_sw_dir            = Radiation%flux_sw_surf_dir(:,:,1)
      flux_sw_dif            = Radiation%flux_sw_surf_dif(:,:,1)
      flux_sw_down_vis_dir   = Radiation%flux_sw_down_vis_dir(:,:,1)
      flux_sw_down_vis_dif   = Radiation%flux_sw_down_vis_dif(:,:,1)
      flux_sw_down_total_dir = Radiation%flux_sw_down_total_dir(:,:,1)
      flux_sw_down_total_dif = Radiation%flux_sw_down_total_dif(:,:,1)
      flux_sw_vis            = Radiation%flux_sw_vis(:,:,1)
      flux_sw_vis_dir        = Radiation%flux_sw_vis_dir(:,:,1)
      flux_sw_vis_dif        = Radiation%flux_sw_vis_dif(:,:,1)
      flux_lw = Radiation%flux_lw_surf
      coszen  = Radiation%coszen_angle
      lw_tendency(is:ie,js:je,:) = Radiation%tdtlw(:,:,:)
      radturbten (is:ie,js:je,:) = radturbten(is:ie,js:je,:) + &
                                   Radiation%tdt_rad(:,:,:,1)

!--------------------------------------------------------------------
!    deallocate the arrays used to return the radiation_driver_mod 
!    output.
!--------------------------------------------------------------------
      deallocate ( Radiation%tdt_rad      )
      deallocate ( Radiation%ufsw         )
      deallocate ( Radiation%dfsw         )
      deallocate ( Radiation%ufsw_clr     )
      deallocate ( Radiation%dfsw_clr     )
      deallocate ( Radiation%flux_sw_surf )
      deallocate ( Radiation%flux_sw_surf_dir )
      deallocate ( Radiation%flux_sw_surf_dif )
      deallocate ( Radiation%flux_sw_down_vis_dir )
      deallocate ( Radiation%flux_sw_down_vis_dif )
      deallocate ( Radiation%flux_sw_down_total_dir )
      deallocate ( Radiation%flux_sw_down_total_dif )
      deallocate ( Radiation%flux_sw_vis )
      deallocate ( Radiation%flux_sw_vis_dir )
      deallocate ( Radiation%flux_sw_vis_dif )
      deallocate ( Radiation%flux_lw_surf )
      deallocate ( Radiation%coszen_angle )
      deallocate ( Radiation%tdtlw        )
      deallocate ( Radiation%flxnet       )
      deallocate ( Radiation%flxnetcf     )
 
!---------------------------------------------------------------------
!    call routines to deallocate the components of the derived type 
!    arrays input to radiation_driver.
!---------------------------------------------------------------------
      if (need_gases) then
        call radiative_gases_dealloc (Rad_gases)
      endif
      if (need_clouds) then
        call cloud_spec_dealloc (Cld_spec, Lsc_microphys,   &
                                 Meso_microphys, Cell_microphys, &
                                 Shallow_microphys)
      endif
      if (need_aerosols) then
        call aerosol_dealloc (Aerosol)
      endif
      if (need_basic) then
        call atmos_input_dealloc (Atmos_input)
        call microphys_dealloc (Model_microphys)
      endif
      call surface_dealloc (Surface)
      call mpp_clock_end ( radiation_clock )
      else
        flux_sw = 0.0
        flux_sw_dir = 0.0
        flux_sw_dif = 0.0
        flux_sw_down_vis_dir = 0.0
        flux_sw_down_vis_dif = 0.0
        flux_sw_down_total_dir = 0.0
        flux_sw_down_total_dif = 0.0
        flux_sw_vis = 0.0
        flux_sw_vis_dir = 0.0
        flux_sw_vis_dif = 0.0
        flux_lw = 0.0
        coszen  = 0.0
        lw_tendency(is:ie,js:je,:) = 0.0
      endif ! do_radiation

      if(do_grey_radiation) then !rif:(09/10/09) 
        call grey_radiation(is, js, Time, Time_next, lat, lon, phalfgrey, albedo, t_surf_rad, t, tdt, flux_sw, flux_lw)
        coszen = 1.0
        flux_sw_dir     = R1*flux_sw
        flux_sw_dif     = R2*flux_sw
        flux_sw_vis_dir = R3*flux_sw
        flux_sw_vis_dif = R4*flux_sw
      endif

#ifdef SCM
! Option to add SCM radiative tendencies from forcing to lw_tendency
! and radturbten

      if (use_scm_rad) then
        call add_scm_tdtlw( lw_tendency(is:ie,js:je,:) )
        call add_scm_tdtlw( radturbten (is:ie,js:je,:) )
        call add_scm_tdtsw( radturbten (is:ie,js:je,:) )
      endif

#endif

!----------------------------------------------------------------------
!    call damping_driver to calculate the various model dampings that
!    are desired. 
!----------------------------------------------------------------------
      z_pbl(:,:) = pbltop(is:ie,js:je) 
      call mpp_clock_begin ( damping_clock )
      call damping_driver (is, js, lat, Time_next, dt,           &
                           p_full, p_half, z_full, z_half,          &
                           um, vm, tm, qm, rm(:,:,:,1:ntp), &
                           udt, vdt, tdt, qdt, rdt,&
                           z_pbl , mask=mask, kbot=kbot)
     call mpp_clock_end ( damping_clock )

!---------------------------------------------------------------------
!    If moist_processes is not called in physics_driver_down then values
!    of convect must be passed in via the optional argument "moist_convect".
!---------------------------------------------------------------------
      if(.not.do_moist_processes) then
        if(present(moist_convect)) then
          convect(is:ie,js:je) = moist_convect
        else
          call error_mesg('physics_driver_down', &
          'moist_convect be present when do_moist_processes=.false.',FATAL) 
        endif
      endif

!---------------------------------------------------------------------
!    call vert_turb_driver to calculate diffusion coefficients. save
!    the planetary boundary layer height on return.
!---------------------------------------------------------------------

      if (id_tdt_phys_turb > 0) then
        used = send_data ( id_tdt_phys_turb, -2.0*tdt(:,:,:), &
                           Time_next, is, js, 1, rmask=mask )
      endif

      do n=1,nt
        if (id_tracer_phys_turb(n) > 0) then
          used = send_data ( id_tracer_phys_turb(n), -2.0*rdt(:,:,:,n), &
                             Time_next, is, js, 1, rmask=mask )
        endif
      end do

      call mpp_clock_begin ( turb_clock )
      call vert_turb_driver (is, js, Time, Time_next, dt,            &
                             lw_tendency(is:ie,js:je,:), frac_land,  &
                             p_half, p_full, z_half, z_full, u_star, &
                             b_star, q_star, rough_mom, lat,         &
                             convect(is:ie,js:je),                   &
                             u, v, t, q, r(:,:,:,1:ntp), um, vm,     &
                             tm, qm, rm(:,:,:,1:ntp),                &
                             udt, vdt, tdt, qdt, rdt,                &
                             diff_t_vert, diff_m_vert, gust, z_pbl,  &
                             mask=mask, kbot=kbot             )
     call mpp_clock_end ( turb_clock )
     pbltop(is:ie,js:je) = z_pbl(:,:)

      if (id_tdt_phys_turb > 0) then
        used = send_data ( id_tdt_phys_turb, +2.0*tdt(:,:,:), &
                           Time_next, is, js, 1, rmask=mask )
      endif

      do n=1,nt
        if (id_tracer_phys_turb(n) > 0) then
          used = send_data ( id_tracer_phys_turb(n), +2.0*rdt(:,:,:,n), &
                             Time_next, is, js, 1, rmask=mask )
        endif
      end do

!-----------------------------------------------------------------------
!    process any tracer fields.
!-----------------------------------------------------------------------
      call mpp_clock_begin ( tracer_clock )
      call atmos_tracer_driver (is, ie, js, je, Time, lon, lat,  &
                                area, z_pbl, rough_mom,         &
                                frac_land, p_half, p_full,  &
                                u, v, t, q, r, &
                                rm, rdt, dt, &
                                u_star, b_star, q_star, &
                                z_half, z_full, t_surf_rad, albedo, &
                                Time_next, &
                                flux_sw_down_vis_dir, flux_sw_down_vis_dif, &  
                                mask, kbot)
      call mpp_clock_end ( tracer_clock )

!-----------------------------------------------------------------------
!    If moist_processes is not called in physics_driver_down then values
!    of the cu_mo_trans diffusion coefficients must be passed in via
!    the optional argument "diff_cum_mom".
!-----------------------------------------------------------------------
      if(.not.do_moist_processes) then
        if(present(diff_cum_mom)) then
          diff_cu_mo(is:ie,js:je,:) = diff_cum_mom          
        else
          call error_mesg('physics_driver_down', &
          'diff_cum_mom must be present when do_moist_processes=.false.',FATAL)
        endif
      endif

!-----------------------------------------------------------------------
!    optionally use an implicit calculation of the vertical diffusion 
!    coefficients.
!
!    the vertical diffusion coefficients are solved using an implicit
!    solution to the following equation:
!
!    dK/dt   = - ( K - K_cur) / tau_diff
!
!    where K         = diffusion coefficient
!          K_cur     = diffusion coefficient diagnosed from current 
!                      time steps' state
!          tau_diff  = time scale for adjustment
!
!    in the code below alpha = dt / tau_diff
!---------------------------------------------------------------------
      if (diffusion_smooth) then
        call get_time (Time_next - Time, sec, day)
        dt2 = real(sec + day*86400)
        alpha = dt2/tau_diff
        diff_m(is:ie,js:je,:) = (diff_m(is:ie,js:je,:) +       &
                                 alpha*(diff_m_vert(:,:,:) +  &
                                 diff_cu_mo(is:ie,js:je,:)) )/&
                                 (1. + alpha)
        where (diff_m(is:ie,js:je,:) < diff_min)
          diff_m(is:ie,js:je,:) = 0.0
        end where
        diff_t(is:ie,js:je,:) = (diff_t(is:ie,js:je,:) +      &
                                 alpha*diff_t_vert(:,:,:) )/  &
                                 (1. + alpha)
        where (diff_t(is:ie,js:je,:) < diff_min)
          diff_t(is:ie,js:je,:) = 0.0
        end where
      else
        diff_t(is:ie,js:je,:) = diff_t_vert
        diff_m(is:ie,js:je,:) = diff_m_vert + diff_cu_mo(is:ie, js:je,:)
      end if

!-----------------------------------------------------------------------
!    call vert_diff_driver_down to calculate the first pass atmos-
!    pheric vertical diffusion.
!-----------------------------------------------------------------------

      if (id_tdt_phys_vdif_dn > 0) then
        used = send_data ( id_tdt_phys_vdif_dn, -2.0*tdt(:,:,:), &
                           Time_next, is, js, 1, rmask=mask )
      endif

      do n=1,nt
        if (id_tracer_phys_vdif_dn(n) > 0) then
          used = send_data ( id_tracer_phys_vdif_dn(n), -2.0*rdt(:,:,:,n), &
                             Time_next, is, js, 1, rmask=mask )
        endif
      end do

      call mpp_clock_begin ( diff_down_clock )
      radturbten(is:ie,js:je,:) = radturbten(is:ie,js:je,:) - tdt(:,:,:)
      call vert_diff_driver_down (is, js, Time_next, dt, p_half,   &
                                  p_full, z_full,   &
                                  diff_m(is:ie,js:je,:),         &
                                  diff_t(is:ie,js:je,:),         &
                                  um ,vm ,tm ,qm ,rm(:,:,:,1:ntp), &
                                  dtau_du, dtau_dv, tau_x, tau_y,  &
                                  udt, vdt, tdt, qdt, rdt,       &
                                  Surf_diff,                     &
                                  mask=mask, kbot=kbot           )

      if (id_tdt_phys_vdif_dn > 0) then
        used = send_data ( id_tdt_phys_vdif_dn, +2.0*tdt(:,:,:), &
                           Time_next, is, js, 1, rmask=mask )
      endif

      do n=1,nt
        if (id_tracer_phys_vdif_dn(n) > 0) then
          used = send_data ( id_tracer_phys_vdif_dn(n), +2.0*rdt(:,:,:,n), &
                             Time_next, is, js, 1, rmask=mask )
        endif
      end do

!---------------------------------------------------------------------
!    if desired, return diff_m and diff_t to calling routine.
!-----------------------------------------------------------------------
      if (present(difft)) then
        difft = diff_t(is:ie,js:je,:)
      endif
      if (present(diffm)) then
        diffm = diff_m(is:ie,js:je,:)
      endif

     call mpp_clock_end ( diff_down_clock )

 end subroutine physics_driver_down



!#######################################################################
! <SUBROUTINE NAME="physics_driver_up">
!  <OVERVIEW>
!    physics_driver_up completes the calculation of vertical diffusion 
!    and also handles moist physical processes.
!  </OVERVIEW>
!  <DESCRIPTION>
!    physics_driver_up completes the calculation of vertical diffusion 
!    and also handles moist physical processes.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call physics_driver_up (is, ie, js, je,                    &
!                               Time_prev, Time, Time_next,        &
!                               lat, lon, area,                    &
!                               p_half, p_full, z_half, z_full,    & 
!                               omega,                             &
!                               u, v, t, q, r, um, vm, tm, qm, rm, &
!                               frac_land,                         &
!                               udt, vdt, tdt, qdt, rdt,           &
!                               Surf_diff,                         &
!                               lprec,   fprec, gust,              &
!                               mask, kbot    )
!  </TEMPLATE>
!  <IN NAME="Time_prev" TYPE="time_type">
!   previous time, for variable um, vm, tm, qm, rm
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   next time, used for diagnostics
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   array of model latitudes at model points [radians]
!  </IN>
!  <IN NAME="lon" TYPE="real">
!   array of model longitudes at model points [radians]
!  </IN>
!  <IN NAME="area" TYPE="real">
!   grid box area - current not used
!  </IN>
!  <IN NAME="p_half" TYPE="real">
!   pressure at model interface levels (offset from t,q,u,v,r)
!  </IN>
!  <IN NAME="p_full" TPYE="real">
!   pressure at full levels
!  </IN>
!  <IN NAME="z_half" TYPE="real">
!   height at model interface levels
!  </IN>
!  <IN NAME="z_full" TPYE="real">
!   height at full levels
!  </IN>
!  <IN NAME="omega" TYPE="real">
!   Veritical pressure tendency
!  </IN>
!  <IN NAME="u" TYPE="real">
!   zonal wind at current time step
!  </IN>
!  <IN NAME="v" TYPE="real">
!   meridional wind at current time step
!  </IN>
!  <IN NAME="t" TYPE="real">
!   temperature at current time step
!  </IN>
!  <IN NAME="q" TYPE="real">
!   specific humidity at current time step
!  </IN>
!  <IN NAME="r" TPYE="real">
!   multiple 3d tracer fields at current time step
!  </IN>
!  <IN NAME="um" TYPE="real">
!   zonal wind at previous time step
!  </IN>
!  <IN NAME="vm" TYPE="real">
!   meridional wind at previous time step
!  </IN>
!  <IN NAME="tm" TYPE="real">
!   temperature at previous time step
!  </IN>
!  <IN NAME="qm" TYPE="real">
!   specific humidity at previous time step
!  </IN>
!  <IN NAME="rm" TPYE="real">
!   multiple 3d tracer fields at previous time step
!  </IN>
!  <IN NAME="frac_land" TYPE="real">
!   fraction of land coverage in a model grid point
!  </IN>
!  <INOUT NAME="udt" TYPE="real">
!   zonal wind tendency
!  </INOUT>
!  <INOUT NAME="vdt" TYPE="real">
!   meridional wind tendency
!  </INOUT>
!  <INOUT NAME="tdt" TYPE="real">
!   temperature tendency
!  </INOUT>
!  <INOUT NAME="qdt" TYPE="real">
!   moisture tracer tendencies
!  </INOUT>
!  <INOUT NAME="rdt" TYPE="real">
!   multiple tracer tendencies
!  </INOUT>
!  <OUT NAME="lprec" TYPE="real">
!  </OUT>
!  <OUT NAME="fprec" TYPE="real">
!  </OUT>
!  <OUT NAME="gust" TYPE="real">
!  </OUT>
!  <INOUT NAME="Surf_diff" TYPE="surface_diffusion_type">
!   Surface diffusion 
!  </INOUT>
!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! </SUBROUTINE>
!
 subroutine physics_driver_up (is, ie, js, je,                    &
                               Time_prev, Time, Time_next,        &
                               lat, lon, area,                    &
                               p_half, p_full, z_half, z_full,    &
                               omega,                             &
                               u, v, t, q, r, um, vm, tm, qm, rm, &
                               frac_land,                         &
                               u_star, b_star, q_star,            &
                               udt, vdt, tdt, qdt, rdt,           &
                               Surf_diff,                         &
                               lprec,   fprec, gust,              &
                               mask, kbot,                        &
                               hydrostatic, phys_hydrostatic      )

!----------------------------------------------------------------------
!    physics_driver_up completes the calculation of vertical diffusion 
!    and also handles moist physical processes.
!---------------------------------------------------------------------

integer,                intent(in)             :: is, ie, js, je
type(time_type),        intent(in)             :: Time_prev, Time,   &
                                                  Time_next
real,dimension(:,:),    intent(in)             :: lat, lon, area
real,dimension(:,:,:),  intent(in)             :: p_half, p_full,   &
                                                  omega,  &
                                                  z_half, z_full,     &
                                                  u , v , t , q ,    &
                                                  um, vm, tm, qm
real,dimension(:,:,:,:),intent(in)             :: r,rm
real,dimension(:,:),    intent(in)             :: frac_land
real,dimension(:,:),    intent(in)             :: u_star, b_star, q_star
real,dimension(:,:,:),  intent(inout)          :: udt,vdt,tdt,qdt
real,dimension(:,:,:,:),intent(inout)          :: rdt
type(surf_diff_type),   intent(inout)          :: Surf_diff
real,dimension(:,:),    intent(out)            :: lprec, fprec
real,dimension(:,:),    intent(inout)          :: gust
real,dimension(:,:,:),  intent(in),   optional :: mask
integer,dimension(:,:), intent(in),   optional :: kbot
logical,                intent(in),   optional :: hydrostatic, phys_hydrostatic

!-----------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                     the physics_window being integrated
!      Time_prev      previous time, for variables um,vm,tm,qm,rm 
!                     (time_type)
!      Time           current time, for variables u,v,t,q,r  (time_type)
!      Time_next      next time, used for diagnostics   (time_type)
!      lat            latitude of model points [ radians ]
!      lon            longitude of model points [ radians ]
!      area           grid box area - currently not used [ m**2 ]
!      p_half         pressure at half levels (offset from t,q,u,v,r)
!                     [ Pa ]
!      p_full         pressure at full levels [ Pa }
!      omega
!      z_half         height at half levels [ m ]
!      z_full         height at full levels [ m ]
!      u              zonal wind at current time step [ m / s ]
!      v              meridional wind at current time step [ m / s ]
!      t              temperature at current time step [ deg k ]
!      q              specific humidity at current time step  kg / kg ]
!      r              multiple 3d tracer fields at current time step
!      um,vm          zonal and meridional wind at previous time step
!      tm,qm          temperature and specific humidity at previous 
!                     time step
!      rm             multiple 3d tracer fields at previous time step
!      frac_land
!      rough_mom
!      albedo
!      t_surf_rad
!      u_star
!      b_star
!      q_star
!      dtau_du
!      dtau_dv
!
!  intent(inout) variables:
!
!      tau_x
!      tau_y
!      udt            zonal wind tendency [ m / s**2 ]
!      vdt            meridional wind tendency [ m / s**2 ]
!      tdt            temperature tendency [ deg k / sec ]
!      qdt            specific humidity tendency 
!                     [  kg vapor / kg air / sec ]
!      rdt            multiple tracer tendencies [ unit / unit / sec ]
!      Surf_diff      surface_diffusion_type variable
!      gust
!
!   intent(out) variables:
!
!      lprec     
!      fprec       
!
!   intent(in), optional variables:
!
!       mask        mask that designates which levels do not have data
!                   present (i.e., below ground); 0.=no data, 1.=data
!       kbot        lowest level which has data
!                   note:  both mask and kbot must be present together.
!
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!   local variables:

      real, dimension(size(u,1), size(u,2), size(u,3)) :: diff_cu_mo_loc
      real, dimension(size(u,1), size(u,2))            :: gust_cv
      real, dimension(size(u,1), size(u,2))            :: land_mask
      integer :: sec, day
      real    :: dt
      real, dimension(size(t,1), size(t,2)) :: u_sfc, v_sfc
      real, dimension(size(t,1), size(t,2), size(t,3)+1) :: pflux
      real, dimension(size(t,1), size(t,2), size(t,3))   ::  &
                             tca, cca, rhoi, lsliq, lsice, ccliq,  &
                             ccice, reff_lsclliq, reff_lsclice, &
                             reff_ccclliq, reff_ccclice, &
                             reff_lsprliq, reff_lsprice, &
                             reff_ccprliq, reff_ccprice, &
                             fl_lsrain_loc, fl_lssnow_loc,  &
                             fl_lsgrpl_loc, &
                             fl_donmca_rain_loc, fl_donmca_snow_loc, &
                             fl_ccrain_loc, fl_ccsnow_loc, mr_ozone_loc
      real, dimension(size(t,1), size(t,2), size(t,3), ncol) ::  &
                             stoch_mr_liq, stoch_mr_ice, &
                             stoch_size_liq, stoch_size_frz
      integer :: i, j , k, n
      integer :: nls, ncc
      real    :: alphb
      integer :: flag_ls, flag_cc
      integer :: kmax
      logical :: used
   
!---------------------------------------------------------------------
!   local variables:
!
!        diff_cu_mo_loc   diffusion coefficient contribution due to 
!                         cumulus momentum transport
!        gust_cv
!        sec, day         second and day components of the time_type 
!                         variable
!        dt               physics time step [ seconds ]
!
!---------------------------------------------------------------------
      type(aerosol_type)                               :: Aerosol

!---------------------------------------------------------------------
!    verify that the module is initialized.
!---------------------------------------------------------------------
      if ( .not. module_is_initialized) then
        call error_mesg ('physics_driver_mod',  &
             'module has not been initialized', FATAL)
      endif

!----------------------------------------------------------------------
!    define number of model layers.
!----------------------------------------------------------------------
      kmax = size(u,3)

!----------------------------------------------------------------------
!    compute the physics time step (from tau-1 to tau+1).
!---------------------------------------------------------------------
      call get_time (Time_next-Time_prev, sec, day)
      dt = real(sec+day*86400)

!------------------------------------------------------------------
!    call vert_diff_driver_up to complete the vertical diffusion
!    calculation.
!------------------------------------------------------------------

      if (id_tdt_phys_vdif_up > 0) then
        used = send_data ( id_tdt_phys_vdif_up, -2.0*tdt(:,:,:), &
                           Time_next, is, js, 1, rmask=mask )
      endif

      do n=1,nt
        if (id_tracer_phys_vdif_up(n) > 0) then
          used = send_data ( id_tracer_phys_vdif_up(n), -2.0*rdt(:,:,:,n), &
                             Time_next, is, js, 1, rmask=mask )
        endif
      end do

      call mpp_clock_begin ( diff_up_clock )
      call vert_diff_driver_up (is, js, Time_next, dt, p_half,   &
                                Surf_diff, tdt, qdt, rdt, mask=mask,  &
                                kbot=kbot)
      radturbten(is:ie,js:je,:) = radturbten(is:ie,js:je,:) + tdt(:,:,:)
      call mpp_clock_end ( diff_up_clock )

      if (id_tdt_phys_vdif_up > 0) then
        used = send_data ( id_tdt_phys_vdif_up, +2.0*tdt(:,:,:), &
                           Time_next, is, js, 1, rmask=mask )
      endif

      do n=1,nt
        if (id_tracer_phys_vdif_up(n) > 0) then
          used = send_data ( id_tracer_phys_vdif_up(n), +2.0*rdt(:,:,:,n), &
                             Time_next, is, js, 1, rmask=mask )
        endif
      end do

!-----------------------------------------------------------------------
!    if the fms integration path is being followed, call moist processes
!    to compute moist physics, including convection and processes 
!    involving condenstion.
!-----------------------------------------------------------------------
      if (do_moist_processes) then

        if (id_tdt_phys_moist > 0) then
          used = send_data ( id_tdt_phys_moist, -2.0*tdt(:,:,:), &
                             Time_next, is, js, 1, rmask=mask )
        endif

        do n=1,nt
          if (id_tracer_phys_moist(n) > 0) then
            used = send_data ( id_tracer_phys_moist(n), -2.0*rdt(:,:,:,n), &
                               Time_next, is, js, 1, rmask=mask )
          endif
        end do

        call mpp_clock_begin ( moist_processes_clock )

!-----------------------------------------------------------------------
        if (.NOT. do_grey_radiation) then !rif:(09/02/09) to avoid a call to Aerosol when using do_grey_radiation
!       Get aerosol mass concentrations
        pflux(:,:,1) = 0.0E+00
        do i=2,size(p_full,3)
          pflux(:,:,i) = 0.5E+00*(p_full(:,:,i-1) + p_full(:,:,i))
        end do
	pflux(:,:,size(p_full,3)+1) = p_full(:,:,size(p_full,3)) 
        call aerosol_driver (is, js, Time, r, &
                             p_half, pflux, &
                             Aerosol)
        end if
!--------------------------------------------------------------------
!    on steps on which the cosp simulator is called, move the values
!    of precip flux saved on the previous step so they will not be 
!    overwritten on the upcoming call to moist_processes.
!--------------------------------------------------------------------
        if (do_cosp) then
          if (step_to_call_cosp) then
            fl_lsrain_loc(:,:,:) = fl_lsrain(is:ie,js:je,:)
            fl_lssnow_loc(:,:,:) = fl_lssnow(is:ie,js:je,:)
            fl_lsgrpl_loc(:,:,:) = fl_lsgrpl(is:ie,js:je,:)
            fl_ccrain_loc(:,:,:) = fl_ccrain(is:ie,js:je,:)
            fl_ccsnow_loc(:,:,:) = fl_ccsnow(is:ie,js:je,:)
            fl_donmca_rain_loc(:,:,:) = fl_donmca_rain(is:ie,js:je,:)
            fl_donmca_snow_loc(:,:,:) = fl_donmca_snow(is:ie,js:je,:)
            mr_ozone_loc(:,:,:)  = mr_ozone (is:ie,js:je,:)
          endif
        endif

       if (doing_donner .and. doing_uw_conv) then
         call moist_processes (is, ie, js, je, Time_next, dt, &
           frac_land, p_half, p_full, z_half, z_full, omega,    &
           diff_t(is:ie,js:je,:), radturbten(is:ie,js:je,:),    &
           cush(is:ie,js:je), cbmf(is:ie,js:je),   &!miz
           pbltop(is:ie,js:je), u_star, b_star, q_star,  &!miz
           t, q, r, u, v, tm, qm, rm, um, vm, tdt, qdt, rdt, udt, &
           vdt, diff_cu_mo_loc, convect(is:ie,js:je), lprec, &
           fprec, fl_lsrain(is:ie,js:je,:), fl_lssnow(is:ie,js:je,:),  &
           fl_ccrain(is:ie,js:je,:), fl_ccsnow(is:ie,js:je,:),    &
           fl_donmca_rain(is:ie,js:je,:), fl_donmca_snow(is:ie,js:je,:), &
           gust_cv, area, lat, lsc_cloud_area(is:ie,js:je,:),  &
           lsc_liquid(is:ie,js:je,:), lsc_ice(is:ie,js:je,:), &
           lsc_droplet_number(is:ie,js:je,:), Aerosol, mask=mask,  &
           kbot=kbot, shallow_cloud_area=shallow_cloud_area(is:ie,js:je,:), &
           shallow_liquid=shallow_liquid(is:ie,js:je,:), &
           shallow_ice= shallow_ice(is:ie,js:je,:),   &
           shallow_droplet_number= shallow_droplet_number(is:ie,js:je,:), &
           cell_cld_frac= cell_cld_frac(is:ie,js:je,:), &
           cell_liq_amt=cell_liq_amt(is:ie,js:je,:), &
           cell_liq_size=cell_liq_size(is:ie,js:je,:), &
           cell_ice_amt= cell_ice_amt(is:ie,js:je,:),     &
           cell_ice_size= cell_ice_size(is:ie,js:je,:),   &
           cell_droplet_number= cell_droplet_number(is:ie,js:je,:), &
           meso_cld_frac= meso_cld_frac(is:ie,js:je,:),   &
           meso_liq_amt=meso_liq_amt(is:ie,js:je,:), &
           meso_liq_size=meso_liq_size(is:ie,js:je,:), &
           meso_ice_amt= meso_ice_amt(is:ie,js:je,:),  &
           meso_ice_size= meso_ice_size(is:ie,js:je,:),  &
           meso_droplet_number= meso_droplet_number(is:ie,js:je,:), &
           nsum_out=nsum_out(is:ie,js:je),    &
           hydrostatic=hydrostatic, phys_hydrostatic=phys_hydrostatic  )
       else if (doing_donner) then
        call moist_processes (is, ie, js, je, Time_next, dt, frac_land, &
                           p_half, p_full, z_half, z_full, omega,    &
                           diff_t(is:ie,js:je,:),                    &
                           radturbten(is:ie,js:je,:),                &
                           cush           (is:ie,js:je),             &
                          cbmf           (is:ie,js:je),             &
                            pbltop(is:ie,js:je),         &!miz
                            u_star, b_star, q_star,          &!miz
                           t, q, r, u, v, tm, qm, rm, um, vm,        &
                           tdt, qdt, rdt, udt, vdt, diff_cu_mo_loc , &
                           convect(is:ie,js:je), lprec, fprec,       &
            fl_lsrain(is:ie,js:je,:), fl_lssnow(is:ie,js:je,:),  &
            fl_ccrain(is:ie,js:je,:), fl_ccsnow(is:ie,js:je,:),    &
           fl_donmca_rain(is:ie,js:je,:), fl_donmca_snow(is:ie,js:je,:), &
                           gust_cv, area, lat,  &
                           lsc_cloud_area(is:ie,js:je,:), &
                           lsc_liquid(is:ie,js:je,:), &
                           lsc_ice(is:ie,js:je,:), &
                           lsc_droplet_number(is:ie,js:je,:), &
                           Aerosol, mask=mask, kbot=kbot, &
                           cell_cld_frac= cell_cld_frac(is:ie,js:je,:), &
                           cell_liq_amt=cell_liq_amt(is:ie,js:je,:), &
                           cell_liq_size=cell_liq_size(is:ie,js:je,:), &
                           cell_ice_amt= cell_ice_amt(is:ie,js:je,:),   &
                           cell_ice_size= cell_ice_size(is:ie,js:je,:), &
              cell_droplet_number= cell_droplet_number(is:ie,js:je,:), &
                           meso_cld_frac= meso_cld_frac(is:ie,js:je,:), &
                           meso_liq_amt=meso_liq_amt(is:ie,js:je,:), &
                           meso_liq_size=meso_liq_size(is:ie,js:je,:), &
                           meso_ice_amt= meso_ice_amt(is:ie,js:je,:),  &
                           meso_ice_size= meso_ice_size(is:ie,js:je,:), &
              meso_droplet_number= meso_droplet_number(is:ie,js:je,:), &
                           nsum_out=nsum_out(is:ie,js:je),    &
           hydrostatic=hydrostatic, phys_hydrostatic=phys_hydrostatic  )
                          
       else if (doing_uw_conv) then
        call moist_processes (is, ie, js, je, Time_next, dt, frac_land,         &
                            p_half, p_full, z_half, z_full, omega,    &
                            diff_t(is:ie,js:je,:),                    &
                            radturbten(is:ie,js:je,:),                &
                            cush           (is:ie,js:je),             &!
                          cbmf           (is:ie,js:je),             &!
                            pbltop(is:ie,js:je),         &!miz
                            u_star, b_star, q_star,          &!miz
                            t, q, r, u, v, tm, qm, rm, um, vm,        &
                            tdt, qdt, rdt, udt, vdt, diff_cu_mo_loc , &
                            convect(is:ie,js:je), lprec, fprec,       &
               fl_lsrain(is:ie,js:je,:), fl_lssnow(is:ie,js:je,:),  &
               fl_ccrain(is:ie,js:je,:), fl_ccsnow(is:ie,js:je,:),    &
           fl_donmca_rain(is:ie,js:je,:), fl_donmca_snow(is:ie,js:je,:), &
                            gust_cv, area, lat,   &
                           lsc_cloud_area(is:ie,js:je,:),  &
                           lsc_liquid(is:ie,js:je,:),  &
                           lsc_ice(is:ie,js:je,:), &
                           lsc_droplet_number(is:ie,js:je,:), &
                             Aerosol, mask=mask, kbot=        kbot,  &
                           shallow_cloud_area= shallow_cloud_area(is:ie,js:je,:), &
                       shallow_liquid=shallow_liquid(is:ie,js:je,:),  &
                           shallow_ice= shallow_ice(is:ie,js:je,:),   &
                       shallow_droplet_number= shallow_droplet_number(is:ie,js:je,:),    &
                           hydrostatic=hydrostatic, phys_hydrostatic=phys_hydrostatic  )
       else
        call moist_processes (is, ie, js, je, Time_next, dt, frac_land, &
                           p_half, p_full, z_half, z_full, omega,    &
                           diff_t(is:ie,js:je,:),                    &
                           radturbten(is:ie,js:je,:),                &
                           cush           (is:ie,js:je),          &!
                        cbmf           (is:ie,js:je),             &!
                            pbltop(is:ie,js:je),         &!miz
                            u_star, b_star, q_star,          &!miz
                           t, q, r, u, v, tm, qm, rm, um, vm,        &
                           tdt, qdt, rdt, udt, vdt, diff_cu_mo_loc , &
                           convect(is:ie,js:je), lprec, fprec,       &
               fl_lsrain(is:ie,js:je,:), fl_lssnow(is:ie,js:je,:),  &
               fl_ccrain(is:ie,js:je,:), fl_ccsnow(is:ie,js:je,:),    &
           fl_donmca_rain(is:ie,js:je,:), fl_donmca_snow(is:ie,js:je,:), &
                           gust_cv, area, lat,   &
                           lsc_cloud_area(is:ie,js:je,:),  &
                           lsc_liquid(is:ie,js:je,:),  &
                           lsc_ice(is:ie,js:je,:), &
                           lsc_droplet_number(is:ie,js:je,:), &
                           Aerosol, mask=mask, kbot=kbot,    &
                           hydrostatic=hydrostatic, phys_hydrostatic=phys_hydrostatic  )
        endif
        call mpp_clock_end ( moist_processes_clock )
        diff_cu_mo(is:ie, js:je,:) = diff_cu_mo_loc(:,:,:)
        radturbten(is:ie,js:je,:) = 0.0

!---------------------------------------------------------------------
!    add the convective gustiness effect to that previously obtained 
!    from non-convective parameterizations.
!---------------------------------------------------------------------
        gust = sqrt( gust*gust + gust_cv*gust_cv)

        if (id_tdt_phys_moist > 0) then
          used = send_data ( id_tdt_phys_moist, +2.0*tdt(:,:,:), &
                             Time_next, is, js, 1, rmask=mask )
        endif

        do n=1,nt
          if (id_tracer_phys_moist(n) > 0) then
            used = send_data ( id_tracer_phys_moist(n), +2.0*rdt(:,:,:,n), &
                               Time_next, is, js, 1, rmask=mask )
          endif
        end do

        if (id_tdt_phys > 0) then
           used = send_data ( id_tdt_phys, tdt(:,:,:), &
                              Time_next, is, js, 1, rmask=mask )
        endif
        if (id_qdt_phys > 0) then
           used = send_data ( id_qdt_phys, qdt(:,:,:), &
                              Time_next, is, js, 1, rmask=mask )
        endif

      endif ! do_moist_processes

      if(ASSOCIATED(Aerosol%aerosol))deallocate(Aerosol%aerosol)
      if(ASSOCIATED(Aerosol%family_members))deallocate(Aerosol%family_members)
      if(ASSOCIATED(Aerosol%aerosol_names))deallocate(Aerosol%aerosol_names)

      
      call mpp_clock_begin ( cosp_clock )
      if (do_cosp) then
        if (step_to_call_cosp) then

!---------------------------------------------------------------------
!    on the first step of a job segment, the values of t,q and precip 
!    flux will not be available at the proper time level. in this case
!    denoted by temp-_last = 0.0, use values from the current step for 
!    t, q and precip flux.
!---------------------------------------------------------------------
          alphb = SUM(temp_last(is:ie,js:je,:))
          if (alphb == 0.) then
            temp_last(is:ie,js:je,:) = t(:,:,:) + dt*tdt(:,:,:)
            q_last(is:ie,js:je,:) = q(:,:,:) + dt*qdt(:,:,:)
            fl_lsrain_loc(:,:,:) = fl_lsrain(is:ie,js:je,:)
            fl_lssnow_loc(:,:,:) = fl_lssnow(is:ie,js:je,:)
            fl_lsgrpl_loc(:,:,:) = fl_lsgrpl(is:ie,js:je,:)
            fl_ccrain_loc(:,:,:) = fl_ccrain(is:ie,js:je,:)
            fl_ccsnow_loc(:,:,:) = fl_ccsnow(is:ie,js:je,:)
            fl_donmca_rain_loc(:,:,:) = fl_donmca_rain(is:ie,js:je,:)
            fl_donmca_snow_loc(:,:,:) = fl_donmca_snow(is:ie,js:je,:)
          endif

!----------------------------------------------------------------------
!    define the total and convective cloud fractions in each grid box as
!    the average over the stochastic columns.
!----------------------------------------------------------------------
          tca = 0.
          cca = 0.
          do n=1,ncol                      
            where (stoch_cloud_type(is:ie,js:je,:,n) > 0) 
              tca(:,:,:)  = tca(:,:,:) +  1.0
            end where
            where (stoch_cloud_type(is:ie,js:je,:,n) == 2) 
              cca(:,:,:)  = cca(:,:,:) +  1.0
            end where
          end do
          tca = tca/ float(ncol)                
          cca = cca/ float(ncol)

!--------------------------------------------------------------------
!    define the atmospheric density to use in converting concentrations
!    to mixing ratios.
!--------------------------------------------------------------------
          do k=1, size(stoch_cloud_type,3)
            do j=1, size(stoch_cloud_type,2)
              do i=1, size(stoch_cloud_type,1)
                rhoi(i,j,k) =  RDGAS*temp_last(i+is-1,j+js-1,k)/ &
                                                          p_full(i,j,k) 
              end do
            end do
          end do

!--------------------------------------------------------------------
!   convert the condensate concentrations in each stochastic column to 
!   mixing ratios. 
!--------------------------------------------------------------------
          do n=1,ncol                       
            do k=1, size(stoch_cloud_type,3)
              do j=1, size(stoch_cloud_type,2)
                do i=1, size(stoch_cloud_type,1)
                  stoch_mr_liq(i,j,k,n) = 1.0e-03*  &
                         stoch_conc_drop(i+is-1,j+js-1,k,n)*rhoi(i,j,k)
                  stoch_mr_ice(i,j,k,n) = 1.0e-03*  &
                         stoch_conc_ice (i+is-1,j+js-1,k,n)*rhoi(i,j,k)
                  stoch_size_liq(i,j,k,n) = 1.0e-06*  &
                         stoch_size_drop(i+is-1,j+js-1,k,n)
                  stoch_size_frz(i,j,k,n) = 1.0e-06*  &
                         stoch_size_ice (i+is-1,j+js-1,k,n)
                end do
              end do
            end do
          end do
          stoch_mr_liq = stoch_mr_liq/(1.0-stoch_mr_liq)
          stoch_mr_ice = stoch_mr_ice/(1.0-stoch_mr_ice)

!---------------------------------------------------------------------
!    define the grid box mean largescale and convective condensate 
!    mixing ratios and sizes.
!---------------------------------------------------------------------
          lsliq = 0.
          lsice = 0.
          ccliq = 0.
          ccice = 0.
          reff_lsclliq = 0.
          reff_lsclice = 0.
          reff_ccclliq = 0.
          reff_ccclice = 0.
          reff_lsprliq = 0.
          reff_lsprice = 0.
          reff_ccprliq = 0.
          reff_ccprice = 0.
          do k=1, size(stoch_cloud_type,3)
            do j=1, size(stoch_cloud_type,2)
              do i=1, size(stoch_cloud_type,1)
                nls = 0
                ncc = 0
                do n=1,ncol                       
                  if (stoch_cloud_type(i+is-1,j+js-1,k,n) == 1) then
                    nls = nls + 1
                    lsliq(i,j,k) = lsliq(i,j,k) +  &
                                     stoch_conc_drop(i+is-1,j+js-1,k,n)
                    lsice(i,j,k) = lsice(i,j,k) +   &
                                     stoch_conc_ice (i+is-1,j+js-1,k,n)
                    reff_lsclliq(i,j,k) = reff_lsclliq(i,j,k) +  &
                                     stoch_size_drop(i+is-1,j+js-1,k,n)
                    reff_lsclice(i,j,k) = reff_lsclice(i,j,k) +  &
                                     stoch_size_ice (i+is-1,j+js-1,k,n)
                  else if (stoch_cloud_type(i+is-1,j+js-1,k,n) == 2)then
                    ncc = ncc + 1
                    ccliq(i,j,k) = ccliq(i,j,k) +  &
                                     stoch_conc_drop(i+is-1,j+js-1,k,n)
                    ccice(i,j,k) = ccice(i,j,k) +  &
                                     stoch_conc_ice (i+is-1,j+js-1,k,n)
                    reff_ccclliq(i,j,k) = reff_ccclliq(i,j,k) +  &
                                     stoch_size_drop(i+is-1,j+js-1,k,n)
                    reff_ccclice(i,j,k) = reff_ccclice(i,j,k) +  &
                                     stoch_size_ice (i+is-1,j+js-1,k,n)
                  endif
                end do
                if (nls > 0) then
                  lsliq(i,j,k) = 1.0e-03*lsliq(i,j,k)/float(nls)
                  lsice(i,j,k) = 1.0e-03*lsice(i,j,k)/float(nls)
                  reff_lsclliq(i,j,k) = 1.0e-06*  &
                                      reff_lsclliq (i,j,k)/float(nls)
                  reff_lsclice(i,j,k) = 1.0e-06*  &
                                      reff_lsclice (i,j,k)/float(nls)
                endif
                if (ncc > 0) then
                  ccliq(i,j,k) = 1.0e-03*ccliq(i,j,k)/float(ncc)
                  ccice(i,j,k) = 1.0e-03*ccice(i,j,k)/float(ncc)
                  reff_ccclliq(i,j,k) = 1.0e-06*  &
                                    reff_ccclliq (i,j,k) /float(ncc)
                  reff_ccclice(i,j,k) = 1.0e-06*  &
                                    reff_ccclice (i,j,k) /float(ncc)
                endif
                ccliq(i,j,k) = ccliq(i,j,k)*rhoi(i,j,k)/ &
                                                  (1.0-ccliq(i,j,k))
                ccice(i,j,k) = ccice(i,j,k)*rhoi(i,j,k)/  &
                                                  (1.0-ccice(i,j,k))
                lsliq(i,j,k) = lsliq(i,j,k)*rhoi(i,j,k)/  &
                                                  (1.0-lsliq(i,j,k))
                lsice(i,j,k) = lsice(i,j,k)*rhoi(i,j,k)/  &
                                                  (1.0-lsice(i,j,k))
              end do
            end do
          end do
     
!---------------------------------------------------------------------
!   define land_mask array. set it to 1 over land, 0 over ocean; define
!   based on frac_land > 0.5 being land.
!---------------------------------------------------------------------
          where (frac_land > 0.50)
            land_mask(:,:) =  1.0
          elsewhere
            land_mask(:,:) =  0.0
          end where

          if (allow_cosp_precip_wo_clouds) then
          else
!--------------------------------------------------------------------
!    allow ls precip only in columns containing ls cloud. allow 
!    convective precip only in columns with convective cloud,
!--------------------------------------------------------------------
          do j=1, size(stoch_cloud_type,2)
            do i=1, size(stoch_cloud_type,1)
              flag_ls = 0
              flag_cc = 0
              do k=1, size(stoch_cloud_type,3)
                do n=1,ncol                        
                  if (stoch_cloud_type(i+is-1,j+js-1,k,n) == 1) then
                    flag_ls = 1
                    exit
                  else if(stoch_cloud_type(i+is-1,j+js-1,k,n) == 2) then
                    flag_cc = 1
                    exit
                  endif
                end do
                if (flag_ls == 1 .and. flag_cc == 1) exit
              end do
              if (flag_ls == 0) then
                fl_lsrain_loc(i,j,:) = 0.
                fl_lssnow_loc(i,j,:) = 0.
                fl_lsgrpl_loc(i,j,:) = 0.
              endif 
              if (flag_cc == 0) then
                fl_ccrain_loc(i,j,:) = 0.
                fl_ccsnow_loc(i,j,:) = 0.
              endif 
            end do
          end do
          endif

          if (include_donmca_in_cosp) then
            fl_ccrain_loc = fl_ccrain_loc + fl_donmca_rain_loc
            fl_ccsnow_loc = fl_ccsnow_loc + fl_donmca_snow_loc
          endif

!---------------------------------------------------------------------
!    pass in the large-scale graupel flux, lowest-level u and v wind
!    components.
!---------------------------------------------------------------------
          fl_lsgrpl = 0.
          u_sfc = u(:,:,kmax)
          v_sfc = v(:,:,kmax)

!---------------------------------------------------------------------
!    call the cosp simulator to produce the desired outputs.
!---------------------------------------------------------------------
          call cosp_driver (lat*180./ACOS(-1.0), lon*180./ACOS(-1.0),  &
                            daytime(is:ie,js:je), &
                            p_half, &
                            p_full, z_half,  &
                            z_full, u_sfc, v_sfc, mr_ozone_loc, &
                            temp_last(is:ie,js:je,:),  &
                            q_last(is:ie,js:je,:), tca, cca, lsliq,  &
                            lsice, ccliq, ccice,  &
                           fl_lsrain_loc, fl_lssnow_loc, fl_lsgrpl_loc,&
                            fl_ccrain_loc, fl_ccsnow_loc,&
                            0.5*reff_lsclliq, 0.5*reff_lsclice,  &
                            reff_lsprliq, reff_lsprice,  &
                            0.5*reff_ccclliq, 0.5*reff_ccclice, &
                            reff_ccprliq, reff_ccprice, &
                            tsurf_save(is:ie, js:je), land_mask, &
                            Time_next, is, js, &
                stoch_mr_liq_in =stoch_mr_liq,  &
                stoch_mr_ice_in =stoch_mr_ice,  &
                stoch_size_liq_in =0.5*stoch_size_liq, &
                stoch_size_frz_in = 0.5*stoch_size_frz,  &
                tau_stoch_in = tau_stoch(is:ie,js:je,:,:),&
                lwem_stoch_in = lwem_stoch(is:ie,js:je,:,:), &
                stoch_cloud_type_in = stoch_cloud_type(is:ie,js:je,:,:))
        endif ! (step_to_call_cosp)
      endif ! (do_cosp)
      call mpp_clock_end ( cosp_clock )

!--------------------------------------------------------------------
! save t and q from end of step for use with next call to COSP
!--------------------------------------------------------------------
      temp_last(is:ie,js:je,:) = t(:,:,:) + tdt(:,:,:)*dt
      q_last   (is:ie,js:je,:) = q(:,:,:) + qdt(:,:,:)*dt
       
!-----------------------------------------------------------------------


 end subroutine physics_driver_up


!#######################################################################
! <SUBROUTINE NAME="physics_driver_end">
!  <OVERVIEW>
!   physics_driver_end is the destructor for physics_driver_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    physics_driver_end is the destructor for physics_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call physics_driver_end (Time)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
! </SUBROUTINE>
!
subroutine physics_driver_end (Time)

!---------------------------------------------------------------------
!    physics_driver_end is the destructor for physics_driver_mod.
!---------------------------------------------------------------------

type(time_type), intent(in) :: Time

!--------------------------------------------------------------------
!   intent(in) variables:
! 
!      Time      current time [ time_type(days, seconds) ]
!
!--------------------------------------------------------------------
integer :: moist_processes_term_clock, damping_term_clock, turb_term_clock, &
           diff_term_clock, cloud_spec_term_clock, aerosol_term_clock, &
           grey_radiation_term_clock, radiative_gases_term_clock, &
           radiation_term_clock, tracer_term_clock, cosp_term_clock

      moist_processes_term_clock =      &
        mpp_clock_id( '   Phys_driver_term: MP: Termination', &
                grain=CLOCK_MODULE_DRIVER )
      damping_term_clock         =     &
        mpp_clock_id( '   Phys_driver_term: Damping: Termination',    &
                  grain=CLOCK_MODULE_DRIVER )
      turb_term_clock            =      &
        mpp_clock_id( '   Phys_driver_term: Vert. Turb.: Termination', &
                  grain=CLOCK_MODULE_DRIVER )
      diff_term_clock       =     &
        mpp_clock_id( '   Phys_driver_term: Vert. Diff.: Termination',   &
                 grain=CLOCK_MODULE_DRIVER )
      cloud_spec_term_clock       =       &
        mpp_clock_id( '   Phys_driver_term: Cloud spec: Termination', &
                       grain=CLOCK_MODULE_DRIVER )
      cosp_term_clock       =       &
        mpp_clock_id( '   Phys_driver_term: COSP: Termination', &
                       grain=CLOCK_MODULE_DRIVER )
      aerosol_term_clock       =       &
        mpp_clock_id( '   Phys_driver_term: Aerosol: Termination', &
                       grain=CLOCK_MODULE_DRIVER )
      grey_radiation_term_clock       =       &
        mpp_clock_id( '   Phys_driver_term: Grey Radiation: Termination', &
                       grain=CLOCK_MODULE_DRIVER )
      radiative_gases_term_clock       =       &
        mpp_clock_id( '   Phys_driver_term: Radiative gases: Termination', &
                       grain=CLOCK_MODULE_DRIVER )
      radiation_term_clock       =       &
        mpp_clock_id( '   Phys_driver_term: Radiation: Termination', &
                       grain=CLOCK_MODULE_DRIVER )
      tracer_term_clock          =      &
        mpp_clock_id( '   Phys_driver_term: Tracer: Termination',    &
                 grain=CLOCK_MODULE_DRIVER )
!---------------------------------------------------------------------
!    verify that the module is initialized.
!---------------------------------------------------------------------
      if ( .not. module_is_initialized) then
        call error_mesg ('physics_driver_mod',  &
              'module has not been initialized', FATAL)
      endif

      call physics_driver_netcdf

!--------------------------------------------------------------------
!    call the destructor routines for those modules who were initial-
!    ized from this module.
!--------------------------------------------------------------------
      call mpp_clock_begin ( turb_term_clock )
      call vert_turb_driver_end
      call mpp_clock_end ( turb_term_clock )
      call mpp_clock_begin ( diff_term_clock )
      call vert_diff_driver_end
      call mpp_clock_end ( diff_term_clock )
      if (do_radiation) then
        call mpp_clock_begin ( radiation_term_clock )
        call radiation_driver_end
        call mpp_clock_end ( radiation_term_clock )
        call mpp_clock_begin ( radiative_gases_term_clock )
        call radiative_gases_end
        call mpp_clock_end ( radiative_gases_term_clock )
        call mpp_clock_begin ( cloud_spec_term_clock )
        call cloud_spec_end
        call mpp_clock_end ( cloud_spec_term_clock )
        call mpp_clock_begin ( aerosol_term_clock )
        call aerosol_end
        call mpp_clock_end ( aerosol_term_clock )
      endif
      call mpp_clock_begin ( grey_radiation_term_clock )

      if(do_grey_radiation) call grey_radiation_end 

      call mpp_clock_end ( grey_radiation_term_clock )
      call mpp_clock_begin ( moist_processes_term_clock )
      call moist_processes_end
      call mpp_clock_end ( moist_processes_term_clock )
      call mpp_clock_begin ( tracer_term_clock )
      call atmos_tracer_driver_end
      call mpp_clock_end ( tracer_term_clock )
      call mpp_clock_begin ( damping_term_clock )
      call damping_driver_end
      call mpp_clock_end ( damping_term_clock )
      call mpp_clock_begin ( cosp_term_clock )
      if (do_cosp) then
        call cosp_driver_end
      endif
      call mpp_clock_end ( cosp_term_clock )

!---------------------------------------------------------------------
!    deallocate the module variables.
!---------------------------------------------------------------------
      deallocate (diff_cu_mo, diff_t, diff_m, pbltop, cush, cbmf, convect,   &
                  radturbten, lw_tendency)
      if (doing_donner) then
        deallocate (cell_cld_frac, cell_liq_amt, cell_liq_size, &
                    cell_ice_amt, cell_ice_size, cell_droplet_number, &
                    meso_cld_frac, meso_liq_amt, meso_liq_size, &
                    meso_ice_amt, meso_ice_size, meso_droplet_number, &
                    nsum_out)
      endif
      if (doing_uw_conv) then
        deallocate (shallow_cloud_area, shallow_liquid, shallow_ice, &
                    shallow_droplet_number)

      endif
 
      deallocate (id_tracer_phys_vdif_dn)
      deallocate (id_tracer_phys_vdif_up)
      deallocate (id_tracer_phys_turb)
      deallocate (id_tracer_phys_moist)

      if (do_cosp .or. do_modis_yim) then
        deallocate (stoch_cloud_type, tau_stoch, lwem_stoch, &
                    stoch_conc_drop, stoch_conc_ice, stoch_size_drop, &
                    stoch_size_ice, tsurf_save)
      endif
!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.


!-----------------------------------------------------------------------

 end subroutine physics_driver_end

!#######################################################################
! <SUBROUTINE NAME="physics_driver_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine physics_driver_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp


  if(do_netcdf_restart) then
    if (mpp_pe() == mpp_root_pe() ) then
       call error_mesg('physics_driver_mod', 'Writing netCDF formatted restart file: RESTART/physics_driver.res.nc', NOTE)
    endif
    call physics_driver_netcdf(timestamp)
    call vert_turb_driver_restart(timestamp)
    if (do_radiation) then
      call radiation_driver_restart(timestamp)
      call radiative_gases_restart(timestamp)
    endif

!    call moist_processes_restart(timestamp)
    call damping_driver_restart(timestamp)
  else
     call error_mesg('physics_driver_mod', &
         'Native intermediate restart files are not supported.', FATAL)
  endif



end subroutine physics_driver_restart
! </SUBROUTINE> NAME="physics_driver_restart"

! <SUBROUTINE NAME="physics_driver_netcdf">
!
! <DESCRIPTION>
! Write out restart file for physics driver.
! This routine is needed so that physics_driver_restart and physics_driver_end
! can call a routine which will not result in multiple copies of restart files 
! being written by the destructor routines.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine physics_driver_netcdf(timestamp)
  character(len=*), intent(in), optional :: timestamp

    r_convect = 0.
    where(convect)
       r_convect = 1.0
    end where
    call save_restart(Phy_restart, timestamp)
    if(in_different_file) call save_restart(Til_restart, timestamp)

end subroutine physics_driver_netcdf
! </SUBROUTINE> NAME="physics_driver_netcdf"

!#######################################################################
! <FUNCTION NAME="do_moist_in_phys_up">
!  <OVERVIEW>
!    do_moist_in_phys_up returns the value of do_moist_processes
!  </OVERVIEW>
!  <DESCRIPTION>
!    do_moist_in_phys_up returns the value of do_moist_processes
!  </DESCRIPTION>
!  <TEMPLATE>
!   logical = do_moist_in_phys_up()
!  </TEMPLATE>
! </FUNCTION>
!
function do_moist_in_phys_up()

!--------------------------------------------------------------------
!    do_moist_in_phys_up returns the value of do_moist_processes
!----------------------------------------------------------------------

logical :: do_moist_in_phys_up

!---------------------------------------------------------------------
!    verify that the module is initialized.
!---------------------------------------------------------------------
      if ( .not. module_is_initialized) then
        call error_mesg ('do_moist_in_phys_up',  &
              'module has not been initialized', FATAL)
      endif
 
!-------------------------------------------------------------------
!    define output variable.
!-------------------------------------------------------------------
      do_moist_in_phys_up = do_moist_processes

 
end function do_moist_in_phys_up

!#####################################################################
! <FUNCTION NAME="get_diff_t">
!  <OVERVIEW>
!    returns the values of array diff_t
!  </OVERVIEW>
!  <DESCRIPTION>
!    returns the values of array diff_t
!  </DESCRIPTION>
!  <TEMPLATE>
!   diff_t(:,:,:) = get_diff_t()
!  </TEMPLATE>
! </FUNCTION>
!
!#####################################################################
function get_diff_t() result(diff_t_out)
real, dimension(size(diff_t,1),size(diff_t,2),size(diff_t,3)) :: diff_t_out

  if ( .not. module_is_initialized) then
    call error_mesg ('get_diff_t','module has not been initialized', FATAL)
  endif

  diff_t_out = diff_t

end function get_diff_t

!#####################################################################
! <FUNCTION NAME="get_radturbten">
!  <OVERVIEW>
!    returns the values of array radturbten
!  </OVERVIEW>
!  <DESCRIPTION>
!    returns the values of array radturbten
!  </DESCRIPTION>
!  <TEMPLATE>
!   radturbten(:,:,:) = get_radturbten()
!  </TEMPLATE>
! </FUNCTION>
!
!#####################################################################
function get_radturbten() result(radturbten_out)
real, dimension(size(radturbten,1),size(radturbten,2),size(radturbten,3)) :: radturbten_out

  if ( .not. module_is_initialized) then
    call error_mesg ('get_radturbten','module has not been initialized', FATAL)
  endif

  radturbten_out = radturbten

end function get_radturbten
!#####################################################################
! <SUBROUTINE NAME="zero_radturbten">
!  <OVERVIEW>
!    sets all values of array radturbten to zero
!  </OVERVIEW>
!  <DESCRIPTION>
!    sets all values of array radturbten to zero
!  </DESCRIPTION>
!  <TEMPLATE>
!   call zero_radturbten()
!  </TEMPLATE>
! </SUBROUTINE>
!
!#####################################################################
subroutine zero_radturbten()

  if ( .not. module_is_initialized) then
    call error_mesg ('zero_radturbten','module has not been initialized', FATAL)
  endif

  radturbten = 0.0

end subroutine zero_radturbten
!#####################################################################



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
          
               
     
!#####################################################################
! <SUBROUTINE NAME="physics_driver_register_restart">
!  <OVERVIEW>
!    physics_driver_register_restart will register restart field when do_netcdf file 
!    is true. 
!  </OVERVIEW>
subroutine physics_driver_register_restart
  character(len=64) :: fname, fname2
  integer           :: id_restart

  
  if(doing_strat()) then 
     now_doing_strat = 1
  else
     now_doing_strat = 0
  endif

  if(doing_edt) then 
     now_doing_edt = 1
  else
     now_doing_edt = 0
  endif

  if(doing_entrain) then 
     now_doing_entrain = 1
  else
     now_doing_entrain = 0
  endif

  fname = 'physics_driver.res.nc'
  call get_mosaic_tile_file(fname, fname2, .false. ) 
  allocate(Phy_restart)
  if(trim(fname2) == trim(fname)) then
     Til_restart => Phy_restart
     in_different_file = .false.
  else
     in_different_file = .true.
     allocate(Til_restart)
  endif

  id_restart = register_restart_field(Phy_restart, fname, 'vers', vers, no_domain=.true.)
  id_restart = register_restart_field(Phy_restart, fname, 'doing_strat', now_doing_strat, no_domain=.true.)
  id_restart = register_restart_field(Phy_restart, fname, 'doing_edt', now_doing_edt, no_domain=.true.)
  id_restart = register_restart_field(Phy_restart, fname, 'doing_entrain', now_doing_entrain, no_domain=.true.)

  id_restart = register_restart_field(Til_restart, fname, 'diff_cu_mo', diff_cu_mo)
  id_restart = register_restart_field(Til_restart, fname, 'pbltop', pbltop)
  id_restart = register_restart_field(Til_restart, fname, 'cush', cush)
  id_restart = register_restart_field(Til_restart, fname, 'cbmf', cbmf)
  id_restart = register_restart_field(Til_restart, fname, 'diff_t', diff_t)
  id_restart = register_restart_field(Til_restart, fname, 'diff_m', diff_m)
  id_restart = register_restart_field(Til_restart, fname, 'convect', r_convect) 
  if (doing_strat()) then
     id_restart = register_restart_field(Til_restart, fname, 'radturbten', radturbten)
  endif
  if (doing_edt .or. doing_entrain) then
     id_restart = register_restart_field(Til_restart, fname, 'lw_tendency', lw_tendency)
  endif
  if (doing_donner) then
     id_restart = register_restart_field(Til_restart, fname, 'cell_cloud_frac', cell_cld_frac)
     id_restart = register_restart_field(Til_restart, fname, 'cell_liquid_amt', cell_liq_amt)
     id_restart = register_restart_field(Til_restart, fname, 'cell_liquid_size', cell_liq_size)
     id_restart = register_restart_field(Til_restart, fname, 'cell_ice_amt', cell_ice_amt)
     id_restart = register_restart_field(Til_restart, fname, 'cell_ice_size', cell_ice_size)
     id_restart = register_restart_field(Til_restart, fname, 'meso_cloud_frac', meso_cld_frac)
     id_restart = register_restart_field(Til_restart, fname, 'meso_liquid_amt', meso_liq_amt)
     id_restart = register_restart_field(Til_restart, fname, 'meso_liquid_size', meso_liq_size)
     id_restart = register_restart_field(Til_restart, fname, 'meso_ice_amt', meso_ice_amt)
     id_restart = register_restart_field(Til_restart, fname, 'meso_ice_size', meso_ice_size)
     id_restart = register_restart_field(Til_restart, fname, 'nsum', nsum_out)
  endif
  if (doing_uw_conv) then
     id_restart = register_restart_field(Til_restart, fname, 'shallow_cloud_area', shallow_cloud_area)
     id_restart = register_restart_field(Til_restart, fname, 'shallow_liquid', shallow_liquid)
     id_restart = register_restart_field(Til_restart, fname, 'shallow_ice', shallow_ice)
     id_restart = register_restart_field(Til_restart, fname, 'shallow_droplet_number', shallow_droplet_number)
  endif
  id_restart = register_restart_field(Til_restart, fname, 'lsc_cloud_area', lsc_cloud_area)
  id_restart = register_restart_field(Til_restart, fname, 'lsc_liquid', lsc_liquid )
  id_restart = register_restart_field(Til_restart, fname, 'lsc_ice', lsc_ice )
  id_restart = register_restart_field(Til_restart, fname, 'lsc_droplet_number',   &
                                                                          lsc_droplet_number)

end subroutine physics_driver_register_restart
! </SUBROUTINE>    
!#####################################################################
! <SUBROUTINE NAME="read_restart_file">
!  <OVERVIEW>
!    read_restart_file will read the physics_driver.res file and process
!    its contents. if no restart data can be found, the module variables
!    are initialized to flag values.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_restart_file will read the physics_driver.res file and process
!    its contents. if no restart data can be found, the module variables
!    are initialized to flag values.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_restart_file
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_restart_file                                     

!---------------------------------------------------------------------
!    read_restart_file will read the physics_driver.res file and process
!    its contents. if no restart data can be found, the module variables
!    are initialized to flag values.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer  :: io, unit
      integer  :: vers2
      character(len=8) :: chvers
      logical  :: was_doing_strat, was_doing_edt, was_doing_entrain
      logical  :: was_doing_donner                                 
      logical  :: was_doing_uw_conv
      logical  :: success = .false.

!--------------------------------------------------------------------
!   local variables:
!
!      ierr              error code
!      io                error status returned from i/o operation
!      unit              io unit number for reading restart file
!      vers              restart version number if that is contained in 
!                        file; otherwise the first word of first data 
!                        record of file
!      vers2             second word of first data record of file
!      was_doing_strat   logical indicating if strat_cloud_mod was 
!                        active in job which wrote restart file
!      was_doing_edt     logical indicating if edt_mod was active
!                        in job which wrote restart file
!      was_doing_entrain logical indicating if entrain_mod was active
!                        in job which wrote restart file
!      success           logical indicating that restart data has been
!                        processed
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    obtain values for radturbten, either from physics_driver.res, if
!    reading a newer version of the file which contains it, or from 
!    strat_cloud.res when an older version of physics_driver.res is
!    being read.
!--------------------------------------------------------------------
      if(mpp_pe() == mpp_root_pe()) call mpp_error ('physics_driver_mod', &
            'Reading native formatted restart file.', NOTE)
      if (file_exist('INPUT/physics_driver.res')) then
        unit = open_restart_file ('INPUT/physics_driver.res', 'read')

!--------------------------------------------------------------------
!    read restart file version number.
!--------------------------------------------------------------------
        read (unit) vers
        if ( .not. any(vers ==restart_versions) ) then
          write (chvers, '(i4)') vers
          call error_mesg ('physics_driver_mod', &
            'restart version ' //chvers// ' cannot be read by this'//&
                                              'module version', FATAL)
        endif

!--------------------------------------------------------------------
!    starting with v8, native mode files are no longer supported.
!--------------------------------------------------------------------
        if (vers >=8 ) then
          call error_mesg ('physics_driver_mod, read_restart_file', &
            ' native mode restart files are not supported after &
                                     &version 7', FATAL)
        endif

!--------------------------------------------------------------------
!    starting with v5,  logicals are written indicating which variables
!    are present.
!--------------------------------------------------------------------
        if (vers >= 5 ) then
          read (unit) was_doing_strat, was_doing_edt, was_doing_entrain
        endif
        if (vers >= 6 ) then
          read (unit) was_doing_donner                                 
        endif
        if (vers >= 7 ) then
          read (unit) was_doing_uw_conv
        endif

!---------------------------------------------------------------------
!    read the contribution to diffusion coefficient from cumulus
!    momentum transport.
!---------------------------------------------------------------------
        call read_data (unit, diff_cu_mo)

!---------------------------------------------------------------------
!    pbl top is present in file versions 2 and up. if not present,
!    set a flag.
!---------------------------------------------------------------------
        if (vers >= 2) then
          call read_data (unit, pbltop)
          
        else
          pbltop     = -999.0
        endif

!---------------------------------------------------------------------
!    cush and cbmf are present in file versions 7 and up. if not 
!    present, set a flag.
!---------------------------------------------------------------------
        if (vers >= 7) then
          call read_data (unit, cush)  !miz
          call read_data (unit, cbmf)  !miz
        else
          cush       = -1. !miz
          cbmf       = 0.0 !miz
        endif

!---------------------------------------------------------------------
!    the temperature and momentum diffusion coefficients are present
!    beginning with v3. if not prsent, set to 0.0.
!---------------------------------------------------------------------
        if (vers >= 3) then
          call read_data (unit, diff_t)
          call read_data (unit, diff_m)
        else
          diff_t = 0.0
          diff_m = 0.0
        end if 

!---------------------------------------------------------------------
!    a flag indicating columns in which convection is occurring is
!    present beginning with v4. if not present, set it to .false.
!---------------------------------------------------------------------
        if (vers >= 4) then
          call read_data (unit, convect)
        else
          convect = .false.
        end if 

!---------------------------------------------------------------------
!    radturbten may be present in versions 5 onward, if strat_cloud_mod
!    was active in the job writing the .res file.
!---------------------------------------------------------------------
        if (vers >= 5) then

!--------------------------------------------------------------------
!    if radturbten was written, read it.
!--------------------------------------------------------------------
          if (was_doing_strat) then
            call read_data (unit, radturbten)

!---------------------------------------------------------------------
!    if strat_cloud_mod was not active in the job which wrote the 
!    restart file but it is active in the current job, initialize
!    radturbten to 0.0 and put a message in the output file.  
!---------------------------------------------------------------------
          else
            if (doing_strat()) then
              radturbten = 0.0
              call error_mesg ('physics_driver_mod', &
              ' initializing radturbten to 0.0, since it not present'//&
                            ' in physics_driver.res file', NOTE)
            endif
          endif

!--------------------------------------------------------------------
!    if lw_tendency was written, read it.
!--------------------------------------------------------------------
          if (was_doing_edt .or. was_doing_entrain) then
            call read_data (unit, lw_tendency)

!---------------------------------------------------------------------
!    if edt_mod or entrain_mod was not active in the job which wrote the
!    restart file but it is active in the current job, initialize
!    lw_tendency to 0.0 and put a message in the output file.  
!---------------------------------------------------------------------
          else
            if (doing_edt .or. doing_entrain) then
              lw_tendency = 0.0
              call error_mesg ('physics_driver_mod', &
             ' initializing lw_tendency to 0.0, since it not present'//&
                  ' in physics_driver.res file', NOTE)
            endif
          endif

!---------------------------------------------------------------------
!    close the io unit associated with physics_driver.res. set flag
!    to indicate that the restart data has been processed. 
!---------------------------------------------------------------------
          call close_file (unit)
          success = .true.
        endif  ! (vers >=5)

        if (doing_donner) then
          if (vers >= 6) then
            if (was_doing_donner) then
              call read_data (unit ,  cell_cld_frac)
              call read_data (unit ,  cell_liq_amt )
              call read_data (unit ,  cell_liq_size)
              call read_data (unit ,  cell_ice_amt )
              call read_data (unit ,  cell_ice_size)
              call read_data (unit ,  meso_cld_frac)
              call read_data (unit ,  meso_liq_amt )
              call read_data (unit ,  meso_liq_size)
              call read_data (unit ,  meso_ice_amt )
              call read_data (unit ,  meso_ice_size)
              call read_data (unit , nsum_out)                 
            else  ! (was_doing_donner)
              cell_cld_frac = 0.
              cell_liq_amt  = 0.
              cell_liq_size = 0.
              cell_ice_amt  = 0.
              cell_ice_size = 0.
              meso_cld_frac = 0.
              meso_liq_amt  = 0.
              meso_liq_size = 0.
              meso_ice_amt  = 0.
              meso_ice_size = 0.
              nsum_out = 1
            endif ! (was_doing_donner)
          else  ! (vers >= 6)
            cell_cld_frac = 0.
            cell_liq_amt  = 0.
            cell_liq_size = 0.
            cell_ice_amt  = 0.
            cell_ice_size = 0.
            meso_cld_frac = 0.
            meso_liq_amt  = 0.
            meso_liq_size = 0.
            meso_ice_amt  = 0.
            meso_ice_size = 0.
            nsum_out = 1
          endif ! (vers >= 6)
        endif  ! (doing_donner)

      if (doing_uw_conv) then
       if (vers >= 7) then
         if (was_doing_uw_conv) then
          call read_data (unit ,  shallow_cloud_area)
          call read_data (unit ,  shallow_liquid )
          call read_data (unit ,  shallow_ice )
          call read_data (unit ,  shallow_droplet_number)
      else  ! (was_doing_uw_conv)
         shallow_cloud_area = 0.
         shallow_liquid  = 0.
         shallow_ice  = 0.
         shallow_droplet_number = 0.
       endif ! (was_doing_uw_conv)
     else  ! (vers >= 7)
       shallow_cloud_area = 0.
       shallow_liquid  = 0.
       shallow_ice  = 0.
       shallow_droplet_number = 0.
     endif ! (vers >= 7)
  
    endif  ! (doing_uw_conv)

!---------------------------------------------------------------------
!    if there is no physics_driver.res, set the remaining module
!    variables to 0.0
!---------------------------------------------------------------------
      else
        diff_t = 0.0
        diff_m = 0.0
        diff_cu_mo = 0.0
        pbltop     = -999.0
        cush       = -1.  !miz
        cbmf       = 0.0  !miz
        convect = .false.
        if (doing_donner) then
        cell_cld_frac = 0.
        cell_liq_amt  = 0.
        cell_liq_size = 0.
        cell_ice_amt  = 0.
        cell_ice_size = 0.
        meso_cld_frac = 0.
        meso_liq_amt  = 0.
        meso_liq_size = 0.
        meso_ice_amt  = 0.
        meso_ice_size = 0.
        nsum_out = 1
        endif ! (doing_donner)
       if (doing_uw_conv) then
        shallow_cloud_area = 0.
        shallow_liquid  = 0.
        shallow_ice  = 0.
        shallow_droplet_number = 0.
      endif ! (doing_uw_conv)
      endif  ! present(.res)

!--------------------------------------------------------------------
!    if a version of physics_driver.res containing the needed data is
!    not present, check for the presence of the radturbten data in 
!    strat_cloud.res.
!--------------------------------------------------------------------
      if ( .not. success) then
        if (doing_strat()) then
          if (file_exist('INPUT/strat_cloud.res')) then
            unit = open_restart_file ('INPUT/strat_cloud.res', 'read')
            read (unit, iostat=io, err=142) vers, vers2

!----------------------------------------------------------------------
!    if an i/o error does not occur, then the strat_cloud.res file 
!    contains the variable radturbten. rewind and read. close file upon
!    completion.
!----------------------------------------------------------------------
142         continue
            if (io == 0) then
              call error_mesg ('physics_driver_mod',  &
                'reading pre-version number strat_cloud.res file, '//&
                 'reading  radturbten', NOTE)
              rewind (unit)
              call read_data (unit, radturbten)
              call close_file (unit)

!---------------------------------------------------------------------
!    if the eor was reached (io /= 0), then the strat_cloud.res file
!    does not contain the radturbten data.  set values to 0.0 and
!    put a note in the output file.
!---------------------------------------------------------------------
            else
              radturbten = 0.0
              call error_mesg ('physics_driver_mod',  &
                  'neither strat_cloud.res nor physics_driver.res '//&
                   'contain the radturbten data, setting it to 0.0', &
                                                                NOTE)
            endif

!----------------------------------------------------------------------
!    if strat_cloud.res is not present, set radturbten to 0.0.
!----------------------------------------------------------------------
          else
            radturbten = 0.0
            call error_mesg ('physics_driver_mod',  &
              'setting radturbten to zero, no strat_cloud.res '//&
               'file present, data not in physics_driver.res', NOTE)
          endif
        endif

!--------------------------------------------------------------------
!    check if the lw_tendency data is in edt.res.
!--------------------------------------------------------------------
        if (doing_edt) then
          if (file_exist('INPUT/edt.res')) Then
            unit = open_restart_file ('INPUT/edt.res', 'read')
            read (unit, iostat=io, err=143) vers, vers2

!----------------------------------------------------------------------
!    if an i/o error does not occur, then the edt.res file 
!    contains the variable lw_tendency. rewind and read. close file 
!    upon completion.
!----------------------------------------------------------------------
143         continue
            if (io == 0) then
              call error_mesg ('physics_driver_mod',  &
                'reading pre-version number edt.res file, &
                 &reading  lw_tendency', NOTE)
              rewind (unit)
              call read_data (unit, lw_tendency)
              call close_file (unit)

!---------------------------------------------------------------------
!    if the eor was reached (io /= 0), then the edt.res file 
!    does not contain the lw_tendency data.  set values to 0.0 and
!    put a note in the output file.
!---------------------------------------------------------------------
            else
              lw_tendency = 0.0
              call error_mesg ('physics_driver_mod',  &
                  'neither edt.res nor physics_driver.res &
                   &contain the lw_tendency data, setting it to 0.0', &
                                                                NOTE)
            endif

!----------------------------------------------------------------------
!    if edt.res is not present, set lw_tendency to 0.0.
!----------------------------------------------------------------------
          else
            lw_tendency = 0.0
            call error_mesg ('physics_driver_mod',  &
               'setting lw_tendency to zero, no edt.res &
               &file present, data not in physics_driver.res', NOTE)
          endif
        endif

!--------------------------------------------------------------------
!    check if the lw_tendency data is in entrain.res. only 1 form of
!    entrain.res has ever existed, containing only the lw_tendency
!    variable, so it can be read without further checking.
!--------------------------------------------------------------------
        if (doing_entrain) then
          if (file_exist('INPUT/entrain.res')) Then
            unit = open_restart_file ('INPUT/entrain.res', 'read')
            call read_data (unit, lw_tendency)
            call close_file (unit)

!----------------------------------------------------------------------
!    if entrain.res is not present, set lw_tendency to 0.0.
!----------------------------------------------------------------------
          else
            lw_tendency = 0.0
            call error_mesg ('physics_driver_mod',  &
              'setting lw_tendency to zero, no entrain.res &
               &file present, data not in physics_driver.res', NOTE)
          endif
        endif
      endif  ! (.not. success)


!----------------------------------------------------------------------


 end subroutine read_restart_file     

!#####################################################################
! <SUBROUTINE NAME="read_restart_nc">
!  <OVERVIEW>
!    read_restart_nc will read the physics_driver.res file and process
!    its contents. if no restart data can be found, the module variables
!    are initialized to flag values.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_restart_nc will read the physics_driver.res file and process
!    its contents. if no restart data can be found, the module variables
!    are initialized to flag values.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_restart_nc
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_restart_nc

!---------------------------------------------------------------------
!    read_restart_file will read the physics_driver.res file and process
!    its contents. if no restart data can be found, the module variables
!    are initialized to flag values.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real  :: was_doing_strat=0., was_doing_edt=0., was_doing_entrain=0.
      logical  :: field_found
      integer, dimension(4)  :: siz
      character(len=64) :: fname = 'INPUT/physics_driver.res.nc'
      real, dimension(size(convect,1), size(convect,2)) :: r_convect
!--------------------------------------------------------------------
!   local variables:
!
!      vers              restart version number if that is contained in 
!                        file; otherwise the first word of first data 
!                        record of file
!      was_doing_strat   logical indicating if strat_cloud_mod was 
!                        active in job which wrote restart file
!      was_doing_edt     logical indicating if edt_mod was active
!                        in job which wrote restart file
!      was_doing_entrain logical indicating if entrain_mod was active
!                        in job which wrote restart file
!
!---------------------------------------------------------------------      
                    
      if(file_exist(fname)) then
         if(mpp_pe() == mpp_root_pe()) call mpp_error ('physics_driver_mod', &
            'Reading NetCDF formatted restart file: INPUT/physics_driver.res.nc', NOTE)
         call read_data(fname, 'vers', vers, no_domain=.true.)
         call read_data(fname, 'doing_strat', was_doing_strat, no_domain=.true.)
         call read_data(fname, 'doing_edt', was_doing_edt, no_domain=.true.)
         call read_data(fname, 'doing_entrain', was_doing_entrain, no_domain=.true.)

!---------------------------------------------------------------------
!    read the contribution to diffusion coefficient from cumulus
!    momentum transport.
!---------------------------------------------------------------------
         call read_data (fname, 'diff_cu_mo', diff_cu_mo)
         
!---------------------------------------------------------------------
!    pbl top is present in file versions 2 and up. if not present,
!    set a flag.
!---------------------------------------------------------------------
         call read_data (fname, 'pbltop', pbltop)
         call field_size (fname, 'cush', siz, field_found = field_found)
         if (field_found) then
           call read_data (fname, 'cush', cush) !miz
           call read_data (fname, 'cbmf', cbmf) !miz
         else
           cush       = -1.  !miz
           cbmf       = 0.0  !miz
         endif

!---------------------------------------------------------------------
!    the temperature and momentum diffusion coefficients are present
!    beginning with v3. if not prsent, set to 0.0.
!---------------------------------------------------------------------
         call read_data (fname, 'diff_t', diff_t)
         call read_data (fname, 'diff_m', diff_m)

!---------------------------------------------------------------------
!    a flag indicating columns in which convection is occurring is
!    present beginning with v4. if not present, set it to .false.
!---------------------------------------------------------------------
         convect = .false.
         r_convect = 0.
         call read_data (fname, 'convect', r_convect)
         where(r_convect .GT. 0.) 
            convect = .true.
         end where
         
!---------------------------------------------------------------------
!    donner_deep cell and meso cloud variables may be present in 
!    versions 6 onward, if donner_deep_mod
!    was active in the job writing the .res file.
!---------------------------------------------------------------------
            if (doing_donner) then
           call field_size (fname, 'cell_cloud_frac', siz, &
                            field_found = field_found)

        if (field_found) then
         call read_data (fname, 'cell_cloud_frac', cell_cld_frac)
         call read_data (fname, 'cell_liquid_amt', cell_liq_amt )
         call read_data (fname, 'cell_liquid_size', cell_liq_size)
         call read_data (fname, 'cell_ice_amt', cell_ice_amt )
         call read_data (fname, 'cell_ice_size', cell_ice_size)
         call read_data (fname, 'meso_cloud_frac', meso_cld_frac)
         call read_data (fname, 'meso_liquid_amt', meso_liq_amt )
         call read_data (fname, 'meso_liquid_size', meso_liq_size)
         call read_data (fname, 'meso_ice_amt', meso_ice_amt )
         call read_data (fname, 'meso_ice_size', meso_ice_size)
         call read_data (fname, 'nsum', nsum_out)                 

!---------------------------------------------------------------------
!    if donner_deep_mod was not active in the job which wrote the 
!    restart file but it is active in the current job, initialize
!    these variables and put a message in the output file.  
!---------------------------------------------------------------------
          else
        cell_cld_frac = 0.
        cell_liq_amt  = 0.
        cell_liq_size = 0.
        cell_ice_amt  = 0.
        cell_ice_size = 0.
        meso_cld_frac = 0.
        meso_liq_amt  = 0.
        meso_liq_size = 0.
        meso_ice_amt  = 0.
        meso_ice_size = 0.
        nsum_out = 1
              call error_mesg ('physics_driver_mod', &
              ' initializing donner cloud  variables, since they are not present'//&
                            ' in physics_driver.res.nc file', NOTE)
            endif  ! (field_found)       
     endif  ! (doing_donner)

!---------------------------------------------------------------------
!    lsc cloud variables will be present in versions 8 onward.
!---------------------------------------------------------------------
      call field_size (fname, 'lsc_cloud_area', siz, &
                             field_found = field_found)
      if (field_found) then

        call read_data (fname, 'lsc_cloud_area', lsc_cloud_area)
        call read_data (fname, 'lsc_liquid', lsc_liquid )
        call read_data (fname, 'lsc_ice', lsc_ice )
        call read_data (fname, 'lsc_droplet_number', lsc_droplet_number)

!---------------------------------------------------------------------
!    if fields are not present, set a flag so that values from the
!    tracer array are supplied to the radiation package, and
!    put a message in the output file.  
!---------------------------------------------------------------------
      else
        lsc_cloud_area = -99.
        lsc_liquid  =  -99.
        lsc_ice  = -99.
        lsc_droplet_number = -99.
        call error_mesg ('physics_driver_mod', &
             ' initial radiation call will use lsc tracer fields; &
               &thus the lsc cloud area field may not be compatible &
               &with the areas assigned to convective clouds', NOTE)
      endif  ! (field_found)       
                                  
!---------------------------------------------------------------------
!    uw_conv cloud variables may be present in 
!    versions 7 onward, if uw_conv_mod
!    was active in the job writing the .res file.
!---------------------------------------------------------------------
          if (doing_uw_conv) then
            call field_size (fname, 'shallow_cloud_area', siz, &
                             field_found = field_found)
 
            if (field_found) then
            call read_data (fname, 'shallow_cloud_area', shallow_cloud_area)
          call read_data (fname, 'shallow_liquid', shallow_liquid )
          call read_data (fname, 'shallow_ice', shallow_ice )
         call read_data (fname, 'shallow_droplet_number', shallow_droplet_number)

!---------------------------------------------------------------------
!    if uw_conv_mod was not active in the job which wrote the 
!    restart file but it is active in the current job, initialize
!    these variables and put a message in the output file.  
!---------------------------------------------------------------------
        else
         shallow_cloud_area = 0.
         shallow_liquid  = 0.
         shallow_ice  = 0.
        shallow_droplet_number = 0.
        call error_mesg ('physics_driver_mod', &
             ' initializing uw_conv cloud  variables, since they are not present'//&
                            ' in physics_driver.res.nc file', NOTE)
       endif  ! (field_found)       
     endif  ! (doing_uw_conv)

!---------------------------------------------------------------------
!    radturbten may be present in versions 5 onward, if strat_cloud_mod
!    was active in the job writing the .res file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    if radturbten was written, read it.
!--------------------------------------------------------------------
          if (was_doing_strat .GT. 0.) then
            call read_data (fname, 'radturbten', radturbten)

!---------------------------------------------------------------------
!    if strat_cloud_mod was not active in the job which wrote the 
!    restart file but it is active in the current job, initialize
!    radturbten to 0.0 and put a message in the output file.  
!---------------------------------------------------------------------
          else
            if (doing_strat()) then
              radturbten = 0.0
              call error_mesg ('physics_driver_mod', &
              ' initializing radturbten to 0.0, since it not present'//&
                            ' in physics_driver.res.nc file', NOTE)
            endif
          endif

!--------------------------------------------------------------------
!    if lw_tendency was written, read it.
!--------------------------------------------------------------------
          if (was_doing_edt .GT. 0. .or. was_doing_entrain .GT. 0.) then
            call read_data (fname, 'lw_tendency', lw_tendency)

!---------------------------------------------------------------------
!    if edt_mod or entrain_mod was not active in the job which wrote the
!    restart file but it is active in the current job, initialize
!    lw_tendency to 0.0 and put a message in the output file.  
!---------------------------------------------------------------------
          else
            if (doing_edt .or. doing_entrain ) then
              lw_tendency = 0.0
              call error_mesg ('physics_driver_mod', &
             ' initializing lw_tendency to 0.0, since it not present'//&
                  ' in physics_driver.res.nc file', NOTE)
            endif
          endif
       endif
!----------------------------------------------------------------------
     
     
end subroutine read_restart_nc


!#####################################################################
! <SUBROUTINE NAME="check_args">
!  <OVERVIEW>
!    check_args determines if the input arrays to physics_driver_down
!    are of a consistent size.
!  </OVERVIEW>
!  <DESCRIPTION>
!    check_args determines if the input arrays to physics_driver_down
!    are of a consistent size.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call check_args (lat, lon, area, p_half, p_full, z_half, z_full,&
!                        u, v, t, q, r, um, vm, tm, qm, rm,             &
!                        udt, vdt, tdt, qdt, rdt, mask, kbot)
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   array of model latitudes at model points [radians]
!  </IN>
!  <IN NAME="lon" TYPE="real">
!   array of model longitudes at model points [radians]
!  </IN>
!  <IN NAME="area" TYPE="real">
!   grid box area - current not used
!  </IN>
!  <IN NAME="p_half" TYPE="real">
!   pressure at model interface levels (offset from t,q,u,v,r)
!  </IN>
!  <IN NAME="p_full" TPYE="real">
!   pressure at full levels
!  </IN>
!  <IN NAME="z_half" TYPE="real">
!   height at model interface levels
!  </IN>
!  <IN NAME="z_full" TPYE="real">
!   height at full levels
!  </IN>
!  <IN NAME="u" TYPE="real">
!   zonal wind at current time step
!  </IN>
!  <IN NAME="v" TYPE="real">
!   meridional wind at current time step
!  </IN>
!  <IN NAME="t" TYPE="real">
!   temperature at current time step
!  </IN>
!  <IN NAME="q" TYPE="real">
!   specific humidity at current time step
!  </IN>
!  <IN NAME="r" TPYE="real">
!   multiple 3d tracer fields at current time step
!  </IN>
!  <IN NAME="um" TYPE="real">
!   zonal wind at previous time step
!  </IN>
!  <IN NAME="vm" TYPE="real">
!   meridional wind at previous time step
!  </IN>
!  <IN NAME="tm" TYPE="real">
!   temperature at previous time step
!  </IN>
!  <IN NAME="qm" TYPE="real">
!   specific humidity at previous time step
!  </IN>
!  <IN NAME="rm" TPYE="real">
!   multiple 3d tracer fields at previous time step
!  </IN>
!  <IN NAME="udt" TYPE="real">
!   zonal wind tendency
!  </IN>
!  <IN NAME="vdt" TYPE="real">
!   meridional wind tendency
!  </IN>
!  <IN NAME="tdt" TYPE="real">
!   temperature tendency
!  </IN>
!  <IN NAME="qdt" TYPE="real">
!   moisture tracer tendencies
!  </IN>
!  <IN NAME="rdt" TYPE="real">
!   multiple tracer tendencies
!  </IN>
!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! </SUBROUTINE>
!
subroutine check_args (lat, lon, area, p_half, p_full, z_half, z_full,&
                        u, v, t, q, r, um, vm, tm, qm, rm,             &
                        udt, vdt, tdt, qdt, rdt, mask, kbot)

!----------------------------------------------------------------------
!    check_args determines if the input arrays to physics_driver_down
!    are of a consistent size.
!-----------------------------------------------------------------------

real,    dimension(:,:),    intent(in)          :: lat, lon, area
real,    dimension(:,:,:),  intent(in)          :: p_half, p_full,   &
                                                   z_half, z_full,   &
                                                   u, v, t, q, um, vm, &
                                                   tm, qm
real,    dimension(:,:,:,:),intent(in)          :: r, rm
real,    dimension(:,:,:),  intent(in)          :: udt, vdt, tdt, qdt
real,    dimension(:,:,:,:),intent(in)          :: rdt
real,    dimension(:,:,:),  intent(in),optional :: mask
integer, dimension(:,:),    intent(in),optional :: kbot

!-----------------------------------------------------------------------
!   intent(in) variables:
!
!      lat            latitude of model points [ radians ]
!      lon            longitude of model points [ radians ]
!      area           grid box area - currently not used [ m**2 ]
!      p_half         pressure at half levels (offset from t,q,u,v,r)
!                     [ Pa ]
!      p_full         pressure at full levels [ Pa }
!      z_half         height at half levels [ m ]
!      z_full         height at full levels [ m ]
!      u              zonal wind at current time step [ m / s ]
!      v              meridional wind at current time step [ m / s ]
!      t              temperature at current time step [ deg k ]
!      q              specific humidity at current time step  kg / kg ]
!      r              multiple 3d tracer fields at current time step
!      um,vm          zonal and meridional wind at previous time step
!      tm,qm          temperature and specific humidity at previous 
!                     time step
!      rm             multiple 3d tracer fields at previous time step
!      udt            zonal wind tendency [ m / s**2 ]
!      vdt            meridional wind tendency [ m / s**2 ]
!      tdt            temperature tendency [ deg k / sec ]
!      qdt            specific humidity tendency 
!                     [  kg vapor / kg air / sec ]
!      rdt            multiple tracer tendencies [ unit / unit / sec ]
!
!   intent(in), optional:
!
!       mask        mask that designates which levels do not have data
!                   present (i.e., below ground); 0.=no data, 1.=data
!       kbot        lowest level which has data
!                   note:  both mask and kbot must be present together.
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      integer ::  id, jd, kd  ! model dimensions on the processor  
      integer ::  ierr        ! error flag

!--------------------------------------------------------------------
!    define the sizes that the arrays should be.
!--------------------------------------------------------------------
      id = size(u,1) 
      jd = size(u,2) 
      kd = size(u,3) 

!--------------------------------------------------------------------
!    check the dimensions of each input array. if they are incompat-
!    ible in size with the standard, the error flag is set to so
!    indicate.
!--------------------------------------------------------------------
      ierr = 0
      ierr = ierr + check_dim (lat, 'lat',  id,jd)
      ierr = ierr + check_dim (lon, 'lon',  id,jd)
      ierr = ierr + check_dim (area,'area', id,jd)

      ierr = ierr + check_dim (p_half,'p_half', id,jd,kd+1)
      ierr = ierr + check_dim (p_full,'p_full', id,jd,kd)
      ierr = ierr + check_dim (z_half,'z_half', id,jd,kd+1)
      ierr = ierr + check_dim (z_full,'z_full', id,jd,kd)

      ierr = ierr + check_dim (u, 'u',  id,jd,kd)
      ierr = ierr + check_dim (v, 'v',  id,jd,kd)
      ierr = ierr + check_dim (t, 't',  id,jd,kd)
      ierr = ierr + check_dim (q, 'q',  id,jd,kd)
      ierr = ierr + check_dim (um,'um', id,jd,kd)
      ierr = ierr + check_dim (vm,'vm', id,jd,kd)
      ierr = ierr + check_dim (tm,'tm', id,jd,kd)
      ierr = ierr + check_dim (qm,'qm', id,jd,kd)

      ierr = ierr + check_dim (udt,'udt', id,jd,kd)
      ierr = ierr + check_dim (vdt,'vdt', id,jd,kd)
      ierr = ierr + check_dim (tdt,'tdt', id,jd,kd)
      ierr = ierr + check_dim (qdt,'qdt', id,jd,kd)

      if (nt > 0) then
        ierr = ierr + check_dim (r,  'r',   id,jd,kd,nt)
        ierr = ierr + check_dim (rm, 'rm',  id,jd,kd,nt)
      endif
      if (ntp > 0) then
        ierr = ierr + check_dim (rdt,'rdt', id,jd,kd,ntp)
      endif

!--------------------------------------------------------------------
!    if any problems were detected, exit with an error message.
!--------------------------------------------------------------------
      if (ierr > 0) then
        call error_mesg ('physics_driver_mod', 'bad dimensions', FATAL)
      endif

!-----------------------------------------------------------------------


      end subroutine check_args


!#######################################################################
! <FUNCTION NAME="check_dim_2d">
!  <OVERVIEW>
!    check_dim_2d compares the size of two-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!  </OVERVIEW>
!  <DESCRIPTION>
!    check_dim_2d compares the size of two-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!  </DESCRIPTION>
!  <TEMPLATE>
!    check_dim_2d (data,name,id,jd) result (ierr)
!  </TEMPLATE>
!  <IN NAME="data" TYPE="real">
!   array of data to be checked
!  </IN>
!  <IN NAME="name" TYPE="character">
!   name associated with array to be checked
!  </IN>
!  <IN NAME="id, jd" TYPE="integer">
!   expected i and j dimensions
!  </IN>
! </FUNCTION>
!
function check_dim_2d (data,name,id,jd) result (ierr)

!--------------------------------------------------------------------
!    check_dim_2d compares the size of two-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!--------------------------------------------------------------------

real,    intent(in), dimension(:,:) :: data
character(len=*), intent(in)        :: name
integer, intent(in)                 :: id, jd
integer                             :: ierr

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     data        array to be checked
!     name        name associated with array to be checked
!     id, jd      expected i and j dimensions
!     
!  result variable:
!
!     ierr        set to 0 if ok, otherwise is a count of the number
!                 of incompatible dimensions
!
!--------------------------------------------------------------------

      ierr = 0
      if (size(data,1) /= id) then
        call error_mesg ('physics_driver_mod',  &
             'dimension 1 of argument ' //  &
              name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif
      if (size(data,2) /= jd) then
           call error_mesg ('physics_driver_mod',  &
                'dimension 2 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
           ierr = ierr + 1
      endif

!----------------------------------------------------------------------

      end function check_dim_2d

!#######################################################################
! <FUNCTION NAME="check_dim_3d">
!  <OVERVIEW>
!    check_dim_3d compares the size of three-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!  </OVERVIEW>
!  <DESCRIPTION>
!    check_dim_3d compares the size of three-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!  </DESCRIPTION>
!  <TEMPLATE>
!    check_dim_3d (data,name,id,jd, kd) result (ierr)
!  </TEMPLATE>
!  <IN NAME="data" TYPE="real">
!   array of data to be checked
!  </IN>
!  <IN NAME="name" TYPE="character">
!   name associated with array to be checked
!  </IN>
!  <IN NAME="id, jd, kd" TYPE="integer">
!   expected i, j and k dimensions
!  </IN>
! </FUNCTION>
!
function check_dim_3d (data,name,id,jd,kd) result (ierr)

!--------------------------------------------------------------------
!    check_dim_3d compares the size of thr1eedimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!--------------------------------------------------------------------

real,    intent(in), dimension(:,:,:) :: data
character(len=*), intent(in)          :: name
integer, intent(in)                   :: id, jd, kd
integer  ierr

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     data        array to be checked
!     name        name associated with array to be checked
!     id, jd,kd   expected i, j and k dimensions
!     
!  result variable:
!
!     ierr        set to 0 if ok, otherwise is a count of the number
!                 of incompatible dimensions
!
!--------------------------------------------------------------------

      ierr = 0
      if (size(data,1) /= id) then
        call error_mesg ('physics_driver_mod',  &
                'dimension 1 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif
      if (size(data,2) /= jd) then
        call error_mesg ('physics_driver_mod',  &
              'dimension 2 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif
      if (size(data,3) /= kd) then
        call error_mesg ('physics_driver_mod',  &
                'dimension 3 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif

!---------------------------------------------------------------------


      end function check_dim_3d


!#######################################################################
! <FUNCTION NAME="check_dim_4d">
!  <OVERVIEW>
!    check_dim_4d compares the size of four-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!  </OVERVIEW>
!  <DESCRIPTION>
!    check_dim_4d compares the size of four-dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!  </DESCRIPTION>
!  <TEMPLATE>
!    check_dim_4d (data,name,id,jd, kd, nt) result (ierr)
!  </TEMPLATE>
!  <IN NAME="data" TYPE="real">
!   array of data to be checked
!  </IN>
!  <IN NAME="name" TYPE="character">
!   name associated with array to be checked
!  </IN>
!  <IN NAME="id, jd, kd, nt" TYPE="integer">
!   expected i, j, k and 4th dimensions
!  </IN>
! </FUNCTION>
!
function check_dim_4d (data,name,id,jd,kd,nt) result (ierr)

!--------------------------------------------------------------------
!    check_dim_4d compares the size of four dimensional input arrays
!    with supplied expected dimensions and returns an error if any
!    inconsistency is found.
!--------------------------------------------------------------------
real,    intent(in), dimension(:,:,:,:) :: data
character(len=*), intent(in)            :: name
integer, intent(in)                     :: id, jd, kd, nt
integer                                 :: ierr

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     data          array to be checked
!     name          name associated with array to be checked
!     id,jd,kd,nt   expected i, j and k dimensions
!     
!  result variable:
!
!     ierr          set to 0 if ok, otherwise is a count of the number
!                   of incompatible dimensions
!
!--------------------------------------------------------------------

      ierr = 0
      if (size(data,1) /= id) then
        call error_mesg ('physics_driver_mod',  &
                'dimension 1 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif
      if (size(data,2) /= jd) then
        call error_mesg ('physics_driver_mod',  &
                'dimension 2 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif
      if (size(data,3) /= kd) then
        call error_mesg ('physics_driver_mod',  &
                'dimension 3 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif
      if (size(data,4) /= nt) then
        call error_mesg ('physics_driver_mod',  &
                'dimension 4 of argument ' //  &
                name(1:len_trim(name)) // ' has wrong size.', NOTE)
        ierr = ierr + 1
      endif

!---------------------------------------------------------------------


      end function check_dim_4d



!#######################################################################
 

 
                end module physics_driver_mod


                module radiation_driver_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="">
!  
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    radiation_driver_mod is the interface between physics_driver_mod
!    and a specific radiation parameterization, currently either the
!    original_fms_rad or sea_esf_rad radiation package. it provides 
!    radiative heating rates, boundary radiative fluxes, and any other 
!    radiation package output fields to other component models of the
!    modeling system.
! </OVERVIEW>
! <DESCRIPTION>
! The following modules are called from this driver module:
!
!   1) astronomy
!
!   2) cloud properties
!
!   3) prescribed zonal ozone
!
!   4) longwave and shortwave radiation driver
! </DESCRIPTION>
!  <DIAGFIELDS>
!  Diagnostic fields may be output to a netcdf file by specifying the
!  module name radiation and the desired field names (given below)
!  in file diag_table. See the documentation for diag_manager.
!  
!  Diagnostic fields for module name: radiation
!  
!     field name      field description
!     ----------      -----------------
!  
!     alb_sfc         surface albedo (percent)
!     coszen          cosine of the solar zenith angle
!  
!     tdt_sw          temperature tendency for SW radiation (deg_K/sec)
!     tdt_lw          Temperature tendency for LW radiation (deg_K/sec)
!     swdn_toa        SW flux down at TOA (watts/m2)
!     swup_toa        SW flux up at TOA (watts/m2)
!     olr             outgoing longwave radiation (watts/m2)
!     swup_sfc        SW flux up at surface (watts/m2)
!     swdn_sfc        SW flux down at surface (watts/m2)
!     lwup_sfc        LW flux up at surface  (watts/m2)
!     lwdn_sfc        LW flux down at surface (watts/m2)
!  
!  NOTE: When namelist variable do_clear_sky_pass = .true. an additional clear sky
!        diagnostic fields may be saved.
!  
!     tdt_sw_clr      clear sky temperature tendency for SW radiation (deg_K/sec)
!     tdt_lw_clr      clear sky Temperature tendency for LW radiation (deg_K/sec)
!     swdn_toa_clr    clear sky SW flux down at TOA (watts/m2)
!     swup_toa_clr    clear sky SW flux up at TOA (watts/m2)
!     olr_clr         clear sky outgoing longwave radiation (watts/m2)
!     swup_sfc_clr    clear sky SW flux up at surface (watts/m2)
!     swdn_sfc_clr    clear sky SW flux down at surface (watts/m2)
!     lwup_sfc_clr    clear sky LW flux up at surface  (watts/m2)
!     lwdn_sfc_clr    clear sky LW flux down at surface (watts/m2)
!  </DIAGFIELDS>

! <INFO>

!   <REFERENCE>  For a specific list of radiation references see the
!     longwave and shortwave documentation.          </REFERENCE>
!   <COMPILER NAME="">     </COMPILER>
!   <PRECOMP FLAG="">      </PRECOMP>
!   <LOADER FLAG="">       </LOADER>
!   <TESTPROGRAM NAME="">  </TESTPROGRAM>
!   <BUG>
!For some of the diagnostics fields that represent fractional amounts,
!    such as reflectivity and absorptivity, the units are incorrectly
!    given as percent.
!</BUG>
!   <NOTE> 
!CHANGE HISTORY
!changes prior to 1/24/2000
!
!  * Modified the radiation alarm. 
!    The module can now be stopped/started on a time step that is not the
!    radiation time step.
!
!  * Modified the radiation restart format.
!    Added a version number and radiation alarm information.
!
!  * Fixed a bug that occurred when namelist variable do_average = true.
!    An addition averaging variable was added for array "solar". 
!    This averaging information was also added to the restart file.
!    ***NOTE: As of this code, this namelist variable has been removed.***
!
!  * Removed the initialization for the astronomy package. This is now done
!    by the astronomy namelist.
!
!changes prior to 10/4/1999
!
!  * MPP version created. Changes to open_file and error_mesg arguments, 
!    Fortran write statements to standard output only on PE 0, Fortran close
!    statement changed to call close_file, and Fortran read/write statements
!    for restart files changed to call read_data/write_data.
!
!  * Implementation of the new MPP diagnostics package. This required major
!    changes to the diagnostic interface and the manner in which diagnostics
!    quantities are selected.
!
!  * There were no changes made that would cause answers to changes.
!
!changes prior to 5/26/1999
!
!  * added namelist variables for modifying the co2 mixing ratio.
!
!  * changed the units of namelist variable solar_constant from ly/min to watts/m2.
!
!   </NOTE>
!   <FUTURE>               </FUTURE>

! </INFO>
!   shared modules:

use mpp_mod,               only: input_nml_file
use fms_mod,               only: fms_init, mpp_clock_id, &
                                 mpp_clock_begin, mpp_clock_end, &
                                 CLOCK_MODULE,  field_exist, &
                                 mpp_pe, mpp_root_pe, &
                                 open_namelist_file, stdlog, &
                                 file_exist, FATAL, WARNING, NOTE, &
                                 close_file, read_data, write_data, &
                                 write_version_number, check_nml_error,&
                                 error_mesg, open_restart_file, &
                                 read_data, mpp_error
use fms_io_mod,            only: get_restart_io_mode, &
                                 register_restart_field, restart_file_type, &
                                 save_restart, get_mosaic_tile_file
use diag_manager_mod,      only: register_diag_field, send_data, &
                                 diag_manager_init, get_base_time
use time_manager_mod,      only: time_type, set_date, set_time,  &
                                 get_time,    operator(+),       &
                                 print_date, time_manager_init, &
                                 assignment(=), &
                                 operator(-), operator(/=), get_date,&
                                 operator(<), operator(>=), operator(>)
use sat_vapor_pres_mod,    only: sat_vapor_pres_init, compute_qs
use constants_mod,         only: constants_init, RDGAS, RVGAS,   &
                                 STEFAN, GRAV, SECONDS_PER_DAY,  &
                                 RADIAN, diffac
use data_override_mod,     only: data_override

! shared radiation package modules:

use rad_utilities_mod,     only: radiation_control_type, Rad_control, &
                                 radiative_gases_type, &
                                 check_derived_types, &
                                 cldrad_properties_type, &
                                 astronomy_type, surface_type, &
                                 cld_specification_type, &
                                 aerosol_diagnostics_type, &
                                 atmos_input_type, rad_utilities_init,&
                                 aerosol_properties_type, aerosol_type,&
                                 sw_output_type, lw_output_type, &
                                 rad_output_type, microphysics_type, &
                                 shortwave_control_type, Sw_control, &
                                 Lw_control, &
                                 fsrad_output_type, &
                                 astronomy_inp_type, &
                                 cloudrad_control_type, Cldrad_control,&
                                 rad_utilities_end
use esfsw_parameters_mod,  only: Solar_spect, esfsw_parameters_init  

!  physics support modules:

use diag_integral_mod,     only: diag_integral_init, &
                                 diag_integral_field_init, &
                                 sum_diag_integral_field
use astronomy_mod,         only: astronomy_init, annual_mean_solar, &
                                 daily_mean_solar, diurnal_solar, &
                                 astronomy_end

!  component modules:

use original_fms_rad_mod,  only: original_fms_rad_init,  &
                                 original_fms_rad, &
                                 original_fms_rad_end
use sea_esf_rad_mod,       only: sea_esf_rad_init, sea_esf_rad, &
                                 sea_esf_rad_time_vary,  &
                                 sea_esf_rad_endts, & 
                                 sea_esf_rad_end
use rad_output_file_mod,   only: rad_output_file_init, &
                                 write_rad_output_file,    &
                                 rad_output_file_end
use cloudrad_package_mod,  only: cloudrad_package_init, &
                                 cloud_radiative_properties, &
                                 cldrad_props_dealloc, &
                                 cloudrad_package_end
use cloudrad_diagnostics_mod,      &
                           only: model_micro_dealloc, &
                                 obtain_cloud_tau_and_em, &
                                 modis_yim, modis_cmip
use microphys_rad_mod,     only: isccp_microphys_sw_driver, &
                                 isccp_microphys_lw_driver
use aerosolrad_package_mod, only: aerosolrad_package_init,    &
                                  aerosolrad_package_alloc, &
                                  aerosolrad_package_endts, &
                                  aerosolrad_package_time_vary, &
                                  aerosol_radiative_properties, &
                                  aerosolrad_package_end
use field_manager_mod,     only: MODEL_ATMOS
use tracer_manager_mod,    only: get_tracer_index, NO_TRACER

!--------------------------------------------------------------------

implicit none 
private 

!----------------------------------------------------------------------
!    radiation_driver_mod is the interface between physics_driver_mod
!    and a specific radiation parameterization, currently either the
!    original_fms_rad or sea_esf_rad radiation package. it provides 
!    radiative heating rates, boundary radiative fluxes, and any other 
!    radiation package output fields to other component models of the
!    modeling system.
!----------------------------------------------------------------------


!----------------------------------------------------------------------
!------------ version number for this module --------------------------

character(len=128) :: version = '$Id: radiation_driver.F90,v 18.0.2.1.2.2.2.1 2010/08/30 20:33:35 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!------ interfaces -----
! <PUBLIC>
!use radiation_driver_mod [,only: radiation_driver_init,
                                   
!                                 radiation_driver,
!                                 radiation_driver_end]
!   radiation_driver_init
!       Must be called once before subroutine radiation_driver to
!       initialize the module (read namelist input and restart file).
!       Also calls the initialization routines for other modules used.
!   radiation_driver
!       Called every time step (not on the radiation time step)
!       to compute the longwave and shortwave radiative tendencies.
!   radiation_driver_end
!       Called once at the end of a model run to terminate the module (write
!       a restart file). Also calls the termination routines for other
!       modules used.
!Notes:
! 1) A namelist interface controls runtime options.
! 3) A restart file radiation_driver.res is generated by this module.
!</PUBLIC>

public    radiation_driver_init, radiation_driver, return_cosp_inputs, &
          radiation_driver_time_vary, radiation_driver_endts, &
          define_rad_times, define_atmos_input_fields,  &
          define_surface, surface_dealloc, atmos_input_dealloc, &
          microphys_dealloc, &
          radiation_driver_end, radiation_driver_restart

private  & 

! called from radiation_driver_init:
          read_restart_file, initialize_diagnostic_integrals,   &
          diag_field_init, read_restart_nc, &

! called from radiation_driver_end:
          write_restart_file, write_restart_nc, &

! called from radiation_driver:
          obtain_astronomy_variables, radiation_calc,    &
          update_rad_fields, produce_radiation_diagnostics,  &
          deallocate_arrays, &
          flux_trop_calc, &

! called from define_atmos_input_fields:
          calculate_auxiliary_variables


!-----------------------------------------------------------------------
!------- namelist ---------
logical :: using_restart_file = .true. ! if set to .false, restart file
                                       ! will NOT be written by this 
                                       ! module; this will not affect
                                       ! answers as long as job is 
                                       ! restarted on a radiation
                                       ! timestep
integer ::  rad_time_step = 0         !  radiative time step in seconds


integer ::  sw_rad_time_step = 0      !  radiative time step in seconds
logical :: use_single_lw_sw_ts = .true. ! lw and sw are integrated
                                        ! using rad_time_step ? if 
                                       ! false, then lw uses 
                                       ! rad_time_step, sw uses 
                                       ! sw_rad_time_step
logical ::  use_hires_coszen = .false. ! calculate for multiple zen angs
                                       ! within sw calc?
integer :: nzens_per_sw_rad_timestep = 1  !  number of cloudy
                                          ! sw calcs done on a sw rad 
                                          ! timestep
logical :: allow_nonrepro_across_restarts = .false.
                                      !  when set true, allows the 
                                      !  use_hires_coszen case to
                                      !  restart on non-radiation steps,
                                      ! with solution dependent on 
                                      ! restart interval
                                      ! (temporary until needed vari-
                                      ! ables added to restart file)
logical ::  do_clear_sky_pass= .false.!  are the clear-sky radiation
                                      !  diagnostics to be calculated ?
character(len=24) ::    &
            zenith_spec = '      '    !  string defining how zenith 
                                      !  angle is computed. acceptable
                                      !  values: 'daily_mean', 'annual_
                                      !  mean', 'diurnally_varying'
character(len=16) ::   &
                rad_package='sea_esf' !  string defining the radiation
                                      !  package being used. acceptable
                                      !  values : 'sea_esf', 
                                      !  'original_fms'     
logical ::    &
         calc_hemi_integrals = .false.!  are hemispheric integrals 
                                      !  desired ? 
logical ::     &
        all_step_diagnostics = .false.!  are lw and sw radiative bdy
                                      !  fluxes and atmospheric heating 
                                      !  rates to be output on physics 
                                      !  steps ?
logical ::     &
         renormalize_sw_fluxes=.false.!  should sw fluxes and the zenith
                                      !  angle be renormalized on each 
                                      !  timestep because of the 
                                      !  movement of earth wrt the sun ?
integer, dimension(6) ::    &
    rad_date = (/ 0, 0, 0, 0, 0, 0 /) !  fixed date for which radiation
                                      !  is to be valid (applies to
                                      !  solar info, ozone, clouds)
                                      !  [yr, mo, day, hr, min, sec]
logical  ::  &
         all_level_radiation = .true. !  is radiation to be calculated 
                                      !  at all model levels ?
integer ::    &
          topmost_radiation_level=-99 !  if all_level_radiation is 
                                      !  false., this is the lowest
                                      !  model index at which radiation
                                      !  is calculated
logical ::    &
          drop_upper_levels = .false. !  if all_level_radiation is false
                                      !  and drop_upper_levels is true,
                                      !  radiation will be calculated
                                      !  at all model levels from
                                      !  topmost_radiation_level to the
                                      !  surface
logical ::  &
         all_column_radiation = .true.!  is radiation to be calculated
                                      !  in all model columns ?
logical :: rsd=.false.                !  (repeat same day) - call 
                                      !  radiation for the specified 
                                      !  rad_date (yr,mo,day), but run 
                                      !  through the diurnal cycle (hr,
                                      !  min,sec)

logical :: use_mixing_ratio = .false. !  assumes q is mixing ratio
                                      !  rather than specific humidity
real    :: solar_constant = 1365.0    !  annual mean solar flux at top 
                                      !  of atmosphere [ W/(m**2) ]
logical :: doing_data_override = .false.  
                                      !  input fields to the radiation
                                      !  package are being overriden
                                      !  using data_override_mod ?
logical :: overriding_temps = .false. !  temperature and ts fields are
                                      !  overriden ?
logical :: overriding_sphum = .false. !  specific humidity field is
                                      !  overriden ?
logical :: overriding_clouds = .false.!  cloud specification fields are
                                      !  overriden ?
logical :: overriding_albedo = .false.!  surface albedo field is
                                      !  overriden ?
logical :: overriding_aerosol = .false.
                                      !  aerosol fields are overriden ?
logical :: use_co2_tracer_field = .false.
                                      !  obtain co2 field for use by 
                                      !  radiation package from co2
                                      !  tracer field ?
logical :: do_swaerosol_forcing = .false.
                                      !  calculating aerosol forcing in
                                      !  shortwave ?
logical :: do_lwaerosol_forcing = .false.
                                      !  calculating aerosol forcing in
                                      !  longwave ?
real    :: trop_ht_at_poles = 30000.  !  assumed height of tropoause at
                                      !  poles for case of tropause
                                      !  linearly varying with latitude
                                      !  [ Pa ]
real    :: trop_ht_at_eq    = 10000.  !  assumed height of tropoause at
                                      !  equator for case of tropause
                                      !  linearly varying with latitude
                                      !  [ Pa ]
real    :: trop_ht_constant = 20000.  !  assumed height of tropoause   
                                      !  when assumed constant       
                                      !  [ Pa ]
logical :: constant_tropo = .true.    !  generate tropopause fluxes when
                                      !  tropopause ht assumed constant?
logical :: linear_tropo   = .true.    !  generate tropopause fluxes when
                                      !  tropopause assumed to vary
                                      !  linearly with latitude?
logical :: thermo_tropo   = .false.   !  generate tropopause fluxes when
                                      !  tropopause determined thermo-
                                      !  dynamically ?
logical :: time_varying_solar_constant = .false. 
                                      !  solar_constant is to vary with
                                      !  time ?
logical :: use_uniform_solar_input = .false.
                                      !  the (lat,lon) values used to
                                      !  calculate zenith angle are
                                      !  uniform across the grid ?
real    :: lat_for_solar_input = 100. !  latitude to be used when uni-
                                      !  form solar input is activated
                                      !  [ degrees ]
real    :: lon_for_solar_input = 500. !  longitude to be used when uni-
                                      !  form solar input is activated
                                      !  [ degrees ]

logical :: always_calculate = .false. !  radiation calculation is done
                                      !  on every call to 
                                      !  radiation_driver ?
logical :: do_h2o         = .true.    !  h2o radiative effects are 
                                      !  included in the radiation 
                                      !  calculation ? 
logical :: do_o3          = .true.    !  o3 radiative effects are 
                                      !  included in the radiation 
                                      !  calculation ? 
integer, dimension(6) :: solar_dataset_entry = (/ 1, 1, 1, 0, 0, 0 /)
                                      ! time in solar data set corresp-
                                      ! onding to model initial time
                                      ! (yr, mo, dy, hr, mn, sc)
! <NAMELIST NAME="radiation_driver_nml">
!  <DATA NAME="rad_time_step" UNITS="" TYPE="integer" DIM="" DEFAULT="14400">
!The radiative time step in seconds.
!  </DATA>
!  <DATA NAME="do_clear_sky_pass" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! are the clear-sky radiation
!  diagnostics to be calculated ?
!  </DATA>
!  <DATA NAME="zenith_spec" UNITS="" TYPE="character" DIM="" DEFAULT="">
!string defining how zenith 
!  angle is computed. acceptable
!  values: 'daily_mean', 'annual_
!  mean', 'diurnally_varying'
!  </DATA>
!  <DATA NAME="rad_package" UNITS="" TYPE="character" DIM="" DEFAULT="">
!string defining the radiation
!  package being used. acceptable
!  values : 'sea_esf', 
!  'original_fms'
!  </DATA>
!  <DATA NAME="calc_hemi_integrals" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!are hemispheric integrals 
!  desired ?
!  </DATA>
!  <DATA NAME="all_step_diagnostics" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!are lw and sw radiative bdy
!  fluxes and atmospheric heating 
!  rates to be output on physics 
!  steps ?
!  </DATA>
!  <DATA NAME="renormalize_sw_fluxes" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!should sw fluxes and the zenith
!  angle be renormalized on each 
!  timestep because of the 
!  movement of earth wrt the sun ?
!  </DATA>
!  <DATA NAME="rad_date" UNITS="" TYPE="integer" DIM="" DEFAULT="">
!fixed date for which radiation
!  is to be valid (applies to
!  solar info, ozone, clouds)
!  [yr, mo, day, hr, min, sec]
!  </DATA>
!  <DATA NAME="all_level_radiation" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!is radiation to be calculated 
!  at all model levels ?
!  </DATA>
!  <DATA NAME="topmost_radiation_level" UNITS="" TYPE="integer" DIM="" DEFAULT="">
!if all_level_radiation is 
!  false., this is the lowest
!  model index at which radiation
!  is calculated
!  </DATA>
!  <DATA NAME="drop_upper_levels" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!if all_level_radiation is false
!  and drop_upper_levels is true,
!  radiation will be calculated
!  at all model levels from
!  topmost_radiation_level to the
!  surface
!  </DATA>
!  <DATA NAME="all_column_radiation" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!is radiation to be calculated
!  in all model columns ?
!  </DATA>
!  <DATA NAME="rsd" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!(repeat same day) - call 
!  radiation for the specified 
!  rad_date (yr,mo,day), but run 
!  through the diurnal cycle (hr,
!  min,sec)
!  </DATA>
!  <DATA NAME="use_mixing_ratio" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!assumes q is mixing ratio
!  rather than specific humidity
!  </DATA>
!  <DATA NAME="solar_constant" UNITS="" TYPE="real" DIM="" DEFAULT="">
!annual mean solar flux at top 
!  of atmosphere [ W/(m**2) ]
!  </DATA>
!  <DATA NAME="doing_data_override" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!input fields to the radiation
!  package are being overriden
!  using data_override_mod ?
!  </DATA>
!  <DATA NAME="overriding_temps" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!temperature and ts fields are
!  overriden ?
!  </DATA>
!  <DATA NAME="overriding_sphum" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! specific humidity field is
!  overriden ?
!  </DATA>
!  <DATA NAME="overriding_clouds" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! cloud specification fields are
!  overriden ?
!  </DATA>
!  <DATA NAME="overriding_albedo" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! surface albedo field is
!  overriden ?
!  </DATA>
!  <DATA NAME="overriding_aerosol" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!aerosol fields are overriden ?
!  </DATA>
!  <DATA NAME="use_co2_tracer_field" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!use co2 value from co2 tracer field?
!  </DATA>
!  <DATA NAME="trop_ht_at_poles" UNITS="" TYPE="" DIM="" DEFAULT="">
!assumed height of tropoause at
!  poles for case of tropause
!  linearly varying with latitude
!  [ Pa ]
!  </DATA>
!  <DATA NAME="trop_ht_at_eq" UNITS="" TYPE="real" DIM="" DEFAULT="">
!assumed height of tropoause at
!  equator for case of tropause
!  linearly varying with latitude
!  [ Pa ]
!  </DATA>
!  <DATA NAME="trop_ht_constant" UNITS="" TYPE="real" DIM="" DEFAULT="">
!assumed height of tropoause   
!  when assumed constant       
!  [ Pa ]
!  </DATA>
!  <DATA NAME="constant_tropo" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! generate tropopause fluxes when
!  tropopause ht assumed constant?
!  </DATA>
!  <DATA NAME="linear_tropo" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! generate tropopause fluxes when
!  tropopause assumed to vary
!  linearly with latitude?
!  </DATA>
!  <DATA NAME="thermo_tropo" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! generate tropopause fluxes when
!  tropopause determined thermo-
!  dynamically ?
!  </DATA>
!  <DATA NAME="time_varying_solar_constant" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!solar_constant is to vary with
!  time ?
!  </DATA>
!  <DATA NAME="always_calculate" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!  calculate radiative fluxes and heating rates on every call to 
!  radiation_driver ?
!  </DATA>
!  <DATA NAME="do_h2o" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!  include h2o effects in radiation calculation ?
!  </DATA>
!  <DATA NAME="do_o3" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!  include o3 effects in radiation calculation ?
!  </DATA>
!  <DATA NAME="solar_dataset_entry" UNITS="" TYPE="integer" DIM="" DEFAULT="">
!time in solar data set corresp-
! onding to model initial time
! (yr, mo, dy, hr, mn, sc)
!  </DATA>
!  <DATA NAME="always_calculate" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!fluxes and heating rates should
! be calculatd on each call to
! radiation_driver ? (true for
! standalone applications)
!  </DATA>
!  <DATA NAME="use_uniform_solar_input" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!  the (lat,lon) values used to
!  calculate zenith angle are
!  uniform across the grid ?
!  </DATA>
!  <DATA NAME="lat_for_solar_input" UNITS="" TYPE="real" DIM="" DEFAULT="">
!  latitude to be used when uni-
!  form solar input is activated
!  [ degrees ]
!  </DATA>
!  <DATA NAME="lon_for_solar_input" UNITS="" TYPE="real" DIM="" DEFAULT="">
!  longitude to be used when uni-
!  form solar input is activated
!  [ degrees ]
!  </DATA>
! </NAMELIST>
!
namelist /radiation_driver_nml/ rad_time_step, do_clear_sky_pass, &
                                using_restart_file, &
                                sw_rad_time_step,  &
                                use_single_lw_sw_ts, &
                                use_hires_coszen, &
                                allow_nonrepro_across_restarts, &
                                nzens_per_sw_rad_timestep, &
                                zenith_spec, rad_package,    &
                                calc_hemi_integrals,     &
                                all_step_diagnostics, &
                                renormalize_sw_fluxes, &
                                rad_date, all_level_radiation, &
                                topmost_radiation_level,   &
                                drop_upper_levels,  &
                                all_column_radiation, rsd,    &
                                use_mixing_ratio, solar_constant, &
                                doing_data_override, &
                                overriding_temps, overriding_sphum, &
                                overriding_clouds, overriding_albedo, &
                                overriding_aerosol, &
                                use_co2_tracer_field, &
                                do_swaerosol_forcing,   &
                                do_lwaerosol_forcing, &
                                trop_ht_at_poles, trop_ht_at_eq, &
                                trop_ht_constant, constant_tropo, &
                                linear_tropo, thermo_tropo, &
                                time_varying_solar_constant, &
                                solar_dataset_entry, &
                                always_calculate,  do_h2o, do_o3, &
                                use_uniform_solar_input, &
                                lat_for_solar_input, lon_for_solar_input
!---------------------------------------------------------------------
!---- public data ----


!---------------------------------------------------------------------
!---- private data ----
!-- for netcdf restart
type(restart_file_type), pointer, save :: Rad_restart => NULL()
type(restart_file_type), pointer, save :: Til_restart => NULL()
logical :: do_netcdf_restart = .true. !  netcdf/native restart
logical                                :: in_different_file = .false.
integer                                :: int_renormalize_sw_fluxes
integer                                :: int_do_clear_sky_pass


!---------------------------------------------------------------------
!    logical  flags.

logical ::  module_is_initialized = .false. ! module initialized?
logical ::  do_rad                          ! is this a radiation step ?
logical ::  do_lw_rad, do_sw_rad            ! is this a radiation step ?
logical ::  use_rad_date                    ! specify time of radiation
                                            ! independent of model time?
logical ::  do_sea_esf_rad                  ! using sea_esf_rad package?

!---------------------------------------------------------------------
!    list of restart files readable by this module.
!
!                 sea_esf_rad.res:
!
!     version 1:  sea_esf_rad.res file version used initially in 
!                 AM2 model series (through galway code, AM2p8). this
!                 is the only version of sea_esf_rad.res ever produced.
!
!                 radiation_driver.res:
!
!     version 1:  not readable by this module.
!     version 2:  added cosine of zenith angle as an output to
!                 radiation_driver.res  (6/27/00)
!     version 3:  added restart variables needed when sw renormalization
!                 is active. (3/21/02)
!     version 4:  added longwave heating rate as separate output 
!                 variable, since it is needed as input to edt_mod
!                 and entrain_mod. (7/17/02)
!     version 5:  removed variables associated with the former 
!                 do_average namelist option (7/23/03)
!     version 6:  added writing of sw tropospheric fluxes (up and
!                 down) so that they are available for the renormal-
!                 ization case (developed by ds, 10/03; added to 
!                 trunk code 01/14/04).
!     version 7:  added swdn to saved variables (developed by slm 
!                 11/23/03, added to trunk code 01/14/04).
!     version 8:  includes additional sw fluxes at sfc, used with
!                 land model (11/13/03).
!     version 9:  consolidation of version 6 and version 8. (version 7
!                 replaced by version 8.)
!     version 10: adds 2 clr sky sw down diffuse and direct sfc flux
!                 diagnostic variables (10/18/04)
!     version 11: adds flux_sw_down_vis_clr diagnostic variable for use
!                 in assessing polar ice maintainability (6/19/07)
!---------------------------------------------------------------------
integer, dimension(10) :: restart_versions     = (/ 2, 3, 4, 5, 6,  &
                                                   7, 8, 9, 10, 11 /)
integer                :: vers ! version number of the restart file being read

!-----------------------------------------------------------------------
!    these arrays must be preserved across timesteps:
!
!    Rad_output is a rad_output_type variable with the following 
!    components:
!          tdt_rad        radiative (sw + lw) heating rate
!          flux_sw_surf   net (down-up) sw flux at surface
!          flux_sw_surf_dir   net (down-up) sw flux at surface
!          flux_sw_surf_dif   net (down-up) sw flux at surface
!          flux_sw_down_vis_dir  downward visible sw flux at surface
!          flux_sw_down_vis_dif  downward visible sw flux at surface
!          flux_sw_down_total_dir  downward total sw flux at surface
!          flux_sw_down_total_dif  downward total sw flux at surface
!          flux_sw_down_total_dir_clr  downward total direct sw flux at 
!                                      surface  (clear sky)
!          flux_sw_down_total_dif_clr  downward total diffuse sw flux 
!                                      at surface   (clear sky)
!          flux_sw_down_vis_clr  downward visible sw flux at surface
!                                       (clear sky)
!          flux_sw_vis    net visible sw flux at surface
!          flux_sw_vis_dir    net visible sw flux at surface
!          flux_sw_vis_dif net visible sw flux at surface
!          flux_lw_surf   downward lw flux at surface
!          coszen_angle   cosine of the zenith angle (used for the 
!                         last radiation calculation)
!          tdt_rad_clr    net radiative heating rate in the absence of
!                         cloud
!          tdtsw          shortwave heating rate
!          tdtsw_clr      shortwave heating rate in he absence of cloud
!          tdtlw_clr       longwave heating rate in he absence of cloud
!          tdtlw          longwave heating rate
!          ufsw          upward sw flux
!          dfsw          downward sw flux
!          ufsw_clr      upward sw flux
!          dfsw_clr      downward sw flux
!          flxnet        net lw flux
!          flxnetcf      net lw flux, cloud free

!    solar_save is used when renormalize_sw_fluxes is active, to save
!    the solar factor (fracday*cosz/r**2) from the previous radiation
!    step so that the radiative forcing terms may be adjusted on each
!    timestep to reflect the current solar forcing.
!
!    sw_heating_clr, tot_heating_clr_save, sw_heating_save, 
!    tot_heating_save, flux_sw_surf_save, flux_sw_surf_dir_save,
!    flux_sw_surf_dif_save, flux_sw_down_vis_dir_save, 
!    flux_sw_down_vis_dif_save, flux_sw_down_vis_clr_save,
!    flux_sw_down_total_dir_clr_save, flux_sw_down_total_dif_clr_save,
!    flux_sw_down_total_dir_save, flux_sw_down_total_dif_save and 
!    flux_sw_vis_save, flux_sw_vis_dir_save, flux_sw_vis_dif_save are 
!    the radiative forcing terms on radiation steps which also must be 
!    saved when renormalization is activated.

!    swdn_special_save, swup_special_save, swdn_special_clr_save,
!    swup_special_clr_save are also saved.
!
!    the ***sw_save arrays are currently saved so that their values may
!    be adjusted during sw renormalization for diagnostic purposes.
!                               
!    the **lw_save arrays are currently saved so that they may be output
!    in the diagnostics file on every physics step, if desired, so that
!    when renormalize_sw_fluxes is active, total radiative terms may be
!    easily generated.
!-----------------------------------------------------------------------

type(rad_output_type),save          ::  Rad_output
real, allocatable, dimension(:,:)   ::  solar_save, &
                                        dum_idjd
real, allocatable, dimension(:,:,:)   ::  &
                                    flux_sw_down_total_dir_clr_save, &
                                    flux_sw_down_total_dif_clr_save, &
                                        flux_sw_down_vis_clr_save
real, allocatable, dimension(:,:,:)   ::   flux_sw_surf_save, &
                                        flux_sw_surf_dir_save, &
                                        flux_sw_surf_dif_save, &
                                        flux_sw_down_vis_dir_save, &
                                        flux_sw_down_vis_dif_save, &
                                        flux_sw_down_total_dir_save, &
                                        flux_sw_down_total_dif_save, &
                                        flux_sw_vis_save, &
                                        flux_sw_vis_dir_save, &
                                        flux_sw_vis_dif_save
real, allocatable, dimension(:,:,:,:) ::  sw_heating_save,    &
                                        tot_heating_save, &
                                        dfsw_save, ufsw_save, fsw_save,&
                                        hsw_save
real, allocatable, dimension(:,:,:,:) ::  sw_heating_clr_save, &
                                        tot_heating_clr_save, &
                                        dfswcf_save,   &
                                        ufswcf_save, fswcf_save, &
                                        hswcf_save
real, allocatable, dimension(:,:,:) ::  tdtlw_save, tdtlw_clr_save
 real, allocatable, dimension(:,:,:) ::  flxnet_save, flxnetcf_save
real, allocatable, dimension(:,:)   ::  olr_save, lwups_save, &
                                        lwdns_save, olr_clr_save, &
                                        lwups_clr_save, lwdns_clr_save
real, allocatable, dimension(:,:,:,:) ::  swdn_special_save, &
                                        swdn_special_clr_save, &  
                                        swup_special_save,&
                                        swup_special_clr_save
real, allocatable, dimension(:,:,:) ::  netlw_special_save, &
                                        netlw_special_clr_save
real, allocatable, dimension(:,:,:,:) ::  dfsw_ad_save, ufsw_ad_save
real, allocatable, dimension(:,:,:,:) ::  dfswcf_ad_save, ufswcf_ad_save
real, allocatable, dimension(:,:)   ::  olr_ad_save, lwups_ad_save, &
                                        lwdns_ad_save, olr_ad_clr_save, &
                                    lwups_ad_clr_save, lwdns_ad_clr_save

!-----------------------------------------------------------------------
!    time-step-related constants
 
integer    :: lwrad_alarm    !  time interval until the next radiation 
                             !  calculation (seconds)
integer    :: swrad_alarm    !  time interval until the next radiation 
                             !  calculation (seconds)
integer    :: current_sw_zenith_step = 1  
                             !  current zenith angle index being used  
                             !  for cloudy sw calculations when 
                             !  use_hires_coszen is .true.
integer    :: num_pts=0      !  counter for current number of grid 
                             !  columns processed (when num_pts=0 or 
                             !  num_pts=total_pts certain things happen)
integer    :: total_pts      !  number of grid columns to be processed 
                             !  every time step (note: all grid columns
                             !  must be processed every time step)
type(time_type) :: Rad_time  !  time at which the climatologically-
                             !  determined, time-varying input fields to
                             !  radiation should apply 
                             !  [ time_type (days, seconds)]
integer    :: dt             !  physics time step (frequency of calling 
                             !  radiation_driver)  [ seconds ]
integer   :: lw_rad_time_step

!-----------------------------------------------------------------------
!    diagnostics variables
integer, parameter :: MX_SPEC_LEVS = 4 
                             ! number of special levels at
                             ! which radiative fluxes are to be 
                             ! calculated for diagnostic purposes

character(len=16)            :: mod_name = 'radiation'
integer                      :: id_alb_sfc, id_cosz, id_fracday, &
                                id_alb_sfc_avg, &
                                id_alb_sfc_vis_dir, id_alb_sfc_nir_dir,&
                                id_alb_sfc_vis_dif, id_alb_sfc_nir_dif
integer                      :: id_flux_sw_dir, id_flux_sw_dif, &
                                id_flux_sw_down_vis_dir, &
                                id_flux_sw_down_vis_dif, &
                                id_flux_sw_down_total_dir, &
                                id_flux_sw_down_total_dif, &
                                id_flux_sw_down_total_dir_clr, &
                                id_flux_sw_down_total_dif_clr, &
                                id_flux_sw_down_vis_clr, &
                                id_flux_sw_vis, &
                                id_flux_sw_vis_dir, &
                                id_flux_sw_vis_dif, &
                                id_rrvco2, id_rrvf11, id_rrvf12, &
                                id_rrvf113, id_rrvf22, id_rrvch4, &
                                id_rrvn2o, id_co2_tf, id_ch4_tf, &
                                id_n2o_tf, id_sol_con
integer                      :: id_conc_drop, id_conc_ice

integer                      :: id_allradp
integer, dimension(2)        :: id_tdt_sw,   id_tdt_lw,  &
                                id_ufsw, id_dfsw,  &
                                id_flxnet, &
                                id_swdn_toa, id_swup_toa, id_olr, &
                                id_netrad_toa,  id_netrad_1_Pa,  &
                                id_swup_sfc, id_swdn_sfc,         &
                                id_lwup_sfc, id_lwdn_sfc
integer, dimension(MX_SPEC_LEVS,2)   :: id_swdn_special,   &
                                        id_swup_special,  &
                                        id_netlw_special
integer, dimension(2)        :: id_swtoa, id_swsfc,               &
                                id_lwsfc,                         &
                                id_swtoa_ad, id_swsfc_ad,         &
                                id_swdn_sfc_ad,                   &
                                id_swup_sfc_ad,                   &
                                id_swup_toa_ad,                   &
                                id_olr_ad, id_lwsfc_ad



real                         :: missing_value = -999.
character(len=8)             :: std_digits   = 'f8.3'
character(len=8)             :: extra_digits = 'f16.11'

!-----------------------------------------------------------------------
!    timing clocks       

integer                      :: misc_clock, clouds_clock, calc_clock

!--------------------------------------------------------------------
! miscellaneous variables and indices

integer        ::  ks         !  model grid coordinate of top level
                              !  at which radiation is calculated 
                              !  (topmost_radiation_level)
integer        ::  ke         !  model grid coordinate of bottommost
                              !  level at which radiation is calculated

integer        ::  ksrad=1    !  always set to 1
integer        ::  kerad      !  number of layers in radiation grid

real           ::  rh2o_lower_limit_orig=3.0E-06
                              !  smallest value of h2o mixing ratio 
                              !  allowed with original_fms_rad package
real           ::  rh2o_lower_limit_seaesf=2.0E-07
                              !  smallest value of h2o mixing ratio 
                              !  allowed with sea_esf_rad package
real           ::  rh2o_lower_limit
                              !  smallest value of h2o mixing ratio 
                              !  allowed in the current experiment
real           ::  temp_lower_limit=100.0  ! [ K ]
                              !  smallest value of temperature      
                              !  allowed in the current experiment
real           ::  temp_upper_limit=370.00  ! [ K ]
                              !  largest value of temperature 
                              !  allowed in the current experiment

real           ::  surf_flx_init=50.0  ! [w / m^2 ]
                              !  value to which surface lw and sw fluxes
                              !  are set in the absence of a .res file
                              !  containing them

real           ::  coszen_angle_init=0.50
                              !  value to which cosine of zenith angle  
                              !  is set in the absence of a .res file
                              !  containing it

real           ::  log_p_at_top=2.0
                              !  assumed value of ln of ratio of pres-
                              !  sure at flux level 2 to that at model
                              !  top (needed for deltaz calculation,
                              !  is infinite for model top at p = 0.0,
                              !  this value is used to give a reasonable
                              !  deltaz)
real,parameter ::  D608 = (RVGAS-RDGAS)/RDGAS
                              !  virtual temperature factor  
real,parameter ::  D622 = RDGAS/RVGAS
                              ! ratio of gas constants - dry air to 
                              ! water vapor
real,parameter ::  D378 = 1.0 - D622  
                              ! 1 - gas constant ratio
integer :: id, jd
integer        ::  size_of_lwoutput = 1
integer        ::  size_of_swoutput = 1
integer        ::  indx_lwaf = 0
integer        ::  indx_swaf = 0

real, dimension(:,:), allocatable :: solflxtot_lean
real            :: solflxtot_lean_ann_1882, solflxtot_lean_ann_2000
integer         ::   first_yr_lean, last_yr_lean,   &
                     nvalues_per_year_lean, numbands_lean
integer         ::   years_of_data_lean 

type(time_type) :: Model_init_time, Solar_offset, &
                   Solar_entry
logical         :: negative_offset = .false.
real, dimension(:,:), allocatable :: swups_acc, swdns_acc
real, dimension(:,:), allocatable :: olr_intgl, swabs_intgl

! <DATASET NAME="CO2 transmission functions">
! Several ascii files are required that can be easily setup by a
!     script for getting physics data sets.
! </DATASET>
! <DATASET NAME="Restart file">
! A restart data set called radiation_driver.res(.nc) saves the
!     global fields for the current radiative tendency, net shortwave
!     surface flux, downward longwave surface flux, and cosine of the
!     zenith angle. If the namelist variable do_average=true,
!     then additional time averaged global data is written.
!     If the restart file is not present when initializing then the
!     radiative tendency is set to zero, the SW and LW surface fluxes
!     to 50 watts/m2, and the cosine of the zenith angle to 0.50.
!     Since radiation is usually computed on the first time step when
!     restarting, these values may have little or no effect.  If the
!     restart file is not present time average data is also set to zero.
! </DATASET>
!<REFERENCE> For a specific list of radiation references see the
!     longwave and shortwave documentation.</REFERENCE>
!---------------------------------------------------------------------
!---------------------------------------------------------------------



                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!######################################################################
! <SUBROUTINE NAME="radiation_driver_init">
!  <OVERVIEW>
!   radiation_driver_init is the constructor for radiation_driver_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   radiation_driver_init is the constructor for radiation_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_driver_init (lonb, latb, pref, axes, Time, &
!                                  aerosol_names)
!
!  </TEMPLATE>
!  <IN NAME="lonb" TYPE="real">
!    lonb      Longitude in radians for all (i.e., the global size)
!              grid box corners, the size of lonb should be one more
!              than the number of points along the x-axis and y-axis.
!                 [real, dimension(:,:)]
!  </IN>
!  <IN NAME="latb" TYPE="real">
!    latb      Latitude in radians for all (i.e., the global size)
!              grid box corners, the size of latb should be one more
!              than the number of latitude points along the x-axis and y-axis.
!                 [real, dimension(:,:)]
!  </IN>
!  <IN NAME="pref" TYPE="real">
!    pref      Two reference profiles of pressure at full model levels
!              plus the surface (nlev+1). The first profile assumes a surface
!              pressure of 101325 pa, and the second profile assumes 
!              81060 pa.  [real, dimension(nlev+1,2)]
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!    axes      The axis indices that are returned by previous calls to
!              diag_axis_init. The values of this array correspond to the
!              x, y, full (p)level, and half (p)level axes. These are the
!              axes that diagnostic fields are output on.
!                 [integer, dimension(4)]
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!    Time      The current time.  [time_type]
!  </IN>
!  <IN NAME="aerosol_names" TYPE="character">
!   Aerosol names
!  </IN>
!   <ERROR MSG="must have two reference pressure profile" STATUS="FATAL">
!     The input argument pref must have a second dimension size of 2.
!   </ERROR>
!   <ERROR MSG="restart version ## cannot be read by this module version" STATUS="FATAL">
!     You have attempted to read a radiation_driver.res file with either
!       no restart version number or an incorrect restart version number.
!   </ERROR>
!
!   <NOTE>
!    radiation time step has changed, next radiation time also changed
!       The radiation time step from the namelist input did not match
!       the radiation time step from the radiation restart file.
!       The next time for radiation will be adjusted for the new  namelist
!       input) value.
!   </NOTE>
! </SUBROUTINE>
!
subroutine radiation_driver_init (lonb, latb, pref, axes, Time, &
                                  aerosol_names, aerosol_family_names,&
                                  do_cosp, ncol)

!---------------------------------------------------------------------
!   radiation_driver_init is the constructor for radiation_driver_mod.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
real, dimension(:,:),            intent(in)  :: lonb, latb
real, dimension(:,:),            intent(in)  :: pref
integer, dimension(4),           intent(in)  :: axes
type(time_type),                 intent(in)  :: Time
character(len=*), dimension(:), intent(in)   :: aerosol_names
character(len=*), dimension(:), intent(in)   :: aerosol_family_names
logical,                         intent(in)  :: do_cosp
integer,                         intent(out) :: ncol
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       lonb           2d array of model longitudes on cell corners 
!                      [ radians ]
!       latb           2d array of model latitudes at cell corners 
!                      [ radians ]
!       pref           array containing two reference pressure profiles 
!                      for use in defining transmission functions
!                      [ pascals ]
!       axes           diagnostic variable axes
!       Time           current time [time_type(days, seconds)]
!       aerosol_names  names associated with the activated aerosol
!                      species
!       aerosol_family_names  
!                      names associated with the activated aerosol
!                      families
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables

      integer           ::   unit, io, ierr, logunit
      integer           ::   kmax 
      integer           ::   nyr, nv, nband
      integer           ::   yr, month, year, dum
      integer           ::   ico2
      integer           ::   nzens

!---------------------------------------------------------------------
!   local variables
! 
!        unit    io unit number for namelist file
!        io      error status returned from io operation
!        ierr    error code
!        id      number of grid points in x direction (on processor)
!        jd      number of grid points in y direction (on processor)
!        kmax    number of model layers
!                
!---------------------------------------------------------------------

      
!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized. note that data_override_init cannot
!    be called successfully from here (a data_override_mod feature);
!    instead it relies upon a check for previous initialization when
!    subroutine data_override is called.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call diag_manager_init
      call time_manager_init
      call sat_vapor_pres_init
      call constants_init
      call diag_integral_init
      call esfsw_parameters_init

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=radiation_driver_nml, iostat=io)
      ierr = check_nml_error(io,'radiation_driver_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=radiation_driver_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'radiation_driver_nml')
        enddo
10      call close_file (unit)
      endif
#endif
      call get_restart_io_mode(do_netcdf_restart)

!--------------------------------------------------------------------
!    make sure other namelist variables are consistent with 
!    doing_data_override. Validate here to prevent potentially mis-
!    leading values from going into the stdlog file.
!--------------------------------------------------------------------
      if (.not. doing_data_override) then
        overriding_temps   = .false.
        overriding_sphum   = .false.
        overriding_albedo  = .false.
        overriding_clouds  = .false.
        overriding_aerosol = .false.
      endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
           write (logunit, nml=radiation_driver_nml)

!---------------------------------------------------------------------
!    set logical variable defining the radiation scheme desired from the
!    namelist-input character string. set lower limit to water vapor 
!    mixing ratio that the radiation code will see, to assure keeping 
!    within radiation lookup tables. exit if value is invalid.
!---------------------------------------------------------------------
      if (rad_package == 'original_fms') then
        do_sea_esf_rad = .false.
        rh2o_lower_limit = rh2o_lower_limit_orig
      else if (rad_package == 'sea_esf') then
        do_sea_esf_rad = .true.
        rh2o_lower_limit = rh2o_lower_limit_seaesf
      else
        call error_mesg ('radiation_driver_mod',  &
           'string provided for rad_package is not valid', FATAL)
      endif

!---------------------------------------------------------------------
!    set control variable indicating whether water vapor effects are to
!    be included in the radiative calculation. if h2o effects are not 
!    to be included in the radiative calculations, set the lower limit 
!    for h2o to zero. set flag to indicate do_h2o has been initialized.
!---------------------------------------------------------------------
      Lw_control%do_h2o = do_h2o 
      if (.not. do_h2o) then
        rh2o_lower_limit = 0.0
      endif
      Lw_control%do_h2o_iz = .true.

!---------------------------------------------------------------------
!    set control variable indicating whether ozone effects are to be
!    included in the radiative calculation. set flag to indicate the
!    control variable has been initialized.
!---------------------------------------------------------------------
      Lw_control%do_o3 = do_o3 
      Lw_control%do_o3_iz = .true.
      
!---------------------------------------------------------------------
!    stop execution if overriding of aerosol data has been requested.
!    code to do so has not yet been written.
!---------------------------------------------------------------------
      if (overriding_aerosol) then
        call error_mesg ('radiation_driver_mod', &
                'overriding of aerosol data not yet implemented', FATAL)
      endif

!RSH:
!RSH    if use_co2_tracer_field is .true., verify here that there is
!RSH   in fact a co2 field included within the tracer array. if not,
!RSH   call error_mesg and abort execution.
!RSH
      if(use_co2_tracer_field) then
         ico2 = get_tracer_index(MODEL_ATMOS, 'co2')
         if(ico2 == NO_TRACER) then
            call error_mesg('radiation_driver_mod', &
                 'co2 must be present as a tracer when use_co2_tracer_field is .true.', FATAL)
         endif
      endif

!--------------------------------------------------------------------
!    set logical variables defining how the solar zenith angle is to
!    be  defined from the namelist-input character string.  exit if the
!    character string is invalid.
!--------------------------------------------------------------------
      if (zenith_spec == 'diurnally_varying') then
        Sw_control%do_diurnal = .true.
        Sw_control%do_annual = .false.
        Sw_control%do_daily_mean = .false.
      else if (zenith_spec == 'daily_mean') then
        Sw_control%do_diurnal = .false.
        Sw_control%do_annual = .false.
        Sw_control%do_daily_mean = .true.
      else if (zenith_spec == 'annual_mean') then
        Sw_control%do_diurnal = .false.
        Sw_control%do_annual = .true.
        Sw_control%do_daily_mean = .false.
      else
        call error_mesg ('radiation_driver_mod', &    
            'string provided for zenith_spec is invalid', FATAL)
      endif

!--------------------------------------------------------------------
!    check if spacially-uniform solar input has been requested. if it
!    has, verify that the requested lat and lon are valid, and convert
!    them to radians.
!--------------------------------------------------------------------
      if (use_uniform_solar_input) then
        if (lat_for_solar_input < -90. .or. &
            lat_for_solar_input >  90. ) then
          call error_mesg ('radiation_driver_mod', &
            'specified latitude for uniform solar input is invalid', &
                                                            FATAL)
        else
          lat_for_solar_input = lat_for_solar_input/RADIAN
        endif
        if (lon_for_solar_input < 0. .or. &
            lon_for_solar_input > 360. ) then
          call error_mesg ('radiation_driver_mod', &
            'specified longitude for uniform solar input is invalid', &
                                                             FATAL)
        else
          lon_for_solar_input = lon_for_solar_input/RADIAN
        endif
      endif

!--------------------------------------------------------------------
!     code to handle time-varying solar input
!--------------------------------------------------------------------
        if (file_exist('INPUT/lean_solar_spectral_data.dat')) then
          unit = open_namelist_file   &
                                 ('INPUT/lean_solar_spectral_data.dat')
          read (unit, FMT = '(4i8)') first_yr_lean, last_yr_lean,  &
                                   nvalues_per_year_lean, numbands_lean
          if (numbands_lean /= Solar_spect%nbands) then
            call error_mesg ('radiation_driver_mod', &
            ' number of sw parameterization bands in solar_spectral &
            &data file differs from that defined in esfsw_parameters',&
                                                           FATAL)
          endif
          years_of_data_lean = last_yr_lean - first_yr_lean + 1
          allocate (solflxtot_lean   &
                           (years_of_data_lean, nvalues_per_year_lean))
          allocate (Solar_spect%solflxband_lean   &
             (years_of_data_lean, nvalues_per_year_lean, numbands_lean))
          allocate (Solar_spect%solflxband_lean_ann_1882(numbands_lean))
          read (unit, FMT = '(2i6,f17.4)') yr, month, &
                                          solflxtot_lean_ann_1882
          read (unit, FMT = '(6e12.5 )')   &
                 (Solar_spect%solflxband_lean_ann_1882 &
                                 (nband), nband =1,numbands_lean)
          do nyr=1,years_of_data_lean
            do nv=1,nvalues_per_year_lean
              read (unit, FMT = '(2i6,f17.4)') yr, month, &
                                       solflxtot_lean(nyr,nv)
              read (unit, FMT = '(6e12.5 )')   &
                 (Solar_spect%solflxband_lean  &
                                (nyr,nv,nband), nband =1,numbands_lean)
            end do
          end do
          allocate (Solar_spect%solflxband_lean_ann_2000(numbands_lean))
          read (unit, FMT = '(2i6,f17.4)') yr, month, &
                                           solflxtot_lean_ann_2000
          read (unit, FMT = '(6e12.5 )')   &
              (Solar_spect%solflxband_lean_ann_2000 &
                              (nband), nband =1,numbands_lean)
          call close_file (unit) 
        else
          if (time_varying_solar_constant) then
            call error_mesg ('radiation_driver_mod', &
             'desired solar_spectral_data input file is not present', &
                                                             FATAL)
          endif
        endif
        
        if (time_varying_solar_constant) then
!----------------------------------------------------------------------
!    define the model base time.
!----------------------------------------------------------------------
          Model_init_time = get_base_time()

!----------------------------------------------------------------------
!    if no solar_dataset_entry is supplied, use the model base time,
!    meaning that the timeseries data will be mapped to the model time
!    without any offset.
!----------------------------------------------------------------------
        if (solar_dataset_entry(1) == 1 .and. &
            solar_dataset_entry(2) == 1 .and. &
            solar_dataset_entry(3) == 1 .and. &
            solar_dataset_entry(4) == 0 .and. &
            solar_dataset_entry(5) == 0 .and. &
            solar_dataset_entry(6) == 0 ) then
          Solar_entry = Model_init_time
 
!----------------------------------------------------------------------
!    if a solar_dataset_entry is supplied, define a corresponding
!    time-type variable.
!----------------------------------------------------------------------
        else
          Solar_entry  = set_date (solar_dataset_entry(1), &
                                   solar_dataset_entry(2), &
                                   solar_dataset_entry(3), &
                                   solar_dataset_entry(4), &
                                   solar_dataset_entry(5), &
                                   solar_dataset_entry(6))
        endif

        call error_mesg ('radiation_driver_mod', &
             'Solar data is varying in time', NOTE)
        call print_date (Solar_entry , str='Data from solar timeseries &
                                            &at time:')
        call print_date (Model_init_time , str='This data is mapped to &
                                             &model time:')
        Solar_offset = Solar_entry - Model_init_time
 
        if (Model_init_time > Solar_entry) then
          negative_offset = .true.
        else
          negative_offset = .false.
        endif
        Rad_control%using_solar_timeseries_data = .true.
        Rad_control%using_solar_timeseries_data_iz = .true.

!---------------------------------------------------------------------
!    if solar input not time-varying, define solar constant and set 
!    offset to 0.0.
!---------------------------------------------------------------------
      else
        if (solar_dataset_entry(1) == 1 .and. &
          solar_dataset_entry(2) == 1 .and. &
          solar_dataset_entry(3) == 1 .and. &
          solar_dataset_entry(4) == 0 .and. &
          solar_dataset_entry(5) == 0 .and. &
          solar_dataset_entry(6) == 0 ) then
          Sw_control%solar_constant = solar_constant
          Solar_offset = set_time(0,0)
          call error_mesg ('radiation_driver_mod', &
                   'Solar data is fixed in time at nml value', NOTE)
          Rad_control%using_solar_timeseries_data = .false.
          Rad_control%using_solar_timeseries_data_iz = .true.
        else
 
!----------------------------------------------------------------------
!    convert solar_dataset_entry to a time_type variable.
!----------------------------------------------------------------------
          Solar_entry  = set_date (solar_dataset_entry(1), &
                                   solar_dataset_entry(2), &
                                   solar_dataset_entry(3), &
                                   solar_dataset_entry(4), &
                                   solar_dataset_entry(5), &
                                   solar_dataset_entry(6))
          call error_mesg ('radiation_driver_mod', &
                                'Solar data is fixed in time', NOTE)
          call print_date (Solar_entry ,    &
             str='Data used in this experiment is from solar &
                  &timeseries at time:')
          if (size(Solar_spect%solflxband(:)) /= numbands_lean) then
            call error_mesg ('radiation_driver_mod', &
             'bands present in solar constant time data differs from &
               &model parameterization band number', FATAL)
          endif

!--------------------------------------------------------------------
!    define time to be used for solar input data.
!--------------------------------------------------------------------
          call get_date (Solar_entry, year, month, dum, dum, dum, dum)

!--------------------------------------------------------------------
!    define input value based on year and month of Solar_time.
!--------------------------------------------------------------------
          if (year < first_yr_lean) then
            Sw_control%solar_constant = solflxtot_lean_ann_1882
            do nband=1,numbands_lean
              Solar_spect%solflxband(nband) =  &
                       Solar_spect%solflxband_lean_ann_1882(nband)
            end do
          else if (year > last_yr_lean) then
            Sw_control%solar_constant = solflxtot_lean_ann_2000    
            do nband=1,numbands_lean
              Solar_spect%solflxband(nband) =  &
                  Solar_spect%solflxband_lean_ann_2000(nband)
            end do
          else
            Sw_control%solar_constant =   & 
                            solflxtot_lean(year-first_yr_lean+1, month)
            do nband=1,numbands_lean
              Solar_spect%solflxband(nband) =  &
         Solar_spect%solflxband_lean(year-first_yr_lean+1, month, nband)
            end do
          endif
          Rad_control%using_solar_timeseries_data = .true.
          Rad_control%using_solar_timeseries_data_iz = .true.
        endif
      endif

!---------------------------------------------------------------------
!     include logical control in Rad_control derived-type variable.
!---------------------------------------------------------------------
      Rad_control%time_varying_solar_constant =  &
                                        time_varying_solar_constant
      Rad_control%time_varying_solar_constant_iz = .true.

!---------------------------------------------------------------------
!    set flags indicating that the Sw_control variables have been 
!    defined.
!---------------------------------------------------------------------
      Sw_control%do_diurnal_iz = .true.
      Sw_control%do_annual_iz = .true.
      Sw_control%do_daily_mean_iz = .true.

!---------------------------------------------------------------------
!    be sure that sw renormalization and hi-res zenith angle are not
!    both selected as options. they are mutually exclusive.
!---------------------------------------------------------------------
      if (renormalize_sw_fluxes .and. use_hires_coszen) then
        call error_mesg ('radiation_driver_init', &
         ' cannot select both hi-res zenith angle and sw &
              &renormalization at same time -- choose only one', FATAL)
      endif

!---------------------------------------------------------------------
!    verify that radiation has been requested at all model levels and in
!    all model columns when the original fms radiation is activated.    
!    verify that renormalize_sw_fluxes has not been requested along
!    with the original fms radiation package. verify that all_step_diag-
!    nostics has not been requested with the original fms radiation
!    package.
!---------------------------------------------------------------------
      if (.not. do_sea_esf_rad) then
        if (.not. all_level_radiation .or. &
            .not. all_column_radiation) then
          call error_mesg ( 'radiation_driver_mod', &
        ' must specify all_level_radiation and all_column_radiation'//&
            ' as true when using original fms radiation', FATAL)
        endif
        if (renormalize_sw_fluxes) then
          call error_mesg ( 'radiation_driver_mod', &
           ' cannot renormalize shortwave fluxes with original_fms '//&
                 'radiation package.', FATAL)
        endif
        if (all_step_diagnostics) then
          call error_mesg ( 'radiation_driver_mod', &
            ' cannot request all_step_diagnostics with original_fms '//&
              'radiation package.', FATAL)
        endif
      endif

!---------------------------------------------------------------------
!    can only renormalize shortwave fluxes when diurnally_varying
!    radiation is used.
!---------------------------------------------------------------------
     if (renormalize_sw_fluxes .and. .not. Sw_control%do_diurnal) then
       call error_mesg ('radiation_driver_mod',  &
       ' can only renormalize sw fluxes when using diurnally-varying'//&
                       ' solar radiation', FATAL)
     endif

!---------------------------------------------------------------------
!    verify that a valid radiation time step has been specified.
!---------------------------------------------------------------------
      if (rad_time_step <= 0) then
        call error_mesg ('radiation_driver_mod', &
            ' radiation timestep must be set to a positive integer', &
              FATAL)
      endif
      if (.not. use_single_lw_sw_ts) then
        if (sw_rad_time_step <= 0) then
          call error_mesg ('radiation_driver_mod', &
           ' sw radiation timestep must be set to a positive integer', &
              FATAL)
        endif
      endif

      if (use_single_lw_sw_ts .and. (sw_rad_time_step /= 0.0 .and. &
          sw_rad_time_step /= rad_time_step) ) then
        call error_mesg ('radiation_driver', &
         'to avoid confusion, sw_rad_time_step must either remain at &
                  &default value of 0.0, or be same as rad_time_step &
                        &when use_single_lw_sw_ts is .true.', FATAL)
      endif
      if (use_single_lw_sw_ts) then
        sw_rad_time_step = rad_time_step
      endif
      lw_rad_time_step = rad_time_step
      Rad_control%rad_time_step = rad_time_step
      Rad_control%rad_time_step_iz  = .true.         
      Rad_control%lw_rad_time_step = lw_rad_time_step
      Rad_control%lw_rad_time_step_iz  = .true.         
      Rad_control%sw_rad_time_step = sw_rad_time_step
      Rad_control%sw_rad_time_step_iz  = .true.         

      if (MOD(INT(SECONDS_PER_DAY), lw_rad_time_step) /= 0) then
        call error_mesg ('radiation_driver_mod', &
             'lw radiation timestep currently restricted to be an &
                       &integral factor of seconds in a day', FATAL)
      endif
      if (MOD(INT(SECONDS_PER_DAY), sw_rad_time_step) /= 0) then
        call error_mesg ('radiation_driver_mod', &
             'sw radiation timestep currently restricted to be an &
                       &integral factor of seconds in a day', FATAL)
      endif

!----------------------------------------------------------------------
!    store the radiation time step in a derived-type variable for 
!    transfer to other modules.
!----------------------------------------------------------------------
      Rad_control%rad_time_step = rad_time_step
      Rad_control%rad_time_step_iz = .true.

!----------------------------------------------------------------------
!    store the controls for hires cloudy coszen calculations.
!----------------------------------------------------------------------
      if (use_hires_coszen) then
        Rad_control%hires_coszen = .true.
      else
        Rad_control%hires_coszen = .false.
      endif
      Rad_control%hires_coszen_iz = .true.
      
      if (nzens_per_sw_rad_timestep > 1 .and. &
          .not. (use_hires_coszen) ) then
        call error_mesg ('radiation_driver_init', &
           'uncertainty in what is desired wrt nzens; if &
           &nzens_per_sw_rad_timestep is not default, &
           &use_hires_coszen must be set to .true.' , FATAL)
      endif
      if (use_hires_coszen)  then
        Rad_control%nzens = nzens_per_sw_rad_timestep
      else
        Rad_control%nzens = 1
      endif
      Rad_control%nzens_iz = .true.

!---------------------------------------------------------------------
!    define the dimensions of the local processors portion of the grid.
!---------------------------------------------------------------------
      id    = size(lonb,1) - 1 
      jd    = size(latb,2) - 1
      kmax  = size(pref,1) - 1 

!---------------------------------------------------------------------
!    save the number of special levels at which fluxes may be defined
!    for diagnostic purposes. 
!---------------------------------------------------------------------
      Rad_control%mx_spec_levs = MX_SPEC_LEVS
      Rad_control%mx_spec_levs_iz = .true.        

!---------------------------------------------------------------------
!    check for consistency if drop_upper_levels is activated.
!----------------------------------------------------------------------
      if (drop_upper_levels .and. all_level_radiation) then
          call error_mesg ( 'radiation_driver_mod',  &
            ' drop_upper_levels and all_level_radiation are '//&
                                         'incompatible', FATAL)
      endif

!---------------------------------------------------------------------
!    define the starting and ending vertical indices of the radiation
!    grid. if all_level_radiation is .true., then radiation is done
!    at all model levels. ks, ke are model-based coordinates, while
!    ksrad and kerad are radiation-grid based coordinates (ksrad always
!    is equal to 1). 
!---------------------------------------------------------------------
      if (all_level_radiation) then
        ks = 1
        ke = kmax
        kerad = kmax
        topmost_radiation_level = 1
      else
        if (topmost_radiation_level <= 0) then
          call error_mesg ('radiation_driver_mod', &
          ' when all_level_radiation is .false., topmost_radiation'//&
              '_level must be specified as a positive integer.', FATAL)
        endif
        if (drop_upper_levels) then
          ks = topmost_radiation_level
          ke = kmax
          kerad = ke - ks + 1
          call error_mesg ( ' radiation_driver_mod', &
            ' code has not been validated for all_level_radiation = '//&
               'false. DO NOT USE!', FATAL)
        else
          call error_mesg ( ' radiation_driver_mod', &
         ' currently only drop_upper_levels is available as option '//&
                           'when all_level_radiation = false.', FATAL)
        endif
      endif
       
!---------------------------------------------------------------------
!    exit if all_column_radiation is not .true. -- this option is not
!    yet certified.
!---------------------------------------------------------------------
      if (.not. all_column_radiation) then
        call error_mesg ('radiation_driver_mod',  &
          ' code currently not validated for all_column_radiation = '//&
                                  'false. DO NOT USE!', FATAL)
      endif

!----------------------------------------------------------------------
!    be sure both reference pressure profiles have been provided.
!----------------------------------------------------------------------
      if (size(pref,2) /= 2)    &
        call error_mesg ('radiation_driver_mod', &
         'must provide two reference pressure profiles (pref).', FATAL)

!---------------------------------------------------------------------
!    allocate space for variables which must be saved when sw fluxes
!    are renormalized or diagnostics are desired to be output on every
!    physics step.
!---------------------------------------------------------------------
        nzens = Rad_control%nzens
      if (renormalize_sw_fluxes .or. all_step_diagnostics) then
        allocate (solar_save             (id,jd))
        allocate (dum_idjd               (id,jd))
        allocate (flux_sw_surf_save      (id,jd,nzens))
        allocate (flux_sw_surf_dir_save      (id,jd,nzens))
        allocate (flux_sw_surf_dif_save      (id,jd,nzens))
        allocate (flux_sw_down_vis_dir_save      (id,jd,nzens))
        allocate (flux_sw_down_vis_dif_save      (id,jd,nzens))
        allocate (flux_sw_down_total_dir_save      (id,jd,nzens))
        allocate (flux_sw_down_total_dif_save      (id,jd,nzens))
        allocate (flux_sw_vis_save      (id,jd,nzens))
        allocate (flux_sw_vis_dir_save      (id,jd,nzens))
        allocate (flux_sw_vis_dif_save      (id,jd,nzens))
        allocate (sw_heating_save        (id,jd,kmax,nzens))
        allocate (tot_heating_save       (id,jd,kmax,nzens))
        allocate (dfsw_save              (id,jd,kmax+1,nzens))
        allocate (ufsw_save              (id,jd,kmax+1,nzens))
        allocate ( fsw_save              (id,jd,kmax+1,nzens))
        allocate ( hsw_save              (id,jd,kmax,nzens))
        allocate (swdn_special_save      (id,jd,MX_SPEC_LEVS,nzens))
        allocate (swup_special_save      (id,jd,MX_SPEC_LEVS,nzens))
        if (do_swaerosol_forcing) then
          allocate (dfsw_ad_save              (id,jd,kmax+1,nzens))
          allocate (ufsw_ad_save              (id,jd,kmax+1,nzens))
        endif
        if (do_clear_sky_pass) then 
          allocate (sw_heating_clr_save  (id,jd,kmax,nzens))
          allocate (tot_heating_clr_save (id,jd,kmax,nzens))
          allocate (dfswcf_save          (id,jd,kmax+1,nzens))
          allocate (ufswcf_save          (id,jd,kmax+1,nzens))
          allocate ( fswcf_save          (id,jd,kmax+1,nzens))
          allocate ( hswcf_save          (id,jd,kmax,nzens))
          allocate (flux_sw_down_total_dir_clr_save  (id,jd,nzens))
          allocate (flux_sw_down_total_dif_clr_save  (id,jd,nzens))
          allocate (flux_sw_down_vis_clr_save (id,jd,nzens)) 
          allocate (swdn_special_clr_save(id,jd, MX_SPEC_LEVS,nzens))
          allocate (swup_special_clr_save(id,jd, MX_SPEC_LEVS,nzens))
          if (do_swaerosol_forcing) then
            allocate (dfswcf_ad_save          (id,jd,kmax+1,nzens))
            allocate (ufswcf_ad_save          (id,jd,kmax+1,nzens))
          endif
        endif
      endif

!---------------------------------------------------------------------
!    allocate space for variables which must be saved when lw fluxes
!    are to be output on every physics step.
!---------------------------------------------------------------------
      if (all_step_diagnostics) then
        allocate (olr_save             (id,jd))
        allocate (lwups_save           (id,jd))
        allocate (lwdns_save           (id,jd))
        allocate (tdtlw_save           (id,jd,kmax))
        allocate (flxnet_save           (id,jd,kmax+1))
        allocate (netlw_special_save   (id,jd,MX_SPEC_LEVS))
        if (do_lwaerosol_forcing) then
          allocate (olr_ad_save             (id,jd))
          allocate (lwups_ad_save           (id,jd))
          allocate (lwdns_ad_save           (id,jd))
        endif
        if (do_clear_sky_pass) then
          allocate (olr_clr_save           (id,jd))
          allocate (lwups_clr_save         (id,jd))
          allocate (lwdns_clr_save         (id,jd))
          allocate (tdtlw_clr_save         (id,jd,kmax))
          allocate (flxnetcf_save         (id,jd,kmax+1))
          allocate (netlw_special_clr_save (id,jd,MX_SPEC_LEVS))
          if (do_lwaerosol_forcing) then
            allocate (olr_ad_clr_save           (id,jd))
            allocate (lwups_ad_clr_save         (id,jd))
            allocate (lwdns_ad_clr_save         (id,jd))
          endif
        endif
      endif

!---------------------------------------------------------------------
!    allocate space for the global integrals being accumulated in 
!    this module.
!---------------------------------------------------------------------
      allocate (olr_intgl(id,jd))
      allocate (swabs_intgl(id,jd))

!---------------------------------------------------------------------
!    allocate space for module variables to contain values which must
!    be saved between timesteps (these are used on every timestep,
!    but only calculated on radiation steps).
!---------------------------------------------------------------------
        allocate (Rad_output%tdt_rad     (id,jd,kmax,nzens))
        allocate (Rad_output%tdt_rad_clr (id,jd,kmax,nzens))
        allocate (Rad_output%tdtsw       (id,jd,kmax,nzens))
        allocate (Rad_output%tdtsw_clr   (id,jd,kmax,nzens))
        allocate (Rad_output%ufsw        (id,jd,kmax+1,nzens))
        allocate (Rad_output%dfsw        (id,jd,kmax+1,nzens))
        allocate (Rad_output%ufsw_clr    (id,jd,kmax+1,nzens))
        allocate (Rad_output%dfsw_clr    (id,jd,kmax+1,nzens))
        allocate (Rad_output%flxnet      (id,jd,kmax+1))
        allocate (Rad_output%flxnetcf    (id,jd,kmax+1))
        allocate (Rad_output%tdtlw       (id,jd,kmax))
        allocate (Rad_output%tdtlw_clr   (id,jd,kmax))
        allocate (Rad_output%flux_sw_surf_dir(id,jd,nzens))
        allocate (Rad_output%flux_sw_surf_dif(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_vis_dir(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_vis_dif(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_total_dir(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_total_dif(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_total_dir_clr(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_total_dif_clr(id,jd,nzens))
        allocate (Rad_output%flux_sw_down_vis_clr(id,jd,nzens))
        allocate (Rad_output%flux_sw_vis(id,jd,nzens))
        allocate (Rad_output%flux_sw_vis_dir(id,jd,nzens))
        allocate (Rad_output%flux_sw_vis_dif(id,jd,nzens))
        allocate (Rad_output%flux_sw_surf(id,jd,nzens))
        allocate (Rad_output%flux_lw_surf(id,jd))
        allocate (Rad_output%coszen_angle(id,jd))
        Rad_output%tdtsw     = 0.0
        Rad_output%tdtsw_clr = 0.0
        Rad_output%ufsw      = 0.0
        Rad_output%dfsw      = 0.0
        Rad_output%ufsw_clr  = 0.0
        Rad_output%dfsw_clr  = 0.0
        Rad_output%flxnet    = 0.0
        Rad_output%flxnetcf  = 0.0
        Rad_output%tdtlw     = 0.0
        Rad_output%tdtlw_clr = 0.0

!-----------------------------------------------------------------------
!    if two radiation restart files exist, exit.
!-----------------------------------------------------------------------
        if ( file_exist('INPUT/sea_esf_rad.res')  .and.     &
             file_exist('INPUT/radiation_driver.res') ) then 
          call error_mesg ('radiation_driver_mod',  &
         ' both sea_esf_rad.res and radiation_driver.res files are'//&
               ' present in INPUT directory. which one to use ?', FATAL)
        endif

   if  (using_restart_file) then

!----------------------------------------------------------------------
!    Register fields to be written out to restart file.
     if(do_netcdf_restart) call rad_driver_register_restart('radiation_driver.res.nc')

!-----------------------------------------------------------------------
!    if a valid restart file exists, call read_restart_file to read it.
!-----------------------------------------------------------------------
        if ( file_exist('INPUT/radiation_driver.res.nc')) then
          call read_restart_nc
        else if ( (do_sea_esf_rad .and.   &
             (file_exist('INPUT/sea_esf_rad.res')  .or. &
              file_exist('INPUT/radiation_driver.res') )  ) .or. &
             (.not. do_sea_esf_rad .and.   &
               file_exist('INPUT/radiation_driver.res') )  ) then
          call read_restart_file 
!----------------------------------------------------------------------
!    if no restart file is present, initialize the needed fields until
!    the radiation package may be called. initial surface flux is set 
!    to 100 wm-2, and is only used for initial guess of sea ice temp.
!    set rad_alarm to be 1 second from now, ie., on the first step of 
!    the job.
!-----------------------------------------------------------------------
        else
          lwrad_alarm                = 1
          swrad_alarm                = 1
          if (mpp_pe() == mpp_root_pe() ) then
          call error_mesg ('radiation_driver_mod', &
           'radiation to be calculated on first step: no restart file&
                                                 & present', NOTE)
          endif
          Rad_output%tdt_rad       = 0.0
          Rad_output%tdt_rad_clr   = 0.0
          Rad_output%tdtlw         = 0.0
          Rad_output%flux_sw_surf  = surf_flx_init
!!! BETTER INITIAL VALUES FOR THESE ARRAYS NEEDED ??
          Rad_output%flux_sw_surf_dir  = surf_flx_init
          Rad_output%flux_sw_surf_dif  = surf_flx_init
!!! BETTER INITIAL VALUES FOR THESE ARRAYS NEEDED ??
          Rad_output%flux_sw_down_vis_dir  = 0.0
          Rad_output%flux_sw_down_vis_dif  = 0.0
          Rad_output%flux_sw_down_total_dir  = 0.0
          Rad_output%flux_sw_down_total_dif  = 0.0
          Rad_output%flux_sw_down_total_dir_clr  = 0.0
          Rad_output%flux_sw_down_total_dif_clr  = 0.0
          Rad_output%flux_sw_down_vis_clr  = 0.0
          Rad_output%flux_sw_vis  = 0.0
          Rad_output%flux_sw_vis_dir  = 0.0
          Rad_output%flux_sw_vis_dif  = 0.0
          Rad_output%flux_lw_surf  = surf_flx_init
          Rad_output%coszen_angle  = coszen_angle_init
          if (mpp_pe() == mpp_root_pe() ) then
            call error_mesg ('radiation_driver_mod', &
           'no acceptable radiation restart file present; therefore'//&
           ' will initialize input fields', NOTE)
          endif
        endif

!---------------------------------------------------------------------
!    if not using restart file, then initialize fields it would contain.
!    it is the responsibility of the user to assure restart is on a
!    radiation timestep so that restart seamlessness is maintained. if
!    restart is done on a non-radiation step, restart seamlessness will 
!    be lost if a restart file is not available.
!---------------------------------------------------------------------
   else  ! (using_restart_file)
     lwrad_alarm                = 1
     swrad_alarm                = 1
     if (mpp_pe() == mpp_root_pe() ) then
       call error_mesg ('radiation_driver_mod', &
          'radiation to be calculated on first step: user asserts that&
           & this is a scheduled radiation step;  if it is not, &
                           &restart seamlessness will be lost ', NOTE)
     endif
     Rad_output%tdt_rad       = 0.0
     Rad_output%tdt_rad_clr   = 0.0
     Rad_output%tdtlw         = 0.0
     Rad_output%flux_sw_surf  = surf_flx_init
     Rad_output%flux_sw_surf_dir  = surf_flx_init
     Rad_output%flux_sw_surf_dif  = surf_flx_init
     Rad_output%flux_sw_down_vis_dir  = 0.0
     Rad_output%flux_sw_down_vis_dif  = 0.0
     Rad_output%flux_sw_down_total_dir  = 0.0
     Rad_output%flux_sw_down_total_dif  = 0.0
     Rad_output%flux_sw_down_total_dir_clr  = 0.0
     Rad_output%flux_sw_down_total_dif_clr  = 0.0
     Rad_output%flux_sw_down_vis_clr  = 0.0
     Rad_output%flux_sw_vis  = 0.0
     Rad_output%flux_sw_vis_dir  = 0.0
     Rad_output%flux_sw_vis_dif  = 0.0
     Rad_output%flux_lw_surf  = surf_flx_init
     Rad_output%coszen_angle  = coszen_angle_init
   endif ! (using_restart_file)

!--------------------------------------------------------------------
!    do the initialization specific to the sea_esf_rad radiation
!    package.
!--------------------------------------------------------------------
      if (do_sea_esf_rad) then 

!---------------------------------------------------------------------
!    define control variables indicating whether the clear-sky forcing
!    should be calculated. set a flag to indicate that the variable
!    has been defined.
!---------------------------------------------------------------------
        Rad_control%do_totcld_forcing = do_clear_sky_pass
        Rad_control%do_totcld_forcing_iz = .true.

!---------------------------------------------------------------------
!    define control variables indicating whether the aerosol forcings
!    should be calculated. set a flag to indicate that the variables
!    have been defined.
!---------------------------------------------------------------------
        Rad_control%do_lwaerosol_forcing = do_lwaerosol_forcing
        Rad_control%do_lwaerosol_forcing_iz = .true.
        Rad_control%do_swaerosol_forcing = do_swaerosol_forcing
        Rad_control%do_swaerosol_forcing_iz = .true.
        if (do_lwaerosol_forcing) then
          size_of_lwoutput = size_of_lwoutput + 1
          indx_lwaf = size_of_lwoutput 
          Rad_control%indx_lwaf = indx_lwaf
        endif
        if (do_swaerosol_forcing) then
          size_of_swoutput = size_of_swoutput + 1
          indx_swaf = size_of_swoutput 
          Rad_control%indx_swaf = indx_swaf
        endif
        Rad_control%indx_lwaf_iz = .true.     
        Rad_control%indx_swaf_iz = .true.

!---------------------------------------------------------------------
!    initialize the modules that are accessed from radiation_driver_mod.
!---------------------------------------------------------------------
        call sea_esf_rad_init        (lonb, latb, pref(ks:ke+1,:))
        call cloudrad_package_init   (pref(ks:ke+1,:), lonb, latb,  &
                                      axes, Time)
        call aerosolrad_package_init (kmax, aerosol_names, lonb, latb)
        call rad_output_file_init    (axes, Time, aerosol_names, &
                                      aerosol_family_names)

!---------------------------------------------------------------------
!    do the initialization specific to the original fms radiation
!    package. 
!---------------------------------------------------------------------
      else
        call original_fms_rad_init (lonb, latb, pref, axes, Time, kmax)
      endif

!--------------------------------------------------------------------
!    initialize the astronomy_package.
!--------------------------------------------------------------------
      if (Sw_control%do_annual) then
        call astronomy_init (latb, lonb)
      else
        call astronomy_init
      endif

!---------------------------------------------------------------------
!    initialize the total number of columns in the processor's domain.
!---------------------------------------------------------------------
        total_pts = id*jd 

!-----------------------------------------------------------------------
!    check if optional radiative date should be used.
!-----------------------------------------------------------------------
        if (rad_date(1) > 1900 .and.                        &
            rad_date(2) >   0  .and. rad_date(2) < 13 .and. &
            rad_date(3) >   0  .and. rad_date(3) < 32 ) then
          use_rad_date = .true.
        else
          use_rad_date = .false.
        endif

!----------------------------------------------------------------------
!    define characteristics of desired diagnostic integrals. 
!----------------------------------------------------------------------
        call initialize_diagnostic_integrals

!----------------------------------------------------------------------
!    register the desired netcdf output variables with the 
!    diagnostics_manager.
!----------------------------------------------------------------------
        call diag_field_init (Time, axes)

!--------------------------------------------------------------------
!    initialize clocks to time portions of the code called from 
!    radiation_driver.
!--------------------------------------------------------------------
      misc_clock =    &
            mpp_clock_id ('   Physics_down: Radiation: misc', &
                grain = CLOCK_MODULE)
      clouds_clock =   &
            mpp_clock_id ('   Physics_down: Radiation: clds', &
               grain = CLOCK_MODULE)
      calc_clock =    &
            mpp_clock_id ('   Physics_down: Radiation: calc', &
                grain = CLOCK_MODULE)

!---------------------------------------------------------------------
!     if Rad_time is unchanging between timesteps, or the same day is being
!     repeated, switch to the alternative seed generation procedure to
!     assure unique temporal and spatial seeds for the stochastic cloud
!     parameterization.
!---------------------------------------------------------------------
      if ( (rsd .or. use_rad_date)) then  
        Cldrad_control%use_temp_for_seed = .true.
        call error_mesg ('cloud_spec_init', &
             'Will use temp as basis for stochastic cloud seed; &
                                &Rad_time is not monotonic', NOTE)
      endif
      Cldrad_control%use_temp_for_seed_iz = .true.

!---------------------------------------------------------------------
!    call check_derived_types to verify that all logical elements of
!    public derived-type variables stored in rad_utilities_mod but
!    initialized elsewhere have been initialized.
!---------------------------------------------------------------------
      if (do_sea_esf_rad) then
        call check_derived_types
      endif

!---------------------------------------------------------------------
!    verify that stochastic clouds have been activated if the COSP 
!    simulator output has been requested.
!---------------------------------------------------------------------
      if (do_cosp .and.   &
          (.not. Cldrad_control%do_stochastic_clouds) ) then
        call error_mesg ('radiation_driver_init', &
         'cannot call COSP simulator unless stochastic clouds are &
           &activated (do_stochastic_clouds in strat_clouds_W_nml)', &
                                                                  FATAL)
      endif

!--------------------------------------------------------------------
!    return the potential number of stochastic columns.
!--------------------------------------------------------------------
      ncol = Solar_spect%nbands + Cldrad_control%nlwcldb
 
!---------------------------------------------------------------------
!    set flag to indicate that module has been successfully initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------


end subroutine radiation_driver_init


!######################################################################
 
subroutine radiation_driver_time_vary (Time, Rad_gases_tv)
 
!---------------------------------------------------------------------
!    radiation_driver_time_vary calculates time-dependent, 
!    space-independent quantities needed within the modules of the 
!    radiation package.
!---------------------------------------------------------------------
 
type(time_type),               intent(in)     :: Time
type(radiative_gases_type),    intent(inout)  ::  Rad_gases_tv
 

      call aerosolrad_package_time_vary (Time)
      call sea_esf_rad_time_vary (Time, Rad_gases_tv)
 
end subroutine radiation_driver_time_vary
 
 
!####################################################################

subroutine radiation_driver_endts (is, js, Rad_gases_tv)

integer,                       intent(in)  :: is,js
type(radiative_gases_type),    intent(in)  ::  Rad_gases_tv

!---------------------------------------------------------------------

      call sum_diag_integral_field ('olr',    olr_intgl)
      call sum_diag_integral_field ('abs_sw', swabs_intgl )

      call aerosolrad_package_endts

      call sea_esf_rad_endts (Rad_gases_tv)

!---------------------------------------------------------------------
!    complete radiation step. if this was a radiation step, set the 
!    radiation alarm to go off rad_time_step seconds from now, and
!    set do_rad to false, so that radiation will not be calculated 
!    again until the alarm goes off.
!--------------------------------------------------------------------
      if (.not. always_calculate) then
        if (do_lw_rad) then
          lwrad_alarm = lwrad_alarm + lw_rad_time_step
          do_lw_rad = .false.
        endif
        if (do_sw_rad) then
          swrad_alarm = swrad_alarm + sw_rad_time_step
          do_sw_rad = .false.
        endif

        if (.not. do_lw_rad .and. .not. do_sw_rad)  then
          do_rad = .false.
        else
          do_rad = .true.
        endif

      endif  ! (always_calculate)

      Rad_control%do_lw_rad = do_lw_rad
      Rad_control%do_sw_rad = do_sw_rad

 
end subroutine radiation_driver_endts


!#####################################################################
! <SUBROUTINE NAME="radiation_driver">
!  <OVERVIEW>
!    radiation_driver adds the radiative heating rate to the temperature
!    tendency and obtains the radiative boundary fluxes and cosine of 
!    the solar zenith angle to be used in the other component models.
!  </OVERVIEW>
!  <DESCRIPTION>
!    radiation_driver adds the radiative heating rate to the temperature
!    tendency and obtains the radiative boundary fluxes and cosine of 
!    the solar zenith angle to be used in the other component models.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_driver (is, ie, js, je, Time, Time_next,  &
!                             lat, lon, Surface, Atmos_input, &
!                             Aerosol, Cld_spec, Rad_gases, &
!                             Lsc_microphys, Meso_microphys,    &
!                             Cell_microphys, Radiation, mask, kbot)
!
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending i,j indices in global storage arrays
!  </IN> 
!  <IN NAME="Time" TYPE="time_type">
!   current model time 
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   The time used for diagnostic output
!  </IN>
!  <IN NAME="lon" TYPE="real">
!    lon        mean longitude (in radians) of all grid boxes processed by
!               this call to radiation_driver   [real, dimension(:,:)]
!  </IN>
!  <IN NAME="lat" TYPE="real">
!    lat        mean latitude (in radians) of all grid boxes processed by this
!               call to radiation_driver   [real, dimension(:,:)]
!  </IN>
!  <INOUT NAME="Surface" TYPE="surface_type">
!   Surface input data to radiation package
!  </INOUT>
!  <INOUT NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data to radiation package
!  </INOUT>
!  <INOUT NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol climatological input data to radiation package
!  </INOUT>
!  <INOUT NAME="r" TYPE="real">
!   4 dimensional tracer array, last index is the number of all tracers
!  </INOUT>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud microphysical and physical parameters to radiation package, 
!                     contains var-
!                     iables defining the cloud distribution, passed 
!                     through to lower level routines
!  </INOUT>
!  <INOUT NAME="Rad_gases" TYPE="radiative_gases_type">
!   Radiative gases properties to radiation package, , contains var-
!                     iables defining the radiatively active gases, 
!                     passed through to lower level routines
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale
!                      clouds
!  </INOUT>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                      clouds associated with donner convection
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale
!                      clouds assciated with donner convection
!  </INOUT>
!  <INOUT NAME="Radiation" TYPE="rad_output_type">
!   Radiation output from radiation package, contains variables
!                     which are output from radiation_driver to the 
!                     calling routine, and then used elsewhere within
!                     the component models.
!  </INOUT>
!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! <ERROR MSG="radiation_driver_init must first be called" STATUS="FALTA">
! You have not called radiation_driver_init before calling
!       radiation_driver.
! </ERROR>
! <ERROR MSG="Time_next <= Time" STATUS="FALTA">
! Time arguments to radiation_driver are producing a time step <= 0.
!       Check that the time argumnets passed to the physics_driver are
!       correct.
! </ERROR>
! </SUBROUTINE>
!
subroutine radiation_driver (is, ie, js, je, Time, Time_next,  &
                             lat, lon, Surface, Atmos_input, &
                             Aerosol, r, Cld_spec, Rad_gases, &
                             Lsc_microphys, Meso_microphys,    &
                             Cell_microphys, Shallow_microphys, &
                             Model_microphys, &
                             Radiation, Astronomy_inp, &
                             mask, kbot)

!---------------------------------------------------------------------
!    radiation_driver adds the radiative heating rate to the temperature
!    tendency and obtains the radiative boundary fluxes and cosine of 
!    the solar zenith angle to be used in the other component models.
!---------------------------------------------------------------------
 
!--------------------------------------------------------------------
integer,                      intent(in)           :: is, ie, js, je
type(time_type),              intent(in)           :: Time, Time_next
real, dimension(:,:),         intent(in)           :: lat, lon
type(surface_type),           intent(inout)        :: Surface
type(atmos_input_type),       intent(inout)        :: Atmos_input
type(aerosol_type),           intent(inout)        :: Aerosol  
real, dimension(:,:,:,:),     intent(inout)        :: r
type(cld_specification_type), intent(inout)        :: Cld_spec
type(radiative_gases_type),   intent(inout)        :: Rad_gases
type(microphysics_type),      intent(inout)        :: Lsc_microphys,&
                                                      Meso_microphys,&
                                                      Cell_microphys, &
                                                    Shallow_microphys, &
                                                      Model_microphys
type(rad_output_type),     intent(inout), optional :: Radiation
type(astronomy_inp_type),  intent(inout), optional :: Astronomy_inp
real, dimension(:,:,:),    intent(in),    optional :: mask
integer, dimension(:,:),   intent(in),    optional :: kbot
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                     the physics_window being integrated
!      Time           current model time [ time_type (days, seconds) ] 
!      Time_next      time on next timestep, used as stamp for diagnos-
!                     tic output  [ time_type  (days, seconds) ]  
!      lat            latitude of model points  [ radians ]
!      lon            longitude of model points [ radians ]
!
!   intent(inout) variables:
!
!      Surface        surface_type structure, contains variables 
!                     defining the surface characteristics, including
!                     the following component referenced in this 
!                     routine:
!
!         asfc          surface albedo  [ dimensionless ]
!
!      Atmos_input    atmos_input_type structure, contains variables
!                     defining atmospheric state, including the follow-
!                     ing component referenced in this routine
!
!         tsfc          surface temperature [ deg K ]
!
!      Aerosol        aerosol_type structure, contains variables
!                     defining aerosol fields, passed through to
!                     lower level routines
!      Cld_spec       cld_specification_type structure, contains var-
!                     iables defining the cloud distribution, passed 
!                     through to lower level routines
!      Rad_gases      radiative_gases_type structure, contains var-
!                     iables defining the radiatively active gases, 
!                     passed through to lower level routines
!      Lsc_microphys  microphysics_type structure, contains variables
!                     describing the microphysical properties of the
!                     large-scale clouds, passed through to lower
!                     level routines
!      Meso_microphys microphysics_type structure, contains variables
!                     describing the microphysical properties of the
!                     meso-scale clouds, passed through to lower
!                     level routines
!      Cell_microphys microphysics_type structure, contains variables
!                     describing the microphysical properties of the
!                     convective cell-scale clouds, passed through to 
!                     lower level routines
!
!   intent(inout), optional variables:
!
!      Radiation      rad_output_type structure, contains variables
!                     which are output from radiation_driver to the 
!                     calling routine, and then used elsewhere within
!                     the component models.  present when running gcm,
!                     not present when running sa_gcm or standalone
!                     columns mode. variables defined here are:
!
!        tdt_rad         radiative (sw + lw) heating rate
!                        [ deg K / sec ]
!        flux_sw_surf    net (down-up) sw surface flux 
!                        [ watts / m^^2 ]
!        flux_lw_surf    downward lw surface flux 
!                        [ watts / m^^2 ]
!        coszen_angle    cosine of the zenith angle which will be used 
!                        for the next ocean_albedo calculation 
!                        [ dimensionless ]
!        tdtlw           longwave heating rate
!                        [ deg K / sec ]
!      Astronomy_inp  astronomy_input_type structure, optionally used
!                     to input astronomical forcings, when it is desired
!                     to specify them rather than use astronomy_mod.
!                     Used in various standalone applications.
!
!   intent(in), optional variables:
!
!        mask            present when running eta vertical coordinate,
!                        mask to remove points below ground
!        kbot            present when running eta vertical coordinate,
!                        index of lowest model level above ground 
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      type(cldrad_properties_type)       :: Cldrad_props
      type(astronomy_type)               :: Astro, Astro2
      type(lw_output_type), dimension(size_of_lwoutput) :: Lw_output
      type(sw_output_type), dimension(size_of_swoutput) :: Sw_output
      type(fsrad_output_type)            :: Fsrad_output
      type(aerosol_properties_type)      :: Aerosol_props
      type(aerosol_diagnostics_type)     :: Aerosol_diags

      real, dimension (ie-is+1, je-js+1) :: flux_ratio, &
                                            lat_uniform, lon_uniform
      integer :: nz
 
!-------------------------------------------------------------------
!   local variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [cldrad_properties_type]
!      Astro             astronomical properties on model grid, usually
!                        valid over radiation timestep
!                        [astronomy_type]
!      Astro2            astronomical properties on model grid, valid 
!                        over current physics timestep
!                        [astronomy_type]
!      Lw_output         sea longwave output fields on model grid,
!                        [lw_output_type]
!      Sw_output         esf shortwave output fields on model grid,
!                        [sw_output_type]
!      Fsrad_output      original fms radiation output fields on model
!                        grid, [fsrad_output_type]
!      flux_ratio        value  used to renormalize sw fluxes and 
!                        heating rates to account for earth-sun motion
!                        during the radiation timestep
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)
     
!---------------------------------------------------------------------
!    if this is a radiation step, or if the astronomical inputs to
!    radiation (solar, cosz, fracday, rrsun) need to be obtained 
!    because of time averaging or renormalization, call 
!    obtain_astronomy_variables to do so.
!---------------------------------------------------------------------
      call mpp_clock_begin (misc_clock)
      if (do_rad .or. renormalize_sw_fluxes .or.   &
          present(Astronomy_inp)) then 
        if (use_uniform_solar_input) then
          if (present (Astronomy_inp)) then
            call error_mesg ('radiation_driver_mod', &
              'cannot specify both use_uniform_solar_input AND use&
              & Astronomy_inp to specify astronomical variables', &
                                                               FATAL)
          endif
          lat_uniform(:,:) = lat_for_solar_input
          lon_uniform(:,:) = lon_for_solar_input
          call obtain_astronomy_variables (is, ie, js, je,  &
                                           lat_uniform, lon_uniform,  &
                                           Astro, Astro2)
        else
          if (present (Astronomy_inp)) then
            Sw_control%do_diurnal = .false.
            Sw_control%do_annual = .false.
            Sw_control%do_daily_mean = .false.
          endif
          call obtain_astronomy_variables (is, ie, js, je, lat, lon,  &
                                           Astro, Astro2, &
                                           Astronomy_inp =  &
                                                          Astronomy_inp)
        endif
      endif

!     print *, 'before aerosol  ', mpp_pe()
      if (do_rad) then
        if (Rad_control%do_aerosol) then
          call aerosolrad_package_alloc (ie-is+1, je-js+1,  &
                              size(Aerosol%aerosol,3), Aerosol_props)
          call aerosol_radiative_properties (is, ie, js, je, &
                                             Rad_time,   &
                                             Atmos_input%pflux, &
                                             Aerosol_diags, &
                                             Aerosol, Aerosol_props)
!         allocate (Aerosol_diags%extopdep (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                           size(Aerosol%aerosol,3), &
!                                           size(Aerosol%aerosol,4) ))
!         Aerosol_diags%extopdep = 0.0
!         allocate (Aerosol_diags%absopdep (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                           size(Aerosol%aerosol,3), &
!                                           size(Aerosol%aerosol,4) ))
!         Aerosol_diags%absopdep = 0.0
!         allocate (Aerosol_diags%extopdep_vlcno    &
!                                          (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                           size(Aerosol%aerosol,3),3)) 
!         Aerosol_diags%extopdep_vlcno = 0.0
!         allocate (Aerosol_diags%absopdep_vlcno  &
!                                          (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                           size(Aerosol%aerosol,3),3))
!         Aerosol_diags%absopdep_vlcno = 0.0
!         allocate (Aerosol_diags%sw_heating_vlcno  &
!                                          (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                           size(Aerosol%aerosol,3)))
!         Aerosol_diags%sw_heating_vlcno = 0.0
!         allocate (Aerosol_diags%lw_extopdep_vlcno    &
!                                          (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                         size(Aerosol%aerosol,3)+1,3)) 
!         Aerosol_diags%lw_extopdep_vlcno = 0.0
!         allocate (Aerosol_diags%lw_absopdep_vlcno  &
!                                          (size(Aerosol%aerosol,1), &
!                                           size(Aerosol%aerosol,2), &
!                                         size(Aerosol%aerosol,3)+1,3))
!         Aerosol_diags%lw_absopdep_vlcno = 0.0
        
        endif
      endif
      call mpp_clock_end (misc_clock)

!--------------------------------------------------------------------
!    when using the sea-esf radiation, call cloud_radiative_properties
!    to obtain the cloud-radiative properties needed for the radiation 
!    calculation. (these properties are obtained within radiation_calc
!    when executing the original fms radiation code). if these fields 
!    are to be time-averaged, this call is made on all steps; otherwise
!    just on radiation steps.
!--------------------------------------------------------------------
!     print *, 'before cloud_rad', mpp_pe()
      call mpp_clock_begin (clouds_clock)
      if (do_rad) then
        if (do_sea_esf_rad) then
          if (present(kbot) ) then
            call cloud_radiative_properties (     &
                         is, ie, js, je, Rad_time, Time_next, Astro,  & 
                         Atmos_input, Cld_spec, Lsc_microphys,  &
                         Meso_microphys, Cell_microphys,    &
                         Shallow_microphys, Cldrad_props,  &
                         Model_microphys, kbot=kbot, mask=mask)
          else    

            call cloud_radiative_properties (      &
                         is, ie, js, je, Rad_time, Time_next, Astro,  & 
                         Atmos_input, Cld_spec, Lsc_microphys,   &
                         Meso_microphys, Cell_microphys,    &
                       Shallow_microphys, Cldrad_props, Model_microphys)
          endif
        endif
      endif
      call mpp_clock_end (clouds_clock)

!---------------------------------------------------------------------
!    on radiation timesteps, call radiation_calc to determine new radia-
!    tive fluxes and heating rates.
!---------------------------------------------------------------------
!     print *, 'before _calc    ', mpp_pe()
      call mpp_clock_begin (calc_clock)
      if (do_rad) then
        call radiation_calc (is, ie, js, je, Rad_time, Time_next, lat, &
                             lon, Atmos_input, Surface, Rad_gases,  &
                             Aerosol_props, Aerosol, r, Cldrad_props, &
                             Cld_spec, Astro, Rad_output, Lw_output, &
                             Sw_output, Fsrad_output, Aerosol_diags, &
                             mask=mask,   &
                             kbot=kbot)       
      endif

      call mpp_clock_end (calc_clock)
!-------------------------------------------------------------------
!    on all timesteps, call update_rad_fields to update the temperature 
!    tendency and define the fluxes needed by other component models.
!    if the shortwave fluxes are to be renormalized because of the 
!    change in zenith angle since the last radiation timestep, that also
!    is done in this subroutine. 
!-------------------------------------------------------------------
!     print *, 'before update   ', mpp_pe()
      call mpp_clock_begin (misc_clock)
!     if (Environment%running_gcm .or.  &
!         Environment%running_sa_model .or. &
!         (Environment%running_standalone .and. &
!          Environment%column_type == 'fms')) then
        call update_rad_fields (is, ie, js, je, Time_next, Astro2, &
                                Sw_output, Astro, Rad_output,    &
                                flux_ratio)

!-------------------------------------------------------------------
!    call produce_radiation_diagnostics to produce radiation 
!    diagnostics, both fields and integrals.
!-------------------------------------------------------------------
        if (do_sea_esf_rad) then
          call produce_radiation_diagnostics        &
                            (is, ie, js, je, Time_next, Time, lat, &
                             Atmos_input%tsfc, Surface,  &
                             flux_ratio,  Astro, Rad_output,  &
                             Rad_gases, Lw_output=Lw_output,&
                             Sw_output=Sw_output,  &
                             Cld_spec=Cld_spec,  &
                             Lsc_microphys=Lsc_microphys)
        else
          call produce_radiation_diagnostics        &
                            (is, ie, js, je, Time_next, Time, lat, &
                             Atmos_input%tsfc, Surface,  &
                             flux_ratio,  Astro, Rad_output,  &
                             Rad_gases, Fsrad_output=Fsrad_output, &
                             mask=mask)
        endif 

!---------------------------------------------------------------------
!    call write_rad_output_file to produce a netcdf output file of 
!    radiation-package-relevant variables. note that this is called
!    only on radiation steps, so that the effects of sw renormalization
!    will not be seen in the variables of the data file written by
!    write_rad_output_file.
!---------------------------------------------------------------------
        if (do_lw_rad .and. do_sw_rad .and. do_sea_esf_rad) then
          if (Rad_control%do_aerosol) then
            call write_rad_output_file (is, ie, js, je,  &
                                        Atmos_input, Surface,   &
                                        Rad_output, Sw_output(1),  &
                                        Lw_output(1), Rad_gases,   & 
                                        Cldrad_props, Cld_spec, & 
                                        Time_next,  &
                                        Aerosol=Aerosol, &
                                        Aerosol_props=Aerosol_props, &
                                        Aerosol_diags=Aerosol_diags)
          else
            call write_rad_output_file (is, ie, js, je,  &
                                        Atmos_input,Surface, &
                                        Rad_output, Sw_output(1),   &
                                        Lw_output(1), Rad_gases,   &
                                        Cldrad_props, Cld_spec, &
                                        Time_next)
          endif
        endif ! (do_rad and do_sea_esf_rad)
!     endif  ! (running_gcm)

!---------------------------------------------------------------------
!    call deallocate_arrays to deallocate the array space associated 
!    with stack-resident derived-type variables.
!---------------------------------------------------------------------
        call deallocate_arrays (Cldrad_props, Astro, Astro2,    &
                                Aerosol_props, &
                                Lw_output, Fsrad_output, Sw_output, &
                                Aerosol_diags)

!--------------------------------------------------------------------
!    define the elements of the rad_output_type variable which will
!    return the needed radiation package output to the calling routine.
!    Radiation is currently present when running within a gcm, but
!    not present for other applications.
!--------------------------------------------------------------------
      if (present (Radiation)) then 
        nz = current_sw_zenith_step
        Radiation%coszen_angle(:,:) =      &
                                  Rad_output%coszen_angle(is:ie,js:je)
        Radiation%tdt_rad(:,:,:,1) =   &
                                  Rad_output%tdt_rad(is:ie,js:je,:,nz)
        Radiation%flux_sw_surf(:,:,1) =    &
                                Rad_output%flux_sw_surf(is:ie,js:je,nz)
        Radiation%flux_sw_surf_dir(:,:,1) =   &
                            Rad_output%flux_sw_surf_dir(is:ie,js:je,nz)
        Radiation%flux_sw_surf_dif(:,:,1) =   &
                            Rad_output%flux_sw_surf_dif(is:ie,js:je,nz)
        Radiation%flux_sw_down_vis_dir(:,:,1) =   &
                         Rad_output%flux_sw_down_vis_dir(is:ie,js:je,nz)
        Radiation%flux_sw_down_vis_dif(:,:,1) =   &
                         Rad_output%flux_sw_down_vis_dif(is:ie,js:je,nz)
        Radiation%flux_sw_down_total_dir(:,:,1) =   &
                       Rad_output%flux_sw_down_total_dir(is:ie,js:je,nz)
        Radiation%flux_sw_down_total_dif(:,:,1) =   &
                      Rad_output%flux_sw_down_total_dif(is:ie,js:je,nz)
        Radiation%flux_sw_vis (:,:,1) =   &
                               Rad_output%flux_sw_vis (is:ie,js:je,nz)
        Radiation%flux_sw_vis_dir (:,:,1) =   &
                           Rad_output%flux_sw_vis_dir (is:ie,js:je,nz)
        Radiation%flux_sw_vis_dif (:,:,1) =   &
                          Rad_output%flux_sw_vis_dif (is:ie,js:je,nz)
        Radiation%flux_lw_surf(:,:)    =   &
                                  Rad_output%flux_lw_surf(is:ie,js:je)
        Radiation%flxnet(:,:,:)         =     &
                                  Rad_output%flxnet(is:ie,js:je,:)
        Radiation%tdtlw(:,:,:)         =     &
                                  Rad_output%tdtlw(is:ie,js:je,:)   
        Radiation%ufsw(:,:,:,1) = Rad_output%ufsw(is:ie,js:je,:,nz)
        Radiation%dfsw(:,:,:,1) = Rad_output%dfsw(is:ie,js:je,:,nz)
        Radiation%flxnetcf(:,:,:)         =     &
                                  Rad_output%flxnetcf(is:ie,js:je,:)
        Radiation%ufsw_clr(:,:,:,1) = Rad_output%ufsw_clr(is:ie,js:je,:,nz)
        Radiation%dfsw_clr(:,:,:,1) = Rad_output%dfsw_clr(is:ie,js:je,:,nz)
      endif
      call mpp_clock_end (misc_clock)

!---------------------------------------------------------------------




end subroutine radiation_driver



!#####################################################################
! <SUBROUTINE NAME="define_rad_times">
!  <OVERVIEW>
!    subroutine define_rad_times determines whether radiation is to be 
!    calculated on the current timestep, and defines logical variables 
!    which determine whether various input fields to radiation_driver 
!    need to be retrieved on the current step.
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine define_rad_times determines whether radiation is to be 
!    calculated on the current timestep, and defines logical variables 
!    which determine whether various input fields to radiation_driver 
!    need to be retrieved on the current step.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  define_rad_times (Time, Time_next, Rad_time_out,    &
!                             need_aerosols, need_clouds, need_gases,  &
!                             need_basic)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current model time
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   The time used for diagnostic output
!  </IN>
!  <INOUT NAME="Rad_time_out" TYPE="time_type">
!   time at which the climatologically-determined,
!                     time-varying input fields to radiation should 
!                     apply    
!  </INOUT>
!  <OUT NAME="need_aerosols" TYPE="logical">
!   aersosol input data is needed on this step ?
!  </OUT>
!  <OUT NAME="need_clouds" TYPE="logical">
!   cloud input data is needed on this step ?
!  </OUT>
!  <OUT NAME="need_gases" TYPE="logical">
!   radiative gas input data is needed on this step ?
!  </OUT>
!  <OUT NAME="need_basic" TYPE="logical">
!   atmospheric input fields are needed on this step ?
!  </OUT>
! </SUBROUTINE>
!
subroutine define_rad_times (Time, Time_next, Rad_time_out,    &
                             need_aerosols, need_clouds, need_gases,  &
                             need_basic)

!--------------------------------------------------------------------
!    subroutine define_rad_times determines whether radiation is to be 
!    calculated on the current timestep, and defines logical variables 
!    which determine whether various input fields to radiation_driver 
!    need to be retrieved on the current step.
!-------------------------------------------------------------------- 

!---------------------------------------------------------------------
type(time_type), intent(in)     ::  Time, Time_next
type(time_type), intent(inout)  ::  Rad_time_out
logical,         intent(out)    ::  need_aerosols, need_clouds,   &
                                    need_gases, need_basic
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     Time            current model time  
!                     [ time_type, days and seconds]
!     Time_next       model time on the next atmospheric timestep
!                     [ time_type, days and seconds]
!     
!   intent(inout) variables:
!
!     Rad_time_out    time at which the climatologically-determined, 
!                     time-varying input fields to radiation should 
!                     apply    
!                     [ time_type, days and seconds]
!
!   intent(out) variables:
!
!     need_aerosols   aersosol input data is needed on this step ?
!     need_clouds     cloud input data is needed on this step ?
!     need_gases      radiative gas input data is needed on this step ?
!     need_basic      atmospheric input fields are needed on this step ?
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer        :: year, month, day, sec
      integer        :: dum, tod(3)
      integer        :: nband
      type(time_type) :: Solar_time

!---------------------------------------------------------------------
!   local variables:
!
!      day            day component of atmospheric timestep
!                     [ days ]
!      sec            seconds component of atmospheric timestep
!                     [ seconds ]
!      dum            dummy variable
!      tod            hours, minutes and seconds components of current
!                     time
!                     [ hours, minutes, seconds ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)

!--------------------------------------------------------------------
!    store the atmospheric timestep into a module variable for later
!    use.
!--------------------------------------------------------------------
      call get_time (Time_next-Time, sec, day)    
      dt = day*SECONDS_PER_DAY + sec

!--------------------------------------------------------------------
!    verify that the radiation timestep is an even multiple of the 
!    physics timestep.
!---------------------------------------------------------------------
      if (MOD(lw_rad_time_step, dt) /= 0) then
        call error_mesg ('radiation_driver_mod',  &
    ' lw radiation timestep is not integral multiple of physics step', &
                                                           FATAL)
      endif
      if (MOD(sw_rad_time_step, dt) /= 0) then
        call error_mesg ('radiation_driver_mod',  &
       ' sw radiation timestep is not integral multiple of physics step', &
                                                           FATAL)
      endif

      if (MOD(sw_rad_time_step/nzens_per_sw_rad_timestep, dt) /= 0) then
        call error_mesg ( 'radiation_driver_mod', &
         'requested nzens per sw timestep incompatible with physics &
                                                    &timestep', FATAL)
      endif

!-------------------------------------------------------------------
!    for the standalone case, new radiation outputs are calculated on 
!    every step, using climatological variable values at the time spec-
!    ified by the input argument Time. 
!-------------------------------------------------------------------
      if (always_calculate) then
        do_rad = .true.
        do_sw_rad = .true.
        do_lw_rad = .true.
        Rad_time = Time
        current_sw_zenith_step = 1
        Rad_control%do_lw_rad = do_lw_rad
        Rad_control%do_sw_rad = do_sw_rad

!--------------------------------------------------------------------
!    if running a gcm aplication, if this is the first call by this
!    processor on this time step to radiation_driver (i.e. num_pts = 0),
!    determine if this is a radiation time step by decrementing the time
!    to alarm by the current model timestep.  if the alarm "goes off", 
!    i.e., is .le. 0, set do_rad to true, indicating this is a radiation
!    step. otherwise set it to .false. . 
!--------------------------------------------------------------------
      else
        if (num_pts == 0)  then
          lwrad_alarm = lwrad_alarm -  dt
          swrad_alarm = swrad_alarm -  dt
        endif
        if (lwrad_alarm <= 0) then
          do_lw_rad = .true.
        else
          do_lw_rad = .false.
        endif
        if (swrad_alarm <= 0) then
          do_sw_rad = .true.
          current_sw_zenith_step = 1
        else
          do_sw_rad = .false.
          if (use_hires_coszen) then
            current_sw_zenith_step = current_sw_zenith_step + 1
          endif
        endif
        if (do_sw_rad .or. do_lw_rad) then
           do_rad = .true.
        else
          do_rad = .false.
        endif
      Rad_control%do_lw_rad = do_lw_rad
      Rad_control%do_sw_rad = do_sw_rad

!-------------------------------------------------------------------
!    define the time to be used in defining the time-varying input 
!    fields for the radiation calculation (Rad_time). 
!-------------------------------------------------------------------
        if (rsd) then

!--------------------------------------------------------------------
!    if this is a repeat-same-day (rsd) experiment, define Rad_time
!    as the specified year-month-day (rad_date(1:3)), and the 
!    hr-min-sec of the current time (Time).
!---------------------------------------------------------------------
          if (.not. use_rad_date)   &
            call error_mesg ('radiation_driver_mod', &  
              'if (rsd), must set rad_date(1:3) to valid date', FATAL)
            call get_date (Time, dum, dum, dum, tod(1), tod(2), tod(3))
            Rad_time = set_date (rad_date(1), rad_date(2),& 
                                 rad_date(3), tod(1), tod(2), &
                                 tod(3))

!---------------------------------------------------------------------
!    if the specified date option is active, define Rad_time to be that
!    date and time.
!----------------------------------------------------------------------
        else if (use_rad_date) then
          Rad_time = set_date (rad_date(1), rad_date(2), rad_date(3),  &
                               rad_date(4), rad_date(5), rad_date(6))

!---------------------------------------------------------------------
!    if neither of these special cases is active, define Rad_time as
!    the current time (Time).
!---------------------------------------------------------------------
        else
          Rad_time = Time
        endif  ! (rsd)
      endif  ! (always_calculate)

!---------------------------------------------------------------------
!    define the solar_constant appropriate at Rad_time, including any
!    offset defined via the namelist.
!---------------------------------------------------------------------
      if (Rad_control%time_varying_solar_constant) then
        if (size(Solar_spect%solflxband(:)) /= numbands_lean) then
          call error_mesg ('radiation_driver_mod', &
             'bands present in solar constant time data differs from &
               &model parameterization band number', FATAL)
        endif

!--------------------------------------------------------------------
!    define time to be used for solar input data.
!--------------------------------------------------------------------
        if (negative_offset) then
          Solar_time = Rad_time - Solar_offset
        else
          Solar_time = Rad_time + Solar_offset
        endif
        call get_date (Solar_time, year, month, dum, dum, dum, dum)

!--------------------------------------------------------------------
!    define input value based on year and month of Solar_time.
!--------------------------------------------------------------------
        if (year < first_yr_lean) then
          Sw_control%solar_constant = solflxtot_lean_ann_1882
          do nband=1,numbands_lean
            Solar_spect%solflxband(nband) =  &
                       Solar_spect%solflxband_lean_ann_1882(nband)
          end do
        else if (year > last_yr_lean) then
          Sw_control%solar_constant = solflxtot_lean_ann_2000           
          do nband=1,numbands_lean
            Solar_spect%solflxband(nband) =  &
                  Solar_spect%solflxband_lean_ann_2000(nband)
          end do
        else
          Sw_control%solar_constant =   &
                            solflxtot_lean(year-first_yr_lean+1, month)
          do nband=1,numbands_lean
            Solar_spect%solflxband(nband) =  &
            Solar_spect%solflxband_lean(year-first_yr_lean+1, month, nband)
          end do
        endif
      endif
          
!--------------------------------------------------------------------
!    set a logical variable indicating whether radiative gas input data
!    is needed on this step.
!--------------------------------------------------------------------
      if (do_rad) then
        need_gases = .true.
      else
        need_gases = .false.
      endif

!--------------------------------------------------------------------
!    set a logical variable indicating whether aerosol input data
!    is needed on this step.
!--------------------------------------------------------------------
      if (do_rad  .and. Rad_control%do_aerosol) then
        need_aerosols = .true.
      else
        need_aerosols = .false.
      endif

!--------------------------------------------------------------------
!    set a logical variable indicating whether cloud input data
!    is needed on this step.
!--------------------------------------------------------------------
      if (do_sea_esf_rad .and. do_rad) then
        need_clouds = .true.
      else
        need_clouds = .false.
      endif
      
!--------------------------------------------------------------------
!    set a logical variable indicating whether atmospheric input data
!    is needed on this step.
!--------------------------------------------------------------------
      if (need_clouds .or. need_aerosols .or. need_gases) then
        need_basic = .true.
      else
        need_basic = .false.
      endif
   
!---------------------------------------------------------------------
!    place the time at which radiation is to be applied into an output
!    variable.
!---------------------------------------------------------------------
      Rad_time_out = Rad_time

!---------------------------------------------------------------------



end subroutine define_rad_times


!######################################################################
! <SUBROUTINE NAME="define_atmos_input_fields">
!  <OVERVIEW>
!    define_atmos_input_fields converts the atmospheric input fields 
!    (pfull, phalf, t, q, ts) to the form needed by the radiation 
!    modules, and when needed returns radiation-ready fields of pressure
!    (press, psfc), temperature (temp, tsfc), water vapor mixing ratio 
!    (rh2o) and several auxiliary variables in the derived type 
!    structure Atmos_input. the optional input variables are present
!    when running radiative feedback studies (sa_model), and are needed
!    to allow variation of temperature and vapor fields while holding 
!    the aerosol and cloud amounts fixed.
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_atmos_input_fields converts the atmospheric input fields 
!    (pfull, phalf, t, q, ts) to the form needed by the radiation 
!    modules, and when needed returns radiation-ready fields of pressure
!    (press, psfc), temperature (temp, tsfc), water vapor mixing ratio 
!    (rh2o) and several auxiliary variables in the derived type 
!    structure Atmos_input. the optional input variables are present
!    when running radiative feedback studies (sa_model), and are needed
!    to allow variation of temperature and vapor fields while holding 
!    the aerosol and cloud amounts fixed.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  define_atmos_input_fields (is, ie, js, je, pfull, phalf, &
!                                      t, q, ts, r, gavg_rrv, Atmos_input, &
!                                      cloudtemp, cloudvapor, &
!                                      aerosoltemp, aerosolvapor, &
!                                      aerosolpress, kbot)  
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!    starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!   pressure at full levels
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!   pressure at half levels
!  </IN>
!  <IN NAME="t" TYPE="real">
!   temperature at full levels
!  </IN>
!  <IN NAME="q" TYPE="real">
!   specific humidity of water vapor at full levels
!  </IN>
!  <IN NAME="ts" TYPE="real">
!   surface temperature
!  </IN>
!  <IN NAME="r" TYPE="real">
!   tracer array
!  </IN>
!  <IN NAME="gavg_rrv" TYPE="real">
!   global average array of tracer volume mixxing ratio
!  </IN>
!  <INOUT NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input type structure, contains the 
!                    following components defined in this subroutine
!  </INOUT>
!  <IN NAME="cloudtemp" TYPE="real">
!    temperature to be seen by clouds (used in 
!                         sa_gcm feedback studies) 
!  </IN>
!  <IN NAME="cloudvapor" TYPE="real">
!   water vapor to be seen by clouds (used in 
!                         sa_gcm feedback studies) 
!  </IN>
!  <IN NAME="aerosoltemp" TYPE="real">
!   required in sa_gcm mode, absent otherwise:
!                         temperature field to be used by aerosol param-
!                         eterization 
!  </IN>
!  <IN NAME="aerosolvapor" TYPE="real">
!   required in sa_gcm mode, absent otherwise:
!                         water vapor field to be used by aerosol param-
!                         eterization 
!  </IN>
!  <IN NAME="aerosolpress" TYPE="real">
!   required in sa_gcm mode, absent otherwise:
!                         pressure field to be used by aerosol param-
!                         eterization
!  </IN>
!  <IN NAME="kbot" TYPE="integer">
!   present when running eta vertical coordinate,
!                         index of lowest model level above ground
!  </IN>
! </SUBROUTINE>
!
subroutine define_atmos_input_fields (is, ie, js, je, pfull, phalf, &
                                      t, q, ts, r, gavg_rrv, Atmos_input, &
                                      cloudtemp, cloudvapor, &
                                      aerosoltemp, aerosolvapor, &
                                      aerosolpress, kbot)     

!---------------------------------------------------------------------
!    define_atmos_input_fields converts the atmospheric input fields 
!    (pfull, phalf, t, q, ts) to the form needed by the radiation 
!    modules, and when needed returns radiation-ready fields of pressure
!    (press, psfc), temperature (temp, tsfc), water vapor mixing ratio 
!    (rh2o) and several auxiliary variables in the derived type 
!    structure Atmos_input. the optional input variables are present
!    when running radiative feedback studies (sa_model), and are needed
!    to allow variation of temperature and vapor fields while holding 
!    the aerosol and cloud amounts fixed.
!---------------------------------------------------------------------
     
integer,                 intent(in)              :: is, ie, js, je
real, dimension(:,:,:),  intent(in)              :: pfull, phalf, t, q
real, dimension(:,:),    intent(in)              :: ts
real, dimension(:),      intent(in)              :: gavg_rrv
real, dimension(:,:,:,:),intent(in)              :: r
type(atmos_input_type),  intent(inout)           :: Atmos_input
integer, dimension(:,:), intent(in), optional    :: kbot
real, dimension(:,:,:),  intent(in), optional    :: cloudtemp,    &
                                                    cloudvapor, &
                                                    aerosoltemp, &
                                                    aerosolvapor, &
                                                    aerosolpress

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      pfull        pressure at full levels [ kg / (m s^2) ]
!      phalf        pressure at half levels [ kg / (m s^2) ]
!      t            temperature at full levels [ deg K]
!      q            specific humidity of water vapor at full levels
!                   [ dimensionless ]
!      ts           surface temperature  [ deg K ]
!
!   intent(out) variables:
!
!      Atmos_input   atmos_input type structure, contains the 
!                    following components defined in this subroutine
!         psfc          surface pressure 
!                       [ (kg /( m s^2) ] 
!         tsfc          surface temperature
!                       [ deg K ]
!         temp          temperature at model levels (1:nlev), surface
!                       temperature is stored at value nlev+1; if eta
!                       coordinates, surface value stored in below 
!                       ground points
!                       [ deg K ]
!         press         pressure at model levels (1:nlev), surface 
!                       pressure is stored at index value nlev+1
!                       [ (kg /( m s^2) ] 
!         rh2o          mixing ratio of water vapor at model full levels
!                       [ non-dimensional ]
!         deltaz        model vertical grid separation
!                       [meters]
!         pflux         average of pressure at adjacent model levels
!                       [ (kg /( m s^2) ] 
!         tflux         average of temperature at adjacent model levels
!                       [ deg K ]
!         rel_hum       relative humidity
!                       [ dimensionless ]
!         cloudtemp     temperature to be seen by clouds (used in 
!                       sa_gcm feedback studies) 
!                       [ degrees K ]
!         cloudvapor    water vapor to be seen by clouds (used in 
!                       sa_gcm feedback studies) 
!                       [ nondimensional ]
!         clouddeltaz   deltaz to be used in defining cloud paths (used
!                       in sa_gcm feedback studies)
!                       [ meters ]
!         aerosoltemp   temperature to be seen by aerosols (used in 
!                       sa_gcm feedback studies) 
!                       [ degrees K ]
!         aerosolvapor  water vapor to be seen by aerosols (used in 
!                       sa_gcm feedback studies) 
!                       [ nondimensional ]
!         aerosolpress  pressure field to be seen by aerosols (used in 
!                       sa_gcm feedback studies) 
!                       [ Pa ]
!         aerosolrelhum relative humidity seen by aerosol package,
!                       used in sa_gcm feedback studies
!                       [ dimensionless ]
!
!   intent(in), optional variables:
!
!      kbot               present when running eta vertical coordinate,
!                         index of lowest model level above ground (???)
!      cloudtemp          temperature to be seen by clouds (used in 
!                         sa_gcm feedback studies) 
!                         [ degrees K ]
!      cloudvapor         water vapor to be seen by clouds (used in 
!                         sa_gcm feedback studies) 
!                         [ nondimensional ]
!      aerosoltemp        required in sa_gcm mode, absent otherwise:
!                         temperature field to be used by aerosol param-
!                         eterization 
!      aerosolvapor       required in sa_gcm mode, absent otherwise:
!                         water vapor field to be used by aerosol param-
!                         eterization 
!      aerosolpress       required in sa_gcm mode, absent otherwise:
!                         pressure field to be used by aerosol param-
!                         eterization
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables
 
      integer :: i, j, k, kb
      integer :: kmax
      logical :: override
      type(time_type)  :: Data_time
      real, dimension (size(q,1), size(q,2), size(q,3)) :: q2
      real, dimension (size(t,1), size(t,2), size(t,3)) :: t2, pfull2
      real, dimension (size(t,1), size(t,2), size(t,3)+1) ::  phalf2
      real, dimension (size(ts,1), size(ts,2)) ::  ts2
      real, dimension (id, jd, size(t,3)) :: r_proc, t_proc, press_proc
      real, dimension (id, jd, size(t,3)+1) :: phalf_proc
      real, dimension (id, jd) :: ts_proc
      integer                  :: ico2

!---------------------------------------------------------------------
!  local variables
!
!     i, j, k      do loop indices
!     kb           vertical index of lowest atmospheric level (when
!                  using eta coordinates)
!     kmax         number of model layers
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)

!----------------------------------------------------------------------
!    define the number of model layers.
!----------------------------------------------------------------------
      kmax = size(t,3)

!---------------------------------------------------------------------
!    if the temperature, cloud, or aerosol input data is to be over-
!    riden, define the time slice of data which is to be used. allocate
!    storage for the temperature data which will be needed for these
!    cases.
!---------------------------------------------------------------------
      if (doing_data_override) then
        Data_time = Rad_time                                  
        if (overriding_temps .or. overriding_aerosol .or. &
            overriding_clouds) then

!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's temper-
!    ature data from the override file. if the process fails, write
!    an error message; if it succeeds move the data fro the current
!    window into array t2.
!---------------------------------------------------------------------
          call data_override ('ATM', 'tnew', t_proc, Data_time ,  &
                              override=override)
          if ( .not. override) then
            call error_mesg ('radiation_driver_mod', &
                      'temp => t not overridden successfully', FATAL)
          else
            t2(:,:,1:kmax) = t_proc(is:ie,js:je,:)
          endif
        else
          t2 = t
        endif

!---------------------------------------------------------------------
!    if the temperature data is to be overriden, allocate storage for 
!    the surface temperature data which will be needed in this cases.
!---------------------------------------------------------------------
        if (overriding_temps) then

!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's surface
!    temperature data from the override file. if the process fails,
!    write an error message; if it succeeds move the data from the 
!    current window into array ts2, and also into array ts2.
!---------------------------------------------------------------------
          call data_override ('ATM', 'ts', ts_proc, Data_time ,  &
                              override=override)
          if ( .not. override) then
            call error_mesg ('radiation_driver_mod', &
              't_surf => ts not overridden successfully', FATAL)
          else
            ts2(:,:) = ts_proc(is:ie,js:je)
            t2(:,:,kmax+1) = ts_proc(is:ie,js:je)
          endif
        else
          ts2 = ts
        endif

!---------------------------------------------------------------------
!    if the humidity, cloud, or aerosol input data is to be over-
!    riden, define the time slice of data which is to be used. allocate
!    storage for the humidity data which will be needed for these
!    cases.
!---------------------------------------------------------------------
        if (overriding_sphum .or. overriding_aerosol .or. &
            overriding_clouds) then

!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's surface
!    humidity data from the override file. if the process fails,
!    write an error message; if it succeeds move the data from the 
!    current window into array q2.
!---------------------------------------------------------------------
          call data_override ('ATM', 'q', r_proc, Data_time ,  &
                              override=override)
          if ( .not. override) then
            call error_mesg ('radiation_driver_mod', &
                 'sphum => q not overridden successfully', FATAL)
          else
            q2(:,:,:) = r_proc(is:ie,js:je,:)
          endif
        else
          q2 = q
        endif

!---------------------------------------------------------------------
!    if the aerosol input data is to be overriden, allocate storage 
!    for the pressure data which will be needed in this case.
!---------------------------------------------------------------------
        if (overriding_aerosol) then

!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's pressure
!    data from the override file. if the process fails, write an error
!    message; if it succeeds move the data from the current window into
!    array pfull2 and phalf2.
!---------------------------------------------------------------------
          call data_override ('ATM', 'pfull2', press_proc,  &
                              Data_time , override=override)
          if ( .not. override) then
            call error_mesg ('radiation_driver_mod', &
                 'pressm => pfull2 not overridden successfully', FATAL)
          else
            pfull2(:,:,:) = press_proc(is:ie,js:je,:)
          endif
          call data_override ('ATM', 'phalf2', phalf_proc,  &
                              Data_time, override=override)
          if ( .not. override) then
            call error_mesg ('radiation_driver_mod', &
                 'phalfm => phalf2 not overridden successfully', FATAL)
          else
            phalf2(:,:,kmax+1) = phalf_proc(is:ie,js:je,kmax+1)
          endif
        else
          pfull2 = pfull
          phalf2(:,:,kmax+1) = phalf(:,:,kmax+1)
        endif
        
!---------------------------------------------------------------------
!    if not doing data_override, define the arrays which will be 
!    used to define the components of Atmos_input%.
!---------------------------------------------------------------------
      else
        t2 = t
        ts2 = ts
        q2 = q
        pfull2 = pfull
        phalf2(:,:,kmax+1) = phalf(:,:,kmax+1)
      endif

!---------------------------------------------------------------------
!    allocate space for the components of the derived type variable
!    Atmos_input.
!---------------------------------------------------------------------
      allocate ( Atmos_input%press(size(t,1), size(t,2), size(t,3)+1) )
      allocate ( Atmos_input%phalf(size(t,1), size(t,2), size(t,3)+1) )
      allocate ( Atmos_input%temp (size(t,1), size(t,2), size(t,3)+1) )
      allocate ( Atmos_input%rh2o (size(t,1), size(t,2), size(t,3)  ) )
      allocate ( Atmos_input%rel_hum(size(t,1), size(t,2),    &
                                                         size(t,3)  ) )
      allocate ( Atmos_input%cloudtemp(size(t,1), size(t,2),   &
                                                         size(t,3)  ) )
      allocate ( Atmos_input%cloudvapor(size(t,1), size(t,2),   &
                                                         size(t,3)  ) )
      allocate ( Atmos_input%clouddeltaz(size(t,1), size(t,2),   &
                                                         size(t,3)  ) )
      allocate ( Atmos_input%aerosoltemp(size(t,1), size(t,2),   &
                                                    size(t,3)  ) )
      allocate ( Atmos_input%aerosolpress(size(t,1), size(t,2),    &
                                                     size(t,3)+1) )
      allocate ( Atmos_input%aerosolvapor(size(t,1), size(t,2),   &
                                                     size(t,3)  ) )
      allocate ( Atmos_input%aerosolrelhum(size(t,1), size(t,2),   &
                                                      size(t,3)  ) )
      allocate ( Atmos_input%deltaz(size(t,1), size(t,2), size(t,3) ) )
      allocate ( Atmos_input%pflux (size(t,1), size(t,2), size(t,3)+1) )
      allocate ( Atmos_input%tflux (size(t,1), size(t,2), size(t,3)+1) )
      allocate ( Atmos_input%psfc (size(t,1), size(t,2)             ) )
      allocate ( Atmos_input%tsfc (size(t,1), size(t,2)             ) )

      if (use_co2_tracer_field) then
         allocate ( Atmos_input%tracer_co2(size(t,1), size(t,2), size(t,3) ) )
      endif
!---------------------------------------------------------------------
!    define the cloudtemp component of Atmos_input. 
!---------------------------------------------------------------------
      if (present (cloudtemp) ) then
        Atmos_input%cloudtemp(:,:,:)   = cloudtemp(:,:,:)
      else
        if (overriding_clouds) then
          Atmos_input%cloudtemp(:,:,:)   = t2(:,:,:)
        else
          Atmos_input%cloudtemp(:,:,:)   = t(:,:,:)
        endif
      endif

!---------------------------------------------------------------------
!    define the cloudvapor component of Atmos_input.
!---------------------------------------------------------------------
      if (present (cloudvapor) ) then
        Atmos_input%cloudvapor(:,:,:)   = cloudvapor(:,:,:)
      else
        if (overriding_clouds) then
          Atmos_input%cloudvapor(:,:,:)   = q2(:,:,:)
        else
          Atmos_input%cloudvapor(:,:,:)   = q(:,:,:)
        endif
      endif

!---------------------------------------------------------------------
!    define the aerosoltemp component of Atmos_input.
!---------------------------------------------------------------------
      if (present (aerosoltemp) ) then
        Atmos_input%aerosoltemp(:,:,:)   = aerosoltemp(:,:,:)
      else
        if (overriding_aerosol) then
          Atmos_input%aerosoltemp(:,:,:)   = t2(:,:,:)
        else
          Atmos_input%aerosoltemp(:,:,:)   = t(:,:,:)
        endif
      endif
 
!---------------------------------------------------------------------
!    define the aerosolvapor component of Atmos_input.
!---------------------------------------------------------------------
      if (present (aerosolvapor) ) then
        Atmos_input%aerosolvapor(:,:,:)   = aerosolvapor(:,:,:)
      else
        if (overriding_aerosol) then
          Atmos_input%aerosolvapor(:,:,:)   = q2(:,:,:)
        else
          Atmos_input%aerosolvapor(:,:,:)   = q(:,:,:)
        endif
      endif

!---------------------------------------------------------------------
!    define values of surface pressure and temperature.
!--------------------------------------------------------------------
      if (present(kbot)) then
        do j=1,je-js+1
          do i=1,ie-is+1
            kb = kbot(i,j)
            Atmos_input%psfc(i,j) = phalf2(i,j,kb+1)
          end do
        end do
      else
        Atmos_input%psfc(:,:) = phalf2(:,:,kmax+1)
      endif

      Atmos_input%tsfc(:,:) = ts2(:,:)

!------------------------------------------------------------------
!    define the atmospheric pressure and temperature arrays.
!------------------------------------------------------------------
      do k=1,kmax 
        Atmos_input%press(:,:,k) = pfull2(:,:,k)
        Atmos_input%phalf(:,:,k) = phalf(:,:,k)
        Atmos_input%temp (:,:,k) = t2(:,:,k)
      end do
      Atmos_input%press(:,:,kmax+1) = phalf2(:,:,kmax+1)
      Atmos_input%phalf(:,:,kmax+1) = phalf2(:,:,kmax+1)
      Atmos_input%temp (:,:,kmax+1) = ts2 (:,:)

!---------------------------------------------------------------------
!    define the aerosolpress component of Atmos_input.
!---------------------------------------------------------------------
      if (present (aerosolpress) ) then
        do k=1,kmax
          Atmos_input%aerosolpress(:,:,k)   = aerosolpress(:,:,k)
        end do
      else
        if (overriding_aerosol) then
          do k=1,kmax
            Atmos_input%aerosolpress(:,:,k)   = pfull2(:,:,k)
          end do
          Atmos_input%aerosolpress(:,:,kmax+1)   = phalf2(:,:,kmax+1)
        else
          do k=1,kmax
            Atmos_input%aerosolpress(:,:,k)   = pfull(:,:,k)
          end do
          Atmos_input%aerosolpress(:,:,kmax+1)   = phalf(:,:,kmax+1)
        endif
      endif
 
!------------------------------------------------------------------
!    if in eta coordinates, fill in underground temperatures with 
!    surface value.
!------------------------------------------------------------------
      if (present(kbot)) then
        do j=1,je-js+1
          do i=1,ie-is+1
            kb = kbot(i,j)
            if (kb < kmax) then
              do k=kb+1,kmax
                Atmos_input%temp(i,j,k) = Atmos_input%temp(i,j,kmax+1)
              end do
            endif
          end do
        end do
      endif

!------------------------------------------------------------------
!    when running the gcm, convert the input water vapor specific 
!    humidity field to mixing ratio. it is assumed that water vapor 
!    mixing ratio is the input in the standalone case.
!------------------------------------------------------------------
        if (use_mixing_ratio) then
          Atmos_input%rh2o (:,:,:) = q2(:,:,:)
        else
          if (.not. overriding_sphum .and. &
              .not. overriding_clouds .and.  &
              .not. overriding_aerosol) then
            Atmos_input%rh2o (:,:,:) = q2(:,:,:)/(1.0 - q2(:,:,:))
          else ! for override, values are already mixing ratio
            Atmos_input%rh2o (:,:,:) = q2(:,:,:)
          endif
          if (.not. overriding_clouds) then
            Atmos_input%cloudvapor(:,:,:) =    &
                                 Atmos_input%cloudvapor(:,:,:)/  &
                            (1.0 - Atmos_input%cloudvapor(:,:,:))
          endif
          if (.not. overriding_aerosol) then
            Atmos_input%aerosolvapor(:,:,:) =    &
                                 Atmos_input%aerosolvapor(:,:,:)/  &
                            (1.0 - Atmos_input%aerosolvapor(:,:,:))
          endif
        endif
 
!------------------------------------------------------------------
!    be sure that the magnitude of the water vapor mixing ratio field 
!    to be input to the radiation code is no smaller than the value of 
!    rh2o_lower_limit, which is 2.0E-07 when running the sea_esf
!    radiation code and 3.0e-06 when running the original radiation
!    code. Likewise, the temperature that the radiation code sees is
!    constrained to lie between 100K and 370K. these are the limits of
!    the tables referenced within the radiation package.
!      exception:
!    if do_h2o is false, the lower limit of h2o is zero, and radiation
!    tables will not be called.
!-----------------------------------------------------------------------
      if (do_rad) then
        Atmos_input%rh2o(:,:,ks:ke) =    &
            MAX(Atmos_input%rh2o(:,:,ks:ke), rh2o_lower_limit)
        Atmos_input%cloudvapor(:,:,ks:ke) =    &
            MAX(Atmos_input%cloudvapor(:,:,ks:ke), rh2o_lower_limit)
        Atmos_input%aerosolvapor(:,:,ks:ke) =    &
                    MAX(Atmos_input%aerosolvapor(:,:,ks:ke), rh2o_lower_limit)
        Atmos_input%temp(:,:,ks:ke) =     &
                    MAX(Atmos_input%temp(:,:,ks:ke), temp_lower_limit)
        Atmos_input%temp(:,:,ks:ke) =     &
                    MIN(Atmos_input%temp(:,:,ks:ke), temp_upper_limit)
        Atmos_input%cloudtemp(:,:,ks:ke) =     &
                    MAX(Atmos_input%cloudtemp(:,:,ks:ke), temp_lower_limit)
        Atmos_input%cloudtemp(:,:,ks:ke) =     &
                    MIN(Atmos_input%cloudtemp(:,:,ks:ke), temp_upper_limit)
        Atmos_input%aerosoltemp(:,:,ks:ke) =     &
                    MAX(Atmos_input%aerosoltemp(:,:,ks:ke), temp_lower_limit)
     Atmos_input%aerosoltemp(:,:,ks:ke) =     &
                    MIN(Atmos_input%aerosoltemp(:,:,ks:ke), temp_upper_limit)
      endif

!--------------------------------------------------------------------
!    call calculate_aulixiary_variables to compute pressure and 
!    temperature arrays at flux levels and an array of model deltaz.
!--------------------------------------------------------------------
      if (do_rad) then
        call calculate_auxiliary_variables (Atmos_input)
      endif

!RSH
!RSH   define here the values for Atmos_input%tracer_co2.
!RSH
!fil   the error message should never be printed as that code should never
!      be executed, it's an extra guard against user error.
      if (use_co2_tracer_field ) then
         ico2 = get_tracer_index(MODEL_ATMOS, 'co2')
         if(ico2 /= NO_TRACER) then
            Atmos_input%tracer_co2(:,:,:) = r(:,:,:,ico2)
            Atmos_input%g_rrvco2 = gavg_rrv(ico2)
         else
            call error_mesg('radiation_driver', &
              'ico2 cannot be NO_TRACER when use_co2_tracer_field is .true.', FATAL)
         endif
      endif


!----------------------------------------------------------------------


end subroutine define_atmos_input_fields 




!#####################################################################
! <SUBROUTINE NAME="define_surface">
!  <OVERVIEW>
!    define_surface stores the input values of land fraction and 
!    surface albedo in a surface_type structure Surface. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_surface stores the input values of land fraction and 
!    surface albedo in a surface_type structure Surface. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_surface (is, ie, js, je, albedo, land, Surface)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!    starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="albedo" TYPE="real">
!   surface albedo
!  </IN>
!  <IN NAME="land" TYPE="real">
!   fraction of grid box which is land 
!  </IN>
!  <INOUT NAME="Surface" TYPE="surface_type">
!   surface_type structure to be valued
!  </INOUT>
! </SUBROUTINE>
!
subroutine define_surface (is, ie, js, je, albedo, albedo_vis_dir,   &
                           albedo_nir_dir, albedo_vis_dif, &
                           albedo_nir_dif, land, Surface)

!---------------------------------------------------------------------
!    define_surface stores the input values of land fraction and 
!    surface albedo in a surface_type structure Surface.  
!---------------------------------------------------------------------
     
integer,                 intent(in)              :: is, ie, js, je
real, dimension(:,:),    intent(in)              :: albedo, land, &
                                                    albedo_vis_dir,    &
                                                    albedo_nir_dir, &
                                                    albedo_vis_dif,    &
                                                    albedo_nir_dif
type(surface_type),      intent(inout)           :: Surface     

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      albedo       surface albedo  [ dimensionless ]
!      albedo_vis_dir surface visible direct albedo  [ dimensionless ]
!      albedo_nir_dir surface nir direct albedo  [ dimensionless ]
!      albedo_vis_dif surface visible diffuse albedo  [ dimensionless ]
!      albedo_nir_dif surface nir diffuse albedo  [ dimensionless ]
!      land         fraction of grid box which is land [ dimensionless ]
!
!   intent(out) variables:
!
!      Surface       surface_type structure, contains the 
!                    following components defined in this subroutine
!         asfc          surface albedo
!                       [ non-dimensional ]
!         asfc_vis_dir  surface direct visible albedo
!                       [ non-dimensional ]
!         asfc_nir_dir  surface direct nir albedo
!                       [ non-dimensional ]
!         asfc_vis_dif  surface diffuse visible albedo
!                       [ non-dimensional ]
!         asfc_nir_dif  surface diffuse nir albedo
!                       [ non-dimensional ]
!         land          fraction of grid box covered by land
!                       [ non-dimensional ]
!
!---------------------------------------------------------------------

     logical :: override
     type(time_type)  :: Data_time
     real, dimension (size(albedo,1), size(albedo,2)) :: albedo_vis_dir2,   &
                                                         albedo_nir_dir2, &
                                                         albedo_vis_dif2,  &
                                                         albedo_nir_dif2
     real, dimension (id,jd) :: albedo_vis_dir_proc, &
                                albedo_nir_dir_proc, &
                                albedo_vis_dif_proc,  &
                                albedo_nir_dif_proc

!-------------------------------------------------------------------
!    verify that the module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)

      if (do_rad) then
        if (doing_data_override) then        
!---------------------------------------------------------------------
!    if the albedo data is to be overriden, define the time from which
!    the data is to be retrieved.
!---------------------------------------------------------------------
          if (overriding_albedo) then
            Data_time = Rad_time 


!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's surface
!    albedo data from the override file. if the process fails,
!    write an error message; if it succeeds move the data from the 
!    current window into array albedo2.
!---------------------------------------------------------------------
!           call data_override ('ATM', 'albedonew', albedo_proc,   &
!                             Data_time, override=override)
!           if ( .not. override) then
!             call error_mesg ('radiation_driver_mod', &
!             'cvisrfgd => albedo not overridden successfully', FATAL)
!           else
!             albedo2(:,:) =      albedo_proc(is:ie,js:je)
!           endif
            
            call data_override ('ATM', 'albedo_nir_dir_new',   &
                                albedo_nir_dir_proc,   &
                                Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
                'nirdir => albedo not overridden successfully', FATAL)
            else
              albedo_nir_dir2(:,:) = albedo_nir_dir_proc(is:ie,js:je)
            endif

            call data_override ('ATM', 'albedo_nir_dif_new',   &
                                albedo_nir_dif_proc,   &
                                Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
                'nirdif => albedo not overridden successfully', FATAL)
            else
              albedo_nir_dif2(:,:) = albedo_nir_dif_proc(is:ie,js:je)
            endif

            call data_override ('ATM', 'albedo_vis_dir_new',   &
                                albedo_vis_dir_proc,   &
                                Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
               'visdir => albedo not overridden successfully', FATAL)
            else
              albedo_vis_dir2(:,:) = albedo_vis_dir_proc(is:ie,js:je)
            endif

            call data_override ('ATM', 'albedo_vis_dif_new',   &
                                albedo_vis_dif_proc,   &
                                Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
              'visdif => albedo not overridden successfully', FATAL)
            else
              albedo_vis_dif2(:,:) = albedo_vis_dif_proc(is:ie,js:je)
           endif

!--------------------------------------------------------------------
!    if albedo data is not being overriden, define albedo2 to be the 
!    model value of albedo.
!--------------------------------------------------------------------
          else
!           albedo2 = albedo
            albedo_vis_dir2 = albedo_vis_dir
            albedo_nir_dir2 = albedo_nir_dir
            albedo_vis_dif2 = albedo_vis_dif
            albedo_nir_dif2 = albedo_nir_dif
          endif
        else ! (doing data_override)       
!         albedo2 = albedo
          albedo_vis_dir2 = albedo_vis_dir
          albedo_nir_dir2 = albedo_nir_dir
          albedo_vis_dif2 = albedo_vis_dif
          albedo_nir_dif2 = albedo_nir_dif
        endif
      else ! (do_rad)
!       albedo2 = albedo
        albedo_vis_dir2 = albedo_vis_dir
        albedo_nir_dir2 = albedo_nir_dir
        albedo_vis_dif2 = albedo_vis_dif
        albedo_nir_dif2 = albedo_nir_dif
      endif ! (do_rad)

!---------------------------------------------------------------------
!    allocate space for the components of the derived type variable
!    Surface.     
!---------------------------------------------------------------------
      allocate (Surface%asfc (size(albedo,1), size(albedo,2)) )
      allocate (Surface%asfc_vis_dir (size(albedo,1), size(albedo,2) ) )
      allocate (Surface%asfc_nir_dir (size(albedo,1), size(albedo,2) ) )
      allocate (Surface%asfc_vis_dif (size(albedo,1), size(albedo,2) ) )
      allocate (Surface%asfc_nir_dif (size(albedo,1), size(albedo,2) ) )
      allocate (Surface%land (size(albedo,1), size(albedo,2)) )

 
!------------------------------------------------------------------
!    define the fractional land area of each grid box and the surface
!    albedo from the input argument values.
!------------------------------------------------------------------
      Surface%land(:,:) = land(:,:)
      Surface%asfc(:,:) = albedo (:,:)

!pjp  Should the albedos below all be set to albedo2,
!pjp  or should they be included in the override data,
!pjp  or should it not be changed?

      Surface%asfc_vis_dir(:,:) = albedo_vis_dir2(:,:)
      Surface%asfc_nir_dir(:,:) = albedo_nir_dir2(:,:)
      Surface%asfc_vis_dif(:,:) = albedo_vis_dif2(:,:)
      Surface%asfc_nir_dif(:,:) = albedo_nir_dif2(:,:)
     

!----------------------------------------------------------------------


end subroutine define_surface    



!#####################################################################
! <SUBROUTINE NAME="surface_dealloc">
!  <OVERVIEW>
!    surface_dealloc deallocates the array components of the
!    surface_type structure Surface.
!  </OVERVIEW>
!  <DESCRIPTION>
!    surface_dealloc deallocates the array components of the
!    surface_type structure Surface.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call surface_dealloc (Surface)
!  </TEMPLATE>
!  <INOUT NAME="Surface" TYPE="surface_type">
!   surface_type structure to be deallocated
!  </INOUT>
! </SUBROUTINE>
!
subroutine surface_dealloc (Surface)

!----------------------------------------------------------------------
!    surface_dealloc deallocates the array components of the
!    surface_type structure Surface.
!----------------------------------------------------------------------

type(surface_type), intent(inout) :: Surface

!--------------------------------------------------------------------
!   intent(inout) variable:
!
!      Surface        surface_type structure, contains variables 
!                     defining the surface albedo and land fraction
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)

!-------------------------------------------------------------------
!    deallocate components of surface_type structure.
!-------------------------------------------------------------------
      deallocate (Surface%asfc)
      deallocate (Surface%asfc_vis_dir )
      deallocate (Surface%asfc_nir_dir )
      deallocate (Surface%asfc_vis_dif )
      deallocate (Surface%asfc_nir_dif )
      deallocate (Surface%land)

!--------------------------------------------------------------------


end subroutine surface_dealloc 



!#####################################################################
! <SUBROUTINE NAME="atmos_input_dealloc">
!  <OVERVIEW>
!    atmos_input_dealloc deallocates the array components of the
!    atmos_input_type structure Atmos_input.
!  </OVERVIEW>
!  <DESCRIPTION>
!    atmos_input_dealloc deallocates the array components of the
!    atmos_input_type structure Atmos_input.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call atmos_input_dealloc (Atmos_input)
!  </TEMPLATE>
!  <INOUT NAME="Atmos_input" TYPE="atmos_input_type">
!      atmos_input_type structure, contains variables 
!                     defining the atmospheric pressure, temperature
!                     and moisture distribution.
!  </INOUT>
! </SUBROUTINE>
!
subroutine atmos_input_dealloc (Atmos_input)

!----------------------------------------------------------------------
!    atmos_input_dealloc deallocates the array components of the
!    atmos_input_type structure Atmos_input.
!----------------------------------------------------------------------

type(atmos_input_type), intent(inout) :: Atmos_input

!--------------------------------------------------------------------
!   intent(inout) variable:
!
!      Atmos_input    atmos_input_type structure, contains variables 
!                     defining the atmospheric pressure, temperature
!                     and moisture distribution.
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    deallocate components of atmos_input_type structure.
!---------------------------------------------------------------------
      deallocate (Atmos_input%press      )
      deallocate (Atmos_input%phalf      )
      deallocate (Atmos_input%temp       )
      deallocate (Atmos_input%rh2o       )
      deallocate (Atmos_input%rel_hum    )
      deallocate (Atmos_input%pflux      )
      deallocate (Atmos_input%tflux      )
      deallocate (Atmos_input%deltaz     )
      deallocate (Atmos_input%psfc       )
      deallocate (Atmos_input%tsfc       )
      deallocate (Atmos_input%cloudtemp  )
      deallocate (Atmos_input%cloudvapor )
      deallocate (Atmos_input%clouddeltaz)
      deallocate (Atmos_input%aerosoltemp)
      deallocate (Atmos_input%aerosolvapor )
      deallocate (Atmos_input%aerosolpress )
      deallocate (Atmos_input%aerosolrelhum )
      if(ASSOCIATED(Atmos_input%tracer_co2)) deallocate(Atmos_input%tracer_co2)
!--------------------------------------------------------------------


end subroutine atmos_input_dealloc 


!#####################################################################

 
subroutine microphys_dealloc (Model_microphys)
 
type(microphysics_type), intent(inout) :: Model_microphys
 
!----------------------------------------------------------------------
!   microphys_dealloc calls model_micro_dealloc to deallocate the 
!   array components of the microphysics_type structure Model_microphys.
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
                 'module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    deallocate the components of module variable Model_microphys.
!---------------------------------------------------------------------
      call model_micro_dealloc (Model_microphys)

!--------------------------------------------------------------------
 

end subroutine microphys_dealloc


!#####################################################################
! <SUBROUTINE NAME="radiation_driver_end">
!  <OVERVIEW>
!   radiation_driver_end is the destructor for radiation_driver_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   radiation_driver_end is the destructor for radiation_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_driver_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine radiation_driver_end

!----------------------------------------------------------------------
!    radiation_driver_end is the destructor for radiation_driver_mod.
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    verify that this module has been initialized. if not, exit.
!-------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ('radiation_driver_mod',  &
               'module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    write restart file if desired; the file is not necessary if job 
!    ends on step prior to radiation ts, or if restart seamlessness 
!    is not required.
!---------------------------------------------------------------------
    if (using_restart_file) then
! Make sure that the restart_versions variable is up to date.
      vers = restart_versions(size(restart_versions(:)))
      if ( do_netcdf_restart ) then
        call radiation_driver_restart
      else
        call write_restart_file
      endif
    endif

!---------------------------------------------------------------------
!    wrap up modules initialized by this module.
!---------------------------------------------------------------------
      call astronomy_end

!---------------------------------------------------------------------
!    wrap up modules specific to the radiation package in use.
!---------------------------------------------------------------------
      if (do_sea_esf_rad) then
        call cloudrad_package_end
        call aerosolrad_package_end
        call rad_output_file_end
        call sea_esf_rad_end
      else
        call original_fms_rad_end
      endif


!---------------------------------------------------------------------
!    release space for renormalization arrays, if that option is active.
!---------------------------------------------------------------------
!     if (renormalize_sw_fluxes .or. use_hires_coszen .or. &
      if (renormalize_sw_fluxes .or.                       &
          all_step_diagnostics)  then
        deallocate (solar_save, flux_sw_surf_save, sw_heating_save, &
                    dum_idjd,   &
                    flux_sw_surf_dir_save,   &
                    flux_sw_surf_dif_save,   &
                    flux_sw_down_vis_dir_save,   &
                    flux_sw_down_vis_dif_save,   &
                    flux_sw_down_total_dir_save, &
                    flux_sw_down_total_dif_save, &
                    flux_sw_vis_save, &
                    flux_sw_vis_dir_save, &
                    flux_sw_vis_dif_save, &
                    tot_heating_save, dfsw_save, ufsw_save,   &
                    swdn_special_save, swup_special_save,          &
                    fsw_save, hsw_save)
        if (do_swaerosol_forcing) then
          deallocate (dfsw_ad_save, ufsw_ad_save)
        endif
        if (do_clear_sky_pass) then
          deallocate (sw_heating_clr_save, tot_heating_clr_save,  &
                      dfswcf_save, ufswcf_save, fswcf_save,   &
                      swdn_special_clr_save, swup_special_clr_save,   &
                     flux_sw_down_total_dir_clr_save, &
                     flux_sw_down_total_dif_clr_save, &
                      flux_sw_down_vis_clr_save,   &
                      hswcf_save)
          if (do_swaerosol_forcing) then
            deallocate (dfswcf_ad_save, ufswcf_ad_save)
          endif
        endif
      endif

!---------------------------------------------------------------------
!    release space needed when all_step_diagnostics is active.
!---------------------------------------------------------------------
      if (all_step_diagnostics)  then
        deallocate (olr_save, lwups_save, lwdns_save, flxnet_save, &
                                                           tdtlw_save)
        deallocate (netlw_special_save)
        if (do_lwaerosol_forcing) then
          deallocate (olr_ad_save, lwups_ad_save, lwdns_ad_save)
        endif
        if (do_clear_sky_pass) then
          deallocate (olr_clr_save, lwups_clr_save, lwdns_clr_save, &
                      flxnetcf_save, tdtlw_clr_save)
          deallocate (netlw_special_clr_save)
          if (do_lwaerosol_forcing) then
            deallocate (olr_ad_clr_save, lwups_ad_clr_save,  &
                        lwdns_ad_clr_save)
          endif
        endif
      endif

!---------------------------------------------------------------------
!    release space used for module variables that hold data between
!    timesteps.
!---------------------------------------------------------------------
        deallocate (Rad_output%tdt_rad, Rad_output%tdt_rad_clr,  & 
                    Rad_output%tdtsw, Rad_output%tdtsw_clr, &
                    Rad_output%ufsw, Rad_output%dfsw, &
                    Rad_output%ufsw_clr, Rad_output%dfsw_clr, &
                    Rad_output%tdtlw_clr, &
                    Rad_output%flxnet, Rad_output%flxnetcf, &
                    Rad_output%tdtlw, Rad_output%flux_sw_surf,  &
                    Rad_output%flux_sw_surf_dir,  &
                    Rad_output%flux_sw_surf_dif,  &
                    Rad_output%flux_sw_down_vis_dir,  &
                    Rad_output%flux_sw_down_vis_dif,  &
                    Rad_output%flux_sw_down_total_dir,  &
                    Rad_output%flux_sw_down_total_dif,  &
                   Rad_output%flux_sw_down_total_dir_clr,  &
                   Rad_output%flux_sw_down_total_dif_clr,  &
                    Rad_output%flux_sw_down_vis_clr,  &
                    Rad_output%flux_sw_vis,  &
                    Rad_output%flux_sw_vis_dir,  &
                    Rad_output%flux_sw_vis_dif,  &
                    Rad_output%flux_lw_surf, Rad_output%coszen_angle)

!----------------------------------------------------------------------
!    deallocate arrays related to the time_varying solar constant.
!----------------------------------------------------------------------
      if (time_varying_solar_constant) then
        deallocate (solflxtot_lean, Solar_spect%solflxband_lean, &
                    Solar_spect%solflxband_lean_ann_1882, &
                    Solar_spect%solflxband_lean_ann_2000)  
      endif

!---------------------------------------------------------------------
!    call rad_utilities_end to uninitialize that module.
!---------------------------------------------------------------------
        call rad_utilities_end

!----------------------------------------------------------------------
!    set initialization status flag.
!----------------------------------------------------------------------
      module_is_initialized = .false.



end subroutine radiation_driver_end



!######################################################################

subroutine return_cosp_inputs (  &
                      is, ie, js, je, donner_meso_is_largescale,  &
                            Time_diag, Atmos_input, stoch_cloud_type, &
                      stoch_conc_drop, stoch_conc_ice, stoch_size_drop,&
                      stoch_size_ice, tau_stoch, lwem_stoch, &
                      Model_microphys, &
                      do_cosp, do_modis_yim, Lsc_microphys)

!---------------------------------------------------------------------
!    subroutine return_cosp_inputs calculates and returns the fields 
!    needed as input by the COSP simulator.
!---------------------------------------------------------------------

integer, intent(in)                      :: is,ie, js, je
logical, intent(in)                      :: donner_meso_is_largescale
logical, intent(in)                      :: do_cosp, do_modis_yim
type(time_type), intent(in)              :: Time_diag
type(atmos_input_type), intent(inout)    :: Atmos_input     
type(microphysics_type), intent(inout)   :: Model_microphys
type(microphysics_type), intent(in)      :: Lsc_microphys
real, dimension(:,:,:,:), intent(inout)  ::    &
                                stoch_cloud_type, stoch_conc_drop, &
                                stoch_conc_ice, stoch_size_drop,  &
                                stoch_size_ice, tau_stoch, lwem_stoch

!-------------------------------------------------------------------
!   local variables
!-------------------------------------------------------------------

!-------------------------------------------------------------------
      call obtain_cloud_tau_and_em (is, js, Model_microphys, &
                                    Atmos_input, &
                                    tau_stoch(is:ie,js:je,:,:),  &
                                    lwem_stoch(is:ie,js:je,:,:) )

!-------------------------------------------------------------------
      if (do_cosp) then

!---------------------------------------------------------------------
!    save the stochastic cloud type in each subcolumn.
!    output values of 0 --> no cloud
!           values of 1 --> stratiform cloud
!           values of 2 --> convective cloud
!    input values are 0(none), 1(strat), 2(donnermeso), 3(donnercell), 
!    4(uw)
!---------------------------------------------------------------------
        stoch_cloud_type(is:ie,js:je,:,:) =   &
                         Model_microphys%stoch_cloud_type(:,:,:,:)
         
!---------------------------------------------------------------------
!    donner meso clouds may be treated either as large-scale or
!    convective clouds, dependent on donner_meso_is_largescale.
!---------------------------------------------------------------------
        if (donner_meso_is_largescale) then
          where (stoch_cloud_type(is:ie,js:je,:,:) == 2)
            stoch_cloud_type(is:ie,js:je,:,:) = 1
          end where
          where (stoch_cloud_type(is:ie,js:je,:,:) >= 3)
            stoch_cloud_type(is:ie,js:je,:,:) = 2
          end where
        else
          where (stoch_cloud_type(is:ie,js:je,:,:) >= 2)
            stoch_cloud_type(is:ie,js:je,:,:) = 2
          end where
        endif    

!---------------------------------------------------------------------
!    save the particle concentrations and sizes seen by the radiation
!    package in each stochastic column.
!---------------------------------------------------------------------
        stoch_conc_drop(is:ie,js:je,:,:) =  &
                             Model_microphys%stoch_conc_drop(:,:,:,:)
        stoch_conc_ice (is:ie,js:je,:,:) =  &
                             Model_microphys%stoch_conc_ice (:,:,:,:)
        stoch_size_drop(is:ie,js:je,:,:) =  &
                             Model_microphys%stoch_size_drop(:,:,:,:)
        stoch_size_ice (is:ie,js:je,:,:) =  &
                             Model_microphys%stoch_size_ice (:,:,:,:)

      endif

!-------------------------------------------------------------------
      if (do_modis_yim) then
        call  modis_yim (is, js, Time_diag, Tau_stoch(is:ie,js:je,:,:),&
                         Model_microphys, Atmos_input)
      endif
      call modis_cmip (is, js, Time_diag, Lsc_microphys, &
                       Atmos_input)

!-------------------------------------------------------------------


end subroutine return_cosp_inputs 



!#######################################################################
!#######################################################################
! <SUBROUTINE NAME="radiation_driver_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine radiation_driver_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

! Make sure that the restart_versions variable is up to date.
  vers = restart_versions(size(restart_versions(:)))
  if ( do_netcdf_restart ) then
    call write_restart_nc(timestamp)
  else
    call error_mesg ('radiation_driver_restart', &
         'Native intermediate restart files are not supported.', FATAL)
  endif  

end subroutine radiation_driver_restart
! </SUBROUTINE> NAME="radiation_driver_restart"

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine write_restart_file

     integer :: unit

!----------------------------------------------------------------------
!    when running in gcm, write a restart file. this is not done in the
!    standalone case.
!---------------------------------------------------------------------
     if(mpp_pe() == mpp_root_pe()) then
       call error_mesg('radiation_driver_mod', 'Writing native formatted restart file.', NOTE)
     endif
        unit = open_restart_file   &
                         ('RESTART/radiation_driver.res', 'write')

!---------------------------------------------------------------------
!    only the root pe will write control information -- the last value 
!    in the list of restart versions and the alarm information.
!---------------------------------------------------------------------
        if (mpp_pe() == mpp_root_pe() ) then
          write (unit) restart_versions(size(restart_versions(:)))
!         write (unit) rad_alarm, rad_time_step
          write (unit) lwrad_alarm, rad_time_step
        endif

!---------------------------------------------------------------------
!    write out the restart data.
!---------------------------------------------------------------------
        call write_data (unit, Rad_output%tdt_rad)
        call write_data (unit, Rad_output%tdtlw)
        call write_data (unit, Rad_output%flux_sw_surf)
        call write_data (unit, Rad_output%flux_sw_surf_dir)
        call write_data (unit, Rad_output%flux_sw_surf_dif)
        call write_data (unit, Rad_output%flux_sw_down_vis_dir)
        call write_data (unit, Rad_output%flux_sw_down_vis_dif)
        call write_data (unit, Rad_output%flux_sw_down_total_dir)
        call write_data (unit, Rad_output%flux_sw_down_total_dif)
        call write_data (unit, Rad_output%flux_sw_vis)
        call write_data (unit, Rad_output%flux_sw_vis_dir)
        call write_data (unit, Rad_output%flux_sw_vis_dif)
        call write_data (unit, Rad_output%flux_lw_surf)
        call write_data (unit, Rad_output%coszen_angle)

!---------------------------------------------------------------------
!    write out the optional time average restart data. note that 
!    do_average and renormalize_sw_fluxes may not both be true.
!---------------------------------------------------------------------
        if (mpp_pe() == mpp_root_pe() ) then
          write (unit) renormalize_sw_fluxes, do_clear_sky_pass
        endif

!---------------------------------------------------------------------
!    write out the optional shortwave renormalization data. 
!---------------------------------------------------------------------
        if (renormalize_sw_fluxes) then   
          call write_data (unit, solar_save)
          call write_data (unit, flux_sw_surf_save)
          call write_data (unit, flux_sw_surf_dir_save)
          call write_data (unit, flux_sw_surf_dif_save)
          call write_data (unit, flux_sw_down_vis_dir_save)
          call write_data (unit, flux_sw_down_vis_dif_save)
          call write_data (unit, flux_sw_down_total_dir_save)
          call write_data (unit, flux_sw_down_total_dif_save)
          call write_data (unit, flux_sw_vis_save)
          call write_data (unit, flux_sw_vis_dir_save)
          call write_data (unit, flux_sw_vis_dif_save)
          call write_data (unit, sw_heating_save(:,:,:,1))
          call write_data (unit, tot_heating_save(:,:,:,1))
          call write_data (unit, dfsw_save(:,:,:,1)) 
          call write_data (unit, ufsw_save(:,:,:,1)) 
          call write_data (unit, fsw_save(:,:,:,1))  
          call write_data (unit, hsw_save(:,:,:,1))
          call write_data (unit, swdn_special_save(:,:,:,1))
          call write_data (unit, swup_special_save(:,:,:,1))
          if (do_clear_sky_pass) then
            call write_data (unit, sw_heating_clr_save)
            call write_data (unit, tot_heating_clr_save)
            call write_data (unit, dfswcf_save) 
            call write_data (unit, ufswcf_save) 
            call write_data (unit, fswcf_save)  
            call write_data (unit, hswcf_save)
            call write_data (unit, flux_sw_down_total_dir_clr_save)
            call write_data (unit, flux_sw_down_total_dif_clr_save)
            call write_data (unit, flux_sw_down_vis_clr_save)
            call write_data (unit, swdn_special_clr_save(:,:,:,1))
            call write_data (unit, swup_special_clr_save(:,:,:,1))
          endif
        endif    ! (renormalize)

!---------------------------------------------------------------------
!    close the radiation_driver.res file
!---------------------------------------------------------------------
        call close_file (unit)

end subroutine write_restart_file

!---------------------------------------------------------------------

subroutine write_restart_nc(timestamp)
  character(len=*), intent(in), optional :: timestamp



!---------------------------------------------------------------------
!    only the root pe will write control information -- the last value 
!    in the list of restart versions and the alarm information.
!---------------------------------------------------------------------
        if (mpp_pe() == mpp_root_pe() ) then
         call error_mesg('radiation_driver_mod', 'Writing netCDF formatted restart file: RESTART/radiation_driver.res.nc', NOTE)
        endif

!---------------------------------------------------------------------
!    write out the optional time average restart data. note that 
!    do_average and renormalize_sw_fluxes may not both be true.
!---------------------------------------------------------------------
        int_renormalize_sw_fluxes = 0
        int_do_clear_sky_pass = 0
        if(renormalize_sw_fluxes) then
          int_renormalize_sw_fluxes = 1
        else if (use_hires_coszen) then
          if (current_sw_zenith_step == nzens_per_sw_rad_timestep) then
            int_renormalize_sw_fluxes = 2
          else
            int_renormalize_sw_fluxes = -2
            call error_mesg ('radiation_driver/write_restart_nc', &
             ' you are writing restart file on a non-radiation &
               &timestep. As a consequence, model results will be &
               &different if the model is run with different restart &
               & intervals. To correct, make sure rad_time_step &
               & is an integral factor of the requested run length.', &
                                                                  NOTE)
          endif
        endif
        if(do_clear_sky_pass) int_do_clear_sky_pass = 1

! Make sure that the restart_versions variable is up to date.
        vers = restart_versions(size(restart_versions(:)))
        call save_restart(Rad_restart, timestamp)
        if(in_different_file) call save_restart(Til_restart, timestamp)

end subroutine write_restart_nc

!#####################################################################
! <SUBROUTINE NAME="read_restart_file">
!  <OVERVIEW>
!    read_restart_file reads a restart file containing radiation
!    restart information. it may be either a radiation_driver.res, or
!    an older sea_esf_rad.res file.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_restart_file reads a restart file containing radiation
!    restart information. it may be either a radiation_driver.res, or
!    an older sea_esf_rad.res file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_restart_file
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_restart_file 

!-------------------------------------------------------------------
!    read_restart_file reads a restart file containing radiation
!    restart information. it may be either a radiation_driver.res, or
!    an older sea_esf_rad.res file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables

      integer               :: unit
      logical               :: avg_present, renorm_present,  &
                               cldfree_present
      character(len=4)      :: chvers
      integer, dimension(5) :: dummy
      integer               :: new_rad_time, old_time_step
      integer               :: rad_alarm

!--------------------------------------------------------------------
!   local variables:
!
!       unit              i/o unit number connected to .res file
!       end               logical variable indicating, if true, that
!                         end of file has been reached on the current
!                         read operation
!       avg_present       if true, time-average data is present in the
!                         restart file
!       renorm_present    if true, sw renormalization data is present 
!                         in the restart file
!       cldfree_present   if true, and if renorm_present is true, then
!                         the clear-sky sw renormalization data is
!                         present in the restart file
!       chvers            character form of restart_version (i4)
!       avg_gases         if true, then time-average data for radiative
!                         gases is present in restart file
!       avg_clouds        if true, then time-average data for clouds is
!                         present in restart file
!       dummy             dummy array used as location to read older
!                         restart version data into           
!       kmax              number of model layers
!       new_rad_time      time remaining until next radiation calcul-
!                         ation; replaces the rad_alarm value read from
!                         restart file when the radiation timestep
!                         changes upon restart  
!       old_time_step     radiation timestep that was used in job 
!                         which wrote the restart file
!
!---------------------------------------------------------------------
      if (mpp_pe() == mpp_root_pe() ) then
         call error_mesg('radiation_driver_mod', 'Reading native formatted restart file.', NOTE)
      endif

!---------------------------------------------------------------------
!    if one is using the sea_esf_rad package and there is a 
!    sea_esf_rad.res restart file present in the input directory, it 
!    must be version 1 in order to be readable by the current module.
!    this file is where radiation restart data for the sea_esf radiation
!    package was written, through AM2p8, or the galway code release.
!    if this file is present and not version 1, exit.
!---------------------------------------------------------------------
      if (do_sea_esf_rad .and. file_exist('INPUT/sea_esf_rad.res')) then
        unit = open_restart_file ('INPUT/sea_esf_rad.res', 'read')
        read (unit) vers
        if ( vers /= 1 ) then
          write (chvers,'(i4)') vers
          call error_mesg ('radiation_driver_mod', &
             'restart version '//chvers//' cannot be read '//&
              'by this module version', FATAL)
        endif

!---------------------------------------------------------------------
!    if a radiation_driver.res file is present, then it must be one
!    of the versions listed as readable for the radiation package
!    being employed. these allowable versions are found in the array
!    restart_versions. if the version is not acceptable, exit.
!---------------------------------------------------------------------
      else if ( file_exist('INPUT/radiation_driver.res')  )  then   
        unit = open_restart_file ('INPUT/radiation_driver.res', 'read')
        read (unit) vers
        if ( .not. any(vers == restart_versions) ) then
          write (chvers,'(i4)') vers
          call error_mesg ('radiation_driver_mod', &
                    'restart version '//chvers//' cannot be read '//&
                    'by this module version', FATAL)
        endif
      endif

!-----------------------------------------------------------------------
!    read alarm information.  if reading an sea_esf_rad.res file 
!    (version 1), recover the time step previously used, and set the
!    radiation alarm to be 1 second from now, assuring radiation 
!    recalculation on the first model step of this run. for later 
!    restarts, read the previous radiation timestep and the rad_alarm
!    that was present when the restart was written.
!-----------------------------------------------------------------------
      if (vers == 1) then
        read (unit) dummy 
        old_time_step = SECONDS_PER_DAY*dummy(4) + dummy(3)
        rad_alarm = 1        
        if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
        ' radiation to be calculated on first step: restart file&
          & is sea_esf_rad.res, additional fields needed to run with &
                                          &current code', NOTE)
        endif
      else
        read (unit) rad_alarm, old_time_step    
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'NOTE from PE 0: rad_alarm as read from restart &
                      &file is ', rad_alarm, 'second(s).'
        endif
      endif

!---------------------------------------------------------------------
!    read the radiation restart data. it consists of radiative temper-
!    ature tendencies, sw surface fluxes, lw surface fluxes and the
!    value of the cosine of the zenith angle to be used for the next
!    ocean albedo calcuation, in restart versions after version 1. for
!    restart version 1, set the cosine of the zenith angle to the value
!    used on initialization for use in diagnostics. since in this case 
!    rad_alarm has been set so that radiation is called on the next 
!    step, the proper zenith angles will be calculated and then used to
!    define the albedos.
!---------------------------------------------------------------------
      call read_data (unit, Rad_output%tdt_rad )
      if (vers >= 4) then
        call read_data (unit, Rad_output%tdtlw )
      else          
        Rad_output%tdtlw = 0.0
      endif
      call read_data (unit, Rad_output%flux_sw_surf )
      if (vers == 7) then
        call read_data (unit, dum_idjd )
        rad_alarm = 1
        if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
        ' radiation to be calculated on first step: restart file&
          & is version 7, additional fields needed to run with &
                                          &current code', NOTE)
        endif
      endif
      if (vers >= 8) then
        call read_data (unit, Rad_output%flux_sw_surf_dir )
        call read_data (unit, Rad_output%flux_sw_surf_dif )
        call read_data (unit, Rad_output%flux_sw_down_vis_dir )
        call read_data (unit, Rad_output%flux_sw_down_vis_dif )
        call read_data (unit, Rad_output%flux_sw_down_total_dir )
        call read_data (unit, Rad_output%flux_sw_down_total_dif )
        call read_data (unit, Rad_output%flux_sw_vis )
        call read_data (unit, Rad_output%flux_sw_vis_dir )
        call read_data (unit, Rad_output%flux_sw_vis_dif )
      else
!    SUITABLE INITIALIZATION ??
        Rad_output%flux_sw_surf_dir = 0.0
        Rad_output%flux_sw_surf_dif = 0.0
        Rad_output%flux_sw_down_vis_dir = 0.0
        Rad_output%flux_sw_down_vis_dif = 0.0
        Rad_output%flux_sw_down_total_dir = 0.0
        Rad_output%flux_sw_down_total_dif = 0.0
        Rad_output%flux_sw_vis = 0.0
        Rad_output%flux_sw_vis_dir = 0.0
        Rad_output%flux_sw_vis_dif = 0.0
      endif
      call read_data (unit, Rad_output%flux_lw_surf )
      if (vers /= 1) then
        call read_data (unit, Rad_output%coszen_angle)
      else
        Rad_output%coszen_angle = coszen_angle_init
      endif

!----------------------------------------------------------------------
!    versions 3 and 4 include variables needed when sw renormalization 
!    is active, and logical variables indicating which additional fields
!    are present.
!----------------------------------------------------------------------
      if (vers == 3 .or. vers == 4) then

!---------------------------------------------------------------------
!    determine if accumulation arrays are present in the restart file.
!    if input fields are to be time-averaged, read the values from the
!    files.  note that avg_present and renorm_present cannot both be 
!    true.
!---------------------------------------------------------------------
        read (unit) avg_present, renorm_present, cldfree_present
  
!---------------------------------------------------------------------
!    if renormalize_sw_fluxes is true and the data is present in the
!    restart file, read it.
!---------------------------------------------------------------------
        if (renormalize_sw_fluxes) then  
          if (renorm_present) then     
            call read_data (unit, solar_save)
            call read_data (unit, flux_sw_surf_save)
            call read_data (unit, sw_heating_save)
            call read_data (unit, tot_heating_save)
            call read_data (unit, dfsw_save) 
            call read_data (unit, ufsw_save)  
            call read_data (unit, fsw_save)  
            call read_data (unit, hsw_save)
!           if (vers >= 6) then
!      call read_data (unit, swdn_trop_save)
!      call read_data (unit, swup_trop_save)
!    endif

!---------------------------------------------------------------------
!    if cldfree data is desired and the data is present in the
!    restart file, read it.
!---------------------------------------------------------------------
            if (do_clear_sky_pass) then
              if (cldfree_present) then
                call read_data (unit, sw_heating_clr_save)
                call read_data (unit, tot_heating_clr_save)
                call read_data (unit, dfswcf_save) 
                call read_data (unit, ufswcf_save) 
                call read_data (unit, fswcf_save)  
                call read_data (unit, hswcf_save)

!               if (vers >= 6) then
!          call read_data (unit, swdn_trop_clr_save)
!          call read_data (unit, swup_trop_clr_save)
!        endif

!--------------------------------------------------------------------
!    if cldfree data is desired and the data is not present in the
!    restart file, force a radiation call on next model step.  
!---------------------------------------------------------------------
              else
        rad_alarm = 1
        if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
        ' radiation to be calculated on first step: cloud-free &
          &calculations are desired, but needed fluxes and heating &
                      &rates are notpresent in restart file', NOTE)
        endif
      endif  ! (cldfree_present)
            endif

!---------------------------------------------------------------------
!    if renormalize_sw_fluxes is true and the data is not present in the
!    restart file, force a radiation call on next model step.  
!---------------------------------------------------------------------
          else  ! (renorm_present)
            rad_alarm = 1
            if (mpp_pe() == mpp_root_pe() ) then
            call error_mesg ('radiation_driver_mod', &
             ' radiation to be calculated on first step: renormaliz&
              &ation of sw fluxes is desired, but needed data is not &
              &present in restart file', NOTE)
            endif
          endif ! (renorm_present)
        endif ! (renormalize)
!     else if (vers == 5) then
      else if (vers >= 5) then

!---------------------------------------------------------------------
!    determine if accumulation arrays are present in the restart file.
!    if input fields are to be time-averaged, read the values from the
!    files.  note that avg_present and renorm_present cannot both be 
!    true.
!---------------------------------------------------------------------
        read (unit) renorm_present, cldfree_present
  
!---------------------------------------------------------------------
!    if renormalize_sw_fluxes is true and the data is present in the
!    restart file, read it.
!---------------------------------------------------------------------
        if (renormalize_sw_fluxes) then  
          if (renorm_present) then     
            call read_data (unit, solar_save)
            call read_data (unit, flux_sw_surf_save)
            if (vers == 7) then
               call read_data (unit, dum_idjd           )
            endif
            if (vers >= 8) then
              call read_data (unit, flux_sw_surf_dir_save)
              call read_data (unit, flux_sw_surf_dif_save)
              call read_data (unit, flux_sw_down_vis_dir_save)
              call read_data (unit, flux_sw_down_vis_dif_save)
              call read_data (unit, flux_sw_down_total_dir_save)
              call read_data (unit, flux_sw_down_total_dif_save)
              call read_data (unit, flux_sw_vis_save)
              call read_data (unit, flux_sw_vis_dir_save)
              call read_data (unit, flux_sw_vis_dif_save)
            else
!! SUITABLE INITIALIZATION ??
              flux_sw_surf_dir_save =0.0
              flux_sw_surf_dif_save =0.0
              flux_sw_down_vis_dir_save =0.0
              flux_sw_down_vis_dif_save =0.0
              flux_sw_down_total_dir_save =0.0
              flux_sw_down_total_dif_save =0.0
              flux_sw_vis_save =0.0
              flux_sw_vis_dir_save =0.0
              flux_sw_vis_dif_save =0.0
            endif
            call read_data (unit, sw_heating_save)
            call read_data (unit, tot_heating_save)
            call read_data (unit, dfsw_save) 
            call read_data (unit, ufsw_save)  
            call read_data (unit, fsw_save)  
            call read_data (unit, hsw_save)

!---------------------------------------------------------------------
!    if this is a pre-version 9 restart (other than version 6), then 
!    radiation must be called on the first step in order to define the 
!    troopause fluxes.
!---------------------------------------------------------------------
            if ( (vers >= 9) .or. (vers == 6) ) then
              call read_data (unit, swdn_special_save(:,:,:,1))
              call read_data (unit, swup_special_save(:,:,:,1))
            else
              rad_alarm = 1
              if (mpp_pe() == mpp_root_pe() ) then
              call error_mesg ('radiation_driver_mod', &
             ' radiation to be calculated on first step: tropopause &
              &fluxes diagnostics are desired, but needed data is not &
              &present in restart file', NOTE)
              endif
            endif

!---------------------------------------------------------------------
!    if cldfree data is desired and the data is present in the
!    restart file, read it.
!---------------------------------------------------------------------
            if (do_clear_sky_pass) then
              if (cldfree_present) then
                call read_data (unit, sw_heating_clr_save)
                call read_data (unit, tot_heating_clr_save)
                call read_data (unit, dfswcf_save) 
                call read_data (unit, ufswcf_save) 
                call read_data (unit, fswcf_save)  
                call read_data (unit, hswcf_save)
                if (vers >= 10) then
                  call read_data (unit, flux_sw_down_total_dir_clr_save)
                  call read_data (unit, flux_sw_down_total_dif_clr_save)
                else
                  flux_sw_down_total_dir_clr_save =0.0
                  flux_sw_down_total_dif_clr_save =0.0
                endif
                if (vers >= 11) then
                  call read_data (unit, flux_sw_down_vis_clr_save)
                else
                  flux_sw_down_vis_clr_save =0.0
                endif
                
!---------------------------------------------------------------------
!    if this is a pre-version 9 restart (other than version 6), then 
!    radiation must be called on the first step in order to define the 
!    troopause fluxes.
!---------------------------------------------------------------------
                if ( (vers >= 9) .or. (vers == 6) ) then
                  call read_data (unit, swdn_special_clr_save(:,:,:,1))
                  call read_data (unit, swup_special_clr_save(:,:,:,1))
                else
                  rad_alarm = 1
                  if (mpp_pe() == mpp_root_pe() ) then
                  call error_mesg ('radiation_driver_mod', &
             ' radiation to be calculated on first step: tropopause &
              &fluxes diagnostics are desired, but needed data is not &
              &present in restart file', NOTE)
                  endif
                endif

!--------------------------------------------------------------------
!    if cldfree data is desired and the data is not present in the
!    restart file, force a radiation call on next model step.  
!---------------------------------------------------------------------
              else
                rad_alarm = 1
                if (mpp_pe() == mpp_root_pe() ) then
                call error_mesg ('radiation_driver_mod', &
             ' radiation to be calculated on first step: cloud-free &
              &diagnostics are desired, but needed data is not &
              &present in restart file', NOTE)
                endif
              endif  ! (cldfree_present)
            endif

!---------------------------------------------------------------------
!    if renormalize_sw_fluxes is true and the data is not present in the
!    restart file, force a radiation call on next model step.  
!---------------------------------------------------------------------
          else  ! (renorm_present)
            rad_alarm = 1
            if (mpp_pe() == mpp_root_pe() ) then
            call error_mesg ('radiation_driver_mod', &
             ' radiation to be calculated on first step: renormaliz&
              &ation of sw fluxes is desired, but needed data is not &
              &present in restart file', NOTE)
            endif
          endif ! (renorm_present)
        endif ! (renormalize)
      endif    ! (vers == 3 or 4)

!--------------------------------------------------------------------
!    close the unit used to read the .res file.
!--------------------------------------------------------------------
      call close_file (unit)

!----------------------------------------------------------------------
!    if all_step_diagnostics is active and rad_alarm is not 1, abort 
!    job with error message. all_step_diagnostics may only be activated
!    when radiation is to be calculated on the first step of a job, 
!    unless additional arrays are added to the radiation restart file.
!----------------------------------------------------------------------
      if (rad_alarm /= 1 .and. all_step_diagnostics) then
        if (mpp_pe() == mpp_root_pe() ) then
          call error_mesg ('radiation_driver_mod', &
           'cannot set all_step_diagnostics to be .true. unless &
            & starting job on step just prior to radiation call; &
            &doing so will lead to non-reproducibility of restarts', &
                                                                 FATAL)
        endif
      endif

!----------------------------------------------------------------------
!    adjust radiation alarm if radiation step has changed from restart 
!    file value, if it has not already been set to the first step.
!----------------------------------------------------------------------
      if (rad_alarm /= 1) then
!     if (rad_alarm == 1) then
!       if (mpp_pe() == mpp_root_pe() ) then
!         call error_mesg ('radiation_driver_mod',          &
!              'radiation will be called on first step of run', NOTE)
!       endif
!     else
        if (rad_time_step /= old_time_step ) then
          new_rad_time = rad_alarm - old_time_step + rad_time_step
          if ( new_rad_time > 0 ) then
            if (mpp_pe() == mpp_root_pe() ) then
              print *, 'radiation time step has changed, therefore '//&
                  'next time to next do radiation also changed;  &
                   &new rad_alarm is', new_rad_time
            endif
            rad_alarm = new_rad_time
          else
            rad_alarm = 1
            if (mpp_pe() == mpp_root_pe() ) then
               call error_mesg ('radiation_driver_mod', &
             ' radiation to be calculated on first step: radiation &
              &timestep has gotten shorter and is past due', NOTE)
            endif
          endif
        endif  
      endif   ! (rad_alarm == 1)
      lwrad_alarm = rad_alarm
      swrad_alarm = rad_alarm

!--------------------------------------------------------------------


end subroutine read_restart_file

!#####################################################################
subroutine rad_driver_register_restart(fname)
  character(len=*), intent(in) :: fname
  character(len=64)            :: fname2
  integer                      :: id_restart

   call get_mosaic_tile_file(fname, fname2, .false. ) 
   allocate(Rad_restart)
   if(trim(fname2) == trim(fname)) then
      Til_restart => Rad_restart
      in_different_file = .false.
   else
      in_different_file = .true.
      allocate(Til_restart)
   endif

  id_restart = register_restart_field(Rad_restart, fname, 'vers', vers)
  id_restart = register_restart_field(Rad_restart, fname, 'lwrad_alarm', lwrad_alarm, mandatory=.false.)
  id_restart = register_restart_field(Rad_restart, fname, 'swrad_alarm', swrad_alarm, mandatory=.false.)
  id_restart = register_restart_field(Rad_restart, fname, 'lw_rad_time_step', lw_rad_time_step, mandatory=.false.)
  id_restart = register_restart_field(Rad_restart, fname, 'sw_rad_time_step', sw_rad_time_step, mandatory=.false.)
  id_restart = register_restart_field(Til_restart, fname, 'tdt_rad', Rad_output%tdt_rad(:,:,:,1) )
  id_restart = register_restart_field(Til_restart, fname, 'tdtlw', Rad_output%tdtlw)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_surf', Rad_output%flux_sw_surf)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_surf_dir', Rad_output%flux_sw_surf_dir)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_surf_dif', Rad_output%flux_sw_surf_dif)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_vis_dir', Rad_output%flux_sw_down_vis_dir)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_vis_dif', Rad_output%flux_sw_down_vis_dif)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_total_dir', Rad_output%flux_sw_down_total_dir)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_total_dif', Rad_output%flux_sw_down_total_dif)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_vis', Rad_output%flux_sw_vis)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_vis_dir', Rad_output%flux_sw_vis_dir)
  id_restart = register_restart_field(Til_restart, fname, 'flux_sw_vis_dif', Rad_output%flux_sw_vis_dif)
  id_restart = register_restart_field(Til_restart, fname, 'flux_lw_surf', Rad_output%flux_lw_surf)
  id_restart = register_restart_field(Til_restart, fname, 'coszen_angle', Rad_output%coszen_angle)
  id_restart = register_restart_field(Rad_restart, fname, 'renormalize_sw_fluxes', int_renormalize_sw_fluxes)
  id_restart = register_restart_field(Rad_restart, fname, 'do_clear_sky_pass', int_do_clear_sky_pass)
  if (renormalize_sw_fluxes ) then   
     id_restart = register_restart_field(Til_restart, fname, 'solar_save', solar_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_surf_save', flux_sw_surf_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_surf_dir_save', flux_sw_surf_dir_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_surf_dif_save', flux_sw_surf_dif_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_vis_dir_save', flux_sw_down_vis_dir_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_vis_dif_save', flux_sw_down_vis_dif_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_total_dir_save', flux_sw_down_total_dir_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_total_dif_save', flux_sw_down_total_dif_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_vis_save', flux_sw_vis_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_vis_dir_save', flux_sw_vis_dir_save)
     id_restart = register_restart_field(Til_restart, fname, 'flux_sw_vis_dif_save', flux_sw_vis_dif_save)
     id_restart = register_restart_field(Til_restart, fname, 'sw_heating_save', sw_heating_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'tot_heating_save', tot_heating_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'dfsw_save', dfsw_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'ufsw_save', ufsw_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'fsw_save', fsw_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'hsw_save', hsw_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'swdn_special_save', swdn_special_save(:,:,:,1))
     id_restart = register_restart_field(Til_restart, fname, 'swup_special_save', swup_special_save(:,:,:,1))
     if (do_clear_sky_pass) then
        id_restart = register_restart_field(Til_restart, fname, 'sw_heating_clr_save', sw_heating_clr_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'tot_heating_clr_save', tot_heating_clr_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'dfswcf_save', dfswcf_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'ufswcf_save', ufswcf_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'fswcf_save', fswcf_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'hswcf_save', hswcf_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_total_dir_clr_save', &
             flux_sw_down_total_dir_clr_save(:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_total_dif_clr_save', &
             flux_sw_down_total_dif_clr_save(:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'flux_sw_down_vis_clr_save', &
             flux_sw_down_vis_clr_save(:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'swdn_special_clr_save', swdn_special_clr_save(:,:,:,1))
        id_restart = register_restart_field(Til_restart, fname, 'swup_special_clr_save', swup_special_clr_save(:,:,:,1))
     endif
  endif

end subroutine rad_driver_register_restart


!#####################################################################
! <SUBROUTINE NAME="read_restart_nc">
!  <OVERVIEW>
!    read_restart_nc reads a netcdf restart file containing radiation
!    restart information.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_restart_nc reads a netcdf restart file containing radiation
!    restart information.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_restart_nc
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_restart_nc

  character(len=64) :: fname='INPUT/radiation_driver.res.nc'
  real              :: flag1, flag2
  logical           :: renorm_present, cldfree_present
  integer           :: new_rad_time
  integer           :: lw_old_time_step, sw_old_time_step
!----------------------------------------------------------------------
!    when running in gcm, read a restart file. this is not done in the
!    standalone case.
!---------------------------------------------------------------------
  if (mpp_pe() == mpp_root_pe() ) then
    call error_mesg('radiation_driver_mod', 'Reading netCDF formatted restart file: INPUT/radiation_driver.res.nc', NOTE)
  endif
  call read_data(fname, 'vers', vers)

!--------------------------------------------------------------------
  if (field_exist (fname, 'rad_alarm')) then
    call read_data(fname, 'rad_alarm', lwrad_alarm)
    call read_data(fname, 'rad_alarm', swrad_alarm)
  else
    call read_data(fname, 'lwrad_alarm', lwrad_alarm)
    call read_data(fname, 'swrad_alarm', swrad_alarm)
  endif

!--------------------------------------------------------------------
  if (field_exist (fname, 'rad_time_step')) then
    call read_data(fname, 'rad_time_step', lw_old_time_step)
    call read_data(fname, 'rad_time_step', sw_old_time_step)
  else
  call read_data(fname, 'sw_rad_time_step', sw_old_time_step)
  call read_data(fname, 'lw_rad_time_step', lw_old_time_step)
  endif


  call read_data(fname, 'renormalize_sw_fluxes', flag1)
  call read_data(fname, 'do_clear_sky_pass', flag2)
  renorm_present = .false.
  cldfree_present = .false.
  if (flag1 ==   1.0)  then
    renorm_present = .true.
  else if (flag1 == 2.0) then
  else if (flag1 == -2.0) then
    if (.not. allow_nonrepro_across_restarts) then
      call error_mesg ( 'radiation_driver/read_restart_nc', &
       'the restart was written on a non-radiation step, so model&
        & solution will NOT be independent of restart interval. If &
        & you dont care about this, set nml variable &
        &allow_nonrepro_across_restarts to .true. and resubmit; &
        &if you do, contact developer so additional code may be &
        &added to allow seamless restart, OR rerun last job segment &
        & so that it is an integral number of rad_time_steps  &
                                                       &long.', FATAL)
    else
      call error_mesg ( 'radiation_driver/read_restart_nc', &
       'the restart was written on a non-radiation step, so model&
        & solution will NOT be independent of restart interval. You &
        & have chosen to proceed anyway by setting nml variable &
        &allow_nonrepro_across_restarts to .true.', NOTE )
      swrad_alarm = 1
      lwrad_alarm = 1
    endif

  endif
    
  if(flag2 .EQ. 1.0) cldfree_present = .true.

!---------------------------------------------------------------------
!    read the restart data.
!    currently this need not be done when hires_coszen = .true.
!---------------------------------------------------------------------
      if (flag1 == 0.0 .or. flag1 == 1.0) then
        call read_data (fname, 'tdt_rad',                Rad_output%tdt_rad(:,:,:,1))
        call read_data (fname, 'tdtlw',                  Rad_output%tdtlw)
        call read_data (fname, 'flux_sw_surf',           Rad_output%flux_sw_surf(:,:,1))
        call read_data (fname, 'flux_sw_surf_dir',       Rad_output%flux_sw_surf_dir(:,:,1))
        call read_data (fname, 'flux_sw_surf_dif',       Rad_output%flux_sw_surf_dif(:,:,1))
        call read_data (fname, 'flux_sw_down_vis_dir',   Rad_output%flux_sw_down_vis_dir(:,:,1))
        call read_data (fname, 'flux_sw_down_vis_dif',   Rad_output%flux_sw_down_vis_dif(:,:,1))
        call read_data (fname, 'flux_sw_down_total_dir', Rad_output%flux_sw_down_total_dir(:,:,1))
        call read_data (fname, 'flux_sw_down_total_dif', Rad_output%flux_sw_down_total_dif(:,:,1))
        call read_data (fname, 'flux_sw_vis',            Rad_output%flux_sw_vis(:,:,1))
        call read_data (fname, 'flux_sw_vis_dir',        Rad_output%flux_sw_vis_dir(:,:,1))
        call read_data (fname, 'flux_sw_vis_dif',        Rad_output%flux_sw_vis_dif(:,:,1))
        call read_data (fname, 'flux_lw_surf',           Rad_output%flux_lw_surf)
        call read_data (fname, 'coszen_angle',           Rad_output%coszen_angle)
   endif

!---------------------------------------------------------------------
!    read the optional shortwave renormalization data. 
!---------------------------------------------------------------------
        if (renormalize_sw_fluxes ) then   
         if(renorm_present) then
          call read_data (fname, 'solar_save', solar_save)
          call read_data (fname, 'flux_sw_surf_save', flux_sw_surf_save(:,:,1))
          call read_data (fname, 'flux_sw_surf_dir_save', flux_sw_surf_dir_save(:,:,1))
          call read_data (fname, 'flux_sw_surf_dif_save', flux_sw_surf_dif_save(:,:,1))
          call read_data (fname, 'flux_sw_down_vis_dir_save', flux_sw_down_vis_dir_save(:,:,1))
          call read_data (fname, 'flux_sw_down_vis_dif_save', flux_sw_down_vis_dif_save(:,:,1))
          call read_data (fname, 'flux_sw_down_total_dir_save', flux_sw_down_total_dir_save(:,:,1))
          call read_data (fname, 'flux_sw_down_total_dif_save', flux_sw_down_total_dif_save(:,:,1))
          call read_data (fname, 'flux_sw_vis_save', flux_sw_vis_save(:,:,1))
          call read_data (fname, 'flux_sw_vis_dir_save', flux_sw_vis_dir_save(:,:,1))
          call read_data (fname, 'flux_sw_vis_dif_save', flux_sw_vis_dif_save(:,:,1))
          call read_data (fname, 'sw_heating_save', sw_heating_save(:,:,:,1))
          call read_data (fname, 'tot_heating_save', tot_heating_save(:,:,:,1))
          call read_data (fname, 'dfsw_save', dfsw_save(:,:,:,1)) 
          call read_data (fname, 'ufsw_save', ufsw_save(:,:,:,1)) 
          call read_data (fname, 'fsw_save', fsw_save(:,:,:,1))  
          call read_data (fname, 'hsw_save', hsw_save(:,:,:,1))
          call read_data (fname, 'swdn_special_save', swdn_special_save(:,:,:,1))
          call read_data (fname, 'swup_special_save', swup_special_save(:,:,:,1))
          if (do_clear_sky_pass) then
           if(cldfree_present) then
            call read_data (fname, 'sw_heating_clr_save', sw_heating_clr_save(:,:,:,1))
            call read_data (fname, 'tot_heating_clr_save', tot_heating_clr_save(:,:,:,1))
            call read_data (fname, 'dfswcf_save', dfswcf_save(:,:,:,1)) 
            call read_data (fname, 'ufswcf_save', ufswcf_save(:,:,:,1)) 
            call read_data (fname, 'fswcf_save', fswcf_save(:,:,:,1))  
            call read_data (fname, 'hswcf_save', hswcf_save(:,:,:,1))
            if (vers >= 10) then
              call read_data (fname, 'flux_sw_down_total_dir_clr_save', flux_sw_down_total_dir_clr_save(:,:,1))
              call read_data (fname, 'flux_sw_down_total_dif_clr_save', flux_sw_down_total_dif_clr_save(:,:,1))
            else
              flux_sw_down_total_dir_clr_save = 0.0
              flux_sw_down_total_dif_clr_save = 0.0
            endif
            if (vers >= 11) then
              call read_data (fname, 'flux_sw_down_vis_clr_save', flux_sw_down_vis_clr_save(:,:,1))
            else
              flux_sw_down_vis_clr_save = 0.0
            endif
            call read_data (fname, 'swdn_special_clr_save', swdn_special_clr_save(:,:,:,1))
            call read_data (fname, 'swup_special_clr_save', swup_special_clr_save(:,:,:,1))
            endif
         endif
      endif  ! (do_clear_sky_pass)
     endif  ! (renormalize_sw_fluxes)
!----------------------------------------------------------------------
!    if all_step_diagnostics is active and rad_alarm is not 1, abort 
!    job with error message. all_step_diagnostics may only be activated
!    when radiation is to be calculated on the first step of a job, 
!    unless additional arrays are added to the radiation restart file.
!----------------------------------------------------------------------
   if (lwrad_alarm /= 1 .and. all_step_diagnostics) then
     if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
       'cannot set all_step_diagnostics to be .true. unless &
         & starting job on step just prior to radiation call; &
         &doing so will lead to non-reproducibility of restarts', &
                                                                 FATAL)
     endif
  endif
   if (swrad_alarm /= 1 .and. all_step_diagnostics) then
     if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
       'cannot set all_step_diagnostics to be .true. unless &
         & starting job on step just prior to radiation call; &
         &doing so will lead to non-reproducibility of restarts', &
                                                                 FATAL)
     endif
  endif

   if (lwrad_alarm /= 1 .and.    &
                (do_lwaerosol_forcing  .or. do_swaerosol_forcing)) then
     if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
       'aerosol forcing diagnostics will only be strictly valid &
      &when restarting a job on the step just prior to radiation&
      &call; not doing so will lead to invalid diagnostics between time&
      & of restart and next radiation calculation, since these fields &
      &are not saved in the restart file', FATAL)
     endif
  endif
   if (swrad_alarm /= 1 .and.    &
                (do_lwaerosol_forcing  .or. do_swaerosol_forcing)) then
     if (mpp_pe() == mpp_root_pe() ) then
        call error_mesg ('radiation_driver_mod', &
       'aerosol forcing diagnostics will only be strictly valid &
      &when restarting a job on the step just prior to radiation&
      &call; not doing so will lead to invalid diagnostics between time&
      & of restart and next radiation calculation, since these fields &
      &are not saved in the restart file', FATAL)
     endif
  endif

  !----------------------------------------------------------------------
  !    adjust radiation alarm if radiation step has changed from restart 
  !    file value, if it has not already been set to the first step.
  !----------------------------------------------------------------------
  if (lwrad_alarm /= 1) then
     !     if (rad_alarm == 1) then
     !       if (mpp_pe() == mpp_root_pe() ) then
     !         call error_mesg ('radiation_driver_mod',          &
     !              'radiation will be called on first step of run', NOTE)
     !       endif
     !     else
     if (rad_time_step /= lw_old_time_step ) then
        new_rad_time = lwrad_alarm - lw_old_time_step + lw_rad_time_step
        if ( new_rad_time > 0 ) then
           if (mpp_pe() == mpp_root_pe() ) then
              print *, 'radiation time step has changed, therefore '//&
                   'next time to next do lw radiation also changed;  &
                   &new lwrad_alarm is', new_rad_time
           endif
           lwrad_alarm = new_rad_time
        else
           lwrad_alarm = 1
           if (mpp_pe() == mpp_root_pe() ) then
              call error_mesg ('radiation_driver_mod', &
                   ' radiation to be calculated on first step: lw radiation &
                   &timestep has gotten shorter and is past due', NOTE)
           endif
        endif
     endif
  endif   ! (lwrad_alarm == 1)
  if (swrad_alarm /= 1) then
     !     if (rad_alarm == 1) then
     !       if (mpp_pe() == mpp_root_pe() ) then
     !         call error_mesg ('radiation_driver_mod',          &
     !              'radiation will be called on first step of run', NOTE)
     !       endif
     !     else
     if (sw_rad_time_step /= sw_old_time_step ) then
        new_rad_time = swrad_alarm - sw_old_time_step + sw_rad_time_step
        if ( new_rad_time > 0 ) then
           if (mpp_pe() == mpp_root_pe() ) then
              print *, 'radiation time step has changed, therefore '//&
                   'next time to next do sw radiation also changed;  &
                   &new swrad_alarm is', new_rad_time
           endif
           swrad_alarm = new_rad_time
        else
           swrad_alarm = 1
           if (mpp_pe() == mpp_root_pe() ) then
              call error_mesg ('radiation_driver_mod', &
                   ' radiation to be calculated on first step: sw radiation &
                   &timestep has gotten shorter and is past due', NOTE)
           endif
        endif
     endif
  endif   ! (swrad_alarm == 1)

  vers = restart_versions(size(restart_versions(:)))

end subroutine read_restart_nc


!#####################################################################
! <SUBROUTINE NAME="initialize_diagnostic_integrals">
!  <OVERVIEW>
!    initialize_diagnostic_integrals registers the desired integrals 
!    with diag_integral_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    initialize_diagnostic_integrals registers the desired integrals 
!    with diag_integral_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call initialize_diagnostic_integrals
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine initialize_diagnostic_integrals

!---------------------------------------------------------------------
!    initialize_diagnostic_integrals registers the desired integrals 
!    with diag_integral_mod.
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    initialize standard global quantities for integral package. 
!----------------------------------------------------------------------
      call diag_integral_field_init ('olr',    std_digits)
      call diag_integral_field_init ('abs_sw', std_digits)
!     call diag_integral_field_init ('olr_clr',    std_digits)
!     call diag_integral_field_init ('abs_sw_clr', std_digits)

!----------------------------------------------------------------------
!    if hemispheric integrals and global integrals with extended signif-
!    icance are desired, inform diag_integrals_mod.
!----------------------------------------------------------------------
      if (calc_hemi_integrals) then
        call diag_integral_field_init ('sntop_tot_sh', extra_digits)
        call diag_integral_field_init ('lwtop_tot_sh', extra_digits)
        call diag_integral_field_init ('sngrd_tot_sh', extra_digits)
        call diag_integral_field_init ('lwgrd_tot_sh', extra_digits)
        call diag_integral_field_init ('sntop_tot_nh', extra_digits)
        call diag_integral_field_init ('lwtop_tot_nh', extra_digits)
        call diag_integral_field_init ('sngrd_tot_nh', extra_digits)
        call diag_integral_field_init ('lwgrd_tot_nh', extra_digits)
        call diag_integral_field_init ('sntop_tot_gl', extra_digits)
        call diag_integral_field_init ('lwtop_tot_gl', extra_digits)
        call diag_integral_field_init ('sngrd_tot_gl', extra_digits)
        call diag_integral_field_init ('lwgrd_tot_gl', extra_digits)

!---------------------------------------------------------------------
!    if clear-sky integrals are desired, include them.
!---------------------------------------------------------------------
        if (do_clear_sky_pass) then
          call diag_integral_field_init ('sntop_clr_sh', extra_digits)
          call diag_integral_field_init ('lwtop_clr_sh', extra_digits)
          call diag_integral_field_init ('sngrd_clr_sh', extra_digits)
          call diag_integral_field_init ('lwgrd_clr_sh', extra_digits)
          call diag_integral_field_init ('sntop_clr_nh', extra_digits)
          call diag_integral_field_init ('lwtop_clr_nh', extra_digits)
          call diag_integral_field_init ('sngrd_clr_nh', extra_digits)
          call diag_integral_field_init ('lwgrd_clr_nh', extra_digits)
          call diag_integral_field_init ('sntop_clr_gl', extra_digits)
          call diag_integral_field_init ('lwtop_clr_gl', extra_digits)
          call diag_integral_field_init ('sngrd_clr_gl', extra_digits)
          call diag_integral_field_init ('lwgrd_clr_gl', extra_digits)
        endif
      endif

!--------------------------------------------------------------------


end subroutine initialize_diagnostic_integrals



!#######################################################################
! <SUBROUTINE NAME="diag_field_init">
!  <OVERVIEW>
!    diag_field_init registers the desired diagnostic fields with the
!    diagnostics manager.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_field_init registers the desired diagnostic fields with the
!    diagnostics manager.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_field_init ( Time, axes )
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   Current time
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!   diagnostic variable axes for netcdf files
!  </IN>
! </SUBROUTINE>
!
subroutine diag_field_init ( Time, axes )

!---------------------------------------------------------------------
!    diag_field_init registers the desired diagnostic fields with the
!    diagnostics manager.
!---------------------------------------------------------------------

type(time_type), intent(in) :: Time
integer        , intent(in) :: axes(4)

!--------------------------------------------------------------------
!  intent(in) variables
!
!      Time        current time
!      axes        data axes for use with diagnostic fields
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables

      character(len=8)  ::   clr
      character(len=16) ::   clr2, lwaer_prep, swaer_prep
      integer           ::   bxes(4)
      integer           ::   i, n

!--------------------------------------------------------------------
!  local variables:
!
!       clr          character string used in netcdf variable short name
!       clr2         character string used in netcdf variable long name
!       n            number of passes through name generation loop
!       i            do-loop index
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    define variable axis array with elements (1:3) valid for variables
!    defined at flux levels.
!-------------------------------------------------------------------
      bxes(1:2) = axes(1:2)
      bxes(3) = axes(4)
      bxes(4) = axes(4)

!---------------------------------------------------------------------
!    determine how many passes are needed through the name generation 
!    loop. 
!---------------------------------------------------------------------
      if (do_clear_sky_pass) then
        n= 2
      else
        n= 1
      endif

      if (Sw_control%do_swaerosol ) then
        swaer_prep = 'without'
      else
        swaer_prep = 'with'
      endif
      if (Lw_control%do_lwaerosol ) then
        lwaer_prep = 'without'
      else
        lwaer_prep = 'with'
      endif

!---------------------------------------------------------------------
!    generate names for standard and clear sky diagnostic fields. if 
!    clear sky values being generated, generate the clear sky names
!    on pass 1, followed by the standard names.
!---------------------------------------------------------------------
      do i = 1, n
        if ( i == n) then
          clr  = "    "
          clr2 = "          "
        else
          clr  = "_clr"
          clr2 = "clear sky "
        endif

        id_swdn_special(1,i) = register_diag_field (mod_name,   &
                'swdn_200hPa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux down at 200 hPa', &
                'watts/m2', missing_value=missing_value)
        id_swdn_special(2,i) = register_diag_field (mod_name,   &
                'swdn_lin_trop'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux down at linear tropopause', &
                'watts/m2', missing_value=missing_value)
        id_swdn_special(3,i) = register_diag_field (mod_name,   &
                'swdn_therm_trop'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux down at thermo tropopause', &
                'watts/m2', missing_value=missing_value)
        id_swdn_special(4,i) = register_diag_field (mod_name,   &
                'swdn_1_Pa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux down at 1 Pa', &
                'watts/m2', missing_value=missing_value)

        id_swup_special(1,i) = register_diag_field (mod_name,   &
                'swup_200hPa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux up at 200 hPa', &
                'watts/m2', missing_value=missing_value)
        id_swup_special(2,i) = register_diag_field (mod_name,   &
                'swup_lin_trop'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux up at linear tropopause', &
                'watts/m2', missing_value=missing_value)
        id_swup_special(3,i) = register_diag_field (mod_name,   &
                'swup_therm_trop'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux up at thermo tropopause', &
                'watts/m2', missing_value=missing_value)
        id_swup_special(4,i) = register_diag_field (mod_name,   &
                'swup_1_Pa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux up at 1 Pa', &
                'watts/m2', missing_value=missing_value)

        id_netlw_special(1,i) = register_diag_field (mod_name,   &
                'netlw_200hPa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'net LW flux at 200 hPa', &
                'watts/m2', missing_value=missing_value)
        id_netlw_special(2,i) = register_diag_field (mod_name,   &
                'netlw_lin_trop'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'net LW flux at linear tropopause', &
                'watts/m2', missing_value=missing_value)
        id_netlw_special(3,i) = register_diag_field (mod_name,   &
                'netlw_therm_trop'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'net LW flux at thermo tropopause', &
                'watts/m2', missing_value=missing_value)
        id_netlw_special(4,i) = register_diag_field (mod_name,   &
                'netlw_1_Pa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'net LW flux at 1 Pa', &
                'watts/m2', missing_value=missing_value)

        id_tdt_sw(i) = register_diag_field (mod_name,   &
                'tdt_sw'//trim(clr), axes(1:3), Time, & 
                trim(clr2)//'temperature tendency for SW radiation', &
                'deg_K/sec', missing_value=missing_value) 

        id_ufsw(i) = register_diag_field (mod_name,   &
               'allufsw'//trim(clr), bxes(1:3), Time, &
               trim(clr2)//'upward sw flux', &
               'watts/m2', missing_value=missing_value)

        id_dfsw(i) = register_diag_field (mod_name,   &
               'alldfsw'//trim(clr), bxes(1:3), Time, &
               trim(clr2)//'downward sw flux', &
               'watts/m2', missing_value=missing_value)

        id_flxnet(i) = register_diag_field (mod_name,   &
               'allnetlw'//trim(clr), bxes(1:3), Time, &
               trim(clr2)//'net lw flux', &
               'watts/m2', missing_value=missing_value)

        id_tdt_lw(i) = register_diag_field (mod_name,    &
                'tdt_lw'//trim(clr), axes(1:3), Time, &
                trim(clr2)//'temperature tendency for LW radiation', &
                'deg_K/sec', missing_value=missing_value)

        id_swdn_toa(i) = register_diag_field (mod_name,   &
                'swdn_toa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux down at TOA', &
                'watts/m2', missing_value=missing_value)

        id_swup_toa(i) = register_diag_field (mod_name,    &
                'swup_toa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux up at TOA', &
                'watts/m2', missing_value=missing_value)

        id_olr(i) = register_diag_field (mod_name,   &
                'olr'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'outgoing longwave radiation', &
                'watts/m2', missing_value=missing_value)

        id_netrad_toa(i) = register_diag_field (mod_name,   &
                'netrad_toa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'net radiation (lw + sw) at toa', &
                'watts/m2', missing_value=missing_value)

        id_netrad_1_Pa(i) = register_diag_field (mod_name,   &
                'netrad_1_Pa'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'net radiation (lw + sw) at 1 Pa', &
                'watts/m2', missing_value=missing_value)

        id_swup_sfc(i) = register_diag_field (mod_name,    &
                'swup_sfc'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux up at surface', &
                'watts/m2', missing_value=missing_value)

        id_swdn_sfc(i) = register_diag_field (mod_name,     &
                'swdn_sfc'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'SW flux down at surface', &
                'watts/m2', missing_value=missing_value)

        id_lwup_sfc(i) = register_diag_field (mod_name,   &
                'lwup_sfc'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'LW flux up at surface', &
                'watts/m2', missing_value=missing_value)

        id_lwdn_sfc(i) = register_diag_field (mod_name,    &
                'lwdn_sfc'//trim(clr), axes(1:2), Time, &
                trim(clr2)//'LW flux down at surface', &
                'watts/m2', missing_value=missing_value)

        id_swtoa(i) = register_diag_field (mod_name,    &
                 'swtoa'//trim(clr), axes(1:2), Time, &
                  trim(clr2)//' Net SW flux at TOA ', &
                  'watts/m2', missing_value=missing_value)

        id_swsfc(i) = register_diag_field (mod_name,    &
                  'swsfc'//trim(clr), axes(1:2), Time, &
                  trim(clr2)//' Net SW flux at surface', &
                  'watts/m2', missing_value=missing_value)
 
        id_lwsfc(i) = register_diag_field (mod_name,    &
                  'lwsfc'//trim(clr), axes(1:2), Time, &
                 trim(clr2)//' Net LW flux at surface', &
                  'watts/m2', missing_value=missing_value)
 
        id_swtoa_ad(i) = register_diag_field (mod_name,    &
                  'swtoa_ad'//trim(clr), axes(1:2), Time, &
                  trim(clr2)//' Net SW flux at TOA '// trim(swaer_prep) &
                                 // ' aerosol', &
                  'watts/m2', missing_value=missing_value)
 
        id_swsfc_ad(i) = register_diag_field (mod_name,    &
                 'swsfc_ad'//trim(clr), axes(1:2), Time, &
            trim(clr2)//' Net SW flux at surface '// trim(swaer_prep) &
           // ' aerosol', &
                'watts/m2', missing_value=missing_value)

       id_swdn_sfc_ad(i) = register_diag_field (mod_name,    &
                 'swdn_sfc_ad'//trim(clr), axes(1:2), Time, &
                 trim(clr2)//' SW flux down at surface '// &
                   trim(swaer_prep) // ' aerosol', &
                 'watts/m2', missing_value=missing_value)
 
        id_swup_sfc_ad(i) = register_diag_field (mod_name,    &
                 'swup_sfc_ad'//trim(clr), axes(1:2), Time, &
                 trim(clr2)//' SW flux up at surface ' //   &
                   trim(swaer_prep) // ' aerosol', &
                  'watts/m2', missing_value=missing_value)

        id_swup_toa_ad(i) = register_diag_field (mod_name,    &
                 'swup_toa_ad'//trim(clr), axes(1:2), Time, &
                 trim(clr2)//' SW flux up at TOA '  //  &
                   trim(swaer_prep) // ' aerosol', &
                 'watts/m2', missing_value=missing_value)
 
         id_olr_ad(i) = register_diag_field (mod_name,    &
                  'lwtoa_ad'//trim(clr), axes(1:2), Time, &
                  trim(clr2)//' Net LW flux at TOA (olr) ' //  &
                   trim(lwaer_prep) // ' aerosol', &
                  'watts/m2', missing_value=missing_value)

         id_lwsfc_ad(i) = register_diag_field (mod_name,    &
                  'lwsfc_ad'//trim(clr), axes(1:2), Time, &
                  trim(clr2)//' Net LW flux at surface  ' //   &
                   trim(lwaer_prep) // ' aerosol', &
                 'watts/m2', missing_value=missing_value)
 
       end do

         id_allradp   = register_diag_field (mod_name,   &
                 'allradp', axes(1:3), Time, &
                 'temperature tendency for SW + LW radiation', &
                 'deg_K/sec', missing_value=missing_value)

!----------------------------------------------------------------------
!    register fields that are not clear-sky depedent.
!----------------------------------------------------------------------
        id_conc_drop = register_diag_field (mod_name,   &
                   'conc_drop', axes(1:3), Time, & 
                   'drop concentration ', &
                   'g/m^3', missing_value=missing_value) 
    
        id_conc_ice = register_diag_field (mod_name,   &
                   'conc_ice', axes(1:3), Time, & 
                   'ice concentration ', &
                   'g/m^3', missing_value=missing_value) 
 
      
      id_flux_sw_dir = register_diag_field (mod_name,    &
                'flux_sw_dir', axes(1:2), Time, &
                'net direct sfc sw flux', 'watts/m2', &
                missing_value=missing_value)

      id_flux_sw_dif = register_diag_field (mod_name,    &
                'flux_sw_dif', axes(1:2), Time, &
                'net diffuse sfc sw flux', 'watts/m2', &
                missing_value=missing_value)

      id_flux_sw_down_vis_dir = register_diag_field (mod_name,    &
                'flux_sw_down_vis_dir', axes(1:2), Time, &
                'downward direct visible sfc sw flux', 'watts/m2', &
                 missing_value=missing_value)

      id_flux_sw_down_vis_dif = register_diag_field (mod_name,    &
                'flux_sw_down_vis_dif', axes(1:2), Time, &
                'downward diffuse visible sfc sw flux', 'watts/m2', &
                 missing_value=missing_value)

      id_flux_sw_down_total_dir = register_diag_field (mod_name,    &
                'flux_sw_down_total_dir', axes(1:2), Time, &
                'downward direct total sfc sw flux', 'watts/m2', &
                 missing_value=missing_value)

      id_flux_sw_down_total_dif = register_diag_field (mod_name,    &
               'flux_sw_down_total_dif', axes(1:2), Time, &
               'downward diffuse total sfc sw flux', 'watts/m2', &
                missing_value=missing_value)

    if (do_clear_sky_pass) then

      id_flux_sw_down_total_dir_clr = register_diag_field (mod_name,  &
               'flux_sw_down_total_dir_clr', axes(1:2), Time, &
               'downward clearsky direct total sfc sw flux',  &
               'watts/m2',  missing_value=missing_value)
  
      id_flux_sw_down_total_dif_clr = register_diag_field (mod_name,  &
               'flux_sw_down_total_dif_clr', axes(1:2), Time, &
               'downward clearsky diffuse total sfc sw flux',  &
               'watts/m2', missing_value=missing_value)

      id_flux_sw_down_vis_clr = register_diag_field (mod_name,    &
                'flux_sw_down_vis_clr', axes(1:2), Time, &
                'downward visible sfc sw flux clear sky', 'watts/m2', &
                 missing_value=missing_value)

    endif 

      id_flux_sw_vis = register_diag_field (mod_name,    &
               'flux_sw_vis', axes(1:2), Time, &
               'net visible sfc sw flux', 'watts/m2', &
                 missing_value=missing_value)

      id_flux_sw_vis_dir = register_diag_field (mod_name,    &
               'flux_sw_vis_dir', axes(1:2), Time, &
               'net direct visible sfc sw flux', 'watts/m2', &
                 missing_value=missing_value)

      id_flux_sw_vis_dif = register_diag_field (mod_name,    &
                'flux_sw_vis_dif', axes(1:2), Time, &
                'net diffuse visible sfc sw flux', 'watts/m2', &
                  missing_value=missing_value)


      id_sol_con = register_diag_field (mod_name,    &
                  'solar_constant', Time, &
                  'solar constant', 'watts/m2', &
                  missing_value=missing_value)      
                           
      id_co2_tf = register_diag_field (mod_name,    &
                  'co2_tf', Time, &
                  'co2 mixing ratio used for tf calculation', 'ppmv', &
                  missing_value=missing_value)      
                           
      id_ch4_tf = register_diag_field (mod_name,    &
                  'ch4_tf', Time, &
                  'ch4 mixing ratio used for tf calculation', 'ppbv', &
                  missing_value=missing_value)      
                           
      id_n2o_tf = register_diag_field (mod_name,    &
                  'n2o_tf', Time, &
                  'n2o mixing ratio used for tf calculation', 'ppbv', &
                  missing_value=missing_value)      
                           
      id_rrvco2 = register_diag_field (mod_name,    &
                  'rrvco2', Time, &
                  'co2 mixing ratio', 'ppmv', &
                  missing_value=missing_value)      
                           
      id_rrvf11 = register_diag_field (mod_name,    &
                  'rrvf11', Time, &
                  'f11 mixing ratio', 'pptv', &
                  missing_value=missing_value)
        
      id_rrvf12 = register_diag_field (mod_name,    &
                  'rrvf12', Time, &
                  'f12 mixing ratio', 'pptv', &
                  missing_value=missing_value)

      id_rrvf113 = register_diag_field (mod_name,    &
                   'rrvf113', Time, &
                   'f113 mixing ratio', 'pptv', &
                   missing_value=missing_value)
 
       id_rrvf22 = register_diag_field (mod_name,    &
                   'rrvf22', Time, &
                   'f22 mixing ratio', 'pptv', &
                   missing_value=missing_value)

       id_rrvch4 = register_diag_field (mod_name,    &
                   'rrvch4', Time, &
                   'ch4 mixing ratio', 'ppbv', &
                   missing_value=missing_value)

       id_rrvn2o = register_diag_field (mod_name,    &
                   'rrvn2o', Time, &
                   'n2o mixing ratio', 'ppbv', &
                   missing_value=missing_value)

         id_alb_sfc_avg = register_diag_field (mod_name,    &
                 'averaged_alb_sfc', axes(1:2), Time, &
                 'surface albedo', 'percent', &
                 missing_value=missing_value)
         if (id_alb_sfc_avg > 0) then
           allocate (swdns_acc(id,jd))
           allocate (swups_acc(id,jd))
           swups_acc = 0.0
           swdns_acc = 1.0e-35
         endif
      id_alb_sfc = register_diag_field (mod_name,    &
                'alb_sfc', axes(1:2), Time, &
                'surface albedo', 'percent', &
                  missing_value=missing_value) 

      id_alb_sfc_vis_dir = register_diag_field (mod_name,    &
                'alb_sfc_vis_dir', axes(1:2), Time, &
!               'surface albedo_vis_dir', 'percent')
! BUGFIX
                'surface albedo_vis_dir', 'percent', &
                 missing_value=missing_value)
      id_alb_sfc_nir_dir = register_diag_field (mod_name,    &
                'alb_sfc_nir_dir', axes(1:2), Time, &
!               'surface albedo_nir', 'percent')
! BUGFIX
                'surface albedo_nir_dir', 'percent', &
                  missing_value=missing_value)
 
      id_alb_sfc_vis_dif = register_diag_field (mod_name,    &
                 'alb_sfc_vis_dif', axes(1:2), Time, &
!               'surface albedo_vis', 'percent')
! BUGFIX
                 'surface albedo_vis_dif', 'percent', &
                  missing_value=missing_value)
      id_alb_sfc_nir_dif = register_diag_field (mod_name,    &
                 'alb_sfc_nir_dif', axes(1:2), Time, &
!               'surface albedo_nir', 'percent')
! BUGFIX
                 'surface albedo_nir_dif', 'percent', &
                   missing_value=missing_value)
      id_cosz = register_diag_field (mod_name,    &
                'cosz',axes(1:2),  Time,    &
                'cosine of zenith angle',    &
                'none', missing_value=missing_value)

      id_fracday = register_diag_field (mod_name,   &
                'fracday',axes(1:2), Time,   &
                'daylight fraction of radiation timestep',   &
                'percent', missing_value=missing_value)

!-----------------------------------------------------------------------


end subroutine diag_field_init



!######################################################################
! <SUBROUTINE NAME="obtain_astronomy_variables">
!  <OVERVIEW>
!    obtain_astronomy_variables retrieves astronomical variables, valid 
!    at the requested time and over the requested time intervals.
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_astronomy_variables retrieves astronomical variables, valid 
!    at the requested time and over the requested time intervals.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_astronomy_variables (is, ie, js, je, lat, lon,     &
!                                       Astro, Astro2)  
!
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending i,j indices in global storage arrays
!  </IN> 
!  <INOUT NAME="Astro" TYPE="astronomy_type">
!     astronomy_type structure; It will
!                    be used to determine the insolation at toa seen
!                    by the shortwave radiation code
!  </INOUT>
!  <INOUT NAME="Astro2" TYPE="astronomy_type">
!     astronomy_type structure, defined when renormal-
!                    ization is active. the same components are defined
!                    as for Astro, but they are valid over the current
!                    physics timestep.
!  </INOUT>
!  <INOUT NAME="Astronomy_inp" TYPE="astronomy_inp_type">
!     astronomy_inp_type structure, optionally used to input astronom-
!     ical forcings, when it is desired to specify them rather than use
!     astronomy_mod. Used in various standalone applications.
!  </INOUT>
!  <IN NAME="lon" TYPE="real">
!    lon        mean longitude (in radians) of all grid boxes processed by
!               this call to radiation_driver   [real, dimension(:,:)]
!  </IN>
!  <IN NAME="lat" TYPE="real">
!    lat        mean latitude (in radians) of all grid boxes processed by this
!               call to radiation_driver   [real, dimension(:,:)]
!  </IN>
! </SUBROUTINE>
!
subroutine obtain_astronomy_variables (is, ie, js, je, lat, lon,     &
                                       Astro, Astro2, Astronomy_inp)  

!---------------------------------------------------------------------
!    obtain_astronomy_variables retrieves astronomical variables, valid 
!    at the requested time and over the requested time intervals.
!---------------------------------------------------------------------
integer,                     intent(in)    ::  is, ie, js, je
real, dimension(:,:),        intent(in)    ::  lat, lon
type(astronomy_type),        intent(inout) ::  Astro, Astro2
type(astronomy_inp_type),   intent(inout), optional ::  &
                                               Astronomy_inp

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      lat          latitude of model points  
!                   [ radians ]
!      lon          longitude of model points 
!                   [ radians ]
!
!   intent(inout) variables:
!
!      Astro         astronomy_type structure; contains the following
!                    components defined in this subroutine that will
!                    be used to determine the insolation at toa seen
!                    by the shortwave radiation code 
!         solar         shortwave flux factor: cosine of zenith angle *
!                       daylight fraction / (earth-sun distance squared)
!                       [ non-dimensional ]
!         cosz          cosine of zenith angle --  mean value over
!                       appropriate averaging interval
!                       [ non-dimensional ]
!         fracday       fraction of timestep during which the sun is 
!                       shining
!                       [ non-dimensional ]
!         rrsun         inverse of square of earth-sun distance, 
!                       relative to the mean square of earth-sun 
!                       distance
!                       [ non-dimensional ]
!
!      Astro2        astronomy_type structure, defined when renormal-
!                    ization is active. the same components are defined
!                    as for Astro, but they are valid over the current
!                    physics timestep.
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      type(time_type)                   :: Dt_zen, Dt_zen2
      type(time_type)                   :: Rad1    
      real, dimension(ie-is+1, je-js+1) ::                            &
                                           cosz_r, solar_r, fracday_r, &
                                           cosz_p, solar_p, fracday_p, &
                                           cosz_a, fracday_a
      real                              :: rrsun_r, rrsun_p, rrsun_a
      integer                           :: nz
      

!--------------------------------------------------------------------
!  local variables:
!
!     Dt_zen        time-type variable containing the components of the
!                   radiation time step, needed unless do_average is
!                   true or this is not a radiation step and renormal-
!                   ize_sw_fluxes is true
!     Dt_zen2       time-type variable containing the components of the
!                   physics time step, needed when renormalize_sw_fluxes
!                   or do_average is true
!     cosz_r        cosine of zenith angle --  mean value over
!                   radiation time step            
!                   [ non-dimensional ]
!     solar_r       shortwave flux factor relevant over radiation time
!                   step: cosine of zenith angle * daylight fraction / 
!                   (earth-sun distance squared)
!                   [ non-dimensional ]
!     fracday_r     fraction of timestep during which the sun is 
!                   shining over radiation time step
!                   [ non-dimensional ]
!     cosz_p        cosine of zenith angle --  mean value over
!                   physics time step            
!                   [ non-dimensional ]
!     solar_p       shortwave flux factor relevant over physics time
!                   step: cosine of zenith angle * daylight fraction / 
!                   (earth-sun distance squared)
!                   [ non-dimensional ]
!     fracday_p     fraction of timestep during which the sun is 
!                   shining over physics time step
!                   [ non-dimensional ]
!     cosz_a        cosine of zenith angle --  mean value over
!                   next radiation time step            
!                   [ non-dimensional ]
!     solar_a       shortwave flux factor relevant over next radiation 
!                   time step: cosine of zenith angle * daylight 
!                   fraction / (earth-sun distance squared)
!                   [ non-dimensional ]
!     fracday_a     fraction of timestep during which the sun is 
!                   shining over next radiation time step
!                   [ non-dimensional ]
!     rrsun_r       inverse of square of earth-sun distance, 
!                   relative to the mean square of earth-sun 
!                   distance, valid over radiation time step
!                   [ non-dimensional ]
!     rrsun_p       inverse of square of earth-sun distance, 
!                   relative to the mean square of earth-sun 
!                   distance, valid over physics time step
!                   [ non-dimensional ]
!     rrsun_a       inverse of square of earth-sun distance, 
!                   relative to the mean square of earth-sun 
!                   distance, valid over next radiation time step
!                   [ non-dimensional ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    allocate the components of the astronomy_type structure which will
!    return the astronomical inputs to radiation (cosine of zenith 
!    angle, daylight fraction, solar flux factor and earth-sun distance)
!    that are to be used on the current step.
!---------------------------------------------------------------------
      allocate ( Astro%cosz   (size(lat,1), size(lat,2) ) )
      allocate ( Astro%fracday(size(lat,1), size(lat,2) ) )
      allocate ( Astro%solar  (size(lat,1), size(lat,2) ) )
      allocate ( Astro%cosz_p   (size(lat,1), size(lat,2),   &
                                                 Rad_control%nzens)  )
      allocate ( Astro%fracday_p(size(lat,1), size(lat,2),   &
                                                 Rad_control%nzens)  )
      allocate ( Astro%solar_p  (size(lat,1), size(lat,2),   &
                                                 Rad_control%nzens)  )

!---------------------------------------------------------------------
!    case 0: input parameters.
!---------------------------------------------------------------------
      if (present (Astronomy_inp)) then
        Astro%rrsun = Astronomy_inp%rrsun
        Astro%fracday(:,:) = Astronomy_inp%fracday(is:ie,js:je)
        Astro%cosz (:,:) = cos(   &
                        Astronomy_inp%zenith_angle(is:ie,js:je)/RADIAN)
        Astro%solar(:,:) = Astro%cosz(:,:)*Astro%fracday(:,:)* &
                           Astro%rrsun
        Rad_output%coszen_angle(is:ie,js:je) = Astro%cosz(:,:)
        do nz = 1, Rad_control%nzens
          Astro%fracday_p(:,:,nz) = Astro%fracday(:,:)
          Astro%cosz_p(:,:,nz) = Astro%cosz(:,:)
          Astro%solar_p(:,:,nz) = Astro%solar(:,:)
        end do

!---------------------------------------------------------------------
!    case 1: diurnally-varying shortwave radiation.
!---------------------------------------------------------------------
      else if (Sw_control%do_diurnal) then

!-------------------------------------------------------------------
!    convert the radiation timestep and the model physics timestep
!    to time_type variables.
!-------------------------------------------------------------------
        Dt_zen  = set_time (sw_rad_time_step, 0)
        Dt_zen2 = set_time (dt, 0)
        
!---------------------------------------------------------------------
!    calculate the astronomical factors averaged over the radiation time
!    step between Rad_time and Rad_time + Dt_zen. these values are 
!    needed on radiation steps. output is stored in Astro_rad.
!---------------------------------------------------------------------
        if (do_sw_rad) then
          if (Rad_control%hires_coszen) then
            Rad1 = Rad_time
            do nz=1,Rad_control%nzens
              call diurnal_solar (lat, lon, Rad1, cosz_r,  &
                                   fracday_r, rrsun_r, dt_time=Dt_zen2)
              fracday_r = MIN (fracday_r, 1.00)
              solar_r = cosz_r*fracday_r*rrsun_r
              Astro%cosz_p(:,:,nz)    = cosz_r
              Astro%fracday_p(:,:,nz) = fracday_r
              Astro%solar_p(:,:,nz)   = solar_r
              Rad1 = Rad1 + Dt_zen2
            end do
          endif
!  calculation for full radiation step:
          call diurnal_solar (lat, lon, Rad_time, cosz_r, fracday_r, &
                              rrsun_r, dt_time=Dt_zen)
          fracday_r = MIN (fracday_r, 1.00)
          solar_r = cosz_r*fracday_r*rrsun_r
        endif

!---------------------------------------------------------------------
!    calculate the astronomical factors averaged over the physics time
!    step between Rad_time and Rad_time + Dt_zen2. these values are
!    needed if either renormalization or time-averaging is active. store
!    the astronomical outputs in Astro_phys.
!---------------------------------------------------------------------
        if (renormalize_sw_fluxes) then
          call diurnal_solar (lat, lon, Rad_time, cosz_p, fracday_p, &
                              rrsun_p, dt_time=Dt_zen2)
          fracday_p = MIN (fracday_p, 1.00)
          solar_p = cosz_p*fracday_p*rrsun_p
        endif

!--------------------------------------------------------------------
!    define the astronomy_type variable(s) to be returned and used in 
!    the radiation calculation. Astro contains the values to be used
!    in the radiation calculation, Astro2 contains values relevant 
!    over the current physics timestep and is used for renormalization.
!    when renormalization is active, the physics step set is always 
!    needed, and in addition on radiation steps, the radiation step
!    values are needed. 
!---------------------------------------------------------------------
        if (renormalize_sw_fluxes) then
          if (.not. do_sw_rad) then
            Astro%cosz    = cosz_p
            Astro%fracday = fracday_p
            Astro%solar   = solar_p
            Astro%rrsun   = rrsun_p
          else 
            Astro%cosz    = cosz_r
            Astro%fracday = fracday_r
            Astro%solar   = solar_r
            Astro%rrsun   = rrsun_r
            allocate ( Astro2%fracday(size(lat,1), size(lat,2) ) )
            allocate ( Astro2%cosz   (size(lat,1), size(lat,2) ) )
            allocate ( Astro2%solar  (size(lat,1), size(lat,2) ) )
            Astro2%cosz    = cosz_p
            Astro2%fracday = fracday_p
            Astro2%solar   = solar_p
            Astro2%rrsun   = rrsun_p
          endif

!---------------------------------------------------------------------
!    if renormalization is active, then only the values applicable over
!    radiation steps are needed. 
!---------------------------------------------------------------------
        else                 
          Astro%cosz    = cosz_r
          Astro%fracday = fracday_r
          Astro%solar   = solar_r
          Astro%rrsun   = rrsun_r
        endif

!---------------------------------------------------------------------
!    when in the gcm and on a radiation calculation step, define cosine
!    of zenith angle valid over the next radiation step. this is needed 
!    so that the ocean albedo (function of zenith angle) may be properly
!    defined and provided as input to the radiation package on the next
!    timestep.
!----------------------------------------------------------------------
        if (do_sw_rad) then
          call diurnal_solar (lat, lon, Rad_time+Dt_zen, cosz_a,   &
                              fracday_a, rrsun_a, dt_time=Dt_zen)
          Rad_output%coszen_angle(is:ie,js:je) = cosz_a(:,:)
        endif  ! (do_sw_rad)

!---------------------------------------------------------------------
!    case 2: annual-mean shortwave radiation.
!---------------------------------------------------------------------
      else if (Sw_control%do_annual) then
        call annual_mean_solar (js, je, lat, Astro%cosz, Astro%solar,&
                                Astro%fracday, Astro%rrsun)

!---------------------------------------------------------------------
!    save the cosine of zenith angle on the current step to be used to 
!    calculate ocean albedo for use on the next radiation timestep.
!---------------------------------------------------------------------
        Rad_output%coszen_angle(is:ie,js:je) = Astro%cosz(:,:)

!---------------------------------------------------------------------
!    case 3: daily-mean shortwave radiation.
!---------------------------------------------------------------------
      else if (Sw_control%do_daily_mean) then
        call daily_mean_solar (lat, Rad_time, Astro%cosz,  &
                               Astro%fracday, Astro%rrsun)
        Astro%solar = Astro%cosz*Astro%rrsun*Astro%fracday

!---------------------------------------------------------------------
!    save the cosine of zenith angle on the current step to be used to 
!    calculate ocean albedo for use on the next radiation timestep.
!---------------------------------------------------------------------
        Rad_output%coszen_angle(is:ie,js:je) = Astro%cosz(:,:)

!----------------------------------------------------------------------
!    if none of the above options are active, write an error message and
!    stop execution.
!----------------------------------------------------------------------
      else
        call error_mesg('radiation_driver_mod', &
             ' no valid zenith angle specification', FATAL)
      endif

!-------------------------------------------------------------------


end subroutine obtain_astronomy_variables 



!####################################################################
! <SUBROUTINE NAME="radiation_calc">
!  <OVERVIEW>
!    radiation_calc is called on radiation timesteps and calculates
!    the long- and short-wave radiative fluxes and heating rates, and
!    obtains the radiation output fields needed in other portions of
!    the model.
!  </OVERVIEW>
!  <DESCRIPTION>
!    radiation_calc is called on radiation timesteps and calculates
!    the long- and short-wave radiative fluxes and heating rates, and
!    obtains the radiation output fields needed in other portions of
!    the model.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_calc (is, ie, js, je, Rad_time, Time_diag,  &
!                           lat, lon, Atmos_input, Surface, Rad_gases, &
!                           Aerosol_props, Aerosol, r, Cldrad_props,   &
!                           Cld_spec, Astro, Rad_output, Lw_output,   &
!                           Sw_output, Fsrad_output, mask, kbot)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending i,j indices in global storage arrays
!  </IN> 
!  <IN NAME="Rad_time" TYPE="time_type">
!      Rad_time          time at which the radiative fluxes are to apply
!                        [ time_type (days, seconds) ] 
!  </IN>
!  <IN NAME="Time_diag" TYPE="time_type">
!      Time_diag         time on next timestep, used as stamp for diag-
!                        nostic output  [ time_type  (days, seconds) ] 
!  </IN>
!  <IN NAME="lon" TYPE="real">
!    lon        mean longitude (in radians) of all grid boxes processed by
!               this call to radiation_driver   [real, dimension(:,:)]
!  </IN>
!  <IN NAME="lat" TYPE="real">
!    lat        mean latitude (in radians) of all grid boxes processed by this
!               call to radiation_driver   [real, dimension(:,:)]
!  </IN>
!  <IN NAME="Surface" TYPE="surface_type">
!   Surface input data to radiation package
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data to radiation package
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol climatological input data to radiation package
!  </IN>
!  <INOUT NAME="Aerosol_props" TYPE="aerosol_properties_type">
!   Aerosol radiative properties
!  </INOUT>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   Cloud radiative properties
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud microphysical and physical parameters to radiation package, 
!                     contains var-
!                     iables defining the cloud distribution, passed 
!                     through to lower level routines
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!   astronomical input data for the radiation package
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   Radiative gases properties to radiation package, , contains var-
!                     iables defining the radiatively active gases, 
!                     passed through to lower level routines
!  </IN>
!  <INOUT NAME="Rad_output" TYPE="rad_output_type">
!   Radiation output from radiation package, contains variables
!                     which are output from radiation_driver to the 
!                     calling routine, and then used elsewhere within
!                     the component models.
!  </INOUT>
!  <INOUT NAME="Lw_output" TYPE="lw_output_type">
!      longwave radiation output data from the 
!                        sea_esf_rad radiation package, when that 
!                        package is active
!  </INOUT>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output data from the 
!                        sea_esf_rad radiation package  when that 
!                        package is active
!  </INOUT>
!  <INOUT NAME="Fsrad_output" TYPE="Fsrad_output_type">
!   radiation output data from the original_fms_rad
!                        radiation package, when that package 
!                        is active
!  </INOUT>
!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! </SUBROUTINE>
!
subroutine radiation_calc (is, ie, js, je, Rad_time, Time_diag,  &
                           lat, lon, Atmos_input, Surface, Rad_gases, &
                           Aerosol_props, Aerosol, r, Cldrad_props,   &
                           Cld_spec, Astro, Rad_output, Lw_output,   &
                           Sw_output, Fsrad_output, Aerosol_diags, &
                           mask, kbot)

!--------------------------------------------------------------------
!    radiation_calc is called on radiation timesteps and calculates
!    the long- and short-wave radiative fluxes and heating rates, and
!    obtains the radiation output fields needed in other portions of
!    the model.
!-----------------------------------------------------------------------

!--------------------------------------------------------------------
integer,                      intent(in)             :: is, ie, js, je
type(time_type),              intent(in)             :: Rad_time,   &
                                                        Time_diag
real, dimension(:,:),         intent(in)             :: lat, lon
type(atmos_input_type),       intent(in)             :: Atmos_input 
type(surface_type),           intent(in)             :: Surface
type(radiative_gases_type),   intent(inout)          :: Rad_gases
type(aerosol_type),           intent(in)             :: Aerosol
real, dimension(:,:,:,:),     intent(inout)          :: r   
type(aerosol_properties_type),intent(inout)          :: Aerosol_props
type(cldrad_properties_type), intent(in)             :: Cldrad_props
type(cld_specification_type), intent(in)             :: Cld_spec
type(astronomy_type),         intent(in)             :: Astro
type(rad_output_type),        intent(inout)          :: Rad_output
type(lw_output_type), dimension(:),  intent(inout)   :: Lw_output
type(sw_output_type), dimension(:), intent(inout)     :: Sw_output
type(fsrad_output_type),      intent(inout)          :: Fsrad_output
type(aerosol_diagnostics_type), intent(inout)        :: Aerosol_diags
real, dimension(:,:,:),       intent(in),   optional :: mask
integer, dimension(:,:),      intent(in),   optional :: kbot

!-----------------------------------------------------------------------
!    intent(in) variables:
!
!      is,ie,js,je       starting/ending subdomain i,j indices of data 
!                        in the physics_window being integrated
!      Rad_time          time at which the radiative fluxes are to apply
!                        [ time_type (days, seconds) ] 
!      Time_diag         time on next timestep, used as stamp for diag-
!                        nostic output  [ time_type  (days, seconds) ]  
!      lat               latitude of model points on model grid 
!                        [ radians ]
!      lon               longitude of model points on model grid 
!                        [ radians ]
!      Atmos_input       atmospheric input data for the radiation 
!                        package 
!                        [ atmos_input_type ]
!      Surface           surface input data to the radiation package
!                        [ surface_type ]
!      Rad_gases         radiative gas input data for the radiation 
!                        package
!                        [ radiative_gases_type ]
!      Aerosol_props     aerosol radiative property input data for the 
!                        radiation package
!                        [ aerosol_properties_type ]
!      Aerosol           aerosol input data to the radiation package
!                        [ aerosol_type ]
!      Cldrad_props      cloud radiative property input data for the 
!                        radiation package 
!                        [ cldrad_properties_type ]
!      Cld_spec          cloud specification input data for the 
!                        radiation package
!                        [ cld_specification_type ]
!      Astro             astronomical input data for the radiation 
!                        package 
!                        [ astronomy_type ]
!      Aerosol_diags     aerosol diagnostic output                  
!                        [ aerosol_diagnostics_type ]
!
!
!    intent(out) variables:
!
!      Rad_output        radiation output data needed by other modules
!                        [ rad_output_type ]
!      Lw_output         longwave radiation output data from the 
!                        sea_esf_rad radiation package, when that 
!                        package is active
!                        [ lw_output_type ]
!          The following are the components of Lw_output:
!                 flxnet    net longwave flux at model flux levels 
!                           (including the ground and the top of the 
!                           atmosphere).
!                 heatra    longwave heating rates in model layers.
!                 flxnetcf  net longwave flux at model flux levels 
!                           (including the ground and the top of the 
!                           atmosphere) computed for cloud-free case.
!                 heatra    longwave heating rates in model layers 
!                           computed for cloud-free case.
!      Sw_output         shortwave radiation output data from the 
!                        sea_esf_rad radiation package  when that 
!                        package is active
!                        [ sw_output_type ]
!      Fsrad_output      radiation output data from the original_fms_rad
!                        radiation package, when that package 
!                        is active
!                        [ fsrad_output_type ]
!
!    intent(in), optional variables:
!
!      mask              present when running eta vertical coordinate,
!                        mask to define values at points below ground   
!      kbot              present when running eta vertical coordinate,
!                        index of lowest model level above ground 
!
!----------------------------------------------------------------------

      integer :: kmax, nz

!---------------------------------------------------------------------
!    all_column_radiation and all_level_radiation are included as 
!    future controls which may be utiliized to execute the radiation
!    code on a grid other than the model grid. in the current release
!    however, both must be .true.. 
!---------------------------------------------------------------------
      if (all_column_radiation .and. all_level_radiation) then

!--------------------------------------------------------------------
!    call routines to perform radiation calculations, either using the
!    sea_esf_rad or original_fms_rad radiation package.
!---------------------------------------------------------------------
        if (do_sea_esf_rad) then
          call sea_esf_rad (is, ie, js, je, Rad_time, Atmos_input, &
                            Surface, Astro, Rad_gases, Aerosol,  &
                            Aerosol_props, Cldrad_props, Cld_spec,  &
                            Lw_output, Sw_output, Aerosol_diags, r)

!--------------------------------------------------------------------
!    define tropopause fluxes for diagnostic use later.
!--------------------------------------------------------------------
        if (do_lw_rad .or. do_sw_rad) then
          call flux_trop_calc (is, ie, js, je, lat,  &
                               Atmos_input, Lw_output(1), Sw_output(1) )
        endif

        else  
          call original_fms_rad (is, ie, js, je, Atmos_input%phalf,  &
                                 lat, lon, do_clear_sky_pass,   &
                                 Rad_time, Time_diag, Atmos_input,  &
                                 Surface, Astro, Rad_gases,   &
                                 Cldrad_props, Cld_spec,    &
                                 Fsrad_output, mask=mask, kbot=kbot) 
        endif
      else  

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!    when this option is coded, replace this error_mesg code with
!    code which will map the input fields from the model grid to
!    the desired radiation grid. A preliminary version of code to per-
!    form this task (at least some of it) is found with the inchon
!    tagged version of this module. it is removed here, since it has
!    not been tested or validated and is considered undesirable in
!    a code being prepared for public release. no immediate need for
!    it is seen at this time, but it will be added back when such need
!    arises.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        call error_mesg ('radiation_driver_mod', &
               ' ability to calculate radiation on subset of columns'//&
              ' and/or levels not yet implemented',  FATAL)

      endif  ! (all_column .and. all_level)

!---------------------------------------------------------------------
!    define the components of Rad_output to be passed back to 
!    radiation_driver --  total and shortwave radiative heating rates 
!    for standard and clear-sky case (if desired), and surface long- 
!    and short-wave fluxes.  mask out any below ground values if 
!    necessary.
!---------------------------------------------------------------------
        if (do_sea_esf_rad) then
          if (do_sw_rad) then
            Rad_output%tdtsw(is:ie,js:je,:,:) =    &
                              Sw_output(1)%hsw(:,:,:,:)/SECONDS_PER_DAY
            Rad_output%ufsw(is:ie,js:je,:,:) =    &
                              Sw_output(1)%ufsw(:,:,:,:)
            Rad_output%dfsw(is:ie,js:je,:,:) =    &
                              Sw_output(1)%dfsw(:,:,:,:)
          endif
          if (present(mask)) then
            if (do_lw_rad) then
              Rad_output%tdtlw(is:ie,js:je,:) =   &
                        (Lw_output(1)%heatra(:,:,:)/SECONDS_PER_DAY)*  &
                                                            mask(:,:,:)
              Rad_output%flxnet(is:ie,js:je,:) =  &
                         Lw_output(1)%flxnet(:,:,:)*mask(:,:,:)
            endif
            do nz = 1, Rad_control%nzens
              Rad_output%tdt_rad (is:ie,js:je,:,nz) =   &
                         (Rad_output%tdtsw(is:ie,js:je,:,nz) + &
                            Rad_output%tdtlw(is:ie,js:je,:))*mask(:,:,:)
            end do
          else
            if (do_lw_rad) then
               Rad_output%tdtlw(is:ie,js:je,:) =   &
                             Lw_output(1)%heatra(:,:,:)/SECONDS_PER_DAY
               Rad_output%flxnet(is:ie,js:je,:) =  &
                          Lw_output(1)%flxnet(:,:,:)
            endif
            do nz = 1, Rad_control%nzens
              Rad_output%tdt_rad (is:ie,js:je,:,nz) =  &
                             (Rad_output%tdtsw(is:ie,js:je,:,nz) +   &
                                       Rad_output%tdtlw(is:ie,js:je,:))
            end do
          endif
          if (do_clear_sky_pass) then
            do nz = 1, Rad_control%nzens
              if (do_sw_rad) then
                Rad_output%tdtsw_clr(is:ie,js:je,:,nz) =   &
                           Sw_output(1)%hswcf(:,:,:,nz)/SECONDS_PER_DAY
                Rad_output%ufsw_clr(is:ie,js:je,:,nz) =   &
                           Sw_output(1)%ufswcf(:,:,:,nz)
                Rad_output%dfsw_clr(is:ie,js:je,:,nz) =   &
                           Sw_output(1)%dfswcf(:,:,:,nz)
                Rad_output%flux_sw_down_total_dir_clr(is:ie,js:je,nz) =&
                               Sw_output(1)%dfsw_dir_sfc_clr(:,:,nz)
                Rad_output%flux_sw_down_total_dif_clr(is:ie,js:je,nz) =&
                                Sw_output(1)%dfsw_dif_sfc_clr(:,:,nz)
                Rad_output%flux_sw_down_vis_clr(is:ie,js:je,nz) =   &
                                 Sw_output(1)%dfsw_vis_sfc_clr(:,:,nz)
              endif
              if (do_lw_rad) then
                Rad_output%tdtlw_clr(is:ie,js:je,:) =   &
                        Lw_output(1)%heatracf(:,:,:)/SECONDS_PER_DAY
                Rad_output%flxnetcf(is:ie,js:je,:) =  &
                              Lw_output(1)%flxnet(:,:,:)
              endif
              if (present(mask)) then
                Rad_output%tdt_rad_clr(is:ie,js:je,:,nz) =    &
                    (Rad_output%tdtsw_clr(is:ie,js:je,:,nz) +  &
                       Rad_output%tdtlw_clr(is:ie,js:je,:))*mask(:,:,:)
              else
                Rad_output%tdt_rad_clr(is:ie,js:je,:,nz) =    &
                           (Rad_output%tdtsw_clr(is:ie,js:je,:,nz) +  &
                                  Rad_output%tdtlw_clr(is:ie,js:je,:))
              endif
            end do
          endif

          kmax = size (Rad_output%tdtsw,3)
          if (do_sw_rad) then
            Rad_output%flux_sw_surf(is:ie,js:je,:) =   &
                            Sw_output(1)%dfsw(:,:,kmax+1,:) - &
                                        Sw_output(1)%ufsw(:,:,kmax+1,:)
            Rad_output%flux_sw_surf_dir(is:ie,js:je,:) =   &
                                    Sw_output(1)%dfsw_dir_sfc(:,:,:)
            Rad_output%flux_sw_surf_dif(is:ie,js:je,:) =   &
                                 Sw_output(1)%dfsw_dif_sfc(:,:,:) - &
                                      Sw_output(1)%ufsw_dif_sfc(:,:,:)
            Rad_output%flux_sw_down_vis_dir(is:ie,js:je,:) =   &
                                   Sw_output(1)%dfsw_vis_sfc_dir(:,:,:)
            Rad_output%flux_sw_down_vis_dif(is:ie,js:je,:) =   &
                                   Sw_output(1)%dfsw_vis_sfc_dif(:,:,:)
            Rad_output%flux_sw_down_total_dir(is:ie,js:je,:) =   &
                                       Sw_output(1)%dfsw_dir_sfc(:,:,:)
            Rad_output%flux_sw_down_total_dif(is:ie,js:je,:) =   &
                                      Sw_output(1)%dfsw_dif_sfc(:,:,:)
            Rad_output%flux_sw_vis (is:ie,js:je,:) =   &
                               Sw_output(1)%dfsw_vis_sfc(:,:,:) - &
                                        Sw_output(1)%ufsw_vis_sfc(:,:,:)
            Rad_output%flux_sw_vis_dir (is:ie,js:je,:) =   &
                                   Sw_output(1)%dfsw_vis_sfc_dir(:,:,:)
            Rad_output%flux_sw_vis_dif (is:ie,js:je,:) =   &
                            Sw_output(1)%dfsw_vis_sfc_dif(:,:,:) - &
                                   Sw_output(1)%ufsw_vis_sfc_dif(:,:,:)
          endif
          if (do_lw_rad) then
            Rad_output%flux_lw_surf(is:ie,js:je) =    &
                         STEFAN*Atmos_input%temp(:,:,kmax+1)**4 -   &
                                       Lw_output(1)%flxnet(:,:,kmax+1)
          endif
        else
          Rad_output%tdtsw(is:ie,js:je,:,1) = Fsrad_output%tdtsw(:,:,:)
          if (present(mask)) then
            Rad_output%tdt_rad (is:ie,js:je,:,1) =   &
                               (Rad_output%tdtsw(is:ie,js:je,:,1) + &
                                Fsrad_output%tdtlw (:,:,:))*mask(:,:,:)
          else
            Rad_output%tdt_rad (is:ie,js:je,:,1) =   &
                               (Rad_output%tdtsw(is:ie,js:je,:,1) +   &
                                Fsrad_output%tdtlw (:,:,:))
          endif
          if (do_clear_sky_pass) then
            Rad_output%tdtsw_clr(is:ie,js:je,:,1) =    &
                                          Fsrad_output%tdtsw_clr(:,:,:)
            if (present(mask)) then
              Rad_output%tdt_rad_clr(is:ie,js:je,:,1) =    &
                         (Rad_output%tdtsw_clr(is:ie,js:je,:,1) +  &
                          Fsrad_output%tdtlw_clr(:,:,:))*mask(:,:,:)
            else
              Rad_output%tdt_rad_clr(is:ie,js:je,:,1) =    &
                         (Rad_output%tdtsw_clr(is:ie,js:je,:,1) +    &
                          Fsrad_output%tdtlw_clr(:,:,:))
            endif
          endif
          Rad_output%flux_sw_surf(is:ie,js:je,1) =    &
                                             Fsrad_output%swdns(:,:) - &
                                             Fsrad_output%swups(:,:)
          Rad_output%flux_lw_surf(is:ie,js:je) = Fsrad_output%lwdns(:,:)
        endif ! (do_sea_esf_rad)


!---------------------------------------------------------------------




end subroutine radiation_calc




!######################################################################
! <SUBROUTINE NAME="update_rad_fields">
!  <OVERVIEW>
!    update_rad_fields defines the current radiative heating rate, 
!    surface long and short wave fluxes and cosine of zenith angle
!    to be returned to physics_driver, including renormalization 
!    effects when that option is activated.
!  </OVERVIEW>
!  <DESCRIPTION>
!    update_rad_fields defines the current radiative heating rate, 
!    surface long and short wave fluxes and cosine of zenith angle
!    to be returned to physics_driver, including renormalization 
!    effects when that option is activated.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call update_rad_fields (is, ie, js, je, Time_diag, Astro2,   &
!                              Sw_output, Astro, Rad_output, flux_ratio)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending i,j indices in global storage arrays
!  </IN>
!  <IN NAME="Time_diag" TYPE="time_type">
!      Time on next timestep, used as stamp for diag-
!                        nostic output  [ time_type  (days, seconds) ] 
!  </IN>
!  <INOUT NAME="Astro" TYPE="astronomy_type">
!   astronomical properties on model grid, usually
!                   valid over radiation timestep on entry, on exit are 
!                   valid over model timestep when renormalizing
!  </INOUT>
!  <IN NAME="Astro2" TYPE="astronomy_type">
!   astronomical properties on model grid, valid over 
!                   physics timestep, used when renormalizing sw fluxes
!  </IN>
!  <INOUT NAME="Rad_output" TYPE="rad_output_type">
!   Radiation output from radiation package, contains variables
!                     which are output from radiation_driver to the 
!                     calling routine, and then used elsewhere within
!                     the component models.
!  </INOUT>
!  <IN NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output data from the 
!                        sea_esf_rad radiation package  when that 
!                        package is active
!  </IN>
!  <OUT NAME="flux_ratio" TYPE="real">
!   factor to multiply the radiation step values of 
!                   sw fluxes and heating rates by in order to get
!                   current physics timestep values
!  </OUT>
! </SUBROUTINE>
!
subroutine update_rad_fields (is, ie, js, je, Time_diag, Astro2,   &
                              Sw_output, Astro, Rad_output, flux_ratio)

!---------------------------------------------------------------------
!    update_rad_fields defines the current radiative heating rate, 
!    surface long and short wave fluxes and cosine of zenith angle
!    to be returned to physics_driver, including renormalization 
!    effects when that option is activated.
!--------------------------------------------------------------------

integer,                 intent(in)    ::  is, ie, js, je
type(time_type),         intent(in)    ::  Time_diag
type(astronomy_type),    intent(in)    ::  Astro2
type(sw_output_type), dimension(:),   intent(inout)    ::  Sw_output
type(astronomy_type),    intent(inout) ::  Astro
type(rad_output_type),   intent(inout) ::  Rad_output
real,  dimension(:,:),   intent(out)   ::  flux_ratio

!-------------------------------------------------------------------
!  intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data 
!                   in the physics_window being integrated
!      Time_diag    time on next timestep, used as stamp for diag-
!                   nostic output  [ time_type  (days, seconds) ]  
!      Astro2       astronomical properties on model grid, valid over 
!                   physics timestep, used when renormalizing sw fluxes
!                   [astronomy_type]
!      Sw_output    shortwave output variables on model grid,
!                   [sw_output_type]     
!
!  intent(inout) variables:
!
!      Astro        astronomical properties on model grid, usually
!                   valid over radiation timestep on entry, on exit are 
!                   valid over model timestep when renormalizing
!                   [astronomy_type]
!      Rad_output   radiation output variables on model grid, valid
!                   on entry over either physics or radiation timestep, 
!                   on exit are valid over physics step when renormal-
!                   izing sw fluxes
!                   [rad_output_type]     
!
!  intent(out) variables:
!
!      flux_ratio   factor to multiply the radiation step values of 
!                   sw fluxes and heating rates by in order to get
!                   current physics timestep values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
!
      real, dimension (is:ie, js:je,                                  &
                      size(Rad_output%tdt_rad,3))  ::  tdtlw, tdtlw_clr
      integer   :: i, j, k
      integer   :: nz

!---------------------------------------------------------------------
!  local variables:
!
!     tdtlw              longwave heating rate
!                        [ deg K sec(-1) ]
!     tdtlw_clr          longwave heating rate under clear sky 
!                        conditions
!                        [ deg K sec(-1) ]
!     i,j,k              do-loop indices
!
!---------------------------------------------------------------------

      if (renormalize_sw_fluxes) then

!----------------------------------------------------------------------
!    if sw fluxes are to be renormalized, save the heating rates, fluxes
!    and solar factor calculated on radiation steps.
!---------------------------------------------------------------------
        if (do_sw_rad) then
          solar_save(is:ie,js:je)  = Astro%solar(:,:)
          dfsw_save(is:ie,js:je,:,:) = Sw_output(1)%dfsw(:, :,:,:)
          ufsw_save(is:ie,js:je,:,:) = Sw_output(1)%ufsw(:, :,:,:)
          if (do_swaerosol_forcing) then
            dfsw_ad_save(is:ie,js:je,:,:) =   &
                                    Sw_output(indx_swaf)%dfsw(:, :,:,:)
            ufsw_ad_save(is:ie,js:je,:,:) =    &
                                    Sw_output(indx_swaf)%ufsw(:, :,:,:)
          endif
          fsw_save(is:ie,js:je,:,:)  = Sw_output(1)%fsw(:, :,:,:)
          hsw_save(is:ie,js:je,:,:)  = Sw_output(1)%hsw(:, :,:,:)
          flux_sw_surf_save(is:ie,js:je,:) =    &
                                 Rad_output%flux_sw_surf(is:ie,js:je,:)
          flux_sw_surf_dir_save(is:ie,js:je,:) =    &
                             Rad_output%flux_sw_surf_dir(is:ie,js:je,:)
          flux_sw_surf_dif_save(is:ie,js:je,:) =    &
                             Rad_output%flux_sw_surf_dif(is:ie,js:je,:)
          flux_sw_down_vis_dir_save(is:ie,js:je,:) =    &
                         Rad_output%flux_sw_down_vis_dir(is:ie,js:je,:)
          flux_sw_down_vis_dif_save(is:ie,js:je,:) =    &
                         Rad_output%flux_sw_down_vis_dif(is:ie,js:je,:)
          flux_sw_down_total_dir_save(is:ie,js:je,:) =    &
                      Rad_output%flux_sw_down_total_dir(is:ie,js:je,:)
          flux_sw_down_total_dif_save(is:ie,js:je,:) =    &
                      Rad_output%flux_sw_down_total_dif(is:ie,js:je,:)
          flux_sw_vis_save(is:ie,js:je,:) =    &
                              Rad_output%flux_sw_vis(is:ie,js:je,:)
          flux_sw_vis_dir_save(is:ie,js:je,:) =    &
                   Rad_output%flux_sw_vis_dir(is:ie,js:je,:)
          flux_sw_vis_dif_save(is:ie,js:je,:) =    &
                               Rad_output%flux_sw_vis_dif(is:ie,js:je,:)
          sw_heating_save(is:ie,js:je,:,:) =    &
                              Rad_output%tdtsw(is:ie,js:je,:,:)
          tot_heating_save(is:ie,js:je,:,:) =    &
                              Rad_output%tdt_rad(is:ie,js:je,:,:)
          swdn_special_save(is:ie,js:je,:,:) =   &
                                     Sw_output(1)%swdn_special(:,:,:,:)
          swup_special_save(is:ie,js:je,:,:) =   &
                                     Sw_output(1)%swup_special(:,:,:,:)
          if (do_clear_sky_pass) then
            sw_heating_clr_save(is:ie,js:je,:,:) =    &
                              Rad_output%tdtsw_clr(is:ie,js:je,:,:)
            tot_heating_clr_save(is:ie,js:je,:,:) =    &
                              Rad_output%tdt_rad_clr(is:ie,js:je,:,:)
            dfswcf_save(is:ie,js:je,:,:) = Sw_output(1)%dfswcf(:, :,:,:)
            ufswcf_save(is:ie,js:je,:,:) = Sw_output(1)%ufswcf(:, :,:,:)
            if (do_swaerosol_forcing) then
              dfswcf_ad_save(is:ie,js:je,:,:) =    &
                                  Sw_output(indx_swaf)%dfswcf(:, :,:,:)
              ufswcf_ad_save(is:ie,js:je,:,:) =   &
                                  Sw_output(indx_swaf)%ufswcf(:, :,:,:)
            endif
            fswcf_save(is:ie,js:je,:,:)  = Sw_output(1)%fswcf(:, :,:,:)
            hswcf_save(is:ie,js:je,:,:)  = Sw_output(1)%hswcf(:, :,:,:)
            flux_sw_down_total_dir_clr_save(is:ie,js:je,:) =    &
                   Rad_output%flux_sw_down_total_dir_clr(is:ie,js:je,:)
            flux_sw_down_total_dif_clr_save(is:ie,js:je,:) =    &
                    Rad_output%flux_sw_down_total_dif_clr(is:ie,js:je,:)
            flux_sw_down_vis_clr_save(is:ie,js:je,:) =    &
                    Rad_output%flux_sw_down_vis_clr(is:ie,js:je,:)
            swdn_special_clr_save(is:ie,js:je,:,:) =  &
                                Sw_output(1)%swdn_special_clr(:,:,:,:)
            swup_special_clr_save(is:ie,js:je,:,:) =  &
                                Sw_output(1)%swup_special_clr(:,:,:,:)
          endif 

!---------------------------------------------------------------------
!    define the ratio of the solar factor valid over this physics step
!    to that valid over the current radiation timestep.
!---------------------------------------------------------------------
          do j=1,je-js+1
            do i=1,ie-is+1
              if (solar_save(i+is-1,j+js-1) /= 0.0) then
                flux_ratio(i, j) = Astro2%solar(i,j)/   &
                                            solar_save(i+is-1,j+js-1)
              else
                flux_ratio(i,j) = 0.0
              endif

!---------------------------------------------------------------------
!    move the physics-step values(Astro2) to Astro, which will be used 
!    to calculate diagnostics. the radiation_step values (Astro) are no
!    longer needed.
!---------------------------------------------------------------------
              Astro%cosz(i,j) = Astro2%cosz(i,j)
              Astro%fracday(i,j) = Astro2%fracday(i,j)
              Astro%solar(i,j) = Astro2%solar(i,j)
              Astro%rrsun = Astro2%rrsun
            end do
          end do

!----------------------------------------------------------------------
!    on non-radiation steps define the ratio of the current solar factor
!    valid for this physics step to that valid for the last radiation 
!    step. 
!----------------------------------------------------------------------
        else 
          do j=1,je-js+1
            do i=1,ie-is+1
              if (solar_save(i+is-1,j+js-1) /= 0.0) then
                flux_ratio(i, j) = Astro%solar(i,j)/   &
                                            solar_save(i+is-1,j+js-1)
              else
                flux_ratio(i,j) = 0.0
              endif
            end do
          end do
        endif  ! (do_sw_rad)

!---------------------------------------------------------------------
!    redefine the total and shortwave heating rates, along with surface
!    sw fluxes, as a result of the difference in solar factor (the 
!    relative earth-sun motion) between the current physics and current
!    radiation timesteps.
!---------------------------------------------------------------------
        nz = current_sw_zenith_step
        tdtlw(:,:,:) = tot_heating_save(is:ie,js:je,:,nz) -    &
                       sw_heating_save(is:ie,js:je,:,nz)
        do k=1, size(Rad_output%tdt_rad,3)
          Rad_output%tdtsw(is:ie,js:je,k,nz) =    &
                       sw_heating_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
        end do
        do k=1, size(Rad_output%tdt_rad,3)+1
          Rad_output%ufsw(is:ie,js:je,k,nz) =    &
                       ufsw_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          Rad_output%dfsw(is:ie,js:je,k,nz) =    &
                       dfsw_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
        end do
        Rad_output%tdt_rad(is:ie,js:je,:,nz) = tdtlw(:,:,:) +    &
                                     Rad_output%tdtsw(is:ie,js:je,:,nz)
        Rad_output%flux_sw_surf(is:ie,js:je,nz) = flux_ratio(:,:)*    &
                                      flux_sw_surf_save(is:ie,js:je,nz)
        Rad_output%flux_sw_surf_dir(is:ie,js:je,nz) = flux_ratio(:,:)* &
                                  flux_sw_surf_dir_save(is:ie,js:je,nz)
        Rad_output%flux_sw_surf_dif(is:ie,js:je,nz) = flux_ratio(:,:)* &
                           flux_sw_surf_dif_save(is:ie,js:je,nz)
        Rad_output%flux_sw_down_vis_dir(is:ie,js:je,nz) =    &
               flux_ratio(:,:)*flux_sw_down_vis_dir_save(is:ie,js:je,nz)
        Rad_output%flux_sw_down_vis_dif(is:ie,js:je,nz) =  &
              flux_ratio(:,:)*flux_sw_down_vis_dif_save(is:ie,js:je,nz)
        Rad_output%flux_sw_down_total_dir(is:ie,js:je,nz) =   &
             flux_ratio(:,:)*flux_sw_down_total_dir_save(is:ie,js:je,nz)
        Rad_output%flux_sw_down_total_dif(is:ie,js:je,nz) =   &
             flux_ratio(:,:)*flux_sw_down_total_dif_save(is:ie,js:je,nz)
        Rad_output%flux_sw_vis(is:ie,js:je,nz) = flux_ratio(:,:)*    &
                                    flux_sw_vis_save(is:ie,js:je,nz)
        Rad_output%flux_sw_vis_dir(is:ie,js:je,nz) = flux_ratio(:,:)*  &
                                   flux_sw_vis_dir_save(is:ie,js:je,nz)
        Rad_output%flux_sw_vis_dif(is:ie,js:je,nz) = flux_ratio(:,:)* &
                                   flux_sw_vis_dif_save(is:ie,js:je,nz)
        if (do_clear_sky_pass) then
          tdtlw_clr(:,:,:) = tot_heating_clr_save(is:ie,js:je,:,nz) -  &
                             sw_heating_clr_save (is:ie,js:je,:,nz)
          Rad_output%flux_sw_down_total_dir_clr(is:ie,js:je,nz) =   &
                  flux_ratio(:,:)*     &
                        flux_sw_down_total_dir_clr_save(is:ie,js:je,nz)
          Rad_output%flux_sw_down_total_dif_clr(is:ie,js:je,nz) =   &
                  flux_ratio(:,:) * &
                        flux_sw_down_total_dif_clr_save(is:ie,js:je,nz)
          Rad_output%flux_sw_down_vis_clr(is:ie,js:je,nz) =   &
               flux_ratio(:,:)*flux_sw_down_vis_clr_save(is:ie,js:je,nz)
          do k=1, size(Rad_output%tdt_rad,3)
            Rad_output%tdtsw_clr(is:ie,js:je,k,nz) =   &
                        sw_heating_clr_save (is:ie,js:je,k,nz)*   &
                                                        flux_ratio(:,:)
          end do
          do k=1, size(Rad_output%tdt_rad,3)+1
            Rad_output%ufsw_clr(is:ie,js:je,k,nz) =    &
                        ufswcf_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
            Rad_output%dfsw_clr(is:ie,js:je,k,nz) =    &
                        dfswcf_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          end do
          Rad_output%tdt_rad_clr(is:ie,js:je,:,nz) = tdtlw_clr(:,:,:) +&
                           Rad_output%tdtsw_clr(is:ie,js:je,:,nz)
        endif
      else if (all_step_diagnostics) then

!----------------------------------------------------------------------
!    if sw fluxes are to be output on every physics step, save the 
!    heating rates and fluxes calculated on radiation steps.
!---------------------------------------------------------------------
        if (do_sw_rad) then
          if (do_swaerosol_forcing) then
            dfsw_ad_save(is:ie,js:je,:,:) =    &
                                   Sw_output(indx_swaf)%dfsw(:, :,:,:)
            ufsw_ad_save(is:ie,js:je,:,:) =    &
                                   Sw_output(indx_swaf)%ufsw(:, :,:,:)
          endif
          dfsw_save(is:ie,js:je,:,:) = Sw_output(1)%dfsw(:, :,:,:)
          ufsw_save(is:ie,js:je,:,:) = Sw_output(1)%ufsw(:, :,:,:)
          fsw_save(is:ie,js:je,:,:)  = Sw_output(1)%fsw(:, :,:,:)
          hsw_save(is:ie,js:je,:,:)  = Sw_output(1)%hsw(:, :,:,:)
          flux_sw_surf_save(is:ie,js:je,:) =    &
                              Rad_output%flux_sw_surf(is:ie,js:je,:)
          flux_sw_surf_dir_save(is:ie,js:je,:) =    &
                              Rad_output%flux_sw_surf_dir(is:ie,js:je,:)
          flux_sw_surf_dif_save(is:ie,js:je,:) =    &
                              Rad_output%flux_sw_surf_dif(is:ie,js:je,:)
          flux_sw_down_vis_dir_save(is:ie,js:je,:) =    &
                          Rad_output%flux_sw_down_vis_dir(is:ie,js:je,:)
          flux_sw_down_vis_dif_save(is:ie,js:je,:) =    &
                         Rad_output%flux_sw_down_vis_dif(is:ie,js:je,:)
          flux_sw_down_total_dir_save(is:ie,js:je,:) =    &
                       Rad_output%flux_sw_down_total_dir(is:ie,js:je,:)
          flux_sw_down_total_dif_save(is:ie,js:je,:) =    &
                       Rad_output%flux_sw_down_total_dif(is:ie,js:je,:)
          flux_sw_vis_save(is:ie,js:je,:) =    &
                               Rad_output%flux_sw_vis(is:ie,js:je,:)
          flux_sw_vis_dir_save(is:ie,js:je,:) =    &
                            Rad_output%flux_sw_vis_dir(is:ie,js:je,:)
          flux_sw_vis_dif_save(is:ie,js:je,:) =    &
                               Rad_output%flux_sw_vis_dif(is:ie,js:je,:)
          sw_heating_save(is:ie,js:je,:,:) =    &
                             Rad_output%tdtsw(is:ie,js:je,:,:)
          tot_heating_save(is:ie,js:je,:,:) =    &
                               Rad_output%tdt_rad(is:ie,js:je,:,:)
          swdn_special_save(is:ie,js:je,:,:) =   &
                                 Sw_output(1)%swdn_special(:,:,:,:)
          swup_special_save(is:ie,js:je,:,:) =   &
                                 Sw_output(1)%swup_special(:,:,:,:)
          if (do_clear_sky_pass) then
            sw_heating_clr_save(is:ie,js:je,:,:) =    &
                        Rad_output%tdtsw_clr(is:ie,js:je,:,:)
            tot_heating_clr_save(is:ie,js:je,:,:) =    &
                          Rad_output%tdt_rad_clr(is:ie,js:je,:,:)
            dfswcf_save(is:ie,js:je,:,:) = Sw_output(1)%dfswcf(:, :,:,:)
            ufswcf_save(is:ie,js:je,:,:) = Sw_output(1)%ufswcf(:, :,:,:)
            if (do_swaerosol_forcing) then
              dfswcf_ad_save(is:ie,js:je,:,:) =  &
                                 Sw_output(indx_swaf)%dfswcf(:, :,:,:)
              ufswcf_ad_save(is:ie,js:je,:,:) =   &
                                 Sw_output(indx_swaf)%ufswcf(:, :,:,:)
            endif
            fswcf_save(is:ie,js:je,:,:)  = Sw_output(1)%fswcf(:, :,:,:)
            hswcf_save(is:ie,js:je,:,:)  = Sw_output(1)%hswcf(:, :,:,:)
            flux_sw_down_total_dir_clr_save(is:ie,js:je,:) =    &
                  Rad_output%flux_sw_down_total_dir_clr(is:ie,js:je,:)
            flux_sw_down_total_dif_clr_save(is:ie,js:je,:) =    &
                   Rad_output%flux_sw_down_total_dif_clr(is:ie,js:je,:)
            flux_sw_down_vis_clr_save(is:ie,js:je,:) =    &
                         Rad_output%flux_sw_down_vis_clr(is:ie,js:je,:)
            swdn_special_clr_save(is:ie,js:je,:,:) =   &
                                Sw_output(1)%swdn_special_clr(:,:,:,:)
            swup_special_clr_save(is:ie,js:je,:,:) =   &
                                Sw_output(1)%swup_special_clr(:,:,:,:)
          endif
        endif
      else
        flux_ratio(:,:) = 1.0
      endif  ! (renormalize_sw_fluxes)

!--------------------------------------------------------------------



end subroutine update_rad_fields 



!####################################################################

! <SUBROUTINE NAME="flux_trop_calc">
!  <OVERVIEW>
!    flux_trop_calc defines the shortwave and longwave fluxes at the
!    tropopause immediately after the computation of fluxes at model
!    levels by the radiation algorithms (invoked by radiation_calc).
!  </OVERVIEW>
!  <DESCRIPTION>
!    flux_trop_calc defines the shortwave and longwave fluxes at the
!    tropopause immediately after the computation of fluxes at model
!    levels by the radiation algorithms (invoked by radiation_calc).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_trop_calc          (is, ie, js, je, lat,      &
!                                 Atmos_input,              &
!                                 Lw_output, Sw_output )
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending i,j indices in global storage arrays
!  </IN>
!  <IN NAME="lat" TYPE="real">
!    mean latitude (in radians) of all grid boxes processed by this
!    call to flux_trop_calc   [real, dimension(:,:)]
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data to radiation package
!  </IN>
!  <INOUT NAME="Lw_output" TYPE="lw_output_type">
!      longwave radiation output data from the 
!                        sea_esf_rad radiation package, when that 
!                        package is active
!  </INOUT>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output data from the 
!                        sea_esf_rad radiation package  when that 
!                        package is active
!  </INOUT>
! </SUBROUTINE>

subroutine flux_trop_calc    (is, ie, js, je, lat, Atmos_input, &
                              Lw_output, Sw_output )

integer,                 intent(in)             :: is, ie, js, je
real,dimension(:,:),     intent(in)             :: lat
type(atmos_input_type),  intent(in)             :: Atmos_input
type(lw_output_type),    intent(inout)          :: Lw_output
type(sw_output_type),    intent(inout)          :: Sw_output

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data 
!                   in the physics_window being integrated
!      lat          latitude of model points  [ radians ]
!      Atmos_input  component pflux (pressure at layer boundaries [ Pa ]
!                   is used
!
!   intent(inout) variables:
!      Lw_output    lw_output_type variable containing output from 
!                   the longwave radiation code of the
!                   sea_esf_rad package, on the model grid
!      Sw_output    sw_output_type variable containing output from 
!                   the shortwave radiation code of the
!                   sea_esf_rad package, on the model grid

      real, dimension (ie-is+1,je-js+1) ::      lat_deg, tropo_ht
      real, dimension (ie-is+1,je-js+1) ::      netlw_trop,  &
                                                swdn_trop, swup_trop, &
                                                netlw_trop_clr, &
                                                swdn_trop_clr,  &
                                                swup_trop_clr
      integer           :: j, k, nz
      integer           :: ki, i
      integer           :: kmax
      real              :: wtlo, wthi

      kmax = size(Atmos_input%pflux,3) - 1

!---------------------------------------------------------------------
!    compute net downward flux at 1 Pa (top of dynmamical model)
!    here dynamical pressure top is hard-wired to 1 Pa.
!---------------------------------------------------------------------
 
      do j = 1,je-js+1
        do i = 1,ie-is+1
          wtlo = (1.0           - Atmos_input%pflux(i,j,1))/ &
               (Atmos_input%pflux(i,j,2) - Atmos_input%pflux(i,j,1))
          wthi = 1.0 - wtlo
          if (Rad_control%do_lw_rad) then
            netlw_trop(i,j) = wthi*Lw_output%flxnet(i,j,1) + &
                              wtlo*Lw_output%flxnet(i,j,2)
            Lw_output%netlw_special(i,j,4) = netlw_trop(i,j)
            if (do_clear_sky_pass) then
              netlw_trop_clr(i,j) = wthi*Lw_output%flxnetcf(i,j,1) + &
                                    wtlo*Lw_output%flxnetcf(i,j,2)
              Lw_output%netlw_special_clr(i,j,4) = netlw_trop_clr(i,j)
            endif
          endif
          if (Rad_control%do_sw_rad) then
            do nz = 1,Rad_control%nzens
              swdn_trop(i,j) = wthi*Sw_output%dfsw(i,j,1,nz) + &
                               wtlo*Sw_output%dfsw(i,j,2,nz)
              swup_trop(i,j) = wthi*Sw_output%ufsw(i,j,1,nz) + &
                               wtlo*Sw_output%ufsw(i,j,2,nz)
              Sw_output%swdn_special(i,j,4,nz) = swdn_trop(i,j)
              Sw_output%swup_special(i,j,4,nz) = swup_trop(i,j)
              if (do_clear_sky_pass) then
                swdn_trop_clr(i,j) = wthi*Sw_output%dfswcf(i,j,1,nz) +&
                                     wtlo*Sw_output%dfswcf(i,j,2,nz)
                swup_trop_clr(i,j) = wthi*Sw_output%ufswcf(i,j,1,nz) +&
                                     wtlo*Sw_output%ufswcf(i,j,2,nz)
                Sw_output%swdn_special_clr(i,j,4,nz) =   &
                                                  swdn_trop_clr(i,j)
                Sw_output%swup_special_clr(i,j,4,nz) =    &
                                                swup_trop_clr(i,j)
              endif
            end do
          endif
        enddo
      enddo


      if (constant_tropo) then
        tropo_ht(:,:) = trop_ht_constant
! interpolate the fluxes between the appropriate pressures bracketing
! (trop) 

        do j = 1,je-js+1
          do i = 1,ie-is+1
            do k = kmax+1,2,-1
              if (Atmos_input%pflux(i,j,k) >= tropo_ht(i,j) .and.     &
                  Atmos_input%pflux(i,j,k-1) < tropo_ht(i,j))      then
                ki = k
!   the indices for high,low pressure bracketing "tropo_ht" are ki, ki-1
            wtlo = (tropo_ht(i,j) - Atmos_input%pflux(i,j,ki-1))/ &
              (Atmos_input%pflux(i,j,ki) - Atmos_input%pflux(i,j,ki-1))
            wthi = 1.0 - wtlo
            if (Rad_control%do_lw_rad) then
              netlw_trop(i,j) = wtlo*Lw_output%flxnet(i,j,ki) + &
                              wthi*Lw_output%flxnet(i,j,ki-1)
              Lw_output%netlw_special(i,j,1) = netlw_trop(i,j)
              if (do_clear_sky_pass) then
               netlw_trop_clr(i,j) = wtlo*Lw_output%flxnetcf(i,j,ki) + &
                                    wthi*Lw_output%flxnetcf(i,j,ki-1)
               Lw_output%netlw_special_clr(i,j,1) = netlw_trop_clr(i,j)
              endif
            endif
            if (Rad_control%do_sw_rad) then
              do nz = 1,Rad_control%nzens
              swdn_trop(i,j) = wtlo*Sw_output%dfsw(i,j,ki,nz) + &
                               wthi*Sw_output%dfsw(i,j,ki-1,nz)
              swup_trop(i,j) = wtlo*Sw_output%ufsw(i,j,ki,nz) + &
                               wthi*Sw_output%ufsw(i,j,ki-1,nz)
              Sw_output%swdn_special(i,j,1,nz) = swdn_trop(i,j)
              Sw_output%swup_special(i,j,1,nz) = swup_trop(i,j)
              if (do_clear_sky_pass) then
                swdn_trop_clr(i,j) = wtlo*Sw_output%dfswcf(i,j,ki,nz) +&
                                     wthi*Sw_output%dfswcf(i,j,ki-1,nz)
                swup_trop_clr(i,j) = wtlo*Sw_output%ufswcf(i,j,ki,nz) +&
                                     wthi*Sw_output%ufswcf(i,j,ki-1,nz)
                Sw_output%swdn_special_clr(i,j,1,nz) =   &
                                               swdn_trop_clr(i,j)
                Sw_output%swup_special_clr(i,j,1,nz) =    &
                                               swup_trop_clr(i,j)
              endif
              end do
            endif
            exit
          endif
          enddo
        enddo
        enddo
      endif
      if (linear_tropo) then
        lat_deg(:,:) = lat(:,:)*RADIAN
        tropo_ht(:,:) = trop_ht_at_eq + ABS(lat_deg(:,:))*  &
                        (trop_ht_at_poles - trop_ht_at_eq)/90.
! interpolate the fluxes between the appropriate pressures bracketing
! (trop) 

        do i = 1,ie-is+1
         do j = 1,je-js+1
          do k = kmax+1,2,-1
          if (Atmos_input%pflux(i,j,k) >= tropo_ht(i,j) .and.     &
              Atmos_input%pflux(i,j,k-1) < tropo_ht(i,j))      then
            ki = k
!   the indices for high,low pressure bracketing "tropo_ht" are ki, ki-1
            wtlo = (tropo_ht(i,j) - Atmos_input%pflux(i,j,ki-1))/ &
              (Atmos_input%pflux(i,j,ki) - Atmos_input%pflux(i,j,ki-1))
            wthi = 1.0 - wtlo
            if (Rad_control%do_lw_rad) then
            netlw_trop(i,j) = wtlo*Lw_output%flxnet(i,j,ki) + &
                              wthi*Lw_output%flxnet(i,j,ki-1)
            Lw_output%netlw_special(i,j,2) = netlw_trop(i,j)
            if (do_clear_sky_pass) then
              netlw_trop_clr(i,j) = wtlo*Lw_output%flxnetcf(i,j,ki) + &
                                    wthi*Lw_output%flxnetcf(i,j,ki-1)
              Lw_output%netlw_special_clr(i,j,2) = netlw_trop_clr(i,j)
            endif
            endif
            if (Rad_control%do_sw_rad) then
              do nz = 1,Rad_control%nzens
            swdn_trop(i,j) = wtlo*Sw_output%dfsw(i,j,ki,nz) + &
                             wthi*Sw_output%dfsw(i,j,ki-1,nz)
            swup_trop(i,j) = wtlo*Sw_output%ufsw(i,j,ki,nz) + &
                             wthi*Sw_output%ufsw(i,j,ki-1,nz)
            Sw_output%swdn_special(i,j,2,nz) = swdn_trop(i,j)
            Sw_output%swup_special(i,j,2,nz) = swup_trop(i,j)
            if (do_clear_sky_pass) then
              swdn_trop_clr(i,j) = wtlo*Sw_output%dfswcf(i,j,ki,nz) + &
                                   wthi*Sw_output%dfswcf(i,j,ki-1,nz)
              swup_trop_clr(i,j) = wtlo*Sw_output%ufswcf(i,j,ki,nz) + &
                                   wthi*Sw_output%ufswcf(i,j,ki-1,nz)
              Sw_output%swdn_special_clr(i,j,2,nz) = swdn_trop_clr(i,j)
              Sw_output%swup_special_clr(i,j,2,nz) = swup_trop_clr(i,j)
            endif
            end do
            endif
            exit
          endif
          enddo
        enddo
        enddo
      endif
      if (thermo_tropo) then
        call error_mesg ( 'radiation_driver_mod', &
              'thermo_tropo option not yet available', FATAL)
! interpolate the fluxes between the appropriate pressures bracketing
! (trop) 

        do i = 1,ie-is+1
         do j = 1,je-js+1
          do k = kmax+1,2,-1
          if (Atmos_input%pflux(i,j,k) >= tropo_ht(i,j) .and.     &
              Atmos_input%pflux(i,j,k-1) < tropo_ht(i,j))      then
            ki = k
!   the indices for high,low pressure bracketing "tropo_ht" are ki, ki-1
            wtlo = (tropo_ht(i,j) - Atmos_input%pflux(i,j,ki-1))/ &
              (Atmos_input%pflux(i,j,ki) - Atmos_input%pflux(i,j,ki-1))
            wthi = 1.0 - wtlo
            if (Rad_control%do_lw_rad) then
            netlw_trop(i,j) = wtlo*Lw_output%flxnet(i,j,ki) + &
                              wthi*Lw_output%flxnet(i,j,ki-1)
            Lw_output%netlw_special(i,j,3) = netlw_trop(i,j)
            if (do_clear_sky_pass) then
              netlw_trop_clr(i,j) = wtlo*Lw_output%flxnetcf(i,j,ki) + &
                                    wthi*Lw_output%flxnetcf(i,j,ki-1)
              Lw_output%netlw_special_clr(i,j,3) = netlw_trop_clr(i,j)
             endif
             endif
            if (Rad_control%do_sw_rad) then
              do nz = 1,Rad_control%nzens
            swdn_trop(i,j) = wtlo*Sw_output%dfsw(i,j,ki,nz) + &
                             wthi*Sw_output%dfsw(i,j,ki-1,nz)
            swup_trop(i,j) = wtlo*Sw_output%ufsw(i,j,ki,nz) + &
                             wthi*Sw_output%ufsw(i,j,ki-1,nz)
            Sw_output%swdn_special(i,j,3,nz) = swdn_trop(i,j)
            Sw_output%swup_special(i,j,3,nz) = swup_trop(i,j)
            if (do_clear_sky_pass) then
              swdn_trop_clr(i,j) = wtlo*Sw_output%dfswcf(i,j,ki,nz) + &
                                   wthi*Sw_output%dfswcf(i,j,ki-1,nz)
              swup_trop_clr(i,j) = wtlo*Sw_output%ufswcf(i,j,ki,nz) + &
                                   wthi*Sw_output%ufswcf(i,j,ki-1,nz)
              Sw_output%swdn_special_clr(i,j,3,nz) = swdn_trop_clr(i,j)
              Sw_output%swup_special_clr(i,j,3,nz) = swup_trop_clr(i,j)
            endif
            end do
            endif
            exit
          endif
          enddo
        enddo
        enddo
      endif

end subroutine flux_trop_calc 


!####################################################################
! <SUBROUTINE NAME="produce_radiation_diagnostics">
!  <OVERVIEW>
!    produce_radiation_diagnostics produces netcdf output and global 
!    and hemispheric integrals of radiation package variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    produce_radiation_diagnostics produces netcdf output and global 
!    and hemispheric integrals of radiation package variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call produce_radiation_diagnostics          &
!                            (is, ie, js, je, Time_diag, lat, ts, asfc, &
!                             flux_ratio, Astro, Rad_output, Lw_output, &
!                             Sw_output, Cld_spec, Lsc_microphys,    &
!                             Fsrad_output, mask)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending i,j indices in global storage arrays
!  </IN> 

!  <IN NAME="Time_diag" TYPE="time_type">
!      Time_diag         time on next timestep, used as stamp for diag-
!                        nostic output  [ time_type  (days, seconds) ] 
!  </IN>

!  <IN NAME="lat" TYPE="real">
!    lat        mean latitude (in radians) of all grid boxes processed by this
!               call to radiation_driver   [real, dimension(:,:)]
!  </IN>
!  <IN NAME="ts" TYPE="real">
!   Surface skin temperature
!  </IN>
!  <IN NAME="asfc" TYPE="real">
!   surface albedo
!  </IN>
!  <IN NAME="flux_ratio" TYPE="real">
!   renormalization factor for sw fluxes and heating 
!                   rates
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!   astronomical input data for the radiation package
!  </IN>
!  <IN NAME="Rad_output" TYPE="rad_output_type">
!   Radiation output from radiation package, contains variables
!                     which are output from radiation_driver to the 
!                     calling routine, and then used elsewhere within
!                     the component models.
!  </IN>
!  <IN NAME="Lw_output" TYPE="lw_output_type">
!      longwave radiation output data from the 
!                        sea_esf_rad radiation package, when that 
!                        package is active
!  </IN>
!  <IN NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output data from the 
!                        sea_esf_rad radiation package  when that 
!                        package is active
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud microphysical and physical parameters to radiation package, 
!                        when the microphysical package is active
!  </IN>
!  <IN NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale clouds,
!                        when the microphysical package is active
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! </SUBROUTINE>
!
subroutine produce_radiation_diagnostics          &
                 (is, ie, js, je, Time_diag, Time, lat, ts, Surface, &
                  flux_ratio, Astro, Rad_output, Rad_gases,&
                  Lw_output, Sw_output, Cld_spec,   &
                  Lsc_microphys, Fsrad_output, mask)

!--------------------------------------------------------------------
!    produce_radiation_diagnostics produces netcdf output and global 
!    and hemispheric integrals of radiation package variables.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
integer,                 intent(in)             :: is, ie, js, je
type(time_type),         intent(in)             :: Time_diag
type(time_type),         intent(in)             :: Time
real,dimension(:,:),     intent(in)             :: lat, ts
type(surface_type),      intent(in)             :: Surface
real,dimension(:,:),     intent(in)             :: flux_ratio
type(astronomy_type),    intent(in)             :: Astro
type(rad_output_type),   intent(in)             :: Rad_output
type(radiative_gases_type), intent(in)          :: Rad_gases
type(lw_output_type), dimension(:), intent(in), optional   :: Lw_output
type(fsrad_output_type), intent(in), optional   :: Fsrad_output
type(sw_output_type),  dimension(:),  intent(in), optional :: Sw_output
type(cld_specification_type), intent(in), optional   :: Cld_spec
type(microphysics_type), intent(in), optional   :: Lsc_microphys
real,dimension(:,:,:),   intent(in), optional   :: mask
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data 
!                   in the physics_window being integrated
!      Time_diag    time on next timestep, used as stamp for diagnostic 
!                   output  [ time_type  (days, seconds) ]  
!      lat          latitude of model points  [ radians ]
!      ts           surface temperature  [ deg K ]
!      asfc         surface albedo  [ dimensionless ]
!      flux_ratio   renormalization factor for sw fluxes and heating 
!                   rates [ dimensionless ]
!      Astro        astronomical  variables input to the radiation
!                   package [ dimensionless ]
!      Rad_output   rad_output_type variable containing radiation 
!                   output fields
!      Rad_gases    radiative_gases_type variable containing co2 mixing
!                   ratio
!
!
!    intent(in) optional variables:
!
!      Lw_output    lw_output_type variable containing output from 
!                   the longwave radiation code of the
!                   sea_esf_rad package, on the model grid
!      Sw_output    sw_output_type variable containing output from 
!                   the shortwave radiation code of the
!                   sea_esf_rad package, on the model grid
!      Cld_spec     cloud specification input data for the 
!                   radiation package
!                   [ cld_specification_type ]
!      Lsc_microphys  microphysics_type structure, contains variables
!                     describing the microphysical properties of the
!                     large-scale clouds, passed through to lower
!                     level routines
!      Fsrad_output fsrad_output_type variable containing 
!                   output from the original_fms_rad radiation
!                   package, on the model grid
!      mask         present when running eta vertical coordinate,
!                   mask to remove points below ground
!        
!----------------------------------------------------------------------

!-----------------------------------------------------------------------
!  local variables

      real, dimension (ie-is+1,je-js+1) ::           & 
                                                swin, swout, olr, &
                                                swups, swdns, lwups, &
                                                lwdns, swin_clr,   &
                                                swout_clr, olr_clr, &
                                                swups_clr, swdns_clr,&
                                                lwups_clr, lwdns_clr   

      real, dimension (ie-is+1,je-js+1, MX_SPEC_LEVS) ::           & 
                                                swdn_trop,  &
                                                swdn_trop_clr, &
                                                swup_trop, &
                                                swup_trop_clr, &
                                                netlw_trop, &
                                                netlw_trop_clr

      real, dimension (ie-is+1,je-js+1, size(Rad_output%tdtsw,3)) ::  &
                                                tdtlw, tdtlw_clr,&
                                                hsw, hswcf

      real, dimension (ie-is+1,je-js+1, size(Rad_output%tdtsw,3)+1) :: &
                                                dfsw, ufsw,  &
                                                dfswcf, ufswcf,&
                                                flxnet, flxnetcf, &
                                                fsw, fswcf
      real, dimension (ie-is+1,je-js+1) ::      &
                                         swin_ad,     swout_ad, olr_ad,&
                              swups_ad,    swdns_ad, lwups_ad,lwdns_ad,&
                                 swin_ad_clr, swout_ad_clr, olr_ad_clr,&
                  swups_ad_clr, swdns_ad_clr, lwups_ad_clr, lwdns_ad_clr
      real, dimension (ie-is+1,je-js+1, size(Rad_output%tdtsw,3)+1) :: &
                                               dfsw_ad, ufsw_ad,  &
                                               dfswcf_ad, ufswcf_ad

      integer           :: j, k
      integer           :: ipass
      logical           :: used
      integer           :: iind, jind
      integer           :: kmax
      integer           :: nz

!      asfc         surface albedo  [ dimensionless ]
!      asfc_vis_dir surface visible albedo  [ dimensionless ]
!      asfc_nir_dir surface nir albedo  [ dimensionless ]
!      asfc_vis_dif surface visible albedo  [ dimensionless ]
!      asfc_nir_dif surface nir albedo  [ dimensionless ]

!---------------------------------------------------------------------
!    if sw flux renormalization is active, modify the fluxes calculated
!    on the last radiation step by the normalization factor based on
!    the difference in solar factor between the current model step and
!    the current radiation step.
!----------------------------------------------------------------------
      nz = current_sw_zenith_step
      kmax = size (Rad_output%tdtsw,3)
      if (renormalize_sw_fluxes) then
        do k=1, kmax         
          hsw(:,:,k) = hsw_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
        end do
        do k=1, kmax+1             
          if (do_swaerosol_forcing) then
            dfsw_ad(:,:,k) =   &
                        dfsw_ad_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
            ufsw_ad(:,:,k) =   &
                        ufsw_ad_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          endif
          dfsw(:,:,k) = dfsw_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          ufsw(:,:,k) = ufsw_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          fsw(:,:,k) = fsw_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
        end do
        do k=1,Rad_control%mx_spec_levs
          swdn_trop(:,:,k) = swdn_special_save(is:ie,js:je,k,nz)*  &
                             flux_ratio(:,:)
          swup_trop(:,:,k) = swup_special_save(is:ie,js:je,k,nz)*   &
                             flux_ratio(:,:)
        end do
        if (do_clear_sky_pass) then
          do k=1, kmax            
            hswcf(:,:,k) = hswcf_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          end do
          do k=1, kmax+1            
            if (do_swaerosol_forcing) then
              dfswcf_ad(:,:,k) = dfswcf_ad_save(is:ie,js:je,k,nz)*  &
                                 flux_ratio(:,:)
              ufswcf_ad(:,:,k) = ufswcf_ad_save(is:ie,js:je,k,nz)*  &
                                 flux_ratio(:,:)
            endif
            dfswcf(:,:,k) =    &
                          dfswcf_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
            ufswcf(:,:,k) =    &
                          ufswcf_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
            fswcf(:,:,k) = fswcf_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          end do
          do k=1,Rad_control%mx_spec_levs
            swdn_trop_clr(:,:,k) =    &
                  swdn_special_clr_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
            swup_trop_clr(:,:,k) =    &
                  swup_special_clr_save(is:ie,js:je,k,nz)*flux_ratio(:,:)
          end do
        endif

!----------------------------------------------------------------------
!    if renormalization is not active and this is a radiation step
!    (i.e., diagnostics desired), define the variables to be output as
!    the values present in Sw_output.
!---------------------------------------------------------------------
      else if (do_sw_rad .and. do_sea_esf_rad) then
        do k=1, kmax            
          hsw(:,:,k) = Sw_output(1)%hsw(:,:,k,nz)
        end do
        do k=1, kmax+1             
          if (do_swaerosol_forcing) then
            dfsw_ad(:,:,k) = Sw_output(indx_swaf)%dfsw(:,:,k,nz)
            ufsw_ad(:,:,k) = Sw_output(indx_swaf)%ufsw(:,:,k,nz)
          endif
          dfsw(:,:,k) = Sw_output(1)%dfsw(:,:,k,nz)
          ufsw(:,:,k) = Sw_output(1)%ufsw(:,:,k,nz)
          fsw(:,:,k) = Sw_output(1)%fsw(:,:,k,nz)
        end do
        swdn_trop(:,:,:) = Sw_output(1)%swdn_special(:,:,:,nz)
        swup_trop(:,:,:) = Sw_output(1)%swup_special(:,:,:,nz)
        if (do_clear_sky_pass) then
          do k=1, kmax             
            hswcf(:,:,k) = Sw_output(1)%hswcf(:,:,k,nz)
          end do
          do k=1, kmax+1            
            if (do_swaerosol_forcing) then
              dfswcf_ad(:,:,k) = Sw_output(indx_swaf)%dfswcf(:,:,k,nz)
              ufswcf_ad(:,:,k) = Sw_output(indx_swaf)%ufswcf(:,:,k,nz)  
            endif
            dfswcf(:,:,k) = Sw_output(1)%dfswcf(:,:,k,nz)
            ufswcf(:,:,k) = Sw_output(1)%ufswcf(:,:,k,nz)
            fswcf(:,:,k) = Sw_output(1)%fswcf(:,:,k,nz)
          end do
          swdn_trop_clr(:,:,:) = Sw_output(1)%swdn_special_clr(:,:,:,nz)
          swup_trop_clr(:,:,:) = Sw_output(1)%swup_special_clr(:,:,:,nz)
        endif

!----------------------------------------------------------------------
!    if renormalization is not active and this is not a radiation step
!    but all_step_diagnostics is activated (i.e., diagnostics desired),
!    define the variables to be output as the values previously saved
!    in the xxx_save variables.
!---------------------------------------------------------------------
      else if (do_sea_esf_rad .and. all_step_diagnostics) then
        do k=1, kmax
          hsw(:,:,k) = hsw_save(is:ie,js:je,k,nz)
        end do
        do k=1, kmax+1
          if (do_swaerosol_forcing) then
            dfsw_ad(:,:,k) = dfsw_ad_save(is:ie,js:je,k,nz)
            ufsw_ad(:,:,k) = ufsw_ad_save(is:ie,js:je,k,nz)
          endif
          dfsw(:,:,k) = dfsw_save(is:ie,js:je,k,nz)
          ufsw(:,:,k) = ufsw_save(is:ie,js:je,k,nz)
          fsw(:,:,k) = fsw_save(is:ie,js:je,k,nz)
        end do
        swdn_trop(:,:,:) = swdn_special_save(is:ie,js:je,:,nz)
        swup_trop(:,:,:) = swup_special_save(is:ie,js:je,:,nz)
        if (do_clear_sky_pass) then
          do k=1, kmax
            hswcf(:,:,k) = hswcf_save(is:ie,js:je,k,nz)
          end do
          do k=1, kmax+1
            if (do_swaerosol_forcing) then
              dfswcf_ad(:,:,k) = dfswcf_ad_save(is:ie,js:je,k,nz)
              ufswcf_ad(:,:,k) = ufswcf_ad_save(is:ie,js:je,k,nz)
            endif
            dfswcf(:,:,k) = dfswcf_save(is:ie,js:je,k,nz)
            ufswcf(:,:,k) = ufswcf_save(is:ie,js:je,k,nz)
            fswcf(:,:,k) = fswcf_save(is:ie,js:je,k,nz)
          end do
          swdn_trop_clr(:,:,:) = swdn_special_clr_save(is:ie,js:je,:,nz)
          swup_trop_clr(:,:,:) = swup_special_clr_save(is:ie,js:je,:,nz)
        endif
      endif

!---------------------------------------------------------------------
!    define the sw diagnostic arrays.
!---------------------------------------------------------------------
      if (renormalize_sw_fluxes .or. do_sw_rad .or.    &
           use_hires_coszen .or.   all_step_diagnostics) then
        if (do_sea_esf_rad) then
          if (do_swaerosol_forcing) then
            swin_ad (:,:) = dfsw_ad(:,:,1)
            swout_ad(:,:) = ufsw_ad(:,:,1)
            swups_ad(:,:) = ufsw_ad(:,:,kmax+1)
            swdns_ad(:,:) = dfsw_ad(:,:,kmax+1)
          endif
          swin (:,:) = dfsw(:,:,1)
          swout(:,:) = ufsw(:,:,1)
          swups(:,:) = ufsw(:,:,kmax+1)
          swdns(:,:) = dfsw(:,:,kmax+1)
          if (do_clear_sky_pass) then
            if (do_swaerosol_forcing) then
              swin_ad_clr (:,:) = dfswcf_ad(:,:,1)
              swout_ad_clr(:,:) = ufswcf_ad(:,:,1)
              swups_ad_clr(:,:) = ufswcf_ad(:,:,kmax+1)
              swdns_ad_clr(:,:) = dfswcf_ad(:,:,kmax+1)
            endif
            swin_clr (:,:) = dfswcf(:,:,1)
            swout_clr(:,:) = ufswcf(:,:,1)
            swups_clr(:,:) = ufswcf(:,:,kmax+1)
            swdns_clr(:,:) = dfswcf(:,:,kmax+1)
          endif
        else   ! original fms rad
          swin (:,:) = Fsrad_output%swin(:,:)               
          swout(:,:) = Fsrad_output%swout(:,:)         
          swups(:,:) = Fsrad_output%swups(:,:)
          swdns(:,:) = Fsrad_output%swdns(:,:)
          if (do_clear_sky_pass) then
            swin_clr (:,:) = Fsrad_output%swin_clr(:,:)               
            swout_clr(:,:) = Fsrad_output%swout_clr(:,:)         
            swups_clr(:,:) = Fsrad_output%swups_clr(:,:)
            swdns_clr(:,:) = Fsrad_output%swdns_clr(:,:)
          endif
        endif  ! do_sea_esf_rad

        if (id_alb_sfc_avg > 0) then
          swups_acc(is:ie,js:je) = swups_acc(is:ie, js:je) + swups(:,:)
          swdns_acc(is:ie,js:je) = swdns_acc(is:ie, js:je) + swdns(:,:)
        endif
 
!---------------------------------------------------------------------
!   send standard sw diagnostics to diag_manager.
!---------------------------------------------------------------------
      if (Time_diag > Time) then
        if (do_clear_sky_pass) then
          ipass = 2
        else
          ipass = 1
        endif

!------- sw tendency -----------
        if (id_tdt_sw(ipass) > 0 ) then
          used = send_data (id_tdt_sw(ipass),    &
                            Rad_output%tdtsw(is:ie,js:je,:,nz),   &
                            Time_diag, is, js, 1, rmask=mask )
        endif

!---- 3d upward sw flux ---------
        if (id_ufsw(ipass) > 0 ) then
          used = send_data (id_ufsw(ipass),    &
                            Rad_output%ufsw(is:ie,js:je,:,nz),   &
                            Time_diag, is, js, 1, rmask=mask )
        endif

!---- 3d downward sw flux ---------
        if (id_dfsw(ipass) > 0 ) then
          used = send_data (id_dfsw(ipass),    &
                            Rad_output%dfsw(is:ie,js:je,:,nz),   &
                            Time_diag, is, js, 1, rmask=mask )
        endif


!------- incoming sw flux toa -------
        if (id_swdn_toa(ipass) > 0 ) then
          used = send_data (id_swdn_toa(ipass), swin,   &
                            Time_diag, is, js )
        endif

!------- outgoing sw flux toa -------
        if (id_swup_toa(ipass) > 0 ) then
          used = send_data (id_swup_toa(ipass), swout,    &
                            Time_diag, is, js )
        endif

!------- incoming sw flux trop -------
        if (id_swdn_special(1,ipass) > 0 ) then
          used = send_data (id_swdn_special(1,ipass),   &
                            swdn_trop(:,:,1), &
                            Time_diag, is, js )
        endif
!------- incoming sw flux trop -------
        if (id_swdn_special(2,ipass) > 0 ) then
          used = send_data (id_swdn_special(2,ipass),   &
                            swdn_trop(:,:,2), &
                            Time_diag, is, js )
        endif
!------- incoming sw flux trop -------
        if (id_swdn_special(3, ipass) > 0 ) then
          used = send_data (id_swdn_special(3,ipass),   &
                            swdn_trop(:,:,3), &
                            Time_diag, is, js )
        endif

!------- net sw downward flux at model dynamics top (1 Pa) ----
        if (id_swdn_special(4, ipass) > 0 ) then
          used = send_data (id_swdn_special(4,ipass),   &
                            swdn_trop(:,:,4), &
                            Time_diag, is, js )
        endif


!------- outgoing sw flux trop -------
        if (id_swup_special(1,ipass) > 0 ) then
          used = send_data (id_swup_special(1,ipass),   &
                            swup_trop(:,:,1), &
                            Time_diag, is, js )
        endif
!------- outgoing sw flux trop -------
        if (id_swup_special(2,ipass) > 0 ) then
          used = send_data (id_swup_special(2,ipass),   &
                            swup_trop(:,:,2), &
                            Time_diag, is, js )
        endif
!------- outgoing sw flux trop -------
        if (id_swup_special(3,ipass) > 0 ) then
          used = send_data (id_swup_special(3,ipass),   &
                            swup_trop(:,:,3), &
                            Time_diag, is, js )
        endif
 
!------- net sw upward flux at model dynamics top (1 Pa) ----
        if (id_swdn_special(4, ipass) > 0 ) then
          used = send_data (id_swup_special(4,ipass),   &
                            swup_trop(:,:,4), &
                            Time_diag, is, js )
        endif

!------- upward sw flux surface -------
        if (id_swup_sfc(ipass) > 0 ) then
          used = send_data (id_swup_sfc(ipass), swups,    &
                            Time_diag, is, js )
        endif

!------- downward sw flux surface -------
        if (id_swdn_sfc(ipass) > 0 ) then
          used = send_data (id_swdn_sfc(ipass), swdns,   &
                            Time_diag, is, js )
        endif
        
!------- net sw flux at toa -------
       if (id_swtoa(ipass) > 0 ) then
          used = send_data (id_swtoa(ipass), swin-swout,   &
                             Time_diag, is, js )
         endif

!------- net sw flux at surface -------
         if (id_swsfc(ipass) > 0 ) then
           used = send_data (id_swsfc(ipass), swdns-swups,   &
                             Time_diag, is, js )
         endif

      if (do_swaerosol_forcing) then

!------- net sw flux at toa -------
         if (id_swtoa_ad(ipass) > 0 ) then
           used = send_data (id_swtoa_ad(ipass), swin_ad-swout_ad,   &
                             Time_diag, is, js )
        endif
 
!------- net sw flux at surface -------
         if (id_swsfc_ad(ipass) > 0 ) then
           used = send_data (id_swsfc_ad(ipass), swdns_ad-swups_ad,   &
                           Time_diag, is, js )
         endif
 
!------- sw flux down at surface -------
         if (id_swdn_sfc_ad(ipass) > 0 ) then
           used = send_data (id_swdn_sfc_ad(ipass), swdns_ad,   &
                             Time_diag, is, js )
         endif

!------- sw flux up at surface -------
         if (id_swup_sfc_ad(ipass) > 0 ) then
           used = send_data (id_swup_sfc_ad(ipass), swups_ad,   &
                            Time_diag, is, js )
         endif

!------- outgoing sw flux toa -------
         if (id_swup_toa_ad(ipass) > 0 ) then
           used = send_data (id_swup_toa_ad(ipass), swout_ad,    &
                            Time_diag, is, js )
        endif
     endif

!----------------------------------------------------------------------
!    now pass clear-sky diagnostics, if they have been calculated.
!----------------------------------------------------------------------
        if (do_clear_sky_pass) then
          ipass = 1

!------- sw tendency -----------
          if (id_tdt_sw(ipass) > 0 ) then
            used = send_data (id_tdt_sw(ipass),   &
                              Rad_output%tdtsw_clr(is:ie,js:je,:,nz),  &
                              Time_diag, is, js, 1, rmask=mask )
          endif

!---- 3d upward sw flux ---------
         if (id_ufsw(ipass) > 0 ) then
           used = send_data (id_ufsw(ipass),    &
                             Rad_output%ufsw_clr(is:ie,js:je,:,nz),   &
                             Time_diag, is, js, 1, rmask=mask )
         endif
 
!---- 3d downward sw flux ---------
         if (id_dfsw(ipass) > 0 ) then
           used = send_data (id_dfsw(ipass),    &
                             Rad_output%dfsw_clr(is:ie,js:je,:,nz),   &
                             Time_diag, is, js, 1, rmask=mask )
         endif

!------- incoming sw flux toa -------
          if (id_swdn_toa(ipass) > 0 ) then
            used = send_data (id_swdn_toa(ipass), swin_clr,    &
                              Time_diag, is, js )
          endif

!------- outgoing sw flux toa -------
          if (id_swup_toa(ipass) > 0 ) then
            used = send_data (id_swup_toa(ipass), swout_clr,  &
                              Time_diag, is, js )
          endif

!------- incoming sw flux trop -------
          if (id_swdn_special(1,ipass) > 0 ) then
            used = send_data (id_swdn_special(1, ipass),    &
                              swdn_trop_clr(:,:,1), &
                              Time_diag, is, js )
          endif
!------- incoming sw flux trop -------
          if (id_swdn_special(2,ipass) > 0 ) then
            used = send_data (id_swdn_special(2, ipass),    &
                              swdn_trop_clr(:,:,2), &
                              Time_diag, is, js )
          endif
!------- incoming sw flux trop -------
          if (id_swdn_special(3,ipass) > 0 ) then
            used = send_data (id_swdn_special(3, ipass),    &
                              swdn_trop_clr(:,:,3), &
                              Time_diag, is, js )
          endif

!------- outgoing sw flux trop -------
          if (id_swup_special(1,ipass) > 0 ) then
            used = send_data (id_swup_special(1,ipass),   &
                              swup_trop_clr(:,:,1),  &
                              Time_diag, is, js )
          endif
!------- outgoing sw flux trop -------
          if (id_swup_special(2,ipass) > 0 ) then
            used = send_data (id_swup_special(2,ipass),   &
                              swup_trop_clr(:,:,2),  &
                              Time_diag, is, js )
          endif
!------- outgoing sw flux trop -------
          if (id_swup_special(3,ipass) > 0 ) then
            used = send_data (id_swup_special(3,ipass),   &
                              swup_trop_clr(:,:,3),  &
                              Time_diag, is, js )
          endif

!------- upward sw flux surface -------
          if (id_swup_sfc(ipass) > 0 ) then
            used = send_data (id_swup_sfc(ipass), swups_clr,   &
                              Time_diag, is, js )
          endif

!------- downward sw flux surface -------
          if (id_swdn_sfc(ipass) > 0 ) then
            used = send_data (id_swdn_sfc(ipass), swdns_clr,    &
                              Time_diag, is, js )
          endif

!------- net sw flux at toa -------
        if (id_swtoa(ipass) > 0 ) then
           used = send_data (id_swtoa(ipass), swin_clr-swout_clr,   &
                             Time_diag, is, js )
         endif
 
!------- net sw flux at surface -------
         if (id_swsfc(ipass) > 0 ) then
           used = send_data (id_swsfc(ipass), swdns_clr-swups_clr,   &
                            Time_diag, is, js )
         endif
     if (do_swaerosol_forcing) then

!------- net sw flux at toa -------
        if (id_swtoa_ad(ipass) > 0 ) then
          used = send_data (id_swtoa_ad(ipass), swin_ad_clr-swout_ad_clr,   &
                            Time_diag, is, js )
        endif
 
!------- net sw flux at surface -------
         if (id_swsfc_ad(ipass) > 0 ) then
           used = send_data (id_swsfc_ad(ipass), swdns_ad_clr-swups_ad_clr,   &
                             Time_diag, is, js )
         endif
 
!------- sw flux down at surface -------
         if (id_swdn_sfc_ad(ipass) > 0 ) then
           used = send_data (id_swdn_sfc_ad(ipass), swdns_ad_clr,   &
                             Time_diag, is, js )
        endif
 
!------- sw flux up at surface -------
        if (id_swup_sfc_ad(ipass) > 0 ) then
          used = send_data (id_swup_sfc_ad(ipass), swups_ad_clr,   &
                            Time_diag, is, js )
        endif
 
!------- outgoing sw flux toa -------
        if (id_swup_toa_ad(ipass) > 0 ) then
           used = send_data (id_swup_toa_ad(ipass), swout_ad_clr,    &
                            Time_diag, is, js )
        endif

     endif
         endif  ! (do_clear_sky_pass)

!-----------------------------------------------------------------------
!    send cloud-forcing-independent diagnostics to diagnostics manager.
!-----------------------------------------------------------------------

!---- 3d total radiative heating ---------
        if (id_allradp > 0 ) then
          used = send_data (id_allradp    ,    &
                            Rad_output%tdt_rad(is:ie,js:je,:,nz),   &
                            Time_diag, is, js, 1, rmask=mask )
        endif

!------- conc_drop  -------------------------
          if (do_rad) then
            if ( id_conc_drop > 0 ) then
              used = send_data (id_conc_drop, Lsc_microphys%conc_drop, &
                                Time_diag, is, js, 1, rmask=mask )
            endif
          endif
  
!------- conc_ice  -------------------------
          if (do_rad) then
            if (id_conc_ice > 0 ) then
              used = send_data (id_conc_ice, Lsc_microphys%conc_ice, &
                                Time_diag, is, js, 1, rmask=mask )
            endif
          endif

!------- solar constant  -------------------------
        if (do_rad) then
          if ( id_sol_con > 0 ) then
            used = send_data ( id_sol_con, Sw_control%solar_constant,  &
                               Time_diag )
          endif
        endif

!------- co2 mixing ratio used for tf calculation  -------------------
        if (do_rad) then
          if ( id_co2_tf > 0 ) then
            used = send_data ( id_co2_tf,   &
                               1.0E6*Rad_gases%co2_for_last_tf_calc,  &
                               Time_diag )
          endif
        endif
 
!------- ch4 mixing ratio used for tf calculation   ---------------
        if (do_rad) then
          if ( id_ch4_tf > 0 ) then
            used = send_data ( id_ch4_tf,  &
                               1.0E9*Rad_gases%ch4_for_last_tf_calc,  &
                               Time_diag )
          endif
        endif
 
!------- n2o mixing ratio used for tf calculation  ---------------
        if (do_rad) then
          if ( id_n2o_tf > 0 ) then
            used = send_data ( id_n2o_tf,   &
                               1.0E9*Rad_gases%n2o_for_last_tf_calc,  &
                               Time_diag )
          endif
        endif
 
!------- co2 mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvco2 > 0 ) then
            used = send_data ( id_rrvco2, 1.0E6*Rad_gases%rrvco2,  &
                               Time_diag )
          endif
        endif
 
!------- f11 mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvf11 > 0 ) then
            used = send_data ( id_rrvf11, 1.0E12*Rad_gases%rrvf11,  &
                               Time_diag )
          endif
        endif
 
!------- f12 mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvf12 > 0 ) then
            used = send_data ( id_rrvf12, 1.0E12*Rad_gases%rrvf12,  &
                               Time_diag )
          endif
        endif
 
!------- f113 mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvf113 > 0 ) then
            used = send_data ( id_rrvf113, 1.0E12*Rad_gases%rrvf113,  &
                               Time_diag )
          endif
        endif

!------- f22 mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvf22 > 0 ) then
            used = send_data ( id_rrvf22, 1.0E12*Rad_gases%rrvf22,  &
                               Time_diag )
          endif
        endif

!------- ch4 mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvch4 > 0 ) then
            used = send_data ( id_rrvch4, 1.0E9*Rad_gases%rrvch4,  &
                               Time_diag )
          endif
        endif

!------- n2o mixing ratio  -------------------------
        if (do_rad) then
          if ( id_rrvn2o > 0 ) then
            used = send_data ( id_rrvn2o, 1.0E9*Rad_gases%rrvn2o,  &
                               Time_diag )
          endif
        endif

!------- surface albedo  -------------------------
        if ( id_alb_sfc_avg > 0 ) then
!         used = send_data ( id_alb_sfc, 100.*Surface%asfc, &
          used = send_data ( id_alb_sfc_avg,  &
                  100.*swups_acc(is:ie,js:je)/swdns_acc(is:ie,js:je), &
                     Time_diag, is, js )
        endif
        if ( id_alb_sfc > 0 ) then
!         used = send_data ( id_alb_sfc, 100.*Surface%asfc, &
          used = send_data ( id_alb_sfc, 100.*swups/(1.0e-35 + swdns), &
                     Time_diag, is, js )
        endif

!------- surface visible albedo  -------------------------
        if ( id_alb_sfc_vis_dir > 0 ) then
          used = send_data ( id_alb_sfc_vis_dir, &
                         100.*Surface%asfc_vis_dir, Time_diag, is, js )
        endif
        if ( id_alb_sfc_vis_dif > 0 ) then
          used = send_data ( id_alb_sfc_vis_dif, &
                         100.*Surface%asfc_vis_dif, Time_diag, is, js )
        endif
 
!------- surface nir albedo  -------------------------
        if ( id_alb_sfc_nir_dir > 0 ) then
          used = send_data ( id_alb_sfc_nir_dir, &
                         100.*Surface%asfc_nir_dir, Time_diag, is, js )
        endif
        if ( id_alb_sfc_nir_dif > 0 ) then
           used = send_data ( id_alb_sfc_nir_dif, &
                         100.*Surface%asfc_nir_dif, Time_diag, is, js )
        endif
 
!------- surface net sw flux, direct and diffuse  --------------------
        if ( id_flux_sw_dir > 0 ) then
         used = send_data ( id_flux_sw_dir, &
          Rad_output%flux_sw_surf_dir( is:ie,js:je,nz), Time_diag,  &
                                                              is, js )
        endif
        if ( id_flux_sw_dif > 0 ) then
          used = send_data ( id_flux_sw_dif, &
           Rad_output%flux_sw_surf_dif(is:ie,js:je,nz), Time_diag, &
                                                              is, js )
        endif

!------- surface downward visible sw flux, direct and diffuse ----------
        if ( id_flux_sw_down_vis_dir > 0 ) then
          used = send_data ( id_flux_sw_down_vis_dir, &
                     Rad_output%flux_sw_down_vis_dir(is:ie,js:je,nz), &
                     Time_diag, is, js )
        endif
        if ( id_flux_sw_down_vis_dif > 0 ) then
          used = send_data ( id_flux_sw_down_vis_dif, &
                     Rad_output%flux_sw_down_vis_dif(is:ie, js:je,nz), &
                     Time_diag, is, js )
        endif
 
!------- surface downward total sw flux, direct and diffuse  ----------
        if ( id_flux_sw_down_total_dir > 0 ) then
          used = send_data ( id_flux_sw_down_total_dir,  &
                     Rad_output%flux_sw_down_total_dir(is:ie,js:je,nz),  &
                     Time_diag, is, js )
        endif
        if ( id_flux_sw_down_total_dif > 0 ) then
         used = send_data ( id_flux_sw_down_total_dif,  &
                    Rad_output%flux_sw_down_total_dif(is:ie,js:je,nz),  &
                    Time_diag, is, js )
        endif

      if (do_clear_sky_pass) then
 
!------- surface downward total sw flux, direct and diffuse  ----------
        if ( id_flux_sw_down_total_dir_clr > 0 ) then
          used = send_data ( id_flux_sw_down_total_dir_clr,  &
                 Rad_output%flux_sw_down_total_dir_clr(is:ie,js:je,nz),&
                 Time_diag, is, js )
        endif
        if ( id_flux_sw_down_total_dif_clr > 0 ) then
          used = send_data ( id_flux_sw_down_total_dif_clr,  &
                  Rad_output%flux_sw_down_total_dif_clr(is:ie,js:je,nz),  &
                  Time_diag, is, js )
        endif
        if ( id_flux_sw_down_vis_clr > 0 ) then
          used = send_data ( id_flux_sw_down_vis_clr, &
                     Rad_output%flux_sw_down_vis_clr(is:ie, js:je,nz), &
                     Time_diag, is, js )
        endif
      endif
 
!------- surface net visible sw flux, total, direct and diffuse -------
        if ( id_flux_sw_vis > 0 ) then
          used = send_data ( id_flux_sw_vis,   &
                Rad_output%flux_sw_vis(is:ie,js:je,nz), Time_diag, is, js )
        endif
        if ( id_flux_sw_vis_dir > 0 ) then
          used = send_data ( id_flux_sw_vis_dir,   &
            Rad_output%flux_sw_vis_dir(is:ie,js:je,nz), Time_diag, is, js )
        endif
        if ( id_flux_sw_vis_dif > 0 ) then
          used = send_data ( id_flux_sw_vis_dif,  &
            Rad_output%flux_sw_vis_dif(is:ie,js:je,nz), Time_diag, is, js )
        endif

!------- cosine of zenith angle ----------------
        if ( id_cosz > 0 ) then
          used = send_data ( id_cosz, Astro%cosz, Time_diag, is, js )
        endif

!------- daylight fraction  --------------
        if ( id_fracday > 0 ) then
          used = send_data (id_fracday, Astro%fracday, Time_diag,   &
                            is, js )
        end if
      endif
      endif   ! (renormalize_sw_fluxes .or. do_rad .or.   
              !  all_step_diagnostics)

!---------------------------------------------------------------------
!    define the longwave diagnostic arrays for the sea-esf radiation 
!    package.  convert to mks units.
!---------------------------------------------------------------------
      if (do_sea_esf_rad) then
!       if (do_rad) then
        if (do_lw_rad) then
          olr  (:,:)   = Lw_output(1)%flxnet(:,:,1)
          lwups(:,:)   =   STEFAN*ts(:,:  )**4
          lwdns(:,:)   = lwups(:,:) - Lw_output(1)%flxnet(:,:,kmax+1)
          tdtlw(:,:,:) = Lw_output(1)%heatra(:,:,:)/ SECONDS_PER_DAY
          netlw_trop(:,:,:) = Lw_output(1)%netlw_special(:,:,:)
          flxnet(:,:,:) = Lw_output(1)%flxnet(:,:,:)
          if (do_lwaerosol_forcing) then
            olr_ad  (:,:)   = Lw_output(indx_lwaf)%flxnet(:,:,1)
            lwups_ad(:,:)   = STEFAN*ts(:,:  )**4
            lwdns_ad(:,:)   = lwups_ad(:,:) -    &
                                  Lw_output(indx_lwaf)%flxnet(:,:,kmax+1)
          endif

          if (do_clear_sky_pass) then
            olr_clr  (:,:)   = Lw_output(1)%flxnetcf(:,:,1)
            lwups_clr(:,:)   =              STEFAN*ts(:,:  )**4
            lwdns_clr(:,:)   = lwups_clr(:,:) -    & 
                               Lw_output(1)%flxnetcf(:,:,kmax+1)
            tdtlw_clr(:,:,:) = Lw_output(1)%heatracf(:,:,:)/SECONDS_PER_DAY
            netlw_trop_clr(:,:,:) = Lw_output(1)%netlw_special_clr(:,:,:)
            flxnetcf(:,:,:) = Lw_output(1)%flxnetcf(:,:,:)
            if (do_lwaerosol_forcing) then
              olr_ad_clr  (:,:)   = Lw_output(indx_lwaf)%flxnetcf(:,:,1)
              lwups_ad_clr(:,:)   = STEFAN*ts(:,:  )**4
              lwdns_ad_clr(:,:)   = lwups_ad_clr(:,:) -    &
                               Lw_output(indx_lwaf)%flxnetcf(:,:,kmax+1)
            endif
          endif

!---------------------------------------------------------------------
!    if diagnostics are desired on all physics steps, save the arrays 
!    for later use.
!---------------------------------------------------------------------
          if (all_step_diagnostics) then
            if (do_lwaerosol_forcing) then
              olr_ad_save  (is:ie,js:je)   = olr_ad(:,:)
              lwups_ad_save(is:ie,js:je)   = lwups_ad(:,:)
              lwdns_ad_save(is:ie,js:je)   = lwdns_ad(:,:)
            endif
            olr_save  (is:ie,js:je)   = olr(:,:)
            lwups_save(is:ie,js:je)   = lwups(:,:)
            lwdns_save(is:ie,js:je)   = lwdns(:,:)
            tdtlw_save(is:ie,js:je,:) = tdtlw(:,:,:)
            flxnet_save(is:ie,js:je,:) = Lw_output(1)%flxnet(:,:,:)
            netlw_special_save(is:ie,js:je,:) = netlw_trop(:,:,:)

            if (do_clear_sky_pass) then
              if (do_lwaerosol_forcing) then 
                olr_ad_clr_save  (is:ie,js:je)   = olr_ad_clr(:,:)
                lwups_ad_clr_save(is:ie,js:je)   = lwups_ad_clr(:,:)
                lwdns_ad_clr_save(is:ie,js:je)   = lwdns_ad_clr(:,:)
              endif
              olr_clr_save  (is:ie,js:je)   = olr_clr(:,:)
              flxnetcf_save(is:ie,js:je,:) = Lw_output(1)%flxnetcf(:,:,:)
              lwups_clr_save(is:ie,js:je)   = lwups_clr(:,:)
              lwdns_clr_save(is:ie,js:je)   = lwdns_clr(:,:)
              tdtlw_clr_save(is:ie,js:je,:) = tdtlw_clr(:,:,:)
              netlw_special_clr_save(is:ie,js:je,:) =   &
                                         netlw_trop_clr(:,:,:)
            endif
           endif

!---------------------------------------------------------------------
!    if this is not a radiation step, but diagnostics are desired,
!    define the fields from the xxx_save variables.
!---------------------------------------------------------------------
!        else if (all_step_diagnostics) then  ! (do_rad)
         else if (all_step_diagnostics) then  ! (do_lw_rad)
           if (do_lwaerosol_forcing) then 
             olr_ad(:,:)     = olr_ad_save  (is:ie,js:je)
             lwups_ad(:,:)   = lwups_ad_save(is:ie,js:je)
             lwdns_ad(:,:)   = lwdns_ad_save(is:ie,js:je) 
           endif
           olr(:,:)     = olr_save  (is:ie,js:je)
           lwups(:,:)   = lwups_save(is:ie,js:je)
           lwdns(:,:)   = lwdns_save(is:ie,js:je)
           tdtlw(:,:,:) = tdtlw_save(is:ie,js:je,:)
           flxnet(:,:,:) = flxnet_save(is:ie,js:je,:)
           netlw_trop(:,:,:) = netlw_special_save(is:ie,js:je,:)

           if (do_clear_sky_pass) then
             if (do_lwaerosol_forcing) then
               olr_ad_clr(:,:)     = olr_ad_clr_save  (is:ie,js:je)
               lwups_ad_clr(:,:)   = lwups_ad_clr_save(is:ie,js:je)
               lwdns_ad_clr(:,:)   = lwdns_ad_clr_save(is:ie,js:je)
             endif
             olr_clr(:,:)     = olr_clr_save  (is:ie,js:je)
             lwups_clr(:,:)   = lwups_clr_save(is:ie,js:je)
             lwdns_clr(:,:)   = lwdns_clr_save(is:ie,js:je)
             tdtlw_clr(:,:,:) = tdtlw_clr_save(is:ie,js:je,:)
             flxnetcf (:,:,:) = flxnetcf_save(is:ie,js:je,:)
             netlw_trop_clr(:,:,:) =   &
                               netlw_special_clr_save(is:ie,js:je,:)
           endif
         endif

!---------------------------------------------------------------------
!    on radiation steps, define the longwave diagnostic arrays for the
!    original_fms_rad package.        
!---------------------------------------------------------------------
      else   ! original fms rad
        if (do_lw_rad) then
          olr  (:,:)   = Fsrad_output%olr(:,:)
          lwups(:,:)   = Fsrad_output%lwups(:,:)
          lwdns(:,:)   = Fsrad_output%lwdns(:,:)
          tdtlw(:,:,:) = Fsrad_output%tdtlw(:,:,:)

          if (do_clear_sky_pass) then
            olr_clr  (:,:)   = Fsrad_output%olr_clr(:,:)
            lwups_clr(:,:)   = Fsrad_output%lwups_clr(:,:)
            lwdns_clr(:,:)   = Fsrad_output%lwdns_clr(:,:)
            tdtlw_clr(:,:,:) = Fsrad_output%tdtlw_clr(:,:,:)
          endif
        endif
      endif  ! do_sea_esf_rad

      if (do_lw_rad .or. all_step_diagnostics) then
      if (Time_diag > Time) then
!---------------------------------------------------------------------
!   send standard lw diagnostics to diag_manager.
!---------------------------------------------------------------------
        if (do_clear_sky_pass) then
          ipass = 2
        else
          ipass = 1
        endif

!---- net lw flux ---------
        if (id_flxnet(ipass) > 0 ) then
          used = send_data (id_flxnet(ipass),    &
                           flxnet,   &
                           Time_diag, is, js, 1, rmask=mask )
        endif

!------- lw tendency -----------
        if (id_tdt_lw(ipass) > 0 ) then
          used = send_data (id_tdt_lw(ipass), tdtlw,    &
                            Time_diag, is, js, 1, rmask=mask )
        endif

!------- outgoing lw flux toa (olr) -------
        if (id_olr(ipass) > 0 ) then
          used = send_data (id_olr(ipass), olr,    &
                            Time_diag, is, js )
        endif

!------- net radiation (lw + sw) at toa -------
        if (id_netrad_toa(ipass) > 0 ) then
          used = send_data (id_netrad_toa(ipass),   &
                            swin - swout - olr, &
                            Time_diag, is, js )
        endif

!------- net radiation (lw + sw) at 1 Pa-------
        if (id_netrad_1_Pa(ipass) > 0 ) then
          used = send_data (id_netrad_1_Pa(ipass),   &
               swdn_trop(:,:,4) -swup_trop(:,:,4) -netlw_trop(:,:,4), &
                             Time_diag, is, js )
        endif

!------- net lw flux trop (netlw_trop) -------
        if (id_netlw_special(1,ipass) > 0 ) then
          used = send_data (id_netlw_special(1, ipass),   &
                            netlw_trop(:,:,1),  &
                            Time_diag, is, js )
        endif
!------- net lw flux trop (netlw_trop) -------
        if (id_netlw_special(2,ipass) > 0 ) then
          used = send_data (id_netlw_special(2, ipass),   &
                            netlw_trop(:,:,2),  &
                            Time_diag, is, js )
        endif
!------- net lw flux trop (netlw_trop) -------
        if (id_netlw_special(3,ipass) > 0 ) then
          used = send_data (id_netlw_special(3, ipass),   &
                            netlw_trop(:,:,3),  &
                            Time_diag, is, js )
        endif
!------- net lw flux 1 Pa (netlw_trop) -------
        if (id_netlw_special(4,ipass) > 0 ) then
          used = send_data (id_netlw_special(4, ipass),   &
                            netlw_trop(:,:,4),  &
                            Time_diag, is, js )
        endif

!------- upward lw flux surface -------
        if ( id_lwup_sfc(ipass) > 0 ) then
          used = send_data (id_lwup_sfc(ipass), lwups,    &
                            Time_diag, is, js )
        endif

!------- downward lw flux surface -------
        if (id_lwdn_sfc(ipass) > 0 ) then
          used = send_data (id_lwdn_sfc(ipass), lwdns,    &
                            Time_diag, is, js )
        endif

!------- net lw flux surface -------
         if ( id_lwsfc(ipass) > 0 ) then
           used = send_data (id_lwsfc(ipass), lwups-lwdns,    &
                             Time_diag, is, js )
         endif
 
     if (do_lwaerosol_forcing) then

!------- outgoing lw flux toa (olr) with aerosols-------
        if (id_olr_ad(ipass) > 0 ) then
          used = send_data (id_olr_ad(ipass), olr_ad,    &
                             Time_diag, is, js )
        endif

!------- net lw flux surface -------
        if ( id_lwsfc_ad(ipass) > 0 ) then
           used = send_data (id_lwsfc_ad(ipass), lwups_ad-lwdns_ad,    &
                             Time_diag, is, js )
        endif
     endif

!----------------------------------------------------------------------
!    now pass clear-sky diagnostics, if they have been calculated.
!----------------------------------------------------------------------
        if (do_clear_sky_pass) then
          ipass = 1

!---- net lw flux ---------
        if (id_flxnet(ipass) > 0 ) then
          used = send_data (id_flxnet(ipass),    &
                            flxnetcf,   &
                            Time_diag, is, js, 1, rmask=mask )
        endif

!------- lw tendency -----------
          if (id_tdt_lw(ipass) > 0 ) then
            used = send_data (id_tdt_lw(ipass), tdtlw_clr,    &
                              Time_diag, is, js, 1, rmask=mask )
          endif

!------- outgoing lw flux toa (olr) -------
          if (id_olr(ipass) > 0 ) then
            used = send_data (id_olr(ipass), olr_clr,   &
                              Time_diag, is, js )
          endif

!------- net radiation (lw + sw) toa -------
          if (id_netrad_toa(ipass) > 0 ) then
            used = send_data (id_netrad_toa(ipass),   &
                              swin_clr - swout_clr - olr_clr,   &
                              Time_diag, is, js )
          endif

!------- net lw flux trop (netlw_trop) -------
          if (id_netlw_special(1,ipass) > 0 ) then
            used = send_data (id_netlw_special(1, ipass),    &
                              netlw_trop_clr(:,:,1),    &
                              Time_diag, is, js )
          endif

!------- net lw flux trop (netlw_trop) -------
          if (id_netlw_special(2,ipass) > 0 ) then
            used = send_data (id_netlw_special(2, ipass),    &
                              netlw_trop_clr(:,:,2),    &
                              Time_diag, is, js )
          endif
!------- net lw flux trop (netlw_trop) -------
          if (id_netlw_special(3,ipass) > 0 ) then
            used = send_data (id_netlw_special(3, ipass),    &
                              netlw_trop_clr(:,:,3),    &
                              Time_diag, is, js )
          endif

!------- upward lw flux surface -------
          if (id_lwup_sfc(ipass) > 0 ) then
            used = send_data (id_lwup_sfc(ipass), lwups_clr,   &
                              Time_diag, is, js )
          endif

!------- downward lw flux surface -------
          if (id_lwdn_sfc(ipass) > 0 ) then
            used = send_data (id_lwdn_sfc(ipass), lwdns_clr,   &
                              Time_diag, is, js )
          endif

!------- net lw flux surface -------
         if ( id_lwsfc(ipass) > 0 ) then
           used = send_data (id_lwsfc(ipass), lwups_clr-lwdns_clr,    &
                             Time_diag, is, js )
        endif   
   
     if (do_lwaerosol_forcing) then

!------- outgoing lw flux toa (olr) with aerosols-------
         if (id_olr_ad(ipass) > 0 ) then
          used = send_data (id_olr_ad(ipass), olr_ad_clr,    &
                            Time_diag, is, js )
         endif   
   
!------- net lw flux surface -------
         if ( id_lwsfc_ad(ipass) > 0 ) then
           used = send_data (id_lwsfc_ad(ipass), lwups_ad_clr-lwdns_ad_clr,    &
                           Time_diag, is, js )
        endif
      endif

        endif  ! (do_clear_sky_pass)
        endif
      endif  ! (do_lw_rad .or. all_step_diagnostics)

!--------------------------------------------------------------------
!    now define various diagnostic integrals.
!--------------------------------------------------------------------
!--------------------------------------------------------------------
!    accumulate global integral quantities 
!--------------------------------------------------------------------
        olr_intgl(is:ie,js:je) = olr(:,:)
        swabs_intgl(is:ie,js:je) = swin(:,:) - swout(:,:)
!       call sum_diag_integral_field ('olr_clr',    olr_clr, is, js)
!       call sum_diag_integral_field ('abs_sw_clr',    &
!                                           swin_clr-swout_clr, is, js)

!--------------------------------------------------------------------
!    accumulate hemispheric integral quantities, if desired. 
!--------------------------------------------------------------------
        if (calc_hemi_integrals) then
          do j=js,je        
            jind = j - js + 1
            iind = 1  ! are assuming all i points are at same latitude

!---------------------------------------------------------------------
!    calculate southern hemisphere integrals.
!---------------------------------------------------------------------
            if (lat(iind,jind) <= 0.0) then
              call sum_diag_integral_field ('sntop_tot_sh ',   &
                                            swin-swout, is, ie, j, j)
              call sum_diag_integral_field ('lwtop_tot_sh ', olr,     &
                                            is, ie, j, j)
              call sum_diag_integral_field ('sngrd_tot_sh ',   &
                                            swdns-swups, is, ie, j, j)
               call sum_diag_integral_field ('lwgrd_tot_sh ',   &
                                          Lw_output(1)%flxnet(:,:,kmax+1),&
                                          is, ie,  j, j)
              if (do_clear_sky_pass) then
                call sum_diag_integral_field ('sntop_clr_sh ',   &
                                              swin_clr-swout_clr, &
                                              is, ie, j, j)
                call sum_diag_integral_field ('lwtop_clr_sh ', olr_clr,&
                                              is, ie, j, j)
                call sum_diag_integral_field ('sngrd_clr_sh ',   &
                                              swdns_clr-swups_clr, &
                                              is, ie, j, j)
                call sum_diag_integral_field ('lwgrd_clr_sh ',    &
                                       Lw_output(1)%flxnetcf(:,:,kmax+1),&
                                       is, ie, j, j)
              endif

!---------------------------------------------------------------------
!    calculate northern hemisphere integrals.
!---------------------------------------------------------------------
            else
              call sum_diag_integral_field ('sntop_tot_nh ',    &
                                            swin-swout, is, ie, j, j)
              call sum_diag_integral_field ('lwtop_tot_nh ', olr,     &
                                            is, ie, j, j)
              call sum_diag_integral_field ('sngrd_tot_nh ',   &
                                            swdns-swups, is, ie, j, j)
              call sum_diag_integral_field ('lwgrd_tot_nh ',   &
                                          Lw_output(1)%flxnet(:,:,kmax+1),&
                                          is, ie, j, j)        
              if (do_clear_sky_pass) then
                call sum_diag_integral_field ('sntop_clr_nh ',   &
                                              swin_clr-swout_clr,  &
                                              is, ie, j, j)
                call sum_diag_integral_field ('lwtop_clr_nh ', olr_clr,&
                                              is, ie, j, j)
                call sum_diag_integral_field ('sngrd_clr_nh ',   &
                                              swdns_clr-swups_clr, &
                                              is, ie, j, j)
                call sum_diag_integral_field ('lwgrd_clr_nh ',   &
                                       Lw_output(1)%flxnetcf(:,:,kmax+1),&
                                       is, ie, j, j)
              endif
            endif
          end do

!--------------------------------------------------------------------
!    accumulate global integral quantities 
!--------------------------------------------------------------------
          call sum_diag_integral_field ('sntop_tot_gl ', swin-swout,  &
                                        is, js)
          call sum_diag_integral_field ('lwtop_tot_gl ', olr, is, js)
          call sum_diag_integral_field ('sngrd_tot_gl ', swdns-swups, &
                                        is, js)
          call sum_diag_integral_field ('lwgrd_tot_gl ',  &
                                  Lw_output(1)%flxnet(:,:,kmax+1), is, js)
          if (do_clear_sky_pass) then
            call sum_diag_integral_field ('sntop_clr_gl ',   &
                                          swin_clr-swout_clr, is, js)
            call sum_diag_integral_field ('lwtop_clr_gl ', olr_clr,   &
                                          is, js)
            call sum_diag_integral_field ('sngrd_clr_gl ',   &
                                          swdns_clr-swups_clr, is, js)
            call sum_diag_integral_field ('lwgrd_clr_gl ',   &
                                        Lw_output(1)%flxnetcf(:,:,kmax+1),&
                                        is, js)
          endif
        endif   ! (calc_hemi_integrals)

!---------------------------------------------------------------------



end subroutine produce_radiation_diagnostics



!###################################################################
! <SUBROUTINE NAME="deallocate_arrays">
!  <OVERVIEW>
!    deallocate_arrays deallocates the array space of local 
!    derived-type variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    deallocate_arrays deallocates the array space of local 
!    derived-type variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call deallocate_arrays (Cldrad_props, Astro, Astro2, Lw_output, &
!                              Fsrad_output, Sw_output)
!  </TEMPLATE>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   Cloud radiative properties
!  </INOUT>
!  <INOUT NAME="Astro" TYPE="astronomy_type">
!   astronomical data for the radiation package
!  </INOUT>
!  <INOUT NAME="Astro2" TYPE="astronomy_type">
!   astronomical data for the radiation package
!  </INOUT>
!  <INOUT NAME="Fsrad_output" TYPE="rad_output_type">
!   radiation output data from the 
!                        original_fms_rad radiation package, when that 
!                        package is active
!  </INOUT>
!  <INOUT NAME="Lw_output" TYPE="lw_output_type">
!      longwave radiation output data from the 
!                        sea_esf_rad radiation package, when that 
!                        package is active
!  </INOUT>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output data from the 
!                        sea_esf_rad radiation package  when that 
!                        package is active
!  </INOUT>
! </SUBROUTINE>
!
subroutine deallocate_arrays (Cldrad_props, Astro, Astro2,  &
                              Aerosol_props, Lw_output, &
                              Fsrad_output, Sw_output, Aerosol_diags)

!---------------------------------------------------------------------
!    deallocate_arrays deallocates the array space of local 
!    derived-type variables.
!---------------------------------------------------------------------

type(cldrad_properties_type), intent(inout)   :: Cldrad_props
type(astronomy_type)        , intent(inout)   :: Astro, Astro2
type(aerosol_properties_type), intent(inout)  :: Aerosol_props
type(lw_output_type),dimension(:), intent(inout)   :: Lw_output
type(fsrad_output_type)     , intent(inout)   :: Fsrad_output
type(sw_output_type),dimension(:), intent(inout)   :: Sw_output
type(aerosol_diagnostics_type), intent(inout)  :: Aerosol_diags

      integer  ::  n

!--------------------------------------------------------------------
!    deallocate the variables in Aerosol_props.
!--------------------------------------------------------------------
      if ( do_rad .and. Rad_control%do_aerosol) then 
        if (Rad_control%volcanic_sw_aerosols) then
          deallocate (Aerosol_props%sw_ext)
          deallocate (Aerosol_props%sw_ssa)
          deallocate (Aerosol_props%sw_asy)
        endif
        if (Rad_control%volcanic_lw_aerosols) then
          deallocate (Aerosol_props%lw_ext)
          deallocate (Aerosol_props%lw_ssa)
          deallocate (Aerosol_props%lw_asy)
        endif
        deallocate (Aerosol_props%ivol)
        if (Sw_control%do_swaerosol .or. &
                      Rad_control%do_swaerosol_forcing) then
          deallocate (Aerosol_props%aerextband)
          deallocate (Aerosol_props%aerssalbband)
          deallocate (Aerosol_props%aerasymmband)
        endif
        if (Lw_control%do_lwaerosol .or. &
                      Rad_control%do_lwaerosol_forcing) then
          deallocate (Aerosol_props%aerextbandlw)
          deallocate (Aerosol_props%aerssalbbandlw)
          deallocate (Aerosol_props%aerextbandlw_cn)
          deallocate (Aerosol_props%aerssalbbandlw_cn)
        endif
        deallocate (Aerosol_props%sulfate_index)
        deallocate (Aerosol_props%optical_index)
        deallocate (Aerosol_props%omphilic_index)
        deallocate (Aerosol_props%bcphilic_index)
        deallocate (Aerosol_props%seasalt1_index)
        deallocate (Aerosol_props%seasalt2_index)
        deallocate (Aerosol_props%seasalt3_index)
        deallocate (Aerosol_props%seasalt4_index)
        deallocate (Aerosol_props%seasalt5_index)
      endif

!--------------------------------------------------------------------
!    deallocate the variables in Astro and Astro2.
!--------------------------------------------------------------------
      if ( do_rad .or. renormalize_sw_fluxes ) then 
        deallocate (Astro%solar)
        deallocate (Astro%cosz )
        deallocate (Astro%fracday)
        deallocate (Astro%solar_p)
        deallocate (Astro%cosz_p )
        deallocate (Astro%fracday_p)
          if ( do_sw_rad .and. renormalize_sw_fluxes   &
              .and. Sw_control%do_diurnal ) then 
            deallocate (Astro2%solar)
            deallocate (Astro2%cosz )
            deallocate (Astro2%fracday)
        endif
      endif

!--------------------------------------------------------------------
!    deallocate the variables in Lw_output.
!--------------------------------------------------------------------
      if (do_sea_esf_rad) then
        if (do_lw_rad) then
         do n=1,size_of_lwoutput
          deallocate (Lw_output(n)%heatra    )
          deallocate (Lw_output(n)%flxnet    )
          deallocate (Lw_output(n)%netlw_special)
          deallocate (Lw_output(n)%bdy_flx)
          if (Rad_control%do_totcld_forcing) then
            deallocate (Lw_output(n)%heatracf  )
            deallocate (Lw_output(n)%flxnetcf  )
            deallocate (Lw_output(n)%netlw_special_clr)
            deallocate (Lw_output(n)%bdy_flx_clr)
          endif
        end do
      endif

!--------------------------------------------------------------------
!    deallocate the variables in Sw_output.
!--------------------------------------------------------------------
        if (do_sw_rad) then
        do n=1,size_of_swoutput
          deallocate (Sw_output(n)%dfsw     )
          deallocate (Sw_output(n)%ufsw     )
          deallocate (Sw_output(n)%dfsw_dir_sfc )
          deallocate (Sw_output(n)%dfsw_dif_sfc )
          deallocate (Sw_output(n)%ufsw_dif_sfc )
          deallocate (Sw_output(n)%fsw     )
          deallocate (Sw_output(n)%hsw     )
          deallocate (Sw_output(n)%dfsw_vis_sfc    )
          deallocate (Sw_output(n)%ufsw_vis_sfc    )
          deallocate (Sw_output(n)%dfsw_vis_sfc_dir    )
          deallocate (Sw_output(n)%dfsw_vis_sfc_dif    )
          deallocate (Sw_output(n)%ufsw_vis_sfc_dif    )
          deallocate (Sw_output(n)%swdn_special)
          deallocate (Sw_output(n)%swup_special)
          deallocate (Sw_output(n)%bdy_flx)
          if (Rad_control%do_totcld_forcing) then
            deallocate (Sw_output(n)%dfswcf   )
            deallocate (Sw_output(n)%ufswcf   )
            deallocate (Sw_output(n)%fswcf   )
            deallocate (Sw_output(n)%hswcf   )
            deallocate (Sw_output(n)%dfsw_dir_sfc_clr)
            deallocate (Sw_output(n)%dfsw_dif_sfc_clr)
            deallocate (Sw_output(n)%dfsw_vis_sfc_clr)
            deallocate (Sw_output(n)%swdn_special_clr)
            deallocate (Sw_output(n)%swup_special_clr)
            deallocate (Sw_output(n)%bdy_flx_clr)
          endif
       end do
        endif
      endif

!--------------------------------------------------------------------
!    call cldrad_props_dealloc to deallocate the variables in 
!    Cldrad_props. 
!--------------------------------------------------------------------
      if (do_rad .and. do_sea_esf_rad) then
        call cldrad_props_dealloc (Cldrad_props)
      endif

!--------------------------------------------------------------------
!    deallocate the variables in Fsrad_output.
!--------------------------------------------------------------------

      if (.not. do_sea_esf_rad .and. do_rad) then
         deallocate (Fsrad_output%tdtsw   )
         deallocate (Fsrad_output%tdtlw   )
         deallocate (Fsrad_output%swdns   )
         deallocate (Fsrad_output%swups   )
         deallocate (Fsrad_output%lwdns   )
         deallocate (Fsrad_output%lwups   )
         deallocate (Fsrad_output%swin    )
         deallocate (Fsrad_output%swout   )
         deallocate (Fsrad_output%olr     )
        if (do_clear_sky_pass) then
           deallocate (Fsrad_output%tdtsw_clr )
           deallocate (Fsrad_output%tdtlw_clr )
           deallocate (Fsrad_output%swdns_clr )
           deallocate (Fsrad_output%swups_clr )
           deallocate (Fsrad_output%lwdns_clr )
           deallocate (Fsrad_output%lwups_clr )
           deallocate (Fsrad_output%swin_clr  )
           deallocate (Fsrad_output%swout_clr )
           deallocate (Fsrad_output%olr_clr   )
        endif 
      endif 

!--------------------------------------------------------------------
!    deallocate the window-resident variables in Aerosol_props.
!--------------------------------------------------------------------
      if (do_rad .and. Rad_control%do_aerosol) then
        deallocate (Aerosol_diags%extopdep)
        deallocate (Aerosol_diags%absopdep)
        deallocate (Aerosol_diags%asymdep)
        deallocate (Aerosol_diags%extopdep_vlcno)
        deallocate (Aerosol_diags%absopdep_vlcno)
        deallocate (Aerosol_diags%sw_heating_vlcno)
        deallocate (Aerosol_diags%lw_extopdep_vlcno)
        deallocate (Aerosol_diags%lw_absopdep_vlcno)
      endif

!---------------------------------------------------------------------



end subroutine deallocate_arrays 



!#####################################################################
! <SUBROUTINE NAME="calculate_auxiliary_variables">
!  <OVERVIEW>
!    calculate_auxiliary_variables defines values of model delta z and
!    relative humidity, and the values of pressure and temperature at
!    the grid box vertical interfaces.
!  </OVERVIEW>
!  <DESCRIPTION>
!    calculate_auxiliary_variables defines values of model delta z and
!    relative humidity, and the values of pressure and temperature at
!    the grid box vertical interfaces.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call calculate_auxiliary_variables (Atmos_input)
!  </TEMPLATE>
!  <INOUT NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable, its press and temp
!                   components are input, and its deltaz, rel_hum, 
!                   pflux, tflux and aerosolrelhum components are 
!                   calculated here and output.
!  </INOUT>
! </SUBROUTINE>
!
subroutine calculate_auxiliary_variables (Atmos_input)

!----------------------------------------------------------------------
!    calculate_auxiliary_variables defines values of model delta z and
!    relative humidity, and the values of pressure and temperature at
!    the grid box vertical interfaces.
!---------------------------------------------------------------------

type(atmos_input_type), intent(inout)  :: Atmos_input

!--------------------------------------------------------------------
!   intent(inout) variables
!
!      Atmos_input  atmos_input_type variable, its press and temp
!                   components are input, and its deltaz, rel_hum, 
!                   pflux, tflux and aerosolrelhum components are 
!                   calculated here and output.
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables

      real, dimension (size(Atmos_input%temp, 1), &
                       size(Atmos_input%temp, 2), &
                       size(Atmos_input%temp, 3) - 1) :: &
                                                     qsat, qv, tv
      integer   ::  k
      integer   ::  kmax


!--------------------------------------------------------------------
!    define flux level pressures (pflux) as midway between data level
!    (layer-mean) pressures. specify temperatures at flux levels
!    (tflux).
!--------------------------------------------------------------------
      do k=ks+1,ke
        Atmos_input%pflux(:,:,k) = 0.5E+00*  &
                (Atmos_input%press(:,:,k-1) + Atmos_input%press(:,:,k))
        Atmos_input%tflux(:,:,k) = 0.5E+00*  &
                (Atmos_input%temp (:,:,k-1) + Atmos_input%temp (:,:,k))
      end do
      Atmos_input%pflux(:,:,ks  ) = 0.0E+00
      Atmos_input%pflux(:,:,ke+1) = Atmos_input%press(:,:,ke+1)
      Atmos_input%tflux(:,:,ks  ) = Atmos_input%temp (:,:,ks  )
      Atmos_input%tflux(:,:,ke+1) = Atmos_input%temp (:,:,ke+1)

!-------------------------------------------------------------------
!    define deltaz in meters.
!-------------------------------------------------------------------
      tv(:,:,:) = Atmos_input%temp(:,:,ks:ke)*    &
                  (1.0 + D608*Atmos_input%rh2o(:,:,:))
      Atmos_input%deltaz(:,:,ks) = log_p_at_top*RDGAS*tv(:,:,ks)/GRAV
      do k =ks+1,ke   
        Atmos_input%deltaz(:,:,k) = alog(Atmos_input%pflux(:,:,k+1)/  &
                                         Atmos_input%pflux(:,:,k))*   &
                                         RDGAS*tv(:,:,k)/GRAV
      end do

!-------------------------------------------------------------------
!    define deltaz in meters to be used in cloud feedback analysis.
!-------------------------------------------------------------------
      tv(:,:,:) = Atmos_input%cloudtemp(:,:,ks:ke)*    &
                  (1.0 + D608*Atmos_input%cloudvapor(:,:,:))
      Atmos_input%clouddeltaz(:,:,ks) = log_p_at_top*RDGAS*  &
                                        tv(:,:,ks)/GRAV
      do k =ks+1,ke   
        Atmos_input%clouddeltaz(:,:,k) =    &
                            alog(Atmos_input%pflux(:,:,k+1)/  &
                                         Atmos_input%pflux(:,:,k))*   &
                                         RDGAS*tv(:,:,k)/GRAV
      end do

!------------------------------------------------------------------
!    define the relative humidity.
!------------------------------------------------------------------
      kmax = size(Atmos_input%temp,3) - 1
      qv(:,:,1:kmax) = Atmos_input%rh2o(:,:,1:kmax) /    &
                                   (1.0 + Atmos_input%rh2o(:,:,1:kmax))
      call compute_qs (Atmos_input%temp(:,:,1:kmax),  &
                       Atmos_input%press(:,:,1:kmax),  &
                       qsat(:,:,1:kmax), q = qv(:,:,1:kmax))
      do k=1,kmax
        Atmos_input%rel_hum(:,:,k) = qv(:,:,k) / qsat(:,:,k)
        Atmos_input%rel_hum(:,:,k) =    &
                                  MIN (Atmos_input%rel_hum(:,:,k), 1.0)
      end do

!------------------------------------------------------------------
!    define the relative humidity seen by the aerosol code.
!------------------------------------------------------------------
        qv(:,:,1:kmax) = Atmos_input%aerosolvapor(:,:,1:kmax) /    &
                         (1.0 + Atmos_input%aerosolvapor(:,:,1:kmax))
        call compute_qs (Atmos_input%aerosoltemp(:,:,1:kmax), &
                         Atmos_input%aerosolpress(:,:,1:kmax),  &
                         qsat(:,:,1:kmax), q = qv(:,:,1:kmax))
      do k=1,kmax
         Atmos_input%aerosolrelhum(:,:,k) = qv(:,:,k) / qsat(:,:,k)
         Atmos_input%aerosolrelhum(:,:,k) =    &
                            MIN (Atmos_input%aerosolrelhum(:,:,k), 1.0)
      end do
 
!----------------------------------------------------------------------


end subroutine calculate_auxiliary_variables


!#######################################################################


                 end module radiation_driver_mod


  MODULE RAS_MOD

!=======================================================================
!  RELAXED ARAKAWA/SCHUBERT (RAS) CUMULUS PARAM SCHEME MODULE          !
!=======================================================================
!  SUBROUTINE RAS_INIT        - INITIALIZE RAS
!  SUBROUTINE RAS             - DRIVER
!  SUBROUTINE RAS_CLOUD       - RAS CU PARAMETERIZATION
!  SUBROUTINE COMP_LCL        - COMPUTE LCL (CLOUD BASE)
!  SUBROUTINE RAS_CEVAP       - EVAPORATION OF CONVECTIVE SCALE PRECIP
!  SUBROUTINE RAS_CLOUD_INDEX - SET ORDER IN WHICH CLOUDS ARE TO BE DONE 
!  SUBROUTINE RAS_CLOUD_EXIST - TEST FOR INSTABILITY IN COLUMN
!  SUBROUTINE RAS_BDGT        - BUDGET CHECK FOR RAS
!  FUNCTION   RAN0            - RANDOM NUMBER GENERATOR
!=======================================================================

 use            mpp_mod, only: mpp_pe,             &
                               mpp_root_pe,        &
                               stdlog
 use Sat_Vapor_Pres_Mod, ONLY: compute_qs
 use      Constants_Mod, ONLY:  HLv, HLs, Cp_Air, Grav, Kappa, rdgas, rvgas
 use   Diag_Manager_Mod, ONLY: register_diag_field, send_data
 use   Time_Manager_Mod, ONLY: time_type
 use            mpp_mod, only: input_nml_file
 use            fms_mod, only: write_version_number, open_namelist_file, &
                               FILE_EXIST, ERROR_MESG, check_nml_error, &
                               CLOSE_FILE, FATAL
 use  field_manager_mod, only: MODEL_ATMOS
 use tracer_manager_mod, only: get_tracer_index,   &
                               get_number_tracers, &
                               get_tracer_names,   &
                               get_tracer_indices, &
                               query_method,       &
                               NO_TRACER
 use  rad_utilities_mod,  only : aerosol_type
 use  aer_ccn_act_mod,    only : aer_ccn_act, aer_ccn_act2
!---------------------------------------------------------------------
 implicit none
 private
 public  :: ras, ras_init, ras_end, ras_bdgt
!---------------------------------------------------------------------

!      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 character(len=128) :: version = '$Id: ras.F90,v 17.0.2.1.4.1.2.1.2.1.2.2 2010/09/13 16:04:08 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

 real :: cp_div_grav
 real :: one_plus_kappa, one_minus_kappa
 real :: onebcp, onebg
 real :: rn_pfac

 logical :: module_is_initialized = .false.

 real, parameter :: d622        = rdgas/rvgas
 real, parameter :: d378        = 1.0-d622
 
!---------------------------------------------------------------------
! --- Climatological cloud work function data
!---------------------------------------------------------------------
 
 real                :: actop 
 real, dimension(15) :: ac, ad
 real, dimension(15) :: ph, a

 data ph / 150.0, 200.0, 250.0, 300.0, 350.0, 400.0, 450.0, 500.0,   &
           550.0, 600.0, 650.0, 700.0, 750.0, 800.0, 850.0 /

 data a / 1.6851, 1.1686, 0.7663, 0.5255, 0.4100, 0.3677,            &
          0.3151, 0.2216, 0.1521, 0.1082, 0.0750, 0.0664,            &
          0.0553, 0.0445, 0.0633  /

!---------------------------------------------------------------------
! --- NAMELIST
!---------------------------------------------------------------------
!       fracs  - Fraction of PBL mass allowed to be used 
!                by a cloud-type in time DT
!       rasal0 - Base value for cloud type relaxation parameter
!       puplim - Upper limit for cloud tops of deepest clouds
!       aratio - Ratio of critical cloud work function to standard
!                value of cloud work function
!       cufric - Should Cumulus friction (momentum transport) occur?
!      rh_trig - Convection takes place only if the relative humidity
!                of the lowest model level exceeds rh_trig
!      alm_min - Min value for entrainment parameter.
!   Tokioka_on - If true, alm_min computed using Tokioka formulation
!  Tokioka_con - Constant for alm_min computed using Tokioka formulation
! Tokioka_plim - Tokioka applied only to clouds detraining above Tokioka_plim
!   modify_pbl - If true, mass flux in sub cloud layer varies linearly   
!                between value at cloud base and zero at surface, and   
!                tendencies are spread out throughout the entire sub cloud layer.
! prevent_unreasonable - If true, unreasonable states (negatives) for the water 
!                        tracers are prevented. This is achieved by borrowing 
!                        from the sources of tracer within this module. 
!                        Otherwise the tendency is added without correction and
!                        can lead to negative mixing ratios. (Default = .FALSE.)
! --- CLOUD ORDER SPECIFICATION ---
!     ncrnd  - Number of random cloud-types between krmin and krmax to be
!              invoked in a single call to ras
!     iseed  - Integer seed used in generating random numbers
!              -- used only when ncrnd > 0
!     krmin  - Index of the top most level to which random clouds may
!              be invoked
!     krmax  - Index of the bottom most level to which random clouds 
!              may be invoked. krmin should be <= krmax. 
!              If ncrnd is specified as zero, then all cloud-types 
!              below the level krmax will be called sequentially.
!     botop  - A logical variable -- .true. if sequential clouds are 
!              called from bottom to top and .false. if top to bottom.
!              Level krmax will be called sequentially.
! --- PARTION CLOUD LIQUID WATER INTO PRECIP & DETRAINED VAPOR AND LIQUID --- 
!     rn_ptop - rn_frac_top of parcel liquid water converted to precip 
!               for cloud top pressures above rn_ptop
!     rn_pbot - rn_frac_bot of parcel liquid water converted to precip 
!               for cloud top pressures below rn_pbot (linear profile in 
!               between)
!     rn_frac_bot - Fraction of parcel liquid water converted to 
!                   precip for cloud top pressures below rn_pbot
!     rn_frac_top - Fraction of liquid water converted to
!                   precip for cloud top pressures above rn_ptop
! --- EVAPORATION OF CONVECTIVE SCALE PRECIP ---
!     evap_on - Turn on evaporation if true
!     cfrac   - Fraction of grid box assumed to be covered by convection
!     hcevap  - Evap allowed while q <= hcevap * qsat
! --- CRITICAL CLOUD WORK FUNCTION ---
!     ph - array, dim(15), of cloud top pressures
!      a - array, dim(15), of critical cloud work functions 
!          for clouds detraining at level ph
!---------------------------------------------------------------------

 logical :: use_online_aerosol = .false.
 real    :: fracs        = 0.25
 real    :: rasal0       = 0.25
 real    :: puplim       = 20.0E2
 real    :: aratio       = 1.4
 logical :: cufric       = .false.
 real    :: rh_trig      = 0.0      
 real    :: alm_min      = 0.0  
 logical :: Tokioka_on   = .false.
 real    :: Tokioka_con  = 0.05 
 real    :: Tokioka_plim = 500.0E2
 logical :: modify_pbl   = .false.
 logical :: prevent_unreasonable   = .false.
 
! --- cloud order specification ---
 integer :: ncrnd = 0
 integer :: iseed = 123
 integer :: krmin = 2
 integer :: krmax = 2
 logical :: botop = .true.

! --- partion cloud liquid water into precip & detrained water --- 
 real :: rn_ptop = 500.0E2
 real :: rn_pbot = 800.0E2
 real :: rn_frac_bot = 0.8
 real :: rn_frac_top = 1.0

! --- evaporation of convective scale precip ---
 logical :: evap_on = .true.   
 real    :: cfrac   = 0.05
 real    :: hcevap  = 0.80    

 real    :: sea_salt_scale = 0.1
 real    :: om_to_oc = 1.67

 integer :: nqn   ! tracer indices for stratiform clouds

    NAMELIST / ras_nml /                          &
      fracs,   rasal0,  puplim, aratio, cufric,   &
      ncrnd,   iseed,   krmin,   krmax, botop,    &
      rn_ptop, rn_pbot, rn_frac_top, rn_frac_bot, &
      evap_on, cfrac,   hcevap, rh_trig, alm_min, &
      Tokioka_on, Tokioka_con, Tokioka_plim, modify_pbl, prevent_unreasonable, &
      ph, a, sea_salt_scale, om_to_oc, use_online_aerosol

!---------------------------------------------------------------------
! DIAGNOSTICS FIELDS 
!---------------------------------------------------------------------

integer :: id_tdt_revap,  id_qdt_revap,    id_prec_revap,  &
           id_snow_revap, id_prec_conv_3d, id_pcldb, &
           id_det0, &
           id_tdt_conv, id_qdt_conv, id_prec_conv, id_snow_conv, &
           id_q_conv_col, id_t_conv_col, id_mc,&
           id_qldt_conv, id_qidt_conv, id_qadt_conv, id_qndt_conv, &
           id_ql_conv_col, id_qi_conv_col, id_qa_conv_col,         &
           id_mfcb, id_mfct, id_alm, id_cfq_ras
integer, allocatable, dimension(:) :: id_tracer_conv, id_tracer_conv_col

character(len=3) :: mod_name = 'ras'

real :: missing_value = -999.

integer  :: num_ras_tracers = 0
logical  :: do_ras_tracer = .false.

!---------------------------------------------------------------------

 contains

!#####################################################################
!#####################################################################

  SUBROUTINE RAS_INIT( do_strat, do_liq_num, axes, Time, tracers_in_ras )

!=======================================================================
! ***** INITIALIZE RAS
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!---------------------------------------------------------------------

 logical,         intent(in) :: do_strat, do_liq_num
 integer,         intent(in) :: axes(4)
 type(time_type), intent(in) :: Time
 logical, dimension(:), intent(in), optional :: tracers_in_ras

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

 integer             :: unit, io, ierr
 real                :: actp, facm 
 real, dimension(15) :: au,   tem
 integer, dimension(3) :: half = (/1,2,4/)
 character(len=128)    :: diagname, diaglname, tendunits, name, units
 integer               :: tr
 integer               :: num_tracers
 integer               :: nn, logunit
!=====================================================================

!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=ras_nml, iostat=io)
  ierr = check_nml_error(io,"ras_nml")
#else
  if( FILE_EXIST( 'input.nml' ) ) then
      unit = OPEN_NAMELIST_FILE ()
      ierr = 1 ; do while ( ierr .ne. 0 )
        READ( unit, nml = ras_nml, iostat = io, end = 10 )
        ierr = check_nml_error (io, 'ras_nml')
      end do
10  CALL CLOSE_FILE ( unit )
  end if
#endif

!---------------------------------------------------------------------
! --- Write namelist
!---------------------------------------------------------------------

  call write_version_number (version, tagname)
       logunit = stdlog()
       WRITE( logunit, nml = ras_nml ) 


!---------------------------------------------------------------------
! --- Find the tracer indices 
!---------------------------------------------------------------------
  call get_number_tracers(MODEL_ATMOS,num_prog=num_tracers)

  nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )
  if (do_liq_num .and. nqn == NO_TRACER) &
    call error_mesg ('ras_init', &
         'prognostic droplet number scheme requested but tracer not found', FATAL) 


!---------------------------------------------------------------------
! --- Initialize constants
!---------------------------------------------------------------------

  
  cp_div_grav = Cp_Air / Grav

  one_plus_kappa  = 1.0 + Kappa
  one_minus_kappa = 1.0 - Kappa

  onebcp = 1.0 / Cp_Air
  onebg  = 1.0 / Grav
  
  rn_pfac = ( rn_frac_top -  rn_frac_bot)  / ( rn_pbot - rn_ptop ) 
  
! --- Climatological cloud work function

 actp  = 1.7
 facm  = 0.01                               
 actop = actp * facm

  a  = facm * a
  ph = 100.0*ph
   
  ac = 0.0     
  ad = 0.0     
  au = 0.0     
 tem = 0.0     

 tem(2:15) = ph(2:15) -  ph(1:14)
  au(2:15) =  a(1:14) / tem(2:15) 
  ad(2:15) =  a(2:15) / tem(2:15)

  ac(2:15) = ph(2:15) * au(2:15) - ph(1:14) * ad(2:15)
  ad(2:15) = ad(2:15) - au(2:15)

!---------------------------------------------------------------------
! --- initialize quantities for diagnostics output
!---------------------------------------------------------------------

   id_tdt_revap = register_diag_field ( mod_name, &
     'tdt_revap', axes(1:3), Time, &
     'Temperature tendency from RAS prec evap',      'deg_K/s',  &
                        missing_value=missing_value               )

   id_qdt_revap = register_diag_field ( mod_name, &
     'qdt_revap', axes(1:3), Time, &
     'Spec humidity tendency from RAS prec evap',    'kg/kg/s',  &
                        missing_value=missing_value               )

   id_prec_revap = register_diag_field ( mod_name, &
     'prec_revap', axes(1:2), Time, &
     'Evap Precip rate from RAS',                   'kg/m2/s' )

   id_snow_revap = register_diag_field ( mod_name, &
     'snow_revap', axes(1:2), Time, &
     'Evap Frozen precip rate from RAS',             'kg/m2/s' )

   id_prec_conv_3d = register_diag_field ( mod_name, &
     'prec_conv_3d', axes(1:3), Time, &
     '3D Precipitation rate from RAS',      'kg/m2/s',  &
                        missing_value=missing_value               )

   id_pcldb = register_diag_field ( mod_name, &
     'pcldb', axes(1:2), Time, &
     'Pressure at cloud base from RAS',              'hPa' )

!---------------------------------------------------------------------

   id_tdt_conv = register_diag_field ( mod_name, &
     'tdt_conv', axes(1:3), Time, &
     'Temperature tendency from RAS',                'deg_K/s',  &
                        missing_value=missing_value               )

   id_qdt_conv = register_diag_field ( mod_name, &
     'qdt_conv', axes(1:3), Time, &
     'Spec humidity tendency from RAS',              'kg/kg/s',  &
                        missing_value=missing_value               )

   id_prec_conv = register_diag_field ( mod_name, &
     'prec_conv', axes(1:2), Time, &
    'Precipitation rate from RAS',                  'kg/m2/s' )

   id_snow_conv = register_diag_field ( mod_name, &
     'snow_conv', axes(1:2), Time, &
    'Frozen precip rate from RAS',                  'kg/m2/s' )

   id_q_conv_col = register_diag_field ( mod_name, &
     'q_conv_col', axes(1:2), Time, &
    'Water vapor path tendency from RAS',           'kg/m2/s' )
   
   id_t_conv_col = register_diag_field ( mod_name, &
     't_conv_col', axes(1:2), Time, &
    'Column static energy tendency from RAS',       'W/m2' )


   id_mc = register_diag_field ( mod_name, &
     'mc', axes(half), Time, &
         'Cumulus Mass Flux from RAS',                   'kg/m2/s', &
                        missing_value=missing_value               )

   id_mfcb = register_diag_field ( mod_name, &
     'mfcb', axes(1:3), Time, &
       'Cumulus cloud-base mass flux from RAS', 'kg/m2/s', &
                        missing_value=missing_value) 

   id_mfct = register_diag_field ( mod_name, &
     'mfct', axes(1:3), Time, &
     'Cumulus cloud-top mass flux from RAS', 'kg/m2/s', &
                       missing_value=missing_value) 
       
   id_alm  = register_diag_field ( mod_name, &
     'alm', axes(1:3), Time, &
     'Cumulus entrainment rate from RAS', '1/m', &
                       missing_value=missing_value) 

   id_cfq_ras = register_diag_field ( mod_name,&
     'cfq_ras', axes(1:3), Time, &
     'Cumulus frequency from RAS', 'none', &
                       missing_value=missing_value) 

   id_qndt_conv = register_diag_field ( mod_name, &
     'qndt_conv', axes(1:3), Time, &
     'Cloud droplet tendency from RAS',              '#/kg/s',  &
                        missing_value=missing_value               )

   id_qldt_conv = register_diag_field ( mod_name, &
     'qldt_conv', axes(1:3), Time, &
     'Liquid water tendency from RAS',              'kg/kg/s',  &
                        missing_value=missing_value               )

   id_qidt_conv = register_diag_field ( mod_name, &
     'qidt_conv', axes(1:3), Time, &
     'Ice water tendency from RAS',                 'kg/kg/s',  &
                        missing_value=missing_value               )

   id_qadt_conv = register_diag_field ( mod_name, &
     'qadt_conv', axes(1:3), Time, &
     'Cloud fraction tendency from RAS',            '1/sec',    &
                        missing_value=missing_value               )

   id_ql_conv_col = register_diag_field ( mod_name, &
     'ql_conv_col', axes(1:2), Time, &
    'Liquid water path tendency from RAS',          'kg/m2/s' )
   
   id_qi_conv_col = register_diag_field ( mod_name, &
     'qi_conv_col', axes(1:2), Time, &
    'Ice water path tendency from RAS',             'kg/m2/s' )
   
   id_qa_conv_col = register_diag_field ( mod_name, &
     'qa_conv_col', axes(1:2), Time, &
    'Cloud mass tendency from RAS',                 'kg/m2/s' )
      
   id_det0        = register_diag_field ( mod_name, &
     'ras_det0', axes(1:3), Time, &
    'Detrained mass flux from RAS',                 'kg/m2/s' )
      
!----------------------------------------------------------------------
!    determine how many tracers are to be transported by ras_mod.
!----------------------------------------------------------------------
      if (present(tracers_in_ras)) then
        num_ras_tracers = count(tracers_in_ras)
      else
        num_ras_tracers = 0
      endif
      if (num_ras_tracers > 0) then
        do_ras_tracer = .true.
      else
        do_ras_tracer = .false.
      endif

!---------------------------------------------------------------------
!    allocate the arrays to hold the diagnostics for the ras tracers.
!---------------------------------------------------------------------
     allocate(id_tracer_conv    (num_ras_tracers)) ; id_tracer_conv = 0
     allocate(id_tracer_conv_col(num_ras_tracers)) ; id_tracer_conv_col = 0
     nn = 1
    do tr = 1,num_tracers
      if (tracers_in_ras(tr)) then
        call get_tracer_names(MODEL_ATMOS, tr, name=name, units=units)
 
!----------------------------------------------------------------------
!    for the column tendencies, the name for the diagnostic will be 
!    the name of the tracer followed by 'dt_RAS'. the longname will be 
!    the name of the tracer followed by ' tendency from RAS'. units are
!    the supplied units of the tracer divided by seconds.
!----------------------------------------------------------------------
        diagname = trim(name)//'dt_RAS'
        diaglname = trim(name)//' tendency from RAS'
        tendunits = trim(units)//'/s'
        id_tracer_conv(nn) = register_diag_field ( mod_name, &
                             trim(diagname), axes(1:3), Time, &
                             trim(diaglname), trim(tendunits),  &
                             missing_value=missing_value               )

!----------------------------------------------------------------------
!    for the column integral  tendencies, the name for the diagnostic 
!    will be the name of the tracer followed by 'dt_RAS_col'. the long-
!    name will be the name of the tracer followed by ' path tendency 
!    from RAS'. units are the supplied units of the tracer multiplied
!    by m**2 /kg divided by seconds.
!----------------------------------------------------------------------
      diagname = trim(name)//'dt_RAS_col'
      diaglname = trim(name)//' path tendency from RAS'
      tendunits = trim(units)//'m2/kg/s'
      id_tracer_conv_col(nn) = register_diag_field ( mod_name, &
                               trim(diagname), axes(1:2), Time, &
                               trim(diaglname), trim(tendunits),  &
                               missing_value=missing_value)
       nn = nn + 1
      endif
     end do

  module_is_initialized = .true.

!=====================================================================
  end SUBROUTINE RAS_INIT


!#####################################################################
subroutine ras_end

integer :: log_unit

log_unit = stdlog()
if ( mpp_pe() == mpp_root_pe() ) then
   write (log_unit,'(/,(a))') 'Exiting RAS.'
endif

module_is_initialized = .FALSE.


end subroutine ras_end

!#####################################################################

  SUBROUTINE RAS( is,     js,      Time,      temp0,   qvap0,     &
          uwnd0,  vwnd0,  pres0,   pres0_int, zhalf0,  coldT0,    &
                  dtime,  dtemp0,  dqvap0,    duwnd0,  dvwnd0,    &
                  rain3d, snow3d,                                 &
                  rain0,  snow0,   ras_tracers, qtrras,           &
                  mask,    kbot,  mc0, det0,                      & ! optional
                  ql0, qi0, qa0,                                  & ! optional
                  dl0, di0, da0,                                  & ! optional
                  qn0, dn0, do_strat, Aerosol)                      ! optional

!=======================================================================
! ***** DRIVER FOR RAS
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!     is, js    - Starting indices for window
!     Time      - Time used for diagnostics [time_type]
!     dtime     - Size of time step in seconds
!     pres0     - Pressure
!     pres0_int - Pressure at layer interface
!     zhalf0    - Height at layer interface
!     temp0     - Temperature
!     qvap0     - Water vapor 
!     uwnd0     - U component of wind
!     vwnd0     - V component of wind
!     coldT0    - should the precipitation assume to be frozen?
!     kbot      - OPTIONAL;lowest model level index (integer)
!     mask      - OPTIONAL;used only for diagnostic output
!     ras_tracers- prognostic tracers to move around
!                 note that R0 is assumed to be dimensioned
!                 (nx,ny,nz,nt), where nt is the number of tracers
!---------------------------------------------------------------------
! Arguments (Intent inout)
!     ql0       - OPTIONAL;cloud liquid
!     qi0       - OPTIONAL;cloud ice
!     qa0       - OPTIONAL;cloud/saturated volume fraction
!---------------------------------------------------------------------
  type(time_type), intent(in)                   :: Time
  integer,         intent(in)                   :: is, js
  real,            intent(in)                   :: dtime
  real,            intent(in), dimension(:,:,:) :: pres0, pres0_int, zhalf0
  real,            intent(inout), dimension(:,:,:) :: temp0, qvap0, uwnd0, vwnd0
  logical,         intent(in), dimension(:,:)   :: coldT0
  logical,         intent(in), optional         :: do_strat
  type(aerosol_type), intent (in), optional     :: Aerosol  
  real, intent(in) , dimension(:,:,:), OPTIONAL :: mask
  integer, intent(in), OPTIONAL, dimension(:,:) :: kbot
  real,  intent(inout), OPTIONAL,dimension(:,:,:)   :: ql0, qi0, qa0, qn0
  real,  intent(in), dimension(:,:,:,:)          :: ras_tracers
!---------------------------------------------------------------------
! Arguments (Intent out)
!       rain0  - surface rain
!       snow0  - surface snow
!       rain3d - 3D rain
!       snow3d - 3D snow
!       dtemp0 - Temperature change 
!       dqvap0 - Water vapor change 
!       duwnd0 - U wind      change 
!       dvwnd0 - V wind      change 
!       mc0    - OPTIONAL; cumulus mass flux
!       Dl0    - OPTIONAL; cloud liquid tendency
!       Di0    - OPTIONAL; cloud ice tendency
!       Da0    - OPTIONAL; cloud fraction tendency
!       qtrras - prognostic tracers tendency
!---------------------------------------------------------------------
  real, intent(out), dimension(:,:,:)           :: dtemp0, dqvap0, duwnd0, dvwnd0
  real, intent(out), dimension(:,:)             :: rain0,  snow0
  real, intent(out), dimension(:,:,:,:)         :: qtrras
  real, intent(out), dimension(:,:,:)           :: rain3d,snow3d
  
  real, intent(out), OPTIONAL, dimension(:,:,:) :: mc0
  real, intent(out), OPTIONAL, dimension(:,:,:) :: det0
  real, intent(out), OPTIONAL, dimension(:,:,:) :: dl0, di0, da0, dn0

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

! precipitation flux and evaporation profiles [kg/m2/sec]
 real, dimension(SIZE(temp0,3)) :: flxprec,flxprec_evap       ! sum of all clouds
 real, dimension(SIZE(temp0,3)) :: flxprec_ib,flxprec_ib_evap ! for each cloud

 real, parameter :: p00 = 1000.0E2

 logical :: coldT,  exist    
 real    :: precip, Hl, psfc, dpcu, dtinv
 integer :: ksfc,   klcl, kk

 integer, dimension(SIZE(temp0,3)) :: ic

 real, dimension(SIZE(temp0,3)) :: &
       temp, qvap, uwnd, vwnd, pres, dtemp, dqvap, duwnd, dvwnd, &    
       ql,   qi,   qa,   qn ,  Dl,   Di,    Da,    Dn,    mass,  pi,    theta, &
       cp_by_dp,   dqvap_sat,  qvap_sat,    alpha, beta,  gamma, &
       dtcu, dqcu, ducu, dvcu, Dlcu, Dicu,  Dacu,  Dncu

 real, dimension(SIZE(temp0      ,3),num_ras_tracers) :: tracer, dtracer, dtracercu
 real, dimension(SIZE(temp0,3)+1) ::  pres_int, mc, pi_int, mccu, zhalf
 real, dimension(SIZE(temp0,3)) ::  det                               

 logical, dimension(size(temp0,1),size(temp0,2)) :: rhtrig_mask
 integer, dimension(size(temp0,1),size(temp0,2)) :: kcbase

 real,    dimension(size(temp0,1),size(temp0,2)) :: &
          psfc0, t_parc, q_parc, p_parc, qs_parc   

 real,    dimension(size(temp0,1),size(temp0,2),size(temp0,3)) :: &
          qvap_sat0, dqvap_sat0, pmass

 real,    dimension(size(temp0,1),size(temp0,2),size(temp0,3)+1) :: mask3

 real,    dimension(size(temp0,1),size(temp0,2),size(temp0,3)) :: mfcb0, mfct0, alm0, cfq_ras !miz
 real,    dimension(SIZE(temp0,3)) ::  mfcb, mfct, alm !miz
 real  :: almx

real, dimension(size(temp0,1),size(temp0,2),size(temp0,3)+1) :: mc0_local

 logical :: setras, cloud_tracers_present, do_liq_num
 integer :: i, imax, j, jmax, k, kmax, tr, num_present
 integer :: ncmax, nc, ib, naer, na
 real    :: rasal, frac, zbase
 real    :: dpfac, dtcu_pbl, dqcu_pbl, ducu_pbl, dvcu_pbl, dtracercu_pbl(num_ras_tracers)
 
 real, dimension(size(temp0,1),size(temp0,2),size(temp0,3),3) :: totalmass1
 real, dimension(size(temp0,1),size(temp0,2),size(temp0,3)) :: airdens
 real, dimension(size(temp0,3),3) :: aerosolmass

 real :: thickness

!--- For extra diagnostics

 logical :: used
 real    :: dpevap, precip_ev

 real, dimension(SIZE(temp0,3)) :: &
       cup, dtevap, dqevap, dtemp_ev, dqvap_ev

 real, dimension(size(temp0,1),size(temp0,2)) :: &
       pcldb0, rain_ev0, snow_ev0, tempdiag

 real, dimension(size(temp0,1),size(temp0,2),size(temp0,3)) :: &
       cuprc3d, dtemp_ev0, dqvap_ev0

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

! --- Check to see if ras has been initialized
  if( .not. module_is_initialized ) CALL ERROR_MESG( 'RAS',  &
                                 'ras_init has not been called', FATAL )
  
  num_present = count((/present(ql0), present(qi0), present(qa0), present(Dl0), present(Di0), present(Da0)/))
  if(num_present == 0) then
    cloud_tracers_present = .false.
  else if(num_present == 6) then
    cloud_tracers_present = .true.
  else
    call ERROR_MESG( 'RAS','Either all or none of the cloud tracers and their tendencies'// &
                     ' must be present in the call to subroutine ras',FATAL)
  endif

  if(cloud_tracers_present .and. .not.present(mc0)) then
    call ERROR_MESG( 'RAS','mc0 must be present when cloud tracers are present',FATAL)
  endif


! --- Set dimensions
  imax  = size( temp0, 1 )
  jmax  = size( temp0, 2 )
  kmax  = size( temp0, 3 )

  
  do_liq_num = PRESENT(qn0) ! Test for presence of liquid droplet number array

  if ( do_liq_num ) then
    if (.not.(PRESENT(dn0)) .or. .not.(PRESENT(Aerosol))) &
      call ERROR_MESG( 'RAS','dn0 and Aerosol must be present when liquid droplet number are present',FATAL)
  
     naer = size(Aerosol%aerosol,4)

 if(use_online_aerosol) then
 
    do k = 1,kmax
      do j = 1,jmax
        do i = 1,imax
          if(pres0_int(i,j,k)<1.) then
            thickness=(pres0_int(i,j,k+1)-pres0_int(i,j,k))* &
             8.314*temp0(i,j,k)/(9.8*0.02888*pres0_int(i,j,k))
          else
            thickness=log(pres0_int(i,j,k+1)/ &
             pres0_int(i,j,k))*8.314*temp0(i,j,k)/(9.8*0.02888)
          end if
         do na = 1,naer
            if(Aerosol%aerosol_names(na) == 'so4' .or. &
                Aerosol%aerosol_names(na) == 'so4_anthro' .or. Aerosol%aerosol_names(na) == 'so4_natural') then
                        totalmass1(i,j,k,1)=totalmass1(i,j,k,1)+Aerosol%aerosol(i,j,k,na)
            else if(Aerosol%aerosol_names(na) == 'omphilic' .or. &
            Aerosol%aerosol_names(na) == 'omphobic') then
                        totalmass1(i,j,k,3)=totalmass1(i,j,k,3)+Aerosol%aerosol(i,j,k,na)
                 else if(Aerosol%aerosol_names(na) == 'seasalt1' .or. &
                  Aerosol%aerosol_names(na) == 'seasalt2') then
                        totalmass1(i,j,k,2)=totalmass1(i,j,k,2)+Aerosol%aerosol(i,j,k,na)
                 end if
         end do
  
         do na = 1, 3
              totalmass1(i,j,k,na)=totalmass1(i,j,k,na)/thickness*1.0e9*1.0e-12
          end do
  
         end do
        end do
      end do
  
    else
    
    do k = 1,kmax
      do j = 1,jmax
        do i = 1,imax
          if(pres0_int(i,j,k)<1.) then
            thickness=(pres0_int(i,j,k+1)-pres0_int(i,j,k))* &
            8.314*temp0(i,j,k)/(9.8*0.02888*pres0_int(i,j,k))
          else
            thickness=log(pres0_int(i,j,k+1)/ &
            pres0_int(i,j,k))*8.314*temp0(i,j,k)/(9.8*0.02888)
          end if
          totalmass1(i,j,k,1)=(Aerosol%aerosol(i,j,k,1)+Aerosol%aerosol(i,j,k,2))  &
          /thickness*1.0e9*1.0e-12
          totalmass1(i,j,k,2)=sea_salt_scale*Aerosol%aerosol(i,j,k,5)  &
          /thickness*1.0e9*1.0e-12
          totalmass1(i,j,k,3)=om_to_oc*Aerosol%aerosol(i,j,k,3)  &
          /thickness*1.0e9*1.0e-12
        end do
      end do
    end do
  
end if

    airdens = pres0 / (rdgas * temp0 * (1.   - ql0 - qi0) )
  endif   

 
! --- Initalize

   dtemp0 = 0.0                               
   dqvap0 = 0.0                               
   duwnd0 = 0.0                               
   dvwnd0 = 0.0                                                                        
    rain0 = 0.0   
    snow0 = 0.0

  dtemp_ev0 = 0.0
  dqvap_ev0 = 0.0
   rain_ev0 = 0.0
   snow_ev0 = 0.0
    cuprc3d = 0.0
     rain3d = 0.0
     snow3d = 0.0
      mfcb0 = 0.0 
      mfct0 = 0.0 
      alm0  = 0.0
    cfq_ras = 0.0

  if ( cloud_tracers_present ) then
      Da0 = 0.0
      Dl0 = 0.0
      Di0 = 0.0
      if ( do_liq_num ) Dn0 = 0.0
  end if
  if (present(mc0) ) then
      mc0 = 0.0
      det0 = 0.0
  end if
! Initialize the tracer tendencies
    qtrras = 0.0

  do k=1,kmax
    pmass(:,:,k) = (pres0_int(:,:,k+1)-pres0_int(:,:,k))/GRAV
  end do

    frac  = fracs  / dtime
    rasal = rasal0 / dtime 
       
! --- Compute saturation value of water vapor & its derivative

    call compute_qs (temp0, pres0, qvap_sat0, dqsdT=dqvap_sat0)


! --- Find LCL ---> cloud base

  if (present(kbot ) ) then
     do j = 1,jmax
     do i = 1,imax
        k = kbot(i,j)
          t_parc(i,j) =     temp0(i,j,k)
          q_parc(i,j) =     qvap0(i,j,k)
          p_parc(i,j) =     pres0(i,j,k)
         qs_parc(i,j) = qvap_sat0(i,j,k)
     end do
     end do
  else
          t_parc(:,:) =     temp0(:,:,kmax)
          q_parc(:,:) =     qvap0(:,:,kmax)
          p_parc(:,:) =     pres0(:,:,kmax)
         qs_parc(:,:) = qvap_sat0(:,:,kmax)
  end if

  q_parc  = MAX( q_parc, 1.0E-6   )
  q_parc  = MIN( q_parc, qs_parc )

  CALL COMP_LCL( t_parc, q_parc, p_parc, pres0, kcbase )

! --- set rh trigger
  rhtrig_mask(:,:) = q_parc(:,:) >= rh_trig*qs_parc(:,:) 

! --- Set surface pressure
  if (present(kbot ) ) then
     do j = 1,jmax
     do i = 1,imax
        k = kbot(i,j) + 1
        psfc0(i,j) = pres0_int(i,j,k)
     end do
     end do
  else
        psfc0(:,:) = pres0_int(:,:,kmax+1)
  end if

! --- Save cloud base pressure
  if ( id_pcldb > 0 ) then
     do j = 1,jmax
     do i = 1,imax
     klcl = kcbase(i,j)
            pcldb0(i,j) = pres0_int(i,j,klcl)
     end do
     end do
  end if

  mc0_local = 0.

!---------------------------------------------------------------------

! LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
  do j = 1,jmax
  do i = 1,imax
! TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
    flxprec(:) = 0.
    flxprec_evap(:) = 0.

! --- Set order in which clouds are to be done                   
  CALL RAS_CLOUD_INDEX ( ic, ncmax )

! --- rh trigger
  if ( .not.rhtrig_mask(i,j) ) CYCLE

! --- Pack input variables / Initalize output variables 

      temp(:) =      temp0(i,j,:)
      qvap(:) =      qvap0(i,j,:)
      uwnd(:) =      uwnd0(i,j,:)
      vwnd(:) =      vwnd0(i,j,:)
      pres(:) =      pres0(i,j,:)
  pres_int(:) =  pres0_int(i,j,:)
     zhalf(:) =     zhalf0(i,j,:)
  qvap_sat(:) =  qvap_sat0(i,j,:) 
 dqvap_sat(:) = dqvap_sat0(i,j,:) 
      psfc    =      psfc0(i,j)
     coldT    =     coldT0(i,j)
      klcl    =     kcbase(i,j)
      if ( do_liq_num ) &
        aerosolmass(:,:) = totalmass1(i,j,:,:)

     dtemp(:) = 0.0                               
     dqvap(:) = 0.0                               
     duwnd(:) = 0.0                               
     dvwnd(:) = 0.0  
    precip    = 0.0   

          cup(:) = 0.0
     dtemp_ev(:) = 0.0 
     dqvap_ev(:) = 0.0 
    precip_ev    = 0.0 
         mfcb(:) = 0.0
         mfct(:) = 0.0
         alm (:) = 0.0
         almx    = 0.0

  if ( cloud_tracers_present ) then
        qa(:) = qa0(i,j,:)
        ql(:) = ql0(i,j,:)
        qi(:) = qi0(i,j,:)
        Da(:) = 0.0
        Dl(:) = 0.0
        Di(:) = 0.0
        if ( do_liq_num ) then
          qn(:) = qn0(i,j,:)
          Dn(:) = 0.0
        endif     
  end if
  if ( present(mc0) .or. id_mc > 0 ) then
        mc(:) = 0.0
        det(:) = 0.0
  end if

! Get the column of tracer data
    do tr = 1,num_ras_tracers
      dtracer(:,tr) = 0.0
      tracer(:,tr)  = ras_tracers(i,j,:,tr)
    enddo

    if( coldT ) then
     Hl = HLs
  else  
     Hl = HLv
  end if

  if( PRESENT( kbot ) ) then
       ksfc = kbot(i,j) + 1
  else
       ksfc = kmax + 1
  endif

! --- Thickness of layers 
  mass(1:kmax) =  pres_int(2:kmax+1) - pres_int(1:kmax) 
  mass(1:kmax) = MAX( mass(1:kmax), 1.0e-5 )

! --- Sub-cloud layer thickness
   zbase = zhalf(klcl) - zhalf(ksfc)

! --- Compute exner functions 
! --- at layer interfaces
  pi_int(:) = ( pres_int(:) / p00  ) ** Kappa                                   
! --- at full levels
  pi(1:kmax) = ( pi_int(2:kmax+1) * pres_int(2:kmax+1)     &
               - pi_int(1:kmax  ) * pres_int(1:kmax  ) )   &
               / ( mass(1:kmax  ) * one_plus_kappa )
  pi(1:kmax) =  MAX( pi(1:kmax), 1.0e-5 )

! --- Compute potential temperature
  theta(:) = temp(:) / pi(:)                                 

! --- Compute Cp divided by dpres                  
  cp_by_dp(1:kmax) = Cp_Air / mass(1:kmax)

! --- Compute mass of layers              
  mass(:) = mass(:) / Grav

  setras  = .true.

! --- Test for convective instability in column             
 CALL RAS_CLOUD_EXIST( klcl, qvap,   qvap_sat, theta,    &
                       pi,   pi_int, ic,       ncmax,    &
                       Hl,   exist  )
 if ( .not. exist ) CYCLE

!---------------------------------------------------------------------
! Cloud top loop starts
!---------------------------------------------------------------------
  do nc = 1,ncmax
!---------------------------------------------------------------------

     ib  = ic(nc)
 if( ib >= klcl) CYCLE

 if ( setras ) then
! --- Compute some stuff
     alpha(:) =  qvap_sat(:) - dqvap_sat(:) * temp(:)
      beta(:) = dqvap_sat(:) * pi(:)
     gamma(:) = 1.0 / ( ( 1.0 + ( Hl * dqvap_sat(:) / Cp_Air ) ) * pi(:) )
 endif

! --- Do adjustment
  if ( cloud_tracers_present .and. .not.(do_liq_num)) then
  CALL RAS_CLOUD(temp0(i,j,:), pres0(i,j,:),airdens(i,j,:),          &
       klcl,  ib,   rasal, frac, Hl, coldT,                          &
       theta, qvap, uwnd,  vwnd, pres_int, pi_int, pi, psfc,         &
       alpha, beta, gamma, cp_by_dp, zbase, almx,                    &
       dtcu,  dqcu, ducu,  dvcu, dpcu, tracer, dtracercu,            &
       mccu, ql, qi, qa, Dlcu, Dicu, Dacu)
  else if ( cloud_tracers_present .and. do_liq_num) then
  CALL RAS_CLOUD(temp0(i,j,:), pres0(i,j,:),airdens(i,j,:),          &
       klcl,  ib,   rasal, frac, Hl, coldT,                          &
       theta, qvap, uwnd,  vwnd, pres_int, pi_int, pi, psfc,         &
       alpha, beta, gamma, cp_by_dp, zbase, almx,                    &
       dtcu,  dqcu, ducu,  dvcu, dpcu, tracer, dtracercu,            &
       mccu, ql, qi, qa, Dlcu, Dicu, Dacu, aerosolmass, qn, Dncu)
  else if (present(mc0) .or. id_mc > 0) then
  CALL RAS_CLOUD(temp0(i,j,:), pres0(i,j,:),airdens(i,j,:),          &
       klcl,  ib,   rasal, frac, Hl,  coldT,                         &
       theta, qvap, uwnd,  vwnd, pres_int, pi_int, pi, psfc,         &
       alpha, beta, gamma, cp_by_dp, zbase, almx,                    &
       dtcu,  dqcu, ducu,  dvcu, dpcu, tracer, dtracercu, mccu)  
  else
  CALL RAS_CLOUD(temp0(i,j,:), pres0(i,j,:),airdens(i,j,:),          &
       klcl,  ib,   rasal, frac, Hl,  coldT,                         &
       theta, qvap, uwnd,  vwnd, pres_int, pi_int, pi, psfc,         &
       alpha, beta, gamma, cp_by_dp, zbase, almx,                    &
       dtcu,  dqcu, ducu,  dvcu, dpcu, tracer, dtracercu)
  end if

! --- For optional diagnostic output
  cup(ib) = dpcu

! --- Multiply tendencies by size of time step
  dtcu(:) =  dtcu(:) * dtime
  dqcu(:) =  dqcu(:) * dtime
  ducu(:) =  ducu(:) * dtime
  dvcu(:) =  dvcu(:) * dtime
  dpcu    =  dpcu    * dtime

  if ( cloud_tracers_present ) then
  Dacu(:) =  Dacu(:) * dtime
  Dlcu(:) =  Dlcu(:) * dtime
  Dicu(:) =  Dicu(:) * dtime
  if ( do_liq_num ) &
    Dncu(:) =  Dncu(:) * dtime
  end if

    do tr = 1,num_ras_tracers
      dtracercu(:,tr) = dtracercu(:,tr) * dtime
    enddo
  if( modify_pbl ) then   
! TTTTTTTTTTTTTTTTTTTTT      
! --- Adjust mass flux between cloud base and surface       
    if ( present(mc0) .or. id_mc > 0 ) then
      do k = klcl+1,ksfc
        mccu(k) = mccu(klcl) * ( psfc - pres_int(k)    ) / &
                               ( psfc - pres_int(klcl) )
      end do
    end if
! --- Adjust tendencies between cloud base and surface
    dpfac = ( pres_int(klcl+1) - pres_int(klcl) ) / &
             ( psfc             - pres_int(klcl) )   
    dtcu_pbl = dpfac * dtcu(klcl) * pi(klcl)
    dqcu_pbl = dpfac * dqcu(klcl) 
    ducu_pbl = dpfac * ducu(klcl) 
    dvcu_pbl = dpfac * dvcu(klcl) 
    do tr = 1,num_ras_tracers
      dtracercu_pbl(tr) = dpfac * dtracercu(klcl,tr)
    enddo
    do k = klcl,ksfc-1
      dtcu(k) = dtcu_pbl / pi(k) 
      dqcu(k) = dqcu_pbl
      ducu(k) = ducu_pbl
      dvcu(k) = dvcu_pbl
        do tr = 1,num_ras_tracers
          dtracercu(k,tr) = dtracercu_pbl(tr)
        enddo
    end do
! LLLLLLLLLLLLLLLLL
  endif
! --- Evaporate some precip

      dtevap(:) = 0.0
      dqevap(:) = 0.0
      dpevap    = 0.0
!
! -- initialise the precipitation and evaporation flux
      flxprec_ib_evap = 0.0

  if( evap_on .and. ( dpcu > 0.0 ) ) then

  CALL RAS_CEVAP ( ib, temp, qvap, pres, mass, qvap_sat,       &
                   dqvap_sat, psfc, Hl, dtime, ksfc, dpcu,     &
                   dtevap, dqevap,  dpevap, flxprec_ib, flxprec_ib_evap  )

      dtcu(:) =  dtcu(:) + dtevap(:) / pi(:)
      dqcu(:) =  dqcu(:) + dqevap(:)
      dpcu    = MAX(dpcu - dpevap, 0.)

  else
    flxprec_ib(1:ib-1) = 0.0
    flxprec_ib(ib:) = dpcu/dtime
  endif

!---sum up precipitation flux and evaporation from  each cloud type
!
flxprec      = flxprec +flxprec_ib
flxprec_evap = flxprec_evap +flxprec_ib_evap

! --- Update prognostic tracers
!     NOTE: negative values of tracers are not prevented
    do tr = 1,num_ras_tracers
         tracer(:,tr)   = amax1(0.,tracer(:,tr) + dtracercu(:,tr))
    enddo  

if ( prevent_unreasonable ) then
! --- Update cloud liquid, ice, and fraction
!     NOTE: unreasonable states are prevented

  if ( cloud_tracers_present ) then
  
    !cloud fraction---------------
    where ((qa + Dacu) .lt. 0.)
         Dacu = -1.*qa
        qa   = 0.
    elsewhere
         qa   = qa + Dacu
    end where
    where (qa .gt. 1.)
         Dacu = Dacu + (1. - qa)
         qa   = 1.
    end where
    
    !cloud liquid----------------
    where ((ql + Dlcu) .lt. 0.)
         dtcu = dtcu - HLv*(ql+Dlcu)/Cp_Air/pi
        dqcu = dqcu + (ql + Dlcu)
         Dlcu = Dlcu - (ql + Dlcu)
        ql   = 0.
    elsewhere
         ql   = ql + Dlcu
    end where
    
    !cloud ice----------------
    where ((qi + Dicu) .lt. 0.)
         dtcu = dtcu - HLs*(qi+Dicu)/Cp_Air/pi
        dqcu = dqcu + (qi + Dicu)
         Dicu = Dicu - (qi + Dicu)
        qi   = 0.
    elsewhere
         qi   = qi + Dicu
    endwhere
            
  end if
else

  if ( cloud_tracers_present ) then
    ql(:) = ql(:) + Dlcu(:)
    qi(:) = qi(:) + Dicu(:)
    qa(:) = qa(:) + Dacu(:)
    if ( do_liq_num ) &
      qn(:) = qn(:) + Dncu(:)
  end if

endif

! --- Update potential temperature, water vapor, winds
  theta(:) = theta(:) + dtcu(:)
   qvap(:) =  qvap(:) + dqcu(:)
   uwnd(:) =  uwnd(:) + ducu(:)
   vwnd(:) =  vwnd(:) + dvcu(:)

! --- Recover temperature 
  temp(:) = theta(:) * pi(:)

! --- Accumulate precip 
  precip    = precip    + dpcu 
  precip_ev = precip_ev + dpevap

! --- Accumulate tendencies 
     dtemp(:) =    dtemp(:) +   dtcu(:) * pi(:)
     dqvap(:) =    dqvap(:) +   dqcu(:)
     duwnd(:) =    duwnd(:) +   ducu(:) 
     dvwnd(:) =    dvwnd(:) +   dvcu(:)
  dtemp_ev(:) = dtemp_ev(:) + dtevap(:)
  dqvap_ev(:) = dqvap_ev(:) + dqevap(:)

  if ( cloud_tracers_present ) then
    Da(:) = Da(:) + Dacu(:)
    Dl(:) = Dl(:) + Dlcu(:)
    Di(:) = Di(:) + Dicu(:)
    if ( do_liq_num ) &
      Dn(:) = Dn(:) + Dncu(:)
  end if
  mfcb(ib)=mccu(klcl) 
  mfct(ib)=mccu(ib+1) 
  alm (ib)=almx 

  if ( present(mc0) .or. id_mc > 0 ) then
    mc(:) = mc(:) + mccu(:)
    det(ib) = det(ib) + mccu(ib+1)
  end if
  do tr = 1,num_ras_tracers
    dtracer(:,tr) = dtracer(:,tr) + dtracercu(:,tr)
  enddo  

  setras = .false.

 if ( setras ) then
! --- Re-Compute saturation value of water vapor & its derivative
   call compute_qs (temp, pres, qvap_sat, dqsdT=dqvap_sat)
  end if
     
!---------------------------------------------------------------------
  end do ! do nc = 1,ncmax
!---------------------------------------------------------------------
! Cloud top loop ends
!---------------------------------------------------------------------

! --- Unpack variables
      dtemp0(i,j,:) = dtemp(:)
      dqvap0(i,j,:) = dqvap(:) 
      duwnd0(i,j,:) = duwnd(:)
      dvwnd0(i,j,:) = dvwnd(:)
      mfcb0 (i,j,:) = mfcb(:)
      mfct0 (i,j,:) = mfct(:)
      alm0  (i,j,:) = alm (:)

   if ( coldT ) then
      snow0(i,j) = precip
   else
      rain0(i,j) = precip
   end if

!-- unpacking the precipitation flux. The 
    do kk = 1,kmax
      if ( coldT ) then
       snow3d(i,j,kk+1)   = flxprec(kk)      !kg/m2/sec
      else
       rain3d(i,j,kk+1)   = flxprec(kk)      !kg/m2/sec
      end if
    enddo

  if ( cloud_tracers_present ) then
        Da0(i,j,:) = Da(:) 
        Dl0(i,j,:) = Dl(:) 
        Di0(i,j,:) = Di(:)
        if ( do_liq_num ) &
          Dn0(i,j,:) = Dn(:)
  end if
  if ( present(mc0) .or. id_mc > 0 ) then
        mc0_local(i,j,:) = mc(:)
        det0(i,j,:) = det(:)
  end if
  do tr = 1,num_ras_tracers
    qtrras(i,j,:,tr) = dtracer(:,tr)
  enddo    

! --- For extra diagnostics
 
     cuprc3d(i,j,:) =       cup(:) 
   dtemp_ev0(i,j,:) =  dtemp_ev(:)
   dqvap_ev0(i,j,:) =  dqvap_ev(:)

    if ( coldT ) then
       snow_ev0(i,j) = precip_ev
    else
       rain_ev0(i,j) = precip_ev
    end if

! LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
  end do ! do i = 1,imax
  end do ! do j = 1,jmax
! TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT

!------- update input values and compute tendency -----------
   dtinv = 1.0/dtime

   temp0=temp0+dtemp0;    qvap0=qvap0+dqvap0
   uwnd0=uwnd0+duwnd0;    vwnd0=vwnd0+dvwnd0

   duwnd0=duwnd0*dtinv; dvwnd0=dvwnd0*dtinv

   dtemp0=dtemp0*dtinv; dqvap0=dqvap0*dtinv
   rain0=rain0*dtinv; snow0=snow0*dtinv

!!------- add on tendency ----------
!      tdt=tdt+ttnd; qdt=qdt+qtnd
!      udt=udt+utnd; vdt=vdt+vtnd

!------- update input values , compute and add on tendency -----------
!-------              in the case of strat                 -----------

   if (cloud_tracers_present) then
     ql0(:,:,:) = ql0(:,:,:)+Dl0(:,:,:)
     qi0(:,:,:) = qi0(:,:,:)+Di0(:,:,:)
     qa0(:,:,:) = qa0(:,:,:)+Da0(:,:,:)
     if ( do_liq_num ) &
       qn0(:,:,:) = qn0(:,:,:)+Dn0(:,:,:)

     Dl0(:,:,:) = Dl0(:,:,:)*dtinv
     Di0(:,:,:) = Di0(:,:,:)*dtinv
     Da0(:,:,:) = Da0(:,:,:)*dtinv
     if ( do_liq_num ) &
       Dn0(:,:,:)=Dn0(:,:,:)*dtinv

   end if
   do tr = 1,num_ras_tracers
     qtrras(:,:,:,tr) = qtrras(:,:,:,tr)*dtinv
   enddo    

   if(present(mc0)) mc0 = mc0_local

!---------------------------------------------------------------------
! --- Extra diagnostics
!---------------------------------------------------------------------
 
   dtemp_ev0(:,:,:) = dtemp_ev0(:,:,:) * dtinv
   dqvap_ev0(:,:,:) = dqvap_ev0(:,:,:) * dtinv
   snow_ev0(:,:)   =  snow_ev0(:,:)   * dtinv
   rain_ev0(:,:)   =  rain_ev0(:,:)   * dtinv

   used = send_data ( id_tdt_revap, dtemp_ev0, Time, is, js, 1 )
   used = send_data ( id_qdt_revap, dqvap_ev0, Time, is, js, 1 )
   used = send_data ( id_prec_revap, rain_ev0+snow_ev0, Time, is, js )
   used = send_data ( id_snow_revap, snow_ev0, Time, is, js )
   used = send_data ( id_prec_conv_3d, cuprc3d, Time, is, js, 1 )
   used = send_data ( id_pcldb, pcldb0, Time, is, js )

!------- diagnostics for dt/dt_ras -------
   used = send_data ( id_tdt_conv, dtemp0, Time, is, js, 1, &
                      rmask=mask )
!------- diagnostics for dq/dt_ras -------
   used = send_data ( id_qdt_conv, dqvap0, Time, is, js, 1, &
                      rmask=mask )
!------- diagnostics for precip_ras -------
   used = send_data ( id_prec_conv, (rain0+snow0), Time, is, js )
!------- diagnostics for snow_ras -------
   used = send_data ( id_snow_conv, snow0, Time, is, js )
!------- diagnostics for cumulus mass flux from ras -------
   if ( id_mc > 0 ) then
        !------- set up mask --------
        mask3(:,:,1:(kmax+1)) = 1.
        if (present(mask)) then
          WHERE (mask(:,:,1:kmax) <= 0.5)
                  mask3(:,:,1:kmax) = 0.
          END WHERE
        endif
        used = send_data ( id_mc, mc0_local, Time, is, js, 1, rmask=mask3 )
   endif
   used = send_data ( id_mfcb, mfcb0(:,:,1:kmax), Time, is, js, 1, rmask=mask )
   used = send_data ( id_mfct, mfct0(:,:,1:kmax), Time, is, js, 1, rmask=mask )
   used = send_data ( id_alm,  alm0 (:,:,1:kmax), Time, is, js, 1, rmask=mask )
   if ( id_cfq_ras > 0 ) then
     where (mfcb0(:,:,:) .gt. 0.)
       cfq_ras(:,:,:) = 1
     end where
     used = send_data ( id_cfq_ras,  cfq_ras (:,:,1:kmax), Time, is, js, 1, rmask=mask )
   endif
    

!------- diagnostics for water vapor path tendency ----------
   if ( id_q_conv_col > 0 ) then
     tempdiag(:,:)=0.
     do k=1,kmax
       tempdiag(:,:) = tempdiag(:,:) + dqvap0(:,:,k)*pmass(:,:,k)*dtinv
     end do
     used = send_data ( id_q_conv_col, tempdiag, Time, is, js )
   end if

!------- diagnostics for dry static energy tendency ---------
   if ( id_t_conv_col > 0 ) then
     tempdiag(:,:)=0.
     do k=1,kmax
       tempdiag(:,:) = tempdiag(:,:) + dtemp0(:,:,k)*Cp_Air*pmass(:,:,k)
     end do
     used = send_data ( id_t_conv_col, tempdiag, Time, is, js )
   end if

   if ( cloud_tracers_present ) then

      !------- diagnostics for dql/dt from RAS -----------------
      used = send_data ( id_qldt_conv, Dl0, Time, is, js, 1, &
                         rmask=mask )
      
      !------- diagnostics for dqi/dt from RAS -----------------
      used = send_data ( id_qidt_conv, Di0, Time, is, js, 1, &
                         rmask=mask )
      
      !------- diagnostics for dqa/dt from RAS -----------------
      used = send_data ( id_qadt_conv, Da0, Time, is, js, 1, &
                         rmask=mask )

      !------- diagnostics for dqn/dt from RAS -----------------
      if (do_liq_num .and. id_qndt_conv > 0 ) &
        used = send_data ( id_qndt_conv, Dn0, Time, is, js, 1, &
                         rmask=mask )

      !------- diagnostics for liquid water path tendency ------
      if ( id_ql_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kmax
          tempdiag(:,:) = tempdiag(:,:) + Dl0(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_ql_conv_col, tempdiag, Time, is, js )
      end if
      
      !------- diagnostics for ice water path tendency ---------
      if ( id_qi_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kmax
          tempdiag(:,:) = tempdiag(:,:) + Di0(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_qi_conv_col, tempdiag, Time, is, js )
      end if
      
      !---- diagnostics for column integrated cloud mass tendency ---
      if ( id_qa_conv_col > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kmax
          tempdiag(:,:) = tempdiag(:,:) + Da0(:,:,k)*pmass(:,:,k)
        end do
        used = send_data ( id_qa_conv_col, tempdiag, Time, is, js )
      end if
         
      !------- diagnostics for det0 from RAS -----------------
      used = send_data ( id_det0, det0, Time, is, js, 1, &
                         rmask=mask )

   end if !end do strat if

   do tr = 1, num_ras_tracers
      !------- diagnostics for dtracer/dt from RAS -------------
      used = send_data ( id_tracer_conv(tr), qtrras(:,:,:,tr), Time, is, js, 1, &
                         rmask=mask )

      !------- diagnostics for column tracer path tendency -----
      if ( id_tracer_conv_col(tr) > 0 ) then
        tempdiag(:,:)=0.
        do k=1,kmax
          tempdiag(:,:) = tempdiag(:,:) + qtrras(:,:,k,tr)*pmass(:,:,k)
        end do
        used = send_data ( id_tracer_conv_col(tr), tempdiag, Time, is, js )
      end if


   enddo
!=====================================================================



  end SUBROUTINE RAS


!#######################################################################
!#######################################################################

 SUBROUTINE RAS_CLOUD(t, p, dens,                                &
            k, ic, rasal, frac, hl, coldT,                       &
            theta, qvap, uwnd, vwnd, pres_int, pi_int, pi, psfc, &
            alf, bet, gam, cp_by_dp, zbase, almx,                &
            dtcu, dqcu, ducu,  dvcu, dpcu, tracer, dtracercu,    &
            mccu, ql, qi, qa, Dlcu, Dicu, Dacu, aerosolmass, qn, Dncu)   ! optional
!=======================================================================
! RAS Cu Parameterization 
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!     k        : Cloud base index.
!     ic       : Cloud top index.
!     hl       : proper latent heat for the column
!     coldT    : is the precipitation frozen?
!     theta    : Potential temperature
!     qvap     : Water vapor 
!     uwnd     : U component of wind
!     vwnd     : V component of wind
!     pres_int : Pressure       at layer interface
!     pi_int   : Exner function at layer interface
!     pi       : Exner function 
!     psfc     : Surface pressure
!     zbase    : Thickness of sub-cloud layer
!     rasal    : Relaxation parameter for cloud type ic
!     ql       : OPTIONAL, cloud liquid
!     qi       : OPTIONAL, cloud ice
!     qa       : OPTIONAL, cloud fraction or saturated volume fraction
!---------------------------------------------------------------------

 real,    intent(inout):: almx    !miz
 real,    intent(in) :: rasal, frac, zbase
 real,    intent(in) :: hl,    psfc
 integer, intent(in) :: ic,    k
 logical, intent(in) :: coldT
 real, intent(in), dimension(:) :: t,p,dens
 real, intent(in), dimension(:) :: theta, qvap, uwnd, vwnd, pres_int, pi_int
 real, intent(in), dimension(:) :: alf,   bet,  gam,  pi,   cp_by_dp
 real, intent(in), OPTIONAL, dimension(:) :: ql,qi,qa,qn
 real, intent(in), dimension(:,:) :: tracer
 real, intent(in), OPTIONAL, dimension(:,:) :: aerosolmass
!---------------------------------------------------------------------
! Arguments (Intent out)
!     dpcu    : Precip for cloud type ic.
!     dtcu    : Potential temperature change
!     dqcu    : Water vapor change
!     ducu    : Cu friction - u component.
!     dvcu    : Cu friction - v component.
!     mccu    : OPTIONAL ; Cumulus Mass Flux
!     Dacu    : OPTIONAL ; Detrained saturated mass fraction tendency
!     Dlcu    : OPTIONAL ; Detrained cloud liquid tendency
!     Dicu    : OPTIONAL ; Detrained cloud ice tendency
!     dtracercu : OPTIONAL ; Detrained tracer tendency 
!---------------------------------------------------------------------

 real, intent(out)  :: dpcu
 real, intent(out), dimension(:) :: dtcu, dqcu, ducu, dvcu
 real, intent(out), OPTIONAL, dimension(:) :: mccu, Dacu, Dlcu, Dicu, Dncu
 real, intent(out), dimension(:,:) :: dtracercu

!---------------------------------------------------------------------
!    (Intent local)
!---------------------------------------------------------------------

 real, parameter :: rhmax  = 0.9999 

  logical :: lcase1,    lcase2
  real    :: wfn_crit,  ftop, rn_frac
  real    :: wfn,  akm, qs1,  uht, vht, wlq, alm 
  real    :: rasalf
  real    :: wll,  wli, wlN
  integer :: km1,  ic1, l,    iwk
  real    :: xx1,  xx2, xx3,  xx4
  real    :: ssl, dtemp, zzl, hccp, hcc,  dpib, dpit 
  real    :: dut, dvt,   dub, dvb,  wdet, dhic, hkb, hic, sic
 
 real, dimension(size(theta,1)) :: gmh, eta, hol, hst, qol
 real, dimension(SIZE(tracer,2)) :: wlR

 logical :: Ldacu, Lmccu, LRcu, do_liq_num

!thetac in-cloud potential temperature (K)
!qc in-cloud vapor mixing ratio (kg water/kg air)
!qt in-cloud qc + ql (kg water/kg air)
 real, dimension(size(theta,1)) :: thetac, qc, qt
 real     :: tc, te, Nc, up_conv, drop
 real, dimension(3) :: totalmass
 integer :: tr

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

! --- Check for presence of optional arguments
  Ldacu = PRESENT( Dacu )
  Lmccu = PRESENT( mccu ) 
  LRcu  = .TRUE.
  do_liq_num = PRESENT(qn) 


! Initialize
  dtcu = 0.0
  dqcu = 0.0
  ducu = 0.0
  dvcu = 0.0
  dpcu = 0.0
  if ( Ldacu ) then
  Dacu = 0.0
  Dlcu = 0.0
  Dicu = 0.0
  if ( do_liq_num ) Dncu = 0.0
  end if
  if ( Lmccu ) then
  mccu = 0.0
  end if
  if ( LRcu ) then
  do tr = 1,num_ras_tracers
    dtracercu(:,tr) = 0.0
  enddo
  end if

! Initialize
  wfn=0.0
  akm=0.0
  qs1=0.0
  uht=0.0
  vht=0.0
  wlq=0.0
  alm=0.0
  almx=0.0
  wll=0.0
  wli=0.0
  if ( do_liq_num ) &
    wlN=0.0
  gmh=0.0
  eta=0.0
  hol=0.0
  hst=0.0
  qol=0.0
  km1=0
  ic1=0
  l=0
  rasalf=0.0

  km1 = k  - 1
  ic1 = ic + 1

!=====================================================================
! --- RECOMPUTE SOUNDING UP TO DETRAINMENT LEVEL
!=====================================================================

! --- at cloud base
    qs1    = alf(k) + bet(k) * theta(k)
    qol(k) = MIN( qs1 * rhmax, qvap(k) )
    hol(k) = pi_int(k+1) * theta(k) * Cp_Air + qol(k) * Hl
    eta(k) = 0.0
    zzl    = ( pi_int(k+1) - pi_int(k) ) * theta(k) * Cp_Air

! --- between cloud base & cloud top
 if ( ic < km1 ) then
 do l = km1,ic1,-1
    qs1    = alf(l) + bet(l) * theta(l)
    qol(l) = MIN( qs1 * rhmax, qvap(l) )
    ssl    = zzl + pi_int(l+1) * theta(l) * Cp_Air 
    hol(l) = ssl + qol(l) * Hl
    hst(l) = ssl + qs1    * Hl
    dtemp  = ( pi_int(l+1) - pi_int(l) ) * theta(l)
    eta(l) = eta(l+1) + dtemp * cp_div_grav
    zzl    = zzl      + dtemp * Cp_Air    
 end do
 end if

! --- at cloud top
    qs1     = alf(ic) + bet(ic) * theta(ic)
    qol(ic) = MIN( qs1 * rhmax, qvap(ic) ) 
    ssl     = zzl + pi_int(ic1) * theta(ic) * Cp_Air 
    hol(ic) = ssl + qol(ic) * Hl
    hst(ic) = ssl + qs1     * Hl
    dtemp   = ( pi_int(ic1) - pi(ic) ) * theta(ic)
    eta(ic) = eta(ic1) + dtemp * cp_div_grav

!=====================================================================
!     ENTRAINMENT PARAMETER
!=====================================================================

    xx1 = hol(k) - hst(ic)

    xx2 = 0.0
 do l = ic,km1
    xx2 = xx2 + ( hst(ic) - hol(l) ) * ( eta(l) - eta(l+1) )
 end do

   lcase1 = ( xx2    >  0.0      ) .and.  &
            ( xx1    >  0.0      )

   lcase2 = ( xx1    <= 0.0      ) .and. &
            ( hol(k) >  hst(ic1) ) .and. &
            ( ic1    <  k ) 

!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
 if ( .not.lcase1 .and. .not.lcase2 )  RETURN
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

  if ( lcase1 ) then
     alm = xx1 / xx2
  else 
     alm = 0.0
  end if

!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!  if( Tokioka_on ) alm_min = Tokioka_con / zbase
!  if( alm < alm_min ) RETURN
     xx2 = alm_min
  if( Tokioka_on ) then
     xx1  = 0.5 * ( pres_int(ic) + pres_int(ic1) )
     if(  xx1 <= Tokioka_plim ) xx2 = Tokioka_con / zbase
  endif
  if( alm < xx2 ) then
    almx = 0.0
    RETURN
  endif
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

!=====================================================================
!    NORMALIZED MASSFLUX
!=====================================================================

 do l = ic,km1
    eta(l) = 1.0 + alm * eta(l)
 end do
    eta(k) = 1.0

!=====================================================================
!     CLOUD WORKFUNCTION
!=====================================================================

    wfn  = 0.0
    hccp = hol(k)

!=====================================================================
!     IN-CLOUD TEMP AND WATER MIXING RATIO
!=====================================================================

    if ( do_liq_num ) then
    thetac(k) = theta(k)
    zzl  = ( pi_int(k+1) - pi_int(k) ) * theta(k) * Cp_Air
    wlq =  qol(k)
    qt(k) = qol(k)
    endif


 if ( ic1 <= km1 ) then
 do l = km1,ic1,-1
!hcc in-cloud moist static energy (MSE)
    hcc = hccp + ( eta(l) - eta(l+1) ) * hol(l)
    dpib = pi_int(l+1) - pi(l)
    dpit = pi(l)       - pi_int(l)
!environment
    xx1  = ( eta(l+1) * dpib + eta(l) * dpit ) * hst(l)
!in-cloud
    xx2  =       hccp * dpib +    hcc * dpit
    wfn  = wfn + ( xx2 - xx1 ) * gam(l)
    hccp = hcc

    if ( do_liq_num ) then
    thetac(l) = ((hcc-zzl)/eta(l)-alf(l)*Hl)/(pi_int(l+1)*Cp_Air+bet(l)*Hl)
!    qc(l) = alf(l)+bet(l)*thetac(l)
    qc(l) = alf(l)+bet(l)*theta(l)

    ssl  = zzl + pi_int(l+1) * thetac(l) * Cp_Air
    dtemp  = ( pi_int(l+1) - pi_int(l) ) * thetac(l)

    zzl    = zzl      + dtemp * Cp_Air    
    xx1 = eta(l) - eta(l+1)
    wlq = wlq + xx1 *  qol(l)
    qt(l) = wlq/eta(l)
    endif

 end do
 end if

 if ( lcase1 ) then
    wfn = wfn + gam(ic) * ( pi_int(ic1) - pi(ic) ) * &
               ( hccp - hst(ic) * eta(ic1) )
 end if

    if ( do_liq_num ) &
      up_conv=0.7*max(wfn,0.)**0.5

!=====================================================================
!    CRITICAL CLOUD WORK FUNCTION
!=====================================================================

      xx1  = 0.5 * ( pres_int(ic) + pres_int(ic1) )
      xx2  = pres_int(k)
      ftop = 1.0

 if ( lcase2 ) then
   if ( hst(ic1) < hst(ic) ) then
      ftop = ( hst(ic1) - hol(k) ) / ( hst(ic1) - hst(ic) )
   else
      ftop = 0.0
   endif
      xx3 = 0.5 * ( pres_int(ic1) + pres_int(ic1+1) )
      xx1 = xx3 * ( 1.0 - ftop ) + xx1 * ftop
 endif

! $$$  CALL RAS_ACRITN ( xx1, xx2, wfn_crit )

        iwk = xx1 * 0.02E-2 - 0.999999999
 if ( ( iwk > 1 ) .and. ( iwk <= 15 ) ) then
         wfn_crit = ac(iwk) + xx1 * ad(iwk)
 else if ( iwk <= 1 ) then
         wfn_crit = actop
 else if ( iwk > 15 ) then
         wfn_crit = a(15)
 end if
         wfn_crit = aratio * wfn_crit * ( xx2 - xx1 )

  wfn = wfn - wfn_crit

 lcase1 = lcase1 .and. ( wfn > 0.0 )
 lcase2 = lcase2 .and. ( wfn > 0.0 ) .and. ( ftop > 0.0 )

!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  if ( .not.lcase1 .and. .not.lcase2 )  then
    almx = 0.0
    RETURN
  endif
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  almx = alm
!=====================================================================

  if ( lcase1 ) then
      dhic = hst(ic) - hol(ic)
  else
      dhic = ( hol(k)  - hol(ic1) ) &
           - ( hol(ic) - hol(ic1) ) * ftop
  end if

  if ( lcase2 ) then
     xx1 = ftop * ( hol(ic) - hol(ic1) ) + hol(ic1)
     xx2 = ftop * ( qol(ic) - qol(ic1) ) + qol(ic1)
     sic = xx1 - xx2 * Hl
     qs1 = xx2 + dhic * ( 1.0 / Hl )
  end if

     hic = hol(ic)
     hkb = hol(k)

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

     wlq =  qol(k) - qs1      * eta(ic)
     uht = uwnd(k) - uwnd(ic) * eta(ic)
     vht = vwnd(k) - vwnd(ic) * eta(ic)

 do l = km1,ic,-1
     xx1 = eta(l) - eta(l+1)
     wlq = wlq + xx1 *  qol(l)
     uht = uht + xx1 * uwnd(l)
     vht = vht + xx1 * vwnd(l)
 end do

!=====================================================================
!         CALCULATE TRACER UPDRAFT PROPERTIES
!            AND CONVECTIVE SOURCE OF TRACER
!=====================================================================


!------------ Prognostic tracers

if ( LRcu ) then

!     wlR = tracer(k,:)
     
! do l = km1,ic,-1
!     xx1 = eta(l) - eta(l+1)
!     wlR = wlR + xx1 * tracer(l,:)
! end do
! 
!!do cloud base level
!     xx1     = 0.5 * cp_by_dp(k) / Cp_Air / onebg
!     dtracercu(k,:) = ( tracer(km1,:) - tracer(k,:) ) * xx1
     
! if ( ic1 <= km1 ) then
! do l = km1,ic1,-1
!     xx1     = 0.5 * cp_by_dp(l) / Cp_Air / onebg
!     dtracercu(l,:) = ( eta(l+1) * ( tracer(l  ,:) - tracer(l+1,:) ) + &
!                   eta(l  ) * ( tracer(l-1,:) - tracer(l  ,:) ) ) * xx1
! end do
! end if
!
! !do cloud top level
!     xx1      = cp_by_dp(ic) / Cp_Air / onebg
!     xx2      = 0.5 * xx1
!     dtracercu(ic,:) = ( eta(ic1) * ( tracer(ic,:) - tracer(ic1,:) ) * xx2 ) + &
!                  ( wlR      - eta(ic) * tracer(ic,:)  ) * xx1
!
 end if

!------------ Cloud liquid, ice, and fraction

 if ( Ldacu ) then

     wll = ql(k)
     wli = qi(k)
     if ( do_liq_num ) &
       wlN = qn(k)
 do tr=1,num_ras_tracers
     wlR(tr) = tracer(k,tr)
 enddo

 do l = km1,ic,-1
     xx1 = eta(l) - eta(l+1)
     wll = wll + xx1 * ql(l)
     wli = wli + xx1 * qi(l)
     do tr=1,num_ras_tracers
       wlR(tr) = wlR(tr) + xx1 * tracer(l,tr)
     enddo
 end do


 if ( do_liq_num ) then
   do l = km1,ic,-1
     xx1 = eta(l) - eta(l+1)
       wlN = wlN + xx1 * qn(l)
   end do
 endif
 
!do cloud base level
     xx1     = 0.5 * cp_by_dp(k) / Cp_Air / onebg
     Dlcu(k) = ( ql(km1) - ql(k) ) * xx1
     Dicu(k) = ( qi(km1) - qi(k) ) * xx1
     Dacu(k) = ( qa(km1) - qa(k) ) * xx1
     if ( do_liq_num ) &
       Dncu(k) = ( qn(km1) - qn(k) ) * xx1
     mccu(k) = eta(k)
     do tr = 1,num_ras_tracers
       dtracercu(k,tr) = ( tracer(km1,tr) - tracer(k,tr) ) * xx1
     enddo

 if ( ic1 <= km1 ) then
   do l = km1,ic1,-1
     xx1     = 0.5 * cp_by_dp(l) / Cp_Air / onebg
     Dlcu(l) = ( eta(l+1) * ( ql(l  ) - ql(l+1) ) + &
                 eta(l  ) * ( ql(l-1) - ql(l  ) ) ) * xx1
     Dicu(l) = ( eta(l+1) * ( qi(l  ) - qi(l+1) ) + &
                 eta(l  ) * ( qi(l-1) - qi(l  ) ) ) * xx1
     Dacu(l) = ( eta(l+1) * ( qa(l  ) - qa(l+1) ) + &
                 eta(l  ) * ( qa(l-1) - qa(l  ) ) ) * xx1
     mccu(l) = eta(l)
     do tr = 1,num_ras_tracers
       dtracercu(l,tr) = ( eta(l+1) * ( tracer(l  ,tr) - tracer(l+1,tr) ) + &
                     eta(l  ) * ( tracer(l-1,tr) - tracer(l  ,tr) ) ) * xx1
     enddo
   end do

   if ( do_liq_num ) then
     do l = km1,ic1,-1
       xx1     = 0.5 * cp_by_dp(l) / Cp_Air / onebg
       Dncu(l) = ( eta(l+1) * ( qn(l  ) - qn(l+1) ) + &
                   eta(l  ) * ( qn(l-1) - qn(l  ) ) ) * xx1
     enddo
   endif
 end if
 

 !do cloud top level
     xx1      = cp_by_dp(ic) / Cp_Air / onebg
     xx2      = 0.5 * xx1
     Dlcu(ic) = ( eta(ic1) * ( ql(ic) - ql(ic1) ) * xx2 ) + &
                ( wll       - eta(ic) * ql(ic)  ) * xx1
     Dicu(ic) = ( eta(ic1) * ( qi(ic) - qi(ic1) ) * xx2 ) + &
                ( wli       - eta(ic) * qi(ic)  ) * xx1
     Dacu(ic) = ( eta(ic1) * ( qa(ic) - qa(ic1) ) * xx2 ) + &
                ( eta(ic)   - eta(ic) * qa(ic)  ) * xx1
     if ( do_liq_num ) &
       Dncu(ic) = ( eta(ic1) * ( qn(ic) - qn(ic1) ) * xx2 ) + &
                  ( wlN       - eta(ic) * qn(ic)  ) * xx1
     do tr = 1,num_ras_tracers
       dtracercu(ic,tr) = ( eta(ic1) * ( tracer(ic,tr) - tracer(ic1,tr) ) * xx2 ) + &
                    ( wlR(tr)      - eta(ic) * tracer(ic,tr)  ) * xx1
     enddo

 end if

 if ( Lmccu .and. .not.Ldacu ) then

 !do cloud base level
     mccu(k) = eta(k)

 if ( ic1 <= km1 ) then
 do l = km1,ic1,-1
   mccu(l) = eta(l)
 end do
 end if

 end if

!=======================================================================
!     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)
!=======================================================================

     xx1      = ( theta(km1) - theta(k) ) / ( pi(k) - pi(km1) )
     hol(k)   = xx1 * ( pi_int(k) - pi(km1) ) * pi(k)   * cp_by_dp(k)
     hol(km1) = xx1 * ( pi(k) - pi_int(k)   ) * pi(km1) * cp_by_dp(km1)
     akm      = 0.0

 if ( ic1 <= km1 ) then
 do l = km1,ic1,-1
     xx1      = ( theta(l-1) - theta(l) ) * eta(l) / ( pi(l) - pi(l-1) )
     hol(l)   = xx1 * ( pi_int(l) - pi(l-1) ) * pi(l)   * cp_by_dp(l) + hol(l)  
     hol(l-1) = xx1 * ( pi(l) - pi_int(l)   ) * pi(l-1) * cp_by_dp(l-1)
     akm      = akm - hol(l)  * ( eta(l)   * ( pi(l  ) - pi_int(l) ) +  &
                                  eta(l+1) * ( pi_int(l+1) - pi(l) ) ) / pi(l)
 end do
 end if

!=======================================================================
!  PARTION CLOUD LIQUID WATER INTO PRECIP & DETRAINED WATER 
!=======================================================================

     xx1 = 0.5 * ( pres_int(ic) + pres_int(ic1) )

! $$$ CALL RAS_RNCL( xx1, rn_frac)
       rn_frac = rn_frac_top
   if ( ( xx1 >= rn_ptop ) .and. ( xx1 <= rn_pbot ) ) then
       rn_frac = ( rn_pbot - xx1 ) * rn_pfac +  rn_frac_bot
   end if
   if ( xx1 > rn_pbot ) then
       rn_frac = rn_frac_bot
   end if

       wdet = ( 1.0 - rn_frac ) * wlq
       wlq  =         rn_frac   * wlq

  if ( Ldacu ) then !detrain non-precipitated fraction of condensed vapor
    
      if (coldT) then
         Dicu(ic) = Dicu(ic) + wdet * cp_by_dp(ic)/Cp_Air/onebg
      else
         Dlcu(ic) = Dlcu(ic) + wdet * cp_by_dp(ic)/Cp_Air/onebg
         if ( do_liq_num ) then
!=======================================================================
!     yim's CONVECTIVE NUCLEATION
!=======================================================================

!Use aerosol at cloud base.

!An assumption which treats ss and oc as sulfate
!convert SO4 to AS
!convert OC to OM
           totalmass(1)=aerosolmass(k,1)
           totalmass(2)=aerosolmass(k,2)
           totalmass(3)=aerosolmass(k,3)
 
           call aer_ccn_act(t(k),p(k),up_conv,totalmass,drop)
           zzl=drop*1.0e6/dens(k)

!YM choose not to do above-cloud activation for the sake of computer time
           if ( ic1 <= km1 ) then
             do l = km1,ic1,-1
               totalmass(1)=aerosolmass(l,1)
               totalmass(2)=aerosolmass(l,2)
               totalmass(3)=aerosolmass(l,3)
 
               tc=thetac(l)*pi(l)
               te=theta(l)*pi(l)
               Nc=zzl/eta(l+1)
 
               call aer_ccn_act2(t(l),p(l),up_conv,totalmass,alm,dens(l),  &
                                 Nc,qc(l),qt(l),qol(l),tc,te,drop)
                                 zzl=zzl+drop*1.0e6/dens(l)*(eta(l)-eta(l+1))
             end do
           end if



           Dncu(ic) = Dncu(ic) + zzl*(1.0-rn_frac)* &
           cp_by_dp(ic)/Cp_Air/onebg
         endif ! end of warm_cloud_aerosol interaction
      end if
          wdet = 0.0

  end if

!=======================================================================
!     CALCULATE GH
!=======================================================================

   xx1 = hol(ic)
 if ( lcase2 ) then
   xx1 = xx1 + ( sic - hic + qol(ic) * Hl ) * ( cp_by_dp(ic) / Cp_Air )
 end if

   hol(ic) = xx1 - ( wdet * Hl * cp_by_dp(ic) / Cp_Air )

 if ( lcase1 ) then
   akm = akm - eta(ic1) * ( pi_int(ic1) - pi(ic) ) * xx1 / pi(ic)
 end if

    xx2    = qol(km1) - qol(k)
    gmh(k) = hol(k) + ( xx2 * cp_by_dp(k) * Hl * 0.5 / Cp_Air )
    akm    = akm + gam(km1) * ( pi_int(k) - pi(km1) ) * gmh(k)

 if ( ic1 <= km1 ) then
 do l = km1,ic1,-1
     xx3    = xx2
     xx2    = ( qol(l-1) - qol(l) ) * eta(l)
     xx3    = xx3 + xx2
     gmh(l) = hol(l) + ( xx3 * cp_by_dp(l) * Hl * 0.5 / Cp_Air )
 end do
 end if

 if ( lcase2 ) then
    xx2 = xx2 + 2.0 * ( hkb - dhic - sic - qol(ic) * Hl ) / Hl
 end if

  gmh(ic) = xx1 + cp_by_dp(ic) * onebcp * ( xx2 * Hl * 0.5 + eta(ic) * dhic )

!=======================================================================
!     CALCULATE HC PART OF AKM
!=======================================================================

 if ( ic1 <= km1 ) then
    xx1 = gmh(k)
 do  l = km1,ic1,-1
   xx1 = xx1 + ( eta(l) - eta(l+1) ) * gmh(l)
   xx2 = gam(l-1) * ( pi_int(l) - pi(l-1) )
   if ( lcase2 .and. ( l == ic1 ) ) xx2 = 0.0
   akm = akm + xx1 * ( xx2 + gam(l) * ( pi(l) - pi_int(l) ) )
 end do
 end if

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

 if ( lcase2 ) then

      xx1 = 0.5*( pres_int(ic  ) + pres_int(ic1) )   &
          + 0.5*( pres_int(ic+2) - pres_int(ic ) ) * ( 1.0 - ftop )
      xx2 =       pres_int(ic1 )
      xx3 = 0.5*( pres_int(ic1 ) + pres_int(ic+2) )

 if ( ( xx1 >= xx2 ) .and. ( xx1 < xx3 ) ) then
        ftop = 1.0 - ( xx1 - xx2 ) / ( xx3 - xx2 )
         xx4 = cp_by_dp(ic1) / cp_by_dp(ic)
    hol(ic1) = hol(ic1) + hol(ic) * xx4
    gmh(ic1) = gmh(ic1) + gmh(ic) * xx4
    hol(ic)  = 0.0
    gmh(ic)  = 0.0
 else if ( xx1 < xx2 ) then
     ftop = 1.0
 else
     ftop = 0.0
 end if

 end if

!=======================================================================
!   MASS FLUX
!=======================================================================
 
 if ( ( akm < 0.0 ) .and. ( wlq >= 0.0 ) ) then
!jjs
  rasalf = rasal * ( pres_int(ic+1) - puplim ) /      &
                   (     psfc       - puplim )
  if (puplim > psfc) rasalf=0.
  rasalf = MAX( 0.0, rasalf )
!jjs
     wfn = -ftop * wfn * rasalf / akm
 else
     wfn = 0.0
 end if

!    xx1 = ( pres_int(k+1) - pres_int(k) ) * frac
     xx1 = ( psfc          - pres_int(k) ) * frac
     wfn = MIN( wfn, xx1 )

!=======================================================================
!     FOR SAK CLOUDS
!=======================================================================

 if ( Ldacu ) then
   xx1 = wfn * onebg
   do l = ic,k
     Dacu(l) = Dacu(l) * xx1
     Dlcu(l) = Dlcu(l) * xx1
     Dicu(l) = Dicu(l) * xx1
     mccu(l) = mccu(l) * xx1
   end do
   if ( do_liq_num ) then
     xx1 = wfn * onebg
     do l = ic,k
       Dncu(l) = Dncu(l) * xx1
     enddo
   endif           

 end if


 if ( LRcu ) then
      xx1 = wfn * onebg
     do l = ic,k
       do tr = 1,num_ras_tracers
          dtracercu(l,tr) = dtracercu(l,tr) * xx1
       end do
     end do
 end if

 if ( Lmccu .and. .not.Ldacu ) then
      xx1 = wfn * onebg
     do l = ic,k
          mccu(l) = mccu(l) * xx1
     end do
 end if
 
!=======================================================================
!     PRECIPITATION
!=======================================================================

   dpcu =  wlq * wfn * onebg

!=======================================================================
!     THETA AND Q CHANGE DUE TO CLOUD TYPE IC
!=======================================================================
 
    xx1 = wfn * onebcp
    xx2 = wfn * ( 1.0 / Hl )

 do l = ic,k
   dtcu(l) = xx1 * hol(l) / pi(l)
   dqcu(l) = xx2 * ( gmh(l) - hol(l) )
 end do

!=======================================================================
!  CUMULUS FRICTION 
!=======================================================================
 if (cufric) then

    xx1 = 0.5 * wfn * onebcp

! --- At cloud base
    xx2    = xx1 * cp_by_dp(k)
    dut    = ( uwnd(km1) - uwnd(k) )
    dvt    = ( vwnd(km1) - vwnd(k) )
   ducu(k) = dut * xx2
   dvcu(k) = dvt * xx2

! --- Between cloud base & cloud top
 do l = km1,ic1,-1
    xx2    = xx1 * cp_by_dp(l)
    dub    = dut
    dvb    = dvt
    dut    = ( uwnd(l-1) - uwnd(l) ) * eta(l)
    dvt    = ( vwnd(l-1) - vwnd(l) ) * eta(l)
   ducu(l) = ( dut + dub ) * xx2
   dvcu(l) = ( dvt + dvb ) * xx2
 end do

! --- At cloud top
    xx2      =   xx1 * cp_by_dp(ic)
    ducu(ic) = ( dut + uht + uht ) * xx2
    dvcu(ic) = ( dvt + vht + vht ) * xx2

  end if

!=======================================================================
  end SUBROUTINE RAS_CLOUD

!#####################################################################
!#####################################################################

  SUBROUTINE COMP_LCL( t_parc, q_parc, p_parc, pres, k_lcl )

!=======================================================================
! ***** COMPUTE LCL ( CLOUD BASE )
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!       t_parc   Initial parcel temperature
!       q_parc   Initial parcel mixing ratio
!       p_parc   Initial parcel pressure
!       pres     Pressure in colunm
!---------------------------------------------------------------------
  real, intent(in), dimension(:,:)   :: t_parc, q_parc, p_parc
  real, intent(in), dimension(:,:,:) :: pres

!---------------------------------------------------------------------
! Arguments (Intent out)
!       k_lcl   Index of LCL in column
!---------------------------------------------------------------------
  integer, intent(out), dimension(:,:) :: k_lcl

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

  real, dimension(size(t_parc,1),size(t_parc,2)) :: &
        qsat, rhum, chi, p_lcl

  integer :: k, kmax, k_lcl_min

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

! --- Index of lowest level
  kmax = size( pres, 3 )

! --- Compute relative humidity
  call compute_qs (t_parc, p_parc, qsat, q = q_parc)
  rhum(:,:) = q_parc(:,:) / qsat(:,:)
  rhum(:,:) = MIN( rhum(:,:), 1.0 )

! --- Compute exponent
   chi(:,:) = t_parc(:,:) / ( 1669.0 - 122.0*rhum(:,:) - t_parc(:,:) )

! --- Compute pressure at LCL
    rhum(:,:) =    chi(:,:) * LOG( rhum(:,:) )
   p_lcl(:,:) = p_parc(:,:) * EXP( rhum(:,:) )

! --- Bound p_lcl 
  p_lcl(:,:) = MAX( p_lcl(:,:), pres(:,:,1) )
  p_lcl(:,:) = MIN( p_lcl(:,:), p_parc(:,:) )

! --- Find index of LCL
  do k = 2,kmax
  where ( ( p_lcl(:,:) >= pres(:,:,k-1) ) .and. &
          ( p_lcl(:,:) <= pres(:,:,k) ) )
     k_lcl(:,:) = k
  end where
  end do

! --- Bound k_lcl
  k_lcl_min  = kmax / 2
  k_lcl(:,:) = MAX( k_lcl(:,:), k_lcl_min )

!=====================================================================
  end SUBROUTINE COMP_LCL

!#######################################################################
!#######################################################################

 SUBROUTINE RAS_CEVAP ( type,     temp,      qvap,   pres,   mass,  &
                        qvap_sat, dqvap_sat, psfc,   hl,     dtime, &
                        ksfc,     dpcu,      dtevap, dqevap, dpevap, &
                        flxprec_ib, flxprec_ib_evap )

!=======================================================================
! EVAPORATION OF CONVECTIVE SCALE PRECIP         
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!     type  - cloud type index
!     temp  - Temperature
!     qvap  - Water vapor
!     pres  - Pressure
!     mass  - Mass of layers
!     qvap_sat - Saturation value of qvap
!     dqvap_sat - Temperature derivative of qvap_sat
!     psfc  - surface presure
!     hl    - proper latent heat for the column
!     dtime - size of time step in seconds
!     ksfc  - index of lowest model level
!     dpcu - Precip in mm
!---------------------------------------------------------------------

  integer, intent(in) :: type
  real,    intent(in) :: dtime

  real,    intent(in), dimension(:) :: temp, qvap, pres, mass
  real,    intent(in), dimension(:) :: qvap_sat, dqvap_sat
  real,    intent(in)               :: psfc, hl, dpcu
  integer, intent(in)               :: ksfc

!---------------------------------------------------------------------
! Arguments (Intent out)
!     dtevap - Temperature change due to precip evap
!     dqevap - Water vapor change due to precip evap
!     dpevap - Amount of precip evaporated
!---------------------------------------------------------------------
  real, intent(out), dimension(:) :: dtevap, dqevap
  real, intent(out)               :: dpevap
  real, intent(out), dimension(:) ::  &
                flxprec_ib,    & ! precipation flux profile for cloud ib
                flxprec_ib_evap  ! evaporaton of precip profile for cloud id
                                 ! [kg/m2/s]

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

  real, parameter :: cem  = 0.054
  real, parameter :: ceta = -544.0E-6

  real, dimension(size(temp,1)) ::  temp_new, qvap_new

  real    :: prec, def, evef
  real    :: prec_mmph, pfac, emx
  integer :: itopp1, kmax, k
  real    :: totalprecip

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

  kmax   = size(temp(:))
  itopp1 = type + 1
  flxprec_ib =0.0
  flxprec_ib_evap =0.0

! --- Initalize
  dpevap   = 0.0
  qvap_new = qvap
  temp_new = temp

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

  do k = itopp1,kmax
!-----------------------------------------

! --- Compute whats available for evaporation 
   prec = MAX(dpcu - dpevap, 0.0 )

! --- Compute precipitation efficiency factor
  prec_mmph = prec * 3600.0 / dtime
  pfac      = SQRT( pres(k) / psfc )
  emx       = SQRT( cem * cfrac * prec_mmph * pfac )   
  evef      = 1.0 - EXP( ceta * dtime * emx ) 
  def=0.

! --- Evaporate precip where needed
  if ( ( hcevap*qvap_sat(k) >= qvap(k) ) .and.  &
          ( prec            > 0.0      ) .and.  &
          ( ksfc            > k        ) ) then
            def = ( hcevap*qvap_sat(k) - qvap(k) ) /    &
                  ( 1.0 + (hl * hcevap * dqvap_sat(k) / Cp_Air ) )
            def = evef*def
            def = MIN( def, prec/mass(k) )
    qvap_new(k) = qvap(k) + def
    temp_new(k) = temp(k) - (def * hl/Cp_Air)
         dpevap = dpevap + def * mass(k)
    flxprec_ib_evap(k) = def * mass(k)/dtime
  end if

!-----------------------------------------
  end do   ! itopp1
!
!-------compute precipitation flux at each model layer
! by deducting the evaporation in each layer  from 
! cloud top to surface/lowest model layer
!

  totalprecip = dpcu         ! precipitation at cloud top
!
  flxprec_ib(type) = MAX(totalprecip,0.0)/dtime
  do k = itopp1,kmax
    flxprec_ib(k) = MAX((totalprecip - flxprec_ib_evap(k)*dtime),0.0)/dtime
    totalprecip =   totalprecip - flxprec_ib_evap(k)*dtime

!-----------------------------------------
  end do


! --- Changes to temperature and water vapor from evaporation
  dtevap(:) = temp_new(:) - temp(:) 
  dqevap(:) = qvap_new(:) - qvap(:) 

!=======================================================================
  end SUBROUTINE RAS_CEVAP

!#######################################################################
!#######################################################################

 SUBROUTINE RAS_CLOUD_INDEX ( ic, ncmax )

!=======================================================================
! Set order in which clouds are to be done                   
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent out)
!       ic      Cloud order index
!       ncmax   Max number of clouds
!---------------------------------------------------------------------
 integer, intent(out), dimension(:) :: ic
 integer, intent(out) :: ncmax

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

 integer :: kmax
 integer :: km1, kcr, kfx, nc, irnd

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

 kmax = size( ic(:) )

 km1   = kmax  - 1
 kcr   = MIN( km1, krmax )
 kfx   = km1 - kcr
 ncmax = kfx + ncrnd

! --- Sequential clouds
  if ( kfx > 0) then
     if ( botop ) then
! --- bottom to top
       do nc = 1,kfx
          ic(nc) = kmax - nc
       end do
     else
! --- top to bottom
       do nc = kfx,1,-1
          ic(nc) = kmax - nc
       end do
     endif
  endif

! --- set non-used clouds to zero
  ic((kfx+1):kmax) = 0

! --- Random clouds
 if ( ncrnd > 0 ) then
     do nc = 1,ncrnd
       irnd      = ( RAN0(iseed) - 0.0005 ) * ( kcr - krmin + 1 )
       ic(kfx+nc) = irnd + krmin
     end do
  endif

!=======================================================================
  end SUBROUTINE RAS_CLOUD_INDEX 

!#####################################################################
!#####################################################################


 SUBROUTINE RAS_CLOUD_EXIST( k,      qvap,   qsat, theta,    &
                             pifull, pihalf, nc,   ncmax,    &
                             Hl,     exist  )
!=======================================================================
 implicit none
!=======================================================================

 integer, intent(in)               :: k, ncmax
 real,    intent(in)               :: Hl
 integer, intent(in), dimension(:) :: nc 
 real,    intent(in), dimension(:) :: qvap, qsat, theta, pifull, pihalf 

 logical, intent(out) :: exist

!---------------------------------------------------------------------
 real, parameter :: rhmax  = 0.9999 

 real, dimension(size(theta(:))) :: ssl, hst
 real                         :: zzl, hol_k, qol_k
 integer                      :: km1, ic, ic1, l

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

 ic  = MINVAL( nc(1:ncmax) )

 km1 = k  - 1
 ic1 = ic + 1

! --- at cloud base
    qol_k = MIN( qsat(k) * rhmax, qvap(k) )
    ssl(k) = pihalf(k+1) * theta(k) * Cp_Air 
    hol_k  = ssl(k) +  qol_k  * Hl
    hst(k) = ssl(k) + qsat(k) * Hl
    zzl    = ( pihalf(k+1) - pihalf(k) ) * theta(k) * Cp_Air

! --- between cloud base & cloud top
 do l = km1,ic1,-1
    ssl(l) = zzl + pihalf(l+1) * theta(l) * Cp_Air 
    hst(l) = ssl(l) + qsat(l) * Hl
    zzl    = zzl + ( pihalf(l+1) - pihalf(l) ) * theta(l) * Cp_Air    
 end do

! --- at cloud top
    ssl(ic) = zzl  + pihalf(ic1) * theta(ic) * Cp_Air 
    hst(ic) = ssl(ic) + qsat(ic) * Hl

! --- test
    exist = hol_k > MINVAL( hst(ic:k) )

!=======================================================================
 end SUBROUTINE RAS_CLOUD_EXIST

!#####################################################################
!#####################################################################

  SUBROUTINE RAS_BDGT ( precip, coldT, dtemp, dqvap, duwnd, dvwnd, &
                        pres_int, dql, dqi)

!=====================================================================
! ***** BUDGET CHECK FOR RAS - A DEBUGGING TOOL
!=====================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!       precip   - either rain or snow
!       coldT    - is the precip snow?
!       dtemp    - Temperature change 
!       dqvap    - Water vapor change 
!       duwnd    - U wind change 
!       dvwnd    - V wind change 
!       pres_int - Pressure at layer interface
!       dql      - OPTIONAL, liquid change
!       dqi      - OPTIONAL, ice change
!---------------------------------------------------------------------
  real, intent(in), dimension(:,:,:) :: dtemp, dqvap, duwnd, dvwnd, pres_int
  real, intent(in), dimension(:,:)   :: precip
  logical, intent(in), dimension(:,:):: coldT
  real, intent(in), optional, dimension(:,:,:) :: dql, dqi
!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------

 integer :: imax, jmax, kmax, i, j, k
 real    :: sum_dtemp, sum_dqvap, sum_duwnd, sum_dvwnd
 real    :: dqvap_prec, dqvap_dtemp
 real , dimension(size(dtemp,1),size(dtemp,2),size(dtemp,3)) :: mass
 
!=====================================================================

  imax = size ( dtemp, 1 )
  jmax = size ( dtemp, 2 )
  kmax = size ( dtemp, 3 )

  mass(:,:,1:kmax) = pres_int(:,:,2:kmax+1) - pres_int(:,:,1:kmax)
  mass = mass / Grav

  do j = 1,jmax
  do i = 1,imax

    sum_dtemp = 0.                                                          
    sum_dqvap = 0. 
    sum_duwnd = 0. 
    sum_dvwnd = 0. 

  do k = 1,kmax
    sum_dtemp = sum_dtemp + dtemp(i,j,k)*mass(i,j,k)                                   
    sum_dqvap = sum_dqvap + dqvap(i,j,k)*mass(i,j,k)  
    sum_duwnd = sum_duwnd + duwnd(i,j,k)*mass(i,j,k)  
    sum_dvwnd = sum_dvwnd + dvwnd(i,j,k)*mass(i,j,k)
  end do

    dqvap_prec  = sum_dqvap + precip(i,j)
     
    if (present(dql)) then
  do k = 1,kmax
    dqvap_prec = dqvap_prec + (dql(i,j,k)+dqi(i,j,k))*mass(i,j,k)      
  end do
    end if  

     if (coldT(i,j)) then
     dqvap_dtemp = sum_dqvap + Cp_Air*sum_dtemp/HLs
     else
     dqvap_dtemp = sum_dqvap + Cp_Air*sum_dtemp/HLv
     end if

   if ( ( abs( dqvap_prec  ) > 1.0E-4 ) .or.     &
        ( abs( dqvap_dtemp ) > 1.0E-4 ) .or.     &
        ( abs( sum_duwnd   ) > 1.0E-1 ) .or.     &      
        ( abs( sum_dvwnd   ) > 1.0E-1 ) )  then
    print *
    print *, ' RAS BUDGET CHECK AT i,j = ', i,j
    print *, ' dqvap + (Cp_Air/hl)*dtemp = ',  dqvap_dtemp                                                                     
    print *, ' dqvap + precip        = ',  dqvap_prec                                                                     
    print *, ' duwnd                 = ',  sum_duwnd                                                                    
    print *, ' dvwnd                 = ',  sum_dvwnd                                                                     
    print *, 'STOP'
!    STOP
   CALL ERROR_MESG( 'RAS_BDGT', 'RAS budget thresholds exceeded.', FATAL )
   endif

  end do
  end do

!=====================================================================
  end SUBROUTINE RAS_BDGT

!#######################################################################
!#######################################################################

FUNCTION ran0(idum)


!     $Id: ras.F90,v 17.0.2.1.4.1.2.1.2.1.2.2 2010/09/13 16:04:08 wfc Exp $
!     Platform independent random number generator from
!     Numerical Recipies
!     Mark Webb July 1999
      
      REAL :: ran0
      INTEGER, INTENT (INOUT) :: idum
      
      INTEGER :: IA,IM,IQ,IR,k
      REAL :: AM

      IA=16807; IM=2147483647; AM=1.0/IM; IQ=127773; IR=2836
      
      if (idum.eq.0) then
        CALL ERROR_MESG( 'ran0', 'idum=0, ZERO seed not allowed.', FATAL )
      endif

      k=idum/IQ
      idum=ia*(idum-k*iq)-ir*k
      if (idum.lt.0) idum=idum+im
      ran0=am*idum

END FUNCTION ran0

!#######################################################################
!#######################################################################
  end MODULE RAS_MOD



module rh_clouds_mod

!=======================================================================
!
!                          RH_CLOUDS MODULE
!
!=======================================================================

use mpp_mod, only : input_nml_file
use fms_mod, only : error_mesg, FATAL, file_exist,    &
                    check_nml_error, open_namelist_file,       &
                    close_file, open_restart_file, &
                    read_data, write_data, mpp_pe, mpp_root_pe, &
                    write_version_number, stdlog

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

implicit none
private

public  rh_clouds, rh_clouds_init, rh_clouds_end,  &
        rh_clouds_sum, rh_clouds_avg, do_rh_clouds

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

!
!  The public interface in this module are RH_CLOUDS_INIT 
!                                          RH_CLOUDS
!                                          
!  SUBROUTINE RH_CLOUDS_INIT
!  -- no input or output -- initializes module by reading namelist 
!  
!  SUBROUTINE RH_CLOUDS(RH, P_FULL, P_SURF, ZENITH, DEG_LAT,
!          N_CLOUD, TOP, BOT, CLDAMT,
!          ALB_UV,ALB_NIR,ABS_UV,ABS_NIR,EMISS)
!
!  input -- 
!
!     real, rh(:,:,:)     -- relative humidity(nlon,nlat,nlev)  
!                            third index runs from top of atmosphere to bottom 
!     real, p_full(:,:,:) -- pressure(nlon, nlat, nlev) at rh levels 
!     real, p_surf(:,:)   -- surface pressure(nlon,nlat)
!                            p_full and p_surf must be in same units
!     real, zenith(:,:)   -- cosine of zenith angle (nlon, nlat) 
!     real, deg_lat(:)    -- latitude in degrees (nlon,nlat) 
!
!  output --
!
!     integer, n_cloud(:,:)  -- number of distinct clouds (nlon, nlat)
!                  
!     integer, top(:,:,:) -- 
!     integer, bot(:,:,:) -- (nlon,nlat,max) --  max must be
!                            larger than any value of n_cloud 
!                            max = (size(rh,3)+1)/2 is safe
!                            the n'th cloud at horizontal location i,j
!                            fills the levels from top(i,j,n) to bot(i,j,n)
!                            inclusive (i.e., if the cloud is only one 
!                            level thick, then top = bot)
!                            cloud numbering starts from top of atmosphere
!     real, cldamt       --  horizontal area covered by nth cloud
!                            each cloud covers total area currently
!                            (i.e. cldamt = 1.)
!
!     real, alb_uv(:,:,:) -- (lon, lat, max)
!                            short wave albedo for each cloud
!     real, alb_nir(:,:,:) - near infrared albedo for each cloud
!     real, abs_uv(:,:,:) -- (lon, lat, max)
!                            short wave absorption coeff for each cloud = 0
!     real, abs_nir(:,:,:) - near infrared absorption coeff for each cloud
!     real, emiss(:.:.:) --(lon, lat, max)
!                        infrared emissivity for each cloud
!=======================================================================
!----------------- data for rh averaging code --------------------------

    real,    allocatable, dimension (:,:,:) :: rhsum
    integer, allocatable, dimension (:,:)   :: nsum

!-----------------------------------------------------------------------

interface rh_clouds
    module procedure  rh_clouds_3d, rh_clouds_2d, rh_clouds_1d
end interface

!--------------------- version number ----------------------------------

character(len=128) :: version = '$Id: rh_clouds.F90,v 17.0.4.1 2010/08/30 20:33:31 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

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

!  DEFAULT VALUES OF NAMELIST PARAMETERS:

! sigma coordinate boundary between high and middle clouds varies linearly
!   in latitude between high_middle_pole at the pole and high_middle_eq
!   at the equator, and similarly for the boundary between middle and low
!   clouds

real :: high_middle_pole = 0.7
real :: high_middle_eq   = 0.4
real :: middle_low_pole  = 0.85
real :: middle_low_eq    = 0.7

! cloud is present when relative humidity >= rh_crit, which varies liearly
!   in sigma from rh_crit_top at sigma = 0 to rh_crit_bot at sigma = 1

real :: rh_crit_bot    = 1.00
real :: rh_crit_top    = 0.90


!  near infrared absorption coeffs 

real :: high_abs    = 0.04
real :: middle_abs  = 0.30
real :: low_abs     = 0.40

! infrared emissivities

real :: high_emiss    = 0.6
real :: middle_emiss  = 1.0
real :: low_emiss     = 1.0

real :: tuning_coeff_low_cld = 1.0

!  flag for time averaging rh

logical :: do_average = .false.
logical :: do_mcm_no_clouds_top = .false.
logical :: do_mcm_crit_rh = .false.

! albedos are computed from a table look-up as function of zenith angle

namelist /rh_clouds_nml/ high_middle_pole, high_middle_eq, &
                         middle_low_pole , middle_low_eq, &
                         rh_crit_bot, rh_crit_top, &
                         high_abs, middle_abs, low_abs, &
                         high_emiss, middle_emiss, low_emiss, &
                         do_average, tuning_coeff_low_cld, &
                         do_mcm_no_clouds_top, do_mcm_crit_rh

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

!  OTHER MODULE VARIABLES

logical :: module_is_initialized = .false.

contains

!#######################################################################

subroutine rh_clouds_init (nlon, nlat, nlev)

integer, intent(in) :: nlon, nlat, nlev

integer :: unit, ierr, io, logunit

      if (module_is_initialized) return

!------------------- read namelist input -------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=rh_clouds_nml, iostat=io)
      ierr = check_nml_error(io,'rh_clouds_nml')
#else   
      if (file_exist('input.nml')) then
         unit = open_namelist_file ()
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=rh_clouds_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'rh_clouds_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist to log-------------------------------------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit, nml=rh_clouds_nml)
      endif

!---------- initialize for rh cloud averaging -------------------------

      allocate (rhsum(nlon,nlat,nlev), nsum(nlon,nlat))

      if (file_exist('INPUT/rh_clouds.res')) then
           unit = open_restart_file ('INPUT/rh_clouds.res', action='read')
           call read_data (unit, nsum)
           call read_data (unit, rhsum)
           call close_file (unit)
      else
           rhsum = 0.0;  nsum = 0
      endif


      module_is_initialized = .true.

!-----------------------------------------------------------------------

end subroutine rh_clouds_init

!#######################################################################

subroutine rh_clouds_end

 integer :: unit

    unit = open_restart_file ('RESTART/rh_clouds.res', action='write')
    call write_data (unit, nsum)
    call write_data (unit, rhsum)
    call close_file (unit)
    module_is_initialized = .false.

end subroutine rh_clouds_end

!#######################################################################

 function do_rh_clouds ( ) result (answer)
   logical :: answer

!  returns logical value for whether rh_clouds has been initialized
!  presumably if initialized then rh_cloud will be used

   answer = module_is_initialized

 end function do_rh_clouds

!#######################################################################

 subroutine rh_clouds_sum (is, js, rh)

!-----------------------------------------------------------------------
   integer, intent(in)                   :: is, js
      real, intent(in), dimension(:,:,:) :: rh
!-----------------------------------------------------------------------
   integer :: ie, je

   ie = is + size(rh,1) - 1
   je = js + size(rh,2) - 1

!--------- use time-averaged or instantaneous clouds -----------

   if (do_average) then
       nsum(is:ie,js:je)   =  nsum(is:ie,js:je)   +  1
      rhsum(is:ie,js:je,:) = rhsum(is:ie,js:je,:) + rh(:,:,:)
   else
       nsum(is:ie,js:je)   =  1
      rhsum(is:ie,js:je,:) = rh(:,:,:)
   endif

!-----------------------------------------------------------------------

 end subroutine rh_clouds_sum

!#######################################################################

 subroutine rh_clouds_avg (is, js, rh, ierr)

!-----------------------------------------------------------------------
   integer, intent(in)                    :: is, js
      real, intent(out), dimension(:,:,:) :: rh
   integer, intent(out)                   :: ierr
!-----------------------------------------------------------------------
   integer ::ie, je, num, k
!-----------------------------------------------------------------------

   if (size(rh,3) .ne. size(rhsum,3)) call error_mesg ( &
                              'rh_clouds_avg in rh_clouds_mod',  &
                              'input argument has the wrong size',FATAL)

   ie = is + size(rh,1) - 1
   je = js + size(rh,2) - 1
   num = count(nsum(is:ie,js:je) == 0)

   if (num > 0) then

!     ----- no average, return error flag -----

!!!    call error_mesg ('rh_clouds_avg in rh_clouds_mod',  &
!!!                     'dividing by a zero counter', FATAL)
       ierr = 1

   else

!      ----- compute average -----

       do k = 1, size(rh,3)
          rh(:,:,k) = rhsum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
       enddo
       ierr = 0

   endif

    nsum(is:ie,js:je)   = 0
   rhsum(is:ie,js:je,:) = 0.0
     
!-----------------------------------------------------------------------

 end subroutine rh_clouds_avg

!#######################################################################

subroutine rh_clouds_3d(rh, p_full, p_surf, zenith, deg_lat,&
            n_cloud,top,bot,cldamt,alb_uv,alb_nir,abs_uv,abs_nir,emiss)

real   , intent(in) , dimension(:,:,:)   :: rh, p_full
real   , intent(in) , dimension(:,:)     :: p_surf, zenith, deg_lat
integer, intent(out), dimension(:,:,:)   :: top, bot
integer, intent(out), dimension(:,:)     :: n_cloud
real   , intent(out), dimension(:,:,:)   :: cldamt,emiss
real   , intent(out), dimension(:,:,:)   :: alb_uv,alb_nir,abs_uv,abs_nir


integer :: i, j, k, n, nlev, max_n_cloud
real   , dimension(size(rh,1),size(rh,2))            :: rh_crit
logical, dimension(size(rh,1),size(rh,2),size(rh,3)) :: cloud
real, dimension(size(rh,1),size(rh,2),2) ::  high_alb, middle_alb, low_alb
real, dimension(size(rh,1),size(rh,2)) :: high_middle, middle_low
real :: sig_bot

! dummy checks

 if (.not.module_is_initialized) call error_mesg( 'RH_CLOUDS in RH_CLOUD        S_MOD', &
        'module not initialized', FATAL)
 if (size(zenith,1).ne.size(rh,1)) &
              call error_mesg( 'RH_CLOUDS in RH_CLOUDS_MOD', &
             'dimensions of zenith and top do not match', FATAL)
 if (size(zenith,2).ne.size(rh,2)) &
              call error_mesg( 'RH_CLOUDS in RH_CLOUDS_MOD', &
             'dimensions of zenith and top do not match', FATAL)
 if (size(deg_lat,1).ne.size(rh,1)) &
              call error_mesg( 'RH_CLOUDS in RH_CLOUDS_MOD', &
             'dimension of deg_lat and top do not match', FATAL)
 if (size(deg_lat,2).ne.size(rh,2)) &
              call error_mesg( 'RH_CLOUDS in RH_CLOUDS_MOD', &
             'dimension of deg_lat and top do not match', FATAL)

cloud = .false.
nlev  = size(rh,3)

do k = 1, nlev
  if ( do_mcm_crit_rh ) then
    rh_crit = rh_crit_top + (rh_crit_bot - rh_crit_top)*p_full(:,:,k)/p_full(:,:,nlev)
  else
    rh_crit = rh_crit_top + (rh_crit_bot - rh_crit_top)*p_full(:,:,k)/p_surf
  endif
  where(rh(:,:,k) >= rh_crit) cloud(:,:,k) = .true.
enddo

if ( do_mcm_no_clouds_top ) cloud(:,:,1) = .false.

n_cloud = 0

do j = 1, size(rh,2)
  do i = 1, size(rh,1)
    if(cloud(i,j,1)) then
      n_cloud(i,j) = 1
      top(i,j,n_cloud(i,j)) = 1
    end if
    do k = 2, nlev
      if(.not.cloud(i,j,k).and.cloud(i,j,k-1)) then
         bot(i,j,n_cloud(i,j)) = k-1
      else if(cloud(i,j,k).and..not.cloud(i,j,k-1)) then
        n_cloud(i,j) = n_cloud(i,j) + 1
        top(i,j,n_cloud(i,j)) = k
      end if
    end do
    if(cloud(i,j,nlev)) bot(i,j,n_cloud(i,j)) = nlev
  end do
end do

max_n_cloud = maxval(n_cloud)
if(size(top,3).lt.max_n_cloud) call error_mesg( 'RH_CLOUDS in RH_CLOUDS_MOD',&
             'third dimension of top not large enough', FATAL)
call cloud_bounds(high_middle, middle_low, deg_lat)
call cloud_albedo(zenith, high_alb, middle_alb, low_alb)


abs_uv(:,:,:) = 0.0

do j = 1, size(top,2)
  do i = 1, size(top,1)
    do n = 1, n_cloud(i,j)


      !set cloud amount
      cldamt(i,j,n) = 1.

      sig_bot = p_full(i,j,bot(i,j,n))/p_surf(i,j)
      
      !guarantee some transmission to the clouds
      !by reducing the actual cloud reflectance in uv and nir band
      ! this break is necessary to avoid the rest of the
      ! radiation code from breaking up.
      if (sig_bot.le.high_middle(i,j)) then      ! high cloud   !
        alb_uv(i,j,n) = high_alb(i,j,1)
        alb_nir(i,j,n) = high_alb(i,j,2)
        abs_nir(i,j,n) = MIN(0.99-alb_nir(i,j,n),high_abs)
        emiss(i,j,n) = high_emiss

      elseif (sig_bot.gt.high_middle(i,j) .and. &
                sig_bot.le.middle_low(i,j))  then  ! middle cloud !
        alb_uv(i,j,n) = middle_alb(i,j,1)
        alb_nir(i,j,n) = middle_alb(i,j,2)
        abs_nir(i,j,n) = MIN(0.99-alb_nir(i,j,n),middle_abs)
        emiss(i,j,n) = middle_emiss

      elseif (sig_bot.gt.middle_low(i,j))  then  ! low cloud    !
        alb_uv(i,j,n) = low_alb(i,j,1)
        alb_nir(i,j,n) = low_alb(i,j,2)
        abs_nir(i,j,n) = MIN(0.99-alb_nir(i,j,n),low_abs)
        emiss(i,j,n) = low_emiss

      endif
        
    end do
  end do
end do

end subroutine rh_clouds_3d

!#######################################################################

subroutine cloud_albedo(zenith, high, middle, low)

real, intent(in), dimension(:,:)    :: zenith
real, intent(out), dimension(:,:,:) :: high, middle, low

integer, parameter :: num_angles = 17
integer, parameter :: num_bands  = 2

real, dimension(num_angles, 2) :: high_cloud, middle_cloud, low_cloud
real, dimension(num_angles, 2) :: low_cloud_tun

real, dimension(size(zenith,1),size(zenith,2)) :: z

real    :: pi, del, x, r
integer :: n, i, j, ind
integer :: n1, n2

! high cloud albedos for zenith angles from 0-80 deg. every 5 degs.
!    first for band =1, then band = 2

data high_cloud  &
 /.04,.05,.05,.05,.06,.06,.07,.07,.08,.11,.13,.16,.21,.28,.39,.48,.61, &
  .04,.05,.05,.05,.06,.06,.07,.07,.08,.10,.11,.14,.19,.26,.35,.44,.55/

! middle cloud albedos 

data middle_cloud &
 /.18,.18,.19,.20,.21,.23,.24,.26,.29,.33,.37,.42,.47,.55,.64,.71,.79, &
  .14,.14,.15,.16,.17,.18,.18,.20,.23,.25,.29,.32,.37,.43,.50,.55,.61/

! low cloud albedos 

data low_cloud &
 /.50,.50,.51,.51,.52,.53,.54,.56,.58,.62,.65,.67,.69,.73,.78,.82,.86, &
  .42,.42,.43,.43,.44,.45,.46,.48,.50,.52,.55,.57,.59,.63,.66,.70,.74/

pi = 4.0*atan(1.0)
z  = acos(zenith)*180.0/pi
del = 90.0/float(num_angles+1)

  do n1 = 1,num_angles
    do n2 = 1,num_bands
      low_cloud_tun(n1,n2) = tuning_coeff_low_cld*low_cloud(n1,n2)
    end do
  end do

! if zenith angle >= 80 degrees, use albedos for zenith angle = 80
do j = 1, size(zenith,2)
  do i = 1, size(zenith,1)
    if (z(i,j) .ge. 80.0) then
      do n = 1,num_bands
          high(i,j,n) =   high_cloud(num_angles,n)
        middle(i,j,n) = middle_cloud(num_angles,n)
           low(i,j,n) = low_cloud_tun(num_angles,n)
      end do
    else
      x = z(i,j)/del
      ind = floor(x)
      r = x - ind
      ind = ind + 1
      do n = 1,num_bands
          high(i,j,n) =   high_cloud(ind,n) &
                   + r*(  high_cloud(ind+1,n) -   high_cloud(ind,n))
        middle(i,j,n) = middle_cloud(ind,n) &
                   + r*(middle_cloud(ind+1,n) - middle_cloud(ind,n))
           low(i,j,n) =    low_cloud_tun(ind,n) &
                   + r*(   low_cloud_tun(ind+1,n) - low_cloud_tun(ind,n))
      end do
    end if
  end do
end do


end subroutine cloud_albedo

!#######################################################################

subroutine cloud_bounds(high_middle, middle_low, deg_lat)

real, intent(in) , dimension(:,:) :: deg_lat
real, intent(out), dimension(:,:) :: high_middle, middle_low

real,dimension(size(deg_lat,1),size(deg_lat,2)) :: x

   x = (90.0 - abs(deg_lat))/90.

   high_middle = high_middle_pole + x*(high_middle_eq - high_middle_pole)
   middle_low  = middle_low_pole  + x*(middle_low_eq  - middle_low_pole )

return
end subroutine cloud_bounds


!#######################################################################
!  THE FOLLOWING CODE ALLOWS RH_CLOUDS TO BE USED IN 2D AND 1D MODELS
!#######################################################################

subroutine rh_clouds_2d(rh, p_full, p_surf, zenith, deg_lat,&
            n_cloud,top,bot,cldamt,alb_uv,alb_nir,abs_uv,abs_nir,emiss)

real   , intent(in) , dimension(:,:)   :: rh, p_full
real   , intent(in) , dimension(:)     :: p_surf,zenith,deg_lat
integer, intent(out), dimension(:,:)   :: top, bot
integer, intent(out), dimension(:)     :: n_cloud
real   , intent(out), dimension(:,:)   :: cldamt,alb_uv,alb_nir,abs_uv
real   , intent(out), dimension(:,:)   :: abs_nir,emiss

real, dimension(1, size(rh,1),size(rh,2)) :: rh_3d, p_full_3d
real, dimension(1, size(rh,1)           ) :: p_surf_3d, zenith_3d,deg_lat_3d
real, dimension(1, size(rh,1),size(rh,2)) :: cldamt_3d,alb_uv_3d,alb_nir_3d
real, dimension(1, size(rh,1),size(rh,2)) :: abs_uv_3d,abs_nir_3d,emiss_3d
integer, dimension(1, size(rh,1), size(rh,2)) :: top_3d, bot_3d
integer, dimension(1, size(rh,1)        ) :: n_cloud_3d

!assign variables to 3d matrices
rh_3d(1,:,:) = rh
p_full_3d(1,:,:) = p_full
p_surf_3d(1,:) = p_surf
zenith_3d(1,:) = zenith
deg_lat_3d(1,:) = deg_lat

call rh_clouds_3d(rh_3d, p_full_3d, p_surf_3d, zenith_3d, deg_lat_3d,&
   n_cloud_3d,top_3d,bot_3d,cldamt_3d,alb_uv_3d,alb_nir_3d,abs_uv_3d,&
   abs_nir_3d,emiss_3d)

!patch back results to 2d matrices
n_cloud = n_cloud_3d(1,:)
top = top_3d(1,:,:)
bot = bot_3d(1,:,:)
cldamt = cldamt_3d(1,:,:)
alb_uv = alb_uv_3d(1,:,:)
alb_nir = alb_nir_3d(1,:,:)
abs_uv = abs_uv_3d(1,:,:)
abs_nir = abs_nir_3d(1,:,:)
emiss = emiss_3d(1,:,:)

end subroutine rh_clouds_2d

!#######################################################################

subroutine rh_clouds_1d(rh, p_full, p_surf, zenith, deg_lat,&
            n_cloud,top,bot,cldamt,alb_uv,alb_nir,abs_uv,abs_nir,emiss)

real   , intent(in) , dimension(:)   :: rh, p_full
real   , intent(in)                  :: p_surf,zenith,deg_lat
integer, intent(out), dimension(:)   :: top, bot
integer, intent(out)                 :: n_cloud
real   , intent(out), dimension(:)   :: cldamt,alb_uv,alb_nir,abs_uv
real   , intent(out), dimension(:)   :: abs_nir,emiss

real, dimension(1, 1,size(rh(:))) :: rh_3d, p_full_3d
real, dimension(1, 1            ) :: p_surf_3d, zenith_3d,deg_lat_3d
real, dimension(1, 1,size(rh(:))) :: cldamt_3d,alb_uv_3d,alb_nir_3d
real, dimension(1, 1,size(rh(:))) :: abs_uv_3d,abs_nir_3d,emiss_3d
integer, dimension(1, 1, size(rh(:))) :: top_3d, bot_3d
integer, dimension(1, 1             ) :: n_cloud_3d

!assign variables to 3d matrices
rh_3d(1,1,:) = rh
p_full_3d(1,1,:) = p_full
p_surf_3d(1,1) = p_surf
zenith_3d(1,1) = zenith
deg_lat_3d(1,1) = deg_lat

call rh_clouds_3d(rh_3d, p_full_3d, p_surf_3d, zenith_3d, deg_lat_3d,&
   n_cloud_3d,top_3d,bot_3d,cldamt_3d,alb_uv_3d,alb_nir_3d,abs_uv_3d,&
   abs_nir_3d,emiss_3d)

!patch back results to 2d matrices
n_cloud = n_cloud_3d(1,1)
top = top_3d(1,1,:)
bot = bot_3d(1,1,:)
cldamt = cldamt_3d(1,1,:)
alb_uv = alb_uv_3d(1,1,:)
alb_nir = alb_nir_3d(1,1,:)
abs_uv = abs_uv_3d(1,1,:)
abs_nir = abs_nir_3d(1,1,:)
emiss = emiss_3d(1,1,:)

end subroutine rh_clouds_1d


!#######################################################################



end module rh_clouds_mod



                    module aerosol_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!  smf
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Code to initialize/allocate aerosol climatology
! </OVERVIEW>
! <DESCRIPTION>
!  This code initializes prescribed aerosol climatology from input file,
!  allocates necessary memory space and interpolate the aerosol climatology
!  to the model specification. Afterwards the memory space is deallocated,
!  the aerosol climatology information is freed.
! </DESCRIPTION>
!  shared modules:

use time_manager_mod,  only: time_type, time_manager_init, operator(+),&
                             set_date, operator(-), print_date, &
                             assignment(=), &
                             set_time, days_in_month, get_date, &
                             operator(>), operator(/=)
use diag_manager_mod,  only: diag_manager_init, get_base_time, &
                             send_data, register_diag_field,  &
                             register_static_field
use field_manager_mod, only: MODEL_ATMOS
use tracer_manager_mod,only: get_tracer_index,   &
                             get_tracer_names,   &
                             get_tracer_indices, &
                             get_number_tracers, &
                             MAX_TRACER_FIELDS,  &
                             query_method
use mpp_mod,           only: input_nml_file
use fms_mod,           only: open_namelist_file, fms_init, &
                             mpp_pe, mpp_root_pe, stdlog, &
                             file_exist, write_version_number, &
                             check_nml_error, error_mesg, &
                             FATAL, NOTE, WARNING, close_file
use interpolator_mod,  only: interpolate_type, interpolator_init, &
                             interpolator, interpolator_end, &
                             obtain_interpolator_time_slices, &    
                             unset_interpolator_time_flag, &
                             CONSTANT, INTERP_WEIGHTED_P
use mpp_io_mod,        only: mpp_open, mpp_close, MPP_RDONLY,   &
                             MPP_ASCII, MPP_SEQUENTIAL, MPP_MULTI,  &
                             MPP_SINGLE, mpp_io_init
use constants_mod,     only: constants_init, RADIAN, GRAV

!  shared radiation package modules:

use   rad_utilities_mod, only  : aerosol_type, rad_utilities_init, &
                                 get_radiative_param,              &
                                 atmos_input_type     

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    aersosol_mod provides aerosol information that is needed by a
!    model physics package. the initial use of aerosol_mod was to
!    provide climatological aerosol fields to the model radiation 
!    package for use in calculating radiative fluxes and heating rates; 
!    with the introduction of predicted aerosols as members of the 
!    model's tracer array, aerosol_mod became the mechanism to collect
!    and bundle those tracers which were to be seen as aerosol by the
!    radiation code. the introduction of the treatment of aerosol 
!    impacts on cloud properties (aerosol indirect effect) required that
!    aerosol_mod be modified to provide needed aerosol information to 
!    routines involved with cloud calculation.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128) :: version = '$Id: aerosol.F90,v 18.0.2.1 2010/08/30 20:39:46 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


!-----------------------------------------------------------------------
!------  interfaces -------

public          &
        aerosol_init, aerosol_driver, aerosol_end, &
        aerosol_time_vary, aerosol_endts, aerosol_dealloc

!private         &


!---------------------------------------------------------------------
!------  namelist ------

 character(len=32)      ::      &
         aerosol_data_source = 'climatology'
                                   ! source of aerosol data, either
                                   ! 'climatology' file (default) or
                                   ! single column 'input' file or
                                   ! calculate a column for location and
                                   ! time specified ('calculate_column')
                                   ! or 'predicted' (calculated online)
integer, parameter     ::      &
        MAX_DATA_FIELDS = 100     ! maximum number of aerosol species
integer, parameter     ::      &
        MAX_AEROSOL_FAMILIES = 12 ! maximum number of aerosol families
character(len=64)      ::      &
        data_names(MAX_DATA_FIELDS) = '  ' 
                                  ! names of active aerosol species 
character(len=64)      ::      &
        filename = '  '           ! name of netcdf file containing 
                                  ! aerosol species to be activated
character(len=64)      ::      &
      family_names(MAX_AEROSOL_FAMILIES) = '  ' 
                                  ! names of active aerosol families 
logical, dimension(MAX_DATA_FIELDS) :: in_family1 = .false.
                                  ! aerosol n is in family 1 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family2 = .false.
                                  ! aerosol n is in family 2 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family3 = .false.
                                  ! aerosol n is in family 3 ?
logical,dimension(MAX_DATA_FIELDS) :: in_family4 = .false.
                                  ! aerosol n is in family 4 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family5 = .false.
                                  ! aerosol n is in family 5 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family6 = .false.
                                  ! aerosol n is in family 6 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family7 = .false.
                                  ! aerosol n is in family 7 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family8 = .false.
                                  ! aerosol n is in family 8 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family9 = .false.
                                  ! aerosol n is in family 9 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family10 = .false.
                                  ! aerosol n is in family 10 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family11 = .false.
                                  ! aerosol n is in family 11 ?
logical, dimension(MAX_DATA_FIELDS) :: in_family12 = .false.
                                  ! aerosol n is in family 12 ?
logical         :: use_aerosol_timeseries = .false.
                                  ! use a timeseries providing inter-
                                  ! annual aerosol variation ?
logical, dimension(MAX_DATA_FIELDS) :: time_varying_species = .true.
                                  ! this aerosol species is 
                                  ! time-varying  ?
integer, dimension(6,MAX_DATA_FIELDS) :: aerosol_dataset_entry  =  1
                      ! time in aerosol data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
logical, dimension(MAX_AEROSOL_FAMILIES) ::   &
                                    volc_in_fam_col_opt_depth = .false.
                      ! is the volcanic contribution to column optical
                      ! depth to be included for this family in the
                      ! netcdf output fields ?
real,dimension(2)   :: lonb_col = (/-999., -999./)
                      ! longitudes defining the region to use for column
                      ! data calculation
real,dimension(2)   :: latb_col = (/-999., -999./)
                      ! latitudes defining the region to use for column
                      ! data calculation
integer, dimension(6)  :: time_col = (/0,0,0,0,0,0/)
                      ! time to use for column data calculation


namelist /aerosol_nml/                            &
                           aerosol_data_source,   &
                           lonb_col, latb_col, time_col, &
                           data_names, filename,  &
                           family_names,   &
                           use_aerosol_timeseries, &
                           time_varying_species,  &
                           aerosol_dataset_entry,  &               
                           in_family1, in_family2, in_family3, &
                           in_family4, in_family5, in_family6, &
                           in_family7, in_family8, in_family9, &
                           in_family10, in_family11, in_family12, &
                           volc_in_fam_col_opt_depth
                           

!---------------------------------------------------------------------
!---- public data ----


!---------------------------------------------------------------------
!---- private data ----


!-------------------------------------------------------------------
!    specified_aerosol contains the column input aerosol concentration
!    ratio (kg/m**2).  used when aerosol_data_source = 'input'.
!-------------------------------------------------------------------
real, dimension (:), allocatable     ::  specified_aerosol
 
!---------------------------------------------------------------------
!   the following is an interpolate_type variable containing the
!   information about the aerosol species.
!---------------------------------------------------------------------
type(interpolate_type), dimension(:), allocatable  :: Aerosol_interp

!--------------------------------------------------------------------
!    miscellaneous variables
!--------------------------------------------------------------------
logical  :: make_separate_calls=.false.      ! aerosol interpolation
                                             ! to be done one at a 
                                             ! time
type(time_type), dimension(:), allocatable   ::    &
                   Aerosol_time              ! time for which data is
                                             ! obtained from aerosol
                                             ! timeseries
logical  :: do_column_aerosol = .false.      ! using single column aero-
                                             ! sol data ?
logical  :: do_predicted_aerosol = .false.   ! using predicted aerosol fields?
logical  :: do_specified_aerosol = .false.   ! using specified aerosol fields 
                                             ! from a timeseries file?
integer  :: nfields=0                        ! number of active aerosol 
                                             ! species
integer  :: nfamilies=0                      ! number of active aerosol 
                                             ! families
logical  :: module_is_initialized = .false.  ! module has been 
                                             ! initialized  ?

type(time_type) :: Model_init_time  ! initial calendar time for model  
                                    ! [ time_type ]
type(time_type), dimension(:), allocatable ::   &
                   Aerosol_offset   ! difference between model initial
                                    ! time and aerosol timeseries app-
                                    ! lied at model initial time
                                    ! [ time_type ]
type(time_type), dimension(:), allocatable ::   &
                   Aerosol_entry    ! time in aerosol timeseries which
                                    ! is mapped to model initial time
                                    ! [ time_type ]
type(time_type)  ::   &
              Aerosol_column_time   ! time for which aerosol data is
                                    ! extracted from aerosol timeseries
                                    ! in 'calculate_columns' case
                                    ! [ time_type ]
logical, dimension(:), allocatable    ::     &
                   negative_offset 
                                    ! the model initial time is later 
                                    ! than the aerosol_dataset_entry 
                                    ! time  ?
integer , dimension(:), allocatable :: data_out_of_bounds, vert_interp
logical, dimension(:), allocatable :: using_fixed_year_data 
                                    ! are we using a fixed year
                                    !  of data from a timeseries file ?
integer, dimension (MAX_DATA_FIELDS) :: aerosol_tracer_index
                                    ! tracer index for each of the 
                                    ! prognostic tracer to be seen as 
                                    ! aerosols by the radiation package
real, dimension (MAX_DATA_FIELDS)    :: aerosol_tracer_scale_factor
                                    ! scaling factor for each of the 
                                    ! prognostic tracer to be seen as 
                                    ! aerosols by the radiation package

#include <netcdf.inc>
 
!---------------------------------------------------------------------
!---------------------------------------------------------------------


                           contains


 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!---------------------------------------------------------------------
! <SUBROUTINE NAME="aerosol_init">
!  <OVERVIEW>
!   Subroutine to initialize/interpolate prescribed aerosol climatology
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to initialize/interpolate prescribed aerosol climatology
!  </DESCRIPTION>
!  <TEMPLATE>
!   call aerosol_init(lonb, latb, aerosol_names)
!  </TEMPLATE>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes on cell corners in [radians]
!  </IN>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes on cell corners in [radians]
!  </IN>
!  <IN NAME="aerosol_names" TYPE="character">
!   names of the activated aerosol species
!  </IN>
! </SUBROUTINE>
!
subroutine aerosol_init (lonb, latb, aerosol_names,   &
                         aerosol_family_names)

!-----------------------------------------------------------------------
!    aerosol_init is the constructor for aerosol_mod.
!-----------------------------------------------------------------------

real, dimension(:,:),            intent(in)  :: lonb,latb
character(len=64), dimension(:), pointer     :: aerosol_names
character(len=64), dimension(:), pointer     :: aerosol_family_names

!----------------------------------------------------------------------
!  intent(in) variables:
!
!       lonb           2d array of model longitudes on cell corners 
!                      [ radians ]
!       latb           2d array of model latitudes at cell corners 
!                      [ radians ]
!
!   pointer variables:
!
!       aerosol_names  names of the activated aerosol species
!       aerosol_family_names  names of the activated aerosol families
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:
      
      character(len=64)  :: data_names_predicted (MAX_DATA_FIELDS) = '  '
                              ! predicted aerosol names to be 
                              ! seen by radiation code
      logical :: flag,rad_forc_online, single_year_file
      character(len=80)       ::tr_rad_name, tr_clim_name
      character(len=80)       :: name,control
      real                    ::tr_rad_scale_factor
      integer   ::   unit, ierr, io, logunit
      integer   ::   ntrace
      integer   ::   n

!---------------------------------------------------------------------
!    local variables:
!
!         unit       io unit number used to read namelist file
!         ierr       error code
!         io         error status returned from io operation
!         n          do-loop index
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call mpp_io_init
      call fms_init
      call diag_manager_init
      call rad_utilities_init
      call time_manager_init
      call constants_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=aerosol_nml, iostat=io)
      ierr = check_nml_error(io,'aerosol_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=aerosol_nml, iostat=io,  &
               end=10)
        ierr = check_nml_error(io,'aerosol_nml')
        end do
10      call close_file (unit)   
      endif                      
#endif
                                  
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=aerosol_nml)

!---------------------------------------------------------------------
!    case of single input aerosol field. when running standalone code
!    on other than FMS level structure, aerosol_data_source must be 
!    'input'.
!---------------------------------------------------------------------
      if (trim(aerosol_data_source)== 'input') then
        do_column_aerosol = .true.
        call obtain_input_file_data
        nfields = 1
        allocate (aerosol_names(nfields))
        aerosol_names (1) = 'total_aerosol'

!---------------------------------------------------------------------
!    case of predicted aerosols.
!---------------------------------------------------------------------
      else if (trim(aerosol_data_source) == 'predicted') then
        do_predicted_aerosol = .true.

!-----------------------------------------------------------------------
!    count number of activated aerosol species, which will be carried
!    in the model as tracers with an attribute of 'radiative_param'. 
!    define the names associated with these aerosols.
!-----------------------------------------------------------------------
        call get_number_tracers(MODEL_ATMOS, num_tracers= ntrace)
        do n = 1, ntrace
          flag = query_method ('radiative_param', MODEL_ATMOS, &
                               n, name, control)
          if (flag) then
            call get_radiative_param(name,control,rad_forc_online, &
                                     tr_rad_name, tr_clim_name, &
                                     tr_rad_scale_factor)
            if (rad_forc_online) then
              nfields = nfields +1
              aerosol_tracer_index(nfields) = n
              data_names_predicted(nfields) = trim(tr_rad_name)
!             data_names(nfields)           = trim(tr_clim_name)
              data_names(nfields)           = trim(tr_rad_name)
              aerosol_tracer_scale_factor(nfields) = tr_rad_scale_factor
            endif
          endif
        end do

!----------------------------------------------------------------------
!    allocate and fill pointer arrays to return the names of the activ-
!    ated species and any activated families to the calling routine.
!---------------------------------------------------------------------
        allocate (aerosol_names(nfields))
        aerosol_names(:)        = data_names_predicted(1:nfields)

!---------------------------------------------------------------------
!    case of 'climatology' and 'calculate_column' aerosol data source.
!---------------------------------------------------------------------
      else   ! (trim(aerosol_data_source) == 'input')     
        do_specified_aerosol = .true.

!---------------------------------------------------------------------
!    determine how many aerosols in the file are activated.
!--------------------------------------------------------------
        do n=1,MAX_DATA_FIELDS
          if (data_names(n) /= ' '  ) then
            nfields = n
          else
            exit
          endif
        end do
  
!---------------------------------------------------------------------
!    check for case of inconsistent nml specification -- case of re-
!    questing time-varying aerosol for a given aerosol, but indicating
!    that the time series is not to be used. in this case, a note will
!    be written to stdout indicating that the aerosol species will not
!    be time-varying. this is needed because the default nml settings  
!    are defined so as to allow backward compatibility with existing 
!    code and script settings, and lead to this conflict.
!---------------------------------------------------------------------
        do n=1, nfields
          if (.not. use_aerosol_timeseries) then
            if (time_varying_species(n)) then
              call error_mesg ('aerosol_mod', &
                  'inconsistent nml settings -- not using aerosol  &
                  &timeseries but requesting interannual variation of  &
                  & aerosol amount for '  // trim (data_names(n))  // &
                 ' -- this aerosol will NOT exhibit interannual &
                  &variation', NOTE)
              time_varying_species(n) = .false.
            endif
          endif
        end do

!---------------------------------------------------------------------
!    allocate and fill pointer arrays to return the names of the activ-
!    ated species and any activated families to the calling routine.
!--------------------------------------------------------------------
        allocate (aerosol_names(nfields))
        aerosol_names (:) = data_names(1:nfields)

!----------------------------------------------------------------------
!    allocate and initialize module variables.
!----------------------------------------------------------------------
        allocate (Aerosol_offset(nfields), Aerosol_entry(nfields), &
              negative_offset(nfields), using_fixed_year_data(nfields)) 
        Aerosol_offset = set_time (0,0)
        Aerosol_entry = set_time (0,0)
        negative_offset = .false.
        using_fixed_year_data = .false.

!----------------------------------------------------------------------
!    define the model base time  (defined in diag_table) 
!----------------------------------------------------------------------
        Model_init_time = get_base_time()

!----------------------------------------------------------------------
!    define the array using_fixed_year_data. it will be .true. for a 
!    given aerosol species if the nml variable use_aerosol_timeseries 
!    is .true., and the nml variable time_varying_species for that
!    aerosol is .false., or if use_aerosol_timeseries is .false but a 
!    non-default aerosol_dataset_entry has been specified; otherwise it 
!    will be .false..
!----------------------------------------------------------------------
        do n=1,nfields           
          if (use_aerosol_timeseries) then
            if (time_varying_species(n)) then
              using_fixed_year_data(n) = .false.
            else
              using_fixed_year_data(n) = .true.
            endif
  
!---------------------------------------------------------------------
!    if no dataset entry point is supplied when an aerosol timeseries
!    file is being used, define the entry point as the model base time.
!---------------------------------------------------------------------
            if (aerosol_dataset_entry(1,n) == 1 .and. &
                aerosol_dataset_entry(2,n) == 1 .and. &
                aerosol_dataset_entry(3,n) == 1 .and. &
                aerosol_dataset_entry(4,n) == 1 .and. &
                aerosol_dataset_entry(5,n) == 1 .and. &
                aerosol_dataset_entry(6,n) == 1 ) then
              Aerosol_entry(n) = Model_init_time

!----------------------------------------------------------------------
!    if a dataset entry time is defined, compute the offset from model 
!    base time to aerosol_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
            else
              Aerosol_entry(n) = set_date (aerosol_dataset_entry(1,n), &
                                           aerosol_dataset_entry(2,n), &
                                           aerosol_dataset_entry(3,n), &
                                           aerosol_dataset_entry(4,n), &
                                           aerosol_dataset_entry(5,n), &
                                           aerosol_dataset_entry(6,n))
            endif

!----------------------------------------------------------------------
!    indicate that aerosol species n will be defined from the timeseries
!    file, and the relationship of the timeseries to the model calendar.
!--------------------------------------------------------------------
            call error_mesg ( 'aerosol_mod', &
               'PROCESSING AEROSOL TIMESERIES FOR ' // &
               trim(aerosol_names(n)), NOTE)
            call print_date (Aerosol_entry(n) ,   &
                str= ' Data from aerosol timeseries at time: ')
            call print_date (Model_init_time , str=' This data is &
                               &mapped to model time:')

!---------------------------------------------------------------------
!    indicate whether a single year of the aerosol climatology will be
!    repeated throughout the model run, or if the aerosol time behavior
!    will show interannual changes.
!---------------------------------------------------------------------
            if (using_fixed_year_data(n)) then
              call error_mesg ('aerosol_mod', &
                 'This annual cycle will be used every model year &
               & -- no interannual variation for '  &
                                     // trim(aerosol_names(n)), NOTE)
            else
              call error_mesg ('aerosol_mod', &
                      trim(aerosol_names(n)) //   &
                     ' will exhibit interannual variation as defined &
                     & in the climatology file ', NOTE)
            endif
!---------------------------------------------------------------------
!    define the offset between the aerosol timeseries and the model
!    calendar, and whether this is a positive or negative offset.
!--------------------------------------------------------------------
            Aerosol_offset(n) = Aerosol_entry(n) - Model_init_time
            if (Model_init_time > Aerosol_entry(n)) then
              negative_offset(n) = .true.
            else
              negative_offset(n) = .false.
            endif

!---------------------------------------------------------------------
!    if use_aerosol_timeseries is .false., then either data from a 
!    single year defined in a timeseries file is to be used throughout 
!    the model integration, or a non-specific single-year aerosol 
!    climatology file is to be used.
!---------------------------------------------------------------------
          else 

!---------------------------------------------------------------------
!    if no dataset entry has been specified, then a non-specific single
!    year climatology file is being used. set the variable 
!    using_fixed_year_data to be .false.. output a descriptive message
!    to stdout.
!---------------------------------------------------------------------
            if (aerosol_dataset_entry(1,n) == 1 .and. &
                aerosol_dataset_entry(2,n) == 1 .and. &
                aerosol_dataset_entry(3,n) == 1 .and. &
                aerosol_dataset_entry(4,n) == 1 .and. &
                aerosol_dataset_entry(5,n) == 1 .and. &
                aerosol_dataset_entry(6,n) == 1 ) then
              using_fixed_year_data(n) = .false.
              if (mpp_pe() == mpp_root_pe() ) then
                print *, 'Aerosol data for ', trim(aerosol_names(n)),   &
                   ' obtained from single year climatology file '
              endif

!---------------------------------------------------------------------
!    if a year has been specified for the dataset entry, then the data
!    will be coming from an aerosol timeseries file, but the same annual
!    aerosol variation will be used for each model year. set the var-
!    iable using_fixed_year_data to be .true..  define Aerosol_entry as
!    feb 01 of the year given by the first element of nml variable 
!    aerosol_dataset_entry. output a descriptive message to stdout.
!--------------------------------------------------------------------
            else
              using_fixed_year_data(n) = .true.
              Aerosol_entry(n) = set_date (aerosol_dataset_entry(1,n), &
                                           2, 1, 0, 0, 0)
              call error_mesg ('aerosol_mod', &
                  'Aerosol data is defined from a single annual cycle &
                  &for ' // trim(aerosol_names(n)) //   &
                  &' - no interannual variation', NOTE)
              if (mpp_pe() == mpp_root_pe() ) then
                print *, 'Aerosol data for ', trim(aerosol_names(n)),  &
                    ' obtained from aerosol timeseries &
                    &for year:', aerosol_dataset_entry(1,n)
              endif
            endif
          endif
        end do

!-----------------------------------------------------------------------
!    count number of activated aerosol families. allocate a pointer 
!    array to return the names of the activated species to the calling 
!    routine.
!-----------------------------------------------------------------------
!       do n=1,MAX_AEROSOL_FAMILIES
!         if (family_names(n) /= ' '  ) then
!           nfamilies = n
!         else
!           exit
!         endif
!       end do

!-----------------------------------------------------------------------
!    allocate and initialize variables needed for interpolator_mod if 
!    any aerosol species have been activated.
!-----------------------------------------------------------------------
        allocate (data_out_of_bounds(nfields))
        allocate (vert_interp       (nfields))
        data_out_of_bounds = CONSTANT
        vert_interp = INTERP_WEIGHTED_P

!----------------------------------------------------------------------
!    determine if separate calls to interpolator  must be made for 
!    each aerosol species, or if all variables in the file may be
!    interpolated together.  reasons for separate calls include differ-
!    ent data times desired for different aerosols, different vertical
!    interpolation procedures and different treatment of undefined
!    data.
!----------------------------------------------------------------------
          do n=2,nfields
            if (time_varying_species(n) .and.   &
               (.not. time_varying_species(n-1) ) ) then
              make_separate_calls = .true.
              exit
            endif
            if (using_fixed_year_data(n) .and.   &
                (.not. using_fixed_year_data(n-1) ) ) then
              make_separate_calls = .true.
              exit
            endif
            if (Aerosol_entry(n) /= Aerosol_entry(n-1)) then
              make_separate_calls = .true.
              exit
            endif
            if (data_out_of_bounds(n) /= data_out_of_bounds(n-1)) then
              make_separate_calls = .true.
              exit
            endif
            if (vert_interp       (n) /= vert_interp       (n-1)) then
              make_separate_calls = .true.
              exit
            endif
          end do
          if (make_separate_calls) then
            allocate (Aerosol_interp(nfields))  
            allocate (Aerosol_time  (nfields))  
          else
            allocate (Aerosol_interp(1))  
            allocate (Aerosol_time  (1))  
          endif

!----------------------------------------------------------------------
!    determine if the aerosol_data_source is specified as 
!    'calculate_column'. 
!--------------------------------------------------------------------
        if (trim(aerosol_data_source) == 'calculate_column') then

!----------------------------------------------------------------------
!    if the aerosol_data_source is specified as 'calculate_column', then
!    the aerosol fields will be obtained by averaging the aerosol fields
!    in the climatology over a specified latitude-longitude section at
!    a specified calendar time, and this profile will be used in all 
!    model columns. make sure the specified lats / lons / time are 
!    valid.
!-------------------------------------------------------------------
          do n=1,2
            if (lonb_col(n) < 0. .or. lonb_col(n) > 360.) then
              call error_mesg ('aerosol_mod', &
                  ' invalid value for lonb_col', FATAL)
            endif
            if (latb_col(n) < -90. .or. latb_col(n) > 90.) then
              call error_mesg ('aerosol_mod', &
                  ' invalid value for latb_col', FATAL)
            endif
          end do
          if (time_col(1) == 0) then
            call error_mesg ('aerosol_mod', &
                'invalid time specified for time_col', FATAL)
          endif

          if (.not. use_aerosol_timeseries) then
              call error_mesg ('aerosol_mod', &
         'must use_aerosol_timeseries when calculate_column is .true.', FATAL)
          endif 

          if (any(time_varying_species(1:nfields))) then
              call error_mesg ('aerosol_mod', &
                   'aerosol values must be fixed in time when &
                                   &calculate_column is .true.', FATAL)
          endif 


!----------------------------------------------------------------------
!    call interpolator_init to begin processing the aerosol climat-
!    ology file. define the valid time as a time_type, and output
!    informative messages.
!---------------------------------------------------------------------
    if (make_separate_calls) then
              call error_mesg ('aerosol_mod', &
         'make_separate_calls not allowed  for calculate_column', FATAL)
     else       
          call interpolator_init (Aerosol_interp(1)    , filename,  &
                                    spread(lonb_col/RADIAN,2,2),  &
                                    spread(latb_col/RADIAN,1,2),&
                                    data_names(:nfields),   &
                                    data_out_of_bounds=   &
                                                  data_out_of_bounds, &
                                    vert_interp=vert_interp,  &
                                    single_year_file = single_year_file)
     endif
          Aerosol_column_time = set_date (time_col(1), time_col(2), &
                                          time_col(3), time_col(4), &
                                          time_col(5), time_col(6))
          call print_date (Aerosol_column_time,  str= &
              ' Aerosol data used is from aerosol timeseries at time: ')
          if (mpp_pe() == mpp_root_pe() ) then
            print *, 'Aerosol data is averaged over latitudes',  &
                latb_col(1), ' to', latb_col(2), ' and longitudes',&
                lonb_col(1), ' to', lonb_col(2)
          endif

!----------------------------------------------------------------------
!    if 'calculate_column' is .false., then the aerosol fields will have
!    the appropriate horizontal variation. call interpolator_init to
!    begin processing the aerosol climatology file.    
!-------------------------------------------------------------------
        else  ! (calculate_column)
    if (make_separate_calls) then
       do n=1,nfields
          call interpolator_init (Aerosol_interp(n), filename, lonb, &
                                  latb, data_names(n:n     ),   &
                                  data_out_of_bounds=    &
                                                  data_out_of_bounds(n:n), &
                                  vert_interp=vert_interp(n:n), &
                                  single_year_file=single_year_file)
       end do
     else
          call interpolator_init (Aerosol_interp(1), filename, lonb, &
                                  latb, data_names(:nfields),   &
                                  data_out_of_bounds=    &
                                                  data_out_of_bounds, &
                                  vert_interp=vert_interp, &
                                  single_year_file=single_year_file)
     endif
        endif ! (calculate_column)

!--------------------------------------------------------------------
!    check for compatibility of nml options requested and the aerosol
!    data file which was read.
!--------------------------------------------------------------------
        if (single_year_file .and.  use_aerosol_timeseries) then
          call error_mesg ('aerosol_mod', &
               'aerosol input file is single-year, yet interannual &
                &variation of aerosol is requested', FATAL  )
        endif
        do n=1, nfields
          if (.not. use_aerosol_timeseries .and.   &
              .not. using_fixed_year_data(n) .and. &
              .not. single_year_file)  then
            call error_mesg ('aerosol_mod', &
              'aerosol input file contains a time-series, yet nml  &
               &settings indicate that a non-specific single-year &
               &climatology is to be used', FATAL)
          endif
          if (.not. use_aerosol_timeseries .and.   &
              using_fixed_year_data(n) .and. &
              single_year_file)  then
            call error_mesg ('aerosol_mod', &
             'aerosol input file is non-specific single-year file,  &
               &yet nml settings specify that a particular single-year &
               &climatology is to be used', FATAL)
          endif
        end do
      endif  ! ('aerosol_data_source == 'input')

!-----------------------------------------------------------------------
!    count number of activated aerosol families. allocate a pointer 
!    array to return the names of the activated species to the calling 
!    routine.
!-----------------------------------------------------------------------
      do n=1,MAX_AEROSOL_FAMILIES
        if (family_names(n) /= ' '  ) then
          nfamilies = n
        else
          exit
        endif
      end do

!---------------------------------------------------------------------
!    allocate and fill pointer arrays to return the names of any activ-
!    ated families to the calling routine.
!-------------------------------------------------------------------
      allocate (aerosol_family_names(nfamilies))
      aerosol_family_names (:) = family_names(1:nfamilies)

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------



end subroutine aerosol_init

!############################################################################

subroutine aerosol_time_vary (model_time)

!--------------------------------------------------------------------------- 
!   subroutine aerosol_time_vary makes sure the aerosol interpolate_type 
!   variable has access to the proper time levels of data in the aerosol
!---------------------------------------------------------------------------

type(time_type), intent(in) :: model_time


      integer :: n

!----------------------------------------------------------------------
!    be sure the proper time levels are in memory for the aerosol timeseries.
!----------------------------------------------------------------------
      if ( do_specified_aerosol) then
 
        if (make_separate_calls) then
!--------------------------------------------------------------------
!    if separate calls are required for each aerosol species, loop over
!    the individual species.
!--------------------------------------------------------------------
          do n=1,nfields

!--------------------------------------------------------------------
!    if the data timeseries is to be used for species n, define the
!    time for which data is desired, and then call interpolator to
!    verify the time levels bracketing the desired time are available.
!--------------------------------------------------------------------
            if (use_aerosol_timeseries) then
              if (time_varying_species(n)) then

!----------------------------------------------------------------------
!    define the Aerosol_time for aerosol n and check for the  
!    appropriate time slices.
!----------------------------------------------------------------------
                if (negative_offset(n)) then
                  Aerosol_time(n) = model_time - Aerosol_offset(n)
                else
                  Aerosol_time(n) = model_time + Aerosol_offset(n)
                endif
                call obtain_interpolator_time_slices (Aerosol_interp(n), &
                                                          Aerosol_time(n))     
              else
                call set_aerosol_time (model_time, Aerosol_entry(n), &
                                       Aerosol_time(n))
                call obtain_interpolator_time_slices (Aerosol_interp(n), &
                                                       Aerosol_time(n))     
              endif

!--------------------------------------------------------------------
!    if the data timeseries is not to be used for species n, define the
!    time for which data is desired, and then call interpolator to
!    obtain the data.
!--------------------------------------------------------------------
            else  ! (use_aerosol_timeseries)

!---------------------------------------------------------------------
!    if a fixed year has not been specified, obtain data relevant for
!    the current model year.
!---------------------------------------------------------------------
              if ( .not. using_fixed_year_data(n)) then
                call obtain_interpolator_time_slices (Aerosol_interp(n), &
                                                              model_time)     
                Aerosol_time(n) = model_time

!----------------------------------------------------------------------
!    if a fixed year has been specified, call set_aerosol_time to define
!    the Aerosol_time to be used for aerosol n. call interpolator to 
!    obtain the aerosol values and store the aerosol amounts in 
!    Aerosol%aerosol.
!----------------------------------------------------------------------
              else 
                call set_aerosol_time (model_time, Aerosol_entry(n), &
                                         Aerosol_time(n))
                call obtain_interpolator_time_slices (Aerosol_interp(n), &
                                                          Aerosol_time(n))     
              endif  
            endif ! (use_aerosol_timeseries)
          end do  !(nfields)

        else  ! (make_separate_calls)
           
!--------------------------------------------------------------------
!    if the data timeseries is to be used for species n, define the
!    time for which data is desired.
!--------------------------------------------------------------------
          if (use_aerosol_timeseries) then
            if (negative_offset(1)) then
              Aerosol_time(1) = model_time - Aerosol_offset(1)
            else
              Aerosol_time(1) = model_time + Aerosol_offset(1)
            endif

!--------------------------------------------------------------------
!    if 'calculate_column' is being used,  be sure the needed time slices
!    are in memory.
!--------------------------------------------------------------------
            if (trim(aerosol_data_source) == 'calculate_column') then
              call obtain_interpolator_time_slices (Aerosol_interp(1), &
                                Aerosol_column_time)
            else

!-------------------------------------------------------------------
!    since separate calls are not required, all aerosol species are 
!    either time_varying  or not.  be sure the needed time slices are available.
!--------------------------------------------------------------------
              if (time_varying_species(1)) then
                call obtain_interpolator_time_slices (Aerosol_interp(1), &
                                Aerosol_time(1))
              else
                call set_aerosol_time (model_time, Aerosol_entry(1), &
                                       Aerosol_time(1))
                call obtain_interpolator_time_slices (Aerosol_interp(1), &
                                Aerosol_time(1))
              endif    
            endif  ! (calculate_column)

!--------------------------------------------------------------------
!    if the data timeseries is not to be used for species n, define the
!    time for which data is desired, and verify the presence of the needed
!    bracketing time slices.
!--------------------------------------------------------------------
          else ! (use_aerosol_timeseries)

!---------------------------------------------------------------------
!    if a fixed year has not been specified, obtain data relevant for
!    the current model year. this data comes from a non-specific single-yr
!    climatology file.
!---------------------------------------------------------------------
            if (.not. using_fixed_year_data(1)) then
              call obtain_interpolator_time_slices (Aerosol_interp(1), &
                                  model_time)
              Aerosol_time(1) = model_time

!----------------------------------------------------------------------
!    if a fixed year has been specified, call set_aerosol_time to define
!    the Aerosol_time, then verify the needed time slices are available. 
!----------------------------------------------------------------------
            else
              call set_aerosol_time (model_time, Aerosol_entry(1), &
                                                             Aerosol_time(1))
              call obtain_interpolator_time_slices (Aerosol_interp(1), &
                                                            Aerosol_time(1))
            endif ! (using_fixed_year)
          endif ! (use_aerosol_timeseries)
        endif  ! (make_separate_calls   )
      endif ! (do_column_aerosol)
               
!-------------------------------------------------------------------- 



end subroutine aerosol_time_vary 



!####################################################################

subroutine aerosol_endts

     integer :: n

     do n=1, size(Aerosol_interp,1)
       call unset_interpolator_time_flag (Aerosol_interp(n))
     end do
  

end subroutine aerosol_endts



!######################################################################
! <SUBROUTINE NAME="aerosol_driver">
!  <OVERVIEW>
!   Interpolate aerosol verical profile based on prescribed aerosol
!   climatology input and model set up.
!  </OVERVIEW>
!  <TEMPLATE>
!   call aerosol_driver (is, js, model_time, p_half, Aerosol)
!  </TEMPLATE>
!  <INOUT NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol climatology input
!  </INOUT>
!  <IN NAME="model_time" TYPE="time_type">
!   The internal model simulation time, i.e. Jan. 1 1982
!  </IN>
!  <IN NAME="tracer" TYPE="real">
!   4 dimensional array of tracers, last index is the number of all tracers
!  </IN>
!  <IN NAME="p_half" TYPE="real">
!   The array of model layer pressure values
!  </IN>
!  <IN NAME="is" TYPE="integer">
!   The longitude index of model physics window domain
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   The latitude index of model physics window domain
!  </IN>
! </SUBROUTINE>
!
subroutine aerosol_driver (is, js, model_time, tracer, &
                           p_half, p_flux, Aerosol)

!-----------------------------------------------------------------------
!    aerosol_driver returns the names and concentrations of activated 
!    aerosol species at model grid points at the model_time to the 
!    calling routine in aerosol_type variable Aerosol. 
!-----------------------------------------------------------------------

integer,                  intent(in)     :: is,js
type(time_type),          intent(in)     :: model_time
real, dimension(:,:,:,:), intent(in)     :: tracer
real, dimension(:,:,:),   intent(in)  :: p_half, p_flux
type(aerosol_type),       intent(inout)  :: Aerosol

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       is, js           starting subdomain i,j indices of data in 
!                        the physics_window being integrated
!       model_time       time for which aerosol data is desired
!                        [ time_type ]
!       p_half           model pressure at interface levels 
!                        [ Pa ]
!      
!   intent(inout) variables:
!
!       Aerosol    aerosol_type variable. the following components will
!                  be returned from this routine:
!                   aerosol      concentration of each active aerosol 
!                                species at each model grid point
!                                [ kg / m**2 ]
!                   aerosol_names 
!                                names assigned to each active species
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension(1,1, size(p_half,3)-1,    &
                                               nfields) :: aerosol_data
      real, dimension(1,1, size(p_half,3))   :: p_half_col
      integer         :: n, k, j, i, na            ! do-loop index
      integer         :: nn

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('aerosol_mod',   &
                         'module has not been initialized',FATAL )
      endif

!---------------------------------------------------------------------
!    allocate an array to hold the activated aerosol names. allocate an
!    array which defines the members of the requested aerosol families.
!    allocate an array to hold the aerosol amounts for each species at
!    each grid point. 
!---------------------------------------------------------------------
      allocate (Aerosol%aerosol_names (nfields))
      allocate (Aerosol%family_members(nfields+1, nfamilies))
      allocate (Aerosol%aerosol(size(p_half,1),  &
                                size(p_half,2), &
                                size(p_half,3) - 1, nfields)) 

      if (do_column_aerosol) then
 
!---------------------------------------------------------------------
!    here all aerosol is consolidated into a single variable.
!----------------------------------------------------------------------
        Aerosol%aerosol_names(1) = 'total_aerosol'
        do k=1, size(Aerosol%aerosol,3)
          Aerosol%aerosol(:,:,k,1) = specified_aerosol(k)
        end do
      else 
      
!--------------------------------------------------------------------
!    define an array to hold the activated aerosol names.
!---------------------------------------------------------------------
        Aerosol%aerosol_names = data_names(:nfields) 

!--------------------------------------------------------------------
!    define an array which defines the members of the requested aerosol
!    families.
!---------------------------------------------------------------------
        if (nfamilies > 0) then
          do n=1,nfamilies
            do na = 1, nfields
              select case(n)
                case (1)
                  Aerosol%family_members(na,1) = in_family1(na)
                case (2)
                  Aerosol%family_members(na,2) = in_family2(na)
                case (3)
                  Aerosol%family_members(na,3) = in_family3(na)
                case (4)
                  Aerosol%family_members(na,4) = in_family4(na)
                case (5)
                  Aerosol%family_members(na,5) = in_family5(na)
                case (6)
                  Aerosol%family_members(na,6) = in_family6(na)
                case (7)
                  Aerosol%family_members(na,7) = in_family7(na)
                case (8)
                  Aerosol%family_members(na,8) = in_family8(na)
                case (9)
                  Aerosol%family_members(na,9) = in_family9(na)
                case (10)
                  Aerosol%family_members(na,10) = in_family10(na)
                case (11)
                  Aerosol%family_members(na,11) = in_family11(na)
                case (12)
                  Aerosol%family_members(na,12) = in_family12(na)
                case DEFAULT
              end select
            end do
            if (volc_in_fam_col_opt_depth(n)) then
              Aerosol%family_members(nfields+1,n) = .true.
            else
              Aerosol%family_members(nfields+1,n) = .false.
            endif
          end do
        endif

!----------------------------------------------------------------------
         if ( do_specified_aerosol) then

!--------------------------------------------------------------------
!    if 'calculate_column' is being used, obtain the aerosol values for
!    each column, one at a time, using the pressure profile for that
!    column. this allows each column to see the same aerosol fields,
!    but distributed appropriately for its pressure structure.
!--------------------------------------------------------------------
              if (trim(aerosol_data_source) == 'calculate_column') then
                do j=1, size(p_half,2)
                  do i=1, size(p_half,1)
                    p_half_col(1,1,:) = p_flux(i,j,:)
                    call interpolator (Aerosol_interp(1),&
                                       Aerosol_column_time,  &
                                       p_half_col, aerosol_data, &
                                       Aerosol%aerosol_names(1), 1, 1  )
                    Aerosol%aerosol(i,j,:,:) = aerosol_data(1,1,:,:)
                  end do
                end do
              else

!--------------------------------------------------------------------
!    if separate calls are required for each aerosol species, loop over
!    the individual species.
!--------------------------------------------------------------------
                if (make_separate_calls) then
                  do n=1,nfields                
                    call interpolator (Aerosol_interp(n), Aerosol_time(n),  &
                                     p_flux, &
                                     Aerosol%aerosol(:,:,:,n),    &
                                     Aerosol%aerosol_names(n), is, js)
                  end do  !(nfields)

!----------------------------------------------------------------------
!    if separate calls are not required, use the first aerosol char-
!    acteristics to define Aerosol_time and make a single call to 
!    interpolator. store the aerosol amounts in Aerosol%aerosol.
!----------------------------------------------------------------------
                else      
                  call interpolator (Aerosol_interp(1), Aerosol_time(1),  &
                                    p_flux, &
                                    Aerosol%aerosol,    &
                                    Aerosol%aerosol_names(1), is, js)
                endif      
              endif ! (calculate_column)

!-------------------------------------------------------------------- 
!    for predicted aerosols (obtained from tracer array), assign the 
!    tracer to "Aerosol" if that TRACER has "radiative_param" and 
!    "online", both defined in the field_table. 
! ***********************WARNINGS**************************************
!    the tracers are assumed to be expressed in Mass Mixing Ratio (MMR), 
!    and are converted into mass column for the radiative code.
!    Conversions (e.g. OC -> OM, or SO4 -> (NH4)2SO4 ) can be done
!    via radiative_param attribute scale_factor (in field_table).
!------------------------------------------------------------------ 
        else                  ! (do_specified_aerosol')
          do nn=1,nfields
            n = aerosol_tracer_index(nn)
            do k=1,size(Aerosol%aerosol,3)
              do j=1,size(Aerosol%aerosol,2)
                do i=1,size(Aerosol%aerosol,1)
                  Aerosol%aerosol(i,j,k,nn) =    &
                          MAX (0.0, tracer(i,j,k,n)) * &
                          aerosol_tracer_scale_factor(nn) * &
                          ( p_half(i,j,k+1)-p_half(i,j,k) )/GRAV
                end do
              end do
            end do
          end do
        endif   ! (do_specified_aerosol')
      endif  ! (do_column_aerosol)

!-------------------------------------------------------------------- 

end subroutine aerosol_driver



!#####################################################################
! <SUBROUTINE NAME="aerosol_end">
!  <OVERVIEW>
!   aerosol_end is the destructor for aerosol_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   aerosol_end is the destructor for aerosol_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call aerosol_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine aerosol_end

!----------------------------------------------------------------------
!    aerosol_end is the destructor for aerosol_mod.
!----------------------------------------------------------------------

      integer  :: n


!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('aerosol_mod',   &
                         'module has not been initialized',FATAL )
      endif

!---------------------------------------------------------------------
!    call interpolator_end to release the interpolate_type variable 
!    used in this module.
!---------------------------------------------------------------------
      if (do_specified_aerosol) then
          if (nfields > 0) then
            do n=1, size(Aerosol_interp,1)
              call interpolator_end (Aerosol_interp(n))
            end do        
          endif
          deallocate (Aerosol_time)
      endif

      if (allocated (specified_aerosol)) deallocate (specified_aerosol)
      if (allocated (Aerosol_offset   )) deallocate (Aerosol_offset   )
      if (allocated (Aerosol_entry    )) deallocate (Aerosol_entry    )
      if (allocated (negative_offset  )) deallocate (negative_offset  )
      if (allocated (data_out_of_bounds))   &
                                      deallocate (data_out_of_bounds  )
      if (allocated (vert_interp      )) deallocate (vert_interp      ) 
      if (allocated (using_fixed_year_data))  &
                                     deallocate (using_fixed_year_data)

!--------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------



end subroutine aerosol_end


!#####################################################################

subroutine set_aerosol_time (Model_time, Entry, Aerosol_time)

type(time_type), intent(in)   :: Model_time, Entry
type(time_type), intent(out)  :: Aerosol_time

      integer :: mo_yr, yr, mo, dy, hr, mn, sc, dum, dayspmn

      call get_date (Model_time, mo_yr, mo, dy, hr, mn, sc)
      call get_date (Entry, yr, dum,dum,dum,dum,dum)
      if (mo ==2 .and. dy == 29) then
        dayspmn = days_in_month(Entry)
        if (dayspmn /= 29) then
          Aerosol_time = set_date (yr, mo, dy-1, hr, mn, sc)
        else
          Aerosol_time = set_date (yr, mo, dy, hr, mn, sc)
        endif
      else
        Aerosol_time = set_date (yr, mo, dy, hr, mn, sc)
      endif

!--------------------------------------------------------------------


end subroutine set_aerosol_time


!#####################################################################
! <SUBROUTINE NAME="aerosol_dealloc">
!  <OVERVIEW>
!    aerosol_dealloc deallocates the array components of an 
!    aersol_type derived type variable.
!  </OVERVIEW>
!  <DESCRIPTION>
!    aerosol_dealloc deallocates the array components of an 
!    aersol_type derived type variable.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call aerosol_dealloc
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine aerosol_dealloc (Aerosol)

!---------------------------------------------------------------------
!    aerosol_dealloc deallocates the array components of an 
!    aersol_type derived type variable.
!---------------------------------------------------------------------

type(aerosol_type), intent(inout) :: Aerosol

!---------------------------------------------------------------------
!  intent(inout) variables:
! 
!      Aerosol       aerosol_type variable containing information on
!                    the activated aerosol species
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('aerosol_mod',   &
                         'module has not been initialized',FATAL )
      endif

!---------------------------------------------------------------------
!    deallocate the components of the aerosol_type variable.
!---------------------------------------------------------------------
      deallocate (Aerosol%aerosol)
      deallocate (Aerosol%aerosol_names)
      deallocate (Aerosol%family_members)
 
!----------------------------------------------------------------------


end subroutine aerosol_dealloc


!#####################################################################

! <SUBROUTINE NAME="obtain_input_file_data">
!  <OVERVIEW>
!   obtain_input_file_data reads an input file containing a single
!    column aerosol profile. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   obtain_input_file_data reads an input file containing a single
!    column aerosol profile. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  obtain_input_file_data
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine obtain_input_file_data 

!---------------------------------------------------------------------
!    obtain_input_file_data reads an input file containing a single
!    column aerosol profile.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer   :: iounit    ! unit to read file on
      integer   :: kmax_file ! number of levels of data in file
      integer   :: k         ! do-loop index
      character(len=31), dimension(200) :: dimnam
      integer(kind=4), dimension(200) :: dimsiz
      integer(kind=4)                 :: ncid, rcode, nvars, ndims, &
                                         ngatts, recdim
      integer    :: i, j
      integer, PARAMETER :: MAXDIMS = 10
      integer(kind=4), dimension(MAXDIMS) :: start, count, vdims
      integer(kind=4)                     :: ivarid, ntp, nvdim, nvs, &
                                             ndsize
      character(len=31)   dummy
      



!-------------------------------------------------------------------
!    determine if a netcdf input data file exists. if so, read the 
!    number of data records in the file.
!---------------------------------------------------------------------
      if (file_exist ( 'INPUT/id1aero.nc') ) then
        ncid = ncopn ('INPUT/id1aero.nc', 0, rcode)
        call ncinq (ncid, ndims, nvars, ngatts, recdim, rcode)
        do i=1,ndims
          call ncdinq (ncid, i, dimnam(i), dimsiz(i), rcode)
          if (dimnam(i) == 'lev') then
            kmax_file = dimsiz(i)
          endif
        end do
             
!-------------------------------------------------------------------
!    allocate space for the input data. read the data set. close the 
!    file upon completion.
!---------------------------------------------------------------------
        allocate (specified_aerosol(kmax_file) )
        ivarid = ncvid(ncid, 'aerosol', rcode)
        call ncvinq (ncid, ivarid, dummy, ntp, nvdim, vdims, nvs, rcode)
        do j=1,nvdim
          call ncdinq (ncid, vdims(j), dummy, ndsize, rcode)
          start(j) = 1
          count(j) = ndsize
        end do
       call ncvgt (ncid, ivarid, start, count, specified_aerosol, rcode)

         call ncclos (ncid, rcode)

!-------------------------------------------------------------------
!    determine if the input data input file exists in ascii format. if 
!    so, read the number of data records in the file.
!---------------------------------------------------------------------
      else if (file_exist ( 'INPUT/id1aero') ) then
        iounit = open_namelist_file ('INPUT/id1aero')
        read (iounit,FMT = '(i4)') kmax_file

!-------------------------------------------------------------------
!    allocate space for the input data. read the data set. close the 
!    file upon completion.
!---------------------------------------------------------------------
         allocate (specified_aerosol(kmax_file) )
         read (iounit,FMT = '(5e18.10)')   &
                          (specified_aerosol(k),k=1,kmax_file)
         call close_file (iounit)

!---------------------------------------------------------------------
!    if file is not present, write an error message.
!---------------------------------------------------------------------
       else
         call error_mesg ( 'aerosol_mod', &
              'desired aerosol input file is not present',FATAL)
       endif

!----------------------------------------------------------------------


end subroutine obtain_input_file_data 


!###################################################################### 



                  end module aerosol_mod 



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



#ifdef test_aerosol

program main

use aerosol_mod
use mpp_mod
use mpp_io_mod
use mpp_domains_mod
use time_manager_mod
use diag_manager_mod
use rad_utilities_mod




implicit none

!-----------------------------------------------------------------------
! ... Local variables
!-----------------------------------------------------------------------
integer, parameter :: NLON=20, NLAT=10,NLEV=8
integer, parameter :: MAX_AERSOL_NAMES = 100
real :: latb(NLON+1,NLAT+1),lonb(NLON+1,NLAT+1),pi,phalf(NLON,NLAT,NLEV+1)
integer :: i,nspecies
type(time_type) :: model_time
character(len=64), dimension(MAX_AEROSOL_NAMES) :: names
type(aerosol_type)  :: Aerosol

pi = 4.*atan(1.)

call mpp_init
call mpp_io_init
call mpp_domains_init
call diag_manager_init
call set_calendar_type(JULIAN)

do i = 1,NLAT+1
   latb(:,i) = -90. + 180.*REAL(i-1)/REAL(NLAT)
end do
do i = 1,NLON+1
   lonb(i,:) = -180. + 360.*REAL(i-1)/REAL(NLON)
end do

latb(:,:) = latb(:,:) * pi/180.
lonb(:,:) = lonb(:,:) * pi/180.

do i = 1,NLEV+1
   phalf(:,:,i) = 101325. * REAL(i-1) / REAL(NLEV)
end do

model_time = set_date(1980,1,1,0,0,0)

call aerosol_init (lonb, latb, names)

call aerosol_driver (1,1,model_time, phalf, Aerosol)

call aerosol_dealloc (Aerosol)

call aerosol_end

call mpp_exit

end program main

#endif


                 module aerosolrad_package_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="">
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    aerosolrad_package_mod provides the radiative properties 
!    associated with the atmospheric aerosols.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!    shared modules:

use mpp_mod,               only: input_nml_file
use fms_mod,               only: open_namelist_file, fms_init, &
                                 mpp_pe, mpp_root_pe, stdlog, &
                                 file_exist, write_version_number, &
                                 check_nml_error, error_mesg, &
                                 FATAL, NOTE, close_file
use mpp_io_mod,            only: mpp_open, mpp_close, MPP_RDONLY,   &
                                 MPP_ASCII, MPP_SEQUENTIAL, MPP_MULTI, &
                                 MPP_SINGLE, mpp_io_init
use time_manager_mod,      only: time_type, time_manager_init,  &
                                 get_date, set_date, operator(+), &
                                 print_date, operator(-), operator(>)
use diag_manager_mod,      only: diag_manager_init, get_base_time
use interpolator_mod,      only: interpolate_type, interpolator_init, &
                                 interpolator, interpolator_end, &
                                 obtain_interpolator_time_slices, &
                                 unset_interpolator_time_flag, &
                                 CONSTANT, INTERP_WEIGHTED_P

! shared radiation package modules:
                                
use rad_utilities_mod,     only: Sw_control, &
                                 Lw_control, &
                                 Rad_control,&
                                 aerosol_type, aerosol_properties_type,&
                                 aerosol_diagnostics_type, &
                                 Lw_parameters, rad_utilities_init, &
                                 thickavg
use esfsw_parameters_mod,  only: Solar_spect, esfsw_parameters_init 
use longwave_params_mod,   only: NBLW, longwave_params_init

!-------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    aerosolrad_package_mod provides the radiative properties 
!    associated with the atmospheric aerosols.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: aerosolrad_package.F90,v 18.0.2.1.2.1.2.1 2010/08/30 20:33:31 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public           &
       aerosolrad_package_init, aerosol_radiative_properties, &
       aerosolrad_package_alloc, aerosolrad_package_time_vary, &
       aerosolrad_package_endts, &
       aerosolrad_package_end,  get_aerosol_optical_info, &
       get_aerosol_optical_index
     
private          &

!  called from aerosolrad_package_init: 
   assign_aerosol_opt_props, read_optical_input_file, &
   sw_aerosol_interaction,  lw_aerosol_interaction
       

!---------------------------------------------------------------------
!-------- namelist  ---------

integer, parameter   ::        &
             MAX_OPTICAL_FIELDS = 1000  ! maximum number of aerosol 
                                       ! optical property types
logical              ::        &
             do_lwaerosol = .false.    ! aerosol efects included in lw
                                       ! radiation ?
logical              ::        &
             do_swaerosol = .false.    ! aerosol effects included in sw
                                       ! radiation ?
logical              ::        &
             force_to_repro_quebec = .false.
                                       ! if true, code sequence is 
                                       ! executed which reproduces
                                       ! quebec+ answers for 
                                       ! AM3p8e in pre_Riga
character(len=48)    ::        &
             aerosol_data_set = ' '    ! source of aerosol data; if 
                                       ! aerosols not desired remains
                                       ! ' ', otherwise is set to either
                                       ! 'shettle_fenn' or 
                                       ! 'Ginoux_Reddy'

!----------------------------------------------------------------------
!    the avaialable aerosol datasets are :
!    1) "shettle_fenn":  
!        Ref: shettle, e.p. and r.w. fenn, models for the aerosols of 
!            the lower atmosphere and the effects of humidity variations
!            on their optical properties,afgl-tr-79-0214,1979,94pp.    
!    2) "Ginoux_Reddy": 3D Aerosol fields are generated online reflecting
!        emissions, transport and deposition:
!        Ref: Reddy et al., 2005, Ginoux et al., 2005
!        
!----------------------------------------------------------------------

character(len=64)    ::        &
             aerosol_optical_names(MAX_OPTICAL_FIELDS) = '  '
                                       ! names associated with the 
                                       ! optical property types that
                                       ! are to be used in this 
                                       ! experiment
character(len=64)    ::        &
             optical_filename = ' '    ! name of file containing the
                                       ! aerosol optical property types
logical              ::        &
             using_volcanic_sw_files = .false.
                                       ! files containing sw aerosol
                                       ! optical properties from vol-
                                       ! canic activity are to be
                                       ! used to supplement those cal-
                                       ! culated by model ?
logical              ::        &
             using_volcanic_lw_files = .false.
                                       ! files containing lw aerosol
                                       ! optical properties from vol-
                                       ! canic activity are to be
                                       ! used to supplement those cal-
                                       ! culated by model ?
character(len=64)    ::        &
              sw_ext_filename = ' '    ! name of file containing the
                                       ! aerosol sw extinction optical
                                       ! depth
character(len=64)    ::        &
              sw_ssa_filename = ' '    ! name of file containing the
                                       ! aerosol sw single scattering 
                                       ! albedo
character(len=64)    ::        &
              sw_asy_filename = ' '    ! name of file containing the
                                       ! aerosol sw asymmetry factor   
character(len=64)    ::        &
              lw_ext_filename = ' '    ! name of file containing the
                                       ! aerosol lw extinction optical
                                       ! depth
character(len=64)    ::        &
              lw_ssa_filename = ' '    ! name of file containing the
                                       ! aerosol lw single scattering 
                                       ! albedo
character(len=64)    ::        &
              lw_asy_filename = ' '    ! name of file containing the
                                       ! aerosol lw asymmetry factor   
                                       ! the supplemental input files
character(len=64)    ::        &
              sw_ext_root                  = '   ' 
                                       ! names given to sw extopdep in
                                       ! input netcdf file
character(len=64)    ::        &
              sw_ssa_root                  = '   ' 
                                       ! name given to sw single scat-
                                       ! tering albedo in input netcdf 
                                       ! file
character(len=64)    ::        &
              sw_asy_root                  = '   ' 
                                       ! name given to sw asymmetry
                                       ! factor in input netcdf file
character(len=64)    ::        &
              lw_ext_root                  = '   ' 
                                       ! name given to lw extopdep in
                                       ! input netcdf file
character(len=64)    ::        &
              lw_ssa_root                  = '   '  
                                       ! name given to lw single scat-
                                       ! tering albedo in input netcdf 
                                       ! file
character(len=64)    ::        &
              lw_asy_root                  = '   '      
                                       ! name given to lw asymmetry
                                       ! factor in input netcdf file
integer, dimension(6) ::       &
              volcanic_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /) 
                                       ! time in volcanic data set
                                       ! corresponding to model
                                       ! initial time 
                                       ! (yr, mo, dy, hr, mn, sc)
logical :: interpolating_volcanic_data = .true.
                                       ! volcanic datasets will be
                                       ! time interpolated rather than
                                       ! held constant for a month ?
logical :: repeat_volcano_year = .false. 
                                      ! the same single year's data from
                                      ! the input data set should be 
                                      ! used for each model year ?
integer :: volcano_year_used = 0      ! year of volcanic data to repeat
                                      ! when repeat_volcano_year is
                                      ! .true.
logical :: using_im_bcsul = .false.   ! bc and sulfate aerosols are 
                                      ! treated as an internal mixture ?
integer, dimension(0:100) ::  omphilic_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  bcphilic_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  seasalt1_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  seasalt2_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  seasalt3_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  seasalt4_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  seasalt5_indices = (/        &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
                             0  /)
integer, dimension(0:100) ::  sulfate_indices = (/      &
                           30,30,30,30,30,30,30,30,30,30,30,30,30,30, &
                           30,30,30,30,30,30,30,30,30,30,30,30,30,30, &
                           30,30,30,30,30,35,35,35,35,35,40,40,40,40, &
                           40,45,45,45,45,45,50,50,50,50,50,55,55,55, &
                           55,55,60,60,60,60,60,65,65,65,65,65,70,70, &
                           70,70,70,75,75,75,75,75,80,80,80,80,82,82, &
                           84,84,86,86,88,88,90,91,92,93,94,95,96,97, &
                           98,99,100 /)
!yim
integer, dimension(0:100) ::  sulfate_vol_indices = (/      &
                             100,98,98,96,96,94,94,92,92,90,90,88,88,86,86,84,84,82,82,80, &
                             80,80,80,75,75,75,75,75,70,70,70,70,70,65,65,65, &
                             65,65,60,60,60,60,60,55,55,55,55,55,50,50,50,50,50,45,45,45, &
                             45,45,40,40,40,40,40,35,35,35,35,35,30,30,30,30,30,25,25,25, &
                             25,25,20,20,20,20,20,15,15,15,15,15,10,10,10,10,10,5,5,5, &
                             5,5,0,0,0  /)


namelist / aerosolrad_package_nml /                          &
                                    do_lwaerosol, do_swaerosol, &
                                    force_to_repro_quebec, &
                                    aerosol_data_set, &
                                    aerosol_optical_names, &
                                    sulfate_indices, &
                                    sulfate_vol_indices, &
                                    omphilic_indices, &
                                    bcphilic_indices, &
                                    seasalt1_indices, &
                                    seasalt2_indices, &
                                    seasalt3_indices, &
                                    seasalt4_indices, &
                                    seasalt5_indices, &
                                    optical_filename   , &
                                    using_volcanic_sw_files, &
                                    using_volcanic_lw_files, &
                                    volcanic_dataset_entry, &
                                    interpolating_volcanic_data, &
                                    repeat_volcano_year, &
                                    volcano_year_used, &
                                    using_im_bcsul, &
                                    sw_ext_filename, sw_ssa_filename, &
                                    sw_asy_filename, lw_ext_filename, &
                                    lw_ssa_filename, lw_asy_filename, &
                                    sw_ext_root, sw_ssa_root,   &
                                    sw_asy_root, lw_ext_root,   &
                                    lw_ssa_root, lw_asy_root

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------


!---------------------------------------------------------------------
!   the following are interpolate_type variables containing the
!   additional aerosol optical properties that may be included as
!   input to the radiation package.
!---------------------------------------------------------------------
type(interpolate_type), save  :: Sw_aer_extopdep_interp
type(interpolate_type), save  :: Sw_aer_ssalb_interp
type(interpolate_type), save  :: Sw_aer_asymm_interp
type(interpolate_type), save  :: Lw_aer_extopdep_interp
type(interpolate_type), save  :: Lw_aer_ssalb_interp
type(interpolate_type), save  :: Lw_aer_asymm_interp

!---------------------------------------------------------------------
!    the following variables define the number and type of different
!    bands over which the radiation package calculates aerosol 
!    radiative properties.
!---------------------------------------------------------------------
integer, parameter ::    &
         N_AEROSOL_BANDS_FR = 8 ! number of non-continuum ir aerosol
                                ! emissivity bands 
integer, parameter ::     &
         N_AEROSOL_BANDS_CO = 1 ! number of continuum ir aerosol
                                ! emissivity bands  
integer, parameter ::     &
         N_AEROSOL_BANDS_CN = 1 ! number of diagnostic continuum ir 
                                ! aerosol emissivity bands  
integer, parameter ::    &
         N_AEROSOL_BANDS = N_AEROSOL_BANDS_FR + N_AEROSOL_BANDS_CO
                                ! total number of ir aerosol emissivity
                                ! bands 

!--------------------------------------------------------------------
!    num_wavenumbers is the number of wavenumber bands over which the
!    aerosol parameterization provides aerosol radiative property data.
!--------------------------------------------------------------------
integer     ::  num_wavenumbers = 0 ! number of wavenumber bands 
                                    ! present in the aerosol 
                                    ! parameterization

!----------------------------------------------------------------------
!    the following variable defines the number of aerosol property 
!    types that are active.
!----------------------------------------------------------------------
integer     :: naermodels = 0   ! number of aerosol optical properties
                                ! types that are active

!---------------------------------------------------------------------
!    flags indicating an index value characteristic of the optical prop-
!    erties associated with different aerosols
!---------------------------------------------------------------------
integer, PARAMETER ::   SULFATE_FLAG =  0
integer, PARAMETER ::  OMPHILIC_FLAG = -1
integer, PARAMETER ::  BCPHILIC_FLAG = -2
integer, PARAMETER ::  SEASALT1_FLAG = -3
integer, PARAMETER ::  SEASALT2_FLAG = -4
integer, PARAMETER ::  SEASALT3_FLAG = -5
integer, PARAMETER ::  SEASALT4_FLAG = -6
integer, PARAMETER ::  SEASALT5_FLAG = -7
!yim
integer, PARAMETER ::  BC_FLAG = -8
integer, PARAMETER ::  NOT_IN_USE = -2000

!----------------------------------------------------------------------
!    the following index arrays contain the mapping information between 
!    actual model relative humidity and the available enties in the 
!    aerosol optical properties file.
!----------------------------------------------------------------------
integer, dimension(:,:), allocatable :: sulfate_index
integer, dimension(:),   allocatable :: optical_index
integer, dimension(:),   allocatable :: omphilic_index
integer, dimension(:),   allocatable :: bcphilic_index
integer, dimension(:),   allocatable :: seasalt1_index
integer, dimension(:),   allocatable :: seasalt2_index
integer, dimension(:),   allocatable :: seasalt3_index
integer, dimension(:),   allocatable :: seasalt4_index
integer, dimension(:),   allocatable :: seasalt5_index

!---------------------------------------------------------------------
!    the following arrays related to sw aerosol effects are allocated 
!    during initialization and retained throughout the integration.
!    here n refers to the bands of the solar parameterization, ni
!    to the bands of the aerosol parameterization, and na to the optical
!    properties type.
!
!      solivlaero(n,ni)  amount of toa incoming solar from solar
!                        spectral band n that is in aerosol parameter-
!                        ization band ni
!      nivl1aero(n)      the aerosol band index corresponding to the 
!                        lowest wave number of spectral band n
!      nivl2aero(n)      the aerosol band index corresponding to the 
!                        highest wave number of spectral band n
!      endaerwvnsf(ni)   ending wave number of aerosol parameterization
!                        band ni
!      aeroextivl(ni,na) extinction coefficient for aerosol parameter-
!                        ization band ni for aerosol optical property 
!                        type na
!      aerossalbivl(ni,na) 
!                        single-scattering albedo for aerosol band 
!                        ni and aerosol optical property type na
!      aeroasymmivl(ni,na)
!                        asymmetry factor for aerosol band ni  and 
!                        aerosol optical property type na
!
!---------------------------------------------------------------------
real,    dimension(:,:), allocatable   :: solivlaero  
integer, dimension(:),   allocatable   :: nivl1aero, nivl2aero
integer, dimension(:),   allocatable   :: endaerwvnsf
real,    dimension(:,:), allocatable   :: aeroextivl, aerossalbivl, &
                                          aeroasymmivl

!---------------------------------------------------------------------
!    sfl following arrays related to lw aerosol effects are allocated 
!    during initialization and retained throughout the integration.
!
!    sflwwts(n,ni)     the fraction of the planck function in aerosol 
!                      emissivity band n that is in aerosol param-
!                      eterization band ni
!
!----------------------------------------------------------------------
real,    dimension(:,:), allocatable   :: sflwwts, sflwwts_cn

!--------------------------------------------------------------------
!    logical flags 
!--------------------------------------------------------------------
logical :: module_is_initialized      = .false. ! module has been
                                                ! initialized ?
!logical :: doing_predicted_aerosols   = .false. ! predicted aerosol 
                                                ! scheme being used ?
logical :: band_calculation_completed = .false. ! lw properties have
                                                ! been calculated ?

type(time_type) :: Model_init_time  ! initial calendar time for model  
                                    ! [ time_type ]
type(time_type) :: Volcanic_offset  ! difference between model initial
                                    ! time and volcanic timeseries app-
                                    ! lied at model initial time
                                    ! [ time_type ]
type(time_type) :: Volcanic_entry   ! time in volcanic timeseries which
                                    ! is mapped to model initial time
                                    ! [ time_type ]
logical    :: negative_offset = .false.
                                !  the model initial time is later than
                                !  the volcanic_dataset_entry time  ?
integer :: nfields_sw_ext = 0   ! number of fields contained in 
                                ! supplemental sw_ext file
integer :: nfields_sw_ssa = 0   ! number of fields contained in 
                                ! supplemental sw_ssa file
integer :: nfields_sw_asy = 0   ! number of fields contained in 
                                ! supplemental sw_asy file
integer :: nfields_lw_ext = 0   ! number of fields contained in 
                                ! supplemental lw_ext file
integer :: nfields_lw_ssa = 0   ! number of fields contained in 
                                ! supplemental lw_ssa file
integer :: nfields_lw_asy = 0   ! number of fields contained in 
                                ! supplemental lw_asy file

!-------------------------------------------------------------------
!   arrays holding variable names:
character(len=64), dimension(:), allocatable ::   &
                                sw_ext_name, sw_ssa_name, sw_asy_name, &
                                lw_ext_name, lw_ssa_name, lw_asy_name

!-------------------------------------------------------------------
!    arrays to hold data when not interpolating on every step:
real, dimension(:,:,:,:), allocatable :: sw_ext_save
real, dimension(:,:,:,:), allocatable :: sw_ssa_save
real, dimension(:,:,:,:), allocatable :: sw_asy_save
real, dimension(:,:,:,:), allocatable :: lw_ext_save
real, dimension(:,:,:,:), allocatable :: lw_ssa_save
real, dimension(:,:,:,:), allocatable :: lw_asy_save

!---------------------------------------------------------------------
!   module variables to hold values unchanging in time:
!---------------------------------------------------------------------
real, dimension(:,:), allocatable :: aerextband_MOD
real, dimension(:,:), allocatable :: aerssalbband_MOD
real, dimension(:,:), allocatable :: aerasymmband_MOD
real, dimension(:,:), allocatable :: aerextbandlw_MOD
real, dimension(:,:), allocatable :: aerssalbbandlw_MOD
real, dimension(:,:), allocatable :: aerextbandlw_cn_MOD
real, dimension(:,:), allocatable :: aerssalbbandlw_cn_MOD

!---------------------------------------------------------------------
!    logical variables indicating whether interpolation is currently
!    needed:
logical :: need_sw_ext = .true.
logical :: need_sw_ssa = .true.
logical :: need_sw_asy = .true.
logical :: need_lw_ext = .true.
logical :: need_lw_ssa = .true.
logical :: need_lw_asy = .true.

!---------------------------------------------------------------------
!    logical variables indicating whether the particular radiative 
!    property associated with volcanoes is being supplied:
logical :: using_sw_ext = .false. 
logical :: using_sw_ssa = .false. 
logical :: using_sw_asy = .false. 
logical :: using_lw_ext = .false. 
logical :: using_lw_ssa = .false. 
logical :: using_lw_asy = .false. 

!---------------------------------------------------------------------
!    counters associated with determining when interpolation needs to
!    be done:
logical :: mo_save_set = .false.
integer :: mo_save = 0
integer :: mo_new

type(time_type) :: Volcano_time
integer :: nfields_save
integer :: num_sul, num_bc
integer, dimension(:), allocatable :: sul_ind, bc_ind

!---------------------------------------------------------------------
!---------------------------------------------------------------------
 


                         contains
 

 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="aerosolrad_package_init">
!  <OVERVIEW>
!     aerosolrad_package_init is the constructor for 
!     aerosolrad_package_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!     aerosolrad_package_init is the constructor for 
!     aerosolrad_package_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call aerosolrad_package_init (aerosol_names)
!  </TEMPLATE>
!  <IN NAME="aerosol_names" TYPE="character">
!   names of the activated aerosol species
!  </IN>
! </SUBROUTINE>
!
subroutine aerosolrad_package_init (kmax, aerosol_names, lonb, latb)

!---------------------------------------------------------------------
!     aerosolrad_package_init is the constructor for 
!     aerosolrad_package_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!character(len=64), dimension(:), intent(in)  :: aerosol_names
integer,                        intent(in)  :: kmax
character(len=*), dimension(:), intent(in)  :: aerosol_names
real, dimension(:,:),           intent(in)  :: lonb,latb



!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      kmax              number of model levels
!      aerosol_names     the names assigned to each of the activated
!                        aerosol species
!       lonb           2d array of model longitudes at cell corners
!                      [ radians ]
!       latb           2d array of model latitudes at cell corners
!                      [ radians ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      integer        :: unit, ierr, io, logunit
      integer        :: n
      character(len=16) :: chvers
      character(len=4)  :: chyr  

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call mpp_io_init
      call fms_init
      call diag_manager_init
      call time_manager_init
      call rad_utilities_init
      call esfsw_parameters_init
      call longwave_params_init

       nfields_save = size(aerosol_names(:))

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=aerosolrad_package_nml, iostat=io)
      ierr = check_nml_error(io,'aerosolrad_package_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=aerosolrad_package_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'aerosolrad_package_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=aerosolrad_package_nml)

!---------------------------------------------------------------------
!   exit if aerosols are desired with the lacis-hansen parameterization.
!---------------------------------------------------------------------
     if (Sw_control%do_lhsw_iz) then
       if (Sw_control%do_lhsw .and. do_swaerosol) then
         call error_mesg ('aerosolrad_package_mod', &
         ' cannot activate sw aerosols with lhsw', FATAL)
        endif
     else
       call error_mesg ('aerosolrad_package_mod', &
        'Sw_control%do_lhsw not yet initialized', FATAL)
     endif

!----------------------------------------------------------------------
!    define control variables which indicate whether the impact of 
!    aerosols on radiation is to be included in the sw and lw rad-
!    iation calculations. define a control variable which will be true 
!    if aerosols are included in either the sw or the lw radiation 
!    (Rad_control%do_aerosol).
!----------------------------------------------------------------------
      Sw_control%do_swaerosol = do_swaerosol
      Lw_control%do_lwaerosol = do_lwaerosol
      if (Rad_control%do_lwaerosol_forcing_iz .and. &
          Rad_control%do_swaerosol_forcing_iz) then

      if (do_lwaerosol .or. do_swaerosol  .or.  &
          using_volcanic_lw_files .or. using_volcanic_sw_files .or. &
         Rad_control%do_lwaerosol_forcing .or.  &
         Rad_control%do_swaerosol_forcing)  then
        Rad_control%do_aerosol = .true.
      else
        Rad_control%do_aerosol = .false.
      endif
      else
        call error_mesg ('aerosolrad_package_mod', &
         ' using Rad_control%do_{l,s}waerosol_forcing  before it &
                                             &is defined', FATAL)
      endif

!--------------------------------------------------------------------
!    mark the just defined logicals as initialized.
!--------------------------------------------------------------------
      Sw_control%do_swaerosol_iz = .true.        
      Lw_control%do_lwaerosol_iz = .true.        
      Rad_control%do_aerosol_iz  = .true.
     
!----------------------------------------------------------------------
!    store the control variable indicating whether aerosol internal
!    mixture is being assumed.
!----------------------------------------------------------------------
      Rad_control%using_im_bcsul = using_im_bcsul
      Rad_control%using_im_bcsul_iz = .true.

!---------------------------------------------------------------------
!    exit if an aerosol_data_set is provided when do_aerosol is 
!    .false..
!---------------------------------------------------------------------
      if ( .not. Rad_control%do_aerosol .and.    &
           trim(aerosol_data_set) /= ' ') then
        call error_mesg ('aerosolrad_package_mod', &
           'if aerosol impacts are not desired, aerosol_data_set '//&
            'must be set to "   "', FATAL)
      endif

!---------------------------------------------------------------------
!    exit if no aerosol_data_set is provided when do_aerosol  
!    is .true..
!---------------------------------------------------------------------
      if ( Rad_control%do_aerosol .and.    &
           trim(aerosol_data_set) == ' ') then
        call error_mesg ('aerosolrad_package_mod', &
           'if aerosol impacts are desired, aerosol_data_set '//&
            'must be non-blank', FATAL)
      endif

!---------------------------------------------------------------------
!    exit if aerosol effects are desired but the aerosol input file
!    provided no aerosol fields.
!---------------------------------------------------------------------
      if (Rad_control%do_aerosol .and. size(aerosol_names(:)) == 0) then
        call error_mesg ('aerosolrad_package_mod', &
          ' aerosols desired  for radiation but no aerosol '//&
            'data_names supplied', FATAL)
      endif


!----------------------------------------------------------------------
!    if aerosol radiative effects are to be included, call 
!    assign_aerosol_opt_props to assign the proper aerosol 
!    properties type to each aerosol type. then call 
!    read_optical_input_file to read the optical input file contain-
!    ing the aerosol parameterization information and data.
!----------------------------------------------------------------------
      if (Rad_control%do_aerosol) then
        call assign_aerosol_opt_props (aerosol_names)
        call read_optical_input_file
      endif
 
!---------------------------------------------------------------------
!    if aerosol effects are to be included in the sw calculation,
!    call sw_aerosol_interaction to define the weights needed to prop-
!    erly map the input data from the aerosol parameterization bands to 
!    the solar parameterization bands that the model is using.
!--------------------------------------------------------------------
      if (do_swaerosol .or. Rad_control%do_swaerosol_forcing) then
        call sw_aerosol_interaction                 
      endif

!---------------------------------------------------------------------
!    if aerosol effects are to be included in the lw calculation,
!    call lw_aerosol_interaction to define the weights needed to prop-
!    erly map the input data from the aerosol parameterization bands to 
!    the solar parameterization bands that the model is using. if
!    they are not, indicate that this part of the code has been 
!    executed.
!---------------------------------------------------------------------
      if (do_lwaerosol .or. Rad_control%do_lwaerosol_forcing) then
        call lw_aerosol_interaction
      else
        Lw_parameters%n_lwaerosol_bands_iz = .true.
      endif

!---------------------------------------------------------------------
!    make sure consistent nml settings are present. Cannot use volcanic
!    aerosols unless model aerosols are also activated.
!---------------------------------------------------------------------
      if (.not. do_swaerosol  .and.   &
          using_volcanic_sw_files) then
        call error_mesg ('aerosolrad_package_mod', &
         'cant use sw volcanic aerosols without activating standard &
                                               & sw aerosols', FATAL)
      endif
      if (.not. do_lwaerosol  .and.   &
          using_volcanic_lw_files) then
        call error_mesg ('aerosolrad_package_mod', &
         'cant use lw volcanic aerosols without activating standard &
                                               & lw aerosols', FATAL)
      endif

!---------------------------------------------------------------------
!    set the volcanic control variables to .false. when the model 
!    aerosols are not active.
!---------------------------------------------------------------------
      Rad_control%volcanic_lw_aerosols = using_volcanic_lw_files
      Rad_control%volcanic_lw_aerosols_iz = .true.
      Rad_control%volcanic_sw_aerosols = using_volcanic_sw_files
      Rad_control%volcanic_sw_aerosols_iz = .true.

!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the volcanic files are
!    to be used; if not present, the dataset entry point is taken as
!    the model base_time, defined in the diag_table.
!---------------------------------------------------------------------
      Model_init_time = get_base_time()
      if (using_volcanic_sw_files .or.  &
          using_volcanic_lw_files) then
        if (volcanic_dataset_entry(1) == 1 .and. &
            volcanic_dataset_entry(2) == 1 .and. &
            volcanic_dataset_entry(3) == 1 .and. &
            volcanic_dataset_entry(4) == 0 .and. &
            volcanic_dataset_entry(5) == 0 .and. &
            volcanic_dataset_entry(6) == 0 ) then      
          Volcanic_entry = Model_init_time

!----------------------------------------------------------------------
!    define the offset from model base time  (defined in diag_table) 
!    to volcanic_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
      else
        Volcanic_entry  = set_date (volcanic_dataset_entry(1), &
                                    volcanic_dataset_entry(2), &
                                    volcanic_dataset_entry(3), &
                                    volcanic_dataset_entry(4), &
                                    volcanic_dataset_entry(5), &
                                    volcanic_dataset_entry(6))
       endif
     else
       Volcanic_entry  = set_date (volcanic_dataset_entry(1), &
                                   volcanic_dataset_entry(2), &
                                   volcanic_dataset_entry(3), &
                                   volcanic_dataset_entry(4), &
                                   volcanic_dataset_entry(5), &
                                   volcanic_dataset_entry(6))

      endif
      if (using_volcanic_sw_files .or.  &
          using_volcanic_lw_files) then
        if (repeat_volcano_year) then
          if (volcano_year_used == 0) then
            call error_mesg ('aerosolrad_package_init', &
              'valid year must be supplied when &
                       &repeat_volcano_year is .true.', FATAL)
          endif
        endif
        call print_date(Volcanic_entry , str='Data from volcano &
                                           &timeseries at time:')
        call print_date(Model_init_time , str='This data is mapped to &
                                                  &model time:')
        if (repeat_volcano_year) then
          write (chyr, '(i4)') volcano_year_used
          call error_mesg ('aerosolrad_package_init', &
           'volcanic data from dataset year '  // chyr // ' will be &
                                    &used for all model years.', NOTE)
        endif
      endif
      Volcanic_offset = Volcanic_entry - Model_init_time

      if (Model_init_time > Volcanic_entry) then
        negative_offset = .true.
      else
        negative_offset = .false.
      endif

!-----------------------------------------------------------------------
!    if desired, process the sw extinction coefficient file. allocate 
!    space for and define the names of each variable. if not interpol-
!    ating the data, allocate an array to store it between timesteps. 
!    call interpolator_init to initialize the interpolation module for
!    the file.
!-----------------------------------------------------------------------
      if (using_volcanic_sw_files) then
        if (trim(sw_ext_root) /= ' '  ) then
          nfields_sw_ext = Solar_spect%nbands
          allocate (sw_ext_name (nfields_sw_ext))
          if (.not. interpolating_volcanic_data) then
            allocate (sw_ext_save(size(lonb,1)-1, size(latb,2)-1, &
                                  kmax, nfields_sw_ext) )
            sw_ext_save = 0.0
          endif
          do n=1, nfields_sw_ext
            if (n<= 9) then
              write (chvers, '(i1)') n
             sw_ext_name(n) = trim(sw_ext_root) // '_b0' // trim(chvers)
            else if (n <= 99) then
              write (chvers, '(i2)') n
              sw_ext_name(n) = trim(sw_ext_root) // '_b' // trim(chvers)
            else 
              call error_mesg ('aerosolrad_package_mod', &
                  ' code only handles up to 100 fields', FATAL)
            endif
          end do
          call interpolator_init (Sw_aer_extopdep_interp,  &
                                  sw_ext_filename, lonb, latb,  &
                                  sw_ext_name(:nfields_sw_ext),   &
                                  data_out_of_bounds=(/CONSTANT/), &
                                  vert_interp=(/INTERP_WEIGHTED_P/) )  
          using_sw_ext = .true.
        endif

!--------------------------------------------------------------------
!    if desired, process the sw single scattering albedo file. allocate 
!    space for and define the names of each variable. if not interpol-
!    ating the data, allocate an array to store it between timesteps. 
!    call interpolator_init to initialize the interpolation module for
!    the file.
!-----------------------------------------------------------------------
        if (trim(sw_ssa_root) /= ' '  ) then
          nfields_sw_ssa = Solar_spect%nbands
          allocate (sw_ssa_name (nfields_sw_ssa))
          if (.not. interpolating_volcanic_data) then
            allocate (sw_ssa_save(size(lonb,1)-1, size(latb,2)-1, &
                                  kmax, nfields_sw_ssa) )
            sw_ssa_save = 0.0
          endif
          do n=1, nfields_sw_ssa
            if (n<= 9) then
              write (chvers, '(i1)') n
             sw_ssa_name(n) = trim(sw_ssa_root) // '_b0' // trim(chvers)
            else if (n <= 99) then
              write (chvers, '(i2)') n
              sw_ssa_name(n) = trim(sw_ssa_root) // '_b' // trim(chvers)
            else 
              call error_mesg ('aerosolrad_package_mod', &
                  ' code only handles up to 100 fields', FATAL)
            endif
          end do
          call interpolator_init (Sw_aer_ssalb_interp,   &
                                  sw_ssa_filename,  lonb, latb,    &
                                  sw_ssa_name(:nfields_sw_ssa),   &
                                  data_out_of_bounds=(/CONSTANT/), &
                                  vert_interp=(/INTERP_WEIGHTED_P/) ) 
          using_sw_ssa = .true.
        endif

!--------------------------------------------------------------------
!    if desired, process the sw asymmetry factor file. allocate 
!    space for and define the names of each variable. if not interpol-
!    ating the data, allocate an array to store it between timesteps. 
!    call interpolator_init to initialize the interpolation module for
!    the file.
!-----------------------------------------------------------------------
        if (trim(sw_asy_root)    /= ' '  ) then
          nfields_sw_asy = Solar_spect%nbands
          allocate (sw_asy_name (nfields_sw_asy))
          if (.not. interpolating_volcanic_data) then
            allocate (sw_asy_save(size(lonb,1)-1, size(latb,2)-1, &
                                  kmax, nfields_sw_asy) )
            sw_asy_save = 0.0
          endif
          do n=1, nfields_sw_asy
            if (n<= 9) then
              write (chvers, '(i1)') n
             sw_asy_name(n) = trim(sw_asy_root) // '_b0' // trim(chvers)
            else if (n <= 99) then
              write (chvers, '(i2)') n
              sw_asy_name(n) = trim(sw_asy_root) // '_b' // trim(chvers)
            else 
              call error_mesg ('aerosolrad_package_mod', &
                  ' code only handles up to 100 fields', FATAL)
            endif
          end do
          call interpolator_init (Sw_aer_asymm_interp,   &
                                  sw_asy_filename, lonb, latb,   &
                                  sw_asy_name(:nfields_sw_asy),   &
                                  data_out_of_bounds=(/CONSTANT/), &
                                  vert_interp=(/INTERP_WEIGHTED_P/) )  
          using_sw_asy = .true.
        endif
      endif

!-----------------------------------------------------------------------
!    if desired, process the lw extinction coefficient file. allocate 
!    space for and define the names of each variable. if not interpol-
!    ating the data, allocate an array to store it between timesteps. 
!    call interpolator_init to initialize the interpolation module for
!    the file.
!-----------------------------------------------------------------------
      if (using_volcanic_lw_files) then
        if (trim(lw_ext_root)    /= ' '  ) then
          nfields_lw_ext = N_AEROSOL_BANDS
          allocate (lw_ext_name (nfields_lw_ext))
          if (.not. interpolating_volcanic_data) then
            allocate (lw_ext_save(size(lonb,1)-1, size(latb,2)-1, &
                                  kmax, nfields_lw_ext) )
            lw_ext_save = 0.0
          endif
          do n=1, nfields_lw_ext
            if (n<= 9) then
              write (chvers, '(i1)') n
             lw_ext_name(n) = trim(lw_ext_root) // '_b0' // trim(chvers)
            else if (n <= 99) then
              write (chvers, '(i2)') n
              lw_ext_name(n) = trim(lw_ext_root) // '_b' // trim(chvers)
            else 
              call error_mesg ('aerosolrad_package_mod', &
                  ' code only handles up to 100 fields', FATAL)
            endif
          end do
          call interpolator_init (Lw_aer_extopdep_interp,   &
                                  lw_ext_filename, lonb,  latb,  &
                                  lw_ext_name(:nfields_lw_ext),   &
                                  data_out_of_bounds=(/CONSTANT/), &
                                  vert_interp=(/INTERP_WEIGHTED_P/) )
          using_lw_ext= .true.
        endif

!--------------------------------------------------------------------
!    if desired, process the lw single scattering albedo file.  it 
!    currently is not needed with the sea lw radiation package. allocate
!    space for and define the names of each variable. call 
!    interpolator_init to initialize the interpolation module for the 
!    file.
!-----------------------------------------------------------------------
        if (trim(lw_ssa_root)    /= ' '  ) then
          nfields_lw_ssa = N_AEROSOL_BANDS
          allocate (lw_ssa_name (nfields_lw_ssa))
          if (.not. interpolating_volcanic_data) then
            allocate (lw_ssa_save(size(lonb,1)-1, size(latb,2)-1, &
                                  kmax, nfields_lw_ssa) )
            lw_ssa_save = 0.0
          endif
          do n=1, nfields_lw_ssa
            if (n<= 9) then
              write (chvers, '(i1)') n
             lw_ssa_name(n) = trim(lw_ssa_root) // '_b0' // trim(chvers)
            else if (n <= 99) then
              write (chvers, '(i2)') n
              lw_ssa_name(n) = trim(lw_ssa_root) // '_b' // trim(chvers)
            else 
              call error_mesg ('aerosolrad_package_mod', &
                  ' code only handles up to 100 fields', FATAL)
            endif
          end do
          call interpolator_init (Lw_aer_ssalb_interp,  &
                                  lw_ssa_filename, lonb, latb,  &
                                  lw_ssa_name(:nfields_lw_ssa),   &
                                  data_out_of_bounds=(/CONSTANT/), &
                                  vert_interp=(/INTERP_WEIGHTED_P/) )  
          using_lw_ssa = .true.
        endif

!--------------------------------------------------------------------
!    if desired, process the lw asymmetry factor file.  it currently is
!    not needed with the sea lw radiation package. allocate space for 
!    and define the names of each variable. call interpolator_init to
!    initialize the interpolation module for the file.
!-----------------------------------------------------------------------
        if (trim(lw_asy_root)    /= ' '  ) then
          nfields_lw_asy = N_AEROSOL_BANDS
          allocate (lw_asy_name (nfields_lw_asy))
          if (.not. interpolating_volcanic_data) then
            allocate (lw_asy_save(size(lonb,1)-1, size(latb,2)-1, &
                                  kmax, nfields_lw_asy) )
            lw_asy_save = 0.0
          endif
          do n=1, nfields_lw_asy
            if (n<= 9) then
              write (chvers, '(i1)') n
             lw_asy_name(n) = trim(lw_asy_root) // '_b0' // trim(chvers)
            else if (n <= 99) then
              write (chvers, '(i2)') n
              lw_asy_name(n) = trim(lw_asy_root) // '_b' // trim(chvers)
            else 
              call error_mesg ('aerosolrad_package_mod', &
                  ' code only handles up to 100 fields', FATAL)
            endif
          end do
          call interpolator_init (Lw_aer_asymm_interp,   &
                                   lw_asy_filename,  lonb, latb,  &
                                   lw_asy_name(:nfields_lw_asy),   &
                                   data_out_of_bounds=(/CONSTANT/), &
                                   vert_interp=(/INTERP_WEIGHTED_P/) )  
          using_lw_asy = .true.
        endif
     endif

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!----------------------------------------------------------------------


end subroutine aerosolrad_package_init


!##########################################################################

subroutine aerosolrad_package_time_vary (Time)

!-------------------------------------------------------------------------
!    aerosolrad_package_time_vary performs time-dependent, space-independent
!    caluclations for this module
!-------------------------------------------------------------------------

type(time_type),         intent(in)   :: Time


      integer  :: yr, mo, dy, hr, mn, sc
    
!---------------------------------------------------------------------
!    define the time for which the volcanic properties will be obtained.
!---------------------------------------------------------------------
        if (using_volcanic_sw_files .or.   &
            using_volcanic_lw_files) then
          if (negative_offset) then
             Volcano_time = Time - Volcanic_offset
          else 
             Volcano_time = Time + Volcanic_offset
          endif
          if (repeat_volcano_year) then
            call get_date (Volcano_time, yr, mo, dy, hr, mn, sc)
            Volcano_time = set_date (volcano_year_used, mo,dy,hr,mn,sc)
          endif

!--------------------------------------------------------------------
!    decide whether the volcanic data must be interpolated on this step.
!    if interpolating_volcanic_data is true, then all variables will
!    always be interpolated. when this is not .true., determine if the
!    month of the data desired has changed from the previous value. if
!    it has set the Volcano_time to 12Z on the 15th of the month, and
!    indicate that new data is needed. On the initial call of the job,
!    one always obtains the data (mo_save_set = .false.).
!--------------------------------------------------------------------
          if (interpolating_volcanic_data) then
            need_sw_ext = .true.
            need_sw_ssa = .true.
            need_sw_asy = .true.
            need_lw_ext = .true.
            need_lw_ssa = .true.
            need_lw_asy = .true.
          else
            call get_date (Volcano_time, yr,mo,dy,hr,mn,sc)
            Volcano_time =  set_date (yr, mo,15,12,0,0)
            if (mo_save_set) then
              if (mo /= mo_save) then
                mo_new = mo       
                need_sw_ext = .true.
                need_sw_ssa = .true.
                need_sw_asy = .true.
                need_lw_ext = .true.
                need_lw_ssa = .true.
                need_lw_asy = .true.
              endif
            else
              need_sw_ext = .true.
              need_sw_ssa = .true.
              need_sw_asy = .true.
              need_lw_ext = .true.
              need_lw_ssa = .true.
              need_lw_asy = .true.
            endif
          endif
        endif ! (using_volcanic_lw or using_volcanic_sw)

!--------------------------------------------------------------------
!    if the volcanic sw aerosol extinction is being supplied, make sure
!    needed time slices are available.
!--------------------------------------------------------------------
        if (using_sw_ext) then
          if (need_sw_ext) then
            if (nfields_sw_ext >= 1) then
              call obtain_interpolator_time_slices  &
                              (Sw_aer_extopdep_interp, Volcano_Time)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic sw aerosol single scattering albedo is being 
!    supplied, make sure needed time slices are available.
!--------------------------------------------------------------------
        if (using_sw_ssa) then
          if (need_sw_ssa) then
            if (nfields_sw_ssa >= 1) then
              call obtain_interpolator_time_slices  &
                              (Sw_aer_ssalb_interp, Volcano_Time)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic sw aerosol asymmetry factor is being supplied, 
!    make sure needed time slices are available.
!--------------------------------------------------------------------
        if (using_sw_asy) then
          if (need_sw_asy) then
            if (nfields_sw_asy >= 1) then
              call obtain_interpolator_time_slices  &
                              (Sw_aer_asymm_interp, Volcano_Time)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic lw aerosol extinction is being supplied, 
!    make sure needed time slices are available.
!--------------------------------------------------------------------
        if (using_lw_ext) then
          if (need_lw_ext) then
            if (nfields_lw_ext >= 1) then
              call obtain_interpolator_time_slices  &
                              (Lw_aer_extopdep_interp, Volcano_Time)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic lw single scattering albedo is being supplied, 
!    make sure needed time slices are available.
!--------------------------------------------------------------------
        if (using_lw_ssa) then
          if (need_lw_ssa) then
            if (nfields_lw_ssa >= 1) then
              call obtain_interpolator_time_slices  &
                              (Lw_aer_ssalb_interp, Volcano_Time)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic lw aerosol asymmetry factor is being supplied, 
!    obtain the appropriate data.
!--------------------------------------------------------------------
        if (using_lw_asy) then
          if (need_lw_asy) then
            if (nfields_lw_asy >= 1) then
              call obtain_interpolator_time_slices  &
                              (Lw_aer_asymm_interp, Volcano_Time)
            endif
          endif
        endif

!---------------------------------------------------------------------------


end subroutine aerosolrad_package_time_vary 

!######################################################################

subroutine aerosolrad_package_alloc (ix, jx, kx, Aerosol_props)

integer,                       intent(in) :: ix, jx, kx
type(aerosol_properties_type), intent(inout) :: Aerosol_props


        if (Rad_control%volcanic_sw_aerosols) then
          allocate (Aerosol_props%sw_ext (ix,jx,kx, nfields_sw_ext))
          allocate (Aerosol_props%sw_ssa (ix,jx,kx,nfields_sw_ssa))
          allocate (Aerosol_props%sw_asy (ix,jx,kx,nfields_sw_asy))
        endif
        if (Rad_control%volcanic_lw_aerosols) then
          allocate (Aerosol_props%lw_ext (ix,jx,kx, nfields_lw_ext))
          allocate (Aerosol_props%lw_ssa (ix,jx,kx,nfields_lw_ssa))
          allocate (Aerosol_props%lw_asy (ix,jx,kx,nfields_lw_asy))
        endif
        allocate (Aerosol_props%ivol(ix,jx,kx))
        if (Rad_control%do_swaerosol_forcing .or.  &
                                         Sw_control%do_swaerosol) then
          allocate (Aerosol_props%aerextband   &
                                      (Solar_spect%nbands, naermodels))
          allocate (Aerosol_props%aerssalbband &
                                      (Solar_spect%nbands, naermodels))
          allocate (Aerosol_props%aerasymmband &
                                      (Solar_spect%nbands, naermodels))
        endif
        if (Rad_control%do_lwaerosol_forcing .or.  &
                                         Lw_control%do_lwaerosol) then
          allocate (Aerosol_props%aerextbandlw  &
                                      (N_AEROSOL_BANDS, naermodels))
          allocate (Aerosol_props%aerssalbbandlw  &
                                      (N_AEROSOL_BANDS, naermodels))
          allocate (Aerosol_props%aerextbandlw_cn &
                                      (N_AEROSOL_BANDS_CN, naermodels))
          allocate (Aerosol_props%aerssalbbandlw_cn  &
                                      (N_AEROSOL_BANDS_CN, naermodels))
        endif
        if (Rad_control%using_im_bcsul) then
          allocate (Aerosol_props%sulfate_index (0:100, 0:100))
        else
          allocate (Aerosol_props%sulfate_index (0:100, 0:0))
        endif
        allocate (Aerosol_props%optical_index (nfields_save))
        allocate (Aerosol_props%omphilic_index(0:100))
        allocate (Aerosol_props%bcphilic_index(0:100))
        allocate (Aerosol_props%seasalt1_index(0:100))
        allocate (Aerosol_props%seasalt2_index(0:100))
        allocate (Aerosol_props%seasalt3_index(0:100))
        allocate (Aerosol_props%seasalt4_index(0:100))
        allocate (Aerosol_props%seasalt5_index(0:100))

!--------------------------------------------------------------------


end subroutine aerosolrad_package_alloc


subroutine aerosolrad_package_endts

!---------------------------------------------------------------------
!    when data is not always interpolated, set flags to indicate whether
!    data must be obtained on the next call to this subroutine. if 
!    the current call has obtained data, set the flag indicating that 
!    data is not needed on the next call. also set the flag to indicate 
!    that the initial call has been completed (mo_save_set), and that 
!    the month for which data was obtained has been defined (mo_save). 
!---------------------------------------------------------------------
        if (.not. interpolating_volcanic_data) then
          if (need_sw_ext) then
              need_sw_ext = .false.
              need_sw_ssa = .false.
              need_sw_asy = .false.
              need_lw_ext = .false.
              mo_save_set = .true.
              mo_save = mo_new
          endif
        endif

      if (using_sw_ext) then
        call unset_interpolator_time_flag (Sw_aer_extopdep_interp)
      endif
      if (using_sw_ssa) then
        call unset_interpolator_time_flag (Sw_aer_ssalb_interp)
      endif
      if (using_sw_asy) then
        call unset_interpolator_time_flag (Sw_aer_asymm_interp)
      endif
      if (using_lw_ext) then
        call unset_interpolator_time_flag (Lw_aer_extopdep_interp)
      endif
      if (using_sw_ssa) then
        call unset_interpolator_time_flag (Lw_aer_ssalb_interp)
      endif
      if (using_sw_asy) then
        call unset_interpolator_time_flag (Lw_aer_asymm_interp)
      endif

end subroutine aerosolrad_package_endts


!####################################################################
! <SUBROUTINE NAME="aerosol_radiative_properties">
!  <OVERVIEW>
!    aerosol_radiative_properties defines and returns the radiative
!    properties for each aerosol properties type and for each solar
!    parameterization band in the shortwave and for each aerosol 
!    emissivity band in the longwave.
!  </OVERVIEW>
!  <DESCRIPTION>
!    aerosol_radiative_properties defines and returns the radiative
!    properties for each aerosol properties type and for each solar
!    parameterization band in the shortwave and for each aerosol 
!    emissivity band in the longwave.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call aerosol_radiative_properties (is, ie, js, je, &
!                                         Aerosol, Aerosol_props)
!  </TEMPLATE>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol climatology input
!  </IN>
!  <INOUT NAME="Aerosol_props" TYPE="aerosol_properties_type">
!   Aerosol radiative properties in radiation package
!  </INOUT>
!  <IN NAME="is, ie" TYPE="integer">
!   The longitude index of model physics window domain
!  </IN>
!  <IN NAME="js, je" TYPE="integer">
!   The latitude index of model physics window domain
!  </IN>
! </SUBROUTINE>
!
subroutine aerosol_radiative_properties (is, ie, js, je, &
                                         Time, p_half, Aerosol_diags, &
                                         Aerosol, Aerosol_props)

!---------------------------------------------------------------------
!    aerosol_radiative_properties defines and returns the radiative
!    properties for each aerosol properties type and for each solar
!    parameterization band in the shortwave and for each aerosol 
!    emissivity band in the longwave.
!---------------------------------------------------------------------

integer,                       intent(in)    :: is, ie, js, je
type(time_type),               intent(in)    :: Time
real, dimension(:,:,:),        intent(in)    :: p_half
type(aerosol_type),            intent(in)    :: Aerosol
type(aerosol_diagnostics_type), intent(inout) :: Aerosol_diags
type(aerosol_properties_type), intent(inout) :: Aerosol_props
 
!----------------------------------------------------------------------
! local variables:                                                     

      integer  :: na, nw, ni       ! do-loop indices
      integer  :: iaer, i, j, k
      real, dimension (size(Aerosol%aerosol,1),  &
                       size(Aerosol%aerosol,2),  &
                       size(Aerosol%aerosol,3))  :: sul, bc
     
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('aerosolrad_package_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    allocate and initialize arrays to hold aerosol diagnostics.
!---------------------------------------------------------------------
      allocate (Aerosol_diags%extopdep (size(Aerosol%aerosol,1), &
                                        size(Aerosol%aerosol,2), &
                                        size(Aerosol%aerosol,3), &
                                        size(Aerosol%aerosol,4), 10 ))
      Aerosol_diags%extopdep = 0.0
      allocate (Aerosol_diags%absopdep (size(Aerosol%aerosol,1), &
                                        size(Aerosol%aerosol,2), &
                                        size(Aerosol%aerosol,3), &
                                        size(Aerosol%aerosol,4), 10 ))
      Aerosol_diags%absopdep = 0.0
      allocate (Aerosol_diags%asymdep (size(Aerosol%aerosol,1), &
                                       size(Aerosol%aerosol,2), &
                                       size(Aerosol%aerosol,3), &
                                       size(Aerosol%aerosol,4), 10 ))
      Aerosol_diags%asymdep = 0.0
      allocate (Aerosol_diags%extopdep_vlcno    &
                                        (size(Aerosol%aerosol,1), &
                                         size(Aerosol%aerosol,2), &
                                         size(Aerosol%aerosol,3),3))
      Aerosol_diags%extopdep_vlcno = 0.0
      allocate (Aerosol_diags%absopdep_vlcno  &
                                        (size(Aerosol%aerosol,1), &
                                         size(Aerosol%aerosol,2), &
                                         size(Aerosol%aerosol,3),3))
      Aerosol_diags%absopdep_vlcno = 0.0
      allocate (Aerosol_diags%sw_heating_vlcno  &
                                        (size(Aerosol%aerosol,1), &
                                         size(Aerosol%aerosol,2), &
                                         size(Aerosol%aerosol,3), &
                                         Rad_control%nzens))
      Aerosol_diags%sw_heating_vlcno = 0.0
      allocate (Aerosol_diags%lw_extopdep_vlcno    &
                                        (size(Aerosol%aerosol,1), &
                                         size(Aerosol%aerosol,2), &
                                         size(Aerosol%aerosol,3)+1,2))
      Aerosol_diags%lw_extopdep_vlcno = 0.0
      allocate (Aerosol_diags%lw_absopdep_vlcno  &
                                        (size(Aerosol%aerosol,1), &
                                         size(Aerosol%aerosol,2), &
                                         size(Aerosol%aerosol,3)+1,2))
      Aerosol_diags%lw_absopdep_vlcno = 0.0


!--------------------------------------------------------------------
!    if the volcanic sw aerosol extinction is being supplied, obtain
!    the appropriate data.
!--------------------------------------------------------------------
        if (using_sw_ext) then

!---------------------------------------------------------------------
!    if new sw extinction data is needed on this step, call interpolator
!    to obtain it.  if the data is not to be interpolated, save the
!    retrieved values in a module variable.
!---------------------------------------------------------------------
          if (need_sw_ext) then
            if (nfields_sw_ext >= 1) then
              call interpolator (Sw_aer_extopdep_interp, Volcano_Time, &
                                 p_half, Aerosol_props%sw_ext,    &
                                 sw_ext_name(1), is, js)
            endif
            if (.not. interpolating_volcanic_data) then
              sw_ext_save(is:ie,js:je,:,:) = Aerosol_props%sw_ext
            endif

!---------------------------------------------------------------------
!    if new data from the file is not needed on this step, then retrieve
!    the relevant data from the storage variable.
!---------------------------------------------------------------------
          else
            if ( .not. interpolating_volcanic_data) then
              Aerosol_props%sw_ext = sw_ext_save(is:ie,js:je,:,:)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic sw aerosol single scattering albedo is being 
!    supplied, obtain the appropriate data.
!--------------------------------------------------------------------
        if (using_sw_ssa) then

!---------------------------------------------------------------------
!    if new sw single scattering albedo data is needed on this step, 
!    call interpolator to obtain it.  if the data is not to be inter-
!    polated, save the retrieved values in a module variable.
!---------------------------------------------------------------------
          if (need_sw_ssa) then
            if (nfields_sw_ssa >= 1) then
              call interpolator (Sw_aer_ssalb_interp, Volcano_Time, &
                                 p_half, Aerosol_props%sw_ssa,    &
                                 sw_ssa_name(1), is, js)
            endif
            if ( .not. interpolating_volcanic_data) then
              sw_ssa_save(is:ie,js:je,:,:) = Aerosol_props%sw_ssa
            endif

!---------------------------------------------------------------------
!    if new data from the file is not needed on this step, then retrieve
!    the relevant data from the storage variable.
!---------------------------------------------------------------------
          else
            if ( .not. interpolating_volcanic_data) then
              Aerosol_props%sw_ssa = sw_ssa_save(is:ie,js:je,:,:)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic sw aerosol asymmetry factor is being supplied, 
!    obtain the appropriate data.
!--------------------------------------------------------------------
        if (using_sw_asy) then

!---------------------------------------------------------------------
!    if new sw asymmetry factor data is needed on this step, call 
!    interpolator to obtain it.  if the data is not to be interpolated,
!    save the retrieved values in a module variable.
!---------------------------------------------------------------------
          if (need_sw_asy) then
            if (nfields_sw_asy >= 1) then
              call interpolator (Sw_aer_asymm_interp, Volcano_Time, &
                                 p_half, Aerosol_props%sw_asy,    &
                                 sw_asy_name(1), is, js)
            endif
            if ( .not. interpolating_volcanic_data) then
              sw_asy_save(is:ie,js:je,:,:) = Aerosol_props%sw_asy
            endif

!---------------------------------------------------------------------
!    if new data from the file is not needed on this step, then retrieve
!    the relevant data from the storage variable.
!---------------------------------------------------------------------
          else
            if (.not. interpolating_volcanic_data) then
              Aerosol_props%sw_asy = sw_asy_save(is:ie,js:je,:,:)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic lw aerosol extinction is being supplied, obtain
!    the appropriate data.
!--------------------------------------------------------------------
        if (using_lw_ext) then

!---------------------------------------------------------------------
!    if new lw extinction data is needed on this step, call interpolator
!    to obtain it.  if the data is not to be interpolated, save the
!    retrieved values in a module variable.
!---------------------------------------------------------------------
          if (need_lw_ext) then
            if (nfields_lw_ext >= 1) then
              call interpolator (Lw_aer_extopdep_interp, Volcano_Time, &
                                 p_half, Aerosol_props%lw_ext,    &
                                 lw_ext_name(1), is, js)
            endif
            if (.not. interpolating_volcanic_data) then
              lw_ext_save(is:ie,js:je,:,:) = Aerosol_props%lw_ext
            endif

!---------------------------------------------------------------------
!    if new data from the file is not needed on this step, then retrieve
!    the relevant data from the storage variable.
!---------------------------------------------------------------------
          else
            if ( .not. interpolating_volcanic_data) then
              Aerosol_props%lw_ext = lw_ext_save(is:ie,js:je,:,:)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic lw single scattering albedo is being supplied, 
!    obtain the appropriate data.
!--------------------------------------------------------------------
        if (using_lw_ssa) then

!---------------------------------------------------------------------
!    if new lw single scattering albedo data is needed on this step, 
!    call interpolator to obtain it.  if the data is not to be inter-
!    polated, save the retrieved values in a module variable.
!---------------------------------------------------------------------
          if (need_lw_ssa) then
            if (nfields_lw_ssa >= 1) then
              call interpolator (Lw_aer_ssalb_interp, Volcano_Time, &
                                 p_half, Aerosol_props%lw_ssa,    &
                                 lw_ssa_name(1), is, js)
            endif
            if ( .not. interpolating_volcanic_data) then
              lw_ssa_save(is:ie,js:je,:,:) = Aerosol_props%lw_ssa
            endif

!---------------------------------------------------------------------
!    if new data from the file is not needed on this step, then retrieve
!    the relevant data from the storage variable.
!---------------------------------------------------------------------
          else
            if ( .not. interpolating_volcanic_data) then
              Aerosol_props%lw_ssa = lw_ssa_save(is:ie,js:je,:,:)
            endif
          endif
        endif

!--------------------------------------------------------------------
!    if the volcanic lw aerosol asymmetry factor is being supplied, 
!    obtain the appropriate data.
!--------------------------------------------------------------------
        if (using_lw_asy) then

!---------------------------------------------------------------------
!    if new lw asymmetry factor data is needed on this step, call 
!    interpolator to obtain it.  if the data is not to be interpolated, 
!    save the retrieved values in a module variable.
!---------------------------------------------------------------------
          if (need_lw_asy) then
            if (nfields_lw_asy >= 1) then
              call interpolator (Lw_aer_asymm_interp, Volcano_Time, &
                                 p_half, Aerosol_props%lw_asy,    &
                                 lw_asy_name(1), is, js)
            endif
            if (.not. interpolating_volcanic_data) then
              lw_asy_save(is:ie,js:je,:,:) = Aerosol_props%lw_asy
            endif

!---------------------------------------------------------------------
!    if new data from the file is not needed on this step, then retrieve
!    the relevant data from the storage variable.
!---------------------------------------------------------------------
          else
            if (.not. interpolating_volcanic_data) then
              Aerosol_props%lw_asy = lw_asy_save(is:ie,js:je,:,:)
            endif
          endif
        endif

!---------------------------------------------------------------------
!    code for treating sulfate and black carbon as an internal aerosol
!    mixture.
!---------------------------------------------------------------------
        if (Rad_control%using_im_bcsul) then
          if (num_sul > 0) then
            sul(:,:,:) = Aerosol%aerosol(:,:,:,sul_ind(1))
            do iaer=2,num_sul
              sul(:,:,:) = sul(:,:,:) +    &
                                Aerosol%aerosol(:,:,:,sul_ind(iaer))
            end do
          else
            sul = 0.
          endif
          if (num_bc > 0) then
            bc(:,:,:) = Aerosol%aerosol(:,:,:,bc_ind(1))
            do iaer=2,num_bc
              bc(:,:,:) = bc(:,:,:) +    &
                                Aerosol%aerosol(:,:,:,bc_ind(iaer))
            end do
          else
            bc = 0.
          endif
          do k = 1,size(Aerosol%aerosol,3)
            do j = 1,size(Aerosol%aerosol,2)
              do i = 1,size(Aerosol%aerosol,1)
                if (bc(i,j,k) > 0 .and. sul(i,j,k) > 0.0) then
                  Aerosol_props%ivol(i,j,k) = 100-MIN(100, MAX( 0,     &
                   NINT(100.*sul(i,j,k)/(sul(i,j,k) +bc(i,j,k)*1.74))))
                else
                  Aerosol_props%ivol(i,j,k) = 0
                end if
              enddo
            end do
          end do
        else
          Aerosol_props%ivol = 0
        endif ! (using_im_bcsul)

!---------------------------------------------------------------------
!    fill the remaining components of the aerosol_properties_type var-
!    iable and return to the calling routine. this variable contains 
!    the aerosol radiative properties for each aerosol properties type 
!    over each solar and aerosol emissivity band.
!---------------------------------------------------------------------
        if (Rad_control%do_swaerosol_forcing .or.  &
                                         Sw_control%do_swaerosol) then
          Aerosol_props%aerextband = aerextband_MOD
          Aerosol_props%aerssalbband = aerssalbband_MOD
          Aerosol_props%aerasymmband = aerasymmband_MOD
        endif

!---------------------------------------------------------------------
!    if longwave aerosol effects are desired, and the following cal-
!    culation has not already been done, calculate the aerosol 
!    properties for each aerosol properties type nw over each aerosol 
!    emissivity band na using the weighted contributions from each
!    aerosol parameterization band ni. mark the calculation as com-
!    pleted.
!
!    the units of extinction coefficient (aeroextivl) are m**2/gm.
!    to make the lw band extinction coefficient (aerextbandlw) have
!    units (m**2/Kg) consistent with the units in FMS models, one
!    must multiply by 1000. this is done below.
!---------------------------------------------------------------------
        if (Rad_control%do_lwaerosol_forcing .or. &
                Lw_control%do_lwaerosol) then
!$OMP MASTER
          if (force_to_repro_quebec) then
            if (.not. band_calculation_completed) then
              Aerosol_props%aerextbandlw = 0.0               
              Aerosol_props%aerssalbbandlw = 0.0                 
              Aerosol_props%aerextbandlw_cn = 0.0
              Aerosol_props%aerssalbbandlw_cn = 0.0
              do nw=1,naermodels    
                do na=1,N_AEROSOL_BANDS  
                  do ni=1,num_wavenumbers 
                    Aerosol_props%aerextbandlw(na,nw) =   &
                               Aerosol_props%aerextbandlw(na,nw) + &
                                aeroextivl(ni,nw)*sflwwts(na,ni)*1.0E+03
                    Aerosol_props%aerssalbbandlw(na,nw) =   &
                              Aerosol_props%aerssalbbandlw(na,nw) +   &
                                     aerossalbivl(ni,nw)*sflwwts(na,ni)
                  end do
                end do
              end do
              do nw=1,naermodels    
                do na=1,N_AEROSOL_BANDS_CN
                  do ni=1,num_wavenumbers 
                    Aerosol_props%aerextbandlw_cn(na,nw) = &
                         Aerosol_props%aerextbandlw_cn(na,nw) + &
                            aeroextivl(ni,nw)*sflwwts_cn(na,ni)*1.0E+03
                    Aerosol_props%aerssalbbandlw_cn(na,nw) =    &
                               Aerosol_props%aerssalbbandlw_cn(na,nw) +&
                                  aerossalbivl(ni,nw)*sflwwts_cn(na,ni)
                  end do
                end do
              end do

              aerextbandlw_MOD = Aerosol_props%aerextbandlw
              aerssalbbandlw_MOD = Aerosol_props%aerssalbbandlw
              aerextbandlw_cn_MOD = Aerosol_props%aerextbandlw_cn
              aerssalbbandlw_cn_MOD = Aerosol_props%aerssalbbandlw_cn
              band_calculation_completed = .true.
            endif
          endif
!$OMP END MASTER
          Aerosol_props%aerextbandlw = aerextbandlw_MOD
          Aerosol_props%aerssalbbandlw = aerssalbbandlw_MOD
          Aerosol_props%aerextbandlw_cn = aerextbandlw_cn_MOD
          Aerosol_props%aerssalbbandlw_cn = aerssalbbandlw_cn_MOD
        endif
        Aerosol_props%sulfate_index = sulfate_index
        Aerosol_props%optical_index = optical_index
        Aerosol_props%omphilic_index =omphilic_index
        Aerosol_props%bcphilic_index =bcphilic_index
        Aerosol_props%seasalt1_index =seasalt1_index
        Aerosol_props%seasalt2_index =seasalt2_index
        Aerosol_props%seasalt3_index =seasalt3_index
        Aerosol_props%seasalt4_index =seasalt4_index
        Aerosol_props%seasalt5_index =seasalt5_index
        Aerosol_props%sulfate_flag =   SULFATE_FLAG
        Aerosol_props%omphilic_flag =  OMPHILIC_FLAG
        Aerosol_props%bcphilic_flag =  BCPHILIC_FLAG
        Aerosol_props%seasalt1_flag =  SEASALT1_FLAG
        Aerosol_props%seasalt2_flag =  SEASALT2_FLAG
        Aerosol_props%seasalt3_flag =  SEASALT3_FLAG
        Aerosol_props%seasalt4_flag =  SEASALT4_FLAG
        Aerosol_props%seasalt5_flag =  SEASALT5_FLAG
        if (Rad_control%using_im_bcsul) then
          Aerosol_props%bc_flag = BC_FLAG
        else
          Aerosol_props%bc_flag = NOT_IN_USE
        endif

end subroutine aerosol_radiative_properties


!#####################################################################
! <SUBROUTINE NAME="aerosolrad_package_end">
!  <OVERVIEW>
!    aerosolrad_package_end is the destructor for 
!    aerosolrad_package_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    aerosolrad_package_end is the destructor for 
!    aerosolrad_package_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call aerosolrad_package_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine aerosolrad_package_end

!--------------------------------------------------------------------
!    aerosolrad_package_end is the destructor for 
!    aerosolrad_package_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('aerosolrad_package_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    deallocate module variables.
!---------------------------------------------------------------------
      if (do_swaerosol .or. Rad_control%do_swaerosol_forcing) then      
        deallocate (solivlaero, nivl1aero, nivl2aero, endaerwvnsf, &
                    aeroextivl, aerossalbivl, aeroasymmivl)
      endif
      if (do_lwaerosol .or. Rad_control%do_lwaerosol_forcing) then
        deallocate ( sflwwts)
        deallocate ( sflwwts_cn)
      endif
      
!---------------------------------------------------------------------
!    deallocate elements of the aerosol_properties_type array.
!---------------------------------------------------------------------
      if (allocated(sulfate_index )) deallocate(sulfate_index )
      if (allocated(bcphilic_index)) deallocate(bcphilic_index)
      if (allocated(omphilic_index)) deallocate(omphilic_index)
      if (allocated(seasalt1_index)) deallocate(seasalt1_index)
      if (allocated(seasalt2_index)) deallocate(seasalt2_index)
      if (allocated(seasalt3_index)) deallocate(seasalt3_index)
      if (allocated(seasalt4_index)) deallocate(seasalt4_index)
      if (allocated(seasalt5_index)) deallocate(seasalt5_index)
      if (allocated(optical_index )) deallocate(optical_index )

      
      if (Rad_control%volcanic_lw_aerosols) then
        if (nfields_lw_ext /= 0) then
          call interpolator_end (Lw_aer_extopdep_interp)
        endif
        if (nfields_lw_ssa /= 0) then
        call interpolator_end (Lw_aer_ssalb_interp)
        endif
        if (nfields_lw_asy /= 0) then
        call interpolator_end (Lw_aer_asymm_interp)
        endif
      endif

      if (Rad_control%volcanic_sw_aerosols) then
        if (nfields_sw_ext /= 0) then
        call interpolator_end (Sw_aer_extopdep_interp)
        endif
        if (nfields_sw_ssa /= 0) then
        call interpolator_end (Sw_aer_ssalb_interp)
        endif
        if (nfields_sw_asy /= 0) then
        call interpolator_end (Sw_aer_asymm_interp)
        endif
      endif

      if (.not. interpolating_volcanic_data) then
        deallocate (sw_ext_save, sw_ssa_save, sw_asy_save, &
                    lw_ext_save, lw_ssa_save, lw_asy_save)
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.




end subroutine aerosolrad_package_end


!####################################################################
! <SUBROUTINE NAME="get_aerosol_optical_info">
!  <OVERVIEW>
!    get_aerosol_optical_info accesses data stored by this module.
!  </OVERVIEW>
!  <DESCRIPTION>
!    get_aerosol_optical_info accesses data stored by this module.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_aerosol_optical_info( num_categories, nwavenumbers, &
!                                     names, wavenumbers, &
!                                     aer_ext, aer_ss_alb, aer_asymm)
!  </TEMPLATE>
!  <OUT NAME="num_categories" TYPE="integer">
!   number of aerosol properties types
!  </OUT>
!  <OUT NAME="nwavenumbers" TYPE="integer">
!   number of wavenumber bands over which
!                           aerosol properties are defined
!  </OUT>
!  <OUT NAME="names" TYPE="character">
!   names assigned to the optical properties types
!  </OUT>
!  <OUT NAME="wavenumbers" TYPE="real">
!   wavenumber limits for each of the bands for
!                           which aerosol properties are defined
!  </OUT>
!  <OUT NAME="aer_ext, aer_ss_alb, aer_asymm" TYPE="real">
!   Aerosol extinction coefficient, single scattering albedo, and
!   asymmetry parameter
!  </OUT>
! </SUBROUTINE>
!
subroutine get_aerosol_optical_info( num_categories, nwavenumbers, &
                                     names, wavenumbers, &
                                     aer_ext, aer_ss_alb, aer_asymm)

!-----------------------------------------------------------------------
!    get_aerosol_optical_info accesses data stored by this module.
!-----------------------------------------------------------------------

integer,                        intent(out), optional ::       &
                                            num_categories, nwavenumbers
character(len=*), dimension(:), intent(out), optional :: names
integer, dimension(:),          intent(out), optional :: wavenumbers
real, dimension(:,:),           intent(out), optional :: aer_ext, &
                                                         aer_ss_alb, &
                                                         aer_asymm

!----------------------------------------------------------------------
!   intent(out), optional variables:
!
!      num_categories       number of aerosol properties types
!      nwavenumbers         number of wavenumber bands over which
!                           aerosol properties are defined
!      names                names assigned to the optical properties 
!                           types
!      wavenumbers          wavenumber limits for each of the bands for
!                           which aerosol properties are defined
!      aer_ext              extinction coefficient for each aerosol
!                           spectral band and each aerosol optical 
!                           property type
!      aer_ss_ab            single-scattering albedo for each aerosol 
!                           band and each aerosol optical property type 
!      aer_asymm            asymmetry factor for each aerosol band and 
!                           each aerosol optical property type
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('aerosolrad_package_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    define the desired output variables.
!---------------------------------------------------------------------
      if( present(num_categories) ) num_categories = naermodels
      if( present(nwavenumbers))    nwavenumbers   = num_wavenumbers
      if( present(names) )          names(:naermodels) =    &
                                     aerosol_optical_names(:naermodels)
      if( present(wavenumbers) )    wavenumbers(:num_wavenumbers) =  &
                                           endaerwvnsf(:num_wavenumbers)
      if( present(aer_ext) )        aer_ext(:,:)    = aeroextivl(:,:)
      if( present(aer_ss_alb) )     aer_ss_alb(:,:) = aerossalbivl(:,:)
      if( present(aer_asymm) )      aer_asymm(:,:)  = aeroasymmivl(:,:)

!---------------------------------------------------------------------

end subroutine get_aerosol_optical_info


!######################################################################
! <SUBROUTINE NAME="get_aerosol_optical_index">
!  <OVERVIEW>
!    get_aerosol_optical_index returns the aerosol optical property
!    index for given aerosol number and relative humidity.
!  </OVERVIEW>
!  <DESCRIPTION>
!    get_aerosol_optical_index returns the aerosol optical property
!    index for given aerosol number and relative humidity.
!  </DESCRIPTION>
!  <TEMPLATE>
!   index = get_aerosol_optical_index( name, naerosol, rh )
!  </TEMPLATE>
!  <IN NAME="name" TYPE="real">
!   aerosol species name for which the optical 
!                      properties index is desired
!  </IN>
!  <IN NAME="naerosol" TYPE="integer">
!   aerosol index of the aerosol for whoch the 
!                      optical properties index is desired
!  </IN>
!  <IN NAME="rh" TYPE="real">
!    relative humidity 
!  </IN>
! </SUBROUTINE>
!
function get_aerosol_optical_index( name, naerosol, rh ) result(index)

!-----------------------------------------------------------------------
!    get_aerosol_optical_index returns the aerosol optical property
!    index for given aerosol number and relative humidity.
!-----------------------------------------------------------------------

character(len=*),         intent(in) :: name
integer,                   intent(in) :: naerosol
real,                      intent(in) :: rh
integer                               :: index  ! function value

!----------------------------------------------------------------------
!   intent(in) variables:
!
!      name            aerosol species name for which the optical 
!                      properties index is desired
!      naerosol        aerosol index of the aerosol for whoch the 
!                      optical properties index is desired
!      rh              relative humidity 
!
!  function value
!
!      index           returned optical properties index for aerosol
!                      name (aerosol index = naerosol) when the 
!                      relative humidity is rh
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer   :: irh     ! integer value for relative humidity, 
                           ! used as an index
      integer   :: nfields ! total number of active aerosols

!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'aerosolrad_package_mod',  &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    be sure the desired aerosol index is valid.
!---------------------------------------------------------------------
      nfields = size(optical_index(:),1)
      if (naerosol > nfields) then
        call error_mesg( 'aerosolrad_package_mod', &
           'aerosol index exceeds number of aerosol fields', FATAL )
      end if

!---------------------------------------------------------------------
!    Determine if the desired aerosol is a hydrophilic or not. 
!    If the aerosol is hydrophilic, then the optical propeties 
!    index will depend on the relative humidity.
!---------------------------------------------------------------------
      if (optical_index(naerosol) == SULFATE_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
!yim no vol info is passed here now. Set 0 for now.
        index = sulfate_index( irh, 0 )
      elseif (optical_index(naerosol) == BC_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
!yim no vol info is passed here now. Set 0 for now.
        index = sulfate_index( irh, 0 )
      elseif (optical_index(naerosol) == &
                                               OMPHILIC_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
        index = omphilic_index( irh )
      elseif (optical_index(naerosol) ==   &
                  BCPHILIC_FLAG .and. Rad_control%using_im_bcsul ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
!yim
        index = sulfate_index( irh, 0 )
      elseif (optical_index(naerosol) == BCPHILIC_FLAG  &
                        .and. .not. Rad_control%using_im_bcsul ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
!yim
        index = bcphilic_index( irh )
      elseif (optical_index(naerosol) ==    &
                                               SEASALT1_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
        index = seasalt1_index( irh )
      elseif (optical_index(naerosol) ==  &            
                                               SEASALT2_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
        index = seasalt2_index( irh )
      elseif (optical_index(naerosol) ==  &            
                                               SEASALT3_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
        index = seasalt3_index( irh )
      elseif (optical_index(naerosol) ==  &           
                                               SEASALT4_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
        index = seasalt4_index( irh )
      elseif (optical_index(naerosol) ==  &           
                                               SEASALT5_FLAG ) then
        irh = MIN( 100, MAX( 0, NINT(100.*rh) ) )
        index = seasalt5_index( irh )
      else
        index = optical_index(naerosol)
      endif

!---------------------------------------------------------------------
!    if no value was obtained for the optical index, stop execution.
!---------------------------------------------------------------------
      if (index == 0 ) then
        call error_mesg ('aerosolrad_package_mod', &
           'Cannot find aerosol optical properties for species = ' // &
                  trim (name), FATAL )
      endif

!----------------------------------------------------------------------


end function get_aerosol_optical_index




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                                  
                                  

!#####################################################################
! <SUBROUTINE NAME="assign_aerosol_opt_props">
!  <OVERVIEW>
!    assign_aerosol_opt_props assigns an index for an available optical
!    properties type to each activated aerosol type. for sulfates, a 
!    flag is set, since the aerosol properties type is a function 
!    of model relative humidity, and will vary with time.
!  </OVERVIEW>
!  <DESCRIPTION>
!    assign_aerosol_opt_props assigns an index for an available optical
!    properties type to each activated aerosol type. for sulfates, a 
!    flag is set, since the aerosol properties type is a function 
!    of model relative humidity, and will vary with time.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call assign_aerosol_opt_props (aerosol_names)
!  </TEMPLATE>
!  <IN NAME="aerosol_names" TYPE="character">
!   names associated with each aerosol species
!  </IN>
! </SUBROUTINE>
!
subroutine assign_aerosol_opt_props (aerosol_names)

!----------------------------------------------------------------------
!    assign_aerosol_opt_props assigns an index for an available optical
!    properties type to each activated aerosol type. for sulfates, a 
!    flag is set, since the aerosol properties type is a function 
!    of model relative humidity, and will vary with time.
!---------------------------------------------------------------------

!character(len=64), dimension(:), intent(in) :: aerosol_names
character(len=*), dimension(:), intent(in) :: aerosol_names

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     aerosol_names     names associated with each aerosol species
!
!----------------------------------------------------------------------

!-----------------------------------------------------------------------
!    local variables:

      character(len=64) :: name_in, target_name
!yim
      character(len=4)  :: chind, chind2
      integer           :: nfields
!yim
      integer           :: n, noptical, m
      integer           :: ibc, isul

!---------------------------------------------------------------------
!   local variables:
!
!       name_in          variable to hold current aerosol name 
!                        being processed
!       target_name      aerosol_optical_name associated with a given
!                        aerosol species     
!       nfields          number of activated aerosol species
!       n, noptical      do-loop indices
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    count the number of aerosol optical property categories requested
!    via the namelist input.
!----------------------------------------------------------------------
      do n=1,MAX_OPTICAL_FIELDS
        if (aerosol_optical_names(n) /= ' '  ) then
          naermodels = n
        else
          exit
        endif
      end do

!---------------------------------------------------------------------
!    define the number of activated aerosol species.
!---------------------------------------------------------------------
      nfields = size (aerosol_names(:))

      if (Rad_control%using_im_bcsul) then
        allocate (sul_ind(nfields))
        allocate (bc_ind(nfields))
      endif

!---------------------------------------------------------------------
!    allocate components of the aerosol_properties_type module variable
!    which will contain the indices for the different aerosols.
!---------------------------------------------------------------------
      if (Rad_control%using_im_bcsul) then
        allocate (sulfate_index (0:100,0:100))
      else
        allocate (sulfate_index (0:100,0:0  ))
      endif
      allocate (omphilic_index(0:100 ), &
                bcphilic_index(0:100 ), &
                seasalt1_index(0:100 ), &
                seasalt2_index(0:100 ), &
                seasalt3_index(0:100 ), &
                seasalt4_index(0:100 ), &
                seasalt5_index(0:100 ) )
      allocate (optical_index(nfields) )
      optical_index    = 0
      sulfate_index    = 0
      omphilic_index    = 0
      bcphilic_index    = 0
      seasalt1_index    = 0
      seasalt2_index    = 0
      seasalt3_index    = 0
      seasalt4_index    = 0
      seasalt5_index    = 0

!----------------------------------------------------------------------
!    match aerosol optical property indices with aerosol indices.
!    sulfate aerosols are handled separately (below) with RH dependence.
!----------------------------------------------------------------------
      num_sul = 0
      num_bc = 0
      isul = 1
      ibc = 1
      do n=1,nfields
        name_in = trim(aerosol_names(n))
        if (name_in == 'so4' .or. name_in == 'so4_anthro' .or. name_in == 'so4_natural') then
          optical_index(n) = SULFATE_FLAG
          if (Rad_control%using_im_bcsul) then
            num_sul = num_sul +1
            sul_ind(isul) = n
            isul = isul + 1
          endif
        else if (name_in == "omphilic" .or. name_in == "oc_hydrophilic") then
            optical_index(n) = OMPHILIC_FLAG
        else if (name_in == "bcphilic" .or. name_in == "bc_hydrophilic") then
            optical_index(n) = BCPHILIC_FLAG
            if (Rad_control%using_im_bcsul) then
              num_bc = num_bc +1
              bc_ind(ibc) = n
              ibc = ibc + 1
            endif
        else if (name_in == "seasalt1") then
            optical_index(n) = SEASALT1_FLAG
        else if (name_in == "seasalt2") then
            optical_index(n) = SEASALT2_FLAG
        else if (name_in == "seasalt3") then
            optical_index(n) = SEASALT3_FLAG
        else if (name_in == "seasalt4") then
            optical_index(n) = SEASALT4_FLAG
        else if (name_in == "seasalt5") then
            optical_index(n) = SEASALT5_FLAG
!yim
        else if (name_in == "black_carbon" .and.   &
                              Rad_control%using_im_bcsul) then
            optical_index(n) = BC_FLAG
            num_bc = num_bc +1
            bc_ind(ibc) = n
            ibc = ibc + 1
        else 
          select case( name_in )
            case( "anthro_dust_0.1", "natural_dust_0.1" )
              target_name = "dust_0.1"
            case( "anthro_dust_0.2", "natural_dust_0.2" )
              target_name = "dust_0.2"
            case( "anthro_dust_0.4", "natural_dust_0.4" )
              target_name = "dust_0.4"
            case( "anthro_dust_0.8", "natural_dust_0.8" )
              target_name = "dust_0.8"
            case( "anthro_dust_1.0", "natural_dust_1.0" )
              target_name = "dust_1.0"
            case( "anthro_dust_2.0", "natural_dust_2.0" )
              target_name = "dust_2.0"
            case( "anthro_dust_4.0", "natural_dust_4.0" )
              target_name = "dust_4.0"
            case( "anthro_dust_8.0", "natural_dust_8.0" )
              target_name = "dust_8.0"
            case( "black_carbon" )
               target_name = "soot"
            case( "organic_carbon" )
              target_name = "organic_carbon"
            case( "sea_salt" )
              target_name = "sea_salt"
            case( "dust1" )
              target_name = "dust1"
            case( "dust2" )
              target_name = "dust2"
            case( "dust3" )
              target_name = "dust3"
            case( "dust4" )
              target_name = "dust4"
            case( "dust5" )
              target_name = "dust5"
            case( "bcdry" )
              target_name = "bcdry"
            case( "omphobic", "oc_hydrophobic" )
              target_name = "omphobic"
            case( "bcphobic", "bc_hydrophobic" )
              target_name = "bcphobic"
            case DEFAULT
              target_name = name_in
          end select  

!--------------------------------------------------------------------
!    go through the set of aerosol properties types looking for 
!    the target_name defined above. when found, associate the
!    optical properties type index with the current aerosol species.
!--------------------------------------------------------------------
          do noptical=1,naermodels
            if (aerosol_optical_names(noptical) == target_name) then
              optical_index(n) = noptical
              exit
            end if
          end do

!--------------------------------------------------------------------
!    if the target_name is not found, exit with an error message.
!----------------------------------------------------------------------
          if (optical_index(n) == 0 ) then
            call error_mesg( 'aerosolrad_package_mod', &
                'Cannot find aerosol optical model = ' //    &
                                           TRIM( target_name ), FATAL )
          endif
        endif  ! (name_in ==)
      end do  ! (n=1,nfields)

      select case(trim(aerosol_data_set))
        case ('Ginoux_Reddy') 
     if (Rad_control%using_im_bcsul) then

!----------------------------------------------------------------------
!    set up RH-dependent sulfate aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
          do m=0,100
            if (sulfate_indices(n) < 10) then
              write (chind, '(i1)') sulfate_indices(n)
            else if (sulfate_indices(n) == 100) then
              write (chind, '(i3)') sulfate_indices(n)
            else
              write (chind, '(i2)') sulfate_indices(n)
            endif
!yim
            if (sulfate_vol_indices(m) < 10) then
              write (chind2, '(i1)') sulfate_vol_indices(m)
            else if (sulfate_vol_indices(m) == 100) then
              write (chind2, '(i3)') sulfate_vol_indices(m)
            else
              write (chind2, '(i2)') sulfate_vol_indices(m)
            endif
!yim format sulfate_10%_10% (RH + volume fraction)
            target_name = 'sulfate_' // trim(chind)  // '%_' // trim(chind2)// '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
        do noptical=1,naermodels
          if (aerosol_optical_names(noptical) == target_name ) then
            sulfate_index(n,m) = noptical
            exit
          end if
        end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
        if (sulfate_index(n,m) == 0 ) then
          call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
        endif
      end do
      end do
     else
!----------------------------------------------------------------------
!    set up RH-dependent sulfate aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (sulfate_indices(n) < 10) then
              write (chind, '(i1)') sulfate_indices(n)
            else if (sulfate_indices(n) == 100) then
              write (chind, '(i3)') sulfate_indices(n)
            else
              write (chind, '(i2)') sulfate_indices(n)
            endif
            target_name = 'sulfate_' // trim(chind)  // '%' 

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
        do noptical=1,naermodels
          if (aerosol_optical_names(noptical) == target_name ) then
            sulfate_index(n,0) = noptical
            exit
          end if
        end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
        if (sulfate_index(n,0) == 0 ) then
          call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
        endif
      end do

     endif

!---------------------------------------------------------------------
!    set up RH-dependent omphilic aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (omphilic_indices(n) < 10) then
              write (chind, '(i1)') omphilic_indices(n)
            else if (omphilic_indices(n) == 100) then
              write (chind, '(i3)') omphilic_indices(n)
            else
              write (chind, '(i2)') omphilic_indices(n)
            endif
            target_name = 'omphilic_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
            do noptical=1,naermodels
              if (aerosol_optical_names(noptical) == target_name ) then
                omphilic_index(n) = noptical
                exit
              endif
            end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
            if (omphilic_index(n) == 0 ) then
              call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
            endif
          end do

!---------------------------------------------------------------------
!    set up RH-dependent seasalt1 aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (seasalt1_indices(n) < 10) then
              write (chind, '(i1)') seasalt1_indices(n)
            else if (seasalt1_indices(n) == 100) then
              write (chind, '(i3)') seasalt1_indices(n)
            else
              write (chind, '(i2)') seasalt1_indices(n)
            endif
            target_name = 'seasalt1_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
            do noptical=1,naermodels
              if (aerosol_optical_names(noptical) == target_name ) then
                seasalt1_index(n) = noptical
                exit
              endif
            end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
            if (seasalt1_index(n) == 0 ) then
              call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
            endif
          end do

!---------------------------------------------------------------------
!    set up RH-dependent seasalt2 aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (seasalt2_indices(n) < 10) then
              write (chind, '(i1)') seasalt2_indices(n)
            else if (seasalt2_indices(n) == 100) then
              write (chind, '(i3)') seasalt2_indices(n)
            else
              write (chind, '(i2)') seasalt2_indices(n)
            endif
            target_name = 'seasalt2_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
            do noptical=1,naermodels
              if (aerosol_optical_names(noptical) == target_name ) then
                seasalt2_index(n) = noptical
                exit
              endif
            end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
            if (seasalt2_index(n) == 0 ) then
              call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
            endif
          end do

!---------------------------------------------------------------------
!    set up RH-dependent seasalt3 aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (seasalt3_indices(n) < 10) then
              write (chind, '(i1)') seasalt3_indices(n)
            else if (seasalt3_indices(n) == 100) then
              write (chind, '(i3)') seasalt3_indices(n)
            else
              write (chind, '(i2)') seasalt3_indices(n)
            endif
            target_name = 'seasalt3_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
            do noptical=1,naermodels
              if (aerosol_optical_names(noptical) == target_name ) then
                seasalt3_index(n) = noptical
                exit
              endif
            end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
            if (seasalt3_index(n) == 0 ) then
              call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
            endif
          end do
 
!---------------------------------------------------------------------
!    set up RH-dependent seasalt4 aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (seasalt4_indices(n) < 10) then
              write (chind, '(i1)') seasalt4_indices(n)
            else if (seasalt4_indices(n) == 100) then
              write (chind, '(i3)') seasalt4_indices(n)
            else
              write (chind, '(i2)') seasalt4_indices(n)
            endif
            target_name = 'seasalt4_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
            do noptical=1,naermodels
              if (aerosol_optical_names(noptical) == target_name ) then
                seasalt4_index(n) = noptical
                exit
              endif
            end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
            if (seasalt4_index(n) == 0 ) then
              call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
            endif
          end do

!-------------------------------------------------------------------
!    set up RH-dependent seasalt5 aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (seasalt5_indices(n) < 10) then
              write (chind, '(i1)') seasalt5_indices(n)
            else if (seasalt5_indices(n) == 100) then
              write (chind, '(i3)') seasalt5_indices(n)
            else
              write (chind, '(i2)') seasalt5_indices(n)
            endif
            target_name = 'seasalt5_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
            do noptical=1,naermodels
              if (aerosol_optical_names(noptical) == target_name ) then
                seasalt5_index(n) = noptical
                exit
              endif
            end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
            if (seasalt5_index(n) == 0 ) then 
              call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
            endif
          end do

          if ( .not. Rad_control%using_im_bcsul) then
!-------------------------------------------------------------------
!    set up RH-dependent bcphilic aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
           do n=0,100
             if (bcphilic_indices(n) < 10) then
               write (chind, '(i1)') bcphilic_indices(n)
             else if (bcphilic_indices(n) == 100) then
               write (chind, '(i3)') bcphilic_indices(n)
             else
               write (chind, '(i2)') bcphilic_indices(n)
             endif
             target_name = 'bcphilic_' // trim(chind)  // '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
             do noptical=1,naermodels
               if (aerosol_optical_names(noptical) == target_name ) then
                 bcphilic_index(n) = noptical
                 exit
               endif
             end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
             if (bcphilic_index(n) == 0 ) then
               call error_mesg( 'aerosolrad_package_mod', &
                  'Cannot find aerosol optical model = ' // &
                                           TRIM( target_name), FATAL )
             endif
           end do
          endif
        case ('shettle_fenn')

   if (Rad_control%using_im_bcsul) then
!----------------------------------------------------------------------
!    set up RH-dependent sulfate aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
          do m=0,100
            if (sulfate_indices(n) < 10) then
              write (chind, '(i1)') sulfate_indices(n)
            else if (sulfate_indices(n) == 100) then
              write (chind, '(i3)') sulfate_indices(n)
            else
              write (chind, '(i2)') sulfate_indices(n)
            endif
!yim
            if (sulfate_vol_indices(m) < 10) then
              write (chind2, '(i1)') sulfate_vol_indices(m)
            else if (sulfate_vol_indices(m) == 100) then
              write (chind2, '(i3)') sulfate_vol_indices(m)
            else
              write (chind2, '(i2)') sulfate_vol_indices(m)
            endif
!yim format sulfate_10%_10% (RH + volume fraction)
            target_name = 'sulfate_' // trim(chind)  // '%_' // trim(chind2)// '%'

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
        do noptical=1,naermodels
          if (aerosol_optical_names(noptical) == target_name ) then
            sulfate_index(n,m) = noptical
            exit
          end if
        end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
        if (sulfate_index(n,m) == 0 ) then
          call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
        endif
      end do
      end do
   else 
!----------------------------------------------------------------------
!    set up RH-dependent sulfate aerosol optical property indices.
!    define the optical properties type for all possible values of 
!    relative humidity.
!-------------------------------------------------------------------
          do n=0,100
            if (sulfate_indices(n) < 10) then
              write (chind, '(i1)') sulfate_indices(n)
            else if (sulfate_indices(n) == 100) then
              write (chind, '(i3)') sulfate_indices(n)
            else
              write (chind, '(i2)') sulfate_indices(n)
            endif
            target_name = 'sulfate_' // trim(chind)  // '%' 

!---------------------------------------------------------------------
!    associate an index value with each possible relative humidity.
!---------------------------------------------------------------------
        do noptical=1,naermodels
          if (aerosol_optical_names(noptical) == target_name ) then
            sulfate_index(n,0) = noptical
            exit
          end if
        end do

!---------------------------------------------------------------------
!    if the  aerosol_optical name_is not included in the potential
!    set listed above, exit with an error message.
!---------------------------------------------------------------------
        if (sulfate_index(n,0) == 0 ) then
          call error_mesg( 'aerosolrad_package_mod', &
                 'Cannot find aerosol optical model = ' // &
                                          TRIM( target_name), FATAL )
        endif
      end do

   endif
      end select  ! (aerosol_data_set)  

!---------------------------------------------------------------------



end subroutine assign_aerosol_opt_props



!######################################################################
! <SUBROUTINE NAME="read_optical_input_file">
!  <OVERVIEW>
!    read_optical_input_file reads the optical properties input file
!    to obtain the specified aerosol radiative properties for each 
!    aerosol in each of the aerosol parameterization spectral bands.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_optical_input_file reads the optical properties input file
!    to obtain the specified aerosol radiative properties for each 
!    aerosol in each of the aerosol parameterization spectral bands.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_optical_input_file
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_optical_input_file

!-----------------------------------------------------------------------
!    read_optical_input_file reads the optical properties input file
!    to obtain the specified aerosol radiative properties for each 
!    aerosol in each of the aerosol parameterization spectral bands.
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!    local variables:

      real,    dimension(:), allocatable    :: aeroext_in,   &
                                               aerossalb_in,   &
                                               aeroasymm_in
      logical, dimension(:), allocatable    :: found

      integer           :: unit, num_input_categories
      character(len=64) :: name_in
      integer           :: n, noptical

!---------------------------------------------------------------------
!   local variables:
!
!       aeroext_in       aerosol extinction coefficient read from 
!                        input file
!       aerossalb_in     aerosol single scattering albedo read from 
!                        input file
!       aeroasymm_in     aerosol asymmetry factor read from 
!                        input file
!       found            aerosol radiative property data has been
!                        obtained from input file for the given
!                        optical properties type ?
!       unit             io unit number used for optical properties file
!       num_input_categories
!                        number of optical properties types contained
!                        in optical data input file
!       name_in          name of optical properties type being processed
!       n, noptical      do-loop indices
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    open the ASCII input file containing aerosol optical property
!    information.
!----------------------------------------------------------------------
      call mpp_open (unit, 'INPUT/'//optical_filename, MPP_RDONLY,  &
                     MPP_ASCII, MPP_SEQUENTIAL, MPP_MULTI, MPP_SINGLE)

!----------------------------------------------------------------------
!    read the dimension information contained in the input file.
!----------------------------------------------------------------------
      read ( unit,* ) num_wavenumbers
      read ( unit,* ) num_input_categories

!----------------------------------------------------------------------
!    read wavenumber limits for aerosol parameterization bands from 
!    the input file.
!----------------------------------------------------------------------
       allocate (endaerwvnsf(num_wavenumbers) )
       read (unit,* )
       read (unit,* ) endaerwvnsf
 
!----------------------------------------------------------------------
!    allocate module arrays to hold the specified sw properties for 
!    each parameterization bnad and each aerosol properties type.
!----------------------------------------------------------------------
      allocate (       &
            aeroextivl   (num_wavenumbers, naermodels),&
            aerossalbivl (num_wavenumbers, naermodels), &
            aeroasymmivl (num_wavenumbers, naermodels) )

!----------------------------------------------------------------------
!    allocate local working arrays.
!----------------------------------------------------------------------
      allocate (aeroext_in   (num_wavenumbers ),             &
                aerossalb_in (num_wavenumbers ),           &
                aeroasymm_in (num_wavenumbers ),           &
                found        (naermodels ) )

!----------------------------------------------------------------------
!    match the names of optical property categories from input file with
!    those specified in the namelist, and store the following data
!    appropriately. indicate that the data has been found.
!----------------------------------------------------------------------
      found(:) = .false.
      do n=1,num_input_categories
        read( unit,* ) name_in
        read( unit,* )
        read( unit,* ) aeroext_in
        read( unit,* )
        read( unit,* ) aerossalb_in
        read( unit,* )
        read( unit,* ) aeroasymm_in
        do noptical=1,naermodels
          if (aerosol_optical_names(noptical) == name_in) then
            aeroextivl(:,noptical)   = aeroext_in
            aerossalbivl(:,noptical) = aerossalb_in
            aeroasymmivl(:,noptical) = aeroasymm_in
            found( noptical ) = .true.
            exit
          endif
        end do
      end do

!----------------------------------------------------------------------
!    close the ASCII input file.
!----------------------------------------------------------------------
      call mpp_close( unit )

!----------------------------------------------------------------------
!    check to make sure data for all aerosol optical property
!    categories specified in namelist were contained in ASCII
!    input file. if not, exit with a message.
!----------------------------------------------------------------------
      do noptical = 1,naermodels
        if (.not. found( noptical ) ) then
              call error_mesg( 'aerosolrad_package_mod', &
              'Cannot find aerosol optical properties for ' // &
                TRIM(aerosol_optical_names(noptical)),  FATAL )
        endif
      end do

!----------------------------------------------------------------------
!    deallocate local working arrays.
!----------------------------------------------------------------------
      deallocate (aeroext_in, aerossalb_in, aeroasymm_in, found)



end subroutine read_optical_input_file



!#####################################################################
! <SUBROUTINE NAME="sw_aerosol_interaction">
!  <OVERVIEW>
!    sw_aerosol_interaction defines the weights and interval infor-
!    mation needed to map the aerosol radiative properties from the
!    aerosol parameterization bands to the solar parameterization
!    bands being used by the model.
!  </OVERVIEW>
!  <DESCRIPTION>
!    sw_aerosol_interaction defines the weights and interval infor-
!    mation needed to map the aerosol radiative properties from the
!    aerosol parameterization bands to the solar parameterization
!    bands being used by the model.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sw_aerosol_interaction
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine sw_aerosol_interaction

!-----------------------------------------------------------------------
!    sw_aerosol_interaction defines the weights and interval infor-
!    mation needed to map the aerosol radiative properties from the
!    aerosol parameterization bands to the solar parameterization
!    bands being used by the model.
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!    local variables:

      integer           :: nbands, nband, nivl3
      real              :: sumsol3
      integer           :: nw
      integer           :: nmodel

!---------------------------------------------------------------------
!   local variables:
!
!       aeroext_in       aerosol extinction coefficient read from 
!                        input file
!       aerossalb_in     aerosol single scattering albedo read from 
!                        input file
!       aeroasymm_in     aerosol asymmetry factor read from 
!                        input file
!       found            aerosol radiative property data has been
!                        obtained from input file for the given
!                        optical properties type ?
!       unit             io unit number used for optical properties file
!       num_input_categories
!                        number of optical properties types contained
!                        in optical data input file
!       name_in          name of optical properties type being processed
!       nbands           number of bands in solar spectral param-
!                        eterization
!       nband            currently active solar spectrum band 
!       nivl3            currently active aerosol parameterization band
!       sumsol3          sum of solar input in current aerosol param-
!                        eterization band
!       n, nw, noptical  do-loop indices
!
!---------------------------------------------------------------------



!---------------------------------------------------------------------
!    define the number of bands in the solar spectrum parameterization.
!    allocate space for variables defining the highest and lowest 
!    aerosol parameterization wavenumber in each solar spectral band
!    and the solar flux common to solar spectral band n and aerosol
!    parameterization band ni.
!---------------------------------------------------------------------
      nbands = Solar_spect%nbands 
      allocate ( nivl1aero  (nbands) )
      allocate ( nivl2aero  (nbands) )
      allocate ( solivlaero (nbands, num_wavenumbers))

!---------------------------------------------------------------------
!    define the solar weights and interval counters that are needed to  
!    map the aerosol parameterization spectral intervals onto the solar
!    spectral intervals and so determine the single-scattering proper-
!    ties on the solar spectral intervals.
!--------------------------------------------------------------------
      nivl3 = 1
      sumsol3 = 0.0
      nband = 1
      solivlaero(:,:) = 0.0
      nivl1aero(1) = 1
      do nw = 1,Solar_spect%endwvnbands(nbands)
        sumsol3 = sumsol3 + Solar_spect%solarfluxtoa(nw)
        if (nw == endaerwvnsf(nivl3) ) then
          solivlaero(nband,nivl3) = sumsol3
          sumsol3 = 0.0
        end if
        if ( nw == Solar_spect%endwvnbands(nband) ) then
          if ( nw /= endaerwvnsf(nivl3) ) then
            solivlaero(nband,nivl3) = sumsol3 
            sumsol3 = 0.0
          end if
          nivl2aero(nband) = nivl3
          nband = nband + 1
          if ( nband <= nbands ) then
            if ( nw == endaerwvnsf(nivl3) ) then
              nivl1aero(nband) = nivl3 + 1
            else
              nivl1aero(nband) = nivl3
            end if
          end if
        end if
        if ( nw == endaerwvnsf(nivl3) ) nivl3 = nivl3 + 1
      end do

!---------------------------------------------------------------------
!    allocate and initialize variables which will hold the aerosol 
!    radiative properties for each solar spectral parameterization band.
!    aerextband     the solar band values of the extinction 
!                   coefficient for aerosols                           
!    aerssalbband   the solar band values of the single-     
!                   scattering albedo for aerosols                      
!    aerasymmband   the solar band values of the asymmetry   
!                   factor for aerosols                                 
!---------------------------------------------------------------------
      allocate     &
        (aerextband_MOD   (Solar_spect%nbands, naermodels), &
         aerssalbband_MOD (Solar_spect%nbands, naermodels), &
         aerasymmband_MOD (Solar_spect%nbands, naermodels) )
      aerextband_MOD   = 0.
      aerssalbband_MOD = 0.
      aerasymmband_MOD = 0.

!--------------------------------------------------------------------
!    if sw aerosol properties are desired and have not yet been calc-
!    ulated, use the thick-averaging technique to define the single-
!    scattering properties for each solar parameterization band n 
!    from the specified properties on the aerosol parameterization 
!    bands ni for each aerosol properties type nmodel. 
! references:                                                          
!    edwards,j.m. and a. slingo, studies with a flexible new radiation  
!    code I: choosing a configuration for a large-scale model.,     
!    q.j.r. meteorological society, 122, 689-719, 1996.              
!                                                                      
! note: a thin-averaging technique (subroutine thinavg in 
!    rad_utilities_mod) is also available.   
!--------------------------------------------------------------------
      do nmodel=1,naermodels
        call thickavg (nivl1aero, nivl2aero, num_wavenumbers,   &
                       Solar_spect%nbands, aeroextivl(:,nmodel), &
                       aerossalbivl(:,nmodel),    &
                       aeroasymmivl(:,nmodel), solivlaero,   &
                       Solar_spect%solflxbandref,  &
                       aerextband_MOD(:,nmodel),    &
                       aerssalbband_MOD(:,nmodel),   &
                       aerasymmband_MOD(:,nmodel))
      end do

!---------------------------------------------------------------------



end subroutine sw_aerosol_interaction   



!#####################################################################
! <SUBROUTINE NAME="lw_aerosol_interaction">
!  <OVERVIEW>
!    lw_aerosol_interaction defines the weights and interval infor-
!    mation needed to map the aerosol radiative properties from the
!    aerosol parameterization bands to the aerosol emissivity bands
!    being used by the model.
!  </OVERVIEW>
!  <DESCRIPTION>
!    lw_aerosol_interaction defines the weights and interval infor-
!    mation needed to map the aerosol radiative properties from the
!    aerosol parameterization bands to the aerosol emissivity bands
!    being used by the model.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_aerosol_interaction
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine lw_aerosol_interaction      

!----------------------------------------------------------------------
!    lw_aerosol_interaction defines the weights and interval infor-
!    mation needed to map the aerosol radiative properties from the
!    aerosol parameterization bands to the aerosol emissivity bands
!    being used by the model.
!----------------------------------------------------------------------

!-----------------------------------------------------------------------
!  local variables:

!---------------------------------------------------------------------
!    the following arrays define the wavenumber ranges for the separate
!    aerosol emissivity bands in the model infrared parameterization. 
!    these may be changed only by the keeper of the radiation code.
!    the order of the frequency bands corresponds to the order used
!    in the lw radiation code.
!
!      aerbandlo_fr      low wavenumber limit for the non-continuum 
!                        aerosol emissivity bands
!      aerbandhi_fr      high wavenumber limit for the non-continuum
!                        aerosol emissivity bands
!      istartaerband_fr  starting wavenumber index for the non-continuum
!                        aerosol emissivity bands
!      iendaerband_fr    ending wavenumber index for the non-continuum
!                        aerosol emissivity bands
!      aerbandlo_co      low wavenumber limit for the continuum 
!                        aerosol emissivity bands
!      aerbandhi_co      high wavenumber limit for the continuum
!                        aerosol emissivity bands
!      istartaerband_co  starting wavenumber index for the continuum
!                        aerosol emissivity bands
!      iendaerband_co    ending wavenumber index for the continuum
!                        aerosol emissivity bands
!      aerbandlo         low wavenumber limit for the entire set of
!                        aerosol emissivity bands
!      aerbandhi         high wavenumber limit for the entire set of
!                        aerosol emissivity bands
!      istartaerband     starting wavenumber index for the entire set of
!                        aerosol emissivity bands
!      iendaerband       ending wavenumber index for the entire set of
!                        aerosol emissivity bands
!
!----------------------------------------------------------------------
      real, dimension (N_AEROSOL_BANDS_FR)     :: aerbandlo_fr =  &
      (/ 560.0, 630.0, 700.0, 800.0, 900.0,  990.0, 1070.0, 1200.0 /)

      real, dimension (N_AEROSOL_BANDS_FR)     :: aerbandhi_fr =  &
      (/ 630.0, 700.0, 800.0, 900.0, 990.0, 1070.0, 1200.0, 1400.0 /)

      integer, dimension (N_AEROSOL_BANDS_FR)  :: istartaerband_fr =  &
      (/ 57,  64,  71,  81,  91, 100, 108, 121 /)

      integer, dimension (N_AEROSOL_BANDS_FR)  :: iendaerband_fr =  &
      (/ 63,  70,  80,  90,  99, 107, 120, 140 /)

      real, dimension (N_AEROSOL_BANDS_CO)     :: aerbandlo_co =  &
      (/ 560.0 /)

      real, dimension (N_AEROSOL_BANDS_CO)     :: aerbandhi_co =  &
      (/ 800.0 /)

      integer, dimension (N_AEROSOL_BANDS_CO)  :: istartaerband_co =  &
      (/ 57  /)

      integer, dimension (N_AEROSOL_BANDS_CO)  :: iendaerband_co =  &
      (/ 80  /)

      integer, dimension (N_AEROSOL_BANDS_CN)  :: istartaerband_cn =  &
      (/ 81  /)

      integer, dimension (N_AEROSOL_BANDS_CN)  :: iendaerband_cn =  &
      (/ 120 /)

      real,    dimension(N_AEROSOL_BANDS)      :: aerbandlo, aerbandhi
      integer, dimension(N_AEROSOL_BANDS)      :: istartaerband,    &
                                                  iendaerband

!---------------------------------------------------------------------
!    the following arrays define how the ir aerosol band structure 
!    relates to the aerosol parameterization bands.
!
!      nivl1aer_fr(n)    aerosol parameterization band index corres-
!                        ponding to the lowest wavenumber of the 
!                        non-continuum ir aerosol emissivity band n
!      nivl2aer_fr(n)    aerosol parameterization band index corres-
!                        ponding to the highest wavenumber of the 
!                        non-continuum ir aerosol emissivity band n
!      nivl1aer_co(n)    aerosol parameterization band index corres-
!                        ponding to the lowest wavenumber of the 
!                        continuum ir aerosol emissivity band n
!      nivl2aer_co(n)    aerosol parameterization band index corres-
!                        ponding to the highest wavenumber of the 
!                        continuum ir aerosol emissivity band n
!      nivl1aer(n)       aerosol parameterization band index corres-
!                        ponding to the lowest wavenumber for the 
!                        ir aerosol emissivity band n
!      nivl2aer(n)       aerosol parameterization band index corres-
!                        ponding to the highest wavenumber for the 
!                        ir aerosol emissivity band n
!      planckaerband(n)  planck function summed over each lw param-
!                        eterization band that is contained in the 
!                        ir aerosol emissivity band n
!
!---------------------------------------------------------------------
      integer, dimension (N_AEROSOL_BANDS_FR)  :: nivl1aer_fr,   &
                                                  nivl2aer_fr
      integer, dimension (N_AEROSOL_BANDS_CO)  :: nivl1aer_co,   &
                                                  nivl2aer_co
      integer, dimension (N_AEROSOL_BANDS_CN)  :: nivl1aer_cn,   &
                                                  nivl2aer_cn
      real,    dimension (N_AEROSOL_BANDS)     :: planckaerband
      real,    dimension (N_AEROSOL_BANDS_CN)  :: planckaerband_cn

!----------------------------------------------------------------------
!    the following arrays relate the ir aerosol emissivity band n to
!    either the aerosol optical properties type na or to the aerosol 
!    parameterization band ni.
!        aerextbandlw_fr(n,na)  band averaged extinction coefficient
!                               for non-continuum aerosol emissivity 
!                               band n and aerosol properties type na
!        aerssalbbandlw_fr(n,na)
!                               band averaged single-scattering
!                               coefficient for non-continuum aerosol
!                               emissivity band n and aerosol properties
!                               type na
!        aerextbandlw_co(n,na)  band averaged extinction coefficient
!                               for the continuum aerosol emissivity
!                               band n and aerosol properties type na
!        aerssalbbandlw_co(n,na)
!                               band averaged single-scattering
!                               coefficient for continuum aerosol
!                               emissivity band n and aerosol properties
!                               type na
!        planckivlaer_fr(n,ni)  planck function over the spectral range
!                               common to aerosol emissivity non-
!                               continuum band n and aerosol parameter-
!                               ization band ni
!        planckivlaer_co(n,ni)  planck function over the spectral range
!                               common to aerosol emissivity continuum 
!                               band n and aerosol parameterization 
!                               band ni
!        sflwwts_fr(n,ni)       band weights for the aerosol emissivity
!                               non-continuum band n and the aerosol 
!                               parameterization band ni 
!        sflwwts_co(n,ni)       band weights for the aerosol emissivity
!                               continuum band n and the aerosol 
!                               parameterization band ni 
!        planckivlaer(n,ni)     planck function over the spectral range
!                               common to aerosol emissivity band n and
!                               aerosol parameterization band ni
!        iendsfbands(ni)        ending wavenumber index for aerosol 
!                               parameterization band ni
!
!----------------------------------------------------------------------
      real,    dimension (N_AEROSOL_BANDS_FR, num_wavenumbers) :: &
                                                  planckivlaer_fr, &
                                                  sflwwts_fr
      real,    dimension (N_AEROSOL_BANDS_CO, num_wavenumbers) :: &
                                                  planckivlaer_co, &
                                                  sflwwts_co
      real,    dimension (N_AEROSOL_BANDS_CN, num_wavenumbers) :: &
                                                  planckivlaer_cn   
      integer, dimension (num_wavenumbers)    ::  iendsfbands

!---------------------------------------------------------------------
!    variables associated with the planck function calculation.
!    the planck function is defined for each of the NBLW longwave 
!    parameterization bands.
!---------------------------------------------------------------------
      real, dimension(NBLW)  :: c1, centnb, sc, src1nb, x, x1
      real                   :: del, xtemv, sumplanck

!---------------------------------------------------------------------
!    miscellaneous variables:

     logical         :: do_band1   !  should we do special calculation 
                                   !  for band 1 ?
     integer         :: ib, nw, nivl, nband, n, ni 
                                   !  do-loop indices and counters
     integer         :: na

!--------------------------------------------------------------------
!    define arrays containing the characteristics of all the ir aerosol
!    emissivity bands, both continuum and non-continuum.
!--------------------------------------------------------------------
      do n=1,N_AEROSOL_BANDS_FR
        aerbandlo(n)     = aerbandlo_fr(n)
        aerbandhi(n)     = aerbandhi_fr(n)
        istartaerband(n) = istartaerband_fr(n)
        iendaerband(n)   = iendaerband_fr(n)
      end do
      do n=N_AEROSOL_BANDS_FR+1,N_AEROSOL_BANDS
        aerbandlo(n)     = aerbandlo_co     (n - N_AEROSOL_BANDS_FR)
        aerbandhi(n)     = aerbandhi_co     (n - N_AEROSOL_BANDS_FR)
        istartaerband(n) = istartaerband_co (n - N_AEROSOL_BANDS_FR)
        iendaerband(n)   = iendaerband_co   (n - N_AEROSOL_BANDS_FR)
      end do

!---------------------------------------------------------------------
!    define the number of aerosol ir bands to be used in other modules.
!    set the initialization flag to .true.
!---------------------------------------------------------------------
      Lw_parameters%n_lwaerosol_bands = N_AEROSOL_BANDS
      Lw_parameters%n_lwaerosol_bands_iz = .true.

!--------------------------------------------------------------------
!    allocate a module variable which will store the weighting function
!    between the aerosol emissivity bands and the aerosol parameter-
!    ization bands.
!--------------------------------------------------------------------
      allocate (sflwwts (N_AEROSOL_BANDS, num_wavenumbers))
      allocate (sflwwts_cn (N_AEROSOL_BANDS_CN, num_wavenumbers))

!--------------------------------------------------------------------
!    define the ending aerosol band index for each of the aerosol
!    parameterization bands.
!--------------------------------------------------------------------
      iendsfbands(:) = INT((endaerwvnsf(:) + 0.01)/10.0)

!--------------------------------------------------------------------
!    compute the planck function at 10C over each of the longwave
!    parameterization bands to be used as the weighting function. 
!--------------------------------------------------------------------
      do n=1,NBLW 
        del  = 10.0E+00
        xtemv = 283.15
        centnb(n) = 5.0 + (n - 1)*del
        c1(n)     = (3.7412E-05)*centnb(n)**3
        x(n)      = 1.4387E+00*centnb(n)/xtemv
        x1(n)     = EXP(x(n))
        sc(n)     = c1(n)/(x1(n) - 1.0E+00)
        src1nb(n) = del*sc(n)
      end do
 
!--------------------------------------------------------------------
!    sum the weighting function calculated over the longwave param-
!    eterization bands that are contained in each of the aerosol 
!    emissivity bands. 
!--------------------------------------------------------------------
      planckaerband(:) = 0.0E+00
      do n = 1,N_AEROSOL_BANDS
        do ib = istartaerband(n),iendaerband(n)
          planckaerband(n) = planckaerband(n) + src1nb(ib)
        end do
      end do
      planckaerband_cn(:) = 0.0E+00
      do n = 1,N_AEROSOL_BANDS_CN
        do ib = istartaerband_cn(n),iendaerband_cn(n)
          planckaerband_cn(n) = planckaerband_cn(n) + src1nb(ib)
        end do
      end do
 
!--------------------------------------------------------------------
!    define the weights and interval counters that are needed to  
!    map the aerosol parameterization spectral intervals onto the non-
!    continuum ir aerosol emissivity bands and so determine the 
!    single-scattering properties on the ir aerosol emissivity bands.
!--------------------------------------------------------------------
      nivl = 1
      sumplanck = 0.0
      nband = 1
      planckivlaer_fr(:,:) = 0.0
      nivl1aer_fr(1) = 1
      do_band1 = .true.
 
      do nw = 1,NBLW
        sumplanck = sumplanck + src1nb(nw)
        if ( nw == iendsfbands(nivl) ) then
          planckivlaer_fr(nband,nivl) = sumplanck
          sumplanck = 0.0
        end if
        if ( nw == iendaerband_fr(nband) ) then
          if ( nw /= iendsfbands(nivl) ) then
            planckivlaer_fr(nband,nivl) = sumplanck 
            sumplanck = 0.0
          end if
          nivl2aer_fr(nband) = nivl
          nband = nband + 1
          if ( nband <= N_AEROSOL_BANDS_FR ) then
            if ( nw == iendsfbands(nivl) ) then
              nivl1aer_fr(nband) = nivl + 1
            else
              nivl1aer_fr(nband) = nivl
            end if
          end if
        end if
        if ( nw == iendsfbands(nivl) ) then
          nivl = nivl + 1
          if (do_band1 .and. nband .eq. 1 .and.   &
              iendsfbands(nivl-1) >= istartaerband_fr(1) .and.  &
              iendsfbands(nivl-1) < iendaerband_fr(1)) then
            nivl1aer_fr(nband) = nivl-1
            do_band1 = .false.
          endif
        endif
        if (nw >= iendaerband_fr(N_AEROSOL_BANDS_FR) ) then
          exit
        endif
      end do

!--------------------------------------------------------------------
!    define the weights and interval counters that are needed to  
!    map the aerosol parameterization spectral intervals onto the 
!    continuum ir aerosol emissivity bands and so determine the 
!    single-scattering properties on the ir aerosol emissivity bands.
!--------------------------------------------------------------------
      nivl = 1
      sumplanck = 0.0
      nband = 1
      planckivlaer_co(:,:) = 0.0
      nivl1aer_co(1) = 1
      do_band1 = .true.
 
      do nw = 1,NBLW
        sumplanck = sumplanck + src1nb(nw)
        if ( nw == iendsfbands(nivl) ) then
          planckivlaer_co(nband,nivl) = sumplanck
          sumplanck = 0.0
        end if
        if ( nw == iendaerband_co(nband) ) then
          if ( nw /= iendsfbands(nivl) ) then
            planckivlaer_co(nband,nivl) = sumplanck 
            sumplanck = 0.0
          end if
          nivl2aer_co(nband) = nivl
          nband = nband + 1
          if ( nband <= N_AEROSOL_BANDS_CO ) then
            if ( nw == iendsfbands(nivl) ) then
              nivl1aer_co(nband) = nivl + 1
            else
              nivl1aer_co(nband) = nivl
            end if
          end if
        end if
        if ( nw == iendsfbands(nivl) ) then
          nivl = nivl + 1
          if (do_band1 .and. nband == 1 .and.  &
              iendsfbands(nivl-1) >= istartaerband_co(1) .and.  &
              iendsfbands(nivl-1) < iendaerband_co(1)) then
            nivl1aer_co(nband) = nivl-1
            do_band1 = .false.
          endif
        endif
        if ( nw >= iendaerband_co(N_AEROSOL_BANDS_CO) ) then
          exit
        endif
      end do

!--------------------------------------------------------------------
!    define the weights and interval counters that are needed to  
!    map the aerosol parameterization spectral intervals onto the 
!    continuum ir aerosol emissivity bands and so determine the 
!    single-scattering properties on the ir aerosol emissivity bands.
!--------------------------------------------------------------------
      nivl = 1
      sumplanck = 0.0
      nband = 1
      planckivlaer_cn(:,:) = 0.0
      nivl1aer_cn(1) = 1
      do_band1 = .true.
 
      do nw = 1,NBLW
        sumplanck = sumplanck + src1nb(nw)
        if ( nw == iendsfbands(nivl) ) then
          planckivlaer_cn(nband,nivl) = sumplanck
          sumplanck = 0.0
        end if
        if ( nw == iendaerband_cn(nband) ) then
          if ( nw /= iendsfbands(nivl) ) then
            planckivlaer_cn(nband,nivl) = sumplanck 
            sumplanck = 0.0
          end if
          nivl2aer_cn(nband) = nivl
          nband = nband + 1
          if ( nband <= N_AEROSOL_BANDS_CN ) then
            if ( nw == iendsfbands(nivl) ) then
              nivl1aer_cn(nband) = nivl + 1
            else
              nivl1aer_cn(nband) = nivl
            end if
          end if
        end if
        if ( nw == iendsfbands(nivl) ) then
          nivl = nivl + 1
          if (do_band1 .and. nband == 1 .and.  &
              iendsfbands(nivl-1) >= istartaerband_cn(1) .and.  &
              iendsfbands(nivl-1) < iendaerband_cn(1)) then
            nivl1aer_cn(nband) = nivl-1
            do_band1 = .false.
          endif
        endif
        if ( nw >= iendaerband_cn(N_AEROSOL_BANDS_CN) ) then
          exit
        endif
      end do

!--------------------------------------------------------------------
!    define the planck-function-weighted band weights for the aerosol
!    parameterization bands onto the non-continuum and continuum ir 
!    aerosol emissivity bands.
!--------------------------------------------------------------------
      sflwwts_fr(:,:) = 0.0E+00
      do n=1,N_AEROSOL_BANDS_FR
        do ni=nivl1aer_fr(n),nivl2aer_fr(n)
          sflwwts_fr(n,ni) = planckivlaer_fr(n,ni)/planckaerband(n)
        end do
      end do
      sflwwts_co(:,:) = 0.0E+00
      do n=1,N_AEROSOL_BANDS_CO
        do ni=nivl1aer_co(n),nivl2aer_co(n)
          sflwwts_co(n,ni) = planckivlaer_co(n,ni)/     &
                             planckaerband(N_AEROSOL_BANDS_FR+n)
        end do
      end do
      sflwwts_cn(:,:) = 0.0E+00
      do n=1,N_AEROSOL_BANDS_CN
        do ni=nivl1aer_cn(n),nivl2aer_cn(n)
          sflwwts_cn(n,ni) = planckivlaer_cn(n,ni)/     &
                             planckaerband_cn(n)
        end do
      end do

!--------------------------------------------------------------------
!    consolidate the continuum and non-continuum weights into an
!    array covering all ir aerosol emissivity bands.
!--------------------------------------------------------------------
      do n=1,N_AEROSOL_BANDS_FR
        do ni = 1,num_wavenumbers
          sflwwts(n,ni) = sflwwts_fr(n,ni)
        end do
      end do
      do n=N_AEROSOL_BANDS_FR+1,N_AEROSOL_BANDS
        do ni = 1,num_wavenumbers
          sflwwts(n,ni) = sflwwts_co(n-N_AEROSOL_BANDS_FR,ni)
        end do
      end do

!-----------------------------------------------------------------
!    allocate and initialize the arrays in the aerosol_properties_type 
!    variable that will contain the ir aerosol properties for each
!    aerosol optical type over each ir aerosol emissivity band.
!----------------------------------------------------------------
      allocate     &
         (aerextbandlw_MOD   (N_AEROSOL_BANDS, naermodels), &
          aerssalbbandlw_MOD (N_AEROSOL_BANDS, naermodels), &
          aerextbandlw_cn_MOD   (N_AEROSOL_BANDS_CN, naermodels), &
          aerssalbbandlw_cn_MOD (N_AEROSOL_BANDS_CN, naermodels) )
      aerextbandlw_MOD   = 0.0E+00
      aerssalbbandlw_MOD = 0.0E+00
      aerextbandlw_cn_MOD   = 0.0E+00
      aerssalbbandlw_cn_MOD = 0.0E+00

      if (.not. force_to_repro_quebec) then
!---------------------------------------------------------------------
!    if longwave aerosol effects are desired, and the following cal-
!    culation has not already been done, calculate the aerosol 
!    properties for each aerosol properties type nw over each aerosol 
!    emissivity band na using the weighted contributions from each
!    aerosol parameterization band ni. mark the calculation as com-
!    pleted.
!
!    the units of extinction coefficient (aeroextivl) are m**2/gm.
!    to make the lw band extinction coefficient (aerextbandlw) have
!    units (m**2/Kg) consistent with the units in FMS models, one
!    must multiply by 1000. this is done below.
!---------------------------------------------------------------------
        do nw=1,naermodels    
          do na=1,N_AEROSOL_BANDS  
            do ni=1,num_wavenumbers 
              aerextbandlw_MOD(na,nw) = aerextbandlw_MOD(na,nw) + &
                                aeroextivl(ni,nw)*sflwwts(na,ni)*1.0E+03
              aerssalbbandlw_MOD(na,nw) = aerssalbbandlw_MOD(na,nw) + &
                                     aerossalbivl(ni,nw)*sflwwts(na,ni)
            end do
          end do
        end do
        do nw=1,naermodels    
          do na=1,N_AEROSOL_BANDS_CN
            do ni=1,num_wavenumbers 
              aerextbandlw_cn_MOD(na,nw) = aerextbandlw_cn_MOD(na,nw) +&
                            aeroextivl(ni,nw)*sflwwts_cn(na,ni)*1.0E+03
              aerssalbbandlw_cn_MOD(na,nw) =    &
                               aerssalbbandlw_cn_MOD(na,nw) +&
                                  aerossalbivl(ni,nw)*sflwwts_cn(na,ni)
            end do
          end do
        end do
      endif

!----------------------------------------------------------------------



end subroutine lw_aerosol_interaction


!######################################################################



               end module aerosolrad_package_mod







!FDOC_TAG_GFDL
               module bulkphys_rad_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!   fil
! </CONTACT>
! <REVIEWER EMAIL="">
!  
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    bulkphys_rad_mod defines cloud radiative properties based on
!    bulk cloud physics values in contrast to microphysically-based
!    properties.
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!
 
!    shared modules:

use mpp_mod,                only: input_nml_file
use fms_mod,                only: open_namelist_file, mpp_pe, &
                                  fms_init, mpp_root_pe, stdlog,  &
                                  write_version_number, file_exist, & 
                                  check_nml_error, error_mesg,   &
                                  FATAL, close_file

!    shared radiation package modules:

use rad_utilities_mod,      only:  rad_utilities_init, &
                                  cldrad_properties_type, &
                                  cld_specification_type, &
                                  Cldrad_control

!    individual cloud modules:

use rh_based_clouds_mod,    only: rh_based_clouds_init, &
                                  obtain_bulk_sw_rh,   &
                                  obtain_bulk_lw_rh
use diag_clouds_W_mod,      only: diag_clouds_W_init, &
                                  obtain_bulk_sw_diag, &
                                  obtain_bulk_lw_diag
use strat_clouds_W_mod,     only: strat_clouds_W_init, &
                                  obtain_bulk_lw_strat, &
                                  obtain_bulk_sw_strat
use standalone_clouds_mod,  only: standalone_clouds_init,  &
                                  define_column_properties, &
                                  obtain_bulk_sw_sa, obtain_bulk_lw_sa

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    bulkphys_rad_mod defines cloud radiative properties based on
!    bulk cloud physics values in contrast to microphysically-based
!    properties.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: bulkphys_rad.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public                                            &
          bulkphys_rad_init, bulkphys_lw_driver,  &
          bulkphys_sw_driver, bulkphys_rad_end

!---------------------------------------------------------------------
!-------- namelist  ---------
 
integer     :: dummy = 1

namelist /bulkphys_rad_nml /  dummy


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

!--------------------------------------------------------------------
!    visible band reflectivity, nir band reflectivity and nir absorp-
!    tivities are given for high, middle and low clouds. two separate
!    sets of parameters are present; set 1 has been used for all cloud
!    parameterizations except for mgrp_prscr_clds, which used the
!    values in data set 2.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   crfvis: visible band reflectivity. 
!--------------------------------------------------------------------
real  :: crfvis_hi_1  = 0.21
real  :: crfvis_hi_2  = 0.21
real  :: crfvis_mid_1 = 0.45
real  :: crfvis_mid_2 = 0.48
real  :: crfvis_low_1 = 0.59
real  :: crfvis_low_2 = 0.69

!--------------------------------------------------------------------
!   crfir: near-ir band reflectivity.
!--------------------------------------------------------------------
real  :: crfir_hi_1   = 0.21
real  :: crfir_hi_2   = 0.21
real  :: crfir_mid_1  = 0.45
real  :: crfir_mid_2  = 0.48
real  :: crfir_low_1  = 0.59
real  :: crfir_low_2  = 0.69

!--------------------------------------------------------------------
!   cabir: near-ir band absorptivity.
!--------------------------------------------------------------------
real  :: cabir_hi_1   = 0.005
real  :: cabir_hi_2   = 0.005
real  :: cabir_mid_1  = 0.02
real  :: cabir_mid_2  = 0.02
real  :: cabir_low_1  = 0.035
real  :: cabir_low_2  = 0.035

!--------------------------------------------------------------------
!   cldem:  infrared emissivity.
!--------------------------------------------------------------------
real  :: cldem_hi   = 1.00
real  :: cldem_mid  = 1.00
real  :: cldem_low  = 1.00

!------------------------------------------------------------------
!    these variables hold the values that are to be used for the
!    cloud radiative properties for the cloud parameterization 
!    activated.
!------------------------------------------------------------------
real  :: crfvis_hi, crfvis_mid, crfvis_low,    &
         crfir_hi,  crfir_mid,  crfir_low,  &
         cabir_hi,  cabir_mid,  cabir_low

real  :: min_cld_drop_rad, max_cld_drop_rad, &
         min_cld_ice_size, max_cld_ice_size

!-------------------------------------------------------------------
!    logical flag.
!-------------------------------------------------------------------
logical  :: module_is_initialized = .false.

!-------------------------------------------------------------------
!-------------------------------------------------------------------



                           contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    
!#####################################################################

! <SUBROUTINE NAME="bulkphys_rad_init">
!  <OVERVIEW>
!    subroutine bulkphys_rad_init is the constructor for
!    bulkphys_rad_mod.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine bulkphys_rad_init is the constructor for
!    bulkphys_rad_mod.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call bulkphys_rad_init (pref, lonb, latb)
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!       pref      array containing two reference pressure profiles
!                 for use in defining transmission functions [ Pa ]
! 
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!       lonb      2d array of model longitudes on cell corners
!                 [ radians ]
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
!       latb      2d array of model latitudes at cell corners [radians]
! 
!  </IN>
! </SUBROUTINE>
!
subroutine bulkphys_rad_init (min_cld_drop_rad_in, max_cld_drop_rad_in,&
                              min_cld_ice_size_in, max_cld_ice_size_in,&
                              pref, lonb, latb)

!---------------------------------------------------------------------
!    subroutine bulkphys_rad_init is the constructor for 
!    bulkphys_rad_mod.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
real,                 intent(in) :: min_cld_drop_rad_in, &
                                    max_cld_drop_rad_in,&
                                    min_cld_ice_size_in,  &
                                    max_cld_ice_size_in
real, dimension(:,:), intent(in) :: pref
real, dimension(:,:), intent(in) :: lonb, latb

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       pref      array containing two reference pressure profiles 
!                 for use in defining transmission functions [ Pa ]
!       lonb      2d array of model longitudes on cell corners [ radians ]
!       latb      2d array of model latitudes at cell corners [radians]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    local variables:

      integer  ::   unit, ierr, io, logunit
      integer  ::   idum

!---------------------------------------------------------------------
!    local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      ierr     error code
!      io       error status returned from io operation  
!      idum     dummy integer argument needed to satisfy 
!               diag_clouds_W_init call
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      if (Cldrad_control%do_diag_clouds)  call diag_clouds_W_init (idum)
      if (Cldrad_control%do_strat_clouds) call strat_clouds_W_init(latb, lonb)
      if (Cldrad_control%do_rh_clouds)    call rh_based_clouds_init 

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=bulkphys_rad_nml, iostat=io)
      ierr = check_nml_error(io,'bulkphys_rad_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=bulkphys_rad_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'bulkphys_rad_nml')
        enddo
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                      write (logunit, nml=bulkphys_rad_nml)

      min_cld_drop_rad = min_cld_drop_rad_in
      max_cld_drop_rad = max_cld_drop_rad_in
      min_cld_ice_size = min_cld_ice_size_in
      max_cld_ice_size = max_cld_ice_size_in

!--------------------------------------------------------------------
!    when executing the gcm or the standalone gcm, define the values
!    of absorptivity and reflectivity to be used for low, middle and
!    high clouds. the values used are different for different cloud 
!    parameterizations.
!---------------------------------------------------------------------
        if (Cldrad_control%do_mgroup_prescribed_iz) then
        if (Cldrad_control%do_mgroup_prescribed) then
          crfvis_hi  = crfvis_hi_2
          crfir_hi   = crfir_hi_2
          crfvis_mid = crfvis_mid_2
          crfir_mid  = crfir_mid_2
          crfvis_low = crfvis_low_2
          crfir_low  = crfir_low_2
          cabir_hi   = cabir_hi_2
          cabir_mid  = cabir_mid_2
          cabir_low  = cabir_low_2
        else
          crfvis_hi  = crfvis_hi_1
          crfir_hi   = crfir_hi_1
          crfvis_mid = crfvis_mid_1
          crfir_mid  = crfir_mid_1
          crfvis_low = crfvis_low_1
          crfir_low  = crfir_low_1
          cabir_hi   = cabir_hi_1
          cabir_mid  = cabir_mid_1
          cabir_low  = cabir_low_1
        endif
      else
        call error_mesg ('bulkphys_rad_mod', &
        ' do_mgroup_prescribed not yet defined', FATAL)
      endif

!---------------------------------------------------------------------
!    when running in standalone columns mode, call 
!    define_column_properties to define the cloud radiative properties.
!---------------------------------------------------------------------
    if (Cldrad_control%do_specified_strat_clouds_iz .and.  &
        Cldrad_control%do_specified_clouds_iz) then
       if (Cldrad_control%do_specified_strat_clouds  .or.  &
           Cldrad_control%do_specified_clouds ) then 
        call standalone_clouds_init   (pref, lonb, latb)
        call define_column_properties (pref, lonb, latb)
       endif 
    else
        call error_mesg ('bulkphys_rad_mod', &
        ' do_specified_strat not yet defined', FATAL)
   endif

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!----------------------------------------------------------------------



end subroutine bulkphys_rad_init



!#################################################################

! <SUBROUTINE NAME="bulkphys_sw_driver">
!  <OVERVIEW>
!    bulkphys_sw_driver obtains bulk shortwave cloud radiative
!    properties for the active cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    bulkphys_sw_driver obtains bulk shortwave cloud radiative
!    properties for the active cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call bulkphys_sw_driver (is, ie, js, je, cosz, Cld_spec,   &
!                Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="cosz" TYPE="real">
!      cosz         cosine of the zenith angle [ dimensionless ]
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec     cloud specification arrays defining the
!                   location, amount and type (hi, middle, lo)
!                   of clouds that are present, provides input
!                   to this subroutine
!                   [ cld_specification_type ]
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the
!                               visible frequency band
!                               [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine bulkphys_sw_driver (is, ie, js, je, cosz, Cld_spec,   &
                              Cldrad_props)

!---------------------------------------------------------------------
!    bulkphys_sw_driver obtains bulk shortwave cloud radiative 
!    properties for the active cloud scheme.
!---------------------------------------------------------------------
 
integer,                      intent(in)    :: is, ie, js, je
real,    dimension(:,:),      intent(in)    :: cosz
type(cld_specification_type), intent(in)    :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      cosz         cosine of the zenith angle [ dimensionless ]
!      Cld_spec     cloud specification arrays defining the 
!                   location, amount and type (hi, middle, lo)
!                   of clouds that are present, provides input 
!                   to this subroutine
!                   [ cld_specification_type ]
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:

      integer     ::    i, j, k       ! do-loop indices

!---------------------------------------------------------------------
!    call obtain_bulk_sw_rh to obtain the cloud-radiative properties 
!    for rh_based_clouds.
!---------------------------------------------------------------------
      if (Cldrad_control%do_rh_clouds) then
        call obtain_bulk_sw_rh (is, ie, js, je, cosz, Cld_spec,   &
                                Cldrad_props)

!--------------------------------------------------------------------
!    values for zonal_clouds, prescribed_clouds and obs_clouds are
!    specified and constant in time. assign the proper values for cloud
!    absorptivity and reflectivity to each grid box with cloudiness, 
!    dependent on whether the cloud in that box is defined as being 
!    high, middle or low cloud. 
!----------------------------------------------------------------------
      else if(Cldrad_control%do_zonal_clouds .or. &
              Cldrad_control%do_mgroup_prescribed .or.  &
              Cldrad_control%do_obs_clouds) then
        do k=1, size(Cld_spec%hi_cloud,3)              
          do j=1,size(Cld_spec%hi_cloud,2)
            do i=1,size(Cld_spec%hi_cloud,1)
              if (Cld_spec%hi_cloud(i,j,k)) then
                Cldrad_props%cirabsw(i,j,k)  = cabir_hi 
                Cldrad_props%cirrfsw(i,j,k)  = crfir_hi
                Cldrad_props%cvisrfsw(i,j,k) = crfvis_hi
              else if (Cld_spec%mid_cloud(i,j,k)) then
                Cldrad_props%cirabsw(i,j,k)  = cabir_mid
                Cldrad_props%cirrfsw(i,j,k)  = crfir_mid
                Cldrad_props%cvisrfsw(i,j,k) = crfvis_mid
              else if (Cld_spec%low_cloud(i,j,k)) then
                Cldrad_props%cirabsw(i,j,k)  = cabir_low
                Cldrad_props%cirrfsw(i,j,k)  = crfir_low
                Cldrad_props%cvisrfsw(i,j,k) = crfvis_low
              endif
            end do
          end do
        end do

!---------------------------------------------------------------------
!    call obtain_bulk_sw_diag to define the cloud radiative properties
!    for the gordon diagnostic cloud scheme.
!---------------------------------------------------------------------
      else if (Cldrad_control%do_diag_clouds) then
        call obtain_bulk_sw_diag (is, ie, js, je, cosz, Cld_spec,  &
                                  Cldrad_props)

!---------------------------------------------------------------------
!    call obtain_bulk_sw_strat to define the cloud radiative properties
!    for the klein prognostic cloud scheme.
!---------------------------------------------------------------------
      else if (Cldrad_control%do_strat_clouds) then
        call obtain_bulk_sw_strat (is, ie, js, je, cosz, Cld_spec,   &
                                   Cldrad_props)

!-------------------------------------------------------------------
!    call obtain_bulk_sw_sa to define the cloud radiative properties
!    when specified clouds are used in standalone columns mode.
!-------------------------------------------------------------------
      else if (Cldrad_control%do_specified_clouds) then
        call obtain_bulk_sw_sa (is, ie, js, je, Cldrad_props)
      endif

!----------------------------------------------------------------------
 

end subroutine bulkphys_sw_driver



!####################################################################

! <SUBROUTINE NAME="bulkphys_lw_driver">
!  <OVERVIEW>
!    bulkphys_lw_driver defines bulk longwave cloud radiative
!    properties for the active cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    bulkphys_lw_driver defines bulk longwave cloud radiative
!    properties for the active cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call bulkphys_lw_driver (is, ie, js, je, Cld_spec, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for
!                               maximally overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine bulkphys_lw_driver (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    bulkphys_lw_driver defines bulk longwave cloud radiative 
!    properties for the active cloud scheme.
!---------------------------------------------------------------------

integer,                      intent(in)    :: is, ie, js, je
type(cld_specification_type), intent(in)    :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:

      integer    :: i, j, k      ! do-loop indices

!------------------------------------------------------------------
!    call obtain_bulk_lw_rh to define long-wave cloud emissivity for
!    rh_based_clouds_mod.
!-------------------------------------------------------------------
      if (Cldrad_control%do_rh_clouds) then
        call obtain_bulk_lw_rh (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    assign the proper values for cloud emissivity to each grid box
!    with cloudiness, dependent on whether the cloud in that box is 
!    defined as being high, middle or low cloud. high and middle clouds
!    are assumed to be random overlap, low clouds are assume to be
!    maximum overlap.
!----------------------------------------------------------------------
      else if (Cldrad_control%do_zonal_clouds .or.   &
               Cldrad_control%do_mgroup_prescribed .or.  &
               Cldrad_control%do_obs_clouds)  then
        do k=1, size(Cld_spec%hi_cloud,3)              
          do j=1,size(Cld_spec%hi_cloud,2)
            do i=1,size(Cld_spec%hi_cloud,1)
              if (Cld_spec%hi_cloud(i,j,k)) then
                Cldrad_props%emrndlw(i,j,k,:,1)  = cldem_hi
              else if (Cld_spec%mid_cloud(i,j,k)) then
                Cldrad_props%emrndlw(i,j,k,:,1)  = cldem_mid
              else if (Cld_spec%low_cloud(i,j,k)) then
                Cldrad_props%emmxolw(i,j,k,:,1)  = cldem_low
              endif
            end do
          end do
        end do

!------------------------------------------------------------------
!    call obtain_bulk_lw_diag to define long-wave cloud emissivity for
!    diag_based_clouds_mod.
!-------------------------------------------------------------------
      else if (Cldrad_control%do_diag_clouds) then
        call obtain_bulk_lw_diag (is, ie, js, je, Cld_spec,  &
                                  Cldrad_props)
 
!------------------------------------------------------------------
!    call obtain_bulk_lw_strat to define long-wave cloud emissivity for
!    strat_clouds_mod.
!-------------------------------------------------------------------
      else if (Cldrad_control%do_strat_clouds) then
        call obtain_bulk_lw_strat (is, ie, js, je, Cld_spec,   &
                                   Cldrad_props)

!--------------------------------------------------------------------
!    call obtain_bulk_lw_sa to define long-wave cloud emissivity for
!    specified clouds when running in standalone columns mode.
!-------------------------------------------------------------------
      else if (Cldrad_control%do_specified_clouds) then
        call obtain_bulk_lw_sa (is, ie, js, je, Cldrad_props)
      endif

!---------------------------------------------------------------------



end subroutine bulkphys_lw_driver



!###################################################################
 
! <SUBROUTINE NAME="bulkphys_rad_end">
!  <OVERVIEW>
!    bulkphys_rad_end is the destructor for bulkphys_rad_mod.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    bulkphys_rad_end is the destructor for bulkphys_rad_mod.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call bulkphys_rad_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine bulkphys_rad_end

!-------------------------------------------------------------------
!    bulkphys_rad_end is the destructor for bulkphys_rad_mod.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    mark the module as not initialized.
!--------------------------------------------------------------------
     module_is_initialized = .false.

!--------------------------------------------------------------------


end subroutine bulkphys_rad_end



                     end module bulkphys_rad_mod

 


                 module cloudrad_diagnostics_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    cloudrad_diagnostics_mod generates any desired netcdf output
!    fields involving the cloud fields seen by the radiation package
!    or the cloud radiation interaction variables.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

! shared modules:

use mpp_mod,                 only: input_nml_file
use fms_mod,                 only: fms_init, open_namelist_file, &
                                   write_version_number, mpp_pe, &
                                   mpp_root_pe, stdlog, file_exist,  &
                                   check_nml_error, error_mesg,   &
                                   FATAL, NOTE, close_file
use time_manager_mod,        only: time_type, time_manager_init
use diag_manager_mod,        only: register_diag_field, send_data, &
                                   diag_manager_init
use constants_mod,           only: diffac, GRAV, RDGAS

! shared radiation package modules:

use rad_utilities_mod,       only: rad_utilities_init, &
                                   cldrad_properties_type, &
                                   cld_specification_type, &
                                   Lw_control, &
                                   microrad_properties_type, &
                                   microphysics_type, atmos_input_type,&
                                   Cldrad_control

use esfsw_parameters_mod,    only: Solar_spect, esfsw_parameters_init

use microphys_rad_mod,       only: isccp_microphys_sw_driver,   &
                                   isccp_microphys_lw_driver

!  other cloud diagnostics modules

use isccp_clouds_mod,        only: isccp_clouds_init, isccp_clouds_end,&
                                   isccp_output, isccp_cloudtypes,   &
                                   isccp_cloudtypes_stochastic


!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    cloudrad_diagnostics_mod generates any desired netcdf output
!    fields involving the cloud fields seen by the radiation package
!    or the cloud radiation interaction variables.
!
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: cloudrad_diagnostics.F90,v 18.0.2.1 2010/08/30 20:39:46 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public          &
         cloudrad_diagnostics_init, cloudrad_netcdf, &
         obtain_cloud_tau_and_em, modis_yim, modis_cmip, &
         model_micro_dealloc, cloudrad_diagnostics_end

private          &
!   called from cloudrad_diagnostics_init:
         diag_field_init, &
!   called from cloudrad_netcdf:
         isccp_diag, isccp_diag_stochastic, compute_isccp_clds,  &
!   called from isccp_diag:  
         cloud_optical_properties_diag


!---------------------------------------------------------------------
!-------- namelist  ---------
!
! do_isccp                 should isccp_cloudtypes processing be done?
!
! do_outdated_isccp        should isccp_cloudtypes processing be done,
!                          here, using outdated isccp code? the 
!                          recommended approach is to use isccp 
!                          supplied via the COSP simulator
!
! isccp_actual_radprops    should the GCM's radiative properties be 
!                          used in the isccp_cloudtypes processing?
!                          If false, then use properties diagnosed
!                          locally from cloud_optical_properties_diag.
!       
! isccp_scale_factor       This scale factor is here to remove the
!                          scaling of liquid water and ice water 
!                          paths in the cloud_rad to account for the
!                          plane-parallel homogenous cloud bias.
!
!                          NOTE THAT THIS SCALE FACTOR SHOULD BE
!                          SET IDENTICAL TO THE ONE SET IN THE
!                          NAMELIST TO CLOUD_RAD.f90
!
!                          It is put here because the diagnostics
!                          are on the clouds themselves, not the
!                          radiative fluxes.  The scale factor
!                          only exists to compute radiative transfer
!                          more accurately.    

logical :: do_isccp = .false.
logical :: do_outdated_isccp = .false.
logical :: isccp_actual_radprops = .true.
real    :: isccp_scale_factor = 0.85
logical :: cloud_screen = .false.
real    :: cloud_cover_limit = 0.8
real    :: cod_limit = 2.
real    :: water_ice_ratio =1.

namelist /cloudrad_diagnostics_nml /  do_isccp, isccp_actual_radprops,&
                                      do_outdated_isccp, &
                                      isccp_scale_factor, cloud_screen,&
                                      cloud_cover_limit, cod_limit, &
                                      water_ice_ratio


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

real, parameter  :: taumin = 1.E-06  ! minimum value allowed for 
                                     ! optical depth 
                                     ! [ dimensionless ]

real,  parameter :: mid_btm  = 6.8e4  ! isccp boundaries
real, parameter  :: high_btm = 4.4e4  ! isccp boundaries
      
!----------------------------------------------------------------------
!    minimum and maximum cloud drop and crystal sizes allowable for use 
!    in microphysically-based radiative property parameterizations 
!----------------------------------------------------------------------
real             :: min_cld_drop_rad, max_cld_drop_rad, &
                    min_cld_ice_size, max_cld_ice_size, &
                    mn_drp_diam, mx_drp_diam

!----------------------------------------------------------------------
!    number of stochastic subcolumns 
!----------------------------------------------------------------------
integer          :: ncol 

integer          :: nswbands, isccpSwBand, isccpLwBand
integer          :: iuv, ivis, inir

!----------------------------------------------------------------------
!    diagnostics variables.     
!----------------------------------------------------------------------
character(len=8)    :: mod_name = 'cloudrad'
real                :: missing_value = -999.

integer :: id_tot_cld_amt, id_cld_amt, &
           id_high_cld_amt, id_mid_cld_amt, id_low_cld_amt,  &
           id_lam_cld_amt
integer :: id_reff_modis, id_reff_modis2, id_reff_modis3
integer :: id_cldtop_reff, id_cldtop_area, id_cldtop_dropnum, &
           id_dropnum_col

! radiative property diagnostics
integer :: id_em_cld_lw, id_em_cld_10u, & 
           id_abs_lsc_cld_10u, id_abs_lsc_cld_lw,  &
           id_abs_cell_cld_10u, id_abs_cell_cld_lw,  &
           id_abs_meso_cld_10u, id_abs_meso_cld_lw,  &
           id_abs_shallow_cld_10u, id_abs_shallow_cld_lw,  &
           id_abs_cld_10u, id_abs_cld_lw,  &
           id_lsc_cld_ext_uv, id_lsc_cld_ext_vis, id_lsc_cld_ext_nir, &
           id_lsc_cld_sct_uv, id_lsc_cld_sct_vis, id_lsc_cld_sct_nir, &
           id_lsc_cld_asymm_uv, id_lsc_cld_asymm_vis,    &
           id_lsc_cld_asymm_nir, &
           id_cell_cld_ext_uv, id_cell_cld_ext_vis,    &
           id_cell_cld_ext_nir, &
           id_cell_cld_sct_uv, id_cell_cld_sct_vis,    &
           id_cell_cld_sct_nir, &
           id_cell_cld_asymm_uv, id_cell_cld_asymm_vis,    &
           id_cell_cld_asymm_nir, &
           id_meso_cld_ext_uv, id_meso_cld_ext_vis,   &
           id_meso_cld_ext_nir, &
           id_meso_cld_sct_uv, id_meso_cld_sct_vis,   &
           id_meso_cld_sct_nir, &
           id_meso_cld_asymm_uv, id_meso_cld_asymm_vis,    &
           id_meso_cld_asymm_nir, &
           id_shallow_cld_ext_uv, id_shallow_cld_ext_vis,    &
           id_shallow_cld_ext_nir, &
           id_shallow_cld_sct_uv, id_shallow_cld_sct_vis,    &
           id_shallow_cld_sct_nir, &
           id_shallow_cld_asymm_uv, id_shallow_cld_asymm_vis,    &
           id_shallow_cld_asymm_nir,    &
           id_ext_cld_uv,   id_sct_cld_uv,  id_asymm_cld_uv, &
           id_ext_cld_vis,  id_sct_cld_vis, id_asymm_cld_vis, &
           id_ext_cld_nir,  id_sct_cld_nir, id_asymm_cld_nir, &
           id_alb_uv_cld, id_alb_nir_cld, id_abs_uv_cld, id_abs_nir_cld
   
! strat cloud microphysical properties diagnostics
integer::  id_strat_area_liq, id_strat_conc_drop, id_strat_size_drop,&
           id_ra_strat_size_drop, id_strat_area_ice, &
           id_strat_conc_ice, id_strat_size_ice, &
           id_strat_droplet_number, id_gb_strat_conc_ice,   &
           id_gb_strat_conc_drop, id_lsc_cld_amt,  id_lsc_lwp, &
           id_gb_lsc_lwp, id_lsc_iwp, id_gb_lsc_iwp

! donner meso cloud microphysical properties diagnostics
integer::  id_meso_area_liq, id_meso_conc_drop, id_meso_size_drop,&
           id_ra_meso_size_drop, id_meso_area_ice, id_meso_conc_ice, &
           id_meso_size_ice, id_meso_droplet_number, &
           id_gb_meso_conc_ice, id_gb_meso_conc_drop, id_meso_cld_amt, &
           id_meso_lwp, id_gb_meso_lwp, id_meso_iwp, id_gb_meso_iwp

! donner cell cloud microphysical properties diagnostics
integer::  id_cell_area_liq, id_cell_conc_drop, id_cell_size_drop,&
           id_ra_cell_size_drop, id_cell_area_ice, id_cell_conc_ice, &
           id_cell_size_ice, id_cell_droplet_number, &
           id_gb_cell_conc_ice, id_gb_cell_conc_drop, id_cell_cld_amt, &
           id_cell_lwp, id_gb_cell_lwp, id_cell_iwp, id_gb_cell_iwp

! uw shallow cloud microphysical properties diagnostics
integer::  id_shallow_area_liq, id_shallow_conc_drop,   &
           id_shallow_size_drop, id_ra_shallow_size_drop, &
           id_shallow_area_ice, id_shallow_conc_ice,  &
           id_shallow_size_ice, id_shallow_droplet_number, &
           id_gb_shallow_conc_ice, id_gb_shallow_conc_drop, &
           id_shallow_cld_amt, id_shallow_lwp, id_gb_shallow_lwp, &
           id_shallow_iwp, id_gb_shallow_iwp

! sum over all active cloud schemes, non-stochastic only
integer::  id_all_conc_drop, id_all_conc_ice, &
           id_predicted_cld_amt

! stochastic cloud diagnostics, avgd over all bands 
integer :: id_cldfrac_tot
integer :: id_cldfrac_ave, id_ice_conc_ave, id_drop_size_ave, &
           id_ice_size_ave, id_ra_drop_size_ave, id_drop_conc_ave, &
           id_droplet_number_ave, id_liq_col_frac_ave,  &
           id_ice_col_frac_ave, &
           id_ic_drop_conc_ave, id_ic_ice_conc_ave, id_lwp_ave,  &  
           id_ic_lwp_ave, id_iwp_ave, id_ic_iwp_ave, id_lsc_lwp_ave, &
           id_cell_lwp_ave, id_meso_lwp_ave, id_shallow_lwp_ave, &
           id_lsc_iwp_ave, id_cell_iwp_ave, id_meso_iwp_ave, &
           id_shallow_iwp_ave, id_lsc_drop_conc_ave,  &
           id_cell_drop_conc_ave, id_meso_drop_conc_ave, & 
           id_shallow_drop_conc_ave, id_lsc_ice_conc_ave,  &
           id_cell_ice_conc_ave, id_meso_ice_conc_ave, & 
           id_shallow_ice_conc_ave

!   stochastic cloud diagnostics used to show effects of extending
!   stochastic treatment to cloud types other than lsc
integer :: id_cldfrac_only_lsc, id_drop_size_only_lsc, &
           id_ice_size_only_lsc, id_ra_drop_size_only_lsc, &
           id_droplet_number_only_lsc, id_liq_col_only_lsc, &
           id_ice_col_only_lsc, id_drop_conc_only_lsc,  &
           id_ice_conc_only_lsc, id_ic_drop_conc_only_lsc, &
           id_ic_ice_conc_only_lsc, id_ic_lwp_only_lsc, &
           id_ic_iwp_only_lsc,  id_lwp_only_lsc, id_iwp_only_lsc
integer :: id_LWPr

! stochastic cloud sampling diagnostics
integer :: id_stoch_ic_cell_cf_ave, id_stoch_ic_meso_cf_ave, &
           id_stoch_ic_lsc_cf_ave, id_stoch_ic_shallow_cf_ave
integer :: id_stoch_sees_cell, id_stoch_sees_meso, &
           id_stoch_sees_lsc, id_stoch_sees_shallow
integer :: id_stoch_cell_cf_ave, id_stoch_shallow_cf_ave, &
           id_stoch_meso_cf_ave, id_stoch_lsc_cf_ave

! diagnostics for each stochastic column:
integer, dimension(:), allocatable ::    &
           id_stoch_cloud_type, &
           id_cldfrac_cols, id_ice_conc_cols, id_ice_size_cols, &
           id_drop_conc_cols, id_drop_size_cols, id_ra_drop_size_cols, &
           id_droplet_number_cols, id_lwp_cols, id_iwp_cols

! diagnostics for each stochastic column, used to show effects of 
! treating non-lsc clouds stochastically:
integer, dimension(:), allocatable ::    &
           id_cldfrac_cols_only_lsc, id_ice_conc_cols_only_lsc, &
           id_ice_size_cols_only_lsc, id_drop_conc_cols_only_lsc, &
           id_drop_size_cols_only_lsc, id_ra_drop_size_cols_only_lsc, &
           id_droplet_number_cols_only_lsc, id_lwp_cols_only_lsc, &
           id_iwp_cols_only_lsc

logical :: module_is_initialized = .false.    ! module  initialized ?


!----------------------------------------------------------------------
!----------------------------------------------------------------------



                        contains 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#####################################################################
! <SUBROUTINE NAME="cloudrad_diagnostics_init">
!  <OVERVIEW>
!    cloudrad_diagnostics_init is the constructor for 
!    cloudrad_diagnostics_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    cloudrad_diagnostics_init is the constructor for 
!    cloudrad_diagnostics_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloudrad_diagnostics_init (axes, Time)
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="real">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
! </SUBROUTINE>
!
subroutine cloudrad_diagnostics_init (min_cld_drop_rad_in,  &
                                      max_cld_drop_rad_in, &
                                      min_cld_ice_size_in, &
                                      max_cld_ice_size_in, axes, Time)

!---------------------------------------------------------------------
!    cloudrad_diagnostics_init is the constructor for 
!    cloudrad_diagnostics_mod.
!------------------------------------------------------------------

real,                    intent(in)    ::   min_cld_drop_rad_in, &
                                            max_cld_drop_rad_in, &
                                            min_cld_ice_size_in, &
                                            max_cld_ice_size_in
integer, dimension(4),   intent(in)    ::   axes
type(time_type),         intent(in)    ::   Time

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       min_cld_drop_rad_in   smallest cloud droplet radius allowed by
!                             radiative properties parameterizations
!                             [ microns ]
!       max_cld_drop_rad_in   largest cloud droplet radius allowed by
!                             radiative properties parameterizations
!                             [ microns ]
!       min_cld_ice_size_in   smallest cloud ice size allowed by
!                             radiative properties parameterizations
!                             [ microns ]
!       max_cld_ice_size_in   largest cloud ice size allowed by
!                             radiative properties parameterizations
!                             [ microns ]
!       axes                  diagnostic variable axes
!       Time                  current time [time_type(days, seconds)]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer         :: unit, io, ierr, logunit

!---------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      io       error status returned from io operation  
!      ierr     error code
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call time_manager_init
      call esfsw_parameters_init
      call diag_manager_init

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cloudrad_diagnostics_nml, iostat=io)
      ierr = check_nml_error(io,'cloudrad_diagnostics_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=cloudrad_diagnostics_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'cloudrad_diagnostics_nml')
        enddo
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                       write (logunit, nml=cloudrad_diagnostics_nml)
 
!---------------------------------------------------------------------
!    define module variables to retain the smallest and largest 
!    allowable droplet and ice particle sizes which can be processed
!    by the model radiative parameterizations.
!---------------------------------------------------------------------
      min_cld_drop_rad = min_cld_drop_rad_in
      max_cld_drop_rad = max_cld_drop_rad_in
      min_cld_ice_size = min_cld_ice_size_in
      max_cld_ice_size = max_cld_ice_size_in
      mn_drp_diam    = 2.*min_cld_drop_rad
      mx_drp_diam    = 2.*max_cld_drop_rad

!---------------------------------------------------------------------
!    allocate the arrays needed to hold the diagnostics to be gener-
!    ated for each of the ncol stochastic sub-columns.
!---------------------------------------------------------------------
      ncol = Cldrad_control%nlwcldb + Solar_spect%nbands
      if (Cldrad_control%do_stochastic_clouds_iz) then
        if (Cldrad_control%do_stochastic_clouds) then
          allocate (id_stoch_cloud_type        (ncol))
          allocate (id_cldfrac_cols            (ncol))
          allocate (id_ice_conc_cols           (ncol))
          allocate (id_drop_conc_cols          (ncol))
          allocate (id_ice_size_cols           (ncol))
          allocate (id_drop_size_cols          (ncol))
          allocate (id_ra_drop_size_cols       (ncol))
          allocate (id_droplet_number_cols     (ncol))
          allocate (id_lwp_cols                (ncol))
          allocate (id_iwp_cols                (ncol))
          allocate (id_cldfrac_cols_only_lsc   (ncol))
          allocate (id_ice_conc_cols_only_lsc  (ncol))
          allocate (id_drop_conc_cols_only_lsc (ncol))
          allocate (id_ice_size_cols_only_lsc  (ncol))
          allocate (id_drop_size_cols_only_lsc      (ncol))
          allocate (id_ra_drop_size_cols_only_lsc   (ncol))
          allocate (id_droplet_number_cols_only_lsc (ncol))
          allocate (id_lwp_cols_only_lsc            (ncol))
          allocate (id_iwp_cols_only_lsc            (ncol)) 
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod',  &
         'Cldrad_control%do_stochastic_clouds not yet defined', &
                                                               FATAL)
      endif
 
!-------------------------------------------------------------------
!    initialize the netcdf diagnostics provided with this module.
!-------------------------------------------------------------------
      if (Cldrad_control%do_no_clouds_iz) then
        if (.not. Cldrad_control%do_no_clouds) then
          call diag_field_init (Time, axes)
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod',  &
         'Cldrad_control%do_no_clouds not yet defined', FATAL)
      endif

!--------------------------------------------------------------------
!    decide if isccp processing will be done here, using outdated 
!    code.
!--------------------------------------------------------------------
      if (do_isccp) then
        if (do_outdated_isccp) then
!         the outdated isccp code referenced here will be executed
        else
          call error_mesg ('cloudrad_diagnostics', &
           ' The isccp code in this module is outdated. if you REALLY &
             &want to use it, set do_outdated_isccp in this nml &
             &to .true., and resubmit; otherwise use the COSP &
             &simulator interface to obtain isccp analysis.', NOTE)
          call error_mesg ('cloudrad_diagnostics', &
             ' The yim modis output is controlled by setting &
         &do_modis_yim to .true. (default)in physics_driver_nml.', NOTE)
          do_isccp = .false.
!         if (mpp_pe() == mpp_root_pe() ) then
!           call error_mesg ('cloudrad_diagnostics', &
!            ' See above two NOTES for ways to avoid this error', FATAL)
!         endif
        endif
      else
        if (do_outdated_isccp) then
          call error_mesg ('cloudrad_diagnostics', &
           'if you REALLY want to use outdated isccp code, you must &
             &also set do_isccp in this nml to .true., and &
             &resubmit; otherwise use the COSP simulator.', NOTE)
          call error_mesg ('cloudrad_diagnostics', &
              ' To get the simple modis output, set do_modis_yim to &
               &.true. in physics_driver_nml.', NOTE)  
          if (mpp_pe() == mpp_root_pe() ) then
            call error_mesg ('cloudrad_diagnostics', &
             ' See above two NOTES for ways to avoid this error', FATAL)
          endif
        endif
      endif

!---------------------------------------------------------------------
!    initialize isccp_clouds_init 
!---------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds_iz) then
        if (Cldrad_control%do_strat_clouds) then
          if (do_isccp) call isccp_clouds_init (axes, Time)
        endif 
        if (do_isccp) then
          if (.not. Cldrad_control%do_strat_clouds) then
            call error_mesg ('cloudrad_diagnostics_mod',  &
                 'if isccp diagnostics desired, strat_clouds &
                                             &must be active', FATAL)
          endif
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod',  &
         'Cldrad_control%do_strat_clouds not yet defined', FATAL)
      endif

      nswbands = Solar_spect%nbands

!--------------------------------------------------------------------
!    define the number of shortwave bands and set integer correspond-
!    ance for diagnostics output
!
!    The understanding used in this code is that there are 2 
!    resolutions to the shortwave spectrum.  A high resolution with
!    25 bands and a low resolution with 18 bands.  The low resolution
!    is used conventional for AM2.      Here are the bands in the 
!    high and low res used for the UV, VIS, and NIR prescriptions
!    below.
!
!
!    For Low Resolution (nswbands = 18) :
!
!    Region   iband     Wavenumbers (cm-1)         Wavelength (microns)
!    ------   -----     ------------------         --------------------
!
!     UV       15          35300-36500                    0.274-0.283
!     VIS       7          16700-20000                      0.5-0.6
!     NIR       3           4200-8200                      1.22-2.38
!
!
!    For High Resolution (nswbands = 25) :
!
!    Region   iband     Wavenumbers (cm-1)         Wavelength (microns)
!    ------   -----     ------------------         --------------------
!
!     UV       22          35300-36500                    0.274-0.283
!     VIS      12          16700-20000                      0.5-0.6
!     NIR       8           6200-8200                      1.22-1.61
!
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! Which bands to use for ISCCP cloud detection?
!
!    Note that cloud optical thickness in the visible band is sent
!    to isccp diag.  Band 6 corresponds to 14600-16700 cm-1 or 
!    0.6-0.685 microns, from 18 band structure.
!
!    If the multi-band lw emissivity is active, longwave emissivity 
!    is taken from the band closest to 10 microns (900-990 cm-1 band, 
!    10.1-11.1 microns, band 4 of 8). If the multi-band lw cloud 
!    emissivity formulation is not active, longwave emissivity is 
!    taken from band 1 (0-2200 cm-1).
!---------------------------------------------------------------------
      select case(nswbands)
        case (25) 
          isccpSwBand = 11
          iuv=22
          ivis=12
          inir=8
        case (18) 
          isccpSwBand = 6
          iuv=15
          ivis=7
          inir=3
        case default
          isccpSwBand = 6
          iuv=15
          ivis=7
          inir=3
      end select
      if (Cldrad_control%do_lw_micro_iz) then
        if (Cldrad_control%do_lw_micro) then
          isccpLwBand = 4
        else
          isccpLwBand = 1    
        end if
      else
        call error_mesg ('cloudrad_diagnostics_mod',  &
         'Cldrad_control%do_lw_micro not yet defined', FATAL)
      endif

!--------------------------------------------------------------------
!    mark the module initialized.
!--------------------------------------------------------------------
      module_is_initialized= .true.

!--------------------------------------------------------------------



end subroutine cloudrad_diagnostics_init



!--------------------------------------------------------------------

subroutine obtain_cloud_tau_and_em (is, js, Model_microphys, &
                                    Atmos_input, &
                                    Tau_stoch, Lwem_stoch)


integer,                     intent(in)     :: is, js
type(atmos_input_type),      intent(in)     :: Atmos_input
type(microphysics_type),     intent(in)     :: Model_microphys
real, dimension(:,:,:,:),    intent(inout)  :: Tau_stoch, LwEm_stoch

      integer :: n

!--------------------------------------------------------------------
!    execute the following when stochastic clouds are activated. there 
!    are separate cloud fields for each sw and lw radiative band.
!--------------------------------------------------------------------
      if (Cldrad_control%do_stochastic_clouds) then
      
!---------------------------------------------------------------------
!    after this call the Tau array is actually extinction.
!---------------------------------------------------------------------
        call isccp_microphys_sw_driver   &
                          (is, js, isccpSwBand, Model_microphys,    &
                                                 cldext=Tau_stoch) 

!---------------------------------------------------------------------
!    and to get optical thickness...
!---------------------------------------------------------------------
        do n=1,ncol
          Tau_stoch(:,:,:,n) = (Tau_stoch(:,:,:,n)*         &
                   Atmos_input%deltaz(:,:,:)/1000./isccp_scale_factor)
        end do
 
!---------------------------------------------------------------------
!    at first the LwEm array holds the absorption coefficient...
!---------------------------------------------------------------------
        call isccp_microphys_lw_driver (is, js, isccpLwBand, &
                                Model_microphys, abscoeff=LwEm_stoch)
 
!---------------------------------------------------------------------
!    and then the emissivity 
!---------------------------------------------------------------------
        do n=1,ncol
          LwEm_stoch(:,:,:,n) = 1. -   &
               exp(-1.*diffac*(LwEm_stoch(:,:,:,n)*  &
                  Atmos_input%deltaz(:,:,:)/1000.)/isccp_scale_factor)
        end do
      else
        call error_mesg ('cloudrad_diagnostics', &
              'trying to activate cosp or modis_yim without &
                                           &stochastic clouds', FATAL)
      endif ! (do_stochastic_clouds)

!-------------------------------------------------------------------

end subroutine obtain_cloud_tau_and_em 




!#####################################################################

subroutine modis_yim (is, js, Time_diag, Tau_stoch, Model_microphys, &
                      Atmos_input)

integer,                        intent(in)   :: is, js
type(time_type),                intent(in)   :: Time_diag
type(microphysics_type),        intent(in)   :: Model_microphys
type(atmos_input_type),         intent(in)   :: Atmos_input
real, dimension(:,:,:,:),       intent(in)   :: Tau_stoch           


      real, dimension(size(Atmos_input%rh2o,1),                  &
                      size(Atmos_input%rh2o,2)) :: reff_modis,   &
                                                   reff_modis2,  &
                                                   reff_modis3      
                                                  
      integer    :: i, j, n, k
      real       :: reff_n, coun_n, pres_n, Tau_m, reff_m, coun_m
      integer    :: ix, jx, kx
      real       :: min_conc
      logical    :: used

!--------------------------------------------------------------------
      ix =  size(Atmos_input%rh2o,1)
      jx =  size(Atmos_input%rh2o,2)
      kx =  size(Atmos_input%rh2o,3)

!---------------------------------------------------------------------
!     generate diagnostics related to the drop sizes which would be
!     diagnosed from MODIS satellite data. use the isccp simulator 
!     data to retrieve the drop size.
!---------------------------------------------------------------------
      if (max(id_reff_modis, id_reff_modis2, id_reff_modis3) > 0) then
        reff_modis(:,:) = 0.
        reff_modis2(:,:) = 0.
        reff_modis3(:,:) = 0.

!---------------------------------------------------------------------
!     process each model grid column. the variables ending in _n accum-
!     ulate vertical column data across the stochastic columns for a
!     given model column.
!---------------------------------------------------------------------
        do j=1,jx
          do i=1,ix
            reff_n = 0.
            coun_n = 0.
            pres_n = 0.

!---------------------------------------------------------------------
!     process each stochastic column. the variables ending in _m accu-
!     mulate data in the vertical column for a given stochastic column.
!---------------------------------------------------------------------
            do n=1,ncol
              Tau_m = 0.
              reff_m = 0.
              coun_m = 0.

!----------------------------------------------------------------------
!     scan downward in each stochastic column until the cloud optical
!     depth limit (cod_limit) is reached (the limit of the MODIS scan).
!     accumulate the effective droplet diameter for each layer the scan
!     penetrates and keep count of the number of such layers.
!----------------------------------------------------------------------
              k = 1
              do while ( k <= kx .and. Tau_m <= cod_limit)
                Tau_m = Tau_m + Tau_stoch(i,j,k,n)
                min_conc = MAX (1.0e-10, water_ice_ratio*  &
                             Model_microphys%stoch_conc_ice(i,j,k,n)) 
                if (Model_microphys%stoch_conc_drop(i,j,k,n)  &
                                                   > min_conc) then  
                  if (Model_microphys%stoch_size_drop(i,j,k,n)  &
                                                            > 1. ) then 
                    reff_m = reff_m +    &
                               Model_microphys%stoch_size_drop(i,j,k,n)
                    coun_m = coun_m + 1.
                  endif
                endif
                k = k + 1
              end do

!---------------------------------------------------------------------
!     if there were any layers in this stochastic column which are seen
!     by MODIS, add the mean droplet diameter from this column to the 
!     sum being accumulated over the stochastic columns. increment the
!     count of contributing columns, and add the pressure of maximum
!     penetration to that accumulation array. 
!---------------------------------------------------------------------
              if (coun_m >= 1.) then
                reff_n = reff_n + reff_m/coun_m
                coun_n = coun_n + 1.
                pres_n = pres_n + Atmos_input%press(i,j,k)
              endif
            end do

!---------------------------------------------------------------------
!     if there were any stochastic columns in this grid column in which
!     MODIS would have seen drops,  process the data.
!---------------------------------------------------------------------
            if (coun_n >= 1.) then

!---------------------------------------------------------------------
!     if cloud_screen is .true., then drop sizes are reported only in 
!     columns with a cloud fraction greater than cloud_cover_limit.
!     otherwise, any grid columns with cloudiness in at least one
!     stochastic column will have the drop size reported. note here that
!     droplet diameter is now converted to droplet radius, and the 
!     pressure level of maximum penetration is converted to hPa.
!---------------------------------------------------------------------
              if (cloud_screen) then
                if (coun_n/real(ncol) > cloud_cover_limit) then
                  reff_modis(i,j) = 0.5*reff_n
                  reff_modis2(i,j) = coun_n
                  reff_modis3(i,j) = pres_n*1.0e-02
                endif  
              else
                reff_modis(i,j) = 0.5*reff_n
                reff_modis2(i,j) = coun_n
                reff_modis3(i,j) = pres_n*1.0e-02
              endif
            endif
          end do
        end do

!---------------------------------------------------------------------
!     send the data to diag_manager. post-processing of these output
!     fields will be needed.
!---------------------------------------------------------------------
        used = send_data (id_reff_modis, reff_modis, Time_diag, is, js)
        used = send_data (id_reff_modis2, reff_modis2,   &
                                                     Time_diag, is, js)
        used = send_data (id_reff_modis3, reff_modis3, &
                                                     Time_diag, is, js)
      endif  ! (reff_modis)

!--------------------------------------------------------------------


end subroutine modis_yim



!#####################################################################

subroutine modis_cmip (is, js, Time_diag, Lsc_microphys, &
                      Atmos_input)

integer,                        intent(in)   :: is, js
type(time_type),                intent(in)   :: Time_diag
type(microphysics_type),        intent(in)   :: Lsc_microphys
type(atmos_input_type),         intent(in)   :: Atmos_input


      real, dimension(size(Atmos_input%rh2o,1),                  &
                      size(Atmos_input%rh2o,2)) :: cldtop_reff,  &
                                                   cldtop_dropnum,  &
                                                   cldtop_area, &      
                                                   dropnum_col
      real, dimension(size(Atmos_input%rh2o,1),                  &
                      size(Atmos_input%rh2o,2),                 &
                      size(Atmos_input%rh2o,3)) :: dpog             
                                                  
      integer    :: i, j, k
      integer    :: ix, jx, kx
      logical    :: used

!--------------------------------------------------------------------
      ix =  size(Atmos_input%rh2o,1)
      jx =  size(Atmos_input%rh2o,2)
      kx =  size(Atmos_input%rh2o,3)

      cldtop_reff = 0.0              
      cldtop_area = 0.0              
      cldtop_dropnum = 0.0              

!---------------------------------------------------------------------
!     generate diagnostics related to the drop sizes which would be
!     diagnosed from MODIS satellite data. use the isccp simulator 
!     data to retrieve the drop size.
!---------------------------------------------------------------------
      if (max(id_cldtop_reff, id_cldtop_dropnum,  &
                                    id_dropnum_col) > 0) then
!---------------------------------------------------------------------
!     process each model grid column. the variables ending in _n accum-
!     ulate vertical column data across the stochastic columns for a
!     given model column.
!---------------------------------------------------------------------
        do j=1,jx
          do i=1,ix
            do k=1, kx

!----------------------------------------------------------------------
!     scan downward in each stochastic column until the cloud optical
!     depth limit (cod_limit) is reached (the limit of the MODIS scan).
!     accumulate the effective droplet diameter for each layer the scan
!     penetrates and keep count of the number of such layers.
!----------------------------------------------------------------------
                if (Lsc_microphys%conc_drop(i,j,k) > 0.0) then
                  cldtop_reff  (i,j) =  0.5*  &
                                Lsc_microphys%cldamt(i,j,k)* &
                                         Lsc_microphys%size_drop(i,j,k)
                  cldtop_dropnum(i,j) = (Atmos_input%press(i,j,k)/  &
                                   (RDGAS*Atmos_input%temp(i,j,k)))* &
                                Lsc_microphys%cldamt(i,j,k)* &
                                    Lsc_microphys%droplet_number(i,j,k)
                  cldtop_area(i,j) =  & 
                            Lsc_microphys%cldamt(i,j,k)
                  exit
                endif
            end do
          end do
          end do

          do k=1, kx
            dpog(:,:,k) = (Atmos_input%pflux(:,:,k+1) -     &
                                     Atmos_input%pflux(:,:,k))/GRAV
          end do
          dropnum_col(:,:) = SUM  &
            (Lsc_microphys%droplet_number*dpog*Lsc_microphys%cldamt, &
                                                                 dim=3)

!---------------------------------------------------------------------
!     send the data to diag_manager. post-processing of these output
!     fields will be needed.
!---------------------------------------------------------------------
        used = send_data (id_cldtop_reff, 1.0e-06*cldtop_reff, Time_diag, is, js)
        used = send_data (id_cldtop_area, cldtop_area, Time_diag, is, js)
        used = send_data (id_cldtop_dropnum, cldtop_dropnum,   &
                                                     Time_diag, is, js)
        used = send_data (id_dropnum_col, dropnum_col, &
                                                     Time_diag, is, js)
      endif  ! (id_cldtop_reff)

!----------------------------------------------------------------------


end subroutine modis_cmip



!###################################################################
! <SUBROUTINE NAME="cloudrad_netcdf">
!  <OVERVIEW>
!    cloudrad_netcdf generates and outputs netcdf fields describing the
!    cloud radiative properties, along with isccp cloud diagnostics
!    fields. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    cloudrad_netcdf generates and outputs netcdf fields describing the
!    cloud radiative properties, along with isccp cloud diagnostics
!    fields. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloudrad_netcdf (is, js, Time_diag, Atmos_input, cosz, &
!                            Lsc_microphys, Meso_microphys, &
!                            Cell_microphys, Shallow_microphys, &
!                            Lscrad_props,  Mesorad_props, &
!                            Cellrad_props, Shallowrad_props, &
!                            Cldrad_props,&
!                            Cld_spec, mask)
!  </TEMPLATE>
!  <IN NAME="is,js" TYPE="integer">
!   starting subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Time_diag" TYPE="time_type">
!   time on next timestep, used as stamp for 
!                        diagnostic output [ time_type (days, seconds) ]
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    atmospheric input fields on model grid,
!  </IN>
!  <IN NAME="cosz" TYPE="real">
!    cosine of solar zenith angle
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </IN>
!  <IN NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </IN>
!  <IN NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!  </IN>
!  <IN NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                        clouds associated with donner convection
!  </IN>
!  <IN NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                        clouds associated with uw shallow convection
!  </IN>
!  <IN NAME="Lscrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the large-scale 
!                      clouds   
!  </IN>
!  <IN NAME="Mesorad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the meso-scale
!                      clouds assciated with donner convection
!  </IN>
!  <IN NAME="Cellrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the convective cell
!                      clouds associated with donner convection 
!  </IN>
!  <IN NAME="Shallowrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the 
!                      clouds associated with uw shallow convection 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties on model grid
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! </SUBROUTINE>
!
subroutine cloudrad_netcdf (is, js, Time_diag, Atmos_input, cosz, &
                            Lsc_microphys, Meso_microphys, &
                            Cell_microphys, Shallow_microphys, &
                            Lscrad_props,   &
                            Mesorad_props, Cellrad_props,  &
                            Shallowrad_props, Cldrad_props,&
                            Cld_spec, Model_microphys, mask)

!---------------------------------------------------------------------
!    cloudrad_netcdf generates and outputs netcdf fields describing the
!    cloud radiative properties, along with isccp cloud diagnostics
!    fields. 
!---------------------------------------------------------------------

integer,                        intent(in)      :: is, js
type(time_type),                intent(in)      :: Time_diag
type(atmos_input_type),         intent(in)      :: Atmos_input
real, dimension(:,:),           intent(in)      :: cosz        
type(microphysics_type),        intent(in)      :: Lsc_microphys, &
                                                   Meso_microphys,&
                                                   Cell_microphys,&
                                                   Shallow_microphys
type(microrad_properties_type), intent(in)      :: Lscrad_props, &
                                                   Mesorad_props, &
                                                   Cellrad_props, &
                                                   Shallowrad_props
type(cldrad_properties_type),   intent(in)      :: Cldrad_props
type(cld_specification_type),   intent(in)      :: Cld_spec       
type(microphysics_type),        intent(inout)   :: Model_microphys
real, dimension(:,:,:),         intent(in),  &
                                       optional :: mask

!-------------------------------------------------------------------
!   intent(in) variables:
!
!      is,js           starting subdomain i,j indices of data 
!                      in the physics_window being integrated
!      Time_diag       time on next timestep, used as stamp for 
!                      diagnostic output [ time_type (days, seconds) ]
!      Atmos_input     atmospheric input fields on model grid,
!                      [ atmos_input_type ]
!      cosz            cosine of zenith angle --  mean value over
!                      appropriate averaging interval
!                      [ non-dimensional ]
!      Lsc_microphys   microphysical specification for large-scale 
!                      clouds
!                      [ microphysics_type ]
!      Meso_microphys  microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!                      [ microphysics_type ]
!      Cell_microphys  microphysical specification for convective cell
!                      clouds associated with donner convection
!                      [ microphysics_type ]
!   Shallow_microphys  microphysical specification for 
!                      clouds associated with uw shallow convection
!                      [ microphysics_type ]
!      Lscrad_props    cloud radiative properties for the large-scale 
!                      clouds   
!                      [ microrad_properties_type ]
!      Mesorad_props   cloud radiative properties for meso-scale 
!                      clouds associated with donner convection   
!                      [ microrad_properties_type ]
!      Cellrad_props   cloud radiative properties for convective cell
!                      clouds associated with donner convection  
!                      [ microrad_properties_type ]
!    Shallowrad_props   
!                      cloud radiative properties for
!                      clouds associated with uw shallow convection  
!                      [ microrad_properties_type ]
!      Cldrad_props    total-cloud radiative properties,
!                      [ cldrad_properties_type ]
!      Cld_spec        variables on the model grid which define the 
!                      cloud location and amount     
!                      [ cld_specification_type ]
!
!   intent(in), optional variables:
!
!      mask              present when running eta vertical coordinate,
!                        mask to remove points below ground
!
!------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      real, dimension(size(Atmos_input%rh2o,1),                       &
                      size(Atmos_input%rh2o,2),                       &
                      size(Atmos_input%rh2o,3))  ::    &
                    cloud, cloud2, dpog, pmass, pmass2, ptm2

      logical, dimension(size(Atmos_input%rh2o,1),                   &
                         size(Atmos_input%rh2o,2))                    &
                                                    :: tmplmask2

      logical, dimension(size(Atmos_input%rh2o,1),                    &
                         size(Atmos_input%rh2o,2),                  &
                         size(Atmos_input%rh2o,3))  :: tmplmask, &
                                                       tmplmaska

      logical, dimension(size(Atmos_input%rh2o,1),                    &
                         size(Atmos_input%rh2o,2),                  &
                         size(Atmos_input%rh2o,3) ,     &
         Cldrad_control%nlwcldb + Solar_spect%nbands) ::   &
                                                    tmplmask4

      real, dimension(size(Atmos_input%rh2o,1),                       &
                      size(Atmos_input%rh2o,2))   :: tca, cloud2d, tca2 

      real, dimension(size(Atmos_input%rh2o,1),                       &
                      size(Atmos_input%rh2o,2),    &
                    Cldrad_control%nlwcldb + Solar_spect%nbands) ::   &
                                             cloud2n     

      real, dimension(size(Atmos_input%rh2o,1),                       &
                      size(Atmos_input%rh2o,2), 4)  :: hml_ca        

      real, dimension(size(Atmos_input%rh2o,1),                       &
                      size(Atmos_input%rh2o,2),                       &
                      size(Atmos_input%rh2o,3),     &
                    Cldrad_control%nlwcldb + Solar_spect%nbands) ::   &
                                                 Tau_stoch, LwEm_stoch

      real, dimension(size(Atmos_input%rh2o,1),                       &
                      size(Atmos_input%rh2o,2),                       &
                      size(Atmos_input%rh2o,3))   ::  Tau, LwEm

      logical    :: used
      integer    :: ix, jx, kx
      integer    :: i, j, k, n
      integer    :: nn


      
!---------------------------------------------------------------------
!  local variables:
!
!      cloud                array used to hold the various netcdf 
!                           output fields as they are sent off to 
!                           diag_manager_mod
!      tca                  total column cloud amount [ dimensionless ]
!      hml_ca               total column cloud amount for isccp high, 
!                           middle and low clouds, individually
!      used                 flag returned from send_data indicating
!                           whether diag_manager_mod has received 
!                           data that was sent
!      kx                   number of model layers 
!      i,j,k                do-loop indices
!      Model_microphys      microphysics_type variable used to hold the
!                           cloud physical properties actuaaly seen by
!                           the model in each stochastic band (only 
!                           present when do_stochastic_clouds = .true.)
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('cloudrad_diagnostics_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!--------------------------------------------------------------------
!    define the array dimensions on the processor.
!---------------------------------------------------------------------
      ix =  size(Cld_spec%camtsw,1)
      jx =  size(Cld_spec%camtsw,2)
      kx =  size(Cld_spec%camtsw,3)

!----------------------------------------------------------------------
!    compute the depth of each model layer to be used in defining water
!    paths. include the 10**3 factor needed to produce water path units
!    of kg(h2o) / m**2 rather than  g(h2o) / m**2. 
!    pmass is consistent with the expression used for donner ans uw
!    shallow clouds, while pmass2 is consistent with that used in
!    strat_cloud.
!----------------------------------------------------------------------
      do k=1,kx
        dpog(:,:,k) = (Atmos_input%pflux(:,:,k+1) -     &
                                     Atmos_input%pflux(:,:,k))/GRAV
        ptm2(:,:,k) = (Atmos_input%pflux(:,:,k+1) -    &
                                   Atmos_input%pflux(:,:,k)) / &
                         log(Atmos_input%pflux(:,:,k+1)/  &
                                   MAX(Atmos_input%pflux(:,:,k),   &
                                        Atmos_input%press(:,:,1))) 
        pmass2(:,:,k) = dpog(:,:,k)/  &
                         (1.0e03*ptm2(:,:,k)*isccp_scale_factor/  &
                                 (RDGAS*Atmos_input%temp(:,:,k)))
        pmass(:,:,k) = dpog(:,:,k)/   &
                         (1.0e03*Atmos_input%press(:,:,k)/&
                                 (RDGAS*Atmos_input%temp(:,:,k)))
      end do

!---------------------------------------------------------------------
!    allocate and initialize the components of a microphysics_type 
!    variable Model_microphys. this variable is used to hold the 
!    combination of stochastic column cloud physical properties actually
!    used by the model when stochastic clouds are active, and the 
!    combined cloud properties of all active cloud schemes when 
!    stochastic clouds are not active.
!---------------------------------------------------------------------
      allocate (Model_microphys%conc_drop  (ix, jx, kx) )
      allocate (Model_microphys%conc_ice   (ix, jx, kx) )
      allocate (Model_microphys%conc_rain  (ix, jx, kx) )
      allocate (Model_microphys%conc_snow  (ix, jx, kx) )
      allocate (Model_microphys%size_drop  (ix, jx, kx) )
      allocate (Model_microphys%size_ice   (ix, jx, kx) )
      allocate (Model_microphys%size_rain  (ix, jx, kx) )
      allocate (Model_microphys%size_snow  (ix, jx, kx) )
      allocate (Model_microphys%cldamt     (ix, jx, kx) )
      allocate (Model_microphys%droplet_number  (ix, jx, kx) )
      Model_microphys%conc_drop = 0.
      Model_microphys%conc_ice  = 0.
      Model_microphys%conc_rain = 0.
      Model_microphys%conc_snow = 0.
      Model_microphys%size_drop = 1.0e-20
      Model_microphys%size_ice  = 1.0e-20
      Model_microphys%size_rain = 1.0e-20
      Model_microphys%size_snow = 1.0e-20
      Model_microphys%cldamt     = 0.
      Model_microphys%droplet_number = 0.              

      if (Cldrad_control%do_stochastic_clouds) then
        allocate (Model_microphys%stoch_conc_ice (ix, jx, kx, nCol) )
        allocate (Model_microphys%stoch_conc_drop(ix, jx, kx, nCol) )
        allocate (Model_microphys%stoch_size_ice (ix, jx, kx, nCol) )
        allocate (Model_microphys%stoch_size_drop(ix, jx, kx, nCol) )
        allocate (Model_microphys%stoch_cldamt   (ix, jx, kx, nCol) )
        allocate (Model_microphys%stoch_cloud_type (ix, jx, kx, nCol) )
        allocate (Model_microphys%stoch_droplet_number   &
                                                 (ix, jx, kx, nCol) )

        Model_microphys%lw_stoch_conc_drop =>    &
         Model_microphys%stoch_conc_drop(:,:,:,1:Cldrad_control%nlwcldb)
        Model_microphys%lw_stoch_conc_ice  =>    &
         Model_microphys%stoch_conc_ice (:,:,:,1:Cldrad_control%nlwcldb)
        Model_microphys%lw_stoch_size_drop =>    &
         Model_microphys%stoch_size_drop(:,:,:,1:Cldrad_control%nlwcldb)
        Model_microphys%lw_stoch_size_ice  =>    &
         Model_microphys%stoch_size_ice (:,:,:,1:Cldrad_control%nlwcldb)
        Model_microphys%sw_stoch_conc_drop =>    &
         Model_microphys%stoch_conc_drop   &
                                       (:,:,:,Cldrad_control%nlwcldb+1:)
        Model_microphys%sw_stoch_conc_ice  =>    &
         Model_microphys%stoch_conc_ice(:,:,:,Cldrad_control%nlwcldb+1:)
        Model_microphys%sw_stoch_size_drop =>    &
         Model_microphys%stoch_size_drop   &
                                       (:,:,:,Cldrad_control%nlwcldb+1:)
        Model_microphys%sw_stoch_size_ice  =>    &
         Model_microphys%stoch_size_ice(:,:,:,Cldrad_control%nlwcldb+1:)
        Model_microphys%lw_stoch_cldamt =>     &
         Model_microphys%stoch_cldamt(:,:,:,1:Cldrad_control%nlwcldb)
        Model_microphys%sw_stoch_cldamt =>     &
         Model_microphys%stoch_cldamt(:,:,:,Cldrad_control%nlwcldb+1:)
        Model_microphys%lw_stoch_droplet_number =>     &
         Model_microphys%stoch_droplet_number   &
                                        (:,:,:,1:Cldrad_control%nlwcldb)
        Model_microphys%sw_stoch_droplet_number =>     &
         Model_microphys%stoch_droplet_number  &
                                       (:,:,:,Cldrad_control%nlwcldb+1:)
        Model_microphys%stoch_conc_drop = 0.
        Model_microphys%stoch_conc_ice  = 0.
        Model_microphys%stoch_size_drop = 1.0e-20
        Model_microphys%stoch_size_ice  = 1.0e-20
        Model_microphys%stoch_cldamt = 0.0
        Model_microphys%stoch_droplet_number = 0.0

!---------------------------------------------------------------------
!    since the sw bands come first in Cld_spec and the lw bands come 
!    first in  Model_microphys, the band index order must be reversed 
!    in defining Model_microphys%stoch_cloud_type.  
!---------------------------------------------------------------------
        do n=1,ncol
          if ( n > Solar_spect%nbands) then
            nn = n - Solar_spect%nbands
          else
            nn = n + Cldrad_control%nlwcldb
          endif

          Model_microphys%stoch_cloud_type(:,:,:,nn)  =  &
                                     Cld_spec%stoch_cloud_type(:,:,:,n)
        end do

!---------------------------------------------------------------------
!    define the cloud properties assigned to each stochastic column,
!    based on the cloud type assignment contained in 
!    Model_microphys%stoch_cloud_type. 
!---------------------------------------------------------------------
        if (Cldrad_control%do_donner_deep_clouds .or.  &
                                   Cldrad_control%do_uw_clouds) then
          do n=1,ncol
            do k=1,kx
              do j=1,jx
                do i=1,ix
                  if (Model_microphys%stoch_cloud_type(i,j,k,n)    &
                                                             == 1) then
                    Model_microphys%stoch_conc_drop(i,j,k,n) =    &
                                 Lsc_microphys%stoch_conc_drop(i,j,k,n)
                    Model_microphys%stoch_conc_ice(i,j,k,n)  =    &
                                Lsc_microphys%stoch_conc_ice (i,j,k,n)
                    Model_microphys%stoch_size_drop(i,j,k,n) =    &
                                Lsc_microphys%stoch_size_drop(i,j,k,n)
                    Model_microphys%stoch_size_ice(i,j,k,n)  =    &
                                 Lsc_microphys%stoch_size_ice(i,j,k,n)
                    Model_microphys%stoch_cldamt(i,j,k,n) =    1.0 
                    Model_microphys%stoch_droplet_number(i,j,k,n) =   &
                            Lsc_microphys%stoch_droplet_number(i,j,k,n)
                  else if (Model_microphys%stoch_cloud_type(i,j,k,n) &
                                                             == 2) then
                    Model_microphys%stoch_conc_drop(i,j,k,n) =    &
                                Meso_microphys%conc_drop(i,j,k)
                    Model_microphys%stoch_conc_ice(i,j,k,n)  =    &
                                Meso_microphys%conc_ice (i,j,k)
                    Model_microphys%stoch_size_drop(i,j,k,n) =    &
                                Meso_microphys%size_drop(i,j,k)
                    Model_microphys%stoch_size_ice(i,j,k,n)  =    &
                                Meso_microphys%size_ice(i,j,k)
                    Model_microphys%stoch_cldamt(i,j,k,n) =   1.0
                    Model_microphys%stoch_droplet_number(i,j,k,n) =   &
                           Meso_microphys%droplet_number(i,j,k) 
                  else if (Model_microphys%stoch_cloud_type(i,j,k,n)   &
                                                             == 3) then
                    Model_microphys%stoch_conc_drop(i,j,k,n) =    &
                                 Cell_microphys%conc_drop(i,j,k)
                    Model_microphys%stoch_conc_ice(i,j,k,n)  =    &
                                 Cell_microphys%conc_ice (i,j,k)
                    Model_microphys%stoch_size_drop(i,j,k,n) =    &
                                 Cell_microphys%size_drop(i,j,k)
                    Model_microphys%stoch_size_ice(i,j,k,n)  =    &
                                  Cell_microphys%size_ice(i,j,k)
                    Model_microphys%stoch_cldamt(i,j,k,n) =  1.0    
                    Model_microphys%stoch_droplet_number(i,j,k,n) =   &
                           Cell_microphys%droplet_number(i,j,k) 
                  else if (Model_microphys%stoch_cloud_type(i,j,k,n)  &
                                                             == 4) then
                    Model_microphys%stoch_conc_drop(i,j,k,n) =    &
                              Shallow_microphys%conc_drop(i,j,k)
                    Model_microphys%stoch_conc_ice(i,j,k,n)  =    &
                              Shallow_microphys%conc_ice (i,j,k)
                    Model_microphys%stoch_size_drop(i,j,k,n) =    &
                              Shallow_microphys%size_drop(i,j,k)
                    Model_microphys%stoch_size_ice(i,j,k,n)  =    &
                              Shallow_microphys%size_ice(i,j,k)
                    Model_microphys%stoch_cldamt(i,j,k,n) =  1.0
                    Model_microphys%stoch_droplet_number(i,j,k,n) =   &
                              Shallow_microphys%droplet_number(i,j,k) 
                  endif
                end do
              end do
            end do
          end do
        else  ! (do_donner_deep_clouds .or. do_uw_clouds)

!---------------------------------------------------------------------
!    if only strat cloud is active, define all column data to be that
!    coming from the strat_cloud stochasticization.
!---------------------------------------------------------------------
          Model_microphys%stoch_conc_drop =    &
                                  Lsc_microphys%stoch_conc_drop
          Model_microphys%stoch_conc_ice  =    &
                          Lsc_microphys%stoch_conc_ice
          Model_microphys%stoch_size_drop =    &
                                Lsc_microphys%stoch_size_drop
          Model_microphys%stoch_size_ice  =    & 
                                Lsc_microphys%stoch_size_ice
          Model_microphys%stoch_cldamt =       &
                                    Lsc_microphys%stoch_cldamt 
          Model_microphys%stoch_droplet_number =     &
                            Lsc_microphys%stoch_droplet_number 
        endif ! (do_donner_deep_clouds)

!---------------------------------------------------------------------
!    if stochastic clouds are not active, use Model_microphys to contain
!    the total cloud field obtained by summing the contribuutions from 
!    each active cloud scheme.
!---------------------------------------------------------------------
      else  ! (do_stochastic_clouds)

!----------------------------------------------------------------------
!    define the total cloud fraction.
!----------------------------------------------------------------------
        Model_microphys%cldamt = Lsc_microphys%cldamt
        if (Cldrad_control%do_donner_deep_clouds) then 
          Model_microphys%cldamt = Model_microphys%cldamt + &
                          Meso_microphys%cldamt + Cell_microphys%cldamt
        endif
        if (Cldrad_control%do_uw_clouds) then
          Model_microphys%cldamt = Model_microphys%cldamt + &
                                                Shallow_microphys%cldamt
        endif

!--------------------------------------------------------------------
!    define total grid box values of drop and ice cloud amounts, 
!    appropriately weighted by fractional area, and summed over all 
!    active cloud types. 
!--------------------------------------------------------------------
        Model_microphys%conc_drop = Lsc_microphys%cldamt*  &
                                              Lsc_microphys%conc_drop
        Model_microphys%conc_ice  = Lsc_microphys%cldamt*  &
                                              Lsc_microphys%conc_ice
         
        if (Cldrad_control%do_donner_deep_clouds) then 
          Model_microphys%conc_drop = Model_microphys%conc_drop +  &
                 Meso_microphys%cldamt*Meso_microphys%conc_drop +   &
                 Cell_microphys%cldamt*Cell_microphys%conc_drop
          Model_microphys%conc_ice = Model_microphys%conc_ice +  &
                 Meso_microphys%cldamt*Meso_microphys%conc_ice +   &
                 Cell_microphys%cldamt*Cell_microphys%conc_ice
        endif      
        if (Cldrad_control%do_uw_clouds) then
          Model_microphys%conc_drop = Model_microphys%conc_drop +  &
                   Shallow_microphys%cldamt*Shallow_microphys%conc_drop
          Model_microphys%conc_ice = Model_microphys%conc_ice +  &
                   Shallow_microphys%cldamt*Shallow_microphys%conc_ice
        endif

!----------------------------------------------------------------------
!    adjust the total cld fraction to be no larger than 1.0.
!----------------------------------------------------------------------
        Model_microphys%cldamt = MIN(Model_microphys%cldamt, 1.0)

      endif ! (do_stochastic_clouds)


!---------------------------------------------------------------------
!
!
!
!                   ISCCP SIMULATOR SECTION
!
!
!
!
!---------------------------------------------------------------------
 
!--------------------------------------------------------------------
!    if desired, call isccp_diag to generate isccp-relevant diagnostics
!    when running strat_clouds.
!---------------------------------------------------------------------

      if (do_isccp) then
        call obtain_cloud_tau_and_em (is, js, Model_microphys, &
                                    Atmos_input, &
                                    Tau_stoch, Lwem_stoch)
      endif  ! (do_isccp )

!--------------------------------------------------------------------
!    execute the following when stochastic clouds are activated. there 
!    are separate cloud fields for each sw and lw radiative band.
!--------------------------------------------------------------------
      if (Cldrad_control%do_stochastic_clouds) then

        if (do_isccp) then
                        
!----------------------------------------------------------------------
!    call isccp_diag_stochastic to map the stochastic clouds and cloud
!    properties to the isccp cloud categories.
!----------------------------------------------------------------------
          call isccp_diag_stochastic (is, js, Atmos_input, cosz, &
                                        Tau_stoch, LwEm_stoch,   &
                                        Model_microphys%stoch_cldamt, &
                                        Time_diag)
        endif

!--------------------------------------------------------------------
!    define the isccp properties when stochastic clouds are not active.
!    here there is only a single cloud profile for each gridbox.
!---------------------------------------------------------------------
      else  ! (do_stochastic_clouds)
        if ( do_isccp ) then 
          Tau(:,:,:) = (Lscrad_props%cldext(:,:,:,isccpSwBand)* &
                                  Atmos_input%deltaz(:,:,:)/1000.) / &
                                                     isccp_scale_factor
          LwEm(:,:,:) =  1. - exp( -1. * diffac *        &
                           (Lscrad_props%abscoeff(:,:,:,isccpLwBand)* &
                                    Atmos_input%deltaz(:,:,:)/1000.)/ &
                                                    isccp_scale_factor) 
          call isccp_diag (is, js, Cld_spec, Atmos_input, cosz, &
                                                  Tau, LwEm, Time_diag)
        endif
      endif ! (do_stochastic_clouds)

!---------------------------------------------------------------------
!
!
!
!      COMPUTE HIGH, MIDDLE, AND LOW CLOUD AMOUNTS
!
!
!---------------------------------------------------------------------
 
!---------------------------------------------------------------------
!    when stochastic clouds are active:
!---------------------------------------------------------------------

      if (Cldrad_control%do_stochastic_clouds) then

!---------------------------------------------------------------------
!    define the total cloud amount as the percentage of stochastic 
!    columns containing cloud at any model level. 
!---------------------------------------------------------------------
!       if (id_tot_cld_amt > 0  .or. id_cldfrac_tot > 0) then
        if (max(id_tot_cld_amt, id_cldfrac_tot) > 0) then
          cloud2n(:,:,:) =    &
                    SUM (Model_microphys%stoch_cldamt(:,:,:,:), dim = 3)
          cloud2n(:,:,:) = MIN (cloud2n(:,:,:), 1.0)
          tca2(:,:) = 100.0*SUM (cloud2n(:,:,:), dim = 3)/REAL (ncol)
          used = send_data (id_tot_cld_amt, tca2, Time_diag, is, js)
        endif 

!---------------------------------------------------------------------
!    define the high cloud region for each grid column. for each 
!    stochastic band, determine if any levels in the high cloud region 
!    contain cloud. if so define cloud2n to be 1.0 for that band; other-
!    wise it is 0.0. define high cloud percentage by summing over all 
!    bands.
!---------------------------------------------------------------------
        if (id_high_cld_amt > 0)  then            
          do n=1,ncol
            tmplmask4(:,:,:,n) = (Atmos_input%pflux(:,:,:) <= high_btm)
          end do

          cloud2n(:,:,:) =    &
               COUNT (Model_microphys%stoch_cldamt(:,:,:,:) > 0 .and. &
                                        tmplmask4(:,:,:,:), dim = 3)
          cloud2n(:,:,:) = MIN (cloud2n(:,:,:), 1.0)
          hml_ca(:,:,1) = 100.0*SUM (cloud2n(:,:,:), dim = 3)/  &
                                                            REAL (ncol)
          used = send_data (id_high_cld_amt, hml_ca(:,:,1),  &
                            Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!    define the middle cloud region for each grid column. for each 
!    stochastic band, determine if any levels in the middle cloud region
!    contain cloud. if so define cloud2n to be 1.0 for that band; other-
!    wise it is 0.0. define middle cloud percentage by summing over all 
!    bands.
!---------------------------------------------------------------------
        if (id_mid_cld_amt > 0) then    
          do n=1,ncol
            tmplmask4(:,:,:,n) =     &
                       (Atmos_input%pflux(:,:,:) <= mid_btm .and. &
                             Atmos_input%pflux(:,:,:) > high_btm) 
          end do
                                                
          cloud2n(:,:,:) =    &
               COUNT (Model_microphys%stoch_cldamt(:,:,:,:) > 0 .and. &
                                        tmplmask4(:,:,:,:), dim = 3)
          cloud2n(:,:,:) = MIN (cloud2n(:,:,:), 1.0)
          hml_ca(:,:,2) = 100.0*SUM (cloud2n(:,:,:), dim = 3)/  &
                                                            REAL (ncol)
          used = send_data (id_mid_cld_amt, hml_ca(:,:,2),   &
                            Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!    define the low cloud region for each grid column. for each 
!    stochastic band, determine if any levels in the lowe cloud region
!    contain cloud. if so define cloud2n to be 1.0 for that band; other-
!    wise it is 0.0. define low cloud percentage by summing over all 
!    bands.
!---------------------------------------------------------------------
        if (id_low_cld_amt > 0)  then            
          do n=1,ncol
            tmplmask4(:,:,:,n) = (Atmos_input%pflux(:,:,: ) > mid_btm)
          end do

          cloud2n(:,:,:) =    &
               COUNT (Model_microphys%stoch_cldamt(:,:,:,:) > 0 .and. &
                                       tmplmask4(:,:,:,:), dim = 3)
          cloud2n(:,:,:) = MIN (cloud2n(:,:,:), 1.0)
          hml_ca(:,:,3) = 100.0*SUM (cloud2n(:,:,:), dim = 3)/    &
                                                            REAL (ncol)
          used = send_data (id_low_cld_amt, hml_ca(:,:,3),  &
                            Time_diag, is, js)
        endif
          
!---------------------------------------------------------------------
!    define the combined low and mid cloud region for each grid column. 
!    for each stochastic band, determine if any levels in the low and
!    mid cloud region contain cloud. if so define cloud2n to be 1.0 for 
!    that band; otherwise it is 0.0. define lam cloud percentage by 
!    summing over all bands.
!---------------------------------------------------------------------
        if (id_lam_cld_amt > 0)  then            
          do n=1,ncol
            tmplmask4(:,:,:,n) = (Atmos_input%pflux(:,:,: ) > high_btm)
          end do

          cloud2n(:,:,:) =    &
               COUNT (Model_microphys%stoch_cldamt(:,:,:,:) > 0 .and. &
                                       tmplmask4(:,:,:,:), dim = 3)
          cloud2n(:,:,:) = MIN (cloud2n(:,:,:), 1.0)
          hml_ca(:,:,4) = 100.0*SUM (cloud2n(:,:,:), dim = 3)/    &
                                                            REAL (ncol)
          used = send_data (id_lam_cld_amt, hml_ca(:,:,4),  &
                            Time_diag, is, js)
        endif
          
!---------------------------------------------------------------------
!    when stochastic clouds are not active:
!---------------------------------------------------------------------
      else ! (do_stochastic_clouds)

!---------------------------------------------------------------------
!    define the total cloud amount. 
!---------------------------------------------------------------------
        if (id_tot_cld_amt > 0 ) then
          tca2 = 1.0  
          do k=1,kx        
            tca2(:,:) = tca2(:,:)*(1.0 - Cld_spec%camtsw(:,:,k))
          end do
          tca2 = 100.*(1. - tca2)
          used = send_data (id_tot_cld_amt, tca2, Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!    if high, mid or low cloud diagnostics are desired, call 
!    compute_isccp_clds to define the amount of each. 
!---------------------------------------------------------------------
        if (max(id_high_cld_amt, id_mid_cld_amt, &
                id_low_cld_amt,  id_lam_cld_amt) > 0) then
          call compute_isccp_clds (Atmos_input%pflux, Cld_spec%camtsw, &
                                   Cld_spec%camtsw_band, hml_ca)
   
          used = send_data (id_high_cld_amt, hml_ca(:,:,1), Time_diag, is, js)
          used = send_data (id_mid_cld_amt, hml_ca(:,:,2), Time_diag, is, js)
          used = send_data (id_low_cld_amt, hml_ca(:,:,3), Time_diag, is, js)
          used = send_data (id_lam_cld_amt, hml_ca(:,:,4), Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!
!
!
!                   3 DIMENSIONAL CLOUD AMOUNT
!
!
!
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    send the 3D cloud amount field to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_cld_amt, 100.*Cld_spec%camtsw,   &
                                      Time_diag, is, js, 1, rmask=mask)

!----------------------------------------------------------------------
!    send the unadjusted sum of the 3D cloud amounts from all active 
!    cloud schemes to diag_manager_mod.
!----------------------------------------------------------------------
        if (id_predicted_cld_amt > 0) then
          cloud (:,:,:) = Lsc_microphys%cldamt(:,:,:)
          if (Cldrad_control%do_donner_deep_clouds) then
            cloud(:,:,:) = cloud(:,:,:) +   &
                                      Cell_microphys%cldamt(:,:,:) + &
                                           Meso_microphys%cldamt(:,:,:)
          endif 
          if (Cldrad_control%do_uw_clouds) then
            cloud(:,:,:) = cloud(:,:,:) +   &
                                      Shallow_microphys%cldamt(:,:,:) 
          endif
          used = send_data (id_predicted_cld_amt, 100.*cloud,    &
                                     Time_diag, is, js, 1, rmask=mask)

        endif 

!----------------------------------------------------------------------
!    send the grid box total cloud-fraction-weighted sums of drop and 
!    ice cloud amounts to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_all_conc_ice, Model_microphys%conc_ice, &
                                                Time_diag, is, js, 1)

        used = send_data (id_all_conc_drop,   &
                            Model_microphys%conc_drop, Time_diag,   &
                                                           is, js, 1)
      endif  ! (do_stochastic_clouds)

!---------------------------------------------------------------------
!
!
!
!          SHORTWAVE RADIATIVE PROPERTIES OF STRATIFORM CLOUDS
!
!
!
!
!---------------------------------------------------------------------
 
!----------------------------------------------------------------------
!    the following diagnostics are meaningful only when strat_clouds
!    is active:
!----------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds) then

!----------------------------------------------------------------------
!    send the 3D large-scale cloud amount field to diag_manager_mod.
!----------------------------------------------------------------------
 
        used = send_data (id_lsc_cld_amt, 100.*Lsc_microphys%cldamt,   &
                      Time_diag, is, js, 1, rmask=mask)

!----------------------------------------------------------------------
!    send various large-scale cloud shortwave radiative property fields
!    to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_lsc_cld_ext_uv, Lscrad_props%cldext(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_ext_vis, Lscrad_props%cldext(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_ext_nir, Lscrad_props%cldext(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_sct_uv, Lscrad_props%cldsct(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_sct_vis, Lscrad_props%cldsct(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_sct_nir, Lscrad_props%cldsct(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_asymm_uv, Lscrad_props%cldasymm(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_asymm_vis, Lscrad_props%cldasymm(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_lsc_cld_asymm_nir, Lscrad_props%cldasymm(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
      endif ! (do_strat_clouds)
 
!---------------------------------------------------------------------
!
!
!
!             SHORTWAVE RADIATIVE PROPERTIES OF DONNER CLOUDS
!
!
!
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    the following diagnostics are meaningful only when 
!    donner_deep_clouds is active:
!----------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then

!----------------------------------------------------------------------
!    send the 3D cell-scale cloud amount field to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_cell_cld_amt,100.*Cell_microphys%cldamt,&
                          Time_diag, is, js, 1, rmask=mask)

!----------------------------------------------------------------------
!    send various cell-scale cloud shortwave radiative property fields
!    to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_cell_cld_ext_uv, Cellrad_props%cldext(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_ext_vis, Cellrad_props%cldext(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_ext_nir, Cellrad_props%cldext(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_sct_uv, Cellrad_props%cldsct(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_sct_vis, Cellrad_props%cldsct(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_sct_nir, Cellrad_props%cldsct(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_asymm_uv, Cellrad_props%cldasymm(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_asymm_vis, Cellrad_props%cldasymm(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_cell_cld_asymm_nir, Cellrad_props%cldasymm(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask )

!----------------------------------------------------------------------
!    send the 3D meso-scale cloud amount field to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_meso_cld_amt,100.*Meso_microphys%cldamt,&
                          Time_diag, is, js, 1, rmask=mask)

!----------------------------------------------------------------------
!    send various meso-scale cloud shortwave radiative property fields
!    to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_meso_cld_ext_uv, Mesorad_props%cldext(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_ext_vis, Mesorad_props%cldext(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_ext_nir, Mesorad_props%cldext(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_sct_uv, Mesorad_props%cldsct(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_sct_vis, Mesorad_props%cldsct(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_sct_nir, Mesorad_props%cldsct(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_asymm_uv, Mesorad_props%cldasymm(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_asymm_vis, Mesorad_props%cldasymm(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_meso_cld_asymm_nir, Mesorad_props%cldasymm(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
      endif ! (do_donner_deep_clouds)


!---------------------------------------------------------------------
!
!
!
!             SHORTWAVE RADIATIVE PROPERTIES OF UW SHALLOW CLOUDS
!
!
!
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    the following diagnostics are meaningful only when 
!    uw shallow convection is active:
!----------------------------------------------------------------------
      if (Cldrad_control%do_uw_clouds) then

!----------------------------------------------------------------------
!    send the 3D cell-scale cloud amount field to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_shallow_cld_amt,   &
                               100.*Shallow_microphys%cldamt, &
                                   Time_diag, is, js, 1, rmask=mask)

!----------------------------------------------------------------------
!    send various uw shallow cloud shortwave radiative property fields
!    to diag_manager_mod.
!----------------------------------------------------------------------
        used = send_data (id_shallow_cld_ext_uv, Shallowrad_props%cldext(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_ext_vis, Shallowrad_props%cldext(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_ext_nir, Shallowrad_props%cldext(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_sct_uv, Shallowrad_props%cldsct(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_sct_vis, Shallowrad_props%cldsct(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_sct_nir, Shallowrad_props%cldsct(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_asymm_uv, Shallowrad_props%cldasymm(:,:,:,iuv), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_asymm_vis, Shallowrad_props%cldasymm(:,:,:,ivis), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_shallow_cld_asymm_nir, Shallowrad_props%cldasymm(:,:,:,inir), &
                          Time_diag, is, js, 1, rmask=mask )

      endif ! (do_uw_clouds)

!---------------------------------------------------------------------
!
!
!
!             LONGWAVE RADIATIVE PROPERTIES OF CLOUDS
!
!
!
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is active, define 
!    a total cloud field emissivity that is the weighted average
!    of the random and max overlap emissivities, over the 990-1070 cm-1 
!    band (band 5 of 7).
!---------------------------------------------------------------------
      if (Cldrad_control%do_lw_micro) then
        if (id_em_cld_10u > 0) then
          cloud(:,:,:) =    &
             (Cld_spec%crndlw(:,:,:)*Cldrad_props%emrndlw(:,:,:,5,1) + &
              Cld_spec%cmxolw(:,:,:)*Cldrad_props%emmxolw(:,:,:,5,1))/ &
             (Cld_spec%crndlw(:,:,:) + Cld_spec%cmxolw(:,:,:) + 1.0E-10)
          used = send_data (id_em_cld_10u, cloud, Time_diag,     &
                            is, js, 1, rmask=mask)
        endif

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is not active, 
!    define a total cloud field emissivity that is the weighted average
!    of the random and max overlap emissivities, over 1 band 
!    (0-2200 cm-1).
!---------------------------------------------------------------------
      else
        if (id_em_cld_lw > 0   ) then
          cloud(:,:,:) =      &
            (Cld_spec%crndlw(:,:,:)*Cldrad_props%emrndlw(:,:,:,1,1) +  &
             Cld_spec%cmxolw(:,:,:)*Cldrad_props%emmxolw(:,:,:,1,1))/ &
            (Cld_spec%crndlw(:,:,:) + Cld_spec%cmxolw(:,:,:) + 1.0E-10)
          used = send_data (id_em_cld_lw, cloud, Time_diag,    &
                            is, js, 1, rmask=mask)
        endif
      endif

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is active, define 
!    a large scale cloud absorption coefficient over the 990-1070 cm-1 
!    band (band 5 of 7).
!---------------------------------------------------------------------
      if (Cldrad_control%do_lw_micro) then
        used = send_data (id_abs_lsc_cld_10u,    &
                          Lscrad_props%abscoeff(:,:,:,5), Time_diag, &
                          is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is not active, 
!    define the large scale cloud absorption coefficient over 1 band 
!    (0-2200 cm-1).
!---------------------------------------------------------------------
      else
        used = send_data (id_abs_lsc_cld_lw,      &
                          Lscrad_props%abscoeff(:,:,:,1), Time_diag, &
                          is, js, 1, rmask=mask)
      endif

      if (Cldrad_control%do_donner_deep_clouds) then
!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is active, define 
!    the cell scale cloud absorption coefficient over the 990-1070 cm-1 
!    band (band 5 of 7).
!---------------------------------------------------------------------
        if (Cldrad_control%do_lw_micro) then
          used = send_data (id_abs_cell_cld_10u,     &
                            Cellrad_props%abscoeff(:,:,:,5), Time_diag,&
                            is, js, 1, rmask=mask)
        else

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is not active, 
!    define the cell scale cloud absorption coefficient over 1 band 
!    (0-2200 cm-1).
!---------------------------------------------------------------------
          used = send_data (id_abs_cell_cld_lw,     &
                            Cellrad_props%abscoeff(:,:,:,1), Time_diag,&
                            is, js, 1, rmask=mask)
        endif

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is active, define 
!    a meso-scale cloud absorption coefficient over the 990-1070 cm-1 
!    band (band 5 of 7).
!---------------------------------------------------------------------
        if (Cldrad_control%do_lw_micro) then
          used = send_data (id_abs_meso_cld_10u,    &
                            Mesorad_props%abscoeff(:,:,:,5), Time_diag,&
                            is, js, 1, rmask=mask)
        else
 
!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is not active, 
!    define the meso-scale cloud absorption coefficient over 1 band 
!    (0-2200 cm-1).
!---------------------------------------------------------------------
          used = send_data (id_abs_meso_cld_lw,    &
                            Mesorad_props%abscoeff(:,:,:,1), Time_diag,&
                            is, js, 1, rmask=mask)
        endif

      endif

      if (Cldrad_control%do_uw_clouds) then
!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is active, define 
!    the cell scale cloud absorption coefficient over the 990-1070 cm-1 
!    band (band 5 of 7).
!---------------------------------------------------------------------
        if (Cldrad_control%do_lw_micro) then
          used = send_data (id_abs_shallow_cld_10u,     &
                            Shallowrad_props%abscoeff(:,:,:,5), Time_diag,&
                            is, js, 1, rmask=mask)
        else
 
!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is not active, 
!    define the cell scale cloud absorption coefficient over 1 band 
!    (0-2200 cm-1).
!---------------------------------------------------------------------
          used = send_data (id_abs_shallow_cld_lw,     &
                            Shallowrad_props%abscoeff(:,:,:,1), Time_diag,&
                            is, js, 1, rmask=mask)
        endif
      endif

!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is active, define 
!    the total-cloud absorption coefficient over the 990-1070 cm-1 
!    band (band 5 of 7).
!---------------------------------------------------------------------
      if (Cldrad_control%do_lw_micro) then
        used = send_data (id_abs_cld_10u,      &
                          Cldrad_props%abscoeff(:,:,:,5,1), Time_diag,&
                          is, js, 1, rmask=mask)
!---------------------------------------------------------------------
!    if a multi-band lw cloud emissivity formulation is not active, 
!    define the total-cloud absorption coefficient over 1 band 
!    (0-2200 cm-1).
!---------------------------------------------------------------------
      else
        used = send_data (id_abs_cld_lw,    &
                          Cldrad_props%abscoeff(:,:,:,1,1), Time_diag, &
                          is, js, 1, rmask=mask)
      endif

!---------------------------------------------------------------------
!
!
!
!             SHORTWAVE RADIATIVE PROPERTIES OF ALL CLOUDS COMBINED
!
!
!
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!    define total-cloud diagnostics that are associated with the micro-
!    physically-based cloud shortwave radiative properties.
!---------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro) then
        used = send_data (id_ext_cld_uv, Cldrad_props%cldext(:,:,:,iuv,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_sct_cld_uv, Cldrad_props%cldsct(:,:,:,iuv,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_asymm_cld_uv, 100.0*Cldrad_props%cldasymm(:,:,:,iuv,1), &
                           Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_ext_cld_vis, Cldrad_props%cldext(:,:,:,ivis,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_sct_cld_vis, Cldrad_props%cldsct(:,:,:,ivis,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_asymm_cld_vis, 100.0*Cldrad_props%cldasymm(:,:,:,ivis,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_ext_cld_nir, Cldrad_props%cldext(:,:,:,inir,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_sct_cld_nir, Cldrad_props%cldsct(:,:,:,inir,1), &
                          Time_diag, is, js, 1, rmask=mask)
        used = send_data (id_asymm_cld_nir, 100.0*Cldrad_props%cldasymm(:,:,:,inir,1), &
                          Time_diag, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    define total-cloud diagnostics that are associated with the bulk 
!    cloud shortwave radiative properties.
!---------------------------------------------------------------------
      else

!---------------------------------------------------------------------
!    define the reflected ultra-violet.
!---------------------------------------------------------------------

        used = send_data (id_alb_uv_cld, Cldrad_props%cvisrfsw(:,:,:), &
                          Time_diag, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    define the reflected infra-red. 
!---------------------------------------------------------------------

        used = send_data (id_alb_nir_cld, Cldrad_props%cirrfsw(:,:,:), &
                          Time_diag, is, js, 1, rmask=mask)

!---------------------------------------------------------------------
!    define the absorbed  ultra-violet (not implemented).
!---------------------------------------------------------------------
!       if ( id_abs_uv_cld > 0 ) then
!         cloud = 0.0
!         used = send_data (id_abs_uv_cld, cloud, Time_diag,    &
!                           is, js, 1, rmask=mask)
!       endif

!---------------------------------------------------------------------
!    define the absorbed  infra-red.
!---------------------------------------------------------------------

        used = send_data (id_abs_nir_cld, Cldrad_props%cirabsw(:,:,:), &
                          Time_diag, is, js, 1, rmask=mask)
      endif 

!---------------------------------------------------------------------
!
!
!             STRATIFORM PHYSICAL PROPERTIES
!
!
!
!
!---------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds) then

!---------------------------------------------------------------------
!    ice cloud properties: fractional area, particle size, 
!    cloud amount and path
!---------------------------------------------------------------------
        if (max(id_strat_area_ice, id_strat_conc_ice,   &
                id_strat_size_ice, id_lsc_iwp) > 0) then
          tmplmask = Lsc_microphys%conc_ice > 0.0
          if (id_strat_area_ice > 0) then
            cloud   = 0.
            where (tmplmask)                     
              cloud   = Lsc_microphys%cldamt
            endwhere      
            used = send_data (id_strat_area_ice, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_strat_size_ice,   &
                            Lsc_microphys%size_ice, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_strat_conc_ice,    &
                            Lsc_microphys%conc_ice, Time_diag,   &
                            is, js, 1, mask=tmplmask)

          if (id_lsc_iwp > 0) then
            cloud2d(:,:) = SUM (Lsc_microphys%conc_ice(:,:,:)*  &
                              pmass2(:,:,:), dim = 3)
            tmplmask2 = cloud2d(:,:) > 0.0
            used = send_data (id_lsc_iwp, cloud2d, Time_diag,   &
                              is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_strat_conc_ice > 0) then
          cloud = Lsc_microphys%conc_ice*Lsc_microphys%cldamt
          used = send_data (id_gb_strat_conc_ice, cloud, &
                            Time_diag, is, js, 1)                
        endif

        if (id_gb_lsc_iwp > 0) then
          cloud2d(:,:) = SUM (Lsc_microphys%conc_ice(:,:,:)*  &
                     Lsc_microphys%cldamt(:,:,:)*pmass2(:,:,:), dim = 3)
          used = send_data (id_gb_lsc_iwp, cloud2d, Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!    water cloud properties:  fractional area, particle size, 
!    cloud amount, path and droplet number
!---------------------------------------------------------------------
        if (max(id_strat_area_liq,       id_strat_size_drop,  &
                id_ra_strat_size_drop,   id_strat_conc_drop,  &
                id_strat_droplet_number, id_lsc_lwp) > 0) then
          tmplmask = Lsc_microphys%conc_drop > 0.0

          if (id_strat_area_liq > 0) then
            cloud   = 0.
            where (tmplmask)                      
              cloud   = Lsc_microphys%cldamt
            endwhere      
            used = send_data (id_strat_area_liq, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_strat_size_drop,   &
                            Lsc_microphys%size_drop, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          if (id_ra_strat_size_drop > 0) then
            cloud = MAX (  &
                MIN(Lsc_microphys%size_drop, mx_drp_diam), mn_drp_diam)
            used = send_data (id_ra_strat_size_drop, cloud, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif

          used = send_data (id_strat_conc_drop,   &
                            Lsc_microphys%conc_drop, Time_diag,   &
                            is, js, 1, mask=tmplmask)

          if (id_strat_droplet_number > 0) then
            if (Cldrad_control%do_liq_num) then
              cloud = 0.0
              where (Lsc_microphys%cldamt > 0.0)
                cloud = Lsc_microphys%droplet_number/   &
                                                   Lsc_microphys%cldamt
              end where
            else
              cloud = 0.0
              where (Lsc_microphys%cldamt > 0.0)
                cloud = Lsc_microphys%droplet_number
              end where
            endif
            used = send_data (id_strat_droplet_number, cloud, &
                              Time_diag, is, js, 1, mask=tmplmask)
          endif

          if (id_lsc_lwp > 0) then
            cloud2d(:,:) = SUM (Lsc_microphys%conc_drop(:,:,:)*  &
                                pmass2(:,:,:), dim = 3)
            tmplmask2 = cloud2d(:,:) > 0.0
            used = send_data (id_lsc_lwp, cloud2d, &
                              Time_diag, is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_strat_conc_drop > 0) then
          cloud = Lsc_microphys%conc_drop*Lsc_microphys%cldamt
          used = send_data (id_gb_strat_conc_drop, cloud, &
                            Time_diag, is, js, 1)                   
        endif

        if (id_gb_lsc_lwp > 0) then
          cloud2d(:,:) = SUM (Lsc_microphys%conc_drop(:,:,:)*  &
                     Lsc_microphys%cldamt(:,:,:)*pmass2(:,:,:), dim = 3)
          used = send_data (id_gb_lsc_lwp, cloud2d, Time_diag, is, js) 
        endif

      endif ! (do_strat_clouds)

!---------------------------------------------------------------------
!
!
!             DONNER MESO PHYSICAL PROPERTIES
!
!
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then

!--------------------------------------------------------------------
!    donner meso ice cloud properties: fractional area, size, 
!    cloud amount and path
!--------------------------------------------------------------------
        if (max(id_meso_area_ice, id_meso_size_ice, &
                id_meso_conc_ice, id_meso_iwp) > 0) then
          tmplmask = Meso_microphys%conc_ice > 0.0

          if (id_meso_area_ice > 0) then
            cloud = 0.
            where (tmplmask)                    
              cloud = Meso_microphys%cldamt
            endwhere      
            used = send_data (id_meso_area_ice, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_meso_size_ice,   &
                            Meso_microphys%size_ice, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_meso_conc_ice,   &
                            Meso_microphys%conc_ice, Time_diag,    &
                            is, js, 1, mask=tmplmask)
   
          if (id_meso_iwp > 0) then
            cloud2d(:,:) =   &
             SUM (Meso_microphys%conc_ice(:,:,:)*pmass(:,:,:), dim = 3 )
            tmplmask2 = cloud2d > 0.0
            used = send_data (id_meso_iwp, cloud2d, Time_diag,   &
                              is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_meso_conc_ice > 0) then
          cloud = Meso_microphys%conc_ice*Meso_microphys%cldamt 
          used = send_data (id_gb_meso_conc_ice, cloud, &
                            Time_diag, is, js, 1)                  
        endif

        if (id_gb_meso_iwp > 0) then
          cloud2d(:,:) =   &
             SUM (Meso_microphys%conc_ice(:,:,:)*  &
                  Meso_microphys%cldamt(:,:,:)*pmass(:,:,:), dim = 3 )
          used = send_data (id_gb_meso_iwp, cloud2d, Time_diag, is, js)
        endif

!--------------------------------------------------------------------
!    donner meso liquid cloud properties: fractional area, size, 
!    cloud amount, path and droplet number. note that the current
!    donner parameterization does not allow mesoscale liquid.
!--------------------------------------------------------------------
        if (max(id_meso_area_liq,       id_meso_size_drop,  &
                id_ra_meso_size_drop,   id_meso_conc_drop, &
                id_meso_droplet_number, id_meso_lwp) > 0) then
          tmplmask = Meso_microphys%conc_drop > 0.0

          if (id_meso_area_liq > 0) then
            cloud = 0.
            where (tmplmask)                      
              cloud = Meso_microphys%cldamt
            endwhere      
            used = send_data (id_Meso_area_liq, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_meso_size_drop,     &
                            Meso_microphys%size_drop, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          if (id_ra_meso_size_drop > 0) then
            cloud = MAX   &
               (MIN(Meso_microphys%size_drop, mx_drp_diam), mn_drp_diam)
            used = send_data (id_ra_meso_size_drop, cloud, Time_diag,  &
                              is, js, 1, mask=tmplmask)
          endif

          used = send_data (id_meso_conc_drop,   &
                            Meso_microphys%conc_drop, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_meso_droplet_number,   &
                            Meso_microphys%droplet_number, &
                            Time_diag, is, js, 1, mask=tmplmask)

          if (id_meso_lwp > 0) then
            cloud2d(:,:) = SUM (Meso_microphys%conc_drop(:,:,:)*   &
                                pmass(:,:,:), dim = 3 )
            tmplmask2 = cloud2d > 0.0
            used = send_data (id_meso_lwp, cloud2d, Time_diag,   &
                              is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_meso_conc_drop > 0) then
          cloud = Meso_microphys%conc_drop*Meso_microphys%cldamt 
          used = send_data (id_gb_meso_conc_drop, cloud, &
                            Time_diag, is, js, 1)                  
        endif

        if (id_gb_meso_lwp > 0) then
          cloud2d(:,:) = SUM (Meso_microphys%conc_drop(:,:,:)*   &
                    Meso_microphys%cldamt(:,:,:)*pmass(:,:,:), dim = 3 )
          used = send_data (id_gb_meso_lwp, cloud2d, Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!
!
!             DONNER CELL PHYSICAL PROPERTIES
!
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    donner cell ice cloud properties: fractional area, size, 
!    cloud amount and path. 
!--------------------------------------------------------------------
        if (max(id_cell_area_ice, id_cell_size_ice,  &
                id_cell_conc_ice, id_cell_iwp) > 0) then
          tmplmask = Cell_microphys%conc_ice > 0.0

          if (id_cell_area_ice > 0) then
            cloud = 0.
            where (tmplmask)                           
              cloud = Cell_microphys%cldamt
            endwhere      
            used = send_data (id_cell_area_ice, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_cell_size_ice,    &
                            Cell_microphys%size_ice, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_cell_conc_ice,   &
                            Cell_microphys%conc_ice, Time_diag,   &
                            is, js, 1, mask=tmplmask)

          if (id_cell_iwp > 0) then
            cloud2d(:,:) = SUM (Cell_microphys%conc_ice(:,:,:)*   &
                                pmass(:,:,:), dim = 3 )
            tmplmask2 = cloud2d  > 0.0
            used = send_data (id_cell_iwp, cloud2d, &
                              Time_diag, is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_cell_conc_ice > 0) then
          cloud = Cell_microphys%conc_ice*Cell_microphys%cldamt 
          used = send_data (id_gb_cell_conc_ice, cloud, &
                            Time_diag, is, js, 1)                
        endif

        if (id_gb_cell_iwp > 0) then
          cloud2d(:,:) = SUM (Cell_microphys%conc_ice(:,:,:)*   &
                   Cell_microphys%cldamt(:,:,:)*pmass(:,:,:), dim = 3 )
          used = send_data (id_gb_cell_iwp, cloud2d, &
                            Time_diag, is, js)                
        endif

!--------------------------------------------------------------------
!    donner cell liquid cloud properties: fractional area, size, 
!    cloud amount, path and droplet number.
!--------------------------------------------------------------------
        if (max(id_cell_area_liq,       id_cell_size_drop, &
                id_ra_cell_size_drop,   id_cell_conc_drop, &
                id_cell_droplet_number, id_cell_lwp) > 0) then
          tmplmask = Cell_microphys%conc_drop > 0.0

          if (id_cell_area_liq > 0) then
            cloud = 0.
            where (tmplmask)                       
              cloud = Cell_microphys%cldamt
            endwhere      
            used = send_data (id_cell_area_liq, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_cell_size_drop,    &
                            Cell_microphys%size_drop, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          if (id_ra_cell_size_drop > 0) then
            cloud = MAX   &
               (MIN (Cell_microphys%size_drop,mx_drp_diam), mn_drp_diam)
            used = send_data (id_ra_cell_size_drop, cloud, Time_diag,  &
                              is, js, 1, mask=tmplmask)
          endif

          used = send_data (id_cell_conc_drop,    &
                            Cell_microphys%conc_drop,Time_diag,   &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_cell_droplet_number,    &
                            Cell_microphys%droplet_number, &  
                            Time_diag, is, js, 1, mask=tmplmask)

          if (id_cell_lwp > 0) then
            cloud2d = SUM (Cell_microphys%conc_drop(:,:,:)*  &
                                                pmass(:,:,:), dim = 3 )
            tmplmask2 = cloud2d  > 0.0
            used = send_data (id_cell_lwp, cloud2d, &
                              Time_diag, is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_cell_conc_drop > 0) then
          cloud = Cell_microphys%conc_drop*Cell_microphys%cldamt 
          used = send_data (id_gb_cell_conc_drop, cloud, &
                            Time_diag, is, js, 1)                
        endif

        if (id_gb_cell_lwp > 0) then
          cloud2d = SUM (Cell_microphys%conc_drop(:,:,:)*  &
                  Cell_microphys%cldamt(:,:,:)*pmass(:,:,:), dim = 3 )
          used = send_data (id_gb_cell_lwp, cloud2d, &
                            Time_diag, is, js)                
        endif
      endif ! (do_donner_deep_clouds)

!---------------------------------------------------------------------
!
!
!             UW SHALLOW PHYSICAL PROPERTIES
!
!
!---------------------------------------------------------------------

      if (Cldrad_control%do_uw_clouds) then

!--------------------------------------------------------------------
!    uw shallow ice cloud properties: fractional area, size, 
!    cloud amount and path 
!--------------------------------------------------------------------
        if (max(id_shallow_area_ice, id_shallow_size_ice, &
                id_shallow_conc_ice, id_shallow_iwp) > 0) then
          tmplmask = Shallow_microphys%conc_ice > 0.0

          if (id_shallow_area_ice > 0) then
            cloud = 0.
            where (tmplmask)                           
              cloud = Shallow_microphys%cldamt
            endwhere      
            used = send_data (id_shallow_area_ice, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_shallow_size_ice,    &
                            Shallow_microphys%size_ice, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_shallow_conc_ice,   &
                            Shallow_microphys%conc_ice, Time_diag,   &
                            is, js, 1, mask=tmplmask)

          if (id_shallow_iwp > 0) then
            cloud2d(:,:) = SUM (Shallow_microphys%conc_ice(:,:,:)*   &
                                pmass(:,:,:), dim = 3 )
            tmplmask2 = cloud2d  > 0.0
            used = send_data (id_shallow_iwp, cloud2d, &
                              Time_diag, is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_shallow_conc_ice > 0) then
          cloud = Shallow_microphys%conc_ice*Shallow_microphys%cldamt 
          used = send_data (id_gb_shallow_conc_ice, cloud, &
                            Time_diag, is, js, 1)                
        endif

        if (id_gb_shallow_iwp > 0) then
          cloud2d(:,:) = SUM (Shallow_microphys%conc_ice(:,:,:)*   &
                 Shallow_microphys%cldamt(:,:,:)*pmass(:,:,:), dim = 3 )
          used = send_data (id_gb_shallow_iwp, cloud2d, &
                            Time_diag, is, js)                
        endif

!--------------------------------------------------------------------
!    uw shallow liquid cloud properties: fractional area, size, 
!    cloud amount, path and droplet number 
!--------------------------------------------------------------------
        if (max(id_shallow_area_liq,       id_shallow_size_drop, &
                id_ra_shallow_size_drop,   id_shallow_conc_drop, &
                id_shallow_droplet_number, id_shallow_lwp) > 0) then
          tmplmask = Shallow_microphys%conc_drop > 0.0

          if (id_shallow_area_liq > 0) then
            cloud = 0.
            where (tmplmask)                       
              cloud = Shallow_microphys%cldamt
            endwhere      
            used = send_data (id_shallow_area_liq, cloud, Time_diag,  &
                              is, js, 1, rmask=mask)
          endif

          used = send_data (id_shallow_size_drop,    &
                            Shallow_microphys%size_drop, Time_diag,  &
                            is, js, 1, mask=tmplmask)

          if (id_ra_shallow_size_drop > 0) then
            cloud = MAX(              &
                      MIN(Shallow_microphys%size_drop,mx_drp_diam), &
                                                            mn_drp_diam)
            used = send_data (id_ra_shallow_size_drop, cloud,  &
                              Time_diag, is, js, 1, mask=tmplmask)
          endif

          used = send_data (id_shallow_conc_drop,    &
                            Shallow_microphys%conc_drop,Time_diag,   &
                            is, js, 1, mask=tmplmask)

          used = send_data (id_shallow_droplet_number,    &
                            Shallow_microphys%droplet_number, &  
                            Time_diag, is, js, 1, mask=tmplmask)

          if (id_shallow_lwp > 0) then
            cloud2d = SUM (Shallow_microphys%conc_drop(:,:,:)*  &
                                               pmass(:,:,:), dim = 3 )
            tmplmask2 = cloud2d  > 0.0
            used = send_data (id_shallow_lwp, cloud2d, &
                              Time_diag, is, js, mask=tmplmask2)
          endif
        endif

        if (id_gb_shallow_conc_drop > 0) then
          cloud = Shallow_microphys%conc_drop*Shallow_microphys%cldamt 
          used = send_data (id_gb_shallow_conc_drop, cloud, &
                            Time_diag, is, js, 1)                
        endif

        if (id_gb_shallow_lwp > 0) then
          cloud2d = SUM (Shallow_microphys%conc_drop(:,:,:)*  &
                 Shallow_microphys%cldamt(:,:,:)*pmass(:,:,:), dim = 3 )
          used = send_data (id_gb_shallow_lwp, cloud2d, &
                            Time_diag, is, js)                
        endif
      endif ! (do_uw_clouds)

!---------------------------------------------------------------------
!
!
!             STOCHASTIC CLOUD PROPERTIES
!
!
!---------------------------------------------------------------------

      if (Cldrad_control%do_stochastic_clouds) then

!--------------------------------------------------------------------
!
!
!                     "_ONLY_LSC" DIAGNOSTICS
!
!
!--------------------------------------------------------------------
!    these "_only_lsc" diagnostics allow one to assess the effect of
!    treating the non-lsc clouds stochastically. the difference between
!    the "_only_lsc" variables and the corresponding "_ave" variables
!    reflect the changes resulting from treating the non-lsc cloud
!    types stochastically. the cloud properties actually seen by the
!    model's radiation package are always contained in the "_ave" 
!    diagnostics.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    grid-box-mean (averaged over all stochastic bands) large-scale 
!    cloud fraction.
!--------------------------------------------------------------------
        if (id_cldfrac_only_lsc > 0) then
          cloud(:,:,:) =   &
              SUM (Lsc_microphys%stoch_cldamt(:,:,:,:), dim = 4)/ncol
          used = send_data (id_cldfrac_only_lsc, cloud, Time_diag, &
                            is, js, 1, rmask=mask)
        endif
  
!--------------------------------------------------------------------
!    grid-box-mean (averaged over all stochastic bands) large-scale 
!    cloud ice amount and icewater path.
!--------------------------------------------------------------------
        if (id_ice_conc_only_lsc > 0 .or. id_iwp_only_lsc > 0)  then   
          cloud(:,:,:) =    &
             SUM (Lsc_microphys%stoch_conc_ice(:,:,:,:), dim = 4)/ncol 
          used = send_data (id_ice_conc_only_lsc, cloud, Time_diag, &
                            is, js, 1, rmask=mask)
          if (id_iwp_only_lsc > 0)  then       
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_iwp_only_lsc, cloud2d, Time_diag, &
                              is, js)
          endif
        endif

!--------------------------------------------------------------------
!    in-cloud (averaged over only cloudy stochastic bands) large-scale 
!    ice water content, ice water path, ice particle size, and fraction
!    of stochastic columns containing ice cloud.
!--------------------------------------------------------------------
        if (max(id_ic_iwp_only_lsc,   id_ic_ice_conc_only_lsc, &  
                id_ice_size_only_lsc, id_ice_col_only_lsc) > 0) then
          tmplmask4(:,:,:,:) =    &
                          Lsc_microphys%stoch_conc_ice(:,:,:,:) > 0.0 
          cloud2(:,:,:) = COUNT (tmplmask4(:,:,:,:), dim = 4)
          tmplmask = cloud2 > 0.0
          cloud(:,:,:) = 0.0
          where (tmplmask)
            cloud(:,:,:) =    &
               SUM (Lsc_microphys%stoch_conc_ice(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
          end where

          used = send_data (id_ic_ice_conc_only_lsc, cloud,   &
                            Time_diag, is, js, 1, mask=tmplmask)

          if (id_ic_iwp_only_lsc > 0 ) then      
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            tmplmask2 = SUM (cloud2(:,:,:), dim=3) > 0.0
            used = send_data (id_ic_iwp_only_lsc, cloud2d, Time_diag, &
                              is, js, mask=tmplmask2)
          endif

          if (id_ice_size_only_lsc > 0) then
            cloud(:,:,:) = 0.0
            where (cloud2 > 0)
              cloud(:,:,:) =    &
                SUM (Lsc_microphys%stoch_size_ice(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where

            used = send_data (id_ice_size_only_lsc, cloud, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif

          if (id_ice_col_only_lsc > 0 ) then      
            cloud2 = cloud2/float(ncol)
            used = send_data (id_ice_col_only_lsc, cloud2, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif
        endif 

!--------------------------------------------------------------------
!    grid-box-mean (averaged over all stochastic bands)large-scale 
!    cloud liquid amount and water path.
!--------------------------------------------------------------------
        if (max(id_drop_conc_only_lsc, id_lwp_only_lsc) > 0 ) then    
          cloud(:,:,:) =   &
             SUM (Lsc_microphys%stoch_conc_drop(:,:,:,:), dim = 4)/ncol

          used = send_data (id_drop_conc_only_lsc, cloud, Time_diag, &
                            is, js, 1, rmask=mask)

          if (id_lwp_only_lsc > 0 ) then    
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_lwp_only_lsc, cloud2d, Time_diag, &
                              is, js)
          endif
        endif 

!--------------------------------------------------------------------
!    in-cloud (averaged only over cloudy stochastic columns) large-scale
!    cloud liq water content, liquid water path, droplet size, droplet
!    number, and fraction of stochastic columns containing cloud liquid.
!--------------------------------------------------------------------
        if (max(id_ic_drop_conc_only_lsc, id_ic_lwp_only_lsc, &
                id_liq_col_only_lsc,      id_drop_size_only_lsc, &
                id_ra_drop_size_only_lsc, id_droplet_number_only_lsc) > 0) then
          tmplmask4(:,:,:,:) =    &
                          Lsc_microphys%stoch_conc_drop(:,:,:,:) > 0.0 
          cloud2(:,:,:) = COUNT (tmplmask4(:,:,:,:), dim = 4)
          tmplmask = cloud2 > 0.0
          cloud(:,:,:) = 0.0
          where (tmplmask)   
            cloud(:,:,:) =    &
                SUM (Lsc_microphys%stoch_conc_drop(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
          end where

          used = send_data (id_ic_drop_conc_only_lsc, cloud,  &
                            Time_diag, is, js, 1, mask=tmplmask)

          if (id_ic_lwp_only_lsc > 0 ) then  
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            tmplmask2 = SUM (cloud2(:,:,:), dim=3) > 0.0
            used = send_data (id_ic_lwp_only_lsc, cloud2d, Time_diag, &
                              is, js, mask=tmplmask2)
          endif

          if (id_drop_size_only_lsc > 0) then
            cloud(:,:,:) = 0.0
            where (tmplmask)   
              cloud(:,:,:) =    &
                 SUM (Lsc_microphys%stoch_size_drop(:,:,:,:),   &
                   mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_drop_size_only_lsc, cloud, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif

          if (id_ra_drop_size_only_lsc > 0) then
            cloud(:,:,:) = 0.0
            where (tmplmask)   
              cloud(:,:,:) = SUM (MIN(MAX(   &
                 Lsc_microphys%stoch_size_drop(:,:,:,:), mn_drp_diam), &
                      mx_drp_diam), mask = tmplmask4, dim = 4)/ &
                                              (cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_ra_drop_size_only_lsc, cloud,   &
                              Time_diag, is, js, 1, mask=tmplmask)
          endif

          if (id_droplet_number_only_lsc > 0) then
            cloud(:,:,:) = 0.0
            where (tmplmask)   
              cloud(:,:,:) =    &
                 SUM (Lsc_microphys%stoch_droplet_number(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_droplet_number_only_lsc, cloud,   &
                              Time_diag, is, js, 1, mask=tmplmask)
          endif

          if (id_liq_col_only_lsc > 0 ) then  
            cloud2 = cloud2/float(ncol)
            used = send_data (id_liq_col_only_lsc, cloud2, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif
        endif 

!--------------------------------------------------------------------
!
!
!                     "_AVE" DIAGNOSTICS
!
!
!--------------------------------------------------------------------
!    these diagnostics are for the cloud properties actually seen by 
!    the model's radiation code, which includes contributions from all 
!    active cloud types, stochastically determined.
!--------------------------------------------------------------------

!------------------------------------------------------------------
!    total projected cloud fraction. note that this has been previously
!    calculated as tca2 and output via id_tot_cld_amt.
!------------------------------------------------------------------
        if (id_cldfrac_tot > 0 ) &
          used = send_data (id_cldfrac_tot, 0.01*tca2,   &
                          Time_diag, is, js)

!--------------------------------------------------------------------
!    grid-box-mean cloud fraction in each layer, averaged across all
!    stochastic columns.
!--------------------------------------------------------------------
        if (id_cldfrac_ave > 0) then
          cloud(:,:,:) =   &
              SUM (Model_microphys%stoch_cldamt(:,:,:,:), dim = 4)/ncol 
          used = send_data (id_cldfrac_ave, cloud, Time_diag, &
                            is, js, 1, rmask=mask)
        endif
  
!--------------------------------------------------------------------
!    grid-box-mean (averaged over all stochastic bands) ice cloud  
!    amount and icewater path.
!--------------------------------------------------------------------
        if (max(id_ice_conc_ave, id_iwp_ave) > 0 ) then 
          cloud(:,:,:) =    &
             sum(Model_microphys%stoch_conc_ice(:,:,:,:), dim = 4)/ncol
          used = send_data (id_ice_conc_ave, cloud, Time_diag, &
                            is, js, 1, rmask=mask)
          if (id_iwp_ave > 0 ) then 
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_iwp_ave, cloud2d, Time_diag, &
                              is, js                )
          endif
        endif !(id_ice_conc_ave > 0  .or. id_iwp_ave > 0 ) 

!--------------------------------------------------------------------
!    grid-box-mean (averaged over all stochastic bands) ice water path 
!    and ice water amount contributions from large-scale, cell,
!    meso, and shallow clouds.
!--------------------------------------------------------------------
        if (max(id_lsc_iwp_ave, id_lsc_ice_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =    &
                       (Model_microphys%stoch_cloud_type(:,:,:,:) == 1) 
          cloud(:,:,:) =   &
                  SUM (Model_microphys%stoch_conc_ice(:,:,:,:),  &
                                       mask=tmplmask4, dim = 4) / ncol
          if (id_lsc_iwp_ave  > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_lsc_iwp_ave, cloud2d,   &
                              Time_diag, is, js)
          endif
          used = send_data (id_lsc_ice_conc_ave, cloud, &
                            Time_diag, is, js,1)
        endif
 
        if (max(id_meso_iwp_ave, id_meso_ice_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =    &
                      (Model_microphys%stoch_cloud_type(:,:,:,:) == 2) 
          cloud(:,:,:) =   &
                  SUM (Model_microphys%stoch_conc_ice(:,:,:,:),  &
                                     mask=tmplmask4, dim = 4) / ncol
          if (id_meso_iwp_ave > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_meso_iwp_ave, cloud2d,   &
                              Time_diag, is, js)
          endif
          used = send_data (id_meso_ice_conc_ave, cloud,   &
                            Time_diag, is, js,1)
        endif
        if (max(id_cell_iwp_ave, id_cell_ice_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =   &
                   (Model_microphys%stoch_cloud_type(:,:,:,:) == 3)  
          cloud(:,:,:) =   &
              SUM (Model_microphys%stoch_conc_ice(:,:,:,:),  &
                                    mask=tmplmask4, dim = 4) / ncol
          if (id_cell_iwp_ave  > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_cell_iwp_ave, cloud2d,  &
                              Time_diag, is, js)
          endif
          used = send_data (id_cell_ice_conc_ave, cloud,   &
                            Time_diag, is, js,1)
        endif

        if (max(id_shallow_iwp_ave, id_shallow_ice_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =    &
                      (Model_microphys%stoch_cloud_type(:,:,:,:) == 4)  
          cloud(:,:,:) =   &
              SUM (Model_microphys%stoch_conc_ice(:,:,:,:),  &
                                      mask=tmplmask4, dim = 4) / ncol
          if (id_shallow_iwp_ave  > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_shallow_iwp_ave, cloud2d,   &
                              Time_diag, is, js)
          endif
          used = send_data (id_shallow_ice_conc_ave, cloud,  &
                            Time_diag, is, js,1)
        endif


!---------------------------------------------------------------------
!    in-cloud (averaged only over cloudy stochastic columns) ice water 
!    content, ice water path, ice particle size, and fraction of 
!    stochastic columns containing cloud ice.
!---------------------------------------------------------------------
        if (max(id_ic_ice_conc_ave, id_ic_iwp_ave, &
                id_ice_size_ave,    id_ice_col_frac_ave) > 0 ) then
          tmplmask4(:,:,:,:) =     &
                   Model_microphys%stoch_conc_ice(:,:,:,:) > 0.0 
          cloud2(:,:,:) = COUNT (tmplmask4(:,:,:,:), dim = 4)
          tmplmask = cloud2 > 0.0
          cloud(:,:,:) = 0.
          where (tmplmask) 
            cloud(:,:,:) =   &
                 SUM (Model_microphys%stoch_conc_ice(:,:,:,:), &
                     mask =tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
          end where

          used = send_data (id_ic_ice_conc_ave, cloud, Time_diag, &
                            is, js, 1, mask=tmplmask)

          if (id_ic_iwp_ave > 0 ) then 
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            tmplmask2 = sum(cloud2(:,:,:), dim=3) > 0.0
            used = send_data (id_ic_iwp_ave, cloud2d, Time_diag, &
                              is, js, mask=tmplmask2)
          endif

          if (id_ice_size_ave > 0) then
            cloud(:,:,:) = 0.
            where (tmplmask) 
              cloud(:,:,:) =   &    
                 SUM (Model_microphys%stoch_size_ice(:,:,:,:), &
                    mask =tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_ice_size_ave, cloud, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif

          if (id_ice_col_frac_ave > 0 ) then
            cloud2 = cloud2 / float(ncol)
            used = send_data (id_ice_col_frac_ave, cloud2, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif
        endif  

!--------------------------------------------------------------------
!    grid-box-mean (averaged over all stochastic bands) liquid cloud  
!    amount and water path.
!--------------------------------------------------------------------
        if (max(id_drop_conc_ave, id_lwp_ave) > 0  ) then  
          cloud(:,:,:) =   &
             SUM (Model_microphys%stoch_conc_drop(:,:,:,:),    &
                                                        dim = 4) / ncol

          used = send_data (id_drop_conc_ave, cloud, Time_diag, &
                            is, js, 1, rmask=mask)

          if (id_lwp_ave > 0  ) then  
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_lwp_ave, cloud2d, Time_diag, &
                              is, js                )
          endif
        endif 

!--------------------------------------------------------------------
!    grid-box-mean values (averaged over all stochastic bands) of the
!    contributions to total liquid cloud amount and water path 
!    from large-scale, cell, meso, and shallow clouds
!--------------------------------------------------------------------
        if (max(id_lsc_lwp_ave, id_lsc_drop_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =      &
                       (Model_microphys%stoch_cloud_type(:,:,:,:) == 1)
          cloud(:,:,:) =   &
             SUM (Model_microphys%stoch_conc_drop(:,:,:,:), &
                                        mask=tmplmask4, dim = 4) / ncol
          if (id_lsc_lwp_ave > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_lsc_lwp_ave, cloud2d,    &
                              Time_diag, is, js)
          endif
          used = send_data (id_lsc_drop_conc_ave, cloud,     &
                            Time_diag, is, js,1)
        endif

        if (max(id_meso_lwp_ave, id_meso_drop_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =    &
                       (Model_microphys%stoch_cloud_type(:,:,:,:) == 2)
          cloud(:,:,:) =   &
             SUM (Model_microphys%stoch_conc_drop(:,:,:,:), &
                                      mask=tmplmask4, dim = 4) / ncol
          if (id_meso_lwp_ave  > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_meso_lwp_ave, cloud2d,    &
                              Time_diag, is, js)
          endif
          used = send_data (id_meso_drop_conc_ave, cloud,   &
                            Time_diag, is, js,1)
        endif

        if (max(id_cell_lwp_ave, id_cell_drop_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =     &
                      (Model_microphys%stoch_cloud_type(:,:,:,:) == 3)
          cloud(:,:,:) =   &
              SUM (Model_microphys%stoch_conc_drop(:,:,:,:), &
                                       mask=tmplmask4, dim = 4) / ncol
          if (id_cell_lwp_ave > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_cell_lwp_ave, cloud2d,   &
                              Time_diag, is, js)
          endif
          used = send_data (id_cell_drop_conc_ave, cloud,    &
                            Time_diag, is, js,1)
        endif

        if (max(id_shallow_lwp_ave, id_shallow_drop_conc_ave) > 0  ) then
          tmplmask4(:,:,:,:) =    &
                      (Model_microphys%stoch_cloud_type(:,:,:,:) == 4) 
          cloud(:,:,:) =   &
              SUM (Model_microphys%stoch_conc_drop(:,:,:,:), &
                                       mask=tmplmask4, dim = 4) / ncol
          if (id_shallow_lwp_ave  > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3)
            used = send_data (id_shallow_lwp_ave, cloud2d,   &
                              Time_diag, is, js)
          endif
          used = send_data (id_shallow_drop_conc_ave, cloud,  &
                            Time_diag, is, js,1)
        endif

!--------------------------------------------------------------------
!    in-cloud (averaged only over cloudy stochastic columns) liquid 
!    water content, liquid water path, droplet size, droplet number
!    and fraction of stochastic columns containing cloud water.
!--------------------------------------------------------------------
        if (max(id_ic_drop_conc_ave, id_ic_lwp_ave,  &
                id_liq_col_frac_ave, id_drop_size_ave, &  
                id_ra_drop_size_ave, id_droplet_number_ave) > 0) then
          tmplmask4(:,:,:,:) =    &
                        Model_microphys%stoch_conc_drop(:,:,:,:) > 0.0 
          cloud2(:,:,:) = COUNT (tmplmask4(:,:,:,:), dim = 4)
          tmplmask = cloud2 > 0.0
          cloud(:,:,:) = 0.0
          where (tmplmask)   
            cloud(:,:,:) =    &
              SUM (Model_microphys%stoch_conc_drop(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
          end where
          
          used = send_data (id_ic_drop_conc_ave, cloud, Time_diag, &
                            is, js, 1, mask=tmplmask)

          if (id_ic_lwp_ave > 0  ) then
            cloud2d(:,:) = SUM (cloud(:,:,:)*pmass(:,:,:), dim = 3) 
            tmplmask2 = SUM (cloud2(:,:,:), dim=3) > 0.0
            used = send_data (id_ic_lwp_ave, cloud2d, Time_diag, &
                              is, js, mask=tmplmask2)
          endif

          if (id_drop_size_ave > 0) then
            cloud(:,:,:) = 0.0
            where (tmplmask)   
              cloud(:,:,:) =    &
                SUM (Model_microphys%stoch_size_drop(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_drop_size_ave, cloud, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif

          if (id_ra_drop_size_ave > 0) then
            cloud(:,:,:) = 0.0
            where (tmplmask)   
              cloud(:,:,:) = SUM (  &
                  MIN(MAX(Model_microphys%stoch_size_drop(:,:,:,:),   &
                                       mn_drp_diam), mx_drp_diam),    &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_ra_drop_size_ave, cloud, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif

          if (id_droplet_number_ave > 0) then
            cloud(:,:,:) = 0.0
            where (tmplmask)   
              cloud(:,:,:) = SUM (    &
                   Model_microphys%stoch_droplet_number(:,:,:,:),   &
                    mask = tmplmask4, dim = 4)/(cloud2(:,:,:) + 1.0E-40)
            end where
            used = send_data (id_droplet_number_ave, cloud, Time_diag,&
                              is, js, 1, mask=tmplmask)
          endif
          if (id_liq_col_frac_ave > 0 ) then   
            cloud2 = cloud2 / float(ncol)
            used = send_data (id_liq_col_frac_ave, cloud2, Time_diag, &
                              is, js, 1, mask=tmplmask)
          endif
        endif 

!--------------------------------------------------------------------
!    special diagnostic : lwp / drop size in sw band 7 (visible band)
!--------------------------------------------------------------------
        if (id_LWPr > 0) then
          cloud(:,:,:) = Cld_spec%lwp(:,:,:)/  &
                               Lsc_microphys%stoch_size_drop(:,:,:,14)
          tca(:,:) = SUM (cloud(:,:,:), dim = 3)
          used = send_data (id_LWPr, tca, Time_diag, is, js)
        endif

!---------------------------------------------------------------------
!
!
!                   INDIVIDUAL BAND DIAGNOSTICS
!
!
!---------------------------------------------------------------------

        do n=1,ncol

!--------------------------------------------------------------------
!
!
!                     "_ONLY_LSC" DIAGNOSTICS
!
!
!--------------------------------------------------------------------
!    these "_only_lsc" diagnostics allow one to assess the effect of
!    treating the non-lsc clouds stochastically. the difference between
!    the "_only_lsc" variables and the corresponding variables without
!    that appended tag reflect the changes resulting from treating the 
!    non-lsc cloud types stochastically. the cloud properties actually 
!    seen by the model's radiation package are always contained in the 
!    non "_only_lsc" diagnostics.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    diagnostics for each stochastic band --  cloud fraction, ice water
!    content and path, liquid water content and path, ice particle size,
!    droplet size, droplet number. 
!--------------------------------------------------------------------
          used = send_data (id_cldfrac_cols_only_lsc(n),   &
                            Lsc_microphys%stoch_cldamt(:,:,:,n), &
                            Time_diag, is, js, 1, rmask=mask)

          used = send_data (id_ice_conc_cols_only_lsc(n),    &
                            Lsc_microphys%stoch_conc_ice(:,:,:,n), &
                            Time_diag, is, js, 1, rmask=mask)

          used = send_data (id_drop_conc_cols_only_lsc(n),   &
                            Lsc_microphys%stoch_conc_drop(:,:,:,n), &
                            Time_diag, is, js, 1, rmask=mask)

          if (id_iwp_cols_only_lsc(n) > 0) then
            cloud2d(:,:) =   &
               SUM (Lsc_microphys%stoch_conc_ice(:,:,:,n)*   &
                                                pmass(:,:,:), dim = 3)
               used = send_data (id_iwp_cols_only_lsc(n), cloud2d,  &
                                 Time_diag, is, js)
          endif

          if (id_lwp_cols_only_lsc(n) > 0) then
            cloud2d(:,:) =   &
              SUM (Lsc_microphys%stoch_conc_drop(:,:,:,n)*  &
                                                 pmass(:,:,:), dim = 3)
              used = send_data (id_lwp_cols_only_lsc(n), cloud2d,   &
                                Time_diag, is, js)
          endif

          if (id_ice_size_cols_only_lsc(n) > 0) then
            tmplmask = Lsc_microphys%stoch_conc_ice(:,:,:,n) > 0.0
            used = send_data (id_ice_size_cols_only_lsc(n),   &
                              Lsc_microphys%stoch_size_ice(:,:,:,n), &
                              Time_diag, is, js, 1, mask=tmplmask)
          endif

          if (max(id_drop_size_cols_only_lsc(n),    &
                  id_ra_drop_size_cols_only_lsc(n), &
                  id_droplet_number_cols_only_lsc(n)) > 0) then
            tmplmask = Lsc_microphys%stoch_conc_drop(:,:,:,n) > 0.0

            used = send_data (id_drop_size_cols_only_lsc(n),   &
                              Lsc_microphys%stoch_size_drop(:,:,:,n),&
                              Time_diag, is, js, 1, mask=tmplmask)

            if (id_ra_drop_size_cols_only_lsc(n) > 0) then
              cloud(:,:,:) = MAX (MIN   &
                       (Lsc_microphys%stoch_size_drop(:,:,:,n),   &
                                          mx_drp_diam), mn_drp_diam)
              used = send_data (id_ra_drop_size_cols_only_lsc(n),  &
                                cloud, Time_diag, is, js, 1,   &
                                mask=tmplmask)
            endif

            used = send_data (id_droplet_number_cols_only_lsc(n),   &
                        Lsc_microphys%stoch_droplet_number(:,:,:,n),&
                              Time_diag, is, js, 1, mask=tmplmask)
          endif ! (3 options)

!---------------------------------------------------------------------
!
!
!              CLOUD PROPERTIES SEEN BY RADIATION CODE 
!
!
!---------------------------------------------------------------------
          used = send_data (id_cldfrac_cols(n),   &
                            Model_microphys%stoch_cldamt(:,:,:,n), &
                            Time_diag, is, js, 1, rmask=mask)

          used = send_data (id_ice_conc_cols(n),   &
                            Model_microphys%stoch_conc_ice(:,:,:,n),&
                            Time_diag, is, js, 1, rmask=mask)

          used = send_data (id_drop_conc_cols(n),   &
                            Model_microphys%stoch_conc_drop(:,:,:,n),&
                            Time_diag, is, js, 1, rmask=mask)

          if (id_iwp_cols(n) > 0) then
            cloud2d(:,:) = SUM (  &
                 Model_microphys%stoch_conc_ice(:,:,:,n)*  &
                                                pmass(:,:,:), dim = 3)
            used = send_data (id_iwp_cols(n), cloud2d, Time_diag, &
                              is, js)
          endif

          if (id_lwp_cols(n) > 0) then
            cloud2d(:,:) = SUM (  &
                Model_microphys%stoch_conc_drop(:,:,:,n)*    &
                                                pmass(:,:,:), dim = 3)
            used = send_data (id_lwp_cols(n), cloud2d, Time_diag, &
                              is, js)
          endif

          if (id_ice_size_cols(n) > 0) then
            tmplmask = Model_microphys%stoch_conc_ice(:,:,:,n) > 0.0
            used = send_data (id_ice_size_cols(n),   &
                              Model_microphys%stoch_size_ice(:,:,:,n), &
                              Time_diag, is, js, 1, mask=tmplmask)
          endif

          if (max(id_drop_size_cols(n),    &
                  id_ra_drop_size_cols(n), &
                  id_droplet_number_cols(n)) > 0) then
            tmplmask = Model_microphys%stoch_conc_drop(:,:,:,n) > 0.0

            used = send_data (id_drop_size_cols(n),   &
                            Model_microphys%stoch_size_drop(:,:,:,n),&
                            Time_diag, is, js, 1, mask=tmplmask)

            if (id_ra_drop_size_cols(n) > 0) then
              cloud(:,:,:) = MAX(MIN(      &
                   Model_microphys%stoch_size_drop(:,:,:,n),  &
                                             mx_drp_diam), mn_drp_diam)
              used = send_data (id_ra_drop_size_cols(n), cloud,   &
                                Time_diag, is, js, 1, mask=tmplmask)
            endif

            used = send_data (id_droplet_number_cols(n),  &
                      Model_microphys%stoch_droplet_number(:,:,:,n),&
                              Time_diag, is, js, 1, mask=tmplmask)
          endif ! (3 options)
        end do

!----------------------------------------------------------------------
!    frequency of occurrence of large-scale, donner meso and cell and 
!    uw shallow clouds in cloudy stochastic columns (stoch_ic_xxx_...).
!    frequency of seeing various cloud types (largescale, donner meso 
!    and cell, uw shallow) when they are present (stoch_sees_xxx), and 
!    the grid-box-mean frequency of their being seen by the radiation 
!    package, averaged over all stochastic columns  (stoch_xxx_cf_ave). 
!----------------------------------------------------------------------
        if (max(id_stoch_ic_shallow_cf_ave, id_stoch_ic_cell_cf_ave, &
                id_stoch_ic_meso_cf_ave,    id_stoch_ic_lsc_cf_ave,  &
                id_stoch_sees_lsc,          id_stoch_sees_meso,      &
                id_stoch_sees_cell,         id_stoch_sees_shallow,   &
                id_stoch_lsc_cf_ave,        id_stoch_meso_cf_ave,    &
                id_stoch_cell_cf_ave,       id_stoch_shallow_cf_ave) > 0 ) then
          cloud(:,:,:) =   &
                  SUM (Model_microphys%stoch_cldamt(:,:,:,:), dim = 4) 
          tmplmask = cloud > 0.0
         
          if (Cldrad_control%do_strat_clouds) then
            if (max(id_stoch_ic_lsc_cf_ave, id_stoch_sees_lsc, &
                    id_stoch_lsc_cf_ave) > 0 )  then
              cloud(:,:,:) = REAL (COUNT(    &
                  Model_microphys%stoch_cloud_type(:,:,:,:) == 1,    &
                                                   dim = 4))/REAL(ncol)
              used = send_data (id_stoch_ic_lsc_cf_ave, cloud, &
                                Time_diag, is, js, 1, mask=tmplmask)
              if (id_stoch_sees_lsc > 0) then
                tmplmaska =  Lsc_microphys%cldamt > 0.0    
                used = send_data (id_stoch_sees_lsc, cloud,  &
                                  Time_diag, is, js, 1, mask=tmplmaska)
              endif
              used = send_data (id_stoch_lsc_cf_ave, cloud,  &
                                Time_diag, is, js, 1)
            endif
          endif

          if (Cldrad_control%do_donner_deep_clouds) then
            if (max(id_stoch_ic_meso_cf_ave, id_stoch_sees_meso, &
                    id_stoch_meso_cf_ave) > 0 )  then
              cloud(:,:,:) = REAL (COUNT(    &
                  Model_microphys%stoch_cloud_type(:,:,:,:) == 2,    &
                                                   dim = 4))/REAL(ncol)
              used = send_data (id_stoch_ic_meso_cf_ave, cloud, &
                                Time_diag, is, js, 1, mask=tmplmask)
              if (id_stoch_sees_meso > 0) then
                tmplmaska =  Meso_microphys%cldamt > 0.0    
                used = send_data (id_stoch_sees_meso, cloud,  &
                                  Time_diag, is, js, 1, mask=tmplmaska)
              endif
              used = send_data (id_stoch_meso_cf_ave, cloud,  &
                                Time_diag, is, js, 1)
            endif
            if (max(id_stoch_ic_cell_cf_ave, id_stoch_sees_cell, &
                    id_stoch_cell_cf_ave) > 0 )  then
              cloud(:,:,:) = REAL (COUNT(    &
                  Model_microphys%stoch_cloud_type(:,:,:,:) == 3,    &
                                                   dim = 4))/REAL(ncol)
              used = send_data (id_stoch_ic_cell_cf_ave, cloud, &
                                Time_diag, is, js, 1, mask=tmplmask)
              if (id_stoch_sees_cell > 0) then
                tmplmaska =  Cell_microphys%cldamt > 0.0    
                used = send_data (id_stoch_sees_cell, cloud,  &
                                  Time_diag, is, js, 1, mask=tmplmaska)
              endif
              used = send_data (id_stoch_cell_cf_ave, cloud,  &
                                Time_diag, is, js, 1)
            endif
          endif

          if (Cldrad_control%do_uw_clouds) then
            if (max(id_stoch_ic_shallow_cf_ave, id_stoch_sees_shallow, &
                    id_stoch_shallow_cf_ave) > 0 )  then
              cloud(:,:,:) = REAL (COUNT(    &
                  Model_microphys%stoch_cloud_type(:,:,:,:) == 4,    &
                                                   dim = 4))/REAL(ncol)
              used = send_data (id_stoch_ic_shallow_cf_ave, cloud, &
                                Time_diag, is, js, 1, mask=tmplmask)
              if (id_stoch_sees_shallow > 0) then
                tmplmaska =  Shallow_microphys%cldamt > 0.0    
                used = send_data (id_stoch_sees_shallow, cloud,  &
                                  Time_diag, is, js, 1, mask=tmplmaska)
              endif
              used = send_data (id_stoch_shallow_cf_ave, cloud,  &
                                Time_diag, is, js, 1)
            endif
          endif
        endif

!----------------------------------------------------------------------
!    cloud type assigned to each stochastic column.
!----------------------------------------------------------------------
        do n=1,ncol    
          if (id_stoch_cloud_type(n) > 0) then
            tmplmask = Model_microphys%stoch_cloud_type(:, :, :, n) /= 0
            used = send_data   &
                       (id_stoch_cloud_type(n),   &
                       REAL(Model_microphys%stoch_cloud_type(:,:,:,n)),&
                       Time_diag, is, js, 1, mask = tmplmask)
          endif
        end do 

      endif ! (do_stochastic_clouds)

!---------------------------------------------------------------------



end subroutine cloudrad_netcdf



!#####################################################################

subroutine model_micro_dealloc (Model_microphys)
 
type(microphysics_type), intent(inout) :: Model_microphys


!--------------------------------------------------------------------
!    deallocate the components of the microphysics_type derived type
!    variable.
!--------------------------------------------------------------------
     if (Cldrad_control%do_stochastic_clouds) then
        nullify (Model_microphys%lw_stoch_conc_ice)
        nullify (Model_microphys%lw_stoch_conc_drop)
        nullify (Model_microphys%lw_stoch_size_ice)
        nullify (Model_microphys%lw_stoch_size_drop)
        nullify (Model_microphys%lw_stoch_cldamt) 
        nullify (Model_microphys%lw_stoch_droplet_number)
        nullify (Model_microphys%sw_stoch_conc_ice)
        nullify (Model_microphys%sw_stoch_conc_drop)
        nullify (Model_microphys%sw_stoch_size_ice)
        nullify (Model_microphys%sw_stoch_size_drop)
        nullify (Model_microphys%sw_stoch_cldamt)
        nullify (Model_microphys%sw_stoch_droplet_number)
        deallocate (Model_microphys%stoch_conc_ice)
        deallocate (Model_microphys%stoch_conc_drop)
        deallocate (Model_microphys%stoch_size_ice)
        deallocate (Model_microphys%stoch_size_drop)
        deallocate (Model_microphys%stoch_cldamt)  
        deallocate (Model_microphys%stoch_cloud_type)
        deallocate (Model_microphys%stoch_droplet_number)
      endif ! (do_stochastic_clouds)

      deallocate (Model_microphys%conc_drop   )
      deallocate (Model_microphys%conc_ice    )
      deallocate (Model_microphys%conc_rain   )
      deallocate (Model_microphys%conc_snow   )
      deallocate (Model_microphys%size_drop   )
      deallocate (Model_microphys%size_ice    )
      deallocate (Model_microphys%size_rain   )
      deallocate (Model_microphys%size_snow  )
      deallocate (Model_microphys%cldamt      )
      deallocate (Model_microphys%droplet_number  )
       
!------------------------------------------------------------------



end subroutine model_micro_dealloc


!####################################################################
! <SUBROUTINE NAME="cloudrad_diagnostics_end">
!  <OVERVIEW>
!    cloudrad_diagnostics_end is the destructor for 
!    cloudrad_diagnostics_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    cloudrad_diagnostics_end is the destructor for 
!    cloudrad_diagnostics_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloudrad_diagnostics_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine cloudrad_diagnostics_end

!-------------------------------------------------------------------
!    cloudrad_diagnostics_end is the destructor for 
!    cloudrad_diagnostics_mod.
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('cloudrad_diagnostics_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!--------------------------------------------------------------------
!    close out the component modules.
!--------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds) then
        if (do_isccp) call isccp_clouds_end
      endif

!--------------------------------------------------------------------
!    mark the module as not initialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------



end subroutine cloudrad_diagnostics_end




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!####################################################################
! <SUBROUTINE NAME="diag_field_init">
!  <OVERVIEW>
!    diag_field_init registers the potential netcdf output variables
!    with diag_manager_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_field_init registers the potential netcdf output variables
!    with diag_manager_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_field_init (axes, Time)
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="real">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
! </SUBROUTINE>
!
subroutine diag_field_init (Time, axes )

!---------------------------------------------------------------------
!    diag_field_init registers the potential netcdf output variables
!    with diag_manager_mod.
!---------------------------------------------------------------------

type(time_type), intent(in) :: Time
integer        , intent(in) :: axes(4)

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       Time      initialization time for the netcdf output fields
!       axes      diagnostic variable axes
!
!---------------------------------------------------------------------
      character(len=8) :: chvers
      integer          :: n

!---------------------------------------------------------------------
!    register the MODIS-related diagnostic fields in this module.
!---------------------------------------------------------------------
      id_reff_modis = register_diag_field    &
                         (mod_name, 'reff_modis', axes(1:2), Time, &
                          'MODIS effective radius', 'micron')

      id_reff_modis2 = register_diag_field    &
                         (mod_name, 'reff_modis2', axes(1:2), Time, &
                          'MODIS effective radius frequency', 'count')

      if ((id_reff_modis < 0 .and. id_reff_modis2 > 0) .or. &
          (id_reff_modis > 0 .and. id_reff_modis2 < 0)) then
        call error_mesg ('cloudrad_diagnostics_mod,diag_field_init:',&
          'both reff_modis and reff_modis2 must either  &
                                       &be active or inactive', FATAL)
      endif
      id_reff_modis3 = register_diag_field    &
                         (mod_name, 'reff_modis3', axes(1:2), Time, &
                          'MODIS scan pressure level', 'mbar')

      id_cldtop_reff = register_diag_field    &
                         (mod_name, 'cldtop_reff', axes(1:2), Time, &
                          'liq drop radius at cld top*cfrac', 'meters')
     
      id_cldtop_area = register_diag_field    &
                         (mod_name, 'cldtop_area', axes(1:2), Time, &
                          'liq cloud area at cld top', '1')
     
      id_cldtop_dropnum = register_diag_field    &
                         (mod_name, 'cldtop_dropnum', axes(1:2), Time, &
                          'liq droplet # at cld top*cfrac', 'm-3')
     
      id_dropnum_col = register_diag_field    &
                         (mod_name, 'dropnum_col', axes(1:2), Time, &
                    'column integrated liq droplet # * cfrac', 'm-2')
     
!---------------------------------------------------------------------
!    register various cloud fraction diagnostics.
!---------------------------------------------------------------------
      id_tot_cld_amt = register_diag_field    &
                         (mod_name, 'tot_cld_amt', axes(1:2), Time, &
                          'total cloud amount', 'percent')

      id_high_cld_amt = register_diag_field   &
                         (mod_name, 'high_cld_amt', axes(1:2), Time, &
                          'high cloud amount', 'percent')

      id_mid_cld_amt =  register_diag_field     &
                         (mod_name, 'mid_cld_amt', axes(1:2), Time, &
                          'mid cloud amount', 'percent')
  
      id_low_cld_amt = register_diag_field    &
                         (mod_name, 'low_cld_amt', axes(1:2), Time, &
                          'low cloud amount', 'percent')

      id_lam_cld_amt = register_diag_field    &
                         (mod_name, 'lam_cld_amt', axes(1:2), Time, &
                          'low and mid cloud amount', 'percent')

      if ( .not. Cldrad_control%do_stochastic_clouds) then
        id_cld_amt =  register_diag_field     &
                         (mod_name, 'cld_amt', axes(1:3), Time,      &
                          'cloud amount', 'percent',     &
                          missing_value=missing_value)

        id_predicted_cld_amt = register_diag_field    &
                         (mod_name, 'predicted_cld_amt', axes(1:3), &
                          Time, 'total raw predicted cloud amount',   &
                          'percent', missing_value=missing_value)

      endif

!---------------------------------------------------------------------
!    register lw cloud radiative properties diagnostics - all active
!    clouds, as seen by radiation package.
!---------------------------------------------------------------------
      id_em_cld_lw =  register_diag_field    &
                         (mod_name, 'em_cld_lw', axes(1:3), Time, &
                          'lw cloud emissivity', 'percent',        &
                           missing_value=missing_value)
 
      id_em_cld_10u = register_diag_field    &
                         (mod_name, 'em_cld_10u', axes(1:3), Time, &
                          'cloud emissivity 10 um band', 'percent',    &
                          missing_value=missing_value)

      id_abs_cld_lw = register_diag_field    &
                         (mod_name, 'abs_lw', axes(1:3), Time, &
                          'cloud abs coeff lw', 'percent',        &
                          missing_value=missing_value)

      id_abs_cld_10u = register_diag_field     &
                         (mod_name, 'abs_10u', axes(1:3), Time, &
                          'cloud abs coeff 10um band', 'percent',    &
                          missing_value=missing_value)

!---------------------------------------------------------------------
!    register diagnostic fields associated with the bulk shortwave
!    parameterization, all active clouds, as seen by radiation package.
!---------------------------------------------------------------------
      if (.not. Cldrad_control%do_sw_micro) then
        id_alb_uv_cld = register_diag_field     &
                         (mod_name, 'alb_uv_cld', axes(1:3), Time, &
                          'UV reflected by cloud', 'percent',       &
                          missing_value=missing_value)

        id_alb_nir_cld = register_diag_field      &
                         (mod_name, 'alb_nir_cld', axes(1:3), Time, &
                          'IR reflected by cloud', 'percent',        &
                          missing_value=missing_value)

!   --- do not output this field ---
!       id_abs_uv_cld =  register_diag_field    &
!                        (mod_name, 'abs_uv_cld', axes(1:3), Time, &
!                         'UV absorbed by cloud', 'percent',        &
!                         missing_value=missing_value)

        id_abs_nir_cld = register_diag_field     &
                         (mod_name, 'abs_nir_cld', axes(1:3), Time, &
                          'IR absorbed by cloud', 'percent',         &
                          missing_value=missing_value)

!---------------------------------------------------------------------
!    register diagnostic fields associated with the microphysically
!    based shortwave parameterization, all active clouds, as seen by
!    radiation package.
!---------------------------------------------------------------------
      else 
        id_ext_cld_uv = register_diag_field       &
                         (mod_name, 'ext_cld_uv', axes(1:3), Time, &
                          '.27um cloud extinction coeff', 'km-1',  &
                         missing_value=missing_value)

        id_sct_cld_uv = register_diag_field     &
                         (mod_name, 'sct_cld_uv', axes(1:3), Time, &
                          '.27um cloud scattering coeff', 'km-1', &
                          missing_value=missing_value)

        id_asymm_cld_uv = register_diag_field    &
                         (mod_name, 'asymm_cld_uv', axes(1:3), Time, &
                          '.27um cloud asymmetry parameter',   &
                          'percent', missing_value=missing_value) 

        id_ext_cld_vis =  register_diag_field     &
                         (mod_name, 'ext_cld_vis', axes(1:3), Time, &
                          '.55um cloud extinction coeff', 'km-1', &
                          missing_value=missing_value)

        id_sct_cld_vis = register_diag_field    &
                         (mod_name, 'sct_cld_vis', axes(1:3), Time, &
                          '.55um cloud scattering coeff', 'km-1', &
                          missing_value=missing_value)

        id_asymm_cld_vis = register_diag_field      &
                         (mod_name, 'asymm_cld_vis', axes(1:3), Time,&
                          '.55um cloud asymmetry parameter',   &
                          'percent', missing_value=missing_value)

        id_ext_cld_nir = register_diag_field    &
                         (mod_name, 'ext_cld_nir', axes(1:3), Time, &
                          '1.4um cloud extinction coeff', 'km-1', &
                          missing_value=missing_value)

        id_sct_cld_nir = register_diag_field    &
                         (mod_name, 'sct_cld_nir', axes(1:3), Time, &
                          '1.4um cloud scattering coeff', 'km-1', &
                          missing_value=missing_value)
 
        id_asymm_cld_nir = register_diag_field   &
                         (mod_name, 'asymm_cld_nir', axes(1:3), Time,&
                          '1.4um cloud asymmetry parameter',   &
                          'percent', missing_value=missing_value)

!---------------------------------------------------------------------
!    register the microphysically-based cloud radiative property
!    diagnostics resulting from the large-scale clouds only.
!---------------------------------------------------------------------
        id_lsc_cld_ext_uv = register_diag_field    &
                         (mod_name, 'lsc_cld_ext_uv', axes(1:3),   &
                          Time, '.27um lsc cloud ext coeff', 'km-1',&
                          missing_value=missing_value)

        id_lsc_cld_ext_vis = register_diag_field   &
                         (mod_name, 'lsc_cld_ext_vis', axes(1:3), &
                          Time, '.55um lsc cloud ext coeff',   &
                          'km-1', missing_value=missing_value)
 
        id_lsc_cld_ext_nir = register_diag_field    &
                         (mod_name, 'lsc_cld_ext_nir', axes(1:3),  &
                          Time, '1.4um lsc cloud ext coeff',   &
                          'km-1', missing_value=missing_value)

        id_lsc_cld_sct_uv = register_diag_field    &
                         (mod_name, 'lsc_cld_sct_uv', axes(1:3),  &
                          Time, '.27um lsc cloud sct coeff', 'km-1',&
                          missing_value=missing_value)

        id_lsc_cld_sct_vis = register_diag_field    &
                         (mod_name, 'lsc_cld_sct_vis', axes(1:3),  &
                          Time, '.55um lsc cloud sct coeff',  &
                          'km-1', missing_value=missing_value)

        id_lsc_cld_sct_nir = register_diag_field    &
                         (mod_name, 'lsc_cld_sct_nir', axes(1:3), &
                          Time, '1.4um lsc cloud sct coeff',  &
                          'km-1', missing_value=missing_value)
 
        id_lsc_cld_asymm_uv = register_diag_field   &
                         (mod_name, 'lsc_cld_asymm_uv', axes(1:3),&
                          Time, '.27um lsc cloud asymm coeff',  &
                          'percent', missing_value=missing_value)

        id_lsc_cld_asymm_vis = register_diag_field  &
                         (mod_name, 'lsc_cld_asymm_vis', axes(1:3),  &
                          Time,  '.55um lsc cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

        id_lsc_cld_asymm_nir = register_diag_field   &
                         (mod_name, 'lsc_cld_asymm_nir', axes(1:3),  &
                          Time, '1.4um lsc cloud asymm coeff', &
                          'percent', missing_value=missing_value)

      endif

!---------------------------------------------------------------------
!    register the microphysically-based cloud amount and lw cloud
!    radiative properties diagnostic fields.
!---------------------------------------------------------------------
      id_lsc_cld_amt = register_diag_field    &
                         (mod_name, 'lsc_cld_amt', axes(1:3), Time, &
                          'lsc cloud amount', 'percent',             &
                          missing_value=missing_value)

      id_abs_lsc_cld_lw = register_diag_field    &
                         (mod_name, 'lsc_abs_lw', axes(1:3), Time, &
                          'lsc cloud abs coeff lw', 'percent',     &
                          missing_value=missing_value)

      id_abs_lsc_cld_10u = register_diag_field   &
                         (mod_name, 'lsc_abs_10u', axes(1:3), Time,&
                          'lsc cloud abs coeff 10um band',   &
                          'percent', missing_value=missing_value)

!---------------------------------------------------------------------
!    register the donner cell-scale cloud radiative property diagnostic 
!    fields.
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds_iz) then
        if (Cldrad_control%do_donner_deep_clouds) then
          id_cell_cld_amt = register_diag_field    &
                         (mod_name, 'cell_cld_amt', axes(1:3), Time,&
                          'cell cloud amount', 'percent',           &
                          missing_value=missing_value)

          id_cell_cld_ext_uv = register_diag_field   &
                         (mod_name, 'cell_cld_ext_uv', axes(1:3),&
                          Time, '.27um cell cloud ext coeff',  &
                          'km-1', missing_value=missing_value)

          id_cell_cld_ext_vis = register_diag_field   &
                         (mod_name, 'cell_cld_ext_vis', axes(1:3),  &
                          Time, '.55um cell cloud ext coeff',  &
                          'km-1', missing_value=missing_value)

          id_cell_cld_ext_nir = register_diag_field   &
                         (mod_name, 'cell_cld_ext_nir', axes(1:3),  &
                          Time, '1.4um cell cloud ext coeff',  &
                          'km-1', missing_value=missing_value)

          id_cell_cld_sct_uv = register_diag_field    &
                         (mod_name, 'cell_cld_sct_uv', axes(1:3),&
                          Time, '.27um cell cloud sct coeff',   &
                          'km-1', missing_value=missing_value)

          id_cell_cld_sct_vis = register_diag_field    &
                         (mod_name, 'cell_cld_sct_vis', axes(1:3),  &
                          Time, '.55um cell cloud sct coeff',  &
                          'km-1', missing_value=missing_value)

          id_cell_cld_sct_nir = register_diag_field    &
                         (mod_name, 'cell_cld_sct_nir', axes(1:3), &
                          Time, '1.4um cell cloud sct coeff', &
                          'km-1', missing_value=missing_value)

          id_cell_cld_asymm_uv = register_diag_field    &
                         (mod_name, 'cell_cld_asymm_uv', axes(1:3), &
                          Time, '.27um cell cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

          id_cell_cld_asymm_vis = register_diag_field     &
                         (mod_name, 'cell_cld_asymm_vis', axes(1:3), &
                          Time, '.55um cell cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

          id_cell_cld_asymm_nir = register_diag_field    &
                         (mod_name, 'cell_cld_asymm_nir', axes(1:3), &
                          Time, '1.4um cell cloud asymm coeff',    &
                          'percent', missing_value=missing_value)

          id_abs_cell_cld_lw = register_diag_field    &
                         (mod_name, 'cell_abs_lw', axes(1:3), Time, &
                          'cell cloud abs coeff lw', &
                          'percent', missing_value=missing_value)

          id_abs_cell_cld_10u = register_diag_field    &
                         (mod_name, 'cell_abs_10u', axes(1:3), Time,   &
                          'cell cloud abs coeff 10um band', &
                          'percent', missing_value=missing_value)

!---------------------------------------------------------------------
!    register the donner meso-scale cloud radiative property diagnostic 
!    fields.
!---------------------------------------------------------------------
          id_meso_cld_amt = register_diag_field     &
                         (mod_name, 'meso_cld_amt', axes(1:3), Time,&
                          'meso cloud amount', 'percent',      &
                          missing_value=missing_value)

          id_meso_cld_ext_uv = register_diag_field    &
                         (mod_name, 'meso_cld_ext_uv', axes(1:3),&
                          Time, '.27um meso cloud ext coeff',   &
                          'km-1', missing_value=missing_value)

          id_meso_cld_ext_vis = register_diag_field   &
                         (mod_name, 'meso_cld_ext_vis', axes(1:3), &
                          Time, '.55um meso cloud ext coeff',  &
                          'km-1', missing_value=missing_value)

          id_meso_cld_ext_nir = register_diag_field   &
                         (mod_name, 'meso_cld_ext_nir', axes(1:3), &
                          Time, '1.4um meso cloud ext coeff',  &
                          'km-1', missing_value=missing_value)

          id_meso_cld_sct_uv = register_diag_field   &
                         (mod_name, 'meso_cld_sct_uv', axes(1:3),&
                          Time, '.27um meso cloud sct coeff',  &
                          'km-1', missing_value=missing_value )

          id_meso_cld_sct_vis = register_diag_field  &
                         (mod_name, 'meso_cld_sct_vis', axes(1:3),  &
                          Time, '.55um meso cloud sct coeff',  &
                          'km-1', missing_value=missing_value)

          id_meso_cld_sct_nir = register_diag_field  &
                         (mod_name, 'meso_cld_sct_nir', axes(1:3),  &
                          Time, '1.4um meso cloud sct coeff',  &
                          'km-1', missing_value=missing_value)

          id_meso_cld_asymm_uv = register_diag_field  &
                         (mod_name, 'meso_cld_asymm_uv', axes(1:3),  &
                          Time, '.27um meso cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

          id_meso_cld_asymm_vis = register_diag_field   &
                         (mod_name, 'meso_cld_asymm_vis', axes(1:3),   &
                          Time, '.55um meso cloud asymm coeff',    &
                          'percent', missing_value=missing_value)

          id_meso_cld_asymm_nir = register_diag_field    &
                         (mod_name, 'meso_cld_asymm_nir', axes(1:3), &
                          Time, '1.4um meso cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

          id_abs_meso_cld_lw = register_diag_field    &
                         (mod_name, 'meso_abs_lw', axes(1:3),  &
                          Time, 'meso cloud abs coeff lw',  &
                          'percent', missing_value=missing_value)

          id_abs_meso_cld_10u = register_diag_field   &
                         (mod_name, 'meso_abs_10u', axes(1:3), Time,   &
                          'meso cloud abs coeff 10um band', &
                          'percent', missing_value=missing_value)
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod', &
            'Cldrad_control%do_donner_deep_clouds not yet defined',  &
                                                                FATAL)
      endif

!---------------------------------------------------------------------
!    register the uw shallow cloud radiative property diagnostic 
!    fields.
!---------------------------------------------------------------------
      if (Cldrad_control%do_uw_clouds_iz) then
        if (Cldrad_control%do_uw_clouds) then
          id_shallow_cld_amt = register_diag_field    &
                         (mod_name, 'shallow_cld_amt', axes(1:3),&
                          Time, 'shallow cloud amount',   &
                          'percent', missing_value=missing_value)

          id_shallow_cld_ext_uv = register_diag_field   &
                         (mod_name, 'uw_shallow_cld_ext_uv', &
                          axes(1:3), Time,   &
                          '.27um uw shallow cloud ext coeff', &
                          'km-1', missing_value=missing_value)

          id_shallow_cld_ext_vis = register_diag_field   &
                         (mod_name, 'uw_shallow_cld_ext_vis',&
                          axes(1:3), Time,   &
                          '.55um uw shallow cloud ext coeff',&
                          'km-1', missing_value=missing_value)

          id_shallow_cld_ext_nir = register_diag_field   &
                         (mod_name, 'uw_shallow_cld_ext_nir',&
                          axes(1:3), Time,   &
                          '1.4um uw shallow cloud ext coeff',&
                          'km-1', missing_value=missing_value)

          id_shallow_cld_sct_uv = register_diag_field    &
                         (mod_name, 'uw_shallow_cld_sct_uv', &
                          axes(1:3), Time,  &
                          '.27um uw shallow cloud sct coeff', &
                          'km-1', missing_value=missing_value)

          id_shallow_cld_sct_vis = register_diag_field    &
                         (mod_name, 'uw_shallow_cld_sct_vis',&
                          axes(1:3), Time,    &
                          '.55um uw_shallow cloud sct coeff',&
                          'km-1', missing_value=missing_value)

          id_shallow_cld_sct_nir = register_diag_field    &
                         (mod_name, 'uw_shallow_cld_sct_nir', &
                          axes(1:3), Time,   &
                          '1.4um uw shallow cloud sct coeff',&
                          'km-1', missing_value=missing_value)

          id_shallow_cld_asymm_uv = register_diag_field    &
                         (mod_name, 'uw_shallow_cld_asymm_uv',   &
                          axes(1:3), Time,  &
                          '.27um uw shallow cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

          id_shallow_cld_asymm_vis = register_diag_field     &
                         (mod_name, 'uw_shallow_cld_asymm_vis',   &
                          axes(1:3), Time,     &
                          '.55um uw shallow cloud asymm coeff',   &
                          'percent', missing_value=missing_value)

          id_shallow_cld_asymm_nir = register_diag_field    &
                         (mod_name, 'uw_shallow_cld_asymm_nir',    &
                          axes(1:3), Time,&
                          '1.4um uw shallow cloud asymm coeff',    &
                          'percent', missing_value=missing_value)

          id_abs_shallow_cld_lw = register_diag_field    &
                         (mod_name, 'uw_shallow_abs_lw', axes(1:3),  &
                          Time, 'uw shallow cloud abs coeff lw',   &
                          'percent', missing_value=missing_value)

          id_abs_shallow_cld_10u = register_diag_field    &
                         (mod_name, 'uw_shallow_abs_10u', axes(1:3), &
                          Time, 'uw shallow cloud abs coeff 10um band',&
                          'percent',  missing_value=missing_value)
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod', &
                'Cldrad_control%do_uw_clouds not yet defined', FATAL)
      endif

!--------------------------------------------------------------------
!    register total cloud condensate (non-stochastic case)   
!--------------------------------------------------------------------
      if ( .not. Cldrad_control%do_stochastic_clouds) then
        id_all_conc_drop = register_diag_field     &
                         (mod_name, 'all_conc_drop', axes(1:3), Time, &
                          'In-cloud liq water content - all clouds', &
                          'grams/m3', missing_value=missing_value)

        id_all_conc_ice = register_diag_field     &
                         (mod_name, 'all_conc_ice', axes(1:3), Time, &
                          'In-cloud ice water content - all clouds', &
                          'grams/m3', missing_value=missing_value)
      endif

!--------------------------------------------------------------------
!    register stratiform microphysical properties
!--------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds_iz) then
        if (Cldrad_control%do_strat_clouds) then
          id_strat_area_liq = register_diag_field     &
              (mod_name, 'strat_area_liq', axes(1:3), Time, &
               'Area of stratiform liquid clouds', 'fraction', &
               missing_value=missing_value)

          id_strat_conc_drop = register_diag_field     &
              (mod_name, 'strat_conc_drop', axes(1:3), Time, &
               'In-cloud liq water content of stratiform clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_strat_conc_drop = register_diag_field     &
              (mod_name, 'gb_strat_conc_drop', axes(1:3), Time, &
               'Grid-box-mean liq water content of stratiform clouds', &
               'grams/m3', missing_value=missing_value)      

          id_strat_size_drop = register_diag_field     &
              (mod_name, 'strat_size_drop', axes(1:3), Time, &
               'Effective diameter for stratiform liquid clouds', &
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

          id_ra_strat_size_drop = register_diag_field     &
              (mod_name, 'ra_strat_size_drop', axes(1:3), Time, &
               'Adjusted effective diameter for strat liquid clouds', &
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

          id_strat_area_ice = register_diag_field     &
              (mod_name, 'strat_area_ice', axes(1:3), Time, &
               'Area of stratiform ice clouds', &
               'fraction', missing_value=missing_value)

          id_strat_conc_ice = register_diag_field     &
              (mod_name, 'strat_conc_ice', axes(1:3), Time, &
               'In-cloud ice water content of stratiform clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_strat_conc_ice = register_diag_field     &
              (mod_name, 'gb_strat_conc_ice', axes(1:3), Time, &
               'Grid-box-mean ice water content of stratiform clouds', &
               'grams/m3', missing_value=missing_value)   

          id_strat_size_ice = register_diag_field     &
              (mod_name, 'strat_size_ice', axes(1:3), Time, &
               'Effective diameter for stratiform ice clouds', &
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

          id_strat_droplet_number = register_diag_field     &
              (mod_name, 'strat_droplet_number', axes(1:3), Time, &
               'cloud droplet number for stratiform clouds', &
               '# per kg of air', missing_value=missing_value, &
               mask_variant = .true.)
     
          id_lsc_lwp = register_diag_field     &
              (mod_name, 'strat_lwp', axes(1:2), Time, &
               'In-cloud liquid water path of stratiform clouds', &
               'kg/m2', missing_value=missing_value,   &
               mask_variant = .true.)

!---------------------------------------------------------------------
!RSH:
!    added to provide backward compatibility to existing diag_tables.
!    here 'LWP' and 'strat_lwp' are identical; given a choice, please 
!    use 'strat_lwp' in the diag_table.
!---------------------------------------------------------------------
          if (id_lsc_lwp <= 0) then
            id_lsc_lwp = register_diag_field     &
                (mod_name, 'LWP', axes(1:2), Time, &
                 'In-cloud liquid water path of stratiform clouds', &
                 'kg/m2', missing_value=missing_value,   &
                 mask_variant = .true.)
          endif

          id_gb_lsc_lwp = register_diag_field     &
              (mod_name, 'gb_strat_lwp', axes(1:2), Time, &
               'Grid-box-mean liquid water path of stratiform clouds', &
               'kg/m2', missing_value=missing_value)      

          id_lsc_iwp = register_diag_field     &
              (mod_name, 'strat_iwp', axes(1:2), Time, &
               'In-cloud ice water path of stratiform clouds', &
               'kg/m2', missing_value=missing_value,   &
                mask_variant = .true.)

          id_gb_lsc_iwp = register_diag_field     &
              (mod_name, 'gb_strat_iwp', axes(1:2), Time, &
               'Grid-box-mean ice water path of stratiform clouds', &
               'kg/m2', missing_value=missing_value)      
        
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod', &
               'Cldrad_control%do_strat_clouds not yet defined', FATAL)
      endif ! (do_strat_clouds_iz)

!--------------------------------------------------------------------
!    register donner meso cloud microphysical properties
!--------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds_iz) then
        if (Cldrad_control%do_donner_deep_clouds) then
          id_meso_area_liq = register_diag_field     &
              (mod_name, 'meso_area_liq', axes(1:3), Time, &
               'Area of donner meso liquid clouds', &
               'fraction', missing_value=missing_value)

          id_meso_conc_drop = register_diag_field     &
              (mod_name, 'meso_conc_drop', axes(1:3), Time, &
              'In-cloud liq water content of donner meso clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_meso_conc_drop = register_diag_field     &
              (mod_name, 'gb_meso_conc_drop', axes(1:3), Time, &
               'Grid-box-mean liq water content of donner meso clouds',&
               'grams/m3', missing_value=missing_value)   
       
          id_meso_size_drop = register_diag_field     &
              (mod_name, 'meso_size_drop', axes(1:3), Time, &
               'Effective diameter for donner meso liquid clouds', &
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

          id_ra_meso_size_drop = register_diag_field     &
              (mod_name, 'ra_meso_size_drop', axes(1:3), Time, &
               'Adjusted Effective diam for donner meso liq clouds',&
               'microns', missing_value=missing_value ,  &
               mask_variant = .true.)

          id_meso_area_ice = register_diag_field     &
              (mod_name, 'meso_area_ice', axes(1:3), Time, &
               'Area of donner meso ice clouds', 'fraction',    &
               missing_value=missing_value)

          id_meso_conc_ice = register_diag_field     &
              (mod_name, 'meso_conc_ice', axes(1:3), Time, &
               'In-cloud ice water content of donner meso clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_meso_conc_ice = register_diag_field     &
              (mod_name, 'gb_meso_conc_ice', axes(1:3), Time, &
               'Grid-box-mean ice water content of donner meso clouds',&
               'grams/m3', missing_value=missing_value)

          id_meso_size_ice = register_diag_field     &
              (mod_name, 'meso_size_ice', axes(1:3), Time, &
               'Effective diameter for donner meso ice clouds', &
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

          id_meso_droplet_number = register_diag_field     &
              (mod_name, 'meso_droplet_number', axes(1:3), Time, &
               'Cloud droplet number for donner meso clouds', &
               '# per kg of air', missing_value=missing_value,   &
               mask_variant = .true.)
     
          id_meso_lwp = register_diag_field     &
              (mod_name, 'meso_lwp', axes(1:2), Time, &
               'In-cloud liquid water path of donner meso clouds', &
               'kg/m2', missing_value=missing_value,  &
               mask_variant = .true.)

          id_gb_meso_lwp = register_diag_field     &
              (mod_name, 'gb_meso_lwp', axes(1:2), Time, &
               'Grid-box-mean liquid water path of donner meso clouds',&
               'kg/m2', missing_value=missing_value)   

          id_meso_iwp = register_diag_field     &
              (mod_name, 'meso_iwp', axes(1:2), Time, &
               'In-cloud ice water path of donner meso clouds', &
               'kg/m2',  missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_meso_iwp = register_diag_field     &
              (mod_name, 'gb_meso_iwp', axes(1:2), Time, &
               'Grid-box-mean ice water path of donner meso clouds', &
               'kg/m2', missing_value=missing_value)   

!--------------------------------------------------------------------
!    register donner cell microphysical properties
!--------------------------------------------------------------------
          id_cell_area_liq = register_diag_field     &
              (mod_name, 'cell_area_liq', axes(1:3), Time, &
               'Area of donner cell liquid clouds', 'fraction',    &
               missing_value=missing_value)

          id_cell_conc_drop = register_diag_field     &
              (mod_name, 'cell_conc_drop', axes(1:3), Time, &
               'In-cloud liquid water content of donner cell clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_cell_conc_drop = register_diag_field     &
              (mod_name, 'gb_cell_conc_drop', axes(1:3), Time, &
               'Grid-box-mean liq water content of donner cell clouds',&
               'grams/m3', missing_value=missing_value)   

          id_cell_size_drop = register_diag_field     &
              (mod_name, 'cell_size_drop', axes(1:3), Time, &
               'Effective diameter for donner cell liquid clouds', &
               'microns', missing_value=missing_value ,   &
               mask_variant = .true. )

          id_ra_cell_size_drop = register_diag_field     &
              (mod_name, 'ra_cell_size_drop', axes(1:3), Time, &
               'Adjusted Effective diam for donner cell liq clouds',&
               'microns', missing_value=missing_value,  &
               mask_variant = .true.)

          id_cell_area_ice = register_diag_field     &
              (mod_name, 'cell_area_ice', axes(1:3), Time, &
               'Area of donner cell ice clouds',  'fraction',    &
               missing_value=missing_value)

          id_cell_conc_ice = register_diag_field     &
              (mod_name, 'cell_conc_ice', axes(1:3), Time, &
               'In-cloud ice water content of donner cell clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_cell_conc_ice = register_diag_field     &
              (mod_name, 'gb_cell_conc_ice', axes(1:3), Time, &
               'Grid-box-mean ice water content of donner cell clouds',&
               'grams/m3', missing_value=missing_value)

          id_cell_size_ice = register_diag_field     &
              (mod_name, 'cell_size_ice', axes(1:3), Time, &
               'Effective diameter for donner cell ice clouds', &
               'microns', missing_value=missing_value ,  &
               mask_variant = .true. )

          id_cell_droplet_number = register_diag_field     &
              (mod_name, 'cell_droplet_number', axes(1:3), Time, &
               'Cloud droplet number for donner cell clouds', &
               '# per kg of air', missing_value=missing_value,   &
               mask_variant = .true.)
     
          id_cell_lwp = register_diag_field     &
              (mod_name, 'cell_lwp', axes(1:2), Time, &
               'In-cloud liquid water path of donner cell clouds', &
               'kg/m2', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_cell_lwp = register_diag_field     &
              (mod_name, 'gb_cell_lwp', axes(1:2), Time, &
               'Grid-box-mean liquid water path of donner cell clouds',&
               'kg/m2', missing_value=missing_value)   

          id_cell_iwp = register_diag_field     &
              (mod_name, 'cell_iwp', axes(1:2), Time, &
               'In-cloud ice water path of donner cell clouds', &
               'kg/m2', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_cell_iwp = register_diag_field     &
              (mod_name, 'gb_cell_iwp', axes(1:2), Time, &
               'Grid-box-mean ice water path of donner cell clouds', &
               'kg/m2', missing_value=missing_value)   
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod', &
          'Cldrad_control%do_donner_deep_clouds not yet defined', FATAL)
      endif  ! (do_donner_deep_clouds_iz)
        
!--------------------------------------------------------------------
!    register uw shallow microphysical properties
!--------------------------------------------------------------------
      if (Cldrad_control%do_uw_clouds_iz) then
        if (Cldrad_control%do_uw_clouds) then
          id_shallow_area_liq = register_diag_field     &
              (mod_name, 'shallow_area_liq', axes(1:3), Time, &
               'Area of uw shallow  liquid clouds', 'fraction',    &
                missing_value=missing_value)

          id_shallow_conc_drop = register_diag_field     &
              (mod_name, 'shallow_conc_drop', axes(1:3), Time, &
               'In-cloud liquid water content of uw shallow  clouds', &
               'grams/m3', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_shallow_conc_drop = register_diag_field     &
              (mod_name, 'gb_shallow_conc_drop', axes(1:3), Time, &
               'Grid-box-mean liq water content of uw shallow clouds', &
               'grams/m3', missing_value=missing_value)   

          id_shallow_size_drop = register_diag_field     &
              (mod_name, 'shallow_size_drop', axes(1:3), Time, &
               'Effective diameter for uw shallow liquid clouds', &
               'microns', missing_value=missing_value ,  &
               mask_variant = .true.)

          id_ra_shallow_size_drop = register_diag_field     &
              (mod_name, 'ra_shallow_size_drop', axes(1:3), Time, &
               'Adjusted Effective diam for uw shallow  liq clouds',&
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

          id_shallow_area_ice = register_diag_field     &
              (mod_name, 'shallow_area_ice', axes(1:3), Time, &
               'Area of uw shallow  ice clouds', 'fraction',    &
               missing_value=missing_value)

          id_shallow_conc_ice = register_diag_field     &
              (mod_name, 'shallow_conc_ice', axes(1:3), Time, &
               'In-cloud ice water content of uw shallow  clouds', &
               'grams/m3', missing_value=missing_value,  &
               mask_variant = .true.)

          id_gb_shallow_conc_ice = register_diag_field     &
              (mod_name, 'gb_shallow_conc_ice', axes(1:3), Time, &
               'Grid-box-mean ice water content of uw shallow clouds', &
               'grams/m3', missing_value=missing_value)

          id_shallow_size_ice = register_diag_field     &
              (mod_name, 'shallow_size_ice', axes(1:3), Time, &
               'Effective diameter for uw shallow  ice clouds', &
               'microns', missing_value=missing_value ,  &
               mask_variant = .true. )

          id_shallow_droplet_number = register_diag_field     &
              (mod_name, 'shallow_droplet_number', axes(1:3), Time, &
               'Cloud droplet number for uw shallow  clouds', &
               '# per kg of air', missing_value=missing_value,   &
               mask_variant = .true.)
     
          id_shallow_lwp = register_diag_field     &
              (mod_name, 'shallow_lwp', axes(1:2), Time, &
               'In-cloud liquid water path of uw shallow  clouds', &
               'kg/m2', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_shallow_lwp = register_diag_field     &
              (mod_name, 'gb_shallow_lwp', axes(1:2), Time, &
               'Grid-box-mean liquid water path of uw shallow clouds', &
               'kg/m2', missing_value=missing_value)   

          id_shallow_iwp = register_diag_field     &
              (mod_name, 'shallow_iwp', axes(1:2), Time, &
               'In-cloud ice water path of uw shallow  clouds', &
               'kg/m2', missing_value=missing_value,   &
               mask_variant = .true.)

          id_gb_shallow_iwp = register_diag_field     &
              (mod_name, 'gb_shallow_iwp', axes(1:2), Time, &
               'Grid-box-mean ice water path of uw shallow  clouds', &
               'kg/m2', missing_value=missing_value)   
        endif
      else
        call error_mesg ('cloudrad_diagnostics_mod', &
          'Cldrad_control%do_uw_clouds not yet defined', FATAL)
      endif  ! (do_uw_clouds_iz)

!---------------------------------------------------------------------
!
!    DIAGNOSTICS RELATED TO STOCHASTIC CLOUD PARAMETERIZATION
!
!---------------------------------------------------------------------
      if (Cldrad_control%do_stochastic_clouds_iz) then
        if (Cldrad_control%do_stochastic_clouds) then

!--------------------------------------------------------------------
!    the following diagnostics output the fields actually seen by the 
!    radiation code (either lsc or donner meso or donner cell or 
!    uw shallow in a given stochastic column, assuming all are 
!    activated), determined by the stochastic selection process.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    total cloud fraction summed across the stochastic subcolumns
!--------------------------------------------------------------------
          id_cldfrac_tot = register_diag_field  &
            (mod_name, 'stoch_cld_tot', axes(1:2), Time, &
             'total projected cloud fraction - stochastic clouds',&
             'fraction', missing_value=missing_value)

!--------------------------------------------------------------------
!     3d cloud fraction 
!--------------------------------------------------------------------
          id_cldfrac_ave = register_diag_field  &
            (mod_name, 'stoch_cld_ave', axes(1:3), Time, &
             'avg cloud fraction - stochastic clouds', &
             'fraction', missing_value=missing_value)

!--------------------------------------------------------------------
!     ice and water content and paths
!--------------------------------------------------------------------
          id_ice_conc_ave = register_diag_field  &
            (mod_name, 'stoch_ice_conc_ave', axes(1:3), Time, &
             'grid box avg ice water content - stochastic clouds', &
             'g/m3', missing_value=missing_value)

          id_ic_ice_conc_ave = register_diag_field  &
            (mod_name, 'stoch_incloud_ice_conc_ave', axes(1:3), Time, &
             'cloudy column avg ice water content - stochastic clouds',&
             'g/m3', missing_value=missing_value, mask_variant=.true.)

          id_drop_conc_ave = register_diag_field  &
            (mod_name, 'stoch_drop_conc_ave', axes(1:3), Time, &
             'grid box avg liquid water content - stochastic clouds', &
             'g/m3', missing_value=missing_value)

          id_ic_drop_conc_ave = register_diag_field  &
            (mod_name, 'stoch_incloud_drop_conc_ave', axes(1:3), Time, &
             'cloudy column avg liq water content - stochastic clouds',&
             'g/m3', missing_value=missing_value, mask_variant = .true.)

          id_lwp_ave = register_diag_field  &
            (mod_name, 'stoch_lwp_ave', axes(1:2), Time, &
             'grid box avg liq water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_ic_lwp_ave = register_diag_field  &
            (mod_name, 'stoch_incloud_lwp_ave', axes(1:2), Time, &
             'cloudy column avg liq water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value, mask_variant=.true.)

          id_iwp_ave = register_diag_field  &
            (mod_name, 'stoch_iwp_ave', axes(1:2), Time, &
             'grid box avg ice water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_ic_iwp_ave = register_diag_field  &
            (mod_name, 'stoch_incloud_iwp_ave', axes(1:2), Time, &
             'cloudy column avg ice water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value, mask_variant=.true.)

          id_LWPr = register_diag_field    &
             (mod_name, 'LWPr', axes(1:2), Time, &  
              'LWPr', 'kg m-2 micron-1')

!--------------------------------------------------------------------
!     ice and water cloud frequency distribution
!--------------------------------------------------------------------
          id_ice_col_frac_ave = register_diag_field  &
            (mod_name, 'stoch_ice_col_frac_ave', axes(1:3), Time, &
             'frctn of columns with ice clouds - stochastic clouds', &
             'fraction', missing_value=missing_value,   &
             mask_variant = .true.)

          id_liq_col_frac_ave = register_diag_field  &
            (mod_name, 'stoch_liq_col_frac_ave', axes(1:3), Time, &
             'frctn of columns with liq clouds - stochastic clouds', &
             'fraction', missing_value=missing_value, &
             mask_variant = .true.)

!--------------------------------------------------------------------
!     crystal and droplet sizes and number
!--------------------------------------------------------------------
          id_ice_size_ave = register_diag_field  &
            (mod_name, 'stoch_ice_size_ave', axes(1:3), Time, &
             'cloudy column avg ice eff diam - stochastic clouds', &
             'microns', missing_value=missing_value, &
             mask_variant = .true.)

          id_drop_size_ave = register_diag_field  &
            (mod_name, 'stoch_drop_size_ave', axes(1:3), Time, &
             'cloudy column avg droplet diam - stochastic clouds', &
             'microns', missing_value=missing_value,  &
             mask_variant = .true.)

          id_ra_drop_size_ave = register_diag_field  &
            (mod_name, 'ra_stoch_drop_size_ave', axes(1:3), Time, &
             'adjustd cloudy column avg drop diam - stochastic clouds',&
             'microns', missing_value=missing_value,  &
             mask_variant = .true. )

          id_droplet_number_ave = register_diag_field  &
            (mod_name, 'stoch_droplet_number_ave', axes(1:3), Time, &
             'cloudy column avg droplet number - stochastic clouds', &
             '#/kg(air)', missing_value=missing_value,  &
             mask_variant = .true. )
      
!--------------------------------------------------------------------
!    the following fields are the contributions from each of the 
!    cloud types to the fields actually seen by the radiation package.
!--------------------------------------------------------------------
          id_lsc_drop_conc_ave = register_diag_field  &
            (mod_name, 'stoch_lsc_drop_conc_ave', axes(1:3), Time, &
             'grid box avg lsc liq water content - stochastic clouds', &
             'g/m3', missing_value=missing_value)

          id_lsc_ice_conc_ave = register_diag_field  &
            (mod_name, 'stoch_lsc_ice_conc_ave', axes(1:3), Time, &
             'grid box avg lsc ice water content - stochastic clouds', &
             'g/m3', missing_value=missing_value)

          id_lsc_lwp_ave = register_diag_field  &
            (mod_name, 'stoch_lsc_lwp_ave', axes(1:2), Time, &
             'grid box avg lsc liq water path  - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_lsc_iwp_ave = register_diag_field  &
            (mod_name, 'stoch_lsc_iwp_ave', axes(1:2), Time, &
             'grid box avg lsc ice water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_cell_drop_conc_ave = register_diag_field  &
            (mod_name, 'stoch_cell_drop_conc_ave', axes(1:3), Time, &
             'grid box avg cell liq water content - stochastic clouds',&
             'g/m3', missing_value=missing_value)

          id_cell_ice_conc_ave = register_diag_field  &
            (mod_name, 'stoch_cell_ice_conc_ave', axes(1:3), Time, &
             'grid box avg cell ice water content - stochastic clouds',&
             'g/m3', missing_value=missing_value)

          id_cell_lwp_ave = register_diag_field  &
            (mod_name, 'stoch_cell_lwp_ave', axes(1:2), Time, &
             'grid box avg cell liq water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_cell_iwp_ave = register_diag_field  &
            (mod_name, 'stoch_cell_iwp_ave', axes(1:2), Time, &
             'grid box avg cell ice water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_meso_drop_conc_ave = register_diag_field  &
            (mod_name, 'stoch_meso_drop_conc_ave', axes(1:3), Time, &
             'grid box avg meso liq water content - stochastic clouds',&
             'g/m3', missing_value=missing_value)

          id_meso_ice_conc_ave = register_diag_field  &
            (mod_name, 'stoch_meso_ice_conc_ave', axes(1:3), Time, &
             'grid box avg meso ice water content - stochastic clouds',&
             'g/m3', missing_value=missing_value)

          id_meso_lwp_ave = register_diag_field  &
            (mod_name, 'stoch_meso_lwp_ave', axes(1:2), Time, &
             'grid box avg meso liq water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_meso_iwp_ave = register_diag_field  &
            (mod_name, 'stoch_meso_iwp_ave', axes(1:2), Time, &
             'grid box avg meso ice water path - stochastic clouds', &
             'kg/m2', missing_value=missing_value)

          id_shallow_drop_conc_ave = register_diag_field  &
            (mod_name, 'stoch_shallow_drop_conc_ave', axes(1:3), Time, &
             'grid box avg shallow liq water content - stoch clouds', &
             'g/m3', missing_value=missing_value)

          id_shallow_ice_conc_ave = register_diag_field  &
            (mod_name, 'stoch_shallow_ice_conc_ave', axes(1:3), Time, &
             'grid box avg shallow ice water content - stoch clouds', &
             'g/m3', missing_value=missing_value)

          id_shallow_lwp_ave = register_diag_field  &
            (mod_name, 'stoch_shallow_lwp_ave', axes(1:2), Time, &
             'grid box avg shallow liq water path - stochastic clouds',&
             'kg/m2', missing_value=missing_value)

          id_shallow_iwp_ave = register_diag_field  &
            (mod_name, 'stoch_shallow_iwp_ave', axes(1:2), Time, &
             'grid box avg shallow ice water path - stochastic clouds',&
             'kg/m2', missing_value=missing_value)

!--------------------------------------------------------------------
!    the following fields wouild be obtained if the stochastic cloud
!    treatment was limited to just the strat_cloud component. the
!    difference between these '_only_lsc' variables and the '_ave' 
!    variables just above reflects the effect of treating the other
!    cloud types stochastically.
!--------------------------------------------------------------------


!--------------------------------------------------------------------
!     3d cloud fraction 
!--------------------------------------------------------------------
          id_cldfrac_only_lsc = register_diag_field  &
            (mod_name, 'stoch_cld_only_lsc', axes(1:3), Time, &
             'avg cld fraction, only lsc stochastic', &
             'fraction', missing_value=missing_value)

!--------------------------------------------------------------------
!     ice and water content and paths.
!--------------------------------------------------------------------
          id_ice_conc_only_lsc = register_diag_field  &
            (mod_name, 'stoch_ice_conc_only_lsc', axes(1:3), Time, &
             'grid box avg ice water content, only lsc stochastic', &
             'g/m3', missing_value=missing_value)

          id_ic_ice_conc_only_lsc = register_diag_field  &
            (mod_name, 'stoch_incloud_ice_conc_only_lsc', axes(1:3), &
             Time, &
             'cldy column avg ice water content, only lsc stochastic',&
             'g/m3', missing_value=missing_value, mask_variant = .true.)

          id_drop_conc_only_lsc = register_diag_field  &
            (mod_name, 'stoch_drop_conc_only_lsc', axes(1:3), Time, &
             'grid box avg liq water content, only lsc stochastic', &
             'g/m3', missing_value=missing_value)

          id_ic_drop_conc_only_lsc = register_diag_field  &
            (mod_name, 'stoch_incloud_drop_conc_only_lsc', axes(1:3), &
             Time, &
             'cldy column avg liq water content, only lsc stochastic', &
             'g/m3', missing_value=missing_value, mask_variant = .true.)

          id_lwp_only_lsc = register_diag_field  &
            (mod_name, 'stoch_lwp_only_lsc', axes(1:2), Time, &
             'grid box avg liq water path, only lsc stochastic', &
             'kg/m2', missing_value=missing_value)

          id_ic_lwp_only_lsc = register_diag_field  &
            (mod_name, 'stoch_incloud_lwp_only_lsc', axes(1:2), Time, &
             'in-cloud avg liq water path, only lsc stochastic', &
             'kg/m2', missing_value=missing_value,   &
             mask_variant = .true.)

          id_iwp_only_lsc = register_diag_field  &
            (mod_name, 'stoch_iwp_only_lsc', axes(1:2), Time, &
             'grid box avg ice water path, only lsc stochastic', &
             'kg/m2', missing_value=missing_value)

          id_ic_iwp_only_lsc = register_diag_field  &
            (mod_name, 'stoch_incloud_iwp_only_lsc', axes(1:2), Time, &
             'in-cloud avg ice water path, only lsc stochastic', &
             'kg/m2', missing_value=missing_value,   &
             mask_variant = .true.)

!--------------------------------------------------------------------
!     ice and water cloud distributions
!--------------------------------------------------------------------
          id_ice_col_only_lsc = register_diag_field  &
            (mod_name, 'stoch_ice_col_frac_only_lsc', axes(1:3), Time, &
             'frctn of columns with ice clouds, only lsc stochastic',&
             'fraction', missing_value=missing_value,   &
             mask_variant=.true.)

          id_liq_col_only_lsc = register_diag_field  &
            (mod_name, 'stoch_liq_col_frac_only_lsc', axes(1:3), Time, &
             'frctn of columns with liq clouds, only lsc stochastic',&
             'fraction', missing_value=missing_value, &
             mask_variant = .true.)

!--------------------------------------------------------------------
!     crystal and droplet sizes and number
!--------------------------------------------------------------------
          id_ice_size_only_lsc = register_diag_field  &
            (mod_name, 'stoch_ice_size_only_lsc', axes(1:3), Time, &
             'cloudy column avg ice eff diam, only lsc stochastic', &
             'microns', missing_value=missing_value, &
             mask_variant = .true.)

          id_drop_size_only_lsc = register_diag_field  &
            (mod_name, 'stoch_drop_size_only_lsc', axes(1:3), Time, &
             'cloudy column avg drop diam, only lsc stochastic', &
             'microns', missing_value=missing_value,  &
             mask_variant = .true.)

          id_ra_drop_size_only_lsc = register_diag_field  &
            (mod_name, 'ra_stoch_drop_size_only_lsc', axes(1:3), Time, &
             'adjustd cldy column avg drop diam, only lsc stochastic', &
            'microns', missing_value=missing_value,  &
            mask_variant = .true.)

          id_droplet_number_only_lsc = register_diag_field  &
            (mod_name, 'stoch_droplet_number_only_lsc', axes(1:3),   &
             Time,&
             'liq cldy column avg droplet number, only lsc stochastic',&
             '#/kg(air)', missing_value=missing_value,  &
             mask_variant = .true.)

!--------------------------------------------------------------------
!    diagnostics relative to the frequency that the radiation code sees
!    lsc cloud properties.
!--------------------------------------------------------------------
          id_stoch_ic_lsc_cf_ave = register_diag_field  &
            (mod_name, 'stoch_ic_lsc_cf_ave', axes(1:3), Time, &
             'fractn of cols in cloudy grid boxes with lsc props', &
             'fraction', missing_value=missing_value,  &
             mask_variant = .true.)


          id_stoch_sees_lsc = register_diag_field  &
            (mod_name, 'stoch_sees_lsc', axes(1:3), Time, &
             'fraction of times lsc clds are used when present',&
             'fraction', missing_value=missing_value,  &
             mask_variant = .true.)
       
          id_stoch_lsc_cf_ave = register_diag_field  &
            (mod_name, 'stoch_lsc_cf_ave', axes(1:3), Time, &
             'fraction of stochastic columns assigned lsc props',&
             'fraction', missing_value=missing_value)

!--------------------------------------------------------------------
!    the following fields are only valid if the donner parameterization
!    is active.
!--------------------------------------------------------------------
          if (Cldrad_control%do_donner_deep_clouds_iz) then
            if (Cldrad_control%do_donner_deep_clouds) then

!--------------------------------------------------------------------
!    diagnostics relative to the frequency that the radiation code sees
!    donner meso and cell cloud properties.
!--------------------------------------------------------------------
              id_stoch_ic_cell_cf_ave = register_diag_field  &
                (mod_name, 'stoch_ic_cell_cf_ave', axes(1:3), Time, &
                'fractn of cols in cloudy grid boxes with cell props', &
                'fraction', missing_value=missing_value,  &
                mask_variant = .true.)

              id_stoch_ic_meso_cf_ave = register_diag_field  &
                (mod_name, 'stoch_ic_meso_cf_ave', axes(1:3), Time, &
                'fractn of cols in cloudy grid boxes with meso props', &
                'fraction', missing_value=missing_value,   &
                mask_variant = .true.)

              id_stoch_sees_cell = register_diag_field  &
                (mod_name, 'stoch_sees_cell', axes(1:3), Time, &
                 'fraction of times cell clds are seen when present', &
                 'fraction', missing_value=missing_value,  &
                 mask_variant = .true.)

              id_stoch_sees_meso = register_diag_field  &
                (mod_name, 'stoch_sees_meso', axes(1:3), Time, &
                 'fraction of times meso clds are seen when present', &
                 'fraction', missing_value=missing_value,   &
                 mask_variant = .true.)

              id_stoch_cell_cf_ave = register_diag_field  &
                (mod_name, 'stoch_cell_cf_ave', axes(1:3), Time, &
                 'fraction of stochastic columns assigned cell props',&
                 'fraction', missing_value=missing_value)

              id_stoch_meso_cf_ave = register_diag_field  &
                (mod_name, 'stoch_meso_cf_ave', axes(1:3), Time, &
                 ' fraction of stochastic columns assigned meso props',&
                 'fraction', missing_value=missing_value)
            endif
          else
            call error_mesg ('cloudrad_diagnostics_mod', &
              'Cldrad_control%do_donner_deep_clouds not yet defined', &
                                                                 FATAL)
          endif

!--------------------------------------------------------------------
!    the following fields are only valid if the uw shallow parameter-
!    ization is active.
!--------------------------------------------------------------------
          if (Cldrad_control%do_uw_clouds_iz) then
            if (Cldrad_control%do_uw_clouds) then
!--------------------------------------------------------------------
!    diagnostics indicating frequency that radiation code sees lsc, 
!    meso, cell and uw shallow clouds, and the frequency that these 
!    cloud types are seen when they exist.
!--------------------------------------------------------------------
              id_stoch_ic_shallow_cf_ave = register_diag_field  &
                (mod_name, 'stoch_ic_shallow_cf_ave', axes(1:3), Time, &
                 'frctn of cols in cldy grid boxes with shallow props',&
                 'fraction', missing_value=missing_value,  &
                 mask_variant = .true.)

              id_stoch_sees_shallow = register_diag_field  &
                (mod_name, 'stoch_sees_shallow', axes(1:3), Time, &
                 'frctn of times shallow clds are seen when present', &
                 'fraction', missing_value=missing_value,  &
                 mask_variant = .true.)

              id_stoch_shallow_cf_ave = register_diag_field  &
                (mod_name, 'stoch_shallow_cf_ave', axes(1:3), Time, &
                 'frctn of stoch columns assigned uw shallow props',&
                 'fraction', missing_value=missing_value)
            endif
          else
            call error_mesg ('cloudrad_diagnostics_mod', &
               'Cldrad_control%do_uw_clouds not yet defined', FATAL)
          endif

!---------------------------------------------------------------------
!    cloud property diagnostics for each stochastic sub-column
!---------------------------------------------------------------------
          do n=1, ncol                                          
            if (n < 10) then
              write (chvers,'(i1)') n 
            else if (n <100) then
              write (chvers,'(i2)') n 
            else
              call error_mesg ('cloudrad_diagnostics_mod', &
                'must modify code to allow writing of more than&
                 & 99 stochastic columns', FATAL)
            endif

!---------------------------------------------------------------------
!    cloud type diagnostic : 0 = no cloud, 1 = lsc, 2 = meso, 3 = cell
!                            4 = uw shallow
!----------------------------------------------------------------------
            id_stoch_cloud_type(n) = register_diag_field  &
                (mod_name, 'stoch_cloud_type_'//trim(chvers),  &
                 axes(1:3), Time, &
                 'cloud type (1-4) in stochastic col  '//trim(chvers), &
                 'none', missing_value=missing_value,   &
                 mask_variant = .true.)
 
!--------------------------------------------------------------------
!
!
!              STOCHASTIC COLUMN VALUES, "_ONLY_LSC" DIAGNOSTICS
!
!
!--------------------------------------------------------------------
!    these "_only_lsc" diagnostics allow one to assess the effect of
!    treating the non-lsc clouds stochastically. the difference between
!    the "_only_lsc" variables and the corresponding "_ave" variables
!    reflect the changes resulting from treating the non-lsc cloud
!    types stochastically. the cloud properties actually seen by the
!    model's radiation package are always contained in the "_ave" 
!    diagnostics.
!--------------------------------------------------------------------
            id_cldfrac_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_cld_col_only_lsc_'//trim(chvers),  &
               axes(1:3), Time, &
               'cloud fraction in column ' //trim(chvers) // &
                     ' when only lsc clouds treated stochastically ', &
               'fraction', missing_value=missing_value)
          
!----------------------------------------------------------------------
!    lsc ice and liquid water content and paths, and  droplet number 
!----------------------------------------------------------------------
            id_ice_conc_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_ice_conc_col_only_lsc_'//trim(chvers), &
               axes(1:3), Time, &
               'ice content in column '//trim(chvers)  // &
                    ' when only lsc clouds treated stochastically', &
               'g/m3', missing_value=missing_value)

            id_drop_conc_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_drop_conc_col_only_lsc_'//trim(chvers),&
               axes(1:3), Time, &
               'liq water content in stoch column '//trim(chvers) // &
                      ' when only lsc clouds treated stochastically', &
               'g/m3', missing_value=missing_value)

            id_droplet_number_cols_only_lsc(n) = register_diag_field  &
              (mod_name,    &
               'stoch_droplet_number_col_only_lsc_'//trim(chvers),&
               axes(1:3), Time, &
               ' droplet number in stochastic column '//trim(chvers) //&
                  ' when only lsc clouds are treated stochastically', &
               '#/kg(air)', missing_value=missing_value,  &
               mask_variant = .true.)

            id_iwp_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_iwp_col_only_lsc_'//trim(chvers),  &
               axes(1:2), Time, &
               'ice water path in stochastic column '//trim(chvers) // &
                     ' when only lsc clouds treated stochastically',&
               'kg/m2', missing_value=missing_value)

            id_lwp_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_lwp_col_only_lsc_'//trim(chvers),  &
               axes(1:2), Time, &
               'liq water path in stochastic column '//trim(chvers) // &
                    ' when only lsc clouds treated stochastically',&
               'kg/m2', missing_value=missing_value)      
  
!----------------------------------------------------------------------
!   lsc ice particle size, liquid droplet size from microphysics and as
!   adjusted for use by radiative routines 
!----------------------------------------------------------------------
            id_ice_size_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_ice_size_col_only_lsc_'//trim(chvers), &
               axes(1:3), Time, &
               'ice eff diam in stochastic column '//trim(chvers) // &
                     ' when only lsc clouds treated stochastically', &
               'microns', missing_value=missing_value, &
               mask_variant = .true.)

            id_drop_size_cols_only_lsc(n) = register_diag_field  &
              (mod_name, 'stoch_drop_size_col_only_lsc_'//trim(chvers),&
               axes(1:3), Time, &
               'droplet diam in stochastic column '//trim(chvers) // &
                     ' when only lsc clouds treated stochastically', &
               'microns', missing_value=missing_value,  &
               mask_variant = .true.)

            id_ra_drop_size_cols_only_lsc(n) = register_diag_field  &
              (mod_name,   &
               'ra_stoch_drop_size_col_only_lsc_'//trim(chvers),  &
               axes(1:3), Time, &
               'adjustd drop diam in stoch column '//trim(chvers)// &
                      ' when only lsc clouds treated stochastically', &
               'microns', missing_value=missing_value,  &
               mask_variant = .true.)
 
!--------------------------------------------------------------------
!
!
!           STOCHASTIC COLUMN VALUES, AS SEEN BY RADIATION PACKAGE
!
!
!--------------------------------------------------------------------
!    the following diagnostics show the cloud properties seen by the
!    radiation package for each of the stochastic columns. 
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    cloud fraction in column that is seen by radiation code 
!----------------------------------------------------------------------
            id_cldfrac_cols(n) = register_diag_field  &
              (mod_name, 'stoch_cld_col_'//trim(chvers),   &
               axes(1:3), Time,&
               'cloud fraction in stochastic column '//trim(chvers), &
               'fraction', missing_value=missing_value)
          
!----------------------------------------------------------------------
!    ice and liquid water content and paths, and  droplet number 
!    as seen by radiation code.
!----------------------------------------------------------------------
            id_ice_conc_cols(n) = register_diag_field  &
              (mod_name, 'stoch_ice_conc_col_'//trim(chvers),  &
               axes(1:3), Time, &
               'ice content in stochastic column '//trim(chvers), &
               'g/m3', missing_value=missing_value)

            id_drop_conc_cols(n) = register_diag_field  &
              (mod_name, 'stoch_drop_conc_col_'//trim(chvers), &
               axes(1:3), Time, &
               'water content in stochastic column '//trim(chvers), &
               'g/m3', missing_value=missing_value)
     
            id_iwp_cols(n) = register_diag_field  &
              (mod_name, 'stoch_iwp_col_'//trim(chvers), &
               axes(1:2), Time, &
               'ice water path in stochastic column '//trim(chvers), &
               'kg/m2', missing_value=missing_value)

            id_lwp_cols(n) = register_diag_field  &
              (mod_name, 'stoch_lwp_col_'//trim(chvers),  &
               axes(1:2), Time, &
               'liq water path in stochastic column '//trim(chvers), &
               'kg/m2', missing_value=missing_value)

            id_droplet_number_cols(n) = register_diag_field  &
              (mod_name, 'stoch_droplet_number_col_'//trim(chvers), &
               axes(1:3), Time, &
               'droplet number in stochastic column '//trim(chvers), &
               '#/kg(air)', missing_value=missing_value,   &
               mask_variant = .true.)

!----------------------------------------------------------------------
!    ice particle size, liquid droplet size from microphysics and as
!    adjusted for use by radiative routines 
!    (as seen by radiation code)
!----------------------------------------------------------------------
            id_ice_size_cols(n) = register_diag_field  &
              (mod_name, 'stoch_ice_size_col_'//trim(chvers), &
               axes(1:3), Time, &
               'ice particle eff diam in stoch column '//trim(chvers), &
               'microns', missing_value=missing_value,   &
               mask_variant = .true.)

            id_drop_size_cols(n) = register_diag_field  &
              (mod_name, 'stoch_drop_size_col_'//trim(chvers), &
               axes(1:3), Time, &
               'droplet diameter in stochastic column '//trim(chvers), &
               'microns', missing_value=missing_value,  &
               mask_variant = .true.)

            id_ra_drop_size_cols(n) = register_diag_field  &
              (mod_name, 'ra_stoch_drop_size_col_'//trim(chvers), &
               axes(1:3), Time, &
               'adjustd droplet diam in stoch column '//trim(chvers), &
               'microns', missing_value=missing_value,  &
               mask_variant = .true.)

          end do
        endif ! (do_stochastic_clouds)
      else
        call error_mesg ('cloudrad_diagnostics_mod', &
          'Cldrad_control%do_stochastic_clouds not yet defined', FATAL)
      endif ! (do_stochastic_clouds_iz)

!---------------------------------------------------------------------

 
end subroutine diag_field_init



!#####################################################################
! <SUBROUTINE NAME="isccp_diag">
!  <OVERVIEW>
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_diag (is, js, Cld_spec, Atmos_input, coszen, Time)
!  </TEMPLATE>
!  <IN NAME="is,js" TYPE="integer">
!   starting subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   time on next timestep, used as stamp for 
!                        diagnostic output [ time_type (days, seconds) ]
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    atmospheric input fields on model grid,
!  </IN>
!  <IN NAME="coszen" TYPE="real">
!    cosine of solar zenith angle
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </IN>
!  <IN NAME="Lsctau" TYPE="real">
!   cloud optical thickness in the visible
!  </IN>
!  <IN NAME="Lsclwem" TYPE="real">
!   10 micron cloud emissivity
!  </IN>
! </SUBROUTINE>
!
subroutine isccp_diag (is, js, Cld_spec, Atmos_input, coszen,       &
                       Lsctau, Lsclwem, Time)

!--------------------------------------------------------------------
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!---------------------------------------------------------------------
 
integer,                      intent(in)   :: is,js
type(cld_specification_type), intent(in)   :: Cld_spec
type(atmos_input_type),       intent(in)   :: Atmos_input
real, dimension(:,:),         intent(in)   :: coszen
real, dimension(:,:,:),       intent(in)   :: Lsctau, Lsclwem
type(time_type),              intent(in)   :: Time

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,js           starting/ending subdomain i,j indices of data 
!                      in the physics_window being integrated
!      Cld_spec        cloud specification properties on model grid,
!                      [ cld_specification_type ]
!      Atmos_input     atmospheric input fields on model grid,
!                      [ atmos_input_type ] 
!      coszen          cosine of zenith angle [ dimensionless ]
!      Lsctau          0.6-0.685 micron cloud optical thickness 
!                      [ dimensionless ]
!      Lsclwem         Longwave emissivity [ dimensionless ]
!                      This is from 10.1-11.1 microns if the multiband 
!                      longwave emissivity is active.
!      Time            time on next timestep, used as stamp for 
!                      diagnostic output [ time_type (days, seconds) ]
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      real, dimension (size(Cld_spec%lwp,1), size(Cld_spec%lwp,2), &
                       size(Cld_spec%lwp,3)) :: &
                                    tau_local, em_local, cldamt_local

      real, dimension (size(Cld_spec%lwp,1), size(Cld_spec%lwp,2), &
                       size(Cld_spec%lwp,3) ) ::  qv, em_lw_local




      real, dimension (size(Cld_spec%lwp,1), size(Cld_spec%lwp,2), &
                       size(Cld_spec%lwp,3), 4 ) ::  tau

      real, dimension (size(Cld_spec%lwp,1), size(Cld_spec%lwp,2), &
                      7, 7) ::       fq_isccp

      real, dimension (size(Cld_spec%lwp,1), size(Cld_spec%lwp,2)) :: &
                          npoints, ninhomog, inhomogeneity_parameter

      integer      :: kdim
      integer      :: max_cld
      integer      :: i, j, k
      integer, dimension(size(Cld_spec%lwp,1),size(Cld_spec%lwp,2)):: &
                        sunlit
      
!---------------------------------------------------------------------
!   local variables:
!
!      tau_local        optical depth in band 1 in the current column
!                       [ dimensionless ]
!      em_local         lw cloud emissivity in current column
!                       [ dimensionless ]
!      cldamt_local     cloud fraction in current column 
!                       [ dimensionless ]
!      qv               water vapor specific humidity
!                       [ kg vapor / kg air ]
!      em_lw_local      lw cloud emissivity [ dimensionless ]
!      rh2o             mixing ratio of water vapor at model full levels
!                       [ non-dimensional ]
!      temp             temperature at model levels (1:nlev), surface
!                       temperature is stored at value nlev+1; if eta
!                       coordinates, surface value stored in below 
!                       ground points
!                       [ deg K ]
!      tau              optical depth in 4 bands [ dimensionless ]
!      fq_isccp         matrix of fractional area covered by cloud
!                       types of a given optical depth and cloud
!                       top pressure range.  The matrix is 7x7 for
!                       7 cloud optical depths and 7 cloud top 
!                       pressure ranges
!      npoints          flag indicating whether isccp cloud is present
!                       in column (cloud + daylight needed)
!      kdim             number of model layers
!      max_cld          greatest number of clouds in any column in the
!                       current physics window
!      i,j,k            do-loop indices
!     
!      sunlit           is the given i,j point sunlit?
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!    define number of model layers.
!----------------------------------------------------------------------
      kdim = size (Cld_spec%lwp,3)
        
!---------------------------------------------------------------------
!    If optical properties are needed and no clouds exist in the 
!    window, call cloud_optical_properties_diag to define the cloud 
!    optical depth, the optical depth due to cloud ice and the 
!    longwave emissivity. If no clouds exist in the window, all the 
!    optical depths and emissivities are left are their initial
!    values of zero.to zero.
!---------------------------------------------------------------------
     
     em_lw_local = 0.
     tau = 0.

     max_cld = MAXVAL(Cld_spec%ncldsw(:,:))
     if (max_cld >= 1 .and. .not.isccp_actual_radprops)          &
       call cloud_optical_properties_diag (Cld_spec, tau, em_lw_local)

!---------------------------------------------------------------------
!    Initialize fields
!---------------------------------------------------------------------

           npoints(:,:) = 0.
           fq_isccp(:,:,:,:) = 0.
           ninhomog(:,:) = 0.
           inhomogeneity_parameter(:,:) = 0.

!---------------------------------------------------------------------
!    Compute sunlit integer flag
!---------------------------------------------------------------------
           sunlit(:,:) = 0
           where(coszen(:,:) > 1.E-06) sunlit(:,:) = 1

!--------------------------------------------------------------------
!    define the specific humidity from the mixing ratio which has been
!    input.
!--------------------------------------------------------------------
                  qv(:,:,:) = Atmos_input%cloudvapor(:,:,:)/   &
                              (1. + Atmos_input%cloudvapor(:,:,:))
                
!---------------------------------------------------------------------
!    define the column values of cloud fraction, cloud optical depth, 
!    and lw cloud emissivity. if cloud is not present, set these var-
!    iables to clear sky values.
!---------------------------------------------------------------------
           do j=1,size(Cld_spec%lwp,2)
            do i=1,size(Cld_spec%lwp,1)
             do k=1,kdim                      

                  if (Cld_spec%camtsw(i,j,k) > 0.0) then
                    cldamt_local(i,j,k) = Cld_spec%camtsw(i,j,k) 
                    if (isccp_actual_radprops) then
                      tau_local(i,j,k) = Lsctau(i,j,k)
                      em_local(i,j,k) = Lsclwem(i,j,k)
                    else 
                      tau_local(i,j,k) = tau(i,j,k,1)/ &
                                 real(Cld_spec%cld_thickness(i,j,k))
                      em_local(i,j,k) = 1.-((1.-em_lw_local(i,j,k))** &
                             (1./real(Cld_spec%cld_thickness(i,j,k))) )
                    end if          
                  else
                    cldamt_local(i,j,k) = 0.
                    tau_local(i,j,k) = 0.
                    em_local(i,j,k) = 0.
                  endif
                  
                end do
               end do
              end do
               
!---------------------------------------------------------------------
!    call isccp_cloudtypes to map each model cloud to an isccp cloud
!    type, based on its optical depth and height above the surface.
!    set a flag to indicate the presence of isccp cloud in this column.
!---------------------------------------------------------------------
                call isccp_cloudtypes (sunlit(:,:), &
                                       Atmos_input%press(:,:,1:kdim), &
                                       Atmos_input%pflux(:,:,:),&
                                       qv(:,:,:),       &
                                       Atmos_input%cloudtemp(:,:,:),  &
                                       Atmos_input%temp(:,:,kdim+1),  &
                                       cldamt_local, tau_local,   &
                                       em_local, fq_isccp(:,:,:,:),   &
                                       npoints(:,:), &
                                       inhomogeneity_parameter(:,:), &
                                       ninhomog(:,:))
 
!----------------------------------------------------------------------
!    send any desired diagnostics to the diag_manager_mod.
!----------------------------------------------------------------------
              
                
          call isccp_output (is, js, fq_isccp, npoints, &
                             inhomogeneity_parameter, ninhomog, Time)
   
!---------------------------------------------------------------------
    
    
end subroutine isccp_diag        

!#####################################################################
! <SUBROUTINE NAME="isccp_diag_stochastic">
!  <OVERVIEW>
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_diag (is, js, Cld_spec, Atmos_input, coszen, Time)
!  </TEMPLATE>
!  <IN NAME="is,js" TYPE="integer">
!   starting subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   time on next timestep, used as stamp for 
!                        diagnostic output [ time_type (days, seconds) ]
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    atmospheric input fields on model grid,
!  </IN>
!  <IN NAME="coszen" TYPE="real">
!    cosine of solar zenith angle
!  </IN>
!  <IN NAME="Lsctau" TYPE="real">
!   cloud optical thickness in the visible
!  </IN>
!  <IN NAME="Lsclwem" TYPE="real">
!   10 micron cloud emissivity
!  </IN>
! </SUBROUTINE>
!
subroutine isccp_diag_stochastic (is, js, Atmos_input, coszen,       &
                                  Lsctau, Lsclwem, LscCldAmt, Time)

!--------------------------------------------------------------------
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!---------------------------------------------------------------------
 
integer,                     intent(in)   :: is,js
type(atmos_input_type),      intent(in)   :: Atmos_input
real, dimension(:,:),        intent(in)   :: coszen
real, dimension(:,:,:,:),    intent(in)   :: Lsctau, Lsclwem, LscCldAmt
type(time_type),             intent(in)   :: Time

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,js           starting/ending subdomain i,j indices of data 
!                      in the physics_window being integrated
!      Atmos_input     atmospheric input fields on model grid,
!                      [ atmos_input_type ] 
!      coszen          cosine of zenith angle [ dimensionless ]
!      Lsctau          0.6-0.685 micron cloud optical thickness 
!                      [ dimensionless ]
!      Lsclwem         Longwave emissivity [ dimensionless ]
!                      This is from 10.1-11.1 microns if the multiband 
!                      longwave emissivity is active.
!      LsCldAmt        Cloud fraction [ dimensionless ]
!                      Values should be identically 0 or 1. 
!      Time            time on next timestep, used as stamp for 
!                      diagnostic output [ time_type (days, seconds) ]
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      real, dimension (size(Lsctau,1), size(Lsctau,2), size(Lsctau,3) ) ::  qv

      !
      ! Isccp histogram variables
      !
      real, dimension (size(Lsctau,1), size(Lsctau,2), 7, 7) &
                                                       :: fq_isccp

      real, dimension (size(Lsctau,1), size(Lsctau,2)) :: npoints, &
                       ninhomog, inhomogeneity_parameter
      

      integer      :: kdim

      integer, dimension(size(Lsctau,1),size(Lsctau,2)):: sunlit
      
!---------------------------------------------------------------------
!   local variables:
!
!      qv               water vapor specific humidity
!                       [ kg vapor / kg air ]
!      fq_isccp         matrix of fractional area covered by cloud
!                       types of a given optical depth and cloud
!                       top pressure range.  The matrix is 7x7 for
!                       7 cloud optical depths and 7 cloud top 
!                       pressure ranges
!      npoints          flag indicating whether isccp cloud is present
!                       in column (cloud + daylight needed)
!      kdim             number of model layers
!      max_cld          greatest number of clouds in any column in the
!                       current physics window
!      i,j,k            do-loop indices
!     
!      sunlit           is the given i,j point sunlit?
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!    define number of model layers.
!----------------------------------------------------------------------
      kdim = size (Lsctau,3)
        
!---------------------------------------------------------------------
!    If optical properties are needed and no clouds exist in the 
!    window, call cloud_optical_properties_diag to define the cloud 
!    optical depth, the optical depth due to cloud ice and the 
!    longwave emissivity. If no clouds exist in the window, all the 
!    optical depths and emissivities are left are their initial
!    values of zero.to zero.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    Initialize ISCCP histograms
!---------------------------------------------------------------------

     npoints(:,:) = 0.
     fq_isccp(:,:,:,:) = 0.
     ninhomog(:,:) = 0.
     inhomogeneity_parameter(:,:) = 0.

!---------------------------------------------------------------------
!    Compute sunlit integer flag
!---------------------------------------------------------------------
     sunlit(:,:) = 0
     where(coszen(:,:) > 1.E-06) sunlit(:,:) = 1

!--------------------------------------------------------------------
!    define the specific humidity from the mixing ratio which has been
!    input.
!--------------------------------------------------------------------
     qv(:,:,:) = Atmos_input%cloudvapor(:,:,:)/ (1. + Atmos_input%cloudvapor(:,:,:))
               
!---------------------------------------------------------------------
!    call isccp_cloudtypes to map each model cloud to an isccp cloud
!    type, based on its optical depth and height above the surface.
!    set a flag to indicate the presence of isccp cloud in this column.
!---------------------------------------------------------------------
     call isccp_cloudtypes_stochastic (sunlit(:,:),        &
                            Atmos_input%press(:,:,1:kdim), &
                            Atmos_input%pflux(:,:,:),      &
                            qv(:,:,:),                     &
                            Atmos_input%cloudtemp(:,:,:),  &
                            Atmos_input%temp(:,:,kdim+1),  &
                            LscCldAmt(:, :, :, :),         &
                            LscTau(:, :, :, :),            &
                            Lsclwem(:, :, :, :),           &
                            fq_isccp(:,:,:,:), npoints(:,:), &
                            inhomogeneity_parameter(:,:), &
                            ninhomog(:,:))
                                                
!----------------------------------------------------------------------
!    send any desired diagnostics to the diag_manager_mod.
!----------------------------------------------------------------------
     call isccp_output (is, js, fq_isccp, npoints, &
                             inhomogeneity_parameter, ninhomog, Time)
   
!---------------------------------------------------------------------
    
    
end subroutine isccp_diag_stochastic        


!#####################################################################
! <SUBROUTINE NAME="compute_isccp_clds">
!  <OVERVIEW>
!    subroutine compute_isccp_clds maps the model clouds into isccp
!    categories (high, middle, low) and defines the cloud fraction of
!    each.
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine compute_isccp_clds maps the model clouds into isccp
!    categories (high, middle, low) and defines the cloud fraction of
!    each.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call compute_isccp_clds (pflux, camtsw, hml_ca)
!  </TEMPLATE>
!  <IN NAME="pflux" TYPE="real">
!   average of pressure at adjacent model levels
!  </IN>
!  <IN NAME="camtsw" TYPE="real">
!   total cloud amount [ nondimensional ]
!  </IN>
!  <OUT NAME="hml_ca" TYPE="real">
!   cloud fraction for the 3 isccp cloud types
!  </OUT>
! </SUBROUTINE>
!
subroutine compute_isccp_clds (pflux, camtsw, camtsw_band, hml_ca)

!---------------------------------------------------------------------
!    subroutine compute_isccp_clds maps the model clouds into isccp
!    categories (high, middle, low) and defines the cloud fraction of
!    each.
!--------------------------------------------------------------------- 

real,  dimension(:,:,:),   intent(in)  :: pflux, camtsw
real,  dimension(:,:,:,:), intent(in)  :: camtsw_band
real,  dimension(:,:,:),   intent(out) :: hml_ca

!---------------------------------------------------------------------
!  intent(in) variables:
!
!        pflux           average of pressure at adjacent model levels
!                        [ (kg /( m s^2) ]
!        camtsw          total cloud amount [ nondimensional ]
!        camtsw_band     total cloud amount in each sw band 
!                        [ nondimensional ]
!
!  intent(out) variable:
!
!        hml_ca          cloud fraction for the 3 isccp cloud types
!                        [ nondimensional ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      integer          ::   i, j, k

!---------------------------------------------------------------------
!  local variables:
!
!         mid_btm     pressure boundary between isccp middle and 
!                     isccp low clouds [ Pa ]
!         high_btm    pressure boundary between isccp middle and
!                     isccp high clouds [ Pa ]
!         i,j,k       do-loop indices
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    initialize a column integrated hi-mid-low cloud-free area array.
!--------------------------------------------------------------------
      hml_ca = 1.0
 
!---------------------------------------------------------------------
!    define arrays giving the cloud-free area in each column within the
!    pressure regionscorresponding to the ISCCP definitions of high 
!    (10-440 hPa), middle (440-680 hPa) and low (680-1000 hPa) clouds. 
!    compute high, middle and low cloud amounts assuming that independ-
!    ent clouds overlap randomly. note that model clouds above 10 hPa 
!    and below 1000 hPa are included in the totals.
!----------------------------------------------------------------------
      do k = 1,size(pflux,3)-1
        do j=1,size(pflux,2)
          do i=1,size(pflux,1)
            if (pflux(i,j,k)  <=  high_btm) then
              hml_ca(i,j,1) = hml_ca(i,j,1) * (1. - camtsw(i,j,k))
            else if ( (pflux(i,j,k) >  high_btm) .and.  &
                      (pflux(i,j,k) <=  mid_btm) ) then
              hml_ca(i,j,2) = hml_ca(i,j,2) * (1. - camtsw(i,j,k))
            else  if ( pflux(i,j,k) > mid_btm ) then
              hml_ca(i,j,3) = hml_ca(i,j,3) * (1. - camtsw(i,j,k))
            endif
            if (pflux(i,j,k)  >  high_btm) then
              hml_ca(i,j,4) = hml_ca(i,j,4) * (1. - camtsw(i,j,k))
            endif
          end do
        end do
      end do

!--------------------------------------------------------------------
!    convert the cloud-free area to an integrated cloud fraction in 
!    the column. express the cloud area in percent.
!--------------------------------------------------------------------
      hml_ca = 1. - hml_ca
      hml_ca = 100.*hml_ca
  
!-------------------------------------------------------------------


end subroutine compute_isccp_clds



!####################################################################
! <SUBROUTINE NAME="cloud_optical_properties_diag">
!  <OVERVIEW>
!    cloud_optical_properties_diag calculates the cloud optical depth,
!    ice cloud optical depth and longwave cloud emissivity for each
!    cloudy grid box.
!  </OVERVIEW>
!  <DESCRIPTION>
!    cloud_optical_properties_diag calculates the cloud optical depth,
!    ice cloud optical depth and longwave cloud emissivity for each
!    cloudy grid box.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_optical_properties_diag (Cld_spec, tau, em_lw)
!  </TEMPLATE>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid
!  </IN>
!  <OUT NAME="tau" TYPE="real">
!   cloud optical depth in each of the
!                     num_slingo_bands
!  </OUT>
!  <OUT NAME="em_lw" TYPE="real">
!   longwave cloud emissivity
!  </OUT>
! </SUBROUTINE>
!
subroutine cloud_optical_properties_diag (Cld_spec, tau, em_lw)

!---------------------------------------------------------------------
!    cloud_optical_properties_diag calculates the cloud optical depth,
!    ice cloud optical depth and longwave cloud emissivity for each
!    cloudy grid box.
!---------------------------------------------------------------------
                              
type(cld_specification_type), intent(in)   :: Cld_spec
real, dimension(:,:,:,:),     intent(out)  :: tau
real, dimension(:,:,:),       intent(out)  :: em_lw       

!--------------------------------------------------------------------
!   intent(in) variable:
!
!      Cld_spec       cloud specification properties on model grid,
!                     [ cld_specification_type ]
!
!   intent(out) variables:
!
!      tau            cloud optical depth in each of the
!                     num_slingo_bands [ dimensionless ]
!      em_lw          longwave cloud emissivity [ dimensionless ]  
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:


      real, dimension (size(Cld_spec%lwp,1),size(Cld_spec%lwp,2),  &
                       size(Cld_spec%lwp,3), 4) ::     &
                                                tau_liq, tau_ice

      real, dimension (size(Cld_spec%lwp,1),size(Cld_spec%lwp,2),   &
                       size(Cld_spec%lwp,3)) ::     &
                                                k_liq, k_ice, &
                                                rdrop, rice

!--------------------------------------------------------------------
!   local variables:
!
!       tau_liq    liquid cloud optical depth [ dimensionless ]
!       tau_ice    ice    cloud optical depth [ dimensionless ]
!       k_liq      liquid cloud mass absorption coefficient for longwave
!                  portion of the spectrum [ m**2 / kg condensate ]
!       k_ice      ice cloud mass absorption coefficient for longwave
!                  portion of the spectrum [ m**2 / kg condensate ]
!       rdrop      droplet radius, forced to be within the valid range 
!                  for the slingo parameterization (4.2 < rdrop < 16.6)
!                  [ microns ]
!       rice       ice particle size, forced to be within the valid 
!                  range for the ebert and curry parameterization 
!                  (10.0 < rdrop < 130.0)
!                  [ microns ]
!
!---------------------------------------------------------------------

!    NOTE: THESE SIZE LIMITS ARE INDEPENDENT OF WHAT IS USED IN THE GCM.
!          This subroutine is called only if isccp_actual_radprops =
!          .false., indicating that the actual gcm properties are not
!          being used in the isccp processing.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    compute uv cloud optical depths due to liquid. the formula for 
!    optical depth comes from: 
!    Slingo (1989), J. Atmos. Sci., vol. 46, pp. 1419-1427
!---------------------------------------------------------------------
      rdrop(:,:,:) = MAX (Cld_spec%reff_liq(:,:,:), 4.2)
      rdrop(:,:,:) = MIN (rdrop(:,:,:), 16.6)
!---------------------------------------------------------------------
!    in this program, reff_ice is limited to be between 10 microns
!    and 130 microns, which is the range of validity for the Ebert
!    and Curry (1992) radiation.
!---------------------------------------------------------------------
      rice (:,:,:) = MAX (Cld_spec%reff_ice(:,:,:), 10.0)
      rice (:,:,:) = MIN (rice (:,:,:), 130.0)
      tau_liq(:,:,:,1) = Cld_spec%lwp(:,:,:) * 1000. * &
                         (0.02817 + (1.305/rdrop(:,:,:)))
      tau_liq(:,:,:,2) = Cld_spec%lwp(:,:,:) * 1000. * &
                         (0.02682 + (1.346/rdrop(:,:,:)))
      tau_liq(:,:,:,3) = Cld_spec%lwp(:,:,:) * 1000. * &
                         (0.02264 + (1.454/rdrop(:,:,:)))
      tau_liq(:,:,:,4) = Cld_spec%lwp(:,:,:) * 1000. * &
                         (0.01281 + (1.641/rdrop(:,:,:)))
        
!---------------------------------------------------------------------
!    compute uv cloud optical depths due to ice. the formula for 
!    optical depth comes from:
!    Ebert and Curry (1992), J. Geophys. Res., vol. 97, pp. 3831-3836
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!    IMPORTANT:  WE ARE CHEATING HERE BECAUSE WE ARE FORCING THE FIVE 
!                BAND MODEL OF EBERT AND CURRY INTO THE FOUR BAND MODEL 
!                OF SLINGO. THIS IS DONE BY COMBINING BANDS 3 and 4 OF 
!                EBERT AND CURRY. EVEN SO THE EXACT BAND LIMITS DO NOT 
!                MATCH.  FOR COMPLETENESS HERE ARE THE BAND LIMITS IN 
!                MICRONS:
!            BAND               SLINGO                 EBERT AND CURRY
!
!             1               0.25-0.69                0.25 - 0.7
!             2               0.69-1.19                0.7 - 1.3
!             3               1.19-2.38                1.3 - 2.5
!             4               2.38-4.00                2.5 - 3.5
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 
!---------------------------------------------------------------------
      tau_ice(:,:,:,1) = Cld_spec%iwp(:,:,:) * 1000. * &
                         (0.003448 + (2.431/rice(:,:,:)))
      tau_ice(:,:,:,2) = tau_ice(:,:,:,1)
      tau_ice(:,:,:,3) = tau_ice(:,:,:,1)
      tau_ice(:,:,:,4) = tau_ice(:,:,:,1)

!---------------------------------------------------------------------
!     back out scaling factor

      tau_liq = tau_liq / isccp_scale_factor
      tau_ice = tau_ice / isccp_scale_factor
        
!---------------------------------------------------------------------
!    compute total cloud optical depth. the mixed phase optical prop-
!    erties are based upon equation 14 of Rockel et al. 1991, 
!    Contributions to Atmospheric Physics, volume 64, pp.1-12. 
!    thus:

!          tau = tau_liq + tau_ice
!
!    and place a minimum value on tau - taumin
!---------------------------------------------------------------------
      tau(:,:,:,:) = max(tau_liq(:,:,:,:) + tau_ice(:,:,:,:),taumin)
        
!----------------------------------------------------------------------
!    define the  mass absorption coefficient for longwave radiation 
!    for cloud ice and cloud liquid.
!
!    NOTE THAT THE NUMBERS HERE ALREADY INCLUDE THE DIFFUSIVITY
!    FACTOR!
!----------------------------------------------------------------------
      k_liq(:,:,:) = 140.
      k_ice(:,:,:) = 4.83591 + 1758.511/rice(:,:,:)
        
!----------------------------------------------------------------------
!    compute combined lw emmisivity. the mixed phase optical properties
!    are based upon equation 14 of Rockel et al. 1991, Contributions to
!    Atmospheric Physics,  volume 64, pp.1-12.  thus:
!
!    transmivvity_lw =   transmissivity_lw_ice * transmissivity_lw_liq
!
!    which can also be written as:
!
!    em_lw =  em_lw_liq + em_lw_ice -  (em_lw_liq * em_lw_ice )
!
!    which is what is solved here.
!----------------------------------------------------------------------
      em_lw(:,:,:) =  1. - exp(-1.*(k_liq(:,:,:)*Cld_spec%lwp(:,:,:) + &
                                    k_ice(:,:,:)*Cld_spec%iwp(:,:,:))/ &
                                    isccp_scale_factor)

!---------------------------------------------------------------------


end subroutine cloud_optical_properties_diag


!######################################################################



                end module cloudrad_diagnostics_mod



                 module cloudrad_package_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that supplies cloud radiative properties
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

! shared modules:

use mpp_mod,                  only: input_nml_file
use fms_mod,                  only: fms_init, open_namelist_file, &
                                    write_version_number, mpp_pe, &
                                    mpp_root_pe, stdlog, file_exist,  &
                                    check_nml_error, error_mesg,   &
                                    FATAL, close_file
use time_manager_mod,         only: time_type, time_manager_init

! shared radiation package modules:

use rad_utilities_mod,        only: rad_utilities_init, Lw_control, &
                                    Sw_control, cldrad_properties_type,&
                                    cld_specification_type, &
                                    microrad_properties_type, &
                                    microphysics_type, astronomy_type, &
                                    atmos_input_type, Cldrad_control
use esfsw_parameters_mod,     only: esfsw_parameters_init, Solar_spect

! radiation package modules:

use cloudrad_diagnostics_mod, only: cloudrad_diagnostics_init, &
                                    cloudrad_netcdf, &
                                    cloudrad_diagnostics_end
use bulkphys_rad_mod,         only: bulkphys_rad_init, &
                                    bulkphys_rad_end, &
                                    bulkphys_lw_driver, &
                                    bulkphys_sw_driver
use microphys_rad_mod,        only: lwemiss_calc, comb_cldprops_calc, &
                                    microphys_rad_init, &
                                    microphys_rad_end, &
                                    microphys_lw_driver, &
                                    microphys_sw_driver

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    cloudrad_package_mod computes cloud radiative properties consistent
!    with the activated radiation package options and returns them to
!    radiation_driver_mod.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: cloudrad_package.F90,v 18.0.2.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public          &
         cloudrad_package_init, cloud_radiative_properties, &
         cldrad_props_dealloc, cloudrad_package_end


private          &
!  called from cloud_radiative_properties:
         initialize_cldrad_props, combine_cloud_properties,  &
         cloudrad_package_dealloc

!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16)  :: microphys_form =  '     ' ! level of microphysics
                                                ! being used; either
                                                ! 'none', 'prescribed',
                                                ! or 'predicted'
real               :: min_cld_drop_rad = 4.2    ! smallest allowable 
                                                ! cloud drop radius 
                                                ! (microns) allowed in
                                                ! slingo scheme
real               :: max_cld_drop_rad = 16.6   ! largest allowable 
                                                ! cloud drop radius 
                                                ! (microns) allowed in
                                                ! slingo scheme
real               :: min_cld_ice_size = 18.6   ! smallest allowable 
                                                ! cloud ice size    
                                                ! (microns) allowed in
                                                ! fu-liou scheme
real               :: max_cld_ice_size = 130.2  ! largest allowable 
                                                ! cloud ice size    
                                                ! (microns) allowed in
                                                ! fu-liou scheme

namelist /cloudrad_package_nml /     &
                               min_cld_drop_rad, max_cld_drop_rad, &
                               min_cld_ice_size, max_cld_ice_size, &
                               microphys_form

!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

logical      :: module_is_initialized = .false.  ! module initialized?



!----------------------------------------------------------------------
!----------------------------------------------------------------------



                          contains 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="cloudrad_package_init">
!  <OVERVIEW>
!   Contructor of cloudrad_package module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Contructor of cloudrad_package module
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloudrad_package_init ( pref, lonb, latb, axes, Time)
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!   reference pressure levels
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   the longitude array of the model grid box corners
!  </IN>
!  <IN NAME="latb" TYPE="real">
!   the latitude array of the model grid box corners
!  </IN>
!  <IN NAME="axes" TYPE="real">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
! </SUBROUTINE>
!
subroutine cloudrad_package_init (pref, lonb, latb, axes, Time)

!---------------------------------------------------------------------
!    cloudrad_package_init is the constructor for cloudrad_package_mod.
!----------------------------------------------------------------------

real,    dimension(:,:), intent(in)    ::   pref
real,    dimension(:,:), intent(in)    ::   lonb, latb
integer, dimension(4),   intent(in)    ::   axes
type(time_type),         intent(in)    ::   Time

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       pref      array containing two reference pressure profiles 
!                 for use in defining transmission functions [ Pa ]
!       lonb      2d array of model longitudes on cell corners[ radians ]
!       latb      2d array of model latitudes at cell corners [radians]
!       axes      diagnostic variable axes
!       Time      current time [time_type(days, seconds)]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer         :: unit, io, ierr, logunit

!---------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file 
!      io       error status returned from io operation  
!      ierr     error code
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call rad_utilities_init

!---------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cloudrad_package_nml, iostat=io)
      ierr = check_nml_error(io,"cloudrad_package_nml")
#else
!---------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=cloudrad_package_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'cloudrad_package_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                       write (logunit, nml=cloudrad_package_nml)
 
!-------------------------------------------------------------------
!    verify that Lw_control%do_lwcldemiss has been defined.
!-------------------------------------------------------------------
      if (Lw_control%do_lwcldemiss_iz) then
      else
        call error_mesg ('cloudrad_package_mod', &
         'Lw_control%do_lwcldemiss has not yet been defined', FATAL)
      endif

!-------------------------------------------------------------------
!    verify that Sw_control%do_esfsw has been defined.
!-------------------------------------------------------------------
      if (Sw_control%do_esfsw_iz) then
      else
        call error_mesg ('cloudrad_package_mod', &
         'Sw_control%do_esfsw has not yet been defined', FATAL)
      endif
!-------------------------------------------------------------------
!    verify that the component cloud scheme elements of Cldrad_control 
!    have been defined.
!-------------------------------------------------------------------
      if (Cldrad_control%do_rh_clouds_iz .and.  &
          Cldrad_control%do_strat_clouds_iz .and.  &
          Cldrad_control%do_zonal_clouds_iz .and.  &
          Cldrad_control%do_mgroup_prescribed_iz .and.  &
          Cldrad_control%do_obs_clouds_iz .and.  &
          Cldrad_control%do_no_clouds_iz .and.  &
          Cldrad_control%do_diag_clouds_iz .and.  &
          Cldrad_control%do_specified_clouds_iz .and.  &
          Cldrad_control%do_uw_clouds_iz .and.  &
          Cldrad_control%do_donner_deep_clouds_iz ) then  
      else
        call error_mesg ('cloudrad_package_mod', &
         'Cldrad_control%do_{some cloud type} not yet been defined', &
                                                                 FATAL)
      endif


!-------------------------------------------------------------------
!    define variables which denote whether microphysically-based cloud
!    radiative properties will be defined for the longwave and shortwave
!    radiation calculations. if esf sw is being used, then do_sw_micro
!    will be .true.; if do_lwcldemiss is .true. or if esf sw is being 
!    used along with strat clouds or diag clouds or specified clouds, 
!    then do_lw_micro will be .true..
!----------------------------------------------------------------------
      if (Lw_control%do_lwcldemiss) then
        Cldrad_control%do_lw_micro = .true.
      endif
      if (Sw_control%do_esfsw) then
        call esfsw_parameters_init
        Cldrad_control%do_sw_micro = .true.
        if (Cldrad_control%do_strat_clouds .or. &
            Cldrad_control%do_specified_clouds .or. &
            Cldrad_control%do_diag_clouds) then
          Cldrad_control%do_lw_micro = .true.
        endif
      endif

!--------------------------------------------------------------------
!    mark the logical controls as initialized.
!--------------------------------------------------------------------
      Cldrad_control%do_lw_micro_iz = .true.
      Cldrad_control%do_sw_micro_iz = .true.

!----------------------------------------------------------------------
!    define the microphysical use desired for this experiment. different
!    levels may be used for the lw and sw parameterizations. 
!----------------------------------------------------------------------
      if (trim(microphys_form) == 'predicted') then 

!---------------------------------------------------------------------
!    if microphys_form asks for predicted microphysics, then either
!    strat or donner deep clouds must be activated, and either one or 
!    both of do_lw_micro and do_sw_micro must be .true..  if these
!    conditions are met, set do_pred_cld_microphys to .true.. if only
!    one of do_sw_micro and do_lw_micro are true, then also set 
!    do_bulk_microphys to .true. so that the bulk scheme initialization
!    may be completed. if  neither do_lw_micro or do_sw_micro are .true.
!    or if a different cloud scheme has been activated, stop execution 
!    with an error message.
!---------------------------------------------------------------------
        if (Cldrad_control%do_strat_clouds .or. &
            Cldrad_control%do_donner_deep_clouds .or. &
            Cldrad_control%do_uw_clouds .or. &
            Cldrad_control%do_zetac_clouds) then
          if (Cldrad_control%do_sw_micro .and.   &
              Cldrad_control%do_lw_micro) then
            Cldrad_control%do_pred_cld_microphys = .true.
          else if (Cldrad_control%do_sw_micro .or.    &
                   Cldrad_control%do_lw_micro) then
            Cldrad_control%do_pred_cld_microphys = .true.
            Cldrad_control%do_bulk_microphys = .true.
          else
            call error_mesg( 'cloudrad_package_mod',  &
             ' not using microphysics -- set microphys_form '//&
                                                    'to none.', FATAL)
          endif
        else
          call error_mesg( 'cloudrad_package_mod',  &
                    ' predicted microphys not available with this '//&
                                                 'cloud scheme.', FATAL)
        endif

!---------------------------------------------------------------------
!    if prescribed microphysics are requested, make sure the cloud 
!    scheme requested has the capability of using the microphysical
!    properties, and that either the sw or lw scheme requested is 
!    microphysically based. if only one of do_sw_micro and do_lw_micro
!    is .true., then set do_bulk_microphys to .true., so that the bulk
!    scheme may be initialized. if neither is .true. or if a cloud
!    scheme has been requested that cannot use prescribed microphysics,
!    stop execution with an error message.
!---------------------------------------------------------------------
      else if (trim(microphys_form) == 'prescribed') then
        if (Cldrad_control%do_rh_clouds .or.  &
            Cldrad_control%do_mgroup_prescribed .or.  &
            Cldrad_control%do_specified_clouds  .or.  &
            Cldrad_control%do_diag_clouds       .or.  &
            Cldrad_control%do_no_clouds)    then
          if (Cldrad_control%do_sw_micro .and.    &
              Cldrad_control%do_lw_micro) then
            Cldrad_control%do_presc_cld_microphys = .true.
          else if (Cldrad_control%do_sw_micro .or.     &
                   Cldrad_control%do_lw_micro) then
            Cldrad_control%do_presc_cld_microphys = .true.
            Cldrad_control%do_bulk_microphys = .true.
          else
            call error_mesg( 'cloudrad_package_mod',  &
                ' not using microphysics -- set microphys_form '//&
                  'to none.', FATAL)
          endif
        else
          call error_mesg( 'cloudrad_package_mod',  &
             ' prescribed microphys not allowed with this cloud '//&
                                     'scheme.',  FATAL) 
        endif

!---------------------------------------------------------------------
!    if no microphysics is requested, make sure that donner_deep clouds
!    has not been requested (must use predicted cloud microphysics
!    for that scheme -- all others can be run without microphysics).  
!    also verify that the lw and sw schemes requested are not micro-
!    physically_based. if all is ok, set do_bulk_microphys to .true.; 
!    if not ok, write an error message and stop.
!---------------------------------------------------------------------
      else if (trim(microphys_form) == 'none') then
        if (Cldrad_control%do_donner_deep_clouds .or.  &
            Cldrad_control%do_uw_clouds) then        
          call error_mesg( 'cloudrad_package_mod',  &
            ' use predicted microphys with donner or uw clouds.', FATAL)
        else     
          if (Cldrad_control%do_sw_micro .or.    &
              Cldrad_control%do_lw_micro) then
            call error_mesg ('cloudrad_package_mod', &
               'must specify microphys_form when using microphysica'//&
                'lly-based cld rad scheme', FATAL)
          else
              Cldrad_control%do_bulk_microphys = .true.
          endif
        endif

!----------------------------------------------------------------------
!    error condition.
!----------------------------------------------------------------------
      else
        call error_mesg( 'cloudrad_package_mod',  &
           ' microphys_form is not an acceptable value.', FATAL)
      endif

!---------------------------------------------------------------------
!    define variables indicating that the desired cloud microphysics
!    type control variables have been defined.
!---------------------------------------------------------------------
      Cldrad_control%do_bulk_microphys_iz = .true.
      Cldrad_control%do_pred_cld_microphys_iz = .true.
      Cldrad_control%do_presc_cld_microphys_iz = .true.

!---------------------------------------------------------------------
!    if a microphysically-based scheme is being used, initialize the 
!    microphys_rad module.
!---------------------------------------------------------------------
      if (Cldrad_control%do_presc_cld_microphys  .or.  &
          Cldrad_control%do_pred_cld_microphys) then
        call microphys_rad_init ( min_cld_drop_rad, max_cld_drop_rad, &
                                  min_cld_ice_size, max_cld_ice_size, &
                                  axes, Time, lonb, latb)
      endif

!---------------------------------------------------------------------
!    if a bulk physics scheme is to be used, call bulkphys_rad_init. 
!---------------------------------------------------------------------
      if (Cldrad_control%do_bulk_microphys) then
        call bulkphys_rad_init (min_cld_drop_rad, max_cld_drop_rad, &
                                min_cld_ice_size, max_cld_ice_size, &
                                pref, lonb, latb)
      endif

!-------------------------------------------------------------------
!    when running the gcm or the standalone model with a cloud scheme,
!    call cloudrad_diagnostics_init to initialize the netcdf diagnostics
!    associated with the cloudrad package.
!-------------------------------------------------------------------
      if (.not. Cldrad_control%do_no_clouds) then
        call cloudrad_diagnostics_init (min_cld_drop_rad,   &
                                        max_cld_drop_rad, &
                                  min_cld_ice_size, max_cld_ice_size, &
                                        axes, Time)
      endif

!--------------------------------------------------------------------
!    mark the module initialized.
!--------------------------------------------------------------------
      module_is_initialized= .true.

!--------------------------------------------------------------------



end subroutine cloudrad_package_init



!####################################################################
! <SUBROUTINE NAME="cloud_radiative_properties">
!  <OVERVIEW>
!   Subroutine to calculate cloud radiative properties
!    appropriate for the radiation options that are active.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to calculate cloud radiative properties
!    appropriate for the radiation options that are active.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_radiative_properties (is, ie, js, je, Rad_time, Time_next,  &
!                                       Astro, Atmos_input, Cld_spec,  &
!                                       Lsc_microphys, Meso_microphys, &
!                                       Cell_microphys, 
!                                     Shallow_microphys, Cldrad_props, &
!                                       kbot, mask)
!  </TEMPLATE>
!  <IN NAME="is,ie,js,je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   time on next timestep, used as stamp for 
!                        diagnostic output [ time_type (days, seconds) ]
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!   astronomical properties needed by radiation
!                        package
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    atmospheric input fields on model grid,
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </IN>
!  <IN NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </IN>
!  <IN NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!  </IN>
!  <IN NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                        clouds associated with donner convection
!  </IN>
!  <IN NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                        clouds associated with uw shallow convection
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties on model grid
!  </INOUT>
!  <IN NAME="kbot" TYPE="integer">
!   OPTIONAL: present when running eta vertical coordinate,
!                        index of lowest model level above ground 
!  </IN>
!  <IN NAME="mask" TYPE="real">
!   OPTIONAL: present when running eta vertical coordinate,
!                        mask to remove points below ground
!  </IN>
! </SUBROUTINE>
!
subroutine cloud_radiative_properties (is, ie, js, je, Rad_time,   &
                                       Time_next,  &
                                       Astro, Atmos_input, Cld_spec,  &
                                       Lsc_microphys, Meso_microphys, &
                                       Cell_microphys,   &
                                       Shallow_microphys,Cldrad_props, &
                                       Model_microphys, &
                                       kbot, mask)

!----------------------------------------------------------------------
!    cloud_radiative_properties defines the cloud radiative properties 
!    appropriate for the radiation options that are active.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
integer,                      intent(in)             :: is, ie, js, je
type(time_type),              intent(in)             :: Rad_time, &
                                                        Time_next
type(astronomy_type),         intent(in)             :: Astro
type(atmos_input_type),       intent(in)             :: Atmos_input
type(cld_specification_type), intent(inout)          :: Cld_spec    
type(microphysics_type),      intent(in)             :: Lsc_microphys, &
                                                        Meso_microphys,&
                                                        Cell_microphys,&
                                                     Shallow_microphys
type(cldrad_properties_type), intent(inout)          :: Cldrad_props
type(microphysics_type),      intent(inout)          :: Model_microphys
integer, dimension(:,:),      intent(in),   optional :: kbot
real, dimension(:,:,:),       intent(in),   optional :: mask
!-------------------------------------------------------------------
 
!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je       starting/ending subdomain i,j indices of data 
!                        in the physics_window being integrated
!      Time_next         time on next timestep, used as stamp for 
!                        diagnostic output [ time_type (days, seconds) ]
!      Astro             astronomical properties needed by radiation
!                        package
!                        [ astronomy_type ]
!      Atmos_input       atmospheric input fields on model grid,
!                        [ atmos_input_type ] 
!      Cld_spec          cloud specification properties on model grid,
!                        [ cld_specification_type ]
!      Lsc_microphys     microphysical specification for large-scale 
!                        clouds
!                        [ microphysics_type ]
!      Meso_microphys    microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!                        [ microphysics_type ]
!      Cell_microphys    microphysical specification for convective cell
!                        clouds associated with donner convection
!                        [ microphysics_type ]
!      Shallow_microphys   
!                        microphysical specification for 
!                        clouds associated with uw shallow convection
!                        [ microphysics_type ]
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!   intent(in), optional variables:
!
!      kbot              present when running eta vertical coordinate,
!                        index of lowest model level above ground 
!      mask              present when running eta vertical coordinate,
!                        mask to remove points below ground
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      type(microrad_properties_type) :: Lscrad_props, Cellrad_props, &
                                        Mesorad_props, Shallowrad_props
      integer  ::   ix, jx, kx  
      logical  ::   donner_flag = .true.
      logical  ::   donner_flag_uw = .false.

!---------------------------------------------------------------------
!   local variables:
!
!       Lscrad_props   cloud radiative properties for the large-scale 
!                      clouds   
!                      [ microrad_properties_type ]
!       Mesorad_props  cloud radiative properties for meso-scale 
!                      clouds associated with donner convection   
!                      [ microrad_properties_type ]
!       Cellrad_props  cloud radiative properties for convective cell
!                      clouds associated with donner convection  
!                      [ microrad_properties_type ]
!       Shallowrad_props   
!                      cloud radiative properties for 
!                      clouds associated with uw shallow convection  
!                      [ microrad_properties_type ]
!       ix             x dimension of current physics window
!       jx             y dimension of current physics window
!       kx             z dimension of current physics window
!       donner_flag    optional argument to microphys_rad module
!                      indicating that the meso or cell cloud compon-
!                      ent is currently being processed. needed because
!                      a different fu ice parameterization is used in
!                      these cases than is used for large-scale clouds.
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the dimensions of the current physics window.
!---------------------------------------------------------------------
      ix = size(Cld_spec%camtsw,1)
      jx = size(Cld_spec%camtsw,2)
      kx = size(Cld_spec%camtsw,3)

!--------------------------------------------------------------------
!    call initialize_cldrad_props to allocate and initialize the cloud 
!    radiative property arrays.
!---------------------------------------------------------------------
      call initialize_cldrad_props (ix, jx, kx, Lscrad_props,   &
                                    Mesorad_props, Cellrad_props, &
                                    Shallowrad_props, Cldrad_props)

!--------------------------------------------------------------------
!    if bulkphys_rad routines are needed, limit the condensate sizes
!    to that range acceptable for the radiative parameterizations.
!--------------------------------------------------------------------
      if (Cldrad_control%do_lw_micro .and. &
        Cldrad_control%do_sw_micro ) then 
      else
        Cld_spec%reff_liq_lim = MAX(MIN(Cld_spec%reff_liq,  &
                                  max_cld_drop_rad), min_cld_drop_rad)
        Cld_spec%reff_ice_lim = MAX(MIN(Cld_spec%reff_ice,  &
                                  max_cld_ice_size), min_cld_ice_size)
      endif

!----------------------------------------------------------------------
!    if a cloud scheme is activated (in contrast to running without any
!    clouds), call either the microphysically-based or bulkphysics-based
!    modules to define the cloud lw and sw radiative properties. if the
!    model is being run with do_no_clouds = .true., exit from this 
!    routine, leaving the cloud radiative property variables as they 
!    were initialized (to values compatible to the non-existence of 
!    cloudiness).
!---------------------------------------------------------------------
      if (.not. Cldrad_control%do_no_clouds) then
        if (Cldrad_control%do_lw_micro) then
          if (Cldrad_control%do_ica_calcs) then
            call microphys_lw_driver (is, ie, js, je, Lsc_microphys,  &
                                      Cloud_rad_props=Cldrad_props)
          else
            call microphys_lw_driver (is, ie, js, je, Lsc_microphys,  &
                                      Micro_rad_props=Lscrad_props)
          endif
        else
          call bulkphys_lw_driver (is, ie, js, je, Cld_spec,    &
                                   Cldrad_props)
        endif
        if (Cldrad_control%do_sw_micro) then
          if (Cldrad_control%do_ica_calcs) then
            call microphys_sw_driver (is, ie, js, je, Lsc_microphys,  &
                                      Cloud_rad_props=Cldrad_props)
          else
            call microphys_sw_driver (is, ie, js, je, Lsc_microphys,  &
                                      Micro_rad_props=Lscrad_props)
          endif
        else
          call bulkphys_sw_driver (is, ie, js, je, Astro%cosz,   &
                                   Cld_spec, Cldrad_props)
        endif

!--------------------------------------------------------------------
!    if donner_deep_clouds is active, obtain the cloud radiative prop-
!    erties associated with the mesoscale and cell-scale convective
!    components. only microphysically-based properties are available.
!    the optional argument  donner_flag is used to indicate that prop-
!    erties associated with the clouds produced by the donner_deep_mod 
!    are being processed, since a different ice parameterization is
!    used for donner_deep relative to large-scale clouds.
!----------------------------------------------------------------------
        if (Cldrad_control%do_donner_deep_clouds) then
          donner_flag = .true.
          call microphys_lw_driver (is, ie, js, je, Meso_microphys,  &
                                    Micro_rad_props=Mesorad_props,   &
                                    donner_flag=donner_flag)
          call microphys_lw_driver (is, ie, js, je, Cell_microphys,  &
                                    Micro_rad_props=Cellrad_props, &
                                    donner_flag=donner_flag)
          call microphys_sw_driver (is, ie, js, je, Meso_microphys,  &
                                    Micro_rad_props=Mesorad_props, &
                                    donner_flag=donner_flag)
          call microphys_sw_driver (is, ie, js, je, Cell_microphys,  &
                                    Micro_rad_props=Cellrad_props, &
                                    donner_flag=donner_flag)
        endif

!--------------------------------------------------------------------
!    if the uw shallow convection scheme is active, obtain the cloud 
!    radiative properties associated with its clouds. only micro-
!    physically-based properties are available.
!    NOTE FOR NOW:
!   the optional argument  donner_flag is set to .false. when processing
!   shallow clouds. the ice cloud radiative properties are obtained from
!    the parameterization used by strat_cloud (effective size), rather 
!    than that used by donner_deep (generalized effective size).
!----------------------------------------------------------------------
       if (Cldrad_control%do_uw_clouds) then
         donner_flag_uw = .false.
         call microphys_lw_driver (is, ie, js, je, Shallow_microphys, &
                                   Micro_rad_props=Shallowrad_props, &
                                   donner_flag=donner_flag_uw)
         call microphys_sw_driver (is, ie, js, je, Shallow_microphys, &
                                   Micro_rad_props=Shallowrad_props,&
                                   donner_flag=donner_flag_uw)
        endif
      endif ! ( .not. do_no_clouds)

!---------------------------------------------------------------------
!    call combine_cloud_properties to define a set of total-cloud cloud
!    radiative properties. if donner deep and / or uw shallow clouds 
!    are active, this requires the combination of the cloud properties 
!    associated with the different types of cloud present (large-scale, 
!    donner meso and  cell, uw shallow). for other schemes the 
!    total-cloud values are simply the large-scale cloud values. 
!    this procedure is only needed when microphysically-based properties
!    are being used.
!---------------------------------------------------------------------
      if (.not. Cldrad_control%do_ica_calcs) then
        if (Cldrad_control%do_sw_micro  .or. &
            Cldrad_control%do_lw_micro) then  
          call combine_cloud_properties (is, js, Rad_time, Time_next, &
                                         Atmos_input%deltaz, &
                                         Cld_spec, &
                                         Lsc_microphys, Meso_microphys,&
                                         Cell_microphys,   &
                                         Shallow_microphys,  &
                                         Lscrad_props, &
                                         Mesorad_props, Cellrad_props, &
                                         Shallowrad_props, &
                                         Cldrad_props)
        endif  
      endif  

!----------------------------------------------------------------------
!    call lwemiss_calc to compute lw emissivity from the absorption 
!    coefficient when a microphysically-based lw emissivity scheme 
!    is being used.
!----------------------------------------------------------------------
      if (Cldrad_control%do_lw_micro) then
        call lwemiss_calc (Atmos_input%clouddeltaz,   &
                           Cldrad_props%abscoeff, Cldrad_props%cldemiss)
        Cldrad_props%emmxolw = Cldrad_props%cldemiss
        Cldrad_props%emrndlw = Cldrad_props%cldemiss
      endif

!-------------------------------------------------------------------
!    if running the gcm or feedback program with a cloud scheme active,
!    call cloudrad_netcdf to generate netcdf output fields.
!-------------------------------------------------------------------
      if (.not. Cldrad_control%do_no_clouds) then 
          call cloudrad_netcdf (is, js, Time_next, Atmos_input,&
                                Astro%cosz, Lsc_microphys, &
                                Meso_microphys, Cell_microphys,   &
                                Shallow_microphys, &
                                Lscrad_props, Mesorad_props,    &
                                Cellrad_props, Shallowrad_props, &
                                Cldrad_props, Cld_spec, Model_microphys)
      endif   ! (do_no_clouds)

!--------------------------------------------------------------------
!    call cloudrad_package_dealloc to deallocate the local derived type
!    variable arrays.
!--------------------------------------------------------------------
      call cloudrad_package_dealloc (Lscrad_props, Mesorad_props,   &
                                     Cellrad_props, Shallowrad_props)

!---------------------------------------------------------------------


end subroutine cloud_radiative_properties     



!#####################################################################
! <SUBROUTINE NAME="cldrad_properties_dealloc">
!  <OVERVIEW>
!    Subroutine to deallocate the array elements of the
!    cldrad_properties_type variable that is input.
!  </OVERVIEW>
!  <DESCRIPTION>
!    Subroutine to deallocate the array elements of the
!    cldrad_properties_type variable that is input.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cldrad_props_dealloc (Cldrad_props)
!  </TEMPLATE>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cldrad_properties_type variable containing cloud 
!   radiative properties
!  </INOUT>
! </SUBROUTINE>
!
subroutine cldrad_props_dealloc (Cldrad_props)

!------------------------------------------------------------------
!    cldrad_props_dealloc deallocates the array elements of the
!    cldrad_properties_type variable that is input.
!------------------------------------------------------------------

type(cldrad_properties_type), intent(inout) :: Cldrad_props

!-------------------------------------------------------------------
!  intent(inout) variables:
!
!    Cldrad_props    cldrad_properties_type variable containing
!                    cloud radiative properties
!
!--------------------------------------------------------------------

!------------------------------------------------------------------
!    deallocate the array elements of Cldrad_props. different variables
!    exist dependent on the sw parameterization being used.
!-------------------------------------------------------------------
      deallocate (Cldrad_props%emmxolw   )
      deallocate (Cldrad_props%emrndlw   )
      deallocate (Cldrad_props%abscoeff  )
      deallocate (Cldrad_props%cldemiss  )

      if ( Cldrad_control%do_sw_micro ) then
        deallocate (Cldrad_props%cldext    )
        deallocate (Cldrad_props%cldasymm  )
        deallocate (Cldrad_props%cldsct    )
      else
        deallocate (Cldrad_props%cvisrfsw  )
        deallocate (Cldrad_props%cirabsw   )
        deallocate (Cldrad_props%cirrfsw   )
      endif

!-------------------------------------------------------------------


end subroutine cldrad_props_dealloc




!####################################################################
! <SUBROUTINE NAME="cloudrad_package_end">
!  <OVERVIEW>
!   Destructor of the cloudrad_package module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Destructor of the cloudrad_package module
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloudrad_package_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine cloudrad_package_end

!--------------------------------------------------------------------
!    cloudrad_package_end is the destructor for cloudrad_package_mod.
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    deactivate the modules which are component modules of
!    cloudrad_package_mod.
!-------------------------------------------------------------------
      if (.not. Cldrad_control%do_no_clouds) then
        call cloudrad_diagnostics_end
      endif
      if (Cldrad_control%do_presc_cld_microphys  .or.  &
          Cldrad_control%do_pred_cld_microphys) then
        call microphys_rad_end
      endif
      if (Cldrad_control%do_bulk_microphys) then
        call bulkphys_rad_end
      endif

!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------



end subroutine cloudrad_package_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!####################################################################
! <SUBROUTINE NAME="initialize_cldrad_props">
!  <OVERVIEW>
!   initialize_cldrad_props allocates and initializes those fields
!    which define the cloud radiative properties needed by the
!    radiation package.
!  </OVERVIEW>
!  <DESCRIPTION>
!   initialize_cldrad_props allocates and initializes those fields
!    which define the cloud radiative properties needed by the
!    radiation package.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call initialize_cldrad_props (ix, jx, kx, Lscrad_props,    &
!                                    Mesorad_props, Cellrad_props, &
!                                    Shallowrad_props, Cldrad_props )
!  </TEMPLATE>
!  <IN NAME="ix, jx, kx" TYPE="integer">
!       ix             size of i dimension of physics window
!       jx             size of j dimension of physics window
!       kx             size of k dimension of physics window
!  </IN>
!  <INOUT NAME="Lscrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the large-scale 
!                      clouds   
!  </INOUT>
!  <INOUT NAME="Mesorad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the meso-scale
!                      clouds assciated with donner convection
!  </INOUT>
!  <INOUT NAME="Cellrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the convective cell
!                      clouds associated with donner convection 
!  </INOUT>
!  <INOUT NAME="Shallowrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the 
!                      clouds associated with uw shallow convection 
!  </INOUT>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties on model grid
!  </INOUT>
! </SUBROUTINE>
!
subroutine initialize_cldrad_props (ix, jx, kx, Lscrad_props,    &
                                    Mesorad_props, Cellrad_props, &
                                    Shallowrad_props, Cldrad_props )

!--------------------------------------------------------------------
!    initialize_cldrad_props allocates and initializes those fields
!    which define the cloud radiative properties needed by the
!    radiation package.
!---------------------------------------------------------------------

integer,                        intent(in)    :: ix, jx, kx
type(microrad_properties_type), intent(inout) :: Lscrad_props, &
                                                 Mesorad_props, &
                                                 Cellrad_props, &
                                                 Shallowrad_props
type(cldrad_properties_type),   intent(inout) :: Cldrad_props

!----------------------------------------------------------------------
!    intent(in) variables:
! 
!       ix             size of i dimension of physics window
!       jx             size of j dimension of physics window
!       kx             size of k dimension of physics window
!
!   intent(inout) variables:
!
!       Lscrad_props   cloud radiative properties for the large-scale 
!                      clouds   
!                      [ microrad_properties_type ]
!       Mesorad_props  cloud radiative properties for meso-scale 
!                      clouds associated with donner convection   
!                      [ microrad_properties_type ]
!       Cellrad_props  cloud radiative properties for convective cell
!                      clouds associated with donner convection  
!                      [ microrad_properties_type ]
!       Shallowrad_props 
!                      cloud radiative properties for
!                      clouds associated with uw shallow convection  
!                      [ microrad_properties_type ]
!          the components of a microrad_structure are:
!            %cldext   parameterization band values of the cloud      
!                      extinction coefficient [ km**(-1) ]   
!            %cldsct   parameterization band values of the cloud      
!                      scattering coefficient [ km**(-1) ]
!            %cldasymm parameterization band values of the asymmetry  
!                      factor [ dimensionless ]
!            %abscoeff combined absorption coefficient for clouds in 
!                      each of the longwave frequency bands [ km**(-1) ]
!
!       Cldrad_props   cloud radiative properties on model grid,
!                      [ cldrad_properties_type ]
!          the components of a cldrad_properties_type strucure are:
!            %emmxolw  longwave cloud emissivity for maximally over-
!                      lapped clouds [ dimensionless ] 
!            %emrndlw  longwave cloud emissivity for randomly overlapped
!                      clouds  [ dimensionless ]
!            %cldext   parameterization band values of the cloud      
!                      extinction coefficient [ km**(-1) ]   
!            %cldsct   parameterization band values of the cloud      
!                      scattering coefficient [ km**(-1) ]
!            %cldasymm parameterization band values of the asymmetry  
!                      factor [ dimensionless ]
!            %abscoeff combined absorption coefficient for clouds in 
!                      each of the longwave frequency bands [ km**(-1) ]
!            %cldemiss longwave emissivity calculated using abscoeff
!                      [ dimensionless ]
!            %cirabsw  absorptivity of clouds in the infrared frequency 
!                      band. may be zenith angle dependent. 
!                      [ dimensionless ]
!            %cirrfsw  reflectivity of clouds in the infrared frequency
!                      band. may be zenith angle dependent.
!                      [ dimensionless ]
!            %cvisrfsw reflectivity of clouds in the visible frequency 
!                      band. may be zenith angle dependent.
!                      [ dimensionless ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variable:

      integer :: n_esfsw_bands
      integer :: nlwcldb

!-------------------------------------------------------------------
!   local variable:
!
!          n_esfsw_bands   number of spectral bands resolved by the 
!                          sw radiation package; set to zero when
!                          bulk-based sw (lhsw) is active
!          nlwcldb         number of frequency bands for which longwave
!                          emissivities are defined
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    allocate the arrays used to define the longwave cloud radiative
!    properties. initialize to appropriate non-cloudy values.
!--------------------------------------------------------------------
      nlwcldb = Cldrad_control%nlwcldb
      if (Cldrad_control%do_ica_calcs) then
        allocate (Cldrad_props%emmxolw  (ix, jx, kx, nlwcldb,nlwcldb) )
        allocate (Cldrad_props%emrndlw  (ix, jx, kx, nlwcldb,nlwcldb) )
        allocate (Cldrad_props%abscoeff (ix, jx, kx, nlwcldb,nlwcldb) )
        allocate (Cldrad_props%cldemiss (ix, jx, kx, nlwcldb,nlwcldb) )
      else
        allocate (Cldrad_props%emmxolw  (ix, jx, kx, nlwcldb,1) )
        allocate (Cldrad_props%emrndlw  (ix, jx, kx, nlwcldb,1) )
        allocate (Cldrad_props%abscoeff (ix, jx, kx, nlwcldb,1) )
        allocate (Cldrad_props%cldemiss (ix, jx, kx, nlwcldb,1) )
      endif
      Cldrad_props%emmxolw           = 1.0E+00
      Cldrad_props%emrndlw           = 1.0E+00
      Cldrad_props%abscoeff          = 0.0E+00
      Cldrad_props%cldemiss          = 0.0E+00

!---------------------------------------------------------------------
!    allocate and initialize the microphysically-based shortwave cloud 
!    radiative properties.
!---------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro) then
        n_esfsw_bands = Solar_spect%nbands 
        if (Cldrad_control%do_ica_calcs) then
          allocate (Cldrad_props%cldext  (ix, jx, kx, n_esfsw_bands, &
                    n_esfsw_bands) )
          allocate (Cldrad_props%cldsct  (ix, jx, kx, n_esfsw_bands, &
                    n_esfsw_bands) )
          allocate (Cldrad_props%cldasymm(ix, jx, kx, n_esfsw_bands, &
                    n_esfsw_bands) )
        else
          allocate (Cldrad_props%cldext  (ix, jx, kx, n_esfsw_bands, 1))
          allocate (Cldrad_props%cldsct  (ix, jx, kx, n_esfsw_bands, 1))
          allocate (Cldrad_props%cldasymm(ix, jx, kx, n_esfsw_bands, 1))
        endif
        Cldrad_props%cldsct            = 0.0E+00
        Cldrad_props%cldext            = 0.0E+00
        Cldrad_props%cldasymm          = 1.0E+00

!---------------------------------------------------------------------
!    allocate and initialize the bulk-based shortwave cloud 
!    radiative properties.
!---------------------------------------------------------------------
      else
        allocate (Cldrad_props%cirabsw (ix, jx, kx) )
        allocate (Cldrad_props%cirrfsw (ix, jx, kx) )
        allocate (Cldrad_props%cvisrfsw(ix, jx, kx) )
        Cldrad_props%cirrfsw (:,:,:) = 0.0E+00
        Cldrad_props%cvisrfsw(:,:,:) = 0.0E+00
        Cldrad_props%cirabsw (:,:,:) = 0.0E+00
      endif

!---------------------------------------------------------------------
!    allocate and initialize the cloud radiative properties associated
!    with large-scale clouds for those cases where mesoscale and cell-
!    scale clouds may also be present.
!---------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro) then
        allocate (Lscrad_props%cldext(ix, jx, kx, n_esfsw_bands) )
        allocate (Lscrad_props%cldsct(ix, jx, kx, n_esfsw_bands) )
        allocate (Lscrad_props%cldasymm(ix, jx, kx, n_esfsw_bands) )
        Lscrad_props%cldext   = 0.
        Lscrad_props%cldsct   = 0.
        Lscrad_props%cldasymm = 1.
      endif
      allocate (Lscrad_props%abscoeff (ix, jx, kx, nlwcldb) )
      Lscrad_props%abscoeff = 0.

!---------------------------------------------------------------------
!    allocate and initialize the cloud radiative properties associated
!    with mesoscale and cellscale clouds when they are present.
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then
        allocate (Cellrad_props%cldext(ix, jx, kx, n_esfsw_bands) )
        allocate (Cellrad_props%cldsct(ix, jx, kx, n_esfsw_bands) )
        allocate (Cellrad_props%cldasymm(ix, jx, kx, n_esfsw_bands) )
        allocate (Cellrad_props%abscoeff (ix, jx, kx, nlwcldb))
        allocate (Mesorad_props%cldext(ix, jx, kx, n_esfsw_bands) )
        allocate (Mesorad_props%cldsct(ix, jx, kx, n_esfsw_bands) )
        allocate (Mesorad_props%cldasymm(ix, jx, kx, n_esfsw_bands) )
        allocate (Mesorad_props%abscoeff (ix, jx, kx, nlwcldb) )
        Cellrad_props%cldext   = 0.
        Cellrad_props%cldsct   = 0.
        Cellrad_props%cldasymm = 1.
        Cellrad_props%abscoeff = 0.
        Mesorad_props%cldext   = 0.
        Mesorad_props%cldsct   = 0.
        Mesorad_props%cldasymm = 1.
        Mesorad_props%abscoeff = 0.
      endif

!---------------------------------------------------------------------
!    allocate and initialize the cloud radiative properties associated
!    with the clouds from the  uw shallow convection parameterization
!    when they are present.
!---------------------------------------------------------------------
       if (Cldrad_control%do_uw_clouds) then
         allocate (Shallowrad_props%cldext(ix, jx, kx, n_esfsw_bands) )
        allocate (Shallowrad_props%cldsct(ix, jx, kx, n_esfsw_bands) )
        allocate (Shallowrad_props%cldasymm(ix, jx, kx, n_esfsw_bands) )
        allocate (Shallowrad_props%abscoeff (ix, jx, kx, nlwcldb))
        Shallowrad_props%cldext   = 0.
        Shallowrad_props%cldsct   = 0.
        Shallowrad_props%cldasymm = 1.
        Shallowrad_props%abscoeff = 0.
      endif

!----------------------------------------------------------------------


end subroutine initialize_cldrad_props         



!#####################################################################
! <SUBROUTINE NAME="combine_cloud_properties">
!  <OVERVIEW>
!   combine_cloud_properties produces cloud-radiative properties fields
!    for the total-cloud field in each grid box.
!  </OVERVIEW>
!  <DESCRIPTION>
!   combine_cloud_properties produces cloud-radiative properties fields
!    for the total-cloud field in each grid box, using as input the 
!    properties and characteristics of the various cloud types that may 
!    be present (large-scale, donner mesoscale and cell-scale, uw 
!    shallow).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call combine_cloud_properties (is, js, Rad_time, deltaz,    &
!                                     Lsc_microphys, Meso_microphys,  &
!                                     Cell_microphys,   &
!                                     Shallow_microphys, &
!                                     Lscrad_props,   &
!                                     Mesorad_props,  Cellrad_props,  &
!                                     Shallowrad_props, &
!                                     Cldrad_props)
!  </TEMPLATE>
!  <IN NAME="ix, jx, kx" TYPE="integer">
!       ix             size of i dimension of physics window
!       jx             size of j dimension of physics window
!       kx             size of k dimension of physics window
!  </IN>
!  <IN NAME="Lsc_microphys" TYPE="microphysics_type">
!    microphysical specification for large-scale 
!                      clouds
!  </IN>
!  <IN NAME="Meso_microphys" TYPE="microphysics_type">
!    microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!  </IN>
!  <IN NAME="Cell_microphys" TYPE="microphysics_type">
!    microphysical specification for  convective cell
!                      clouds associated with donner convection
!  </IN>
!  <IN NAME="Shallow_microphys" TYPE="microphysics_type">
!    microphysical specification for 
!                      clouds associated with uw shallow convection
!  </IN>
!  <IN NAME="Lscrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the large-scale 
!                      clouds   
!  </IN>
!  <IN NAME="Mesorad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the meso-scale
!                      clouds   
!  </IN>
!  <IN NAME="Cellrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the convective cell
!                      clouds associated with donner convection 
!  </IN>
!  <IN NAME="Shallowrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the 
!                      clouds associated with uw shallow convection 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties on model grid
!  </INOUT>
! </SUBROUTINE>
!
subroutine combine_cloud_properties (is, js, Rad_time, Time_next,  &
                                     deltaz,  Cld_spec,   &
                                     Lsc_microphys, Meso_microphys,  &
                                     Cell_microphys,   &
                                     Shallow_microphys, &
                                     Lscrad_props,   &
                                     Mesorad_props,  Cellrad_props,  &
                                     Shallowrad_props, &
                                     Cldrad_props)

!----------------------------------------------------------------------
!    combine_cloud_properties produces cloud-radiative properties fields
!    for the total-cloud field in each grid box, using as input the 
!    properties and characteristics of the various cloud types that may 
!    be present (large-scale, donner mesoscale and cell-scale, uw 
!    shallow).
!----------------------------------------------------------------------

integer,                        intent(in)    :: is, js
type(time_type),                intent(in)    :: Rad_time, Time_next
real, dimension(:,:,:),         intent(in)    :: deltaz
type(cld_specification_type),   intent(inout) :: Cld_spec
type(microphysics_type),        intent(in)    :: Lsc_microphys, &
                                                 Meso_microphys, &
                                                 Cell_microphys, &
                                                 Shallow_microphys
type(microrad_properties_type), intent(in)    :: Lscrad_props,  &
                                                 Mesorad_props,  &
                                                 Cellrad_props,&
                                                 Shallowrad_props
type(cldrad_properties_type), intent(inout)   :: Cldrad_props

!----------------------------------------------------------------------
!   intent(in) variables:
!
!       Lsc_microphys  microphysical specification for large-scale 
!                      clouds
!                      [ microphysics_type ]
!       Meso_microphys microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!                      [ microphysics_type ]
!       Cell_microphys microphysical specification for convective cell
!                      clouds associated with donner convection
!                      [ microphysics_type ]
!       Shallow_microphys 
!                      microphysical specification for 
!                      clouds associated with uw shallow convection
!                      [ microphysics_type ]
!       Lscrad_props   cloud radiative properties for the large-scale 
!                      clouds   
!                      [ microrad_properties_type ]
!       Mesorad_props  cloud radiative properties for meso-scale 
!                      clouds associated with donner convection   
!                      [ microrad_properties_type ]
!       Cellrad_props  cloud radiative properties for convective cell
!                      clouds associated with donner convection  
!                      [ microrad_properties_type ]
!       Shallowrad_props  
!                      cloud radiative properties for
!                      clouds associated with uw shallow convection  
!                      [ microrad_properties_type ]
!
!    intent(inout) variables:
!
!      Cldrad_props    cloud radiative properties on model grid,
!                      [ cldrad_properties_type ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    call comb_cldprops_calc with the appropriate arguments dependent 
!    upon the cloud / convection scheme which is active.
!---------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds .and.    &
          Cldrad_control%do_uw_clouds .and. &
          Cldrad_control%do_donner_deep_clouds) then

!----------------------------------------------------------------------
!    if strat_cloud, donner_deep and uw shallow are all active, then 
!    lw and sw cloud radiative properties are microphysically based, 
!    and large-scale, donner mesoscale and cell-scale, and uw shallow
!    cloud properties are available. call comb_cldprops_calc to combine
!    these into a single set of cloud radiative properties to be used 
!    by the radiation package. 
!---------------------------------------------------------------------
        call comb_cldprops_calc (is, js, Rad_time, Time_next, deltaz,  &
                                 Cld_spec%stoch_cloud_type, &
                                 Cldrad_props%cldext,   &
                                 Cldrad_props%cldsct,   &
                                 Cldrad_props%cldasymm,  &
                                 Cldrad_props%abscoeff,   &
                                 Lsc_microphys = Lsc_microphys, &
                                 Meso_microphys = Meso_microphys, &
                                 Cell_microphys = Cell_microphys, &
                                 Shallow_microphys = Shallow_microphys,&
                                 Lscrad_props=Lscrad_props,  &
                                 Mesorad_props = Mesorad_props, &
                                 Cellrad_props = Cellrad_props, &
                                Shallowrad_props = Shallowrad_props)
     else if (Cldrad_control%do_strat_clouds .and.    &
             Cldrad_control%do_donner_deep_clouds) then
 

!----------------------------------------------------------------------
!    if strat_cloud and donner_deep are both active, then both lw and 
!    sw cloud radiative properties are microphysically based, and large-
!    scale, mesoscale and cell-scale properties are available. call
!    comb_cldprops_calc to combine these into a single set of cloud
!    radiative properties to be used by the radiation package. 
!---------------------------------------------------------------------
        call comb_cldprops_calc (is, js, Rad_time, Time_next, deltaz,   &
                                 Cld_spec%stoch_cloud_type, &
                                 Cldrad_props%cldext,   &
                                 Cldrad_props%cldsct,   &
                                 Cldrad_props%cldasymm,  &
                                 Cldrad_props%abscoeff,   &
                                 Lsc_microphys = Lsc_microphys, &
                                 Meso_microphys = Meso_microphys, &
                                 Cell_microphys = Cell_microphys, &
                                 Lscrad_props=Lscrad_props,  &
                                 Mesorad_props = Mesorad_props, &
                                 Cellrad_props = Cellrad_props)

      else if (Cldrad_control%do_strat_clouds .and.    &
               Cldrad_control%do_uw_clouds) then

!----------------------------------------------------------------------
!    if strat_cloud and uw shallow are both active, then both lw and 
!    sw cloud radiative properties are microphysically based, and large-
!    scale and uw shallow cloud properties are available. call
!    comb_cldprops_calc to combine these into a single set of cloud
!    radiative properties to be used by the radiation package. 
!---------------------------------------------------------------------
        call comb_cldprops_calc (is, js, Rad_time, Time_next, deltaz,  &
                                 Cld_spec%stoch_cloud_type, &
                                  Cldrad_props%cldext,   &
                               Cldrad_props%cldsct,   &
                                 Cldrad_props%cldasymm,  &
                                  Cldrad_props%abscoeff,   &
                                  Lsc_microphys = Lsc_microphys, &
                                 Shallow_microphys = Shallow_microphys,&
                                  Lscrad_props=Lscrad_props,  &
                                  Shallowrad_props = Shallowrad_props)

   else if (Cldrad_control%do_uw_clouds .and.    &
            Cldrad_control%do_donner_deep_clouds) then
 
!----------------------------------------------------------------------
!    if uw shallow and donner_deep clouds are both active, then both 
!    lw and sw cloud radiative properties are microphysically based, 
!    and donner mesoscale and cell-scale and uw shallow cloud properties
!    are available. call comb_cldprops_calc to combine these into a 
!    single set of cloud radiative properties to be used by the 
!    radiation package. 
!---------------------------------------------------------------------
      call comb_cldprops_calc (is, js, Rad_time, Time_next, deltaz,  &
                                 Cld_spec%stoch_cloud_type, &
                                Cldrad_props%cldext,   &
                                 Cldrad_props%cldsct,   &
                                Cldrad_props%cldasymm,  &
                                  Cldrad_props%abscoeff,   &
                                Meso_microphys = Meso_microphys, &
                                 Cell_microphys = Cell_microphys, &
                                 Shallow_microphys = Shallow_microphys,&
                                 Mesorad_props = Mesorad_props, &
                                 Cellrad_props = Cellrad_props, &
                                Shallowrad_props=Shallowrad_props)
      

!---------------------------------------------------------------------
!    if donner_deep alone is active, then the mesoscale
!    and cell-scale properties must be combined. 
!----------------------------------------------------------------------
      else if (Cldrad_control%do_donner_deep_clouds) then
        call comb_cldprops_calc (is, js, Rad_time, Time_next, deltaz,  &
                                 Cld_spec%stoch_cloud_type, &
                                 Cldrad_props%cldext,   &
                                 Cldrad_props%cldsct,   &
                                 Cldrad_props%cldasymm, &
                                 Cldrad_props%abscoeff,   &
                                 Meso_microphys = Meso_microphys, &
                                 Cell_microphys = Cell_microphys, &
                                 Mesorad_props = Mesorad_props, &
                                 Cellrad_props = Cellrad_props)

!---------------------------------------------------------------------
!    if uw shallow alone is active, then total cloud values are 
!    defined as the uw shallow values.
!----------------------------------------------------------------------
     else if (Cldrad_control%do_uw_clouds) then
       if (Cldrad_control%do_sw_micro) then
         Cldrad_props%cldsct(:,:,:,:,1) =    &
                                      Shallowrad_props%cldsct(:,:,:,:)
         Cldrad_props%cldext(:,:,:,:,1) =    &
                                      Shallowrad_props%cldext(:,:,:,:)
         Cldrad_props%cldasymm(:,:,:,:,1) =  &
                                     Shallowrad_props%cldasymm(:,:,:,:)
      endif
      if (Cldrad_control%do_lw_micro) then
        Cldrad_props%abscoeff(:,:,:,:,1) =   &
                                  Shallowrad_props%abscoeff(:,:,:,:)
     endif
      
!----------------------------------------------------------------------
!    if microphysically-based properties have been generated without
!    donner_deep being active, total-cloud values are defined as the
!    large-scale cloud values.
!----------------------------------------------------------------------
      else if (Cldrad_control%do_strat_clouds) then
        if (Cldrad_control%do_sw_micro) then
          Cldrad_props%cldsct(:,:,:,:,1) = Lscrad_props%cldsct(:,:,:,:)
          Cldrad_props%cldext(:,:,:,:,1) = Lscrad_props%cldext(:,:,:,:)
          Cldrad_props%cldasymm(:,:,:,:,1) =  &
                                         Lscrad_props%cldasymm(:,:,:,:)
        endif
        if (Cldrad_control%do_lw_micro) then
          Cldrad_props%abscoeff(:,:,:,:,1) =   &
                                      Lscrad_props%abscoeff(:,:,:,:)
        endif
      endif

!--------------------------------------------------------------------



end subroutine  combine_cloud_properties 



!####################################################################
! <SUBROUTINE NAME="cloudrad_package_dealloc">
!  <OVERVIEW>
!   Subroutine to deallocate the space cloud radiative properties use
!   in the model
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to deallocate the space cloud radiative properties use
!   in the model
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  cloudrad_package_dealloc (Lscrad_props, Mesorad_props,  &
!                                   Cellrad_props)
!  </TEMPLATE>
!  <IN NAME="Lscrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the large-scale 
!                      clouds   
!  </IN>
!  <IN NAME="Mesorad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the meso-scale
!                      clouds   
!  </IN>
!  <IN NAME="Cellrad_props" TYPE="cldrad_prperties_type">
!   cldrad_prperties_type variable containing the cloud radiative
!   properties for the donner cell clouds
!  </IN>
!  <IN NAME="Shallowrad_props" TYPE="cldrad_properties_type">
!   cldrad_prperties_type variable containing the cloud radiative
!   properties for the uw shallow clouds
!  </IN>
! </SUBROUTINE>
!
subroutine cloudrad_package_dealloc (Lscrad_props, Mesorad_props,   &
                                     Cellrad_props, Shallowrad_props)

!---------------------------------------------------------------------
!    cloudrad_package_dealloc deallocates the components of the local
!    derived-type variables.
!---------------------------------------------------------------------
        
type(microrad_properties_type), intent(inout) :: Lscrad_props,  &
                                                 Mesorad_props, &
                                                 Cellrad_props, &
                                                 Shallowrad_props
!---------------------------------------------------------------------
!   intent(in) variables:
!
!       Lscrad_props   cloud radiative properties for the large-scale 
!                      clouds   
!                      [ microrad_properties_type ]
!       Mesorad_props  cloud radiative properties for meso-scale 
!                      clouds associated with donner convection   
!                      [ microrad_properties_type ]
!       Cellrad_props  cloud radiative properties for convective cell
!                      clouds associated with donner convection  
!                      [ microrad_properties_type ]
!     Shallowrad_props  cloud radiative properties for 
!                      clouds associated with uw shallow convection  
!                      [ microrad_properties_type ]
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    deallocate the elements of Lscrad_props.
!---------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro) then
        deallocate (Lscrad_props%cldext    )
        deallocate (Lscrad_props%cldsct    )
        deallocate (Lscrad_props%cldasymm  )
      endif
      deallocate (Lscrad_props%abscoeff    )

!--------------------------------------------------------------------
!    deallocate the elements of Cellrad_props and Mesorad_props.
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then
        deallocate (Cellrad_props%cldext   )
        deallocate (Cellrad_props%cldsct   )
        deallocate (Cellrad_props%cldasymm )
        deallocate (Cellrad_props%abscoeff )
        deallocate (Mesorad_props%cldext   )
        deallocate (Mesorad_props%cldsct   )
        deallocate (Mesorad_props%cldasymm )
        deallocate (Mesorad_props%abscoeff )
      endif

!--------------------------------------------------------------------
!    deallocate the elements of Shallowrad_props.
!---------------------------------------------------------------------
      if (Cldrad_control%do_uw_clouds) then
        deallocate (Shallowrad_props%cldext   )
        deallocate (Shallowrad_props%cldsct   )
        deallocate (Shallowrad_props%cldasymm )
        deallocate (Shallowrad_props%abscoeff )
      endif

!---------------------------------------------------------------------



end subroutine cloudrad_package_dealloc



!###################################################################





                   end module cloudrad_package_mod



                 module cloud_spec_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    cloud_spec_mod defines the variables that are used in a partic-
!    ular cloud parameterization to specify the cloud location, cloud
!    type and cloud magnitude for the active cloud parameterization(s).
! </OVERVIEW>
! <DESCRIPTION>
!    if microphysically-based radiative properties are desired, then
!    cloud_spec_mod also provides the microphysical parameters used in
!    determining the radiative properties, either from the cloud scheme
!    itself if they are present, or from a prescribed formula based on
!    prescribed water paths for high, middle and low clouds.
! </DESCRIPTION>

!   shared modules:

use time_manager_mod,         only: time_type, time_manager_init, &
                                    set_time, operator (+)
use mpp_mod,                  only: input_nml_file
use fms_mod,                  only: open_namelist_file, mpp_pe, &
                                    mpp_root_pe, stdlog,  fms_init, &
                                    write_version_number, file_exist, & 
                                    check_nml_error, error_mesg,   &
                                    FATAL, NOTE, close_file
use tracer_manager_mod,       only:         &
!                                   tracer_manager_init,  &
                                    get_tracer_index, NO_TRACER
use field_manager_mod,        only:       &
                                    field_manager_init, &
                                    MODEL_ATMOS
use data_override_mod,        only: data_override
use random_numbers_mod,    only:  randomNumberStream,   &
                                  initializeRandomNumberStream, &
                                  getRandomNumbers,             &
                                  constructSeed
use cloud_generator_mod,   only:  cloud_generator_init, &
                                  cloud_generator_end
use constants_mod,         only : radian, RDGAS

! shared radiation package modules:

use rad_utilities_mod,        only: rad_utilities_init, &
                                    cld_specification_type, &
                                    atmos_input_type, &
                                    surface_type, &
                                    Rad_control, &
                                    microphysics_type,  &         
                                    Cldrad_control
use esfsw_parameters_mod,     only: esfsw_parameters_init, Solar_spect

! interface modules to various cloud parameterizations:

use strat_clouds_W_mod,       only: strat_clouds_W_init,   &
                                    strat_clouds_amt, strat_clouds_W_end
use diag_clouds_W_mod,        only: diag_clouds_W_init,   &
                                    diag_clouds_amt, &
                                    diag_clouds_W_end
use zetac_clouds_W_mod,       only: zetac_clouds_W_init,   &
                                    zetac_clouds_amt, &
                                    zetac_clouds_W_end
use specified_clouds_W_mod,   only: specified_clouds_W_init, &
                                    specified_clouds_amt, &
                                    specified_clouds_W_end
use rh_based_clouds_mod,      only: rh_based_clouds_init,  &
                                    rh_clouds_amt, &
                                    rh_based_clouds_end
use donner_deep_clouds_W_mod, only: donner_deep_clouds_W_init, &
                                    donner_deep_clouds_amt, &
                                    donner_deep_clouds_W_end
use uw_clouds_W_mod,          only: uw_clouds_W_init, &
                                    uw_clouds_amt, &
                                    uw_clouds_W_end
use mgrp_prscr_clds_mod,      only: mgrp_prscr_clds_init, &
                                    prscr_clds_amt,  & 
                                    mgrp_prscr_clds_end 
use standalone_clouds_mod,    only: standalone_clouds_init, &
                                    standalone_clouds_amt, &
                                    standalone_clouds_end
                                 
!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    cloud_spec_mod defines the variables that are used in a partic-
!    ular cloud parameterization to specify the cloud location, cloud
!    type and cloud magnitude for the active cloud parameterization(s).
!    if microphysically-based radiative properties are desired, then
!    cloud_spec_mod also provides the microphysical parameters used in
!    determining the radiative properties, either from the cloud scheme
!    itself if they are present, or from a prescribed formula based on
!    prescribed water paths for high, middle and low clouds.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: cloud_spec.F90,v 17.0.8.1.2.1.2.1 2010/08/30 20:33:31 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public          &
         cloud_spec_init, cloud_spec,    &
         cloud_spec_dealloc, cloud_spec_end

private    &

!  called from cloud_spec:
         initialize_cldamts, microphys_presc_conc,  &
         combine_cloud_properties


!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16)  ::      &
              cloud_type_form = '     ' ! cloud parameterization being 
                                        ! used; either 'strat', 'rh', 
                                        ! 'deep',  'stratdeep', 'zonal',
                                        ! 'obs', 'prescribed', 'diag', 
                                        ! 'none', 'specified', 'zetac'
                                        ! 'specified_strat', 'stratuw',
                                        ! 'stratdeepuw', 'uw', 'deepuw
                                        ! or 'not_sea_esf'       
real :: wtr_cld_reff=10.                ! assumed cloud drop efective
                                        ! radius [ microns ]  
real :: ice_cld_reff=50.                ! assumed ice cloud effective
                                        ! size [ microns ]
real :: rain_reff=250.                  ! assumed rain drop effective
                                        ! radius [ microns ]
character(len=16) :: overlap_type = 'random'    
                                        ! cloud overlap assumption; 
                                        ! allowable values are 'random'
                                        ! or 'max-random'  
logical :: doing_data_override=.false.
logical :: do_fu2007 = .false.
logical :: do_rain   = .false. !sjl
logical :: do_snow   = .false. !miz
logical :: do_graupel  = .false. !sjl
logical :: force_use_of_temp_for_seed = .false.  
                                        ! if true, when using stochastic 
                                        ! clouds, force the seed to use 
                                        ! top-model-level temps as input to
                                        ! random number generator
                                        ! (needed for some 
                                        ! specialized applications)

namelist /cloud_spec_nml / cloud_type_form, wtr_cld_reff,   &
                           ice_cld_reff, rain_reff, overlap_type, &
                           doing_data_override, do_fu2007,    &
                           do_rain, do_snow, do_graupel, &
                           force_use_of_temp_for_seed

!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

!--------------------------------------------------------------------
!    assumed water paths.
!--------------------------------------------------------------------
real   ::  lwpath_hi  = 6.313929   ! assumed water path for high clouds
                                   ! [ grams / m**2 ]
real   ::  lwpath_mid = 18.94179   ! assumed water path for middle 
                                   ! clouds [ grams / m**2 ]
real   ::  lwpath_low = 75.76714   ! assumed water path for low clouds
                                   ! [ grams / m**2 ]

!---------------------------------------------------------------------
!    logical  flags.

logical :: module_is_initialized = .false.   ! module initialized ?

!---------------------------------------------------------------------
!    time-step related constants.

integer :: num_pts       !  number of grid columns processed so far that
                         !  have cloud data present (used to identify
                         !  module coldstart condition)
integer :: tot_pts       !  total number of grid columns in the 
                         !  processor's domain

!---------------------------------------------------------------------
!     indices for cloud tracers

integer :: nql           ! tracer index for liquid water
integer :: nqi           ! tracer index for ice water
integer :: nqa           ! tracer index for cloud area
integer :: nqn           ! tracer index for cloud droplet number
integer :: nqr, nqs, nqg ! tracer index for rainwat, snowwat and graupel           

!----------------------------------------------------------------------
!   variables needed for random number seed:
!----------------------------------------------------------------------
real, dimension(:,:), allocatable  :: lats, lons ! lat and lon of columns
                                               ! in this processor's
                                               ! domain [ degrees ]

!---------------------------------------------------------------------
!     miscellaneous variables:

integer :: num_slingo_bands  ! number of radiative bands over which 
                             ! cloud optical depth is calculated in the
                             ! gordon diag_cloud parameterization
integer :: id, jd, kmax

!----------------------------------------------------------------------
!----------------------------------------------------------------------



                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="cloud_spec_init">
!  <OVERVIEW>
!   Contructor of cloud_spec_package module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Contructor of cloud_spec_package module
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_spec_init ( pref, lonb, latb, axes, Time)
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!   reference pressure levels containing two reference pressure profiles 
!                 for use in defining transmission functions [ Pa ]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   the longitude array of the model grid box corners
!  </IN>
!  <IN NAME="latb" TYPE="real">
!   the latitude array of the model grid box corners
!  </IN>
!  <IN NAME="axes" TYPE="real">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
! </SUBROUTINE>
! 
subroutine cloud_spec_init (pref, lonb, latb, axes, Time)

!---------------------------------------------------------------------
!    cloud_spec_init is the constructor for cloud_spec_mod.
!---------------------------------------------------------------------

real, dimension(:,:),     intent(in)   ::  pref        
real, dimension(:,:),     intent(in)   ::  lonb, latb
integer, dimension(4),    intent(in)   ::  axes
type(time_type),          intent(in)   ::  Time

!-------------------------------------------------------------------
!    intent(in) variables:
!
!       pref      array containing two reference pressure profiles 
!                 for use in defining transmission functions [ Pa ]
!       lonb      array of model longitudes at cell corners [ radians ]
!       latb      array of model latitudes at cell corners [radians]
!       axes      diagnostic variable axes
!       Time      current time [time_type(days, seconds)]
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:
 
      integer   ::   unit, ierr, io, logunit
      integer   ::   ndum, i, j, ii, jj
      

!--------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      ierr     error code
!      io       error status returned from io operation  
!      ndum     dummy argument needed for call to field_manager_init
!
!--------------------------------------------------------------------
 
!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call rad_utilities_init
      call field_manager_init (ndum)
      call esfsw_parameters_init
!  not yet compliant:
!     call tracer_manager_init  ! not public
 
!---------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=cloud_spec_nml, iostat=io)
      ierr = check_nml_error(io,"cloud_spec_nml")
#else
!---------------------------------------------------------------------
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read (unit, nml=cloud_spec_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'cloud_spec_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!----------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
           write (logunit, nml=cloud_spec_nml)

      id = size(lonb,1) - 1
      jd = size(latb,2) - 1
      kmax = size(pref,1) - 1

!--------------------------------------------------------------------
!    verify a valid type of cloud overlap. set logical variables
!    based on the namelist value.
!--------------------------------------------------------------------
      if (trim(overlap_type) == 'random') then
        Cldrad_control%do_random_overlap = .true.
      else if (trim(overlap_type) == 'max-random') then
        Cldrad_control%do_max_random_overlap = .true.
      else
        call error_mesg ('cloud_spec_mod',  &
         ' invalid specification of overlap_type', FATAL)
      endif

!-------------------------------------------------------------------
!    set the variables indicating that the above control variables have
!    been set.
!--------------------------------------------------------------------
      Cldrad_control%do_random_overlap_iz = .true.
      Cldrad_control%do_max_random_overlap_iz = .true.

!--------------------------------------------------------------------
!    if the sea-esf radiation package is not being used, then 
!    cloud_type_form will have been set to 'not_sea_esf'. in such a
!    case, the clouds will be specified internally within the 
!    radiation_driver_mod, so simply return.
!--------------------------------------------------------------------
      if (trim(cloud_type_form) == 'not_sea_esf')  return
        
!-------------------------------------------------------------------
!    verify that the nml variable cloud_type_form specifies a valid
!    cloud parameterization. set the appropriate logical control
!    variable(s) to .true.. call the constructor modules for the
!    specific cloud scheme(s) requested.
!-------------------------------------------------------------------
      if (trim(cloud_type_form) == 'strat')  then

!-------------------------------------------------------------------
!    cloud fractions, heights are predicted by the model based on klein 
!    parameterization. strat is an acceptable option both for standalone
!    and gcm applications.
!-------------------------------------------------------------------
        Cldrad_control%do_strat_clouds = .true.
        call strat_clouds_W_init(latb, lonb)

      else if (trim(cloud_type_form) == 'specified_strat')  then
        Cldrad_control%do_specified_strat_clouds = .true.
        Cldrad_control%do_strat_clouds = .true.
        call strat_clouds_W_init(latb, lonb)
        call standalone_clouds_init (pref, lonb, latb)

!-------------------------------------------------------------------
!    cloud fractions, heights are diagnosed based on model relative 
!    humidity.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form)  == 'rh')   then
            Cldrad_control%do_rh_clouds = .true.
            call rh_based_clouds_init 

!-------------------------------------------------------------------
!    cloud fractions, heights are predicted by the donner deep cloud 
!    (cell cloud, anvil cloud) scheme.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form) == 'deep')  then
            Cldrad_control%do_donner_deep_clouds = .true.
            call donner_deep_clouds_W_init (pref, lonb, latb,   &
                                            axes, Time)

!------------------------------------------------------------------
!    cloud fractions, heights are provided by the uw_conv shallow
!    convection scheme  
!-------------------------------------------------------------------
          else if (trim(cloud_type_form) == 'uw')  then
            Cldrad_control%do_uw_clouds = .true.
            call uw_clouds_W_init (pref, lonb, latb,   &
                                             axes, Time)

!-------------------------------------------------------------------
!    cloud fractions, heights are a combination of the donner
!    deep cloud (cell cloud, anvil cloud) and klein large-scale cloud
!    parameterizations.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form) == 'stratdeep')  then
            Cldrad_control%do_strat_clouds = .true.
            Cldrad_control%do_donner_deep_clouds = .true.
            call strat_clouds_W_init(latb, lonb)
            call donner_deep_clouds_W_init (pref, lonb, latb,   &
                                            axes, Time)

!-------------------------------------------------------------------
!    cloud fractions, heights are provided by the donner deep convection
!    (cell cloud, anvil cloud) and uw_conv shallow convection
!    cloud parameterizations.
!-------------------------------------------------------------------
         else if (trim(cloud_type_form) == 'deepuw')  then
           Cldrad_control%do_donner_deep_clouds = .true.
           Cldrad_control%do_uw_clouds = .true.
           call donner_deep_clouds_W_init (pref, lonb, latb,   &
                                             axes, Time)
           call uw_clouds_W_init (pref, lonb, latb,   &
                                            axes, Time)

!-------------------------------------------------------------------
!    cloud fractions, heights are provided by the klein large-scale
!    and uw_conv shallow convection cloud parameterizations.
!-------------------------------------------------------------------
        else if (trim(cloud_type_form) == 'stratuw')  then
          Cldrad_control%do_strat_clouds = .true.
          Cldrad_control%do_uw_clouds = .true.
          call strat_clouds_W_init(latb, lonb)
          call uw_clouds_W_init (pref, lonb, latb,   &
                                             axes, Time)

!-------------------------------------------------------------------
!    cloud fractions, heights are provided by the klein large-scale
!    the donner deep convection (cell cloud, anvil cloud) and the
!    uw_conv shallow convection cloud parameterizations.
!-------------------------------------------------------------------
       else if (trim(cloud_type_form) == 'stratdeepuw')  then
         Cldrad_control%do_strat_clouds = .true.
         Cldrad_control%do_donner_deep_clouds = .true.
         Cldrad_control%do_uw_clouds = .true.
         call strat_clouds_W_init(latb, lonb)
         call donner_deep_clouds_W_init (pref, lonb, latb,   &
                                            axes, Time)
         call uw_clouds_W_init (pref, lonb, latb,   &
                                            axes, Time)

!---------------------------------------------------------------
!    cloud fractions, heights are prescribed as zonally uniform using
!    the original fms specification.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form) == 'zonal')  then
            Cldrad_control%do_zonal_clouds = .true.
            call specified_clouds_W_init (lonb, latb)

!-------------------------------------------------------------------
!    cloud fractions, heights are based on observed data set.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form) == 'obs')  then
            Cldrad_control%do_obs_clouds = .true.
            call specified_clouds_W_init (lonb, latb)

!-------------------------------------------------------------------
!    cloud fractions, heights are prescribed as zonally invariant, using
!    the formulation from skyhi, with the ability to use a prescribed
!    microphysics. WILL ONLY WORK WITH REGULAR LAT/LON GRID
!-------------------------------------------------------------------
          else if (trim(cloud_type_form)  == 'prescribed')  then
            Cldrad_control%do_mgroup_prescribed = .true.
            call mgrp_prscr_clds_init (pref, latb(1,:))

!-------------------------------------------------------------------
!    model is run with gordon diagnostic clouds.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form)  == 'diag')  then
            Cldrad_control%do_diag_clouds = .true.
            call diag_clouds_W_init (num_slingo_bands)

!-------------------------------------------------------------------
!    model is run with zetac clouds.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form)  == 'zetac')  then
            Cldrad_control%do_zetac_clouds = .true.
            call zetac_clouds_W_init 
 
!-------------------------------------------------------------------
!    model is run without clouds.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form) == 'none')  then
            Cldrad_control%do_no_clouds = .true.

!-------------------------------------------------------------------
!    model is run with specified clouds and cloud properties.
!-------------------------------------------------------------------
          else if (trim(cloud_type_form)  == 'specified')  then
            Cldrad_control%do_specified_clouds = .true.
            call standalone_clouds_init (pref, lonb, latb)

!-------------------------------------------------------------------
!    failure message if none of the above options was chosen.
!-------------------------------------------------------------------
          else
            call error_mesg ('cloud_spec_mod',  &
              'invalid cloud_type_form specified', FATAL)
      endif  ! (strat)

!--------------------------------------------------------------------
!    define the dimensions of the model subdomain assigned to the 
!    processor.
!--------------------------------------------------------------------
      tot_pts = (size(latb,2)-1)*(size(lonb,1)-1)

!--------------------------------------------------------------------
!    determine if the current run is cold-starting this module. if a 
!    restart file is present, then this is not a coldstart. in that case
!    set num_pts to tot_pts so that if cloud data is not available an 
!    error message can be generated. if this is a coldstart, cloud data
!    will not be available until num_pts equals or exceeds tot_pts, so
!    continue processing without issuing an error message. 
!--------------------------------------------------------------------
      if (file_exist ('INPUT/tracer_cld_amt.res') .or.  &
          file_exist ('INPUT/strat_cloud.res') ) then
        num_pts = tot_pts
      else
        num_pts = 0
      endif

!---------------------------------------------------------------------
!    obtain the tracer indices for the strat_cloud variables when
!    running gcm.
!---------------------------------------------------------------------
        if (Cldrad_control%do_strat_clouds .or.  &
            Cldrad_control%do_zetac_clouds) then
          nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
          nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
          nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )

          if (do_rain) then !sjl
             nqr = get_tracer_index ( MODEL_ATMOS, 'rainwat' )
             if (nqr < 0 ) call error_mesg ('cloud_spec_mod', &
                'rainwat tracer not found, but do_rain is true', FATAL)
          end if
          if (do_snow) then !miz
             nqs = get_tracer_index ( MODEL_ATMOS, 'snowwat' )
             if (nqs < 0 ) call error_mesg ('cloud_spec_mod', &
                'snowwat tracer not found, but do_snow is true', FATAL)
          end if
          if (do_graupel) then !sjl
             nqg = get_tracer_index ( MODEL_ATMOS, 'graupel' )
             if (nqg < 0 ) call error_mesg ('cloud_spec_mod', &
                'graupel tracer not found, but do_graupel is true', FATAL)
          end if

          if (mpp_pe() == mpp_root_pe()) &
            write (logunit,'(a,3i4)') 'Stratiform cloud tracer ind&
                &ices: nql,nqi,nqa =',nql,nqi,nqa
          if (min(nql,nqi,nqa) <= 0)   &
             call error_mesg ('cloud_spec_mod', &
             'stratiform cloud tracer(s) not found', FATAL)
          if (nql == nqi .or. nqa == nqi .or. nql == nqa)   &
              call error_mesg ('cloud_spec_mod',  &
            'tracers indices cannot be the same (i.e., nql=nqi=nqa).', &
                                                              FATAL)
          nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )
          if (nqn /= NO_TRACER)  then
            Cldrad_control%do_liq_num = .true.
          else
            Cldrad_control%do_liq_num = .false.
          endif
        else
          Cldrad_control%do_liq_num = .false.
        endif
        Cldrad_control%do_liq_num_iz = .true.

!---------------------------------------------------------------------
!    define the variables indicating that the cloud parameterization
!    control variables have been defined.
!---------------------------------------------------------------------
      Cldrad_control%do_rh_clouds_iz = .true.
      Cldrad_control%do_strat_clouds_iz = .true.
      Cldrad_control%do_zonal_clouds_iz = .true.
      Cldrad_control%do_mgroup_prescribed_iz = .true.
      Cldrad_control%do_obs_clouds_iz = .true.
      Cldrad_control%do_no_clouds_iz = .true.
      Cldrad_control%do_diag_clouds_iz = .true.
      Cldrad_control%do_specified_clouds_iz = .true.
      Cldrad_control%do_specified_strat_clouds_iz = .true.
      Cldrad_control%do_donner_deep_clouds_iz = .true.
      Cldrad_control%do_uw_clouds_iz = .true.
      Cldrad_control%do_zetac_clouds_iz = .true.
      Cldrad_control%do_stochastic_clouds_iz = .true.
 
!--------------------------------------------------------------------
!    if stochastic clouds is active, allocate and define arrays holding
!    the processor's latitudes and longitudes. be sure that the
!    cloud_generator module has been initialized.
!--------------------------------------------------------------------
      if (Cldrad_control%do_stochastic_clouds_iz) then
        if (Cldrad_control%do_stochastic_clouds) then
          allocate (lats(size(latb,1),size(latb,2)))
          allocate (lons(size(lonb,1), size(lonb,2)))
          lats(:,:) = latb(:,:)*radian
          lons(:,:) = lonb(:,:)*radian
          call cloud_generator_init

!---------------------------------------------------------------------
!     if it is desired to force the use of the temperature-based
!     random number seed (as is used when time is not always advancing
!     as seen by the radiation package, or when model resolution is
!     less than 1 degree), set the logical control variable in 
!     Cldrad_control to so indicate. 
!---------------------------------------------------------------------
          if ( force_use_of_temp_for_seed) then
            Cldrad_control%use_temp_for_seed = .true.
            Cldrad_control%use_temp_for_seed_iz = .true.
            call error_mesg ('cloud_spec_init', &
                 'Will use temp as basis for stochastic cloud seed; &
                    &force_use_of_temp_for_seed is set true', NOTE)
          endif

!---------------------------------------------------------------------
!     if model resolution is less than 1 degree, set the logical control 
!     variable in Cldrad_control to use the model temperature at top 
!     level as the random number seed to provide spacial uniqueness.
!---------------------------------------------------------------------
          if (.not. Cldrad_control%use_temp_for_seed) then
  jLoop:    do j=1,jd
              do i=1,id
                do jj=j+1,jd+1
                  do ii=i+1,id+1
                    if (NINT(lats(ii,jj)) == NINT(lats(i,j))) then
                      if (NINT(lons(ii,jj)) == NINT(lons(i,j))) then      
                        Cldrad_control%use_temp_for_seed = .true.
                        Cldrad_control%use_temp_for_seed_iz = .true.
                        call error_mesg ('cloud_spec_init', &
                       'Will use temp as basis for stochastic cloud seed; &
                              &resolution higher than 1 degree', NOTE)
                        exit jLoop
                      endif
                    endif
                  end do
                end do
              end do
            end do jLoop
          endif
        endif
      else
        call error_mesg ('microphys_rad_mod', &
         ' attempt to use Cldrad_control%do_stochastic_clouds before &
                                                &it is defined', FATAL)
      endif
 
!--------------------------------------------------------------------
!    include do_fu2007 in the cloudrad_control_type variable for use
!    in other modules.
!--------------------------------------------------------------------
      Cldrad_control%using_fu2007 = do_fu2007
      Cldrad_control%using_fu2007_iz = .true.     

!---------------------------------------------------------------------
!    mark the module initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!-------------------------------------------------------------------



end subroutine cloud_spec_init



!######################################################################
! <SUBROUTINE NAME="cloud_spec">
!  <OVERVIEW>
!    cloud_radiative_properties defines the cloud radiative properties 
!    appropriate for the radiation options that are active.
!  </OVERVIEW>
!  <DESCRIPTION>
!    cloud_radiative_properties defines the cloud radiative properties 
!    appropriate for the radiation options that are active.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_spec (is, ie, js, je, lat, z_half, z_full, Rad_time,
!                       Atmos_input, &
!                       Surface, Cld_spec, Lsc_microphys,  &
!                       Meso_microphys, Cell_microphys, lsc_area_in, &
!                       lsc_liquid_in, lsc_ice_in, lsc_droplet_number_in        , r)
!  </TEMPLATE>
!  <IN NAME="is,ie,js,je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
!   time at which radiation calculation is to apply
!  </IN>
!  <INOUT NAME="Atmos_input" TYPE="atmos_input_type">
!    atmospheric input fields on model grid,
!  </INOUT>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!  </INOUT>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                        clouds associated with donner convection
!  </INOUT>
!  <INOUT NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                        clouds associated with uw shallow convection
!  </INOUT>
!  <INOUT NAME="Surface" TYPE="Surface">
!   Surface boundary condition to radiation package
!  </INOUT>
!  <IN NAME="lsc_liquid_in" TYPE="real">
!   OPTIONAL: lsc cloud water mixing ratio  present when running 
!    standalone columns or sa_gcm
!  </IN>
!  <IN NAME="lsc_ice_in" TYPE="real">
!   OPTIONAL: cloud ice mixing ratio  present when running 
!    standalone columns or sa_gcm
!  </IN>
!  <IN NAME="lsc_area_in" TYPE="real">
!   OPTIONAL: fractional cloud area, present when running 
!                        standalone columns or sa_gcm
!  </IN>
!  <IN NAME="r" TYPE="real">
!   OPTIONAL: model tracer fields on the current time step
!  </IN>
! </SUBROUTINE>
!
subroutine cloud_spec (is, ie, js, je, lat, z_half, z_full, Rad_time, &
                       Atmos_input, Surface, Cld_spec, Lsc_microphys, &
                       Meso_microphys, Cell_microphys,  &
                       Shallow_microphys, lsc_area_in, lsc_liquid_in, &
                       lsc_ice_in, lsc_droplet_number_in, r,          &
                       shallow_cloud_area, shallow_liquid, shallow_ice,&
                       shallow_droplet_number, &
                       cell_cld_frac, cell_liq_amt, cell_liq_size, &
                       cell_ice_amt, cell_ice_size, &
                       cell_droplet_number, &
                       meso_cld_frac, meso_liq_amt, meso_liq_size, &
                       meso_ice_amt, meso_ice_size,  &
                       meso_droplet_number, nsum_out)

!----------------------------------------------------------------------
!    cloud_spec specifies the cloud field seen by the radiation package.
!----------------------------------------------------------------------


!----------------------------------------------------------------------
integer,                      intent(in)             :: is, ie, js, je
real, dimension(:,:),         intent(in)             :: lat
real, dimension(:,:,:),       intent(in)             :: z_half, z_full
type(time_type),              intent(in)             :: Rad_time
type(atmos_input_type),       intent(inout)          :: Atmos_input
type(surface_type),           intent(inout)          :: Surface       
type(cld_specification_type), intent(inout)          :: Cld_spec    
type(microphysics_type),      intent(inout)          :: Lsc_microphys, &
                                                        Meso_microphys,&
                                                        Cell_microphys,&
                                                     Shallow_microphys
real, dimension(:,:,:),       intent(in), optional ::  &
                                           lsc_liquid_in, lsc_ice_in, &
                                      lsc_droplet_number_in, lsc_area_in
real, dimension(:,:,:,:),     intent(in),   optional :: r
real, dimension(:,:,:),       intent(inout),optional :: &
                      shallow_cloud_area, shallow_liquid, shallow_ice,&
                        shallow_droplet_number, &
                           cell_cld_frac, cell_liq_amt, cell_liq_size, &
                           cell_ice_amt, cell_ice_size, &
                           cell_droplet_number, &
                           meso_cld_frac, meso_liq_amt, meso_liq_size, &
                           meso_ice_amt, meso_ice_size, &
                           meso_droplet_number
integer, dimension(:,:),      intent(inout), optional:: nsum_out

!-------------------------------------------------------------------
 
!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je       starting/ending subdomain i,j indices of data 
!                        in the physics_window being integrated
!      lat               latitude of model points  [ radians ]
!      z_half            height asl at half levels [ m ]
!      z_full            height asl at full levels [ m ]
!      Rad_time          time at which radiation calculation is to apply
!                        [ time_type (days, seconds) ] 
!
!   intent(inout) variables:
!
!      Atmos_input       atmospheric input fields on model grid,
!                        [ atmos_input_type ] 
!      Surface           variables defining the surface albedo and land
!                        fraction
!                        [ surface_type ]
!      Cld_spec          variables on the model grid which define all or
!                        some of the following, dependent on the 
!                        specific cloud parameterization: cloud optical 
!                        paths, particle sizes, cloud fractions, cloud 
!                        thickness, number of clouds in a column, 
!                        and /or cloud type (high/mid/low, ice/liq or 
!                        random/max overlap)
!                        [ cld_specification_type ]
!      Lsc_microphys     variables describing the microphysical proper-
!                        ties of the large-scale clouds
!                        [ microphysics_type ]
!      Meso_microphys    variables describing the microphysical proper-
!                        ties of the meso-scale clouds
!                        [ microphysics_type ]
!      Cell_microphys    variables describing the microphysical proper-
!                        ties of the convective cell-scale clouds
!                        [ microphysics_type ]
!
!   intent(in), optional variables:
!
!      lsc_liquid_in     cloud water mixing ratio (or specific humidity 
!                        ????), present when running standalone columns
!                        or sa_gcm
!                        [ non-dimensional ]
!      lsc_ice_in        cloud ice mixing ratio (or specific humidity 
!                         ????), present when running standalone columns
!                        or sa_gcm
!                        [ non-dimensional ]
!      lsc_area_in       fractional cloud area, present when running 
!                        standalone columns or sa_gcm
!                        [ non-dimensional ]
!      r                 model tracer fields on the current time step
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer   :: ix, jx, kx
      integer   :: ierr
      logical   :: override
      type(time_type) :: Data_time
      real, dimension (id, jd, kmax) :: ql_proc, qi_proc, qa_proc
      real, dimension (size (Atmos_input%deltaz,1), &
                       size (Atmos_input%deltaz,2), &
                       size (Atmos_input%deltaz,3)) :: rho

!---------------------------------------------------------------------
!   local variables:
!
!        ix      number of grid points in x direction (on processor)
!        jx      number of grid points in y direction (on processor)
!        kx      number of model layers
!        rho     atmospheric density [ kg / m**3 ]
!        ierr
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    check for the presence of optional input arguments.
!---------------------------------------------------------------------
      ierr = 1
      if (present(lsc_liquid_in) .and.   &
          present(lsc_ice_in) .and. &
          present(lsc_area_in)) then
        ierr = 0
        if (Cldrad_control%do_liq_num) then
          if (.not. present(lsc_droplet_number_in) ) then
            call error_mesg ('cloud_spec_mod', &
               'must input lsc_droplet_number_in when  &
                                   &using do_liq_num', FATAL)
          endif
        endif
      else
        if (present (r)) then
          ierr = 0
        else
          call error_mesg ('cloud_spec_mod', &
              'must input either r or lsc_liquid_in and  &
              &lsc_ice_in when using predicted cloud microphysics', &
                                                               FATAL)
        endif
      endif

!----------------------------------------------------------------------
!    define model dimensions.
!----------------------------------------------------------------------
      ix = size(Atmos_input%deltaz,1)
      jx = size(Atmos_input%deltaz,2)
      kx = size(Atmos_input%deltaz,3)

!----------------------------------------------------------------------
!    call initialize_cldamts to allocate and initialize the arrays
!    contained in the structures used to specify the cloud amounts, 
!    types and locations and the microphysical parameters.
!----------------------------------------------------------------------
      call initialize_cldamts (ix, jx, kx, Lsc_microphys,   &
                               Meso_microphys, Cell_microphys, &
                               Shallow_microphys, Cld_spec)

!---------------------------------------------------------------------
!    define the cloud_water, cloud_ice and cloud_area components of 
!    Cld_spec.
!---------------------------------------------------------------------
      if (present (lsc_ice_in) .and. &
          present (lsc_liquid_in) ) then
        Cld_spec%cloud_ice   = lsc_ice_in
        Cld_spec%cloud_water = lsc_liquid_in
        if (Cldrad_control%do_liq_num) then
          if (present(lsc_droplet_number_in)) then
             Cld_spec%cloud_droplet (:,:,:) = lsc_droplet_number_in
          endif
        endif
      endif
      if (present (lsc_area_in)  )then
        Cld_spec%cloud_area = lsc_area_in
      endif

!----------------------------------------------------------------------
!    if a cloud scheme is activated (in contrast to running without any
!    clouds), call the appropriate subroutine to define the cloud
!    location, type, amount or whatever other arrays the particular 
!    parameterization uses to specify its clouds. if the model is being
!    run with do_no_clouds = .true., exit from this routine, leaving
!    the cloud specification variables as they were initialized (to a
!    condition of no clouds).
!---------------------------------------------------------------------
      if (.not. Cldrad_control%do_no_clouds) then

!---------------------------------------------------------------------
!    when running in standalone columns mode, call standalone_clouds_amt
!    to obtain the cloud specification variables. 
!---------------------------------------------------------------------
        if (Cldrad_control%do_specified_clouds .or. &
            Cldrad_control%do_specified_strat_clouds )   then

          call standalone_clouds_amt (is, ie, js, je, lat,     &
                                      Atmos_input%press, Cld_spec)

!---------------------------------------------------------------------
!    if the rh diagnostic cloud scheme is active, call rh_clouds_amt
!    to define the needed cloud specification variables.
!---------------------------------------------------------------------
        else if (Cldrad_control%do_rh_clouds) then
          call rh_clouds_amt (is, ie, js, je, Atmos_input%press, lat,  &
                              Cld_spec)

!---------------------------------------------------------------------
!    if either zonal clouds or obs clouds is active, call 
!    specified_clouds_amt to obtain the needed cloud specification
!    variables.
!---------------------------------------------------------------------
        else if (Cldrad_control%do_zonal_clouds .or. &
                 Cldrad_control%do_obs_clouds) then
          call specified_clouds_amt (is, ie, js, je, Rad_time, lat,    &
                                     Atmos_input%pflux, Cld_spec)

!---------------------------------------------------------------------
!    if mgrp_prscr_clds is active, call prscr_clds_amt to obtain the 
!    needed cloud specification variables.
!---------------------------------------------------------------------
        else if (Cldrad_control%do_mgroup_prescribed) then
          call prscr_clds_amt (is, ie, js, je, Cld_spec)

!----------------------------------------------------------------------
!    if gordon diagnostic clouds are active, call diag_clouds_amt to 
!    obtain the needed cloud specification variables.
!---------------------------------------------------------------------
        else if (Cldrad_control%do_diag_clouds) then
          call diag_clouds_amt (is, ie, js, je, lat, Atmos_input%pflux,&
                                Atmos_input%press, Rad_time, Cld_spec, &
                                Lsc_microphys)

!----------------------------------------------------------------------
!    if zetac clouds are active, call zetac_clouds_amt to 
!    obtain the needed cloud specification variables.
!---------------------------------------------------------------------
        else if (Cldrad_control%do_zetac_clouds) then
          if (present (r)) then
            Cld_spec%cloud_water(:,:,:) = r(:,:,:,nql)
            Cld_spec%cloud_ice  (:,:,:) = r(:,:,:,nqi)
            Cld_spec%cloud_area (:,:,:) = r(:,:,:,nqa)
!           ierr = 0
!         else
!           call error_mesg ('cloud_spec_mod', &
!             ' must pass tracer array r when using zetac clouds', &
!                                                             FATAL)
          endif
          call zetac_clouds_amt (is, ie, js, je, z_half, z_full, &
                                 Surface%land, Atmos_input%phalf, &
                                 Atmos_input%deltaz, Cld_spec, &
                                 Lsc_microphys)

        endif ! (do_rh_clouds)
!--------------------------------------------------------------------
!    if klein prognostic clouds are active, call strat_clouds_amt to 
!    obtain the needed cloud specification variables.
!--------------------------------------------------------------------
        if (Cldrad_control%do_strat_clouds) then

!---------------------------------------------------------------------
!    if the gcm is being executed, call strat_cloud_avg to obtain the
!    appropriate (either instantaneous or time-averaged) values of
!    cloud water, cloud ice and cloud fraction. if the sa_gcm or the
!    standalone columns mode is being executed with the strat cloud
!    option, then values for the cloud water, cloud ice and when needed
!    cloud area have been input as optional arguments to this sub-
!    routine.
!---------------------------------------------------------------------
          if(present(lsc_liquid_in)) then
            if (Cld_spec%cloud_area(1,1,1) == -99.) then
              if (present (r)) then
                Cld_spec%cloud_water(:,:,:) = r(:,:,:,nql)
                Cld_spec%cloud_ice  (:,:,:) = r(:,:,:,nqi)
                Cld_spec%cloud_area (:,:,:) = r(:,:,:,nqa)
                if (Cldrad_control%do_liq_num) then
                  Cld_spec%cloud_droplet (:,:,:) = r(:,:,:,nqn)
                endif
              else
                call error_mesg ('cloud_spec_mod', &
                   'lsc_area_in, etc not present in restart file (flag &
                    &has been set), and r array is not passed to &
                                 &cloud_spec; cannot proceed', FATAL)
              endif
            endif
          else  ! (present (lsc_liquid_in))
            if (present (r)) then
              Cld_spec%cloud_water(:,:,:) = r(:,:,:,nql)
              Cld_spec%cloud_ice  (:,:,:) = r(:,:,:,nqi)
              Cld_spec%cloud_area (:,:,:) = r(:,:,:,nqa)
              if (Cldrad_control%do_liq_num) then
                Cld_spec%cloud_droplet (:,:,:) = r(:,:,:,nqn)
              endif
            else
              call error_mesg ('cloud_spec_mod', &
                  'neither lsc_area_in, etc nor r array &
                 &has been passed to cloud_spec; cannot proceed', FATAL)
            endif
          endif ! (present(lsc_liquid_in))

          if (present(r)) then
            if (do_rain) then !sjl
              Cld_spec%cloud_water(:,:,:) = Cld_spec%cloud_water(:,:,:)+r(:,:,:,nqr)
            end if
            if (do_snow) then !miz
              Cld_spec%cloud_ice(:,:,:) = Cld_spec%cloud_ice(:,:,:)+r(:,:,:,nqs)
            end if
            if (do_graupel) then !SJL
              Cld_spec%cloud_ice(:,:,:) = Cld_spec%cloud_ice(:,:,:)+r(:,:,:,nqg)
            end if
          endif  

!---------------------------------------------------------------------
!    if the cloud input data is to be overriden, define the time slice
!    of data which is to be used. allocate storage for the cloud data.
!---------------------------------------------------------------------
          if (doing_data_override) then
            Data_time = Rad_time +    &
                          set_time (Rad_control%rad_time_step, 0)
 
!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's cloud
!    water data from the override file. if the process fails, write
!    an error message; if it succeeds move the data for the current 
!    physics window, into the appropriate Cld_spec% array.
!---------------------------------------------------------------------
            call data_override ('ATM', 'qlnew', ql_proc,   &
                                  Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
                'ql => cloud_water not overridden successfully', FATAL)
            else
              Cld_spec%cloud_water(:,:,:) = ql_proc(is:ie,js:je,:)
            endif

!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's cloud
!    ice data from the override file. if the process fails, write
!    an error message; if it succeeds move the data for the current 
!    physics window, into the appropriate Cld_spec% array.
!---------------------------------------------------------------------
            call data_override ('ATM', 'qinew', qi_proc,   &
                                Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
                'qi => cloud_ice   not overridden successfully', FATAL)
            else
              Cld_spec%cloud_ice(:,:,:) = qi_proc(is:ie,js:je,:)
            endif

!---------------------------------------------------------------------
!    call data_override to retrieve the processor subdomain's cloud
!    fraction data from the override file. if the process fails, write
!    an error message; if it succeeds move the data for the current
!    physics window, into the appropriate Cld_spec% array.
!---------------------------------------------------------------------
            call data_override ('ATM', 'qanew', qa_proc,   &
                                 Data_time, override=override)
            if ( .not. override) then
              call error_mesg ('radiation_driver_mod', &
               'qa => cloud_area not overridden successfully', FATAL)
            else
              Cld_spec%cloud_area(:,:,:) = qa_proc(is:ie,js:je,:)
            endif
            ierr = 0
          endif ! (doing_override)

!---------------------------------------------------------------------
!    if values for the cloud variables have been successfully obtained,
!    call strat_clouds_amt to define the appropriate cloud specification
!    variables.
!---------------------------------------------------------------------
          if (ierr == 0) then
            call strat_clouds_amt (is, ie, js, je, Rad_time, &
                                   Atmos_input%pflux,  &
                                   Atmos_input%press,   &
                                   Atmos_input%cloudtemp, &
                                   Atmos_input%cloudvapor(:,:,:)/  &
                                   (1.0+Atmos_input%cloudvapor(:,:,:)), &
                                   Surface%land,&
                                   Cld_spec, Lsc_microphys)

!----------------------------------------------------------------------
!    if ierr is non-zero, then cloud data was not successfully obtained.
!    if this is not the coldstart step, write an error message and 
!    stop execution.
!----------------------------------------------------------------------
          else 
            if (num_pts >= tot_pts) then
              call error_mesg ('cloud_spec_mod',  &
                     'no strat cloud data available; ierr /= 0', FATAL)

!----------------------------------------------------------------------
!    if this is the coldstart step, retain the input values corres-
!    ponding to no clouds, increment the points counter, and continue. 
!----------------------------------------------------------------------
            else
              num_pts = num_pts + size(Atmos_input%press,1)*   &
                                  size(Atmos_input%press,2)
            endif
          endif
        endif ! (do_strat_clouds)

!--------------------------------------------------------------------
!    since donner_deep_clouds may be active along with strat clouds, 
!    the associated properties are determined outside of the above loop.
!    these properties are placed in Cell_microphys and Meso_microphys.
!----------------------------------------------------------------------
        if (Cldrad_control%do_donner_deep_clouds) then
          call donner_deep_clouds_amt (is, ie, js, je,  &
                           cell_cld_frac, cell_liq_amt, cell_liq_size, &
                           cell_ice_amt, cell_ice_size, &
                           cell_droplet_number, &
                           meso_cld_frac, meso_liq_amt, meso_liq_size, &
                           meso_ice_amt, meso_ice_size,  &
                           meso_droplet_number,  nsum_out, &
                           Cell_microphys, Meso_microphys)

!---------------------------------------------------------------------
!    convert the cloud and ice amounts from kg(h2o) / kg(air) to 
!    g(h2o) / m**3, as required for use in the microphys_rad routines
!    which compute cloud radiative properties.
!---------------------------------------------------------------------
          rho(:,:,:) = Atmos_input%press(:,:,1:kx)/  &
                       (RDGAS*Atmos_input%temp(:,:,1:kx))
          Cell_microphys%conc_drop = 1.0e03*rho*Cell_microphys%conc_drop
          Cell_microphys%conc_ice  = 1.0e03*rho*Cell_microphys%conc_ice 
          Meso_microphys%conc_drop = 1.0e03*rho*Meso_microphys%conc_drop
          Meso_microphys%conc_ice  = 1.0e03*rho*Meso_microphys%conc_ice 
        endif

!--------------------------------------------------------------------
!    since uw_clouds may be active along with strat clouds and / or 
!    donner deep clouds, the associated properties are determined 
!    outside of the above loop. these properties are placed in  
!    Shallow_microphys.
!----------------------------------------------------------------------
         if (Cldrad_control%do_uw_clouds) then
           call uw_clouds_amt (is, ie, js, je,  &
                            shallow_cloud_area, shallow_liquid, &
                            shallow_ice, shallow_droplet_number, &
                            Surface%land, Atmos_input%press,  &
                            Atmos_input%cloudtemp, Shallow_microphys)
        endif

!---------------------------------------------------------------------
!    obtain the microphysical properties (sizes and concentrations) if
!    a prescribed microphysics scheme is active. 
!---------------------------------------------------------------------
        if (Cldrad_control%do_presc_cld_microphys) then
          call microphys_presc_conc (is, ie, js, je,   &
                                     Atmos_input%clouddeltaz,   &
                                     Atmos_input%cloudtemp, &
                                     Cld_spec, Lsc_microphys)
        endif

!---------------------------------------------------------------------
!    call combine_cloud_properties to combine (if necessary) the cloud 
!    properties from multiple cloud types (large-scale, donner deep,
!    uw shallow) into a single set for use by the radiation package. 
!    this is only needed when microphysically-based properties are 
!    present, and when either strat clouds, donner deep and / or uw
!    shallow clouds is activated.
!---------------------------------------------------------------------
        if ( .not. Cldrad_control%do_specified_strat_clouds ) then
          if (Cldrad_control%do_sw_micro  .or.    &
              Cldrad_control%do_lw_micro) then
            if (Cldrad_control%do_strat_clouds .or.    &
                Cldrad_control%do_uw_clouds .or.    &
                Cldrad_control%do_donner_deep_clouds) then
              call combine_cloud_properties ( is, js,  &
                                             Atmos_input%temp(:,:,1), &
                                             Rad_time, &
                                             Lsc_microphys,    &
                                             Meso_microphys,   &
                                             Cell_microphys,   &
                                             Shallow_microphys, &
                                             Cld_spec)
            endif
          endif
        endif
      endif  !  (.not. do_no_clouds)

!--------------------------------------------------------------------
!    if microphysics is active and strat_clouds is not, define the water
!    paths (in units of kg / m**2).  if strat_clouds is active, these 
!    values will have already been defined. when microphysics is active,
!    define the effective sizes for the liquid and ice particles.
!--------------------------------------------------------------------
      if (Cldrad_control%do_lw_micro .or.    &
          Cldrad_control%do_sw_micro)  then
        if (.not. Cldrad_control%do_strat_clouds .and.   &
            .not. Cldrad_control%do_zetac_clouds ) then
          Cld_spec%lwp = 1.0E-03*Lsc_microphys%conc_drop(:,:,:)* &
                         Atmos_input%clouddeltaz(:,:,:)
          Cld_spec%iwp = 1.0E-03*Lsc_microphys%conc_ice(:,:,:)*  &
                         Atmos_input%clouddeltaz(:,:,:)
        endif
        Cld_spec%reff_liq_micro = Lsc_microphys%size_drop
        Cld_spec%reff_ice_micro = Lsc_microphys%size_ice
      endif

!---------------------------------------------------------------------


end subroutine cloud_spec    



!######################################################################
! <SUBROUTINE NAME="cloud_spec_dealloc">
!  <OVERVIEW>
!    cloud_spec_dealloc deallocates the component arrays of the 
!    cld_specification_type structure Cld_spec and the microphysics_type
!    structures Lsc_microphys, Meso_microphys, Cell_microphys and
!    Shallow_microphys.
!  </OVERVIEW>
!  <DESCRIPTION>
!    cloud_spec_dealloc deallocates the component arrays of the 
!    cld_specification_type structure Cld_spec and the microphysics_type
!    structures Lsc_microphys, Meso_microphys, Cell_microphys and
!    Shallow_microphys.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud_spec_dealloc (Cld_spec, Lsc_microphys, Meso_microphys,&
!                               Cell_microphys, Shallow_microphys)
!  </TEMPLATE>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!  </INOUT>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                        clouds associated with donner convection
!  </INOUT>
!  <INOUT NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                        clouds associated with uw shallow convection
!  </INOUT>
! </SUBROUTINE>
! 
subroutine cloud_spec_dealloc (Cld_spec, Lsc_microphys, Meso_microphys,&
                               Cell_microphys, Shallow_microphys)

!---------------------------------------------------------------------
!    cloud_spec_dealloc deallocates the component arrays of the 
!    cld_specification_type structure Cld_spec and the microphysics_type
!    structures Lsc_microphys, Meso_microphys, Cell_microphys and
!    Shallow_microphys.
!----------------------------------------------------------------------

type(cld_specification_type), intent(inout) :: Cld_spec
type(microphysics_type),      intent(inout) :: Lsc_microphys,   &
                                               Meso_microphys, &
                                               Cell_microphys, &
                                               Shallow_microphys


!----------------------------------------------------------------------
!    deallocate the array elements of Cld_spec.
!----------------------------------------------------------------------
      deallocate (Cld_spec%camtsw         )  
      deallocate (Cld_spec%cmxolw         )
      deallocate (Cld_spec%crndlw         )
      deallocate (Cld_spec%ncldsw         )
      deallocate (Cld_spec%nmxolw         )
      deallocate (Cld_spec%nrndlw         )
      if (Cldrad_control%do_stochastic_clouds) then
        deallocate (Cld_spec%camtsw_band    )
        deallocate (Cld_spec%ncldsw_band    )
        deallocate (Cld_spec%cld_thickness_sw_band  )
        deallocate (Cld_spec%lwp_sw_band            )
        deallocate (Cld_spec%iwp_sw_band            )
        deallocate (Cld_spec%reff_liq_sw_band       )
        deallocate (Cld_spec%reff_ice_sw_band       )
        deallocate (Cld_spec%stoch_cloud_type       )
      endif
      if (Cldrad_control%do_stochastic_clouds) then
        deallocate (Cld_spec%crndlw_band    )
        deallocate (Cld_spec%nrndlw_band    )
        deallocate (Cld_spec%cld_thickness_lw_band  )
        deallocate (Cld_spec%lwp_lw_band            )
        deallocate (Cld_spec%iwp_lw_band            )
        deallocate (Cld_spec%reff_liq_lw_band       )
        deallocate (Cld_spec%reff_ice_lw_band       )
      endif
      deallocate (Cld_spec%tau            )
      deallocate (Cld_spec%lwp            )
      deallocate (Cld_spec%iwp            )
      deallocate (Cld_spec%reff_liq       )
      deallocate (Cld_spec%reff_ice       )
      deallocate (Cld_spec%reff_liq_lim   )
      deallocate (Cld_spec%reff_ice_lim   )
      deallocate (Cld_spec%reff_liq_micro )
      deallocate (Cld_spec%reff_ice_micro )
      deallocate (Cld_spec%liq_frac       )
      deallocate (Cld_spec%cld_thickness  )
      deallocate (Cld_spec%hi_cloud       )
      deallocate (Cld_spec%mid_cloud      )
      deallocate (Cld_spec%low_cloud      )
      deallocate (Cld_spec%ice_cloud      )
      deallocate (Cld_spec%cloud_water    )
      deallocate (Cld_spec%cloud_ice      )
      deallocate (Cld_spec%cloud_area     )
      deallocate (Cld_spec%cloud_droplet  )

!--------------------------------------------------------------------
!    deallocate the elements of Lsc_microphys.
!---------------------------------------------------------------------
      deallocate (Lsc_microphys%conc_drop   )
      deallocate (Lsc_microphys%conc_ice    )
      deallocate (Lsc_microphys%conc_rain   )
      deallocate (Lsc_microphys%conc_snow   )
      deallocate (Lsc_microphys%size_drop   )
      deallocate (Lsc_microphys%size_ice    )
      deallocate (Lsc_microphys%size_rain   )
      deallocate (Lsc_microphys%size_snow   )
      deallocate (Lsc_microphys%cldamt      )
      deallocate (Lsc_microphys%droplet_number )
      if (Cldrad_control%do_stochastic_clouds) then
        nullify (Lsc_microphys%lw_stoch_conc_drop   )
        nullify (Lsc_microphys%lw_stoch_conc_ice    )
        nullify (Lsc_microphys%lw_stoch_size_drop   )
        nullify (Lsc_microphys%lw_stoch_size_ice    )
        nullify (Lsc_microphys%lw_stoch_cldamt      )
        nullify (Lsc_microphys%lw_stoch_droplet_number)

        nullify (Lsc_microphys%sw_stoch_conc_drop   )
        nullify (Lsc_microphys%sw_stoch_conc_ice    )
        nullify (Lsc_microphys%sw_stoch_size_drop   )
        nullify (Lsc_microphys%sw_stoch_size_ice    )
        nullify (Lsc_microphys%sw_stoch_cldamt      )
        nullify (Lsc_microphys%sw_stoch_droplet_number)

        deallocate (Lsc_microphys%stoch_conc_drop   )
        deallocate (Lsc_microphys%stoch_conc_ice    )
        deallocate (Lsc_microphys%stoch_size_drop   )
        deallocate (Lsc_microphys%stoch_size_ice    )
        deallocate (Lsc_microphys%stoch_cldamt      )
        deallocate (Lsc_microphys%stoch_droplet_number )
      endif

!--------------------------------------------------------------------
!    deallocate the elements of Cell_microphys.
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then
        deallocate (Cell_microphys%conc_drop   )
        deallocate (Cell_microphys%conc_ice    )
        deallocate (Cell_microphys%conc_rain   )
        deallocate (Cell_microphys%conc_snow   )
        deallocate (Cell_microphys%size_drop   )
        deallocate (Cell_microphys%size_ice    )
        deallocate (Cell_microphys%size_rain   )
        deallocate (Cell_microphys%size_snow   )
        deallocate (Cell_microphys%cldamt      )
        deallocate (Cell_microphys%droplet_number )

!--------------------------------------------------------------------
!    deallocate the elements of Meso_microphys.
!---------------------------------------------------------------------
        deallocate (Meso_microphys%conc_drop   )
        deallocate (Meso_microphys%conc_ice    )
        deallocate (Meso_microphys%conc_rain   )
        deallocate (Meso_microphys%conc_snow   )
        deallocate (Meso_microphys%size_drop   )
        deallocate (Meso_microphys%size_ice    )
        deallocate (Meso_microphys%size_rain   )
        deallocate (Meso_microphys%size_snow   )
        deallocate (Meso_microphys%cldamt      )
        deallocate (Meso_microphys%droplet_number )
      endif

!--------------------------------------------------------------------
!    deallocate the elements of Shallow_microphys.
!---------------------------------------------------------------------
      if (Cldrad_control%do_uw_clouds) then
        deallocate (Shallow_microphys%conc_drop   )
        deallocate (Shallow_microphys%conc_ice    )
        deallocate (Shallow_microphys%conc_rain   )
        deallocate (Shallow_microphys%conc_snow   )
        deallocate (Shallow_microphys%size_drop   )
        deallocate (Shallow_microphys%size_ice    )
        deallocate (Shallow_microphys%size_rain   )
        deallocate (Shallow_microphys%size_snow   )
        deallocate (Shallow_microphys%cldamt      )
        deallocate (Shallow_microphys%droplet_number )
      endif

!---------------------------------------------------------------------


end subroutine cloud_spec_dealloc 



!#####################################################################

subroutine cloud_spec_end

!---------------------------------------------------------------------
!    cloud_spec_end is the destructor for cloud_spec_mod.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    close the modules that were initialized by this module.
!--------------------------------------------------------------------
      if (.not. Cldrad_control%do_no_clouds) then

!-------------------------------------------------------------------
!    mgroup prescribed clouds.
!-------------------------------------------------------------------
        if (Cldrad_control%do_mgroup_prescribed) then
          call mgrp_prscr_clds_end 

!-------------------------------------------------------------------
!    rh-based diagnostic clouds.
!-------------------------------------------------------------------
        else if (Cldrad_control%do_rh_clouds) then
          call rh_based_clouds_end 

!-------------------------------------------------------------------
!    zonal or observed clouds.
!-------------------------------------------------------------------
        else if (Cldrad_control%do_zonal_clouds .or.  &
                 Cldrad_control%do_obs_clouds)  then
          call specified_clouds_W_end             

!-------------------------------------------------------------------
!    klein predicted clouds. if this option is active, donner_deep 
!    clouds may also be active. additionally, this may also have been
!    activated when running in standalone columns mode, in which case
!    standalone_clouds_end must be called.
!-------------------------------------------------------------------
        else if (Cldrad_control%do_strat_clouds) then
          if (Cldrad_control%do_specified_strat_clouds .or. &
              Cldrad_control%do_specified_clouds ) then 
            call standalone_clouds_end
          endif

!-------------------------------------------------------------------
!    gordon diagnostic clouds.
!-------------------------------------------------------------------
        else if (Cldrad_control%do_diag_clouds) then
          call diag_clouds_W_end

!-------------------------------------------------------------------
!    zetac clouds.
!-------------------------------------------------------------------
        else if (Cldrad_control%do_zetac_clouds) then
          call zetac_clouds_W_end

!-------------------------------------------------------------------
!    standalone specified clouds.
!-------------------------------------------------------------------
        else if (Cldrad_control%do_specified_clouds) then
          call standalone_clouds_end
        endif

!------------------------------------------------------------------
!    cloud types which may coexist must be processed outside of if loop
!------------------------------------------------------------------
        if (Cldrad_control%do_strat_clouds) then
          call strat_clouds_W_end
        endif
        if (Cldrad_control%do_donner_deep_clouds) then
          call donner_deep_clouds_W_end
        endif
        if (Cldrad_control%do_uw_clouds) then
          call uw_clouds_W_end
        endif
      endif  ! (not do_no_clouds)

!--------------------------------------------------------------------
!    mark the module as no longer initialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------



end subroutine cloud_spec_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!#####################################################################
! <SUBROUTINE NAME="initialize_cldamts">
!  <OVERVIEW>
!    initialize_cldamts allocates and initializes the array components 
!    of the structures used to specify the model cloud and microphysics
!    fields.
!  </OVERVIEW>
!  <DESCRIPTION>
!    initialize_cldamts allocates and initializes the array components 
!    of the structures used to specify the model cloud and microphysics
!    fields.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call initialize_cldamts (ix, jx, kx, Lsc_microphys,    &
!                               Meso_microphys, Cell_microphys, Cld_spec)
!  </TEMPLATE>
!  <IN NAME="ix, jx, kx" TYPE="integer">
!       ix             size of i dimension of physics window
!       jx             size of j dimension of physics window
!       kx             size of k dimension of physics window
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!  </INOUT>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                        clouds associated with donner convection
!  </INOUT>
!  <INOUT NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                        clouds associated with uw shallow convection
!  </INOUT>
! </SUBROUTINE>
! 
subroutine initialize_cldamts (ix, jx, kx, Lsc_microphys,    &
                               Meso_microphys, Cell_microphys,  &
                               Shallow_microphys, Cld_spec)

!---------------------------------------------------------------------
!    initialize_cldamts allocates and initializes the array components 
!    of the structures used to specify the model cloud and microphysics
!    fields.
!---------------------------------------------------------------------

integer,                      intent(in)     :: ix, jx, kx
type(microphysics_type),      intent(inout)  :: Lsc_microphys,   &
                                                Meso_microphys, &
                                                Cell_microphys, &
                                                Shallow_microphys
type(cld_specification_type), intent(inout)  :: Cld_spec

!----------------------------------------------------------------------
!    intent(in) variables:
! 
!       ix             size of i dimension of physics window
!       jx             size of j dimension of physics window
!       kx             size of k dimension of physics window
!
!    intent(inout) variables:
!
!       Lsc_microphys  microphysical specification for large-scale 
!                      clouds
!                      [ microphysics_type ]
!       Meso_microphys microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!                      [ microphysics_type ]
!       Cell_microphys microphysical specification for convective cell
!                      clouds associated with donner convection
!                      [ microphysics_type ]
!       Shallow_microphys 
!                      microphysical specification for 
!                      clouds associated with uw shallow convection
!                      [ microphysics_type ]
!
!            the following elements are components of these  
!            microphysics_type variables which are allocated and
!            initialized here:
!
!            %conc_ice   ice particle concentration [ g / m**3 ]
!            %conc_drop  cloud droplet concentration [ g / m**3 ]
!            %conc_rain  rain drop concentration [ g / m**3 ]
!            %conc_snow  snow concentration [ g / m**3 ]
!            %size_ice   effective ice crystal diameter [ microns ]
!            %size_drop  effective cloud drop diameter [ microns ]
!            %size_rain  effective rain drop diameter [ microns ]
!            %size_snow  effective snow flake diameter [ microns ]
!            %cldamt     total cloud fraction (crystal + droplet)
!                        [ dimensionless ]
!            %lw_stoch_conc_ice
!                        ice particle concentration as a function of
!                        lw parameterization band [ g / m**3 ]
!            %lw_stoch_conc_drop
!                        cloud droplet concentration as a function of
!                        lw parameterization band [ g / m**3 ]
!            %lw_stoch_size_ice
!                        effective ice crystal diameter as a function
!                        of lw parameterization band [ microns ]
!            %lw_stoch_size_drop
!                        effective cloud drop diameter as a function of
!                        lw parameterization band [ microns ]
!            %lw_stoch_cldamt
!                        total cloud fraction (crystal + droplet) as a
!                        function of lw parameterization band
!                        [ dimensionless ]
!            %sw_stoch_conc_ice
!                        ice particle concentration as a function of
!                        sw parameterization band [ g / m**3 ]
!            %sw_stoch_conc_drop
!                        cloud droplet concentration as a function of
!                        sw parameterization band [ g / m**3 ]
!            %sw_stoch_size_ice
!                        effective ice crystal diameter as a function
!                        of sw parameterization band [ microns ]
!            %sw_stoch_size_drop
!                        effective cloud drop diameter as a function of
!                        sw parameterization band [ microns ]
!            %sw_stoch_cldamt
!                        total cloud fraction (crystal + droplet) as a
!                        function of sw parameterization band
!                        [ dimensionless ]
!
!       Cld_spec       variables on the model grid which define all or
!                      some of the following, dependent on the specific
!                      cloud parameterization: cloud optical paths, 
!                      particle sizes, cloud fractions, cloud thickness,
!                      number of clouds in a column, and /or cloud type 
!                      (high/mid/low, ice/liq or random/max overlap)
!                      [ cld_specification_type ]
!
!            the following elements are components of this  
!            cld_specification_type variable which is allocated and
!            initialized here:
!
!            %cmxolw         amount of maximally overlapped longwave 
!                            clouds [ dimensionless ]
!            %crndlw         amount of randomly overlapped longwave 
!                            clouds [ dimensionless ]
!            %nmxolw         number of maximally overlapped longwave 
!                            clouds in each grid column.
!            %nrndlw         number of maximally overlapped longwave 
!                            clouds in each grid column.
!            %camtsw         shortwave cloud amount. the sum of the max-
!                            imally overlapped and randomly overlapped 
!                            longwave cloud amounts. [ dimensionless ]
!            %ncldsw         number of shortwave clouds in each grid 
!                            column.
!            %camtsw_band    shortwave cloud amount. the sum of the max-
!                            imally overlapped and randomly overlapped
!                            longwave cloud amounts, differing with sw
!                            parameterization band. [ dimensionless ]
!            %crndlw_band    amount of randomly overlapped longwave
!                            clouds, differing with lw parameterization
!                            band [ dimensionless ]
!            %hi_cloud       logical mask for high clouds 
!            %mid_cloud      logical mask for middle clouds
!            %low_cloud      logical mask for low clouds
!            %ice_cloud      logical mask for ice clouds
!            %iwp            ice water path  [ kg / m**2 ]
!            %lwp            liquid water path [ kg / m**2 ]
!            %reff_liq       effective cloud drop radius  used with
!                            bulk cloud physics scheme [ microns ]
!            %reff_ice       effective ice crystal radius used with
!                            bulk cloud physics scheme [ microns ]
!            %reff_liq_micro effective cloud drop radius used with 
!                            microphysically based scheme [ microns ]
!            %reff_ice_micro effective ice crystal radius used with
!                            microphysically based scheme [ microns ]
!            %tau            extinction optical path  [ dimensionless ]
!            %liq_frac       fraction of cloud in a box which is liquid
!                            [ dimensionless ]
!            %cld_thickness  number of model layers contained in cloud  
!            %cloud_water    liquid cloud content [ kg liq / kg air ]
!            %cloud_ice      ice cloud content [ kg ice / kg air ]
!            %cloud_area     saturated volume fraction [ dimensionless ]
!
!---------------------------------------------------------------------

      integer  :: n

!---------------------------------------------------------------------
!    allocate the arrays defining the microphysical parameters of the 
!    large-scale cloud scheme, including any precipitation fields and
!    the total cloud fraction. concentrations and fractions are init-
!    ialized to 0.0, and the effective sizes are set to small numbers to
!    avoid potential divides by zero.
!---------------------------------------------------------------------
      allocate (Lsc_microphys%conc_drop  (ix, jx, kx) )
      allocate (Lsc_microphys%conc_ice   (ix, jx, kx) )
      allocate (Lsc_microphys%conc_rain  (ix, jx, kx) )
      allocate (Lsc_microphys%conc_snow  (ix, jx, kx) )
      allocate (Lsc_microphys%size_drop  (ix, jx, kx) )
      allocate (Lsc_microphys%size_ice   (ix, jx, kx) )
      allocate (Lsc_microphys%size_rain  (ix, jx, kx) )
      allocate (Lsc_microphys%size_snow  (ix, jx, kx) )
      allocate (Lsc_microphys%cldamt     (ix, jx, kx) )
      allocate (Lsc_microphys%droplet_number (ix, jx, kx) )
      Lsc_microphys%conc_drop(:,:,:) = 0.
      Lsc_microphys%conc_ice(:,:,:)  = 0.
      Lsc_microphys%conc_rain(:,:,:) = 0.
      Lsc_microphys%conc_snow(:,:,:) = 0.
      Lsc_microphys%size_drop(:,:,:) = 1.0e-20 
      Lsc_microphys%size_ice(:,:,:)  = 1.0e-20 
      Lsc_microphys%size_rain(:,:,:) = 1.0e-20        
      Lsc_microphys%size_snow(:,:,:) = 1.0e-20 
      Lsc_microphys%cldamt(:,:,:)    = 0.0
      Lsc_microphys%droplet_number(:,:,:)    = 0.0
      if (Cldrad_control%do_stochastic_clouds) then
        allocate (Lsc_microphys%stoch_conc_drop  &
                                  (ix, jx, kx, Cldrad_control%nlwcldb + Solar_spect%nbands) )
        allocate (Lsc_microphys%stoch_conc_ice &
                                  (ix, jx, kx, cldrad_control%nlwcldb + Solar_spect%nbands) )
        allocate (Lsc_microphys%stoch_size_drop  &
                                  (ix, jx, kx, cldrad_control%nlwcldb + Solar_spect%nbands) )
        allocate (Lsc_microphys%stoch_size_ice   &
                                  (ix, jx, kx, cldrad_control%nlwcldb + Solar_spect%nbands) )
        allocate (Lsc_microphys%stoch_cldamt  &
                                  (ix, jx, kx, cldrad_control%nlwcldb + Solar_spect%nbands) )
        allocate (Lsc_microphys%stoch_droplet_number  &
                                  (ix, jx, kx, cldrad_control%nlwcldb + Solar_spect%nbands) )
  
        Lsc_microphys%lw_stoch_conc_drop => Lsc_microphys%stoch_conc_drop(:, :, :, 1:Cldrad_control%nlwcldb)
        Lsc_microphys%sw_stoch_conc_drop => Lsc_microphys%stoch_conc_drop(:, :, :, Cldrad_control%nlwcldb+1:)
        Lsc_microphys%lw_stoch_conc_ice  => Lsc_microphys%stoch_conc_ice (:, :, :, 1:Cldrad_control%nlwcldb)
        Lsc_microphys%sw_stoch_conc_ice  => Lsc_microphys%stoch_conc_ice (:, :, :, Cldrad_control%nlwcldb+1:)
        Lsc_microphys%lw_stoch_size_drop => Lsc_microphys%stoch_size_drop(:, :, :, 1:Cldrad_control%nlwcldb)
        Lsc_microphys%sw_stoch_size_drop => Lsc_microphys%stoch_size_drop(:, :, :, Cldrad_control%nlwcldb+1:)
        Lsc_microphys%lw_stoch_size_ice  => Lsc_microphys%stoch_size_ice (:, :, :, 1:Cldrad_control%nlwcldb)
        Lsc_microphys%sw_stoch_size_ice  => Lsc_microphys%stoch_size_ice (:, :, :, Cldrad_control%nlwcldb+1:)
        Lsc_microphys%lw_stoch_cldamt    => Lsc_microphys%stoch_cldamt   (:, :, :, 1:Cldrad_control%nlwcldb)
        Lsc_microphys%sw_stoch_cldamt    => Lsc_microphys%stoch_cldamt   (:, :, :, Cldrad_control%nlwcldb+1:)
        Lsc_microphys%lw_stoch_droplet_number    => Lsc_microphys%stoch_droplet_number   (:, :, :, 1:Cldrad_control%nlwcldb)
        Lsc_microphys%sw_stoch_droplet_number    => Lsc_microphys%stoch_droplet_number   (:, :, :, Cldrad_control%nlwcldb+1:)

       do n=1,Cldrad_control%nlwcldb + Solar_spect%nbands
        Lsc_microphys%stoch_conc_drop(:,:,:,n) = 0.
        Lsc_microphys%stoch_conc_ice(:,:,:,n)  = 0.
        Lsc_microphys%stoch_size_drop(:,:,:,n) = 1.0e-20
        Lsc_microphys%stoch_size_ice(:,:,:,n)  = 1.0e-20
        Lsc_microphys%stoch_cldamt(:,:,:,n)    = 0.0
        Lsc_microphys%stoch_droplet_number(:,:,:,n)    = 0.0
       end do
      endif

!---------------------------------------------------------------------
!    allocate the arrays defining the microphysical parameters of the 
!    meso-scale cloud scheme, including any precipitation fields and
!    the total cloud fraction. concentrations and fractions are init-
!    ialized to 0.0, and the effective sizes are set to small numbers to
!    avoid potential divides by zero.
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then
      allocate (Meso_microphys%conc_drop  (ix, jx, kx) )
      allocate (Meso_microphys%conc_ice   (ix, jx, kx) )
      allocate (Meso_microphys%conc_rain  (ix, jx, kx) )
      allocate (Meso_microphys%conc_snow  (ix, jx, kx) )
      allocate (Meso_microphys%size_drop  (ix, jx, kx) )
      allocate (Meso_microphys%size_ice   (ix, jx, kx) )
      allocate (Meso_microphys%size_rain  (ix, jx, kx) )
      allocate (Meso_microphys%size_snow  (ix, jx, kx) )
      allocate (Meso_microphys%cldamt     (ix, jx, kx) )
      allocate (Meso_microphys%droplet_number   (ix, jx, kx) )
      Meso_microphys%conc_drop = 0.
      Meso_microphys%conc_ice  = 0.
      Meso_microphys%conc_rain = 0.
      Meso_microphys%conc_snow = 0.
      Meso_microphys%size_drop = 1.0e-20 
      Meso_microphys%size_ice  = 1.0e-20  
      Meso_microphys%size_rain = 1.0e-20                            
      Meso_microphys%size_snow = 1.0e-20 
      Meso_microphys%cldamt    = 0.0                               
      Meso_microphys%droplet_number   = 0.0                               
      endif

!---------------------------------------------------------------------
!    allocate the arrays defining the microphysical parameters of the 
!    cell-scale cloud scheme, including any precipitation fields and
!    the total cloud fraction. concentrations and fractions are init-
!    ialized to 0.0, and the effective sizes are set to small numbers to
!    avoid potential divides by zero.
!---------------------------------------------------------------------
      if (Cldrad_control%do_donner_deep_clouds) then
      allocate (Cell_microphys%conc_drop  (ix, jx, kx) )
      allocate (Cell_microphys%conc_ice   (ix, jx, kx) )
      allocate (Cell_microphys%conc_rain  (ix, jx, kx) )
      allocate (Cell_microphys%conc_snow  (ix, jx, kx) )
      allocate (Cell_microphys%size_drop  (ix, jx, kx) )
      allocate (Cell_microphys%size_ice   (ix, jx, kx) )
      allocate (Cell_microphys%size_rain  (ix, jx, kx) )
      allocate (Cell_microphys%size_snow  (ix, jx, kx) )
      allocate (Cell_microphys%cldamt     (ix, jx, kx) )
      allocate (Cell_microphys%droplet_number  (ix, jx, kx) )
      Cell_microphys%conc_drop = 0.
      Cell_microphys%conc_ice  = 0.
      Cell_microphys%conc_rain = 0.
      Cell_microphys%conc_snow = 0.
      Cell_microphys%size_drop = 1.0e-20 
      Cell_microphys%size_ice  = 1.0e-20  
      Cell_microphys%size_rain = 1.0e-20                          
      Cell_microphys%size_snow = 1.0e-20 
      Cell_microphys%cldamt     = 0.
      Cell_microphys%droplet_number    = 0.
      endif

!---------------------------------------------------------------------
!    allocate the arrays defining the microphysical parameters of the 
!    clouds of the shallow convection scheme, including any precip-
!    itation fields and the total cloud fraction. concentrations and 
!    fractions are initialized to 0.0, and the effective sizes are set 
!    to small numbers to avoid potential divides by zero.
!---------------------------------------------------------------------
      if (Cldrad_control%do_uw_clouds) then
        allocate (Shallow_microphys%conc_drop  (ix, jx, kx) )
        allocate (Shallow_microphys%conc_ice   (ix, jx, kx) )
        allocate (Shallow_microphys%conc_rain  (ix, jx, kx) )
        allocate (Shallow_microphys%conc_snow  (ix, jx, kx) )
        allocate (Shallow_microphys%size_drop  (ix, jx, kx) )
        allocate (Shallow_microphys%size_ice   (ix, jx, kx) )
        allocate (Shallow_microphys%size_rain  (ix, jx, kx) )
        allocate (Shallow_microphys%size_snow  (ix, jx, kx) )
        allocate (Shallow_microphys%cldamt     (ix, jx, kx) )
        allocate (Shallow_microphys%droplet_number  (ix, jx, kx) )
        Shallow_microphys%conc_drop = 0.
       Shallow_microphys%conc_ice  = 0.
       Shallow_microphys%conc_rain = 0.
       Shallow_microphys%conc_snow = 0.
       Shallow_microphys%size_drop = 1.0e-20
       Shallow_microphys%size_ice  = 1.0e-20
       Shallow_microphys%size_rain = 1.0e-20
       Shallow_microphys%size_snow = 1.0e-20
       Shallow_microphys%cldamt    = 0.0
       Shallow_microphys%droplet_number    = 0.
     endif

!---------------------------------------------------------------------
!    allocate arrays to hold the cloud fractions seen by the shortwave
!    and the random and maximum overlap fractions seen by the longwave
!    radiation, and then the number of each of these types of cloud in
!    each column. initialize the cloud fractions and number of clouds
!    to zero.
!---------------------------------------------------------------------
      allocate ( Cld_spec%camtsw (ix, jx, kx ) )
      allocate ( Cld_spec%cmxolw (ix, jx, kx ) )
      allocate ( Cld_spec%crndlw (ix, jx, kx ) )
      allocate ( Cld_spec%ncldsw (ix, jx     ) )
      allocate ( Cld_spec%nmxolw (ix, jx     ) )
      allocate ( Cld_spec%nrndlw (ix, jx     ) )
      Cld_spec%cmxolw(:,:,:) = 0.0E+00
      Cld_spec%crndlw(:,:,:) = 0.0E+00
      Cld_spec%camtsw(:,:,:) = 0.0E+00
      Cld_spec%nmxolw (:,:)  = 0
      Cld_spec%nrndlw (:,:)  = 0
      Cld_spec%ncldsw (:,:)  = 0
      if (Cldrad_control%do_stochastic_clouds) then
        allocate ( Cld_spec%camtsw_band    &
                                 (ix, jx, kx, Solar_spect%nbands) )
        allocate ( Cld_spec%ncldsw_band    &
                                 (ix, jx, Solar_spect%nbands) )
        allocate (Cld_spec%cld_thickness_sw_band & 
                                 (ix, jx, kx, Solar_spect%nbands) )
        allocate (Cld_spec%iwp_sw_band    &
                                 (ix, jx, kx, Solar_spect%nbands) )
        allocate (Cld_spec%lwp_sw_band   &
                                 (ix, jx, kx, Solar_spect%nbands) )
        allocate (Cld_spec%reff_liq_sw_band   &  
                                 (ix, jx, kx, Solar_spect%nbands) )
        allocate (Cld_spec%reff_ice_sw_band   &   
                                 (ix, jx, kx, Solar_spect%nbands) )
        do n=1,Solar_spect%nbands
        Cld_spec%camtsw_band(:,:,:,n) = 0.0E+00
        Cld_spec%ncldsw_band(:,:,n) = 0
        Cld_spec%cld_thickness_sw_band(:,:,:,n) = 0              
        Cld_spec%lwp_sw_band(:,:,:,n)   = 0.0
        Cld_spec%iwp_sw_band(:,:,:,n)   = 0.0
        Cld_spec%reff_liq_sw_band(:,:,:,n)      = 10.0
        Cld_spec%reff_ice_sw_band(:,:,:,n)      = 30.0
        end do
        allocate ( Cld_spec%crndlw_band    &
                                 (ix, jx, kx, Cldrad_control%nlwcldb) )
        allocate ( Cld_spec%nrndlw_band    &
                                 (ix, jx, Cldrad_control%nlwcldb) )
        allocate (Cld_spec%cld_thickness_lw_band & 
                                 (ix, jx, kx, Cldrad_control%nlwcldb) )
        allocate (Cld_spec%iwp_lw_band    &
                                 (ix, jx, kx, Cldrad_control%nlwcldb) )
        allocate (Cld_spec%lwp_lw_band   &
                                 (ix, jx, kx, Cldrad_control%nlwcldb) )
        allocate (Cld_spec%reff_liq_lw_band   &  
                                 (ix, jx, kx, Cldrad_control%nlwcldb) )
        allocate (Cld_spec%reff_ice_lw_band   &   
                                 (ix, jx, kx, Cldrad_control%nlwcldb) )
        do n=1, Cldrad_control%nlwcldb
        Cld_spec%crndlw_band(:,:,:,n) = 0.0E+00
        Cld_spec%nrndlw_band(:,:,n) = 0
        Cld_spec%cld_thickness_lw_band(:,:,:,n) = 0              
        Cld_spec%lwp_lw_band(:,:,:,n)   = 0.0
        Cld_spec%iwp_lw_band(:,:,:,n)   = 0.0
        Cld_spec%reff_liq_lw_band(:,:,:,n)      = 10.0
        Cld_spec%reff_ice_lw_band (:,:,:,n)     = 30.0
        end do
        allocate (Cld_spec%stoch_cloud_type   &
            (ix, jx, kx, Solar_spect%nbands + Cldrad_control%nlwcldb) )
        Cld_spec%stoch_cloud_type = 0
      endif

!--------------------------------------------------------------------
!    allocate and initialize various arrays that are used by one or
!    another cloud scheme to specify the cloud locations and amounts.
!    initialization provides values consistent with the absence of
!    cloud, with the exception of the particle size fields which are
!    set to small, non-zero values.
!---------------------------------------------------------------------
      allocate (Cld_spec%hi_cloud       (ix, jx, kx) )
      allocate (Cld_spec%mid_cloud      (ix, jx, kx) )
      allocate (Cld_spec%low_cloud      (ix, jx, kx) )
      allocate (Cld_spec%ice_cloud      (ix, jx, kx) )
      allocate (Cld_spec%iwp            (ix, jx, kx) )
      allocate (Cld_spec%lwp            (ix, jx, kx) )
      allocate (Cld_spec%reff_liq       (ix, jx, kx) )
      allocate (Cld_spec%reff_ice       (ix, jx, kx) )
      allocate (Cld_spec%reff_liq_lim   (ix, jx, kx) )
      allocate (Cld_spec%reff_ice_lim   (ix, jx, kx) )
      allocate (Cld_spec%reff_liq_micro (ix, jx, kx) )
      allocate (Cld_spec%reff_ice_micro (ix, jx, kx) )
      allocate (Cld_spec%tau            (ix, jx, kx, num_slingo_bands) )
      allocate (Cld_spec%liq_frac       (ix, jx, kx) )
      allocate (Cld_spec%cld_thickness  (ix, jx, kx) )
      allocate (Cld_spec%cloud_water    (ix,jx,kx) )
      allocate (Cld_spec%cloud_ice      (ix,jx,kx)   )
      allocate (Cld_spec%cloud_area     (ix,jx,kx)  )
      allocate (Cld_spec%cloud_droplet  (ix,jx,kx)  )

      Cld_spec%hi_cloud (:,:,:)     = .false.
      Cld_spec%mid_cloud(:,:,:)     = .false.
      Cld_spec%low_cloud(:,:,:)     = .false.
      Cld_spec%ice_cloud(:,:,:)     = .false.
      Cld_spec%lwp(:,:,:)    = 0.0
      Cld_spec%iwp(:,:,:)    = 0.0
      Cld_spec%reff_liq(:,:,:)      = 10.0
      Cld_spec%reff_ice(:,:,:)      = 30.0
      Cld_spec%reff_liq_lim(:,:,:)      = 10.0
      Cld_spec%reff_ice_lim(:,:,:)      = 30.0
      Cld_spec%reff_liq_micro(:,:,:) = 10.0
      Cld_spec%reff_ice_micro(:,:,:) = 30.0
      Cld_spec%liq_frac(:,:,:)      = 0.0
      Cld_spec%cld_thickness(:,:,:) = 0              
      Cld_spec%cloud_water(:,:,:)   = 0.
      Cld_spec%cloud_ice(:,:,:)     = 0.
      Cld_spec%cloud_area(:,:,:)    = 0.
      Cld_spec%cloud_droplet(:,:,:)    = 0.
      do n=1, num_slingo_bands
      Cld_spec%tau(:,:,:,n)  = 0.0
      end do

!---------------------------------------------------------------------



end subroutine initialize_cldamts              



!###################################################################
! <SUBROUTINE NAME="combine_cloud_properties">
!  <OVERVIEW>
!    combine_cloud_properties produces cloud specification property 
!    arrays for the total cloud field in each grid box, using as input 
!    the specification of the component cloud types that may be present
!    (large-scale, mesoscale and cell-scale).
!  </OVERVIEW>
!  <DESCRIPTION>
!    combine_cloud_properties produces cloud specification property 
!    arrays for the total cloud field in each grid box, using as input 
!    the specification of the component cloud types that may be present
!    (large-scale, mesoscale and cell-scale).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call combine_cloud_properties (Lsc_microphys, Meso_microphys,  &
!                                     Cell_microphys, Cld_spec)
!  </TEMPLATE>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </INOUT>
!  <IN NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </IN>
!  <IN NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                        clouds assciated with donner convection
!  </IN>
!  <IN NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell
!                        clouds associated with donner convection
!  </IN>
!  </IN>
!  <IN NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                        clouds associated with uw shallow convection
!  </IN>
! </SUBROUTINE>
! 
subroutine combine_cloud_properties (is, js, temp, Rad_time, &
                                     Lsc_microphys, Meso_microphys,  &
                                     Cell_microphys, Shallow_microphys,&
                                     Cld_spec)

!----------------------------------------------------------------------
!    combine_cloud_properties produces cloud specification property 
!    arrays for the total cloud field in each grid box, using as input 
!    the specification of the component cloud types that may be present
!    (large-scale, donner mesoscale and cell-scale, uw shallow).
!----------------------------------------------------------------------

integer, intent(in)  :: is, js
real, dimension(:,:), intent(in) :: temp
type(time_type), intent(in) :: Rad_time
type(microphysics_type),        intent(in)    :: Lsc_microphys, &
                                                 Meso_microphys, &
                                                 Cell_microphys, &
                                                 Shallow_microphys
type(cld_specification_type), intent(inout)   :: Cld_spec

!----------------------------------------------------------------------
!   intent(in) variables:
!
!       Lsc_microphys  microphysical specification for large-scale 
!                      clouds
!                      [ microphysics_type ]
!       Meso_microphys microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!                      [ microphysics_type ]
!       Cell_microphys microphysical specification for convective cell
!                      clouds associated with donner convection
!                      [ microphysics_type ]
!       Shallow_microphys 
!                      microphysical specification for 
!                      clouds associated with uw shallow convection
!                      [ microphysics_type ]
!
!    intent(inout) variables:
!
!       Cld_spec       variables on the model grid which define all or
!                      some of the following, dependent on the specific
!                      cloud parameterization: cloud optical paths, 
!                      particle sizes, cloud fractions, cloud thickness,
!                      number of clouds in a column, and /or cloud type 
!                      (high/mid/low, ice/liq or random/max overlap)
!                      [ cld_specification_type ]
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!    variables for folding Donner cloud properties into stochastic
!    cloud arrays
!------------------------------------------------------------------
      type(randomNumberStream),   &
                    dimension(size(Lsc_microphys%cldamt,1),   &
                              size(Lsc_microphys%cldamt,2)) :: streams
      real, &            
                    dimension(size(Lsc_microphys%cldamt,1),   &
                              size(Lsc_microphys%cldamt,2),   &       
                              size(Lsc_microphys%cldamt,3),   &       
                              size(Lsc_microphys%stoch_cldamt, 4))  :: &
                                                     randomNumbers
      real    :: seedwts(8) = (/3000.,1000.,300.,100.,30.,10.,3.,1./)
      integer :: nn, nsubcols

      integer :: i, j, k, n

!---------------------------------------------------------------------
!    total-cloud specification properties need be defined only when
!    strat_cloud, donner_deep and/or uw shallow clouds are active.
!---------------------------------------------------------------------
      if (Cldrad_control%do_strat_clouds .and.    &
          Cldrad_control%do_uw_clouds .and.   &
          Cldrad_control%do_donner_deep_clouds) then

!----------------------------------------------------------------------
!    if strat_cloud, donner_deep and uw shallow are all active, define 
!    the random overlap cloud fraction as the sum of the fractions of 
!    the large-scale, donner meso-scale and cell-scale, and the
!    uw shallow clouds.
!---------------------------------------------------------------------
       Cld_spec%crndlw = Lsc_microphys%cldamt +   &
                         Cell_microphys%cldamt +  &
                       Meso_microphys%cldamt + Shallow_microphys%cldamt
     else if (Cldrad_control%do_strat_clouds .and.    &
          Cldrad_control%do_donner_deep_clouds) then


!----------------------------------------------------------------------
!    if strat_cloud and donner_deep are both active, define the random
!    overlap cloud fraction as the sum of the fractions of the large-
!    scale, meso-scale and cell-scale clouds.
!---------------------------------------------------------------------
        Cld_spec%crndlw = Lsc_microphys%cldamt +    &
                          Cell_microphys%cldamt + Meso_microphys%cldamt

       else if (Cldrad_control%do_strat_clouds .and.    &
           Cldrad_control%do_uw_clouds) then

!----------------------------------------------------------------------
!    if strat_cloud and uw_shallow  are both active, define the random
!    overlap cloud fraction as the sum of the fractions of the large-
!    scale and uw shallow clouds.
!---------------------------------------------------------------------
         Cld_spec%crndlw = Lsc_microphys%cldamt +    &
                           Shallow_microphys%cldamt

    else if (Cldrad_control%do_uw_clouds .and.    &
             Cldrad_control%do_donner_deep_clouds) then
 
!----------------------------------------------------------------------
!    if strat_cloud and donner_deep are both active, define the random
!    overlap cloud fraction as the sum of the fractions of the large-
!    scale, meso-scale and cell-scale clouds.
!---------------------------------------------------------------------
         Cld_spec%crndlw = Shallow_microphys%cldamt +    &
                          Cell_microphys%cldamt + Meso_microphys%cldamt

!------------------------------------------------------------------
!    if strat cloud is activated but donner_deep is not, define the 
!    total-cloud amount to be the large scale cloud amount.
!----------------------------------------------------------------------
      else if (Cldrad_control%do_strat_clouds) then
        Cld_spec%crndlw = Lsc_microphys%cldamt

!---------------------------------------------------------------------
!    if donner_deep is active but strat cloud is not, then the mesoscale
!    and cell-scale cloud amounts are combined to define the total
!    random-overlap cloud fraction.
!----------------------------------------------------------------------
      else if (Cldrad_control%do_donner_deep_clouds) then
        Cld_spec%crndlw = Cell_microphys%cldamt + Meso_microphys%cldamt
      else if (Cldrad_control%do_uw_clouds) then
        Cld_spec%crndlw = Shallow_microphys%cldamt
      endif

!---------------------------------------------------------------------
!    randomly-overlapped clouds are being assumed for donner_deep and 
!    strat cloud module clouds. set the max overlap cloud fraction to 
!    zero, be certain that the random overlap fraction is .le. 1. after
!    the summing of the component cloud fractions, and define the total
!    cloud fraction to be used by the sw code.
!---------------------------------------------------------------------
      Cld_spec%cmxolw = 0.0
      Cld_spec%crndlw = MIN (Cld_spec%crndlw, 1.00)
      Cld_spec%camtsw = Cld_spec%crndlw

!--------------------------------------------------------------------
!    if stochastic clouds are being used, define the cloud type to be 
!    seen by the radiation code in each stochastic subcolumn.
!--------------------------------------------------------------------
      if (Cldrad_control%do_stochastic_clouds) then

!--------------------------------------------------------------------
!   assign either a 1 or a 0 to each subcolumn indicating whether
!   lsc cloud is present or not. 
!--------------------------------------------------------------------
        nsubcols = Solar_spect%nbands + Cldrad_control%nlwcldb
        do n=1,nsubcols
          if ( n > Solar_spect%nbands) then
            nn = n - Solar_spect%nbands    
          else
            nn = n + Cldrad_control%nlwcldb    
          endif
          do k=1,size(Lsc_microphys%cldamt,3) ! Levels
            do j=1,size(Lsc_microphys%cldamt,2) ! Lons
              do i=1,size(Lsc_microphys%cldamt,1) ! Lats
                if (Lsc_microphys%stoch_cldamt(i,j,k,nn) > 0.) then
 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                  Cld_spec%stoch_cloud_type(i,j,k,n) = 1 
               else
                  Cld_spec%stoch_cloud_type(i,j,k,n) = 0  
               endif
             end do
            end do
          end do
        end do

!----------------------------------------------------------------------
!    compare the cell and meso-scale cloud amounts to a random number, 
!    and replace the large-scale cloud and clear sky assignment in each 
!    subcolumn with an assignment of cell or meso-scale clouds when the 
!    number is less than the cloud fraction. use the maximum overlap 
!    assumption. treat the random number as the location with the PDF 
!    of total water. cells are at the top of the PDF; then meso-scale 
!    anvils, then large-scale clouds and clear sky.
!------------------------------------------------------------
        if (Cldrad_control%do_donner_deep_clouds) then     
          if (Cldrad_control%use_temp_for_seed) then
            do j=1,size(Lsc_microphys%cldamt,2)
              do i=1,size(Lsc_microphys%cldamt,1)
                streams(i,j) = &
                  initializeRandomNumberStream (                      &
                    ishftc(nint(temp(i,j)*seedwts),1))
              end do
            end do
          else
            do j=1,size(Lsc_microphys%cldamt,2)
              do i=1,size(Lsc_microphys%cldamt,1)
                streams(i,j) = &
                  initializeRandomNumberStream (                      &
                    constructSeed(nint(lons(is+i-1,js+j-1)),           &
                                  nint(lats(is+i-1,js+j-1)), Rad_time, &
                                  perm = 1))
              end do
            end do
          endif
 
!----------------------------------------------------------------------
!    get the random numbers to do both sw and lw at oncer.
!----------------------------------------------------------------------
          do j=1,size(Lsc_microphys%cldamt,2) ! Lons
            do i=1,size(Lsc_microphys%cldamt,1) ! Lats
              call getRandomNumbers (streams(i,j),    &
                                                randomNumbers(i,j,1,:))
            end do
          end do
 
!----------------------------------------------------------------------
!    here is maximum overlap. we use a 3D arrary for the random numbers
!    for flexibility.
!----------------------------------------------------------------------
          do k=2,size(Lsc_microphys%cldamt,3)
            randomNumbers(:,:,k,:) = randomNumbers(:,:,1,:)
          end do
 
!----------------------------------------------------------------------
!    assign cloud types, band by band
!----------------------------------------------------------------------
          do n=1,nsubcols    
            do k=1,size(Lsc_microphys%cldamt,3) ! Levels
              do j=1,size(Lsc_microphys%cldamt,2) ! Lons
                do i=1,size(Lsc_microphys%cldamt,1) ! Lats
                  if (randomNumbers(i,j,k,n) >     &
                            (1. - Cell_microphys%cldamt(i,j,k))) then

!----------------------------------------------------------------------
!    it's a cell.
!----------------------------------------------------------------------
                    Cld_spec%stoch_cloud_type(i,j,k,n) = 3  
                  else if (randomNumbers(i,j,k,n) >    &
                           (1. - Cell_microphys%cldamt(i, j, k) - &
                                  Meso_microphys%cldamt(i, j, k))) then
 
!----------------------------------------------------------------------
!    it's a meso-scale.
!----------------------------------------------------------------------
                    Cld_spec%stoch_cloud_type(i,j,k,n) = 2 
                  endif
                end do
              end do
            end do
          end do
        endif

!----------------------------------------------------------------------
!    compare the uw shallow cloud amount to a random number, and replace
!    the donner cloud, large-scale cloud or clear sky previously 
!    assigned in each subcolumn with an assignment of uw shallow cloud 
!    when the number is less than the cloud fraction. use the maximum 
!    overlap assumption. treat the random number as the location with 
!    the PDF of total water. uw shallow clouds are at the top of this 
!    PDF, then large-scale clouds and clear sky.
!------------------------------------------------------------
        if (Cldrad_control%do_uw_clouds) then     
          if (Cldrad_control%use_temp_for_seed) then
            do j=1,size(Lsc_microphys%cldamt,2)
              do i=1,size(Lsc_microphys%cldamt,1)
                streams(i,j) = &
                  initializeRandomNumberStream (                      &
                    ishftc(nint(temp(i,j)*seedwts),2))
              end do
            end do
          else
            do j=1,size(Lsc_microphys%cldamt,2)
              do i=1,size(Lsc_microphys%cldamt,1)
                streams(i,j) = &
                  initializeRandomNumberStream (                      &
                    constructSeed(nint(lons(is+i-1,js+j-1)),           &
                                  nint(lats(is+i-1,js+j-1)), Rad_time, &
                                  perm = 2))
              end do
            end do
          endif
 
!----------------------------------------------------------------------
!    get the random numbers to do both sw and lw at oncer.
!----------------------------------------------------------------------
          do j=1,size(Lsc_microphys%cldamt,2) ! Lons
            do i=1,size(Lsc_microphys%cldamt,1) ! Lats
              call getRandomNumbers (streams(i,j),    &
                                                randomNumbers(i,j,1,:))
            end do
          end do
 
!----------------------------------------------------------------------
!    here is maximum overlap. we use a 3D arrary for the random numbers
!    for flexibility.
!----------------------------------------------------------------------
          do k=2,size(Lsc_microphys%cldamt,3)
            randomNumbers(:,:,k,:) = randomNumbers(:,:,1,:)
          end do
 
!----------------------------------------------------------------------
!    assign cloud type, band by band
!----------------------------------------------------------------------
          do n=1,nsubcols
            do k=1,size(Lsc_microphys%cldamt,3) ! Levels
              do j=1,size(Lsc_microphys%cldamt,2) ! Lons
                do i=1,size(Lsc_microphys%cldamt,1) ! Lats
                  if (randomNumbers(i,j,k,n) >     &
                            (1. - Shallow_microphys%cldamt(i,j,k))) then

!----------------------------------------------------------------------
!    it's a uw shallow.
!----------------------------------------------------------------------
                    Cld_spec%stoch_cloud_type(i,j,k,n) = 4  
                  endif
                end do
              end do
            end do
          end do
        endif

!---------------------------------------------------------------------
!     define the cloud amount in each stochastic subcolumn to be either
!     1.0 if cloud is present, or 0.0 if no cloud exists.
!---------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(Lsc_microphys%cldamt,3) ! Levels
            do j=1,size(Lsc_microphys%cldamt,2) ! Lons
              do i=1,size(Lsc_microphys%cldamt,1) ! Lats
                if (Cld_spec%stoch_cloud_type(i,j,k,n) /= 0) then  
                  Cld_spec%camtsw_band(i,j,k,n) = 1.0
                else
                  Cld_spec%camtsw_band(i,j,k,n) = 0.0
                endif
              end do
            end do
          end do
        end do
        
        do n=1,Cldrad_control%nlwcldb
          nn = Solar_spect%nbands + n
          do k=1,size(Lsc_microphys%cldamt,3) ! Levels
            do j=1,size(Lsc_microphys%cldamt,2) ! Lons
              do i=1,size(Lsc_microphys%cldamt,1) ! Lats
                if (Cld_spec%stoch_cloud_type(i,j,k,nn) /= 0) then  
                  Cld_spec%crndlw_band(i,j,k,n) = 1.0
                else
                  Cld_spec%crndlw_band(i,j,k,n) = 0.0
                endif
              end do
            end do
          end do
        end do
      endif  ! (do_stochastic)


!#####################################################################


end subroutine combine_cloud_properties 



!###################################################################
! <SUBROUTINE NAME="microphs_presc_conc">
!  <OVERVIEW>
!   Subroutine to determine water droplet and ice crystal based on
!   prescribed microphysics model.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine uses prescribed microphysics model to determine
!   concentrations of water droplets and ice crystals. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_presc_conc (is, ie, js, je, deltaz, temp,      &
!                                 Cld_spec, Lsc_microphys)
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting indice of the x dimension in the physics domain
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   ending indice of the x dimension in the physics domain
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting indice of the y dimension in the physics domain
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   ending indice of the y dimension in the physics domain 
!  </IN>
!  <IN NAME="deltaz" TYPE="real">
!   Height of each pressure layers.
!  </IN>
!  <IN NAME="temp" TYPE="real">
!   Temperatures of pressure levels
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification properties on model grid,
!  </IN>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                        clouds
!  </INOUT>
! </SUBROUTINE>
!
subroutine microphys_presc_conc (is, ie, js, je, deltaz, temp,      &
                                 Cld_spec, Lsc_microphys)

!---------------------------------------------------------------------
!    microphys_presc_conc defines microphysical properties based on the
!    assumption of specified total water paths for high, middle and low 
!    clouds.
!---------------------------------------------------------------------

integer,                      intent(in)     :: is, ie, js, je
real, dimension(:,:,:),       intent(in)     :: deltaz, temp  
type(cld_specification_type), intent(in)     :: Cld_spec
type(microphysics_type),      intent(inout)  :: Lsc_microphys

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                     the physics_window being integrated
!      deltaz         model vertical grid separation that is to be used
!                     for cloud calculations
!                     [meters]
!      temp           temperature at model levels (1:nlev) that is to
!                     be used in cloud calculations
!                     [ deg K ]
!      Cld_spec       cld_specification_type structure, contains var-
!                     iables defining the cloud distribution
!
!   intent(inout) variables:
!
!      Lsc_microphys  microphysics_type structure, contains variables
!                     describing the microphysical properties of the
!                     large-scale clouds
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
! local variables:                                                  
!---------------------------------------------------------------------

      real,    dimension(size(temp,1), size(temp,2), size(temp,3)) :: &
                                                       conc

      integer, dimension(size(temp,1), size(temp,2)) :: &
                                                       nhi_clouds, &
                                                       nmid_clouds, &
                                                       nlow_clouds

      integer  :: i,j,k

!--------------------------------------------------------------------
!  local variables:
!
!      conc             droplet concentration  [ g / m**3 ]
!      nhi_clouds       number of layers with high clouds
!      nmid_clouds      number of layers with middle clouds
!      nlow_clouds      number of layers with low clouds
!      i,j,k            do-loop indices
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!!! RSH NOTE:
!
!    THE FOLLOWING treatment of diag_cloud_mod is here as an INITIAL 
!    IMPLEMENTATION to allow compilation and model execution, and 
!    provide "reasonable ?? " values.
! 
!    Code developed but NOT YET ADDED HERE reflects a later approach. 
!    That code is available under the fez release, and will be added to
!    the repository when upgrades to the cloud-radiation modules are 
!    completed.
!
!    obtain drop and ice size and concentrations, consistent with 
!    the diag_cloud scheme. As a test case, the following is a simple 
!    specification of constant concentration and size in all boxes 
!    defined as cloudy, attempting to come close to the prescribed 
!    values used for other cloud schemes. assume ice cld thickness 
!    = 2.0 km; then conc_ice=10.0E-03 => iwp = 20 g/m^2, similar to that
!    prescribed in microphys_presc_conc. assume water cld thickness 
!    = 3.5 km; then conc_drop = 20E-03 => lwp = 70 g / m^2, similar to 
!    that prescribed in microphys_presc_conc.  use sizes as used in 
!    microphys_presc_conc (50 and 20 microns). when done, radiative 
!    boundary fluxes are "similar" to non-microphysical results
!    for test case done here, and shows reasonable sensitivity to
!    variations in concentrations.
!    AGAIN, THIS IS AN INITIAL IMPLEMENTATION FOR TESTING ONLY !!!!
!
!!! RSH
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

!---------------------------------------------------------------------

      if (Cldrad_control%do_diag_clouds) then
!---------------------------------------------------------------------
!    define concentrations and sizes of ice at those points which have
!    condensate and which were previously determined to be ice points
!    (Cld_spec%ice_cloud), and define concentrations and sizes of
!    liquid droplets at those points with condensate that had been 
!    determined to support liquid clouds.
!---------------------------------------------------------------------
        do k=1,size(Cld_spec%camtsw,3)
          do j=1,size(Cld_spec%camtsw,2)
            do i=1,size(Cld_spec%camtsw,1)
              if (Cld_spec%camtsw(i,j,k) > 0.0) then
                if (Cld_spec%ice_cloud(i,j,k)) then
                  Lsc_microphys%conc_ice(i,j,k) = 10.0E-03  
                  Lsc_microphys%size_ice(i,j,k) = 50.     
                else
                  Lsc_microphys%conc_drop(i,j,k) = 20.0E-03
                  Lsc_microphys%size_drop(i,j,k) = 20.
                endif
              endif
            end do
          end do
        end do
!----------------------------------------------------------------------
!    for the non-diag_cloud_mod cases, assume that the water path is 
!    preset at fixed values (lwpath_hi, _mid, _low) for "high", "mid", 
!    "low" clouds. the lwpath in each cloud layer within "hi", "mid" 
!    "low" pressure intervals is that lwpath_... divided by the number 
!    of clouds present in that pressure interval.
!----------------------------------------------------------------------
      else

!----------------------------------------------------------------------
!    define the number of high, middle, low clouds according to
!    Wetherald's criterion.
!----------------------------------------------------------------------
        do j=1,size(Cld_spec%camtsw,2)
          do i=1,size(Cld_spec%camtsw,1)
            nhi_clouds(i,j)  = 0
            nmid_clouds(i,j) = 0
            nlow_clouds(i,j) = 0
            do k=1,size(Cld_spec%camtsw,3)
              if (Cld_spec%hi_cloud(i,j,k)) &
                               nhi_clouds(i,j)  =  nhi_clouds(i,j)  + 1
              if (Cld_spec%mid_cloud(i,j,k)) &
                               nmid_clouds(i,j) =  nmid_clouds(i,j) + 1
              if (Cld_spec%low_cloud(i,j,k))  &
                               nlow_clouds(i,j) =  nlow_clouds(i,j) + 1
            end do
          end do
        end do

!----------------------------------------------------------------------
!    compute the water substance concentration in each layer 
!    (as water path / layer geometric path).
!----------------------------------------------------------------------
        conc(:,:,:) = 0.0E+00
        do j=1,size(Cld_spec%camtsw,2)
          do i=1,size(Cld_spec%camtsw,1)
            do k=1,size(Cld_spec%camtsw,3)
              if (Cld_spec%hi_cloud(i,j,k)) then
                conc(i,j,k) = lwpath_hi/   &
                              (nhi_clouds(i,j)*deltaz(i,j,k))
              endif
              if (Cld_spec%mid_cloud(i,j,k)) then
                conc(i,j,k) = lwpath_mid/    &
                              (nmid_clouds(i,j)*deltaz(i,j,k))
              endif
              if (Cld_spec%low_cloud(i,j,k)) then
                conc(i,j,k) = lwpath_low    /                   &
                              (nlow_clouds(i,j)*deltaz(i,j,k))
              endif
            end do
          end do
        end do

!----------------------------------------------------------------------
!    split conc into conc_ice and conc_drop, depending on temperature
!    criterion (T < 273.16). assume that rain and / or snow are not
!    present.
!----------------------------------------------------------------------
        do k=1,size(Cld_spec%camtsw,3)
          do j=1,size(Cld_spec%camtsw,2)
            do i=1,size(Cld_spec%camtsw,1)
              if (temp(i,j,k) .LT. 273.16) then
                Lsc_microphys%conc_ice(i,j,k) = conc(i,j,k)
              else
                Lsc_microphys%conc_drop(i,j,k) = conc(i,j,k)
              endif
            end do
          end do
        end do

!----------------------------------------------------------------------
!    define sizes of microphysical species, using namelist values. note
!    that namelist drop and rain sizes are radii, so multiply by 2 to 
!    produce diameter, as desired for the %size_ arrays.
!----------------------------------------------------------------------
        Lsc_microphys%size_drop(:,:,:) = 2.0*wtr_cld_reff
        Lsc_microphys%size_rain(:,:,:) = 2.0*rain_reff
        Lsc_microphys%size_ice (:,:,:) = ice_cld_reff
      endif ! (do_diag_clouds)

!--------------------------------------------------------------------


end subroutine microphys_presc_conc


!#################################################################



                       end module cloud_spec_mod



!FDOC_TAG_GFDL

                 module diag_clouds_W_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!    fil
! </CONTACT>
! <REVIEWER EMAIL="">
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!           diag cloud radiative properties module
!            currently a wrapper until SKYHI goes away and this
!            module can be consolidated with diag_cloud_mod
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use time_manager_mod,       only: time_type
use diag_cloud_mod,         only: diag_cloud_avg2, diag_cloud_driver2
use diag_cloud_rad_mod,     only: cloud_opt_prop_tg_lw,  &
                                  cloud_opt_prop_tg_sw
use mpp_mod,                only: input_nml_file
use fms_mod,                only: open_namelist_file, file_exist, &
                                  check_nml_error, &
                                  write_version_number, &
                                  mpp_pe, mpp_root_pe, &
                                  close_file, stdlog
use rad_utilities_mod,      only: microphysics_type, &
                                  cld_specification_type, &
                                  cldrad_properties_type, &
                                  Sw_control

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!           diag cloud radiative properties module
!            currently a wrapper until SKYHI goes away and this
!            module can be consolidated with diag_cloud_mod
!
!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

   character(len=128)  :: version =  '$Id: diag_clouds_W.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
   character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          diag_clouds_W_init,    &
          diag_clouds_W_end,    &
          diag_clouds_amt,  &
          obtain_bulk_lw_diag, &
          obtain_bulk_sw_diag

!---------------------------------------------------------------------
!-------- namelist  ---------

real       :: taucrit = 1.0     !  critical optical depth at which 
                                !  solar beam is treated as diffuse
                                !  rather than direct
integer    :: num_slingo_bands = 4



namelist /diag_clouds_W_nml /     &
                               num_slingo_bands, &
                               taucrit


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

logical :: module_is_initialized = .false.
!----------------------------------------------------------------------
!----------------------------------------------------------------------




contains 





! <SUBROUTINE NAME="diag_clouds_W_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_clouds_W_init  (num_slingo_bands_out)
!
!  </TEMPLATE>
!  <OUT NAME="num_slingo_bands_out" TYPE="integer">
! 
!  </OUT>
! </SUBROUTINE>
!
subroutine diag_clouds_W_init  (num_slingo_bands_out)


integer, intent(out) :: num_slingo_bands_out

      integer            :: unit, ierr, io, logunit


      if (module_is_initialized) return
!---------------------------------------------------------------------
!-----  read namelist  ------
  
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=diag_clouds_W_nml, iostat=io)
      ierr = check_nml_error(io,'diag_clouds_W_nml')
#else   
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=diag_clouds_W_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'diag_clouds_W_nml')
        enddo
10      call close_file (unit)
      endif
#endif

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           logunit = stdlog()
           write (logunit,nml=diag_clouds_W_nml)
      endif

      num_slingo_bands_out = num_slingo_bands
! (ultimately get from diag_cloud_mod when call diag_cloud_init)
      module_is_initialized = .true.

end subroutine diag_clouds_W_init


!#####################################################################

! <SUBROUTINE NAME="diag_clouds_W_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_clouds_W_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine diag_clouds_W_end
 
!----------------------------------------------------------------------
!    diag_clouds_W_end is the destructor for diag_clouds_W_mod.
!----------------------------------------------------------------------
 
!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------


end subroutine diag_clouds_W_end



!#################################################################

! <SUBROUTINE NAME="diag_clouds_amt">
!  <OVERVIEW>
!    diag_clouds_amt defines the location, amount (cloud fraction),
!    number, optical depth, thickness and liquid percentage of clouds
!    present on the model grid.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_clouds_amt defines the location, amount (cloud fraction),
!    number, optical depth, thickness and liquid percentage of clouds
!    present on the model grid.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_clouds_amt (is, ie, js, je, lat, pflux, press,   &
!                Rad_time, Cld_spec, Lsc_microphys) 
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="lat" TYPE="real">
!      lat          latitude of model points  [ radians ]
! 
!  </IN>
!  <IN NAME="pflux" TYPE="real">
!      pflux        average of pressure at adjacent model levels
!                   [ (kg /( m s^2) ]
! 
!  </IN>
!  <IN NAME="press" TYPE="real">
!      press        pressure at model levels (1:nlev), surface
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
! 
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
!      Rad_time     time at which the climatologically-determined,
!                   time-varying zonal cloud fields should apply
!                   [ time_type, days and seconds]
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec     cld_specification_type variable containing the
!                   cloud specification input fields needed by the
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %liq_frac
!                           percentage of cloud condensate in a grid
!                           box which is liquid  [ dimensionless ]
!                  %tau     cloud optical depth  [ dimensionless ]
!                  %cloud_thickness
!                           number of model layers over which the cloud
!                           in this grid box extends
!                  %ice_cloud
!                           logical variable, which if true, indicates
!                           that the grid box will contain ice cloud;
!                           if false, the box will contain liquid cloud
! 
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine diag_clouds_amt (is, ie, js, je, lat, pflux, press,   &
                            Rad_time, Cld_spec, Lsc_microphys) 

!----------------------------------------------------------------------
!    diag_clouds_amt defines the location, amount (cloud fraction), 
!    number, optical depth, thickness and liquid percentage of clouds 
!    present on the model grid.
!----------------------------------------------------------------------

integer,                      intent(in)     ::  is, ie, js, je
real,    dimension(:,:),      intent(in)     ::  lat
real,    dimension(:,:,:),    intent(in)     ::  pflux, press
type(time_type),              intent(in)     ::  Rad_time     
type(cld_specification_type), intent(inout)  ::  Cld_spec
type(microphysics_type),      intent(inout)  ::  Lsc_microphys

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      lat          latitude of model points  [ radians ]
!      pflux        average of pressure at adjacent model levels
!                   [ (kg /( m s^2) ] 
!      press        pressure at model levels (1:nlev), surface 
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
!      Rad_time     time at which the climatologically-determined, 
!                   time-varying zonal cloud fields should apply
!                   [ time_type, days and seconds]
!
!   intent(inout) variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %liq_frac 
!                           percentage of cloud condensate in a grid 
!                           box which is liquid  [ dimensionless ]
!                  %tau     cloud optical depth  [ dimensionless ]
!                  %cloud_thickness
!                           number of model layers over which the cloud
!                           in this grid box extends
!                  %ice_cloud  
!                           logical variable, which if true, indicates 
!                           that the grid box will contain ice cloud; 
!                           if false, the box will contain liquid cloud
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables

      logical, dimension (size(Cld_spec%camtsw,1),                 &
                          size(Cld_spec%camtsw,2),                 &
                          size(Cld_spec%camtsw,3)) :: ice_cloud_cs

      real, dimension    (size(Cld_spec%camtsw,1),                 &
                          size(Cld_spec%camtsw,2),                 &
                          size(Cld_spec%camtsw,3)) ::  cldamt,     &
                                                       liq_frac

      real, dimension    (size(Cld_spec%camtsw,1),                 &
                          size(Cld_spec%camtsw,2),                 &
                          size(Cld_spec%camtsw,3),                 &
                          size(Cld_spec%tau,4))    ::  tau

      integer, dimension (size(Cld_spec%camtsw,1),                 &
                          size(Cld_spec%camtsw,2),                 &
                          size(Cld_spec%camtsw,3)) ::  ktop, kbtm

      integer     ::   i,j, k, kc           
      integer     ::   kx                     

!----------------------------------------------------------------------
!  local variables:
!
!      ice_cloud_cs  logical flag indicating whether a given cloud (in
!                    cloud-space) is made up of ice (.true.) or liquid
!                    (.false.)
!      cldamt        fractional cloudiness in a grid box 
!                    (in cloud-space)  [ dimensionless ]
!      liq_frac      the fraction of cloud in a grid box which is liquid
!                    (in cloud-space) [ dimensionless ]
!      tau           cloud optical depth, in cloud-space   
!                    [ dimensionless ]
!      ktop          model index of the cloud top
!      kbtm          model index of the cloud base
!      i, j, k, kc   do loop indices
!      kx            number of model layers
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    define number of model layers.
!--------------------------------------------------------------------
      kx = size(Cld_spec%camtsw,3)

!---------------------------------------------------------------------
!    call diag_cloud_driver2 to obtain the cloud specification variables
!    in cloud space.
!---------------------------------------------------------------------
      call diag_cloud_driver2 (is, js, press, pflux, lat, Rad_time,  &
                               Cld_spec%ncldsw, ktop, kbtm, cldamt, &
                               liq_frac, tau, ice_cloud_cs)

!---------------------------------------------------------------------
!    map the various cloud specification arrays from cloud-space to 
!    physical space so that they may be exported for use elsewhere.
!-------------------------------------------------------------------
      do j=1,size(Cld_spec%camtsw,2)
        do i=1,size(Cld_spec%camtsw,1)
          do kc=1,Cld_spec%ncldsw(i,j)  
            do k=ktop(i,j,kc), kbtm(i,j,kc)
              Cld_spec%camtsw(i,j,k) = cldamt(i,j,kc) 
              Cld_spec%liq_frac(i,j,k) = liq_frac(i,j,kc)
              Cld_spec%tau(i,j,k,:) = tau(i,j,kc,:)
              Cld_spec%cld_thickness(i,j,k) =    &
                                      kbtm(i,j,kc) - ktop(i,j,kc) + 1
              Cld_spec%ice_cloud(i,j,k) = ice_cloud_cs(i,j,kc)
      
!---------------------------------------------------------------------
!    determine if max overlap or random overlap assumption is made. if
!    cloud is more than one layer deep and using lhsw, then max overlap
!    assumed; otherwise random overlap is assumed.
!----------------------------------------------------------------------
              if (ktop(i,j,kc) == kbtm(i,j,kc)) then
                Cld_spec%crndlw(i,j,k) = cldamt(i,j,kc)
                Cld_spec%cmxolw(i,j,k) = 0.0             
              else
                if (Sw_control%do_esfsw) then
                  Cld_spec%crndlw(i,j,k) = cldamt(i,j,kc)  
                  Cld_spec%cmxolw(i,j,k) = 0.0             
                else
                  Cld_spec%cmxolw(i,j,k) = cldamt(i,j,kc)
                  Cld_spec%crndlw(i,j,k) = 0.0
                endif       
              endif
            end do
            if (ktop(i,j,kc) == kbtm(i,j,kc)) then
              Cld_spec%nrndlw(i,j) = Cld_spec%nrndlw(i,j) + 1
            else
              if (Sw_control%do_esfsw) then
                Cld_spec%nrndlw(i,j) = Cld_spec%nrndlw(i,j) + 1
              else
                Cld_spec%nmxolw(i,j) = Cld_spec%nmxolw(i,j) + 1
              endif     
            endif
          end do
        end do
      end do
 

!--------------------------------------------------------------------

end subroutine diag_clouds_amt 





!#####################################################################

! <SUBROUTINE NAME="obtain_bulk_lw_diag">
!  <OVERVIEW>
!    obtain_bulk_lw_diag defines bulk longwave cloud radiative
!    properties for the gordon diag cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_lw_diag defines bulk longwave cloud radiative
!    properties for the gordon diag cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_lw_diag (is, ie, js, je, Cld_spec, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for
!                               maximally overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_lw_diag (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_lw_diag defines bulk longwave cloud radiative 
!    properties for the gordon diag cloud scheme.
!---------------------------------------------------------------------
 
integer,                     intent(in)     :: is, ie, js, je
type(cld_specification_type), intent(in   ) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:

      real, dimension (size(Cldrad_props%emrndlw,1),               &
                       size(Cldrad_props%emrndlw,2),                &
                       size(Cldrad_props%emrndlw,3)) ::  emcld

      integer    :: max_cld
      integer    :: i,j,k

!---------------------------------------------------------------------
!   local variables:
!
!            emcld    longwave cloud emissivity, assuming a single 
!                     band, returned from diag_cloud_rad_mod
!            max_cld  maximum number of clouds in any column in the 
!                     window
!            i,j,k    do-loop indices
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    determine if any clouds are present in the window.
!---------------------------------------------------------------------
      max_cld = maxval(Cld_spec%ncldsw)

!---------------------------------------------------------------------
!    if cloud is nowhere present, return. 
!---------------------------------------------------------------------
      if (max_cld > 0) then

!--------------------------------------------------------------------
!    initialize property array in cloud-space to zero.
!--------------------------------------------------------------------
        emcld = 0.

!---------------------------------------------------------------------
!    call cloud_opt_prop_tg_lw to obtain the cloud longwave enmissivity.
!---------------------------------------------------------------------
        call cloud_opt_prop_tg_lw (Cld_spec%tau, Cld_spec%liq_frac,  &
                                   emcld)

!---------------------------------------------------------------------
!    assign the emissivity value returned to both the random and max-
!    imum overlap case. the value will only be used when there is a
!    non-zero cloud fraction of a particular type.
!-------------------------------------------------------------------
        do k=1,size(Cldrad_props%emrndlw,3)
          do j=1,size(Cldrad_props%emrndlw,2)
            do i=1,size(Cldrad_props%emrndlw,1)
              Cldrad_props%emrndlw(i,j,k,:,1) = emcld(i,j,k) 
              Cldrad_props%emmxolw(i,j,k,:,1) = emcld(i,j,k) 
            end do
          end do
        end do
      endif  
 
!---------------------------------------------------------------------


end subroutine obtain_bulk_lw_diag




!#####################################################################

! <SUBROUTINE NAME="obtain_bulk_sw_diag">
!  <OVERVIEW>
!    obtain_bulk_sw_diag defines bulk shortwave cloud radiative
!    properties for the gordon diag cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_sw_diag defines bulk shortwave cloud radiative
!    properties for the gordon diag cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_sw_diag (is, ie, js, je, cosz, Cld_spec,  &   
!                Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="cosz" TYPE="real">
!      cosz         cosine of the zenith angle  [ dimensionless ]
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the
!                               visible frequency band
!                               [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_sw_diag (is, ie, js, je, cosz, Cld_spec,  &   
                                Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_sw_diag defines bulk shortwave cloud radiative 
!    properties for the gordon diag cloud scheme.
!---------------------------------------------------------------------

integer,                      intent(in)    ::  is, ie, js, je
real, dimension(:,:),         intent(in)    ::  cosz
type(cld_specification_type), intent(in   ) ::  Cld_spec
type(cldrad_properties_type), intent(inout) ::  Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      cosz         cosine of the zenith angle  [ dimensionless ]
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:


      real, dimension (size(Cldrad_props%cirabsw,1),                 &
                       size(Cldrad_props%cirabsw,2),                 &
                       size(Cldrad_props%cirabsw,3)) ::  cuvab

      real, dimension (size(Cldrad_props%cirabsw,1),                 &
                       size(Cldrad_props%cirabsw,2)) :: qmix_kx

      logical, dimension (size(Cldrad_props%cirabsw,1),    &
                          size(Cldrad_props%cirabsw,2), &
                          size(Cldrad_props%cirabsw,3)) ::  direct

      real        ::    taucum
      integer     ::    max_cld, ierr, kcld
      integer     ::    i, j, k, kk

!-------------------------------------------------------------------
!   local variables:
!
!        cuvab      absorptivity of clouds in the visible frequency
!                   bands [ nondimensional ]
!        qmix_kx    mixing ratio at the lowest model level
!                   [ nondimensional ]
!        direct     logical variable indicating whether solar beam is
!                   treated as direct or diffuse
!        taucum     sum of cloud extinction coefficients from model
!                   top to the current level; if taucum is > taucrit
!                   then the solar beam is considered to be diffuse 
!                   at lower model levels [ dimensionless ]
!        max_cld    maximum number of clouds in any physics window 
!                   column
!        ierr       error flag
!        kcld       next model layer to check for the presence of cloud
!                   in the calculation of taucum. this will not be the
!                   next lower level when multi-layer clouds are present
!        i,j,k,kk   do-loop indices
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    define the nature of the solar beam at the top of atmosphere.
!---------------------------------------------------------------------
      direct(:,:,:) = .true.

!----------------------------------------------------------------------
!    in each column, integrate downward, defining the nature of the 
!    solar beam at each model level, and summing the cloud optical 
!    depths. once the optical depth exceeds taucrit, the solar beam is 
!    assigned diffuse properties rather than the properties of a direct 
!    solar beam. the logical variable direct is defined to indicate how
!    the beam is to be treated at each level.
!---------------------------------------------------------------------
      do j=1,size(Cld_spec%tau,2)
        do i=1,size(Cld_spec%tau,1)
          kcld = 1
          taucum = 0.
          do k=1,size(Cld_spec%tau,3)
            if (k >= kcld) then

!---------------------------------------------------------------------
!    once taucrit is exceeded, mark all lower levels as being diffuse,
!    and begin the next column.
!----------------------------------------------------------------------
              if (taucum > taucrit) then
                do kk=k,size(Cld_spec%tau,3)
                  direct(i,j,kk) = .false.
                end do
                exit
              endif

!---------------------------------------------------------------------
!    when multi-layer clouds are encountered, the optical depth for the
!    cloud must be added to taucum only once. kcld is defined as the 
!    first level below the current cloud at which to again start check-
!    ing taucum vs taucrit.
!---------------------------------------------------------------------
              if (Cld_spec%cld_thickness(i,j,k) > 0) then
                taucum = taucum + Cld_spec%tau(i,j,k,1)
                kcld = kcld + Cld_spec%cld_thickness(i,j,k)
              else
                kcld = kcld + 1
              endif
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------
!    determine if any clouds are present in the window.
!---------------------------------------------------------------------
      max_cld = maxval(Cld_spec%ncldsw)

!--------------------------------------------------------------------
!    define the absorptivity in the visible spectrum to be 0.0.
!--------------------------------------------------------------------
      cuvab = 0.

!---------------------------------------------------------------------
!    if cloud is present, define cloud radiative properties. otherwise 
!    the default values corresponding to no clouds will be used.
!---------------------------------------------------------------------
      if (max_cld > 0) then

!--------------------------------------------------------------------
!    obtain the properly averaged (or instantaneous) mixing ratio at
!    the lowest model level. it will be passed to cloud_opt_prop_tg_sw
!    and used to calculate anomalous absorption.
!---------------------------------------------------------------------
        call diag_cloud_avg2 (is, js, qmix_kx, ierr)

!---------------------------------------------------------------------
!    call cloud_opt_prop_tg_sw to obtain short-wave cloud radiative 
!    properties. 
!---------------------------------------------------------------------
        call cloud_opt_prop_tg_sw (Cld_spec%liq_frac, Cld_spec%tau, &
                                   direct,  qmix_kx, cosz,   &
                                   Cldrad_props%cvisrfsw, &
                                   Cldrad_props%cirrfsw, &
                                   cuvab, Cldrad_props%cirabsw)
      endif  ! (max_cld > 0)

!--------------------------------------------------------------------




end subroutine obtain_bulk_sw_diag



!####################################################################


       end module diag_clouds_W_mod





!FDOC_TAG_GFDL

                 module donner_deep_clouds_W_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!   fil
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!          donner deep cloud radiative properties module
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use time_manager_mod,       only: time_type
use mpp_mod,                only: input_nml_file
use fms_mod,                only: open_namelist_file, file_exist,   &
                                  check_nml_error, error_mesg,   &
                                  close_file, FATAL,  &
                                  mpp_pe, mpp_root_pe, &
                                  write_version_number, stdlog
use rad_utilities_mod,      only: microphysics_type

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!          donner deep cloud radiative properties module
!
!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

   character(len=128)  :: version =  '$Id: donner_deep_clouds_W.F90,v 18.0.4.2 2010/09/07 16:17:19 wfc Exp $'
   character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          donner_deep_clouds_W_init,   &
          donner_deep_clouds_W_end , donner_deep_clouds_amt

!---------------------------------------------------------------------
!-------- namelist  ---------

logical   :: using_dge_lw = .true.
logical   :: using_dge_sw = .true.



namelist /donner_deep_clouds_W_nml /     &
       using_dge_sw, using_dge_lw


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------


  logical :: module_is_initialized = .false.
!----------------------------------------------------------------------
!----------------------------------------------------------------------




contains 





! <SUBROUTINE NAME="donner_deep_clouds_W_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call donner_deep_clouds_W_init  (pref, lonb, latb, axes, Time)
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
! 
!  </IN>
!  <IN NAME="lonb" TYPE="real">
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
! 
!  </IN>
!  <IN NAME="axes" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine donner_deep_clouds_W_init  (pref, lonb, latb, axes, Time)

real, dimension(:,:), intent(in) :: pref
real, dimension(:,:), intent(in) :: lonb, latb
integer, dimension(4), intent(in)      :: axes
type(time_type),       intent(in)      :: Time

      integer            :: unit, ierr, io, logunit

     if (module_is_initialized) return
!---------------------------------------------------------------------
!-----  read namelist  ------
  
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=donner_deep_clouds_W_nml, iostat=io)
      ierr = check_nml_error(io,"donner_deep_clouds_W_nml")
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=donner_deep_clouds_W_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'donner_deep_clouds_W_nml')
        enddo
10      call close_file (unit)
      endif
#endif

      if ( mpp_pe() == mpp_root_pe() ) then
         call write_version_number(version, tagname)
         logunit = stdlog()
         write (logunit,nml=donner_deep_clouds_W_nml)
      endif

!---------------------------------------------------------------------

       module_is_initialized = .true.


end subroutine donner_deep_clouds_W_init

! <SUBROUTINE NAME="donner_deep_clouds_W_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call donner_deep_clouds_W_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine donner_deep_clouds_W_end
       
!----------------------------------------------------------------------
!    diag_clouds_W_end is the destructor for diag_clouds_W_mod.
!----------------------------------------------------------------------
       
!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.
       
!--------------------------------------------------------------------


end subroutine donner_deep_clouds_W_end


!#################################################################


!---------------------------------------------------------------------

! <SUBROUTINE NAME="donner_deep_clouds_amt">
!  <OVERVIEW>
!    donner_deep_clouds_amt defines the distribution of cloud water and
!    cloud ice concentration and particle size and total cloud fraction
!    in both the mesoscale and convective cell-scale components of the
!    clouds associated with donner_deep convection. these values will
!    be combined with the large-scale cloud fields to produce the dist-
!    ribution of cloud radiative properties that will be seen by the
!    radiation package.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    donner_deep_clouds_amt defines the distribution of cloud water and
!    cloud ice concentration and particle size and total cloud fraction
!    in both the mesoscale and convective cell-scale components of the
!    clouds associated with donner_deep convection. these values will
!    be combined with the large-scale cloud fields to produce the dist-
!    ribution of cloud radiative properties that will be seen by the
!    radiation package.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call donner_deep_clouds_amt (is, ie, js, je, Cell_microphys,  &
!                Meso_microphys)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine donner_deep_clouds_amt (is, ie, js, je,   &
                   cell_cloud_frac, cell_liquid_amt, cell_liquid_size, &
                   cell_ice_amt, cell_ice_size, &
                   cell_droplet_number, &
                   meso_cloud_frac, meso_liquid_amt, meso_liquid_size, &
                   meso_ice_amt, meso_ice_size, &
                   meso_droplet_number,  nsum_out, &
                   Cell_microphys,  Meso_microphys)

!---------------------------------------------------------------------
!    donner_deep_clouds_amt defines the distribution of cloud water and
!    cloud ice concentration and particle size and total cloud fraction
!    in both the mesoscale and convective cell-scale components of the
!    clouds associated with donner_deep convection. these values will
!    be combined with the large-scale cloud fields to produce the dist-
!    ribution of cloud radiative properties that will be seen by the
!    radiation package.
!----------------------------------------------------------------------

integer,                 intent(in)    :: is,ie,js,je
real, dimension(:,:,:), intent(inout) ::   &
                   cell_cloud_frac, cell_liquid_amt, cell_liquid_size, &
                   cell_ice_amt, cell_ice_size, &
                   cell_droplet_number, &
                   meso_cloud_frac, meso_liquid_amt, meso_liquid_size, &
                   meso_ice_amt, meso_ice_size, &
                   meso_droplet_number
integer, dimension(:,:), intent(inout) ::  nsum_out
type(microphysics_type), intent(inout) :: Cell_microphys, Meso_microphys

!---------------------------------------------------------------------
!     call donner_deep_avg to obtain the specification fields for both
!     the mesoscale and convective cellscale clouds assocated with 
!     donner_deep convection.
!---------------------------------------------------------------------
      call donner_deep_avg (                           &
                      is, ie, js, je,           &
                      cell_cloud_frac,  Cell_microphys%cldamt, &
                      cell_liquid_amt, Cell_microphys%conc_drop, &
                      cell_liquid_size, Cell_microphys%size_drop,&
                      cell_ice_amt, Cell_microphys%conc_ice, &
                      cell_ice_size, Cell_microphys%size_ice, &
                 cell_droplet_number, Cell_microphys%droplet_number, &
                      meso_cloud_frac, Meso_microphys%cldamt,   &
                      meso_liquid_amt, Meso_microphys%conc_drop, &
                      meso_liquid_size, Meso_microphys%size_drop,&
                      meso_ice_amt, Meso_microphys%conc_ice, &
                      meso_ice_size, Meso_microphys%size_ice,   &
                 meso_droplet_number, Meso_microphys%droplet_number, &
                      nsum_out)

!---------------------------------------------------------------------



end subroutine donner_deep_clouds_amt  



!####################################################################

subroutine donner_deep_avg    &
               (is, ie, js, je,           &
                cell_cloud_frac,  cell_cloud_frac_out,   &
                cell_liquid_amt, cell_liquid_amt_out,      &
                cell_liquid_size, cell_liquid_size_out    ,&
                cell_ice_amt, cell_ice_amt_out, &
                cell_ice_size, cell_ice_size_out, &
                cell_droplet_number, cell_droplet_number_out, &
                meso_cloud_frac, meso_cloud_frac_out, &
                meso_liquid_amt, meso_liquid_amt_out, &
                meso_liquid_size, meso_liquid_size_out,&
                meso_ice_amt, meso_ice_amt_out, &
                meso_ice_size, meso_ice_size_out,   &
                meso_droplet_number, meso_droplet_number_out, &
                nsum)

!------------------------------------------------------------------
!    subroutine donner_deep_avg outputs the cloud microphysical quant-
!    ities associated with donner_deep convection for use by the rad-
!    iation package. these fields are the cloud liquid and ice amounts,
!    liquid and ice sizes, and fractional coverage, for both the con-
!    vective cell and mesoscale components of the convective system.
!--------------------------------------------------------------------

integer,                   intent(in)  :: is, ie, js, je
real,    dimension(:,:,:), intent(inout) :: cell_cloud_frac,        &
                                          cell_liquid_amt,   &
                                          cell_liquid_size,  &
                                          cell_ice_amt, &
                                          cell_ice_size,   &
                                       cell_droplet_number, &
                                          meso_cloud_frac,   &
                                          meso_liquid_amt, &
                                          meso_liquid_size, &
                                          meso_ice_amt,  &
                                          meso_ice_size, &
                                        meso_droplet_number
integer, dimension(:,:), intent(inout) :: nsum                        
real,    dimension(:,:,:), intent(out) :: cell_cloud_frac_out,        &
                                          cell_liquid_amt_out,   &
                                          cell_liquid_size_out,  &
                                          cell_ice_amt_out, &
                                          cell_ice_size_out,   &
                                        cell_droplet_number_out, &
                                          meso_cloud_frac_out,   &
                                          meso_liquid_amt_out, &
                                          meso_liquid_size_out, &
                                          meso_ice_amt_out,  &
                                          meso_ice_size_out, &
                                       meso_droplet_number_out

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     is, ie         first and last values of i index values of points 
!                    in this physics window (processor coordinates)
!     js, je         first and last values of j index values of points 
!                    in this physics window (processor coordinates)
!
!  intent(out) variables:
!
!     cell_cloud_frac_out  fractional coverage of convective cells in 
!                          grid box [ dimensionless ]
!     cell_liquid_amt_out  liquid water content of convective cells 
!                          [ kg(h2o) / kg(air) ]
!     cell_liquid_size_out assumed effective size of cell liquid drops
!                          [ microns ]
!     cell_ice_amt_out     ice water content of cells 
!                          [ kg(h2o) / kg(air) ]
!     cell_ice_size_out    generalized effective diameter for ice in
!                          convective cells [ microns ]
!     meso_cloud_frac_out  fractional area of mesoscale clouds in grid 
!                          box [ dimensionless ]
!     meso_liquid_amt_out  liquid water content in mesoscale clouds
!                          [ kg(h2o) / kg(air) ]
!     meso_liquid_size_out assumed effective size of mesoscale drops
!                          [ microns ]
!     meso_ice_amt_out     ice water content of mesoscale elements 
!                          [ kg(h2o) / kg(air) ]
!     meso_ice_size_out    generalized ice effective size for anvil ice
!                          [ microns ]
!
!---------------------------------------------------------------------

   
!------------------------------------------------------------------
!   local variables

      real, dimension(size(cell_cloud_frac_out,1), &
                      size(cell_cloud_frac_out,2))   :: inv_nsum
      integer                                        :: num
      integer                                        ::   k
   
!---------------------------------------------------------------------
!   local variables:
!
!       inv_sum     inverse of number of elements in the time averaged
!                   output fields
!       num         number of grid columns which have not been given
!                   values for the output variables by donner_deep_mod
!       i,j,k       do-loop indices
!
!--------------------------------------------------------------------- 

!---------------------------------------------------------------------
!    check to make sure dimensions of arguments match the module
!    variable dimensions.
!---------------------------------------------------------------------
      if (size(cell_cloud_frac_out,3) /= size(cell_cloud_frac,3)) &
        call error_mesg (  'donner_rad_mod',  &
                         'input argument has the wrong size',FATAL)

!---------------------------------------------------------------------
!    check to see that all columns have been given values for the module
!    variables that are going to be averaged. 
!----------------------------------------------------------------------
      num = count(        nsum(:,:) == 0)

!----------------------------------------------------------------------
!    if all points have values of 0, then the scheme has not yet been
!    called. use the initialized values that are present.
!----------------------------------------------------------------------
      if (num == (ie-is+1)*(je-js+1) ) then
        cell_cloud_frac_out             = cell_cloud_frac
        cell_liquid_amt_out             = cell_liquid_amt
        cell_liquid_size_out            = cell_liquid_size
        cell_ice_amt_out                = cell_ice_amt
        cell_ice_size_out               = cell_ice_size
        cell_droplet_number_out         = cell_droplet_number
        meso_cloud_frac_out             = meso_cloud_frac
        meso_liquid_amt_out             = meso_liquid_amt
        meso_liquid_size_out            = meso_liquid_size
        meso_ice_amt_out                = meso_ice_amt
        meso_ice_size_out               = meso_ice_size
        meso_droplet_number_out         = meso_droplet_number
        
!----------------------------------------------------------------------
!    if any columns have not been given values, stop execution with an 
!    error message. 
!----------------------------------------------------------------------
      else if (num > 0) then
        call error_mesg ( 'donner_rad_mod', &
                         'nsum has some zero entries', FATAL)

!----------------------------------------------------------------------
!    if all columns have valid data, produce time averaged values of
!    the desired output fields.
!----------------------------------------------------------------------
      else
        inv_nsum(:,:) = 1.0/float(nsum(  :  , :   ))
        do k=1,size(cell_cloud_frac_out,3)
          cell_cloud_frac_out(:,:,k) =   &
                              cell_cloud_frac(:,:,        k)*inv_nsum
          cell_liquid_amt_out(:,:,k) =   &
                              cell_liquid_amt(:,:,        k)*inv_nsum
          cell_liquid_size_out(:,:,k) =  &
                              cell_liquid_size(:,:,k        )*inv_nsum
          cell_ice_amt_out(:,:,k) =      &
                              cell_ice_amt(:,:,k        )*inv_nsum
          cell_ice_size_out(:,:,k) =     &
                              cell_ice_size(:,:,k        )*inv_nsum
          cell_droplet_number_out(:,:,k) =     &
                              cell_droplet_number(:,:,k      )*inv_nsum
          meso_cloud_frac_out(:,:,k) =   &
                              meso_cloud_frac(:,:,        k)*inv_nsum
          meso_liquid_amt_out(:,:,k) =   &
                              meso_liquid_amt(:,:,        k)*inv_nsum
          meso_liquid_size_out(:,:,k) =  &
                              meso_liquid_size(:,:,        k)*inv_nsum
          meso_ice_amt_out(:,:,k) =      &
                              meso_ice_amt(:,:,        k)*inv_nsum
          meso_ice_size_out(:,:,k) =     & 
                              meso_ice_size(:,:,        k)*inv_nsum
          meso_droplet_number_out(:,:,k) =     & 
                              meso_droplet_number(:,:,     k)*inv_nsum
        end do
     
!---------------------------------------------------------------------
!     prevent the occurrence of cloud area with no condensate and cond-
!     ensate with no area, for both the convective cell clouds and the
!     mesoscale cloud.
!---------------------------------------------------------------------
        where (cell_cloud_frac_out  > 0.0 .and.  &
               cell_liquid_amt_out == 0.0 .and.  &
               cell_ice_amt_out    == 0.0)
          cell_cloud_frac_out  = 0.0
        end where
        where (cell_cloud_frac_out == 0.0 .and.   &
               cell_liquid_amt_out  > 0.0)
          cell_liquid_amt_out  = 0.0
        end where
        where (cell_cloud_frac_out == 0.0 .and.   &
               cell_ice_amt_out     > 0.0)
          cell_ice_amt_out     = 0.0
        end where

        where (meso_cloud_frac_out  > 0.0 .and.  &
               meso_liquid_amt_out == 0.0 .and.  &
               meso_ice_amt_out    == 0.0)
          meso_cloud_frac_out  = 0.0
        end where
        where (meso_cloud_frac_out == 0.0 .and.   &
               meso_liquid_amt_out  > 0.0)
          meso_liquid_amt_out  = 0.0
        end where
        where (meso_liquid_amt_out == 0.0)
          meso_liquid_size_out = 0.0
        end where
        where (meso_cloud_frac_out == 0.0 .and.   &
               meso_ice_amt_out     > 0.0)
          meso_ice_amt_out     = 0.0
        end where
      endif
 
!----------------------------------------------------------------------
!    reset the variables just processed so that new sums may be begun 
!    when donner_deep is called again.
!----------------------------------------------------------------------
      cell_cloud_frac                 = 0.0
      cell_liquid_amt                 = 0.0
      cell_liquid_size                = 0.0
      cell_ice_amt                    = 0.0
      cell_ice_size                   = 0.0
      cell_droplet_number             = 0.0
      meso_cloud_frac                 = 0.0
      meso_liquid_amt                 = 0.0
      meso_liquid_size                = 0.0
      meso_ice_amt                    = 0.0
      meso_ice_size                   = 0.0
      meso_droplet_number             = 0.0
      nsum                            = 0
       
!----------------------------------------------------------------------



end subroutine donner_deep_avg


!#####################################################################

       end module donner_deep_clouds_W_mod





                     module esfsw_driver_mod
!
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!  smf
! </REVIEWER>
!
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
!
! <OVERVIEW>
!  Code that initializes and calculates shortwave radiative quantities
!  such as flux and heating rate.
! </OVERVIEW>
! <DESCRIPTION>
!  This code initializes the necessary shortwave radiative parameters
!  in the initialization subroutine. It then uses delta-eddington approximation
!  and doubling and adding technique to calculate solar flux and
!  heating rate.
! </DESCRIPTION>
!

!    shared modules:

use mpp_mod,              only:  input_nml_file
use fms_mod,              only:  open_namelist_file, fms_init, &
                                 mpp_pe, mpp_root_pe, stdlog, &
                                 file_exist, write_version_number, &
                                 check_nml_error, error_mesg, &
                                 FATAL, close_file
use constants_mod,        only:  PI, GRAV, radcon_mks, o2mixrat, &
                                 rhoair, pstd_mks, WTMAIR, &
                                 constants_init

!  shared radiation package modules:

use esfsw_parameters_mod, only:  Solar_spect, esfsw_parameters_init, &
                                 esfsw_parameters_end
use rad_utilities_mod,    only:  Rad_control, rad_utilities_init, &
                                 cldrad_properties_type, &
                                 cld_specification_type, &
                                 astronomy_type, &
                                 aerosol_diagnostics_type, &
                                 radiative_gases_type, &
                                 aerosol_type, aerosol_properties_type,&
                                 Cldrad_control, &
                                 atmos_input_type, surface_type, &
                                 sw_output_type, Sw_control
use tracer_manager_mod,   only : get_tracer_index,   &
                                 NO_TRACER
use field_manager_mod,    only : MODEL_ATMOS
!---------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    esfsw_driver_mod is the internal driver for the esf shortwave
!    package.
!------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: esfsw_driver.F90,v 18.0.2.1.2.1.2.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public    &
         esfsw_driver_init, swresf,   &
         esfsw_driver_end

private     &

!   called from swresf:
         adding, deledd


!---------------------------------------------------------------------
!-------- namelist  ---------

 logical     ::  do_ica_calcs=.false.           ! do independent column
                                                ! calculations when sto-
                                                ! chastic clouds are
                                                ! active ?
logical      ::  do_rayleigh_all_bands = .true. ! rayleigh scattering 
                                                ! calculated in all sw 
                                                ! bands ?
logical      ::  do_herzberg = .false.          ! include the herzberg 
                                                ! effect on the o2 
                                                ! optical depth ?
logical      ::  do_quench = .false.            ! include the quenching
                                                ! effect of non-LTE 
                                                ! processes on the co2 
                                                ! optical depth ?
logical      ::  do_ch4_sw_effects = .false.    ! the shortwave effects
                                                ! of ch4 are included ?
logical      ::  do_n2o_sw_effects = .false.    ! the shortwave effects
                                                ! of n2o are included ?
logical      ::  do_coupled_stratozone = .false. ! include the coupled
                                                 ! stratospheric ozone effects?
  

namelist / esfsw_driver_nml /    &
                               do_ica_calcs, do_rayleigh_all_bands, &
                               do_herzberg, do_quench, &
                               do_ch4_sw_effects, do_n2o_sw_effects, &
                               do_coupled_stratozone

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------


!---------------------------------------------------------------------
!    variables associated with absorptivity and sw transmission for
!    various gaseous atmospheric components
!
! powph2o      = the scaling factor used in the fit of the h2o          
!                transmission function                                  
!                                                                       
! p0h2o        = the reference pressure (mb) used in the fit of the     
!                h2o transmission function                              
!                                                                       
! c(n)co2(str) = coefficients for the absorptivity expression for co2   
!                for the pressure-scaled and non-scaled, respectively,  
!                portions of the fit (=1.0e-99 if no absorption)        
!                                                                       
! c(n)o2(str)  = coefficients for the absorptivity expression for o2    
!                for the pressure-scaled and non-scaled, respectively,  
!                portions of the fit (=1.0e-99 if no absorption)        
!                                                                       
! ""(schrun)   = coefficients for the absorptivity expression for the   
!                Schuman-Runge o2 band (non-scaled only)                
!                                                                       
! kh2o         =  the psuedo-absorption coefficients in cm2/gm for h2o  
!                                                                       
! ko3          = the absorption coefficients in cm2/gm for o3           
!                                                                       
! wtfreq       = the weight associated with each exponential term       
! strterm      = logical flag to indicate whether or not a h2o pseudo-  
!                absorption coefficient is assigned a non-scaled        
!                (true) or pressure-scaled (false) gas amount           
!---------------------------------------------------------------------
real, dimension (:), allocatable    :: c1co2, c1co2str, c1o2, c1o2str, &
                                       c2co2, c2co2str, c2o2, c2o2str, &
                                       c3co2, c3co2str, c3o2, c3o2str, &
                                       c4co2, c4co2str, c4o2, c4o2str, &
                                       c1ch4, c1ch4str, c2ch4,         &
                                       c2ch4str, c3ch4, c3ch4str,      &
                                       c4ch4, c4ch4str,                &
                                       c1n2o, c1n2ostr, c2n2o,         &
                                       c2n2ostr, c3n2o, c3n2ostr,      &
                                       c4n2o, c4n2ostr,                &
                                       powph2o, p0h2o
real                                :: c1o2strschrun, c2o2strschrun, &
                                       c3o2strschrun, c4o2strschrun
real, dimension (:), allocatable    :: kh2o, ko3, wtfreq
logical, dimension(:), allocatable  :: strterm

!---------------------------------------------------------------------
!    quantities associated with solar spectral parameterization
!                                                                       
! firstrayband = the first band number where the contribution by        
!                rayleigh scattering is included in the solar           
!                calculations                                           
!                                                                       
! nirbands     = the number of bands in the near-infrared (used in      
!                assigning the value of the surface albedo for the      
!                near-infrared, and the visible and ultraviolet         
!                regions, separately)                                   
! nfreqpts     = the number of pseudo-monochromatic frequencies         
! solflxband   = the solar flux in each parameterization band           
! solflxbandref = the solar flux in each parameterization band, used for
!                 defining band-averaged optical parameters. If the
!                 solar constant is time-invariant, it is also the solar
!                 flux in each parameterization band (solflxband).
! vis_wvnum    = the wavenumber of visible light (corresponds to
!                wavelength of 0.55 microns) [ cm **(-1) ]
!---------------------------------------------------------------------
real                                :: refquanray, solflxtotal
integer                             :: firstrayband, nirbands
integer, dimension (:), allocatable :: nfreqpts
real,    dimension(:), allocatable  :: solflxband
real,    dimension(:), allocatable  :: solflxbandref
real, dimension(:), allocatable     :: wtstr, cosangstr
real, dimension(4)                  :: wtstr_4 =      &
                                       (/0.347854845, 0.652145155,&
                                         0.347854845, 0.652145155/)

integer :: nbands, tot_wvnums, nfrqpts, nh2obands, nstreams
logical :: nstr4 = .false.
real    :: vis_wvnum = 1.0E+04/0.55
real    :: wvnum_870 = 1.0E+04/0.87
real    :: wvnum_340 = 1.0E+04/0.34
real    :: wvnum_380 = 1.0E+04/0.38
real    :: wvnum_440 = 1.0E+04/0.44
real    :: wvnum_670 = 1.0E+04/0.67
real    :: one_micron_wvnum = 1.0E+04/1.00
real    :: onepsix_micron_wvnum = 1.0E+04/1.61
integer :: onepsix_band_indx

!---------------------------------------------------------------------
!    variables associated with rayleigh scattering
!---------------------------------------------------------------------
real, dimension (:), allocatable    :: betaddensitymol

!----------------------------------------------------------------------
!    variables associated with total optical path of species ? - smf
!----------------------------------------------------------------------
real                            :: toto2strmaxschrun
real, dimension(:), allocatable :: totco2max, totco2strmax, &
                                   toto2max, toto2strmax, &
                                   totch4max, totch4strmax, &
                                   totn2omax, totn2ostrmax

!----------------------------------------------------------------------
!    variables associated with the herzberg effect. wtmo2 is the mol-
!    ecular weight of o2. herzberg_fac is a factor used in the last 
!    shortwave band, so that herzberg_fac*wo2 yields a correction for 
!    the o2 optical depth to account for the herzberg o2 heating. this 
!    is done only when do_herzberg is true.
!----------------------------------------------------------------------
real, parameter   :: wtmo2        = 3.19988E+01  
real, parameter   :: herzberg_fac = 9.9488377E-3

!----------------------------------------------------------------------
!    variables associated with the quenching effect. co2_quenchfac is a
!    multiplication factor that reduces the co2 gas optical depth, and 
!    hence, the solar heating in the upper atmosphere, to account for 
!    "quenching" due to non-LTE processes. co2_quenchfac_height is the 
!    reference height for co2_quenchfac [ meters ].
!----------------------------------------------------------------------
real, dimension(30) :: co2_quenchfac
data co2_quenchfac /1.0,.954,.909,.853,.800,.747,.693,.637,.583, .526,&
                    .467,.416,.368,.325,.285,.253,.229,.206,.186,.170,&
                    .163,.156,.151,.144,.138,.132,.127,.124,.068,.037/

real, dimension(30) :: co2_quenchfac_height
data co2_quenchfac_height /67304.,68310.,69303.,70288.,71267.,72245.,&
                           73221.,74195.,75169.,76141.,77112.,78082.,&
                           79051.,80018.,80985.,81950.,82914.,83876.,&
                           84838.,85798.,86757.,87715.,88672.,89627.,&
                           90582.,91535.,92487.,93438.,94387.,106747./



!---------------------------------------------------------------------
!    miscellaneous variables
!---------------------------------------------------------------------
integer, parameter :: NSOLWG = 1
real, dimension(NSOLWG) :: gausswt
logical        :: module_is_initialized = .false.
logical        :: do_esfsw_band_diagnostics = .false.
integer        :: naerosol_optical, naerosoltypes_used


!---------------------------------------------------------------------
!---------------------------------------------------------------------
 


                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!    
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
! <SUBROUTINE NAME="esfsw_driver_init">
!  <OVERVIEW>
!   Subroutine that defines the time-independent quantities associated
!   with the incoming shortwave radiation in the multiple-band solar
!   radiation parameterization.
!  </OVERVIEW>
!  <DESCRIPTION>
!   It first reads in the input namelist and then allocates gas absorption
!   coefficient variables. It then reads in the shortwave input namelist
!   file and assigns the gas absorption coefficients. Rayleigh scattering
!   coefficient is also calculated based on the temperature and pressure
!   structure of the atmosphere.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call esfsw_driver_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine esfsw_driver_init
 
!---------------------------------------------------------------------- 
!    esfsw_driver_init is the constructor for esfsw_driver_mod. it
!    defines the time-independent quantities associated with the 
!    incoming shortwave radiation in the multiple-band solar radiation 
!    parameterization.                                    
!---------------------------------------------------------------------- 

!---------------------------------------------------------------------
!  local variables:

      real,    dimension(Solar_spect%nbands)    :: freqnu
      real,    dimension(Solar_spect%nstreams)  :: ptstr 
      integer, dimension(0:Solar_spect%nbands) :: endwvnbands

      integer, dimension(:), allocatable  :: nwvnsolar
      real   , dimension(:), allocatable  :: solint   

      character(len=64)    :: file_name
      real, dimension(4)   :: ptstr_4 = (/-0.861136312,&
                                          -0.339981044, &
                                           0.861136312,  &
                                           0.339981044 /)
      real      :: ptstr_1 = 0.2
      real      :: temprefray  = 288.15
      real      :: pressrefray = 101325.       ! MKS units
      real      :: densmolref  = 2.54743E+19
      real      :: convfac     = 1.0E+18
      real      :: corrfac, gamma, f1, f2, f3, pinteg, &
                   twopiesq, densmolrefsqt3, wavelength,  &
                   freqsq, ristdm1, ri
      integer   :: iounit, nband, nf, ni, nw, nw1, nw2, nintsolar
      integer   :: unit, io, ierr, logunit
      integer   :: i
      integer   :: n
      real      :: input_flag = 1.0e-99

!---------------------------------------------------------------------
!  local variables:
!                                                                       
!      freqnu   
!      ptstr          gaussian points and weights for evaluation of the
!                     diffuse beam.
!      nwvnsolar      the number of wavenumbers in each region where the
!                     solar flux is constant                         
!      solint         the solar flux in watts per meter**2 in each      
!                     wavenumber region where it is constant    
!      endwvnbands    the wavenumber value for the band limits   
!      file_name
!      ptstr_4    
!      ptstr_1     
!      temprefray     reference temperature used in defining rayleigh
!                     optical depth
!      pressrefray    reference pressure used in defining rayleigh
!                     optical depth [ Pa ]
!      densmolref     reference density used in defining rayleigh
!                     optical depth
!      convfac     
!      corrfac
!      gamma
!      f1
!      f2
!      f3
!      pinteg
!      twopiesq
!      densmolrefsqt3
!      wavelength
!      freqsq
!      ristdm1
!      ri
!      iounit
!      nband
!      nf
!      ni
!      nw
!      nw1
!      nw2
!      nintsolar      the number of wavenumber regions where the  
!                     solar flux is constant.   
!      unit
!      io
!      ierr
!      i
!                                                                       
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init
      call esfsw_parameters_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
       read (input_nml_file, nml=esfsw_driver_nml, iostat=io)
       ierr = check_nml_error(io,'esfsw_driver_nml')
#else   
       if ( file_exist('input.nml')) then
         unit =  open_namelist_file ( )
         ierr=1; do while (ierr /= 0)
         read  (unit, nml=esfsw_driver_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'esfsw_driver_nml')
         end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
       call write_version_number (version, tagname)
       logunit = stdlog()
       if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=esfsw_driver_nml)

!---------------------------------------------------------------------
!    define flag indicating if ICA calculations being done.
!---------------------------------------------------------------------
      Cldrad_control%do_ica_calcs = do_ica_calcs
      Cldrad_control%do_ica_calcs_iz = .true.

!---------------------------------------------------------------------
!    allocate module variables
!---------------------------------------------------------------------
      nbands = Solar_spect%nbands       
      tot_wvnums = Solar_spect%tot_wvnums
      nfrqpts = Solar_spect%nfrqpts
      nstreams = Solar_spect%nstreams
      nh2obands = Solar_spect%nh2obands
      allocate ( betaddensitymol (nbands) )
      allocate ( c1co2   (nh2obands),  &
                 c1co2str(nh2obands),  &
                 c1o2    (nh2obands),  &
                 c1o2str (nh2obands),  &
                 c2co2   (nh2obands),  &
                 c2co2str(nh2obands),  &
                 c2o2    (nh2obands),  &
                 c2o2str (nh2obands),  &
                 c3co2   (nh2obands),  &
                 c3co2str(nh2obands),  &
                 c3o2    (nh2obands),  &
                 c3o2str (nh2obands),  &
                 c4co2   (nh2obands),  &
                 c4co2str(nh2obands),  &
                 c4o2    (nh2obands),  &
                 c4o2str (nh2obands),  &
                 c1ch4   (nh2obands),  &
                 c1ch4str(nh2obands),  &
                 c2ch4   (nh2obands),  &
                 c2ch4str(nh2obands),  &
                 c3ch4   (nh2obands),  &
                 c3ch4str(nh2obands),  &
                 c4ch4   (nh2obands),  &
                 c4ch4str(nh2obands),  &
                 c1n2o   (nh2obands),  &
                 c1n2ostr(nh2obands),  &
                 c2n2o   (nh2obands),  &
                 c2n2ostr(nh2obands),  &
                 c3n2o   (nh2obands),  &
                 c3n2ostr(nh2obands),  &
                 c4n2o   (nh2obands),  &
                 c4n2ostr(nh2obands),  &
                 powph2o (nh2obands),  &
                 p0h2o   (nh2obands)    )
      allocate ( nfreqpts        (nbands) )
      allocate ( solflxband      (nbands) )
      allocate ( solflxbandref   (nbands) )
      allocate ( kh2o            (nfrqpts),   & 
                 ko3             (nfrqpts),   &
                 wtfreq          (nfrqpts),   &
                 strterm         (nfrqpts)   )
      allocate ( wtstr           (nstreams),   & 
                 cosangstr       (nstreams)  )
      allocate ( totco2max    (nh2obands),     &
                 totco2strmax (nh2obands),     &
                 toto2max     (nh2obands),     &
                 toto2strmax  (nh2obands),   &
                 totch4max    (nh2obands),   &
                 totch4strmax (nh2obands),   &
                 totn2omax    (nh2obands),   &
                 totn2ostrmax (nh2obands)    )

      betaddensitymol = 0.0 ; c1co2    = 0.0 ; c1co2str = 0.0
      c1o2     = 0.0 ; c1o2str  = 0.0 ; c2co2    = 0.0
      c2co2str = 0.0 ; c2o2     = 0.0 ; c2o2str  = 0.0
      c3co2    = 0.0 ; c3co2str = 0.0 ; c3o2     = 0.0
      c3o2str  = 0.0 ; c4co2    = 0.0 ; c4co2str = 0.0
      c4o2     = 0.0 ; c4o2str  = 0.0 ; powph2o  = 0.0
      p0h2o    = 0.0 ; nfreqpts        = 0.0 ; solflxband      = 0.0
      solflxbandref   = 0.0 ; kh2o            = 0.0 ; ko3             = 0.0
      wtfreq          = 0.0 ; strterm     = .FALSE. ; wtstr           = 0.0
      cosangstr       = 0.0 ; totco2max     = 0.0 ; totco2strmax  = 0.0
      toto2max      = 0.0 ; toto2strmax   = 0.0
      c1ch4    = 0.0 ; c1ch4str = 0.0; c2ch4    = 0.0
      c2ch4str = 0.0 ; c3ch4    = 0.0 ; c3ch4str = 0.0
      c4ch4    = 0.0 ; c4ch4str = 0.0
      totch4max     = 0.0 ; totch4strmax  = 0.0
      c1n2o    = 0.0 ; c1n2ostr = 0.0; c2n2o    = 0.0
      c2n2ostr = 0.0 ; c3n2o    = 0.0 ; c3n2ostr = 0.0
      c4n2o    = 0.0 ; c4n2ostr = 0.0
      totn2omax     = 0.0 ; totn2ostrmax  = 0.0

!---------------------------------------------------------------------
!    allocate local variables.
!---------------------------------------------------------------------
      if (nstreams == 4) then
        ptstr(:) = ptstr_4(:)
        wtstr(:) = wtstr_4(:)
        nstr4 = .true.
      else if (nstreams == 1) then
        ptstr(1) = ptstr_1
        wtstr(1) = 1.0
        nstr4 = .false.
      endif

!---------------------------------------------------------------------
!    read input file for band positions, solar fluxes and band
!    strengths.
!---------------------------------------------------------------------
      if (nbands == 25 .and. nfrqpts == 72) then 
        file_name = 'INPUT/esf_sw_input_data_n72b25'
      else if (nbands == 18 .and. nfrqpts == 38) then
        file_name = 'INPUT/esf_sw_input_data_n38b18'
      else
        call error_mesg ( 'esfsw_driver_mod', &
          'input file for desired bands and frqs is not available', &
                                                               FATAL)
      endif
      iounit = open_namelist_file (file_name)
      read(iounit,101) ( solflxbandref(nband), nband=1,NBANDS )
      read(iounit,102) ( nfreqpts(nband), nband=1,NBANDS )
      read(iounit,103) ( endwvnbands(nband), nband=1,NBANDS )
      read(iounit,103) FIRSTRAYBAND,NIRBANDS
      read(iounit,104) ( powph2o(nband), nband=1,NH2OBANDS )
      read(iounit,104) ( p0h2o(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1co2(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1co2str(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2co2(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2co2str(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3co2(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3co2str(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1o2(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1o2str(nband), nband=1,NH2OBANDS ),  &
                         c1o2strschrun
      read(iounit,105) ( c2o2(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2o2str(nband), nband=1,NH2OBANDS ), &
                         c2o2strschrun
      read(iounit,105) ( c3o2(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3o2str(nband), nband=1,NH2OBANDS ),  &
                         c3o2strschrun
      read(iounit,105) ( c1ch4(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1ch4str(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2ch4(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2ch4str(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3ch4(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3ch4str(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1n2o(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c1n2ostr(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2n2o(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c2n2ostr(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3n2o(nband), nband=1,NH2OBANDS )
      read(iounit,105) ( c3n2ostr(nband), nband=1,NH2OBANDS )
      do nf = 1,nfrqpts
        read(iounit,106) wtfreq(nf),kh2o(nf),ko3(nf),strterm (nf)
      end do

      read(iounit,107) nintsolar

      allocate ( nwvnsolar (nintsolar) )
      allocate ( solint    (nintsolar) )
 
      do ni = 1,nintsolar
        read(iounit,107) nwvnsolar (ni),solint(ni)
      end do
 
      call close_file (iounit)
 
      if (Solar_spect%tot_wvnums /=       &
                                 endwvnbands(Solar_spect%nbands)) then
        call error_mesg ( 'esfsw_driver_mod', &
         ' inconsistency between highest solar spectrum wavenumber '//&
          'in esfsw_parameters_mod and in esfsw_sriver input file', &
                                                           FATAL)
      endif

!---------------------------------------------------------------------
!    define the band index corresponding to near ultraviolet light
!    (0.34 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > wvnum_340) then
          Solar_spect%w340_band_indx = ni
          Solar_spect%w340_band_iz = .true.
          exit
        endif
      end do
!---------------------------------------------------------------------
!    define the band index corresponding to near ultraviolet light
!    (0.38 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > wvnum_380) then
          Solar_spect%w380_band_indx = ni
          Solar_spect%w380_band_iz = .true.
          exit
        endif
      end do
!---------------------------------------------------------------------
!    define the band index corresponding to blue light
!    (0.44 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > wvnum_440) then
          Solar_spect%w440_band_indx = ni
          Solar_spect%w440_band_iz = .true.
          exit
        endif
      end do
!---------------------------------------------------------------------
!    define the band index corresponding to red light
!    (0.67 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > wvnum_670) then
          Solar_spect%w670_band_indx = ni
          Solar_spect%w670_band_iz = .true.
          exit
        endif
      end do
!---------------------------------------------------------------------
!    define the band index corresponding to visible light
!    (0.55 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > vis_wvnum) then
          Solar_spect%visible_band_indx = ni
          Solar_spect%visible_band_indx_iz = .true.
          exit
        endif
      end do

!---------------------------------------------------------------------
!    define the band index corresponding to 870nm
!    (0.87 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > wvnum_870) then
          Solar_spect%eight70_band_indx = ni
          Solar_spect%eight70_band_indx_iz = .true.
          exit
        endif
      end do

!---------------------------------------------------------------------
!    define the band index corresponding to near infra red band
!    (1.00 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > one_micron_wvnum) then
          Solar_spect%one_micron_indx = ni
          Solar_spect%one_micron_indx_iz = .true.
          exit
        endif
      end do
 
!---------------------------------------------------------------------
!    define the band index corresponding to               
!    (1.61 microns). note that endwvnbands is in units of (cm**-1).
!---------------------------------------------------------------------
      do ni=1,nbands
        if (endwvnbands(ni) > onepsix_micron_wvnum) then
          onepsix_band_indx = ni
          exit
        endif
      end do

!--------------------------------------------------------------------
!    define the wavenumber one solar fluxes.                       
!----------------------------------------------------------------- --
      do ni = 1,nintsolar
        if ( ni.eq.1 ) then
          nw1 = 1
        else
          nw1 = nw1 + nwvnsolar(ni-1)
        end if
        nw2 = nw1 + nwvnsolar(ni) - 1
        do nw = nw1,nw2
          Solar_spect%solarfluxtoa(nw) = solint(ni)
        end do
      end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      deallocate  (solint    )
      deallocate  (nwvnsolar )
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if ( .not. Rad_control%using_solar_timeseries_data) then
        Solar_spect%solflxband = solflxbandref
      endif
      Solar_spect%solflxbandref = solflxbandref
      Solar_spect%endwvnbands = endwvnbands

!--------------------------------------------------------------------
!    override the input file value of firstrayband if the nml control
!    variables indicates rayleigh effects are to be considered in
!    all bands.
!--------------------------------------------------------------------
      if (do_rayleigh_all_bands)  firstrayband = 1

!----------------------------------------------------------------------
!    convert some values to mks to match model units
!--------------------------------------------------------------------
      p0h2o = 1.0E-2/p0h2o  ! invert, and convert mb to mks
      kh2o = kh2o *1.0E-01   ! cgs to mks
      ko3  = ko3 *1.0E-01    ! cgs to mks

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      do n=1,NH2OBANDS
        if (c1co2(n) /= input_flag .and.  &
            c2co2(n) /= input_flag .and.  &
            c3co2(n) /= input_flag ) then
          c4co2(n) = c1co2(n) * c2co2(n) ** c3co2(n)
          c4co2str(n) = c1co2str(n) * c2co2str(n) ** c3co2str(n)
          totco2max(n) = ( (1.0/c1co2(n) ) + c2co2(n) ** c3co2(n) ) ** &
                       (1.0/c3co2(n) ) - c2co2(n)
          if (nbands == 18) then
            if ( n /= 4) then
              totco2strmax(n) = ( (1.0/c1co2str(n) ) + c2co2str(n) ** &
                                 c3co2str(n) ) ** (1.0/c3co2str(n) ) - &
                                c2co2str(n)
            else 
              totco2strmax(n) = HUGE (c4o2strschrun) 
            endif
          else
              totco2strmax(n) = ( (1.0/c1co2str(n) ) + c2co2str(n) ** &
                                 c3co2str(n) ) ** (1.0/c3co2str(n) ) - &
                                c2co2str(n)
          endif
        else
          c4co2(n) = 0.0                              
          c4co2str(n) = 0.0
          totco2max(n) = 0.0                                            
          totco2strmax(n) = 0.0
        endif
        if (c1o2(n) /= input_flag .and.   &
            c2o2(n) /= input_flag .and.   &
            c3o2(n) /= input_flag ) then
          c4o2(n) = c1o2(n) * c2o2(n) ** c3o2(n)
          c4o2str(n) = c1o2str(n) * c2o2str(n) ** c3o2str(n)
          toto2max(n) = ( (1.0/c1o2(n) ) + c2o2(n) ** c3o2(n) ) ** &
                          (1.0/c3o2(n) ) - c2o2(n)
          if (nbands == 18) then
            if ( n /= 4) then
              toto2strmax(n) = ( (1.0/c1o2str(n) ) + c2o2str(n) ** &
                                c3o2str(n) ) ** (1.0/c3o2str(n) ) - &
                                c2o2str(n)
            else
              toto2strmax(n) = HUGE (c4o2strschrun) 
            endif
          else
              toto2strmax(n) = ( (1.0/c1o2str(n) ) + c2o2str(n) ** &
                                c3o2str(n) ) ** (1.0/c3o2str(n) ) - &
                                c2o2str(n)
          endif
        else
          c4o2(n) = 0.0                              
          c4o2str(n) = 0.0
          toto2max(n) = 0.0                                            
          toto2strmax(n) = 0.0
        endif
    if (do_ch4_sw_effects) then
        if (c1ch4(n) /= input_flag .and.  &
            c2ch4(n) /= input_flag .and.  &
            c3ch4(n) /= input_flag ) then
          c4ch4(n) = c1ch4(n) * c2ch4(n) ** c3ch4(n)
          c4ch4str(n) = c1ch4str(n) * c2ch4str(n) ** c3ch4str(n)
          totch4max(n) = ( (1.0/c1ch4(n) ) + c2ch4(n) ** c3ch4(n) ) ** &
                           (1.0/c3ch4(n) ) - c2ch4(n)
          totch4strmax(n) = ( (1.0/c1ch4str(n) ) + c2ch4str(n) ** &
                            c3ch4str(n) ) ** (1.0/c3ch4str(n) ) - &
                            c2ch4str(n)
        else
          c4ch4(n) = 0.
          c4ch4str(n) = 0.
          totch4max(n) = 0.
          totch4strmax(n) = 0.     
        endif
     endif
     if (do_n2o_sw_effects) then
        if (c1n2o(n) /= input_flag .and.  &
            c2n2o(n) /= input_flag .and.  &
            c3n2o(n) /= input_flag ) then
          c4n2o(n) = c1n2o(n) * c2n2o(n) ** c3n2o(n)
          c4n2ostr(n) = c1n2ostr(n) * c2n2ostr(n) ** c3n2ostr(n)
          totn2omax(n) = ( (1.0/c1n2o(n) ) + c2n2o(n) ** c3n2o(n) ) ** &
                           (1.0/c3n2o(n) ) - c2n2o(n)
          totn2ostrmax(n) = ( (1.0/c1n2ostr(n) ) + c2n2ostr(n) ** &
                               c3n2ostr(n) ) ** (1.0/c3n2ostr(n) ) - &
                               c2n2ostr(n)
        else
          c4n2o(n) = 0.
          c4n2ostr(n) = 0.
          totn2omax(n) = 0.
          totn2ostrmax(n) = 0.     
        endif
     endif
      end do

      c4o2strschrun = c1o2strschrun * c2o2strschrun ** c3o2strschrun
      toto2strmaxschrun = ( (1.0/c1o2strschrun) + c2o2strschrun ** &
                             c3o2strschrun) ** (1.0/c3o2strschrun) - &
                             c2o2strschrun

!     if (mpp_pe() == 0) then
!       print *, 'c1ch4    ', c1ch4    
!       print *, 'c2ch4    ', c2ch4    
!       print *, 'c3ch4    ', c3ch4    
!       print *, 'c4ch4    ', c4ch4    
!       print *, 'totch4max', totch4max
!       print *, 'c1ch4str ', c1ch4str    
!       print *, 'c2ch4str ', c2ch4str    
!       print *, 'c3ch4str ', c3ch4str    
!       print *, 'c4ch4str ', c4ch4str    
!       print *, 'totch4strmax', totch4strmax
!       print *, 'c1co2    ', c1co2    
!       print *, 'c2ch4    ', c2co2    
!       print *, 'c3ch4    ', c3co2    
!       print *, 'c4ch4    ', c4co2    
!       print *, 'totch4max', totco2max
!       print *, 'c1ch4str ', c1co2str    
!       print *, 'c2ch4str ', c2co2str    
!       print *, 'c3ch4str ', c3co2str    
!       print *, 'c4ch4str ', c4co2str    
!       print *, 'totch4strmax', totco2strmax
!       print *, 'c1n2o    ', c1n2o    
!       print *, 'c2ch4    ', c2n2o    
!       print *, 'c3ch4    ', c3n2o    
!       print *, 'c4ch4    ', c4n2o    
!       print *, 'totch4max', totn2omax
!       print *, 'c1ch4str ', c1n2ostr    
!       print *, 'c2ch4str ', c2n2ostr    
!       print *, 'c3ch4str ', c3n2ostr    
!       print *, 'c4ch4str ', c4n2ostr    
!       print *, 'totch4strmax', totn2ostrmax
!       print *, '1/c1', 1.0/c1co2str
!       print *, '1/c3', 1.0/c3co2str
!       print *, 'c2**c3', c2co2str**c3co2str
!       print *, '(1 / + c2**c3)**1/c3',  &
!                 (1.0/c1co2str + c2co2str**c3co2str)**(1./c3co2str)
!       print *, 'c4o2    ', c4o2    
!       print *, 'c4o2str    ', c4o2str    
!       print *, 'toto2max', toto2max
!       print *, 'toto2strmax', toto2strmax
!     endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      if ( .not. Rad_control%using_solar_timeseries_data) then
      solflxtotal = 0.0
      do nband = 1,NBANDS
        solflxtotal = solflxtotal + Solar_spect%solflxbandref(nband)
      end do
      endif
 
!----------------------------------------------------------------------
!    define the wavenumbers to evaluate rayleigh optical depth.      
!-------------------------------------------------------------------
      endwvnbands(0) = 0
      do nband = 1,NBANDS
        freqnu(nband) = 0.5 * ( endwvnbands(nband-1) +   &
                                endwvnbands(nband) )
      end do
 
!---------------------------------------------------------------------
!    define quantities used to determine the rayleigh optical depth. 
!    notes: refquanray is the quantity which multiplies pressure /  
!           temperature to yield the molecular density.                 
!           betaddensitymol is the quantity which multiples the       
!           molecular density to yield the rayleigh scattering      
!           coefficient.                                           
!           1.39E-02 is the depolorization factor.              
!-----------------------------------------------------------------
      refquanray = densmolref * temprefray / pressrefray 
      corrfac = ( 6.0E+00 + 3.0E+00 * 1.39E-02 )/( 6.0E+00 - 7.0E+00 * &
                  1.39E-02 )
      gamma = 1.39E-02 / ( 2.0E+00 - 1.39E-02 )
      f1 = 7.5E-01 / ( gamma * 2.0E+00 + 1.0E+00 )
      f2 = gamma * 3.0E+00 + 1.0E+00 
      f3 = 1.0E+00 - gamma 
      pinteg = 2.0E+00 * PI * ( 2.0E+00 * f1 * f2 * ( 1.0E+00 + f3 / &
               f2 / 3.0E+00 ) )
      twopiesq = 2.0E+00 *  PI ** 2
      densmolrefsqt3 = 3.0E+00 * densmolref ** 2
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do nband = 1,NBANDS
        wavelength = 1.0E+04 / freqnu(nband)
        freqsq = 1.0 / ( wavelength ) ** 2
        ristdm1 = ( 6.4328E+03 + 2.94981E+06 / ( 1.46E+02 - freqsq ) + &
                    2.554E+04 / ( 4.1E+01 - freqsq ) ) * 1.0E-08
        ri = ristdm1 + 1
        betaddensitymol(nband) = twopiesq*( ri ** 2 - 1.0E+00 ) ** 2 * &
                                 corrfac / ( densmolrefsqt3 *  &
                                 wavelength ** 4 ) * pinteg * convfac 
      end do
 
      gausswt(1) = 1.0

!---------------------------------------------------------------------
!    define the gaussian angles for evaluation of the diffuse beam.  
!--------------------------------------------------------------------
      do i = 1,nstreams
        cosangstr(i) = ( ptstr(i) + 1. ) * 5.0E-01
      end do

!--------------------------------------------------------------------
!    mark the module as initialized.
!--------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------
 101  format( 12f10.4 )
 102  format( 32i4 )
 103  format( 20i6 )
 104  format( 12f10.2 )
 105  format( 1p,16e8.1 )
 106  format( 1p,3e16.6,l16 )
 107  format( i5,1p,e14.5 )
 
!---------------------------------------------------------------------


end subroutine esfsw_driver_init 



!#################################################################
! <SUBROUTINE NAME="swresf">
!  <OVERVIEW>
!   Subroutine that uses the delta-eddington technique in conjunction
!   with a multi-band parameterization for h2o+co2+o2+o3 absorption
!   in the solar spectrum to derive solar fluxes and heating rates.
!  </OVERVIEW>
!  <DESCRIPTION>
!    This subroutine calculates optical depth, single scattering albedo,
!    asymmetry parameter of a layer based on gaseous absorbers,
!    clouds, aerosols, and rayleigh scattering. It then uses delta-
!    eddington technique to calculate radiative flux at each layer. 
!    Doubling and adding technique is used to combine the layers
!    and calculate flux at TOA and surface and heating rate. This
!    subroutine allocates a substantial amount of memory and deallocates
!    the allocated memory at the end of the subroutine.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call swresf(is, ie, js, je, Atmos_input, Surface, Rad_gases, Aerosol, 
!               Astro, &
!               Cldrad_props, Cld_spec, Sw_output)
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!    starting subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!    ending subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!    starting subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="je" TYPE="integer">
!    ending subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    Atmos_input_type variable containing the atmospheric
!    input fields on the radiation grid 
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol input data for shortwave radiation calculation
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!    Astronomy_type variable containing the astronomical
!    input fields on the radiation grid  
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!    Radiative_gases_type variable containing the radiative 
!    gas input fields on the radiation grid 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!    The cloud radiative property input fields on the
!    radiation grid
!  </IN>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!    The shortwave radiation calculation result
!  </INOUT>
!  <IN NAME="Surface" TYPE="surface_type">
!   Surface data as boundary condition to radiation
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud specification data as initial condition to radiation
!  </IN>
! </SUBROUTINE>

subroutine swresf (is, ie, js, je, Atmos_input, Surface, Rad_gases,  &
                   Aerosol, Aerosol_props, Astro, Cldrad_props,  &
                   Cld_spec, including_volcanoes, Sw_output,   &
                   Aerosol_diags, r, including_aerosols,   &
                   naerosol_optical) 

!----------------------------------------------------------------------
!    swresf uses the delta-eddington technique in conjunction with a    
!    multiple-band parameterization for h2o+co2+o2+o3 absorption to   
!    derive solar fluxes and heating rates.                             
!    notes: drops are assumed if temp>273.15K, ice crystals otherwise.
!-------------------------------------------------------------------

integer,                       intent(in)    :: is, ie, js, je
type(atmos_input_type),        intent(in)    :: Atmos_input
type(surface_type),            intent(in)    :: Surface
type(radiative_gases_type),    intent(in)    :: Rad_gases   
type(aerosol_type),            intent(in)    :: Aerosol     
type(aerosol_properties_type), intent(in)    :: Aerosol_props
type(astronomy_type),          intent(in)    :: Astro
type(cldrad_properties_type),  intent(in)    :: Cldrad_props
type(cld_specification_type),  intent(in)    :: Cld_spec      
logical,                       intent(in)    :: including_volcanoes
type(sw_output_type),          intent(inout) :: Sw_output   
type(aerosol_diagnostics_type),intent(inout) :: Aerosol_diags
real,dimension(:,:,:,:),       intent(inout) :: r
logical,                       intent(in)    :: including_aerosols  
integer,                       intent(in)    :: naerosol_optical


!-------------------------------------------------------------------
!  intent(in) variables:
!
!    is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Atmos_input    atmos_input_type structure, contains variables
!                     defining atmospheric state
!      Surface        surface_type structure, contains variables 
!                     defining the surface characteristics
!      Rad_gases      radiative_gases_type structure, contains var-
!                     iables defining the radiatively active gases, 
!                     passed through to lower level routines
!      Aerosol        aerosol_type structure, contains variables
!                     defining aerosol fields, passed through to
!                     lower level routines
!      Aerosol_props  aerosol radiative property input data for the 
!                     radiation package
!      Astro          astronomy_type structure
!      Cldrad_props   cloud radiative property input data for the 
!                     radiation package
!      Cld_spec       cld_specification_type structure, contains var-
!                     iables defining the cloud distribution, passed 
!                     through to lower level routines
!                                                                 
!   intent(inout) variables:
!
!      Sw_output         shortwave radiation output data
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!     local variables:
 

      logical, dimension (size(Atmos_input%temp,1), &
                          size(Atmos_input%temp,2), &
                          size(Atmos_input%temp,3)-1)  :: &
                             cloud

      logical, dimension (size(Atmos_input%temp,1), &
                          size(Atmos_input%temp,2))  ::   &
                              cloud_in_column,   daylight

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)-1, &
                        Solar_spect%nbands)  :: &
            aeroasymfac,     aerosctopdep,   aeroextopdep, &
            rayopdep

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)-1, &
                       nfrqpts,NSOLWG)  ::     &
                                                    gasopdep

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)-1)  :: &
            cloudfrac,      cldfrac_band,    cldfrac,         &
            deltaz,         cloud_deltaz,                     &
            cldext,         cldsct,          cldasymm,         &
            cloudasymfac,   cloudextopdep,                     &
            cloudsctopdep,                   deltap,           &
            densitymol,     extopdepclr,                       &
            extopdepovc,    fclr,            fovc,             &
            gocpdp,         gclr,            gstrclr,          &
            gstrovc,        govc,            omegastrclr,      &
            omegastrovc,    rlayerdif,       rlayerdir,        &
            rlayerdifclr,   rlayerdifovc,    &
            rlayerdirclr,   rlayerdirovc,                     &
            sctopdepclr,    sctopdepovc,      &
            ssalbclr,        ssalbovc,                         &
            taustrclr,      taustrovc,        &
            tlayerde,       tlayerdeclr,      &
            tlayerdeovc,    tlayerdif,                        &
            tlayerdifclr,   tlayerdifovc,     &
            tlayerdir,      tlayerdirclr,     &
            tlayerdirovc
           
      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3))  :: &
              reflectance,  transmittance,  tr_dir            

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3), &
                       Rad_control%nzens)  :: &
            dfswbandclr,     fswbandclr,    ufswbandclr, &
            dfswband,        fswband,       ufswband,  &
            sumtrclr,        sumreclr,      sumtr_dir_clr,  & 
            sumtr,           sumre,         sumtr_dir

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3))  :: &
            press,           pflux,            pflux_mks, &
            temp,                                       &
            reflectanceclr,  transmittanceclr, tr_dirclr

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)-1 , &
                       Rad_control%nzens)  :: &
                hswbandclr,  hswband

      real, dimension (size(Atmos_input%temp,1), &
                       size(Atmos_input%temp,2))    ::  &
            sfcalb_dir,   sfcalb_dif,  wtfac_p,    &
            fracday_p,    solarflux_p

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),   &
                                         NSOLWG) ::         &
                 cosangsolar_p

      integer :: j, i, k, ng, np, nband, nf, ns, nz
      integer :: nzens

      integer :: nprofile, nprofiles
      real    :: profiles_inverse

      integer :: ix, jx, kx, israd, jsrad, ierad, jerad, ksrad, kerad
      real    :: ssolar  
      real    :: solflxtotal_local




!-----------------------------------------------------------------------
!     local variables:
!
!       aeramt
!       sum_g_omega_tau
!       opt_index_v3
!       irh
!    etc.
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('esfsw_driver_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    define the solar_constant appropriate at Rad_time when solar
!    input is varying with time.
!---------------------------------------------------------------------
!-- The following fix is for openmp
      if (Rad_control%using_solar_timeseries_data) then
        solflxtotal_local = 0.0
        do nband = 1,NBANDS
          solflxtotal_local = solflxtotal_local + Solar_spect%solflxband(nband)
        end do
      else
        solflxtotal_local = solflxtotal
      endif

!---------------------------------------------------------------------
!
      
      cldfrac = Cld_spec%camtsw

!---------------------------------------------------------------------
!  convert to cgs and then back to mks for consistency with previous 
!---------------------------------------------------------------------
      press(:,:,:) = 0.1*(10.0*Atmos_input%press(:,:,:))
      pflux(:,:,:) =     (10.0*Atmos_input%pflux(:,:,:))
      deltaz(:,:,:) = Atmos_input%deltaz(:,:,:)
      temp  (:,:,:) = Atmos_input%temp  (:,:,:)
      cloud_deltaz = Atmos_input%clouddeltaz

!--------------------------------------------------------------------
!    define limits and dimensions 
!--------------------------------------------------------------------
      ix = size(temp,1)
      jx = size(temp,2)
      kx = size(temp,3) - 1
      israd = 1
      jsrad = 1
      ksrad = 1
      ierad = ix
      jerad = jx
      kerad = kx

!----------------------------------------------------------------------c
!    define a flag indicating columns in which there is sunshine during
!    this radiation time step. define a flag indicating points with both
!    sunlight and cloud.      
!----------------------------------------------------------------------c
      do j = JSRAD,JERAD
        do i = ISRAD,IERAD
          if ( Astro%fracday(i,j) /= 0.0) then
            daylight(i,j) = .true.                 
          else
            daylight(i,j) = .false.                
          endif     
          cloud_in_column(i,j) = .false.
        end do
      end do
        
      call compute_aerosol_optical_props     &
                (Atmos_input, Aerosol, Aerosol_props, &
                 including_volcanoes, Aerosol_diags, r,  &
                 including_aerosols, naerosol_optical, &
                 daylight, aeroextopdep, aerosctopdep, aeroasymfac) 

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ssolar = Sw_control%solar_constant*Astro%rrsun

 
!----------------------------------------------------------------------
!    define a flag indicating points with both sunlight and cloud. set
!    the flag indicating that cloud is present in columns with such
!    points.
!----------------------------------------------------------------------
      if (.not. Cldrad_control%do_stochastic_clouds) then
        do j = JSRAD,JERAD
          do i = ISRAD,IERAD
            if (daylight(i,j)) then
              do k=KSRAD,KERAD
                if (cldfrac(i,j,k) > 0.0)  then
                  cloud_in_column(i,j) = .true.
                  cloud(i,j,k) = .true.
                  cloudfrac(i,j,k) = cldfrac(i,j,k)
                else
                  cloud(i,j,k) = .false.
                  cloudfrac(i,j,k) = 0.0
                endif
              end do
            else
              do k=KSRAD,KERAD
                cloud(i,j,k) = .false.
                cloudfrac(i,j,k) = 0.0
              end do
            endif
          end do
        end do
      endif

!----------------------------------------------------------------------c
!    define pressure related quantities, pressure is in mks units. 
!----------------------------------------------------------------------c
      pflux_mks = pflux*1.0E-1

      do k = KSRAD+1,KERAD+1
        deltap(:,:,k-1) = pflux_mks(:,:,k) - pflux_mks(:,:,k-1)
        gocpdp(:,:,k-1) = radcon_mks/deltap(:,:,k-1)
      end do
 
      call compute_gas_props (Atmos_input, Rad_gases, Astro,   &
                              daylight, gasopdep)
  
!---------------------------------------------------------------------
!    define the molecular density for use in calculating the           
!    rayleigh optical depth (deltaz is in meters).                     
!--------------------------------------------------------------------
      do k = KSRAD,KERAD
        densitymol(:,:,k) = refquanray * press(:,:,k) / temp(:,:,k)
      end do
 

! assumption is that there is 1 cloud profile for each sw band
      if (do_ica_calcs) then
        nprofiles = nbands
        profiles_inverse = 1.0/nprofiles
      else
        nprofiles = 1
        profiles_inverse = 1.0
      endif

!--------------------------------------------------------------------
!    define the rayleigh optical depths.                                
!---------------------------------------------------------------------
      do nband = 1, NBANDS
        rayopdep(:,:,:,nband) = betaddensitymol(nband)*  &
                                        densitymol(:,:,:)*deltaz(:,:,:)
      end do   ! (nband loop)

      nzens = Rad_control%nzens

!--------------------------------------------------------------------
 
      do nprofile=1, nprofiles
        if (do_ica_calcs) then
          cldfrac_band(:,:,:) = Cld_spec%camtsw_band(:,:,:,nprofile)
        endif

!----------------------------------------------------------------------c
!    np is a counter for the pseudo-monochromatic frequency point 
!    number.
!----------------------------------------------------------------------c
        np = 0
 
        do nz=1,nzens
          if (Rad_control%do_totcld_forcing) then
            dfswbandclr(:,:,:,nz) = 0.0
            fswbandclr(:,:,:,nz) = 0.0
            hswbandclr(:,:,:,nz) = 0.0
            ufswbandclr(:,:,:,nz) = 0.0
          endif
        end do
        reflectanceclr = 0.0
        transmittanceclr = 0.0

!----------------------------------------------------------------------c
!    begin band loop                                                   
!----------------------------------------------------------------------c
        do nband = 1,NBANDS
 
          do nz=1,nzens
            sumtr(:,:,:,nz) = 0.0
            sumtr_dir(:,:,:,nz) = 0.0
            sumre(:,:,:,nz) = 0.0
            if (Rad_control%do_totcld_forcing) then
              sumtrclr(:,:,:,nz) = 0.0
              sumreclr(:,:,:,nz) = 0.0
              sumtr_dir_clr(:,:,:,nz) = 0.0
            endif
          end do
          if (Cldrad_control%do_stochastic_clouds) then
            if (.not. do_ica_calcs) then
              cldfrac_band(:,:,:) = Cld_spec%camtsw_band(:,:,:,nband)
            endif
          endif
 
!----------------------------------------------------------------------
!    if stochastic clouds are activated (cloud fields differ with sw
!    parameterization band), define a flag indicating points with both
!    sunlight and cloud for the current sw parameterization band. set
!    the flag indicating that cloud is present in columns with such
!    points.
!----------------------------------------------------------------------
          if (Cldrad_control%do_stochastic_clouds) then
            do j = JSRAD,JERAD
              do i = ISRAD,IERAD
                cloud_in_column(i,j) = .false.
                if (daylight(i,j)) then
                  do k = KSRAD,KERAD
                    if (cldfrac_band(i,j,k) > 0.0)  then
                      cloud_in_column(i,j) = .true.
                      cloud(i,j,k) = .true.
                      cloudfrac(i,j,k) = cldfrac_band(i,j,k)
                    else
                      cloud(i,j,k) = .false.
                      cloudfrac(i,j,k) = 0.0
                    endif
                  end do
                else
                  do k = KSRAD,KERAD
                    cloud(i,j,k) = .false.
                    cloudfrac(i,j,k) = 0.0
                  end do
                endif
              end do
            end do
          endif


!---------------------------------------------------------------------
!    obtain cloud properties from the Cldrad_props input variable.
!--------------------------------------------------------------------
          cldext(:,:,:) = Cldrad_props%cldext(:,:,:,nband,nprofile)
          cldsct(:,:,:) = Cldrad_props%cldsct(:,:,:,nband,nprofile)
          cldasymm(:,:,:) = Cldrad_props%cldasymm(:,:,:,nband,nprofile)

          do k = KSRAD,KERAD
            do j=JSRAD,JERAD
              do i=ISRAD, IERAD
                if (cloud(i,j,k) ) then
                  cloudextopdep(i,j,k) = 1.0E-03*cldext(i,j,k) *    &
                                         cloud_deltaz(i,j,k)
                  cloudsctopdep(i,j,k) = 1.0E-03*cldsct(i,j,k) *    &
                                         cloud_deltaz(i,j,k)
                  cloudasymfac(i,j,k) = cldasymm(i,j,k)
                endif
              end do
            end do
          end do

!-----------------------------------------------------------------
!    define clear sky arrays
!-----------------------------------------------------------------
          if (nband >= firstrayband ) then
            do k=ksrad,kerad
              do j=jsrad,jerad
                do i=israd,ierad
                  if (daylight(i,j) ) then
                    sctopdepclr(i,j,k) = rayopdep(i,j,k,nband) +   &
                                            aerosctopdep(i,j,k,nband)
                    gclr(i,j,k) = aeroasymfac(i,j,k,nband)*  &
                                  aerosctopdep(i,j,k,nband)/&
                                                     sctopdepclr(i,j,k)
                    fclr(i,j,k) = aeroasymfac(i,j,k,nband)*gclr(i,j,k)
                    gstrclr(i,j,k) = ( gclr(i,j,k)  - fclr(i,j,k) )/  &
                                     ( 1.0 - fclr(i,j,k) )
                  endif
                end do
              end do
            end do
          endif

!-----------------------------------------------------------------
!    define cloudy sky arrays
!-----------------------------------------------------------------
          do k=KSRAD,KERAD
            do j=JSRAD,JERAD
              do i=ISRAD,IERAD
                if (cloud(i,j,k)) then
                  sctopdepovc(i,j,k) = rayopdep(i,j,k,nband) +    &
                                       aerosctopdep(i,j,k,nband) + &
                                       cloudsctopdep(i,j,k) 
                  govc(i,j,k) = ( ( cloudasymfac(i,j,k) *   &
                                    cloudsctopdep(i,j,k) ) +  &
                                  ( aeroasymfac(i,j,k,nband) *   &
                                    aerosctopdep(i,j,k,nband)))/   &
                                    sctopdepovc(i,j,k)
                  fovc(i,j,k) = ( ( cloudasymfac(i,j,k) ** 2 *  &
                                    cloudsctopdep(i,j,k) ) + &
                                  ( aeroasymfac(i,j,k,nband) ** 2 *  &
                                    aerosctopdep(i,j,k,nband) ))/  &
                                    sctopdepovc(i,j,k)
                  gstrovc(i,j,k) = ( govc(i,j,k)  - fovc(i,j,k))/  &
                                   ( 1.0 - fovc(i,j,k) )
                endif
              end do
            end do
          end do

!---------------------------------------------------------------------
!    begin frequency points in the band loop.                          
!--------------------------------------------------------------------
          do nf = 1,nfreqpts(nband)
            np = np + 1
 
!---------------------------------------------------------------------
!    begin gaussian angle loop (ng > 1 only when lswg = true).        
!--------------------------------------------------------------------
            do ng = 1,NSOLWG
 
!---------------------------------------------------------------------
!    clear sky mode                                                    
!    note: in this mode, the delta-eddington method is performed for all
!    spatial columns experiencing sunlight.         
!--------------------------------------------------------------------
              if (nband >= firstrayband )  then
                do k=ksrad,kerad
                  do j=jsrad,jerad
                    do i=israd,ierad
                      if (daylight(i,j) ) then
                        extopdepclr(i,j,k) = gasopdep(i,j,k,np,ng) +  &
                                             rayopdep(i,j,k,nband) +   &
                                             aeroextopdep(i,j,k,nband)
                        ssalbclr(i,j,k) = sctopdepclr(i,j,k)/    &
                                          extopdepclr(i,j,k)
                        taustrclr(i,j,k) = extopdepclr(i,j,k)*( 1.0 -  &
                                           ssalbclr(i,j,k)*fclr(i,j,k) )
                        omegastrclr(i,j,k) =      &
                               ssalbclr(i,j,k)*((1.0 - fclr(i,j,k))/  &
                               (1.0 -  ssalbclr(i,j,k)*fclr(i,j,k)))
                      endif
                    end do
                  end do
                end do
              endif

!--------------------------------------------------------------------
!    calculate the scaled single-scattering quantities for use in the   
!    delta-eddington routine.                                         
!--------------------------------------------------------------------
              do k=KSRAD,KERAD
                do j=JSRAD,JERAD
                  do i=ISRAD,IERAD
                    if (cloud(i,j,k) ) then
                      extopdepovc(i,j,k) = gasopdep(i,j,k,np,ng) +    &
                                           rayopdep(i,j,k,nband) +  &
                                           aeroextopdep(i,j,k,nband) + &
                                           cloudextopdep(i,j,k)
                      ssalbovc(i,j,k) = sctopdepovc(i,j,k) /    &
                                        extopdepovc(i,j,k)
                      taustrovc(i,j,k) = extopdepovc(i,j,k)*( 1.0 - &
                                         ssalbovc(i,j,k)*fovc(i,j,k) )
                      omegastrovc(i,j,k) = ssalbovc(i,j,k)*( ( 1.0 - &
                                           fovc(i,j,k) )/( 1.0 -   &
                                           ssalbovc(i,j,k) *   &
                                           fovc(i,j,k) ) )
                    endif
                  end do
                end do
              end do

!---------------------------------------------------------------------
!    do calculations for all desired zenith angles.
!---------------------------------------------------------------------
              do nz = 1, nzens
                if (Rad_control%hires_coszen) then
                  cosangsolar_p(:,:,ng) = Astro%cosz_p(:,:,nz)   
                else
                  cosangsolar_p(:,:,ng) = Astro%cosz(:,:)          
                endif

                where (cosangsolar_p(:,:,:) == 0.0)   &
                                            cosangsolar_p(:,:,:) = 1.0

!---------------------------------------------------------------------
!    clear sky mode                                                    
!    note: in this mode, the delta-eddington method is performed for all
!    spatial columns experiencing sunlight.         
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    calculate the scaled single-scattering quantities for use in the   
!    delta-eddington routine.                                       
!---------------------------------------------------------------------
                if (nband >= firstrayband )  then

!---------------------------------------------------------------------
!    do diffuse calculation only for first zenith angle -- it is 
!    independent of zenith angle.
!---------------------------------------------------------------------
                  if (nz == 1) then
                    call deledd     &
                        (ix, jx, kx, taustrclr, omegastrclr, &
                         gstrclr, cosangsolar_p(:,:,ng), ng, daylight, &
                         rlayerdirclr, tlayerdirclr, tlayerdeclr, &
                         rlayerdif=rlayerdifclr, tlayerdif=tlayerdifclr)
                  else
                    call deledd     &
                        (ix, jx, kx, taustrclr, omegastrclr, &
                         gstrclr, cosangsolar_p(:,:,ng), ng, daylight,&
                         rlayerdirclr, tlayerdirclr, tlayerdeclr)
                  endif

!---------------------------------------------------------------------
!    the following needs to be done at daylight points only -- currently
!    this code is not active, since ng == 1.
!---------------------------------------------------------------------
                  if (ng /= 1) then
                    tlayerdifclr = 0.0       
                    if (NSTREAMS == 1) then
                      tlayerdifclr(:,:,:) =   &
                             exp(-gasopdep(:,:,:,np,ng)/cosangstr(1))
                    else
                      do ns = 1,NSTREAMS
                        tlayerdifclr(:,:,:) =    &
                             tlayerdifclr(:,:,:) +  & 
                                   exp( -gasopdep(:,:,:,np,ng)/&
                                         cosangstr(ns) )*wtstr(ns)* &
                                         cosangstr(ns)
                      end do
                    endif
                    rlayerdifclr = 0.0
                  endif
  
!---------------------------------------------------------------------
!    initialize the layer reflection and transmission arrays for the   
!    non-rayleigh-scattering case.                            
!-------------------------------------------------------------------
                else
!---------------------------------------------------------------------
!    the following needs to be done at daylight points only -- currently
!    this code is not active, since ng == 1, and all bands see rayleigh
!    scattering.
!---------------------------------------------------------------------
                  tlayerdifclr = 0.0       
                  if (NSTREAMS == 1) then
                    tlayerdifclr(:,:,:) =     &
                            exp( -gasopdep(:,:,:,np,ng)/cosangstr(1))
                  else
                    do ns = 1,NSTREAMS
                      tlayerdifclr(:,:,:) =   &
                         tlayerdifclr(:,:,:) +    &
                              exp(-gasopdep(:,:,:,np,ng)/&
                                cosangstr(ns))*wtstr(ns)*cosangstr(ns)
                    end do
                  endif
                  rlayerdirclr(:,:,:) = 0.0
                  do k=KSRAD,KERAD
                    tlayerdirclr(:,:,k) =      &
                                  exp( -gasopdep(:,:,k,np,ng) /   &
                                                 cosangsolar_p(:,:,ng) )
                  end do  
                  tlayerdeclr(:,:,:) = tlayerdirclr(:,:,:)
                  rlayerdifclr = 0.0
                endif

!---------------------------------------------------------------------
!    overcast sky mode                                                  
!    note: in this mode, the delta-eddington method is performed only 
!    for spatial columns containing a cloud and experiencing sunlight. 
!---------------------------------------------------------------------


!----------------------------------------------------------------------
!    calculate the reflection and transmission in the scattering layers 
!    using the delta-eddington method.                                  
!-------------------------------------------------------------------
                if (nz == 1) then
                  call deledd      &
                       (ix, jx, kx, taustrovc, omegastrovc, gstrovc, &
                        cosangsolar_p(:,:,ng), ng, daylight, &
                        rlayerdirovc, tlayerdirovc, tlayerdeovc, &
                        rlayerdif=rlayerdifovc, tlayerdif=tlayerdifovc,&
                        cloud=cloud)
                else
                  call deledd      &
                       (ix, jx, kx, taustrovc, omegastrovc, gstrovc, &
                        cosangsolar_p(:,:,ng), ng, daylight, &
                        rlayerdirovc, tlayerdirovc, tlayerdeovc,   & 
                        cloud=cloud)
                endif
                if (ng /= 1) then
                  tlayerdifovc(:,:,:) = tlayerdifclr(:,:,:)
                  rlayerdifovc(:,:,:) = rlayerdifclr(:,:,:)
                endif
 
!-------------------------------------------------------------------- 
!    weight the reflection and transmission arrays for clear and        
!    overcast sky conditions by the cloud fraction, to calculate the    
!    resultant values.                                                  
!---------------------------------------------------------------------- 
                do k=KSRAD,KERAD
                  do j=JSRAD,JERAD
                    do i=ISRAD,IERAD
                      if ( cloud(i,j,k) ) then
                        rlayerdir(i,j,k) = cloudfrac(i,j,k)*   &
                                           rlayerdirovc(i,j,k) +  &
                                           (1.0 - cloudfrac(i,j,k) )*  &
                                           rlayerdirclr(i,j,k)
                        rlayerdif(i,j,k) = cloudfrac(i,j,k) *  &
                                           rlayerdifovc(i,j,k) +  &
                                           ( 1.0 - cloudfrac(i,j,k) )* &
                                           rlayerdifclr(i,j,k)
                        tlayerdir(i,j,k) = cloudfrac(i,j,k) *   &
                                           tlayerdirovc(i,j,k) +  &
                                           ( 1.0 - cloudfrac(i,j,k) )* &
                                           tlayerdirclr(i,j,k)
                        tlayerdif(i,j,k) = cloudfrac(i,j,k) *   &
                                           tlayerdifovc(i,j,k) +  &
                                           ( 1.0 - cloudfrac(i,j,k) )* &
                                           tlayerdifclr(i,j,k)
                        tlayerde(i,j,k) =  cloudfrac(i,j,k) *   &
                                           tlayerdeovc(i,j,k) +  &
                                           (1.0 - cloudfrac(i,j,k) )* &
                                           tlayerdeclr(i,j,k)
                      else if (daylight(i,j)) then
                        rlayerdir(i,j,k) = rlayerdirclr(i,j,k)
                        tlayerdir(i,j,k) = tlayerdirclr(i,j,k)
                        rlayerdif(i,j,k) = rlayerdifclr(i,j,k)
                        tlayerdif(i,j,k) = tlayerdifclr(i,j,k)
                        tlayerde (i,j,k) = tlayerdeclr (i,j,k)
                      endif
                    end do
                  end do
                end do
 
!---------------------------------------------------------------------
!    define the surface albedo (infrared value for infrared bands,      
!    visible value for the remaining bands).                            
!----------------------------------------------------------------------c
                if (nband <= NIRBANDS ) then
                  sfcalb_dir(:,:) = Surface%asfc_nir_dir(:,:)
                  sfcalb_dif(:,:) = Surface%asfc_nir_dif(:,:)
                else
                  sfcalb_dir(:,:) = Surface%asfc_vis_dir(:,:)
                  sfcalb_dif(:,:) = Surface%asfc_vis_dif(:,:)
                end if
 
!-------------------------------------------------------------------- 
!    calculate the reflection and transmission at flux levels from the  
!    direct and diffuse values of reflection and transmission in the  
!    corresponding layers using the adding method.                      
!---------------------------------------------------------------------
                call adding         &
                    (ix, jx, kx, rlayerdir, tlayerdir, rlayerdif, &
                     tlayerdif, tlayerde, sfcalb_dir, sfcalb_dif,    &
                     daylight, reflectance, transmittance, tr_dir)    

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
                if (Rad_control%do_totcld_forcing) then
                  call adding       &
                      (ix, jx,  kx, rlayerdirclr, tlayerdirclr,   &
                       rlayerdifclr, tlayerdifclr, tlayerdeclr,   &
                       sfcalb_dir,  sfcalb_dif, cloud_in_column,  &
                       reflectanceclr, transmittanceclr, tr_dirclr)
                endif

!---------------------------------------------------------------------- 
!    weight and sum the reflectance and transmittance to calculate the 
!    band values.                                                     
!-------------------------------------------------------------------
                do j=JSRAD,JERAD
                  do i=ISRAD,IERAD
                    wtfac_p(i,j) = wtfreq(np)*gausswt(ng)*   &
                                                  cosangsolar_p(i,j,ng)
                  end do
                end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
                do k = KSRAD,KERAD+1
                  do j=JSRAD,JERAD
                    do i=ISRAD,IERAD
                      if (daylight(i,j) ) then
                        sumtr(i,j,k,nz) = sumtr(i,j,k,nz) +    &
                                      transmittance(i,j,k)*wtfac_p(i,j)
                        sumtr_dir(i,j,k,nz) = sumtr_dir(i,j,k,nz) +  &
                                        tr_dir(i,j,k)*wtfac_p(i,j)
                        sumre(i,j,k,nz) = sumre(i,j,k,nz) +     &
                                       reflectance(i,j,k)*wtfac_p(i,j)
                      endif
                    end do
                  end do
                end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
                if (Rad_control%do_totcld_forcing) then
                  do k = KSRAD,KERAD+1
                    do j=JSRAD,JERAD
                      do i=ISRAD,IERAD
                        if (cloud_in_column(i,j)) then
                          sumtrclr(i,j,k,nz) =    &
                                sumtrclr(i,j,k,nz) +   &
                                transmittanceclr(i,j,k)* wtfac_p(i,j) 
                          sumtr_dir_clr(i,j,k,nz) = &
                                sumtr_dir_clr(i,j,k,nz) +  &
                                tr_dirclr(i,j,k)*wtfac_p(i,j)
                          sumreclr(i,j,k,nz) = sumreclr(i,j,k,nz) +   &
                                reflectanceclr(i,j,k)*wtfac_p(i,j)
                        else if (daylight(i,j) ) then
                          sumtrclr(i,j,k,nz) = sumtrclr(i,j,k,nz) +   &
                                transmittance(i,j,k)*wtfac_p(i,j)
                          sumtr_dir_clr(i,j,k,nz) =    &
                             sumtr_dir_clr(i,j,k,nz) + tr_dir(i,j,k)*&
                                                            wtfac_p(i,j)
                          sumreclr(i,j,k,nz) = sumreclr(i,j,k,nz) +   &
                                        reflectance(i,j,k)*wtfac_p(i,j)
                        endif
                      end do
                    end do
                  end do
                endif
              end do ! end of nz loop
            end do    ! end of gaussian loop
          end do  ! end of frequency points in the band loop
 
!----------------------------------------------------------------------
!    normalize the solar flux in the band to the appropriate value for  
!    the given total solar insolation.                                 
!---------------------------------------------------------------------
          do nz = 1,nzens
            if (Rad_control%hires_coszen) then
              fracday_p(:,:) = Astro%fracday_p(:,:,nz)
            else
              fracday_p(:,:) = Astro%fracday(:,:)
            endif
            solarflux_p(:,:) = fracday_p(:,:)*  &
                                   Solar_spect%solflxband(nband)*  &
                                                      ssolar/solflxtotal_local
 
            if (nband == Solar_spect%visible_band_indx) then
              Sw_output%bdy_flx(:,:,1,nz) =   &
                  Sw_output%bdy_flx(:,:,1,nz) + sumre(:,:,1,nz)*   &
                                                        solarflux_p(:,:)
              Sw_output%bdy_flx(:,:,3,nz) =    &
                  Sw_output%bdy_flx(:,:,3,nz) + sumtr(:,:,KERAD+1,nz)*&
                                                solarflux_p(:,:) -  &
                                                sumre(:,:,KERAD+1,nz)* &
                                                solarflux_p(:,:) 
            endif
            if (nband == onepsix_band_indx) then
               Sw_output%bdy_flx(:,:,2,nz) =     &
                   Sw_output%bdy_flx(:,:,2,nz) + sumre(:,:,1,nz)*  &
                                                        solarflux_p(:,:)
               Sw_output%bdy_flx(:,:,4,nz) =    &
                   Sw_output%bdy_flx(:,:,4,nz) + sumtr(:,:,KERAD+1,nz)*&
                                                 solarflux_p(:,:) - &
                                                 sumre(:,:,KERAD+1,nz)*&
                                                 solarflux_p(:,:)
            endif
          
!-------------------------------------------------------------------
!    calculate the band fluxes and heating rates.                       
!--------------------------------------------------------------------
            if (do_esfsw_band_diagnostics) then
              do k = KSRAD,KERAD+1
                do j=JSRAD,JERAD
                  do i=ISRAD,IERAD
                    dfswband(i,j,k,nz) = sumtr(i,j,k,nz)*   &
                                                       solarflux_p(i,j) 
                    ufswband(i,j,k,nz) = sumre(i,j,k,nz)*      &
                                                       solarflux_p(i,j)
                  end do
                end do
              end do
            endif
 
!----------------------------------------------------------------------
!    sum the band fluxes and heating rates to calculate the total       
!    spectral values.                                                  
!------------------------------------------------------------------
            do k = KSRAD,KERAD+1
              do j=JSRAD,JERAD
                do i=ISRAD,IERAD
                  if (daylight(i,j) ) then
                    Sw_output%dfsw (i,j,k,nz) =   &
                       Sw_output%dfsw(i,j,k,nz) + sumtr(i,j,k,nz)*&
                                                       solarflux_p(i,j)
                    Sw_output%ufsw (i,j,k,nz) =   &
                       Sw_output%ufsw(i,j,k,nz) + sumre(i,j,k,nz)*  &
                                                       solarflux_p(i,j)
                    fswband(i,j,k,nz) = ((sumre(i,j,k,nz)*  &
                                          solarflux_p(i,j)) - &
                                         (sumtr(i,j,k,nz)*    &
                                                      solarflux_p(i,j)))
                    Sw_output%fsw(i,j,k,nz) = Sw_output%fsw(i,j,k,nz) +&
                                                      fswband(i,j,k,nz)
                  endif
                end do
              end do
            end do
 
            do j=JSRAD,JERAD
              do i=ISRAD,IERAD
                if (daylight(i,j) ) then
                  Sw_output%dfsw_dir_sfc(i,j,nz) =   &
                            Sw_output%dfsw_dir_sfc(i,j,nz) +   &
                              sumtr_dir(i,j,KERAD+1,nz)*solarflux_p(i,j)
                  Sw_output%ufsw_dif_sfc(i,j,nz) =   &
                             Sw_output%ufsw_dif_sfc(i,j,nz) +   &
                                 sumre(i,j,KERAD+1,nz)*solarflux_p(i,j)
                endif
              end do
            end do

            if (nband > NIRBANDS) then
              do j=JSRAD,JERAD
                do i=ISRAD,IERAD
                  if (daylight(i,j) ) then
                    Sw_output%dfsw_vis_sfc(i,j,nz) =   &
                          Sw_output%dfsw_vis_sfc(i,j,nz) +   &
                                sumtr(i,j,KERAD+1,nz)*solarflux_p(i,j)
                    Sw_output%ufsw_vis_sfc(i,j,nz) =   &
                           Sw_output%ufsw_vis_sfc(i,j,nz) +   &
                                 sumre(i,j,KERAD+1,nz)*solarflux_p(i,j)
                    Sw_output%dfsw_vis_sfc_dir(i,j,nz) =   &
                            Sw_output%dfsw_vis_sfc_dir(i,j,nz) +   &
                              sumtr_dir(i,j,KERAD+1,nz)*solarflux_p(i,j)
                    Sw_output%ufsw_vis_sfc_dif(i,j,nz) =   &
                             Sw_output%ufsw_vis_sfc_dif(i,j,nz) +   &
                                 sumre(i,j,KERAD+1,nz)*solarflux_p(i,j)
                  endif
                end do
              end do
            endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
            do k = KSRAD,KERAD
              do j=JSRAD,JERAD
                do i=ISRAD,IERAD
                  if (daylight(i,j) ) then
                    hswband(i,j,k,nz) = (fswband(i,j,k+1,nz) -    &
                                      fswband(i,j,k,nz) )*gocpdp(i,j,k)
                    Sw_output%hsw(i,j,k,nz) =    &
                          Sw_output%hsw(i,j,k,nz) + hswband(i,j,k,nz)
                  endif
                end do
              end do
            end do

!----------------------------------------------------------------------
!    calculate the band fluxes and heating rates.                       
!---------------------------------------------------------------------
            if (nprofile == 1) then  ! clr sky need be done only for 
                                     ! first cloud profile
              if (Rad_control%do_totcld_forcing) then
                do j=JSRAD,JERAD
                  do i=ISRAD,IERAD
                    if (daylight(i,j) ) then
                      Sw_output%dfsw_dir_sfc_clr(i,j,nz) =   &
                         Sw_output%dfsw_dir_sfc_clr(i,j,nz) +   &
                          sumtr_dir_clr(i,j,KERAD+1,nz)*solarflux_p(i,j)
                    endif
                  end do
                end do
                if (nband > NIRBANDS) then
                  do j=JSRAD,JERAD
                    do i=ISRAD,IERAD
                      if (daylight(i,j) ) then
                        Sw_output%dfsw_vis_sfc_clr(i,j,nz) =   &
                           Sw_output%dfsw_vis_sfc_clr(i,j,nz) +   &
                              sumtrclr(i,j,KERAD+1,nz)*solarflux_p(i,j)
                      endif
                    end do
                  end do
                endif
                if (nband == Solar_spect%visible_band_indx) then
                  Sw_output%bdy_flx_clr(:,:,1,nz) =      &
                           sumreclr(:,:,1,nz)*solarflux_p(:,:)
                  Sw_output%bdy_flx_clr(:,:,3,nz) =    &
                          sumtrclr(:,:,KERAD+1,nz)*solarflux_p(:,:) - &
                          sumreclr(:,:,KERAD+1,nz)*solarflux_p(:,:) 
                endif
                if (nband == onepsix_band_indx) then
                  Sw_output%bdy_flx_clr(:,:,2,nz) =    &
                          sumreclr(:,:,1,nz)*solarflux_p(:,:)
                  Sw_output%bdy_flx_clr(:,:,4,nz) =    &
                         sumtrclr(:,:,KERAD+1,nz)*solarflux_p(:,:)  -  &
                         sumreclr(:,:,KERAD+1,nz)*solarflux_p(:,:) 
                endif
          
                if (do_esfsw_band_diagnostics) then
                  do k = KSRAD,KERAD+1
                    do j=JSRAD,JERAD
                      do i=ISRAD,IERAD
                        dfswbandclr(i,j,k,nz) =     &
                                   sumtrclr(i,j,k,nz)*solarflux_p(i,j)
                        ufswbandclr(i,j,k,nz) =    &
                                   sumreclr(i,j,k,nz)*solarflux_p(i,j)
                      end do
                    end do
                  end do
                endif

!----------------------------------------------------------------------c
!    sum the band fluxes and heating rates to calculate the total     
!    spectral values.                                                 
!----------------------------------------------------------------------c
                do k = KSRAD,KERAD+1
                  do j=JSRAD,JERAD
                    do i=ISRAD,IERAD
                      Sw_output%dfswcf(i,j,k,nz) =    &
                              Sw_output%dfswcf(i,j,k,nz) +  &
                                    sumtrclr(i,j,k,nz)*solarflux_p(i,j)
                      Sw_output%ufswcf(i,j,k,nz) =      &
                              Sw_output%ufswcf(i,j,k,nz) +  &
                                    sumreclr(i,j,k,nz)*solarflux_p(i,j)
                      fswbandclr(i,j,k,nz) =    &
                            (sumreclr(i,j,k,nz)*solarflux_p(i,j)) - &
                            (sumtrclr(i,j,k,nz)*solarflux_p(i,j))
                      Sw_output%fswcf(i,j,k,nz) =    &
                                    Sw_output%fswcf(i,j,k,nz) +    &
                                                  fswbandclr(i,j,k,nz)
                    end do
                  end do
                end do

!----------------------------------------------------------------------c
!    sum the band fluxes and heating rates to calculate the total    
!    spectral values.                                               
!----------------------------------------------------------------------c
                do k = KSRAD,KERAD
                  do j=JSRAD,JERAD
                    do i=ISRAD,IERAD
                      hswbandclr(i,j,k,nz) =    &
                                (fswbandclr(i,j,k+1,nz) -      &
                                    fswbandclr(i,j,k,nz))*gocpdp(i,j,k)
                      Sw_output%hswcf(i,j,k,nz) =   &
                                   Sw_output%hswcf(i,j,k,nz) +    &
                                                   hswbandclr(i,j,k,nz)
                    end do
                  end do
                end do
              endif
            endif ! (nprofile == 1)
          end do ! (nz loop)
        end do   ! (end of band loop)
      end do   ! (end of nprofile loop)

!----------------------------------------------------------------------
!    if the ica calculation was being done, the fluxes and heating rates
!    which have been summed over nprofiles cloud profiles must be 
!    averaged.
!------------------------------------------------------------------
      if (do_ica_calcs) then
        do j=JSRAD,JERAD
          do i=ISRAD,IERAD
            Sw_output%dfsw_dir_sfc (i,j,:) =   &
                      Sw_output%dfsw_dir_sfc(i,j,:)*profiles_inverse
            Sw_output%ufsw_dif_sfc (i,j,:) =   &
                      Sw_output%ufsw_dif_sfc(i,j,:)*profiles_inverse
            Sw_output%dfsw_vis_sfc (i,j,:) =   &
                      Sw_output%dfsw_vis_sfc(i,j,:)*profiles_inverse
            Sw_output%ufsw_vis_sfc (i,j,:) =   &
                      Sw_output%ufsw_vis_sfc(i,j,:)*profiles_inverse
            Sw_output%dfsw_vis_sfc_dir (i,j,:) =   &
                      Sw_output%dfsw_vis_sfc_dir(i,j,:)*profiles_inverse
            Sw_output%ufsw_vis_sfc_dif (i,j,:) =   &
                      Sw_output%ufsw_vis_sfc_dif(i,j,:)*profiles_inverse
            Sw_output%bdy_flx(i,j,:,:) =  &
                      Sw_output%bdy_flx(i,j,:,:)*profiles_inverse
          end do
        end do
        do k = KSRAD,KERAD+1
          do j=JSRAD,JERAD
            do i=ISRAD,IERAD
              Sw_output%dfsw (i,j,k,:) = Sw_output%dfsw(i,j,k,:)*  &
                                       profiles_inverse
              Sw_output%ufsw (i,j,k,:) = Sw_output%ufsw(i,j,k,:)*  &
                                       profiles_inverse
              Sw_output%fsw(i,j,k,:) = Sw_output%fsw(i,j,k,:)*  &
                                     profiles_inverse
            end do
          end do
        end do
        do k = KSRAD,KERAD
          do j=JSRAD,JERAD
            do i=ISRAD,IERAD
              Sw_output%hsw(i,j,k,:) = Sw_output%hsw(i,j,k,:)*  &
                                       profiles_inverse
            end do
          end do
        end do
      endif

      do j=JSRAD,JERAD
        do i=ISRAD,IERAD
          if (daylight(i,j) ) then
            Sw_output%dfsw_dif_sfc(i,j,: ) =   &
                              Sw_output%dfsw(i,j,KERAD+1,: ) -   &
                                      Sw_output%dfsw_dir_sfc(i,j,: )
          endif
        end do
      end do

      if (Rad_control%do_totcld_forcing) then
        do j=JSRAD,JERAD
          do i=ISRAD,IERAD
            if (daylight(i,j) ) then
              Sw_output%dfsw_dif_sfc_clr(i,j,: ) =   &
                                Sw_output%dfswcf(i,j,KERAD+1,:) -   &
                                Sw_output%dfsw_dir_sfc_clr(i,j,:)
            endif
          end do
        end do
      endif

      do j=JSRAD,JERAD
        do i=ISRAD,IERAD
          if (daylight(i,j) ) then
            Sw_output%dfsw_vis_sfc_dif(i,j,:) =   &
                                Sw_output%dfsw_vis_sfc(i,j,:) -   &
                                Sw_output%dfsw_vis_sfc_dir(i,j,:) 
          endif
        end do
      end do

!--------------------------------------------------------------------
!    convert sw fluxes to cgs and then back to  mks units.
!---------------------------------------------------------------------
      Sw_output%fsw(:,:,:,:) =     &
                            1.0E-03*(1.0E+03*Sw_output%fsw(:,:,:,:))
      Sw_output%dfsw(:,:,:,:) =    &
                            1.0E-03*(1.0E+03*Sw_output%dfsw(:,:,:,:))
      Sw_output%ufsw(:,:,:,:) =     &
                            1.0E-03*(1.0E+03*Sw_output%ufsw(:,:,:,:))
      if (Rad_control%do_totcld_forcing) then
        Sw_output%fswcf(:,:,:,:) =   &
                            1.0E-03*(1.0E+03*Sw_output%fswcf(:,:,:,:))
        Sw_output%dfswcf(:,:,:,:) =     &
                            1.0E-03*(1.0E+03*Sw_output%dfswcf(:,:,:,:))
        Sw_output%ufswcf(:,:,:,:) =     &
                            1.0E-03*(1.0E+03*Sw_output%ufswcf(:,:,:,:))
      endif

!---------------------------------------------------------------------


end subroutine swresf



!####################################################################

subroutine esfsw_driver_end

!---------------------------------------------------------------------
!    esfsw_driver_end is the destructor for esfsw_driver_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('esfsw_driver_mod',   &
              'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    close out the modules that this module initialized.
!--------------------------------------------------------------------
      call esfsw_parameters_end

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------

end subroutine esfsw_driver_end




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#################################################################
! <SUBROUTINE NAME="compute_aerosol_optical_props">
!  <OVERVIEW>
!   Subroutine that uses the delta-eddington technique in conjunction
!   with a multi-band parameterization for h2o+co2+o2+o3 absorption
!   in the solar spectrum to derive solar fluxes and heating rates.
!  </OVERVIEW>
!  <DESCRIPTION>
!    This subroutine calculates optical depth, single scattering albedo,
!    asymmetry parameter of a layer based on gaseous absorbers,
!    clouds, aerosols, and rayleigh scattering. It then uses delta-
!    eddington technique to calculate radiative flux at each layer. 
!    Doubling and adding technique is used to combine the layers
!    and calculate flux at TOA and surface and heating rate. This
!    subroutine allocates a substantial amount of memory and deallocates
!    the allocated memory at the end of the subroutine.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call comput(is, ie, js, je, Atmos_input, Surface, Rad_gases, Aerosol, 
!               Astro, &
!               Cldrad_props, Cld_spec, Sw_output)
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!    starting subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!    ending subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!    starting subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="je" TYPE="integer">
!    ending subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    Atmos_input_type variable containing the atmospheric
!    input fields on the radiation grid 
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol input data for shortwave radiation calculation
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!    Astronomy_type variable containing the astronomical
!    input fields on the radiation grid  
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!    Radiative_gases_type variable containing the radiative 
!    gas input fields on the radiation grid 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!    The cloud radiative property input fields on the
!    radiation grid
!  </IN>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!    The shortwave radiation calculation result
!  </INOUT>
!  <IN NAME="Surface" TYPE="surface_type">
!   Surface data as boundary condition to radiation
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud specification data as initial condition to radiation
!  </IN>
! </SUBROUTINE>

subroutine compute_aerosol_optical_props    &
          (Atmos_input, Aerosol, Aerosol_props, including_volcanoes,  &
           Aerosol_diags, r, including_aerosols, naerosol_optical, &
           daylight, aeroextopdep, aerosctopdep, aeroasymfac)

!----------------------------------------------------------------------
!    comput uses the delta-eddington technique in conjunction with a    
!    multiple-band parameterization for h2o+co2+o2+o3 absorption to   
!    derive solar fluxes and heating rates.                             
!    notes: drops are assumed if temp>273.15K, ice crystals otherwise.
!-------------------------------------------------------------------

type(atmos_input_type),        intent(in)    :: Atmos_input
type(aerosol_type),            intent(in)    :: Aerosol     
type(aerosol_properties_type), intent(in)    :: Aerosol_props
logical,                       intent(in)    :: including_volcanoes
type(aerosol_diagnostics_type),intent(inout) :: Aerosol_diags
real,dimension(:,:,:,:),       intent(inout) :: r
logical,                       intent(in)    :: including_aerosols  
integer,                       intent(in)    :: naerosol_optical
logical,dimension(:,:),        intent(in)    :: daylight
real, dimension(:,:,:,:),      intent(out)   :: aeroextopdep, &
                                                aerosctopdep, &
                                                aeroasymfac 


!-------------------------------------------------------------------
!  intent(in) variables:
!
!      Atmos_input    atmos_input_type structure, contains variables
!                     defining atmospheric state
!      Aerosol        aerosol_type structure, contains variables
!                     defining aerosol fields, passed through to
!                     lower level routines
!      Aerosol_props  aerosol radiative property input data for the 
!                     radiation package
!                                                                 
!   intent(inout) variables:
!
!      Sw_output         shortwave radiation output data
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!     local variables:
 
      real, dimension (size(Atmos_input%temp,3)-1)  :: &
                      arprod, asymm,   arprod2,      deltaz, &     
                      sum_g_omega_tau, sum_ext,      sum_sct

      integer, dimension (size (Atmos_input%press, 3)-1 ) ::   &
                      opt_index_v3, opt_index_v4, &
                      opt_index_v5, opt_index_v6, &
                      opt_index_v7, opt_index_v8, &
                      opt_index_v9, opt_index_v10, &
                      irh

      real, dimension (naerosol_optical)   ::            &
                      aerext,          aerssalb,       aerasymm

      real        :: aerext_i, aerssalb_i, aerasymm_i
      integer     :: j, i, k, nband, nsc
      integer     :: israd, jsrad, ierad, jerad, ksrad, kerad
      integer     :: nextinct  !variable to pass extinction to chemistry

!-----------------------------------------------------------------------
!     local variables:
!
!       aeramt
!       sum_g_omega_tau
!       opt_index_v3
!       irh
!    etc.
!
!--------------------------------------------------------------------


!--------------------------------------------------------------------
!    define limits and dimensions 
!--------------------------------------------------------------------
      israd = 1
      jsrad = 1
      ksrad = 1
      ierad = size(Atmos_input%temp,1)
      jerad = size(Atmos_input%temp,2)
      kerad = size(Atmos_input%temp,3) - 1

      naerosoltypes_used = size(Aerosol%aerosol,4)

      do j = JSRAD,JERAD
        do i = ISRAD,IERAD
          if (daylight(i,j) .or. Sw_control%do_cmip_diagnostics) then
            deltaz(:) = Atmos_input%deltaz(i,j,:)

            do nband = 1,Solar_spect%nbands
              if (including_aerosols) then                           
                aerext(:) = Aerosol_props%aerextband(nband,:)
                aerssalb(:) = Aerosol_props%aerssalbband(nband,:)
                aerasymm(:) = Aerosol_props%aerasymmband(nband,:)

!-------------------------------------------------------------------
!    define the local variables for the band values of aerosol and 
!    cloud single scattering parameters.                               
!    note: the unit for the aerosol extinction is kilometer**(-1).     
!--------------------------------------------------------------------
                do k = KSRAD,KERAD
                  irh(k) = MIN(100, MAX( 0,     &
                      NINT(100.*Atmos_input%aerosolrelhum(i,j,k))))
                  opt_index_v3(k) = &
                              Aerosol_props%sulfate_index (irh(k), &
                                            Aerosol_props%ivol(i,j,k))
                  opt_index_v4(k) =    &
                              Aerosol_props%omphilic_index( irh(k) )
                  opt_index_v5(k) =    &
                              Aerosol_props%bcphilic_index( irh(k) )
                  opt_index_v6(k) =    &
                              Aerosol_props%seasalt1_index( irh(k) )
                  opt_index_v7(k) =    &
                              Aerosol_props%seasalt2_index( irh(k) )
                  opt_index_v8(k) =    &
                              Aerosol_props%seasalt3_index( irh(k) )
                  opt_index_v9(k) =    &
                              Aerosol_props%seasalt4_index( irh(k) )
                  opt_index_v10(k) =    &
                              Aerosol_props%seasalt5_index( irh(k) )
                end do

!---------------------------------------------------------------------
!    calculate scattering properties for all aerosol constituents 
!    combined.
!---------------------------------------------------------------------
                do k = KSRAD,KERAD
                  sum_g_omega_tau(k) = 0.0
                  sum_ext(k) = 0.
                  sum_sct(k) = 0.
                end do
                do nsc = 1,NAEROSOLTYPES_USED
                  if (Aerosol_props%optical_index(nsc) > 0) then
                    aerext_i =     &
                            aerext(Aerosol_props%optical_index(nsc))
                    aerssalb_i =     &
                            aerssalb(Aerosol_props%optical_index(nsc))
                    aerasymm_i =     &
                            aerasymm(Aerosol_props%optical_index(nsc))
                    do k = KSRAD,KERAD
                      arprod(k) =    &
                            aerext_i*(1.e3*Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb_i*arprod(k)
                      asymm(k)   = aerasymm_i
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) + aerssalb_i*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +     &
                                      aerasymm_i*(aerssalb_i*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                                     Aerosol_props%sulfate_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v3(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v3(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v3(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) +    &
                                    aerssalb(opt_index_v3(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +  &
                               aerasymm(opt_index_v3(k))*  &
                                   (aerssalb(opt_index_v3(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                                     Aerosol_props%bc_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v3(k)) *    &
                                    (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v3(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v3(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) +       &
                                    aerssalb(opt_index_v3(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) + &
                               aerasymm(opt_index_v3(k)) * &
                                   (aerssalb(opt_index_v3(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                               Aerosol_props%omphilic_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v4(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v4(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v4(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v4(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +   &
                               aerasymm(opt_index_v4(k))*     &
                                  (aerssalb(opt_index_v4(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                                  Aerosol_props%bcphilic_flag) then
                    if (Rad_control%using_im_bcsul) then
                      do k = KSRAD,KERAD
                        arprod(k) = aerext(opt_index_v3(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                        arprod2(k) = aerssalb(opt_index_v3(k))*arprod(k)
                        asymm(k)   = aerasymm(opt_index_v3(k))
                        sum_ext(k) = sum_ext(k) + arprod(k)
                        sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v3(k))*arprod(k)
                        sum_g_omega_tau(k) = sum_g_omega_tau(k) +  &
                               aerasymm(opt_index_v3(k)) * &
                                  (aerssalb(opt_index_v3(k))*arprod(k))
                      end do
                    else  ! (using_im_bcsul)
                      do k = KSRAD,KERAD
                        arprod(k) = aerext(opt_index_v5(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                        arprod2(k) = aerssalb(opt_index_v5(k))*arprod(k)
                        asymm(k)   = aerasymm(opt_index_v5(k))
                        sum_ext(k) = sum_ext(k) + arprod(k)
                        sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v5(k))*arprod(k)
                        sum_g_omega_tau(k) = sum_g_omega_tau(k) +  &
                              aerasymm(opt_index_v5(k)) * &
                                 (aerssalb(opt_index_v5(k))*arprod(k))
                      end do
                    endif  !(using_im_bcsul)
                  else if (Aerosol_props%optical_index(nsc) == &
                                Aerosol_props%seasalt1_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v6(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v6(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v6(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v6(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +  &
                                aerasymm(opt_index_v6(k)) * &
                                  (aerssalb(opt_index_v6(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                              Aerosol_props%seasalt2_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v7(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v7(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v7(k))
                      sum_ext(k) = sum_ext(k) +  arprod(k)
                      sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v7(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) + &
                               aerasymm(opt_index_v7(k)) * &
                                 (aerssalb(opt_index_v7(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                               Aerosol_props%seasalt3_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v8(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v8(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v8(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v8(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +  &
                              aerasymm(opt_index_v8(k)) * &
                                  (aerssalb(opt_index_v8(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                               Aerosol_props%seasalt4_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v9(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v9(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v9(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) + &
                                     aerssalb(opt_index_v9(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +  &
                                aerasymm(opt_index_v9(k))*  &
                                   (aerssalb(opt_index_v9(k))*arprod(k))
                    end do
                  else if (Aerosol_props%optical_index(nsc) == &
                             Aerosol_props%seasalt5_flag) then
                    do k = KSRAD,KERAD
                      arprod(k) = aerext(opt_index_v10(k)) *    &
                                   (1.e3 * Aerosol%aerosol(i,j,k,nsc))
                      arprod2(k) = aerssalb(opt_index_v10(k))*arprod(k)
                      asymm(k)   = aerasymm(opt_index_v10(k))
                      sum_ext(k) = sum_ext(k) + arprod(k)
                      sum_sct(k) = sum_sct(k) + &
                                    aerssalb(opt_index_v10(k))*arprod(k)
                      sum_g_omega_tau(k) = sum_g_omega_tau(k) +&
                              aerasymm(opt_index_v10(k)) * &
                                 (aerssalb(opt_index_v10(k))*arprod(k))
                    end do
                  endif

                  if (Sw_control%do_cmip_diagnostics) then
                    if (nband == Solar_spect%visible_band_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,1) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,1) =    &
                                            arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,1) = asymm(:)
                    endif
                    if (nband == Solar_spect%eight70_band_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,6) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,6) =    &
                                            arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,6) = asymm(:)
                    endif
                    if (nband == Solar_spect%one_micron_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,2) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,2) =    &
                                               arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,2) = asymm(:)
                    endif
                    if (nband == Solar_spect%w340_band_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,7) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,7) =    &
                                                arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,7) = asymm(:)
                    endif
                    if (nband == Solar_spect%w380_band_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,8) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,8) =    &
                                                arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,8) = asymm(:)
                    endif
                    if (nband == Solar_spect%w440_band_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,9) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,9) =    &
                                               arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,9) = asymm(:)
                    endif
                    if (nband == Solar_spect%w670_band_indx) then
                      Aerosol_diags%extopdep(i,j,:,nsc,10) = arprod(:)
                      Aerosol_diags%absopdep(i,j,:,nsc,10) =    &
                                                arprod(:) - arprod2(:)
                      Aerosol_diags%asymdep(i,j,:,nsc,10) = asymm(:)
                    endif
                  endif
                end do

!----------------------------------------------------------------------
!    add the effects of volcanic aerosols, if they are to be included.
!    include generation of diagnostics in the visible (0.55 micron) and
!    nir band (1.0 micron).
!----------------------------------------------------------------------
                if (including_volcanoes) then
                  do k = KSRAD,KERAD
                    sum_ext(k) = sum_ext(k) +    &
                                 Aerosol_props%sw_ext(i,j,k,nband)*  &
                                 deltaz(k)
                    sum_sct(k) = sum_sct(k) +    &
                                 Aerosol_props%sw_ssa(i,j,k,nband)*  &
                                 Aerosol_props%sw_ext(i,j,k,nband)*  &
                                 deltaz(k)
                    sum_g_omega_tau(k) =   &
                                 sum_g_omega_tau(k) +&
                                 Aerosol_props%sw_asy(i,j,k,nband)* &
                                 Aerosol_props%sw_ssa(i,j,k,nband)*  &
                                 Aerosol_props%sw_ext(i,j,k,nband)*  &
                                 deltaz(k)
                    if (Sw_control%do_cmip_diagnostics) then
                      if (nband == Solar_spect%visible_band_indx) then
                           Aerosol_diags%extopdep_vlcno(i,j,k,1) =   &
                                 Aerosol_props%sw_ext(i,j,k,nband)*  &
                                 deltaz(k)
                           Aerosol_diags%absopdep_vlcno(i,j,k,1) =   &
                            (1.0 - Aerosol_props%sw_ssa(i,j,k,nband))*&
                                Aerosol_props%sw_ext(i,j,k,nband)*  &
                                deltaz(k)
                      endif
                      if (nband == Solar_spect%eight70_band_indx) then
                           Aerosol_diags%extopdep_vlcno(i,j,k,3) =   &
                                 Aerosol_props%sw_ext(i,j,k,nband)*  &
                                 deltaz(k)
                           Aerosol_diags%absopdep_vlcno(i,j,k,3) =   &
                            (1.0 - Aerosol_props%sw_ssa(i,j,k,nband))*&
                                Aerosol_props%sw_ext(i,j,k,nband)*  &
                                deltaz(k)
                      endif
                      if (nband == Solar_spect%one_micron_indx) then
                           Aerosol_diags%extopdep_vlcno(i,j,k,2) =   &
                                 Aerosol_props%sw_ext(i,j,k,nband)*  &
                                 deltaz(k)
                           Aerosol_diags%absopdep_vlcno(i,j,k,2) =   &
                            (1.0 - Aerosol_props%sw_ssa(i,j,k,nband))*&
                                Aerosol_props%sw_ext(i,j,k,nband)*  &
                                deltaz(k)
                      endif
                    endif
                  end do
                endif   ! (including_volcanoes)
!
!----------------------------------------------------------------------
                do k = KSRAD,KERAD
                  aeroextopdep(i,j,k,nband) = sum_ext(k) 
                  aerosctopdep(i,j,k,nband) = sum_sct(k) 
                  aeroasymfac(i,j,k,nband) = sum_g_omega_tau(k) / &
                                                (sum_sct(k) + 1.0e-30 )
                end do
              else  ! (if not including_aerosols)
                do k = KSRAD,KERAD
                  aeroextopdep(i,j,k,nband) = 0.0                    
                  aerosctopdep(i,j,k,nband) = 0.0                  
                  aeroasymfac(i,j,k,nband) = 0.0                 
                end do
              endif ! (including_aerosols)
            end do ! (nband)
          endif  ! (daylight or cmip_diagnostics)

          if (including_volcanoes) then
            if (do_coupled_stratozone ) then
              nextinct = get_tracer_index(MODEL_ATMOS,'Extinction')
              if (nextinct  /= NO_TRACER) &
                    r(i,j,:,nextinct) = Aerosol_props%sw_ext(i,j,:,4)
            endif  
          endif  

        end do ! (i loop)
      end do   ! (j loop)

!---------------------------------------------------------------------
!

!---------------------------------------------------------------------


end subroutine compute_aerosol_optical_props

!#################################################################
! <SUBROUTINE NAME="compute_gas_props">
!  <OVERVIEW>
!   Subroutine that uses the delta-eddington technique in conjunction
!   with a multi-band parameterization for h2o+co2+o2+o3 absorption
!   in the solar spectrum to derive solar fluxes and heating rates.
!  </OVERVIEW>
!  <DESCRIPTION>
!    This subroutine calculates optical depth, single scattering albedo,
!    asymmetry parameter of a layer based on gaseous absorbers,
!    clouds, aerosols, and rayleigh scattering. It then uses delta-
!    eddington technique to calculate radiative flux at each layer. 
!    Doubling and adding technique is used to combine the layers
!    and calculate flux at TOA and surface and heating rate. This
!    subroutine allocates a substantial amount of memory and deallocates
!    the allocated memory at the end of the subroutine.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call comput(is, ie, js, je, Atmos_input, Surface, Rad_gases, Aerosol, 
!               Astro, &
!               Cldrad_props, Cld_spec, Sw_output)
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!    starting subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!    ending subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!    starting subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="je" TYPE="integer">
!    ending subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    Atmos_input_type variable containing the atmospheric
!    input fields on the radiation grid 
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol input data for shortwave radiation calculation
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!    Astronomy_type variable containing the astronomical
!    input fields on the radiation grid  
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!    Radiative_gases_type variable containing the radiative 
!    gas input fields on the radiation grid 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!    The cloud radiative property input fields on the
!    radiation grid
!  </IN>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!    The shortwave radiation calculation result
!  </INOUT>
!  <IN NAME="Surface" TYPE="surface_type">
!   Surface data as boundary condition to radiation
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud specification data as initial condition to radiation
!  </IN>
! </SUBROUTINE>

subroutine compute_gas_props (Atmos_input, Rad_gases, Astro,   &
                              daylight, gasopdep)

!----------------------------------------------------------------------
!    comput uses the delta-eddington technique in conjunction with a    
!    multiple-band parameterization for h2o+co2+o2+o3 absorption to   
!    derive solar fluxes and heating rates.                             
!    notes: drops are assumed if temp>273.15K, ice crystals otherwise.
!-------------------------------------------------------------------

type(atmos_input_type),        intent(in)    :: Atmos_input
type(radiative_gases_type),    intent(in)    :: Rad_gases   
type(astronomy_type),          intent(in)    :: Astro
logical, dimension(:,:),       intent(in)    :: daylight
real, dimension(:,:,:,:,:),    intent(out)   :: gasopdep              


!-------------------------------------------------------------------
!  intent(in) variables:
!
!      Atmos_input    atmos_input_type structure, contains variables
!                     defining atmospheric state
!      Rad_gases      radiative_gases_type structure, contains var-
!                     iables defining the radiatively active gases, 
!                     passed through to lower level routines
!      Astro          astronomy_type structure
!                                                                 
!   intent(inout) variables:
!
!      Sw_output         shortwave radiation output data
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!     local variables:
 

      real, dimension (size(Atmos_input%temp,3)-1)  :: &
                   deltaz,     qo3,         rh2o,                    &
                   efftauo2,   efftauco2,   efftauch4,   efftaun2o, &
                   wh2ostr,    wo3,         wo2,         quenchfac, &
                   opdep,      delpdig,     deltap,      tco2,    &
                   tch4,       tn2o,        to2,         wh2o

           
      real, dimension (size(Atmos_input%temp,3))  :: &
            alphaco2,        alphaco2str,    alphao2,          &
            alphao2str,      alphach4,       alphach4str,      &
            alphan2o,        alphan2ostr,    scale,            &
            scalestr,        totco2,         totco2str,        &
            toto2,           toto2str,       totch4,           &
            totch4str,       totn2o,         totn2ostr,        &
            press,           pflux,          pflux_mks,        &
            temp,            z

      real :: cosangsolar
      real :: denom
      real :: wtquench
      real :: rrvco2 
      real :: rrvch4, rrvn2o

      integer  :: j, i, k, ng, nband, kq
      integer  :: np, nf
      integer  :: israd, jsrad, ierad, jerad, ksrad, kerad


!-----------------------------------------------------------------------
!     local variables:
!
!       aeramt
!       sum_g_omega_tau
!       opt_index_v3
!       irh
!    etc.
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    define limits and dimensions 
!--------------------------------------------------------------------
      israd = 1
      jsrad = 1
      ksrad = 1
      ierad = size(Atmos_input%temp,1)
      jerad = size(Atmos_input%temp,2)
      kerad = size(Atmos_input%temp,3) - 1

!---------------------------------------------------------------------
!    initialize local variables.                                        
!------------------------------------------------------------------
      alphaco2   (1) = 0.0
      alphaco2str(1) = 0.0
      alphao2    (1) = 0.0
      alphao2str (1) = 0.0
      alphach4   (1) = 0.0
      alphach4str(1) = 0.0
      alphan2o   (1) = 0.0
      alphan2ostr(1) = 0.0

      rrvco2 = Rad_gases%rrvco2
      rrvch4 = Rad_gases%rrvch4
      rrvn2o = Rad_gases%rrvn2o

      do j = JSRAD,JERAD
        do i = ISRAD,IERAD
          if ( daylight(i,j) ) then

!---------------------------------------------------------------------
!  convert to cgs and then back to mks for consistency with previous 
!---------------------------------------------------------------------
            do k = KSRAD,KERAD+1
              press(k) = 0.1*(10.0*Atmos_input%press(i,j,k))
              pflux(k) =     (10.0*Atmos_input%pflux(i,j,k))
              temp (k) = Atmos_input%temp  (i,j,k)
            end do
            do k = KSRAD,KERAD
              rh2o  (k) = Atmos_input%rh2o  (i,j,k)
              qo3   (k) = Rad_gases%qo3(i,j,k)
              deltaz(k) = Atmos_input%deltaz(i,j,k)
            end do

!----------------------------------------------------------------------c
!    define pressure related quantities, pressure is in mks units. 
!----------------------------------------------------------------------c
            pflux_mks(:) = pflux(:)*1.0E-1

            do k = KSRAD+1,KERAD+1
              deltap(k-1) = pflux_mks(k) - pflux_mks(k-1)
              delpdig(k-1) = deltap(k-1)/ GRAV
              scalestr(k) = pflux_mks(k) 
              scale(k) = scalestr(k)*pflux_mks(k)/pstd_mks
            end do
 

            do k = KSRAD,KERAD
              wh2ostr(k) = rh2o(k)*delpdig(k)
              wo3(k)     = qo3(k)*delpdig(k)
              wo2(k) = o2mixrat*(WTMO2/WTMAIR)*delpdig(k)
            end do
  
!---------------------------------------------------------------------
!    if quenching factor effects are desired, calculate the height above
!    the surface of the model flux levels.
!---------------------------------------------------------------------
            if (do_quench) then
              z(KERAD+1) = 0.0
              do k = KERAD,KSRAD,-1
                z(k) = z(k+1) + deltaz(k)
              end do
          
!---------------------------------------------------------------------
!    define the quenching factor for each grid point.
!---------------------------------------------------------------------
              do k = KSRAD,KERAD
                if (z(k) < co2_quenchfac_height(1) ) then
                  quenchfac(k) = 1.0
                else if (z(k) > co2_quenchfac_height(30) ) then 
                  quenchfac(k) = 0.037
                else
                  do kq = 1,29
                    if (z(k) > co2_quenchfac_height(kq) .and. &
                        z(k) <= co2_quenchfac_height(kq+1)) then
                      wtquench = (z(k) - co2_quenchfac_height(kq))/ &
                                 (co2_quenchfac_height(kq+1) - &
                                  co2_quenchfac_height(kq))
                      quenchfac(k) = (1. - wtquench)*   &
                                           co2_quenchfac(kq) +   &
                                      wtquench*co2_quenchfac(kq+1)
                      exit
                    endif
                  end do
                endif
              end do
            else
              quenchfac(:) = 1.0
            endif !(do_quench)


            do ng = 1,NSOLWG
              cosangsolar  = Astro%cosz(i,j)
              if (cosangsolar == 0.0) cosangsolar = 1.0

!----------------------------------------------------------------------c
!    define the scaled and unscaled co2 and o2 pathlengths in 
!    centimeter-atm, and the unscaled h2o and o3 amounts in   
!    kgrams/meter**2. 
!    cm-atm needed as units because of c2co2 having those units.
!----------------------------------------------------------------------c
              denom = 1.0/(GRAV*rhoair*cosangsolar*2.0)
              do k = KSRAD+1,KERAD+1
                totco2(k) = 1.0E+02*rrvco2*scale(k)*denom       
                totco2str(k) = 2.0E+02*rrvco2*scalestr(k)*denom     
                toto2(k) = 1.0E+02*o2mixrat*scale(k)*denom      
                toto2str(k) = 2.0E+02*o2mixrat*scalestr(k)*denom      
                if (do_ch4_sw_effects) then
                  totch4(k) = 1.0E+02*rrvch4*scale(k)*denom     
                  totch4str(k) = 2.0E+02*rrvch4*scalestr(k)*denom     
                endif
                if (do_n2o_sw_effects) then
                  totn2o(k) = 1.0E+02*rrvn2o*scale(k)*denom     
                  totn2ostr(k) = 2.0E+02*rrvn2o*scalestr(k)*denom      
                endif
              end do

              np = 0
              do nband = 1, NBANDS

!-------------------------------------------------------------------
!    define the h2o scaled gas amounts in kgrams/meter**2            
!---------------------------------------------------------------------
                if (nband <= nh2obands) then
                  do k = KSRAD,KERAD
                    wh2o(k) = rh2o(k)*delpdig(k)*   &
                        exp(powph2o(nband)*alog(press(k)*p0h2o(nband)))
                  end do
 
!---------------------------------------------------------------------
!    calculate the "effective" co2, o2, ch4 and n2o gas optical depths 
!    for the appropriate absorbing bands.                               
!    note: for large zenith angles, alpha can exceed 1. In this case,a
!    the optical depths are set to the previous layer values.          
!-------------------------------------------------------------------
                  if ( c1co2(nband).ne.1.0E-99 ) then
                    do k = KSRAD+1,KERAD+1
                      if (totco2(k) < totco2max(nband) .and.  &
                          totco2str(k) < totco2strmax(nband))  then
                        alphaco2(k) =     &
                             c1co2(nband)*exp(c3co2(nband)* &
                                 alog((totco2(k) + c2co2(nband))))  -  &
                                                          c4co2(nband)
                        alphaco2str(k) = &
                          c1co2str(nband)*exp(c3co2str(nband)*  &
                            alog((totco2str(k) + c2co2str(nband)))) - &
                                                        c4co2str(nband)
                        tco2(k-1) =      &
                             (1.0 - alphaco2(k))*   &
                                            (1.0 - alphaco2str(k))/ &
                             ((1.0 - alphaco2(k-1))*    &
                                            (1.0 - alphaco2str(k-1)))
                        efftauco2(k-1) = -cosangsolar*alog( tco2(k-1))
                      else if (k > KSRAD+1) then
                        efftauco2(k-1) = efftauco2(k-2)
                      else
                        efftauco2(k-1) = 0.0
                      end if
                    end do
                  else    !( c1co2(nband).ne.1.0E-99 ) 
                    efftauco2(:) = 0.0
                  end if  !( c1co2(nband).ne.1.0E-99 ) 

                  if (do_ch4_sw_effects) then
                    if (c1ch4(nband).ne.1.0E-99 ) then
                      do k = KSRAD+1,KERAD+1
                        if (totch4(k) < totch4max(nband) .and.  &
                              totch4str(k) < totch4strmax(nband))  then
                           alphach4(k) =    &
                              c1ch4(nband)*exp(c3ch4(nband)*&
                              alog((totch4(k) + c2ch4(nband))))  -   &
                                                           c4ch4(nband)
                           alphach4str(k) = &
                            c1ch4str(nband)*exp(c3ch4str(nband)*  &
                            alog((totch4str(k) + c2ch4str(nband)))) - &
                                                        c4ch4str(nband)
                           tch4(k-1) = &
                                  (1.0 - alphach4(k))*    &
                                           (1.0 - alphach4str(k))/ &
                                   ((1.0 - alphach4(k-1))*   &
                                           (1.0 - alphach4str(k-1)))
                           efftauch4(k-1) = -cosangsolar*alog(tch4(k-1))
                         else if (k > KSRAD+1) then
                           efftauch4(k-1) = efftauch4(k-2)
                         else
                           efftauch4(k-1) = 0.0
                         end if
                       end do
                     else    !( c1ch4(nband).ne.1.0E-99 )
                       efftauch4(:) = 0.0
                     end if  !( c1ch4(nband).ne.1.0E-99 )
                   else    !do_ch4 = .false.
                     efftauch4(:) = 0.0
                   end if

                   if (do_n2o_sw_effects) then
                     if ( c1n2o(nband).ne.1.0E-99 ) then
                       do k = KSRAD+1,KERAD+1
                         if (totn2o(k) < totn2omax(nband) .and.  &
                              totn2ostr(k) < totn2ostrmax(nband)) then
                           alphan2o(k) = &
                                c1n2o(nband)*exp(c3n2o(nband)* &
                                   alog((totn2o(k) +c2n2o(nband)))) -  &
                                                          c4n2o(nband)
                           alphan2ostr(k) = &
                            c1n2ostr(nband)*exp(c3n2ostr(nband)*  &
                            alog((totn2ostr(k) + c2n2ostr(nband)))) -  &
                                                       c4n2ostr(nband)
                           tn2o(k-1) = &
                                    (1.0 - alphan2o(k)) *  &
                                              (1.0 - alphan2ostr(k))/ &
                                    (( 1.0 - alphan2o(k-1)) *  &
                                            (1.0 - alphan2ostr(k-1)))
                           efftaun2o(k-1) = -cosangsolar*alog(tn2o(k-1))
                         else if (k > KSRAD+1) then
                           efftaun2o(k-1) = efftaun2o(k-2)
                         else
                           efftaun2o(k-1) = 0.0
                         end if
                       end do
                     else    !( c1n2o(nband).ne.1.0E-99 )
                       efftaun2o(:) = 0.0
                     end if  !( c1n2o(nband).ne.1.0E-99 )
                   else  !do_n2o = .false.
                     efftaun2o(:) = 0.0
                   end if

                  if ( c1o2(nband).ne.1.0E-99 ) then
                    do k = KSRAD+1,KERAD+1
                      if (toto2(k) .lt. toto2max(nband) .and.   &
                          toto2str(k) .lt. toto2strmax(nband)) then
                        alphao2(k) = c1o2(nband)*exp( c3o2(nband)* &
                                     alog((toto2(k) + c2o2(nband)))) - &
                                                            c4o2(nband)
                        alphao2str( k) = &
                            c1o2str(nband)*exp(c3o2str(nband)*  &
                                alog((toto2str(k) + c2o2str(nband)))) &
                                                        - c4o2str(nband)
                        to2(k-1) = &
                               (1.0 - alphao2(k))*  &
                                    (1.0 - alphao2str(k) )/ &
                                ((1.0 - alphao2(k-1)) *  &
                                            (1.0 - alphao2str(k-1)))
                        efftauo2(k-1) = -cosangsolar*alog(to2(k-1))
                      else if (k.gt.KSRAD+1) then
                        efftauo2(k-1) = efftauo2(k-2)
                      else
                        efftauo2(k-1) = 0.0
                      end if
                    end do
                  else   !  ( c1o2(nband).ne.1.0E-99 ) 
                    efftauo2(:) = 0.0
                  end if  !  ( c1o2(nband).ne.1.0E-99 ) 
                end if  ! (nband <= nh2obands)
 
!---------------------------------------------------------------------
!    calculate the "effective" o2 gas optical depths for the Schuman- 
!    Runge band.                                                        
!-------------------------------------------------------------------
                if ( nband.EQ.NBANDS ) then
                  do k = KSRAD+1,KERAD+1
                    if ( toto2str(k).lt.toto2strmaxschrun) then
                      alphao2str(k) =  &
                           c1o2strschrun*exp( c3o2strschrun*&
                              alog((toto2str(k) + c2o2strschrun))) - &
                                                       c4o2strschrun
                      to2(k-1) = &
                          (1.0 - alphao2str(k))/(1.0 - alphao2str(k-1)) 
                      efftauo2(k-1) =  -cosangsolar*alog(to2(k-1) )
                      if (do_herzberg) then
                        efftauo2(k-1) = efftauo2(k-1) +     &
                                                 wo2(k-1)*herzberg_fac
                      endif
                    else if (k.gt.KSRAD+1) then
                      efftauo2(k-1) = efftauo2(k-2)
                    else
                      efftauo2(k-1) = 0.0
                    end if
                  end do
                end if

                do nf =1,nfreqpts(nband)
                  np = np + 1

!---------------------------------------------------------------------
!    define the h2o + o3 gas optical depths.                           
!--------------------------------------------------------------------
                  if (strterm(np)) then
                    opdep(:) = kh2o(np)*wh2ostr(:) + ko3(np)*wo3(:)
                  else
                    opdep(:) = kh2o(np)*wh2o(:) + ko3(np)*wo3(:)
                  end if

                  gasopdep(i,j,:,np,ng) =    &
                           opdep(:) + quenchfac(:)*efftauco2(:) +   &
                              efftauo2(:) + efftauch4(:) + efftaun2o(:)

                end do  ! (nf loop)
              end do   ! (nband loop)
            end do  ! (ng loop)
          endif  ! (daylight)
        end do ! (i loop)
      end do ! (j loop)

!---------------------------------------------------------------------



end subroutine compute_gas_props


!#####################################################################
!<SUBROUTINE NAME="adding">
! <OVERVIEW>
!  Subroutine that implements doubling and adding technique to combine
!  multiple atmospheric layers to calculate solar fluxes
! </OVERVIEW>
! <DESCRIPTION>
!  This subroutine implements the standard doubling and adding
!  technique to combine reflectance and transmittance of multiple 
!  atmospheric layers to compute solar flux and heating rate.
! </DESCRIPTION>
! <TEMPLATE>
!  call adding ( ix, jx, kx, &
!                rlayerdir, tlayerdir, rlayerdif, tlayerdif,  &
!                tlayerde, sfcalb, calc_flag, reflectance,   &
!                transmittance)
! </TEMPLATE>
! <IN NAME="ix" TYPE="integer">
!  ix is the current longitudinal index in the physics cell being
!  integrated.
! </IN>
! <IN NAME="jx" TYPE="integer">
!  jx is the current latitudinal index in the physics cell being
!  integrated.
! </IN>
! <IN NAME="kx" TYPE="integer">
!  ix is the current vertical index in the physics cell being
!  integrated.
! </IN>
! <IN NAME="rlayerdir" TYPE="real">
!  layer reflectivity to direct incident beam
! </IN>
! <IN NAME="tlayerdir" TYPE="real">
!  layer transmissivity to direct incident beam
! </IN>
! <IN NAME="rlayerdif" TYPE="real">
!  layer reflectivity to diffuse incident beam
! </IN>
! <IN NAME="tlayerdir" TYPE="real">
!  layer transmissivity to diffuse incident beam
! </IN>
! <IN NAME="tlayerde" TYPE="real">
!  layer diffuse transmissivity to direct incident beam
! </IN>
! <IN NAME="sfcalb" TYPE="real">
!  surface albedo
! </IN>
! <IN NAME="calcflag" TYPE="integer">
!  flag to indicate columns where adding is to be done
! </IN>
! <OUT NAME="reflectance" TYPE="real">
!  diffuse reflectance at a level
! </OUT>
! <OUT NAME="transmittance" TYPE="real">
!  diffuse transmittance at a level
! </OUT>
!</SUBROUTINE>
!

subroutine adding (ix, jx, kx, rlayerdir, tlayerdir, rlayerdif,   &
                   tlayerdif, tlayerde, sfcalb_dir, sfcalb_dif,  &
                   calc_flag, reflectance, transmittance, tr_dir)
 
!-------------------------------------------------------------------
!    adding calculates the reflection and transmission at flux levels 
!    from the direct and diffuse values of reflection and transmission
!    in the corresponding layers using the adding method.           
!    references:                                                        
!    bowen, m.m., and v. ramaswamy, effects of changes in radiatively
!        active species upon the lower stratospheric temperatures.,    
!        j. geophys. res., 18909-18921, 1994.                         
!--------------------------------------------------------------------

integer, intent(in)                    :: ix, jx, kx
real, dimension(:,:,:),   intent(in)   :: rlayerdir, rlayerdif, &
                                          tlayerdir, tlayerdif, & 
                                          tlayerde
real, dimension (:,:),    intent(in)   :: sfcalb_dir, sfcalb_dif
logical, dimension (:,:), intent(in)   :: calc_flag
real, dimension(:,:,:),   intent(out)  :: reflectance, transmittance, &
                                          tr_dir

!-------------------------------------------------------------------
!  intent(in) variables:
!
!    ix,jx,kx        dimensions of current physics window            
!    rlayerdir       layer reflectivity to a direct incident beam      
!    tlayerdir       layer transmissivity to a direct incident beam   
!    rlayerdif       layer reflectivity to a diffuse incident beam  
!    tlayerdif       layer transmissivity to a diffuse incident beam  
!    tlayerde        layer transmissivity (non-scattered) to the direct 
!                    incident beam                                 
!    sfcalb_dir      surface albedo, direct beam 
!    sfcalb_dif      surface albedo, diffuse beam
!    calc_flag       flag to indicate columns where adding is to be 
!                    done. calculations not done in "dark" columns and 
!                    on clr sky pass in columns without any clouds.
!
!  intent(out) variables:
!
!    reflectance     reflectance of the scattered radiation at a level 
!    transmittance   transmittance of the scattered radiation at a level
!    tr_dir
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:
 
      real, dimension (lbound(rlayerdir,3):ubound(rlayerdir,3)+1) ::  &
                            raddupdif2, raddupdir2

      real, dimension (lbound(rlayerdir,3):ubound(rlayerdir,3)  ) ::  &
                                      radddowndif2,  tadddowndir2

      real :: dm1tl2, dm2tl2, rdm2tl2, dm32, dm3r2, dm3r1p2, alpp2, &
              raddupdif2p, raddupdir2p, tlevel2p, radddowndifm, &
              tadddowndirm
      integer     ::  k, j, i

!-------------------------------------------------------------------
!   local variables:
!
!      raddupdif2
!      raddupdir2
!      tlevel2
!      radddowndif2
!      tadddowndir2
!      tlayerdif2
!      tlayerdir2
!      rlayerdif2
!      rlayerdir2
!      tlayerde2
!      dm1tl2
!      dm2tl2
!      rdm2tl2
!      dm32
!      dm3r2
!      dm3r1p2
!      alpp2
!      raddupdif2
!      raddupdir2p
!      tlevel2p
!      radddowndifm
!      tadddowndirm
!      i,j,k
!
!--------------------------------------------------------------------

!----------------------------------------------------------------------c
!    initialization for the surface layer.                           
!----------------------------------------------------------------------c
      do j=1,jx        
        do i=1,ix
          if (calc_flag(i,j) ) then
 
!------------------------------------------------------------------ 
!    add the inhomogeneous layers upward from the surface to the top of
!    the atmosphere.                                                  
!    radiation incident from above for diffuse beam, reflection of  
!    direct beam and conversion to diffuse.                           
!--------------------------------------------------------------------
            raddupdif2p = sfcalb_dif(i,j)
            raddupdir2p = sfcalb_dir(i,j)
            do k = kx, 1,-1
              dm2tl2    = tlayerdif(i,j,k)/(1.0 - rlayerdif(i,j,k)*  &
                          raddupdif2p )
              rdm2tl2    = dm2tl2*raddupdif2p     
              raddupdif2(k) = rlayerdif(i,j,k) + tlayerdif(i,j,k)*   &
                              rdm2tl2    
              raddupdir2(k) = rlayerdir(i,j,k) + tlayerde(i,j,k)*   &
                              raddupdir2p* dm2tl2 +   &     
                              (tlayerdir(i,j,k) - tlayerde(i,j,k))*  &
                              rdm2tl2   
              raddupdir2p = raddupdir2(k)
              raddupdif2p = raddupdif2(k)
            end do
 
!---------------------------------------------------------------------
!    define the direct transmittance. add the inhomogeneous layers 
!    downward from the second layer to the surface. radiation incident
!    from below for diffuse beam, transmission of direct beam and 
!    conversion to diffuse.                             
!-------------------------------------------------------------------
 
!--------------------------------------------------------------------
!    initialization for the first scattering layer.                   
!-------------------------------------------------------------------
            tlevel2p         = tlayerde(i,j,1)
            radddowndifm    =  rlayerdif(i,j,1)
            tadddowndirm    =  tlayerdir(i,j,1)
            do k= 2,kx    
              dm1tl2 = tlayerdif(i,j,k)/(1.0 - rlayerdif(i,j,k)*  &
                       radddowndifm)
              radddowndif2(k) = rlayerdif(i,j,k) + radddowndifm* &
                                tlayerdif(i,j,k)*dm1tl2      
              tadddowndir2(k) = tlevel2p*(tlayerdir(i,j,k) + &
                                rlayerdir(i,j,k)*radddowndifm* &
                                dm1tl2) + (tadddowndirm -  &
                                tlevel2p)*dm1tl2           

!---------------------------------------------------------------------
!    add downward to calculate the resultant reflectances and           
!    transmittances at flux levels.                                    
!------------------------------------------------------------------
              dm32  = 1.0/(1.0 - raddupdif2(k)*radddowndifm)
              dm3r2 = dm32*radddowndifm      
              dm3r1p2 = 1.0 + raddupdif2(k)*dm3r2   
              alpp2 = (tadddowndirm - tlevel2p)*dm32   
              transmittance(i,j,k) = (tlevel2p*(1.0 + raddupdir2(k)* &
                                      dm3r2) + alpp2)
              tr_dir(i,j,k) = tlevel2p
              reflectance(i,j,k) = (tlevel2p*raddupdir2(k)*   &
                                    dm3r1p2 + alpp2*   &
                                    raddupdif2(k))
              tlevel2p = tlevel2p*tlayerde (i,j,k) 
              radddowndifm = radddowndif2(k)
              tadddowndirm = tadddowndir2(k)
            end do
!! CORRECT ???
!           dm32  = 1.0/(1.0 - sfcalb(i,j)*radddowndifm)
            dm32          = 1.0/(1.0 - sfcalb_dif(i,j)*   &
                               radddowndifm       )
            dm3r2 = dm32*radddowndifm       
!! CORRECT ???
!           dm3r1p2 = 1.0 + sfcalb(i,j)*dm3r2         
            dm3r1p2          = 1.0 + sfcalb_dif(i,j) * dm3r2
            alpp2 = (tadddowndirm - tlevel2p)*dm32          
            transmittance(i,j,kx+1) = (tlevel2p*(1.0 +   &
!! CORRECT ???
!                                      sfcalb(i,j)* &
!12-08-03:  CHANGE THIS TO _dir as per SMF  sfcalb_dif(i,j)* &
                                       sfcalb_dir(i,j)* &
                                       dm3r2) + alpp2)
            tr_dir(i,j,kx+1) = tlevel2p
            reflectance(i,j,kx+1) = (tlevel2p*  &
!! CORRECT ???
!                                   sfcalb(i,j)*   &
                                    sfcalb_dir(i,j)* &
                                     dm3r1p2 + alpp2* &
!! CORRECT ???
!                                sfcalb(i,j) )
                                    sfcalb_dif(i,j))  
            reflectance(i,j,1) = raddupdir2p         
            transmittance(i,j,1) = 1.0
            tr_dir(i,j,1) = 1.0
          endif
        end do
      end do

!------------------------------------------------------------------


end subroutine adding 



!####################################################################
! <SUBROUTINE NAME="deledd">
!  <OVERVIEW>
!   Subroutine that calculates reflectivity and transmissivity in a
!   scattering layer using delta-eddington method
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine takes layer optical depth, single scattering abledo,
!   and asymmetry parameter, using delta-eddington method, to calculate
!   direct/diffuse reflectivity/transmissivity to direct/diffuse incident
!   radiation. The approximation uses the strong forward scattering of
!   aerosol particles.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call deledd (ix, jx, kx,  &
!                taustr, omegastr, gstr, cosang, ng , daylight,  &
!                rlayerdir, tlayerdir, rlayerdif, tlayerdif,   &
!                tlayerde,  cloud)
!  </TEMPLATE>
!  <IN NAME="ix" TYPE="integer">
!  ix is the current longitudinal index in the physics cell being
!  integrated.
!  </IN>
!  <IN NAME="jx" TYPE="integer">
!   jx is the current latitudinal index in the physics cell being
!   integrated.
!  </IN>
!  <IN NAME="kx" TYPE="integer">
!   ix is the current vertical index in the physics cell being
!   integrated.
!  </IN>
!  <IN NAME="taustr" TYPE="real">
!   the scaled optical depth, true optical depth normalized using
!   delta-eddington approximation
!  </IN>
!  <IN NAME="omegastr" TYPE="real">
!   the scaled single-scattering albedo
!  </IN>
!  <IN NAME="gstr" TYPE="real">
!   the scaled asymmetry factor
!  </IN>
!  <IN NAME="cosang" TYPE="real">
!   cosine of the solar zenith angle
!  </IN>
!  <IN NAME="ng" TYPE="real">
!   the number of gaussian angles to compute the diurnally    
!   averaged solar radiation (=1 unless lswg = true)
!  </IN>
!  <IN NAME="cloud" TYPE="real">
!   flag for existence of a cloud (used only in 'ovc' mode)
!  </IN>
!  <OUT NAME="rlayerdir" TYPE="real">
!   layer reflectivity to direct incident beam
!  </OUT>
!  <OUT NAME="tlayerdir" TYPE="real">
!   layer transmissivity to direct incident beam
!  </OUT>
!  <OUT NAME="rlayerdif" TYPE="real">
!   layer reflectivity to diffuse incident beam
!  </OUT>
!  <OUT NAME="tlayerdir" TYPE="real">
!   layer transmissivity to diffuse incident beam
!  </OUT>
!  <OUT NAME="tlayerde" TYPE="real">
!   layer diffuse transmissivity to direct incident beam
!  </OUT>
! </SUBROUTINE>
!
subroutine deledd (ix, jx, kx, taustr, omegastr, gstr, cosang, ng, &
                   daylight, rlayerdir, tlayerdir, tlayerde,   &
                   rlayerdif, tlayerdif, cloud)
 
!---------------------------------------------------------------------- 
!    deledd calculates the reflection and transmission in the 
!    scattering layers using the delta-eddington method.         
!    references:                                                   
!      joseph, j.h., w. wiscombe, and j.a. weinman, the delta-eddington
!      approximation for radiative flux transfer.,j. atmos. sci.,33,  
!      2452-2459, 1976.                                              
!-------------------------------------------------------------------

integer,                   intent(in)              :: ix, jx, kx
real, dimension(:,:,:),    intent(inout)           :: taustr, omegastr
real, dimension(:,:,:),    intent(in)              :: gstr
real, dimension(:,:),    intent(in)                ::  cosang
integer,                   intent(in)              :: ng
logical, dimension(:,:),   intent(in)              :: daylight
real, dimension(:,:,:),    intent(out)             :: rlayerdir,   &
                                                      tlayerdir,   &
                                                      tlayerde
real, dimension(:,:,:),    intent(inout), optional :: rlayerdif,   &
                                                      tlayerdif
logical, dimension(:,:,:), intent(in), optional    :: cloud          

!----------------------------------------------------------------------
!  intent(in) variables:
!
!    ix,jx,kx
!    gstr        the scaled asymmetry factor                       
!    cosang      the cosine of the solar zenith angle    
!    ng          the number of gaussian angles to compute the diurnally 
!                averaged solar radiation (=1 unless lswg = true)       
!    daylight
!
!  intent(inout) variables:
!
!    taustr      the scaled extinction optical depth                    
!    omegastr    the scaled single-scattering albedo               
!
!  intent(out) variables:
!
!    rlayerdir   the layer reflectivity to a direct incident beam      
!    tlayerdir   the layer transmissivity to a direct incident beam   
!    rlayerdif   the layer reflectivity to a diffuse incident beam   
!    tlayerdif   the layer transmissivity to a diffuse incident beam
!    tlayerde    the layer transmissivity (non-scattered) to the direct 
!                incident beam                                       
!
! intent(in),optional:
!
!    cloud       flag for existence of a cloud (used only in 'ovc' mode)
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:

      real        :: qq(7), rr(5), ss(8), tt(8), ww(4)
      real        :: rsum, tsum
      real        :: onedi3 = 1.0/3.0           
      real        :: twodi3 = 2.0/3.0             
      integer     :: k, i, ns, j, nn, ntot

      integer, dimension(ix, jx, kx) :: cld_index

      real,    dimension(ix)                  ::   &
                                          gstr2, taustr2, omegastr2, &
                                           cosangzk2, rlayerdir2,    &
                                           tlayerde2, tlayerdir2, &
                                           sumr, sumt


!----------------------------------------------------------------------
!  local variables:
!
!      qq
!      rr
!      ss
!      tt
!      ww
!      rsum
!      tsum
!      alpha
!      onedi3
!      twodi3
!      i,j,k
!      ns
!      nn
!      ntot
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do k=1,kx         
        do j=1,jx         

!---------------------------------------------------------------------
!    overcast sky mode. note: in this mode, the delta-eddington method
!    is performed only for spatial points containing a cloud.   
!-------------------------------------------------------------------
          nn = 0
          if (present(cloud)) then
            do i=1,ix          
              if (cloud(i,j,k) ) then
                nn = nn + 1
                cld_index(i,j,k) = nn
                gstr2(nn) = gstr(i,j,k)
                taustr2(nn) = taustr(i,j,k)
                omegastr2(nn) = omegastr(i,j,k)
                cosangzk2(nn) = cosang(i,j)

!----------------------------------------------------------------------
!    note: the following are done to avoid the conservative scattering 
!    case, and to eliminate floating point errors in the exponential 
!    calculations, respectively.                      
!----------------------------------------------------------------------c
                if (omegastr2(nn) >= 1.0) omegastr2(nn) = 9.9999999E-01
                if (taustr2(nn) >= 1.0E+02) taustr2(nn) = 1.0E+02
              endif
            end do

!----------------------------------------------------------------------c
!    clear sky mode. note: in this mode, the delta-eddington method is 
!    performed for all spatial points.                 
!----------------------------------------------------------------------c
          else
            do i=1,ix         
              if (daylight(i,j) ) then
                nn = nn + 1
                cld_index(i,j,k) = nn
                gstr2(nn) = gstr(i,j,k)
                taustr2(nn) = taustr(i,j,k)
                omegastr2(nn) = omegastr(i,j,k)
                cosangzk2(nn) = cosang(i,j   )

!----------------------------------------------------------------------c
!    note: the following are done to avoid the conservative scattering  
!    case, and to eliminate floating point errors in the exponential 
!    calculations, respectively.                    
!----------------------------------------------------------------------c
                if (omegastr2(nn) >= 1.0) omegastr2(nn) = 9.9999999E-01
                if (taustr2(nn) >= 1.0E+02) taustr2(nn) = 1.0E+02
              endif
            end do
          endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
          ntot = nn

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
          do nn=1,ntot      

!----------------------------------------------------------------------c
!    direct quantities                                            
!----------------------------------------------------------------------c
            ww(1) = omegastr2(nn)
            ww(2) = gstr2(nn)
            ww(3) = taustr2(nn)
            ww(4) = cosangzk2(nn)

            qq(1)     = 3.0 * ( 1.0 - ww(1) )
            qq(2)         = 1.0 - ww(1) * ww(2)
            qq(3)     = qq(1)/qq(2)
            qq(4) = sqrt( qq(1) * qq(2) )
            qq(5) = sqrt (qq(3))
            qq(6) = 1.0 + twodi3 * qq(5)         
            qq(7) = 1.0 - twodi3 * qq(5)       

            rr(1) = 1./qq(6)
            rr(2) = qq(7)*rr(1)
            rr(3) = exp( -ww(3)          * qq(4) )
            rr(4) = 1.0/rr(3)
            rr(5) = 1.0/(qq(6) * rr(4) - qq(7) * rr(3) * rr(2) )

            ss(1) = 0.75 * ww(1)/(1.0 - (qq(4)*ww(4)      ) ** 2 )
            ss(2) = ss(1)*ww(4)*( 1.0 + ww(2)*qq(1)*onedi3)
            ss(3) = ss(1)*(1.0 + ww(2)*qq(1)*ww(4)** 2 )
            ss(4) = ss(2) - twodi3*ss(3)     
            ss(5) = ss(2) + twodi3 * ss(3)     
            ss(6) = exp( -ww(3)          / ww(4) )
            ss(7) = (ss(4)*ss(6) - ss(5)*rr(3)*rr(2))*rr(5)
            ss(8) = (ss(5) - qq(7)*ss(7))*rr(1)

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
            rlayerdir2(nn) = qq(7) * ss(8) + qq(6)*ss(7) - ss(4)
            tlayerdir2(nn) = ((rr(3) * qq(6) * ss(8) + &
                               qq(7) * rr(4) * ss(7) -  &
                               ss(5) * ss(6) ) + ss(6) )
            tlayerde2(nn) = ss(6)

!----------------------------------------------------------------------c
!    diffuse quantities                                       
!    notes: the number of streams for the diffuse beam is fixed at 4.   
!    this calculation is done only for ng=1.                 
!----------------------------------------------------------------------c
            if (present (tlayerdif) .and. present(rlayerdif)) then
              if ( ng.eq.1 ) then   
                rsum = 0.0
                tsum = 0.0
                do ns = 1,NSTREAMS
                  tt(1) = 0.75 * ww(1)            / ( 1.0 - ( qq(4) * &
                          cosangstr(ns) ) ** 2 )
                  tt(2) = tt(1) * cosangstr(ns) * ( 1.0 +  &
                          ww(2)        * qq(1) * onedi3 )
                  tt(3) = tt(1) * ( 1.0 + ww(2)        * qq(1)*&
                          cosangstr(ns) ** 2 )
                  tt(4) = tt(2) - twodi3 * tt(3)
                  tt(5) = tt(2) + twodi3 * tt(3)
                  tt(6) = exp( -ww(3)          / cosangstr(ns) )
                  tt(7) = ( tt(4) * tt(6) - tt(5) *  &
                          rr(3) * rr(2)   ) * rr(5)
                  tt(8) = ( tt(5) - qq(7) * tt(7) )*rr(1)
                  if (nstr4) then
                    rsum = rsum + (qq(7)*tt(8) + qq(6)*tt(7) - tt(4))* &
                           wtstr(ns)*cosangstr(ns)
                    tsum = tsum + ((rr(3)*qq(6)*tt(8) +   &
                                    qq(7)*rr(4)*tt(7) -   &
                                    tt(5)*tt(6)) + tt(6))*  &
                                    wtstr(ns)*cosangstr(ns)
                  else 
                    rsum = rsum + (qq(7)*tt(8) + qq(6)*tt(7) - tt(4))
                    tsum = tsum + ( (rr(3)*qq(6)*tt(8) +    &
                                     qq(7)*rr(4)*tt(7) -   &
                                     tt(5)*tt(6)) + tt(6))
                  endif
                end do
                sumr(nn) = rsum
                sumt(nn) = tsum
              endif  !  ng == 1
            endif ! (present (tlayerdiff))
          end do  ! ntot loop

!---------------------------------------------------------------------
!     return results in proper locations in (i,j,k) arrays
!---------------------------------------------------------------------
          if (present(cloud)) then
            do i=1,ix           
              if (cloud(i,j,k) ) then
                rlayerdir(i,j,k) = rlayerdir2(cld_index(i,j,k))
                tlayerdir(i,j,k) = tlayerdir2(cld_index(i,j,k))
                tlayerde(i,j,k) = tlayerde2(cld_index(i,j,k))
                if (present(tlayerdif)) then
                  if (ng .eq. 1) then
                    rlayerdif(i,j,k) = sumr(cld_index(i,j,k))
                    tlayerdif(i,j,k) = sumt(cld_index(i,j,k))
                  endif
                endif
              endif
            end do

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
          else
            do i=1,ix            
              if (daylight(i,j) ) then
                rlayerdir(i,j,k) = rlayerdir2(cld_index(i,j,k))
                tlayerdir(i,j,k) = tlayerdir2(cld_index(i,j,k))
                tlayerde(i,j,k) = tlayerde2(cld_index(i,j,k))
                if (present(tlayerdif)) then
                  if (ng .eq. 1) then
                    rlayerdif(i,j,k) = sumr(cld_index(i,j,k))
                    tlayerdif(i,j,k) = sumt(cld_index(i,j,k))
                  endif
                endif
              endif
            end do
          endif
        end do
      end do

!---------------------------------------------------------------------
 
end subroutine deledd



!#####################################################################


                   end module esfsw_driver_mod


                 module esfsw_parameters_mod
!
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!  smf
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Code to initialize shortwave parameters and access flux data.
! </OVERVIEW>
! <DESCRIPTION>
!  This code initializes shortwave radiation calculation parameters such as
!  solar flux input at top of the atmosphere, number of shortwave bands
!  depending on the spectral resolution used, number of frequency points
!  in the gaussian quadrature algorithm, the number of streams used in
!  multiple stream flux algorithm, and the number of water vapor bands.
!
!  The code also provides two access methods: get and put solar flux data
!  
! </DESCRIPTION>

!    shared modules:

use mpp_mod,           only: input_nml_file
use fms_mod,           only: open_namelist_file, fms_init, &
                             mpp_pe, mpp_root_pe, stdlog, &
                             file_exist, write_version_number, &
                             check_nml_error, error_mesg, &
                             FATAL, close_file

!  shared radiation package modules:

use rad_utilities_mod, only: solar_spectrum_type


!--------------------------------------------------------------------

implicit none
private

!-------------------------------------------------------------------
!     esfsw_parameters_mod defines parameters for esf shortwave code,
!     including a description of the band structure  used to define the
!     solar spectrum.
!------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: esfsw_parameters.F90,v 18.0.2.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'

!--------------------------------------------------------------------
!----- interfaces ------

public       &
         esfsw_parameters_init, &
         esfsw_parameters_end

!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16)  :: sw_resolution = '   ' ! either 'high' or 'low'
integer            :: sw_diff_streams = 0   ! number of streams of
                                            ! diffuse radiation that
                                            ! are considered


namelist /esfsw_parameters_nml/    &
                                 sw_resolution,   &
                                 sw_diff_streams

!-------------------------------------------------------------------
!----- public data --------

!---------------------------------------------------------------------
!    TOT_WVNUMS     number of wavenumbers included in the parameter-
!                   ization of the solar spectrum 
!    Solar_spect    solar_spectrum_type variable defining the nature
!                   of the solar spectral paramaterization
!---------------------------------------------------------------------
integer, parameter                      :: TOT_WVNUMS  = 57600
type(solar_spectrum_type), public, save :: Solar_spect


!-------------------------------------------------------------------
!----- private data --------

logical :: module_is_initialized = .false.  ! module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                      contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!     
!                     PUBLIC SUBROUTINES
!            
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
!
! <SUBROUTINE NAME="esfsw_parameters_init">
!  <OVERVIEW>
!   Subroutine that initializes and set up shortwave radiation.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine that initializes shortwave radiation calculation parameters such as
!   solar flux input at top of the atmosphere, number of shortwave bands
!   depending on the spectral resolution used, number of frequency points
!   in the gaussian quadrature algorithm, the number of streams used in
!   multiple stream flux algorithm, and the number of water vapor bands.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call esfsw_parameters_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine esfsw_parameters_init

!------------------------------------------------------------------
!    esfsw_parameters_init is the constructor for esfsw_parameters_mod.
!------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      integer    ::  unit, ierr, io, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=esfsw_parameters_nml, iostat=io)
      ierr = check_nml_error(io,'esfsw_parameters_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=esfsw_parameters_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'esfsw_parameters_nml')
        end do
10      call close_file (unit)
      endif
#endif

!--------------------------------------------------------------------
!    process the namelist entries to obtain the parameters specifying
!    the solar spectral parameterization.
!--------------------------------------------------------------------
      if (trim(sw_resolution) == 'high') then
        Solar_spect%nbands = 25
        Solar_spect%nfrqpts = 72
        Solar_spect%nh2obands = 14
      else if (trim(sw_resolution) == 'low') then
        Solar_spect%nbands = 18
        Solar_spect%nfrqpts = 38
        Solar_spect%nh2obands = 9
      else
        call error_mesg ( 'esfsw_parameters_mod',   &
       ' sw_resolution must be specified as "high" or "low".', FATAL)
      endif
      if (sw_diff_streams == 4) then
        Solar_spect%nstreams = 4
      else if (sw_diff_streams == 1) then
        Solar_spect%nstreams = 1
      else
        call error_mesg ( 'esfsw_parameters_mod',   &
          ' sw_diff_streams must be specified as either 1 or 4.', FATAL)
      endif

!---------------------------------------------------------------------
!    include the total number of wavenumbers in the solar parameter-
!    ization in the solar_spectrum_type variable.
!---------------------------------------------------------------------
      Solar_spect%tot_wvnums = TOT_WVNUMS

!---------------------------------------------------------------------
!    write version number and namelist to logfile also write out
!    some key parameters obtained from an input data file.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) then
        write (logunit,9000)     &
            Solar_spect%NBANDS, Solar_spect%NFRQPTS,  &
            Solar_spect%NSTREAMS, Solar_spect%NH2OBANDS 
        write (logunit, nml=esfsw_parameters_nml)
      endif  

!-------------------------------------------------------------------
!    indicate that visible_band_indx has not yet been defined.
!-------------------------------------------------------------------
      Solar_spect%visible_band_indx = -10000000
      Solar_spect%visible_band_indx_iz = .false.

!-------------------------------------------------------------------
!    indicate that eight70_band_indx has not yet been defined.
!-------------------------------------------------------------------
      Solar_spect%eight70_band_indx = -10000000
      Solar_spect%eight70_band_indx_iz = .false.

!-------------------------------------------------------------------
!    allocate space for the array components of the solar_spect_type
!    variable.
!-------------------------------------------------------------------
      allocate (Solar_spect%solflxband (Solar_spect%nbands) )
      allocate (Solar_spect%solflxbandref (Solar_spect%nbands) )
      allocate (Solar_spect%endwvnbands (0:Solar_spect%nbands) )
      allocate (Solar_spect%solarfluxtoa (Solar_spect%tot_wvnums))

!------------------------------------------------------------------
!    mark the module as initialized.
!------------------------------------------------------------------
      module_is_initialized = .true.

!------------------------------------------------------------------
9000  format ( '  NBANDS=  ', i4, '  NFRQPTS=', i4, &
               '  NSTREAMS= ', i4, '  NH2OBANDS= ', i4 )

!------------------------------------------------------------------


end subroutine esfsw_parameters_init



!####################################################################
!
! <SUBROUTINE NAME="esfsw_parameters_end">
!  <OVERVIEW>
!   Subroutine that is the destructor for esfsw_parameters_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine that deallocates module variables and marks the module  
!   as uninitialized.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call esfsw_parameters_end
!  </TEMPLATE>
! </SUBROUTINE>
!

subroutine esfsw_parameters_end

!--------------------------------------------------------------------
!    esfsw_parameters_end is the destructor for esfsw_parameters_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('esfsw_parameters_mod',   &
             'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    deallocate the components of the solar_spect_type variable.
!---------------------------------------------------------------------
      deallocate (Solar_spect%solflxband, &
                  Solar_spect%solflxbandref, &
                  Solar_spect%endwvnbands, &
                  Solar_spect%solarfluxtoa)

!-------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------

end subroutine esfsw_parameters_end



!###################################################################

      end module esfsw_parameters_mod


                       module gas_tf_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that calculates gas transmission functions
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!  shared modules:

use mpp_mod,             only : input_nml_file
use fms_mod,             only : open_namelist_file, fms_init, &
                                mpp_pe, mpp_root_pe, stdlog, &
                                file_exist, write_version_number, &
                                check_nml_error, error_mesg, &
                                FATAL, close_file, &
                                open_restart_file
use constants_mod,       only : constants_init, RDGAS, GRAV, pstd

!   shared radiation package modules:

use rad_utilities_mod,   only : rad_utilities_init, Lw_control, &
                                atmos_input_type, gas_tf_type
use longwave_params_mod, only : longwave_params_init, NBCO215

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    gas_tf_mod is the gas transmission functions module.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: gas_tf.F90,v 18.0.2.1 2010/08/30 20:39:46 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!------    interfaces   ------

 public    &
         gas_tf_init, co2coef, transcol,    &
         transcolrow, trans_nearby, trans_sfc,   &
         put_co2_stdtf_for_gas_tf,  &
         put_co2_nbltf_for_gas_tf, &
         put_ch4_stdtf_for_gas_tf,  &
         put_n2o_stdtf_for_gas_tf, &
         get_control_gas_tf, &
         process_co2_input_file, &
         process_ch4_input_file,  &
         process_n2o_input_file, &
         gas_tf_dealloc, gas_tf_end

private   &

!  called from gas_tf_init:
         ptz,    &

!  called from ptz:
         antemp,   &

!  called from process_co2_input_file,  
!  process_ch4_input_file and process_n2o_input_file:
         process_gas_input_file, &

!  called from co2coef:
         transfn


!---------------------------------------------------------------------
!------     namelist  -----

character(len=16) :: interp_form='log'
logical           :: do_calcstdco2tfs = .true.,   &
                     do_writestdco2tfs = .false., &
                     do_readstdco2tfs = .false.
logical           :: do_calcstdch4tfs = .true.,   &
                     do_writestdch4tfs = .false., &
                     do_readstdch4tfs = .false.
logical           :: do_calcstdn2otfs = .true.,   &
                     do_writestdn2otfs = .false., &
                     do_readstdn2otfs = .false.


namelist / gas_tf_nml /  &
                            interp_form, &
                            do_calcstdch4tfs,  &
                            do_writestdch4tfs, &
                            do_readstdch4tfs, &
                            do_calcstdn2otfs,  &
                            do_writestdn2otfs,  &
                            do_readstdn2otfs, &
                            do_calcstdco2tfs,  &
                            do_writestdco2tfs,  &
                            do_readstdco2tfs

!---------------------------------------------------------------------
!---- public data -------


!---------------------------------------------------------------------
!----   private data  -------


!--------------------------------------------------------------------- 
!    the following arrays are co2 transmission functions, temperature
!    and pressure derivatives for the 560-800 cm-1 band, and standard 
!    temperature and weighting functions.
! 
!      co251   =  transmission functions for t0 (standard profile)
!                 with p(surface)=1013.25 mb.
!
!      co258   =  transmission functions for t0 (standard profile) 
!                 with p(surface)=810 mb.
!
!      cdt51   =  first temperature derivative of co251.
! 
!      cdt58   =  first temperature derivative of co258.
! 
!      c2d51   =  second temperature derivative of co251.
!
!      c2d58   =  second temperature derivative of co258.
!
!      co2m51  =  transmission functions for t0 for adjacent pressure 
!                 levels, with no pressure quadrature.  used for nearby
!                 layer computations.  p(surface)=1013.25 mb.
! 
!      co2m58  =  transmission functions for t0 for adjacent pressure 
!                 levels, with no pressure quadrature.  used for nearby
!                 layer computations.  p(surface)=810 mb.
!
!      cdtm51  =  first temperature derivative of co2m51.
!
!      cdtm58  =  first temperature derivative of co2m58.
!
!      c2dm51  =  second temperature derivative of co2m51.
! 
!      c2dm58  =  second temperature derivative of co2m58.
!--------------------------------------------------------------------- 

real, allocatable, dimension (:,:)       ::  co251, co258,     &    
                                             cdt51, cdt58,     &    
                                             c2d51, c2d58
real, allocatable, dimension (:)         ::  co2m51, co2m58,   &    
                                             cdtm51, cdtm58,   &    
                                             c2dm51, c2dm58

!--------------------------------------------------------------------- 
!    the following arrays are co2 transmission functions for the 2270- 
!    2380 cm-1 part of the 4.3 um co2 band.
! 
!       co211    =  transmission functions for t0 (standard profile)
!                   with p(surface)=1013.25 mb.
!
!       co218    =  transmission functions for t0 (standard profile) 
!                   with p(surface)=810 mb.
!--------------------------------------------------------------------- 

real, allocatable, dimension (:)         ::  co211, co218

!--------------------------------------------------------------------- 
!    the following arrays are co2 transmission functions and temperature
!    and pressure derivatives for (NBCO215) narrow bands in the 15um
!    co2 band.
!
!        co215nbps1    =  transmission functions for USSTD profile
!                        with p(surface)=1013.25 mb.
!        co215nbps8    =  transmission functions for USSTD profile
!                        with p(surface)=810.2 mb.
!
!        co2dt15nbps1  = temperature derivative of co215nbps1.
!
!        co2dt15nbps8  = temperature derivative of co215nbps8.
!
!        co2d2t15nbps1 = second temperature derivative of co215nbps1.
!
!        co2d2t15nbps8 = second temperature derivative of co215nbps8.
!--------------------------------------------------------------------- 

real, allocatable, dimension (:,:)       ::  co215nbps1,       &    
                                             co215nbps8,       &    
                                             co2dt15nbps1,     &    
                                             co2dt15nbps8,     &    
                                             co2d2t15nbps1,    &    
                                             co2d2t15nbps8

!--------------------------------------------------------------------- 
!    the following arrays are ch4 and n2o transmission functions for
!    the 1200-1400 cm-1 band.
! 
!       ch451   =  ch4 transmission functions for t0 (standard profile)
!                  with p(surface)=1013.25 mb.
!
!       ch458   =  ch4 transmission functions for t0 (standard profile) 
!                  with p(surface)=810 mb.
!
!       ch4dt51 =  first temperature derivative of ch4 transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       ch4d2t51=  second temperature derivative of ch4 transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       ch4dt58 =  first temperature derivative of ch4 transmission
!                  functions for t0 profile with p(surface)=810 mb.
!
!       ch4d2t58=  second temperature derivative of ch4 transmission
!                  functions for t0 profile with p(surface)=810 mb.
!
!       n2o51   =  n2o transmission functions for t0 (standard profile)
!                  with p(surface)=1013.25 mb.
!
!       n2o58   =  n2o transmission functions for t0 (standard profile) 
!                  with p(surface)=810 mb.
!
!       n2odt51 =  first temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       n2od2t51=  second temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       n2odt58 =  first temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=810 mb.
!
!       n2od2t58=  second temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=810 mb.
!--------------------------------------------------------------------- 
  
real, allocatable, dimension (:,:)       ::  ch451, ch458,     &    
                                             ch4dt51, ch4dt58, &    
                                             ch4d2t51, ch4d2t58
real, allocatable, dimension (:,:)       ::  n2o51, n2o58,     &    
                                             n2odt51, n2odt58, &    
                                             n2od2t51, n2od2t58

!--------------------------------------------------------------------- 
!    the following arrays are n2o transmission functions for
!    the 560-630 cm-1 band.
! 
!       n2o71   =  n2o transmission functions for t0 (standard profile)
!                  with p(surface)=1013.25 mb.
!
!       n2o78   =  n2o transmission functions for t0 (standard profile) 
!                  with p(surface)=810 mb.
!
!       n2odt71 =  first temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       n2od2t71=  second temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       n2odt78 =  first temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=810 mb.
!
!       n2od2t78=  second temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=810 mb.
!--------------------------------------------------------------------- 
!
  
real, allocatable, dimension (:,:)       ::  n2o71, n2o78,     &    
                                             n2odt71, n2odt78, &    
                                             n2od2t71, n2od2t78

!--------------------------------------------------------------------- 
!    the following arrays are n2o transmission functions for
!    the 1070-1200 cm-1 band.
! 
!       n2o91   =  n2o transmission functions for t0 (standard profile)
!                  with p(surface)=1013.25 mb.
!
!       n2o98   =  n2o transmission functions for t0 (standard profile) 
!                  with p(surface)=810 mb.
!
!       n2odt91 =  first temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       n2od2t91=  second temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=1013.25 mb.
!
!       n2odt98 =  first temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=810 mb.
!
!       n2od2t98=  second temperature derivative of n2o transmission
!                  functions for t0 profile with p(surface)=810 mb.
!--------------------------------------------------------------------- 
  
real, allocatable, dimension (:,:)       ::  n2o91, n2o98,     &    
                                             n2odt91, n2odt98, &    
                                             n2od2t91, n2od2t98

!----------------------------------------------------------------------
!    stemp   =  standard temperatures for model pressure level
!               structure with p(surface)=1013.25 mb.
!    gtemp   =  weighting function for model pressure level 
!               structure with p(surface)=1013.25 mb.
!----------------------------------------------------------------------
real, dimension (:),       allocatable   :: stemp, gtemp 

!----------------------------------------------------------------------
!    define 4 coefficients (formerly in Id3).
!    b0, b1, b2, b3 are coefficients used to correct for the use of
!    250k in the planck function used in evaluating planck-weighted co2
!    transmission functions. (see reference(1).)
!----------------------------------------------------------------------
real     :: b0 = -0.51926410E-04
real     :: b1 = -0.18113332E-03
real     :: b2 = -0.10680132E-05
real     :: b3 = -0.67303519E-07

integer               :: ksrad, kerad
integer, parameter    :: nvalids=1
integer               :: ixprkminh2o
logical               :: do_linearlblint, do_loglblint
character(len=8)      :: co2_name_save, ch4_name_save, n2o_name_save
real                  :: co2_amount_save, ch4_amount_save, &
                         n2o_amount_save
integer               :: nstdlvls_save, kbegin_save, kend_save

real, dimension(:), allocatable      :: pa_save, pd_save, plm_save
character(len=8), dimension(nvalids) :: valid_versions= 'v1.00'
logical :: module_is_initialized = .false.  ! module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------




                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!###############################################################
! <SUBROUTINE NAME="gas_tf_init">
!  <OVERVIEW>
!   Initialize gas transmission function calculation from input 
!   namelist, model pressure coordinate system, etc.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Initialize gas transmission function calculation from input 
!   namelist, model pressure coordinate system, etc.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call gas_tf_init(pref)
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!   Model pressure coordinate array
!  </IN>
! </SUBROUTINE>
!
subroutine gas_tf_init (pref)                        

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

real, dimension(:,:), intent(in) :: pref

!---------------------------------------------------------------------
!  intent(in)  variables:
!
!     pref
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables;

      real, dimension (size(pref,1)) :: plm
      real, dimension (size(pref,1)) :: pd

      real     ::  prkminh2o = 28.0
      integer  ::  kmin, kmax
      integer  ::  ks = 1
      integer  ::  unit, ierr, io, logunit
      integer  ::  k

!--------------------------------------------------------------------
!  local variables:
!
!       plm
!       pd
!       prkminh2o   pressure above which h2o-co2 overlap affects
!                   nearby layer transmissivities  [ mb ]
!       kmin
!       kmax
!       ks
!       unit
!       ierr
!       io
!       k
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
 !---------------------------------------------------------------------
 !    verify that modules used by this module that are not called later
 !    have already been initialized.
 !---------------------------------------------------------------------
       call fms_init
       call constants_init
       call rad_utilities_init
       call longwave_params_init

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=gas_tf_nml, iostat=io)
      ierr = check_nml_error(io,"gas_tf_nml")
#else
!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=gas_tf_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'gas_tf_nml')
        end do
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                       write (logunit, nml=gas_tf_nml)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      kmin = 1
      kerad = size(pref  ,1) - 1
      kmax = kerad
      ksrad = 1
      ks = 1

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      pd (:) = pref(:,1)
      plm (kmin) = 0.
      do k=kmin+1,kmax
        plm (k) = 0.5*(pd (k-1) + pd (k))
      enddo
      plm (kmax+1) = pd (kmax+1)

!---------------------------------------------------------------------
!    convert plm to mb.
!---------------------------------------------------------------------
      plm = plm   *1.0E-02
      pd = pd   *1.0E-02

!--------------------------------------------------------------------
!    check on consistency between namelist values
!--------------------------------------------------------------------
      if ( (Lw_control%do_ch4lbltmpint) .and.    &
           (.not.(Lw_control%do_ch4)) ) then
        call error_mesg ( 'gas_tf_mod', &
       'cannot have do_ch4lbltmpint active when do_ch4 is off',& 
                                                                 FATAL)
      endif
      if ( (Lw_control%do_n2olbltmpint) .and.    &
           (.not.(Lw_control%do_n2o)) ) then
        call error_mesg ( 'gas_tf_mod', &
       'cannot have do_n2olbltmpint active when do_n2o is off',& 
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(interp_form) == 'log') then
        do_loglblint    = .true.
        do_linearlblint = .false.
      else if (trim(interp_form) == 'linear') then
        do_loglblint    = .false.
        do_linearlblint = .true.
      else
        call error_mesg ( 'gas_tf_mod', &
       'improper specification for gas lbl interpolation scheme', FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (Lw_control%do_co2_iz) then
        if (Lw_control%do_co2) then
          if (do_writestdco2tfs .and. do_readstdco2tfs) then
            call error_mesg ( 'gas_tf_mod', &
                ' cannot read and write std tfs in same job', FATAL)
          endif

          if (do_writestdco2tfs .and. .not. do_calcstdco2tfs) then
            call error_mesg ( 'gas_tf_mod', &
              ' cannot write std tfs without calculating them', FATAL)
          endif
        endif
      else
        call error_mesg ('gas_tf_mod', &
              'do_co2 has not yet been defined', FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (Lw_control%do_ch4_iz) then
        if (Lw_control%do_ch4) then
          if (do_writestdch4tfs .and. do_readstdch4tfs) then
            call error_mesg ( 'gas_tf_mod', &
              ' cannot read and write std tfs in same job', FATAL)
          endif
          if (do_writestdch4tfs .and. .not. do_calcstdch4tfs) then
            call error_mesg ( 'gas_tf_mod', &
              ' cannot write std tfs without calculating them', FATAL)
          endif
        endif
      else
        call error_mesg ('gas_tf_mod', &
                 'do_ch4 has not yet been defined', FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (Lw_control%do_n2o_iz) then
        if (Lw_control%do_n2o) then
          if (do_writestdn2otfs .and. do_readstdn2otfs) then
            call error_mesg ( 'gas_tf_mod', &
              ' cannot read and write std tfs in same job', FATAL)
          endif
          if (do_writestdn2otfs .and. .not. do_calcstdn2otfs) then
            call error_mesg ( 'gas_tf_mod', &
               ' cannot write std tfs without calculating them', FATAL)
          endif
        endif
      else
        call error_mesg ('gas_tf_mod', &
              'do_n2o has not yet been defined', FATAL)
      endif

!--------------------------------------------------------------------
!    call ptz to compute standard temps and a pressure coefficient 
!    (gtemp) used in the radiation algorithm. 
!--------------------------------------------------------------------
      call ptz (plm, pd)

!--------------------------------------------------------------------
!    convert pressure specification for top (flux) pressure level
!    for nearby layer calculation into an index (ixprkminh2o)
!    note: minimum value of ixprkminh2o is KSRAD . (but if KSRAD = 1,
!    plm(1) is zero, so minimum value of KSRAD is at least 2).
!    if all levels used for radiative calculations are at pressures
!    less than 28 mb, nearby layer effects are going to be ignored,
!    so ixprkminh2o is set to KERAD+1 to avoid loop calculations.
!--------------------------------------------------------------------
      if (plm(ks) >= prkminh2o) then
        ixprkminh2o = 1
      else if (plm(kmax ) < prkminh2o) then
        ixprkminh2o = (kmax - ks + 1) + 1
      else
        do k=ks+1,kmax  
          if ((plm(k) - prkminh2o) .LT. 0.0) then
!! ixprkminh2o in radiation grid coordianates, not model grid coords
          else
            ixprkminh2o = k-ks + 1
            exit
          endif
        enddo
      endif
   
!----------------------------------------------------------------------
!    allocate co2 transmission function arrays to hold data which will 
!    either be read in or will be coming from lw_gases_stdtf module.
!----------------------------------------------------------------------
     if (Lw_control%do_co2) then
      allocate (cdtm51(KSRAD:KERAD) , &
                co2m51(KSRAD:KERAD) , &
                c2dm51(KSRAD:KERAD) , &
                cdtm58(KSRAD:KERAD) , &
                co2m58(KSRAD:KERAD) , &
                c2dm58(KSRAD:KERAD)   )
      allocate (co2dt15nbps1(KSRAD:KERAD+1, NBCO215) , &
                co215nbps1(KSRAD:KERAD+1, NBCO215) , &
                co2d2t15nbps1(KSRAD:KERAD+1, NBCO215) , &
                co2dt15nbps8(KSRAD:KERAD+1, NBCO215) , &
                co215nbps8(KSRAD:KERAD+1, NBCO215) , &
                co2d2t15nbps8(KSRAD:KERAD+1, NBCO215)   )
      allocate (cdt51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                co251(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                c2d51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                cdt58(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                co258(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                c2d58(KSRAD:KERAD+1, KSRAD:KERAD+1)   )
      allocate (co211(KSRAD:KERAD+1) , &
                co218(KSRAD:KERAD+1) )
     endif

!----------------------------------------------------------------------
!    allocate ch4 and n2o transmission function arrays to hold data 
!    which will either be read in or will be coming from 
!    lw_gases_stdtf module.
!----------------------------------------------------------------------
      if (Lw_control%do_ch4) then
        allocate (ch4dt51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  ch451(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  ch4d2t51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  ch4dt58(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  ch458(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  ch4d2t58(KSRAD:KERAD+1, KSRAD:KERAD+1)   )
      endif
      if (Lw_control%do_n2o) then
        allocate (n2odt51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2o51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2od2t51(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2odt58(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2o58(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2od2t58(KSRAD:KERAD+1, KSRAD:KERAD+1)   )
        allocate (n2odt91(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2o91(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2od2t91(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2odt98(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2o98(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2od2t98(KSRAD:KERAD+1, KSRAD:KERAD+1)   )
        allocate (n2odt71(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2o71(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2od2t71(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2odt78(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2o78(KSRAD:KERAD+1, KSRAD:KERAD+1) , &
                  n2od2t78(KSRAD:KERAD+1, KSRAD:KERAD+1)   )
      endif

!-------------------------------------------------------------------
!    mark the module as initialized.
!-------------------------------------------------------------------
      module_is_initialized = .true.
 
!---------------------------------------------------------------------


end subroutine gas_tf_init



!###################################################################
! <SUBROUTINE NAME="co2coef">
!  <OVERVIEW>
!   Calculate CO2 absorption coefficients and transmission function
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculate CO2 absorption coefficients and transmission function
!  </DESCRIPTION>
!  <TEMPLATE>
!   call co2coef(Atmos_input, Gas_tf)
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   The input data of the atmosphere structure and gas concentration
!  </IN>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   The gas transmission function table
!  </INOUT>
! </SUBROUTINE>
!
subroutine co2coef (Atmos_input, Gas_tf)
 
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

type(gas_tf_type),      intent(inout) :: Gas_tf
type(atmos_input_type), intent(in)    :: Atmos_input

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     Atmos_input
!
!  intent(inout) variables:
!
!     Gas_tf
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(Atmos_input%pflux,1), &
                       size(Atmos_input%pflux,2), &
                       size(Atmos_input%pflux,3)-1) :: pdflux

      real, dimension (size(Atmos_input%pflux,1), &
                       size(Atmos_input%pflux,2), &
                       size(Atmos_input%pflux,3)  ) ::  &
                             tdif, press, temp, pflux, tflux

      real                                 ::  palog8, alogps8 
      integer                              ::  i, j, k   
      integer                              :: israd, ierad, jsrad, jerad

!---------------------------------------------------------------------
!  local variables:
!
!      pdflux
!      tdif
!      press
!      temp
!      pflux
!      tflux
!      palog8
!      alogp8
!      i,j,k
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    convert press and pflux to cgs.
!---------------------------------------------------------------------
      press(:,:,:) = 10.0*Atmos_input%press(:,:,:)
      pflux(:,:,:) = 10.0*Atmos_input%pflux(:,:,:)
      tflux(:,:,:) = Atmos_input%tflux(:,:,:)
      temp(:,:,:) = Atmos_input%temp(:,:,:)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      israd = 1
      ierad = size(Atmos_input%press,1)
      jsrad = 1
      jerad = size(Atmos_input%press,2)
    
!---------------------------------------------------------------------
!    allocate module variables
!---------------------------------------------------------------------
      allocate (Gas_tf%a1      (ISRAD:IERAD, JSRAD:JERAD           ))
      allocate (Gas_tf%a2      (ISRAD:IERAD, JSRAD:JERAD           ))
      allocate (Gas_tf%tdav    (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD+1))
      allocate (Gas_tf%tlsqu   (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD+1))
      allocate (Gas_tf%tmpdiff (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD+1))
      allocate (Gas_tf%tstdav  (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD+1))
      allocate (Gas_tf%co2nbl  (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD  ))
      allocate (Gas_tf%n2o9c   (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD+1))
      allocate (Gas_tf%tn2o17  (ISRAD:IERAD, JSRAD:JERAD,KSRAD:KERAD+1))
      allocate (Gas_tf%co2spnb (ISRAD:IERAD, JSRAD:JERAD,  &
                                               KSRAD:KERAD+1,  NBCO215))
      Gas_tf%co2nbl  = 1.0                                         
      Gas_tf%co2spnb = 1.0                                           
      Gas_tf%n2o9c  = 0.                                          
      Gas_tf%tn2o17  = 0.0                                        

!--------------------------------------------------------------------
!    compute temperature difference between model profile and 
!    standard profile
!---------------------------------------------------------------------
      do k = KSRAD,KERAD+1
        Gas_tf%tmpdiff(:,:,k) = temp(:,:,k) - stemp(k)
      enddo

!-----------------------------------------------------------------------
!    compute weighted temperature difference (tdav) and pressure
!    integrals (tstdav) from level KSRAD to level KERAD. the quotient 
!    of these will be used to obtain  the difference (dift) between the
!    model temperature profile and the standard profile.
!-----------------------------------------------------------------------
      Gas_tf%tstdav(:,:,KSRAD) = 0.0E+00
      Gas_tf%tdav  (:,:,KSRAD) = 0.0E+00
      do k=KSRAD,KERAD
        pdflux(:,:,k) = pflux(:,:,k+1) - pflux(:,:,k)
        Gas_tf%tstdav(:,:,k+1) = Gas_tf%tstdav(:,:,k) + gtemp(k)* &
                                 pdflux(:,:,k)
        Gas_tf%tdav  (:,:,k+1) = Gas_tf%tdav  (:,:,k) + gtemp(k)* &
                                 pdflux(:,:,k)*Gas_tf%tmpdiff(:,:,k)
      enddo

!----------------------------------------------------------------------
!    evaluate coefficients for co2 pressure interpolation (a1, a2).
!    a linear interpolation is presently assumed, with the 2 
!    2nd pressure profile having pressures 0.8* the first, thus
!    accounting for the 0.8 and 0.2 factors.
!----------------------------------------------------------------------
      if (do_linearlblint) then
        Gas_tf%a1(:,:) = (press(:,:,KERAD+1) - pstd*0.8E+00)/ &
                         (pstd*0.2E+00)
        Gas_tf%a2(:,:) = (pstd - press(:,:,KERAD+1))/(pstd*0.2E+00)

!----------------------------------------------------------------------
!    a logarithmic interpolation is presently assumed, with the 2 
!    2nd pressure profile having pressures 0.8* the first, thus
!    accounting for the 0.8 and 0.2 factors. The denominator, which
!    is (log(pstd) - log(0.8*pstd)) is a constant (-log(0.8)) so the
!    expression can be replaced by the quantity palog8.
!----------------------------------------------------------------------
      else if (do_loglblint) then 
        alogps8 = ALOG(pstd*0.8E+00)
        palog8 = -ALOG(0.8E+00)
        Gas_tf%a1(:,:) = (ALOG(press(:,:,KERAD+1)) - alogps8)/palog8
        Gas_tf%a2(:,:) = 1.0E+00 - Gas_tf%a1(:,:)
      else 
        call error_mesg ('gas_tf_mod', &
              'neither linearlblint nor loglblint was specified.', &
                                                                FATAL)
      endif

!----------------------------------------------------------------------
!    compute temperature coefficient based on tflux. see fels and
!    schwarzkopf (1981) for details.
!----------------------------------------------------------------------
      tdif(:,:,:) = tflux(:,:,:) - 2.5E+02
      do k=KSRAD,KERAD+1
        do j=JSRAD,JERAD
          do i=ISRAD,IERAD
            if (tflux(i,j,k) .LE. 2.5E+02) then
              Gas_tf%tlsqu(i,j,k) = b0 +     tdif (i,j,k)  *  &
                                   (b1 +     tdif (i,j,k)  *  &
                                   (b2 + b3* tdif (i,j,k)  )) 
            else 
              Gas_tf%tlsqu(i,j,k) = b0 
            endif
          enddo
        enddo
      enddo


!----------------------------------------------------------------------
!    call transfn to compute temperature-corrected co2 transmission 
!    functions (co2spnb and co2nbl). 
!---------------------------------------------------------------------
    if (Lw_control%do_co2) then
      call transfn (Gas_tf)
    endif

!-------------------------------------------------------------------

end subroutine co2coef





!#####################################################################
! <SUBROUTINE NAME="transcol">
!  <OVERVIEW>
!   Subroutine to compute temperature-corrected co2 transmission 
!   functions at a particular (krow).
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute temperature-corrected co2 transmission 
!   functions at a particular (krow).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call transcol (kcol, krow, kcols, kcole, co21c, Gas_tf)
!  </TEMPLATE>
!  <IN NAME="kcol" TYPE="integer">
!   Not used
!  </IN>
!  <IN NAME="krow" TYPE="integer">
!   The row index where co2 transmission is calculated
!  </IN>
!  <IN NAME="kcols" TYPE="integer">
!   The starting column index number
!  </IN>
!  <IN NAME="kcole" TYPE="integer">
!   The ending column index number
!  </IN>
!  <OUT NAME="co21c" TYPE="real">
!   The column of transmission functions
!  </OUT>
!  <IN NAME="Gas_tf" TYPE="gas_tf_type">
!   The pre temperature-corrected co2 transmission functions
!  </IN>
! </SUBROUTINE>
!
subroutine transcol (kcol, krow, kcols, kcole, co21c, Gas_tf)        

!---------------------------------------------------------------------
!    transcol computes temperature-corrected co2 transmission 
!    functions at a particular (krow).
!    author: c. l. kerr
!    revised: 11/11/93
!    certified:  radiation version 1.0
!---------------------------------------------------------------------

integer,                intent(in)  :: krow, kcol, kcols, kcole
real, dimension(:,:,:), intent(out) :: co21c
type(gas_tf_type),      intent(in)  :: Gas_tf

!-------------------------------------------------------------------
!  intent(in) variables:
!
!      krow
!      kcol
!      kcols
!      kcole
!      Gas_tf
!
!  intent(out) variables:
!
!      co21c    column of transmission functions.
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(Gas_tf%tdav,1),&
                       size(Gas_tf%tdav,2), &
                       size(Gas_tf%tdav,3)  ) ::   &  
                                            co2r, dift,  d2cdt2, dco2dt
      integer    ::   kp

!---------------------------------------------------------------------
!  local variables:
!
!    co2r
!    dift
!    d2cdt2
!    dco2dt
!    k,kp
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
              'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      co21c(:,:,KSRAD:KERAD+1) = 1.0E+00

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do kp = kcols,kcole
        if (kp .NE. krow) then
          dift(:,:,kp) = (Gas_tf%tdav  (:,:,kp) -   &
                          Gas_tf%tdav(:,:,krow))/  &
                         (Gas_tf%tstdav(:,:,kp) -  &
                          Gas_tf%tstdav(:,:,krow))
        else if (krow .NE. KSRAD) then
          dift(:,:,kp) = 0.5E+00*(Gas_tf%tmpdiff(:,:,kp) +  &
                                  Gas_tf%tmpdiff(:,:,kp-1))
        else
          dift(:,:,kp) = 0.0E+00
        endif
      end do

!----------------------------------------------------------------------
!    obtain transmission functions used for the flux at a fixed level
!    (krow). ie, tf's  from varying flux levels (kp) to (krow)
!       pressure interpolation
!----------------------------------------------------------------------
      do kp=kcols,kcole
        co2r  (:,:,kp) = Gas_tf%a1(:,:)*co251(kp,krow) + &
                         Gas_tf%a2(:,:)*co258(kp,krow)
        dco2dt(:,:,kp) = 1.0E-02*(Gas_tf%a1(:,:)*cdt51(kp,krow) +   &
                                  Gas_tf%a2(:,:)*cdt58(kp,krow))
        d2cdt2(:,:,kp) = 1.0E-03*(Gas_tf%a1(:,:)*c2d51(kp,krow) +  &
                                  Gas_tf%a2(:,:)*c2d58(kp,krow))
      enddo
 
!----------------------------------------------------------------------
!    temperature interpolation
!----------------------------------------------------------------------
      do kp=kcols,kcole
        co21c (:,:,kp) = co2r(:,:,kp) + dift(:,:,kp)*(dco2dt(:,:,kp) + &
                         0.5E+00*dift(:,:,kp)*d2cdt2(:,:,kp))
      enddo
 
!----------------------------------------------------------------------
!    correction for finite width of co2 bands
!    (Eqs. 7a-7c, Ref. (2))
!----------------------------------------------------------------------
      do kp=kcols,kcole
        co21c(:,:,kp) = co21c(:,:,kp)*(1.0E+00 -  &
                        Gas_tf%tlsqu(:,:,kp)) +  &
                        Gas_tf%tlsqu(:,:,kp)
      enddo

!----------------------------------------------------------------


end subroutine transcol



 
!#####################################################################
! <SUBROUTINE NAME="transcolrow">
!  <OVERVIEW>
!   Subroutine to compute temperature-corrected co2/ch4/n2o transmission 
!   functions at a particular row and particular column.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute temperature-corrected co2/ch4/n2o transmission 
!   functions at a particular row and particular column.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call transcolrow (Gas_tf, kcol, krow, kcols, kcole, krows, krowe,    &
!                     co21c, co21r, tch4n2oe)   
!  </TEMPLATE>
!  <IN NAME="kcol" TYPE="integer">
!   The column index of temperature-corrected transmission function
!  </IN>
!  <IN NAME="krow" TYPE="integer">
!   The row index of temperature-corrected transmission function
!  </IN>
!  <IN NAME="kcols" TYPE="integer">
!   The starting column index number
!  </IN>
!  <IN NAME="kcole" TYPE="integer">
!   The ending column index number
!  </IN>
!  <IN NAME="krows" TYPE="integer">
!   The starting row index number
!  </IN>
!  <IN NAME="krowe" TYPE="integer">
!   The ending row index number
!  </IN>
!  <OUT NAME="co21c" TYPE="real">
!   The column of transmission functions
!  </OUT>
!  <OUT NAME="co21r" TYPE="real">
!   The row of transmission functions
!  </OUT>
!  <INOUT NAME="tch4n2oe" TYPE="real">
!   The ch4 and n2o transmission functions
!  </INOUT>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   The pre temperature-corrected co2 transmission functions
!  </INOUT>
! </SUBROUTINE>
!
subroutine transcolrow (Gas_tf, kcol, krow, kcols, kcole, krows, krowe,&
                        co21c, co21r, tch4n2oe)                     

!----------------------------------------------------------------------
!    transcolrow computes the temperature-corrected co2 transmission 
!    functions for a particular (krow) (varying column index) and for 
!    a particular (kcol) (varying row index).
!    transcolrow also computes the pressure-interpolated ch4 and n2o
!    transmission functions for a particular (krow) and for a parti-
!    cular (kcol). By assumption, no correction for finite bandwidth
!    is performed.
!    author: c. l. kerr
!    revised: 11/11/93
!    certified:  radiation version 1.0
!----------------------------------------------------------------------

integer,                   intent(in)    ::  kcol, krow, kcols, kcole, &
                                             krows, krowe
type(gas_tf_type),         intent(inout) ::  Gas_tf
real, dimension (:,:,:),   intent(out)   :: co21c, co21r
real, dimension (:,:,:,:), intent(inout) :: tch4n2oe

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     kcol
!     krow
!     kcols
!     kcole
!     krows
!     krowe
!
!  intent(inout) variables:
!
!     Gas_tf
!     tch4n2oe
!
!  intent(out) variables:
!     
!     co21c    column of transmission functions (fixed krow).
!     co21r    column of transmission functions (fixed kcol).
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real, dimension (size(Gas_tf%tdav,1),  &
                       size(Gas_tf%tdav,2), &
                       size(Gas_tf%tdav,3)  ) ::   &  
                                           ch41c, n2o1c, n2o17c,&
                                           co2p, dift, d2cdt2, dco2dt,&
                                           ch4p, d2ch4dt2, dch4dt, &
                                           d2n2odt2, dn2odt,    &
                                           d2n2o17dt2, dn2o17dt, &
                                           d2n2o9dt2, dn2o9dt, n2op,  &
                                           n2o17p, n2o9p

      integer    :: kp

!--------------------------------------------------------------------
!   local variables:
!
!      ch41c  = column of ch4 transmission functions (fixed krow).
!      ch41r  = column of ch4 transmission functions (fixed kcol).
!      n2o1c  = column of n2o transmission functions (fixed krow).
!      n2o1r  = column of n2o transmission functions (fixed kcol).
!      n2o17c = column of n2o 17 um transmission functions (fixed krow).
!      n2o17r = column of n2o 17 um transmission functions (fixed kcol).
!      n2o9c = column of n2o 9 um transmission functions (fixed krow).
!      n2o9r = column of n2o 9 um transmission functions (fixed kcol).
!      kp
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
              'module has not been initialized', FATAL )
      endif

!-----------------------------------------------------------------------
!    initialization.
!-----------------------------------------------------------------------
      co21c(:,:,kcols:kcole  ) = 1.0E+00
      co21r(:,:,KSRAD:KERAD+1) = 1.0E+00
      ch41c(:,:,kcols:kcole  ) = 1.0E+00
      n2o1c(:,:,kcols:kcole) = 1.0E+00
      n2o17c(:,:,KSRAD:KERAD+1) = 1.0E+00
      Gas_tf%n2o9c(:,:,KSRAD:KERAD+1) = 1.0E+00

!-----------------------------------------------------------------------
!    temperature difference averaged between levels k and kp
!-----------------------------------------------------------------------
      do kp = kcols,kcole
        if (kp .NE. krow) then
          dift(:,:,kp) = (Gas_tf%tdav  (:,:,kp) -  &
                          Gas_tf%tdav  (:,:,krow))/  &
                         (Gas_tf%tstdav(:,:,kp) -  &
                          Gas_tf%tstdav(:,:,krow))
        elseif (krow .NE. KSRAD) then
          dift(:,:,kp) = 0.5E+00*(Gas_tf%tmpdiff(:,:,kp) + &
                                  Gas_tf%tmpdiff(:,:,kp-1))
        else
          dift(:,:,kp) = 0.0E+00
        endif
      end do

!-----------------------------------------------------------------------
!    obtain transmission functions used for the flux at a fixed level
!    (krow). ie, tf's  from varying flux levels (kp) to (krow)
!       pressure interpolation
!-----------------------------------------------------------------------
      do kp=kcols,kcole
        if (Lw_control%do_co2) then
        co2p  (:,:,kp) = Gas_tf%a1(:,:)*co251(kp,krow) +  &
                         Gas_tf%a2(:,:)*co258(kp,krow)
        dco2dt(:,:,kp) = 1.0E-02*(Gas_tf%a1(:,:)*cdt51(kp,krow) +   &
                                  Gas_tf%a2(:,:)*cdt58(kp,krow))
        d2cdt2(:,:,kp) = 1.0E-03*(Gas_tf%a1(:,:)*c2d51(kp,krow) +   &
                                  Gas_tf%a2(:,:)*c2d58(kp,krow))
        endif
        if (Lw_control%do_ch4) then
          if (Lw_control%do_ch4lbltmpint) then
            ch4p (:,:,kp)  = Gas_tf%a1(:,:)*ch451(kp,krow) +  &
                             Gas_tf%a2(:,:)*ch458(kp,krow)
            dch4dt(:,:,kp) = 1.0E-02*(Gas_tf%a1(:,:)*ch4dt51(kp,krow) +&
                                      Gas_tf%a2(:,:)*ch4dt58(kp,krow))
            d2ch4dt2(:,:,kp) = 1.0E-03*  &
                                  (Gas_tf%a1(:,:)*ch4d2t51(kp,krow) +  &
                                   Gas_tf%a2(:,:)*ch4d2t58(kp,krow))
          else
            ch41c(:,:,kp)  = Gas_tf%a1(:,:)*ch451(kp,krow) +  &
                             Gas_tf%a2(:,:)*ch458(kp,krow)
          endif
        endif
        if (Lw_control%do_n2o) then
          if (Lw_control%do_n2olbltmpint) then
            n2op (:,:,kp)  = Gas_tf%a1(:,:)*n2o51(kp,krow) + &
                             Gas_tf%a2(:,:)*n2o58(kp,krow)
            n2o17p(:,:,kp) = Gas_tf%a1(:,:)*n2o71(kp,krow) + &
                             Gas_tf%a2(:,:)*n2o78(kp,krow)
            n2o9p(:,:,kp) = Gas_tf%a1(:,:)*n2o91(kp,krow) + &
                            Gas_tf%a2(:,:)*n2o98(kp,krow)
            dn2odt(:,:,kp) = 1.0E-02*(Gas_tf%a1(:,:)*n2odt51(kp,krow) +&
                                    Gas_tf%a2(:,:)*n2odt58(kp,krow))
            dn2o17dt(:,:,kp) = 1.0E-02* &
                                    (Gas_tf%a1(:,:)*n2odt71(kp,krow) +&
                                     Gas_tf%a2(:,:)*n2odt78(kp,krow))
            dn2o9dt(:,:,kp) = 1.0E-02*  &
                                    (Gas_tf%a1(:,:)*n2odt91(kp,krow) + &
                                     Gas_tf%a2(:,:)*n2odt98(kp,krow))
            d2n2odt2(:,:,kp) = 1.0E-03*  &
                                  (Gas_tf%a1(:,:)*n2od2t51(kp,krow) +  &
                                   Gas_tf%a2(:,:)*n2od2t58(kp,krow))
            d2n2o17dt2(:,:,kp) = 1.0E-03* &
                                  (Gas_tf%a1(:,:)*n2od2t71(kp,krow) +  &
                                   Gas_tf%a2(:,:)*n2od2t78(kp,krow))
            d2n2o9dt2(:,:,kp) = 1.0E-03*  &
                                  (Gas_tf%a1(:,:)*n2od2t91(kp,krow) +  &
                                   Gas_tf%a2(:,:)*n2od2t98(kp,krow))
          else
            n2o1c(:,:,kp)  = Gas_tf%a1(:,:)*n2o51(kp,krow) + &
                             Gas_tf%a2(:,:)*n2o58(kp,krow)
            n2o17c(:,:,kp) = Gas_tf%a1(:,:)*n2o71(kp,krow) + &
                             Gas_tf%a2(:,:)*n2o78(kp,krow)
            Gas_tf%n2o9c(:,:,kp) = Gas_tf%a1(:,:)*n2o91(kp,krow) +  &
                                   Gas_tf%a2(:,:)*n2o98(kp,krow)
          endif
        endif
      enddo

!----------------------------------------------------------------------
!    temperature interpolation
!----------------------------------------------------------------------
      do kp=kcols,kcole
        if (Lw_control%do_co2) then
        co21c (:,:,kp) = co2p(:,:,kp) + dift(:,:,kp)*(dco2dt(:,:,kp) + &
                         0.5E+00*dift(:,:,kp)*d2cdt2(:,:,kp))
        endif
        if (Lw_control%do_ch4lbltmpint) then
          ch41c (:,:,kp) = ch4p(:,:,kp) + dift(:,:,kp)* &
                           (dch4dt(:,:,kp) + 0.5E+00*dift(:,:,kp)* &
                            d2ch4dt2(:,:,kp))
        endif
        if (Lw_control%do_n2olbltmpint) then
          n2o1c (:,:,kp) = n2op(:,:,kp) + dift(:,:,kp)* &
                           (dn2odt(:,:,kp) + 0.5E+00*dift(:,:,kp)* &
                            d2n2odt2(:,:,kp))
          n2o17c(:,:,kp) = n2o17p(:,:,kp) +  &
                           dift(:,:,kp)*(dn2o17dt(:,:,kp) +  &
                           0.5E+00*dift(:,:,kp)*d2n2o17dt2(:,:,kp))
          Gas_tf%n2o9c(:,:,kp) = n2o9p(:,:,kp) +   &
                                 dift(:,:,kp)*(dn2o9dt(:,:,kp) +  &
                                 0.5E+00*dift(:,:,kp)*d2n2o9dt2(:,:,kp))
        endif
      enddo

!---------------------------------------------------------------------
!    correction for finite width of co2 bands
!    (Eqs. 7a-7c, Ref. (2))
!---------------------------------------------------------------------
      do kp=kcols,kcole
        if (Lw_control%do_co2) then
        co21c(:,:,kp) = co21c(:,:,kp)*(1.0E+00 -  &
                        Gas_tf%tlsqu(:,:,kp)) + Gas_tf%tlsqu(:,:,kp)
        endif
      enddo

!-----------------------------------------------------------------------
!    obtain transmission functions used for the flux for varying levels
!    (krow) from a fixed level (kcol). ie, tf's  from a fixed flux
!    level (kcol) to varying levels (krow).
!-----------------------------------------------------------------------
 
!-----------------------------------------------------------------------
!    temperature difference averaged between levels k and kp. This 
!    computation is made unless krow = kcol, and range (krows,krowe) is
!    entirely within (kcols,kcole), in which case the dift computed
!    for column tfs is applicable to row tfs.
!-----------------------------------------------------------------------
      if (Lw_control%do_co2) then
        if (kcol  .NE. krow   .or. krows .LT. kcols  .or.  &
            krowe .GT. kcole)     then
          do kp = krows,krowe
            if (kp .NE. krow) then
              dift(:,:,kp) = (Gas_tf%tdav(:,:,kp) -  &
                              Gas_tf%tdav(:,:,krow))/  &
                             (Gas_tf%tstdav(:,:,kp) -  &
                              Gas_tf%tstdav(:,:,krow))
            elseif (krow .NE. KSRAD) then
              dift(:,:,kp) = 0.5E+00*(Gas_tf%tmpdiff(:,:,kp) +  &
                                      Gas_tf%tmpdiff(:,:,kp-1))
            else
              dift(:,:,kp) = 0.0E+00
            endif
          end do
        endif
      endif  ! (do_co2)

!--------------------------------------------------------------------
!    pressure interpolation
!--------------------------------------------------------------------
      do kp=krows,krowe
        if (Lw_control%do_co2) then
        co2p  (:,:,kp) = Gas_tf%a1(:,:)*co251(kcol,kp) +  &
                         Gas_tf%a2(:,:)*co258(kcol,kp)
        dco2dt(:,:,kp) = 1.0E-02*(Gas_tf%a1(:,:)*cdt51(kcol,kp) +   &
                                  Gas_tf%a2(:,:)*cdt58(kcol,kp))
        d2cdt2(:,:,kp) = 1.0E-03*(Gas_tf%a1(:,:)*c2d51(kcol,kp) +   &
                                  Gas_tf%a2(:,:)*c2d58(kcol,kp))
        endif
        if (Lw_control%do_ch4) then
          if (Lw_control%do_ch4lbltmpint) then
            ch4p (:,:,kp)  = Gas_tf%a1(:,:)*ch451(kcol,kp) +  &
                             Gas_tf%a2(:,:)*ch458(kcol,kp)
            dch4dt(:,:,kp) = 1.0E-02* &
                             (Gas_tf%a1(:,:)*ch4dt51(kcol,kp) +   &
                              Gas_tf%a2(:,:)*ch4dt58(kcol,kp))
            d2ch4dt2(:,:,kp) = 1.0E-03*  &
                               (Gas_tf%a1(:,:)*ch4d2t51(kcol,kp) +  &
                                Gas_tf%a2(:,:)*ch4d2t58(kcol,kp))
          endif
        endif
        if (Lw_control%do_n2o) then
          if (Lw_control%do_n2olbltmpint) then
            n2op (:,:,kp)  = Gas_tf%a1(:,:)*n2o51(kcol,kp) +&
                             Gas_tf%a2(:,:)*n2o58(kcol,kp)
            n2o17p(:,:,kp) = Gas_tf%a1(:,:)*n2o71(kcol,kp) + &
                             Gas_tf%a2(:,:)*n2o78(kcol,kp)
            n2o9p(:,:,kp) = Gas_tf%a1(:,:)*n2o91(kcol,kp) + &
                            Gas_tf%a2(:,:)*n2o98(kcol,kp)
            dn2odt(:,:,kp) = 1.0E-02* &
                             (Gas_tf%a1(:,:)*n2odt51(kcol,kp) +  &
                              Gas_tf%a2(:,:)*n2odt58(kcol,kp))
            dn2o17dt(:,:,kp) = 1.0E-02* &
                               (Gas_tf%a1(:,:)*n2odt71(kcol,kp) +   &
                                Gas_tf%a2(:,:)*n2odt78(kcol,kp))
            dn2o9dt(:,:,kp) = 1.0E-02* &
                              (Gas_tf%a1(:,:)*n2odt91(kcol,kp) +   &
                               Gas_tf%a2(:,:)*n2odt98(kcol,kp))
            d2n2odt2(:,:,kp) = 1.0E-03* &
                               (Gas_tf%a1(:,:)*n2od2t51(kcol,kp) +   &
                                Gas_tf%a2(:,:)*n2od2t58(kcol,kp))
            d2n2o17dt2(:,:,kp) = 1.0E-03* &
                                 (Gas_tf%a1(:,:)*n2od2t71(kcol,kp) +   &
                                  Gas_tf%a2(:,:)*n2od2t78(kcol,kp))
            d2n2o9dt2(:,:,kp) = 1.0E-03* &
                                (Gas_tf%a1(:,:)*n2od2t91(kcol,kp) +   &
                                 Gas_tf%a2(:,:)*n2od2t98(kcol,kp))
          endif
        endif
      enddo

!---------------------------------------------------------------------
!    temperature interpolation
!---------------------------------------------------------------------
      do kp=krows,krowe
        if (Lw_control%do_co2) then
        co21r (:,:,kp) = co2p(:,:,kp) + dift(:,:,kp)*(dco2dt(:,:,kp) +&
                         0.5E+00*dift(:,:,kp)*d2cdt2(:,:,kp))
        endif
      enddo

!---------------------------------------------------------------------
!    correction for finite width of co2 bands
!    (Eqs. 7a-7c, Ref. (2))
!---------------------------------------------------------------------
      do kp=krows,krowe
        if (Lw_control%do_co2) then
        co21r(:,:,kp) = co21r(:,:,kp)*(1.0E+00 -  &
                        Gas_tf%tlsqu(:,:,kcol)) +  &
                        Gas_tf%tlsqu(:,:,kcol)
        endif
      enddo

!----------------------------------------------------------------------
!    save the values which are needed elsewhere
!    tn2o17 results are for 560-630 cm-1 band. (if NBCO215=3)
!----------------------------------------------------------------------
      if (Lw_control%do_ch4 .or. Lw_control%do_n2o) then
        if (kcols == 1) then
          tch4n2oe(:,:,kcols,1) = ch41c(:,:,kcols)*n2o1c(:,:,kcols)
        endif
        tch4n2oe(:,:,kcols+1:kcole,1) = ch41c(:,:,kcols+1:kcole)*  &
                                        n2o1c(:,:,kcols+1:kcole)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      Gas_tf%tn2o17(:,:,:) = n2o17c(:,:,:)

!---------------------------------------------------------------------



end subroutine transcolrow




!#####################################################################
! <SUBROUTINE NAME="trans_nearby">
!  <OVERVIEW>
!   Compute nearby layer transmission functions at certain level in
!   the frequency band at 15 um
!  </OVERVIEW>
!  <DESCRIPTION>
!   Compute "nearby  layer" transmission functions at level k 
!  ( tau(p(k),p(k))) in the frequency band at 15 um. include all
!  gases (co2, h2o, h2o cont) used in computing fluxes in this band.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call trans_nearby (Gas_tf, Atmos_input, overod, co2diag)
!  </TEMPLATE>
!  <IN NAME="Gas_tf" TYPE="gas_tf_type">
!   The gas transmission functions at model coordinate system
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   The atmospheric input data
!  </IN>
!  <IN NAME="overod" TYPE="real">
!   CO2 data
!  </IN>
!  <OUT NAME="co21diag" TYPE="real">
!   CO2 transmission function
!  </OUT>
! </SUBROUTINE>
subroutine trans_nearby (Gas_tf, Atmos_input, overod, co21diag)
 
!-------------------------------------------------------------------
!    compute "nearby  layer" transmission functions at level k 
!    ( tau(p(k),p(k))) in the frequency band at 15 um. include all
!    gases (co2, h2o, h2o cont) used in computing fluxes in this band.
!    the algorithm assumes that at pressures (p') near the pressure
!    at level k (p(k)), the transmission function may be written as:
!
!              tau(p',p(k)) = EXP(-alpha*SQRT(p'-p(k)))
!
!    with alpha determined by the boundary condition(s)
!    tau(p(k+1),p(k)) and tau(p(k-1),p(k)) = the values from  "normal"
!    calculations. An integration is performed over the "nearby" 
!    pressure layer to obtain tau(p(k),p(k)).
!    the computation is not done for levels from KSRAD to KMINH2O-1 (if
!    different), where it is assumed that the h2o transmissivities 
!    are near unity, and that the precomputed co2 transmissivities may
!    be used.
!     two "special case" transmissivities, viz.,
!    tau(p(KERAD),p(KERAD+1)) and tau(p(KERAD+1),p(KERAD)) are also 
!    evaluated using the above assumptions and an integration.
!-------------------------------------------------------------------

type(gas_tf_type),       intent(in)  :: Gas_tf
type(atmos_input_type),  intent(in)  :: Atmos_input
real, dimension (:,:,:), intent(in)  :: overod  
real, dimension (:,:,:), intent(out) :: co21diag

!--------------------------------------------------------------------
! intent(in) variables:
!
!    Gas_tf
!    Atmos_input
!    overod
!
! intent(out) variables:
!
!    co21diag
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:




      real, dimension (size(Atmos_input%pflux,1),  &
                       size(Atmos_input%pflux,2),  &
                       size(Atmos_input%pflux,3)-1) :: pdfinv

      real, dimension (size(Atmos_input%pflux,1), &
                       size(Atmos_input%pflux,2),  &
                       size(Atmos_input%pflux,3)) ::         &
               press, pflux, alpa, alpb, ca, cb, delpr1, delpr2, rlog

      integer   :: k, km, kmp1

!-------------------------------------------------------------------
!  local variables:
!
!    pdfl
!    pdfinv
!    press
!
!    k
!
!    kmp1
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    convert press and pflux to cgs.
!---------------------------------------------------------------------
      press(:,:,:) = 10.0*Atmos_input%press(:,:,:)
      pflux(:,:,:) = 10.0*Atmos_input%pflux(:,:,:)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      pdfinv(:,:,KSRAD:KERAD) = 1.0/(pflux(:,:,KSRAD+1:KERAD+1) -   &
                                     pflux(:,:,KSRAD:KERAD) )

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      km= MAX(ixprkminh2o - 1, KSRAD)
      kmp1 = MAX(ixprkminh2o - 1, KSRAD+1)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      rlog  (:,:,km:KERAD)     = LOG(Gas_tf%co2nbl(:,:,km:KERAD)*   &
                                 overod(:,:,km+1:KERAD+1))
      delpr1(:,:,kmp1:KERAD)   = pdfinv (:,:,kmp1:KERAD)*  &
                                 (press(:,:,kmp1:KERAD) - &
                                  pflux(:,:,kmp1:KERAD)) 
      alpb  (:,:,kmp1:KERAD)   = -SQRT(delpr1(:,:,kmp1:KERAD))*  &
                                  rlog(:,:,kmp1:KERAD)
      delpr2(:,:,kmp1:KERAD+1) = pdfinv(:,:,kmp1-1:KERAD)*  &
                                 (pflux(:,:,kmp1:KERAD+1) -  &
                                  press(:,:,kmp1-1:KERAD)) 
      alpa  (:,:,km:KERAD)     = -SQRT(delpr2(:,:,km+1:KERAD+1))*  &
                                 rlog(:,:,km:KERAD)
      alpa  (:,:,KERAD+1)      = -rlog(:,:,KERAD)
      alpb  (:,:,KERAD+1)      = -rlog(:,:,KERAD)* &
                                  SQRT(pdfinv(:,:,KERAD)*&
                                 (pflux(:,:,KERAD+1) -   &
                                  press(:,:,KERAD-1)))
      ca(:,:,km:KERAD+1) = alpa(:,:,km:KERAD+1)*(-0.66667E+00 +  &
                           alpa(:,:,km:KERAD+1)*(0.25E+00 +   &
                           alpa(:,:,km:KERAD+1)*(-0.066667E+00)))
      cb(:,:,kmp1:KERAD+1) = alpb(:,:,kmp1:KERAD+1)*(-0.66667E+00 +  &
                             alpb(:,:,kmp1:KERAD+1)*(0.25E+00 +    &
                             alpb(:,:,kmp1:KERAD+1)*(-0.066667E+00)))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do k=ixprkminh2o,KERAD
        co21diag(:,:,k) = 1.0E+00 + 0.5E+00*(cb(:,:,k) + ca(:,:,k-1))
      enddo
      co21diag(:,:,KERAD+1) = 1.0E+00 + ca(:,:,KERAD)

!-------------------------------------------------------------------




end subroutine trans_nearby

!#####################################################################
! <SUBROUTINE NAME="trans_sfc">
!  <OVERVIEW>
!   Compute nearby layer transmission functions at certain level in
!   the frequency band at 15 um
!  </OVERVIEW>
!  <DESCRIPTION>
!   Compute "nearby  layer" transmission functions at level k 
!  ( tau(p(k),p(k))) in the frequency band at 15 um. include all
!  gases (co2, h2o, h2o cont) used in computing fluxes in this band.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call trans_sfc    (Gas_tf, Atmos_input, overod, co21c, co21r)
!  </TEMPLATE>
!  <IN NAME="Gas_tf" TYPE="gas_tf_type">
!   The gas transmission functions at model coordinate system
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   The atmospheric input data
!  </IN>
!  <IN NAME="overod" TYPE="real">
!   CO2 data
!  </IN>
!  <OUT NAME="co21c" TYPE="real">
!   CO2 transmission function
!  </OUT>
!  <OUT NAME="co21r" TYPE="real">
!   CO2 transmission function
!  </OUT>
! </SUBROUTINE>
!subroutine trans_sfc    (Gas_tf, Atmos_input, overod, co21c, co21diag, co21r)
subroutine trans_sfc (Gas_tf, Atmos_input, overod, co21c, co21r)
 
!-------------------------------------------------------------------
!    compute "nearby  layer" transmission functions at level k 
!    ( tau(p(k),p(k))) in the frequency band at 15 um. include all
!    gases (co2, h2o, h2o cont) used in computing fluxes in this band.
!    the algorithm assumes that at pressures (p') near the pressure
!    at level k (p(k)), the transmission function may be written as:
!
!              tau(p',p(k)) = EXP(-alpha*SQRT(p'-p(k)))
!
!    with alpha determined by the boundary condition(s)
!    tau(p(k+1),p(k)) and tau(p(k-1),p(k)) = the values from  "normal"
!    calculations. An integration is performed over the "nearby" 
!    pressure layer to obtain tau(p(k),p(k)).
!    the computation is not done for levels from KSRAD to KMINH2O-1 (if
!    different), where it is assumed that the h2o transmissivities 
!    are near unity, and that the precomputed co2 transmissivities may
!    be used.
!     two "special case" transmissivities, viz.,
!    tau(p(KERAD),p(KERAD+1)) and tau(p(KERAD+1),p(KERAD)) are also 
!    evaluated using the above assumptions and an integration.
!-------------------------------------------------------------------

type(gas_tf_type),       intent(in)  :: Gas_tf
type(atmos_input_type),  intent(in)  :: Atmos_input
real, dimension (:,:,:), intent(in)  :: overod  
real, dimension (:,:),   intent(out) :: co21c, co21r

!--------------------------------------------------------------------
! intent(in) variables:
!
!    Gas_tf
!    Atmos_input
!    overod
!
! intent(out) variables:
!
!    co21c
!    co21r
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension (size(Atmos_input%pflux,1),  &
                       size(Atmos_input%pflux,2)) :: pdfl

      real, dimension (size(Atmos_input%pflux,1),  &
                       size(Atmos_input%pflux,2),  &
                       size(Atmos_input%pflux,3)-1) :: pdfinv

      real, dimension (size(Atmos_input%pflux,1), &
                       size(Atmos_input%pflux,2),  &
                       size(Atmos_input%pflux,3)) ::         &
               press, pflux, alpa, alpb, ca, cb, delpr1, delpr2, rlog

      integer   ::  km, kmp1

!-------------------------------------------------------------------
!  local variables:
!
!    pdfl
!    pdfinv
!    press
!
!    k
!
!    kmp1
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    convert press and pflux to cgs.
!---------------------------------------------------------------------
      press(:,:,:) = 10.0*Atmos_input%press(:,:,:)
      pflux(:,:,:) = 10.0*Atmos_input%pflux(:,:,:)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      pdfinv(:,:,KSRAD:KERAD) = 1.0/(pflux(:,:,KSRAD+1:KERAD+1) -   &
                                     pflux(:,:,KSRAD:KERAD) )

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      km= MAX(ixprkminh2o - 1, KSRAD)
      kmp1 = MAX(ixprkminh2o - 1, KSRAD+1)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      rlog  (:,:,km:KERAD)     = LOG(Gas_tf%co2nbl(:,:,km:KERAD)*   &
      overod(:,:,km+1:KERAD+1))
      delpr1(:,:,kmp1:KERAD)   = pdfinv (:,:,kmp1:KERAD)*  &
                                 (press(:,:,kmp1:KERAD) - &
                                  pflux(:,:,kmp1:KERAD)) 
      alpb  (:,:,kmp1:KERAD)   = -SQRT(delpr1(:,:,kmp1:KERAD))*  &
                                 rlog(:,:,kmp1:KERAD)
      delpr2(:,:,kmp1:KERAD+1) = pdfinv(:,:,kmp1-1:KERAD)*  &
                                 (pflux(:,:,kmp1:KERAD+1) -  &
                                  press(:,:,kmp1-1:KERAD)) 
      alpa  (:,:,km:KERAD)     = -SQRT(delpr2(:,:,km+1:KERAD+1))*  &
                                 rlog(:,:,km:KERAD)
      alpa  (:,:,KERAD+1)      = -rlog(:,:,KERAD)
      alpb  (:,:,KERAD+1)      = -rlog(:,:,KERAD)* &
                                 SQRT(pdfinv(:,:,KERAD)*&
                                 (pflux(:,:,KERAD+1) -  &
                                  press(:,:,KERAD-1)))
      ca(:,:,km:KERAD+1) = alpa(:,:,km:KERAD+1)*(-0.66667E+00 +  &
                           alpa(:,:,km:KERAD+1)*(0.25E+00 +   &
                           alpa(:,:,km:KERAD+1)*(-0.066667E+00)))
      cb(:,:,kmp1:KERAD+1) = alpb(:,:,kmp1:KERAD+1)*(-0.66667E+00 +  &
                             alpb(:,:,kmp1:KERAD+1)*(0.25E+00 +    &
                             alpb(:,:,kmp1:KERAD+1)*(-0.066667E+00)))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      pdfl(:,:) = pflux(:,:,KERAD+1) - pflux(:,:,KERAD)
      co21c(:,:        ) = 1.0E+00 +    &
                           (pdfl  (:,:      )*ca(:,:,KERAD+1) -    &
                           (press(:,:,KERAD) - pflux(:,:,KERAD))*   &
                            cb(:,:,KERAD))/   &
                            (pflux(:,:,KERAD+1) - press(:,:,KERAD))
      co21r(:,:        )   = 1.0E+00 +    &
                             ((pflux(:,:,KERAD+1) -  &
                               press(:,:,KERAD-1))*  &
                             cb(:,:,KERAD+1) -   &
                             (pflux(:,:,KERAD+1) - press(:,:,KERAD))*  &
                             ca(:,:,KERAD))/ &
                             (press(:,:,KERAD) - press(:,:,KERAD-1))

!-------------------------------------------------------------------




end subroutine trans_sfc


!####################################################################
! <SUBROUTINE NAME="put_co2_stdtf_for_gas_tf">
!  <OVERVIEW>
!   Assign co2 transmission functions
!  </OVERVIEW>
!  <DESCRIPTION>
!   Assign co2 transmission functions
!  </DESCRIPTION>
!  <TEMPLATE>
!   call put_co2_stdtf_for_gas_tf  (nf,        &
!                                      co251_o, co258_o,   &
!                                      cdt51_o, cdt58_o,   &
!                                      c2d51_o, c2d58_o)
!  </TEMPLATE>
!  <IN NAME="nf" TYPE="integer">
!   index variable
!  </IN>
!  <IN NAME="co251_o co258_o  cdt51_o cdt58_o  c2d51_o c2d58_o" TYPE="real">
!   CO2 transmission functions
!  </IN>
! </SUBROUTINE>
!
subroutine put_co2_stdtf_for_gas_tf (nf, co251_o, co258_o,   &
                                     cdt51_o, cdt58_o,   &
                                     c2d51_o, c2d58_o)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

integer,              intent(in)  :: nf
real, dimension(:,:), intent(in)  :: co251_o, co258_o,   &
                                     cdt51_o, cdt58_o,   &
                                     c2d51_o, c2d58_o

!-------------------------------------------------------------------
!  intent(in) variables:
!
!     nf
!     co251_o
!     co258_o
!     cdt51_o
!     cdt58_o
!     c2d51_o
!     c2d58_o
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (nf == 1) then
        co251 = co251_o
        co258 = co258_o
        cdt51 = cdt51_o
        cdt58 = cdt58_o
        c2d51 = c2d51_o
        c2d58 = c2d58_o
      else if (nf == 5) then
        co211(:) = co251_o(:,1)
        co218(:) = co258_o(:,1)
      endif

!--------------------------------------------------------------------


end subroutine put_co2_stdtf_for_gas_tf




!#####################################################################
! <SUBROUTINE NAME="put_co2_nbltf_for_gas_tf">
!  <OVERVIEW>
!   Assign co2 transmission functions
!  </OVERVIEW>
!  <DESCRIPTION>
!   Assign co2 transmission functions
!  </DESCRIPTION>
!  <TEMPLATE>
!   call put_co2_nbltf_for_gas_tf  (nf,       &
!                                      co2m51_o, cdtm51_o, c2dm51_o, &
!                                      co2m58_o, cdtm58_o, c2dm58_o, &
!                                      co215nbps1_o, co215nbps8_o,     &
!                                      co2dt15nbps1_o, co2dt15nbps8_o, &
!                                      co2d2t15nbps1_o, co2d2t15nbps8_o )
!  </TEMPLATE>
!  <IN NAME="nf" TYPE="integer">
!   index variable
!  </IN>
!  <IN NAME="co2m51_o, cdtm51_o, c2dm51_o, co2m58_o, cdtm58_o, c2dm58_o, co215nbps1_o, co215nbps8_o" TYPE="real">
!   CO2 transmission functions
!  </IN>
!  <IN NAME="co2dt15nbps1_o, co2dt15nbps8_o, co2d2t15nbps1_o, co2d2t15nbps8_o" TYPE="real">
!   CO2 transmission functions
!  </IN>
! </SUBROUTINE>
!
subroutine put_co2_nbltf_for_gas_tf  (nf,       &
                                      co2m51_o, cdtm51_o, c2dm51_o, &
                                      co2m58_o, cdtm58_o, c2dm58_o, &
                                      co215nbps1_o, co215nbps8_o,     &
                                      co2dt15nbps1_o, co2dt15nbps8_o, &
                                      co2d2t15nbps1_o, co2d2t15nbps8_o )

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
integer,              intent(in)  :: nf
real, dimension(:,:), intent(in)  :: co2m51_o, cdtm51_o, c2dm51_o, &
                                     co2m58_o, cdtm58_o, c2dm58_o
real, dimension(:),   intent(in)  :: co215nbps1_o, co215nbps8_o,     &
                                     co2dt15nbps1_o, co2dt15nbps8_o, &
                                     co2d2t15nbps1_o, co2d2t15nbps8_o

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     nf
!     co2m51_o
!     cdtm51_o
!     c2dm51_o
!     co2m58_o
!     cdtm58_o
!     c2dm58_o
!     co215nbsp1_o
!     co215nbsp8_o
!     co2dt15nbsp1_o
!     co2dt15nbsp8_o
!     co2d2t15nbps1_o
!     co2d2t15nbps8_o
!
!--------------------------------------------------------------------


!--------------------------------------------------------------------
!   local variables:

      integer    :: k    ! do-loop index

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
             'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (nf == 1) then
        do k=KSRAD,KERAD
          co2m51(k) = co2m51_o(k,k+1)
          co2m58(k) = co2m58_o(k,k+1)
          cdtm51(k) = cdtm51_o(k,k+1)
          cdtm58(k) = cdtm58_o(k,k+1)
          c2dm51(k) = c2dm51_o(k,k+1)
          c2dm58(k) = c2dm58_o(k,k+1)
        end do
      endif
      if (nf >= 2 .and. nf <= 4) then
        co215nbps1(:,nf-1) = co215nbps1_o(:)
        co215nbps8(:,nf-1) = co215nbps8_o(:)
        co2dt15nbps1(:,nf-1) = co2dt15nbps1_o(:)
        co2dt15nbps8(:,nf-1) = co2dt15nbps8_o(:)
        co2d2t15nbps1(:,nf-1) = co2d2t15nbps1_o(:)
        co2d2t15nbps8(:,nf-1) = co2d2t15nbps8_o(:)
      endif

!--------------------------------------------------------------------

end subroutine put_co2_nbltf_for_gas_tf




!#####################################################################
! <SUBROUTINE NAME="put_ch4_stdtf_for_gas_tf">
!  <OVERVIEW>
!   Assign ch4 transmission functions
!  </OVERVIEW>
!  <DESCRIPTION>
!   Assign ch4 transmission functions
!  </DESCRIPTION>
!  <TEMPLATE>
!   call put_ch4_stdtf_for_gas_tf  (             &
!                                      ch451_o, ch458_o,   &
!                                      ch4dt51_o, ch4dt58_o,   &
!                                      ch4d2t51_o, ch4d2t58_o)
!  </TEMPLATE>
!  <IN NAME="nf" TYPE="integer">
!   index variable
!  </IN>
!  <IN NAME="ch451_o, ch458_o, ch4dt51_o, ch4dt58_o, ch4d2t51_o, ch4d2t58_o" TYPE="real">
!   CH4 transmission functions
!  </IN>
! </SUBROUTINE>
!
subroutine put_ch4_stdtf_for_gas_tf  (             &
                                       ch451_o, ch458_o,   &
                                       ch4dt51_o, ch4dt58_o,   &
                                       ch4d2t51_o, ch4d2t58_o)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

real, dimension (:,:), intent(in) :: ch451_o, ch458_o,     &    
                                     ch4dt51_o, ch4dt58_o, &    
                                     ch4d2t51_o, ch4d2t58_o

!------------------------------------------------------------------
!  intent(in) variables:
!
!    ch451_o
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ch451 = ch451_o
      ch458 = ch458_o
      ch4dt51 = ch4dt51_o
      ch4dt58 = ch4dt58_o
      ch4d2t51 = ch4d2t51_o
      ch4d2t58 = ch4d2t58_o

!--------------------------------------------------------------------


end subroutine put_ch4_stdtf_for_gas_tf



!#####################################################################
! <SUBROUTINE NAME="put_n2o_stdtf_for_gas_tf">
!  <OVERVIEW>
!   Assign n2o transmission functions
!  </OVERVIEW>
!  <DESCRIPTION>
!   Assign n2o transmission functions
!  </DESCRIPTION>
!  <TEMPLATE>
!   call put_n2o_stdtf_for_gas_tf  (nf,         &
!                                      n2o1_o, n2o8_o,   &
!                                      n2odt1_o, n2odt8_o,   &
!                                      n2od2t1_o, n2od2t8_o)
!  </TEMPLATE>
!  <IN NAME="nf" TYPE="integer">
!   index variable
!  </IN>
!  <IN NAME="n2o1_o, n2o8_o, n2odt1_o, n2odt8_o, n2od2t1_o, n2od2t8_o" TYPE="real">
!   N2O transmission functions
!  </IN>
! </SUBROUTINE>
!
subroutine put_n2o_stdtf_for_gas_tf  (nf,         &
                                      n2o1_o, n2o8_o,   &
                                      n2odt1_o, n2odt8_o,   &
                                      n2od2t1_o, n2od2t8_o)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

integer,               intent(in) :: nf
real, dimension (:,:), intent(in) :: n2o1_o, n2o8_o,     &    
                                     n2odt1_o, n2odt8_o, &    
                                     n2od2t1_o, n2od2t8_o

!------------------------------------------------------------------
!  intent(in) variables:
!
!    nf       
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (nf == 1) then
        n2o51 = n2o1_o
        n2o58 = n2o8_o
        n2odt51 = n2odt1_o
        n2odt58 = n2odt8_o
        n2od2t51 = n2od2t1_o
        n2od2t58 = n2od2t8_o
      else if (nf == 3) then
        n2o71 = n2o1_o
        n2o78 = n2o8_o
        n2odt71 = n2odt1_o
        n2odt78 = n2odt8_o
        n2od2t71 = n2od2t1_o
        n2od2t78 = n2od2t8_o
      else if (nf == 2) then
        n2o91 = n2o1_o
        n2o98 = n2o8_o
        n2odt91 = n2odt1_o
        n2odt98 = n2odt8_o
        n2od2t91 = n2od2t1_o
        n2od2t98 = n2od2t8_o
      endif

!---------------------------------------------------------------------

end subroutine put_n2o_stdtf_for_gas_tf



!#####################################################################
! <SUBROUTINE NAME="get_control_gas_tf">
!  <OVERVIEW>
!   Turn on gas transmission function flag
!  </OVERVIEW>
!  <DESCRIPTION>
!   Turn on gas transmission function flag
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_control_gas_tf (calc_co2, calc_ch4, calc_n2o)
!  </TEMPLATE>
!  <OUT NAME="calc_co2, calc_ch4, calc_n2o" TYPE="logical">
!   logical variables that determine whether gas transmission functions
!   should be calculated.
!  </OUT>
! </SUBROUTINE>
subroutine get_control_gas_tf (calc_co2, calc_ch4, calc_n2o)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

logical, intent(out), optional     :: calc_co2, calc_ch4, calc_n2o

!------------------------------------------------------------------
!  intent(out),optional variables:
!
!    calc_co2 
!    calc_ch4 
!    calc_n2o 
!
!-------------------------------------------------------------------


!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
            'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      calc_co2 = do_calcstdco2tfs
      calc_ch4 = do_calcstdch4tfs
      calc_n2o = do_calcstdn2otfs

!---------------------------------------------------------------------


end subroutine get_control_gas_tf


!####################################################################
! <SUBROUTINE NAME="gas_tf_dealloc">
!  <OVERVIEW>
!    gas_tf_dealloc deallocates the array components of the gas_tf_type
!    input variable.
!  </OVERVIEW>
!  <DESCRIPTION>
!    gas_tf_dealloc deallocates the array components of the gas_tf_type
!    input variable.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call gas_tf_dealloc (Gas_tf)  
!  </TEMPLATE>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   gas_tf_type variable containing information needed
!   to define the gas transmission functions
!  </INOUT>
! </SUBROUTINE>
subroutine gas_tf_dealloc (Gas_tf)

!------------------------------------------------------------------
!    gas_tf_dealloc deallocates the array components of the gas_tf_type
!    input variable.
!--------------------------------------------------------------------

type(gas_tf_type), intent(inout) :: Gas_tf

!---------------------------------------------------------------------
!  intent(inout) variables:
!
!     Gas_tf     gas_tf_type variable containing information needed
!                to define the gas transmission functions
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    deallocate the array components of Gas_tf.
!---------------------------------------------------------------------
      deallocate (Gas_tf%tdav)
      deallocate (Gas_tf%tlsqu         )
      deallocate (Gas_tf%tmpdiff       )
      deallocate (Gas_tf%tstdav        )
      deallocate (Gas_tf%co2nbl        )
      deallocate (Gas_tf%n2o9c         )
      deallocate (Gas_tf%tn2o17        )
      deallocate (Gas_tf%co2spnb       )
      deallocate (Gas_tf%a1            )
      deallocate (Gas_tf%a2            )

!--------------------------------------------------------------------


end subroutine gas_tf_dealloc



!###################################################################
! <SUBROUTINE NAME="gas_tf_end">
!  <OVERVIEW>
!   End and clean up gas tranmission function calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   End and clean up gas tranmission function calculation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call gas_tf_end
!  </TEMPLATE>
! </SUBROUTINE>
!   
subroutine gas_tf_end

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variable:

      integer :: tfsunit  ! unit number for i/o

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ( 'gas_tf_mod', &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_writestdco2tfs) then
        if (mpp_pe() == mpp_root_pe() ) then
          tfsunit = open_restart_file ('stdco2tfs', action='write')
          write (tfsunit) valid_versions(nvalids)
          write (tfsunit) co2_name_save, co2_amount_save,   &
                           nstdlvls_save, kbegin_save, kend_save
          write (tfsunit) pd_save, plm_save, pa_save
          write (tfsunit) co215nbps1, co215nbps8, co2dt15nbps1,    & 
                          co2dt15nbps8, co2d2t15nbps1, co2d2t15nbps8
          write (tfsunit) co251, co258, cdt51, cdt58, c2d51, c2d58, &
                          co2m51, co2m58, cdtm51, cdtm58, c2dm51, c2dm58
          write (tfsunit) co211, co218
          call close_file (tfsunit)
        endif
      endif

      if (do_writestdn2otfs) then
        if (mpp_pe() == mpp_root_pe()) then
          tfsunit = open_restart_file ('stdn2otfs', action='write')
          write (tfsunit) valid_versions(nvalids)
          write (tfsunit) n2o_name_save, n2o_amount_save,   &
                          nstdlvls_save, kbegin_save, kend_save
          write (tfsunit) pd_save, plm_save, pa_save
          write (tfsunit) n2o51, n2o58, n2odt51, n2odt58, n2od2t51,   &
                          n2od2t58
          write (tfsunit) n2o71, n2o78, n2odt71, n2odt78, n2od2t71,  &
                          n2od2t78
          write (tfsunit) n2o91, n2o98, n2odt91, n2odt98, n2od2t91, &
                          n2od2t98
          call close_file (tfsunit)
        endif
      endif

      if (do_writestdch4tfs) then
        if (mpp_pe() == mpp_root_pe()) then
          tfsunit = open_restart_file ('stdch4tfs', action='write')
          write (tfsunit) valid_versions(nvalids)
          write (tfsunit) ch4_name_save, ch4_amount_save,   &
                          nstdlvls_save, kbegin_save, kend_save
          write (tfsunit) pd_save, plm_save, pa_save
          write (tfsunit) ch451, ch458, ch4dt51, ch4dt58, ch4d2t51,  &
                          ch4d2t58
          call close_file (tfsunit)
        endif
      endif

!--------------------------------------------------------------------
!    mark this module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!-------------------------------------------------------------------


end subroutine gas_tf_end




!###################################################################

! <SUBROUTINE NAME="process_co2_input_file">
!  <OVERVIEW>
!   Subroutine to process co2 input file information
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to process co2 input file information
!  </DESCRIPTION>
!  <TEMPLATE>
!   call process_co2_input_file (gas_name, gas_amount, nstdlvls,  &
!                                   kbegin, kend, pd, plm, pa)
!  </TEMPLATE>
!  <IN NAME="gas_name" TYPE="character">
!   Name of the gas specy
!  </IN>
!  <IN NAME="gas_amount" TYPE="real">
!   Amount of the gas specy
!  </IN>
!  <IN NAME="nstdlvls" TYPE="integer">
!   Number of standard levels
!  </IN>
!  <IN NAME="kbegin, kend" TYPE="integer">
!   Index of the starting and ending vertical levels
!  </IN>
!  <IN NAME="pd, plm, pa" TYPE="real">
!   Pressure coordinate variables, at boundaries, mid points.
!  </IN>
! </SUBROUTINE>
! 
subroutine process_co2_input_file (gas_name, gas_amount, nstdlvls,  &
                                   kbegin, kend, pd, plm, pa)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

character(len=*),   intent(in)      :: gas_name
real,               intent(in)      :: gas_amount
integer,            intent(in)      :: nstdlvls, kbegin, kend
real, dimension(:), intent(in)      :: pd, plm, pa

!------------------------------------------------------------------
!  intent(in) variables:
!
!    gas_name 
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:




      integer               ::  unit



!---------------------------------------------------------------------
!  local variables:
!
!       pd_file
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('gas_tf_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_readstdco2tfs) then

!--------------------------------------------------------------------
!    read the input tf file and verify that the current model config-
!    uration matches that for which the tfs were generated.
!--------------------------------------------------------------------
        unit = open_restart_file ('INPUT/stdco2tfs', action='read')
        call process_gas_input_file (gas_name, gas_amount, nstdlvls,  &
                                     kbegin, kend, pd, plm, pa, unit)

        read  (unit) co215nbps1, co215nbps8, co2dt15nbps1,           & 
                     co2dt15nbps8, co2d2t15nbps1, co2d2t15nbps8
        read  (unit) co251, co258, cdt51, cdt58, c2d51, c2d58,       &  
                     co2m51, co2m58, cdtm51, cdtm58, c2dm51, c2dm58
        read  (unit) co211, co218
        call close_file (unit)
      else if (do_writestdco2tfs) then

!--------------------------------------------------------------------
!    save the data necessary to write a tf file at the end of this job
!    if that is desired  
!--------------------------------------------------------------------
       co2_name_save = gas_name
       co2_amount_save = gas_amount
       nstdlvls_save = nstdlvls
       kbegin_save = kbegin
       kend_save = kend
       if (.not. (allocated(pd_save) ) ) then
         allocate ( pd_save(kbegin:kend))
         allocate ( plm_save(kbegin:kend))
         allocate ( pa_save(nstdlvls))
       endif
       pd_save(:) = pd(:)
       plm_save(:) = plm(:)
       pa_save(:) = pa(:)
     endif

!--------------------------------------------------------------------

end subroutine process_co2_input_file



!####################################################################
! <SUBROUTINE NAME="process_ch4_input_file">
!  <OVERVIEW>
!   Subroutine to process ch4 input file information
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to process ch4 input file information
!  </DESCRIPTION>
!  <TEMPLATE>
!   call process_ch4_input_file (gas_name, gas_amount, nstdlvls,  &
!                                   kbegin, kend, pd, plm, pa)
!  </TEMPLATE>
!  <IN NAME="gas_name" TYPE="character">
!   Name of the gas specy
!  </IN>
!  <IN NAME="gas_amount" TYPE="real">
!   Amount of the gas specy
!  </IN>
!  <IN NAME="nstdlvls" TYPE="integer">
!   Number of standard levels
!  </IN>
!  <IN NAME="kbegin, kend" TYPE="integer">
!   Index of the starting and ending vertical levels
!  </IN>
!  <IN NAME="pd, plm, pa" TYPE="real">
!   Pressure coordinate variables, at boundaries, mid points.
!  </IN>
! </SUBROUTINE>
!
subroutine process_ch4_input_file (gas_name, gas_amount, nstdlvls,  &
                                   kbegin, kend, pd, plm, pa)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

character(len=*),   intent(in)      :: gas_name
real,               intent(in)      :: gas_amount
integer,            intent(in)      :: nstdlvls, kbegin, kend
real, dimension(:), intent(in)      :: pd, plm, pa

!------------------------------------------------------------------
!  intent(in) variables:
!
!    gas_name 
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:




   integer               ::  unit



!---------------------------------------------------------------------
!  local variables:
!
!       pd_file
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ( 'gas_tf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_readstdch4tfs) then

!--------------------------------------------------------------------
!    read the input tf file and verify that the current model config-
!    uration matches that for which the tfs were generated.
!--------------------------------------------------------------------
        unit = open_restart_file ('INPUT/stdch4tfs', action='read')
        call process_gas_input_file (gas_name, gas_amount, nstdlvls,  &
                                     kbegin, kend, pd, plm, pa, unit)
        read  (unit) ch451, ch458, ch4dt51, ch4dt58, ch4d2t51, ch4d2t58
        call close_file (unit)

!--------------------------------------------------------------------
!    save the data necessary to write a tf file at the end of this job
!    if that is desired  
!--------------------------------------------------------------------
      else if (do_writestdch4tfs) then
        ch4_name_save = gas_name
        ch4_amount_save = gas_amount
        nstdlvls_save = nstdlvls
        kbegin_save = kbegin
        kend_save = kend
        if (.not. (allocated(pd_save) ) ) then
          allocate ( pd_save(kbegin:kend))
          allocate ( plm_save(kbegin:kend))
          allocate ( pa_save(nstdlvls))
        endif
        pd_save(:) = pd(:)
        plm_save(:) = plm(:)
        pa_save(:) = pa(:)
      endif

!---------------------------------------------------------------------


end subroutine process_ch4_input_file



!####################################################################
! <SUBROUTINE NAME="process_n2o_input_file">
!  <OVERVIEW>
!   Subroutine to process n2o input file information
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to process n2o input file information
!  </DESCRIPTION>
!  <TEMPLATE>
!   call process_n2o_input_file (gas_name, gas_amount, nstdlvls,  &
!                                   kbegin, kend, pd, plm, pa)
!  </TEMPLATE>
!  <IN NAME="gas_name" TYPE="character">
!   Name of the gas specy
!  </IN>
!  <IN NAME="gas_amount" TYPE="real">
!   Amount of the gas specy
!  </IN>
!  <IN NAME="nstdlvls" TYPE="integer">
!   Number of standard levels
!  </IN>
!  <IN NAME="kbegin, kend" TYPE="integer">
!   Index of the starting and ending vertical levels
!  </IN>
!  <IN NAME="pd, plm, pa" TYPE="real">
!   Pressure coordinate variables, at boundaries, mid points.
!  </IN>
! </SUBROUTINE>
!
subroutine process_n2o_input_file (gas_name, gas_amount, nstdlvls,  &
                                   kbegin, kend, pd, plm, pa)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

character(len=*),   intent(in)      :: gas_name
real,               intent(in)      :: gas_amount
integer,            intent(in)      :: nstdlvls, kbegin, kend
real, dimension(:), intent(in)      :: pd, plm, pa

!------------------------------------------------------------------
!  intent(in) variables:
!
!    gas_name 
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:




   integer               ::  unit



!---------------------------------------------------------------------
!  local variables:
!
!       pd_file
!
!--------------------------------------------------------------------
        
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ( 'gas_tf_mod', &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_readstdn2otfs) then

!--------------------------------------------------------------------
!    read the input tf file and verify that the current model config-
!    uration matches that for which the tfs were generated.
!--------------------------------------------------------------------
        unit = open_restart_file ('INPUT/stdn2otfs', action='read')
        call process_gas_input_file (gas_name, gas_amount, nstdlvls,  &
                                     kbegin, kend, pd, plm, pa, unit)
        read  (unit) n2o51, n2o58, n2odt51, n2odt58, n2od2t51, n2od2t58
        read  (unit) n2o71, n2o78, n2odt71, n2odt78, n2od2t71, n2od2t78
        read  (unit) n2o91, n2o98, n2odt91, n2odt98, n2od2t91, n2od2t98
        call close_file (unit)

!--------------------------------------------------------------------
!    save the data necessary to write a tf file at the end of this job
!    if that is desired  
!--------------------------------------------------------------------
      else if (do_writestdn2otfs) then
        n2o_name_save = gas_name
        n2o_amount_save = gas_amount
        nstdlvls_save = nstdlvls
        kbegin_save = kbegin
        kend_save = kend
       if (.not. (allocated(pd_save) ) ) then
         allocate ( pd_save(kbegin:kend))
         allocate ( plm_save(kbegin:kend))
         allocate ( pa_save(nstdlvls))
       endif
       pd_save(:) = pd(:)
       plm_save(:) = plm(:)
       pa_save(:) = pa(:)
     endif

!--------------------------------------------------------------------


end subroutine process_n2o_input_file




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!####################################################################
! <SUBROUTINE NAME="ptz">
!  <OVERVIEW>
!   Subroutine to calculate temperatures at up to 200 user     
!   specified pressures.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to calculate temperatures at up to 200 user     
!   specified pressures.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ptz(plm, pd)
!  </TEMPLATE>
!  <IN NAME="plm" TYPE="real">
!   pressure at midpoint of layer (average of adjacent
!   pd values) 
!  </IN>
!  <IN NAME="pd" TYPE="real">
!   pressures (mb) for layer boundaries. (also known
!   as flux levels).
!  </IN>
! </SUBROUTINE>
!
subroutine ptz (plm, pd)

!--------------------------------------------------------------------
!    this program calculates temperatures at up to 200 user     
!    specified pressures. it makes use of an analytical       
!    function which approximates  the us standard atm(1976).  
!    this is calculated in function 'antemp', which is called
!    by ptz.  the form of the analytical function was    
!    suggested to me (S.B. Fels) in 1971 by richard s. lindzen. 
!
!--------------------------------------------------------------------

real, dimension(:), intent(in)    :: plm, pd

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     pd:  pressures (mb) for layer boundaries. (also known
!          as flux levels).
!     plm  pressure at midpoint of layer (average of adjacent
!          pd values)
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      real, dimension(:), allocatable  ::  press, altquad, tempquad, & 
                                           prsint, plmcgs,  tmpint

      real       ::  delzap = 0.5
      real       ::  dlogp, znint, dz, ht, rk1,  &
                     rk2, rk3, rk4
      integer    ::  k, nlay, nint, m

!--------------------------------------------------------------------
!   local variables:
!
!            plmcgs : plm in cgs units. needed for gtemp calc.
!            prsint: same as pd, but with indices reversed,index 1 at
!                    the surface, and index (nlev+1) at the top  level.
!            press: pressures used for quadratures (4 quad. pts.)  
!                     indices run as in prsint.
!         tempquad: temperature at quad. pts. index 1 is at the sfc.
!           tmpint: temperature at quad. pts, saved over both height
!                   and quadrature index. values come from tempquad.
!            tmpout: as in temp, but with indices reversed (index 1=
!                    temp at top data level),others are layer averages
!            altquad:  height values (km) generated by antemp. lowest
!                     index = surface.
!--------------------------------------------------------------------

!-----------------------------------------------------------------
!
!-----------------------------------------------------------------
      nlay = KERAD - KSRAD + 1

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------
      allocate ( gtemp    (KSRAD:KERAD+1) )
      allocate ( stemp    (KSRAD:KERAD+1) )
      allocate ( plmcgs   (KSRAD:KERAD+1) )
      allocate ( press    (1:nlay+1) )
      allocate ( altquad  (1:nlay+1) )
      allocate ( tempquad (1:nlay+1) )
      allocate ( prsint   (1:nlay+1) )
      allocate ( tmpint   (1:nlay+1) )

!--------------------------------------------------------------------
!    the gtemp code below assumes plmcgs in cgs units
!--------------------------------------------------------------------

      plmcgs(KSRAD:KERAD+1) = pd(KSRAD:KERAD+1)*1.0E+03
      do k = KSRAD,KERAD 
        gtemp(k) = plmcgs(k)**0.2*(1.+plmcgs(k)/30000.)**0.8/1013250.
      enddo
      gtemp(KERAD+1) = 1.0
 
      altquad(1)=0.0
      tempquad(1)=antemp(0.0)
 
      do k=KSRAD, KERAD+1
        prsint(k)=plm(nlay+2-k)
      enddo

!-------------------------------------------------------------------
!    obtain layer-mean quantities by quadrature over the layers.
!    the calculation is made  to find the temperature at
!    the layer-mean (plm)
!
!    calculations are done (oddly!) 1 quad. interval at a time, with
!    each going from the sfc upward to the top layer.
!-------------------------------------------------------------------- 
      press(1) = prsint(1)
      do k=2, nlay+1
        press(k) = pd(nlay+KSRAD+1-k)
      enddo

!---------------------------------------------------------------------
!    press is the pressure at the quadrature point; alt and temp
!    are the heights and pressures for each
!    such quadrature point. these are saved as tmpint and a.
!      note that press is not explicitly saved.
!--------------------------------------------------------------------
      do k=1,nlay
 
!-------------------------------------------------------------------
!    establish computational levels between user levels at   
!    intervals of approximately 'delzap' km.                
!    special care is needed for the topmost layer, which usually
!    goes to zero pressure.
!    (special definition not needed; top pressure is nonzero)
!------------------------------------------------------------------
        dlogp=7.0*ALOG(press(k)/press(k+1))
        nint=dlogp/delzap
        nint=nint+1
        znint=nint

!------------------------------------------------------------------
!    the conversion factor is used to convert dz from cm (using the
!    model's values for rgas and grav) to km (as in this program)
!------------------------------------------------------------------
        dz  = 1.0E-05*(1.0E+02*RDGAS)*dlogp/(7.0*GRAV*znint)
        ht=altquad(k)
 
!---------------------------------------------------------------------
!    calculate height at next user level by means of       
!    runge-kutta integration.                   
!-------------------------------------------------------------------
        do m=1,nint
          rk1=antemp(ht)*dz
          rk2=antemp(ht+0.5*rk1)*dz
          rk3=antemp(ht+0.5*rk2)*dz
          rk4=antemp(ht+rk3)*dz
          ht=ht+0.16666667*(rk1+rk2+rk2+rk3+rk3+rk4)
        enddo
        altquad(k+1)=ht
        tempquad(k+1)=antemp(ht)
      enddo
 
!--------------------------------------------------------------------
!    save temperature (tmpint) at quadrature
!    points for layer-mean evaluations by simpsons rule.
!--------------------------------------------------------------------
      do k=1,nlay+1
        tmpint(k)=tempquad(k)
      enddo

!--------------------------------------------------------------------
!    end of quadrature loop.
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!    stemp is layer-mean temperature with index 1 
!    at the top.applies for nq=5
!---------------------------------------------------------------------
      do k=KSRAD,KERAD+1
        stemp(k)=tmpint(nlay+KSRAD+1-k)
      enddo
 
!--------------------------------------------------------------------
      deallocate ( tmpint   )
      deallocate ( prsint   )
      deallocate ( tempquad )
      deallocate ( altquad  )
      deallocate ( press    )
      deallocate ( plmcgs   )

!------------------------------------------------------------------

end subroutine ptz



!###################################################################
! <SUBROUTINE NAME="antemp">
!  <OVERVIEW>
!   Subroutine to analytically calculate temperature profiles of
!   atmosphere with arbitrary levels
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to analytically calculate temperature profiles of
!   atmosphere with arbitrary levels
!  </DESCRIPTION>
!  <TEMPLATE>
!   temp = antemp(z)
!  </TEMPLATE>
!  <IN NAME="z" TYPE="real">
!   Height
!  </IN>
! </SUBROUTINE>
!
real function antemp (z)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
real, intent(in)   ::  z

!--------------------------------------------------------------------
!  intent(in) variables:
!
!    z
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

      real, dimension (10)   :: zb, delta
      real, dimension (11)   :: c
      real                   :: tstar, temp, expo, x, y, zlog, expp,   &
                                faclog
      integer                :: n, nlast

      data zb/   &
                             11.0,  20.0,  32.0,  47.0,  51.0,      &
                             71.0,  84.8520,  90.0,  91.0,  92.0/
      data c/  &
                             -6.5,   0.0,   1.0,   2.80,  0.0,    &
                             -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
      data delta/    &
                              0.3,   1.0,   1.0,   1.0,   1.0,    &
                              1.0,   1.0,   1.0,   1.0,   1.0/
 
      data tstar/    &
                  288.15/
 
!-------------------------------------------------------------------
!  local variables:
!
!    zb
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------
      temp = tstar + c(1)*z

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------
      nlast = 10
      do n = 1,nlast
        expo = (z - zb(n))/delta(n)
        if (ABS(expo) .LE. 60.) then
          x = EXP(expo)
          y = x + 1.0/x
          zlog = ALOG(y)
        else
          zlog = ABS(expo)
        endif
        expp = zb(n)/delta(n)
        if (ABS(expp) .LE. 60.) then
          x = EXP(expp)
          y = x + 1.0/x
          faclog = ALOG(y)
        else
          faclog = ABS(expp)
        endif
        temp = temp + (c(n+1) - c(n))*0.5*(z + delta(n)*     &
               (zlog - faclog))
      enddo
      antemp = temp

!--------------------------------------------------------------------


end function antemp


!#####################################################################
! <SUBROUTINE NAME="transfn">
!  <OVERVIEW>
!   Subroutine to compute the temperature corrected co2 nearby layer
!   transmission functions
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute the temperature corrected co2 nearby layer
!   transmission functions
!  </DESCRIPTION>
!  <TEMPLATE>
!   call transfn( Gas_tf)
!  </TEMPLATE>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   The output variable of temperature corrected co2 transmission
!   functions
!  </INOUT>
! </SUBROUTINE>
!
subroutine transfn (Gas_tf)

!----------------------------------------------------------------------
!    transfn computes the temperature-corrected co2 nearby layer
!    transmission functions.
!    author: m. d. schwarzkopf
!    revised: 1/1/93
!    certified:  radiation version 1.0
!----------------------------------------------------------------------

type(gas_tf_type), intent(inout) :: Gas_tf

!--------------------------------------------------------------------
!  intent(inout) variables:
!    
!     Gas_tf
!       co2nbl =  co2 transmission functions (not pressure-integrated) 
!                 for adjacent levels, over the 560-800 cm-1 range.
!       co2spnb = co2 transmission functions between a flux level and
!                 space, for each of (NBCO215) frequency bands in
!                 the 15 um range. used for cool-to-space calculations.
! 
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(Gas_tf%tdav,1), &
                       size(Gas_tf%tdav,2), &
                       size(Gas_tf%tdav,3)-1) :: co2m2d, co2md, co2mr

      real, dimension (size(Gas_tf%tdav,1), &
                       size(Gas_tf%tdav,2), &
                       size(Gas_tf%tdav,3)  ) :: dift                 

      real, dimension (size(Gas_tf%tdav,1), &
                       size(Gas_tf%tdav,2), &
                       size(Gas_tf%tdav,3), NBCO215  ) ::       &
                                    co215nb, co2dt15nb, co2d2t15nb

      integer    ::  inb, k

!---------------------------------------------------------------------
!  local variables:
!
!     co2m2d
!     co2md
!     co2mr
!     dift
!     co215nb
!     co2dt15nb
!     co2d2t15nb
!     inb
!     k
! 
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    perform co2 pressure interpolation on all inputted transmission 
!    functions and temperature derivatives successively computing 
!    co2r, dco2dt, and d2cdt2.
!----------------------------------------------------------------------
      do inb=1,NBCO215
        do k=KSRAD,KERAD+1
          co215nb(:,:,k,inb)    = Gas_tf%a1(:,:)*co215nbps1(k,inb) +  &
                                  Gas_tf%a2(:,:)*co215nbps8(k,inb)
          co2dt15nb(:,:,k,inb)  = 1.0E-2*(Gas_tf%a1(:,:)* &
                                  co2dt15nbps1(k,inb) +&
                                  Gas_tf%a2(:,:)*co2dt15nbps8(k,inb))
          co2d2t15nb(:,:,k,inb) = 1.0E-3*(Gas_tf%a1(:,:)* &
                                  co2d2t15nbps1(k,inb)+&
                                  Gas_tf%a2(:,:)*co2d2t15nbps8(k,inb))
        enddo
      enddo

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do k=KSRAD,KERAD
        co2mr (:,:,k) = Gas_tf%a1(:,:)*co2m51(k) +  &
                        Gas_tf%a2(:,:)*co2m58(k)
        co2md (:,:,k) = 1.0E-02*(Gas_tf%a1(:,:)*cdtm51(k) +   &
                                 Gas_tf%a2(:,:)*cdtm58(k))
        co2m2d(:,:,k) = 1.0E-03*(Gas_tf%a1(:,:)*c2dm51(k) +   &
                                 Gas_tf%a2(:,:)*c2dm58(k))
      enddo

!----------------------------------------------------------------------
!    perform the temperature interpolation for these transmissivities
!----------------------------------------------------------------------
      dift(:,:,KSRAD+1:KERAD+1) = Gas_tf%tdav(:,:,KSRAD+1:KERAD+1)/   &
                                  Gas_tf%tstdav(:,:,KSRAD+1:KERAD+1)
      do inb=1,NBCO215
        Gas_tf%co2spnb(:,:,KSRAD,inb) = 1.0E+00
        Gas_tf%co2spnb(:,:,KSRAD+1:KERAD+1,inb) =     &
                                   co215nb(:,:,KSRAD+1:KERAD+1,inb) +  &
                                   dift(:,:,KSRAD+1:KERAD+1)*    &
                                  (co2dt15nb(:,:,KSRAD+1:KERAD+1,inb) +&
                                  0.5E+00*dift(:,:,KSRAD+1:KERAD+1)*   &
                                  co2d2t15nb(:,:,KSRAD+1:KERAD+1,inb))
        do k=KSRAD,KERAD+1
          Gas_tf%co2spnb(:,:,k,inb) = Gas_tf%co2spnb(:,:,k,inb)*  &
                                      (1.0E+00 -   &
                                      Gas_tf%tlsqu(:,:,KSRAD)) +    &
                                      Gas_tf%tlsqu(:,:,KSRAD)
        enddo
      enddo

!----------------------------------------------------------------------
!    compute special nearby layer transmission functions for combined
!    band in 15 um range. the transmissivities are not layer-averaged.
!----------------------------------------------------------------------
      Gas_tf%co2nbl(:,:,KSRAD:KERAD) = co2mr(:,:,KSRAD:KERAD) +   &
                                       Gas_tf%tmpdiff(:,:,KSRAD:KERAD)*&
                                       (co2md (:,:,KSRAD:KERAD) +   &
                                       0.5E+00*  &
                                       Gas_tf%tmpdiff(:,:,KSRAD:KERAD)*&
                                       co2m2d(:,:,KSRAD:KERAD))

      Gas_tf%co2nbl(:,:,KSRAD:KERAD) = Gas_tf%co2nbl(:,:,KSRAD:KERAD)*&
                                       (1.0E+00 -   &
                                       Gas_tf%tlsqu(:,:,KSRAD:KERAD)) +&
                                       Gas_tf%tlsqu(:,:,KSRAD:KERAD) 

!--------------------------------------------------------------------


end subroutine transfn



!###################################################################
! <SUBROUTINE NAME="process_gas_input_file">
!  <OVERVIEW>
!   Subroutine to process gas input file information
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to process gas input file information
!  </DESCRIPTION>
!  <TEMPLATE>
!   call process_gas_input_file (gas_name, gas_amount, nstdlvls,  &
!                                   kbegin, kend, pd, plm, pa, unit)
!  </TEMPLATE>
!  <IN NAME="gas_name" TYPE="character">
!   Name of the gas specy
!  </IN>
!  <IN NAME="gas_amount" TYPE="real">
!   Amount of the gas specy
!  </IN>
!  <IN NAME="nstdlvls" TYPE="integer">
!   Number of standard levels
!  </IN>
!  <IN NAME="kbegin, kend" TYPE="integer">
!   Index of the starting and ending vertical levels
!  </IN>
!  <IN NAME="pd, plm, pa" TYPE="real">
!   Pressure coordinate variables, at boundaries, mid points.
!  </IN>
!  <IN NAME="unit" TYPE="integer">
!   The input file descriptor
!  </IN>
! </SUBROUTINE>
! 
subroutine process_gas_input_file (gas_name, gas_amount, nstdlvls,  &
                                   kbegin, kend, pd, plm, pa, unit)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

character(len=*),   intent(in)      :: gas_name
real,               intent(in)      :: gas_amount
integer,            intent(in)      :: nstdlvls, kbegin, kend, unit
real, dimension(:), intent(in)      :: pd, plm, pa

!---------------------------------------------------------------------
! intent(in) variables:
!
!    gas_nmae
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension(:), allocatable :: pd_file, plm_file, pa_file

      logical               :: valid=.false.
      integer               :: k, n
      character(len=8)      :: gastf_version, gas_file
      real                  :: gas_amount_file
      integer               :: nstdlvls_file, kbegin_file, kend_file

!--------------------------------------------------------------------
!  local variables:
!
!     pd_file
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      read (unit) gastf_version
      do n=1, nvalids
        if (gastf_version == valid_versions(n)) then
          valid = .true.
          exit
        endif
      end do
      if (.not.valid) then
        call error_mesg ( 'gas_tf_mod', &
           ' old gastf file -- no info on its contents ---'//&
           ' for safety, please recreate by running this code'// &
           ' with do_calc and do_write of stdtfs activated and'//&
           ' save the file thus generated to be read in future jobs',  &
                                                                FATAL)
      endif

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      read (unit) gas_file, gas_amount_file, nstdlvls_file, &
                  kbegin_file, kend_file

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      if (trim(gas_file) /= trim(gas_name) ) then
        call error_mesg ( 'gas_tf_mod', &
      'inconsistency in gas name between input file and current job', &
                                                              FATAL)
      endif
      if (gas_amount /= gas_amount_file) then
        call error_mesg ( 'gas_tf_mod', &
      'inconsistency in gas amount between input file and current job',&
                                                               FATAL)
      endif
      if (nstdlvls /= nstdlvls_file) then
        call error_mesg ( 'gas_tf_mod', &
        'inconsistency in nstdlvls between input file and current job',&
                                                                FATAL)
      endif
      if (kbegin_file /= KSRAD) then
        call error_mesg ( 'gas_tf_mod', &
         'inconsistency in KSRAD between input file and current job',&
                                                                 FATAL)
      endif
      if (kend_file /= KERAD) then
        call error_mesg ( 'gas_tf_mod', &
           'inconsistency in KERAD between input file and current job',&
                                                               FATAL)
      endif

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      allocate ( pd_file (kbegin_file:kend_file) )
      allocate ( plm_file(kbegin_file:kend_file) )
      allocate ( pa_file (nstdlvls   ) )

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      read (unit) pd_file, plm_file, pa_file

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do k=KSRAD,KERAD
        if (pd(k) /= pd_file(k)) then
          call error_mesg ( 'gas_tf_mod', &
         'inconsistency in pd  between input file and current job'//&
              '  -- have the input files been constructed using'//&
              ' current model pressure levels ?',  FATAL)
        endif
        if (plm(k) /= plm_file(k)) then
          call error_mesg ( 'gas_tf_mod', &
         'inconsistency in plm  between input file and current job'//&
          ' -- have the input files been constructed using'//&
          ' current model pressure levels ?',  FATAL)
        endif
      end do     

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do k=1,nstdlvls
        if (pa(k) /= pa_file(k)) then
          call error_mesg ( 'gas_tf_mod', &
         'inconsistency in pa between input file and current job',&
                                                           FATAL)
        endif
      end do

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      deallocate ( pa_file  )
      deallocate ( plm_file )
      deallocate ( pd_file  )

!--------------------------------------------------------------------

end subroutine process_gas_input_file


!#####################################################################

 
      end module gas_tf_mod





                 module isccp_clouds_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    isccp_clouds partitions the model cloud fields into the isccp
!    cloud categories, by cld top height and cld optical thickness
!    and provides netcdf output.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>


! shared modules:

use mpp_mod,                 only: input_nml_file
use fms_mod,                 only: fms_init, open_namelist_file, &
                                   write_version_number, mpp_pe, &
                                   mpp_root_pe, stdlog, file_exist,  &
                                   check_nml_error, error_mesg,   &
                                   FATAL, close_file
use time_manager_mod,        only: time_type, time_manager_init
use diag_manager_mod,        only: register_diag_field, send_data, &
                                   diag_manager_init

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    isccp_clouds partitions the model cloud fields into the isccp
!    cloud categories, by cld top height and cld optical thickness
!    and provides netcdf output.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: isccp_clouds.F90,v 17.0.8.2 2010/08/30 20:39:46 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public   isccp_clouds_init, isccp_output,               &
         isccp_cloudtypes, isccp_cloudtypes_stochastic, &
         isccp_clouds_end

private          &
!   called from isccp_clouds_init:
         diag_field_init, &
!   called from isccp_cloudtypes:
         ran0


!---------------------------------------------------------------------
!-------- namelist  ---------
!
!                         ISCCP CLOUD PROCESSING
!    
!
!       top_height
!
!                      integer variable indicating whether 
!                      or not to simulate 10.5 micron brightness
!                      temperatures to adjust top heights according
!                      to the emissivity of the cloud. 
!                     
!                      1 = adjust top height using both a computed
!                          infrared brightness temperature and the
!                          visible optical depth to adjust cloud top
!                          pressure. Note that this calculation is
!                          most appropriate to compare to ISCCP data
!                          during sunlit hours.
!       
!                      2 = do not adjust top height, that is cloud top
!                          pressure is the actual cloud top pressure
!                          in the model
!       
!                      3 = adjust top height using only the computed
!                          infrared brightness temperature. Note that
!                          this calculation is most appropriate to
!                          compare to ISCCP IR only algortihm (i.e.
!                          you can compare to nighttime ISCCP data
!                          with this option)
!                      
!       ncol           number of columns used in ISCCP cloud type
!                      simulations
!                      NOTE: This parameter is ignored when using 
!                      stochastic clouds. 
! 
!       isccp_taumin   minimum optical depth ISCCP can see
!                      [ dimensionless ]
!
!       emsfclw        assumed constant fraction of longwave emissivity
!                      of the surface [ dimensionless ]
! 
!       do_sunlit_only should ISCCP diagnostics be done during sunlit
!                      hours only? [ logical ]
!
!       overlap        variable indicating which overlap assumption to 
!                      use in ISCCP processing.
!
!                      NOTE THIS HAS NO IMPACT ON ANYTHING ELSE BUT
!                      ISCCP DIAGNOSIS FROM THIS SUBROUTINE
!
!                      NOTE: This parameter is ignored when using 
!                      stochastic clouds. 
!
!                      overlap = 1. means condensate in all levels 
!                                   is treated as part of the same cloud
!                                   i.e. maximum overlap
!
!                      overlap = 2. means condensate in adjacent levels 
!                                   is treated as different clouds
!                                   i.e. random overlap
!       
!                      overlap = 3. means condensate in adjacent levels 
!                                   is treated as part of the same cloud
!                                   i.e. maximum-random overlap
!
!      minColsInhomo   Minimum number of cloudy subcolumns required
!                      to do calculation of the inhomogeneity parameter
!                      epsilon = 1 - tau**/tau_bar
!
!                      where tau_bar = linear average of tau
!
!                            tau**  = exponential of the
!                                     linear average of logarithm of tau
!
!
!----------------------------------------------------------------------

integer  ::  ncol = 50
integer  ::  top_height = 1
real     ::  isccp_taumin = 0.3
real     ::  emsfclw = 0.94
logical  ::  do_sunlit_only = .false.
integer  ::  overlap = 2
integer  ::  minColsInhomo = 3

namelist /isccp_clouds_nml /  ncol, top_height, isccp_taumin, emsfclw,&
                              do_sunlit_only, overlap, minColsInhomo

!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

integer, parameter :: numIsccpPressureIntervals     = 7, &
                      numIsccpOpticalDepthIntervals = 7

real, parameter     :: taumin = 1.E-06  ! minimum value allowed for 
                                        ! optical depth 
                                        ! [ dimensionless ]
real                :: qmin = 1.E-06    ! small number used in a couple
                                        ! of places in the code

!----------------------------------------------------------------------
!    diagnostics variables.     
!----------------------------------------------------------------------
character(len=5)    :: mod_name = 'isccp'
real                :: missing_value = -999.

integer :: id_deep,         id_cirrostratus,  id_cirrus,           &
           id_nimbostratus, id_altostratus,   id_altocumulus,      &
           id_stratus,      id_stratocumulus, id_cumulus,          &
           id_hithin,       id_midthin,       id_lowthin,          &
           id_high,         id_mid,           id_low,              &
           id_total,        id_allclouds,                          &          
           id_pc1tau0,id_pc1tau1,id_pc1tau2,id_pc1tau3,id_pc1tau4, &
           id_pc1tau5,id_pc1tau6, &
           id_pc2tau0,id_pc2tau1,id_pc2tau2,id_pc2tau3,id_pc2tau4, &
           id_pc2tau5,id_pc2tau6, &
           id_pc3tau0,id_pc3tau1,id_pc3tau2,id_pc3tau3,id_pc3tau4, &
           id_pc3tau5,id_pc3tau6, &
           id_pc4tau0,id_pc4tau1,id_pc4tau2,id_pc4tau3,id_pc4tau4, &
           id_pc4tau5,id_pc4tau6, &
           id_pc5tau0,id_pc5tau1,id_pc5tau2,id_pc5tau3,id_pc5tau4, &
           id_pc5tau5,id_pc5tau6, &
           id_pc6tau0,id_pc6tau1,id_pc6tau2,id_pc6tau3,id_pc6tau4, &
           id_pc6tau5,id_pc6tau6, &
           id_pc7tau0,id_pc7tau1,id_pc7tau2,id_pc7tau3,id_pc7tau4, &
           id_pc7tau5,id_pc7tau6, &
           id_nisccp, id_ninhomog, id_inhomogeneity

logical :: module_is_initialized =   .false.    ! module  initialized ?


!----------------------------------------------------------------------
!----------------------------------------------------------------------


  !
  ! Overloaded procedures
  !
  interface fluxToTb
    module procedure fluxToTb_1D, fluxToTb_2D, fluxToTb_3d
  end interface ! fluxToTb
  
  interface TbToFlux
    module procedure TbToFlux_1D, TbToFlux_2D, TbToFlux_3d
  end interface ! TbToFlux
  
  interface computeRadiance
    module procedure computeRadiance_1D, computeRadiance_2D
  end interface ! computeRadiance

                        contains 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#####################################################################
! <SUBROUTINE NAME="isccp_clouds_init">
!  <OVERVIEW>
!    isccp_clouds_init is the constructor for isccp_clouds_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    isccp_clouds_init is the constructor for isccp_clouds_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_clouds_init (axes, Time)
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="real">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
! </SUBROUTINE>
!
subroutine isccp_clouds_init (axes, Time)

!---------------------------------------------------------------------
!    isccp_clouds_init is the constructor for isccp_clouds_mod.
!------------------------------------------------------------------

integer, dimension(4),   intent(in)              :: axes
type(time_type),         intent(in)              :: Time

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       axes             diagnostic variable axes
!       Time             current time [time_type(days, seconds)]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer         :: unit, io, ierr, logunit

!---------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      io       error status returned from io operation  
!      ierr     error code
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
      
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call diag_manager_init

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=isccp_clouds_nml, iostat=io)
      ierr = check_nml_error(io,'isccp_clouds_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=isccp_clouds_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'isccp_clouds_nml')
        enddo
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                       write (logunit, nml=isccp_clouds_nml)
 

!-------------------------------------------------------------------
!    initialize the netcdf diagnostics provided with this module.
!-------------------------------------------------------------------
      call diag_field_init (Time, axes)

!--------------------------------------------------------------------
!    mark the module initialized.
!--------------------------------------------------------------------
      module_is_initialized= .true.

!--------------------------------------------------------------------



end subroutine isccp_clouds_init



!######################################################################
! <SUBROUTINE NAME="isccp_output">
!  <OVERVIEW>
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_output (is, js, fq_isccp, npoints, 
!                      inhomogeneity_parameter, ninhomog, Time)
!  </TEMPLATE>
!  <IN NAME="is, js" TYPE="integer">
!   starting/ending subdomain i,j indices of data 
!                      in the physics_window being integrated
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   time on next timestep, used as stamp for 
!                      diagnostic output 
!  </IN>
!  <IN NAME="fq_isccp" TYPE="real">
!   matrix of fractional area covered by cloud
!                      types of a given optical depth and cloud
!                      top pressure range.  The matrix is 7x7 for
!                      7 cloud optical depths and 7 cloud top 
!                      pressure ranges
!  </IN>
!  <IN NAME="npoints" TYPE="real">
!   flag indicating whether isccp cloud is present
!                      in column (cloud + daylight needed)
!  </IN>
!  <OUT NAME="inhomogeneity_parameter" TYPE="real">
!   Cloud inhomogeneity parameter (between 0 and 1 if valid
!   point, -1. if not computed at this point [ dimensionless ]
!  </OUT>
!  <IN NAME="ninhomog" TYPE="real">
!   flag indicating cloud inhomogeneity calculations have been
!      performed [1.=True, 0.=False]
!  </IN>
! </SUBROUTINE>
!
subroutine isccp_output (is, js, fq_isccp, npoints, &
                         inhomogeneity_parameter, ninhomog, Time)

!--------------------------------------------------------------------
!    subroutine isccp_diag maps the model cloud distribution to the
!    isccp cloud categories, and provides netcdf output if desired.
!---------------------------------------------------------------------
 
integer,                      intent(in)   :: is,js
real, dimension(:,:,:,:),     intent(in)   :: fq_isccp
real, dimension(:,:),         intent(in)   :: npoints, ninhomog, &
                                              inhomogeneity_parameter
type(time_type),              intent(in)   :: Time

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,js           starting/ending subdomain i,j indices of data 
!                      in the physics_window being integrated
!      fq_isccp        matrix of fractional area covered by cloud
!                      types of a given optical depth and cloud
!                      top pressure range.  The matrix is 7x7 for
!                      7 cloud optical depths and 7 cloud top 
!                      pressure ranges
!      npoints         flag indicating whether isccp cloud is present
!                      in column (cloud + daylight needed)
!      Time            time on next timestep, used as stamp for 
!                      diagnostic output [ time_type (days, seconds) ]
!
!---------------------------------------------------------------------

!local variable:
     
     real, dimension(size(npoints,1),size(npoints,2)) :: tmpmat
     
     logical :: used     !  flag returned from send_data indicating
                         !  whether diag_manager_mod has received 
                         !  data that was sent

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('isccp_clouds_mod',   &
               'module has not been initialized', FATAL )
      endif

!----------------------------------------------------------------------
!    send any desired diagnostics to the diag_manager_mod.
!----------------------------------------------------------------------

      !------------------------------------------------------------
      ! do individual types
      
      used = send_data (id_pc1tau0, fq_isccp(:,:,1,1), Time, &
                        is, js )
      used = send_data (id_pc1tau1, fq_isccp(:,:,2,1), Time, &
                        is, js )
      used = send_data (id_pc1tau2, fq_isccp(:,:,3,1), Time, &
                        is, js )
      used = send_data (id_pc1tau3, fq_isccp(:,:,4,1), Time, &
                        is, js )
      used = send_data (id_pc1tau4, fq_isccp(:,:,5,1), Time, &
                        is, js )
      used = send_data (id_pc1tau5, fq_isccp(:,:,6,1), Time, &
                        is, js )
      used = send_data (id_pc1tau6, fq_isccp(:,:,7,1), Time, &
                        is, js )
      used = send_data (id_pc2tau0, fq_isccp(:,:,1,2), Time, &
                        is, js )
      used = send_data (id_pc2tau1, fq_isccp(:,:,2,2), Time, &
                        is, js )
      used = send_data (id_pc2tau2, fq_isccp(:,:,3,2), Time, &
                        is, js )
      used = send_data (id_pc2tau3, fq_isccp(:,:,4,2), Time, &
                        is, js )
      used = send_data (id_pc2tau4, fq_isccp(:,:,5,2), Time, &
                        is, js )
      used = send_data (id_pc2tau5, fq_isccp(:,:,6,2), Time, &
                        is, js )
      used = send_data (id_pc2tau6, fq_isccp(:,:,7,2), Time, &
                        is, js )
      used = send_data (id_pc3tau0, fq_isccp(:,:,1,3), Time, &
                        is, js )
      used = send_data (id_pc3tau1, fq_isccp(:,:,2,3), Time, &
                        is, js )
      used = send_data (id_pc3tau2, fq_isccp(:,:,3,3), Time, &
                        is, js )
      used = send_data (id_pc3tau3, fq_isccp(:,:,4,3), Time, &
                        is, js )
      used = send_data (id_pc3tau4, fq_isccp(:,:,5,3), Time, &
                        is, js )
      used = send_data (id_pc3tau5, fq_isccp(:,:,6,3), Time, &
                        is, js )
      used = send_data (id_pc3tau6, fq_isccp(:,:,7,3), Time, &
                        is, js )
      used = send_data (id_pc4tau0, fq_isccp(:,:,1,4), Time, &
                        is, js )
      used = send_data (id_pc4tau1, fq_isccp(:,:,2,4), Time, &
                        is, js )
      used = send_data (id_pc4tau2, fq_isccp(:,:,3,4), Time, &
                        is, js )
      used = send_data (id_pc4tau3, fq_isccp(:,:,4,4), Time, &
                        is, js )
      used = send_data (id_pc4tau4, fq_isccp(:,:,5,4), Time, &
                        is, js )
      used = send_data (id_pc4tau5, fq_isccp(:,:,6,4), Time, &
                        is, js )
      used = send_data (id_pc4tau6, fq_isccp(:,:,7,4), Time, &
                        is, js )
      used = send_data (id_pc5tau0, fq_isccp(:,:,1,5), Time, &
                        is, js )
      used = send_data (id_pc5tau1, fq_isccp(:,:,2,5), Time, &
                        is, js )
      used = send_data (id_pc5tau2, fq_isccp(:,:,3,5), Time, &
                        is, js )
      used = send_data (id_pc5tau3, fq_isccp(:,:,4,5), Time, &
                        is, js )
      used = send_data (id_pc5tau4, fq_isccp(:,:,5,5), Time, &
                        is, js )
      used = send_data (id_pc5tau5, fq_isccp(:,:,6,5), Time, &
                        is, js )
      used = send_data (id_pc5tau6, fq_isccp(:,:,7,5), Time, &
                        is, js )
      used = send_data (id_pc6tau0, fq_isccp(:,:,1,6), Time, &
                        is, js )
      used = send_data (id_pc6tau1, fq_isccp(:,:,2,6), Time, &
                        is, js )
      used = send_data (id_pc6tau2, fq_isccp(:,:,3,6), Time, &
                        is, js )
      used = send_data (id_pc6tau3, fq_isccp(:,:,4,6), Time, &
                        is, js )
      used = send_data (id_pc6tau4, fq_isccp(:,:,5,6), Time, &
                        is, js )
      used = send_data (id_pc6tau5, fq_isccp(:,:,6,6), Time, &
                        is, js )
      used = send_data (id_pc6tau6, fq_isccp(:,:,7,6), Time, &
                        is, js )
      used = send_data (id_pc7tau0, fq_isccp(:,:,1,7), Time, &
                        is, js )
      used = send_data (id_pc7tau1, fq_isccp(:,:,2,7), Time, &
                        is, js )
      used = send_data (id_pc7tau2, fq_isccp(:,:,3,7), Time, &
                        is, js )
      used = send_data (id_pc7tau3, fq_isccp(:,:,4,7), Time, &
                        is, js )
      used = send_data (id_pc7tau4, fq_isccp(:,:,5,7), Time, &
                        is, js )
      used = send_data (id_pc7tau5, fq_isccp(:,:,6,7), Time, &
                        is, js )
      used = send_data (id_pc7tau6, fq_isccp(:,:,7,7), Time, &
                        is, js )
      used = send_data (id_nisccp, npoints, Time, is, js )

      used = send_data (id_ninhomog, ninhomog, Time, is, js )
     
      used = send_data (id_inhomogeneity, inhomogeneity_parameter, &
                        Time, is, js )

      !------------------------------------------------------------
      ! do summed fields

      !do hithin
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,1:1,1:3), dim = 4), dim = 3)
      used = send_data (id_hithin, tmpmat(:,:), Time, is, js )
      !do cirrus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:3,1:3), dim = 4), dim = 3)
      used = send_data (id_cirrus, tmpmat(:,:), Time, is, js )
      
      !do cirrostratus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,4:5,1:3), dim = 4), dim = 3)
      used = send_data (id_cirrostratus, tmpmat(:,:), Time, is, js )
      
      !do deep
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,6:7,1:3), dim = 4), dim = 3)
      used = send_data (id_deep, tmpmat(:,:), Time, is, js )
      
      !do high
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:7,1:3), dim = 4), dim = 3)
      used = send_data (id_high, tmpmat(:,:), Time, is, js )
      
      !do midthin
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,1:1,4:5), dim = 4), dim = 3)
      used = send_data (id_midthin, tmpmat(:,:), Time, is, js )
      
      !do altocumulus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:3,4:5), dim = 4), dim = 3)
      used = send_data (id_altocumulus, tmpmat(:,:), Time, is, js )
      
      !do altostratus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,4:5,4:5), dim = 4), dim = 3)
      used = send_data (id_altostratus, tmpmat(:,:), Time, is, js )
      
      !do nimbostratus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,6:7,4:5), dim = 4), dim = 3)
      used = send_data (id_nimbostratus, tmpmat(:,:), Time, is, js )
      
      !do mid
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:7,4:5), dim = 4), dim = 3)
      used = send_data (id_mid, tmpmat(:,:), Time, is, js )
      
      !do lowthin
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,1:1,6:7), dim = 4), dim = 3)
      used = send_data (id_lowthin, tmpmat(:,:), Time, is, js )
      
      !do cumulus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:3,6:7), dim = 4), dim = 3)
      used = send_data (id_cumulus, tmpmat(:,:), Time, is, js )
      
      !do stratocumulus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,4:5,6:7), dim = 4), dim = 3)
      used = send_data (id_stratocumulus, tmpmat(:,:), Time, is, js )
      
      !do stratus
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,6:7,6:7), dim = 4), dim = 3)
      used = send_data (id_stratus, tmpmat(:,:), Time, is, js )
      
      !do low
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:7,6:7), dim = 4), dim = 3)
      used = send_data (id_low, tmpmat(:,:), Time, is, js )
            
      !do total
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,2:7,1:7), dim = 4), dim = 3)
      used = send_data (id_total, tmpmat(:,:), Time, is, js )
             
      !do all clouds
      tmpmat(:,:) = sum(sum(fq_isccp(:,:,1:7,1:7), dim = 4), dim = 3)
      used = send_data (id_allclouds, tmpmat(:,:), Time, is, js )
       
!--------------------------------------------------------------------
         

end subroutine isccp_output


!######################################################################
! <SUBROUTINE NAME="isccp_cloudtypes">
!  <OVERVIEW>
!    isccp_cloudtypes calculates the fraction of each model grid box 
!    covered by each of the 49 ISCCP D level cloud types 
!    (i.e. stratified by optical depth and cloud top pressure) by 
!    accounting for model overlap. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    isccp_cloudtypes calculates the fraction of each model grid box 
!    covered by each of the 49 ISCCP D level cloud types 
!    (i.e. stratified by optical depth and cloud top pressure) by 
!    accounting for model overlap. For further explanation see Klein 
!    and Jakob, Monthly Weather Review, (2000), vol x, pp. .
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_cloudtypes (sunlit, pfull, phalf, qv, at, skt, cc, &
!                          dtau_s, dem_s, fq_isccp, nisccp,&
!                          inhomogeneity_parameter, ninhomog)
!  </TEMPLATE>
!  <IN NAME="sunlit" TYPE="integer">
!   integer flag indicating whether or not a given point is sunlit
!                        [1 = True, 0 = False ]
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!   pressure of full model levels, pfull(1) is top
!                        level of model, pfull(nlev) is bottom level of
!                        model
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!   pressure of half model levels, phalf(1) is top
!                        of model, phalf(nlev+1) is the surface pressure
!  </IN>
!  <IN NAME="qv" TYPE="real">
!   water vapor specific humidity on model levels.
!                        used only if top_height = 1 or top_height = 3.
!  </IN>
!  <IN NAME="at" TYPE="real">
!   temperature in each model level [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!  </IN>
!  <IN NAME="skt" TYPE="real">
!   skin temperature [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!  </IN>
!  <INOUT NAME="cc" TYPE="real">
!   cloud cover in each model layer [ fraction ]
!                        this includes convective clouds if any
!                        NOTE:  This is the HORIZONTAL area of each
!                               grid box covered by clouds
!  </INOUT>
!  <INOUT NAME="dtau_s" TYPE="real">
!   mean 0.67 micron optical depth of stratiform
!                        clouds in each model level [ dimensionless ]
!                        NOTE:  this the cloud optical depth of only the
!                               cloudy part of the grid box, it is not 
!                               weighted with the 0 cloud optical depth 
!                               of the clear part of the grid box
!  </INOUT>
!  <INOUT NAME="dem_s" TYPE="real">
!   10.5 micron longwave emissivity of stratiform
!                        clouds in each model level. 
!                        used only if top_height = 1 or top_height = 3.
!                        Same note applies as in dtau. [ dimensionless ]
!  </INOUT>
!  <OUT NAME="fq_isccp" TYPE="real">
!   matrix of fractional area covered by cloud
!                       types of a given optical depth and cloud
!                       top pressure range.  The matrix is 7x7 for
!                       7 cloud optical depths and 7 cloud top 
!                       pressure ranges. [ fraction ]
!  </OUT>
!  <OUT NAME="nisccp" TYPE="real">
!   real flag indicating whether or not isccp_cloudtypes produced
!                       valid output [ 1.=True, 0.=False ]
!  </OUT>
!  <OUT NAME="inhomogeneity_parameter" TYPE="real">
!   Cloud inhomogeneity parameter (between 0 and 1 if valid
!   point, -1. if not computed at this point [ dimensionless ]
!  </OUT>
!  <IN NAME="ninhomog" TYPE="real">
!   flag indicating cloud inhomogeneity calculations have been
!      performed [1.=True, 0.=False]
!  </IN>
! </SUBROUTINE>
!
subroutine isccp_cloudtypes (sunlit, pfull, phalf, qv, at, skt, cc, &
                             dtau_s, dem_s, fq_isccp, nisccp, &
                             inhomogeneity_parameter, ninhomog)

!---------------------------------------------------------------------
!    isccp_cloudtypes calculates the fraction of each model grid box 
!    covered by each of the 49 ISCCP D level cloud types 
!    (i.e. stratified by optical depth and cloud top pressure) by 
!    accounting for model overlap. For further explanation see Klein 
!    and Jakob, Monthly Weather Review, (2000), vol x, pp. .
!
!---------------------------------------------------------------------

integer, dimension(:,:),  intent(in)      :: sunlit
real,  dimension(:,:,:),  intent(in)      :: pfull, phalf, qv, at
real,    dimension(:,:),  intent(in)      :: skt
real,  dimension(:,:,:),  intent(in)      :: cc, dtau_s, dem_s
real,dimension(:,:,:,:),  intent(out)     :: fq_isccp
!  Last two dimensions should be numIsccpOpticalDepthIntervals, numIsccpPressureIntervals (7, 7)
real,    dimension(:,:),  intent(out)     :: nisccp
real,  dimension(:,:),    intent(out)     :: inhomogeneity_parameter, &
                                             ninhomog

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       sunlit           integer indicating whether or not a given
!                        point is sunlit
!       pfull            pressure of full model levels, pfull(1) is top
!                        level of model, pfull(nlev) is bottom level of
!                        model [ Pa ]
!       phalf            pressure of half model levels, phalf(1) is top
!                        of model, phalf(nlev+1) is the surface pressure
!                        [ Pa ]
!       qv               water vapor specific humidity on model levels.
!                        used only if top_height = 1 or top_height = 3.
!                        [ kg vapor / kg air ]
!       at               temperature in each model level [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!       skt              skin temperature [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!
!   intent(inout) variables:
!
!       cc               cloud cover in each model layer [ fraction ]
!                        this includes convective clouds if any
!                        NOTE:  This is the HORIZONTAL area of each
!                               grid box covered by clouds
!       dtau_s           mean 0.67 micron optical depth of stratiform
!                        clouds in each model level [ dimensionless ]
!                        NOTE:  this the cloud optical depth of only the
!                               cloudy part of the grid box, it is not 
!                               weighted with the 0 cloud optical depth 
!                               of the clear part of the grid box
!       dem_s            10.5 micron longwave emissivity of stratiform
!                        clouds in each model level. 
!                        used only if top_height = 1 or top_height = 3.
!                        Same note applies as in dtau. [ dimensionless ]
!
!       NOTE :  OPTION TO RUN WITH CONVECTIVE CLOUDS IS NOT
!               IMPLEMENTED YET
!
!       conv             convective cloud cover in each model 
!                        level (fraction) this includes convective 
!                        clouds if any
!  
!                        NOTE:  This is the HORIZONTAL area of each
!                               grid box covered by clouds
!                         
!       dtau_c           mean 0.67 micron optical depth of convective
!                        clouds in each model level
!
!                        NOTE:  this the cloud optical depth of only the
!                               cloudy part of the grid box, it is not 
!                               weighted with the 0 cloud optical depth 
!                               of the clear part of the grid box
!
!   intent(out) variable:
!
!       fq_isccp        matrix of fractional area covered by cloud
!                       types of a given optical depth and cloud
!                       top pressure range.  The matrix is 7x7 for
!                       7 cloud optical depths and 7 cloud top 
!                       pressure ranges. [ fraction ]
!
!       nisccp          integer indicating whether or not isccp diagnostics
!                       were calculated for this point
!
!       inhomogeneity_parameter
!
!                         = 1 - tau**/tau_bar
!
!                      where tau_bar = linear average of tau
!
!                            tau**  = exponential of the
!                                     linear average of logarithm of tau
!
!       ninhomog       flag indicating that the inhomogeneity 
!                      parameter was calculated
!
!---------------------------------------------------------------------
! Local variables
!   The ISCCP simulator code is vectorized over one set of input GCM grid cells
!   The input variables here are over an x-y window, so we'll loop 
!   over y. 
    integer :: nPoints, nYPoints, nLev, i, j
    real,    dimension(size(pFull, 1), nCol, size(pFull, 3)) :: frac_out, dtau, dem
    real,    dimension(size(pFull, 1),       size(pFull, 3)) :: conv, strat
    real,    dimension(size(pFull, 1),       size(pFull, 3)) :: dem_wv
    integer, dimension(size(pFull, 1))                       :: seed
    real,    dimension(size(pFull, 1), nCol)                 :: boxPtop, boxTau
    
!---------------------------------------------------------------------
    nPoints  = size(pFull, 1)
    nYPoints = size(pFull, 2) 
    nLev     = size(pFull, 3)
    
    if(.not. module_is_initialized) &
      call error_mesg("isccp_clouds_mod", "module has not been initialized", FATAL)
    
    !
    ! Don't compute statistics if do_sunlit_only flag is set and this point is in darkness
    !   (sunlit = 0).  
    !
    do j = 1, nYPoints
      if(do_sunlit_only .and. .not. any(sunlit(:, j) == 1)) then
        fq_isccp(:, j, :, :) = 0.
        nisccp(:, j) = 0
        inhomogeneity_parameter(:,j) = 0.
        ninhomog(:,j) = 0.
      else
        strat(:, :) = cc(:, j, :)
        conv (:, :) = 0.
        ! Make sure all the values are resonable
        where (strat(:, :) < 0.) strat(:, :) = 0
        where (strat(:, :) > 1.) strat(:, :) = 1.
        !
        ! Generate sub-cloud structures
        !
        seed(:) = (pfull(:, j, nlev) - int(pfull(:, j, nlev))) * 100 + 1
        call scops(strat, conv, seed, frac_out)
        
        !
        ! Take scops predictions of cloud fraction and fill in emmissivity and optical 
        !   depth arrays
        !
        where(nint(frac_out(:, :, :)) == 0)
          dem (:, :, :) = 0. 
          dtau(:, :, :) = 0. 
        elsewhere(nint(frac_out(:, :, :)) == 1)
          dem (:, :, :) = spread(dem_s (:, j, :), dim = 2, nCopies = nCol)
          dtau(:, :, :) = spread(dtau_s(:, j, :), dim = 2, nCopies = nCol) 
        end where 
        ! Make sure all the values are resonable
        where (dtau(:, :, :) < 0.) dtau(:, :, :) = 0
        where (dem (:, :, :) < 0.) dem (:, :, :) = 0
        where (dem (:, :, :) > 1.) dem (:, :, :) = 1.
        
        if(top_height == 1 .or. top_height == 3) then 
          ! 
          ! We're looking for adjusted cloud tops. Compute water vapor emissivity
          !
          call computeWaterVaporEmissivity(pfull(:, j, :), phalf(:, j, :), &
                                           qv(:, j, :),    at(:, j, :), dem_wv)
          
          ! Call Icarus...
          call icarus(dtau, pFull(:, j, :),                  & 
                      dem, dem_wv,  at(:, j, :),  skt(:, j), &
                       (/ (emsfclw, j = 1, nPoints) /),      &
                      boxtau = boxtau, boxptop = boxptop)
        else 
          ! We're asking for the real cloud tops. 
          !   We don't correct very optically thin clouds either. 
          call icarus(dtau, pFull(:, j, :),                  & 
                      boxtau = boxtau, boxptop = boxptop)
        end if 
        
        ! Compute histograms
        fq_isccp(:, j, :, :) = computeIsccpJointHistograms(boxtau, boxptop, sunlit(:, j))
        nisccp(:, j) = 1

        ! Compute inhomogeneity parameter
        inhomogeneity_parameter(:,j) = computeInhomogeneityParameter(boxtau,boxptop,sunlit(:,j))

        where(inhomogeneity_parameter(:,j)<-0.5)
              inhomogeneity_parameter(:,j) = 0.
              ninhomog(:,j) = 0.
        elsewhere
              ninhomog(:,j) = 1.
        endwhere   
        
        ! Zero out frequency histograms if the point is dark and we want statistics
        !    only for sunlit points. 
        if(do_sunlit_only) then
          where(sunlit(:, j) == 0) 
            nisccp(:, j) = 0
            inhomogeneity_parameter(:,j) = 0.
            ninhomog(:,j) = 0.
          endwhere
          do i = 1, nPoints
            if(sunlit(i, j) == 0) fq_isccp(i, j, :, :) = 0. 
          end do 
        end if 
        
      end if
    end do

end subroutine isccp_cloudtypes

!######################################################################
! <SUBROUTINE NAME="isccp_cloudtypes_stochastic">
!  <OVERVIEW>
!    isccp_cloudtypes calculates the fraction of each model grid box 
!    covered by each of the 49 ISCCP D level cloud types 
!    (i.e. stratified by optical depth and cloud top pressure). 
!    This version uses the columns generated for the McICA treatment
!    of radiation.  
!  </OVERVIEW>
!  <DESCRIPTION>
!    isccp_cloudtypes calculates the fraction of each model grid box 
!    covered by each of the 49 ISCCP D level cloud types 
!    (i.e. stratified by optical depth and cloud top pressure). 
!    For further explanation see Klein 
!    and Jakob, Monthly Weather Review, (2000), vol x, pp. .
!    This version uses the columns generated for the McICA treatment
!    of radiation; overlap is imposed in the "cloud generator" that 
!    takes the place of SCOPS, and internal inhomogeneity can be 
!    added too.  
!
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_cloudtypes (sunlit, pfull, phalf, qv, at, skt, cc, &
!                          dtau_s, dem_s, fq_isccp, nisccp,&
!                          inhomogeneity_parameter, ninhomog)
!  </TEMPLATE>
!  <IN NAME="sunlit" TYPE="integer">
!   integer flag indicating whether or not a given point is sunlit
!                        [1 = True, 0 = False ]
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!   pressure of full model levels, pfull(1) is top
!                        level of model, pfull(nlev) is bottom level of
!                        model
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!   pressure of half model levels, phalf(1) is top
!                        of model, phalf(nlev+1) is the surface pressure
!  </IN>
!  <IN NAME="qv" TYPE="real">
!   water vapor specific humidity on model levels.
!                        used only if top_height = 1 or top_height = 3.
!  </IN>
!  <IN NAME="at" TYPE="real">
!   temperature in each model level [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!  </IN>
!  <IN NAME="skt" TYPE="real">
!   skin temperature [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!  </IN>
!  <INOUT NAME="cc" TYPE="real">
!   cloud cover in each model layer [ fraction ]
!                        this includes convective clouds if any
!                        NOTE:  This is the HORIZONTAL area of each
!                               grid box covered by clouds
!  </INOUT>
!  <INOUT NAME="dtau_s" TYPE="real">
!   mean 0.67 micron optical depth of stratiform
!                        clouds in each model level [ dimensionless ]
!                        NOTE:  this the cloud optical depth of only the
!                               cloudy part of the grid box, it is not 
!                               weighted with the 0 cloud optical depth 
!                               of the clear part of the grid box
!  </INOUT>
!  <INOUT NAME="dem_s" TYPE="real">
!   10.5 micron longwave emissivity of stratiform
!                        clouds in each model level. 
!                        used only if top_height = 1 or top_height = 3.
!                        Same note applies as in dtau. [ dimensionless ]
!  </INOUT>
!  <OUT NAME="fq_isccp" TYPE="real">
!   matrix of fractional area covered by cloud
!                       types of a given optical depth and cloud
!                       top pressure range.  The matrix is 7x7 for
!                       7 cloud optical depths and 7 cloud top 
!                       pressure ranges. [ fraction ]
!  </OUT>
!  <OUT NAME="nisccp" TYPE="real">
!   real flag indicating whether or not isccp_cloudtypes produced
!                       valid output [ 1.=True, 0.=False ]
!  </OUT>
!  <OUT NAME="inhomogeneity_parameter" TYPE="real">
!   Cloud inhomogeneity parameter (between 0 and 1 if valid
!   point, -1. if not computed at this point [ dimensionless ]
!  </OUT>
!  <IN NAME="ninhomog" TYPE="real">
!   flag indicating cloud inhomogeneity calculations have been
!      performed [1.=True, 0.=False]
!  </IN>
! </SUBROUTINE>
!
subroutine isccp_cloudtypes_stochastic (sunlit, pfull, phalf, qv, at, skt, cc, &
                                        dtau_s, dem_s, fq_isccp, nisccp, &
                                        inhomogeneity_parameter, ninhomog)

!---------------------------------------------------------------------
!    isccp_cloudtypes calculates the fraction of each model grid box 
!    covered by each of the 49 ISCCP D level cloud types 
!    (i.e. stratified by optical depth and cloud top pressure).
!    For further explanation see Klein 
!    and Jakob, Monthly Weather Review, (2000), vol x, pp. .
!    This version uses the columns generated for the McICA treatment
!    of radiation; overlap is imposed in the "cloud generator" that 
!    takes the place of SCOPS, and internal inhomogeneity can be 
!    added too.  
!
!---------------------------------------------------------------------

integer, dimension(:,:),     intent(in)  :: sunlit
real,    dimension(:,:,:),   intent(in)  :: pfull, phalf, qv, at
real,    dimension(:,:),     intent(in)  :: skt
real,    dimension(:,:,:,:), intent(in)  :: cc, dtau_s, dem_s
real,    dimension(:,:,:,:), intent(out) :: fq_isccp
!  Last two dimensions should be numIsccpOpticalDepthIntervals, numIsccpPressureIntervals (7, 7)
real,    dimension(:,:),     intent(out) :: nisccp
real,  dimension(:,:),    intent(out)    :: inhomogeneity_parameter, &
                                            ninhomog      

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       sunlit           integer indicating whether or not a given
!                        point is sunlit
!       pfull            pressure of full model levels, pfull(1) is top
!                        level of model, pfull(nlev) is bottom level of
!                        model [ Pa ]
!       phalf            pressure of half model levels, phalf(1) is top
!                        of model, phalf(nlev+1) is the surface pressure
!                        [ Pa ]
!       qv               water vapor specific humidity on model levels.
!                        used only if top_height = 1 or top_height = 3.
!                        [ kg vapor / kg air ]
!       at               temperature in each model level [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!       skt              skin temperature [ deg K ]
!                        used only if top_height = 1 or top_height = 3.
!
!   intent(inout) variables:
!
!       cc               cloud cover in each model layer [ fraction ]
!                        this includes convective clouds if any
!                        NOTE:  This is the HORIZONTAL area of each
!                               grid box covered by clouds
!       dtau_s           mean 0.67 micron optical depth of stratiform
!                        clouds in each model level [ dimensionless ]
!                        NOTE:  this the cloud optical depth of only the
!                               cloudy part of the grid box, it is not 
!                               weighted with the 0 cloud optical depth 
!                               of the clear part of the grid box
!       dem_s            10.5 micron longwave emissivity of stratiform
!                        clouds in each model level. 
!                        used only if top_height = 1 or top_height = 3.
!                        Same note applies as in dtau. [ dimensionless ]
!
!
!   intent(out) variable:
!
!       fq_isccp        matrix of fractional area covered by cloud
!                       types of a given optical depth and cloud
!                       top pressure range.  The matrix is 7x7 for
!                       7 cloud optical depths and 7 cloud top 
!                       pressure ranges. [ fraction ]
!
!       nisccp          integer indicating whether or not isccp diagnostics
!                       were calculated for this point
!
!       inhomogeneity_parameter
!
!                         = 1 - tau**/tau_bar
!
!                      where tau_bar = linear average of tau
!
!                            tau**  = exponential of the
!                                     linear average of logarithm of tau
!
!
!       ninhomog       flag indicating that the inhomogeneity 
!                      parameter was calculated
!
!
!---------------------------------------------------------------------
! Local variables
!   The ISCCP simulator code is vectorized over one set of input GCM grid cells
!   The input variables here are over an x-y window, so we'll loop 
!   over y. 
    integer :: nPoints, nYPoints, nLev, nColumns, i, j, col
    real,    dimension(size(cc, 1), size(cc, 4), size(cc, 3)) :: dtau, dem
    real,    dimension(size(cc, 1), size(cc, 3))              :: dem_wv
    real,    dimension(size(cc, 1), size(cc, 4))              :: boxPtop, boxTau
    
!---------------------------------------------------------------------
    nPoints  = size(cc, 1)
    nYPoints = size(cc, 2) 
    nLev     = size(cc, 3)
    nColumns = size(cc, 4)
    
    if(.not. module_is_initialized) &
      call error_mesg("isccp_clouds_mod", "module has not been initialized", FATAL)
    
    !
    ! Don't compute statistics if do_sunlit_only flag is set and this point is in darkness
    !   (sunlit = 0).  
    !
    do j = 1, nYPoints
      if(do_sunlit_only .and. .not. any(sunlit(:, j) == 1)) then
        fq_isccp(:, j, :, :) = 0.
        nisccp(:, j) = 0
        inhomogeneity_parameter(:,j) = 0.
        ninhomog(:,j) = 0.
      else
        !
        ! Reorder optical depth and emissivity arrays for this set 
        !   of Y points. In calling routines the order is x, y, lev, col; 
        !   icarus expects x, col, lev.  
        !
        do col = 1, nColumns
          dtau(:, col, :) = dtau_s(:, j, :, col)
          dem (:, col, :) = dem_s (:, j, :, col)
        end do
        !
        ! Make sure all the values are resonable
        !
        where (dtau(:, :, :) < 0.) dtau(:, :, :) = 0
        where (dem (:, :, :) < 0.) dem (:, :, :) = 0
        where (dem (:, :, :) > 1.) dem (:, :, :) = 1.
        
        if(top_height == 1 .or. top_height == 3) then 
          ! 
          ! We're looking for adjusted cloud tops. Compute water vapor emissivity
          !
          call computeWaterVaporEmissivity(pfull(:, j, :), phalf(:, j, :), &
                                           qv(:, j, :),    at(:, j, :), dem_wv)
          
          ! Call Icarus...
          call icarus(dtau, pFull(:, j, :),                  & 
                      dem, dem_wv,  at(:, j, :),  skt(:, j), &
                       (/ (emsfclw, j = 1, nPoints) /),       &
                      boxtau = boxtau, boxptop = boxptop)
        else 
          ! We're asking for the real cloud tops. 
          !   We don't correct very optically thin clouds either. 
          call icarus(dtau, pFull(:, j, :),                 & 
                      boxtau = boxtau, boxptop = boxptop)
        end if 
        
        ! Compute histograms
        fq_isccp(:, j, :, :) = computeIsccpJointHistograms(boxtau, boxptop, sunlit(:, j))
        nisccp(:, j) = 1

        ! Compute inhomogeneity parameter
        inhomogeneity_parameter(:,j) = computeInhomogeneityParameter(boxtau,boxptop,sunlit(:,j))

        where(inhomogeneity_parameter(:,j)<-0.5)
              inhomogeneity_parameter(:,j) = 0.
              ninhomog(:,j) = 0.
        elsewhere
              ninhomog(:,j) = 1.
        endwhere   
        
        ! Zero out frequency histograms if the point is dark and we want statistics
        !    only for sunlit points. 
        if(do_sunlit_only) then
          where(sunlit(:, j) == 0) 
            nisccp(:, j) = 0
            inhomogeneity_parameter(:,j) = 0.
            ninhomog(:,j) = 0.
          endwhere
          do i = 1, nPoints
            if(sunlit(i, j) == 0) fq_isccp(i, j, :, :) = 0. 
          end do 
        end if 
        
      end if
    end do

end subroutine isccp_cloudtypes_stochastic
!###################################################################

! <SUBROUTINE NAME="isccp_clouds_end">
!  <OVERVIEW>
!    isccp_clouds_end is the destructor for isccp_clouds_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    isccp_clouds_end is the destructor for isccp_clouds_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_clouds_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine isccp_clouds_end

!-------------------------------------------------------------------
!    isccp_clouds_end is the destructor for isccp_clouds_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('isccp_clouds_mod',   &
              'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    mark the module as not initialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------



end subroutine isccp_clouds_end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!####################################################################
! <SUBROUTINE NAME="diag_field_init">
!  <OVERVIEW>
!    diag_field_init registers the potential netcdf output variables
!    with diag_manager_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diag_field_init registers the potential netcdf output variables
!    with diag_manager_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_field_init (Time, axes )
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="real">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   initialization time for the netcdf output fields
!  </IN>
! </SUBROUTINE>
subroutine diag_field_init (Time, axes )

!---------------------------------------------------------------------
!    diag_field_init registers the potential netcdf output variables
!    with diag_manager_mod.
!---------------------------------------------------------------------

type(time_type), intent(in) :: Time
integer        , intent(in) :: axes(4)

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       Time      initialization time for the netcdf output fields
!       axes      diagnostic variable axes
!
!---------------------------------------------------------------------


!-----------------------------------------------------------------------
!    register the isccp diagnostic fields with diag_manager_mod.
!-----------------------------------------------------------------------
       
       id_allclouds     = register_diag_field ( mod_name, &
                        'all_clouds_is', axes(1:2), Time, &
       'Cloud fraction as ISCCP would see it', 'fraction' )       
       id_total         = register_diag_field ( mod_name, &
                       'tot_cld_amt_is', axes(1:2), Time, &
       'Cloud fraction as ISCCP would see it', 'fraction' )       
       id_high          = register_diag_field ( mod_name, &
                      'high_cld_amt_is', axes(1:2), Time, &
               '    pc<440                  ', 'fraction' )       
       id_mid           = register_diag_field ( mod_name, &
                       'mid_cld_amt_is', axes(1:2), Time, &
               '440<pc<680                  ', 'fraction' )
       id_low           = register_diag_field ( mod_name, &
                       'low_cld_amt_is', axes(1:2), Time, &
               '680<pc                      ', 'fraction' )       
       id_deep          = register_diag_field ( mod_name, &
                                 'deep', axes(1:2), Time, &
               '    pc<440;    23<tau       ', 'fraction' )       
       id_cirrostratus  = register_diag_field ( mod_name, &
                                   'cs', axes(1:2), Time, &
               '    pc<440;   3.6<tau<23    ', 'fraction' )
       id_cirrus        = register_diag_field ( mod_name, &
                                   'ci', axes(1:2), Time, &
               '    pc<440;taumin<tau<3.6   ', 'fraction' )
       id_hithin        = register_diag_field ( mod_name, &
                               'hithin', axes(1:2), Time, &
               '    pc<440;     0<tau<taumin', 'fraction' )
       id_nimbostratus  = register_diag_field ( mod_name, &
                                   'ns', axes(1:2), Time, &
               '440<pc<680;    23<tau       ', 'fraction' )
       id_altostratus   = register_diag_field ( mod_name, &
                                   'as', axes(1:2), Time, &
               '440<pc<680;   3.6<tau<23    ', 'fraction' )
       id_altocumulus   = register_diag_field ( mod_name, &
                                   'ac', axes(1:2), Time, &
               '440<pc<680;taumin<tau<3.6   ', 'fraction' )
       id_midthin       = register_diag_field ( mod_name, &
                              'midthin', axes(1:2), Time, &
               '440<pc<680;     0<tau<taumin', 'fraction' )
       id_stratus       = register_diag_field ( mod_name, &
                                   'st', axes(1:2), Time, &
               '680<pc    ;    23<tau       ', 'fraction' )
       id_stratocumulus = register_diag_field ( mod_name, &
                                   'sc', axes(1:2), Time, &
               '680<pc    ;   3.6<tau<23    ', 'fraction' )
       id_cumulus       = register_diag_field ( mod_name, &
                                   'cu', axes(1:2), Time, &
               '680<pc    ;taumin<tau<3.6   ', 'fraction' )
       id_lowthin       = register_diag_field ( mod_name, &
                              'lowthin', axes(1:2), Time, &
               '680<pc    ;     0<tau<taumin', 'fraction' )
       
        id_pc1tau0 = register_diag_field ( mod_name, &
                             'pc1tau0', axes(1:2), Time, &
                      '    pc<180;     0<tau<taumin', 'fraction' )
        id_pc1tau1 = register_diag_field ( mod_name, &
                             'pc1tau1', axes(1:2), Time, &
                      '    pc<180;taumin<tau<1.3   ', 'fraction' )
        id_pc1tau2 = register_diag_field ( mod_name, &
                             'pc1tau2', axes(1:2), Time, &
                      '    pc<180;   1.3<tau<3.6   ', 'fraction' )
        id_pc1tau3 = register_diag_field ( mod_name, &
                             'pc1tau3', axes(1:2), Time, &
                     '    pc<180;   3.6<tau<9.4   ', 'fraction' )
        id_pc1tau4 = register_diag_field ( mod_name, &
                             'pc1tau4', axes(1:2), Time, &
                      '    pc<180;   9.4<tau<23    ', 'fraction' )
        id_pc1tau5 = register_diag_field ( mod_name, &
                             'pc1tau5', axes(1:2), Time, &
                      '    pc<180;    23<tau<60    ', 'fraction' )
        id_pc1tau6 = register_diag_field ( mod_name, &
                             'pc1tau6', axes(1:2), Time, &
                      '    pc<180;    60<tau       ', 'fraction' )
        id_pc2tau0 = register_diag_field ( mod_name, &
                             'pc2tau0', axes(1:2), Time, &
                      '180<pc<310;     0<tau<taumin', 'fraction' )
        id_pc2tau1 = register_diag_field ( mod_name, &
                             'pc2tau1', axes(1:2), Time, &
                      '180<pc<310;taumin<tau<1.3   ', 'fraction' )
        id_pc2tau2 = register_diag_field ( mod_name, &
                             'pc2tau2', axes(1:2), Time, &
                      '180<pc<310;   1.3<tau<3.6   ', 'fraction' )
        id_pc2tau3 = register_diag_field ( mod_name, &
                             'pc2tau3', axes(1:2), Time, &
                      '180<pc<310;   3.6<tau<9.4   ', 'fraction' )
        id_pc2tau4 = register_diag_field ( mod_name, &
                             'pc2tau4', axes(1:2), Time, &
                      '180<pc<310;   9.4<tau<23    ', 'fraction' )
        id_pc2tau5 = register_diag_field ( mod_name, &
                             'pc2tau5', axes(1:2), Time, &
                      '180<pc<310;    23<tau<60    ', 'fraction' )
        id_pc2tau6 = register_diag_field ( mod_name, &
                             'pc2tau6', axes(1:2), Time, &
                      '180<pc<310;    60<tau       ', 'fraction' )
        id_pc3tau0 = register_diag_field ( mod_name, &
                             'pc3tau0', axes(1:2), Time, &
                      '310<pc<440;     0<tau<taumin', 'fraction' )
        id_pc3tau1 = register_diag_field ( mod_name, &
                             'pc3tau1', axes(1:2), Time, &
                      '310<pc<440;taumin<tau<1.3   ', 'fraction' )
        id_pc3tau2 = register_diag_field ( mod_name, &
                             'pc3tau2', axes(1:2), Time, &
                      '310<pc<440;   1.3<tau<3.6   ', 'fraction' )
        id_pc3tau3 = register_diag_field ( mod_name, &
                             'pc3tau3', axes(1:2), Time, &
                      '310<pc<440;   3.6<tau<9.4   ', 'fraction' )
        id_pc3tau4 = register_diag_field ( mod_name, &
                             'pc3tau4', axes(1:2), Time, &
                      '310<pc<440;   9.4<tau<23    ', 'fraction' )
        id_pc3tau5 = register_diag_field ( mod_name, &
                             'pc3tau5', axes(1:2), Time, &
                      '310<pc<440;    23<tau<60    ', 'fraction' )
        id_pc3tau6 = register_diag_field ( mod_name, &
                             'pc3tau6', axes(1:2), Time, &
                      '310<pc<440;    60<tau       ', 'fraction' )
        id_pc4tau0 = register_diag_field ( mod_name, &
                             'pc4tau0', axes(1:2), Time, &
                      '440<pc<560;     0<tau<taumin', 'fraction' )
        id_pc4tau1 = register_diag_field ( mod_name, &
                             'pc4tau1', axes(1:2), Time, &
                      '440<pc<560;taumin<tau<1.3   ', 'fraction' )
        id_pc4tau2 = register_diag_field ( mod_name, &
                             'pc4tau2', axes(1:2), Time, &
                      '440<pc<560;   1.3<tau<3.6   ', 'fraction' )
        id_pc4tau3 = register_diag_field ( mod_name, &
                             'pc4tau3', axes(1:2), Time, &
                      '440<pc<560;   3.6<tau<9.4   ', 'fraction' )
        id_pc4tau4 = register_diag_field ( mod_name, &
                             'pc4tau4', axes(1:2), Time, &
                      '440<pc<560;   9.4<tau<23    ', 'fraction' )
        id_pc4tau5 = register_diag_field ( mod_name, &
                             'pc4tau5', axes(1:2), Time, &
                      '440<pc<560;    23<tau<60    ', 'fraction' )
        id_pc4tau6 = register_diag_field ( mod_name, &
                             'pc4tau6', axes(1:2), Time, &
                      '440<pc<560;    60<tau       ', 'fraction' )
        id_pc5tau0 = register_diag_field ( mod_name, &
                             'pc5tau0', axes(1:2), Time, &
                      '560<pc<680;     0<tau<taumin', 'fraction' )
        id_pc5tau1 = register_diag_field ( mod_name, &
                             'pc5tau1', axes(1:2), Time, &
                      '560<pc<680;taumin<tau<1.3   ', 'fraction' )
        id_pc5tau2 = register_diag_field ( mod_name, &
                             'pc5tau2', axes(1:2), Time, &
                      '560<pc<680;   1.3<tau<3.6   ', 'fraction' )
        id_pc5tau3 = register_diag_field ( mod_name, &
                             'pc5tau3', axes(1:2), Time, &
                      '560<pc<680;   3.6<tau<9.4   ', 'fraction' )
        id_pc5tau4 = register_diag_field ( mod_name, &
                             'pc5tau4', axes(1:2), Time, &
                      '560<pc<680;   9.4<tau<23    ', 'fraction' )
        id_pc5tau5 = register_diag_field ( mod_name, &
                             'pc5tau5', axes(1:2), Time, &
                      '560<pc<680;    23<tau<60    ', 'fraction' )
        id_pc5tau6 = register_diag_field ( mod_name, &
                             'pc5tau6', axes(1:2), Time, &
                      '560<pc<680;    60<tau       ', 'fraction' )
        id_pc6tau0 = register_diag_field ( mod_name, &
                             'pc6tau0', axes(1:2), Time, &
                      '680<pc<800;     0<tau<taumin', 'fraction' )
        id_pc6tau1 = register_diag_field ( mod_name, &
                             'pc6tau1', axes(1:2), Time, &
                     '680<pc<800;taumin<tau<1.3   ', 'fraction' )
        id_pc6tau2 = register_diag_field ( mod_name, &
                             'pc6tau2', axes(1:2), Time, &
                      '680<pc<800;   1.3<tau<3.6   ', 'fraction' )
        id_pc6tau3 = register_diag_field ( mod_name, &
                             'pc6tau3', axes(1:2), Time, &
                      '680<pc<800;   3.6<tau<9.4   ', 'fraction' )
        id_pc6tau4 = register_diag_field ( mod_name, &
                             'pc6tau4', axes(1:2), Time, &
                      '680<pc<800;   9.4<tau<23    ', 'fraction' )
        id_pc6tau5 = register_diag_field ( mod_name, &
                             'pc6tau5', axes(1:2), Time, &
                      '680<pc<800;    23<tau<60    ', 'fraction' )
        id_pc6tau6 = register_diag_field ( mod_name, &
                             'pc6tau6', axes(1:2), Time, &
                      '680<pc<800;    60<tau       ', 'fraction' )
        id_pc7tau0 = register_diag_field ( mod_name, &
                             'pc7tau0', axes(1:2), Time, &
                      '800<pc    ;     0<tau<taumin', 'fraction' )
        id_pc7tau1 = register_diag_field ( mod_name, &
                             'pc7tau1', axes(1:2), Time, &
                      '800<pc    ;taumin<tau<1.3   ', 'fraction' )
        id_pc7tau2 = register_diag_field ( mod_name, &
                             'pc7tau2', axes(1:2), Time, &
                      '800<pc    ;   1.3<tau<3.6   ', 'fraction' )
        id_pc7tau3 = register_diag_field ( mod_name, &
                             'pc7tau3', axes(1:2), Time, &
                      '800<pc    ;   3.6<tau<9.4   ', 'fraction' )
        id_pc7tau4 = register_diag_field ( mod_name, &
                             'pc7tau4', axes(1:2), Time, &
                      '800<pc    ;   9.4<tau<23    ', 'fraction' )
        id_pc7tau5 = register_diag_field ( mod_name, &
                             'pc7tau5', axes(1:2), Time, &
                      '800<pc    ;    23<tau<60    ', 'fraction' )
        id_pc7tau6 = register_diag_field ( mod_name, &
                             'pc7tau6', axes(1:2), Time, &
                      '800<pc    ;    60<tau       ', 'fraction' )
        id_nisccp = register_diag_field ( mod_name, &
                             'nisccp', axes(1:2), Time, &
                      'frequency of ISCCP calculations', 'fraction' )
       
        id_ninhomog = register_diag_field ( mod_name, &
                             'ninhomog', axes(1:2), Time, &
                      'frequency of cloud inhomogeneity calculations', &
                       'fraction' )
        
        id_inhomogeneity = register_diag_field ( mod_name, &
                      'inhomog_param', axes(1:2), Time, &
                      'Ratio of logarthmic to linear mean optical thickness', &
                       'fraction' )
       
        
!---------------------------------------------------------------------

 
end subroutine diag_field_init




!######################################################################
! <FUNCTION NAME="ran0">
!  <OVERVIEW>
!    ran0 is a platform-independent random number generator from
!    Numerical Recipes -- Mark Webb July 1999
!  </OVERVIEW>
!  <DESCRIPTION>
!    ran0 is a platform-independent random number generator from
!    Numerical Recipes -- Mark Webb July 1999
!  </DESCRIPTION>
!  <TEMPLATE>
!   x = ran0 (idum)
!  </TEMPLATE>
!  <IN NAME="idum" TYPE="real">
!   seed for random number generator
!  </IN>
! </FUNCTION>
function ran0 (idum)

!--------------------------------------------------------------------- 
!    ran0 is a platform-independent random number generator from
!    Numerical Recipes -- Mark Webb July 1999
!---------------------------------------------------------------------
       
real                    :: ran0               
integer, intent(inout)  :: idum
                                 
!--------------------------------------------------------------------
!  intent(out) variable:
!
!      ran0           random number generated by this function
!
!  intent(inout) variable:
!
!      idum           seed for random number generator
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer :: ia = 16807        ! constant in random number generator
      integer :: im = 2147483647   ! constant in random number generator
      integer :: iq = 127773       ! constant in random number generator
      integer :: ir = 2836         ! constant in random number generator
      real    :: am                ! constant in random number generator
      integer :: k                 ! work variable              

!---------------------------------------------------------------------
!    define a needed  variable.
!---------------------------------------------------------------------
      am = 1.0/im

!---------------------------------------------------------------------
!    verify that the seed is valid.
!---------------------------------------------------------------------
      if (idum == 0) then
        call error_mesg ('isccp_clouds_mod', &
         'ZERO seed not allowed in ran0', FATAL)
      endif
 
!---------------------------------------------------------------------
!    compute next random number in sequence, using input value of
!    idum. return a new value of idum for use on next call.
!---------------------------------------------------------------------
      k = idum/iq
      idum = ia*(idum - k*iq) - ir*k
      if (idum < 0) idum = idum + im
      ran0 = am*idum

!---------------------------------------------------------------------


end function ran0

!######################################################################
! Pincus additions start here
! 
!######################################################################
  subroutine scops(cc, conv, seed, frac_out)
    real,    dimension(:, :), &  ! Dimensions nPoints, nLev
      intent( in) :: cc, &       !  Cloud cover in each model level (fraction) 
                                 !    NOTE:  This is the HORIZONTAL area of each grid box covered by clouds
                     conv        !  Convective cloud cover in each model level (fraction) 
                                 !    NOTE:  This is the HORIZONTAL area of each grid box covered by convective clouds
    integer, dimension(:), & ! Dimensions nPoints
      intent(inout) :: seed        !  seed value for random number generator ( see Numerical Recipes Chapter 7)
                                 !  It is recommended that the seed is set to a different value for each model
                                 !  gridbox it is called on, as it is possible that the choice of the same 
                                 !  seed value every time may introduce some statistical bias in the results, 
                                 !  particularly for low values of NCOL.

    real, dimension(:, :, :), &  ! Dimensions nPoints, nCol, nLev
      intent(out) :: frac_out    ! boxes gridbox divided up into
                                 ! Equivalent of BOX in original version, but indexed by column then row, 
                                 ! rather than by row then column
!     -----
!     Internal variables 
!     -----
    integer :: nPoints, nCol, nLev
!     -----
    integer :: ilev, ibox
    real, dimension(size(frac_out, 1), &
                  0:size(frac_out, 3)) :: tca ! total cloud cover in each model level (fraction)
                                              ! with extra layer of zeroes on top
                                              ! in this version this just contains the values input
                                              ! from cc but with an extra level
    real, dimension(size(frac_out, 1), &
                    size(frac_out, 3)) :: cca ! convective cloud cover in each model level (fraction) from conv 

    real, dimension(size(frac_out, 1), &
                    size(frac_out, 2)) :: threshold, &   ! pointer to position in gridbox
                                           maxocc,   &   ! Flag for max overlapped conv cld
                                           maxosc,   &   ! Flag for max overlapped strat cld
                                           boxpos,   &   ! ordered pointer to position in gridbox
                                           threshold_min ! minimum value to define range in with new threshold is chosen
    real, dimension(size(frac_out, 1), &
                    size(frac_out, 2)) :: ran            ! vector of random numbers
      
! ---------------------------------------------------------------------------
      nPoints = size(frac_out, 1)
      nCol    = size(frac_out, 2)
      nLev    = size(frac_out, 3)

!     -----------------------------------------------------!
!  Error checking - not needed in this version because we reset these variables in the calling routine.
!     ---------------------------------------------------!
!      call check_bounds(cc,   "cloud fraction",             0., 1.)
!      call check_bounds(conv, "convective cloud fraction",  0., 1.)

!     ---------------------------------------------------!

!     assign 2d tca array using 1d input array cc
      tca(:, 0 )   = 0.
      tca(:, 1:)   = cc(:, :)
 !     assign 2d cca array using 1d input array conv
      cca(:, :)    = conv(:, :)
      boxpos(:, :) = spread((/ (ibox - 0.5, ibox = 1, nCol) /) , &
                             dim = 1, nCopies = nPoints) / real(nCol)

!     ---------------------------------------------------!
!     Initialise output variable
!     ---------------------------------------------------!

!   Initialised frac_out to zero
      frac_out(:, :, :) = 0.
   
!     ---------------------------------------------------!
!     ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
!     frac_out is the array that contains the information 
!     where 0 is no cloud, 1 is a stratiform cloud and 2 is a
!     convective cloud
      
      !loop over vertical levels
      DO ilev = 1,nlev
!     Initialise threshold
        IF (ilev == 1) then
          ! If max overlap 
          IF (overlap == 1) then
            ! select pixels spread evenly across the gridbox
            threshold(:, :) = boxpos(:, :)
          ELSE
            DO ibox=1, ncol
              call ran0_vec(seed, ran(:, ibox))
              ! select random pixels from the non-convective
              ! part the gridbox ( some will be converted into
              ! convective pixels below )
              threshold(:,ibox) = cca(:,ilev) + (1 - cca(:,ilev)) * ran(:, ibox)
            end do
          ENDIF
        end if

        ! All versions of overlap
        where(boxpos(:, :) <= spread(cca(:, ilev), dim = 2, nCopies = nCol))
          maxocc(:, :) = 1
        elsewhere
          maxocc(:, :) = 0
        end where
        
        !
        ! Apply the overlap assumption
        !
        select case(overlap)
          case(1) ! Max overlap
            threshold_min(:, :) = spread(cca(:,ilev), dim = 2, nCopies = nCol)
            maxosc(:, :) = 1
          case(2)! Random overlap
            threshold_min(:, :) = spread(cca(:,ilev), dim = 2, nCopies = nCol)
            maxosc(:, :) = 0
          case(3)  ! Max/Random overlap
            threshold_min(:, :) = spread(max(cca(:, ilev), min(tca(:, ilev-1), tca(:, ilev))), &
                                         dim = 2, nCopies = nCol)
            where (threshold(:, :) < spread(min(tca(:, ilev-1), tca(:, ilev)), dim = 2, nCopies = nCol) .and. &
                   threshold(:, :) > spread(cca(:, ilev),                      dim = 2, nCopies = nCol)) 
              maxosc(:, :)= 1
            elsewhere
              maxosc(:, :)= 0
            end where
        end select
  
        ! Reset threshold 
        DO ibox=1,ncol
          call ran0_vec(seed, ran(:, ibox))
        end do
        threshold(:, :) = &
            !if max overlapped conv cloud     
            (    maxocc(:, :)) * ( boxpos(:, :)                                                ) +   &
            ! else
                !if max overlapped strat cloud; threshold=boxpos                       
            (1 - maxocc(:, :)) * ( (    maxosc(:, :)) * (threshold(:, :)                       ) +   &
                !else threshold_min=random[thrmin,1] 
                                   (1 - maxosc(:, :)) * (threshold_min(:, :) + &
                                                        (1 - threshold_min(:, :)) * ran(:, :) )    &
                                 )

        ! Fill frac_out with 1's where tca is greater than the threshold
        where (spread(tca(:,ilev), dim = 2, nCopies = nCol) > threshold(:, :)) 
          frac_out(:, :, ilev) = 1
        elsewhere
          frac_out(:, :,ilev) = 0
        end where               

       ! Partition boxes into stratiform and convective parts 
        where (spread(cca(:,ilev), dim = 2, nCopies = nCol) > threshold(:, :)) 
          frac_out(:, :, ilev) = 2
        end where               

    end do    !loop over nlev
      
  end subroutine scops
! -------------------------------------------------------------------
  subroutine icarus(dtau, pfull,                              & ! Required 
                    dem, dem_wv, at, skt, emsfc_lw, iTrop,    & ! Optional
                    boxtau, boxptop)
    !
    ! Required input arguments
    !
    real,    dimension(:, :, :), & ! Dimensions nPoints, nCol, nLev
      intent( in)  :: dtau         !  mean 0.67 micron optical depth of clouds in each model level
                                   !  NOTE:  this the cloud optical depth of only the cloudy part of the grid box, 
                                   !  it is not weighted with the 0 cloud optical depth of the clear part of the grid box
    real,    dimension(:, :),    &
      intent( in) :: pfull         !  pressure of full model levels (Pascals)
                                   !  pfull(npoints,1)    is    top level of model
                                   !  pfull(npoints,nlev) is bottom level of model
    !
    ! Optional input arguments - for computing radiative cloud-top pressure 
    !   All variables except itrop are needed if top_height == 1 .or. top_height == 3
    !
    real,    dimension(:, :, :), optional, & ! Dimensions nPoints, nCol, nLev
     intent( in) ::  dem         !  10.5 micron longwave emissivity of clouds in each model level.  
                                 !  Same note applies as in dtau.
   real,   dimension(:, :),      optional, & ! Dimensions nPoints, nLev
     intent( in) :: dem_wv, &    ! Water vapor emissivity.  
                    at           ! Air temperature in each model level (K)
   real,   dimension(:),         optional, &
     intent( in) :: skt, &       !  skin Temperature (K)
                    emsfc_lw     !  10.5 micron emissivity of surface (fraction)
   ! Users may supply their own tropopause height indicator
   integer, dimension(:),        optional, & ! Dimension nPoints
     intent( in) :: itrop        ! Index of the tropopause location in each column
   
    !     ------
    !     Output
    !     ------
    real, dimension(:, :), &   !  dimension nPoints, nCol
      intent(out) :: boxtau,         &   !  optical thickness in each column
                     boxptop             !  cloud top pressure (mb) in each sub-column
                  
    !     --------------------------------------------
    !     Local variables and parameters
    integer :: nPoints, nCol, nLev 
    !     ------
    integer                           ::  i, j, ilev, ibox, icycle
    real,    dimension(size(dtau, 1), &
                       size(dtau, 2)) :: tau, pTop, tb
    real,    dimension(size(dtau, 1), &
                       size(dtau, 2), &
                       size(dtau, 3)) :: dem_local
    
    ! Variables for adjusting cloud top pressure based on TOA IR radiance
    real,    dimension(size(dtau, 1)) :: fluxtop_clrsky
    real,    dimension(size(dtau, 1), &
                       size(dtau, 2)) :: emcld, fluxtop, tauir, taumin, &
                                         fluxtopinit, transmax, btcmin
    logical, dimension(size(dtau, 1), &
                       size(dtau, 2)) :: intermedTrans
  
    ! Historgram quanitities 
    integer, dimension(size(dtau, 1), &
                       size(dtau, 2)) :: levMatch
    
    ! Tropopause 
    integer, dimension(size(dtau, 1)) :: itrop_local    ! index to tropopause level
    real,    dimension(size(dtau, 1)) :: pTrop, atTrop  ! tropopause pressure, temperature
                                   
    
    !     ------
    !     Local constants
    !     ------
    real,    parameter ::  VisTauToIrTauIce = 1./2.13, VisTauToIrTauLiquid = 1./2.56, &
                           assumedFreezingTb = 260.

    ! -----------------------------------------------------------------------------------
    nPoints = size(dtau, 1); nCol    = size(dtau, 2); nLev    = size(dtau, 3)
    
    ! Error checking - not needed in this version because we ensured these values
    !   made sense in the calling routine.
!   call check_Lbound(dtau, "cloud optical depth", 0.)
!   if(present(dem)) &
!     call check_bounds(dem, "cloud emissivity",  0., 1.)
    
    ! -----------------------------------------------------------------------------------
    ! The easy part - what's the total cloud optical depth in each column? 
    ! 
    tau(:, :) = sum(dtau, dim = 3)

    ! -----------------------------------------------------------------------------------
    ! If we're adjusting cloud-top heights using the VIS and/or IR radiances 
    !    we need to know 1) the TOA radiance, and 2) the position of the tropopause 
    !    (the latter is the pressure level to which really cold clouds are assigned)
    !
    if(top_height == 1 .or. top_height == 3) then
      dem_local(:, :, :) = spread(dem_wv(:, :), dim = 2, nCopies = nCol)

      !
      ! Clear sky calculation - only need one col per GCM grid point
      !
      call computeRadiance(dem_local(:, 1, :), at, skt, emsfc_lw, fluxtop_clrsky(:))
      !
      ! Add contribution to emissivity from cloud
      !
      where(dem(:, :, :) > tiny(dem)) 
        dem_local(:, :, :) = 1. - ( (1. - dem_local(:, :, :)) * (1. -  dem(:, :, :)) )
      end where
      !
      ! And now the all-sky radiance
      !
      call computeRadiance(dem_local, at, skt, emsfc_lw, fluxtop)
    end if
    !     ---------------------------------------------------!
    ! Account for ISCCP procedures to determine cloud top temperature
  
    ! Account for partially transmitting cloud and recompute flux 
    !    ISCCP would see assuming a single layer cloud
    ! Note choice here of VisTauToIrTauIce = 1/2.13, as it is primarily ice
    !    clouds which have partial emissivity and need the adjustment 
    !
    ! If the cloud brightness temperature is greater than 260K,  the liquid cloud conversion
    !   factor is used.
    !
    ! This is discussed on pages 85-87 of the ISCCP D level documentation (Rossow et al. 1996)

    if (top_height == 1 .or. top_height == 3) then
      ! Tropoause height needed if cloud tops are to be adjusted
      !
      if(present(itrop)) then
        itrop_local(:) = itrop(:)
      else 
        call diagnoseTropPressure(pfull, at, itrop_local)
      end if
      do j = 1, nPoints
        ptrop(j)  = pfull(j, itrop_local(j)) 
        attrop(j) =    at(j, itrop_local(j))
      end do

      if (top_height == 1) then
        !compute minimum brightness temperature and optical depth
        btcmin(:, :) = spread(TbToFlux(attrop(:) - 5.), dim = 2, nCopies = nCol)
        
        !note that the initial setting of tauir(:) is needed so that
        !tauir(:) has a realistic value 
        tauir(:, :) = tau(:, :) * VisTauToIrTauIce
        transmax(:, :) = (fluxtop(:,:) - btcmin(:, :)) / &
                         (spread(fluxtop_clrsky(:), dim = 2, nCopies = nCol) - btcmin(:, :))
        taumin(:, :) = -log(max(min(transmax(:, :), 1. - spacing(1.)), tiny(transmax)))

        intermedTrans(:, :) = transmax(:, :) > tiny(transmax) .and. &
                              transmax(:, :) < 1. - spacing(1.)
        where (intermedTrans) 
          fluxtopinit(:, :) = fluxtop(:,:)
          tauir(:, :) = tau(:,:) * VisTauToIrTauIce
        end where
        
!       do icycle=1,2
!         where (tau(:,:) > tiny(tau) .and. intermedTrans) 
!            emcld(:,:) = 1. - exp(-tauir(:, :))
!            fluxtop(:,:) = fluxtopinit(:, :) - ( (1. - emcld(:,:)) * &
!                                                 spread(fluxtop_clrsky(:), dim = 2, nCopies = nCol) )
!            fluxtop(:,:) = max(tiny(fluxtop), fluxtop(:,:)/emcld(:,:))
!            tb(:, :) = fluxToTb(fluxtop(:, :))
!            where (tb(:, :) .gt. assumedFreezingTb) tauir(:, :) = tau(:,:) * VisTauToIrTauLiquid
!         end where
!       enddo

        do icycle=1,2
          do j= 1, size(tau,2)
          do i= 1, size(tau,1)
            if (tau(i,j) > tiny(tau)  .and. intermedTrans(i,j)) then
             emcld(i,j) = 1. - exp(-tauir(i, j))
             fluxtop(i,j) = fluxtopinit(i,j) - ( (1. - emcld(i,j)) * &
                      fluxtop_clrsky(i))
             fluxtop(i,j) = max(tiny(fluxtop), fluxtop(i,j)/emcld(i,j))
!            tb(i,j) = fluxToTb(fluxtop(i ,j))
              tb(i,j) = 1307.27/ log(1.+(1./fluxtop(i,j)))
             if (tb(i,j) .gt. assumedFreezingTb)  then
               tauir(i,j) = tau(i,j) * VisTauToIrTauLiquid
             endif
            endif
           end do
           end do
        enddo
      end if  
      
      where(tau(:, :) > tiny(tau)) 
        tb(:, :) = fluxToTb(fluxtop(:, :))
      elsewhere
        ! Clear sky brightness temperature
        tb(:,:) = spread(fluxToTb(fluxtop_clrsky(:)), dim = 2, nCopies = nCol)
      end where 
      
      if(top_height == 1) then
        ! Adjust the brightness temperature and optical depth of very thin clouds
        where (tau(:, :) > tiny(tau) .and. tauir(:, :) < taumin(:, :)) 
           tb(:, :) = spread(attrop(:) - 5., dim= 2, nCopies = nCol)
          tau(:, :) = taumin(:, :) / VisTauToIrTauIce
        end where
      end if
    end if
    ! -----------------------------------------------------------------------------------
    ! Determine cloud-top pressure. Three choices:
    !     Radiatively determined cloud top pressure (top_height = 1 for VIS/R;  3 for IR)
    !     Physical cloud top pressure (top_height = 2)
    
    if (top_height .eq. 1 .or. top_height .eq. 3) then  
      !segregate according to optical thickness (??? - RP)
      levmatch(:, :) = 0
      do ibox=1,ncol
        ! find lowest (?) level whose temperature
        ! most closely matches brightness temperature
        !
        do ilev = 1, nlev-1
          where((at(:,ilev) >= tb(:,ibox) .and. at(:,ilev+1) < tb(:,ibox)) .or. &
                (at(:,ilev) <= tb(:,ibox) .and. at(:,ilev+1) > tb(:,ibox)) )
            where(abs(at(:,ilev) - tb(:,ibox)) < abs(at(:,ilev+1) - tb(:,ibox)))
              levmatch(:, ibox) = ilev
            elsewhere 
              levmatch(:, ibox) = ilev + 1
            end where
          end where 
        end do

        ! If we've found a matching level use it, otherwise use the boundary value
        !  
        do j = 1, nPoints
          if(levmatch(j, ibox) >= 1) then
            ptop(j, ibox) = pfull(j, levmatch(j, ibox))
          else if (tb(j, ibox) < minval(at(j, :))) then
            levmatch(j, ibox) = itrop_local(j)
            ptop(j, ibox) = ptrop(j)
          else if (tb(j, ibox) > maxval(at(j, :))) then
            levmatch(j, ibox) = nLev
            ptop(j, ibox) = pFull(j, nLev)
          end if
        end do
      end do
      
    else !  When top_height .eq. 2
      ! The highest cloud top (clouds being where tau > 0). 
      ptop(:, :) = 0.
      do ibox = 1, nCol
        do ilev = 1, nlev
          where(ptop(:, ibox) <= 0. .and. dtau(:, ibox, ilev) > 0.)
            ptop(:, ibox) = pfull(:, ilev)
            levmatch(:,ibox) = ilev
          end where
        end do
      end do
    end if                            
          
    ! No matter how cloud top pressure is determined, 
    !   pTop and levmatch are 0 when the column is clear.   
    ! 
    where (tau(:,:) <= tiny(tau)) 
      ptop(:,:) = 0.
      levmatch(:,:) = 0      
    end where
    !     ---------------------------------------------------!
    ! Output
    !    
    boxptop(:, :) = ptop(:, :) / 100. 
    boxtau(:, :)  = tau(:, :)
    
  end subroutine icarus
  ! -------------------------------------------------------------------
  ! ------------------------------------------------------ 
  function computeIsccpJointHistograms(tau, ptop, sunlit) result(isccpJointHistogram)
    ! Dimensions nGridCell, nSubColumn 
    real, dimension(:, :),    intent( in) :: tau, ptop
    ! Dimensions nGridCell 
    integer, dimension(:),    intent( in) :: sunlit
    ! Dimensions nGridCells, nTauLevels (7), nPressureLevels(7)
    real, dimension(size(tau, 1), numIsccpOpticalDepthIntervals, numIsccpPressureIntervals) &
                                          :: isccpJointHistogram
    
    ! Local parameters
    real, dimension(numIsccpPressureIntervals + 1),      parameter ::       &
             isccpPressureBinEdges = (/ tiny(isccp_taumin),                 &
                                        180., 310., 440., 560., 680., 800., &
                                        huge(isccp_taumin) /) 
    real, dimension(numIsccpOpticalDepthIntervals + 1)             ::            &
            isccpOpticalDepthBinEdges ! Set at runtime, since isccp_taumin is variable.

    ! Local variables
    integer                     :: i, j
    logical, dimension(size(tau, 1), size(tau, 2)) &
                                :: box_cloudy
    ! --------------------
    isccpOpticalDepthBinEdges = (/ tiny(isccp_taumin),                    &
                                   isccp_taumin, 1.3, 3.6, 9.4, 23., 60., & 
                                   huge(isccp_taumin) /) 
    box_cloudy(:, :) = tau(:, :) > tiny(tau) .and. ptop(:, :) > 0 
    
    !
    ! Construct the histogram
    !
    do i = 1, numIsccpPressureIntervals 
      do j = 1, numIsccpOpticalDepthIntervals 
        isccpJointHistogram(:, i, j) = count(box_cloudy(:, :) .and.                               &
                                             tau(:, :)  >= isccpOpticalDepthBinEdges(i)     .and. &
                                             tau(:, :)  <  isccpOpticalDepthBinEdges(i + 1) .and. &
                                             pTop(:, :) >= isccpPressureBinEdges(j)         .and. &
                                             pTop(:, :) <  isccpPressureBinEdges(j + 1), dim = 2)
      end do
    end do
    isccpJointHistogram(:, :, :)  = isccpJointHistogram(:, :, :)/size(tau, 2)
  end function computeIsccpJointHistograms
  ! ------------------------------------------------------ 
  ! ------------------------------------------------------ 
  function computeInhomogeneityParameter (tau,  ptop, sunlit)  result(inhomog_number)
    ! Dimensions nGridCell, nSubColumn 
    real, dimension(:, :),    intent( in) :: tau, ptop
    ! Dimensions nGridCell 
    integer, dimension(:),    intent( in) :: sunlit
    ! Dimensions nGridCell
    real, dimension(size(tau, 1))         :: inhomog_number
    
    ! Local variables
    real,   dimension(size(tau, 1))               :: logAve, linearAve, tmp
    logical, dimension(size(tau, 1), size(tau, 2)) :: isCloudy
    integer :: i,j
    !
    ! compute linear and logarithmic averages
    
    isCloudy(:, :) = tau(:,:) > isccp_taumin .and. ptop(:, :) > 0
    
    !
    ! compute inhomogeneity parameter
    
!    where(count(isCloudy(:, :), dim = 2) > minColsInhomo)
!      logAve(:)    = sum(log(tau(:, :)), dim = 2, mask = isCloudy(:, :)) / &
!                     count(isCloudy(:, :), dim = 2)
!      linearAve(:) = sum(tau(:, :),      dim = 2, mask = isCloudy(:, :)) / &
!                     count(isCloudy(:, :), dim = 2)
!      inhomog_number(:) = 1. - ( exp(logAve(:))/linearAve(:) )        
!    elsewhere
!      inhomog_number(:) = -1.
!    endwhere
    tmp = count(isCloudy(:, :), dim = 2)
    inhomog_number(:) = -1.
    do i= 1,size(logave,1)
      if ( tmp(i) > minColsInhomo) then
      logAve(i)    = 0.0
      linearAve(i) = 0.0
        do j = 1, size(tau,2)
          if (isCloudy(i,j) ) then
            logAve(i)    = logAve(i) + log(tau(i,j))
            linearAve(i) = linearAve(i) +  tau(i,j)
          endif
        enddo
      logAve(i)    = logAve(i)   /tmp(i)
      linearAve(i) = linearAve(i)/tmp(i)
      endif
    enddo  
    do i= 1,size(logave,1)
      if ( tmp(i) > minColsInhomo) &
        inhomog_number(i) = 1. - ( exp(logAve(i))/linearAve(i) )
    enddo  
    
  end function computeInhomogeneityParameter
  ! ------------------------------------------------------   
  ! -------------------------------------------------------------------      
  subroutine computeWaterVaporEmissivity(pfull, phalf, qv, at, dem_wv)
     real, dimension(:, :), & ! nPoints, nLev
       intent( in) :: pFull, pHalf, qv, at
     real, dimension(:, :), & ! nPoints, nLev
       intent(out) :: dem_wv
     
     ! Local variables
     integer :: nPoints, nLev
     integer :: iLev
     real, dimension(size(dem_wv, 1)) :: press, dpress, atmden, rvh20, wk, rhoave, rh20s, &
                                         rfrgn, tmpexp, tauwv
    
     real, parameter :: wtmair = 28.9644, wtmh20 = 18.01534, Navo = 6.023E+23, grav = 9.806650E+02, &
                        pstd = 1.013250E+06, t0 = 296.
    ! -------------------------------------------
    nPoints = size(pFull, 1); nLev    = size(pFull, 2)

    !compute water vapor continuum emissivity
    !this treatment follows Schwarkzopf and Ramasamy
    !JGR 1999,vol 104, pages 9467-9499.
    !the emissivity is calculated at a wavenumber of 955 cm-1, 
    !or 10.47 microns 
    do ilev=1,nlev
      ! press and dpress are dyne/cm2 = Pascals *10
      press(:) = pfull(:,ilev)*10.
      dpress(:) = (phalf(:,ilev+1)-phalf(:,ilev))*10
      !atmden = g/cm2 = kg/m2 / 10 
      atmden(:) = dpress(:)/grav
      rvh20(:) = qv(:,ilev)*wtmair/wtmh20
      wk(:) = rvh20(:)*Navo*atmden(:)/wtmair
      rhoave(:) = (press(:)/pstd)*(t0/at(:,ilev))
      rh20s(:) = rvh20(:)*rhoave(:)
      rfrgn(:) = rhoave(:)-rh20s(:)
      tmpexp(:) = exp(-0.02*(at(:,ilev)-t0))
      tauwv(:) = wk(:)*1.e-20*((0.0224697*rh20s(:)*tmpexp(:)) + (3.41817e-7*rfrgn(:)) )*0.98
      dem_wv(:,ilev) = 1. - exp( -1. * tauwv(:))
    end do
  end subroutine computeWaterVaporEmissivity 
  ! -------------------------------------------------------------------
  subroutine diagnoseTropPressure(pfull, at, itrop)
    real,    dimension(:, :), intent( in) :: pFull, at
    integer, dimension(:),    intent(out) :: itrop
    
    integer                         :: nPoints, nLev
    real, dimension(size(pFull, 1)) :: attropmin
    integer                         :: ilev

    nPoints = size(pFull, 1); nLev = size(pFull, 2)
    attropmin(:) = 400.
    itrop(:)     = 1
  
    do  ilev=1,nlev
      where(pfull(:, ilev) < 40000. .and. pfull(:, ilev) > 5000. .and. &
            at(:, ilev) < attropmin(:)) 
        attropmin(:) = at(:, ilev)
        itrop(:)=ilev
      end where
    end do
  end subroutine diagnoseTropPressure 
  ! -------------------------------------------------------------------      
  ! -------------------------------------------------------------------      
  subroutine check_bounds(array, name, minAllowed, maxAllowed)
    implicit none
    ! Input variables
    real, dimension(:, :), intent( in) :: array
    character(len = *),    intent( in) :: name
    real,                  intent( in) :: minAllowed, maxAllowed
    
    ! ---------------------
    if(any(array(:, :) < minAllowed .or. array(:, :) > maxAllowed)) then
      call error_mesg ('isccp_clouds_mod', &
                       'Values in array out of bounds', FATAL)
    end if
  end subroutine check_bounds
  ! -------------------------------------------------------------------      
  subroutine check_Lbound(array, name, minAllowed)
    implicit none
    ! Input variables
    real, dimension(:, :, :), intent( in) :: array
    character(len = *),       intent( in) :: name
    real,                     intent( in) :: minAllowed
    
    ! ---------------------
    if(any(array(:, :, :) < minAllowed )) then
      call error_mesg ('isccp_clouds_mod', &
                       'Array values smaller than lower bound', FATAL)
    end if
  end subroutine check_lBound
  ! -------------------------------------------------------------------      
  ! Functions to compute brightness temperature given a 11 micron radiance
  !
  ! -------------------------------------------------------------------      
  function fluxToTb_1D(flux) result(tb)
    real, dimension(:),       intent( in) :: flux
    real, dimension(size(flux))           :: tb
    
    tb(:) = 1307.27 / log(1. + (1./flux(:)))
  end function fluxToTb_1D
  !     ---------------------------------------------------!
  function fluxToTb_2D(flux) result(tb)
    real, dimension(:, :),    intent( in) :: flux
    real, dimension(size(flux, 1), &
                    size(flux, 2))        :: tb
    
    tb(:, :) = 1307.27 / log(1. + (1./flux(:, :)))
  end function fluxToTb_2D
  !     ---------------------------------------------------!
  function fluxToTb_3D(flux) result(tb)
    real, dimension(:, :, :), intent( in) :: flux
    real, dimension(size(flux, 1), &
                    size(flux, 2), &
                    size(flux, 3))        :: tb
    
    tb(:, :, :) = 1307.27 / log(1. + (1./flux(:, :, :)))
  end function fluxToTb_3D
  ! -------------------------------------------------------------------      
  ! Functions to compute 11 micron radiance given a brightness temperature
  !
  ! -------------------------------------------------------------------      
  function TbToFlux_1D(tb) result(flux)
    real, dimension(:),       intent( in) :: tb
    real, dimension(size(tb))             :: flux
    
    flux(:) = 1. / ( exp(1307.27/tb(:)) - 1. )
  end function TbToFlux_1D
  !     ---------------------------------------------------!
  function TbToFlux_2D(tb) result(flux)
    real, dimension(:, :),    intent( in) :: tb
    real, dimension(size(tb, 1), &  
                    size(tb, 2))          :: flux
    
    flux(:, :) = 1. / ( exp(1307.27/tb(:, :)) - 1. )
  end function TbToFlux_2D
  ! ---------------------------------------------------!
  function TbToFlux_3D(tb) result(flux)
    real, dimension(:, :, :), intent( in) :: tb
    real, dimension(size(tb, 1), &
                    size(tb, 2), &
                    size(tb, 3))          :: flux
    
    flux(:, :, :) = 1. / ( exp(1307.27/tb(:, :, :)) - 1. )
  end function TbToFlux_3D
  ! -------------------------------------------------------------------      
  ! -------------------------------------------------------------------      
  subroutine computeRadiance_1D(dem, at, skt, emsfc_lw, TOAradiance)
    real,    dimension(:, :), &  ! Dimensions nPoints, nLev
      intent( in) :: dem,     &  !   10.5 micron emissivity of water vapor
                     at          !   air temperature
    real,   dimension(:),     &  ! Dimension nPoints
      intent( in) :: skt,     &  !   skin Temperature (K)
                     emsfc_lw    !   10.5 micron emissivity of surface (fraction) 
    real, dimension(:),       &  ! Dimension nPoint, nCol
      intent(out) :: TOAradiance !   10.5 micron nadir radiance at TOA
    
  !     ------
  !     Local variables and parameters
    integer :: nPoints, nLev
    !     ------
    integer ::  ilev
    real,    dimension(size(dem, 1)) :: trans_layers_above
    real,    dimension(size(dem, 1)) :: bb
                                                          
    !----------------------------------------------------------------------
    ! Computes radiance at TOA from an emitting/absorbing atmosphere
    !     TOAradiance is the 10.5 micron radiance at the top of the
    !              atmosphere
    !     trans_layers_above is the total transmissivity in the layers
    !             above the current layer
    !----------------------------------------------------------------------
  
    !initialize variables
    nPoints = size(dem, 1); nLev    = size(dem, 2)
    TOAradiance(:) = 0.; trans_layers_above(:) = 1.
  
    do ilev=1,nlev
      ! Black body emission at temperature of the layer
      bb(:) = TbToFlux(at(:,ilev))
  
      ! increase TOA flux by flux emitted from layer
      ! times total transmittance in layers above
      TOAradiance(:) = TOAradiance(:) + dem(:, ilev) * trans_layers_above(:) * bb(:)
        
      ! update trans_layers_above with transmissivity
      ! from this layer for next time around loop
      trans_layers_above(:) = trans_layers_above(:) * (1. - dem(:, ilev))
    enddo ! ilev
  
    !surface emission
    bb(:) = TbToFlux(skt(:)) 
  
    !add in surface emission
    TOAradiance(:) = TOAradiance(:) + trans_layers_above(:) * emsfc_lw(:) * bb(:)
                       
  end subroutine computeRadiance_1D
 ! -------------------------------------------------------------------      
  subroutine computeRadiance_2D(dem, at, skt, emsfc_lw, TOAradiance)
    real,    dimension(:, :, :), &  ! Dimensions nPoints, nCol, nLev
      intent( in) :: dem            !   10.5 micron emissivity of water vapor
   real,    dimension(:, :),     &  ! Dimensions nPoints, nLev
      intent( in) :: at             !   air temperature
    real,   dimension(:),        &  ! Dimension nPoints
      intent( in) :: skt,        &  !   skin Temperature (K)
                     emsfc_lw       !   10.5 micron emissivity of surface (fraction) 
    real, dimension(:, :),       &  ! Dimension nPoint, nCol
      intent(out) :: TOAradiance    !   10.5 micron nadir radiance at TOA
    
  !     ------
  !     Local variables and parameters
    integer :: nPoints, nCol, nLev 
    !     ------
    integer ::  ilev
    real,    dimension(size(dem, 1), &
                       size(dem, 2)) :: trans_layers_above
    real,    dimension(size(dem, 1)) :: bb
 
    !----------------------------------------------------------------------
    ! Computes radiance at TOA from an emitting/absorbing atmosphere
    !     TOAradiance is the 10.5 micron radiance at the top of the
    !              atmosphere
    !     trans_layers_above is the total transmissivity in the layers
    !             above the current layer
    !----------------------------------------------------------------------
  
    !initialize variables
    nPoints = size(dem, 1); nCol    = size(dem, 2); nLev    = size(dem, 3)
    TOAradiance(:, :) = 0.; trans_layers_above(:, :) = 1.
  
    do ilev=1,nlev
      ! Black body emission at temperature of the layer
      bb(:) = TbToFlux(at(:,ilev))
  
      ! increase TOA flux by flux emitted from layer
      ! times total transmittance in layers above
      TOAradiance(:,:) = TOAradiance(:,:) + &
                         dem(:,:, ilev) * trans_layers_above(:,:) * spread(bb(:), dim = 2, nCopies = nCol) 
        
      ! update trans_layers_above with transmissivity
      ! from this layer for next time around loop
      trans_layers_above(:, :) = trans_layers_above(:, :) * (1. - dem(:, :, ilev))
    enddo ! ilev
  
    !surface emission
    bb(:) = TbToFlux(skt(:)) 
  
    !add in surface emission
    TOAradiance(:,:) = TOAradiance(:,:) +  &
                       trans_layers_above(:,:) * spread(emsfc_lw(:) * bb(:), dim = 2, nCopies = nCol)
  
  end subroutine computeRadiance_2D
 ! -------------------------------------------------------------------      
  subroutine ran0_vec(idum, ran0)
    integer, dimension(:), intent(inout) :: idum
    real,    dimension(:), intent(  out) :: ran0
!     $Id: isccp_clouds.F90,v 17.0.8.2 2010/08/30 20:39:46 wfc Exp $
!     Platform independent random number generator from
!     Numerical Recipies
!     Mark Webb July 1999
!     Fortran 90 implementation Robert Pincus, Dec 2003
    
    integer, parameter :: IA = 16807, IM = 2147483647,  IQ = 127773, IR = 2836
    real,    parameter :: AM = 1.0/IM
    
    integer, dimension(size(idum)) :: k

    if(any(idum(:) == 0))                  &
      call error_mesg ('isccp_clouds_mod', &
                       'idum: ZERO seed not allowed', FATAL)

    k(:) = idum(:) / IQ
    idum (:) = IA * (idum(:) - k(:) * IQ) - IR * k(:)
    where (idum(:) < 0) idum(:) = idum(:) + IM
    ran0(:) = AM * idum(:)

  end subroutine ran0_vec
!#####################################################################

                end module isccp_clouds_mod




!FDOC_TAG_GFDL
      module lhsw_driver_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!   fil
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!            lacis-hansen shortwave parameterization
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use rad_utilities_mod,     only: astronomy_type, &
                                 Sw_control, &
                                 atmos_input_type, &
                                 surface_type, &
                                 sw_output_type, &
                                 cld_space_properties_type, &
                                 radiative_gases_type, &
                                 cld_specification_type, &
                                 cldrad_properties_type
use  constants_mod,        only: GRAV, diffac, radcon, alogmin, wtmair
use        mpp_mod,        only: input_nml_file
use        fms_mod,        only: fms_init, open_namelist_file, file_exist, &
                                 check_nml_error, error_mesg, &  
                                 FATAL, close_file, mpp_pe, mpp_root_pe, &
                                 write_version_number, stdlog

!--------------------------------------------------------------------

implicit none
private


!--------------------------------------------------------------------
!            lacis-hansen shortwave parameterization
!
!------------------------------------------------------------------


!--------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

    character(len=128)  :: version =  '$Id: lhsw_driver.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
    character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'
    logical             :: module_is_initialized = .false.



!---------------------------------------------------------------------
!-------  interfaces --------
 
public  lhsw_driver_init, lhsw_driver_end, swrad

private convert_to_cloud_space


!-------------------------------------------------------------------
!-------- namelist ----------


real     :: dummy = 0.0
integer  :: nbands_to_use = 9
logical  :: calculate_o2_absorption = .false.

namelist /lhsw_driver_nml /         &
                            nbands_to_use, &
                            calculate_o2_absorption, &
                            dummy


!--------------------------------------------------------------------
!------ public data -------





!--------------------------------------------------------------------
!------ private data -------


!---------------------------------------------------------------------
!       abcff   = absorption coefficients for bands in k-distribution
!                 that were originally given by lacis and hansen and
!                 revised by ramaswamy.
!       pwts    = the corresponding weights assigned to the 
!                 shortwave radiation k-distribution.
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   absorption coefficients and weights for bands as revised by 
!   ramaswamy.
!-------------------------------------------------------------------

real, dimension(12)   :: abcff_12, pwts_12

data abcff_12 /4.0000E-05, 4.0000E-05, 0.0020E+00, 0.0350E+00,   &
               0.3770E+00, 1.9500E+00, 9.4000E+00, 4.4600E+01,   &
               1.9000E+02, 9.8900E+02, 2.7060E+03, 3.9011E+04/
  
data pwts_12 /0.50000E+00, 0.121416E+00, 0.06980E+00, 0.15580E+00, &
              0.06310E+00, 0.036200E+00, 0.02430E+00, 0.01580E+00,&
              0.00870E+00, 0.001467E+00, 0.23420E-02, 0.10750E-02/

!---------------------------------------------------------------------
!     the original 9-band lacis-hansen coefficients and weights.
!---------------------------------------------------------------------
 
real, dimension(9)    :: abcff_9, pwts_9

data abcff_9 /4.000E-05, 4.000E-05, 0.002E+00, 0.035E+00,  &
              0.377E-00, 1.950E+00, 9.400E+00, 4.460E+01,  &
              1.900E+02/

data pwts_9 /0.5000E+00, 0.1470E+00, 0.0698E+00, 0.1443E+00,  &
             0.0584E+00, 0.0335E+00, 0.0225E+00, 0.0158E+00, &
             0.0087E+00/

 
!--------------------------------------------------------------------
!   cfco2, cfo3 = conversion factors from gm/cm**2 to cm-atm (standard
!                 temperature and pressure).
!reflo3, rrayav = reflection coefficients given by lacis and hansen to 
!                 account for effects of rayleigh scattering in the 
!                 visible band one frequencies.         
!         prko2 = pressure (mb) below which o2 absorption affects short-
!                 wave transmissivities. 
!       efmago3 = ??????????
!--------------------------------------------------------------------
real           :: cfco2=5.0896E+02
real           :: cfo3=4.6664E+02
real           :: reflo3=1.9000E+00
real           :: rrayav=1.4400E-01
real           :: prko2=2.8
real           :: efmago3=1.900
!---------------------------------------------------------------------
 
integer        :: NB
integer        :: ixprko2


real, dimension(:), allocatable   :: abcff, pwts

real  :: wtmco2 = 44.00995
real  :: rco2air







!------------------------------------------------------------------
!------------------------------------------------------------------




contains


! <SUBROUTINE NAME="lhsw_driver_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lhsw_driver_init ( pref )
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine lhsw_driver_init ( pref )

real, dimension(:,:), intent(in) :: pref

      integer :: unit, ierr, io, logunit
      integer :: k, KSL, KEL, kmin, kmax

      real, dimension(size(pref,1) )  :: plm
      
      call fms_init

!---------------------------------------------------------------------
!-----  read namelist  ------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=lhsw_driver_nml, iostat=io)
      ierr = check_nml_error(io,'lhsw_driver_nml')
#else   
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=lhsw_driver_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'lhsw_driver_nml')
        enddo
10      call close_file (unit)
      endif
#endif

      if ( mpp_pe() == mpp_root_pe() ) then
        call write_version_number(version, tagname)
        logunit = stdlog()
        write (logunit,nml=lhsw_driver_nml)
      endif

!---------------------------------------------------------------------
      KSL = 1
      KEL = size(pref, 1) - 1
      kmin = ksl
      kmax = kel
 
!     if (Environment%using_fms_periphs) then
      if (nbands_to_use == 9) then
         NB = 9
         allocate (abcff (9) )
         allocate (pwts  (9) )
        abcff(:) = abcff_9(:)
         pwts(:)  = pwts_9(:)
!     else if (Environment%using_sky_periphs) then
      else if (nbands_to_use == 12) then           
        NB = 12
        allocate (abcff (12) )
        allocate (pwts  (12) )
        abcff(:) = abcff_12(:)
        pwts(:)  = pwts_12(:)
      else
        call error_mesg ('lhsw_driver_mod', &
           ' nbands_to_use has improper value', FATAL)
      endif

!-------------------------------------------------------------------
!   convert pressure specification for bottom (flux) pressure level
!   for o2 calculation into an index (ixprko2)
!------------------------------------------------------------------- 

      plm (kmin) = 0.
     do k=kmin+1,kmax
         plm (k) = 0.5*(pref (k-1,1) + pref (k,1))
     enddo
      plm (kmax+1) = pref (kmax+1,1)
      ixprko2 = KSL 
      do k=KSL+1,KEL
        if ((plm(k)*1.0E-02 - prko2) .LT. 0.0) then
          ixprko2 = k + KSL - 1
        else
          exit
        endif
      enddo


      rco2air = wtmco2/wtmair

!------------------------------------------------------------------- 
      module_is_initialized = .true.
!------------------------------------------------------------------- 


end subroutine lhsw_driver_init


!######################################################################
! <SUBROUTINE NAME="lhsw_driver_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lhsw_driver_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine lhsw_driver_end

!------------------------------------------------------------------- 
      module_is_initialized = .true.
!---------------------------------------------------------------------

end subroutine lhsw_driver_end




!######################################################################
 
! <SUBROUTINE NAME="swrad">
!  <OVERVIEW>
!     Swrad solves for shortwave radiation.
!
!     references:
!
!     (1)  lacis, a. a. and j. e. hansen, "a parameterization for the
!          absorption of solar radiation in the earth's atmosphere,"
!          journal of the atmospheric sciences, 31 (1974), 118-133.
!
!     author: m. d. schwarzkopf
!
!     revised: 1/1/93
!
!     certified:  radiation version 1.0
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call swrad ( is, ie, js, je,   &
!                Astro,                with_clouds,    Atmos_input,   &
!                Surface,  &
!                Rad_gases,                                   &
!                Cldrad_props, Cld_spec, Sw_output, Cldspace_rad, gwt)
!
!  </TEMPLATE>
!  <IN NAME=" is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
! 
!  </IN>
!  <IN NAME="with_clouds" TYPE="logical">
! 
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
! 
!  </IN>
!  <IN NAME="Surface" TYPE="surface_type">
! 
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
! 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
! 
!  </IN>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
! 
!  </INOUT>
!  <INOUT NAME="Cldspace_rad" TYPE="cld_space_properties_type">
! 
!  </INOUT>
!  <IN NAME="gwt" TYPE="real">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine swrad ( is, ie, js, je,   &
            Astro,                with_clouds,    Atmos_input,   &
             Surface,  &
            Rad_gases,                                   &
   Cldrad_props, Cld_spec, Sw_output, Cldspace_rad, gwt)
       
!-----------------------------------------------------------------------
!
!     Swrad solves for shortwave radiation.
!
!     references:
!
!     (1)  lacis, a. a. and j. e. hansen, "a parameterization for the
!          absorption of solar radiation in the earth's atmosphere," 
!          journal of the atmospheric sciences, 31 (1974), 118-133.
!
!     author: m. d. schwarzkopf
!
!     revised: 1/1/93
!
!     certified:  radiation version 1.0
!
!-----------------------------------------------------------------------
!     intent in:
!
!     fracday =  fraction of day (or timestep) that sun is above 
!                horizon.
! 
!     press   =  pressure at data levels of model.
!
!     qo3     =  mass mixing ratio of o3 at model data levels.
!
!     rh2o    =  mass mixing ratio of h2o at model data levels.
!
!     ssolar  =  solar constant (may vary over one year). units: Wm-2.
!
! cosangsolar =  zenith angle at grid point.
!-----------------------------------------------------------------------

integer,                  intent(in)     :: is, ie, js, je
logical,                  intent(in)     :: with_clouds
type(cldrad_properties_type), intent(in) :: Cldrad_props
type(cld_specification_type), intent(in) :: Cld_spec       
real, dimension(:), optional, intent(in) :: gwt
type(astronomy_type), intent(in) :: Astro
type(atmos_input_type), intent(in) :: Atmos_input
type(surface_type), intent(in) :: Surface
type(radiative_gases_type), intent(in) :: Rad_gases  

type(sw_output_type), intent(inout) :: Sw_output
type(cld_space_properties_type), intent(inout) :: Cldspace_rad

!-----------------------------------------------------------------------
!     intent out:
!
!     dfsw    =  downward radiation at all pressure levels.
!
!     fsw     =  net radiation (up-down) at all pressure levels.
!
!     hsw     =  radiation heating rates at all pressure layers.
!
!     ufsw    =  upward radiation at all pressure levels.
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!     intent local:
!
!     absdo3  =  absorption of o3 down the atmosphere.
!
!     absuo3  =  absorption of o3 up the atmosphere.
!
!     alfa    =  effective reflective coefficient of a cloud and all
!                clouds below it.
! 
!     alfau   =  effective reflective coefficient excluding current
!                cloud.
!
!     cr      =  coefficient of reflection of a cloud.
!
!     ct      =  coefficient of transmission of a cloud.
!
!     dfn     =  downwards flux for current band n.
!
!     dfnclb  =  down flux at cloud bottom.
!
!     dfnclt  =  down flux at cloud top.
!
!     dfntop  =  down flux at atmosphere top. (in cgs units)
!
!     dfntrn  =  down flux partial product at cloud.
!
!     dp      =  derivative of pressure.
!
!     dpcldi  =  inverse of pressure difference between cloud top and
!                bottom.
!
!     du      =  delta optical path.
!
!     duco2   =  delta optical path for co2.
!
!     duo3    =  delta optical path for o3.
!
!     ff      =  angular optical factor.
!
!     ffco2   =  angular optical for co2.
!
!     ffo3    =  angular optical for o3.
!
!     pp      =  pressure.
!
!     ppbtm   =  pressure at bottom of cloud.
!
!     pptop   =  pressure at top of cloud.
!
!     pr2     =  normalized pressure.
!
!     refl    =  ground coefficent of reflection.
!
!     rray    =  parameterization for rayleigh scrattering.
!
!     secz    =  average secant of solar angle.
!
!     tdclbt  =  transmission down from cloud top to next cloud top
!
!     tdcltt  =  transmission down from cloud top to to next cloud top.
!
!     tdcltop =  transmission down at cloud top.
!
!     tdcltopi=  inverse of tdcltop.
!
!     tdclbtm =  transmission down at cloud bottom.
!
!     tdco2   =  transmission down co2.
!
!     ttd     =  transmission down h2o.
!
!     ttdb1   =  band one transmission quantity.
!
!     ttu     =  transmission up h2o.
!
!     ttub1   =  band one transmission quantity.
!
!     tuclbtm =  transmission up at cloud bottom.
!
!     tucltop =  transmission up at cloud top.
!
!     tucltop =  inverse of tucltop.
!
!     tuco2   =  transmission up co2.
!
!     ud      =  optical path down h2o.
!
!     udco2   =  optical path down co2.
!
!     udo3    =  optical path down o3.
!
!     ufn     =  upward flux for current band n.
!
!     ufnclb  =  upward flux at cloud bottom.
!
!     ufnclt  =  upward flux cloud top.
!
!     ufntrn  =  up flux partial product at cloud.
!
!     uu      =  optical path up h2o.
!
!     uuco2   =  optical path up co2.
!
!     uuo3    =  optical path up o3.
!
!     absdo2  =  absorption down o2.
!     udo2    =  optical path o2 (up-down).
!     uo2     =  optical path o2 (up-down).
!-----------------------------------------------------------------------
      real, dimension(:,:),   allocatable :: refl, rray, seczen
      real, dimension(:,:,:), allocatable ::   &
  absdo3,        absuo3,          alfa,   &
  alfau,         alogtt,          cr,       &
  ct,            dfn,             dfncltop, &
  dfnlbc,        dfntop,          dp,       &
  dpcldi,        du,              duco2,    &
  duo3,          ff,              ffco2,    &
  ffo3,          pp,              pptop,    &
  pr2,           tdcltt,          tdclbt,   &
  tdcltop,       tdclbtm,         tdco2,    &
  ttd,           ttdb1,           ttu,      &
  ttub1,         tucltop,         tuco2,    &
  ud,            udco2,           udo3,     &
  ufn,           ufncltop,        ufnlbc,   &
  uu,            uuco2,           uuo3,     &
  absdo2,        uo2,             dfswg,    &
  fswg,          hswg,            ufswg
     integer :: k,j,i,kc, kc1, nband, ko, ngp, kcldsw
     real    :: tempu, tempd
     real, dimension(:,:,:  ),  allocatable   :: cirabsw, cirrfsw, &
                  cvisrfsw
     real, dimension(:,:,:),    allocatable   :: camtsw
     integer, dimension(:,:),   allocatable   :: ncldsw            
     integer, dimension(:,:,:), allocatable   :: ktopsw, kbtmsw    

     integer :: israd, ierad, jsrad, jerad, ks, ke
     real    :: rrco2
     real :: rrvco2
     integer :: nsolwg=1
     real, dimension(size(Atmos_input%press,1),  &
                   size(Atmos_input%press,2),1) :: cosangsolar
     real, dimension(size(Atmos_input%press,1),  &
                   size(Atmos_input%press,2)  ) :: fracday, &
                               cirabgd, cvisrfgd_dir, cirrfgd_dir, &
                                  cvisrfgd_dif, cirrfgd_dif

     real, dimension(size(Atmos_input%press,1),   &
                size(Atmos_input%press,2), &
                      size(Atmos_input%press,3)) :: press     

     real, dimension(size(Atmos_input%press,1),   &
                size(Atmos_input%press,2), &
                      size(Atmos_input%press,3)-1) :: qo3, rh2o 

     real :: ssolar


     cosangsolar(:,:, 1) = Astro%cosz(:,:)
     fracday(:,:) = Astro%fracday(:,:)
!    cvisrfgd(:,:) = Surface%asfc(:,:)
!    cirrfgd(:,:) = Surface%asfc(:,:)
     cvisrfgd_dir(:,:) = Surface%asfc_vis_dir(:,:)
     cirrfgd_dir(:,:) = Surface%asfc_nir_dir(:,:)
     cvisrfgd_dif(:,:) = Surface%asfc_vis_dif(:,:)
     cirrfgd_dif(:,:) = Surface%asfc_nir_dif(:,:)    


! convert press to cgs.
      press(:,:,:) = 10.0*Atmos_input%press(:,:,:)
      rh2o (:,:,:) = Atmos_input%rh2o (:,:,:)
      qo3(:,:,:) = Rad_gases%qo3(:,:,:)
      rrvco2 = Rad_gases%rrvco2

      ssolar = Sw_control%solar_constant*Astro%rrsun

     israd = 1
     ierad = size(Atmos_input%press, 1)
     jsrad = 1
     jerad = size(Atmos_input%press,2)
     ks    = 1
     ke    = size(Atmos_input%press,3) - 1
    

!--------------------------------------------------------------------
!     allocate space for and then retrieve the number of clouds in 
!     in each model column.
!------------------------------------------------------------------
      allocate( ncldsw (ISRAD:IERAD, JSRAD:JERAD) )
      ncldsw(:,:) = Cld_spec%ncldsw(:,:)

!---------------------------------------------------------------------
!     define the maximum number of clouds in any column of the chunk
!     and the distribution of clouds with grid column to be used in 
!     this execution of the shortwave radiation code.
!---------------------------------------------------------------------
      if (with_clouds) then
        kcldsw = MAXVAL(ncldsw)
      else
        kcldsw = 0
        ncldsw(:,:) = 0
      endif

!--------------------------------------------------------------------
!     allocate space for and then retrieve the shortwave radiative 
!     cloud properties in each model column.
!------------------------------------------------------------------
      if (kcldsw /= 0) then
        allocate( camtsw (ISRAD:IERAD, JSRAD:JERAD, 1:kcldsw) )
        allocate( ktopsw (ISRAD:IERAD, JSRAD:JERAD, 1:kcldsw) )
        allocate( kbtmsw (ISRAD:IERAD, JSRAD:JERAD, 1:kcldsw+1) )
        allocate( cirabsw(ISRAD:IERAD, JSRAD:JERAD, 1:kcldsw        ) )
        allocate( cirrfsw(ISRAD:IERAD, JSRAD:JERAD, 1:kcldsw        ) )
        allocate( cvisrfsw(ISRAD:IERAD, JSRAD:JERAD,1:kcldsw        ) )
        camtsw   = 0.0
        ktopsw   = 0.0
        kbtmsw   = 0.0
        cirabsw  = 0.0
        cirrfsw  = 0.0
        cvisrfsw = 0.0
        call convert_to_cloud_space (is, ie, js, je,   Cldrad_props, &
           Cld_spec,      cirabsw, cirrfsw, cvisrfsw,  &
   ktopsw, kbtmsw, camtsw, Cldspace_rad)

!!! IS THIS NEEDED ???
!!! 1-13-03  : YES, YES, YES !!!!
      else if (with_clouds) then
!!!!! needed for radiation_diag_mod
       allocate ( Cldspace_rad%camtswkc(ie-is+1, je-js+1, 1 ))
       allocate ( Cldspace_rad%cirabswkc(ie-is+1, je-js+1, 1 ))
       allocate ( Cldspace_rad%cirrfswkc(ie-is+1, je-js+1, 1 ))
       allocate ( Cldspace_rad%cvisrfswkc(ie-is+1, je-js+1, 1 ))
       allocate ( Cldspace_rad%ktopswkc(ie-is+1, je-js+1,  1 ))
       allocate ( Cldspace_rad%kbtmswkc(ie-is+1, je-js+1,  1 ))
       Cldspace_rad%camtswkc = -99.0       
       Cldspace_rad%cirabswkc = -99.0       
       Cldspace_rad%cirrfswkc = -99.0       
       Cldspace_rad%cvisrfswkc = -99.0        
       Cldspace_rad%ktopswkc = -99.0      
       Cldspace_rad%kbtmswkc = -99.0         
      endif
  
!--------------------------------------------------------------------
!    allocate local arrays
!--------------------------------------------------------------------

      allocate( absdo3  (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( absuo3  (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( alfa    (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( alfau   (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( alogtt  (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( cr      (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( ct      (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( dfn     (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( dfncltop(ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( dfnlbc  (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( dfntop  (ISRAD:IERAD, JSRAD:JERAD, NB) )
      allocate( dp      (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( dpcldi  (ISRAD:IERAD, JSRAD:JERAD, kcldsw) )
      allocate( du      (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( duco2   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( duo3    (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ff      (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ffco2   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ffo3    (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( pp      (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( pptop   (ISRAD:IERAD, JSRAD:JERAD, kcldsw) )
      allocate( pr2     (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( refl    (ISRAD:IERAD, JSRAD:JERAD) )
      allocate( rray    (ISRAD:IERAD, JSRAD:JERAD) )
      allocate( seczen  (ISRAD:IERAD, JSRAD:JERAD) )
      allocate( tdcltt  (ISRAD:IERAD, JSRAD:JERAD, kcldsw  ))
      allocate( tdclbt  (ISRAD:IERAD, JSRAD:JERAD, kcldsw  ) ) 
      allocate( tdcltop (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( tdclbtm (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( tdco2   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ttd     (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ttdb1   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ttu     (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ttub1   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( tucltop (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( tuco2   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ud      (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( udco2   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( udo3    (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ufn     (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( ufncltop(ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( ufnlbc  (ISRAD:IERAD, JSRAD:JERAD, kcldsw+1) )
      allocate( uu      (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( uuco2   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) ) 
      allocate( uuo3    (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )

      allocate( absdo2  (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      allocate( uo2     (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
      absdo3 = 0.0 ; absuo3   = 0.0 ; alfa     = 0.0 ; alfau    = 0.0
      alogtt   = 0.0 ; cr       = 0.0 ; ct       = 0.0 ; dfn      = 0.0
      dfncltop = 0.0 ; dfnlbc   = 0.0 ; dfntop   = 0.0 ; dp       = 0.0
      dpcldi   = 0.0 ; du       = 0.0 ; duco2    = 0.0 ; duo3     = 0.0
      ff       = 0.0 ; ffco2    = 0.0 ; ffo3     = 0.0 ; pp       = 0.0
      pptop    = 0.0 ; pr2      = 0.0 ; refl     = 0.0 ; rray     = 0.0
      seczen   = 0.0 ; tdcltt   = 0.0 ; tdclbt   = 0.0 ; tdcltop  = 0.0
      tdclbtm  = 0.0 ; tdco2    = 0.0 ; ttd      = 0.0 ; ttdb1    = 0.0
      ttu      = 0.0 ; ttub1    = 0.0 ; tucltop  = 0.0 ; tuco2    = 0.0
      ud       = 0.0 ; udco2    = 0.0 ; udo3     = 0.0 ; ufn      = 0.0
      ufncltop = 0.0 ; ufnlbc   = 0.0 ; uu       = 0.0 ; uuco2    = 0.0
      uuo3     = 0.0 ; absdo2   = 0.0 ; uo2      = 0.0

      if (present(gwt)) then
        allocate( dfswg   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
        allocate( fswg    (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
        allocate( hswg    (ISRAD:IERAD, JSRAD:JERAD, KS:KE  ) )
        allocate( ufswg   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )
        dfswg = 0.0 ; fswg = 0.0 ; hswg =0.0  ; ufswg =0.0
      endif
!----------------------------------------------------------------------

    rrco2 = rrvco2*rco2air

    do ngp=1,nsolwg

!-----------------------------------------------------------------------
!     calculate secant of zenith angle seczen, flux pressures pp, layer
!     width dp, and pressure scaling factor pr2.  see reference (1).
!-----------------------------------------------------------------------

      seczen(:,:        ) = 3.5E+01/SQRT(1.224E+03*  &
    cosangsolar(:,:,ngp)*  &
                            cosangsolar(:,:,ngp) + 1.0E+00)
      pp    (:,:,KS     ) = 0.0E+00
      pp    (:,:,KE+1   ) = press(:,:,KE+1)
      pp    (:,:,KS+1:KE) = (press(:,:,KS+1:KE) + press(:,:,KS:KE-1))* &
                             0.5E+00
      dp    (:,:,KS:KE  ) = (pp(:,:,KS+1:KE+1) - pp(:,:,KS:KE  ))
      pr2   (:,:,KS:KE  ) = (pp(:,:,KS:KE  )+ pp(:,:,KS+1:KE+1))*0.5E+00
      do k=KS,KE
        pr2(:,:,k) = pr2(:,:,k)/press(:,:,KE+1)
      end do

!-----------------------------------------------------------------------
!     set up angular factor to be multiplied by the optical factor.
!     above the highest cloud, this is the secant of the zenith angle 
!     seczen (modified slightly for refractive effects).  below the 
!     highest cloud, this is diffac (efmago3 for ozone, in accordance 
!     with lacis-hansen parameterization).  this factor is used 
!     regardless of cloud amount and for direct and diffuse radiation 
!     (this is not a 2-1/2 stream model).
!-----------------------------------------------------------------------

      ff   (:,:,KS:KE+1) = diffac
      ffco2(:,:,KS:KE+1) = diffac
      ffo3 (:,:,KS:KE+1) = efmago3
      do j=JSRAD,JERAD
        do i=ISRAD,IERAD
  if (ncldsw(i,j) .NE. 0) then
            kc1=ktopsw(i,j,ncldsw(i,j))
  else
    kc1 = KE+1
  endif
          do kc=KS,kc1 
            ffo3 (i,j,kc) = seczen(i,j) 
            ffco2(i,j,kc) = seczen(i,j)
            ff   (i,j,kc) = seczen(i,j) 
          end do
        end do
      end do

!-----------------------------------------------------------------------
!     calculate pressure-weighted optical paths for each layer.
!     pressure weighting uses pr2.  du equals value for h2o; duco2 for
!     co2; duo3 for o3.
!-----------------------------------------------------------------------
      duo3 (:,:,KS:KE) = (cfo3/(1.0E+02*GRAV))*qo3(:,:,KS:KE)*dp(:,:,KS:KE)
      duco2(:,:,KS:KE) = (rrco2/(1.0E+02*GRAV)*cfco2)*dp(:,:,KS:KE)*  &
                          pr2(:,:,KS:KE)
      du   (:,:,KS:KE) = rh2o(:,:,KS:KE)*dp(:,:,KS:KE)* &
                          pr2(:,:,KS:KE)/(1.0E+02*GRAV)

!-----------------------------------------------------------------------
!     obtain the optical path from the top of the atmosphere to the
!     flux pressure.  angular factors are now included.  ud equals 
!     downward path for h2o, with uu the upward path for h2o. 
!     corresponding quantities for co2 and o3 are udco2/uuco2 and 
!     udo3/uuo3 respectively.
!-----------------------------------------------------------------------
      ud   (:,:,KS) = 0.0E+00 
      udco2(:,:,KS) = 0.0E+00
      udo3 (:,:,KS) = 0.0E+00
      do k=KS+1,KE+1
        ud   (:,:,k) = ud   (:,:,k-1) + du   (:,:,k-1)*ff   (:,:,k) 
        udco2(:,:,k) = udco2(:,:,k-1) + duco2(:,:,k-1)*ffco2(:,:,k)
        udo3 (:,:,k) = udo3 (:,:,k-1) + duo3 (:,:,k-1)*ffo3 (:,:,k) 
      end do
      uu   (:,:,KE+1) = ud   (:,:,KE+1) 
      uuco2(:,:,KE+1) = udco2(:,:,KE+1) 
      uuo3 (:,:,KE+1) = udo3 (:,:,KE+1)
      do k=KE,KS,-1
        uu   (:,:,k) = uu   (:,:,k+1) + du   (:,:,k)*diffac
        uuco2(:,:,k) = uuco2(:,:,k+1) + duco2(:,:,k)*diffac
        uuo3 (:,:,k) = uuo3 (:,:,k+1) + duo3 (:,:,k)*reflo3 
      end do

!-----------------------------------------------------------------------
!     for the skyhi model only, obtain the oxygen optical path, using
!     the o3 angular integration.
!-----------------------------------------------------------------------
      uo2(:,:,KS+1:ixprKO2) = pp(:,:,KS+1:ixprKO2)*    &
                              ffo3(:,:,KS+1:ixprKO2)

!-----------------------------------------------------------------------
!     calculate co2 absorptions.  they will be used in near infrared
!     bands.  since the absorption amount is given (in the formula used
!     below, derived from sasamori) in terms of the total solar flux,
!     and the absorption is only included in the near infrared 
!     (50 percent of the solar spectrum), the absorptions are multiplied
!     by two.
!-----------------------------------------------------------------------
      tdco2(:,:,KS:KE+1) =    &
!                     1.0E+00 - 2.0E+00*(2.35E-03* EXP(0.26E+00*ALOG( &
!                      (udco2(:,:,Ks   :Ke   +1) + &
!                     1.29E-02))) - 7.58265E-04)
                     1.0E+00 - 2.0E+00*(2.35E-03*(udco2(:,:,KS:KE+1) + &
                     1.29E-02)**2.6E-01 - 7.58265E-04)
      tuco2(:,:,KS:KE+1) =    &
!          1.0E+00 - 2.0E+00*(2.35E-03* EXP(0.26E+00*ALOG(  &
!                     (uuco2(:,:,Ks   :Ke   +1) +  &
!                     1.29E-02))) - 7.58265E-04)
                     1.0E+00 - 2.0E+00*(2.35E-03*(uuco2(:,:,KS:KE+1) + &
                     1.29E-02)**2.6E-01 - 7.58265E-04)

!-----------------------------------------------------------------------
!     now calculate ozone absorptions.  these will be used in the
!     visible band one.  just as in the co2 case, since this band is
!     50 percent of the solar spectrum, the absorptions are multiplied
!     by two.  see reference (1).
!-----------------------------------------------------------------------
       absdo3(:,:,KS:KE+1) =   &
!     &   2.0E+00*udo3(:,:,Ks :Ke   +1)*(1.082E+00*EXP(-.805E+00*ALOG( &
!     &    (1.0E+00 + 1.386E+02*udo3(:,:,Ks   :Ke   +1)))) + &
!     &    6.58E-02/(1.0E+00 + (1.036E+02)**3* &
!     &    udo3(:,:,Ks   :Ke   +1)**3) +  &
!     &    2.118E-02/(1.0E+00 + udo3(:,:,Ks   :Ke   +1)*(4.2E-02 + &
!     &    3.23E-04*   &
!     &    udo3(:,:,KS   :Ke   +1))))
          2.0E+00*udo3(:,:,KS:KE+1)*(1.082E+00*    &
          (1.0E+00 + 1.386E+02*udo3(:,:,KS:KE+1))**(-8.05E-01) +   &
          6.58E-02/(1.0E+00 + (1.036E+02)**3*udo3(:,:,KS:KE+1)**3) + &
          2.118E-02/(1.0E+00 + udo3(:,:,KS:KE+1)*(4.2E-02 + 3.23E-04* &
          udo3(:,:,KS:KE+1))))
       absuo3(:,:,KS:KE+1) =   &

!         2.0E+00*uuo3(:,:,Ks :Ke   +1)*(1.082E+00*EXP(-.805E+00*ALOG( &
!         (1.0E+00 + 1.386E+02*uuo3(:,:,Ks   :Ke   +1)))) +  &
!         6.58E-02/(1.0E+00 + (1.036E+02)**3*  &
!         uuo3(:,:,Ks   :Ke   +1)**3) +  &
!         2.118E-02/(1.0E+00 + uuo3(:,:,Ks   :Ke   +1)*(4.2E-02 + &
!         3.23E-04*   &
!         uuo3(:,:,Ks   :Ke   +1)))) 
          2.0E+00*uuo3(:,:,KS:KE+1)*(1.082E+00*  &
          (1.0E+00 + 1.386E+02*uuo3(:,:,KS:KE+1))**(-8.05E-01) + &
          6.58E-02/(1.0E+00 + (1.036E+02)**3*uuo3(:,:,KS:KE+1)**3) + &
          2.118E-02/(1.0E+00 + uuo3(:,:,KS:KE+1)*(4.2E-02 + 3.23E-04* &
          uuo3(:,:,KS:KE+1))))

!---------------------------------------------------------------------
!     calculate o2 absorptions (in visible band one).
!
!     formula is: abs=1.02E-05*uo2(k)**0.3795 for uo2 < 673.9057
!
!                 abs=4.51E-06*uo2(k)**0.5048 for uo2 > 673.9057
!
!     the absorption is constant below 35 km (level ixprKO2).
!---------------------------------------------------------------------
!   if (Environment%using_sky_periphs) then
    if (calculate_o2_absorption) then
      absdo2(:,:,KS) = 0.0E+00
      do ko=KS+1,ixprKO2
        do j=JSRAD,JERAD
          do i=ISRAD,IERAD
            if(uo2(i,j,ko) .LE. 6.739057E+02) then
!    absdo2(i,j,ko) = 1.02E-05*EXP(.3795E+00*ALOG(uo2(i,j,ko)))
               absdo2(i,j,ko) = 1.02E-05*uo2(i,j,ko)**0.3795E+00
            else
!    absdo2(i,j,ko) = 4.51E-06*EXP(.5048E+00*ALOG(uo2(i,j,ko)))
               absdo2(i,j,ko) = 4.51E-06*uo2(i,j,ko)**0.5048E+00
            endif
          end do
        end do
      end do

!-----------------------------------------------------------------------
!     add o2 absorption to o3 absorption.
!-----------------------------------------------------------------------
      do k=KS,KE+1
        if(k .LE. ixprKO2) then
          absdo3(:,:,k) = absdo3(:,:,k) + absdo2(:,:,k  )
        else
          absdo3(:,:,k) = absdo3(:,:,k) + absdo2(:,:,ixprKO2)
        endif
        absuo3(:,:,k) = absuo3(:,:,k) + absdo2(:,:,ixprKO2)
      end do
    endif

!-----------------------------------------------------------------------
!     computations for bands have been divided into: band one, band two,
!     and band three through NB.  begin by calculating flux entering
!     at the top for each band.
!-----------------------------------------------------------------------
      do nband=1,NB
        dfntop(:,:,nband) = ssolar*1.0E+03*cosangsolar(:,:,ngp)*   &
                                fracday(:,:)*pwts(nband)
      end do

!-----------------------------------------------------------------------
!     initialize dfsw and ufsw for the bands.
!-----------------------------------------------------------------------
      if (present(gwt)) then
        dfswg(:,:,KS:KE+1) = 0.0E+00
        ufswg(:,:,KS:KE+1) = 0.0E+00
      endif

!-----------------------------------------------------------------------
!     execute the reflectivity parameterization for the visible band 
!     one.  see reference (1)
!-----------------------------------------------------------------------
      rray(:,:) = 2.19E-01/(1.0E+00 + 8.16E-01*cosangsolar(:,:,ngp))
!! WHAT TO DO HERE ?
!!  USING ONLY DIR ALBEDOES IN THIS SCHEME - the totals will be assigned
!!  to _dir and the _dif fluxes will remain zero, pending a better
!! assignment ??     
      refl(:,:) = rray(:,:) + (1.0E+00 - rray(:,:))*(1.0E+00 -    &
!                 rrayav)*cvisrfgd(:,:)/(1.0E+00 - cvisrfgd(:,:  )* &
             rrayav)*cvisrfgd_dir(:,:)/(1.0E+00 - cvisrfgd_dir(:,:)* &
                  rrayav)

!-----------------------------------------------------------------------
!     where clouds exist.
!-----------------------------------------------------------------------
      if(kcldsw .NE. 0) then
!-----------------------------------------------------------------------
!     the first cloud is the ground; its properties are given by refl. 
!     the transmission ct(:,:,1) is irrelevant for now.
!-----------------------------------------------------------------------
        cr(:,:,1) = refl(:,:)
!-----------------------------------------------------------------------
!     obtain cloud reflection and transmission coefficients for
!     remaining clouds in the visible band one.  the maximum number of 
!     clouds kcldsw is used.  this creates extra work and may be removed
!     in a subsequent update.
!-----------------------------------------------------------------------
        cr(:,:,2:kcldsw+1) = cvisrfsw(:,:,1:kcldsw    )*   &
      camtsw(:,:,1:kcldsw)
        ct(:,:,2:kcldsw+1) = 1.0E+00 - cr(:,:,2:kcldsw+1)
      end if

!-----------------------------------------------------------------------
!     begin computations for visible band one, near infrared band two,
!     and near infrared bands three thru NB.
!-----------------------------------------------------------------------
      do nband=1,NB
!-----------------------------------------------------------------------
!     calculations for visible band one which includes o3, o2, and 
!     (negligible) h2o absorption.
!-----------------------------------------------------------------------
        if(nband .EQ. 1) then
          alogtt(:,:,KS:KE+1) = -abcff(1)*ud(:,:,KS:KE+1)
          ttdb1 (:,:,KS:KE+1) = EXP(MAX(alogmin, alogtt(:,:,KS:KE+1)))
          ttd   (:,:,KS:KE+1) = ttdb1 (:,:,KS:KE+1)*(1.0E+00 -   &
                                absdo3(:,:,KS:KE+1))
          alogtt(:,:,KS:KE+1) = -abcff(1)*uu(:,:,KS:KE+1)
          ttub1 (:,:,KS:KE+1) = EXP(MAX(alogmin, alogtt(:,:,KS:KE+1)))
          ttu   (:,:,KS:KE+1) = ttub1 (:,:,KS:KE+1)*(1.0E+00 -   &
                                absuo3(:,:,KS:KE+1))

!-----------------------------------------------------------------------
!     calculations for the near infrared band two where the water vapor
!     transmission function ttdb1 and ttub1 for band two is equal to
!     that of band one.
!-----------------------------------------------------------------------
else if(nband .EQ. 2) then
          alogtt(:,:,KS:KE+1) = -abcff(1)*ud(:,:,KS:KE+1)
          ttdb1 (:,:,KS:KE+1) = EXP(MAX(alogmin,alogtt(:,:,KS:KE+1)))
          ttd   (:,:,KS:KE+1) = ttdb1(:,:,KS:KE+1)*tdco2(:,:,KS:KE+1)
          alogtt(:,:,KS:KE+1) = -abcff(1)*uu(:,:,KS:KE+1)
          ttub1 (:,:,KS:KE+1) = EXP(MAX(alogmin,alogtt(:,:,KS:KE+1)))
          ttu   (:,:,KS:KE+1) = ttub1(:,:,KS:KE+1)*tuco2(:,:,KS:KE+1)

!-----------------------------------------------------------------------
!     calculate water vapor transmission functions for near infrared
!     bands.  include co2 transmission tdco2/tuco2, which is the
!     same for all infrared bands.
!-----------------------------------------------------------------------
else if(nband .GE. 3) then
          alogtt(:,:,KS:KE+1) = -abcff(nband)*ud(:,:,KS:KE+1)
          ttd   (:,:,KS:KE+1) = EXP(MAX(alogmin,alogtt(:,:,KS:KE+1)))* &
                                tdco2(:,:,KS:KE+1)
          alogtt(:,:,KS:KE+1) = -abcff(nband)*uu(:,:,KS:KE+1)
          ttu   (:,:,KS:KE+1) = EXP(MAX(alogmin,alogtt(:,:,KS:KE+1)))* &
                                tuco2(:,:,KS:KE+1)
        endif

!-----------------------------------------------------------------------
!     at this point, include ttd(KS), ttu(KE+1), noting that ttd(KS)=1 
!     for all bands, and that ttu(KE+1)=ttd(KE+1) for all bands.
!-----------------------------------------------------------------------
        ttd(:,:,KS  ) = 1.0E+00
        ttu(:,:,KE+1) = ttd(:,:,KE+1)
!-----------------------------------------------------------------------
!     where no clouds exist.
!-----------------------------------------------------------------------
        if (kcldsw .EQ. 0) then
          if(nband .EQ. 1) then
            do k=KS,KE+1
              ufn(:,:,k) = refl(:,:)*ttu(:,:,k)
              dfn(:,:,k) = ttd(:,:,k)
            end do
          else
            do k=KS,KE+1
!             ufn(:,:,k) = cirrfgd(:,:)*ttu(:,:,k)
!! WHAT TO DO HERE ?
!!  USING ONLY DIR ALBEDOES IN THIS SCHEME - the totals will be assigned
!!  to _dir and the _dif fluxes will remain zero, pending a better
!! assignment ??
              ufn(:,:,k) = cirrfgd_dir(:,:)*ttu(:,:,k)
              dfn(:,:,k) = ttd(:,:,k)
            end do      
          endif
!-----------------------------------------------------------------------
!     where clouds exist.
!-----------------------------------------------------------------------
        else
!-----------------------------------------------------------------------
!     for execution of the cloud loop, it is necessary to separate the
!     transmission functions at the top and bottom of the clouds, for
!     each band.  the required quantities are:
!
!       ttd(:,:,ktopsw(:,:,kc),nband) kc=1,ncldsw(:,:)+1 
!       ttd(:,:,kbtmsw(:,:,kc),nband) kc=1,ncldsw(:,:)+1 
!       ttu(:,:,ktopsw(:,:,kc),nband) kc=1,ncldsw(:,:)+1.
!
!     the above quantities are stored in tdcltop, tdclbtm, and tucltop 
!     respectively, as they have multiple use in the program.
!-----------------------------------------------------------------------
 
!-----------------------------------------------------------------------
!     for first cloud layer (i.e. the ground) tdcltop and tucltop are
!     known.
!-----------------------------------------------------------------------
          tdcltop (:,:,1) = ttd    (:,:,KE+1)
          tucltop (:,:,1) = ttu    (:,:,KE+1)
          tdclbtm (:,:,1) = tdcltop(:,:,1 )

!-----------------------------------------------------------------------
!     use gathers for remaining ones.
!-----------------------------------------------------------------------
              do kc=1,kcldsw
          do j=JSRAD,JERAD
            do i=ISRAD,IERAD
                tdcltop(i,j,kc+1) = ttd(i,j,ktopsw(i,j,kc))
                tucltop(i,j,kc+1) = ttu(i,j,ktopsw(i,j,kc))
                tdclbtm(i,j,kc+1) = ttd(i,j,kbtmsw(i,j,kc))
              end do
            end do
          end do
!-----------------------------------------------------------------------
!     compute the transmissivity from the top of cloud kc+1 to the top
!     of cloud kc.  the cloud transmission ct is included.  this
!     quantity is called tdclbt(kc)-transmission down cloud bottom-top.
!     also, obtain the transmissivity from the bottom of cloud kc+1
!     to the top of cloud kc (a path entirely outside clouds).  this
!     quantity is called tdcltt(kc)-transmission down cloud top-top.
!-----------------------------------------------------------------------
          tdclbt(:,:,1:kcldsw) = tdcltop(:,:,1:kcldsw)/  &
                              tdcltop(:,:,2:kcldsw+1)*ct(:,:,2:kcldsw+1)
          tdcltt(:,:,1:kcldsw) = tdcltop(:,:,1:kcldsw)/   &
                              tdclbtm(:,:,2:kcldsw+1)

!-----------------------------------------------------------------------
!     the following is the recursion relation for alfa. the reflection
!     coefficient for a system including the cloud in question and the
!     flux coming out of the cloud system including all clouds below
!     the cloud in question.
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!     alfau is alfa without the reflection of the cloud in question.
!----------------------------------------------------------------------!
          alfa (:,:,1) = cr(:,:,1)
          alfau(:,:,1) = 0.0E+00
          do kc=1,kcldsw
!-----------------------------------------------------------------------
!     excessive calculations.
!-----------------------------------------------------------------------
            alfau(:,:,kc+1) = (tdclbt(:,:,kc)**2)*alfa(:,:,kc)/ &
                            (1.0E+00 - (tdcltt(:,:,kc)**2)* &
                            alfa(:,:,kc)*cr(:,:,kc+1))
            alfa (:,:,kc+1) = alfau(:,:,kc+1) + cr(:,:,kc+1)
          end do
!-----------------------------------------------------------------------
!     the following calculation is done for visible band one case only.
!     obtain the pressure at the top, bottom and the thickness of thick 
!     clouds (those at least 2 layers thick).  this is used later is 
!     obtaining fluxes inside the thick clouds, for all frequency bands.
!-----------------------------------------------------------------------
          if(nband .EQ. 1) then
            do kc=1,kcldsw
              do j=JSRAD,JERAD
                do i=ISRAD,IERAD
                  if(ktopsw(i,j,kc  ) .NE. KS) then 
                  if((kbtmsw(i,j,kc  ) - ktopsw(i,j,kc  )) .GT. 1) then
                      pptop (i,j,kc) = pp(i,j,ktopsw(i,j,kc  )) 
                      dpcldi(i,j,kc) = 1.0E+00/(pptop(i,j,kc) -  &
                                       pp(i,j,kbtmsw(i,j,kc  )))
                    endif
                  endif
                end do
              end do
            end do
!! define this as zero -- could at some point be an input ??
            cirabgd(:,:) = 0.0
!! WHAT TO DO HERE ?
!!  USING ONLY DIR ALBEDOES IN THIS SCHEME - the totals will be assigned
!!  to _dir and the _dif fluxes will remain zero, pending a better
!! assignment ??
!           cr(:,:,1) = cirrfgd(:,:)
!           ct(:,:,1) = 1.0E+00 - (cirrfgd(:,:) + cirabgd(:,:))
            cr(:,:,1) = cirrfgd_dir(:,:)
            ct(:,:,1) = 1.0E+00 - (cirrfgd_dir(:,:) + cirabgd(:,:))
            cr(:,:,2:kcldsw+1) = cirrfsw(:,:,1:kcldsw    )*  &
                                 camtsw(:,:,1:kcldsw)
            ct(:,:,2:kcldsw+1) = 1.0E+00 - camtsw(:,:,1:kcldsw  )*  &
                                 (cirrfsw(:,:,1:kcldsw      ) +    &
                                  cirabsw(:,:,1:kcldsw      ))
          endif

!-----------------------------------------------------------------------
!     calculate ufn at cloud tops and dfn at cloud bottoms note that 
!     ufncltop(:,:,kcldsw+1) gives the upward flux at the top of the 
!     highest real cloud (if ncldsw(:,:)=kcldsw).  it gives the flux at 
!     the top of the atmosphere if ncldsw(:,:) < kcldsw.  it the first 
!     case, tdcltop equals the transmission function to the top of the 
!     highest cloud, as we want.  in the second case, tdcltop=1, so
!     ufncltop equals alfa. this is also correct.
!-----------------------------------------------------------------------
          ufncltop(:,:,kcldsw+1) = alfa(:,:,kcldsw+1)*   &
                                   tdcltop(:,:,kcldsw+1)
          dfncltop(:,:,kcldsw+1) = tdcltop(:,:,kcldsw+1)
!-----------------------------------------------------------------------
!     this calculation is the reverse of the recursion relation used
!     above.
!-----------------------------------------------------------------------
          do kc=kcldsw,1,-1
            ufncltop(:,:,kc) = ((ufncltop(:,:,kc+1)*alfau(:,:,kc+1))/ &
                               alfa(:,:,kc+1))/tdclbt(:,:,kc)
            dfncltop(:,:,kc) = ufncltop(:,:,kc)/alfa (:,:,kc)
          end do

!-----------------------------------------------------------------------
!     now obtain dfn and ufn for levels between the clouds.
!-----------------------------------------------------------------------
          ufnlbc(:,:,1:kcldsw+1) = ufncltop(:,:,1:kcldsw+1)/  &
                                   tucltop (:,:,1:kcldsw+1)
          dfnlbc(:,:,1:kcldsw+1) = dfncltop(:,:,1:kcldsw+1)/  &
                                   tdcltop (:,:,1:kcldsw+1)
!-----------------------------------------------------------------------
!     case of kc=1 (from the ground to the bottom of the lowest cloud).
!-----------------------------------------------------------------------
          do j=JSRAD,JERAD
            do i=ISRAD,IERAD
              do k=kbtmsw(i,j,1),KE+1
                ufn(i,j,k) = ufnlbc(i,j,1)*ttu(i,j,k)
                dfn(i,j,k) = dfnlbc(i,j,1)*ttd(i,j,k)
              end do
            end do
          end do
!-----------------------------------------------------------------------
!     remaining levels.
!-----------------------------------------------------------------------
            do j=JSRAD,JERAD
              do i=ISRAD,IERAD
do kc=1,ncldsw(i,j)
                  do k=kbtmsw(i,j,kc+1),ktopsw(i,j,kc  )
                    ufn(i,j,k) = ufnlbc(i,j,kc+1)*ttu(i,j,k) 
                    dfn(i,j,k) = dfnlbc(i,j,kc+1)*ttd(i,j,k)
                  end do
!-----------------------------------------------------------------------
!     for the thick clouds, the flux divergence through the cloud layer
!     is assumed to be constant.  the flux derivative is given by
!     tempu (for the upward flux) and tempd (for the downward flux).
!-----------------------------------------------------------------------
                  if((kbtmsw(i,j,kc  ) - ktopsw(i,j,kc  )) .GT. 1) then
               tempu=(ufncltop(i,j,kc+1) - ufn(i,j,kbtmsw(i,j,kc  )))*&
                           dpcldi(i,j,kc  )
                tempd=(dfncltop(i,j,kc+1) - dfn(i,j,kbtmsw(i,j,kc  )))*&
                           dpcldi(i,j,kc  )
                    do k=ktopsw(i,j,kc  )+1,kbtmsw(i,j,kc  )-1
                      ufn(i,j,k) = ufncltop(i,j,kc+1) +   &
                                   tempu*(pp(i,j,k) - pptop(i,j,kc  ))
                      dfn(i,j,k) = dfncltop(i,j,kc+1) +   &
                                   tempd*(pp(i,j,k) - pptop(i,j,kc  ))
                    end do
                  endif
              end do
            end do
          end do
        endif  ! (end of kcldsw loop)

!-----------------------------------------------------------------------
!     scale the previously computed fluxes by the flux at the top of the
!     atmosphere.
!-----------------------------------------------------------------------
        do k=KS,KE+1
          dfn(:,:,k) = dfn(:,:,k)*dfntop(:,:,nband)
          ufn(:,:,k) = ufn(:,:,k)*dfntop(:,:,nband)
        end do

!-----------------------------------------------------------------------
!     sum over bands.
!-----------------------------------------------------------------------
        if (present(gwt)) then
          dfswg(:,:,KS:KE+1) = dfswg(:,:,KS:KE+1) + dfn(:,:,KS:KE+1)
          ufswg(:,:,KS:KE+1) = ufswg(:,:,KS:KE+1) + ufn(:,:,KS:KE+1)
        else
           if (with_clouds) then
          Sw_output%dfsw (:,:,KS:KE+1,1) = Sw_output%dfsw (:,:,KS:KE+1,1) + dfn(:,:,KS:KE+1)
          Sw_output%ufsw (:,:,KS:KE+1,1) = Sw_output%ufsw (:,:,KS:KE+1,1) + ufn(:,:,KS:KE+1)
  else
          Sw_output%dfswcf (:,:,KS:KE+1,1) = Sw_output%dfswcf (:,:,KS:KE+1,1) + dfn(:,:,KS:KE+1)
          Sw_output%ufswcf (:,:,KS:KE+1,1) = Sw_output%ufswcf (:,:,KS:KE+1,1) + ufn(:,:,KS:KE+1)
  endif
        endif
      end do

!-----------------------------------------------------------------------
!     obtain the net flux and the shortwave heating rate for all bands.
!-----------------------------------------------------------------------
      if (present(gwt)) then
        fswg(:,:,KS:KE+1) = ufswg(:,:,KS:KE+1) - dfswg(:,:,KS:KE+1)
        hswg(:,:,KS:KE  ) = radcon*(fswg(:,:,KS+1:KE+1) -    &
      fswg(:,:,KS:KE))/dp(:,:,KS:KE)
      else
if (with_clouds) then
        Sw_output%fsw (:,:,KS:KE+1,1) = Sw_output%ufsw (:,:,KS:KE+1,1) - &
                  Sw_output%dfsw (:,:,KS:KE+1,1)
        Sw_output%hsw (:,:,KS:KE,1  ) = radcon*   &
         (Sw_output%fsw (:,:,KS+1:KE+1,1) -    &
      Sw_output%fsw (:,:,KS:KE,1))/dp(:,:,KS:KE)
else
        Sw_output%fswcf (:,:,KS:KE+1,1) = Sw_output%ufswcf (:,:,KS:KE+1,1) -   &
              Sw_output%dfswcf (:,:,KS:KE+1,1)
        Sw_output%hswcf (:,:,KS:KE,1  ) = radcon*  &
 (Sw_output%fswcf (:,:,KS+1:KE+1,1) -    &
     Sw_output% fswcf (:,:,KS:KE,1))/dp(:,:,KS:KE)
      endif

      endif
    end do ! (ngp loop)

!--------------------------------------------------------------------
!   deallocate local arrays
!-------------------------------------------------------------------
      if (present(gwt)) then
        deallocate (ufswg      )
        deallocate (hswg       )
        deallocate (fswg       )
        deallocate (dfswg      )
      endif
      deallocate ( absdo3    )
      deallocate ( absuo3    )
      deallocate ( alfa      )
      deallocate ( alfau     )
      deallocate ( alogtt    )
      deallocate ( cr        )
      deallocate ( ct        )
      deallocate ( dfn       )
      deallocate ( dfncltop  )
      deallocate ( dfnlbc    )
      deallocate ( dfntop    )
      deallocate ( dp        )
      deallocate ( dpcldi    )
      deallocate ( du        )
      deallocate ( duco2     )
      deallocate ( duo3      )
      deallocate ( ff        )
      deallocate ( ffco2     )
      deallocate ( ffo3      )
      deallocate ( pp        )
      deallocate ( pptop     )
      deallocate ( pr2       )
      deallocate ( refl      )
      deallocate ( rray      )
      deallocate ( seczen    )
      deallocate ( tdcltt    )
      deallocate ( tdclbt    )
      deallocate ( tdcltop   )
      deallocate ( tdclbtm   )
      deallocate ( tdco2     )
      deallocate ( ttd       )
      deallocate ( ttdb1     )
      deallocate ( ttu       )
      deallocate ( ttub1     )
      deallocate ( tucltop   )
      deallocate ( tuco2     )
      deallocate ( ud        )
      deallocate ( udco2     )
      deallocate ( udo3      )
      deallocate ( ufn       )
      deallocate ( ufncltop  )
      deallocate ( ufnlbc    )
      deallocate ( uu        )
      deallocate ( uuco2     )
      deallocate ( uuo3      )
      deallocate ( absdo2    )
      deallocate ( uo2       )
  
      if (kcldsw /= 0) then
        deallocate ( camtsw )
        deallocate ( cirabsw    )
        deallocate ( cirrfsw    )
        deallocate ( cvisrfsw     )
        deallocate ( ktopsw )
        deallocate ( kbtmsw )
      endif

      deallocate ( ncldsw )

!--------------------------------------------------------------------
!   convert sw fluxes to mks units.
!---------------------------------------------------------------------
      if (with_clouds) then
      Sw_output%fsw(:,:,:,:) = 1.0E-03*Sw_output%fsw(:,:,:,:)
      Sw_output%dfsw(:,:,:,:) = 1.0E-03*Sw_output%dfsw(:,:,:,:)
      Sw_output%ufsw(:,:,:,:) = 1.0E-03*Sw_output%ufsw(:,:,:,:)
      else
        Sw_output%fswcf(:,:,:,:) = 1.0E-03*Sw_output%fswcf(:,:,:,:)
       Sw_output%dfswcf(:,:,:,:) = 1.0E-03*Sw_output%dfswcf(:,:,:,:)
      Sw_output%ufswcf(:,:,:,:) = 1.0E-03*Sw_output%ufswcf(:,:,:,:)
     endif
!-------------------------------------------------------------------

      end subroutine swrad 



!##################################################################
!####################################################################

! <SUBROUTINE NAME="convert_to_cloud_space">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call convert_to_cloud_space (is, ie, js, je,  Cldrad_props, &
!                Cld_spec,  &
!                cirabswkc, cirrfswkc,  &
!                cvisrfswkc, ktopswkc, kbtmswkc,  &
!                camtswkc, Cldspace_rad)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
! 
!  </IN>
!  <OUT NAME="cirabswkc" TYPE="real">
! 
!  </OUT>
!  <OUT NAME="cirrfswkc" TYPE="real">
! 
!  </OUT>
!  <OUT NAME="cvisrfswkc" TYPE="real">
! 
!  </OUT>
!  <OUT NAME="ktopswkc" TYPE="integer">
! 
!  </OUT>
!  <OUT NAME="kbtmswkc" TYPE="integer">
! 
!  </OUT>
!  <OUT NAME="camtswkc" TYPE="real">
! 
!  </OUT>
!  <INOUT NAME="Cldspace_rad" TYPE="cld_space_properties_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine convert_to_cloud_space (is, ie, js, je,  Cldrad_props, &
                               Cld_spec,  &
                               cirabswkc, cirrfswkc,  &
cvisrfswkc, ktopswkc, kbtmswkc,  &
camtswkc, Cldspace_rad)
      
integer, intent(in) :: is, ie, js, je
type(cldrad_properties_type), intent(in) :: Cldrad_props
type(cld_specification_type), intent(in) :: Cld_spec       
real, dimension(:,:,:),   intent(out) :: camtswkc
real, dimension(:,:,:  ), intent(out) :: cirabswkc, cirrfswkc,  &
 cvisrfswkc
integer, dimension(:,:,:),intent(out) :: ktopswkc, kbtmswkc
type(cld_space_properties_type), intent(inout) :: Cldspace_rad
!-------------------------------------------------------------------


      integer :: i,j,k, index_kbot, index_ktop
      integer :: kcldsmx
      integer :: ix, jx, kx

       ix = size(Cld_spec%camtsw,1)
       jx = size(Cld_spec%camtsw,2)
       kx = size(Cld_spec%camtsw,3)

!---------------------------------------------------------------------
!     obtain arrays for shortwave cloud properties in "cloud space".
!     "bottom up" counting is used in conformity with the lhsw
!     radiative algorithm. (ie, index = 1 = lowest cloud (if any), etc.)
!---------------------------------------------------------------------
      
      kcldsmx = MAXVAL(Cld_spec%ncldsw)
      if (kcldsmx /= 0.0) then
      camtswkc(:,:,:) = 0.0E+00
      cirabswkc(:,:,:  ) = 0.0E+00
      cirrfswkc(:,:,:  ) = 0.0E+00
      cvisrfswkc(:,:,:) = 0.0E+00
      ktopswkc(:,:,:) = 1        
      kbtmswkc(:,:,:) = 1        

      do j=1,jx         
        do i=1,ix         
 index_kbot = 0
  index_ktop = 0
!---------------------------------------------------------------------
!     in the kx   'th layer, the presence of cloud (camtsw) implies a
!     shortwave cloud bottom at level (kx   +1) but nothing about
!     cloud tops.
!---------------------------------------------------------------------
          if (Cld_spec%camtsw(i,j,kx   ) .GT. 0.0E+00) then
            index_kbot = index_kbot + 1
    kbtmswkc(i,j,index_kbot) = kx   +1
    camtswkc(i,j,index_kbot) = Cld_spec%camtsw(i,j,kx   )
      cirabswkc(i,j,index_kbot    ) = Cldrad_props%cirabsw(i,j,kx )
              cirrfswkc(i,j,index_kbot    ) = Cldrad_props%cirrfsw(i,j,kx )
      cvisrfswkc(i,j,index_kbot    ) = Cldrad_props%cvisrfsw(i,j,kx )
          endif
!---------------------------------------------------------------------
!   in other layers, cloud bottoms and tops are determined according
!   to changes in shortwave cloud (and special case).
!---------------------------------------------------------------------
          do k=kx-1,1    ,-1
!---------------------------------------------------------------------
!     cloud bottoms.
!--------------------------------------------------------------------
    if (Cld_spec%camtsw(i,j,k) .NE. Cld_spec%camtsw(i,j,k+1) .AND.    &
      Cld_spec%camtsw(i,j,k) .GT. 0.0E+00              .OR.  &
!---------------------------------------------------------------------
!     special case where shortwave cloud amounts for adjacent
!     layers are equal, but a randomly overlapped cloud exists
!     in at least one of these layers
!---------------------------------------------------------------------
                Cld_spec%camtsw(i,j,k) .EQ. Cld_spec%camtsw(i,j,k+1) .AND.   &
               (Cld_spec%crndlw(i,j,k) .NE. 0.0E+00 .OR.      &
                Cld_spec%crndlw(i,j,k+1) .NE. 0.0E+00)                ) then
              index_kbot = index_kbot + 1
      kbtmswkc(i,j,index_kbot) = k+1
      camtswkc(i,j,index_kbot) = Cld_spec%camtsw(i,j,k)
      cirabswkc(i,j,index_kbot    ) = Cldrad_props%cirabsw(i,j,k)
      cirrfswkc(i,j,index_kbot    ) = Cldrad_props%cirrfsw(i,j,k)
      cvisrfswkc(i,j,index_kbot    ) = Cldrad_props%cvisrfsw(i,j,k)
            endif
!---------------------------------------------------------------------
!     cloud tops.
!---------------------------------------------------------------------
            if (Cld_spec%camtsw(i,j,k) .NE. Cld_spec%camtsw(i,j,k+1) .AND.      &
                Cld_spec%camtsw(i,j,k+1) .GT. 0.0E+00            .OR.  &
!---------------------------------------------------------------------
!     special case where shortwave cloud amounts for adjacent
!     layers are equal, but a randomly overlapped cloud exists
!     in at least one of these layers
!---------------------------------------------------------------------
                Cld_spec%camtsw(i,j,k) .EQ. Cld_spec%camtsw(i,j,k+1) .AND.    &
               (Cld_spec%crndlw(i,j,k) .NE. 0.0E+00 .OR.        &
                Cld_spec%crndlw(i,j,k+1) .NE. 0.0E+00)                ) then
      index_ktop = index_ktop + 1
      ktopswkc(i,j,index_ktop) = k+1
            endif
          enddo
        enddo
      enddo


!---------------------------------------------------------------------
      allocate ( Cldspace_rad%camtswkc(ie-is+1, je-js+1,  &
                                 size(camtswkc,3) ) )
      allocate ( Cldspace_rad%cirabswkc(ie-is+1, je-js+1,  &
                                 size(camtswkc,3)   ) )
      allocate ( Cldspace_rad%cirrfswkc(ie-is+1, je-js+1,  &
                                 size(camtswkc,3)   ) )
      allocate ( Cldspace_rad%cvisrfswkc(ie-is+1, je-js+1,  &
                                 size(camtswkc,3)   ) )
      allocate ( Cldspace_rad%ktopswkc(ie-is+1, je-js+1,  &
                                 size(camtswkc,3) ) )
      allocate ( Cldspace_rad%kbtmswkc(ie-is+1, je-js+1,  &
                                 size(camtswkc,3)+1 ) )
      Cldspace_rad%camtswkc = camtswkc
      Cldspace_rad%cirabswkc = cirabswkc
      Cldspace_rad%cirrfswkc = cirrfswkc
      Cldspace_rad%cvisrfswkc = cvisrfswkc
      Cldspace_rad%ktopswkc = ktopswkc
      Cldspace_rad%kbtmswkc = kbtmswkc
      else
      endif



end subroutine convert_to_cloud_space



!####################################################################


             end module lhsw_driver_mod



                     module longwave_clouds_mod
 
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  This code calculates longwave cloud radiative parameters, i.e.
!  cloud optical depth, flux, and heating rate.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!

!   shared modules:

use mpp_mod,           only: input_nml_file
use fms_mod,           only: open_namelist_file, fms_init, &
                             mpp_pe, mpp_root_pe, stdlog, &
                             file_exist, write_version_number, &
                             check_nml_error, error_mesg, &
                             FATAL, close_file
use constants_mod,     only: constants_init, radcon

!  shared radiation package modules:

use rad_utilities_mod, only: rad_utilities_init, lw_output_type, &
                             Cldrad_control, lw_clouds_type, &
                             cld_specification_type,  & 
                             cldrad_properties_type

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    longwave_clouds_mod determines lw cloud transmission for each
!    longwave cloud band.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: longwave_clouds.F90,v 17.0.4.1 2010/08/30 20:33:31 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!----- interfaces  -----
           
public       &
            longwave_clouds_init, &
            cldtau,  cloud,  thickcld, &
            lw_clouds_dealloc,  &
            longwave_clouds_end


!---------------------------------------------------------------------
!---- namelist   -----

logical    :: dummy         = .false.


namelist / longwave_clouds_nml /   &
                                     dummy

!----------------------------------------------------------------------
!--- public data ---------


!----------------------------------------------------------------------
!---   private ---------

integer  :: NLWCLDB
logical  :: module_is_initialized = .false.    ! module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
!
! <SUBROUTINE NAME="longwave_clouds_init">
!  <OVERVIEW>
!   The constructor method of longwave_clouds module.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This method does the initialization of longwave cloud module. It
!   reads the longwave clouds namelist from input namelist file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_clouds_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_clouds_init

!--------------------------------------------------------------------
!    longwave_clouds_init is the constructor for longwave_clouds_mod.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer               :: unit, ierr, io, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=longwave_clouds_nml, iostat=io)
      ierr = check_nml_error(io,'longwave_clouds_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=longwave_clouds_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'longwave_clouds_nml')
        end do
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=longwave_clouds_nml)

!--------------------------------------------------------------------
!    mark the module as initialized.
!--------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------


end subroutine longwave_clouds_init



!####################################################################
! <SUBROUTINE NAME="cldtau">
!  <OVERVIEW>
!   Subroutine to calculate cloud optical depth
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine calculates cloud transmission function from cloud
!   emissivity.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cldtau(Cldrad_props, Cld_spec, Lw_clouds)
!  </TEMPLATE>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification input data to cloud optical depth calculation
!  </IN>
!  <INOUT NAME="Lw_clouds" TYPE="Lw_clouds">
!   cloud longwave parameters
!  </INOUT>
! </SUBROUTINE>
!
subroutine cldtau (nprofile, Cldrad_props, Cld_spec, Lw_clouds)
 
!--------------------------------------------------------------------
!    cldtau claculates the cloud transmission function for max overlap
!    and weighted random overlap clouds in each of the lw cloud
!    parameterization bands.  
!--------------------------------------------------------------------

integer,                      intent(in)    :: nprofile
type(cldrad_properties_type), intent(in)    :: Cldrad_props
type(cld_specification_type), intent(in)    :: Cld_spec       
type(lw_clouds_type),         intent(inout) :: Lw_clouds

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     Cldrad_props
!     Cld_spec
!
!   intent(inout) variables:
!
!     Lw_clouds
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      integer  :: is, ie, js, je, ks, ke
      integer   :: n, k, i, j
      integer   :: emiss_index, profile_index

!---------------------------------------------------------------------
!  local variables:
!
!      is,ie,js,je,ks,ke
!      i,j,k,n
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_clouds_mod',   &
               'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      is = 1
      ie = size(Cld_spec%cmxolw, 1)
      js = 1
      je = size(Cld_spec%cmxolw, 2)
      ks = 1
      ke = size(Cld_spec%cmxolw, 3)
      NLWCLDB = Cldrad_control%NLWCLDB

!--------------------------------------------------------------------
!    allocate the components of the lw_clouds derived type variable.
!--------------------------------------------------------------------
      allocate (Lw_clouds%taucld_rndlw (IS:IE, JS:JE,KS:KE, NLWCLDB) )
      allocate (Lw_clouds%taunbl_mxolw (IS:IE, JS:JE,KS:KE, NLWCLDB) )
      allocate (Lw_clouds%taucld_mxolw (IS:IE, JS:JE,KS:KE, NLWCLDB) )

!----------------------------------------------------------------------
!    define max overlap layer transmission function over layers KS,KE
!----------------------------------------------------------------------
      do n = 1,NLWCLDB
        do k = KS,KE
          Lw_clouds%taucld_mxolw(:,:,k,n) = 1.0E+00 -    &
                                Cldrad_props%emmxolw(:,:,k,n, nprofile)
        end do
      end do
 
!----------------------------------------------------------------------
!    define "weighted random cloud" layer transmission function
!    over layers KS,KE
!----------------------------------------------------------------------
      if (Cldrad_control%do_stochastic_clouds) then
        do n = 1,NLWCLDB
          if (Cldrad_control%do_ica_calcs) then
            profile_index = nprofile
            emiss_index = nprofile
          else
            profile_index = n
            emiss_index = 1
          endif
          do k = KS,KE
            do j = JS,JE
              do i = IS,IE
                if (Cld_spec%crndlw_band(i,j,k,profile_index) >   &
                                                          0.0E+00) then
                  Lw_clouds%taucld_rndlw(i,j,k,n) =   &
                        (Cld_spec%crndlw_band(i,j,k,profile_index)/ &
                        (1.0E+00 - Cld_spec%cmxolw(i,j,k)))*  &
                        (1.0E+00 -   &
                          Cldrad_props%emrndlw(i,j,k,n,emiss_index)) + &
                        1.0E+00 -    &
                          Cld_spec%crndlw_band(i,j,k,profile_index)/   &
                           (1.0E+00 - Cld_spec%cmxolw(i,j,k))
                else
                  Lw_clouds%taucld_rndlw(i,j,k,n) = 1.0E+00
                endif
              end do
            end do
          end do
        end do
      else
        do n = 1,NLWCLDB
          do k = KS,KE
            do j = JS,JE
              do i = IS,IE
                if (Cld_spec%crndlw(i,j,k) > 0.0E+00) then
                  Lw_clouds%taucld_rndlw(i,j,k,n) =   &
                         (Cld_spec%crndlw(i,j,k)/(1.0E+00 - &
                          Cld_spec%cmxolw(i,j,k)))*  &
                    (1.0E+00 - Cldrad_props%emrndlw(i,j,k,n,1)) + &
                         1.0E+00 - Cld_spec%crndlw(i,j,k)/   &
                         (1.0E+00 - Cld_spec%cmxolw(i,j,k))
                else
                  Lw_clouds%taucld_rndlw(i,j,k,n) = 1.0E+00
                endif
              end do
            end do
          end do
        end do
      endif
 
!--------------------------------------------------------------------
!    define "nearby layer" cloud transmission function for max
!    overlapped clouds (if emissivity not equal to one)
!--------------------------------------------------------------------
      do n = 1,NLWCLDB
        do k=KS,KE
          Lw_clouds%taunbl_mxolw(:,:,k,n) = 0.0E+00
        end do
      end do
 
!------------------------------------------------------------------

  
end subroutine cldtau



!######################################################################
! <SUBROUTINE NAME="cloud">
!  <OVERVIEW>
!   Subroutine to calculate cloud transmission function
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine calculates cloud transmission functions above certain
!   level.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloud (kl, Cldrad_props, Cld_spec, Lw_clouds, cldtf)
!  </TEMPLATE>
!  <IN NAME="kl" TYPE="integer">
!   the vertical level above which cloud transmission functions are desired.
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification input data to cloud optical depth calculation
!  </IN>
!  <IN NAME="Lw_clouds" TYPE="lw_clouds_type">
!   cloud longwave radiative properties
!  </IN>
!  <OUT NAME="cldtf" TYPE="real">
!   cloud transmission functions
!  </OUT>
! </SUBROUTINE>
!
subroutine cloud (kl, Cldrad_props, Cld_spec,  Lw_clouds, cldtf)

!---------------------------------------------------------------------
!    
!---------------------------------------------------------------------

integer,                      intent(in)  :: kl
type(cldrad_properties_type), intent(in)  :: Cldrad_props
type(cld_specification_type), intent(in)  :: Cld_spec
type(lw_clouds_type),         intent(in)  :: Lw_clouds
real, dimension(:,:,:,:),     intent(out) :: cldtf        

!--------------------------------------------------------------------
!  intent(in) variables;
!
!     kl
!     Cldrad_props
!     Cld_spec 
!     Lw_clouds
!
!  intent(out) variables:
!
!     cldtf
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (size(Cld_spec%cmxolw,1), &
                       size(Cld_spec%cmxolw,2), & 
                       size(Cld_spec%cmxolw,3) + 1) ::   &
                                                       cldtfmo, cldtfrd

      integer   :: is, ie, js, je, ks, ke
      integer   :: i, j, kp, n

!---------------------------------------------------------------------
!   local variables:
!
!       cldtfmo
!       cldtfrd
!       is,ie,js,je,ks,ke
!       i,j,kp,n
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_clouds_mod',   &
               'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
! 
!---------------------------------------------------------------------
      is = 1
      ie = size (Cld_spec%cmxolw, 1)
      js = 1
      je = size(Cld_spec%cmxolw,2)
      ks = 1
      ke = size(Cld_spec%cmxolw, 3)

!---------------------------------------------------------------------
!    the definition of "within a max overlapped cloud" is:
!    at pressure level k (separating layers k and (k-1)), the max
!    overlap cloud amounts for layers k and (k-1) must be 1) nonzero
!    (else no such cloud) and 2) equal (else one such cloud ends at
!    level k and another begins). Another way to define this is: if
!    considering the transmission across layer kp (between levels
!    kp and (kp+1)) the max overlap cloud amounts for layers kp and
!    (kp-1) must be nonzero and equal.
!---------------------------------------------------------------------
      do n = 1,NLWCLDB

!--------------------------------------------------------------------
!   cloud "nearby layer" transmission functions
!--------------------------------------------------------------------
        cldtfmo(:,:,kl) = 0.0
        cldtfrd(:,:,kl) = 1.0

!--------------------------------------------------------------------
!   if level kl is within a maximum overlapped cloud, the cloud
!   "nearby layer" transmission function may be non-unity. Exception:
!   at levels KS,KE+1  the function must be unity.
!--------------------------------------------------------------------
        if (kl > KS .AND. kl < KE+1) then
          do j=JS,JE
            do i=IS,IE
              if (Cld_spec%cmxolw(i,j,kl-1) /= 0.0 .and.     &
                  Cld_spec%cmxolw(i,j,kl) ==   &
                  Cld_spec%cmxolw(i,j,kl-1)) then
                cldtfmo(i,j,kl) = Cld_spec%cmxolw(i,j,kl)*  &
                                  Lw_clouds%taunbl_mxolw(i,j,kl,n)
                cldtfrd(i,j,kl) = 1.0 - Cld_spec%cmxolw(i,j,kl)
              endif
            enddo
          enddo
        endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
        cldtf(:,:,kl,n) = cldtfmo(:,:,kl) + cldtfrd(:,:,kl)

!--------------------------------------------------------------------
!     cloud transmission functions between level kl and higher
!     levels ( when kl le KE+1)
!--------------------------------------------------------------------
        if (kl .LT. KE+1) then
          cldtfmo(:,:,kl) = 0.0
          cldtfrd(:,:,kl) = 1.0

!--------------------------------------------------------------------
!    for first layer below  level kl, assume flux at level kl
!   is unity and is apportioned between (cmxolw) max. overlap cld,
!   (crndlw) rnd overlap cld, and remainder as clear sky.
!--------------------------------------------------------------------
          cldtfmo(:,:,kl+1) = Cld_spec%cmxolw(:,:,kl)*   &
                              Lw_clouds%taucld_mxolw(:,:,kl,n)
          cldtfrd(:,:,kl+1) = (1.0 - Cld_spec%cmxolw(:,:,kl))*  &
                               Lw_clouds%taucld_rndlw(:,:,kl,n)
          cldtf(:,:,kl+1,n) = cldtfmo(:,:,kl+1) + cldtfrd(:,:,kl+1)

!--------------------------------------------------------------------
!    if layers above and below level (kp-1) have no max overlap cloud,
!    or their amounts differ (ie, either top of new max overlap cld or
!    no max overlap cld at all), then apportion total "flux" (or,
!    cloud tf (cldtf)) between any max overlap cloud in layer(kp-1),
!    any rnd overlap cloud and clear sky.
!--------------------------------------------------------------------
          do kp = kl+2, KE+1
            do j=JS,JE
              do i=IS,IE
                if (Cld_spec%cmxolw(i,j,kp-2) .eq. 0. .or.    &
                    Cld_spec%cmxolw(i,j,kp-2) .ne.    &
                    Cld_spec%cmxolw(i,j,kp-1)) then
                  cldtfmo(i,j,kp) = cldtf(i,j,kp-1,n)*   &
                                    Cld_spec%cmxolw(i,j,kp-1)* &
                                    Lw_clouds%taucld_mxolw(i,j,kp-1,n)
                  cldtfrd(i,j,kp) = cldtf(i,j,kp-1,n)*   &
                                    (1.0 - Cld_spec%cmxolw(i,j,kp-1))*&
                                    Lw_clouds%taucld_rndlw(i,j,kp-1,n)
                  cldtf(i,j,kp,n) = cldtfmo(i,j,kp) + cldtfrd(i,j,kp)

!--------------------------------------------------------------------
!    if layer above level (kp-1) has a max overlap cloud, and layer
!    layer below level (kp-1) also does (ie, within max overlap cld)
!    obtain separate cloud tfs for max overlap cloud and for 
!    remainder (which may contain a random overlap cloud).
!--------------------------------------------------------------------
                else 
                  cldtfmo(i,j,kp) = cldtfmo(i,j,kp-1)*   &
                                    Lw_clouds%taucld_mxolw(i,j,kp-1,n)
                  cldtfrd(i,j,kp) = cldtfrd(i,j,kp-1)*   &
                                    Lw_clouds%taucld_rndlw(i,j,kp-1,n)
                  cldtf(i,j,kp,n) = cldtfmo(i,j,kp) + cldtfrd(i,j,kp)
                endif
              end do
            end do
          end do
        endif
      end do

!---------------------------------------------------------------------


end subroutine cloud



!####################################################################

! <SUBROUTINE NAME="thickcld">
!  <OVERVIEW>
!   Subroutine to calculate longwave cloud flux
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine calculates longwave cloud flux at model pressure
!   levels and heating rate.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call thickcld (pflux_in, Cldrad_props, Cld_spec, Lw_output)
!  </TEMPLATE>
!  <IN NAME="pflux_in" TYPE="real">
!   pressure at flux levels of model
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cloud radiative properties
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cloud specification input data to cloud optical depth calculation
!  </IN>
!  <INOUT NAME="Lw_output" TYPE="lw_output_type">
!   cloud longwave radiative flux
!  </INOUT>
! </SUBROUTINE>
!
subroutine thickcld (pflux_in, Cldrad_props, Cld_spec, Lw_output)

!------------------------------------------------------------------
!    thickcld recomputes cloud fluxes in "thick" clouds assuming
!    that df/dp is constant. the effect is to reduce top-of-cloud
!    cooling rates, thus performing a "pseudo-convective adjustment"
!    by heating (in a relative sense) the cloud top.
!    NOTE: this subroutine cannot handle a frequency-dependent 
!    emissivity. therefore, it assumes that emissivity quantities 
!    (emmxolw) are from frequency band 1 (normally unity).
!---------------------------------------------------------------------

real,   dimension (:,:,:),    intent(in)    ::  pflux_in
type(cldrad_properties_type), intent(in)    :: Cldrad_props
type(cld_specification_type), intent(in)    :: Cld_spec      
type(lw_output_type),         intent(inout) :: Lw_output      

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     pflux   =  pressure at flux levels of model.
!     Cldrad_props
!     Cld_spec
!
!  intent(inout) variables:
!
!     Lw_output
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
 
      real, dimension (size(pflux_in,1),   &
                       size(pflux_in,2))  :: &
                                        delptc, fbtm, ftop, pbtm, ptop

      integer, dimension (size(pflux_in,1),   &
                          size(pflux_in,2))  :: &
                                               itopmxo, ibtmmxo

      integer, dimension (size(pflux_in,1),    &
                          size(pflux_in,2),  &
                          size(pflux_in,3)-1)  :: &
                                                  ktopmxo, kbtmmxo

      real, dimension (size(pflux_in,1),   &
                       size(pflux_in,2),  &
                       size(pflux_in,3)-1)  :: &
                                                  tmp1, pdfinv

      real, dimension (size(pflux_in,1),  &
                       size(pflux_in,2),  &
                       size(pflux_in,3)  )  :: pflux


      integer   :: is, ie, js, je, ks, ke
      integer   ::  kmxolw
      integer   :: i,j, k, kc, kc1, kc2

!---------------------------------------------------------------------
!   local variables:
!
!     delptc
!     fbtm
!     ftop
!     pbtm
!     ptop
!     itopmxo
!     ibtmmxo
!     ktopmxo
!     kbtmmxo
!     tmp1
!     pdfinv 
!     pflux
!     is,ie,js,je,ks,ke
!     kmxolw
!     i,j,k
!     kc
!     kc1,kc2
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_clouds_mod',   &
               'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      kmxolw = MAXVAL(Cld_spec%nmxolw)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
    is = 1
    ie = size (pflux_in, 1)
    js = 1
    je = size(pflux_in,2)
    ks = 1
    ke = size(pflux_in, 3) - 1

!--------------------------------------------------------------------
!    convert pflux to cgs.
!--------------------------------------------------------------------
      pflux = 10.0*pflux_in
      pdfinv(:,:,ks:ke) = 1.0/(pflux(:,:,ks+1:ke+1) - pflux(:,:,ks:ke))

!--------------------------------------------------------------------
!    determine levels at which max overlap clouds start and stop
!--------------------------------------------------------------------
      itopmxo(:,:) = 0
      ibtmmxo(:,:) = 0
      ktopmxo(:,:,:) = 0
      kbtmmxo(:,:,:) = 0

!--------------------------------------------------------------------
!    max overlap cloud in first layer (not likely)
!--------------------------------------------------------------------
      do j = JS,JE
        do i = IS,IE
          if ( Cld_spec%cmxolw(i,j,KS) .GT. 0.0E+00) then
            itopmxo(i,j) = itopmxo(i,j) + 1
            ktopmxo(i,j,itopmxo(i,j)) = KS
          endif
        end do
      end do

!--------------------------------------------------------------------
!    k-level for which top of max overlap cloud is defined
!--------------------------------------------------------------------
      do k = KS+1,KE
        do j = JS,JE
          do i = IS,IE
            if (Cld_spec%cmxolw(i,j,k) .GT. 0.0E+00 .AND.   &
                Cld_spec%cmxolw(i,j,k-1) /= Cld_spec%cmxolw(i,j,k)) then
              itopmxo(i,j) = itopmxo(i,j) + 1
              ktopmxo(i,j,itopmxo(i,j)) = k
            endif
          end do
        end do
      end do

!--------------------------------------------------------------------
!    k-level for which bottom of max overlap cloud is defined
!--------------------------------------------------------------------
      do k=KS,KE-1
        do j=JS,JE
          do i=IS,IE
            if (CLd_spec%cmxolw(i,j,k) > 0.0E+00 .AND.    &
                Cld_spec%cmxolw(i,j,k+1) /= Cld_spec%cmxolw(i,j,k)) then
              ibtmmxo(i,j) = ibtmmxo(i,j) + 1
              kbtmmxo(i,j,ibtmmxo(i,j)) = k+1
            endif
          enddo
        enddo
      enddo

!--------------------------------------------------------------------
!    bottom of max overlap cloud in KE'th level
!--------------------------------------------------------------------
      do j = JS,JE
        do i = IS,IE
          if (Cld_spec%cmxolw(i,j,KE) .GT. 0.0E+00) then
            ibtmmxo(i,j) = ibtmmxo(i,j) + 1
            kbtmmxo(i,j,ibtmmxo(i,j)) = KE+1
          endif
        enddo
      enddo
 
!---------------------------------------------------------------------- 
!    obtain the pressures and fluxes of the top and bottom of the cloud.
!---------------------------------------------------------------------- 
      if (kmxolw .NE. 0) then
        do kc=1,kmxolw 
          do j=JS,JE
            do i=IS,IE
              if (kbtmmxo(i,j,kc) > ktopmxo(i,j,kc)) then
                kc1 = ktopmxo(i,j,kc)
                kc2 = kbtmmxo(i,j,kc)
                ptop(i,j) = pflux (i,j,kc1) 
                pbtm(i,j) = pflux (i,j,kc2)
                ftop(i,j) = Lw_output%flxnet(i,j,kc1)
                fbtm(i,j) = Lw_output%flxnet(i,j,kc2)

!-----------------------------------------------------------------------
!      compute the "flux derivative" df/dp delptc.
!-----------------------------------------------------------------------
                delptc(i,j) = (ftop(i,j) - fbtm(i,j))/   &
                              (ptop(i,j) - pbtm(i,j))
!-----------------------------------------------------------------------
!      compute the total flux change from the top of the cloud.
!-----------------------------------------------------------------------
                do k=kc1+1,kc2-1
                  tmp1(i,j,k) = ftop(i,j) + (pflux(i,j,k) - ptop(i,j))*&
                                delptc(i,j) 
                  Lw_output%flxnet(i,j,k) =   &
                        Lw_output%flxnet(i,j,k)*(1.0E+00 -    &
                        Cld_spec%cmxolw(i,j,k)*   &
                        Cldrad_props%emmxolw(i,j,k,1,1)) +  &
                        tmp1(i,j,k)*Cld_spec%cmxolw(i,j,k)*   &
                        Cldrad_props%emmxolw(i,j,k,1,1)
                end do
              endif
            end do
          end do
        end do
      endif

!-----------------------------------------------------------------------
!     recompute the heating rates based on the revised fluxes.
!-----------------------------------------------------------------------
      Lw_output%heatra(:,:,KS:KE) = radcon* &
                                    (Lw_output%flxnet(:,:,KS+1:KE+1) - &
                                     Lw_output%flxnet(:,:,KS:KE))* &
                                     pdfinv(:,:,KS:KE)

!----------------------------------------------------------------------


end subroutine thickcld
  
   
!#####################################################################
! <SUBROUTINE NAME="lw_clouds_dealloc">
!  <OVERVIEW>
!    subroutine to deallocate the array components of the
!    lw_clouds_type variable that is input.
!  </OVERVIEW>
!  <DESCRIPTION>
!    This subroutine deallocates the array components of the
!    lw_clouds_type variable that is input.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_clouds_dealloc (Lw_clouds)
!  </TEMPLATE>
!  <INOUT NAME="Lw_clouds" TYPE="lw_clouds_type">
!   lw_clouds_type variable containing cloud trans-
!   mission function information
!  </INOUT>
! </SUBROUTINE>

subroutine lw_clouds_dealloc (Lw_clouds)

!------------------------------------------------------------------
!    lw_clouds_dealloc deallocates the array components of the
!    lw_clouds_type variable that is input.
!-------------------------------------------------------------------

type(lw_clouds_type), intent(inout)  :: Lw_clouds

!---------------------------------------------------------------------
!  intent(inout) variables:
!
!     Lw_clouds      lw_clouds_type variable containing cloud trans-
!                    mission function information
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    deallocate the array components of Lw_clouds.
!--------------------------------------------------------------------
      deallocate (Lw_clouds%taucld_rndlw)
      deallocate (Lw_clouds%taucld_mxolw)
      deallocate (Lw_clouds%taunbl_mxolw)

!-------------------------------------------------------------------

end subroutine lw_clouds_dealloc 


!#####################################################################
!
! <SUBROUTINE NAME="longwave_clouds_end">
!  <OVERVIEW>
!   The destructor for longwave_clouds module.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine closes the longwave cloud module. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_clouds_end 
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_clouds_end

!---------------------------------------------------------------------
!    longwave_clouds_end is the destructor for longwave_clouds_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_clouds_mod',   &
               'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------


end subroutine longwave_clouds_end


!######################################################################


                   end module longwave_clouds_mod



                     module longwave_driver_mod
!
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Code to set up longwave radiation calculation
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
! 

use mpp_mod,            only: input_nml_file
use fms_mod,            only: open_namelist_file, fms_init, &
                              mpp_pe, mpp_root_pe, stdlog, &
                              file_exist, write_version_number, &
                              check_nml_error, error_mesg, &
                              FATAL, close_file
use time_manager_mod,   only: time_type

! shared radiation package modules:

use rad_utilities_mod,  only: rad_utilities_init, Rad_control, &
                              cldrad_properties_type, &
                              cld_specification_type, lw_output_type, &
                              atmos_input_type, radiative_gases_type, &
                              aerosol_type, aerosol_properties_type,  &
                              aerosol_diagnostics_type, &
                              Lw_control, assignment(=), &
                              lw_table_type, lw_diagnostics_type

!   radiation package module:

use sealw99_mod,        only: sealw99_init,sealw99_time_vary, sealw99, &
                              sealw99_endts, sealw99_end

!------------------------------------------------------------------

implicit none
private

!-------------------------------------------------------------------
!    longwave_driver_mod is the driver for the longwave radiation
!    component of the sea_esf_rad radiation package.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: longwave_driver.F90,v 18.0.2.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

public      &
   longwave_driver_init, longwave_driver_time_vary, longwave_driver,   &
   longwave_driver_endts, longwave_driver_end

private      &

! called from longwave_driver:
         longwave_driver_alloc


!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16) :: lwform= 'sealw99'
 

namelist / longwave_driver_nml /    &
                                 lwform

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------

logical :: module_is_initialized =  .false.   ! module initialized ?
logical :: do_sealw99 = .false.               ! sealw99 parameter-
                                              ! ization active ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
!                    PUBLIC SUBROUTINES
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! <SUBROUTINE NAME="longwave_driver_init">
!  <OVERVIEW>
!   longwave_driver_init is the constructor for longwave_driver_mod
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine initializes longwave radiation package
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_driver_init (latb, lonb, pref, Lw_tables)
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes at cell corners [radians]
!  </IN>
!  <IN NAME="pref" TYPE="real">
!   array containing two reference pressure profiles [pascals]
!  </IN>
!  <INOUT NAME="Lw_tables" TYPE="lw_table_type">
!   lw_tables_type variable containing various longwave
!                 table specifiers needed by radiation_diag_mod.
!  </INOUT>
! </SUBROUTINE>
!
subroutine longwave_driver_init (latb, lonb, pref, Lw_tables)
 
!---------------------------------------------------------------------
!    longwave_driver_init is the constructor for longwave_driver_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:,:),   intent(in)    :: latb, lonb
real, dimension(:,:),   intent(in)    :: pref
type(lw_table_type),    intent(inout) :: Lw_tables

!---------------------------------------------------------------------
!  intent(in) variables:
!
!       latb      2d array of model latitudes at cell corners 
!                 [ radians ]
!       lonb      2d array of model longitudes at cell corners 
!                 [ radians ]
!       pref      array containing two reference pressure profiles 
!                 [ Pa ]
!
!  intent(out) variables:
!
!       Lw_tables lw_tables_type variable containing various longwave
!                 table specifiers needed by radiation_diag_mod.
!
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!  local variables

      integer     :: unit, ierr, io, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=longwave_driver_nml, iostat=io)
      ierr = check_nml_error(io,'longwave_driver_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=longwave_driver_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'longwave_driver_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=longwave_driver_nml)

!--------------------------------------------------------------------
!    determine if valid specification of lw radiation has been made.
!    if optional packages are provided at some later time, this is where
!    the choice of package will be made.
!---------------------------------------------------------------------
      if (trim(lwform) == 'sealw99') then
        do_sealw99 = .true.
        call sealw99_init ( latb, lonb, pref, Lw_tables)
      else
        call error_mesg ( 'longwave_driver_mod', &
                 'invalid longwave radiation form specified', FATAL)
      endif

!---------------------------------------------------------------------
!    set flag indicating successful initialization of module.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------


end  subroutine longwave_driver_init


!#####################################################################

subroutine longwave_driver_time_vary (Time, Rad_gases_tv)
 
!-------------------------------------------------------------------- 
type(time_type), intent(in) :: Time
type(radiative_gases_type), intent(inout) :: Rad_gases_tv

 

      call sealw99_time_vary (Time, Rad_gases_tv)
 
end subroutine longwave_driver_time_vary      

        
 
!#####################################################################

subroutine longwave_driver_endts (Rad_gases_tv)
          
type(radiative_gases_type), intent(in) :: Rad_gases_tv
 

     call sealw99_endts (Rad_gases_tv)


end subroutine longwave_driver_endts 



!#####################################################################
! <SUBROUTINE NAME="longwave_driver">
!  <OVERVIEW>
!   Subroutine to set up and execute longwave radiation calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   longwave_driver allocates and initializes longwave radiation out-
!    put variables and selects an available longwave radiation param-
!    eterization, executes it, and then returns the output fields to 
!    sea_esf_rad_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_driver (is, ie, js, je, Atmos_input, Rad_gases, &
!                         Aerosol, Cldrad_props, Cld_spec, Lw_output, &
!                         Lw_diagnostics)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting subdomain i indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   ending subdomain i indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting subdomain j indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   ending subdomain j indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cldrad_properties_type variable containing the 
!                   cloud radiative property input fields needed by the 
!                   radiation package
!  </IN>
!  <INOUT NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                   radiation output data
!  </INOUT>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!  </INOUT>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol input data to longwave radiation
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   Cloud specification input data to longwave radiation
!  </IN>
! </SUBROUTINE>
!
subroutine longwave_driver (is, ie, js, je, Rad_time, Atmos_input,  &
                            Rad_gases, Aerosol, Aerosol_props,   &
                            Cldrad_props, Cld_spec, Aerosol_diags, &
                            Lw_output, Lw_diagnostics)

!--------------------------------------------------------------------
!    longwave_driver allocates and initializes longwave radiation out-
!    put variables and selects an available longwave radiation param-
!    eterization, executes it, and then returns the output fields to 
!    sea_esf_rad_mod.
!--------------------------------------------------------------------

integer,                      intent(in)     :: is, ie, js, je
type(time_type),              intent(in)     :: Rad_time
type(atmos_input_type),       intent(in)     :: Atmos_input  
type(radiative_gases_type),   intent(inout)  :: Rad_gases   
type(aerosol_type),           intent(in)     :: Aerosol     
type(aerosol_properties_type),intent(inout)  :: Aerosol_props
type(aerosol_diagnostics_type),intent(inout)  :: Aerosol_diags
type(cldrad_properties_type), intent(in)     :: Cldrad_props
type(cld_specification_type), intent(in)     :: Cld_spec     
type(lw_output_type), dimension(:),  intent(inout)  :: Lw_output
type(lw_diagnostics_type),    intent(inout)  :: Lw_diagnostics

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                     the physics_window being integrated
!      Rad_time       time at which the climatologically-determined, 
!                     time-varying input fields to radiation should 
!                     apply    
!                     [ time_type, days and seconds]
!      Atmos_input    atmos_input_type variable containing the atmos-
!                     pheric input fields needed by the radiation 
!                     package
!      Rad_gases      radiative_gases_type variable containing the radi-
!                     ative gas input fields needed by the radiation 
!                     package
!      Aerosol        aerosol_type variable containing the aerosol 
!                     fields that are seen by the longwave radiation 
!                     package
!      Cldrad_props   cldrad_properties_type variable containing the 
!                     cloud radiative property input fields needed by 
!                     the radiation package
!      Cld_spec       cld_specification_type variable containing the 
!                     cloud specification input fields needed by the 
!                     radiation package
!
!   intent(inout) variables:
!
!      Aerosol_props  aerosol_properties_type variable containing the 
!                     aerosol radiative properties needed by the rad-
!                     iation package 
!      Lw_output      lw_output_type variable containing longwave 
!                     radiation output data 
!      Lw_diagnostics lw_diagnostics_type variable containing diagnostic
!                     longwave output used by the radiation diagnostics
!                     module
!  
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables

      type(lw_output_type)  :: Lw_output_std, Lw_output_ad
      logical :: calc_includes_aerosols
      integer  :: ix, jx, kx  ! dimensions of current physics window

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_driver_mod',   &
          'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    call longwave_driver_alloc to allocate component arrays of a
!    lw_output_type variable.
!----------------------------------------------------------------------
      ix = ie - is + 1
      jx = je - js + 1
      kx = size (Atmos_input%press,3) - 1
!**************************************
      ! This is a temporary fix! Lw_output needs to be allocated at a higher level!
      ! Constructor and destructor for lw_output_type needs to be provided through
      ! rad_utilities
!**************************************
      call longwave_driver_alloc (ix, jx, kx, Lw_output(1))
      call longwave_driver_alloc (ix, jx, kx, Lw_output_std)
      if (Rad_control%do_lwaerosol_forcing) then
      ! This is a temporary fix! Lw_output needs to be allocated at a higher level!
        call longwave_driver_alloc (ix, jx, kx, Lw_output(Rad_control%indx_lwaf))
        call longwave_driver_alloc (ix, jx, kx, Lw_output_ad)
      endif

!--------------------------------------------------------------------
!    calculate the longwave radiative heating rates and fluxes.
!--------------------------------------------------------------------
      if (do_sealw99) then

             
!--------------------------------------------------------------------
!    call sealw99 to use the simplified-exchange-approximation (sea)
!    parameterization.
!----------------------------------------------------------------------
         if (Rad_control%do_lwaerosol_forcing) then
           if (Lw_control%do_lwaerosol) then
             calc_includes_aerosols = .false.
           else
             calc_includes_aerosols = .true.
           endif

!----------------------------------------------------------------------
!    call sealw99 with aerosols (if model is being run without) and 
!    without aerosols (if model is being run with). save the radiation
!    fluxes to Lw_output_ad (which does not feed back into the model),
!    but which may be used to define the aerosol forcing.
!----------------------------------------------------------------------
           call sealw99 (is, ie, js, je, Rad_time, Atmos_input,  &
                     Rad_gases, Aerosol, Aerosol_props, Cldrad_props, &
                     Cld_spec, Aerosol_diags, Lw_output_ad, &
                     Lw_diagnostics, calc_includes_aerosols)
           Lw_output(Rad_control%indx_lwaf) = Lw_output_ad
         endif
 
!----------------------------------------------------------------------
!    standard call, where radiation output feeds back into the model.
!----------------------------------------------------------------------
        call sealw99 (is, ie, js, je, Rad_time, Atmos_input,  &
                      Rad_gases, Aerosol, Aerosol_props, Cldrad_props, &
                      Cld_spec, Aerosol_diags, Lw_output_std,  &
                      Lw_diagnostics, Lw_control%do_lwaerosol)
        Lw_output(1) = Lw_output_std
      else

!--------------------------------------------------------------------
!    at the current time sealw99 is the only longwave parameterization 
!    available.
!----------------------------------------------------------------------
        call error_mesg ('longwave_driver_mod', &
         'invalid longwave radiation parameterization selected', FATAL)
      endif

      call longwave_driver_dealloc (Lw_output_std)
      if (Rad_control%do_lwaerosol_forcing) then
        call longwave_driver_dealloc (Lw_output_ad)
      endif

!---------------------------------------------------------------------

end subroutine longwave_driver


!#####################################################################
! <SUBROUTINE NAME="longwave_driver_end">
!  <OVERVIEW>
!   Subroutine to end longwave calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine end longwave calculation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_driver_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_driver_end                  

!--------------------------------------------------------------------
!    longwave_driver_end is the destructor for longwave_driver_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_driver_mod',   &
          'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    call sealw99_end to close sealw99_mod.
!-------------------------------------------------------------------
      if (do_sealw99) then
        call sealw99_end
      endif

!--------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------


end subroutine longwave_driver_end                  


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
!                     PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#####################################################################
! <SUBROUTINE NAME="longwave_driver_alloc">
!  <OVERVIEW>
!   Subroutine to allocate output variables from longwave calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine allocates and initializes the components
!    of the lw_output_type variable Lw_output which holds the longwave
!    output needed by radiation_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_driver_alloc (ix, jx, kx, Lw_output)
!  </TEMPLATE>
!  <IN NAME="ix" TYPE="integer">
!   Dimension 1 length of radiation arrays to be allocated
!  </IN>
!  <IN NAME="jx" TYPE="integer">
!   Dimension 2 length of radiation arrays to be allocated
!  </IN>
!  <IN NAME="kx" TYPE="integer">
!   Dimension 3 length of radiation arrays to be allocated
!  </IN>
!  <OUT NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                   radiation output data
!  </OUT>
! </SUBROUTINE>
!
subroutine longwave_driver_alloc (ix, jx, kx, Lw_output)

!--------------------------------------------------------------------
!    longwave_driver_alloc allocates and initializes the components
!    of the lw_output_type variable Lw_output which holds the longwave
!    output needed by radiation_driver_mod.
!--------------------------------------------------------------------

integer,                   intent(in)    :: ix, jx, kx
type(lw_output_type),      intent(inout) :: Lw_output

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      ix,jx,kx     (i,j,k) dimensions of current physics window 
!
!
!   intent(inout) variables:
!
!      Lw_output    lw_output_type variable containing longwave 
!                   radiation output data 
!  
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    allocate and initialize arrays to hold net longwave fluxes and 
!    the longwave heating rate at each gridpoint. if the
!    cloud-forcing calculation is to be done, also allocate and init-
!    ialize arrays for fluxes and heating rates without clouds.
!-------------------------------------------------------------------
      allocate (Lw_output%flxnet( ix, jx, kx+1) )
      allocate (Lw_output%heatra( ix, jx, kx  ) )
      allocate (Lw_output%netlw_special   &
                                ( ix, jx, Rad_control%mx_spec_levs  ) )
      allocate (Lw_output%bdy_flx         &
                                ( ix, jx, 4) )
      Lw_output%flxnet(:,:,:) = 0.0
      Lw_output%heatra(:,:,:) = 0.0
      Lw_output%netlw_special(:,:,:) = 0.0
      Lw_output%bdy_flx (:,:,:) = 0.0      
      if (Rad_control%do_totcld_forcing)  then
        allocate (Lw_output%flxnetcf( ix, jx, kx+1) )
        allocate (Lw_output%heatracf( ix, jx, kx  ) )
        allocate (Lw_output%netlw_special_clr  &
                                ( ix, jx, Rad_control%mx_spec_levs  ) )
        allocate (Lw_output%bdy_flx_clr         &
                                ( ix, jx, 4) )
        Lw_output%flxnetcf(:,:,:) = 0.0
        Lw_output%heatracf(:,:,:) = 0.0
        Lw_output%netlw_special_clr(:,:,:) = 0.0
        Lw_output%bdy_flx_clr (:,:,:) = 0.0      
      endif
    
!--------------------------------------------------------------------

end subroutine longwave_driver_alloc


!#####################################################################
! <SUBROUTINE NAME="longwave_driver_dealloc">
!  <OVERVIEW>
!   Subroutine to deallocate output variables from longwave calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine allocates and initializes the components
!    of the lw_output_type variable Lw_output which holds the longwave
!    output needed by radiation_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_driver_alloc (Lw_output)
!  </TEMPLATE>
!  <OUT NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                   radiation output data
!  </OUT>
! </SUBROUTINE>
!
subroutine longwave_driver_dealloc (Lw_output)

!--------------------------------------------------------------------
!    longwave_driver_alloc deallocates the components
!    of the lw_output_type variable Lw_output.
!--------------------------------------------------------------------

type(lw_output_type),      intent(inout) :: Lw_output

!--------------------------------------------------------------------
!
!   intent(inout) variables:
!
!      Lw_output    lw_output_type variable containing longwave 
!                   radiation output data 
!  
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    deallocate arrays to hold net longwave fluxes and 
!    the longwave heating rate at each gridpoint
!-------------------------------------------------------------------
      deallocate (Lw_output%flxnet)
      deallocate (Lw_output%heatra)
      deallocate (Lw_output%netlw_special)
      deallocate (Lw_output%bdy_flx)
      if (Rad_control%do_totcld_forcing)  then
        deallocate (Lw_output%flxnetcf)
        deallocate (Lw_output%heatracf)
        deallocate (Lw_output%netlw_special_clr)
        deallocate (Lw_output%bdy_flx_clr)
      endif
    
!--------------------------------------------------------------------

end subroutine longwave_driver_dealloc

!###################################################################



                end module longwave_driver_mod


                  module longwave_fluxes_mod
!
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  Fei Liu
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  Dan Schwartzkopf
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  This code is a helper module that provides various operations on 
!  longwave flux variables.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!
!  shared modules:

use mpp_mod,            only: input_nml_file
use fms_mod,            only: open_namelist_file, fms_init, &
                              mpp_pe, mpp_root_pe, stdlog, &
                              file_exist, write_version_number, &
                              check_nml_error, error_mesg, &
                              FATAL, close_file

!  shared radiation package modules:

use rad_utilities_mod, only:  Rad_control, &
                              rad_utilities_init, lw_diagnostics_type

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    longwave_fluxes calculates the longwave fluxes between each model
!    level and every other modle level for each of the longwave
!    spectral parameterization bands.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: longwave_fluxes.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public    &
       longwave_fluxes_init, &
       longwave_fluxes_ks, longwave_fluxes_k_down, &
       longwave_fluxes_KE_KEp1, longwave_fluxes_diag, &
       longwave_fluxes_sum, longwave_fluxes_end



!---------------------------------------------------------------------
!-------- namelist  ---------

real      ::  dummy = 1.0                    

namelist / longwave_fluxes_nml /        &
                                    dummy

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------

logical :: module_is_initialized = .false. ! module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                         contains

! <SUBROUTINE NAME="longwave_fluxes_init">
!  <OVERVIEW>
!   Subroutine to initialize longwave fluxes namelist
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to initialize longwave fluxes namelist
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_fluxes_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_fluxes_init 

!---------------------------------------------------------------------
!    longwave_fluxes_init is the constructor for longwave_fluxes_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
     integer    ::  unit, ierr, io, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=longwave_fluxes_nml, iostat=io)
      ierr = check_nml_error(io,"longwave_fluxes_nml")
#else
!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=longwave_fluxes_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'longwave_fluxes_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=longwave_fluxes_nml)

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------

end subroutine longwave_fluxes_init



!#####################################################################
! <SUBROUTINE NAME="longwave_fluxes_ks">
!  <OVERVIEW>
!   Subroutine to calculate longwave diagnostic fluxes
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to calculate longwave diagnostic fluxes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_fluxes_ks ( source, trans, source2, trans2,  &
!                             cld_trans, cld_ind, Lw_diagnostics)
!  </TEMPLATE>
!  <IN NAME="source" TYPE="real">
!   source is longwave source function.
!  </IN>
!  <IN NAME="trans" TYPE="real">
!   trans is longwve transmittance function
!  </IN>
!  <IN NAME="source2" TYPE="real">
!   source2 is longwave source function
!  </IN>
!  <IN NAME="trans2" TYPE="real">
!   trans2 is longwve transmittance function
!  </IN>
!  <IN NAME="cld_trans" TYPE="real">
!   cld_trans is longwave cloud transmittance function
!  </IN>
!  <IN NAME="cld_ind" TYPE="real">
!   cld_ind is a lookup table to translate longwave band index to cloud index
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   Lw_diagnostics contains the longwave diagnostics flux values
!  </INOUT>
! </SUBROUTINE>
!
subroutine longwave_fluxes_ks (source, trans, source2, trans2,  &
                               cld_trans, cld_ind, Lw_diagnostics)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
integer, dimension(:),      intent(in)    :: cld_ind
real, dimension (:,:,:,:),  intent(in)    :: source
real, dimension (:,:,:,:),  intent(in)    :: source2
real, dimension (:,:,:,:),  intent(in)    :: trans2, trans
real, dimension (:,:,:,:),  intent(in)    :: cld_trans
type(lw_diagnostics_type),  intent(inout) :: Lw_diagnostics
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!  intent(in) variables:
!
!     cld_ind
!     source
!     source2
!     trans
!     trans2
!     cld_trans
!
!  intent(inout) variables:
!
!     Lw_diagnostics
!
!---------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      real, dimension (size(source2,1), &
                       size(source2,2), &
                       size(source2,3) ) ::    flux_tmp, flux_tmp2

      integer   ::   k, ks, ke, nbands, m

!---------------------------------------------------------------------
!  local variables:
!
!      flux_tmp
!      flux_tmp2
!      k
!      ks
!      ke
!      nbands
!      m
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_fluxes_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ks =1
      ke = size(source2,3)-1
      nbands = size(source,4)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do m = 1, nbands
        do k=KS+1, KE+1
          flux_tmp(:,:,k) = source(:,:,KS,m)*trans(:,:,k,m    )
          flux_tmp2(:,:,k) = source2(:,:,k,m)*trans2(:,:,k ,m    )
        end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        if ((m  == 1) .or. (m  >= 7)) then
          Lw_diagnostics%fluxn(:,:,KS,m) =    &
                                     Lw_diagnostics%fluxn(:,:,KS,m) + &
                                     source(:,:,KS,m)*trans(:,:,KS,m)
        else
          Lw_diagnostics%fluxn(:,:,KS,m) =    &
                                     Lw_diagnostics%fluxn(:,:,KS,m) + &
                                     source(:,:,KS,m)
        endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        do k=KS+1,KE+1
          Lw_diagnostics%fluxn(:,:,k,m) =   &
                                     Lw_diagnostics%fluxn(:,:,k,m) +  &
                                     flux_tmp(:,:,k)* & 
                                     cld_trans(:,:,k,cld_ind(m))
          Lw_diagnostics%fluxn(:,:,KS,m) =  &
                                     Lw_diagnostics%fluxn(:,:,KS,m) + &
                                     flux_tmp2(:,:,k)*   &
                                     cld_trans(:,:,k,cld_ind(m))
        end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        if (Rad_control%do_totcld_forcing) then
          if ((m  == 1) .or. (m  >= 7)) then
            Lw_diagnostics%fluxncf(:,:,KS,m) = source(:,:,KS,m)*   &
                                               trans(:,:,KS,m)
          else
            Lw_diagnostics%fluxncf(:,:,KS,m) =  source(:,:,KS,m)
          endif
          do k=KS+1,KE+1
            Lw_diagnostics%fluxncf(:,:,k,m) =   &
                                    Lw_diagnostics%fluxncf(:,:,k,m) + &
                                    flux_tmp(:,:,k)
            Lw_diagnostics%fluxncf(:,:,KS,m) =  &
                                    Lw_diagnostics%fluxncf(:,:,KS,m) + &
                                    flux_tmp2(:,:,k)
          end do
        endif
     end do   ! (m loop)

!---------------------------------------------------------------------


end subroutine longwave_fluxes_ks



!####################################################################
! <SUBROUTINE NAME="longwave_fluxes_k_down">
!  <OVERVIEW>
!   Subroutine to calculate longwave diagnostic fluxes
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to calculate longwave diagnostic fluxes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_fluxes_k_down (klevel, source, trans, trans2,   &
!                                cld_trans, cld_ind,   Lw_diagnostics)
!  </TEMPLATE>
!  <IN NAME="klevel" TYPE="integer">
!   klevel is the starting vertical level to calculate longwave fluxes
!  </IN>
!  <IN NAME="source" TYPE="real">
!   source is longwave flux source function
!  </IN>
!  <IN NAME="trans" TYPE="real">
!   trans is longwave flux transmittance function
!  </IN>
!  <IN NAME="trans2" TYPE="real">
!   trans2 is longwave flux transmittance function
!  </IN>
!  <IN NAME="cld_trans" TYPE="real">
!   cld_trans is longwave cloud transmittance function
!  </IN>
!  <IN NAME="cld_ind" TYPE="real">
!   cld_ind is a lookup table to translate longwave band index to cloud index
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   Lw_diagnostics contains the longwave diagnostics flux values
!  </INOUT>
! </SUBROUTINE>
!
subroutine longwave_fluxes_k_down (klevel, source, trans, trans2,   &
                                   cld_trans, cld_ind, Lw_diagnostics)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

integer,                      intent(in)     ::  klevel
real,    dimension (:,:,:,:), intent(in)     ::  source, trans, &
                                                 trans2, cld_trans
type(lw_diagnostics_type),    intent(inout)  ::  Lw_diagnostics
integer, dimension(:),        intent(in)     ::  cld_ind

!-------------------------------------------------------------------
!  intent(in) variables:
!
!     klevel
!     source
!     trans
!     trans2
!     cld_trans
!     cld_ind
!
!  intent(inout) variables:
!
!     Lw_diagnostics
!
!---------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      real, dimension (size(source,1), size(source,2)) :: flux4, flux4a

      real    ::  flux_tmp, flux_tmp2
      integer ::  kp, i, j, israd, ierad, jsrad, jerad
      integer :: ke
      integer :: m, nbands

!---------------------------------------------------------------------
!  local variables:
!
!      flux4
!      flux4a
!      flux3a
!      flux_tmp
!      flux_tmp2
!      kp
!      i,j,k
!      nn
!      ntot
!      israd,ierad
!      jsrad,jerad
!      ke
!      m
!      nbands
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_fluxes_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ierad  = size(source,1)
      jerad  = size(source,2)
      israd  = 1
      jsrad  = 1
      ke     = size(source,3)-1
      nbands = size(trans,4)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do m=1, nbands
        do kp=klevel+1,KE+1
          do j=jsrad,jerad
            do i=israd,ierad   
              flux_tmp = source(i,j,klevel,m)*trans(i,j,kp,m)
              Lw_diagnostics%fluxn(i,j,kp,m) =    &
                          Lw_diagnostics%fluxn(i,j,kp,m) + flux_tmp*   &
                          cld_trans(i,j,kp, cld_ind(m))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
              if (Rad_control%do_totcld_forcing) then
                Lw_diagnostics%fluxncf(i,j,kp,m) =   &
                            Lw_diagnostics%fluxncf(i,j,kp,m) + flux_tmp 

              endif
            end do
          end do
        end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        flux4(:,:)  = 0.0
        flux4a(:,:) = 0.0
        do kp=klevel+1,KE+1
          do j=jsrad,jerad
            do i=israd,ierad   
              flux_tmp2 = source(i,j,kp,m)*trans2(i,j,kp,m)
              flux4(i,j) = flux4(i,j) + flux_tmp2*  &
                           cld_trans(i,j,kp, cld_ind(m))
              if (Rad_control%do_totcld_forcing) then
                flux4a (i,j) = flux4a (i,j) + flux_tmp2        
              endif
            end do
          end do
        end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        do j=jsrad,jerad
          do i=israd,ierad   
            Lw_diagnostics%fluxn  (i,j,klevel,m) =   &
                               Lw_diagnostics%fluxn  (i,j,klevel,m) +  &
                               flux4    (i,j       )
            if (Rad_control%do_totcld_forcing) then
              Lw_diagnostics%fluxncf(i,j,klevel,m) =  &
                               Lw_diagnostics%fluxncf(i,j,klevel,m) +  &
                               flux4a   (i,j       )
            endif
          end do
        end do
      end do  ! (nbands loop)

!---------------------------------------------------------------------


end subroutine longwave_fluxes_k_down



!####################################################################
! <SUBROUTINE NAME="longwave_fluxes_KE_KEp1">
!  <OVERVIEW>
!   Subroutine to calculate longwave diagnostic fluxes
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to calculate longwave diagnostic fluxes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_fluxes_KE_KEp1 (source, trans, trans2,   &
!                                cld_trans, cld_ind,   Lw_diagnostics)
!  </TEMPLATE>
!  <IN NAME="source" TYPE="real">
!   source is longwave flux source function
!  </IN>
!  <IN NAME="trans" TYPE="real">
!   trans is longwave flux transmittance function
!  </IN>
!  <IN NAME="trans2" TYPE="real">
!   trans2 is longwave flux transmittance function
!  </IN>
!  <IN NAME="cld_trans" TYPE="real">
!   cld_trans is longwave cloud transmittance function
!  </IN>
!  <IN NAME="cld_ind" TYPE="real">
!   cld_ind is a lookup table to translate longwave band index to cloud index
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   Lw_diagnostics contains the longwave diagnostics flux values
!  </INOUT>
! </SUBROUTINE>
!
subroutine longwave_fluxes_KE_KEp1 (source, trans, trans2, cld_trans,&
                                       cld_ind, Lw_diagnostics)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real,    dimension (:,:,:,:),   intent(in)    :: source, cld_trans
real,    dimension (:,:,:),     intent(in)    :: trans, trans2
integer, dimension(:),          intent(in)    :: cld_ind
type(lw_diagnostics_type),      intent(inout) :: Lw_diagnostics

!-------------------------------------------------------------------
!  intent(in) variables:
!
!     source
!     cld_trans
!     trans
!     trans2
!     cld_ind
!
!  intent(inout) variables:
!
!     Lw_diagnostics
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension (size(trans,1), size(trans,2)) ::  &
                                                   flux_tmp, flux_tmp2

      integer :: ke
      integer :: m, nbands

!---------------------------------------------------------------------
!  local variables:
!
!      flux_tmp
!      flux_tmp2
!      ke
!      m
!      nbands
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_fluxes_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ke     = size(source,3) - 1
      nbands = size(trans,3) 

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do m=1,nbands
        flux_tmp(:,:) = source(:,:,KE+1,m)*trans(:,:,m)
        flux_tmp2(:,:) = source(:,:,KE,m)*trans2(:,:,m)
        Lw_diagnostics%fluxn(:,:,KE,m) =    &
                       Lw_diagnostics%fluxn(:,:,KE,m) + &
                       flux_tmp(:,:)*cld_trans(:,:,KE+1,cld_ind(m))
        Lw_diagnostics%fluxn(:,:,KE+1,m) =  &
                       Lw_diagnostics%fluxn(:,:,KE+1,m) +   &
                       flux_tmp2(:,:)*cld_trans(:,:,KE+1,cld_ind(m))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        if (Rad_control%do_totcld_forcing) then
          Lw_diagnostics%fluxncf(:,:,KE,m) =   &
                       Lw_diagnostics%fluxncf(:,:,KE,m) + flux_tmp(:,:)
          Lw_diagnostics%fluxncf(:,:,KE+1,m) =  &
                       Lw_diagnostics%fluxncf(:,:,KE+1,m) +  &
                       flux_tmp2(:,:)
        endif
      end do  ! (nbands loop)

!---------------------------------------------------------------------

end subroutine longwave_fluxes_KE_KEp1



!####################################################################
! <SUBROUTINE NAME="longwave_fluxes_diag">
!  <OVERVIEW>
!   Subroutine to calculate longwave diagnostic fluxes
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to calculate longwave diagnostic fluxes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_fluxes_diag (source, trans,  &
!                               cld_trans, cld_ind,   Lw_diagnostics)
!  </TEMPLATE>
!  <IN NAME="source" TYPE="real">
!   source is longwave flux source function
!  </IN>
!  <IN NAME="trans" TYPE="real">
!   trans is longwave flux transmittance function
!  </IN>
!  <IN NAME="cld_trans" TYPE="real">
!   cld_trans is longwave cloud transmittance function
!  </IN>
!  <IN NAME="cld_ind" TYPE="real">
!   cld_ind is a lookup table to translate longwave band index to cloud index
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   Lw_diagnostics contains the longwave diagnostics flux values
!  </INOUT>
! </SUBROUTINE>
!
subroutine longwave_fluxes_diag (source, trans, cld_trans, cld_ind, &
                                 Lw_diagnostics)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
!---------------------------------------------------------------------
real, dimension (:,:,:,:), intent(in)    :: source, trans, cld_trans
integer, dimension(:),     intent(in)    :: cld_ind
type(lw_diagnostics_type), intent(inout) :: Lw_diagnostics
!-------------------------------------------------------------------
!  intent(in) variables:
!
!     source
!     trans
!     cld_trans
!     cld_ind
!
!  intent(inout) variables:
!
!     Lw_diagnostics
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables

      real, dimension (size(trans,1), &
                       size(trans,2), &
                       size(trans,3)) ::   flux_tmp

      integer   :: k, ks, ke
      integer   :: m, nbands

!---------------------------------------------------------------------
!  local variables:
!
!      flux_tmp
!      k
!      ks
!      ke
!      m
!      nbands
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_fluxes_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ks     = 1
      ke     = size(trans,3) - 1
      nbands = size(trans,4)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do m=1,nbands

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

        do k=KS+1, KE+1
          flux_tmp(:,:,k) = source(:,:,k,m)*trans(:,:,k,m)
        end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        do k=KS+1,KE+1
          Lw_diagnostics%fluxn(:,:,k,m) =   &
                             Lw_diagnostics%fluxn(:,:,k,m) +  &
                             flux_tmp(:,:,k)*cld_trans(:,:,k,cld_ind(m))
        end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        if (Rad_control%do_totcld_forcing) then
          do k=KS+1,KE+1
            Lw_diagnostics%fluxncf(:,:,k,m) =    &
                               Lw_diagnostics%fluxncf(:,:,k,m) +   &
                               flux_tmp(:,:,k)
          end do
        endif
      end do ! (m loop)

!---------------------------------------------------------------------



end subroutine longwave_fluxes_diag




!###################################################################
! <SUBROUTINE NAME="longwave_fluxes_sum">
!  <OVERVIEW>
!   Subroutine to compute summation of diagnostic longwave fluxes over
!   all bands
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute summation of diagnostic longwave fluxes over
!   all bands
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_fluxes_sum (is, ie, js, je, flux, NBTRGE,         &
!                             Lw_diagnostics, fluxcf)
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   Obsolete
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   Obsolete
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   Obsolete
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   Obsolete
!  </IN>
!  <OUT NAME="flux" TYPE="real">
!   all sky total longwave flux
!  </OUT>
!  <IN NAME="NBTRGE" TYPE="integer">
!   number of longwave flux bands 
!  </IN>
!  <IN NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   longwave flux diagnostics
!  </IN>
!  <OUT NAME="fluxcf" TYPE="real">
!   clear sky total longwave flux
!  </OUT>
! </SUBROUTINE>
!
subroutine longwave_fluxes_sum (is, ie, js, je, flux, nbtrge,         &
                                Lw_diagnostics, fluxcf)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

integer,                          intent(in)    :: is, ie, js, &
                                                   je, nbtrge
real, dimension(:,:,:),           intent(out)   :: flux
real, dimension(:,:,:), optional, intent(out)   :: fluxcf
type(lw_diagnostics_type),        intent(in)    :: Lw_diagnostics

!-------------------------------------------------------------------
!  intent(in) variables:
!
!     is,ie,js,je
!     nbtrge
!     Lw_diagnostics
!
!  intent(out) variables:
!
!     flux
!     fluxcf
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables
!--------------------------------------------------------------------
    integer       ::   m

!---------------------------------------------------------------------
!  local variables:
!
!      j,m        
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_fluxes_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      flux = 0.
      do m= 1, 6+NBTRGE               
        flux(:,:,:) = flux(:,:,:) + Lw_diagnostics%fluxn(:,:,:,m)
      end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (Rad_control%do_totcld_forcing) then 
        fluxcf = 0.
        do m= 1, 6+NBTRGE               
          fluxcf(:,:,:) = fluxcf(:,:,:) +    &
                          Lw_diagnostics%fluxncf(:,:,:,m)
        end do
      endif

!--------------------------------------------------------------------


end subroutine longwave_fluxes_sum


!#####################################################################

subroutine longwave_fluxes_end

!--------------------------------------------------------------------
!    longwave_fluxes_end is the destructor for the longwave_fluxes_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_fluxes_mod',   &
              'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------


end subroutine longwave_fluxes_end


!#####################################################################


                end module longwave_fluxes_mod



                    module longwave_params_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Code that contains parameters for the longwave code
! </OVERVIEW>  
! <DESCRIPTION>
!  This code has the number of bands defined for the longwave gases.
! </DESCRIPTION>
! 

!   shared modules:

 use mpp_mod, only: input_nml_file
 use fms_mod, only: open_namelist_file, fms_init, &
                    mpp_pe, mpp_root_pe, stdlog, &
                    file_exist, write_version_number, &
                    check_nml_error, error_mesg, &
                    FATAL, close_file

!--------------------------------------------------------------------

implicit none
private

!-------------------------------------------------------------------
!    longwave_params_mod defines basic parameters used by the
!    longwave radiation code.
!------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: longwave_params.F90,v 17.0.4.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!--------------------------------------------------------------------
!----- interfaces ------

public     &
         longwave_params_init, &
         longwave_params_end

!private   &


!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=8)   :: dummy  = '     '


namelist /longwave_params_nml/    &
                               dummy                 

!-------------------------------------------------------------------
!----- public data --------

!--------------------------------------------------------------------
!       NBCO215
!       NBLY_RSB
!       NBLY_CKD
!       NBLW
!       NBLX
!---------------------------------------------------------------------
integer, parameter, public   :: NBCO215     = 3
integer, parameter, public   :: NBLY_RSB    = 16
integer, parameter, public   :: NBLY_CKD    = 48
integer, parameter, public   :: NBLW        = 300
integer, parameter, public   :: NBLX        = 48




!-------------------------------------------------------------------
!----- private data --------

logical :: module_is_initialized = .false.  ! module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!####################################################################

! <SUBROUTINE NAME="longwave_params_init">
!  <OVERVIEW>
!   Subroutine to initialize longwave parameter module
!  </OVERVIEW>
!  <DESCRIPTION>
!   This is the longwave_params constructor method
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_params_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_params_init

!------------------------------------------------------------------
!    longwave_params_init is the constructor for longwave_params_mod.
!------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      integer    ::  unit, ierr, io, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init

!-----------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=longwave_params_nml, iostat=io)
      ierr = check_nml_error(io,"longwave_params_nml")
#else
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=longwave_params_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'longwave_params_nml')
        end do
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) then
        write (logunit, nml=longwave_params_nml)
        write (logunit,9000) NBCO215, NBLY_RSB, NBLY_CKD,   &
                              NBLW, NBLX 
      endif

!----------------------------------------------------------------------
!    mark the module as initialized.
!----------------------------------------------------------------------
     module_is_initialized = .true.

!------------------------------------------------------------------
9000 format ( 'NBCO215=', i3,'  NBLY_RSB=', i4,   &
              '  NBLY_CKD=', i4, '  NBLW= ', i4, '  NBLX=', i4 )

!-------------------------------------------------------------------


end  subroutine longwave_params_init



!####################################################################

! <SUBROUTINE NAME="longwave_params_end">
!  <OVERVIEW>
!   Subroutine to close out longwave parameter module
!  </OVERVIEW>
!  <DESCRIPTION>
!   This is the longwave_params destructor subroutine
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_params_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_params_end

!-------------------------------------------------------------------
!    longwave_params_end is the destructor for longwave_params_mod.
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_params_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!-------------------------------------------------------------------



end subroutine longwave_params_end


!####################################################################


                   end module longwave_params_mod


                  module longwave_tables_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  Fei Liu
! </CONTACT>
! <REVIEWER EMAIL="ds@gfdl.noaa.gv">
!  Dan Schwarzkopf
! </REVIEWER>
! <OVERVIEW>
!  This code defines longwave radiation tables, it also
!  allocate, compute related parameters based on prescribed
!  tables.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!

!    shared modules:

use mpp_mod,               only: input_nml_file
use fms_mod,               only: open_namelist_file, fms_init, &
                                 mpp_pe, mpp_root_pe, stdlog, &
                                 file_exist, write_version_number, &
                                 check_nml_error, error_mesg, &
                                 FATAL, close_file

!  shared radiation package modules:

use rad_utilities_mod,     only: rad_utilities_init,       &  
                                 longwave_tables1_type,  &
                                 longwave_tables2_type,  &
                                 longwave_tables3_type,  &
                                 lw_table_type, Lw_parameters,&
                                 table_alloc, mass_1, temp_1, &
                                 Lw_control
use longwave_params_mod,   only: longwave_params_init, NBLW, NBLX, &
                                 NBLY_RSB, NBLY_CKD

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    longwave_tables_mod constructs various tables used in the longwave
!    radiation parameterization.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: longwave_tables.F90,v 17.0.4.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!------    interfaces   ------

public      &
          longwave_tables_init, &
          longwave_tables_end

private      &

!  called from longwave_tables_init:
          idrbtsh2o, id2h2o, table


!---------------------------------------------------------------------
!------  namelist  -----

real       :: dummy = 1.0

namelist / longwave_tables_nml /  &
                                   dummy

!---------------------------------------------------------------------
!---- public data -------


!---------------------------------------------------------------------
!---- private data -------

!--------------------------------------------------------------------
!    define continuum coefficients over special bands, the choices 
!    depend on model architecture. the program gasbnd is used.
!--------------------------------------------------------------------
real, dimension(:), allocatable :: afach4, afan2o
              
real, dimension(:), allocatable :: fbdlo_12001400, fbdhi_12001400
real, dimension(:), allocatable :: dummy_ch4n2o

real, dimension(:), allocatable :: bdlahcn, bdhahcn

real, dimension(:), allocatable :: bfach4, bfan2o             

real, dimension(:), allocatable :: dch4, dn2o, ech4, en2o
real                            :: d171n2o, e171n2o

real, dimension(:), allocatable :: acomb, bcomb, apcm, bpcm, atpcm,  &
                                   btpcm, bdlocm, bdhicm

integer, parameter              :: NTTABH2O   = 28
integer, parameter              :: NUTABH2O   = 181

real, dimension (NBLW)          :: bandlo, bandhi, arndm, brndm, betad
integer, dimension(40)          :: iband
real, dimension(3)              :: ao3cm, bo3cm
real, dimension(2)              :: ab15cm

integer                         :: NBTRG, NBTRGE, NBLY
real                            :: apwd, bpwd, atpwd, btpwd, bdlowd, &
                                   bdhiwd 

logical :: module_is_initialized = .false.   !  module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------




                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
!#####################################################################

! <SUBROUTINE NAME="longwave_tables_init">
!  <OVERVIEW>
!   Constructor of longwave_tables module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Defines continuum coefficients and random band parameters for longwave
!   gas species.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_tables_init (Lw_tables, tabsr,   &
!                        tab1, tab2, tab3, tab1w, tab1a, tab2a, tab3a)
!  </TEMPLATE>
!  <IN NAME="Lw_tables" TYPE="lw_table_type">
!   Contains the tables used in longwave radiation
!  </IN>
!  <OUT NAME="tabsr" TYPE="longwave_tables3_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab1" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tabs2" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab3" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab1w" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab1a" TYPE="longwave_tables2_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tabs2a" TYPE="longwave_tables2_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab3a" TYPE="longwave_tables2_type">
!   Contains the tables used in longwave radiation
!  </OUT>
! </SUBROUTINE>
!
subroutine longwave_tables_init (Lw_tables, tabsr, tab1, tab2, tab3, &
                                 tab1w, tab1a, tab2a, tab3a)

!--------------------------------------------------------------------
!    longwave_tables_init is the constructor for longwave_tables_mod.
!--------------------------------------------------------------------

type(lw_table_type),          intent(inout) :: Lw_tables
type(longwave_tables3_type),  intent(inout) :: tabsr
type (longwave_tables1_type), intent(inout) :: tab1, tab2, tab3, tab1w
type (longwave_tables2_type), intent(inout) :: tab1a, tab2a, tab3a

!---------------------------------------------------------------------
!   intent(inout) variables:
!
!    Lw_tables
!    tabsr
!    tab1
!    tab2
!    tab3
!    tab1w
!    tab1a
!    tab2a
!    tab3a
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

!---------------------------------------------------------------------
!    define continuum coefficients over special bands, the choices 
!    depend on model architecture. the program gasbnd is used.
!---------------------------------------------------------------------
      real                          :: apwd_c, bpwd_c, atpwd_c,    &
                                       btpwd_c, bdlowd_c, bdhiwd_c
      real, dimension (NBLY_CKD)    :: acomb_c, bcomb_c, apcm_c,  &
                                       bpcm_c, atpcm_c,   &
                                       btpcm_c, bdlocm_c,  bdhicm_c
      integer                       :: inrad, k
      integer                       :: subb
      integer, dimension(5)         :: no_h2o12001400bands = &
                                        (/ 1, 2, 4, 10, 20 /)
 
!---------------------------------------------------------------------
!    2) 160-560 (as 40 bands). program gasbnd is used with 10 cm-1
!    bandwidth. iband is straightforward mapping.
!---------------------------------------------------------------------
      integer, dimension(40)        :: iband_c
      data iband_c /    &
          1,   2,   3,   4,   5,   6,   7,   8,   9,  10,   &
         11,  12,  13,  14,  15,  16,  17,  18,  19,  20,  &
         21,  22,  23,  24,  25,  26,  27,  28,  29,  30,   &
         31,  32,  33,  34,  35,  36,  37,  38,  39,  40/ 

!----------------------------------------------------------------------
!    define random band parameters for special bands. the choices 
!    depend on model architecture. the program gasbnd is used.
!    2) 160-560 (as 8 bands using combined bands). program gasbnd is
!    used as 40 bands (160-560,10 cm-1 bandwidth) with ifdef icomb
!    on. combined bands defined according to index iband.
!----------------------------------------------------------------------
      real                        ::   apwd_n, bpwd_n, atpwd_n,   &
                                       btpwd_n, bdlowd_n, bdhiwd_n
      real, dimension (NBLY_RSB)  ::   acomb_n, bcomb_n, apcm_n,  &
                                       bpcm_n, atpcm_n, btpcm_n,  &
                                       bdlocm_n,  bdhicm_n
      real, dimension(NBLY_RSB)   ::   dummy_n
      real                        ::   dum
 
      integer, dimension(40)      ::   iband_n
      data iband_n /   &
          2,   1,   2,   2,   1,   2,   1,   3,   2,   2,   &
          3,   2,   2,   4,   2,   4,   2,   3,   3,   2,  &
          4,   3,   4,   3,   7,   5,   6,   7,   6,   5,  &
          7,   6,   7,   8,   6,   6,   8,   8,   8,   8/
 
!---------------------------------------------------------------------
!    miscellaneous variables:
!    unit            io unit number used for namelist file
!    ierr            error code
!    io              error status returned from io operation
!    k4
!    n4
!---------------------------------------------------------------------
      integer    :: unit, ierr, io, logunit


!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call longwave_params_init

!-----------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=longwave_tables_nml, iostat=io)
      ierr = check_nml_error(io,"longwave_tables_nml")
#else
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=longwave_tables_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'longwave_tables_nml')
        end do
10      call close_file (unit)
      endif
#endif
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=longwave_tables_nml)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(Lw_control%linecatalog_form) == 'hitran_1992' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
          inrad = open_namelist_file ('INPUT/h2ocoeff_ckd_speccombwidebds_hi92')
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) apwd_c   ! ckd capphi coeff for 560-800 band
          read (inrad,9000) bpwd_c   ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) atpwd_c  ! ckd capphi coeff for 560-800 band
          read (inrad,9000) btpwd_c  ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) bdlowd_c  ! lo freq of 560-800 band
          read (inrad,9000) bdhiwd_c  ! hi freq of 560-800 band
!  ckd rndm coeff for 40 bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bcomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (apcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (atpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (btpcm_c(k),k=1,NBLY_CKD)
!  ckd lo/hi freq for 40 bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (bdlocm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bdhicm_c(k),k=1,NBLY_CKD)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_rsb_speccombwidebds_hi92')
          read (inrad,9000) dum     
          read (inrad,9000) dum    
          read (inrad,9000) apwd_n   ! rsb capphi coeff for 560-800 band
          read (inrad,9000) bpwd_n   ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) atpwd_n  ! rsb capphi coeff for 560-800 band
          read (inrad,9000) btpwd_n  ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) bdlowd_n ! lo freq of 560-800 band
          read (inrad,9000) bdhiwd_n ! hi freq of 560-800 band
          read (inrad,9000) dum   
!  rsb rndm coeff for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bcomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (apcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (atpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (btpcm_n(k),k=1,NBLY_RSB)
!  rsb lo/hi freq for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (bdlocm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bdhicm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
        endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      else if (trim(Lw_control%linecatalog_form) == 'hitran_2000' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_ckd_speccombwidebds_hi00')
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) apwd_c   ! ckd capphi coeff for 560-800 band
          read (inrad,9000) bpwd_c   ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) atpwd_c  ! ckd capphi coeff for 560-800 band
          read (inrad,9000) btpwd_c  ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) bdlowd_c ! lo freq of 560-800 band
          read (inrad,9000) bdhiwd_c ! hi freq of 560-800 band
!  ckd rndm coeff for 40 bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bcomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (apcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (atpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (btpcm_c(k),k=1,NBLY_CKD)
!  ckd lo/hi freq for 40 bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (bdlocm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bdhicm_c(k),k=1,NBLY_CKD)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_rsb_speccombwidebds_hi00')
          read (inrad,9000) dum     
          read (inrad,9000) dum    
          read (inrad,9000) apwd_n   ! rsb capphi coeff for 560-800 band
          read (inrad,9000) bpwd_n   ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) atpwd_n  ! rsb capphi coeff for 560-800 band
          read (inrad,9000) btpwd_n  ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) bdlowd_n ! lo freq of 560-800 band
          read (inrad,9000) bdhiwd_n ! hi freq of 560-800 band
          read (inrad,9000) dum   
!  rsb rndm coeff for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bcomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (apcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (atpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (btpcm_n(k),k=1,NBLY_RSB)
!  rsb lo/hi freq for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (bdlocm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bdhicm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
        endif
      endif
      call close_file (inrad)

!----------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (Lw_parameters%NBTRG_iz) then
        NBTRG  = Lw_parameters%NBTRG
      else
        call error_mesg ('longwave_tables_mod', &
                       ' Lw_parameters%NBTRG not yet defined', FATAL) 
      endif
      if (Lw_parameters%NBTRGE_iz) then
        NBTRGE = Lw_parameters%NBTRGE
      else
        call error_mesg ('longwave_tables_mod', &
                       ' Lw_parameters%NBTRGE not yet defined', FATAL)
      endif

!----------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (NBTRGE > 0) then
        allocate ( fbdlo_12001400 (NBTRGE) )
        allocate ( fbdhi_12001400 (NBTRGE) )
        allocate ( dummy_ch4n2o (NBTRGE) )
      endif
      if (NBTRG  > 0) then
        allocate ( afach4 (NBTRG ) )
        allocate ( afan2o (NBTRG ) )
        allocate ( bdlahcn(NBTRG ) )
        allocate ( bdhahcn(NBTRG ) )
        allocate ( bfach4 (NBTRG ) )
        allocate ( bfan2o (NBTRG ) )
        allocate ( dch4   (NBTRG ) )
        allocate ( dn2o   (NBTRG ) )
        allocate ( ech4   (NBTRG ) )
        allocate ( en2o   (NBTRG ) )
      endif

!----------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (NBTRGE > 0) then
        if (trim(Lw_control%linecatalog_form) == 'hitran_1992') then
          inrad = open_namelist_file ('INPUT/h2o12001400_hi92_data')
        else if(trim(Lw_control%linecatalog_form) == 'hitran_2000') then
          inrad = open_namelist_file ('INPUT/h2o12001400_hi00_data')
        endif

!----------------------------------------------------------------------
!    read in random coefficients for 1200-1400 freq region, spacing
!    through the data until  those appropriate for NBTRGE h2o bands
!    are reached. note: unless a continuum is inserted beyond 1200
!    cm-1, the band coefficients are independent of continuum type.
!---------------------------------------------------------------------
        do subb = 1,5    ! 5 = no. band divisions in h2o 1200-1400 data
          if (NBTRGE == no_h2o12001400bands(subb)) then

!---------------------------------------------------------------------
!    read and process data for sub-band number from data matching NBTRGE
!    then exit subb loop
!---------------------------------------------------------------------
            read (inrad,2001) (dummy_ch4n2o(k),k=1,NBTRGE)
            read (inrad,2001) (dummy_ch4n2o(k),k=1,NBTRGE)
            read (inrad,2001) (dummy_ch4n2o(k),k=1,NBTRGE)
            read (inrad,2001) (dummy_ch4n2o(k),k=1,NBTRGE)
            read (inrad,2001) (dummy_ch4n2o(k),k=1,NBTRGE)
            read (inrad,2001) (dummy_ch4n2o(k),k=1,NBTRGE)
            read (inrad,2001) (fbdlo_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (fbdhi_12001400(k),k=1,NBTRGE)
            exit
          else if (subb < 5) then 

!---------------------------------------------------------------------
!    read data for sub-band number from  data not matching NBTRGE
!---------------------------------------------------------------------
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
            read (inrad,2001) (dummy_ch4n2o(k),k=1,  &
                                          no_h2o12001400bands(subb))
          else

!---------------------------------------------------------------------
!    failure of any sub-band number to match NBTRGE
!---------------------------------------------------------------------
            call error_mesg ('longwave_tables_mod', &
                 'NBTRGE is inconsistent with available data', FATAL)
          endif
        end do
        call close_file(inrad)
      endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      if (trim(Lw_control%linecatalog_form) == 'hitran_1992') then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          NBLY = NBLY_CKD
          call id2h2o ('INPUT/id2h2obdckd2p1')
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          NBLY = NBLY_RSB
          call id2h2o ('INPUT/id2h2obdfull')

!----------------------------------------------------------------------
!  read roberts continuum data for self-broadened h2o continuum
!----------------------------------------------------------------------
          call idrbtsh2o
        endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      else if (trim(Lw_control%linecatalog_form) == 'hitran_2000' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          NBLY = NBLY_CKD
          call id2h2o ('INPUT/h2ocoeff_ckd_0_3000_10cm_hi00')
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          NBLY = NBLY_RSB
          call id2h2o ('INPUT/h2ocoeff_rsb_0_3000_10cm_hi00')

!----------------------------------------------------------------------
!  read roberts continuum data for self-broadened h2o continuum
!----------------------------------------------------------------------
          call idrbtsh2o
        endif
      endif

      allocate  ( acomb(NBLY))
      allocate  ( bcomb(NBLY))
      allocate  ( apcm (NBLY))
      allocate  ( bpcm (NBLY))
      allocate  ( atpcm(NBLY))
      allocate  ( btpcm(NBLY))
      allocate  (bdlocm(NBLY))
      allocate  (bdhicm(NBLY))

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        apwd = apwd_c
        bpwd = bpwd_c
        atpwd = atpwd_c
        btpwd = btpwd_c
        bdlowd = bdlowd_c
        bdhiwd = bdhiwd_c
        iband = iband_c
        acomb = acomb_c
        bcomb = bcomb_c
        apcm = apcm_c
        bpcm = bpcm_c
        atpcm = atpcm_c
        btpcm = btpcm_c
        bdlocm = bdlocm_c
        bdhicm = bdhicm_c
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        apwd = apwd_n
        bpwd = bpwd_n
        atpwd = atpwd_n
        btpwd = btpwd_n
        bdlowd = bdlowd_n
        bdhiwd = bdhiwd_n
        iband = iband_n
        acomb = acomb_n
        bcomb = bcomb_n
        apcm = apcm_n
        bpcm = bpcm_n
        atpcm = atpcm_n
        btpcm = btpcm_n
        bdlocm = bdlocm_n
        bdhicm = bdhicm_n
      endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      call table_alloc (tab1 , NTTABH2O, NUTABH2O)
      call table_alloc (tab2 , NTTABH2O, NUTABH2O)
      call table_alloc (tab3 , NTTABH2O, NUTABH2O)
      call table_alloc (tab1w, NTTABH2O, NUTABH2O)
      if (NBTRGE > 0) then
        call table_alloc (tab1a, NTTABH2O, NUTABH2O, NBTRGE)
        call table_alloc (tab2a, NTTABH2O, NUTABH2O, NBTRGE)
        call table_alloc (tab3a, NTTABH2O, NUTABH2O, NBTRGE)
      endif
      call table_alloc (tabsr, NTTABH2O, NBLY    )

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      call table (tabsr, tab1, tab2, tab3, tab1w, &
                  tab1a, tab2a, tab3a )

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      allocate (Lw_tables%bdlocm(NBLY))
      allocate (Lw_tables%bdhicm(NBLY))
      allocate (Lw_tables%iband (40))
      allocate (Lw_tables%bandlo (NBLW))
      allocate (Lw_tables%bandhi (NBLW))
      Lw_tables%bdlocm = bdlocm
      Lw_tables%bdhicm = bdhicm
      Lw_tables%iband  = iband 
      Lw_tables%bandlo = bandlo
      Lw_tables%bandhi = bandhi

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------
2001  format (5e14.6)
9000  format (5e14.6)

!----------------------------------------------------------------------



end subroutine longwave_tables_init



!#####################################################################


! <SUBROUTINE NAME="longwave_tables_end">
!  <OVERVIEW>
!   Destructor of longwave_tables module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Closes out longwave tables module.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call longwave_tables_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine longwave_tables_end

!--------------------------------------------------------------------
!    longwave_tables_end is the destructor for longwave_tables_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('longwave_tables_mod', &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------

 

end subroutine longwave_tables_end 




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!####################################################################
! <SUBROUTINE NAME="idrbtsh2o">
!  <OVERVIEW>
!   Subroutine to read h2o roberts continuum quantities used in longwave
!   radiation
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine reads h2o roberts continuum quantities used in
!   longwave radiation from an INPUT file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call idrbtsh2o
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine idrbtsh2o

!----------------------------------------------------------------------
!    idrbtsh2o reads h2o roberts continuum quantities used in
!    longwave radiation.
!    author: m. d. schwarzkopf
!    revised: 1/1/96
!    certified:  radiation version 1.0
!----------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      integer   :: inrad  !  unit number for i/o
      integer   :: k      !  do-loop index

!-----------------------------------------------------------------------
!    the following roberts continuum coefficients are computed using the
!    program (gasbnd) over the 0-3000 cm-1 range with 10 cm-1 bandwidth.
!-----------------------------------------------------------------------
      inrad = open_namelist_file ('INPUT/id2h2orbts')
      read (inrad, FMT = '(5e14.6)') (betad(k),k=1,NBLW)
      call close_file (inrad)

!---------------------------------------------------------------------
 
end subroutine idrbtsh2o


!#####################################################################

subroutine id2h2o (filename)

!---------------------------------------------------------------------
!    id2h2o reads h2o random model band parameters used for 
!    longwave radiation
!    references:
!     (1) fels, s. b., and m. d. schwarzkopf, "the simplified exchange
!         approximation: a new method for radiative transfer
!         calculations," journal atmospheric science, 32 (1975),
!         1475-1488.
!    author: m. d. schwarzkopf
!    revised: 1/1/96
!    certified:  radiation version 1.0
!---------------------------------------------------------------------

character(len=*), intent(in)   :: filename

!---------------------------------------------------------------------
!  intent(in) variable:
!
!    filename
!
!---------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      real, dimension (NBLW) :: dummy   ! dummy array

      integer   :: inrad  !  unit number for i/o
      integer   :: k      !  do-loop index

!-----------------------------------------------------------------------
!    the following h2o random band parameters are obtained from the
!    afgl 1992 HITRAN tape. parameters are obtained using an auxi-
!    liary program (gasbnd). values depend on assumptions as to
!    line shape, line strength and width. The inputted values span
!    the 0-3000 cm-1 range, with 10 cm-1 bandwidth. other parameter
!    values used in the program are obtained separately.
!-----------------------------------------------------------------------
      inrad = open_namelist_file (filename)
      read (inrad,9000) (arndm(k),k=1,NBLW)
      read (inrad,9000) (brndm(k),k=1,NBLW)
      read (inrad,9000) (dummy(k),k=1,NBLW)
      read (inrad,9000) (dummy(k),k=1,NBLW)
      read (inrad,9000) (dummy(k),k=1,NBLW)
      read (inrad,9000) (dummy(k),k=1,NBLW)
      read (inrad,9000) (bandlo(k),k=1,NBLW)
      read (inrad,9000) (bandhi(k),k=1,NBLW)
      call close_file (inrad)

!--------------------------------------------------------------------
9000  format(5e14.6)

!--------------------------------------------------------------------


end subroutine id2h2o




!#####################################################################
! <SUBROUTINE NAME="table">
!  <OVERVIEW>
!   Subroutine to compute table entries used in longwave radiation
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine computes the table entries used in longwave radiation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call table  (tabsr, tab1, tab2, tab3, tab1w, tab1a, tab2a, tab3a)
!  </TEMPLATE>
!  <OUT NAME="tabsr" TYPE="longwave_tables3_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab1" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tabs2" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab3" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab1w" TYPE="longwave_tables1_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab1a" TYPE="longwave_tables2_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tabs2a" TYPE="longwave_tables2_type">
!   Contains the tables used in longwave radiation
!  </OUT>
!  <OUT NAME="tab3a" TYPE="longwave_tables2_type">
!   Contains the tables used in longwave radiation
!  </OUT>
! </SUBROUTINE>
!
subroutine table  (tabsr, tab1, tab2, tab3, tab1w, tab1a, tab2a, tab3a)

!---------------------------------------------------------------------
!    table computes table entries used in longwave radiation.  
!    author: m. d. schwarzkopf
!    revised: 1/1/93
!    certified:  radiation version 1.0
!---------------------------------------------------------------------
 
type(longwave_tables3_type), intent(inout)   :: tabsr
type(longwave_tables1_type), intent(inout)   :: tab1, tab2, tab3, tab1w
type(longwave_tables2_type), intent(inout)   :: tab1a, tab2a, tab3a

!----------------------------------------------------------------------
!  intent(inout) variables:
!
!     tabsr
!     tab1
!     tab2
!     tab3
!     tab1w
!     tab1a
!     tab2a
!     tab3a
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (:,:), allocatable   :: r1a, r2a, s2a, t3a,   &
                                              sum4a, sum6a, sum7a, sum8a
      real, dimension(:,:,:),allocatable   :: suma, sumdbea, sum3a 
      real, dimension (NBLW)               :: alfanb, anb, arotnb,   &
                                              betanb, bnb, centnb, delnb
      real, dimension (30)                 :: cnusb, dnusb
      real, dimension (NTTABH2O,NBLW)      :: dbdtnb, src1nb
      real, dimension (NTTABH2O,NBLX)      :: srcwd        
      real, dimension (NTTABH2O, NUTABH2O) :: sumdbe, sum, sum3, sumwde
      real, dimension (NTTABH2O)           :: ddsc, fortcu, r1, r1wd, &
                                              r2, s2, sc, srcs, sum4, &
                                              sum4wd, sum6, sum7, sum8,&
                                              t3, tfour, x, x1, xtemv
      real, dimension (NUTABH2O)           :: expo, fac, x2, zmass, &
                                              zroot
      integer                              :: n, m, ioffset, itab,   &
                                              jtab, nsubds, nsb,  iter
      real                                 :: zmassincr, cent, del,&
                                              bdlo, bdhi, anu, c1,   &
                                              freq_cutoff

!---------------------------------------------------------------------
!  local variables:
!
!    r1a
!    r2a
!    s2a
!    t3a
!    sum4a
!    sum6a
!    sum7a
!    sum8a
!    suma
!    suma
!    sumdbea
!    sum3a
!    ETC. 

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      if (NBTRGE > 0) then
        allocate ( r1a     (NTTABH2O,NBTRGE) )
        allocate (r2a      (NTTABH2O,NBTRGE) )
        allocate (s2a      (NTTABH2O,NBTRGE) )
        allocate ( t3a     (NTTABH2O,NBTRGE) )
        allocate ( suma    (NTTABH2O,NUTABH2O,NBTRGE) )
        allocate ( sumdbea (NTTABH2O,NUTABH2O,NBTRGE) )
        allocate ( sum3a   (NTTABH2O,NUTABH2O,NBTRGE) )
        allocate ( sum4a   (NTTABH2O,NBTRGE) )
        allocate ( sum6a   (NTTABH2O,NBTRGE) )
        allocate ( sum7a   (NTTABH2O,NBTRGE) )
        allocate (sum8a    (NTTABH2O,NBTRGE) )
      endif

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      if (Lw_parameters%offset_iz) then
        ioffset = Lw_parameters%offset
      else
        call error_mesg ('longwave_tables_mod', &
                 ' Lw_parameters%offset not yet defined', FATAL)
      endif

!--------------------------------------------------------------------- 
!     compute local quantities and ao3, bo3, ab15 for narrow bands.
!---------------------------------------------------------------------
      do n=1,NBLW
        anb   (n) = arndm(n) 
        bnb   (n) = brndm(n) 
        centnb(n) = 0.5E+00*(bandlo(n) + bandhi(n)) 
        delnb (n) = bandhi(n) - bandlo(n)
        betanb(n) = betad(n)
      enddo

!---------------------------------------------------------------------
!    compute a*b and sqrt(a*b) for all 10 cm-1 frequency bands.
!---------------------------------------------------------------------
      do n=1,NBLW
        alfanb(n) = bnb(n)*anb(n) 
        arotnb(n) = SQRT(alfanb(n))
      enddo

!-------------------------------------------------------------------
!   define critical frequency (cutoff for wide band ?? )
!------------------------------------------------------------------
      if (NBTRGE > 0) then
        freq_cutoff = 1400.
      else
        freq_cutoff = 1200.
      endif

!---------------------------------------------------------------------
!    begin table computations here.  compute temperatures and masses
!    for table entries.
!    note: the dimensioning and initialization of xtemv and other
!    arrays with dimension of NTTABH2O=28 imply a restriction of model 
!    temperatures from 100k to 370k.
!    the dimensioning of zmass, zroot and other arrays with 
!    dimension of NUTABH2O=181 imply a restriction of model h2o amounts
!    such that optical paths are between 10**-16 and 10**2, in cgs 
!    units (index 2-181), plus zero (index 1).
!---------------------------------------------------------------------
      zmass(1) = 0.0
      zmass(2) = 10.0E+00**mass_1%min_val
      zmassincr = 10.0E+00**mass_1%tab_inc
 
!---------------------------------------------------------------------
!    the definition of zmassincr as 10**0.1 is slightly different from
!    all previous versions, in which it is 1.258925411E+00. This
!    produces slightly different answers (fluxes differ by 1.0e-6 W/m2).
!---------------------------------------------------------------------
      do jtab=3,NUTABH2O
        zmass(jtab) = zmass(jtab-1)*zmassincr
      enddo
      zroot(1) = 0.0
      do jtab=2,NUTABH2O
        zroot(jtab) = SQRT(zmass(jtab))
      enddo 
      do itab=1,NTTABH2O
        xtemv (itab) = temp_1%min_val + temp_1%tab_inc*(itab-1)
        tfour (itab) = xtemv(itab)**4
        fortcu(itab) = 4.0E+00*xtemv(itab)**3
      enddo
      
!---------------------------------------------------------------------
!    the computation of source, dsrce is needed only for the combined 
!    wide band case.  to obtain them,  the source must be computed 
!    for each of the NBLX wide bands srcwd then combined using iband
!    into source.
!---------------------------------------------------------------------
      do n=1,NBLY
        do itab=1,NTTABH2O
          tabsr%vae  (itab,n) = 0.0E+00
        enddo
      enddo
      do n=1,NBLX
        do itab=1,NTTABH2O
          srcwd(itab,n) = 0.0E+00
        enddo
      enddo

!---------------------------------------------------------------------
!    begin frequency loop.
!---------------------------------------------------------------------
      do n=1,NBLX 
  
!---------------------------------------------------------------------
!     the 160-560 cm-1 region
!---------------------------------------------------------------------
        if (n .LE. 40) then
          cent = centnb(n+16) 
          del  = delnb (n+16) 
          bdlo = bandlo(n+16) 
          bdhi = bandhi(n+16) 
 
!---------------------------------------------------------------------
!      the 560-1200 cm-1 region, and the 2270-2380 cm-1 region
!---------------------------------------------------------------------
        else
          cent = 0.5E+00*(bdlocm(n-32+ioffset) + bdhicm(n-32+ioffset))
          del  = bdhicm(n-32+ioffset) - bdlocm(n-32+ioffset)
          bdlo = bdlocm(n-32+ioffset)
          bdhi = bdhicm(n-32+ioffset)
        endif

!---------------------------------------------------------------------
!    for purposes of accuracy, all evaluations of planck functions
!    are made on 10 cm-1 intervals, then summed into the NBLX wide 
!    bands.  the last subband may be narrower than 10 cm-1.
!---------------------------------------------------------------------
        nsubds = (del - 1.0E-03)/10 + 1
        do nsb=1,nsubds 
          if(nsb .NE. nsubds) then 
            cnusb(nsb) = 10.0E+00*(nsb - 1) + bdlo + 5.0E+00
            dnusb(nsb) = 10.0E+00
          else
            cnusb(nsb) = 0.5E+00*(10.0E+00*(nsb - 1) + bdlo + bdhi)
            dnusb(nsb) = bdhi -  (10.0E+00*(nsb - 1) + bdlo)
          endif 
          c1 = 3.7412E-05*cnusb(nsb)**3

!---------------------------------------------------------------------
!    begin temperature loop.
!---------------------------------------------------------------------
          do itab=1,NTTABH2O
            x    (itab)   = 1.4387E+00*cnusb(nsb)/xtemv(itab)
            x1   (itab)   = EXP(x(itab)) 
            srcs (itab)   = c1/(x1(itab) - 1.0E+00)
            srcwd(itab,n) = srcwd(itab,n) + srcs(itab)*dnusb(nsb)
          enddo
        enddo
      enddo

!---------------------------------------------------------------------
!    the following loops create the combined wide band quantities 
!    source and dsrce.  the first 40 bands map to bands 1 to 8 in
!    source and dsrce for the bands in the case of using the rsb
!    continuum . the first 40 bands map to bands 1 to 40 if the
!    band structure for the ckd continuum is used.
!---------------------------------------------------------------------
      do n=1,40
        do itab=1,NTTABH2O 
          tabsr%vae  (itab,iband(n)) = tabsr%vae(itab,iband(n)) +      &
                                  srcwd(itab,n)
        enddo
      enddo
      do n=9+ioffset,NBLY  
        do itab=1,NTTABH2O
          tabsr%vae  (itab,n) = srcwd(itab,n+32-ioffset)
        enddo
      enddo
      do n=1,NBLY
        do itab=1,NTTABH2O-1 
          tabsr%td(itab,n) = (tabsr%vae(itab+1,n) -   &
                      tabsr%vae(itab,n))*0.1E+00
        enddo
      enddo

!---------------------------------------------------------------------
!    first compute planck functions src1nb and derivatives dbdtnb 
!    for use in table evaluations.  these are different from source,
!    dsrce because different frequency points are used in evaluation,
!    the frequency ranges are different, and the derivative algorithm
!    is different.
!---------------------------------------------------------------------
      do n=1,NBLW 
        cent = centnb(n)
        del  = delnb (n)

!---------------------------------------------------------------------
!    note: at present, the iter loop is only used for iter=2.  the 
!    loop structure is kept so that in the future, we may use a
!    quadrature scheme for the planck function evaluation, rather
!    than use the mid-band frequency.
!---------------------------------------------------------------------
        do iter=2,2
          anu = cent + 0.5E+00*(iter - 2)*del 
          c1  = (3.7412E-05)*anu**3
!---------------------------------------------------------------------
!    temperature loop.
!---------------------------------------------------------------------
          do itab=1,NTTABH2O
            x  (itab)      = 1.4387E+00*anu/xtemv(itab)
            x1 (itab)      = EXP(x(itab))
            sc (itab)      = c1/((x1(itab) - 1.0E+00) + 1.0E-20) 
            sc (itab)      = c1/(x1(itab) - 1.0E+00)
            ddsc(itab)     = sc(itab)/(x1(itab)-1.0E+00)*x1(itab)*  &
                             x(itab)/xtemv(itab)
            src1nb(itab,n) = del*sc (itab)
            dbdtnb(itab,n) = del*ddsc(itab)
          enddo
        enddo
      enddo

!---------------------------------------------------------------------
!    next compute r1, r2, s2, and t3 coefficients used for e3 
!    function when the optical path is less than 10**-4.  in this 
!    case, we assume a different dependence on zmass.  also obtain 
!    r1wd, which is r1 summed over the 160-560 cm-1 range.
!---------------------------------------------------------------------
      do itab=1,NTTABH2O
        sum4  (itab) = 0.0E+00
        sum6  (itab) = 0.0E+00
        sum7  (itab) = 0.0E+00
        sum8  (itab) = 0.0E+00
        sum4wd(itab) = 0.0E+00
      enddo

      if (NBTRGE > 0) then
        sum4a (:,:)    = 0.0E+00
        sum6a (:,:)    = 0.0E+00
        sum7a (:,:)    = 0.0E+00
        sum8a (:,:)    = 0.0E+00
      endif

      do n=1,NBLW 
        cent = centnb(n)
!---------------------------------------------------------------------
!#ifndef ch4n2o
!    perform summations for frequency ranges of 0-560, 1200-2200 cm-1 
!#else   ch4n2o
!    perform summations for frequency ranges of 0-560, 1400-2200 cm-1 
!#endif ch4n2o
!---------------------------------------------------------------------
        if (cent .LT. 5.6E+02 .OR. cent .GT. freq_cutoff .AND.   &
            cent .LE. 2.2E+03) then
          do itab=1,NTTABH2O 
            sum4(itab) = sum4(itab) + src1nb(itab,n)
            sum6(itab) = sum6(itab) + dbdtnb(itab,n)
            sum7(itab) = sum7(itab) + dbdtnb(itab,n)*arotnb(n)
            sum8(itab) = sum8(itab) + dbdtnb(itab,n)*alfanb(n)
          enddo
        endif

        if (NBTRGE > 0) then

!---------------------------------------------------------------------
!    perform summations for frequency range of 1200-1400 cm-1
!    for sum4a, sum6a, sum7a, and sum8a. the computation depends
!    on the value of NBTRGE.
!---------------------------------------------------------------------
          if (cent .GT. 1.2E+03 .AND. cent .LE. 1.4E+03) then
            do m=1,NBTRGE
              if (cent .GT. fbdlo_12001400(m) .AND.   &
                  cent .LE. fbdhi_12001400(m)) then
                sum4a(:,m) = sum4a(:,m) + src1nb(:,n)
                sum6a(:,m) = sum6a(:,m) + dbdtnb(:,n)
                sum7a(:,m) = sum7a(:,m) + dbdtnb(:,n)*arotnb(n)
                sum8a(:,m) = sum8a(:,m) + dbdtnb(:,n)*alfanb(n)
              endif
            enddo
          endif
        endif

!---------------------------------------------------------------------
!    perform summations over 160-560 cm-1 frequency range for e1 
!    calculations sum4wd.
!---------------------------------------------------------------------
        if (cent .GT. 1.6E+02 .AND. cent .LT. 5.6E+02) then
          do itab=1,NTTABH2O 
            sum4wd(itab) = sum4wd(itab) + src1nb(itab,n)
          enddo
        endif 
      enddo

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do itab=1,NTTABH2O
        r1(itab)   = sum4(itab)/tfour (itab)
        r2(itab)   = sum6(itab)/fortcu(itab) 
        s2(itab)   = sum7(itab)/fortcu(itab) 
        t3(itab)   = sum8(itab)/fortcu(itab) 
        r1wd(itab) = sum4wd(itab)/tfour(itab)
      enddo

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do jtab=1,NUTABH2O
        do itab=1,NTTABH2O
          sum   (itab,jtab) = 0.0E+00 
          sumdbe(itab,jtab) = 0.0E+00
          sum3  (itab,jtab) = 0.0E+00
          sumwde(itab,jtab) = 0.0E+00
        enddo
      enddo
      if (NBTRGE > 0) then
        do m=1,NBTRGE
          r1a(:,m)   = sum4a(:,m)/tfour(:)
          r2a(:,m)   = sum6a(:,m)/fortcu(:)
          s2a(:,m)   = sum7a(:,m)/fortcu(:)
          t3a(:,m)   = sum8a(:,m)/fortcu(:)
        enddo
        suma   (:,:,:) = 0.0E+00 
        sumdbea(:,:,:) = 0.0E+00
        sum3a  (:,:,:) = 0.0E+00
      endif

!---------------------------------------------------------------------
!    frequency loop begins.
!--------------------------------------------------------------------
      do n=1,NBLW 
        cent = centnb(n)

!---------------------------------------------------------------------
!    perform calculations for frequency ranges of 0-560, 
!#ifndef ch4n2o
!    1200-2200 cm-1.
!#else   ch4n2o
!    1400-2200 cm-1.
!#endif  ch4n2o
!---------------------------------------------------------------------
        if (cent .LT. 5.6E+02 .OR. cent .GT. freq_cutoff .AND.    &
            cent .LE. 2.2E+03) then
          do jtab=1,NUTABH2O 
            x2  (jtab) = arotnb(n)*zroot(jtab) 
            expo(jtab) = EXP( - x2(jtab))
          enddo
          do jtab=122,NUTABH2O
            fac(jtab) = (1.0E+00 - (1.0E+00 + x2(jtab))*expo(jtab))/ &
                        (alfanb(n)*zmass(jtab))
          enddo
          do jtab=1,NUTABH2O 
            do itab=1,NTTABH2O
              sum   (itab,jtab) = sum   (itab,jtab) +   &
                                  src1nb(itab,n)*expo(jtab)
              sumdbe(itab,jtab) = sumdbe(itab,jtab) +    &
                                  dbdtnb(itab,n)*expo(jtab)
            enddo
          enddo 
          do jtab=122,NUTABH2O
            do itab=1,NTTABH2O 
              sum3(itab,jtab) = sum3(itab,jtab) +    &
                                dbdtnb(itab,n)*fac(jtab)
            enddo 
          enddo 
        endif

!-------------------------------------------------------------------
!    perform calculations over the frequency range 1200-1400 cm-1. 
!    the calculations depend on the value of NBTRGE.
!-------------------------------------------------------------------
        if (NBTRGE > 0) then 
          if (cent .GT. 1.2E+03 .AND. cent .LE. 1.4E+03) then
            do m=1,NBTRGE
              if (cent .GT. fbdlo_12001400(m) .AND.   &
                  cent .LE. fbdhi_12001400(m)) then
                x2  (:) = arotnb(n)*zroot(:) 
                expo(:) = EXP( - x2(:))
                do jtab=122,NUTABH2O
                  fac(jtab) = (1.0E+00 - (1.0E+00 + x2(jtab))*  &
                               expo(jtab))/(alfanb(n)*zmass(jtab))
                enddo
                do jtab=1,NUTABH2O 
                  suma(:,jtab,m)    = suma(:,jtab,m) +  &
                                      src1nb(:,n)*expo(jtab)
                  sumdbea(:,jtab,m) = sumdbea(:,jtab,m) +   &
                                      dbdtnb(:,n)*expo(jtab)
                enddo
                do jtab=122,NUTABH2O 
                  sum3a(:,jtab,m)   = sum3a(:,jtab,m) +   &
                                      dbdtnb(:,n)*fac(jtab)
                enddo
              endif
            enddo
          endif
        endif

!---------------------------------------------------------------------
!    compute sum over 160-560 cm-1 range for use in e1 calculations
!    sumwde.
!---------------------------------------------------------------------
        if (cent .GT. 1.6E+02 .AND. cent .LT. 5.6E+02) then 
          do jtab=1,NUTABH2O
            do itab=1,NTTABH2O 
              sumwde(itab,jtab) = sumwde(itab,jtab) +     &
                                  src1nb(itab,n)*expo(jtab)
            enddo
          enddo 
        endif 
      enddo

!--------------------------------------------------------------------
!    frequency loop ends
!--------------------------------------------------------------------
      do jtab=1,NUTABH2O
        do itab=1,NTTABH2O
          tab1%vae      (itab,jtab) = sum(itab,jtab)/tfour(itab)
          tab2%vae(itab,jtab) = sumdbe(itab,jtab)/fortcu(itab)
        enddo 
      enddo
      do jtab=122,NUTABH2O
        do itab=1,NTTABH2O
          tab3%vae(itab,jtab) = sum3(itab,jtab)/fortcu(itab)
        enddo
      enddo
      do jtab=1,3
        do itab=1,NTTABH2O
          tab1%vae      (itab,jtab) = r1(itab)
        enddo
      enddo
      do jtab=1,121
        do itab=1,NTTABH2O
          tab3%vae(itab,jtab) = r2(itab)/2.0E+00 -    &
                                s2(itab)*zroot(jtab)/3.0E+00 +   &
                                t3(itab)*zmass(jtab)/8.0E+00
        enddo
      enddo

!---------------------------------------------------------------------
!    compute e1 tables for 160-560 cm-1 bands.
!---------------------------------------------------------------------
      do jtab=1,NUTABH2O
        do itab=1,NTTABH2O
          tab1w%vae      (itab,jtab) = sumwde(itab,jtab)/tfour(itab)
        enddo
      enddo
      do jtab=1,3
        do itab=1,NTTABH2O
          tab1w%vae      (itab,jtab) = r1wd(itab)
        enddo 
      enddo

!---------------------------------------------------------------------
!    initialize all derivative table entries.
!---------------------------------------------------------------------
      do jtab=1,NUTABH2O
        do itab=1,NTTABH2O
          tab1%td (itab,jtab) = 0.0E+00
          tab1w%td(itab,jtab) = 0.0E+00
          tab2%td  (itab,jtab) = 0.0E+00
          tab3%td (itab,jtab) = 0.0E+00
          tab1%md (itab,jtab) = 0.0E+00
          tab1w%md(itab,jtab) = 0.0E+00
          tab2%md  (itab,jtab) = 0.0E+00
          tab3%md (itab,jtab) = 0.0E+00
          tab1%cd (itab,jtab) = 0.0E+00
          tab1w%cd(itab,jtab) = 0.0E+00
          tab2%cd  (itab,jtab) = 0.0E+00
          tab3%cd (itab,jtab) = 0.0E+00
        enddo
      enddo

!---------------------------------------------------------------------
!    compute table entries for temperature derivatives.
!---------------------------------------------------------------------
      do jtab=1,NUTABH2O
        do itab=1,NTTABH2O-1
          tab1%td  (itab,jtab) =    &
          (tab1%vae(itab+1,jtab) - tab1%vae (itab,jtab))/temp_1%tab_inc

          tab1w%td(itab,jtab) =     &
         (tab1w%vae(itab+1,jtab) - tab1w%vae(itab,jtab))/temp_1%tab_inc

          tab2%td  (itab,jtab) =    &
       (tab2%vae  (itab+1,jtab) - tab2%vae  (itab,jtab))/temp_1%tab_inc

          tab3%td (itab,jtab) =     &
         (tab3%vae (itab+1,jtab) - tab3%vae (itab,jtab))/temp_1%tab_inc

        enddo
      enddo

!---------------------------------------------------------------------
!    compute table entries for mass derivatives.
!---------------------------------------------------------------------
      do jtab=2,NUTABH2O-1
        do itab=1,NTTABH2O
          tab1%md (itab,jtab) =   &
     (tab1%vae (itab,jtab+1) - tab1%vae (itab,jtab))/mass_1%tab_inc

          tab1w%md(itab,jtab) =   &
    (tab1w%vae(itab,jtab+1) - tab1w%vae(itab,jtab))/mass_1%tab_inc

          tab2%md  (itab,jtab) =    &
   (tab2%vae  (itab,jtab+1) - tab2%vae  (itab,jtab))/mass_1%tab_inc

          tab3%md (itab,jtab) =    &
   (tab3%vae (itab,jtab+1) - tab3%vae (itab,jtab))/mass_1%tab_inc

        enddo
      enddo

!---------------------------------------------------------------------
!    compute table entries for cross derivatives.
!---------------------------------------------------------------------
      do jtab=2,NUTABH2O-1
        do itab=1,NTTABH2O-1
      tab1%cd (itab,jtab) =    &
             (tab1%vae (itab+1,jtab+1) - tab1%vae (itab+1,jtab) -   &
              tab1%vae (itab  ,jtab+1) + tab1%vae (itab  ,jtab))/   &
             (temp_1%tab_inc*mass_1%tab_inc)

      tab1w%cd(itab,jtab) =    &
             (tab1w%vae(itab+1,jtab+1) - tab1w%vae(itab+1,jtab) -   &
              tab1w%vae(itab  ,jtab+1) + tab1w%vae(itab  ,jtab))/   &
             (temp_1%tab_inc*mass_1%tab_inc)


!!  THIS NEVER USED :
!     tab2%cd  (itab,jtab) =     &
!            (tab2%vae  (itab+1,jtab+1) - tab2%vae  (itab+1,jtab) -   &
!             tab2%vae  (itab  ,jtab+1) + tab2%vae  (itab  ,jtab))/   &
!            (DTTABH2O*DUTABH2O)
!            (temp_1%tab_inc*mass_1%tab_inc)


      tab3%cd (itab,jtab) =     &
             (tab3%vae (itab+1,jtab+1) - tab3%vae (itab+1,jtab) -   &
              tab3%vae (itab  ,jtab+1) + tab3%vae (itab  ,jtab))/   &
             (temp_1%tab_inc*mass_1%tab_inc)

        enddo
      enddo
      if (NBTRGE > 0) then
        do m=1,NBTRGE
          do jtab=1,NUTABH2O
            tab1a%vae      (:,jtab,m) = suma(:,jtab,m)/tfour(:)
            tab2a%vae (:,jtab,m) = sumdbea(:,jtab,m)/fortcu(:) 
          enddo
          do jtab=122,NUTABH2O
            tab3a%vae(:,jtab,m) = sum3a(:,jtab,m)/fortcu(:)
          enddo
          do jtab=1,3
            tab1a%vae      (:,jtab,m) = r1a(:,m)
          enddo
          do jtab=1,121
            tab3a%vae(:,jtab,m) = r2a(:,m)/2.0E+00 -     &
                                  s2a(:,m)*zroot(jtab)/3.0E+00 +   &
                                  t3a(:,m)*zmass(jtab)/8.0E+00
          enddo
        enddo

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        tab1a%td (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab2a%td  (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab3a%td (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab1a%md (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab2a%md  (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab3a%md (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab1a%cd (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab2a%cd (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00
        tab3a%cd (1:NTTABH2O,1:NUTABH2O,:) = 0.0E+00

        tab1a%td(1:NTTABH2O-1,1:NUTABH2O,:) =    &
                 (tab1a%vae(2:NTTABH2O,1:NUTABH2O,:) -   &
                  tab1a%vae(1:NTTABH2O-1,1:NUTABH2O,:))/temp_1%tab_inc

        tab2a%td (1:NTTABH2O-1,1:NUTABH2O,:) =   &
                (tab2a%vae (2:NTTABH2O,1:NUTABH2O,:) -    &
                 tab2a%vae (1:NTTABH2O-1,1:NUTABH2O,:))/temp_1%tab_inc

        tab3a%td(1:NTTABH2O-1,1:NUTABH2O,:) =    &
                  (tab3a%vae(2:NTTABH2O,1:NUTABH2O,:) -  &
                   tab3a%vae(1:NTTABH2O-1,1:NUTABH2O,:))/temp_1%tab_inc

        tab1a%md(1:NTTABH2O,2:NUTABH2O-1,:) =     &
                  (tab1a%vae(1:NTTABH2O,3:NUTABH2O,:) -   &
                   tab1a%vae(1:NTTABH2O,2:NUTABH2O-1,:))/mass_1%tab_inc

        tab2a%md (1:NTTABH2O,2:NUTABH2O-1,:) =   &
                 (tab2a%vae (1:NTTABH2O,3:NUTABH2O,:) -   &
                  tab2a%vae (1:NTTABH2O,2:NUTABH2O-1,:))/mass_1%tab_inc

        tab3a%md(1:NTTABH2O,2:NUTABH2O-1,:) =     &
                  (tab3a%vae(1:NTTABH2O,3:NUTABH2O,:) -   &
                   tab3a%vae(1:NTTABH2O,2:NUTABH2O-1,:))/mass_1%tab_inc

        tab1a%cd(1:NTTABH2O-1,2:NUTABH2O-1,:) =     &
                        (tab1a%vae(2:NTTABH2O,3:NUTABH2O,:) -    &
                         tab1a%vae(2:NTTABH2O,2:NUTABH2O-1,:)   -  &
                         tab1a%vae(1:NTTABH2O-1,3:NUTABH2O,:)   +  &
                         tab1a%vae(1:NTTABH2O-1,2:NUTABH2O-1,:))/  &
                                         (temp_1%tab_inc*mass_1%tab_inc)

        tab3a%cd(1:NTTABH2O-1,2:NUTABH2O-1,:) =    &
                        (tab3a%vae(2:NTTABH2O,3:NUTABH2O,:) -    &
                         tab3a%vae(2:NTTABH2O,2:NUTABH2O-1,:)   -  &
                         tab3a%vae(1:NTTABH2O-1,3:NUTABH2O,:)   +  &
                         tab3a%vae(1:NTTABH2O-1,2:NUTABH2O-1,:))/  &
                                        (temp_1%tab_inc*mass_1%tab_inc)
     
!---------------------------------------------------------------------
!    deallocate local arrays.
!---------------------------------------------------------------------
        deallocate ( r1a    )
        deallocate (r2a     )
        deallocate (s2a     )
        deallocate ( t3a     )
        deallocate ( suma    )
        deallocate ( sumdbea )
        deallocate ( sum3a   )
        deallocate ( sum4a   )
        deallocate ( sum6a   )
        deallocate ( sum7a   )
        deallocate (sum8a  )
      endif

!-------------------------------------------------------------------


end subroutine table



!####################################################################


                  end module longwave_tables_mod




                  module lw_gases_stdtf_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that computes longwave gas transmission functions
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!

!  shared modules:

use mpp_mod,              only: input_nml_file
use fms_mod,              only: open_namelist_file, fms_init, &
                                mpp_pe, mpp_root_pe, stdlog, &
                                file_exist, write_version_number, &
                                check_nml_error, error_mesg, &
                                FATAL, NOTE, close_file, &
                                open_direct_file
use fms_io_mod,           only: read_data
!  shared radiation package modules:

use rad_utilities_mod,    only: rad_utilities_init, optical_path_type

!  radiation package modules

use gas_tf_mod,           only: gas_tf_init,  &
                                put_co2_stdtf_for_gas_tf, &
                                put_co2_nbltf_for_gas_tf, &
                                put_ch4_stdtf_for_gas_tf, &
                                put_n2o_stdtf_for_gas_tf, &
                                get_control_gas_tf, &
                                process_co2_input_file, &
                                process_ch4_input_file, &
                                process_n2o_input_file

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    lw_gases_stdf_mod computes line-by-line transmission 
!    functions for co2, ch4 and n2o for a usstd temperature 
!    profile and (if needed) that profile +/- 25 degrees, for 
!    the vertical layer structure of the atmospheric model 
!    with surface pressures of 1013.25 hPa and 0.8*1013.25 hPa.
!    options are taken from namelist(s).
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: lw_gases_stdtf.F90,v 17.0.4.1 2010/08/30 20:33:32 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public         &
        lw_gases_stdtf_init, lw_gases_stdtf_time_vary,      &
        ch4_lblinterp, co2_lblinterp, n2o_lblinterp, &
        lw_gases_stdtf_dealloc,  lw_gases_stdtf_end, &
        cfc_exact, cfc_exact_part, cfc_indx8, cfc_indx8_part, &
        cfc_overod, cfc_overod_part

private        &
        std_lblpressures, approx_fn, approx_fn_std, &
        gasins, gasint, coeint, intcoef_1d, intcoef_2d, &
        intcoef_2d_std, interp_error, interp_error_r, &
        pathv1, rctrns, read_lbltfs, allocate_interp_arrays, &
        deallocate_interp_arrays


!---------------------------------------------------------------------
!-------- namelist  ---------

logical    :: do_coeintdiag = .false.
integer    :: NSTDCO2LVLS = 496 ! # of levels at which lbl tfs exist


namelist/lw_gases_stdtf_nml/ &
                                   do_coeintdiag,    &
                                   NSTDCO2LVLS
!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------


real,    dimension (:,:),   allocatable  ::                      &   
                                            pressint_hiv_std_pt1,   & 
                                            pressint_lov_std_pt1,   & 
                                            pressint_hiv_std_pt2,   &
                                            pressint_lov_std_pt2
integer, dimension (:,:),   allocatable  ::                      &   
                                            indx_pressint_hiv_std_pt1, &
                                            indx_pressint_lov_std_pt1, &
                                            indx_pressint_hiv_std_pt2, &
                                            indx_pressint_lov_std_pt2

!--------------------------------------------------------------------
!    xa, ca, dop_core, uexp, sexp are coefficients for
!    the approximation function (Eq. (4) in Ref. (2)) used in
!    the co2 interpolation algorithm. the nomenclature is:
!
!      this code           Ref. (2)
!      ---------           --------
!       xa                  X (see Eq. A1) 
!       ca                  C (see Eq. A1)
!       uexp                delta (see Eq. A6b)
!       sexp                gamma (see Eq. A6c)
!       dop_core            core (see Eq. A6a)
!----------------------------------------------------------------------
real,    dimension (:),     allocatable  :: xa, ca, uexp, sexp, &
                                            press_lo, press_hi
real,    dimension (:,:),   allocatable  :: pressint_hiv_std, &
                                            pressint_lov_std, &
                                            trns_std_hi, &
                                            trns_std_lo
real,    dimension (:,:,:), allocatable  :: trns_std_hi_nf, &
                                            trns_std_lo_nf

!---------------------------------------------------------------------
!   pa          = pressure levels where line-by-line co2 transmission
!                 functions have been calculated
!---------------------------------------------------------------------
real, dimension(:), allocatable   :: pa

!----------------------------------------------------------------------
!    ch4 data
!----------------------------------------------------------------------
integer, parameter                        ::  number_std_ch4_vmrs = 8
real,    dimension(number_std_ch4_vmrs)   ::   ch4_std_vmr
data ch4_std_vmr / 0., 300., 700., 1250., 1750., 2250., 2800., 4000. /

integer, parameter                        ::  nfreq_bands_sea_ch4 = 1

logical, dimension(nfreq_bands_sea_ch4)   ::  do_lyrcalc_ch4_nf, &
                                              do_lvlcalc_ch4_nf, &
                                              do_lvlctscalc_ch4_nf
data   do_lyrcalc_ch4_nf    /  .true.  /
data   do_lvlcalc_ch4_nf    /  .true.  /
data   do_lvlctscalc_ch4_nf /  .false. /

integer, dimension(nfreq_bands_sea_ch4)   ::  ntbnd_ch4
data   ntbnd_ch4      /  3  /

!----------------------------------------------------------------------
!    n2o data
!----------------------------------------------------------------------
integer, parameter                        ::  number_std_n2o_vmrs = 7
real,    dimension(number_std_n2o_vmrs)   ::  n2o_std_vmr
data n2o_std_vmr / 0., 180., 275., 310., 340., 375., 500. /

integer, parameter                        ::  nfreq_bands_sea_n2o = 3
logical, dimension(nfreq_bands_sea_n2o)   ::  do_lyrcalc_n2o_nf, &
                                              do_lvlcalc_n2o_nf, &
                                              do_lvlctscalc_n2o_nf
data do_lyrcalc_n2o_nf    / .true., .true., .true./
data do_lvlcalc_n2o_nf    / .true., .true., .true./
data do_lvlctscalc_n2o_nf / .false., .false., .false./

integer, dimension(nfreq_bands_sea_n2o)   ::  ntbnd_n2o
data ntbnd_n2o /  3, 3, 3/

!----------------------------------------------------------------------
!    co2 data
!----------------------------------------------------------------------
integer, parameter                        ::  number_std_co2_vmrs = 11
real,    dimension(number_std_co2_vmrs)   ::  co2_std_vmr
data co2_std_vmr / 0., 165.0, 300.0, 330.0, 348.0, 356.0, 360.0,  &
                   600.0, 660.0, 1320.0, 1600.0/

integer, parameter                        ::  nfreq_bands_sea_co2 = 5
logical, dimension(nfreq_bands_sea_co2)   ::  do_lyrcalc_co2_nf, &
                                              do_lvlcalc_co2_nf, &
                                              do_lvlctscalc_co2_nf
data do_lyrcalc_co2_nf    / .true., .false., .false., .false., .true./
data do_lvlcalc_co2_nf    / .true., .true., .true., .true., .true./
data do_lvlctscalc_co2_nf / .false., .true., .true., .true., .false./

integer, dimension(nfreq_bands_sea_co2)   ::  ntbnd_co2
data ntbnd_co2 / 3, 3, 3, 3, 1/

real,  dimension (:,:), allocatable   :: dgasdt8_lvl, dgasdt10_lvl, &
                                         d2gast8_lvl, d2gast10_lvl, &
                                         gasp10_lvl, gasp8_lvl,   &  
                                         dgasdt8_lyr, dgasdt10_lyr, &
                                         d2gast8_lyr, d2gast10_lyr, &
                                         gasp10_lyr, gasp8_lyr
real,  dimension (:), allocatable :: dgasdt8_lvlcts, dgasdt10_lvlcts, &
                                     d2gast8_lvlcts, d2gast10_lvlcts, &
                                     gasp10_lvlcts, gasp8_lvlcts

real,  dimension (:,:), allocatable   :: trns_interp_lyr_ps, &
                                         trns_interp_lyr_ps8, &
                                         trns_interp_lvl_ps, &
                                         trns_interp_lvl_ps8
real,  dimension (:,:,:), allocatable :: trns_interp_lyr_ps_nf, &
                                         trns_interp_lyr_ps8_nf, &
                                         trns_interp_lvl_ps_nf, &
                                         trns_interp_lvl_ps8_nf
 
 
real, dimension(:), allocatable  :: plm, plm8, pd, pd8

!!$integer             :: k, kp, nf, nt
integer             :: ndimkp, ndimk, nlev
real, parameter     :: dop_core0 = 25.0
real                :: dop_core 
logical             :: do_calcstdco2tfs
logical             :: do_calcstdch4tfs
logical             :: do_calcstdn2otfs

!--------------------------------------------------------------------
!       NBLWCFC =  number of frequency bands with cfc band strengths
!                  included. The bands have the same frequency ranges
!                  as those used for h2o calculations
!--------------------------------------------------------------------
integer, parameter :: NBLWCFC = 8


!--------------------------------------------------------------------
!   data for averaged f11 band strength
!--------------------------------------------------------------------
real strf11(NBLWCFC) 

data  strf11 /       &
         0.000000E+00,  0.000000E+00,  0.527655E+02,  0.297523E+04,  &
         0.134488E+03,  0.247279E+03,  0.710717E+03,  0.000000E+00/

!--------------------------------------------------------------------
!   data for averaged f12 band strength
!--------------------------------------------------------------------
real strf12(NBLWCFC) 

data strf12 /       &
         0.552499E+01,  0.136436E+03,  0.243867E+02,  0.612532E+03, &
         0.252378E+04,  0.438226E+02,  0.274950E+04,  0.000000E+00/

!--------------------------------------------------------------------
!   data for averaged f113 band strength
!--------------------------------------------------------------------
real strf113(NBLWCFC)

data strf113 /     &
         0.627223E+01,  0.690936E+02,  0.506764E+02,  0.122039E+04,  &
         0.808762E+03,  0.742843E+03,  0.109485E+04,  0.194768E+03/

!--------------------------------------------------------------------
!   data for averaged f22 band strength
!--------------------------------------------------------------------
real strf22(NBLWCFC) 

data strf22 /    &
         0.301881E+02,  0.550826E+01,  0.397496E+03,  0.124802E+04,  &
         0.190285E+02,  0.460065E+02,  0.367359E+04,  0.508838E+03/

!--------------------------------------------------------------------
!   data for averaged f11 560-800 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf1115=0.219856E+02

!--------------------------------------------------------------------
!   data for averaged f12 560-800 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf1215=0.515665E+02

!--------------------------------------------------------------------
!   data for averaged f113 560-800 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf11315=0.430969E+02

!--------------------------------------------------------------------
!   data for averaged f22 560-800 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf2215=0.176035E+03

!--------------------------------------------------------------------
!   data for averaged f11 800-990, 1070-1200 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf11ct=0.125631E+04

!--------------------------------------------------------------------
!   data for averaged f12 800-990, 1070-1200 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf12ct=0.201821E+04

!--------------------------------------------------------------------
!   data for averaged f113 800-990, 1070-1200 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf113ct=0.105362E+04

!--------------------------------------------------------------------
!   data for averaged f22 800-990, 1070-1200 cm-1 band strength
!--------------------------------------------------------------------
real  :: sf22ct=0.188775E+04

integer :: ksrad, kerad
logical   :: module_is_initialized = .false.


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                        contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="lw_gases_stdtf_init">
!  <OVERVIEW>
!   Subroutine to initialize longwave gas transmission function 
!   calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to initialize longwave gas transmission function 
!   calculation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_gases_stdtf_init ( pref)
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!   reference level pressure array
!  </IN>
! </SUBROUTINE>
!
subroutine lw_gases_stdtf_init ( pref)

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------

real,  dimension(:,:), intent(in) :: pref

!--------------------------------------------------------------------
!  intent(in)  variables:
!
!    pref
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      integer :: unit, ierr, io, logunit
      integer :: kmin, kmax, k

!---------------------------------------------------------------------
!  local variables:
!
!    unit
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call gas_tf_init (pref)

!-----------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=lw_gases_stdtf_nml, iostat=io)
      ierr = check_nml_error(io,"lw_gases_stdtf_nml")
#else
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=lw_gases_stdtf_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'lw_gases_stdtf_nml')
        end do
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=lw_gases_stdtf_nml)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      allocate (pd   (size(pref,1)   ))
      allocate (plm  (size(pref,1)  ))
      allocate (pd8  (size(pref,1)  ))
      allocate (plm8 (size(pref,1 ) ))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      kmin = 1
      kmax = size(pref,1) - 1
      pd (:) = pref(:,1)
      pd8(:) = pref(:,2)
      plm (kmin) = 0.
      plm8(kmin) = 0.
      do k=kmin+1,kmax
        plm (k) = 0.5*(pd (k-1) + pd (k))
        plm8(k) = 0.5*(pd8(k-1) + pd8(k))
      enddo
      plm (kmax+1) = pd (kmax+1)
      plm8(kmax+1) = pd8(kmax+1)
      pd = pd*1.0E-02
      pd8 = pd8*1.0E-02
      plm =plm*1.0E-02           
      plm8 = plm8*1.0E-02           

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ksrad = 1
      kerad = kmax

!--------------------------------------------------------------------
!    define the standard pressure levels for use in calculating the 
!    transmission functions.
!--------------------------------------------------------------------- 
      call std_lblpressures

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------


end subroutine lw_gases_stdtf_init



!#####################################################################
! <SUBROUTINE NAME="lw_gases_stdtf_time_vary">
!  <OVERVIEW>
!   Allocate transmission function memory tables
!  </OVERVIEW>
!  <DESCRIPTION>
!   Allocate transmission function memory tables
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_gases_stdtf_time_vary
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine lw_gases_stdtf_time_vary

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!-------------------------------------------------------------------
!    determine if the tfs are to be calculated.
!-------------------------------------------------------------------
      call get_control_gas_tf (calc_co2=do_calcstdco2tfs, &
                               calc_n2o=do_calcstdn2otfs, &
                               calc_ch4=do_calcstdch4tfs)

!-------------------------------------------------------------------
!    define the number of levels being used in the calculation and
!    the dimension extents of the interpolation arrays:
!-------------------------------------------------------------------
      if (do_calcstdco2tfs .or. do_calcstdn2otfs .or.   &
          do_calcstdch4tfs) then
        nlev = KERAD - KSRAD + 1
        ndimkp = nlev + 1
        ndimk  = nlev + 1

!---------------------------------------------------------------------
!    allocate module variables.
!---------------------------------------------------------------------
        allocate (xa          (NSTDCO2LVLS) )
        allocate (ca          (NSTDCO2LVLS) )
        allocate (uexp        (NSTDCO2LVLS) )
        allocate (sexp        (NSTDCO2LVLS) )
        allocate (press_lo    (NSTDCO2LVLS) )
        allocate (press_hi    (NSTDCO2LVLS) )
        allocate (pressint_hiv_std    (NSTDCO2LVLS, NSTDCO2LVLS) )
        allocate (pressint_lov_std    (NSTDCO2LVLS, NSTDCO2LVLS) )
        allocate (trns_std_hi         (NSTDCO2LVLS, NSTDCO2LVLS) )
        allocate (trns_std_lo         (NSTDCO2LVLS, NSTDCO2LVLS) )
        allocate (trns_std_hi_nf      (NSTDCO2LVLS, NSTDCO2LVLS, 3) )
        allocate (trns_std_lo_nf      (NSTDCO2LVLS, NSTDCO2LVLS, 3) )

        allocate ( trns_interp_lyr_ps(KSRAD:KERAD+1, KSRAD:KERAD+1) )
        allocate ( trns_interp_lyr_ps8(KSRAD:KERAD+1, KSRAD:KERAD+1) )
        allocate ( trns_interp_lvl_ps(KSRAD:KERAD+1, KSRAD:KERAD+1) )
        allocate ( trns_interp_lvl_ps8(KSRAD:KERAD+1, KSRAD:KERAD+1) )

        allocate (trns_interp_lyr_ps_nf(KSRAD:KERAD+1,KSRAD:KERAD+1,3) )
        allocate (trns_interp_lyr_ps8_nf(KSRAD:KERAD+1,KSRAD:KERAD+1,3))
        allocate (trns_interp_lvl_ps_nf(KSRAD:KERAD+1,KSRAD:KERAD+1,3) )
        allocate (trns_interp_lvl_ps8_nf(KSRAD:KERAD+1,KSRAD:KERAD+1,3))

        allocate (  dgasdt8_lvl (KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  dgasdt10_lvl(KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  d2gast8_lvl (KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  d2gast10_lvl(KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  gasp10_lvl(KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  gasp8_lvl (KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  dgasdt8_lvlcts (KSRAD:KERAD+1) )
        allocate (  dgasdt10_lvlcts(KSRAD:KERAD+1) )
        allocate (  d2gast8_lvlcts (KSRAD:KERAD+1) )
        allocate (  d2gast10_lvlcts(KSRAD:KERAD+1) )
        allocate (  gasp10_lvlcts(KSRAD:KERAD+1) )
        allocate (  gasp8_lvlcts (KSRAD:KERAD+1) )
        allocate (  dgasdt8_lyr (KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  dgasdt10_lyr(KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  d2gast8_lyr (KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  d2gast10_lyr(KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  gasp10_lyr(KSRAD:KERAD+1,KSRAD:KERAD+1) )
        allocate (  gasp8_lyr (KSRAD:KERAD+1,KSRAD:KERAD+1) )
      endif

!------------------------------------------------------------------


end subroutine lw_gases_stdtf_time_vary



!###################################################################
! <SUBROUTINE NAME="ch4_lblinterp">
!  <OVERVIEW>
!   Subroutine to interpolate ch4 transmission function to user
!   specified pressure levels and ch4 concentration
!  </OVERVIEW>
!  <DESCRIPTION>
!   this routine is 1) a standalone program for a ch4 interpolation
!     to user-specified pressure levels and ch4 concentration;
!     2) an interface between a GCM and ch4 interpolation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ch4_lblinterp (ch4_vmr)
!  </TEMPLATE>
!  <IN NAME="ch4_vmr" TYPE="real">
!   ch4 volume mixing ratio
!  </IN>
! </SUBROUTINE>
!
subroutine ch4_lblinterp (ch4_vmr)

!-----------------------------------------------------------------
!    ch4_lblinterp is 
!    1) a standalone program for a ch4 interpolation
!       to user-specified pressure levels and ch4 concentration;
!    2) an interface between a GCM and ch4 interpolation
!
!    input files:
!
!         1)     : gas transmission function at higher of 2 
!                  standard mixing ratios, for a specified frequency
!                  range, determined by choice of (ch4_vmr).
!         2)     : gas transmission function at higher of 2 
!                  standard mixing ratios, for a specified frequency
!                  range, determined by choice of (ch4_vmr). may not be
!                  used, depending on value of (ch4_vmr).
!
!    output files:
!
!         id2,   : interpolated gas transmission fctns and derivatives
!       id2nb      saved in format suitable as input to operational
!                  radiation program, for the desired gas mixing ratio
!                  and frequency range. The number of records will
!                  vary, depending on the frequency range. these 
!                  files are created if ifdef (writeinterpch4) is
!                  on. otherwise, it is assumed the data is fed
!                 directly back to the parent model.
!-----------------------------------------------------------------

real,              intent(in)  :: ch4_vmr

!-----------------------------------------------------------------
!  intent(in) variables:
!
!     ch4_vmr
!
!-----------------------------------------------------------------

        
!---------------------------------------------------------------------
!  local variables:

      logical                   ::  callrctrns_ch4
      logical                   ::  do_lyrcalc_ch4
      logical                   ::  do_lvlcalc_ch4
      logical                   ::  do_lvlctscalc_ch4
      integer                   ::  n, nf, nt
      real                      ::  ch4_std_lo, ch4_std_hi
      integer                   ::  nstd_ch4_lo, nstd_ch4_hi
      character(len=8)          ::  gas_type = 'ch4'

!---------------------------------------------------------------------
!  local variables:
!
!     callrctrns_ch4
!
!---------------------------------------------------------------------
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!    this routine does nothing unless the calculation of tfs is desired.
!---------------------------------------------------------------------
      if (do_calcstdch4tfs) then

!--------------------------------------------------------------------
!    using the value of the ch4 volume mixing ratio (ch4_vmr) and
!    the available standard ch4 mixing ratios (with lbl 
!    transmission functions) obtain the two standard mixing ratios
!    which bracket (ch4_vmr). if (as in a fixed ch4 experiment) the
!    difference between (ch4_vmr) and the higher of the standard
!    mixing ratios is less than a tolerance (taken as 0.1 ppbv)
!    we will assume that that standard ch4 transmissivity applies
!    to (ch4_vmr) without interpolation. otherwise, interpolation
!    to (ch4_vmr) will be performed, in rctrns.F
!--------------------------------------------------------------------
        if (ch4_vmr .LT. ch4_std_vmr(1) .OR.               &
            ch4_vmr .GT. ch4_std_vmr(number_std_ch4_vmrs)) then
          call error_mesg ('lw_gases_stdtf_mod', &
                     'ch4 volume mixing ratio is out of range', FATAL)
        endif

        if (ch4_vmr .EQ. ch4_std_vmr(1)) then
          ch4_std_lo = ch4_std_vmr(1)
          ch4_std_hi = ch4_std_vmr(1)
          nstd_ch4_lo = 1
          nstd_ch4_hi = 1
        else 
          do n=1,number_std_ch4_vmrs-1
            if (ch4_vmr .GT. ch4_std_vmr(n) .AND.            &
                ch4_vmr .LE. ch4_std_vmr(n+1)) then
              ch4_std_lo = ch4_std_vmr(n)
              ch4_std_hi = ch4_std_vmr(n+1)
              nstd_ch4_lo = n
              nstd_ch4_hi = n+1
              exit
            endif
          enddo
        endif

!--------------------------------------------------------------------
!    ch4_std_lo, nstd_ch4_lo have arbitrary definitions, since they
!    will not be used, as callrctrns will be false in this case.
!--------------------------------------------------------------------
        if (ABS(ch4_vmr - ch4_std_hi) .LE. 1.0e-1) then
          callrctrns_ch4 = .false.
        else
          callrctrns_ch4 = .true.
        endif

!-------------------------------------------------------------------
!    allocate pressure, index arrays used in rctrns (if needed)
!-------------------------------------------------------------------
        if (callrctrns_ch4) then
          call allocate_interp_arrays
        endif
 
!---------------------------------------------------------------------
!    loop on frequency bands. in the 1996 SEA formulation, there are
!    1 frequency ranges for lbl ch4 transmissions:
!    nf = 1:  lbl transmissions over 1200-1400 cm-1    
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!    read in ch4 transmissivities at this point-----
!    data is read for all temperature profiles required for the
!    frequency band (at 1 or 2 appropriate concentrations). the 
!    number of temperature profiles for band (nf) is ntbnd(nf).
!    in the 1996 SEA formulation, the profiles required are 3 
!    (USSTD,1976; USSTD,1976 +- 25).
!----------------------------------------------------------------------
        do nf = 1,nfreq_bands_sea_ch4
          call read_lbltfs ('ch4', callrctrns_ch4, nstd_ch4_lo, &
                            nstd_ch4_hi, nf, ntbnd_ch4, & 
                            trns_std_hi_nf, trns_std_lo_nf )
          do_lyrcalc_ch4    = do_lyrcalc_ch4_nf(nf)
          do_lvlcalc_ch4    = do_lvlcalc_ch4_nf(nf)
          do_lvlctscalc_ch4 = do_lvlctscalc_ch4_nf(nf)
 
!---------------------------------------------------------------------
!    load in appropriate ch4 transmission functions
!---------------------------------------------------------------------
          if (ch4_vmr /= 0.0) then
          do nt = 1,ntbnd_ch4(nf)   ! temperature structure loop.
            trns_std_hi(:,:) = trns_std_hi_nf(:,:,nt)
            if (callrctrns_ch4) then
              trns_std_lo(:,:) = trns_std_lo_nf(:,:,nt)
            endif
            call gasint(gas_type,           &
                        ch4_vmr, ch4_std_lo, ch4_std_hi,   &
                        callrctrns_ch4,   &
                        do_lvlcalc_ch4, do_lvlctscalc_ch4,    &
                        do_lyrcalc_ch4, nf, nt)
            trns_interp_lyr_ps_nf(:,:,nt) = trns_interp_lyr_ps(:,:)
            trns_interp_lyr_ps8_nf(:,:,nt) = trns_interp_lyr_ps8(:,:)
            trns_interp_lvl_ps_nf(:,:,nt) = trns_interp_lvl_ps(:,:)
            trns_interp_lvl_ps8_nf(:,:,nt) = trns_interp_lvl_ps8(:,:)
          enddo   ! temperature structure loop
       endif
 
!--------------------------------------------------------------------
!    perform final processing for each frequency band.
!--------------------------------------------------------------------
          if (ch4_vmr /= 0.0) then
          call gasins(gas_type, do_lvlcalc_ch4, do_lvlctscalc_ch4,   &
                      do_lyrcalc_ch4, nf, ntbnd_ch4(nf), ndimkp, ndimk,&
                      dgasdt10_lvl, dgasdt10_lvlcts, dgasdt10_lyr,   &
                      gasp10_lvl, gasp10_lvlcts, gasp10_lyr,   &
                      d2gast10_lvl, d2gast10_lvlcts, d2gast10_lyr,   &
                      dgasdt8_lvl,  dgasdt8_lvlcts,  dgasdt8_lyr ,   &
                      gasp8_lvl,  gasp8_lvlcts,  gasp8_lyr ,   &
                      d2gast8_lvl,  d2gast8_lvlcts,  d2gast8_lyr )
 
         else
!---------------------------------------------------------------------
!    define arrays for the SEA module. the SEA model nomenclature
!    has been used here and the values of do_lvlcalc, do_lvlctscalc,
!    and do_lyrcalc are assumed to be from the data statement.
!---------------------------------------------------------------------
!15
           gasp10_lyr = 1.0 
           gasp8_lyr = 1.0 
           dgasdt10_lyr = 0.0
           dgasdt8_lyr = 0.0
           d2gast10_lyr = 0.0
           d2gast8_lyr = 0.0
         endif
          call put_ch4_stdtf_for_gas_tf (gasp10_lyr, gasp8_lyr,    &
                                         dgasdt10_lyr, dgasdt8_lyr,  &
                                         d2gast10_lyr,  d2gast8_lyr)
        enddo  !  frequency band loop

!--------------------------------------------------------------------
!    deallocate pressure, index arrays used in rctrns (if needed)
!--------------------------------------------------------------------
        if (callrctrns_ch4) then
          call deallocate_interp_arrays
        endif

!-----------------------------------------------------------------
!    pass necessary data to gas_tf in case stdtf file is to be written
!-----------------------------------------------------------------
        call process_ch4_input_file (gas_type, ch4_vmr, NSTDCO2LVLS, &
                                     KSRAD, KERAD, pd, plm, pa)

!---------------------------------------------------------------------
!    if not calculating tfs, read them in
!---------------------------------------------------------------------
      else                                      
        call process_ch4_input_file (gas_type, ch4_vmr, NSTDCO2LVLS, &
                                     KSRAD, KERAD, pd, plm, pa)

      endif   ! (do_calcstdch4tfs)

!-------------------------------------------------------------------
 
 
end subroutine ch4_lblinterp



!####################################################################
! <SUBROUTINE NAME="co2_lblinterp">
!  <OVERVIEW>
!   Subroutine to interpolate co2 transmission function to user
!   specified pressure levels and co2 concentration
!  </OVERVIEW>
!  <DESCRIPTION>
!   this routine is 1) a standalone program for a co2 interpolation
!     to user-specified pressure levels and co2 concentration;
!     2) an interface between a GCM and co2 interpolation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call co2_lblinterp (co2_vmr)
!  </TEMPLATE>
!  <IN NAME="co2_vmr" TYPE="real">
!   co2 volume mixing ratio
!  </IN>
! </SUBROUTINE>
!
      subroutine co2_lblinterp (co2_vmr         )

!--------------------------------------------------------------------
!    this routine is 
!    1) a standalone program for a co2 interpolation
!       to user-specified pressure levels and co2 concentration;
!    2) an interface between a GCM and co2 interpolation
!
!    input files:
!
!         1)     : gas transmission function at higher of 2 
!                  standard mixing ratios, for a specified frequency
!                  range, determined by choice of (co2_vmr).
!         2)     : gas transmission function at higher of 2 
!                  standard mixing ratios, for a specified frequency
!                  range, determined by choice of (co2_vmr). may not be
!                  used, depending on value of (co2_vmr).
!
!    output files:
!
!         id2,   : interpolated gas transmission fctns and derivatives
!       id2nb      saved in format suitable as input to operational
!                  radiation program, for the desired gas mixing ratio
!                  and frequency range. The number of records will
!                  vary, depending on the frequency range. these 
!                  files are created if ifdef (writeinterpco2) is
!                  on. otherwise, it is assumed the data is fed
!                  directly back to the parent model.
!--------------------------------------------------------------------

real,             intent(in)     ::  co2_vmr

!--------------------------------------------------------------------
!  intent(in) variables:
!
!    co2_vmr
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables
      logical              ::  callrctrns_co2
      logical              ::  do_lyrcalc_co2
      logical              ::  do_lvlcalc_co2
      logical              ::  do_lvlctscalc_co2
      integer              ::  n, nf, nt
      real                 ::  co2_std_lo, co2_std_hi
      integer              ::  nstd_co2_lo, nstd_co2_hi
      character(len=8)     ::  gas_type = 'co2'

!---------------------------------------------------------------------
!  local variables
!
!     callrctrns_co2
!
!---------------------------------------------------------------------
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod',   &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!    this routine does nothing unless the calculation of tfs is desired.
!---------------------------------------------------------------------
      if (do_calcstdco2tfs) then

!--------------------------------------------------------------------
!    using the value of the co2 volume mixing ratio (co2_vmr) and
!    the available standard co2 mixing ratios (with lbl 
!    transmission functions) obtain the two standard mixing ratios
!    which bracket (co2_vmr). if (as in a fixed co2 experiment) the
!    difference between (co2_vmr) and the higher of the standard
!    mixing ratios is less than a tolerance (taken as .0001 ppmv)
!    we will assume that that standard co2 transmissivity applies
!    to (co2_vmr) without interpolation. otherwise, interpolation
!    to (co2_vmr) will be performed, in rctrns.F
!--------------------------------------------------------------------- 
        if (co2_vmr .LT. co2_std_vmr(1) .OR.                     &
          co2_vmr .GT. co2_std_vmr(number_std_co2_vmrs)) then
          call error_mesg ('lw_gases_stdtf_mod', &
                'co2 volume mixing ratio is out of range', FATAL)
        endif

        if (co2_vmr .EQ. co2_std_vmr(1)) then
          co2_std_lo = co2_std_vmr(1)
          co2_std_hi = co2_std_vmr(1)
          nstd_co2_lo = 1
          nstd_co2_hi = 1
        else 
          do n=1,number_std_co2_vmrs-1
            if ( co2_vmr .GT. co2_std_vmr(n) .AND.                 &  
                 co2_vmr .LE. co2_std_vmr(n+1)) then
              co2_std_lo = co2_std_vmr(n)
              co2_std_hi = co2_std_vmr(n+1)
              nstd_co2_lo = n
              nstd_co2_hi = n+1
              exit
            endif
          enddo
        endif 

!-------------------------------------------------------------------
!    co2_std_lo, nstd_co2_lo have arbitrary definitions, since they
!    will not be used, as callrctrns will be false in this case.
!-------------------------------------------------------------------
        if (ABS(co2_vmr - co2_std_hi) .LE. 1.0e-4) then
          callrctrns_co2 = .false.
        else
          callrctrns_co2 = .true.
        endif

!-------------------------------------------------------------------
!    allocate pressure, index arrays used in rctrns (if needed)
!-------------------------------------------------------------------
        if (callrctrns_co2) then
          call allocate_interp_arrays
        endif

!--------------------------------------------------------------------
!    loop on frequency bands. in the 1996 SEA formulation, there are
!    5 frequency ranges for lbl co2 transmissions:
!    nf = 1:  lbl transmissions over 490-850 cm-1    
!    nf = 2:  lbl transmissions over 490-630 cm-1    
!    nf = 3:  lbl transmissions over 630-700 cm-1    
!    nf = 4:  lbl transmissions over 700-800 cm-1    
!    nf = 5:  lbl transmissions over 2270-2380 cm-1    
!---------------------------------------------------------------------
        do nf = 1,nfreq_bands_sea_co2
 
!---------------------------------------------------------------------
!    read in co2 transmissivities at this point-----
!    data is read for all temperature profiles required for the
!    frequency band (at 1 or 2 appropriate concentrations). the 
!    number of temperature profiles for band (nf) is ntbnd_co2(nf).
!    in the 1996 SEA formulation, the profiles required are 3 
!    (USSTD,1976; USSTD,1976 +- 25) except for the 4.3 um band (nf=2)
!    where the number is one.
!---------------------------------------------------------------------
          call read_lbltfs('co2',                               &
                           callrctrns_co2, nstd_co2_lo, nstd_co2_hi,  &
                           nf, ntbnd_co2,                          &
                           trns_std_hi_nf, trns_std_lo_nf )
 
          do_lyrcalc_co2 = do_lyrcalc_co2_nf(nf)
          do_lvlcalc_co2 = do_lvlcalc_co2_nf(nf)
          do_lvlctscalc_co2 = do_lvlctscalc_co2_nf(nf)
 
!--------------------------------------------------------------------
!    load in appropriate co2 transmission functions
!--------------------------------------------------------------------
        if (co2_vmr /= 0.0) then
          do nt = 1,ntbnd_co2(nf)    !  temperature structure loop.
            trns_std_hi(:,:) = trns_std_hi_nf(:,:,nt)
            if (callrctrns_co2) then
              trns_std_lo(:,:) = trns_std_lo_nf(:,:,nt)
            endif
    
            call gasint(         & 
                        gas_type,        &
                        co2_vmr, co2_std_lo, co2_std_hi,      &
                        callrctrns_co2,                             & 
                        do_lvlcalc_co2, do_lvlctscalc_co2,    &
                        do_lyrcalc_co2,   &
                        nf, nt)
 
            trns_interp_lyr_ps_nf(:,:,nt) = trns_interp_lyr_ps(:,:)
            trns_interp_lyr_ps8_nf(:,:,nt) = trns_interp_lyr_ps8(:,:)
            trns_interp_lvl_ps_nf(:,:,nt) = trns_interp_lvl_ps(:,:)
            trns_interp_lvl_ps8_nf(:,:,nt) = trns_interp_lvl_ps8(:,:)
          enddo        !  temperature structure loop
 
        endif
!--------------------------------------------------------------------
!    perform final processing for each frequency band.
!--------------------------------------------------------------------
        if (co2_vmr /= 0.0) then
          call gasins('co2',                                 &
                      do_lvlcalc_co2, do_lvlctscalc_co2,    &
                      do_lyrcalc_co2, &
                      nf, ntbnd_co2(nf),                            & 
                      ndimkp,ndimk,                                 & 
                      dgasdt10_lvl, dgasdt10_lvlcts, dgasdt10_lyr,   & 
                      gasp10_lvl, gasp10_lvlcts, gasp10_lyr,        & 
                      d2gast10_lvl, d2gast10_lvlcts, d2gast10_lyr,   & 
                      dgasdt8_lvl,  dgasdt8_lvlcts,  dgasdt8_lyr ,    & 
                      gasp8_lvl,  gasp8_lvlcts,  gasp8_lyr ,        & 
                      d2gast8_lvl,  d2gast8_lvlcts,  d2gast8_lyr )
        else
          dgasdt10_lvl = 0.
          dgasdt10_lvlcts  = 0.
          dgasdt10_lyr = 0.
          gasp10_lvl  = 1.
          gasp10_lvlcts = 1.
          gasp10_lyr = 1.
          d2gast10_lvl = 0.
          d2gast10_lvlcts   = 0.
          d2gast10_lyr = 0.
          dgasdt8_lvl = 0.
          dgasdt8_lvlcts = 0.
          dgasdt8_lyr      = 0.
          gasp8_lvl  = 1.
          gasp8_lvlcts  = 1.
          gasp8_lyr  = 1.
          d2gast8_lvl  = 0.
          d2gast8_lvlcts  = 0.
          d2gast8_lyr = 0.
        endif
 
!--------------------------------------------------------------------
!    define arrays for the SEA module. the SEA model nomenclature
!    has been used here and the values of do_lvlcalc, do_lvlctscalc,
!    and do_lyrcalc are assumed to be from the data statement.
!----------------------------------------------------------------------
          if (nf == 1 .or. nf == 5) then
            call put_co2_stdtf_for_gas_tf (nf, gasp10_lyr, gasp8_lyr, &
                                           dgasdt10_lyr, dgasdt8_lyr, &
                                           d2gast10_lyr,  d2gast8_lyr)
          endif
          if (nf <= 4) then
            call put_co2_nbltf_for_gas_tf (nf, gasp10_lvl,   &
                                           dgasdt10_lvl, d2gast10_lvl, &
                                           gasp8_lvl, dgasdt8_lvl,  &
                                           d2gast8_lvl, gasp10_lvlcts, &
                                           gasp8_lvlcts,&
                                           dgasdt10_lvlcts,  &
                                           dgasdt8_lvlcts,&
                                           d2gast10_lvlcts, &
                                           d2gast8_lvlcts)
          endif 
        enddo  ! frequency band loop

!-----------------------------------------------------------------
!    deallocate pressure, index arrays used in rctrns (if needed)
!-----------------------------------------------------------------
        if (callrctrns_co2) then
          call deallocate_interp_arrays
        endif

!-----------------------------------------------------------------
!    pass necessary data to gas_tf in case stdtf file is to be written
!-----------------------------------------------------------------
        call process_co2_input_file (gas_type, co2_vmr, NSTDCO2LVLS, &
                                     KSRAD, KERAD, pd, plm, pa)

!---------------------------------------------------------------------
!    if not calculating tfs, read them in
!---------------------------------------------------------------------
      else                                    
        call process_co2_input_file (gas_type, co2_vmr, NSTDCO2LVLS, &
                                     KSRAD, KERAD, pd, plm, pa)
      endif    !   (do_calcstdco2tfs)

!-------------------------------------------------------------------



end subroutine co2_lblinterp



!#####################################################################
! <SUBROUTINE NAME="n2o_lblinterp">
!  <OVERVIEW>
!   Subroutine to interpolate n2o transmission function to user
!   specified pressure levels and n2o concentration
!  </OVERVIEW>
!  <DESCRIPTION>
!   this routine is 1) a standalone program for a n2o interpolation
!     to user-specified pressure levels and n2o concentration;
!     2) an interface between a GCM and n2o interpolation
!  </DESCRIPTION>
!  <TEMPLATE>
!   call n2o_lblinterp (n2o_vmr)
!  </TEMPLATE>
!  <IN NAME="n2o_vmr" TYPE="real">
!   n2o volume mixing ratio
!  </IN>
! </SUBROUTINE>
!
subroutine n2o_lblinterp (n2o_vmr)

!---------------------------------------------------------------------
!    n2o_lblinterp is 
!    1) a standalone program for a n2o interpolation
!       to user-specified pressure levels and n2o concentration;
!    2) an interface between a GCM and n2o interpolation
!
!    input files:
!
!         1)     : gas transmission function at higher of 2 
!                  standard mixing ratios, for a specified frequency
!                  range, determined by choice of (n2o_vmr).
!         2)     : gas transmission function at higher of 2 
!                  standard mixing ratios, for a specified frequency
!                  range, determined by choice of (n2o_vmr). may not be
!                  used, depending on value of (n2o_vmr).
!
!    output files:
!
!         id2,   : interpolated gas transmission fctns and derivatives
!       id2nb      saved in format suitable as input to operational
!                  radiation program, for the desired gas mixing ratio
!                  and frequency range. The number of records will
!                  vary, depending on the frequency range. these 
!                  files are created if ifdef (writeinterpn2o) is
!                  on. otherwise, it is assumed the data is fed
!                 directly back to the parent model.
!---------------------------------------------------------------------

real,             intent(in)   :: n2o_vmr

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     n2o_vmr
!
!--------------------------------------------------------------------
        
!--------------------------------------------------------------------
!    local variables

      logical                   ::  callrctrns_n2o
      logical                   ::  do_lyrcalc_n2o
      logical                   ::  do_lvlcalc_n2o
      logical                   ::  do_lvlctscalc_n2o
      integer                   ::  n, nf, nt
      real                      ::  n2o_std_lo, n2o_std_hi
      integer                   ::  nstd_n2o_lo, nstd_n2o_hi
      character(len=8)          ::  gas_type = 'n2o'

!--------------------------------------------------------------------
!    local variables
!
!      callrctrns_n2o
!
!---------------------------------------------------------------------
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!    this routine does nothing unless the calculation of tfs is desired.
!---------------------------------------------------------------------
      if (do_calcstdn2otfs) then

!--------------------------------------------------------------------
!    using the value of the n2o volume mixing ratio (n2o_vmr) and
!    the available standard n2o mixing ratios (with lbl 
!    transmission functions) obtain the two standard mixing ratios
!    which bracket (n2o_vmr). if (as in a fixed n2o experiment) the
!    difference between (n2o_vmr) and the higher of the standard
!    mixing ratios is less than a tolerance (taken as 0.1 ppbv)
!    we will assume that that standard n2o transmissivity applies
!    to (n2o_vmr) without interpolation. otherwise, interpolation
!    to (n2o_vmr) will be performed, in rctrns.F
!---------------------------------------------------------------------
        if (n2o_vmr .LT. n2o_std_vmr(1) .OR.     &
             n2o_vmr .GT. n2o_std_vmr(number_std_n2o_vmrs)) then
          call error_mesg ('lw_gases_stdtf_mod', &
               'n2o volume mixing ratio is out of range', FATAL)
        endif

        if (n2o_vmr .EQ. n2o_std_vmr(1)) then
          n2o_std_lo = n2o_std_vmr(1)
          n2o_std_hi = n2o_std_vmr(1)
          nstd_n2o_lo = 1
          nstd_n2o_hi = 1
        else 
          do n=1,number_std_n2o_vmrs-1
            if ( n2o_vmr .GT. n2o_std_vmr(n) .AND.               &
                 n2o_vmr .LE. n2o_std_vmr(n+1)) then
              n2o_std_lo = n2o_std_vmr(n)
              n2o_std_hi = n2o_std_vmr(n+1)
              nstd_n2o_lo = n
              nstd_n2o_hi = n+1
              exit
            endif
          enddo
        endif

!-------------------------------------------------------------------
!    n2o_std_lo, nstd_n2o_lo have arbitrary definitions, since they
!    will not be used, as callrctrns will be false in this case.
!-------------------------------------------------------------------
        if (ABS(n2o_vmr - n2o_std_hi) .LE. 1.0e-1) then
          callrctrns_n2o = .false.
        else
         callrctrns_n2o = .true.
        endif
 
!--------------------------------------------------------------------
!    allocate pressure, index arrays used in rctrns (if needed)
!--------------------------------------------------------------------
        if (callrctrns_n2o) then
          call allocate_interp_arrays
        endif
 
!---------------------------------------------------------------------
!    loop on frequency bands. in the 1996 SEA formulation, there are
!    3 frequency ranges for lbl n2o transmissions:
!    nf = 1:  lbl transmissions over 1200-1400 cm-1    
!    nf = 2:  lbl transmissions over 1070-1200 cm-1    
!    nf = 3:  lbl transmissions over 560-630 cm-1    
!---------------------------------------------------------------------

        do nf = 1,nfreq_bands_sea_n2o
 
!---------------------------------------------------------------------
!    read in n2o transmissivities at this point-----
!    data is read for all temperature profiles required for the
!    frequency band (at 1 or 2 appropriate concentrations). the 
!    number of temperature profiles for band (nf) is ntbnd(nf).
!    in the 1996 SEA formulation, the profiles required are 3 
!    (USSTD,1976; USSTD,1976 +- 25).
!----------------------------------------------------------------------
         call read_lbltfs('n2o',                                    &   
                         callrctrns_n2o, nstd_n2o_lo, nstd_n2o_hi, nf,&
                         ntbnd_n2o,                             &
                         trns_std_hi_nf, trns_std_lo_nf )
          do_lyrcalc_n2o = do_lyrcalc_n2o_nf(nf)
          do_lvlcalc_n2o = do_lvlcalc_n2o_nf(nf)
          do_lvlctscalc_n2o = do_lvlctscalc_n2o_nf(nf)
 
!----------------------------------------------------------------------
!    load in appropriate n2o transmission functions
!----------------------------------------------------------------------
          if (n2o_vmr /= 0.0) then
          do nt = 1,ntbnd_n2o(nf) ! temperature structure loop
            trns_std_hi(:,:) = trns_std_hi_nf(:,:,nt)
            if (callrctrns_n2o) then
              trns_std_lo(:,:) = trns_std_lo_nf(:,:,nt)
            endif
            call gasint(gas_type, n2o_vmr, n2o_std_lo, n2o_std_hi,    &
                        callrctrns_n2o,     &
                        do_lvlcalc_n2o, do_lvlctscalc_n2o,    &
                        do_lyrcalc_n2o, nf, nt)
            trns_interp_lyr_ps_nf(:,:,nt) = trns_interp_lyr_ps(:,:)
            trns_interp_lyr_ps8_nf(:,:,nt) = trns_interp_lyr_ps8(:,:)
            trns_interp_lvl_ps_nf(:,:,nt) = trns_interp_lvl_ps(:,:)
            trns_interp_lvl_ps8_nf(:,:,nt) = trns_interp_lvl_ps8(:,:)
          enddo    ! temperature structure loop
        endif 

!--------------------------------------------------------------------
!    perform final processing for each frequency band.
!--------------------------------------------------------------------
          if (n2o_vmr /= 0.0) then
          call gasins('n2o',                                        &
                      do_lvlcalc_n2o, do_lvlctscalc_n2o,   &
                      do_lyrcalc_n2o, nf, ntbnd_n2o(nf),   &
                      ndimkp,ndimk,                               &
                      dgasdt10_lvl, dgasdt10_lvlcts, dgasdt10_lyr,   &
                      gasp10_lvl, gasp10_lvlcts, gasp10_lyr,      &
                      d2gast10_lvl, d2gast10_lvlcts, d2gast10_lyr,  &  
                      dgasdt8_lvl,  dgasdt8_lvlcts,  dgasdt8_lyr ,    &
                      gasp8_lvl,  gasp8_lvlcts,  gasp8_lyr ,      &
                      d2gast8_lvl,  d2gast8_lvlcts,  d2gast8_lyr )
          else
!15
           gasp10_lyr = 1.0 
           gasp8_lyr = 1.0 
           dgasdt10_lyr = 0.0
           dgasdt8_lyr = 0.0
           d2gast10_lyr = 0.0
           d2gast8_lyr = 0.0
         endif
 
!--------------------------------------------------------------------
!    define arrays for the SEA module. the SEA model nomenclature
!    has been used here and the values of do_lvlcalc, do_lvlctscalc,
!    and do_lyrcalc are assumed to be from the data statement.
!--------------------------------------------------------------------
          call put_n2o_stdtf_for_gas_tf (nf, gasp10_lyr, gasp8_lyr,   &
                                         dgasdt10_lyr, dgasdt8_lyr, &
                                         d2gast10_lyr, d2gast8_lyr)
        enddo    ! frequency band loop

!---------------------------------------------------------------------
!    deallocate pressure, index arrays used in rctrns (if needed)
!--------------------------------------------------------------------
        if (callrctrns_n2o) then
          call deallocate_interp_arrays
        endif

!-----------------------------------------------------------------
!    pass necessary data to gas_tf in case stdtf file is to be written
!-----------------------------------------------------------------
        call process_n2o_input_file (gas_type, n2o_vmr, NSTDCO2LVLS, &
                                     KSRAD, KERAD, pd, plm, pa)

!---------------------------------------------------------------------
!   if not calculating tfs, read them in
!---------------------------------------------------------------------
      else                                   
        call process_n2o_input_file (gas_type, n2o_vmr, NSTDCO2LVLS, &
                                     KSRAD, KERAD, pd, plm, pa)
      endif
 
!------------------------------------------------------------------



end subroutine n2o_lblinterp





!#####################################################################
! <SUBROUTINE NAME="lw_gases_stdtf_dealloc">
!  <OVERVIEW>
!   Subroutine to deallocate long wave gas transmission functions
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to deallocate long wave gas transmission functions
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_gases_stdtf_dealloc
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine lw_gases_stdtf_dealloc

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      deallocate (xa                )
      deallocate (ca                )
      deallocate (uexp              )
      deallocate (sexp              )
      deallocate (press_lo          )
      deallocate (press_hi          )
      deallocate (pressint_hiv_std  )
      deallocate (pressint_lov_std  )
      deallocate (trns_std_hi       )
      deallocate (trns_std_lo       )
      deallocate (trns_std_hi_nf    )
      deallocate (trns_std_lo_nf    )

      deallocate (  trns_interp_lyr_ps )
      deallocate (  trns_interp_lyr_ps8 )
      deallocate (  trns_interp_lvl_ps )
      deallocate (  trns_interp_lvl_ps8 )
 
      deallocate (  trns_interp_lyr_ps_nf )
      deallocate (  trns_interp_lyr_ps8_nf )
      deallocate (  trns_interp_lvl_ps_nf )
      deallocate (  trns_interp_lvl_ps8_nf )

      deallocate (  dgasdt8_lvl )
      deallocate (  dgasdt10_lvl )
      deallocate (  d2gast8_lvl  )
      deallocate (  d2gast10_lvl )
      deallocate (  gasp10_lvl )
      deallocate (  gasp8_lvl  )
      deallocate (  dgasdt8_lvlcts  )
      deallocate (  dgasdt10_lvlcts )
      deallocate (  d2gast8_lvlcts  )
      deallocate (  d2gast10_lvlcts )
      deallocate (  gasp10_lvlcts )
      deallocate (  gasp8_lvlcts  )
      deallocate (  dgasdt8_lyr  )
      deallocate (  dgasdt10_lyr )
      deallocate (  d2gast8_lyr  )
      deallocate (  d2gast10_lyr )
      deallocate (  gasp10_lyr )
      deallocate (  gasp8_lyr  )

!--------------------------------------------------------------------

end subroutine lw_gases_stdtf_dealloc



!####################################################################
! <SUBROUTINE NAME="cfc_exact">
!  <OVERVIEW>
!   cfc_exact computes exact cool-to-space transmission function 
!   for cfc for the desired band (given by index). 
!  </OVERVIEW>
!  <DESCRIPTION>
!   cfc_exact computes exact cool-to-space transmission function 
!   for cfc for the desired band (given by index).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_exact (index, Optical, cfc_tf)
!  </TEMPLATE>
!  <IN NAME="index" TYPE="integer">
!   the spectral index where exact CTS transmision function is computed
!  </IN>
!  <IN NAME="Optical" TYPE="optical_depth_type">
!   The CFC gas optical depth
!  </IN>
!  <OUT NAME="cfc_tf" TYPE="real">
!   exact CTS transmission function output
!  </OUT>
! </SUBROUTINE>
!
subroutine cfc_exact (index, Optical, cfc_tf)

!----------------------------------------------------------------------
!    cfc_exact computes exact cool-to-space transmission function 
!    for cfc for the desired band (given by index). 
!----------------------------------------------------------------------

integer,                 intent(in)    :: index
type(optical_path_type), intent(in)    :: Optical
real, dimension (:,:,:), intent(out)   :: cfc_tf

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     index
!     Optical
!
!  intent(out) variables:
!
!     cfc_tf
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer :: kx   ! do-loop  index

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod',   &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      kx = size (Optical%totf11,3) 
      cfc_tf(:,:,:          ) = 1.0E+00 -    &
                      strf113(index)*Optical%totf113(:,:,2:kx) -   &
                      strf22 (index)*Optical%totf22 (:,:,2:kx) -   &
                      strf11 (index)*Optical%totf11 (:,:,2:kx) -   &
                      strf12 (index)*Optical%totf12 (:,:,2:kx)    

!---------------------------------------------------------------------

end subroutine cfc_exact




!####################################################################
! <SUBROUTINE NAME="cfc_exact_part">
!  <OVERVIEW>
!   cfc_exact computes exact cool-to-space transmission function 
!   at levels below klevel for cfc for the band given by index. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   cfc_exact computes exact cool-to-space transmission function 
!   at levels below klevel for cfc for the band given by index.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_exact_part(index, Optical, cfc_tf, klevel)
!  </TEMPLATE>
!  <IN NAME="index" TYPE="integer">
!   The spectral index where exact CTS transmision function is computed
!  </IN>
!  <IN NAME="Optical" TYPE="optical_depth_type">
!   The CFC gas optical depth
!  </IN>
!  <OUT NAME="cfc_tf" TYPE="real">
!   exact CTS transmission function output
!  </OUT>
!  <IN NAME="klevel" TYPE="integer">
!   The level below which exact CTS transmision function is computed
!  </IN>
! </SUBROUTINE>
!
subroutine cfc_exact_part (index, Optical, cfc_tf, klevel)

!----------------------------------------------------------------------
!    cfc_exact computes exact cool-to-space transmission function 
!    at levels below klevel for cfc for the band given by index. 
!----------------------------------------------------------------------

integer,                 intent(in)    :: index, klevel
type(optical_path_type), intent(in)    :: Optical
real, dimension (:,:,:), intent(out)   :: cfc_tf

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     index
!     klevel
!     Optical
!
!  intent(out) variables:
!
!     cfc_tf
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer     ::  k     ! do-loop index
      integer     ::  kx    !

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod',   &
              'module has not been initialized', FATAL )
      endif
 
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      kx = size (Optical%totf11,3) 
      do k=klevel,kx-1 
        cfc_tf(:,:,k) = 1.0E+00 - strf113(index)*    &
                        (Optical%totf113(:,:,k+1) -  &
                         Optical%totf113(:,:,klevel)) -   &
                        strf22 (index)*   &
                        (Optical%totf22(:,:,k+1) -   &
                         Optical%totf22(:,:,klevel)) -   &
                        strf11 (index)*                          &
                        (Optical%totf11(:,:,k+1) -   &
                         Optical%totf11(:,:,klevel)) -   &
                        strf12 (index)*      &   
                        (Optical%totf12(:,:,k+1) -   &
                         Optical%totf12(:,:,klevel)) 
      end do

!--------------------------------------------------------------------

end subroutine cfc_exact_part



!####################################################################
! <SUBROUTINE NAME="cfc_indx8">
!  <OVERVIEW>
!   cfc_indx8 computes transmission function for cfc for the band 8. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   cfc_indx8 computes transmission function for cfc for the band 8. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_indx8(index, Optical, tcfc8)
!  </TEMPLATE>
!  <IN NAME="index" TYPE="integer">
!   The spectral index where exact CTS transmision function is computed
!  </IN>
!  <IN NAME="Optical" TYPE="optical_depth_type">
!   The CFC gas optical depth
!  </IN>
!  <OUT NAME="tcfc8" TYPE="real">
!   exact CTS transmission function output for the band 8
!  </OUT>
! </SUBROUTINE>
!
subroutine cfc_indx8 (index, Optical, tcfc8)

!----------------------------------------------------------------------
!     cfc_indx8 computes transmission function for cfc for the band 8. 
!----------------------------------------------------------------------

integer,                 intent(in)    :: index
type(optical_path_type), intent(in)    :: Optical
real, dimension (:,:,:), intent(out)   :: tcfc8

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     index
!     Optical
!
!  intent(out) variables:
!
!     tcfc8 
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      tcfc8 (:,:,:) = 1.0E+00 -    &
                      strf113(index)*Optical%totf113 -   &
                      strf22 (index)*Optical%totf22  

!---------------------------------------------------------------------

end subroutine cfc_indx8



!####################################################################
! <SUBROUTINE NAME="cfc_indx8_part">
!  <OVERVIEW>
!   cfc_indx8 computes transmission function for cfc for the band 8. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   cfc_indx8 computes transmission function for cfc for the band 8. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_indx8_part(index, Optical, tcfc8, klevel)
!  </TEMPLATE>
!  <IN NAME="index" TYPE="integer">
!   The spectral index where exact CTS transmision function is computed
!  </IN>
!  <IN NAME="Optical" TYPE="optical_depth_type">
!   The CFC gas optical depth
!  </IN>
!  <OUT NAME="tcfc8" TYPE="real">
!   exact CTS transmission function output for the band 8
!  </OUT>
!  <IN NAME="klevel" TYPE="integer">
!   The level below which exact CTS transmision function is computed
!  </IN>
! </SUBROUTINE>
!
subroutine cfc_indx8_part (index, Optical, tcfc8, klevel)

!----------------------------------------------------------------------
!     cfc_indx8_part computes transmission function for cfc for 
!     the band 8. 
!----------------------------------------------------------------------

integer,                 intent(in)    :: index, klevel
type(optical_path_type), intent(in)    :: Optical
real, dimension (:,:,:), intent(out)   :: tcfc8

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     index
!     klevel
!     Optical
!
!  intent(out) variables:
!
!     tcfc8 
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer     :: kx
      integer     :: k

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      kx = size (Optical%totf11,3) 
      do k=klevel,kx-1 
        tcfc8 (:,:,k+1) = 1.0E+00 -  strf113(index)*    &
                          (Optical%totf113(:,:,k+1) -  &
                           Optical%totf113(:,:,klevel)) -   &
                          strf22 (index)*  &
                          (Optical%totf22(:,:,k+1) -   &
                           Optical%totf22(:,:,klevel)) 
      end do

!--------------------------------------------------------------------

end subroutine cfc_indx8_part




!####################################################################
! <SUBROUTINE NAME="cfc_overod">
!  <OVERVIEW>
!   cfc_overod computes transmission function for cfc that is used   
!   with overod variable in the 15 um (560-800 cm-1) band.
!  </OVERVIEW>
!  <DESCRIPTION>
!   cfc_overod computes transmission function for cfc that is used   
!   with overod variable in the 15 um (560-800 cm-1) band.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_overod (Optical, cfc_tf)
!  </TEMPLATE>
!  <IN NAME="Optical" TYPE="optical_path_type">
!   CFC optical depth values
!  </IN>
!  <OUT NAME="cfc_tf" TYPE="real">
!   CFC transmission function
!  </OUT>
! </SUBROUTINE>
! 
subroutine cfc_overod (Optical, cfc_tf)

!----------------------------------------------------------------------
!     cfc_overod computes transmission function for cfc that is used   
!     with overod variable.
!----------------------------------------------------------------------

type(optical_path_type), intent(in)    :: Optical
real, dimension (:,:,:), intent(out)   :: cfc_tf

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     Optical
!
!  intent(out) variables:
!
!     cfc_tf
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer :: kx

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      kx = size (Optical%totf11,3) 
      cfc_tf(:,:,:) = 1.0E+00 -    &
                      sf11315*Optical%totf113(:,:,2:kx) -   &
                      sf2215 *Optical%totf22 (:,:,2:kx) -  &
                      sf1115*Optical%totf11  (:,:,2:kx) -  &
                      sf1215*Optical%totf12  (:,:,2:kx)

!---------------------------------------------------------------------


end subroutine cfc_overod




!####################################################################
! <SUBROUTINE NAME="cfc_overod_part">
!  <OVERVIEW>
!   cfc_overod computes transmission function for cfc that is used   
!   with overod variable in the 15 um (560-800 cm-1) band from klevel down.
!  </OVERVIEW>
!  <DESCRIPTION>
!   cfc_overod computes transmission function for cfc that is used   
!   with overod variable in the 15 um (560-800 cm-1) band from klevel down.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_overod_part (Optical, cfc_tf, klevel)
!  </TEMPLATE>
!  <IN NAME="Optical" TYPE="optical_path_type">
!   CFC optical depth values
!  </IN>
!  <OUT NAME="cfc_tf" TYPE="real">
!   CFC transmission function
!  </OUT>
!  <IN NAME="klevel" TYPE="integer">
!   The level below which exact CTS transmision function is computed
!  </IN>
! </SUBROUTINE>
!  
subroutine cfc_overod_part (Optical, cfc_tf, klevel)

!----------------------------------------------------------------------
!    cfc_overod_part computes transmission function for cfc that is 
!    used with overod variable from klevel down.
!----------------------------------------------------------------------

type(optical_path_type), intent(in)    :: Optical
real, dimension (:,:,:), intent(out)   :: cfc_tf
integer,                 intent(in)    :: klevel

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     Optical
!     klevel
!
!  intent(out) variables:
!
!     cfc_tf
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer     ::      kx
      integer     ::      k

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      kx = size (Optical%totf11,3) 
      do k=klevel,kx-1 
        cfc_tf(:,:,k) = 1.0E+00 - sf11315*      &
                        (Optical%totf113(:,:,k+1) -   &
                         Optical%totf113(:,:,klevel)) - &
                        sf2215 *  &
                        (Optical%totf22 (:,:,k+1) -   &
                         Optical%totf22 (:,:,klevel)) -   & 
                        sf1115*   &
                        (Optical%totf11 (:,:,k+1) -   &
                         Optical%totf11 (:,:,klevel)) -   & 
                        sf1215*  &
                        (Optical%totf12 (:,:,k+1) -   &
                         Optical%totf12 (:,:,klevel))   
      end do

!---------------------------------------------------------------------


end subroutine cfc_overod_part


!#####################################################################
! <SUBROUTINE NAME="lw_gases_stdtf_end">
!  <OVERVIEW>
!   lw_gases_stdtf_end is the destructor for lw_gases_stdtf_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   lw_gases_stdtf_end is the destructor for lw_gases_stdtf_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lw_gases_stdtf_end           
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine lw_gases_stdtf_end

!--------------------------------------------------------------------
!    lw_gases_stdtf_end is the destructor for lw_gases_stdtf_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('lw_gases_stdtf_mod', &
              'module has not been initialized', FATAL )
      endif
 
!-------------------------------------------------------------------
!    deallocate module variables.
!--------------------------------------------------------------------
      deallocate (pd, plm, pd8, plm8)
      deallocate (pa)

!--------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.



end subroutine lw_gases_stdtf_end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!######################################################################
! <SUBROUTINE NAME="std_lblpressures">
!  <OVERVIEW>
!   calculation of pa -- the "table" of (NSTDCO2LVLS) grid pressures
!  </OVERVIEW>
!  <DESCRIPTION>
!   calculation of pa -- the "table" of (NSTDCO2LVLS) grid pressures
!  </DESCRIPTION>
!  <TEMPLATE>
!   call std_lblpressures
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine std_lblpressures
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables
      real      ::  fact15, fact30, dummy
      integer   ::  unit

!---------------------------------------------------------------------
!  local variables
!
!     fact15
!
!-------------------------------------------------------------------
     integer :: k
!---------------------------------------------------------------------
!    calculation of pa -- the "table" of (NSTDCO2LVLS) grid pressures
!    note-this code must not be changed by the user!!!!!!!!!
!---------------------------------------------------------------------
      allocate ( pa (NSTDCO2LVLS) )

      if (NSTDCO2LVLS .EQ. 109) then
        pa(1)=0.
        fact15=10.**(1./15.)
        fact30=10.**(1./30.)
        pa(2)=1.0e-3
        do k=2,76
          pa(k+1)=pa(k)*fact15
        enddo
        do k=77,108
          pa(k+1)=pa(k)*fact30
        enddo
      else if (NSTDCO2LVLS .EQ. 496) then
        unit = open_namelist_file ('INPUT/stdlvls')
        do k=1,496
          read (unit,FMT =  '(4E20.10)') pa(k),dummy,dummy,dummy
        enddo
        call close_file (unit)
      endif

!---------------------------------------------------------------------
 



end subroutine std_lblpressures




!#####################################################################
! <SUBROUTINE NAME="approx_fn">
!  <OVERVIEW>
!   Subroutine to compute co2 approximation function
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute co2 approximation function
!  </DESCRIPTION>
!  <TEMPLATE>
!   call approx_fn (press_hi_app, press_lo_app, do_triangle,     &  
!                   nklo, nkhi, nkplo, nkphi,                      &
!                   ca_app, sexp_app, xa_app, uexp_app, approx)
!  </TEMPLATE>
!  <IN NAME="press_hi_app" TYPE="real">
!   high standard pressure array
!  </IN>
!  <IN NAME="press_lo_app" TYPE="real">
!   low standard pressure array
!  </IN>
!  <IN NAME="do_triangle" TYPE="logical">
!   state variable of interpolation scheme
!  </IN>
!  <IN NAME="nklo, nkhi" TYPE="integer">
!   vertical level pairs: the upper and lower level index
!  </IN>
!  <IN NAME="nkplo, nkphi" TYPE="integer">
!   pressure level pairs: the upper and lower level index
!  </IN>
!  <IN NAME="ca_app, sexp_app, xa_app, uexp_app" TYPE="real">
!   The interpolation coefficients
!  </IN>
!  <OUT NAME="approx" TYPE="real">
!   co2 approximation function
!  </OUT>
! </SUBROUTINE>
!
subroutine approx_fn (press_hi_app, press_lo_app, do_triangle,     &  
                      nklo, nkhi, nkplo, nkphi,                      &
                      ca_app, sexp_app, xa_app, uexp_app, approx)

!----------------------------------------------------------------------
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    approx_fn computes the co2 approximation function
!          A(press_hi_app(i), press_lo_app(j))  (Eq.(4), Ref. (2))
!    for a particular co2 amount and a standard pressure grid (pa).
!    the calculation is performed for all (press_hi(k),press_lo(k')
!    pairs which are possible according to the state of (do_triangle).
!    the path function (upathv) is evaluated using the expression
!    given in Eqs. (5) and (A5) in Ref. (2) for the co2 interpolation
!    program between a lower model pressure (press_lo_app) and
!    a higher model pressure (press_hi_app) using the interpolation
!    coefficients (ca_app, sexp_app, xa_app, uexp_app) computed in
!    subroutine coeint.
!         the output is in (approx).
!----------------------------------------------------------------------

real, dimension(:,:), intent(in)  :: press_hi_app, press_lo_app, &
                                     ca_app, sexp_app, xa_app,   &
                                     uexp_app
logical,              intent(in)  :: do_triangle 
integer,              intent(in)  :: nklo, nkhi, nkplo, nkphi
real, dimension(:,:), intent(out) :: approx

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     press_hi_app
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables

       real, dimension(:,:), allocatable :: upathv

       integer   :: k, kp, kp0
       integer   :: k1, k2

!----------------------------------------------------------------------
!  local variables
!
!    upathv
!
!--------------------------------------------------------------------

!----------------------------------------------------------------------
!    obtain array extents for internal arrays  and allocate these arrays
!----------------------------------------------------------------------
      k1 = size(press_hi_app,1)       ! this corresponds to ndimkp
      k2 = size(press_hi_app,2)       ! this corresponds to ndimk
      allocate (upathv(k1,k2) )
 
      do k=nklo,nkhi
        if (do_triangle) then
          kp0 = k + nkplo
        else
          kp0 = nkplo
        endif
        do kp=kp0,nkphi

!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in radiag 
!    file
!          upathv(kp,k) = (press_hi_app(kp,k) -    &
!   press_lo_app(kp,k))**(1./sexp_app(kp,k))* &
!                         (press_hi_app(kp,k) + press_lo_app(kp,k) +  &
!          upathv(kp,k) = upathv(kp,k)**uexp_app(kp,k)
!          approx(kp,k) = (ca_app(kp,k)*           &
!                          LOG(1.0 + xa_app(kp,k)*upathv(kp,k)))**   &
!                          (sexp_app(kp,k)/uexp_app(kp,k))
!------------------------------------------------------------------

          upathv(kp,k) = (press_hi_app(kp,k) -    &
                          press_lo_app(kp,k))**(1./sexp_app(kp,k))* &
                          (press_hi_app(kp,k) + press_lo_app(kp,k) +  &
                          dop_core)
           upathv(kp,k) = upathv(kp,k)**uexp_app(kp,k)
           approx(kp,k) = (ca_app(kp,k)*           &
                           LOG(1.0 + xa_app(kp,k)*upathv(kp,k)))**   &
                           (sexp_app(kp,k)/uexp_app(kp,k))

!          upathv(kp,k) = EXP((1.0/sexp_app(kp,k))* ALOG(  &
!  (press_hi_app(kp,k) - press_lo_app(kp,k))))* &
!                         (press_hi_app(kp,k) + press_lo_app(kp,k) +  &
!                                     dop_core)
!          upathv(kp,k) = EXP(uexp_app(kp,k)*ALOG(upathv(kp,k)))
!          approx(kp,k) = EXP( ((sexp_app(kp,k)/uexp_app(kp,k)) *   &
!   ALOG( ca_app(kp,k)*  &
!                          LOG(1.0 + xa_app(kp,k)*upathv(kp,k)))))
          enddo
        enddo

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        deallocate (upathv)
 
!---------------------------------------------------------------------


end subroutine approx_fn



!#####################################################################
! <SUBROUTINE NAME="approx_fn_std">
!  <OVERVIEW>
!   Subroutine to compute co2 approximation function
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute co2 approximation function
!  </DESCRIPTION>
!  <TEMPLATE>
!   call approx_fn_std (press_hi_app, press_lo_app, do_triangle,     &  
!                   ca_app, sexp_app, xa_app, uexp_app, approx)
!  </TEMPLATE>
!  <IN NAME="press_hi_app" TYPE="real">
!   high standard pressure array
!  </IN>
!  <IN NAME="press_lo_app" TYPE="real">
!   low standard pressure array
!  </IN>
!  <IN NAME="do_triangle" TYPE="logical">
!   state variable of interpolation scheme
!  </IN>
!  <IN NAME="ca_app, sexp_app, xa_app, uexp_app" TYPE="real">
!   The interpolation coefficients
!  </IN>
!  <OUT NAME="approx" TYPE="real">
!   co2 approximation function
!  </OUT>
! </SUBROUTINE>
!
subroutine approx_fn_std (press_hi_pa, press_lo_pa, do_triangle, &
                          ca_app, sexp_app, xa_app, uexp_app,  &
                          approx)
 
!---------------------------------------------------------------------
!    approx_fn_std computes the co2 approximation function
!               A(press_hi(i), press_lo(j))  (Eq.(4), Ref. (2))
!    for a particular co2 amount and a standard pressure grid (pa).
!    the calculation is performed for all (press_hi(k),press_lo(k')
!    pairs which are possible according to the state of (do_triangle).
!    the path function (upathv) is evaluated using the expression
!    given in Eqs. (5) and (A5) in Ref. (2) for the co2 interpolation
!    program between a lower standard pressure (press_lo_pa) and
!    a higher standard pressure (press_hi_pa) using the interpolation
!    coefficients (ca_app, sexp_app, xa_app, uexp_app) computed in
!    subroutine coeint.
!         the output is in (approx).
!--------------------------------------------------------------------

real, dimension(:,:), intent(in)    :: ca_app, sexp_app, xa_app, &
                                       uexp_app
real, dimension(:,:), intent(in)    :: press_hi_pa, press_lo_pa
logical,              intent(in)    :: do_triangle
real, dimension(:,:), intent(out)   :: approx

!--------------------------------------------------------------------
!  local variables
      
      real, dimension(:,:), allocatable  :: upathv
      integer         :: k, kp, kp0

!--------------------------------------------------------------------
!  local variables
!   
!     upathv
!
!--------------------------------------------------------------------
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      allocate (upathv (NSTDCO2LVLS,NSTDCO2LVLS) )
      do k=1,NSTDCO2LVLS
        if (do_triangle) then
          kp0 = k + 1
        else
          kp0 = 1
        endif
        do kp=kp0,NSTDCO2LVLS

!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in 
!    radiag file
!         upathv(kp,k) = (press_hi_pa(kp,k) -    &
!  press_lo_pa(kp,k))**(1./sexp_app(kp,k)) *  &
!                         (press_hi_pa(kp,k) + press_lo_pa(kp,k) +    &
!    dop_core)
!         upathv(kp,k) = upathv(kp,k)**uexp_app(kp,k)
!         approx(kp,k) = (ca_app(kp,k)*                              &
!                         LOG(1.0 + xa_app(kp,k)*upathv(kp,k)))**    &
!                             (sexp_app(kp,k)/uexp_app(kp,k))
!---------------------------------------------------------------------

          upathv(kp,k) = EXP((1.0/sexp_app(kp,k))* ALOG(  &
                        (press_hi_pa(kp,k) - press_lo_pa(kp,k))))* &
                        (press_hi_pa(kp,k) + press_lo_pa(kp,k) +  &
                         dop_core)
          upathv(kp,k) = EXP(uexp_app(kp,k)*ALOG(upathv(kp,k)))
          approx(kp,k) = EXP( ((sexp_app(kp,k)/uexp_app(kp,k)) *  &
                         ALOG( ca_app(kp,k)*   &
                         LOG(1.0 + xa_app(kp,k)*upathv(kp,k)))))
        enddo
      enddo

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      deallocate (upathv)

!--------------------------------------------------------------------

end subroutine approx_fn_std


!#####################################################################
! <SUBROUTINE NAME="gasins">
!  <OVERVIEW>
!   gasins processes transmission functions to produce 
!     "consolidated" functions over the specific frequency band
!     ranges needed by the SEA code, and the derivatives needed
!     by the SEA algorithm.
!  </OVERVIEW>
!  <DESCRIPTION>
!    gasins processes transmission functions to produce 
!     "consolidated" functions over the specific frequency band
!     ranges needed by the SEA code, and the derivatives needed
!     by the SEA algorithm.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call gasins (gas_type, do_lvlcalc, do_lvlctscalc, do_lyrcalc,  &
!                   nf, ntbnd, ndimkp, ndimk,  &
!                   dgasdt10_lvl, dgasdt10_lvlcts, dgasdt10_lyr,  &
!                   gasp10_lvl, gasp10_lvlcts, gasp10_lyr,  &
!                   d2gast10_lvl, d2gast10_lvlcts, d2gast10_lyr,  &
!                   dgasdt8_lvl,  dgasdt8_lvlcts,  dgasdt8_lyr ,  &
!                   gasp8_lvl,  gasp8_lvlcts,  gasp8_lyr ,  &
!                   d2gast8_lvl,  d2gast8_lvlcts,  d2gast8_lyr )
!  </TEMPLATE>
!  <IN NAME="gas_type" TYPE="character">
!   Gas type information
!  </IN>
!  <IN NAME="do_lvlcalc, do_lvlctscalc, do_lyrcalc" TYPE="logical">
!   State variables that determines calculation paths
!        do_lvlcalc     : compute level co2 transmissivities if true.
!        do_lyrcalc     : compute layer co2 transmissivities if true.
!        do_lvlctscalc  : compute cts level co2 transmissivities if true
!  </IN>
!  <IN NAME="nf" TYPE="integer">
!   frequency band number
!  </IN>
!  <IN NAME="ntbnd" TYPE="integer">
!   temperature index of the frequency band
!  </IN>
!  <IN NAME="ndimkp, ndimk" TYPE="integer">
!   extents of dimensions for output interpolation transmissivity arrays.
!  </IN>
!  <OUT NAME="dgasdt10_lvl gasp10_lvl d2gast10_lvl dgasdt8_lvl gasp8_lvl d2gast8_lvl" TYPE="real">
!   variables used in do_lvlcalc calculation path
!  </OUT>
!  <OUT NAME="dgasdt10_lvlcts gasp10_lvlcts d2gast10_lvlcts dgasdt8_lvlcts gasp8_lvlcts d2gast8_lvlcts" TYPE="real">
!   variables used in do_lvlctscalc calculation path
!  </OUT>
!  <OUT NAME="dgasdt10_lyr gasp10_lyr d2gast10_lyr dgasdt8_lyr gasp8_lyr d2gast8_lyr" TYPE="real">
!   variables used in do_lyrcalc calculation path
!  </OUT>
! </SUBROUTINE>
!

subroutine gasins (gas_type, do_lvlcalc, do_lvlctscalc, do_lyrcalc,  &
                   nf, ntbnd, ndimkp, ndimk,  &
                   dgasdt10_lvl, dgasdt10_lvlcts, dgasdt10_lyr,  &
                   gasp10_lvl, gasp10_lvlcts, gasp10_lyr,  &
                   d2gast10_lvl, d2gast10_lvlcts, d2gast10_lyr,  &
                   dgasdt8_lvl,  dgasdt8_lvlcts,  dgasdt8_lyr ,  &
                   gasp8_lvl,  gasp8_lvlcts,  gasp8_lyr ,  &
                   d2gast8_lvl,  d2gast8_lvlcts,  d2gast8_lyr )
 
!-------------------------------------------------------------------
!    gasins processes transmission functions to produce 
!    "consolidated" functions over the specific frequency band
!    ranges needed by the SEA code, and the derivatives needed
!    by the SEA algorithm. writing to a file, formerly done in
!    this module, is now done (if needed) in write_seaco2fcns.F
!-------------------------------------------------------------------

character(len=*),     intent(in)   :: gas_type
logical,              intent(in)   :: do_lvlcalc, do_lyrcalc, &
                                      do_lvlctscalc
integer,              intent(in)   :: nf, ntbnd
integer,              intent(in)   :: ndimkp, ndimk
real, dimension(:,:), intent(out)  :: &
                                      dgasdt10_lvl, dgasdt10_lyr,  &
                                      gasp10_lvl, gasp10_lyr,  &
                                      d2gast10_lvl, d2gast10_lyr,  &
                                      dgasdt8_lvl,  dgasdt8_lyr ,  &
                                      gasp8_lvl,  gasp8_lyr ,  &
                                      d2gast8_lvl,  d2gast8_lyr
real, dimension(:)  , intent(out)  :: &
                                      dgasdt10_lvlcts, &
                                      gasp10_lvlcts, &
                                      d2gast10_lvlcts, &
                                      dgasdt8_lvlcts,  &
                                      gasp8_lvlcts,  &
                                      d2gast8_lvlcts   

!-------------------------------------------------------------------
!  intent(in) variables:
!
!    gas_type 
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables

      integer      :: k1, k2, k, kp
      real         :: c1,c2

!-------------------------------------------------------------------
!  local variables
!
!     k1
!
!-------------------------------------------------------------------

!--------------------------------------------------------------------
!    obtain array extents for internal arrays and allocate these arrays
!--------------------------------------------------------------------
      k1 = size(trns_interp_lvl_ps_nf,1) ! this corresponds to ndimkp
      k2 = size(trns_interp_lvl_ps_nf,2) ! this corresponds to ndimk
 
!---------------------------------------------------------------------
!    the following code is rewritten so that the radiative bands
!    are: 
!        nf=1    560-800     (consol.=490-850)
!        nf=2    560-630      consol=490-630
!        nf=3    630-700      consol=630-700
!        nf=4    700-800      consol=700-850
!        nf=5   2270-2380     consol=2270-2380
!    the following loop obtains transmission functions for bands
!    used in radiative model calculations,with the equivalent
!    widths kept from the original consolidated co2 tf's.
!---------------------------------------------------------------------
      if (gas_type .EQ. 'co2') then
        if (nf.eq.1) then
          c1=1.5
          c2=0.5
        else if (nf.eq.2) then
          c1=2.0
          c2=1.0
        else if (nf.eq.3) then
          c1=1.0
          c2=0.0
        else if (nf.eq.4) then
          c1=1.5
          c2=0.5
        else if (nf.eq.5) then
          c1=1.0
          c2=0.0
        else
          call error_mesg ('lw_gases_stdtf_mod', &
              'illegal value of nf for co2', FATAL)
        endif

!--------------------------------------------------------------------
!    the following code is rewritten so that the radiative bands
!    are: 
!        nf=1    1200-1400    consol=1200-1400
!    the following loop obtains transmission functions for bands
!    used in radiative model calculations,with the equivalent
!    widths kept from the original consolidated co2 tf's.
!--------------------------------------------------------------------
      else if (gas_type .EQ. 'ch4') then
        if (nf.eq.1) then
          c1=1.0
          c2=0.0
        else 
          call error_mesg ('lw_gases_stdtf_mod', &
                 'illegal value of nf for ch4', FATAL)
        endif

!--------------------------------------------------------------------
!    the following code is rewritten so that the radiative bands
!    are: 
!        nf=1    1200-1400    consol=1200-1400
!        nf=2    1070-1200    consol=1070-1200
!        nf=3    560-630    consol=560-630
!    the following loop obtains transmission functions for bands
!    used in radiative model calculations,with the equivalent
!    widths kept from the original consolidated co2 tf's.
!--------------------------------------------------------------------
      else if (gas_type .EQ. 'n2o') then
        if (nf.eq.1) then
          c1=1.0
          c2=0.0
        else if (nf.eq.2) then
          c1=1.0
          c2=0.0
        else if (nf.eq.3) then
          c1=1.0
          c2=0.0
        else
          call error_mesg ('lw_gases_stdtf_mod', &
               'illegal value of nf for n2o', FATAL)
        endif
      else 
        call error_mesg ('lw_gases_stdtf_mod', &
            'radiative gas type unrecognized in lw_gases_stdtf', &
                                                              FATAL)
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_lvlcalc) then
        do k=1,k2
          do kp=1,k1
            gasp10_lvl(kp,k) = c1*trns_interp_lvl_ps_nf(kp,k,1) - c2
            gasp8_lvl(kp,k) = c1*trns_interp_lvl_ps8_nf(kp,k,1) - c2
          enddo
        enddo

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
        if (ntbnd .EQ. 3) then
          do k=1,k2
            do kp=1,k1
              dgasdt10_lvl(kp,k) = .02*(trns_interp_lvl_ps_nf(kp,k,2) -&
                                        trns_interp_lvl_ps_nf(kp,k,3))*&
                                   100.
              dgasdt8_lvl(kp,k) = .02*(trns_interp_lvl_ps8_nf(kp,k,2) -&
                                       trns_interp_lvl_ps8_nf(kp,k,3))*&
                                   100.
              d2gast10_lvl(kp,k) = .0016*    &
                                   (trns_interp_lvl_ps_nf(kp,k,2) +&
                                    trns_interp_lvl_ps_nf(kp,k,3) -&
                                    2.0*   &
                                    trns_interp_lvl_ps_nf(kp,k,1))*&
                                    1000.
              d2gast8_lvl(kp,k)  =   &
                                    .0016*  &
                                    (trns_interp_lvl_ps8_nf(kp,k,2) +&
                                     trns_interp_lvl_ps8_nf(kp,k,3) - &
                                     2.0* &
                                     trns_interp_lvl_ps_nf(kp,k,1))*  &
                                     1000.
            enddo
          enddo
        endif
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_lvlctscalc) then
        do kp=1,k1
          gasp10_lvlcts(kp) = c1*trns_interp_lvl_ps_nf(kp,1,1) - c2
          gasp8_lvlcts(kp) = c1*trns_interp_lvl_ps8_nf(kp,1,1) - c2
        enddo
        if (ntbnd .EQ. 3) then
          do kp=1,k1
            dgasdt10_lvlcts(kp) = .02*(trns_interp_lvl_ps_nf(kp,1,2) - &
                                       trns_interp_lvl_ps_nf(kp,1,3))* &
                                  100.
            dgasdt8_lvlcts(kp)  = .02*(trns_interp_lvl_ps8_nf(kp,1,2) -&
                                       trns_interp_lvl_ps8_nf(kp,1,3))*&
                                  100.
            d2gast10_lvlcts(kp) = .0016*  &
                                  (trns_interp_lvl_ps_nf(kp,1,2) +   &
                                   trns_interp_lvl_ps_nf(kp,1,3) -  &
                                   2.0*trns_interp_lvl_ps_nf(kp,1,1))*&
                                   1000.
            d2gast8_lvlcts(kp)  = .0016*  &
                                  (trns_interp_lvl_ps8_nf(kp,1,2) +  &
                                   trns_interp_lvl_ps8_nf(kp,1,3) - &
                                  2.0*trns_interp_lvl_ps_nf(kp,1,1))*  &
                                  1000.
          enddo
        endif
      endif
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_lyrcalc) then
        do k=1,k2
          do kp=1,k1
            gasp10_lyr(kp,k) = c1*trns_interp_lyr_ps_nf(kp,k,1) - c2
            gasp8_lyr(kp,k) = c1*trns_interp_lyr_ps8_nf(kp,k,1) - c2
          enddo
        enddo
        if (ntbnd .EQ. 3) then
          do k=1,k2
            do kp=1,k1
              dgasdt10_lyr(kp,k) = .02*(trns_interp_lyr_ps_nf(kp,k,2) -&
                                        trns_interp_lyr_ps_nf(kp,k,3))*&
                                    100.
              dgasdt8_lyr(kp,k) = .02*(trns_interp_lyr_ps8_nf(kp,k,2) -&
                                       trns_interp_lyr_ps8_nf(kp,k,3))*&
                                                   100.
              d2gast10_lyr(kp,k) = .0016*  &
                                   (trns_interp_lyr_ps_nf(kp,k,2) +   &
                                    trns_interp_lyr_ps_nf(kp,k,3) -  &
                                    2.0*trns_interp_lyr_ps_nf(kp,k,1))*&
                                    1000.
              d2gast8_lyr(kp,k)  = .0016*  &
                                   (trns_interp_lyr_ps8_nf(kp,k,2) +   &
                                    trns_interp_lyr_ps8_nf(kp,k,3) - &
                                    2.0* &
                                    trns_interp_lyr_ps8_nf(kp,k,1))*  &
                                    1000.
            enddo
          enddo
        endif
      endif

!--------------------------------------------------------------------

 
end subroutine gasins




!#####################################################################
! <SUBROUTINE NAME="gasint">
!  <OVERVIEW>
!   gasint interpolates carbon dioxide transmission functions
!   from the standard level grid,for which the transmission functions
!   have been pre-calculated, to the grid structure specified by the
!   user.
!  </OVERVIEW>
!  <DESCRIPTION>
!   gasint interpolates carbon dioxide transmission functions
!   from the standard level grid,for which the transmission functions
!   have been pre-calculated, to the grid structure specified by the
!   user.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call gasint (gas_type, co2_vmr, co2_std_lo, co2_std_hi,  &
!                callrctrns, do_lvlcalc, do_lvlctscalc, do_lyrcalc,  &
!                nf, nt)
!  </TEMPLATE>
!  <IN NAME="gas_type" TYPE="character">
!   Gas type information
!  </IN>
!  <IN NAME="do_lvlcalc, do_lvlctscalc, do_lyrcalc" TYPE="logical">
!   State variables that determine calculation paths
!        do_lvlcalc     : compute level co2 transmissivities if true.
!        do_lyrcalc     : compute layer co2 transmissivities if true.
!        do_lvlctscalc  : compute cts level co2 transmissivities if true
!  </IN>
!  <IN NAME="nf" TYPE="integer">
!   frequency band number
!  </IN>
!  <IN NAME="nt" TYPE="integer">
!   temperature index of the frequency band
!  </IN>
!  <IN NAME="co2_vmr" TYPE="real">
!   co2 volume mixing ratio
!  </IN>
!  <IN NAME="co2_std_lo, co2_std_hi" TYPE="real">
!   standard co2 high and low volume mixing ratio (ppmv) pair
!  </IN>
!  <IN NAME="callrctrns" TYPE="logical">
!   state variable that determines calculation path
!  </IN>
! </SUBROUTINE>
!
subroutine gasint (gas_type, co2_vmr, co2_std_lo, co2_std_hi,  &
                   callrctrns, do_lvlcalc, do_lvlctscalc, do_lyrcalc,  &
                   nf, nt)
 
!---------------------------------------------------------------------
!    gasint interpolates carbon dioxide transmission functions
!    from the standard level grid,for which the transmission functions
!    have been pre-calculated, to the grid structure specified by the
!    user.
!
!        method: 
!
!    gasint is employable for two purposes: 1) to obtain transmis-
!    sivities between any 2 of an array of user-defined pressures; and
!    2) to obtain layer-mean transmissivities between any 2 of an array
!    of user-defined pressure layers.to clarify these two purposes,see
!    the diagram and discussion below.
!
!    let p be an array of user-defined pressures
!    and plm the array of user-defined level pressures 
!    and pd the extent of the interpolation layer.
!    for many purposes,plm will be chosen to be the average
!    pressure in the interpolation layer -i.e.,
!    plm(i) = 0.5*(pd(i-1)+pd(i)).
!
!       - - - - - - - - -   pd(i-1)  -----------!
!                                               !
!       -----------------   plm(i), p(k)-----!  !  interpolation layer
!                                            !  !
!       - - - - - - - - -   pd(i)    -----------!       model layer (i)
!                                            !
!       -----------------   plm(i+1)---------!
!            ...
!            ...                          (the notation used is
!            ...                          consistent with the code)
!            ...
!       - - - - - - - - -   pd(j-1)  -----------!
!                                               !
!       -----------------   plm(j), p(k')----!  !  interpolation layer
!                                            !  !
!       - - - - - - - - -   pd(j)    -----------!       model layer (j)
!                                            !
!       -----------------   plm(j+1)---------!
!
!    purpose 1:   the transmissivity between specific pressures
!    p(k) and p(k') ,tau(p(k),p(k'))  is computed by this program.
!    in this mode,there is no reference to layer pressures pd
!
!    purpose 2:   the transmissivity between a pressure p(k) and
!    the interpolation layer centered at p(k') (taulm(p(k),p(k'))
!    is obtained. it is computed by the integral
!
!                           pd(j)
!                           ----
!             1             !
!        -------------  *   !   tau ( p',plm(i) )  dp'
!        pd(j)-pd(j-1)      !
!                        ----
!                        pd(j-1)
!
!    the level pressures (plm) and layer-mean pressures (pd) are
!    both inputted in for this purpose.
!
!    in general, this integral is done using simpson's rule with
!    7 points. however , when plm(i) = pjm(j) (the nearby layer
!    case) a 51-point quadrature is used for greater accuracy.
!    note that taulm(k,k') is not a symmetrical matrix. also, no
!    quadrature is performed over the layer between the smallest 
!    nonzero pressure and zero pressure;
!    taulm is taulm(0,plm(j)) in this case,and taulm(0,0)=1.

!
!    the following paragraphs depict the utilization of this
!    code when used to compute transmissivities between specific
!    pressures. later paragraphs describe additional features needed
!    for layer-mean transmissivities.
!
!    for a given co2 mixing ratio and standard temperature
!    profile,a table of transmission functions for a fixed grid
!    of atmospheric pressures has been pre-calculated.
!    the standard temperature profile is from the us
!    standard atmosphere (1977) table.additionally, the
!    same transmission functions have been pre-calculated for a
!    temperature profile increased and decreased (at all levels)
!    by 25 degrees.
!    this program reads in the prespecified transmission functions
!    and a user-supplied pressure grids (p(k)) and calculates trans-
!    mission functions ,tau(p(k),p(k')), for all (k,k') using one
!    of the above methods, for one of the three temperature profiles.
!    outputs are tables of transmission functions. 
!
!
!    this code may be considered to be version 2 of the
!    interpolator. differences between this code and version 1, 
!    written in ~1983, are as follows:
!
!    1) the code is written using arrays (previous code was entirely
!       scalar)
!    2) double precision quantities are removed. it is assumed that
!       this code is being run on a 64-bit machine. if not, the
!       user will have to reinstate double precisioning, or
!       the appropriate KIND statement in Fortran 90.
!    3) many redundant calculations were eliminated
!    4) the error function is defined exactly as in Ref. (2).
!
!    as a result, this version of the code runs 100-200 times as fast
!    as version 1, and is suitable for on-line calculation of the
!    co2 transmission function.
!     
!                differences in the answers:
!
!    1) as part of the elimination of redundant calculation, the
!       following algorithmic change was performed:
!       calculation of the error function (error_guess1) at standard
!       pressures is done WITHOUT reference to model (user) pressures.
!       answers (in fractional absorptivity change) differ by 10-3 (max)
!       to 10-5. the new method should be "better", as there is no 
!       reason why the error function at standard pressures should care
!       about the pressures where it will be interpolated to.
!
!    2) in the "closely spaced" case (model pressures p,p' both
!       between standard pressures (pa(k),pa(k+1))) the coefficients 
!       (c,x,eta,sexp) are interpolated, not the approx function. this
!       is consistent with all other cases. fractional absorptivity 
!       changes are ~3x10-5 (max) and only for a(p,p') with p~ or = p'.
!
!    3) double precision to single precision change causes fractional
!       absorptivity changes of < 1x10-6.
!
!             references: 
!
!    (1): s.b.fels and m.d.schwarzkopf,"an efficient,accurate
!    algorithm for calculating co2 15 um band cooling rates",journal
!    of geophysical research,vol.86,no. c2, pp.1205-1232,1981.
!    (2): m.d. schwarzkopf and s.b. fels, "Improvements to the
!    algorithm for computing co2 transmissivities and cooling rates",
!    JGR, vol. 90, no. C10, pp10541-10550, 1985.
!
!            author:    m.daniel schwarzkopf
!
!            date:      14 july 1996
!
!            address: 
!
!                      GFDL
!                      p.o.box 308
!                      princeton,n.j.08542
!                      u.s.a.
!            telephone:  (609) 452-6521
!
!            e-mail:   Dan.Schwarzkopf@noaa.gov
!
!
!
!    NOTE: the comment line below is part of the original version
!    of this code, written in the late '70s by Stephen B. Fels. 
!    although the code has been extensively rewritten, and might
!    be unrecognizable to Steve, this line is kept as a tribute
!    to him.
!
!      ************   function interpolator routine  *****
!
!--------------------------------------------------------------------

logical,              intent(in)  ::  do_lvlcalc, do_lyrcalc,   &
                                      do_lvlctscalc, callrctrns
real,                 intent(in)  ::  co2_vmr, co2_std_lo, co2_std_hi
integer,              intent(in)  ::  nf, nt
character(len=*),     intent(in)  ::  gas_type
 
!--------------------------------------------------------------------
! miscellaneous variables: 
!
!    trns_std_lo : array of co2 transmission functions at the
!                  lower of two standard co2 concentrations
!                  at a given temperature profile.
!                  used if interpolation to the actual co2
!                  mixing ratio is required (callrctrns = true).
!                  dimensions: (NSTDCO2LVLS,NSTDCO2LVLS)
!    trns_std_hi : array of co2 transmission functions at the
!                  higher of two standard co2 concentrations
!                  at a given temperature profile.
!                  dimensions: (NSTDCO2LVLS,NSTDCO2LVLS)
!    co2_vmr  : actual co2 concentration (in ppmv)
!    co2_std_lo  : co2 concentration (ppmv) of lower of
!                  two standard concentrations.
!    co2_std_hi  : co2 concentration (ppmv) of higher of
!                  two standard concentrations.
!    callrctrns  : call rctrns.F if true.
! pressint_hiv_std_pt1  : allocated array used for rctrns hi pressure
! pressint_lov_std_pt1  : allocated array used for rctrns low pressure
! pressint_hiv_std_pt2  : allocated array used for rctrns hi pressure
! pressint_lov_std_pt2  : allocated array used for rctrns low pressure
! indx_pressint_hiv_std_pt1  : allocated index array used in rctrns
! indx_pressint_lov_std_pt1  : allocated index array used in rctrns
! indx_pressint_hiv_std_pt2  : allocated index array used in rctrns
! indx_pressint_lov_std_pt2  : allocated index array used in rctrns
!           do_lvlcalc  : compute level co2 transmissivities if true.
!           do_lyrcalc  : compute layer co2 transmissivities if true.
!        do_lvlctscalc  : compute cts level co2 transmissivities if true
!                   nf  : frequency band index
!                   nt  : temperature index (for the freq band)
!        ndimkp, ndimk  : extents of dimensions for output interp
!                         transmissivity arrays.
!              pd, plm  : see description below. note that the
!                         present limits on pressures (from the lbl
!                         computations require that the top level
!                         be 0 mb, and the bottom level pressure
!                         not exceed 1165 mb.
!             pd8, plm8 : same as pd, plm; highest pressure is 0.8*
!                         (highest pressure in plm).
!                         
!
!
!     outputs: 
!        trns_interp_lyr_ps : array of interpolated layer transmission
!           do_lvlcalc  : compute level co2 transmissivities if true.
!           do_lyrcalc  : compute layer co2 transmissivities if true.
!        do_lvlctscalc  : compute cts level co2 transmissivities if true
!                   nf  : frequency band index
!                   nt  : temperature index (for the freq band)
!        ndimkp, ndimk  : extents of dimensions for output interp
!                         transmissivity arrays.
!              pd, plm  : see description below. note that the
!                         present limits on pressures (from the lbl
!                         computations require that the top level
!                         be 0 mb, and the bottom level pressure
!                         not exceed 1165 mb.
!             pd8, plm8 : same as pd, plm; highest pressure is 0.8*
!                         (highest pressure in plm).
!                         
!
!
!     outputs: 
!        trns_interp_lyr_ps : array of interpolated layer transmission
!                             functions for the pressure array (pd).
!        trns_interp_lyr_ps8: array of interpolated layer transmission
!                             functions for the pressure array (pd8).
!        trns_interp_lyr_ps : array of interpolated level transmission
!                             functions for the pressure array (plm).
!        trns_interp_lyr_ps8: array of interpolated level transmission
!                             functions for the pressure array (plm8).
!

!--------------------------------------------------------------------
!  local variables

      real, dimension(:,:),    allocatable :: trns_vmr
      real, dimension(:,:),    allocatable :: approx_guess1,          &
                                              approxint_guess1,       &
                                              error_guess1,           &
                                              errorint_guess1
      real, dimension(:,:),    allocatable :: caintv, uexpintv,       &
                                              sexpintv, xaintv,       &
                                              press_hiv, press_lov
      real, dimension(:,:),    allocatable :: pressint_lov, pressint_hiv
      integer, dimension(:,:), allocatable :: indx_pressint_hiv,   &
                                              indx_pressint_lov
      real, dimension(:,:),    allocatable :: sexpnblv, uexpnblv,  &
                                              canblv, xanblv,      &
                                              pressnbl_lov,        &
                                              pressnbl_hiv,        &
                                              approxnbl_guess1,    &
                                              errornbl_guess1
      integer, dimension(:,:), allocatable :: indx_pressnbl_hiv, &
                                              indx_pressnbl_lov
 
      real, dimension(7)    ::  wgt_lyr
      real, dimension(51)   ::  wgt_nearby_lyr
      logical               ::  do_triangle
      integer               ::  n, k, kp, nklo, nkhi, nkplo, nkphi,   &
                                nq, nprofile

!--------------------------------------------------------------------
!    compute the layer weights for transmissivities. used only if
!    layer transmissivities are needed (do_lyrcalc = true)
!--------------------------------------------------------------------
      if (do_lyrcalc) then
        wgt_lyr(1) = 1./18.
        wgt_lyr(7) = 1./18.
        do n=1,3
          wgt_lyr(2*n) = 4./18.
        enddo
        do n=1,2
          wgt_lyr(2*n+1) = 2./18.
        enddo
        wgt_nearby_lyr(1) = 1./150.
        wgt_nearby_lyr(51) = 1./150.
        do n=1,25
          wgt_nearby_lyr(2*n) = 4./150.
        enddo
        do n=1,24
          wgt_nearby_lyr(2*n+1) = 2./150.
        enddo
      endif

!-------------------------------------------------------------------
!    define transmission function array for (co2_vmr) over
!    standard pressures (pa), using a call to rctrns if necessary.
!-------------------------------------------------------------------
      allocate (trns_vmr (NSTDCO2LVLS, NSTDCO2LVLS) )
      if (callrctrns) then
        call rctrns (gas_type, co2_std_lo, co2_std_hi, co2_vmr,  &
                     nf, nt, trns_vmr)
      else
        trns_vmr = trns_std_hi
      endif
                         
      do k=1,NSTDCO2LVLS
        trns_vmr(k,k)=1.0
      enddo
 
!-------------------------------------------------------------------
!    compute co2 transmission functions for actual co2 concentration
!    using method of section 5, Ref. (2).
!-------------------------------------------------------------------
      call coeint (gas_type, nf, trns_vmr, ca, sexp, xa, uexp)
 
!-------------------------------------------------------------------
!    compute the interpolation. 
!-------------------------------------------------------------------
      do_triangle = .true.
 
!-------------------------------------------------------------------
!    1) compute approx function at standard (pa) pressures
!-------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        press_hi(k) = pa(k)
        press_lo(k) = pa(k)
      enddo
 
!-------------------------------------------------------------------
!    allocate the 2-d input and output arrays needed to obtain the
!    approx function
!-------------------------------------------------------------------
      allocate ( approx_guess1(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate ( caintv(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate ( sexpintv(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate ( xaintv(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate ( uexpintv(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate ( press_hiv(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate ( press_lov(NSTDCO2LVLS,NSTDCO2LVLS))
   
!-------------------------------------------------------------------
!    compute the 2-d input arrays
!-------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        do kp=k,NSTDCO2LVLS
          press_hiv(kp,k) = pa(kp)
          press_lov(kp,k) = pa(k)
          caintv(kp,k) = ca(kp)
          sexpintv(kp,k) = sexp(kp)
          xaintv(kp,k) = xa(kp)
          uexpintv(kp,k) = uexp(kp)
        enddo
      enddo

!-------------------------------------------------------------------
!    the call (and calculations) to pathv2_std has been subsumed into
!    the subroutine approx_fn_std
!-------------------------------------------------------------------
      call approx_fn_std (press_hiv, press_lov, do_triangle, &
                          caintv, sexpintv, xaintv, uexpintv,  &
                          approx_guess1)

      deallocate (press_lov)
      deallocate (press_hiv)
      deallocate (uexpintv)
      deallocate (xaintv)
      deallocate (sexpintv)
      deallocate (caintv)

!-------------------------------------------------------------------
!    2) compute error function at standard (pa) pressures
!-------------------------------------------------------------------
      allocate ( error_guess1(NSTDCO2LVLS,NSTDCO2LVLS) )
 
      do k=1,NSTDCO2LVLS
        do kp=k+1,NSTDCO2LVLS
          error_guess1(kp,k) = 1.0 - trns_vmr(kp,k) -  &
                               approx_guess1(kp,k)
        enddo
        error_guess1(k,k) = 0.0
      enddo
      deallocate (approx_guess1)
        
!-------------------------------------------------------------------
!    define the actual extents of the level interpolation calculation.
!    this depends on the type of calculation desired (whether
!    do_lvlcalc, do_lvlctscalc is true).
!-------------------------------------------------------------------
      if (do_lvlcalc) then
        nklo = KSRAD
        nkhi = KERAD + 1
        nkplo = KSRAD
        nkphi = KERAD + 1
      elseif (do_lvlctscalc) then
        nklo = KSRAD
        nkhi = KSRAD
        nkplo = KSRAD
        nkphi = KERAD + 1
      endif
 
!-------------------------------------------------------------------
!    allocate arrays with user-defined k-extents, which are used
!    in the remainder of the subroutine
!-------------------------------------------------------------------
      allocate ( pressint_hiv(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( pressint_lov(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( indx_pressint_hiv(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( indx_pressint_lov(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( caintv(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( sexpintv(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( xaintv(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( uexpintv(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( errorint_guess1(KSRAD:KERAD+1, KSRAD:KERAD+1) )
      allocate ( approxint_guess1(KSRAD:KERAD+1, KSRAD:KERAD+1) )
 
      if (do_lvlctscalc .OR. do_lvlcalc) then
        do k=KSRAD,KERAD+1
          trns_interp_lvl_ps(k,k) = 1.0
          trns_interp_lvl_ps8(k,k) = 1.0
        enddo
 
!-------------------------------------------------------------------
!    3) derive the pressures for interpolation using Eqs. (8a-b)
!       in Ref.(2).
!-------------------------------------------------------------------
        do_triangle = .true.
        do nprofile = 1,2
          if (nprofile .EQ. 1) then
            do k=nklo,nkhi
              do kp=k+nkplo,nkphi
                pressint_hiv(kp,k) = plm(kp)
                pressint_lov(kp,k) = plm(k)
              enddo
            enddo
          else
            do k=nklo,nkhi
              do kp=k+nkplo,nkphi
                pressint_hiv(kp,k) = plm8(kp)
                pressint_lov(kp,k) = plm8(k)
              enddo
            enddo
          endif
          call intcoef_2d (pressint_hiv, pressint_lov, do_triangle,  &
                           nklo, nkhi, nkplo, nkphi,  &
                           indx_pressint_hiv, indx_pressint_lov,  &
                           caintv, sexpintv, xaintv, uexpintv)

!-------------------------------------------------------------------
!    4) interpolate error function to (pressint_hiv, pressint_lov)
!       for relevant (k',k)
!-------------------------------------------------------------------
          call interp_error (error_guess1, pressint_hiv, pressint_lov, &
                             indx_pressint_hiv, indx_pressint_lov,  &
                             do_triangle, nklo, nkhi, nkplo, nkphi,  &
                             errorint_guess1)

!-------------------------------------------------------------------
!    5) compute approx function for (pressint_hiv, pressint_lov)
!       the call (and calculations) to pathv2 has been subsumed 
!       into subroutine approx_fn
!-------------------------------------------------------------------
          call approx_fn (pressint_hiv, pressint_lov, do_triangle,  &
                          nklo, nkhi, nkplo, nkphi,  &
                          caintv, sexpintv, xaintv, uexpintv,  &
                          approxint_guess1)
 
!-------------------------------------------------------------------
!    6) compute interp transmission function using Eq.(3),
!       Ref.(2).
!-------------------------------------------------------------------
          if (nprofile .EQ. 1) then
            do k=nklo,nkhi
              do kp=k+nkplo,nkphi
                trns_interp_lvl_ps(kp,k) = 1.0 -  &
                        (errorint_guess1(kp,k) + approxint_guess1(kp,k))
                trns_interp_lvl_ps(k,kp) = trns_interp_lvl_ps(kp,k)
              enddo
            enddo
          else
            do k=nklo,nkhi
              do kp=k+nkplo,nkphi
                trns_interp_lvl_ps8(kp,k) = 1.0 -  &
                        (errorint_guess1(kp,k) + approxint_guess1(kp,k))
                trns_interp_lvl_ps8(k,kp) = trns_interp_lvl_ps8(kp,k)
              enddo
            enddo
          endif  
        enddo  ! (nprofile loop)
      endif
 
      if (do_lyrcalc) then
!-------------------------------------------------------------------
!    allocate arrays used for layer calculations
!-------------------------------------------------------------------
        allocate ( sexpnblv(51,KERAD+1) )
        allocate ( uexpnblv(51,KERAD+1) )
        allocate ( canblv(51,KERAD+1) )
        allocate ( xanblv(51,KERAD+1) )
        allocate ( pressnbl_lov(51,KERAD+1) )
        allocate ( pressnbl_hiv(51,KERAD+1) )
        allocate ( indx_pressnbl_lov(51,KERAD+1) )
        allocate ( indx_pressnbl_hiv(51,KERAD+1) )
        allocate ( approxnbl_guess1(51,KERAD+1) )
        allocate ( errornbl_guess1(51,KERAD+1) )
 
!-------------------------------------------------------------------
!    A): calculate, for (kp,k) pairs with kp > k, a set of 7 transmis-
!    sivities, with the values of p'(kp) encompassing the layer bounded
!    by (pd(kp-1),pd(kp)). the weighted average of these is the layer-
!    averaged transmissivity (trns_interp_lyr_ps(8)(kp,k)).
!    B): calculate, for (kp,k) pairs with kp < k, a set of 7 transmis-
!    sivities, with the values of p'(kp) encompassing the layer bounded
!    by (pd(kp-1),pd(kp)). the weighted average of these is the layer-
!    averaged transmissivity (trns_interp_lyr_ps(8)(kp,k)).
!    C): calculate, for pairs (kp,kp) with kp > 1, a set of 51 transmis-
!    sivities, with the values of p'(kp) encompassing the layer bounded
!    by (pd(kp-1),pd(kp)). the weighted average of these is the layer-
!    averaged transmissivity (trns_interp_lyr_ps(8)(kp,k)).
!
!    note: one of the 7 (or 51) transmissivities equals the level
!    transmissivity (trns_interp_lvl_ps(8))
!
!    initialize the layer transmissivities to zero (summing later)
!    except the (1,1), which are set to 1
!-------------------------------------------------------------------
        trns_interp_lyr_ps = 0.0
        trns_interp_lyr_ps8 = 0.0
        trns_interp_lyr_ps(1,1) = 1.0
        trns_interp_lyr_ps8(1,1) = 1.0
 
!-------------------------------------------------------------------
!   case A): (kp) levels are at higher pressure, hence are used for
!            pressint_hiv. the (fixed) (k) levels are used for
!            pressint_lov
!-------------------------------------------------------------------
        do_triangle = .true.
        nklo = KSRAD
        nkhi = KERAD
        nkplo = KSRAD
        nkphi = KERAD + 1
 
!-------------------------------------------------------------------
!    3) derive the pressures for interpolation using Eqs. (8a-b)
!       in Ref.(2).
!-------------------------------------------------------------------
        do nprofile = 1,2
          do nq = 1,7
            if (nprofile .EQ. 1) then
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  pressint_hiv(kp,k) = pd(kp-1) + (nq-1)*  &
                                       (pd(kp) - pd(kp-1))/6
                  pressint_lov(kp,k) = plm(k)
                enddo
              enddo
            else
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  pressint_hiv(kp,k) = pd8(kp-1) + (nq-1)*  &
                                       (pd8(kp) - pd8(kp-1))/6
                  pressint_lov(kp,k) = plm8(k)
                enddo
              enddo
            endif
            call intcoef_2d (pressint_hiv, pressint_lov, do_triangle,  &
                             nklo, nkhi, nkplo, nkphi,  &
                             indx_pressint_hiv, indx_pressint_lov,  &
                             caintv, sexpintv, xaintv, uexpintv)

!-------------------------------------------------------------------
!    4) interpolate error function to (pressint_hiv, pressint_lov)
!       for relevant (k',k)
!-------------------------------------------------------------------
            call interp_error (error_guess1, pressint_hiv, &
                               pressint_lov, indx_pressint_hiv,  &
                               indx_pressint_lov, do_triangle,  &
                               nklo, nkhi, nkplo, nkphi,  &
                               errorint_guess1)
 
!-------------------------------------------------------------------
!    5) compute approx function for (pressint_hiv, pressint_lov)
!       the call (and calculations) to pathv2 has been subsumed 
!       into subroutine approx_fn
!-------------------------------------------------------------------
            call approx_fn (pressint_hiv, pressint_lov, do_triangle,  &
                            nklo, nkhi, nkplo, nkphi,  &
                            caintv, sexpintv, xaintv, uexpintv,  &
                            approxint_guess1)
 
!-------------------------------------------------------------------
!    6) compute interp transmission function using Eq.(3),
!       Ref.(2).
!-------------------------------------------------------------------
            if (nprofile .EQ. 1) then
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  trns_interp_lyr_ps(kp,k) = trns_interp_lyr_ps(kp,k) +&
                                             wgt_lyr(nq)*(1.0 -   &
                                             (errorint_guess1(kp,k) +  &
                                             approxint_guess1(kp,k)))
 
!-------------------------------------------------------------------
!    for the case (nq=4), where  (pressint_hiv(kp,k) = plm(kp)) use
!    the (kp,1) unweighted values (errorint + approxint) for
!    the (1,kp) transmissivity, otherwise uncalculated. (exception:
!    when kp = nkphi, the (nq=7) value must be used)
!-------------------------------------------------------------------
                  if (nq .EQ. 4 .AND. k .EQ. nklo) then
                    trns_interp_lyr_ps(nklo,kp) = 1.0 -  &
                       (errorint_guess1(kp,k) + approxint_guess1(kp,k))
                  endif
                enddo
              enddo
              if (nq .EQ. 7) then
                trns_interp_lyr_ps(nklo,nkphi) = 1.0 -  &
                                     (errorint_guess1(nkphi,nklo) +   &
                                      approxint_guess1(nkphi,nklo))
              endif
            else
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  trns_interp_lyr_ps8(kp,k) = &
                                         trns_interp_lyr_ps8(kp,k) +  &
                                         wgt_lyr(nq)*(1.0 -  &
                       (errorint_guess1(kp,k) + approxint_guess1(kp,k)))
 
!-------------------------------------------------------------------
!    for the case (nq=4), where  (pressint_hiv(kp,k) = plm(kp)) use
!    the (kp,1) unweighted values (errorint + approxint) for
!    the (1,kp) transmissivity, otherwise uncalculated. (exception:
!    when kp = nkphi, the (nq=7) value must be used)
!
!-------------------------------------------------------------------
                  if (nq .EQ. 4 .AND. k .EQ. nklo) then
                    trns_interp_lyr_ps8(nklo,kp) = 1.0 -  &
                        (errorint_guess1(kp,k) + approxint_guess1(kp,k))
                  endif
                enddo
              enddo
              if (nq .EQ. 7) then
                trns_interp_lyr_ps8(nklo,nkphi) = 1.0 -  &
                                     (errorint_guess1(nkphi,nklo) +   &
                                      approxint_guess1(nkphi,nklo))
              endif
            endif
          enddo
        enddo

!-------------------------------------------------------------------
!    case B): (k) levels are at higher pressure, hence are used for
!             pressint_hiv. the (variable) (kp) levels are used for
!             pressint_lov. (kp,k) calculations are loaded into
!             (k,kp) array locations to keep calculations into the
!             "upper sandwich". results are then put into their proper
!             array locations (before weighting function is applied).
!             also, no calculations are made for (1,k). these values
!             are obtained from level calcs for (k,1), nq=4.
!-------------------------------------------------------------------
        do_triangle = .true.
        nklo = KSRAD+1
        nkhi = KERAD
        nkplo = KSRAD
        nkphi = KERAD + 1

!-------------------------------------------------------------------
!    3) derive the pressures for interpolation using Eqs. (8a-b)
!       in Ref.(2).
!-------------------------------------------------------------------
        do nprofile = 1,2
          do nq = 1,7
            if (nprofile .EQ. 1) then
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  pressint_hiv(kp,k) = plm(kp)
                  pressint_lov(kp,k) = pd(k-1) + (nq-1)*  &
                                       (pd(k) - pd(k-1))/6
                enddo
              enddo
            else
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  pressint_hiv(kp,k) = plm8(kp)
                  pressint_lov(kp,k) = pd8(k-1) + (nq-1)*  &
                                       (pd8(k) - pd8(k-1))/6
                enddo
              enddo
            endif
            call intcoef_2d (pressint_hiv, pressint_lov, do_triangle,  &
                             nklo, nkhi, nkplo, nkphi,  &
                             indx_pressint_hiv, indx_pressint_lov,  &
                             caintv, sexpintv, xaintv,uexpintv)

!-------------------------------------------------------------------
!    4) interpolate error function to (pressint_hiv, pressint_lov)
!       for relevant (k',k)
!-------------------------------------------------------------------
            call interp_error (error_guess1, pressint_hiv,    &
                               pressint_lov, indx_pressint_hiv,   &
                               indx_pressint_lov, do_triangle,  &
                               nklo, nkhi, nkplo, nkphi,  &
                               errorint_guess1)
 
!-------------------------------------------------------------------
!    5) compute approx function for (pressint_hiv, pressint_lov)
!       the call (and calculations) to pathv2 has been subsumed 
!       into subroutine approx_fn
!-------------------------------------------------------------------
            call approx_fn (pressint_hiv, pressint_lov, do_triangle,  &
                            nklo, nkhi, nkplo, nkphi,  &
                            caintv, sexpintv, xaintv, uexpintv,  &
                            approxint_guess1)
 
!-------------------------------------------------------------------
!    6) compute interp transmission function using Eq.(3),
!       Ref.(2).
!-------------------------------------------------------------------
            if (nprofile .EQ. 1) then
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  trns_interp_lyr_ps(k,kp) = trns_interp_lyr_ps(k,kp) +&
                                             wgt_lyr(nq)*(1.0 -  &
                       (errorint_guess1(kp,k) + approxint_guess1(kp,k)))
                enddo
              enddo
            else
              do k=nklo,nkhi
                do kp=k+nkplo,nkphi
                  trns_interp_lyr_ps8(k,kp) =    &
                                         trns_interp_lyr_ps8(k,kp) +  &
                                         wgt_lyr(nq)*(1.0 -  &
                       (errorint_guess1(kp,k) + approxint_guess1(kp,k)))
                enddo
              enddo
            endif
          enddo ! (nq loop)
        enddo   ! (nprofile loop)

!-------------------------------------------------------------------
!    C): calculate, for pairs (kp,kp) with kp > 1, a set of 51 transmis-
!    sivities, with the values of p'(kp) encompassing the layer bounded
!    by (pd(kp-1),pd(kp)). the weighted average of these is the layer-
!    averaged transmissivity (trns_interp_lyr_ps(8)(kp,k)).
!    case C): (kp) levels are at higher pressure, hence are used for
!           pressint_hiv. the (fixed) (k) levels are used for
!           pressint_lov
!-------------------------------------------------------------------
        do_triangle = .false.
        nklo = KSRAD + 1
        nkhi = KERAD + 1 
        nkplo = 1
        nkphi = 51

!-------------------------------------------------------------------
!    3) derive the pressures for interpolation using Eqs. (8a-b)
!       in Ref.(2).
!-------------------------------------------------------------------
        do nprofile = 1,2
          if (nprofile .EQ. 1) then
            do k=nklo,nkhi-1
              do kp=1,25
                pressnbl_lov(kp,k) = pd(k-1) + (kp-1)*  &
                                     (pd(k) - pd(k-1))/50
                pressnbl_hiv(kp,k) = plm(k)
              enddo
              pressnbl_lov(26,k) = plm(k)
              pressnbl_hiv(26,k) = plm(k) + 1.0E-13*plm(k)
              do kp=27,51
                pressnbl_hiv(kp,k) = pd(k-1) + (kp-1)*  &
                                     (pd(k) - pd(k-1))/50
                pressnbl_lov(kp,k) = plm(k)
              enddo
            enddo
            do kp=1,50
              pressnbl_lov(kp,nkhi) = pd(nkhi-1) + (kp-1)*  &
                                      (pd(nkhi) - pd(nkhi-1))/50
              pressnbl_hiv(kp,nkhi) = plm(nkhi)
            enddo
            pressnbl_lov(51,nkhi) = plm(nkhi)
            pressnbl_hiv(51,nkhi) = plm(nkhi) + 1.0E-13*plm(nkhi)
          else
            do k=nklo,nkhi-1
              do kp=1,25
                pressnbl_lov(kp,k) = pd8(k-1) + (kp-1)*  &
                                     (pd8(k) - pd8(k-1))/50
                pressnbl_hiv(kp,k) = plm8(k)
              enddo
              pressnbl_lov(26,k) = plm8(k)
              pressnbl_hiv(26,k) = plm8(k) + 1.0E-13*plm8(k)
              do kp=27,51
                pressnbl_hiv(kp,k) = pd8(k-1) + (kp-1)*  &
                                     (pd8(k) - pd8(k-1))/50
                pressnbl_lov(kp,k) = plm8(k)
              enddo
            enddo
            do kp=1,50
              pressnbl_lov(kp,nkhi) = pd8(nkhi-1) + (kp-1)*  &
                                      (pd8(nkhi) - pd8(nkhi-1))/50
              pressnbl_hiv(kp,nkhi) = plm8(nkhi)
            enddo
            pressnbl_lov(51,nkhi) = plm8(nkhi)
            pressnbl_hiv(51,nkhi) = plm8(nkhi) + 1.0E-13*plm8(nkhi)
          endif
          call intcoef_2d (pressnbl_hiv, pressnbl_lov, do_triangle,  &
                           nklo, nkhi, nkplo, nkphi,  &
                           indx_pressnbl_hiv, indx_pressnbl_lov,  &
                           canblv, sexpnblv, xanblv, uexpnblv)

!-------------------------------------------------------------------
!    4) interpolate error function to (pressnbl_hiv, pressnbl_lov)
!       for relevant (k',k)
!-------------------------------------------------------------------
          call interp_error (error_guess1, pressnbl_hiv, pressnbl_lov,&
                             indx_pressnbl_hiv, indx_pressnbl_lov,  &
                             do_triangle, nklo, nkhi, nkplo, nkphi,  &
                             errornbl_guess1)
 
!-------------------------------------------------------------------
!    5) compute approx function for (pressnbl_hiv, pressnbl_lov)
!       the call (and calculations) to pathv2 has been subsumed 
!       into subroutine approx_fn
!-------------------------------------------------------------------
          call approx_fn (pressnbl_hiv, pressnbl_lov, do_triangle,  &
                          nklo, nkhi, nkplo, nkphi,  &
                          canblv, sexpnblv, xanblv, uexpnblv,  &
                          approxnbl_guess1)
 
!-------------------------------------------------------------------
!    6) compute interp transmission function using Eq.(3),
!       Ref.(2).
!-------------------------------------------------------------------
          if (nprofile .EQ. 1) then
            do k=nklo,nkhi
              do kp=1,51
                trns_interp_lyr_ps(k,k) = trns_interp_lyr_ps(k,k) +  &
                                           wgt_nearby_lyr(kp)*   &
                (1.0 - (errornbl_guess1(kp,k) + approxnbl_guess1(kp,k)))
              enddo
            enddo
          else
            do k=nklo,nkhi
              do kp=1,51
                trns_interp_lyr_ps8(k,k) = trns_interp_lyr_ps8(k,k) +  &
                                            wgt_nearby_lyr(kp)*   &
                (1.0 - (errornbl_guess1(kp,k) + approxnbl_guess1(kp,k)))
              enddo
            enddo
          endif
        enddo    ! (nprofile loop)

!-------------------------------------------------------------------
!    deallocate arrays used for layer calculations
!-------------------------------------------------------------------
        deallocate ( sexpnblv )
        deallocate ( uexpnblv )
        deallocate ( canblv )
        deallocate ( xanblv )
        deallocate ( pressnbl_lov )
        deallocate ( pressnbl_hiv )
        deallocate ( indx_pressnbl_lov )
        deallocate ( indx_pressnbl_hiv )
        deallocate ( approxnbl_guess1 )
        deallocate ( errornbl_guess1 )
      endif

!-------------------------------------------------------------------
!      deallocate arrays with user-defined k-extents
!-------------------------------------------------------------------
      deallocate ( pressint_hiv )
      deallocate ( pressint_lov )
      deallocate ( indx_pressint_hiv )
      deallocate ( indx_pressint_lov )
      deallocate ( caintv )
      deallocate ( sexpintv )
      deallocate ( xaintv )
      deallocate ( uexpintv )
      deallocate ( errorint_guess1 )
      deallocate ( approxint_guess1 )
      deallocate (error_guess1)
      deallocate (trns_vmr)

!---------------------------------------------------------------------


end subroutine gasint


!#####################################################################
! <SUBROUTINE NAME="coeint">
!  <OVERVIEW>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method
!  </DESCRIPTION>
!  <TEMPLATE>
!   call coeint (gas_type, nf, trns_val, ca, sexp, xa, uexp)
!  </TEMPLATE>
!  <IN NAME="gas_type" TYPE="character">
!   Gas type information
!  </IN>
!  <IN NAME="nf" TYPE="integer">
!   number of frequency band
!  </IN>
!  <IN NAME="trns_val" TYPE="real">
!   transmission function array
!  </IN>
!  <OUT NAME="ca, xa, sexp, uexp" TYPE="real">
!   coefficients in the transmission function between two pressure
!   levels
!  </OUT>
! </SUBROUTINE>
!
subroutine coeint (gas_type, nf, trns_val, ca, sexp, xa, uexp)

!-------------------------------------------------------------------
!    the transmission function between p1 and p2 is assumed to
!    have the  functional form
!         tau(p1,p2)= 1.0-(c*log(1.0+x*path**delta))**(gamma/delta),
!    where
!         path(p1,p2)=(p1-p2)**2)*(p1+p2+dop_core)
!         and p2 is the larger of the two pressures (p1,p2).

!    the coefficients c and x are functions of p2, while dop_core,
!    gamma and delta are predetermined coefficients.
!    (delta,gamma are uexp,sexp in this code).
!    subroutine coeint determines c(i) and x(i) by using actual
!    values of tau(p(i-2),p(i)) and tau(p(i-1),p(i)), obtained
!    from line-by-line calculations.
!    define: 
!             patha=(path(p(i),p(i-2),dop_core)**delta
!             pathb=(path(p(i),p(i-1),dop_core)**delta;
!    then
!         r=(1-tau(p(i),p(i-2)))/(1-tau(p(i),p(i-1)))
!          = (log(1+x(p(i))*patha)/log(1+x(p(i))*pathb))**(gamma/delta),
!    since   c(p(i)) cancels out
!    so that
!           r**(delta/gamma)= log(1+x(p(i))*patha)/log(1+x(p(i))*pathb).
!    this equation is solved by newton's method for x and then the
!    result used to find c. this is repeated for each value of i 
!    greater than 2 to give the arrays x(i), c(i).
!    there are several possible pitfalls: 
!       1) in the course of iteration, x may reach a value which makes
!          1+x*patha negative; in this case the iteration is stopped,
!          and an error message is printed out.
!       2) even if (1) does not occur, it is still possible that x may
!          be negative and large enough to make
!          1+x*path(p(i),0,dop_core) negative. this is checked in
!          a final loop, and if true,a warning is printed out.
!-----------------------------------------------------------------

character(len=*),       intent(in)  :: gas_type
real, dimension(:,:),   intent(in)  :: trns_val
integer,                intent(in)  :: nf
real, dimension(:),     intent(out) :: ca, xa, sexp, uexp

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      gas_type
!
!-------------------------------------------------------------------

!-----------------------------------------------------------------
!   local variables
      real, dimension(:), allocatable    :: upath0, upatha, upathb,   &
                                            pam1, pam2, pa0, pr_hi, r, &
                                            rexp, f, f1, f2, fprime, &
                                            ftest1, ftest2, xx, xxlog,&
                                            pa2
      integer     :: k, ll
      real        :: check

!-----------------------------------------------------------------
!   local variables
! 
!     upath0
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    allocate local variables
!--------------------------------------------------------------------
      allocate ( upath0  (NSTDCO2LVLS) )
      allocate ( upatha  (NSTDCO2LVLS) )
      allocate ( upathb  (NSTDCO2LVLS) )
      allocate ( pam1    (NSTDCO2LVLS) )
      allocate ( pam2    (NSTDCO2LVLS) )
      allocate ( pa0     (NSTDCO2LVLS) )
      allocate ( pr_hi   (NSTDCO2LVLS) )
      allocate ( r       (NSTDCO2LVLS) )
      allocate ( rexp    (NSTDCO2LVLS) )
      allocate ( f       (NSTDCO2LVLS) )
      allocate ( f1      (NSTDCO2LVLS) )
      allocate ( f2      (NSTDCO2LVLS) )
      allocate ( fprime  (NSTDCO2LVLS) )
      allocate ( ftest1  (NSTDCO2LVLS) )
      allocate ( ftest2  (NSTDCO2LVLS) )
      allocate ( xx      (NSTDCO2LVLS) )
      allocate ( xxlog   (NSTDCO2LVLS) )
      allocate ( pa2     (NSTDCO2LVLS) )

!--------------------------------------------------------------------
!    the following specifications for dop_core, sexp and uexp follow
!    "try9", which has (as of 5/27/97) been found to produce the
!    most accurate co2 40 level 490-850 cm-1 transmissivities, when
!    compared to LBL calculations over the same frequencies and 
!    vertical structure.
!--------------------------------------------------------------------
      if (gas_type .EQ. 'co2') then
        if (nf .eq. 1) dop_core = dop_core0
        if (nf .eq. 2) dop_core = dop_core0*560./670.
        if (nf .eq. 3) dop_core = dop_core0*665./670.
        if (nf .eq. 4) dop_core = dop_core0*775./670.
        if (nf .eq. 5) dop_core = dop_core0*2325./670.
      endif
      if (gas_type .EQ. 'ch4') then
        if (nf .eq. 1) dop_core = dop_core0*1300./670.
      endif
      if (gas_type .EQ. 'n2o') then
        if (nf .eq. 1) dop_core = dop_core0*1300./670.
        if (nf .eq. 2) dop_core = dop_core0*1135./670.
        if (nf .eq. 3) dop_core = dop_core0*595./670.
      endif
 
      do k=1,NSTDCO2LVLS
        pa2(k)=pa(k)*pa(k)
        sexp(k)=.505+2.0e-5*pa(k)+.035*(pa2(k)-.25)/(pa2(k)+.25)
        uexp(k) = sexp(k)*(1.0 + 0.33*pa2(k)/(pa2(k) + 40000.))
      enddo
 
      do k=1,NSTDCO2LVLS
        pr_hi(k) = pa(k)
      enddo
      do k=3,NSTDCO2LVLS
        pam1(k) = pa(k-1)
        pam2(k) = pa(k-2)
        pa0(k) = 0.0
      enddo
 
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      call pathv1 (pr_hi, pam1, 3, NSTDCO2LVLS, upathb)
 
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      call pathv1 (pr_hi, pam2, 3, NSTDCO2LVLS, upatha)
 
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do k=3,NSTDCO2LVLS
        r(k) = (1.0 -trns_val(k,k-2))/(1.0 -trns_val(k,k-1))

!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in radiag 
!    file
!       rexp(k) = r(k)**(uexp(k)/sexp(k))
!       upatha(k) = upatha(k)**uexp(k)
!       upathb(k) = upathb(k)**uexp(k)
!------------------------------------------------------------------
        rexp(k) = EXP((uexp(k)/sexp(k))*ALOG(r(k)))
        upatha(k) = EXP(uexp(k)*ALOG(upatha(k)))
        upathb(k) = EXP(uexp(k)*ALOG(upathb(k)))
        xx(k) = 2.0*(upathb(k)*rexp(k) - upatha(k))/   &
                (upathb(k)*upathb(k)*rexp(k) - upatha(k)*upatha(k))
      enddo
      do ll=1,20
        do k=3,NSTDCO2LVLS
          ftest1(k) =xx(k)*upatha(k)
          ftest2(k) =xx(k)*upathb(k)
!--------------------------------------------------------------------
!    end iteration and solve if ftest1 is small or ftest2 is large
!--------------------------------------------------------------------
          if (ftest1(k) .LE. 1.0E-10) then
            xa(k)=1.0
    
!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in radiag 
!    file
!           ca(k)=(1.0 - trns_val(k,k-2))**(uexp(k)/sexp(k))/upatha(k)
!------------------------------------------------------------------
            ca(k)=EXP((uexp(k)/sexp(k))*   &
                  ALOG((1.0 - trns_val(k,k-2))))/upatha(k)
          elseif (ftest2(k) .GE. 1.0E+8) then
            xxlog(k) = (LOG(upatha(k)) - rexp(k)*LOG(upathb(k)))/  &
                        (rexp(k)-1.0 )
            xa(k) = EXP(xxlog(k))

!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in radiag 
!    file
!           ca(k) = (1.0 - trns_val(k,k-2))**(uexp(k)/sexp(k))/  &
!                   (xxlog(k) + LOG(upatha(k)))
!------------------------------------------------------------------
            ca(k)=EXP((uexp(k)/sexp(k))*   &
                  ALOG((1.0 - trns_val(k,k-2))))/   &
                       (xxlog(k) + LOG(upatha(k)))
          else
            f1(k) = LOG(1.0 + xx(k)*upatha(k))
            f2(k) = LOG(1.0 + xx(k)*upathb(k))
            f(k) = f1(k)/f2(k) - rexp(k)
            fprime(k) = (f2(k)*upatha(k)/(1.0 + xx(k)*upatha(k)) -  &
                         f1(k)*upathb(k)/(1.0 + xx(k)*upathb(k)))/  &
                         (f2(k)*f2(k))
            xx(k) = xx(k) - f(k)/fprime(k)
          endif
        enddo
      enddo

!--------------------------------------------------------------------
!    the following if loop is diagnostic only
!--------------------------------------------------------------------
      if (do_coeintdiag) then
        do k=3,NSTDCO2LVLS
          check=1.0 +xx(k)*upatha(k)
          if (check .le. 0.0) then
    write (     *, 360)  k, check
360         format ('check le zero, i=',i3, ' check =',f20.10)
            call error_mesg ('lw_gases_stdtf_mod', &
                             ' error, check le zero', FATAL)
          endif
        enddo
      endif

      do k=3,NSTDCO2LVLS
        if (ftest1(k) .GT. 1.0E-10 .AND. ftest2(k) .LT. 1.0E+8) then
          ca(k) = (1.0 - trns_val(k,k-2))**(uexp(k)/sexp(k))/  &
                  (LOG(1.0 + xx(k)*upatha(k)) + 1.0e-20)
          xa(k) = xx(k)
        endif
      enddo

!----------------------------------------------------------------------
!    by assumption, ca, xa for the first two levels  are
!    equal to the values for the third level.
!----------------------------------------------------------------------
      xa(2)=xa(3)
      xa(1)=xa(3)
      ca(2)=ca(3)
      ca(1)=ca(3)
 
!--------------------------------------------------------------------
!    the following if loop is diagnostic only
!--------------------------------------------------------------------
      if (do_coeintdiag) then
        call pathv1 (pr_hi, pa0, 3, NSTDCO2LVLS, upath0)
        do k=3,NSTDCO2LVLS

!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in radiag 
!    file
!         upath0(k)=upath0(k)**uexp(k)
!------------------------------------------------------------------
          upath0(k)=EXP(uexp(k)*ALOG(upath0(k)))
          upath0(k)=1.0 +xa(k)*upath0(k)
          if (upath0(k).lt.0.)   then
            write (     *, 361) k, upath0(k), xa(k) 
361         format (' 1+xa*path(pa(i),0) is negative,i= ',i3,/  &
                    20x,'upath0(i)=',f16.6,' xa(i)=',f16.6)
            call error_mesg ('lw_gases_stdtf_mod', &
                      '1+xa*path(pa(i),0) is negative', FATAL)
          endif
        enddo
      endif

!--------------------------------------------------------------------
!    deallocate local arrays
!--------------------------------------------------------------------
      deallocate ( upath0   )
      deallocate ( upatha   )
      deallocate ( upathb   )
      deallocate ( pam1     )
      deallocate ( pam2     )
      deallocate ( pa0      )
      deallocate ( pr_hi    )
      deallocate ( r        )
      deallocate ( rexp     )
      deallocate ( f        )
      deallocate ( f1       )
      deallocate ( f2       )
      deallocate ( fprime   )
      deallocate ( ftest1   )
      deallocate ( ftest2   )
      deallocate ( xx       )
      deallocate ( xxlog   )
      deallocate ( pa2      )

!--------------------------------------------------------------------


end subroutine coeint


!#####################################################################
! <SUBROUTINE NAME="intcoef_1d">
!  <OVERVIEW>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method (1 dimensional)
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method (1 dimensional)
!  </DESCRIPTION>
!  <TEMPLATE>
!   call intcoef_1d (press_hi, press_lo, cav, sexpv, xav, uexpv)
!  </TEMPLATE>
!  <IN NAME="press_hi, press_lo" TYPE="real">
!   high and low pressure pair
!  </IN>
!  <OUT NAME="cav, xav, sexpv, uexpv" TYPE="real">
!   coefficients in the transmission function between two pressure
!   levels
!  </OUT>
! </SUBROUTINE>
!
subroutine intcoef_1d (press_hi, press_lo, cav, sexpv, xav, uexpv)
 
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

real, dimension (:), intent(in)  :: press_hi, press_lo
real, dimension (:), intent(out) :: cav, sexpv, xav, uexpv

!--------------------------------------------------------------------
!  intent(in) vaiables:
!
!       press_hi
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

      real,    dimension(:), allocatable :: caxa, ca_hi, prod_hi, &
                                            sexp_hi, uexp_hi, xa_hi
      integer, dimension(:), allocatable :: indx_press_hi, indx_press_lo

      integer         :: k, kp, kpp

!-------------------------------------------------------------------
!  local variables:
!
!      caxa
!
!--------------------------------------------------------------------
!-------------------------------------------------------------------
!    allocate local arrays.
!-------------------------------------------------------------------
      allocate (   caxa   ( NSTDCO2LVLS) )
      allocate (   ca_hi  ( NSTDCO2LVLS) )
      allocate (   prod_hi( NSTDCO2LVLS) )
      allocate (   sexp_hi( NSTDCO2LVLS) )
      allocate (   uexp_hi( NSTDCO2LVLS) )
      allocate (   xa_hi  ( NSTDCO2LVLS) )
      allocate (indx_press_hi( NSTDCO2LVLS) )
      allocate (indx_press_lo( NSTDCO2LVLS) )
 
!---------------------------------------------------------------------
!    compute the index of press_hi and press_lo  corresponding to pa
!---------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        if (press_hi(k) .LT. pa(1)) then
          indx_press_hi(k) = 1
        endif
        if (press_hi(k) .GE. pa(NSTDCO2LVLS)) then
          indx_press_hi(k) = NSTDCO2LVLS - 1
        endif
        if (press_lo(k) .LT. pa(1)) then
          indx_press_lo(k) = 1
        endif
        if (press_lo(k) .GE. pa(NSTDCO2LVLS)) then
          indx_press_lo(k) = NSTDCO2LVLS - 1
        endif
      enddo
      do k=1,NSTDCO2LVLS
        do kpp=1,NSTDCO2LVLS - 1
          if (press_hi(k) .GE. pa(kpp) .AND.  &
              press_hi(k) .LT. pa(kpp+1)) then
            indx_press_hi(k) = kpp
          endif
          if (press_lo(k) .GE. pa(kpp) .AND.  &
              press_lo(k) .LT. pa(kpp+1)) then
            indx_press_lo(k) = kpp
          endif
        enddo
      enddo

!--------------------------------------------------------------------
!    interpolate values of cint, xint, sexp, for the pressures
!    (press_hi)
!--------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        caxa(k) = ca(k)*xa(k)
      enddo
      do k=1,NSTDCO2LVLS
        sexp_hi(k) = sexp(indx_press_hi(k)) +   &
                     (sexp(indx_press_hi(k)+1) -    &
                      sexp(indx_press_hi(k))) /  &
                     (pa  (indx_press_hi(k)+1) -    &
                      pa  (indx_press_hi(k))) *  &
                     (press_hi(k) - pa(indx_press_hi(k)))
        uexp_hi(k) = uexp(indx_press_hi(k)) +   &
                     (uexp(indx_press_hi(k)+1) -    &
                     uexp(indx_press_hi(k))) /  &
                     (pa  (indx_press_hi(k)+1) -    &
                      pa  (indx_press_hi(k))) *  &
                     (press_hi(k) - pa(indx_press_hi(k)))
        prod_hi(k) = caxa(indx_press_hi(k)) +   &
                     (caxa(indx_press_hi(k)+1) -   &
                     caxa(indx_press_hi(k))) /  &
                     (pa  (indx_press_hi(k)+1) -    &
                      pa  (indx_press_hi(k))) *  &
                     (press_hi(k) - pa(indx_press_hi(k)))
        xa_hi(k) = xa(indx_press_hi(k)) +   &
                   (xa(indx_press_hi(k)+1) - xa(indx_press_hi(k))) /  &
                   (pa  (indx_press_hi(k)+1) -     &
                    pa  (indx_press_hi(k))) *  &
                   (press_hi(k) - pa(indx_press_hi(k)))
                   ca_hi(k) = prod_hi(k)/xa_hi(k)
      enddo
 
!-------------------------------------------------------------------
!
!-------------------------------------------------------------------
      do kp=k, NSTDCO2LVLS
        sexpv(kp)     = sexp_hi(kp)
        uexpv(kp)     = uexp_hi(kp)
        cav(kp)     = ca_hi(kp)
        xav(kp)     = xa_hi(kp)
      enddo

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------
      deallocate (   caxa    )
      deallocate (   ca_hi  )
      deallocate (   prod_hi )
      deallocate (   sexp_hi )
      deallocate (   uexp_hi )
      deallocate (   xa_hi   )
      deallocate (indx_press_hi )
      deallocate (indx_press_lo )

!-------------------------------------------------------------------



end subroutine intcoef_1d


!#####################################################################
! <SUBROUTINE NAME="intcoef_2d">
!  <OVERVIEW>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method (2 dimensional)
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method (2 dimensional)
!  </DESCRIPTION>
!  <TEMPLATE>
!   call intcoef_2d (press_hiv, press_lov, do_triangle,  &
!                    nklo, nkhi, nkplo, nkphi,  &
!                    indx_hiv, indx_lov,  &
!                    caintv,  sexpintv, xaintv, uexpintv)
!  </TEMPLATE>
!  <IN NAME="press_hiv, press_lov" TYPE="real">
!   high and low pressure pair
!  </IN>
!  <IN NAME="do_triangle" TYPE="logical">
!   State variable of triangle interpolation scheme
!  </IN>
!  <IN NAME="nklo, nkhi, nkplo, nkphi" TYPE="integer">
!   the high and low level and pressure pairs
!  </IN>
!  <IN NAME="indx_hiv, indx_lov" TYPE="integer">
!   the high and low index pair
!  </IN>
!  <OUT NAME="caintv, xaintv, sexpintv, uexpintv" TYPE="real">
!   coefficients in the transmission function between two pressure
!   levels
!  </OUT>
! </SUBROUTINE>
!
subroutine intcoef_2d (press_hiv, press_lov, do_triangle,  &
                       nklo, nkhi, nkplo, nkphi,  &
                       indx_hiv, indx_lov,  &
                       caintv,  sexpintv, xaintv, uexpintv)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real,    dimension(:,:), intent(out) :: sexpintv, &
                                        uexpintv, caintv, xaintv
integer, dimension(:,:), intent(out) :: indx_hiv, indx_lov
integer,                 intent(in)  :: nklo, nkhi, nkplo, nkphi
real,    dimension(:,:), intent(in)  :: press_hiv, press_lov
logical,                 intent(in)  :: do_triangle

!--------------------------------------------------------------------
!  intent(in) variables:
!
!    sexpintv
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

      real, dimension(:),   allocatable :: caxa
      real, dimension(:,:), allocatable :: sexp_hiv, uexp_hiv, ca_hiv, &
                                           prod_hiv, xa_hiv, d1kp,   &
                                           d2kp, bkp, akp, delp_hi

      integer    :: k, kp, kp0, kpp
      integer    :: k1, k2

!-------------------------------------------------------------------
!  local variables:
!
!      caxa
!
!--------------------------------------------------------------------

!----------------------------------------------------------------
!    obtain array extents for internal arrays and allocate these arrays
!----------------------------------------------------------------
      k1 = size(press_hiv,1)       ! this corresponds to ndimkp
      k2 = size(press_hiv,2)       ! this corresponds to ndimk
      allocate  (caxa (NSTDCO2LVLS) )
      allocate (sexp_hiv(k1,k2),    &
                uexp_hiv(k1,k2),    &
                ca_hiv(k1,k2)  ,    &
                prod_hiv(k1,k2),    &
                xa_hiv(k1,k2)  ,    &
                d1kp(k1,k2)    ,    &
                d2kp(k1,k2)    ,    &
                bkp(k1,k2)     ,    &
                akp(k1,k2)     ,    &
                delp_hi(k1,k2)      )

!---------------------------------------------------------------------
!    compute the index of the inputted pressures (press_hiv,
!    press_lov) corresponding to the standard (pa) pressures.
!---------------------------------------------------------------------
      do k=nklo,nkhi
        if (do_triangle) then
          kp0 = k + nkplo
        else
          kp0 = nkplo
        endif
        do kp=kp0,nkphi
          if (press_hiv(kp,k) .LT. pa(1)) then
            indx_hiv(kp,k) = 1
          endif
          if (press_hiv(kp,k) .GE. pa(NSTDCO2LVLS)) then
            indx_hiv(kp,k) = NSTDCO2LVLS - 1
          endif
          if (press_lov(kp,k) .LT. pa(1)) then
            indx_lov(kp,k) = 1
          endif
          if (press_lov(kp,k) .GE. pa(NSTDCO2LVLS)) then
            indx_lov(kp,k) = NSTDCO2LVLS - 1
          endif
        enddo
      enddo

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

      do k=nklo,nkhi
        if (do_triangle) then
          kp0 = k + nkplo
        else
          kp0 = nkplo
        endif
        do kp=kp0,nkphi
          do kpp=1,NSTDCO2LVLS - 1
            if (press_hiv(kp,k) .GE. pa(kpp) .AND.  &
                press_hiv(kp,k) .LT. pa(kpp+1)) then
              indx_hiv(kp,k) = kpp
              exit
            endif
          enddo
          do kpp=1,NSTDCO2LVLS - 1
            if (press_lov(kp,k) .GE. pa(kpp) .AND.  &
                press_lov(kp,k) .LT. pa(kpp+1)) then
              indx_lov(kp,k) = kpp
              exit
            endif
          enddo
        enddo
      enddo
 
!---------------------------------------------------------------------
!    interpolate values of cint, xint, sexp, uexp for the pressures
!    (press_hiv)
!--------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        caxa(k) = ca(k)*xa(k)
      enddo
      do k=nklo,nkhi
        if (do_triangle) then
          kp0 = k + nkplo
        else
          kp0 = nkplo
        endif
        do kp=kp0,nkphi
          sexp_hiv(kp,k) = sexp(indx_hiv(kp,k)) +   &
                   (sexp(indx_hiv(kp,k)+1) - sexp(indx_hiv(kp,k))) /  &
                   (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                   (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
           uexp_hiv(kp,k) = uexp(indx_hiv(kp,k)) +   &
                   (uexp(indx_hiv(kp,k)+1) - uexp(indx_hiv(kp,k))) /  &
                   (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                   (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
 
!--------------------------------------------------------------------
!    use 3-point interpolation: (indx_hiv of 1 or 2 are excluded
!    since ca and xa were arbitrarily set to ca(3),xa(3))
!--------------------------------------------------------------------
          if (indx_hiv(kp,k) .GT. 2 .AND.                        &
              indx_hiv(kp,k) .LT. NSTDCO2LVLS - 1) then     
            delp_hi(kp,k) =                           &
                 press_hiv(kp,k) - pa(indx_hiv(kp,k)+1)

!------------------------------------------------------------------
!    interpolate xa
!------------------------------------------------------------------
            d1kp(kp,k) =   &
              (xa(indx_hiv(kp,k)+2) - xa(indx_hiv(kp,k)+1)) /  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            d2kp(kp,k) =   &
              (xa(indx_hiv(kp,k)+1) -  xa(indx_hiv(kp,k) )) /  &
              (pa(indx_hiv(kp,k)+1) - pa(indx_hiv(kp,k)  ))
            bkp(kp,k) = (d1kp(kp,k) - d2kp(kp,k))/  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)  ))
            akp(kp,k) = d1kp(kp,k) - bkp(kp,k)*  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            xa_hiv(kp,k) =   &
              xa(indx_hiv(kp,k)+1) +                     &
              delp_hi(kp,k)*(akp(kp,k) + delp_hi(kp,k)*bkp(kp,k))

!----------------------------------------------------------------------
!    if xa_hiv is negative or zero, the interpolation fails and
!    the model may bomb. to avoid this, use 2-point interpolation
!    in this case. the 3-point interpolation for prod_hiv is
!    stable, so there is no need to change this calculation.
!----------------------------------------------------------------------
            if (xa_hiv(kp,k) .LE. 0.0E+00) then                 
              xa_hiv(kp,k) = xa(indx_hiv(kp,k)) +                  &
                 (xa(indx_hiv(kp,k)+1) - xa(indx_hiv(kp,k))) /     &
                 (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *   &
                          (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
            endif
 
!----------------------------------------------------------------------
!    interpolate caxa
!----------------------------------------------------------------------
            d1kp(kp,k) =   &
              (caxa(indx_hiv(kp,k)+2) - caxa(indx_hiv(kp,k)+1)) /  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            d2kp(kp,k) =   &
              (caxa(indx_hiv(kp,k)+1) -  caxa(indx_hiv(kp,k) )) /  &
              (pa(indx_hiv(kp,k)+1) - pa(indx_hiv(kp,k)  ))
            bkp(kp,k) = (d1kp(kp,k) - d2kp(kp,k))/  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)  ))
            akp(kp,k) = d1kp(kp,k) - bkp(kp,k)*  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            prod_hiv(kp,k) =   &
              caxa(indx_hiv(kp,k)+1) +  &
                delp_hi(kp,k)*(akp(kp,k) + delp_hi(kp,k)*bkp(kp,k))
          else
            prod_hiv(kp,k) = caxa(indx_hiv(kp,k)) +   &
               (caxa(indx_hiv(kp,k)+1) - caxa(indx_hiv(kp,k))) /  &
               (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                          (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
            xa_hiv(kp,k) = xa(indx_hiv(kp,k)) +   &
               (xa(indx_hiv(kp,k)+1) - xa(indx_hiv(kp,k))) /  &
               (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                          (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
          endif

!---------------------------------------------------------------------
!    compute ca
!---------------------------------------------------------------------
          ca_hiv(kp,k) = prod_hiv(kp,k)/xa_hiv(kp,k)
        enddo
      enddo
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do k=nklo,nkhi
        if (do_triangle) then
          kp0 = k + nkplo
        else
          kp0 = nkplo
        endif
        do kp=kp0,nkphi
          sexpintv(kp,k)     = sexp_hiv(kp,k)
          uexpintv(kp,k)     = uexp_hiv(kp,k)
          caintv(kp,k)     = ca_hiv(kp,k)
          xaintv(kp,k)     = xa_hiv(kp,k)
        enddo
      enddo

!--------------------------------------------------------------------- 
!    deallocate local arrays
!--------------------------------------------------------------------- 
      deallocate (sexp_hiv,    &
                  uexp_hiv,    &
                  ca_hiv  ,    &
                  prod_hiv,    &
                  xa_hiv  ,    &
                  d1kp    ,    &
                  d2kp    ,    &
                  bkp     ,    &
                  akp     ,    &
                  caxa,        &
                  delp_hi      )

!---------------------------------------------------------------------

end subroutine intcoef_2d


!#####################################################################
! <SUBROUTINE NAME="intcoef_2d_std">
!  <OVERVIEW>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method (2 dimensional)
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to inverse coefficients from transmission functions
!   using newton method (2 dimensional)
!  </DESCRIPTION>
!  <TEMPLATE>
!   call intcoef_2d (press_hiv, press_lov, nf, nt, do_triangle,  &
!                    indx_hiv, indx_lov,  &
!                    caintv,  sexpintv, xaintv, uexpintv)
!  </TEMPLATE>
!  <IN NAME="press_hiv, press_lov" TYPE="real">
!   high and low pressure pair
!  </IN>
!  <IN NAME="nf" TYPE="integer">
!   number of frequency bands
!  </IN>
!  <IN NAME="nt" TYPE="integer">
!   number of temperature values
!  </IN>
!  <IN NAME="do_triangle" TYPE="logical">
!   State variable of triangle interpolation scheme
!  </IN>
!  <IN NAME="nklo, nkhi, nkplo, nkphi" TYPE="integer">
!   the high and low level and pressure pairs
!  </IN>
!  <IN NAME="indx_hiv, indx_lov" TYPE="integer">
!   the high and low index pair
!  </IN>
!  <OUT NAME="caintv, xaintv, sexpintv, uexpintv" TYPE="real">
!   coefficients in the transmission function between two pressure
!   levels
!  </OUT>
! </SUBROUTINE>
!
subroutine intcoef_2d_std (press_hiv, press_lov, nf, nt, do_triangle,  &
                           indx_hiv, indx_lov,  &
                           caintv,  sexpintv, xaintv, uexpintv)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

integer,                 intent(in)   :: nf, nt
real,    dimension(:,:), intent(in)   :: press_hiv, press_lov
logical,                 intent(in)   :: do_triangle
real,    dimension(:,:), intent(out)  :: sexpintv, uexpintv, caintv,  &
                                         xaintv
integer, dimension(:,:), intent(out)  :: indx_hiv, indx_lov

!----------------------------------------------------------------------
!  intent(in) variables:
!
!      nf
!
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!  local variables:

      real, dimension(:,:), allocatable   :: prod_hiv
      real, dimension(:),   allocatable   :: d1kp, d2kp, bkp, akp, &
                                             delp_hi, caxa
      integer         :: k, kp, kp0, kpp
 
!--------------------------------------------------------------------
!  local variables:
!
!     prod_hiv
!
!----------------------------------------------------------------------

!------------------------------------------------------------------
!    allocate local variables
!------------------------------------------------------------------
      allocate ( prod_hiv      (NSTDCO2LVLS, NSTDCO2LVLS) )
      allocate ( d1kp          (NSTDCO2LVLS) )
      allocate ( d2kp          (NSTDCO2LVLS) )
      allocate ( bkp           (NSTDCO2LVLS) )
      allocate ( akp           (NSTDCO2LVLS) )
      allocate ( delp_hi       (NSTDCO2LVLS) )
      allocate ( caxa          (NSTDCO2LVLS) )
 
!--------------------------------------------------------------------
!    compute the index of the inputted pressures (press_hiv,
!    press_lov) corresponding to the standard (pa) pressures.
!    (only calculate if nf = 1, nt = 1)
!--------------------------------------------------------------------
      if (nf .EQ. 1 .AND. nt .EQ. 1) then
        do k=1,NSTDCO2LVLS
          if (do_triangle) then
            kp0 = k + 1
          else
            kp0 = 1
          endif
          do kp=kp0,NSTDCO2LVLS
            if (press_hiv(kp,k) .LT. pa(1)) then
              indx_hiv(kp,k) = 1
            endif
            if (press_hiv(kp,k) .GE. pa(NSTDCO2LVLS)) then
              indx_hiv(kp,k) = NSTDCO2LVLS - 1
            endif
            if (press_lov(kp,k) .LT. pa(1)) then
              indx_lov(kp,k) = 1
            endif
            if (press_lov(kp,k) .GE. pa(NSTDCO2LVLS)) then
              indx_lov(kp,k) = NSTDCO2LVLS - 1
            endif
          enddo
        enddo

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
        do k=1,NSTDCO2LVLS
          if (do_triangle) then
            kp0 = k + 1
          else
            kp0 = 1
          endif
          do kp=kp0,NSTDCO2LVLS
            do kpp=1,NSTDCO2LVLS - 1
              if (press_hiv(kp,k) .GE. pa(kpp) .AND.  &
                  press_hiv(kp,k) .LT. pa(kpp+1)) then
                indx_hiv(kp,k) = kpp
                exit
              endif
            enddo
            do kpp=1,NSTDCO2LVLS - 1
              if (press_lov(kp,k) .GE. pa(kpp) .AND.  &
                  press_lov(kp,k) .LT. pa(kpp+1)) then
                indx_lov(kp,k) = kpp
                exit
              endif
            enddo
          enddo
        enddo
      endif
 
!--------------------------------------------------------------------
!    interpolate values of cint, xint, sexp, uexp for the pressures
!    (press_hiv) (for all values of nf, nt)
!--------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        caxa(k) = ca(k)*xa(k)
      enddo

      do k=1,NSTDCO2LVLS
        if (do_triangle) then
          kp0 = k + 1
        else
          kp0 = 1
        endif
        do kp=kp0,NSTDCO2LVLS
          sexpintv(kp,k) = sexp(indx_hiv(kp,k)) +   &
                  (sexp(indx_hiv(kp,k)+1) - sexp(indx_hiv(kp,k))) /  &
                  (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                        (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
          uexpintv(kp,k) = uexp(indx_hiv(kp,k)) +   &
                  (uexp(indx_hiv(kp,k)+1) - uexp(indx_hiv(kp,k))) /  &
                  (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                        (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
 
!--------------------------------------------------------------------
!    use 3-point interpolation: (indx_hiv of 1 or 2 are excluded
!    since ca and xa were arbitrarily set to ca(3),xa(3))
!--------------------------------------------------------------------
           if (indx_hiv(kp,k) .GT. 2 .AND.  &
              indx_hiv(kp,k) .LT. NSTDCO2LVLS - 1) then     
             delp_hi(kp) =                    &
                 press_hiv(kp,k) - pa(indx_hiv(kp,k)+1)

!---------------------------------------------------------------------
!    interpolate xa
!---------------------------------------------------------------------
            d1kp(kp) =   &
              (xa(indx_hiv(kp,k)+2) - xa(indx_hiv(kp,k)+1)) /  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            d2kp(kp) =   &
              (xa(indx_hiv(kp,k)+1) -  xa(indx_hiv(kp,k) )) /  &
              (pa(indx_hiv(kp,k)+1) - pa(indx_hiv(kp,k)  ))
            bkp(kp) = (d1kp(kp) - d2kp(kp))/  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)  ))
            akp(kp) = d1kp(kp) - bkp(kp)*  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            xaintv(kp,k) =   &
              xa(indx_hiv(kp,k)+1) +  &
                delp_hi(kp)*(akp(kp) + delp_hi(kp)*bkp(kp))

!--------------------------------------------------------------------
!    if xaintv is negative or zero, the interpolation fails and
!    the model may bomb. to avoid this, use 2-point interpolation
!    in this case. the 3-point interpolation for prod_hiv is
!    stable, so there is no need to change this calculation.
!--------------------------------------------------------------------
            if (xaintv(kp,k) .LE. 0.0E+00) then                 
              xaintv(kp,k) = xa(indx_hiv(kp,k)) +                  &
                 (xa(indx_hiv(kp,k)+1) - xa(indx_hiv(kp,k))) /     &
                  (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *   &
                            (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
            endif
 
!-------------------------------------------------------------------
!    interpolate caxa
!-------------------------------------------------------------------
            d1kp(kp) =   &
              (caxa(indx_hiv(kp,k)+2) - caxa(indx_hiv(kp,k)+1)) /  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            d2kp(kp) =   &
              (caxa(indx_hiv(kp,k)+1) -  caxa(indx_hiv(kp,k) )) /  &
              (pa(indx_hiv(kp,k)+1) - pa(indx_hiv(kp,k)  ))
            bkp(kp) = (d1kp(kp) - d2kp(kp))/  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)  ))
            akp(kp) = d1kp(kp) - bkp(kp)*  &
              (pa(indx_hiv(kp,k)+2) - pa(indx_hiv(kp,k)+1))
            prod_hiv(kp,k) =   &
              caxa(indx_hiv(kp,k)+1) +  &
                delp_hi(kp)*(akp(kp) + delp_hi(kp)*bkp(kp))
 
          else
            prod_hiv(kp,k) = caxa(indx_hiv(kp,k)) +   &
                 (caxa(indx_hiv(kp,k)+1) - caxa(indx_hiv(kp,k))) /  &
                  (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                          (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
            xaintv(kp,k) = xa(indx_hiv(kp,k)) +   &
                 (xa(indx_hiv(kp,k)+1) - xa(indx_hiv(kp,k))) /  &
                  (pa  (indx_hiv(kp,k)+1) - pa  (indx_hiv(kp,k))) *  &
                          (press_hiv(kp,k) - pa(indx_hiv(kp,k)))
          endif

!------------------------------------------------------------------
!    compute ca
!------------------------------------------------------------------
          caintv(kp,k) = prod_hiv(kp,k)/xaintv(kp,k)
        enddo  ! (kp loop)
      enddo   ! (k loop)
 
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      deallocate ( prod_hiv     )
      deallocate ( d1kp          )
      deallocate ( d2kp           )
      deallocate ( bkp            )
      deallocate ( akp            )
      deallocate ( delp_hi     )
      deallocate ( caxa           )

!--------------------------------------------------------------------

end subroutine intcoef_2d_std


!#####################################################################
! <SUBROUTINE NAME="interp_error">
!  <OVERVIEW>
!   Subroutine to examine error associated with interpolation onto
!   pressure grids.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to examine error associated with interpolation onto
!   pressure grids.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call interp_error (error, pressint_hiv, pressint_lov,  &
!                         indx_press_hiv, indx_press_lov,  &
!                         do_triangle, nklo, nkhi, nkplo, nkphi,  &
!                         errorint)
!  </TEMPLATE>
!  <IN NAME="error" TYPE="real">
!   interpolation error at standard pa grid. evaluated on
!             a (NSTDCO2LVLS,NSTDCO2LVLS) grid when kp ge k).
!  </IN>
!  <IN NAME="pressint_hiv, pressint_lov" TYPE="real">
!     pressint_hiv = pressure of high(kp) interpolated pressure
!     pressint_lov = pressure of low (kp) interpolated pressure
!  </IN>
!  <IN NAME="indx_press_hiv, indx_press_lov" TYPE="real">
!   indx_press_hiv = pressure on std pa grid of high (kp) pressure
!   indx_press_lov = pressure on std pa grid of low  (kp) pressure
!  </IN>
!  <IN NAME="do_triangle" TYPE="logical">
!   state variable that determines the interpolation scheme
!  </IN>
!  <IN NAME="nkl, nkhi, nkplo, nkphi" TYPE="integer">
!   The index of level and pressure high/low pair
!  </IN>
!  <OUT NAME="errorint" TYPE="real">
!   error at interpolated grid
!  </OUT>
! </SUBROUTINE>
!
subroutine interp_error (error, pressint_hiv, pressint_lov,  &
                         indx_press_hiv, indx_press_lov,  &
                         do_triangle, nklo, nkhi, nkplo, nkphi,  &
                         errorint)

!--------------------------------------------------------------------
!
!---------------------------------------------------------------------

real,    dimension(:,:), intent(in)   :: error,   &
                                         pressint_hiv, pressint_lov
integer, dimension(:,:), intent(in)   :: indx_press_hiv, indx_press_lov
logical,                 intent(in)   :: do_triangle
integer,                 intent(in)   :: nklo, nkhi, nkplo, nkphi
real,    dimension(:,:), intent(out)  :: errorint

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     error
!     press_hiv = pressure on std pa grid of high (kp) pressure
!     pressint_hiv = pressure of high(kp) interpolated pressure
!     error = error ot standard pa grid. evaluated on
!             a (NSTDCO2LVLS,NSTDCO2LVLS) grid when kp ge k).
!     errorint = error at interpolated grid
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension(:,:), allocatable   :: delp_lo, delp_hi, &
                                             d1kp, d2kp, bkp, akp, fkp,&
                                             fkp1, fkp2
      integer        :: k, kp, kp0
      integer        :: k1, k2

!---------------------------------------------------------------------
!  local variables:
!
!    delp_lo
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    obtain array extents for internal arrays and allocate these arrays
!---------------------------------------------------------------------
      k1 = size(pressint_hiv,1)       ! this corresponds to ndimkp
      k2 = size(pressint_hiv,2)       ! this corresponds to ndimk
      allocate (delp_lo(k1,k2) ,    &
                delp_hi(k1,k2) ,    &
                d1kp(k1,k2)    ,    &
                d2kp(k1,k2)    ,    &
                bkp(k1,k2)     ,    &
                akp(k1,k2)     ,    &
                fkp(k1,k2)     ,    &
                fkp1(k1,k2)    ,    &
                fkp2(k1,k2)         )
 
      do k=nklo,nkhi
        if (do_triangle) then
          kp0 = k + nkplo
        else
          kp0 = nkplo
        endif
        do kp=kp0,nkphi
          if (indx_press_hiv(kp,k) - indx_press_lov(kp,k) .GE. 3 .AND. &
              indx_press_hiv(kp,k) .LT. NSTDCO2LVLS - 1         ) then

!---------------------------------------------------------------------
!    use quadratic interpolation:
!---------------------------------------------------------------------
            delp_lo(kp,k) =             &
                 pressint_lov(kp,k) - pa(indx_press_lov(kp,k)+1)

!--------------------------------------------------------------------
!    1) for fixed (kp), varying (k)
!--------------------------------------------------------------------
            d1kp(kp,k) =   &
              (error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+2) -  &
               error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1)  )/  &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            d2kp(kp,k) =   &
              (error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1) -  &
               error(indx_press_hiv(kp,k),indx_press_lov(kp,k)  )  )/  &
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            bkp(kp,k) = (d1kp(kp,k) - d2kp(kp,k))/  &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)  ))
            akp(kp,k) = d1kp(kp,k) - bkp(kp,k)*  &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            fkp(kp,k) =   &
              error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1) +  &
                delp_lo(kp,k)*(akp(kp,k) + delp_lo(kp,k)*bkp(kp,k))

!--------------------------------------------------------------------
!    2) for fixed (kp+1), varying (k)
!--------------------------------------------------------------------
            d1kp(kp,k) =   &
              (error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+2) -  &
               error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1)  )/&
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            d2kp(kp,k) =   &
              (error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1) -  &
               error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)  )  )/&
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  )) 
            bkp(kp,k) = (d1kp(kp,k) - d2kp(kp,k))/    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)  ))
            akp(kp,k) = d1kp(kp,k) - bkp(kp,k)*    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            fkp1(kp,k) =     &
              error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1) +   &
                delp_lo(kp,k)*(akp(kp,k) + delp_lo(kp,k)*bkp(kp,k))

!----------------------------------------------------------------------
!    3) for fixed (kp+2), varying (k)
!----------------------------------------------------------------------
            d1kp(kp,k) =     &
              (error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+2) -  &
               error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+1)  )/&
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            d2kp(kp,k) =     &
              (error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+1) - &
               error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)  )  )/&
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            bkp(kp,k) = (d1kp(kp,k) - d2kp(kp,k))/    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)  ))
            akp(kp,k) = d1kp(kp,k) - bkp(kp,k)*    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            fkp2(kp,k) =     &
              error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+1) +  &
                delp_lo(kp,k)*(akp(kp,k) + delp_lo(kp,k)*bkp(kp,k))

!---------------------------------------------------------------------
!    4) finally, varying (kp) using (fkp,fkp1,fkp2)
!---------------------------------------------------------------------
            delp_hi(kp,k) =     &
                 pressint_hiv(kp,k) - pa(indx_press_hiv(kp,k)+1)
            d1kp(kp,k) =     &
              (fkp2(kp,k) - fkp1(kp,k)) /    &
              (pa(indx_press_hiv(kp,k)+2) - pa(indx_press_hiv(kp,k)+1))
            d2kp(kp,k) =     &
              (fkp1(kp,k) - fkp (kp,k)) /    &
              (pa(indx_press_hiv(kp,k)+1) - pa(indx_press_hiv(kp,k)+0))
            bkp(kp,k) = (d1kp(kp,k) - d2kp(kp,k))/    &
              (pa(indx_press_hiv(kp,k)+2) - pa(indx_press_hiv(kp,k)  ))
            akp(kp,k) = d1kp(kp,k) - bkp(kp,k)*    &
              (pa(indx_press_hiv(kp,k)+2) - pa(indx_press_hiv(kp,k)+1))
            errorint(kp,k) =     &
                             fkp1(kp,k) +     &
              delp_hi(kp,k)*(akp(kp,k) + delp_hi(kp,k)*bkp(kp,k))
 
          elseif (indx_press_hiv(kp,k) .GT. indx_press_lov(kp,k)) then

!--------------------------------------------------------------------
!    use linear interpolation:
!--------------------------------------------------------------------
            delp_lo(kp,k) =     &
                 pressint_lov(kp,k) - pa(indx_press_lov(kp,k))

!--------------------------------------------------------------------
!    1) for fixed (kp), varying (k)
!--------------------------------------------------------------------
            d2kp(kp,k) =     &
              (error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1) -    &
               error(indx_press_hiv(kp,k),indx_press_lov(kp,k)  )  ) / &
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            fkp(kp,k) =     &
                  error(indx_press_hiv(kp,k),indx_press_lov(kp,k)) +  &
                              delp_lo(kp,k)*d2kp(kp,k)

!--------------------------------------------------------------------
!    2) for fixed (kp+1), varying (k)
!--------------------------------------------------------------------
            d2kp(kp,k) =     &
              (error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1) -  &
               error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k) ))/  &
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k) ))
            fkp1(kp,k) =     &
                  error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)) +&
                              delp_lo(kp,k)*d2kp(kp,k)

!--------------------------------------------------------------------
!    3) linear interpolate (fkp,fkp1):
!--------------------------------------------------------------------
            errorint(kp,k) =     &
              (fkp(kp,k)*    &
              (pa(indx_press_hiv(kp,k)+1) - pressint_hiv(kp,k)) +    &
               fkp1(kp,k)*    &
              (pressint_hiv(kp,k) - pa(indx_press_hiv(kp,k))) ) /    &
              (pa(indx_press_hiv(kp,k)+1) - pa(indx_press_hiv(kp,k)))

          else

!---------------------------------------------------------------------
!    the error function for closely-spaced pressures equals zero
!    (section 3.2, Ref. (2))
!---------------------------------------------------------------------
            errorint(kp,k) = 0.0
          endif
        enddo
      enddo

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------
      deallocate (delp_lo ,    &
                  delp_hi ,    &
                  d1kp    ,    &
                  d2kp    ,    &
                  bkp     ,    &
                  akp     ,    &
                  fkp     ,    &
                  fkp1    ,    &
                 fkp2         )

!---------------------------------------------------------------------


end subroutine interp_error



!#####################################################################
! <SUBROUTINE NAME="interp_error_r">
!  <OVERVIEW>
!   Subroutine to examine error associated with interpolation onto
!   pressure grids.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to examine error associated with interpolation onto
!   pressure grids.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call interp_error_r (error, pressint_hiv, pressint_lov,  &
!                         indx_press_hiv, indx_press_lov,  &
!                         do_triangle, errorint)
!  </TEMPLATE>
!  <IN NAME="error" TYPE="real">
!   interpolation error at standard pa grid. evaluated on
!             a (NSTDCO2LVLS,NSTDCO2LVLS) grid when kp ge k).
!  </IN>
!  <IN NAME="pressint_hiv, pressint_lov" TYPE="real">
!     pressint_hiv = pressure of high(kp) interpolated pressure
!     pressint_lov = pressure of low (kp) interpolated pressure
!  </IN>
!  <IN NAME="indx_press_hiv, indx_press_lov" TYPE="real">
!   indx_press_hiv = pressure on std pa grid of high (kp) pressure
!   indx_press_lov = pressure on std pa grid of low  (kp) pressure
!  </IN>
!  <IN NAME="do_triangle" TYPE="logical">
!   state variable that determines the interpolation scheme
!  </IN>
!  <OUT NAME="errorint" TYPE="real">
!   error at interpolated grid
!  </OUT>
! </SUBROUTINE>
!
subroutine interp_error_r (error, pressint_hiv, pressint_lov,    &
                           indx_press_hiv, indx_press_lov,    &
                           do_triangle, errorint)

!-------------------------------------------------------------------
!
!-------------------------------------------------------------------

logical,                 intent(in)   :: do_triangle
real,    dimension(:,:), intent(in)   :: error, pressint_hiv,   &
                                         pressint_lov
integer, dimension(:,:), intent(in)   :: indx_press_hiv, indx_press_lov
real,    dimension(:,:), intent(out)  :: errorint

!--------------------------------------------------------------------
!  intent(in) variables:
!
!    do_triangle
!     press_hiv = pressure on std pa grid of high (kp) pressure
!     pressint_hiv = pressure of high(kp) interpolated pressure
!     error = error at standard pa grid. evaluated on
!             a (NSTDCO2LVLS,NSTDCO2LVLS) grid when kp ge k).
!     errorint = error at interpolated grid
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:

      real, dimension(:), allocatable :: delp_lo, delp_hi, d1kp, d2kp, &
                                         bkp, akp, fkp, d1kp1, d2kp1,  &
                                         bkp1, akp1, fkp1, d1kp2,   &
                                         d2kp2, bkp2, akp2, fkp2,   &
                                         d1kpf, d2kpf, bkpf, akpf
      integer     :: k, kp, kp0
 
!-------------------------------------------------------------------
!   local variables:
!
!     delp_lo
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    allocate local variables
!---------------------------------------------------------------------
      allocate ( delp_lo (NSTDCO2LVLS) )
      allocate ( delp_hi (NSTDCO2LVLS) )
      allocate ( d1kp    (NSTDCO2LVLS) )
      allocate ( d2kp    (NSTDCO2LVLS) )
      allocate ( bkp     (NSTDCO2LVLS) )
      allocate ( akp     (NSTDCO2LVLS) )
      allocate ( fkp     (NSTDCO2LVLS) )
      allocate ( d1kp1   (NSTDCO2LVLS) )
      allocate ( d2kp1   (NSTDCO2LVLS) )
      allocate ( bkp1    (NSTDCO2LVLS) )
      allocate ( akp1    (NSTDCO2LVLS) )
      allocate ( fkp1    (NSTDCO2LVLS) )
      allocate ( d1kp2   (NSTDCO2LVLS) )
      allocate ( d2kp2   (NSTDCO2LVLS) )
      allocate ( bkp2    (NSTDCO2LVLS) )
      allocate ( akp2    (NSTDCO2LVLS) )
      allocate ( fkp2    (NSTDCO2LVLS) )
      allocate ( d1kpf   (NSTDCO2LVLS) )
      allocate ( d2kpf   (NSTDCO2LVLS) )
      allocate ( bkpf    (NSTDCO2LVLS) )
      allocate ( akpf    (NSTDCO2LVLS) )

      do k=1,NSTDCO2LVLS
        if (do_triangle) then
          kp0 = k + 1
        else
          kp0 = 1
        endif
        do kp=kp0,NSTDCO2LVLS
          if (indx_press_hiv(kp,k) - indx_press_lov(kp,k) .GE. 3 .AND. &
              indx_press_hiv(kp,k) .LT. NSTDCO2LVLS - 1         ) then

!---------------------------------------------------------------------
!    use quadratic interpolation:
!---------------------------------------------------------------------
            delp_lo(kp) =     &
                 pressint_lov(kp,k) - pa(indx_press_lov(kp,k)+1)
 
!---------------------------------------------------------------------
!    1) for fixed (kp), varying (k)
!---------------------------------------------------------------------
            d1kp(kp) =     &
              (error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+2) -    &
               error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1)  ) / &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1)) 
            d2kp(kp) =     &
              (error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1) -    &
               error(indx_press_hiv(kp,k),indx_press_lov(kp,k)  )  ) / &
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            bkp(kp) = (d1kp(kp) - d2kp(kp))/    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)  ))
            akp(kp) = d1kp(kp) - bkp(kp)*    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            fkp(kp) =     &
              error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1) +    &
                delp_lo(kp)*(akp(kp) + delp_lo(kp)*bkp(kp))

!---------------------------------------------------------------------
!    2) for fixed (kp+1), varying (k)
!---------------------------------------------------------------------
            d1kp1(kp) =     &
              (error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+2) -  &
               error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1))/  &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            d2kp1(kp) =     &
              (error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1) -  &
               error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k) ) )/  &
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            bkp1(kp) = (d1kp1(kp) - d2kp1(kp))/    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)  ))
            akp1(kp) = d1kp1(kp) - bkp1(kp)*    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            fkp1(kp) =     &
              error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1) +  &
                delp_lo(kp)*(akp1(kp) + delp_lo(kp)*bkp1(kp))
 
!---------------------------------------------------------------------
!    3) for fixed (kp+2), varying (k)
!---------------------------------------------------------------------
            d1kp2(kp) =     &
              (error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+2) -  &
               error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+1)  )/&
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            d2kp2(kp) =     &
              (error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+1) - & 
               error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)  )  )/&
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            bkp2(kp) = (d1kp2(kp) - d2kp2(kp))/    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)  ))
            akp2(kp) = d1kp2(kp) - bkp2(kp)*    &
              (pa(indx_press_lov(kp,k)+2) - pa(indx_press_lov(kp,k)+1))
            fkp2(kp) =     &
              error(indx_press_hiv(kp,k)+2,indx_press_lov(kp,k)+1) +  &
                delp_lo(kp)*(akp2(kp) + delp_lo(kp)*bkp2(kp))
 
!---------------------------------------------------------------------
!    4) finally, varying (kp) using (fkp,fkp1,fkp2)
!---------------------------------------------------------------------
            delp_hi(kp) =     &
                 pressint_hiv(kp,k) - pa(indx_press_hiv(kp,k)+1)
            d1kpf(kp) =     &
              (fkp2(kp) - fkp1(kp)) /    &
              (pa(indx_press_hiv(kp,k)+2) - pa(indx_press_hiv(kp,k)+1))
            d2kpf(kp) =     &
              (fkp1(kp) - fkp (kp)) /    &
              (pa(indx_press_hiv(kp,k)+1) - pa(indx_press_hiv(kp,k)+0))
            bkpf(kp) = (d1kpf(kp) - d2kpf(kp))/    &
              (pa(indx_press_hiv(kp,k)+2) - pa(indx_press_hiv(kp,k)  ))
            akpf(kp) = d1kpf(kp) - bkpf(kp)*    &
              (pa(indx_press_hiv(kp,k)+2) - pa(indx_press_hiv(kp,k)+1))
            errorint(kp,k) =     &
                             fkp1(kp) +     &
              delp_hi(kp)*(akpf(kp) + delp_hi(kp)*bkpf(kp))

          elseif (indx_press_hiv(kp,k) .GT. indx_press_lov(kp,k)) then

!---------------------------------------------------------------------
!    use linear interpolation:
!---------------------------------------------------------------------
            delp_lo(kp) =     &
                 pressint_lov(kp,k) - pa(indx_press_lov(kp,k))
 
!---------------------------------------------------------------------
!    1) for fixed (kp), varying (k)
!---------------------------------------------------------------------
            d2kp(kp) =     &
              (error(indx_press_hiv(kp,k),indx_press_lov(kp,k)+1) -    &
               error(indx_press_hiv(kp,k),indx_press_lov(kp,k)  )  ) / &
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            fkp(kp) =   &
                  error(indx_press_hiv(kp,k),indx_press_lov(kp,k)) +  &
                              delp_lo(kp)*d2kp(kp)

!---------------------------------------------------------------------
!    2) for fixed (kp+1), varying (k)
!---------------------------------------------------------------------
            d2kp1(kp) =   &
              (error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)+1) -  &
               error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)  )  )/&
              (pa(indx_press_lov(kp,k)+1) - pa(indx_press_lov(kp,k)  ))
            fkp1(kp) =   &
                  error(indx_press_hiv(kp,k)+1,indx_press_lov(kp,k)) + &
                              delp_lo(kp)*d2kp1(kp)

!---------------------------------------------------------------------
!    3) linear interpolate (fkp,fkp1):
!---------------------------------------------------------------------
            errorint(kp,k) =   &
              (fkp(kp)*  &
              (pa(indx_press_hiv(kp,k)+1) - pressint_hiv(kp,k)) +  &
               fkp1(kp)*  &
              (pressint_hiv(kp,k) - pa(indx_press_hiv(kp,k))) ) /  &
              (pa(indx_press_hiv(kp,k)+1) - pa(indx_press_hiv(kp,k)))
          else
 
!---------------------------------------------------------------------
!    the error function for closely-spaced pressures equals zero
!    (section 3.2, Ref. (2))
!---------------------------------------------------------------------
            errorint(kp,k) = 0.0
          endif
        enddo
      enddo
 
!---------------------------------------------------------------------
!    deallocate local arrays
!---------------------------------------------------------------------
      deallocate ( delp_lo  )
      deallocate ( delp_hi  )
      deallocate ( d1kp    )
      deallocate ( d2kp     )
      deallocate ( bkp      )
      deallocate ( akp      )
      deallocate ( fkp      )
      deallocate ( d1kp1    )
      deallocate ( d2kp1    )
      deallocate ( bkp1     )
      deallocate ( akp1     )
      deallocate ( fkp1     )
      deallocate ( d1kp2    )
      deallocate ( d2kp2    )
      deallocate ( bkp2     )
      deallocate ( akp2     )
      deallocate ( fkp2     )
      deallocate ( d1kpf    )
      deallocate ( d2kpf    )
      deallocate ( bkpf     )
      deallocate ( akpf     )

!------------------------------------------------------------------
 

end subroutine interp_error_r



!#####################################################################
! <SUBROUTINE NAME="pathv1">
!  <OVERVIEW>
!   Subroutine to compute the path function for the co2 interpolation pgm. 
!   between a pressure (press_lo) and a variable pressure (press_hi)
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute the path function for the co2 interpolation pgm. 
!   between a pressure (press_lo) and a variable pressure (press_hi)
!  </DESCRIPTION>
!  <TEMPLATE>
!   call pathv1 (press_hi, press_lo, ndimlo, ndimhi, upath)
!  </TEMPLATE>
!  <IN NAME="press_hi, press_lo" TYPE="real">
!   The reference pressure levels
!  </IN>
!  <IN NAME="ndimlo, ndimhi" TYPE="integer">
!   the index of pressure level bound
!  </IN>
!  <OUT NAME="upath" TYPE="real">
!   The path function for the co2 interpolation pgm.
!  </OUT>
! </SUBROUTINE>
!
subroutine pathv1 (press_hi, press_lo, ndimlo, ndimhi, upath)
 
!--------------------------------------------------------------------
!    pathv1 computes the path function given in Eqs. (5) and (A5) in
!    Ref. (2) for the co2 interpolation pgm. between a 
!    pressure (press_lo) and a variable pressure (press_hi). This
!    has been modified on 5/27/97.
!--------------------------------------------------------------------
 
real,     dimension (:), intent(in)       :: press_hi, press_lo
real,     dimension (:), intent(out)      :: upath
integer,                 intent(in)       :: ndimlo, ndimhi

!-------------------------------------------------------------------
!   intent(in) variables:
!
!     press_hi
!
!--------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables

      integer      :: k   ! do-loop index

!------------------------------------------------------------------
!
!------------------------------------------------------------------
      do k = ndimlo,ndimhi

!------------------------------------------------------------------
!    all  a(**)b code replaced with exp(b*(alog(a)) code below for 
!    overall ~ 10% speedup in standalone code -- no change in radiag 
!    file
!       upath(k) = (press_hi(k) - press_lo(k))**(1./sexp(k))*   &
!                  (press_hi(k) + press_lo(k) + dop_core)
!------------------------------------------------------------------

        upath(k) = EXP((1./sexp(k))*ALOG((press_hi(k) - press_lo(k))))*&
                   (press_hi(k) + press_lo(k) + dop_core)
      enddo

!---------------------------------------------------------------------

 
end subroutine pathv1




!#####################################################################
! <SUBROUTINE NAME="rctrns">
!  <OVERVIEW>
!   Subroutine to compute co2 transmission functions for actual co2 
!   concentration
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute co2 transmission functions for actual co2 
!   concentration
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rctrns (gas_type, co2_std_lo, co2_std_hi, co2_vmr,  &
!                nf, nt, trns_vmr)
!  </TEMPLATE>
! </SUBROUTINE>
subroutine rctrns (gas_type, co2_std_lo, co2_std_hi, co2_vmr,  &
                   nf, nt, trns_vmr)

!-------------------------------------------------------------------
!    rctrns computes co2 transmission functions for actual co2 
!    concentration using method of section 5, Ref. (2).
!-------------------------------------------------------------------

character(len=*),        intent(in)    :: gas_type
integer,                 intent(in)    :: nf,nt
real,                    intent(in)    :: co2_vmr, co2_std_lo,   &
                                          co2_std_hi
real,    dimension(:,:), intent(inout) :: trns_vmr

!-------------------------------------------------------------------
!  intent(in) variables:
!
!     gas_type
!      co2_std_hi = value of higher std co2 concentration in ppmv
!      co2_std_lo = value of lower std co2 concentration in ppmv
!      co2_vmr   = value of actual co2 concentration in ppmv
!
!-------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension(:,:), allocatable :: approx_guess1,          &
                                           approxint_guess1,       &
                                           approxint_guess2,       &
                                           error_guess1,           &
                                           errorint_guess1,        &
                                           errorint_guess2,        &
                                           trans_guess1,           &
                                           trans_guess2
      real, dimension(:,:), allocatable :: caintv, uexpintv,       &
                                           sexpintv, xaintv,       &
                                           press_hiv, press_lov
      logical do_triangle

!--------------------------------------------------------------------
!  local variables:
!
!     approx_guess1
!
!---------------------------------------------------------------------
     integer :: k, kp
!----------------------------------------------------------------------
!    the first part of the method is to obtain a first guess co2
!    transmission function for the desired concentration using only the
!    co2 tf's for the higher standard concentration.
!----------------------------------------------------------------------
      call coeint (gas_type, nf, trns_std_hi, ca, sexp, xa, uexp)
 
!-------------------------------------------------------------------
!    compute the interpolation. 
!-------------------------------------------------------------------
      do_triangle = .true.

!--------------------------------------------------------------------
!    1) compute approx function at standard (pa) pressures
!--------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        press_hi(k) = pa(k)
        press_lo(k) = pa(k)
      enddo
 
!-------------------------------------------------------------------
!    allocate the 2-d input and output arrays needed to obtain the
!    approx function
!-------------------------------------------------------------------
      allocate ( caintv(NSTDCO2LVLS,NSTDCO2LVLS), &
                 sexpintv(NSTDCO2LVLS,NSTDCO2LVLS), &
                 xaintv(NSTDCO2LVLS,NSTDCO2LVLS), &
                 uexpintv(NSTDCO2LVLS,NSTDCO2LVLS) , &
                 press_hiv(NSTDCO2LVLS,NSTDCO2LVLS), &
                 press_lov(NSTDCO2LVLS,NSTDCO2LVLS) )
      allocate ( approx_guess1(NSTDCO2LVLS,NSTDCO2LVLS))

!-------------------------------------------------------------------
!    compute the 2-d input arrays
!-------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        do kp=k,NSTDCO2LVLS
          press_hiv(kp,k) = pa(kp)
          press_lov(kp,k) = pa(k)
          caintv(kp,k) = ca(kp)
          sexpintv(kp,k) = sexp(kp)
          xaintv(kp,k) = xa(kp)
          uexpintv(kp,k) = uexp(kp)
        enddo
      enddo

!-------------------------------------------------------------------
!    the call (and calculations) to pathv2_std has been subsumed into
!    the subroutine approx_fn_std
!-------------------------------------------------------------------
      call approx_fn_std (press_hiv, press_lov, do_triangle, &
                          caintv, sexpintv, xaintv, uexpintv,  &
                          approx_guess1)

!-------------------------------------------------------------------
      deallocate (press_hiv)
      deallocate (press_lov)

!--------------------------------------------------------------------
!    2) compute error function at standard (pa) pressures
!--------------------------------------------------------------------
      allocate ( error_guess1(NSTDCO2LVLS,NSTDCO2LVLS) )
      do k=1,NSTDCO2LVLS
        do kp=k+1,NSTDCO2LVLS
          error_guess1(kp,k) = 1.0 - trns_std_hi(kp,k) -  &
                               approx_guess1(kp,k)
        enddo
        error_guess1(k,k) = 0.0
      enddo
      deallocate (approx_guess1)
        
!---------------------------------------------------------------------
!    3) derive the pressures for interpolation using Eqs. (8a-b)
!       in Ref.(2).
!---------------------------------------------------------------------
      if (nf .EQ. 1 .AND. nt .EQ. 1) then
        do k=1,NSTDCO2LVLS
          do kp=k+1,NSTDCO2LVLS
            pressint_hiv_std_pt1(kp,k) = ((co2_vmr+co2_std_hi)*pa(kp) +&
                                         (co2_std_hi-co2_vmr)*pa(k))  /&
                                         (2.*co2_std_hi)
            pressint_lov_std_pt1(kp,k) = ((co2_std_hi-co2_vmr)*pa(kp) +&
                                         (co2_vmr+co2_std_hi)*pa(k))  /&
                                         (2.*co2_std_hi)
          enddo
        enddo
      endif
      call intcoef_2d_std (pressint_hiv_std_pt1, pressint_lov_std_pt1, &
                           nf, nt, do_triangle,  &
                           indx_pressint_hiv_std_pt1,   &
                           indx_pressint_lov_std_pt1,  &
                           caintv, sexpintv, xaintv,uexpintv)

!----------------------------------------------------------------------
!    4) interpolate error function to (pressint_hiv, pressint_lov)
!    for all (k,k')
!----------------------------------------------------------------------
      allocate ( errorint_guess1(NSTDCO2LVLS,NSTDCO2LVLS) )
      call interp_error_r (error_guess1, pressint_hiv_std_pt1,  &
                           pressint_lov_std_pt1,  &
                           indx_pressint_hiv_std_pt1,   &
                           indx_pressint_lov_std_pt1, do_triangle,  &
                           errorint_guess1)

!---------------------------------------------------------------------
!    5) compute approx function for (pressint_hiv, pressint_lov)
!---------------------------------------------------------------------
      allocate (approxint_guess1(NSTDCO2LVLS,NSTDCO2LVLS))

!--------------------------------------------------------------------
!    the call (and calculations) to pathv2_std has been subsumed into
!    the subroutine approx_fn_std
!--------------------------------------------------------------------
      call approx_fn_std (pressint_hiv_std_pt1, pressint_lov_std_pt1,  &
                          do_triangle, caintv, sexpintv, xaintv,   &
                          uexpintv, approxint_guess1)

!---------------------------------------------------------------------
!    6) compute first guess transmission function using Eq.(3),
!    Ref.(2).
!---------------------------------------------------------------------
      allocate (trans_guess1(NSTDCO2LVLS,NSTDCO2LVLS))
      do k=1,NSTDCO2LVLS
        do kp=k+1,NSTDCO2LVLS
          trans_guess1(kp,k) = 1.0 -  &
                       (errorint_guess1(kp,k) + approxint_guess1(kp,k))
        enddo
      enddo
      deallocate (approxint_guess1)
      deallocate (errorint_guess1)
 
!---------------------------------------------------------------------
!    the second part of the method is to obtain a second guess co2
!    transmission function for the lower standard  concentration using
!    only the co2 tf's for the higher standard concentration.
!    the coeint call and steps (1-2) of part (1) need not be repeated.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    3) derive the pressures for interpolation using Eqs. (8a-b)
!       in Ref.(2).
!---------------------------------------------------------------------
      if (nf .EQ. 1 .AND. nt .EQ. 1) then
        do k=1,NSTDCO2LVLS
          do kp=k+1,NSTDCO2LVLS
            pressint_hiv_std_pt2(kp,k) = ((co2_std_lo+co2_std_hi)*  &
                                           pa(kp) +  &
                                         (co2_std_hi-co2_std_lo)*  &
                                           pa(k))/  &
                                          (2.*co2_std_hi)
            pressint_lov_std_pt2(kp,k) = ((co2_std_hi-co2_std_lo)* &
                                           pa(kp) +  &
                                         (co2_std_lo+co2_std_hi)* &
                                           pa(k))/  &
                                         (2.*co2_std_hi)
          enddo
        enddo
      endif
      call intcoef_2d_std (pressint_hiv_std_pt2, pressint_lov_std_pt2, &
                           nf, nt, do_triangle,  &
                           indx_pressint_hiv_std_pt2,    &
                           indx_pressint_lov_std_pt2,  &
                           caintv, sexpintv, xaintv,uexpintv)

!---------------------------------------------------------------------
!    4) interpolate error function to (pressint_hiv, pressint_lov)
!       for all (k,k')
!---------------------------------------------------------------------
      allocate ( errorint_guess2(NSTDCO2LVLS,NSTDCO2LVLS) )
      call interp_error_r (error_guess1, pressint_hiv_std_pt2,   &
                           pressint_lov_std_pt2,  &
                           indx_pressint_hiv_std_pt2,   &
                           indx_pressint_lov_std_pt2,  &
                           do_triangle,  errorint_guess2)
      deallocate (error_guess1)

!---------------------------------------------------------------------
!    5) compute approx function for (pressint_hiv, pressint_lov)
!--------------------------------------------------------------------
      allocate (approxint_guess2(NSTDCO2LVLS,NSTDCO2LVLS))

!---------------------------------------------------------------------
!    the call (and calculations) to pathv2_std has been subsumed into
!    the subroutine approx_fn_std
!---------------------------------------------------------------------
      call approx_fn_std (pressint_hiv_std_pt2, pressint_lov_std_pt2,  &
                          do_triangle, caintv, sexpintv, xaintv,   &
                          uexpintv, approxint_guess2)
 
      deallocate (caintv)
      deallocate (sexpintv)
      deallocate (xaintv)
      deallocate (uexpintv)

!--------------------------------------------------------------------
!    6) compute second guess transmission function using Eq.(3),
!       Ref.(2).
!--------------------------------------------------------------------
      allocate (trans_guess2(NSTDCO2LVLS,NSTDCO2LVLS))
      do k=1,NSTDCO2LVLS 
        do kp=k+1,NSTDCO2LVLS
          trans_guess2(kp,k) = 1.0 -  &
            (errorint_guess2(kp,k) + approxint_guess2(kp,k))
        enddo
      enddo
      deallocate (approxint_guess2)
      deallocate (errorint_guess2)

!---------------------------------------------------------------------
!    finally, obtain transmission function for (co2_vmr) using
!    Eq.(9), Ref. (2).
!---------------------------------------------------------------------
      do k=1,NSTDCO2LVLS
        do kp=k+1,NSTDCO2LVLS
          trns_vmr(kp,k) = trans_guess1(kp,k) +  &
                           (co2_std_hi - co2_vmr)/  &
                           (co2_std_hi - co2_std_lo)*  &
                          (trns_std_lo(kp,k) - trans_guess2(kp,k))
          trns_vmr(k,kp) = trns_vmr(kp,k)
        enddo
        trns_vmr(k,k) = 1.0
      enddo
      deallocate (trans_guess1)
      deallocate (trans_guess2)

!---------------------------------------------------------------------
       
end subroutine rctrns



!#####################################################################
! <SUBROUTINE NAME="read_lbltfs">
!  <OVERVIEW>
!   Subroutine to read gas transmission functions from input file
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to read gas transmission functions from input file
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_lbltfs (gas_type, callrctrns, nstd_lo, nstd_hi, nf,   &
!                     ntbnd, trns_std_hi_nf, trns_std_lo_nf )
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_lbltfs (gas_type, callrctrns, nstd_lo, nstd_hi, nf,   &
                        ntbnd, trns_std_hi_nf, trns_std_lo_nf )
 
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

character(len=*),           intent(in)   :: gas_type
logical,                    intent(in)   :: callrctrns
integer,                    intent(in)   :: nstd_lo, nstd_hi, nf
integer, dimension(:),      intent(in)   :: ntbnd
real,    dimension (:,:,:), intent(out)  :: trns_std_hi_nf,   &
                                            trns_std_lo_nf

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     gas_type
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      character(len=24) input_lblco2name(nfreq_bands_sea_co2,11)
      character(len=24) input_lblch4name(nfreq_bands_sea_ch4,8)
      character(len=24) input_lbln2oname(nfreq_bands_sea_n2o,7)
      character(len=24) name_lo
      character(len=24) name_hi
      character(len=32) filename, ncname

      real, dimension(:,:), allocatable  :: trns_in

      integer        :: n, nt, nrec_inhi, inrad, nrec_inlo
 
      data (input_lblco2name(n,1),n=1,nfreq_bands_sea_co2)/            &
        'cns_0_490850   ', 'cns_0_490630   ', 'cns_0_630700   ', &
        'cns_0_700850   ', 'cns_0_43um     '/
      data (input_lblco2name(n,2),n=1,nfreq_bands_sea_co2)/            &
        'cns_165_490850   ', 'cns_165_490630   ', 'cns_165_630700   ', &
        'cns_165_700850   ', 'cns_165_43um     '/
      data (input_lblco2name(n,3),n=1,nfreq_bands_sea_co2)/            &
        'cns_300_490850   ', 'cns_300_490630   ', 'cns_300_630700   ', &
        'cns_300_700850   ', 'cns_300_43um     '/
      data (input_lblco2name(n,4),n=1,nfreq_bands_sea_co2)/            &
        'cns_330_490850   ', 'cns_330_490630   ', 'cns_330_630700   ', &
        'cns_330_700850   ', 'cns_330_43um     '/
      data (input_lblco2name(n,5),n=1,nfreq_bands_sea_co2)/            &
        'cns_348_490850   ', 'cns_348_490630   ', 'cns_348_630700   ', &
        'cns_348_700850   ', 'cns_348_43um     '/
      data (input_lblco2name(n,6),n=1,nfreq_bands_sea_co2)/            &
        'cns_356_490850   ', 'cns_356_490630   ', 'cns_356_630700   ', &
        'cns_356_700850   ', 'cns_356_43um     '/
      data (input_lblco2name(n,7),n=1,nfreq_bands_sea_co2)/            &
        'cns_360_490850   ', 'cns_360_490630   ', 'cns_360_630700   ', &
        'cns_360_700850   ', 'cns_360_43um     '/
      data (input_lblco2name(n,8),n=1,nfreq_bands_sea_co2)/            &
        'cns_600_490850   ', 'cns_600_490630   ', 'cns_600_630700   ', &
        'cns_600_700850   ', 'cns_600_43um     '/
      data (input_lblco2name(n,9),n=1,nfreq_bands_sea_co2)/            &
        'cns_660_490850   ', 'cns_660_490630   ', 'cns_660_630700   ', &
        'cns_660_700850   ', 'cns_660_43um     '/
      data (input_lblco2name(n,10),n=1,nfreq_bands_sea_co2)/           &
        'cns_1320_490850  ', 'cns_1320_490630  ', 'cns_1320_630700  ', &
        'cns_1320_700850  ', 'cns_1320_43um    '/
      data (input_lblco2name(n,11),n=1,nfreq_bands_sea_co2)/           &
        'cns_1600_490850  ', 'cns_1600_490630  ', 'cns_1600_630700  ', &
        'cns_1600_700850  ', 'cns_1600_43um    '/
 
      data (input_lblch4name(n,1),n=1,nfreq_bands_sea_ch4)/          &
        'cns_0_12001400'/
      data (input_lblch4name(n,2),n=1,nfreq_bands_sea_ch4)/          &
        'cns_300_12001400'/
      data (input_lblch4name(n,3),n=1,nfreq_bands_sea_ch4)/          &
        'cns_700_12001400'/
      data (input_lblch4name(n,4),n=1,nfreq_bands_sea_ch4)/          &
        'cns_1250_12001400'/
      data (input_lblch4name(n,5),n=1,nfreq_bands_sea_ch4)/          &
        'cns_1750_12001400'/
      data (input_lblch4name(n,6),n=1,nfreq_bands_sea_ch4)/          &
        'cns_2250_12001400'/
      data (input_lblch4name(n,7),n=1,nfreq_bands_sea_ch4)/          &
        'cns_2800_12001400'/
      data (input_lblch4name(n,8),n=1,nfreq_bands_sea_ch4)/          &
        'cns_4000_12001400'/
 
      data (input_lbln2oname(n,1),n=1,nfreq_bands_sea_n2o)/           &
        'cns_0_12001400 ', 'cns_0_10701200 ', 'cns_0_560630   '/
      data (input_lbln2oname(n,2),n=1,nfreq_bands_sea_n2o)/           &
        'cns_180_12001400 ', 'cns_180_10701200 ', 'cns_180_560630   '/
      data (input_lbln2oname(n,3),n=1,nfreq_bands_sea_n2o)/           &
        'cns_275_12001400 ', 'cns_275_10701200 ', 'cns_275_560630   '/
      data (input_lbln2oname(n,4),n=1,nfreq_bands_sea_n2o)/           &
        'cns_310_12001400 ', 'cns_310_10701200 ', 'cns_310_560630   '/
      data (input_lbln2oname(n,5),n=1,nfreq_bands_sea_n2o)/           &
        'cns_340_12001400 ', 'cns_340_10701200 ', 'cns_340_560630   '/
      data (input_lbln2oname(n,6),n=1,nfreq_bands_sea_n2o)/           &
        'cns_375_12001400 ', 'cns_375_10701200 ', 'cns_375_560630   '/
      data (input_lbln2oname(n,7),n=1,nfreq_bands_sea_n2o)/           &
        'cns_500_12001400 ', 'cns_500_10701200 ', 'cns_500_560630   '/

!--------------------------------------------------------------------
!  local variables:
!
!     input_lblco2name    
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (gas_type .EQ. 'co2') then
        name_lo = input_lblco2name(nf,nstd_lo)
        name_hi = input_lblco2name(nf,nstd_hi)
      endif
      if (gas_type .EQ. 'ch4') then
        name_lo = input_lblch4name(nf,nstd_lo)
        name_hi = input_lblch4name(nf,nstd_hi)
      endif
      if (gas_type .EQ. 'n2o') then
        name_lo = input_lbln2oname(nf,nstd_lo)
        name_hi = input_lbln2oname(nf,nstd_hi)
      endif

!-------------------------------------------------------------------
!    read in tfs of higher std gas concentration
!-------------------------------------------------------------------
      filename = 'INPUT/' // trim(name_hi)
      ncname = trim(filename) // '.nc'
      if(file_exist(trim(ncname))) then
         if (mpp_pe() == mpp_root_pe()) call error_mesg ('lw_gases_stdtf_mod', &
              'Reading NetCDF formatted input data file: ' // ncname, NOTE)
         call read_data(ncname, 'trns_std_nf', trns_std_hi_nf(:,:,1:ntbnd(nf)), no_domain=.true.)
      else
         if (mpp_pe() == mpp_root_pe()) call error_mesg ('lw_gases_stdtf_mod', &
              'Reading native formatted input data file: ' // filename, NOTE)
         allocate (trns_in(NSTDCO2LVLS,NSTDCO2LVLS))
         inrad = open_direct_file (file=filename, action='read', &
              recl = NSTDCO2LVLS*NSTDCO2LVLS*8)
         nrec_inhi = 0
         do nt=1,ntbnd(nf)
            nrec_inhi = nrec_inhi + 1
            read (inrad, rec = nrec_inhi) trns_in
            trns_std_hi_nf(:,:,nt) = trns_in(:,:)
         enddo
         call close_file (inrad)
         deallocate (trns_in)
      endif

!--------------------------------------------------------------------
!    if necessary, read in tfs of lower standard gas concentration
!-------------------------------------------------------------------
      if (callrctrns) then
        filename = 'INPUT/' // trim(name_lo )
        ncname = trim(filename) // '.nc'
        if(file_exist(trim(ncname))) then
           if (mpp_pe() == mpp_root_pe()) call error_mesg ('lw_gases_stdtf_mod', &
                'Reading NetCDF formatted input data file: ' // ncname, NOTE)
           call read_data(ncname, 'trns_std_nf', trns_std_lo_nf(:,:,1:ntbnd(nf)), no_domain=.true.)
        else
           if (mpp_pe() == mpp_root_pe()) call error_mesg ('lw_gases_stdtf_mod', &
                'Reading native formatted input data file: ' // filename, NOTE)
           allocate (trns_in(NSTDCO2LVLS,NSTDCO2LVLS))
           inrad = open_direct_file (file=filename, action='read', &
                recl = NSTDCO2LVLS*NSTDCO2LVLS*8)
           nrec_inlo = 0
           do nt=1,ntbnd(nf)
              nrec_inlo = nrec_inlo + 1
              read (inrad, rec = nrec_inlo) trns_in
              trns_std_lo_nf(:,:,nt) = trns_in(:,:)
           enddo
           call close_file (inrad)
           deallocate (trns_in)
        endif
     endif
 
!--------------------------------------------------------------------


end subroutine read_lbltfs




!#####################################################################
! <SUBROUTINE NAME="allocate_interp_arrays">
!  <OVERVIEW>
!   Subroutine to allocate interpolation arrays
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to allocate interpolation arrays
!  </DESCRIPTION>
!  <TEMPLATE>
!   call allocate_interp_arrays
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine allocate_interp_arrays

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

      allocate (pressint_hiv_std_pt1(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (pressint_lov_std_pt1(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (pressint_hiv_std_pt2(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (pressint_lov_std_pt2(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (indx_pressint_hiv_std_pt1(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (indx_pressint_lov_std_pt1(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (indx_pressint_hiv_std_pt2(NSTDCO2LVLS,NSTDCO2LVLS))
      allocate (indx_pressint_lov_std_pt2(NSTDCO2LVLS,NSTDCO2LVLS))

!-------------------------------------------------------------------


end subroutine allocate_interp_arrays


!####################################################################

subroutine deallocate_interp_arrays

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

      deallocate (pressint_hiv_std_pt1)
      deallocate (pressint_lov_std_pt1)
      deallocate (pressint_hiv_std_pt2)
      deallocate (pressint_lov_std_pt2)
      deallocate (indx_pressint_hiv_std_pt1)
      deallocate (indx_pressint_lov_std_pt1)
      deallocate (indx_pressint_hiv_std_pt2)
      deallocate (indx_pressint_lov_std_pt2)

!-------------------------------------------------------------------


end subroutine deallocate_interp_arrays


!####################################################################



             end module lw_gases_stdtf_mod




!FDOC_TAG_GFDL

                 module mgrp_prscr_clds_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!  fil   
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!       mgroup prescribed cloud properties module
!               (this module runnable in SKYHI and FMS;
!                zonal_clouds_mod is FMS native equivalent)
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use mpp_mod,           only: input_nml_file
use fms_mod,           only: fms_init, file_exist, &
                             open_namelist_file,  &
                             check_nml_error, close_file,   &
                             write_version_number, &
                             mpp_pe, mpp_root_pe, stdlog, &
                             error_mesg, FATAL

use constants_mod,     only: radian
use rad_utilities_mod, only: rad_utilities_init, &
                             cldrad_properties_type, &
                             cld_specification_type


!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!       mgroup prescribed cloud properties module
!               (this module runnable in SKYHI and FMS; 
!                zonal_clouds_mod is FMS native equivalent)
!
!!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128)  :: version =  '$Id: mgrp_prscr_clds.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
  character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public     mgrp_prscr_clds_init,  &
           mgrp_prscr_clds_end,  &
          prscr_clds_amt, &      
          obtain_bulk_lw_prscr, obtain_bulk_sw_prscr 


private    cldht, cldint  


!---------------------------------------------------------------------
!-------- namelist  ---------



integer    ::     dummy=0



namelist /mgrp_prscr_clds_nml /     &
                                           dummy


!----------------------------------------------------------------------
!----  public data -------

!----------------------------------------------------------------------
!----  private data -------


!--------------------------------------------------------------------
!     these variables define cloud amounts and radiative properties  
!     on a global (j,k) model grid.
!--------------------------------------------------------------------
  
logical, dimension(:,:),   allocatable :: zhi_cloud_gl, zmid_cloud_gl, &
                                         zlow_cloud_gl
real, dimension(:,:),   allocatable :: zcamtmxo, zcamtrnd

 
!--------------------------------------------------------------------
!     these variables define cloud tops and bottoms, amounts and rad-
!     iative properties on an input (LATOBS,NOFCLDS_SP) grid. the input 
!     values are the original Skyhi values. 
!--------------------------------------------------------------------
 
integer, parameter                    :: NOFCLDS_SP=3  
integer, parameter                    :: NOFMXOLW=1  
integer, parameter                    :: NOFRNDLW=2  
integer, parameter                    :: LATOBS=19

!-------------------------------------------------------------------
!   default low, middle, high cloud properties 
!   cldem    : infrared emissivity
!   crfvis   : visible band reflectivity
!   crfir    : near-ir band reflectivity
!   cabir    : near-ir band absorptivity
!-------------------------------------------------------------------
real  :: cldem_hi = 1.0     
real ::  cldem_mid= 1.0
real ::  cldem_low = 1.0          
real :: crfvis_hi = 0.21 
real :: crfvis_mid =0.48          
real :: crfvis_low =0.69          
real :: crfir_hi = 0.21
real :: crfir_mid =0.48     
real :: crfir_low = 0.69          
real :: cabir_hi =  0.005         
real :: cabir_mid =0.02           
real :: cabir_low =0.035

!-------------------------------------------------------------------
!   prescribed high, mid, low cloud amounts on 19 latitudes
!-------------------------------------------------------------------

integer                                 ::  jj, kkc
real, dimension(LATOBS)                 ::  ccd_low, ccd_mid, ccd_hi  
real, dimension(LATOBS)                 ::  cloud_lats

data cloud_lats / -90., -80., -70., -60., -50., -40., -30., -20., &
                  -10., 0.0, 10., 20., 30., 40., 50., 60., 70., 80., &
                   90. /

data ccd_low  /    &
     &  0.360E+00, 0.401E+00, 0.439E+00, 0.447E+00, 0.417E+00, &
     &  0.343E+00, 0.269E+00, 0.249E+00, 0.290E+00, 0.330E+00, &
     &  0.290E+00, 0.249E+00, 0.269E+00, 0.343E+00, 0.417E+00, &
     &  0.447E+00, 0.439E+00, 0.401E+00, 0.360E+00/               

data ccd_mid  /    &
     &  0.090E+00, 0.102E+00, 0.117E+00, 0.128E+00, 0.122E+00, &
     &  0.095E+00, 0.070E+00, 0.060E+00, 0.068E+00, 0.080E+00, &
     &  0.068E+00, 0.060E+00, 0.070E+00, 0.095E+00, 0.122E+00, &
     &  0.128E+00, 0.117E+00, 0.102E+00, 0.090E+00/              

data ccd_hi   /    &
     &  0.198E+00, 0.231E+00, 0.254E+00, 0.250E+00, 0.227E+00, &
     &  0.192E+00, 0.159E+00, 0.168E+00, 0.205E+00, 0.241E+00, &
     &  0.205E+00, 0.168E+00, 0.159E+00, 0.192E+00, 0.227E+00, &
     &  0.250E+00, 0.254E+00, 0.231E+00, 0.198E+00/ 
!----------------------------------------------------------------------


!----------------------------------------------------------------------
!    NLWCLDB is the number of frequency bands for which lw
!    emissitivies are defined.
!----------------------------------------------------------------------

logical :: module_is_initialized = .false.

!----------------------------------------------------------------------
!----------------------------------------------------------------------




 contains 


! <SUBROUTINE NAME="mgrp_prscr_clds_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call mgrp_prscr_clds_init (    pref, latb      )
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="">
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine mgrp_prscr_clds_init (    pref, latb      )

!------------------------------------------------------------------
real, dimension(:), intent(in)             ::  latb      
real, dimension(:,:), intent(in)             :: pref          
!--------------------------------------------------------------------

      integer            :: unit, ierr, io, logunit
      integer            :: j, k,                 li
      integer            :: jdf
      integer, dimension ( LATOBS, NOFCLDS_SP)  :: kkbh, kkth
         
 integer :: kerad

      integer, dimension(:), allocatable :: jindx2

      if (module_is_initialized) return

      call fms_init
      call rad_utilities_init

!---------------------------------------------------------------------
!-----  read namelist  ------
  
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=mgrp_prscr_clds_nml, iostat=io)
      ierr = check_nml_error(io,"mgrp_prscr_clds_nml")
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=mgrp_prscr_clds_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'mgrp_prscr_clds_nml')
        enddo
10      call close_file (unit)
      endif
#endif

      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )   &
         write (logunit, nml = mgrp_prscr_clds_nml)

!--------------------------------------------------------------------
!  retrieve module variables that come from other modules
!--------------------------------------------------------------------

       kerad = size(pref,1) - 1
      jdf = size(latb,1) - 1

         allocate (jindx2  (size(latb,1)-1)) ; jindx2 = 0.0
         call find_nearest_index (latb, jindx2)

!---------------------------------------------------------------------
!    define the number of cloud emissivity bands for use in this module.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!   allocate space to hold the cloud radiative properties on the model
!   grid (j,k)
!---------------------------------------------------------------------
      allocate( zcamtmxo    (jdf , KERAD)) ; zcamtmxo = 0.0
      allocate( zcamtrnd    (jdf , KERAD)) ; zcamtrnd = 0.0

      allocate( zhi_cloud_gl(jdf ,     kerad  ))
      allocate( zmid_cloud_gl(jdf ,    kerad   ))
      allocate( zlow_cloud_gl(jdf ,    kerad   ))
      zhi_cloud_gl  = .false.
      zmid_cloud_gl = .false.
      zlow_cloud_gl = .false.

!---------------------------------------------------------------------
!     define index arrays for cloud tops and cloud bottoms(kkth, kkbh). 
!     a program courtesy of Ron Stouffer is used. cldht specifies cloud 
!     height data in mb for each cloud type, at 10 deg intervals from 
!     90S to 90N.(ie, 19 lats).
!---------------------------------------------------------------------
 
      call cldht  (pref(:,1), kkbh, kkth)


!---------------------------------------------------------------------
!    perform latitude "interpolation" to the (JD) model latitudes
!    in default case, no interpolation is actually done; the nearest
!    latitude available (using NINT function) is used.
!---------------------------------------------------------------------

       zcamtmxo = 0.
       zcamtrnd = 0.

      do j=1,jdf
        li = jindx2(j)
do k=kkth(li,1), kkbh(li,1)
           zlow_cloud_gl(j,k) = .true.
  zcamtmxo(j,k) = ccd_low(li)        
        end do
        do k=kkth(li,2), kkbh(li,2)
           zmid_cloud_gl(j,k) = .true.
   zcamtrnd(j,k) = ccd_mid(li)
         end do
         do k=kkth(li,3), kkbh(li,3)
            zhi_cloud_gl(j,k) = .true.
    zcamtrnd(j,k) = ccd_hi(li)
        end do
      end do

!---------------------------------------------------------------------
!    if a cloud microphysics scheme is to be employed with the cloud
!    scheme, initialize the microphysics_rad module.
!--------------------------------------------------------------------

      module_is_initialized = .true.

end subroutine mgrp_prscr_clds_init

!######################################################################

! <SUBROUTINE NAME="mgrp_prscr_clds_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call mgrp_prscr_clds_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine mgrp_prscr_clds_end
        
!----------------------------------------------------------------------
!    mgrp_prscr_clds_end is the destructor for mgrp_prscr_clds_mod.
!----------------------------------------------------------------------
       
!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.
        
!--------------------------------------------------------------------
 
 
end subroutine mgrp_prscr_clds_end




!#####################################################################

! <SUBROUTINE NAME="find_nearest_index">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call find_nearest_index (latb, jindx2)
!
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
! 
!  </IN>
!  <OUT NAME="jindx2" TYPE="integer">
! 
!  </OUT>
! </SUBROUTINE>
!
subroutine find_nearest_index (latb, jindx2)

real, dimension(:), intent(in) :: latb
integer, dimension(:), intent(out)  :: jindx2


      integer :: jd, j, jj
      real   :: diff_low, diff_high
      real, dimension(size(latb,1)-1) :: lat


      jd = size(latb,1) - 1

      do j = 1,jd
        lat(j) = 0.5*(latb(j) + latb(j+1))
      do jj=1, LATOBS         
         if (lat(j)*radian >= cloud_lats(jj)) then
           diff_low = lat(j)*radian - cloud_lats(jj)
           diff_high = cloud_lats(jj+1) - lat(j)*radian
          if (diff_high <= diff_low) then
            jindx2(j) = jj+1
          else
            jindx2(j) = jj
          endif
        endif
      end do
      end do






end subroutine find_nearest_index 





!######################################################################

! <SUBROUTINE NAME="prscr_clds_amt">
!  <OVERVIEW>
!    prscr_clds_amt defines the location, amount (cloud fraction),
!    number and type (hi, mid, low) of clouds present on the model grid.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    prscr_clds_amt defines the location, amount (cloud fraction),
!    number and type (hi, mid, low) of clouds present on the model grid.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call prscr_clds_amt (is, ie, js, je, Cld_spec)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine prscr_clds_amt (is, ie, js, je, Cld_spec)

!---------------------------------------------------------------------
!    prscr_clds_amt defines the location, amount (cloud fraction), 
!    number and type (hi, mid, low) of clouds present on the model grid.
!----------------------------------------------------------------------

integer, intent(in)                          :: is, ie, js, je
type(cld_specification_type), intent(inout)  :: Cld_spec       

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of 
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of 
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of 
!                           low clouds in a grid box
!                                                                  
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:
 
      integer  ::  i,j,k    ! do loop indices


!---------------------------------------------------------------------
!    define the number of clouds in each column. the assumption is made
!    that all grid columns have NOFCLDS_SP clouds, with NOFMXOLW of 
!    these being maximally overlapped and the remainder (NOFRNDLW) 
!    randomly overlapped. The default case, corresponding to all 
!    previous model simulations, is 3 clouds (1 maximally overlapped, 
!    2 randomly overlapped).
!----------------------------------------------------------------------
      Cld_spec%nmxolw(:,:) = NOFMXOLW
      Cld_spec%nrndlw(:,:) = NOFRNDLW
      Cld_spec%ncldsw(:,:) = NOFCLDS_SP 

!----------------------------------------------------------------------
!    define the fractions of random and maximally overlapped clouds and
!    the total cloud fraction seen by the shortwave radiation. define
!    the hi-mid-low cloud flag arrays based on the pre-defined latitude
!    and height dependent specifications that were defined during init-
!    ialization.
!----------------------------------------------------------------------
      do k=1,size (Cld_spec%hi_cloud,3)
        do j=1,size (Cld_spec%hi_cloud,2)
          do i=1,size (Cld_spec%hi_cloud,1)
            Cld_spec%cmxolw(i,j,k) = zcamtmxo(j+js-1  ,k)
            Cld_spec%crndlw(i,j,k) = zcamtrnd(j+js-1  ,k)
            Cld_spec%camtsw(i,j,k) = Cld_spec%cmxolw(i,j,k) +  &
                                     Cld_spec%crndlw(i,j,k)
            if (Cld_spec%camtsw(i,j,k) > 0.0) then
              if (zhi_cloud_gl(js+j-1,k)) then
                Cld_spec%hi_cloud(i,j,k) = .true.
              else if (zmid_cloud_gl(js+j-1,k)) then
                Cld_spec%mid_cloud(i,j,k) = .true.
              else if (zlow_cloud_gl(js+j-1,k) ) then
                Cld_spec%low_cloud(i,j,k) = .true.
              else
                call error_mesg ('mgrp_prscr_clds_mod',  &
                    'model level is not mapped to a cloud type', FATAL)
              endif
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------



end subroutine prscr_clds_amt


!######################################################################

! <SUBROUTINE NAME="obtain_bulk_lw_prscr">
!  <OVERVIEW>
!    obtain_bulk_lw_prscr defines bulk longwave cloud radiative
!    properties for the mgrp_prscr_clds cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_lw_prscr defines bulk longwave cloud radiative
!    properties for the mgrp_prscr_clds cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_lw_prscr (is, ie, js, je, Cld_spec, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </INOUT>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for
!                               maximally overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_lw_prscr (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_lw_prscr defines bulk longwave cloud radiative 
!    properties for the mgrp_prscr_clds cloud scheme.
!---------------------------------------------------------------------

integer,                     intent(in)     :: is, ie, js, je
type(cld_specification_type), intent(inout) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
 
      integer   ::    i,j,k   ! do-loop indices

!---------------------------------------------------------------------
!    assign the proper values for cloud emissivity to each grid box
!    with cloudiness, dependent on whether the cloud in that box is 
!    defined as being high, middle or low cloud. high and middle clouds
!    are assumed to be random overlap, low clouds are assume to be
!    maximum overlap.
!----------------------------------------------------------------------
      do k=1, size(Cld_spec%hi_cloud,3)
        do j=1,size(Cld_spec%hi_cloud,2)
          do i=1,size(Cld_spec%hi_cloud,1)
            if (Cld_spec%hi_cloud(i,j,k)) then
              Cldrad_props%emrndlw(i,j,k,:,1)  = cldem_hi
            else if (Cld_spec%mid_cloud(i,j,k)) then
              Cldrad_props%emrndlw(i,j,k,:,1)  = cldem_mid
            else if (Cld_spec%low_cloud(i,j,k)) then
              Cldrad_props%emmxolw(i,j,k,:,1)  = cldem_low
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------



end subroutine obtain_bulk_lw_prscr 



!#####################################################################

! <SUBROUTINE NAME="obtain_bulk_sw_prscr">
!  <OVERVIEW>
!    obtain_bulk_sw_zonal defines bulk shortwave cloud radiative
!    properties for the zonal cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_sw_zonal defines bulk shortwave cloud radiative
!    properties for the zonal cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_sw_prscr (is, ie, js, je, Cld_spec, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </INOUT>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the
!                               visible frequency band
!                               [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_sw_prscr (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_sw_zonal defines bulk shortwave cloud radiative 
!    properties for the zonal cloud scheme.
!---------------------------------------------------------------------

integer,                      intent(in)    :: is, ie, js, je
type(cld_specification_type), intent(inout) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props
!-------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer     ::  i,j,k    ! do loop indices
 
!---------------------------------------------------------------------
!    assign the proper values for cloud absorptivity and reflectivity
!    to each grid box with cloudiness, dependent on whether the cloud 
!    in that box is defined as being high, middle or low cloud. 
!----------------------------------------------------------------------
      do k=1, size(Cld_spec%hi_cloud,3)
        do j=1,size(Cld_spec%hi_cloud,2)
          do i=1,size(Cld_spec%hi_cloud,1)
            if (Cld_spec%hi_cloud(i,j,k)) then
              Cldrad_props%cirabsw(i,j,k)  = cabir_hi
              Cldrad_props%cirrfsw(i,j,k)  = crfir_hi
              Cldrad_props%cvisrfsw(i,j,k) = crfvis_hi
            else if (Cld_spec%mid_cloud(i,j,k)) then
              Cldrad_props%cirabsw(i,j,k)  = cabir_mid
              Cldrad_props%cirrfsw(i,j,k)  = crfir_mid
              Cldrad_props%cvisrfsw(i,j,k) = crfvis_mid
            else if (Cld_spec%low_cloud(i,j,k)) then
              Cldrad_props%cirabsw(i,j,k)  = cabir_low
              Cldrad_props%cirrfsw(i,j,k)  = crfir_low
              Cldrad_props%cvisrfsw(i,j,k) = crfvis_low
            endif
          end do
        end do
      end do

!----------------------------------------------------------------------



end subroutine obtain_bulk_sw_prscr 




!######################################################################




!##################################################################


! <SUBROUTINE NAME="cldht">
!  <OVERVIEW>
!  This subroutine computes the heights of the cloud tops
!  and bottoms for the fixed cloud model.  The observed data
!  are from London (1954, 1957).  This data is a function of 10 deg.
!  latitude bands (0-10, 10-20 and etc.), season and height
!  in the orginal paper and only for
!  the Northern Hemisphere for various cloud types.
!  Dick and Suki averaged the four seasons together to get annual
!  mean cloud heights for three type of clouds (hi, middle and low).
!  Somebody also interpolated the data from the 10 deg latitude
!  bands to 5 deg bands.  At the equator, this interpolation
!  was more like an extrapolation.
!  These heights were then put in pressure coordinates using
!  a Skew-T diagram which assumes a "standard atmosphere".
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!  This subroutine computes the heights of the cloud tops
!  and bottoms for the fixed cloud model.  The observed data
!  are from London (1954, 1957).  This data is a function of 10 deg.
!  latitude bands (0-10, 10-20 and etc.), season and height
!  in the orginal paper and only for
!  the Northern Hemisphere for various cloud types.
!  Dick and Suki averaged the four seasons together to get annual
!  mean cloud heights for three type of clouds (hi, middle and low).
!  Somebody also interpolated the data from the 10 deg latitude
!  bands to 5 deg bands.  At the equator, this interpolation
!  was more like an extrapolation.
!  These heights were then put in pressure coordinates using
!  a Skew-T diagram which assumes a "standard atmosphere".
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cldht (plevel, kkbh, kkth)
!
!  </TEMPLATE>
!  <IN NAME="plevel" TYPE="real">
! 
!  </IN>
!  <OUT NAME="kkbh" TYPE="integer">
! 
!  </OUT>
!  <OUT NAME="kkth" TYPE="integer">
! 
!  </OUT>
! </SUBROUTINE>
!
subroutine cldht (plevel, kkbh, kkth)

real, dimension(:), intent(in) :: plevel
integer, dimension(:,:), intent(out) :: kkbh, kkth
 
!------------------------------------------------------------------
!  This subroutine computes the heights of the cloud tops
!  and bottoms for the fixed cloud model.  The observed data
!  are from London (1954, 1957).  This data is a function of 10 deg.
!  latitude bands (0-10, 10-20 and etc.), season and height 
!  in the orginal paper and only for
!  the Northern Hemisphere for various cloud types.
!  Dick and Suki averaged the four seasons together to get annual 
!  mean cloud heights for three type of clouds (hi, middle and low).
!  Somebody also interpolated the data from the 10 deg latitude
!  bands to 5 deg bands.  At the equator, this interpolation
!  was more like an extrapolation.
!  These heights were then put in pressure coordinates using
!  a Skew-T diagram which assumes a "standard atmosphere".
!
!  The Dick and Suki (Ron's pressures) data follow:
!
! TYPE:      hi      |   middle    |            low
!     |              |             |     ctop    |   cbase
! Lat |   ht   press |  ht   press |  ht   press |  ht   press
! 0   |  9.80  272   | 4.35  590   | 3.00  700   | 1.40  855
! 5   |  9.82  271   | 4.40  586   | 3.04  698   | 1.47  848
! 10  | 10.13  259   | 4.45  581   | 3.08  693   | 1.61  836
! 15  | 10.35  250   | 4.50  578   | 3.08  693   | 1.70  828 
! 20  | 10.50  244   | 4.50  578   | 3.01  699   | 1.72  825
! 25  | 10.50  244   | 4.41  584   | 2.91  710   | 1.71  826
! 30  | 10.38  248   | 4.26  595   | 2.80  719   | 1.70  828
! 35  | 10.03  263   | 4.10  614   | 2.70  729   | 1.65  830
! 40  |  9.44  285   | 3.92  621   | 2.60  735   | 1.58  839
! 45  |  8.65  322   | 3.79  633   | 2.47  750   | 1.50  846
! 50  |  7.97  357   | 3.67  647   | 2.35  760   | 1.40  859
! 55  |  7.55  379   | 3.56  651   | 2.24  770   | 1.31  867
! 60  |  7.29  392   | 3.51  657   | 2.17  780   | 1.25  871
! 65  |  7.13  401   | 3.50  658   | 2.10  783   | 1.20  875
! 70  |  7.03  406   | 3.48  659   | 2.03  788   | 1.12  881
! 75  |  7.01  409   | 3.44  660   | 1.98  795   | 1.05  890
! 80  |  6.99  410   | 3.43  661   | 1.91  800   | 1.02  891
! 85  |  6.98  411   | 3.43  661   | 1.88  803   | 1.00  896
! 90  |  6.98  411   | 3.43  661   | 1.87  804   | 1.00  896
!
!  Note that the heights are in kilometers and the pressures
!  in millibars.
!--------------------------------------------------------------------

      real, dimension(10)   :: ciht, asht, cltop, clbase
      integer               :: n, nl, j
 
!------------------------------------------------------------------
!  The data in the following arrays run pole to equator,
!  starting at 90, 80, 70....10, 0.
!------------------------------------------------------------------
 
!  Observed high cloud heights running pole to equator (mb)
      data ciht / 411, 410, 406, 392, 357, 285, 248, 244, 259, 272 /
 
!  Observed middle cloud heights running pole to equator (mb)
      data asht / 661, 661, 659, 657, 647, 621, 595, 578, 581, 590 /
 
!  Observed low cloud top heights running pole to equator (mb)
!     data cltop / 804, 800, 788, 780, 760, 735, 719, 699, 693, 700 /
      data cltop / 804, 800, 788, 780, 766, 735, 719, 699, 693, 700 /
!  The above data statement was changed so that this code would
!  reproduce exactly the indexes used in the 9 level model.  The 6 mb
!  error should not affect the results very much....if at all.
 
!  Observed low cloud bottom heights running pole to equator (mb)
      data clbase / 896, 891, 881, 871, 859, 839, 828, 825, 836, 855 /
 
 
!--------------------------------------------------------------------
!   for (at present) unexplained reasons, the middle cloud 
!   specification does not agree with the current gcm specification.
!   a glance at the telegadas and london paper suggests differences
!   caused by 1) use of cldmid rather than clotop and cldbase heights
!   2) seeming errors in polar cloud height locations. for now,
!   the foregoing kluge gives cloud positions in agreement with
!   SKYHI, PROVIDED:
!    it is realized that these indexes are the true values, which
!   differ by 1 from the skyhiindices. in the gcm, a subtraction
!   is done to get the indices to be correct (see radmn.F).
!--------------------------------------------------------------------

      do n=8,10
asht(n) = asht(n) - 25.
      enddo
 
      clbase = clbase *1.0E02
      cltop  = cltop  *1.0E02
     asht  = asht*100.
     ciht = ciht*100.

 
!-------------------------------------------------------------------
!  First compute the cloud top indexes for the high clouds
!  nl is the index for cloud type nl=3 => high
!--------------------------------------------------------------------  

      nl = 3
      call Cldint(plevel, ciht ,kkth, nl)
 
!---------------------------------------------------------------------
!  Set cloud bottom height equal to cloud top height.
!  This assumes cirrus clouds are one level thick.
!---------------------------------------------------------------------

      do j=1,latobs
       kkbh(j,nl) = kkth(j,nl)
      end do
 
!-------------------------------------------------------------------
!  Second compute the cloud top indexes for the middle clouds
!  nl is the index for cloud type nl=2 => middle
!-------------------------------------------------------------------
  
      nl = 2
      call Cldint(plevel, asht,kkth,  nl)
 
!-------------------------------------------------------------------
!  Set cloud bottom height equal to cloud top height.
!  This assumes middle clouds are one level thick.
!-------------------------------------------------------------------

      do j=1,latobs
       kkbh(j,nl) = kkth(j,nl)
      end do
 
!-------------------------------------------------------------------
!  Third compute the cloud top indexes for the low clouds
!  nl is the index for cloud type nl=1 => low
!-------------------------------------------------------------------
  
      nl = 1
      call Cldint(plevel, cltop,kkth,  nl)
 
!-------------------------------------------------------------------
!  Lastly compute the cloud bottom indexes for the low clouds
!  This assumes that low clouds can be thicker than one level.
!  nl is the index for cloud type nl=1 => low
!-------------------------------------------------------------------
  
      nl = 1
      call Cldint(plevel, clbase, kkbh, nl)
 
end subroutine cldht


!##################################################################

! <SUBROUTINE NAME="cldint">
!  <OVERVIEW>
!  This subroutine computes the indexes for the heights of the cloud
!  tops and bottoms for the fixed cloud model.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!  This subroutine computes the indexes for the heights of the cloud
!  tops and bottoms for the fixed cloud model.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cldint(plevel, cldobs, kindex, nl)
!
!  </TEMPLATE>
!  <IN NAME="plevel" TYPE="real">
! 
!  </IN>
!  <IN NAME="cldobs" TYPE="real">
! 
!  </IN>
!  <OUT NAME="kindex" TYPE="integer">
! 
!  </OUT>
!  <IN NAME="nl" TYPE="integer">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine cldint(plevel, cldobs, kindex, nl)
 
!-------------------------------------------------------------------
!  This subroutine computes the indexes for the heights of the cloud 
!  tops and bottoms for the fixed cloud model. 
!-------------------------------------------------------------------
 
real, dimension(10), intent(in)                    :: cldobs
integer, dimension(LATOBS,NOFCLDS_SP), intent(out) :: kindex
integer,                               intent(in)  :: nl
real, dimension(:), intent(in) :: plevel
!------------------------------------------------------------------
 
      real, dimension(LATOBS)     :: cldlat
      real                        :: prsmid
      integer                     :: j, k
      integer                     :: kerad
 
      kerad = size(plevel(:)) - 1
!---------------------------------------------------------------------
!  Fill in Southern hemisphere cloud heights
!---------------------------------------------------------------------

      do j=1,10
       cldlat(j) = cldobs(j)
      end do  
      do j=1,9
       cldlat(j+10) = cldobs(10-j)
      end do  
  
!-------------------------------------------------------------------
!  Start latitude loop to compute index at each latitude.
!-------------------------------------------------------------------
      do j=1,LATOBS
 
!-------------------------------------------------------------------
!  Find first place where the pressure on the model level
!  is greater than the pressure of the cloud height.  Starting
!  from the top of the atm and going down the column.
!-------------------------------------------------------------------
        if (plevel(KERAD)       .lt. cldlat(j)) then       
        call error_mesg ('mgrp_prscr_clds_mod',  &
         'no level found with pressure greater than cloud pressure', & 
FATAL)
endif
        if (plevel(1)       .gt. cldlat(j)) then       
        call error_mesg ('mgrp_prscr_clds_mod',  &
                ' cloud is above highest model level', FATAL)
        endif
do k=1,KERAD
          if (plevel(k) .gt. cldlat(j)) then       
!-------------------------------------------------------------------
!  k is the index of the first model level below the cloud height.
!  compute the pressure half way between the model levels
!-------------------------------------------------------------------
            prsmid = (plevel(k)+plevel(k-1))      *0.5   
 
!-------------------------------------------------------------------
!  If prsmid is greater than cldlat (cloud height) then the
!  level above is closer to cloud height, otherwise it is the
!  level below.
!-------------------------------------------------------------------
            if (prsmid .gt. cldlat(j)) then
              kindex(j,nl) = k-1
            else
              kindex(j,nl) = k
            endif
            exit
  endif
        end do
      end do
!--------------------------------------------------------------------

 

end subroutine cldint




!####################################################################

       end module mgrp_prscr_clds_mod






!FDOC_TAG_GFDL
module microphys_cloud_mod
! <CONTACT EMAIL="your_email@noaa.gov">
!   
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

!-----------------------------------------------------------------------
! module information
!-----------------------------------------------------------------------

use mpp_mod, only: input_nml_file
use fms_mod, only: open_namelist_file, mpp_pe,          &
                   mpp_root_pe, stdlog, fms_init,       &
                   write_version_number, file_exist,    &
                   check_nml_error, close_file

!-----------------------------------------------------------------------
! public interfaces
!-----------------------------------------------------------------------

implicit none
private

public microphys_cloud, microphys_cloud_init, microphys_cloud_end

integer :: idim, jdim, kdim

!namelist:
!real :: diam_liq = 40.0  ! vtp
real :: diam_liq = 33.2

namelist /microphys_cloud_nml/  diam_liq

!-----------------------------------------------------------------------
! version control information
!-----------------------------------------------------------------------

character(len=128)  :: version =  '$Id: microphys_cloud.F90,v 18.0.4.2 2010/09/07 16:17:19 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'

logical ::   module_is_initialized = .false.
contains 

!#######################################################################

! <SUBROUTINE NAME="microphys_cloud">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_cloud ( zhalf, zfull, diam_liq_out, diam_ice)
!
!  </TEMPLATE>
!  <IN NAME="zhalf" TYPE="real">
! 
!  </IN>
!  <IN NAME="zfull" TYPE="real">
! 
!  </IN>
!  <OUT NAME="diam_liq_out" TYPE="real">
! 
!  </OUT>
!  <OUT NAME="diam_ice" TYPE="real">
! 
!  </OUT>
! </SUBROUTINE>
!
subroutine microphys_cloud ( zhalf, zfull, diam_liq_out, diam_ice)

real,    dimension(:,:,:),    intent(in)        :: zhalf, zfull
real,    dimension(:,:,:),    intent(out)       :: diam_liq_out,  &
                                                   diam_ice

!-----------------------------------------------------------------------
!   intent(in) variables:
!
!      zhalf        height asl at half levels [m]
!      zfull        height asl at full levels [m]
!
!   intent(out):
!
!      diam_liq
!      diam_ice
!
!----------------------------------------------------------------------

!-----------------------------------------------------------------------
! local allocations
!-----------------------------------------------------------------------

  idim = size (zfull,1)
  jdim = size (zfull,2)
  kdim = size (zfull,3)

  call get_diam ( zhalf, zfull, diam_ice )
  diam_liq_out = diam_liq

end subroutine microphys_cloud

!#######################################################################

! <SUBROUTINE NAME="get_diam">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_diam ( zhalf, zfull, diam )
!
!  </TEMPLATE>
!  <IN NAME="zhalf" TYPE="real">
! 
!  </IN>
!  <IN NAME="zfull" TYPE="real">
! 
!  </IN>
!  <OUT NAME="diam" TYPE="real">
! 
!  </OUT>
! </SUBROUTINE>
!
subroutine get_diam ( zhalf, zfull, diam )

real, dimension(:,:,:), intent(in)  :: zhalf
real, dimension(:,:,:), intent(in)  :: zfull
real, dimension(:,:,:), intent(out) :: diam

!-----------------------------------------------------------------------
! local allocations
!-----------------------------------------------------------------------

real, dimension(size(zfull,3)+1) :: relht

real :: slope, zref
integer :: i, j, k

  relht(kdim+1) = 0.0

  do i=1,idim
     do j=1,jdim

       zref = zhalf(i,j,kdim+1) + 9.9e3
       relht(1:kdim) = max(0.0, min(1.0, (zfull(i,j,:) - zref)/3.3e3 ))

        k = kdim+1
        do while ( relht(k) < 0.30 .and. k > 1 )
           k=k-1
           slope = (30.72 - 38.50)/(0.30 - 0.00)
           diam(i,j,k) = 38.50 + (relht(k) - 0.00) * slope
        enddo

        do while ( relht(k) < 0.45 .and. k > 1 )
           k=k-1
           slope = (28.28 - 30.72)/(0.45 - 0.30)
           diam(i,j,k) = 30.72 + (relht(k) - 0.30) * slope
        enddo

        do while ( relht(k) < 0.64 .and. k > 1 )
           k=k-1
           slope = (25.62 - 28.28)/(0.64 - 0.45)
           diam(i,j,k) = 28.28 + (relht(k) - 0.45) * slope
        enddo

        do while ( relht(k) < 0.76 .and. k > 1 )
           k=k-1
           slope = (24.80 - 25.62)/(0.76 - 0.64)
           diam(i,j,k) = 25.62 + (relht(k) - 0.64) * slope
        enddo

        do while ( k > 1 ) 
           k=k-1
!           slope = (13.30 - 24.80)/(1.00 - 0.76)                              !vtp
           slope = (18.60 - 24.80)/(1.00 - 0.76)
           diam(i,j,k) = 24.80 + (relht(k) - 0.76) * slope
        enddo

     enddo
  enddo

  return
end subroutine get_diam

!#######################################################################

! <SUBROUTINE NAME="microphys_cloud_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_cloud_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine microphys_cloud_init

integer :: unit, ierr, io, logunit

   if (module_is_initialized ) return
   call fms_init

!-----------------------------------------------------------------------
! read namelist       
!-----------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=microphys_cloud_nml, iostat=io)
  ierr = check_nml_error(io,"microphys_cloud_nml")
#else
  if (file_exist('input.nml')) then
     unit =  open_namelist_file ( )
     ierr=1; do while (ierr /= 0)
     read (unit, nml=microphys_cloud_nml, iostat=io, end=10) 
     ierr = check_nml_error (io, 'microphys_cloud_nml')
     enddo                       
10   call close_file (unit)      
  endif                         
#endif
                                    
!------------------------------------------------------------------------
!  write version number and namelist to logfile.
!------------------------------------------------------------------------

  call write_version_number (version, tagname)
  logunit = stdlog()
  if (mpp_pe() == mpp_root_pe() )                                       &
                                write (logunit, nml=microphys_cloud_nml)

   module_is_initialized = .true.

  return
end subroutine microphys_cloud_init

!#######################################################################
subroutine microphys_cloud_end

   module_is_initialized = .true.

  return
end subroutine microphys_cloud_end

!#######################################################################

end module microphys_cloud_mod



                 module microphys_rad_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!  smf
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Code to provide micro physics subroutines for radiation calculation
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!
!  shared modules:

use mpp_mod,               only:  input_nml_file
use fms_mod,               only:  fms_init, open_namelist_file, &
                                  write_version_number, mpp_pe, &
                                  mpp_root_pe, stdlog, file_exist,  &
                                  check_nml_error, error_mesg,   &
                                  FATAL, close_file
use constants_mod,         only:  constants_init, diffac, radian
use time_manager_mod,      only:  time_type
use diag_manager_mod,      only:  register_diag_field, send_data, &
                                  diag_manager_init
use random_numbers_mod,    only:  randomNumberStream,   &
                                  initializeRandomNumberStream, &
                                  getRandomNumbers,             &
                                  constructSeed
use cloud_generator_mod,   only:  cloud_generator_init, &
                                  cloud_generator_end

!  shared radiation package modules:

use rad_utilities_mod,     only:  rad_utilities_init, Lw_control, &
                                  Cldrad_control, thickavg,  &
                                  cld_specification_type, &
                                  microrad_properties_type, &
                                  cldrad_properties_type, &
                                  microphysics_type, Lw_parameters
use longwave_params_mod,   only:  NBLW, longwave_params_init
use esfsw_parameters_mod,  only:  esfsw_parameters_init, Solar_spect

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    microphys_rad_mod produces cloud radiative properties 
!    based upon input microphysical properties.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: microphys_rad.F90,v 17.0.4.2 2010/09/07 14:03:35 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public          &
           microphys_rad_init, microphys_sw_driver,     &
           microphys_lw_driver, lwemiss_calc,    &
           comb_cldprops_calc, microphys_rad_end, &
           isccp_microphys_lw_driver, isccp_microphys_sw_driver

private         &
!    called from microphys_sw_driver:
           cloudpar, &
!    called from cloudpar:
           slingo, savijarvi, fu, icesolar, snowsw,  &
!    called from microphys_lw_driver:
           cloud_lwpar, cloud_lwem_oneband,    &
!    caled from cloud_lwpar:
           el, el_dge, cliqlw, furainlw, fusnowlw, &
!    currently not used:
           snowlw


!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16)   :: lwem_form=' '     ! longwave emissivity param-
                                         ! eterization; either 'fuliou'
                                         ! or 'ebertcurry'
logical       ::  do_orig_donner_stoch = .true.
logical       ::  do_delta_adj = .false.
logical       ::  do_const_asy = .false.
real          ::  val_const_asy = 0.75
real          ::  alpha = 0.1
                  ! frequency-independent parameter for absorption due 
                  ! to cloud drops in the infrared. this value is given 
                  ! in held et al, JAS, 1993. [ m**2 / g ]

namelist /microphys_rad_nml /     &
                               lwem_form, &
                               do_orig_donner_stoch, &
                               do_delta_adj, &
                               do_const_asy, val_const_asy, &
                               alpha

!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

!----------------------------------------------------------------------
!    parameters and data needed when frequency-dependent longwave 
!    cloud emissivities are activated.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    N_EMISS_BDS : number of  infrared frequency bands over which 
!                  frequency-dependent emissivities are computed 
!                  using appropriate parameterizations. 
!----------------------------------------------------------------------
integer, parameter       :: N_EMISS_BDS = 7

!----------------------------------------------------------------------
!    wavenumber limits for the cloud emissivity frequency bands.
!    THESE MAY BE CHANGED ONLY BY THE KEEPER OF THE RADIATION CODE.
!
!    cldbandlo : low wave number  boundary for the emissivity band
!    cldbandhi : high wave number  boundary for the emissivity band
!----------------------------------------------------------------------
real, dimension (N_EMISS_BDS)     :: cldbandlo, cldbandhi

data cldbandlo /                    &
             0.0, 560.0, 800.0, 900.0, 990.0, 1070.0, 1200.0 /
data cldbandhi /                    &
           560.0, 800.0, 900.0, 990.0, 1070.0, 1200.0, 1400.0 /

!----------------------------------------------------------------------
!    note: the cloud properties for wavelengths beyond 1400 wavenumbers
!    are included in the results for the first band, ie, that band
!    actually is 0-560, 1400-2200 cm-1. thus the following indices 
!    include an extra band.
!  
!     istartcldband : starting wave number index for emissivity band
!     iendcldband   : ending wave number index for emissivity band
!----------------------------------------------------------------------
integer, dimension (N_EMISS_BDS + 1) :: istartcldband, iendcldband

data istartcldband /                &
               1,   57,   81,    91,   100,    108,   121,   141 /
data iendcldband /                  &
              56,   80,   90,    99,   107,    120,   140,   220 /

!----------------------------------------------------------------------
!    parameters for Fu and Liou lw snow water parameterization.
!    NBFL : number of frequency bands in the lw snow water para-
!           meterization. corresponds to bands 7-18 in Fu and Liou 
!           (Table 2).
!    NBA  : number of terms in parameterization for series
!           expansion (not counting the 0th power term) for ai
!    NBB  : number of terms in parameterization for series
!           expansion (not counting the 0th power term) for bi
!    NBC  : number of terms in parameterization for series
!           expansion (not counting the 0th power term) for ci
!   NBA2
!   NBB2
!   NBC2
!----------------------------------------------------------------------
integer, parameter  :: NBFL= 12
integer, parameter  :: NBA = 3
integer, parameter  :: NBB = 3
integer, parameter  :: NBC = 3
integer, parameter  :: NBD = 3
 
integer, parameter  :: NBA2 = 5
integer, parameter  :: NBB2 = 5
integer, parameter  :: NBC2 = 5

!----------------------------------------------------------------------
!    wavenumber ranges  for Fu-Liou ice crystal parameterizations
!    these apply to the ice crystal (El), cloud rain (Furainlw)
!    and cloud snow (Fusnowlw) parameterizations. note: the cloud 
!    liquid drop parameterization (Cliqlw) is frequency-independent.
!
!    endfubands : high wavenumber boundary of wavenumber bands used
!                 in Fu-Liou parameterization. since model wavenumber 
!                 bands are in order of increasing wavenumber, the Fu 
!                 coefficients have been reversed; thus bands 1 -> 12
!                 correspond to Fu bands 18 -> 7.
!    iendfubands : index of model 10 cm-1 bands corresponding to
!                  the value of endfubands. computed in the code.
!----------------------------------------------------------------------
real,    dimension (NBFL)        :: endfubands
integer, dimension (NBFL)        :: iendfubands

data endfubands /                  &
                 280,    400,    540,   670,  800,  980,  1100,  1250, &
                1400,   1700,   1900,   2200 /

!----------------------------------------------------------------------
!    weighting factors relating fu lw bands to model lw frequency
!    bands.
!
!    fulwwts         : fraction of total planck function in emissivity
!                      band n that is in fu band ni. for a given emis-
!                      sivity band, the sum of fulwwts over all fu bands
!                      equals 1.0
!    planckivlicecld : value of the planck function in the portion of
!                      the spectrum common to emissivity band n and 
!                      fu band ni. 
!----------------------------------------------------------------------
real,    dimension (N_EMISS_BDS, NBFL)     :: fulwwts
real,    dimension (N_EMISS_BDS + 1, NBFL) :: planckivlicecld

!---------------------------------------------------------------------
!    nivl1lwicecld  :  fu band index corresponding to the lowest wave
!                      number of the emissivity band
!    nivl2lwicecld  :  fu band index corresponding to the highest wave
!                      number of the emissivity band
!    planckcldband  :  sum of the planck function over the given emis-
!                      sivity band
!---------------------------------------------------------------------
integer, dimension (N_EMISS_BDS + 1) :: nivl1lwicecld, nivl2lwicecld
real,    dimension (N_EMISS_BDS)     :: planckcldband

!----------------------------------------------------------------------
!    parameters for shortwave cloud-radiation parameterizations.
!----------------------------------------------------------------------
 
!----------------------------------------------------------------------
!    NICECLDIVLS  : the number of scattering spectral intervals for the
!                   ice crystals used in the fu parameterization (1996).
!    NICESOLARCLDIVLS 
!                 : the number of scattering spectral intervals for the
!                   ice crystals used in the icesolar parameterization
!                   (fu and liou, 1993).
!    NLIQCLDIVLS  : the number of scattering spectral intervals for the 
!                   cloud drops                                    
!    NRAINCLDIVLS : the number of scattering spectral intervals for the 
!                   rain drops                                         
!    NSNOWCLDIVLS : the number of scattering spectral intervals for snow
!----------------------------------------------------------------------
integer, parameter         ::   NICECLDIVLS      = 25 
integer, parameter         ::   NICESOLARCLDIVLS = 6
integer, parameter         ::   NLIQCLDIVLS      = 24 
integer, parameter         ::   NRAINCLDIVLS     = 4 
integer, parameter         ::   NSNOWCLDIVLS     = 6 
 
!---------------------------------------------------------------------
!    define the spectral limits for drop, rain, ice and snow single    
!    scattering properties in shortwave frequency ranges. 
!---------------------------------------------------------------------
 
!---------------------------------------------------------------------
!    wavenumber limits for slingo cloud drop intervals.             
!---------------------------------------------------------------------
integer, dimension (NLIQCLDIVLS)       :: endliqcldwvn
 
data endliqcldwvn /  2924,  3437,  4202,  4695,  6098,  6536,  7813,   &
                     8404,  9091, 10000, 11494, 12821, 13333, 14493,   &
                    15625, 17544, 19231, 20833, 22727, 25000, 27778,   &
                    30303, 33333, 57600 /
 
!-------------------------------------------------------------------
!    wavenumber limits for Savijarvi rain drop intervals.
!-------------------------------------------------------------------
integer, dimension (NRAINCLDIVLS)      :: endraincldwvn
 
data endraincldwvn / 4202, 8403, 14493, 57600 /
 
!----------------------------------------------------------------------
!    wavenumber limits for icesolar ice crystal intervals.
!---------------------------------------------------------------------- 
integer, dimension (NICESOLARCLDIVLS)  :: endicesolcldwvn
 
data endicesolcldwvn / 2857, 4000, 5263, 7692, 14493, 57600 /
 
!---------------------------------------------------------------------
!    wavenumber limits for fu ice crystal intervals.
!--------------------------------------------------------------------
integer, dimension (NICECLDIVLS)       :: endicecldwvn
 
data endicecldwvn /  2000,  2924,  3437,  4202,  4695,  6098,  6536,   &
                     7092,  8404,  9091, 10000, 11494, 12821, 13333,   &
                    14493, 15625, 17544, 19231, 20833, 22727, 25000,   &
                    27778, 30303, 33333, 57600 /
 
!---------------------------------------------------------------------
!    wavenumber limits for the Fu snow intervals                       
!--------------------------------------------------------------------
integer, dimension (NSNOWCLDIVLS)      :: endsnowcldwvn
 
data endsnowcldwvn / 2857, 4000, 5263, 7692, 14493, 57600 /
 
!----------------------------------------------------------------------
!    these arrays define the intersection points of the solar spectral
!    bands and the wavenumber bands for each of the microphysical
!    species. these must be allocated since the number of spectral
!    bands is determined from namelist input.
!
!       nivl1liqcld    :  cloud droplet band index corresponding to the
!                         lowest wave number of spectral band n
!       nivl1icecld    :  ice crystal band index corresponding to the
!                         lowest wave number of spectral band n, 
!                         (fu, 1996)
!       nivl1icesolcld :  ice crystal band index corresponding to the
!                         lowest wave number of spectral band n
!                         (fu and liou, 1993)
!       nivl1raincld   :  rain drop band index corresponding to the
!                         lowest wave number of spectral band n
!       nivl1snowcld   :  snow flake band index corresponding to the
!                         lowest wave number of spectral band n
!       nivl2liqcld    :  cloud droplet band index corresponding to the
!                         highest wave number of spectral band n
!       nivl2icecld    :  ice crystal band index corresponding to the
!                         highest wave number of spectral band n, 
!                         (fu, 1996)
!       nivl2icesolcld :  ice crystal band index corresponding to the
!                         highest wave number of spectral band n
!                         (fu and liou, 1993)
!       nivl2raincld   :  rain drop band index corresponding to the
!                         highest wave number of spectral band n
!       nivl2snowcld   :  snow flake band index corresponding to the
!                         highest wave number of spectral band n
!----------------------------------------------------------------------
integer, dimension(:), allocatable  :: nivl1liqcld,   &
                                       nivl1icecld,   &
                                       nivl1icesolcld,   &
                                       nivl1raincld,  &
                                       nivl1snowcld,  &
                                       nivl2liqcld,   &
                                       nivl2icecld,   &
                                       nivl2icesolcld,   &
                                       nivl2raincld,  &
                                       nivl2snowcld 

!---------------------------------------------------------------------
!    these arrays define the sum of the toa solar flux in the wave
!    number spectrum common to solar spectral band n and particle
!    spectral band ni.
!
!    solivlicecld    : solar flux in solar spectral band n and ice
!                      crystal band ni (fu, 1996)
!    solivlicesolcld : solar flux in solar spectral band n and ice
!                      crystal band ni (fu and liou, 1996)
!    solivlliqcld    : solar flux in solar spectral band n and cloud
!                      droplet band ni (fu, 1996)
!    solivlraincld   : solar flux in solar spectral band n and rain
!                      drop band ni (fu, 1996)
!    solivlsnowcld    : solar flux in solar spectral band n and snow
!                      flake band ni (fu, 1996)
!---------------------------------------------------------------------
real, dimension(:,:), allocatable  :: solivlicecld,   &
                                      solivlicesolcld, &
                                      solivlliqcld, &
                                      solivlraincld , &
                                      solivlsnowcld

real                               :: min_cld_drop_rad, max_cld_drop_rad
real                               :: min_cld_ice_size, max_cld_ice_size

!----------------------------------------------------------------------
!   variables needed for random number seed:
!----------------------------------------------------------------------
real, dimension(:,:), allocatable  :: lats, lons ! lat and lon of columns
                                               ! in this processor's
                                               ! domain [ degrees ]

!----------------------------------------------------------------------
!    diagnostics variables
!----------------------------------------------------------------------
character(len=16)   :: mod_name = 'microphys_rad'
real                :: missing_value = -999.

!-------------------------------------------------------------------
!    logical variables:
!-------------------------------------------------------------------
logical    :: module_is_initialized = .false. ! module is initialized ?

!--------------------------------------------------------------------
!--------------------------------------------------------------------



                    contains 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="microphys_rad_init">
!  <OVERVIEW>
!   The microphys_rad module constructor
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine initializes micro physics module data,
!   determines micro physics parameterization scheme based
!   on initialization input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_rad_init(cldhm_abs_in, cldml_abs_in)
!  </TEMPLATE>
!  <IN NAME="cldhm_abs_in" TYPE="cldhm_abs_in">
!   boundaries in sigma pressure level between high and middle
!   clouds
!  </IN>
!  <IN NAME="cldml_abs_in" TYPE="cldml_abs_in">
!   boundaries in sigma pressure level between middle and low
!   clouds
!  </IN>
! </SUBROUTINE>
!
subroutine microphys_rad_init (min_cld_drop_rad_in, max_cld_drop_rad_in, &
                               min_cld_ice_size_in, max_cld_ice_size_in, &
                               axes, Time, lonb, latb) 

!------------------------------------------------------------------
!    subroutine microphys_rad_init is the constructor for 
!    microphys_rad_mod.
!--------------------------------------------------------------------

real,                    intent(in)    :: min_cld_drop_rad_in, &
                                          max_cld_drop_rad_in, &
                                          min_cld_ice_size_in, &
                                          max_cld_ice_size_in     
integer, dimension(4),   intent(in)    ::  axes
type(time_type),         intent(in)    ::  Time
real, dimension(:,:),    intent(in)    ::  lonb, latb

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       axes      diagnostic variable axes
!       Time      current time [time_type(days, seconds)]

!----------------------------------------------------------------------
! local variables:                                                  

      real, dimension (NBLW)    ::  src1nb
      real                      :: c1, centnb, sc, x, x1
      real                      :: sumsol1, sumsol2, sumsol3, sumsol4, &
                                   sumsol5
      real                      :: sumplanck 
      real                      :: xtemv = 233.15
      integer                   :: unit, ierr, io, logunit
      integer                   :: nivl, nband
      integer                   :: nivl1, nivl2, nivl3, nivl4, nivl5
      integer                   :: n, ib, nw, ni

!---------------------------------------------------------------------
! local variables:                                                  
!
!     src1nb            radiation emitted in a wavelength band  
!                       [ sec (-3) or ergs/(sec*cm**2) ]
!     c1                expression in Planck's radiation law, 
!                       2*pi*speed of light squared* planck's constant/
!                       wavelength**3 [ gm cm / (sec**3) ]
!     centb             wave number at center of spectral interval
!                       [ cm (-1) ]
!     sc                radiation emitted per unit wavelength
!                       [ 1/(sec**3*cm) or ergs/(sec*cm**2) ]
!     x                 expression in planck's law: 
!                       (h*c)/(k*lambda*temp) [ nondimensional ]
!     x1                expression in planck's law:
!                       exp ( (h*c)/(k*lambda*temp) ) [ nondimensional ]
!     sumsol1           scalar used to accumulate sum of toa solar flux
!                       over a spectral interval common to a cloud drop-
!                       let band and a solar spectral band 
!     sumsol2           scalar used to accumulate sum of toa solar flux
!                       over a spectral interval common to a fu (1996)
!                       ice crystal band and a solar spectral band 
!     sumsol3           scalar used to accumulate sum of toa solar flux
!                       over a spectral interval common to a rain drop 
!                       band and a solar spectral band 
!     sumsol4           scalar used to accumulate sum of toa solar flux
!                       over a spectral interval common to a snow flake
!                       band and a solar spectral band 
!     sumsol5           scalar used to accumulate sum of toa solar flux
!                       over a spectral interval common to a fu and liou
!                       (1993) ice crystal band and a solar spectral 
!                       band 
!     sumplanck         sum of the planck function over a spectral
!                       interval common to a cloud emissivity band and
!                       a water substance band
!     xtemv             temperature at which planck function is 
!                       evaluated [  deg k ]
!     unit              io unit for reading nml file and writing logfile
!     io                error status returned from io operation  
!     ierr              error code
!     nivl              fu band index for lw case
!     nband             cloud band index for lw portion of routine,
!                       sw parameterization band index when doing sw
!     nivl1             cloud droplet band index, sw case
!     nivl2             fu (1996) ice band index, sw case
!     nivl3             rain band index, sw case
!     nivl4             snow band index, sw case
!     nivl5             fu and liou (1993) ice crystal band index, sw
!                       case
!     i,j,k,n,ib,nw,ni  do-loop indices
!
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
        
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init
      call longwave_params_init
      call diag_manager_init

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=microphys_rad_nml, iostat=io)
      ierr = check_nml_error(io,'microphys_rad_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=microphys_rad_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'microphys_rad_nml')
        enddo
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write namelist and version number to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                      write (logunit, nml=microphys_rad_nml)

      min_cld_drop_rad  = min_cld_drop_rad_in
      max_cld_drop_rad  = max_cld_drop_rad_in
      min_cld_ice_size = min_cld_ice_size_in
      max_cld_ice_size = max_cld_ice_size_in

!--------------------------------------------------------------------
!    verify that Lw_control%do_lwcldemiss has been initialized.
!--------------------------------------------------------------------
      if (Lw_control%do_lwcldemiss_iz) then
      else
        call error_mesg ('microphys_rad_mod', &
          ' Lw_control%do_lwcldemiss has not been initialized', FATAL)
      endif

!--------------------------------------------------------------------
!    perform consistency checks between lwem_form and desired lwcld 
!    emissivity. do_lwcldemiss being true implies a multi-band emiss-
!    ivity parameterization; do_lw_micro implies a microphysically-
!    based parameterization. ebert-curry is a single band, microphysic-
!    ally based scheme, fuliou is a multi-band microphysically based
!    scheme.
!--------------------------------------------------------------------
      if (Lw_control%do_lwcldemiss)    then
        if (trim(lwem_form) == 'fuliou') then
        else if (trim(lwem_form) == 'ebertcurry') then
          call error_mesg('microphys_rad_mod',  &
              'ebert-curry not implemented for multi-bands', FATAL)
        else
          call error_mesg('microphys_rad_mod',  &
           'incorrect specification of lwem_form for multi-band', FATAL)
        endif
      else
        if (trim(lwem_form) == 'fuliou') then
          call error_mesg('microphys_rad_mod',  &
          'fu parameterization implemented only for multi-band', FATAL)
        else if (trim(lwem_form) == 'ebertcurry') then
        else
          call error_mesg('microphys_rad_mod',  &
         'incorrect specification of lwem_form for single band', FATAL)
        endif
      endif
      if (Cldrad_control%do_strat_clouds_iz) then     
        if (Cldrad_control%do_strat_clouds) then     
          if (Cldrad_control%do_stochastic_clouds_iz) then
            if (Cldrad_control%do_stochastic_clouds) then
              if (trim(lwem_form)  == 'ebertcurry') then
                call error_mesg ('microphys_rad_mod',  &
              'ebert-curry not allowed with stochastic clouds', FATAL)
              endif
            endif
          else
            call error_mesg ('microphys_rad_mod', &
        'Cldrad_control%do_stochastic_clouds has not been initialized',&
                                                                 FATAL)
          endif
        endif
      else
        call error_mesg ('microphys_rad_mod', &
          ' Cldrad_control%do_strat_clouds has not been initialized',  &
                                                                FATAL)
      endif

!--------------------------------------------------------------------
!    compute band-averaged coefficients for h2o forms in infrared 
!    frequency ranges for the fuliou multi-band parameterization.
!    the actual extinction coefficients (to become emissivities)
!    (and other coefficients) will be calculated as time-dependent
!    quantities.
!    at present, the species included are:
!    1)   cloud drops
!    2)   ice crystals
!    3)   cloud rain
!    4)   cloud snow
!--------------------------------------------------------------------
      if (Lw_control%do_lwcldemiss) then

!--------------------------------------------------------------------
!    verify that  Lw_parameters%lw_band_resolution has been initialized.
!--------------------------------------------------------------------
      if (Lw_parameters%lw_band_resolution_iz) then
      else
        call error_mesg ('microphys_rad_mod', &
         'Lw_parameters%lw_band_resolution has not been initialized',&
                                                                FATAL)
      endif

!--------------------------------------------------------------------
!    determine the band indices in the full lw spectrum which corres-
!    pond to the high wavenumber boundary of the bands used in the 
!    Fu-Liou parameterization. the resolution of the full lw spectrum
!    is given by Lw_parameters%lw_band_resolution.
!--------------------------------------------------------------------
        iendfubands(:) = INT((endfubands(:) + 0.01)/  &
                                     Lw_parameters%lw_band_resolution)

!--------------------------------------------------------------------
!    compute weighting function for each wavenumber band. according to 
!    Fu and Liou, this should be the Planck function evaluated at -40C.
!    (src1nb)
!--------------------------------------------------------------------
        do n=1,NBLW 
          centnb    = 5.0 + (n - 1)*Lw_parameters%lw_band_resolution
          c1        = (3.7412E-05)*centnb   **3
          x         = 1.4387E+00*centnb   /xtemv
          x1        = EXP(x   )
          sc        = c1   /(x1    - 1.0E+00)
          src1nb(n) = Lw_parameters%lw_band_resolution*sc
        end do
 
!--------------------------------------------------------------------
!    add the planck function from each full-spectrum band to the
!    proper cloud band sum. 
!--------------------------------------------------------------------
        planckcldband(:) = 0.0E+00
        do n=1,N_EMISS_BDS
          do ib=istartcldband(n),iendcldband(n)
            planckcldband(n) = planckcldband(n) + src1nb(ib)
          end do
        end do

!--------------------------------------------------------------------
!    contributions from the last cloud band (1400-2200 cm-1) are added
!    to the first cloud band.
!--------------------------------------------------------------------
        do ib=istartcldband(N_EMISS_BDS+1),iendcldband(N_EMISS_BDS+1)
          planckcldband(1) = planckcldband(1) + src1nb(ib)
        end do
 
!---------------------------------------------------------------------
!    compute the sum of the planck function over each spectral segment
!    created when the fu bands and the cloud bands are overlapped. nivl
!    is the fu band index while nband is the cloud band index.
!    planckivlicecld(nband, nivl) is the sum of the planck function in 
!    the portion of the wave number spectrum common to cloud band nband 
!    and fu band nivl. nivl1icecld(nband) is the fu band index 
!    corresponding to the lowest wave number of the nbandth cloud band,
!    and nivl2icecld(nband) is the fu band index corresponding to the
!    highest wave number of the nbandth cloud band.
!---------------------------------------------------------------------
        nivl = 1
        sumplanck = 0.0
        nband = 1
        planckivlicecld(:,:) = 0.0
        nivl1lwicecld(1) = 1
 
        do nw = 1,NBLW
          sumplanck = sumplanck + src1nb(nw)
          if (nw == iendfubands(nivl)) then
            planckivlicecld(nband,nivl) = sumplanck
            sumplanck = 0.0
          end if
          if (nw == iendcldband(nband)) then
            if (nw /= iendfubands(nivl)) then
              planckivlicecld(nband,nivl) = sumplanck 
              sumplanck = 0.0
            end if
            nivl2lwicecld(nband) = nivl
            nband = nband + 1
            if (nband <= N_EMISS_BDS+1) then
              if (nw == iendfubands(nivl)) then
                nivl1lwicecld(nband) = nivl + 1
              else
                nivl1lwicecld(nband) = nivl
              end if
            end if
          end if
          if (nw == iendfubands(nivl)) nivl = nivl + 1
          if (nw >= iendcldband(N_EMISS_BDS+1)) exit
        end do

!--------------------------------------------------------------------
!    compute the fraction of the total planck function in cloud band
!    n that is present in fu band ni. the sum of fulwwts over ni should
!    be 1.00.
!--------------------------------------------------------------------
        fulwwts(:,:) = 0.0E+00
        do n=1,N_EMISS_BDS
          do ni=nivl1lwicecld(n),nivl2lwicecld(n)
            fulwwts(n,ni) = planckivlicecld(n,ni)/planckcldband(n)
          end do
        end do

!--------------------------------------------------------------------
!    the contributions from cloud band (N_EMISS_BDS+1) are included
!    in band 1.
!--------------------------------------------------------------------
        do ni=nivl1lwicecld(N_EMISS_BDS+1),nivl2lwicecld(N_EMISS_BDS+1)
          fulwwts(1,ni) = planckivlicecld(N_EMISS_BDS+1,ni)/   &
                          planckcldband(1)
        end do
      endif  ! (do_lwcldemiss)

!--------------------------------------------------------------------
!    verify that Cldrad_control%do_sw_micro has been initialized.
!--------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro_iz) then
      else
        call error_mesg ('microphys_rad_mod', &
         'Cldrad_control%do_sw_micro has not been initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    the following section is executed when the shortwave parameter-
!    ization is based on microphysical information.
!---------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro) then

!--------------------------------------------------------------------
!    make certain esfsw_parameters_mod has been initialized.
!--------------------------------------------------------------------
        call esfsw_parameters_init

!--------------------------------------------------------------------
!    verify consistency between the highest wavenumber in the solar 
!    spectrum and the highest wavenumber in the various particle
!    spectral intervals to assure that all solar spectral bands are 
!    assigned to a particle band.
!--------------------------------------------------------------------
        if (Solar_spect%tot_wvnums /= endliqcldwvn(NLIQCLDIVLS) .or.  &
            Solar_spect%tot_wvnums /= endicecldwvn(NICECLDIVLS) .or.  &
            Solar_spect%tot_wvnums /=      &
                               endicesolcldwvn(NICESOLARCLDIVLS) .or.  &
            Solar_spect%tot_wvnums /= endraincldwvn(NRAINCLDIVLS) .or.  &
            Solar_spect%tot_wvnums /= endsnowcldwvn(NSNOWCLDIVLS) ) then
          call error_mesg ( 'microphys_rad_mod',  &
              ' highest wavenumber in particle spectrum differs '//&
                'from highest wavenumber in solar spectrum ', FATAL)
        endif

!--------------------------------------------------------------------
!    allocate the module variables that are needed for the shortwave
!    parameterization.
!--------------------------------------------------------------------
        allocate ( nivl1liqcld    (Solar_spect%nbands),    &
                   nivl1icecld    (Solar_spect%nbands),   &
                   nivl1icesolcld (Solar_spect%nbands),   &
                   nivl1raincld   (Solar_spect%nbands),  &
                   nivl1snowcld   (Solar_spect%nbands),  &
                   nivl2liqcld    (Solar_spect%nbands),   &
                   nivl2icecld    (Solar_spect%nbands),   &
                   nivl2icesolcld (Solar_spect%nbands),   &
                   nivl2raincld   (Solar_spect%nbands),   & 
                   nivl2snowcld   (Solar_spect%nbands) ) 

        allocate ( solivlicecld   (Solar_spect%nbands, nicecldivls),  &
                   solivlicesolcld                                  &
                               (Solar_spect%nbands, nicesolarcldivls), &
                   solivlliqcld   (Solar_spect%nbands, nliqcldivls), &
                   solivlraincld  (Solar_spect%nbands, nraincldivls), &
                   solivlsnowcld  (Solar_spect%nbands, nsnowcldivls) )

!---------------------------------------------------------------------
!    compute the sum of the toa solar flux over each spectral segment
!    created when the individual particle bands (fu ice, liquid, rain, 
!    snow, icesolar ice) and the parameterization bands are overlapped. 
!    nivlx is the particle band index while nband is the parameteriz-
!    ation band index. thus solivlxxxcld(nband, nivlx) is the sum of the
!    toa solar flux in the portion of the wave number spectrum common 
!    to parameterization band nband and particle band nivl. 
!    nivl1xxxcld(nband) is the particle band index corresponding to the
!    lowest wave number of the nbandth parameterization band, and 
!    nivl2xxxcld(nband) is the particle band index corresponding to the
!    highest wave number of the nbandth parameterization band.
!    the naming convention is as follows:
!        xxx1 refers to liquid cloud particles
!        xxx2 refers to fu ice cloud particles
!        xxx3 refers to rain particles
!        xxx4 refers to snow particles      
!        xxx5 refers to icesolar ice particles
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    initialize the indices and sums.
!--------------------------------------------------------------------
        nivl1 = 1
        nivl2 = 1
        nivl3 = 1
        nivl4 = 1
        nivl5 = 1
        sumsol1 = 0.0
        sumsol2 = 0.0
        sumsol3 = 0.0
        sumsol4 = 0.0
        sumsol5 = 0.0
        nband = 1
        solivlliqcld(:,:) = 0.0
        solivlicecld(:,:) = 0.0
        solivlicesolcld(:,:) = 0.0
        solivlraincld(:,:) = 0.0
        solivlsnowcld(:,:) = 0.0

!---------------------------------------------------------------------
!    the single scattering properties for wavenumbers < the lower limit
!    to which the various parameterizations apply are assigned the
!    values in the lowest interval of the parameterization; thus all
!    solar spectral parameterization bands are assigned to a 
!    water-species parameterization band.
!---------------------------------------------------------------------
        nivl1liqcld(1) = 1
        nivl1icecld(1) = 1
        nivl1icesolcld(1) = 1
        nivl1raincld(1) = 1
        nivl1snowcld(1) = 1
 
!---------------------------------------------------------------------
!    integrate over wavenumber, summing the solar spectral bands con-
!    sistent with the parameterization band structure and the particle 
!    band structure. when the loop is ended, the solar flux in each
!    spectral region generated by overlapping the parameterization
!    spectrum and a particular particle spectrum will be resident in
!    the solivlxxxcld arrays.
!---------------------------------------------------------------------
        do nw = 1,Solar_spect%tot_wvnums           
          sumsol1 = sumsol1 + Solar_spect%solarfluxtoa(nw) 
          sumsol2 = sumsol2 + Solar_spect%solarfluxtoa(nw) 
          sumsol3 = sumsol3 + Solar_spect%solarfluxtoa(nw) 
          sumsol4 = sumsol4 + Solar_spect%solarfluxtoa(nw) 
          sumsol5 = sumsol5 + Solar_spect%solarfluxtoa(nw) 
          if ( nw == endliqcldwvn(nivl1) ) then
            solivlliqcld(nband,nivl1) = sumsol1
            sumsol1 = 0.0
          end if
          if ( nw == endicecldwvn(nivl2) ) then
            solivlicecld(nband,nivl2) = sumsol2
            sumsol2 = 0.0
          end if
          if ( nw == endraincldwvn(nivl3) ) then
            solivlraincld(nband,nivl3) = sumsol3
            sumsol3 = 0.0
          end if
          if ( nw == endsnowcldwvn(nivl4) ) then
            solivlsnowcld(nband,nivl4) = sumsol4
            sumsol4 = 0.0
          end if
          if ( nw == endicesolcldwvn(nivl5) ) then
            solivlicesolcld(nband,nivl5) = sumsol5
            sumsol5 = 0.0
          end if
          if ( nw == Solar_spect%endwvnbands(nband) ) then
            if ( nw /= endliqcldwvn(nivl1) ) then
              solivlliqcld(nband,nivl1) = sumsol1 
              sumsol1 = 0.0
            end if
            if ( nw /= endicecldwvn(nivl2) ) then
              solivlicecld(nband,nivl2) = sumsol2 
              sumsol2 = 0.0
            end if
            if ( nw /= endraincldwvn(nivl3) ) then
              solivlraincld(nband,nivl3) = sumsol3 
              sumsol3 = 0.0
            end if
            if ( nw /= endsnowcldwvn(nivl4) ) then
              solivlsnowcld(nband,nivl4) = sumsol4 
              sumsol4 = 0.0
            end if
            if ( nw /= endicesolcldwvn(nivl5) ) then
              solivlicesolcld(nband,nivl5) = sumsol5 
              sumsol5 = 0.0
            end if
            nivl2liqcld(nband) = nivl1
            nivl2icecld(nband) = nivl2
            nivl2raincld(nband) = nivl3
            nivl2snowcld(nband) = nivl4
            nivl2icesolcld(nband) = nivl5
 
            nband = nband + 1
 
            if ( nband <= Solar_spect%nbands ) then
 
              if ( nw == endliqcldwvn(nivl1) ) then
                nivl1liqcld(nband) = nivl1 + 1
              else
                nivl1liqcld(nband) = nivl1
              end if
              if ( nw == endicecldwvn(nivl2) ) then
                nivl1icecld(nband) = nivl2 + 1
              else
                nivl1icecld(nband) = nivl2
              end if
              if ( nw == endraincldwvn(nivl3) ) then
                nivl1raincld(nband) = nivl3 + 1
              else
                nivl1raincld(nband) = nivl3
              end if
              if ( nw == endsnowcldwvn(nivl4) ) then
                nivl1snowcld(nband) = nivl4 + 1
              else
                nivl1snowcld(nband) = nivl4
              end if
              if ( nw == endicesolcldwvn(nivl5) ) then
                nivl1icesolcld(nband) = nivl5 + 1
              else
                nivl1icesolcld(nband) = nivl5
              end if
            end if
          end if
          if ( nw == endliqcldwvn(nivl1) ) nivl1 = nivl1 + 1
          if ( nw == endicecldwvn(nivl2) ) nivl2 = nivl2 + 1
          if ( nw == endraincldwvn(nivl3) ) nivl3 = nivl3 + 1
          if ( nw == endsnowcldwvn(nivl4) ) nivl4 = nivl4 + 1
          if ( nw == endicesolcldwvn(nivl5) ) nivl5 = nivl5 + 1
        end do
      endif   ! (do_sw_micro)

!-----------------------------------------------------------------
!    mark module as initialized.
!----------------------------------------------------------------
      module_is_initialized = .true.

!-----------------------------------------------------------------


end subroutine microphys_rad_init


!###################################################################
! <SUBROUTINE NAME="microphys_sw_driver">
!  <OVERVIEW>
!   Subroutine to deploy micro physics radiation calculation,
!   particularly for cloud parameterizations in the shortwave
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine takes cloud micro physics parameters and
!   calculate broad band cloud radiation parameters. For example
!   the input parameters are cloud droplet concentration, size,
!   and composition; the output parameters are cloud extinction
!   coefficient, scattering coefficient, and assymmetry parameters.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_sw_driver (is, ie, js, je, Cloud_microphysics,  &
!                                Cloud_rad_props, donner_flag )
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting indice of x dimension in current physics window
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   ending indice of x dimension in current physics window
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting indice of y dimension in current physics window
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   ending indice of y dimension in current physics window
!  </IN>
!  <IN NAME="Cloud_microphysics" TYPE="microphysics_type">
!   derived type variable containing cloud 
!                          microphysical specification information 
!  </IN>
!  <INOUT NAME="Cloud_rad_props" TYPE="microrad_properties_type">
!   derived type variable containing the micro-
!                          physically-based sw cloud radiative proper-
!                          ties [ microrad_properties_type ]
!                              the components defined in this routine:
!                            %cldext   parameterization band values of 
!                                      the cloud extinction coefficient 
!                                      [ km**(-1) ]   
!                            %cldsct   parameterization band values of 
!                                      the cloud scattering coefficient 
!                                      [ km**(-1) ] 
!                            %cldasymm parameterization band values of 
!                                      the asymmetry factor 
!                                      [ dimensionless ]
!  </INOUT>
!  <IN NAME="donner_flag" TYPE="logical">
!   OPTIONAL: logical flag which if present indicates
!                           that clouds from donner_deep_mod are being
!                           processed, and that an ice parameterization
!                           associated with that scheme (which differs
!                           from that used by strat_cloud_mod) is to
!                           be used.
!  </IN>
! </SUBROUTINE>
subroutine microphys_sw_driver (is, ie, js, je, Cloud_microphysics,  &
                                Cloud_rad_props, Micro_rad_props, &
                                donner_flag )

!---------------------------------------------------------------------
!    microphys_sw_driver obtains microphysically-based cloud shortwave
!    radiative properties for the cloud field described by Cloud_micro-
!    physics and returnms them in Cloud_rad_props.
!---------------------------------------------------------------------

integer,                        intent(in)      :: is, ie, js, je
type(microphysics_type),        intent(in)      :: Cloud_microphysics
type(microrad_properties_type), intent(inout), optional   :: Micro_rad_props
type(cldrad_properties_type), intent(inout), optional   :: Cloud_rad_props
logical,                        intent(in),                         &
                                       optional :: donner_flag 

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je         starting/ending subdomain i,j indices of data
!                          in the physics_window being integrated
!      Cloud_microphysics  derived type variable containing cloud 
!                          microphysical specification information 
!                          [ microphysics_type ]
!
!   intent(inout) variable:
!
!      Cloud_rad_props     derived type variable containing the micro-
!                          physically-based sw cloud radiative proper-
!                          ties [ microrad_properties_type ]
!                              the components defined in this routine:
!                            %cldext   parameterization band values of 
!                                      the cloud extinction coefficient 
!                                      [ km**(-1) ]   
!                            %cldsct   parameterization band values of 
!                                      the cloud scattering coefficient 
!                                      [ km**(-1) ] 
!                            %cldasymm parameterization band values of 
!                                      the asymmetry factor 
!                                      [ dimensionless ]
!
!    intent(in), optional variable:
!
!      donner_flag          logical flag which if present indicates
!                           that clouds from donner_deep_mod are being
!                           processed, and that an ice parameterization
!                           associated with that scheme (which differs
!                           from that used by strat_cloud_mod) is to
!                           be used. 
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:                                                  

      real, dimension   &
                   (size(Cloud_microphysics%size_drop,1), &
                    size(Cloud_microphysics%size_drop,2), &
                    size(Cloud_microphysics%size_drop,3), &
                                      Solar_spect%nbands) :: &
                       size_drop, size_ice, conc_drop, conc_ice
      logical, dimension &
                   (size(Cloud_microphysics%size_drop,1), &
                    size(Cloud_microphysics%size_drop,2), &
                    size(Cloud_microphysics%size_drop,3), &
                                      Solar_spect%nbands) :: &
                                                        dge_column

      logical       :: do_dge_sw, isccp_call
      integer       :: nbmax
      integer       :: n
      integer       :: nnn, nbprofiles, nonly

!----------------------------------------------------------------------
!  local variables:                                                  
!
!      do_dge_sw     logical flag; when .true., indicates that 
!                    donner_deep_mod clouds are being processed
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!    define variable indicating whether doner_deep_mods clouds or 
!    large-scale clouds are currently being processed.
!---------------------------------------------------------------------
      if (present (donner_flag )) then
        if (donner_flag) then
          do_dge_sw = .true.
        else
          do_dge_sw = .false.
        endif
      else
        do_dge_sw = .false.
     endif
     if (Cldrad_control%using_fu2007) then
       do_dge_sw = .true.
     endif

     dge_column = do_dge_sw
     isccp_call = .false.

!---------------------------------------------------------------------
!    if large-scale clouds are being processed and stochastic sw
!    clouds has been activated, define the microphysical inputs
!    for each sw parameterization band and the number of such fields.
!---------------------------------------------------------------------
      if (.not. present (donner_flag)) then
        if (Cldrad_control%do_stochastic_clouds) then
          size_drop = Cloud_microphysics%sw_stoch_size_drop
          size_ice  = Cloud_microphysics%sw_stoch_size_ice
          conc_drop = Cloud_microphysics%sw_stoch_conc_drop
          conc_ice  = Cloud_microphysics%sw_stoch_conc_ice
          if (Cldrad_control%do_ica_calcs) then
            nbprofiles = Solar_spect%nbands
            nbmax = 1
          else
            nbprofiles = 1
            nbmax = Solar_spect%nbands
          endif

!---------------------------------------------------------------------
!    if large-scale clouds are being processed and stochastic sw
!    clouds are not desired, define the microphysical inputs
!    as obtained previously from the full predicted cloud field.
!---------------------------------------------------------------------
        else
          size_drop(:,:,:,1) = Cloud_microphysics%size_drop
          size_ice(:,:,:,1)  = Cloud_microphysics%size_ice
          conc_drop(:,:,:,1) = Cloud_microphysics%conc_drop
          conc_ice(:,:,:,1)  = Cloud_microphysics%conc_ice
          nbmax = 1
        endif

!---------------------------------------------------------------------
!    call cloudpar to define microphysically-based sw cloud properties.
!---------------------------------------------------------------------
      if (present(Cloud_rad_props)) then
      do nnn=1,nbprofiles ! loop over profiles
      nonly = 0
      call cloudpar                                                 &
                     (nonly, nbmax, nnn, size_drop, size_ice,   &
                      Cloud_microphysics%size_rain,              &
                      conc_drop, conc_ice, &
                      Cloud_microphysics%conc_rain, &
                      Cloud_microphysics%conc_snow, do_dge_sw,   &
                      dge_column, isccp_call, &
                      Cloud_rad_props%cldext(:,:,:,:,nnn),   &
                      Cloud_rad_props%cldsct(:,:,:,:,nnn), &
                      Cloud_rad_props%cldasymm(:,:,:,:,nnn))
       end do
      else
      nnn = 1
      nonly = 0
      call cloudpar                                                 &
                     (nonly, nbmax, nnn, size_drop, size_ice,   &
                      Cloud_microphysics%size_rain,              &
                      conc_drop, conc_ice, &
                      Cloud_microphysics%conc_rain, &
                      Cloud_microphysics%conc_snow, do_dge_sw,   &
                      dge_column, isccp_call, &
                      Micro_rad_props%cldext, Micro_rad_props%cldsct, &
                      Micro_rad_props%cldasymm)
       endif

!-------------------------------------------------------------------
!    if donner cloud fields are being processed, there is currently
!    no stochastic component. use the same properties for each sw
!    parameterization band.
!-------------------------------------------------------------------
      else  ! (donner_flag)
        nnn = 1
        nbprofiles = 1
        nbmax = Solar_spect%nbands
        nonly = 0
        do n=1, Solar_spect%nbands
        size_drop(:,:,:,n) = Cloud_microphysics%size_drop
        size_ice(:,:,:,n)  = Cloud_microphysics%size_ice
        conc_drop(:,:,:,n) = Cloud_microphysics%conc_drop
        conc_ice(:,:,:,n)  = Cloud_microphysics%conc_ice
        end do

        call cloudpar                                 &
                     (nonly, nbmax, nnn, size_drop, size_ice,   &
                      Cloud_microphysics%size_rain,              &
                      conc_drop, conc_ice, &
                      Cloud_microphysics%conc_rain, &
                      Cloud_microphysics%conc_snow, do_dge_sw,   &
                      dge_column, isccp_call, &
                      Micro_rad_props%cldext, Micro_rad_props%cldsct, &
                      Micro_rad_props%cldasymm)
      endif ! (present(donner_flag))
 
!--------------------------------------------------------------------



end subroutine microphys_sw_driver


!#####################################################################
! <SUBROUTINE NAME="microphys_lw_driver">
!  <OVERVIEW>
!   Subroutine to deploy micro physics radiation calculation,
!   particularly for cloud parameterizations in the longwave
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine takes cloud micro physics parameters and
!   calculate broad band cloud radiation parameters. For example
!   the input parameters are cloud droplet concentration, size,
!   and composition; the output parameters are cloud extinction
!   coefficient, scattering coefficient, and assymmetry parameters.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_lw_driver (is, ie, js, je, Cloud_microphysics,  &
!                                Cloud_rad_props, donner_flag )
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting indice of x dimension in current physics window
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   ending indice of x dimension in current physics window
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting indice of y dimension in current physics window
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   ending indice of y dimension in current physics window
!  </IN>
!  <IN NAME="Cloud_microphysics" TYPE="microphysics_type">
!   derived type variable containing cloud 
!                          microphysical specification information 
!  </IN>
!  <INOUT NAME="Cloud_rad_props" TYPE="microrad_properties_type">
!   derived type variable containing the micro-
!                          physically-based sw cloud radiative proper-
!                          ties [ microrad_properties_type ]
!                              the components defined in this routine:
!                            %cldext   parameterization band values of 
!                                      the cloud extinction coefficient 
!                                      [ km**(-1) ]   
!                            %cldsct   parameterization band values of 
!                                      the cloud scattering coefficient 
!                                      [ km**(-1) ] 
!                            %cldasymm parameterization band values of 
!                                      the asymmetry factor 
!                                      [ dimensionless ]
!  </INOUT>
!  <IN NAME="donner_flag" TYPE="logical">
!   OPTIONAL: logical flag which if present indicates
!                           that clouds from donner_deep_mod are being
!                           processed, and that an ice parameterization
!                           associated with that scheme (which differs
!                           from that used by strat_cloud_mod) is to
!                           be used.
!  </IN>
! </SUBROUTINE>
subroutine microphys_lw_driver (is, ie, js, je, Cloud_microphysics,  &
                                Cloud_rad_props, Micro_rad_props, &
                                donner_flag )

!---------------------------------------------------------------------
!    microphys_lw_driver obtains microphysically-based cloud longwave
!    radiative properties for the cloud field described by Cloud_micro-
!    physics and returnms them in Cloud_rad_props.
!---------------------------------------------------------------------

integer,                        intent(in)      :: is, ie, js, je
type(microphysics_type),        intent(in)      :: Cloud_microphysics
type(cldrad_properties_type), intent(inout),optional   :: Cloud_rad_props
type(microrad_properties_type), intent(inout),optional   :: Micro_rad_props
logical,                        intent(in),                         &
                                       optional :: donner_flag 

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je         starting/ending subdomain i,j indices of data
!                          in the physics_window being integrated
!      Cloud_microphysics  derived type variable containing cloud 
!                          microphysical specification information 
!                          [ microphysics_type ]
!
!   intent(inout) variable:
!
!      Cloud_rad_props     derived type variable containing the micro-
!                          physically-based sw cloud radiative proper-
!                          ties [ microrad_properties_type ]
!                              the component defined in this routine:
!                             %abscoeff absorption coefficient for 
!                                       clouds in each of the longwave 
!                                       frequency bands [ km**(-1) ]
!
!    intent(in), optional variable:
!
!      donner_flag          logical flag which if present indicates
!                           that clouds from donner_deep_mod are being
!                           processed, and that an ice parameterization
!                           associated with that scheme (which differs
!                           from that used by strat_cloud_mod) is to
!                           be used. 
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:                                                  

      real, dimension   &
                  (size(Cloud_microphysics%size_drop,1), &
                   size(Cloud_microphysics%size_drop,2), &
                   size(Cloud_microphysics%size_drop,3), &
                   Cldrad_control%nlwcldb) :: &
                        size_drop, size_ice, conc_drop, conc_ice
      logical       :: do_dge_lw, isccp_call
      integer :: nbmax, nbprofiles, nnn, nonly
      logical, dimension   &
                  (size(Cloud_microphysics%size_drop,1), &
                   size(Cloud_microphysics%size_drop,2), &
                   size(Cloud_microphysics%size_drop,3), &
                   Cldrad_control%nlwcldb) ::   dge_column

!----------------------------------------------------------------------
!  local variables:                                                  
!
!      do_dge_lw     logical flag; when .true., indicates that 
!                    donner_deep_mod clouds are being processed
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!    define variable indicating whether donner_deep_mods clouds or 
!    large-scale clouds are currently being processed.
!---------------------------------------------------------------------
      if (present (donner_flag )) then
        if (donner_flag) then
          do_dge_lw = .true.
        else
          do_dge_lw = .false.
        endif
      else
        do_dge_lw = .false.
      endif

      if (Cldrad_control%using_fu2007) then
        do_dge_lw = .true.
      endif

       dge_column = do_dge_lw
       isccp_call = .false.

!---------------------------------------------------------------------
!    if large-scale clouds are being processed and stochastic lw
!    clouds has been activated, define the microphysical inputs
!    for each lw parameterization band and the number of such fields.
!---------------------------------------------------------------------
      if ( .not. present (donner_flag )) then
        if (Cldrad_control%do_stochastic_clouds) then
          size_drop = Cloud_microphysics%lw_stoch_size_drop
          size_ice  = Cloud_microphysics%lw_stoch_size_ice
          conc_drop = Cloud_microphysics%lw_stoch_conc_drop
          conc_ice  = Cloud_microphysics%lw_stoch_conc_ice
          if (Cldrad_control%do_ica_calcs) then
            nbprofiles = Cldrad_control%nlwcldb
            nbmax = 1
          else
            nbprofiles = 1
            nbmax = Cldrad_control%nlwcldb
          endif


!---------------------------------------------------------------------
!    if large-scale clouds are being processed and stochastic lw
!    clouds are not desired, define the microphysical inputs
!    as obtained previously from the full predicted cloud field.
!---------------------------------------------------------------------
        else
          size_drop(:,:,:,1) = Cloud_microphysics%size_drop
          size_ice(:,:,:,1)  = Cloud_microphysics%size_ice
          conc_drop(:,:,:,1) = Cloud_microphysics%conc_drop
          conc_ice(:,:,:,1)  = Cloud_microphysics%conc_ice
          nbmax = 1
        endif

!-------------------------------------------------------------------
!    if the fuliou lw emissivity was selected, call cloud_lwpar to 
!    compute multi-band emissivities based on fu parameterizations for
!    cloud drop, cloud ice, snow and rain. 
!---------------------------------------------------------------------
      if (trim(lwem_form) == 'fuliou') then
      if (present(Cloud_rad_props)) then
      do nnn=1,nbprofiles ! loop over profiles
        nonly = 0
        call cloud_lwpar (nonly, nbmax, nnn, size_drop, size_ice,   &
                          Cloud_microphysics%size_rain,              &
                          conc_drop, conc_ice, &
                          Cloud_microphysics%conc_rain, &
                          Cloud_microphysics%conc_snow, do_dge_lw,   &
                          dge_column, isccp_call, &
                          Cloud_rad_props%abscoeff(:,:,:,:,nnn))
     end do
    else  ! ((present(Cloud_rad_props))
        nnn = 1
        nonly = 0
        call cloud_lwpar (nonly, nbmax, nnn, size_drop, size_ice,   &
                          Cloud_microphysics%size_rain,              &
                          conc_drop, conc_ice, &
                          Cloud_microphysics%conc_rain, &
                          Cloud_microphysics%conc_snow, do_dge_lw,   &
                          dge_column, isccp_call, &
                          Micro_rad_props%abscoeff)
     endif   ! ((present(Cloud_rad_props))

!---------------------------------------------------------------------
!    if the ebert-curry emissivity was selected, call cloud_lwem_oneband
!    to compute a single value for the lw emissivity (including effects
!    of drops and ice) based on the ebert and curry parameterization.
!---------------------------------------------------------------------
      else if (trim(lwem_form) == 'ebertcurry') then
       if (present(Cloud_rad_props)) then
        call cloud_lwem_oneband (Cloud_microphysics%conc_drop,   &
                                 Cloud_microphysics%conc_ice,    &
                                 Cloud_microphysics%size_drop,    &
                                 Cloud_microphysics%size_ice,      &
                                 Cloud_rad_props%abscoeff(:,:,:,1,1))
       else
        call cloud_lwem_oneband (Cloud_microphysics%conc_drop,   &
                                 Cloud_microphysics%conc_ice,    &
                                 Cloud_microphysics%size_drop,    &
                                 Cloud_microphysics%size_ice,      &
                                 Micro_rad_props%abscoeff(:,:,:,1))
       endif
      endif

!-------------------------------------------------------------------
!    if donner cloud fields are being processed, there is currently
!    no stochastic component. use the same properties for each lw
!    parameterization band.
!-------------------------------------------------------------------
    else ! (donner_flag)
      nbmax = 1
      size_drop(:,:,:,1) = Cloud_microphysics%size_drop
      size_ice(:,:,:,1)  = Cloud_microphysics%size_ice
      conc_drop(:,:,:,1) = Cloud_microphysics%conc_drop
      conc_ice(:,:,:,1)  = Cloud_microphysics%conc_ice
 
!---------------------------------------------------------------------
!    if the fuliou lw emissivity was selected, call cloud_lwpar to
!    compute multi-band emissivities based on fu parameterizations for
!    cloud drop, cloud ice, snow and rain.
!---------------------------------------------------------------------
     if (trim(lwem_form) == 'fuliou') then
       nnn = 1
       nonly = 0
       call cloud_lwpar (nonly, nbmax, nnn,  size_drop, size_ice,   &
                         Cloud_microphysics%size_rain,              &
                         conc_drop, conc_ice, &
                         Cloud_microphysics%conc_rain, &
                         Cloud_microphysics%conc_snow, do_dge_lw,   &
                          dge_column, isccp_call, &
                         Micro_rad_props%abscoeff)

!---------------------------------------------------------------------
!    if the ebert-curry emissivity was selected, call cloud_lwem_oneband
!    to compute a single value for the lw emissivity (including effects
!    of drops and ice) based on the ebert and curry parameterization.
!---------------------------------------------------------------------
     else if (trim(lwem_form) == 'ebertcurry') then
       call cloud_lwem_oneband (Cloud_microphysics%conc_drop,   &
                                Cloud_microphysics%conc_ice,    &
                                Cloud_microphysics%size_drop,    &
                                Cloud_microphysics%size_ice,      &
                                Cloud_rad_props%abscoeff(:,:,:,1,1))
     endif
   endif

!--------------------------------------------------------------------



end subroutine microphys_lw_driver  




!###################################################################
! <SUBROUTINE NAME="isccp_microphys_sw_driver">
!  <OVERVIEW>
!   Subroutine to deploy micro physics radiation calculation,
!   particularly for cloud parameterizations in the shortwave
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine takes cloud micro physics parameters and
!   calculate broad band cloud radiation parameters. For example
!   the input parameters are cloud droplet concentration, size,
!   and composition; the output parameters are cloud extinction
!   coefficient, scattering coefficient, and assymmetry parameters.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_microphys_sw_driver (is, js, iswband,
!                                   Cloud_microphysics,cldext )
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting indice of x dimension in current physics window
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting indice of y dimension in current physics window
!  </IN>
!  <IN NAME="iswband" TYPE="integer">
!   swband whose extinction we desire
!  </IN>
!  <IN NAME="Cloud_microphysics" TYPE="microphysics_type">
!   derived type variable containing cloud 
!                          microphysical specification information 
!  </IN>
!  <OUT NAME="cldext " TYPE="real">
!   derived type variable containing the micro-
!                          physically-based sw cloud radiative proper-
!                          ties [ microrad_properties_type ]
!                              the components defined in this routine:
!                            %cldext   parameterization band values of 
!                                      the cloud extinction coefficient 
!                                      [ km**(-1) ]   
!  </OUT>
! </SUBROUTINE>
subroutine isccp_microphys_sw_driver (is, js, iswband, &
                                Cloud_microphysics, cldext )

!---------------------------------------------------------------------
!    isccp_microphys_sw_driver obtains microphysically-based cloud shortwave
!    radiative properties for the cloud field described by Cloud_micro-
!    physics and returnms them in Cloud_rad_props.
!---------------------------------------------------------------------

integer,                        intent(in)      :: is, js
integer,                        intent(in)      :: iswband
type(microphysics_type),        intent(in)      :: Cloud_microphysics
real, intent(out), dimension(:,:,:,:)           :: cldext

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is, js              starting  subdomain i,j indices of data
!                          in the physics_window being integrated
!      Cloud_microphysics  derived type variable containing cloud 
!                          microphysical specification information 
!                          [ microphysics_type ]
!
!   intent(out) variable:
!
!      cldext   parameterization band values of 
!                                      the cloud extinction coefficient 

!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:                                                  

      real, dimension   &
                   (size(Cloud_microphysics%size_drop,1), &
                    size(Cloud_microphysics%size_drop,2), &
                    size(Cloud_microphysics%size_drop,3), &
                                      Solar_spect%nbands) :: &
                       size_drop, size_ice, conc_drop, conc_ice, &
                       tmpcldext,tmpcldsct,tmpcldasymm
      logical, dimension &
                   (size(Cloud_microphysics%size_drop,1), &
                    size(Cloud_microphysics%size_drop,2), &
                    size(Cloud_microphysics%size_drop,3), &
                                      Solar_spect%nbands) :: dge_column

      
      logical       :: do_dge_sw, isccp_call
      integer       :: nbmax
      integer       :: i,j,k
      integer       :: nnn, nbprofiles, nonly

!----------------------------------------------------------------------
!  local variables:                                                  
!
!      do_dge_sw     logical flag; when .true., indicates that 
!                    donner_deep_mod clouds are being processed
!
!----------------------------------------------------------------------
        
!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!    define variable indicating whether doner_deep_mods clouds or 
!    large-scale clouds are currently being processed.
!   
!    donner clouds will not be accessed here
!---------------------------------------------------------------------
      if (Cldrad_control%using_fu2007) then
        do_dge_sw = .true.
      else
        do_dge_sw = .false.
      endif

      isccp_call = .true.


!---------------------------------------------------------------------
!    loop over profiles
!---------------------------------------------------------------------
     nonly = iswband
     nbmax = Solar_spect%nbands
     nbprofiles = size(Cloud_microphysics%stoch_size_drop,4)
     
     do nnn = 1, nbprofiles

!---------------------------------------------------------------------
!    if large-scale clouds are being processed and stochastic sw
!    clouds has been activated, define the microphysical inputs
!    for each sw parameterization band and the number of such fields.
!---------------------------------------------------------------------
        
      size_drop(:,:,:,nonly) = Cloud_microphysics%stoch_size_drop(:,:,:,nnn)
      size_ice(:,:,:,nonly)  = Cloud_microphysics%stoch_size_ice(:,:,:,nnn)
      conc_drop(:,:,:,nonly) = Cloud_microphysics%stoch_conc_drop(:,:,:,nnn)
      conc_ice(:,:,:,nonly)  = Cloud_microphysics%stoch_conc_ice(:,:,:,nnn)
      if (Cldrad_control%using_fu2007) then
        dge_column = .true.
      else
      do k=1, size(cldext,3)
        do j=1, size(cldext,2)
          do i=1, size(cldext,1)
            if (Cloud_microphysics%stoch_cloud_type(i,j,k,nnn) == 2   &
                        .or. &
                Cloud_microphysics%stoch_cloud_type(i,j,k,nnn) == 3 ) &
                         then 
              dge_column(i,j,k,nonly) = .true.
            else
              dge_column(i,j,k,nonly) = .false.
            endif
          end do
        end do
      end do
      endif
           
!---------------------------------------------------------------------
!    call cloudpar to define microphysically-based sw cloud properties.
!---------------------------------------------------------------------
         call cloudpar                                        &
                     (nonly, nbmax, 1, size_drop, size_ice,   &
                      Cloud_microphysics%size_rain,              &
                      conc_drop, conc_ice, &
                      Cloud_microphysics%conc_rain, &
                      Cloud_microphysics%conc_snow, do_dge_sw,   &
                      dge_column, isccp_call, &
                      tmpcldext, tmpcldsct,tmpcldasymm)
       
!---------------------------------------------------------------------
!   save desired profile
!---------------------------------------------------------------------

         cldext(:,:,:,nnn) = tmpcldext(:,:,:,iswband)

     enddo        !loop over profiles


end subroutine isccp_microphys_sw_driver





!#####################################################################
! <SUBROUTINE NAME="isccp_microphys_lw_driver">
!  <OVERVIEW>
!   Subroutine to deploy micro physics radiation calculation,
!   particularly for cloud parameterizations in the longwave
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine takes cloud micro physics parameters and
!   calculate broad band cloud radiation parameters. For example
!   the input parameters are cloud droplet concentration, size,
!   and composition; the output parameters are cloud extinction
!   coefficient, scattering coefficient, and assymmetry parameters.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call isccp_microphys_lw_driver (is, js, ilwband, &
!                                Cloud_microphysics,abscoeff )
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting indice of x dimension in current physics window
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting indice of y dimension in current physics window
!  </IN>
!  <IN NAME="ilwband" TYPE="integer">
!   lwband whose absorption we desire
!  </IN>
!  <IN NAME="Cloud_microphysics" TYPE="microphysics_type">
!   derived type variable containing cloud 
!                          microphysical specification information 
!  </IN>
!  <OUT NAME="abscoeff" TYPE="real">
!        abscoeff absorption coefficient for 
!        clouds in each of the longwave frequency bands [ km**(-1) ]
!  </OUT>
! </SUBROUTINE>
subroutine isccp_microphys_lw_driver (is, js, ilwband, &
                                Cloud_microphysics, abscoeff )

!---------------------------------------------------------------------
!    isccp_microphys_lw_driver obtains microphysically-based cloud longwave
!    radiative properties for the cloud field described by Cloud_micro-
!    physics and returnms them in Cloud_rad_props.
!---------------------------------------------------------------------

integer,                        intent(in)      :: is, js
integer,                        intent(in)      :: ilwband
type(microphysics_type),        intent(in)      :: Cloud_microphysics
real, intent(out), dimension(:,:,:,:)           :: abscoeff

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je         starting/ending subdomain i,j indices of data
!                          in the physics_window being integrated
!      Cloud_microphysics  derived type variable containing cloud 
!                          microphysical specification information 
!                          [ microphysics_type ]
!
!   intent(out) variable:
!
!      abscoeff absorption coefficient for 
!                                       clouds in each of the longwave 
!                                       frequency bands [ km**(-1) ]
!
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:                                                  

      real, dimension   &
                  (size(Cloud_microphysics%size_drop,1), &
                   size(Cloud_microphysics%size_drop,2), &
                   size(Cloud_microphysics%size_drop,3), &
                   Cldrad_control%nlwcldb) :: &
                        size_drop, size_ice, conc_drop, conc_ice, &
                        tmpabscoeff
      logical, dimension &
                  (size(Cloud_microphysics%size_drop,1), &
                   size(Cloud_microphysics%size_drop,2), &
                   size(Cloud_microphysics%size_drop,3), &
                   Cldrad_control%nlwcldb) :: dge_column
      logical       :: do_dge_lw, isccp_call
      integer :: nbmax, nbprofiles, nnn, nonly
      integer   :: i, j, k

!----------------------------------------------------------------------
!  local variables:                                                  
!
!      do_dge_lw     logical flag; when .true., indicates that 
!                    donner_deep_mod clouds are being processed
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!    define variable indicating whether doner_deep_mods clouds or 
!    large-scale clouds are currently being processed.
!
!     Donner is never on for this loop
!---------------------------------------------------------------------
      if (Cldrad_control%using_fu2007) then
        do_dge_lw = .true.
      else
        do_dge_lw = .false.
      endif
      isccp_call = .true.
      

!---------------------------------------------------------------------
!    loop over profiles
!---------------------------------------------------------------------
     nonly = ilwband
     nbmax = Cldrad_control%nlwcldb
     nbprofiles = size(Cloud_microphysics%stoch_size_drop,4)
     
     do nnn = 1, nbprofiles

!---------------------------------------------------------------------
!    if large-scale clouds are being processed and stochastic sw
!    clouds has been activated, define the microphysical inputs
!    for each sw parameterization band and the number of such fields.
!---------------------------------------------------------------------
     size_drop(:,:,:,nonly) = Cloud_microphysics%stoch_size_drop(:,:,:,nnn)
     size_ice(:,:,:,nonly)  = Cloud_microphysics%stoch_size_ice(:,:,:,nnn)
     conc_drop(:,:,:,nonly) = Cloud_microphysics%stoch_conc_drop(:,:,:,nnn)
     conc_ice(:,:,:,nonly)  = Cloud_microphysics%stoch_conc_ice(:,:,:,nnn)
        
      if (Cldrad_control%using_fu2007) then
        dge_column = .true.
      else
      do k=1, size(abscoeff,3)
        do j=1, size(abscoeff,2)
          do i=1, size(abscoeff,1)
            if (Cloud_microphysics%stoch_cloud_type(i,j,k,nnn) == 2   &
                        .or. &
                Cloud_microphysics%stoch_cloud_type(i,j,k,nnn) == 3 ) &
                         then 
              dge_column(i,j,k,nonly) = .true.
            else
              dge_column(i,j,k,nonly) = .false.
            endif
          end do
        end do
      end do
      endif
!-------------------------------------------------------------------
!    if the fuliou lw emissivity was selected, call cloud_lwpar to 
!    compute multi-band emissivities based on fu parameterizations for
!    cloud drop, cloud ice, snow and rain. 
!---------------------------------------------------------------------
      if (trim(lwem_form) == 'fuliou') then
      
         
        
        call cloud_lwpar (nonly, nbmax, 1, size_drop, size_ice,   &
                          Cloud_microphysics%size_rain,              &
                          conc_drop, conc_ice, &
                          Cloud_microphysics%conc_rain, &
                          Cloud_microphysics%conc_snow, do_dge_lw,   &
                           dge_column, isccp_call, &
                          tmpabscoeff)
        abscoeff(:,:,:,nnn)=tmpabscoeff(:,:,:,ilwband)                  
!---------------------------------------------------------------------
!    if the ebert-curry emissivity was selected, call cloud_lwem_oneband
!    to compute a single value for the lw emissivity (including effects
!    of drops and ice) based on the ebert and curry parameterization.
!---------------------------------------------------------------------
      else if (trim(lwem_form) == 'ebertcurry') then
        call cloud_lwem_oneband (Cloud_microphysics%conc_drop,   &
                                 Cloud_microphysics%conc_ice,    &
                                 Cloud_microphysics%size_drop,    &
                                 Cloud_microphysics%size_ice,      &
                                 tmpabscoeff(:,:,:,1))
                                 
        abscoeff(:,:,:,nnn)=tmpabscoeff(:,:,:,1)                         
      endif


  enddo        !loop over profiles


!--------------------------------------------------------------------



end subroutine isccp_microphys_lw_driver  



!####################################################################
! <SUBROUTINE NAME="lwemiss_calc">
!  <OVERVIEW>
!   Subroutine to compute infrared emissivity from the absorption
!   coefficient
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute infrared emissivity from the absorption
!   coefficient
!  </DESCRIPTION>
!  <TEMPLATE>
!   call lwemiss_calc(     deltaz, abscoeff, cldemiss)
!  </TEMPLATE>
!  <IN NAME="deltaz" TYPE="real">
!   Pressure layer thickness
!  </IN>
!  <IN NAME="abscoeff" TYPE="real">
!   Absorption coefficient
!  </IN>
!  <OUT NAME="cldemiss" TYPE="real">
!   Emissivity calculated from absorption coefficient
!  </OUT>
! </SUBROUTINE>
!
subroutine lwemiss_calc (deltaz, abscoeff, cldemiss)

!---------------------------------------------------------------------
!    lwemiss_calc computes the infrared emissivity from the absorption 
!    coefficient.
!---------------------------------------------------------------------
 
real, dimension(:,:,:),   intent(in)   :: deltaz  
real, dimension(:,:,:,:,:), intent(in)   :: abscoeff
real, dimension(:,:,:,:,:), intent(out)  :: cldemiss

!----------------------------------------------------------------------
!   intent(in) variables:
!
!      deltaz    depth of the model layer [ meters ]
!      abscoeff  lw absorption coefficient for each of the nlwcldb
!                bands [ km**(-1) ]
!                                                                   
!   intent(out) variables:                                     
!                                                                   
!      cldemiss  the infrared cloud emissivity for each of the nlwcldb
!                bands [ dimensionless ]
!                                                                   
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    local variables:

      integer           :: n, np     ! do-loop index

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!----------------------------------------------------------------------
!    define the cloud emissivity. over a single frequency band 
!    (see goody and yung, eq. 6.72), the emissivity in a layer is 
!    defined as (1 - T(f))    where T(f) is the flux transmissivity, 
!    which may be computed as exp(-(1.66)*(abs. coeff)*
!    (layer thickness)) where the factor 1.66 is the diffusivity factor
!    (diffac). 1.0E-3 is conversion factor from (m) to (km), needed 
!    because abscoeff is in [ km**(-1) ] and deltaz is in [ m ].
!----------------------------------------------------------------------
      do np =1, size(cldemiss,5)
      do n=1,Cldrad_control%nlwcldb
        cldemiss(:,:,:,n,np)  = 1.0E+00 -                           &
                 exp(-diffac*abscoeff(:,:,:,n,np)*deltaz(:,:,:)*1.0E-03)
      end do
      end do
 
!---------------------------------------------------------------------


end subroutine lwemiss_calc



!#################################################################
! <SUBROUTINE NAME="comb_cldprops_calc">
!  <OVERVIEW>
!   Subroutine to define the total-cloud radiative
!    properties
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to define the total-cloud radiative
!    properties to be seen by the radiation package, obtained by the 
!    appropriate combination of the large-scale, donner mesoscale and 
!    cell-scale and uw shallow clouds present in a grid box.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call comb_cldprops_calc ( is, js, Rad_time, deltaz,     &
!                               cldext, cldsct, cldasymm, abscoeff, &
!                               Lsc_microphys, Cell_microphys,    &
!                               Meso_microphys, Shallow_microphys, &
!                               Lscrad_props,    &
!                               Cellrad_props, Mesorad_props,  &
!                               Shallowrad_props)
!  </TEMPLATE>
!  <INOUT NAME="cldext" TYPE="real">
!   parameterization band values of the cloud      
!                      extinction coefficient [ km**(-1) ]  
!  </INOUT>
!  <INOUT NAME="cldsct" TYPE="real">
!   parameterization band values of the cloud      
!                      scattering coefficient [ km**(-1) ] 
!  </INOUT>
!  <INOUT NAME="cldasymm" TYPE="real">
!   parameterization band values of the asymmetry  
!                      factor [ dimensionless ]
!  </INOUT>
!  <INOUT NAME="abscoeff" TYPE="real">
!   combined absorption coefficient for clouds in 
!                      each of the longwave frequency bands [ km**(-1) ]
!  </INOUT>
!  <IN NAME="Lsc_microphys" TYPE="microphysics_type">
!   microphysical specification for large-scale 
!                      clouds
!  </IN>
!  <IN NAME="Cell_microphys" TYPE="microphysics_type">
!   microphysical specification for convective cell 
!                      clouds associated with donner convection
!  </IN>
!  <IN NAME="Meso_microphys" TYPE="microphysics_type">
!   microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!  </IN>
!  <IN NAME="Shallow_microphys" TYPE="microphysics_type">
!   microphysical specification for 
!                      clouds assciated with uw shallow convection
!  </IN>
!  <IN NAME="Lscrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the large-scale 
!                      clouds
!  </IN>
!  <IN NAME="Cellrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the convective cell
!                      clouds associated with donner convection
!  </IN>
!  <IN NAME="Mesorad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the meso-scale 
!                      clouds associated with donner convection
!  </IN>
!  <IN NAME="Shallowrad_props" TYPE="microrad_properties_type">
!   cloud radiative properties for the  
!                      clouds associated with uw shallow convection
!  </IN>
! </SUBROUTINE>
! 
subroutine comb_cldprops_calc ( is, js, Rad_time, Time_next, deltaz,  &
                               stoch_cloud_type, &
                               cldext, cldsct, cldasymm, abscoeff, &
                               Lsc_microphys, Cell_microphys,    &
                               Meso_microphys, &
                               Shallow_microphys, &
                               Lscrad_props, Cellrad_props,  &
                               Mesorad_props, Shallowrad_props)

!---------------------------------------------------------------------
!    subroutine comb_cldprops_calc defines the total-cloud radiative
!    properties to be seen by the radiation package, obtained by the 
!    appropriate combination of the large-scale, donner mesoscale and 
!    cell-scale, and uw shallow clouds present in a grid box.
!---------------------------------------------------------------------

integer,                intent(in)  :: is, js
type(time_type),        intent(in)  :: Rad_time, Time_next
real, dimension(:,:,:), intent(in)  :: deltaz
integer, dimension(:,:,:,:), intent(in)  :: stoch_cloud_type
real, dimension(:,:,:,:,:),       intent(inout)       ::  cldext,     &
                                                        cldsct, &
                                                        cldasymm
real, dimension(:,:,:,:,:),       intent(inout)       ::  abscoeff
type(microphysics_type),        intent(in), optional :: Lsc_microphys, &
                                                        Cell_microphys,&
                                                        Meso_microphys,&
                                                    Shallow_microphys
type(microrad_properties_type), intent(in), optional :: Lscrad_props, &
                                                        Cellrad_props, &
                                                        Mesorad_props, &
                                                    Shallowrad_props

!--------------------------------------------------------------------
!   intent(inout) variables:
!
!       cldext         parameterization band values of the cloud      
!                      extinction coefficient [ km**(-1) ]   
!       cldsct         parameterization band values of the cloud      
!                      scattering coefficient [ km**(-1) ] 
!       cldasymm       parameterization band values of the asymmetry  
!                      factor [ dimensionless ]
!       abscoeff       combined absorption coefficient for clouds in 
!                      each of the longwave frequency bands [ km**(-1) ]
!
!   intent(in), optional variables:
!
!       Lsc_microphys  microphysical specification for large-scale 
!                      clouds
!                      [ microphysics_type ]
!       Meso_microphys microphysical specification for meso-scale 
!                      clouds assciated with donner convection
!                      [ microphysics_type ]
!       Cell_microphys microphysical specification for convective cell
!                      clouds associated with donner convection
!                      [ microphysics_type ]
!       Shallow_microphys 
!                      microphysical specification for 
!                      clouds associated with uw shallow convection
!                      [ microphysics_type ]
!       Lscrad_props   cloud radiative properties for the large-scale 
!                      clouds   
!                      [ microrad_properties_type ]
!       Mesorad_props  cloud radiative properties for meso-scale 
!                      clouds associated with donner convection   
!                      [ microrad_properties_type ]
!       Cellrad_props  cloud radiative properties for convective cell
!                      clouds associated with donner convection  
!                      [ microrad_properties_type ]
!       Shallowrad_props  cloud radiative properties for 
!                      clouds associated with uw shallow convection  
!                      [ microrad_properties_type ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
 
      real, dimension (size(cldext,1), size(cldext,2),              &
                                    size(cldext,3))    :: cldsum
      real :: cltau,cldextdu
      integer :: i, j, k, n
     
!-----------------------------------------------------------------------
!    variables for folding Donner cloud properties into stochastic 
!    cloud arrays
!------------------------------------------------------------------
      integer :: nn
  
!------------------------------------------------------------------
!    diagnostics
!------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!        cldsum         total cloud amount in grid box [ dimensionless ]
!        cltau
!        cldextu
!        i,j,k,n        do-loop indices
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!    make sure that appropriate combinations of optional arguments are
!    present.
!---------------------------------------------------------------------
      if (present(Lscrad_props) .or.   &
          present(Lsc_microphys))  then     
        if (.not. present(Lscrad_props) .or.   &
            .not. present(Lsc_microphys))  then     
          call error_mesg ('microphys_rad_mod', &
              ' both Lscrad_props and Lsc_microphys must be present '//&
               'when one is', FATAL)
        endif
      endif
      if (present (Cellrad_props) .or. present (Cell_microphys) .or. &
          present (Mesorad_props) .or. present (Meso_microphys)) then
        if ( .not. present (Cellrad_props) .or.     &
             .not. present (Cell_microphys) .or. &
             .not. present (Mesorad_props) .or.   &
             .not. present (Meso_microphys)) then
          call error_mesg ('microphys_rad_mod', &
            ' either all or none of the cell-scale and meso-scale '//&
              'cloud arguments must be present.', FATAL)
        endif
      endif
      if (present(Shallowrad_props) .or.   &
          present(Shallow_microphys))  then
       if (.not. present(Shallowrad_props) .or.   &
           .not. present(Shallow_microphys))  then
         call error_mesg ('microphys_rad_mod', &
               ' both Shallowrad_props and Shallow_microphys   &
               &must be present when one is', FATAL)
       endif
     endif

!---------------------------------------------------------------------
!    define appropriately-weighted total-cloud radiative properties
!    when large-scale, donner meso-scale and cell-scale, and uw shallow
!    clouds may be present.
!----------------------------------------------------------------------
      if (present(Lscrad_props) .and. present(Cellrad_props) .and. &
          present(Shallowrad_props)) then

!---------------------------------------------------------------------
!    define total cloud fraction.
!---------------------------------------------------------------------
        if (.not. Cldrad_control%do_stochastic_clouds) then
          cldsum = Lsc_microphys%cldamt + Cell_microphys%cldamt +   &
                     Meso_microphys%cldamt + Shallow_microphys%cldamt

!---------------------------------------------------------------------
!     define the cloud scattering, cloud extinction and cloud asymmetry
!     factor in each of the spectral bands. if cloud is not present, 
!     values remain at the non-cloudy initialized values.
!---------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu        = (Lsc_microphys%cldamt(i,j,k)*  &
                                     Lscrad_props%cldext(i,j,k,n) + &
                                     Cell_microphys%cldamt(i,j,k)*   &
                                     Cellrad_props%cldext(i,j,k,n) +  &
                                     Meso_microphys%cldamt(i,j,k)*   &
                                     Mesorad_props%cldext(i,j,k,n) + &
                                   Shallow_microphys%cldamt(i,j,k)* &
                                   Shallowrad_props%cldext(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldext(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                   cltau=cltau+(Shallow_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                exp(-Shallowrad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldext(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
                  if (cldext(i,j,k,n,1) .gt. cldextdu)   &
                               cldext(i,j,k,n,1)=cldextdu

                  cldextdu        = (Lsc_microphys%cldamt(i,j,k)*   &
                                     Lscrad_props%cldsct(i,j,k,n) +   &
                                     Cell_microphys%cldamt(i,j,k)*  &
                                     Cellrad_props%cldsct(i,j,k,n) +  &
                                     Meso_microphys%cldamt(i,j,k)*  &
                                     Mesorad_props%cldsct(i,j,k,n) + &
                                   Shallow_microphys%cldamt(i,j,k)*  &
                              Shallowrad_props%cldsct(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldsct(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                   cltau=cltau+(Shallow_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                exp(-Shallowrad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                 cldsct(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldsct(i,j,k,n,1) .gt. cldextdu) cldsct(i,j,k,n,1)=cldextdu

                  cldasymm(i,j,k,n,1) =        &
                          (Lsc_microphys%cldamt(i,j,k)*  &
                           Lscrad_props%cldsct(i,j,k,n)* &
                           Lscrad_props%cldasymm(i,j,k,n) +&
                           Cell_microphys%cldamt(i,j,k)*  &
                           Cellrad_props%cldsct(i,j,k,n)* &
                           Cellrad_props%cldasymm(i,j,k,n) + &
                           Meso_microphys%cldamt(i,j,k)*   &
                           Mesorad_props%cldsct(i,j,k,n)*  &
                           Mesorad_props%cldasymm(i,j,k,n) + &
                        Shallow_microphys%cldamt(i,j,k)*   &
                        Shallowrad_props%cldsct(i,j,k,n)*  &
                       Shallowrad_props%cldasymm(i,j,k,n) ) /&
                          (Lsc_microphys%cldamt(i,j,k)*  &
                           Lscrad_props%cldsct(i,j,k,n) +        &
                           Cell_microphys%cldamt(i,j,k)*    &
                           Cellrad_props%cldsct(i,j,k,n) +          &
                           Meso_microphys%cldamt(i,j,k)*    &
                           Mesorad_props%cldsct(i,j,k,n) + &
                        Shallow_microphys%cldamt(i,j,k)*    &
                        Shallowrad_props%cldsct(i,j,k,n) )
                endif
              end do
            end do
          end do
        end do

!------------------------------------------------------------
!    define the total-cloud lw emissivity when large-scale, meso-scale
!    and cell-scale clouds may be present.
!---------------------------------------------------------------------
        do n=1,Cldrad_control%nlwcldb
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu          =                            &
                             (Lsc_microphys%cldamt(i,j,k)*  &
                              Lscrad_props%abscoeff(i,j,k,n) +&
                              Cell_microphys%cldamt(i,j,k)* &
                              Cellrad_props%abscoeff(i,j,k,n) +    &
                              Meso_microphys%cldamt(i,j,k)*   &
                              Mesorad_props%abscoeff(i,j,k,n) +  &
                              Shallow_microphys%cldamt(i,j,k)*   &
                              Shallowrad_props%abscoeff(i,j,k,n)) /   &
                              cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%abscoeff(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                   cltau=cltau+(Shallow_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Shallowrad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 abscoeff(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (abscoeff(i,j,k,n,1) .gt. cldextdu) abscoeff(i,j,k,n,1)=cldextdu
                endif
              end do
            end do
          end do
        end do
      else

!------------------------------------------------------------------------
!    stochastic clouds are being used. we compare the cell and meso-scale
!    cloud amounts to a random number, and replace the large-scale clouds
!    and clear sky in each subcolum with the properties of the cell or 
!    meso-scale clouds when the number is less than the cloud fraction. 
!    we use the maximum overlap assumption. we treat the random number 
!    as the location with the PDF of total water. cells are at the top 
!    of the PDF; then meso-scale anvils, then large-scale clouds and 
!    clear sky. 
!------------------------------------------------------------
      
!----------------------------------------------------------------------
!    get the random numbers to do both sw and lw at oncer.
!----------------------------------------------------------------------
!       nSubCols = size(Lsc_microphys%stoch_cldamt, 4)
      
!----------------------------------------------------------------------
!    shortwave cloud properties, band by band
!----------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3) ! Levels
            do j=1,size(cldext,2) ! Lons
              do i=1,size(cldext,1) ! Lats
                if (stoch_cloud_type(i,j,k,n) == 3) then
!----------------------------------------------------------------------
!    it's a cell.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Cellrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Cellrad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n, 1) = Cellrad_props%cldasymm(i,j,k,n)
                else if (stoch_cloud_type(i,j,k,n) == 2) then
                 
!----------------------------------------------------------------------
!    it's a meso-scale.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Mesorad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Mesorad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n,1) = Mesorad_props%cldasymm(i,j,k,n)
                else if (stoch_cloud_type(i,j,k,n) == 4) then
                 
!----------------------------------------------------------------------
!    it's a uw shallow cloud.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Shallowrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Shallowrad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n,1) = Shallowrad_props%cldasymm(i,j,k,n)
                else if (stoch_cloud_type(i,j,k,n) == 1) then
                 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Lscrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Lscrad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n,1) = Lscrad_props%cldasymm(i,j,k,n)
                else
                  cldext(i,j,k,n,1) = 0. 
                  cldsct(i,j,k,n,1) = 0. 
                  cldasymm(i,j,k,n,1) = 1. 
                endif
              end do 
            end do 
          end do 
        end do 

!----------------------------------------------------------------------
!    longwave cloud properties, band by band
!----------------------------------------------------------------------
      do n=1,Cldrad_control%nlwcldb
        nn = Solar_spect%nbands + n
        do k=1,size(cldext,3) ! Levels
          do j=1,size(cldext,2) ! Lons
            do i=1,size(cldext,1) ! Lats
              if (stoch_cloud_type(i,j,k,nn) == 3) then
                 
!----------------------------------------------------------------------
!    it's a cell.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Cellrad_props%abscoeff(i,j,k,n)
              else if (stoch_cloud_type(i,j,k,nn) == 2) then
                 
!----------------------------------------------------------------------
!    it's a meso-scale.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Mesorad_props%abscoeff(i,j,k,n)
              else if (stoch_cloud_type(i,j,k,nn) == 4) then
                 
!----------------------------------------------------------------------
!    it's a uw shallow.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Shallowrad_props%abscoeff(i,j,k,n)
              else if (stoch_cloud_type(i,j,k,nn) == 1) then
                 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Lscrad_props%abscoeff(i,j,k,n)
              else
                abscoeff(i,j,k,n,1) = 0. 
              endif
            end do 
          end do 
        end do 
      end do 
      
      

     endif  ! (do_stochastic)

!---------------------------------------------------------------------
!    define appropriately-weighted total-cloud radiative properties
!    when large-scale, meso-scale and cell-scale clouds may be present.
!----------------------------------------------------------------------
      else if (present(Lscrad_props) .and. present(Cellrad_props)) then

!---------------------------------------------------------------------
!    define total cloud fraction.
!---------------------------------------------------------------------
        if (.not. Cldrad_control%do_stochastic_clouds) then
          cldsum = Lsc_microphys%cldamt + Cell_microphys%cldamt +   &
                     Meso_microphys%cldamt

!---------------------------------------------------------------------
!     define the cloud scattering, cloud extinction and cloud asymmetry
!     factor in each of the spectral bands. if cloud is not present, 
!     values remain at the non-cloudy initialized values.
!---------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu        = (Lsc_microphys%cldamt(i,j,k)*  &
                                     Lscrad_props%cldext(i,j,k,n) + &
                                     Cell_microphys%cldamt(i,j,k)*   &
                                     Cellrad_props%cldext(i,j,k,n) +  &
                                     Meso_microphys%cldamt(i,j,k)*   &
                                     Mesorad_props%cldext(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldext(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldext(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
                  if (cldext(i,j,k,n,1) .gt. cldextdu)   &
                               cldext(i,j,k,n,1)=cldextdu

                  cldextdu        = (Lsc_microphys%cldamt(i,j,k)*   &
                                     Lscrad_props%cldsct(i,j,k,n) +   &
                                     Cell_microphys%cldamt(i,j,k)*  &
                                     Cellrad_props%cldsct(i,j,k,n) +  &
                                     Meso_microphys%cldamt(i,j,k)*  &
                                     Mesorad_props%cldsct(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldsct(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldsct(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldsct(i,j,k,n,1) .gt. cldextdu) cldsct(i,j,k,n,1)=cldextdu

                  cldasymm(i,j,k,n,1) =        &
                          (Lsc_microphys%cldamt(i,j,k)*  &
                           Lscrad_props%cldsct(i,j,k,n)* &
                           Lscrad_props%cldasymm(i,j,k,n) +&
                           Cell_microphys%cldamt(i,j,k)*  &
                           Cellrad_props%cldsct(i,j,k,n)* &
                           Cellrad_props%cldasymm(i,j,k,n) + &
                           Meso_microphys%cldamt(i,j,k)*   &
                           Mesorad_props%cldsct(i,j,k,n)*  &
                           Mesorad_props%cldasymm(i,j,k,n)) /&
                          (Lsc_microphys%cldamt(i,j,k)*  &
                           Lscrad_props%cldsct(i,j,k,n) +        &
                           Cell_microphys%cldamt(i,j,k)*    &
                           Cellrad_props%cldsct(i,j,k,n) +          &
                           Meso_microphys%cldamt(i,j,k)*    &
                           Mesorad_props%cldsct(i,j,k,n) )
                endif
              end do
            end do
          end do
        end do

!------------------------------------------------------------
!    define the total-cloud lw emissivity when large-scale, meso-scale
!    and cell-scale clouds may be present.
!---------------------------------------------------------------------
        do n=1,Cldrad_control%nlwcldb
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu          =                            &
                             (Lsc_microphys%cldamt(i,j,k)*  &
                              Lscrad_props%abscoeff(i,j,k,n) +&
                              Cell_microphys%cldamt(i,j,k)* &
                              Cellrad_props%abscoeff(i,j,k,n) +    &
                              Meso_microphys%cldamt(i,j,k)*   &
                              Mesorad_props%abscoeff(i,j,k,n)) /   &
                              cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%abscoeff(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 abscoeff(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (abscoeff(i,j,k,n,1) .gt. cldextdu) abscoeff(i,j,k,n,1)=cldextdu
                endif
              end do
            end do
          end do
        end do
      else

        if (do_orig_donner_stoch) then

!---------------------------------------------------------------------
!     define the cloud scattering, cloud extinction and cloud asymmetry
!     factor in each of the spectral bands. if cloud is not present,
!     values remain at the non-cloudy initialized values.
!---------------------------------------------------------------------
       do n=1,Solar_spect%nbands
         cldsum = Lsc_microphys%sw_stoch_cldamt(:,:,:,n) +   &
                  Cell_microphys%cldamt + Meso_microphys%cldamt
         do k=1,size(cldext,3)
           do j=1,size(cldext,2)
             do i=1,size(cldext,1)
               if (cldsum(i,j,k) > 0.0) then
                 cldextdu        = (  &
                              Lsc_microphys%sw_stoch_cldamt(i,j,k,n)*  &
                                  Lscrad_props%cldext(i,j,k,n) +   &
                                     Cell_microphys%cldamt(i,j,k)*   &
                                      Cellrad_props%cldext(i,j,k,n) +  &
                                      Meso_microphys%cldamt(i,j,k)*   &
                                      Mesorad_props%cldext(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                            exp(-Cellrad_props%cldext(i,j,k,n)*     &
                           deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                          cldsum(i,j,k))* &
                    exp(-Mesorad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                               1000.)
                 cltau=cltau+(Lsc_microphys%sw_stoch_cldamt(i,j,k,n)/  &
                            cldsum(i,j,k))* &
                     exp(-Lscrad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldext(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
                 if (cldext(i,j,k,n,1) .gt. cldextdu)   &
                               cldext(i,j,k,n,1)=cldextdu

          cldextdu        = (Lsc_microphys%sw_stoch_cldamt(i,j,k,n)*   &
                                    Lscrad_props%cldsct(i,j,k,n) +   &
                                     Cell_microphys%cldamt(i,j,k)*  &
                                      Cellrad_props%cldsct(i,j,k,n) +  &
                                      Meso_microphys%cldamt(i,j,k)*  &
                                    Mesorad_props%cldsct(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                        exp(-Cellrad_props%cldsct(i,j,k,n)*     &
                           deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                        cldsum(i,j,k))* &
                  exp(-Mesorad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                             1000.)
               cltau=cltau+(Lsc_microphys%sw_stoch_cldamt(i,j,k,n)/  &
                          cldsum(i,j,k))* &
                   exp(-Lscrad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                          1000.)
                cldsct(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldsct(i,j,k,n,1) .gt. cldextdu) cldsct(i,j,k,n,1)=cldextdu

                 cldasymm(i,j,k,n,1) =        &
                          (Lsc_microphys%sw_stoch_cldamt(i,j,k,n)*  &
                           Lscrad_props%cldsct(i,j,k,n)* &
                          Lscrad_props%cldasymm(i,j,k,n) +&
                           Cell_microphys%cldamt(i,j,k)*  &
                          Cellrad_props%cldsct(i,j,k,n)* &
                        Cellrad_props%cldasymm(i,j,k,n) + &
                           Meso_microphys%cldamt(i,j,k)*   &
                          Mesorad_props%cldsct(i,j,k,n)*  &
                                Mesorad_props%cldasymm(i,j,k,n)) /&
                       (Lsc_microphys%sw_stoch_cldamt(i,j,k,n)*  &
                            Lscrad_props%cldsct(i,j,k,n) +        &
                           Cell_microphys%cldamt(i,j,k)*    &
                           Cellrad_props%cldsct(i,j,k,n) +          &
                           Meso_microphys%cldamt(i,j,k)*    &
                            Mesorad_props%cldsct(i,j,k,n) )
                endif
             end do
            end do
          end do
        end do

!---------------------------------------------------------------------
!    define the total-cloud lw emissivity when large-scale, meso-scale
!    and cell-scale clouds may be present.
!---------------------------------------------------------------------
       do n=1,Cldrad_control%nlwcldb
         cldsum = Lsc_microphys%lw_stoch_cldamt(:,:,:,n) +   &
                  Cell_microphys%cldamt + Meso_microphys%cldamt
         do k=1,size(cldext,3)
           do j=1,size(cldext,2)
             do i=1,size(cldext,1)
               if (cldsum(i,j,k) > 0.0) then
                 cldextdu          =                            &
                      (Lsc_microphys%lw_stoch_cldamt(i,j,k,n)*  &
                               Lscrad_props%abscoeff(i,j,k,n) +&
                               Cell_microphys%cldamt(i,j,k)* &
                              Cellrad_props%abscoeff(i,j,k,n) +    &
                              Meso_microphys%cldamt(i,j,k)*   &
                             Mesorad_props%abscoeff(i,j,k,n)) /   &
                               cldsum(i,j,k)
                 cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                   exp(-Cellrad_props%abscoeff(i,j,k,n)*             &
                       deltaz(i,j,k)/1000.)
                cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                          cldsum(i,j,k))* &
         exp(-Mesorad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/          &
                           1000.)
      cltau=cltau+(Lsc_microphys%lw_stoch_cldamt(i,j,k,n)/  &
                           cldsum(i,j,k))* &
           exp(-Lscrad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/          &
                          1000.)
              abscoeff(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
       if (abscoeff(i,j,k,n,1) .gt. cldextdu) abscoeff(i,j,k,n,1)=cldextdu
               endif
          end do
           end do
         end do
       end do 
       
        else  ! (using new donner-stochastic connection)
!------------------------------------------------------------------------
!    stochastic clouds are being used. we compare the cell and meso-scale
!    cloud amounts to a random number, and replace the large-scale clouds
!    and clear sky in each subcolum with the properties of the cell or 
!    meso-scale clouds when the number is less than the cloud fraction. 
!    we use the maximum overlap assumption. we treat the random number 
!    as the location with the PDF of total water. cells are at the top 
!    of the PDF; then meso-scale anvils, then large-scale clouds and 
!    clear sky. 
!------------------------------------------------------------
      
!----------------------------------------------------------------------
!    get the random numbers to do both sw and lw at oncer.
!----------------------------------------------------------------------
!       nSubCols = size(Lsc_microphys%stoch_cldamt, 4)

!----------------------------------------------------------------------
!    shortwave cloud properties, band by band
!----------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3) ! Levels
            do j=1,size(cldext,2) ! Lons
              do i=1,size(cldext,1) ! Lats
                if ( stoch_cloud_type(i,j,k,n) == 3) then 
!----------------------------------------------------------------------
!    it's a cell.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Cellrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Cellrad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n, 1) = Cellrad_props%cldasymm(i,j,k,n)
                else if ( stoch_cloud_type(i,j,k,n) == 2) then 
                 
!----------------------------------------------------------------------
!    it's a meso-scale.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Mesorad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Mesorad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n,1) = Mesorad_props%cldasymm(i,j,k,n)
                else if ( stoch_cloud_type(i,j,k,n) == 1) then 
                 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Lscrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Lscrad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n,1) = Lscrad_props%cldasymm(i,j,k,n)
                else
                  cldext(i,j,k,n,1) = 0. 
                  cldsct(i,j,k,n,1) = 0. 
                  cldasymm(i,j,k,n,1) = 1. 
                endif
              end do 
            end do 
          end do 
        end do 

!----------------------------------------------------------------------
!    longwave cloud properties, band by band
!----------------------------------------------------------------------
      do n=1,Cldrad_control%nlwcldb
        nn = Solar_spect%nbands + n
        do k=1,size(cldext,3) ! Levels
          do j=1,size(cldext,2) ! Lons
            do i=1,size(cldext,1) ! Lats
                if ( stoch_cloud_type(i,j,k,nn) == 3) then 
                 
!----------------------------------------------------------------------
!    it's a cell.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Cellrad_props%abscoeff(i,j,k,n)
                else if ( stoch_cloud_type(i,j,k,nn) == 2) then 
                 
!----------------------------------------------------------------------
!    it's a meso-scale.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Mesorad_props%abscoeff(i,j,k,n)
                else if ( stoch_cloud_type(i,j,k,nn) == 1) then 
                 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Lscrad_props%abscoeff(i,j,k,n)
              else
                abscoeff(i,j,k,n,1) = 0. 
              endif
            end do 
          end do 
        end do 
      end do 
      

      endif ! (do_orig_donner_stoch)
     endif  ! (do_stochastic)

!---------------------------------------------------------------------
!    define appropriately-weighted total-cloud radiative properties
!    when large-scale, and uw shallow clouds may be present.
!----------------------------------------------------------------------
     else if (present(Lscrad_props) .and. present(Shallowrad_props)) then

!---------------------------------------------------------------------
!    define total cloud fraction.
!---------------------------------------------------------------------
        if (.not. Cldrad_control%do_stochastic_clouds) then
          cldsum = Lsc_microphys%cldamt + Shallow_microphys%cldamt 

!---------------------------------------------------------------------
!     define the cloud scattering, cloud extinction and cloud asymmetry
!     factor in each of the spectral bands. if cloud is not present, 
!     values remain at the non-cloudy initialized values.
!---------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu        = (Lsc_microphys%cldamt(i,j,k)*  &
                                     Lscrad_props%cldext(i,j,k,n) + &
                                   Shallow_microphys%cldamt(i,j,k)*   &
                                   Shallowrad_props%cldext(i,j,k,n) )/ &
                                     cldsum(i,j,k)
                cltau=(Shallow_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                           exp(-Shallowrad_props%cldext(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldext(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
                  if (cldext(i,j,k,n,1) .gt. cldextdu)   &
                               cldext(i,j,k,n,1)=cldextdu

                  cldextdu        = (Lsc_microphys%cldamt(i,j,k)*   &
                                     Lscrad_props%cldsct(i,j,k,n) +   &
                                  Shallow_microphys%cldamt(i,j,k)*  &
                                  Shallowrad_props%cldsct(i,j,k,n)) / &
                                     cldsum(i,j,k)
                cltau=(Shallow_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                            exp(-Shallowrad_props%cldsct(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldsct(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldsct(i,j,k,n,1) .gt. cldextdu) cldsct(i,j,k,n,1)=cldextdu

                  cldasymm(i,j,k,n,1) =        &
                          (Lsc_microphys%cldamt(i,j,k)*  &
                           Lscrad_props%cldsct(i,j,k,n)* &
                           Lscrad_props%cldasymm(i,j,k,n) +&
                        Shallow_microphys%cldamt(i,j,k)*   &
                        Shallowrad_props%cldsct(i,j,k,n)*  &
                        Shallowrad_props%cldasymm(i,j,k,n)) /&
                          (Lsc_microphys%cldamt(i,j,k)*  &
                           Lscrad_props%cldsct(i,j,k,n) +        &
                        Shallow_microphys%cldamt(i,j,k)*    &
                        Shallowrad_props%cldsct(i,j,k,n) )
                endif
              end do
            end do
          end do
        end do

!------------------------------------------------------------
!    define the total-cloud lw emissivity when large-scale, meso-scale
!    and cell-scale clouds may be present.
!---------------------------------------------------------------------
        do n=1,Cldrad_control%nlwcldb
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu          =                            &
                             (Lsc_microphys%cldamt(i,j,k)*  &
                              Lscrad_props%abscoeff(i,j,k,n) +&
                        Shallow_microphys%cldamt(i,j,k)*   &
                           Shallowrad_props%abscoeff(i,j,k,n)) /   &
                              cldsum(i,j,k)
                cltau=(Shallow_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                         exp(-Shallowrad_props%abscoeff(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Lsc_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Lscrad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 abscoeff(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (abscoeff(i,j,k,n,1) .gt. cldextdu) abscoeff(i,j,k,n,1)=cldextdu
                endif
              end do
            end do
          end do
        end do
      else

!------------------------------------------------------------------------
!    stochastic clouds are being used. we compare the cell and meso-scale
!    cloud amounts to a random number, and replace the large-scale clouds
!    and clear sky in each subcolum with the properties of the cell or 
!    meso-scale clouds when the number is less than the cloud fraction. 
!    we use the maximum overlap assumption. we treat the random number 
!    as the location with the PDF of total water. cells are at the top 
!    of the PDF; then meso-scale anvils, then large-scale clouds and 
!    clear sky. 
!------------------------------------------------------------
      
!----------------------------------------------------------------------
!    get the random numbers to do both sw and lw at oncer.
!----------------------------------------------------------------------
!       nSubCols = size(Lsc_microphys%stoch_cldamt, 4)

!----------------------------------------------------------------------
!    shortwave cloud properties, band by band
!----------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3) ! Levels
            do j=1,size(cldext,2) ! Lons
              do i=1,size(cldext,1) ! Lats
                if ( stoch_cloud_type(i,j,k,n) == 4) then 
!----------------------------------------------------------------------
!    it's a uw shallow
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Shallowrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Shallowrad_props%cldsct(i,j,k,n)
              cldasymm(i,j,k,n, 1) = Shallowrad_props%cldasymm(i,j,k,n)
                else if ( stoch_cloud_type(i,j,k,n) == 1) then 
                 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                  cldext(i,j,k,n,1) = Lscrad_props%cldext(i,j,k,n)
                  cldsct(i,j,k,n,1) = Lscrad_props%cldsct(i,j,k,n)
                  cldasymm(i,j,k,n,1) = Lscrad_props%cldasymm(i,j,k,n)
                else
                  cldext(i,j,k,n,1) = 0. 
                  cldsct(i,j,k,n,1) = 0. 
                  cldasymm(i,j,k,n,1) = 1. 
                endif
              end do 
            end do 
          end do 
        end do 

!----------------------------------------------------------------------
!    longwave cloud properties, band by band
!----------------------------------------------------------------------
      do n=1,Cldrad_control%nlwcldb
        nn = Solar_spect%nbands + n
        do k=1,size(cldext,3) ! Levels
          do j=1,size(cldext,2) ! Lons
            do i=1,size(cldext,1) ! Lats
                if ( stoch_cloud_type(i,j,k,nn) == 4) then 
                 
!----------------------------------------------------------------------
!    it's a uw shallow.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Shallowrad_props%abscoeff(i,j,k,n)
                else if ( stoch_cloud_type(i,j,k,nn) == 1) then 
                 
!----------------------------------------------------------------------
!    fill it in with the large-scale cloud values.
!----------------------------------------------------------------------
                abscoeff(i,j,k,n,1) = Lscrad_props%abscoeff(i,j,k,n)
              else
                abscoeff(i,j,k,n,1) = 0. 
              endif
            end do 
          end do 
        end do 
      end do 
      

     endif  ! (do_stochastic)

!---------------------------------------------------------------------
!    define appropriately-weighted total-cloud radiative properties
!    when donner deep convective clouds and uw shallow clouds
!    may be present.
!----------------------------------------------------------------------
     else if (present(Cellrad_props) .and. present(Shallowrad_props)) then

!---------------------------------------------------------------------
!    define total cloud fraction.
!---------------------------------------------------------------------
        cldsum = Shallow_microphys%cldamt + Cell_microphys%cldamt +   &
                     Meso_microphys%cldamt

!---------------------------------------------------------------------
!     define the cloud scattering, cloud extinction and cloud asymmetry
!     factor in each of the spectral bands. if cloud is not present, 
!     values remain at the non-cloudy initialized values.
!---------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu        = (Shallow_microphys%cldamt(i,j,k)*  &
                                   Shallowrad_props%cldext(i,j,k,n) + &
                                     Cell_microphys%cldamt(i,j,k)*   &
                                     Cellrad_props%cldext(i,j,k,n) +  &
                                     Meso_microphys%cldamt(i,j,k)*   &
                                     Mesorad_props%cldext(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldext(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Shallow_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                 exp(-Shallowrad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldext(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
                  if (cldext(i,j,k,n,1) .gt. cldextdu)   &
                               cldext(i,j,k,n,1)=cldextdu

               cldextdu        = (Shallow_microphys%cldamt(i,j,k)*   &
                                  Shallowrad_props%cldsct(i,j,k,n) +   &
                                     Cell_microphys%cldamt(i,j,k)*  &
                                     Cellrad_props%cldsct(i,j,k,n) +  &
                                     Meso_microphys%cldamt(i,j,k)*  &
                                     Mesorad_props%cldsct(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldsct(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Shallow_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Shallowrad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 cldsct(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldsct(i,j,k,n,1) .gt. cldextdu) cldsct(i,j,k,n,1)=cldextdu

                  cldasymm(i,j,k,n,1) =        &
                          (Shallow_microphys%cldamt(i,j,k)*  &
                           Shallowrad_props%cldsct(i,j,k,n)* &
                           Shallowrad_props%cldasymm(i,j,k,n) +&
                           Cell_microphys%cldamt(i,j,k)*  &
                           Cellrad_props%cldsct(i,j,k,n)* &
                           Cellrad_props%cldasymm(i,j,k,n) + &
                           Meso_microphys%cldamt(i,j,k)*   &
                           Mesorad_props%cldsct(i,j,k,n)*  &
                           Mesorad_props%cldasymm(i,j,k,n)) /&
                          (Shallow_microphys%cldamt(i,j,k)*  &
                           Shallowrad_props%cldsct(i,j,k,n) +        &
                           Cell_microphys%cldamt(i,j,k)*    &
                           Cellrad_props%cldsct(i,j,k,n) +          &
                           Meso_microphys%cldamt(i,j,k)*    &
                           Mesorad_props%cldsct(i,j,k,n) )
                endif
              end do
            end do
          end do
        end do

!------------------------------------------------------------
!    define the total-cloud lw emissivity when large-scale, meso-scale
!    and cell-scale clouds may be present.
!---------------------------------------------------------------------
        do n=1,Cldrad_control%nlwcldb
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu          =                            &
                             (Shallow_microphys%cldamt(i,j,k)*  &
                              Shallowrad_props%abscoeff(i,j,k,n) +&
                              Cell_microphys%cldamt(i,j,k)* &
                              Cellrad_props%abscoeff(i,j,k,n) +    &
                              Meso_microphys%cldamt(i,j,k)*   &
                              Mesorad_props%abscoeff(i,j,k,n)) /   &
                              cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%abscoeff(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                   cltau=cltau+(Shallow_microphys%cldamt(i,j,k)/  &
                           cldsum(i,j,k))* &
                    exp(-Shallowrad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                           1000.)
                 abscoeff(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (abscoeff(i,j,k,n,1) .gt. cldextdu) abscoeff(i,j,k,n,1)=cldextdu
                endif
              end do
            end do
          end do
        end do
!--------------------------------------------------------------------
!    define the total-cloud radiative properties when only meso-scale 
!    and cell-scale clouds may be present.
!--------------------------------------------------------------------
      else if (present(Cellrad_props)) then

!---------------------------------------------------------------------
!    define total cloud fraction.
!---------------------------------------------------------------------
        cldsum = Cell_microphys%cldamt + Meso_microphys%cldamt

!---------------------------------------------------------------------
!     define the cloud scattering, cloud extinction and cloud asymmetry
!     factor in each of the spectral bands. if cloud is not present, 
!     values remain at the non-cloudy initialized values.
!---------------------------------------------------------------------
        do n=1,Solar_spect%nbands
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu        = (Cell_microphys%cldamt(i,j,k)* &
                                     Cellrad_props%cldext(i,j,k,n) +   &
                                     Meso_microphys%cldamt(i,j,k)*  &
                                     Mesorad_props%cldext(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldext(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldext(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                 cldext(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldext(i,j,k,n,1) .gt. cldextdu) cldext(i,j,k,n,1)=cldextdu

                  cldextdu        = (Cell_microphys%cldamt(i,j,k)*  &
                                     Cellrad_props%cldsct(i,j,k,n) +   &
                                     Meso_microphys%cldamt(i,j,k)*   &
                                     Mesorad_props%cldsct(i,j,k,n)) / &
                                     cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%cldsct(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%cldsct(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                 cldsct(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (cldsct(i,j,k,n,1) .gt. cldextdu) cldsct(i,j,k,n,1)=cldextdu

                  cldasymm(i,j,k,n,1) =                           &
                          (Cell_microphys%cldamt(i,j,k)* &
                           Cellrad_props%cldsct(i,j,k,n)* &
                           Cellrad_props%cldasymm(i,j,k,n) + &
                           Meso_microphys%cldamt(i,j,k)*   &
                           Mesorad_props%cldsct(i,j,k,n)*  &
                           Mesorad_props%cldasymm(i,j,k,n)) /&
                          (Cell_microphys%cldamt(i,j,k)*  &
                           Cellrad_props%cldsct(i,j,k,n) +     &
                           Meso_microphys%cldamt(i,j,k)*   &
                           Mesorad_props%cldsct(i,j,k,n) )
                endif     
              end do
            end do
          end do
        end do

!---------------------------------------------------------------------
!    define the total-cloud lw emissivity when only meso-scale and
!    cell-scale clouds may be present.
!---------------------------------------------------------------------
        do n=1,Cldrad_control%nlwcldb
          do k=1,size(cldext,3)
            do j=1,size(cldext,2)
              do i=1,size(cldext,1)
                if (cldsum(i,j,k) > 0.0) then
                  cldextdu          =                           &
                       (Cell_microphys%cldamt(i,j,k)*  &
                        Cellrad_props%abscoeff(i,j,k,n) +   &
                        Meso_microphys%cldamt(i,j,k)*   &
                        Mesorad_props%abscoeff(i,j,k,n)) /   &
                        cldsum(i,j,k)
                   cltau=(Cell_microphys%cldamt(i,j,k)/cldsum(i,j,k))* &
                               exp(-Cellrad_props%abscoeff(i,j,k,n)*     &
                          deltaz(i,j,k)/1000.)
                   cltau=cltau+(Meso_microphys%cldamt(i,j,k)/  &
                         cldsum(i,j,k))* &
                   exp(-Mesorad_props%abscoeff(i,j,k,n)*deltaz(i,j,k)/  &
                              1000.)
                 abscoeff(i,j,k,n,1)=-1000.*alog(cltau)/deltaz(i,j,k)
        if (abscoeff(i,j,k,n,1) .gt. cldextdu) abscoeff(i,j,k,n,1)=cldextdu
                endif
              end do
            end do
          end do
        end do
      endif


!---------------------------------------------------------------------



end subroutine comb_cldprops_calc




!#################################################################
! <SUBROUTINE NAME="microphys_rad_end">
!  <OVERVIEW>
!   microphys_rad_end is the destructor for microphys_rad_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   microphys_rad_end is the destructor for microphys_rad_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call microphys_rad_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine microphys_rad_end

!-------------------------------------------------------------------
!    microphys_rad_end is the destructor for microphys_rad_mod.
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg('microphys_rad_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!--------------------------------------------------------------------
!    deallocate module variables.
!--------------------------------------------------------------------
      if (Cldrad_control%do_sw_micro) then
        deallocate ( nivl1liqcld    ,   &
                     nivl1icecld    ,   &
                     nivl1icesolcld ,   &
                     nivl1raincld   ,   &
                     nivl1snowcld   ,   &
                     nivl2liqcld    ,   &
                     nivl2icecld    ,   &
                     nivl2icesolcld ,   &
                     nivl2raincld   ,   & 
                     nivl2snowcld   ,   &
                     solivlicecld   ,   &
                     solivlicesolcld,   &
                     solivlliqcld   ,   &
                     solivlraincld  ,   &
                     solivlsnowcld  )
      endif

!--------------------------------------------------------------------
!    mark the module as no longer being initialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------



end subroutine microphys_rad_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!#################################################################
! <SUBROUTINE NAME="cloudpar">
!  <OVERVIEW>
!   Subroutine to determine cloud single scattering parameters
!  </OVERVIEW>
!  <DESCRIPTION>
!   determine the parameterization band values of the single scattering   
! parameters (extinction coefficient, scattering coefficient and   
! asymmetry factor) for clouds from the size and/or concentration of    
! each constituent (cloud drops, rain drops, ice crystals and snow)     
! present.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cloudpar (   nonly, nbmax, nnn, &
!                     size_drop, size_ice, size_rain, conc_drop,   &
!                     conc_ice, conc_rain, conc_snow, do_dge_sw,   &
!                     cldext, cldsct, cldasymm)
!  </TEMPLATE>
!  <IN NAME="nonly" TYPE="integer">
!   The single band for calculations.  Note that this is used
!   only in the case of a call from cloudrad_diagnostics to 
!   do isccp simulator work.  For all other calls, nonly should
!   be 0 and will have no effect on the calculations below
!  </IN>
!  <IN NAME="nbmax" TYPE="integer">
!   The number of individual bands to do calculations over. Note
!   that for normal GCM calls this will be 1.  For calls using
!   stochastic clouds with or without the isccp simulator this will
!   be equal to the number of shortwave bands
!  </IN>
!  <IN NAME="nnn" TYPE="integer">
!   This integer controls which cloud state to access for radiation
!   calculations.  For normal GCM applications this will be 1. For
!   Full Independent Column Approximation calculations with stochast-
!   ic clouds this will be the profile number being accessed. 
!  </IN>
!  <IN NAME="conc_drop" TYPE="real">
!   total cloud droplet concentration
!  </IN>
!  <IN NAME="conc_ice" TYPE="real">
!   ice crystal concentration
!  </IN>
!  <IN NAME="conc_rain" TYPE="real">
!   rain droplet concetration
!  </IN>
!  <IN NAME="conc_snow" TYPE="real">
!   snow concentration
!  </IN>
!  <IN NAME="size_drop" TYPE="real">
!   cloud droplet size distribution
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   ice crystal size distribution
!  </IN>
!  <IN NAME="size_rain" TYPE="real">
!   rain drop size distribution
!  </IN>
!  <IN NAME="do_dge_sw" TYPE="logical">
!   use sw parameterizations using generalized effective 
!                  size developed by Fu et al (1998) (if true). 
!                  otherwise use parameterizations by Fu et al using 
!                  effective size.
!  </IN>
!  <OUT NAME="cldext" TYPE="real">
!   the parameterization band values of the cloud      
!               extinction coefficient in kilometer**(-1)
!  </OUT>
!  <OUT NAME="cldsct" TYPE="real">
!   the parameterization band values of the cloud      
!               scattering coefficient in kilometer**(-1)
!  </OUT>
!  <OUT NAME="cldasymm" TYPE="real">
!   the parameterization band values of the asymmetry  
!               factor
!  </OUT>
! </SUBROUTINE>
subroutine cloudpar (nonly, nbmax, nnn, size_drop, size_ice, size_rain, & 
                     conc_drop, conc_ice, conc_rain, conc_snow, do_dge_sw, &
                     dge_column, isccp_call, cldext, cldsct, cldasymm)
 
!----------------------------------------------------------------------
!    subroutine cloudpar determines the parameterization band values of
!    the single scattering parameters (extinction coefficient, scatter-
!    ing coefficient and asymmetry factor) for clouds from the size and/
!    or concentration of each constituent (cloud drops, rain drops, ice
!    crystals and snow) present.                          
!----------------------------------------------------------------------

integer,                   intent(in)     ::  nonly, nbmax, nnn
real, dimension (:,:,:),   intent(in)     ::  size_rain, conc_rain,   &
                                              conc_snow
real, dimension (:,:,:,:), intent(in)     ::  size_drop, size_ice,    &
                                              conc_drop, conc_ice
logical, dimension (:,:,:,:), intent(in)     ::  dge_column
logical,                   intent(in)     ::  do_dge_sw
logical,                   intent(in)     ::  isccp_call
real, dimension (:,:,:,:), intent(inout)  ::  cldext, cldsct, cldasymm
 
!-------------------------------------------------------------------
! intent(in) variables:                                            
!                                                                  
!       size_drop  the cloud drop effective diameter [ microns ]    
!       size_ice   the ice crystal effective size  [ microns ]     
!       size_rain  the rain drop effective diameter [ microns ]    
!       conc_drop  the cloud drop liquid water concentration 
!                  [ grams / meter**3 ]                            
!       conc_ice   the ice water concentation 
!                  [ grams / meter**3 ]                            
!       conc_rain  the rain drop water concentration 
!                  [ grams / meter**3 ]                            
!       conc_snow  the snow concentration 
!                  [ grams / meter**3 ]                            
!       do_dge_sw  use sw parameterizations using generalized effective 
!                  size developed by Fu et al (1998) (if true). 
!                  otherwise use parameterizations by Fu et al using 
!                  effective size.
! 
! intent(inout) variables:                                           
!                                                                  
!       cldext     the parameterization band values of the cloud      
!                  extinction coefficient [ kilometer**(-1) ]          
!       cldsct     the parameterization band values of the cloud      
!                  scattering coefficient [ kilometer**(-1) ]         
!       cldasymm   the parameterization band values of the asymmetry  
!                  factor  [ dimensionless ]                    
!----------------------------------------------------------------------
 
!---------------------------------------------------------------------
! local variables:                                                   
!--------------------------------------------------------------------
      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), NLIQCLDIVLS)  ::   &
                    cldextivlliq, cldssalbivlliq, cldasymmivlliq

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), NRAINCLDIVLS)  ::   &
                    cldextivlrain, cldssalbivlrain, cldasymmivlrain

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), NSNOWCLDIVLS)  ::   &
                    cldextivlsnow, cldssalbivlsnow, cldasymmivlsnow

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), NICECLDIVLS)  ::   &
                    cldextivlice, cldssalbivlice, cldasymmivlice

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), NICESOLARCLDIVLS)  ::   &
                    cldextivlice2, cldssalbivlice2, cldasymmivlice2

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), Solar_spect%nbands)  ::    &
                    cldextbandliq, cldssalbbandliq, cldasymmbandliq,&
                    cldextbandice, cldssalbbandice, cldasymmbandice,&
                    cldextbandrain, cldssalbbandrain, cldasymmbandrain,&
                    cldextbandsnow, cldssalbbandsnow, cldasymmbandsnow

      logical, dimension (size(conc_drop,1), size(conc_drop,2), &
                          size(conc_drop,3))  ::   maskl, anymask, &
                                                   maskr, maski, masks,&
                                                   maskif, maskis
      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                          size(conc_drop,3))  ::   tempext, tempext2, &
                                     tempssa, tempssa2, &
                                             tempasy, tempasy2

      integer  :: nb
      integer  :: i,j,k
      real :: sum, sum2, sum3

!----------------------------------------------------------------------
!   local variables:
!
!      cldextivlliq     cloud extinction coefficient over the spectral
!                       intervals relevant to cloud droplets 
!                       [ km**(-1)]
!      cldssalbivlliq   cloud single scattering albedo over the spectral
!                       intervals relevant to cloud droplets 
!                       [ non-dimensional ]
!      cldasymmivlliq   cloud asymmetry factor over the spectral
!                       intervals relevant to cloud droplets 
!                       [ non-dimensional ]
!      cldextivlrain    cloud extinction coefficient over the spectral
!                       intervals relevant to rain drops [ km**(-1)]  
!      cldssalbivlrain  cloud single scattering albedo over the spectral
!                       intervals relevant to rain drops 
!                       [ non-dimensional ]
!      cldasymmivlrain  cloud asymmetry factor over the spectral
!                       intervals relevant to rain drops         
!                       [ non-dimensional ]
!      cldextivlsnow    cloud extinction coefficient over the spectral
!                       intervals relevant to snow flakes  [ km**(-1)] 
!      cldssalbivlsnow  cloud single scattering albedo over the spectral
!                       intervals relevant to snow flakes 
!                       [ non-dimensional ]
!      cldasymmivlsnow  cloud asymmetry factor over the spectral
!                       intervals relevant to snow flakes       
!                       [ non-dimensional ]
!      cldextivlice     cloud extinction coefficient over the spectral
!                       intervals relevant to fu (1996) ice crystals 
!                       [ km**(-1)]
!      cldssalbivlice   cloud single scattering albedo over the spectral
!                       intervals relevant to fu(1996) ice crystals 
!                       [ non-dimensional ]
!      cldasymmivlice   cloud asymmetry factor over the spectral
!                       intervals relevant to fu(1996) ice crystals
!                       [ non-dimensional ]
!      cldextivlice2    cloud extinction coefficient over the spectral
!                       intervals relevant to fu and liou(1993) ice
!                       crystals  [ km**(-1)]
!      cldssalbivlice2  cloud single scattering albedo over the spectral
!                       intervals relevant to fu and liou(1993) ice
!                       crystals  [ non-dimensional ]
!      cldasymmivlice2  cloud asymmetry factor over the spectral
!                       intervals relevant to fu and liou(1993) ice
!                       crystals
!                       [ non-dimensional ]
!      cldextbandliq    cloud extinction coefficient for each spectral
!                       parameterization bands resulting from the 
!                       presence of cloud droplets  [ km**(-1)]  
!      cldssalbbandliq  cloud single scattering albedo for each spectral
!                       parameterization bands resulting from the 
!                       presence of cloud droplets
!                       [ non-dimensional ]
!      cldasymmbandliq  cloud asymmetry factor for each spectral
!                       parameterization bands resulting from the 
!                       presence of cloud droplets [ non-dimensional ]
!      cldextbandice    cloud extinction coefficient for each spectral
!                       parameterization bands resulting from the 
!                       presence of cloud ice  [ km**(-1)]  
!      cldssalbbandice  cloud single scattering albedo for each spectral
!                       parameterization bands resulting from the 
!                       presence of cloud ice 
!                       [ non-dimensional ]
!      cldasymmbandice  cloud asymmetry factor for each spectral
!                       parameterization bands resulting from the 
!                       presence of cloud ice [ non-dimensional ]
!      cldextbandrain   cloud extinction coefficient for each spectral
!                       parameterization bands resulting from the 
!                       presence of rain drops  [ km**(-1)]  
!      cldssalbbandrain cloud single scattering albedo for each spectral
!                       parameterization bands resulting from the 
!                       presence of rain drops  
!                       [ non-dimensional ]
!      cldasymmbandrain cloud asymmetry factor for each spectral
!                       parameterization bands resulting from the 
!                       presence of rain drops [ non-dimensional ]
!      cldextbandsnow   cloud extinction coefficient for each spectral
!                       parameterization bands resulting from the 
!                       presence of snow flakes  [ km**(-1)]  
!                       [ non-dimensional ]
!      cldssalbbandsnow cloud single scattering albedo for each spectral
!                       parameterization bands resulting from the 
!                       presence of snow flakes 
!                       [ non-dimensional ]
!      cldasymmbandsnow cloud asymmetry factor for each spectral
!                       parameterization bands resulting from the 
!                       presence of snow flakes [ non-dimensional ]
!      nb               do-loop index
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!
!  NOTE THE FOLLOWING LOGICAL TO THE LOOPS BELOW
!
!        do nb=1,nbmax
!             if (nbmax==1) then
!                  call slingo(conc_drop(:,:,:,nnn).....)
!             else
!                  call slingo(conc_drop(:,:,:,nb),....)
!             end if
!
!        enddo           
!             
!        Note that nbmax = 1 in the following cases:
!
!                 (a) standard GCM applications which do not use
!                     McICA  
!                 (b) Full Independent Column Approximation 
!                     calculations
!
!        Note that nbmax = Solar_spect%nbands in the following cases
!               
!                 (c) McICA calculations where nb = the cloud 
!                     profile being used
!                 (d) ISCCP simulator calls from cloudrad_diagnostics
!                     where "nonly" will be used
!
!----------------------------------------------------------------------


!----------------------------------------------------------------------
!    call slingo to define the single scattering parameters for cloud 
!    droplets for each of the slingo cloud droplet spectral intervals.
!----------------------------------------------------------------------
      do nb=1,nbmax
        if (nbmax == 1) then
          call slingo (conc_drop(:,:,:,nnn), size_drop(:,:,:,nnn),  &
                       cldextivlliq, cldssalbivlliq, cldasymmivlliq, &
                       maskl)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for cloud
!    droplets that were calculated for each cloud droplet spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
          call thickavg (nivl1liqcld, nivl2liqcld, NLIQCLDIVLS,     &
                         Solar_spect%nbands, cldextivlliq,   &
                         cldssalbivlliq, cldasymmivlliq, solivlliqcld, &
                         Solar_spect%solflxbandref, maskl, &
                         cldextbandliq, &
                         cldssalbbandliq, cldasymmbandliq)

!----------------------------------------------------------------------
!    call savijarvi to define the single scattering parameters for 
!    rain drops for each of the savijarvi rain drop spectral intervals. 
!----------------------------------------------------------------------
          call savijarvi (conc_rain, size_rain, cldextivlrain,   &
                      cldssalbivlrain, cldasymmivlrain,maskr) 

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for rain 
!    drops that were calculated for each rain drop spectral interval 
!    to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
          call thickavg (nivl1raincld, nivl2raincld, NRAINCLDIVLS,  &
                     Solar_spect%nbands, cldextivlrain,    &
                     cldssalbivlrain , cldasymmivlrain,  &
                     solivlraincld, Solar_spect%solflxbandref, maskr,   &
                     cldextbandrain, cldssalbbandrain,  &
                     cldasymmbandrain)
 
!---------------------------------------------------------------------
!    on calls from the isccp simulator with stochastic clouds, call all 
!    parameterizations, since some subcolumns may have cloud types 
!    using that parameterization. calculation control is provided 
!    within the parameterization subroutine.
!---------------------------------------------------------------------
         if (isccp_call) then

!----------------------------------------------------------------------
!    define the single scattering parameters for ice crystals.        
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    call the ice crystal parameterization scheme of fu et al(1998) 
!    using generalized effective size. call subroutine fu to calculate 
!    the single scattering parameters.
!----------------------------------------------------------------------
            call fu (conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn),   &
                     dge_column(:,:,:,nnn), &
                     cldextivlice, cldssalbivlice,  &
                     cldasymmivlice, maski)
 
!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for ice
!    crystals that were calculated for each ice crystal spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
            call thickavg (nivl1icecld, nivl2icecld, NICECLDIVLS,   &
                           Solar_spect%nbands, cldextivlice,     &
                           cldssalbivlice, cldasymmivlice,     &
                           solivlicecld, Solar_spect%solflxbandref,   &
                           maski, &
                           cldextbandice, cldssalbbandice,   &
                           cldasymmbandice)

!----------------------------------------------------------------------
!    call the ice crystal parameterization scheme of fu et al(1993) 
!    using effective size. call subroutine icesolar to calculate
!    the single scattering parameters.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    if the ice crystal parameterization scheme of fu et al(1993) using
!    effective size is to be used, call subroutine icesolar to calculate
!    the single scattering parameters.
!----------------------------------------------------------------------
            call icesolar (conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn), &
                           dge_column(:,:,:,nnn), &
                           cldextivlice2, cldssalbivlice2,   &
                           cldasymmivlice2, maski)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for ice
!    crystals that were calculated for each ice crystal spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
            call thickavg (nivl1icesolcld, nivl2icesolcld,    &
                           NICESOLARCLDIVLS, Solar_spect%nbands, &
                           cldextivlice2, cldssalbivlice2,  &
                           cldasymmivlice2, solivlicesolcld,  &
                           Solar_spect%solflxbandref, maski,  &
                           cldextbandice,  cldssalbbandice,  &
                           cldasymmbandice)

!--------------------------------------------------------------------
!    if this is not an isccp call with activated stochastic clouds, all
!    grid columns will use the same parameterization.
!--------------------------------------------------------------------
         else  !(isccp_call)
           if (do_dge_sw) then

!----------------------------------------------------------------------
!    if the ice crystal parameterization scheme of fu et al(1998) using
!    generalized effective size is to be used, call subroutine fu 
!    to calculate the single scattering parameters.
!----------------------------------------------------------------------
            call fu (conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn),   &
                     dge_column(:,:,:,nnn), &
                     cldextivlice, cldssalbivlice,  &
                     cldasymmivlice, maski)
 
!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for ice
!    crystals that were calculated for each ice crystal spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
            call thickavg (nivl1icecld, nivl2icecld, NICECLDIVLS,   &
                           Solar_spect%nbands, cldextivlice,     &
                           cldssalbivlice, cldasymmivlice,     &
                           solivlicecld, Solar_spect%solflxbandref,   &
                           maski, &
                           cldextbandice, cldssalbbandice,   &
                           cldasymmbandice)

!----------------------------------------------------------------------
!    if the ice crystal parameterization scheme of fu et al(1993) using
!    effective size is to be used, call subroutine icesolar to calculate
!    the single scattering parameters.
!----------------------------------------------------------------------
          else

!----------------------------------------------------------------------
!    if the ice crystal parameterization scheme of fu et al(1993) using
!    effective size is to be used, call subroutine icesolar to calculate
!    the single scattering parameters.
!----------------------------------------------------------------------
            call icesolar (conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn), &
                           dge_column(:,:,:,nnn), &
                           cldextivlice2, cldssalbivlice2,   &
                           cldasymmivlice2, maski)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for ice
!    crystals that were calculated for each ice crystal spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
            call thickavg (nivl1icesolcld, nivl2icesolcld,    &
                           NICESOLARCLDIVLS, Solar_spect%nbands, &
                           cldextivlice2, cldssalbivlice2,  &
                           cldasymmivlice2, solivlicesolcld,  &
                           Solar_spect%solflxbandref, maski,  &
                           cldextbandice,  cldssalbbandice,  &
                           cldasymmbandice)
          endif
        endif !(isccp_call)

!----------------------------------------------------------------------
!    define the single scattering parameters for snow.                
!----------------------------------------------------------------------
          call snowsw (conc_snow, cldextivlsnow, cldssalbivlsnow,    &
                       cldasymmivlsnow, masks)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for each snow flake spectral interval 
!    to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
          call thickavg (nivl1snowcld, nivl2snowcld, NSNOWCLDIVLS,  &
                         Solar_spect%nbands, cldextivlsnow,     &
                         cldssalbivlsnow , cldasymmivlsnow,  &
                         solivlsnowcld, Solar_spect%solflxbandref,  &
                         masks, &
                         cldextbandsnow, cldssalbbandsnow,  &
                         cldasymmbandsnow)
 
        else
          if (nonly.eq.0   .or. nonly.eq.nb ) then
            call slingo (conc_drop(:,:,:,nb), size_drop(:,:,:,nb),  &
                       cldextivlliq, cldssalbivlliq, cldasymmivlliq,  &
                       maskl,  &
                       starting_band = nivl1liqcld(nb), &
                       ending_band = nivl2liqcld(nb))

!----------------------------------------------------------------------
!    call savijarvi to define the single scattering parameters for 
!    rain drops for each of the savijarvi rain drop spectral intervals. 
!----------------------------------------------------------------------
            call savijarvi (conc_rain, size_rain, cldextivlrain,   &
                            cldssalbivlrain, cldasymmivlrain, &
                            maskr,  &
                            starting_band = nivl1raincld(nb), &
                            ending_band = nivl1raincld(nb)) 

!---------------------------------------------------------------------
!    on calls from the isccp simulator with stochastic clouds, call all 
!    parameterizations, since some subcolumns may have cloud types 
!    using that parameterization. calculation control is provided 
!    within the parameterization subroutine.
!---------------------------------------------------------------------
         if (isccp_call) then

!----------------------------------------------------------------------
!    define the single scattering parameters for ice crystals.        
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    call the ice crystal parameterization scheme of fu et al(1998) 
!    using generalized effective size is to be used, call subroutine fu 
!    to calculate the single scattering parameters.
!----------------------------------------------------------------------
              call fu (conc_ice(:,:,:,nb), size_ice(:,:,:,nb),   &
                        dge_column(:,:,:,nb), &
                       cldextivlice, cldssalbivlice,  &
                     cldasymmivlice,   maskif, &
                     starting_band = nivl1icecld(nb), &
                     ending_band = nivl2icecld(nb))

!----------------------------------------------------------------------
!    call the ice crystal parameterization scheme of fu et al(1993) 
!    using effective size is to be used, call subroutine icesolar to 
!    calculate the single scattering parameters.
!----------------------------------------------------------------------
              call icesolar (conc_ice(:,:,:,nb), size_ice(:,:,:,nb), &
                           dge_column(:,:,:,nb), &
                           cldextivlice2,     &
                           cldssalbivlice2, cldasymmivlice2, &
                           maskis, &
                           starting_band = nivl1icesolcld(nb), &
                           ending_band = nivl2icesolcld(nb))

!--------------------------------------------------------------------
!    if this is not an isccp call with activated stochastic clouds, all
!    grid columns will use the same parameterization.
!--------------------------------------------------------------------
        else   ! (isccp_call)
            if (do_dge_sw) then

!----------------------------------------------------------------------
!    if the ice crystal parameterization scheme of fu et al(1998) using
!    generalized effective size is to be used, call subroutine fu 
!    to calculate the single scattering parameters.
!----------------------------------------------------------------------
              maskis = .false.
              call fu (conc_ice(:,:,:,nb), size_ice(:,:,:,nb),   &
                        dge_column(:,:,:,nb), &
                       cldextivlice, cldssalbivlice,  &
                     cldasymmivlice,   maskif, &
                     starting_band = nivl1icecld(nb), &
                     ending_band = nivl2icecld(nb))
            else

!----------------------------------------------------------------------
!    if the ice crystal parameterization scheme of fu et al(1993) using
!    effective size is to be used, call subroutine icesolar to calculate
!    the single scattering parameters.
!----------------------------------------------------------------------
              maskif = .false.
              call icesolar (conc_ice(:,:,:,nb), size_ice(:,:,:,nb), &
                           dge_column(:,:,:,nb), &
                           cldextivlice2,     &
                           cldssalbivlice2, cldasymmivlice2, &
                           maskis, &
                           starting_band = nivl1icesolcld(nb), &
                           ending_band = nivl2icesolcld(nb))
            endif
         endif  ! (isccp_call)

!----------------------------------------------------------------------
!    define the single scattering parameters for snow.                
!----------------------------------------------------------------------
            call snowsw (conc_snow, cldextivlsnow, cldssalbivlsnow,    &
                         cldasymmivlsnow, &
                           masks, &
                         starting_band = nivl1snowcld(nb), &
                         ending_band = nivl1snowcld(nb)) 
          
!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for cloud
!    droplets that were calculated for each cloud droplet spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
            if (nonly == 0 ) then
              call thickavg (nb, nivl1liqcld(nb), nivl2liqcld(nb),  &
                            NLIQCLDIVLS,   &
                        Solar_spect%nbands, cldextivlliq,    &
                        cldssalbivlliq, cldasymmivlliq, solivlliqcld, &
                        Solar_spect%solflxbandref(nb),  maskl, &
                        cldextbandliq(:,:,:,nb),   &
                        cldssalbbandliq(:,:,:,nb),  &
                        cldasymmbandliq(:,:,:,nb))

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for rain 
!    drops that were calculated for each rain drop spectral interval 
!    to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              call thickavg ( nb, nivl1raincld(nb), nivl2raincld(nb), &
                              NRAINCLDIVLS,  &
                     Solar_spect%nbands, cldextivlrain,    &
                     cldssalbivlrain , cldasymmivlrain,  &
                     solivlraincld, Solar_spect%solflxbandref(nb),  &
                     maskr,&
                     cldextbandrain(:,:,:,nb),   &
                     cldssalbbandrain(:,:,:,nb), &
                     cldasymmbandrain(:,:,:,nb))

!---------------------------------------------------------------------
!    on calls from the isccp simulator with stochastic clouds, call all 
!    parameterizations, since some subcolumns may have cloud types 
!    using that parameterization. calculation control is provided 
!    within the parameterization subroutine.
!---------------------------------------------------------------------
           if (isccp_call) then

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for ice
!    crystals that were calculated for each ice crystal spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
                call thickavg (nb, nivl1icecld(nb), nivl2icecld(nb), &
                               NICECLDIVLS, &
                           Solar_spect%nbands, cldextivlice,     &
                           cldssalbivlice, cldasymmivlice,     &
                           solivlicecld,   &
                           Solar_spect%solflxbandref(nb),  &
                           maskif, &
                           tempext, tempssa, tempasy)   
                call thickavg (nb, nivl1icesolcld(nb),  &
                              nivl2icesolcld(nb),    &
                           NICESOLARCLDIVLS, Solar_spect%nbands, &
                           cldextivlice2, cldssalbivlice2,  &
                           cldasymmivlice2,&
                           solivlicesolcld,  &
                           Solar_spect%solflxbandref(nb),&
                           maskis, &
                           tempext2, tempssa2, tempasy2)   

              do k=1, size(cldextbandliq,3)
                do j=1, size(cldextbandliq,2)
                  do i=1, size(cldextbandliq,1)
                    if (maskif(i,j,k)) then
                      cldextbandice(i,j,k,nb) = tempext(i,j,k)
                       cldssalbbandice(i,j,k,nb) = tempssa(i,j,k)
                       cldasymmbandice(i,j,k,nb) = tempasy(i,j,k)
                    else if (maskis(i,j,k)) then
                      cldextbandice(i,j,k,nb) = tempext2(i,j,k)
                       cldssalbbandice(i,j,k,nb) = tempssa2(i,j,k)
                       cldasymmbandice(i,j,k,nb) = tempasy2(i,j,k)
                    endif
                  end do
                  end do
                  end do
!--------------------------------------------------------------------
!    if this is not an isccp call with activated stochastic clouds, all
!    grid columns will use the same parameterization.
!--------------------------------------------------------------------
  else ! (isccp_call)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for ice
!    crystals that were calculated for each ice crystal spectral
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              if (do_dge_sw) then
                maskis = .false.
                call thickavg (nb, nivl1icecld(nb), nivl2icecld(nb), &
                               NICECLDIVLS, &
                           Solar_spect%nbands, cldextivlice,     &
                           cldssalbivlice, cldasymmivlice,     &
                           solivlicecld,   &
                           Solar_spect%solflxbandref(nb),  &
                           maskif, &
                           cldextbandice(:,:,:,nb),   &
                            cldssalbbandice(:,:,:,nb),   &
                           cldasymmbandice(:,:,:,nb))
              else
                maskif = .false.
                call thickavg (nb, nivl1icesolcld(nb),  &
                              nivl2icesolcld(nb),    &
                           NICESOLARCLDIVLS, Solar_spect%nbands, &
                           cldextivlice2, cldssalbivlice2,  &
                           cldasymmivlice2,&
                           solivlicesolcld,  &
                           Solar_spect%solflxbandref(nb),&
                           maskis, &
                           cldextbandice(:,:,:,nb),  &
                           cldssalbbandice(:,:,:,nb),  &
                           cldasymmbandice(:,:,:,nb))
              endif

  endif ! (isccp_call)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for each snow flake spectral interval 
!    to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              call thickavg (nb, nivl1snowcld(nb), nivl2snowcld(nb), &
                            NSNOWCLDIVLS,  &
                     Solar_spect%nbands, cldextivlsnow,     &
                     cldssalbivlsnow , cldasymmivlsnow,  &
                     solivlsnowcld,  &
                     Solar_spect%solflxbandref(nb), masks, &
                     cldextbandsnow(:,:,:,nb),  &
                     cldssalbbandsnow(:,:,:,nb),  &
                     cldasymmbandsnow(:,:,:,nb))

              do k=1, size(cldextbandliq,3)
                do j=1, size(cldextbandliq,2)
                  do i=1, size(cldextbandliq,1)
                    anymask(i,j,k) = maskl(i,j,k) .or. maskr(i,j,k)  &
                                    .or. maskif(i,j,k) .or.  &
                                        maskis(i,j,k) .or. masks(i,j,k)
                  end do
                end do
              end do

              do k=1, size(cldextbandliq,3)
                do j=1, size(cldextbandliq,2)
                  do i=1, size(cldextbandliq,1)
                    if (anymask(i,j,k)) then
                      sum =0.
                      sum2 =0.
                      sum3 =0.
                      if (maskl(i,j,k)) then
                        sum = sum + cldextbandliq(i,j,k,nb)
                        sum2 = sum2 + cldextbandliq(i,j,k,nb)* &
                                      cldssalbbandliq(i,j,k,nb)
                        sum3 = sum3 + (cldextbandliq(i,j,k,nb)* &
                                       cldssalbbandliq(i,j,k,nb))* &
                                       cldasymmbandliq(i,j,k,nb)
                      endif
                      if (maskr(i,j,k)) then
                        sum = sum + cldextbandrain(i,j,k,nb)
                        sum2 = sum2 + cldextbandrain(i,j,k,nb)* &
                                      cldssalbbandrain(i,j,k,nb)
                        sum3 = sum3 + (cldextbandrain(i,j,k,nb)*&
                                       cldssalbbandrain(i,j,k,nb))* &
                                       cldasymmbandrain(i,j,k,nb)
                      endif
                      if (maskis(i,j,k) .or. maskif(i,j,k)) then
                        sum = sum + cldextbandice(i,j,k,nb)
                        sum2 = sum2 + cldextbandice(i,j,k,nb)* &
                                      cldssalbbandice(i,j,k,nb)
                        sum3 = sum3 + (cldextbandice(i,j,k,nb)*&
                                       cldssalbbandice(i,j,k,nb))*&
                                       cldasymmbandice(i,j,k,nb)
                      endif
                      if (masks(i,j,k)) then
                        sum = sum +  cldextbandsnow(i,j,k,nb)
                        sum2 = sum2 + cldextbandsnow(i,j,k,nb)* &
                                      cldssalbbandsnow(i,j,k,nb)
                        sum3 = sum3 + (cldextbandsnow(i,j,k,nb)*&
                                       cldssalbbandsnow(i,j,k,nb))* &
                                       cldasymmbandsnow(i,j,k,nb)
                      endif
                      cldext(i,j,k,nb) = sum
                      cldsct(i,j,k,nb) = sum2
                      cldasymm(i,j,k,nb) = sum3/ (cldsct(i,j,k,nb) +  &
                                                  1.0e-100)
                    else
                      cldext(i,j,k,nb) = 0.0
                      cldsct(i,j,k,nb) = 0.0
                      cldasymm(i,j,k,nb) = 0.0
                    endif
                  end do
                end do
              end do

            else

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for the desired cloud drop spectral 
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              call thickavg (nb, nivl1liqcld(nb), nivl2liqcld(nb),&
                            cldextivlliq,    &
                            solivlliqcld, &
                           Solar_spect%solflxbandref(nb), maskl,  &
                               cldextbandliq(:,:,:,nb))

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for the desired rain drop spectral 
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              call thickavg (nonly, nivl1raincld(nonly),  &
                             nivl2raincld(nonly),  &
                                         cldextivlrain,    &
                     solivlraincld, Solar_spect%solflxbandref(nonly), &
                     maskr, cldextbandrain(:,:,:,nonly))

!---------------------------------------------------------------------
!    on calls from the isccp simulator with stochastic clouds, call all 
!    parameterizations, since some subcolumns may have cloud types 
!    using that parameterization. calculation control is provided 
!    within the parameterization subroutine.
!---------------------------------------------------------------------
           if (isccp_call) then

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for the desired ice crystal spectral 
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
                call thickavg (nb, nivl1icecld(nb), nivl2icecld(nb),  &
                                               cldextivlice,     &
                          solivlicecld,   &
                          Solar_spect%solflxbandref(nb),    &
                           maskif, tempext                )
                call thickavg (nb, nivl1icesolcld(nb),  &
                               nivl2icesolcld(nb),    &
                           cldextivlice2,   &
                       solivlicesolcld,  &
                            Solar_spect%solflxbandref(nb),    &
                           maskis, tempext2               )
              do k=1, size(cldextbandliq,3)
                do j=1, size(cldextbandliq,2)
                  do i=1, size(cldextbandliq,1)
                    if (maskif(i,j,k)) then
                      cldextbandice(i,j,k,nb) = tempext(i,j,k)
                    else if (maskis(i,j,k)) then
                      cldextbandice(i,j,k,nb) = tempext2(i,j,k)
                    endif
                  end do
                  end do
                  end do
                    
!--------------------------------------------------------------------
!    if this is not an isccp call with activated stochastic clouds, all
!    grid columns will use the same parameterization.
!--------------------------------------------------------------------
        else  ! (isccp_call)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for the desired ice crystal spectral 
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              if (do_dge_sw) then
                maskis = .false.
                call thickavg (nb, nivl1icecld(nb), nivl2icecld(nb),  &
                                               cldextivlice,     &
                          solivlicecld,   &
                          Solar_spect%solflxbandref(nb),    &
                           maskif, cldextbandice(:,:,:,nb))
              else
                maskif = .false.
                call thickavg (nb, nivl1icesolcld(nb),  &
                               nivl2icesolcld(nb),    &
                           cldextivlice2,   &
                       solivlicesolcld,  &
                            Solar_spect%solflxbandref(nb),    &
                           maskis, cldextbandice(:,:,:,nb))
              endif
  endif ! (isccp_call)

!----------------------------------------------------------------------
!    call thickavg to map the single-scattering properties for snow 
!    flakes that were calculated for the desired snow flake spectral 
!    interval to the sw parameterization band spectral intervals.
!----------------------------------------------------------------------
              call thickavg (nonly, nivl1snowcld(nonly),   &
                             nivl2snowcld(nonly), &
                                         cldextivlsnow,     &
                  solivlsnowcld, Solar_spect%solflxbandref(nonly),   &
                     masks, cldextbandsnow(:,:,:,nonly))

              do k=1, size(cldextbandliq,3)
                do j=1, size(cldextbandliq,2)
                  do i=1, size(cldextbandliq,1)
                    anymask(i,j,k) = maskl(i,j,k) .or.  &
                                     maskr(i,j,k) .or.  &
                                      maskif(i,j,k) .or. &
                                      maskis(i,j,k) .or. masks(i,j,k)
                  end do
                end do
              end do

              do k=1, size(cldextbandliq,3)
                do j=1, size(cldextbandliq,2)
                  do i=1, size(cldextbandliq,1)
                    if (anymask(i,j,k)) then
                      sum =0.
                      if (maskl(i,j,k)) then
                        sum = sum + cldextbandliq(i,j,k,nonly)
                      endif
                      if (maskr(i,j,k)) then
                        sum = sum + cldextbandrain(i,j,k,nonly)
                      endif
                      if (maskif(i,j,k) .or. maskis(i,j,k)) then
                        sum = sum + cldextbandice(i,j,k,nonly)
                      endif
                      if (masks(i,j,k)) then
                        sum = sum +  cldextbandsnow(i,j,k,nonly)
                      endif
                      cldext(i,j,k,nonly) = sum
                    else
                      cldext(i,j,k,nonly) = 0.0
                    endif
                  end do
                end do
              end do
            endif
          endif !for nonly              
        endif !for (nbmax == 1)
      end do

!----------------------------------------------------------------------
!    combine the contribution to the single-scattering properties from
!    each of the individual constituents to define the overall cloud 
!    values in each sw parameterization band.                
!----------------------------------------------------------------------
      if (nbmax == 1) then
        cldext   =  cldextbandliq + cldextbandrain +  &
                    cldextbandice + cldextbandsnow
        cldsct   =  cldssalbbandliq*cldextbandliq  + &
                    cldssalbbandrain*cldextbandrain  + &
                    cldssalbbandice*cldextbandice +  &
                    cldssalbbandsnow*cldextbandsnow
        cldasymm = (cldasymmbandliq*(cldssalbbandliq*cldextbandliq) + &
                    cldasymmbandrain*                                 &
                              (cldssalbbandrain*cldextbandrain) +     &
                    cldasymmbandice*(cldssalbbandice*cldextbandice) + &
                    cldasymmbandsnow*                                 &
                              (cldssalbbandsnow*cldextbandsnow))/     &
                                                     (cldsct + 1.0e-100)
      endif 



!---------------------------------------------------------------------


end subroutine cloudpar



!#####################################################################
! <SUBROUTINE NAME="slingo">
!  <OVERVIEW>
!   Subroutine to determine single scattering parameters for clouds
!  </OVERVIEW>
!  <DESCRIPTION>
!   define the single scattering parameters for cloud drops using the     
! Slingo parameterization for his spectral intervals.
!   slingo, a., a gcm parameterization of the shortwave properties of     
!      water clouds., j. atmos. sci.,46, 1419-1427, 1989.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call slingo                                               &
!                    (conc_drop   , size_drop     ,                    &
!                     cldextivlliq, cldssalbivlliq, cldasymmivlliq, &
!                     starting_band, ending_band )
!  </TEMPLATE>
!  <IN NAME="conc_drop" TYPE="real">
!   the cloud drop liquid water concentration in grams meter**3 
!  </IN>
!  <IN NAME="size_drop" TYPE="real">
!   the cloud drop effective diameter in microns
!  </IN>
!  <OUT NAME="cldextivlliq" TYPE="real">
!   The specified spectral values of the extinction      
!   coefficient in kilometer**(-1) for drops
!  </OUT>
!  <OUT NAME="cldssalbivlliq" TYPE="real">
!   the specified spectral values of the single-scattering albedo 
!   for drops
!  </OUT>
!  <OUT NAME="cldasymmivlliq" TYPE="real">
!   the specified spectral values of the asymmetry factor for drops
!  </OUT>
!  <IN NAME="starting_band">
!
!  </IN>
!  <IN NAME="ending_band">
!
!  </IN>
! </SUBROUTINE>
!
subroutine slingo (conc_drop, size_drop, cldextivlliq, cldssalbivlliq, &
                   cldasymmivlliq, mask, starting_band, ending_band)
 
!----------------------------------------------------------------------
!    subroutine slingo defines the single scattering parameters for 
!    cloud droplets using the Slingo parameterization for his spectral 
!    intervals. references:                                      
!    slingo, a., a gcm parameterization of the shortwave properties of 
!                water clouds., j. atmos. sci.,46, 1419-1427, 1989.   
!----------------------------------------------------------------------

real, dimension (:,:,:),   intent(in)     ::   conc_drop, size_drop
real, dimension (:,:,:,:), intent(inout)  ::   cldextivlliq,  &
                                               cldssalbivlliq,   &
                                               cldasymmivlliq
logical, dimension(:,:,:), intent(out)    ::   mask
integer, intent(in), optional             ::   starting_band,  &
                                               ending_band

!-------------------------------------------------------------------
!   intent(in) variables:                                              
!                                                                       
!        conc_drop        cloud drop liquid water concentration 
!                         [ grams / meter**3 ]                       
!        size_drop        cloud drop effective diameter [ microns ]    
!
!    intent(out) variables:                                     
!                                                                       
!        cldextivlliq     extinction coefficient in each spectral
!                         interval of the slingo cloud droplet param-
!                         eterization resulting from the presence of 
!                         cloud droplets  [ km **(-1) ]
!        cldssalbivlliq   single scattering albedo in each spectral
!                         interval of the slingo cloud droplet param-
!                         eterization resulting from the presence of 
!                         cloud droplets  [ dimensionless ]
!        cldasymmivlliq   asymmetry factor in each spectral
!                         interval of the slingo cloud droplet param-
!                         eterization resulting from the presence of 
!                         cloud droplets  [ dimensionless ]
!
!   intent(in), optional variables:
!
!        starting_band    the index of the first droplet spectral
!                         band contained in the sw parameterization
!                         band(s) being processed
!        ending_band      the index of the last droplet spectral
!                         band contained in the sw parameterization
!                         band(s) being processed
!
!----------------------------------------------------------------------
 
!---------------------------------------------------------------------
! local variables:                                                   

      real, dimension (size(conc_drop,1), size(conc_drop,2),  &
                       size(conc_drop,3))   ::  size_d

      real, dimension (NLIQCLDIVLS)         ::  a, b, c, d, e, f
 
      data a /-1.023E+00, 1.950E+00, 1.579E+00, 1.850E+00, 1.970E+00, &
               2.237E+00, 2.463E+00, 2.551E+00, 2.589E+00, 2.632E+00, &
               2.497E+00, 2.622E+00, 2.650E+00, 3.115E+00, 2.895E+00, &
               2.831E+00, 2.838E+00, 2.672E+00, 2.698E+00, 2.668E+00, &
               2.801E+00, 3.308E+00, 2.944E+00, 3.094E+00 /
      data b / 1.933E+00, 1.540E+00, 1.611E+00, 1.556E+00, 1.501E+00, &
               1.452E+00, 1.420E+00, 1.401E+00, 1.385E+00, 1.365E+00, &
               1.376E+00, 1.362E+00, 1.349E+00, 1.244E+00, 1.315E+00, &
               1.317E+00, 1.300E+00, 1.320E+00, 1.315E+00, 1.307E+00, &
               1.293E+00, 1.246E+00, 1.270E+00, 1.252E+00 /
      data c / 2.500E-02, 4.490E-01, 1.230E-01, 1.900E-04, 1.200E-03, &
               1.200E-04, 2.400E-04, 6.200E-05,-2.800E-05,-4.600E-05, &
               9.800E-06, 3.300E-06, 2.300E-06,-2.700E-07,-1.200E-07, &
              -1.200E-06, 0.000E+00, 0.000E+00, 1.000E-06, 0.000E+00, &
               1.000E-06,-3.000E-07,-6.500E-07, 7.900E-07 /
      data d / 1.220E-02, 1.540E-03, 9.350E-03, 2.540E-03, 2.160E-03, &
               6.670E-04, 8.560E-04, 2.600E-04, 8.000E-05, 5.000E-05, &
               2.100E-05, 2.800E-06, 1.700E-06, 1.400E-06, 4.400E-07, &
               4.000E-07, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, &
               0.000E+00, 2.360E-07, 4.330E-07, 3.690E-07 /
      data e / 7.260E-01, 8.310E-01, 8.510E-01, 7.690E-01, 7.400E-01, &
               7.490E-01, 7.540E-01, 7.730E-01, 7.800E-01, 7.840E-01, &
               7.830E-01, 8.060E-01, 8.090E-01, 8.040E-01, 8.180E-01, &
               8.280E-01, 8.250E-01, 8.280E-01, 8.200E-01, 8.400E-01, &
               8.360E-01, 8.390E-01, 8.410E-01, 8.440E-01 /
      data f / 6.652E+00, 6.102E+00, 2.814E+00, 5.171E+00, 7.469E+00, &
               6.931E+00, 6.555E+00, 5.405E+00, 4.989E+00, 4.745E+00, &
               5.035E+00, 3.355E+00, 3.387E+00, 3.520E+00, 2.989E+00, &
               2.492E+00, 2.776E+00, 2.467E+00, 3.004E+00, 1.881E+00, &
               2.153E+00, 1.946E+00, 1.680E+00, 1.558E+00 /

      integer   :: nistart, niend
      integer   :: i, j, k, ni
 
!---------------------------------------------------------------------
! local variables:                                                   
!
!      size_d       droplet effective radius [ microns ]
!      a            slingo parameterization coefficient for cloud
!                   extinction coefficient [ m**2 / g ]
!      b            slingo parameterization coefficient for cloud
!                   extinction coefficient [ micron*m**2 / g ]
!      c            slingo parameterization coefficient for cloud
!                   single scattering albedo [ nondimensional ]
!      d            slingo parameterization coefficient for cloud
!                   single scattering albedo [ micron **(-1) ]
!                   asymmetry factor [ nondimensional ]
!      f            slingo parameterization coefficient for cloud
!                   asymmetry factor [ micron **(-1) ]
!      nistart      first droplet parameterization band to be processed
!      niend        last droplet parameterization band to be processed
!      i,j,k,ni     do-loop indices
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the starting and ending droplet parameterization bands to
!    be processed during this call.
!--------------------------------------------------------------------
      if (present(starting_band)) then
        nistart = starting_band
      else
        nistart = 1
      endif
      if (present(ending_band)) then
        niend = ending_band
      else
        niend = NLIQCLDIVLS
      endif
 
!---------------------------------------------------------------------
      do k=1,size(conc_drop,3)
        do j=1,size(conc_drop,2)
          do i=1,size(conc_drop,1)

!------------------------------------------------------------------
!    bypass calculations if no drops are present. values are set to
!    zero in all spectral bands.
!-----------------------------------------------------------------
            if (conc_drop(i,j,k) == 0.0) then
              mask(i,j,k) = .false.

!--------------------------------------------------------------------
!    convert input variable size from diameter to radius for use in the
!    slingo formulae.
!--------------------------------------------------------------------
            else
              mask(i,j,k) = .true.
              size_d(i,j,k) = 0.5*size_drop(i,j,k)

!----------------------------------------------------------------------
!    the cloud drop effective radius must be between 4.2 and 16.6 
!    microns.                               
!----------------------------------------------------------------------
              if (size_d(i,j,k) <  min_cld_drop_rad) then   
                size_d(i,j,k) =  min_cld_drop_rad
              else if (size_d(i,j,k) > max_cld_drop_rad) then 
                size_d(i,j,k) = max_cld_drop_rad             
              endif

!---------------------------------------------------------------------
!    define values of extinction coefficient, single-scattering albedo
!    and asymmetry factor for each of the slingo parameterization 
!    spectral bands. these values are a function of droplet concen-
!    tration and droplet effective radius. the extinction coefficient 
!    is converted to kilometer**(-1).     
!---------------------------------------------------------------------
                do ni=nistart, niend
                  cldextivlliq(i,j,k,ni) = 1.0E+03*conc_drop(i,j,k)* &
                                           (1.0E-02*a(ni) + (b(ni)/  &
                                           size_d(i,j,k)            ) )
                  cldssalbivlliq(i,j,k,ni) = 1.0 - ( c(ni) + d(ni)* &
                                             size_d(i,j,k) )
                  cldasymmivlliq(i,j,k,ni) = e(ni) + 1.0E-03*f(ni)*  &
                                             size_d(i,j,k)
                end do
            endif     
          end do
        end do
      end do

!-------------------------------------------------------------------


end subroutine slingo




!#####################################################################
! <SUBROUTINE NAME="savijarvi">
!  <OVERVIEW>
!   Subroutine to define the single scattering parameters for rain drop
!  </OVERVIEW>
!  <DESCRIPTION>
!   define the single scattering parameters for rain drops using the      
! Savijarvi parameterization for his spectral intervals.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call savijarvi                                          &
!                    (conc_rain    , size_rain      ,                &
!                     cldextivlrain, cldssalbivlrain, cldasymmivlrain)
!  </TEMPLATE>
!  <IN NAME="conc_rain" TYPE="real">
!   the rain drop water concentration in grams / meter**3
!  </IN>
!  <IN NAME="size_rain" TYPE="real">
!   the rain drop effective diameter in microns
!  </IN>
!  <OUT NAME="cldextivlrain" TYPE="real">
!   the specified spectral values of the extinction     
!                   coefficient for rain in kilometers**(-1)
!  </OUT>
!  <OUT NAME="cldssalbivlrain" TYPE="real">
!   the specified spectral values of the single-        
!                   scattering albedo for rain
!  </OUT>
!  <OUT NAME="cldasymmivlrain" TYPE="real">
!   the specified spectral values of the asymmetry      
!                   factor for rain
!  </OUT>
! </SUBROUTINE>
!
subroutine savijarvi (conc_rain, size_rain, cldextivlrain,    &
                      cldssalbivlrain, cldasymmivlrain, &
                      mask, starting_band, ending_band)      
 
!----------------------------------------------------------------------
!    subroutine savijarvi defines the single scattering parameters for 
!    rain drops using the Savijarvi parameterization for his spectral 
!    intervals. references:                                     
!    savijarvi, h., shortwave optical properties of rain., tellus, 49a, 
!    177-181, 1997.                                                   
!---------------------------------------------------------------------- 

real, dimension (:,:,:),   intent(in)   ::  conc_rain, size_rain
real, dimension (:,:,:,:), intent(out)  ::  cldextivlrain,            &
                                            cldssalbivlrain,   &
                                            cldasymmivlrain
logical, dimension(:,:,:), intent(out)    ::   mask
integer, intent(in), optional             ::   starting_band,  &
                                               ending_band

!---------------------------------------------------------------------
!  intent(in) variables:
!
!        conc_rain        rain drop water concentration [ grams / m**3 ]
!        size_rain        rain drop effective diameter [ microns ]     
!
!  intent(out) variables:
!
!        cldextivlrain    extinction coefficient in each spectral
!                         interval of the savijarvi rain drop param-
!                         eterization resulting from the presence of 
!                         rain drops  [ km **(-1) ]
!        cldssalbivlrain  single scattering albedo in each spectral
!                         interval of the savijarvi rain drop param-
!                         eterization resulting from the presence of 
!                         rain drops  [ dimensionless ]
!        cldasymmivlrain  asymmetry factor in each spectral
!                         interval of the savijarvi rain drop param-
!                         eterization resulting from the presence of 
!                         rain drops  [ dimensionless ]
!
!---------------------------------------------------------------------
 
!---------------------------------------------------------------------- 
! local variables:                                                      
 
      real, dimension (size(conc_rain,1), size(conc_rain,2),       &
                       size(conc_rain,3) )       ::                &
                                                      rcap, size_d
 
      real, dimension (NRAINCLDIVLS)          ::  a, b, asymm

      data a     / 4.65E-01, 2.64E-01, 1.05E-02, 8.00E-05 /
      data b     / 1.00E-03, 9.00E-02, 2.20E-01, 2.30E-01 /
      data asymm / 9.70E-01, 9.40E-01, 8.90E-01, 8.80E-01 /

      integer   ::  i, j, k, ni
      integer   ::  nistart, niend

!---------------------------------------------------------------------
!   local variables:
! 
!         rcap       drop size function used in savijarvi parameter-
!                    ization : (drop radius/500.)**4.348
!                    [ dimensionless ]
!         size_d     rain drop effective radius [ microns ]
!         a          interval-dependent parameter in savijarvi single 
!                    scattering albedo formula
!                    [ dimensionless ]
!         b          interval-dependent parameter in savijarvi single 
!                    scattering albedo formula
!                    [ dimensionless ]
!         asymm      asymmetry factor for each savijarvi spectral band
!         i,j,k,ni   do-loop indices
!--------------------------------------------------------------------
!---------------------------------------------------------------------
!    define the starting and ending droplet parameterization bands to
!    be processed during this call.
!--------------------------------------------------------------------
      if (present(starting_band)) then
        nistart = starting_band
      else
        nistart = 1
      endif
      if (present(ending_band)) then
        niend = ending_band
      else
        niend = NRAINCLDIVLS
      endif

!--------------------------------------------------------------------
      do k=1,size(conc_rain,3)
        do j=1,size(conc_rain,2)
          do i=1,size(conc_rain,1)
 
!-----------------------------------------------------------------
!    if no rain is present in a grid box, set the scattering parameters
!    to so indicate.
!-----------------------------------------------------------------
            if (conc_rain(i,j,k) == 0.0) then
              mask(i,j,k) = .false.

!----------------------------------------------------------------------
!    convert input size from drop diameter to drop radius. 
!----------------------------------------------------------------------
            else
              mask(i,j,k) = .true.
              size_d(i,j,k) = 0.5*size_rain(i,j,k) 

!---------------------------------------------------------------------
!    the rain drop effective radius must be between 16.6 and 5000    
!    microns. compute the rcap function, used in the savijarvi formula.
!---------------------------------------------------------------------
              if (size_d(i,j,k) > 16.6 .and.              &
                  size_d(i,j,k) <= 5000. ) then                       
                rcap(i,j,k) = (size_d(i,j,k)/500.) ** 4.348E+00

!--------------------------------------------------------------------
!    compute values for each of the savijarvi rain drop spectral
!    intervals. the extinction coefficient is converted to km**(-1).    
!--------------------------------------------------------------------
!               do ni = 1,NRAINCLDIVLS
                do ni = nistart, niend 
                  cldextivlrain(i,j,k,ni) = 1.00E+03*1.505E+00*     &
                                            conc_rain(i,j,k)/     &
                                            size_d(i,j,k)  
                  cldssalbivlrain(i,j,k,ni) = 1.0E+00 - (a(ni)*    &
                                              (rcap(i,j,k)**b(ni)))
                  cldasymmivlrain(i,j,k,ni) = asymm(ni)
                end do
              else
                call error_mesg ('microphys_rad_mod', &
                          'rain drop size out of range', FATAL)
              endif
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------
 


end subroutine savijarvi


!####################################################################
! <SUBROUTINE NAME="fu">
!  <OVERVIEW>
!   Subroutine to define the single scattering parameters for ice crystals
!  </OVERVIEW>
!  <DESCRIPTION>
!   define the single scattering parameters for ice crystals using the    
! Fu parameterization for his spectral intervals.
!                                                                       
! references:                                                           
!                                                                       
! fu, q., an accurate parameterization of the solar radiative           
!      properties of cirrus clouds for climate models., j. climate,     
!      9, 2058-2082, 1996.                                              
!                                                                       
! notes: the ice crystal effective size (D^sub^ge in his paper) can     
!        only be 18.6 <= D^sub^ge <= 130.2 microns.                     
!                                                                       
!        the single scattering properties for wavenumbers < 2000 cm-1   
!        are assigned the values in the first interval, since the       
!        formulation is not defined for those wavenumbers.              
!                                                                       
!        the extinction coefficient is converted to kilometer**(-1)     
!        the unit utilized by the shortwave routine Swresf.             
!                                                                       
!        a value of 1.0E-100 is added to the size so that no division   
!        by zero occurs when the size is zero, in defining the          
!        extinction coefficient.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call fu                                                 &
!                    (conc_ice    , size_ice      ,                  &
!                     cldextivlice, cldssalbivlice, cldasymmivlice)
!  </TEMPLATE>
!  <IN NAME="conc_ice" TYPE="real">
!   the ice water concentation in grams / meter**3
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   the ice crystal effective size in microns
!  </IN>
!  <OUT NAME="cldextivlice" TYPE="real">
!   the specified spectral values of the extinction      
!                  coefficient for ice particles in kilometers**(-1)
!  </OUT>
!  <OUT NAME="cldssalbivlice" TYPE="real">
!   the specified spectral values of the single-         
!                  scattering albedo for ice particles
!  </OUT>
!  <OUT NAME="cldasymmivlice" TYPE="real">
!   the specified spectral values of the asymmetry       
!                  factor for ice particles
!  </OUT>
! </SUBROUTINE>
!
subroutine fu (conc_ice, size_ice, dge_column, cldextivlice,  &
               cldssalbivlice, cldasymmivlice, mask, starting_band, &
               ending_band)
 
!----------------------------------------------------------------------
!    subroutine fu defines the single scattering parameters for ice
!    crystals using the Fu parameterization for his spectral intervals.
!    references:                                                
!    fu, q., an accurate parameterization of the solar radiative    
!    properties of cirrus clouds for climate models., j. climate,     
!    9, 2058-2082, 1996.                                              
!---------------------------------------------------------------------- 
                                                                        
real, dimension (:,:,:),   intent(in)    ::   conc_ice, size_ice
logical, dimension (:,:,:),   intent(in)    ::   dge_column          
real, dimension (:,:,:,:), intent(inout)   ::  cldextivlice,      &
                                               cldssalbivlice,    &
                                               cldasymmivlice
logical, dimension(:,:,:), intent(out)    ::   mask
integer,     intent(in), optional          ::  starting_band, &
                                               ending_band

!----------------------------------------------------------------------
!  intent(in) variables:                                              
!                                                                       
!        conc_ice         ice water concentation [ grams / meter**3 ]
!        size_ice         ice crystal effective size [ microns ]  
!
!  intent(out) variables:                                               
!                                                                       
!        cldextivlice     extinction coefficient in each spectral
!                         interval of the fu ice crystal param-
!                         eterization resulting from the presence of 
!                         ice crystals [ km **(-1) ]
!        cldssalbivlice   single scattering albedo in each spectral
!                         interval of the fu ice crystal param-
!                         eterization resulting from the presence of 
!                         ice crystals [ dimensionless ]
!        cldasymmivlice   asymmetry factor in each spectral
!                         interval of the fu ice crystal param-
!                         eterization resulting from the presence of 
!                         ice crystals [ dimensionless ]
!
!   intent(in), optional variables:
!
!        starting_band    the index of the first ice crystal spectral
!                         band contained in the sw parameterization
!                         band(s) being processed
!        ending_band      the index of the last ice crystal spectral
!                         band contained in the sw parameterization
!                         band(s) being processed
!
!---------------------------------------------------------------------
 
!----------------------------------------------------------------------c
! local variables:                                                     c

      real, dimension (size(conc_ice,1), size(conc_ice,2),  &
                       size(conc_ice,3))   ::  size_i

      real, dimension (NICECLDIVLS) ::  a0fu, a1fu,             &
                                        b0fu, b1fu, b2fu, b3fu,       &
                                        c0fu, c1fu, c2fu, c3fu
 
      data a0fu / -2.54823E-04, 1.87598E-04, 2.97295E-04, 2.34245E-04, &
                   4.89477E-04,-8.37325E-05, 6.44675E-04,-8.05155E-04, &
                   6.51659E-05, 4.13595E-04,-6.14288E-04, 7.31638E-05, &
                   8.10443E-05, 2.26539E-04,-3.04991E-04, 1.61983E-04, &
                   9.82244E-05,-3.03108E-05,-9.45458E-05, 1.29121E-04, &
                  -1.06451E-04,-2.58858E-04,-2.93599E-04,-2.66955E-04, &
                  -2.36447E-04 /
      data a1fu /  2.52909E+00, 2.51396E+00, 2.48895E+00, 2.48573E+00, &
                   2.48776E+00, 2.52504E+00, 2.47060E+00, 2.57600E+00, &
                   2.51660E+00, 2.48783E+00, 2.56520E+00, 2.51051E+00, &
                   2.51619E+00, 2.49909E+00, 2.54412E+00, 2.50746E+00, &
                   2.50875E+00, 2.51805E+00, 2.52061E+00, 2.50410E+00, &
                   2.52684E+00, 2.53815E+00, 2.54540E+00, 2.54179E+00, &
                   2.53817E+00 /
      data b0fu /  2.60155E-01, 1.96793E-01, 4.64416E-01, 9.05631E-02, &
                   5.83469E-04, 2.53234E-03, 2.01931E-03,-2.85518E-05, &
                  -1.48012E-07, 6.47675E-06,-9.38455E-06,-2.32733E-07, &
                  -1.57963E-07,-2.75031E-07, 3.12168E-07,-7.78001E-08, &
                  -8.93276E-08, 9.89368E-08, 5.08447E-07, 7.10418E-07, &
                   3.25057E-08,-1.98529E-07, 1.82299E-07,-1.00570E-07, &
                  -2.69916E-07 /
      data b1fu/   5.45547E-03, 5.75235E-03, 2.04716E-05, 2.93035E-03, &
                   1.18127E-03, 1.75078E-03, 1.83364E-03, 1.71993E-03, &
                   9.02355E-05, 2.18111E-05, 1.77414E-05, 6.41602E-06, &
                   1.72475E-06, 9.72285E-07, 4.93304E-07, 2.53360E-07, &
                   1.14916E-07, 5.44286E-08, 2.73206E-08, 1.42205E-08, &
                   5.43665E-08, 9.39480E-08, 1.12454E-07, 1.60441E-07, &
                   2.12909E-07 /
      data b2fu / -5.58760E-05,-5.29220E-05,-4.60375E-07,-1.89176E-05, &
                  -3.40011E-06,-8.00994E-06,-7.00232E-06,-7.43697E-06, &
                  -1.98190E-08, 1.83054E-09,-1.13004E-09, 1.97733E-10, &
                   9.02156E-11,-2.23685E-10, 1.79019E-10,-1.15489E-10, &
                  -1.62990E-10,-1.00877E-10, 4.96553E-11, 1.99874E-10, &
                  -9.24925E-11,-2.54540E-10,-1.08031E-10,-2.05663E-10, &
                  -2.65397E-10 /
      data b3fu /  1.97086E-07, 1.76618E-07, 2.03198E-09, 5.93361E-08, &
                   8.78549E-09, 2.31309E-08, 1.84287E-08, 2.09647E-08, &
                   4.01914E-11,-8.28710E-12, 2.37196E-12,-6.96836E-13, &
                  -3.79423E-13, 5.75512E-13,-7.31058E-13, 4.65084E-13, &
                   6.53291E-13, 4.56410E-13,-1.86001E-13,-7.81101E-13, &
                   4.53386E-13, 1.10876E-12, 4.99801E-13, 8.88595E-13, &
                   1.12983E-12 /
      data c0fu /  7.99084E-01, 7.59183E-01, 9.19599E-01, 8.29283E-01, &
                   7.75916E-01, 7.58748E-01, 7.51497E-01, 7.52528E-01, &
                   7.51277E-01, 7.52292E-01, 7.52048E-01, 7.51715E-01, &
                   7.52318E-01, 7.51779E-01, 7.53393E-01, 7.49693E-01, &
                   7.52131E-01, 7.51135E-01, 7.49856E-01, 7.48613E-01, &
                   7.47054E-01, 7.43546E-01, 7.40926E-01, 7.37809E-01, &
                   7.33260E-01 /
      data c1fu /  4.81706E-03, 4.93765E-03, 5.03025E-04, 2.06865E-03, &
                   1.74517E-03, 2.02709E-03, 2.05963E-03, 1.95748E-03, &
                   1.29824E-03, 1.14395E-03, 1.12044E-03, 1.10166E-03, &
                   1.04224E-03, 1.03341E-03, 9.61630E-04, 1.05446E-03, &
                   9.37763E-04, 9.09208E-04, 8.89161E-04, 8.90545E-04, &
                   8.86508E-04, 9.08674E-04, 8.90216E-04, 8.97515E-04, &
                   9.18317E-04 /
      data c2fu / -5.13220E-05,-4.84059E-05,-5.74771E-06,-1.59247E-05, &
                  -9.21314E-06,-1.17029E-05,-1.12135E-05,-1.02495E-05, &
                  -4.99075E-06,-3.27944E-06,-3.11826E-06,-2.91300E-06, &
                  -2.26618E-06,-2.13121E-06,-1.32519E-06,-2.32576E-06, &
                  -9.72292E-07,-6.34939E-07,-3.49578E-07,-3.44038E-07, &
                  -2.59305E-07,-4.65326E-07,-1.87919E-07,-2.17099E-07, &
                  -4.22974E-07 /
      data c3fu /  1.84420E-07, 1.65801E-07, 2.01731E-08, 5.01791E-08, &
                   2.15003E-08, 2.95195E-08, 2.73998E-08, 2.35479E-08, &
                   6.33757E-09,-2.42583E-10,-5.70868E-10,-1.37242E-09, &
                  -3.68283E-09,-4.24308E-09,-7.17071E-09,-3.58307E-09, &
                  -8.62063E-09,-9.84390E-09,-1.09913E-08,-1.10117E-08, &
                  -1.13305E-08,-1.05786E-08,-1.16760E-08,-1.16090E-08, &
                  -1.07976E-08 /
 
      integer     :: nistart, niend
      integer     :: i, j, k, ni
      real        :: fd, f, fw

!---------------------------------------------------------------------
!   local variables:
!
!        a0fu     interval-dependent parameter used to define extinction
!                 coefficient due to ice crystals in the fu 
!                 parameterization
!        a1fu     interval-dependent parameter used to define extinction
!                 coefficient due to ice crystals in the fu 
!                 parameterization
!        b0fu     interval-dependent parameter used to define single-
!                 scattering albedo due to ice crystals in the fu 
!                 parameterization
!        b1fu     interval-dependent parameter used to define single-
!                 scattering albedo due to ice crystals in the fu 
!                 parameterization
!        b2fu     interval-dependent parameter used to define single-
!                 scattering albedo due to ice crystals in the fu 
!                 parameterization
!        b3fu     interval-dependent parameter used to define single-
!                 scattering albedo due to ice crystals in the fu 
!                 parameterization
!        c0fu     interval-dependent parameter used to define asymmetry 
!                 factor due to ice crystals in the fu parameterization
!        c1fu     interval-dependent parameter used to define asymmetry
!                 factor due to ice crystals in the fu parameterization
!        c2fu     interval-dependent parameter used to define asymmetry
!                 factor due to ice crystals in the fu parameterization
!        c3fu     interval-dependent parameter used to define asymmetry 
!                 factor due to ice crystals in the fu parameterization
!        nistart  first ice crystal parameterization band to be
!                 processed
!        niend    last ice crystal parameterization band to be processed
!        i,j,k,ni do-loop indices
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the starting and ending droplet parameterization bands to
!    be processed during this call.
!--------------------------------------------------------------------
      if (present(starting_band)) then
        nistart = starting_band
      else
        nistart = 1
      endif
      if (present(ending_band)) then
        niend = ending_band
      else
        niend = NICECLDIVLS
      endif

!----------------------------------------------------------------------
      do k=1,size(conc_ice,3)
        do j=1,size(conc_ice,2)
          do i=1,size(conc_ice,1)

            if (dge_column(i,j,k)) then
!----------------------------------------------------------------------
!    if no ice crystals are present in a grid box, set the scattering
!    parameters to zero.
!----------------------------------------------------------------------
              if (conc_ice (i,j,k) == 0.0) then
                mask(i,j,k) = .false.

!----------------------------------------------------------------------
!    compute the ice crystal scattering parameters.
!----------------------------------------------------------------------
              else !(conc_ice > 0)
                mask(i,j,k) = .true.

!--------------------------------------------------------------------
!    the ice crystal effective size (D^sub^ge in fu's paper) is limited.
!--------------------------------------------------------------------
                if (size_ice(i,j,k) <= min_cld_ice_size) then
                  size_i(i,j,k) = min_cld_ice_size      
                else if (size_ice(i,j,k) > max_cld_ice_size ) then    
                  size_i(i,j,k) = max_cld_ice_size         
                else
                  size_i(i,j,k) = size_ice(i,j,k)          
                endif

!---------------------------------------------------------------------
!     compute the scattering parameters for each of the fu spectral 
!     intervals. the extinction coefficient is converted to km**(-1).  
!---------------------------------------------------------------------
                do ni = nistart, niend
                  cldextivlice(i,j,k,ni) = 1.0E+03*conc_ice(i,j,k)*  &
                                           (a0fu(ni) + (a1fu(ni)/    &
                                            size_i(i,j,k)     ))
                  cldssalbivlice(i,j,k,ni) =  1.0 -                &
                                     ( b0fu(ni)                    +   &
                                       b1fu(ni)*size_i(i,j,k)    +   &
                                       b2fu(ni)*size_i(i,j,k)**2 +   &
                                       b3fu(ni)*size_i(i,j,k)**3 )
                  cldasymmivlice(i,j,k,ni) =                        &
                          c0fu(ni) +                                   &
                          c1fu(ni)*size_i(i,j,k) +                   &
                          c2fu(ni)*size_i(i,j,k)**2 +                &
                          c3fu(ni)*size_i(i,j,k)**3

                  if (do_delta_adj .and. (.not. do_const_asy)) then
                    fd =                                           &
                          1.1572963e-1 +                       &
                          2.5648064e-4*size_ice(i,j,k) +     &
                          1.9131293e-6*size_ice(i,j,k)**2    &
                         -1.2460341e-8*size_ice(i,j,k)**3
                    f = 0.5/cldssalbivlice(i,j,k,ni) + fd
                    fw = f * cldssalbivlice(i,j,k,ni)
                    cldextivlice(i,j,k,ni) =   &
                            cldextivlice(i,j,k,ni) * (1. - fw)
                    cldssalbivlice(i,j,k,ni) =   &
                          cldssalbivlice(i,j,k,ni) * (1. - f)/(1. - fw)
                    cldasymmivlice(i,j,k,ni) =  &
                          (cldasymmivlice(i,j,k,ni) - f)/(1. - f)
                  endif
  
                  if (do_const_asy .and. (.not. do_delta_adj)) then
                    f = 0.5/cldssalbivlice(i,j,k,ni)
                    fw = f * cldssalbivlice(i,j,k,ni)
                    cldextivlice(i,j,k,ni) = cldextivlice(i,j,k,ni) &
                                                        * (1. - fw)
                    cldssalbivlice(i,j,k,ni) =  &
                           cldssalbivlice(i,j,k,ni) * (1. - f)/(1. - fw)
                    cldasymmivlice(i,j,k,ni) = (val_const_asy - f)/ &
                                                            (1. - f)
                  endif

                  if (do_delta_adj .and. do_const_asy) then
                    fd =                                           &
                        1.1572963e-1 +                         &
                        2.5648064e-4*size_ice(i,j,k) +              &
                        1.9131293e-6*size_ice(i,j,k)**2       &
                       -1.2460341e-8*size_ice(i,j,k)**3
                    f = 0.5/cldssalbivlice(i,j,k,ni) + fd
                    fw = f * cldssalbivlice(i,j,k,ni)
                    cldextivlice(i,j,k,ni) = cldextivlice(i,j,k,ni) &
                                                         * (1. - fw)
                    cldssalbivlice(i,j,k,ni) =  &
                          cldssalbivlice(i,j,k,ni) * (1. - f)/(1. - fw)
                    cldasymmivlice(i,j,k,ni) =  &
                                         (val_const_asy - f)/(1. - f)
                  endif
                end do
              endif ! (conc_ice > 0)
            else ! (dge_column)
              mask(i,j,k) = .false.
            endif ! (dge_column)
          end do
        end do
      end do

!---------------------------------------------------------------------
 


end subroutine fu



!#####################################################################
! <SUBROUTINE NAME="icesolar">
!  <OVERVIEW>
!   Subroutine to define the single scattering parameters for ice crystals
!  </OVERVIEW>
!  <DESCRIPTION>
!   define the single scattering parameters for ice crystals using the    
! Fu parameterization for his spectral intervals.                       
!                                                                       
! references:                                                           
!                                                                       
! fu and Liou (1993, JAS) 
!                                                                       
! notes: the ice crystal effective size (D^sub^e in paper) can          
!        only be 18.6 <= D^sub^e <= 130.2 microns.                     
!                                                                       
!        the single scattering properties for wavenumbers < 2000 cm-1   
!        are assigned the values in the first interval, since the       
!        formulation is not defined for those wavenumbers.              
!                                                                       
!        the extinction coefficient is converted to kilometer**(-1)     
!        the unit utilized by the shortwave routine Swresf.             
!                                                                       
!        a value of 1.0E-100 is added to the size so that no division  
!        by zero occurs when the size is zero, in defining the          
!        extinction coefficient.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call icesolar                                           &
!                    (conc_ice    , size_ice      ,                  &
!                     cldextivlice, cldssalbivlice, cldasymmivlice)
!  </TEMPLATE>
!  <IN NAME="conc_ice" TYPE="real">
!   the ice water concentation in grams / meter**3
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   the ice crystal effective size in microns                  
! Corresponds to minimum dimension of hexagonal crystal.
!  </IN>
!  <OUT NAME="cldextivlice" TYPE="real">
!   the specified spectral values of the extinction      
!                  coefficient for ice particles in kilometers**(-1)
!  </OUT>
!  <OUT NAME="cldssalbivlice" TYPE="real">
!   the specified spectral values of the single-         
!                  scattering albedo for ice particles
!  </OUT>
!  <OUT NAME="cldasymmivlice" TYPE="real">
!   the specified spectral values of the asymmetry       
!                  factor for ice particles
!  </OUT>
! </SUBROUTINE>
!
subroutine icesolar (conc_ice, size_ice, dge_column, cldextivlice,    &
                     cldssalbivlice, cldasymmivlice, &
                     mask, &
                     starting_band, ending_band)
 
!---------------------------------------------------------------------- 
!    subroutine icesolar defines the single scattering parameters for 
!    ice crystals using the fu and liou (1993) parameterization for 
!    their spectral intervals. references:                      
!    Fu and Liou (1993, JAS) 
!----------------------------------------------------------------------
                                                                   
real, dimension (:,:,:),   intent(in)   ::   conc_ice, size_ice
logical, dimension (:,:,:),   intent(in)   ::   dge_column        
real, dimension (:,:,:,:), intent(inout)  ::   cldextivlice,           &
                                               cldssalbivlice,         &
                                               cldasymmivlice
logical, dimension(:,:,:), intent(out)    ::   mask
integer,  intent(in), optional            ::   starting_band, &
                                               ending_band

!---------------------------------------------------------------------- 
! intent(in) variables:                                                 
!                                                                       
!        conc_ice         ice water concentation [ grams / meter**3 ]  
!        size_ice         ice crystal effective size. this corresponds 
!                         to the minimum dimension of hexagonal crystal.
!                         [ microns ]
!                                                                       
! intent(out) variables:                                                
!                                                                       
!        cldextivlice     extinction coefficient in each spectral
!                         interval of the fu and liou ice crystal param-
!                         eterization resulting from the presence of 
!                         ice crystals [ km **(-1) ]
!        cldssalbivlice   single scattering albedo in each spectral
!                         interval of the fu and liou ice crystal param-
!                         eterization resulting from the presence of 
!                         ice crystals [ dimensionless ]
!        cldasymmivlice   asymmetry factor in each spectral interval of
!                         the fu iand liou ice crystal param-
!                         eterization resulting from the presence of 
!                         ice crystals [ dimensionless ]
!
!   intent(in), optional variables:
!
!        starting_band    the index of the first ice crystal spectral
!                         band contained in the sw parameterization
!                         band(s) being processed
!        ending_band      the index of the last ice crystal spectral
!                         band contained in the sw parameterization
!                         band(s) being processed
!
!---------------------------------------------------------------------
 
!---------------------------------------------------------------------- 
! local variables:                                                      

      real, dimension (size(conc_ice,1), size(conc_ice,2),  &
                       size(conc_ice,3))   ::  size_i
      real, dimension (1:NICESOLARCLDIVLS, 0:NBB) :: b
      real, dimension (1:NICESOLARCLDIVLS, 0:NBC) :: c
      real, dimension (1:NICESOLARCLDIVLS, 0:NBD) :: d

      data b     /                                           &
 .10998e-5,  .20208e-4, .1359e-3,  -.16598e-2,  .4618,      .42362e-1, &
-.26101e-7,  .96483e-5, .73453e-3,  .20933e-2,  .24471e-3,  .86425e-2, &
 .10896e-8,  .83009e-7, .28281e-5, -.13977e-5, -.27839e-5, -.75519e-4, &
-.47387e-11,-.32217e-9,-.18272e-7, -.18703e-7,  .10379e-7,  .24056e-6/

      data c     /                                            &
 2.211,      2.2151,    2.2376,    2.3012,    2.7975,    1.9655,      &
 -.10398e-2, -.77982e-3, .10293e-2, .33854e-2, .29741e-2, .20094e-1,  &
  .65199e-4,  .6375e-4,  .50842e-4, .23528e-4,-.32344e-4,-.17067e-3,  &
 -.34498e-6, -.34466e-6,-.30135e-6,-.20068e-6, .11636e-6, .50806e-6 /

      data d     /                                           & 
  .12495,    .12363,    .12117,    .11581,   -.15968e-3, .1383,       &
 -.43582e-3,-.44419e-3,-.48474e-3,-.55031e-3, .10115e-4,-.18921e-2,   &
  .14092e-4, .14038e-4, .12495e-4, .98776e-5,-.12472e-6, .1203e-4,    &
 -.69565e-7,-.68851e-7,-.62411e-7,-.50193e-7, .48667e-9,-.31698e-7 /

      real    :: a0 = -6.656e-03
      real    :: a1 =  3.686
      real    :: fgam2, fdel2

      integer :: nistart, niend
      integer :: i, j, k, ni

!----------------------------------------------------------------------
!   local variables:
!
!        b             coefficients in fu and liou expression for
!                      single scattering albedo; when second dimension
!                      has values of 0 -> 3, units are [ dimensionless,
!                      microns**(-1), microns**(-2) and microns**(-3) ]
!                      respectively.
!        c             coefficients in fu and liou expression for
!                      asymmetry factor; when second dimension
!                      has values of 0 -> 3, units are [ dimensionless,
!                      microns**(-1), microns**(-2) and microns**(-3) ]
!                      respectively.
!        d             coefficients in fu and liou expression for
!                      asymmetry factor; when second dimension
!                      has values of 0 -> 3, units are [ dimensionless, 
!                      microns**(-1), microns**(-2) and microns**(-3) ]
!                      respectively.
!        a0             parameter in fu and liou extinction formula 
!                       [ m**2 / g ]
!        a1             parameter in fu and liou extinction formula
!                       [ (m**2)*microns / g ]
!        fgam2          intermediate expression used in evaluating
!                       asymmetry factor
!        fdel2          intermediate expression used in evaluating
!                       asymmetry factor
!        nistart        first ice crystal parameterization band to be
!                       processed
!        niend          last ice crystal parameterization band to be
!                       processed
!        i,j,k,ni       do-loop indices
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the starting and ending droplet parameterization bands to
!    be processed during this call.
!--------------------------------------------------------------------
      if (present(starting_band)) then
        nistart = starting_band
      else
        nistart = 1
      endif
      if (present(ending_band)) then
        niend = ending_band
      else
        niend = NICESOLARCLDIVLS
      endif

!-----------------------------------------------------------------
!    compute scattering parameters for ice crystals. 
!-----------------------------------------------------------------
      do k=1,size(conc_ice,3)
        do j=1,size(conc_ice,2)
          do i=1,size(conc_ice,1)

            if (.not. dge_column(i,j,k)) then
!---------------------------------------------------------------------
!    bypass calculations if no crystals are present. set scattering
!    parameters to values comatible with the absence of cloud.
!-----------------------------------------------------------------
            if (conc_ice (i,j,k) == 0.0) then
              mask(i,j,k) = .false.

!--------------------------------------------------------------------
!    the ice crystal effective size (D^sub^ge in fu's paper) is limited
!    to the range of 18.6 to 130.2 microns.                     
!--------------------------------------------------------------------
            else
              mask(i,j,k) = .true.

              if (size_ice(i,j,k) < min_cld_ice_size) then           
                size_i(i,j,k) = min_cld_ice_size             
              else if(size_ice(i,j,k) > max_cld_ice_size ) then  
                size_i(i,j,k) = max_cld_ice_size       
              else
                size_i(i,j,k) = size_ice(i,j,k)
              endif

!---------------------------------------------------------------------
!     compute the scattering parameters for each of the fu spectral 
!     intervals. the extinction coefficient is converted to km**(-1).  
!---------------------------------------------------------------------
                do ni = nistart,niend
                  cldextivlice(i,j,k,ni) = 1.0E+03*       &
                         conc_ice(i,j,k)*(a0 + (a1/size_i(i,j,k))) 
                  cldssalbivlice(i,j,k,ni) = 1.0 -           &
                             (b(7-ni,0) +                    &
                              b(7-ni,1)*size_i(i,j,k) +    &
                              b(7-ni,2)*size_i(i,j,k)**2 + &
                              b(7-ni,3)*size_i(i,j,k)**3 )
                  fgam2  =                                   &
                              c(7-ni,0) +                    &
                              c(7-ni,1)*size_i(i,j,k) +    &
                              c(7-ni,2)*size_i(i,j,k)**2 + &
                              c(7-ni,3)*size_i(i,j,k)**3
                  fdel2  =                                   &
                              d(7-ni,0) +                    &
                              d(7-ni,1)*size_i(i,j,k) +    &
                              d(7-ni,2)*size_i(i,j,k)**2 + &
                              d(7-ni,3)*size_i(i,j,k)**3
                  cldasymmivlice(i,j,k,ni) =                 &
                              ((1. - fdel2)*fgam2 + 3.*fdel2)/3.
                end do
            endif
           else
             mask(i,j,k) = .false.
           endif
          end do
        end do
      end do

!------------------------------------------------------------------


end subroutine icesolar



!######################################################################
! <SUBROUTINE NAME="snowsw">
!  <OVERVIEW>
!   Subroutine to define the single scattering parameters for snow
!  </OVERVIEW>
!  <DESCRIPTION>
!   define the single scattering parameters for snow using the Fu         
!   parameterization for his spectral intervals.
! author: leo donner, gfdl, 11 Sept 98                                  
!                                                                       
! references:                                                           
!                                                                       
! fu, q., et al., (See notes from Kuo-Nan Liou, 1 Sept 98). (SNOW)      
!                                                                       
! notes: the single scattering properties for wavenumbers < 2500 cm-1   
!        are assigned the values in the first interval, since the       
!        formulation is not defined for those wavenumbers.              
!                                                                       
!        the extinction coefficient is in units of kilometer**(-1)
!  </DESCRIPTION>
!  <TEMPLATE>
!   call snowsw                                            &
!                    (conc_snow,                                    &
!                     cldextivlsnow, cldssalbivlsnow, cldasymmivlsnow)
!  </TEMPLATE>
!  <IN NAME="conc_snow" TYPE="real">
!   the snow concentration in grams / meter**3
!  </IN>
!  <OUT NAME="cldextivlsnow" TYPE="real">
!   the specified spectral values of the extinction     
!                   coefficient for snow in kilometers**(-1)
!  </OUT>
!  <OUT NAME="cldssalbivlsnow" TYPE="real">
!   the specified spectral values of the single-        
!                   scattering albedo for snow
!  </OUT>
!  <OUT NAME="cldasymmivlsnow" TYPE="real">
!   the specified spectral values of the asymmetry      
!                   factor for snow
!  </OUT>
! </SUBROUTINE>
!
subroutine snowsw (conc_snow, cldextivlsnow, cldssalbivlsnow,    &
                   cldasymmivlsnow, mask, starting_band, ending_band)      
 
!----------------------------------------------------------------------
!    subroutine snowsw defines the single scattering parameters for snow
!    flakes  using the Fu parameterization for his spectral intervals. 
!    author: leo donner, gfdl, 11 Sept 98                     
!    references:                                     
!    fu, q., et al., (See notes from Kuo-Nan Liou, 1 Sept 98). (SNOW)  
!----------------------------------------------------------------------

real, dimension (:,:,:),   intent(in)     ::  conc_snow
real, dimension (:,:,:,:), intent(out)    ::  cldextivlsnow,       &
                                              cldssalbivlsnow,     &
                                              cldasymmivlsnow
logical, dimension(:,:,:), intent(out)    ::   mask
integer,  intent(in), optional            ::   starting_band, &
                                               ending_band

!----------------------------------------------------------------------
!   intent(in) variables:                                
!                                                                       
!        conc_snow        snow concentration [ grams / meter**3 ]     
!
!  intent(out) variables:                                               
!                                                                       
!        cldextivlsnow    extinction coefficient in each spectral
!                         interval of the fu snow flake param-
!                         eterization resulting from the presence of 
!                         snow flakes [ km **(-1) ]
!        cldssalbivlsnow  single scattering albedo in each spectral
!                         interval of the fu snow flake param-
!                         eterization resulting from the presence of 
!                         snow flakes [ dimensionless ]
!        cldasymmivlsnow  asymmetry factor in each spectral
!                         interval of the fu snow flake param-
!                         eterization resulting from the presence of 
!                         snow flakes [ dimensionless ]
!
!---------------------------------------------------------------------
 
!---------------------------------------------------------------------
! local variables:                                                     
      real, dimension (NSNOWCLDIVLS)  ::  asymm, ext, ssalb
 
      data asymm / 9.6373E-01,9.8141E-01,9.7816E-01,9.6820E-01,      &
                   8.9940E-01,8.9218E-01 /
      data ext   / 8.3951E-01,8.3946E-01,8.3941E-01,8.3940E-01,      &
                   8.3940E-01,8.3939E-01 /
      data ssalb / 5.3846E-01,5.2579E-01,5.3156E-01,5.6192E-01,      &
                   9.7115E-01,9.99911E-01 /

      real          ::  conc_ref=0.5
      integer       ::  i, j, k, ni
      integer      :: nistart, niend

!---------------------------------------------------------------------
! local variables:                                                     
!
!       asymm        asymmetry factor due to snow flakes in each of the 
!                    snow spectral bands [ dimensionless ]
!       ext          extinction coefficient due to snow flakes in each
!                    of the snow spectral bands, relevant for a snow
!                    concentration of conc_ref [ km**(-1) ]
!       ssalb        single scattering albedo due to snow flakes in each
!                    of the snow flake spectral bands [ dimensionless ]
!       conc_ref     reference snow flake concentration for which the
!                    values of ext apply [ g / m**3 ]
!       i,j,k,ni     do-loop indices
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the starting and ending droplet parameterization bands to
!    be processed during this call.
!--------------------------------------------------------------------
      if (present(starting_band)) then
        nistart = starting_band
      else
        nistart = 1
      endif
      if (present(ending_band)) then
        niend = ending_band
      else
        niend = NSNOWCLDIVLS
      endif

!----------------------------------------------------------------------
      do k=1,size(conc_snow,3)
        do j=1,size(conc_snow,2)
          do i=1,size(conc_snow,1)

!-----------------------------------------------------------------
!    if no snow is present in the box, set the scattering parameters
!    to so indicate.
!-----------------------------------------------------------------
            if (conc_snow(i,j,k) == 0.0) then
              mask(i,j,k) = .false.

!---------------------------------------------------------------------
!    if snow is present, calculate the scattering parameters over each
!    of the snow spectral intervals. the extinction coefficient is 
!    in units of km**(-1).
!---------------------------------------------------------------------
            else
              mask(i,j,k) = .true.
              do ni = nistart, niend
                cldextivlsnow(i,j,k,ni) = ext(ni)*conc_snow(i,j,k)/   &
                                          conc_ref
                cldssalbivlsnow(i,j,k,ni) = ssalb(ni)
                cldasymmivlsnow(i,j,k,ni) = asymm(ni)
              end do
            endif
          end do
        end do
      end do

!--------------------------------------------------------------------
 

end subroutine snowsw


!######################################################################
! <SUBROUTINE NAME="cloud_lwpar">
!  <OVERVIEW>
!   Subroutine to determine cloud infrared emissivity
!  </OVERVIEW>
!  <DESCRIPTION>
! determine the infrared cloud emissivities for specified wavenumber    
! bands from parameterizations for absorption coefficients due to       
! cloud drops, cloud ice crystals, rain and snow. conceptually one      
! could have separate concentrations and sizes for "thin" or randomly   
! overlapped and for maximally overlapped clouds. for now, there is     
! one concentration and size, therefore the two emissivities are set    
! equal.
!  </DESCRIPTION>
!  <TEMPLATE>
!   subroutine cloud_lwpar  (nonly, nbmax, nnn,                  &
!                     size_drop, size_ice, size_rain,            &
!                     conc_drop, conc_ice, conc_rain, conc_snow, &
!                     do_dge_lw, abscoeff)
!  </TEMPLATE>
!  <IN NAME="nonly" TYPE="integer">
!   The single band for calculations.  Note that this is used
!   only in the case of a call from cloudrad_diagnostics to 
!   do isccp simulator work.  For all other calls, nonly should
!   be 0 and will have no effect on the calculations below
!  </IN>
!  <IN NAME="nbmax" TYPE="integer">
!   The number of individual bands to do calculations over. Note
!   that for normal GCM calls this will be 1.  For calls using
!   stochastic clouds with or without the isccp simulator this will
!   be equal to the number of longwave bands
!  </IN>
!  <IN NAME="nnn" TYPE="integer">
!   This integer controls which cloud state to access for radiation
!   calculations.  For normal GCM applications this will be 1. For
!   Full Independent Column Approximation calculations with stochast-
!   ic clouds this will be the profile number being accessed. 
!  </IN>
!  <IN NAME="conc_drop" TYPE="real">
!   total cloud droplet concentration
!  </IN>
!  <IN NAME="conc_ice" TYPE="real">
!   ice cloud droplet concentration
!  </IN>
!  <IN NAME="conc_rain" TYPE="real">
!   rain droplet concetration
!  </IN>
!  <IN NAME="conc_snow" TYPE="real">
!   snow concentration
!  </IN>
!  <IN NAME="size_drop" TYPE="real">
!   cloud droplet size distribution
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   ice droplet size distribution
!  </IN>
!  <IN NAME="size_rain" TYPE="real">
!   rain droplet size distribution
!  </IN>
!  <OUT NAME="abscoeff" TYPE="real">
!   cloud absorption coefficient
!  </OUT>
!  <IN NAME="do_dge_lw" TYPE="logical">
!   flag for using dge longwave parameterization
!  </IN>
! </SUBROUTINE>
subroutine cloud_lwpar (nonly, nbmax, nnn, size_drop, size_ice,  &
                        size_rain, conc_drop, conc_ice, conc_rain,  &
                        conc_snow, do_dge_lw, dge_column, isccp_call, &
                        abscoeff)
 
!----------------------------------------------------------------------
!    cloud_lwpar determines the absorption coefficients due to cloud 
!    drops, cloud ice crystals, rain and snow over appropriate spectral
!    intervals and then maps these into the appropriate lw radiation
!    bands. the contributions from each of the water species are then
!    consolidated into a single absorption coefficient which is output
!    to the calling routine.
!----------------------------------------------------------------------

integer,                   intent(in)   ::   nonly, nbmax, nnn
real, dimension (:,:,:,:), intent(in)   ::   size_drop, size_ice,    &
                                             conc_drop, conc_ice
logical, dimension (:,:,:,:), intent(in)   :: dge_column
real, dimension (:,:,:),   intent(in)   ::   size_rain, conc_rain,   &
                                             conc_snow
logical,                   intent(in)   ::   do_dge_lw
logical,                   intent(in)   ::   isccp_call
real, dimension (:,:,:,:), intent(out)  ::   abscoeff 
 
!
!----------------------------------------------------------------------
! intent(in) variables:                                             
!                                                                   
!       size_drop    cloud drop effective diameter [ microns ]          
!       size_ice     ice crystal effective size [ microns ]    
!       size_rain    rain drop effective diameter [ microns ] 
!       conc_drop    cloud drop liquid water concentration 
!                    [ grams / meter**3 ]                               
!       conc_ice     ice water concentation [ grams / meter**3 ] 
!       conc_rain    rain drop water concentration [ grams / meter**3 ] 
!       conc_snow    snow concentration [ grams / meter**3 ]  
!       do_dge_lw    if true, use parameterization using generalized 
!                    effective size developed by Fu et al (1998); other-
!                    wise use parameterization by Fu et al using 
!                    effective size.
!                                    
! intent(out) variable:                                             
!                                                                   
!       abscoeff     infrared absorption coefficient. [ km**(-1) ]
!                                                                   
!----------------------------------------------------------------------
 
!----------------------------------------------------------------------
! local variables:                                                  

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3), N_EMISS_BDS)  ::    &
             cldextbndrainlw, cldssalbbndrainlw, cldasymmbndrainlw, &
             cldextbndsnowlw, cldssalbbndsnowlw, cldasymmbndsnowlw, &
             cldextbndicelw,  cldssalbbndicelw,  cldasymmbndicelw,    &
             cldextbnddroplw
      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3)             )  ::    &
             cldext, cldssa, cldasy, cldext2, cldssa2, cldasy2
      logical, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3)             )  ::    &
                 maskf, maski
      

      integer  :: i,j,k,n

!----------------------------------------------------------------------
! local variables:                                                  
!
!       cldextbndrainlw    values of the extinction coefficient for 
!                          rain water over the wavenumber bands used by 
!                          the radiation code [ km**(-1) ]
!       cldssalbbndrainlw  values of the single-scattering albedo for 
!                          rain water over the wavenumber bands used by
!                          the radiation code  [ dimensionless ] 
!       cldasymmbndrainlw  values of the asymmetry factor for rain water
!                          over the wavenumber bands used by the 
!                          radiation code  
!       cldextbndsnowlw    values of the extinction coefficient for 
!                          snow flakes over the wavenumber bands used by
!                          the radiation code [ km**(-1) ]
!       cldssalbbndsnowlw  values of the single-scattering albedo for 
!                          snow flakes over the wavenumber bands used by
!                          the radiation code  [ dimensionless ] 
!       cldasymmbndsnowlw  values of the asymmetry factor for snow
!                          flakes over the wavenumber bands used by the 
!                          radiation code  
!       cldextbndicelw     values of the extinction coefficient for 
!                          ice crystals over the wavenumber bands used 
!                          by the radiation code [ km**(-1) ]
!       cldssalbbndicelw   values of the single-scattering albedo for 
!                          ice crystals over the wavenumber bands used 
!                          by the radiation code  [ dimensionless ] 
!       cldasymmbndicelw   values of the asymmetry factor for ice 
!                          crystals over the wavenumber bands used by 
!                          the radiation code  
!       cldextbnddroplw    values of the extinction coefficient for 
!                          cloud droplets over the wavenumber bands used
!                          by the radiation code [ km**(-1) ]
!       n                  do-loop index
!                                                                   
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!    call furainlw to compute the extinction coefficient, single 
!    scattering coefficient and asymmetry parameter for rain.
!-------------------------------------------------------------------
      do n=1,Cldrad_control%nlwcldb
        if (nonly == 0 .or. n == nonly) then
          call furainlw (n, conc_rain, cldextbndrainlw(:,:,:,n),   &
                         cldssalbbndrainlw(:,:,:,n), &
                         cldasymmbndrainlw(:,:,:,n))
        endif
      end do

!----------------------------------------------------------------------
!    call fusnowlw to compute the extinction coefficient, single 
!    scattering coefficient and asymmetry parameter for snow.
!----------------------------------------------------------------------
      do n=1,Cldrad_control%nlwcldb
        if (nonly == 0 .or. n == nonly) then
          call fusnowlw (n, conc_snow, cldextbndsnowlw(:,:,:,n),   &
                         cldssalbbndsnowlw(:,:,:,n), &
                         cldasymmbndsnowlw(:,:,:,n))
        endif
      end do

!----------------------------------------------------------------------
!
!  NOTE THE FOLLOWING LOGICAL TO THE LOOPS BELOW
!
!        do n=1,Cldrad_control%nlwcldb
!             if (nbmax==1) then
!                  call cliqlw(conc_drop(:,:,:,nnn).....)
!             else
!                  call slingo(conc_drop(:,:,:,n),....)
!             end if
!
!        enddo           
!             
!        Note that nbmax = 1 in the following cases:
!
!                 (a) standard GCM applications which do not use
!                     McICA  
!                 (b) Full Independent Column Approximation 
!                     calculations
!
!        Note that nbmax = Cldrad_control%nlwcldb in the following cases
!               
!                 (c) McICA calculations where n = the cloud 
!                     profile being used
!                 (d) ISCCP simulator calls from cloudrad_diagnostics
!                     where "nonly" will be used
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    call cliqlw to compute the extinction coefficient for cloud drops.
!----------------------------------------------------------------------
      do n=1,Cldrad_control%nlwcldb
        if (nbmax == 1) then
          call cliqlw (conc_drop(:,:,:,nnn), cldextbnddroplw(:,:,:,n))
        else
          if (nonly.eq.0   .or. nonly.eq.n ) then            
            call cliqlw (conc_drop(:,:,:,n), cldextbnddroplw(:,:,:,n))
          endif 
        endif 
      end do
 
!----------------------------------------------------------------------
!    compute the extinction coefficient, single scattering coefficient
!    and asymmetry parameter for cloud ice crystals. if the generalized
!    effectiuve radius parameterization is to be used call subroutine 
!    el_dge; if it is not, call subroutine el.
!----------------------------------------------------------------------
      if (isccp_call) then
        do n=1,Cldrad_control%nlwcldb
          if (nbmax == 1) then
            call el_dge (n, conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn),  &
                          
                  dge_column(:,:,:,nnn), maskf, cldext, cldssa, cldasy)
           else
             if (nonly.eq.0   .or. nonly.eq.n ) then            
             call el_dge (n, conc_ice(:,:,:,n), size_ice(:,:,:,n),  &
                   dge_column(:,:,:,n), maskf, cldext, cldssa, cldasy)
             end if ! for nonly
           endif ! for nbmax == 1
          if (nbmax == 1) then
            call el (n, conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn),  &
               dge_column(:,:,:,nnn), maski, cldext2, cldssa2, cldasy2)
          else
            if (nonly.eq.0   .or. nonly.eq.n ) then            
            call el (n, conc_ice(:,:,:,n), size_ice(:,:,:,n),  &
                 dge_column(:,:,:,n), maski, cldext2, cldssa2, cldasy2)
            endif ! for nonly 
          endif ! for nbmax == 1
 
              do k=1, size(conc_drop,3)
                do j=1, size(conc_drop    ,2)
                  do i=1, size(conc_drop,1)
                    if (maskf(i,j,k)) then
                     cldextbndicelw(i,j,k,n) = cldext(i,j,k)
                     cldssalbbndicelw(i,j,k,n) = cldssa(i,j,k)
!                    cldasymmbndicelw(i,j,k,n) = cldasy(i,j,k)
                    else if (maski(i,j,k)) then
                     cldextbndicelw(i,j,k,n) = cldext2(i,j,k)
                     cldssalbbndicelw(i,j,k,n) = cldssa2(i,j,k)
!                    cldasymmbndicelw(i,j,k,n) = cldasy2(i,j,k)
                    else
                     cldextbndicelw(i,j,k,n) = 0.0             
                     cldssalbbndicelw(i,j,k,n) = 0.0              
!                    cldasymmbndicelw(i,j,k,n) = cldasy2(i,j,k)
                    endif
                  end do
                  end do
                  end do
        end do

   else    ! (isccp_call)
      if (do_dge_lw) then
          maski = .false.
        do n=1,Cldrad_control%nlwcldb
          maski = .false.
          if (nbmax == 1) then
            call el_dge (n, conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn),  &
                          
                         dge_column(:,:,:,nnn), maskf, &
                         cldextbndicelw(:,:,:,n),     &
                         cldssalbbndicelw(:,:,:,n),   &
                         cldasymmbndicelw(:,:,:,n))
           else
             if (nonly.eq.0   .or. nonly.eq.n ) then            
             call el_dge (n, conc_ice(:,:,:,n), size_ice(:,:,:,n),  &
                         dge_column(:,:,:,n), maskf, &
                          cldextbndicelw(:,:,:,n),     &
                          cldssalbbndicelw(:,:,:,n),    &
                          cldasymmbndicelw(:,:,:,n))
             end if ! for nonly
           endif ! for nbmax == 1
         end do
      else
          maskf = .false.
        do n=1,Cldrad_control%nlwcldb
          if (nbmax == 1) then
            call el (n, conc_ice(:,:,:,nnn), size_ice(:,:,:,nnn),  &
                         dge_column(:,:,:,nnn), maski,  &
                     cldextbndicelw(:,:,:,n),     &
                     cldssalbbndicelw(:,:,:,n),    &
                     cldasymmbndicelw(:,:,:,n))
          else
            if (nonly.eq.0   .or. nonly.eq.n ) then            
            call el (n, conc_ice(:,:,:,n), size_ice(:,:,:,n),  &
                         dge_column(:,:,:,n), maski,  &
                     cldextbndicelw(:,:,:,n),     &
                     cldssalbbndicelw(:,:,:,n),  &
                     cldasymmbndicelw(:,:,:,n))
            endif ! for nonly 
          endif ! for nbmax == 1
        end do
      endif
 
    endif   ! (isccp_call)

!----------------------------------------------------------------------
!    compute absorption coefficient for each species as the product of 
!    the extinction coefficient and (1 - single scattering albedo). 
!    the total absorption coefficient is the sum of the species 
!    absorption coefficients. 
!----------------------------------------------------------------------
      if (nonly == 0) then
        do n=1,Cldrad_control%nlwcldb
          abscoeff(:,:,:,n) = cldextbndicelw(:,:,:,n)*       &
                              (1.0E+00 - cldssalbbndicelw(:,:,:,n)) +  &
                              cldextbnddroplw(:,:,:,n)              +  &
                              cldextbndsnowlw(:,:,:,n)*               &
                              (1.0E+00 - cldssalbbndsnowlw(:,:,:,n)) + &
                              cldextbndrainlw(:,:,:,n)*                &
                              (1.0E+00 - cldssalbbndrainlw(:,:,:,n))
        end do
      else 
        abscoeff(:,:,:,nonly) = cldextbndicelw(:,:,:,nonly)*       &
                           (1.0E+00 - cldssalbbndicelw(:,:,:,nonly)) + &
                           cldextbnddroplw(:,:,:,nonly)          +    &
                           cldextbndsnowlw(:,:,:,nonly)*           &
                           (1.0E+00 - cldssalbbndsnowlw(:,:,:,nonly)) +&
                           cldextbndrainlw(:,:,:,nonly)*           &
                           (1.0E+00 - cldssalbbndrainlw(:,:,:,nonly))
      endif
 
!---------------------------------------------------------------------


end subroutine cloud_lwpar



!######################################################################
! <SUBROUTINE NAME="cloud_lwem_oneband">
!  <OVERVIEW>
!   Subroutine to determine a single broadband cloud infrared emissivity
!  </OVERVIEW>
!  <DESCRIPTION>
! determine the infrared cloud emissivities for a single broadband
! from parameterizations for absorption coefficients due to
! cloud drops and cloud ice crystals. the parameterization comes from
! from the 5-band formulation given by Ebert and Curry (1992,
! J. Geophys. Res., vol. 97, pp. 3831-3836). S. Klein  derived the
! coefficients for the 1-band version used here.
!  </DESCRIPTION>
!  <TEMPLATE>
!   subroutine cloud_lwem_oneband                              &
!                    (conc_drop, conc_ice, size_drop, size_ice, &
!                     abscoeff)
!  </TEMPLATE>
!  <IN NAME="conc_drop" TYPE="real">
!   total cloud droplet concentration
!  </IN>
!  <IN NAME="conc_ice" TYPE="real">
!   ice cloud droplet concentration
!  </IN>
!  <IN NAME="size_drop" TYPE="real">
!   cloud droplet size distribution
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   ice droplet size distribution
!  </IN>
!  <OUT NAME="abscoeff" TYPE="real">
!   cloud absorption coefficient
!  </OUT>
! </SUBROUTINE>
 subroutine cloud_lwem_oneband (conc_drop, conc_ice, size_drop,    &
                                size_ice, abscoeff)

!----------------------------------------------------------------------
!    subroutine cloud_lwem_oneband determines the infrared cloud emis-
!    sivities for a single broadband from parameterizations for absor-
!    ption coefficients due to cloud drops and cloud ice crystals. the 
!    parameterization comes from the 5-band formulation given by Ebert 
!    and Curry (1992, J. Geophys. Res., vol. 97, pp. 3831-3836). 
!    S. Klein  derived the coefficients for the 1-band version used 
!    here.
!----------------------------------------------------------------------

real, dimension (:,:,:),   intent(in)     ::   conc_drop, conc_ice, &
                                               size_drop, size_ice
!real, dimension (:,:,:,:), intent(out)    ::   abscoeff         
real, dimension (:,:,:), intent(out)    ::   abscoeff         

!----------------------------------------------------------------------
!
!   intent(in) variables:
!
!      conc_drop      cloud drop liquid water concentration 
!                     [ grams / m**3 ]                           
!      conc_ice       ice water concentation 
!                     [ grams / m**3 ]                           
!      size_drop      cloud drop effective diameter [ microns ]
!      size_ice       ice crystal effective size [ microns ]
!
!   intent(out) variables:
!
!      abscoeff       one-band infrared absorption coefficient.
!                     [ kilometer**(-1) ]
!
!----------------------------------------------------------------------
 

!----------------------------------------------------------------------
!   local variables:

      real, dimension (size(conc_drop,1), size(conc_drop,2), &
                       size(conc_drop,3))                    ::   &
                                     reff_ice, k_liq, k_ice, size_i
      integer  :: i, j, k
 
!---------------------------------------------------------------------
!    local variables:
!
!         reff_ice       effective diameter of ice crystals. [ microns ]
!         k_liq          liquid cloud mass absorption coefficient for 
!                        longwave portion of spectrum 
!                        [ m**2 / kg condensate ]
!         k_ice          ice cloud mass absorption coefficient for 
!                        longwave portion of spectrum 
!                        [ m**2 / kg condensate ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    reff_ice is the effective diameter obtained using an expression 
!    provided by S. Klein. 
!---------------------------------------------------------------------
      
      do k=1,size(conc_ice,3)
        do j=1,size(conc_ice,2)
          do i=1,size(conc_ice,1)
            if (size_ice(i,j,k) < min_cld_ice_size) then         
              size_i(i,j,k) = min_cld_ice_size             
            else if(size_ice(i,j,k) > max_cld_ice_size) then    
              size_i(i,j,k) = max_cld_ice_size       
            else
              size_i(i,j,k) = size_ice(i,j,k)
            endif
          end do
         end do
      end do
      reff_ice = ((0.1033741*size_i*size_i +      &
                   0.2115169*(size_i**2.272))**0.5)
  
!---------------------------------------------------------------------
!    define the mass absorption coefficients for liquid and ice
!    clouds for the longwave spectrum.
!---------------------------------------------------------------------
      k_liq(:,:,:) = 140.
      where (size_i(:,:,:) /= 0.0) 
        k_ice(:,:,:) = 4.83591 + 1758.511/reff_ice(:,:,:)
      elsewhere
        k_ice(:,:,:) = 0.0                                  
      end where

!--------------------------------------------------------------------- 
!    compute the absorption coefficient. the division by the diffusivity
!    coefficient (diffac) is due to the assumption that the effect of 
!    angular integration is accounted for on the values of k_liq and 
!    k_ice. since the dimensions of k_liq and k_ice are [m**2/Kg] 
!    and conc_ice and conc_drop is in [g/m**3] the unit conversion
!    factor to obtain [km**-1] is unity.
!--------------------------------------------------------------------- 
 
!      abscoeff(:,:,:,1) = ( k_liq(:,:,:)*conc_drop(:,:,:) +       &
       abscoeff(:,:,:  ) = ( k_liq(:,:,:)*conc_drop(:,:,:) +       &
                             k_ice(:,:,:)*conc_ice (:,:,:))/diffac
      
!---------------------------------------------------------------------



end subroutine cloud_lwem_oneband




!######################################################################
! <SUBROUTINE NAME="el">
!  <OVERVIEW>
!   Subroutine to calculates total optical depth and scattering 
!   optical depth
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine calculates total optical depth and scattering 
!     optical depth
!     for infrared radiation using Fu and Liou (1993,
!     JAS). To be used for crystal effective sizes from 20 to 130 um.
!     limits changed to 18.6 to 130.2 um on 2 April 1999 to
!     match shortwave limits.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call el  (conc_ice    , size_ice      ,                   &
!                cldextbndicelw, cldssalbbndicelw, cldasymmbndicelw)
!  </TEMPLATE>
!  <IN NAME="conc_ice" TYPE="real">
!   the ice crystal concentation in grams / meter**3
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   the ice crystal effective size in microns
!  </IN>
!  <OUT NAME="cldextbndicelw" TYPE="real">
!   the specified values of the extinction          
!                 coefficient for ice particles in kilometers**(-1)
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldssalbbndicelw" TYPE="real">
!   the specified values of the single-           
!                  scattering albedo for ice particles             
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldasymmbndicelw" TYPE="real">
!   the specified values of the asymmetry         
!                  factor for ice particles                        
!                 over wavenumber bands used by the radiation code
!  </OUT>
! </SUBROUTINE>
!
subroutine el  (nb, conc_ice, size_ice, dge_column, mask,  &
                cldextbndicelw, cldssalbbndicelw, cldasymmbndicelw)
 
!-----------------------------------------------------------------------
!    subroutine el calculates total optical depth and scattering optical
!    depth for infrared radiation using Fu and Liou (1993, JAS).  the
!    parameterization will be used for crystal effective sizes between
!    18.6 and 130.2 microns.
!    Leo Donner, GFDL, 29 Aug 98
!-----------------------------------------------------------------------

integer,                 intent(in)    ::  nb
real, dimension (:,:,:),   intent(in)    ::  conc_ice, size_ice
logical, dimension (:,:,:),   intent(in )    ::  dge_column        
logical, dimension (:,:,:),   intent(out)    ::  mask              
real, dimension (:,:,:  ), intent(out)   ::  cldextbndicelw,   &
                                             cldssalbbndicelw,    &
                                             cldasymmbndicelw

!----------------------------------------------------------------------
!  intent(in) variables:                                            
!                                                                  
!       conc_ice           ice crystal concentation [ grams / meter**3 ]
!       size_ice           ice crystal effective size [ microns ]      
!                                                                  
!  intent(out) variables:                                           
!                                                                  
!       cldextbndicelw     values of the extinction coefficient for 
!                          ice crystals over the wavenumber bands used 
!                          by the radiation code [ km**(-1) ]
!       cldssalbbndicelw   values of the single-scattering albedo for 
!                          ice crystals over the wavenumber bands used 
!                          by the radiation code  [ dimensionless ] 
!       cldasymmbndicelw   values of the asymmetry factor for ice 
!                          crystals over the wavenumber bands used by 
!                          the radiation code  
!
!--------------------------------------------------------------------- 
 
                                                                   
!---------------------------------------------------------------------
! local variables:                                                   
      real, dimension (size(conc_ice,1), size(conc_ice,2), &
                       size(conc_ice,3))                    ::   &
                                                    size_i
      integer     :: n
      integer     :: i, j,k
      real  ::          cldextivlice, cldssalbivlice

      real     ::               sumext, sumssalb

      real, dimension (NBFL)  ::   a0, a1, a2
 
      data a0 /                                                      &
          -7.752E-03,  -1.741E-02,  -1.704E-02,  -1.151E-02,         &
          -1.026E-02,  -8.294E-03,  -1.153E-02,  -9.609E-03,         &
          -9.061E-03,  -8.441E-03,  -8.088E-03,  -7.770E-03/
      data a1 /                                                      &
           4.624,   5.541,   4.830,   4.182,   4.105,   3.925,       &
           4.109,   3.768,   3.741,   3.715,   3.717,   3.734/
      data a2 /                                                      &
         -42.010, -58.420,  16.270,  31.130,  16.360,   1.315,       &
          17.320,  34.110,  26.480,  19.480,  17.170,  11.850/

      real, dimension (1:NBFL,0:NBB)     ::   b

      data (b(n,0),n=1,NBFL) /                                     &
          0.8079,   0.3964,   0.1028,   0.3254,   0.5207,   0.5631,  &
          0.2307,   0.2037,   0.3105,   0.3908,   0.3014,   0.1996/
      data (b(n,1),n=1,NBFL) /                                     &
         -0.7004E-02, -0.3155E-02,  0.5019E-02,  0.3434E-02,         &
         -0.9778E-03, -0.1434E-02,  0.3830E-02,  0.4247E-02,         &
          0.2603E-02,  0.1272E-02,  0.2639E-02,  0.3780E-02/
      data (b(n,2),n=1,NBFL) /                                     &
          0.5209E-04,  0.6417E-04, -0.2024E-04, -0.3081E-04,         &
          0.3725E-05,  0.6298E-05, -0.1616E-04, -0.1810E-04,         &
          -0.1139E-04, -0.5564E-05, -0.1116E-04, -0.1491E-04/
      data (b(n,3),n=1,NBFL) /                                     &
         -0.1425E-06, -0.2979E-06,  0.0000E+00,  0.9143E-07,         &
          0.0000E+00,  0.0000E+00,  0.0000E+00,  0.0000E+00,         &
          0.0000E+00,  0.0000E+00,  0.0000E+00,  0.0000E+00/


!---------------------------------------------------------------------
!   local variables:
!
!      cldextivlice     cloud extinction coefficient over the spectral
!                       intervals relevant to fu and liou (1993) ice 
!                       crystals. 
!                       [ km**(-1)]
!      cldssalbivlice   cloud single scattering albedo over the spectral
!                       intervals relevant to fu and liou (1993) ice 
!                       crystals. 
!                       [ non-dimensional ]
!      cldasymmivlice   cloud asymmetry factor over the spectral
!                       intervals relevant to fu and liou (1993) ice 
!                       crystals. not currently used.
!                       [ non-dimensional ]
!      sumext           weighted sum of extinction coefficient over fu 
!                       bands to produce value for lw radiation bands
!                       [ kilometers**(-1) ]
!      sumssalb         sum of single scattering albedo over fu bands 
!                       to produce value for lw radiation bands 
!                       [ dimensionless ]
!      a0,a1,a2         empirical coefficients for extinction 
!                       coefficient parameterization
!      b                empirical coefficients for single scattering 
!                       albedo parameterization
!      n,ni             do-loop indices
!
!---------------------------------------------------------------------
      do k=1,size(conc_ice,3)
        do j=1,size(conc_ice,2)
          do i=1,size(conc_ice,1)
            if (size_ice(i,j,k) < min_cld_ice_size) then        
              size_i(i,j,k) = min_cld_ice_size             
            else if(size_ice(i,j,k) > max_cld_ice_size) then    
              size_i(i,j,k) = max_cld_ice_size       
            else
              size_i(i,j,k) = size_ice(i,j,k)
            endif
          end do
         end do
      end do

      do k=1, size(conc_ice,3)
        do j=1, size(conc_ice,2)
          do i=1, size(conc_ice,1)
            if ( .not. dge_column(i,j,k)) then
            sumext = 0.
            sumssalb = 0.
            if (conc_ice(i,j,k) /= 0.0) then

              mask(i,j,k) = .true.
!-----------------------------------------------------------------------
!    calculate extinction coefficient [ km**(-1) ] over the wavenumber
!    bands of the Fu-Liou parameterization (not the radiation code
!    wavenumber bands).
!-----------------------------------------------------------------------
              do n=1,NBFL                                               
                cldextivlice  = 1.0E+03*conc_ice(i,j,k)*        &
                                (a0(n) +                              &
                                 a1(n)/size_i(i,j,k) +              &
                                 a2(n)/size_i(i,j,k)**2)

!-----------------------------------------------------------------------
!    calculate single-scattering albedo and asymmetry parameter.
!    the asymmetry parameter is not currently used in the infrared 
!    code. therefore its calculation is commented out.
!-----------------------------------------------------------------------
                cldssalbivlice  = 1.0E+00 -                           &
                                  (b(n,0) +                           &
                                   b(n,1)*size_i(i,j,k) +           &
                                   b(n,2)*size_i(i,j,k)**2 +        &
                                   b(n,3)*size_i(i,j,k)**3)
 
!-----------------------------------------------------------------------
!    use the band weighting factors computed in microphys_rad_init
!    to define the radiation band values for the scattering parameters.
!-----------------------------------------------------------------------
                sumext    = sumext + cldextivlice*fulwwts(nb,n )
                sumssalb  = sumssalb + cldssalbivlice*fulwwts(nb,n )
              end do
            else 
              mask(i,j,k) = .false.
        cldextbndicelw(i,j,k) = 0.0        
        cldssalbbndicelw(i,j,k) = 0.0          
            endif
            cldextbndicelw(i,j,k)   = sumext       
            cldssalbbndicelw(i,j,k) = sumssalb       
             else
                mask(i,j,k) = .false.
            cldextbndicelw(i,j,k)   = 0.0          
            cldssalbbndicelw(i,j,k) = 0.0            
             endif
          end do
        end do
      end do

!--------------------------------------------------------------------
 


end subroutine el




!#####################################################################
! <SUBROUTINE NAME="el_dge">
!  <OVERVIEW>
!   Subroutine to calculate total optical depth and scattering optical
!   depth in infrared.
!  </OVERVIEW>
!  <DESCRIPTION>
!   calculates total optical depth and scattering optical depth
!     for infrared radiation using Fu et al (J. Clim., 11,2223 (1998)).
!     To be used for crystal generalized effective diameters from 
!     18.6 to 130.2 um to match shortwave limits.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call el_dge( conc_ice    , size_ice      ,                &
!                cldextbndicelw, cldssalbbndicelw, cldasymmbndicelw)
!  </TEMPLATE>
!  <IN NAME="conc_ice" TYPE="real">
!   the ice crystal concentation in grams / meter**3
!  </IN>
!  <IN NAME="size_ice" TYPE="real">
!   the ice crystal effective size in microns
!  </IN>
!  <OUT NAME="cldextbndicelw" TYPE="real">
!   the specified values of the extinction          
!                 coefficient for ice particles in kilometers**(-1)
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldssalbbndicelw" TYPE="real">
!   the specified values of the single-           
!                  scattering albedo for ice particles             
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldasymmbndicelw" TYPE="real">
!   the specified values of the asymmetry         
!                  factor for ice particles                        
!                 over wavenumber bands used by the radiation code
!  </OUT>
! </SUBROUTINE>
!  
 
subroutine el_dge (nb, conc_ice, size_ice, dge_column, mask, &
                   cldextbndicelw, cldssalbbndicelw, cldasymmbndicelw)
 
!-----------------------------------------------------------------------
!    subroutine el_dge calculates the total optical depth and scattering
!    optical depth for infrared radiation using Fu et al (J. Clim., 11,
!    2223 (1998)). this parameterization will be used for crystal 
!    generalized effective diameters from 18.6 to 130.2 um to match 
!    shortwave limits.
!    Leo Donner, GFDL, 29 Aug 98
!    Dan Schwarzkopf, GFDL 31 July 2001
!-----------------------------------------------------------------------

integer,                   intent(in)    ::  nb
real, dimension (:,:,:),   intent(in)    ::  conc_ice, size_ice
logical, dimension (:,:,:),   intent(in)    ::  dge_column
logical, dimension (:,:,:),   intent(out)    ::  mask       
real, dimension (:,:,:  ), intent(out)   ::  cldextbndicelw,   &
                                             cldssalbbndicelw,    &
                                             cldasymmbndicelw

!----------------------------------------------------------------------
!   intent(in) variables:                                            
!                                                                  
!       conc_ice           ice crystal concentation [ grams / meter**3 ]
!       size_ice           ice crystal effective size [ microns ]      
!                                                                  
!  intent(out) variables:                                           
!                                                                  
!       cldextbndicelw     values of the extinction coefficient for 
!                          ice crystals over the wavenumber bands used 
!                          by the radiation code [ km**(-1) ]
!       cldssalbbndicelw   values of the single-scattering albedo for 
!                          ice crystals over the wavenumber bands used 
!                          by the radiation code  [ dimensionless ] 
!       cldasymmbndicelw   values of the asymmetry factor for ice 
!                          crystals over the wavenumber bands used by 
!                          the radiation code  
!
!--------------------------------------------------------------------- 
 
!---------------------------------------------------------------------
!  local variables:                                                   
      real, dimension (size(conc_ice,1), size(conc_ice,2), &
                       size(conc_ice,3))                    ::   &
                                                    size_i
      integer     :: n, m
      integer     :: i,j,k
 
      real                        ::    cldextivlice, cldabsivlice, &
                                        cldssalbivlice

      real    ::        sumext, sumssalb
      real    ::        fw1,fw2,fw3,fw4

      real, dimension (NBFL)  ::   a0, a1, a2
 
      data a0 /                                                       &
           4.919685E-03,  3.325756E-03, -1.334860E-02, -9.524174E-03, &
          -4.159424E-03, -1.691632E-03, -8.372696E-03, -8.178608E-03, &
          -4.936610E-03, -3.034573E-03, -2.465236E-03, -2.308881E-03/
      data a1 /                                                     &
           2.327741, 2.601360, 4.043808, 3.587742, 3.047325, 2.765756, &
           3.455018, 3.401245, 3.087764, 2.900043, 2.833187, 2.814002  /
      data a2 /                                                    &
          -1.390858E+01, -1.909602E+01, -2.171029E+01, -1.068895E+01, &
          -5.061568E+00, -8.331033E+00, -1.516692E+01, -8.812820E+00, &
          -3.884262E+00, -1.849911E+00, -4.227573E-01,  1.072211E+00/

      real, dimension (1:NBFL,0:NBB)     ::   b
      data (b(n,0),n=1,NBFL) /                                     &
          8.869787E-01,  2.005578E-01,  3.003701E-01,  9.551440E-01, &
          1.466481E+00,  1.195515E+00,  5.409536E-01,  5.874323E-01, &
          7.152274E-01,  8.862434E-01,  7.428957E-01,  4.346482E-01/
      data (b(n,1),n=1,NBFL) /                                     &
          2.118409E-02,  2.132614E-02,  2.051529E-02,  1.309792E-02, &
         -2.129226E-03,  3.350616E-03,  1.949649E-02,  1.876628E-02, &
          1.621734E-02,  1.226538E-02,  1.279601E-02,  1.721457E-02/
      data (b(n,2),n=1,NBFL) /                                     &
         -2.781429E-04, -1.751052E-04, -1.931684E-04, -1.793694E-04, &
         -1.361630E-05, -5.266996E-05, -2.050908E-04, -2.045834E-04, &
         -1.868544E-04, -1.523076E-04, -1.391803E-04, -1.623227E-04/
      data (b(n,3),n=1,NBFL) /                                     &
          1.094562E-06,  5.355885E-07,  6.583031E-07,  7.313392E-07, &
          1.193649E-07,  2.233377E-07,  7.364680E-07,  7.510080E-07, &
          7.078738E-07,  6.000892E-07,  5.180104E-07,  5.561523E-07/


!+yim small dge
      real, dimension (NBA2,NBFL)     ::   aa
      real, dimension (NBB2,NBFL)     ::   bb
 
        data aa / &
      -2.005187e+00, 1.887870e+00, -2.394987e-01, 1.226004e-02, &
      -2.176747e-04, &
      -1.221428e+00, 1.190519e+00, -1.081918e-01, 3.207774e-03, &
      -7.790185e-06, &
      -5.522210e-01, 5.556264e-01, 1.350808e-02, -5.182503e-03, &
       1.854760e-04, &
      -2.411192e-01, 2.109769e-01, 7.588264e-02, -9.103300e-03, &
       2.678349e-04, &
      -1.485194e-02, 4.630892e-03, 8.989527e-02, -8.569112e-03, &
       2.290338e-04, &
       4.292661e-02, -7.619363e-04, 5.089112e-02, -4.101744e-03, &
       9.917537e-05, &
      -1.257657e-03, 3.840350e-01, -2.336758e-02, 5.263245e-04, &
       9.536367e-07, &
      -2.482977e-01, 5.149985e-01, -1.086854e-02, -1.909389e-03, &
       8.220600e-05, &
       1.130811e-01, -7.663294e-02, 9.961269e-02, -8.920452e-03, &
       2.325299e-04, &
       1.477471e-01, -1.276555e-01, 5.889066e-02, -3.637540e-03, &
       7.242738e-05, &
       2.778228e-02, 9.410452e-03, 7.771632e-03, -1.847559e-05, &
      -7.178001e-06, &
       2.954018e-03, 1.254725e-01, -3.265442e-03, 2.270727e-04, &
      -6.365789e-06 /
        data bb / &
      -8.768658e-03, 8.493330e-02, -3.632126e-03, 6.987413e-05, &
       2.703965e-07, &
      -7.762272e-03, 1.653825e-01, -1.242696e-02, 4.813596e-04, &
      -6.987702e-06, &
      -1.103846e-02, 1.880946e-01, -1.320780e-02, 4.530029e-04, &
      -5.384886e-06, &
      -1.240034e-02, 1.353184e-01, -6.773254e-03, 1.353446e-04, &
       4.783046e-07, &
      -9.834148e-03, 1.045283e-01, -3.714625e-03, 9.185834e-06, &
       2.434297e-06, &
      -4.989783e-03, 9.761852e-02, -3.464011e-03, 1.681863e-05, &
       1.990612e-06, &
       5.524896e-02, 3.828618e-01, -4.868927e-02, 2.788080e-03, &
      -5.893696e-05, &
      -1.102297e-01, 4.983548e-01, -5.947312e-02, 3.147713e-03, &
      -6.196981e-05, &
      -3.705134e-02, 1.612865e-01, -4.132244e-03, -2.863781e-04, &
       1.374847e-05, &
       5.730367e-03, 3.433887e-02, 3.147511e-03, -3.044807e-04, &
       7.929481e-06, &
       3.126666e-03, 3.533685e-02, 5.299923e-04, -6.735890e-05, &
       1.687872e-06, &
       9.549627e-03, 1.140347e-01, 1.223725e-03, -4.282989e-04, &
       1.343652e-05 /



!---------------------------------------------------------------------
!   local variables:
!
!      cldextivlice     cloud extinction coefficient over the spectral
!                       intervals relevant to fu and liou (1998) ice 
!                       crystals. 
!                       [ km**(-1)]
!      cldabsivlice     absorption coefficient over the spectral
!                       intervals relevant to fu and liou (1998) ice 
!                       crystals. 
!                       [ km**(-1)]
!      cldssalbivlice   cloud single scattering albedo over the spectral
!                       intervals relevant to fu and liou (1998) ice 
!                       crystals. 
!                       [ non-dimensional ]
!      cldasymmivlice   cloud asymmetry factor over the spectral
!                       intervals relevant to fu and liou (1998) ice 
!                       crystals. not currently used.
!                       [ non-dimensional ]
!      sumext           weighted sum of extinction coefficient over fu 
!                       bands to produce value for lw radiation bands
!                       [ kilometers**(-1) ]
!      sumssalb         sum of single scattering albedo over fu bands 
!                       to produce value for lw radiation bands 
!                       [ dimensionless ]
!      a0,a1,a2         empirical coefficients for extinction coef-
!                       ficient parameterization
!      b                empirical coefficients for single scattering 
!                       albedo parameterization
!      n,ni             do-loop indices
! 
!----------------------------------------------------------------------

      do k=1,size(conc_ice,3)
        do j=1,size(conc_ice,2)
          do i=1,size(conc_ice,1)
            if (size_ice(i,j,k) < min_cld_ice_size) then       
              size_i(i,j,k) = min_cld_ice_size             
            else if(size_ice(i,j,k) > max_cld_ice_size ) then  
              size_i(i,j,k) = max_cld_ice_size       
            else
              size_i(i,j,k) = size_ice(i,j,k)
            endif
          end do
         end do
      end do

      do k=1, size(conc_ice,3)
        do j=1, size(conc_ice,2)
          do i=1, size(conc_ice,1)
            if (dge_column(i,j,k)) then
              sumext = 0.
              sumssalb = 0.
              if (conc_ice(i,j,k) /= 0.0) then
                mask (i,j,k)= .true.

                if ((Cldrad_control%using_fu2007 .and.    &
                    size_i(i,j,k) > 15.0) .or. &
                    .not. Cldrad_control%using_fu2007) then

!-----------------------------------------------------------------------
!    calculate extinction coefficient [km**(-1)] for each wavenumber
!    band of the Fu-Liou parameterization (not the radiation
!    code wavenumber bands).
!-----------------------------------------------------------------------
                  do n=1,NBFL                                   
                    cldextivlice          = 1.0E+03*conc_ice(i,j,k)*  &
                                  (a0(n) +                           &
                                   a1(n)*(1.0/size_i(i,j,k)) +     &
                                   a2(n)*(1.0/size_i(i,j,k)**2))

!-----------------------------------------------------------------------
!    calculate the absorption coefficient. convert to units of 
!    [ km**(-1) ].
!-----------------------------------------------------------------------
                    cldabsivlice          = 1.0E+03*conc_ice(i,j,k)*   &
                                  (1.0/size_i(i,j,k))*        &       
                                   (b(n,0) +                    &
                                    b(n,1)*size_i(i,j,k) +    &
                                    b(n,2)*size_i(i,j,k)**2 + &
                                    b(n,3)*size_i(i,j,k)**3)

!---------------------------------------------------------------------
!    compute the single-scattering albedo. the asymmetry parameter is
!    not currently used in the infrared code, so its calculation is
!    commented out.
!-----------------------------------------------------------------------
                    if (cldextivlice /= 0.0) then
                      cldssalbivlice = 1.0E+00 -    &
                                             cldabsivlice/cldextivlice
                    else
                      cldssalbivlice = 0.0
                    endif 
 
!-----------------------------------------------------------------------
!    use the band weighting factors computed in microphys_rad_init
!    to define the values of these parameters for each lw radiation
!    band.
!-----------------------------------------------------------------------
                    sumext        = sumext +         &
                          cldextivlice*fulwwts(nb,n)
                    sumssalb = sumssalb +     &
                            cldssalbivlice*fulwwts(nb,n)
                  end do
                else ! ( using_fu2007 .and. size_i > 15.0 .or. not
                     !   using_fu2007)

 !+yim small dge
!-----------------------------------------------------------------------
!    calculate extinction coefficient [km**(-1)] for each wavenumber
!    band of the Fu-Liou parameterization (not the radiation
!    code wavenumber bands).
!-----------------------------------------------------------------------
                  do n=1,NBFL                          
                    m = NBFL - n + 1
                    fw1 = size_i(i,j,k)
                    fw2 = fw1*size_i(i,j,k)
                    fw3 = fw2*size_i(i,j,k)
                    fw4 = fw3*size_i(i,j,k)
       
                    cldextivlice   = 1.0E+03*conc_ice(i,j,k)/fw1*  &
                                 (aa(1,m) +       &
                                  aa(2,m)*fw1 +   &
                                  aa(3,m)*fw2 +   &
                                  aa(4,m)*fw3 +   &
                                  aa(5,m)*fw4 )

!-----------------------------------------------------------------------
!    calculate the absorption coefficient. convert to units of 
!    [ km**(-1) ].
!-----------------------------------------------------------------------
                    cldabsivlice    = 1.0E+03*conc_ice(i,j,k)*      &
                                 (1.0/fw1)*        &
                                  (bb(1,m) +                    &
                                   bb(2,m)*fw1 +  &
                                   bb(3,m)*fw2 +  &
                                   bb(4,m)*fw3 +  &
                                   bb(5,m)*fw4 )

!---------------------------------------------------------------------
!    compute the single-scattering albedo. the asymmetry parameter is
!    not currently used in the infrared code, so its calculation is
!    commented out.
!-----------------------------------------------------------------------
                    if (cldextivlice /= 0.0) then
                      cldssalbivlice = 1.0E+00 -    &
                                            cldabsivlice/cldextivlice
                    else
                      cldssalbivlice = 0.0
                    endif

!                   do n=1,NBFL                           
!                     m = NBFL - n + 1
!                     cldasymmivlice(:,:,:,n) = cc(1,m) +        &
!                                 cc(2,m)*fw1 +     &
!                                 cc(3,m)*fw2 +     &
!                                 cc(4,m)*fw3 +     &
!                                 cc(5,m)*fw4
!                   end do
 
!-----------------------------------------------------------------------
!    use the band weighting factors computed in microphys_rad_init
!    to define the values of these parameters for each lw radiation
!    band.
!-----------------------------------------------------------------------
                    sumext  = sumext + cldextivlice*fulwwts(nb,n)
                    sumssalb = sumssalb + cldssalbivlice*fulwwts(nb,n)
                  end do
                endif ! (size > 15)    
                cldextbndicelw(i,j,k) = sumext
                cldssalbbndicelw(i,j,k) = sumssalb
              else  ! (conc_ice > 0)
                mask(i,j,k) = .false.
                cldextbndicelw(i,j,k) = 0.0        
                cldssalbbndicelw(i,j,k) = 0.0          
              endif ! (convc_ice > 0)
              cldextbndicelw(i,j,k) = sumext
              cldssalbbndicelw(i,j,k) = sumssalb
            else  ! (dge_column)
              mask(i,j,k) = .false.
              cldextbndicelw(i,j,k) = 0.0        
              cldssalbbndicelw(i,j,k) = 0.0          
            endif !(dge_column)
          end do
        end do
      end do

!---------------------------------------------------------------------


end subroutine el_dge



!#####################################################################
! <SUBROUTINE NAME="cliqlw">
!  <OVERVIEW>
!   Subroutine to calculate longwave absorption optical depth for liquid
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculates longwave absorption optical depth for liquid.
!     Follows Held et al. (J. Atmos. Sci., 1993).
!     
!     Leo Donner, GFDL, 1 Feb 1999
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cliqlw (conc_drop, cldextbnddroplw)
!  </TEMPLATE>
!  <IN NAME="conc_drop" TYPE="real">
!   the cloud drop concentration in grams / meter**3
!  </IN>
!  <OUT NAME="cldextbnddroplw" TYPE="real">
!   the specified values of the extinction         
!                 coefficient for cloud drops in kilometers**(-1)  
!                 over wavenumber bands used by the radiation code
!  </OUT>
! </SUBROUTINE>

subroutine cliqlw (conc_drop, cldextbnddroplw)
 
!-----------------------------------------------------------------------
!    subroutine cliqlw calculates the longwave absorption optical depth
!    for cloud drops. the parameterization follows Held et al. 
!    (J. Atmos. Sci., 1993).
!     Leo Donner, GFDL, 1 Feb 1999
!-----------------------------------------------------------------------

real, dimension (:,:,:),   intent(in)   ::  conc_drop
real, dimension (:,:,:), intent(out)  ::  cldextbnddroplw

!---------------------------------------------------------------------
!   intent(in) variable:                                            
!                                                                  
!     conc_drop        cloud drop concentration [ grams / meter**3 ]
!                                                                  
!   intent(out) variable:                                            
!                                                                  
!     cldextbnddroplw  values of the extinction coefficient for 
!                      cloud droplets over the wavenumber bands 
!                      used by the radiation code [ km**(-1) ]
!                                                                  
!-----------------------------------------------------------------------

 
!---------------------------------------------------------------------
!  local variables:                                                   

!     real        ::   alpha = 0.1   (now is module variable set in nml)

!---------------------------------------------------------------------
!  local variables:                                                   
!
!     n           do-loop index
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the cloud droplet extinction coefficient. convert to
!    units of [ km**(-1) ].
!--------------------------------------------------------------------
        cldextbnddroplw(:,:,:  ) = 1.0E+03*alpha*conc_drop(:,:,:)
 
!---------------------------------------------------------------------

end subroutine cliqlw


!#####################################################################
! <SUBROUTINE NAME="furainlw">
!  <OVERVIEW>
!   Subroutine to calculate total optical depth and scattering optical
!   depth in infrared for cloud rain water
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculates absorption coefficient for cloud rain water for
!      longwave radiation (Fu et al., 1995, J. Atmos. Sci.)
!      To be used for rain water with radii between 60 um and 1.8 mm.
!      See also notes from Q. Fu (4 Sept 98)
!      note: the size of the rain water from the microphysical
!      model (if existing) does not enter into the calculations.
!
!      Leo Donner, GFDL, 20 Mar 99
!  </DESCRIPTION>
!  <TEMPLATE>
!   subroutine furainlw                                         &
!                (conc_rain    ,                                   &
!                 cldextbndrainlw, cldssalbbndrainlw, cldasymmbndrainlw)
!  </TEMPLATE>
!  <IN NAME="conc_rain" TYPE="real">
!   the rain drop water concentration in grams / meter**3
!  </IN>
!  <OUT NAME="cldextbndrainlw" TYPE="real">
!   the specified values of the extinction          
!                 coefficient for rain water in kilometers**(-1)
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldssalbbndrainlw" TYPE="real">
!   the specified values of the single-           
!                  scattering albedo for rain water             
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldasymmbndrainlw" TYPE="real">
!   the specified values of the asymmetry         
!                  factor for rain water                       
!                 over wavenumber bands used by the radiation code
!  </OUT>
! </SUBROUTINE>
!  

subroutine furainlw (nb, conc_rain, cldextbndrainlw, cldssalbbndrainlw,&
                     cldasymmbndrainlw)
 
!----------------------------------------------------------------------
!    subroutine furainlw calculates the absorption coefficient for 
!    rain water for longwave radiation (Fu et al., 1995, J. Atmos. Sci.)
!    it is designed for use with rain drops with radii between 60 um 
!    and 1.8 mm. see also notes from Q. Fu (4 Sept 98). note that the 
!    size of the rain water from the microphysical model (if existing) 
!    does not enter into the calculations.
!    Leo Donner, GFDL, 20 Mar 99
!----------------------------------------------------------------------

integer,                   intent(in)    ::   nb
real, dimension (:,:,:),   intent(in)    ::   conc_rain
real, dimension (:,:,:  ), intent(out)   ::   cldextbndrainlw,    &
                                              cldssalbbndrainlw,   &
                                              cldasymmbndrainlw

!----------------------------------------------------------------------
!   intent(in) variables:                                             
!
!       conc_rain           rain drop concentration [ grams / meter**3 ]
!
!   intent(out) variables:                                            
!
!       cldextbndrainlw     values of the extinction coefficient for 
!                           rain drops over the wavenumber bands used 
!                           by the radiation code [ km**(-1) ]
!       cldssalbbndrainlw   values of the single-scattering albedo for 
!                           rain drops over the wavenumber bands used 
!                           by the radiation code  [ dimensionless ] 
!       cldasymmbndrainlw   values of the asymmetry factor for rain
!                           drops over the wavenumber bands used by 
!                           the radiation code  
!
!--------------------------------------------------------------------- 


!----------------------------------------------------------------------
!  local variables:                                                  

      real ::          cldextivlrain, cldssalbivlrain
 
      real ::          sumext, sumssalb

      real, dimension (NBFL)    :: brn, wrnf

      data brn /                                                     &
             1.6765,  1.6149,  1.5993,  1.5862,  1.5741,  1.5647,    &
             1.5642,  1.5600,  1.5559,  1.5512,  1.5478,  1.5454/
      data wrnf /                                                    &
              .55218,  .55334,  .55488,  .55169,  .53859,  .51904,   &
              .52321,  .52716,  .52969,  .53192,  .52884,  .53233/

      real      :: rwc0 = 0.5
      integer   :: n
      integer   :: i,j,k

!----------------------------------------------------------------------
!  local variables:                                                  
!
!       cldextivlrain     the specified spectral values of the 
!                         extinction coefficient for rain water 
!                         [ kilometers**(-1) ] 
!       cldssalbivlrain   the specified spectral values of the single-  
!                         scattering albedo for rain water     
!                         [ dimensionless ]
!       cldasymmivlrain   the specified spectral values of the 
!                         asymmetry factor for rain water    
!                         [ dimensionless ]
!       sumext            weighted sum of extinction coefficient over fu
!                         bands to produce value for lw radiation bands
!                         [ kilometers**(-1) ]
!       sumssalb          sum of single scattering albedo over fu bands 
!                         to produce value for lw radiation bands 
!                         [ dimensionless ]
!        brn              empirical coefficients for extinction 
!                         coefficient parameterization [ (km**-1) ]
!        wrnf             empirical coefficients for single scattering 
!                         albedo parameterization
!                         [ dimensionless ]
!        rwc0             rain water content used to obtain above
!                         empirical coefficients.  [ g / m**3 ] 
!        n, ni            do-loop indices         
!
!---------------------------------------------------------------------
      do k=1, size(conc_rain,3)
        do j=1, size(conc_rain,2)
          do i=1, size(conc_rain,1)
            sumext = 0.
            sumssalb = 0.
            if (conc_rain(i,j,k) /= 0.0) then
 
!-----------------------------------------------------------------------
!    calculate extinction coefficient (km**(-1)) over the wavenumber
!    bands of the Fu-Liou parameterization (not the radiation code
!    wavenumber bands). define the single-scattering albedo for each
!    band. the asymmetry factor is not currently used, so the code
!    defining it is commented out.
!-----------------------------------------------------------------------
              do n=1,NBFL
                cldextivlrain   = brn(n)*conc_rain(i,j,k)/rwc0
                cldssalbivlrain = wrnf(n)
 
!-----------------------------------------------------------------------
!    use the band weighting factors computed in microphys_rad_init
!    to define the values of these parameters for each lw radiation
!    band.
!-----------------------------------------------------------------------
                sumext   = sumext + cldextivlrain*fulwwts(nb,n )
                sumssalb = sumssalb + cldssalbivlrain*fulwwts(nb,n )
              end do
            endif
            cldextbndrainlw  (i,j,k  ) = sumext
            cldssalbbndrainlw(i,j,k  ) = sumssalb
          end do
        end do
      end do

!---------------------------------------------------------------------
 
 
end subroutine furainlw



!#####################################################################
! <SUBROUTINE NAME="fusnowlw">
!  <OVERVIEW>
!   Subroutine to calculate total optical depth and scattering optical
!   depth in infrared for cloud rain water
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculates absorption coefficient for cloud rain water for
!      longwave radiation (Fu et al., 1995, J. Atmos. Sci.)
!      To be used for rain water with radii between 60 um and 1.8 mm.
!      See also notes from Q. Fu (4 Sept 98)
!      note: the size of the rain water from the microphysical
!      model (if existing) does not enter into the calculations.
!
!      Leo Donner, GFDL, 20 Mar 99
!  </DESCRIPTION>
!  <TEMPLATE>
!   subroutine fusnowlw                                         &
!                (conc_snow    ,                                   &
!                 cldextbndsnowlw, cldssalbbndsnowlw, cldasymmbndsnowlw)
!  </TEMPLATE>
!  <IN NAME="conc_snow" TYPE="real">
!   the snow drop water concentration in grams / meter**3
!  </IN>
!  <OUT NAME="cldextbndsnowlw" TYPE="real">
!   the specified values of the extinction          
!                 coefficient for snow drop water in kilometers**(-1)
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldssalbbndsnowlw" TYPE="real">
!   the specified values of the single-           
!                  scattering albedo for snow drop water             
!                 over wavenumber bands used by the radiation code
!  </OUT>
!  <OUT NAME="cldasymmbndsnowlw" TYPE="real">
!   the specified values of the asymmetry         
!                  factor for snow drop water                       
!                 over wavenumber bands used by the radiation code
!  </OUT>
! </SUBROUTINE>
!
subroutine fusnowlw (nb, conc_snow, cldextbndsnowlw, cldssalbbndsnowlw,&
                     cldasymmbndsnowlw)
 
!-----------------------------------------------------------------------
!    subroutine fusnowlw calculates the absorption coefficient for cloud
!    snow water for longwave radiation (Fu et al., 1995, J. Atmos. Sci.)
!    it is relevant for snow flakes with radii between 60 um and 5.0 mm.
!    see also notes from Q. Fu (4 Sept 98). note that the size of the 
!    snow flakes from the microphysical model (if existing) does not
!    enter into the calculations.
!    Leo Donner, GFDL, 20 Mar 99
!
!-----------------------------------------------------------------------
                                                                    
integer,                   intent(in)     ::   nb
real, dimension (:,:,:),   intent(in)     ::   conc_snow
real, dimension (:,:,:  ), intent(out)    ::   cldextbndsnowlw,    &
                                               cldssalbbndsnowlw,  &
                                               cldasymmbndsnowlw

!----------------------------------------------------------------------
!   intent(in) variables:                                             
!
!       conc_snow           snow concentration [ grams / meter**3 ]
!
!   intent(out) variables:                                            
!
!       cldextbndsnowlw     values of the extinction coefficient for 
!                           snow flakes over the wavenumber bands used 
!                           by the radiation code [ km**(-1) ]
!       cldssalbbndsnowlw   values of the single-scattering albedo for 
!                           snow flakes over the wavenumber bands used 
!                           by the radiation code  [ dimensionless ] 
!       cldasymmbndsnowlw   values of the asymmetry factor for snow
!                           flakes over the wavenumber bands used by 
!                           the radiation code  
!
!--------------------------------------------------------------------- 
 
!----------------------------------------------------------------------
!  local variables:                                                  

     real  ::          cldextivlsnow, cldssalbivlsnow

      real ::          sumext, sumssalb

      real, dimension (NBFL)     :: brn, wrnf
      data brn /                                                     &
              .87477,  .85421,  .84825,  .84418,  .84286,  .84143,   &
              .84097,  .84058,  .84029,  .83995,  .83979,  .83967/
      data wrnf /                                                    &
              .55474,  .53160,  .54307,  .55258,  .54914,  .52342,   &
              .52446,  .52959,  .53180,  .53182,  .53017,  .53296/
                                                                    
      real      :: swc0 = 0.5
      integer   :: n
      integer   :: i,j,k
 
!---------------------------------------------------------------------
!   local variables:
!
!       cldextivlsnow     the specified spectral values of the 
!                         extinction coefficient for snow flakes
!                         [ kilometers**(-1) ] 
!       cldssalbivlsnow   the specified spectral values of the single-  
!                         scattering albedo for snow flakes    
!                         [ dimensionless ]
!       cldasymmivlsnow   the specified spectral values of the 
!                         asymmetry factor for snow flakes   
!                         [ dimensionless ]
!       sumext            weighted sum of extinction coefficient over fu
!                         bands to produce value for lw radiation bands
!                         [ kilometers**(-1) ]
!       sumssalb          sum of single scattering albedo over fu bands 
!                         to produce value for lw radiation bands 
!                         [ dimensionless ]
!       brn               empirical coefficients for extinction 
!                         coefficient parameterization (km**-1)
!       wrnf              empirical coefficients for single scattering 
!                         albedo parameterization [ dimensionless ]
!       swc0              snow water content used to obtain above
!                         empirical coefficients  [ g / m**3 ]
!       n,ni              do-loop indices
!
!---------------------------------------------------------------------

      do k=1, size(conc_snow,3)
        do j=1, size(conc_snow,2)
          do i=1, size(conc_snow,1)
            sumext = 0.
            sumssalb = 0.
            if (conc_snow(i,j,k) /= 0.0) then

!-----------------------------------------------------------------------
!    calculate the extinction coefficient over the wavenumber bands of 
!    the Fu-Liou parameterization (not the radiation code wavenumber 
!    bands). define the single scattering albedo for each band. the
!    asymmetry factor is not currently used, so the code defining it
!    is commented out.
!-----------------------------------------------------------------------
              do n=1,NBFL
                cldextivlsnow   = brn(n)*conc_snow(i,j,k)/swc0
                cldssalbivlsnow = wrnf(n)
 
!-----------------------------------------------------------------------
!    use the band weighting factors computed in microphys_rad_init     
!    to define the appropriate values for the scattering parameters for
!    each lw radiation band.
!-----------------------------------------------------------------------
                sumext     = sumext + cldextivlsnow*fulwwts(nb,n )
                sumssalb   = sumssalb + cldssalbivlsnow*fulwwts(nb,n )
              end do
            endif
            cldextbndsnowlw(i,j,k)   = sumext
            cldssalbbndsnowlw(i,j,k) = sumssalb         
          end do
        end do
      end do

!----------------------------------------------------------------------
 
 
end subroutine fusnowlw



!####################################################################

!!! THIS SUBOUTINE IS CURRENTLY NOT USED.
subroutine snowlw
!subroutine snowlw(riwp, tau)
!
!-----------------------------------------------------------------------
!
!     Calculates emissivity
!     for longwave radiation using Fu et al. (1995,
!     JAS). (See notes from Kuo-Nan Liou, 1 Sept 98).
!
!-----------------------------------------------------------------------
!
!     On Input:
!
!        riwp   snow path  (g/(m**2))
!
!     On Output:
!
!        tau   absorption optical depth
!
!        Leo Donner, GFDL, 11 Sept 98
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
!     Calculate extinction coefficient (m**(-1)) and optical depth
!     for absorption. Extinction coefficient is taken as product of
!     total extinction coefficient (.84 km**(-1)) and single-scattering
!     albedo. See Kuo-Nan Liou notes 
!     (1 Sept 98).
!
!-----------------------------------------------------------------------
!
!     riwc0=0.5
!     ext=.4
!     if (riwp .eq. 0.) then
!       tau=0.
!     else
!       tau=ext*.001*riwp/riwc0
!     end if
!     emis=1.-exp(-tau)

!-----------------------------------------------------------------------


end subroutine snowlw



!#################################################################




                   end module microphys_rad_mod



                    module optical_path_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that set up optical depth calculaiton
! </OVERVIEW>
! <DESCRIPTION>
!  radiative fluxes
! </DESCRIPTION>

!   shared modules:

use mpp_mod,             only: input_nml_file
use fms_mod,             only: open_namelist_file, fms_init, &
                               mpp_pe, mpp_root_pe, stdlog, &
                               file_exist, write_version_number, &
                               check_nml_error, error_mesg, &
                               FATAL, close_file
use constants_mod,       only: RDGAS, RVGAS, GRAV, wtmair, &
                               avogno, pstd, diffac, tfreeze, &
                               constants_init

!   shared radiation package modules:

use rad_utilities_mod,   only: looktab, longwave_tables3_type, &
                               rad_utilities_init,  &
                               radiative_gases_type, &
                               aerosol_type,  &
                               aerosol_diagnostics_type,&
                               aerosol_properties_type, &
                               atmos_input_type, &
                               Lw_parameters,  Lw_control, &
                               Rad_control, &
                               optical_path_type, &
                               gas_tf_type, &
                               table_alloc
use longwave_params_mod, only: longwave_params_init, NBCO215,&
                               NBLY_RSB

!   radiation package modules:

use lw_gases_stdtf_mod,  only: lw_gases_stdtf_init, cfc_exact,&
                               cfc_overod, cfc_overod_part,   &
                               cfc_exact_part

!--------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    optical_path_mod computes the optical depths and associated
!    transmission functions for various atmospheric components 
!    including radiative gases and aerosols.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

   character(len=128)  :: &
   version =  '$Id: optical_path.F90,v 18.0.2.1 2010/08/30 20:39:46 wfc Exp $'
   character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!----- interfaces  -----
           
public     &
         optical_path_init, optical_path_setup,     &
         optical_trans_funct_from_KS,    &
         optical_trans_funct_k_down, &
         optical_trans_funct_KE,  &
         optical_trans_funct_diag, &
         get_totch2o, get_totch2obd, &
         get_totvo2, optical_dealloc, &
         optical_path_end

private    &

!   called from optical_path_init:
         optical_ckd_init,     &

!   called from optical_path_setup:
         optical_path_ckd, optical_o3, optical_rbts,   &
         optical_h2o, cfc_optical_depth, optical_depth_aerosol


!---------------------------------------------------------------------
!---- namelist   -----

logical   :: tmp_dpndnt_h2o_lines = .true.  ! the 1200-1400 cm(-1)
                                            ! band h2o line intensities
                                            ! are temperature dependent?



namelist / optical_path_nml /    &
                                 tmp_dpndnt_h2o_lines

!-------------------------------------------------------------------
!-----  public data ----


!---------------------------------------------------------------------
!----- private  data  ----

!--------------------------------------------------------------------
!    data from former block data bs296 for self-broadened continuum
!    at 296K, band-integrated, in 5 - 19995 cm-1 range.
!               06/28/82
!               units of (cm**3/mol) * 1.E-20
!-------------------------------------------------------------------
real       :: v1sh2o_296, v2sh2o_296, dvsh2o_296,   &
              ssh2o_296(2000)
integer    :: nptsh2o_296

!--------------------------------------------------------------------
!  data from former block data bfh2o for foreign-broadened continuum
!    band-integrated, in 5 - 19995 cm-1 range.
!               06/28/82
!               units of (cm**3/mol) * 1.E-20
!--------------------------------------------------------------------
real        ::  v1fh2o, v2fh2o, dvfh2o, sfh2o(2000)
integer     ::  nptfh2o

!--------------------------------------------------------------------
!    array sfac is the frequency-dependent multiplicative factor used
!    to change the original self-broadened continuum coefficients
!    to those used in ckd2.1 or ckd2.4 (including intermediate changes).
!
!    array fscal is the frequency-dependent multiplicative factor used
!    to change the original foreign-broadened continuum coefficients
!    to those used in ckd2.1 or ckd2.4 (including intermediate changes).
!
!    array tmpfctrs is the logarithmic temperature dependence (per K)
!    of the self-broadened continuum coefficient, as a function of
!    frequency, used in all ckd AFGL continuum models.
!    the frequency ranges and intervals are as in sh2o_296.
!----------------------------------------------------------------------
real         :: sfac(2000), fscal(2000), tmpfctrs(2000)

!----------------------------------------------------------------------
!         the radfunc function (1 - exp(-h*nu/kt))/(1 + exp(-h*nu/kt))
!    is tabulated from 5 to 2995 cm-1 at intervals of 10 cm-1,
!    and from 100K to 490K at 10K intervals. note that the
!    radfn function used in ckd models equals the radfunc function
!    defined above, multiplied by nu (in cm-1).
!        the temperature derivative (at 105K to 485K, with the final
!    array value set to zero) is obtained from radfunc, and stored in
!    radfuncderiv.
!        tktab and vjtab are the respective temperature and frequency
!    points at which tabulations occurred.
!----------------------------------------------------------------------
type (longwave_tables3_type),save  :: radfunc
integer                            :: ioffh2o, nptch2o 
real                               :: vvj(2000)

!---------------------------------------------------------------------
!        fvj = foreign-broadened ckd 2.1 (ckd2.4) coefficient (including
!              all corrections), averaged over 7 specified wide
!              frequency bands in the 560-1200 cm-1 range. The average
!              is weighted by the frequency of the individual 10 cm-1
!              bands used in the averaging process.
!     fvjinw = band-averaged foreign coefficient (as in fvj) over
!              the 900-990,1070-1200 cm-1 range.
!      fvjwd = band-averaged foreign coefficient (as in fvj) over
!              the 560-800 cm-1 range.
!        svj = self-broadened ckd 2.1 (ckd2.4) coefficient (including
!              all corrections), averaged over 7 specified wide
!              frequency bands in the 560-1200 cm-1 range. The average
!              is weighted by the frequency of the individual 10 cm-1
!              bands used in the averaging process.
!     fvjinw = band-averaged self coefficient (as in svj) over
!              the 900-990,1070-1200 cm-1 range.
!      svjwd = band-averaged self coefficient (as in svj) over
!              the 560-800 cm-1 range.
!    radfnbd = the radiation function (radfn) averaged over each of
!              the 7 frequency bands: assumed to be altitude-independent
! radfnbdinw = same as radfnbd, but for the 560-800 cm-1 range.
!  radfnbdwd = same as radfnbd, but for the 900-990,1070-1200 cm-1 range
!----------------------------------------------------------------------
real      ::    fvj(7), fvjinw, fvjwd, svj(7), svjinw, svjwd,    &
                radfnbd(7), radfnbdinw, radfnbdwd

real      ::    ao3rnd(3), bo3rnd(3)

real      ::    ab15wd 

!---------------------------------------------------------------------
!  define continuum coefficients over special bands, the choices
!  depend on model architecture. the program gasbnd is used.
!
!    1) 560-800 as 1 band
!----------------------------------------------------------------------
real      ::    betawd 

!----------------------------------------------------------------------
!    3) 160-560 (as 8 bands using combined bands). program gasbnd is
!    used as 40 bands (160-560,10 cm-1 bandwidth) with ifdef icomb on.
!    4) 560-1200 and 4.3 um band (8 bands, frequency range given
!    by bdlocm-bdhicm). program gasbnd is used with 8 specified
!    bandwidths.
!--------------------------------------------------------------------
real, dimension (NBLY_RSB)           :: betacm

!---------------------------------------------------------------------

real, allocatable, dimension (:,:)     ::             csfah2o

!---------------------------------------------------------------------
!   the values of the molecular weights of f11 and f12 are derived
!   from elemental atomic weights adopted by the International Union of 
!   Pure and Applied Chemistry in 1961. These values are also used in 
!   the US Standard Atmosphere, 1976.
!   some previous radiative calculations at gfdl have used the
!   values  137.5, 121.0 for the molecular weights of f11 and f12.
!---------------------------------------------------------------------
real       ::  wtmf11  = 137.36855
real       ::  wtmf12  = 120.91395
real       ::  wtmf113 = 187.3765
real       ::  wtmf22  =  86.46892

!---------------------------------------------------------------------
real, dimension(2,10)  :: cpf10h2o, csf10h2o
real, dimension(2, 4)  :: cpf4h2o, csf4h2o
real, dimension(2, 2)  :: cpf2h2o, csf2h2o
real, dimension(2   )  :: cpf1h2o, csf1h2o


real      :: d622 = RDGAS/RVGAS
integer   :: NBTRG, NBTRGE
!!$integer   :: n

integer   :: ks, ke

logical   :: module_is_initialized      = .false. ! module has been
                                                  ! initialized ?


!----------------------------------------------------------------------




                              contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
!#####################################################################
! <SUBROUTINE NAME="optical_path_init">
!  <OVERVIEW>
!   Subroutine to initialize optical depth calculation and read
!   optical path namelist from input file.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to initialize optical depth calculation and read
!   optical path namelist from input file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_path_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine optical_path_init(pref)

!--------------------------------------------------------------------
!    optical_path_init is the constructor for optical_path_mod.
!--------------------------------------------------------------------

      real, dimension(:,:), intent(in) :: pref
!--------------------------------------------------------------------
!  local variables:

      real                    :: dum
      real, dimension (NBLY_RSB)  :: dummy_n
      real, dimension (Lw_parameters%NBTRGE) :: dummy_ch4n2o
      real                    :: awide_c, bwide_c, awide_n, bwide_n, &
                                 awide, bwide
      integer, dimension(5)   :: no_h2o12001400bands = &
                                  (/ 1, 2, 4, 10, 20 /)
      real, dimension(20)     :: arndm_12001400, brndm_12001400,    &
                                 ap_12001400, bp_12001400,          &
                                 atp_12001400, btp_12001400,        &
                                 fbdlo_12001400, fbdhi_12001400
      integer                 ::  unit, ierr, io, logunit
      integer                 :: inrad, k, m
      integer                 :: subb

!---------------------------------------------------------------------
!  local variables:
!
!       dum
!       dummy
!       dummy_n
!       dummy_ch4n2o
!       ap
!       bp
!       atp
!       btp
!    define random band parameters for special bands. the choices 
!    depend on model architecture. the program gasbnd is used.
!    1)  560-800 as 1 band
!       awide_c
!       bwide_c
!       awide_n
!       bwide_n
!    end comment for above
!       awide
!       bwide
!       no_h2o12001400bands
!       arndm_12001400
!       brndm_12001400
!       ap_12001400
!       bp_12001400
!       atp_12001400
!       btp_12001400
!       fbdlo_12001400
!       fbdhi_12001400
!       unit
!       ierr
!       io
!       inrad
!       k,m
!       subb
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init
      call longwave_params_init
      call lw_gases_stdtf_init(pref)

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=optical_path_nml, iostat=io)
      ierr = check_nml_error(io,"optical_path_nml")
#else
!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=optical_path_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'optical_path_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=optical_path_nml)

!--------------------------------------------------------------------
!    verify that Lw_parameters%NBTRG and NBTRGE have been initialized.
!--------------------------------------------------------------------
      if (Lw_parameters%NBTRG_iz) then
        NBTRG  = Lw_parameters%NBTRG
      else
        call error_mesg ('optical_path_mod',  &
           ' Lw_parameters%NBTRG not yet initialized', FATAL)
      endif
      if (Lw_parameters%NBTRGE_iz) then
        NBTRGE = Lw_parameters%NBTRGE
      else
        call error_mesg ('optical_path_mod',  &
           ' Lw_parameters%NBTRGE not yet initialized', FATAL)
      endif

      if (nbtrge == 0 .and. tmp_dpndnt_h2o_lines) then
        call error_mesg ('optical_path_mod', &
        'cannot have temperature-dependent h2o line intensities &
             &without having separate 1200-1400 cm(-1) band(s)', FATAL) 
      endif
        
!---------------------------------------------------------------------
!    read needed data from raduiation input files.
!---------------------------------------------------------------------
      if (trim(Lw_control%linecatalog_form) == 'hitran_1992' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          inrad = open_namelist_file('INPUT/h2ocoeff_ckd_speccombwidebds_hi92')
          read (inrad,9000) awide_c   ! ckd rndm coeff for 560-800 band
          read (inrad,9000) bwide_c   ! ckd rndm coeff for 560-800 band
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          inrad = open_namelist_file('INPUT/h2ocoeff_rsb_speccombwidebds_hi92')
          read (inrad,9000) awide_n   ! rsb rndm coeff for 560-800 band
          read (inrad,9000) bwide_n   ! rsb rndm coeff for 560-800 band
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) betawd    ! rsb cont coeff for 560-800 band
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
!  rsb cont coeff for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (betacm(k),k=1,NBLY_RSB)
        endif
      else if (trim(Lw_control%linecatalog_form) == 'hitran_2000' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          inrad = open_namelist_file('INPUT/h2ocoeff_ckd_speccombwidebds_hi00')
          read (inrad,9000) awide_c   ! ckd rndm coeff for 560-800 band
          read (inrad,9000) bwide_c   ! ckd rndm coeff for 560-800 band
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          inrad = open_namelist_file('INPUT/h2ocoeff_rsb_speccombwidebds_hi00')
          read (inrad,9000) awide_n   ! rsb rndm coeff for 560-800 band
          read (inrad,9000) bwide_n   ! rsb rndm coeff for 560-800 band
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) betawd    ! rsb cont coeff for 560-800 band
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (dummy_n(k),k=1,NBLY_RSB)
!  rsb cont coeff for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (betacm(k),k=1,NBLY_RSB)
        endif
      endif
9000  format(5e14.6)
      call close_file (inrad)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        awide = awide_c
        bwide = bwide_c
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        awide = awide_n
        bwide = bwide_n
      endif

!---------------------------------------------------------------------
!    compute a*b for computational frequency bands for the 15 um
!    region, as 1 band (ab15wd)
!---------------------------------------------------------------------
      ab15wd = awide*bwide

      if (trim(Lw_control%linecatalog_form) == 'hitran_1992') then
        inrad = open_namelist_file('INPUT/o39001200_hi92_data')
      else if (trim(Lw_control%linecatalog_form) == 'hitran_2000') then
        inrad = open_namelist_file('INPUT/o39001200_hi00_data')
      endif
      read (inrad,2001) (ao3rnd(k),k=1,3)
      read (inrad,2001) (bo3rnd(k),k=1,3)

!---------------------------------------------------------------------
!    verify that Lw_control%do_ch4 has been initialized.
!--------------------------------------------------------------------
      if (Lw_control%do_ch4_iz) then
      else
        call error_mesg ( 'optical_path_mod',  &
                      ' do_ch4 not yet initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    verify that Lw_control%do_n2o has been initialized.
!--------------------------------------------------------------------
      if (Lw_control%do_n2o_iz) then
      else
        call error_mesg ( 'optical_path_mod',  &
                      ' do_n2o not yet initialized', FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (NBTRGE > 0) then
        allocate ( csfah2o(2, NBTRGE) )
        if (trim(Lw_control%linecatalog_form) == 'hitran_1992') then
          inrad = open_namelist_file('INPUT/h2o12001400_hi92_data')
        else if (trim(Lw_control%linecatalog_form) ==    &
                                                    'hitran_2000') then
          inrad = open_namelist_file('INPUT/h2o12001400_hi00_data')
        endif

!----------------------------------------------------------------------
!     read in random coefficients for 1200-1400 freq region, spacing
!     through the data until  those appropriate for NBTRGE h2o bands
!     are reached. note: unless a continuum is inserted beyond 1200
!     cm-1, the band coefficients are independent of continuum type.
!---------------------------------------------------------------------
        do subb = 1,5    ! 5 = no. band divisions in h2o 1200-1400 data
          if (NBTRGE == no_h2o12001400bands(subb)) then
!  read and process data for sub-band number from data matching NBTRGE
!  then exit subb loop
            read (inrad,2001) (arndm_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (brndm_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (ap_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (bp_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (atp_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (btp_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (fbdlo_12001400(k),k=1,NBTRGE)
            read (inrad,2001) (fbdhi_12001400(k),k=1,NBTRGE)
            do m=1,NBTRGE
              csfah2o(1,m) =          atp_12001400(m)
              csfah2o(2,m) =          btp_12001400(m)
            end do
            exit
          else if (subb < 5) then 
!  read data for sub-band number from  data not matching NBTRGE
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
            read (inrad,2001)    &
                       (dummy_ch4n2o(k),k=1,no_h2o12001400bands(subb))
          else
!    failure of any sub-band number to match NBTRGE
            call error_mesg ('optical_path_mod',  &
              'NBTRGE is inconsistent with available data', FATAL)
          endif
        end do
2001  format(5e14.6)
        call close_file(inrad)
      endif

!------------------------------------------------------------------
!
!------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        call optical_ckd_init
      endif

!------------------------------------------------------------------
!    mark the module as initialized.
!------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------



end subroutine optical_path_init




!###################################################################
! <SUBROUTINE NAME="optical_path_setup">
!  <OVERVIEW>
!   Subroutine to prepare optical path calculation, such as memory
!   allocation.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to prepare optical path calculation, such as memory
!   allocation.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_path_setup (is, ie, js, je,  Atmos_input, &
!                            Rad_gases, Aerosol, Aerosol_props, Optical)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   Latitude and longitude bound of model physics window.
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   Radiative gases input data
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol radiative properties input data
!  </IN>
!  <INOUT NAME="Aerosol_props" TYPE="aerosol_properties_type">
!   Aerosol radiative properties output (extinction coefficient,
!   single scattering albedo and asymmetry parameter in different
!   bands)
!  </INOUT>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   optical path output
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_path_setup (is, ie, js, je, Atmos_input, &
                               Rad_gases, Aerosol, Aerosol_props,  &
                               Aerosol_diags, Optical, &
                               including_aerosols)  

!------------------------------------------------------------------
!
!------------------------------------------------------------------

integer, intent(in)                          :: is, ie, js, je
type(atmos_input_type),        intent(in)    :: Atmos_input
type(radiative_gases_type),    intent(in)    :: Rad_gases
type(aerosol_type),            intent(in)    :: Aerosol      
type(aerosol_properties_type), intent(inout) :: Aerosol_props      
type(aerosol_diagnostics_type), intent(inout) :: Aerosol_diags      
type(optical_path_type),       intent(inout) :: Optical     
logical,                   intent(in)            :: including_aerosols  

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      is,ie,js,je
!      Atmos_input
!      Rad_gases
!      Aerosol
!
!  intent(inout) variables:
!
!      Aerosol_props
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:
 
      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3) )  :: press, pflux, &
                                                       temp, tflux, &
                                                       atmden, vv

      real, dimension (size(Atmos_input%press,1),   &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3) - 1 )  ::   &
                                                       rh2o, deltaz
      real, dimension (size(Atmos_input%press,3) ) :: bsum

      integer      :: n_aerosol_bands
      integer      :: k, i, j, n
      integer      :: ix, jx, kx
      integer      :: israd, ierad, jsrad, jerad

!--------------------------------------------------------------------
!  local variables:
!
!       press
!       pflux
!       temp
!       tflux
!       atmden
!       vv             layer-mean pressure in atmospheres. due to quad-
!                      rature considerations, this does not equal the 
!                      pressure at the data level (press).
!       rh2o
!       deltaz
!       n_aerosol_bands
!       i,k
!       ix,jx,kx
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
      ix = ie -is + 1
      jx = je -js +1
      israd = 1
      ierad = ix
      jsrad = 1
      jerad = jx
      ks    = 1
      kx = size(Atmos_input%press,3) - 1
      ke    = kx

!  convert press and pflux to cgs.
      press(:,:,:) = 10.0*Atmos_input%press(:,:,:)
      pflux(:,:,:) = 10.0*Atmos_input%pflux(:,:,:)
      deltaz = Atmos_input%deltaz
      temp = Atmos_input%temp
      rh2o = Atmos_input%rh2o
      tflux = Atmos_input%tflux

!--------------------------------------------------------------------
!    atmden   =  atmospheric density, in gm/cm**2, for each of the
!                KMAX layers.
!-------------------------------------------------------------------
      allocate (Optical%wk       (ISRAD:IERAD, JSRAD:JERAD, KS:KE  ) )
      allocate (Optical%rh2os    (ISRAD:IERAD, JSRAD:JERAD, KS:KE  ) )
      allocate (Optical%rfrgn    (ISRAD:IERAD, JSRAD:JERAD, KS:KE  ) )
      allocate (Optical%tfac     (ISRAD:IERAD, JSRAD:JERAD, KS:KE  ) )
      allocate (Optical%avephi   (ISRAD:IERAD, JSRAD:JERAD, KS:KE+1) )

      if (NBTRGE > 0) then
        allocate (Optical%avephif(ISRAD:IERAD, JSRAD:JERAD,    &
                                  KS:KE+1, NBTRGE) )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      Optical%wk      = 0.                                      
      Optical%rh2os   = 0.                                      
      Optical%rfrgn   = 0.                                       
      Optical%tfac    = 0.                                       
      Optical%avephi   = 0.

      if (NBTRGE > 0) then
        Optical%avephif   = 0.
      endif
 
!----------------------------------------------------------------------
!    define the layer-mean pressure in atmospheres (vv) and the layer 
!    density (atmden). 
!----------------------------------------------------------------------
      do k=KS,KE
        atmden(:,:,k) = (pflux(:,:,k+1) - pflux(:,:,k))/(1.0E+02*GRAV)
        vv(:,:,k)     = 0.5E+00*(pflux(:,:,k+1) + pflux(:,:,k)  )/pstd
      end do

!----------------------------------------------------------------------
!     compute optical paths.
!----------------------------------------------------------------------
      call optical_h2o (pflux, atmden, vv, press, temp, rh2o,   &
                        tflux, Optical)

!---------------------------------------------------------------------
!    call optical_ckd2p1 to determine self- and foreign-broadened h2o
!    continuum paths, for the given temperature, pressure and mixing
!    ratio, over the predetermined frequency range for the ckd2.1 
!    continuum. call optical_roberts for self-broadened continuum
!    paths for the rsb (Roberts) continuum.
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        call optical_path_ckd  (atmden, press, temp, rh2o, Optical)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        call optical_rbts  (temp, rh2o, Optical)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      call optical_o3 (atmden, Rad_gases%qo3, vv, Optical)

!--------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_optical_depth (atmden, Rad_gases, Optical) 
      endif

!---------------------------------------------------------------------
!    compute aerosol layer transmission functions for all layers.
!    option predlwaer is planned, but not yet available. when  it 
!    becomes available,  aeralb, aerext and aerconc will be additional 
!    arguments going to aertau.
!---------------------------------------------------------------------
      if (including_aerosols .or. Rad_control%volcanic_lw_aerosols) then
        n_aerosol_bands = Lw_parameters%n_lwaerosol_bands

!---------------------------------------------------------------------
!    allocate space for and then retrieve the aerosol mixing ratios and
!    aerosol optical properties from the aerosol module.
!--------------------------------------------------------------------
        allocate (Optical%totaerooptdep (ix,jx,kx+1, N_AEROSOL_BANDS))
        allocate (Optical%aerooptdep_KE_15 (ix, jx ) )
        Optical%totaerooptdep = 0.                              
        Optical%aerooptdep_KE_15 = 0.           
      endif
!-------------------------------------------------------------------
!    for each aerosol frequency band, retrieve aerosol optical proper-
!    ties for each aerosol category. then call optical_depth_aerosol 
!    to compute for aerosol optical depth. 
!-------------------------------------------------------------------
      do n=1,n_aerosol_bands  !  loop on aerosol frequency bands
        if (including_aerosols) then
          call optical_depth_aerosol (js, Atmos_input, n, Aerosol,   &
                                      Aerosol_props, Aerosol_diags, &
                                      Optical)
        endif   ! (including_aerosols)

        if (Rad_control%volcanic_lw_aerosols) then
          if (size(Aerosol_props%lw_ext,4) /= 0) then
            do j=1,jx
              do i=1,ix
                bsum(1) = 0.0
                do k=2,kx+1
                  if (n == 5) then
                    Aerosol_diags%lw_extopdep_vlcno(i,j,k,1) =  &
                                   Aerosol_props%lw_ext(i,j,k-1,n)*&
                                   Atmos_input%deltaz(i,j,k-1)
                    Aerosol_diags%lw_absopdep_vlcno(i,j,k,1) =  &
                          Aerosol_diags%lw_extopdep_vlcno(i,j,k,1) 
!! NOT CURRENTLY AVAILABLE IN SEA LW CODE -- lw_ssa not processed
!                     Aerosol_diags%lw_absopdep_vlcno(i,j,k,2) =  &
!                              (1.0-Aerosol_props%lw_ssa(i,j,k-1,n))*  &
!                                  Aerosol_props%lw_ext(i,j,k-1,n)*&
!                                  Atmos_input%deltaz(i,j,k-1)
                  endif
                  if (n == 6) then
                    Aerosol_diags%lw_extopdep_vlcno(i,j,k,2) =  &
                                   Aerosol_props%lw_ext(i,j,k-1,n)*&
                                   Atmos_input%deltaz(i,j,k-1)
                    Aerosol_diags%lw_absopdep_vlcno(i,j,k,2) =  &
                           Aerosol_diags%lw_extopdep_vlcno(i,j,k,2) 
!! NOT CURRENTLY AVAILABLE IN SEA LW CODE -- lw_ssa not processed
!                     Aerosol_diags%lw_absopdep_vlcno(i,j,k,1) =  &
!                           (1.0-Aerosol_props%lw_ssa(i,j,k-1,n))*  &
!                                  Aerosol_props%lw_ext(i,j,k-1,n)*&
!                                  Atmos_input%deltaz(i,j,k-1)
                  endif
                  bsum(k) = bsum(k-1) +    &
                            Aerosol_props%lw_ext(i,j,k-1,n)*&
                            Atmos_input%deltaz(i,j,k-1)
                end do
                Optical%totaerooptdep(i,j,2:kx+1,n) =    &
                        Optical%totaerooptdep(i,j,2:kx+1,n) +   &
                        bsum(2:kx+1)
                if (n == n_aerosol_bands) then
                  Optical%aerooptdep_KE_15(i,j) = &
                                Optical%aerooptdep_KE_15(i,j) +  &
                                Aerosol_props%lw_ext(i,j,kx,n)* &
                                Atmos_input%deltaz(i,j,kx)
                endif
              end do   
            end do
          endif ! (size)
        endif  ! (volcanic_lw_aerosols)
      end do  ! (n_aerosol_bnads)

!---------------------------------------------------------------------
       


end subroutine  optical_path_setup



!####################################################################
! <SUBROUTINE NAME="optical_trans_funct_from_KS">
!  <OVERVIEW>
!   Subroutine to compute transmission function from level KS to another
!   level
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute transmission function from level KS to another
!   level
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_trans_funct_from_KS (Gas_tf, to3cnt, overod, Optical, &
!                                        cnttaub1, cnttaub2, cnttaub3)
!  </TEMPLATE>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   Gas transmission functions
!  </INOUT>
!  <OUT NAME="to3cnt" TYPE="real">
!   Ozone continuum transmission function
!  </OUT>
!  <OUT NAME="overod" TYPE="real">
!   Transmission function due to h2o continuum and aerosol
!  </OUT> 
!  <INOUT NAME="Optical" TYPE="real">
!   Optical depth function
!  </INOUT>
!  <OUT NAME="cnttaub1, cnttaub2, cnttaub3" TYPE="real">
!   Transmission functions of gas continuum
!  </OUT>
! </SUBROUTINE>
!
subroutine optical_trans_funct_from_KS (Gas_tf, to3cnt, overod,   &
                                        Optical, cnttaub1, cnttaub2, &
                                        cnttaub3, including_aerosols)  

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension (:,:,:), intent(out)   ::  to3cnt, overod, &
                                           cnttaub1, cnttaub2, cnttaub3
type(optical_path_type), intent(inout) ::  Optical
type(gas_tf_type),       intent(inout) ::  Gas_tf 
logical,                   intent(in)            :: including_aerosols  
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(inout) variables:
!
!     Optical
!     Gas_tf
!
!   intent(out) variables:
!
!     to3cnt
!     overod
!     cnttaub1
!     cnttaub2
!     cnttaub3
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(to3cnt,1), size(to3cnt,2), &
                       size(to3cnt,3)) ::   &
                                               tmp1, tmp2, tmp3,   &
                                               totch2o_tmp,  &
                                               totaer_tmp, tn2o17

      real, dimension (size(to3cnt,1), size(to3cnt,2), &
                       size(to3cnt,3)-1) ::    cfc_tf

      integer    :: m

!---------------------------------------------------------------------
!  local variables:
!
!     tmp1
!     tmp2
!     tmp3
!     totch2o_tmp
!     totaer_tmp
!     tn2o17
!     cfc_tf
!     m
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
              'module has not been initialized', FATAL )
      endif
!-----------------------------------------------------------------------
!    compute transmission functions in 990-1070 cm-1 range, including
!    ozone and h2o continuum, from level KS to all other levels. 
!------------------------------------------------------------------
      if (Lw_control%do_o3) then
        tmp1  (:,:,KS:KE) = bo3rnd(2)*Optical%tphio3(:,:,KS+1:KE+1)/  &
                            Optical%toto3(:,:,KS+1:KE+1)
        tmp2(:,:,KS:KE) = 0.5*(tmp1(:,:,KS:KE)*(SQRT(1.0E+00 +   &
                              (4.0E+00*ao3rnd(2)*  &
                               Optical%toto3(:,:,KS+1:KE+1))/  &
                               tmp1(:,:,KS:KE))  - 1.0E+00))
      else
        tmp2(:,:,KS:KE)  = 0.0E+00
      endif

      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        call get_totch2obd(6, Optical, totch2o_tmp)
        tmp2(:,:,KS:KE) = tmp2(:,:,KS:KE) + diffac*   &
                          totch2o_tmp(:,:,KS+1:KE+1)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp2(:,:,KS:KE) = tmp2(:,:,KS:KE) + betacm(14)*   &
                          Optical%totvo2(:,:,KS+1:KE+1)
      endif

      if (including_aerosols) then
        totaer_tmp(:,:,:) = Optical%totaerooptdep(:,:,:,6)
        tmp2(:,:,KS:KE) = tmp2(:,:,KS:KE) +    &
                          totaer_tmp   (:,:,KS+1:KE+1)
      endif
      to3cnt(:,:,KS) = 1.0
      to3cnt(:,:,KS+1:KE+1) = EXP(-1.0E+00*tmp2(:,:,KS:KE))
 
!--------------------------------------------------------------------
!    if cfcs are included, also include the transmission functions for
!    f11, f12, f113, and f22 in to3cnt.
!---------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_exact (6, Optical, cfc_tf)
        to3cnt(:,:,KS+1:KE+1) = to3cnt(:,:,KS+1:KE+1)* cfc_tf(:,:,KS:KE)
      endif

!---------------------------------------------------------------------
!    compute transmission function in the 560-800 cm-1 range
!    evaluate  optical depth contributions 
!    add contributions from h2o(lines) and h2o(continuum).
!    h2o(continuum) contributions are either Roberts or CKD2.1
!---------------------------------------------------------------------
      if (Lw_control%do_h2o) then
        tmp1(:,:,KS:KE) = SQRT(ab15wd*Optical%totphi(:,:,KS+1:KE+1)) 
      else
        tmp1(:,:,:) = 0.0
      endif
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        tmp1(:,:,KS:KE) = tmp1(:,:,KS:KE) + diffac*   &
                          Optical%totch2obdwd(:,:,KS+1:KE+1)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp1(:,:,KS:KE) = tmp1(:,:,KS:KE) + betawd*   &
                          Optical%totvo2     (:,:,KS+1:KE+1)
      endif

!--------------------------------------------------------------------
!    add contribution from longwave aerosols (if desired).
!--------------------------------------------------------------------
      if (including_aerosols) then
        totaer_tmp(:,:,:) = Optical%totaerooptdep(:,:,:, 9)
        tmp1(:,:,KS:KE) = tmp1(:,:,KS:KE) +    &
                          totaer_tmp(:,:,KS+1:KE+1)
      endif
 
!----------------------------------------------------------------------
!    compute transmission function due to these contributions. the
!    effects of co2, n2o  and  cfc's (not exponentials) are added
!    later.
!---------------------------------------------------------------------
      overod(:,:,KS) = 1.0
      overod(:,:,KS+1:KE+1) = EXP(-1.0E+00*tmp1     (:,:,KS:KE))

!---------------------------------------------------------------------
!    add contribution from the 17 um n2o band (if desired).
!    the expression with tn2o17 retains the 560-630 cm-1 equi-
!    valent widths in evaluating 560-800 cm-1 transmissivities.
!---------------------------------------------------------------------
      if (Lw_control%do_n2o) then
        tn2o17(:,:,ks+1:ke+1) = Gas_tf%tn2o17(:,:,ks+1:ke+1)
        if (NBCO215 .EQ. 2) then
          overod(:,:,KS+1:KE+1) = overod(:,:,KS+1:KE+1) *    &
                                  (130./240. + 110./240.*   &
                                  tn2o17(:,:,KS+1:KE+1))
        elseif (NBCO215 .EQ. 3) then
          overod(:,:,KS+1:KE+1) = overod(:,:,KS+1:KE+1)*(170./240. +  &
                                  70./240.*tn2o17(:,:,KS+1:KE+1))
        endif
      endif

!--------------------------------------------------------------------- 
!    if cfcs are included, also include the transmission functions for
!    f11, f12, f113, and f22 in overod .
!--------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_overod (Optical, cfc_tf)
        overod(:,:,KS+1:KE+1) = overod(:,:,KS+1:KE+1)*cfc_tf(:,:,KS:KE)
      endif 

!----------------------------------------------------------------------
!    compute continuum band transmission functions from level KS to
!    other levels (cnttau). the continuum transmission function from
!    level k to kp (contod) equals cnttau for k=KS, so is not
!    evaluated here. for all other levels k, contod is obtained by
!    division of relevant values of cnttau.
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        call get_totch2obd(4, Optical, totch2o_tmp)
        tmp1(:,:,KS:KE) = diffac*totch2o_tmp(:,:,KS+1:KE+1)
        call get_totch2obd(5, Optical, totch2o_tmp)
        tmp2(:,:,KS:KE) = diffac*totch2o_tmp(:,:,KS+1:KE+1)
        call get_totch2obd(7, Optical, totch2o_tmp)
        tmp3(:,:,KS:KE) = diffac*totch2o_tmp(:,:,KS+1:KE+1)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp1(:,:,KS:KE) = betacm(12)*Optical%totvo2(:,:,KS+1:KE+1)
        tmp2(:,:,KS:KE) = betacm(13)*Optical%totvo2(:,:,KS+1:KE+1)
        tmp3(:,:,KS:KE) = betacm(15)*Optical%totvo2(:,:,KS+1:KE+1)
      endif

      if (including_aerosols) then
        totaer_tmp(:,:,:) = Optical%totaerooptdep(:,:,:,4)
        tmp1(:,:,KS:KE) =  tmp1(:,:,KS:KE) +    &
                           totaer_tmp   (:,:,KS+1:KE+1  )
        totaer_tmp(:,:,:) = Optical%totaerooptdep(:,:,:,5)
        tmp2(:,:,KS:KE) =  tmp2(:,:,KS:KE) +    &
                           totaer_tmp   (:,:,KS+1:KE+1)
        totaer_tmp(:,:,:) = Optical%totaerooptdep(:,:,:,7)
        tmp3(:,:,KS:KE) =  tmp3(:,:,KS:KE) +    &
                           totaer_tmp   (:,:,KS+1:KE+1)
      endif

      cnttaub1(:,:,KS) = 1.0                       
      cnttaub2(:,:,KS) = 1.0                       
      cnttaub3(:,:,KS) = 1.0                       
      cnttaub1(:,:,KS+1:KE+1) = EXP(-1.0*tmp1(:,:,KS:KE))
      cnttaub2(:,:,KS+1:KE+1) = EXP(-1.0*tmp2(:,:,KS:KE))
      cnttaub3(:,:,KS+1:KE+1) = EXP(-1.0*tmp3(:,:,KS:KE))

!---------------------------------------------------------------------
!    if cfcs are included, add transmission functions for f11, f12,
!    f113, and f22.
!---------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_exact (4, Optical, cfc_tf)
        cnttaub1(:,:,KS+1:KE+1) = cnttaub1(:,:,KS+1:KE+1)*  &
                                  cfc_tf(:,:,KS:KE)
        call cfc_exact (5, Optical, cfc_tf)
        cnttaub2(:,:,KS+1:KE+1) = cnttaub2(:,:,KS+1:KE+1)*  &
                                  cfc_tf(:,:,KS:KE)
        call cfc_exact (7, Optical, cfc_tf)
        cnttaub3(:,:,KS+1:KE+1) = cnttaub3(:,:,KS+1:KE+1)*   &
                                  cfc_tf(:,:,KS:KE)
      endif 
 
!----------------------------------------------------------------------
!    evaluate h2o (mbar*phibar) between level KS and other levels.
!----------------------------------------------------------------------
      Optical%avephi(:,:,KS:KE) = Optical%totphi(:,:,KS+1:KE+1)
 
!----------------------------------------------------------------------
!    the evaluation of emiss over the layer between data level (KS)
!    and flux level (KE+1) is done by averaging E2 functions referring
!    to the top and bottom of the layer. a special value of (mbar*
!    phibar) is required; it is stored in the (otherwise vacant)
!    KE+1'th position of avephi.
!----------------------------------------------------------------------
      Optical%avephi(:,:,KE+1) = Optical%avephi(:,:,KE-1) +   &
                                 Optical%emx1(:,:)

!----------------------------------------------------------------------
!    if h2o lines in the 1200-1400 range are assumed to have a temp-
!    erature dependent intensity, similar evaluation for (mbar*phibar)
!    is performed, with a special value for the lowest layer
!----------------------------------------------------------------------
      if (NBTRGE > 0) then
        if (tmp_dpndnt_h2o_lines) then
          do m=1,NBTRGE
            Optical%avephif(:,:,KS:KE,m) =     &
                                       Optical%tphfh2o(:,:,KS+1:KE+1,m)
          end do
          do m=1,NBTRGE
            Optical%avephif(:,:,KE+1,m) =   &
                                        Optical%avephif(:,:,KE-1,m) +  &
                                        Optical%emx1f(:,:,m)
          end do
        else 
          do m=1,NBTRGE
            Optical%avephif(:,:,KS:KE,m) =     &
                                       Optical%avephi(:,:,KS:KE)
          end do
          do m=1,NBTRGE
            Optical%avephif(:,:,KE+1,m) = Optical%avephi(:,:,KE+1)
          end do
        endif
      endif

!----------------------------------------------------------------------


end subroutine optical_trans_funct_from_KS




!####################################################################
! <SUBROUTINE NAME="optical_trans_funct_k_down">
!  <OVERVIEW>
!   Subroutine to compute transmission function downward from level k
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute transmission function downward from level k
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_trans_funct_k_down (Gas_tf, k,                     &
!                                    to3cnt, overod, Optical)
!  </TEMPLATE>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   Gas transmission functions
!  </INOUT>
!  <IN NAME="k" TYPE="integer">
!   The data level from which downward transmission functions are computed
!  </IN>
!  <OUT NAME="to3cnt" TYPE="real">
!   Ozone continuum transmission function
!  </OUT>
!  <OUT NAME="overod" TYPE="real">
!   Transmission function due to h2o continuum and aerosol
!  </OUT> 
!  <INOUT NAME="Optical" TYPE="real">
!   Optical depth function
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_trans_funct_k_down (Gas_tf, k, to3cnt, overod,   &
                                       Optical,including_aerosols)  

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

integer,                 intent (in)    :: k
real, dimension (:,:,:), intent(out)    :: to3cnt, overod
type(optical_path_type), intent(inout)  :: Optical
type(gas_tf_type),       intent(inout)  :: Gas_tf 
logical,                   intent(in)            :: including_aerosols  

!---------------------------------------------------------------------
!   intent(in) variable:
!        
!       k
!
!   intent(inout) variables:
!
!       Optical
!       Gas_tf
!
!   intent(out) variables:
!
!       to3cnt
!       overod
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (size(to3cnt,1), size(to3cnt,2), &
                       size(to3cnt,3)) ::    &
                                                avmo3, avpho3, tmp1, &
                                                tmp2, avvo2,  &
                                                avckdwd, avckdo3, &
                                                avaero3, totch2o_tmp,  &
                                                totaer_tmp, tn2o17

      real, dimension (size(to3cnt,1), size(to3cnt,2), &
                       size(to3cnt,3)-1) ::     cfc_tf

      integer       :: kp, m

!---------------------------------------------------------------------
!   local variables:
!
!       avmo3
!       avpho3
!       tmp1
!       tmp2
!       avvo2
!       avchdwd
!       avckdo3
!       avaero3  
!       totch2o_tmp
!       totaer_tmp
!       tn2o17
!       cfc_tf
!       kp
!       m
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
              'module has not been initialized', FATAL )
      endif
!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        call get_totch2obd(6, Optical, totch2o_tmp)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (including_aerosols) then
        totaer_tmp(:,:,:) = Optical%totaerooptdep(:,:,:,6)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do kp=1,KE+1-k
        avmo3 (:,:,kp+k-1) = Optical%toto3 (:,:,kp+k) -    &
                             Optical%toto3 (:,:,k)
        avmo3 (:,:,kp+k-1) = max(avmo3 (:,:,kp+k-1),1.0e-10)
        avpho3(:,:,kp+k-1) = Optical%tphio3(:,:,kp+k) -    &
                             Optical%tphio3(:,:,k) 
        avpho3 (:,:,kp+k-1) = max(avpho3 (:,:,kp+k-1),1.0e-12)
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          avckdwd(:,:,kp+k-1) = Optical%totch2obdwd(:,:,kp+k) -   &
                                Optical%totch2obdwd(:,:,k)
          avckdo3(:,:,kp+k-1) = totch2o_tmp(:,:,kp+k) -  &
                                totch2o_tmp(:,:,k)
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          avvo2 (:,:,kp+k-1) = Optical%totvo2(:,:,kp+k) -   &
                               Optical%totvo2(:,:,k)
        endif 
        if (including_aerosols) then
          avaero3(:,:,kp+k-1) =  &
                       totaer_tmp   (:,:,kp+k) - totaer_tmp   (:,:,k)
         endif
       end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
       do kp=1,KE+1-k
         Optical%avephi  (:,:,kp+k-1) = Optical%totphi(:,:,kp+k) -  &
                                        Optical%totphi(:,:,k)
       end do
       Optical%avephi (:,:,KE+1) = Optical%avephi(:,:,KE-1) +   &
                                   Optical%emx1(:, :)

!---------------------------------------------------------------------
!    if h2o lines in the 1200-1400 range are assumed to have a temp-
!    erature dependent intensity, similar evaluation for (mbar*phibar)
!    is performed, with a special value for the lowest layer
!---------------------------------------------------------------------
      if (NBTRGE > 0) then
        if (tmp_dpndnt_h2o_lines) then
          do m=1,NBTRGE
            do kp=1,KE+1-k
              Optical%avephif(:,:,kp+k-1,m) =   &
                                     Optical%tphfh2o(:,:,kp+k,m) -  &
                                     Optical%tphfh2o(:,:,k,   m)
            end do
            Optical%avephif(:,:,KE+1,m) =   &
                                         Optical%avephif(:,:,KE-1,m) + &
                                         Optical%emx1f(:,:,m)
          end do
        else
          do m=1,NBTRGE
            do kp=1,KE+1-k
              Optical%avephif(:,:,kp+k-1,m) = Optical%avephi(:,:,kp+k-1)
            end do
            Optical%avephif(:,:,KE+1,m) = Optical%avephi(:,:,KE+1) 
          end do
        endif
      endif

!----------------------------------------------------------------------
!    compute transmission function in the 560-800 cm-1 range
!    evaluate  optical depth contributions 
!
!    add contributions from h2o(lines) and h2o(continuum).
!    h2o(continuum) contributions are either Roberts or CKD2.1
!----------------------------------------------------------------------
      if (Lw_control%do_h2o) then 
        tmp1(:,:,k:KE) = SQRT(ab15wd*Optical%avephi(:,:,k:KE)) 
      else
        tmp1(:,:,k:KE) = 0.0
      endif

      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        tmp1(:,:,k:KE) = tmp1(:,:,k:KE) + diffac*   &
                         avckdwd    (:,:,k:KE)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp1(:,:,k:KE) = tmp1(:,:,k:KE) + betawd*   &
                         avvo2      (:,:,k:KE)
      endif

!-------------------------------------------------------------------
!    add contribution from longwave aerosols (if desired).
!-------------------------------------------------------------------
      if (including_aerosols) then
        totaer_tmp      (:,:,:) = Optical%totaerooptdep   (:,:,:,9)
        do kp=k,KE
          tmp1(:,:,kp) = tmp1(:,:,kp) +    &
                         (totaer_tmp(:,:,kp+1) - totaer_tmp(:,:,k) )
        end do
      endif

!---------------------------------------------------------------------
!    compute transmission function due to these contributions. the
!    effects of co2, n2o  and  cfc's (not exponentials) are added
!    later.
!--------------------------------------------------------------------
      overod(:,:,k+1:KE+1) = EXP(-1.0E+00*tmp1(:,:,k:KE))

!----------------------------------------------------------------------
!    add contribution from the 17 um n2o band (if desired).
!    the expression with tn2o17 retains the 560-630 cm-1 equi-
!    valent widths in evaluating 560-800 cm-1 transmissivities.
!---------------------------------------------------------------------
      if (Lw_control%do_n2o) then
        tn2o17(:,:,k+1:ke+1) = Gas_tf%tn2o17(:,:,k+1:ke+1)
        if (NBCO215 .EQ. 2) then
          overod(:,:,k+1:KE+1) = overod(:,:,k+1:KE+1) *(130./240. +  &
                                 110./240.*tn2o17(:,:,k+1:KE+1))
        elseif (NBCO215 .EQ. 3) then
          overod(:,:,k+1:KE+1) = overod(:,:,k+1:KE+1)*(170./240. + &
                                 70./240.*tn2o17(:,:,k+1:KE+1))
        endif
      endif

!----------------------------------------------------------------------
!    if cfcs are included, also include the transmission functions for
!    f11, f12, f113, and f22 in overod .
!----------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_overod_part ( Optical, cfc_tf, k)
        overod(:,:,k+1:KE+1) = overod(:,:,k+1:KE+1)*cfc_tf(:,:,k:KE)
      endif

!--------------------------------------------------------------------
!    compute transmission functions in 990-1070 cm-1 range, including
!    ozone and h2o continuum, from level k to all other levels. 
!---------------------------------------------------------------------
      if (Lw_control%do_o3) then
        tmp1  (:,:,k:KE) = bo3rnd(2)*avpho3(:,:,k:KE)/avmo3(:,:,k:KE)
        tmp2(:,:,k:KE) = 0.5*(tmp1(:,:,k:KE)*(SQRT(1.0E+00 + (4.0E+00* &
                           ao3rnd(2)*avmo3(:,:,k:KE))/tmp1(:,:,k:KE))  &
                           - 1.0E+00))
      else
        tmp2(:,:,k:KE) = 0.0
      endif

      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        tmp2(:,:,k:KE) = tmp2(:,:,k:KE) + diffac*   &
                         avckdo3  (:,:,k:KE) 
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp2(:,:,k:KE) = tmp2(:,:,k:KE) + betacm(14)*   &
                         avvo2 (:,:,k:KE)
      endif
      if (including_aerosols) then
        tmp2(:,:,k:KE) = tmp2(:,:,k:KE) +   &
                         avaero3      (:,:,k:KE)
      endif
      to3cnt(:,:,k+1:KE+1) = EXP(-1.0E+00*tmp2(:,:,k:KE))

!---------------------------------------------------------------------
!    if cfcs are included, also include the transmission functions for
!    f11, f12, f113, and f22 in to3cnt.
!---------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_exact_part (6, Optical, cfc_tf, k)
        to3cnt(:,:,k+1:KE+1) = to3cnt(:,:,k+1:KE+1)*cfc_tf(:,:,k:KE)
      endif 
!---------------------------------------------------------------------


end subroutine optical_trans_funct_k_down



!#################################################################
! <SUBROUTINE NAME="optical_trans_funct_KE">
!  <OVERVIEW>
!   Subroutine to compute transmission function from level KE
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute transmission function from level KE
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_trans_funct_KE (Gas_tf, to3cnt, Optical, overod)
!  </TEMPLATE>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   Gas transmission functions
!  </INOUT>
!  <OUT NAME="to3cnt" TYPE="real">
!   Ozone continuum transmission function
!  </OUT>
!  <OUT NAME="overod" TYPE="real">
!   Transmission function due to h2o continuum and aerosol
!  </OUT> 
!  <INOUT NAME="Optical" TYPE="real">
!   Optical depth function
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_trans_funct_KE (Gas_tf, to3cnt, Optical, overod, &
                                   including_aerosols)  

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real, dimension (:,:,:), intent(out)   :: to3cnt, overod
type(optical_path_type), intent(inout) :: Optical
type(gas_tf_type),       intent(inout) :: Gas_tf 
logical,                   intent(in)            :: including_aerosols  

!---------------------------------------------------------------------
!   intent(inout) variables:
!
!     Optical
!     Gas_tf
!
!   intent(out) variables:
!
!     to3cnt
!     overod
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!   local variables:

      real, dimension (size(to3cnt,1), size(to3cnt,2), &
                       size(to3cnt,3)) ::    &
                                             tmp1, tmp2, tn2o17

      real, dimension (size(to3cnt,1), size(to3cnt,2), &
                       size(to3cnt,3)-1) ::    &
                                             cfc_tf

      real, dimension (size(to3cnt,1), size(to3cnt,2)) :: &
                                             aerooptdep_KE_15

!---------------------------------------------------------------------
!   local variables:
!
!      tmp1
!      tmp2
!      tn2o17
!      cfc_tf
!      aer_tmp
!      aerooptdep_KE_15
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
             'module has not been initialized', FATAL )
      endif

!-----------------------------------------------------------------------
!    compute transmission function in the 560-800 cm-1 range. evaluate 
!    optical depth contributions. add contributions from h2o(lines) and
!    h2o(continuum). h2o(continuum) contributions are either Roberts 
!    or CKD2.1 or CKD2.4.
!----------------------------------------------------------------------
      if (Lw_control%do_h2o) then
        tmp1     (:,:,KE) = SQRT(ab15wd*Optical%var2  (:,:,KE)) 
      else
        tmp1     (:,:,KE) = 0.0
      endif
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        tmp1(:,:,KE) = tmp1(:,:,KE) + diffac*   &
                       Optical%xch2obdwd   (:,:,KE)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp1(:,:,KE) = tmp1(:,:,KE) + betawd*  &
                       Optical%cntval     (:,:,KE)
      endif

!---------------------------------------------------------------------
!    add contribution from longwave aerosols (if desired).
!---------------------------------------------------------------------
      if (including_aerosols) then
        aerooptdep_KE_15(:,:) = Optical%aerooptdep_KE_15(:,:)
        tmp1(:,:,KE) = tmp1(:,:,KE) + aerooptdep_KE_15(:,:)  
      endif
 
!---------------------------------------------------------------------
!    compute transmission function due to these contributions. the
!    effects of co2, n2o  and  cfc's (not exponentials) are added
!    later.
!---------------------------------------------------------------------
      overod(:,:,KE+1) = EXP(-1.0E+00*tmp1     (:,:,KE))
 
!---------------------------------------------------------------------
!    add contribution from the 17 um n2o band (if desired).
!    the expression with tn2o17 retains the 560-630 cm-1 equi-
!    valent widths in evaluating 560-800 cm-1 transmissivities.
!---------------------------------------------------------------------
      if (Lw_control%do_n2o) then
        tn2o17(:,:,ke+1    ) = Gas_tf%tn2o17(:,:,ke+1)
        if (NBCO215 .EQ. 2) then
          overod(:,:,KE+1) = overod(:,:,KE+1) *  &
                             (130./240. + 110./240.*tn2o17(:,:,KE+1))
        else if (NBCO215 .EQ. 3) then
          overod(:,:,KE+1) = overod(:,:,KE+1) *   &
                             (170./240. + 70./240.*tn2o17(:,:,KE+1))
        endif
      endif

!---------------------------------------------------------------------
!    if cfcs are included, also include the transmission functions for
!    f11, f12, f113, and f22 in overod .
!---------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_overod_part (Optical, cfc_tf, KE)
        overod(:,:,KE+1) = overod(:,:,KE+1)*cfc_tf(:,:,KE)
      endif 

!-----------------------------------------------------------------------
!    compute transmission functions in 990-1070 cm-1 range, including
!    ozone and h2o continuum, from level KS to all other levels. 
!---------------------------------------------------------------------
      if (Lw_control%do_o3) then
        tmp1  (:,:,KE) = bo3rnd(2)*Optical%var4(:,:,KE)/  &
                         Optical%var3(:,:,KE)
        tmp2(:,:,KE) = 0.5*(tmp1(:,:,KE)*(SQRT(1.0E+00 + (4.0E+00*  &
                       ao3rnd(2)*Optical%var3 (:,:,KE))/  &
                       tmp1(:,:,KE)) - 1.0E+00))
      else
        tmp2(:,:,KE) = 0.0
      endif

      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        tmp2(:,:,KE) = tmp2(:,:,KE) + diffac*Optical%xch2obd  (:,:,KE,6)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        tmp2(:,:,KE) = tmp2(:,:,KE) + betacm(14)*Optical%cntval (:,:,KE)
      endif

      to3cnt(:,:,KE+1) = EXP(-1.0E+00*tmp2(:,:,KE))

!---------------------------------------------------------------------
!    if cfcs are included, also include the transmission functions for
!    f11, f12, f113, and f22 in overod and to3cnt.
!---------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_exact_part (6, Optical, cfc_tf, KE)
        to3cnt(:,:,KE+1) = to3cnt(:,:,KE+1)*cfc_tf(:,:,KE)
      endif

!-------------------------------------------------------------------


end subroutine optical_trans_funct_KE




!####################################################################
! <SUBROUTINE NAME="optical_trans_funct_diag">
!  <OVERVIEW>
!   Subroutine to compute diagnostic transmission function
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute diagnostic transmission function
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_trans_funct_diag (Atmos_input, contdg, to3dg, &
!                                  Optical)
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data
!  </IN>
!  <OUT NAME="to3dg" TYPE="real">
!   Ozone continuum diagnostic transmission function
!  </OUT>
!  <OUT NAME="contdg" TYPE="real">
!   Diagnostic continuum transmission functions
!  </OUT> 
!  <INOUT NAME="Optical" TYPE="real">
!   Optical depth function
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_trans_funct_diag (Atmos_input, contdg, to3dg, &
                                     Optical)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real, dimension (:,:,:),   intent(out)   :: to3dg                
real, dimension (:,:,:,:), intent(out)   :: contdg               
type(optical_path_type),   intent(inout) :: Optical
type(atmos_input_type),    intent(in)    :: Atmos_input

!---------------------------------------------------------------------
!   intent(in) variables:
!
!     Atmos_input
!
!   intent(inout) variables:
!
!     Optical
!
!   intent(out) variables:
!
!     to3dg
!     contdg
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension (size(Atmos_input%pflux,1),             &
                       size(Atmos_input%pflux,2),             &
                       size(Atmos_input%pflux,3)-1) ::        &
                                                       pdfinv

      real, dimension (size(Atmos_input%pflux,1),          &
                       size(Atmos_input%pflux,2), &
                       size(Atmos_input%pflux,3)) ::  &
                                    press, pflux, ca, cb, csuba,  &
                                    csubb, ctmp2, ctmp3, delpr1, delpr2

!---------------------------------------------------------------------
!   local variables:
!
!      pdfinv
!      press 
!      pflux 
!      ca        
!      cb      
!      csuba 
!      csubb 
!      ctmp2 
!      ctmp3 
!      delpr1
!      delpr2
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
               'module has not been initialized', FATAL )
      endif
!---------------------------------------------------------------------
!    convert press and pflux to cgs.
!---------------------------------------------------------------------
      press(:,:,:) = 10.0*Atmos_input%press(:,:,:)
      pflux(:,:,:) = 10.0*Atmos_input%pflux(:,:,:)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      pdfinv(:,:,ks:ke) = 1.0/(pflux(:,:,ks+1:ke+1) - pflux(:,:,ks:ke))
      delpr1(:,:,KS+1:KE)   = pdfinv (:,:,KS+1:KE)*  &
                              (press(:,:,KS+1:KE) - pflux(:,:,KS+1:KE)) 
      delpr2(:,:,KS+1:KE+1) = pdfinv(:,:,KS:KE)*   &
                              (pflux(:,:,KS+1:KE+1) - press(:,:,KS:KE)) 

!-----------------------------------------------------------------------
!    compute nearby-layer transmissivities for the o3 band and for the
!    one-band continuum band.  the sf function is used.
!    the method is the same as described for co2 in reference(4).
!-----------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'rsb' ) then
        ctmp2(:,:,KS+1:KE)  = Optical%cntval(:,:,KS+1:KE)*  &
                              delpr1(:,:,KS+1:KE) 
        ctmp3(:,:,KS+1:KE)  = Optical%cntval(:,:,KS:KE-1)*   &
                              delpr2(:,:,KS+1:KE) 
      endif
    
!-----------------------------------------------------------------------
!    compute sf2.
!    continuum band 1
!-----------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        csuba(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS+1:KE,4)*  &
                              delpr1(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS:KE-1,4)*  &
                              delpr2(:,:,KS+1:KE)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        csuba(:,:,KS+1:KE)  = betacm(12)*ctmp2(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = betacm(12)*ctmp3(:,:,KS+1:KE)
      endif
      ca    (:,:,KS+1:KE) = csuba(:,:,KS+1:KE)*(-0.5E+00 +    &
                            csuba(:,:,KS+1:KE)*(0.166666E+00 -  &
                            csuba(:,:,KS+1:KE)*0.416666E-01))   
      cb    (:,:,KS+1:KE) = csubb(:,:,KS+1:KE)*(-0.5E+00 +  &
                            csubb(:,:,KS+1:KE)*(0.166666E+00 - &
                            csubb(:,:,KS+1:KE)*0.416666E-01)) 
      contdg(:,:,KE+1,1)    = 1.0E+00 + cb (:,:,KE)
      contdg(:,:,KS+1:KE,1) = 1.0E+00 + 0.5E+00*(ca (:,:,KS+1:KE) +  &
                              cb (:,:,KS+1:KE))

!--------------------------------------------------------------------
!    continuum band 2
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        csuba(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS+1:KE,5)*   &
                              delpr1(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS:KE-1,5)*  &
                              delpr2(:,:,KS+1:KE)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        csuba(:,:,KS+1:KE)  = betacm(13)*ctmp2(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = betacm(13)*ctmp3(:,:,KS+1:KE)
      endif
      ca    (:,:,KS+1:KE) = csuba(:,:,KS+1:KE)*(-0.5E+00 +  &
                            csuba(:,:,KS+1:KE)*(0.166666E+00 -   &
                            csuba(:,:,KS+1:KE)*0.416666E-01)) 
      cb    (:,:,KS+1:KE) = csubb(:,:,KS+1:KE)*(-0.5E+00 +   &
                            csubb(:,:,KS+1:KE)*(0.166666E+00 -   &
                            csubb(:,:,KS+1:KE)*0.416666E-01)) 
      contdg(:,:,KE+1,2)    = 1.0E+00 + cb (:,:,KE)
      contdg(:,:,KS+1:KE,2) = 1.0E+00 + 0.5E+00*(ca (:,:,KS+1:KE) +  &
                              cb (:,:,KS+1:KE))

!--------------------------------------------------------------------
!    continuum band 3
!--------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        csuba(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS+1:KE,7)*   &
                              delpr1(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS:KE-1,7)*  &
                              delpr2(:,:,KS+1:KE)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        csuba(:,:,KS+1:KE)  = betacm(15)*ctmp2(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = betacm(15)*ctmp3(:,:,KS+1:KE)
      endif
      ca    (:,:,KS+1:KE) = csuba(:,:,KS+1:KE)*(-0.5E+00 +    &
                            csuba(:,:,KS+1:KE)*(0.166666E+00 -  &
                            csuba(:,:,KS+1:KE)*0.416666E-01)) 
      cb    (:,:,KS+1:KE) = csubb(:,:,KS+1:KE)*(-0.5E+00 +   &
                            csubb(:,:,KS+1:KE)*(0.166666E+00 -  &
                            csubb(:,:,KS+1:KE)*0.416666E-01)) 
      contdg(:,:,KE+1,3)    = 1.0E+00 + cb (:,:,KE)
      contdg(:,:,KS+1:KE,3) = 1.0E+00 + 0.5E+00*(ca (:,:,KS+1:KE) +   &
                              cb (:,:,KS+1:KE))

!--------------------------------------------------------------------
!    ozone band
!--------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        csuba(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS+1:KE,6)*   &
                              delpr1(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = diffac*Optical%xch2obd(:,:,KS:KE-1,6)*  &
                              delpr2(:,:,KS+1:KE)
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        csuba(:,:,KS+1:KE)  = betacm(14)*ctmp2(:,:,KS+1:KE)
        csubb(:,:,KS+1:KE)  = betacm(14)*ctmp3(:,:,KS+1:KE)
      endif
      ca   (:,:,KS+1:KE)  = csuba(:,:,KS+1:KE)*(-0.5E+00 +   &
                            csuba(:,:,KS+1:KE)*   &
                            (0.166666E+00 - csuba(:,:,KS+1:KE)*  &
                            0.416666E-01)) 
      cb   (:,:,KS+1:KE)  = csubb(:,:,KS+1:KE)*(-0.5E+00 +  &
                            csubb(:,:,KS+1:KE)*   &
                            (0.166666E+00 - csubb(:,:,KS+1:KE)*   &
                            0.416666E-01)) 
      to3dg (:,:,KE+1)    = 1.0E+00 + cb(:,:,KE)
      to3dg (:,:,KS+1:KE) = 1.0E+00 + 0.5E+00*(ca(:,:,KS+1:KE) +   &
                            cb(:,:,KS+1:KE))

!-------------------------------------------------------------------



end subroutine optical_trans_funct_diag


!###################################################################
! <SUBROUTINE NAME="get_totch2o">
!  <OVERVIEW>
!   Subroutine to compute self broadened temperature dependent
!   water vapor continuum
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute self broadened temperature dependent
!   water vapor continuum
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_totch2o (n, Optical, totch2o, dte1, ixoe1)
!  </TEMPLATE>
!  <IN NAME="n" TYPE="integer">
!   frequency band index
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth output
!  </INOUT>
!  <OUT NAME="totch2o" TYPE="real">
!   self broadened and temperature dependent continuum
!  </OUT>
!  <IN NAME="dte1" TYPE="real">
!   temperature step delta
!  </IN>
!  <IN NAME="ixoe1" TYPE="integer">
!   temperature index array
!  </IN>
! </SUBROUTINE>
!
subroutine get_totch2o (n, Optical, totch2o, dte1, ixoe1)

!------------------------------------------------------------------
!
!------------------------------------------------------------------

real, dimension(:,:,:),    intent(in)      :: dte1    
type(optical_path_type),   intent(inout)   :: Optical
integer, dimension(:,:,:), intent(in)      :: ixoe1   
real, dimension(:,:,:),    intent(out)     :: totch2o
integer,                   intent(in)      :: n

!-----------------------------------------------------------------
!   intent(in) variables:
!
!        dte1
!        ixoe1
!        n
!      
!   intent(inout) variables:
!        Optical
!
!   intent(out) variables:
!
!        totch2o
!
!---------------------------------------------------------------------

!------------------------------------------------------------------
!   local variables:

      real, dimension (size(Optical%tfac,1), size(Optical%tfac,2), &
                       size(Optical%tfac,3)) ::     &
                                                 radf, sh2o , tmpexp

      real               ::  fh2o0, sh2o0
      integer            ::  k, nu

!------------------------------------------------------------------
!   local variables:
!
!       radf
!       sh2o
!       tmpexp
!       fh2o0
!       sh2o0
!       k
!       nu
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
              'module has not been initialized', FATAL )
      endif
!--------------------------------------------------------------------
!    compute self-broadened temperature-dependent continuum coefficient
!    using the single coefficient -.013 for all frequencies in
!    the 160-560 cm-1 range. experiments with the mid-latitude
!    summer profile show errors of < .01 W/m**2 (in the net broadband
!    flux, 0-2200 cm-1) using this value. this value is used instead
!    of tmpfctrs at each frequency band.
!--------------------------------------------------------------------
      tmpexp(:,:,KS:KE) = EXP(-.013*Optical%tfac(:,:,KS:KE))

!--------------------------------------------------------------------
!    compute source function for frequency bands (ioffh2o+1 to ioffh2o
!    +nptch2o) at layer temperatures using table lookup.
!    note that ixoe1 can be used for temp index, and dte1 for deltat,
!    as the table extent for radf is the same as for the e1 tables
!    of the model.
!--------------------------------------------------------------------
      nu = n
      call looktab (radfunc, ixoe1, dte1, radf, KS, KE, nu+ioffh2o)
      sh2o0 = ssh2o_296(nu+ioffh2o)*sfac(nu+ioffh2o)

      do k=KS,KE 
        sh2o(:,:,k) = sh2o0*        tmpexp(:,:,k)
      end do
 
!--------------------------------------------------------------------
!    compute h2o self- and foreign- broadened continuum optical path,
!    summed from the top of the atmosphere through layer k.
!--------------------------------------------------------------------
      fh2o0 = sfh2o(nu+ioffh2o)*fscal(nu+ioffh2o)
      totch2o(:,:,1) = 0.0E+00
      do k = KS+1,KE+1
        totch2o(:,:,k) = Optical%wk(:,:,k-1)*1.0e-20*   &
                         (sh2o(:,:,k-1)*Optical%rh2os(:,:,k-1) +    &
                          fh2o0*Optical%rfrgn(:,:,k-1))* &
                          vvj(nu)*radf(:,:,k-1   )    +   &
                          totch2o(:,:,k-1)
      end do

!------------------------------------------------------------------

end subroutine get_totch2o



!#####################################################################
! <SUBROUTINE NAME="get_totch2obd">
!  <OVERVIEW>
!   Subroutine to compute self broadened temperature dependent
!   water vapor continuum
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute self broadened temperature dependent
!   water vapor continuum
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_totch2obd (n, Optical, totch2obd)
!  </TEMPLATE>
!  <IN NAME="n" TYPE="integer">
!   frequency band index
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth output
!  </INOUT>
!  <OUT NAME="totch2obd" TYPE="real">
!   self broadened and temperature dependent h2o continuum
!  </OUT>
! </SUBROUTINE>
!
subroutine get_totch2obd (n, Optical, totch2obd)

!------------------------------------------------------------------
!
!------------------------------------------------------------------

real, dimension(:,:,:), intent(out)     :: totch2obd
integer,                intent(in)      :: n
type(optical_path_type), intent(inout) :: Optical

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      n
!
!   intent(inout) variable:
!
!      Optical
!
!   intent(out) variable:
!
!      totch2obd
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer            ::  k, nu

!--------------------------------------------------------------------
!  local variables:
!
!      k
!      nu
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
              'module has not been initialized', FATAL )
      endif
!---------------------------------------------------------------------
!    compute h2o self- and foreign- broadened continuum optical path 
!    for each layer k (xch2obd, xch2obdinw, xch2obdwd) and summed from
!    the top of the atmosphere through layer k (totch2obd,
!    totch2obdinw, totch2obdwd).
!---------------------------------------------------------------------
      nu = n     
      totch2obd(:,:,1) = 0.0E+00
      do k = KS+1,KE+1
        totch2obd(:,:,k) = totch2obd(:,:,k-1) +   &
                           Optical%xch2obd(:,:,k-1,nu)
      end do

!--------------------------------------------------------------------
 
end subroutine get_totch2obd




!#####################################################################
! <SUBROUTINE NAME="get_totvo2">
!  <OVERVIEW>
!   Subroutine to compute continuum coefficients in band n
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute continuum coefficients in band n
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_totvo2 (n, Optical, totvo2_out) 
!  </TEMPLATE>
!  <IN NAME="n" TYPE="integer">
!   frequency band index
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth output
!  </INOUT>
!  <OUT NAME="totvo2_out" TYPE="real">
!   Continuum coefficients in band n
!  </OUT>
! </SUBROUTINE>
!
subroutine get_totvo2 (n, Optical, totvo2_out) 

!------------------------------------------------------------------
!
!------------------------------------------------------------------

integer,                 intent(in)       :: n
type(optical_path_type), intent(inout)    :: Optical
real, dimension(:,:,:),  intent(out)      :: totvo2_out

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      n
!
!   intent(inout) variable:
!
!      Optical
!
!   intent(out) variable:
!
!      totvo2_out
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
             'module has not been initialized', FATAL )
      endif

!-----------------------------------------------------------------

      totvo2_out(:,:,:) = betacm(n)*Optical%totvo2(:,:,KS+1:KE+1)

end subroutine get_totvo2 



!####################################################################
! <SUBROUTINE NAME="optical_dealloc">
!  <OVERVIEW>
!   Subroutine to deallocate the array components of the 
!   optical_path_type input variable.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine deallocates the array components of the 
!   optical_path_type input variable. Dependent on the namelist
!   options chosen, some of the arrays may or may nothave been
!   allocated.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_dealloc (Optical)            
!  </TEMPLATE>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Derived type variable containing information related to
!   the computation of optical depth associated with 
!   different atmospheric constituents. 
!  </INOUT>
! </SUBROUTINE>
!

subroutine optical_dealloc (Optical, including_aerosols)  

!-------------------------------------------------------------------
!    optical_dealloc deallocates the array components of the 
!    optical_path_type input variable.
!--------------------------------------------------------------------

type(optical_path_type), intent(inout) :: Optical
logical,                   intent(in)            :: including_aerosols  

!--------------------------------------------------------------------
! intent(inout) variables:
!
!    Optical       optical_path_type variable containing fields used
!                  in the calculation of optical paths for various
!                  atmospheric constituents
! 
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    deallocate the array elements of Optical.
!--------------------------------------------------------------------
       deallocate (Optical%empl1          )
       deallocate (Optical%empl2          )
       deallocate (Optical%var1           )
       deallocate (Optical%var2           )
       deallocate (Optical%avephi         )
       deallocate (Optical%totphi         )
       deallocate (Optical%emx1           )
       deallocate (Optical%emx2           )

 
       if (NBTRGE > 0) then
         deallocate (Optical%avephif        )
         deallocate (Optical%emx1f          )
         deallocate (Optical%emx2f          )
         deallocate (Optical%empl1f         )
         deallocate (Optical%empl2f         )
         deallocate (Optical%vrpfh2o        )
         deallocate (Optical%tphfh2o         )
       endif
 
       if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
           trim(Lw_control%continuum_form) == 'ckd2.4' ) then
         deallocate (Optical%xch2obd        )
         deallocate (Optical%totch2obdwd    )
         deallocate (Optical%xch2obdwd      )
       else if (trim(Lw_control%continuum_form) == 'rsb' ) then
         deallocate (Optical%cntval         )
         deallocate (Optical%totvo2         )
       endif
 
       deallocate (Optical%toto3          )
       deallocate (Optical%tphio3         )
       deallocate (Optical%var3           )
       deallocate (Optical%var4           )
       deallocate (Optical%wk             )
       deallocate (Optical%rh2os          )
       deallocate (Optical%rfrgn          )
       deallocate (Optical%tfac           )

       if (Lw_control%do_cfc) then
         deallocate (Optical%totf11         )
         deallocate (Optical%totf12         )
         deallocate (Optical%totf113         )
         deallocate (Optical%totf22         )
       endif

       if (including_aerosols) then
         deallocate (Optical%totaerooptdep  )
         deallocate (Optical%aerooptdep_KE_15  )
       endif

!-------------------------------------------------------------------


end subroutine optical_dealloc



!####################################################################
! <SUBROUTINE NAME="optical_path_end">
!  <OVERVIEW>
!   optical_path_end is the destructor for optical_path_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   optical_path_end is the destructor for optical_path_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_depth_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine optical_path_end

!--------------------------------------------------------------------
!    optical_path_end is the destructor for optical_path_mod.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'optical_path_mod',  &
             'module has not been initialized', FATAL )
      endif

!-----------------------------------------------------------------
!    mark the module as uninitialized.
!-----------------------------------------------------------------
      module_is_initialized = .false.

!------------------------------------------------------------------



end subroutine optical_path_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  
                                   
                                  
!###################################################################
! <SUBROUTINE NAME="optical_ckd_init">
!  <OVERVIEW>
!   Subroutine to initialize water vapor self and foreign broadened
!   continuum coefficients. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   Idckdh2o reads ckd2.1 self and foreign-broadened h2o continuum
!   coefficients, corrections, and coefficients for temperature
!   dependence of the self-continuum. these are tabulated at 10
!   cm-1 intervals from 0 to 20000 cm-1
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_ckd_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine optical_ckd_init

!------------------------------------------------------------------
!    optical_ckd_init reads ckd2.1 or ckd2.4 self and foreign-broadened
!    h2o continuum coefficients, corrections, and coefficients for
!    temperature dependence of the self-continuum. these are tabulated
!    at 10 cm-1 intervals from 0 to 20000 cm-1.
!    (the above information is as of 2/12/96).
!
!    references:
!
!    (1) clough, s. a.  et al. "line shape and the water vapor
!        continuum," atmospheric research, 23 (1989) 229-241.
!
!
!    author: m. d. schwarzkopf
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:


!-------------------------------------------------------------------
!   data from former block data bs260 for self-broadened continuum
!    at 260K, band-integrated, in 5 - 19995 cm-1 range.
!               06/28/82
!               units of (cm**3/mol) * 1.E-20
!---------------------------------------------------------------------
      real    ::  v1sh2o_260, v2sh2o_260, dvsh2o_260,    &
                  ssh2o_260(2000)
      integer ::  nptsh2o_260

!--------------------------------------------------------------------
!        tktab and vjtab are the respective temperature and frequency
!    points at which tabulations occurred.
!---------------------------------------------------------------------
      real   ::   tktab(40),  vjtab(300)

!---------------------------------------------------------------------
      integer  :: inrad, k, j, ihih2o

!--------------------------------------------------------------------
!   local variables:
!
!      v1sh2o_260
!      v2sh2o_260
!      dvsh2o_260
!      ssh2o_260
!      nptsh2o_260
!      tktab
!      vjtab
!      inrad
!      k,j
!      ihih2o
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    call routine to allocate radfunc table
!---------------------------------------------------------------------
      call table_alloc (radfunc, 40, 300)

!--------------------------------------------------------------------
!    read h2o (original) data
!    data are at frequencies 5 - 19995 cm-1, at 10 cm-1 intervals
!-------------------------------------------------------------------
      inrad = open_namelist_file ('INPUT/h2ockd2.1_data')
      read (inrad,9001) v1sh2o_296, v2sh2o_296, dvsh2o_296,  &
                        nptsh2o_296
      read (inrad,9002) (ssh2o_296(k),k=1,2000)
      read (inrad,9001) v1sh2o_260, v2sh2o_260, dvsh2o_260,   &
                        nptsh2o_260
      read (inrad,9002) (ssh2o_260(k),k=1,2000)
      read (inrad,9001) v1fh2o, v2fh2o, dvfh2o, nptfh2o
      read (inrad,9002) (sfh2o(k),k=1,2000)
9001  format (3f12.1,i8)
9002  format (5e14.5)
 
      call close_file (inrad)

!--------------------------------------------------------------------
!    read h2o corrected data
!--------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1') then
        inrad = open_namelist_file ('INPUT/h2ockd2.1_corrdata')
      else if (trim(Lw_control%continuum_form) == 'ckd2.4') then
        inrad = open_namelist_file ('INPUT/h2ockd2.4_corrdata')
      endif
      read (inrad,9007) (sfac(k),k=1,2000)
      read (inrad,9007) (fscal(k),k=1,2000)
      read (inrad,9007) (tmpfctrs(k),k=1,2000)
9007  format (5e13.6)
 
      call close_file (inrad)

!--------------------------------------------------------------------
!    read radfn data
!--------------------------------------------------------------------
      inrad = open_namelist_file ('INPUT/radfn_5-2995_100-490k')
      read (inrad,9000) ((radfunc%vae(k,j),radfunc%td(k,j),k=1,40), &
                                                           j=1,300)
9000  format (8f14.6)
      call close_file (inrad)

!---------------------------------------------------------------------
      do k=1,40
        tktab(k) = 100. + 10.*(k-1)
      end do
      do j=1,300
        vjtab(j) = 5. + 10.*(j-1)
      end do
 
!--------------------------------------------------------------------
!    compute range to use in datasets for actual frequency intervals
!    used in model.
!
!    freqlo = 160.
!    freqhi = 560.
!
!    define initial offset and number of data points to use
!    for the 3 h2o continua over the frequency range of the
!    calculations (freqlo,freqhi). note: we assume no interpolation
!    is needed. if interp. was required, these limits would be
!    expanded. values are put into commons in include file tab.h
!    for transmission into Optical_ckd2.1.F.
!
!    ioff is the offset from the absorption tables (starting at 5)
!    needed for proper freq computations. first index used then
!    is (ioff+1). for calculations with the first band beginning
!    at 160 cm-1, this number is 16, and the index number of the
!    band ending at 560 cm-1 is 56.
!-----------------------------------------------------------------------
      ioffh2o = 16

!---------------------------------------------------------------------
!    the final index number used in the calculation is (ihi)
!--------------------------------------------------------------------
      ihih2o  = 56

!--------------------------------------------------------------------
!    nptc is the number of frequency points used in the calculation.
!    ( = ihi - (ioff+1) + 1)
!---------------------------------------------------------------------
      nptch2o = ihih2o - ioffh2o

!---------------------------------------------------------------------
!    vvj are the frequencies for calculation of h2o coefficients. by
!    assumption, no other frequencies are used.
!----------------------------------------------------------------------
      do j=1,nptch2o
        vvj(j) = v1sh2o_296 + dvsh2o_296*float(j+ioffh2o-1)
      end do

!---------------------------------------------------------------------
!    compute h2o coefficients averaged over the broad bands used
!    in the 560 -1200 cm-1 range. until the frequency bands are read
!    in, I will re-list them here, rather than use rnddta.H variables
!    (where they are stored).
!
!    the required wide bands are:
!        560-630 cm-1
!        630-700   (assuming 3 bands in 15um complex)
!        700-800
!        560-800   (1 band for entire complex)
!        800-900
!        900-990
!        990-1070
!        1070-1200
!        800-900,1070-1200   (until this band is broken into 2)
!    we assume that, for best accuracy:
!    the quantity required is <svj> and <fvj) where angle brackets are
!    averages over frequency, s and f are self- and foreign coeff-
!    icients, including corrections, and vj is frequency (from vjtab).
!    notations for special bands attempt similarity with that
!    previously used in the radiation code.
!    we also assume that one value may be used (at all altitudes)
!    for the radiation correction term radfn, in each frequency band.
!    the values used below result from experimentation.
!---------------------------------------------------------------------
      svj = 0.0
      fvj = 0.0
      svjwd = 0.0
      fvjwd = 0.0
      svjinw = 0.0
      fvjinw = 0.0

!--------------------------------------------------------------------
!    560-630 band:
!--------------------------------------------------------------------
      do j=57,63
        svj(1) = svj(1) + vjtab(j)*ssh2o_296(j)*sfac(j)/7.
        fvj(1) = fvj(1) + vjtab(j)*sfh2o(j)*fscal(j)/7.
      end do
      radfnbd(1) = 0.90

!--------------------------------------------------------------------
!    630-700 band:
!--------------------------------------------------------------------
      do j=64,70
        svj(2) = svj(2) + vjtab(j)*ssh2o_296(j)*sfac(j)/7.
        fvj(2) = fvj(2) + vjtab(j)*sfh2o(j)*fscal(j)/7.
      end do
      radfnbd(2) = 0.92

!--------------------------------------------------------------------
!    700-800 band:
!--------------------------------------------------------------------
      do j=71,80
        svj(3) = svj(3) + vjtab(j)*ssh2o_296(j)*sfac(j)/10.
        fvj(3) = fvj(3) + vjtab(j)*sfh2o(j)*fscal(j)/10.
      end do
      radfnbd(3) = 0.95
!--------------------------------------------------------------------
!    800-900 band:
!--------------------------------------------------------------------
      do j=81,90
        svj(4) = svj(4) + vjtab(j)*ssh2o_296(j)*sfac(j)/10.
        fvj(4) = fvj(4) + vjtab(j)*sfh2o(j)*fscal(j)/10.
      end do
      radfnbd(4) = 0.97

!--------------------------------------------------------------------
!    900-990 band:
!--------------------------------------------------------------------
      do j=91,99
        svj(5) = svj(5) + vjtab(j)*ssh2o_296(j)*sfac(j)/9.
        fvj(5) = fvj(5) + vjtab(j)*sfh2o(j)*fscal(j)/9.
      end do
      radfnbd(5) = 0.98

!--------------------------------------------------------------------
!    990-1070 band:
!--------------------------------------------------------------------
      do j=100,107
        svj(6) = svj(6) + vjtab(j)*ssh2o_296(j)*sfac(j)/8.
        fvj(6) = fvj(6) + vjtab(j)*sfh2o(j)*fscal(j)/8.
      end do
      radfnbd(6) = 0.99

!--------------------------------------------------------------------
!    1070-1200 band:
!--------------------------------------------------------------------
      do j=108,120
        svj(7) = svj(7) + vjtab(j)*ssh2o_296(j)*sfac(j)/13.
        fvj(7) = fvj(7) + vjtab(j)*sfh2o(j)*fscal(j)/13.
      end do
      radfnbd(7) = 0.992

!--------------------------------------------------------------------
!    560-800 combined band:
!-------------------------------------------------------------------
      do j=57,80
        svjwd = svjwd + vjtab(j)*ssh2o_296(j)*sfac(j)/24.
        fvjwd = fvjwd + vjtab(j)*sfh2o(j)*fscal(j)/24.
      end do
      radfnbdwd = 0.92

!--------------------------------------------------------------------
!    800-990,1070-1200 combined band:
!--------------------------------------------------------------------
      do j=81,99
        svjinw = svjinw + vjtab(j)*ssh2o_296(j)*sfac(j)/22.
        fvjinw = fvjinw + vjtab(j)*sfh2o(j)*fscal(j)/32.
      end do
      do j=108,120
        svjinw = svjinw + vjtab(j)*ssh2o_296(j)*sfac(j)/32.
        fvjinw = fvjinw + vjtab(j)*sfh2o(j)*fscal(j)/32.
      end do
      radfnbdinw = 0.98

!--------------------------------------------------------------------


end subroutine optical_ckd_init




!###################################################################
! <SUBROUTINE NAME="optical_path_ckd">
!  <OVERVIEW>
!   Subroutine to compute water vapor self and foreign broadened 
!   continuum optical paths
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute water vapor self and foreign broadened 
!   continuum optical paths over the frequency range specified by
!    ioffh2o and nptch2o using the ckd algorithm, modified for 
!    the gcm parameterization.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_path_ckd (atmden, press, temp, rh2o, Optical)
!  </TEMPLATE>
!  <IN NAME="atmden" TYPE="real">
!   Atmospheric density profile
!  </IN>
!  <IN NAME="press" TYPE="real">
!   The pressure coordinate array
!  </IN>
!  <IN NAME="temp" TYPE="real">
!   Temperature
!  </IN> 
!  <IN NAME="rh2o" TYPE="real">
!   mass mixing ratio of h2o at model data levels
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   water vapor continuum optical path otuput
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_path_ckd (atmden, press, temp, rh2o, Optical) 

!------------------------------------------------------------------
!    subroutine optical_ckd computes h2o continuum optical paths
!    (self + foreign) over the frequency range specified by
!    ioffh2o and nptch2o using the ckd algorithm, modified for 
!    the gcm parameterization.
!    (this routine is previously called contnm.F)
!------------------------------------------------------------------

real, dimension (:,:,:), intent(in)       :: atmden, press, temp, rh2o
type(optical_path_type), intent(inout)    :: Optical

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      atmden
!      press
!      temp
!      rh2o
!
!   intent(inout) variable:
!
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension (size(press,1), size(press,2), &
                       size(press,3)) ::                totch2obdinw

      real, dimension (size(press,1), size(press,2), &
                       size(press,3)-1) ::       &
                                    xch2obdinw, tmpexp, rvh2o, rhoave

      real                    ::  t0 = 296.0
      integer                 ::  k, nu
      integer      :: israd, ierad, jsrad, jerad

!---------------------------------------------------------------------
!  local variables:
!
!      totch2obdinw
!      xch2obdinw
!      tmpexp
!      rvh2o
!      rhoave
!      t0
!      n,k
!      nu
!
!--------------------------------------------------------------------
      israd = 1
      ierad = size(press,1)
      jsrad = 1
      jerad = size(press,2)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      allocate (Optical%xch2obd    (ISRAD:IERAD, JSRAD:JERAD,    &
                                                          KS:KE  , 7) )
      allocate (Optical%totch2obdwd(ISRAD:IERAD, JSRAD:JERAD,    &
                                                          KS:KE+1   ) )
      allocate (Optical%xch2obdwd  (ISRAD:IERAD, JSRAD:JERAD,    &
                                                          KS:KE     ) )
      Optical%xch2obd  = 0.                                           
      Optical%totch2obdwd = 0.                                        
      Optical%xch2obdwd  = 0.      

!--------------------------------------------------------------------
!    define the volume mixing ratio of h2o
!---------------------------------------------------------------------
      rvh2o(:,:,KS:KE) = rh2o(:,:,KS:KE)/d622

!---------------------------------------------------------------------
!    define input arguments to optical_ckd
!    wk is column density (molec/cm2) of water vapor
!    rfrgn is partial pressure (Amagat) at 296K from N2+O2+Ar
!    rh2os is partial pressure (Amagat) at 296K from water vapor
!-------------------------------------------------------------------
      Optical%wk(:,:,KS:KE) =  rvh2o(:,:,KS:KE)*avogno/wtmair*   &
                               atmden(:,:,KS:KE)/   &
                               (1.0 + rvh2o(:,:,KS:KE))
      rhoave(:,:,KS:KE) = (press(:,:,KS:KE)/pstd)*   &
                          (tfreeze/temp(:,:,KS:KE))
      Optical%rfrgn(:,:,KS:KE) =  rhoave(:,:,KS:KE)*(t0/tfreeze)/  &
                                  (1.0 + rvh2o(:,:,KS:KE))
      Optical%rh2os(:,:,KS:KE) = Optical%rfrgn(:,:,KS:KE)*   &
                                 rvh2o(:,:,KS:KE)
      Optical%tfac(:,:,KS:KE) = temp(:,:,KS:KE) - t0

!--------------------------------------------------------------------
!    compute self-broadened temperature-dependent continuum coefficient
!    using the single coefficient -.020 for all frequencies in
!    the 560-1200 cm-1 range. experiments with the mid-latitude
!    summer profile show errors of < .01 W/m**2 (in the net broadband
!    flux, 0-2200 cm-1) using this value. this value is used instead
!    of tmpfctrs at each frequency band.
!-------------------------------------------------------------------
      tmpexp(:,:,KS:KE) = EXP(-.020*Optical%tfac(:,:,KS:KE))
 
!-------------------------------------------------------------------
!    compute h2o self- and foreign- broadened continuum optical path 
!    for each layer k (xch2obd, xch2obdinw, xch2obdwd) and summed from
!    the top of the atmosphere through layer k (totch2obd,
!    totch2obdinw, totch2obdwd).
!--------------------------------------------------------------------
      do nu = 1,7
        do k = KS,KE 
          Optical%xch2obd(:,:,k,nu) = Optical%wk(:,:,k)*1.0e-20*   &
                                      (svj(nu)*Optical%rh2os(:,:,k)*&
                                      tmpexp(:,:,k) + fvj(nu)*   &
                                      Optical%rfrgn(:,:,k))*radfnbd(nu)
        end do
      end do
 
      do k = KS,KE 
        xch2obdinw(:,:,k) = Optical%wk(:,:,k)*1.0e-20*(svjinw*  &
                            Optical%rh2os(:,:,k)* tmpexp(:,:,k) +   &
                            fvjinw*Optical%rfrgn(:,:,k))*radfnbdinw
        Optical%xch2obdwd(:,:,k) = Optical%wk(:,:,k)*1.0e-20*   &
                                   (svjwd*Optical%rh2os(:,:,k)* &
                                   tmpexp(:,:,k) + fvjwd*  &
                                   Optical%rfrgn(:,:,k))*radfnbdwd
      end do
 
      totch2obdinw(:,:,1) = 0.0E+00
      Optical%totch2obdwd(:,:,1) = 0.0E+00
      do k = KS+1,KE+1
        totch2obdinw(:,:,k) = totch2obdinw(:,:,k-1) +    &
                              xch2obdinw(:,:,k-1)
        Optical%totch2obdwd(:,:,k) = Optical%totch2obdwd(:,:,k-1) + &
                                     Optical%xch2obdwd(:,:,k-1)
      end do

!----------------------------------------------------------------------

 
end subroutine optical_path_ckd
 


!################################################################## 
! <SUBROUTINE NAME="optical_o3">
!  <OVERVIEW>
!   Subroutine to compute optical paths for o3.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute optical paths for o3.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_o3 (atmden, qo3, vv, Optical)
!  </TEMPLATE>
!  <IN NAME="atmden" TYPE="real">
!   Atmospheric density profile
!  </IN>
!  <IN NAME="qo3" TYPE="real">
!   mass mixing ratio of o3 at model data levels
!  </IN>
!  <IN NAME="vv" TYPE="real">
!   Ozone volume mixing atio
!  </IN> 
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   ozone optical path otuput
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_o3 (atmden, qo3, vv, Optical)

!------------------------------------------------------------------
!    optical_o3 computes optical paths for o3.
!------------------------------------------------------------------

real, dimension(:,:,:),  intent(in)    ::  atmden, qo3, vv
type(optical_path_type), intent(inout) ::  Optical

!-----------------------------------------------------------------
!   intent(in) variables:
!
!     atmden
!     qo3     mass mixing ratio of o3 at model data levels.
!     vv
!
!   intent(inout) variable:
!
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer  ::    k    ! do-loop index
      integer      :: israd, ierad, jsrad, jerad

!---------------------------------------------------------------------
      israd = 1
      ierad = size(qo3,1)
      jsrad = 1
      jerad = size(qo3,2)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      allocate (Optical%toto3 (ISRAD:IERAD, JSRAD:JERAD, KS:KE      +1))
      allocate (Optical%tphio3(ISRAD:IERAD, JSRAD:JERAD, KS:KE      +1))
      allocate (Optical%var3  (ISRAD:IERAD, JSRAD:JERAD, KS:KE        ))
      allocate (Optical%var4  (ISRAD:IERAD, JSRAD:JERAD, KS:KE        ))
      Optical%toto3  = 0.
      Optical%tphio3 = 0.
      Optical%var3  = 0.
      Optical%var4  = 0.                                        

!-----------------------------------------------------------------------
!    compute optical paths for o3, using the diffusivity 
!    approximation 1.66 for the angular integration.  obtain 
!    unweighted values var3 and weighted values  var4.
!    the quantities  0.003 (.003) appearing in the
!    var4 expression are the approximate voigt corrections
!    for o3.
!---------------------------------------------------------------------  
      Optical%var3(:,:,KS:KE) = atmden(:,:,KS:KE)*qo3(:,:,KS:KE)*diffac
      Optical%var4(:,:,KS:KE) = Optical%var3(:,:,KS:KE)*    &
                                (vv(:,:,KS:KE) + 3.0E-03)

!----------------------------------------------------------------------
!    compute summed optical paths for o3.
!----------------------------------------------------------------------
      Optical%toto3 (:,:,KS) = 0.0E+00
      Optical%tphio3(:,:,KS) = 0.0E+00
      do k=KS+1,KE+1
        Optical%toto3 (:,:,k) = Optical%toto3 (:,:,k-1) +    &
                                Optical%var3  (:,:,k-1) 
        Optical%tphio3(:,:,k) = Optical%tphio3(:,:,k-1) +    &
                                Optical%var4  (:,:,k-1) 
      end do

!----------------------------------------------------------------------


end subroutine optical_o3




!#####################################################################
! <SUBROUTINE NAME="optical_rbts">
!  <OVERVIEW>
!   Subroutine to compute optical paths for h2o rbts continuum
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute optical paths for h2o rbts continuum
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_rbts (temp, rh2o, Optical) 
!  </TEMPLATE>
!  <IN NAME="temp" TYPE="real">
!   temperature profile used in continuum calculation
!  </IN>
!  <IN NAME="rh2o" TYPE="real">
!   mass mixing ratio of h2o at model data levels
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   water vapor robert continuum optical path
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_rbts (temp, rh2o, Optical) 

!------------------------------------------------------------------
!    optical_rbts computes optical paths for h2o rbts comtinuum.
!------------------------------------------------------------------

real, dimension(:,:,:),  intent(in)    :: temp, rh2o
type(optical_path_type), intent(inout) :: Optical

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      temp
!      rh2o
!
!   intent(inout) variable:
!
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension(size(temp,1), size(temp,2), &
                                     size(temp,3)) :: texpsl
      integer     :: k
      integer      :: israd, ierad, jsrad, jerad

!--------------------------------------------------------------------
!  local variables:
!
!      texpsl
!      i,k
!
!----------------------------------------------------------------------
      israd = 1
      ierad = size(temp,1)
      jsrad = 1
      jerad = size(temp,2)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      allocate (Optical%cntval(ISRAD:IERAD, JSRAD:JERAD,   KS:KE+1   ))
      allocate (Optical%totvo2(ISRAD:IERAD, JSRAD:JERAD,   KS:KE+1   ))
      Optical%cntval = 0.                                         
      Optical%totvo2 = 0.                                        

!----------------------------------------------------------------------
!    compute argument for constant temperature coefficient (this is 
!    1.800E+03/(1.0E+00/temp - 1.0E+00/2.960E+02)).
!---------------------------------------------------------------------- 
      texpsl(:,:,KS:KE+1) = EXP(1.800E+03/temp(:,:,KS:KE+1) -   &
                                6.081081081E+00) 

!----------------------------------------------------------------------
!    compute optical path for the h2o continuum, using roberts 
!    coefficients betinw, and temperature correction texpsl. 
!    the diffusivity approximation (which cancels out in this
!    expression) is assumed to be 1.66.  the use of the diffusivity
!    factor has been shown to be a significant source of error in the
!    continuum calculations, however, the time penalty of an angular
!    integration is severe.
!---------------------------------------------------------------------  
      Optical%cntval(:,:,KS:KE) = texpsl(:,:,KS:KE)*rh2o(:,:,KS:KE)*   &
                                  Optical%var2(:,:,KS:KE)/   &
                                  (rh2o(:,:,KS:KE) + d622   )

!----------------------------------------------------------------------
!    compute summed optical paths for h2o roberts continuum.
!----------------------------------------------------------------------
      Optical%totvo2(:,:,KS) = 0.0E+00
      do k=KS+1,KE+1
        Optical%totvo2(:,:,k) = Optical%totvo2(:,:,k-1) +   &
                                Optical%cntval(:,:,k-1) 
      end do

!----------------------------------------------------------------------



end subroutine optical_rbts



!####################################################################
! <SUBROUTINE NAME="optical_h2o">
!  <OVERVIEW>
!   Subroutine to compute water vapor optical paths
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute water vapor optical paths
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_h2o (pflux, atmden, vv, press, temp, rh2o, tflux, &
!                     Optical) 
!  </TEMPLATE>
!  <IN NAME="pflux" TYPE="real">
!   pressure at flux levels of model
!  </IN>
!  <IN NAME="atmden" TYPE="real">
!   Atmospheric density profile
!  </IN>
!  <IN NAME="vv" TYPE="real">
!   volume mixing ratio of h2o at model data levels
!  </IN>
!  <IN NAME="press" TYPE="real">
!   The pressure coordinate array
!  </IN>
!  <IN NAME="temp" TYPE="real">
!   Temperature at data levels of model
!  </IN> 
!  <IN NAME="rh2o" TYPE="real">
!   mass mixing ratio of h2o at model data levels
!  </IN>
!  <IN NAME="tflux" TYPE="real">
!   Temperature at flux levels of model
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   water vapor optical path otuput
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_h2o (pflux, atmden, vv, press, temp, rh2o, tflux, &
                        Optical) 

!----------------------------------------------------------------------
!    optical_h2o computes optical paths for h2o.
!----------------------------------------------------------------------

real, dimension (:,:,:), intent(in)    ::  pflux, atmden, vv, press, &
                                           temp, rh2o, tflux
type(optical_path_type), intent(inout) ::  Optical

!-----------------------------------------------------------------
!   intent(in) variables:
!
!     pflux     pressure at flux levels of model.
!     atmden
!     vv
!     press     pressure at data levels of model.
!     temp      temperature at data levels of model. 
!     rh2o      mass mixing ratio of h2o at model data levels 
!     tflux
!
!   intent(inout) variable:
!
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension (size(pflux,1), size(pflux,2), &
                       size(pflux,3)) ::        &
                                             tpl1, tpl2, &
                                             qh2o, tdif, tdif2
      integer    ::  m, k
      integer      :: israd, ierad, jsrad, jerad

!--------------------------------------------------------------------
!  local variables:
!
!      tpl1
!      tpl2
!      qh2o       h2o mass mixing ratio, multiplied by the diffusivity
!                 factor diffac.
!      tdif
!      tdif2
!      m,k
!
!-----------------------------------------------------------------------

      israd = 1
      ierad = size(pflux,1)
      jsrad = 1
      jerad = size(pflux,2)
!-------------------------------------------------------------------- 
!    compute mean temperature in the "nearby layer" between a flux
!    level and the first data level below the flux level (tpl1) or the
!    first data level above the flux level (tpl2)
!---------------------------------------------------------------------
      tpl1(:,:,KS   )         = temp(:,:,KE   )
      tpl1(:,:,KS   +1:KE   ) = tflux(:,:,KS   +1:KE   )
      tpl1(:,:,KE   +1)       = 0.5E+00*(tflux(:,:,KE   +1) +   &
                                temp(:,:,KE   ))
      tpl2(:,:,KS   +1:KE   ) = tflux(:,:,KS   +1:KE   )
      tpl2(:,:,KE   +1)       = 0.5E+00*(tflux(:,:,KE   ) +    &
                                temp(:,:,KE   ))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      allocate (Optical%empl1  (ISRAD:IERAD, JSRAD:JERAD  , KS:KE+1   ))
      allocate (Optical%empl2  (ISRAD:IERAD, JSRAD:JERAD  , KS:KE+1   ))
      allocate (Optical%totphi (ISRAD:IERAD, JSRAD:JERAD  , KS:KE+1   ))
      allocate (Optical%var1   (ISRAD:IERAD, JSRAD:JERAD  , KS:KE     ))
      allocate (Optical%var2   (ISRAD:IERAD, JSRAD:JERAD  , KS:KE     ))
      allocate (Optical%emx1   (ISRAD:IERAD, JSRAD:JERAD              ))
      allocate (Optical%emx2   (ISRAD:IERAD, JSRAD:JERAD              ))
      Optical%empl1   = 0.
      Optical%empl2  =0.
      Optical%totphi  = 0.
      Optical%var1   = 0.
      Optical%var2   = 0.
      Optical%emx1   = 0.
      Optical%emx2   = 0.

!----------------------------------------------------------------------
!    compute optical paths for h2o, using the diffusivity 
!    approximation 1.66 for the angular integration.  obtain 
!    unweighted values var1, and weighted values var2.
!    the quantities 0.0003 (.0003) appearing in the
!    var2 expressions are the approximate voigt corrections
!    for h2o.  vv is the layer-mean pressure (in 
!    atmosphere), which is not the same as the level pressure press.
!---------------------------------------------------------------------  
      qh2o(:,:,KS:KE) = rh2o(:,:,KS:KE)*diffac
      Optical%var1(:,:,KS:KE) = atmden(:,:,KS:KE)*qh2o(:,:,KS:KE)
      Optical%var2(:,:,KS:KE) = Optical%var1(:,:,KS:KE)*   &
                                (vv(:,:,KS:KE) + 3.0E-04)

!----------------------------------------------------------------------
!    compute summed optical paths for h2o.
!----------------------------------------------------------------------
      Optical%totphi(:,:,KS) = 0.0E+00
      do k=KS+1,KE+1
        Optical%totphi(:,:,k) = Optical%totphi(:,:,k-1) +   &
                                Optical%var2  (:,:,k-1) 
      end do

!----------------------------------------------------------------------
!    emx1 is the additional pressure-scaled mass from press(KE) to 
!    pflux(KE).  it is used in nearby layer and emiss calculations.
!    emx2 is the additional pressure-scaled mass from press(KE) to 
!    pflux(KE+1).  it is used in calculations between flux levels k
!    and KE+1.
!----------------------------------------------------------------------
      Optical%emx1(:,:) = qh2o(:,:,KE)*press(:,:,KE)*(press(:,:,KE) - &
                          pflux(:,:,KE))/(1.0E+02*GRAV*pstd)
      Optical%emx2(:,:) = qh2o(:,:,KE)*press(:,:,KE)*(pflux(:,:,KE+1) -&
                          press(:,:,KE))/(1.0E+02*GRAV*pstd)

!----------------------------------------------------------------------
!    empl is the pressure scaled mass from pflux(k) to press(k) or to 
!    press(k+1).
!----------------------------------------------------------------------
      Optical%empl1(:,:,KS) = Optical%var2(:,:,KE)
      Optical%empl1(:,:,KS+1:KE+1) = qh2o(:,:,KS:KE)*    &
                                     pflux(:,:,KS+1:KE+1)*   &
                                     (pflux(:,:,KS+1:KE+1) -   &
                                      press(:,:,KS:KE))/   &
                                      (1.0E+02*GRAV*pstd)
      Optical%empl2(:,:,KS+1:KE) =    &
                 qh2o(:,:,KS+1:KE)*pflux(:,:,KS+1:KE)*   &
                 (press(:,:,KS+1:KE) - pflux(:,:,KS+1:KE))/  &
                 (1.0E+02*GRAV*pstd)
      Optical%empl2(:,:,KE+1) = Optical%empl2(:,:,KE) 

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (NBTRGE > 0) then
        allocate ( Optical%empl1f (ISRAD:IERAD , JSRAD:JERAD ,    & 
                                                  KS:KE+1,  NBTRGE ) ) 
        allocate ( Optical%empl2f (ISRAD:IERAD , JSRAD:JERAD ,     &  
                                                  KS:KE+1,  NBTRGE ) ) 
        allocate ( Optical%tphfh2o(ISRAD:IERAD , JSRAD:JERAD ,     & 
                                                  KS:KE+1,  NBTRGE ) ) 
        allocate ( Optical%vrpfh2o(ISRAD:IERAD , JSRAD:JERAD ,    &
                                                  KS:KE+1,  NBTRGE ) )
        allocate ( Optical%emx1f  (ISRAD:IERAD , JSRAD:JERAD ,   &
                                                            NBTRGE ) )
        allocate ( Optical%emx2f  (ISRAD:IERAD , JSRAD:JERAD ,   &
                                                            NBTRGE ) )
        Optical%empl1f  = 0.
        Optical%empl2f  = 0.
        Optical%tphfh2o  = 0.
        Optical%vrpfh2o = 0.
        Optical%emx1f   = 0.
        Optical%emx2f  = 0.                               

        if (tmp_dpndnt_h2o_lines) then
!----------------------------------------------------------------------
!    compute h2o optical paths for use in the 1200-1400 cm-1 range if
!    temperature dependence of line intensities is accounted for.
!----------------------------------------------------------------------
          tdif(:,:,KS:KE) = temp(:,:,KS:KE)-2.5E+02

          do m=1,NBTRGE
            Optical%vrpfh2o(:,:,KS:KE,m) = Optical%var2(:,:,KS:KE)*   &
                                           EXP(csfah2o(1,m)*   &
                                               (tdif(:,:,KS:KE)) +   &
                                               csfah2o(2,m)*   &
                                               (tdif(:,:,KS:KE))**2 )
          end do
          do m=1,NBTRGE
            Optical%tphfh2o(:,:,KS,m) = 0.0E+00
            do k=KS+1,KE+1
              Optical%tphfh2o(:,:,k,m) = Optical%tphfh2o(:,:,k-1,m) +  &
                                         Optical%vrpfh2o(:,:,k-1,m)
            end do
          end do

          tdif2(:,:,KS+1:KE+1) = tpl2(:,:,KS+1:KE+1)-2.5E+02
          tdif (:,:,KS+1:KE+1) = tpl1(:,:,KS+1:KE+1)-2.5E+02

!---------------------------------------------------------------------
!    compute this additional mass, for use in the 1200-1400 cm-1 range,
!    if temperature dependence of line intensities is accounted for.
!--------------------------------------------------------------------
          do m=1,NBTRGE
            Optical%emx1f(:,:,m) = Optical%emx1(:,:) *    &
                                   EXP(csfah2o(1,m)*(tdif2(:,:,KE+1)) +&
                                     csfah2o(2,m)*(tdif2(:,:,KE+1))**2 )
            Optical%emx2f(:,:,m) = Optical%emx2(:,:) *    &
                                 EXP(csfah2o(1,m)*(tdif (:,:,KE+1)) + &
                                     csfah2o(2,m)*(tdif (:,:,KE+1))**2 )
          end do

!----------------------------------------------------------------------
!    compute this additional mass, for use in the 1200-1400 cm-1 range,
!    if temperature dependence of line intensities is accounted for.
!----------------------------------------------------------------------
          do m=1,NBTRGE
            Optical%empl1f(:,:,KS+1:KE+1,m) =     &
                                        Optical%empl1(:,:,KS+1:KE+1)*&
                                        EXP(csfah2o(1,m)*   &
                                            (tdif(:,:,KS+1:KE+1)) + &
                                            csfah2o(2,m)*   &
                                            (tdif(:,:,KS+1:KE+1))**2 )
            Optical%empl2f(:,:,KS+1:KE,m) = Optical%empl2(:,:,KS+1:KE)*&
                                          EXP(csfah2o(1,m)*  &
                                              (tdif2(:,:,KS+1:KE)) +   &
                                              csfah2o(2,m)*  &
                                              (tdif2(:,:,KS+1:KE))**2 )
            Optical%empl1f(:,:,KS ,m) = Optical%vrpfh2o(:,:,KE,m)
            Optical%empl2f(:,:,KE+1,m) = Optical%empl2f(:,:,KE,m)
          end do
        else
          do m=1,NBTRGE
            Optical%empl1f(:,:,ks+1:ke+1,m) =   &
                                           Optical%empl1(:,:,ks+1:ke+1)
            Optical%empl2f(:,:,ks+1:ke,m) = Optical%empl2(:,:,ks+1:ke)
            Optical%emx1f(:,:,m)   = Optical%emx1(:,:)
            Optical%emx2f(:,:,m)  = Optical%emx2(:,:)              
            Optical%tphfh2o(:,:,:,m) = Optical%totphi (:,:,:)
            Optical%vrpfh2o(:,:,KE,m) = Optical%var2(:,:,KE)
            Optical%vrpfh2o(:,:,KS:ke,m) = Optical%var2(:,:,KS:Ke)
            Optical%empl1f(:,:,KS,m) = Optical%vrpfh2o(:,:,KE,1)
            Optical%empl2f(:,:,KE+1,m) = Optical%empl2f (:,:,KE,1)
          end do
        endif
      endif
!---------------------------------------------------------------------



end subroutine optical_h2o



!####################################################################
! <SUBROUTINE NAME="cfc_optical_depth">
!  <OVERVIEW>
!   Subroutine to compute CFC optical depths
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute CFC optical depths. The code assumes
!   a constant mixing ratio throughout the atmosphere.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cfc_optical_depth (density, Rad_gases, Optical)
!  </TEMPLATE>
!  <IN NAME="density" TYPE="real">
!   density profile of CFC in the atmosphere
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   Radiative gases optical properties input data
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   CFC Optical depth output
!  </INOUT>
! </SUBROUTINE>
!
subroutine cfc_optical_depth (density, Rad_gases, Optical)

!------------------------------------------------------------------
!    cfc_optical_depth computes optical paths for cfc. The code assumes
!    a constant mixing ratio throughout the atmosphere.
!------------------------------------------------------------------

real, dimension (:,:,:),    intent(in)     :: density 
type(radiative_gases_type), intent(in)     :: Rad_gases
type(optical_path_type),    intent(inout)  :: Optical 

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      density
!      Rad_gases
!
!   intent(inout) variable:
!
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real          ::  rrf11, rrf12, rrf113, rrf22
      real          ::  rf11air, rf12air, rf113air, rf22air
      integer       ::  k
      integer       ::  kx

!--------------------------------------------------------------------
!  local variables:
!
!      rrf11
!      rrf12
!      rrf113
!      rrf22
!      rf11air
!      rf12air
!      rf113air
!      rf22air
!      k
!      kx
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      allocate ( Optical%totf11 (size(density,1), size(density,2),    &
                                 size(density,3) ) )
      allocate ( Optical%totf12 (size(density,1), size(density,2),    &
                                 size(density,3) ) )
      allocate ( Optical%totf113(size(density,1), size(density,2),    &
                                 size(density,3) ) )
      allocate ( Optical%totf22 (size(density,1), size(density,2),    &
                                 size(density,3) ) )
      Optical%totf11  = 0.
      Optical%totf12  = 0.
      Optical%totf113 = 0.
      Optical%totf22 = 0.
 
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      kx = size (density,3)

!--------------------------------------------------------------------
!    define cfc mixing ratio conversion factors.
!--------------------------------------------------------------------
      rf11air  = wtmf11/wtmair
      rf12air  = wtmf12/wtmair
      rf113air = wtmf113/wtmair
      rf22air  = wtmf22/wtmair

      rrf11 = Rad_gases%rrvf11*rf11air
      rrf12 = Rad_gases%rrvf12*rf12air
      rrf113 = Rad_gases%rrvf113*rf113air
      rrf22 = Rad_gases%rrvf22*rf22air

!----------------------------------------------------------------------
!    compute summed optical paths for f11,f12, f113 and f22  with the 
!    diffusivity factor of 2 (appropriate for weak-line absorption 
!    limit).
!----------------------------------------------------------------------
      Optical%totf11(:,:,1) = 0.0E+00
      Optical%totf12(:,:,1) = 0.0E+00
      Optical%totf113(:,:,1) = 0.0E+00
      Optical%totf22 (:,:,1) = 0.0E+00
      do k=2,kx           
        Optical%totf11(:,:,k) = Optical%totf11(:,:,k-1) +    &
                                density(:,:,k-1)*rrf11*2.0E+00
        Optical%totf12(:,:,k) = Optical%totf12(:,:,k-1) +    &
                                density(:,:,k-1)*rrf12*2.0E+00
        Optical%totf113(:,:,k) = Optical%totf113(:,:,k-1) +  &
                                 density(:,:,k-1)*rrf113*2.0E+00
        Optical%totf22(:,:,k) = Optical%totf22(:,:,k-1) +    &
                                density(:,:,k-1)*rrf22*2.0E+00
      end do
       
!--------------------------------------------------------------------


end subroutine cfc_optical_depth



!#####################################################################
! <SUBROUTINE NAME="optical_depth_aerosol">
!  <OVERVIEW>
!   Subroutine to compute aerosol optical depths
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to compute aerosol optical depths. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call optical_depth_aerosol (Atmos_input, n, Aerosol,    &
!                                  Aerosol_props, Optical)
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data to model grid point for radiative 
!   properties calculation
!  </IN>
!  <IN NAME="n" TYPE="integer">
!   aerosol optical index
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol climatological input data
!  </IN>
!  <INOUT NAME="Aerosol_props" TYPE="aerosol_properties_type">
!   Aerosol radiative properties
!  </INOUT>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Aerosol Optical depth output
!  </INOUT>
! </SUBROUTINE>
!
subroutine optical_depth_aerosol ( js, Atmos_input, n, Aerosol,    &
                                  Aerosol_props, Aerosol_diags, &
                                  Optical)

!------------------------------------------------------------------
!
!------------------------------------------------------------------

integer,                       intent(in)    :: js
type(atmos_input_type),        intent(in)    :: Atmos_input
integer,                       intent(in)    :: n
type(aerosol_type),            intent(in)    :: Aerosol
type(aerosol_properties_type), intent(inout) :: Aerosol_props
type(aerosol_diagnostics_type),intent(inout) :: Aerosol_diags
type(optical_path_type),       intent(inout) :: Optical

!-----------------------------------------------------------------
!   intent(in) variables:
!
!      Atmos_input
!      n
!      Aerosol
!
!   intent(inout) variable:
!
!      Aerosol_props
!      Optical
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension (size(Aerosol%aerosol,1),  &
                       size(Aerosol%aerosol,2),  &
                       size(Aerosol%aerosol,3), &
                       size(Aerosol%aerosol,4))   :: aerooptdepspec, &
                                                     aerooptdepspec_cn

      real, dimension (size(Aerosol%aerosol,1),  &
                       size(Aerosol%aerosol,2),  &
                       size(Aerosol%aerosol,3))  :: aerooptdep
!yim
      integer, dimension (size(Aerosol%aerosol,1),  &
                          size(Aerosol%aerosol,2),  &
                          size(Aerosol%aerosol,3))  :: opt_index_v1, &
                          opt_index_v2, opt_index_v3, opt_index_v4, &
                          opt_index_v5, opt_index_v6, opt_index_v7,opt_index_v8

      real, dimension (size(Aerosol%aerosol,3)+1) :: bsum

      real      :: asum
      integer   :: nfields, irh
      integer   ::  N_AEROSOL_BANDS 
      integer   :: i,j,k
      integer   :: ix, jx, kx
      integer   :: nsc, opt_index
!--------------------------------------------------------------------
!  local variables:
!
!      aerooptdepspec
!      aerooptdep
!      irh
!      opt_index_v
!      bsum
!      asum
!      nfields
!      n_aerosol_bands
!      i,j,k
!      ix,jx,kx
!      na, nw, ni  
!      nsc 
!      opt_index
!      
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      ix = size (Aerosol%aerosol,1)
      jx = size (Aerosol%aerosol,2)
      kx = size (Aerosol%aerosol,3)
      nfields = size (Aerosol%aerosol,4)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      aerooptdep(:,:,:) = 0.0
      Optical%totaerooptdep(:,:,:,n) = 0.0
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            irh = MIN(100, MAX(0,     &
                      NINT(100.*Atmos_input%aerosolrelhum(i,j,k))))
            opt_index_v1(i,j,k) =     &
                        Aerosol_props%sulfate_index (irh, &
                                             Aerosol_props%ivol(i,j,k) )
            opt_index_v2(i,j,k) =     &
                               Aerosol_props%omphilic_index( irh )
            opt_index_v3(i,j,k) =     &
                               Aerosol_props%bcphilic_index( irh )
            opt_index_v4(i,j,k) =     &
                               Aerosol_props%seasalt1_index( irh )
            opt_index_v5(i,j,k) =     &
                               Aerosol_props%seasalt2_index( irh )
            opt_index_v6(i,j,k) =     &
                               Aerosol_props%seasalt3_index( irh )
            opt_index_v7(i,j,k) =     &
                               Aerosol_props%seasalt4_index( irh )
            opt_index_v8(i,j,k) =     &
                               Aerosol_props%seasalt5_index( irh )
          end do
        end do
      end do

!---------------------------------------------------------------------
!    using relative humidity criterion (where necessary) determine the
!    aerosol category (as an index) appropriate for the aerosol species
!---------------------------------------------------------------------
  do nsc=1,nfields  ! loop on aerosol species
      if (Aerosol_props%optical_index(nsc) > 0 ) then   

      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
                opt_index = Aerosol_props%optical_index(nsc)
                if (opt_index == 0 ) then
                   call error_mesg ('optical_path_init', &
                  'Cannot find aerosol optical properties for species = ' // &
                   TRIM( Aerosol%aerosol_names(nsc) ),  FATAL )
                endif
                aerooptdepspec(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                     (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))*&
                            Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                   aerooptdepspec_cn(i,j,k,nsc) =    &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                   (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                   Aerosol_props%aerextbandlw_cn(n,opt_index)
                 end if
            end do
          end do
        end do
     else if (Aerosol_props%optical_index(nsc) == &   
                          Aerosol_props%sulfate_flag  ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v1(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
!yim
     else if (Aerosol_props%optical_index(nsc) == &   
                          Aerosol_props%bc_flag  ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v1(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%omphilic_flag ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v2(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
!yim
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%bcphilic_flag ) then
      if (Rad_control%using_im_bcsul) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v1(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
      else ! (using_im_bcsul)
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v3(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
      endif  ! (using_im_bcsul)
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%seasalt1_flag ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v4(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%seasalt2_flag ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v5(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%seasalt3_flag ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v6(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%seasalt4_flag ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v7(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
     else if (Aerosol_props%optical_index(nsc) ==  &
                        Aerosol_props%seasalt5_flag ) then
      do k = 1,kx         
        do j = 1,jx         
          do i = 1,ix           
            opt_index = opt_index_v8(i,j,k)
                aerooptdepspec(i,j,k,nsc) =     &
                   diffac*Aerosol%aerosol(i,j,k,nsc)*&
                   (1.0 - Aerosol_props%aerssalbbandlw(n,opt_index))* &
                          Aerosol_props%aerextbandlw(n,opt_index)
                if (n == 1) then
                  aerooptdepspec_cn(i,j,k,nsc) =    &
                     diffac*Aerosol%aerosol(i,j,k,nsc)*   &
                 (1.0 - Aerosol_props%aerssalbbandlw_cn(n,opt_index))*&
                        Aerosol_props%aerextbandlw_cn(n,opt_index)
              endif
            end do
          end do
        end do
      endif
   end do

!---------------------------------------------------------------------
!    save optical path contributions from each layer for band4 and the
!    continuum band. note that if the lw scheme is changed to allow
!    longwave scattering then the %absopdep must be defined approp-
!    riately.
!---------------------------------------------------------------------
      if (n == 1) then
        Aerosol_diags%extopdep(:,:,:,:,3) = aerooptdepspec_cn(:,:,:,:)
        Aerosol_diags%absopdep(:,:,:,:,3) = aerooptdepspec_cn(:,:,:,:)
      endif

!---------------------------------------------------------------------
!    sum optical depths over all species and obtain column optical depth
!---------------------------------------------------------------------
      do k=1,kx
        do j=1,jx
          do i=1,ix
            asum = 0.0
            do nsc=1,nfields
              asum = asum + aerooptdepspec(i,j,k,nsc)
            end do
            aerooptdep(i,j,k) = asum                         
          end do
        end do
      end do

      do j=1,jx
        do i=1,ix
          bsum(1) = 0.0
          do k=2,kx+1         
            bsum(k) = bsum(k-1) + aerooptdep(i,j,k-1)
          end do
          do k=2,kx+1         
            Optical%totaerooptdep(i,j,k,n) = bsum(k)
          end do
        end do
      end do

!---------------------------------------------------------------------
!    continuum band is the last indx:
!---------------------------------------------------------------------
      n_aerosol_bands = Lw_parameters%n_lwaerosol_bands
      if ( n == n_aerosol_bands) then
        Optical%aerooptdep_KE_15(:,:) = aerooptdep(:,:,kx)
      endif
    
!---------------------------------------------------------------------

end subroutine optical_depth_aerosol


!#####################################################################

                   end module optical_path_mod




!FDOC_TAG_GFDL
                module original_fms_rad_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!   
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!


!-----------------------------------------------------------------------
!                 radiation interface module 
!-----------------------------------------------------------------------

use           mcm_lw_mod, only: mcm_lw_init

use    mcm_sw_driver_mod, only: mcm_sw_driver_init

use            fsrad_mod, only: rdparm_init, fsrad, co2_data

use           clouds_mod, only: clouds, clouds_init, clouds_end

use     time_manager_mod, only: time_type

use              mpp_mod, only: input_nml_file
use              fms_mod, only: fms_init, FATAL, &
                                close_file, &
                                open_namelist_file,    &
                                check_nml_error, file_exist,       &
                                error_mesg, &
                                mpp_pe, mpp_root_pe, &
                                write_version_number

use    rad_utilities_mod, only: rad_utilities_init, &
                                radiative_gases_type, &
                                cldrad_properties_type, &
                                cld_specification_type, &
                                astronomy_type, &
                                atmos_input_type, &
                                surface_type, &
                                Sw_control, &
                                rad_output_type, &
                                fsrad_output_type

implicit none 
private 

!----------- public interfaces in this module -----------------------

public    original_fms_rad_init, original_fms_rad_end, original_fms_rad

!-----------------------------------------------------------------------
!------------ version number for this module ---------------------------
character(len=128) :: version = '$Id: original_fms_rad.F90,v 15.0.10.2 2010/09/07 16:17:19 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!   ---- list of restart versions readable by this module ----
!   (sorry, but restart version 1 will not be readable by this module)
      integer, dimension(2) :: restart_versions = (/ 2, 3 /)
!-----------------------------------------------------------------------

     logical :: module_is_initialized = .false.

!-----------------------------------------------------------------------
!   the following code converts rvco2, the volume mixing ratio of co2
!   (used by lwrad) into rco2, the mass mixing ratio (used by swrad).

!   real, parameter :: ratco2mw=1.519449738  ! unused variable (pjp)

!   real, parameter :: rvco2 = 3.3e-4        ! unused variable (pjp)
!   real, parameter :: rco2 = rvco2*ratco2mw ! unused variable (pjp)


!--------- flags -------------------------------------------------------

    logical ::  do_rad
    logical ::  use_rad_date

!-----------------------------------------------------------------------
!  ------- allocatable global data saved by this module -------
!
!   tdt_rad      = radiative (sw + lw) heating rate
!   flux_sw_surf = net (down-up) sw flux at surface
!   flux_lw_surf = downward lw flux at surface
!   coszen_angle = cosine of the zenith angle 
!                  (used for the last radiation calculation)

    type(rad_output_type),save          ::  Rad_output
    real, allocatable, dimension(:,:)   ::  solar_save

!   real, allocatable, dimension(:,:,:) :: tdt_rad
!   real, allocatable, dimension(:,:)   :: flux_sw_surf, &
!                                          flux_lw_surf, &
!                                          coszen_angle, &
!                                          solar_save, &
!                                          fracday

!-----------------------------------------------------------------------
!   ------------------- time step constant --------------------------
!
!   rad_alarm     = time interval until the next radiation calculation
!                   (integer in seconds)
!   rad_time_step = radiation time step (integer in seconds)
!   total_pts = number of grid boxes to be processed every time step
!               (note: all grid boxes must be processed every time step)
!   num_pts   = counter for current number of grid boxes processed
!             (when num_pts=0 or num_pts=total_pts certain things happen)

           integer :: num_pts, total_pts
!          integer :: rad_alarm, rad_time_step, old_time_step
           integer :: rad_alarm, rad_time_step

!-----------------------------------------------------------------------
!------- private allocatable array for time averaged input data --------

      real, allocatable, dimension(:,:,:)   :: psum, tsum, qsum
      real, allocatable, dimension(:,:)     :: asum, csum, ssum,   &
                                               fsum, rrsum
   integer, allocatable, dimension(:,:)     :: nsum
      real, allocatable, dimension(:,:,:)   :: gas_component_sum
      real, allocatable, dimension(:,:,:,:) :: cld_component_sum

!-----------------------------------------------------------------------
!-------------------- namelist -----------------------------------------
!
!   dt_rad  =  radiative time step in seconds
!
!   offset  =  offset for radiative time step (in seconds) 
!              note if offset=1 radition will be done on the first
!              time step after t=0, dt_rad, 2*dt_rad, etc.
!              for now do not change this value

!! the following not needed as of 11-13-01 :
! NOTE:  when reading vers = 1 sea_esf_rad.resfile, offset MUST be < the
!        model timestep
!! end of not needed
!
!   solar_constant = solar constant in watts/m2
!
!   rad_date       = fixed date (year,month,day,hour,min,sec)
!                    for radiation (solar info, ozone, clouds)
!
!   co2std = standard co2 vol. mixing ratio (either 300 or 330 ppmv)
!
!   ratio  = co2 vol. mixing ratio in units of the standard vol.
!            mixing ratio (must lie between 0.5 and 4.0)
!   rsd (repeat same day) : call radiation for the specified rad_date,
!                           running through the diurnal cycle

!  integer :: dt_rad=43200, offset=1
!  logical ::                                         &
!             do_clear_sky_diag=.false., do_average=.false., &
!      do_average_gases = .false., do_average_clouds=.false.
!  logical :: rsd=.false.
!!!   real :: solar_constant = 1.96  !(1367.44w/m2)
      real :: solar_constant = 1365.
!  integer, dimension(6) :: rad_date = (/ 0, 0, 0, 0, 0, 0 /)
      logical :: do_mcm_radiation=.false.
      real :: co2std = 330., ratio = 1.0
!     integer :: jpt = -35, ipt = -35
       real :: lat_diag = -1000.
       real :: long_diag = -1000.
!     logical :: calc_hemi_integrals = .false.
!     logical :: renormalize_sw_fluxes=.false.
!     logical :: do_bounds_chk        =.false.

! character(len=24) :: zenith_spec = '      '
!  character(len=16)    :: rad_step_physics='default'

!logical         :: all_column_radiation = .true.
!logical         :: all_level_radiation = .true.
!integer         :: topmost_radiation_level=-99

namelist /original_fms_rad_nml/ &
!                               offset, do_average, &
!                               do_average_gases, do_average_clouds, &
!                               do_clear_sky_diag,          &
!                               zenith_spec,  &
!                               rad_step_physics, &
!                               calc_hemi_integrals, &
                                lat_diag, long_diag, &
!                               renormalize_sw_fluxes, &
!                               solar_constant, rad_date,   &
                                solar_constant,             &
!                               co2std, ratio, jpt, ipt, &
                                co2std, ratio, &
!                               do_bounds_chk, &
!  all_level_radiation, &
!  topmost_radiation_level, &
!  all_column_radiation, &
!                               rsd
                                do_mcm_radiation

!-----------------------------------------------------------------------
!-------------------- diagnostics fields -------------------------------

integer :: id_alb_sfc, id_coszen

integer, dimension(2) :: id_tdt_sw,   id_tdt_lw,  &
                         id_swdn_toa, id_swup_toa, id_olr, &
                         id_swup_sfc, id_swdn_sfc,         &
                         id_lwup_sfc, id_lwdn_sfc

!character(len=9), parameter :: mod_name = 'radiation'
character(len=16), parameter :: mod_name = 'radiation'

real :: missing_value = -999.
logical  :: do_sea_esf_rad
logical  :: do_clear_sky_pass

!-------------------------------------------------------------------- 
!   list of restart versions readable by this module ----
!-------------------------------------------------------------------- 
integer, dimension(2) :: restart_versions_sea = (/ 2, 3 /)

!--------------------------------------------------------------------
!   tdt_rad = the current radiative (sw + lw) heating rate
!--------------------------------------------------------------------

!---------------------------------------------------------------------
! diagnostics field informations 
!---------------------------------------------------------------------
integer ::             id_cosz, id_fracday 

logical   :: do_diurnal, do_annual, do_daily_mean

integer            ::  id, jd, kmin, kmax
integer            ::  ipgl, jpgl
integer            ::  vers
integer            ::  ksrad, kerad ! vertical indices on radiation grid
                                    ! ksrad ==1

integer            ::  ks, ke ! vertical indices in model grid coords
                              !  ks is topmost_radiation_level
integer            ::  iomsgs
real               ::  rh2o_lower_limit_orig=3.0E-06
real               ::  rh2o_lower_limit_seaesf=2.0E-07
real               ::  rh2o_lower_limit

     integer :: israd, ierad, jsrad, jerad

!---------------------------------------------------------------------
!---------------------------------------------------------------------

                         contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!####################################################################

! <SUBROUTINE NAME="original_fms_rad_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call original_fms_rad_init
!  </TEMPLATE>
! </SUBROUTINE>
!
   subroutine original_fms_rad_init ( lonb, latb, pref, axes, Time , &
!      co2std, ratio, kmax,  &
!                     kmax,  &
                      kmax)
!      lat_diag, long_diag, ipgl, jpgl)
!                           ipgl, jpgl)

!-----------------------------------------------------------------------
           integer, intent(in)  :: kmax
!   real, intent(in) :: co2std, ratio
           real, intent(in), dimension(:,:) :: lonb, latb
           real, intent(in), dimension(:,:) :: pref
        integer, intent(in), dimension(4)   :: axes
type(time_type), intent(in)                 :: Time
!real, intent(inout) :: lat_diag, long_diag
!integer, intent(out) :: ipgl, jpgl
!-----------------------------------------------------------------------
      integer :: unit, io, ierr


!     character(len=4) :: chvers

      real, dimension(size (lonb,1)-1) :: idiff
      real, dimension(size (latb,2)-1) :: jdiff
      integer :: i, j, minindx
      real  :: mindiff
      integer :: id, jd

      if(module_is_initialized) return
      call fms_init
      call rad_utilities_init

!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=original_fms_rad_nml, iostat=io)
      ierr = check_nml_error(io,'original_fms_rad_nml')
#else   
      if ( file_exist('input.nml')) then
        unit = open_namelist_file ()
        ierr=1; do while (ierr /= 0)
          read  (unit, nml=original_fms_rad_nml, iostat=io, end=10)
          ierr = check_nml_error(io,'original_fms_rad_nml')
        enddo
  10    call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
      if ( mpp_pe() == mpp_root_pe() ) then
        call write_version_number(version, tagname)
        write (unit, nml=original_fms_rad_nml)
      endif


    jd = size(latb,2)-1
    id = size(lonb,1)-1
    
!--------------------------------------------------------------------
!  define location of radiation diagnostics column, if present
!--------------------------------------------------------------------

     if (lat_diag /= -1000. .and. long_diag /= -1000.) then
       if ( (lat_diag < -90. .or. lat_diag > 90.) .or.  &
           (long_diag <    0. .or. long_diag > 360.) ) then 
          call error_mesg ('original_fms_rad_mod', & 
       ' bad values specified for lat_diag or long_diag', FATAL) 
       endif
       
!      jd = size(latb,2)-1
!      id = size(lonb,1) - 1
       lat_diag = lat_diag*4.0*atan(1.0)/180.0
       long_diag = long_diag*4.0*atan(1.0)/180.0
       if (  (lat_diag >= latb(1,1) .and. lat_diag <= latb(1,jd+1))   .and. &
          (long_diag >= lonb(1,1) .and. long_diag <= lonb(id+1,1))  ) then
         do j=1,jd
           jdiff(j) = abs ( 0.5*(latb(1,j)+latb(1,j+1)) - lat_diag)  
         end do
          mindiff = 10.0
          minindx = 1
         do j=1,jd
          if (jdiff(j) .lt. mindiff) then
            mindiff = jdiff(j)
            minindx = j
          endif 
          end do
          jpgl = minindx
         do i=1,id
           idiff(i) = abs ( 0.5*(lonb(i,1)+lonb(i+1,1)) - long_diag)  
         end do
          mindiff = 10.0
          minindx = 1
         do i=1,id
          if (idiff(i) .lt. mindiff) then
            mindiff = idiff(i)
            minindx = i
          endif 
          end do
          ipgl = minindx
         else
            jpgl = 0  
            ipgl = 0  
         endif
         else
            jpgl = 0  
            ipgl = 0  
         endif

!        print *,  get_my_pe() , ipgl, jpgl

!-----------------------------------------------------------------------

         call rdparm_init (kmax)

         if(do_mcm_radiation) then
           call mcm_lw_init (id,jd,kmax)
           call mcm_sw_driver_init(kmax)
         else
           call co2_data (co2std, ratio, pref)
         endif

         call clouds_init ( lonb, latb, axes, Time )

         module_is_initialized = .true.

   end subroutine original_fms_rad_init

!#######################################################################

! <SUBROUTINE NAME="original_fms_rad_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call original_fms_rad_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine original_fms_rad_end

!   --- terminate other modules ---

if(.not.module_is_initialized) return
 
     call clouds_end

!-----------------------------------------------------------------------
module_is_initialized = .false.

end subroutine original_fms_rad_end
      
!###################################################################

!subroutine original_fms_rad (is, ie, js, je, kerad, ipgl, jpgl,   &
!subroutine original_fms_rad (lat_in, lon_in, is, ie, js, je, kerad,   &
!subroutine original_fms_rad (is, ie, js, je, kerad, lat_in, lon_in, &
! <SUBROUTINE NAME="original_fms_rad">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call original_fms_rad (is, ie, js, je, phalf, lat_in, lon_in, &
!                do_clear_sky_pass, &
!                Rad_time, Time_diag, Atmos_input, &
!                Surface, &
!                Astro, Rad_gases, Cldrad_props, Cld_spec, &
!                Fsrad_output, mask, kbot) 
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="phalf" TYPE="real">
! 
!  </IN>
!  <IN NAME="lat_in" TYPE="real">
! 
!  </IN>
!  <IN NAME="lon_in" TYPE="real">
! 
!  </IN>
!  <IN NAME="do_clear_sky_pass" TYPE="logical">
! 
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
! 
!  </IN>
!  <IN NAME="Time_diag" TYPE="time_type">
! 
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
! 
!  </IN>
!  <IN NAME="Surface" TYPE="surface_type">
! 
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
! 
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
! 
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
! 
!  </IN>
!  <INOUT NAME="Fsrad_output" TYPE="fsrad_output_type">
! 
!  </INOUT>
!  <IN NAME="mask" TYPE="real">
! 
!  </IN>
!  <IN NAME="kbot" TYPE="integer">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine original_fms_rad (is, ie, js, je, phalf, lat_in, lon_in, &
                             do_clear_sky_pass, &
                             Rad_time, Time_diag, Atmos_input, &
                             Surface, &
                             Astro, Rad_gases, Cldrad_props, Cld_spec, &
                             Fsrad_output, mask, kbot) 

!--------------------------------------------------------------------
!integer, intent(in) :: is, ie, js, je, kerad, ipgl, jpgl
!integer, intent(in) :: is, ie, js, je, kerad              
integer, intent(in) :: is, ie, js, je
real, intent(in), dimension(:,:,:) :: phalf
real, dimension(:,:), intent(in) :: lat_in, lon_in
type(time_type), intent(in) :: Rad_time, Time_diag
logical, intent(in) :: do_clear_sky_pass
type(atmos_input_type), intent(in) :: Atmos_input
type(surface_type), intent(in) :: Surface
type(astronomy_type), intent(in) :: Astro        
type(radiative_gases_type), intent(in) :: Rad_gases
type(cldrad_properties_type), intent(in) :: Cldrad_props
type(cld_specification_type), intent(in) :: Cld_spec
type(fsrad_output_type), intent(inout)  :: Fsrad_output
real, dimension(:,:,:), intent(in), optional :: mask
integer, dimension(:,:), intent(in), optional  :: kbot
!--------------------------------------------------------------------
!-----------------------------------------------------------------------
! local variables

!    real,dimension(size( lat_in,1),size( lat_in,2), ke+1     )   ::   &
!                    press_in, temp_in, pflux_in, tflux_in, &
!      real, dimension(ie-is+1, je-js+1, kerad+1) :: &
      real, dimension(ie-is+1, je-js+1, size(Atmos_input%press,3)) :: &
                    cldamt,emcld, cuvrf,cirrf, cirab

!    real,dimension(size( lat_in,1),size( lat_in,2), ke               )   ::  &
!                   rh2o_in,  deltaz_in, cloud_water_in, cloud_ice_in,&
!                   q,qo3

!    real,dimension(size( lat_in,1),size( lat_in,2)     )   ::  &
!                      land_in, tsfc, asfc_in, psfc 
!     real, dimension(ie-is+1, je-js+1, kerad+1) :: temp, press, &
     real, dimension(ie-is+1, je-js+1, size(Atmos_input%press,3)) :: temp, press, &
                                                pflux, tflux

!    real, dimension(ie-is+1, je-js+1, kerad+1) :: temp, press, &
!                                               pflux, tflux
!    real, dimension(ie-is+1, je-js+1, kerad  ) :: rh2o        , &
     real, dimension(ie-is+1, je-js+1, size(Atmos_input%press,3)-1  ) :: rh2o        , &
                                                   q, qo3
!    integer,dimension(size(temp_in,1),size(temp_in,2), size(temp_in,3) ) ::  &
!  integer, dimension(ie-is+1, je-js+1, kerad+1  ) :: &
   integer, dimension(ie-is+1, je-js+1, size(Atmos_input%press,3)  ) :: &
                    ktop,kbtm, ktopsw, kbtmsw

!    integer,dimension(size(temp_in,1),size(temp_in,2))   :: nclds
      integer, dimension(ie-is+1, je-js+1 ) ::   nclds

     integer ::                   ip, jp
     logical :: no_clouds



     real :: rrsun

      real, dimension(ie-is+1, je-js+1) :: &
!               lat, lon, land, asfc, cosz, fracday, solar, &
                          land, asfc, cosz, fracday, solar, &
!23             lat ,lon ,land, asfc, cosz, fracday, solar, &
                 psfc, tsfc
!     real, dimension(ie-is+1, je-js+1, kerad  ) :: &
!     real, dimension(ie-is+1, je-js+1, size(Atmos_input%press,3)  ) :: &
!                             cloud_water, cloud_ice, deltaz, qo3_in, &
!                       qo3_out          

      integer :: ierad, jerad, kerad
      real :: rvco2

           ierad = ie - is + 1
           jerad = je -js + 1
           kerad = size(Atmos_input%press,3) - 1
!   print *, get_my_pe(), is, ie, js, je, kerad, do_clear_sky_pass
!   print *, 'lat', get_my_pe(), lat_in
!   print *, 'lon', get_my_pe(), lon_in
!   print *, 'ipgl,jpgl', get_my_pe(), ipgl, jpgl
!--------------------------------------------------------------------
!    define variables on the radiation grid which will be passed into
!    the radiation routines.
!---------------------------------------------------------------------
               press = Atmos_input%press
               temp  = Atmos_input%temp 
               rh2o  = Atmos_input%rh2o 
               asfc  = Surface%asfc
               psfc  = Atmos_input%psfc 
               tsfc  = Atmos_input%tsfc 
               pflux = Atmos_input%pflux
               tflux = Atmos_input%tflux
!              deltaz = Atmos_input%deltaz
               land  = Surface%land
!              cloud_water = Atmos_input%cloud_water
!              cloud_ice = Atmos_input%cloud_ice

!-------------------------------------------------------------------
!    make mods necessary for use with original fms radiation code:
!    1) the value expected for cosz in the diurnally-varying case is the
!    product of cosz and fracday; and 2) the solar constant is included 
!    in the solar array, in contrast to the sea-esf radiation, where it 
!    is resident in the shortwave module and is applied in that module.
!--------------------------------------------------------------------
!              cosz = Astro%cosz
!              if (Astro%do_diurnal) then
               if (Sw_control%do_diurnal) then
                 cosz = Astro%cosz*Astro%fracday
               else
                 cosz = Astro%cosz
               endif
               fracday = Astro%fracday
!       solar = Astro%solar
               solar = Astro%solar*solar_constant
               rrsun = Astro%rrsun

               qo3 = Rad_gases%qo3
               rvco2 = Rad_gases%rrvco2
     
        allocate (Fsrad_output%tdtsw    ( ierad, jerad, kerad) )
        allocate (Fsrad_output%tdtlw    ( ierad, jerad, kerad) )
        allocate (Fsrad_output%swdns    ( ierad, jerad       ) )
        allocate (Fsrad_output%swups    ( ierad, jerad       ) )
        allocate (Fsrad_output%lwdns    ( ierad, jerad       ) )
        allocate (Fsrad_output%lwups    ( ierad, jerad       ) )
        allocate (Fsrad_output%swin     ( ierad, jerad       ) )
        allocate (Fsrad_output%swout    ( ierad, jerad       ) )
        allocate (Fsrad_output%olr      ( ierad, jerad       ) )

        Fsrad_output%tdtsw   = 0.
        Fsrad_output%tdtlw  = 0.
        Fsrad_output%swdns   = 0.
        Fsrad_output%swups  = 0.
        Fsrad_output%lwdns   = 0.
        Fsrad_output%lwups   = 0.
        Fsrad_output%swin     = 0.
        Fsrad_output%swout  = 0.
        Fsrad_output%olr     = 0.
     if (do_clear_sky_pass) then
        allocate (Fsrad_output%tdtsw_clr( ierad, jerad, kerad) )
        allocate (Fsrad_output%tdtlw_clr( ierad, jerad, kerad) )
        allocate (Fsrad_output%swdns_clr( ierad, jerad       ) )
        allocate (Fsrad_output%swups_clr( ierad, jerad       ) )
        allocate (Fsrad_output%lwdns_clr( ierad, jerad       ) )
        allocate (Fsrad_output%lwups_clr( ierad, jerad       ) )
        allocate (Fsrad_output%swin_clr ( ierad, jerad       ) )
        allocate (Fsrad_output%swout_clr( ierad, jerad       ) )
        allocate (Fsrad_output%olr_clr  ( ierad, jerad       ) )

        Fsrad_output%tdtsw_clr = 0.
        Fsrad_output%tdtlw_clr =0.
        Fsrad_output%swdns_clr = 0.
        Fsrad_output%swups_clr = 0.
        Fsrad_output%lwdns_clr = 0.
        Fsrad_output%lwups_clr = 0.
        Fsrad_output%swin_clr  = 0.
        Fsrad_output%swout_clr = 0.
        Fsrad_output%olr_clr   = 0.
     endif

!----------------------------------------------------------------------
!   determine if radiation diagnostics column is present in current 
!   physics window. if so, determine its coordinates in the 
!   physics_window space. if not present, set ip and jp to 0.
!----------------------------------------------------------------------
!        call define_diag_column (is, ie, js, je, ipgl, jpgl, lat,   &
        call define_diag_column (is, ie, js, je,             lat_in,   &
                                 lon_in, ip, jp)
       
!-----------------------------------------------------------------------
!--------------- loop for clear sky diagnostics option -----------------

      if (do_clear_sky_pass) then
        no_clouds = .true.
!  redefine values to be input to clouds to be the time-averaged ones
!  now available, when that option is selected.
!  this change MAY affect isccp diagnostics from strat_cloud_mod.

     q = rh2o/(1.+rh2o)

!      call clouds (is,js, no_clouds, Rad_time, Time_diag, lat, land, tsfc, &
      call clouds (is,js, no_clouds, Rad_time, Time_diag, lat_in, land, tsfc, &
!                   press(:,:,1:kmax), pflux, temp(:,:,1:kmax), q,  &
                    press(:,:,1:kerad), pflux, temp(:,:,1:kerad), q,  &
                            cosz ,nclds, ktopsw, kbtmsw, ktop, kbtm,   &
                    cldamt, cuvrf, cirrf, cirab, emcld, mask, kbot)
!-----------------------------------------------------------------------
!----------------------------- radiation -------------------------------

     if (present(kbot)) then
!        call fsrad (ip,jp,press,temp,rh2o,Rad_gases%qo3,  &
         call fsrad (ip,jp,press,temp,rh2o,          qo3,  &
                     phalf,do_mcm_radiation,               &
                     nclds,ktopsw,kbtmsw,ktop,kbtm,cldamt,  &
                     emcld,cuvrf,cirrf,cirab,asfc,rvco2,  &
                            cosz ,          solar,                            &
                     Fsrad_output%swin_clr,Fsrad_output%swout_clr, &
                     Fsrad_output%olr_clr,Fsrad_output%swups_clr, &
                     Fsrad_output%swdns_clr,Fsrad_output%lwups_clr, &
                     Fsrad_output%lwdns_clr,  &
                     Fsrad_output%tdtsw_clr,Fsrad_output%tdtlw_clr, &
                     kbot,psfc)
     else
!        call fsrad (ip,jp,press,temp,rh2o,Rad_gases%qo3,  &
         call fsrad (ip,jp,press,temp,rh2o,          qo3,  &
                     phalf,do_mcm_radiation,               &
                     nclds,ktopsw,kbtmsw,ktop,kbtm,cldamt,  &
                     emcld,cuvrf,cirrf,cirab,asfc,rvco2,  &
                  cosz ,solar,                            &
                     Fsrad_output%swin_clr,Fsrad_output%swout_clr, &
                     Fsrad_output%olr_clr,Fsrad_output%swups_clr, &
                     Fsrad_output%swdns_clr,Fsrad_output%lwups_clr, &
                     Fsrad_output%lwdns_clr,  &
                     Fsrad_output%tdtsw_clr,Fsrad_output%tdtlw_clr )
     endif

  endif  ! (do_clear_sky_pass)

        no_clouds = .false.

!  redefine values to be input to clouds to be the time-averaged ones
!  now available, when that option is selected.
!  this change MAY affect isccp diagnostics from strat_cloud_mod.

     q = rh2o/(1.+rh2o)

!     call clouds (is,js, no_clouds, Rad_time, Time_diag, lat, land, tsfc, &
      call clouds (is,js, no_clouds, Rad_time, Time_diag, lat_in, land, tsfc, &
!                   press(:,:,1:kmax), pflux, temp(:,:,1:kmax), q,  &
                    press(:,:,1:kerad), pflux, temp(:,:,1:kerad), q,  &
                            cosz ,nclds, ktopsw, kbtmsw, ktop, kbtm,   &
                    cldamt, cuvrf, cirrf, cirab, emcld, mask, kbot)
 
!-----------------------------------------------------------------------
!----------------------------- radiation -------------------------------

     if (present(kbot)) then
!        call fsrad (ip,jp,press,temp,rh2o,Rad_gases%qo3,  &
         call fsrad (ip,jp,press,temp,rh2o,          qo3,  &
                     phalf,do_mcm_radiation,               &
                     nclds,ktopsw,kbtmsw,ktop,kbtm,cldamt,  &
                     emcld,cuvrf,cirrf,cirab,asfc,rvco2,  &
                  cosz ,solar,                            &
                     Fsrad_output%swin,Fsrad_output%swout, &
                     Fsrad_output%olr,Fsrad_output%swups, &
                     Fsrad_output%swdns,Fsrad_output%lwups, &
                     Fsrad_output%lwdns,  &
                     Fsrad_output%tdtsw,Fsrad_output%tdtlw, kbot,psfc)
     else
!        call fsrad (ip,jp,press,temp,rh2o,Rad_gases%qo3,  &
         call fsrad (ip,jp,press,temp,rh2o,          qo3,  &
                     phalf,do_mcm_radiation,               &
                     nclds,ktopsw,kbtmsw,ktop,kbtm,cldamt,  &
                     emcld,cuvrf,cirrf,cirab,asfc,rvco2,  &
                            cosz ,solar,                            &
                     Fsrad_output%swin,Fsrad_output%swout, &
                     Fsrad_output%olr,Fsrad_output%swups, &
                     Fsrad_output%swdns,Fsrad_output%lwups, &
                     Fsrad_output%lwdns,  &
                     Fsrad_output%tdtsw,Fsrad_output%tdtlw)
     endif

     if (do_clear_sky_pass) then
       Fsrad_output%npass = 2
      else

       Fsrad_output%npass = 1
      endif

!---------------------------------------------------------------------

end subroutine original_fms_rad

!#####################################################################

!subroutine define_diag_column (is, ie, js, je, ipgl, jpgl, lat,  &
! <SUBROUTINE NAME="define_diag_column">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_diag_column (is, ie, js, je,             lat,  &
!                lon, ip, jp) 
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="lat" TYPE="real">
! 
!  </IN>
!  <IN NAME="lon" TYPE="real">
! 
!  </IN>
!  <OUT NAME="ip" TYPE="integer">
! 
!  </OUT>
!  <OUT NAME="jp" TYPE="integer">
! 
!  </OUT>
! </SUBROUTINE>
!
subroutine define_diag_column (is, ie, js, je,             lat,  &
                               lon, ip, jp) 

!--------------------------------------------------------------------
!integer, intent(in) :: is, ie, js, je, ipgl, jpgl
integer, intent(in) :: is, ie, js, je
real, dimension(:,:), intent(in) :: lat, lon
integer, intent(out) :: ip, jp
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   determine if radiation diagnostics column is present in current 
!   physics window. if so, determine its coordinates in the 
!   physics_window space. if not present, set ip and jp to 0.
!----------------------------------------------------------------------
       
     if (jpgl == 0 .and. ipgl == 0) then
       ip = 0
       jp = 0
     else
       if  (   (is <= ipgl .and. ie >= ipgl) .and.   &
               (js <= jpgl .and. je >= jpgl) ) then
          ip = ipgl - is + 1
          jp = jpgl - js + 1
          print *, 'long and lat of point for radiation diagnostics', &
                    lon(ip,jp)*45./atan(1.0), lat(ip,jp)*45./atan(1.0)      
        else
          ip = 0
          jp = 0
        endif
      endif

end subroutine define_diag_column 

!######################################################################
      
                 end module original_fms_rad_mod


                       module ozone_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  This code supplies mass mixing ratios of ozone (g/g) to the 
!  sea_esf_rad radiation_package (and the original_fms_rad package).
! </OVERVIEW>
! <DESCRIPTION>
!  This code supplies mass mixing ratios of ozone (g/g) to the 
!  sea_esf_rad radiation_package (and the original_fms_rad package).
!   Recent changes allow provision for predicted ozone to be considered. 
!   This is a field passed in the tracer array, r 
! </DESCRIPTION>
!   shared modules:

use mpp_mod,             only: input_nml_file
use fms_mod,             only: open_namelist_file, file_exist,    &
                               check_nml_error, error_mesg,  &
                               fms_init, stdlog, &
                               write_version_number, FATAL, NOTE, &
                               WARNING, mpp_pe, mpp_root_pe, close_file
use fms_io_mod,          only: read_data, open_restart_file
use time_manager_mod,    only: time_type,  &
                               time_manager_init, operator(+), &
                               set_date, operator(-), print_date, &
                               set_time, operator(>), get_date, days_in_month
use diag_manager_mod,    only: diag_manager_init, get_base_time
use time_interp_mod,     only: fraction_of_year, &
                               time_interp_init  
use constants_mod,       only: constants_init, radian
use interpolator_mod,    only: interpolate_type, interpolator_init, &
                               obtain_interpolator_time_slices, &
                               unset_interpolator_time_flag, &
                               interpolator, interpolator_end, &
                               CONSTANT, INTERP_WEIGHTED_P

!-------------------------------

use tracer_manager_mod,  only: get_tracer_index, NO_TRACER
use field_manager_mod,   only: MODEL_ATMOS

!---------------------------------

!   shared radiation package modules:

use rad_utilities_mod,   only:  rad_utilities_init,   &
                                radiative_gases_type,  &
                                atmos_input_type

!---------------------------------------------------------------------

implicit none
private

!-------------------------------------------------------------------
!    ozone_mod supplies mass mixing ratios of ozone [ g/g ] to the 
!    model radiation package.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

character(len=128)  :: version =  '$Id: ozone.F90,v 18.0.2.2 2010/09/07 16:17:19 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public       &
        ozone_init, ozone_time_vary, ozone_driver, ozone_endts, &
        ozone_end
private         &

!   called from ozone_init:
        obtain_input_file_data, &
        obtain_gfdl_zonal_ozone_data, &
        obtain_clim_zonal_ozone_data, &

!   called from ozone_driver:
        gfdl_zonal_ozone, &
        get_clim_ozone

interface gfdl_zonal_ozone
    module procedure geto3_2d, geto3_3d
end interface


!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=24)  ::   basic_ozone_type = 'clim_zonal'     
                      ! label for ozone type, currently unused      
                      ! 'clim_zonal' or 'time_varying' or 'fixed_year'
character(len=32)  :: filename = 'o3.trend.nc'
                      ! name of file which contains the ozone data 
integer, parameter :: MAX_DATA_FIELDS = 1
character(len=32)  :: data_name(MAX_DATA_FIELDS) = 'ozone_1990'
                      ! name of variable in the data file to be used
character(len=24)  ::   ozone_data_source = 'fortuin_kelder' 
                      ! source for the ozone data being used, either 
                      ! 'input', 'gfdl_zonal_ozone', 'calculate_column'
                      ! for the date and location specified,
                      ! or externally-derived datasets:
                      ! 'fortuin_kelder', 'mozart_moztop_fk',
                      ! 'mozart_trop_fk'
character(len=24)  ::   clim_base_year = '1990'
                      ! year with which the ozone data set is assoc-
                      ! iated, used with fortuin_kelder( either '1979',
                      ! '1990' or '1997'), or mozart datasets
                      ! (presently either '1850' or '1860' or '1990')
character(len=24)  ::   trans_data_type = 'linear'
                      ! time interpolation method to be used if trans-
                      ! ient ozone is activated, not yet available
character(len=24)  ::   gfdl_zonal_ozone_type = 'seasonally_varying'
                      ! if gfdl_zonal_ozone is active, the time behavior
                      ! of ozone to use; either 'winter', 'summer', 
                      ! 'spring', 'autumn', annual_mean' or
                      ! 'seasonally_varying'
logical            ::   do_mcm_o3_clim = .false.
                      ! treat ozone as in the manabe climate model ?
integer, dimension(6) ::       &
                        ozone_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in ozone data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
real,dimension(2)  :: lonb_col = (/-999., -999./)
                      ! longitudes defining the region to use for column
                      ! data calculation
real,dimension(2)  :: latb_col = (/-999., -999./)
                      ! latitudes defining the region to use for column
                      ! data calculation
integer, dimension(6) :: time_col = (/0,0,0,0,0,0/)
                      ! time to use for column calculation
logical      ::  do_coupled_stratozone = .false. ! include the coupled
                                                 ! stratospheric ozone effects?


namelist /ozone_nml/             &
                       basic_ozone_type, &
                       ozone_data_source, &
                       lonb_col, latb_col, time_col, &
                       clim_base_year, &
                       trans_data_type, &
                       data_name, &
                       filename, &
                       gfdl_zonal_ozone_type, &
                       ozone_dataset_entry, &
                       do_mcm_o3_clim, &
                       do_coupled_stratozone

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------


!-------------------------------------------------------------------
!    qqo3 contains the column input ozone mass mixing ratio (g/g).
!    used when ozone_data_source = 'input'.
!-------------------------------------------------------------------
real, dimension (:), allocatable     ::  qqo3

!-------------------------------------------------------------------
!    o3data contains the zonal ozone mass mixing ratio (10**6 g/g)
!    at 19 specified latitudes, 81 specified pressures and up to 4
!    specified times. rstd contains the zonal ozone mass mixing ratio 
!    (10**6 g/g) at 19 specified latitudes, 81 specified pressures and 
!    at the currently specified time. ph is the array defining the 
!    interface levels in the zonal ozone data set. used when
!    ozone_data_source = 'gfdl_zonal_ozone'.
!-------------------------------------------------------------------
real, dimension (82)        ::    ph
real, dimension (19,81,4)   ::    o3data
real, dimension (19,81)     ::    rstd

!----------------------------------------------------------------------
!    O3 is an interpolate_type variable containing the relevant 
!    information about the ozone data set. used when
!    ozone_data_source = 'fortuin_kelder', 'mozart_moztop_fk',
!    'mozart_trop_fk', and others in the future.
!---------------------------------------------------------------------- 
type(interpolate_type),save         ::  O3_interp 

!---------------------------------------------------------------------
!    miscellaneous variables:

integer     ::  iseason=-1 ! flag indicating type of gfdl_zonal_ozone 
                           ! time variation to use
real        ::  current_fyear=-1.0  
                           ! flag to force interpolation on initial call
                           ! (used with gfdl_zonal_ozone)
logical     ::  do_gfdl_zonal_ozone=.false.
                           ! using gfdl zonal ozone data set ?
logical     ::  do_clim_zonal_ozone=.false.
                           ! using clim zonal ozone data set ?
logical     ::  do_column_input_ozone=.false.
                           ! using ozone column input data set ?
logical     ::  do_predicted_ozone=.false.
                           ! using predicted ozone ?
logical     ::  module_is_initialized=.false.  ! module initialized ?

type(time_type) :: Model_init_time  ! initial calendar time for model  
                                    ! [ time_type ]
type(time_type) :: Ozone_offset     ! difference between model initial
                                    ! time and ozone timeseries app-
                                    ! lied at model initial time
                                    ! [ time_type ]
type(time_type) :: Ozone_entry      ! time in ozone timeseries which
                                    ! is mapped to model initial time
                                    ! [ time_type ]
type(time_type) :: Ozone_time       ! time for which ozone profile is 
                                    ! valid
type(time_type) :: Ozone_column_time
                                    ! time for which ozone data is extr
                                    ! acted from the ozone timeseries
                                    ! in the 'calculate_columns' case
                                    ! [ time_type ]
logical    :: negative_offset = .false.
                            !  the model initial time is later than
                            !  the ozone_dataset_entry time  ?


include 'netcdf.inc'


!-------------------------------------------------------------------
!-------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! <SUBROUTINE NAME="ozone_init">
!  <OVERVIEW>
!   ozone_init is the constructor for ozone_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   ozone_init is the constructor for ozone_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ozone_init (latb, lonb)
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes at cell corners [radians]
!  </IN>
! </SUBROUTINE>
!
subroutine ozone_init (latb, lonb)

!---------------------------------------------------------------------
!    ozone_init is the constructor for ozone_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:,:),   intent(in) :: latb, lonb
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  intent(in) variables:
!
!       latb      2d array of model latitudes at cell corners 
!                 [ radians ]
!       lonb      2d array of model longitudes at cell corners 
!                 [ radians ]
!
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!  local variables:

       integer           ::  unit, ierr, io, logunit
       integer           ::  n, no3

!---------------------------------------------------------------------
!  local variables:
!
!         unit       io unit number 
!         ierr       error code
!         io         error status returned from io operation
!
!---------------------------------------------------------------------
 

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!-------------------------------------------------------------------
      if (module_is_initialized) return

!-------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!-------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call time_manager_init   
      call diag_manager_init   
      call time_interp_init   
      call constants_init
 
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=ozone_nml, iostat=io)
      ierr = check_nml_error(io,"ozone_nml")
#else
!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=ozone_nml, iostat=io, end=10)
        ierr = check_nml_error(io, 'ozone_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=ozone_nml)

!---------------------------------------------------------------------
!    check for a valid value of clim_base_year.
!---------------------------------------------------------------------
      if (trim(basic_ozone_type) == 'clim_zonal' ) then 
        if (trim(clim_base_year)  == '1990' .or.        &
            trim(clim_base_year)  == '1979' .or.        &
            trim(clim_base_year)  == '1850' .or.        &
            trim(clim_base_year)  == '1860' .or.        &
            trim(clim_base_year)  == '1997')            then
        else
          call error_mesg ('ozone_mod', &
              ' clim_base_year must be 1990, 1979, 1850, 1860 &
                                        &or 1997 at present', FATAL)
        endif
        Ozone_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *,   &
           'Ozone data is obtained from a clim_zonal ozone file &
             &for year ', trim(clim_base_year)
        endif

!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the ozone timeseries 
!    files are to be used.                                
!---------------------------------------------------------------------
      else if (trim(basic_ozone_type) == 'time_varying') then
        Model_init_time = get_base_time()
 
!---------------------------------------------------------------------
!    if a dataset entry point is not supplied, use the model base time 
!    as the entry point.
!---------------------------------------------------------------------
        if (ozone_dataset_entry(1) == 1 .and. &
            ozone_dataset_entry(2) == 1 .and. &
            ozone_dataset_entry(3) == 1 .and. &
            ozone_dataset_entry(4) == 0 .and. &
            ozone_dataset_entry(5) == 0 .and. &
            ozone_dataset_entry(6) == 0 ) then
          Ozone_entry = Model_init_time
 
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ozone_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        else
          Ozone_entry  = set_date (ozone_dataset_entry(1), &
                                   ozone_dataset_entry(2), &
                                   ozone_dataset_entry(3), &
                                   ozone_dataset_entry(4), &
                                   ozone_dataset_entry(5), &
                                   ozone_dataset_entry(6))
        endif
        call print_date (Ozone_entry , str='Data from ozone timeseries &
                                           &at time:')
        call print_date (Model_init_time , str='This data is mapped to &
                                                &model time:')
        Ozone_offset = Ozone_entry - Model_init_time
 
        if (Model_init_time > Ozone_entry) then
          negative_offset = .true.
        else
          negative_offset = .false.
        endif
      else if (trim(basic_ozone_type) == 'fixed_year') then
        if (ozone_dataset_entry(1) == 1 .and. &
            ozone_dataset_entry(2) == 1 .and. &
            ozone_dataset_entry(3) == 1 .and. &
            ozone_dataset_entry(4) == 0 .and. &
            ozone_dataset_entry(5) == 0 .and. &
            ozone_dataset_entry(6) == 0 ) then
           call error_mesg ('ozone_mod', &
            'must set ozone_dataset_entry when using  &
                                  &fixed_year ozone', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ozone_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        Ozone_entry  = set_date (ozone_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('ozone_mod', &
           'Ozone data is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'Ozone data obtained from ozone timeseries &
                    &for year:', ozone_dataset_entry(1)
        endif

!------------------------------------------------------------------
!    use predicted ozone
!-----------------------------------------------------------------
      else if (trim(basic_ozone_type) == 'predicted_ozone' ) then
        do_predicted_ozone = .true.
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'Using predicted ozone '
        endif
        no3= get_tracer_index(MODEL_ATMOS,'O3')
        if (no3 == NO_TRACER) &
          call error_mesg ('ozone_mod', &
            'Using predicted ozone but O3 tracer not present in field_table', FATAL)

      else
        call error_mesg ('ozone_mod', &
          'invalid specification of basic_ozone_type', FATAL)
      endif

!------------------------------------------------------------------
!    obtain the desired ozone data set based on the value of namelist
!    variable 'ozone_data_source'. set a logical flag to true to 
!    indicate the desired ozone data source. 
!-----------------------------------------------------------------
      if (trim(ozone_data_source) == 'input' ) then
        do_column_input_ozone = .true.
        call obtain_input_file_data 

      else if (trim(ozone_data_source) == 'gfdl_zonal_ozone' ) then
        do_gfdl_zonal_ozone = .true.
        if (trim(gfdl_zonal_ozone_type)      == 'winter' ) then
          iseason = 1   
        else if (trim(gfdl_zonal_ozone_type) == 'spring' ) then
          iseason = 2   
        else if (trim(gfdl_zonal_ozone_type) == 'summer' ) then
          iseason = 3   
        else if (trim(gfdl_zonal_ozone_type) == 'autumn' ) then
          iseason = 4   
        else if (trim(gfdl_zonal_ozone_type) == 'annual_mean' ) then
          iseason = 0   
        else if (trim(gfdl_zonal_ozone_type) ==    &
                                            'seasonally_varying' ) then
          iseason = 5   
        else
          call error_mesg ( 'ozone_mod', &
                    'improper specification of nml variable  '//&
                                     'gfdl_zonal_ozone_type', FATAL)
        endif
        call obtain_gfdl_zonal_ozone_data (iseason)

      else if (trim(ozone_data_source) == 'fortuin_kelder' ) then
        do_clim_zonal_ozone = .true.
        call obtain_clim_zonal_ozone_data (lonb, latb)

      else if (trim(ozone_data_source) == 'mozart_moztop_fk' ) then
        do_clim_zonal_ozone = .true.
        call obtain_clim_zonal_ozone_data (lonb, latb)

      else if (trim(ozone_data_source) == 'mozart_trop_fk' ) then
        do_clim_zonal_ozone = .true.
        call obtain_clim_zonal_ozone_data (lonb, latb)

      else if (trim(ozone_data_source) == 'calculate_column' ) then
        do_clim_zonal_ozone = .true.
        do n=1,2
          if (lonb_col(n) < 0. .or. lonb_col(n) > 360.) then
            call error_mesg ('ozone_mod', &
                   ' invalid value for lonb_col', FATAL)
          endif
          if (latb_col(n) < -90. .or. latb_col(n) > 90.) then
            call error_mesg ('ozone_mod', &
                ' invalid value for latb_col', FATAL)
          endif
        end do
        if (time_col(1) == 0) then
          call error_mesg ('ozone_mod', &
                'invalid time specified for time_col', FATAL)
        endif
        call interpolator_init (O3_interp, filename,  &
                                spread(lonb_col/RADIAN,2,2),  &
                                spread(latb_col/RADIAN,1,2),&
                                data_out_of_bounds=  (/CONSTANT/), &
                                data_names = data_name, &
                                vert_interp=(/INTERP_WEIGHTED_P/) )
        Ozone_column_time = set_date (time_col(1), time_col(2), &
                                      time_col(3), time_col(4), &
                                      time_col(5), time_col(6))
        call print_date (Ozone_column_time,   &
            str= ' Ozone data used is from ozone timeseries at time: ')
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'Ozone data is averaged over latitudes',  &
                  latb_col(1), ' to', latb_col(2), ' and longitudes',&
                  lonb_col(1), ' to', lonb_col(2)
        endif

      else if (trim(basic_ozone_type) == 'predicted_ozone' ) then
        call error_mesg ('ozone_mod', &
          'Using predicted ozone: no input data set is necessary ', NOTE)

      else
        call error_mesg ( 'ozone_mod',    &
               ' ozone_data_source is not an acceptable value.', FATAL)
      endif

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.
    


end subroutine ozone_init


!#################################################################### 
 
subroutine ozone_time_vary (model_time)
 
!----------------------------------------------------------------------
!     subroutine ozone_time_vary calculates time-dependent, 
!     space-independent variables needed by this module.
!---------------------------------------------------------------------

type(time_type),    intent(in)   :: model_time
 
!----------------------------------------------------------------------
!
!   local variables
 
      integer         :: yr, mo, dy, hr, mn, sc, dum
      integer         :: dayspmn, mo_yr

      if (do_clim_zonal_ozone) then


       if(trim(basic_ozone_type) == 'time_varying') then
!--------------------------------------------------------------------
!    define the time in the ozone data set from which data is to be 
!    taken. if ozone is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
       if (negative_offset) then
         Ozone_time = model_time - Ozone_offset
       else
         Ozone_time = model_time + Ozone_offset
       endif
     else if(trim(basic_ozone_type) == 'fixed_year') then
       call get_date (Ozone_entry, yr, dum,dum,dum,dum,dum)
       call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
       if (mo ==2 .and. dy == 29) then
         dayspmn = days_in_month(Ozone_entry)
         if (dayspmn /= 29) then
           Ozone_time = set_date (yr, mo, dy-1, hr, mn, sc)
         else
           Ozone_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         Ozone_time = set_date (yr, mo, dy, hr, mn, sc)
       endif
     else if(trim(basic_ozone_type) == 'clim_zonal') then
       Ozone_time = model_time
    endif

!--------------------------------------------------------------------
!    if 'calculate_column' is being used, obtain the ozone values for
!    each column, one at a time, using the pressure profile for that
!    column. this allows each column to see the same ozone fields,
!    but distributed appropriately for its pressure structure.
!--------------------------------------------------------------------
   if (trim(ozone_data_source) == 'calculate_column') then
     call obtain_interpolator_time_slices (O3_interp, Ozone_column_time)
   else
     call obtain_interpolator_time_slices (O3_interp, Ozone_time)
   endif

!----------------------------------------------------------------------

     endif
 
end subroutine ozone_time_vary



!######################################################################

subroutine ozone_endts


     call unset_interpolator_time_flag (O3_interp)


end subroutine ozone_endts




!######################################################################
! <SUBROUTINE NAME="ozone_driver">
!  <OVERVIEW>
!    ozone_driver obtains the current ozone distributions and returns 
!   them in Rad_gases%qo3.
!  </OVERVIEW>
!  <DESCRIPTION>
!   ozone_driver obtains the current ozone distributions and returns 
!   them in Rad_gases%qo3.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ozone_driver (is, ie, js, je, lat, Rad_time, Atmos_input, &
!                      Rad_gases )
!  </TEMPLATE>
!  <IN NAME="is,ie,js,je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   latitude of model points  [ radians ]
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
!   time at which the climatologically-determined,
!                   time-varying ozone field should apply
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable containing the atmospheric
!   input fields needed by the radiation package
!  </IN> 
!  <INOUT NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable which will return
!                   the ozone mass mixing ratio (g/g) to the calling
!                   routine
!  </INOUT>
! </SUBROUTINE>
!

subroutine ozone_driver (is, ie, js, je, lat, Rad_time, Atmos_input, &
                         r, Rad_gases )
 
!--------------------------------------------------------------------
!   ozone_driver obtains the current ozone distributions and returns 
!   them in Rad_gases%qo3.
!--------------------------------------------------------------------

integer,                    intent(in)    :: is, ie, js, je
real, dimension(:,:),       intent(in)    :: lat
type(time_type),            intent(in)    :: Rad_time
type(atmos_input_type),     intent(in)    :: Atmos_input
real, dimension(:,:,:,:),   intent(in)    :: r
type(radiative_gases_type), intent(inout) :: Rad_gases

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      lat          latitude of model points  [ radians ]
!      Rad_time     time at which the climatologically-determined,
!                   time-varying ozone field should apply
!                   [ time_type (days, seconds) ] 
!      Atmos_input  atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!
!   intent(out) variables:
!
!      Rad_gases    radiative_gases_type variable which will return
!                   the ozone mass mixing ratio [ g/g ] to the calling
!                   routine
!
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!  local variables:
!
!      phaf         pressure at model interface levels, normalized
!                   by the mean sea level pressure (101325 N/m**2).
!                   if mcm ozone scheme is used, this variable is
!                   defined differently. [ Pa ]
!      kmax         number of model layers
!      k            do-loop index
!
!---------------------------------------------------------------------
      real, dimension (size(Atmos_input%press,1), &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3))    :: phaf

      integer   ::   kmax
      integer   ::   k, j, i   !  do-loop indices
      integer   ::   noy

!--------------------------------------------------------------------
      if ( .not. module_is_initialized)    & 
        call error_mesg ('ozone_mod',  &         
           'module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    define the number of model layers.
!---------------------------------------------------------------------
      kmax = size (Rad_gases%qo3,3) 

!-----------------------------------------------------------------------
!    if column input ozone is being used, be certain the input column
!    has the same number of levels as the model grid. broadcast the
!    column data over the entire horizontal domain.
!-----------------------------------------------------------------------
      if (do_column_input_ozone) then 
        if (size(qqo3(:)) /= kmax) then
           call error_mesg ('ozone_mod', &
             'size of ozone profile in input file does not match '//&
                                              'model grid.', FATAL)
         endif
         do k=1,kmax
           Rad_gases%qo3(:,:,k) = qqo3(k)
         end do
!---------------------------------------------------------------------
!    if a specified ozone column is not being used, define the 
!    normalized pressure to be used to assign the ozone values. this
!    formulation varies between mcm and the fms models.
!---------------------------------------------------------------------
      else 
        do k=1,kmax+1
          if (do_mcm_o3_clim) then
            phaf(:,:,k) = 100000.*Atmos_input%phalf(:,:,k)/  &
                          Atmos_input%phalf(:,:,kmax+1)
          else
            phaf(:,:,k) = (Atmos_input%pflux(:,:,k))
!           phaf(:,:,k) = (Atmos_input%pflux(:,:,k))*101325./   &
!                         (Atmos_input%pflux(:,:,kmax +1))
          endif
        end do

!---------------------------------------------------------------------
!    if gfdl_zonal_ozone has been activated, call gfdl_zonal_ozone
!    to obtain the values of ozone at model grid points at the desired
!    time Rad_time.
!---------------------------------------------------------------------
        if (do_gfdl_zonal_ozone) then
          call gfdl_zonal_ozone (Rad_time, lat, phaf, Rad_gases%qo3)

!---------------------------------------------------------------------
!    if clim_zonal_ozone has been activated, call clim_zonal_ozone
!    to obtain the values of ozone at model grid points at the desired
!    time Rad_time.
!---------------------------------------------------------------------
        else if (do_clim_zonal_ozone) then
          call get_clim_ozone (is, js, Rad_time, phaf, Rad_gases%qo3)



!---------------------------------------------------------------------
!    if do_predicted_ozone has been activated, set ozone to the appropriate
!    prognostic tracer field;  here defined by tracer name 'O3'
!---------------------------------------------------------------------
        else if ( do_predicted_ozone ) then 

          noy= get_tracer_index(MODEL_ATMOS,'O3')

          do k= 1,kmax
            do j= 1,je-js+1    
              do i= 1,ie-is+1    
!                Rad_gases%qo3(i,j,k) =  r(i,j,k,noy) * 48./29.0 
                 Rad_gases%qo3(i,j,k) =  MAX(r(i,j,k,noy),1.e-20) * 48./29.
             end do
            end do
          end do

        endif
      endif

!--------------------------------------------------------------------




end subroutine ozone_driver



!#####################################################################
! <SUBROUTINE NAME="ozone_end">
!  <OVERVIEW>
!   ozone_end is the destructor for ozone_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   ozone_end is the destructor for ozone_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ozone_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine ozone_end

!---------------------------------------------------------------------
!    ozone_end is the destructor for ozone_mod.
!---------------------------------------------------------------------
     
!---------------------------------------------------------------------
!    deallocate any module variables that have been allocated.
!---------------------------------------------------------------------
      if (do_column_input_ozone) then
        deallocate (qqo3)
      endif

!---------------------------------------------------------------------
!    call interpolator_end to close out the O3_interp interpolate_type
!    variable.
!---------------------------------------------------------------------
      if (do_clim_zonal_ozone) then
        call interpolator_end (O3_interp)
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.



end subroutine ozone_end




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!######################################################################
! <SUBROUTINE NAME="obtain_input_file_data">
!  <OVERVIEW>
!   obtain_input_file_data reads an input file containing a single
!    column ozone profile. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   obtain_input_file_data reads an input file containing a single
!    column ozone profile. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  obtain_input_file_data
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine obtain_input_file_data 

!---------------------------------------------------------------------
!    obtain_input_file_data reads an input file containing a single
!    column ozone profile.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer   :: iounit    ! unit to read file on
      integer   :: kmax_file ! number of levels of data in file
      integer   :: k         ! do-loop index
      character(len=31), dimension(200) :: dimnam
      integer(kind=4), dimension(200) :: dimsiz
      integer(kind=4)                 :: ncid, rcode, nvars, ndims, &
                                         ngatts, recdim
      integer    :: i, j
      integer, PARAMETER :: MAXDIMS = 10
      integer(kind=4), dimension(MAXDIMS) :: start, count, vdims
      integer(kind=4)                     :: ivarid, ntp, nvdim, nvs, &
                                             ndsize
      character(len=31) ::  dummy


!-------------------------------------------------------------------
!    determine if a netcdf input data file exists. if so, read the
!    number of data records in the file.
!---------------------------------------------------------------------
      if (file_exist ( 'INPUT/id1o3.nc') ) then
        ncid = ncopn ('INPUT/id1o3.nc', 0, rcode)
        call ncinq (ncid, ndims, nvars, ngatts, recdim, rcode)
        do i=1,ndims
          call ncdinq (ncid, i, dimnam(i), dimsiz(i), rcode)
          if (dimnam(i) == 'lev') then
            kmax_file = dimsiz(i)
          endif
        end do

!-------------------------------------------------------------------
!    allocate space for the input data. read the data set. close the
!    file upon completion.
!---------------------------------------------------------------------
        allocate (qqo3(kmax_file) )
        ivarid = ncvid(ncid, 'ozone', rcode)
        call ncvinq (ncid, ivarid, dummy, ntp, nvdim, vdims, nvs, rcode)
        do j=1,nvdim
          call ncdinq (ncid, vdims(j), dummy, ndsize, rcode)
          start(j) = 1
          count(j) = ndsize
        end do
        call ncvgt (ncid, ivarid, start, count, qqo3, rcode)
        call ncclos (ncid, rcode)

!-------------------------------------------------------------------
!    determine if the input data input file exists in ascii format.
!    if so, read the number of data records in the file.
!---------------------------------------------------------------------
      else if (file_exist ( 'INPUT/id1o3') ) then
        iounit = open_namelist_file ('INPUT/id1o3')
        read (iounit,FMT = '(i4)') kmax_file

!-------------------------------------------------------------------
!    allocate space for the input data. read the data set. close the 
!    file upon completion.
!---------------------------------------------------------------------
         allocate (qqo3(kmax_file) )
         read (iounit,FMT = '(5e18.10)') (qqo3(k),k=1,kmax_file)
         call close_file (iounit)

!---------------------------------------------------------------------
!    if file is not present, write an error message.
!---------------------------------------------------------------------
       else
         call error_mesg ( 'ozone_mod', &
              'desired ozone input file is not present',FATAL)
       endif

!----------------------------------------------------------------------


end subroutine obtain_input_file_data 




!######################################################################
! <SUBROUTINE NAME="obtain_gfdl_zonal_ozone_data">
!  <OVERVIEW>
!   obtain_gfdl_zonal_ozone_data generates data at the appropriate time
!    from the basic fms_zonal_ozone input data set, allowing the use of
!    annual mean, fixed seasonal, or seasonally-varying ozone distrib-
!    utions.
!  </OVERVIEW>
!  <DESCRIPTION>
!   obtain_gfdl_zonal_ozone_data generates data at the appropriate time
!    from the basic fms_zonal_ozone input data set, allowing the use of
!    annual mean, fixed seasonal, or seasonally-varying ozone distrib-
!    utions.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  obtain_gfdl_zonal_ozone_data (season)
!  </TEMPLATE>
!  <IN NAME="season" TYPE="integer">
!   scalar integer between 0-5, where 1-4 uses fixed
!                      data (1=winter, 2=spring, etc.), season=0 is 
!                      annual mean ozone, and season=5 is seasonally
!                      varying ozone
!  </IN> 
! </SUBROUTINE>
!
subroutine obtain_gfdl_zonal_ozone_data (season)

!---------------------------------------------------------------------
!    obtain_gfdl_zonal_ozone_data retrieves ozone data as requested
!    from the gfdl_zonal_ozone input data set. data corresponding to
!    annual mean, fixed seasonal, or seasonally-varying ozone distrib-
!    utions may be obtained.
!---------------------------------------------------------------------

integer, intent(in) :: season

!--------------------------------------------------------------------
!  intent(in) variables:
!
!      season          scalar integer between 0-5, where 1-4 uses fixed
!                      data (1=winter, 2=spring, etc.), season=0 is 
!                      annual mean ozone, and season=5 is seasonally
!                      varying ozone
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!  local variables:

      real, dimension (10,41)             ::  ro31, ro32
      real, dimension (19,41)             ::  duo3n
      real, dimension (19,81,4)           ::  data4
      real, dimension (82)                ::  ph3
      real, dimension (10,25)             ::  o3hi
      real, dimension (10,16)             :: o3lo1, o3lo2, o3lo3, o3lo4

      real                      ::  pref = 101325. 
      character(len=48)         ::  err_string 
      integer                   ::  iounit   
      integer                   ::  j, k, kk, n  

!-----------------------------------------------------------------------
!  local variables:
! 
!     ro31, ro32       ozone values for the proper time, at 41 standard
!                      levels and 10 standard latitudes (index 1 = 
!                      equator, index 10= pole, 10 deg resolution)
!     duo3n            array of ozone at proper time, at 41 standard 
!                      levels, over 19 global latitudes (10 deg 
!                      resolution), index 1 = north pole, index 10=
!                      equator, index 19 = south pole)
!     data4            array of ozone at proper time, at 81 levels, over
!                      19 global latitudes (10 deg resolution). if 
!                      seasonally-varying ozone is desired, there are
!                      4 such arrays, to which harmonic interpolation
!                      will be applied.
!     ph3              sigma levels at which zonal ozone data set data
!                      exists
!     o3hi             array containing ozone data at 25 high layers in
!                      which mixing ratios are invariant with season
!     o3lo1            array containing ozone data at 16 lower layers
!                      valid for nh spring, latitudinal indices from
!                      equator to pole
!     o3lo2            array containing ozone data at 16 lower layers
!                      valid for nh fall, latitudinal indices from
!                      equator to pole
!     o3lo3            array containing ozone data at 16 lower layers
!                      valid for nh winter, latitudinal indices from
!                      equator to pole
!     o3lo4            array containing ozone data at 16 lower layers
!                      valid for nh summer, latitudinal indices from
!                      equator to pole
!     pref             assumed surface pressure value used to convert 
!                      ph3 from sigma to pressure
!     err_string       part of error message if generated
!     iounit           unit number used to read input data file
!     j,k,kk,n         do-loop indices
!     
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure that the input argument is valid.
!---------------------------------------------------------------------
      if (season < 0 .or. season > 5) then
        write (err_string,9001) season
 9001   format ('invalid value of season=',i10)
        call error_mesg ('ozone_mod', err_string, FATAL)
      endif

!---------------------------------------------------------------------
!    save input argument as a module variable.
!---------------------------------------------------------------------
      iseason = season

!---------------------------------------------------------------------
!    determine if the zonal ozone input data file exists. if so, 
!    open the file and read the data set.  close the file upon 
!    completion. if it is not present, write an error message.
!---------------------------------------------------------------------
      if (file_exist ( 'INPUT/zonal_ozone_data.nc')) then
        if(mpp_pe() == mpp_root_pe()) &
             call error_mesg('ozone_mod','Reading netCDF input data: zonal_ozone_data.nc',NOTE)
        call read_data('INPUT/zonal_ozone_data.nc', 'ph3', ph3, no_domain=.true.)
        call read_data('INPUT/zonal_ozone_data.nc', 'o3hi', o3hi, no_domain=.true.)
        call read_data('INPUT/zonal_ozone_data.nc', 'o3lo1', o3lo1, no_domain=.true.)
        call read_data('INPUT/zonal_ozone_data.nc', 'o3lo2', o3lo2, no_domain=.true.)
        call read_data('INPUT/zonal_ozone_data.nc', 'o3lo3', o3lo3, no_domain=.true.)
        call read_data('INPUT/zonal_ozone_data.nc', 'o3lo4', o3lo4, no_domain=.true.)
      else if (file_exist ( 'INPUT/zonal_ozone_data') ) then
        iounit = open_restart_file ('INPUT/zonal_ozone_data', action='read')
        if(mpp_pe() == mpp_root_pe()) &
             call error_mesg('ozone_mod','Reading native input data: zonal_ozone_data',NOTE)
        read (iounit) ph3
        read (iounit)    
        read (iounit) o3hi
        read (iounit) o3lo1
        read (iounit) o3lo2
        read (iounit) o3lo3
        read (iounit) o3lo4
        call close_file (iounit)
      else
        call error_mesg ( 'ozone_mod', &
                'zonal_ozone_data data file is not present',FATAL)
      endif

!---------------------------------------------------------------------
!    define standard pressure interfaces (ph).
!---------------------------------------------------------------------
      ph(:) = ph3(:)*pref

!-----------------------------------------------------------------------
!    define the seasonally-invariant elements of arrays ro31, ro32 from
!    the values in o3hi.
!---------------------------------------------------------------------
      do k=1,25
         ro31(:,k) = o3hi(:,k)
         ro32(:,k) = o3hi(:,k)
      end do

!---------------------------------------------------------------------
!    define the ozone values at the lower levels to be seasonally
!    varying. northern hemisphere seasons are used to define the
!    indices, with n = 1 being winter, going to n = 4 being fall.
!--------------------------------------------------------------------
      do n=1,4

!---------------------------------------------------------------------
!    for nh spring or fall, obtain the o3lo1 and o3lo2 data (ro31 and 
!    ro32). 
!----------------------------------------------------------------------
        if (n == 2 .or. n == 4) then
          do k=26,41
            ro31(:,k) = o3lo1(:,k-25)
            ro32(:,k) = o3lo2(:,k-25)
          end do
        endif

!---------------------------------------------------------------------
!    for nh winter or summer, obtain the o3lo3 and o3lo4 data (ro31 and
!    ro32). 
!----------------------------------------------------------------------
        if (n == 1 .or. n == 3) then
          do k=26,41
            ro31(:,k) = o3lo3(:,k-25)
            ro32(:,k) = o3lo4(:,k-25)
          end do
        endif

!---------------------------------------------------------------------
!    define ozone values for both hemispheres -- indices 1->9 = nh,
!    index 10 = equator, indices 11-19 = sh. for nh spring (n=2)
!    and nh winter (n=1), nh values are contained in ro31, in
!    reverse latitudinal order. sh values are contained in ro32, going
!    from equator to south pole.
!----------------------------------------------------------------------
        if (n == 2 .or. n == 1) then
          do k=1,41
            do j=1,10
              duo3n(j  ,k) = ro31(11-j,k)
              duo3n(j+9,k) = ro32(j   ,k)
            end do
            duo3n(10 ,k) = 0.50*(ro31(1,k) + ro32(1,k))
          end do

!---------------------------------------------------------------------
!    for nh summer (n=3) and nh fall (n=4), nh values are 
!    contained in ro32, in reverse latitudinal order. sh values are 
!    contained in ro31, going from equator to south pole.
!---------------------------------------------------------------------
        else if(n == 4 .or. n == 3) then
          do k=1,41
            do j=1,10
              duo3n(j  ,k) = ro32(11-j,k)
              duo3n(j+9,k) = ro31(j   ,k)
            end do
            duo3n(10 ,k) = 0.50*(ro31(1,k) + ro32(1,k))
          end do
        endif

!-----------------------------------------------------------------------
!    vertical interp between original data using bessels half-point 
!    interpolation formula.
!-----------------------------------------------------------------------
        do kk=4,78,2
          k = kk/2
          o3data(:,kk,n) = 0.50*(duo3n(:,k) + duo3n(:,k+1)) -  &
                           (duo3n(:,k+2) - duo3n(:,k+1) -   &
                            duo3n(:,k) + duo3n(:,k-1))/16.
        end do
        o3data(:, 2,n) = 0.50*(duo3n(:,2) + duo3n(:,1))
        o3data(:,80,n) = 0.50*(duo3n(:,41) + duo3n(:,40))

!---------------------------------------------------------------------
!    put intermediate (unchanged) data into new array.                
!---------------------------------------------------------------------
        do kk=1,81,2
          k = (kk + 1)/2
          o3data(:,kk,n) = duo3n(:,k)
        end do
      end do  ! n loop

!-----------------------------------------------------------------------
!    prepare seasonal interpolation.
!-----------------------------------------------------------------------
      if (iseason == 5) then
        data4(:,:,1) = 0.25*(o3data(:,:,1) + o3data(:,:,2)  &
                           + o3data(:,:,3) + o3data(:,:,4))
        data4(:,:,2) = 0.50*(o3data(:,:,2) - o3data(:,:,4))
        data4(:,:,3) = 0.50*(o3data(:,:,1) - o3data(:,:,3))
        data4(:,:,4) = 0.25*(o3data(:,:,1) - o3data(:,:,2)  &
                           + o3data(:,:,3) - o3data(:,:,4))
        o3data(:,:,1) = data4(:,:,1)
        o3data(:,:,2) = data4(:,:,2)
        o3data(:,:,3) = data4(:,:,3)
        o3data(:,:,4) = data4(:,:,4)
      endif

!-----------------------------------------------------------------------
!    prepare annual mean data. store it into o3data with index 1. reset
!    the o3data index to be 1 so that this overwritten field will be
!    retrieved.
!-----------------------------------------------------------------------
      if (iseason == 0) then
        data4(:,:,1) = 0.25*(o3data(:,:,1) + o3data(:,:,2)  &
                           + o3data(:,:,3) + o3data(:,:,4))
        o3data(:,:,1) = data4(:,:,1)
        iseason = 1
      endif

!---------------------------------------------------------------------



end subroutine obtain_gfdl_zonal_ozone_data




!######################################################################
! <SUBROUTINE NAME="obtain_clim_zonal_ozone_data">
!  <OVERVIEW>
!   obtain_clim_zonal_ozone_data provides the necessary information 
!    to interpolator_mod so that the appropriate clim_ozone data may
!    be obtained later on when needed.
!  </OVERVIEW>
!  <DESCRIPTION>
!   obtain_clim_zonal_ozone_data provides the necessary information 
!    to interpolator_mod so that the appropriate clim_ozone data may
!    be obtained later on when needed.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  obtain_clim_zonal_ozone_data (lonb, latb) 
!  </TEMPLATE>
!  <IN NAME="lonb, latb" TYPE="real">
!       lonb      2d array of model longitudes at cell corners [radians]
!       latb      2d array of model latitudes at cell corners [radians]
!  </IN> 
! </SUBROUTINE>
!
subroutine obtain_clim_zonal_ozone_data (lonb, latb)

!----------------------------------------------------------------------
!    obtain_clim_zonal_ozone_data calls interpolator_init to supply
!    the necessary information to interpolator_mod to allow the appro-
!    priate clim_zonal_ozone data to be obtained later when needed.
!---------------------------------------------------------------------

real, dimension(:,:), intent(in) :: lonb, latb

!---------------------------------------------------------------------
!  intent(in) variables:
!
!       lonb      2d array of model longitudes at cell corners [radians]
!       latb      2d array of model latitudes at cell corners [radians]
!
!-----------------------------------------------------------------

!---------------------------------------------------------------------
!    call interpolator_init to initialize an interp_type variable
!    O3_interp which will be used to retrieve interpolated ozone
!    data when requested.
!---------------------------------------------------------------------
        call interpolator_init (O3_interp, filename, lonb, &
                                latb, data_out_of_bounds=(/CONSTANT/), &
                                data_names = data_name, &
                                vert_interp=(/INTERP_WEIGHTED_P/) )


!----------------------------------------------------------------------


end subroutine obtain_clim_zonal_ozone_data



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    INTERFACE GFDL_ZONAL_OZONE
!
!
! call gfdl_zonal_ozone (Rad_time, lat, phaf, ozone)
!
!  separate routines exist within this interface for 3d and 2d
!  array input and output:
!
!  real, dimension(:,:),    intent(in)  :: lat
!  real, dimension(:,:,:),  intent(in)  :: phalf
!  real, dimension(:,:,:),  intent(out) :: ozone
! OR
!  real, dimension(:),    intent(in)    :: lat
!  real, dimension(:,:),  intent(in)    :: phalf
!  real, dimension(:,:),  intent(out)   :: ozone
!
!--------------------------------------------------------------------
!
!  intent(in) variables:
!
!      Time         current model time [ time_type (days, seconds) ] 
!      lat          latitude of model points  [ radians ]
!      phalf        pressure at model layer interfaces [ Pa ]
!
!  intent(out) variables:
!
!      ozone        ozone mass mixing ratio at model levels [ g / g ]
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#######################################################################
! <SUBROUTINE NAME="geto3_3d">
!  <OVERVIEW>
!   geto3_3d retrieves an (i,j,k) array of ozone mass mixing ratio 
!    (g / g ) valid at the specified time to be returned to the 
!    calling routine.
!  </OVERVIEW>
!  <DESCRIPTION>
!   geto3_3d retrieves an (i,j,k) array of ozone mass mixing ratio 
!    (g / g ) valid at the specified time to be returned to the 
!    calling routine.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call geto3_3d (Time, lat, phalf, ozone)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current model time [ time_type (days, seconds) ]
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   latitude of model points  [ radians ]
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!   pressure at model layer interfaces [ kg / (m s^2) ]
!  </IN>
!  <OUT NAME="ozone" TYPE="real">
!   ozone mass mixing ratio at model levels [ g / g ]
!  </OUT>  
! </SUBROUTINE>
!
subroutine geto3_3d (Time, lat, phalf, ozone)

!---------------------------------------------------------------------
!    geto3_3d retrieves an (i,j,k) array of ozone mass mixing ratio 
!    [ g / g ] valid at the specified time to be returned to the 
!    calling routine.
!---------------------------------------------------------------------

type(time_type),         intent(in)  :: Time
real, dimension(:,:),    intent(in)  :: lat
real, dimension(:,:,:),  intent(in)  :: phalf
real, dimension(:,:,:),  intent(out) :: ozone

!---------------------------------------------------------------------
!  local variables:
!
!      rlag         time lag of  valid time of seasonal ozone data from 
!                   start of calendar year [ years ]
!      profile      ozone profile in model grid column
!      dp           pressure difference between data layer interfaces
!      dp1, dp2, dp3, dp4          
!                   pressure differences used to assign data set layer
!                   ozone to the proper model layer
!      o3col        total ozone in a model pressure layer
!      rang         angular position of specified time from start of
!                   ozone year
!      rsin1        argument for harmonic interpolation
!      rcos1        argument for harmonic interpolation
!      rcos2        argument for harmonic interpolation
!      phd          model latitude, guaranteed to be between -90 and +90
!                   degrees
!      th           relative latitudinal distance of model grid point
!                   from nearest lower data set index, normalized by
!                   data set resolution 
!      fyear        fraction of the year which has passed at the 
!                   specified time
!      j1           nearest lower latitude index in data set to the
!                   model latitude
!      j2           j1 + 1; data from index j1 and j2 will be inter-
!                   polated to the model grid point
!
!------------------------------------------------------------------
      real                :: rlag
      real, dimension(81) :: profile, dp, dp1, dp2, dp3, dp4, o3col
      real                :: rang, rsin1, rcos1, rcos2, phd, th, fyear
      integer             :: j1,j2

      integer             :: i,j,k,l  ! various indices

!--------------------------------------------------------------------
!    when seasonally-varying ozone is desired, perform a harmonic time 
!    interpolation to obtain values at the specified time.
!--------------------------------------------------------------------
      if (iseason == 5) then
        if (do_mcm_o3_clim) then
          rlag = 12.6875/365.
        else
          rlag = 1./24.
        endif
        fyear = fraction_of_year (time)
        if (fyear /= current_fyear) then
          rang = 4.0*acos(0.0)*(fyear-rlag)
          rsin1 = sin(rang)
          rcos1 = cos(rang)
          rcos2 = cos(2.0*rang)
          rstd(:,:) = o3data(:,:,1) + rsin1*o3data(:,:,2) +  &
                      rcos1*o3data(:,:,3) + rcos2*o3data(:,:,4)
          current_fyear = fyear
        endif
!---------------------------------------------------------------------
!    otherwise, no interpolation is needed, use the specified seasonal 
!    data. if annual mean value has been specified, that data will be
!    at iseason = 1.
!---------------------------------------------------------------------
      else
        rstd(:,:) = o3data(:,:,iseason)
      endif

!---------------------------------------------------------------------
!    define the pressure increments of the standard data levels.
!---------------------------------------------------------------------
      do l=1,81
         dp (l) = ph(l+1) - ph(l)
      end do

!---------------------------------------------------------------------
!    perform horizontal interpolation into the data set. profile is
!    the vertical ozone data at the grid point.
!---------------------------------------------------------------------
      do j=1,size(lat,2)
        do i=1,size(lat,1)
          phd = max(min(lat(i,j)*radian, 90.), -90.)
          j1 = 10.000 - phd*0.10
          j1 = max(min(j1, 18), 1)
          j2 = j1 + 1
          th = (10-j1) - phd*0.10
          profile(:) = rstd(j1,:) + th*(rstd(j2,:) - rstd(j1,:))

!---------------------------------------------------------------------
!    now interpolate in the vertical to produce values at model
!    levels. calculate layer-mean ozone mixing ratio from data set for 
!    each model layer.
!---------------------------------------------------------------------
          do k=1,size(ozone,3)

!---------------------------------------------------------------------
!    calculate sums over data set layers to get model layer 
!    ozone. the mcm ozone data is obtained in a somewhat
!    different manner.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    mcm algorithm.
!--------------------------------------------------------------------
            if (do_mcm_o3_clim) then
              ozone(i,j,k) = 0.0
              do l=1,81
                if ((ph(l+1) >= phalf(i,j,k)) .and.   &
                    (ph(l) <= phalf(i,j,k+1))) then
                  if ((ph(l+1) < phalf(i,j,k+1)) .and.    &
                      (ph(l) < phalf(i,j,k)))   then
                    ozone(i,j,k) = ozone(i,j,k) + profile(l)*   &
                                   (ph(l+1) - phalf(i,j,k))
                  endif
                  if ((ph(l+1) < phalf(i,j,k+1)) .and.    &
                      (ph(l) >= phalf(i,j,k)))   then  
                    ozone(i,j,k) = ozone(i,j,k) + profile(l)*    &
                                   (ph(l+1) - ph(l))
                  endif
                  if ((ph(l+1) > phalf(i,j,k+1)) .and.    &
                      (ph(l) > phalf(i,j,k)))  then 
                    ozone(i,j,k) = ozone(i,j,k) + profile(l)*   &
                                   (phalf(i,j,k+1) - ph(l))
                  endif
                endif
              end do

!---------------------------------------------------------------------
!    fms algorithm.
!---------------------------------------------------------------------
            else 
              do l=1,81
                dp1(l) = ph(l+1) - phalf(i,j,k)
                dp2(l) = phalf(i,j,k+1) - ph(l)
                dp3(l) = ph(l+1) - phalf(i,j,k+1)
                dp4(l) = ph(l) - phalf(i,j,k)
              end do
              where (dp1(:) < 0.0) dp1(:)=0.0
              where (dp2(:) < 0.0) dp2(:)=0.0
              do l=1,81
                o3col(l) = 0.0
                if ( dp3(l) < 0.0 ) then
                  if ( dp4(l) < 0.0 ) then
                    o3col(l) = profile(l)*dp1(l)
                  else
                    o3col(l) = profile(l)*dp(l)
                  endif
                else
                  if ( dp4(l) < 0.0 ) then
                    o3col(l) = profile(l)*    &
                               (phalf(i,j,k+1) - phalf(i,j,k))
                  else
                    o3col(l) = profile(l)*dp2(l)
                  endif
                endif
              end do
              ozone(i,j,k) = sum(o3col(:))
            endif ! do_mcm_o3_clim if block

!---------------------------------------------------------------------
!    normalize by the model pressure depth to produce a mass 
!    mixing ratio.
!---------------------------------------------------------------------
            ozone(i,j,k) = ozone(i,j,k)/(phalf(i,j,k+1)-phalf(i,j,k))

!---------------------------------------------------------------------
!    code to cover case when surface pressure is greater than pref.
!---------------------------------------------------------------------
            if (.not.do_mcm_o3_clim .and. ph(82) < phalf(i,j,k+1)) then
              ozone(i,j,k) = profile(81)
            endif

!----------------------------------------------------------------------
!    code to cover case when model resolution is so fine that no value
!    of ph(l) in the ozone data array falls betwen phalf(k+1) and
!    phalf(k).   procedure is to simply grab the nearest value from
!    rdata (or profile in the fms code).
!----------------------------------------------------------------------
            if (do_mcm_o3_clim) then
              if (ozone(i,j,k) <= 0.0) then
                do l=1,81
                  if (ph(l) < phalf(i,j,k) .and.     &
                      ph(l+1) > phalf(i,j,k+1) ) then
                    ozone(i,j,k) = profile(l)
                  endif
                end do
              endif
            endif 
          end do ! k loop
        end do   ! i loop
      end do     ! j loop

!---------------------------------------------------------------------
!    convert units from micrograms/gram to kg/kg.
!---------------------------------------------------------------------
      ozone(:,:,:) = ozone(:,:,:)*1.e-6

!-----------------------------------------------------------------------



end subroutine geto3_3d




!#######################################################################
! <SUBROUTINE NAME="geto3_2d">
!  <OVERVIEW>
!   geto3_2d retrieves an (i,k) array of ozone mass mixing ratio 
!    (g / g ) valid at the specified time to be returned to the 
!    calling routine.
!  </OVERVIEW>
!  <DESCRIPTION>
!   geto3_2d retrieves an (i,k) array of ozone mass mixing ratio 
!    (g / g ) valid at the specified time to be returned to the 
!    calling routine.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  geto3_2d(Time, lat, phalf, ozone)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current model time [ time_type (days, seconds) ]
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   latitude of model points  [ radians ]
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!   pressure at model layer interfaces [ kg / (m s^2) ]
!  </IN>
!  <OUT NAME="ozone" TYPE="real">
!   ozone mass mixing ratio at model levels [ g / g ]
!  </OUT>  
! </SUBROUTINE>
!
subroutine geto3_2d (Time, lat, phalf, ozone)

!---------------------------------------------------------------------
!    geto3_2d retrieves an (i,k) array of ozone mass mixing ratio 
!    [ g / g ] valid at the specified time to be returned to the 
!    calling routine.
!---------------------------------------------------------------------

type(time_type),       intent(in)  :: Time
real, dimension(:),    intent(in)  :: lat
real, dimension(:,:),  intent(in)  :: phalf
real, dimension(:,:),  intent(out) :: ozone

!---------------------------------------------------------------------
!  local variables:
!
!      lat3         2d equivalent of lat
!      phalf3       3d equivalent of phalf
!      ozone3       3d equivalent of ozone
!
!--------------------------------------------------------------------

      real,dimension (size(lat,1),1)                  :: lat3
      real,dimension (size(phalf,1),1, size(phalf,2)) :: phalf3
      real,dimension (size(ozone,1),1, size(ozone,2)) :: ozone3

!---------------------------------------------------------------------
!    add an extra dummy dimension to the input variables.
!---------------------------------------------------------------------
      lat3(:,1)     = lat(:)
      phalf3(:,1,:) = phalf(:,:)

!---------------------------------------------------------------------
!    call the 3d interface of this procedure.
!---------------------------------------------------------------------
      call geto3_3d (time, lat3, phalf3, ozone3)

!---------------------------------------------------------------------
!    remove the extra dummy dimension from the output variables.
!---------------------------------------------------------------------
      ozone(:,:) = ozone3(:,1,:)

!--------------------------------------------------------------------


end subroutine geto3_2d


 
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                END INTERFACE GFDL_ZONAL_OZONE
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!#######################################################################
! <SUBROUTINE NAME="get_clim_ozone">
!  <OVERVIEW>
!   get_clim_ozone retrieves the clim_ozone field at the desired place 
!    and time from the o3.climatology.nc file by accessing 
!    interpolator_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   get_clim_ozone retrieves the clim_ozone field at the desired place 
!    and time from the o3.climatology.nc file by accessing 
!    interpolator_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  get_clim_ozone (is, js, model_time, p_half, model_data)
!  </TEMPLATE>
!  <IN NAME="model_time" TYPE="time_type">
!   time at which the climatologically-determined,
!                   time-varying ozone field should apply
!  </IN>
!  <IN NAME="p_half" TYPE="real">
!   pressure at model layer interfaces [ kg / (m s^2) ]
!  </IN>
!  <OUT NAME="model_data" TYPE="real">
!   output field containing ozone field at desired time
!  </OUT>  
!  <IN NAME="is, js" TYPE="integer">
!   OPTIONAL: starting subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
! </SUBROUTINE>
!
subroutine get_clim_ozone (is, js, model_time, p_half, model_data)

!--------------------------------------------------------------------
!    get_clim_ozone retrieves the clim_ozone field for the requested
!    points at the desired time from the clim ozone data file by
!    accessing interpolator_mod.
!---------------------------------------------------------------------

integer,                intent(in)      :: is,js
type(time_type),        intent(in)      :: model_time
real, dimension(:,:,:), intent(in)      :: p_half
real, dimension(:,:,:), intent(out)     :: model_data

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,js        starting subdomain i,j indices of data in 
!                   the physics_window being integrated
!      model_time   time at which the climatologically-determined,
!                   time-varying ozone field should apply
!                   [ time_type (days, seconds) ] 
!      p_half       pressure at model interface levels
!                   [ Pa ]
!
!   intent(out) variables:
!
!      model_data   output field containing ozone field at desired time
!                   [ g / g ]
!
!
!----------------------------------------------------------------------
!
!   local variables
 
      real, dimension(1,1, size(p_half,3)-1) :: ozone_data
      real, dimension(1,1, size(p_half,3)) :: p_half_col
      integer         :: i, j

!--------------------------------------------------------------------
!    if 'calculate_column' is being used, obtain the ozone values for
!    each column, one at a time, using the pressure profile for that
!    column. this allows each column to see the same ozone fields,
!    but distributed appropriately for its pressure structure.
!--------------------------------------------------------------------
     if (trim(ozone_data_source) == 'calculate_column') then
       do j=1, size(p_half,2)
         do i=1, size(p_half,1)
           p_half_col(1,1,:) = p_half(i,j,:)
           call interpolator (O3_interp, Ozone_column_time,  &
                              p_half_col, ozone_data, &
!                             trim(data_name(1)), is, js)
                              trim(data_name(1)), 1, 1  )
           model_data(i,j,:) = ozone_data(1,1,:)
         end do
       end do
     else

!--------------------------------------------------------------------
!    call interpolator to obtain data at the specified grid points and 
!    specified time.
!--------------------------------------------------------------------
      
      call interpolator (O3_interp, Ozone_time, p_half, model_data,  &
                         trim(data_name(1)), is, js)
     endif 

!----------------------------------------------------------------------


end subroutine get_clim_ozone



!#####################################################################



                       end module ozone_mod





                         module radiation_diag_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that provides a diagnostic output file of radiation-
!    related variables in user-specified atmospheric columns for the
!    sea_esf_rad radiation package.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!  shared modules:

use mpp_mod,            only: input_nml_file
use fms_mod,            only: open_namelist_file, fms_init, &
                              mpp_pe, mpp_root_pe, stdlog, &
                              file_exist, write_version_number, &
                              check_nml_error, error_mesg, &
                              FATAL, close_file, &
                              open_file     
use constants_mod,      only: constants_init, radcon_mks, radian

!  shared radiation package modules:

use rad_utilities_mod,  only: Lw_control,  Sw_control,&
                              rad_utilities_init, radiative_gases_type,&
                              astronomy_type, atmos_input_type, &
                              surface_type, cldrad_properties_type, &
                              cld_specification_type,  &
                              cld_space_properties_type, &
                              lw_diagnostics_type, lw_table_type, &
                              sw_output_type, lw_output_type, &
                              Rad_control

!--------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    radiation_diag_mod provides a diagnostic output file of radiation-
!    related variables in user-specified atmospheric columns for the
!    sea_esf_rad radiation package.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: radiation_diag.F90,v 17.0.4.1 2010/08/30 20:33:33 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!------    interfaces   ------

public    &
         radiation_diag_init,  &
         radiation_diag_driver,   &
         radiation_diag_end


private   &
         radiag


!---------------------------------------------------------------------
!---------- namelist  -----

integer, parameter                 :: MAX_PTS = 20
integer, dimension (MAX_PTS)       :: iradprt_gl=0, jradprt_gl=0
real, dimension(MAX_PTS)           :: latradprt=999., lonradprt=999.
integer                            :: num_pts_ij = 0
integer                            :: num_pts_latlon = 0


namelist / radiation_diag_nml /  &
                                  iradprt_gl, jradprt_gl, &
                                  num_pts_ij, num_pts_latlon,       &
                                  latradprt, lonradprt

!----------------------------------------------------------------------
!---  public data ---


!----------------------------------------------------------------------
!---  private data ---

!----------------------------------------------------------------------
!    bandlo and bandhi are the lower and upper frequencies defining 
!    each of the nblw longwave radiation bands in the longwave spectrum
!    (0 - 3000 cm-1).
!----------------------------------------------------------------------
real,    dimension(:), allocatable  :: bandlo, bandhi

!----------------------------------------------------------------------
!    bdlocm and bdhicm are the lower and upper frequencies defining 
!    each of the nbly frequency bands used in the exact cool-to-space
!    calculation.
! --------------------------------------------------------------------
real,    dimension(:), allocatable  :: bdlocm, bdhicm

!---------------------------------------------------------------------
!    iband is frequency band index to be used in combined band 
!    calculations. 
!---------------------------------------------------------------------
integer, dimension(:), allocatable  :: iband

!---------------------------------------------------------------------
!    deglon1 and deglat1 are the longitude and latitude of the columns
!    at which diagnostics will be calculated (degrees).
!---------------------------------------------------------------------
real,    dimension(:), allocatable  :: deglon1, deglat1

!---------------------------------------------------------------------
!    iradprt and jradprt are the processor-based i and j coordinates 
!    of the desired diagnostics columns.
!---------------------------------------------------------------------
integer, dimension(:), allocatable  :: jradprt, iradprt

!---------------------------------------------------------------------
!    do_raddg is an array of logicals indicating which latitude rows
!    belonging to the processor contain diagnostics columns.
!---------------------------------------------------------------------
logical, dimension(:), allocatable  :: do_raddg


integer     :: nbly              ! number of frequency bands for exact 
                                 ! cool-to-space calculation
integer     :: n_continuum_bands ! number of bands in the h2o continuum
integer     :: radiag_unit       ! i/o unit to which output file is 
                                 ! written
integer     :: num_pts           !  total number of columns in which
                                 !  diagnostics are desired
logical     :: module_is_initialized = .false.        
                                 ! module initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------





                       contains


 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
!                    PUBLIC SUBROUTINES
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#####################################################################
! <SUBROUTINE NAME="radiation_diag_init">
!  <OVERVIEW> 
!   Constructor of the radiation_diag_mod module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Constructor of the radiation_diag_mod module
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_diag_init (latb, lonb, Lw_tables)
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes at cell corners [radians]
!  </IN>
!  <IN NAME="Lw_tables" TYPE="lw_table_type">
!    lw_tables_type variable containing various longwave
!    table specifiers needed by radiation_diag_mod.
!  </IN>
! </SUBROUTINE>
!
subroutine radiation_diag_init (latb, lonb, Lw_tables)

!---------------------------------------------------------------------
!    radiation_diag_init is the constructor for radiation_diag_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:,:), intent(in)  ::  latb, lonb         
type(lw_table_type),  intent(in)  ::  Lw_tables
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  intent(in) variables:
!
!       latb      2d array of model latitudes at cell corners [radians]
!       lonb      2d array of model longitudes at cell corners [radians]
!       Lw_tables lw_tables_type variable containing various longwave
!                 table specifiers needed by radiation_diag_mod.
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables

      integer     :: unit, ierr, io, logunit
      integer     :: nn, j, i, nblw
      real        :: dellat, dellon

!--------------------------------------------------------------------
!  local variables
!
!     unit
!
!-------------------------------------------------------------------

!--------------------------------------------------------------------
!    if routine has already been executed, return.
!--------------------------------------------------------------------
      if (module_is_initialized)  return
 
!-------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!-------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init

!-----------------------------------------------------------------------
!    read namelist.              
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=radiation_diag_nml, iostat=io)
      ierr = check_nml_error(io,'radiation_diag_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=radiation_diag_nml, iostat=io, end=10) 
        ierr = check_nml_error(io,'radiation_diag_nml')
        end do                   
10      call close_file (unit)   
      endif                      
#endif
                                  
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                         write (logunit, nml=radiation_diag_nml)

!---------------------------------------------------------------------
!    allocate and initialize a flag array which indicates the latitudes
!    containing columns where radiation diagnostics are desired.
!---------------------------------------------------------------------
      allocate (do_raddg (size(latb,2)-1) )
      do_raddg(:) = .false.

!-------------------------------------------------------------------
!    define the total number of points at which diagnostics are desired.
!    points may be specified either by lat-lon pairs or by global index
!    pairs. 
!-------------------------------------------------------------------
      num_pts = num_pts_latlon + num_pts_ij

!-------------------------------------------------------------------
!    continue on only if diagnostics are desired in at least one column.
!-------------------------------------------------------------------
      if (num_pts > 0) then

!-------------------------------------------------------------------
!    if more points are desired than space has been reserved for, print 
!    a message.
!-------------------------------------------------------------------
        if (num_pts > MAX_PTS) then
          call error_mesg ( 'radiation_diag_mod', &
         'must reset MAX_PTS or reduce number of diagnostics points', &
                                                             FATAL)
        endif

!-------------------------------------------------------------------
!    allocate space for arrays which will contain the lat and lon and
!    processor-local i and j indices.
!-------------------------------------------------------------------
        allocate ( deglon1 (num_pts))
        allocate ( deglat1 (num_pts))
        allocate ( jradprt (num_pts))
        allocate ( iradprt (num_pts))

!---------------------------------------------------------------------
!    if any points for diagnostics are specified by (i,j) global 
!    indices, determine their lat-lon coordinates. assumption is made 
!    that the deltas of latitude and longitude are uniform over 
!    the globe.
!---------------------------------------------------------------------
        do nn=1,num_pts_ij
          dellat = latb(1,2) - latb(1,1)
          dellon = lonb(2,1) - lonb(1,1)
          latradprt(nn + num_pts_latlon) =     &
                      (-0.5*acos(-1.0) + (jradprt_gl(nn) - 0.5)*  &
                                           dellat) * radian
          lonradprt(nn + num_pts_latlon) =                & 
                       (iradprt_gl(nn) - 0.5)*dellon*radian
        end do

!--------------------------------------------------------------------
!    determine if the lat/lon values are within the global grid,
!    latitude between -90 and 90 degrees and longitude between 0 and
!    360 degrees.
!--------------------------------------------------------------------
        do nn=1,num_pts
          jradprt(nn) = 0
          iradprt(nn) = 0
          deglat1(nn) = 0.0
          deglon1(nn) = 0.0
          if (latradprt(nn) .ge. -90. .and. &
              latradprt(nn) .le.  90.) then
          else
            call error_mesg ('radiation_diag_mod', &
                ' invalid latitude for radiation diagnostics ', FATAL)
          endif

          if (lonradprt(nn) .ge. 0. .and. &
              lonradprt(nn) .le. 360.) then
          else
            call error_mesg ('radiation_diag_mod', &
                ' invalid longitude for radiation diagnostics ', FATAL)
          endif

!--------------------------------------------------------------------
!    determine if the diagnostics column is within the current 
!    processor's domain. if so, set a logical flag indicating the
!    presence of a diagnostic column on the particular row, define the 
!    i and j processor-coordinates and the latitude and longitude of 
!    the diagnostics column.
!--------------------------------------------------------------------
          do j=1,size(latb,2) - 1
            if (latradprt(nn) .ge. latb(1,j)*radian .and.  &
                latradprt(nn) .lt. latb(1,j+1)*radian) then
              do i=1,size(lonb,1) - 1
                if (lonradprt(nn) .ge. lonb(i,1)*radian   &
                                  .and.&
                    lonradprt(nn) .lt. lonb(i+1,1)*radian)  &
                                   then
                  do_raddg(j) = .true.
                  jradprt(nn) = j
                  iradprt(nn) = i
                  deglon1(nn) = 0.5*(lonb(i,1) + lonb(i+1,1))*  &
                                radian
                  deglat1(nn) = 0.5*(latb(1,j) + latb(1,j+1))*   &
                                radian
                  exit
                endif
              end do
              exit
            endif
          end do
        end do

!----------------------------------------------------------------------
!    open a unit for the radiation diagnostics output.
!---------------------------------------------------------------------
        radiag_unit = open_file ('radiation_diag.out', action='write', &
                                 threading='multi', form='formatted')

!----------------------------------------------------------------------
!    save the input fields from the lw_tables_type variable that will
!    be used by this module.
!----------------------------------------------------------------------
        nbly              = size(Lw_tables%bdlocm(:))
        nblw              = size(Lw_tables%bandlo(:))
        n_continuum_bands = size(Lw_tables%iband(:))

        allocate ( bdlocm (nbly) )
        allocate ( bdhicm (nbly) )
        allocate ( iband  (n_continuum_bands) )
        allocate ( bandlo (nblw) )
        allocate ( bandhi (nblw) )

        bdlocm(:) = Lw_tables%bdlocm(:)
        bdhicm(:) = Lw_tables%bdhicm(:)
        iband (:) = Lw_tables%iband(:)
        bandlo(:) = Lw_tables%bandlo(:)
        bandhi(:) = Lw_tables%bandhi(:)

      endif     ! (num_pts > 0)

!---------------------------------------------------------------------
!    set flag indicating successful initialization of module.
!---------------------------------------------------------------------
      module_is_initialized = .true.



end subroutine radiation_diag_init





!####################################################################
! <SUBROUTINE NAME="radiation_diag_driver">
!  <OVERVIEW>
!   Subroutine to  determine if a diagnostics column is present
!    in the current physics window, and, if so, calls radiag to 
!    obtain the desired variables in that column and output them to
!    a data file.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to  determine if a diagnostics column is present
!    in the current physics window, and, if so, calls radiag to 
!    obtain the desired variables in that column and output them to
!    a data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_diag_driver (is, ie, js, je, Atmos_input, Surface, Astro, &
!                                  Rad_gases, Cldrad_props,   &
!                                  Cld_spec, Sw_output,   &
!                                  Lw_output, Lw_diagnostics,   &
!                                  Cldspace_rad)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!  </IN>
!  <IN NAME="Surface" TYPE="Surface">
!   Surface boundary condition to radiation package
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!   astronomy_type variable containing the astronomical
!     input fields needed by the radiation package
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_prperties_type">
!   cldrad_prperties_type variable containing the cloud radiative
!   property input fields needed by the radiation package
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cld_specification_type variable containing 
!                   cloud information relevant to the radiation package
!  </IN>
!  <IN NAME="Sw_output" TYPE="sw_output_type">
!   sw_output_type variable containing shortwave 
!                   radiation output data 
!  </IN>
!  <IN NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                   radiation output data
!  </IN>
!  <IN NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!  </IN>
!  <IN NAME="Cldspace_rad" TYPE="cld_space_properties_type">
!   cld_space_properties_type variable containing infor-
!                   mation on cloud properties seen by the radiation 
!                   package in cloud-space coordinates
!  </IN>
! </SUBROUTINE>
!
subroutine radiation_diag_driver (is, ie, js, je, Atmos_input,  &
                                  Surface, Astro, Rad_gases,   &
                                  Cldrad_props, Cld_spec,  &
                                  Sw_output, Lw_output, Lw_diagnostics,&
                                  Cldspace_rad)

!---------------------------------------------------------------------
!    radiation_diag_driver determines if a diagnostics column is present
!    in the current physics window, and, if so, calls radiag to 
!    obtain the desired variables in that column and output them to
!    a data file.
!----------------------------------------------------------------------

integer,                         intent(in) :: is, ie, js, je
type(atmos_input_type),          intent(in) :: Atmos_input
type(surface_type),              intent(in) :: Surface
type(astronomy_type),            intent(in) :: Astro
type(radiative_gases_type),      intent(in) :: Rad_gases
type(cldrad_properties_type),    intent(in) :: Cldrad_props
type(cld_specification_type),    intent(in) :: Cld_spec       
type(sw_output_type), dimension(:), intent(in) :: Sw_output
type(lw_output_type), dimension(:), intent(in) :: Lw_output
type(lw_diagnostics_type),       intent(in) :: Lw_diagnostics
type(cld_space_properties_type), intent(in) :: Cldspace_rad

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Atmos_input  atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!      Surface      surface_type variable containing surface variables
!                   needed by the radiation package
!      Astro        astronomy_type variable containing the astronomical
!                   input fields needed by the radiation package
!      Rad_gases    radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!      Cldrad_props cldrad_properties_type variable containing the 
!                   cloud radiative property input fields needed by the 
!                   radiation package
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!      Sw_output    sw_output_type variable containing shortwave 
!                   radiation output data 
!      Lw_output    lw_output_type variable containing longwave 
!                   radiation output data 
!      Lw_diagnostics
!                   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!      Cldspace_rad cld_space_properties_type variable containing infor-
!                   mation on cloud properties seen by the radiation 
!                   package in cloud-space coordinates
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables

      integer    :: j   ! do-loop index

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('radiation_diag_mod',   &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    if this physics window includes a point at which diagnostics are 
!    to be calculated, call radiag to compute and write out the desired 
!    column data to a data file.
!---------------------------------------------------------------------
      do j=js,je
        if (do_raddg(j)) then
          call radiag (is, ie, js, je, j, Atmos_input, Surface, Astro, &
                       Rad_gases, Cldrad_props, Cld_spec, Sw_output, &
                       Lw_output, Lw_diagnostics, Cldspace_rad)
        endif
      end do

!--------------------------------------------------------------------


end subroutine radiation_diag_driver



!###################################################################
! <SUBROUTINE NAME="radiation_diag_end">
!  <OVERVIEW>
!   radiation_diag_end is the destructor for radiation_diag_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   radiation_diag_end is the destructor for radiation_diag_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiation_diag_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine radiation_diag_end

!--------------------------------------------------------------------
!    radiation_diag_end is the destructor for radiation_diag_mod.
!--------------------------------------------------------------------
      deallocate ( do_raddg )

      if (num_pts > 0 ) then
!--------------------------------------------------------------------
!    close the radiation_diag.out file.
!--------------------------------------------------------------------
        call close_file (radiag_unit)

!--------------------------------------------------------------------
!    deallocate module arrays.
!--------------------------------------------------------------------
        deallocate ( deglon1, deglat1, jradprt, iradprt,  &
                     bdlocm, bdhicm, iband, bandlo, bandhi )   
      endif

!--------------------------------------------------------------------
      module_is_initialized = .false.    

!---------------------------------------------------------------------


end subroutine radiation_diag_end


 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
!                     PRIVATE SUBROUTINES
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!#####################################################################
! <SUBROUTINE NAME="radiag">
!  <OVERVIEW>
!   radiag calculates and outputs radiation diagnostics in user-
!    specified columns.
!  </OVERVIEW>
!  <DESCRIPTION>
!   radiag calculates and outputs radiation diagnostics in user-
!    specified columns.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiag (is, ie, js, je, jrow, Atmos_input, Surface, Astro, &
!                   Rad_gases, Cldrad_props, Cld_spec, Sw_output, Lw_output,  &
!                   Lw_diagnostics, Cldspace_rad)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="jrow" TYPE="integer">
!   the current physics-window j index, which contains 
!                   a radiation diagnostics column
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!  </IN>
!  <IN NAME="Surface" TYPE="Surface">
!   Surface boundary condition to radiation package
!  </IN>
!  <IN NAME="Astro" TYPE="astronomy_type">
!   astronomy_type variable containing the astronomical
!     input fields needed by the radiation package
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!  </IN>
!  <IN NAME="Cldrad_props" TYPE="cldrad_prperties_type">
!   cldrad_prperties_type variable containing the cloud radiative
!   property input fields needed by the radiation package
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cld_specification_type variable containing 
!                   cloud information relevant to the radiation package
!  </IN>
!  <IN NAME="Sw_output" TYPE="sw_output_type">
!   sw_output_type variable containing shortwave 
!                   radiation output data 
!  </IN>
!  <IN NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                   radiation output data
!  </IN>
!  <IN NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!  </IN>
!  <IN NAME="Cldspace_rad" TYPE="cld_space_properties_type">
!   cld_space_properties_type variable containing infor-
!                   mation on cloud properties seen by the radiation 
!                   package in cloud-space coordinates
!  </IN>
! </SUBROUTINE>
!
subroutine radiag (is, ie, js, je, jrow, Atmos_input, Surface, Astro, &
                   Rad_gases, Cldrad_props, Cld_spec, Sw_output,  &
                   Lw_output, Lw_diagnostics, Cldspace_rad)

!--------------------------------------------------------------------
!    radiag calculates and outputs radiation diagnostics in user-
!    specified columns.
!--------------------------------------------------------------------

integer,                         intent(in) :: is, ie, js, je, jrow
type(atmos_input_type),          intent(in) :: Atmos_input
type(surface_type),              intent(in) :: Surface
type(astronomy_type),            intent(in) :: Astro
type(radiative_gases_type),      intent(in) :: Rad_gases
type(cldrad_properties_type),    intent(in) :: Cldrad_props
type(cld_specification_type),    intent(in) :: Cld_spec       
type(sw_output_type), dimension(:), intent(in) :: Sw_output
type(lw_output_type), dimension(:), intent(in) :: Lw_output
type(lw_diagnostics_type),       intent(in) :: Lw_diagnostics
type(cld_space_properties_type), intent(in) :: Cldspace_rad

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      jrow         the current physics-window j index, which contains 
!                   a radiation diagnostics column
!      Atmos_input  atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!      Surface      surface_type variable containing surface variables
!                   needed by the radiation package
!      Astro        astronomy_type variable containing the astronomical
!                   input fields needed by the radiation package
!      Rad_gases    radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!      Cldrad_props cldrad_properties_type variable containing the 
!                   cloud radiative property input fields needed by the 
!                   radiation package
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!      Sw_output    sw_output_type variable containing shortwave 
!                   radiation output data 
!      Lw_output    lw_output_type variable containing longwave 
!                   radiation output data 
!      Lw_diagnostics
!                   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!      Cldspace_rad cld_space_properties_type variable containing infor-
!                   mation on cloud properties seen by the radiation 
!                   package in cloud-space coordinates
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      type(lw_output_type)   :: Lw_output_ad
      type(sw_output_type)   :: Sw_output_ad

!---------------------------------------------------------------------
!    these variables are dimensioned by the number of layers in the 
!    grid:
!
!     cts        approximate cool-to-space heating rates for 160-560
!                and 800-990, 1070-1200 cm-1 ranges. (h2o bands)
!                [ degrees K /day ]
!     ctsco2     approximate cool-to-space heating rates for 560-800
!                cm-1 range. (15 micron co2 band)
!                [ degrees K /day ]
!     ctso3      approximate cool-to-space heating rates for 990-1070
!                cm-1 range.  (9.6 micron o3 band)
!                [ degrees K /day ]
!     ctst       approximate cool-to-space heating rates for 160-1200
!                cm-1 range (sum of above 3 variables).
!                [ degrees K /day ]
!     hlwsw      total radiation heating rates.
!                [ degrees K /day ]
!     hlwswcf    total radiation heating rates in the absence of clouds.
!                [ degrees K /day ]
!     convert    factor to convert flux difference (cgs units) to 
!                heating rate in degrees/day.
!                [ (degrees K * sec**3) / ( grams * day) ]
!     cmxolw     amount of maximally overlapped longwave cloud.
!                [ dimensionless ]
!     crndlw     amount of randomly overlapped longwave cloud.
!                [ dimensionless ]
!     camtsw     shortwave cloud amount. 
!                [ dimensionless ]
!     htem       emissivity heating rate, summed over bands 0 - 160,
!                560 - 2200 cm-1.
!                [ degrees K /day ]
!     htem1      emissivity heating rate for 0-160, 1200-2200 cm-1 band,
!                when ch4, n2o are not active,  emissivity heating rate 
!                for 0-160, 1400-2200 cm-1 band when ch4, n2o are 
!                active.
!                [ degrees K /day ]
!     htem2      emissivity heating rate for 560-800 cm-1 band.
!                [ degrees K /day ]
!     htem3      emissivity heating rate for 800-900 cm-1 band
!                [ degrees K /day ]
!     htem4      emissivity heating rate for 900-990 cm-1 band
!                [ degrees K /day ]
!     htem5      emissivity heating rate for 990-1070 cm-1 band.
!                [ degrees K /day ]
!     htem6      emissivity heating rate for 1070-1200 cm-1 band
!                [ degrees K /day ]
!     htem7t     emissivity heating rate over 1200-1400 cm-1 band
!                [ degrees K /day ]
!
!---------------------------------------------------------------------
      real, dimension (size(Atmos_input%press,3) - 1 ) ::   &
                                           cts, ctsco2, ctso3, ctst, &
                                           hlwsw, hlwswcf, convert, &
                                           cmxolw, crndlw, camtsw, &
                                           htem, htem1, htem2, htem3, &
                                           htem4, htem5, htem6, htem7t


!---------------------------------------------------------------------
!    these variables are dimensioned by the number of flux levels
!    (number of layers + 1):
!
!     flx1       net emissivity flux for 0-160, 1200-2200 cm-1 band 
!                when ch4, n2o not active, net emissivity flux for 
!                0-160, 1400-2200 cm-1 band when ch4, n2o are active.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx2       flux for 560-800 cm-1 band (as one band).
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx3       flux for 800-900 cm-1 band.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx4       flux for 900-990 cm-1 band.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx5       flux for 990-1070 cm-1 band.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx6       flux for 1070-1200 cm-1 band.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx1cf     same as flx1, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx2cf     same as flx2, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx3cf     same as flx3, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx4cf     same as flx4, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx5cf     same as flx5, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx6cf     same as flx6, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     press      pressure at data levels of model.
!                [ pascals ]
!     pflux      pressure at flux levels of model.
!                [ pascals ]
!     flwsw      sum of net lw and sw fluxes.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flxem      sum of emissivity fluxes over bands 0 - 160,
!                560 - 2200 cm-1.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flxemch4n2o  
!                sum of emissivity fluxes over the nbtrge bands in the 
!                1200 - 1400 cm-1 band.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flwswcf    sum of net lw and sw fluxes in the absence of clouds.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!
!----------------------------------------------------------------------
      real, dimension (size(Atmos_input%press,3)   ) ::   &
                                         flx1, flx2, flx3, flx4, flx5, &
                                         flx6, flx1cf, flx2cf, flx3cf, &
                                         flx4cf, flx5cf, flx6cf,    &
                                         press, pflux, flwsw, flxem, &
                                         flxemch4n2o, flwswcf      


!---------------------------------------------------------------------
!    these variables are dimensioned by the number of flux levels  
!    and the number of bands in the 1200 - 1400 cm-1 range when ch4 
!    and n2o are radiatively active gases.
!     flx7       when ch4, n2o are active, flux for 1200-1400 cm-1 
!                band (nbtrge bands).
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!     flx7cf     same as flx7, but for cloud-free conditions.
!                [ ergs / (cm**2  sec), or gram / sec**3 ]
!
!---------------------------------------------------------------------
      real, dimension (size(Atmos_input%press,3),        &
                       size (Lw_diagnostics%flx1e1f,3) ) :: flx7, flx7cf


!---------------------------------------------------------------------
!    this variable is dimensioned by the number of model layers 
!    and the number of bands in the 1200 - 1400 cm-1 range when ch4 
!    and n2o are radiatively active gases.
!     htem7      emissivity heating rate for each of the nbtrge bands
!                in the 1200-1400 cm-1 band
!                [ degrees K /day ]
!
!---------------------------------------------------------------------
      real, dimension (size(Atmos_input%press,3)-1,    &
                       size (Lw_diagnostics%flx1e1f,3))  :: htem7 


!---------------------------------------------------------------------
!    this variable is dimensioned by the number of model layers 
!    and the number of frequency bands used in the exact cool-to-space 
!    calculation.
!     exctsn     exact cool-to-space heating rates for each band.
!                [ degrees K /day ]
!---------------------------------------------------------------------
      real, dimension (size(Atmos_input%press,3)-1, nbly) :: exctsn


!---------------------------------------------------------------------
!    these variables are dimensioned by the number of frequency bands 
!    used in the exact cool-to-space calculation.
!     ftopn      total cool to space flux at toa for each of the nbly 
!                bands
!                [ Watts / m**2 , or kg / sec**3 ]
!     ftopac     total cool to space flux at toa summed between band 1
!                and band n
!                [ Watts / m**2 , or kg / sec**3 ]
!     vsumac     cool-to-space flux at the ground summed between bands 
!                1 and n.
!                [ Watts / m**2 , or kg / sec**3 ]
!---------------------------------------------------------------------
      real, dimension (nbly) ::  ftopac, ftopn, vsumac


!---------------------------------------------------------------------
!    various scalar variables:
!---------------------------------------------------------------------

      integer :: ncldsw    ! number of clouds at each grid point.
                           ! [ dimensionless ]
      integer :: nrndlw    ! number of randomly overlapped longwave 
                           ! clouds at each grid point.
                           ! [ dimensionless ]
      integer :: nmxolw    ! number of maximally overlapped longwave 
                           ! clouds at each grid point.
                           ! [ dimensionless ]
      real    :: fdiff     ! difference in fluxes (toa - grd)
                           ! [ Watts / m**2 , or kg / sec**3 ]
      real    ::  qsum     ! sum of cool-to-space fluxes through the 
                           ! column in a given band
                           ! [ Watts / m**2 , or kg / sec**3 ]
      real    :: ftopeft   ! flux at toa summed over nbtrge bands in 
                           ! 1200- 1400 cm-1 range.
                           ! [ Watts / m**2 , or kg / sec**3 ]
      real    :: cldext    ! exp (-cldext) = cloud sw extinction     
                           ! [ dimensionless ]
      real    :: cldssalb  ! cloud single-scattering albedo 
                           ! [ dimensionless ]
      real    :: cvisrfgd_dir  ! visible direct beam sfc albedo
                           ! [ dimensionless ]
      real    :: cvisrfgd_dif  ! visible diffuse beam sfc albedo
                           ! [ dimensionless ]
      real    :: cirrfgd_dir   ! infrared direct beam sfc albedo
                           ! [ dimensionless ]
      real    :: cirrfgd_dif   ! infrared diffuse beam sfc albedo
                           ! [ dimensionless ]
      real    :: dfsw_nir, dfsw_nir_dir, dfsw_nir_dif
!     real    :: ufsw_nir, ufsw_nir_dir, ufsw_nir_dif
      real    :: ufsw_nir,               ufsw_nir_dif
      integer :: ks=1      ! index of top level of radiation grid
      integer :: ke        ! index of lowest radiation grid level
      integer :: nlwcldb   ! number of lw cloud bands
      integer :: nbtrge    ! number of h2o bands in the 1200-1400 
                           ! cm-1 range
      integer :: iloc      ! physics window x coordinate of 
                           ! diagnostics column
      integer :: jloc      ! physics window y coordinate of 
                           ! diagnostics column

!---------------------------------------------------------------------
!  miscellaneous indices
!---------------------------------------------------------------------
      integer ::   kc, nprt, ny, nx, k, nn, m, n
      integer :: nz

      if (Rad_control%do_swaerosol_forcing) then
        Sw_output_ad = Sw_output(Rad_control%indx_swaf)
      endif
      if (Rad_control%do_lwaerosol_forcing) then
        Lw_output_ad = Lw_output(Rad_control%indx_lwaf)
      endif

!---------------------------------------------------------------------
!    define the vertical grid dimension and the number of h2o bands in 
!    the 1200 - 1400 cm-1 range.
!---------------------------------------------------------------------
      ke     = size (Atmos_input%press,3) - 1
      nbtrge = size (Lw_diagnostics%flx1e1f,3)

!--------------------------------------------------------------------
!    check for the diagnostic point(s) in the current jrow. define the 
!    physics window coordinates for those points and process the 
!    radiation diagnostic data.
!---------------------------------------------------------------------
      do nn=1,num_pts
        if (jrow == jradprt(nn)) then
          if ( (iradprt(nn) >= is) .and. (iradprt(nn) <= ie) ) then
            iloc = iradprt(nn) - is + 1
            jloc = jradprt(nn) - js + 1

!---------------------------------------------------------------------
!    write out the latitude and longitude of the model point for which
!    diagnostics will be produced.
!---------------------------------------------------------------------
            write (radiag_unit,99000) deglon1(nn), deglat1(nn)

!----------------------------------------------------------------------
!    write longwave cloud data. determine if any clouds are present
!    in the column. if there are, define the number of lw cloud bands.
!----------------------------------------------------------------------
            write (radiag_unit,9009)
            nmxolw     = Cld_spec%nmxolw(iloc, jloc)
            nrndlw     = Cld_spec%nrndlw(iloc, jloc)
            if (nmxolw > 0 .OR. nrndlw > 0) then
              write (radiag_unit,9010) nmxolw, nrndlw    
              nlwcldb = size (Cldrad_props%emmxolw,4)
!----------------------------------------------------------------------
!    write longwave cloud amounts and emissivities for each cloud band.
!    %emmxolw =  lw cloud emissivity for maximally overlapped clouds.
!                [ dimensionless ]
!    %emrndlw =  lw cloud emissivity for randomly overlapped clouds.
!                [ dimensionless ]
!----------------------------------------------------------------------
              do n=1,nlwcldb
                write (radiag_unit,9041) n
                do k = ks,ke
                  cmxolw(k) = Cld_spec%cmxolw(iloc, jloc, k)
                  crndlw(k) = Cld_spec%crndlw(iloc, jloc, k)
                  if (cmxolw(k) > 0.0 .or. crndlw(k) > 0.0)  then
                    write (radiag_unit,9030)   k,    &
                      cmxolw(k), Cldrad_props%emmxolw(iloc,jloc,k,n,1),&
                      crndlw(k), Cldrad_props%emrndlw(iloc,jloc,k,n,1)
                  endif
                end do
              end do

!--------------------------------------------------------------------
!    if no clouds are present, write a message.
!--------------------------------------------------------------------
            else
              write (radiag_unit, 9052)
            endif 

!----------------------------------------------------------------------
!    define the number of shortwave clouds.
!----------------------------------------------------------------------
            ncldsw = Cld_spec%ncldsw(iloc, jloc)
            write (radiag_unit, 9018)
            write (radiag_unit, 9019) ncldsw

!----------------------------------------------------------------------
!    if clouds exist, write shortwave cloud data.
!----------------------------------------------------------------------
            if (ncldsw /= 0) then

!---------------------------------------------------------------------
!     write out the relevant cloud-radiation variables for the lacis-
!     hansen parameterization from the data in Cldspace_rad:
!     %camtswkc   shortwave cloud amounts. their locations are specified
!                 in the ktopsw/kbtmsw indices. 
!                 [ dimensionless ]
!     %cvisrfswkc reflectivity of clouds in the visible frequency band.
!                 [ dimensionless ]
!     %cirabswkc  absorptivity of clouds in the infrared frequency band.
!                 [ dimensionless ]
!     %cirrfswkc  reflectivity of clouds in the infrared frequency band.
!                 [ dimensionless ]
!     %kbtmswkc   index of flux level pressure of cloud bottom.  
!     %ktopswkc   index of flux level pressure of cloud top. 
!---------------------------------------------------------------------
              if (Sw_control%do_lhsw) then
                write (radiag_unit,9035) 
                write (radiag_unit,9036)   (kc,    &
                         Cldspace_rad%camtswkc  (iloc, jloc,kc), &
                         Cldspace_rad%ktopswkc  (iloc,jloc,kc),   &
                         Cldspace_rad%kbtmswkc  (iloc,jloc,kc)   ,   &
                         Cldspace_rad%cvisrfswkc(iloc,jloc,kc),&
                         Cldspace_rad%cirrfswkc (iloc,jloc,kc),    &
                         Cldspace_rad%cirabswkc (iloc,jloc,kc),&
                                                      kc=ncldsw,1,-1)

!---------------------------------------------------------------------
!     write out the relevant cloud-radiation variables for the expo-
!     nential-sum-fit parameterization from the data in Cldspace_rad:
!---------------------------------------------------------------------
              else if (Sw_control%do_esfsw) then

!---------------------------------------------------------------------
!    for each shortwave cloud band, define an exinction factor,
!    single-scattering albedo and asymmetry factor and write them
!    out along with the cloud amount. use the contents of Cldrad_props,
!    Cld_spec and Atmos_input for these calculations:
!    %cldext      cloud extinction coefficient [ km -1 ]  
!    %cldsct      cloud scattering coefficient [ dimensionless ]
!    %cldsasymm   cloud asymmetry factor  [ dimensionless ]
!    %deltaz      model vertical grid interval [ meters ]
!---------------------------------------------------------------------
                do n=1,size(Cldrad_props%cldext,4)
                  write (radiag_unit,9040) n
                  do k=ks,ke
                    if (Cld_spec%camtsw(iloc,jloc,k) > 0.0) then
                      cldext = Cldrad_props%cldext(iloc,jloc,k,n,1)*   &
                               Atmos_input%clouddeltaz(iloc,jloc,k)* &
                               1.0E-03
                      if (cldext > 0.0) then           
                        cldssalb = Cldrad_props%cldsct(iloc,jloc,k,n,1)/ &
                                   Cldrad_props%cldext(iloc,jloc,k,n,1)
                      else
                        cldssalb = 0.0
                      endif
                      write (radiag_unit,9050) k,     &
                             Cld_spec%camtsw (iloc,jloc,k),   &
                             cldext, cldssalb,                      &
                             Cldrad_props%cldasymm(iloc,jloc,k,n,1)
                    endif
                  end do
                end do

!----------------------------------------------------------------------
!    if no shortwave scheme has been specified, abort.
!----------------------------------------------------------------------
              else
                call error_mesg ('radiation_diag_mod', &
                       'no shortwave clouds are activated', FATAL)
              endif

!----------------------------------------------------------------------
!    if no clouds are present in the column, write out a message. 
!----------------------------------------------------------------------
            else
              write (radiag_unit, 9053)
            endif

!--------------------------------------------------------------------
!    if microphysics has been activated, write microphysical parameters
!    at those levels where cloud is present. use variables found in 
!    Cld_spec.
!    %lwp        liquid water path                   [ kg / m**2 ]
!    %iwp        ice water path                      [ kg / m**2 ]
!    %reff_liq_micro effective cloud drop size       [ microns ]
!    %reff_ice_micro effective ice crystal size      [ microns ]
!----------------------------------------------------------------------
            if (ncldsw /= 0) then
              if (Lw_control%do_lwcldemiss .or.    &
                  Sw_control%do_esfsw) then
                write (radiag_unit, 9510)
                do k=ks,ke     
                  if (cmxolw(k) > 0.0 .or. crndlw(k) > 0.0) then
                    write (radiag_unit, 9520)   k,                &
                     1.0e03*Cld_spec%lwp      (iloc,jloc,k),   &
                     1.0e03*Cld_spec%iwp      (iloc,jloc,k),    &
                     Cld_spec%reff_liq_micro(iloc,jloc,k),  &
                     Cld_spec%reff_ice_micro(iloc,jloc,k)
                  endif
                end do
              endif
            endif

!--------------------------------------------------------------------
!    write out the visible and infrared reflectivities at the ground.
!    currently these are both given the same value (Surface%asfc), 
!    but could be different in the future.
!--------------------------------------------------------------------
!           cvisrfgd = Surface%asfc(iloc,jloc)
!           cirrfgd  = Surface%asfc(iloc,jloc)
            cvisrfgd_dir = Surface%asfc_vis_dir(iloc,jloc)
            cirrfgd_dir  = Surface%asfc_nir_dir(iloc,jloc)
            cvisrfgd_dif = Surface%asfc_vis_dif(iloc,jloc)
            cirrfgd_dif  = Surface%asfc_nir_dif(iloc,jloc)
            write (radiag_unit,9059)
!           write (radiag_unit,9060) cvisrfgd, cirrfgd 
            write (radiag_unit,9060) cvisrfgd_dir, cirrfgd_dir, &
                                     cvisrfgd_dif, cirrfgd_dif

!----------------------------------------------------------------------
!     write out the amounts of the radiative gases that the radiation
!     code sees.     
!--------------------------------------------------------------------
            write (radiag_unit,9069)
            write (radiag_unit,9070) Rad_gases%rrvco2
            write (radiag_unit,9071) Rad_gases%rrvf11
            write (radiag_unit,9072) Rad_gases%rrvf12
            write (radiag_unit,9075) Rad_gases%rrvf113
            write (radiag_unit,9076) Rad_gases%rrvf22
            write (radiag_unit,9073) Rad_gases%rrvch4
            write (radiag_unit,9074) Rad_gases%rrvn2o
 
!---------------------------------------------------------------------
!    define the shortwave parameterization being employed. define the 
!    assumption used to specify the solar zenith angle.
!---------------------------------------------------------------------
            write (radiag_unit, 9079)
            if (Sw_control%do_diurnal) then
              write (radiag_unit,99020) 
            else if (Sw_control%do_annual) then
              write (radiag_unit,99025)
            else if (Sw_control%do_daily_mean) then
              write (radiag_unit,99030)
            else ! (if all 3 are false)
              write (radiag_unit,99040)
            endif

!----------------------------------------------------------------------
!     write out the astronomical data used for this shortwave
!     calculation. use the contents in Astro:
!     %fracday         fraction of averaging period that has daylight.
!                      [ dimensionless ]
!     %cosz            mean cosine of zenith angle for all longitudes.
!                      [ dimensionless ]
!     %solar_constant  solar flux at toa at mean earth-sun radius. 
!                      [ Watts / m**2 , or kg / sec**3 ]
!     %rrsun           earth-sun distance relative to mean distance 
!                      [ dimensionless ]
!----------------------------------------------------------------------
            write (radiag_unit,9080)    &
                               Sw_control%solar_constant*Astro%rrsun, &
                               Astro%cosz(iloc,jloc), &
                               Astro%fracday(iloc,jloc)
            if (Rad_control%hires_coszen) then
              write (radiag_unit, 9081)
              do nz = 1,Rad_control%nzens
                write (radiag_unit, 9082) nz
            write (radiag_unit,9080)    &
                               Sw_control%solar_constant*Astro%rrsun, &
                               Astro%cosz_p(iloc,jloc,nz), &
                               Astro%fracday_p(iloc,jloc,nz)
              end do
             endif
        
!----------------------------------------------------------------------
!    write out atmospheric input data and longwave fluxes and heating
!    rates. Use atmospheric fields from Atmos_input and Rad_gases and 
!    longwave data from Lw_output:
!    %rh2o       mass mixing ratio of h2o at model data levels.
!                [ dimensionless ]
!    %qo3        mass mixing ratio of o3 at model data levels.
!                [ dimensionless ]
!    %temp       temperature at data levels of model.
!                [ degrees K ]
!    %heatra     lw heating rate.
!                [ degrees K / day ]
!    %flxnet     net longwave flux at model flux levels (including the 
!                ground and the top of the atmosphere).
!                [ Watts / m**2 , or kg / sec**3 ]
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    define the pressures at model and flux levels.
!----------------------------------------------------------------------
            do k=ks,ke+1
              pflux(k)  = Atmos_input%pflux(iloc,jloc,k)
              press(k)  = Atmos_input%press(iloc,jloc,k)
            end do

            write(radiag_unit,9090)
            write(radiag_unit,9100)
            write(radiag_unit,9110) (k, press (k),   &
                                     Atmos_input%temp  (iloc,jloc,k),&
                                     Atmos_input%rh2o  (iloc,jloc,k), &
                                     Rad_gases%qo3     (iloc,jloc,k),&
                                     Lw_output(1)%heatra  (iloc,jloc,k),  &
                                     Lw_output(1)%flxnet  (iloc,jloc,k), &
                                     pflux             (k), k=ks,ke)
            write(radiag_unit,9120) press (ke+1), &
                             Atmos_input%temp  (iloc,jloc,ke+1), &
                             Lw_output(1)%flxnet  (iloc,jloc,ke+1), &
                             pflux             (ke+1)

!----------------------------------------------------------------------
!    write out shortwave fluxes and heating rates. use the data in
!    Sw_output:
!    %dfsw       downward short-wave radiation
!                [ Watts / m**2 , or kg / sec**3 ]
!    %fsw        net radiation (up-down) 
!                [ Watts / m**2 , or kg / sec**3 ]
!    %ufsw       upward short-wave radiation.
!                [ Watts / m**2 , or kg / sec**3 ]
!    %hsw        sw radiation heating rates.
!                [ degrees K / day ]
!----------------------------------------------------------------------
            write (radiag_unit,9130)
            if (Sw_control%do_esfsw) then
              write (radiag_unit, 99016)
            else if (Sw_control%do_lhsw) then
              write (radiag_unit, 99018)
            endif
          do nz=1,Rad_control%nzens
                write (radiag_unit, 9082) nz
            write (radiag_unit,9140)
            write (radiag_unit,9150) (k, press(k),   &
                                     Sw_output(1)%hsw  (iloc,jloc,k,nz), &
                                     Sw_output(1)%fsw  (iloc,jloc,k,nz), &
                                     Sw_output(1)%dfsw (iloc,jloc,k,nz),    &
                                     Sw_output(1)%ufsw (iloc,jloc,k,nz),&
                                     pflux          (k), k=ks,ke)
            write (radiag_unit,6556) press(ke+1),    &
                                     Sw_output(1)%fsw  (iloc,jloc,ke+1,nz), &
                                     Sw_output(1)%dfsw (iloc,jloc,ke+1,nz), &
                                     Sw_output(1)%ufsw (iloc,jloc,ke+1,nz), &
                                     pflux          (ke+1)

            if (Sw_control%do_esfsw) then
              dfsw_nir = Sw_output(1)%dfsw(iloc,jloc,ke+1,nz) -   &
                           Sw_output(1)%dfsw_vis_sfc(iloc,jloc,nz)
              dfsw_nir_dir = Sw_output(1)%dfsw_dir_sfc(iloc,jloc,nz) -   &
                             Sw_output(1)%dfsw_vis_sfc_dir(iloc,jloc,nz)
              dfsw_nir_dif = Sw_output(1)%dfsw_dif_sfc(iloc,jloc,nz) -   &
                             Sw_output(1)%dfsw_vis_sfc_dif(iloc,jloc,nz)
              ufsw_nir = Sw_output(1)%ufsw(iloc,jloc,ke+1,nz) -   &
                         Sw_output(1)%ufsw_vis_sfc(iloc,jloc,nz)
              ufsw_nir_dif = Sw_output(1)%ufsw_dif_sfc(iloc,jloc,nz) -   &
                            Sw_output(1)%ufsw_vis_sfc_dif(iloc,jloc,nz)
              write (radiag_unit, 99026)    &
                           Sw_output(1)%dfsw_vis_sfc(iloc,jloc,nz), &
                           Sw_output(1)%ufsw_vis_sfc(iloc,jloc,nz), &
                           Sw_output(1)%dfsw_vis_sfc_dir(iloc,jloc,nz), &
                           Sw_output(1)%dfsw_vis_sfc_dif(iloc,jloc,nz), &
                           Sw_output(1)%ufsw_vis_sfc_dif(iloc,jloc,nz), &
                           dfsw_nir, ufsw_nir,  &
                           dfsw_nir_dir,               &
                           dfsw_nir_dif, ufsw_nir_dif
            endif

!----------------------------------------------------------------------
!    compute and write out total radiative heating and total fluxes 
!    (lw + sw, up-down).
!----------------------------------------------------------------------
            do k=ks,ke+1
              flwsw(k) = Lw_output(1)%flxnet (iloc,jloc,k) +    &
                         Sw_output(1)%fsw    (iloc,jloc,k,nz)
            end do
            do k=ks,ke
              hlwsw(k) = Sw_output(1)%hsw    (iloc,jloc,k,nz) +    &
                         Lw_output(1)%heatra (iloc,jloc,k)
            end do
            write (radiag_unit,9160)
            write (radiag_unit,9170)
            write (radiag_unit,9190) (k, press(k),    &
                                      hlwsw(k), flwsw(k), &
                                      pflux(k), k=ks,ke)
            write (radiag_unit,9180)  press(ke+1), flwsw(ke+1),   &
                                      pflux(ke+1)
      end do

            if (Rad_control%do_totcld_forcing) then
!----------------------------------------------------------------------
!    write out atmospheric input data and longwave fluxes and heating
!    rates for the cloud-free case. use the following data from 
!    Lw_output:
!    %heatracf   lw heating rate in the absence of clouds.
!                [ degrees K / day ]
!    %flxnetcf   net longwave flux at model flux levels (including the 
!                ground and the top of the atmosphere) in the absence of
!                cloud.
!                [ Watts / m**2 , or kg / sec**3 ]
!----------------------------------------------------------------------
              write (radiag_unit,9400)
              write (radiag_unit,9100)
              write (radiag_unit,9110) (k, press (k),  &
                                    Atmos_input%temp  (iloc,jloc,k), &
                                    Atmos_input%rh2o  (iloc,jloc,k), &
                                    Rad_gases%qo3     (iloc,jloc,k), &
                                    Lw_output(1)%heatracf(iloc,jloc,k), &
                                    Lw_output(1)%flxnetcf(iloc,jloc,k), &
                                    pflux (k), k=ks,ke)
              write (radiag_unit,9120)  press (ke+1),  &
                                    Atmos_input%temp  (iloc,jloc,ke+1),&
                                    Lw_output(1)%flxnetcf(iloc,jloc,ke+1),&
                                    pflux(ke+1)

!----------------------------------------------------------------------
!    write out shortwave fluxes and heating rates for the cloud-free 
!    case. use the data in Sw_output:
!    %dfswcf     downward short-wave radiation in absence of clouds
!                [ Watts / m**2 , or kg / sec**3 ]
!    %fswcf      net radiation (up-down) in absence of clouds   
!                [ Watts / m**2 , or kg / sec**3 ]
!    %ufswcf     upward short-wave radiation in absence of clouds
!                [ Watts / m**2 , or kg / sec**3 ]
!    %hswcf      sw radiation heating rates in the absence of clouds.
!                [ degrees K / day ]
!----------------------------------------------------------------------
              write (radiag_unit,9410)
       do nz=1,Rad_control%nzens
                write (radiag_unit, 9082) nz
            write (radiag_unit,9140)
              write (radiag_unit,9150) (k, press(k),   &
                                        Sw_output(1)%hswcf (iloc,jloc,k,nz), &
                                        Sw_output(1)%fswcf (iloc,jloc,k,nz), &
                                        Sw_output(1)%dfswcf(iloc,jloc,k,nz),&
                                        Sw_output(1)%ufswcf(iloc,jloc,k,nz), &
                                        pflux(k), k=ks,ke)
              write (radiag_unit,6556)    &
                                    press(ke+1), &
                                    Sw_output(1)%fswcf(iloc,jloc,ke+1,nz),&
                                    Sw_output(1)%dfswcf(iloc,jloc,ke+1,nz),  &
                                    Sw_output(1)%ufswcf(iloc,jloc,ke+1,nz), &
                                    pflux(ke+1)

!----------------------------------------------------------------------
!    compute and write out total radiative heating and total fluxes 
!    (lw + sw, up-down) for the cloud-free case
!----------------------------------------------------------------------
              do k=ks,ke+1
                flwswcf(k) = Lw_output(1)%flxnetcf(iloc,jloc,k) +    &
                             Sw_output(1)%fswcf   (iloc,jloc,k,nz)
              end do
              do k=ks,ke
                hlwswcf(k) = Sw_output(1)%hswcf   (iloc,jloc,k,nz) +    &
                             Lw_output(1)%heatracf(iloc,jloc,k)
              end do

              write (radiag_unit,9420)
              write (radiag_unit,9170)
              write (radiag_unit,9190) (k, press(k), hlwswcf(k),   &
                                       flwswcf(k), pflux(k), k=ks,ke)
              write (radiag_unit,9180) press(ke+1), flwswcf(ke+1),  &
                                       pflux(ke+1)
      end do
            endif

            if (Rad_control%do_lwaerosol_forcing) then
!----------------------------------------------------------------------
!    write out atmospheric input data and longwave fluxes and heating
!    rates for the aerosol forcing case. use the following data from 
!    Lw_output_ad:
!    %heatra   lw heating rate.
!                [ degrees K / day ]
!    %flxnet   net longwave flux at model flux levels (including the 
!                ground and the top of the atmosphere.
!                [ Watts / m**2 , or kg / sec**3 ]
!    %heatracf   lw heating rate in the absence of clouds.
!                [ degrees K / day ]
!    %flxnetcf   net longwave flux at model flux levels (including the 
!                ground and the top of the atmosphere) in the absence of
!                cloud.
!                [ Watts / m**2 , or kg / sec**3 ]
!----------------------------------------------------------------------
              if (Lw_control%do_lwaerosol) then
! climate includes aerosol effects, lw aerosol forcing by exclusion
                write (radiag_unit,9603)
              else
! climate includes no aerosol effects, lw aerosol forcing by inclusion
                write (radiag_unit,9601)
              endif
              write (radiag_unit,9100)
              write (radiag_unit,9110) (k, press (k),  &
                                    Atmos_input%temp  (iloc,jloc,k), &
                                    Atmos_input%rh2o  (iloc,jloc,k), &
                                    Rad_gases%qo3     (iloc,jloc,k), &
                                    Lw_output_ad%heatra(iloc,jloc,k), &
                                    Lw_output_ad%flxnet(iloc,jloc,k), &
                                    pflux (k), k=ks,ke)
              write (radiag_unit,9120)  press (ke+1),  &
                                    Atmos_input%temp  (iloc,jloc,ke+1),&
                                    Lw_output_ad%flxnet(iloc,jloc,ke+1),&
                                    pflux(ke+1)
! clear-sky results
              if (Lw_control%do_lwaerosol) then
! climate includes aerosol effects, lw aerosol forcing by exclusion
                write (radiag_unit,9604)
              else
! climate includes no aerosol effects, lw aerosol forcing by inclusion
                write (radiag_unit,9602)
              endif
              write (radiag_unit,9100)
              write (radiag_unit,9110) (k, press (k),  &
                                    Atmos_input%temp  (iloc,jloc,k), &
                                    Atmos_input%rh2o  (iloc,jloc,k), &
                                    Rad_gases%qo3     (iloc,jloc,k), &
                                    Lw_output_ad%heatracf(iloc,jloc,k), &
                                    Lw_output_ad%flxnetcf(iloc,jloc,k), &
                                    pflux (k), k=ks,ke)
              write (radiag_unit,9120)  press (ke+1),  &
                                    Atmos_input%temp  (iloc,jloc,ke+1),&
                                    Lw_output_ad%flxnetcf(iloc,jloc,ke+1),&
                                    pflux(ke+1)
            endif

            if (Rad_control%do_swaerosol_forcing) then
!----------------------------------------------------------------------
!    write out atmospheric input data and shortwave fluxes and heating
!    rates for the aerosol forcing case. use the following data from 
!    Sw_output_ad:
!    %dfsw       downward short-wave radiation
!                [ Watts / m**2 , or kg / sec**3 ]
!    %fsw        net radiation (up-down)
!                [ Watts / m**2 , or kg / sec**3 ]
!    %ufsw       upward short-wave radiation
!                [ Watts / m**2 , or kg / sec**3 ]
!    %hsw        sw radiation heating rates
!                [ degrees K / day ]
!    %dfswcf     downward short-wave radiation in absence of clouds
!                [ Watts / m**2 , or kg / sec**3 ]
!    %fswcf      net radiation (up-down) in absence of clouds   
!                [ Watts / m**2 , or kg / sec**3 ]
!    %ufswcf     upward short-wave radiation in absence of clouds
!                [ Watts / m**2 , or kg / sec**3 ]
!    %hswcf      sw radiation heating rates in the absence of clouds.
!                [ degrees K / day ]
!----------------------------------------------------------------------
              if (Sw_control%do_swaerosol) then
! climate includes aerosol effects, sw aerosol forcing by exclusion
                write (radiag_unit,9703)
              else
! climate includes no aerosol effects, sw aerosol forcing by inclusion
                write (radiag_unit,9701)
              endif
              write (radiag_unit,9140)
    do nz = 1, Rad_control%nzens
              write (radiag_unit,9150) (k, press(k),   &
                                        Sw_output_ad%hsw (iloc,jloc,k,nz), &
                                        Sw_output_ad%fsw (iloc,jloc,k,nz), &
                                        Sw_output_ad%dfsw(iloc,jloc,k,nz),&
                                        Sw_output_ad%ufsw(iloc,jloc,k,nz), &
                                        pflux(k), k=ks,ke)
              write (radiag_unit,6556)    &
                                    press(ke+1), &
                                    Sw_output_ad%fsw(iloc,jloc,ke+1,nz),&
                                    Sw_output_ad%dfsw(iloc,jloc,ke+1,nz),  &
                                    Sw_output_ad%ufsw(iloc,jloc,ke+1,nz), &
                                    pflux(ke+1)
! clear-sky results
              if (Sw_control%do_swaerosol) then
! climate includes aerosol effects, sw aerosol forcing by exclusion
                write (radiag_unit,9704)
              else
! climate includes no aerosol effects, sw aerosol forcing by inclusion
                write (radiag_unit,9702)
              endif
              write (radiag_unit,9140)
              write (radiag_unit,9150) (k, press(k),   &
                                        Sw_output_ad%hswcf (iloc,jloc,k,nz), &
                                        Sw_output_ad%fswcf (iloc,jloc,k,nz), &
                                        Sw_output_ad%dfswcf(iloc,jloc,k,nz),&
                                        Sw_output_ad%ufswcf(iloc,jloc,k,nz), &
                                        pflux(k), k=ks,ke)
              write (radiag_unit,6556)    &
                                    press(ke+1), &
                                    Sw_output_ad%fswcf(iloc,jloc,ke+1,nz),&
                                    Sw_output_ad%dfswcf(iloc,jloc,ke+1,nz),  &
                                    Sw_output_ad%ufswcf(iloc,jloc,ke+1,nz), &
                                    pflux(ke+1)
        end do
            endif

            if (Rad_control%do_lwaerosol_forcing .and.   &
                Rad_control%do_swaerosol_forcing) then
       do nz=1,Rad_control%nzens
!----------------------------------------------------------------------
!    compute and write out total radiative heating and total fluxes 
!    (lw + sw, up-down) for the total-sky and cloud-free case
!    with lw and sw aerosol forcing
!----------------------------------------------------------------------
              do k=ks,ke+1
                flwsw(k) = Lw_output_ad%flxnet(iloc,jloc,k) +    &
                             Sw_output_ad%fsw   (iloc,jloc,k,nz)
                flwswcf(k) = Lw_output_ad%flxnetcf(iloc,jloc,k) +    &
                             Sw_output_ad%fswcf   (iloc,jloc,k,nz)
              end do
              do k=ks,ke
                hlwsw(k) = Sw_output_ad%hsw   (iloc,jloc,k,nz) +    &
                             Lw_output_ad%heatra(iloc,jloc,k)
                hlwswcf(k) = Sw_output_ad%hswcf   (iloc,jloc,k,nz) +    &
                             Lw_output_ad%heatracf(iloc,jloc,k)
              end do

              write (radiag_unit,9801)
              write (radiag_unit,9170)
              write (radiag_unit,9190) (k, press(k),    &
                                        hlwsw(k), flwsw(k), &
                                        pflux(k), k=ks,ke)
              write (radiag_unit,9180)  press(ke+1), flwsw(ke+1),   &
                                        pflux(ke+1)

              write (radiag_unit,9802)
              write (radiag_unit,9170)
              write (radiag_unit,9190) (k, press(k), hlwswcf(k),   &
                                       flwswcf(k), pflux(k), k=ks,ke)
              write (radiag_unit,9180) press(ke+1), flwswcf(ke+1),  &
                                       pflux(ke+1)
     end do
            endif

!----------------------------------------------------------------------
!    define emissivity fluxes, both the standard and cloud-free case.
!    note that Lw_diagnostics%fluxn is in cgs units (ergs/(cm**2 sec).
!----------------------------------------------------------------------
            do k=ks,ke+1
              flx1(k) = Lw_diagnostics%fluxn(iloc,jloc,k,1)
              flx2(k) = Lw_diagnostics%fluxn(iloc,jloc,k,2)
              flx3(k) = Lw_diagnostics%fluxn(iloc,jloc,k,3)
              flx4(k) = Lw_diagnostics%fluxn(iloc,jloc,k,4)
              flx5(k) = Lw_diagnostics%fluxn(iloc,jloc,k,5)
              flx6(k) = Lw_diagnostics%fluxn(iloc,jloc,k,6)
              if (Rad_control%do_totcld_forcing) then
                flx1cf(k) = Lw_diagnostics%fluxncf(iloc, jloc, k,1)
                flx2cf(k) = Lw_diagnostics%fluxncf(iloc, jloc, k,2)
                flx3cf(k) = Lw_diagnostics%fluxncf(iloc, jloc, k,3)
                flx4cf(k) = Lw_diagnostics%fluxncf(iloc, jloc, k,4)
                flx5cf(k) = Lw_diagnostics%fluxncf(iloc, jloc, k,5)
                flx6cf(k) = Lw_diagnostics%fluxncf(iloc, jloc, k,6)
              endif
              if (nbtrge > 0) then
                do m=1,nbtrge
                  if (Rad_control%do_totcld_forcing) then
                    flx7cf(k,m) =     &
                             Lw_diagnostics%fluxncf(iloc, jloc, k,6+m)
                  endif
                  flx7(k,m) = Lw_diagnostics%fluxn(iloc, jloc, k,6+m)
                end do
              endif
            end do

!--------------------------------------------------------------------
!    define the factor used to convert a flux divergence in cgs units 
!    to a heating rate in units of degrees per day. the 1.0e-03 
!    converts the fluxes (in cgs) to mks units [ (ergs/cm^2/s)  X 
!    1.0e-03  ---> (J/m^2/s) ]. radcon includes the conversion to 
!    degrees/day from degrees/second.
!---------------------------------------------------------------------
            do k=ks,ke
              convert(k) = 1.0e-03*radcon_mks*    &
                           (1.0/(pflux(k+1) - pflux(k)))
            end do

!----------------------------------------------------------------------
!    compute emissivity heating rates in degrees K / day.
!----------------------------------------------------------------------
            do k=ks,ke
              htem1(k) = (flx1(k+1) - flx1(k))*convert(k)
              htem2(k) = (flx2(k+1) - flx2(k))*convert(k)
              htem3(k) = (flx3(k+1) - flx3(k))*convert(k)
              htem4(k) = (flx4(k+1) - flx4(k))*convert(k)
              htem5(k) = (flx5(k+1) - flx5(k))*convert(k)
              htem6(k) = (flx6(k+1) - flx6(k))*convert(k)
            end do
            if (nbtrge > 0) then
              do m=1,nbtrge
                do k=ks,ke
                  htem7(k,m) = (flx7(k+1,m) - flx7(k,m))* convert(k)
                end do
              end do

!--------------------------------------------------------------------
!    define the sum of the heating rates in the 1200 - 1400 cm-1 band.
!--------------------------------------------------------------------
              do k=ks,ke
                htem7t(k) = 0.0E+00
                do m=1,nbtrge
                  htem7t(k) = htem7t(k) + htem7(k,m)
                end do
              end do
            endif

!----------------------------------------------------------------------
!    define the emissivity heating rate summed over all frequencies.
!----------------------------------------------------------------------
            do k=ks,ke
              htem(k) = htem1(k) + htem2(k) + htem3(k) + htem4(k) +   &
                        htem5(k) + htem6(k)
            end do
            if (nbtrge > 0) then
              do k=ks,ke
                htem(k) = htem(k) + htem7t(k)
              enddo
            endif

!----------------------------------------------------------------------
!    write approximate emissivity heating rates.
!----------------------------------------------------------------------
            if (nbtrge == 0) then
              write (radiag_unit,9200)
              write (radiag_unit,9210) (k, press(k), htem1(k),   &
                                        htem2(k), htem3(k), htem4(k), &
                                        htem5(k), htem6(k), htem(k), &
                                        k=ks,ke)
            else
              if (nbtrge .EQ. 1) then
                write (radiag_unit,9201)
                write (radiag_unit,9211) (k, press(k), htem1(k),  &
                                         htem2(k), htem3(k), htem4(k), &
                                         htem5(k), htem6(k),  &
                                         htem7(k,1), htem(k),k=ks,ke)
              else if (nbtrge .EQ. 2) then
                write (radiag_unit,9202)
                write (radiag_unit,9212) (k, press(k), htem1(k),  &
                                         htem2(k), htem3(k), htem4(k), &
                                         htem5(k), htem6(k),   &
                                         (htem7(k,n),n=1,nbtrge),  &
                                         htem7t(k), htem(k),k=ks,ke)
              else if (nbtrge .EQ. 4) then
                write (radiag_unit,9203)
                write (radiag_unit,9213) (k, press(k), htem1(k),   &
                                         htem2(k), htem3(k), htem4(k),&
                                         htem5(k), htem6(k),   &
                                         (htem7(k,n),n=1,nbtrge),   &
                                         htem7t(k), htem(k),k=ks,ke)
              else if (nbtrge .EQ. 10) then
                write (radiag_unit,9201)
                write (radiag_unit,9211) (k, press(k), htem1(k),  &
                                         htem2(k), htem3(k), htem4(k), &
                                         htem5(k), htem6(k), &
                                         htem7t(k), &
                                         htem(k),k=ks,ke)
              else if (nbtrge .EQ. 20) then
                write (radiag_unit,9201)
                write (radiag_unit,9211) (k, press(k), htem1(k),  &
                                         htem2(k), htem3(k), htem4(k), &
                                         htem5(k), htem6(k), &
                                         htem7t(k), &
                                         htem(k),k=ks,ke)
              endif
            endif

!----------------------------------------------------------------------
!    compute and write out approximate cool-to-space heating rates 
!    for the h2o, 15 micron co2 and 9.6 micron o3 bands individually, 
!    and for their sum. 
!----------------------------------------------------------------------
            do k=ks,ke
              ctsco2(k) = Lw_diagnostics%cts_out(iloc,jloc,k,2)
              ctso3(k)  = Lw_diagnostics%cts_out(iloc,jloc,k,5)
              cts (k)   = Lw_diagnostics%cts_out(iloc,jloc,k,1)
              cts (k)   = cts(k) +      &
                          Lw_diagnostics%cts_out(iloc,jloc,k,3)
              cts (k)   = cts(k) +     &
                          Lw_diagnostics%cts_out(iloc,jloc,k,4)
              cts (k)   = cts(k) +    &
                          Lw_diagnostics%cts_out(iloc,jloc,k,6)
            end do
            do k=ks,ke
              ctst(k) = ctso3(k) + ctsco2(k) + cts(k)
            end do

            write (radiag_unit,9220)
            write (radiag_unit,9230) (k, press(k), cts(k), ctsco2(k),  &
                                     ctso3(k), ctst(k), k=ks,ke)

!----------------------------------------------------------------------
!    write out exact cool-to-space heating rates, total and for each
!    individual band.
!    Lw_diagnostics%excts      exact cool-to-space heating rates for 
!                              160-1200 cm-1 range, when using ckd2.1
!                              continuum, or 560 - 1200 cm-1 range
!                              when using Roberts continuum.
!                              [ degrees K / day ]
!----------------------------------------------------------------------
            do n=1,nbly
              do k=ks,ke
                exctsn(k,n) =  Lw_diagnostics%exctsn(iloc,jloc,k,n)
              end do
            end do
            write (radiag_unit,9240)
            write (radiag_unit,9250) (k, press(k),            &
                                     Lw_diagnostics%excts(iloc,jloc,k),&
                                     (exctsn(k,n), n=1,7) , k=ks,ke)
            write (radiag_unit,9260)
            write (radiag_unit,9250) (k, press(k),   &
                                     (exctsn(k,n), n=8,15) , k=ks,ke)
            if (nbly == 48) then
              write (radiag_unit,9261)
              write (radiag_unit,9250) (k, press(k),   &
                                       (exctsn(k,n), n=16,23) , k=ks,ke)
              write (radiag_unit,9262)
              write (radiag_unit,9250) (k, press(k),   &
                                       (exctsn(k,n), n=24,31) , k=ks,ke)
              write (radiag_unit,9263)
              write (radiag_unit,9250) (k, press(k),   &
                                       (exctsn(k,n), n=32,39) , k=ks,ke)
              write (radiag_unit,9264)
              write (radiag_unit,9250) (k, press(k),   &
                                      (exctsn(k,n), n=40,47) , k=ks,ke)
            endif

!----------------------------------------------------------------------
!    compute net flux at each level summed over all bands.
!----------------------------------------------------------------------
            do k=ks,ke+1
              flxem(k) = flx1(k) + flx2(k) + flx3(k) + flx4(k) +  &
                         flx5(k) + flx6(k)
            end do
            if (nbtrge > 0) then
              flxemch4n2o(:) = 0.0E+00
              do m=1,nbtrge
                do k=ks,ke+1 
                  flxemch4n2o(k) = flxemch4n2o(k) + flx7(k,m)
                end do
              end do
              do k=ks,ke+1
                flxem(k) = flxem(k) + flxemch4n2o(k)
              end do
            endif

!----------------------------------------------------------------------
!    compute sum of flux through atmosphere for each band by converting
!    back the heating rates. the flux at toa is the difference 
!    between the surface flux and this net flux through the atmosphere.
!    %fctsg     cool-to-space flux at the ground for each band.
!                [ Watts / m**2 , or kg / sec**3 ]
!--------------------------------------------------------------------
            do n=1,nbly-1
              qsum = 0.0E+00
              do k=ks,ke
                qsum = qsum + 1.0e-03*exctsn(k,n)/convert(k)
              end do
              ftopn(n) = Lw_diagnostics%fctsg(iloc,jloc,n) - qsum
            end do
            ftopn(nbly) = 0.0E+00

!----------------------------------------------------------------------
!    compute the accumulated sum over bands from band 1 to band n for
!    the surface and toa fluxes.
!---------------------------------------------------------------------- 
            ftopac(1) = ftopn(1)
            vsumac(1) = Lw_diagnostics%fctsg(iloc,jloc,1)
            do n=2,nbly
              ftopac(n) = ftopac(n-1) + ftopn(n)
              vsumac(n) = vsumac(n-1) +           &
                                     Lw_diagnostics%fctsg(iloc,jloc,n)
            end do

!----------------------------------------------------------------------
!    write toa and surface fluxes and the differences between them.
!    %gxcts      flux at top of atmosphere for 160-1200 cm-1 range. 
!                [ Watts / m**2 , or kg / sec**3 ]
!    %flx1e1     flux at top of atmosphere for 0-160, 1200-2200
!                cm-1 range.
!                [ Watts / m**2 , or kg / sec**3 ]
!    %flx1e1f    flux at top of atmosphere for nbtrge bands in 1200-
!                1400 cm-1 range.
!                [ Watts / m**2 , or kg / sec**3 ]
!----------------------------------------------------------------------
            fdiff = Lw_diagnostics%gxcts(iloc,jloc) +   &
                    Lw_diagnostics%flx1e1(iloc,jloc) -    &
                    Lw_output(1)%flxnet(iloc,jloc,ke+1)
            write (radiag_unit,9270)      &
                                Lw_diagnostics%gxcts(iloc,jloc), &
                                Lw_diagnostics%flx1e1(iloc,jloc), &
                                Lw_diagnostics%gxcts(iloc,jloc)+ &
                                    Lw_diagnostics%flx1e1(iloc,jloc),&
                                Lw_output(1)%flxnet(iloc,jloc,ke+1), &
                                fdiff
            if (nbtrge > 0) then
              do m=1,nbtrge
                write (radiag_unit,9271) m,    &
                                   Lw_diagnostics%flx1e1f(iloc,jloc,m)
              end do
              ftopeft   = 0.0E+00
              do m=1,nbtrge
                ftopeft   = ftopeft +    &
                                    Lw_diagnostics%flx1e1f(iloc,jloc,m)
              end do
              write (radiag_unit,9272) ftopeft
            endif

!----------------------------------------------------------------------
!    write out toa and sfc fluxes for 8 combined continuum bands between
!    160-560 cm-1 when ckd2.1 is not active, toa and sfc fluxes for 40 
!    combined continuum bands when ckd2.1 is active.
!----------------------------------------------------------------------
            write(radiag_unit,9280)
            do ny=1,nbly-8   
              nprt = 1
              do nx=1,n_continuum_bands
                if (iband(nx) .EQ. ny) then
                  if (nprt .EQ. 1) then
                    write (radiag_unit,9290) ny,   &
                          bandlo(nx+16), bandhi(nx+16), &
                          ftopn(ny), ftopac(ny),    &
                          Lw_diagnostics%fctsg(iloc,jloc,ny), vsumac(ny)
                    nprt = 0
                  else
                    write (radiag_unit,9300) bandlo(nx+16),   &
                                             bandhi(nx+16)
                  endif
                endif
              end do
            end do

!----------------------------------------------------------------------
!    write out toa and sfc fluxes for remaining bands.
!----------------------------------------------------------------------
            do ny =nbly-7, nbly
              write (radiag_unit,9290) ny,     &
                        bdlocm(ny), bdhicm(ny), ftopn(ny),ftopac(ny), &
                        Lw_diagnostics%fctsg(iloc,jloc,ny), vsumac(ny)
            end do

!----------------------------------------------------------------------
!    write out emissivity fluxes.
!----------------------------------------------------------------------
            write (radiag_unit,9310)
            if (nbtrge == 0) then
              write (radiag_unit,9320) 
              write (radiag_unit,9330) (k, flx1(k),flx2(k), flx3(k),  &
                                       flx4(k), flx5(k), flx6(k), &
                                       flxem(k),  k=ks,ke+1)
            else
              if (nbtrge .EQ. 1) then
                write (radiag_unit,9321)
                write (radiag_unit,9331) (k, flx1(k),flx2(k), &
                                         flx3(k),flx4(k), &
                                         flx5(k), flx6(k), &
                                         flxemch4n2o(k), flxem(k), &
                                         k=ks,ke+1)
              else if (nbtrge .EQ. 2) then
                write (radiag_unit,9322)
                write (radiag_unit,9332) (k, flx1(k),flx2(k), &
                                         flx3(k),flx4(k), &
                                         flx5(k), flx6(k), &
                                         (flx7(k,m   ),m=1,nbtrge), &
                                         flxemch4n2o(k), flxem(k), &
                                         k=ks,ke+1)
              else if (nbtrge .EQ. 4) then
                write (radiag_unit,9323)
                write (radiag_unit,9333) (k, flx1(k),flx2(k), &
                                         flx3(k),flx4(k), &
                                         flx5(k), flx6(k),&
                                         (flx7(k,m),m=1,nbtrge),&
                                         flxemch4n2o(k), flxem(k), &
                                         k=ks,ke+1)
              endif
            endif
          endif
        endif
      end do    ! (num_pts loop)


!----------------------------------------------------------------------
!     format statements.
!----------------------------------------------------------------------

99000  format (/////' GRID POINT LOCATION (DEGREES) : LON = ', &
               F10.5, 2X, ' LAT = ', F10.5)
99016  format (/, ' THIS RUN USED THE EXPONENTIAL-SUM-FIT SW &
               &PARAMETERIZATION.',//)
99018  format (/, ' THIS RUN USED THE LACIS-HANSEN SW &
               &PARAMETERIZATION.',//)
99020  format (' SHORTWAVE CALCULATIONS BASED ON &
               &DIURNALLY VARYING ZENITH ANGLES')
99025  format (' SHORTWAVE CALCULATIONS BASED ON  &
               &ANNUAL MEAN ZENITH ANGLES')
99026  format ( '      VISIBLE SFC SW FLUXES:', //, &
                ' total downward   = ', F12.6,   &
                '   total upward   = ', F12.6,   /, &
                ' downward direct  = ', F12.6,  &
                '   upward direct  =   NONEXISTENT', /,    &
                ' downward diffuse = ', F12.6,  &
                '   upward diffuse = ', F12.6,  //,   &
                '       NIR SFC SW FLUXES:', //, &
                ' total downward   = ', F12.6, &
                '   total upward   = ', F12.6,  /,  &
                ' downward direct  = ', F12.6, &
                '   upward direct  =   NONEXISTENT', /,    &
                ' downward diffuse = ', F12.6, &
                '   upward diffuse = ', F12.6)
99030  format (' SHORTWAVE CALCULATIONS BASED ON &
               &DIURNALLY AVERAGED ZENITH ANGLES')
99040  format (' SHORTWAVE CALCULATIONS BASED ON &
               &SPECIFIED ASTRONOMICAL INPUTS')
9009   format (///, ' ************ LONGWAVE CLOUD DATA ***************')
9010   format (/,' NO. MAX OVERLAP CLOUDS= ',I2,    &
                  ' NO. RANDOM OVERLAP CLOUDS= ',I2)
9018   format (///, ' ************ SHORTWAVE CLOUD DATA **************')
9019   format (/,' NO. SW CLOUDS = ',I2)        
9030   format (I4,7X,4F14.6)
9035   format (22X,' SW CLOUD DATA '/,&
               ' CLD. NO',8X,'CLD. AMT.',2X, &
               'CLD TOP INDEX',2X,'CLD BOT INDEX',2X,'VIS. REFL',3X, &
               ' IR REFL',4X,' IR ABS.')  
9036   format (I5,7X,F12.6,I8,I15,6X,3F12.6)
9040   format (12X,      &
               ' SW CLOUD DATA, BAND = ',i2, &
               /,' MDL. LVL',7X, 'CLD. AMT.',7X,'EXT OP DEP.',3X, &
               ' SSALB.',2X,' ASYMM. PAR.')
9041   format (27X,' LW CLOUD DATA, BAND = ',i2,/,' MDL. LVL',4X, &
               'MXO CLD AMT.',2X,'MXO CLD EMIS',2X, &
               'RNDO CLD AMT.',2X,'RNDO CLD EMIS')
9050   format (I5,7X,F12.6,6X,3F12.6)
9052   format (/, ' THIS LW RADIATION CALL SEES NO CLOUDS.')
9053   format (/, ' THIS SW RADIATION CALL SEES NO CLOUDS.')
9059   format (//, ' *********** SURFACE ALBEDO DATA ****************')
!9060   format (/,10X,'VIS. SFC. ALBEDO=',F12.6,' IR SFC. ALBEDO=',  &
!              F12.6)
9060   format (/,'ALBEDO, VIS. SFC. DIRECT =',F10.6,' ALBEDO, NIR SFC. DIRECT =',  &
               F10.6,   &
              /,'ALBEDO, VIS. SFC. DIFFUSE=',F10.6,' ALBEDO, NIR SFC. DIFFUSE=',  &
               F10.6)
9069   format (//, ' *********** RADIATIVE GAS DATA ****************')
9070   format (/,' CO2 VOL.  MIXING RATIO = ', 6PF10.2,' ppmv')
9071   format (' F11 VOL.  MIXING RATIO = ',12PF10.2,' pptv')
9072   format (' F12 VOL.  MIXING RATIO = ',12PF10.2,' pptv')
9075   format (' F113 VOL. MIXING RATIO = ',12PF10.2,' pptv')
9076   format (' F22 VOL.  MIXING RATIO = ',12PF10.2,' pptv')
9073   format (' CH4 VOL.  MIXING RATIO = ', 9PF10.2,' ppbv')
9074   format (' N2O VOL.  MIXING RATIO = ', 9PF10.2,' ppbv')
9079   format (//, ' *********** ASTRONOMICAL DATA ****************')
9080   format (/,' INCOMING SOLAR FLUX =',F12.6,' W/M**2',/,  &
               ' COS(AZIMUTH)=',F12.6,10X,' FRACTION SUNUP=',F12.6)
9081   format (//, 'FOR THE HIRES ZENITH ANGLES OF THIS STEP:')
9082   format (/, ' ZENITH ANGLE NUMBER :', I4)
9090   format (//,'********* LW HEATING RATES AND FLUXES ***********',/)
9100   format ('  LVL',' PRESSURE   ',4X,' TEMP.     ','H2O MMR',5X,&
               'O3 MMR',7X,'HEAT RATE',2X,'NET FLUX',3X,'FLUX PRESS.')
9110   format (I4,E13.6,F12.4,2E12.5,2F12.6,E13.6)
9120   format (4X,E13.6,F12.4,36X,F12.6,E13.6)
9130   format (/,'*************** SW HEATING RATES AND FLUXES ******',/)
9140   format ('  LVL',' PRESSURE    ',3X,'HEAT RATE',2X,'NET FLUX',  &
               4X,'DN FLUX',6X,'UP FLUX',3X,'FLUX PRESS.') 
6556   format (4X,E13.6,12X,3F12.6,E13.6)
9150   format (I4,E13.6,4F12.6,E13.6)
9160   format (/,'*********** COMBINED HEATING RATES AND FLUXES ****',/)
9170   format ('  LVL',' PRESSURE    ',4X,'HEAT RATE',2X,'NET FLUX',  &
               3X,'FLUX PRESS.') 
9180   format (4X,E13.6,12X,F12.6,E13.6)
9190   format (I4,E13.6,2F12.6,E13.6)
9200   format (/,'****   APPROXIMATE HEATING RATES  (Q(APPROX)) ****'/ &
               '  LVL',' PRESSURE   ',5X,'  0-160,1200-2200 ', &
               '    560-800       ','     800-900      ',   &
               '      900-990     ', '    990-1070      ',  &
               '     1070-1200    ', '       TOTAL')
9210   format (I4,E13.6,7F18.6)
9201   format (/,'****   APPROXIMATE HEATING RATES  (Q(APPROX)) ****'/ &
               '  LVL',' PRESSURE   ',5X,'  0-160,1400-2200 ',  &
               '    560-800       ','     800-900      ',  &
               '      900-990     ', '    990-1070      ',   &
               '     1070-1200    ','     1200-1400    ', &
               '       TOTAL')
9211   format (I4,E13.6,8F18.6)
9202   format (/,'****   APPROXIMATE HEATING RATES  (Q(APPROX)) ****'/ &
               '  LVL',' PRESSURE   ',5X,'  0-160,1400-2200 ',   &
               '    560-800       ','     800-900      ', &
               '      900-990     ',  '    990-1070      ',  &
               '     1070-1200    ','  1200-1300 ', &
               '  1300-1400 ','  1200-1400 ','       TOTAL')
9212   format (I4,E13.6,6F18.6,3F12.6,F18.6)
9203   format (/,'****   APPROXIMATE HEATING RATES  (Q(APPROX)) ****'/ &
               '  LVL',' PRESSURE   ',5X,'  0-160,1400-2200 ',  &
               '    560-800       ','     800-900      ',   &
               '      900-990     ', '    990-1070      ',  &
               '     1070-1200    ','  1200-1250 ',  &
               '  1250-1300 ','  1300-1350 ','  1350-1400 ', &
               '  1200-1400 ','       TOTAL')
9213   format (I4,E13.6,6F18.6,5F12.6,F18.6)
9220   format (/,'*******APPROXIMATE CTS HEATING RATES *****'/    &
               '  LVL',' PRESSURE',&
               7X,' H2O BANDS    ',' 15 UM BAND   ',  &
               ' 9.6 UM BAND  ',' TOTAL')
9230   format (I4,E13.6,4F14.6)
9240   format (/,'********EXACT CTS HEATING RATES, BY BAND *******'/   &
               '  LVL',' PRESSURE   ','    TOTAL    ',5X,'1',11X,  &
               '2',11X,'3',  11X,'4',11X,'5',11X,'6',11X,'7',/)
9250   format (I4,E13.6,8F12.6)
9260   format ('  LVL PRESSURE   ',7X,'8',11X,'9',10X,'10',10X,'11', &
               10X,'12',10X,'13',10X,'14',10X,'15')
9261   format ('  LVL PRESSURE   ',6X,'16',10X,'17',10X,'18',10X,'19',&
               10X,'20',10X,'21',10X,'22',10X,'23')
9262   format ('  LVL PRESSURE   ',6X,'24',10X,'25',10X,'26',10X,'27',&
               10X,'28',10X,'29',10X,'30',10X,'31')
9263   format ('  LVL PRESSURE   ',6X,'32',10X,'33',10X,'34',10X,'35',&
               10X,'36',10X,'37',10X,'38',10X,'39')
9264   format ('  LVL PRESSURE   ',6X,'40',10X,'41',10X,'42',10X,'43',&
               10X,'44',10X,'45',10X,'46',10X,'47')
9270   format ( 40X,'   FLUXES'/   &
               ' FLUX AT TOP,160-1200 CM-1       =',F14.6,' W/M**2'/ &
               ' FLUX AT TOP,0-160,1200-2200 CM-1=',F14.6,' W/M**2'/&
               ' FLUX AT TOP,0-2200 CM-1         =',F14.6,' W/M**2'/&
               ' NET FLUX AT GROUND,0-2200 CM-1  =',F14.6,' W/M**2'/  &
               ' NET FLUX DIFFERENCE,0-2200 CM-1 =',F14.6,' W/M**2')
9271   format ( /,  &
               ' FLUX AT TOP, BAND ',I2,' 1200-1400 CM-1 RANGE =',  &
                F14.6, ' W/M**2')
9272   format ( /,   &
               ' FLUX AT TOP, 1200-1400 CM-1 BAND  =',F14.6, &
                 ' W/M**2')
9280   format (/,'**********CTS FLUXES **********'/   &
               1X,'BAND NO',8X,'LOFREQ',9X,'HIFREQ',9X,'F(1)',  &
               11X,'ACCUM. F(1)',4X,'CTS F(GRD)',5X,'ACCUM. CTS F(GRD)')
9290   format (I11,6F15.6)
9300   format (11X,2F15.6)
9310   format (/,'********* EMISSIVITY FLUXES ***********')
9320   format (/,2x,' lvl ',2x,   &
               ' h2o emiss ',' 560-800   ',' 800-900   ',  &
               ' 900-990   ',' 990-1070  ',' 1070-1200 ','  total    ') 
9321   format (/,2x,' lvl ',2x,   &
               ' h2o emiss ',' 560-800   ',' 800-900   ',' 900-990   ',&
               ' 990-1070  ',' 1070-1200 ',' 1200-1400 ',  &
               '  total    ')
9322   format (/,2x,' lvl ',2x,  &
               ' h2o emiss ',' 560-800   ',' 800-900   ',' 900-990   ',&
               ' 990-1070  ',' 1070-1200 ',' 1200-1300 ', &
               ' 1300-1400 ',' 1200-1400 ',' total     ')
9323   format (/,2x,' lvl ',2x,   &
               ' h2o emiss ',' 560-800   ',' 800-900   ',' 900-990   ',&
               ' 990-1070  ',' 1070-1200 ',' 1200-1250 ',' 1250-1300 ',&
               ' 1300-1350 ',' 1350-1400 ',' 1200-1400 ',  &
               '  total    ')
9330   format (i5,-3p,7f11.5)
9331   format (i5,-3p,8f11.5)
9332   format (i5,-3p,10f11.5)
9333   format (i5,-3p,12f11.5)
9400   format (/,'***** CLEAR-SKY LW HEATING RATES AND FLUXES ******',/)
9410   format (/,'**** CLEAR-SKY SW HEATING RATES AND FLUXES******',/)
9420   format (/,'*** COMBINED CLEAR-SKY HEATING RATES AND FLUXES **',/)
9510   format (///, '********* CLOUD MICROPHYSICAL PARAMETERS ******', &
               /, 2x,'lyr',8x, 'liq water path', 3x,    &
               'ice water path',3x, 'eff diam water', ' eff diam ice')
9520   format (I5,7X,F14.6,3x,F14.6,3x,F14.6,3x,F14.6)
9601   format (/,'***** TOTAL-SKY LW HEATING RATES AND FLUXES (AEROSOLS INCLUDED) ******',/)
9602   format (/,'***** CLEAR-SKY LW HEATING RATES AND FLUXES (AEROSOLS INCLUDED) ******',/)
9603   format (/,'***** TOTAL-SKY LW HEATING RATES AND FLUXES (AEROSOLS EXCLUDED) ******',/)
9604   format (/,'***** CLEAR-SKY LW HEATING RATES AND FLUXES (AEROSOLS EXCLUDED) ******',/)
9701   format (/,'***** TOTAL-SKY SW HEATING RATES AND FLUXES (AEROSOLS INCLUDED) ******',/)
9702   format (/,'***** CLEAR-SKY SW HEATING RATES AND FLUXES (AEROSOLS INCLUDED) ******',/)
9703   format (/,'***** TOTAL-SKY SW HEATING RATES AND FLUXES (AEROSOLS EXCLUDED) ******',/)
9704   format (/,'***** CLEAR-SKY SW HEATING RATES AND FLUXES (AEROSOLS EXCLUDED) ******',/)
9801   format (/,'**** COMBINED HEATING RATES AND FLUXES -- AEROSOL FORCING ****',/)
9802   format (/,'*** COMBINED CLEAR-SKY HEATING RATES AND FLUXES -- AEROSOL FORCING **',/)

!--------------------------------------------------------------------


end subroutine radiag         



!##################################################################



                    end module radiation_diag_mod


                  module radiative_gases_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that defines mixing ratios of radiatively-active 
!    gases to be used in the calculation of longwave and shortwave
!    radiative fluxes and heating rates in the sea_esf_rad radiation
!    package.
! </OVERVIEW>
! <DESCRIPTION>
!  Module that defines mixing ratios of radiatively-active 
!    gases to be used in the calculation of longwave and shortwave
!    radiative fluxes and heating rates in the sea_esf_rad radiation
!    package.
! </DESCRIPTION>

!  shared modules:

use time_manager_mod,    only: time_manager_init, time_type, set_date, &
                               get_calendar_type, GREGORIAN, &
                               operator(>=), operator(-), operator(<=),&
                               operator(>),  operator (<), get_date,  &
                               set_time, operator(+), print_date,  &
                               days_in_year, get_time, length_of_year
use diag_manager_mod,    only: diag_manager_init, get_base_time
use mpp_mod,             only: input_nml_file
use fms_mod,             only: open_namelist_file, fms_init, &
                               mpp_pe, mpp_root_pe, stdlog, &
                               file_exist, write_version_number, &
                               check_nml_error, error_mesg, &
                               FATAL, NOTE, close_file, &
                               open_restart_file, read_data
use fms_io_mod,          only: get_restart_io_mode, &
                               register_restart_field, restart_file_type, &
                               save_restart, restore_state, query_initialized
use time_interp_mod,     only: time_interp_init, time_interp
use tracer_manager_mod,  only: get_tracer_index, NO_TRACER
use field_manager_mod,   only: MODEL_ATMOS

!  shared radiation package modules:

use rad_utilities_mod,   only: rad_utilities_init, Lw_control, &
                               atmos_input_type, &
                               radiative_gases_type, Rad_control

! component modules:

use ozone_mod,           only: ozone_driver, ozone_init,  &
                               ozone_time_vary, ozone_endts, ozone_end

!---------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    radiative_gases_mod defines mixing ratios of radiatively-active 
!    gases to be used in the calculation of longwave and shortwave
!    radiative fluxes and heating rates in the sea_esf_rad radiation
!    package.
!---------------------------------------------------------------------
 

!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  &
'$Id: radiative_gases.F90,v 17.0.2.1.2.1.4.2.2.1 2010/08/30 20:33:33 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

public     &
         radiative_gases_init, define_radiative_gases,  &
         radiative_gases_time_vary, radiative_gases_endts,  &
         radiative_gases_end, radiative_gases_dealloc,  &
         radiative_gases_restart

private    &
! called from radiative_gases_init:
         validate_time_varying_inputs, &
         read_restart_radiative_gases, &
         define_ch4, define_n2o, define_f11, &
         define_f12, define_f113, define_f22, &
         define_co2, read_gas_timeseries,  &

! called from define_radiative_gases:
         define_gas_amount,     &

! called from radiative_gases_end:
         write_restart_radiative_gases


!---------------------------------------------------------------------
!-------- namelist  ---------

integer          :: verbose = 0   ! verbosity levels, values run from
                                  ! 0 (least output) to 5 (most output)
integer          :: gas_printout_freq = 32*24
                                  ! frequency of outputting gas concen-
                                  ! trations [ hours ] default: 32 days

!--------------------------------------------------------------------
!    time_varying_xxx  logical flag indicating whether the vol. mixing 
!                      ratio of gas xxx varies in time
!    xxx_data_source   source of input data for initial value of gas xxx
!    xxx_floor         smallest value allowed for gas xxx vol. mixing 
!                      ratio [ no. / no. ]
!    xxx_ceiling       largest value allowed for gas xxx vol. mixing 
!                      ratio [ no. / no. ]
!    xxx_specification_type
!                      indicator as to the form of time variation of
!                      vol. mixing ratio for gas xxx; either 
!                      'base_and_trend' or 'time_series'
!    xxx_variation_type
!                      indicator as to the form of time variation of
!                      the vol. mixing ratio of gas xxx; either 'linear'
!                      or 'logarithmic'. Must be 'linear' for 
!                      'time_series'.
!      
!         The following variables only have relevance when 
!         specification_type = 'base_and_trend':
!
!    xxx_base_value    initial value of gas xxx vol. mixing ratio when
!                      xxx_data_source is 'namelist' [ no. / no. ]
!    xxx_base_time     time at which xxx_base_value is relevant spec-
!                      ified as (year, month, day, 0, 0, 0). (Can only 
!                      be specified as 00Z on the particular day).
!
!    xxx_change_rate   time rate of change of gas xxx vol. mixing ratio.
!                      [  1 +/- % per year ]
!
!--------------------------------------------------------------------

logical              :: time_varying_co2 = .false.
character(len=16)    :: co2_data_source  = '   '
real                 :: co2_base_value    = 0.0
integer,dimension(6) :: co2_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: co2_change_rate   = 0.0
real                 :: co2_floor = 0.0
real                 :: co2_ceiling = 1.0E6
character(len=16)    :: co2_specification_type = '              '
character(len=16)    :: co2_variation_type = '           '

logical              :: time_varying_ch4 = .false.
character(len=16)    :: ch4_data_source  = '   '
real                 :: ch4_base_value    = 0.0
integer,dimension(6) :: ch4_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: ch4_change_rate   = 0.0
real                 :: ch4_floor = 0.0
real                 :: ch4_ceiling = 1.0E6
character(len=16)    :: ch4_specification_type = '              '
character(len=16)    :: ch4_variation_type = '           '

logical              :: time_varying_n2o = .false.
character(len=16)    :: n2o_data_source  = '   '
real                 :: n2o_base_value    = 0.0
integer,dimension(6) :: n2o_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: n2o_change_rate   = 0.0
real                 :: n2o_floor = 0.0
real                 :: n2o_ceiling = 1.0E6
character(len=16)    :: n2o_specification_type = '              '
character(len=16)    :: n2o_variation_type = '           '

logical              :: time_varying_f11 = .false.
character(len=16)    :: f11_data_source  = '   '
real                 :: f11_base_value    = 0.0
integer,dimension(6) :: f11_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: f11_change_rate   = 0.0
real                 :: f11_floor = 0.0
real                 :: f11_ceiling = 1.0E6
character(len=16)    :: f11_specification_type = '              '
character(len=16)    :: f11_variation_type = '           '

logical              :: time_varying_f12 = .false.
character(len=16)    :: f12_data_source  = '   '
real                 :: f12_base_value    = 0.0
integer,dimension(6) :: f12_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: f12_change_rate   = 0.0
real                 :: f12_floor = 0.0
real                 :: f12_ceiling = 1.0E6
character(len=16)    :: f12_specification_type = '              '
character(len=16)    :: f12_variation_type = '           '

logical              :: time_varying_f113 = .false.
character(len=16)    :: f113_data_source  = '   '
real                 :: f113_base_value    = 0.0
integer,dimension(6) :: f113_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: f113_change_rate   = 0.0
real                 :: f113_floor = 0.0
real                 :: f113_ceiling = 1.0E6
character(len=16)    :: f113_specification_type = '              '
character(len=16)    :: f113_variation_type = '           '

logical              :: time_varying_f22 = .false.
character(len=16)    :: f22_data_source  = '   '
real                 :: f22_base_value    = 0.0
integer,dimension(6) :: f22_base_time     = (/ 0,0,0,0,0,0 /)
real                 :: f22_change_rate   = 0.0
real                 :: f22_floor = 0.0
real                 :: f22_ceiling = 1.0E6
character(len=16)    :: f22_specification_type = '              '
character(len=16)    :: f22_variation_type = '           '

integer, dimension(6) ::       &
                         co2_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in co2  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
integer, dimension(6) ::       &
                         ch4_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in ch4  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
integer, dimension(6) ::       &
                         n2o_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in n2o  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
integer, dimension(6) ::       &
                         f11_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in f11  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
integer, dimension(6) ::       &
                         f12_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in f12  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
integer, dimension(6) ::       &
                         f113_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in f113  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
integer, dimension(6) ::       &
                         f22_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
                      ! time in f22  data set corresponding to model
                      ! initial time  (yr, mo, dy, hr, mn, sc)
logical              :: time_varying_restart_bug = .false.
logical              :: use_globally_uniform_co2 = .true.
namelist /radiative_gases_nml/ verbose, &
        use_globally_uniform_co2, &
        gas_printout_freq, time_varying_restart_bug, &
        co2_dataset_entry, ch4_dataset_entry, n2o_dataset_entry,  &
        f11_dataset_entry, f12_dataset_entry, f113_dataset_entry, &
        f22_dataset_entry, &

        time_varying_co2, co2_data_source, co2_base_value,  &
        co2_base_time, co2_change_rate, co2_floor, co2_ceiling,  &
        co2_specification_type, co2_variation_type, &

                                time_varying_ch4, ch4_data_source, &
                                ch4_base_value, ch4_base_time, &
                                ch4_change_rate, ch4_floor,   &
                                ch4_ceiling, ch4_specification_type, &
                                ch4_variation_type, &

                                time_varying_n2o, n2o_data_source, &
                                n2o_base_value, n2o_base_time, &
                                n2o_change_rate, n2o_floor,   &
                                n2o_ceiling, n2o_specification_type, &
                                n2o_variation_type, &

                                time_varying_f11, f11_data_source, &
                                f11_base_value, f11_base_time, &
                                f11_change_rate, f11_floor,   &
                                f11_ceiling, f11_specification_type, &
                                f11_variation_type, &

                                time_varying_f12, f12_data_source, &
                                f12_base_value, f12_base_time, &
                                f12_change_rate, f12_floor,   &
                                f12_ceiling, f12_specification_type, &
                                f12_variation_type, &

                                time_varying_f113, f113_data_source, &
                                f113_base_value, f113_base_time, &
                                f113_change_rate, f113_floor,   &
                                f113_ceiling, f113_specification_type, &
                                f113_variation_type, &

                                time_varying_f22, f22_data_source, &
                                f22_base_value, f22_base_time, &
                                f22_change_rate, f22_floor,   &
                                f22_ceiling, f22_specification_type, &
                                f22_variation_type

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------

!--- for netcdf restart
type(restart_file_type), save :: Rad_restart
logical                       :: do_netcdf_restart= .true.
integer                       ::  vers   ! version number of restart file 
!---------------------------------------------------------------------
!    list of restart versions of radiation_driver.res readable by this 
!    module.
!---------------------------------------------------------------------
integer, dimension(3)    ::  restart_versions = (/ 1, 2, 3 /)

!--------------------------------------------------------------------
!    initial mixing ratios of the various radiative gases. if a gas 
!    is not active, its mixing ratio is set to zero.
!--------------------------------------------------------------------
real         ::  rch4, rn2o, rf11, rf12, rf113, rf22, rco2

!--------------------------------------------------------------------
!    this is the mixing ratio of gas used when the transmission 
!    functions were last calculated.
!--------------------------------------------------------------------
real         ::  co2_for_last_tf_calc
real         ::  ch4_for_last_tf_calc
real         ::  n2o_for_last_tf_calc

!RSH
!  Need these as module variables rather than components of derived type
!   since they are needed in region executed by master thread only:
real         ::  co2_for_next_tf_calc
real         ::  ch4_for_next_tf_calc
real         ::  n2o_for_next_tf_calc
real         ::  ch4_tf_offset
real         ::  n2o_tf_offset
real         ::  co2_tf_offset
!--------------------------------------------------------------------
!    these variables are .true. if transmission functions are cal-
!    culated for the referenced gas.
!--------------------------------------------------------------------
logical, parameter   :: co2_uses_tfs  = .true.
logical, parameter   :: ch4_uses_tfs  = .true.
logical, parameter   :: n2o_uses_tfs  = .true.
logical, parameter   :: f11_uses_tfs  = .false.
logical, parameter   :: f12_uses_tfs  = .false.
logical, parameter   :: f113_uses_tfs = .false.
logical, parameter   :: f22_uses_tfs  = .false.

!--------------------------------------------------------------------
!    these variables contain the mixing ratios of the radiative gases
!    at the current time. if the gases are fixed, this is the same as
!    the initial value; otherwise it will be time-varying.
!--------------------------------------------------------------------
real   :: rrvco2, rrvf11, rrvf12, rrvf113, rrvf22, rrvch4, rrvn2o 

!---------------------------------------------------------------------
!    variables to specify data for gas xxx, when xxx_specification_type
!    is 'time_series':
!
!    xxx_time_list          list of times (time_type variable) for 
!                           which values for gas xxx are specified 
!                           for 'time_series', these define the data 
!                           points, for 'base_and_trend', the single
!                           entry is the xxx_base_time  [ time_type ]
!    xxx_value              values (vol. mixing ratio) of gas xxx at
!                           times given by xxx_time_list. data may have
!                           to be converted from other units (eg, ppmv 
!                           or ppbv or pptv). [real]
!---------------------------------------------------------------------
type(time_type), dimension(:), pointer :: Co2_time_list, N2o_time_list,&
                                          Ch4_time_list, F11_time_list,&
                                          F12_time_list, F22_time_list,&
                                          F113_time_list
real,            dimension(:), pointer :: co2_value, ch4_value,  &
                                          n2o_value, f11_value,  &
                                          f12_value, f113_value, &
                                          f22_value

!---------------------------------------------------------------------
!    miscellaneous variables:
!
!    restart_present        restart file present ?
!    module_is_initialized  module is initialized ?
!    pts_processed          number of processor's columns that have 
!                           been processed on the current time step 
!    total_points           number of model columns on the processor
!    define_xxx_for_last_tf_calc
!                           the tf's that were used for gas xxx on the 
!                           last step of the previous job must be 
!                           recalculated ? this can only be true when
!                           a restart file version earlier than version
!                           3 is being read. 

!---------------------------------------------------------------------
logical      ::  restart_present =  .false.   
logical      ::  module_is_initialized =  .false. 
integer      ::  ico2
logical      ::  define_co2_for_last_tf_calc = .false.
logical      ::  define_ch4_for_last_tf_calc = .false.
logical      ::  define_n2o_for_last_tf_calc = .false.
logical      ::  printed_current_floor_msg = .false.
logical      ::  printed_current_ceiling_msg = .false.
logical      ::  printed_next_floor_msg = .false.
logical      ::  printed_next_ceiling_msg = .false.
integer      ::  print_alarm = 0
 
type(time_type) :: Model_init_time  ! initial calendar time for model  
                                    ! [ time_type ]

!-------------------------------------------------------------------
!   xxx_offset  ! difference between model initial time and gas time-
                ! series mapped to model initial time
                ! [ time_type ]
!   xxx_entry   ! time in gas timeseries which is mapped to model 
                ! initial time
                ! [ time_type ]
!   negative_offset_xxx 
                !  the model initial time is later than the gas 
                !  xxx_dataset_entry time  ?
!-------------------------------------------------------------------
type(time_type)    :: Co2_offset,  Co2_entry
type(time_type)    :: Ch4_offset,  Ch4_entry
type(time_type)    :: N2o_offset,  N2o_entry
type(time_type)    :: F11_offset,  F11_entry
type(time_type)    :: F12_offset,  F12_entry
type(time_type)    :: F113_offset,  F113_entry
type(time_type)    :: F22_offset,  F22_entry

logical    :: negative_offset_co2 = .false.
logical    :: negative_offset_ch4 = .false.
logical    :: negative_offset_n2o = .false.
logical    :: negative_offset_f11 = .false.
logical    :: negative_offset_f12 = .false.
logical    :: negative_offset_f113 = .false.
logical    :: negative_offset_f22 = .false.

logical    :: co2_tfs_needed = .true.
logical    :: ch4_tfs_needed = .true.
logical    :: n2o_tfs_needed = .true.

!---------------------------------------------------------------------
!---------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PUBLIC SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!####################################################################
! <SUBROUTINE NAME="radiative_gases_init">
!  <OVERVIEW>
!   Subroutine to initialize radiative_gases module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to initialize radiative_gases module
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiative_gases_init (pref, latb, lonb)
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!   reference prssure profiles
!  </IN>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes at cell corners [radians]
!  </IN>
! </SUBROUTINE>
!
subroutine radiative_gases_init (pref, latb, lonb)

!---------------------------------------------------------------------
!    radiative_gases_init is the constructor for radiative_gases_mod.
!---------------------------------------------------------------------

real, dimension(:,:), intent(in) :: pref
real, dimension(:,:), intent(in) :: latb, lonb

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       pref      array containing two reference pressure profiles 
!                 for use in defining transmission functions [pascals]
!       latb      2d array of model latitudes at cell corners [radians]
!       lonb      2d array of model longitudes at cell corners [radians]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer              :: unit     ! unit number for i/o operation
      integer              :: ierr     ! error code 
      integer              :: io       ! io status upon completion 
      integer              :: calendar ! calendar type used in model
      character(len=8)     :: gas_name ! name associated with current
                                       ! gas being processed
      character(len=32)    :: restart_file
      integer              :: id_restart
      integer              :: logunit  ! unit number for writing to logfile.

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call time_manager_init
      call diag_manager_init
      call time_interp_init

!-----------------------------------------------------------------------
!    read namelist.              
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=radiative_gases_nml, iostat=io)
      ierr = check_nml_error(io,'radiative_gases_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=radiative_gases_nml, iostat=io, end=10) 
        ierr = check_nml_error(io,'radiative_gases_nml')
        end do                   
10      call close_file (unit)   
      endif                      
#endif
      call get_restart_io_mode(do_netcdf_restart)

                                  
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                       write (logunit, nml=radiative_gases_nml)

!---------------------------------------------------------------------
!    force xxx_data_source to be 'input' when gas is time-varying and
!    that variation is specified via a time-series file.
!----------------------------------------------------------------------
      if (time_varying_ch4 .and.   &
          trim(ch4_specification_type) == 'time_series' .and. &
          trim (ch4_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when ch4 is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

      if (time_varying_n2o .and.   &
          trim(n2o_specification_type) == 'time_series' .and. &
          trim (n2o_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when n2o is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

      if (time_varying_co2 .and.   &
          trim(co2_specification_type) == 'time_series' .and. &
          trim (co2_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when co2 is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

      if (time_varying_f11 .and.   &
          trim(f11_specification_type) == 'time_series' .and. &
          trim (f11_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when f11 is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

      if (time_varying_f12 .and.   &
          trim(f12_specification_type) == 'time_series' .and. &
          trim (f12_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when f12 is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

      if (time_varying_f113 .and.   &
          trim(f113_specification_type) == 'time_series' .and. &
          trim (f113_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when f113 is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

      if (time_varying_f22 .and.   &
          trim(f22_specification_type) == 'time_series' .and. &
          trim (f22_data_source) /= 'input') then
        call error_mesg ('radiative_gases_mod', &
          ' when f22 is time-varying and comes from a timeseries,&
          & data source must be specified as "input" ', FATAL)  
      endif

!--------------------------------------------------------------------
!    time variation of radiative gases is not currently available if the
!    gregorian calendar is being employed. NOTE : gregorian calendar
!    not available currently in FMS; if it becomes available, then
!    code to properly handle the time variation of gases with that
!    calendar may be developed.
!--------------------------------------------------------------------
      if (time_varying_co2 .or. &
          time_varying_ch4 .or. &
          time_varying_n2o .or. &
          time_varying_f11 .or. &
          time_varying_f12 .or. &
          time_varying_f113 .or. &
          time_varying_f22 )  then
        calendar = get_calendar_type()
        if (calendar == GREGORIAN ) then 
          call error_mesg ('radiative_gases_mod', &
               'code not available to handle time-varying radiative &
                &gases with gregorian calendar', FATAL)
        endif
      endif

!---------------------------------------------------------------------
!    if present, read the radiative gases restart file. set a flag 
!    indicating the presence of the file.
!---------------------------------------------------------------------
     restart_file = 'radiative_gases.res.nc'
      if(do_netcdf_restart) then
         id_restart = register_restart_field(Rad_restart, restart_file, 'vers', vers, no_domain = .true. )
         id_restart = register_restart_field(Rad_restart, restart_file, 'rco2', rco2, no_domain = .true. )          
         id_restart = register_restart_field(Rad_restart, restart_file, 'rf11', rf11, no_domain = .true. )
         id_restart = register_restart_field(Rad_restart, restart_file, 'rf12', rf12, no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'rf113', rf113, no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'rf22', rf22, no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'rch4', rch4, no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'rn2o', rn2o, no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'co2_for_last_tf_calc', &
                                             co2_for_last_tf_calc, mandatory=.false., no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'ch4_for_last_tf_calc', &
                                             ch4_for_last_tf_calc, mandatory=.false., no_domain = .true. ) 
         id_restart = register_restart_field(Rad_restart, restart_file, 'n2o_for_last_tf_calc', &
                                             n2o_for_last_tf_calc, mandatory=.false., no_domain = .true. )     
      endif

      restart_present = .false.
      if (file_exist('INPUT/radiative_gases.res.nc')) then
         if (mpp_pe() == mpp_root_pe()) call error_mesg ('radiative_gases_mod', &
              'Reading NetCDF formatted restart file: INPUT/radiative_gases.res.nc', NOTE)
         if(.not. do_netcdf_restart) call error_mesg ('radiative_gases_mod', &
              'netcdf format restart file INPUT/radiative_gases.res.nc exist, but do_netcdf_restart is false.', FATAL)
         call restore_state(Rad_restart)
         restart_present = .true.
         if(vers >= 3) then
            if(.NOT. query_initialized(Rad_restart, id_restart) ) call error_mesg('radiative_gases_mod', &
                'vers >=3 and INPUT/radiative_gases.res.nc exist, but field n2o_for_last_tf_calc does not in that file', FATAL)
         else
            define_co2_for_last_tf_calc = .true.
            define_ch4_for_last_tf_calc = .true.
            define_n2o_for_last_tf_calc = .true.
         endif       
         vers = restart_versions(size(restart_versions(:)))     
      else
         if (file_exist ('INPUT/radiative_gases.res')) then
            if (mpp_pe() == mpp_root_pe()) call error_mesg ('radiative_gases_mod', &
                 'Reading native formatted restart file.', NOTE)
            call read_restart_radiative_gases
            restart_present = .true.
         endif
      endif

!---------------------------------------------------------------------
!    call a routine for each gas to initialize its mixing ratio
!    and set a flag indicating whether it is fixed in time or time-
!    varying.  fixed-in-time gases will be defined from the 
!    source specified in the namelist.
!---------------------------------------------------------------------
      call define_ch4 (ch4_data_source)
      call define_n2o (n2o_data_source)
      call define_f11 (f11_data_source)
      call define_f12 (f12_data_source)
      call define_f113(f113_data_source)
      call define_f22 (f22_data_source)
      call define_co2 (co2_data_source)

!---------------------------------------------------------------------
!    define logical variable indicating whether ch4 is active.
!---------------------------------------------------------------------
      if ((.not. time_varying_ch4) .and. rch4 == 0.0) then
        Lw_control%do_ch4 = .false.
      else
        Lw_control%do_ch4 = .true.
      endif

!---------------------------------------------------------------------
!    define logical variable indicating whether n2o is active.
!---------------------------------------------------------------------
      if ((.not. time_varying_n2o) .and. rn2o == 0.0) then
        Lw_control%do_n2o = .false.
      else
        Lw_control%do_n2o = .true.
      endif

!--------------------------------------------------------------------
!    set flag to indicate variable has been initialized.
!--------------------------------------------------------------------
      Lw_control%do_ch4_iz = .true.
      Lw_control%do_n2o_iz = .true.

!---------------------------------------------------------------------
!    if any of the cfcs are activated, set a flag indicating that cfcs
!    are active.
!---------------------------------------------------------------------
      if ((.not. time_varying_f11) .and. rf11 == 0.0 .and. &
          (.not. time_varying_f12) .and. rf12 == 0.0 .and. &
          (.not. time_varying_f113) .and. rf113 == 0.0 .and. &
          (.not. time_varying_f22) .and. rf22 == 0.0 )  then 
        Lw_control%do_cfc = .false.
      else
        Lw_control%do_cfc = .true.
      endif

!---------------------------------------------------------------------
!    set flag to indicate variable has been initialized.
!---------------------------------------------------------------------
      Lw_control%do_cfc_iz = .true.

!---------------------------------------------------------------------
!    define a logical variable indicating whether co2 is to be 
!    activated. currently co2 must be activated. 
!---------------------------------------------------------------------
      if ((.not. time_varying_co2) .and. rco2 == 0.0) then
        Lw_control%do_co2 = .false.
      else
        Lw_control%do_co2 = .true.
      endif

!---------------------------------------------------------------------
!    set flag to indicate variable has been initialized.
!---------------------------------------------------------------------
      Lw_control%do_co2_iz = .true.

!--------------------------------------------------------------------
!    define module variable which will be contain mixing ratio of each 
!    gas as model is integrated in time.
!--------------------------------------------------------------------
      rrvch4  = rch4
      rrvn2o  = rn2o
      rrvf11  = rf11
      rrvf12  = rf12
      rrvf113 = rf113
      rrvf22  = rf22
      rrvco2  = rco2

!--------------------------------------------------------------------
!    verify that the nml variables used when co2 is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_co2) then
        gas_name = 'co2 '
        call validate_time_varying_inputs   &
                        (gas_name, co2_base_time, co2_base_value,  &
                         co2_specification_type, co2_change_rate, &
                         co2_dataset_entry,  negative_offset_co2, &
                         Co2_offset, Co2_entry, &
                         co2_variation_type, Co2_time_list, co2_value)
      endif

!--------------------------------------------------------------------
!    verify that the nml variables used when ch4 is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_ch4) then
        gas_name = 'ch4 '
        call validate_time_varying_inputs   &
                        (gas_name, ch4_base_time, ch4_base_value,  &
                         ch4_specification_type, ch4_change_rate, &
                         ch4_dataset_entry,  negative_offset_ch4, &
                         Ch4_offset, Ch4_entry, &
                         ch4_variation_type, Ch4_time_list, ch4_value)
      endif

!--------------------------------------------------------------------
!    verify that the nml variables used when n2o is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_n2o) then
        gas_name = 'n2o '
        call validate_time_varying_inputs   &
                        (gas_name, n2o_base_time, n2o_base_value,  &
                         n2o_specification_type, n2o_change_rate, &
                         n2o_dataset_entry,  negative_offset_n2o, &
                         N2o_offset, N2o_entry, &
                         n2o_variation_type, N2o_time_list, n2o_value)
      endif

!--------------------------------------------------------------------
!    verify that the nml variables used when f11 is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_f11) then
        gas_name = 'f11 '
        call validate_time_varying_inputs  &
                        (gas_name, f11_base_time, f11_base_value,  &
                         f11_specification_type, f11_change_rate, &
                         f11_dataset_entry,  negative_offset_f11, &
                         F11_offset, F11_entry, &
                         f11_variation_type, F11_time_list, f11_value)
      endif

!--------------------------------------------------------------------
!    verify that the nml variables used when f12 is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_f12) then
        gas_name = 'f12 '
        call validate_time_varying_inputs   &
                        (gas_name, f12_base_time, f12_base_value, &
                         f12_specification_type, f12_change_rate, &
                         f12_dataset_entry,  negative_offset_f12, &
                         F12_offset, F12_entry, &
                         f12_variation_type, F12_time_list, f12_value)
      endif

!--------------------------------------------------------------------
!    verify that the nml variables used when f113 is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_f113) then
        gas_name = 'f113'
        call validate_time_varying_inputs   &
                        (gas_name, f113_base_time, f113_base_value, &
                         f113_specification_type, f113_change_rate, &
                         f113_dataset_entry,  negative_offset_f113, &
                         F113_offset, F113_entry, &
                         f113_variation_type, F113_time_list,   &
                         f113_value)
      endif

!--------------------------------------------------------------------
!    verify that the nml variables used when f22 is varying with time
!    have been given acceptable values.
!--------------------------------------------------------------------
      if (time_varying_f22) then
        gas_name = 'f22 '
        call validate_time_varying_inputs  &
                        (gas_name, f22_base_time, f22_base_value, &
                         f22_specification_type, f22_change_rate, &
                         f22_dataset_entry,  negative_offset_f22, &
                         F22_offset, F22_entry, &
                         f22_variation_type, F22_time_list, f22_value)
      endif

      ico2 = get_tracer_index(MODEL_ATMOS, 'co2')
      if (ico2 == NO_TRACER .and. trim(co2_data_source) == 'predicted') then
        call error_mesg('radiation_driver_mod', &
        'co2 must be a tracer when predicted co2 desired for radiation.', FATAL)
      endif

!--------------------------------------------------------------------- 
!    call ozone_init to initialize the ozone field.
!---------------------------------------------------------------------
      call ozone_init (latb, lonb)

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------


end subroutine radiative_gases_init



!####################################################################


! <SUBROUTINE NAME="define_radiative_gases">
!  <OVERVIEW>
!   Subroutine that returns the current values of the radiative 
!    gas mixing ratios to radiation_driver in Rad_gases.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine that returns the current values of the radiative 
!    gas mixing ratios to radiation_driver in Rad_gases.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_radiative_gases (is, ie, js, je, Rad_time, lat, &
!                                Atmos_input, Time_next, Rad_gases)
!  </TEMPLATE>
!  <IN NAME="is,ie,js,je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
!   time at which radiation is to be calculated
!                   [ time_type (days, seconds) ] 
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   latitude of model points [ radians ] 
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data
!  </IN>
!  <IN NAME="Time_next" TYPE="time_type">
!   time on next timestep, used as stamp for diagnostic 
!                   output  [ time_type  (days, seconds) ]
!  </IN>
!  <INOUT NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!  </INOUT>
! </SUBROUTINE>
!
subroutine define_radiative_gases (is, ie, js, je, Rad_time, lat, &
                                   Atmos_input, r, Time_next, Rad_gases)

!-------------------------------------------------------------------
!    define_radiative_gases returns the current values of the radiative 
!    gas mixing ratios to radiation_driver in Rad_gases.
!-------------------------------------------------------------------

integer,                    intent(in)    :: is, ie, js, je
type(time_type),            intent(in)    :: Rad_time, Time_next
real, dimension(:,:),       intent(in)    :: lat
type(atmos_input_type),     intent(in)    :: Atmos_input
real, dimension(:,:,:,:),   intent(in)    :: r
type(radiative_gases_type), intent(inout) :: Rad_gases

!---------------------------------------------------------------------
!
!  intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Rad_Time     time at which radiation is to be calculated
!                   [ time_type (days, seconds) ] 
!      Time_next    time on next timestep, used as stamp for diagnostic 
!                   output  [ time_type  (days, seconds) ]  
!      lat          latitude of model points  [ radians ]
!      Atmos_input  atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!      r            array of tracers, some of which may represent
!                   evolving, radiatively active gases (e.g. ozone) 
!
!
!  intent(inout) variables:
!
!      Rad_gases    radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
!
      character(len=8)   :: gas_name  ! name associated with the 
                                      ! radiative gas
      integer            :: yr, mo, dy, hr, mn, sc 
                                      ! components of Rad_time
      type(time_type)    :: Gas_time

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ( 'radiative_gases_mod', &
             'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    if time-varying co2 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of co2 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_co2) then 
        else
           if (trim(co2_data_source) == 'predicted') then
              if (.not. use_globally_uniform_co2) then    
! if predicted, not globally uniform co2 for radiation is desired, then
! rrvco2 will have become an array and will be filled here:
!               rrvco2(:,:,:) = Atmos_input%tracer_co2(is:ie,js:je,:)  
              endif
           endif
        endif

!--------------------------------------------------------------------
!    fill the contents of the radiative_gases_type variable which
!    will be returned to the calling routine.  values of the gas mixing
!    ratio at the current time and a flag indicating if the gas is time-
!    varying are returned for all gases, and for gases for which tfs are
!    calculated, a variable indicating how long they have been varying,
!    and the value of gas mixing ratio used for the last tf calculation
!    are returned.
!---------------------------------------------------------------------
!   these values must now be filled from the module variables:
!      Rad_gases%ch4_tf_offset = ch4_tf_offset
!      Rad_gases%n2o_tf_offset = n2o_tf_offset
!      Rad_gases%co2_tf_offset = co2_tf_offset
!      Rad_gases%ch4_for_next_tf_calc = ch4_for_next_tf_calc
!      Rad_gases%n2o_for_next_tf_calc = n2o_for_next_tf_calc
!      Rad_gases%co2_for_next_tf_calc = co2_for_next_tf_calc

!      Rad_gases%rrvch4  = rrvch4
!      Rad_gases%rrvn2o  = rrvn2o
!      Rad_gases%rrvf11  = rrvf11
!      Rad_gases%rrvf12  = rrvf12
!      Rad_gases%rrvf113 = rrvf113
!      Rad_gases%rrvf22  = rrvf22
!      Rad_gases%rrvco2  = rrvco2
!      Rad_gases%time_varying_co2  = time_varying_co2
!      Rad_gases%time_varying_ch4  = time_varying_ch4
!      Rad_gases%time_varying_n2o  = time_varying_n2o
!      Rad_gases%time_varying_f11  = time_varying_f11
!      Rad_gases%time_varying_f12  = time_varying_f12
!      Rad_gases%time_varying_f113 = time_varying_f113
!      Rad_gases%time_varying_f22  = time_varying_f22
!      if (time_varying_co2) then
!        Rad_gases%Co2_time = Co2_time_list(1)
!      endif
!      if (time_varying_ch4) then
!        Rad_gases%Ch4_time = Ch4_time_list(1)
!      endif
!      if (time_varying_n2o) then
!        Rad_gases%N2o_time = N2o_time_list(1)
!      endif
!RSH    define value for the new variable 
!RSH                     Rad_gases%use_model_supplied_co2, .true. for
!RSH   co2_data_source = 'predicted', .false. otherwise.
!      if (trim(co2_data_source) == 'predicted') then
!         Rad_gases%use_model_supplied_co2 = .true.
!      else
!         Rad_gases%use_model_supplied_co2 = .false.
!      endif

!      Rad_gases%co2_for_last_tf_calc = co2_for_last_tf_calc
!      Rad_gases%ch4_for_last_tf_calc = ch4_for_last_tf_calc
!      Rad_gases%n2o_for_last_tf_calc = n2o_for_last_tf_calc

!--------------------------------------------------------------------
!    allocate an array in a radiative_gases_type variable to hold the
!    model ozone field at the current time. call ozone_driver to define
!    this field for use in the radiation calculation.
!--------------------------------------------------------------------
      allocate (Rad_gases%qo3(ie-is+1, je-js+1,    &
                              size(Atmos_input%press,3) - 1))
      Rad_gases%qo3 = 0.
      call ozone_driver (is, ie, js, je, lat, Rad_time, Atmos_input, &
                         r, Rad_gases)


!---------------------------------------------------------------------


end subroutine define_radiative_gases


!#####################################################################

subroutine radiative_gases_time_vary (Rad_time, gavg_rrv, Rad_gases_tv)

!---------------------------------------------------------------------
!     subroutine radiative_gases_time_vary calculates time-dependent, space-
!     independent quantities needed by this module
!---------------------------------------------------------------------

type(time_type),    intent(in)   :: Rad_time
real, dimension(:), intent(in)   :: gavg_rrv
type(radiative_gases_type), intent(inout)  :: Rad_gases_tv

!---------------------------------------------------------------------
!  local variables:
!
      character(len=8)   :: gas_name  ! name associated with the 
                                      ! radiative gas
      integer            :: yr, mo, dy, hr, mn, sc 
                                      ! components of Rad_time
      type(time_type)    :: Gas_time

!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    if time-varying ch4 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of ch4 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_ch4) then 
            if (negative_offset_ch4) then
              Gas_time = Rad_time - Ch4_offset
            else
              Gas_time = Rad_time + Ch4_offset
            endif
          if (Gas_time >= Ch4_time_list(1)) then
!         if (Rad_time >= Ch4_time_list(1)) then
            gas_name = 'ch4 '
            call define_gas_amount      &
                (gas_name, Gas_time, ch4_specification_type,  &
!               (gas_name, Rad_time, ch4_specification_type,  &
!                negative_offset_ch4, Ch4_offset, &
                 ch4_variation_type, ch4_floor, ch4_ceiling, rch4,   &
                 ch4_uses_tfs, ch4_change_rate, rrvch4, Ch4_time_list, &
                 ch4_value, &
                 gas_tf_calc_intrvl =        &
                            Rad_control%ch4_tf_calc_intrvl,         &
                 gas_tf_time_displacement =  &
                            Rad_control%ch4_tf_time_displacement,   &
                 calc_gas_tfs_on_first_step =  &
                            Rad_control%calc_ch4_tfs_on_first_step, &
                 calc_gas_tfs_monthly       =  &
                            Rad_control%calc_ch4_tfs_monthly,       &
                 use_current_gas_for_tf = &
                            Rad_control%use_current_ch4_for_tf,  &
                 gas_tf_offset = &
                            ch4_tf_offset,  &
                 gas_for_last_tf_calc =   &
                            ch4_for_last_tf_calc,    &
                 gas_for_next_tf_calc = &
                            ch4_for_next_tf_calc, &
                 gas_tfs_needed = ch4_tfs_needed, &
                 define_gas_for_last_tf_calc = &
                            define_ch4_for_last_tf_calc)
                 if (Rad_control%calc_ch4_tfs_on_first_step) then
                   ch4_tfs_needed = .false.
                 endif

!---------------------------------------------------------------------
!    if time-variation is desired, but it is not yet time to begin
!    variation, define the ch4 mixing ratio that was used for the last
!    transmission function calculation, so that the tfs may be calcul-
!    ated as previously. (this is only done on initial timestep of a 
!    job).
!---------------------------------------------------------------------
          else  ! (Rad_time > Ch4_time)
            ch4_for_last_tf_calc = rrvch4
            ch4_tf_offset = 0.0
          endif   ! (Rad_time > Ch4_time)
        else
          ch4_for_last_tf_calc = rrvch4
        endif  ! (time_varying_ch4)

!--------------------------------------------------------------------
!    if time-varying n2o is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of n2o needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_n2o) then 
            if (negative_offset_n2o) then
              Gas_time = Rad_time - N2o_offset
            else
              Gas_time = Rad_time + N2o_offset
            endif
          if (Gas_time >= N2o_time_list(1)) then
            gas_name = 'n2o '
            call define_gas_amount      &
                (gas_name, Gas_time, n2o_specification_type,  &
!                negative_offset_n2o, N2o_offset, &
                 n2o_variation_type, n2o_floor, n2o_ceiling, rn2o,  &
                 n2o_uses_tfs, n2o_change_rate, rrvn2o, N2o_time_list, &
                 n2o_value, &
                 gas_tf_calc_intrvl =        &
                               Rad_control%n2o_tf_calc_intrvl,         &
                 gas_tf_time_displacement =  &
                               Rad_control%n2o_tf_time_displacement,   &
                 calc_gas_tfs_on_first_step =  &
                               Rad_control%calc_n2o_tfs_on_first_step, &
                 calc_gas_tfs_monthly       =  &
                            Rad_control%calc_n2o_tfs_monthly,       &
                 use_current_gas_for_tf = &
                               Rad_control%use_current_n2o_for_tf,  &
                 gas_tf_offset = &
                               n2o_tf_offset,  &
                 gas_for_last_tf_calc =   &
                               n2o_for_last_tf_calc,    &
                 gas_for_next_tf_calc = &
                               n2o_for_next_tf_calc, &
                 gas_tfs_needed = n2o_tfs_needed, &
                 define_gas_for_last_tf_calc = &
                               define_n2o_for_last_tf_calc)
                 if (Rad_control%calc_n2o_tfs_on_first_step) then
                   n2o_tfs_needed = .false.
                 endif

!---------------------------------------------------------------------
!    if time-variation is desired, but it is not yet time to begin
!    variation, define the n2o mixing ratio that was used for the last
!    transmission function calculation, so that the tfs may be calcul-
!    ated as previously. (this is only done on initial timestep of a 
!    job).
!---------------------------------------------------------------------
          else  ! (Rad_time > N2o_time)
            n2o_for_last_tf_calc = rrvn2o
            n2o_tf_offset = 0.0
          endif   ! (Rad_time > N2o_time)
        else
          n2o_for_last_tf_calc = rrvn2o
        endif  ! (time_varying_n2o)

!--------------------------------------------------------------------
!    if time-varying f11 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of f11 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_f11) then 
            if (negative_offset_f11) then
              Gas_time = Rad_time - F11_offset
            else
              Gas_time = Rad_time + F11_offset
            endif
          if (Gas_time >= F11_time_list(1)) then
            gas_name = 'f11 '
            call define_gas_amount      &
                (gas_name, Gas_time, f11_specification_type,  &
!                negative_offset_f11, F11_offset, &
                 f11_variation_type, f11_floor, f11_ceiling, rf11,   &
                 f11_uses_tfs, f11_change_rate, rrvf11, F11_time_list, &
                 f11_value)
          endif   ! (Rad_time > F11_time)
        endif  ! (time_varying_f11)

!--------------------------------------------------------------------
!    if time-varying f12 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of f12 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_f12) then 
            if (negative_offset_f12) then
              Gas_time = Rad_time - F12_offset
            else
              Gas_time = Rad_time + F12_offset
            endif
          if (Gas_time >= F12_time_list(1)) then
            gas_name = 'f12 '
            call define_gas_amount      &
                (gas_name, Gas_time, f12_specification_type,   &
!                negative_offset_f12, F12_offset, &
                 f12_variation_type, f12_floor, f12_ceiling, rf12,   &
                 f12_uses_tfs, f12_change_rate, rrvf12, F12_time_list, &
                 f12_value)
          endif   ! (Rad_time > F12_time)
        endif  ! (time_varying_f12)

!--------------------------------------------------------------------
!    if time-varying f113 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of f113 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_f113) then 
            if (negative_offset_f113) then
              Gas_time = Rad_time - F113_offset
            else
              Gas_time = Rad_time + F113_offset
            endif
          if (Gas_time >= F113_time_list(1)) then
            gas_name = 'f113'
            call define_gas_amount      &
                (gas_name, Gas_time, f113_specification_type,  &
!                negative_offset_f113, F113_offset, &
                 f113_variation_type, f113_floor, f113_ceiling, rf113, &
                 f113_uses_tfs, f113_change_rate, rrvf113,  &
                 F113_time_list, f113_value)
          endif   ! (Rad_time > F113_time)
        endif  ! (time_varying_f113)

!--------------------------------------------------------------------
!    if time-varying f22 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of f22 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_f22) then 
            if (negative_offset_f22) then
              Gas_time = Rad_time - F22_offset
            else
              Gas_time = Rad_time + F22_offset
            endif
          if (Gas_time >= F22_time_list(1)) then
            gas_name = 'f22 '
            call define_gas_amount      &
                (gas_name, Gas_time, f22_specification_type,  &
!                negative_offset_f22, F22_offset, &
                 f22_variation_type, f22_floor, f22_ceiling, rf22, &
                 f22_uses_tfs, f22_change_rate, rrvf22, F22_time_list, &
                 f22_value)
          endif   ! (Rad_time > F22_time)
        endif  ! (time_varying_f22)

!--------------------------------------------------------------------
!    if time-varying co2 is desired, and the time at which variation 
!    was to begin has been exceeded, define the gas_name variable and
!    call define_gas_amount to return the values of co2 needed on this
!    timestep.
!--------------------------------------------------------------------
        if (time_varying_co2) then 
            if (negative_offset_co2) then
              Gas_time = Rad_time - Co2_offset
            else
              Gas_time = Rad_time + Co2_offset
            endif
          if (Gas_time >= Co2_time_list(1)) then
            gas_name = 'co2 '
            call define_gas_amount      &
                (gas_name, Gas_time, co2_specification_type,  &
!                negative_offset_co2, Co2_offset, &
                 co2_variation_type, co2_floor, co2_ceiling, rco2, &
                 co2_uses_tfs, co2_change_rate, rrvco2, Co2_time_list, &
                 co2_value,  &
                 gas_tf_calc_intrvl =        &
                               Rad_control%co2_tf_calc_intrvl,         &
                 gas_tf_time_displacement =  &
                               Rad_control%co2_tf_time_displacement,   &
                 calc_gas_tfs_on_first_step =  &
                               Rad_control%calc_co2_tfs_on_first_step, &
                 calc_gas_tfs_monthly       =  &
                            Rad_control%calc_co2_tfs_monthly,       &
                 use_current_gas_for_tf = &
                               Rad_control%use_current_co2_for_tf,  &
                 gas_tf_offset = &
                               co2_tf_offset,  &
                 gas_for_last_tf_calc =   &
                               co2_for_last_tf_calc,    &
                 gas_for_next_tf_calc = &
                               co2_for_next_tf_calc, &
                 gas_tfs_needed = co2_tfs_needed, &
                 define_gas_for_last_tf_calc = &
                               define_co2_for_last_tf_calc)
                 if (Rad_control%calc_co2_tfs_on_first_step) then
                   co2_tfs_needed = .false.
                 endif

!---------------------------------------------------------------------
!    if time-variation is desired, but it is not yet time to begin
!    variation, define the co2 mixing ratio that was used for the last
!    transmission function calculation, so that the tfs may be calcul-
!    ated as previously. (this is only needed on initial timestep of a 
!    job).
!---------------------------------------------------------------------
          else  ! (Rad_time > Co2_time)
            co2_for_last_tf_calc = rrvco2
            co2_tf_offset = 0.0
          endif   ! (Rad_time > Co2_time)
        else
           if (trim(co2_data_source) == 'predicted') then
              if (use_globally_uniform_co2) then    
                 rrvco2 = gavg_rrv(ico2)
              else
!    if 3d co2 distribution desired for radiation, it will be defined in
!    define_radiatiove_gases.
              endif
           else !trim(co2_data_source) == 'predicted')
              co2_for_last_tf_calc = rrvco2
           endif  !(trim(co2_data_source) == 'predicted')
        endif  ! (time_varying_co2)


!---------------------------------------------------------------------
!    print out the current gas mixing ratios, if desired.
!---------------------------------------------------------------------
      if ((mpp_pe() == mpp_root_pe()) .and. verbose >= 3) then
        if (Rad_control%do_lw_rad) then
          print_alarm = print_alarm - Rad_control%lw_rad_time_step
        endif
        if (print_alarm <= 0) then
          call get_date (Rad_time, yr, mo, dy, hr, mn, sc)
          write (*, FMT ='(a, i5, i3, i3, i3, i3, i3,   &
                           & a, f11.6, a, f11.6, a, /,  &
                           & 7x, a, f11.6, a, f11.6,  &
                           & a, f11.6, a , /, 7x, a,  f11.6, &
                           & a, f11.6, a)')  &
                  'Time =',  yr, mo, dy, hr, mn, sc, &
                  '    ch4 = ', rrvch4*1.0e09, 'ppb  n2o = ' ,  &
                  rrvn2o*1.0e9, 'ppb', 'co2  = ', rrvco2*1.0e6,  &
                  'ppm  f11 = ' , rrvf11*1.0e12,  'ppt  f12 = ', &
                  rrvf12*1.0e12, 'ppt', 'f113 = ', rrvf113*1.0e12, &
                  'ppt  f22 = ', rrvf22*1.0e12, 'ppt'
          print_alarm = gas_printout_freq*3600
        endif
      endif

!--------------------------------------------------------------------
!    fill the contents of the radiative_gases_type variable which
!    will be returned to the calling routine.  values of the gas mixing
!    ratio at the current time and a flag indicating if the gas is time-
!    varying are returned for all gases, and for gases for which tfs are
!    calculated, a variable indicating how long they have been varying,
!    and the value of gas mixing ratio used for the last tf calculation
!    are returned.
!---------------------------------------------------------------------
!   these values must now be filled from the module variables:
      Rad_gases_tv%ch4_tf_offset = ch4_tf_offset
      Rad_gases_tv%n2o_tf_offset = n2o_tf_offset
      Rad_gases_tv%co2_tf_offset = co2_tf_offset
      Rad_gases_tv%ch4_for_next_tf_calc = ch4_for_next_tf_calc
      Rad_gases_tv%n2o_for_next_tf_calc = n2o_for_next_tf_calc
      Rad_gases_tv%co2_for_next_tf_calc = co2_for_next_tf_calc

      Rad_gases_tv%rrvch4  = rrvch4
      Rad_gases_tv%rrvn2o  = rrvn2o
      Rad_gases_tv%rrvf11  = rrvf11
      Rad_gases_tv%rrvf12  = rrvf12
      Rad_gases_tv%rrvf113 = rrvf113
      Rad_gases_tv%rrvf22  = rrvf22
      Rad_gases_tv%rrvco2  = rrvco2
      Rad_gases_tv%time_varying_co2  = time_varying_co2
      Rad_gases_tv%time_varying_ch4  = time_varying_ch4
      Rad_gases_tv%time_varying_n2o  = time_varying_n2o
      Rad_gases_tv%time_varying_f11  = time_varying_f11
      Rad_gases_tv%time_varying_f12  = time_varying_f12
      Rad_gases_tv%time_varying_f113 = time_varying_f113
      Rad_gases_tv%time_varying_f22  = time_varying_f22
      if (time_varying_co2) then
        Rad_gases_tv%Co2_time = Co2_time_list(1)
      endif
      if (time_varying_ch4) then
        Rad_gases_tv%Ch4_time = Ch4_time_list(1)
      endif
      if (time_varying_n2o) then
        Rad_gases_tv%N2o_time = N2o_time_list(1)
      endif
!    define value for the new variable 
!    Rad_gases%use_model_supplied_co2, .true. for
!                    co2_data_source = 'predicted', .false. otherwise.
      if (trim(co2_data_source) == 'predicted') then
         Rad_gases_tv%use_model_supplied_co2 = .true.
      else
         Rad_gases_tv%use_model_supplied_co2 = .false.
      endif

      Rad_gases_tv%co2_for_last_tf_calc = co2_for_last_tf_calc
      Rad_gases_tv%ch4_for_last_tf_calc = ch4_for_last_tf_calc
      Rad_gases_tv%n2o_for_last_tf_calc = n2o_for_last_tf_calc


!----------------------------------------------------------------------

            call ozone_time_vary (Rad_time)

!--------------------------------------------------------------------


end subroutine radiative_gases_time_vary



!##################################################################

subroutine radiative_gases_endts

     call ozone_endts


end subroutine radiative_gases_endts




!##################################################################

!####################################################################
! <SUBROUTINE NAME="radiative_gases_end">
!  <OVERVIEW>
!    radiative_gases_end is the destructor for radiative_gases_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    radiative_gases_end is the destructor for radiative_gases_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiative_gases_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine radiative_gases_end

!---------------------------------------------------------------------
!    radiative_gases_end is the destructor for radiative_gases_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ( 'radiative_gases_mod', &
               'module has not been initialized', FATAL )
      endif

      call radiative_gases_restart

!--------------------------------------------------------------------
!    deallocate the timeseries arrays.
!--------------------------------------------------------------------
      deallocate (co2_value, ch4_value, n2o_value, f11_value, &
                  f12_value, f113_value, f22_value)    
      deallocate (Co2_time_list, Ch4_time_list, N2o_time_list, &
                  F11_time_list, F12_time_List, &
                  F113_time_list, F22_time_list)

!---------------------------------------------------------------------
!    call the destructors for the component gas module(s).
!---------------------------------------------------------------------
      call ozone_end

!--------------------------------------------------------------------
      module_is_initialized = .false.


end subroutine radiative_gases_end

!#######################################################################
! <SUBROUTINE NAME="radiative_gases_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine radiative_gases_restart(timestamp)
   character(len=*), intent(in), optional :: timestamp

! Make sure that the restart_versions variable is up to date.
   vers = restart_versions(size(restart_versions(:)))     
   if( do_netcdf_restart ) then
      if(mpp_pe() == mpp_root_pe() ) then
         call error_mesg ('radiative_gases_mod', 'Writing NetCDF formatted restart file: RESTART/radiative_gases.res.nc', NOTE)
      endif
      call save_restart(Rad_restart, timestamp)
   else
      call error_mesg ('radiative_gases_mod', &
         'Native intermediate restart files are not supported.', FATAL)
   endif

end subroutine radiative_gases_restart
! </SUBROUTINE>

!####################################################################
! <SUBROUTINE NAME="radiative_gases_dealloc">
!  <OVERVIEW>
!    radiative_gases_end is the destructor for radiative_gases_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    radiative_gases_end is the destructor for radiative_gases_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call radiative_gases_dealloc (Rad_gases)
!  </TEMPLATE>
!  <INOUT NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing the radi-
!              ative gas input fields needed by the radiation package
!  </INOUT>
! </SUBROUTINE>
!
subroutine radiative_gases_dealloc (Rad_gases)

!---------------------------------------------------------------------
!
!--------------------------------------------------------------------

type(radiative_gases_type), intent(inout)  :: Rad_gases

!---------------------------------------------------------------------
!  intent(inout) variable:
!
!     Rad_gases
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ( 'radiative_gases_mod', &
             'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    deallocate the variables in Rad_gases.
!--------------------------------------------------------------------
      deallocate (Rad_gases%qo3)


!--------------------------------------------------------------------
!    save the value of the gas mixing ratio used to calculate the gas
!    transmission functions (it may have been updated on this step)
!    so that it is available to write to the restart file.
!--------------------------------------------------------------------
      co2_for_last_tf_calc = Rad_gases%co2_for_last_tf_calc
      ch4_for_last_tf_calc = Rad_gases%ch4_for_last_tf_calc
      n2o_for_last_tf_calc = Rad_gases%n2o_for_last_tf_calc

!---------------------------------------------------------------------


end subroutine radiative_gases_dealloc 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="validate_time_varying_inputs">
!  <OVERVIEW>
!   validate_time_varying_inputs checks for consistency among the 
!   namelist parameters defining the time variation of the input gas.
!   NOTE: THIS IS A PRIVATE SUBROUTINE.
!
!  </OVERVIEW>
!
!  <DESCRIPTION>
!   Subroutine validate_time_varying_inputs performs the following 
!   checks of the namelist variables:
!     1) Verifies that base_time has a non-zero month and day number,
!        indicating a change from the default;
!     2) Verifies that the base value of gas mixing ratio is non-zero;
!     3) Verifies that specification_type is valid, either 
!        'base_and_trend' or 'time_series';
!     4) Verifies that variation_type is valid, either 'linear' or
!        'logarithmic';
!     5) When specification_type is 'base_and_trend', verifies that 
!        change_rate is non-zero;
!  </DESCRIPTION>
!  <TEMPLATE>
!   call validate_time_varying_inputs   &
!                     (gas, base_time, base_value, specification_type, &
!                      change_rate, variation_type, Gas_time_list,  &
!                      gas_value)
!  </TEMPLATE>
!  <IN NAME="gas">
!   name associated with the current gas
!  </IN>
!  <IN NAME="base_time">
!   time at which the base_value is applicable
!   [ year, month, day, hour, minute, second ]
!  </IN>
!  <IN NAME="base_value">
!   base value for vol. mixing ratio of gas 
!   [ number / number ]
!  </IN>
!  <IN NAME="specification_type">
!   specification of form of time variation of gas 
!  </IN>
!  <IN NAME="change_rate">
!   rate of change of gas; 1.00 + [ percent change / year ]
!  </IN>
!  <IN NAME="variation_type">
!   form of the temporal behavior of gas; either 'linear' or 
!   'logarithmic'
!  </IN>
!  <INOUT NAME="Gas_time_list">
!   array of time_type variables defining the data times for the gas;
!   if specification_type is timeseries, then it is the set of times
!   in the daa set, if specification type is base_and_trend, then it
!   is an array of dimension 1 containing the xxx_base_time. 
!   [ time_type ]
!  </INOUT>
!  <IN NAME="gas_value">
!   array of values of gas concentrations corresponding to the times
!   in Gas_time_list [ number / number ]
!  </IN>
!

!<PUBLICROUTINE>
!
!NOTE: THIS IS A PRIVATE SUBROUTINE.
!

subroutine validate_time_varying_inputs   &
                      (gas, base_time, base_value, specification_type, &
                       change_rate,  gas_dataset_entry,  &
                       negative_offset_gas, Gas_offset, Gas_entry, &
                       variation_type, Gas_time_list, gas_value)

!---------------------------------------------------------------------
!    validate_time_varying_inputs checks for consistency among the 
!    namelist parameters defining the time variation of the input gas.
!--------------------------------------------------------------------

character(len=*),      intent(in)  :: gas
integer, dimension(6), intent(in)  :: base_time, gas_dataset_entry
real,                  intent(in)  :: base_value,            &
                                      change_rate
logical,               intent(inout)  :: negative_offset_gas
character(len=*),     intent(in)  :: specification_type, variation_type
type(time_type),dimension(:), intent(inout)  :: Gas_time_list
type(time_type), intent(inout)  :: Gas_offset, Gas_entry
real, dimension(:), intent(in) :: gas_value

!--------------------------------------------------------------------
!   local variables:

      integer :: n

!</PUBLICROUTINE>

!------------------------------------------------------------------
!    perform checks for the base_and_trend specification_type.
!------------------------------------------------------------------
      if (trim(specification_type) == 'base_and_trend') then

!------------------------------------------------------------------
!    verify that base_time has a valid value (month and day /= 0 , 
!    hr, min and sec == 0). 
!------------------------------------------------------------------
        if (base_time(4) /= 0 .or. base_time(5) /= 0  .or. &
            base_time(6) /= 0)  then  
          call error_mesg ('radiative_gases_mod', &
           'base_time for gas' // trim(gas)//'must be specified as 00Z &
            &of desired day', FATAL)
        endif

!------------------------------------------------------------------
!    verify that base_value is non-zero. 
!------------------------------------------------------------------
        if (base_value < 0.0) then
          call error_mesg ('radiative_gases_mod', &
                        trim(gas)//'_base_value must be >= 0.0', FATAL)
        endif

!---------------------------------------------------------------------
!    convert the base_time to a time_type and store in Gas_time_list(1).
!---------------------------------------------------------------------
        if (base_time(2) /= 0 .and. base_time(3) /= 0 ) then  
          Gas_time_list(1) = set_date (base_time(1), base_time(2), &
                                       base_time(3), base_time(4), &
                                       base_time(5), base_time(6))  
        else
          call error_mesg ('radiative_gases_mod', &
           'must supply valid date for '//trim(gas)//'_base_time when&
                              & using time_varying '//trim(gas), FATAL)
        endif

!------------------------------------------------------------------
!    make sure that change_rate has been specified as non-zero; a value
!    of 0.0 corresponds to non-time-varying, and is not allowed.
!------------------------------------------------------------------
        if (change_rate == 0.0) then
          call error_mesg ('radiative_gases_mod', &
            ' have specified base_and_trend '//gas//' variation but ' &
                            //trim(gas)//'_change_rate is zero', FATAL)
        endif
        
!------------------------------------------------------------------
!    set Gas_offset to 0 when timeseries is not being used.
!------------------------------------------------------------------
        Gas_offset = set_time(0,0)

!------------------------------------------------------------------
!    perform checks for the time_series specification_type.
!------------------------------------------------------------------
      else if (trim(specification_type) ==  'time_series') then

!------------------------------------------------------------------
!    make sure that the entries are in chronological order.
!------------------------------------------------------------------
        do n = 2, size(Gas_time_list(:)) 
          if (Gas_time_list(n) < Gas_time_list(n-1)) then
            call error_mesg ('radiative_gases_mod', &
                 'times  for ' // trim(gas) //   &
                 ' in Gas_time_list are not in sequence', FATAL) 
          endif
        end do
      
!------------------------------------------------------------------
!    make sure that all gas concentrations are acceptable in magnitude.
!------------------------------------------------------------------
        do n = 1, size(Gas_time_list(:)) 
          if (gas_value(n) < 0) then
          call error_mesg ('radiative_gases_mod', &
             trim(gas)//'_value must be >= 0.0', FATAL)
          endif
        end do
        
!------------------------------------------------------------------
!    if 'time_series' is specified, variation_type
!    must be 'linear'.
!------------------------------------------------------------------
        if (trim(variation_type) == 'logarithmic') then
          call error_mesg ('radiative_gases_mod', &
            'logarithmic variation not allowed with time_series &
                                   &specification', FATAL)
        endif

!---------------------------------------------------------------------
!    define model initial time (from diag_table).
!---------------------------------------------------------------------
        Model_init_time = get_base_time()
 
!---------------------------------------------------------------------
!    if an entry into the gas timeseries has not been specified, use
!    the model base time as the entry point.
!---------------------------------------------------------------------
        if (gas_dataset_entry(1) == 1 .and. &
            gas_dataset_entry(2) == 1 .and. &
            gas_dataset_entry(3) == 1 .and. &
            gas_dataset_entry(4) == 0 .and. &
            gas_dataset_entry(5) == 0 .and. &
            gas_dataset_entry(6) == 0 ) then
          Gas_entry = Model_init_time

!---------------------------------------------------------------------
!    define time for which gas data is desired.
!---------------------------------------------------------------------
        else
          Gas_entry  = set_date (gas_dataset_entry(1), &
                                 gas_dataset_entry(2), &
                                 gas_dataset_entry(3), &
                                 gas_dataset_entry(4), &
                                 gas_dataset_entry(5), &
                                 gas_dataset_entry(6))
        endif

        call error_mesg ( 'radiative_gases_mod', &
              'PROCESSING TIMESERIES FOR ' // trim(gas), NOTE)
        call print_date (Gas_entry , str='Data from timeseries &
                                           &at time:')
        call print_date(Model_init_time , str='This data is mapped to&
                                                  & model time:')

!----------------------------------------------------------------------
!    define the offset from model base time to gas_dataset_entry
!    as a time_type variable.
!----------------------------------------------------------------------
        Gas_offset = Gas_entry - Model_init_time

        if (Model_init_time > Gas_entry) then
          negative_offset_gas = .true.
        else
          negative_offset_gas = .false.
        endif

!------------------------------------------------------------------
!    if specification_type is invalid, issue an error message.
!------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
               ' invalid '//trim(gas)//'_specification_type', FATAL)
      endif

!------------------------------------------------------------------
!    verify that variation_type is valid.
!------------------------------------------------------------------
      if (trim(variation_type) == 'linear' .or. &
          trim(variation_type) == 'logarithmic' ) then
      else
        call  error_mesg ('radiative_gases_mod', &
          trim(gas)//'_variation_type must be "linear" or &
                                             &"logarithmic" ', FATAL)
      endif

!---------------------------------------------------------------------



end subroutine validate_time_varying_inputs


! </SUBROUTINE>

!#####################################################################
! <SUBROUTINE NAME="read_restart_radiative_gases">
!  <OVERVIEW>
!   Subroutine to read the radiative_gases.res file
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to read the radiative_gases.res file
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_restart_radiative_gases
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine read_restart_radiative_gases 

!---------------------------------------------------------------------
!    read_restart_radiative_gases reads the radiative_gases.res file.
!---------------------------------------------------------------------

      integer  ::  unit   ! unit number fused for i/o

!--------------------------------------------------------------------
!    determine if  a radiative_gases.parameters.res file is present.
!    this file is only present in restart version 1.
!--------------------------------------------------------------------
      if (file_exist('INPUT/radiative_gases.parameters.res' ) ) then

!---------------------------------------------------------------------
!    read radiative gas restart file, version 1.
!---------------------------------------------------------------------
        if (file_exist('INPUT/radiative_gases.res' ) ) then
          unit = open_restart_file     &
                          ('INPUT/radiative_gases.res', action= 'read')
          read (unit) rco2
          read (unit) rf11, rf12, rf113, rf22
          read (unit) rch4, rn2o
          call close_file (unit)
        endif ! (file_exist(.res))
      else 
!---------------------------------------------------------------------
!    read radiative gas restart file. version number will be the first
!    file record.
!---------------------------------------------------------------------
        if (file_exist('INPUT/radiative_gases.res' ) ) then
          unit = open_restart_file   &
                          ('INPUT/radiative_gases.res', action= 'read')
          read (unit) vers

!---------------------------------------------------------------------
!    verify that this restart file version is readable by the current
!    code. if not, print a message.
!---------------------------------------------------------------------
          if ( .not. any(vers == restart_versions) ) then
            call error_mesg ('radiative_gases_mod', &
              'radiative_gases restart problem --  may be '//&
               'attempting to read version 1 file '//&
                 'w/o parameters.res file being present.',  FATAL)
          endif

!--------------------------------------------------------------------
!    read the gas concentrations from the file.
!--------------------------------------------------------------------
          read (unit) rco2
          read (unit) rf11, rf12, rf113, rf22
          read (unit) rch4, rn2o

!---------------------------------------------------------------------
!    for file versions 3 and higher, the gas values used when tfs were
!    last calculated are present.
!---------------------------------------------------------------------
          if (vers >= 3) then
            read (unit) co2_for_last_tf_calc
            read (unit) ch4_for_last_tf_calc
            read (unit) n2o_for_last_tf_calc
          else

!--------------------------------------------------------------------
!  set flag to indicate value is needed.
!--------------------------------------------------------------------
            define_co2_for_last_tf_calc = .true.
            define_ch4_for_last_tf_calc = .true.
            define_n2o_for_last_tf_calc = .true.
          endif
          call close_file (unit)
        endif 
      endif 

!--------------------------------------------------------------------


end subroutine read_restart_radiative_gases


!###################################################################
! <SUBROUTINE NAME="define_ch4">
!  <OVERVIEW>
!   Subroutine that provides initial values for ch4 mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine that provides initial values for ch4 mixing ratio.if ch4
!    is fixed in time, the value is given by the namelist specification.
!    if ch4 is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_ch4 (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define ch4 initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_ch4 (data_source) 

!---------------------------------------------------------------------
!    define_ch4 provides initial values for ch4 mixing ratio. if ch4
!    is fixed in time, the value is given by the namelist specification.
!    if ch4 is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define ch4 initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rch4_ipcc_80  = 1.56900E-06
      real       ::  rch4_ipcc_92  = 1.71400E-06
      real       ::  rch4_icrccm   = 1.75000E-06
      real       ::  rch4_ipcc_98  = 1.82120E-06




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial ch4 mixing ratios to be used.
!    'icrccm'     --> rch4_icrccm
!    'ipcc80'     --> rch4_ipcc_80
!    'ipcc92'     --> rch4_ipcc_92
!    'ipcc98'     --> rch4_ipcc_98
!    'input'      --> file INPUT/id1ch4n2o, record 1
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(ch4_specification_type) /= 'time_series') then
        allocate (Ch4_time_list(1))
        allocate (ch4_value(1))
      endif

      if (trim(data_source)      == 'icrccm') then
        rch4   = rch4_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rch4   = rch4_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rch4   = rch4_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rch4   = rch4_ipcc_98

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(ch4_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1ch4n2o') ) then
            inrad = open_namelist_file ('INPUT/id1ch4n2o')
            read (inrad, FMT = '(5e18.10)')  rch4
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired ch4_n2o input file is not present', FATAL)
          endif
        else
          gas_name = 'ch4 '
          call read_gas_timeseries (gas_name, ch4_value, &
                                    Ch4_time_list, time_varying_ch4, &
                                    ch4_dataset_entry, rch4)   
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart ch4 values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1ch4n2o') ) then
            inrad = open_namelist_file ('INPUT/id1ch4n2o')
            read (inrad, FMT = '(5e18.10)') rch4
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor ch4 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1ch4n2o') ) then
            inrad = open_namelist_file ('INPUT/id1ch4n2o')
            read (inrad, FMT = '(5e18.10)') rch4
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor ch4 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of ch4 is obtained
!    from the namelist variable ch4_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rch4 = ch4_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for ch4' , FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rch4 < ch4_floor) then
        call error_mesg ('radiative_gases_mod', &
              'base ch4 mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rch4 > ch4_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base ch4 mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------



end subroutine define_ch4



!#####################################################################
! <SUBROUTINE NAME="define_n2o">
!  <OVERVIEW>
!   Subroutine that provides initial values for n2o mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine that provides initial values for n2o mixing ratio.if n2o
!    is fixed in time, the value is given by the namelist specification.
!    if n2o is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_n2o (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define n2o initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_n2o (data_source) 

!---------------------------------------------------------------------
!    define_n2o provides initial values for n2o mixing ratio. if n2o
!    is fixed in time, the value is given by the namelist specification.
!    if n2o is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define n2o initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rn2o_ipcc_80  = 3.02620E-07
      real       ::  rn2o_ipcc_92  = 3.11000E-07
      real       ::  rn2o_icrccm   = 2.80000E-07
      real       ::  rn2o_ipcc_98  = 3.16000E-07




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial n2o mixing ratios to be used.
!    'icrccm'     --> rn2o_icrccm
!    'ipcc80'     --> rn2o_ipcc_80
!    'ipcc92'     --> rn2o_ipcc_92
!    'ipcc98'     --> rn2o_ipcc_98
!    'input'      --> file INPUT/id1ch4n2o, record 2
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(n2o_specification_type) /= 'time_series') then
        allocate (N2o_time_list(1))
        allocate (n2o_value(1))
      endif

      if (trim(data_source)      == 'icrccm') then
        rn2o   = rn2o_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rn2o   = rn2o_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rn2o   = rn2o_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rn2o   = rn2o_ipcc_98

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(n2o_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1ch4n2o') ) then
            inrad = open_namelist_file ('INPUT/id1ch4n2o')
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  rn2o
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired ch4_n2o input file is not present', FATAL)
          endif
        else
          gas_name = 'n2o '
          call read_gas_timeseries (gas_name, n2o_value,   &
                                    N2o_time_list, time_varying_n2o, &
                                    n2o_dataset_entry, rn2o)   
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart n2o values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1ch4n2o') ) then
            inrad = open_namelist_file ('INPUT/id1ch4n2o')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rn2o
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor n2o input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1ch4n2o') ) then
            inrad = open_namelist_file ('INPUT/id1ch4n2o')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rn2o
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor n2o input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of n2o is obtained
!    from the namelist variable n2o_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rn2o = n2o_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for n2o ', FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rn2o < n2o_floor) then
        print *, 'rn2o, n2o_floor', rn2o, n2o_floor, mpp_pe()
        call error_mesg ('radiative_gases_mod', &
              'base n2o mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rn2o > n2o_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base n2o mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------




end subroutine define_n2o



!#####################################################################
! <SUBROUTINE NAME="define_f11">
!  <OVERVIEW>
!   Subroutine that provides initial values for f11 mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_f11 provides initial values for f11 mixing ratio. if f11
!    is fixed in time, the value is given by the namelist specification.
!    if f11 is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_f11 (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define f11 initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_f11 (data_source) 

!---------------------------------------------------------------------
!    define_f11 provides initial values for f11 mixing ratio. if f11
!    is fixed in time, the value is given by the namelist specification.
!    if f11 is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define f11 initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rf11_icrccm   = 1.00000E-09
      real       ::  rf11_ipcc_80  = 1.57500E-10
      real       ::  rf11_ipcc_92  = 2.68000E-10
      real       ::  rf11_ipcc_98  = 2.68960E-10




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial f11 mixing ratios to be used.
!    'icrccm'     --> rf11_icrccm
!    'ipcc80'     --> rf11_ipcc_80
!    'ipcc92'     --> rf11_ipcc_92
!    'ipcc98'     --> rf11_ipcc_98
!    'input'      --> file INPUT/id1cfc, record 1
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(f11_specification_type) /= 'time_series') then
        allocate (F11_time_list(1))
        allocate (f11_value(1))
     endif

      if (trim(data_source)      == 'icrccm') then
        rf11   = rf11_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rf11   = rf11_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rf11   = rf11_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rf11   = rf11_ipcc_98

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(f11_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)')  rf11
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired cfc input file is not present', FATAL)
          endif
        else
          gas_name = 'f11 '
          call read_gas_timeseries (gas_name, f11_value,   &
                                    F11_time_list, time_varying_f11, &
                                    f11_dataset_entry, rf11)   
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart f11 values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') rf11
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f11 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') rf11
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f11 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of f11 is obtained
!    from the namelist variable f11_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rf11 = f11_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for f11 ', FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rf11 < f11_floor) then
        call error_mesg ('radiative_gases_mod', &
              'base f11 mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rf11 > f11_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base f11 mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------




end subroutine define_f11




!#####################################################################
! <SUBROUTINE NAME="define_f12">
!  <OVERVIEW>
!   Subroutine that provides initial values for f12 mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_f12 provides initial values for f12 mixing ratio. if f12
!    is fixed in time, the value is given by the namelist specification.
!    if f12 is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_f12 (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define f12 initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_f12 (data_source) 

!---------------------------------------------------------------------
!    define_f12 provides initial values for f12 mixing ratio. if f12
!    is fixed in time, the value is given by the namelist specification.
!    if f12 is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define f12 initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rf12_icrccm   = 1.00000E-09
      real       ::  rf12_ipcc_80  = 2.72500E-10
      real       ::  rf12_ipcc_92  = 5.03000E-10
      real       ::  rf12_ipcc_98  = 5.31510E-10




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial f12 mixing ratios to be used.
!    'icrccm'     --> rf12_icrccm
!    'ipcc80'     --> rf12_ipcc_80
!    'ipcc92'     --> rf12_ipcc_92
!    'ipcc98'     --> rf12_ipcc_98
!    'input'      --> file INPUT/id1cfc, record 2
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(f12_specification_type) /= 'time_series') then
        allocate (F12_time_list(1))
        allocate (f12_value(1))
      endif

      if (trim(data_source)      == 'icrccm') then
        rf12   = rf12_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rf12   = rf12_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rf12   = rf12_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rf12   = rf12_ipcc_98

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(f12_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  rf12
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired cfc input file is not present', FATAL)
          endif
        else
          gas_name = 'f12 '
          call read_gas_timeseries (gas_name, f12_value,   &
                                    F12_time_list, time_varying_f12, &
                                    f12_dataset_entry, rf12)
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart f12 values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rf12
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f12 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rf12
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f12 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of f12 is obtained
!    from the namelist variable f12_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rf12 = f12_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for f12', FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rf12 < f12_floor) then
        call error_mesg ('radiative_gases_mod', &
              'base f12 mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rf12 > f12_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base f12 mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------




end subroutine define_f12




!#####################################################################
! <SUBROUTINE NAME="define_f113">
!  <OVERVIEW>
!   Subroutine that provides initial values for f113 mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_f113 provides initial values for f113 mixing ratio. if f113
!    is fixed in time, the value is given by the namelist specification.
!    if f113 is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_f113 (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define f113 initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_f113 (data_source) 

!---------------------------------------------------------------------
!    define_f113 provides initial values for f113 mixing ratio. if f113
!    is fixed in time, the value is given by the namelist specification.
!    if f113 is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define f113 initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rf113_icrccm  = 1.00000E-09
      real       ::  rf113_ipcc_80 = 2.31400E-11
      real       ::  rf113_ipcc_92 = 8.20000E-11
      real       ::  rf113_ipcc_98 = 8.58100E-11




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial f113 mixing ratios to be used.
!    'icrccm'     --> rf113_icrccm
!    'ipcc80'     --> rf113_ipcc_80
!    'ipcc92'     --> rf113_ipcc_92
!    'ipcc98'     --> rf113_ipcc_98
!    'input'      --> file INPUT/id1cfc, record 3
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(f113_specification_type) /= 'time_series') then
        allocate (F113_time_list(1))
        allocate (f113_value(1))
      endif

      if (trim(data_source)      == 'icrccm') then
        rf113   = rf113_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rf113   = rf113_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rf113   = rf113_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rf113   = rf113_ipcc_98

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(f113_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  rf113
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired f113 input file is not present', FATAL)
          endif
        else
          gas_name = 'f113'
          call read_gas_timeseries (gas_name, f113_value,   &
                                  F113_time_list, time_varying_f113, &
                                  f113_dataset_entry, rf113 )
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart f113 values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rf113
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f113 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rf113
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f113 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of f113 is obtained
!    from the namelist variable f113_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rf113 = f113_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for f113', FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rf113 < f113_floor) then
        call error_mesg ('radiative_gases_mod', &
              'base f113 mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rf113 > f113_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base f113 mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------




end subroutine define_f113



!#####################################################################
! <SUBROUTINE NAME="define_f22">
!  <OVERVIEW>
!   Subroutine that provides initial values for f22 mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_f22 provides initial values for f22 mixing ratio. if f22
!    is fixed in time, the value is given by the namelist specification.
!    if f22 is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_f22 (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define f22 initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_f22 (data_source) 

!---------------------------------------------------------------------
!    define_f22 provides initial values for f22 mixing ratio. if f22
!    is fixed in time, the value is given by the namelist specification.
!    if f22 is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define f22 initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rf22_icrccm   = 1.00000E-09
      real       ::  rf22_ipcc_80  = 6.20200E-11
      real       ::  rf22_ipcc_92  = 1.05000E-10
      real       ::  rf22_ipcc_98  = 1.26520E-10




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial f22 mixing ratios to be used.
!    'icrccm'     --> rf22_icrccm
!    'ipcc80'     --> rf22_ipcc_80
!    'ipcc92'     --> rf22_ipcc_92
!    'ipcc98'     --> rf22_ipcc_98
!    'input'      --> file INPUT/id1cfc, record 4
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(f22_specification_type) /= 'time_series') then
        allocate (F22_time_list(1))
        allocate (f22_value(1))
      endif

      if (trim(data_source)      == 'icrccm') then
        rf22   = rf22_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rf22   = rf22_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rf22   = rf22_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rf22   = rf22_ipcc_98

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(f22_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  
            read (inrad, FMT = '(5e18.10)')  rf22
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired cfc input file is not present', FATAL)
          endif
        else
          gas_name = 'f22 '
          call read_gas_timeseries (gas_name, f22_value,  &
                                    F22_time_list, time_varying_f22, &
                                    f22_dataset_entry, rf22)
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart f22 values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rf22
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f22 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1cfc') ) then
            inrad = open_namelist_file ('INPUT/id1cfc')
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') 
            read (inrad, FMT = '(5e18.10)') rf22
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor f22 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of f22 is obtained
!    from the namelist variable f22_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rf22 = f22_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for f22', FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rf22 < f22_floor) then
        call error_mesg ('radiative_gases_mod', &
              'base f22 mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rf22 > f22_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base f22 mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------




end subroutine define_f22



!#####################################################################
! <SUBROUTINE NAME="define_co2">
!  <OVERVIEW>
!   Subroutine that provides initial values for co2 mixing ratio.
!  </OVERVIEW>
!  <DESCRIPTION>
!    define_co2 provides initial values for co2 mixing ratio. if co2
!    is fixed in time, the value is given by the namelist specification.
!    if co2 is time-varying, the values are obtained from either a
!    restart or input data file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_co2 (data_source) 
!  </TEMPLATE>
!  <IN NAME="data_source" TYPE="character">
!   character string defining source to use to define co2 initial values
!  </IN>
! </SUBROUTINE>
!
subroutine define_co2 (data_source) 

!---------------------------------------------------------------------
!    define_co2 provides initial values for co2 mixing ratio. if co2
!    is fixed in time, the value is given by the namelist specification.
!    if co2 is time-varying, the values are obtained from either a
!    restart or input data file.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*), intent(in)    ::  data_source
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       data_source     character string defining source to use to
!                       define co2 initial values
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:
!
!---------------------------------------------------------------------
!    initial trace gas volume mixing ratios in (no./no.) from various
!    sources.
!---------------------------------------------------------------------
      real       ::  rco2_icrccm   = 3.00000E-04
      real       ::  rco2_ipcc_92  = 3.56000E-04
      real       ::  rco2_ipcc_80  = 3.37320E-04
      real       ::  rco2_ipcc_98  = 3.69400E-04
      real       ::  rco2_330ppm   = 3.30000E-04
      real       ::  rco2_660ppm   = 6.60000E-04
      real       ::  rco2_720ppm   = 7.20000E-04




      integer    :: inrad   ! unit number for i/o

character(len=8)     :: gas_name ! name associated with current
                                 ! gas being processed

!---------------------------------------------------------------------
!    define initial co2 mixing ratios to be used.
!    'icrccm'     --> rco2_icrccm
!    'ipcc80'     --> rco2_ipcc_80
!    'ipcc92'     --> rco2_ipcc_92
!    'ipcc98'     --> rco2_ipcc_98
!    '330ppm'     --> rco2_330ppm 
!    '660ppm'     --> rco2_660ppm 
!    'input'      --> file INPUT/id1co2, record 2
!    'restart'    --> values read from restart file
!    'prescribed' --> from restart file; if restart not present, 
!                     from input file
!    'predicted'  --> from restart file; if restart not present, 
!                     from input file
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if specification_type is 'base_and_trend', allocate length (1)
!    arrays to hold the base_time and base_value.
!---------------------------------------------------------------------
      if (trim(co2_specification_type) /= 'time_series') then
        allocate (Co2_time_list(1))
        allocate (co2_value(1))
      endif

      if (trim(data_source)      == 'icrccm') then
        rco2   = rco2_icrccm

      else if (trim(data_source) == 'ipcc_80') then
        rco2   = rco2_ipcc_80

      else if (trim(data_source) == 'ipcc_92') then
        rco2   = rco2_ipcc_92  

      else if (trim(data_source) == 'ipcc_98') then
        rco2   = rco2_ipcc_98

      else if (trim(data_source) == '330ppm') then
        rco2   = rco2_330ppm

      else if (trim(data_source) == '660ppm') then
        rco2   = rco2_660ppm

      else if (trim(data_source) == '720ppm') then
        rco2   = rco2_720ppm

!--------------------------------------------------------------------
!    if data_source is an input file, determine if it is present. if so,
!    open and read.  if not present, write an error message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'input') then
        if (trim(co2_specification_type) /= 'time_series') then
          if (file_exist ('INPUT/id1co2') ) then
            inrad = open_namelist_file ('INPUT/id1co2')
            read (inrad, FMT = '(5e18.10)')  rco2
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
                   'desired co2 input file is not present', FATAL)
          endif
        else
          gas_name = 'co2 '
          call read_gas_timeseries (gas_name, co2_value, &
                                    Co2_time_list, time_varying_co2, &
                                    co2_dataset_entry, rco2)
        endif

!--------------------------------------------------------------------
!    if data_source is a restart file and it is present, the value to be
!    used has been previously read. if not present, write an error 
!    message and stop.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'restart') then
        if (.not. restart_present ) then
          call error_mesg ( 'radiative_gases_mod', &
           'cannot use restart co2 values without a restart file', &
                                  FATAL)
        endif

!--------------------------------------------------------------------
!    if data_source is 'prescribed' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'prescribed') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1co2') ) then
            inrad = open_namelist_file ('INPUT/id1co2')
            read (inrad, FMT = '(5e18.10)') rco2
            call close_file (inrad)
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor co2 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"prescribed" ', FATAL)
          endif
        endif

!--------------------------------------------------------------------
!    if data_source is 'predicted' and a restart file is present, the 
!    value to be used has been previously read. if a restart file is
!    not present, check for an input file. if it is present, read the
!    file; if not, write an error message and stop. set the time_vary-
!    ing flag to .true.
!--------------------------------------------------------------------
      else if (trim(data_source) == 'predicted') then
        if (.not. restart_present) then
          if (file_exist ('INPUT/id1co2') ) then
            inrad = open_namelist_file ('INPUT/id1co2')
            read (inrad, FMT = '(5e18.10)') rco2
            call close_file (inrad)
            co2_for_last_tf_calc = rco2
          else
            call error_mesg ( 'radiative_gases_mod', &
              'neither restart nor co2 input file is present. one '//&
          'of these is required when the data_source is  '//&
          '"predicted" ', FATAL)
          endif
        endif

!-------------------------------------------------------------------
!    when the data_source is 'namelist', the value of co2 is obtained
!    from the namelist variable co2_base_value.
!-------------------------------------------------------------------
      else if (trim(data_source) == 'namelist') then
        rco2 = co2_base_value

!--------------------------------------------------------------------
!    write an error message if the data_source is invalid.
!--------------------------------------------------------------------
      else
        call error_mesg ('radiative_gases_mod', &
         'no valid data source was specified for co2 input', FATAL)
      endif

!---------------------------------------------------------------------
!    be sure value is within range of acceptable values. a later check
!    in lw_gases_stdtf_mod will further limit values to be those for
!    which tfs may be determined.
!---------------------------------------------------------------------
      if (rco2 < co2_floor) then
        call error_mesg ('radiative_gases_mod', &
              'base co2 mixing ratio LOWER THAN FLOOR value', FATAL)
      endif
      if (rco2 > co2_ceiling) then
        call error_mesg ('radiative_gases_mod', &
              ' base co2 mixing ratio HIGHER THAN CEILING value', FATAL)
      endif

!---------------------------------------------------------------------


end subroutine define_co2


!#####################################################################
! <SUBROUTINE NAME="read_gas_timeseries">
!  <OVERVIEW>
!   Subroutine that reads in data values for well-mixed greenhouse
!   gases at specified times.
!  </OVERVIEW>
!  <DESCRIPTION>
!    read_gas_timeseries obtains global values for well-mixed
!    greenhouse gases from observed data sources for gas xxx.
!     the data are obtained from an input file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call read_gas_timeseries (gas, gas_value, Gas_time_list, rgas)
!  </TEMPLATE>
!  <IN NAME="gas">
!   name associated with the current gas
!  </IN>
!  <INOUT NAME="gas_value">
!   array of volume mixing ratio of gas 'gas' for each time in 
!   Gas_time_list gas_year. [no. /no. ]
!  </INOUT>
!  <INOUT NAME="Gas_time_list">
!   list of times (time_type) associated with the gas_value data 
!  </INOUT>
!  <OUT NAME="rgas">
!   gas volume mixing ratio at the start of the timeseries
!  </OUT>
! </SUBROUTINE>
!
subroutine read_gas_timeseries (gas, gas_value, Gas_time_list,   &
                                time_varying_gas, gas_dataset_entry, &
                                rgas)
 
!--------------------------------------------------------------------
!    read_gas_timeseries obtains global values for well-mixed
!    greenhouse gases from observed data sources for gas xxx.
!     the data are obtained from an input file.
!--------------------------------------------------------------------

character(len=*),                   intent(in)    :: gas
real, dimension(:),                 pointer       :: gas_value
type(time_type), dimension(:),      pointer       :: Gas_time_list
logical,                            intent(in)    :: time_varying_gas
integer,dimension(:),               intent(in)    :: gas_dataset_entry
real,                               intent(out)   :: rgas

!--------------------------------------------------------------------
!
!  intent(in) variables:
!
!      gas     name associated with the current gas
!
!   pointer variables:
!
!      gas_value
!      Gas_time_list
!
!   intent(out) variables:
!
!      rgas
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    local variables :

      real,dimension(:), allocatable :: input_time
      type(time_type)                :: Year_t, Extra_time
      character(len=64)              :: file_name

      real       :: extra_seconds
      integer    :: inrad   ! unit number for i/o
      integer    :: i       ! do loop index
      integer    :: year, diy, yr, mo, dy, hr, mn, sc
      integer    :: series_length
      integer    :: index1, index2
      real       :: percent_of_period
      type(time_type) :: Gas_entry

!-------------------------------------------------------------------
!    define the gas_name which is currently being processed.
!-------------------------------------------------------------------
      file_name = 'INPUT/' // trim(gas) //'_gblannualdata'

!--------------------------------------------------------------------
!    process the gas timeseries file.
!--------------------------------------------------------------------
      if (file_exist (file_name) ) then
        inrad = open_namelist_file (file_name)

!--------------------------------------------------------------------
!    read the number of data points in the timeseries.
!--------------------------------------------------------------------
        read (inrad, FMT = '(i12)')  series_length

!----------------------------------------------------------------------
!    allocate gas_value, input_time and Gas_time_list arrays.
!----------------------------------------------------------------------
        allocate (gas_value(series_length))
        allocate (input_time(series_length))
        allocate (Gas_time_list(series_length))

!---------------------------------------------------------------------
!    read the timeseries data, time and then gas value.
!---------------------------------------------------------------------
        do i=1,series_length
          read (inrad, FMT = '(2f12.4)') input_time(i), &
                                         gas_value(i)
        end do

!---------------------------------------------------------------------
!    convert from input units  to [ no. / no. ].
!---------------------------------------------------------------------
        if ( trim(gas) == 'co2') then
          gas_value = 1.0e-6*gas_value
        else if (trim(gas) == 'ch4' .or. &
                 trim(gas) == 'n2o' ) then   
          gas_value = 1.0e-9*gas_value
        else if (trim(gas) == 'f11' .or. &
                 trim(gas) == 'f12' .or. &   
                 trim(gas) == 'f113' .or. &   
                 trim(gas) == 'f22' ) then   
          gas_value = 1.0e-12*gas_value
        endif

!---------------------------------------------------------------------
!    close the input file.
!---------------------------------------------------------------------
        call close_file (inrad)

!---------------------------------------------------------------------
!    convert the time stamps of the series to time_type variables.     
!---------------------------------------------------------------------
        if (verbose > 3) then
          if ( mpp_pe() == mpp_root_pe() ) then
            print *, 'time series entries for ' // trim (gas)
          endif
        endif
        do i=1,series_length
          year = INT(input_time(i))
          Year_t = set_date (year,1,1,0,0,0)
          diy = days_in_year (Year_t)
          extra_seconds = (input_time(i) - year)*diy*86400. 
          Extra_time=    set_time(NINT(extra_seconds), 0)
          Gas_time_list(i)    = Year_t + Extra_time
          call get_date (Gas_time_list(i), yr, mo, dy, hr, mn, sc)
          if (verbose > 3) then
            if ( mpp_pe() == mpp_root_pe() ) then
              print *, i, yr, mo, dy, hr, mn, sc, gas_value(i)
            endif
          endif
        end do

!--------------------------------------------------------------------
!    if the gas is not time-varying, its value must be defined here.
!--------------------------------------------------------------------
        if (.not. time_varying_gas) then

!--------------------------------------------------------------------
!    if a dataset entry time has not been specified, send an error
!    message.
!--------------------------------------------------------------------
          if (gas_dataset_entry(1) == 1 .and. &
              gas_dataset_entry(2) == 1 .and. &
              gas_dataset_entry(3) == 1 .and. &
              gas_dataset_entry(4) == 0 .and. &
              gas_dataset_entry(5) == 0 .and. &
              gas_dataset_entry(6) == 0 ) then   
            call error_mesg ('radiative_gases_mod', &
             'timeseries selected but no valid datset_entry time &
                             &provided for ' // trim(gas) , FATAL)

!---------------------------------------------------------------------
!    convert the dataset entry that is provided to a time_type variable,
!    and determine the timeseries value that corresponds.
!---------------------------------------------------------------------
          else
            Gas_entry = set_date (gas_dataset_entry(1), &
                                  gas_dataset_entry(2), &
                                  gas_dataset_entry(3), &
                                  gas_dataset_entry(4), &
                                  gas_dataset_entry(5), &
                                  gas_dataset_entry(6))     
            call time_interp (Gas_entry, Gas_time_list,  &
                              percent_of_period, index1, index2)
            rgas = gas_value(index1) + percent_of_period*  &
                   (gas_value(index2) - gas_value(index1))
            call error_mesg ( 'radiative_gases_mod', &
                   'PROCESSING TIMESERIES FOR ' // trim(gas), NOTE)
            call print_date (Gas_entry , str='Gas value is taken from &
                                     &timeseries at time:')
            if (mpp_pe() == mpp_root_pe() ) then
              print *, trim(gas) // ' value is ', rgas
            endif
          endif

!---------------------------------------------------------------------
!    if gas is time_varying, define the initial gas mixing ratio to be 
!    the first value in the timeseries. this value will be replaced 
!    before it is used.
!---------------------------------------------------------------------
        else
          rgas = gas_value(1)
        endif

!---------------------------------------------------------------------
!    if the requested input file is not present, write an error message.
!---------------------------------------------------------------------
      else
        call error_mesg ( 'radiative_gases_mod', &
             'desired ' // file_name // ' input file is not present', &
                                                                FATAL)
      endif

!--------------------------------------------------------------------
 


end subroutine read_gas_timeseries
 

!#####################################################################
! <SUBROUTINE NAME="define_gas_amount">
!  <OVERVIEW>
!   define_gas_amount defines the values of the gas mixing ratio needed !   at the current time, when the gas is varying with time.
!  </OVERVIEW>
!  <DESCRIPTION>
!   define_gas_amount performs the following actions:
!     1) checks for the presence of needed optional arguments;
!     2) determines how long the gas has been varying with time;
!     3) calculates values for the gas mixing ratio at the current time;
!     4) constrains calculated gas values to lie between the
!        specified floor and ceiling;
!
!   if transmission functions are calculated for the gas, then:
!     1) it is determined if the gas value used when the tfs were last
!        calculated is needed;
!     2) if the gas does not use its current value at the time when tfs
!        are calculated, the offset from the current time to the time
!        used for tfs is obtained;
!     3) if the gas value used when the tfs were last calculated is 
!        needed, it is calculated along with the time offset of that
!        time from the present time;
!     4) if the gas value at the time when the tfs are next to be cal-
!        culated is needed, it is calculated;
!     5) gas values relevant at the time when tfs are next to be 
!        calculated are constrained to lie between the specified floor 
!        and ceiling;
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_gas_amount      &
!        (gas, Rad_time, gas_specification_type, gas_variation_type, &
!         gas_floor, gas_ceiling, rgas, gas_uses_tfs, gas_change_rate, &
!         rrvgas, Gas_time_list, gas_value, gas_tf_calc_intrvl,  &
!         gas_tf_time_displacement, calc_gas_tfs_on_first_step,  &
!         use_current_gas_for_tf, gas_tf_offset, gas_for_last_tf_calc, &
!         gas_for_next_tf_calc, define_gas_for_last_tf_calc)
!  </TEMPLATE>
!  <IN NAME="gas">
!   character string associated with the gas being processed
!  </IN>
!  <IN NAME="Rad_time">
!   time at which radiation calculation is to apply
!  </IN>
!  <IN NAME="gas_specification_type">
!   indicator as to the form of time variation of vol. mixing ratio;
!   either 'base_and_trend' or 'time_series'.
!  </IN>
!  <IN NAME="gas_variation_type">
!   indicator as to the form of time variation of the vol. mixing ratio
!   of gas; either 'linear' or 'logarithmic'
!  </IN>
!  <IN NAME="gas_floor">
!   smallest value allowed for gas xxx vol. mixing ratio [ no. / no. ]
!  </IN>
!  <IN NAME="gas_ceiling">
!   largest value allowed for gas xxx vol. mixing ratio [ no. / no. ]
!  </IN>
!  <IN NAME="rgas">
!   initially specified gas mixing ratio [ no. / no. ]
!  </IN>
!  <IN NAME="gas_uses_tfs">
!   this gas has transmission functions associated with it ?
!  </IN>
!  <INOUT NAME="gas_change_rate">
!   time rate of change of gas xxx vol. mixing ratio
!   [  1 +/- % per year ]
!  </INOUT>
!  <INOUT NAME="rrvgas">
!   gas mixing ratio at current time [ no. / no. ]
!  </INOUT>
!  <IN NAME="Gas_time_list">
!   list of times in gas timeseries [ time_type ]
!  </IN>
!  <IN NAME="gas_value">
!   gas concentrations [ no. / no. ] associated with the times 
!   in Gas_time_list
!  </IN>
!  <IN NAME="gas_tf_calc_intrvl">
!   time interval between calculating gas tfs  [ hours ]
!   OPTIONAL: present only when the gas has tfs associated with it
!  </IN>
!  <IN NAME="gas_tf_time_displacement">
!   time displacement from present to the time at which gas values are
!   to be used in the calculation of tfs. may be <0, ==0, or > 0.
!   [ hours ]
!   OPTIONAL: present only when the gas has tfs associated with it, only
!   used when calc_gas_tfs_on_first_step is .true.
!  </IN>
!  <IN NAME="calc_gas_tfs_on_first_step">
!   if true, tfs are calculated ONLY on the first time step of a run,
!   using gas mixing ratios valid gas_tf_time_displacement hours from 
!   the start time
!   OPTIONAL: present only when the gas has tfs associated with it
!  </IN>
!  <IN NAME="use_current_gas_for_tf">
!   if true, the gas  mixing ratio at the current time is used to cal-
!   culate the gas tfs
!   OPTIONAL: present only when the gas has tfs associated with it
!  </IN>
!  <OUT NAME = "gas_tf_offset">
!   time between last tf calculation and present [ hours ]
!   OPTIONAL: present only when the gas has tfs associated with it
!  </OUT>
!  <OUT NAME = "gas_for_last_tf_calc">
!   value of gas mixing ratio used in last tf calculation [ no. / no. ]
!   OPTIONAL: present only when the gas has tfs associated with it
!  </OUT>
!  <OUT NAME = "gas_for_next_tf_calc">
!   value of gas mixing ratio to be used in next tf calculation 
!   OPTIONAL: present only when the gas has tfs associated with it
!   [ no. / no. ]
!  </OUT>
!  <INOUT NAME = "define_gas_for_last_tf_calc">
!   logical indicating if the gas value used for the last tf calculation
!   must be obtained
!  </INOUT>
!

!<PUBLICROUTINE>
!
!NOTE: THIS IS A PRIVATE SUBROUTINE>
!
subroutine define_gas_amount      &
         (gas, Rad_time, gas_specification_type,  &
!         negative_offset_gas, Gas_offset, gas_variation_type, &
                                           gas_variation_type, &
          gas_floor, gas_ceiling, rgas, gas_uses_tfs, gas_change_rate, &
          rrvgas, Gas_time_list, gas_value, gas_tf_calc_intrvl,  &
          gas_tf_time_displacement, calc_gas_tfs_on_first_step,  &
          calc_gas_tfs_monthly, &
          use_current_gas_for_tf, gas_tf_offset, gas_for_last_tf_calc, &
          gas_for_next_tf_calc,  gas_tfs_needed,  &
          define_gas_for_last_tf_calc)

!--------------------------------------------------------------------
character(len=*),              intent(in)    :: gas
type(time_type),               intent(in)    :: Rad_time
character(len=*),              intent(in)    :: gas_specification_type,&
                                                gas_variation_type
real,                          intent(in)    :: gas_floor, gas_ceiling,&
                                                rgas
logical,                       intent(in)    :: gas_uses_tfs  
!logical,                       intent(in)    :: negative_offset_gas  
real,                          intent(inout) :: gas_change_rate, rrvgas

type(time_type), dimension(:), intent(in)    :: Gas_time_list
!type(time_type),               intent(inout) :: Gas_offset      
real, dimension(:),            intent(in)    :: gas_value
real,               intent(in),    optional  :: gas_tf_calc_intrvl,    &
                                                gas_tf_time_displacement
logical,            intent(in),    optional  ::   &
                                           gas_tfs_needed, &
                                          calc_gas_tfs_on_first_step, &
                                          calc_gas_tfs_monthly,  &
                                          use_current_gas_for_tf 
real,               intent(out),   optional  :: gas_tf_offset, &
                                                gas_for_last_tf_calc, &
                                                gas_for_next_tf_calc
logical,            intent(inout), optional  :: &  
                                          define_gas_for_last_tf_calc

!---------------------------------------------------------------------
!  local variables:

     type(time_type)    :: Gas_yrs   
     integer            :: days, seconds
     real               :: years_of_gas, years_of_gas_till_next
     integer            :: days2, seconds2
     integer            :: days3, seconds3
     real               :: mean_days, calc_time
     character(len=16)  :: chvers7, chvers8, chvers9
     integer            :: alarm, minutes_from_start

     real               :: percent_of_period
     type(time_type)    :: Tf_offset, Tf_calc_intrvl 
     real               :: rseconds3
     integer            :: index1, index2
     integer            :: yr, mo, dy, hr, mn, sc
     integer            :: days7, seconds7
     type(time_type)    :: Tf_displ, First_of_month, Gas_tf_next, &
                           Time_left
!---------------------------------------------------------------------
!  local variables:
!    
!     Gas_yrs                 time interval from start of time variation
!                             until current time [ time_type ]
!     days                    days component of Gas_yrs  [ days ]   
!     seconds                 seconds component of Gas_yrs  [ seconds ]
!     minutes_from_start      time interval from start of time variation
!                             until current time [ minutes ]
!     years_of_gas            time interval from start of time variation
!                             until current time [ years ]
!     years_of_gas_till_next  time interval from start of time variation
!                             until next tf calculation [ years ]
!     days2                   days component of the mean length of year
!                             time_type variable [ days ]
!     seconds2                seconds component of the mean length of 
!                             year time_type variable [ seconds ]
!     mean_days               average number of days in a year [ days ]
!     calc_time               time at which tfs were last calculated
!                             [ years from start of gas time variation ]
!     chvers7                 character variable used to output model
!                             variables through error_mesg interface
!     chvers8                 character variable used to output model
!                             variables through error_mesg interface
!     chvers9                 character variable used to output model
!                             variables through error_mesg interface
!     chvers11                character variable used to output model
!                             variables through error_mesg interface
!     alarm                   time since last tf calculation until
!                             current time [ minutes ]              
!
!--------------------------------------------------------------------

!     type(time_type)  :: Gas_time  ! time for which gas data is desired

!</PUBLICROUTINE>

!--------------------------------------------------------------------
!    define the time for which gas data is desired.
!--------------------------------------------------------------------
!     if (negative_offset_gas) then
!       Gas_time = Rad_time - Gas_offset
!     else
!       Gas_time = Rad_time + Gas_offset
!     endif

!---------------------------------------------------------------------
!    if this gas calculates transmission functions, make sure all 
!    optional arguments needed when tfs are in use are present.
!---------------------------------------------------------------------
      if (gas_uses_tfs) then
        if (present( gas_tf_calc_intrvl) .and. &
            present( gas_tf_time_displacement) .and. &
            present( gas_tf_offset) .and. &
            present( gas_for_last_tf_calc) .and. &
            present( gas_for_next_tf_calc) .and. &
            present( calc_gas_tfs_on_first_step) .and. &
            present( calc_gas_tfs_monthly) .and. &
            present( define_gas_for_last_tf_calc) .and. &
            present( use_current_gas_for_tf) ) then 
        else
          call error_mesg ('radiative_gases_mod', &
          'necessary optional arguments for '//trim(gas)//' call to&
           & subroutine define_gas_amount are not present', FATAL)
        endif
      endif

!--------------------------------------------------------------------
!    define the mean length of the year in units of days. this will
!    be a function of the calendar being used. this will be the unit
!    used to define how long gas variation has been occurring 
!    (years_of_gas), not exactly equivalent to calendar years.
!--------------------------------------------------------------------
      call get_time (length_of_year(), seconds2, days2)
      mean_days = days2 + seconds2/86400.

!---------------------------------------------------------------------
!    define how long the gas variation has been occurring, expressed
!    as a time_type, the components of the time_type and then in units
!    of gas-years.
!---------------------------------------------------------------------
      Gas_yrs = Rad_time - Gas_time_list(1)
!     Gas_yrs = Gas_time - Gas_time_list(1)
      call get_time (Gas_yrs, seconds, days)
      years_of_gas = (days + seconds/86400.)/mean_days

!---------------------------------------------------------------------
!    define the current value of gas. this value will be used in sw
!    calculations. the following expressions are available:
!      base_and_trend, logarithmic: 
!                    g(t) = g(t0)*(gas_change_rate)**(t-t0)
!      base_and_trend, linear:   
!                    g(t) = g(t0)*(1.0 + (t-t0)*(gas_change_rate - 1.0)
!    where t0 is the base time.
!---------------------------------------------------------------------
      if (trim(gas_specification_type) =='base_and_trend') then
        if (trim(gas_variation_type) == 'logarithmic') then
          if (gas_change_rate /=0.0) then
            rrvgas = rgas* exp(alog(gas_change_rate)*years_of_gas)
          else
            rrvgas = rgas
          endif
        else 
          rrvgas = rgas*(1.0 + years_of_gas*(gas_change_rate-1.0))
        endif

      else if (trim(gas_specification_type) == 'time_series') then
        call time_interp (Rad_time, Gas_time_list,   &
!       call time_interp (Gas_time, Gas_time_list,   &
                          percent_of_period, index1, index2)
        rrvgas   = gas_value(index1) + percent_of_period*  &
                   (gas_value(index2) - gas_value(index1))
      endif

!---------------------------------------------------------------------
!    be sure that newly calculated current gas mixing ratio remains 
!    within the floor / ceiling range. if either is exceeded, reset the
!    gas amount to the floor/ ceiling value.
!---------------------------------------------------------------------
      if (rrvgas < gas_floor) then
        if (verbose >= 1) then
          if (.not. printed_current_floor_msg) then
            write (chvers7, '(3pe15.7)') rrvgas
            write (chvers8, '(3pe15.7)') gas_floor
            write (chvers9, '(f9.5)') years_of_gas
            call error_mesg ('radiative_gases_mod', &
           'calculated '//trim(gas)//' mixing ratio ('//chvers7//  &
           ') LOWER THAN FLOOR ('//chvers8//') after'//chvers9//'years&
           & of '//trim(gas)// ' variation; reset to floor value ',  &
                                                                  NOTE)
            printed_current_floor_msg = .true.
          endif
        endif ! (verbose)
        rrvgas = gas_floor
      endif
      if (rrvgas > gas_ceiling) then
        if (verbose >= 1) then
          if (.not. printed_current_ceiling_msg) then
            write (chvers7, '(3pe15.7)') rrvgas
            write (chvers8, '(3pe15.7)') gas_ceiling
            write (chvers9, '(f 9.5)') years_of_gas
            call error_mesg ('radiative_gases_mod', &
           'calculated '//trim(gas)// ' mixing ratio ('//chvers7// &
           ') HIGHER THAN CEILING ('//chvers8//') after'//chvers9// &
           'years of '//trim(gas)// ' variation; reset to ceiling &
                                                        &value ', NOTE)
            printed_current_ceiling_msg = .true.
          endif
        endif ! (verbose)
        rrvgas = gas_ceiling
      endif

!---------------------------------------------------------------------
!    execute the following code if tfs are to be calculated for this 
!    gas.
!---------------------------------------------------------------------
      if (gas_uses_tfs) then
!     if (gas_uses_tfs .and. gas_tfs_needed) then
        if (gas_tfs_needed) then

!---------------------------------------------------------------------
!    if this gas uses tfs, determine if the gas mixing ratio used the
!    last time tfs were calculated is needed. in general it is  
!    needed if it was not read in from the restart file (a non-
!    current version), and gas time variation has already begun. 
!    however if time variation has not yet begun (the usual case if 
!    using an old restart) or if the tfs are to be calculated on the 
!    first step of the job, it will not be needed, and the flag is 
!    reset to so indicate. 
!---------------------------------------------------------------------
        if (years_of_gas == 0.0 .or. calc_gas_tfs_on_first_step .or. &
             calc_gas_tfs_monthly) then
          define_gas_for_last_tf_calc =.false.
        endif

!--------------------------------------------------------------------
!    define the time to which the gas mixing ratio used in the last
!    calculation corresponded. 
!--------------------------------------------------------------------
        if (define_gas_for_last_tf_calc) then
          calc_time = years_of_gas - MOD (years_of_gas, &
                      gas_tf_calc_intrvl/(24.0*mean_days))
          if (verbose >= 4 .and. mpp_pe() == mpp_root_pe() ) then
            print *, 'last tf:calc_time, years_of_gas', calc_time, &
                     years_of_gas
          endif

!--------------------------------------------------------------------
!    if the value of the gas mixing ratio used for the last tf calcul-
!    ation is needed, define it and the time to which it applies. after
!    calculation, set the flag indicating its need to .false.
!--------------------------------------------------------------------
          if (trim(gas_specification_type) =='base_and_trend') then
            if (trim(gas_variation_type) == 'logarithmic') then
              gas_for_last_tf_calc = rgas*exp(alog(gas_change_rate)* &
                                              calc_time)
              gas_tf_offset = (calc_time - years_of_gas)*24.0*mean_days
            else 
              gas_for_last_tf_calc  = rgas*(1.0 + calc_time*  &
                                      (gas_change_rate-1.0))
              gas_tf_offset = (calc_time - years_of_gas)*24.0*mean_days
            endif
          else if (trim(gas_specification_type) == 'time_series') then
            Tf_calc_intrvl = set_time (NINT(calc_time*24.0*  &
                                            mean_days*3600.), 0)
            call time_interp (Rad_time - Tf_calc_intrvl, Gas_time_list, &
!           call time_interp (Gas_time - Tf_calc_intrvl, Gas_time_list, &
                              percent_of_period, index1, index2)
            gas_for_last_tf_calc   = gas_value(index1) +    &
                                     percent_of_period*  &
                                     (gas_value(index2) -   &
                                      gas_value(index1))
            if (mpp_pe() == mpp_root_pe() )then
              print *, 'gas_for_last_tf_calc, , *3,  &
                       &index1, index2, days3, seconds3, % ',   &
                         gas_for_last_tf_calc,   &
                         index1, index2, percent_of_period
            endif
            gas_tf_offset = (calc_time - years_of_gas)*24.0* mean_days
          endif
          define_gas_for_last_tf_calc = .false.
        endif !(define_gas_for_last_tf_calc) 

!---------------------------------------------------------------------
!    if tfs are calculated using other than the gas values at the 
!    current time, define the time that has elapsed since the beginning
!    of variation, and determine if this is a time at which tfs are
!    due to be calculated (alarm = 0).
!---------------------------------------------------------------------
        if (.not. use_current_gas_for_tf) then
          minutes_from_start = INT(days*1440.0 + real(seconds)/60.)
          if (gas_tf_calc_intrvl /= 0.0) then
            alarm = MOD(minutes_from_start,   &
                        INT(gas_tf_calc_intrvl*60.0))
          else
            alarm = 0
          endif

!---------------------------------------------------------------------
!    if alarm is 0 (indicating this is a step on which to calculate the
!    tfs), or if the option has been chosen to always and only calculate
!    tfs on the first step of a job, define the time to use to obtain 
!    the gas mixing ratio used to calculate those tfs.
!---------------------------------------------------------------------
          if (alarm == 0 .or. calc_gas_tfs_on_first_step .or. &
             calc_gas_tfs_monthly) then

!--------------------------------------------------------------------
!    if calc_gas_tfs_on_first_step is true, the gas mixing ratio at a
!    time gas_tf_time_displacement hours from now (plus, zero or minus 
!    allowed) will be used.
!--------------------------------------------------------------------
            if (calc_gas_tfs_on_first_step  ) then
              years_of_gas_till_next = years_of_gas +   &
                              gas_tf_time_displacement/(24.0*mean_days)
           else if (calc_gas_tfs_monthly) then
              call get_date (Rad_time, yr, mo, dy, hr, mn, sc)
              Tf_displ =   &
                      set_time(NINT(gas_tf_time_displacement*60*60), 0)
              First_of_month = set_date (yr, mo, 1, 0, 0, 0)
              Gas_tf_next =  First_of_month + Tf_displ
              if (Gas_tf_next > Rad_time) then
                Time_left = Gas_tf_next - Rad_time
                call get_time (Time_left, seconds7, days7)
                years_of_gas_till_next = years_of_gas + (days7 +   &
                                         seconds7/86400.)/mean_days
              else
                Time_left = Rad_time - Gas_tf_next
                call get_time (Time_left, seconds7, days7)
                years_of_gas_till_next = years_of_gas - (days7 +   &
                                         seconds7/86400.)/mean_days
!               years_of_gas_till_next = years_of_gas            
              endif
!--------------------------------------------------------------------
!    if alarm is 0, the gas mixing ratio at the mid point of the time
!    interval between this calculation time and the next is used.
!--------------------------------------------------------------------
            else if (alarm == 0 ) then   
              years_of_gas_till_next = years_of_gas +   &
                              0.5*(gas_tf_calc_intrvl)/(24.0*mean_days)
            endif

!--------------------------------------------------------------------
!    calculate the difference in time (hours) between current time and 
!    time used to define the gas mixing ratio used for the next tf
!    calculation.
!--------------------------------------------------------------------
            gas_tf_offset = (years_of_gas_till_next - years_of_gas)* &
                             24.0*mean_days

!--------------------------------------------------------------------
!    if the value of the gas mixing ratio to be used for the next tf 
!    calculation is needed, define it here. it will be needed if the
!    gas mixing ratio to be used in defining the tfs is not the
!    current value and either it is time to do the calculation or the
!    calculation is desired on the first step of the job.
!--------------------------------------------------------------------
            if (trim(gas_specification_type) =='base_and_trend') then
              if (trim(gas_variation_type) == 'logarithmic') then
                gas_for_next_tf_calc = rgas*exp(alog(gas_change_rate)*&
                                       years_of_gas_till_next)
              else 
                gas_for_next_tf_calc = rgas*(1.0 +   &
                                       years_of_gas_till_next*  &
                                       (gas_change_rate-1.0))
              endif
            else if (trim(gas_specification_type) == 'time_series') then
             if (calc_gas_tfs_monthly) then
               Tf_offset = Time_left
               if (gas_tf_offset > 0) then
                 call time_interp (Rad_time + Tf_offset, Gas_time_list,&


                                percent_of_period, index1, index2)
               else
                 call time_interp (Rad_time - Tf_offset, Gas_time_list,&
                                percent_of_period, index1, index2)
               endif
             else
               days3 = NINT(gas_tf_offset/24.0)
               rseconds3 = (gas_tf_offset - days3*24)*3600.0
               seconds3 = NINT(rseconds3)
               Tf_offset = set_time (seconds3, days3)
               call time_interp (Rad_time + Tf_offset, Gas_time_list,  &
                                percent_of_period, index1, index2)
              endif
              gas_for_next_tf_calc   = gas_value(index1) +    &
                                       percent_of_period*  &
                                       (gas_value(index2) -   &
                                        gas_value(index1))
            endif

!---------------------------------------------------------------------
!    if the current value is not being used, be sure that the gas mixing
!    ratio calculated for use when tfs are next calculated is within 
!    the floor / ceiling range. if either is exceeded, reset the gas 
!    amount to the floor/ ceiling value.
!---------------------------------------------------------------------
            if (gas_for_next_tf_calc < gas_floor) then
              if (verbose >= 1) then
                if (.not. printed_next_floor_msg) then
                  write (chvers7, '(3pe15.7)')  gas_for_next_tf_calc
                  write (chvers8, '(3pe15.7)') gas_floor
                  write (chvers9, '(f9.5)') years_of_gas_till_next
                  call error_mesg ('radiative_gases_mod', &    
                  'calculated '//trim(gas)// ' mixing ratio to be used&
                  & for tf calcs ('//chvers7//') LOWER  &
                  &THAN FLOOR ('//chvers8//') after'//chvers9//'years&
                  & of '//trim(gas)// ' variation; reset to floor  &
                                                         &value ', NOTE)
                  printed_next_floor_msg = .true.
                endif
              endif ! (verbose)
              gas_for_next_tf_calc = gas_floor
            endif
            if (gas_for_next_tf_calc > gas_ceiling) then
              if (verbose >= 1) then
                if (.not. printed_next_ceiling_msg) then
                  write (chvers7, '(3pe15.7)')   gas_for_next_tf_calc
                  write (chvers8, '(3pe15.7)') gas_ceiling
                  write (chvers9, '(f 9.5)') years_of_gas_till_next
                  call error_mesg ('radiative_gases_mod', &
                 'calculated '//trim(gas)// ' mixing ratio to be used&
                  & for tf calcs (' //chvers7//') HIGHER  &
                  &THAN CEILING ('//chvers8//') after'//chvers9//'years&
                  & of '//trim(gas)// ' variation; reset to ceiling &
                                                        &value ', NOTE)
                  printed_next_ceiling_msg = .true.
                endif
              endif ! (verbose)
              gas_for_next_tf_calc        = gas_ceiling
            endif
          else

!--------------------------------------------------------------------
!    set the value to be the current value. in this case it will not 
!    be used.
!--------------------------------------------------------------------
            gas_for_next_tf_calc = rrvgas
          endif

!---------------------------------------------------------------------
!    if the current value of the gas mixing ratio is to be used for the
!    next tf calculation, reset the values to the just-adjusted current
!    value rrvgas and set the time offset to 0.0.
!---------------------------------------------------------------------
        else ! (.not. use_current_gas_for_tf)
          gas_for_next_tf_calc = rrvgas
          gas_tf_offset = 0.0
        endif
 else ! (gas_tfs_needed)
          define_gas_for_last_tf_calc =.false.
          gas_for_next_tf_calc = rrvgas
          gas_tf_offset = 0.0
 endif ! (gas_tfs_needed)
      endif ! (gas_uses_tfs) 

!---------------------------------------------------------------------



end subroutine define_gas_amount 


! </SUBROUTINE>

!####################################################################
! <SUBROUTINE NAME="write_restart_radiative_gases">
!  <OVERVIEW>
!   Subroutine to write the radiative restart files
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to write the radiative restart files
!  </DESCRIPTION>
!  <TEMPLATE>
!   call write_restart_radiative_gases
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine write_restart_radiative_gases

!---------------------------------------------------------------------
!    write_restart_radiative_gases writes the radiative_gases.res file.
!---------------------------------------------------------------------

      integer    :: unit    ! unit number for i/o



!---------------------------------------------------------------------
!    open unit and write radiative gas restart file.
!---------------------------------------------------------------------
      if (mpp_pe() == mpp_root_pe() ) then
         call error_mesg ('radiative_gases_mod', 'Writing native formatted restart file: RESTART/radiative_gases.res', NOTE)
        unit = open_restart_file ('RESTART/radiative_gases.res',   &
                                   action= 'write')
        write (unit) restart_versions(size(restart_versions(:)))
        write (unit) rrvco2
        write (unit) rrvf11, rrvf12, rrvf113, rrvf22
        write (unit) rrvch4, rrvn2o
        write (unit) co2_for_last_tf_calc
        write (unit) ch4_for_last_tf_calc
        write (unit) n2o_for_last_tf_calc
        call close_file (unit)
      endif

!----------------------------------------------------------------------
      


end subroutine write_restart_radiative_gases

!####################################################################


                  end module radiative_gases_mod



                       module rad_output_file_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Module that provides subroutines to write radiation output to
!  history file
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!   shared modules:

use mpp_mod,           only: input_nml_file
use fms_mod,           only: open_namelist_file, fms_init, &
                             mpp_pe, mpp_root_pe, stdlog, &
                             file_exist, write_version_number, &
                             check_nml_error, error_mesg, &
                             FATAL, close_file
use time_manager_mod,  only: time_manager_init, time_type
use diag_manager_mod,  only: register_diag_field, diag_manager_init, &
                             send_data
use constants_mod,     only: constants_init, GRAV, WTMAIR, WTMOZONE

!  radiation package shared modules:

use rad_utilities_mod, only:  rad_utilities_init, radiative_gases_type,&
                              rad_output_type, cldrad_properties_type, &
                              cld_specification_type, atmos_input_type,&
                              Sw_control, aerosol_diagnostics_type, &
                              aerosol_type, aerosol_properties_type, &
                              surface_type, sw_output_type,  &
                              lw_output_type, Rad_control
use esfsw_parameters_mod, only : esfsw_parameters_init, Solar_spect

!--------------------------------------------------------------------

implicit none
private

!------------------------------------------------------------------
!    rad_output_file_mod writes an output file containing an assort-
!    ment of variables related to the sea_esf_rad radiation package.
!    this is an optionally-generated file, which may be used to sup-
!    plement the standard diagnostic model output files. NOTE THAT
!    THIS FILE IS GENERATED ONLY ON RADIATION TIMESTEPS, SO THAT WHEN 
!    SW FLUXES ARE BEING RENORMALIZED ON EACH PHYSICS STEP, VARIABLES 
!    IN THIS FILE RELATED TO SW RADIATION WILL NOT REFLECT THE EFFECTS 
!    OF THE RENORMALIZATION.
!------------------------------------------------------------------


!-------------------------------------------------------------------
!----------- version number for this module ------------------------

character(len=128)  :: version = &
'$Id: rad_output_file.F90,v 18.0.2.1.2.4 2010/09/20 17:54:12 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public   &
         rad_output_file_init, write_rad_output_file,   &
         rad_output_file_end

private   &

!   called from rad_output_file_init
        register_fields


!-------------------------------------------------------------------
!-------- namelist  ---------

logical :: write_data_file=.false.  ! data file to be written  ?


namelist  / rad_output_file_nml /  &
                                  write_data_file
     
!------------------------------------------------------------------
!----public data------


!------------------------------------------------------------------
!----private data------

!--------------------------------------------------------------------
!    DU_factor is Dobson units per (kg/m2). the first term is 
!    (avogadro's number/loeschmidt's number at STP = vol./kmol of an 
!    ideal gas at STP). second term = mol wt o3 . third term is units 
!    conversion. values are chosen from US Standard Atmospheres, 1976.
!--------------------------------------------------------------------
real, parameter  :: DU_factor =    &
                            (6.022169e26/2.68684e25)/(47.9982)*1.0e5
real, parameter  :: DU_factor2 = DU_factor/GRAV
                                   ! Dobson units per (kg/kg * dyn/cm2) 
                                   ! Dobson units per (kg/kg * N  /m2) 

!--------------------------------------------------------------------
! netcdf diagnostics field variables
!---------------------------------------------------------------------
character(len=16), parameter       :: mod_name='radiation'
real                               :: missing_value = -999.
integer, dimension(:), allocatable :: id_aerosol, id_aerosol_column
!integer, dimension(:), allocatable :: id_aerosol, id_aerosol_column, &
!                                     id_absopdep, id_absopdep_column, &
integer, dimension(:,:), allocatable :: id_absopdep,  &
                                        id_absopdep_column, &
                                      id_extopdep, id_extopdep_column
integer, dimension(:,:), allocatable :: id_asymdep, id_asymdep_column
integer, dimension(2)              :: id_lw_absopdep_vlcno_column, &
                                      id_lw_extopdep_vlcno_column, &
                                      id_lwext_vlcno, id_lwssa_vlcno, &
                                      id_lwasy_vlcno, id_lw_xcoeff_vlcno
integer, dimension(2)              :: id_absopdep_vlcno_column, &
                                      id_extopdep_vlcno_column, &
                                      id_swext_vlcno, id_swssa_vlcno, &
                                      id_swasy_vlcno, id_sw_xcoeff_vlcno
integer, dimension(4)              :: id_lw_bdyflx_clr, id_lw_bdyflx, &
                                      id_sw_bdyflx_clr, id_sw_bdyflx
integer                            :: id_swheat_vlcno
integer                            :: id_sulfate_col_cmip,  &
                                      id_sulfate_cmip
integer, dimension(:), allocatable :: id_aerosol_fam, &
                                      id_aerosol_fam_column    
integer, dimension(:,:), allocatable :: id_absopdep_fam,  &
                                        id_absopdep_fam_column, &
                                        id_extopdep_fam,  &
                                        id_extopdep_fam_column
integer, dimension(:,:), allocatable :: id_asymdep_fam,  &
                                        id_asymdep_fam_column
integer                            :: id_radswp, id_radp, id_temp, &
                                      id_rh2o, id_qo3, id_qo3_col,  &
                                      id_qo3v, &
                                      id_cmxolw, id_crndlw, id_flxnet, &
                                      id_fsw, id_ufsw, id_psj, &
                                      id_dfsw, &
                                      id_tmpsfc, id_cvisrfgd_dir,  &
                                      id_cirrfgd_dir, &
                                      id_cvisrfgd_dif, id_cirrfgd_dif, &
                                      id_radswpcf,  &
                                      id_cldwater, id_cldice,  &
                                      id_cldarea, &
                                      id_radpcf, id_flxnetcf, &
                                      id_fswcf, id_ufswcf, id_pressm,  &
                                      id_dfswcf, &
                                      id_phalfm, id_pfluxm, &
                                      id_dphalf, id_dpflux, &
                                      id_ptop



!---------------------------------------------------------------------
!    miscellaneous variables
!---------------------------------------------------------------------
integer :: nso4 
integer :: naerosol=0                      ! number of active aerosols
logical :: module_is_initialized= .false.  ! module initialized ?
integer, parameter              :: N_DIAG_BANDS = 10
character(len=16), dimension(N_DIAG_BANDS) ::   &
                     band_suffix = (/ '_vis', '_nir', '_con',  &
                                      '_bd5', '_bd6', '_870', &
! +++ pag 11/13/2009
                                      '_340','_380','_440','_670' /)
! Properties at specific wavelength are in fact averaged over a band which
! are defined in the input file:
! /home/pag/fms/radiation/esf_sw_input_data_n38b18_1992_version_ckd2.1.lean.nov89.ref
!
! 309 < 340 < 364
! 364 < 380 < 406
! 406 < 440 < 448
! 500 < vis < 600
! 600 < 670 < 685
! 685 < 870 < 870
! 870 < nir < 1219
! In the file, each band is defined by its end wavelength in wavenumber.
! For 340nm, the endband is 1.e4/0.309=32400 (11th wavenumber among the 18
! specified in the input file)
! +++ pag 11/13/2009


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!     
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    
!#####################################################################
! <SUBROUTINE NAME="rad_output_file_init">
!  <OVERVIEW>
!   Constructor of rad_output_file module
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine to initialize and set up rad_output_file module
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  rad_output_file_init (axes, Time, names)
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="integer">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
!  <IN NAME="names" TYPE="character">
!   aerosol names
!  </IN>
! </SUBROUTINE>
!
subroutine rad_output_file_init (axes, Time, names, family_names)

!--------------------------------------------------------------------
!    rad_output_file_init is the constructor for rad_output_file_mod.
!--------------------------------------------------------------------

integer, dimension(4),           intent(in)    :: axes
type(time_type),                 intent(in)    :: Time
!character(len=64), dimension(:), intent(in)    :: names
character(len=*), dimension(:), intent(in)    :: names
character(len=*), dimension(:), intent(in)    :: family_names

!--------------------------------------------------------------------
!  intent(in) variables:
!
!    these variables are present when running the gcm, not present
!    when running the standalone code.
!  
!       axes      diagnostic variable axes for netcdf files
!       Time      current time [ time_type(days, seconds) ]
!       names     names of active aerosols
!       family_names 
!                 names of active aerosol families
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer   :: unit, io, ierr, logunit
      integer   :: nfields

!---------------------------------------------------------------------
!   local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!        nfields         number of active aerosol fields
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init
      call esfsw_parameters_init
      call diag_manager_init  
      call time_manager_init 

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=rad_output_file_nml, iostat=io)
      ierr = check_nml_error(io,'rad_output_file_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=rad_output_file_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'rad_output_file_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                         write (logunit, nml=rad_output_file_nml)

!--------------------------------------------------------------------
!    if running gcm, continue on if data file is to be written. 
!--------------------------------------------------------------------
        if (write_data_file) then

!---------------------------------------------------------------------
!    register the diagnostic fields for output.
!---------------------------------------------------------------------
          nfields = size(names(:))
          call register_fields (Time, axes, nfields, names,  &
                                family_names)
        endif

!--------------------------------------------------------------------
!    mark the module as initialized.
!--------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------


end subroutine rad_output_file_init



!################################################################
! <SUBROUTINE NAME="write_rad_output_file">
!  <OVERVIEW>
!   write_rad_output_file produces a netcdf output file containing
!   the user-specified radiation-related variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!   write_rad_output_file produces a netcdf output file containing
!   the user-specified radiation-related variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call write_rad_output_file (is, ie, js, je, Atmos_input, Surface, &
!                                  Rad_output, &
!                                  Sw_output, Lw_output, Rad_gases, &
!                                  Cldrad_props, Cld_spec,  &
!                                  Time_diag, aerosol_in)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data 
!   in the physics_window being integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable containing atmos-
!                        pheric input data for the radiation package 
!                        on the model grid
!  </IN>
!  <IN NAME="Surface" TYPE="surface_type">
!   Surface input data to radiation package
!  </IN>
!  <IN NAME="Rad_output" TYPE="rad_output_type">
!   rad_output_type variable containing radiation
!                        output data needed by other modules
!  </IN>
!  <IN NAME="Sw_output" TYPE="sw_output_type">
!   sw_output_type variable containing shortwave 
!                        radiation output data from the sea_esf_rad
!                        radiation package on the model grid
!  </IN>
!  <IN NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                        radiation output data from the sea_esf_rad
!                        radiation package on the model grid 
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing rad-
!                        iative gas input data for the radiation package
!                        on the model grid
!  </IN>
!  <IN NAME="Cldrad_pros" TYPE="cldrad_properties_type">
!   cldrad_properties_type variable containing 
!                        cloud radiative property input data for the 
!                        radiation package on the model grid
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_diagnostics_type">
!   cld_specification_type variable containing cloud
!                        microphysical data
!  </IN>
!  <IN NAME="Time_diag" TYPE="time_type">
!   time on next timestep, used as stamp for diag-
!                        nostic output  [ time_type  (days, seconds) ]
!  </IN>
!  <IN NAME="aerosol_in" TYPE="real">
!   optional aerosol data
!  </IN>
! </SUBROUTINE>
!
subroutine write_rad_output_file (is, ie, js, je, Atmos_input, Surface,&
                                  Rad_output, Sw_output, Lw_output,    &
                                  Rad_gases, Cldrad_props, Cld_spec,   &
                                  Time_diag, Aerosol, Aerosol_props, &
                                  Aerosol_diags)

!----------------------------------------------------------------
!    write_rad_output_file produces a netcdf output file containing
!    the user-specified radiation-related variables.
!----------------------------------------------------------------

integer,                      intent(in)            ::  is, ie, js, je
type(atmos_input_type),       intent(in)            ::  Atmos_input
type(surface_type),           intent(in)            ::  Surface
type(rad_output_type),        intent(in)            ::  Rad_output
type(sw_output_type),         intent(in)            ::  Sw_output
type(lw_output_type),         intent(in)            ::  Lw_output
type(radiative_gases_type),   intent(in)            ::  Rad_gases
type(cldrad_properties_type), intent(in)            ::  Cldrad_props
type(cld_specification_type), intent(in)            ::  Cld_spec      
type(time_type),              intent(in)            ::  Time_diag
type(aerosol_type),           intent(in), optional  ::  Aerosol
type(aerosol_properties_type), intent(in), optional ::  Aerosol_props
type(aerosol_diagnostics_type), intent(in), optional :: Aerosol_diags

!------------------------------------------------------------------
!  intent(in) variables:
!
!      is,ie,js,je       starting/ending subdomain i,j indices of data 
!                        in the physics_window being integrated
!      Atmos_input       atmos_input_type variable containing atmos-
!                        pheric input data for the radiation package 
!                        on the model grid
!      Surface           surface input fields to radiation package
!                        [ surface_type ]
!      Rad_output        rad_output_type variable containing radiation
!                        output data needed by other modules
!      Sw_output         sw_output_type variable containing shortwave 
!                        radiation output data from the sea_esf_rad
!                        radiation package on the model grid
!      Lw_output         lw_output_type variable containing longwave 
!                        radiation output data from the sea_esf_rad
!                        radiation package on the model grid 
!      Rad_gases         radiative_gases_type variable containing rad-
!                        iative gas input data for the radiation package
!                        on the model grid
!      Cldrad_props      cldrad_properties_type variable containing 
!                        cloud radiative property input data for the 
!                        radiation package on the model grid
!      Cld_spec          cld_specification_type variable containing 
!                        cloud specification input data for the 
!                        radiation package on the model grid
!      Time_diag         time on next timestep, used as stamp for diag-
!                        nostic output  [ time_type  (days, seconds) ]  
!
!  intent(in), optional variables:
!
!      aerosol_in        active aerosol distributions
!                        [ kg / m**2 ]
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:

      real, dimension (size(Atmos_input%press,1),   &
                       size(Atmos_input%press,2) )  ::  &
                           tmpsfc, psj, cvisrfgd_dir, cirrfgd_dir,  &
                           cvisrfgd_dif, cirrfgd_dif, qo3_col, &
                           ptop

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3)  ) ::   &
                          fsw, ufsw, fswcf, ufswcf, flxnet, flxnetcf, &
                          phalfm, pfluxm

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3)-1 ) ::  &
                       temp, rh2o, qo3, cmxolw, crndlw, radp, radswp, &
                       v_heat, &
                       radpcf, radswpcf, pressm, dphalf, dpflux, deltaz

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), 4)  :: &
                                bdy_flx_mean, bdy_flx_clr_mean

      real, dimension(:,:,:),   allocatable :: aerosol_col
      real, dimension(:,:,:,:),   allocatable :: extopdep_col
      real, dimension(:,:,:,:),   allocatable :: absopdep_col
      real, dimension(:,:,:),   allocatable :: lw_extopdep_vlcno_col
      real, dimension(:,:,:),   allocatable :: lw_absopdep_vlcno_col
      real, dimension(:,:,:),   allocatable :: extopdep_vlcno_col
      real, dimension(:,:,:),   allocatable :: absopdep_vlcno_col
      real, dimension(:,:,:,:),   allocatable :: absopdep_fam_col
      real, dimension(:,:,:,:),   allocatable :: extopdep_fam_col
      real, dimension(:,:,:),   allocatable :: aerosol_fam_col
      real, dimension(:,:,:,:,:), allocatable :: absopdep_fam
      real, dimension(:,:,:,:,:), allocatable :: extopdep_fam
      real, dimension(:,:,:,:), allocatable :: aerosol_fam
      real, dimension(:,:,:,:),   allocatable :: asymdep_col
      real, dimension(:,:,:,:,:), allocatable :: asymdep_fam
      real, dimension(:,:,:,:),   allocatable :: asymdep_fam_col
      real, dimension(:,:,:,:), allocatable :: sum1
      real, dimension(:,:,:), allocatable :: sum2

      logical   :: used, Lasymdep
      integer   :: kerad ! number of model layers
      integer   :: n, k, na, nfamilies, nl
      integer   :: nv, vis_indx, nir_indx
      integer   :: co_indx, bnd_indx
      integer   :: nzens, nz

!----------------------------------------------------------------------
!  local variables:
!
!      tmpsfc         surface temperature [ deg K ]
!      psj            surface pressure [ hPa ]
!      cvisrfgd       surface visible light albedo [ dimensionless ]
!      cirrfgd        surface ir albedo [ dimensionless ]
!      tot_clds       total column isccp clouds [ percent ]
!      cld_isccp_hi   number of isccp high clouds [ percent ]
!      cld_isccp_mid  number of isccp middle clouds [ percent ]
!      cld_isccp_low  number of isccp low clouds [ percent ]
!      qo3_col        ozone column [ DU ]
!      fsw            net shortwave flux [ W / m**2 ]
!      ufsw           upward shortwave flux [ W / m**2 ]
!      fswcf          net sw flux in the absence of clouds [ W / m**2 ]
!      ufswcf         upward sw flux in absence of clouds [ W / m**2]
!      flxnet         net longwave flux [ W / m**2 ]
!      flxnetcf       net lw flux in the absence of clouds [ W / m**2 ]
!      phalfm         model interface level pressure [ Pa ]
!      pfluxm         avg of adjacent model level pressures [ Pa ]
!      temp           temperature [ deg K ]
!      rh2o           water vapor specific humidity [ g / g ]
!      qo3            ozone mixing ratio [ g / g ]
!      heatra         lw heating rate [ deg K / day ]
!      heatracf       lw heating rate without cloud [ deg K / day ]
!      cmxolw         amount of maximal overlap clouds [ percent]
!      crndlw         amount of ramndom overlap clouds [ percent]
!      radp           lw + sw heating rate [ deg K / sec ]
!      radswp         sw heating rate [ deg K / sec ]
!      radpcf         lw + sw heating rate w/o clouds [ deg K / sec ]
!      radswpcf       sw heating rate w/o clouds [ deg K / sec ]
!      pressm         pressure at model levels [ Pa ]
!      aerosol_col
!      used
!      kerad
!      n,k
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_output_file_mod', &
              'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    if the file is not to be written, do nothing.
!--------------------------------------------------------------------
      if (write_data_file) then

        Lasymdep = .false.
        if (any(id_asymdep_fam(:,:)  > 0) .or. &
            any(id_asymdep_fam_column(:,:)  > 0 )) Lasymdep = .true.
            
!--------------------------------------------------------------------
!    define the number of zenith angles that the sw was calculated 
!    for on this step.
!--------------------------------------------------------------------
        nzens = Rad_control%nzens

!--------------------------------------------------------------------
!    if the file is to be written, define the number of model layers.
!--------------------------------------------------------------------
        kerad = ubound(Atmos_input%temp,3) - 1

!--------------------------------------------------------------------
!    retrieve the desired fields from the input derived data types.
!--------------------------------------------------------------------
        tmpsfc(:,:)     = Atmos_input%temp(:,:,kerad+1)
        psj   (:,:)     = Atmos_input%press(:,:,kerad+1)
        pressm(:,:,:)   = Atmos_input%press(:,:,1:kerad)
        phalfm(:,:,:)   = Atmos_input%phalf(:,:,:)
        pfluxm(:,:,:)   = Atmos_input%pflux(:,:,:)
        temp(:,:,:)     = Atmos_input%temp(:,:,1:kerad)
        rh2o(:,:,:)     = Atmos_input%rh2o(:,:,:)
        radp = 0.
        radswp = 0.
        fsw = 0.
        ufsw = 0.
        bdy_flx_mean = 0.
        do nz = 1, nzens
          radp(:,:,:)     = radp(:,:,:) +    &
                                 Rad_output%tdt_rad(is:ie,js:je,:,nz)
          radswp(:,:,:)   = radswp(:,:,:) +    &
                                 Rad_output%tdtsw  (is:ie,js:je,:,nz)
          fsw(:,:,:)    = fsw(:,:,:) + Sw_output% fsw(:,:,:,nz)
          ufsw(:,:,:)   = ufsw(:,:,:) + Sw_output%ufsw(:,:,:,nz)
          bdy_flx_mean(:,:,:) = bdy_flx_mean(:,:,:) +  &
                                  Sw_output%bdy_flx(:,:,:,nz) 
        end do
        radp = radp/float(nzens)
        radswp = radswp/float(nzens)
        fsw = fsw/float(nzens)
        ufsw = ufsw/float(nzens)
        bdy_flx_mean = bdy_flx_mean/float(nzens)
!       cirrfgd(:,:)    = Surface%asfc(:,:)
!       cvisrfgd(:,:)   = Surface%asfc(:,:)
        cirrfgd_dir(:,:)    = Surface%asfc_nir_dir(:,:)
        cvisrfgd_dir(:,:)   = Surface%asfc_vis_dir(:,:)
        cirrfgd_dif(:,:)    = Surface%asfc_nir_dif(:,:)
        cvisrfgd_dif(:,:)   = Surface%asfc_vis_dif(:,:)
        flxnet(:,:,:)   = Lw_output%flxnet(:,:,:)
        qo3(:,:,:)      = Rad_gases%qo3(:,:,:)
        cmxolw(:,:,:)   = 100.0*Cld_spec%cmxolw(:,:,:)
        crndlw(:,:,:)   = 100.0*Cld_spec%crndlw(:,:,:)
        deltaz(:,:,:)   = Atmos_input%deltaz(:,:,:)

          do k = 1,kerad
            dphalf(:,:,k)   = phalfm(:,:,k+1) - phalfm(:,:,k)
            dpflux(:,:,k)   = pfluxm(:,:,k+1) - pfluxm(:,:,k)
          enddo
          ptop(:,:) = 0.01*Atmos_input%phalf(:,:,1)

        if (Rad_control%do_totcld_forcing) then 
          fswcf = 0.
          ufswcf = 0.
          radpcf = 0.
          radswpcf = 0.
          bdy_flx_clr_mean = 0.
          do nz=1,nzens
            fswcf(:,:,:)    = fswcf(:,:,:) + Sw_output%fswcf(:,:,:,nz)
            ufswcf(:,:,:)   = ufswcf(:,:,:) + Sw_output%ufswcf(:,:,:,nz)
            radpcf(:,:,:)   = radpcf(:,:,:) +    &
                                Rad_output%tdt_rad_clr(is:ie,js:je,:,nz)
            radswpcf(:,:,:) = radswpcf(:,:,:) +    &
                                Rad_output%tdtsw_clr  (is:ie,js:je,:,nz)
            bdy_flx_clr_mean(:,:,:) = bdy_flx_clr_mean(:,:,:) +  &
                                  Sw_output%bdy_flx_clr(:,:,:,nz) 
          end do
          fswcf = fswcf/float(nzens)
          ufswcf = ufswcf/float(nzens)
          radpcf = radpcf/float(nzens)
          radswpcf = radswpcf/float(nzens)
          bdy_flx_clr_mean = bdy_flx_clr_mean/float(nzens)
          flxnetcf(:,:,:) = Lw_output%flxnetcf(:,:,:)
        endif

!---------------------------------------------------------------------
!    calculate the column ozone in DU (Dobson units). convert from 
!    (kg/kg) * (N/m2) to DU (1DU = 2.687E16 molec cm^-2).
!---------------------------------------------------------------------
        qo3_col(:,:) = 0.
        do k = 1,size(qo3,3)
          qo3_col(:,:) = qo3_col(:,:) + &
                         qo3(:,:,k)*(Atmos_input%pflux(:,:,k+1) -  &
                                     Atmos_input%pflux(:,:,k))
        end do
        qo3_col(:,:) = qo3_col(:,:)*DU_factor2

!---------------------------------------------------------------------
!    define the aerosol fields and calculate the column aerosol. 
!---------------------------------------------------------------------
        if (Rad_control%do_aerosol) then
          allocate ( aerosol_col(size(Aerosol%aerosol, 1), &
                                 size(Aerosol%aerosol, 2), &
                                 size(Aerosol%aerosol, 4)) )       
          aerosol_col(:,:,:) = SUM (Aerosol%aerosol(:,:,:,:), 3)
!         if (Sw_control%do_swaerosol) then
            allocate ( extopdep_col(size(Aerosol_diags%extopdep  , 1), &
                                    size(Aerosol_diags%extopdep  , 2), &
                               size(Aerosol_diags%extopdep  , 4), &
                                    N_DIAG_BANDS) )
            extopdep_col(:,:,:,:) =    &
                          SUM (Aerosol_diags%extopdep  (:,:,:,:,:), 3)
            allocate ( absopdep_col(size(Aerosol_diags%absopdep  , 1), &
                                    size(Aerosol_diags%absopdep  , 2), &
                              size(Aerosol_diags%absopdep  , 4), &
                                   N_DIAG_BANDS) )
            absopdep_col(:,:,:,:) =    &
                           SUM (Aerosol_diags%absopdep  (:,:,:,:,:), 3)
            if ( Lasymdep ) then 
              allocate ( asymdep_col(size(Aerosol_diags%asymdep  , 1), &
                                 size(Aerosol_diags%asymdep  ,     2), &
                                 size(Aerosol_diags%asymdep  ,     4), &
                                      N_DIAG_BANDS) )
              asymdep_col(:,:,:,:) =  SUM ( &
                            Aerosol_diags%asymdep(:,:,:,:,:) &
                                *(Aerosol_diags%extopdep(:,:,:,:,:)-  &
                                    Aerosol_diags%absopdep(:,:,:,:,:)), 3) &
                             /(1.e-30+SUM(Aerosol_diags%extopdep(:,:,:,:,:)&
                                     -Aerosol_diags%absopdep(:,:,:,:,:), 3))
            endif
            if (Rad_control%volcanic_sw_aerosols) then
              allocate ( extopdep_vlcno_col(   &
                           size(Aerosol_diags%extopdep_vlcno  , 1), &
                           size(Aerosol_diags%extopdep_vlcno  , 2),3))
              extopdep_vlcno_col(:,:,:) =    &
                        SUM (Aerosol_diags%extopdep_vlcno  (:,:,:,:), 3)
              allocate ( absopdep_vlcno_col(    &
                            size(Aerosol_diags%absopdep_vlcno  , 1), &
                            size(Aerosol_diags%absopdep_vlcno  , 2),3))
              absopdep_vlcno_col(:,:,:) =    &
                        SUM (Aerosol_diags%absopdep_vlcno  (:,:,:,:), 3)
            endif
              
            if (Rad_control%volcanic_lw_aerosols) then
              allocate ( lw_extopdep_vlcno_col(   &
                         size(Aerosol_diags%lw_extopdep_vlcno  , 1), &
                         size(Aerosol_diags%lw_extopdep_vlcno  , 2),2))
              lw_extopdep_vlcno_col(:,:,:) =    &
                    SUM (Aerosol_diags%lw_extopdep_vlcno  (:,:,:,:), 3)
              allocate ( lw_absopdep_vlcno_col(    &
                          size(Aerosol_diags%lw_absopdep_vlcno  , 1), &
                          size(Aerosol_diags%lw_absopdep_vlcno  , 2),2))
              lw_absopdep_vlcno_col(:,:,:) =    &
                    SUM (Aerosol_diags%lw_absopdep_vlcno  (:,:,:,:), 3)
            endif
        endif
        
!---------------------------------------------------------------------
!    define the aerosol family output fields.
!---------------------------------------------------------------------
        if (Rad_control%do_aerosol) then
          nfamilies = size(Aerosol%family_members,2)
          if (nfamilies > 0) then
            allocate (aerosol_fam (     &
                                    size(Aerosol%aerosol,1), &
                                    size(Aerosol%aerosol,2), &
                                    size(Aerosol%aerosol,3), &
                                    nfamilies))
            allocate (aerosol_fam_col (     &
                                    size(Aerosol%aerosol,1), &
                                    size(Aerosol%aerosol,2), &
                                    nfamilies))
            allocate (extopdep_fam (     &
                                    size(Aerosol%aerosol,1), &
                                    size(Aerosol%aerosol,2), &
                                    size(Aerosol%aerosol,3), &
                                    nfamilies, N_DIAG_BANDS))
            allocate (absopdep_fam (     &
                                    size(Aerosol%aerosol,1), &
                                    size(Aerosol%aerosol,2), &
                                    size(Aerosol%aerosol,3), &
                                    nfamilies, N_DIAG_BANDS))
            allocate (extopdep_fam_col (     &
                                    size(Aerosol%aerosol,1), &
                                    size(Aerosol%aerosol,2), &
                                    nfamilies, N_DIAG_BANDS))
            allocate (absopdep_fam_col (     &
                                    size(Aerosol%aerosol,1), &
                                    size(Aerosol%aerosol,2), &
                                    nfamilies, N_DIAG_BANDS))
            aerosol_fam = 0.
            aerosol_fam_col = 0.
            extopdep_fam = 0.
            absopdep_fam = 0.
            extopdep_fam_col = 0.
            absopdep_fam_col = 0.

            if ( Lasymdep ) then
              allocate (asymdep_fam ( size(Aerosol%aerosol,1), &
                                      size(Aerosol%aerosol,2), &
                                      size(Aerosol%aerosol,3), &
                                      nfamilies, N_DIAG_BANDS))
              allocate (asymdep_fam_col ( size(Aerosol%aerosol,1), &
                                          size(Aerosol%aerosol,2), &
                                          nfamilies, N_DIAG_BANDS))
              allocate (sum1 (       size(Aerosol%aerosol,1), &
                                     size(Aerosol%aerosol,2), &
                                     size(Aerosol%aerosol,3), &
                                     N_DIAG_BANDS))
              allocate (sum2 (       size(Aerosol%aerosol,1), &
                                     size(Aerosol%aerosol,2), &
                                     N_DIAG_BANDS))
              asymdep_fam = 0.
              asymdep_fam_col = 0.
            endif

            do n = 1, nfamilies                      
              do na = 1, naerosol                
                if (Aerosol%family_members(na,n)) then
                  aerosol_fam(:,:,:,n) = aerosol_fam(:,:,:,n) +  &
                                         Aerosol%aerosol(:,:,:,na)
                  aerosol_fam_col(:,:,n) = aerosol_fam_col(:,:,n) +  &
                                         aerosol_col(:,:,na)
                  do nl = 1,N_DIAG_BANDS
                    extopdep_fam(:,:,:,n,nl) = extopdep_fam(:,:,:,n,nl) +  &
                                      Aerosol_diags%extopdep(:,:,:,na,nl)
                    extopdep_fam_col(:,:,n,nl) = extopdep_fam_col(:,:,n,nl) +  &
                                      extopdep_col(:,:,na,nl)
                    absopdep_fam(:,:,:,n,nl) = absopdep_fam(:,:,:,n,nl) +  &
                                      Aerosol_diags%absopdep(:,:,:,na,nl)
                    absopdep_fam_col(:,:,n,nl) = absopdep_fam_col(:,:,n,nl) +  &
                                      absopdep_col(:,:,na,nl)
                  end do ! (nl)
                endif
              end do ! (na)
              if ( Lasymdep ) then
                sum1(:,:,:,:)=1.e-30
                sum2(:,:,:)=1.e-30
                do na = 1, naerosol                
                  if (Aerosol%family_members(na,n)) then
                    do nl = 1,N_DIAG_BANDS
                      asymdep_fam(:,:,:,n,nl) = asymdep_fam(:,:,:,n,nl) &
                          + Aerosol_diags%asymdep(:,:,:,na,nl) &
                          *( Aerosol_diags%extopdep(:,:,:,na,nl) &
                          -Aerosol_diags%absopdep(:,:,:,na,nl))
                      sum1(:,:,:,nl) = sum1(:,:,:,nl) &
                          + Aerosol_diags%extopdep(:,:,:,na,nl) &
                          - Aerosol_diags%absopdep(:,:,:,na,nl)
                      asymdep_fam_col(:,:,n,nl) = asymdep_fam_col(:,:,n,nl) &
                          + asymdep_col(:,:,na,nl)&
                          *(extopdep_col(:,:,na,nl)-absopdep_col(:,:,na,nl))
                      sum2(:,:,nl) = sum2(:,:,nl)&
                          + extopdep_col(:,:,na,nl) - absopdep_col(:,:,na,nl)
                    end do ! (nl)
                  endif
                end do ! (na)

                asymdep_fam = max (0., min(1., asymdep_fam))
                sum1 = max(1.e-30,min(1.,sum1))
                asymdep_fam_col = max (0., min(1., asymdep_fam_col))
                sum2 = max (1.e-30, min(1.,sum2))
                do nl = 1,N_DIAG_BANDS
                  asymdep_fam(:,:,:,n,nl) = asymdep_fam(:,:,:,n,nl)/sum1(:,:,:,nl)
                  asymdep_fam_col(:,:,n,nl)=asymdep_fam_col(:,:,n,nl)/sum2(:,:,nl)
                enddo
              endif

              if (Aerosol%family_members(naerosol+1,n)) then
                if (Rad_control%volcanic_sw_aerosols) then
                  extopdep_fam_col(:,:,n,1) = extopdep_fam_col(:,:,n,1) +  &
                                              extopdep_vlcno_col(:,:,1)
                  absopdep_fam_col(:,:,n,1) = absopdep_fam_col(:,:,n,1) +  &
                                              absopdep_vlcno_col(:,:,1)
                  extopdep_fam_col(:,:,n,2) = extopdep_fam_col(:,:,n,2) +  &
                                              extopdep_vlcno_col(:,:,2)
                  absopdep_fam_col(:,:,n,2) = absopdep_fam_col(:,:,n,2) +  &
                                              absopdep_vlcno_col(:,:,2)
                  extopdep_fam_col(:,:,n,6) = extopdep_fam_col(:,:,n,6) +  &
                                              extopdep_vlcno_col(:,:,3)
                  absopdep_fam_col(:,:,n,6) = absopdep_fam_col(:,:,n,6) +  &
                                              absopdep_vlcno_col(:,:,3)
                endif
                if (Rad_control%volcanic_lw_aerosols) then
                  extopdep_fam_col(:,:,n,4) = extopdep_fam_col(:,:,n,4) +  &
                                              lw_extopdep_vlcno_col(:,:,1)
                  absopdep_fam_col(:,:,n,4) = absopdep_fam_col(:,:,n,4) +  &
                                              lw_absopdep_vlcno_col(:,:,1)
                  extopdep_fam_col(:,:,n,5) = extopdep_fam_col(:,:,n,5) +  &
                                              lw_extopdep_vlcno_col(:,:,2)
                  absopdep_fam_col(:,:,n,5) = absopdep_fam_col(:,:,n,5) +  &
                                              lw_absopdep_vlcno_col(:,:,2)
                endif
              endif
            enddo ! (n)

          do n = 1,nfamilies
            if (id_aerosol_fam(n)  > 0 ) then
              used = send_data (id_aerosol_fam(n),  &
                                aerosol_fam(:,:,:,n)/deltaz(:,:,:),   &
                                Time_diag, is, js, 1)
            endif
            if (id_aerosol_fam_column(n)  > 0 ) then
              used = send_data (id_aerosol_fam_column(n),     &
                                aerosol_fam_col(:,:,n), Time_diag, is, js)
            endif
            do nl=1,N_DIAG_BANDS
              if (id_extopdep_fam(n,nl)  > 0 ) then
                used = send_data (id_extopdep_fam(n,nl),    &
                                  extopdep_fam  (:,:,:,n,nl), &
                                  Time_diag, is, js, 1)
              endif
              if (id_extopdep_fam_column(n,nl)  > 0 ) then
                used = send_data (id_extopdep_fam_column(n,nl),     &
                                 extopdep_fam_col(:,:,n,nl), Time_diag, is, js)
              endif
              if (id_absopdep_fam(n,nl)  > 0 ) then
                used = send_data (id_absopdep_fam(n,nl),    &
                                  absopdep_fam  (:,:,:,n,nl), &
                                  Time_diag, is, js, 1)
              endif
              if (id_absopdep_fam_column(n,nl)  > 0 ) then
                used = send_data (id_absopdep_fam_column(n,nl),     &
                             absopdep_fam_col(:,:,n,nl), Time_diag, is, js)
              endif
              if (id_asymdep_fam(n,nl)  > 0 ) then
                used = send_data (id_asymdep_fam(n,nl),    &
                                  asymdep_fam  (:,:,:,n,nl), &
                                  Time_diag, is, js, 1)
              endif
              if (id_asymdep_fam_column(n,nl)  > 0 ) then
                used = send_data (id_asymdep_fam_column(n,nl),     &
                             asymdep_fam_col(:,:,n,nl), Time_diag, is, js)
              endif
            end do  
        end do
          deallocate (aerosol_fam)
          deallocate (aerosol_fam_col)
          deallocate (extopdep_fam)
          deallocate (absopdep_fam)
          deallocate (extopdep_fam_col)
          deallocate (absopdep_fam_col)
          if ( Lasymdep ) then
            deallocate (asymdep_fam)
            deallocate (asymdep_fam_col)
            deallocate (sum1)
            deallocate (sum2)
          endif
      endif
    endif
        
!---------------------------------------------------------------------
!    send the user-designated data to diag_manager_mod for processing.
!---------------------------------------------------------------------
        if (id_radswp > 0 ) then
          used = send_data (id_radswp, radswp, Time_diag, is, js, 1)
        endif

        if (id_radp > 0 ) then
          used = send_data (id_radp, radp, Time_diag, is, js, 1)
        endif

        if (id_temp > 0 ) then
          used = send_data (id_temp, temp, Time_diag, is, js, 1)
        endif

        if (id_pressm > 0 ) then
          used = send_data (id_pressm, pressm, Time_diag, is, js, 1)
        endif

        if (id_phalfm > 0 ) then
          used = send_data (id_phalfm, phalfm, Time_diag, is, js, 1)
        endif
 
        if (id_pfluxm > 0 ) then
          used = send_data (id_pfluxm, pfluxm, Time_diag, is, js, 1)
        endif

        if (id_rh2o > 0 ) then
          used = send_data (id_rh2o, rh2o, Time_diag, is, js, 1)
        endif

        if (id_cldwater > 0 ) then
          used = send_data (id_cldwater, Cld_spec%cloud_water,  &
                            Time_diag, is, js, 1)
        endif

        if (id_cldice > 0 ) then
          used = send_data (id_cldice, Cld_spec%cloud_ice,  &
                            Time_diag, is, js, 1)
        endif

        if (id_cldarea > 0 ) then
          used = send_data (id_cldarea, Cld_spec%cloud_area,  &
                            Time_diag, is, js, 1)
        endif

        if (id_qo3  > 0 ) then
          used = send_data (id_qo3, qo3, Time_diag, is, js, 1)
        endif

        if (id_qo3v  > 0 ) then
          used = send_data (id_qo3v, 1.0e09*qo3*WTMAIR/WTMOZONE, Time_diag, is, js, 1)
        endif

        if (id_qo3_col  > 0 ) then
          used = send_data (id_qo3_col, qo3_col, Time_diag, is, js)
        endif

          if (id_dphalf > 0 ) then
            used = send_data (id_dphalf, dphalf, Time_diag, is, js, 1)
          endif

          if (id_dpflux > 0 ) then
            used = send_data (id_dpflux, dpflux, Time_diag, is, js, 1)
          endif

          if (id_ptop  > 0 ) then
            used = send_data (id_ptop, ptop, Time_diag, is, js)
          endif
        if (Rad_control%do_aerosol) then
            if (id_sulfate_col_cmip  > 0 ) then
              used = send_data (id_sulfate_col_cmip,      &
                            (96./132.)*aerosol_col(:,:,nso4), Time_diag, is, js)
            endif
            if (id_sulfate_cmip  > 0 ) then
              used = send_data (id_sulfate_cmip,      &
                       (96./132.)*Aerosol%aerosol(:,:,:,nso4)/  &
                                   deltaz(:,:,:), Time_diag, is, js,1)
            endif
!           if (Sw_control%do_swaerosol) then
          do n = 1,naerosol
            if (id_aerosol(n)  > 0 ) then
              used = send_data (id_aerosol(n),  &
                                Aerosol%aerosol(:,:,:,n)/deltaz(:,:,:),&
                                Time_diag, is, js, 1)
            endif
            if (id_aerosol_column(n)  > 0 ) then
              used = send_data (id_aerosol_column(n),     &
                                aerosol_col(:,:,n), Time_diag, is, js)
            endif
!           if (Sw_control%do_swaerosol) then
            do nl=1,N_DIAG_BANDS
              if (id_extopdep(n,nl)  > 0 ) then
                used = send_data (id_extopdep(n,nl),    &
                                  Aerosol_diags%extopdep  (:,:,:,n,nl), &
                                  Time_diag, is, js, 1)
              endif
              if (id_extopdep_column(n,nl)  > 0 ) then
                used = send_data (id_extopdep_column(n,nl),     &
                                 extopdep_col(:,:,n,nl), Time_diag, is, js)
              endif
              if (id_absopdep(n,nl)  > 0 ) then
                used = send_data (id_absopdep(n,nl),    &
                                  Aerosol_diags%absopdep  (:,:,:,n,nl), &
                                  Time_diag, is, js, 1)
              endif
              if (id_absopdep_column(n,nl)  > 0 ) then
                used = send_data (id_absopdep_column(n,nl),     &
                                 absopdep_col(:,:,n,nl), Time_diag, is, js)
              endif
              if (id_asymdep(n,nl)  > 0 ) then
                used = send_data (id_asymdep(n,nl),    &
                                  Aerosol_diags%asymdep  (:,:,:,n,nl), &
                                  Time_diag, is, js, 1)
              endif
              if (id_asymdep_column(n,nl)  > 0 ) then
                used = send_data (id_asymdep_column(n,nl),     &
                                 asymdep_col(:,:,n,nl), Time_diag, is, js)
              endif
!           endif
            end do
          end do
          if (Rad_control%volcanic_lw_aerosols) then
!           co_indx = size(Aerosol_props%lw_ext,4)
            co_indx = 5
            if (id_lwext_vlcno(1)  > 0 ) then
              used = send_data (id_lwext_vlcno(1),     &
                         Aerosol_props%lw_ext(:,:,:,co_indx)*  &
                         Atmos_input%deltaz(:,:,:),  &
                         Time_diag, is, js,1)
            endif
            if (id_lw_xcoeff_vlcno(1)  > 0 ) then
              used = send_data (id_lw_xcoeff_vlcno(1),     &
                            Aerosol_props%lw_ext(:,:,:,co_indx),  &
                            Time_diag, is, js,1)
            endif
            if (id_lwssa_vlcno(1)  > 0 ) then
              used = send_data (id_lwssa_vlcno(1),     &
                            Aerosol_props%lw_ssa(:,:,:,co_indx),  &
                            Time_diag, is, js,1)
            endif
            if (id_lwasy_vlcno(1)  > 0 ) then
              used = send_data (id_lwasy_vlcno(1),     &
                           Aerosol_props%lw_asy(:,:,:,co_indx),  &
                           Time_diag, is, js,1)
            endif
!           bnd_indx = 4
            bnd_indx = 6
            if (id_lwext_vlcno(2)  > 0 ) then
              used = send_data (id_lwext_vlcno(2),     &
                               Aerosol_props%lw_ext(:,:,:,bnd_indx)* &
                               Atmos_input%deltaz(:,:,:),  &
                               Time_diag, is, js,1)
            endif
            if (id_lw_xcoeff_vlcno(2)  > 0 ) then
              used = send_data (id_lw_xcoeff_vlcno(2),     &
                               Aerosol_props%lw_ext(:,:,:,bnd_indx),  &
                               Time_diag, is, js,1)
            endif
            if (id_lwssa_vlcno(2)  > 0 ) then
              used = send_data (id_lwssa_vlcno(2),     &
                               Aerosol_props%lw_ssa(:,:,:,bnd_indx), &
                               Time_diag, is, js,1)
            endif
            if (id_lwasy_vlcno(2)  > 0 ) then
              used = send_data (id_lwasy_vlcno(2),     &
                              Aerosol_props%lw_asy(:,:,:,bnd_indx), &
                              Time_diag, is, js,1)
            endif
            do nv=1,2
              if (id_lw_extopdep_vlcno_column(nv)  > 0 ) then
                used = send_data (id_lw_extopdep_vlcno_column(nv),     &
                                  lw_extopdep_vlcno_col(:,:,nv),  &
                                  Time_diag, is, js)
              endif
              if (id_lw_absopdep_vlcno_column(nv)  > 0 ) then
                used = send_data (id_lw_absopdep_vlcno_column(nv),     &
                                  lw_absopdep_vlcno_col(:,:,nv),  &
                                  Time_diag, is, js)
              endif
            end do
            deallocate (lw_absopdep_vlcno_col, lw_extopdep_vlcno_col)
          endif
          if (Rad_control%volcanic_sw_aerosols) then
            vis_indx = Solar_spect%visible_band_indx
            if (id_swext_vlcno(1)  > 0 ) then
              used = send_data (id_swext_vlcno(1),     &
                                Aerosol_props%sw_ext(:,:,:,vis_indx)* &
                                Atmos_input%deltaz(:,:,:),  &
                                Time_diag, is, js,1)
            endif
            if (id_sw_xcoeff_vlcno(1)  > 0 ) then
              used = send_data (id_sw_xcoeff_vlcno(1),     &
                               Aerosol_props%sw_ext(:,:,:,vis_indx),  &
                               Time_diag, is, js,1)
            endif
            if (id_swssa_vlcno(1)  > 0 ) then
              used = send_data (id_swssa_vlcno(1),     &
                                 Aerosol_props%sw_ssa(:,:,:,vis_indx), &
                                 Time_diag, is, js,1)
            endif
            if (id_swasy_vlcno(1)  > 0 ) then
              used = send_data (id_swasy_vlcno(1),     &
                                Aerosol_props%sw_asy(:,:,:,vis_indx), &
                                Time_diag, is, js,1)
            endif
            if (id_swheat_vlcno  > 0 ) then

              v_heat = 0.0
              do nz = 1,nzens
                v_heat(:,:,:) = v_heat(:,:,:)  +  &
                              Aerosol_diags%sw_heating_vlcno(:,:,:,nz)
              end do
              v_heat = v_heat/float(nzens)

              used = send_data (id_swheat_vlcno ,    &
!                               Aerosol_diags%sw_heating_vlcno(:,:,:), &
                                v_heat(:,:,:), &
                                Time_diag, is, js, 1)
            endif
            nir_indx = Solar_spect%one_micron_indx
            if (id_swext_vlcno(2)  > 0 ) then
              used = send_data (id_swext_vlcno(2),     &
                               Aerosol_props%sw_ext(:,:,:,nir_indx)*  &
                               Atmos_input%deltaz(:,:,:),  &
                               Time_diag, is, js,1)
            endif
            if (id_sw_xcoeff_vlcno(2)  > 0 ) then
              used = send_data (id_sw_xcoeff_vlcno(2),     &
                               Aerosol_props%sw_ext(:,:,:,nir_indx),  &
                               Time_diag, is, js,1)
            endif
            if (id_swssa_vlcno(2)  > 0 ) then
              used = send_data (id_swssa_vlcno(2),     &
                                Aerosol_props%sw_ssa(:,:,:,nir_indx),  &
                                Time_diag, is, js,1)
            endif
            if (id_swasy_vlcno(2)  > 0 ) then
              used = send_data (id_swasy_vlcno(2),     &
                                Aerosol_props%sw_asy(:,:,:,vis_indx), &
                                Time_diag, is, js,1)
            endif
            do nv=1,2
              if (id_extopdep_vlcno_column(nv)  > 0 ) then
                used = send_data (id_extopdep_vlcno_column(nv),     &
                                  extopdep_vlcno_col(:,:,nv),  &
                                  Time_diag, is, js)
              endif
              if (id_absopdep_vlcno_column(nv)  > 0 ) then
                used = send_data (id_absopdep_vlcno_column(nv),     &
                                  absopdep_vlcno_col(:,:,nv),  &
                                  Time_diag, is, js)
              endif
            end do
            deallocate (absopdep_vlcno_col, extopdep_vlcno_col)
          endif
          deallocate (aerosol_col)
!         if (Sw_control%do_swaerosol) then
            deallocate (extopdep_col)
            deallocate (absopdep_col)
            if (allocated (asymdep_col)) deallocate (asymdep_col)
!         endif
        endif

        if (id_cmxolw > 0 ) then
          used = send_data (id_cmxolw, cmxolw, Time_diag, is, js, 1)
        endif

        if (id_crndlw > 0 ) then
          used = send_data (id_crndlw, crndlw, Time_diag, is, js, 1)
        endif

        if (id_flxnet > 0 ) then
          used = send_data (id_flxnet, flxnet, Time_diag, is, js, 1)
        endif

        if (id_fsw    > 0 ) then
          used = send_data (id_fsw   , fsw   , Time_diag, is, js, 1)
        endif

        if (id_ufsw   > 0 ) then
          used = send_data (id_ufsw  , ufsw  , Time_diag, is, js, 1)
        endif

        if (id_dfsw   > 0 ) then
          used = send_data (id_dfsw  , ufsw-fsw  , Time_diag, is, js, 1)
        endif

        if (id_psj    > 0 ) then
          used = send_data (id_psj   , psj   , Time_diag, is, js)
        endif

        if (id_tmpsfc > 0 ) then
          used = send_data (id_tmpsfc, tmpsfc, Time_diag, is, js)
        endif

        if (id_cvisrfgd_dir > 0 ) then
          used = send_data (id_cvisrfgd_dir, cvisrfgd_dir, Time_diag, is, js)
        endif
 
        if (id_cvisrfgd_dif > 0 ) then
          used = send_data (id_cvisrfgd_dif, cvisrfgd_dif, Time_diag, is, js)
        endif

        if (id_cirrfgd_dir > 0 ) then
          used = send_data (id_cirrfgd_dir , cirrfgd_dir , Time_diag, is,js)
        endif
 
        if (id_cirrfgd_dif > 0 ) then
          used = send_data (id_cirrfgd_dif , cirrfgd_dif , Time_diag, is,js)
        endif

     do n=1, 4
        if (id_lw_bdyflx(n) > 0 ) then
          used = send_data (id_lw_bdyflx(n) , Lw_output%bdy_flx(:,:,n),&
                            Time_diag, is,js)
        endif
        if (id_sw_bdyflx(n) > 0 ) then
          used = send_data (id_sw_bdyflx(n) , bdy_flx_mean(:,:,n),&
                            Time_diag, is,js)
        endif
     end do

        if (Rad_control%do_totcld_forcing) then
     do n=1, 4
        if (id_lw_bdyflx_clr(n) > 0 ) then
          used = send_data (id_lw_bdyflx_clr(n) ,   &
                            Lw_output%bdy_flx_clr(:,:,n),&
                            Time_diag, is,js)
        endif
        if (id_sw_bdyflx_clr(n) > 0 ) then
          used = send_data (id_sw_bdyflx_clr(n) ,   &
                            bdy_flx_clr_mean(:,:,n),&
                            Time_diag, is,js)
        endif
     end do

          if (id_radswpcf > 0 ) then
            used = send_data (id_radswpcf, radswpcf, Time_diag,   &
                              is, js, 1)
          endif

          if (id_radpcf > 0 ) then
            used = send_data (id_radpcf, radpcf, Time_diag, is, js, 1)
          endif

          if (id_flxnetcf > 0 ) then
            used = send_data (id_flxnetcf, flxnetcf, Time_diag,   &
                              is, js, 1)
          endif

          if (id_fswcf  > 0 ) then
            used = send_data (id_fswcf , fswcf , Time_diag, is, js, 1)
          endif

          if (id_ufswcf  > 0 ) then
            used = send_data (id_ufswcf , ufswcf , Time_diag, is, js, 1)
          endif

          if (id_dfswcf  > 0 ) then
            used = send_data (id_dfswcf , ufswcf-fswcf , Time_diag, is, js, 1)
          endif
        endif
      endif

!------------------------------------------------------------------


end subroutine write_rad_output_file



!#####################################################################
! <SUBROUTINE NAME="rad_output_file_end">
!  <OVERVIEW>
!   rad_output_file_end is the destructor for rad_output_file_mod
!  </OVERVIEW>
!  <DESCRIPTION>
!   rad_output_file_end is the destructor for rad_output_file_mod
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rad_output_file_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine rad_output_file_end

!-------------------------------------------------------------------
!    rad_output_file_end is the destructor for rad_output_file_mod.
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_output_file_mod', &
              'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized= .false. 

!----------------------------------------------------------------------

end subroutine rad_output_file_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!     
!                     PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!#################################################################
! <SUBROUTINE NAME="register_fields">
!  <OVERVIEW>
!   register_fields send the relevant information concerning the 
!    user-desired output fields to diag_manager_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   register_fields send the relevant information concerning the 
!    user-desired output fields to diag_manager_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call register_fields (Time, axes, nfilds, names)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time [ time_type(days, seconds) ]
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!   diagnostic variable axes for netcdf files
!  </IN>
!  <IN NAME="nfields" TYPE="integer">
!   number of aerosol fields
!  </IN>
!  <IN NAME="names" TYPE="character">
!   names of aerosol fields
!  </IN>
! </SUBROUTINE>
!
subroutine register_fields (Time, axes, nfields, names, family_names)

!--------------------------------------------------------------------
!    register_fields send the relevant information concerning the 
!    user-desired output fields to diag_manager_mod.
!--------------------------------------------------------------------

type(time_type),                 intent(in) :: Time
integer, dimension(4),           intent(in) :: axes
integer,                         intent(in) :: nfields
!character(len=64), dimension(:), intent(in) :: names
character(len=*), dimension(:), intent(in) :: names, family_names

!--------------------------------------------------------------------
!  intent(in) variables:
!
!       Time      current time [ time_type(days, seconds) ]
!       axes      diagnostic variable axes for netcdf files
!       nfields   number of active aerosol species
!       names     names of active aerosol species
!       family_names  
!                 names of active aerosol families
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      character(len=64), dimension(:), allocatable ::   & 
                                               aerosol_column_names, &
                                              extopdep_column_names, &
                                              absopdep_column_names, &
                                                 extopdep_names, &
                                                 absopdep_names, &
                                             asymdep_column_names, &
                                             asymdep_names, &
                                             asymdep_fam_column_names, &
                                             asymdep_fam_names, &
                                          aerosol_fam_column_names, &
                                         extopdep_fam_column_names, &
                                        absopdep_fam_column_names, &
                                        extopdep_fam_names, &
                                        absopdep_fam_names
      integer, dimension(4)    :: bxes
      integer                  :: n, nl
      integer                  :: nfamilies
      real                     :: trange(2)

!---------------------------------------------------------------------
!   local variables:
!
!       aerosol_column_names
!       bxes                   diagnostic variable axes with elements 
!                              (1:3) valid for variables defined at
!                              flux levels
!       n
!
!--------------------------------------------------------------------
 
!-------------------------------------------------------------------
!    define variable axis array with elements (1:3) valid for variables
!    defined at flux levels.
!-------------------------------------------------------------------
      bxes(1:2) = axes(1:2)
      bxes(3) = axes(4)
      bxes(4) = axes(4)
      trange =(/ 100., 400. /)

!---------------------------------------------------------------------
!    register the potential diagnostic variables from this module.
!    the variables will actually be saved and then output only if
!    they are activated through the input diag_file.
!---------------------------------------------------------------------
      id_radswp = &
         register_diag_field (mod_name, 'radswp', axes(1:3), Time, &
                          'temperature tendency for SW radiation', &
                          'deg_K/sec', missing_value=missing_value)

      id_radp = &
         register_diag_field (mod_name, 'radp', axes(1:3), Time, &
                          'temperature tendency for radiation', &
                          'deg_K/sec', missing_value=missing_value)

      id_temp   = &
         register_diag_field (mod_name, 'temp', axes(1:3), Time, &
                          'temperature field', &
                          'deg_K', missing_value=trange(1), &
                          range=trange)

      id_pressm  = &
         register_diag_field (mod_name, 'pressm', axes(1:3), Time, &
                           'model level pressure', &
                           'Pa', missing_value=missing_value)
 
      id_phalfm  = &
         register_diag_field (mod_name, 'phalfm', bxes(1:3), Time, &
                           'model interface level pressure', &
                           'Pa', missing_value=missing_value)

      id_pfluxm  = &
          register_diag_field (mod_name, 'pfluxm', bxes(1:3), Time, &
                           'radiation flux level pressures', &
                           'Pa', missing_value=missing_value)

        id_dpflux  = &
          register_diag_field (mod_name, 'dpflux', axes(1:3), Time,  &
                           'radiation flux layer thickness', &
                           'hPa', missing_value=missing_value)
   
        id_dphalf  = &
          register_diag_field (mod_name, 'dphalf', axes(1:3), Time,  &
                           'radiation model layer thickness', &
                           'hPa', missing_value=missing_value)
   
        id_ptop  = &
          register_diag_field (mod_name, 'ptop', axes(1:2), Time, &
                           'pressure at model top', &
                           'hPa', missing_value=missing_value)
 

      id_rh2o   = &
         register_diag_field (mod_name, 'rh2o', axes(1:3), Time, &
                          'water vapor mixing ratio', &
                          'kg/kg', missing_value=missing_value)

      id_cldwater = &
         register_diag_field (mod_name, 'cloud_water', axes(1:3), Time,&
                          'cloud water specific humidity', &
                          'kg/kg', missing_value=missing_value)

      id_cldice = &
         register_diag_field (mod_name, 'cloud_ice', axes(1:3), Time,&
                          'cloud ice specific humidity', &
                          'kg/kg', missing_value=missing_value)

      id_cldarea = &
         register_diag_field (mod_name, 'cloud_area', axes(1:3), Time,&
                          'cloud fractional area', &
                          'fraction', missing_value=missing_value)

      id_qo3    = &
         register_diag_field (mod_name, 'qo3', axes(1:3), Time, &
                          'ozone mixing ratio', &
                          'kg/kg', missing_value=missing_value)

      id_qo3v    = &
         register_diag_field (mod_name, 'qo3v', axes(1:3), Time, &
                          'ozone mole fraction', &
                          '1.e-9', missing_value=missing_value)

      id_qo3_col = &
         register_diag_field (mod_name, 'qo3_col', axes(1:2), Time, &
                          'ozone column', &
                          'DU', missing_value=missing_value)

!--------------------------------------------------------------------
!    allocate space for and save aerosol name information.
!--------------------------------------------------------------------
      if (nfields /= 0) then
        naerosol = nfields
        allocate (id_aerosol(naerosol))
        allocate (id_aerosol_column(naerosol)) 
        allocate (aerosol_column_names(naerosol))
        id_sulfate_col_cmip = &
             register_diag_field (mod_name, 'sulfate_col_cmip',  &
                            axes(1:2), Time, 'sulfate_col_cmip',&
                                  'kg/m2', missing_value=missing_value)
        id_sulfate_cmip = &
             register_diag_field (mod_name, 'sulfate_cmip',  &
                            axes(1:3), Time, 'sulfate_cmip',&
                                  'kg/m3', missing_value=missing_value)
        do n = 1,naerosol                           
          aerosol_column_names(n) = TRIM(names(n) ) // "_col"
          if (TRIM(names(n)) == 'so4') then
            nso4 = n
          endif
        end do
        do n = 1,naerosol
          id_aerosol(n)    = &
             register_diag_field (mod_name, TRIM(names(n)), axes(1:3), &
                                  Time, TRIM(names(n)),&
                                  'kg/m3', missing_value=missing_value)
          id_aerosol_column(n)    = &
             register_diag_field (mod_name,   &
                      TRIM(aerosol_column_names(n)), axes(1:2), Time, &
                      TRIM(aerosol_column_names(n)), &
                      'kg/m2', missing_value=missing_value)
        end do
        deallocate (aerosol_column_names)

        allocate (extopdep_names(naerosol))
        allocate (extopdep_column_names(naerosol))
        allocate (absopdep_names(naerosol))
        allocate (absopdep_column_names(naerosol))
        allocate (id_extopdep(naerosol, N_DIAG_BANDS))
        allocate (id_extopdep_column(naerosol, N_DIAG_BANDS))
        allocate (id_absopdep(naerosol, N_DIAG_BANDS))
        allocate (id_absopdep_column(naerosol, N_DIAG_BANDS))
        allocate (id_asymdep(naerosol, N_DIAG_BANDS))
        allocate (id_asymdep_column(naerosol, N_DIAG_BANDS))
        allocate (asymdep_names(naerosol))
        allocate (asymdep_column_names(naerosol))
     do nl=1,N_DIAG_BANDS
        do n = 1,naerosol                           
          extopdep_names(n) =   &
                TRIM(names(n) ) // "_exopdep" // TRIM(band_suffix(nl))
          extopdep_column_names(n) =   &
             TRIM(names(n) ) // "_exopdep_col" // TRIM(band_suffix(nl))
          absopdep_names(n) =   &
             TRIM(names(n) ) // "_abopdep" // TRIM(band_suffix(nl))
          absopdep_column_names(n) =   &
             TRIM(names(n) ) // "_abopdep_col" // TRIM(band_suffix(nl))
          asymdep_names(n) =   &
             TRIM(names(n) ) // "_asymdep" // TRIM(band_suffix(nl))
          asymdep_column_names(n) =   &
             TRIM(names(n) ) // "_asymdep_col" // TRIM(band_suffix(nl))
        end do
        do n = 1,naerosol
          id_extopdep(n,nl)    = &
             register_diag_field (mod_name, TRIM(extopdep_names(n)), axes(1:3), &
                                  Time, TRIM(extopdep_names(n)),&
                                  'dimensionless', missing_value=missing_value)
          id_extopdep_column(n,nl)    = &
             register_diag_field (mod_name,   &
                      TRIM(extopdep_column_names(n)), axes(1:2), Time, &
                      TRIM(extopdep_column_names(n)), &
                      'dimensionless', missing_value=missing_value)
          id_absopdep(n,nl)    = &
             register_diag_field (mod_name, TRIM(absopdep_names(n)), axes(1:3), &
                                  Time, TRIM(absopdep_names(n)),&
                                  'dimensionless', missing_value=missing_value)
          id_absopdep_column(n,nl)    = &
             register_diag_field (mod_name,   &
                      TRIM(absopdep_column_names(n)), axes(1:2), Time, &
                      TRIM(absopdep_column_names(n)), &
                      'dimensionless', missing_value=missing_value)
          id_asymdep(n,nl)    = &
             register_diag_field (mod_name, TRIM(asymdep_names(n)), axes(1:3),&
                                  Time, TRIM(asymdep_names(n)),&
                                  'dimensionless', missing_value=missing_value)
          id_asymdep_column(n,nl)    = &
             register_diag_field (mod_name,   &
                      TRIM(asymdep_column_names(n)), axes(1:2), Time, &
                      TRIM(asymdep_column_names(n)), &
                      'dimensionless', missing_value=missing_value)
        end do
      end do
        deallocate (extopdep_names)
        deallocate (extopdep_column_names)
        deallocate (absopdep_names)
        deallocate (absopdep_column_names)
        deallocate (asymdep_names)
        deallocate (asymdep_column_names)
      endif

      if (size(family_names(:)) /= 0) then
        nfamilies = size(family_names(:))
        allocate (id_aerosol_fam(nfamilies))
        allocate (id_aerosol_fam_column(nfamilies)) 
        allocate (aerosol_fam_column_names(naerosol))
        do n=1,nfamilies      
          aerosol_fam_column_names(n) = TRIM(family_names(n) ) // "_col"
        end do
        do n = 1,nfamilies
          id_aerosol_fam(n)    = &
             register_diag_field (mod_name, TRIM(family_names(n)), axes(1:3), &
                                  Time, TRIM(family_names(n)),&
                                  'kg/m3', missing_value=missing_value)
          id_aerosol_fam_column(n)    = &
             register_diag_field (mod_name,   &
                      TRIM(aerosol_fam_column_names(n)), axes(1:2), Time, &
                      TRIM(aerosol_fam_column_names(n)), &
                      'kg/m2', missing_value=missing_value)
        end do
        deallocate (aerosol_fam_column_names)


        allocate (id_extopdep_fam(nfamilies, N_DIAG_BANDS))
        allocate (id_extopdep_fam_column(nfamilies, N_DIAG_BANDS))
        allocate (id_absopdep_fam(nfamilies, N_DIAG_BANDS))
        allocate (id_absopdep_fam_column(nfamilies, N_DIAG_BANDS))
        allocate (extopdep_fam_names(naerosol))
        allocate (extopdep_fam_column_names(naerosol))
        allocate (absopdep_fam_names(naerosol))
        allocate (absopdep_fam_column_names(naerosol))
        allocate (id_asymdep_fam(nfamilies, N_DIAG_BANDS))
        allocate (id_asymdep_fam_column(nfamilies, N_DIAG_BANDS))
        allocate (asymdep_fam_names(naerosol))
        allocate (asymdep_fam_column_names(naerosol))
   do nl=1,N_DIAG_BANDS
        do n=1,nfamilies      
          extopdep_fam_names(n) =   &
           TRIM(family_names(n) ) // "_exopdep" // TRIM(band_suffix(nl))
          extopdep_fam_column_names(n) =   &
       TRIM(family_names(n) ) // "_exopdep_col" // TRIM(band_suffix(nl))
          absopdep_fam_names(n) =   &
          TRIM(family_names(n) ) // "_abopdep" // TRIM(band_suffix(nl))
          absopdep_fam_column_names(n) =  &
       TRIM(family_names(n) ) // "_abopdep_col" // TRIM(band_suffix(nl))
          asymdep_fam_names(n) =   &
          TRIM(family_names(n) ) // "_asymdep" // TRIM(band_suffix(nl))
          asymdep_fam_column_names(n) =  &
       TRIM(family_names(n) ) // "_asymdep_col" // TRIM(band_suffix(nl))
        end do
        do n = 1,nfamilies
          id_extopdep_fam(n,nl)    = &
             register_diag_field (mod_name, TRIM(extopdep_fam_names(n)), axes(1:3), &
                                  Time, TRIM(extopdep_fam_names(n)),&
                                  'dimensionless', missing_value=missing_value)
          id_extopdep_fam_column(n,nl)    = &
             register_diag_field (mod_name,   &
                      TRIM(extopdep_fam_column_names(n)), axes(1:2), Time, &
                      TRIM(extopdep_fam_column_names(n)), &
                      'dimensionless', missing_value=missing_value)
          id_absopdep_fam(n,nl)    = &
             register_diag_field (mod_name, TRIM(absopdep_fam_names(n)), axes(1:3), &
                                  Time, TRIM(absopdep_fam_names(n)),&
                                  'dimensionless', missing_value=missing_value)
          id_absopdep_fam_column(n,nl)    = &
             register_diag_field (mod_name,   &
                      TRIM(absopdep_fam_column_names(n)), axes(1:2), Time, &
                      TRIM(absopdep_fam_column_names(n)), &
                      'dimensionless', missing_value=missing_value)
          id_asymdep_fam(n,nl)    = &
             register_diag_field(mod_name,TRIM(asymdep_fam_names(n)),axes(1:3),&
                      Time, TRIM(asymdep_fam_names(n)),&
                     'dimensionless', missing_value=missing_value)
          id_asymdep_fam_column(n,nl)    = &
             register_diag_field (mod_name,   &
                      TRIM(asymdep_fam_column_names(n)), axes(1:2), Time, &
                      TRIM(asymdep_fam_column_names(n)), &
                      'dimensionless', missing_value=missing_value)
        end do
   end do
        deallocate (extopdep_fam_names)
        deallocate (extopdep_fam_column_names)
        deallocate (absopdep_fam_names)
        deallocate (absopdep_fam_column_names)
        deallocate (asymdep_fam_names)
        deallocate (asymdep_fam_column_names)
      endif
      
      if (Rad_control%volcanic_lw_aerosols_iz) then
        if (Rad_control%volcanic_lw_aerosols) then
          id_lw_extopdep_vlcno_column(1) = &
             register_diag_field (mod_name,   &
                    'lw_b5_extopdep_vlcno_c', axes(1:2), Time, &
                    'lw 900-990 band column volcanic extopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_lw_absopdep_vlcno_column(1)    = &
             register_diag_field (mod_name,   &
                    'lw_b5_absopdep_vlcno_c', axes(1:2), Time, &
                    'lw 900-990 band column volcanic absopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_lwext_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'bnd5_extopdep_vlcno', axes(1:3), Time, &
                    '900-990 band volcanic lw extopdep  ',  &
                      'dimensionless', missing_value=missing_value)
          id_lw_xcoeff_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'bnd5_lwext_vlcno', axes(1:3), Time, &
                    '900-990 band volcanic lw extinction',  &
                      'meter**(-1)  ', missing_value=missing_value)
          id_lwssa_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'bnd5_lwssa_vlcno', axes(1:3), Time, &
                    '900-990   band volcanic lw scattering albedo', &
                      'dimensionless', missing_value=missing_value)
          id_lwasy_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'bnd5_lwasy_vlcno', axes(1:3), Time, &
                    '900-990 band volcanic lw asymmetry',  &
                      'dimensionless', missing_value=missing_value)
          id_lw_extopdep_vlcno_column(2) = &
             register_diag_field (mod_name,   &
                    'bnd6_extopdep_vlcno_c', axes(1:2), Time, &
                    '990-1070 column volcanic extopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_lw_absopdep_vlcno_column(2)    = &
             register_diag_field (mod_name,   &
                    'bnd6_absopdep_vlcno_c', axes(1:2), Time, &
                    '990-1070 column volcanic absopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_lwext_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'bnd6_extopdep_vlcno', axes(1:3), Time, &
                    '990-1070 volcanic lw extopdep  ',  &
                      'dimensionless', missing_value=missing_value)
          id_lw_xcoeff_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'bnd6_lwext_vlcno', axes(1:3), Time, &
                    '990-1070 volcanic lw extinction',  &
                      'meter**(-1)  ', missing_value=missing_value)
          id_lwssa_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'bnd6_lwssa_vlcno', axes(1:3), Time, &
                    '990-1070 volcanic lw scattering albedo',  &
                      'dimensionless', missing_value=missing_value)
          id_lwasy_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'bnd6_lwasy_vlcno', axes(1:3), Time, &
                    '990-1070 volcanic lw asymmetry',  &
                      'dimensionless', missing_value=missing_value)
        endif
      else 
        call error_mesg ('rad_output_file_mod', &
            'Rad_control%volcanic_lw_aerosols not yet defined', FATAL)
      endif
      if (Rad_control%volcanic_sw_aerosols_iz) then
        if (Rad_control%volcanic_sw_aerosols) then
          id_extopdep_vlcno_column(1) = &
             register_diag_field (mod_name,   &
                    'vis_extopdep_vlcno_c', axes(1:2), Time, &
                    'visband column volcanic extopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_absopdep_vlcno_column(1)    = &
             register_diag_field (mod_name,   &
                    'vis_absopdep_vlcno_c', axes(1:2), Time, &
                    'visband column volcanic absopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_swext_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'visband_swextopdep_vlcno', axes(1:3), Time, &
                    'visband volcanic sw extopdep  ',  &
                      'dimensionless', missing_value=missing_value)
          id_sw_xcoeff_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'visband_swext_vlcno', axes(1:3), Time, &
                    'visband volcanic sw extinction',  &
                      'meter**(-1)', missing_value=missing_value)
          id_swssa_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'visband_swssa_vlcno', axes(1:3), Time, &
                    'visband volcanic sw scattering albedo',  &
                      'dimensionless', missing_value=missing_value)
          id_swasy_vlcno(1)    = &
             register_diag_field (mod_name,   &
                    'visband_swasy_vlcno', axes(1:3), Time, &
                    'visband volcanic sw asymmetry',  &
                      'dimensionless', missing_value=missing_value)
          id_extopdep_vlcno_column(2) = &
             register_diag_field (mod_name,   &
                    'nir_extopdep_vlcno_c', axes(1:2), Time, &
                    'nirband column volcanic extopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_absopdep_vlcno_column(2)    = &
             register_diag_field (mod_name,   &
                    'nir_absopdep_vlcno_c', axes(1:2), Time, &
                    'nirband column volcanic absopdep',  &
                      'dimensionless', missing_value=missing_value)
          id_swext_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'nirband_swextopdep_vlcno', axes(1:3), Time, &
                    'nirband volcanic sw extopdep  ',  &
                      'dimensionless', missing_value=missing_value)
          id_sw_xcoeff_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'nirband_swext_vlcno', axes(1:3), Time, &
                    'nirband volcanic sw extinction',  &
                      'meter**(-1)', missing_value=missing_value)
          id_swssa_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'nirband_swssa_vlcno', axes(1:3), Time, &
                    'nirband volcanic sw scattering albedo',  &
                      'dimensionless', missing_value=missing_value)
          id_swasy_vlcno(2)    = &
             register_diag_field (mod_name,   &
                    'nirband_swasy_vlcno', axes(1:3), Time, &
                    'nirband volcanic sw asymmetry',  &
                      'dimensionless', missing_value=missing_value)
          id_swheat_vlcno    = &
             register_diag_field (mod_name,   &
                    'sw_heating_vlcno', axes(1:3), Time, &
                    'sw heating due to vlcnic aero',  &
                      'deg K per day', missing_value=missing_value)
        endif
      else 
        call error_mesg ('rad_output_file_mod', &
           'Rad_control%volcanic_sw_aerosols not yet defined', FATAL)
      endif


      id_cmxolw = &
         register_diag_field (mod_name, 'cmxolw', axes(1:3), Time, &
                          'maximum overlap cloud amount', &
                          'percent', missing_value=missing_value)

      id_crndlw = &
         register_diag_field (mod_name, 'crndlw', axes(1:3), Time, &
                          'random overlap cloud amount', &
                          'percent', missing_value=missing_value)

      id_flxnet = &
         register_diag_field (mod_name, 'flxnet', bxes(1:3), Time, &
                          'net longwave radiative flux', &
                          'W/m**2', missing_value=missing_value)

      id_fsw    = &
         register_diag_field (mod_name, 'fsw', bxes(1:3), Time, &
                          'net shortwave radiative flux', &
                          'W/m**2', missing_value=missing_value)

      id_ufsw   = &
         register_diag_field (mod_name, 'ufsw', bxes(1:3), Time, &
                          'upward shortwave radiative flux ', &
                          'W/m**2', missing_value=missing_value)

      id_dfsw   = &
         register_diag_field (mod_name, 'dfsw', bxes(1:3), Time, &
                          'downward shortwave radiative flux ', &
                          'W/m**2', missing_value=missing_value)

      id_psj    = &
         register_diag_field (mod_name, 'psj', axes(1:2), Time, &
                          'surface pressure', &
                          'Pa', missing_value=missing_value)

      id_tmpsfc = &
         register_diag_field (mod_name, 'tmpsfc', axes(1:2), Time, &
                          'surface temperature', &
                          'deg_K', missing_value=missing_value)

      id_cvisrfgd_dir = &
         register_diag_field (mod_name, 'cvisrfgd_dir', axes(1:2), Time , &
                         'direct visible surface albedo', &
                        'dimensionless', missing_value=missing_value)

       id_cvisrfgd_dif = &
       register_diag_field (mod_name, 'cvisrfgd_dif', axes(1:2), Time, &
                          'diffuse visible surface albedo', &
                          'dimensionless', missing_value=missing_value)
 
       id_cirrfgd_dir = &
        register_diag_field (mod_name, 'cirrfgd_dir', axes(1:2), Time, &
                       'direct infra-red surface albedo', &
                       'dimensionless', missing_value=missing_value)

       id_cirrfgd_dif = &
         register_diag_field (mod_name, 'cirrfgd_dif', axes(1:2), Time, &
                       'diffuse infra-red surface albedo', &
                      'dimensionless', missing_value=missing_value)

       id_lw_bdyflx(1) = &
         register_diag_field (mod_name, 'olr_800_1200', axes(1:2), Time, &
                       'olr in 800_1200  band', &
                      'W/m**2', missing_value=missing_value)

       id_lw_bdyflx(2) = &
         register_diag_field (mod_name, 'olr_900_990', axes(1:2), Time, &
                       'olr in 800_900  band', &
                      'W/m**2', missing_value=missing_value)

       id_lw_bdyflx(3) = &
         register_diag_field (mod_name, 'sfc_800_1200', axes(1:2),&
                             Time, 'lw sfc flx in 800_1200  band', &
                      'W/m**2', missing_value=missing_value)

       id_lw_bdyflx(4) = &
         register_diag_field (mod_name, 'sfc_900_990', axes(1:2), &
                              Time, 'lw sfc flx in 900_990 band', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx(1) = &
         register_diag_field (mod_name, 'swup_toa_vis', axes(1:2),  &
                       Time, &
                       'sw up flx in vis band at toa', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx(2) = &
         register_diag_field (mod_name, 'swup_toa_1p6', axes(1:2),  &
                       Time, &
                       'sw up flx in 1.6 micron band at toa', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx(3) = &
         register_diag_field (mod_name, 'swnt_sfc_vis', axes(1:2),  &
                       Time, &
                       'net sw flx in vis band at sfc', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx(4) = &
         register_diag_field (mod_name, 'swnt_sfc_1p6', axes(1:2),  &
                       Time, &
                       'net sw flx in 1.6 micron band at sfc', &
                      'W/m**2', missing_value=missing_value)

!-------------------------------------------------------------------
!    verify that Rad_control%do_totcld_forcing has been initialized.
!-------------------------------------------------------------------
      if (Rad_control%do_totcld_forcing_iz) then
      else
        call error_mesg ('rad_output_file_mod', &
         ' attempting to use Rad_control%do_totcld_forcing before'//&
                                                ' it is set', FATAL)
      endif

      if (Rad_control%do_totcld_forcing) then
        id_radswpcf = &
           register_diag_field (mod_name, 'radswpcf', axes(1:3), Time, &
                            'temperature forcing from sw w/o clouds', &
                            'deg_K/sec', missing_value=missing_value)

        id_radpcf = &
           register_diag_field (mod_name, 'radpcf', axes(1:3), Time, &
                            'temperature forcing w/o clouds', &
                            'deg_K/sec', missing_value=missing_value)

        id_flxnetcf = &
           register_diag_field (mod_name, 'flxnetcf', bxes(1:3), Time, &
                            'net longwave flux w/o clouds', &
                            'W/m**2', missing_value=missing_value)

        id_fswcf = &
           register_diag_field (mod_name, 'fswcf', bxes(1:3), Time, &
                            'net shortwave flux w/o clouds', &
                            'W/m**2', missing_value=missing_value)

        id_ufswcf   = &
           register_diag_field (mod_name, 'ufswcf', bxes(1:3), Time, &
                            'upward shortwave flux w/o clouds', &
                            'W/m**2', missing_value=missing_value)

        id_dfswcf   = &
           register_diag_field (mod_name, 'dfswcf', bxes(1:3), Time, &
                            'downward shortwave flux w/o clouds', &
                            'W/m**2', missing_value=missing_value)

       id_lw_bdyflx_clr(1) = &
         register_diag_field (mod_name, 'olr_800_1200_cf', axes(1:2), Time, &
                       'clr sky olr in 800_1200  band', &
                      'W/m**2', missing_value=missing_value)

       id_lw_bdyflx_clr(2) = &
         register_diag_field (mod_name, 'olr_900_990_cf', axes(1:2), Time, &
                       'clr sky olr in 800_900  band', &
                      'W/m**2', missing_value=missing_value)

       id_lw_bdyflx_clr(3) = &
         register_diag_field (mod_name, 'sfc_800_1200_cf', axes(1:2),&
                             Time, 'clr sky lw sfc flx in 800_1200 band', &
                      'W/m**2', missing_value=missing_value)

       id_lw_bdyflx_clr(4) = &
         register_diag_field (mod_name, 'sfc_900_990_cf', axes(1:2), &
                              Time, 'clr sky lw sfc flx in 900_990 band', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx_clr(1) = &
         register_diag_field (mod_name, 'swup_toa_vis_cf', axes(1:2),  &
                       Time, &
                       'clr sky sw up flx in vis band at toa', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx_clr(2) = &
         register_diag_field (mod_name, 'swup_toa_1p6_cf', axes(1:2),  &
                       Time, &
                       'clr sky sw up flx in 1.6 micron band at toa', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx_clr(3) = &
         register_diag_field (mod_name, 'swnt_sfc_vis_cf', axes(1:2),  &
                       Time, &
                       'clr sky net sw flx in vis band at sfc', &
                      'W/m**2', missing_value=missing_value)

       id_sw_bdyflx_clr(4) = &
         register_diag_field (mod_name, 'swnt_sfc_1p6_cf', axes(1:2),  &
                       Time, &
                       'clr sky net sw flx in 1.6 micron band at sfc', &
                      'W/m**2', missing_value=missing_value)

      endif

!---------------------------------------------------------------------


end subroutine register_fields


!####################################################################





                  end module rad_output_file_mod


 
               module rad_utilities_mod
!
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!  smf
! </REVIEWER>
! 
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  Code to define the derived data types and provide table search routines.
! </OVERVIEW>
! <DESCRIPTION>
!  This code is used in the radiation code package as a helper module.
!  It defines many derived data types used in radiation calculation.
!  This code also provides table search routines and simple arithmatic
!  routines.
! </DESCRIPTION>
!
use mpp_mod,            only : input_nml_file
use fms_mod,            only : open_namelist_file, fms_init, &
                               mpp_pe, mpp_root_pe, stdlog, &
                               file_exist, write_version_number, &
                               check_nml_error, error_mesg, &
                               FATAL, close_file, lowercase
use  field_manager_mod, only : parse

use time_manager_mod,   only : time_type

!--------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    rad_utilities_mod contains radiation table search routines,
!    some band averaging routines, and the derived-type variables 
!    used in the radiation package.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

character(len=128)  :: version =  '$Id: rad_utilities.F90,v 18.0.2.1.2.1.2.1 2010/08/30 20:33:33 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

public      &
          rad_utilities_init, check_derived_types, & 
          locate_in_table,  &
          looktab, table_alloc, &
          thickavg, thinavg,   &
          rad_utilities_end,   &
          get_radiative_param, assignment(=)

interface looktab
    module procedure  looktab_type1, looktab_type2, looktab_type3
end interface

interface table_alloc
   module procedure    table1_alloc, table2_alloc, table3_alloc
end interface

interface thickavg
   module procedure thickavg_3d
   module procedure thickavg_0d
   module procedure thickavg_1band
   module procedure thickavg_isccp
end interface

interface assignment(=)
  module procedure lw_output_type_eq
  module procedure sw_output_type_eq
  module procedure aerosol_props_type_eq
end interface

!------------------------------------------------------------------

public   aerosol_type              
  
!    aerosol
!    aerosol_names
!    family_members

type aerosol_type
     real, dimension(:,:,:,:),        pointer :: aerosol=>NULL()
     logical, dimension(:,:),        pointer :: family_members=>NULL()
     character(len=64), dimension(:), pointer :: aerosol_names=>NULL()
end type aerosol_type              

!------------------------------------------------------------------
 
public   aerosol_diagnostics_type
 
!    extopdep
!    absopdep
!    extopdep_vlcno
!    absopdep_vlcno
!    lw_extopdep_vlcno
!    lw_absopdep_vlcno
!    sw_heating_vlcno
 
type aerosol_diagnostics_type
!    real, dimension(:,:,:),   pointer  :: sw_heating_vlcno=>NULL()
     real, dimension(:,:,:,:),   pointer  :: sw_heating_vlcno=>NULL()
     real, dimension(:,:,:,:,:), pointer  :: extopdep=>NULL(), &
                                             absopdep=>NULL()
     real, dimension(:,:,:,:,:), pointer  :: asymdep=>NULL()

     real, dimension(:,:,:,:), pointer  :: extopdep_vlcno=>NULL(), &
                                           absopdep_vlcno=>NULL(), &
                                           lw_extopdep_vlcno=>NULL(), &
                                           lw_absopdep_vlcno=>NULL()
 
end type aerosol_diagnostics_type
 
!------------------------------------------------------------------

public   aerosol_properties_type

!    aerextband
!    aerssalbband
!    aerasymmband
!    aerextbandlw
!    aerssalbbandlw
!    sulfate_index
!    optical_index

type aerosol_properties_type
     integer, dimension(:,:,:), pointer  :: ivol=>NULL()
     real, dimension(:,:), pointer  :: aerextband=>NULL(),   &
                                       aerssalbband=>NULL(), &
                                       aerasymmband=>NULL(), &
                                       aerextbandlw=>NULL(), &
                                       aerssalbbandlw=>NULL(), &
                                       aerextbandlw_cn=>NULL(), &
                                       aerssalbbandlw_cn=>NULL()
     real, dimension(:,:,:,:), pointer :: sw_ext=>NULL(), &
                                          sw_ssa=>NULL(), &
                                          sw_asy=>NULL(), &
                                          lw_ext=>NULL(), &
                                          lw_ssa=>NULL(), &
                                          lw_asy=>NULL()
!yim
     integer, dimension(:,:), pointer :: sulfate_index=>NULL()
     integer, dimension(:), pointer :: optical_index=>NULL()
     integer, dimension(:), pointer :: omphilic_index=>NULL()
     integer, dimension(:), pointer :: bcphilic_index=>NULL()
     integer, dimension(:), pointer :: seasalt1_index=>NULL()
     integer, dimension(:), pointer :: seasalt2_index=>NULL()
     integer, dimension(:), pointer :: seasalt3_index=>NULL()
     integer, dimension(:), pointer :: seasalt4_index=>NULL()
     integer, dimension(:), pointer :: seasalt5_index=>NULL()
     integer                        :: sulfate_flag
     integer                        :: omphilic_flag
     integer                        :: bcphilic_flag
     integer                        :: seasalt1_flag
     integer                        :: seasalt2_flag
     integer                        :: seasalt3_flag
     integer                        :: seasalt4_flag
     integer                        :: seasalt5_flag
!yim
     integer                        :: bc_flag
end type aerosol_properties_type

!------------------------------------------------------------------

public astronomy_type
    
!    solar
!    cosz
!    fracday
!    rrsun

type astronomy_type
     real, dimension(:,:), pointer  :: solar=>NULL(),   &
                                       cosz=>NULL(),  &
                                       fracday=>NULL()
     real, dimension(:,:,:), pointer  :: solar_p=>NULL(),   &
                                       cosz_p=>NULL(),  &
                                       fracday_p=>NULL()
     real    :: rrsun
end type astronomy_type

!--------------------------------------------------------------------
 
public astronomy_inp_type
 
!    zenith_angle   specified zenith angles [ degrees ]
!    fracday        specified daylight fraction [ fraction ]
!    rrsun          specified earth-sun distance, normalized by mean
!                   distance 

type astronomy_inp_type
     real, dimension(:,:), pointer  :: zenith_angle=>NULL()
     real, dimension(:,:), pointer  :: fracday=>NULL()
     real                           :: rrsun
end type astronomy_inp_type

!--------------------------------------------------------------------

public atmos_input_type

!    press
!    temp
!    rh2o
!    zfull
!    pflux
!    tflux
!    deltaz
!    phalf
!    rel_hum
!    cloudtemp
!    clouddeltaz
!    cloudvapor
!    aerosoltemp
!    aerosolvapor
!    aerosolpress
!    aerosolrelhum
!    tracer_co2
!    g_rrvco2
!    tsfc
!    psfc

type atmos_input_type
     real, dimension(:,:,:), pointer :: press=>NULL(),   &
                                        temp=>NULL(), &
                                        rh2o=>NULL(),  &
                                        zfull=>NULL(),  &
                                        pflux=>NULL(), &
                                        tflux=>NULL(),  &
                                        deltaz=>NULL(),  &
                                        phalf=>NULL(),   &
                                        rel_hum=>NULL(), &
                                        cloudtemp=>NULL(),   &
                                        clouddeltaz=>NULL(), &
                                        cloudvapor=>NULL(), &
                                        aerosoltemp=>NULL(), &
                                        aerosolvapor=>NULL(), &
                                        aerosolpress=>NULL(), &
                                        aerosolrelhum=>NULL(), &
                                        tracer_co2 => NULL()
     real, dimension(:,:),   pointer :: tsfc=>NULL(),   &
                                        psfc=>NULL()              
     real                            :: g_rrvco2
end type atmos_input_type

!-------------------------------------------------------------------

public cldrad_properties_type

!    cldext
!    cldasymm
!    cldsct
!    emmxolw
!    emrndlw
!    abscoeff
!    cldemiss
!    cirabsw
!    cirrfsw
!    cvisrfsw

type cldrad_properties_type
     real, dimension(:,:,:,:,:), pointer :: cldext=>NULL(),   &
                                          cldasymm=>NULL(), &
                                          cldsct=>NULL()
     real, dimension(:,:,:,:,:), pointer ::                   &
                                          emmxolw=>NULL(), &
                                          emrndlw=>NULL(),  &
                                          abscoeff=>NULL(),  &
                                          cldemiss=>NULL()
     real, dimension(:,:,:), pointer ::   cirabsw=>NULL(), &
                                          cirrfsw=>NULL(),   &
                                          cvisrfsw=>NULL()
end type cldrad_properties_type

!------------------------------------------------------------------

public cld_space_properties_type

!    camtswkc
!    cirabswkc
!    cirrfswkc
!    cvisrfswkc
!    ktopswkc
!    kbtmswkc

type cld_space_properties_type
     real, dimension(:,:,:),    pointer :: camtswkc=>NULL()        
     real, dimension(:,:,:),    pointer :: cirabswkc=>NULL(),  &
                                           cirrfswkc=>NULL(), &
                                           cvisrfswkc=>NULL()
     integer, dimension(:,:,:), pointer :: ktopswkc=>NULL(),   &
                                           kbtmswkc=>NULL()
end type cld_space_properties_type

!------------------------------------------------------------------

public cld_specification_type

!    tau
!    lwp
!    iwp
!    reff_liq
!    reff_ice
!    liq_frac
!    cloud_water
!    cloud_ice
!    cloud_area
!    cloud_droplet
!    reff_liq_micro
!    reff_ice_micro
!    camtsw
!    cmxolw
!    crndlw
!    cld_thickness
!    ncldsw
!    nmxolw
!    nrndlw
!    hi_cloud
!    mid_cloud
!    low_cloud
!    ice_cloud

type cld_specification_type
   real, dimension(:,:,:,:),  pointer :: tau=>NULL(),  &
                                         camtsw_band=>NULL(), &
                                         crndlw_band=>NULL(), &
                                         lwp_lw_band=>NULL(), &
                                         iwp_lw_band=>NULL(), &
                                         lwp_sw_band=>NULL(), &
                                         iwp_sw_band=>NULL(), &
                                         reff_liq_lw_band=>NULL(),   &
                                         reff_ice_lw_band=>NULL(), &
                                         reff_liq_sw_band=>NULL(),   &
                                         reff_ice_sw_band=>NULL()
   real, dimension(:,:,:),    pointer :: lwp=>NULL(),   &
                                         iwp=>NULL(),  &
                                         reff_liq=>NULL(),   &
                                         reff_ice=>NULL(), &
                                         reff_liq_lim=>NULL(),   &
                                         reff_ice_lim=>NULL(), &
                                         liq_frac=>NULL(), &
                                         cloud_water=>NULL(), &
                                         cloud_ice=>NULL(),  &
                                         cloud_area=>NULL(), &
					 cloud_droplet=>NULL(), &
                                         reff_liq_micro=>NULL(),   &
                                         reff_ice_micro=>NULL(),&
                                         camtsw=>NULL(),   &
                                         cmxolw=>NULL(),  &
                                         crndlw=>NULL()
   integer, dimension(:,:,:), pointer :: cld_thickness=>NULL()
   integer, dimension(:,:,:,:), pointer :: stoch_cloud_type=>NULL()
   integer, dimension(:,:,:,:), pointer :: cld_thickness_lw_band=>NULL()
   integer, dimension(:,:,:,:), pointer :: cld_thickness_sw_band=>NULL()
   integer, dimension(:,:),   pointer :: ncldsw=>NULL(),   &
                                         nmxolw=>NULL(),&
                                         nrndlw=>NULL()
   integer, dimension(:,:,:), pointer :: ncldsw_band=>NULL(),   &
                                         nrndlw_band=>NULL()
   logical, dimension(:,:,:), pointer :: hi_cloud=>NULL(),   &
                                         mid_cloud=>NULL(),  &
                                         low_cloud=>NULL(),   &
                                         ice_cloud=>NULL()
end type cld_specification_type

!------------------------------------------------------------------

public cloudrad_control_type

type cloudrad_control_type
    logical :: do_pred_cld_microphys
    logical :: do_presc_cld_microphys
    logical :: do_bulk_microphys
    logical :: do_sw_micro
    logical :: do_lw_micro
    logical :: do_rh_clouds        
    logical :: do_strat_clouds        
    logical :: do_zonal_clouds        
    logical :: do_mgroup_prescribed
    logical :: do_obs_clouds        
    logical :: do_no_clouds        
    logical :: do_diag_clouds        
    logical :: do_specified_clouds        
    logical :: do_donner_deep_clouds
    logical :: do_uw_clouds
    logical :: do_zetac_clouds
    logical :: do_random_overlap
    logical :: do_max_random_overlap
    logical :: do_stochastic_clouds
    logical :: use_temp_for_seed
    logical :: do_specified_strat_clouds
    logical :: do_ica_calcs
    logical :: do_liq_num
    logical :: using_fu2007
    integer :: nlwcldb                   !   number of frequency bands 
                                         !   for which lw cloud emissiv-
                                         !   ities are defined.
    integer :: cloud_data_points
    integer :: ich
    integer :: icm
    integer :: ict
    integer :: icb
    logical :: do_pred_cld_microphys_iz
    logical :: do_presc_cld_microphys_iz
    logical :: do_bulk_microphys_iz
    logical :: do_sw_micro_iz
    logical :: do_lw_micro_iz
    logical :: do_rh_clouds_iz
    logical :: do_strat_clouds_iz
    logical :: do_zonal_clouds_iz
    logical :: do_mgroup_prescribed_iz
    logical :: do_obs_clouds_iz
    logical :: do_no_clouds_iz
    logical :: do_diag_clouds_iz
    logical :: do_specified_clouds_iz
    logical :: do_donner_deep_clouds_iz
    logical :: do_uw_clouds_iz
    logical :: do_zetac_clouds_iz
    logical :: do_random_overlap_iz
    logical :: do_max_random_overlap_iz
    logical :: do_stochastic_clouds_iz
    logical :: use_temp_for_seed_iz
    logical :: do_specified_strat_clouds_iz
    logical :: do_ica_calcs_iz
    logical :: do_liq_num_iz
    logical :: using_fu2007_iz
end type cloudrad_control_type

!------------------------------------------------------------------

public fsrad_output_type

!    tdtsw
!    tdtlw
!    tdtsw_clr
!    tdtlw_clr
!    swdns
!    swups
!    lwdns
!    lwups
!    swin
!    swout
!    olr
!    swdns_clr
!    swups_clr
!    lwdns_clr
!    lwups_clr`
!    swin_clr
!    swout_clr
!    olr_clr
!    npass

type fsrad_output_type
     real, dimension(:,:,:), pointer :: tdtsw=>NULL(), &
                                        tdtlw=>NULL(),  &
                                        tdtsw_clr=>NULL(),  &
                                        tdtlw_clr=>NULL()
     real, dimension(:,:),   pointer :: swdns=>NULL(),   &
                                        swups=>NULL(),  &
                                        lwups=>NULL(), &
                                        lwdns=>NULL(), &
                                        swin=>NULL(), &
                                        swout=>NULL(), &
                                        olr=>NULL(), &
                                        swdns_clr=>NULL(),  &
                                        swups_clr=>NULL(),  &
                                        lwups_clr=>NULL(),&
                                        lwdns_clr=>NULL(),   &
                                        swin_clr=>NULL(),  &
                                        swout_clr=>NULL(), &
                                        olr_clr=>NULL()
     integer      :: npass
end type fsrad_output_type

!-------------------------------------------------------------------

public gas_tf_type

!    tdav
!    tlsqu
!    tmpdiff
!    tstdav
!    co2nbl
!    n2o9c
!    tn2o17
!    co2spnb
!    a1
!    a2

type gas_tf_type
     real, dimension(:,:,:),   pointer :: tdav=>NULL(),   &
                                          tlsqu=>NULL(),   &
                                          tmpdiff=>NULL(),   &
                                          tstdav=>NULL(),  &
                                          co2nbl=>NULL(),   &
                                          n2o9c=>NULL(),   &
                                          tn2o17=>NULL()
     real, dimension(:,:,:,:), pointer :: co2spnb=>NULL()
     real, dimension(:,:),     pointer :: a1=>NULL(),    &
                                          a2=>NULL()
end type gas_tf_type

!------------------------------------------------------------------

public longwave_control_type 

type longwave_control_type
    character(len=16) :: lw_form
    character(len=16) :: continuum_form
    character(len=16) :: linecatalog_form
    logical           :: do_cfc
    logical           :: do_lwaerosol
    logical           :: do_ch4
    logical           :: do_n2o
    logical           :: do_ch4lbltmpint
    logical           :: do_n2olbltmpint
    logical           :: do_co2
    logical           :: do_lwcldemiss
    logical           :: do_h2o
    logical           :: do_o3 
    logical           :: do_cfc_iz
    logical           :: do_lwaerosol_iz
    logical           :: do_ch4_iz
    logical           :: do_n2o_iz
    logical           :: do_ch4lbltmpint_iz
    logical           :: do_n2olbltmpint_iz
    logical           :: do_co2_iz
    logical           :: do_lwcldemiss_iz
    logical           :: do_h2o_iz
    logical           :: do_o3_iz 
end type longwave_control_type

!---------------------------------------------------------------------

public longwave_parameter_type

type longwave_parameter_type
     integer   :: offset
     integer   :: NBTRG
     integer   :: NBTRGE
     integer   :: NBLY
     integer   :: n_lwaerosol_bands
     real      :: lw_band_resolution
     logical   :: offset_iz
     logical   :: NBTRG_iz
     logical   :: NBTRGE_iz
     logical   :: NBLY_iz
     logical   :: n_lwaerosol_bands_iz
     logical   :: lw_band_resolution_iz
end type longwave_parameter_type

!--------------------------------------------------------------------

public longwave_tables1_type

!    vae
!    td
!    md
!    cd

type longwave_tables1_type
    real, dimension(:,:), pointer  ::  vae=>NULL(),   &
                                       td=>NULL(), &
                                       md=>NULL(), &
                                       cd=>NULL()
end type longwave_tables1_type

!--------------------------------------------------------------------

public longwave_tables2_type

!    vae
!    td
!    md
!    cd

type longwave_tables2_type
    real, dimension(:,:,:), pointer  ::  vae=>NULL(),  &
                                         td=>NULL(),  &
                                         md=>NULL(),   &
                                         cd=>NULL()
end type longwave_tables2_type

!---------------------------------------------------------------------

public longwave_tables3_type

!    vae
!    td

type longwave_tables3_type
     real,  dimension(:,:), pointer    ::  vae=>NULL(),   &
                                           td=>NULL()          
end type longwave_tables3_type

!---------------------------------------------------------------------

public lw_clouds_type

!    taucld_rndlw
!    taucld_mxolw
!    taunbl_mxolw

type lw_clouds_type
     real, dimension(:,:,:,:),   pointer :: taucld_rndlw=>NULL(), &
                                            taucld_mxolw=>NULL(), &
                                            taunbl_mxolw=>NULL()
end type lw_clouds_type

!------------------------------------------------------------------

public lw_diagnostics_type

!    flx1e1
!    gxcts
!    flx1e1f
!    excts
!    fctsg
!    fluxn
!    fluxncf
!    exctsn
!    cts_out
!    cts_outcf

type lw_diagnostics_type
     real, dimension(:,:),   pointer   :: flx1e1=>NULL(),  &
                                          gxcts=>NULL()
     real, dimension(:,:,:), pointer   :: flx1e1f=>NULL(),  &
                                          excts=>NULL(),&
                                          fctsg=>NULL()
     real, dimension(:,:,:,:), pointer :: fluxn=>NULL(),   &
                                          fluxncf=>NULL(),   &
                                          exctsn=>NULL(),  &
                                          cts_out=>NULL(), &
                                          cts_outcf=>NULL()
end type lw_diagnostics_type

!-------------------------------------------------------------------

public lw_output_type

!    heatra
!    flxnet
!    heatracf
!    flxnetcf
!    netlw_special
!    netlw_special_clr

type lw_output_type
     real, dimension(:,:,:), pointer :: heatra=>NULL(), &
                                        flxnet=>NULL(),  &
                                        heatracf=>NULL(), &
                                        flxnetcf=>NULL()
     real, dimension(:,:,:), pointer   :: netlw_special=>NULL(), &
                                          netlw_special_clr=>NULL(), &
                                          bdy_flx=>NULL(), &
                                          bdy_flx_clr=>NULL()
end type lw_output_type

!------------------------------------------------------------------

public lw_table_type

!    bdlocm
!    bdhicm
!    bandlo
!    bandhi
!    iband

type lw_table_type
     real, dimension(:),    pointer :: bdlocm=>NULL(),   &
                                       bdhicm=>NULL(),  &
                                       bandlo=>NULL(),  &
                                       bandhi=>NULL()
     integer, dimension(:), pointer :: iband=>NULL()
end type lw_table_type

!------------------------------------------------------------------

public microphysics_type
 
!    conc_ice
!    conc_drop
!    size_ice
!    size_drop
!    size_snow
!    conc_snow
!    size_rain
!    conc_rain
!    cldamt
!    stoch_conc_ice
!    stoch_conc_drop
!    stoch_size_ice
!    stoch_size_drop
!    stoch_cldamt
!    stoch_cloud_type
!    lw_stoch_conc_ice
!    lw_stoch_conc_drop
!    lw_stoch_size_ice
!    lw_stoch_size_drop
!    lw_stoch_cldamt
!    sw_stoch_conc_ice
!    sw_stoch_conc_drop
!    sw_stoch_size_ice
!    sw_stoch_size_drop
!    sw_stoch_cldamt

type microphysics_type
   real, dimension(:,:,:), pointer :: conc_ice=>NULL(),   &
                                      conc_drop=>NULL(),      &
                                      size_ice=>NULL(),   &
                                      size_drop=>NULL(),     &
                                      size_snow=>NULL(),   &
                                      conc_snow=>NULL(),     &
                                      size_rain=>NULL(),     &
                                      conc_rain=>NULL(),   &
                                      cldamt=>NULL(),      &
                                      droplet_number=>NULL()
real, dimension(:,:,:,:), pointer :: stoch_conc_ice=>NULL(),   &
                                     stoch_conc_drop=>NULL(),  &
                                     stoch_size_ice=>NULL(),   &
                                     stoch_size_drop=>NULL(),  &
                                     stoch_cldamt=>NULL(),     &
                                     stoch_droplet_number=>NULL()
integer, dimension(:,:,:,:), pointer ::  stoch_cloud_type=>NULL()
!
! In practice, we allocate a single set of columns for the stochastic
!   clouds, then point to sections of the larger array with the 
!   lw_ and sw_type. 
!   I.e. lw_stoch_conc_ice => stoch_conc_ice(:, :, :, 1:numLwBands)
!
real, dimension(:,:,:,:), pointer :: lw_stoch_conc_ice=>NULL(),   &
                                     lw_stoch_conc_drop=>NULL(),  &
                                     lw_stoch_size_ice=>NULL(),   &
                                     lw_stoch_size_drop=>NULL(),  &
                                     lw_stoch_cldamt=>NULL(),     &
                                     lw_stoch_droplet_number=>NULL(), &
                                     sw_stoch_conc_ice=>NULL(),   &
                                     sw_stoch_conc_drop=>NULL(),  &
                                     sw_stoch_size_ice=>NULL(),   &
                                     sw_stoch_size_drop=>NULL(),  &
                                     sw_stoch_cldamt=>NULL(),     &
                                     sw_stoch_droplet_number=>NULL()
end type microphysics_type

!-------------------------------------------------------------------

public microrad_properties_type
 
!    cldext
!    cldsct
!    cldasymm
!    abscoeff

type microrad_properties_type
   real, dimension(:,:,:,:), pointer :: cldext=>NULL(),  &
                                        cldsct=>NULL(), &
                                        cldasymm=>NULL(),    &
                                        abscoeff=>NULL()
end type microrad_properties_type

!--------------------------------------------------------------------

public optical_path_type

!    empl1f
!    vrpfh2o
!    xch2obd
!    tphfh2o
!    avephif
!    totaerooptdep
!    empl1
!    empl2
!    var1
!    var2
!    emx1f
!    emx2f
!    totvo2
!    avephi
!    totch2obdwd
!    xch2obdwd
!    totphi
!    cntval
!    toto3
!    tphio3
!    var3
!    var4
!    wk
!    rh2os
!    rfrgn
!    tfac
!    totaerooptdep15
!    totf11
!    totf12
!    totf113
!    totf22
!    emx1
!    emx2
!    csfah2o
!    aerooptdep_KE_15

type optical_path_type
     real, dimension (:,:,:,:), pointer :: empl1f=>NULL(),  &
                                           empl2f=>NULL(),  &
                                           vrpfh2o=>NULL(), &
                                           xch2obd=>NULL(),  &
                                           tphfh2o=>NULL(), &
                                           avephif=>NULL(), &
                                           totaerooptdep=>NULL()
     real, dimension (:,:,:),   pointer :: empl1=>NULL(), &
                                           empl2=>NULL(),  &
                                           var1=>NULL(), &
                                           var2=>NULL(), &
                                           emx1f=>NULL(),   &
                                           emx2f=>NULL(),   &
                                           totvo2=>NULL(),  &
                                           avephi=>NULL(),&
                                           totch2obdwd=>NULL(), &
                                           xch2obdwd=>NULL(), &
                                           totphi=>NULL(),   &
                                           cntval=>NULL(), &
                                           toto3=>NULL(),   &
                                           tphio3=>NULL(),  &
                                           var3=>NULL(),  &
                                           var4=>NULL(),        &
                                           wk=>NULL(),         &
                                           rh2os=>NULL(),  &
                                           rfrgn=>NULL(),  &
                                           tfac=>NULL(), &
                                           totaerooptdep_15=>NULL(), &
                                           totf11=>NULL(),   &
                                           totf12=>NULL(),  &
                                           totf113=>NULL(),   &
                                           totf22=>NULL()
      real, dimension (:,:), pointer    :: emx1=>NULL(),  &
                                           emx2=>NULL(),  &
                                           csfah2o=>NULL(), &
                                           aerooptdep_KE_15=>NULL()
end type optical_path_type

!------------------------------------------------------------------

public radiation_control_type

type radiation_control_type
    logical  :: do_totcld_forcing
    logical  :: do_aerosol
    integer  :: rad_time_step
    integer  :: lw_rad_time_step
    integer  :: sw_rad_time_step
    logical  :: do_sw_rad
    logical  :: do_lw_rad
    logical  :: hires_coszen
    integer  :: nzens
    real     :: co2_tf_calc_intrvl
    logical  :: use_current_co2_for_tf
    logical  :: calc_co2_tfs_on_first_step
    logical  :: calc_co2_tfs_monthly
    real     :: co2_tf_time_displacement
    real     :: ch4_tf_calc_intrvl
    logical  :: use_current_ch4_for_tf
    logical  :: calc_ch4_tfs_on_first_step
    logical  :: calc_ch4_tfs_monthly
    real     :: ch4_tf_time_displacement
    real     :: n2o_tf_calc_intrvl
    logical  :: use_current_n2o_for_tf
    logical  :: calc_n2o_tfs_on_first_step
    logical  :: calc_n2o_tfs_monthly
    real     :: n2o_tf_time_displacement
    integer  :: mx_spec_levs
    logical  :: time_varying_solar_constant
    logical  :: volcanic_sw_aerosols
    logical  :: volcanic_lw_aerosols
    logical  :: using_solar_timeseries_data
    logical  :: do_lwaerosol_forcing
    logical  :: do_swaerosol_forcing
    integer  :: indx_swaf
    integer  :: indx_lwaf
    logical  :: using_im_bcsul
    logical  :: do_totcld_forcing_iz
    logical  :: do_aerosol_iz
    logical  :: rad_time_step_iz
    logical  :: lw_rad_time_step_iz
    logical  :: sw_rad_time_step_iz
    logical  :: do_sw_rad_iz
    logical  :: do_lw_rad_iz
    logical  :: hires_coszen_iz
    logical  :: nzens_iz  
    logical  :: co2_tf_calc_intrvl_iz
    logical  :: use_current_co2_for_tf_iz
    logical  :: calc_co2_tfs_on_first_step_iz
    logical  :: calc_co2_tfs_monthly_iz
    logical  :: ch4_tf_calc_intrvl_iz
    logical  :: use_current_ch4_for_tf_iz
    logical  :: calc_ch4_tfs_on_first_step_iz
    logical  :: calc_ch4_tfs_monthly_iz
    logical  :: n2o_tf_calc_intrvl_iz
    logical  :: use_current_n2o_for_tf_iz
    logical  :: calc_n2o_tfs_on_first_step_iz
    logical  :: calc_n2o_tfs_monthly_iz
    logical  :: co2_tf_time_displacement_iz
    logical  :: ch4_tf_time_displacement_iz
    logical  :: n2o_tf_time_displacement_iz
    logical  :: mx_spec_levs_iz
    logical  :: time_varying_solar_constant_iz
    logical  :: volcanic_sw_aerosols_iz
    logical  :: volcanic_lw_aerosols_iz
    logical  :: using_solar_timeseries_data_iz
    logical  :: do_lwaerosol_forcing_iz
    logical  :: do_swaerosol_forcing_iz
    logical  :: indx_swaf_iz
    logical  :: indx_lwaf_iz
    logical  :: using_im_bcsul_iz
end type radiation_control_type

!------------------------------------------------------------------

public   radiative_gases_type
 
!    qo3
!    rrvch4
!    rrvn2o
!    rrvco2
!    rrvf11
!    rrvf12
!    rrvf113
!    rrvf22
!    rf11air
!    rf12air
!    rf113air
!    rf22air
!    time_varying_co2
!    time_varying_f11
!    time_varying_f12
!    time_varying_f113
!    time_varying_f22
!    time_varying_ch4
!    time_varying_n2o

type radiative_gases_type
     real, dimension(:,:,:), pointer :: qo3=>NULL()
     real                            :: rrvch4, rrvn2o, rrvco2,    &
                                        rrvf11, rrvf12, rrvf113,  &
                                        rrvf22, rf11air, rf12air,  &
                                        rf113air, rf22air, &
                                        co2_for_last_tf_calc,  &
                                        co2_tf_offset, &
                                        co2_for_next_tf_calc, &
                                        ch4_for_last_tf_calc,  &
                                        ch4_tf_offset, &
                                        ch4_for_next_tf_calc, &
                                        n2o_for_last_tf_calc,  &
                                        n2o_tf_offset, &
                                        n2o_for_next_tf_calc
     logical                         :: time_varying_co2,  &
                                        time_varying_f11, &
                                        time_varying_f12,  &
                                        time_varying_f113, &
                                        time_varying_f22,  &
                                        time_varying_ch4, &
                                        time_varying_n2o, &
                                        use_model_supplied_co2
     type(time_type)                 :: Co2_time, Ch4_time, N2o_time
end type radiative_gases_type

!------------------------------------------------------------------

public rad_output_type

!    tdt_rad
!    tdt_rad_clr
!    tdtsw
!    tdtsw_clr
!    tdtlw
!    flux_sw_surf
!    flux_lw_surf
!    coszen_angle

type rad_output_type
     real, dimension(:,:,:,:), pointer :: tdt_rad=>NULL(),  &
                                        ufsw=>NULL(),  &
                                        dfsw=>NULL(),  &
                                        tdtsw=>NULL()  
     real, dimension(:,:,:,:), pointer :: tdt_rad_clr=>NULL(), &
                                        ufsw_clr=>NULL(),  &
                                        dfsw_clr=>NULL(),  &
                                        tdtsw_clr=>NULL()
                                        
     real, dimension(:,:,:), pointer :: tdtlw=>NULL()
     real, dimension(:,:,:), pointer :: flxnet=>NULL()
     real, dimension(:,:,:), pointer :: flxnetcf=>NULL()
     real, dimension(:,:,:), pointer :: tdtlw_clr=>NULL()
     real, dimension(:,:,:),   pointer :: flux_sw_surf=>NULL(), &
                                        flux_sw_surf_dir=>NULL(), &
                                        flux_sw_surf_dif=>NULL(), &
                                        flux_sw_down_vis_dir=>NULL(), &
                                        flux_sw_down_vis_dif=>NULL(), &
                                       flux_sw_down_total_dir=>NULL(), &
                                       flux_sw_down_total_dif=>NULL(), &
                                        flux_sw_vis=>NULL(), &
                                        flux_sw_vis_dir=>NULL(), &
                                        flux_sw_vis_dif=>NULL()
     real, dimension(:,:,:),   pointer :: flux_sw_down_vis_clr=>NULL(), &
                                  flux_sw_down_total_dir_clr=>NULL(), &
                                  flux_sw_down_total_dif_clr=>NULL()
     real, dimension(:,:),   pointer :: flux_lw_surf=>NULL(), &
                                        coszen_angle=>NULL()
end type rad_output_type

!-------------------------------------------------------------------

public shortwave_control_type

type shortwave_control_type
    logical  :: do_lhsw
    logical  :: do_esfsw
    logical  :: do_swaerosol
    logical  :: do_diurnal
    logical  :: do_annual
    logical  :: do_daily_mean
    logical  :: do_cmip_diagnostics
    real     :: solar_constant
    logical  :: do_lhsw_iz
    logical  :: do_esfsw_iz
    logical  :: do_swaerosol_iz
    logical  :: do_diurnal_iz
    logical  :: do_annual_iz
    logical  :: do_daily_mean_iz
    logical  :: do_cmip_diagnostics_iz
end type shortwave_control_type

!---------------------------------------------------------------------

public solar_spectrum_type

!    solarfluxtoa      highly-resolved solar flux at toa in 
!                      Sw_control%tot_wvnums 
!                      bands [         ]
!    solflxband_lean   a time series of toa solar flux in each
!                      parameterization band
!    solflxband_lean_ann_1882   1882 average toa solar flux in each
!                               parameterization band
!    solflxband_lean_ann_2000   2000 average toa solar flux in each
!                               parameterization band
!    solflxband        toa solar flux in each parameterization band
!                      [         ]
!    endwvnbands       highest wave number in each of the solar
!                      spectral parameterization bands [ cm (-1) ]
!    tot_wvnums
!    nbands
!    nfrqpts
!    nstreams
!    nh2obands
!    visible_band_indx
!    one_micron_indx
!    eight70_band_indx
!    visible_band_indx_iz
!    one_micron_indx_iz
!    eight70_band_indx_iz

type solar_spectrum_type
    real, dimension(:),    pointer   :: solarfluxtoa=>null()
    real, dimension(:),    pointer   :: solflxband=>NULL()
    real, dimension(:),    pointer   :: solflxbandref=>NULL()
    real, dimension(:),    pointer   :: solflxband_lean_ann_1882=>NULL()
    real, dimension(:),    pointer   :: solflxband_lean_ann_2000=>NULL()
    real, dimension(:,:,:),pointer   :: solflxband_lean=>NULL()
    integer, dimension(:), pointer   :: endwvnbands=>NULL()
    integer         :: tot_wvnums
    integer         :: nbands
    integer         :: nfrqpts
    integer         :: nstreams
    integer         :: nh2obands
    integer         :: visible_band_indx, one_micron_indx
    integer         :: eight70_band_indx
    logical         :: visible_band_indx_iz, one_micron_indx_iz
    logical         :: eight70_band_indx_iz
    integer         :: w340_band_indx, w380_band_indx,  &
                       w440_band_indx, w670_band_indx
    logical         :: w340_band_iz, w380_band_iz, &
                       w440_band_iz, w670_band_iz
end type solar_spectrum_type

!---------------------------------------------------------------------

public surface_type

!    asfc
!    land

type surface_type
    real, dimension(:,:),   pointer ::  asfc=>NULL(),   &
                                        land=>NULL(),  &
                                        asfc_vis_dir=>NULL(), &
                                        asfc_nir_dir=>NULL(), &
                                        asfc_vis_dif=>NULL(), &
                                        asfc_nir_dif=>NULL()
end type surface_type
 
!-------------------------------------------------------------------

public sw_output_type

!    dfsw
!    ufsw
!    fsw
!    hsw
!    dfswcf
!    ufswcf
!    fswcf
!    hswcf
!    swdn_special
!    swup_special
!    swdn_special_clr
!    swup_special_clr

type sw_output_type
     real, dimension(:,:,:,:), pointer :: dfsw=>NULL(),   &
                                        ufsw=>NULL(),  &
                                        fsw=>NULL(),   &
                                        hsw=>NULL()   
     real, dimension(:,:,:,:), pointer :: dfswcf=>NULL(),   &
                                        ufswcf=>NULL(),&
                                        fswcf=>NULL(),  &
                                        hswcf=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_vis_sfc=>NULL(),   &
                                       ufsw_vis_sfc=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_dir_sfc=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_dir_sfc_clr=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_dif_sfc=>NULL(),   &
                                       ufsw_dif_sfc=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_dif_sfc_clr=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_vis_sfc_dir=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_vis_sfc_clr=>NULL()
      real, dimension(:,:,:), pointer :: dfsw_vis_sfc_dif=>NULL(),   &
                                       ufsw_vis_sfc_dif=>NULL()
      real, dimension(:,:,:,:), pointer   ::  bdy_flx=>NULL()
      real, dimension(:,:,:,:), pointer   ::  bdy_flx_clr=>NULL()
      real, dimension(:,:,:,:), pointer   ::                       &
                                        swup_special=>NULL(), &
                                        swup_special_clr=>NULL()
     real, dimension(:,:,:,:), pointer   :: swdn_special=>NULL(), &
                                          swdn_special_clr=>NULL()
end type sw_output_type

!-------------------------------------------------------------------

public table_axis_type

type table_axis_type
  integer :: first_col
  real    :: min_val
  real    :: max_val
  real    :: tab_inc
end type table_axis_type

!---------------------------------------------------------------------

!private      &


!--------------------------------------------------------------------
!-------- namelist  ---------

integer            ::  dummy = 0


namelist / rad_utilities_nml /   &
                                dummy


!---------------------------------------------------------------------
!------- public data ------


type (longwave_control_type),  public   ::    &
     Lw_control = longwave_control_type( '    ', '    ', '    ', &
                                         .false., .false., .false.,  &
                                         .false., .false., .false.,  &
                                         .false., .false.,  &
                                         .false., .false.,  &
                                         .false., .false., .false.,  &
                                         .false., .false.,  &
                                         .false., .false.,  &
                                         .false., .false., .false.   )

type (shortwave_control_type), public   ::  &
    Sw_control = shortwave_control_type( .false., .false., .false. , &
                                         .false., .false., .false., &
                                         .false., &
                                         0.0, &
                                         .false., .false., .false. , &
                                         .false., &
                                         .false., .false., .false.)

type (radiation_control_type), public   ::  &
   Rad_control = radiation_control_type( .false., .false., 0, 0, 0, &
                                         .false., .false., &
                                         .false., 1, &
                                         0.0,  .true.,  .false.,&
                                         .false.,  0.0, &
                                         0.0, .true., .false.,  &
                                         .false.,  0.0,  &
                                         0.0, .true., .false.,   &
                                         .false., 0.0, &
                                         0, .false., .false.,   &
                                         .false., .false.,&
                                         .false., .false.,      &
                                         0, 0, .false., &
! _iz variables:
                                         .false., .false., .false., &
                                         .false., .false., .true., &
                                         .true.,  &
                                         .false., .false., &
                                         .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., &
                                         .false., .false., &
                                         .false., .false., &
                                         .false.,          &
                                         .false., .false., .false.,  &
                                         .false., .false.,   &
                                         .false., .false., &
                                         .false., .false., .false.)

type (cloudrad_control_type), public    ::   &
 Cldrad_control = cloudrad_control_type( .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         0,0,0,0,0,0 , &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false., &
                                         .false., .false., .false.   )


type (longwave_parameter_type), public  ::   &
Lw_parameters = longwave_parameter_type( 0, 0, 0, 0, 0, 10.0, &
                                         .false., .false., .false.,  &
                                         .false., .false., .true.)

type (table_axis_type),        public   ::    &
               temp_1 = table_axis_type( 1, 100.0, 370.0, 10.0), &
               mass_1 = table_axis_type( 1, -16.0,   1.9,  0.1)


!---------------------------------------------------------------------
!------- private data ------


logical :: module_is_initialized=.false.   ! module is initialized ?


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                           contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! <SUBROUTINE NAME="rad_utilities_init">
!  <OVERVIEW>
!   Subroutine to initialize radiation utility package.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine reads the input namelist file and initializes 
!   rad_utilities_nml. It then writes out this namelist to the output
!   logfile. It also sets up the radiation calculation environment
!   and the initialization flag variable.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rad_utilities_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine rad_utilities_init

!---------------------------------------------------------------------
!    rad_utilities_init is the constructor for rad_uti;lities_mod.
!---------------------------------------------------------------------

!------------------------------------------------------------------
!  local variables:

      integer    ::  unit, ierr, io, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!                                
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=rad_utilities_nml, iostat=io)
      ierr = check_nml_error(io,'rad_utilities_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=rad_utilities_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'rad_utilities_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=rad_utilities_nml)

!-------------------------------------------------------------------
!    mark the module as initialized.
!-------------------------------------------------------------------
      module_is_initialized = .true.

!------------------------------------------------------------------

end subroutine rad_utilities_init


!#####################################################################
!
! <SUBROUTINE NAME="check_derived_types">
!  <OVERVIEW>
!   Subroutine to verify that all logical elements of derived-type
!   variables were initialized during the initialization phase.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine checks that all of the variable names ending in 
!   "_iz" in its public derived-type module variables are set to .true..
!   If additional types or variables within current public types are
!   added, it is necessary to also add the corresponding "_iz" variable,
!   initialized in this module to .false., and then set to .true. when 
!   the variable is initialized, and add a check in this routine to 
!   verify that initialization.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call check_derived_types
!  </TEMPLATE>
! </SUBROUTINE>
!

subroutine check_derived_types 

!--------------------------------------------------------------------
!    check_derived_types is called at the end of radiation package
!    initialization to verify that all logical components of public
!    derived-type module variables have been initialized.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    check the components of Lw_control.
!--------------------------------------------------------------------
      if (Lw_control%do_cfc_iz .and. &
          Lw_control%do_lwaerosol_iz .and. &
          Lw_control%do_ch4_iz .and. &
          Lw_control%do_n2o_iz .and. &
          Lw_control%do_ch4lbltmpint_iz .and. &
          Lw_control%do_n2olbltmpint_iz .and. &
          Lw_control%do_co2_iz .and. &
          Lw_control%do_h2o_iz .and. &
          Lw_control%do_o3_iz .and. &
          Lw_control%do_lwcldemiss_iz ) then  
      else
        call error_mesg ('rad_utilities_mod', &
             ' at least one component of Lw_control has not been '//&
                                     'initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    check the components of Sw_control.
!--------------------------------------------------------------------
      if (Sw_control%do_lhsw_iz .and. &
          Sw_control%do_esfsw_iz .and. &
          Sw_control%do_swaerosol_iz .and. &
          Sw_control%do_diurnal_iz .and. &
          Sw_control%do_annual_iz .and. &
          Sw_control%do_cmip_diagnostics_iz .and. &
          Sw_control%do_daily_mean_iz ) then  
      else
        call error_mesg ('rad_utilities_mod', &
             ' at least one component of Sw_control has not been '//&
                                     'initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    check the components of Rad_control.
!--------------------------------------------------------------------
      if (Rad_control%do_totcld_forcing_iz .and. &
          Rad_control%do_lwaerosol_forcing_iz .and.  &
          Rad_control%do_swaerosol_forcing_iz .and.  &
          Rad_control%indx_lwaf_iz .and.   &
          Rad_control%indx_swaf_iz .and.   &
          Rad_control%using_im_bcsul_iz .and. &
          Rad_control%do_aerosol_iz .and.     &
          Rad_control%mx_spec_levs_iz .and.   &
          Rad_control%use_current_co2_for_tf_iz .and. &
          Rad_control%co2_tf_calc_intrvl_iz .and. &
          Rad_control%calc_co2_tfs_on_first_step_iz .and. &
          Rad_control%calc_co2_tfs_monthly_iz .and. &
          Rad_control%co2_tf_time_displacement_iz .and. &
          Rad_control%use_current_ch4_for_tf_iz .and. &
          Rad_control%ch4_tf_calc_intrvl_iz .and. &
          Rad_control%calc_ch4_tfs_on_first_step_iz .and. &
          Rad_control%calc_ch4_tfs_monthly_iz .and. &
          Rad_control%ch4_tf_time_displacement_iz .and. &
          Rad_control%use_current_n2o_for_tf_iz .and. &
          Rad_control%n2o_tf_calc_intrvl_iz .and. &
          Rad_control%calc_n2o_tfs_on_first_step_iz .and. &
          Rad_control%calc_n2o_tfs_monthly_iz .and. &
          Rad_control%n2o_tf_time_displacement_iz .and. &
          Rad_control%do_lw_rad_iz .and. &
          Rad_control%do_sw_rad_iz .and. &
          Rad_control%nzens_iz .and. &
          Rad_control%hires_coszen_iz .and. &
          Rad_control%lw_rad_time_step_iz .and.  &
          Rad_control%sw_rad_time_step_iz .and.  &
          Rad_control%rad_time_step_iz ) then
      else
        call error_mesg ('rad_utilities_mod', &
          ' at least one component of Rad_control has not been '//&
                                     'initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    check the components of Cldrad_control.
!--------------------------------------------------------------------
      if (Cldrad_control%do_pred_cld_microphys_iz .and. &
          Cldrad_control%do_presc_cld_microphys_iz .and. &
          Cldrad_control%do_bulk_microphys_iz .and. &
          Cldrad_control%do_sw_micro_iz .and. &
          Cldrad_control%do_lw_micro_iz .and. &
          Cldrad_control%do_strat_clouds_iz .and. &
          Cldrad_control%do_rh_clouds_iz .and. &
          Cldrad_control%do_zonal_clouds_iz .and. &
          Cldrad_control%do_mgroup_prescribed_iz .and. &
          Cldrad_control%do_obs_clouds_iz .and. &
          Cldrad_control%do_no_clouds_iz .and. &
          Cldrad_control%do_diag_clouds_iz .and. &
          Cldrad_control%do_specified_clouds_iz .and. &
          Cldrad_control%do_specified_strat_clouds_iz .and. &
          Cldrad_control%do_donner_deep_clouds_iz .and. &
          Cldrad_control%do_uw_clouds_iz .and. &
          Cldrad_control%do_stochastic_clouds_iz .and. &
          Cldrad_control%use_temp_for_seed_iz .and. &
          Cldrad_control%do_random_overlap_iz .and. &
          Cldrad_control%do_ica_calcs_iz .and. &
          CLdrad_control%using_fu2007_iz .and.  &
          Cldrad_control%do_max_random_overlap_iz ) then     
      else
        call error_mesg ('rad_utilities_mod', &
          ' at least one component of Cldrad_control has not been '//&
                                     'initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    check the components of Lw_parameters.
!--------------------------------------------------------------------
      if (Lw_parameters%offset_iz .and. &
          Lw_parameters%nbtrg_iz .and. &
          Lw_parameters%nbtrge_iz .and. &
          Lw_parameters%nbly_iz .and. &
          Lw_parameters%n_lwaerosol_bands_iz .and. &
          Lw_parameters%lw_band_resolution_iz) then
      else
        call error_mesg ('rad_utilities_mod', &
          ' at least one component of Lw_parameters has not been '//&
                                     'initialized', FATAL)
      endif

!---------------------------------------------------------------------
!    check for consistency between band structure and cfc and lwaerosol
!    effects.
!---------------------------------------------------------------------
      if (Lw_parameters%nbtrge == 0) then
        if (Lw_control%do_cfc .or. Lw_control%do_lwaerosol) then
          call error_mesg ('rad_utilities_mod', &
             'when do_cfc and / or do_lwaerosol is .true., must set &
              &sealw99_nml variable no_h2o_bands_1200_1400 > 0 ', FATAL)
        endif
      endif
!--------------------------------------------------------------------

!--------------------------------------------------------------------


end subroutine check_derived_types 



!####################################################################
! <SUBROUTINE NAME="locate_in_table">
!  <OVERVIEW>
!   Subroutine to locate index and residual value from an array provided 
!   with array and axis information
!  </OVERVIEW>
!  <DESCRIPTION>
!     given array x and an arithmetic sequence of table column headings
!     tabxmin, tabxmin+tabdeltax, ..., corresponding to column ixlow, 
!     ixlow+1, ..., ixupp, Locate returns the array ix is column 
!     indices and the array dx of residuals.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call locate_in_table(table_axis, x, dx, ix, k_min, k_max)
!  </TEMPLATE>
!  <IN NAME="table_axis" TYPE="table_axis_type">
!   table_axis contains the axis information such as, min, increment,
!   and first column values.
!  </IN>
!  <IN NAME="x" TYPE="real">
!   array from which data is to be searched
!  </IN>
!  <OUT NAME="dx" TYPE="real">
!   residual between x and x(ix+first_column)
!  </OUT>
!  <OUT NAME="ix" TYPE="integer">
!   index values of the searched domain in the array
!  </OUT>
!  <IN NAME="k_min" TYPE="integer">
!   minimum k value of the search domain 
!  </IN>
!  <IN NAME="k_max" TYPE="integer">
!   maximum k value of the search domain
!  </IN>
! </SUBROUTINE>
subroutine locate_in_table (table_axis, x, dx, ix, k_min, k_max) 

!---------------------------------------------------------------------
!    given array x and an arithmetic sequence of table column headings
!    tabxmin, tabxmin+tabdeltax, ..., corresponding to column ixlow, 
!    ixlow+1, ..., ixupp, locate_in_table returns the array ix of
!    column indices and the array dx of residuals.
!    author: c. h. goldberg
!    revised: 1/1/93
!    certified:  radiation version 1.0
!----------------------------------------------------------------------

type(table_axis_type),     intent(in)  :: table_axis
real,    dimension(:,:,:), intent(in)  :: x
integer,                   intent(in)  :: k_min, k_max
real,    dimension(:,:,:), intent(out) :: dx
integer, dimension(:,:,:), intent(out) :: ix

!--------------------------------------------------------------------
!  intent(in) variables:
!
!    table_axis
!    x
!    k_min
!    k_max
!
!  intent(out) variables:
!
!    dx
!    ix
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(x,1), size(x,2), size(x,3))  ::  fx
      integer     ::  k

!---------------------------------------------------------------------
!  local variables:
!
!     fx
!     table_min
!     table_inc
!     k
!     table_col
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do k=k_min,k_max
        fx (:,:,k) = AINT((x(:,:,k) - table_axis%min_val )/  &
                     table_axis%tab_inc)
        ix (:,:,k) = INT(fx(:,:,k)) + table_axis%first_col
        dx (:,:,k) = x(:,:,k) - fx(:,:,k)*table_axis%tab_inc - &
                     table_axis%min_val
      end do
      
!---------------------------------------------------------------------


end subroutine locate_in_table



!####################################################################
! <SUBROUTINE NAME="looktab_type1">
!  <OVERVIEW>
!   Subroutine to calculate answer from input differentials.
!  </OVERVIEW>
!  <DESCRIPTION>
!   given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and
!     arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and
!     y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:))
!     from four tables of values, f, df/dx, df/dy, and d2f/dxdy.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call looktab_type1 (tab, ix, iy, dx, dy, answer, k_min, k_max)
!  </TEMPLATE>
!  <IN NAME="tab" TYPE="longwave_tables1_type">
!   The data array that contains function values and differentials
!  </IN>
!  <IN NAME="ix" TYPE="integer">
!   x subscript of input data array
!  </IN>
!  <IN NAME="iy" TYPE="integer">
!   y subscript of input data array
!  </IN>
!  <IN NAME="dx" TYPE="real">
!   x step in the x subscript space
!  </IN>
!  <IN NAME="dy" TYPE="real">
!   y step in the y subscript space
!  </IN>
!  <OUT NAME="answer" TYPE="real">
!   the answer to be calculated
!  </OUT>
!  <IN NAME="k_min" TYPE="integer">
!   the minimum k value of the domain
!  </IN>
!  <IN NAME="k_max" TYPE="integer">
!   the maximum k value of the domain
!  </IN>
! </SUBROUTINE>
!
subroutine looktab_type1 (tab, ix, iy, dx, dy, answer, k_min, k_max)   

!----------------------------------------------------------------------
!    given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and
!    arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and
!    y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:))
!    from four tables of values, f, df/dx, df/dy, and d2f/dxdy.
!    author: c. h. goldberg
!    revised: 1/1/93
!    certified:  radiation version 1.0
!--------------------------------------------------------------------

type(longwave_tables1_type), intent(in)  :: tab
integer,dimension(:,:,:),    intent(in)  :: ix, iy
real,   dimension(:,:,:),    intent(in)  :: dx, dy   
real,   dimension(:,:,:),    intent(out) :: answer
integer,                     intent(in)  :: k_min, k_max

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    tab
!    ix
!    iy
!    dx
!    dy
!    k_min
!    k_max
!
!  intent(out) variables:
!
!    answer
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer    ::  i_min, i_max, j_min, j_max, i, j, k
  
!--------------------------------------------------------------------
!  local variables:
!
!    i_min
!    i_max
!    j_min
!    j_max
!    i,j,k
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

      i_min = lbound(ix,1)
      i_max = ubound(ix,1)
      j_min = lbound(ix,2)
      j_max = ubound(ix,2)

      do k=k_min, k_max
        do j=j_min, j_max
          do i=i_min, i_max
            answer(i,j,k) =                                         &
                                      tab%vae (ix(i,j,k), iy(i,j,k)) + &
                            dx(i,j,k)*tab%td  (ix(i,j,k), iy(i,j,k)) + &
                            dy(i,j,k)*tab%md  (ix(i,j,k), iy(i,j,k)) + &
                  dx(i,j,k)*dy(i,j,k)*tab%cd(ix(i,j,k), iy(i,j,k))
          end do
        end do
      end do

!---------------------------------------------------------------------


end subroutine looktab_type1



!#####################################################################
! <SUBROUTINE NAME="looktab_type2">
!  <OVERVIEW>
!   Subroutine to calculate answer from input differentials.
!  </OVERVIEW>
!  <DESCRIPTION>
!   given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and
!     arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and
!     y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:))
!     from four tables of values, f, df/dx, df/dy, and d2f/dxdy.
!     The difference between this version about the version above is
!     that the differential arrays are 3 dimensional.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call looktab_type2 (tab, ix, iy, dx, dy, answer, k_min, k_max, m)
!  </TEMPLATE>
!  <IN NAME="tab" TYPE="longwave_tables2_type">
!   The data array that contains function values and differentials
!  </IN>
!  <IN NAME="ix" TYPE="integer">
!   x subscript of input data array
!  </IN>
!  <IN NAME="iy" TYPE="integer">
!   y subscript of input data array
!  </IN>
!  <IN NAME="dx" TYPE="real">
!   x step in the x subscript space
!  </IN>
!  <IN NAME="dy" TYPE="real">
!   y step in the y subscript space
!  </IN>
!  <OUT NAME="answer" TYPE="real">
!   the answer to be calculated
!  </OUT>
!  <IN NAME="k_min" TYPE="integer">
!   the minimum k value of the domain
!  </IN>
!  <IN NAME="k_max" TYPE="integer">
!   the maximum k value of the domain
!  </IN>
!  <IN NAME="m" TYPE="integer">
!   the z indice of the differential arrays
!  </IN>
! </SUBROUTINE>
!
subroutine looktab_type2 (tab, ix, iy, dx, dy, answer, k_min, k_max, m)

!-------------------------------------------------------------------
!    given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and
!    arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and
!    y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:))
!    from four tables of values, f, df/dx, df/dy, and d2f/dxdy.
!    author: c. h. goldberg
!    revised: 1/1/93
!    certified:  radiation version 1.0
!--------------------------------------------------------------------

type(longwave_tables2_type), intent(in)   :: tab
integer, dimension (:,:,:),  intent(in)   :: ix, iy
integer,                     intent(in)   :: m
real, dimension (:,:,:),     intent(in)   :: dx, dy
real, dimension (:,:,:),     intent(out)  :: answer
integer,                     intent(in)   :: k_min, k_max

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    tab
!    ix
!    iy
!    m
!    dx
!    dy
!    k_min
!    k_max
!
!  intent(out) variables:
!
!    answer
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

       integer    ::    i_min, i_max, j_min, j_max
       integer    ::    i, j, k
  
!--------------------------------------------------------------------
!  local variables:
!
!    i_min
!    i_max
!    j_min
!    j_max
!    i,j,k
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

      i_min = lbound(ix,1)
      i_max = ubound(ix,1)
      j_min = lbound(ix,2)
      j_max = ubound(ix,2)

      do k=k_min, k_max
        do j=j_min, j_max
          do i=i_min, i_max
            answer(i,j,k) =                                           &
                                   tab%vae (ix(i,j,k), iy(i,j,k),m) + &
                         dx(i,j,k)*tab%td (ix(i,j,k), iy(i,j,k),m) + &
                         dy(i,j,k)*tab%md (ix(i,j,k), iy(i,j,k),m) + &
               dx(i,j,k)*dy(i,j,k)*tab%cd   (ix(i,j,k), iy(i,j,k),m)
           end do
        end do
      end do

!--------------------------------------------------------------------

end subroutine looktab_type2



!###################################################################
! <SUBROUTINE NAME="looktab_type3">
!  <OVERVIEW>
!   Subroutine to calculate answer from input differentials.
!  </OVERVIEW>
!  <DESCRIPTION>
!   given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and
!     arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and
!     y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:))
!     from four tables of values, f, df/dx, df/dy, and d2f/dxdy.
!   In this version, only f(x,y) and f(x,y)+dx*df/dx is used. Probably
!   the f(x,y) is homogeneous in y space.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call looktab_type3 (tab, ix, dx,  answer, k_min, k_max, n)
!  </TEMPLATE>
!  <IN NAME="tab" TYPE="longwave_tables3_type">
!   The data array that contains function values and differentials
!  </IN>
!  <IN NAME="ix" TYPE="integer">
!   x subscript of input data array
!  </IN>
!  <IN NAME="dx" TYPE="real">
!   x step in the x subscript space
!  </IN>
!  <OUT NAME="answer" TYPE="real">
!   the answer to be calculated
!  </OUT>
!  <IN NAME="k_min" TYPE="integer">
!   the minimum k value of the domain
!  </IN>
!  <IN NAME="k_max" TYPE="integer">
!   the maximum k value of the domain
!  </IN>
!  <IN NAME="n" TYPE="integer">
!   the z indice of the differential arrays
!  </IN>
! </SUBROUTINE>
!
subroutine looktab_type3 (tab, ix, dx,  answer, k_min, k_max, n)

!----------------------------------------------------------------------
!
!    given arrays ix(:,:,:) and dx(:,:,:) of integer subscripts and!
!    differences from x(:,:,:) and constant column subscript iyconst, 
!    calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) from four tables
!    of values f, df/dx, df/dy, and d2f/dxdy.
!    author: c. h. goldberg
!    revised: 1/1/93
!    certified:  radiation version 1.0
!-----------------------------------------------------------------------

type(longwave_tables3_type), intent(in)  :: tab
integer, dimension (:,:,:),  intent(in)  :: ix
integer,                     intent(in)  :: n
real,    dimension(:,:,:),   intent(in)  :: dx
real,    dimension(:,:,:),   intent(out) :: answer 
integer,                     intent(in)  :: k_min, k_max

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    tab
!    ix
!    n
!    dx
!    k_min
!    k_max
!
!  intent(out) variables:
!
!    answer
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer    :: i_min, i_max, j_min, j_max
      integer    :: i, j, k
   
!--------------------------------------------------------------------
!  local variables:
!
!    i_min
!    i_max
!    j_min
!    j_max
!    i,j,k
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

!-----------------------------------------------------------------
      i_min = lbound(ix,1)
      i_max = ubound(ix,1)
      j_min = lbound(ix,2)
      j_max = ubound(ix,2)

      do k=k_min, k_max
        do j=j_min, j_max
          do i=i_min, i_max
                answer(i,j,k) =                                 &
                                      tab%vae (ix(i,j,k),n) +   &
                            dx(i,j,k)*tab%td(ix(i,j,k),n)
          end do
        end do
      end do

!------------------------------------------------------------------

end subroutine  looktab_type3


!#####################################################################
! <SUBROUTINE NAME="table1_alloc">
!  <OVERVIEW>
!   Allocate the longwave tables.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Allocate the longwave tables based on 2 dimension sizes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call table1_alloc(tab, dim1, dim2)
!  </TEMPLATE>
!  <INOUT NAME="tab" TYPE="longwave_tables1_type">
!   The longwave tables
!  </INOUT>
!  <IN NAME="dim1" TYPE="integer">
!   size of the x dimension
!  </IN>
!  <IN NAME="dim2" TYPE="integer">
!   size of the y dimension
!  </IN>
! </SUBROUTINE>
!
subroutine table1_alloc (tab, dim1, dim2)

!------------------------------------------------------------------
!    table1_alloc allocates the arrays contained in a 
!    longwave_tables1_type variable.
!------------------------------------------------------------------

type(longwave_tables1_type), intent (inout) :: tab
integer,                     intent(in)     :: dim1, dim2

!-------------------------------------------------------------------
! intent(in) variables:
!
!     dim1
!     dim2
!
!  intent(inout) variables:
!
!     tab
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    allocate the component arrays of a longwave_tables1_type variable.
!---------------------------------------------------------------------
      allocate (tab%vae(dim1, dim2))
      allocate (tab%td (dim1, dim2))
      allocate (tab%md (dim1, dim2))
      allocate (tab%cd (dim1, dim2))

!---------------------------------------------------------------------

end subroutine table1_alloc


!####################################################################
! <SUBROUTINE NAME="table2_alloc">
!  <OVERVIEW>
!   Allocate the longwave tables.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Allocate the longwave tables based on 3 dimension sizes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call table2_alloc(tab, dim1, dim2)
!  </TEMPLATE>
!  <INOUT NAME="tab" TYPE="longwave_tables2_type">
!   The longwave tables
!  </INOUT>
!  <IN NAME="dim1" TYPE="integer">
!   size of the x dimension
!  </IN>
!  <IN NAME="dim2" TYPE="integer">
!   size of the y dimension
!  </IN>
!  <IN NAME="dim3" TYPE="integer">
!   size of the z dimension
!  </IN>
! </SUBROUTINE>
!
subroutine table2_alloc (tab, dim1, dim2, dim3)

!------------------------------------------------------------------
!    table2_alloc allocates the arrays contained in a 
!    longwave_tables2_type variable.
!------------------------------------------------------------------

type(longwave_tables2_type), intent (inout) :: tab
integer,                     intent(in)     :: dim1, dim2, dim3

!-------------------------------------------------------------------
! intent(in) variables:
!
!     dim1
!     dim2
!     dim3
!
!  intent(inout) variables:
!
!     tab
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    allocate the component arrays of a longwave_tables2_type variable.
!---------------------------------------------------------------------
      allocate (tab%vae(dim1, dim2, dim3))
      allocate (tab%td (dim1, dim2, dim3))
      allocate (tab%md (dim1, dim2, dim3))
      allocate (tab%cd (dim1, dim2, dim3))

!--------------------------------------------------------------------

end subroutine table2_alloc


!#####################################################################
! <SUBROUTINE NAME="table3_alloc">
!  <OVERVIEW>
!   Allocate the longwave tables.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Allocate the longwave tables based on 2 dimension sizes
!  </DESCRIPTION>
!  <TEMPLATE>
!   call table3_alloc(tab, dim1, dim2)
!  </TEMPLATE>
!  <INOUT NAME="tab" TYPE="longwave_tables3_type">
!   The longwave tables
!  </INOUT>
!  <IN NAME="dim1" TYPE="integer">
!   size of the x dimension
!  </IN>
!  <IN NAME="dim2" TYPE="integer">
!   size of the y dimension
!  </IN>
! </SUBROUTINE>
!
subroutine table3_alloc (tab, dim1, dim2)

type(longwave_tables3_type), intent (inout) :: tab
integer,                     intent(in)     :: dim1, dim2

!-------------------------------------------------------------------
! intent(in) variables:
!
!     dim1
!     dim2
!
!  intent(inout) variables:
!
!     tab
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilities_mod',   &
               'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    allocate the component arrays of a longwave_tables3_type variable.
!---------------------------------------------------------------------
      allocate (tab%vae(dim1, dim2))
      allocate (tab%td (dim1, dim2))

end subroutine table3_alloc


!##################################################################

! <SUBROUTINE NAME="thickavg_3d">
!  <OVERVIEW>
!   Subroutine to use thick-averaging technique to define band interval
!   single scattering properties.
!  </OVERVIEW>
!  <DESCRIPTION>
! use the thick-averaging technique to define the single-scattering    
! properties of the parameterization band spectral intervals from the  
! specified spectral intervals of the particular scatterer.            
!                                                                      
! references:                                                          
!                                                                      
! edwards,j.m. and a. slingo, studies with a flexible new radiation    
!      code I: choosing a configuration for a large-scale model.,      
!      q.j.r. meteorological society, 122, 689-719, 1996.              
!                                                                      
! note: the 1.0E-100 factor to calculate asymmband is to prevent        
!       division by zero.                                              
!  </DESCRIPTION>
!  <TEMPLATE>
!   call subroutine thickavg_3d (nivl1    , nivl2     , nivls   ,   &
!                        nbands, $
!                        extivl   , ssalbivl  , asymmivl, solflxivl, &
!                        solflxband, extband  , ssalbband , asymmband)
!  </TEMPLATE>
!  <IN NAME="nivl1" TYPE="integer">
!   interval number for the specified single-scattering                
!              properties corresponding to the first psuedo-           
!              monochromatic frequency in a given parameterization     
!              band  
!  </IN>
!  <IN NAME="nivl2" TYPE="integer">
!   interval number for the specified single-scattering     
!              properties corresponding to the last psuedo-            
!              monochromatic frequency in a given parameterization     
!              band
!  </IN>
!  <IN NAME="nivls" TYPE="integer">
!   number of specified scattering spectral intervals
!  </IN>
!  <IN NAME="nbands" TYPE="integer">
!   number of spectral bands
!  </IN>
!  <IN NAME="extivl" TYPE="real">
!   the specified spectral values of the extinction coefficient 
!  </IN>
!  <INOUT NAME="ssalbivl" TYPE="real">
!   the specified spectral values of the single-scattering albedo
!  </INOUT>
!  <IN NAME="asymmivl" TYPE="real">
!   the specified spectral values of the asymmetry factor
!  </IN>
!  <IN NAME="solflxivl" TYPE="real">
!   the solar flux in each specified scattering spectral interval
!  </IN>
!  <IN NAME="solflxband" TYPE="real">
!   the solar flux in each parameterization band
!  </IN>
!  <OUT NAME="extband" TYPE="real">
!   the parameterization band values of the extinction coefficient
!  </OUT>
!  <OUT NAME="ssalbband" TYPE="real">
!   the parameterization band values of the single-scattering albedo
!  </OUT>
!  <OUT NAME="asymmband" TYPE="real">
!   the parameterization band values of the asymmetry factor
!  </OUT>
! </SUBROUTINE>
!
subroutine thickavg_3d (nivl1, nivl2, nivls, nbands, extivl, ssalbivl,&
                        asymmivl, solflxivl, solflxband, mask, extband,&
                        ssalbband, asymmband)
 
!---------------------------------------------------------------------
!    thickavg_3d uses the thick-averaging technique to define the 
!    single-scattering properties of the parameterization band spectral
!    intervals from the  specified spectral intervals of the particular
!    scatterer, using 3d input arrays.   
!    references:                                                       
!    edwards,j.m. and a. slingo, studies with a flexible new radiation  
!      code I: choosing a configuration for a large-scale model.,   
!      q.j.r. meteorological society, 122, 689-719, 1996.            
!--------------------------------------------------------------------

integer, dimension(:),    intent(in)       :: nivl1, nivl2
integer,                  intent(in)       :: nivls
integer,                  intent(in)       :: nbands
real, dimension(:,:,:,:), intent(in)       :: extivl, asymmivl
real, dimension(:,:,:,:), intent(inout)    :: ssalbivl
real, dimension(:,:),     intent(in)       :: solflxivl             
real, dimension(:),       intent(in)       :: solflxband            
real, dimension(:,:,:,:), intent(out)      :: extband, ssalbband,   &
                                              asymmband
logical, dimension(:,:,:), intent(in)      :: mask

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    nivl1       interval number for the specified single-scattering  
!                properties corresponding to the first psuedo-         
!                monochromatic frequency in a given parameterization    
!                band                                                  
!    nivl2       interval number for the specified single-scattering 
!                properties corresponding to the last psuedo-          
!                monochromatic frequency in a given parameterization    
!                band                                                 
!    nivls       number of specified scattering spectral intervals      
!    nbands
!    extivl      specified spectral values of the extinction coefficient
!    asymmivl    the specified spectral values of the asymmetry     
!                factor                                           
!    solflxivl   the solar flux in each specified scattering spectral
!                interval                                         
!    solflxband  the solar flux in each parameterization band  
!
!  intent(inout) variables:
!
!    ssalbivl    the specified spectral values of the single-       
!                scattering albedo                                   
!
!  intent(out) variables:
!
!    extband     the parameterization band values of the extinction 
!                coefficient                                      
!    ssalbband   the parameterization band values of the single-   
!                scattering albedo                                  
!    asymmband   the parameterization band values of the asymmetry   
!                factor                                               
!    
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!  local variables:
 
      real, dimension (size(ssalbivl,1),   &
                       size(ssalbivl,2), &
                       size(ssalbivl,3), nbands)  ::   refband        

      real, dimension (size(ssalbivl,1),   &
                       size(ssalbivl,2), &
                       size(ssalbivl,3))  ::   refthick, sp, sumk,   &
                                               sumomegak, sumomegakg, &
                                               sumrefthick

      integer  :: nband
      integer  :: i, j, k, ni
 
!--------------------------------------------------------------------
!  local variables:
!
!     refband
!     refthick
!     sp
!     sumk
!     sumomegak
!     sumomegakg
!     sumrefthck
!     nband
!     i,j,k,ni
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('rad_utilities_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!------------------------------------------------------ --------------
!--------------------------------------------------------------------
      do nband = 1,nbands
        sumk(:,:,:) = 0.0
        sumomegak(:,:,:) = 0.0
        sumomegakg(:,:,:) = 0.0
        sumrefthick(:,:,:) = 0.0
        do ni = nivl1(nband),nivl2(nband)
!
          do k=1, size(ssalbivl,3)
            do j=1,size(ssalbivl,2)
              do i=1,size(ssalbivl,1)
                if (mask(i,j,k)) then
                  ssalbivl(i,j,k,ni) = MIN(ssalbivl(i,j,k,ni), 1.0)
                  sp(i,j,k) = sqrt( ( 1.0 - ssalbivl(i,j,k,ni) ) /    &
                                    ( 1.0 - ssalbivl(i,j,k,ni) *      &
                                      asymmivl(i,j,k,ni) ) )
                  refthick(i,j,k) = (1.0 - sp(i,j,k))/(1.0 + sp(i,j,k))
                  sumrefthick(i,j,k) = sumrefthick(i,j,k) +    &
                                       refthick(i,j,k)*  &
                                       solflxivl(nband,ni)
                  sumk(i,j,k) = sumk(i,j,k) + extivl(i,j,k,ni) *   &
                                solflxivl(nband,ni)
                  sumomegak(i,j,k) = sumomegak(i,j,k) +     &
                                     ssalbivl(i,j,k,ni)*   &
                                     extivl(i,j,k,ni) *   &
                                     solflxivl(nband,ni)
                  sumomegakg(i,j,k) = sumomegakg(i,j,k) +    &
                                      ssalbivl(i,j,k,ni)*&
                                      extivl(i,j,k,ni)*  &
                                      asymmivl(i,j,k,ni) * &
                                      solflxivl(nband,ni)
                endif
              end do
            end do
          end do
        end do

!---------------------------------------------------------------------
!    the 1.0E-100 factor to calculate asymmband is to prevent        
!    division by zero.                                             
!---------------------------------------------------------------------
        do k=1, size(ssalbivl,3)
          do j=1,size(ssalbivl,2)
            do i=1,size(ssalbivl,1)
              extband(i,j,k,nband) = sumk(i,j,k) / solflxband(nband)
              asymmband(i,j,k,nband) = sumomegakg(i,j,k) /         &
                                       ( sumomegak(i,j,k) + 1.0E-100)
              refband(i,j,k,nband) = sumrefthick(i,j,k)/  &
                                     solflxband(nband)
              ssalbband(i,j,k,nband) = 4.0 * refband(i,j,k,nband) / &
                                       ((1.0 +    &
                                       refband(i,j,k,nband)) ** 2 -&
                                       asymmband(i,j,k,nband) *     &
                                       (1.0 - refband(i,j,k,nband))**2 )
            end do
          end do
        end do
      end do

!---------------------------------------------------------------------

  
end subroutine thickavg_3d



!####################################################################
! <SUBROUTINE NAME="thickavg_0d">
!  <OVERVIEW>
!   Subroutine to use thick-averaging technique to define band interval
!   single scattering properties.
!  </OVERVIEW>
!  <DESCRIPTION>
! use the thick-averaging technique to define the single-scattering    
! properties of the parameterization band spectral intervals from the  
! specified spectral intervals of the particular scatterer.            
!                                                                      
! references:                                                          
!                                                                      
! edwards,j.m. and a. slingo, studies with a flexible new radiation    
!      code I: choosing a configuration for a large-scale model.,      
!      q.j.r. meteorological society, 122, 689-719, 1996.              
!                                                                      
! note: the 1.0E-100 factor to calculate asymmband is to prevent        
!       division by zero.                                              
!  </DESCRIPTION>
!  <TEMPLATE>
!   call subroutine thickavg_0d (nivl1    , nivl2     , nivls   ,   &
!                        nbands,  &
!                        extivl   , ssalbivl  , asymmivl, solflxivl, &
!                        solflxband, extband  , ssalbband , asymmband)
!  </TEMPLATE>
!  <IN NAME="nivl1" TYPE="integer">
!   interval number for the specified single-scattering                
!              properties corresponding to the first psuedo-           
!              monochromatic frequency in a given parameterization     
!              band  
!  </IN>
!  <IN NAME="nivl2" TYPE="integer">
!   interval number for the specified single-scattering     
!              properties corresponding to the last psuedo-            
!              monochromatic frequency in a given parameterization     
!              band
!  </IN>
!  <IN NAME="nivls" TYPE="integer">
!   number of specified scattering spectral intervals
!  </IN>
!  <IN NAME="nbands" TYPE="integer">
!   number of spectral bands
!  </IN>
!  <IN NAME="extivl" TYPE="real">
!   the specified spectral values of the extinction coefficient 
!  </IN>
!  <INOUT NAME="ssalbivl" TYPE="real">
!   the specified spectral values of the single-scattering albedo
!  </INOUT>
!  <IN NAME="asymmivl" TYPE="real">
!   the specified spectral values of the asymmetry factor
!  </IN>
!  <IN NAME="solflxivl" TYPE="real">
!   the solar flux in each specified scattering spectral interval
!  </IN>
!  <IN NAME="solflxband" TYPE="real">
!   the solar flux in each parameterization band
!  </IN>
!  <OUT NAME="extband" TYPE="real">
!   the parameterization band values of the extinction coefficient
!  </OUT>
!  <OUT NAME="ssalbband" TYPE="real">
!   the parameterization band values of the single-scattering albedo
!  </OUT>
!  <OUT NAME="asymmband" TYPE="real">
!   the parameterization band values of the asymmetry factor
!  </OUT>
! </SUBROUTINE>
!
subroutine thickavg_0d (nivl1, nivl2, nivls, nbands, extivl, ssalbivl,&
                        asymmivl, solflxivl, solflxband, extband,  &
                        ssalbband , asymmband)
 
!---------------------------------------------------------------------
!    thickavg_0d uses the thick-averaging technique to define the 
!    single-scattering properties of the parameterization band spectral
!    intervals from the  specified spectral intervals of the particular
!    scatterer, using 3d input arrays.   
!    references:                                                       
!    edwards,j.m. and a. slingo, studies with a flexible new radiation  
!      code I: choosing a configuration for a large-scale model.,   
!      q.j.r. meteorological society, 122, 689-719, 1996.            
!--------------------------------------------------------------------

integer, dimension(:),    intent(in)       :: nivl1, nivl2
integer,                  intent(in)       :: nivls
integer,                  intent(in)       :: nbands
real, dimension(:),       intent(in)       :: extivl, asymmivl
real, dimension(:),       intent(inout)    :: ssalbivl
real, dimension(:,:),     intent(in)       :: solflxivl             
real, dimension(:),       intent(in)       :: solflxband            
real, dimension(:),       intent(out)      :: extband, ssalbband, &
                                              asymmband

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    nivl1       interval number for the specified single-scattering  
!                properties corresponding to the first psuedo-         
!                monochromatic frequency in a given parameterization    
!                band                                                  
!    nivl2       interval number for the specified single-scattering 
!                properties corresponding to the last psuedo-          
!                monochromatic frequency in a given parameterization    
!                band                                                 
!    nivls       number of specified scattering spectral intervals      
!    nbands
!    extivl      specified spectral values of the extinction coefficient
!    asymmivl    the specified spectral values of the asymmetry     
!                factor                                           
!    solflxivl   the solar flux in each specified scattering spectral
!                interval                                         
!    solflxband  the solar flux in each parameterization band  
!
!  intent(inout) variables:
!
!    ssalbivl    the specified spectral values of the single-       
!                scattering albedo                                   
!
!  intent(out) variables:
!
!    extband     the parameterization band values of the extinction 
!                coefficient                                      
!    ssalbband   the parameterization band values of the single-   
!                scattering albedo                                  
!    asymmband   the parameterization band values of the asymmetry   
!                factor                                               
!    
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!  local variables:

      real, dimension (nbands)        ::   refband
      real                            ::   refthick, sp, sumk,   &
                                           sumomegak, sumomegakg, &
                                           sumrefthick
      integer  :: nband 
      integer  :: ni
 
 
!--------------------------------------------------------------------
!  local variables:
!
!     refband
!     refthick
!     sp
!     sumk
!     sumomegak
!     sumomegakg
!     sumrefthck
!     nband
!     i,j,k,ni
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('rad_utilities_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif
  
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------
      do nband = 1,nbands
        sumk        = 0.0
        sumomegak   = 0.0
        sumomegakg  = 0.0
        sumrefthick = 0.0
        do ni = nivl1(nband),nivl2(nband)
          if (extivl(ni) /= 0.0) then
            ssalbivl(ni) = MIN(ssalbivl(ni), 1.0)
            sp = sqrt( ( 1.0 - ssalbivl(ni) ) /    &
                       ( 1.0 - ssalbivl(ni) * asymmivl(ni) ) )
            refthick = (1.0 - sp)/(1.0 + sp)
            sumrefthick = sumrefthick + refthick * solflxivl(nband,ni)
            sumk = sumk + extivl(ni) * solflxivl(nband,ni)
            sumomegak = sumomegak +     &
                        ssalbivl(ni) * extivl(ni) * solflxivl(nband,ni)
            sumomegakg = sumomegakg +    &
                         ssalbivl(ni) * extivl(ni) *  &
                         asymmivl(ni) * solflxivl(nband,ni)
          endif
        end do

!--------------------------------------------------------------------- 
!
!--------------------------------------------------------------------- 
        extband(nband) = sumk / solflxband(nband)
        asymmband(nband) = sumomegakg / ( sumomegak + 1.0E-100)
        refband(nband) = sumrefthick/ solflxband(nband)
        ssalbband(nband) = 4.0 * refband(nband) / &
                           ( (1.0 + refband(nband))**2 - &
                          asymmband(nband) * (1.0 - refband(nband))**2 )
      end do

!---------------------------------------------------------------------
  

end subroutine thickavg_0d


!##################################################################

! <SUBROUTINE NAME="thickavg_isccp">
!  <OVERVIEW>
!   Subroutine to use thick-averaging technique to define band interval
!   single scattering properties for a single specified band.
!  </OVERVIEW>
!  <DESCRIPTION>
! use the thick-averaging technique to define the single-scattering    
! properties of the specified parameterization band spectral interval 
! from the specified spectral intervals of the particular scatterer.    
!                                                                      
! references:                                                          
!                                                                      
! edwards,j.m. and a. slingo, studies with a flexible new radiation    
!      code I: choosing a configuration for a large-scale model.,      
!      q.j.r. meteorological society, 122, 689-719, 1996.              
!                                                                      
! note: the 1.0E-100 factor to calculate asymmband is to prevent        
!       division by zero.                                              
!  </DESCRIPTION>
!  <TEMPLATE>
!   call subroutine thickavg (nband, nivl1, nivl2, extivl, solflxivl, &
!                             solflxband, mask, extband )
!  </TEMPLATE>
!  <IN NAME="nband" TYPE="integer">
!
!  </IN>
!  <IN NAME="nivl1" TYPE="integer">
!   interval number for the specified single-scattering                
!              properties corresponding to the first psuedo-           
!              monochromatic frequency in a given parameterization     
!              band  
!  </IN>
!  <IN NAME="nivl2" TYPE="integer">
!   interval number for the specified single-scattering     
!              properties corresponding to the last psuedo-            
!              monochromatic frequency in a given parameterization     
!              band
!  </IN>
!  <IN NAME="extivl" TYPE="real">
!   the specified spectral values of the extinction coefficient 
!  </IN>
!  <IN NAME="solflxivl" TYPE="real">
!   the solar flux in each specified scattering spectral interval
!  </IN>
!  <IN NAME="solflxband" TYPE="real">
!   the solar flux in each parameterization band
!  </IN>
!  <IN NAME="mask" TYPE="logical">
!   mask is .true. at gridpoints where extband needs to be calculated
!  </IN>
!  <OUT NAME="extband" TYPE="real">
!   the parameterization band values of the extinction coefficient
!  </OUT>
! </SUBROUTINE>
!
subroutine thickavg_isccp (nband, nivl1, nivl2, extivl,          &
                           solflxivl, solflxband, mask, extband)
 
!---------------------------------------------------------------------
!    thickavg_isccp uses the thick-averaging technique to define the 
!    solar extinction for the single specified parameterization band 
!    spectral interval (nband) from the  specified spectral intervals 
!    of the particular scatterer, using 3d input arrays.   
!    references:                                                       
!    edwards,j.m. and a. slingo, studies with a flexible new radiation  
!      code I: choosing a configuration for a large-scale model.,   
!      q.j.r. meteorological society, 122, 689-719, 1996.            
!--------------------------------------------------------------------

integer,                  intent(in)       :: nband
integer,                  intent(in)       :: nivl1, nivl2
real, dimension(:,:,:,:), intent(in)       :: extivl
real, dimension(:,:),     intent(in)       :: solflxivl             
real,                     intent(in)       :: solflxband            
logical, dimension(:,:,:),intent(in)       :: mask
real, dimension(:,:,:),   intent(out)      :: extband

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    nband       the sw parameterization band for which the optical
!                properties are being calculated
!    nivl1       interval number for the specified single-scattering  
!                properties corresponding to the first psuedo-         
!                monochromatic frequency in a given parameterization    
!                band                                                  
!    nivl2       interval number for the specified single-scattering 
!                properties corresponding to the last psuedo-          
!                monochromatic frequency in a given parameterization    
!                band                                                 
!    extivl      specified spectral values of the extinction coefficient
!    solflxband  the solar flux in each parameterization band  
!    mask        logical indicating the points at which the band values 
!                should be calculated       
!
!  intent(out) variables:
!
!    extband     the parameterization band values of the extinction 
!                coefficient                                      
!    
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!  local variables:
 
      real     ::  sumk
      integer  ::  i, j, k, ni
 
!--------------------------------------------------------------------
!  local variables:
!
!     sumk
!     i,j,k,ni
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('rad_utilities_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!--------------------------------------------------------------------
!
      do k=1, size(extivl,3)
        do j=1,size(extivl,2)
          do i=1,size(extivl,1)
            if (mask(i,j,k)) then
              sumk = 0.0
              do ni = nivl1,nivl2
                sumk = sumk + extivl(i,j,k,ni)*solflxivl(nband,ni)
              end do
              extband(i,j,k) = sumk/solflxband
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------

  
end subroutine thickavg_isccp

!##################################################################

! <SUBROUTINE NAME="thickavg_1band">
!  <OVERVIEW>
!   Subroutine to use thick-averaging technique to define band interval
!   single scattering properties for a single specified band.
!  </OVERVIEW>
!  <DESCRIPTION>
! use the thick-averaging technique to define the single-scattering    
! properties of the specified parameterization band spectral interval 
! from the specified spectral intervals of the particular scatterer.    
!                                                                      
! references:                                                          
!                                                                      
! edwards,j.m. and a. slingo, studies with a flexible new radiation    
!      code I: choosing a configuration for a large-scale model.,      
!      q.j.r. meteorological society, 122, 689-719, 1996.              
!                                                                      
! note: the 1.0E-100 factor to calculate asymmband is to prevent        
!       division by zero.                                              
!  </DESCRIPTION>
!  <TEMPLATE>
!   call subroutine thickavg (nband, nivl1  , nivl2   , nivls   , &
!                        nbands, &
!                        extivl   , ssalbivl  , asymmivl, solflxivl, &
!                        solflxband,  mask, extband  , ssalbband ,  &
!                        asymmband)
!  </TEMPLATE>
!  <IN NAME="nband" TYPE="integer">
!
!  </IN>
!  <IN NAME="nivl1" TYPE="integer">
!   interval number for the specified single-scattering                
!              properties corresponding to the first psuedo-           
!              monochromatic frequency in a given parameterization     
!              band  
!  </IN>
!  <IN NAME="nivl2" TYPE="integer">
!   interval number for the specified single-scattering     
!              properties corresponding to the last psuedo-            
!              monochromatic frequency in a given parameterization     
!              band
!  </IN>
!  <IN NAME="nivls" TYPE="integer">
!   number of specified scattering spectral intervals
!  </IN>
!  <IN NAME="nbands" TYPE="integer">
!   number of spectral bands
!  </IN>
!  <IN NAME="extivl" TYPE="real">
!   the specified spectral values of the extinction coefficient 
!  </IN>
!  <INOUT NAME="ssalbivl" TYPE="real">
!   the specified spectral values of the single-scattering albedo
!  </INOUT>
!  <IN NAME="asymmivl" TYPE="real">
!   the specified spectral values of the asymmetry factor
!  </IN>
!  <IN NAME="solflxivl" TYPE="real">
!   the solar flux in each specified scattering spectral interval
!  </IN>
!  <IN NAME="solflxband" TYPE="real">
!   the solar flux in each parameterization band
!  </IN>
!  <IN NAME="mask" TYPE="logical">
!   mask is .true. at gridpoints where band calculations are needed
!  </IN>
!  <OUT NAME="extband" TYPE="real">
!   the parameterization band values of the extinction coefficient
!  </OUT>
!  <OUT NAME="ssalbband" TYPE="real">
!   the parameterization band values of the single-scattering albedo
!  </OUT>
!  <OUT NAME="asymmband" TYPE="real">
!   the parameterization band values of the asymmetry factor
!  </OUT>
! </SUBROUTINE>
!
subroutine thickavg_1band (nband, nivl1, nivl2, nivls, nbands, extivl, &
                           ssalbivl, asymmivl, solflxivl, solflxband, &
                           mask, extband, ssalbband, asymmband)
 
!---------------------------------------------------------------------
!    thickavg_1band uses the thick-averaging technique to define the 
!    single-scattering properties of the specified parameterization band
!    spectral interval from the  specified spectral intervals of the 
!    particular scatterer, using 3d input arrays.   
!    references:                                                       
!    edwards,j.m. and a. slingo, studies with a flexible new radiation  
!      code I: choosing a configuration for a large-scale model.,   
!      q.j.r. meteorological society, 122, 689-719, 1996.            
!--------------------------------------------------------------------

integer,                  intent(in)       :: nband
integer,                  intent(in)       :: nivl1, nivl2
integer,                  intent(in)       :: nivls
integer,                  intent(in)       :: nbands
real, dimension(:,:,:,:), intent(in)       :: extivl, asymmivl
real, dimension(:,:,:,:), intent(inout)    :: ssalbivl
real, dimension(:,:),     intent(in)       :: solflxivl             
real,                     intent(in)       :: solflxband            
real, dimension(:,:,:  ), intent(inout)      :: extband, ssalbband,   &
                                              asymmband
logical, dimension(:,:,:), intent(in)      :: mask

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    nband       the sw parameterization band for which the optical
!                properties are being calculated
!    nivl1       interval number for the specified single-scattering  
!                properties corresponding to the first psuedo-         
!                monochromatic frequency in a given parameterization    
!                band                                                  
!    nivl2       interval number for the specified single-scattering 
!                properties corresponding to the last psuedo-          
!                monochromatic frequency in a given parameterization    
!                band                                                 
!    nivls       number of specified scattering spectral intervals      
!    nbands
!    extivl      specified spectral values of the extinction coefficient
!    asymmivl    the specified spectral values of the asymmetry     
!                factor                                           
!    solflxivl   the solar flux in each specified scattering spectral
!                interval                                         
!    solflxband  the solar flux in each parameterization band  
!    mask        logical indicating the points at which the band values 
!                should be calculated       
!
!  intent(inout) variables:
!
!    ssalbivl    the specified spectral values of the single-       
!                scattering albedo                                   
!
!  intent(out) variables:
!
!    extband     the parameterization band values of the extinction 
!                coefficient                                      
!    ssalbband   the parameterization band values of the single-   
!                scattering albedo                                  
!    asymmband   the parameterization band values of the asymmetry   
!                factor                                               
!    
!--------------------------------------------------------------------
 
!--------------------------------------------------------------------
!  local variables:
 
      real :: refband, sp, refthick
      real :: sumk, sumomegak, sumomegakg,  sumrefthick

      integer  :: i, j, k, ni
 
!--------------------------------------------------------------------
!  local variables:
!
!     refband
!     refthick
!     sp
!     sumk
!     sumomegak
!     sumomegakg
!     sumrefthck
!     nband
!     i,j,k,ni
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('rad_utilities_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      do k=1, size(ssalbivl,3)
        do j=1,size(ssalbivl,2)
          do i=1,size(ssalbivl,1)
            if (mask(i,j,k)) then
              sumk        = 0.0
              sumomegak        = 0.0
              sumomegakg        = 0.0
              sumrefthick        = 0.0
              do ni = nivl1,nivl2
                ssalbivl(i,j,k,ni) = MIN(ssalbivl(i,j,k,ni), 1.0)
                sp = sqrt((1.0 - ssalbivl(i,j,k,ni) ) /    &
                          (1.0 - ssalbivl(i,j,k,ni)*asymmivl(i,j,k,ni)))
                refthick = (1.0 - sp)/(1.0 + sp)
                sumrefthick = sumrefthick + refthick*solflxivl(nband,ni)
                sumk = sumk + extivl(i,j,k,ni)*solflxivl(nband,ni)
                sumomegak = sumomegak + ssalbivl(i,j,k,ni)*   &
                                        extivl(i,j,k,ni)*   &
                                        solflxivl(nband,ni)
                sumomegakg = sumomegakg + ssalbivl(i,j,k,ni)*&
                                          extivl(i,j,k,ni)*  &
                                          asymmivl(i,j,k,ni)* &
                                          solflxivl(nband,ni)
              end do

!---------------------------------------------------------------------
!    the 1.0E-100 factor to calculate asymmband is to prevent        
!    division by zero.                                             
!---------------------------------------------------------------------
              extband(i,j,k) = sumk/solflxband
              asymmband(i,j,k) = sumomegakg/(sumomegak + 1.0E-100)
              refband  = sumrefthick/solflxband        
              ssalbband(i,j,k) = 4.0*refband/((1.0 + refband) ** 2 - &
                                 asymmband(i,j,k)*(1.0 - refband)**2 )
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------

  
end subroutine thickavg_1band

!####################################################################
! <SUBROUTINE NAME="thinavg">
!  <OVERVIEW>
!   Subroutine to use thin-averaging technique to define band interval
!   single scattering properties.
!  </OVERVIEW>
!  <DESCRIPTION>
! use the thin-averaging technique to define the single-scattering    
! properties of the parameterization band spectral intervals from the  
! specified spectral intervals of the particular scatterer.            
!                                                                      
! references:                                                          
!                                                                      
! edwards,j.m. and a. slingo, studies with a flexible new radiation    
!      code I: choosing a configuration for a large-scale model.,      
!      q.j.r. meteorological society, 122, 689-719, 1996.              
!                                                                      
! note: the 1.0E-100 factor to calculate asymmband is to prevent        
!       division by zero.                                              
!  </DESCRIPTION>
!  <TEMPLATE>
!   call subroutine thinavg (nivl1    , nivl2     , nivls   ,   &
!                        nbands, &
!                        extivl   , ssalbivl  , asymmivl, solflxivl, &
!                        solflxband, extband  , ssalbband , asymmband)
!  </TEMPLATE>
!  <IN NAME="nivl1" TYPE="integer">
!   interval number for the specified single-scattering                
!              properties corresponding to the first psuedo-           
!              monochromatic frequency in a given parameterization     
!              band  
!  </IN>
!  <IN NAME="nivl2" TYPE="integer">
!   interval number for the specified single-scattering     
!              properties corresponding to the last psuedo-            
!              monochromatic frequency in a given parameterization     
!              band
!  </IN>
!  <IN NAME="nivls" TYPE="integer">
!   number of specified scattering spectral intervals
!  </IN>
!  <IN NAME="extivl" TYPE="real">
!   the specified spectral values of the extinction coefficient 
!  </IN>
!  <IN NAME="nbands" TYPE="integer">
!   number of spectral bands
!  </IN>
!  <INOUT NAME="ssalbivl" TYPE="real">
!   the specified spectral values of the single-scattering albedo
!  </INOUT>
!  <IN NAME="asymmivl" TYPE="real">
!   the specified spectral values of the asymmetry factor
!  </IN>
!  <IN NAME="solflxivl" TYPE="real">
!   the solar flux in each specified scattering spectral interval
!  </IN>
!  <IN NAME="solflxband" TYPE="real">
!   the solar flux in each parameterization band
!  </IN>
!  <OUT NAME="extband" TYPE="real">
!   the parameterization band values of the extinction coefficient
!  </OUT>
!  <OUT NAME="ssalbband" TYPE="real">
!   the parameterization band values of the single-scattering albedo
!  </OUT>
!  <OUT NAME="asymmband" TYPE="real">
!   the parameterization band values of the asymmetry factor
!  </OUT>
! </SUBROUTINE>
!
subroutine thinavg (nivl1, nivl2, nivls, nbands, extivl, ssalbivl, &
                    asymmivl,  solflxivl, solflxband, extband,   &
                    ssalbband , asymmband)
 
!---------------------------------------------------------------------
!    thinavg uses the thin-averaging technique to define the 
!    single-scattering properties of the parameterization band spectral
!    intervals from the  specified spectral intervals of the particular
!    scatterer, using 3d input arrays.   
!    references:                                                       
!    edwards,j.m. and a. slingo, studies with a flexible new radiation  
!      code I: choosing a configuration for a large-scale model.,   
!      q.j.r. meteorological society, 122, 689-719, 1996.            
!--------------------------------------------------------------------

integer, dimension(:),    intent(in)       :: nivl1, nivl2
integer,                  intent(in)       :: nivls
integer,                  intent(in)       :: nbands
real, dimension(:,:,:,:), intent(in)       :: extivl, asymmivl
real, dimension(:,:,:,:), intent(inout)    :: ssalbivl
real, dimension(:,:),     intent(in)       :: solflxivl             
real, dimension(:),       intent(in)       :: solflxband            
real, dimension(:,:,:,:), intent(out)      :: extband, ssalbband,   &
                                              asymmband

!---------------------------------------------------------------------
!  intent(in) variables:
!
!    nivl1       interval number for the specified single-scattering  
!                properties corresponding to the first psuedo-         
!                monochromatic frequency in a given parameterization    
!                band                                                  
!    nivl2       interval number for the specified single-scattering 
!                properties corresponding to the last psuedo-          
!                monochromatic frequency in a given parameterization    
!                band                                                 
!    nivls       number of specified scattering spectral intervals      
!    nbands
!    extivl      specified spectral values of the extinction coefficient
!    asymmivl    the specified spectral values of the asymmetry     
!                factor                                           
!    solflxivl   the solar flux in each specified scattering spectral
!                interval                                         
!    solflxband  the solar flux in each parameterization band  
!
!  intent(inout) variables:
!
!    ssalbivl    the specified spectral values of the single-       
!                scattering albedo                                   
!
!  intent(out) variables:
!
!    extband     the parameterization band values of the extinction 
!                coefficient                                      
!    ssalbband   the parameterization band values of the single-   
!                scattering albedo                                  
!    asymmband   the parameterization band values of the asymmetry   
!                factor                                               
!    
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      real, dimension (size(ssalbivl,1),   &
                       size(ssalbivl,2),  &
                       size(ssalbivl,3)) ::   sumk,  sumomegak,   &
                                              sumomegakg
 
      integer   ::   nband
      integer   ::   i, j, k, ni

!--------------------------------------------------------------------
!  local variables:
! 
!    sumk
!    sumomegak
!    sumomegakg
!    nband
!    i,j,k,ni
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!    be sure module has been initialized.
!--------------------------------------------------------------------
      if (.not. module_is_initialized) then
        call error_mesg ('rad_utilities_mod',  &
         'initialization routine of this module was never called', &
                                                                 FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      do nband = 1,nbands
        sumk(:,:,:) = 0.0
        sumomegak(:,:,:) = 0.0
        sumomegakg(:,:,:) = 0.0
        do ni = nivl1(nband),nivl2(nband)
          do k=1, size(ssalbivl,3)
            do j=1,size(ssalbivl,2)
              do i=1,size(ssalbivl,1)
                if ((ssalbivl(i,j,k,ni) +    &
                     asymmivl(i,j,k,ni)) /= 0.0) then
                  ssalbivl(i,j,k,ni) = MIN(ssalbivl(i,j,k,ni), 1.0)
                  sumk(i,j,k) = sumk(i,j,k) + extivl(i,j,k,ni) *   &
                                solflxivl(nband,ni)
                  sumomegak(i,j,k) = sumomegak(i,j,k) +    &
                                     ssalbivl(i,j,k,ni) *  &
                                     extivl(i,j,k,ni) *   &
                                     solflxivl(nband,ni)
                  sumomegakg(i,j,k) = sumomegakg(i,j,k) +    &
                                      ssalbivl(i,j,k,ni) * & 
                                      extivl(i,j,k,ni) *   &
                                      asymmivl(i,j,k,ni) *  &
                                      solflxivl(nband,ni)
                endif
              end do
            end do
          end do
        end do

!----------------------------------------------------------------------
!
!---------------------------------------------------------------------
        do k=1, size(ssalbivl,3)
          do j=1,size(ssalbivl,2)
            do i=1,size(ssalbivl,1)
              extband(i,j,k,nband) = sumk(i,j,k) / solflxband(nband)
              asymmband(i,j,k,nband) = sumomegakg(i,j,k) /    &
                                       ( sumomegak(i,j,k) + 1.0E-100 )
              ssalbband(i,j,k,nband) = sumomegak(i,j,k) /   &
                                       ( sumk(i,j,k) + 1.0E-100 )
            end do
          end do
        end do
      end do

!-------------------------------------------------------------------
  

end subroutine thinavg 


!#########################################################################
subroutine get_radiative_param(text_in_scheme,text_in_param, &
                               rad_forc_online, tr_rad_name,  &
                               tr_clim_name, tr_rad_scale_factor)

character(len=*), intent(in)    :: text_in_scheme, text_in_param
logical, intent(out)            :: rad_forc_online
character(len=*), intent(out)   :: tr_rad_name,tr_clim_name
real,             intent(out)   :: tr_rad_scale_factor
integer                         :: flag


if(lowercase(trim(text_in_scheme(1:6))) == 'online') then
       rad_forc_online = .true.
       flag=parse(text_in_param,'name_in_rad_mod', tr_rad_name)
       flag=parse(text_in_param,'name_in_clim_mod', tr_clim_name)
       tr_rad_scale_factor = 1.
       flag=parse(text_in_param,'scale_factor', tr_rad_scale_factor)
else
       rad_forc_online = .false.
       tr_rad_name  = ' '
       tr_clim_name = ' '
       tr_rad_scale_factor = 1.
endif

end subroutine get_radiative_param


!#####################################################################

! <SUBROUTINE NAME="rad_utilities_end">
!  <OVERVIEW>
!   Subroutine to close out the radiation utility package.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine is the destructor for rad_utilies_mod. it marks
!   the module as uninitialized.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rad_utilities_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine rad_utilities_end

!--------------------------------------------------------------------
!    rad_utilites_end is the destructor for rad_utilities_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('rad_utilites_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
       module_is_initialized = .false.

!-------------------------------------------------------------------


end subroutine rad_utilities_end


subroutine aerosol_props_type_eq(aerosol_props_out,aerosol_props_in)

   type(aerosol_properties_type), intent(inout) :: aerosol_props_out
   type(aerosol_properties_type), intent(in)    :: aerosol_props_in

!  Need to add error trap to catch unallocated aerosol_props_in
   if (ASSOCIATED(aerosol_props_in%aerextband)) then
     aerosol_props_out%aerextband    = aerosol_props_in%aerextband
     aerosol_props_out%aerssalbband    = aerosol_props_in%aerssalbband
     aerosol_props_out%aerasymmband    = aerosol_props_in%aerasymmband
    else
      call error_mesg ('=', 'extband', FATAL)
   endif
   if (ASSOCIATED(aerosol_props_in%aerextbandlw)) then
     aerosol_props_out%aerextbandlw    = aerosol_props_in%aerextbandlw
     aerosol_props_out%aerssalbbandlw  = aerosol_props_in%aerssalbbandlw
     aerosol_props_out%aerextbandlw_cn =    &
                                       aerosol_props_in%aerextbandlw_cn
     aerosol_props_out%aerssalbbandlw_cn  =    &
                                     aerosol_props_in%aerssalbbandlw_cn
    else
      call error_mesg ('=', 'extbandlw', FATAL)
   endif
  if (Rad_control%volcanic_sw_aerosols) then
   if (ASSOCIATED(aerosol_props_in%sw_ext)) then
     aerosol_props_out%sw_ext        = aerosol_props_in%sw_ext     
     aerosol_props_out%sw_ssa          = aerosol_props_in%sw_ssa       
     aerosol_props_out%sw_asy          = aerosol_props_in%sw_asy
    else
      call error_mesg ('=', 'sw volc', FATAL)
   endif
  endif
  if (Rad_control%volcanic_lw_aerosols) then
   if (ASSOCIATED(aerosol_props_in%lw_ext)) then
     aerosol_props_out%lw_ext        = aerosol_props_in%lw_ext     
     aerosol_props_out%lw_ssa          = aerosol_props_in%lw_ssa       
     aerosol_props_out%lw_asy          = aerosol_props_in%lw_asy
    else
      call error_mesg ('=', 'lw volc', FATAL)
   endif
  endif
   if (ASSOCIATED(aerosol_props_in%sulfate_index)) then
     aerosol_props_out%sulfate_index = aerosol_props_in%sulfate_index
     aerosol_props_out%optical_index = aerosol_props_in%optical_index
     aerosol_props_out%omphilic_index = aerosol_props_in%omphilic_index
     aerosol_props_out%bcphilic_index = aerosol_props_in%bcphilic_index
     aerosol_props_out%seasalt1_index = aerosol_props_in%seasalt1_index
     aerosol_props_out%seasalt2_index = aerosol_props_in%seasalt2_index
     aerosol_props_out%seasalt3_index = aerosol_props_in%seasalt3_index
     aerosol_props_out%seasalt4_index = aerosol_props_in%seasalt4_index
     aerosol_props_out%seasalt5_index = aerosol_props_in%seasalt5_index
    else
      call error_mesg ('=', 'index  ', FATAL)
   endif

   if (ASSOCIATED(aerosol_props_in%ivol)) then
     aerosol_props_out%ivol = aerosol_props_in%ivol
    else
      call error_mesg ('=', 'ivol   ', FATAL)
   endif
   
     aerosol_props_out%sulfate_flag = aerosol_props_in%sulfate_flag
     aerosol_props_out%omphilic_flag = aerosol_props_in%omphilic_flag
     aerosol_props_out%bcphilic_flag = aerosol_props_in%bcphilic_flag
     aerosol_props_out%seasalt1_flag = aerosol_props_in%seasalt1_flag
     aerosol_props_out%seasalt2_flag = aerosol_props_in%seasalt2_flag
     aerosol_props_out%seasalt3_flag = aerosol_props_in%seasalt3_flag
     aerosol_props_out%seasalt4_flag = aerosol_props_in%seasalt4_flag
     aerosol_props_out%seasalt5_flag = aerosol_props_in%seasalt5_flag
     aerosol_props_out%bc_flag = aerosol_props_in%bc_flag



end subroutine aerosol_props_type_eq



subroutine lw_output_type_eq(lw_output_out,lw_output_in)

   type(lw_output_type), intent(inout) :: lw_output_out
   type(lw_output_type), intent(in)    :: lw_output_in

!  Need to add error trap to catch unallocated lw_output_in
   lw_output_out%heatra        = lw_output_in%heatra
   lw_output_out%flxnet        = lw_output_in%flxnet
   lw_output_out%netlw_special = lw_output_in%netlw_special
   lw_output_out%bdy_flx       = lw_output_in%bdy_flx
   if (ASSOCIATED(lw_output_in%heatracf))then
       lw_output_out%heatracf          = lw_output_in%heatracf
       lw_output_out%flxnetcf          = lw_output_in%flxnetcf
       lw_output_out%netlw_special_clr = lw_output_in%netlw_special_clr
       lw_output_out%bdy_flx_clr       = lw_output_in%bdy_flx_clr
   endif
end subroutine lw_output_type_eq


subroutine sw_output_type_eq(sw_output_out,sw_output_in)

   type(sw_output_type), intent(inout) :: sw_output_out
   type(sw_output_type), intent(in)    :: sw_output_in

!  Need to add error trap to catch unallocated sw_output_in
   sw_output_out%fsw              = sw_output_in%fsw
   sw_output_out%dfsw             = sw_output_in%dfsw
   sw_output_out%ufsw             = sw_output_in%ufsw
   sw_output_out%hsw              = sw_output_in%hsw
   sw_output_out%dfsw_dir_sfc     = sw_output_in%dfsw_dir_sfc
   sw_output_out%dfsw_dif_sfc     = sw_output_in%dfsw_dif_sfc
   sw_output_out%ufsw_dif_sfc     = sw_output_in%ufsw_dif_sfc
   sw_output_out%dfsw_vis_sfc     = sw_output_in%dfsw_vis_sfc
   sw_output_out%ufsw_vis_sfc     = sw_output_in%ufsw_vis_sfc
   sw_output_out%dfsw_vis_sfc_dir = sw_output_in%dfsw_vis_sfc_dir
   sw_output_out%dfsw_vis_sfc_dif = sw_output_in%dfsw_vis_sfc_dif
   sw_output_out%dfsw_vis_sfc_clr = sw_output_in%dfsw_vis_sfc_clr
   sw_output_out%ufsw_vis_sfc_dif = sw_output_in%ufsw_vis_sfc_dif
   sw_output_out%swdn_special     = sw_output_in%swdn_special
   sw_output_out%swup_special     = sw_output_in%swup_special
   sw_output_out%bdy_flx          = sw_output_in%bdy_flx
   if (ASSOCIATED(sw_output_in%fswcf))then
       sw_output_out%fswcf            = sw_output_in%fswcf
       sw_output_out%dfswcf           = sw_output_in%dfswcf
       sw_output_out%ufswcf           = sw_output_in%ufswcf
       sw_output_out%hswcf            = sw_output_in%hswcf
       sw_output_out%dfsw_dir_sfc_clr = sw_output_in%dfsw_dir_sfc_clr
       sw_output_out%dfsw_dif_sfc_clr = sw_output_in%dfsw_dif_sfc_clr
       sw_output_out%swdn_special_clr = sw_output_in%swdn_special_clr
       sw_output_out%swup_special_clr = sw_output_in%swup_special_clr
       sw_output_out%bdy_flx_clr      = sw_output_in%bdy_flx_clr
   endif  
end subroutine sw_output_type_eq


!####################################################################


                     end module rad_utilities_mod




!FDOC_TAG_GFDL

                 module rh_based_clouds_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!   fil
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!           module which defines cloud locations
!                     based on model relative humidity
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use mpp_mod,           only: input_nml_file
use fms_mod,           only: fms_init, open_namelist_file, mpp_pe, &
                             mpp_root_pe, stdlog,  &
                             write_version_number, file_exist, & 
                             check_nml_error, error_mesg,   &
                             FATAL, close_file
use rh_clouds_mod,     only: rh_clouds_avg      
use rad_utilities_mod, only: rad_utilities_init, &
                             cldrad_properties_type, &
                             cld_specification_type
use constants_mod,     only: radian
                                 

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!           module which defines cloud locations
!                     based on model relative humidity
!
!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128)  :: version =  '$Id: rh_based_clouds.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
  character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          rh_based_clouds_init,  &
          rh_clouds_amt,  &
          obtain_bulk_lw_rh, obtain_bulk_sw_rh, &
          rh_based_clouds_end, &
          cldalb, albcld_lw, albcld_sw




!---------------------------------------------------------------------
!-------- namelist  ---------


character(len=8)             :: cirrus_cld_prop_form  = 'full'

!    logical variables derived from namelist input

logical                      :: do_part_black_cirrus=.false.
logical                      :: do_full_black_cirrus=.false.






namelist /rh_based_clouds_nml /     &
       cirrus_cld_prop_form


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

!--------------------------------------------------------------------
!     define radiative properties for low, middle and high clouds
!     indices 1, 2 and 3, respectively).
!     cldem     : infrared emissivity
!     crfvis    : visible band reflectivity
!     crfir     : near-ir band reflectivity
!     cabir     : near-ir band absorptivity
!     crz       : cloud fraction
!--------------------------------------------------------------------
 
integer, parameter             :: NOFCLDS_SP=3  

real, dimension(NOFCLDS_SP)    ::                                  &
  crfvis,     crfir,     cabir,  &
                                  cldem
real                           :: crz


data crfvis / 0.59E+00, 0.45E+00, 0.21E+00 /
data crfir  / 0.59E+00, 0.45E+00, 0.21E+00 /
data cabir  / 0.40E+00, 0.30E+00, 0.04E+00 /
data cldem  / 1.0E+00, 1.0E+00, 1.0E+00 /  
data crz    / 1.00 /                     

!---------------------------------------------------------------------

!--------------------------------------------------------------------
!     these arrays define the cloud reflectivities as a function of 
!     zenith angle and the radiation band (visible and infrared) for 
!     high, middle and low clouds.
!     NREFL_BDS = number of radiative bands over which reflectivities
!              are provided.
!     NANGS     = number of zenith angles at which reflectivity values
!              are given.
!--------------------------------------------------------------------
 
integer, parameter                    ::  NANGS=17
integer, parameter                    ::  NREFL_BDS=2
real, dimension(NANGS,NREFL_BDS)      ::  albch, albcm, albcl 
 

!---------------------------------------------------------------------
!     albedos for high clouds at zenith angles from 0-80 deg. at 5 deg.
!     intervals for 1) visible and 2) infrared radiation.
!---------------------------------------------------------------------

data albch /      &
                 .04,.05,.05,.05,.06,.06,.07,.07,.08,.11,.13,.16,.21,  &
                 .28,.39,.48,.61,                                     &
                 .04,.05,.05,.05,.06,.06,.07,.07,.08,.10,.11,.14,.19, &
                 .26,.35,.44,.55 /

!---------------------------------------------------------------------
!     albedos for middle clouds at zenith angles from 0-80 deg. at 5 deg
!     intervals for 1) visible and 2) infrared radiation.
!----------------------------------------------------------------------

data albcm /     &
               .18,.18,.19,.20,.21,.23,.24,.26,.29,.33,.37,.42,.47,  &
               .55,.64,.71,.79,                                      &
               .14,.14,.15,.16,.17,.18,.18,.20,.23,.25,.29,.32,.37, &
               .43,.50,.55,.61 /

!-----------------------------------------------------------------------
!     albedos for low clouds at zenith angles from 0-80 deg. at 5 deg
!     intervals for 1) visible and 2) infrared radiation.
!-----------------------------------------------------------------------

data albcl /     &
                .50,.50,.51,.51,.52,.53,.54,.56,.58,.62,.65,.67,.69, &
                .73,.78,.82,.86,                                     &
                .42,.42,.43,.43,.44,.45,.46,.48,.50,.52,.55,.57,.59, &
                .63,.66,.70,.74 /


 
!-------------------------------------------------------------------
!     this array defines the zenith angle dependent albedo for each of 
!     the different cloud types (NOFCLDS_SP) for each of the radiative 
!     bands (NREFL_BDS). currently NREFL_BDS are the visible and the
!     infrared.
!-------------------------------------------------------------------
 
real, dimension (NOFCLDS_SP,NREFL_BDS)  ::  zza 
 
!--------------------------------------------------------------------
!     these variables define the boundaries (in sigma coordinates) 
!     between high and middle and middle and low clouds at the poles
!     and at the equator. 
!--------------------------------------------------------------------

real    :: cldhp = 0.7E+00
real    :: cldhe = 0.4E+00
real    :: cldmp = 0.85E+00
real    :: cldme = 0.7E+00
!-----------------------------------------------------------------

! cloud is present when relative humidity >= rh_crit, which varies liearly
!   in sigma from rh_crit_top at sigma = 0 to rh_crit_bot at sigma = 1

real :: rh_crit_bot    = 1.00
real :: rh_crit_top    = 0.90

logical :: module_is_initialized = .false.

!----------------------------------------------------------------------
!----------------------------------------------------------------------




                           contains 


! <SUBROUTINE NAME="rh_based_clouds_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rh_based_clouds_init
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine rh_based_clouds_init 



!--------------------------------------------------------------------
     integer :: unit, ierr, io, logunit


      if (module_is_initialized) return
      call fms_init
      call rad_utilities_init
!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=rh_based_clouds_nml, iostat=io)
      ierr = check_nml_error(io,"rh_based_clouds_nml")
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file (                          )
        ierr=1; do while (ierr /= 0)
        read (unit, nml=rh_based_clouds_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'rh_based_clouds_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!----------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
           write (logunit, nml=rh_based_clouds_nml)

!--------------------------------------------------------------------
! define the "blackness" of the cirrus clouds. cirrus clouds are either 
! "part black" with emissivity of 0.6 or are "full black" with emis-
! sivity of 1.0
!--------------------------------------------------------------------
        if (trim(cirrus_cld_prop_form) == 'part') then
          do_part_black_cirrus = .true.
        else if (trim(cirrus_cld_prop_form) == 'full') then
          do_full_black_cirrus = .true.
        else
          call error_mesg( 'cloudrad_package_init',  &
                ' cirrus_cld_prop_form is not an acceptable value.', & 
                                                      FATAL)
        endif


       module_is_initialized = .true.

end subroutine rh_based_clouds_init

!####################################################################

! <SUBROUTINE NAME="rh_based_clouds_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rh_based_clouds_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine rh_based_clouds_end

!----------------------------------------------------------------------
!    rh_based_clouds_end is the destructor for rh_based_cloouds_mod.
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------


end subroutine rh_based_clouds_end



!######################################################################

! <SUBROUTINE NAME="rh_clouds_amt">
!  <OVERVIEW>
!    rh_clouds_amt defines the location, amount (cloud fraction), number
!    and type (hi, mid, low) of clouds present on the model grid.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    rh_clouds_amt defines the location, amount (cloud fraction), number
!    and type (hi, mid, low) of clouds present on the model grid.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call rh_clouds_amt (is, ie, js, je, press, lat, Cld_spec)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="press" TYPE="real">
!      press        pressure at model levels (1:nlev), surface
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
! 
!  </IN>
!  <IN NAME="lat" TYPE="real">
!      lat          latitude of model points  [ radians ]
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec     cld_specification_type variable containing the
!                   cloud specification input fields needed by the
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of
!                           low clouds in a grid box
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine rh_clouds_amt (is, ie, js, je, press, lat, Cld_spec)

!----------------------------------------------------------------------
!    rh_clouds_amt defines the location, amount (cloud fraction), number
!    and type (hi, mid, low) of clouds present on the model grid.
!----------------------------------------------------------------------

integer,                      intent(in)    ::  is, ie, js, je
real,    dimension(:,:,:),    intent(in)    ::  press
real,    dimension(:,:),      intent(in)    ::  lat                    
type(cld_specification_type), intent(inout) ::  Cld_spec       

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      press        pressure at model levels (1:nlev), surface 
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
!      lat          latitude of model points  [ radians ]
!
!   intent(inout) variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of 
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of 
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of 
!                           low clouds in a grid box
!                                                                  
!---------------------------------------------------------------------
 
!-------------------------------------------------------------------
!   local variables:
 
      real, dimension (size(press,1), size(press,2),    &
                       size(press,3)-1)   ::  ccover, rh, sigma

      real, dimension (size(lat,1), size(lat,2)) ::     &
                                                 cldhm, cldml, rh_crit

      logical   ::  inside_max_ovlp_cld
      integer   ::  kmax 
      integer   ::  ierr
      integer   ::  k, j, i

!----------------------------------------------------------------------
!   local variables:
!
!           ccover       cloud fraction in a grid box [ dimensinless ]
!           rh           relative humidity [ dimensionless ]
!           sigma        ratio of pressure to surface pressure 
!                        [ dimensionless ]
!           cldhm        sigma value to use as the transition between
!                        middle and high clouds [ dimensionless ]
!           cldml        sigma value to use as the transition between
!                        low and middle clouds [ dimensionless ]
!           rh_crit      value of relative humidity at which clouds 
!                        are assumed present, as a function of sigma
!                        [ dimensionless ]
!           inside_max_ovlp_cld
!                        logical flag indicating whether the model grid
!                        box under consideration is part of a maximum
!                        overlap cloud with its base below the current
!                        level
!           kmax         number of model layers
!           ierr         error flag returned from rh_clouds_mod, if 
!                        non-zero indicates that all or some of the 
!                        relative humidity field was not retrievable
!           i,j,k        do loop indices
!
!--------------------------------------------------------------------- 


!--------------------------------------------------------------------
!    define the number of model layers.
!----------------------------------------------------------------------
      kmax = size (Cld_spec%camtsw,3)

!---------------------------------------------------------------------
!    define the sigma values marking the transitions between high,
!    middle and low clouds.  it must be calculated in this routine 
!    because model latitudes are not available during initialization
!    phase in the bgrid model core.
!---------------------------------------------------------------------
      cldhm(:,:) = cldhp + (90.0E+00-abs(lat(:,:)*   &
                   radian))*(cldhe-cldhp)/90.0E+00
      cldml(:,:) = cldmp + (90.0E+00-abs(lat(:,:)*    &
                   radian))*(cldme-cldmp)/90.0E+00

!---------------------------------------------------------------------- 
!    call rh_clouds_avg to obtain the appropriate array of relative 
!    humidity to use in defining cloud locations. this may be the inst-
!    antaneous field from the last time step or the average field in the
!    interval from the previous call to rh_clouds_avg.
!----------------------------------------------------------------------
      call rh_clouds_avg (is, js, rh, ierr)

!----------------------------------------------------------------------
!    if relative humidity data was present in rh_clouds_mod and values 
!    have been returned, determine those grid points where the relative
!    humidity exceeds the critical value for that grid box. define a
!    non-zero cloud fraction for those boxes; other boxes are given a
!    zero cloud fraction. note that cloud is not allowed to be present
!    in the topmost layer.
!----------------------------------------------------------------------
      if (ierr ==  0) then
        ccover(:,:,1) = 0.0
        do k=2,kmax 
          do j=1,size(press,2)
            do i=1,size(press,1)
              sigma(i,j,k) = press(i,j,k)/press(i,j,kmax+1)
              rh_crit(i,j) = rh_crit_top + sigma(i,j,k)*  &
                                           (rh_crit_bot - rh_crit_top)
              if (rh(i,j,k) >= rh_crit(i,j))  then 
                ccover(i,j,k) = crz
              else 
                ccover(i,j,k) = 0.0
              endif     
            end do
          end do
        end do

!---------------------------------------------------------------------
!    if relative humidity data could not be returned, set the clouds
!    to zero everywhere. this is a valid occurrence on the first
!    time step of a run, when radiation is calculated prior to the
!    moist_processes physics, and so no relative humidity data is 
!    present. if it occurs after the first step, an error is likely
!    present.
!---------------------------------------------------------------------
      else
        ccover(:,:,:) = 0.0
      endif

!---------------------------------------------------------------------
!    define the cloud specification arrays used by rh_clouds -- cloud 
!    fractions for random and maximally overlapped clouds and total 
!    clouds, number of each type of cloud in each column, and flags to
!    indicate whether a given cloud is to be given high, middle or low 
!    cloud properties.
!---------------------------------------------------------------------
      do j=1,size(press,2)
        do i=1,size(press,1)

!--------------------------------------------------------------------
!    define an indicator as to whether the current level is part of a
!    maximum-overlap cloud with a base at a lower level. the lowest
!    level obviously is not.
!---------------------------------------------------------------------
          inside_max_ovlp_cld = .false.

!---------------------------------------------------------------------
!    move upwards from the surface to level 2, since clouds are not
!    allowed at the topmost model level.
!----------------------------------------------------------------------
          do k=kmax,2,-1

!---------------------------------------------------------------------
!    if inside_max_ovlp_cld is .false., then this level is not part of 
!    a multi-layer cloud with a cloud base at a lower level, either 
!    because it does not contain cloud or because it contains a single 
!    level cloud, or because it is the lowest model level.
!---------------------------------------------------------------------
            if (.not. inside_max_ovlp_cld) then

!---------------------------------------------------------------------
!    if there is cloud at this level, determine if cloud exists at the
!    level above. if it doesn't then this is a one layer cloud and it
!    is counted as a random overlap cloud. if cloud does exist at the
!    level above, then this is the lowest level of a multi-layer cloud,
!    and it is denoted as a maximum overlap cloud. the flag 
!    inside_max_ovlp_cld is set to .true. to indicate that the next 
!    level is within a maximum overlap cloud.
!---------------------------------------------------------------------
              if (ccover(i,j,k) .NE. 0.0E+00) then
                if (ccover(i,j,k-1) .EQ. 0.0E+00 ) then
                  Cld_spec%nrndlw(i,j) = Cld_spec%nrndlw(i,j) + 1
                  Cld_spec%crndlw(i,j,k) = ccover(i,j,k)
                else
                  inside_max_ovlp_cld = .true.
                  Cld_spec%cmxolw(i,j,k) = ccover(i,j,k)
                endif
              endif
!--------------------------------------------------------------------
!    if inside_max_ovlp_cld is .true., then the current level is 
!    contained within a multi-layer cloud (max overlap) with a cloud 
!    base at a lower level. define the cloud on this level as maximum 
!    overlap. the counter of maximum overlap clouds is incremented when 
!    either the model top (k = 2, since no clouds allowed at level 1) 
!    is reached, or the level above does not contain cloudiness. if the 
!    level above does not contain clouds, then the flag 
!    inside_max_ovlp_cld is set .false. to indicate that the level above
!    is not part of a maximum overlap cloud with a cloud base at a 
!    lower level.
!--------------------------------------------------------------------
            else
              Cld_spec%cmxolw(i,j,k) = ccover(i,j,k)
              if (k .EQ. 2) then
                Cld_spec%nmxolw(i,j) = Cld_spec%nmxolw(i,j) + 1
              endif
              if (ccover(i,j,k-1) .EQ. 0.0E+00) then
                Cld_spec%nmxolw(i,j) = Cld_spec%nmxolw(i,j) + 1
                inside_max_ovlp_cld = .false.
              endif
            endif

!---------------------------------------------------------------------
!    define the cloud fraction seen by the shortwave radiation as the 
!    sum of the random and maximum overlap cloud fractions.
!---------------------------------------------------------------------
            Cld_spec%camtsw(i,j,k) = Cld_spec%cmxolw(i,j,k) +  &
                                     Cld_spec%crndlw(i,j,k)

!----------------------------------------------------------------------
!    if cloud is present, it must be designated as high, middle or low
!    so that the grid box can be given the radiation characteristics of
!    that cloud type. the arrays cldhm and cldml define the sigma
!    boundaries of the different cloud types.
!----------------------------------------------------------------------
            if (Cld_spec%camtsw(i,j,k) > 0.0) then
              if (sigma(i,j,k) <= cldhm(i,j) ) then
                Cld_spec%hi_cloud(i,j,k) = .true.
              else if (sigma(i,j,k) > cldhm(i,j)  .and.  &
                       sigma(i,j,k) < cldml(i,j) ) then
                Cld_spec%mid_cloud(i,j,k) = .true.
              else if (sigma(i,j,k) >= cldml(i,j) ) then
                Cld_spec%low_cloud(i,j,k) = .true.
              endif
            endif
          end do

!-------------------------------------------------------------------
!      define the total number of clouds present in each column.
!-------------------------------------------------------------------
          Cld_spec%ncldsw(i,j) = Cld_spec%nmxolw(i,j) +   &
                                 Cld_spec%nrndlw(i,j)
        end do
      end do

!--------------------------------------------------------------------


end subroutine rh_clouds_amt 





!####################################################################

! <SUBROUTINE NAME="obtain_bulk_lw_rh">
!  <OVERVIEW>
!    obtain_bulk_lw_rh defines bulk longwave cloud radiative
!    properties for the rh cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_lw_rh defines bulk longwave cloud radiative
!    properties for the rh cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_lw_rh (is, ie, js, je, Cld_spec, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for
!                               maximally overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_lw_rh (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_lw_rh defines bulk longwave cloud radiative 
!    properties for the rh cloud scheme.
!---------------------------------------------------------------------

integer,                     intent(in)     :: is, ie, js, je
type(cld_specification_type), intent(in   ) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------


!------------------------------------------------------------------
!     call albcld_lw to define long-wave cloud emissivities.
!-------------------------------------------------------------------
        call albcld_lw (Cld_spec%hi_cloud, Cld_spec%mid_cloud,  &
                        Cld_spec%low_cloud, Cld_spec%cmxolw,  &
                        Cld_spec%crndlw,    &
                        Cldrad_props%emmxolw(:,:,:,:,1),  &
                        Cldrad_props%emrndlw(:,:,:,:,1))


end subroutine obtain_bulk_lw_rh



!######################################################################

! <SUBROUTINE NAME="obtain_bulk_sw_rh">
!  <OVERVIEW>
!    obtain_bulk_sw_rh defines bulk shortwave cloud radiative
!    properties for the rh cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_sw_rh defines bulk shortwave cloud radiative
!    properties for the rh cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_sw_rh (is, ie, js, je, cosz, Cld_spec,   &
!                Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="cosz" TYPE="real">
!      cosz         cosine of the zenith angle [ dimensionless ]
! 
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the
!                               visible frequency band
!                               [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_sw_rh (is, ie, js, je, cosz, Cld_spec,   &
                              Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_sw_rh defines bulk shortwave cloud radiative 
!    properties for the rh cloud scheme.
!---------------------------------------------------------------------
 
integer,                      intent(in)    :: is, ie, js, je
real,    dimension(:,:),      intent(in)    :: cosz
type(cld_specification_type), intent(in   ) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      cosz         cosine of the zenith angle [ dimensionless ]
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    local variables:

      integer      ::  j, i  ! do-loop indices
 
!-------------------------------------------------------------------
!    define the bulk sw cloud radiative properties at each grid point 
!    which contains cloud.
!-------------------------------------------------------------------
      do j=1,size(Cld_spec%ncldsw,2)          
        do i=1,size(Cld_spec%ncldsw,1)          
          if (Cld_spec%ncldsw(i,j) > 0 ) then

!-----------------------------------------------------------------------
!    call cldalb to define the zenith angle dependent cloud visible
!    and infrared reflectivities for high, middle and low clouds in
!    each model column containing cloud.
!-----------------------------------------------------------------------
            call cldalb (cosz(i,j))

!-----------------------------------------------------------------------
!    call albcld_sw to assign the zenith-angle-dependent visible and 
!    infrared reflectivities and infrared absorptivities to the model 
!    clouds in the current column.
!-----------------------------------------------------------------------
            call albcld_sw (i, j, Cld_spec%hi_cloud, &
                            Cld_spec%mid_cloud, Cld_spec%low_cloud,  &
                            Cld_spec%camtsw, Cld_spec%cmxolw,   &
                            Cld_spec%crndlw, Cldrad_props%cvisrfsw, &
                            Cldrad_props%cirrfsw, Cldrad_props%cirabsw)
          endif
        end do
      end do

!----------------------------------------------------------------------
 

 end subroutine obtain_bulk_sw_rh



!####################################################################

! <SUBROUTINE NAME="cldalb">
!  <OVERVIEW>
!     cldalb calculates a zenith angle dependency for the cloud albedos.
!     the cloud albedos are interpolated using data adapted from fritz
!     (1954).  the solar zenith angle is the only input required.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!     cldalb calculates a zenith angle dependency for the cloud albedos.
!     the cloud albedos are interpolated using data adapted from fritz
!     (1954).  the solar zenith angle is the only input required.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call cldalb (zenith)
!
!  </TEMPLATE>
!  <IN NAME="zenith" TYPE="real">
!   zenith angle
!  </IN>
! </SUBROUTINE>
!
subroutine cldalb (zenith)

!---------------------------------------------------------------------
!     cldalb calculates a zenith angle dependency for the cloud albedos.
!     the cloud albedos are interpolated using data adapted from fritz 
!     (1954).  the solar zenith angle is the only input required.
!-----------------------------------------------------------------------

real, intent(in)           ::  zenith

!--------------------------------------------------------------------
      real                 :: zangle, remain
      integer              :: nband, indx

!--------------------------------------------------------------------
!     define zenith angle in degrees. for original Skyhi results, use 
!     a zenith angle specified as 60.00001 and the skyhi albedo values.
!-----------------------------------------------------------------------

        zangle = ACOS(zenith)*radian

!-----------------------------------------------------------------------
!     define reflectivities for each cloud level.
!-----------------------------------------------------------------------
        if (zangle .GE. 80.0E+00) then
!-----------------------------------------------------------------------
!     if zenith angle is greater than 80 degrees, define the reflect-
!     ivities as those values in the table at 80 degrees (last entry).
!-----------------------------------------------------------------------
          do nband=1,NREFL_BDS
            zza(3,nband) = albch(NANGS,nband)
            zza(2,nband) = albcm(NANGS,nband)
            zza(1,nband) = albcl(NANGS,nband)
          end do  
        else
!-----------------------------------------------------------------------
!     if zenith angle is less than 80 degrees, interpolate albedos from 
!     tables for each cloud level.
!-----------------------------------------------------------------------
          indx   = IFIX(zangle/5.0E+00) + 1
          remain = AMOD(zangle, 5.0E+00)
          do nband=1,NREFL_BDS
            zza(3,nband) = albch(indx,nband) + (remain/5.0E+00)*  &
                           (albch(indx+1,nband) - albch(indx,nband))
            zza(2,nband) = albcm(indx,nband) + (remain/5.0E+00)*  &
                           (albcm(indx+1,nband) - albcm(indx,nband))
            zza(1,nband) = albcl(indx,nband) + (remain/5.0E+00)*   &
                           (albcl(indx+1,nband) - albcl(indx,nband))
          end do 
        endif



end subroutine cldalb




!##################################################################

! <SUBROUTINE NAME="albcld_lw">
!  <OVERVIEW>
!     albcld_lw computes the lw cloud emissivities. This calculation is
!     based on sigma and cloud thickness in the old scheme (cldht60)
!     and sigma, cloud thickness and latitude in the new scheme
!     (cldht93).
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!     albcld_lw computes the lw cloud emissivities. This calculation is
!     based on sigma and cloud thickness in the old scheme (cldht60)
!     and sigma, cloud thickness and latitude in the new scheme
!     (cldht93).
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call albcld_lw(hi_cloud, mid_cloud, low_cloud,       &
!                cmxolw, crndlw, emmxolw, emrndlw)
!
!  </TEMPLATE>
!  <IN NAME="hi_cloud" TYPE="logical">
! 
!  </IN>
!  <IN NAME="mid_cloud" TYPE="logical">
! 
!  </IN>
!  <IN NAME="low_cloud" TYPE="logical">
! 
!  </IN>
!  <IN NAME="cmxolw" TYPE="real">
! 
!  </IN>
!  <IN NAME="crndlw" TYPE="real">
! 
!  </IN>
!  <INOUT NAME="emmxolw" TYPE="real">
! 
!  </INOUT>
!  <INOUT NAME="emrndlw" TYPE="real">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine albcld_lw(hi_cloud, mid_cloud, low_cloud,       &
             cmxolw, crndlw, emmxolw, emrndlw)

!-----------------------------------------------------------------------
!     albcld_lw computes the lw cloud emissivities. This calculation is 
!     based on sigma and cloud thickness in the old scheme (cldht60) 
!     and sigma, cloud thickness and latitude in the new scheme 
!     (cldht93).
!-----------------------------------------------------------------------

real, dimension(:,:,:),   intent(in)    :: cmxolw, crndlw
real, dimension(:,:,:,:), intent(inout) :: emmxolw, emrndlw
logical, dimension(:,:,:),intent(in)    :: hi_cloud, mid_cloud,   &
   low_cloud

!---------------------------------------------------------------------
!    local variables
!---------------------------------------------------------------------

       integer  ::  i, j, k, kk
      integer  :: israd, ierad, jsrad, jerad, ksrad, kerad
      israd= 1
      jsrad= 1
      ksrad= 1
      ierad = size (cmxolw,1)
      jerad = size (cmxolw,2)
      kerad = size (cmxolw,3)

!-----------------------------------------------------------------------
!     compute the emissivities for each cloud in the column. 
!-----------------------------------------------------------------------

         do k=KSRAD,KERAD
   do j=JSRAD,JERAD
     do i=ISRAD,IERAD
               if ((cmxolw(i,j,k) + crndlw(i,j,k) ) > 0.0) then
!-----------------------------------------------------------------------
!     case of a thick cloud. note that thick cloud properties are deter-
!     mined by the height of the base of the thick cloud, so that if 
!     there are two adjacent cirrus level clouds, they are assigned
!     cirrus cloud properties, incontrast to the cldht60 treatment.
!-----------------------------------------------------------------------
                 if (cmxolw(i,j,k) .NE. 0.0E+00) then
!-----------------------------------------------------------------------
!     case of a thick high cloud.
!-----------------------------------------------------------------------
                   if (hi_cloud(i,j,k)) then
                       emmxolw(i,j,k,:) = cldem(3)*0.6
!-----------------------------------------------------------------------
!     case of a thick middle cloud.
!-----------------------------------------------------------------------
                   else if (mid_cloud(i,j,k)) then
             emmxolw(i,j,k,:) = cldem(2)
!-----------------------------------------------------------------------
!     case of a thick low cloud.
!-----------------------------------------------------------------------
                   else if (low_cloud (i,j,k)) then
             emmxolw(i,j,k,:) = cldem(1)
                   endif
                 endif
         if (crndlw(i,j,k) .NE. 0.0E+00) then
!-----------------------------------------------------------------------
!     case of a thin high cloud.
!-----------------------------------------------------------------------
                   if (hi_cloud(i,j,k)) then
             if (do_full_black_cirrus) then
                       emrndlw(i,j,k,:) = cldem(3)
             else if (do_part_black_cirrus) then
               emrndlw(i,j,k,:) = 0.6E+00*cldem(3)
             endif
!-----------------------------------------------------------------------
!     case of a thin middle cloud.
!-----------------------------------------------------------------------
                   else if (mid_cloud(i,j,k)) then 
             emrndlw(i,j,k,:) = cldem(2)
!-----------------------------------------------------------------------
!     case of a thin low cloud.
!-----------------------------------------------------------------------
                   else if (low_cloud(i,j,k)) then
             emrndlw(i,j,k,:) = cldem(1)
           endif
                 endif
       endif
             end do     
           end do
         end do
!------------------------------------------------------------------
!! for fms formulation, set thick cloud properties based on cloud base,
!  even if some cloud layers extend out of the cloud base type region
!-------------------------------------------------------------------

           do k=KERAD,KSRAD+1,-1
     do j=JSRAD,JERAD
       do i=ISRAD,IERAD
                 if (cmxolw(i,j,k) /= 0.0) then
                   kk = k-1
                   if (cmxolw(i,j,kk) /= 0.0) then
                     emmxolw(i,j,kk,:) = emmxolw(i,j,k,:)
                   endif
                 endif
               end do
             end do
           end do
     
 
end subroutine albcld_lw


!####################################################################

! <SUBROUTINE NAME="albcld_sw">
!  <OVERVIEW>
!     albcld_sw computes the cloud albedos. This calculation is based on
!     sigma and cloud thickness in the old scheme (cldht60) and sigma,
!     cloud thickness  and latitude in the new scheme (cldht93).
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!     albcld_sw computes the cloud albedos. This calculation is based on
!     sigma and cloud thickness in the old scheme (cldht60) and sigma,
!     cloud thickness  and latitude in the new scheme (cldht93).
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call albcld_sw(i,j, hi_cloud, mid_cloud, low_cloud,         &
!                camtsw, cmxolw, crndlw, cvisrfsw, cirrfsw, cirabsw)
!
!  </TEMPLATE>
!  <INOUT NAME="i" TYPE="real">
! 
!  </INOUT>
!  <IN NAME="j" TYPE="integer">
! 
!  </IN>
!  <IN NAME="hi_cloud" TYPE="logical">
! 
!  </IN>
!  <IN NAME="mid_cloud" TYPE="logical">
! 
!  </IN>
!  <IN NAME="low_cloud" TYPE="logical">
! 
!  </IN>
!  <IN NAME="camtsw" TYPE="real">
! 
!  </IN>
!  <IN NAME="cmxolw" TYPE="real">
! 
!  </IN>
!  <IN NAME="crndlw" TYPE="real">
! 
!  </IN>
!  <INOUT NAME="cvisrfsw" TYPE="real">
! 
!  </INOUT>
!  <INOUT NAME="cirrfsw" TYPE="real">
! 
!  </INOUT>
!  <INOUT NAME="cirabsw" TYPE="real">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine albcld_sw(i,j, hi_cloud, mid_cloud, low_cloud,         &
     camtsw, cmxolw, crndlw, cvisrfsw, cirrfsw, cirabsw)

!-----------------------------------------------------------------------
!     albcld_sw computes the cloud albedos. This calculation is based on
!     sigma and cloud thickness in the old scheme (cldht60) and sigma, 
!     cloud thickness  and latitude in the new scheme (cldht93).
!-----------------------------------------------------------------------

!real, dimension(:,:,:),   intent(inout) :: camtsw, cmxolw, crndlw
real, dimension(:,:,:),   intent(in) :: camtsw, cmxolw, crndlw
real, dimension(:,:,:), intent(inout) :: cvisrfsw, cirrfsw, cirabsw
logical, dimension(:,:,:),intent(in)    :: hi_cloud, mid_cloud,   &
   low_cloud
integer,                  intent(in)    :: i, j
!---------------------------------------------------------------------

       integer  ::  k,  kk

      integer  :: israd, ierad, jsrad, jerad, ksrad, kerad

      israd = 1
      jsrad = 1
      ksrad = 1
      ierad = size (camtsw,1)
      jerad = size (camtsw,2)
      kerad = size (camtsw,3)
!-----------------------------------------------------------------------
!     compute the reflectivities and absorptivities for each cloud in 
!     the column. cldhm and cldml are sigma levels which serve as 
!     boundaries between low, middle and high clouds. 
!-----------------------------------------------------------------------
         do k=KSRAD+1,KERAD
           if (camtsw(i,j,k) .NE. 0.0E+00) then
!-----------------------------------------------------------------------
!     case of a thick cloud. note that thick cloud properties are deter-
!     mined by the height of the base of the thick cloud, so that if 
!     there are two adjacent cirrus level clouds, they are assigned
!     cirrus cloud properties.
!-----------------------------------------------------------------------
             if (cmxolw(i,j,k) .NE. 0.0E+00) then
!-----------------------------------------------------------------------
!     case of a thick high cloud.
!-----------------------------------------------------------------------
               if (hi_cloud(i,j,k)) then
                 cvisrfsw(i,j,k) = zza(3,1)
                 cirrfsw(i,j,k) = zza(3,2)
                   cirabsw(i,j,k) = MIN(0.99-cirrfsw(i,j,k), &
                                            cabir(3) )

!-----------------------------------------------------------------------
!     case of a thick middle cloud.
!-----------------------------------------------------------------------
               else if (mid_cloud(i,j,k)) then
                 cvisrfsw(i,j,k) = zza(2,1)
                 cirrfsw(i,j,k) = zza(2,2)
                   cirabsw(i,j,k) = MIN(0.99-cirrfsw(i,j,k), &
                                            cabir(2) )

!-----------------------------------------------------------------------
!     case of a thick low cloud.
!-----------------------------------------------------------------------
               else if (low_cloud(i,j,k)) then
                 cvisrfsw(i,j,k) = zza(1,1)
                 cirrfsw(i,j,k) = zza(1,2)
                   cirabsw(i,j,k) = MIN(0.99-cirrfsw(i,j,k), &
                                    cabir(1) )
               endif
             endif
     if (crndlw(i,j,k) .NE. 0.0E+00) then

!-----------------------------------------------------------------------
!     case of a thin high cloud.
!-----------------------------------------------------------------------
               if (hi_cloud(i,j,k)) then
                 cvisrfsw(i,j,k) = zza(3,1)
                 cirrfsw(i,j,k) = zza(3,2)
                   cirabsw(i,j,k) = MIN(0.99-cirrfsw(i,j,k), &
                                            cabir(3) )

!-----------------------------------------------------------------------
!     case of a thin middle cloud.
!-----------------------------------------------------------------------
               else if (mid_cloud(i,j,k))  then
                 cvisrfsw(i,j,k) = zza(2,1)
                 cirrfsw(i,j,k) = zza(2,2)
                   cirabsw(i,j,k) = MIN(0.99-cirrfsw(i,j,k), &
                                            cabir(2) )

!-----------------------------------------------------------------------
!     case of a thin low cloud.
!-----------------------------------------------------------------------
               else if (low_cloud(i,j,k)) then
                 cvisrfsw(i,j,k) = zza(1,1)
                 cirrfsw(i,j,k) = zza(1,2)
                   cirabsw(i,j,k) = MIN(0.99-cirrfsw(i,j,k), &
                                            cabir(1) )
               endif
             endif
           endif
         end do     

!------------------------------------------------------------------
!! for fms formulation, set thick cloud properties based on cloud base,
!  even if some cloud layers extend out of the cloud base type region
!-------------------------------------------------------------------
           do k=KERAD,KSRAD+1,-1
             if (cmxolw(i,j,k) /= 0.0) then
               kk = k-1
               if (cmxolw(i,j,kk) /= 0.0) then
                 cvisrfsw(i,j,kk) = cvisrfsw(i,j,k)
                 cirrfsw(i,j,kk) = cirrfsw(i,j,k)
                 cirabsw(i,j,kk) = cirabsw(i,j,k)
               endif
             endif
           end do
     
 
end subroutine albcld_sw



       end module rh_based_clouds_mod




                           module sealw99_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Dan.Schwarzkopf@noaa.gov">
!  ds
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!  This code provides the core functionality of FMS longwave
!  radiation. It is based on exchange method with prescribed
!  coefficients embedded in the code.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>
!
!  shared modules:

use mpp_mod,             only: input_nml_file
use fms_mod,             only: open_namelist_file, fms_init, &
                               mpp_pe, mpp_root_pe, stdlog, &
                               file_exist, write_version_number, &
                               check_nml_error, error_mesg, &
                               FATAL, NOTE,  close_file
use time_manager_mod,    only: time_type, operator(>=), get_time, &
                               operator(-), get_date
use constants_mod,       only: constants_init, diffac, radcon_mks, &
                               SECONDS_PER_DAY, radcon

!  radiation package shared modules:

use rad_utilities_mod,   only: rad_utilities_init, Lw_control, &
                               cldrad_properties_type, &
                               cld_specification_type, &
                               lw_output_type, longwave_tables1_type,  &
                               longwave_tables2_type,  &
                               longwave_tables3_type, atmos_input_type,&
                               Cldrad_control, radiative_gases_type, &
                               aerosol_type, aerosol_properties_type, &
                               aerosol_diagnostics_type, &
                               optical_path_type, gas_tf_type, &
                               lw_table_type, Lw_parameters, &
                               lw_diagnostics_type, lw_clouds_type, &
                               locate_in_table, looktab, mass_1,  &
                               temp_1, Rad_control
use longwave_params_mod, only: longwave_params_init, NBCO215, &
                               NBLY_CKD, NBLY_RSB, longwave_params_end

! radiation package modules:

use longwave_clouds_mod, only: longwave_clouds_init, cldtau, cloud,   &
                               lw_clouds_dealloc, longwave_clouds_end, &
                               thickcld 
use longwave_fluxes_mod, only: longwave_fluxes_ks,    &
                               longwave_fluxes_init, &
                               longwave_fluxes_end, &
                               longwave_fluxes_k_down,  &
                               longwave_fluxes_KE_KEp1,  &
                               longwave_fluxes_diag,   &
                               longwave_fluxes_sum
use longwave_tables_mod, only: longwave_tables_init,  &
                               longwave_tables_end
use optical_path_mod,    only: optical_path_setup, &
                               optical_path_init,  &
                               optical_trans_funct_from_KS, &
                               optical_trans_funct_k_down, &
                               optical_trans_funct_KE, &
                               optical_trans_funct_diag, &
                               get_totvo2, get_totch2o, get_totch2obd,&
                               optical_dealloc, optical_path_end
use gas_tf_mod,          only: co2coef, transcolrow, transcol, &
                               get_control_gas_tf, gas_tf_init, &
                               gas_tf_dealloc, gas_tf_end,   &
                               trans_sfc, trans_nearby
use lw_gases_stdtf_mod,  only: lw_gases_stdtf_init, cfc_indx8,  &
                               cfc_indx8_part, cfc_exact, &
                               lw_gases_stdtf_time_vary, &
                               lw_gases_stdtf_dealloc, co2_lblinterp, &
                               ch4_lblinterp, n2o_lblinterp, &
                               lw_gases_stdtf_end

!------------------------------------------------------------------

implicit none
private

!-------------------------------------------------------------------
!    sealw99_mod is the internal driver for the 1999 sea longwave 
!    radiation code.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module -------------------

    character(len=128)  :: version =  '$Id: sealw99.F90,v 18.0.2.1.2.1.2.1 2010/08/30 20:33:33 wfc Exp $'
    character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'
    logical             ::  module_is_initialized = .false.

!---------------------------------------------------------------------
!-------  interfaces --------

public       &
         sealw99_init,  sealw99_time_vary,  sealw99,  &
         sealw99_endts, sealw99_end

private   &
          check_tf_interval, obtain_gas_tfs, &
          sealw99_alloc, &
          cool_to_space_approx,   cool_to_space_exact, &
          e1e290, e290, esfc, enear, &
          co2_source_calc, nlte, co2curt, &
          co2_time_vary, ch4_time_vary, n2o_time_vary


!---------------------------------------------------------------------
!-------- namelist  ---------

logical            ::    &
                do_thick = .false.  ! perform "pseudo-convective  
                                    ! adjustment" for maximally 
                                    ! overlapped clouds ?
logical            ::    &
            do_lwcldemiss = .false. ! use multiple bands to calculate
                                    ! lw cloud emissivites ? 
logical            ::    &
      do_ch4lbltmpint  = .false.    ! perform and save intermediate
                                    ! flux calculations for ch4?
logical            ::    &
      do_n2olbltmpint  = .false. ! perform and save intermediate
                                    ! flux calculations for n2o?
logical            ::   &
           do_nlte = .false.        ! there is a non-local thermodynamic
                                    ! equilibrium region at top 
                                    ! of model ?
character(len=16)  ::  &
            continuum_form = '    ' ! continuum specification; either
                                    ! 'ckd2.1', 'ckd2.4', 'mt_ckd1.0', 
                                    ! 'rsb' or 'none'
character(len=16)  ::  &
        linecatalog_form = '    '   ! line catalog specification; either
                                    ! 'hitran_1992' or 'hitran_2000'
real               ::  &
        co2_tf_calc_intrvl = 1.0E6  ! interval between recalculating co2
                                    ! transmission functions, relevant
                                    ! for time-varying co2 cases 
                                    ! [ hours ]
logical            ::  &
        calc_co2_tfs_on_first_step = .true. 
                                    ! always calculate co2 tfs on 
                                    ! first time step of job ?
logical            ::  &
        use_current_co2_for_tf = .false.  
                                    ! use current co2 mixing ratio for  
                                    ! calculating tfs ?
real               ::  &
        co2_tf_time_displacement = 0.0 
                                    ! time displacement from job start 
                                    ! to the point in time where co2 
                                    ! tfs are to be valid -- may be (-),
                                    ! 0.0 or (+); used only when
                                    ! calc_co2_tfs_on_first_step is true
                                    ! [ hours ]
real               ::  &
        ch4_tf_calc_intrvl = 1.0E6  ! interval between recalculating ch4
                                    ! transmission functions, relevant
                                    ! for time-varying ch4 cases 
                                    ! [ hours ]
logical            ::  &
        calc_ch4_tfs_on_first_step = .true. 
                                    ! always calculate ch4 tfs on 
                                    ! first time step of job ?
logical            ::  &
        use_current_ch4_for_tf = .false. 
                                    ! use current ch4 mixing ratio for  
                                    ! calculating tfs ?
real               ::  &
        ch4_tf_time_displacement = 0.0 
                                    ! time displacement from job start 
                                    ! to the point in time where ch4 
                                    ! tfs are to be valid -- may be (-),
                                    ! 0.0 or (+); used only when
                                    ! calc_ch4_tfs_on_first_step is true
                                    ! [ hours ]
real               ::  &
        n2o_tf_calc_intrvl = 1.0E6  ! interval between recalculating n2o
                                    ! transmission functions, relevant
                                    ! for time-varying n2o cases 
                                    ! [ hours ]
logical            ::  &
        calc_n2o_tfs_on_first_step = .true. 
                                    ! always calculate n2o tfs on 
                                    ! first time step of job ?
logical            ::  &
        use_current_n2o_for_tf = .false. 
                                    ! use current n2o mixing ratio for  
                                    ! calculating tfs ?
real               ::  &
        n2o_tf_time_displacement = 0.0 
                                    ! time displacement from job start 
                                    ! to the point in time where n2o 
                                    ! tfs are to be valid -- may be (-),
                                    ! 0.0 or (+); used only when
                                    ! calc_n2o_tfs_on_first_step is true
                                    ! [ hours ]
integer            ::  &
        verbose = 0                 ! verbosity level, ranges from 0
                                    ! (min output) to 5 (max output)
logical            ::  &
       calc_co2_tfs_monthly = .false.
logical            ::  &
       calc_ch4_tfs_monthly = .false.
logical            ::  &
       calc_n2o_tfs_monthly = .false.
integer            ::      &
       no_h2o_bands_1200_1400 = 1 ! number of bands in the lw par-
                                  ! ameterization between 1200 and 1400
                                  ! cm (-1); 0 and 1 have been
                                  ! tested. other potentially available
                                  ! values are 2, 4, 10  and 20. 
logical            ::      &
    use_bnd1_cldtf_for_h2o_bands = .false. ! the 1200-1400 cm(-1) band
                                             ! uses the same radiative
                                             ! properties as the 0-160,
                                             ! 1400-2200 band. needed 
                                             ! for backward compatibil-
                                             ! ity


namelist / sealw99_nml /                          &
                          do_thick, do_lwcldemiss, &
!                         do_nlte, do_ch4n2olbltmpint, &
                          do_nlte, do_ch4lbltmpint, do_n2olbltmpint, &
                          continuum_form, linecatalog_form, &
                          verbose, &
                          no_h2o_bands_1200_1400, &
                          use_bnd1_cldtf_for_h2o_bands, &
                          calc_co2_tfs_monthly, &
                          calc_ch4_tfs_monthly, &
                          calc_n2o_tfs_monthly, &
                          calc_co2_tfs_on_first_step, &
                          use_current_co2_for_tf, &
                          co2_tf_calc_intrvl, &
                          co2_tf_time_displacement, &
                          calc_ch4_tfs_on_first_step, &
                          use_current_ch4_for_tf, &
                          ch4_tf_calc_intrvl, &
                          ch4_tf_time_displacement, &
                          calc_n2o_tfs_on_first_step, &
                          use_current_n2o_for_tf, &
                          n2o_tf_calc_intrvl, &
                          n2o_tf_time_displacement

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------

!---------------------------------------------------------------------
!     apcm, bpcm    capphi coefficients for NBLY bands.
!     atpcm, btpcm  cappsi coefficients for NBLY bands.
!     acomb         random "a" parameter for NBLY bands.
!     bcomb         random "b" parameter for NBLY bands.
!---------------------------------------------------------------------
real, dimension (:), allocatable    ::  apcm, bpcm, atpcm, btpcm,&
                                        acomb, bcomb

!-------------------------------------------------------------------
!    the following longwave tables are retained for the life of the
!    run.
!-------------------------------------------------------------------
type (longwave_tables3_type), save       :: tabsr
type (longwave_tables1_type), save       :: tab1, tab2, tab3, tab1w
type (longwave_tables2_type), save       :: tab1a, tab2a, tab3a


!-------------------------------------------------------------------
!
!--------------------------------------------------------------------
integer, parameter                  ::  no_combined_bands = 8
real, dimension(no_combined_bands)  ::  band_no_start, band_no_end
integer, dimension(NBLY_CKD-1)      ::  cld_indx_table

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
real, dimension (:),    allocatable    ::  c1b7, c2b7
integer, dimension (:), allocatable    ::  cld_indx

!---------------------------------------------------------------------
!    miscellaneous variables.
!---------------------------------------------------------------------
integer    ::  nbly      ! number of frequency bands for exact
                         ! cool-to-space computations.
integer    ::  nbtrge, nbtrg
integer    ::  ixprnlte
integer    ::  ks, ke
logical    ::  do_co2_tf_calc = .true.
logical    ::  do_ch4_tf_calc = .true.
logical    ::  do_n2o_tf_calc = .true.
logical    ::  do_co2_tf_calc_init = .true.
logical    ::  do_ch4_tf_calc_init = .true.
logical    ::  do_n2o_tf_calc_init = .true.

integer    ::  month_of_co2_tf_calc = 0
integer    ::  month_of_ch4_tf_calc = 0
integer    ::  month_of_n2o_tf_calc = 0

!----------------------------------------------------------------------
!----------------------------------------------------------------------



                          contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="sealw99_init">
!  <OVERVIEW>
!   Subroutine to initialize longwave radiation
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine initializes longwave radiation. It includes the
!   prescribed gas band coefficients, initializes gas optical depth, 
!   longwave tables, and allocate cloud related variables in the
!   longwave spectrum.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sealw99_init (latb, lonb, pref, Lw_tables)
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes at cell corners [radians]
!  </IN>
!  <IN NAME="pref" TYPE="real">
!   array containing two reference pressure profiles [pascals]
!  </IN>
!  <INOUT NAME="Lw_tables" TYPE="lw_table_type">
!   lw_tables_type variable containing various longwave
!                 table specifiers needed by radiation_diag_mod.
!  </INOUT>
! </SUBROUTINE>
!
subroutine sealw99_init (latb, lonb, pref, Lw_tables)
 
!---------------------------------------------------------------------
!    sealw99_init is the constructor for sealw99_mod.
!---------------------------------------------------------------------

real, dimension(:,:), intent(in) :: latb, lonb
real, dimension(:,:), intent(in) :: pref
type(lw_table_type), intent(inout) :: Lw_tables

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       lonb           2d array of model longitudes on cell corners
!                      [ radians ]
!       latb           2d array of model latitudes at cell corners
!                      [ radians ]
!       pref           array containing two reference pressure profiles 
!                      for use in defining transmission functions
!                      [ Pa ]
!
!   intent(inout)    
!
!       Lw_tables      lw_table_type variable which holds much of the
!                      relevant data used in the longwave radiation
!                      parameterization
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

       real, dimension (no_combined_bands)  :: band_no_start_rsb,   &
                                           band_no_start_ckd, &
                                             band_no_end_rsb,    &
                                           band_no_end_ckd

       data band_no_start_ckd / 1, 25, 41, 42, 43, 44, 46, 47 /
       data band_no_end_ckd   / 24,40, 41, 42, 43, 45, 46, 47 /

       data band_no_start_rsb / 1, 5, 9, 10, 11, 12, 14, 15 /
       data band_no_end_rsb   / 4, 8, 9, 10, 11, 13, 14, 15 /

       real, dimension (NBLY_CKD-1) :: cld_indx_table_lwclde, &
                                      cld_indx_table_rsb

       data cld_indx_table_lwclde /40*1, 2, 2, 2, 3, 4, 5, 6 /

       data cld_indx_table_rsb   / 47*1 /

       real, dimension(NBLY_RSB)   :: apcm_n, bpcm_n,     &
                                       atpcm_n, btpcm_n,   &
                                       acomb_n, bcomb_n
       real, dimension(NBLY_CKD) :: apcm_c, bpcm_c, atpcm_c,  &
                                       btpcm_c, acomb_c, bcomb_c 
       real, dimension(size(pref,1) ) :: plm
       real, dimension (NBCO215) :: cent, del

       integer         :: unit, ierr, io, k, n,  nn, logunit
       integer         :: ioffset
       real            :: prnlte
       integer         ::     kmax, kmin
       integer         :: inrad
       real            :: dum
       character(len=4)  :: gas_name

!---------------------------------------------------------------------
!  local variables:
!
!     band_no_start_rsb
!     band_no_start_ckd
!     band_no_end_rsb
!     band_no_end_ckd
!     cld_indx_table_lwclde
!     cld_indx_table_rsb
!     apcm_n 
!     bpcm_n
!     atpcm_n 
!     btpcm_n
!     acomb_n 
!     bcomb_n
!     apcm_c 
!     bpcm_c 
!     atpcm_c 
!     btpcm_c 
!     acomb_c 
!     bcomb_c 
!     plm
!     cent 
!     del
!     unit 
!     ierr 
!     io 
!     k,n,m,nn
!     ioffset
!     prnlte
!     kmax 
!     kmin
!     inrad
!     dum
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return
 
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call constants_init
      call rad_utilities_init

!-----------------------------------------------------------------------
!    read namelist.
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=sealw99_nml, iostat=io)
      ierr = check_nml_error(io,"sealw99_nml")
#else
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=sealw99_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'sealw99_nml')
        end do
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=sealw99_nml)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      kmax = size(pref,1) - 1   ! radiation grid size
      ks = 1
      ke = kmax

!---------------------------------------------------------------------
!    be sure that the radiation time step has been defined before using
!    it.
!---------------------------------------------------------------------
      if (Rad_control%lw_rad_time_step_iz ) then  
      else
        call error_mesg ('sealw99_mod', &
               'must define lw_rad_time_step before using it', FATAL)
      endif

!---------------------------------------------------------------------
!    call check_tf_interval to verify that the namelist input variables
!    related to co2 are consistent.
!---------------------------------------------------------------------
      gas_name = 'co2 '
      call check_tf_interval (gas_name, co2_tf_calc_intrvl, &
                              calc_co2_tfs_on_first_step,   &
                              calc_co2_tfs_monthly, &
                              use_current_co2_for_tf)

!--------------------------------------------------------------------
!    define the radiation_control_type variable components related to
!    co2 tf calculation.
!--------------------------------------------------------------------
      Rad_control%co2_tf_calc_intrvl = co2_tf_calc_intrvl
      Rad_control%use_current_co2_for_tf = use_current_co2_for_tf
      Rad_control%calc_co2_tfs_monthly       =   &
                                             calc_co2_tfs_monthly      
      Rad_control%calc_co2_tfs_on_first_step =   &
                                             calc_co2_tfs_on_first_step
      Rad_control%co2_tf_time_displacement = co2_tf_time_displacement
      Rad_control%co2_tf_calc_intrvl_iz = .true.             
      Rad_control%use_current_co2_for_tf_iz = .true.
      Rad_control%calc_co2_tfs_on_first_step_iz = .true.
      Rad_control%calc_co2_tfs_monthly_iz    =  .true.
      Rad_control%co2_tf_time_displacement_iz = .true.

!---------------------------------------------------------------------
!    call check_tf_interval to verify that the namelist input variables
!    related to ch4 are consistent.
!---------------------------------------------------------------------
      gas_name = 'ch4 '
      call check_tf_interval (gas_name, ch4_tf_calc_intrvl, &
                              calc_ch4_tfs_on_first_step,   &
                              calc_ch4_tfs_monthly, &
                              use_current_ch4_for_tf)

!--------------------------------------------------------------------
!    define the radiation_control_type variable components related to
!    ch4 tf calculation.
!--------------------------------------------------------------------
      Rad_control%ch4_tf_calc_intrvl = ch4_tf_calc_intrvl
      Rad_control%use_current_ch4_for_tf = use_current_ch4_for_tf
      Rad_control%calc_ch4_tfs_on_first_step =   &
                                             calc_ch4_tfs_on_first_step
      Rad_control%calc_ch4_tfs_monthly       =   &
                                             calc_ch4_tfs_monthly      
      Rad_control%ch4_tf_time_displacement = ch4_tf_time_displacement
      Rad_control%ch4_tf_calc_intrvl_iz = .true.             
      Rad_control%use_current_ch4_for_tf_iz = .true.
      Rad_control%calc_ch4_tfs_on_first_step_iz = .true.
      Rad_control%calc_ch4_tfs_monthly_iz    =  .true.
      Rad_control%ch4_tf_time_displacement_iz = .true.

!---------------------------------------------------------------------
!    call check_tf_interval to verify that the namelist input variables
!    related to n2o are consistent.
!---------------------------------------------------------------------
      gas_name = 'n2o '
      call check_tf_interval (gas_name, n2o_tf_calc_intrvl, &
                              calc_n2o_tfs_on_first_step,   &
                              calc_n2o_tfs_monthly, &
                              use_current_n2o_for_tf)

!--------------------------------------------------------------------
!    define the radiation_control_type variable components related to
!    n2o tf calculation.
!--------------------------------------------------------------------
      Rad_control%n2o_tf_calc_intrvl = n2o_tf_calc_intrvl
      Rad_control%use_current_n2o_for_tf = use_current_n2o_for_tf
      Rad_control%calc_n2o_tfs_on_first_step =   &
                                           calc_n2o_tfs_on_first_step
      Rad_control%calc_n2o_tfs_monthly       =   &
                                             calc_n2o_tfs_monthly      
      Rad_control%n2o_tf_time_displacement = n2o_tf_time_displacement
      Rad_control%n2o_tf_calc_intrvl_iz = .true.             
      Rad_control%use_current_n2o_for_tf_iz = .true.
      Rad_control%calc_n2o_tfs_on_first_step_iz = .true.
      Rad_control%calc_n2o_tfs_monthly_iz    =  .true.
      Rad_control%n2o_tf_time_displacement_iz = .true.

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
    call longwave_params_init

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(continuum_form) == 'ckd2.1'      .or.   &
          trim(continuum_form) == 'ckd2.4'      .or.   &
          trim(continuum_form) == 'mt_ckd1.0'   .or.   &
          trim(continuum_form) == 'rsb'         .or.   &
          trim(continuum_form) == 'none'        )      then
      else
        call error_mesg ( 'sealw99_mod', &
           'continuum_form is not specified correctly', FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(linecatalog_form) == 'hitran_1992'  .or.  &
          trim(linecatalog_form) == 'hitran_2000' )  then
      else
        call error_mesg ( 'sealw99_mod', &
           'linecatalog_form is not specified correctly', FATAL)
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
    Lw_control%continuum_form     = continuum_form
    Lw_control%linecatalog_form   = linecatalog_form
    Lw_control%do_ch4lbltmpint = do_ch4lbltmpint
    Lw_control%do_n2olbltmpint = do_n2olbltmpint
    Lw_control%do_ch4lbltmpint_iz  = .true.
    Lw_control%do_n2olbltmpint_iz  = .true.

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then
      Lw_parameters%offset = 32
      NBLY = NBLY_CKD
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then
     Lw_parameters%offset = 0
      NBLY = NBLY_RSB  
   endif
   Lw_parameters%offset_iz = .true.

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(Lw_control%linecatalog_form) == 'hitran_1992' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_ckd_speccombwidebds_hi92')
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum     ! ckd capphi coeff for 560-800 band
          read (inrad,9000) dum     ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) dum     ! ckd capphi coeff for 560-800 band
          read (inrad,9000) dum     ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) dum     ! lo freq of 560-800 band
          read (inrad,9000) dum     ! hi freq of 560-800 band
!  ckd rndm coeff for 40 bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bcomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (apcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (atpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (btpcm_c(k),k=1,NBLY_CKD)
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_rsb_speccombwidebds_hi92')
          read (inrad,9000) dum     
          read (inrad,9000) dum    
          read (inrad,9000) dum    ! rsb capphi coeff for 560-800 band
          read (inrad,9000) dum    ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) dum    ! rsb capphi coeff for 560-800 band
          read (inrad,9000) dum    ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) dum    ! lo freq of 560-800 band
          read (inrad,9000) dum    ! hi freq of 560-800 band
          read (inrad,9000) dum   
!  rsb rndm coeff for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bcomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (apcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (atpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (btpcm_n(k),k=1,NBLY_RSB)
        endif
      else if (trim(Lw_control%linecatalog_form) == 'hitran_2000' ) then
        if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
            trim(Lw_control%continuum_form) == 'ckd2.4' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_ckd_speccombwidebds_hi00')
          read (inrad,9000) dum
          read (inrad,9000) dum
          read (inrad,9000) dum    ! ckd capphi coeff for 560-800 band
          read (inrad,9000) dum    ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) dum    ! ckd capphi coeff for 560-800 band
          read (inrad,9000) dum    ! ckd cappsi coeff for 560-800 band
          read (inrad,9000) dum    ! lo freq of 560-800 band
          read (inrad,9000) dum    ! hi freq of 560-800 band
!  ckd rndm coeff for 40 bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bcomb_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (apcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (bpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (atpcm_c(k),k=1,NBLY_CKD)
          read (inrad,9000) (btpcm_c(k),k=1,NBLY_CKD)
        else if (trim(Lw_control%continuum_form) == 'rsb' ) then
          inrad = open_namelist_file ('INPUT/h2ocoeff_rsb_speccombwidebds_hi00')
          read (inrad,9000) dum     
          read (inrad,9000) dum    
          read (inrad,9000) dum    ! rsb capphi coeff for 560-800 band
          read (inrad,9000) dum   ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) dum    ! rsb capphi coeff for 560-800 band
          read (inrad,9000) dum    ! rsb cappsi coeff for 560-800 band
          read (inrad,9000) dum    ! lo freq of 560-800 band
          read (inrad,9000) dum    ! hi freq of 560-800 band
          read (inrad,9000) dum   
!  rsb rndm coeff for 8 comb bands (160-560) and 8 wide bands (560-1400)
          read (inrad,9000) (acomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bcomb_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (apcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (bpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (atpcm_n(k),k=1,NBLY_RSB)
          read (inrad,9000) (btpcm_n(k),k=1,NBLY_RSB)
        endif
      endif
9000  format (5e14.6)
      call close_file (inrad)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the number of separate bands in the 1200 - 1400 cm-1
!    region. this region may be broken into 1, 2 , 4, 10 or 20 individ-
!    ual bands, or it may remain part of the 0-160, 1200-2200 band. 
!---------------------------------------------------------------------
      nbtrge = no_h2o_bands_1200_1400 
      nbtrg  = no_h2o_bands_1200_1400 
      Lw_parameters%NBTRG  = nbtrg
      Lw_parameters%NBTRGE = nbtrge

!---------------------------------------------------------------------
!    set flag indicating these values have been initialized.
!---------------------------------------------------------------------
      Lw_parameters%NBTRG_iz = .true.
      Lw_parameters%NBTRGE_iz = .true.

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      call lw_gases_stdtf_init   (pref)
      call optical_path_init (pref)
      call longwave_tables_init (Lw_tables, tabsr, &
                                 tab1, tab2, tab3, tab1w, &
                                 tab1a, tab2a, tab3a)
      if (Lw_control%do_co2_iz) then
        if (do_nlte .and. .not. Lw_control%do_co2) then
          call error_mesg ('sealw99_mod', &
         ' cannot activate nlte when co2 not active as radiative gas',&
                                                          FATAL)
        endif 
      else  ! (do_co2_iz)
        call error_mesg ('sealw99_mod', &
           'do_co2 not yet defined', FATAL)
      endif ! (do_co2_iz)

!---------------------------------------------------------------------
!    define pressure-dependent index values used in the infrared
!    radiation code. by this manner, the coefficients are defined
!    at execution time (not dependent on the choice of vertical
!    layers)
!      prnlte : pressure (mb) below which non-LTE code (Nlte.F) affects
!               CO2 transmissivities
!---------------------------------------------------------------------
      if (do_nlte) then
        prnlte = 0.1

!--------------------------------------------------------------------
!    abort execution if trying to run with modified radiation grid
!    code must be added to properly map plm (on the model grid)
!    to the radiation grid. if simply dropping upper levels, then is
!    fairly easy.  abort here so that problem may be addressed and to
!    prevent uncertified results.
!    solution is likely to be to pass in plm on radiation grid, whatever
!    that is.
!--------------------------------------------------------------------
        kmin = 1
        plm (kmin) = 0.
        do k=kmin+1,kmax
          plm (k) = 0.5*(pref (k-1,1) + pref (k,1))
        end do
        plm (kmax+1) = pref (kmax+1,1)

!--------------------------------------------------------------------
!    convert pressure specification for bottom (flux) pressure level
!    for nlte calculation into an index (ixprnlte)
!!! CAN THE MODEL TOP BE AT A PRESSURE THAT IS NOT ZERO ??
!!! if not, then must define plm(ks) always to be 0.0
!!! implications for lw_gas tf calcs ??
!      kmax = size(plm,1) - 1
!-------------------------------------------------------------------
        ixprnlte = 1 
        do k=ks+1, kmax
          if (plm(k)*1.0E-02  .LT. prnlte) then
            ixprnlte = k-ks+1 
          else
            exit
          endif
        end do

!---------------------------------------------------------------------
!   allocate and obtain elements of the source function for bands in 
!   the 15 um range (used in nlte)
!---------------------------------------------------------------------
        ioffset = Lw_parameters%offset
        allocate ( c1b7    (NBCO215) )
        allocate ( c2b7    (NBCO215) )
        do n=1,NBCO215 
          cent(n) = 0.5E+00*(Lw_tables%bdlocm(n+8+ioffset) +   &
                             Lw_tables%bdhicm(n+8+ioffset))
          del (n) = Lw_tables%bdhicm(n+8+ioffset) -    &
                    Lw_tables%bdlocm(n+8+ioffset)
          c1b7(n) = (3.7412E-05)*cent(n)*cent(n)*cent(n)*del(n) 
          c2b7(n) = (1.4387E+00)*cent(n)
        end do
      endif

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      call gas_tf_init (pref)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      call longwave_clouds_init

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        band_no_start = band_no_start_ckd
        band_no_end   = band_no_end_ckd
        NBLY = NBLY_CKD
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        band_no_start = band_no_start_rsb  
        band_no_end   = band_no_end_rsb  
        NBLY = NBLY_RSB 
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      Lw_parameters%NBLY = NBLY
      Lw_parameters%NBLY_iz = .true.
      Lw_control%do_lwcldemiss = do_lwcldemiss
      Lw_control%do_lwcldemiss_iz = .true.

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (do_lwcldemiss) then
        cld_indx_table = cld_indx_table_lwclde
        Cldrad_control%nlwcldb = 7
      else
        cld_indx_table = cld_indx_table_rsb
        Cldrad_control%nlwcldb = 1
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      allocate (apcm(NBLY))
      allocate (bpcm(NBLY))
      allocate (atpcm(NBLY))
      allocate (btpcm(NBLY))
      allocate (acomb(NBLY))
      allocate (bcomb(NBLY))

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
          trim(Lw_control%continuum_form) == 'ckd2.4' ) then
        apcm = apcm_c
        atpcm = atpcm_c
        bpcm = bpcm_c
        btpcm = btpcm_c
        acomb = acomb_c
        bcomb = bcomb_c
      else if (trim(Lw_control%continuum_form) == 'rsb' ) then
        apcm = apcm_n
        atpcm = atpcm_n
        bpcm = bpcm_n
        btpcm = btpcm_n
        acomb = acomb_n
        bcomb = bcomb_n
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      allocate (cld_indx(6+NBTRGE) )
      do nn=1,6+NBTRGE
        if (nn > Cldrad_control%nlwcldb) then
          cld_indx(nn) = Cldrad_control%nlwcldb
        else
          cld_indx(nn) = nn
        endif
      end do
      if (NBTRGE == 0 .and. .not. use_bnd1_cldtf_for_h2o_bands) then
        call error_mesg ('sealw99_mod', &
        'must use band1 cld tfs for the 1200-1400 cm(-1) bands when &
          & they are included in the 1200-2200 cm(-1) band', FATAL)
      endif 

      if (NBTRGE  > 0 .and. use_bnd1_cldtf_for_h2o_bands) then
        cld_indx(7:) = 1
      endif

!--------------------------------------------------------------------
!
!---------------------------------------------------------------------
      call longwave_fluxes_init

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
     module_is_initialized = .true.

!---------------------------------------------------------------------


end subroutine sealw99_init


!####################################################################

subroutine sealw99_time_vary (Rad_time, Rad_gases)

type(time_type), intent(in) :: Rad_time
type(radiative_gases_type),    intent(inout)    ::  Rad_gases   

         logical                    :: calc_co2, calc_n2o, calc_ch4

         character(len=4)           :: gas_name
      integer                    :: year, month, day, hour, minute, &
                                    second
!---------------------------------------------------------------------------

      call get_control_gas_tf (calc_co2, calc_ch4, calc_n2o)

!----------------------------------------------------------------------
!
!--------------------------------------------------------------------
      call lw_gases_stdtf_time_vary

!----------------------------------------------------------------------
!
!--------------------------------------------------------------------
      if (Rad_gases%time_varying_ch4 .or.    &
          Rad_gases%time_varying_n2o) then
        if (Rad_gases%time_varying_ch4 .and. .not. calc_ch4) then
          call error_mesg ('sealw99_mod', &
          ' if ch4 amount is to vary in time, ch4 tfs must be '//&
                                          'recalculated', FATAL)
        endif
        if (Rad_gases%time_varying_n2o        .and. .not. calc_n2o) then
          call error_mesg ('sealw99_mod', &
          ' if n2o amount is to vary in time, n2o tfs must be '//&
                                             'recalculated', FATAL)
        endif

      endif

!----------------------------------------------------------------------
!
!--------------------------------------------------------------------
      if (Rad_gases%time_varying_co2) then 
        if (.not. calc_co2) then
          call error_mesg ('sealw99_mod', &
          ' if co2 amount is to vary in time, co2 tfs must be '//&
                                            'recalculated', FATAL)
        endif
      endif

!----------------------------------------------------------------------
!    if ch4 is activated in this job, varying in time, and 
!    calculation of ch4 tfs are requested, call obtain_gas_tfs to
!    define the tfs.
!--------------------------------------------------------------------
      if (Rad_gases%time_varying_ch4) then
        if (Lw_control%do_ch4) then
          if (do_ch4_tf_calc) then
            gas_name = 'ch4 '
            call obtain_gas_tfs (gas_name, Rad_time,   &
                                 Rad_gases%Ch4_time,  &
                                 ch4_tf_calc_intrvl,&
                                 Rad_gases%ch4_tf_offset,  &
                                 calc_ch4_tfs_on_first_step, &
                                 calc_ch4_tfs_monthly, &
                                 month_of_ch4_tf_calc, &
                                 Rad_gases%ch4_for_next_tf_calc,  &
                                 Rad_gases%ch4_for_last_tf_calc, &
                                 do_ch4_tf_calc, do_ch4_tf_calc_init)
          endif  ! (do_ch4_tf_calc)

        endif ! (do_ch4)

!---------------------------------------------------------------------
!    if ch4 is not time-varying and it is the initial call to sealw99,
!    call ch4_time_vary to calculate the tfs. set flags to indicate
!    the calculation has been done.
!---------------------------------------------------------------------
      else ! (time_varying_ch4)
        if (Lw_control%do_ch4 .and. do_ch4_tf_calc ) then
          call ch4_time_vary (Rad_gases%rrvch4)
          do_ch4_tf_calc = .false.
          do_ch4_tf_calc_init = .false.
        else if (.not. Lw_control%do_ch4) then
          do_ch4_tf_calc = .false.
          do_ch4_tf_calc_init = .false.
        endif
      endif  ! (time_varying_ch4)

!----------------------------------------------------------------------
!    if n2o is activated in this job, varying in time, and 
!    calculation of n2o tfs are requested, call obtain_gas_tfs to
!    define the tfs.
!--------------------------------------------------------------------
      if (Rad_gases%time_varying_n2o) then
        if (Lw_control%do_n2o) then
          if (do_n2o_tf_calc) then
            gas_name = 'n2o '
            call obtain_gas_tfs (gas_name, Rad_time,   &
                                 Rad_gases%N2o_time,  &
                                 n2o_tf_calc_intrvl,&
                                 Rad_gases%n2o_tf_offset,  &
                                 calc_n2o_tfs_on_first_step, &
                                 calc_n2o_tfs_monthly, &
                                 month_of_n2o_tf_calc, &
                                 Rad_gases%n2o_for_next_tf_calc,  &
                                 Rad_gases%n2o_for_last_tf_calc, &
                                 do_n2o_tf_calc, do_n2o_tf_calc_init)
          endif  ! (do_n2o_tf_calc)
        endif ! (do_n2o)

!---------------------------------------------------------------------
!    if n2o is not time-varying and it is the initial call to sealw99,
!    call n2o_time_vary to calculate the tfs. set flags to indicate
!    the calculation has been done.
!---------------------------------------------------------------------
      else
        if (Lw_control%do_n2o .and. do_n2o_tf_calc) then
          call n2o_time_vary (Rad_gases%rrvn2o)
          do_n2o_tf_calc = .false.
          do_n2o_tf_calc_init = .false.
        else if (.not. Lw_control%do_n2o) then
          do_n2o_tf_calc = .false.
          do_n2o_tf_calc_init = .false.
        endif
      endif  ! (time_varying_n2o)


!----------------------------------------------------------------------
!    if co2 is activated in this job, varying in time, and 
!    calculation of co2 tfs are requested, call obtain_gas_tfs to
!    define the tfs.
!--------------------------------------------------------------------
      if (Rad_gases%time_varying_co2) then
        if (Lw_control%do_co2) then
          if (do_co2_tf_calc) then
            gas_name = 'co2 '
            call obtain_gas_tfs (gas_name, Rad_time,  &
                                 Rad_gases%Co2_time,  &
                                 co2_tf_calc_intrvl,&
                                 Rad_gases%co2_tf_offset,  &
                                 calc_co2_tfs_on_first_step, &
                                 calc_co2_tfs_monthly, &
                                 month_of_co2_tf_calc, &
                                 Rad_gases%co2_for_next_tf_calc,  &
                                 Rad_gases%co2_for_last_tf_calc, &
                                 do_co2_tf_calc, do_co2_tf_calc_init)
          endif  ! (do_co2_tf_calc)
        endif ! (do_co2)

!---------------------------------------------------------------------
!    if co2 is not time-varying and it is the initial call to sealw99,
!    call co2_time_vary to calculate the tfs. set flags to indicate
!    the calculation has been done.
!---------------------------------------------------------------------
      else
! interactive co2 mod for radiation calculation
! here it's hardcoded to recompute co2 TF on the 1st of each month
         if (Rad_gases%use_model_supplied_co2) then
            call get_date (Rad_time, year, month, day, hour, minute,&
                 second)
            if (day == 1 .and. hour == 0 .and. minute == 0 .and. &
                 second == 0) then
               call co2_time_vary (Rad_gases%rrvco2)
               Rad_gases%co2_for_last_tf_calc = Rad_gases%rrvco2
               do_co2_tf_calc_init = .false.
            else
               if (do_co2_tf_calc_init) then
                  call co2_time_vary (Rad_gases%co2_for_last_tf_calc)
                  do_co2_tf_calc_init = .false.
               endif
            endif
         else  !(Rad_gases%use_model_supplied_co2)
            if (Lw_control%do_co2 .and. do_co2_tf_calc) then
               call co2_time_vary (Rad_gases%rrvco2)
               do_co2_tf_calc = .false.
               do_co2_tf_calc_init = .false.
            else if (.not. Lw_control%do_co2) then
               do_co2_tf_calc = .false.
               do_co2_tf_calc_init = .false.
            endif
         endif  !(Rad_gases%use_model_supplied_co2)
      endif  ! (time_varying_co2)

!----------------------------------------------------------------------
!
!--------------------------------------------------------------------
      if ((Lw_control%do_co2 .and. calc_co2) .or. &
          (Lw_control%do_ch4 .and. calc_ch4) .or. &
          (Lw_control%do_n2o .and. calc_n2o)) then
        call lw_gases_stdtf_dealloc
      endif
 
!------------------------------------------------------------------------


end subroutine sealw99_time_vary


!#####################################################################
 
subroutine sealw99_endts (Rad_gases_tv)

type(radiative_gases_type), intent(in) :: Rad_gases_tv

       if (Rad_gases_tv%time_varying_ch4) then
         if (Lw_control%do_ch4) then
           if (.not. calc_ch4_tfs_on_first_step) then
             do_ch4_tf_calc = .true.
           endif
          endif
        endif

       if (Rad_gases_tv%time_varying_n2o) then
         if (Lw_control%do_n2o) then
          if (.not. calc_n2o_tfs_on_first_step) then
            do_n2o_tf_calc = .true.
         endif
        endif
      endif

     if (Rad_gases_tv%time_varying_co2) then
       if (Lw_control%do_co2) then
         if (.not. calc_co2_tfs_on_first_step) then
           do_co2_tf_calc = .true.
         endif
       endif
      endif

end subroutine sealw99_endts



!#####################################################################
!#####################################################################
! <SUBROUTINE NAME="sealw99">
!  <OVERVIEW>
!   Subroutine to calculate longwave radiation flux and heating rate.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine calculates longwave radiation flux and heating rate
!   based on the simplified exchange method. It also provides diagnostics
!   for the longwave radiation and cloud.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sealw99 (is, ie, js, je, Atmos_input, Rad_gases, &
!                 Aerosol, Aerosol_props, Cldrad_props, Cld_spec, &
!                Lw_output, Lw_diagnostics)
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!   starting subdomain i indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   ending subdomain i indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   starting subdomain j indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   ending subdomain j indice of data in the physics_window being
!       integrated
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   atmos_input_type variable containing the atmospheric
!                   input fields needed by the radiation package
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   radiative_gases_type variable containing the radi-
!                   ative gas input fields needed by the radiation 
!                   package
!  </IN>
!  <IN NAME="Aerosol" TYPE="aerosol_type">
!   Aerosol climatological input data to longwave radiation
!  </IN>
!  <INOUT NAME="Aerosol_props" TYPE="aerosol_properties_type">
!   Aerosol radiative properties
!  </INOUT>
!  <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!   cldrad_properties_type variable containing the 
!                   cloud radiative property input fields needed by the 
!                   radiation package
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_TYPE">
!   Cloud specification type contains cloud microphysical, geometrical,
!   and distribution properties in a model column.
!  </IN>
!  <INOUT NAME="Lw_output" TYPE="lw_output_type">
!   lw_output_type variable containing longwave 
!                   radiation output data
!  </INOUT>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!  </INOUT>
! </SUBROUTINE>
!
subroutine sealw99 (is, ie, js, je, Rad_time, Atmos_input, Rad_gases, &
                    Aerosol, Aerosol_props, Cldrad_props, Cld_spec, &
                    Aerosol_diags, Lw_output, Lw_diagnostics, &
                    including_aerosols)

!---------------------------------------------------------------------
!    sealw99 is the longwave driver subroutine.
!
!     references:
!
!     (1) schwarzkopf, m. d., and s. b. fels, "the simplified
!         exchange method revisited: an accurate, rapid method for
!         computation of infrared cooling rates and fluxes," journal
!         of geophysical research, 96 (1991), 9075-9096.
!
!     (2) schwarzkopf, m. d., and s. b. fels, "improvements to the
!         algorithm for computing co2 transmissivities and cooling
!         rates," journal geophysical research, 90 (1985) 10541-10550.
!
!     (3) fels, s.b., "simple strategies for inclusion of voigt
!         effects in infrared cooling calculations," application
!         optics, 18 (1979), 2634-2637.
!
!     (4) fels, s. b., and m. d. schwarzkopf, "the simplified exchange
!         approximation: a new method for radiative transfer
!         calculations," journal atmospheric science, 32 (1975),
!         1475-1488.
!
!     author: m. d. schwarzkopf
!
!     revised: 10/7/93
!
!     certified:  radiation version 1.0
!---------------------------------------------------------------------

integer,                       intent(in)    ::  is, ie, js, je
type(time_type),               intent(in)    ::  Rad_time
type(atmos_input_type),        intent(in)    ::  Atmos_input  
type(radiative_gases_type),    intent(inout)    ::  Rad_gases   
type(aerosol_type),            intent(in)    ::  Aerosol      
type(aerosol_properties_type), intent(inout) ::  Aerosol_props      
type(aerosol_diagnostics_type), intent(inout) ::  Aerosol_diags      
type(cldrad_properties_type),  intent(in)    ::  Cldrad_props
type(cld_specification_type),  intent(in)    ::  Cld_spec
type(lw_output_type),          intent(inout) ::  Lw_output   
type(lw_diagnostics_type),     intent(inout) ::  Lw_diagnostics
logical,                   intent(in)            :: including_aerosols  

!-----------------------------------------------------------------------
!  intent(in) variables:
!
!    is,js,ie,je 
!    Atmos_input
!    Rad_gases
!    Aerosol
!    Cldrad_props
!    Cld_spec
!
!  intent(inout) variables:
!
!    Aerosol_props
!    Lw_output
!    Lw_diagnostics
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3),    &
                       Cldrad_control%nlwcldb) ::    &
           cldtf

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3)) ::    &
           cnttaub1, cnttaub2, cnttaub3, co21c, &
           co21r, heatem, overod, tmp1, to3cnt

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), 2)  ::    &
            emspec

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2))   ::  &
           co21c_KEp1, co21r_KEp1   

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3), 3) ::    &
           contdg

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3) -1) ::    &
           pdflux

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2))   ::  &
           flx1e1cf, gxctscf

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3)) ::    &
           e1ctw1, e1ctw2,        &
           emisdg, flxcf, &
           heatemcf, flx, to3dg, tcfc8
                       
      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3) - 1) ::    &
           cts_sum, cts_sumcf

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),    &
                       size(Atmos_input%press,3), NBTRGE) ::    &
           emisdgf, tch4n2oe

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3),   &
                                               8)::  &
           sorc

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3),   &
                                       6+NBTRGE     ) ::    &
           source_band, dsrcdp_band

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                       size(Atmos_input%press,3) ,  &
                                        6+NBTRGE     ) ::  &
           trans_band1, trans_band2

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), &
                                        6+NBTRGE     ) ::  &
           trans_b2d1, trans_b2d2

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2), 2, NBTRGE) ::    &
           emspecf

      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),  &     
                       size(Atmos_input%press,3)-1 )  :: &
            pdfinv, heatra_save
      real, dimension (size(Atmos_input%press,1),    &
                       size(Atmos_input%press,2),  &
                       size(Atmos_input%press,3) )  :: flxnet_save

      type(lw_clouds_type)       :: Lw_clouds
      type(optical_path_type)    :: Optical
      type(gas_tf_type)          :: Gas_tf   

      integer                    :: ix, jx, kx
      integer                    ::  k, kp, m, j
      integer                    :: kk, i, l
      integer                    :: nprofiles, nnn

!---------------------------------------------------------------------
!  local variables:
!
!     cldtf
!     cnttaub1
!     cnttaub2      
!     cnttaub3      
!     co21c       transmission function for the 560-800 cm-1 band 
!                 from levels k through KE+1 to level k. used for flux
!                 at level k arising from exchange with levels k 
!                 through KE+1. includes co2 (from tables), h2o (after
!                 multiplication with over).
!     co21diag    transmission function for co2 only in the 560-800
!                 cm-1 band, from levels k to k, where k ranges from
!                 KS to KE+1. 
!     co21r       transmission function for the 560-800 cm-1 band 
!                 from level k to levels k+1 through KE+1. used for 
!                 flux at levels k+1 through KE+1 arising from
!                 exchange with level k. includes co2 (from tables),
!                 h2o (after multiplication with over).
!     dsorc15
!     dsorc93
!     dsorcb1
!     dsorcb2
!     dsorcb3
!     dt4       
!     emiss
!     heatem
!     overod
!     sorc15      planck function for 560-800 cm-1 bands (sum over
!                 bands 9 and 10).
!     t4
!     tmp1        temporary array, used for computational purposes
!                 in various places. should have no consequences
!                 beyond the immediate module wherein it is defined.
!     tmp2        temporary arrays, similar to tmp1
!     to3cnt      transmission function for the 990-1070 cm-1 band
!                 including o3(9.6 um) + h2o continuum (no lines) 
!                 and possibly cfcs.
!     ch41c
!     n2o1c
!     n2o17c
!     emspec
!     s1a
!     flxge1
!     co21c_KEp1
!     co21r_KEp1
!     contdg
!     cfc_tf
!     pdflux
!     flx1e1cf
!     flxge1cf
!     gxctscf
!     emissb 
!     e1cts1
!     e1cts2
!     e1ctw1
!     e1ctw2
!     soe2
!     soe3
!     soe4
!     soe5
!     emisdg
!     flxcf
!     heatemcf
!     flx
!     to3dg
!     taero8
!     taero8kp
!     totaer_tmp
!     tcfc8
!     cts_sum
!     cts_sumcf
!     emissbf
!     e1cts1f
!     e1cts2f
!     emisdgf
!     emissf
!     tch4n2oe
!     flx1e1fcf
!     flxge1f
!     flxge1fcf
!     sorc        planck function, at model temperatures, for all
!                 bands;  used in cool-to-space calculations.
!     source_band
!     dsrcdp_band
!     trans_band1
!     trans_band2
!     trans_b2d1
!     trans_b2d2
!     emspecf
!     pdfinv
!     Lw_clouds
!     Optical
!     Gas_tf
!     calc_co2
!     calc_n2o
!     calc_ch4
!     ch4_vmr
!     n2o_vmr
!     co2_vmr
!     ix,jx,kx
!     n,k,kp,m,j
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'sealw99_mod',  &
             'module has not been initialized', FATAL )
      endif

!----------------------------------------------------------------------
!
!--------------------------------------------------------------------
      kx = size(Atmos_input%press,3) - 1
      ix = ie-is+1
      jx = je-js+1

!--------------------------------------------------------------------
!    call sealw99_alloc to allocate component arrays of 
!    lw_diagnostics_type variables.
!----------------------------------------------------------------------
      if ( .not. associated (Lw_diagnostics%flx1e1)) then
        call sealw99_alloc (ix, jx, kx, Lw_diagnostics)
      else
        Lw_diagnostics%flx1e1   = 0.
        Lw_diagnostics%cts_out    = 0.
        Lw_diagnostics%cts_outcf = 0.
        Lw_diagnostics%gxcts    = 0.
        Lw_diagnostics%excts  = 0.
        Lw_diagnostics%exctsn   = 0.
        Lw_diagnostics%fctsg   = 0.
        Lw_diagnostics%fluxn  = 0.
        if (Rad_control%do_totcld_forcing) then
          Lw_diagnostics%fluxncf = 0.
        endif
        Lw_diagnostics%flx1e1f  = 0.
      endif

!----------------------------------------------------------------------
!
!--------------------------------------------------------------------
       call optical_path_setup (is, ie, js, je, Atmos_input, Rad_gases, &
                               Aerosol, Aerosol_props, Aerosol_diags, &
                               Optical, including_aerosols)   
    
!--------------------------------------------------------------------
!    call co2coef to compute some co2 temperature and pressure   
!    interpolation quantities and to compute temperature-corrected co2
!    transmission functions (co2spnb and co2nbl). 
!-------------------------------------------------------------------
      call co2coef (Atmos_input, Gas_tf)

!----------------------------------------------------------------------
!    call co2_source_calc to calculate the source function.
!-----------------------------------------------------------------------
      call co2_source_calc (Atmos_input, Rad_gases, sorc, Gas_tf, &
                            source_band, dsrcdp_band)
      
      if (Cldrad_control%do_ica_calcs) then
        nprofiles = Cldrad_control%nlwcldb
        heatra_save = 0.
        flxnet_save = 0.0
      else
        nprofiles = 1
      endif
 
      do nnn = 1, nprofiles

!  reinitialize these values (done in sealw99_alloc)
       Lw_diagnostics%flx1e1   = 0.
       Lw_diagnostics%cts_out    = 0.
       Lw_diagnostics%cts_outcf = 0.
       Lw_diagnostics%gxcts    = 0.
       Lw_diagnostics%excts  = 0.
       Lw_diagnostics%exctsn   = 0.
       Lw_diagnostics%fctsg   = 0.

       Lw_diagnostics%fluxn  (:,:,:,:) = 0.0

       if (Rad_control%do_totcld_forcing) then
         Lw_diagnostics%fluxncf(:,:,:,:) = 0.0
       endif

       if (NBTRGE > 0) then
         Lw_diagnostics%flx1e1f  = 0.
       end if

!----------------------------------------------------------------------
!    call cldtau to compute cloud layer transmission functions for 
!    all layers.
!-------------------------------------------------------------------
      call cldtau (nnn, Cldrad_props, Cld_spec, Lw_clouds)


!---------------------------------------------------------------------
!    BEGIN LEVEL KS CALCULATIONS
!---------------------------------------------------------------------


!-----------------------------------------------------------------
!    compute co2 560-800 cm-1, ch4 and n2o 1200-1400 cm-1 trans-
!    mission functions and n2o 560-670 cm-1 transmission functions
!    appropriate for level KS. 
!---------------------------------------------------------------------
      call transcolrow (Gas_tf, KS, KS, KS, KE+1, KS+1, KE+1,   &
                        co21c, co21r, tch4n2oe)

!---------------------------------------------------------------------
!    go into optical_path_mod to obtain the optical path functions 
!    needed for use from level KS.
!    to3cnt contains values in the 990 - 1070 cm-1 range (ozone, water
!    vapor continuum, aerosol, cfc).
!    overod contains values in the 560 - 800 cm-1 range (water vapor 
!    lines, continuum, aerosol, 17 um n2o band, cfc).
!    cnttaub1 is continuum band 4 (water vapor continuum, aerosol, cfc)
!    cnttaub2 is continuum band 5 (water vapor continuum, aerosol, cfc)
!    cnttaub3 is continuum band 7 (water vapor continuum, aerosol, cfc)
!    the 15um band transmission functions between levels KS and KS+1
!    are stored in overod and co2nbl; they will not be overwritten,
!    as long as calculations are made for pressure levels increasing
!    from KS.
!---------------------------------------------------------------------
       call optical_trans_funct_from_KS (Gas_tf, to3cnt, overod,  &
                                        Optical, cnttaub1, cnttaub2, &
                                        cnttaub3, including_aerosols)   

!-----------------------------------------------------------------------
!    compute cloud transmission functions between level KS and all
!    other levels.
!-----------------------------------------------------------------------
      call cloud (KS, Cldrad_props, Cld_spec, Lw_clouds, cldtf)

!-----------------------------------------------------------------------
!    obtain exact cool-to-space for water and co2, and approximate 
!    cool-to-space for co2 and o3.
!----------------------------------------------------------------------
        call cool_to_space_exact (cldtf, Atmos_input, Optical, Gas_tf, &
                                 sorc, to3cnt, Lw_diagnostics, cts_sum, &
                                 cts_sumcf, gxctscf, including_aerosols)

!----------------------------------------------------------------------
!    compute the emissivity fluxes for k=KS.
!! trans_band1:
!    index 1 = e1flx
!    index 2 = co21r*overod
!    index 3 = cnttaub1
!    index 4 = cnttaub2
!    index 5 = to3cnt
!    index 6 = cnttaub3
!    index 7 = e1flxf
!! trans_band2:
!    index 1 = emiss
!    index 2 = co21c*overod
!    index 3 = cnttaub1
!    index 4 = cnttaub2
!    index 5 = to3cnt
!    index 6 = cnttaub3
!    index 7 = emissf
!----------------------------------------------------------------------
       call e1e290 (Atmos_input,  e1ctw1, e1ctw2, trans_band1,   &
                    trans_band2,  Optical, tch4n2oe, &
                    source_band(:,:,:,1), Lw_diagnostics, cldtf, &
                    cld_indx, flx1e1cf,  tcfc8, including_aerosols)  

     do kk = KS,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,2) = co21r   (i,j,kk)*  &
                                               overod(i,j,kk)
           end do
        end do
     end do
     do kk = KS,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,3) = cnttaub1(i,j,kk)
           end do
        end do
     end do
     do kk = KS,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,4) = cnttaub2(i,j,kk)
           end do
        end do
     end do
     do kk = KS,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,5) = to3cnt  (i,j,kk)
           end do
        end do
     end do
     do kk = KS,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,6) = cnttaub3(i,j,kk)
           end do
        end do
     end do

!! trans_band2:
!   index 1 = emiss
!   index 2 = co21c*overod
!   index 3 = cnttaub1
!   index 4 = cnttaub2
!   index 5 = to3cnt
!   index 6 = cnttaub3
!   index 7 = emissf


     do kk = KS+1,KE+1
        do j = 1,size(trans_band2(:,:,:,:),2)
           do i = 1,size(trans_band2(:,:,:,:),1)
              trans_band2(i,j,kk,2) = co21c(i,j,kk)*   &
                                       overod(i,j,kk)
           end do
        end do
     end do
     do l = 3,6
        do kk = KS+1,KE+1
           do j = 1,size(trans_band2(:,:,:,:),2)
              do i = 1,size(trans_band2(:,:,:,:),1)
                 trans_band2(i,j,kk,l) = trans_band1(i,j,kk,l)
              end do
           end do
        end do
     end do

!----------------------------------------------------------------------
!     the following is a rewrite of the original code largely to
!     eliminate three-dimensional arrays.  the code works on the
!     following principles.  let k be a fixed flux level and kp be
!     a varying flux level, then
! 
!     flux(k) = sum(deltab(kp)*tau(kp,k)) for kp=KS,KE+1.
!
!     if we assume a symmetrical array tau(k,kp)=tau(kp,k), we can
!     break down the calculations for k=KS,KE+1 as follows:
! 
!     flux(k) = sum(deltab(kp)*tau(kp,k)) for kp=k+1,KE+1            (1)
!
!     flux(kp) =   (deltab(k )*tau(kp,k)) for kp=k+1,KE+1.           (2)
!
!     plus deltab(k)*tau(k,k) for all k.
!
!     if we compute a one-dimensional array tauod(kp) for 
!     kp=k+1,KE+1, equations (1) and (2) become:
!
!     tauod(kp) = tau(kp,k)                                          (3)
!
!     flux (k ) = sum(deltab(kp)*tauod(kp)) for kp=k+1,KE+1          (4)
!
!     flux (kp) =    (deltab(k )*tauod(kp)) for kp=k+1,KE+1          (5)
!
!     where tau(k,k) and nearby layer terms are handled separately.
!
!     compute fluxes at level k = KS
!     compute the terms for flux at levels KS+1 to KE+1 from level KS.
!     compute terms for flux at level KS from level KS.
!     compute the terms for flux at level KS due to levels KP from KS+1 
!     to KE+1.
!
!-----------------------------------------------------------------------
    call longwave_fluxes_ks (source_band, trans_band1, dsrcdp_band,  &
                             trans_band2, cldtf, cld_indx , &
                                          Lw_diagnostics)  

 
     do kk = KS,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,1) = e1ctw2(i,j,kk)
           end do
        end do
     end do

!-----------------------------------------------------------------------
!     compute approximate cool-to-space heating rates for 1 wide band
!     in the 15um  range (560-800 cm-1) (ctsco2) and for 1 band in 
!     the 9.6 um band (ctso3).
!----------------------------------------------------------------------
    call cool_to_space_approx ( Atmos_input%pflux,  source_band, &
                                trans_band1, cldtf, cld_indx ,   &
                                Lw_diagnostics, e1ctw1)

!-----------------------------------------------------------------------
!     perform flux calculations for the flux levels KS+1 to KE-1. calcu-
!     lations for flux levels KE and KE+1 are done separately, as all
!     calculations are special cases or nearby layers.
!----------------------------------------------------------------------
    do k=KS+1,KE-1

!--------------------------------------------------------------------
!     compute co2 560-800 cm-1, ch4 and n2o 1200-1400 cm-1 trans-
!     mission functions and n2o 560-670 cm-1 transmission functions
!     appropriate for level k. 
!--------------------------------------------------------------------
        call transcolrow (Gas_tf, k, k, k, KE+1, k+1, KE+1,  &
                          co21c, co21r, tch4n2oe)

!-------------------------------------------------------------------
!     the 15 um band transmission functions between levels k and k+1
!     are stored in overod and co2nbl; they will not be overwritten,
!     as long as calculations are made for pressure levels increasing
!     from k.
!---------------------------------------------------------------------
       call optical_trans_funct_k_down (Gas_tf, k, to3cnt, overod,  &
                                         Optical, including_aerosols)  

!-----------------------------------------------------------------------
!     compute cloud transmission functions between level k and all
!     other levels greater or equal to k.
!---------------------------------------------------------------------
      call cloud (k,Cldrad_props,Cld_spec,  Lw_clouds, cldtf)

!-----------------------------------------------------------------------
!     compute the exchange terms in the flux equation (except the 
!     nearby layer (k,k) terms, done later).
!! trans_band1:
!   index 1 = emissb
!   index 2 = co21r*overod
!   index 3 = contodb1
!   index 4 = contodb2
!   index 5 = to3cnt
!   index 6 = contodb3
!   index 7 = emissbf
!! trans_band2:
!   index 1 = emiss
!   index 2 = co21c*overod
!   index 3 = contodb1
!   index 4 = contodb2
!   index 5 = to3cnt
!   index 6 = contodb3
!   index 7 = emissf
!---------------------------------------------------------------------
       call e290 (Atmos_input, k, trans_band2, trans_band1,   &
                  Optical,  tch4n2oe,  tcfc8, including_aerosols)     
       do kp=k,KE
      do j = 1,size(trans_band1(:,:,:,:),2)
         do i = 1,size(trans_band1(:,:,:,:),1)
            trans_band1(i,j,kp+1,3) = cnttaub1(i,j,kp+1  )/cnttaub1(i,j,k  )
         end do
      end do
      do j = 1,size(trans_band1(:,:,:,:),2)
         do i = 1,size(trans_band1(:,:,:,:),1)
            trans_band1(i,j,kp+1,4) = cnttaub2(i,j,kp+1  )/cnttaub2(i,j,k  )
         end do
      end do
      do j = 1,size(trans_band1(:,:,:,:),2)
         do i = 1,size(trans_band1(:,:,:,:),1)
            trans_band1(i,j,kp+1,6) = cnttaub3(i,j,kp+1  )/cnttaub3(i,j,k  )
         end do
      end do
       end do


     do kk = k+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,2) = co21r(i,j,kk)*   &
                                       overod(i,j,kk)
           end do
        end do
     end do
     do kk = k+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,5) = to3cnt(i,j,kk)
           end do
        end do
     end do


     do kk = k+1,KE+1
        do j = 1,size(trans_band2(:,:,:,:),2)
           do i = 1,size(trans_band2(:,:,:,:),1)
              trans_band2(i,j,kk,2) = co21c(i,j,kk)*   &
                                            overod(i,j,kk)
           end do
        end do
     end do
     do l = 3,6
        do kk = k+1,KE+1
           do j = 1,size(trans_band2(:,:,:,:),2)
              do i = 1,size(trans_band2(:,:,:,:),1)
                 trans_band2(i,j,kk,l) = trans_band1(i,j,kk,l)
              end do
           end do
        end do
     end do

!-----------------------------------------------------------------------
!     compute the terms for flux at levels k+1 to KE+1 from level k.
!     compute the terms for flux at level k due to levels 
!     kp from k+1 to KE+1.
!----------------------------------------------------------------------
      call longwave_fluxes_k_down  (k, dsrcdp_band, trans_band1, &
                                    trans_band2, cldtf, cld_indx,  &
                                    Lw_diagnostics          )  
   end do   ! (end of k=KS+1,KE-1 loop)

!-----------------------------------------------------------------------
!     compute remaining flux terms. these include:
!       1) the (k,k) terms, for pressure levels k from KS+1 to KE-1 
!          (the KS,KS term was handled earlier);
!       2) terms for pressure level KE. these include the (KE,KE) term,
!          computed as in (1), and the (KE,KE+1) and (KE+1,KE) terms,
!          computed somewhat differently from the similar terms at
!          higher levels, owing to the proximity to the surface layer
!          KE+1;
!       3) the term for pressure level KE+1 (the (KE+1,KE+1 term).
!
!     compute k=KE case.  since the kp loop is length one, many 
!     simplifications occur.  the co2 quantities and the emissivity
!     quantities) are computed in the nbl section. therefore, we want
!     to compute over, to3cnt, and contod; according to our notation    
!     over(:,:,KE), to3cnt(:,:,KE), and contod(:,:,KE).  the boundary
!     layer and nearby layer corrections to the transmission functions 
!     are obtained above.  the following ratios are used in various nbl
!     nbl calculations.  the remaining calculations are for:
!
!       1) the (k,k) terms, k=KS+1,KE-1;
!       2) the (KE,KE    ) term;
!       3) the (KE,KE+1  ) term;
!       4) the (KE+1,KE  ) term;
!       5) the (KE+1,KE+1) term.
!
!     each is uniquely handled.  different flux terms are computed
!     differently the fourth section obtains water transmission 
!     functions used in q(approximate) calculations and also makes nbl 
!     corrections:
!  
!       1) emiss (:,:) is the transmission function matrix obtained 
!          using E2spec;
! 
!       2) "nearby layer" corrections (emiss(i,i)) are obtained
!          using E3v88;
! 
!       3) special values at the surface (emiss(KE,KE+1),
!          emiss(KE+1,KE), emiss(KE+1,KE+1)) are calculated.
!
!
!     compute temperature and/or scaled amount indices and residuals 
!     for nearby layer and special layer lookup tables.
!
!          calculation for special cases (KE,KE+1) and (KE+1,KE)
!
!     compute co2 560-800 cm-1, ch4 and n2o 1200-1400 cm-1 trans-
!     mission functions and n2o 560-670 cm-1 transmission functions
!     appropriate for level KE. if activated, save ch4n2o tf term.
!-------------------------------------------------------------------
      call transcolrow (Gas_tf, KE, KE, KE, KE+1, KE+1, KE+1,  &
                        co21c, co21r, tch4n2oe)

!----------------------------------------------------------------------
!     get optical path terms for KE
!----------------------------------------------------------------------
      call optical_trans_funct_KE (Gas_tf, to3cnt, Optical, overod, &
                                   including_aerosols)        

   do j = 1,size(trans_b2d1(:,:,:),2)
      do i = 1,size(trans_b2d1(:,:,:),1)
         trans_b2d1(i,j,3  ) = cnttaub1(i,j,KE+1)/cnttaub1(i,j,KE  )
      end do
   end do
   do j = 1,size(trans_b2d1(:,:,:),2)
      do i = 1,size(trans_b2d1(:,:,:),1)
         trans_b2d1(i,j,4  ) = cnttaub2(i,j,KE+1)/cnttaub2(i,j,KE  )
      end do
   end do
   do j = 1,size(trans_b2d1(:,:,:),2)
      do i = 1,size(trans_b2d1(:,:,:),1)
         trans_b2d1(i,j,6  ) = cnttaub3(i,j,KE+1)/cnttaub3(i,j,KE  )
      end do
   end do

!-----------------------------------------------------------------------
!     compute cloud transmission functions between level KE and KE and
!     KE+1
!----------------------------------------------------------------------
      call cloud (KE, Cldrad_props, Cld_spec, Lw_clouds, cldtf)
   
!-------------------------------------------------------------------- 
!     compute mean temperature in the "nearby layer" between a flux
!     level and the first data level below the flux level (tpl1) or the
!     first data level above the flux level (tpl2)
!---------------------------------------------------------------------
      call esfc  (Atmos_input, emspec, Optical, emspecf, &
                  tch4n2oe, tcfc8)

!----------------------------------------------------------------------
!     compute nearby layer transmission functions for 15 um band, cont-
!     inuum bands, and 9.3 um band in subroutine Nearbylyrtf. trans-
!     mission functions for the special cases (KE,KE+1) and (KE+1,KE)
!     are also computed for the 15 um band.
!! trans_band1:
!    index 1 = emspec(KS+1)
!    index 2 = co21c_KEp1  
!    index 3 = contodb1
!    index 4 = contodb2
!    index 5 = to3cnt
!    index 6 = contodb3
!    index 7 = emspecf(KS+1)

!! trans_band2:
!    index 1 = emspec(KS)
!    index 2 = co21r_KEp1   
!    index 3 = contodb1
!    index 4 = contodb2
!    index 5 = to3cnt
!    index 6 = contodb3
!    index 7 = emspecf(KS)
!----------------------------------------------------------------------
    call trans_sfc    (Gas_tf, Atmos_input, overod, co21c_KEp1, &
                       co21r_KEp1)



     do j = 1,size(trans_b2d1(:,:,:),2)
        do i = 1,size(trans_b2d1(:,:,:),1)
           trans_b2d1(i,j,1) = emspec(i,j,KS+1)
        end do
     end do
     do j = 1,size(trans_b2d1(:,:,:),2)
        do i = 1,size(trans_b2d1(:,:,:),1)
           trans_b2d1(i,j,2) = co21c_KEp1(i,j)
        end do
     end do
     do j = 1,size(trans_b2d1(:,:,:),2)
        do i = 1,size(trans_b2d1(:,:,:),1)
           trans_b2d1(i,j,5) = to3cnt(i,j,KE+1)
        end do
     end do

     do m=1,NBTRGE
     do j = 1,size(trans_b2d1(:,:,:),2)
        do i = 1,size(trans_b2d1(:,:,:),1)
           trans_b2d1(i,j,6+m) = emspecf(i,j,KS+1,m)
        end do
     end do
     end do

     do j = 1,size(trans_b2d2(:,:,:),2)
        do i = 1,size(trans_b2d2(:,:,:),1)
           trans_b2d2(i,j,1) = emspec(i,j,KS)
        end do
     end do
     do j = 1,size(trans_b2d2(:,:,:),2)
        do i = 1,size(trans_b2d2(:,:,:),1)
           trans_b2d2(i,j,2) = co21r_KEP1(i,j)
        end do
     end do
     do kk = 3,6
        do j = 1,size(trans_b2d2(:,:,:),2)
           do i = 1,size(trans_b2d2(:,:,:),1)
              trans_b2d2(i,j,kk) = trans_b2d1(i,j,kk)
           end do
        end do
     end do
     do m=1,NBTRGE
     do j = 1,size(trans_b2d2(:,:,:),2)
        do i = 1,size(trans_b2d2(:,:,:),1)
           trans_b2d2(i,j,6+m) = emspecf(i,j,KS,m)
        end do
     end do
     end do

!-----------------------------------------------------------------------
!     obtain fluxes for the two terms (KE,KE+1) and (KE+1,KE), both 
!     using the same cloud transmission functions (from layer KE)
!----------------------------------------------------------------------
    call longwave_fluxes_KE_KEp1 (dsrcdp_band, trans_b2d1, &
                                  trans_b2d2, cldtf, cld_indx,  &
                                  Lw_diagnostics )

!---------------------------------------------------------------------
!     call enear to calculate emissivity arrays
!----------------------------------------------------------------------
      call enear (Atmos_input, emisdg, Optical, emisdgf , tch4n2oe, &
                  tcfc8)

!-------------------------------------------------------------------
!     obtain optical path transmission functions for diagonal terms
!------------------------------------------------------------------
    call optical_trans_funct_diag (Atmos_input, contdg, to3dg, &
                                   Optical)
 
!-----------------------------------------------------------------------
!     compute cloud transmission functions between level KE+1 and KE+1
!------------------------------------------------------------------
     call cloud (KE+1, Cldrad_props, Cld_spec, Lw_clouds, cldtf)
 
!----------------------------------------------------------------------
!     compute nearby layer transmission functions for 15 um band, cont-
!     inuum bands, and 9.3 um band in subroutine Nearbylyrtf. trans-
!     mission functions for the special cases (KE,KE+1) and (KE+1,KE)
!     are also computed for the 15 um band.
!----------------------------------------------------------------------
     call trans_nearby (Gas_tf, Atmos_input, overod,  co21c)


     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,1) = emisdg(i,j,kk)
           end do
        end do
     end do
     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,2) = co21c(i,j,kk)
           end do
        end do
     end do
     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,3) = contdg(i,j,kk,1)
           end do
        end do
     end do
     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,4) = contdg(i,j,kk,2)
           end do
        end do
     end do
     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,5) = to3dg(i,j,kk)
           end do
        end do
     end do
     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,6) = contdg(i,j,kk,3)
           end do
        end do
     end do


     do m=1,NBTRGE
     do kk = ks+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,6+m) = emisdgf(i,j,kk,m)
           end do
        end do
     end do
     end do

!-----------------------------------------------------------------------
!     obtain fluxes for the diagonal terms at all levels.
!-----------------------------------------------------------------------
    call longwave_fluxes_diag (dsrcdp_band, trans_band1, cldtf , &
                               cld_indx, Lw_diagnostics )

!--------------------------------------------------------------------
!      sum up fluxes over bands
!-----------------------------------------------------------------------
    if (Rad_control%do_totcld_forcing) then
      call longwave_fluxes_sum (is, ie, js, je, flx, NBTRGE, &
                                Lw_diagnostics, flxcf)
    else
      call longwave_fluxes_sum (is, ie, js, je, flx, NBTRGE, &
                                Lw_diagnostics)
    endif
    Lw_output%bdy_flx(:,:,1) = Lw_output%bdy_flx(:,:,1) + &
                               Lw_diagnostics%fluxn(:,:,1,3) + &
                               Lw_diagnostics%fluxn(:,:,1,4) + &
                               Lw_diagnostics%fluxn(:,:,1,5) + &
                               Lw_diagnostics%fluxn(:,:,1,6) 
    Lw_output%bdy_flx(:,:,2) = Lw_output%bdy_flx(:,:,2) + &
                               Lw_diagnostics%fluxn(:,:,1,4) 
    Lw_output%bdy_flx(:,:,3) = Lw_output%bdy_flx(:,:,3) + &
                               Lw_diagnostics%fluxn(:,:,ke+1,3) + &
                               Lw_diagnostics%fluxn(:,:,ke+1,4) + &
                               Lw_diagnostics%fluxn(:,:,ke+1,5) + &
                               Lw_diagnostics%fluxn(:,:,ke+1,6) 
    Lw_output%bdy_flx(:,:,4) = Lw_output%bdy_flx(:,:,4) + &
                               Lw_diagnostics%fluxn(:,:,ke+1,4) 
!   Lw_output%bdy_flx = 1.0E-03*Lw_output%bdy_flx

    if (nnn == 1) then ! need do only once
    if (Rad_control%do_totcld_forcing) then
      Lw_output%bdy_flx_clr(:,:,1) = Lw_diagnostics%fluxncf(:,:,1,3) + &
                                 Lw_diagnostics%fluxncf(:,:,1,4) + &
                                 Lw_diagnostics%fluxncf(:,:,1,5) + &
                                 Lw_diagnostics%fluxncf(:,:,1,6) 
      Lw_output%bdy_flx_clr(:,:,2) = Lw_diagnostics%fluxncf(:,:,1,4) 
      Lw_output%bdy_flx_clr(:,:,3) = Lw_diagnostics%fluxncf(:,:,ke+1,3) + &
                                 Lw_diagnostics%fluxncf(:,:,ke+1,4) + &
                                 Lw_diagnostics%fluxncf(:,:,ke+1,5) + &
                                 Lw_diagnostics%fluxncf(:,:,ke+1,6) 
      Lw_output%bdy_flx_clr(:,:,4) = Lw_diagnostics%fluxncf(:,:,ke+1,4) 
      Lw_output%bdy_flx_clr = 1.0E-03*Lw_output%bdy_flx_clr
    endif
    endif

    
!-----------------------------------------------------------------------
!     compute emissivity heating rates.
!-----------------------------------------------------------------------

     do kk = ks,ke
        do j = 1,size(pdfinv(:,:,:),2)
           do i = 1,size(pdfinv(:,:,:),1)
              pdfinv(i,j,kk) = 1.0/(Atmos_input%pflux(i,j,kk+ks+1-(ks)) -  &
                            Atmos_input%pflux(i,j,kk))
           end do
        end do
     end do



    do kk = KS,KE
       do j = 1,size(heatem(:,:,:),2)
          do i = 1,size(heatem(:,:,:),1)
             heatem(i,j,kk) = (radcon_mks*(flx(i,j,kk+KS+1-(KS)) -    &
                        flx(i,j,kk))*pdfinv(i,j,kk))*1.0e-03
          end do
       end do
    end do
    if (Rad_control%do_totcld_forcing) then                    
      do kk = KS,KE
         do j = 1,size(heatemcf(:,:,:),2)
            do i = 1,size(heatemcf(:,:,:),1)
               heatemcf(i,j,kk) = (radcon_mks*(flxcf(i,j,kk+KS+1-(KS)) -    &
                            flxcf(i,j,kk))*pdfinv(i,j,kk)*1.0e-03)
            end do
         end do
      end do
    endif

!-----------------------------------------------------------------------
!     compute total heating rates.
!-----------------------------------------------------------------------
!--------------------------------------------------------------------
!     cts_sum is the sum of the values from cool_to_space_exact and
!     the values defined here in cool_to_space_approx. it will be used
!     by longwave_driver_mod.
!--------------------------------------------------------------------
    do kk = 1,size(cts_sum(:,:,:),3)
       do j = 1,size(cts_sum(:,:,:),2)
          do i = 1,size(cts_sum(:,:,:),1)
             cts_sum(i,j,kk) = ((((((cts_sum(i,j,kk) -   &
               Lw_diagnostics%cts_out(i,j,kk,2)) -  & 
               Lw_diagnostics%cts_out(i,j,kk,5) )-  &
               Lw_diagnostics%cts_out(i,j,kk,1))  - &
               Lw_diagnostics%cts_out(i,j,kk,3)) - &
               Lw_diagnostics%cts_out(i,j,kk,4))- &
               Lw_diagnostics%cts_out(i,j,kk,6))
          end do
       end do
    end do

    if (Rad_control%do_totcld_forcing) then
    do kk = 1,size(cts_sumcf(:,:,:),3)
       do j = 1,size(cts_sumcf(:,:,:),2)
          do i = 1,size(cts_sumcf(:,:,:),1)
             cts_sumcf(i,j,kk) = ((((((cts_sumcf(i,j,kk) -  &
                            Lw_diagnostics%cts_outcf(i,j,kk,2)) - &
                            Lw_diagnostics%cts_outcf(i,j,kk,5)) - &
                            Lw_diagnostics%cts_outcf(i,j,kk,1)) - &
                            Lw_diagnostics%cts_outcf(i,j,kk,3)) - &
                            Lw_diagnostics%cts_outcf(i,j,kk,4) ) - &
                            Lw_diagnostics%cts_outcf(i,j,kk,6))
          end do
       end do
    end do
    endif
      do kk = KS,KE
         do j = 1,size(Lw_output%heatra(:,:,:),2)
            do i = 1,size(Lw_output%heatra(:,:,:),1)
               Lw_output%heatra(i,j,kk) = heatem(i,j,kk) +   &
               cts_sum  (i,j,kk)  
            end do
         end do
      end do

    if (nnn == 1) then ! only need to do once
    if (Rad_control%do_totcld_forcing) then                    
      do kk = KS,KE
         do j = 1,size(Lw_output%heatracf(:,:,:),2)
            do i = 1,size(Lw_output%heatracf(:,:,:),1)
               Lw_output%heatracf(i,j,kk) = heatemcf(i,j,kk) +   &
                           cts_sumcf(i,j,kk) 
            end do
         end do
      end do
    endif
    endif !  (nnn == 1)

!-----------------------------------------------------------------------
!     compute the flux at each flux level using the flux at the
!     top (flx1e1 + gxcts) and the integral of the heating rates.
!---------------------------------------------------------------------
      do kk = KS,KE
         do j = 1,size(pdflux(:,:,:),2)
            do i = 1,size(pdflux(:,:,:),1)
               pdflux(i,j,kk) = Atmos_input%pflux(i,j,kk+KS+1-(KS)) -   &
                              Atmos_input%pflux(i,j,kk)
            end do
         end do
      end do

      do j = 1,size(Lw_output%flxnet(:,:,:),2)
         do i = 1,size(Lw_output%flxnet(:,:,:),1)
            Lw_output%flxnet(i,j,KS   ) = Lw_diagnostics%flx1e1(i,j) + Lw_diagnostics%gxcts(i,j)
         end do
      end do


!---------------------------------------------------------------------
! convert values to mks (1.0e-03 factor) 
!---------------------------------------------------------------------
      do j = 1,size(Lw_diagnostics%gxcts(:,:),2)
         do i = 1,size(Lw_diagnostics%gxcts(:,:),1)
            Lw_diagnostics%gxcts(i,j) = 1.0e-03*Lw_diagnostics%gxcts(i,j)
         end do
      end do
      do j = 1,size(Lw_diagnostics%flx1e1(:,:),2)
         do i = 1,size(Lw_diagnostics%flx1e1(:,:),1)
            Lw_diagnostics%flx1e1(i,j) = 1.0e-03*Lw_diagnostics%flx1e1(i,j)
         end do
      end do
      if (NBTRGE> 0) then
      do kk = 1,size(Lw_diagnostics%flx1e1f(:,:,:),3)
         do j = 1,size(Lw_diagnostics%flx1e1f(:,:,:),2)
            do i = 1,size(Lw_diagnostics%flx1e1f(:,:,:),1)
               Lw_diagnostics%flx1e1f(i,j,kk) = &
                    1.0e-03*Lw_diagnostics%flx1e1f(i,j,kk)
            end do
         end do
      end do
      endif


!---------------------------------------------------------------------
!    convert mks values to cgs (1.0e03 factor) so can be summed with
!    cgs value.
!---------------------------------------------------------------------
      do kk = KS,KE
         do j = 1,size(tmp1(:,:,:),2)
            do i = 1,size(tmp1(:,:,:),1)
               tmp1(i,j,kk) = 1.0e03*Lw_output%heatra(i,j,kk)*pdflux(i,j,kk)/radcon_mks
            end do
         end do
      end do
    do k=KS+1,KE+1
      do j = 1,size(Lw_output%flxnet(:,:,:),2)
         do i = 1,size(Lw_output%flxnet(:,:,:),1)
            Lw_output%flxnet(i,j,k) = Lw_output%flxnet(i,j,k-1) + tmp1(i,j,k-1)
         end do
      end do
    enddo

   if (nnn == 1) then   ! only need to do once
   if (Rad_control%do_totcld_forcing) then                    
     do j = 1,size(Lw_output%flxnetcf(:,:,:),2)
        do i = 1,size(Lw_output%flxnetcf(:,:,:),1)
           Lw_output%flxnetcf(i,j,KS   ) = flx1e1cf(i,j) + gxctscf(i,j)
        end do
     end do
!---------------------------------------------------------------------
!    convert mks values to cgs (1.0e03 factor) so can be summed 
!    with cgs value.
!---------------------------------------------------------------------
     do kk = KS,KE
        do j = 1,size(tmp1(:,:,:),2)
           do i = 1,size(tmp1(:,:,:),1)
              tmp1(i,j,kk) = 1.0e03*Lw_output%heatracf(i,j,kk)*pdflux(i,j,kk)/radcon_mks 
           end do
        end do
     end do
     do k=KS+1,KE+1
       do j = 1,size(Lw_output%flxnetcf(:,:,:),2)
          do i = 1,size(Lw_output%flxnetcf(:,:,:),1)
             Lw_output%flxnetcf(i,j,k) = Lw_output%flxnetcf(i,j,k-1) + tmp1(i,j,k-1)
          end do
       end do
     enddo
   endif
   endif  ! (nnn == 1) 
 
   if (Cldrad_control%do_ica_calcs) then
     heatra_save = heatra_save + Lw_output%heatra
     flxnet_save = flxnet_save + Lw_output%flxnet
   endif
 
   end do  ! (profiles loop)
 
 

    if (Cldrad_control%do_ica_calcs) then
      Lw_output%heatra = heatra_save / Float(nprofiles)
      Lw_output%flxnet = flxnet_save / Float(nprofiles)
      Lw_output%bdy_flx = 1.0e-03*Lw_output%bdy_flx/Float(nprofiles)
    endif

!-----------------------------------------------------------------------
!    call thickcld to perform "pseudo-convective adjustment" for
!    maximally overlapped clouds, if desired.
!-----------------------------------------------------------------------
   if (do_thick) then
       call thickcld (Atmos_input%pflux, Cldrad_props, Cld_spec, &
                      Lw_output)
   endif  ! (do_thick)

!--------------------------------------------------------------------
!   convert lw fluxes to mks units.
!---------------------------------------------------------------------
     do kk = 1,size(Lw_output%flxnet(:,:,:),3)
        do j = 1,size(Lw_output%flxnet(:,:,:),2)
           do i = 1,size(Lw_output%flxnet(:,:,:),1)
              Lw_output%flxnet(i,j,kk) = 1.0E-03*Lw_output%flxnet(i,j,kk)
           end do
        end do
     end do
     if (Rad_control%do_totcld_forcing) then
        do kk = 1,size(Lw_output%flxnetcf(:,:,:),3)
           do j = 1,size(Lw_output%flxnetcf(:,:,:),2)
              do i = 1,size(Lw_output%flxnetcf(:,:,:),1)
                 Lw_output%flxnetcf(i,j,kk) = 1.0E-03*Lw_output%flxnetcf(i,j,kk)
              end do
           end do
        end do
      endif

!--------------------------------------------------------------------
!    call lw_clouds_dealloc to deallocate component arrays of Lw_clouds.
!--------------------------------------------------------------------
      call lw_clouds_dealloc (Lw_clouds)

!--------------------------------------------------------------------
!    call gas_tf_dealloc to deallocate component arrays of Gas_tf.
!--------------------------------------------------------------------
      call gas_tf_dealloc (Gas_tf)

!--------------------------------------------------------------------
!    call optical_dealloc to deallocate component arrays of Optical.
!--------------------------------------------------------------------
      call optical_dealloc (Optical, including_aerosols)      
      
!--------------------------------------------------------------------


end subroutine sealw99 

!#####################################################################
! <SUBROUTINE NAME="sealw99_end">
!  <OVERVIEW>
!   sealw99_end is the destructor for sealw99_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!   sealw99_end is the destructor for sealw99_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call sealw99_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine sealw99_end                  

!---------------------------------------------------------------------
!    sealw99_end is the destructor for sealw99_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module is initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg( 'sealw99_mod',  &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    call the destructor routines for the modules initialized by 
!    sealw99.
!---------------------------------------------------------------------
      call gas_tf_end
      call optical_path_end
      call lw_gases_stdtf_end
      call longwave_clouds_end
      call longwave_fluxes_end
      call longwave_tables_end
      call longwave_params_end

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------


end subroutine sealw99_end                  




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

                                 
!#####################################################################
! <SUBROUTINE NAME="check_tf_interval">
!  <OVERVIEW>
!   check_tf_interval verifies that requested tf calculation intervals
!   are compatible with radiation time step
!  </OVERVIEW>
!
!  <DESCRIPTION>
!   check_tf_interval verifies the following relationships:
!     1) that the tf calculation interval is no smaller than the
!        radiation time step;
!     2) that the tf calculation interval is an integral multiple of
!        the radiation time step;
!     3) that the specification for calculating tfs on the first step
!        of the job is done properly.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call check_tf_interval (gas, gas_tf_calc_intrvl, &
!                           calc_gas_tfs_on_first_step,  &
!                           use_current_gas_for_tf)
!   call sealw99_alloc (ix, jx, kx, Lw_diagnostics)  
!  </TEMPLATE>
!  <IN NAME="gas">    
!   name associated with the gas
!  </IN>
!  <IN NAME="gas_tf_calc_intrvl">    
!   time interval between recalculating transmission fumctions [ hours ]
!  </IN>
!  <IN NAME="calc_gas_tfs_on_first_step">  
!   flag indicating if tfs are to be calculated only on first step 
!   of job
!  </IN>
!  <IN NAME="use_current_gas_for_tf">  
!   flag indicating if gas mixing ratio at current time is to be used
!   for calculation of gas tfs 
!  </IN>
! </SUBROUTINE>
! <PUBLICROUTINE>
!
!NOTE: THIS IS A PRIVATE SUBROUTINE.
!

subroutine check_tf_interval (gas, gas_tf_calc_intrvl, &
                              calc_gas_tfs_on_first_step,  &
                              calc_gas_tfs_monthly,        &
                              use_current_gas_for_tf)

!--------------------------------------------------------------------
character(len=4), intent(in) :: gas
real,             intent(in) :: gas_tf_calc_intrvl
logical,          intent(in) :: calc_gas_tfs_on_first_step,  &
                                calc_gas_tfs_monthly,        &
                                use_current_gas_for_tf

! </PUBLICROUTINE>

!---------------------------------------------------------------------
!    if tfs are not being calculated on the first step, the requested 
!    gas transmission function recalculation interval must be greater
!    than the radiation time step. 
!---------------------------------------------------------------------
      if (.not. calc_gas_tfs_on_first_step .and. &
          .not. calc_gas_tfs_monthly) then
        if (INT(3600.0*gas_tf_calc_intrvl) <   &
            Rad_control%lw_rad_time_step) then
          call error_mesg ('sealw99_mod', &
             trim(gas)// ' tf calculation interval must be greater&
                    & than or equal to the radiation time step', FATAL)
        endif

!---------------------------------------------------------------------
!    be sure that the tf calculation interval is an integral multiple 
!    of the radiation timestep.
!---------------------------------------------------------------------
        if (mod(INT(3600.0*gas_tf_calc_intrvl),   &
                Rad_control%lw_rad_time_step) /= 0) then
          call  error_mesg ('sealw99_mod',  &
           trim(gas)//' transmission function calculation interval &
           &must be integral multiple of radiation time step', FATAL)
        endif
      endif ! (.not. calc_gas_tfs_on_first_step)

!---------------------------------------------------------------------
!    to calculate the tfs using the gas value at the start of the run,
!    one must set use_current_gas_for_tf to .false, and set the 
!    gas_tf_time_displacement to 0.0, rather than setting 
!    use_current_gas_for_tf to .true.
!---------------------------------------------------------------------
      if (calc_gas_tfs_on_first_step) then
        if (use_current_gas_for_tf) then
          call error_mesg ('sealw99_mod', &
              'cannot specify use of current '//trim(gas)//' value&
              & for tfs when calculating tfs on first step; instead   &
              &set use_current_'//trim(gas)//'_for_tf to false and set &
              & '//trim(gas)//'_tf_time_displacement =    0.0', FATAL)
        endif
      endif

      if (calc_gas_tfs_on_first_step .and. &
          calc_gas_tfs_monthly) then
        call error_mesg ( 'sealw99_mod',  &
          'cannot request calc of tfs both on first step and monthly',&
                                                                FATAL)
      endif

!---------------------------------------------------------------------


end subroutine check_tf_interval



!####################################################################
! <SUBROUTINE NAME="obtain_gas_tfs">
!  <OVERVIEW>
!   obtain_gas_tfs obtains the transmission functions for the requested
!   gas
!  </OVERVIEW>
!
!  <DESCRIPTION>
!   obtain_gas_tfs performs the following functions:
!     a) if time variation of the gas has begun at the current time:
!        1) defines how long the gas has been varying and whether
!           the tfs are due to be recalculated at the current time;
!        2) if the tfs are not to be always recalculated on the first
!           step:
!           a) if this is a recalculation step;
!             1) call the routine to calculate the tfs for the input 
!                gas;
!             2) redefine the value of the gas mixing ratio used fro the
!                last tf calculation to be the one just used;
!             3) set the flag indicating the need to initially calculate
!                the tfs to .false.
!           b) if this is not a recalculation step:
!             1) if this is the initial step, call the routine to calc-
!                ulate the tfs for the input gas;
!             2) set the flag indicating the need to initially calculate
!                the tfs to .false.
!        3) if the tfs are to be always calculated on the first step:
!           a) call the routine to calculate the tfs for the input gas;
!           b) redefine the value of the gas mixing ratio used from the
!              last tf calculation to be the one just used;
!           c) set the flag indicating the need to initially calculate
!              the tfs to .false.
!     b) if time variation of the gas has not begun at the current time:
!         1) if this is the initial call of the job, call the routine
!            to calculate the tfs for the input gas;
!         2) set a flag to indicate that the initial call has been made.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_gas_tfs (gas, Rad_time, Gas_time, gas_tf_calc_intrvl,&
!                       gas_tf_offset, calc_gas_tfs_on_first_step, &
!                       gas_for_next_tf_calc, gas_for_last_tf_calc, &
!                       do_gas_tf_calc, do_gas_tf_calc_init)
!  </TEMPLATE>
!  <IN NAME="gas">    
!   name associated with the gas
!  </IN>
!  <IN NAME="Rad_time">
!   current model time [ time_type ]
!  </IN>
!  <IN NAME="Gas_time">
!   time since time variation of gas began [ time_type ]
!  </IN>
!  <IN NAME="gas_tf_calc_intrvl">    
!   time interval between recalculating transmission fumctions [ hours ]
!  </IN>
!  <IN NAME="gas_tf_offset">
!   time difference between current time and the time for which the 
!   tfs are calculated
!  </IN>
!  <IN NAME="calc_gas_tfs_on_first_step">  
!   flag indicating if tfs are to be calculated only on first step 
!   of job
!  </IN>
!  <INOUT NAME="gas_for_next_tf_calc">  
!   value of gas mixing ratio to be used when tfs are next calculated
!   [ no. / no. ]
!  </INOUT>
!  <INOUT NAME="gas_for_last_tf_calc">  
!   value of gas mixing ratio to be used when tfs were last calculated
!   [ no. / no. ]
!  </INOUT>
!  <INOUT NAME="do_gas_tf_calc">
!   if true, calculate gas tfs when alarm again goes off
!  </INOUT>
!  <INOUT NAME="do_gas_tf_calc_init">
!   this variable is true initially to force calculation of the tfs on 
!   the first call of the job; it is then set to false
!  </INOUT>
!</SUBROUTINE>
!
!NOTE: THIS IS A PRIVATE SUBROUTINE.
!
subroutine obtain_gas_tfs (gas, Rad_time, Gas_time, gas_tf_calc_intrvl,&
                           gas_tf_offset, calc_gas_tfs_on_first_step, &
                           calc_gas_tfs_monthly,month_of_gas_tf_calc, &
                           gas_for_next_tf_calc, gas_for_last_tf_calc, &
                           do_gas_tf_calc, do_gas_tf_calc_init)

!----------------------------------------------------------------------
character(len=4),       intent(in)    :: gas
type(time_type),        intent(in)    :: Rad_time, Gas_time
real,                   intent(in)    :: gas_tf_calc_intrvl,  &
                                         gas_tf_offset
logical,                intent(in)    :: calc_gas_tfs_on_first_step
integer,                intent(inout) :: month_of_gas_tf_calc
logical,                intent(in)    :: calc_gas_tfs_monthly       
real,                   intent(inout) :: gas_for_next_tf_calc, &
                                         gas_for_last_tf_calc
logical,                intent(inout) :: do_gas_tf_calc,&
                                         do_gas_tf_calc_init
                       
!---------------------------------------------------------------------
!  local variables:

      type(time_type)      :: Time_since_gas_start
      integer              :: seconds, days, minutes_from_start, alarm
      integer              :: year, month, day, hour, minute, second
      character(len=4)     :: chvers, chvers2, chvers3, chvers4, &
                              chvers5, chvers6
      character(len=12)    :: chvers10
      character(len=16)    :: chvers7

!---------------------------------------------------------------------
!  local variables:
!
!     Time_since_gas_start   length of time that gas has been varying
!                            [ time_type ]
!     seconds                seconds component of Time_since_gas_start
!                            [ seconds ]
!     days                   days component of Time_since_gas_start
!                            [ days ]
!     minutes_from_start     minutes since time variation started
!                            [ minutes ]
!     alarm                  if alarm = 0, it is time to calculate the
!                            tfs [ minutes ]
!     year                   year component of current time
!     month                  month component of current time
!     day                    day component of current time
!     hour                   hour component of current time
!     minute                 minute component of current time
!     second                 second component of current time
!     chvers, chversx        characters used to output model variables
!                            through the error_mesg interface
!      
!---------------------------------------------------------------------


!--------------------------------------------------------------------
!    if gas variation is underway, define how long it has been since
!    that started, and whether the current time is an integral multiple
!    of the calculation interval from that gas starting time. put
!    the current time into character variables for output via the
!    error_mesg interface.
!--------------------------------------------------------------------
      if (Rad_time >= Gas_time) then 
        Time_since_gas_start = Rad_time - Gas_time
        call get_time (Time_since_gas_start, seconds, days)
        call get_date (Rad_time, year, month, day, hour, minute, second)
        write (chvers, '(i4)') year
        write (chvers2, '(i4)') month
        write (chvers3, '(i4)') day  
        write (chvers4, '(i4)') hour 
        write (chvers5, '(i4)') minute
        write (chvers6, '(i4)') second
        write (chvers10, '( f9.3)') gas_tf_offset    

!---------------------------------------------------------------------
!    if tfs are not automatically calculated on the first step of the
!    job and if the current time is a desired recalculation time, call 
!    xxx_time_vary to do the calculation.
!---------------------------------------------------------------------
!       if (.not. calc_gas_tfs_on_first_step) then
        if (.not. calc_gas_tfs_on_first_step .and. &
            .not. calc_gas_tfs_monthly) then
          minutes_from_start = INT(days*1440.0 + real(seconds)/60.)
          if (gas_tf_calc_intrvl /= 0.0) then
            alarm = MOD (minutes_from_start,   &
                         INT(gas_tf_calc_intrvl*60.0))
          endif
          if (alarm == 0) then
            if (trim(gas) == 'ch4') then
              call ch4_time_vary (gas_for_next_tf_calc)
              write (chvers7, '(4pe15.7)')  gas_for_next_tf_calc
            else if (trim(gas) == 'n2o') then
              call n2o_time_vary (gas_for_next_tf_calc)
              write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
            else if (trim(gas) == 'co2') then
              call co2_time_vary (gas_for_next_tf_calc)
              write (chvers7, '(3pe15.7)')  gas_for_next_tf_calc
            endif

!--------------------------------------------------------------------
!    redefine the value for the gas mixing ratio used fro the last tf 
!    calculation.
!--------------------------------------------------------------------
            gas_for_last_tf_calc = gas_for_next_tf_calc

!---------------------------------------------------------------------
!    if a record of the tf calculation path is desired, print out the
!    relevant data.
!---------------------------------------------------------------------
            if (verbose >= 1) then
              if (gas_tf_offset /= 0.0) then
                call error_mesg ('sealw99_mod',  &
                 'calculating '//trim(gas)//' transmission functions&
                 & at time '//chvers//chvers2//chvers3//chvers4//  &
                 chvers5// chvers6// ', using '//trim(gas)//' &
                 &mixing ratio of:' // chvers7 //', which&
                 & is the value '//chvers10// 'hours from current &
                                                         & time.', NOTE)
              else
                call error_mesg ('sealw99_mod',  &
                 'calculating '//trim(gas)//' transmission functions&
                 & at time ' //chvers//chvers2//chvers3//chvers4//&
                 chvers5// chvers6// ', using '//trim(gas)//'  &
                 &mixing ratio of:' // chvers7 //', which&
                             & is the value at the current time', NOTE)
              endif
            endif ! (verbose)

!---------------------------------------------------------------------
!    set the flag to indicate that the initial tf calculation has been 
!    completed.
!---------------------------------------------------------------------
            do_gas_tf_calc_init = .false.

!----------------------------------------------------------------------
!    if alarm is not 0 and the tfs have not yet been calculated, call 
!    xxx_time_vary to do the calculation. set the flag appropriately.
!---------------------------------------------------------------------
          else
            if (do_gas_tf_calc_init) then
              if (trim(gas) == 'ch4') then
                call ch4_time_vary (gas_for_last_tf_calc)
                write (chvers7, '(4pe15.7)') gas_for_last_tf_calc
              else if (trim(gas) == 'n2o') then
                call n2o_time_vary (gas_for_last_tf_calc)
                write (chvers7, '(3pe15.7)') gas_for_last_tf_calc
              else if (trim(gas) == 'co2') then
                call co2_time_vary (gas_for_last_tf_calc)
                write (chvers7, '(3pe15.7)') gas_for_last_tf_calc
              endif
              do_gas_tf_calc_init = .false.

!---------------------------------------------------------------------
!    if a record of the tf calculation path is desired, print out the
!    relevant data.
!---------------------------------------------------------------------
              if (verbose >= 1) then
                if (gas_tf_offset /= 0.0) then
                  call error_mesg ('sealw99_mod',  &
                       'initial '//gas//' transmission function  &
                        &calculation uses '//trim(gas)//' mixing ratio &
                        &of:'//chvers7//'.', NOTE) 
                else
                  call error_mesg ('sealw99_mod',  &
                        'initial '//trim(gas)//' transmission function&
                         & calculation uses '//trim(gas)//' mixing &
                        &ratio of:' // chvers7 //', which is the value &
                        &at the current time.', NOTE)
                endif
              endif
            endif
          endif !(alarm == 0)

!---------------------------------------------------------------------
!    if it is desired that the tfs be calculated only on the first 
!    step, call the appropriate subroutines to do so. redefine the
!    gas values used for the last tf calculation  redefine the
!    gas values used for the last tf calculation. 
!---------------------------------------------------------------------
!       else ! (.not. calc_gas_tfs_on_first_step)
        else  if (calc_gas_tfs_on_first_step) then
          if (trim(gas) == 'ch4') then
            call ch4_time_vary (gas_for_next_tf_calc)
            write (chvers7, '(4pe15.7)') gas_for_next_tf_calc
          else if (trim(gas) == 'n2o') then
            call n2o_time_vary (gas_for_next_tf_calc)
            write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
          else if (trim(gas) == 'co2') then
            call co2_time_vary (gas_for_next_tf_calc)
            write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
          endif
          gas_for_last_tf_calc = gas_for_next_tf_calc

!---------------------------------------------------------------------
!    if a record of the tf calculation path is desired, print out the
!    relevant data.
!---------------------------------------------------------------------
          if (verbose >= 1) then
            if (gas_tf_offset /= 0.0) then
              call error_mesg ('sealw99_mod',  &
                  'calculating '//trim(gas)//' transmission functions&
                  & at time '  //chvers//chvers2//chvers3//chvers4// &
                  chvers5//chvers6// ', using '//trim(gas)//' mixing &
                  &ratio of:' // chvers7 //', which is the value ' &
                  //chvers10// 'hours from current time.', NOTE)
            else
              call error_mesg ('sealw99_mod',  &
                   'calculating '//trim(gas)//' transmission functions&
                   & at time ' //chvers//chvers2//chvers3//chvers4//&
                   chvers5//chvers6// ', using '//trim(gas)//' mixing &
                   &ratio of:' // chvers7 //', which is the value at &
                   &the current time.', NOTE)
            endif
          endif

!---------------------------------------------------------------------
!    set the flag to indicate that the initial tf calculation has been 
!    completed.
!---------------------------------------------------------------------
          do_gas_tf_calc_init = .false.
        else if (calc_gas_tfs_monthly) then
          if (do_gas_tf_calc_init)  then          
            if (trim(gas) == 'ch4') then
              call ch4_time_vary (gas_for_next_tf_calc)
              write (chvers7, '(4pe15.7)') gas_for_next_tf_calc
            else if (trim(gas) == 'n2o') then
              call n2o_time_vary (gas_for_next_tf_calc)
              write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
            else if (trim(gas) == 'co2') then
              call co2_time_vary (gas_for_next_tf_calc)
              write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
            endif
            gas_for_last_tf_calc = gas_for_next_tf_calc

!---------------------------------------------------------------------
!    if a record of the tf calculation path is desired, print out the
!    relevant data.
!---------------------------------------------------------------------
            if (verbose >= 1) then
              if (gas_tf_offset /= 0.0) then
                call error_mesg ('sealw99_mod',  &
                  'calculating '//trim(gas)//' transmission functions&
                  & at time '  //chvers//chvers2//chvers3//chvers4// &
                  chvers5//chvers6// ', using '//trim(gas)//' mixing &
                  &ratio of:' // chvers7 //', which is the value ' &
                  //chvers10// 'hours from current time  .', NOTE)
              else
                call error_mesg ('sealw99_mod',  &
                   'calculating '//trim(gas)//' transmission functions&
                   & at time ' //chvers//chvers2//chvers3//chvers4//&
                   chvers5//chvers6// ', using '//trim(gas)//' mixing &
                   &ratio of:' // chvers7 //', which is the value at &
                   &the current time.', NOTE)
              endif
            endif

!---------------------------------------------------------------------
!    set the flag to indicate that the initial tf calculation has been 
!    completed.
!---------------------------------------------------------------------
            do_gas_tf_calc_init = .false.
            month_of_gas_tf_calc = month
          else ! (do_gas_tf_calc_init)
            if (month /= month_of_gas_tf_calc) then
              if (trim(gas) == 'ch4') then
                call ch4_time_vary (gas_for_next_tf_calc)
                write (chvers7, '(4pe15.7)') gas_for_next_tf_calc
              else if (trim(gas) == 'n2o') then
                call n2o_time_vary (gas_for_next_tf_calc)
                write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
              else if (trim(gas) == 'co2') then
                call co2_time_vary (gas_for_next_tf_calc)
                write (chvers7, '(3pe15.7)') gas_for_next_tf_calc
              endif
              gas_for_last_tf_calc = gas_for_next_tf_calc

!---------------------------------------------------------------------
!    if a record of the tf calculation path is desired, print out the
!    relevant data.
!---------------------------------------------------------------------
              if (verbose >= 1) then
                if (gas_tf_offset /= 0.0) then
                  call error_mesg ('sealw99_mod',  &
                  'calculating '//trim(gas)//' transmission functions&
                  & at time '  //chvers//chvers2//chvers3//chvers4// &
                  chvers5//chvers6// ', using '//trim(gas)//' mixing &
                  &ratio of:' // chvers7 //', which is the value ' &
                  //chvers10// 'hours from current time.', NOTE)
                else
                  call error_mesg ('sealw99_mod',  &
                   'calculating '//trim(gas)//' transmission functions&
                   & at time ' //chvers//chvers2//chvers3//chvers4//&
                   chvers5//chvers6// ', using '//trim(gas)//' mixing &
                   &ratio of:' // chvers7 //', which is the value at &
                   &the current time.', NOTE)
                endif
              endif

!---------------------------------------------------------------------
!    set the flag to indicate that the initial tf calculation has been 
!    completed.
!---------------------------------------------------------------------
              month_of_gas_tf_calc = month
            endif
          endif ! (do_gas_tf_calc_init)
        endif ! (.not. calc_gas_tfs_on_first_step)

!---------------------------------------------------------------------
!    set the flag to indicate that the tf calculation has been 
!    completed on the current timestep.
!---------------------------------------------------------------------
        do_gas_tf_calc = .false.

!---------------------------------------------------------------------
!    if the time variation of the gas has not yet begun, and it is the 
!    initial call of the job, call the appropriate subroutines to
!    define the transmission functions.
!---------------------------------------------------------------------
      else ! (Rad_time >= Gas_time)
        if (do_gas_tf_calc_init) then
          if (trim(gas) == 'ch4') then
            call ch4_time_vary (gas_for_last_tf_calc)
            write (chvers7, '(4pe15.7)') gas_for_last_tf_calc
          else if (trim(gas) == 'n2o') then
            call n2o_time_vary (gas_for_last_tf_calc)
            write (chvers7, '(3pe15.7)') gas_for_last_tf_calc
          else if (trim(gas) == 'co2') then
            call co2_time_vary (gas_for_last_tf_calc)
            write (chvers7, '(3pe15.7)') gas_for_last_tf_calc
          endif

!---------------------------------------------------------------------
!    set the flag to indicate that the initial tf calculation has been 
!    completed.
!---------------------------------------------------------------------
          do_gas_tf_calc_init = .false.

!---------------------------------------------------------------------
!    if a record of the tf calculation path is desired, print out the
!    relevant data.
!---------------------------------------------------------------------
          if (verbose >= 1) then
            write (chvers10, '( f9.3)') gas_tf_offset    
            if (gas_tf_offset /= 0.0) then
              call error_mesg ('sealw99_mod',  &
                 'initial '//trim(gas)//' transmission function  &
                 &calculation uses '//trim(gas)//' mixing ratio of:'  &
                 // chvers7 //', which is the value '//chvers10//  &
                 'hours from current time.', NOTE)
            else
              call error_mesg ('sealw99_mod',  &
                 'initial '//trim(gas)//' transmission function   &
                 &calculation uses '//trim(gas)//' mixing ratio of:'  &
                 // chvers7 //', which is the value at the current  &
                                                        &time.', NOTE)
            endif
          endif
        endif ! (do_gas_tf_calc_init)
      endif   ! (Rad_time >= Gas_time) 

!--------------------------------------------------------------------


end subroutine obtain_gas_tfs 




                                  
!#####################################################################
! <SUBROUTINE NAME="sealw99_alloc">
!  <OVERVIEW>
!   Subroutine to allocate variables needed for longwave diagnostics
!  </OVERVIEW>
!  <TEMPLATE>
!   call sealw99_alloc (ix, jx, kx, Lw_diagnostics)  
!  </TEMPLATE>
!  <IN NAME="ix" TYPE="integer">
!   Dimension 1 length of radiation arrays to be allocated
!  </IN>
!  <IN NAME="jx" TYPE="integer">
!   Dimension 2 length of radiation arrays to be allocated
!  </IN>
!  <IN NAME="kx" TYPE="integer">
!   Dimension 3 length of radiation arrays to be allocated
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_output_type">
!   lw_diagnostics_type variable containing longwave 
!                   radiation output data
!  </INOUT>
! </SUBROUTINE>
!
subroutine sealw99_alloc (ix, jx, kx, Lw_diagnostics)

!--------------------------------------------------------------------
!    sealw99_alloc allocates and initializes the components of the 
!    lw_diagnostics_type variable Lw_diagnostics which holds diagnostic
!    output generated by sealw99_mod.  
!--------------------------------------------------------------------

integer,                   intent(in)    :: ix, jx, kx
type(lw_diagnostics_type), intent(inout) :: Lw_diagnostics

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      ix,jx,kx     (i,j,k) lengths of radiation arrays to be allocated
!
!
!   intent(inout) variables:
!
!      Lw_diagnostics
!                   lw_diagnostics_type variable containing diagnostic
!                   longwave output used by the radiation diagnostics
!                   module
!  
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer ::  NBTRGE, NBLY
    
!---------------------------------------------------------------------
!    allocate (and initialize where necessary) lw_diagnostics_type 
!    component arrays.
!---------------------------------------------------------------------
      NBTRGE = Lw_parameters%NBTRGE
      NBLY   = Lw_parameters%NBLY

      allocate ( Lw_diagnostics%flx1e1   (ix, jx                ) )
      allocate ( Lw_diagnostics%fluxn    (ix, jx, kx+1, 6+NBTRGE) )
      allocate (Lw_diagnostics%cts_out   (ix, jx, kx,   6       ) )
      allocate (Lw_diagnostics%cts_outcf (ix, jx, kx,   6       ) )
      allocate (Lw_diagnostics%gxcts     (ix, jx                ) )
      allocate (Lw_diagnostics%excts     (ix, jx, kx            ) )
      allocate (Lw_diagnostics%exctsn    (ix, jx, kx,   NBLY    ) )
      allocate (Lw_diagnostics%fctsg     (ix, jx,       NBLY    ) )

      Lw_diagnostics%flx1e1   = 0.
      Lw_diagnostics%cts_out    = 0.
      Lw_diagnostics%cts_outcf = 0.
      Lw_diagnostics%gxcts    = 0.
      Lw_diagnostics%excts  = 0.
      Lw_diagnostics%exctsn   = 0.
      Lw_diagnostics%fctsg   = 0.

      Lw_diagnostics%fluxn  (:,:,:,:) = 0.0

      if (Rad_control%do_totcld_forcing) then
        allocate ( Lw_diagnostics%fluxncf (ix, jx, kx+1, 6+NBTRGE) )
        Lw_diagnostics%fluxncf(:,:,:,:) = 0.0
      endif

        allocate( Lw_diagnostics%flx1e1f  (ix, jx,       NBTRGE  ) )
         Lw_diagnostics%flx1e1f  = 0.

!--------------------------------------------------------------------

end subroutine sealw99_alloc



!####################################################################
! <SUBROUTINE NAME="cool_to_space_approx">
!  <OVERVIEW>
!   Subroutine the calculate the cool to space approximation longwave
!   radiation.
!  </OVERVIEW>
!  <TEMPLATE>
!   call cool_to_space_approx (     pflux_in,        source,  &
!                                 trans,      cld_trans, cld_ind, &
!                                 Lw_diagnostics, &
!                                 trans2      )
!  </TEMPLATE>
!  <IN NAME="pflux_in" TYPE="real">
!   pressure values at flux levels
!  </IN>
!  <IN NAME="source" TYPE="real">
!   band integrated longwave source function of each model layer
!  </IN>
!  <IN NAME="trans" TYPE="real">
!   clear sky longwave transmission
!  </IN>
!  <IN NAME="cld_trans" TYPE="real">
!   cloud transmission
!  </IN>
!  <IN NAME="cld_ind" TYPE="real">
!   cloud type index
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_dignostics_type">
!   longwave diagnostics output
!  </INOUT>
!  <IN NAME="trans2" TYPE="real">
!   optional input alternative transmission profile
!  </IN>
! </SUBROUTINE>
! 
subroutine cool_to_space_approx ( pflux_in, source, trans, cld_trans, &
                                  cld_ind, Lw_diagnostics, trans2      )

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real, dimension (:,:,:),   intent(in)           :: pflux_in
real, dimension (:,:,:,:), intent(in)           :: source, trans, &
                                                   cld_trans
integer, dimension (:),    intent(in)           :: cld_ind
type(lw_diagnostics_type), intent(inout)        :: Lw_diagnostics
real, dimension (:,:,:),   intent(in), optional :: trans2

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     pflux_in
!     source
!     trans
!     cld_trans
!     cld_ind
!     
!  intent(inout) variables:
!
!     Lw_diagnostics
!
!  intent(in),optional:
!     trans2
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

    real, dimension(size(pflux_in,1), size(pflux_in,2), &
                    size(pflux_in,3)-1) :: pdfinv
    integer  ::  i,j,kk
    integer  :: index, nbands

!---------------------------------------------------------------------
!   local variables:
!
!      pdfinv      
!      index
!      nbands
!      j
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
     nbands = size(source,4) - NBTRGE
     do kk = KS,KE
        do j = 1,size(pdfinv(:,:,:),2)
           do i = 1,size(pdfinv(:,:,:),1)
              pdfinv(i,j,kk) = 1.0/(pflux_in(i,j,kk+KS+1-(KS)) - pflux_in(i,j,kk))
           end do
        end do
     end do
!---------------------------------------------------------------------
!
!--------------------------------------------------------------------
     do index=1,nbands
    if (index == 1     ) then
      do kk = KS,KE
         do j = 1,size(Lw_diagnostics%cts_out(:,:,:,:),2)
            do i = 1,size(Lw_diagnostics%cts_out(:,:,:,:),1)
               Lw_diagnostics%cts_out(i,j,kk,index) = (radcon_mks*pdfinv(i,j,kk)*     &
                             source(i,j,kk,index)*  &
                             (trans(i,j,kk,index)*   &
                                cld_trans(i,j,kk+KS+1-(KS), cld_ind(index)) -   &
                             trans2(i,j,kk)*     &
                             cld_trans(i,j,kk, cld_ind(index)))*1.0e-03)
            end do
         end do
      end do
    else
      do kk = KS,KE
         do j = 1,size(Lw_diagnostics%cts_out(:,:,:,:),2)
            do i = 1,size(Lw_diagnostics%cts_out(:,:,:,:),1)
               Lw_diagnostics%cts_out(i,j,kk,index) = (radcon_mks*pdfinv(i,j,kk)*     &
                             source(i,j,kk, index)*  &
                             (trans(i,j,kk+KS+1-(KS),index    )*   &
                             cld_trans(i,j,kk+KS+1-(KS), cld_ind(index)) -   &
                             trans(i,j,kk,index    )*     &
                             cld_trans(i,j,kk, cld_ind(index)))*1.0e-03)
            end do
         end do
      end do
    endif
    if (Rad_control%do_totcld_forcing) then
    if (index == 1     ) then
        do kk = KS,KE
           do j = 1,size(Lw_diagnostics%cts_outcf(:,:,:,:),2)
              do i = 1,size(Lw_diagnostics%cts_outcf(:,:,:,:),1)
                 Lw_diagnostics%cts_outcf(i,j,kk,index) = (radcon_mks*pdfinv(i,j,kk)*     &
                                 source(i,j,kk,index)* &
                                 (trans(i,j,kk,index      ) -     &
                                  trans2(i,j,kk))*1.0e-03)
              end do
           end do
        end do
      else
        do kk = KS,KE
           do j = 1,size(Lw_diagnostics%cts_outcf(:,:,:,:),2)
              do i = 1,size(Lw_diagnostics%cts_outcf(:,:,:,:),1)
                 Lw_diagnostics%cts_outcf(i,j,kk,index) = (radcon_mks*pdfinv(i,j,kk)*     &
                                 source(i,j,kk,index)* &
                                 (trans(i,j,kk+KS+1-(KS), index    ) -     &
                                  trans(i,j,kk, index    ))*1.0e-03)
              end do
           end do
        end do
      endif
    endif
   end do  ! (index loop)

!--------------------------------------------------------------------


end subroutine cool_to_space_approx



!####################################################################
! <SUBROUTINE NAME="cool_space_exact">
!  <OVERVIEW>
!   cool_to_space calculates the cool-to-space cooling rate for 
!   a band n.
!  </OVERVIEW>
!  <TEMPLATE>
!   call  cool_to_space_exact (                cldtf,          &
!                             Atmos_input, Optical, Gas_tf,  &
!                             sorc,        to3cnt, Lw_diagnostics, &
!                             cts_sum, cts_sumcf, &
!                             gxctscf) 
!  </TEMPLATE>
!  <IN NAME="cldtf" TYPE="real">
!   cloud transmission function between levels k level KS.
!  </IN>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input to the cool to space approximation method
!  </IN>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth of atmospheric layers and clouds
!  </INOUT>
!  <INOUT NAME="Gas_tf" TYPE="gas_tf_type">
!   Gas transmission function
!  </INOUT>
!  <IN NAME="sorc" TYPE="real">
!   band-integrated Planck function, for each combined
!   band in the 160-1200 cm-1 region.
!  </IN>
!  <IN NAME="to3cnt" TYPE="real">
!   transmission functions between levels k and
!   level KS for the 990-1070 cm-1 range.
!  </IN>
!  <INOUT NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!   Longwave diagnostics 
!  </INOUT>
!  <INOUT NAME="cts_sum" TYPE="real">
!   Cool to space heating rates
!  </INOUT>
!  <INOUT NAME="cts_sumcf" TYPE="real">
!   Cool to space heating rates due to cloud forcing
!  </INOUT>
!  <INOUT NAME="gxctscf" TYPE="real">
!   gxcts is the "exact" surface flux accumulated over
!   the frequency bands in the 160-1200 cm-1 range.
!  </INOUT>
! </SUBROUTINE>
subroutine cool_to_space_exact (cldtf, Atmos_input, Optical, Gas_tf,  &
                                sorc, to3cnt, Lw_diagnostics, &
                                cts_sum, cts_sumcf, gxctscf,  &
                                including_aerosols)     

!-----------------------------------------------------------------------
!    cool_to_space calculates the cool-to-space cooling rate for 
!    a band n.
!-----------------------------------------------------------------------

real, dimension (:,:,:,:), intent(in)     :: cldtf
type(atmos_input_type),    intent(in)     :: Atmos_input
type(optical_path_type),   intent(inout)  :: Optical
type(gas_tf_type),         intent(inout)  :: Gas_tf 
real, dimension (:,:,:,:), intent(in)     :: sorc
real, dimension (:,:,:),   intent(in)     :: to3cnt
type(lw_diagnostics_type), intent(inout)  :: Lw_diagnostics
real, dimension(:,:,:),    intent(inout)  :: cts_sum, cts_sumcf
real, dimension(:,:),      intent(inout)  :: gxctscf
logical,                   intent(in)  :: including_aerosols   

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     cldtf        cloud transmission function between levels k and 
!                  level KS.
!     Atmos_input
!     sorc          band-integrated Planck function, for each combined
!                   band in the 160-1200 cm-1 region.
!     to3cnt        transmission functions between levels k and
!                   level KS for the 990-1070 cm-1 range.
!
!  intent(inout) variables:
!
!     Optical
!     Gas_tf
!     Lw_diagnostics
!     cts_sum
!     cts_sumcf
!     gxctscf
!
!--------------------------------------------------------------------

!-----------------------------------------------------------------------
!  local variables
!-----------------------------------------------------------------------
      integer        :: i,kk
    real, dimension(size(Atmos_input%pflux,1), &
                    size(Atmos_input%pflux,2), &
                    size(Atmos_input%pflux,3)-1) :: pdfinv, pdfinv2

    real, dimension(size(Atmos_input%pflux,1), &
                    size(Atmos_input%pflux,2), &
                    size(Atmos_input%pflux,3)  ) :: &
                                              dte1, press, temp, pflux

    integer, dimension(size(Atmos_input%pflux,1), &
                       size(Atmos_input%pflux,2), &
                       size(Atmos_input%pflux,3)  ) :: ixoe1 

    real, dimension(size(Atmos_input%pflux,1),   &
                    size(Atmos_input%pflux,2))   ::   &
                                                      pfac1, pfac2

    real, dimension(size(Atmos_input%pflux,1),   &
                    size(Atmos_input%pflux,2),        &
                    size(Atmos_input%pflux,3)) :: &
                              sorc_tmp, ctmp, totch2o_tmp, totaer_tmp

    real, dimension(size(Atmos_input%pflux,1),   &
                    size(Atmos_input%pflux,2),        &
                    2:size(Atmos_input%pflux,3)) :: &
                                                    totvo2_tmp

    real, dimension(size(Atmos_input%pflux,1),   &
                    size(Atmos_input%pflux,2),        &
                    size(Atmos_input%pflux,3)-1) :: &
                                  exctscf, tt, x, y, topm, &
                                  topphi, phitmp, psitmp, ag, &
                                  agg, f, ff, tmp1, tmp2, fac1, &
                                  fac2, cfc_tf

    real, dimension(size(Atmos_input%pflux,1),   &
                    size(Atmos_input%pflux,2),        &
                    size(Atmos_input%pflux,3)-1, NBLY) :: &
                            exctsncf

    real, dimension(size(Atmos_input%pflux,1),   &
                    size(Atmos_input%pflux,2),        &
                                                 NBLY) :: &
                                fctsgcf
      integer        :: n, k, j, ioffset

!-----------------------------------------------------------------------
!  local variables
!
!     pdfinv      inverse of pressure difference between flux levels.
!     pdfinv2
!     dte1
!     press       pressure at data levels of model.
!     temp        temperature at data levels of model.
!     pflux       pressure at flux levels of model.
!     ixoe1
!     pfac1
!     pfac2
!     sorc_tmp
!     ctmp
!     totch2o_tmp
!     totaer_tmp
!     totvo2_tmp
!     exctscf
!     tt
!     x
!     y
!     topm
!     topphi
!     phitmp
!     psitmp
!     ag
!     agg
!     f 
!     ff
!     tmp1
!     tmp2
!     fac1
!     fac2
!     cfc_tf
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  convert press and pflux to cgs.
        do kk = 1,size(press(:,:,:),3)
           do j = 1,size(press(:,:,:),2)
              do i = 1,size(press(:,:,:),1)
                 press(i,j,kk) = 10.0*Atmos_input%press(i,j,kk)
              end do
           end do
        end do
       do kk = 1,size(pflux(:,:,:),3)
          do j = 1,size(pflux(:,:,:),2)
             do i = 1,size(pflux(:,:,:),1)
                pflux(i,j,kk) = 10.0*Atmos_input%pflux(i,j,kk)
             end do
          end do
       end do
      do kk = 1,size(temp(:,:,:),3)
         do j = 1,size(temp(:,:,:),2)
            do i = 1,size(temp(:,:,:),1)
               temp(i,j,kk) = Atmos_input%temp(i,j,kk)
            end do
         end do
      end do

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------


      do kk = KS,KE
         do j = 1,size(pdfinv2(:,:,:),2)
            do i = 1,size(pdfinv2(:,:,:),1)
               pdfinv2(i,j,kk) = 1.0/(pflux(i,j,kk+KS+1-(KS)) - pflux(i,j,kk))
            end do
         end do
      end do
     do kk = KS,KE
        do j = 1,size(pdfinv(:,:,:),2)
           do i = 1,size(pdfinv(:,:,:),1)
              pdfinv(i,j,kk) = 1.0/(Atmos_input%pflux(i,j,kk+KS+1-(KS)) -   &
                               Atmos_input%pflux(i,j,kk))
           end do
        end do
     end do
!----------------------------------------------------------------------
      ioffset = Lw_parameters%offset

!-----------------------------------------------------------------------
!     initialize quantities.
!-----------------------------------------------------------------------
      do kk = KS,KE
         do j = 1,size(Lw_diagnostics%excts(:,:,:),2)
            do i = 1,size(Lw_diagnostics%excts(:,:,:),1)
               Lw_diagnostics%excts(i,j,kk) = 0.0E+00
            end do
         end do
      end do
      do j = 1,size(Lw_diagnostics%gxcts(:,:),2)
         do i = 1,size(Lw_diagnostics%gxcts(:,:),1)
            Lw_diagnostics%gxcts(i,j) = 0.0E+00
         end do
      end do

      if (Rad_control%do_totcld_forcing) then
        do kk = KS,KE
           do j = 1,size(exctscf(:,:,:),2)
              do i = 1,size(exctscf(:,:,:),1)
                 exctscf(i,j,kk) = 0.0E+00
              end do
           end do
        end do
        do j = 1,size(gxctscf(:,:),2)
           do i = 1,size(gxctscf(:,:),1)
              gxctscf(i,j) = 0.0E+00
           end do
        end do
      endif

!-----------------------------------------------------------------------
!     compute temperature quantities.
!-----------------------------------------------------------------------
      do kk = KS,KE
         do j = 1,size(x(:,:,:),2)
            do i = 1,size(x(:,:,:),1)
               x(i,j,kk) = temp(i,j,kk) - 2.5E+02
            end do
         end do
      end do
      do kk = KS,KE
         do j = 1,size(y(:,:,:),2)
            do i = 1,size(y(:,:,:),1)
               y(i,j,kk) = x(i,j,kk)*x(i,j,kk)
            end do
         end do
      end do
      do j = 1,size(ctmp(:,:,:),2)
         do i = 1,size(ctmp(:,:,:),1)
            ctmp(i,j,KS) = 1.0E+00
         end do
      end do


!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
       call locate_in_table(temp_1, temp, dte1, ixoe1, KS, KE+1)

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------

      do j = 1,size(Lw_diagnostics%fctsg(:,:,:),2)
         do i = 1,size(Lw_diagnostics%fctsg(:,:,:),1)
            Lw_diagnostics%fctsg(i,j,NBLY) = 0.0
         end do
      end do
      do n=1,NBLY-1
!-----------------------------------------------------------------------
!     obtain temperature correction capphi, cappsi, then multiply
!     by optical path var1, var2 to compute temperature-corrected
!     optical path and mean pressure for a layer: phitmp, psitmp.
!-----------------------------------------------------------------------
        do kk = KS,KE
           do j = 1,size(f(:,:,:),2)
              do i = 1,size(f(:,:,:),1)
                 f(i,j,kk) = 0.44194E-01*(apcm (n)*x(i,j,kk) +  &
                            bpcm (n)*y(i,j,kk)) 
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(ff(:,:,:),2)
              do i = 1,size(ff(:,:,:),1)
                 ff(i,j,kk) = 0.44194E-01*(atpcm(n)*x(i,j,kk) +   &
                            btpcm(n)*y(i,j,kk))
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(ag(:,:,:),2)
              do i = 1,size(ag(:,:,:),1)
                 ag(i,j,kk) = (1.418191E+00 + f (i,j,kk))*   &
                            f (i,j,kk) + 1.0E+00
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(agg(:,:,:),2)
              do i = 1,size(agg(:,:,:),1)
                 agg(i,j,kk) = (1.418191E+00 + ff(i,j,kk))*   &
                            ff(i,j,kk) + 1.0E+00 
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(phitmp(:,:,:),2)
              do i = 1,size(phitmp(:,:,:),1)
                 phitmp(i,j,kk) = Optical%var1(i,j,kk)*     &
                            ((((ag (i,j,kk)*        &
                            ag (i,j,kk))**2)**2)**2)
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(psitmp(:,:,:),2)
              do i = 1,size(psitmp(:,:,:),1)
                 psitmp(i,j,kk) = Optical%var2(i,j,kk)*     &
                            ((((agg(i,j,kk)*       &
                            agg(i,j,kk))**2)**2)**2)
              end do
           end do
        end do

!-----------------------------------------------------------------------
!     obtain optical path and mean pressure from the top of the 
!     atmosphere to the level k.
!-----------------------------------------------------------------------
        do j = 1,size(topm(:,:,:),2)
           do i = 1,size(topm(:,:,:),1)
              topm(i,j,KS) = phitmp(i,j,KS) 
           end do
        end do
        do j = 1,size(topphi(:,:,:),2)
           do i = 1,size(topphi(:,:,:),1)
              topphi(i,j,KS) = psitmp(i,j,KS) 
           end do
        end do
        do k=KS+1,KE
          do j = 1,size(topm(:,:,:),2)
             do i = 1,size(topm(:,:,:),1)
                topm(i,j,k) = topm  (i,j,k-1) + phitmp(i,j,k) 
             end do
          end do
          do j = 1,size(topphi(:,:,:),2)
             do i = 1,size(topphi(:,:,:),1)
                topphi(i,j,k) = topphi(i,j,k-1) + psitmp(i,j,k) 
             end do
          end do
        enddo

!-----------------------------------------------------------------------
!     tt is the cloud-free h2o cool-to-space transmission function.
!-----------------------------------------------------------------------

      if (Lw_control%do_h2o) then
        do kk = KS,KE
           do j = 1,size(fac1(:,:,:),2)
              do i = 1,size(fac1(:,:,:),1)
                 fac1(i,j,kk) = acomb(n)*topm(i,j,kk)
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(fac2(:,:,:),2)
              do i = 1,size(fac2(:,:,:),1)
                 fac2(i,j,kk) = fac1(i,j,kk)*topm(i,j,kk)/   &
                              (bcomb(n)*topphi(i,j,kk))
              end do
           end do
        end do
        do kk = KS,KE
           do j = 1,size(tmp1(:,:,:),2)
              do i = 1,size(tmp1(:,:,:),1)
                 tmp1(i,j,kk) = fac1(i,j,kk)/SQRT(1.0E+00 +     &
                          fac2(i,j,kk))
              end do
           end do
        end do

      else
        do kk = KS,KE
          do j = 1,size(tmp1(:,:,:),2)
            do i = 1,size(tmp1(:,:,:),1)
              tmp1(i,j,kk) = 0.0
            end do
          end do
        end do
      endif
        


!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
        if (n >= band_no_start(1) .and. n <= band_no_end(1)) then
!                       160-400 cm-1 region (h2o)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! bands 1-24.
            call get_totch2o (n, Optical, totch2o_tmp, dte1, ixoe1)
            do kk = KS,KE
               do j = 1,size(tt(:,:,:),2)
                  do i = 1,size(tt(:,:,:),1)
                     tt(i,j,kk) = EXP(-1.0*(tmp1(i,j,kk) + diffac*   &
                            totch2o_tmp(i,j,kk+KS+1-(KS))))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! bands 1-4.
            do kk = KS,KE
               do j = 1,size(tt(:,:,:),2)
                  do i = 1,size(tt(:,:,:),1)
                     tt(i,j,kk) = EXP(-1.0*tmp1(i,j,kk)) 
                  end do
               end do
            end do
          endif

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(2) .and. n <= band_no_end(2)) then
!                       400-560 cm-1 region (h2o)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! bands 25-40.
            call get_totch2o (n, Optical, totch2o_tmp, dte1, ixoe1)
            do kk = KS,KE
               do j = 1,size(tt(:,:,:),2)
                  do i = 1,size(tt(:,:,:),1)
                     tt(i,j,kk) = EXP(-1.0*(tmp1(i,j,kk) + diffac*   &
                            totch2o_tmp(i,j,kk+KS+1-(KS))))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! bands 5-8.
            call get_totvo2 (n, Optical, totvo2_tmp)
            do kk = KS,KE
               do j = 1,size(tt(:,:,:),2)
                  do i = 1,size(tt(:,:,:),1)
                     tt(i,j,kk) = EXP(-1.0*(tmp1(i,j,kk) +  &
                                totvo2_tmp(i,j,kk+KS+1-(KS)))) 
                  end do
               end do
            end do
          endif

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(3) .and. n <= band_no_end(3)) then
!                       560-630 cm-1 region (h2o, co2, n2o, aerosol)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! band 41.
            call get_totch2obd (n-40, Optical, totch2o_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) + diffac*     &
                            totch2o_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! band 9
            call get_totvo2 (n, Optical, totvo2_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) +               &
                                totvo2_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          if (including_aerosols) then                    
            do kk = 1,size(totaer_tmp(:,:,:),3)
               do j = 1,size(totaer_tmp(:,:,:),2)
                  do i = 1,size(totaer_tmp(:,:,:),1)
                     totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,1)
                  end do
               end do
            end do
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp2(i,j,kk) +        &
                            totaer_tmp  (i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = EXP(-1.0E+00*tmp2(i,j,kk))*    &
                                (Gas_tf%co2spnb(i,j,kk+KS+1-(KS),1)* &
                                Gas_tf%tn2o17(i,j,kk+KS+1-(KS)))
                end do
             end do
          end do

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(4) .and. n <= band_no_end(4)) then
!                       630-700 cm-1 region (h2o, co2, aerosol)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! band 42.
            call get_totch2obd (n-40, Optical, totch2o_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) + diffac*     &
                            totch2o_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! band 10
            call get_totvo2 (n, Optical, totvo2_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) +               &
                                totvo2_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          if (including_aerosols) then      
            do kk = 1,size(totaer_tmp(:,:,:),3)
               do j = 1,size(totaer_tmp(:,:,:),2)
                  do i = 1,size(totaer_tmp(:,:,:),1)
                     totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,2)
                  end do
               end do
            end do
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp2(i,j,kk) +          &
                            totaer_tmp   (i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = EXP(-1.0E+00*tmp2(i,j,kk))*     &
                                Gas_tf%co2spnb(i,j,kk+KS+1-(KS),2)
                end do
             end do
          end do

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(5) .and. n <= band_no_end(5)) then
!                       700-800 cm-1 region (h2o, co2, aerosol)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! band 43.
            call get_totch2obd (n-40, Optical, totch2o_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) + diffac*      &
                            totch2o_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! band 11
            call get_totvo2 (n, Optical, totvo2_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) +                &
                                totvo2_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          if (including_aerosols) then           
            do kk = 1,size(totaer_tmp(:,:,:),3)
               do j = 1,size(totaer_tmp(:,:,:),2)
                  do i = 1,size(totaer_tmp(:,:,:),1)
                     totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,3)
                  end do
               end do
            end do
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp2(i,j,kk) +       &
                            totaer_tmp   (i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = EXP(-1.0E+00*tmp2(i,j,kk))*     &
                                Gas_tf%co2spnb(i,j,kk+KS+1-(KS),3)
                end do
             end do
          end do

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(6) .and. n <= band_no_end(6)) then
!                       800-990 cm-1 region (h2o, aerosol)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! bands 44-45.
            call get_totch2obd (n-40, Optical, totch2o_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) + diffac*    &
                            totch2o_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! bands 12-13
            call get_totvo2 (n, Optical, totvo2_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) +               &
                                totvo2_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          if (including_aerosols) then    
            do kk = 1,size(totaer_tmp(:,:,:),3)
               do j = 1,size(totaer_tmp(:,:,:),2)
                  do i = 1,size(totaer_tmp(:,:,:),1)
                     totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,n-8-ioffset)
                  end do
               end do
            end do
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp2(i,j,kk) +         &
                            totaer_tmp   (i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = EXP(-1.0E+00*tmp2(i,j,kk))
                end do
             end do
          end do

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(7) .and. n <= band_no_end(7)) then
!                       990-1070 cm-1 region (h2o(lines), o3)
!                       band 46 (ckd2.1) or 14 (rsb)

          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = EXP(-1.0E+00*tmp1(i,j,kk))*      &
                               to3cnt (i,j,kk+KS+1-(KS))
                end do
             end do
          end do

!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
else if (n >= band_no_start(8) .and. n <= band_no_end(8)) then
!                       1070-1200 cm-1 region (h2o, n2o)
  if (trim(Lw_control%continuum_form) == 'ckd2.1' .or.     &
      trim(Lw_control%continuum_form) == 'ckd2.4' ) then 
! band 47.
            call get_totch2obd (n-40, Optical, totch2o_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) + diffac*    &
                            totch2o_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
  else if (trim(Lw_control%continuum_form) == 'rsb' ) then 
! band 15
            call get_totvo2 (n, Optical, totvo2_tmp)
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp1(i,j,kk) +              &
                                totvo2_tmp(i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          if (including_aerosols) then      
            do kk = 1,size(totaer_tmp(:,:,:),3)
               do j = 1,size(totaer_tmp(:,:,:),2)
                  do i = 1,size(totaer_tmp(:,:,:),1)
                     totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,7)
                  end do
               end do
            end do
            do kk = KS,KE
               do j = 1,size(tmp2(:,:,:),2)
                  do i = 1,size(tmp2(:,:,:),1)
                     tmp2(i,j,kk) = tmp2(i,j,kk)    +                &
                            totaer_tmp   (i,j,kk+KS+1-(KS))
                  end do
               end do
            end do
          endif
          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = EXP(-1.0E+00*tmp2(i,j,kk))*   &
                                Gas_tf%n2o9c  (i,j,kk+KS+1-(KS))
                end do
             end do
          end do

        endif
!--------------------------------------------------------------------
!     calculate or retrieve the source function for the current band.
!--------------------------------------------------------------------
        if (n <= 8 + ioffset) then
          call looktab (tabsr, ixoe1, dte1, sorc_tmp, KS, KE+1, n)
        else
         do kk = 1,size(sorc_tmp(:,:,:),3)
            do j = 1,size(sorc_tmp(:,:,:),2)
               do i = 1,size(sorc_tmp(:,:,:),1)
                  sorc_tmp(i,j,kk) = sorc(i,j,kk,n-8-ioffset)
               end do
            end do
         end do
        endif

!---------------------------------------------------------------------
!     retrieve the cfc effect if cfcs are activated.
!---------------------------------------------------------------------
        if (Lw_control%do_cfc .and. n >= 9+ioffset) then
          call cfc_exact(n-8-ioffset, Optical, cfc_tf)
          do kk = KS,KE
             do j = 1,size(tt(:,:,:),2)
                do i = 1,size(tt(:,:,:),1)
                   tt(i,j,kk) = tt(i,j,kk)*cfc_tf(i,j,kk)
                end do
             end do
          end do
        endif

!------------------------------------------------------------------
!     define some near-surface pressure functions that are needed
!------------------------------------------------------------------
        do j = 1,size(pfac1(:,:),2)
           do i = 1,size(pfac1(:,:),1)
              pfac1(i,j) = 0.5*pdfinv2(i,j,KE)*(pflux(i,j,KE+1) - &
                     press(i,j,KE))*tt(i,j,KE-1)
           end do
        end do
        do j = 1,size(pfac2(:,:),2)
           do i = 1,size(pfac2(:,:),1)
              pfac2(i,j) = 0.5*pdfinv2(i,j,KE)*(pflux(i,j,KE+1) +    &
                     press(i,j,KE) - 2.0*pflux(i,j,KE))*tt(i,j,KE)
           end do
        end do

!--------------------------------------------------------------------
!     calculate the ground fluxes (?)
!--------------------------------------------------------------------
        if (Rad_control%do_totcld_forcing) then
          do j = 1,size(fctsgcf(:,:,:),2)
             do i = 1,size(fctsgcf(:,:,:),1)
                fctsgcf(i,j,n) = tt(i,j,KE)*sorc_tmp(i,j,KE) +   &
                           (pfac1(i,j) + pfac2(i,j))*   &
                           (sorc_tmp(i,j,KE+1) - sorc_tmp(i,j,KE))
             end do
          end do
    do j = 1,size(Lw_diagnostics%fctsg(:,:,:),2)
       do i = 1,size(Lw_diagnostics%fctsg(:,:,:),1)
          Lw_diagnostics%fctsg(i,j,n) = cldtf(i,j,KE+1,cld_indx_table(n+32-ioffset))* &
                         fctsgcf(i,j,n)
       end do
    end do
          do j = 1,size(gxctscf(:,:),2)
             do i = 1,size(gxctscf(:,:),1)
                gxctscf(i,j) = gxctscf(i,j) + fctsgcf(i,j,n)
             end do
          end do
          do j = 1,size(Lw_diagnostics%gxcts(:,:),2)
             do i = 1,size(Lw_diagnostics%gxcts(:,:),1)
                Lw_diagnostics%gxcts(i,j) = Lw_diagnostics%gxcts(i,j) +   &
                      Lw_diagnostics%fctsg(i,j,n)
             end do
          end do
        else
do j = 1,size(Lw_diagnostics%fctsg(:,:,:),2)
   do i = 1,size(Lw_diagnostics%fctsg(:,:,:),1)
      Lw_diagnostics%fctsg(i,j,n) = cldtf(i,j,KE+1,cld_indx_table(n+32-ioffset))* &
                         (tt(i,j,KE)*sorc_tmp(i,j,KE) +  &
                         (pfac1(i,j) + pfac2(i,j))*   &
                         (sorc_tmp(i,j,KE+1) - sorc_tmp(i,j,KE)))
   end do
end do
          do j = 1,size(Lw_diagnostics%gxcts(:,:),2)
             do i = 1,size(Lw_diagnostics%gxcts(:,:),1)
                Lw_diagnostics%gxcts(i,j) = Lw_diagnostics%gxcts(i,j) +   &
          Lw_diagnostics%fctsg(i,j,n)
             end do
          end do
        endif
        do j = 1,size(Lw_diagnostics%fctsg(:,:,:),2)
           do i = 1,size(Lw_diagnostics%fctsg(:,:,:),1)
              Lw_diagnostics%fctsg(i,j,n) = 1.0e-03*   &
                                      Lw_diagnostics%fctsg(i,j,n)
           end do
        end do

!--------------------------------------------------------------------
!    include the effect of the cloud transmission function.
!--------------------------------------------------------------------
        do kk = KS+1,KE+1
           do j = 1,size(ctmp(:,:,:),2)
              do i = 1,size(ctmp(:,:,:),1)
                 ctmp(i,j,kk) = tt(i,j,kk+KS-(KS+1))*        &
                      cldtf(i,j,kk,cld_indx_table(n+32-ioffset)) 
              end do
           end do
        end do

!---------------------------------------------------------------------
!    if diagnostics is on, save each band's contribution separately.
!    exctsn is the cool-to-space heating rate for each frequency
!    band. fctsg is the "exact" surface flux for each frequency
!    band in the 160-1200 cm-1 range.
!---------------------------------------------------------------------
!! the following array only needed when diagnostics on
          do kk = KS,KE
             do j = 1,size(Lw_diagnostics%exctsn(:,:,:,:),2)
                do i = 1,size(Lw_diagnostics%exctsn(:,:,:,:),1)
                   Lw_diagnostics%exctsn(i,j,kk,n) = sorc_tmp(i,j,kk)*     &
                                (ctmp(i,j,kk+KS+1-(KS)) - ctmp(i,j,kk))
                end do
             end do
          end do
          if (Rad_control%do_totcld_forcing) then
            do j = 1,size(exctsncf(:,:,:,:),2)
               do i = 1,size(exctsncf(:,:,:,:),1)
                  exctsncf(i,j,KS,n) = sorc_tmp(i,j,KS)*         &
                                  (tt(i,j,KS) - 1.0E+00)
               end do
            end do
            do kk = KS+1,KE
               do j = 1,size(exctsncf(:,:,:,:),2)
                  do i = 1,size(exctsncf(:,:,:,:),1)
                     exctsncf(i,j,kk,n) = sorc_tmp(i,j,kk)*     &
                                     (tt(i,j,kk) - tt(i,j,kk+KS-(KS+1)))
                  end do
               end do
            end do
          endif

!-----------------------------------------------------------------------
!     excts is the cool-to-space cooling rate accumulated over
!     frequency bands.
!-----------------------------------------------------------------------
        do kk = KS,KE
           do j = 1,size(Lw_diagnostics%excts(:,:,:),2)
              do i = 1,size(Lw_diagnostics%excts(:,:,:),1)
                 Lw_diagnostics%excts(i,j,kk) = &
               Lw_diagnostics%excts(i,j,kk) +   &
               Lw_diagnostics%exctsn(i,j,kk,n)  
              end do
           end do
        end do
        if (Rad_control%do_totcld_forcing) then
          do j = 1,size(exctscf(:,:,:),2)
             do i = 1,size(exctscf(:,:,:),1)
                exctscf(i,j,KS) = exctscf(i,j,KS) +     &
                             exctsncf(i,j,KS,n)
             end do
          end do
          do kk = KS+1,KE
             do j = 1,size(exctscf(:,:,:),2)
                do i = 1,size(exctscf(:,:,:),1)
                   exctscf(i,j,kk) = exctscf(i,j,kk) +     &
                             exctsncf(i,j,kk,n)
                end do
             end do
          end do
        endif
      end do

!-----------------------------------------------------------------------
!     gxcts is the "exact" surface flux accumulated over
!     the frequency bands in the 160-1200 cm-1 range.
!     obtain cool-to-space flux at the top by integration of heating
!     rates and using cool-to-space flux at the bottom (current value 
!     of gxcts).  note that the pressure quantities and conversion
!     factors have not been included either in excts or in gxcts.
!     these cancel out, thus reducing computations.
!-----------------------------------------------------------------------
      do k=KS,KE
        do j = 1,size(Lw_diagnostics%gxcts(:,:),2)
           do i = 1,size(Lw_diagnostics%gxcts(:,:),1)
              Lw_diagnostics%gxcts(i,j) = Lw_diagnostics%gxcts(i,j) - Lw_diagnostics%excts(i,j,k)
           end do
        end do
      enddo
      if (Rad_control%do_totcld_forcing) then
        do k=KS,KE
          do j = 1,size(gxctscf(:,:),2)
             do i = 1,size(gxctscf(:,:),1)
                gxctscf(i,j) = gxctscf(i,j) - exctscf(i,j,k)
             end do
          end do
        enddo  
      endif

!-----------------------------------------------------------------------
!     now scale the cooling rate excts by including the pressure 
!     factor pdfinv and the conversion factor radcon.
!-----------------------------------------------------------------------
!! the following array only needed when diagnostics on
        do n=1,NBLY-1
          do kk = KS,KE
             do j = 1,size(Lw_diagnostics%exctsn(:,:,:,:),2)
                do i = 1,size(Lw_diagnostics%exctsn(:,:,:,:),1)
                   Lw_diagnostics%exctsn(i,j,kk,n) = 1.0e-03*(Lw_diagnostics%exctsn(i,j,kk,n)*radcon_mks*     &
                                pdfinv(i,j,kk))
                end do
             end do
          end do
        enddo
        if (Rad_control%do_totcld_forcing) then
          do n=1,NBLY-1
            do kk = KS,KE
               do j = 1,size(exctsncf(:,:,:,:),2)
                  do i = 1,size(exctsncf(:,:,:,:),1)
                     exctsncf(i,j,kk,n) = 1.0e-03*(exctsncf(i,j,kk,n)*radcon_mks*    &
                                    pdfinv(i,j,kk) )
                  end do
               end do
            end do
          enddo
        endif

      do kk = KS,KE
         do j = 1,size(Lw_diagnostics%excts(:,:,:),2)
            do i = 1,size(Lw_diagnostics%excts(:,:,:),1)
               Lw_diagnostics%excts(i,j,kk) = (Lw_diagnostics%excts(i,j,kk)*radcon_mks*pdfinv(i,j,kk))*1.0e-03
            end do
         end do
      end do

      if (Rad_control%do_totcld_forcing) then
        do kk = KS,KE
           do j = 1,size(exctscf(:,:,:),2)
              do i = 1,size(exctscf(:,:,:),1)
                 exctscf(i,j,kk) = (exctscf(i,j,kk)*radcon_mks*pdfinv(i,j,kk))*1.0e-03
              end do
           end do
        end do
      endif

!--------------------------------------------------------------------
!    save the heating rates to be later sent to longwave_driver_mod.
!--------------------------------------------------------------------
      do kk = 1,size(cts_sum(:,:,:),3)
         do j = 1,size(cts_sum(:,:,:),2)
            do i = 1,size(cts_sum(:,:,:),1)
               cts_sum(i,j,kk) = Lw_diagnostics%excts(i,j,kk)
            end do
         end do
      end do
      do kk = 1,size(cts_sumcf(:,:,:),3)
         do j = 1,size(cts_sumcf(:,:,:),2)
            do i = 1,size(cts_sumcf(:,:,:),1)
               cts_sumcf(i,j,kk) = exctscf(i,j,kk)
            end do
         end do
      end do


!--------------------------------------------------------------------


end  subroutine cool_to_space_exact




!####################################################################
! <SUBROUTINE NAME="e1e290">
!  <OVERVIEW>
!   Subroutine to compute thermal exchange terms and emissivities used
!   to obtain the cool-to-space heating rates for all pressure layers.
!  </OVERVIEW>
!  <DESCRIPTION>
!   !     E1e290 computes two different quantities.
!     
!     1) emissivities used to compute the exchange terms for flux at the
!     top of the atmosphere (level KS). (the top layer, isothermal by
!     assumption, does not contribute to photon exchanges with other
!     layers). these terms are obtained using precomputed e2 functions
!     (see ref. (2)).
!
!     2) emissivities used to obtain the cool-to-space heating rates
!     for all pressure layers. these are obtained using precomputed
!     e1 functions (see ref. (2)).
!
!     the frequency ranges for the e2 calculations are 0-560 and 1200-
!     2200 cm-1. the CTS calculations also require calculations in the
!     160-560 cm-1 range. (see refs. (1) and (2)).
!ifdef ch4n2o
!
!     if ch4 and n2o are included, the frequency range for emissivities
!     is 1400-2200 cm-1, with separate emissivity quantities for the
!     1200-1400 cm-1 range.
!endif ch4n2o
!
!     the reason for combining these calculations is that both use
!     the same scaled h2o amount (avephi) as input, thus reducing
!     some calculation time for obtaining index quantities.
!   
!     references:
!
!     (1) schwarzkopf, m. d., and s. b. fels, "the simplified
!         exchange method revisited: an accurate, rapid method for
!         computation of infrared cooling rates and fluxes," journal
!         of geophysical research, 96 (1981), 9075-9096.
!
!     (2) fels, s. b., and m. d. schwarzkopf, "the simplified exchange
!         approximation: a new method for radiative transfer
!         calculations," journal atmospheric science, 32 (1975),
!         1475-1488.
!
!     author: m. d. schwarzkopf
!
!     revised: 1/1/93
!
!     certified:  radiation version 1.0
!   </DESCRIPTION>
!   <TEMPLATE>
!    call e1e290 (Atmos_input,                 e1ctw1, e1ctw2,   &
!                 trans_band1, trans_band2, Optical, tch4n2oe, &
!                 t4, Lw_diagnostics, cldtf, cld_indx, flx1e1cf, &
!                 tcfc8)
!   </TEMPLATE>
!   <IN NAME="Atmos_input" TYPE="atmos_input_type">
!    Atmospheric input data to the thermal exchange method
!   </IN>
!   <OUT NAME="e1ctw1" TYPE="real">
!    Cool to space thermal exchange terms in 0-560 band
!   </OUT>
!   <OUT NAME="e1ctw2" TYPE="real">
!    Cool to space thermal exchange terms in 1200-2200  band
!   </OUT>
!   <OUT NAME="trans_band1" TYPE="real">
!    transmission functions in band 1
!   </OUT>
!   <OUT NAME="trans_band2" TYPE="real">
!    transmission function in band 2
!   </OUT>
!   <INOUT NAME="Optical" TYPE="optical_path_type">
!    thermal layer optical path 
!   </INOUT>
!   <IN NAME="tch4n2oe" TYPE="real">
!    CH4 and N2O transmission functions
!   </IN>
!   <IN NAME="t4" TYPE="real">
!    source function of the top most layer
!   </IN>
!   <IN NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!    longwave diagnostics variable
!   </IN>
!   <IN NAME="cld_tf" TYPE="real">
!    Cloud transmission function
!   </IN>
!   <IN NAME="cld_indx" TYPE="real">
!    Cloud type index
!   </IN>
!   <OUT NAME="flx1e1cf" TYPE="real">
!    TOA flux due to cloud forcing
!   </OUT>
!   <INOUT NAME="tcfc8" TYPE="real">
!    CFC transmission function (chloroflurocarbons)
!   </INOUT>
! </SUBROUTINE>
!
subroutine e1e290 (Atmos_input, e1ctw1, e1ctw2, trans_band1, &
                   trans_band2, Optical, tch4n2oe, t4, Lw_diagnostics, &
                   cldtf, cld_indx, flx1e1cf, tcfc8, including_aerosols) 

!-----------------------------------------------------------------------
!
!     E1e290 computes two different quantities.
!     
!     1) emissivities used to compute the exchange terms for flux at the
!     top of the atmosphere (level KS). (the top layer, isothermal by
!     assumption, does not contribute to photon exchanges with other
!     layers). these terms are obtained using precomputed e2 functions
!     (see ref. (2)).
!
!     2) emissivities used to obtain the cool-to-space heating rates
!     for all pressure layers. these are obtained using precomputed
!     e1 functions (see ref. (2)).
!
!     the frequency ranges for the e2 calculations are 0-560 and 1200-
!     2200 cm-1. the CTS calculations also require calculations in the
!     160-560 cm-1 range. (see refs. (1) and (2)).
!ifdef ch4n2o
!
!     if ch4 and n2o are included, the frequency range for emissivities
!     is 1400-2200 cm-1, with separate emissivity quantities for the
!     1200-1400 cm-1 range.
!endif ch4n2o
!
!     the reason for combining these calculations is that both use
!     the same scaled h2o amount (avephi) as input, thus reducing
!     some calculation time for obtaining index quantities.
!   
!     references:
!
!     (1) schwarzkopf, m. d., and s. b. fels, "the simplified
!         exchange method revisited: an accurate, rapid method for
!         computation of infrared cooling rates and fluxes," journal
!         of geophysical research, 96 (1981), 9075-9096.
!
!     (2) fels, s. b., and m. d. schwarzkopf, "the simplified exchange
!         approximation: a new method for radiative transfer
!         calculations," journal atmospheric science, 32 (1975),
!         1475-1488.
!
!     author: m. d. schwarzkopf
!
!     revised: 1/1/93
!
!     certified:  radiation version 1.0
!-----------------------------------------------------------------------

type(atmos_input_type),    intent(in)    :: Atmos_input
real, dimension (:,:,:),   intent(out)   :: e1ctw1, e1ctw2
real, dimension (:,:,:,:), intent(out)   :: trans_band1, trans_band2  
type(optical_path_type),   intent(inout) :: Optical
real, dimension (:,:,:,:), intent(in)    ::  tch4n2oe                  
real, dimension(:,:,:),    intent(in)    :: t4
type(lw_diagnostics_type), intent(inout) :: Lw_diagnostics
real, dimension(:,:,:,:),  intent(in)    :: cldtf
integer, dimension(:),     intent(in)    :: cld_indx
real, dimension(:,:),      intent(out)   :: flx1e1cf
real, dimension (:,:,:),   intent(inout) ::  tcfc8           
logical,                   intent(in)            :: including_aerosols  
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      Atmos_input
!      tch4n2oe
!      t4
!      cldtf
!      cld_indx
!
!   intent(inout) variables:
!
!      Optical
!      Lw_diagnostics
!      tcfc8
!
!   intent(out) variables:
!
!      e1ctw1
!      e1ctw2
!      trans_band1
!      trans_band2
!      flx1e1cf
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables

      real, dimension (size(trans_band2,1), &
                       size(trans_band2,2), &
                       size(trans_band2,3)) :: dte1, dte2,ttmp,ttmp0

      integer, dimension (size(trans_band2,1), &
                          size(trans_band2,2), &
                          size(trans_band2,3)) :: ixoe1, ixoe2

      real, dimension (size(Atmos_input%temp,1),    &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)) ::   &
                                     temp, tflux, totaer_tmp, taero8, &
                                     tmp1, tmp2, e1cts1, e1cts2, &
                                     avphilog, dt1, du, dup, du1, dup1

      integer, dimension (size(Atmos_input%temp,1),    &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)) ::   &
                                         ixo1, iyo, iyop, iyo1, iyop1 

      real, dimension (size(Atmos_input%temp,1),    &
                       size(Atmos_input%temp,2)) :: &
                        s1a, flxge1, flxge1cf

      real, dimension (size(Atmos_input%temp,1),    &
                       size(Atmos_input%temp,2), NBTRGE) :: &
                        flx1e1fcf, flxge1f, flxge1fcf
      real, dimension (size(Atmos_input%temp,1),    &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3), NBTRGE) ::   &
                         e1cts1f, e1cts2f

      integer  :: i,j,k,kk,m
!---------------------------------------------------------------------
!  local variables
!
!     dte1
!     dte2
!     ixoe1
!     ixoe2  
!     temp
!     tflux
!     totaer_tmp
!     taero8
!     tmp1
!     tmp2
!     e1cts1
!     e1cts2
!     avphilog
!     dt1
!     du
!     dup
!     ixo1
!     iyo
!     iyop
!     s1a
!     flxge1
!     flxge1cf
!     flx1e1fcf
!     flxge1f
!     flxge1fcf
!     e1cts1f
!     e1cts2f
!     k,m
!
!----------------------------------------------------------------------

     do kk = 1,size(tflux(:,:,:),3)
        do j = 1,size(tflux(:,:,:),2)
           do i = 1,size(tflux(:,:,:),1)
              tflux(i,j,kk) = Atmos_input%tflux(i,j,kk)
           end do
        end do
     end do
     do kk = 1,size(temp(:,:,:),3)
        do j = 1,size(temp(:,:,:),2)
           do i = 1,size(temp(:,:,:),1)
              temp(i,j,kk) = Atmos_input%temp(i,j,kk)
           end do
        end do
     end do

!---------------------------------------------------------------------
!     obtain the "exchange" emissivities as a function of temperature 
!     (fxo) and water amount (fyo). the temperature indices have
!     been obtained in longwave_setup_mod.
!-------------------------------------------------------------------
  call locate_in_table(temp_1, temp, dte1, ixoe1, KS, KE+1)
  call locate_in_table(temp_1, tflux, dte2, ixoe2, KS, KE+1)

  do kk = KS,KE
     do j = 1,size(ixoe2(:,:,:),2)
        do i = 1,size(ixoe2(:,:,:),1)
           ixoe2(i,j,kk) = ixoe2(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  do kk = KS,KE
     do j = 1,size(dte2(:,:,:),2)
        do i = 1,size(dte2(:,:,:),1)
           dte2(i,j,kk) = dte2 (i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  do j = 1,size(ixoe2(:,:,:),2)
     do i = 1,size(ixoe2(:,:,:),1)
        ixoe2(i,j,KE+1) = ixoe1(i,j,KE)
     end do
  end do
  do j = 1,size(dte2(:,:,:),2)
     do i = 1,size(dte2(:,:,:),1)
        dte2(i,j,KE+1) = dte1 (i,j,KE)
     end do
  end do



   if (Lw_control%do_h2o) then
      do kk = KS,KE+1
         do j = 1,size(avphilog(:,:,:),2)
            do i = 1,size(avphilog(:,:,:),1)
               avphilog(i,j,kk) = LOG10(Optical%avephi(i,j,kk))
            end do
         end do
      end do
      call locate_in_table (mass_1, avphilog, du, iyo, KS, KE+1)
      iyo(:,:,KS:KE+1) = iyo(:,:,KS:KE+1) + 1
      call looktab (tab2, ixoe2, iyo, dte2, du, &
                    trans_band2(:,:,:,1), KS, KE+1)
   else
     iyo1(:,:,KS:KE+1) = 1
     du1(:,:,KS:KE+1) = 0.0
     call looktab (tab2, ixoe2, iyo1, dte2, du1, &
                   trans_band2(:,:,:,1), KS, KE+1)
   endif

!-----------------------------------------------------------------------
!     the special case emiss(:,:,KE+1) for layer KE+1 is obtained by 
!     averaging the values for KE and KE+1.
!---------------------------------------------------------------------
      do j = 1,size(trans_band2(:,:,:,:),2)
         do i = 1,size(trans_band2(:,:,:,:),1)
            trans_band2(i,j,KE+1,1) = 0.5E+00*(trans_band2(i,j,KE,1) +  &
                          trans_band2(i,j,KE+1, 1))
         end do
      end do
      ttmp(:,:,:) = trans_band2(:,:,:,1)
      do kk = KS+1,KE
         do j = 1,size(trans_band2(:,:,:,:),2)
            do i = 1,size(trans_band2(:,:,:,:),1)
               trans_band2(i,j,kk,1) = ttmp(i,j,kk-1)
            end do
         end do
      end do
 
!---------------------------------------------------------------------
!     perform calculations for the e1 function. the terms involving top
!     layer du are not known.  we use index two to represent index one
!     in previous calculations. (now 3)
!--------------------------------------------------------------------
      do j = 1,size(iyop(:,:,:),2)
         do i = 1,size(iyop(:,:,:),1)
            iyop(i,j,KS) = 2
         end do
      end do
      do kk = KS+1,KE+1
         do j = 1,size(iyop(:,:,:),2)
            do i = 1,size(iyop(:,:,:),1)
               iyop(i,j,kk) = iyo(i,j,kk+KS-(KS+1))
            end do
         end do
      end do
      do j = 1,size(dup(:,:,:),2)
         do i = 1,size(dup(:,:,:),1)
            dup(i,j,KS) = 0.0E+00
         end do
      end do
      do kk = KS+1,KE+1
         do j = 1,size(dup(:,:,:),2)
            do i = 1,size(dup(:,:,:),1)
               dup(i,j,kk) = du (i,j,kk+KS-(KS+1))
            end do
         end do
      end do
      do k=KS,KE+1
        do j = 1,size(ixo1(:,:,:),2)
           do i = 1,size(ixo1(:,:,:),1)
              ixo1(i,j,k) = ixoe1(i,j,KS)
           end do
        end do
        do j = 1,size(dt1(:,:,:),2)
           do i = 1,size(dt1(:,:,:),1)
              dt1(i,j,k) = dte1 (i,j,KS)
           end do
        end do
      enddo

    if (Lw_control%do_h2o) then
!-----------------------------------------------------------------------
!     e1flx(:,:,KS) equals e1cts1(:,:,KS).
!-----------------------------------------------------------------------
      call looktab (tab1, ixoe1, iyop, dte1, dup, e1cts1, KS, KE+1)
      call looktab (tab1, ixoe1, iyo, dte1, du, e1cts2, KS, KE)
      call looktab (tab1, ixo1, iyop, dt1, dup, &
                    trans_band1(:,:,:,1), KS, KE+1)
      call looktab (tab1w, ixoe1, iyop, dte1, dup, e1ctw1, KS, KE+1)
      call looktab (tab1w, ixoe1, iyo, dte1, du, e1ctw2, KS, KE)
    else
      iyop1(:,:,:) = 1
      dup1 (:,:,:) = 0.0
      call looktab (tab1, ixoe1, iyop1, dte1, dup1, e1cts1, KS, KE+1)
      call looktab (tab1, ixoe1, iyo1, dte1, du1, e1cts2, KS, KE)
      call looktab (tab1, ixo1, iyop1, dt1, dup1, &
                    trans_band1(:,:,:,1), KS, KE+1)
      call looktab (tab1w, ixoe1, iyop1, dte1, dup1, e1ctw1, KS, KE+1)
      call looktab (tab1w, ixoe1, iyo1, dte1, du1, e1ctw2, KS, KE)
    endif

!--------------------------------------------------------------------
!     calculations with ch4 and n2o require NBTRGE separate emissivity
!     bands for h2o.
!--------------------------------------------------------------------
      if (NBTRGE > 0) then
        do m=1,NBTRGE
          if (Lw_control%do_h2o) then
          do kk = KS,KE+1
             do j = 1,size(avphilog(:,:,:),2)
                do i = 1,size(avphilog(:,:,:),1)
                   avphilog(i,j,kk) = LOG10(Optical%avephif(i,j,kk,m))
                end do
             end do
          end do
          call locate_in_table (mass_1, avphilog, du, iyo, KS , KE+1)
          iyo(:,:,KS:KE+1) = iyo(:,:,KS:KE+1) + 1
          do j = 1,size(iyop(:,:,:),2)
             do i = 1,size(iyop(:,:,:),1)
                iyop(i,j,KS) = 2
             end do
          end do
          do kk = KS+1,KE+1
             do j = 1,size(iyop(:,:,:),2)
                do i = 1,size(iyop(:,:,:),1)
                   iyop(i,j,kk) = iyo(i,j,kk+KS-(KS+1))
                end do
             end do
          end do
          do j = 1,size(dup(:,:,:),2)
             do i = 1,size(dup(:,:,:),1)
                dup(i,j,KS) = 0.0E+00
             end do
          end do
          do kk = KS+1,KE+1
             do j = 1,size(dup(:,:,:),2)
                do i = 1,size(dup(:,:,:),1)
                   dup(i,j,kk) = du (i,j,kk+KS-(KS+1))
                end do
             end do
          end do
          call looktab (tab2a, ixoe2, iyo, dte2, du, &
                        trans_band2(:,:,:,6+m), KS, KE+1, m)
          call looktab (tab1a, ixoe1, iyop, dte1, dup,    &
                        e1cts1f(:,:,:,m), KS, KE+1, m)
          call looktab (tab1a, ixoe1, iyo, dte1, du, e1cts2f(:,:,:,m),&
                        KS, KE, m)
          call looktab (tab1a, ixo1, iyop, dt1, dup,   &
                        trans_band1(:,:,:,6+m), KS, KE+1, m)
         else
          iyo1(:,:,KS:KE+1) = 1
          iyop1(:,:,KS:KE+1) = 1
          du1(:,:,KS:KE+1) = 0.0
          dup1(:,:,KS:KE+1) = 0.0
          call looktab (tab2a, ixoe2, iyo1, dte2, du1, &
                        trans_band2(:,:,:,6+m), KS, KE+1, m)
          call looktab (tab1a, ixoe1, iyop1, dte1, dup1,    &
                        e1cts1f(:,:,:,m), KS, KE+1, m)
          call looktab (tab1a, ixoe1, iyo1, dte1, du1, &
                        e1cts2f(:,:,:,m), KS, KE, m)
          call looktab (tab1a, ixo1, iyop1, dt1, dup1,   &
                        trans_band1(:,:,:,6+m), KS, KE+1, m)
        endif
        enddo

!--------------------------------------------------------------------
!     the special case emissf(:,:,KE+1,m) for layer KE+1 is obtained by 
!     averaging the values for KE and KE+1.
!--------------------------------------------------------------------
        do m=1,NBTRGE
         ttmp(:,:,:) = trans_band2(:,:,:,6+m)
         ttmp0(:,:,:) = trans_band2(:,:,:,6+m)
          do j = 1,size(trans_band2(:,:,:,:),2)
             do i = 1,size(trans_band2(:,:,:,:),1)
                trans_band2(i,j,KE+1,6+m) = 0.5E+00*    &
                             (ttmp(i,j,KE) +  &
                                   ttmp0(i,j,KE+1))
             end do
          end do
      ttmp(:,:,:)=trans_band2(:,:,:,6+m)
      do kk = KS+1,KE
         do j = 1,size(trans_band2(:,:,:,:),2)
            do i = 1,size(trans_band2(:,:,:,:),1)
               trans_band2(i,j,kk,6+m) = ttmp(i,j,kk+KS-(KS+1))
            end do
         end do
      end do
     enddo
    endif

!---------------------------------------------------------------------
!    add the effects of other radiative gases on these flux arrays.
!    the lbl transmissivities imply (at present) NBTRG = NBTRGE = 1).
!    thus, tch4e and tn2oe are obtained directly from the transmission
!    functions. 
!----------------------------------------------------------------------
   if (NBTRGE > 0) then
   if (Lw_control%do_ch4 .or. Lw_control%do_n2o) then
     do kk = KS+1,KE+1
        do j = 1,size(trans_band1(:,:,:,:),2)
           do i = 1,size(trans_band1(:,:,:,:),1)
              trans_band1(i,j,kk,6+1) = trans_band1(i,j,kk,6+1)*  &
                                tch4n2oe(i,j,kk,1)
           end do
        end do
     end do
     do kk = KS,KE+1
        do j = 1,size(e1cts1f(:,:,:,:),2)
           do i = 1,size(e1cts1f(:,:,:,:),1)
              e1cts1f(i,j,kk,1) = e1cts1f(i,j,kk,1)*  &
                                tch4n2oe(i,j,kk,1)
           end do
        end do
     end do
     do kk = KS,KE
        do j = 1,size(e1cts2f(:,:,:,:),2)
           do i = 1,size(e1cts2f(:,:,:,:),1)
              e1cts2f(i,j,kk,  1) = e1cts2f(i,j,kk,1)*   &
                                tch4n2oe(i,j,kk+KS+1-(KS),1)
           end do
        end do
     end do
     do kk = KS+1,KE+1
        do j = 1,size(trans_band2(:,:,:,:),2)
           do i = 1,size(trans_band2(:,:,:,:),1)
              trans_band2(i,j,kk,  6+1) = trans_band2(i,j,kk,6+1)*   &
                                tch4n2oe(i,j,kk,1)
           end do
        end do
     end do
   endif
 
!----------------------------------------------------------------------
!    add cfc transmissivities if species which absorb in this fre-
!    quency range ( presently index 8) are present.
!----------------------------------------------------------------------
!----------------------------------------------------------------------
     if (Lw_control%do_cfc) then
       call cfc_indx8 (8, Optical, tcfc8)
       do kk = KS+1,KE+1
          do j = 1,size(trans_band1(:,:,:,:),2)
             do i = 1,size(trans_band1(:,:,:,:),1)
                trans_band1(i,j,kk,6+1) = trans_band1(i,j,kk,6+1)*  &
                                  tcfc8(i,j,kk)
             end do
          end do
       end do
       do kk = KS,KE+1
          do j = 1,size(e1cts1f(:,:,:,:),2)
             do i = 1,size(e1cts1f(:,:,:,:),1)
                e1cts1f(i,j,kk,1) = e1cts1f(i,j,kk,1)*  &
                                  tcfc8(i,j,kk)
             end do
          end do
       end do
       do kk = KS,KE
          do j = 1,size(e1cts2f(:,:,:,:),2)
             do i = 1,size(e1cts2f(:,:,:,:),1)
                e1cts2f(i,j,kk,  1) = e1cts2f(i,j,kk,1)*  &
                                  tcfc8(i,j,kk+KS+1-(KS))
             end do
          end do
       end do
       do kk = KS+1,KE+1
          do j = 1,size(trans_band2(:,:,:,:),2)
             do i = 1,size(trans_band2(:,:,:,:),1)
                trans_band2(i,j,kk,6+1) = trans_band2(i,j,kk,6+1)*   &
                                  tcfc8(i,j,kk)
             end do
          end do
       end do
     endif 

!----------------------------------------------------------------------
!    compute aerosol transmission function for 1200-1400 cm-1 region
!----------------------------------------------------------------------
      if (including_aerosols) then
        do kk = 1,size(totaer_tmp(:,:,:),3)
           do j = 1,size(totaer_tmp(:,:,:),2)
              do i = 1,size(totaer_tmp(:,:,:),1)
                 totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,8)
              end do
           end do
        end do
       do kk = KS,KE+1
          do j = 1,size(taero8(:,:,:),2)
             do i = 1,size(taero8(:,:,:),1)
                taero8(i,j,kk) = EXP(-1.0E+00*totaer_tmp(i,j,kk))
             end do
          end do
       end do
       do kk = KS+1,KE+1
          do j = 1,size(trans_band1(:,:,:,:),2)
             do i = 1,size(trans_band1(:,:,:,:),1)
                trans_band1(i,j,kk,6+1) = trans_band1(i,j,kk,6+1)*   &
                                  taero8(i,j,kk)
             end do
          end do
       end do
       do kk = KS,KE+1
          do j = 1,size(e1cts1f(:,:,:,:),2)
             do i = 1,size(e1cts1f(:,:,:,:),1)
                e1cts1f(i,j,kk,1) = e1cts1f(i,j,kk,1)*  &
                                  taero8(i,j,kk)
             end do
          end do
       end do
       do kk = KS,KE
          do j = 1,size(e1cts2f(:,:,:,:),2)
             do i = 1,size(e1cts2f(:,:,:,:),1)
                e1cts2f(i,j,kk,  1) = e1cts2f(i,j,kk,1)*   &
                                  taero8(i,j,kk+KS+1-(KS))
             end do
          end do
       end do
       do kk = KS+1,KE+1
          do j = 1,size(trans_band2(:,:,:,:),2)
             do i = 1,size(trans_band2(:,:,:,:),1)
                trans_band2(i,j,kk,6+1) = trans_band2(i,j,kk,6+1)*   &
                                  taero8(i,j,kk)
             end do
          end do
       end do
     endif
   endif  ! (NBTRGE > 0) 

!-----------------------------------------------------------------------
!     obtain the flux at the top of the atmosphere in the 0-160, 
!     1200-2200 cm-1 frequency ranges, where heating rates and fluxes
!     are derived from h2o emissivity calculations (flx1e1) by:
!     1) obtaining the surface flux (flxge1); 2) summing the
!     emissivity flux divergence for these ranges (tmp1) over all 
!     pressure layers.
!#ifdef ch4n2o
!     if the 1200-1400 cm-1 range is computed separately, flux calcu-
!     lations are done separately in this range, then combined with
!     those from the other frequency range.
!#endif ch4n2o
!----------------------------------------------------------------------
    do j = 1,size(s1a(:,:),2)
       do i = 1,size(s1a(:,:),1)
          s1a(i,j) = t4(i,j,KE+1)*(e1cts1(i,j,KE+1) - e1ctw1(i,j,KE+1))
       end do
    end do
    do j = 1,size(flxge1(:,:),2)
       do i = 1,size(flxge1(:,:),1)
          flxge1(i,j) = s1a(i,j)*cldtf(i,j,KE+1,1)
       end do
    end do
    do kk = KS,KE
       do j = 1,size(tmp1(:,:,:),2)
          do i = 1,size(tmp1(:,:,:),1)
             tmp1(i,j,kk) = t4(i,j,kk)*    &
                      (e1cts1(i,j,kk) - e1ctw1(i,j,kk)) 
          end do
       end do
    end do
    do kk = KS,KE
       do j = 1,size(tmp2(:,:,:),2)
          do i = 1,size(tmp2(:,:,:),1)
             tmp2(i,j,kk) = t4(i,j,kk)*   &
                       (e1cts2(i,j,kk) - e1ctw2(i,j,kk))
          end do
       end do
    end do
    do j = 1,size(Lw_diagnostics%flx1e1(:,:),2)
       do i = 1,size(Lw_diagnostics%flx1e1(:,:),1)
          Lw_diagnostics%flx1e1(i,j) = flxge1(i,j)
       end do
    end do
    do k=KS,KE
      do j = 1,size(Lw_diagnostics%flx1e1(:,:),2)
         do i = 1,size(Lw_diagnostics%flx1e1(:,:),1)
            Lw_diagnostics%flx1e1(i,j) = Lw_diagnostics%flx1e1(i,j) + tmp1(i,j,k)*cldtf(i,j,k,1) -   &
                    tmp2(i,j,k)*cldtf(i,j,k+1,1)
         end do
      end do
    enddo
    if (Rad_control%do_totcld_forcing) then
      do j = 1,size(flxge1cf(:,:),2)
         do i = 1,size(flxge1cf(:,:),1)
            flxge1cf(i,j) = s1a(i,j)
         end do
      end do
      do j = 1,size(flx1e1cf(:,:),2)
         do i = 1,size(flx1e1cf(:,:),1)
            flx1e1cf(i,j) = flxge1cf(i,j)
         end do
      end do
      do k=KS,KE
        do j = 1,size(flx1e1cf(:,:),2)
           do i = 1,size(flx1e1cf(:,:),1)
              flx1e1cf(i,j) = flx1e1cf(i,j) + tmp1(i,j,k) - tmp2(i,j,k)
           end do
        end do
      enddo
    endif
    if (NBTRGE > 0) then
      do m=1,NBTRGE
        do j = 1,size(s1a(:,:),2)
           do i = 1,size(s1a(:,:),1)
              s1a(i,j) = t4(i,j,KE+1)*e1cts1f(i,j,KE+1,m)
           end do
        end do
        do j = 1,size(flxge1f(:,:,:),2)
           do i = 1,size(flxge1f(:,:,:),1)
              flxge1f(i,j,m) = s1a(i,j)*cldtf(i,j,KE+1,cld_indx(7))
           end do
        end do
        do j = 1,size(Lw_diagnostics%flx1e1f(:,:,:),2)
           do i = 1,size(Lw_diagnostics%flx1e1f(:,:,:),1)
              Lw_diagnostics%flx1e1f(i,j,m) = flxge1f(i,j,m)
           end do
        end do
        do k=KS,KE
          do j = 1,size(tmp1(:,:,:),2)
             do i = 1,size(tmp1(:,:,:),1)
                tmp1(i,j,k) = t4(i,j,k)*e1cts1f(i,j,k,m)
             end do
          end do
          do j = 1,size(tmp2(:,:,:),2)
             do i = 1,size(tmp2(:,:,:),1)
                tmp2(i,j,k) = t4(i,j,k)*e1cts2f(i,j,k,m)
             end do
          end do
          do j = 1,size(Lw_diagnostics%flx1e1f(:,:,:),2)
             do i = 1,size(Lw_diagnostics%flx1e1f(:,:,:),1)
                Lw_diagnostics%flx1e1f(i,j,m) =  &
                       Lw_diagnostics%flx1e1f(i,j,m) + tmp1(i,j,k)*   &
                           cldtf(i,j,k,cld_indx(7)) - tmp2(i,j,k)*  &
                           cldtf(i,j,k+1,cld_indx(7))
             end do
          end do
        end do
      end do
      do m=1,NBTRGE
        do j = 1,size(Lw_diagnostics%flx1e1(:,:),2)
           do i = 1,size(Lw_diagnostics%flx1e1(:,:),1)
              Lw_diagnostics%flx1e1(i,j) =    &
                                 Lw_diagnostics%flx1e1(i,j) +  &
                                 Lw_diagnostics%flx1e1f(i,j,m)
           end do
        end do
      enddo
      if (Rad_control%do_totcld_forcing) then
        do m=1,NBTRGE
          do j = 1,size(flxge1fcf(:,:,:),2)
             do i = 1,size(flxge1fcf(:,:,:),1)
                flxge1fcf(i,j,m) = s1a(i,j)
             end do
          end do
          do j = 1,size(flx1e1fcf(:,:,:),2)
             do i = 1,size(flx1e1fcf(:,:,:),1)
                flx1e1fcf(i,j,m) = s1a(i,j)
             end do
          end do
          do k=KS,KE
            do j = 1,size(flx1e1fcf(:,:,:),2)
               do i = 1,size(flx1e1fcf(:,:,:),1)
                  flx1e1fcf(i,j,m) = flx1e1fcf(i,j,m) + tmp1(i,j,k) -   &
                                                    tmp2(i,j,k)
               end do
            end do
          end do
        end do
        do m=1,NBTRGE
          do j = 1,size(flx1e1cf(:,:),2)
             do i = 1,size(flx1e1cf(:,:),1)
                flx1e1cf(i,j) = flx1e1cf(i,j) + flx1e1fcf(i,j,m)
             end do
          end do
        enddo
      endif
    endif  ! (ntrge > 0)

!----------------------------------------------------------------------



end  subroutine e1e290



!###################################################################
! <SUBROUTINE NAME="e290">
!  <OVERVIEW>
!   e290 computes the exchange terms in the flux equation for longwave
!     radiation for all terms except the exchange with the top of the
!     atmosphere.
!  </OVERVIEW>
!  <DESCRIPTION>
!     e290 computes the exchange terms in the flux equation for longwave
!     radiation for all terms except the exchange with the top of the
!     atmosphere.  the method is a table lookup on a pre-computed e2
!     function (defined in reference (2)).  calculation are done in the
!     frequency range: 0-560, 1200-2200 cm-1 for q(approximate).
!     motivation for these calculations is in references (1) and (2).
!
!     references:
!
!     (1) schwarzkopf, m. d., and s. b. fels, "the simplified
!         exchange method revisited: an accurate, rapid method for
!         computation of infrared cooling rates and fluxes," journal
!         of geophysical research, 96 (1981), 9075-9096.
!
!     (2) fels, s. b., and m. d. schwarzkopf, "the simplified exchange
!         approximation: a new method for radiative transfer
!         calculations," journal atmospheric science, 32 (1975),
!         1475-1488.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call e290 (Atmos_input, k, trans_band2, trans_band1, Optical,  tch4n2oe, &
!              tcfc8)
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data
!  </IN>
!  <IN NAME="k" TYPE="integer">
!   Starting vertical level k to compute exchange terms
!  </IN>
!  <INOUT NAME="trans_band2" TYPE="real">
!   Transmission funciton in band 1200-2200
!  </INOUT>
!  <INOUT NAME="trans_band" TYPE="real">
!   Transmission function in band 0-560
!  </INOUT>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth of the thermal layers
!  </INOUT>
!  <IN NAME="tch4n2oe" TYPE="real">
!   CH4 and N2O transmission function
!  </IN>
!  <INOUT NAME="tcfc8" TYPE="real">
!   CFC transmission function
!  </INOUT>
! </SUBROUTINE>
!
subroutine e290 (Atmos_input, k, trans_band2, trans_band1, Optical,  &
                 tch4n2oe, tcfc8, including_aerosols)   

!-----------------------------------------------------------------------
!
!     e290 computes the exchange terms in the flux equation for longwave
!     radiation for all terms except the exchange with the top of the
!     atmosphere.  the method is a table lookup on a pre-computed e2
!     function (defined in reference (2)).  calculation are done in the
!     frequency range: 0-560, 1200-2200 cm-1 for q(approximate).
!     motivation for these calculations is in references (1) and (2).
!
!     references:
!
!     (1) schwarzkopf, m. d., and s. b. fels, "the simplified
!         exchange method revisited: an accurate, rapid method for
!         computation of infrared cooling rates and fluxes," journal
!         of geophysical research, 96 (1981), 9075-9096.
!
!     (2) fels, s. b., and m. d. schwarzkopf, "the simplified exchange
!         approximation: a new method for radiative transfer
!         calculations," journal atmospheric science, 32 (1975),
!         1475-1488.
!
!     author: c. h. goldberg
!
!     revised: 1/1/93
!
!     certified:  radiation version 1.0
!
!---------------------------------------------------------------------

type(atmos_input_type),   intent(in)    ::  Atmos_input
integer,                  intent(in)    ::  k
real, dimension(:,:,:,:), intent(inout) :: trans_band1, trans_band2
type(optical_path_type),  intent(inout) ::  Optical
real, dimension(:,:,:,:), intent(in)    :: tch4n2oe       
real, dimension(:,:,:),   intent(inout) :: tcfc8          
logical,                   intent(in)            :: including_aerosols  
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!   intent(in) variables:
!
!       Atmos_input
!       k
!       tch4n2oe
!
!   intent(inout) variables:
!
!       trans_band1
!       trans_band2
!       Optical
!       tcfc8
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables
!-------------------------------------------------------------------
      integer      :: i,j,kk,kp, m

      real,    dimension (size(Atmos_input%temp,1),    &
                          size(Atmos_input%temp,2), &
                          size(Atmos_input%temp,3)) ::    &
                                  temp, tflux, totaer_tmp, taero8, &
                                  taero8kp, avphilog, dtk, du, du1

      integer, dimension (size(Atmos_input%temp,1),    &
                          size(Atmos_input%temp,2), &
                          size(Atmos_input%temp,3)) ::              &
                                                  ixok, iyo, iyo1    

      real,    dimension (size(trans_band2,1), &
                          size(trans_band2,2), &
                          size(trans_band2,3)) :: dte1, dte2

      integer, dimension (size(trans_band2,1), &
                          size(trans_band2,2), &
                          size(trans_band2,3)) :: ixoe1, ixoe2
      real,    dimension (size(trans_band2,1), &
                          size(trans_band2,2), &
                          size(trans_band2,3)) ::ttmp

      real,    dimension (size(trans_band1,1), &
                          size(trans_band1,2), &
                          size(trans_band1,3)) :: ttmp0

!-------------------------------------------------------------------
!  local variables:
!
!      temp
!      tflux
!      totaer_tmp
!      taero8
!      taero8kp
!      avphilog
!      dtk
!      du
!      du1
!      ixok
!      iyo
!      iyo1
!      dte1
!      dte2
!      ixoe1
!      ixoe2
!      kp,m
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
      temp = Atmos_input%temp
      tflux = Atmos_input%tflux

!-----------------------------------------------------------------------
!     obtain the "exchange" emissivities as a function of temperature 
!     (fxo) and water amount (avephi). the temperature indices have
!     been obtained in Lwrad. calculations are for flux level k, with
!     kp = k+1 to KE+1. the case k=KS is excluded (done in E1e290).
!     calculations are also made for flux levels k to KE, for
!     contributions from flux level k. in this case, the temperature
!     index (ixok) represents tflux(:,:,k-1); the water index (iyo)
!     has the same values as in the case with varying kp.
!---------------------------------------------------------------------

!----------------------------------------------------------------------

  call locate_in_table(temp_1, temp, dte1, ixoe1, KS, KE+1)
  call locate_in_table(temp_1, tflux, dte2, ixoe2, KS, KE+1)

  ttmp(:,:,:) = ixoe2(:,:,:)
  do kk = KS,KE
     do j = 1,size(ixoe2(:,:,:),2)
        do i = 1,size(ixoe2(:,:,:),1)
           ixoe2(i,j,kk) = ttmp(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  ttmp(:,:,:)=dte2 (:,:,:)
  do kk = KS,KE
     do j = 1,size(dte2(:,:,:),2)
        do i = 1,size(dte2(:,:,:),1)
           dte2(i,j,kk) = ttmp(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  do j = 1,size(ixoe2(:,:,:),2)
     do i = 1,size(ixoe2(:,:,:),1)
        ixoe2(i,j,KE+1) = ixoe1(i,j,KE)
     end do
  end do
  do j = 1,size(dte2(:,:,:),2)
     do i = 1,size(dte2(:,:,:),1)
        dte2(i,j,KE+1) = dte1 (i,j,KE)
     end do
  end do


      do kp=k,KE
        do j = 1,size(ixok(:,:,:),2)
           do i = 1,size(ixok(:,:,:),1)
              ixok(i,j,kp) = ixoe2(i,j,k-1)
           end do
        end do
        do j = 1,size(dtk(:,:,:),2)
           do i = 1,size(dtk(:,:,:),1)
              dtk(i,j,kp) = dte2 (i,j,k-1)
           end do
        end do
      end do

   if (Lw_control%do_h2o) then
      do kk = k,KE+1
         do j = 1,size(avphilog(:,:,:),2)
            do i = 1,size(avphilog(:,:,:),1)
               avphilog(i,j,kk) = LOG10(Optical%avephi(i,j,kk))
            end do
         end do
      end do
      call locate_in_table (mass_1, avphilog, du, iyo,k, KE+1)
      iyo(:,:,k:KE+1) = iyo(:,:,k:KE+1) + 1
      call looktab (tab2, ixoe2, iyo, dte2, du, &
                    trans_band2(:,:,:,1), k, KE+1)
      call looktab (tab2, ixok, iyo, dtk, du, &
                    trans_band1(:,:,:,1), k, KE)
   else
     iyo1(:,:,k:KE+1) = 1
     du1(:,:,k:KE+1) = 0.0
     call looktab (tab2, ixoe2, iyo1, dte2, du1, &
                   trans_band2(:,:,:,1), k, KE+1)
     call looktab (tab2, ixok, iyo1, dtk, du1, &
                   trans_band1(:,:,:,1), k, KE)
   endif
       ttmp0(:,:,:)=trans_band1(:,:,:,1)
       do kk = k+1,KE+1
          do j = 1,size(trans_band1(:,:,:,:),2)
             do i = 1,size(trans_band1(:,:,:,:),1)
                trans_band1(i,j,kk,1) = ttmp0(i,j,kk+k-(k+1))
             end do
          end do
       end do

!--------------------------------------------------------------------
!     the special case emiss(:,:,KE) for layer KE is obtained by 
!     averaging the values for KE and KE+1. note that emiss(:,:,KE+1) 
!     is not useful after this point.
!-------------------------------------------------------------------
      do j = 1,size(trans_band2(:,:,:,:),2)
         do i = 1,size(trans_band2(:,:,:,:),1)
            trans_band2(i,j,KE+1,1) = 0.5E+00*(trans_band2(i,j,KE,1) +  &
                                               trans_band2(i,j,KE+1,1))
         end do
      end do
      ttmp(:,:,:)=trans_band2(:,:,:,1)
      do kk = k+1,KE
         do j = 1,size(trans_band2(:,:,:,:),2)
            do i = 1,size(trans_band2(:,:,:,:),1)
               trans_band2(i,j,kk,1) = ttmp(i,j,kk+k-(k+1))
            end do
         end do
      end do
 
!--------------------------------------------------------------------
!     calculations with ch4 and n2o require NBTRGE separate emissivity
!     bands for h2o. reqults are in emissf (flux level k) and
!     emissbf (other levels).
!-------------------------------------------------------------------
      if (nbtrge > 0) then
        do m=1,NBTRGE
   if (Lw_control%do_h2o) then
          do kk = k,KE+1
             do j = 1,size(avphilog(:,:,:),2)
                do i = 1,size(avphilog(:,:,:),1)
                   avphilog(i,j,kk) = LOG10(Optical%avephif(i,j,kk,m))
                end do
             end do
          end do
          call locate_in_table (mass_1, avphilog, du, iyo, k, KE+1)
          iyo(:,:,k:KE+1) = iyo(:,:,k:KE+1) + 1
          call looktab (tab2a, ixoe2, iyo, dte2, du, &
                        trans_band2(:,:,:,6+m), k, KE+1, m)
          call looktab (tab2a, ixok, iyo, dtk, du, &
                        trans_band1(:,:,:,6+m), k, KE, m)
   else
      iyo1(:,:,k:KE+1) = 1
      du1(:,:,k:KE+1) = 0.0
      call looktab (tab2a, ixoe2, iyo1, dte2, du1, &
                    trans_band2(:,:,:,6+m), k, KE+1, m)
      call looktab (tab2a, ixok, iyo1, dtk, du1, &
                    trans_band1(:,:,:,6+m), k, KE, m)
   endif
       ttmp0(:,:,:)=trans_band1(:,:,:,6+m)
       do kk = k+1,KE+1
          do j = 1,size(trans_band1(:,:,:,:),2)
             do i = 1,size(trans_band1(:,:,:,:),1)
                trans_band1(i,j,kk,6+m) = ttmp0(i,j,kk+k-(k+1))
             end do
          end do
       end do
      enddo

!----------------------------------------------------------------------
!     the special case emissf(:,:,KE) for layer KE is obtained by 
!     averaging the values for KE and KE+1. note that emissf(:,:,KE+1,m)
!     is not useful after this point.
!----------------------------------------------------------------------
        do m=1,NBTRGE
          do j = 1,size(trans_band2(:,:,:,:),2)
             do i = 1,size(trans_band2(:,:,:,:),1)
                trans_band2(i,j,KE+1,6+m) = 0.5E+00*  &
                             (trans_band2(i,j,KE,6+m) +   &
                               trans_band2(i,j,KE+1,6+m))
             end do
          end do
          ttmp(:,:,:)=trans_band2(:,:,:,6+m)
          do kk = k+1,KE
             do j = 1,size(trans_band2(:,:,:,:),2)
                do i = 1,size(trans_band2(:,:,:,:),1)
                   trans_band2(i,j,kk,6+m) = ttmp(i,j,kk+k-(k+1))
                end do
             end do
          end do
        enddo
      endif

!----------------------------------------------------------------------
!    add the effects of other radiative gases on these flux arrays.
!    the lbl transmissivities imply (at present) NBTRG = NBTRGE = 1).
!    thus, tch4e and tn2oe are obtained directly from the transmission
!    functions. 
!---------------------------------------------------------------------
    if (nbtrge > 0) then
      if (Lw_control%do_ch4 .or. Lw_control%do_n2o) then
        do kk = k+1,KE+1
           do j = 1,size(trans_band1(:,:,:,:),2)
              do i = 1,size(trans_band1(:,:,:,:),1)
                 trans_band1(i,j,kk,6+1) = trans_band1(i,j,kk,6+1)*  &
                         tch4n2oe(i,j,kk,1)
              end do
           end do
        end do
        do kk = k+1,KE+1
           do j = 1,size(trans_band2(:,:,:,:),2)
              do i = 1,size(trans_band2(:,:,:,:),1)
                 trans_band2(i,j,kk,6+1) = trans_band2(i,j,kk,6+1)*tch4n2oe(i,j,kk,1)
              end do
           end do
        end do
      endif 

!--------------------------------------------------------------------
!    add cfc transmissivities if species which absorb in this fre-
!    quency range are present.
!--------------------------------------------------------------------
        if (Lw_control%do_cfc) then
          call cfc_indx8_part (8, Optical, tcfc8, k)
          do kk = k+1,KE+1
             do j = 1,size(trans_band1(:,:,:,:),2)
                do i = 1,size(trans_band1(:,:,:,:),1)
                   trans_band1(i,j,kk,6+1) = trans_band1(i,j,kk,6+1)*tcfc8(i,j,kk)
                end do
             end do
          end do
          do kk = k+1,KE+1
             do j = 1,size(trans_band2(:,:,:,:),2)
                do i = 1,size(trans_band2(:,:,:,:),1)
                   trans_band2(i,j,kk,6+1) = trans_band2(i,j,kk,6+1)*tcfc8(i,j,kk)
                end do
             end do
          end do
        endif

!--------------------------------------------------------------------
!     compute aerosol transmission function for 1200-1400 cm-1 region
!    (as quotient of 2 exponentials)
!     taero8kp(k) contains the (k+1,k) transmissivities for all k
!     in the 1200-1400 cm-1 frequency range.
!---------------------------------------------------------------------
      if (including_aerosols) then
        do kk = 1,size(totaer_tmp(:,:,:),3)
           do j = 1,size(totaer_tmp(:,:,:),2)
              do i = 1,size(totaer_tmp(:,:,:),1)
                 totaer_tmp(i,j,kk) = Optical%totaerooptdep(i,j,kk,8)
              end do
           end do
        end do
       do kk = KS,KE+1
          do j = 1,size(taero8(:,:,:),2)
             do i = 1,size(taero8(:,:,:),1)
                taero8(i,j,kk) = EXP(-1.0E+00*totaer_tmp(i,j,kk))
             end do
          end do
       end do
          do kp = k+1,KE+1
            do j = 1,size(taero8kp(:,:,:),2)
               do i = 1,size(taero8kp(:,:,:),1)
                  taero8kp(i,j,kp) = taero8(i,j,kp)/taero8(i,j,k)
               end do
            end do
          enddo
          do kk = k+1,KE+1
             do j = 1,size(trans_band1(:,:,:,:),2)
                do i = 1,size(trans_band1(:,:,:,:),1)
                   trans_band1(i,j,kk,6+1) = trans_band1(i,j,kk,6+1)*  &
                  taero8kp(i,j,kk)
                end do
             end do
          end do
          do kk = k+1,KE+1
             do j = 1,size(trans_band2(:,:,:,:),2)
                do i = 1,size(trans_band2(:,:,:,:),1)
                   trans_band2(i,j,kk,6+1) = trans_band2(i,j,kk,6+1)*  &
                  taero8kp(i,j,kk)
                end do
             end do
          end do
        endif
      endif  ! (nbtrge > 0)

!--------------------------------------------------------------------

end subroutine e290



!####################################################################
! <SUBROUTINE NAME="esfc">
!  <OVERVIEW>
!   Subroutine to compute thermal layer emissivity using pre computed
!   look up tables
!  </OVERVIEW>
!  <TEMPLATE>
!   call esfc  (Atmos_input,         emspec,             Optical, &
!               emspecf, tch4n2oe, tcfc8 )
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data such as temperature and flux level temp
!  </IN>
!  <OUT NAME="emspec" TYPE="real">
!   Emissivity of thermal layers
!  </OUT>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth of thermal layers
!  </INOUT>
!  <OUT NAME="emspecf" TYPE="real">
!   Emissivity of thermal layers including effects of minor gas species
!  </OUT>
!  <IN NAME="tch4n2oe" TYPE="real">
!   CH4 and N2O transmission function
!  </IN>
!  <INOUT NAME="tcfc8" TYPE="real">
!   CFC transmission function
!  </INOUT>
! </SUBROUTINE>
!
subroutine esfc (Atmos_input, emspec, Optical, emspecf, tch4n2oe, tcfc8 ) 
   
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

type(atmos_input_type),    intent(in)    :: Atmos_input
real, dimension (:,:,:),   intent(out)   :: emspec
type(optical_path_type),   intent(inout) :: Optical
real, dimension (:,:,:,:), intent(out)   :: emspecf
real, dimension (:,:,:,:), intent(in)    :: tch4n2oe
real, dimension (:,:,:),   intent(inout) :: tcfc8   
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  intent(in)variables:
!    
!     Atmos_input
!     tch4n2oe
!
!  intent(inout) variables:
!
!     Optical
!     tcfc8
!
!  intent(out) variables:
!
!     emspec
!     emspecf
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables

      integer :: i,j,k,kk,m



      real, dimension (size(Atmos_input%temp,1),   &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)) :: &
                                     temp, tflux, tpl1, tpl2, dte1, &
                                     dte2, dxsp, ylog, dysp, emiss, &
                                     emd1, emd2, dysp1

      integer, dimension (size(Atmos_input%temp,1),   &
                          size(Atmos_input%temp,2), &
                          size(Atmos_input%temp,3)) :: &
                                        ixsp, iysp, iysp1, ixoe1, ixoe2
      real, dimension (size(Atmos_input%temp,1),   &
                       size(Atmos_input%temp,2),   &
                       size(Atmos_input%temp,3)) :: ttmp

      real, dimension (size(Atmos_input%temp,1),   &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3), NBTRGE) ::    &
                                                  emissf, emd2f,  emd1f

!--------------------------------------------------------------------
!   local variables:
!
!      temp
!      tflux
!      tpl1
!      tpl2
!      dte1
!      dte2 
!      dxsp
!      ylog
!      dysp
!      dysp1
!      emiss
!      emd1
!      emd2
!      ixsp
!      iysp
!      iysp1
!      ixoe1
!      ixoe2
!      emissf
!      emd2f
!      emd1f
!      m,k
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

     do kk = 1,size(tflux(:,:,:),3)
        do j = 1,size(tflux(:,:,:),2)
           do i = 1,size(tflux(:,:,:),1)
              tflux(i,j,kk) = Atmos_input%tflux(i,j,kk)
           end do
        end do
     end do
      do kk = 1,size(temp(:,:,:),3)
         do j = 1,size(temp(:,:,:),2)
            do i = 1,size(temp(:,:,:),1)
               temp(i,j,kk) = Atmos_input%temp(i,j,kk)
            end do
         end do
      end do
 


      do j = 1,size(tpl1(:,:,:),2)
         do i = 1,size(tpl1(:,:,:),1)
            tpl1(i,j,KS) = temp(i,j,KE)
         end do
      end do
     do kk = KS+1,KE
        do j = 1,size(tpl1(:,:,:),2)
           do i = 1,size(tpl1(:,:,:),1)
              tpl1(i,j,kk) = tflux(i,j,kk)
           end do
        end do
     end do
     do j = 1,size(tpl1(:,:,:),2)
        do i = 1,size(tpl1(:,:,:),1)
           tpl1(i,j,KE+1) = 0.5E+00*(tflux(i,j,KE+1) +   &
                                     temp(i,j,KE))
        end do
     end do
  do kk = KS+1,KE
     do j = 1,size(tpl2(:,:,:),2)
        do i = 1,size(tpl2(:,:,:),1)
           tpl2(i,j,kk) = tflux(i,j,kk)
        end do
     end do
  end do
    do j = 1,size(tpl2(:,:,:),2)
       do i = 1,size(tpl2(:,:,:),1)
          tpl2(i,j,KE+1) = 0.5E+00*(tflux(i,j,KE) +    &
                                temp(i,j,KE))
       end do
    end do


!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
  call locate_in_table(temp_1, temp, dte1, ixoe1, KS, KE+1)
  call locate_in_table(temp_1, tflux, dte2, ixoe2, KS, KE+1)

  ttmp(:,:,:)=ixoe2(:,:,:)
  do kk = KS,KE
     do j = 1,size(ixoe2(:,:,:),2)
        do i = 1,size(ixoe2(:,:,:),1)
           ixoe2(i,j,kk) = ttmp(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  ttmp(:,:,:)=dte2 (:,:,:)
  do kk = KS,KE
     do j = 1,size(dte2(:,:,:),2)
        do i = 1,size(dte2(:,:,:),1)
           dte2(i,j,kk) = ttmp(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  do j = 1,size(ixoe2(:,:,:),2)
     do i = 1,size(ixoe2(:,:,:),1)
        ixoe2(i,j,KE+1) = ixoe1(i,j,KE)
     end do
  end do
  do j = 1,size(dte2(:,:,:),2)
     do i = 1,size(dte2(:,:,:),1)
        dte2(i,j,KE+1) = dte1 (i,j,KE)
     end do
  end do




      do j = 1,size(ixsp(:,:,:),2)
         do i = 1,size(ixsp(:,:,:),1)
            ixsp(i,j,KE) = ixoe2(i,j,KE-1)
         end do
      end do
      do j = 1,size(ixsp(:,:,:),2)
         do i = 1,size(ixsp(:,:,:),1)
            ixsp(i,j,KE+1) = ixoe1(i,j,KE-1)
         end do
      end do
      do j = 1,size(dxsp(:,:,:),2)
         do i = 1,size(dxsp(:,:,:),1)
            dxsp(i,j,KE) = dte2(i,j,KE-1)
         end do
      end do
      do j = 1,size(dxsp(:,:,:),2)
         do i = 1,size(dxsp(:,:,:),1)
            dxsp(i,j,KE+1) = dte1(i,j,KE-1)
         end do
      end do

    if (Lw_control%do_h2o) then
      do j = 1,size(ylog(:,:,:),2)
         do i = 1,size(ylog(:,:,:),1)
            ylog(i,j,KE  ) = ALOG10(Optical%var2(i,j,KE))
         end do
      end do
      do j = 1,size(ylog(:,:,:),2)
         do i = 1,size(ylog(:,:,:),1)
            ylog(i,j,KE+1) = ALOG10(Optical%var2(i,j,KE) + Optical%empl1(i,j,KE))
         end do
      end do

      call locate_in_table (mass_1, ylog, dysp, iysp, KE, KE+1)
      iysp(:,:,KE:KE+1) = iysp(:,:,KE:KE+1) + 1

!--------------------------------------------------------------------
!     compute exchange terms in the flux equation for two terms used
!     for nearby layer computations.
!--------------------------------------------------------------------
      call looktab (tab2, ixsp, iysp, dxsp, dysp, emiss, KE, KE+1)

    else
      iysp1(:,:,KE:KE+1) = 1
      dysp1(:,:,KE:KE+1) = 0.0
      call looktab (tab2, ixsp, iysp1, dxsp, dysp1, emiss, KE, KE+1)
    endif

!----------------------------------------------------------------------
!     obtain index values of h2o pressure-scaled mass for each band
!     in the 1200-1400 range.
!---------------------------------------------------------------------
      if (nbtrge > 0) then
        do m=1,NBTRGE
    if (Lw_control%do_h2o) then
          do j = 1,size(ylog(:,:,:),2)
             do i = 1,size(ylog(:,:,:),1)
                ylog(i,j,KE  ) = ALOG10(Optical%vrpfh2o(i,j,KE,m))
             end do
          end do
          do j = 1,size(ylog(:,:,:),2)
             do i = 1,size(ylog(:,:,:),1)
                ylog(i,j,KE+1) = ALOG10(Optical%vrpfh2o(i,j,KE,m) + Optical%empl1f(i,j,KE,m))
             end do
          end do

          call locate_in_table (mass_1, ylog, dysp, iysp, KE, KE+1)
          iysp(:,:,KE:KE+1) = iysp(:,:,KE:KE+1) + 1

!-----------------------------------------------------------------------
!     compute exchange terms in the flux equation for two terms used
!     for nearby layer computations.
!---------------------------------------------------------------------
          call looktab (tab2a, ixsp, iysp, dxsp, dysp, &
                        emissf(:,:,:,m), KE, KE+1, m)
   else
        iysp1(:,:,KE:KE+1) = 1
        dysp1(:,:,KE:KE+1) = 0.0
        call looktab (tab2a, ixsp, iysp1, dxsp, dysp1, &
                      emissf(:,:,:,m), KE, KE+1, m)
   endif
        enddo
      endif
!-----------------------------------------------------------------------
!     compute nearby layer transmissivities for h2o.
!--------------------------------------------------------------------
    if (Lw_control%do_h2o) then
      call locate_in_table (temp_1, tpl1, dxsp, ixsp, KS, KE+1)
      do kk = KS,KE+1
         do j = 1,size(ylog(:,:,:),2)
            do i = 1,size(ylog(:,:,:),1)
               ylog(i,j,kk) = ALOG10(Optical%empl1(i,j,kk))
            end do
         end do
      end do
      call locate_in_table (mass_1, ylog, dysp, iysp, KS, KE+1)
      iysp(:,:,KS:KE+1) = iysp(:,:,KS:KE+1) + 1
      call looktab (tab3, ixsp, iysp, dxsp, dysp, emd1, KS, KE+1)
   else
     call locate_in_table (temp_1, tpl1, dxsp, ixsp, KS, KE+1)
     iysp1(:,:,KS:KE+1) = 1
     dysp1(:,:,KS:KE+1) = 0.0
     call looktab (tab3, ixsp, iysp1, dxsp, dysp1, emd1, KS, KE+1)
   endif

!----------------------------------------------------------------------
!     obtain index values of h2o pressure-scaled mass for each band
!     in the 1200-1400 range.
!------------------------------------------------------------------
      if (nbtrge > 0) then
        do m=1,NBTRGE
   if (Lw_control%do_h2o) then
          do kk = KS,KE+1
             do j = 1,size(ylog(:,:,:),2)
                do i = 1,size(ylog(:,:,:),1)
                   ylog(i,j,kk) = ALOG10(Optical%empl1f(i,j,kk,m))
                end do
             end do
          end do
          call locate_in_table (mass_1, ylog, dysp, iysp, KS, KE+1)
          iysp(:,:,KS:KE+1) = iysp(:,:,KS:KE+1) + 1
          call looktab (tab3a, ixsp, iysp, dxsp, dysp, &
                        emd1f(:,:,:,m), KS, KE+1, m)
    else
      iysp1(:,:,KS:KE+1) = 1
      dysp1(:,:,KS:KE+1) = 0.0
      call looktab (tab3a, ixsp, iysp1, dxsp, dysp1, &
                    emd1f(:,:,:,m), KS, KE+1, m)
    endif
        enddo
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
  if (Lw_control%do_h2o) then
      call locate_in_table (temp_1, tpl2, dxsp, ixsp, KS+1, KE+1)
      do kk = KS+1,KE+1
         do j = 1,size(ylog(:,:,:),2)
            do i = 1,size(ylog(:,:,:),1)
               ylog(i,j,kk) = ALOG10(Optical%empl2(i,j,kk))
            end do
         end do
      end do
      call locate_in_table (mass_1, ylog, dysp, iysp, KS+1, KE+1)
      iysp(:,:,KS+1:KE+1) = iysp(:,:,KS+1:KE+1) + 1
      call looktab (tab3, ixsp, iysp, dxsp, dysp, emd2, KS+1, KE+1)
  else
     call locate_in_table (temp_1, tpl2, dxsp, ixsp, KS+1, KE+1)
     iysp1(:,:,KS+1:KE+1) = 1
     dysp1(:,:,KS+1:KE+1) = 0.0
     call looktab (tab3, ixsp, iysp1, dxsp, dysp1, emd2, KS+1, KE+1)
   endif

!----------------------------------------------------------------------
!     obtain index values of h2o pressure-scaled mass for each band
!     in the 1200-1400 range.
!---------------------------------------------------------------------
      if (nbtrge > 0 ) then
        do m=1,NBTRGE
    if (Lw_control%do_h2o) then
          do kk = KS+1,KE+1
             do j = 1,size(ylog(:,:,:),2)
                do i = 1,size(ylog(:,:,:),1)
                   ylog(i,j,kk) = ALOG10(Optical%empl2f(i,j,kk,m))
                end do
             end do
          end do
          call locate_in_table (mass_1, ylog, dysp, iysp, KS+1, KE+1)
          iysp(:,:,KS+1:KE+1) = iysp(:,:,KS+1:KE+1) + 1
          call looktab (tab3a, ixsp, iysp, dxsp, dysp, &
                        emd2f(:,:,:,m), KS+1, KE+1, m)
    else
      iysp1(:,:,KS+1:KE+1) = 1
      dysp1(:,:,KS+1:KE+1) = 0.0
      call looktab (tab3a, ixsp, iysp1, dxsp, dysp1, &
                    emd2f(:,:,:,m), KS+1, KE+1, m)
    endif
        enddo
      endif

!---------------------------------------------------------------------- 
!     compute nearby layer and special-case transmissivities for
!     emissivity using methods for h2o given in reference (4).
!-------------------------------------------------------------------- 
     if (Lw_control%do_h2o) then   
      do j = 1,size(emspec(:,:,:),2)
         do i = 1,size(emspec(:,:,:),1)
            emspec(i,j,KS     ) = (emd1(i,j,KS)*Optical%empl1(i,j,KS) -    &
                             emd1(i,j,KE+1)*Optical%empl1(i,j,KE+1))/  &
                             Optical%emx1(i,j) + 0.25E+00*(emiss(i,j,KE) +   &
                             emiss(i,j,KE+1))
         end do
      end do
      do j = 1,size(emspec(:,:,:),2)
         do i = 1,size(emspec(:,:,:),1)
            emspec(i,j,KS+1) = 2.0E+00*(emd1(i,j,KS)*Optical%empl1(i,j,KS) -    &
                         emd2(i,j,KE+1)*Optical%empl2(i,j,KE+1))/  &
                           Optical%emx2(i,j)
         end do
      end do
   else
     do j = 1,size(emspec(:,:,:),2)
       do i = 1,size(emspec(:,:,:),1)
         emspec(i,j,KS     ) = (emd1(i,j,KS) - emd1(i,j,KE+1)) /  &
                              (Atmos_input%press(i,j,KE) - Atmos_input%pflux(i,j,KE)) + &
                               0.25E+00*(emiss(i,j,KE) + emiss(i,j,KE+1))
        end do
      end do
      do j = 1,size(emspec(:,:,:),2)
        do i = 1,size(emspec(:,:,:),1)
            emspec(i,j,KS+1) = 2.0E+00*(emd1(i,j,KS) -  emd2(i,j,KE+1)) /  &
                      (Atmos_input%pflux(i,j,KE+1) - Atmos_input%press(i,j,KE))
        end do
      end do
    endif

     if (nbtrge > 0) then
       do m=1,NBTRGE
     if (Lw_control%do_h2o) then
         do j = 1,size(emspecf(:,:,:,:),2)
            do i = 1,size(emspecf(:,:,:,:),1)
               emspecf(i,j,KS,m   ) = (emd1f(i,j,KS,m)*Optical%empl1f(i,j,KS,m) -   &
                              emd1f(i,j,KE+1,m)*Optical%empl1f(i,j,KE+1,m))/   &
                   Optical%emx1f(i,j,m) + 0.25E+00*(emissf(i,j,KE,m) +  &
                             emissf(i,j,KE+1,m))
            end do
         end do
         do j = 1,size(emspecf(:,:,:,:),2)
            do i = 1,size(emspecf(:,:,:,:),1)
               emspecf(i,j,KS+1,m) = 2.0E+00*    &
                                 (emd1f(i,j,KS,m)*Optical%empl1f(i,j,KS,m) -  &
                              emd2f(i,j,KE+1,m)*Optical%empl2f(i,j,KE+1,m)) / &
                              Optical%emx2f(i,j,m)
            end do
         end do
     else
       do j = 1,size(emspecf(:,:,:,:),2)
           do i = 1,size(emspecf(:,:,:,:),1)
               emspecf(i,j,KS,m   ) = (emd1f(i,j,KS,m) - emd1f(i,j,KE+1,m)) / &
                            (Atmos_input%press(i,j,KE) - Atmos_input%pflux(i,j,KE)) + &
                               0.25E+00*(emissf(i,j,KE,m) +  emissf(i,j,KE+1,m))
            end do
          end do
          do j = 1,size(emspecf(:,:,:,:),2)
            do i = 1,size(emspecf(:,:,:,:),1)
              emspecf(i,j,KS+1,m) = 2.0E+00*    &
                                  (emd1f(i,j,KS,m) - emd2f(i,j,KE+1,m)) / &
                          (Atmos_input%pflux(i,j,KE+1) - Atmos_input%press(i,j,KE))
             end do
          end do
        endif

       enddo
     endif

!--------------------------------------------------------------------
!    add the effects of other radiative gases on these flux arrays.
!    the lbl transmissivities imply (at present) NBTRG = NBTRGE = 1).
!    thus, tch4e and tn2oe are obtained directly from the transmission
!    functions. 
!----------------------------------------------------------------------
  if (nbtrge > 0) then
    if (Lw_control%do_ch4 .or. Lw_control%do_n2o) then
      do k=KS,KS+1
        do j = 1,size(emspecf(:,:,:,:),2)
           do i = 1,size(emspecf(:,:,:,:),1)
              emspecf(i,j,K,1) = emspecf(i,j,K,1)*tch4n2oe(i,j,KE+1,1)
           end do
        end do
      end do
     endif 

!--------------------------------------------------------------------
!     add cfc transmissivities if species which absorb in this fre-
!    quency range are present.
!----------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_indx8_part (8, Optical, tcfc8, KE)
        do k=KS,KS+1
          do j = 1,size(emspecf(:,:,:,:),2)
             do i = 1,size(emspecf(:,:,:,:),1)
                emspecf(i,j,K,1) = emspecf(i,j,K,1)*tcfc8(i,j,KE+1)
             end do
          end do
        end do
      endif
    endif ! (nbtrge > 0)

!------------------------------------------------------------------



end subroutine esfc 


!######################################################################
! <SUBROUTINE NAME="enear">
!  <OVERVIEW>
!   Subroutine to compute thermal layer emissivity using pre computed
!   look up tables
!  </OVERVIEW>
!  <TEMPLATE>
!   call enear  (Atmos_input,         emisdg,             Optical, &
!               emisdgf, tch4n2oe, tcfc8 )
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data such as temperature and flux level temp
!  </IN>
!  <OUT NAME="emisdg" TYPE="real">
!   Emissivity of thermal layers
!  </OUT>
!  <INOUT NAME="Optical" TYPE="optical_path_type">
!   Optical depth of thermal layers
!  </INOUT>
!  <OUT NAME="emisdgf" TYPE="real">
!   Emissivity of thermal layers including effects of minor gas species
!  </OUT>
!  <IN NAME="tch4n2oe" TYPE="real">
!   CH4 and N2O transmission function
!  </IN>
!  <INOUT NAME="tcfc8" TYPE="real">
!   CFC transmission function
!  </INOUT>
! </SUBROUTINE>
!
subroutine enear (Atmos_input, emisdg, Optical, emisdgf, tch4n2oe,  &
                  tcfc8) 
   
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

type(atmos_input_type),    intent(in)    ::  Atmos_input
real, dimension (:,:,:),   intent(out)   ::  emisdg 
type(optical_path_type),   intent(inout) ::  Optical
real, dimension (:,:,:,:), intent(out)   ::  emisdgf
real, dimension (:,:,:,:), intent(in)    ::  tch4n2oe
real, dimension (:,:,:),   intent(inout) ::  tcfc8       
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  intent(in) variables:
!
!     Atmos_input
!     tch4n2oe
!
!  intent(inout) variables:
!
!     Optical
!     tcfc8
!
!  intent(out) variables:
!
!     emisdg
!     emisdgf
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables:

      integer   :: i,j,kk,m

      real, dimension (size(emisdg,1), &
                       size(emisdg,2), &
                       size(emisdg,3)) :: dte1, dte2

      integer, dimension (size(emisdg,1), &
                          size(emisdg,2), &
                          size(emisdg,3)) :: ixoe1, ixoe2

      real, dimension (size(emisdg,1), &
                       size(emisdg,2), &
                       size(emisdg,3)) :: ttmp 

      real, dimension (size(Atmos_input%temp,1),   &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)) :: &
                             temp, tflux, tpl1, tpl2, &
                             dxsp, ylog, dysp, dysp1, emd1, emd2

      integer, dimension (size(Atmos_input%temp,1),   &
                          size(Atmos_input%temp,2), &
                          size(Atmos_input%temp,3)) :: &
                                                       ixsp, iysp, iysp1

      real, dimension (size(Atmos_input%temp,1),   &
                       size(Atmos_input%temp,2), &
                         size(Atmos_input%temp,3), NBTRGE) ::    &
                            emd2f,  emd1f

!--------------------------------------------------------------------
!   local variables:
!
!      dte1
!      dte2
!      ixoe1
!      ixoe2 
!      temp
!      tflux
!      tpl1
!      tpl2
!      dxsp
!      ylog
!      dysp
!      dysp1
!      emiss
!      emd1
!      emd2
!      ixsp
!      iysp
!      iysp1
!      emissf
!      emd2f
!      emd1f
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
     do kk = 1,size(tflux(:,:,:),3)
        do j = 1,size(tflux(:,:,:),2)
           do i = 1,size(tflux(:,:,:),1)
              tflux(i,j,kk) = Atmos_input%tflux(i,j,kk)
           end do
        end do
     end do
      do kk = 1,size(temp(:,:,:),3)
         do j = 1,size(temp(:,:,:),2)
            do i = 1,size(temp(:,:,:),1)
               temp(i,j,kk) = Atmos_input%temp(i,j,kk)
            end do
         end do
      end do
 


      do j = 1,size(tpl1(:,:,:),2)
         do i = 1,size(tpl1(:,:,:),1)
            tpl1(i,j,KS) = temp(i,j,KE)
         end do
      end do
     do kk = KS+1,KE
        do j = 1,size(tpl1(:,:,:),2)
           do i = 1,size(tpl1(:,:,:),1)
              tpl1(i,j,kk) = tflux(i,j,kk)
           end do
        end do
     end do
     do j = 1,size(tpl1(:,:,:),2)
        do i = 1,size(tpl1(:,:,:),1)
           tpl1(i,j,KE+1) = 0.5E+00*(tflux(i,j,KE+1) +   &
                                     temp(i,j,KE))
        end do
     end do
  do kk = KS+1,KE
     do j = 1,size(tpl2(:,:,:),2)
        do i = 1,size(tpl2(:,:,:),1)
           tpl2(i,j,kk) = tflux(i,j,kk)
        end do
     end do
  end do
    do j = 1,size(tpl2(:,:,:),2)
       do i = 1,size(tpl2(:,:,:),1)
          tpl2(i,j,KE+1) = 0.5E+00*(tflux(i,j,KE) +    &
                                temp(i,j,KE))
       end do
    end do


!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
  call locate_in_table(temp_1, temp, dte1, ixoe1, KS, KE+1)
  call locate_in_table(temp_1, tflux, dte2, ixoe2, KS, KE+1)

  ttmp(:,:,:)=ixoe2(:,:,:)
  do kk = KS,KE
     do j = 1,size(ixoe2(:,:,:),2)
        do i = 1,size(ixoe2(:,:,:),1)
           ixoe2(i,j,kk) = ttmp(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  ttmp(:,:,:)=dte2 (:,:,:)
  do kk = KS,KE
     do j = 1,size(dte2(:,:,:),2)
        do i = 1,size(dte2(:,:,:),1)
           dte2(i,j,kk) = ttmp(i,j,kk+KS+1-(KS))
        end do
     end do
  end do
  do j = 1,size(ixoe2(:,:,:),2)
     do i = 1,size(ixoe2(:,:,:),1)
        ixoe2(i,j,KE+1) = ixoe1(i,j,KE)
     end do
  end do
  do j = 1,size(dte2(:,:,:),2)
     do i = 1,size(dte2(:,:,:),1)
        dte2(i,j,KE+1) = dte1 (i,j,KE)
     end do
  end do




      do j = 1,size(ixsp(:,:,:),2)
         do i = 1,size(ixsp(:,:,:),1)
            ixsp(i,j,KE) = ixoe2(i,j,KE-1)
         end do
      end do
      do j = 1,size(ixsp(:,:,:),2)
         do i = 1,size(ixsp(:,:,:),1)
            ixsp(i,j,KE+1) = ixoe1(i,j,KE-1)
         end do
      end do
      do j = 1,size(dxsp(:,:,:),2)
         do i = 1,size(dxsp(:,:,:),1)
            dxsp(i,j,KE) = dte2(i,j,KE-1)
         end do
      end do
      do j = 1,size(dxsp(:,:,:),2)
         do i = 1,size(dxsp(:,:,:),1)
            dxsp(i,j,KE+1) = dte1(i,j,KE-1)
         end do
      end do

!--------------------------------------------------------------------
!     compute exchange terms in the flux equation for two terms used
!     for nearby layer computations.
!     obtain index values of h2o pressure-scaled mass for each band
!     in the 1200-1400 range.
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!     compute nearby layer transmissivities for h2o.
!--------------------------------------------------------------------
   if (Lw_control%do_h2o) then
      call locate_in_table (temp_1, tpl1, dxsp, ixsp, KS, KE+1)
      do kk = KS,KE+1
         do j = 1,size(ylog(:,:,:),2)
            do i = 1,size(ylog(:,:,:),1)
               ylog(i,j,kk) = ALOG10(Optical%empl1(i,j,kk))
            end do
         end do
      end do
      call locate_in_table (mass_1, ylog, dysp, iysp, KS, KE+1)
      iysp(:,:,KS:KE+1) = iysp(:,:,KS:KE+1) + 1
      call looktab (tab3, ixsp, iysp, dxsp, dysp, emd1, KS, KE+1)
   else
      call locate_in_table (temp_1, tpl1, dxsp, ixsp, KS, KE+1)
      iysp1(:,:,KS:KE+1) = 1
      dysp1(:,:,KS:KE+1) = 0.0
      call looktab (tab3, ixsp, iysp1, dxsp, dysp1, emd1, KS, KE+1)
   endif

!----------------------------------------------------------------------
!     obtain index values of h2o pressure-scaled mass for each band
!     in the 1200-1400 range.
!------------------------------------------------------------------
      if (nbtrge > 0) then
        do m=1,NBTRGE
    if (Lw_control%do_h2o) then
          do kk = KS,KE+1
             do j = 1,size(ylog(:,:,:),2)
                do i = 1,size(ylog(:,:,:),1)
                   ylog(i,j,kk) = ALOG10(Optical%empl1f(i,j,kk,m))
                end do
             end do
          end do
          call locate_in_table (mass_1, ylog, dysp, iysp, KS, KE+1)
          iysp(:,:,KS:KE+1) = iysp(:,:,KS:KE+1) + 1
          call looktab (tab3a, ixsp, iysp, dxsp, dysp, &
                        emd1f(:,:,:,m), KS, KE+1, m)
    else
          iysp1(:,:,KS:KE+1) = 1
          dysp1(:,:,KS:KE+1) = 0.0
          call looktab (tab3a, ixsp, iysp1, dxsp, dysp1, &
                        emd1f(:,:,:,m), KS, KE+1, m)
    endif
        enddo
      endif

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------
   if (Lw_control%do_h2o) then
      call locate_in_table (temp_1, tpl2, dxsp, ixsp, KS+1, KE+1)
      do kk = KS+1,KE+1
         do j = 1,size(ylog(:,:,:),2)
            do i = 1,size(ylog(:,:,:),1)
               ylog(i,j,kk) = ALOG10(Optical%empl2(i,j,kk))
            end do
         end do
      end do
      call locate_in_table (mass_1, ylog, dysp, iysp, KS+1, KE+1)
      iysp(:,:,KS+1:KE+1) = iysp(:,:,KS+1:KE+1) + 1
      call looktab (tab3, ixsp, iysp, dxsp, dysp, emd2, KS+1, KE+1)
   else
      call locate_in_table (temp_1, tpl2, dxsp, ixsp, KS+1, KE+1)
      iysp1(:,:,KS+1:KE+1) = 1
      dysp1(:,:,KS+1:KE+1) = 0.0
      call looktab (tab3, ixsp, iysp1, dxsp, dysp1, emd2, KS+1, KE+1)
   endif

!----------------------------------------------------------------------
!     obtain index values of h2o pressure-scaled mass for each band
!     in the 1200-1400 range.
!---------------------------------------------------------------------
      if (nbtrge > 0) then
        do m=1,NBTRGE
   if (Lw_control%do_h2o) then
          do kk = KS+1,KE+1
             do j = 1,size(ylog(:,:,:),2)
                do i = 1,size(ylog(:,:,:),1)
                   ylog(i,j,kk) = ALOG10(Optical%empl2f(i,j,kk,m))
                end do
             end do
          end do
          call locate_in_table (mass_1, ylog, dysp, iysp, KS+1, KE+1)
          iysp(:,:,KS+1:KE+1) = iysp(:,:,KS+1:KE+1) + 1
          call looktab (tab3a, ixsp, iysp, dxsp, dysp, &
                        emd2f(:,:,:,m), KS+1, KE+1, m)
    else
          iysp1(:,:,KS+1:KE+1) = 1
          dysp1(:,:,KS+1:KE+1) = 0.0
          call looktab (tab3a, ixsp, iysp1, dxsp, dysp1, &
                        emd2f(:,:,:,m), KS+1, KE+1, m)
    endif
        enddo
      endif

!---------------------------------------------------------------------- 
!     compute nearby layer and special-case transmissivities for
!     emissivity using methods for h2o given in reference (4).
!-------------------------------------------------------------------- 
      do kk = KS+1,KE
         do j = 1,size(emisdg(:,:,:),2)
            do i = 1,size(emisdg(:,:,:),1)
               emisdg(i,j,kk) = emd2(i,j,kk) + emd1(i,j,kk)
            end do
         end do
      end do
      do j = 1,size(emisdg(:,:,:),2)
         do i = 1,size(emisdg(:,:,:),1)
            emisdg(i,j,KE+1) = 2.0E+00*emd1(i,j,KE+1)
         end do
      end do

     if (nbtrge > 0) then
       do m=1,NBTRGE
         do kk = KS+1,KE
            do j = 1,size(emisdgf(:,:,:,:),2)
               do i = 1,size(emisdgf(:,:,:,:),1)
                  emisdgf(i,j,kk,m) = &
                            emd2f(i,j,kk,m) + emd1f(i,j,kk,m)
               end do
            end do
         end do
         do j = 1,size(emisdgf(:,:,:,:),2)
            do i = 1,size(emisdgf(:,:,:,:),1)
               emisdgf(i,j,KE+1,m) = 2.0E+00*emd1f(i,j,KE+1,m)
            end do
         end do
       enddo
     endif

!--------------------------------------------------------------------
!    add the effects of other radiative gases on these flux arrays.
!    the lbl transmissivities imply (at present) NBTRG = NBTRGE = 1).
!    thus, tch4e and tn2oe are obtained directly from the transmission
!    functions. 
!----------------------------------------------------------------------
  if (nbtrge > 0) then
    if (Lw_control%do_ch4 .or. Lw_control%do_n2o) then
      do kk = KS+1,KE+1
         do j = 1,size(emisdgf(:,:,:,:),2)
            do i = 1,size(emisdgf(:,:,:,:),1)
               emisdgf(i,j,kk,1) = emisdgf(i,j,kk,1) *   &
                                 tch4n2oe(i,j,kk,1)
            end do
         end do
      end do
     endif 

!--------------------------------------------------------------------
!     add cfc transmissivities if species which absorb in this fre-
!    quency range are present.
!----------------------------------------------------------------------
      if (Lw_control%do_cfc) then
        call cfc_indx8_part (8, Optical, tcfc8, KE)
        do kk = KS+1,KE+1
           do j = 1,size(emisdgf(:,:,:,:),2)
              do i = 1,size(emisdgf(:,:,:,:),1)
                 emisdgf(i,j,kk,1) = emisdgf(i,j,kk,1) *   &
                                   tcfc8(i,j,kk)
              end do
           end do
        end do
      endif
    endif ! (nbtrge > 0)

!------------------------------------------------------------------



end subroutine enear



!####################################################################
! <SUBROUTINE NAME="co2_source_calc">
!  <OVERVIEW>
!   Subroutine to calculate CO2 source function
!  </OVERVIEW>
!  <TEMPLATE>
!   call co2_source_calc (Atmos_input, Rad_gases, sorc,  Gas_tf, &
!                         source_band, dsrcdp_band)
!  </TEMPLATE>
!  <IN NAME="Atmos_input" TYPE="atmos_input_type">
!   Atmospheric input data
!  </IN>
!  <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!   Radiative gases properties
!  </IN>
!  <OUT NAME="sorc" TYPE="real">
!   CO2 source function results
!  </OUT>
!  <IN NAME="Gas_tf" TYPE="gas_tf_type">
!   Gas transmission functions
!  </IN>
!  <OUT NAME="source_band" TYPE="real">
!   CO2 source function bands
!  </OUT>
!  <OUT NAME="dsrcdp_band" TYPE="real">
!   Difference of source function between nearby thermal layers
!  </OUT>
! </SUBROUTINE>
!
subroutine co2_source_calc (Atmos_input, Rad_gases, sorc,  Gas_tf, &
                            source_band, dsrcdp_band)

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------

type(atmos_input_type),     intent(in)   ::  Atmos_input
type(radiative_gases_type), intent(in)   ::  Rad_gases
real, dimension(:,:,:,:),   intent(out)  ::  sorc               
type(gas_tf_type),          intent(in)   ::  Gas_tf
real, dimension(:,:,:,:),   intent(out)  ::  source_band, dsrcdp_band  

!----------------------------------------------------------------------
!  intent(in) variables:
!
!     Atmos_input
!     Rad_gases
!     Gas_tf
!
!  intent(out) variables:
!
!     sorc
!     source_band
!     dsrcdp_band
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(Atmos_input%temp,1),   &
                       size(Atmos_input%temp,2), &
                       size(Atmos_input%temp,3)) ::   &
                                              dte1, press, pflux, temp

      integer, dimension (size(Atmos_input%temp,1),   &
                          size(Atmos_input%temp,2), &
                          size(Atmos_input%temp,3)) ::          ixoe1

      integer            ::   i,j,kk
      integer            ::   n, ioffset, m
      integer            :: nbly                    
      real               :: rrvco2

!---------------------------------------------------------------------
!  local variables:
!
!     dte1
!     press
!     pflux
!     temp
!     ixoe1
!     n
!     ioffset
!     m
!     nbly
!     rrvco2
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
      ioffset = Lw_parameters%offset
      nbly = 16+ioffset

!--------------------------------------------------------------------
 !  convert press and pflux to cgs.
        do kk = 1,size(press(:,:,:),3)
           do j = 1,size(press(:,:,:),2)
              do i = 1,size(press(:,:,:),1)
                 press(i,j,kk) = 10.0*Atmos_input%press(i,j,kk)
              end do
           end do
        end do
        do kk = 1,size(pflux(:,:,:),3)
           do j = 1,size(pflux(:,:,:),2)
              do i = 1,size(pflux(:,:,:),1)
                 pflux(i,j,kk) = 10.0*Atmos_input%pflux(i,j,kk)
              end do
           end do
        end do
     do kk = 1,size(temp(:,:,:),3)
        do j = 1,size(temp(:,:,:),2)
           do i = 1,size(temp(:,:,:),1)
              temp(i,j,kk) = Atmos_input%temp(i,j,kk)
           end do
        end do
     end do
      rrvco2 = Rad_gases%rrvco2

!----------------------------------------------------------------------
!     compute source function for frequency bands (9+ioffset to NBLY-1) 
!     at layer temperatures using table lookup.
!----------------------------------------------------------------------
      call locate_in_table(temp_1, temp, dte1, ixoe1, KS, Ke+1)
      do n=9+ioffset,NBLY-1
        call looktab (tabsr, ixoe1, dte1,   & 
                      sorc(:,:,:,n-ioffset-8), KS, ke+1, n)
      enddo

!-----------------------------------------------------------------------
!     compute the nlte source function for co2.
!-----------------------------------------------------------------------
      if (do_nlte) then
        call nlte (pflux, press, rrvco2, sorc, Gas_tf)
      endif

!----------------------------------------------------------------------
!    define "source function" appropriate for emissivity calculations
!    (temp**4), source functions for selected ranges including more 
!    than 1 frequency band (sorc15 for 15 um co2 band)
!    and differences in source functions (deltab) over
!    pressure layers.
!  
!    note: the values of sorc, sorc15, sorcwin, and derivatives 
!    depend on the no. of freq. bands!
!-----------------------------------------------------------------------
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,1) = Atmos_input%temp (i,j,kk+KS-(1))**4
            end do
         end do
      end do
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,2) = sorc(i,j,kk, 1) + &
                             sorc(i,j,kk, 2) + &
                             sorc(i,j,kk, 3 )
            end do
         end do
      end do
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,3) = sorc(i,j,kk,4 )
            end do
         end do
      end do
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,4) = sorc(i,j,kk,5 )
            end do
         end do
      end do
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,5) = sorc(i,j,kk, 6 )
            end do
         end do
      end do
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,6) = sorc(i,j,kk,7 )
            end do
         end do
      end do
      do m=1,NBTRGE
      do kk = 1,size(source_band(:,:,:,:),3)
         do j = 1,size(source_band(:,:,:,:),2)
            do i = 1,size(source_band(:,:,:,:),1)
               source_band(i,j,kk,6+m) = source_band(i,j,kk,1)
            end do
         end do
      end do
      end do

      do n=1, 6+NBTRGE       
       do kk = KS+1,KE+1
          do j = 1,size(dsrcdp_band(:,:,:,:),2)
             do i = 1,size(dsrcdp_band(:,:,:,:),1)
                dsrcdp_band(i,j,kk,n) = source_band(i,j,kk,n) - &
                               source_band(i,j,kk+KS-(KS+1),n)
             end do
          end do
       end do
      end do

!-------------------------------------------------------------------


end subroutine co2_source_calc




!#####################################################################
! <SUBROUTINE NAME="nlte">
!  <OVERVIEW>
!   nlte is the present formulation of an nlte calculation of the 
!     source function in the 15 um region (two bands).
!  </OVERVIEW>
!  <DESCRIPTION>
!   nlte is the present formulation of an nlte calculation of the 
!     source function in the 15 um region (two bands).
!
!     the essential theory is:
!
!           phi = C*j
!             j = b + E*phi
!
!     where
!             C = Curtis matrix
!              E = NLTE contribution (diagonal matrix)
!           phi = heating rate vector
!             b = LTE source function vector
!             j = NLTE source function vector
!
!             j = b (by assumption) for pressure layers > ixnltr
!             j = b (by assumption) for pressure layers > ixprnlte
!      E is obtained using a formulation devised by Fels (denoted
!      Ri in his notes).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call nlte (pflux, press, rrvco2, sorc, Gas_tf)
!  </TEMPLATE>
!  <IN NAME="pflux" TYPE="real">
!   pressure values at flux levels.
!  </IN>
!  <IN NAME="press" TYPE="real">
!   pressure cordinates
!  </IN>
!  <IN NAME="rrvco2" TYPE="real">
!   CO2 volumn mixing ratio
!  </IN>
!  <INOUT NAME="sorc" TYPE="real">
!   CO2 source function to be calculated
!  </INOUT>
!  <IN NAME="Gas_tf" TYPE="gas_tf_type">
!   Gas transmission function 
!  </IN>
! </SUBROUTINE>
!
subroutine nlte (pflux, press, rrvco2, sorc, Gas_tf)

!-----------------------------------------------------------------------
!     nlte is the present formulation of an nlte calculation of the 
!     source function in the 15 um region (two bands).
!
!     the essential theory is:
!
!           phi = C*j
!             j = b + E*phi
!
!     where
!             C = Curtis matrix
!              E = NLTE contribution (diagonal matrix)
!           phi = heating rate vector
!             b = LTE source function vector
!             j = NLTE source function vector
!
!             j = b (by assumption) for pressure layers > ixnltr
!             j = b (by assumption) for pressure layers > ixprnlte
!      E is obtained using a formulation devised by Fels (denoted
!      Ri in his notes).
!
!     author: m. d. schwarzkopf
!
!     revised: 1/1/93
!
!     certified:  radiation version 1.0
!-----------------------------------------------------------------------

real, dimension (:,:,:),   intent(in)    ::  pflux, press
real,                      intent(in)    ::  rrvco2
real, dimension (:,:,:,:), intent(inout) ::  sorc               
type(gas_tf_type),         intent(in)    :: Gas_tf

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     pflux
!     press
!     rrvco2
!     Gas_tf
!
!  intent(inout) variables:
!
!     sorc
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:

      real, dimension (size(press,1), size(press,2), &
                       ixprnlte) ::  &
                                ag, az, bdenom, cdiag, &
                                                tcoll, phifx, phivar

      real, dimension (size(press,1), size(press,2), &
                       ixprnlte, NBCO215) ::  &
                                    fnlte
      real, dimension (size(press,1), size(press,2), &
                       size(press,3)-1, ixprnlte ) ::  &
                                     cmtrx

      real                                   :: degen = 0.5
      integer                                :: i,j,kk
      integer                                :: n, k, inb, kp, ioffset

!---------------------------------------------------------------------
!  local variables:
!
!     ag
!     az
!     bdenom
!     cdiag
!     tcoll
!     phifx     fixed portion of PHI (contributions from
!               layers > ixnltr, where j(k) = b(k))
!               layers > ixprnlte, where j(k) = b(k))
!     phivar    varying portion of PHI (contributions
!               from layers <= ixprnlte).
!               from layers <= ixnltr).
!     fnlte     NLTE contribution: (E in above notes)
!     cmtrx
!     degen     degeneracy factor (= 0.5)
!     n
!     k
!     inb
!     kp
!     ioffset
!
!-----------------------------------------------------------------------
 
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!---------------------------------------------------------------------
      ioffset =  Lw_parameters%offset

!--------------------------------------------------------------------

!-----------------------------------------------------------------------
!     compute curtis matrix for both frequency bands.
!-----------------------------------------------------------------------
      call co2curt (pflux, cmtrx, Gas_tf)

      do k=KS,ixprnlte
        do j = 1,size(cdiag(:,:,:),2)
           do i = 1,size(cdiag(:,:,:),1)
              cdiag(i,j,k) = cmtrx(i,j,k,k)
           end do
        end do
      end do

!-----------------------------------------------------------------------
!   collisional relaxation time (see fels notes for "tcoll")
!-----------------------------------------------------------------------
      do k=KS,ixprnlte
        do j = 1,size(tcoll(:,:,:),2)
           do i = 1,size(tcoll(:,:,:),1)
              tcoll(i,j,k) = degen*1.5E-05*press(i,j,KE+1)/   &
                       (seconds_per_day*press(i,j,k)) 
           end do
        end do
      end do

!-----------------------------------------------------------------------
!   compute NLTE contribution for each band at each pressure level
!   <= ixprnlte. fnlte = zero by assumption at other levels.
!-----------------------------------------------------------------------
      do n=1,NBCO215
        do kk = KS,ixprnlte
           do j = 1,size(fnlte(:,:,:,:),2)
              do i = 1,size(fnlte(:,:,:,:),1)
                 fnlte(i,j,kk,n) = 3.5E+00*tcoll(i,j,kk)*  &
                                    c1b7(n)/(rrvco2*c2b7(n)) 
              end do
           end do
        end do
      enddo

!-----------------------------------------------------------------------
!     begin computations for (NBCO215) bands in 15um range.
!-----------------------------------------------------------------------
      do inb = 1,NBCO215
        do kk = KS,ixprnlte
           do j = 1,size(bdenom(:,:,:),2)
              do i = 1,size(bdenom(:,:,:),1)
                 bdenom(i,j,kk) = 1.0E+00/   &
              (1.0E+00 - fnlte(i,j,kk,inb)*   &
                        cdiag(i,j,kk))
              end do
           end do
        end do
        do kk = KS,ixprnlte
           do j = 1,size(phifx(:,:,:),2)
              do i = 1,size(phifx(:,:,:),1)
                 phifx(i,j,kk) = 0.0E+00
              end do
           end do
        end do
        do k=KS,ixprnlte
          do kp=ixprnlte+1,KE
            do j = 1,size(phifx(:,:,:),2)
               do i = 1,size(phifx(:,:,:),1)
                  phifx(i,j,k) = phifx(i,j,k) +   &
                           cmtrx(i,j,kp,k)*sorc(i,j,kp,inb           )
               end do
            end do
          end do
        end do
        do kk = KS,ixprnlte
           do j = 1,size(az(:,:,:),2)
              do i = 1,size(az(:,:,:),1)
                 az(i,j,kk) = sorc (i,j,kk,inb           ) +  &
                     fnlte(i,j,kk,inb)*phifx(i,j,kk)
              end do
           end do
        end do

!----------------------------------------------------------------------
!     first iteration. (J(k) = B(k)) as initial guess)
!-----------------------------------------------------------------------
        do kk = KS,ixprnlte
           do j = 1,size(phivar(:,:,:),2)
              do i = 1,size(phivar(:,:,:),1)
                 phivar(i,j,kk) = 0.0E+00
              end do
           end do
        end do
        do k=KS,ixprnlte
          do kp=KS,ixprnlte
            do j = 1,size(phivar(:,:,:),2)
               do i = 1,size(phivar(:,:,:),1)
                  phivar(i,j,k) = phivar(i,j,k) +   &
                            cmtrx(i,j,kp,k)*sorc(i,j,kp,inb           )
               end do
            end do
          end do
        end do
        do kk = KS,ixprnlte
           do j = 1,size(ag(:,:,:),2)
              do i = 1,size(ag(:,:,:),1)
                 ag(i,j,kk) = fnlte(i,j,kk,inb)*   &
                                (phivar(i,j,kk) -   &
                                 cdiag(i,j,kk)*  &
                                 sorc(i,j,kk,inb           ))
              end do
           end do
        end do

        do kk = KS,ixprnlte
           do j = 1,size(sorc(:,:,:,:),2)
              do i = 1,size(sorc(:,:,:,:),1)
                 sorc(i,j,kk,inb           ) = bdenom(i,j,kk)*&
                                               (az(i,j,kk) + &
                                                ag(i,j,kk)) 
              end do
           end do
        end do

!-----------------------------------------------------------------------
!     second iteration.  (J(k) = result of first iteration as guess)
!-----------------------------------------------------------------------
        do kk = KS,ixprnlte
           do j = 1,size(phivar(:,:,:),2)
              do i = 1,size(phivar(:,:,:),1)
                 phivar(i,j,kk) = 0.0E+00
              end do
           end do
        end do
        do k=KS,ixprnlte
          do kp=KS,ixprnlte
            do j = 1,size(phivar(:,:,:),2)
               do i = 1,size(phivar(:,:,:),1)
                  phivar(i,j,k) = phivar(i,j,k) +    &
                            cmtrx(i,j,kp,k)*sorc(i,j,kp,inb           )
               end do
            end do
          end do
        end do
        do kk = KS,ixprnlte
           do j = 1,size(ag(:,:,:),2)
              do i = 1,size(ag(:,:,:),1)
                 ag(i,j,kk) = fnlte(i,j,kk,inb)*   &
                        (phivar(i,j,kk) -   &
            cdiag(i,j,kk)*sorc(i,j,kk,inb           ))
              end do
           end do
        end do

        do kk = KS,ixprnlte
           do j = 1,size(sorc(:,:,:,:),2)
              do i = 1,size(sorc(:,:,:,:),1)
                 sorc(i,j,kk,inb           ) = bdenom(i,j,kk)*&
                                               (az(i,j,kk) +  &
                                                ag(i,j,kk)) 
              end do
           end do
        end do
      enddo

!-----------------------------------------------------------------------


end subroutine nlte



!#####################################################################
! <SUBROUTINE NAME="co2curt">
!  <OVERVIEW>
!   co2curt computes Curtis matrix elements derived from co2
!     transmission functions.
!  </OVERVIEW>
!  <TEMPLATE>
!   call co2curt (pflux, cmtrx, Gas_tf)
!  </TEMPLATE>
!  <IN NAME="pflux" TYPE="real">
!   pressure values at flux levels
!  </IN>
!  <OUT NAME="cmtrx" TYPE="real">
!   Curtis matrix elements
!  </OUT>
!  <IN NAME="Gas_tf" TYPE="gas_tf_type">
!   gas transmission function
!  </IN>
! </SUBROUTINE>
!
subroutine co2curt (pflux, cmtrx, Gas_tf)

!----------------------------------------------------------------------
!     co2curt computes Curtis matrix elements derived from co2
!     transmission functions.
!     functions.
!
!     author: m. d. schwarzkopf
!
!     revised: 8/18/94
!
!     certified:  radiation version 1.0
!
!---------------------------------------------------------------------
real, dimension(:,:, :),   intent(in)  :: pflux                  
real, dimension(:,:, :,:), intent(out) :: cmtrx                  
type(gas_tf_type),         intent(in)  :: Gas_tf

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     pflux
!     Gas_tf
!
!  intent(out) variables:
!
!     cmtrx    cutris matrix.
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
! local variables:

      real, dimension (size(pflux,1),  &
                       size(pflux,2), &
                       size(pflux,3)-1) ::            pdfinv

      real, dimension (size(pflux,1),   &
                       size(pflux,2), &
                       size(pflux,3)) ::              co2row, co2rowp

     integer   :: k, krow, kp
     integer   :: i, j, kk

!---------------------------------------------------------------------
! local variables:
!
!     pdfinv
!     co2row
!     co2rowp
!     k
!     krow
!     kp
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!     compute co2 transmission functions.
!-----------------------------------------------------------------------
      do kk = KS,KE+1
         do j = 1,size(co2row(:,:,:),2)
            do i = 1,size(co2row(:,:,:),1)
               co2row(i,j,kk) = 1.0E+00
            end do
         end do
      end do
      do kk = KS,KE+1
         do j = 1,size(co2rowp(:,:,:),2)
            do i = 1,size(co2rowp(:,:,:),1)
               co2rowp(i,j,kk) = 1.0E+00
            end do
         end do
      end do

!-----------------------------------------------------------------------
!    compute curtis matrix for rows from KS to ixprnlte
!-----------------------------------------------------------------------
      do k = KS,ixprnlte
        krow = k
        do j = 1,size(pdfinv(:,:,:),2)
           do i = 1,size(pdfinv(:,:,:),1)
              pdfinv(i,j,k) = 1.0/(pflux(i,j,k+1) - pflux(i,j,k))
           end do
        end do

        call transcol ( KS, krow, KS, KE+1, co2row, Gas_tf)
        call transcol ( KS, krow+1, KS, KE+1, co2rowp, Gas_tf)
        do kp=KS,KE-1 
          do j = 1,size(cmtrx(:,:,:,:),2)
             do i = 1,size(cmtrx(:,:,:,:),1)
                cmtrx(i,j,kp,k) = radcon*pdfinv(i,j,k)*   &
                            (co2rowp(i,j,kp) - co2rowp(i,j,kp+1) -  &
                             co2row(i,j,kp) + co2row(i,j,kp+1)) 
             end do
          end do
        end do

        do j = 1,size(cmtrx(:,:,:,:),2)
           do i = 1,size(cmtrx(:,:,:,:),1)
              cmtrx(i,j,KE,k) = radcon*pdfinv(i,j,k)*   &
                          (co2rowp(i,j,KE) - co2row(i,j,KE)) 
           end do
        end do
      enddo

!--------------------------------------------------------------------


end subroutine co2curt




!####################################################################

! <SUBROUTINE NAME="co2_time_vary">
!  <OVERVIEW>
!   Calculate CO2 absorption coefficient based on its volume
!   mixing ratio using precomputed lbl tables
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculate CO2 absorption coefficient based on its volume
!   mixing ratio using precomputed lbl tables
!  </DESCRIPTION>
!  <TEMPLATE>
!   call co2_time_vary ( rrvco2 )
!  </TEMPLATE>
!  <IN NAME="rrvco2" TYPE="real">
!   CO2 volume mixing ratio
!  </IN>
! </SUBROUTINE>
!
subroutine co2_time_vary ( rrvco2 )

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real, intent(in   )    ::  rrvco2

!---------------------------------------------------------------------
!  intent(in) variables:
!
!     rrvco2
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:

      real    ::    co2_vmr   !

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
        co2_vmr = rrvco2*1.0E+06

!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
        call co2_lblinterp  (co2_vmr            )

!--------------------------------------------------------------------


end subroutine co2_time_vary



!####################################################################
! <SUBROUTINE NAME="ch4_time_vary">
!  <OVERVIEW>
!   Calculate CH4 and N2O absorption coefficients from their
!   mixing ratios using precomputed lbl tables
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculate CH4 and N2O absorption coefficients from their
!   mixing ratios using precomputed lbl tables
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ch4_n2o_time_vary (rrvch4, rrvn2o)
!  </TEMPLATE>
!  <IN NAME="rrvch4" TYPE="real">
!   ch4 volume mixing ratio
!  </IN>
!  <IN NAME="rrvn2o" TYPE="real">
!   n2o volume mixing ratio
!  </IN>
! </SUBROUTINE>
!
subroutine ch4_time_vary (rrvch4)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real, intent(in) :: rrvch4         

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      rrvch4
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
 
     real   ::  ch4_vmr !

!---------------------------------------------------------------------
!  the ch4 volume mixing ratio is set to the initial value (rch4) and 
!  the mass mixing ratio is defined on the first access of this
!  routine. then the lbl transmission function is calculated. after 
!  first access, this routine does nothing. 
!--------------------------------------------------------------------
         ch4_vmr = rrvch4*1.0E+09
         call Ch4_lblinterp  (ch4_vmr)

!---------------------------------------------------------------------
!  the n2o volume mixing ratio is set to initial value (rn2o) and the 
!  mass mixing ratio is defined on the first access of this routine. 
!  routines are called to calculate the lbl transmission functions for 
!  n2o. after first access, this routine does nothing. 
!--------------------------------------------------------------------
!        n2o_vmr = rrvn2o*1.0E+09
!        call N2o_lblinterp (n2o_vmr)

!----------------------------------------------------------------------

end subroutine ch4_time_vary


!####################################################################
! <SUBROUTINE NAME="n2o_time_vary">
!  <OVERVIEW>
!   Calculate CH4 and N2O absorption coefficients from their
!   mixing ratios using precomputed lbl tables
!  </OVERVIEW>
!  <DESCRIPTION>
!   Calculate CH4 and N2O absorption coefficients from their
!   mixing ratios using precomputed lbl tables
!  </DESCRIPTION>
!  <TEMPLATE>
!   call ch4_n2o_time_vary (rrvch4, rrvn2o)
!  </TEMPLATE>
!  <IN NAME="rrvch4" TYPE="real">
!   ch4 volume mixing ratio
!  </IN>
!  <IN NAME="rrvn2o" TYPE="real">
!   n2o volume mixing ratio
!  </IN>
! </SUBROUTINE>
!
subroutine n2o_time_vary (rrvn2o)

!---------------------------------------------------------------------
!
!---------------------------------------------------------------------

real, intent(in) :: rrvn2o               

!---------------------------------------------------------------------
!  intent(in) variables:
!
!      rrvch4
!      rrvn2o
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables:
 
!    real   ::  ch4_vmr !
     real   ::  n2o_vmr !

!---------------------------------------------------------------------
!  the ch4 volume mixing ratio is set to the initial value (rch4) and 
!  the mass mixing ratio is defined on the first access of this
!  routine. then the lbl transmission function is calculated. after 
!  first access, this routine does nothing. 
!--------------------------------------------------------------------
!        ch4_vmr = rrvch4*1.0E+09
!        call Ch4_lblinterp  (ch4_vmr)

!---------------------------------------------------------------------
!  the n2o volume mixing ratio is set to initial value (rn2o) and the 
!  mass mixing ratio is defined on the first access of this routine. 
!  routines are called to calculate the lbl transmission functions for 
!  n2o. after first access, this routine does nothing. 
!--------------------------------------------------------------------
         n2o_vmr = rrvn2o*1.0E+09
         call N2o_lblinterp (n2o_vmr)

!----------------------------------------------------------------------

end subroutine n2o_time_vary



!####################################################################




                  end module sealw99_mod


                    module sea_esf_rad_mod

! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!   fil
! </CONTACT>
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!   smf
! </REVIEWER>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!   Code to initialize, commpute, and clean up radiation calculation. 
! </OVERVIEW>
! <DESCRIPTION>
!   The radiation component that initializes, deployes, and ends longwave,
!   shortwave, and diagnostics calculation in the FMS model.
! </DESCRIPTION>

!  shared modules:

use mpp_mod,              only: input_nml_file
use fms_mod,              only: open_namelist_file, fms_init, &
                                mpp_pe, mpp_root_pe, stdlog, &
                                file_exist, write_version_number, &
                                check_nml_error, error_mesg, &
                                FATAL, close_file, &
                                mpp_clock_id, mpp_clock_begin, &
                                mpp_clock_end, CLOCK_ROUTINE, &
                                CLOCK_MODULE
use time_manager_mod,     only: time_manager_init, time_type

!  shared radiation package modules:

use rad_utilities_mod,    only: rad_utilities_init, Rad_control, &
                                radiative_gases_type, & 
                                cldrad_properties_type, &
                                cld_specification_type,  &
                                astronomy_type, atmos_input_type, &
                                surface_type, lw_diagnostics_type, &
                                aerosol_diagnostics_type, &
                                cld_space_properties_type, &
                                lw_table_type, &
                                aerosol_type, aerosol_properties_type,&
                                sw_output_type, lw_output_type, &
                                Sw_control, Lw_parameters

!   radiation package modules:

use radiation_diag_mod,   only: radiation_diag_init,   &
                                radiation_diag_driver, &
                                radiation_diag_end
use longwave_driver_mod,  only: longwave_driver_init,   &
                                longwave_driver_time_vary, &
                                longwave_driver, &
                                longwave_driver_endts, &
                                longwave_driver_end
use shortwave_driver_mod, only: shortwave_driver_init,  &
                                shortwave_driver,  &
                                shortwave_driver_end

!----------------------------------------------------------------------

implicit none 
private 

!-----------------------------------------------------------------------
!    sea_esf_rad_mod is the driver for the sea_esf_rad radiation 
!    package.
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!------------ version number for this module ---------------------------

character(len=128) :: version = '$Id: sea_esf_rad.F90,v 18.0.2.1 2010/08/30 20:39:46 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


!--------------------------------------------------------------------
!-- interfaces -----

public       &
            sea_esf_rad_init, sea_esf_rad, sea_esf_rad_time_vary,  &
            sea_esf_rad_endts,  sea_esf_rad_end


private      &

! called from sea_esf_rad:
             deallocate_arrays


!---------------------------------------------------------------------
!--- namelist ---

logical :: dummy


namelist /sea_esf_rad_nml/   &
                            dummy

!---------------------------------------------------------------------
!---- public data ----


!---------------------------------------------------------------------
!---- private data ----


logical :: module_is_initialized = .false.    ! module initialized ?
integer :: longwave_clock, shortwave_clock    ! timing clocks


!---------------------------------------------------------------------
!---------------------------------------------------------------------



                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!######################################################################
! <SUBROUTINE NAME="sea_esf_rad_init">
!   <OVERVIEW>
!     Routine to initialize the radiation calculation
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine initializes the utilities and radiation utilities
!     modules. Then it reads in the radiation namelist from the input
!     namelist file and log the namelist in an output log file.
!   </DESCRIPTION>
!   <TEMPLATE>
!     CALL sea_esf_rad_init (lonb, latb, pref_r)
!   </TEMPLATE>
!
!   <IN NAME="lonb" TYPE="real">
!     2d array of model longitudes at cell corners in [radians]
!   </IN>
!   <IN NAME="latb" TYPE="real">
!     2d array of model latitudes at cell corners in [radians]
!   </IN>
!   <IN NAME="pref_r" TYPE="real">
!     Array containing two reference pressure profiles 
!     on the radiation grid for use in defining 
!     transmission functions in [pascals]
!   </IN>
! </SUBROUTINE>
subroutine sea_esf_rad_init (lonb, latb, pref_r)

!---------------------------------------------------------------------
!   sea_esf_rad_init is the constructor for sea_esf_rad_mod.
!---------------------------------------------------------------------

real, dimension(:,:),    intent(in)  :: lonb, latb
real, dimension(:,:),    intent(in)  :: pref_r

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       lonb      2d array of model longitudes at cell corners 
!                 [radians]
!       latb      2d array of model latitudes at cell corners 
!                 [radians]
!       pref_r    array containing two reference pressure profiles 
!                 on the radiation grid for use in defining 
!                 transmission functions 
!                 [pascals]
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables

      integer                           :: unit, io, ierr, logunit
      type(lw_table_type)               :: Lw_tables

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!        end
!        Lw_tables
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call time_manager_init

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=sea_esf_rad_nml, iostat=io)
      ierr = check_nml_error(io,'sea_esf_rad_nml')
#else   
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=sea_esf_rad_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'sea_esf_rad_nml')
        end do
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                           write (logunit, nml=sea_esf_rad_nml)

!---------------------------------------------------------------------
!    initialize the modules called by this module.
!---------------------------------------------------------------------
      call longwave_driver_init  (latb, lonb, pref_r, Lw_tables)
      call shortwave_driver_init (latb, pref_r)
      call radiation_diag_init   (latb, lonb, Lw_tables)

!---------------------------------------------------------------------
!    initialize clocks to time various modules called by this module.
!---------------------------------------------------------------------
      longwave_clock =      &
                  mpp_clock_id ('   Physics_down: Radiation: lw', &
                        grain=CLOCK_ROUTINE)
      shortwave_clock =     &
                  mpp_clock_id ('   Physics_down: Radiation: sw', &
                        grain=CLOCK_ROUTINE)

!-------------------------------------------------------------------
!    mark the module as initialized.
!-------------------------------------------------------------------
      module_is_initialized = .true.

!-------------------------------------------------------------------



end subroutine sea_esf_rad_init


!####################################################################
 
subroutine sea_esf_rad_time_vary (Time, Rad_gases_tv)

!----------------------------------------------------------------------
type(time_type), intent(in)  :: Time
type(radiative_gases_type), intent(inout) :: Rad_gases_tv

 
      call longwave_driver_time_vary (Time, Rad_gases_tv)
 

end subroutine sea_esf_rad_time_vary
 

!#######################################################################        ######

subroutine sea_esf_rad_endts (Rad_gases_tv)
 
type(radiative_gases_type), intent(in) :: Rad_gases_tv
 
    call longwave_driver_endts (Rad_gases_tv)

end subroutine sea_esf_rad_endts 



!#####################################################################
! <SUBROUTINE NAME="sea_esf_rad">
!   
!   <OVERVIEW>
!     The radiation component interface of the climate model
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine calls longwave radiation computation subroutine, 
!     shortwave radiation computation subroutine, radiation diagnostics
!     computation routine, and finally it deallocates all previously
!     allocated memory spaces of temporary arrays.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call sea_esf_rad (is, ie, js, je, Atmos_input, Surface, Astro, Rad_gases, &
!    Aerosol, Cldrad_props, Cld_spec, Cld_diagnostics, Lw_output, Sw_output)
!   </TEMPLATE>
!
!   <IN NAME="is" TYPE="integer">
!     Starting subdomain i indice of data in the physics window being
!     modeled (longitudinal)
!   </IN>
!   <IN NAME="js" TYPE="integer">
!     Starting subdomain j indice of data in the physics window being
!     modeled (latitudinal)
!   </IN>
!   <IN NAME="ie" TYPE="integer">
!     Ending subdomain i indice of data in the physics window being
!     modeled  (longitudinal)
!   </IN>
!   <IN NAME="je" TYPE="integer">
!     Ending subdomain j indice of data in the physics window being
!     modeled (latitudinal)
!   </IN>
!   <IN NAME="Atmos_input" TYPE="atmos_input_type">
!     Atmos_input_type variable containing the atmospheric
!     input fields on the radiation grid 
!   </IN>
!   <IN NAME="Astro" TYPE="astronomy_type">
!     Astronomy_type variable containing the astronomical
!     input fields on the radiation grid  
!   </IN>
!   <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!     Radiative_gases_type variable containing the radiative 
!     gas input fields on the radiation grid 
!   </IN>
!   <IN NAME="Aerosol" TYPE="aerosol_type">
!     Aerosol input data to the shortwave radiation calculation
!   </IN>
!   <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!     The cloud radiative property input fields on the
!     radiation grid
!   </IN>
!   <IN NAME="Cld_diagnostics" TYPE="cld_diagnostics_type">
!     The cloud diagnostics input fields on the radiation grid
!   </IN>
!   <INOUT NAME="Lw_output" TYPE="lw_output_type">
!     The longwave radiation calculation result
!   </INOUT>
!   <INOUT NAME="Sw_output" TYPE="sw_output_type">
!     The shortwave radiation calculation result
!   </INOUT>
!   <IN NAME="Surface" TYPE="surface_type">
!    Surface data as boundary condition to radiation
!   </IN>
!   <IN NAME="Cld_spec" TYPE="cld_specification_type">
!    Cloud specification data as initial condition to radiation
!   </IN>
! </SUBROUTINE>

subroutine sea_esf_rad (is, ie, js, je, Rad_time, Atmos_input, Surface,&
                        Astro, Rad_gases, Aerosol, Aerosol_props,    &
                        Cldrad_props, Cld_spec, Lw_output, Sw_output, &
                        Aerosol_diags, r)

!-----------------------------------------------------------------------
!     sea_esf_rad calls the modules which calculate the long- and short-
!     wave radiational heating terms and fluxes and the radiation diag-
!     nostics module which provides radiation package diagnostics.
!-----------------------------------------------------------------------

integer,                      intent(in)     :: is, ie, js, je
type(time_type),              intent(in)     :: Rad_time
type(atmos_input_type),       intent(in)     :: Atmos_input
type(surface_type),           intent(in)     :: Surface     
type(astronomy_type),         intent(in)     :: Astro
type(radiative_gases_type),   intent(inout)  :: Rad_gases
type(aerosol_type),           intent(in)     :: Aerosol      
type(aerosol_properties_type),intent(inout)  :: Aerosol_props
type(cldrad_properties_type), intent(in)     :: Cldrad_props
type(cld_specification_type), intent(in)     :: Cld_spec       
type(lw_output_type), dimension(:), intent(inout)  :: Lw_output
type(sw_output_type), dimension(:), intent(inout)  :: Sw_output 
type(aerosol_diagnostics_type), intent(inout)  :: Aerosol_diags
real, dimension(:,:,:,:),     intent(inout)  :: r
!---------------------------------------------------------------------
!  intent(in) variables:
!
!      is,ie,js,je   starting/ending subdomain i,j indices of data in 
!                    the physics_window being integrated
!      Rad_time      time at which the climatologically-determined, 
!                    time-varying input fields to radiation should 
!                    apply    
!                    [ time_type, days and seconds]
!      Atmos_input   atmospheric input fields          
!                    [ atmos_input_type ]
!      Surface       surface variables 
!                    [ surface_type ]
!      Astro         astronomical input fields            
!                    [ astronomy_type ]
!      Rad_gases     radiative gas input fields   
!                    [ radiative_gases_type ]
!      Aerosol       aerosol input fields 
!                    [ aerosol_type ]
!      Cldrad_props  cloud radiative property input fields
!                    [ cldrad_properties_type ]
!      Cld_spec      cloud specification input fields 
!                    [ cld_specification_type ]
!
!  intent(out) variables:
!
!      Aerosol_props aerosol radiative properties
!                    [ aerosol_properties_type ]
!      Lw_output     longwave radiation output data from the sea_esf_rad
!                    radiation package
!                    [ lw_output_type ]
!      Sw_output     shortwave radiation output data from the
!                    sea_esf_rad radiation package 
!                    [ sw_output_type ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables

      type(lw_diagnostics_type)         :: Lw_diagnostics
      type(cld_space_properties_type)   :: Cldspace_rad

!---------------------------------------------------------------------
!   local variables
!
!         Lw_diagnostics      used to hold desired diagnostics from 
!                             longwave_driver_mod so they may be passed
!                             to radiation_diag_mod
!                             [ lw_diagnostics_type ]
!         Cldspace_rad        used to hold output from bulk sw routine
!                             so that it may be passed to the 
!                             radiation_diag_mod    
!                             [ cld_space_properties_type ]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('sea_esf_rad_mod',   &
              'module has not been initialized', FATAL )
      endif

!----------------------------------------------------------------------
!    compute longwave radiation.
!----------------------------------------------------------------------
    if (Rad_control%do_lw_rad) then
      call mpp_clock_begin (longwave_clock)
      call longwave_driver (is, ie, js, je, Rad_time, Atmos_input,  &
                            Rad_gases, Aerosol, Aerosol_props,   &
                            Cldrad_props, Cld_spec, Aerosol_diags, &
                            Lw_output, Lw_diagnostics)
      call mpp_clock_end (longwave_clock)
    endif

!----------------------------------------------------------------------
!    compute shortwave radiation.
!----------------------------------------------------------------------
    if (Rad_control%do_sw_rad) then
      call mpp_clock_begin (shortwave_clock)
      call shortwave_driver (is, ie, js, je, Atmos_input, Surface,  &
                             Astro, Aerosol, Aerosol_props, Rad_gases, &
                             Cldrad_props, Cld_spec, Sw_output,   &
                             Cldspace_rad, Aerosol_diags, r)
      call mpp_clock_end (shortwave_clock)
    endif

!--------------------------------------------------------------------
!    call radiation_diag_driver to compute radiation diagnostics at 
!    desired points.
!--------------------------------------------------------------------
    if (Rad_control%do_sw_rad .and. Rad_control%do_lw_rad) then
      call radiation_diag_driver (is, ie, js, je, Atmos_input, Surface,&
                                  Astro, Rad_gases, Cldrad_props,   &
                                  Cld_spec, Sw_output, Lw_output, &
                                  Lw_diagnostics, Cldspace_rad)
    endif

!---------------------------------------------------------------------
!    call deallocate_arrays to deallocate the array components of the 
!    local derived-type variables.
!---------------------------------------------------------------------
      call deallocate_arrays (Lw_diagnostics, Cldspace_rad)

!--------------------------------------------------------------------

end subroutine sea_esf_rad




!###################################################################
! <SUBROUTINE NAME="sea_esf_rad_end">
! 
!   <OVERVIEW>
!     Ends radiation calculation.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine ends longwave, shortwave, and radiation
!     diagnostics calculation.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call sea_esf_rad_end
!   </TEMPLATE>
! </SUBROUTINE>

subroutine sea_esf_rad_end
 
!-------------------------------------------------------------------
!    sea_esf_rad_end is the destructor for the sea_esf_rad module.
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('sea_esf_rad_mod',   &
              'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    close out the modules initialized by this module.
!--------------------------------------------------------------------
      call longwave_driver_end
      call shortwave_driver_end
      call radiation_diag_end
 
!--------------------------------------------------------------------
!    mark the module as uninitialized.
!--------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------


end subroutine sea_esf_rad_end


!####################################################################
      

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!####################################################################
! <SUBROUTINE NAME="deallocate_arrays">
!  
!   <OVERVIEW>
!     A routine to deallocate arrays allocated temporarily during
!     radiation calculation.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine deallocates arrays used in longwave 
!     diagnostics and cloud space parameters used in the
!     lacis-hansen formulation.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call deallocate_arrays (Lw_diagnostics, Cldspace_rad)
!   </TEMPLATE>
!
!   <IN NAME="Lw_diagnostics" TYPE="lw_diagnostics_type">
!     Desired diagnostics from longwave_driver
!     so they may be passed to radiation_diag_mod
!   </IN>
!   <IN NAME="Cldspace_rad" TYPE="cld_space_properties_type">
!     Cld_space_properties_type variable which
!     holds lacis-hansen sw cloud-radiation
!     variables in cloud-space, rather than 
!     k-space, as the third dimension.
!   </IN>
! </SUBROUTINE>

subroutine deallocate_arrays (Lw_diagnostics, Cldspace_rad)

!---------------------------------------------------------------------
!    deallocate_arrays deallocates the array cpomponents of local
!    derived-type variables.
!---------------------------------------------------------------------

type(lw_diagnostics_type),       intent(inout)   :: Lw_diagnostics
type(cld_space_properties_type), intent(inout)   :: Cldspace_rad

!---------------------------------------------------------------------
!  intent(inout) variables:
!
!         Lw_diagnostics      lw_diagnostics_type variable to hold
!                             desired diagnostics from longwave_driver
!                             so they may be passed to 
!                             radiation_diag_mod
!         Cldspace_rad        cld_space_properties_type variable which
!                             holds lacis-hansen sw cloud-radiation
!                             variables in cloud-space, rather than 
!                             k-space, as the third dimension.
!
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!    deallocate the components of Lw_diagnostics.
!--------------------------------------------------------------------
    if (Rad_control%do_lw_rad) then
      deallocate (Lw_diagnostics%flx1e1)
      deallocate (Lw_diagnostics%fluxn )
      deallocate (Lw_diagnostics%cts_out)
      deallocate (Lw_diagnostics%cts_outcf)
      deallocate (Lw_diagnostics%gxcts )
      deallocate (Lw_diagnostics%excts )
      deallocate (Lw_diagnostics%exctsn)
      deallocate (Lw_diagnostics%fctsg )
      if (Lw_parameters%nbtrge > 0) then
        deallocate (Lw_diagnostics%flx1e1f)
      endif
      if (Rad_control%do_totcld_forcing) then
        deallocate (Lw_diagnostics%fluxncf)
      endif
   endif

!--------------------------------------------------------------------
!    deallocate the components of Cldspace_rad. these arrays are only
!    allocated when the lh sw code is called with clouds present; 
!    therefore one must test for pointer association before deallo-
!    cating the memory.
!--------------------------------------------------------------------
   if (Rad_control%do_sw_rad) then
      if (Sw_control%do_lhsw) then
        if (associated ( Cldspace_rad%camtswkc) ) then
          deallocate (Cldspace_rad%camtswkc )
          deallocate (Cldspace_rad%cirabswkc )
          deallocate (Cldspace_rad%cirrfswkc )
          deallocate (Cldspace_rad%cvisrfswkc )
          deallocate (Cldspace_rad%ktopswkc )
          deallocate (Cldspace_rad%kbtmswkc )
        endif
      endif
    endif

!--------------------------------------------------------------------


end subroutine deallocate_arrays 


!####################################################################



                 end module sea_esf_rad_mod



                     module shortwave_driver_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
!
! <REVIEWER EMAIL="Stuart.Freidenreich@noaa.gov">
!  smf
! </REVIEWER>
! 
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
!
! <OVERVIEW>
!  Code to carry out shortwave calculation.
! </OVERVIEW>
! <DESCRIPTION>
!  This code initializes, prepares, and ends shortwave radiation calculation.
!  This code is called by sea_esf_rad.f90 and calls shortwave subroutines
!  to do shortwave flux calculation.
! </DESCRIPTION>
!

!   shared modules:

use mpp_mod,              only: input_nml_file
use fms_mod,              only: open_namelist_file, fms_init, &
                                mpp_pe, mpp_root_pe, stdlog, &
                                file_exist, write_version_number, &
                                check_nml_error, error_mesg, &
                                FATAL, close_file

!   shared radiation package modules:
 
use rad_utilities_mod,    only: rad_utilities_init, Rad_control,  &
                                cldrad_properties_type, &
                                cld_specification_type, Sw_control, &
                                Cldrad_control, &
                                radiative_gases_type,   &
                                aerosol_diagnostics_type, &
                                aerosol_type, aerosol_properties_type,&
                                atmos_input_type, surface_type, &
                                astronomy_type, sw_output_type, &
                                assignment(=), cld_space_properties_type
use esfsw_parameters_mod, only: esfsw_parameters_init

!  radiation package modules:

use lhsw_driver_mod,      only: lhsw_driver_init, swrad
use esfsw_driver_mod,     only: esfsw_driver_init, swresf,   &
                                esfsw_driver_end

!-------------------------------------------------------------------

implicit none
private

!------------------------------------------------------------------
!    shortwave_driver_mod is the driver for shortwave radiation 
!    component of the sea_esf_rad radiation package.
!-----------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module  -------------------------

character(len=128)  :: version =  '$Id: shortwave_driver.F90,v 17.0.4.1 2010/08/30 20:33:33 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public        &
          shortwave_driver_init , shortwave_driver,    & 
          shortwave_driver_end


private       &

!   called from shortwave_driver:
          shortwave_driver_alloc


!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16)   :: swform = '    '
logical             :: do_cmip_diagnostics = .false.
logical             :: calculate_volcanic_sw_heating = .false.
  
 
namelist / shortwave_driver_nml /             &
                                     do_cmip_diagnostics, &
                                     calculate_volcanic_sw_heating, &
                                     swform

!---------------------------------------------------------------------
!------- public data ------


!---------------------------------------------------------------------
!------- private data ------

logical :: module_is_initialized = .false.  ! module initialized ?


!-------------------------------------------------------------------
!-------------------------------------------------------------------



                         contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! <SUBROUTINE NAME="shortwave_driver_init">
!  <OVERVIEW>
!   Code that initializes shortwave radiation calculation.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Initialize utilities and radiation utilities if necessary. They
!   should have been initialized in the radiation initialiation subroutine
!   in the sea_esf_rad.f90. The code then reads in input.nml namelist
!   and logs input parameters to logfile. It uses lhsw or esfsw package
!   depends on namelist parameter. Initializes apropriate shortwave
!   package subroutines and set up the initialize parameter.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call shortwave_driver_init (latb, pref)
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="pref" TYPE="real">
!   An array containing two reference pressure profiles [pascals]
!  </IN>
! </SUBROUTINE>
subroutine shortwave_driver_init (latb, pref)

!---------------------------------------------------------------------
!    shortwave_driver_init is the constructor for shortwave_driver_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:,:), intent(in) :: latb
real, dimension(:,:), intent(in) :: pref
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  intent(in) variables:
!
!       latb      2d array of model latitudes at cell corners 
!                 [ radians ]
!                                
!       pref      array containing two reference pressure profiles 
!                 [ Pa ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables:

      integer   :: unit, io, ierr, logunit

!---------------------------------------------------------------------
!  local variables:
!
!        unit            io unit number used for namelist file
!        ierr            error code
!        io              error status returned from io operation
!                                
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!-------------------------------------------------------------------
      if (module_is_initialized) return

!-------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!-------------------------------------------------------------------
      call fms_init
      call rad_utilities_init

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=shortwave_driver_nml, iostat=io)
      ierr = check_nml_error(io,"shortwave_driver_nml")
#else
!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=shortwave_driver_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'shortwave_driver_nml')
        end do
10      call close_file (unit)
      endif
#endif
 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                       write (logunit, nml=shortwave_driver_nml)

!--------------------------------------------------------------------
!    define logicals specifying the sw package in use as an element
!    of a shortwave_control_type variable usable by other radiation-
!    related modules. initialize the modules associated with the chosen
!    sw package.
!---------------------------------------------------------------------
      if (trim(swform) == 'lhsw') then
        Sw_control%do_lhsw  = .true.
        call lhsw_driver_init (pref)
        Cldrad_control%do_ica_calcs_iz = .true.
      else if (trim(swform) == 'esfsw99') then
        Sw_control%do_esfsw = .true.
        call esfsw_parameters_init
        call esfsw_driver_init
      else
        call error_mesg ( 'shortwave_driver_mod',   &
        'improper specification of desired shortwave parameterization',&
                                                               FATAL)
      endif

!---------------------------------------------------------------------
!    mark the just-defined logicals as defined.
!---------------------------------------------------------------------
      Sw_control%do_lhsw_iz  = .true.
      Sw_control%do_esfsw_iz = .true.

!---------------------------------------------------------------------
!    save the logical indicating the need to generate cmip aerosol
!    diagnostics and mark it as initialized.
!---------------------------------------------------------------------
      Sw_control%do_cmip_diagnostics = do_cmip_diagnostics
      Sw_control%do_cmip_diagnostics_iz = .true.             

!     if (calculate_volcanic_sw_heating) then
!       if (Rad_control%volcanic_sw_aerosols_iz) then
!         if (Rad_control%volcanic_sw_aerosols) then
!         else
!           call error_mesg ('shortwave_driver_mod', &
!            'cannot calculate volcanic sw heating when wolcanic sw &
!                            &aerosols are not activated', FATAL)
!         endif
!       else
!           call error_mesg ('shortwave_driver_mod', &
!            'Rad_control%volcanic_sw_aerosols not yet defined', FATAL)
!       endif
!     endif

!-------------------------------------------------------------------
!    set flag indicating successful initialization of module.
!-------------------------------------------------------------------
      module_is_initialized = .true.

!--------------------------------------------------------------------


end subroutine shortwave_driver_init



!###########################################################
! <SUBROUTINE NAME="shortwave_driver">
!  <OVERVIEW>
!   Code that deploys shortwave radiation calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!    shortwave_driver initializes shortwave radiation output variables, 
!    determines if shortwave radiation is present in the current physics
!    window, selects one of the available shortwave parameterizations,
!    executes it, and returns the output fields to sea_esf_rad_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!    call shortwave_driver (is, ie, js, je, Atmos_input, Surface, Astro, &
!                           Rad_gases, Cldrad_props, Cld_spec, Sw_output, &
!                           Cldspace_rad) 
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!    starting subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!    ending subdomain i indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="js" TYPE="integer">
!    starting subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="je" TYPE="integer">
!    ending subdomain j indices of data in 
!                   the physics_window being integrated
!  </IN>
!   <IN NAME="Atmos_input" TYPE="atmos_input_type">
!     Atmos_input_type variable containing the atmospheric
!     input fields on the radiation grid 
!   </IN>
!   <IN NAME="Astro" TYPE="astronomy_type">
!     Astronomy_type variable containing the astronomical
!     input fields on the radiation grid  
!   </IN>
!   <IN NAME="Aerosol" TYPE="aerosol_type">
!    Aerosol input data of shortwave radiation calculation
!   </IN>
!   <IN NAME="Aerosol_props" TYPE="aerosol_properties_type">
!    Aerosol radiative property input data 
!   </IN>
!   <IN NAME="Rad_gases" TYPE="radiative_gases_type">
!     Radiative_gases_type variable containing the radiative 
!     gas input fields on the radiation grid 
!   </IN>
!   <IN NAME="Cldrad_props" TYPE="cldrad_properties_type">
!     The cloud radiative property input fields on the
!     radiation grid
!   </IN>
!   <INOUT NAME="Sw_output" TYPE="sw_output_type">
!     The shortwave radiation calculation result
!   </INOUT>
!   <INOUT NAME="Cldspace_rad" TYPE="cld_space_properties_type">
!     Optional cloud radiative forcing output used in lacis-hansen
!     formulation.
!   </INOUT>
!   <IN NAME="Surface" TYPE="surface_type">
!    Surface data as boundary condition to radiation
!   </IN>
!   <IN NAME="Cld_spec" TYPE="cld_specification_type">
!    Cloud specification data as initial condition to radiation
!   </IN>
! </SUBROUTINE>
subroutine shortwave_driver (is, ie, js, je, Atmos_input, Surface,  &
                             Astro, Aerosol, Aerosol_props, Rad_gases, &
                             Cldrad_props,  Cld_spec, Sw_output,      &
                             Cldspace_rad, Aerosol_diags, r) 

!---------------------------------------------------------------------
!    shortwave_driver initializes shortwave radiation output variables, 
!    determines if shortwave radiation is present in the current physics
!    window, selects one of the available shortwave parameterizations,
!    executes it, and returns the output fields to sea_esf_rad_mod.
!---------------------------------------------------------------------

integer,                         intent(in)    :: is, ie, js, je
type(atmos_input_type),          intent(in)    :: Atmos_input     
type(surface_type),              intent(in)    :: Surface     
type(astronomy_type),            intent(in)    :: Astro           
type(radiative_gases_type),      intent(in)    :: Rad_gases   
type(aerosol_type),              intent(in)    :: Aerosol     
type(aerosol_properties_type),   intent(inout) :: Aerosol_props
type(cldrad_properties_type),    intent(in)    :: Cldrad_props
type(cld_specification_type),    intent(in)    :: Cld_spec
type(sw_output_type), dimension(:), intent(inout) :: Sw_output
type(cld_space_properties_type), intent(inout) :: Cldspace_rad
type(aerosol_diagnostics_type), intent(inout)  :: Aerosol_diags
real, dimension(:,:,:,:),        intent(inout) :: r

!--------------------------------------------------------------------
!  intent(in) variables:
!
!      is,ie,js,je    starting/ending subdomain i,j indices of data in 
!                     the physics_window being integrated
!      Atmos_input    atmos_input_type variable containing the atmos-
!                     pheric input fields needed by the radiation 
!                     package
!      Surface        surface_type variable containing the surface input
!                     fields needed by the radiation package
!      Astro          astronomy_type variable containing the astronom-
!                     ical input fields needed by the radiation package
!      Rad_gases      radiative_gases_type variable containing the radi-
!                     ative gas input fields needed by the radiation 
!                     package
!      Aerosol        aerosol_type variable containing the aerosol input
!                     data needed by the radiation package
!      Aerosol_props  aerosol_properties_type variable containing the
!                     aerosol radiative properties input data needed by
!                     the radiation package
!      Cldrad_props   cldrad_properties_type variable containing the 
!                     cloud radiative property input fields needed by 
!                     the radiation package
!      Cld_spec       cld_specification_type variable containing the 
!                     cloud specification input fields needed by the 
!                     radiation package
!
!   intent(out) variables:
!
!      Sw_output      sw_output_type variable containing shortwave 
!                     radiation output data 
!      Cldspace_rad   cld_space_properties_type variable containing the
!                     sw output fields obtained from the lacis-hansen
!                     shortwave parameterization 
!
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!  local variables:

      type(sw_output_type) :: Sw_output_ad, Sw_output_std
      logical  :: skipswrad
      logical  :: with_clouds
      logical  :: calc_includes_aerosols
      integer  :: naerosol_optical
      integer  :: i, j       
      integer  :: ix, jx, kx

!---------------------------------------------------------------------
!   local variables:
!
!      skipswrad    bypass calling sw package because sun is not 
!                   shining any where in current physics window ?
!      with_clouds  are clouds to be considered in determining
!                   the sw fluxes and heating rates ?
!      ix,jx,kx     dimensions of current physics window
!      i,j          do-loop indices
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('shortwave_driver_mod',   &
             'module has not been initialized', FATAL )
      endif

!----------------------------------------------------------------------
!    call shortwave_driver_alloc to initialize shortwave fluxes and 
!    heating rates.
!--------------------------------------------------------------------
      ix = ie - is + 1
      jx = je - js + 1
      kx = size (Atmos_input%press,3) - 1
!**************************************
      ! This is a temporary fix! Sw_output needs to be allocated at a higher level!
      ! Constructor and destructor for sw_output_type needs to be provided through
      ! rad_utilities
!**************************************
      call shortwave_driver_alloc (ix, jx, kx, Sw_output(1)) 
      call shortwave_driver_alloc (ix, jx, kx, Sw_output_std) 
      if (Rad_control%do_swaerosol_forcing) then
        call shortwave_driver_alloc (ix, jx, kx, Sw_output_ad)
        call shortwave_driver_alloc (ix, jx, kx, Sw_output(Rad_control%indx_swaf)) 
      endif

!--------------------------------------------------------------------
!    determine when the no-sun case exists at all points within the 
!    physics window and bypass the sw radiation calculations for that 
!    window. for do_annual_mean or do_daily_mean, only one cosz in a
!    model row need be tested, since all points in i have the same 
!    zenith angle.
!--------------------------------------------------------------------
      skipswrad = .true.
      do j=1,jx        
        if ( Astro%cosz(1,j) > 0.0 ) skipswrad = .false.
        if (Sw_control%do_diurnal) then
          do i = 2,ix         
            if (Astro%cosz(i,j) > 0.0 )  then
              skipswrad = .false.
              exit
            endif
          end do
        endif
      end do

!--------------------------------------------------------------------
!    for aerosol optical depth diagnostics, swresf must be called
!    on all radiation steps.
!--------------------------------------------------------------------
      if (do_cmip_diagnostics)  skipswrad = .false.

!--------------------------------------------------------------------
!    if the sun is shining nowhere in the physics window allocate
!    output fields which will be needed later, set them to a flag
!    value and return.
!--------------------------------------------------------------------
      if (skipswrad)  then
        allocate ( Cldspace_rad%camtswkc(ie-is+1, je-js+1, 1 ))
        allocate ( Cldspace_rad%cirabswkc(ie-is+1, je-js+1, 1 ))
        allocate ( Cldspace_rad%cirrfswkc(ie-is+1, je-js+1, 1 ))
        allocate ( Cldspace_rad%cvisrfswkc(ie-is+1, je-js+1, 1 ))
        allocate ( Cldspace_rad%ktopswkc(ie-is+1, je-js+1,  1 ))
        allocate ( Cldspace_rad%kbtmswkc(ie-is+1, je-js+1,  1 ))
        Cldspace_rad%camtswkc = -99.0
        Cldspace_rad%cirabswkc = -99.0
        Cldspace_rad%cirrfswkc = -99.0
        Cldspace_rad%cvisrfswkc = -99.0
        Cldspace_rad%ktopswkc = -99.0
        Cldspace_rad%kbtmswkc = -99.0

!---------------------------------------------------------------------
!    calculate shortwave radiative forcing and fluxes using the 
!    exponential-sum-fit parameterization.
!---------------------------------------------------------------------
      else if (Sw_control%do_esfsw) then

!---------------------------------------------------------------------
!    if volcanic sw heating calculation desired, set up to call swresf
!    twice.
!---------------------------------------------------------------------
        if (calculate_volcanic_sw_heating ) then  
          if (Rad_control%volcanic_sw_aerosols) then
          else
            call error_mesg ('shortwave_driver_mod', &
             'cannot calculate volcanic sw heating when volcanic sw &
                             &aerosols are not activated', FATAL)
          endif

!----------------------------------------------------------------------
!    call swresf without including volcanic aerosol effects. save the 
!    heating rate as Aerosol_diags%sw_heating_vlcno.
!----------------------------------------------------------------------
          if (Sw_control%do_swaerosol) then
            naerosol_optical = size (Aerosol_props%aerextband,2)
          else
            naerosol_optical = 0  
          endif 
          call swresf (is, ie, js, je, Atmos_input, Surface, Rad_gases,&
                       Aerosol, Aerosol_props, Astro, Cldrad_props,  &
                       Cld_spec, .false., Sw_output_std, Aerosol_diags, r, &
!                      Sw_control%do_swaerosol)
                       Sw_control%do_swaerosol, naerosol_optical)
          Aerosol_diags%sw_heating_vlcno = Sw_output_std%hsw 

!----------------------------------------------------------------------
!    reinitialize the sw outputs for the "real" call.
!----------------------------------------------------------------------
          Sw_output_std%fsw   (:,:,:,:) = 0.0
          Sw_output_std%dfsw  (:,:,:,:) = 0.0
          Sw_output_std%ufsw  (:,:,:,:) = 0.0
          Sw_output_std%hsw   (:,:,:,:) = 0.0
          Sw_output_std%dfsw_dir_sfc = 0.0
          Sw_output_std%dfsw_dif_sfc  = 0.0
          Sw_output_std%ufsw_dif_sfc = 0.0
          Sw_output_std%dfsw_vis_sfc = 0.
          Sw_output_std%ufsw_vis_sfc = 0.
          Sw_output_std%dfsw_vis_sfc_dir = 0.
          Sw_output_std%dfsw_vis_sfc_dif = 0.
          Sw_output_std%ufsw_vis_sfc_dif = 0.
          Sw_output_std%swdn_special  (:,:,:,:) = 0.0
          Sw_output_std%swup_special  (:,:,:,:) = 0.0
          Sw_output_std%bdy_flx(:,:,:,:) = 0.0
      if (Rad_control%do_totcld_forcing) then
          Sw_output_std%fswcf (:,:,:,:) = 0.0
          Sw_output_std%dfswcf(:,:,:,:) = 0.0
          Sw_output_std%ufswcf(:,:,:,:) = 0.0
          Sw_output_std%hswcf (:,:,:,:) = 0.0
          Sw_output_std%dfsw_dir_sfc_clr = 0.             
          Sw_output_std%dfsw_dif_sfc_clr = 0.           
          Sw_output_std%dfsw_vis_sfc_clr = 0.
          Sw_output_std%swdn_special_clr  (:,:,:,:) = 0.0
          Sw_output_std%swup_special_clr  (:,:,:,:) = 0.0
          Sw_output_std%bdy_flx_clr(:,:,:,:) = 0.0
      endif
          if (Sw_control%do_swaerosol) then
            naerosol_optical = size (Aerosol_props%aerextband,2)
          else
            naerosol_optical = 0  
          endif 
          call swresf (is, ie, js, je, Atmos_input, Surface, Rad_gases,&
                       Aerosol, Aerosol_props, Astro, Cldrad_props,  &
                       Cld_spec, Rad_control%volcanic_sw_aerosols, &
                       Sw_output_std, Aerosol_diags, r, &
                       Sw_control%do_swaerosol, naerosol_optical)

!----------------------------------------------------------------------
!    define the difference in heating rates betweenthe case with 
!    volcanic aerosol and the case without. save in 
!    Aerosol_diags%sw_heating_vlcno.
!----------------------------------------------------------------------
          Aerosol_diags%sw_heating_vlcno = Sw_output_std%hsw  -   &
                                         Aerosol_diags%sw_heating_vlcno
          Sw_output(1) = Sw_output_std

!----------------------------------------------------------------------
!    if volcanic heating calculation not desired, simply call swresf.
!----------------------------------------------------------------------
        else
 
          if (Rad_control%do_swaerosol_forcing) then
            if (Sw_control%do_swaerosol) then
              calc_includes_aerosols = .false.
            else
              calc_includes_aerosols = .true.
            endif

!-----------------------------------------------------------------------
!    call swresf with aerosols (if model is being run without) or without
!    aerosols (if model is being run with). save the radiation fluxes 
!    in Sw_output_ad (which does not feed back into the model), but 
!    which may be used to define the aerosol forcing.
!-----------------------------------------------------------------------
          if (calc_includes_aerosols) then
            naerosol_optical = size (Aerosol_props%aerextband,2)
          else
            naerosol_optical = 0  
          endif 
           call swresf (is, ie, js, je, Atmos_input, Surface, Rad_gases,&
                        Aerosol, Aerosol_props, Astro, Cldrad_props,  &
                        Cld_spec, Rad_control%volcanic_sw_aerosols, &
                        Sw_output_ad, Aerosol_diags, r,   &
                        calc_includes_aerosols, naerosol_optical)  
            Sw_output(Rad_control%indx_swaf) = Sw_output_ad
         endif
 
!----------------------------------------------------------------------
!    standard call, where radiation output feeds back into the model.
!----------------------------------------------------------------------
          if (Sw_control%do_swaerosol) then
            naerosol_optical = size (Aerosol_props%aerextband,2)
          else
            naerosol_optical = 0  
          endif 
          call swresf (is, ie, js, je, Atmos_input, Surface, Rad_gases,&
                       Aerosol, Aerosol_props, Astro, Cldrad_props,  &
                       Cld_spec, Rad_control%volcanic_sw_aerosols, &
                       Sw_output_std, Aerosol_diags, r,  &
                       Sw_control%do_swaerosol, naerosol_optical)
            Sw_output(1) = Sw_output_std
        endif

!---------------------------------------------------------------------
!    calculate shortwave radiative forcing and fluxes using the 
!    lacis-hansen parameterization.
!---------------------------------------------------------------------
      else if (Sw_control%do_lhsw) then
        with_clouds = .true.
        call swrad (is, ie, js, je, Astro, with_clouds, Atmos_input, &
                    Surface, Rad_gases, Cldrad_props, Cld_spec,  &
                    Sw_output_std, Cldspace_rad)
        Sw_output(1) = Sw_output_std

!!  FOR NOW, total sw fluxes, which have been determined using the
!!  direct beam albedoes, will be assigned to the _dir arrays, and 
!!  the _dif arrays will remain zero. Likewise, it is assumed that all
!!  of the flux is contained in the nir part of the spectrum, so that
!!  the _vis arrays remain as initialized, at values of 0.0. If a 
!   better asssignment is available and desired, it should be implem-
!!  ented.
!!   I do not know whether direct and diffuse are even definable within 
!!  lhsw, but since this is a dead parameterization, it is unlikely
!   that making the partitioning is worthwhile.

!! NOTE THAT IT IS NOT INTENDED THAT THE LAND MODEL BE RUN WITH LHSW
!! RADIATION, so the only aim here is that the total flux be retrievable
!! within the land model, so that the previous results are obtained,
!! when all 4 albedoes have the same value.


!      Sw_output%ufsw_dir = Sw_output%ufsw
!      Sw_output%dfsw_dir = Sw_output%dfsw

!---------------------------------------------------------------------
!    lacis-hansen requires a second call to produce the cloud-free
!    fluxes.
!---------------------------------------------------------------------
        if (Rad_control%do_totcld_forcing) then
          with_clouds = .false.
          call swrad (is, ie, js, je, Astro, with_clouds, Atmos_input, &
                      Surface, Rad_gases, Cldrad_props, Cld_spec,  &
                      Sw_output_std, Cldspace_rad)  
        endif
        Sw_output(1) = Sw_output_std
      endif  


      call shortwave_driver_dealloc (Sw_output_std)
      if (Rad_control%do_swaerosol_forcing) then
        call shortwave_driver_dealloc (Sw_output_ad)
      endif
!--------------------------------------------------------------------


end subroutine shortwave_driver



!###################################################################
! <SUBROUTINE NAME="shortwave_driver_end">
!  <OVERVIEW>
!   Code that ends shortwave radiation calculation
!  </OVERVIEW>
!  <DESCRIPTION>
!   Subroutine that simply reset shortwave_driver_initialized to false
!  </DESCRIPTION>
!  <TEMPLATE>
!   call shortwave_driver_end
!  </TEMPLATE>
! </SUBROUTINE>
subroutine shortwave_driver_end

!---------------------------------------------------------------------
!    shortwave_driver_end is the destructor for shortwave_driver_mod.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('shortwave_driver_mod',   &
             'module has not been initialized', FATAL )
      endif

!--------------------------------------------------------------------
!    close out the modules initialized by this module.
!--------------------------------------------------------------------
      if (Sw_control%do_esfsw) then
        call esfsw_driver_end
      endif

!---------------------------------------------------------------------
!    mark the module as uninitialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!-------------------------------------------------------------------

end subroutine shortwave_driver_end



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                    PRIVATE SUBROUTINES
!                                
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!###################################################################
! <SUBROUTINE NAME="shortwave_driver_alloc">
!  <OVERVIEW>
!   Code that allocates and initializes shortwave output variables
!  </OVERVIEW>
!  <DESCRIPTION>
!   Shortwave_driver_alloc allocates and initializes the components
!   of the sw_output_type variable Sw_output, which is used to hold
!   output data from shortwave_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call shortwave_driver_alloc (ix, jx, kx, Sw_output)
!  </TEMPLATE>
!  <IN NAME="ix" TYPE="integer">
!   x dimention of the radiation grid where shortwave output is desired
!  </IN>
!  <IN NAME="jx" TYPE="integer">
!   y dimention of the radiation grid where shortwave output is desired
!  </IN>
!  <IN NAME="kx" TYPE="integer">
!   z dimention of the radiation grid where shortwave output is desired
!  </IN>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output variable
!  </INOUT>
! </SUBROUTINE>
!
subroutine shortwave_driver_alloc (ix, jx, kx, Sw_output) 

!--------------------------------------------------------------------
!    shortwave_driver_alloc allocates and initializes the components
!    of the sw_output_type variable Sw_output, which is used to hold
!    output data from shortwave_driver_mod.
!--------------------------------------------------------------------

integer,              intent(in)     ::  ix, jx, kx 
type(sw_output_type), intent(inout)  ::  Sw_output 

!-------------------------------------------------------------------
!  intent(in) variables:
!
!    ix, jx, kx   dimensions of the radiation grid on which output 
!                 will be produced
!
!  intent(inout) variables:
!
!      Sw_output  sw_output_type variable containing shortwave 
!                 radiation output data 
!
!--------------------------------------------------------------------

      integer :: nzens

      nzens = Rad_control%nzens

!--------------------------------------------------------------------
!    allocate and initialize fields to contain net(up-down) sw flux 
!    (fsw), upward sw flux (ufsw), downward sw flux(dfsw) at flux 
!    levels and sw heating in model layers (hsw).
!--------------------------------------------------------------------
      allocate (Sw_output%fsw  (ix, jx, kx+1, nzens) )
      allocate (Sw_output%ufsw (ix, jx, kx+1, nzens) )
      allocate (Sw_output%dfsw (ix, jx, kx+1, nzens) )
      allocate (Sw_output%hsw  (ix, jx, kx  , nzens) )
      allocate (Sw_output%dfsw_dir_sfc (ix, jx, nzens) )
      allocate (Sw_output%ufsw_dif_sfc (ix, jx, nzens) )
      allocate (Sw_output%dfsw_dif_sfc (ix, jx, nzens) )
      allocate (Sw_output%dfsw_vis_sfc (ix, jx, nzens  ) )
      allocate (Sw_output%ufsw_vis_sfc (ix, jx, nzens  ) )
      allocate (Sw_output%dfsw_vis_sfc_dir (ix, jx, nzens  ) )
      allocate (Sw_output%dfsw_vis_sfc_dif (ix, jx, nzens  ) )
      allocate (Sw_output%ufsw_vis_sfc_dif (ix, jx, nzens  ) )
      allocate (Sw_output%swdn_special   &
                            (ix, jx, Rad_control%mx_spec_levs,nzens) )
      allocate (Sw_output%swup_special   &
                            (ix, jx, Rad_control%mx_spec_levs,nzens) )
      allocate (Sw_output%bdy_flx        &
                                 (ix, jx, 4, nzens) )

      Sw_output%fsw   (:,:,:,:) = 0.0
      Sw_output%dfsw  (:,:,:,:) = 0.0
      Sw_output%ufsw  (:,:,:,:) = 0.0
      Sw_output%hsw   (:,:,:,:) = 0.0
      Sw_output%dfsw_dir_sfc = 0.0
      Sw_output%dfsw_dif_sfc  = 0.0
      Sw_output%ufsw_dif_sfc = 0.0
      Sw_output%dfsw_vis_sfc = 0.
      Sw_output%ufsw_vis_sfc = 0.
      Sw_output%dfsw_vis_sfc_dir = 0.
      Sw_output%dfsw_vis_sfc_dif = 0.
      Sw_output%ufsw_vis_sfc_dif = 0.
      Sw_output%swdn_special  (:,:,:,:) = 0.0
      Sw_output%swup_special  (:,:,:,:) = 0.0
      Sw_output%bdy_flx(:,:,:,:) = 0.0       

!---------------------------------------------------------------------
!    if the cloud-free values are desired, allocate and initialize 
!    arrays for the fluxes and heating rate in the absence of clouds.
!----------------------------------------------------------------------
      if (Rad_control%do_totcld_forcing) then
        allocate (Sw_output%fswcf  (ix, jx, kx+1,nzens) )
        allocate (Sw_output%dfswcf (ix, jx, kx+1,nzens) )
        allocate (Sw_output%ufswcf (ix, jx, kx+1,nzens) )
        allocate (Sw_output%hswcf  (ix, jx, kx,nzens  ) )
        allocate (Sw_output%dfsw_dir_sfc_clr (ix, jx,nzens) )
        allocate (Sw_output%dfsw_dif_sfc_clr (ix, jx,nzens) )
        allocate (Sw_output%dfsw_vis_sfc_clr (ix, jx,nzens  ) )
        allocate (Sw_output%swdn_special_clr    &
                            (ix, jx, Rad_control%mx_spec_levs,nzens) )
        allocate (Sw_output%swup_special_clr   &
                            (ix, jx, Rad_control%mx_spec_levs,nzens) )
        allocate (Sw_output%bdy_flx_clr        &
                                 (ix, jx, 4,nzens) )

        Sw_output%fswcf (:,:,:,:) = 0.0
        Sw_output%dfswcf(:,:,:,:) = 0.0
        Sw_output%ufswcf(:,:,:,:) = 0.0
        Sw_output%hswcf (:,:,:,:) = 0.0
        Sw_output%dfsw_dir_sfc_clr = 0.0
        Sw_output%dfsw_dif_sfc_clr  = 0.0
        Sw_output%dfsw_vis_sfc_clr = 0.
        Sw_output%swdn_special_clr  (:,:,:,:) = 0.0
        Sw_output%swup_special_clr  (:,:,:,:) = 0.0
        Sw_output%bdy_flx_clr (:,:,:,:) = 0.0
      endif

!--------------------------------------------------------------------

end  subroutine shortwave_driver_alloc


!###################################################################
! <SUBROUTINE NAME="shortwave_driver_alloc">
!  <OVERVIEW>
!   Code that allocates and initializes shortwave output variables
!  </OVERVIEW>
!  <DESCRIPTION>
!   Shortwave_driver_alloc allocates and initializes the components
!   of the sw_output_type variable Sw_output, which is used to hold
!   output data from shortwave_driver_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call shortwave_driver_alloc (ix, jx, kx, Sw_output)
!  </TEMPLATE>
!  <IN NAME="ix" TYPE="integer">
!   x dimention of the radiation grid where shortwave output is desired
!  </IN>
!  <IN NAME="jx" TYPE="integer">
!   y dimention of the radiation grid where shortwave output is desired
!  </IN>
!  <IN NAME="kx" TYPE="integer">
!   z dimention of the radiation grid where shortwave output is desired
!  </IN>
!  <INOUT NAME="Sw_output" TYPE="sw_output_type">
!   shortwave radiation output variable
!  </INOUT>
! </SUBROUTINE>
!
subroutine shortwave_driver_dealloc (Sw_output)

!--------------------------------------------------------------------
!    shortwave_driver_dealloc deallocates the components
!    of the sw_output_type variable Sw_output, which is used to hold
!    output data from shortwave_driver_mod.
!--------------------------------------------------------------------

type(sw_output_type), intent(inout)  ::  Sw_output

!-------------------------------------------------------------------
!  intent(inout) variables:
!
!      Sw_output  sw_output_type variable containing shortwave 
!                 radiation output data 
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    deallocate fields to contain net(up-down) sw flux 
!    (fsw), upward sw flux (ufsw), downward sw flux(dfsw) at flux 
!    levels and sw heating in model layers (hsw).
!--------------------------------------------------------------------
      deallocate (Sw_output%fsw)
      deallocate (Sw_output%ufsw)
      deallocate (Sw_output%dfsw)
      deallocate (Sw_output%hsw)
      deallocate (Sw_output%dfsw_dir_sfc)
      deallocate (Sw_output%ufsw_dif_sfc)
      deallocate (Sw_output%dfsw_dif_sfc)
      deallocate (Sw_output%dfsw_vis_sfc)
      deallocate (Sw_output%ufsw_vis_sfc)
      deallocate (Sw_output%dfsw_vis_sfc_dir)
      deallocate (Sw_output%dfsw_vis_sfc_dif)
      deallocate (Sw_output%ufsw_vis_sfc_dif)
      deallocate (Sw_output%swdn_special)
      deallocate (Sw_output%swup_special)
      deallocate (Sw_output%bdy_flx)
!---------------------------------------------------------------------
!    if the cloud-free values are desired, allocate and initialize 
!    arrays for the fluxes and heating rate in the absence of clouds.
!----------------------------------------------------------------------
      if (Rad_control%do_totcld_forcing) then
        deallocate (Sw_output%fswcf)
        deallocate (Sw_output%dfswcf)
        deallocate (Sw_output%ufswcf)
        deallocate (Sw_output%hswcf)
        deallocate (Sw_output%dfsw_dir_sfc_clr)
        deallocate (Sw_output%dfsw_dif_sfc_clr)
        deallocate (Sw_output%dfsw_vis_sfc_clr)
        deallocate (Sw_output%swdn_special_clr)
        deallocate (Sw_output%swup_special_clr)
        deallocate (Sw_output%bdy_flx_clr)
      endif

!--------------------------------------------------------------------

end  subroutine shortwave_driver_dealloc



!####################################################################


                end module shortwave_driver_mod



!FDOC_TAG_GFDL

                 module specified_clouds_W_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use  time_manager_mod,  only:  time_type
use   cloud_zonal_mod,  only:  getcld
use     cloud_obs_mod,  only:  cloud_obs, cloud_obs_init
use           mpp_mod,  only:  input_nml_file
use           fms_mod,  only:  open_namelist_file, file_exist, &
                               check_nml_error, &
                               close_file, &
                               mpp_pe, mpp_root_pe, &
                               write_version_number, stdlog
use rad_utilities_mod,  only:  cldrad_properties_type, &
                               Cldrad_control, &
                               cld_specification_type
use     constants_mod,  only:  pstd_mks

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!             specified clouds radiative properties module;
!             used with cloud_obs_mod and cloud_zonal_mod
!
!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128)  :: version =  '$Id: specified_clouds_W.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
  character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          specified_clouds_W_init, specified_clouds_amt, &
          specified_clouds_W_end

!---------------------------------------------------------------------
!-------- namelist  ---------


integer    :: dummy=0           



namelist /specified_clouds_W_nml /     &
                                         dummy   


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

integer, parameter  :: NOFCLDS_SP=3  ! total number of clouds per column
integer, parameter  :: NOFMXOLW=1    ! number of max overlap clouds
integer, parameter  :: NOFRNDLW=2    ! number of random overlap clouds
 

!--------------------------------------------------------------------
!   crfvis   :  visible band reflectivity
!--------------------------------------------------------------------
real  :: crfvis_hi  = 0.21
real  :: crfvis_mid = 0.45
real  :: crfvis_low = 0.59

!--------------------------------------------------------------------
!   crfir    :  near-ir band reflectivity
!--------------------------------------------------------------------
real  :: crfir_hi   = 0.21
real  :: crfir_mid  = 0.45
real  :: crfir_low  = 0.59

!--------------------------------------------------------------------
!   cldem    :  infrared emissivity
!--------------------------------------------------------------------
real  :: cldem_hi   = 1.00
real  :: cldem_mid  = 1.00
real  :: cldem_low  = 1.00

!--------------------------------------------------------------------
!   cabir    :  near-ir band absorptivity
!--------------------------------------------------------------------
real  :: cabir_hi   = 0.005
real  :: cabir_mid  = 0.02
real  :: cabir_low  = 0.035


logical  :: module_is_initialized = .false.

!------------------------------------------------------------------
!------------------------------------------------------------------



contains 





! <SUBROUTINE NAME="specified_clouds_W_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call specified_clouds_W_init (lonb, latb)
!
!  </TEMPLATE>
!  <IN NAME="lonb" TYPE="real">
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine specified_clouds_W_init (lonb, latb)


real, dimension(:,:), intent(in) :: lonb, latb


      integer          :: unit, ierr, io, logunit

!---------------------------------------------------------------------
!-----  read namelist  ------
  
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=specified_clouds_W_nml, iostat=io)
      ierr = check_nml_error(io,'specified_clouds_W_nml')
#else   
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=specified_clouds_W_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'specified_clouds_W_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
        call write_version_number(version, tagname)
        logunit = stdlog()
        write (logunit,nml=specified_clouds_W_nml)
      endif

!---------------------------------------------------------------------
!    if observed clouds is active, initialize that module.
!---------------------------------------------------------------------
      if (Cldrad_control%do_obs_clouds) then
        call cloud_obs_init (lonb, latb)
      endif
 
      module_is_initialized = .true.

end subroutine specified_clouds_W_init

! <SUBROUTINE NAME="specified_clouds_W_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call specified_clouds_W_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine specified_clouds_W_end
        
!----------------------------------------------------------------------
!    specified_clouds_W_end is the destructor for specified_clouds_W_mod.
!----------------------------------------------------------------------
        
!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.

!--------------------------------------------------------------------
 

end subroutine specified_clouds_W_end


!######################################################################

! <SUBROUTINE NAME="specified_clouds_amt">
!  <OVERVIEW>
!    specified_clouds_amt defines the location, amount (cloud fraction),
!    number and type (hi, mid, low) of clouds present on the model grid.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    specified_clouds_amt defines the location, amount (cloud fraction),
!    number and type (hi, mid, low) of clouds present on the model grid.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call specified_clouds_amt (is, ie, js, je, Rad_time, lat, pflux, &
!                Cld_spec)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
!      Rad_time     time at which the climatologically-determined,
!                   time-varying specified cloud fields should apply
!                   [ time_type, days and seconds]
! 
!  </IN>
!  <IN NAME="lat" TYPE="real">
!      lat          latitude of model points  [ radians ]
! 
!  </IN>
!  <IN NAME="pflux" TYPE="real">
!      pflux        average of pressure at adjacent model levels
!                   [ (kg /( m s^2) ]
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec     cld_specification_type variable containing the
!                   cloud specification input fields needed by the
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of
!                           low clouds in a grid box
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine specified_clouds_amt (is, ie, js, je, Rad_time, lat, pflux, &
                                 Cld_spec)

!----------------------------------------------------------------------
!    specified_clouds_amt defines the location, amount (cloud fraction),
!    number and type (hi, mid, low) of clouds present on the model grid.
!----------------------------------------------------------------------
 
!--------------------------------------------------------------------
integer,                      intent(in)    :: is, ie, js, je
type(time_type),              intent(in)    :: Rad_time
real, dimension(:,:),         intent(in)    :: lat
real, dimension(:,:,:),       intent(in)    :: pflux
type(cld_specification_type), intent(inout) :: Cld_spec
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Rad_time     time at which the climatologically-determined, 
!                   time-varying specified cloud fields should apply
!                   [ time_type, days and seconds]
!      lat          latitude of model points  [ radians ]
!      pflux        average of pressure at adjacent model levels
!                   [ (kg /( m s^2) ] 
!
!   intent(inout) variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of 
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of 
!                           low clouds in a grid box
!                                                                  
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real, dimension    (size (Cld_spec%camtsw,1),                 &
                          size (Cld_spec%camtsw,2),                 &
                          NOFCLDS_SP       ) ::      camtsw3
      integer, dimension (size (Cld_spec%camtsw,1),                 &
                          size (Cld_spec%camtsw,2),                 &
                          NOFCLDS_SP       ) ::      ktopsw3, kbtmsw3
      real, dimension    (size (Cld_spec%camtsw,1),                 &
                          size (Cld_spec%camtsw,2),                 &
                          size (Cld_spec%camtsw,3)+1)  ::   phaf      

      integer  ::     k, j, i
      integer  ::     kerad

!---------------------------------------------------------------------
!    local variables:
!
!
!         camtsw3   cloud fraction in cloud space for the specified 
!                   cloud types;  currently, k = 1 is for hi cloud,
!                   k = 2 is for mid cloud, k = 3 is for low cloud
!         ktopsw3   model k index of cloud top for the specified cloud 
!                   types (hi, mid, low)
!         kbtmsw3   model k index of the cloud base for the specified 
!                   cloud types (hi, mid, low)
!            phaf   pressure at model interface levels adjusted so that
!                   a sigma value based on the mean sea level pressure 
!                   is the same as the sigma value based on actual 
!                   surface pressure
!         i, j, k   do loop indices
!           kerad   number of model layers
!
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!    define the number of model layers.
!---------------------------------------------------------------------
      kerad = size (Cld_spec%camtsw,3)

!-----------------------------------------------------------------------
!    define the number of random and maximally overlapped clouds and the
!    total number of clouds in a column. these numbers are prescribed.
!-----------------------------------------------------------------------
      Cld_spec%nmxolw(:,:) = NOFMXOLW
      Cld_spec%nrndlw(:,:) = NOFRNDLW
      Cld_spec%ncldsw(:,:) = NOFCLDS_SP 

!---------------------------------------------------------------------
!    define the interface pressure that produces the same value of
!    sigma based on the mean sea level pressure as is obtained using
!    the actual interface pressures and surface pressure.
!---------------------------------------------------------------------
      do k=1, kerad+1        
        phaf(:,:,k) = pflux(:,:,k)*pstd_mks/pflux(:,:,kerad+1)
      end do

!------------------------------------------------------------------
!    call getcld to obtain the cloud fractions, tops and bases for
!    the specified clouds. these are returned in cloud-space.
!------------------------------------------------------------------
      call getcld (Rad_time, lat, phaf, ktopsw3, kbtmsw3, camtsw3 )
      if (Cldrad_control%do_obs_clouds) then
        call cloud_obs (is, js, Rad_time, camtsw3)
      endif


!---------------------------------------------------------------------
!    map the cloud-space arrays obtained above to model space arrays. 
!    define the logical arrays which denote the grid boxes containing
!    the various cloud types (hi, middle, low).
!-------------------------------------------------------------------
      do j=1, size(Cld_spec%hi_cloud,2)
        do i=1,size(Cld_spec%hi_cloud,1)

!--------------------------------------------------------------------
!    high clouds
!--------------------------------------------------------------------
          do k=ktopsw3(i,j,1), kbtmsw3(i,j,1)-1
            Cld_spec%camtsw(i,j,k) = camtsw3(i,j,1)
            Cld_spec%hi_cloud(i,j,k) = .true.
            Cld_spec%crndlw(i,j,k) = camtsw3(i,j,1)
          end do

!--------------------------------------------------------------------
!    middle clouds
!--------------------------------------------------------------------
          do k=ktopsw3(i,j,2), kbtmsw3(i,j,2)-1
            Cld_spec%camtsw(i,j,k) = camtsw3(i,j,2)
            Cld_spec%mid_cloud(i,j,k) = .true.
            Cld_spec%crndlw(i,j,k) = camtsw3(i,j,2)
          end do

!--------------------------------------------------------------------
!    low clouds
!--------------------------------------------------------------------
          do k=ktopsw3(i,j,3), kbtmsw3(i,j,3)-1
            Cld_spec%camtsw(i,j,k) = camtsw3(i,j,3)
            Cld_spec%low_cloud(i,j,k) = .true.
            Cld_spec%cmxolw(i,j,k) = camtsw3(i,j,3)
          end do
        end do
      end do

!---------------------------------------------------------------------


end subroutine specified_clouds_amt 


!####################################################################

! <SUBROUTINE NAME="obtain_bulk_lw_specified">
!  <OVERVIEW>
!    obtain_bulk_lw_specified defines bulk longwave cloud radiative
!    properties for the specified cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_lw_specified defines bulk longwave cloud radiative
!    properties for the specified cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_lw_specified (is, ie, js, je, Cld_spec,   &
!                Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </INOUT>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for
!                               maximally overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_lw_specified (is, ie, js, je, Cld_spec,   &
                                     Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_lw_specified defines bulk longwave cloud radiative 
!    properties for the specified cloud scheme.
!---------------------------------------------------------------------

integer,                      intent(in)    :: is, ie, js, je
type(cld_specification_type), intent(inout) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer     ::  i,j,k    ! do loop indices

!---------------------------------------------------------------------
!    assign the proper values for cloud emissivity to each grid box
!    with cloudiness, dependent on whether the cloud in that box is 
!    defined as being high, middle or low cloud. high and middle clouds
!    are assumed to be random overlap, low clouds are assume to be
!    maximum overlap.
!----------------------------------------------------------------------
      do k=1, size(Cld_spec%hi_cloud,3)              
        do j=1,size(Cld_spec%hi_cloud,2)
          do i=1,size(Cld_spec%hi_cloud,1)
            if (Cld_spec%hi_cloud(i,j,k)) then
              Cldrad_props%emrndlw(i,j,k,:,1)  = cldem_hi
            else if (Cld_spec%mid_cloud(i,j,k)) then
              Cldrad_props%emrndlw(i,j,k,:,1)  = cldem_mid
            else if (Cld_spec%low_cloud(i,j,k)) then
              Cldrad_props%emmxolw(i,j,k,:,1)  = cldem_low
            endif
          enddo
        end do
      end do

!---------------------------------------------------------------------



end subroutine obtain_bulk_lw_specified



!####################################################################

! <SUBROUTINE NAME="obtain_bulk_sw_specified">
!  <OVERVIEW>
!    obtain_bulk_sw_specified defines bulk shortwave cloud radiative
!    properties for the specified cloud scheme.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_sw_specified defines bulk shortwave cloud radiative
!    properties for the specified cloud scheme.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_sw_specified (is, ie, js, je, Cld_spec, &
!                Cldrad_props)                     
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec          cloud specification arrays defining the
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input
!                        to this subroutine
!                        [ cld_specification_type ]
! 
!  </INOUT>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the
!                               visible frequency band
!                               [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_sw_specified (is, ie, js, je, Cld_spec, &
                                 Cldrad_props)                     

!---------------------------------------------------------------------
!    obtain_bulk_sw_specified defines bulk shortwave cloud radiative 
!    properties for the specified cloud scheme.
!---------------------------------------------------------------------

integer,                      intent(in)    :: is, ie, js, je
type(cld_specification_type), intent(inout) :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props
!-------------------------------------------------------------------

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cld_spec          cloud specification arrays defining the 
!                        location, amount and type (hi, middle, lo)
!                        of clouds that are present, provides input 
!                        to this subroutine
!                        [ cld_specification_type ]
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      integer     ::  i,j,k    ! do loop indices

!---------------------------------------------------------------------
!    assign the proper values for cloud absorptivity and reflectivity
!    to each grid box with cloudiness, dependent on whether the cloud 
!    in that box is defined as being high, middle or low cloud. 
!----------------------------------------------------------------------
      do k=1, size(Cld_spec%hi_cloud,3)              
        do j=1,size(Cld_spec%hi_cloud,2)
          do i=1,size(Cld_spec%hi_cloud,1)
            if (Cld_spec%hi_cloud(i,j,k)) then
              Cldrad_props%cirabsw(i,j,k)  = cabir_hi 
              Cldrad_props%cirrfsw(i,j,k)  = crfir_hi
              Cldrad_props%cvisrfsw(i,j,k) = crfvis_hi
            else if (Cld_spec%mid_cloud(i,j,k)) then
              Cldrad_props%cirabsw(i,j,k)  = cabir_mid
              Cldrad_props%cirrfsw(i,j,k)  = crfir_mid
              Cldrad_props%cvisrfsw(i,j,k) = crfvis_mid
            else if (Cld_spec%low_cloud(i,j,k)) then
              Cldrad_props%cirabsw(i,j,k)  = cabir_low
              Cldrad_props%cirrfsw(i,j,k)  = crfir_low
              Cldrad_props%cvisrfsw(i,j,k) = crfvis_low
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------



end subroutine obtain_bulk_sw_specified 




!######################################################################



                 end module specified_clouds_W_mod





!FDOC_TAG_GFDL
 
                 module standalone_clouds_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
! fil   
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use mpp_mod,                    only: input_nml_file
use fms_mod,                    only: fms_init, open_namelist_file, &
                                      write_version_number, mpp_pe, &
                                      mpp_root_pe, stdlog,   &
                                      file_exist, check_nml_error,   &
                                      error_mesg, FATAL, close_file
use rad_utilities_mod,          only: rad_utilities_init, &
                                      Cldrad_control, &
                                      cld_specification_type, &
                                      cldrad_properties_type,  &
                                      microphysics_type,  &
                                      microrad_properties_type, &
                                      Sw_control

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!   standalone cloud radiative properties module
!
!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128)  :: version =  '$Id: standalone_clouds.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
  character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          standalone_clouds_init,                           &
          standalone_clouds_end,                           &
          define_column_properties, &
      standalone_clouds_amt, obtain_micro_lw_sa, obtain_micro_sw_sa,  &
       obtain_bulk_lw_sa, obtain_bulk_sw_sa

!---------------------------------------------------------------------
!-------- namelist  ---------

character(len=16) :: cldht_type_form='   '
character(len=16) :: cloud_data_form='   '
character(len=16) :: cloud_overlap_form='   '
character(len=16) :: lhsw_cld_prop_form='   '
character(len=16) :: lw_cld_prop_form='   '
integer           :: cloud_data_points = 0

namelist /standalone_clouds_nml /     &
                          cldht_type_form, cloud_data_form, &
                          cloud_data_points, cloud_overlap_form, &
                          lhsw_cld_prop_form,  &
                          lw_cld_prop_form


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

!logical ::          do_esfsw

!------------------------------------------------------------------
!    test (singlecolumn) values for cloud amount, height index,
!    infrared emissivity and shortwave reflectivity and absorptivity
!------------------------------------------------------------------

integer                               :: ich, icm, ict, icb
real                                  :: ch, cm, cl
real, dimension(:,:), allocatable     :: cloud_amount_in
real, dimension(:,:), allocatable     :: max_cloud_amount_in
real, dimension(:,:), allocatable     :: rnd_cloud_amount_in
integer, dimension(:), allocatable    :: nmax_cloud_in
integer, dimension(:), allocatable    :: nrnd_cloud_in




 real, dimension(:,:), allocatable     :: cvis_rf_in, cir_rf_in,  &
                                          cir_abs_in

 real, dimension(:,:,:), allocatable   :: emlw_band_in
real, dimension(:,:), allocatable     :: emlw_in

!----------------------------------------------------------------------
!   define default values for shortwave cloud absorptivity and
!   reflectivity for use only in the lacis-hansen implementation
!   of shortwave radiative transfer
!      (these are the values previously used in SKYHI)
!----------------------------------------------------------------------
real                 :: lowcloud_refl_visband = 0.66E+00
real                 :: midcloud_refl_visband = 0.54E+00
real                 :: highcloud_refl_visband = 0.21E+00
real                 :: lowcloud_refl_nearirband = 0.50E+00
real                 :: midcloud_refl_nearirband = 0.46E+00
real                 :: highcloud_refl_nearirband = 0.19E+00
real                 :: lowcloud_abs_visband = 0.0E+00
real                 :: midcloud_abs_visband = 0.0E+00
real                 :: highcloud_abs_visband = 0.0E+00
real                 :: lowcloud_abs_nearirband = 0.30E+00
real                 :: midcloud_abs_nearirband = 0.20E+00
real                 :: highcloud_abs_nearirband = 0.04E+00

!----------------------------------------------------------------------
!   define default (grey) values for longwave emissivity for low, mid,
!   high clouds. these are used if no microphysics parameterizations
!   (or assumptions) are used in the longwave radiative transfer
!      (these are the values previously used in SKYHI)
!----------------------------------------------------------------------
real                 :: lowcloud_emiss = 1.00E+00
real                 :: midcloud_emiss = 1.00E+00
real                 :: highcloud_emiss = 1.00E+00

real  ::       pie 

!---------------------------------------------------------------------
!        cldhp             sigma value defining high-middle cloud boun-
!                          dary at the pole [ dimensionless ]
!        cldhe             sigma value defining high-middle cloud boun-
!                          dary at the equator [ dimensionless ]
!        cldmp             sigma value defining middle-low cloud boun-
!                          dary at the pole [ dimensionless ]
!        cldme             sigma value defining middle-low cloud boun-
!                          dary at the equator [ dimensionless ]
!---------------------------------------------------------------------
      real        :: cldhp = 0.7                   
      real        :: cldhe = 0.4            
      real        :: cldmp = 0.85                  
      real        :: cldme = 0.7                 

     logical :: module_is_initialized = .false.
!----------------------------------------------------------------------
!----------------------------------------------------------------------



                        contains 


!####################################################################

! <SUBROUTINE NAME="standalone_clouds_init">
!  <OVERVIEW>
!    subroutine standalone_clouds_init is the constructor for the
!    standalone_clouds_mod.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine standalone_clouds_init is the constructor for the
!    standalone_clouds_mod.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call standalone_clouds_init (pref, lonb, latb)
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!       pref      array containing two reference pressure profiles
!                 for use in defining transmission functions [ Pa ]
! 
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!       lonb      2d array of model longitudes at cell corners [ radians ]
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
!       latb      2d array of model latitudes at cell corners [radians]
! 
!  </IN>
! </SUBROUTINE>
!
subroutine standalone_clouds_init (pref, lonb, latb)

!--------------------------------------------------------------------
!    subroutine standalone_clouds_init is the constructor for the
!    standalone_clouds_mod.
!---------------------------------------------------------------------

real, dimension(:,:), intent(in)    ::  pref        
real, dimension(:,:), intent(in)    ::  lonb, latb

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       pref      array containing two reference pressure profiles 
!                 for use in defining transmission functions [ Pa ]
!       lonb      2d array of model longitudes at cell corners [ radians ]
!       latb      2d array of model latitudes at cell corners [radians]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables:

      real               :: max_cld_calc
      integer            :: unit, ierr, io, logunit
      integer            :: ktop, kbot
      integer            :: idf, jdf, kx
      integer            :: i, k, kk

!---------------------------------------------------------------------
!   local variables:
!
!      max_cld_calc maximum cloud amount in any layer within a maximum
!                   random overlap cloud [ dimensionless ]
!      unit         io unit for reading nml file and writing logfile
!      io           error status returned from io operation  
!      ierr         error code
!      ktop         cloud top index
!      kbot         cloud bottom index
!      idf          number of longitudes assigned to the processor
!      jdf          number of latitudes assigned to the processor
!      kx           number of layers in the model
!      i,k,kk       do loop indices
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
 
!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=standalone_clouds_nml, iostat=io)
   ierr = check_nml_error(io,"standalone_clouds_nml")
#else
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=standalone_clouds_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'standalone_clouds_nml')
        enddo
10      call close_file (unit)
      endif
#endif

!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() )    &
                       write (logunit, nml=standalone_clouds_nml)

!---------------------------------------------------------------------
!    define size of processor's domain.
!---------------------------------------------------------------------
      idf = size(lonb,1) - 1
      jdf = size(latb,2) - 1
      kx  = size(pref,1) - 1
      
!---------------------------------------------------------------------
!    define the value of pi for later use.
!---------------------------------------------------------------------
      pie = 4.0*ATAN(1.0)

!---------------------------------------------------------------------
!    save the number of requested cloud columns in a derived type 
!    variable for later use. ensure that this quantity is  at least one
!    but no more than the number of longitudes assigned to the processor
!    (idf). 
!---------------------------------------------------------------------
      Cldrad_control%cloud_data_points = cloud_data_points
      if (cloud_data_points < 1 .or.   &
          cloud_data_points > idf) then
        call error_mesg( 'standalone_clouds_mod',  &
                 ' cloud_data_points must be greater than zero but '//&
                   'no larger than the number of model longitudes', &
                                                               FATAL)
      endif

!---------------------------------------------------------------------
!    allocate the module variables which will hold the cloud specific-
!    ation information (total amount, max rnd amount, rnd amount, max
!    rnd cloud number, rnd cloud number). initialize the values to zero,
!    corresponding to the absence of clouds.
!---------------------------------------------------------------------
      allocate (cloud_amount_in     (idf, kx))
      allocate (max_cloud_amount_in (idf, kx))
      allocate (rnd_cloud_amount_in (idf, kx))
      allocate (nmax_cloud_in       (idf))
      allocate (nrnd_cloud_in       (idf))
      cloud_amount_in     = 0.0E+00
      max_cloud_amount_in = 0.0E+00
      rnd_cloud_amount_in = 0.0E+00
      nmax_cloud_in       = 0
      nrnd_cloud_in       = 0

!---------------------------------------------------------------------
!    if cloud data is to be supplied via input file, open the input
!    file, read the data for each column into cloud-amount_in, and then
!    close the file.
!---------------------------------------------------------------------
      if (trim(cloud_data_form) == 'input') then
        unit = open_namelist_file ('INPUT/cld_amt_file')
        do i=1,cloud_data_points
          read (unit,FMT = '(5e18.10)') (cloud_amount_in(i,k),k=1,kx)
        end do
        call close_file (unit)
      
!---------------------------------------------------------------------
!    if random overlap is assumed, compute the number of max_random and
!    random overlap clouds. the number of max_random is assumed to
!    be zero, while each layer with cloud present is assumed to be
!    a separate raandom overlap cloud. 
!---------------------------------------------------------------------
        if (trim(cloud_overlap_form) == 'random') then
          nrnd_cloud_in = COUNT(cloud_amount_in > 0.0E+00,DIM=2)
          nmax_cloud_in = 0
          max_cloud_amount_in = 0.0E+00
          rnd_cloud_amount_in = cloud_amount_in

!---------------------------------------------------------------------
!    if max_random overlap is assumed, compute the number of max_random
!    and random overlap clouds. 
!---------------------------------------------------------------------
        else if (trim(cloud_overlap_form) == 'max_random') then
          do i=1,cloud_data_points
            ktop = 1
            kbot = 1
            do k=1,kx-1
!----------------------------------------------------------------------
!    the cloud code below accounts for clouds in the (ktop, kbot) 
!    layers. cycle k to (kbot+1) to continue processing.
!----------------------------------------------------------------------
              if (k  > 1 .AND. k <= kbot) CYCLE

!----------------------------------------------------------------------
!    march downward in the column; find the next lower cloud top layer.
!----------------------------------------------------------------------
              if (cloud_amount_in(i,k) > 0.0E+00) then

!----------------------------------------------------------------------
!   determine the thickness of this cloud.
!----------------------------------------------------------------------
                ktop = k
                kbot = k
                do kk=ktop+1,kx   
!----------------------------------------------------------------------
!   find the base of the current cloud. at that point exit the loop.
!----------------------------------------------------------------------
                  if ( cloud_amount_in(i,kk) == 0.0E+00) EXIT
                  kbot = kk
                end do

!----------------------------------------------------------------------
!    if it is a single-layer cloud, assign it random cloud overlap prop-
!    erties.
!----------------------------------------------------------------------
                if (ktop == kbot) then
                  max_cloud_amount_in(i,k) = 0.0E+00
                  rnd_cloud_amount_in(i,k) = cloud_amount_in(i,k)
                  nrnd_cloud_in(i) = nrnd_cloud_in(i) + 1

!----------------------------------------------------------------------
!    if it is a multi-layer cloud, treat it as a max-random overlap
!    cloud. TEMPORARILY, set max cloud amount = max(cloud amounts from 
!    ktop to kbot) and set rnd cloud amount = zero.
!----------------------------------------------------------------------
                else
                  max_cld_calc = MAXVAL (cloud_amount_in(i,ktop:kbot))
                  max_cloud_amount_in(i,ktop:kbot) = max_cld_calc
                  rnd_cloud_amount_in(i,ktop:kbot) = 0.0E+00
                  nmax_cloud_in(i) = nmax_cloud_in(i) + 1
                endif

!----------------------------------------------------------------------
!    if cloud is not present at this level,  check the next level.
!----------------------------------------------------------------------
              else
                ktop = k
                kbot = k
              endif
            end do

!----------------------------------------------------------------------
!    deal with special case of cloud in lowest layer, no cloud in
!    next lowest layer (should never happen).
!----------------------------------------------------------------------
            if (cloud_amount_in(i,kx) > 0.0E+00 .AND.     &
                cloud_amount_in(i,kx-1) == 0.0E+00   ) then
              rnd_cloud_amount_in(i,kx   ) = cloud_amount_in(i,kx   )
              max_cloud_amount_in(i,kx   ) = 0.0E+00
              nrnd_cloud_in(i) = nrnd_cloud_in(i) + 1
            endif
          end do

!----------------------------------------------------------------------
!    error case: invalid specification of cloud_overlap_form.
!----------------------------------------------------------------------
        else
          call error_mesg( 'standalone_clouds_mod',  &
             ' cloud_overlap_form is not an acceptable value.', FATAL)
        endif
 
!----------------------------------------------------------------------
!    if cloud data is specified, define cloud amounts for high, middle
!    and low clouds. 
!----------------------------------------------------------------------
      else if (trim(cloud_data_form) == 'specified') then
        ch   = 0.159E+00
        cm   = 0.070E+00
        cl   = 0.269E+00

!----------------------------------------------------------------------
!    define the model k indices of the high and middle clouds (single 
!    layer) and the k indices of low cloud tops and bases (multi-layer 
!    clouds)  for levels corresponding to 3 different gcms: L40 SKYHI, 
!    the L18 NMC model, and the R30L14 supersource model. if column_type
!    is not recognized, print an error message and stop.
!----------------------------------------------------------------------
        if (trim(cldht_type_form)         == 'skyl40') then
          ich  = 29 
          icm  = 34
          ict  = 35 
          icb  = 37 
        else if (trim(cldht_type_form)         == 'nmcl18') then
          ich  =  5 
          icm  = 11 
          ict  = 12 
          icb  = 14 
        else if (trim(cldht_type_form)         == 'r30l14') then
          ich  = 6 
          icm  = 9 
          ict  = 10 
          icb  = 12 
        else if (trim(cldht_type_form)         == 'fmsl18') then
          ich  = 6   
          icm  = 9       
          ict  = 10  
          icb  = 12
        else
          call error_mesg ('standalone_clouds_mod', &
            'cloud properties have not been specified for'//&
             ' this column type', FATAL)
        endif

!---------------------------------------------------------------------
!    verify that the specified cloud levels are compatible with the
!    the model grid being used in this experiment.
!---------------------------------------------------------------------
        if (ich > kx  .or. icm > kx .or. ict > kx .or. icb > kx) then
          call error_mesg ('standalone_clouds_mod', &
            'specified cloud level index not within model grid', FATAL)
        endif
        if (ich < 1   .or. icm < 1  .or. ict < 1  .or. icb < 1) then
          call error_mesg ('standalone_clouds_mod', &
            'specified cloud level index not within model grid', FATAL)
        endif

!---------------------------------------------------------------------
!    save the cloud level indices for use elsewhere in defining the 
!    cloud radiative properties.
!---------------------------------------------------------------------
        Cldrad_control%ich = ich
        Cldrad_control%icm = icm
        Cldrad_control%ict = ict
        Cldrad_control%icb = icb

!---------------------------------------------------------------------
!    now specify the characteristics of three cloud columns; more can
!    be specified if desired, limited by the number of longitudes owned
!    by the processor.
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!    the first cloud column contains 3 clouds, including a max-random 
!    overlap cloud.
!----------------------------------------------------------------------
        rnd_cloud_amount_in(1,ich) = ch
        rnd_cloud_amount_in(1,icm) = cm
        do k=ict,icb
          max_cloud_amount_in(1,k) = cl
        end do
        nmax_cloud_in(1) = 1
        nrnd_cloud_in(1) = 2

!---------------------------------------------------------------------
!    the second cloud column is cloudless.
!---------------------------------------------------------------------
        if (cloud_data_points > 1) then
          max_cloud_amount_in(2,:) = 0.0
          rnd_cloud_amount_in(2,:) = 0.0
          nmax_cloud_in(2) = 0
          nrnd_cloud_in(2) = 0
        endif

!---------------------------------------------------------------------
!    the third cloud column contains 5 random overlap clouds.
!---------------------------------------------------------------------
        if (cloud_data_points > 2) then
          rnd_cloud_amount_in(3,ich) = ch
          rnd_cloud_amount_in(3,icm) = cm
          do k=ict,icb
            rnd_cloud_amount_in(3,k) = cl
          enddo
          nmax_cloud_in(3) = 0
          nrnd_cloud_in(3) = 5
        endif

!---------------------------------------------------------------------
!    error case: invalid cloud_data_form
!---------------------------------------------------------------------
      else
        call error_mesg( 'standalone_clouds_mod',  &
             ' cloud_data_form is not an acceptable value.', FATAL)
      endif

!--------------------------------------------------------------------
!    mark the module as initialized.
!--------------------------------------------------------------------
      module_is_initialized = .true.

!---------------------------------------------------------------------


end subroutine standalone_clouds_init



!####################################################################

! <SUBROUTINE NAME="define_column_properties">
!  <OVERVIEW>
!    subroutine define_column_properties defines values for lw emiss-
!    ivity, visible and nir reflectivity and nir absorption to be used
!    with standalone clouds.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    subroutine define_column_properties defines values for lw emiss-
!    ivity, visible and nir reflectivity and nir absorption to be used
!    with standalone clouds.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call define_column_properties (pref, lonb, latb)
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
!       pref      array containing two reference pressure profiles
!                 for use in defining transmission functions [ Pa ]
! 
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!       lonb      2d array of model longitudes at cell corners [ radians ]
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
!       latb      2d array of model latitudes at cell corners [radians]
! 
!  </IN>
! </SUBROUTINE>
!
subroutine define_column_properties (pref, lonb, latb)

!---------------------------------------------------------------------
!    subroutine define_column_properties defines values for lw emiss-
!    ivity, visible and nir reflectivity and nir absorption to be used
!    with standalone clouds.
!---------------------------------------------------------------------

!--------------------------------------------------------------------
real, dimension(:,:), intent(in) :: pref
real, dimension(:,:), intent(in) :: lonb, latb

!---------------------------------------------------------------------
!   intent(in) variables:
!
!       pref      array containing two reference pressure profiles 
!                 for use in defining transmission functions [ Pa ]
!       lonb      2d array of model longitudes at cell corners [ radians ]
!       latb      2d array of model latitudes at cell corners [radians]
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    local variables:

      integer  ::   unit
      integer  ::   idf, jdf, kx
      integer  ::   ich, icm, ict, icb
      integer  ::   i, k, n

!---------------------------------------------------------------------
!    local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      ierr     error code
!      io       error status returned from io operation  
!      idf      x dimension of physics window
!      jdf      y dimension of physics window
!      kx       number of model layers
!      ich      model level index corresponding to level of high cloud
!      icm      model level index corresponding to level of middle cloud
!      ict      model level index corresponding to low-cloud cloud top
!      icb      model level index corresponding to low-cloud cloud base
!      i,k,n    do-loop indices
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the processor's domain dimensions. 
!---------------------------------------------------------------------
        jdf = size(latb,2) - 1
        idf = size(lonb,1) - 1
        kx  = size(pref,1) - 1

!-------------------------------------------------------------------
!    define the model levels corresponding to high cloud location, 
!    middle cloud location, low cloud top and low cloud base. 
!-------------------------------------------------------------------
        ich = Cldrad_control%ich
        icm = Cldrad_control%icm
        ict = Cldrad_control%ict
        icb = Cldrad_control%icb

!-------------------------------------------------------------------
!    allocate lw emissivity array and fill with either input or
!    specified values. default emissivity value is unity.
!-------------------------------------------------------------------
        allocate (emlw_band_in(idf, kx, Cldrad_control%nlwcldb))
        emlw_band_in(:,:,:) = 1.00E+00

!-------------------------------------------------------------------
!    if lw emissivity is to be obtained from an input file, allocate
!    an array into which it may be read, and then read the input data
!    for each desired cloud column. broadcast this data over all bands
!    of the emissivity variable.  close the input file unit. note that 
!    there must be consistency between the cloud fraction / altitude 
!    values and the emissivity values. this will be dealt with later.
!-------------------------------------------------------------------
        if (trim(lw_cld_prop_form) == 'input') then
          allocate (emlw_in (idf, kx))
          unit = open_namelist_file ('INPUT/lw_cld_prop_file')
          do i=1,Cldrad_control%cloud_data_points
            read (unit,FMT = '(5e18.10)')  (emlw_in(i,k),k=1,kx)
          end do
          do n=1,CLdrad_control%nlwcldb
            emlw_band_in(:,:,n) = emlw_in(:,:)
          end do
          call close_file (unit)

!---------------------------------------------------------------------
!    if using specified lw cloud emissivity, assign the values specified
!    in this module to the specified levels containing high, middle and
!    low clouds for each column that is to be integrated.
!---------------------------------------------------------------------
        else if (trim(lw_cld_prop_form) == 'specified') then
          if (trim(cloud_data_form) == 'specified') then
            do n=1,Cldrad_control%nlwcldb

!---------------------------------------------------------------------
!    the first specified column contains 3 clouds (max-random).
!----------------------------------------------------------------------
              emlw_band_in(1,ich,n) = highcloud_emiss
              emlw_band_in(1,icm,n) = midcloud_emiss
              do k=ict,icb
                emlw_band_in(1,k,n) = lowcloud_emiss
              end do
            end do

!---------------------------------------------------------------------
!    the second specified column contains no clouds - use default
!    value to which the array was initialized.
!----------------------------------------------------------------------
!           if (Cldrad_control%cloud_data_points > 1) then
!             emlw_band_in(2,:,:) = 1.00E+00
!           endif

!---------------------------------------------------------------------
!    the third specified column contains 5 random-overlap clouds.
!----------------------------------------------------------------------
            if (Cldrad_control%cloud_data_points > 2) then
              do n=1,CLdrad_control%nlwcldb
                emlw_band_in(3,ich,n) = highcloud_emiss
                emlw_band_in(3,icm,n) = midcloud_emiss
                do k=ict,icb
                  emlw_band_in(3,k,n) = lowcloud_emiss
                end do
              end do
            endif

!----------------------------------------------------------------------
!    if lw_cld_prop_form was specified then cloud_data_form must also be
!    specified. if this is not the case, write error message and stop
!    execution.
!---------------------------------------------------------------------
          else
            call error_mesg( 'standalone_clouds_mod',  &
                 ' if lw_cld_prop_form is specified  cloud_data_form'//&
                 ' must be specified.',                         FATAL)
          endif

!----------------------------------------------------------------------
!    if lw_cld_prop_form was neither specified nor input, write an
!    error message and stop execution.
!----------------------------------------------------------------------
        else
          call error_mesg ('standalone_clouds_mod', &
             'lw cld properties have not been specified correctly', &
                                                                FATAL)
        endif

!-------------------------------------------------------------------
!   if lhsw is active, allocate and initialize the lhsw cloud property 
!   arrays and either read an input file containing values for them or 
!   define them using the values specified in this module. the default
!   values are total reflection and zero absorption.
!-------------------------------------------------------------------
        if (Sw_control%do_lhsw) then
          allocate (cvis_rf_in (idf, kx))
          allocate (cir_rf_in  (idf, kx))
          allocate (cir_abs_in (idf, kx))
          cvis_rf_in(:,:) = 1.00E+00
          cir_rf_in (:,:) = 1.00E+00
          cir_abs_in(:,:) = 0.0

!----------------------------------------------------------------------
!    if values are supplied from an input file, open the file and read 
!    the values into the appropriate module variables.
!----------------------------------------------------------------------
          if (trim(lhsw_cld_prop_form) == 'input') then
            unit = open_namelist_file ('INPUT/lhsw_cld_prop_file')
            do i=1,Cldrad_control%cloud_data_points
              read (unit,FMT = '(5e18.10)') (cvis_rf_in(i,k),k=1,kx)
              read (unit,FMT = '(5e18.10)') (cir_rf_in(i,k),k=1,kx)
              read (unit,FMT = '(5e18.10)') (cir_abs_in(i,k),k=1,kx)
            end do
            call close_file (unit)
      
!----------------------------------------------------------------------
!    if one is to use the values provided by this module, define the
!    cldrad variables with the appropriate high, middle and low cloud
!    values. levels containing cloud are defined by ich, icm, ict and 
!    icb.
!---------------------------------------------------------------------
          else if (trim(lhsw_cld_prop_form) == 'specified') then

!---------------------------------------------------------------------
!    the first point contains 3 max-random overlap clouds. 
!---------------------------------------------------------------------
            cvis_rf_in(1,ich) = highcloud_refl_visband
            cvis_rf_in(1,icm) = midcloud_refl_visband
            cir_rf_in(1,ich)  = highcloud_refl_nearirband
            cir_rf_in(1,icm)  = midcloud_refl_nearirband
            cir_abs_in(1,ich) = highcloud_abs_nearirband
            cir_abs_in(1,icm) = midcloud_abs_nearirband
            do k=ict,icb
              cvis_rf_in(1,k) = lowcloud_refl_visband
              cir_rf_in(1,k)  = lowcloud_refl_nearirband
              cir_abs_in(1,k) = lowcloud_abs_nearirband
            end do

!---------------------------------------------------------------------
!    the second point contains no clouds -- use initialized values. 
!---------------------------------------------------------------------
!           if (Cldrad_control%cloud_data_points > 1) then
!             cvis_rf_in(2,:) = 1.00E+00
!             cir_rf_in(2,:)  = 1.00E+00
!             cir_abs_in(2,:) = 0.0
!           endif

!---------------------------------------------------------------------
!    the third point contains 5 random overlap clouds. 
!---------------------------------------------------------------------
            if (Cldrad_control%cloud_data_points > 2) then
              cvis_rf_in(3,ich) = highcloud_refl_visband
              cvis_rf_in(3,icm) = midcloud_refl_visband
              cir_rf_in(3,ich)  = highcloud_refl_nearirband
              cir_rf_in(3,icm)  = midcloud_refl_nearirband
              cir_abs_in(3,ich) = highcloud_abs_nearirband
              cir_abs_in(3,icm) = midcloud_abs_nearirband
              do k=ict,icb
                cvis_rf_in(3,k) = lowcloud_refl_visband
                cir_rf_in(3,k)  = lowcloud_refl_nearirband
                cir_abs_in(3,k) = lowcloud_abs_nearirband
              end do
            endif

!---------------------------------------------------------------------
!    if lhsw_cld_props was neither specified or input, write an error
!    message and stop execution.
!---------------------------------------------------------------------
          else
            call error_mesg ('standalone_clouds_mod', &
                    'lhsw_cld_prop_form has an improper value',  FATAL)
          endif
        endif !  (do_lhsw)

!---------------------------------------------------------------------




end subroutine define_column_properties




!######################################################################

! <SUBROUTINE NAME="standalone_clouds_end">
!  <OVERVIEW>
!    standalone_clouds_end is the destructor for standalone_clouds_mod.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    standalone_clouds_end is the destructor for standalone_clouds_mod.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call standalone_clouds_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine standalone_clouds_end
        
!----------------------------------------------------------------------
!    standalone_clouds_end is the destructor for standalone_clouds_mod.
!----------------------------------------------------------------------
       
!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.
        
!--------------------------------------------------------------------


end subroutine standalone_clouds_end



!#################################################################

! <SUBROUTINE NAME="standalone_clouds_amt">
!  <OVERVIEW>
!    standalone_clouds_amt defines the number, amount (cloud fraction),
!    and type (hi, mid, low) of clouds present on the model grid.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    standalone_clouds_amt defines the number, amount (cloud fraction),
!    and type (hi, mid, low) of clouds present on the model grid.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call standalone_clouds_amt (is, ie, js, je, lat, press_mks,  &
!                Cld_spec)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <IN NAME="lat" TYPE="real">
!      lat          latitude of model points  [ radians ]
! 
!  </IN>
!  <IN NAME="press_mks" TYPE="real">
!      press_mks    pressure at model levels (1:nlev), surface
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
! 
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!      Cld_spec     cld_specification_type variable containing the
!                   cloud specification input fields needed by the
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of
!                           low clouds in a grid box
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine standalone_clouds_amt (is, ie, js, je, lat, press_mks,  &
                                  Cld_spec)

!---------------------------------------------------------------------
!    standalone_clouds_amt defines the number, amount (cloud fraction), 
!    and type (hi, mid, low) of clouds present on the model grid.
!----------------------------------------------------------------------

integer,                      intent(in)     ::  is, ie, js, je
real,    dimension(:,:),      intent(in)     ::  lat  
real,    dimension(:,:,:),    intent(in)     ::  press_mks
type(cld_specification_type), intent(inout)  ::  Cld_spec

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      lat          latitude of model points  [ radians ]
!      press_mks    pressure at model levels (1:nlev), surface 
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
!
!   intent(inout) variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by he shortwave
!                           radiation in each grid column.
!                  %hi_cld  logical flag indicating the presence of 
!                           high clouds in a grid box
!                 %mid_cld  logical flag indicating the presence of 
!                           middle clouds in a grid box
!                 %low_cld  logical flag indicating the presence of 
!                           low clouds in a grid box
!                                                                  
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables

      real, dimension (size(Cld_spec%camtsw,2) ) :: cldhm, cldml

      real, dimension (size(Cld_spec%camtsw,1),                    &
                       size(Cld_spec%camtsw,2) ) ::  press_hm, press_ml

      integer     :: kx
      integer     :: i, j, k

!--------------------------------------------------------------------
!  local variables:
!
!        cldhm             sigma value defining high-middle cloud boun-
!                          daries at window latitudes [ dimensionless ]
!        cldml             sigma value defining middle-low cloud boun-
!                          daries at window latitudes [ dimensionless ]
!        press_hm          pressure corresponding to the high-middle
!                          cloud boundary [ (kg /( m s^2) ]
!        press_ml          pressure corresponding to the middle-low
!                          cloud boundary [ (kg /( m s^2) ]
!        kx                number of model layers
!        i,j,k             do loop indices
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    define the number of model layers.
!---------------------------------------------------------------------
      kx = size(Cld_spec%camtsw,3)

!---------------------------------------------------------------------
!    define the cloud fractions and number of clouds per column (random 
!    and max overlap) from the cloud specification data that was input. 
!    each cloud data point is replicated on each latitude row in the 
!    window.
!---------------------------------------------------------------------
      do j=1,size(Cld_spec%camtsw,2)
        do i=1,cloud_data_points
          Cld_spec%crndlw(i,j,:) = rnd_cloud_amount_in(i,:)
          Cld_spec%cmxolw(i,j,:) = max_cloud_amount_in(i,:)
          Cld_spec%nmxolw(i,j) = nmax_cloud_in(i)
          Cld_spec%nrndlw(i,j) = nrnd_cloud_in(i)
        end do
      end do

!!! NOTE:
!!!!  define Cld_spec%cld_thickness here (if needed)

!--------------------------------------------------------------------
!    sum up the random and max overlap cloud fractions and number of 
!    clouds per column to produce the values seen by the shortwave 
!    radiation. insure that cloud fraction at all grid points is <= 1.
!--------------------------------------------------------------------
      do j=1, size(Cld_spec%camtsw,2)
        do i=1,cloud_data_points
          Cld_spec%camtsw(i,j,:) = Cld_spec%crndlw(i,j,:) +    &
                                   Cld_spec%cmxolw(i,j,:)
          Cld_spec%ncldsw(i,j)   = Cld_spec%nmxolw(i,j) +      &
                                   Cld_spec%nrndlw(i,j)
        end do
      end do
      Cld_spec%camtsw = MIN (Cld_spec%camtsw,1.00)
      Cld_spec%cloud_area = Cld_spec%camtsw

!---------------------------------------------------------------------
!    determine the sigmas defining the hi-middle-lo cloud transitions
!    at each grid point. the sigmas vary with latitude between equator
!    and pole, and are linearly interpolated to the model latitude.
!---------------------------------------------------------------------
      do j=1,size(Cld_spec%camtsw,2)
        cldhm(j) = cldhp + ( (0.5*pie - abs(lat(1,j)))/(0.5*pie))* &
                   (cldhe - cldhp)
        cldml(j) = cldmp + ( (0.5*pie - abs(lat(1,j)))/(0.5*pie))* &
                   (cldme - cldmp)
      end do

!---------------------------------------------------------------------
!    define the pressures at the high-middle-low cloud boundaries.
!---------------------------------------------------------------------
      do j=1,size(Cld_spec%camtsw,2)
        do i=1,size(Cld_spec%camtsw,1)
          press_hm(i,j) = cldhm(j)*press_mks(i,j,kx+1)
          press_ml(i,j) = cldml(j)*press_mks(i,j,kx+1)
        end do
      end do

!--------------------------------------------------------------------
!    define flags indicating grid points at which either high, middle
!    or low clouds exist.
!---------------------------------------------------------------------
      do k=1,kx
        do j=1,size(Cld_spec%camtsw,2)
          do i=1,size(Cld_spec%camtsw,1)
            if (Cld_spec%camtsw(i,j,k) > 0.0) then
              if (press_mks(i,j,k) <= press_hm(i,j)) then
                Cld_spec%hi_cloud(i,j,k) = .true.
              else if (press_mks(i,j,k) > press_hm(i,j) .and.      &
                       press_mks(i,j,k) <= press_ml(i,j)) then
                Cld_spec%mid_cloud(i,j,k) = .true.
              else if (press_mks(i,j,k) > press_ml(i,j) ) then
                Cld_spec%low_cloud(i,j,k) = .true.
              endif
            endif
          end do
        end do
      end do

!---------------------------------------------------------------------




end subroutine standalone_clouds_amt   



!#####################################################################

! <SUBROUTINE NAME="obtain_micro_lw_sa">
!  <OVERVIEW>
!    obtain_micro_lw_sa defines microphysically-based longwave cloud
!    radiative properties when the code is executed in standalone
!    columns mode.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_micro_lw_sa defines microphysically-based longwave cloud
!    radiative properties when the code is executed in standalone
!    columns mode.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_micro_lw_sa (is, ie, js, je, Lsc_microphys, &
!                Meso_microphys, Cell_microphys, &
!                Lscrad_props,  Mesorad_props, &
!                Cellrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
!      Lsc_microphys     microphysical specification for large-scale
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
! 
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
!      Meso_microphys    microphysical specification for meso-scale
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
! 
!  </INOUT>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
!      Cell_microphys    microphysical specification for cell-scale
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
! 
!  </INOUT>
!  <INOUT NAME="Lscrad_props" TYPE="microrad_properties_type">
!      Lscrad_props      cloud radiative properties on model grid,
!                        [ microrad_properties_type ]
! 
!  </INOUT>
!  <INOUT NAME="Mesorad_props" TYPE="microrad_properties_type">
!      Mesorad_props     meso-scale cloud radiative properties on
!                        model grid, [ microrad_properties_type ]
! 
!  </INOUT>
!  <INOUT NAME="Cellrad_props" TYPE="microrad_properties_type">
!      Cellrad_props     cell-scale cloud radiative properties on
!                        model grid, [ microrad_properties_type ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_micro_lw_sa (is, ie, js, je, Lsc_microphys, &
                               Meso_microphys, Cell_microphys, &
                               Lscrad_props,  Mesorad_props, &
                               Cellrad_props)

!---------------------------------------------------------------------
!    obtain_micro_lw_sa defines microphysically-based longwave cloud 
!    radiative properties when the code is executed in standalone 
!    columns mode.
!---------------------------------------------------------------------

integer,                        intent(in)    :: is, ie, js, je
type(microphysics_type),        intent(inout) :: Lsc_microphys, &
                                                 Meso_microphys, &
                                                 Cell_microphys
type(microrad_properties_type), intent(inout) :: Lscrad_props, &
                                                 Mesorad_props, &
                                                 Cellrad_props
 
!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Lsc_microphys     microphysical specification for large-scale 
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
!      Meso_microphys    microphysical specification for meso-scale 
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
!      Cell_microphys    microphysical specification for cell-scale 
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
!      Lscrad_props      cloud radiative properties on model grid,
!                        [ microrad_properties_type ]
!      Mesorad_props     meso-scale cloud radiative properties on 
!                        model grid, [ microrad_properties_type ]
!      Cellrad_props     cell-scale cloud radiative properties on 
!                        model grid, [ microrad_properties_type ]
!
!               the following component of the **_props variables is 
!               output from this routine:
!
!                    %abscoeff  absorption coefficient for  
!                               clouds in each of the longwave 
!                               frequency bands  [ km **(-1) ]
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------
!    call microphys_rad_driver2 to obtain the microphysically-based
!    sw cloud radiative quantities.
!---------------------------------------------------------------------
!     call microphys_rad_driver2 (is, ie, js, je, Lsc_microphys,   &
!     call microphys_lw_driver2 (is, ie, js, je, Lsc_microphys,   &
!                                 abscoeff=Lscrad_props%abscoeff)

!---------------------------------------------------------------------
!    if donner_deep is activated, process the cloud radiative properties
!    associated with the mesoscale and cellscale components of that
!    parameterization.
!---------------------------------------------------------------------
!     if (do_donner_deep_clouds) then
!     if (Cldrad_control%do_donner_deep_clouds) then
!        call obtain_micro_lw_donner_deep (is, ie, js, je,  &
!                                          Cell_microphys, & 
!                                          Meso_microphys,  &
!                                          Cellrad_props, Mesorad_props)
!     endif

!--------------------------------------------------------------------


end subroutine obtain_micro_lw_sa     




!#####################################################################

! <SUBROUTINE NAME="obtain_micro_sw_sa">
!  <OVERVIEW>
!    obtain_micro_sw_sa defines microphysically-based shortwave cloud
!    radiative properties for the standalone cloud scheme when run in
!    columns mode.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_micro_sw_sa defines microphysically-based shortwave cloud
!    radiative properties for the standalone cloud scheme when run in
!    columns mode.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_micro_sw_sa (is, ie, js, je, Lsc_microphys,   &
!                Meso_microphys, Cell_microphys,   &
!                Lscrad_props, Mesorad_props,   &
!                Cellrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Lsc_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
!  <INOUT NAME="Meso_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
!  <INOUT NAME="Cell_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
!  <INOUT NAME="Lscrad_props" TYPE="microrad_properties_type">
! 
!  </INOUT>
!  <INOUT NAME="Mesorad_props" TYPE="microrad_properties_type">
! 
!  </INOUT>
!  <INOUT NAME="Cellrad_props" TYPE="microrad_properties_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_micro_sw_sa (is, ie, js, je, Lsc_microphys,   &
                               Meso_microphys, Cell_microphys,   &
                               Lscrad_props, Mesorad_props,   &
                               Cellrad_props)

!--------------------------------------------------------------------
!    obtain_micro_sw_sa defines microphysically-based shortwave cloud 
!    radiative properties for the standalone cloud scheme when run in 
!    columns mode.
!---------------------------------------------------------------------

integer,                         intent(in)    ::  is, ie, js, je
type(microphysics_type),         intent(inout) ::  Lsc_microphys, &
                                                   Meso_microphys,   &
                                                   Cell_microphys
type(microrad_properties_type),  intent(inout) ::  Lscrad_props,   &
                                                   Mesorad_props,  &
                                                   Cellrad_props

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Lsc_microphys     microphysical specification for large-scale 
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
!      Meso_microphys    microphysical specification for meso-scale 
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
!      Cell_microphys    microphysical specification for cell-scale 
!                        clouds, provides input to this subroutine
!                        [ microphysics_type ]
!      Lscrad_props      large-scale cloud radiative properties on 
!                        model grid, [ microrad_properties_type ]
!      Mesorad_props     meso-scale cloud radiative properties on 
!                        model grid, [ microrad_properties_type ]
!      Cellrad_props     cell-scale cloud radiative properties on 
!                        model grid, [ microrad_properties_type ]
!
!               the following components of the microrad_properties
!               variables are output from this routine:
!
!                   %cldext    sw extinction coefficient for  
!                              clouds in each of the shortwave 
!                              frequency bands  [ km **(-1) ]
!                   %cldsct    sw scattering coefficient for
!                              clouds in each of the shortwave
!                              frequency bands  [ km **(-1) ]
!                   %cldasymm  sw asymmetry factor for
!                              clouds in each of the shortwave 
!                              frequency bands  [ dimensionless ]
!
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!    call microphys_rad_driver2 to obtain the microphysically-based
!    sw cloud radiative quantities.
!---------------------------------------------------------------------
!     call microphys_rad_driver2 (is, ie, js, je, Lsc_microphys, &
!     call microphys_sw_driver2 (is, ie, js, je, Lsc_microphys, &
!                                 cldext=Lscrad_props%cldext,   &
!                                 cldsct=Lscrad_props%cldsct,   &
!                                 cldasymm=Lscrad_props%cldasymm )

!---------------------------------------------------------------------
!    if donner_deep is activated, process the cloud radiative properties
!    associated with the mesoscale and cellscale components of that
!    parameterization.
!---------------------------------------------------------------------
!     if (do_donner_deep_clouds) then
!     if (CLdrad_control%do_donner_deep_clouds) then
!       call  obtain_micro_sw_donner_deep (is, ie, js, je,     &
!                                          Cell_microphys,&
!                                          Meso_microphys,     &
!                                          Cellrad_props, Mesorad_props)
!     endif

!--------------------------------------------------------------------



end subroutine obtain_micro_sw_sa     




!#####################################################################

! <SUBROUTINE NAME="obtain_bulk_lw_sa">
!  <OVERVIEW>
!    obtain_bulk_lw_sa defines bulk longwave cloud radiative properties
!    when using specified clouds in the standalone columns mode.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_lw_sa defines bulk longwave cloud radiative properties
!    when using specified clouds in the standalone columns mode.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_lw_sa (is, ie, js, je, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!      is,ie,js,je  starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for
!                               maximally overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_lw_sa (is, ie, js, je, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_lw_sa defines bulk longwave cloud radiative properties 
!    when using specified clouds in the standalone columns mode.
!---------------------------------------------------------------------
 
integer,                      intent(in)    :: is, ie, js, je
type(cldrad_properties_type), intent(inout) :: Cldrad_props
 
!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      integer       :: i, j     ! do-loop indices

!--------------------------------------------------------------------
!    define the lw bulk cloud radiative properties from the values
!    previously defined in this module.
!--------------------------------------------------------------------
      do j=1,size(Cldrad_props%emrndlw,2)
        do i=1,cloud_data_points
          Cldrad_props%emmxolw(i,j,:,:,1) = emlw_band_in(i,:,:)
          Cldrad_props%emrndlw(i,j,:,:,1) = emlw_band_in(i,:,:)
        end do
      end do

!--------------------------------------------------------------------


end subroutine obtain_bulk_lw_sa     


!#####################################################################

! <SUBROUTINE NAME="obtain_bulk_sw_sa">
!  <OVERVIEW>
!    obtain_bulk_sw_sa defines bulk shortwave cloud radiative
!    properties for the specified cloud scheme when running in
!    standalone columns mode.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    obtain_bulk_sw_sa defines bulk shortwave cloud radiative
!    properties for the specified cloud scheme when running in
!    standalone columns mode.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_sw_sa (is, ie, js, je, Cldrad_props)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Cldrad_props" TYPE="cldrad_properties_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_sw_sa (is, ie, js, je, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_sw_sa defines bulk shortwave cloud radiative 
!    properties for the specified cloud scheme when running in 
!    standalone columns mode.
!---------------------------------------------------------------------

integer,                      intent(in)    ::   is, ie, js, je
type(cldrad_properties_type), intent(inout) ::   Cldrad_props

!---------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables

      integer       :: i, j    ! do-loop indices

!--------------------------------------------------------------------
!    define the sw bulk cloud radiative properties from the values
!    previously defined in this module.
!--------------------------------------------------------------------
      do j=1,size(Cldrad_props%cirabsw,2)
        do i=1,cloud_data_points
          Cldrad_props%cirabsw(i,j,:) = cir_abs_in(i,:)
          Cldrad_props%cirrfsw(i,j,:) = cir_rf_in(i,:)
          Cldrad_props%cvisrfsw(i,j,:) = cvis_rf_in(i,:)
        end do
      end do

!--------------------------------------------------------------------


end subroutine obtain_bulk_sw_sa     




!###################################################################

!subroutine find_nearest_index (latb, jindx2)

!real, dimension(:), intent(in) :: latb
!integer, dimension(:), intent(out)  :: jindx2
 

!      integer :: jd, j, jj
!     real   :: diff_low, diff_high
!      real, dimension(size(latb,1)-1) :: lat

 
!      jd = size(latb,1) - 1

!      do j = 1,jd
!        lat(j) = 0.5*(latb(j) + latb(j+1))
!      do jj=1, LATOBS
!        if (lat(j)*radians_to_degrees >= cloud_lats(jj)) then
!         diff_low = lat(j)*radians_to_degrees - cloud_lats(jj)
!          diff_high = cloud_lats(jj+1) - lat(j)*radians_to_degrees
!          if (diff_high <= diff_low) then
!            jindx2(j) = jj+1
!          else
!            jindx2(j) = jj
!          endif
!        endif
!      end do
!   end do






!end subroutine find_nearest_index

!#####################################################################




       end module standalone_clouds_mod




 


                 module strat_clouds_W_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stephen.Klein@noaa.gov">
!  sak
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    strat_clouds_W_mod obtains the cloud specification variables
!    for the klein strat cloud parameterization from cloud_rad_mod
!    and makes them available to the radiation package.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!   shared modules:

use constants_mod,          only: radian
use time_manager_mod,       only: time_type, time_manager_init
use mpp_mod,                only: input_nml_file
use fms_mod,                only: open_namelist_file, mpp_pe, &
                                  mpp_root_pe, stdlog,  fms_init, &
                                  write_version_number, file_exist, &
                                  check_nml_error, error_mesg,   &
                                  FATAL, close_file

!   shared radiation package modules:

use rad_utilities_mod,      only: rad_utilities_init, &
                                  cldrad_properties_type,  &
                                  cld_specification_type, &
                                  solar_spectrum_type, &
                                  microphysics_type, Cldrad_control
use esfsw_parameters_mod,   only: Solar_spect, esfsw_parameters_init

!   cloud parameterization module:

use cloud_rad_mod,          only: cloud_rad_init, cloud_summary3, &
                                  lw_emissivity, sw_optical_properties

!    stochastic cloud generator module
use random_numbers_mod,     only: randomNumberStream,           &
                                  initializeRandomNumberStream, &
                                  constructSeed
use cloud_generator_mod,    only: cloud_generator_init, &
                                  generate_stochastic_clouds,&
                                  cloud_generator_end
!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    strat_clouds_W_mod obtains the cloud specification variables
!    for the klein strat cloud parameterization from cloud_rad_mod
!    and makes them available to the radiation package.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: strat_clouds_W.F90,v 17.0.8.1.2.1.2.1 2010/08/30 20:33:33 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          strat_clouds_W_init, strat_clouds_amt, obtain_bulk_lw_strat, &
          obtain_bulk_sw_strat, strat_clouds_W_end

!---------------------------------------------------------------------
!-------- namelist  ---------

logical   :: do_stochastic_clouds = .false.
integer   :: seedperm = 0
logical   :: one_generator_call = .false.


namelist /strat_clouds_W_nml /                      &
                                do_stochastic_clouds, seedperm, &
                                one_generator_call


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------


logical                               :: module_is_initialized = .false.  ! module is initialized ?
real,    dimension(:,:),    allocatable :: lats, lons  ! lats and lons in this processor window (degrees)
!----------------------------------------------------------------------
!----------------------------------------------------------------------



                              contains 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="strat_clouds_W_init">
!  <OVERVIEW>
!    strat_clouds_W_init is the constructor for strat_clouds_W_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    strat_clouds_W_init is the constructor for strat_clouds_W_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call strat_clouds_W_init
!  </TEMPLATE>
! </SUBROUTINE>
!  
subroutine strat_clouds_W_init(latb, lonb)
  real, dimension(:,:), intent( in) :: latb, lonb
!---------------------------------------------------------------------
!    strat_clouds_W_init is the constructor for strat_clouds_W_mod.
!---------------------------------------------------------------------
!       lonb      2d array of model longitudes on cell corners [ radians ]
!       latb      2d array of model latitudes at cell corners [radians]


!----------------------------------------------------------------------
!   local variables:

      integer   ::   unit, ierr, io, logunit

!--------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      ierr     error code
!      io       error status returned from io operation  
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    Save copies of lat and lon values for this window
!---------------------------------------------------------------------
      allocate(lats(size(latb,1),size(latb,2)), lons(size(lonb,1),size(lonb,2)))
      lats(:,:) = latb(:,:) * radian
      lons(:,:) = lonb(:,:) * radian
!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call rad_utilities_init
      call esfsw_parameters_init
      call cloud_rad_init

!---------------------------------------------------------------------
!    read namelist.         
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=strat_clouds_W_nml, iostat=io)
   ierr = check_nml_error(io,'strat_clouds_W_nml')
#else   
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read (unit, nml=strat_clouds_W_nml, iostat=io, end=10) 
        ierr = check_nml_error (io, 'strat_clouds_W_nml')
        enddo                       
10      call close_file (unit)      
      endif                         
#endif
                                    
!----------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                 write (logunit, nml=strat_clouds_W_nml)

!--------------------------------------------------------------------
!    save the flags indicating whether stochastic clouds are to be
!    used.
!--------------------------------------------------------------------
      Cldrad_control%do_stochastic_clouds = do_stochastic_clouds
      Cldrad_control%do_stochastic_clouds_iz = .true.
      if (do_stochastic_clouds) &
                 call cloud_generator_init

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!----------------------------------------------------------------------

end subroutine strat_clouds_W_init



!######################################################################
! <SUBROUTINE NAME="strat_clouds_amt">
!  <OVERVIEW>
!    strat_clouds_amt defines the location, amount (cloud fraction), 
!    and number of clouds present on the model grid, in addition to
!    liquid and ice-water paths, cloud thickness, and effective drop 
!    and crystal sizes. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    strat_clouds_amt defines the location, amount (cloud fraction), 
!    and number of clouds present on the model grid, in addition to
!    liquid and ice-water paths, cloud thickness, and effective drop 
!    and crystal sizes. if a microphysically-based cloud parameter-
!    ization is being used, particle sizes and concentrations are also
!    provided.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call strat_clouds_amt (is, ie, js, je, Rad_time, pflux, press, 
!                          temp, qv, land, Cld_spec, Lsc_microphys)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Rad_time" TYPE="time_type">
!   time at which radiation calculation is to apply
!  </IN>
!  <IN NAME="pflux" TYPE="real">
!   pressure values at flux levels (average of pressure values at
!   model grid points
!  </IN>
!  <IN NAME="press" TYPE="real">
!   pressure values at model grid points. surface 
!                   pressure is stored at index value nlev+1
!  </IN>
!  <IN NAME="temp" TYPE="real">
!    temperature at model levels (1:nlev), to be used
!                   in cloud calculations
!  </IN>
!  <IN NAME="qv" TYPE="real">
!    water vapor specific humidity at model levels (1:nlev), to be used
!                   in cloud calculations
!  </IN>
!  <IN NAME="land" TYPE="real">
!   fraction of grid box covered by land
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphys_type">
!   microphysics_type variable containing the size,
!                   concentration and fraction of the four condensate 
!                   types (cloud drop, cloud ice, rain, snow) in the 
!                   grid box, present when microphysically-based
!                   cloud radiation properties are desired.
!  </INOUT>
! </SUBROUTINE>
!
subroutine strat_clouds_amt (is, ie, js, je, Rad_time, pflux, &
                             press, temp, qv, &
                             land, Cld_spec, Lsc_microphys)

!---------------------------------------------------------------------
!    strat_clouds_amt defines the location, amount (cloud fraction), 
!    and number of clouds present on the model grid, in addition to
!    liquid and ice-water paths, cloud thickness, and effective drop 
!    and crystal sizes. if a microphysically-based cloud parameter-
!    ization is being used, particle sizes and concentrations are also
!    provided.
!----------------------------------------------------------------------

integer,                      intent(in)        :: is, ie, js, je
type(time_type),              intent(in)        :: Rad_time
real,    dimension(:,:,:),    intent(in)        :: pflux, press, temp, qv
real,    dimension(:,:),      intent(in)        :: land
type(cld_specification_type), intent(inout)     :: Cld_spec      
type(microphysics_type),      intent(inout)     :: Lsc_microphys

!----------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Rad_time     time type variable containing radiation time
!      pflux        average of pressure at adjacent model levels
!                   [ (kg /( m s^2) ] 
!      press        pressure at model levels (1:nlev), surface 
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
!      temp         temperature at model levels (1:nlev), to be used
!                   in cloud calculations
!                   [ deg K ]
!      qv           water vapor specific humidity at model levels
!                   (1:nlev), to be used in cloud calculations
!      land         fraction of grid box covered by land
!                   [ non-dimensional ]
!
!   intent(inout), optional variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by the shortwave
!                           radiation in each grid column.
!                  %cloud_thickness
!                           number of model layers over which the cloud
!                           in this grid box extends
!                  %lwp     liquid water path 
!                           [ kg / m^2 ]
!                  %iwp     ice water path
!                           [ kg / m^2 ]
!                  %reff_liq
!                           effective drop radius [ microns ]
!                  %reff_ice
!                           effective ice particle size [ microns ]
!
!      Lsc_microphys
!                   microphysics_type variable containing the size,
!                   concentration and fraction of the four condensate 
!                   types (cloud drop, cloud ice, rain, snow) in the 
!                   grid box, present when microphysically-based
!                   cloud radiation properties are desired.
!
!               the following components of this variable are output 
!               from this routine when microphysically-based properties
!               are desired:
!
!                  %conc_ice  ice particle concentration [ g /m^3 ]
!                  %conc_drop cloud droplet concentration [ g /m^3 ]
!                  %size_ice  ice particle effective diameter 
!                  [ microns ]
!                  %size_drop cloud droplet effective diameter
!                  [ microns ]
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    local variables

      real, dimension (size(pflux,1), size(pflux,2),  &
                       size(pflux,3)-1) ::      cldamt

      real, dimension (size(pflux,1), size(pflux,2),  &
                       size(pflux,3)-1, Cldrad_control%nlwcldb) :: &
                         ql_stoch_lw2, qi_stoch_lw2, qa_stoch_lw2, &
                         qn_stoch_lw2

      real, dimension (size(pflux,1), size(pflux,2),  &
                       size(pflux,3)-1, Solar_spect%nbands) :: &
                         ql_stoch_sw2, qi_stoch_sw2, qa_stoch_sw2, &
                         qn_stoch_sw2
      real, dimension (size(pflux,1), size(pflux,2),                 &
                       size(pflux,3)-1,                              &
                       Cldrad_control%nlwcldb + Solar_spect%nbands), &
             target :: ql_stoch, qi_stoch, qa_stoch, qn_stoch
 
      real, dimension(:, :, :, :), pointer :: &
                  ql_stoch_lw, qi_stoch_lw, qa_stoch_lw,qn_stoch_lw, &
                  ql_stoch_sw, qi_stoch_sw, qa_stoch_sw, qn_stoch_sw
      
!      integer, dimension(size(Cld_spec%cld_thickness_lw_band, 1), &
!                         size(Cld_spec%cld_thickness_lw_band, 2), &
!                         size(Cld_spec%cld_thickness_lw_band, 3), &
      integer, dimension(size(temp, 1), size(temp, 2), size(temp, 3), &
          Cldrad_control%nlwcldb + Solar_spect%nbands) ::         &
                        cld_thickness

      integer, dimension (size(pflux,1), size(pflux,2), &
                          size(pflux,3)-1) ::   ktop, kbtm

      integer, dimension (size(pflux,1), size(pflux,2)) :: &
                                                 ncldlvls

      type(randomNumberStream), &
                dimension(size(pflux,1), size(pflux,2)) :: streams
      integer     ::    kx 
      integer     ::    i, j, k, kc, nb
      real        ::   seedwts(8) = (/3000.,1000.,300.,100.,30.,10.,3.,1./)

!-------------------------------------------------------------------
!    local variables:
!
!       cldamt          cloud fraction, in cloud-space when microphysics
!                       not being used, in model-space when microphysics
!                       is active 
!                       [ dimensionless ]
!       lwp             cloud liquid water path in cloud-space 
!                       [ kg condensate / m^2 ]
!       iwp             cloud ice path, in cloud-space 
!                       [ kg condensate / m^2 ]
!       reff_liq        effective radius for liquid clouds, 
!                       in cloud-space [ microns ]
!       reff_ice        effective particle size for ice clouds 
!                       in cloud-space [ microns ]
!       ktop            index of the model level which is cloud top
!       kbtm            index of the model level which is cloud base
!       ncldlvls        number of layers with cloud in a column
!       kx              number of model layers
!       i,j,k,kc        do-loop indices  
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('strat_clouds_W_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    define the number of model layers.
!---------------------------------------------------------------------
      kx = size (press,3) - 1

!----------------------------------------------------------------------
!    compute the cloud specification properties under the assumption
!    of random cloud overlap.
!----------------------------------------------------------------------
      if (Cldrad_control%do_random_overlap) then

!----------------------------------------------------------------------
!    if microphysically-based radiative properties are needed, call
!    cloud_summary3 with the Lsc_microphys% optional arguments.
!----------------------------------------------------------------------
        if (Cldrad_control%do_pred_cld_microphys .or. &
            Cldrad_control%do_presc_cld_microphys) then

!--------------------------------------------------------------------
!    call cloud_summary3 with the full cloud field, regardless of 
!    whether or not stochastic clouds are active.
!    the full cloud field is assumed random overlap when stochastic
!    clouds are activated.
!--------------------------------------------------------------------
            where (Cld_spec%cloud_area(:,:,:) > 0.0) 
              Cld_spec%cld_thickness(:,:,:) = 1
            end where
          call cloud_summary3 (is, js, land,   &
                               Cldrad_control%using_fu2007, &
                               Cld_spec%cloud_water, &
                               Cld_spec%cloud_ice, Cld_spec%cloud_area,&
                               Cld_spec%cloud_droplet, &       
                               press(:,:,1:kx), pflux, temp, ncldlvls, &
                               cldamt, Cld_spec%lwp, Cld_spec%iwp,   &
                               Cld_spec%reff_liq, Cld_spec%reff_ice, &
                               conc_drop= Lsc_microphys%conc_drop, &
                               conc_ice = Lsc_microphys%conc_ice, &
                               size_drop =Lsc_microphys%size_drop,   &
                               size_ice = Lsc_microphys%size_ice, &
                         droplet_number = Lsc_microphys%droplet_number)
           cldamt = MIN (cldamt, 1.0)
          if (.not. Cldrad_control%do_specified_strat_clouds) then
            Cld_spec%ncldsw        = ncldlvls
            Cld_spec%nrndlw        = ncldlvls         
            Cld_spec%camtsw        = cldamt           
            Cld_spec%crndlw        = cldamt
            Lsc_microphys%cldamt   = cldamt            
          endif

!---------------------------------------------------------------------
!    if using stochastic clouds for either sw or lw, Initialize the random number streams, 
!       one per grid cell, with unique and replicable integer based 
!       on grid location and model date/time
!---------------------------------------------------------------------
          if (do_stochastic_clouds) then
            if (Cldrad_control%use_temp_for_seed) then
              do j = 1, size(Cld_spec%cloud_water, 2)
                do i = 1, size(Cld_spec%cloud_water, 1)
                  streams(i, j) =   &
                           initializeRandomNumberStream(  &
                               ishftc(nint(temp(i,j,1)*seedwts),seedperm))

                end do
              end do
            else
              do j = 1, size(Cld_spec%cloud_water, 2)
                do i = 1, size(Cld_spec%cloud_water, 1)
                  streams(i, j) =   &
                     initializeRandomNumberStream(  &
                        constructSeed(nint(lons(is + i - 1, js + j - 1)), &
                                      nint(lats(is + i - 1, js + j - 1)), &
                                                      Rad_time, seedperm))
                end do
              end do
            endif

            if (one_generator_call) then
!---------------------------------------------------------------------
!    then generate all the subcolumns at once and divide them into 
!    those needed  for the sw and lw bands.
!    call routine to obtain  band-dependent values of ql, qi and qa. 
!---------------------------------------------------------------------
              call generate_stochastic_clouds (        &
                      streams,                &
                      Cld_spec%cloud_water,   &
                      Cld_spec%cloud_ice,     &
                      Cld_spec%cloud_area,    &
                      Cld_spec%cloud_droplet, &
                      pFull = press(:, :, :kx),&
                      pHalf = pflux, &
                      temperature = temp(:, :, :kx),        &
                      qv= qv(:, :, :kx), &
                      cld_thickness = cld_thickness, &
                      ql_stoch = ql_stoch, &
                      qi_stoch = qi_stoch, &
                      qa_stoch = qa_stoch, &
                      qn_stoch = qn_stoch )

          ql_stoch_lw => ql_stoch(:, :, :, 1:Cldrad_control%nlwcldb)
          qi_stoch_lw => qi_stoch(:, :, :, 1:Cldrad_control%nlwcldb)
          qa_stoch_lw => qa_stoch(:, :, :, 1:Cldrad_control%nlwcldb)
          qn_stoch_lw => qn_stoch(:, :, :, 1:Cldrad_control%nlwcldb)
          Cld_spec%cld_thickness_lw_band = &
                       cld_thickness(:, :, :, 1:Cldrad_control%nlwcldb)

          ql_stoch_sw => ql_stoch(:, :, :, Cldrad_control%nlwcldb +1:)
          qi_stoch_sw => qi_stoch(:, :, :, Cldrad_control%nlwcldb +1:)
          qa_stoch_sw => qa_stoch(:, :, :, Cldrad_control%nlwcldb +1:)
          qn_stoch_sw => qn_stoch(:, :, :, Cldrad_control%nlwcldb +1:)
          Cld_spec%cld_thickness_sw_band = &
                     cld_thickness(:, :, :, Cldrad_control%nlwcldb +1:)

!---------------------------------------------------------------------
!    call cloud_summary3 for each lw band, using the band-dependent
!    cloud inputs, to obtain band-dependent values of liquid and ice
!    size and concentration.
!---------------------------------------------------------------------
            do nb=1,Cldrad_control%nlwcldb
              call cloud_summary3 (          &
                is, js, land, &
                Cldrad_control%using_fu2007, &
                ql_stoch_lw(:,:,:,nb),&
                qi_stoch_lw(:,:,:,nb), qa_stoch_lw(:,:,:,nb),&
                qn_stoch_lw(:,:,:,nb), &
                press(:,:,1:kx), pflux, temp, ncldlvls, &
                cldamt, Cld_spec%lwp_lw_band(:,:,:,nb),&
                Cld_spec%iwp_lw_band(:,:,:,nb),   &
                Cld_spec%reff_liq_lw_band(:,:,:,nb), &
                Cld_spec%reff_ice_lw_band(:,:,:,nb), &
                conc_drop= Lsc_microphys%lw_stoch_conc_drop(:,:,:,nb), &
                conc_ice = Lsc_microphys%lw_stoch_conc_ice(:,:,:,nb), &
                size_drop =Lsc_microphys%lw_stoch_size_drop(:,:,:,nb), &
                size_ice = Lsc_microphys%lw_stoch_size_ice(:,:,:,nb), &
       droplet_number = Lsc_microphys%lw_stoch_droplet_number(:,:,:,nb))
              
              !now that the vertical cloud fraction has been used to
              !properly calculate the in-cloud particle size, rescale
              !the concentrations and cloud amounts to that the cloud
              !amount is unity in any partially cloudy sub-column. 
              !
              !This is necessary so that the radiation code will not
              !do cloud fraction weights of cloudy and clear sky fluxes.
              !
              !The rescaling of the concentrations is necessary so that the
              !total optical depth of the layer is constant.  Note that this
              !works because cloud extinction is linear in the concentration
              Lsc_microphys%lw_stoch_conc_drop(:,:,:,nb) = &
                   Lsc_microphys%lw_stoch_conc_drop(:,:,:,nb) * cldamt(:,:,:)     
              Lsc_microphys%lw_stoch_conc_ice(:,:,:,nb) = &
                   Lsc_microphys%lw_stoch_conc_ice(:,:,:,nb) * cldamt(:,:,:)
              where (cldamt .gt. 0.) cldamt = 1.                  
               
              if (.not. Cldrad_control%do_specified_strat_clouds) then
                Cld_spec%nrndlw_band(:,:,nb) = ncldlvls(:,:)
                Lsc_microphys%lw_stoch_cldamt(:,:,:,nb) = cldamt
              endif
            end do

!---------------------------------------------------------------------
!    call cloud_summary3 for each sw band, using the band-dependent
!    cloud inputs, to obtain band-dependent values of liquid and ice
!    size and concentration.
!---------------------------------------------------------------------
          do nb=1,size(Lsc_microphys%sw_stoch_conc_ice,4)
            call cloud_summary3 (                            &
              is, js, land,  &
              Cldrad_control%using_fu2007, &
              ql_stoch_sw(:,:,:,nb), &
              qi_stoch_sw(:,:,:,nb), qa_stoch_sw(:,:,:,nb),&
              qn_stoch_sw(:,:,:,nb), &
              press(:,:,1:kx), pflux, temp, ncldlvls, &
              cldamt, Cld_spec%lwp_sw_band(:,:,:,nb), &
              Cld_spec%iwp_sw_band(:,:,:,nb),   &
              Cld_spec%reff_liq_sw_band(:,:,:,nb), &
              Cld_spec%reff_ice_sw_band(:,:,:,nb), &
              conc_drop= Lsc_microphys%sw_stoch_conc_drop(:,:,:,nb), &
              conc_ice = Lsc_microphys%sw_stoch_conc_ice(:,:,:,nb), &
              size_drop =Lsc_microphys%sw_stoch_size_drop(:,:,:,nb), &
              size_ice = Lsc_microphys%sw_stoch_size_ice(:,:,:,nb), &
       droplet_number = Lsc_microphys%sw_stoch_droplet_number(:,:,:,nb))

         !now that the vertical cloud fraction has been used to
         !properly calculate the in-cloud particle size, rescale
         !the concentrations and cloud amounts to that the cloud
         !amount is unity in any partially cloudy sub-column. 
         !
         !This is necessary so that the radiation code will not
         !do cloud fraction weights of cloudy and clear sky fluxes.
         !
         !The rescaling of the concentrations is necessary so that         the
         !total optical depth of the layer is constant.  Note that         this
         !works because cloud extinction is linear in the concentra        tion
            Lsc_microphys%sw_stoch_conc_drop(:,:,:,nb) = &
             Lsc_microphys%sw_stoch_conc_drop(:,:,:,nb) * cldamt(:,:,:)
            Lsc_microphys%sw_stoch_conc_ice(:,:,:,nb) = &
             Lsc_microphys%sw_stoch_conc_ice(:,:,:,nb) * cldamt(:,:,:)
             where (cldamt .gt. 0.) cldamt = 1.

             if (.not. Cldrad_control%do_specified_strat_clouds) then
               Cld_spec%ncldsw_band(:,:,nb) = ncldlvls(:,:)
               Lsc_microphys%sw_stoch_cldamt(:,:,:,nb) = cldamt
             endif
           end do
 
        else  ! (one_call)
!---------------------------------------------------------------------
!    call routine to obtain lw band-dependent values of ql, qi and qa. 
!---------------------------------------------------------------------
            call generate_stochastic_clouds (        &
                     streams,                &
                     Cld_spec%cloud_water,   &
                     Cld_spec%cloud_ice,     &
                     Cld_spec%cloud_area,    &
                     Cld_spec%cloud_droplet, &
                     pFull    = press(:, :, :kx),     &
                     pHalf    = pflux,&
                     temperature = temp(:, :, :kx),   &
                     qv = qv(:,:, :kx),   &
                     cld_thickness = Cld_spec%cld_thickness_lw_band, &
                     ql_stoch = ql_stoch_lw2, &
                     qi_stoch = qi_stoch_lw2, &
                     qa_stoch = qa_stoch_lw2, &
                     qn_stoch = qn_stoch_lw2 )

!---------------------------------------------------------------------
!    call routine to obtain sw band-dependent values of ql, qi and qa. 
!---------------------------------------------------------------------
            call generate_stochastic_clouds (        &
                     streams,                &
                     Cld_spec%cloud_water,   &
                     Cld_spec%cloud_ice,     &
                     Cld_spec%cloud_area,    &
                     Cld_spec%cloud_droplet, &
                     pFull    = press(:, :, :kx),     &
                     pHalf    = pflux,&
                     temperature = temp(:, :, :kx),   &
                     qv = qv(:,:, :kx),   &
                     cld_thickness = Cld_spec%cld_thickness_sw_band, &
                     ql_stoch = ql_stoch_sw2, &
                     qi_stoch = qi_stoch_sw2, &
                     qa_stoch = qa_stoch_sw2, &
                     qn_stoch = qn_stoch_sw2 )

!---------------------------------------------------------------------
!    call cloud_summary3 for each lw band, using the band-dependent
!    cloud inputs, to obtain band-dependent values of liquid and ice
!    size and concentration.
!---------------------------------------------------------------------
            do nb=1,Cldrad_control%nlwcldb
              call cloud_summary3 (          &
                is, js, land,  &
                Cldrad_control%using_fu2007, &
                ql_stoch_lw2(:,:,:,nb),&
                qi_stoch_lw2(:,:,:,nb), qa_stoch_lw2(:,:,:,nb),&
                qn_stoch_lw2(:,:,:,nb), &
                press(:,:,1:kx), pflux, temp, ncldlvls, &
                cldamt, Cld_spec%lwp_lw_band(:,:,:,nb),&
                Cld_spec%iwp_lw_band(:,:,:,nb),   &
                Cld_spec%reff_liq_lw_band(:,:,:,nb), &
                Cld_spec%reff_ice_lw_band(:,:,:,nb), &
                conc_drop= Lsc_microphys%lw_stoch_conc_drop(:,:,:,nb), &
                conc_ice = Lsc_microphys%lw_stoch_conc_ice(:,:,:,nb), &
                size_drop =Lsc_microphys%lw_stoch_size_drop(:,:,:,nb), &
                size_ice = Lsc_microphys%lw_stoch_size_ice(:,:,:,nb), &
       droplet_number = Lsc_microphys%lw_stoch_droplet_number(:,:,:,nb))
              
              !now that the vertical cloud fraction has been used to
              !properly calculate the in-cloud particle size, rescale
              !the concentrations and cloud amounts to that the cloud
              !amount is unity in any partially cloudy sub-column. 
              !
              !This is necessary so that the radiation code will not
              !do cloud fraction weights of cloudy and clear sky fluxes.
              !
              !The rescaling of the concentrations is necessary so that the
              !total optical depth of the layer is constant.  Note that this
              !works because cloud extinction is linear in the concentration
              Lsc_microphys%lw_stoch_conc_drop(:,:,:,nb) = &
                   Lsc_microphys%lw_stoch_conc_drop(:,:,:,nb) * cldamt(:,:,:)     
              Lsc_microphys%lw_stoch_conc_ice(:,:,:,nb) = &
                   Lsc_microphys%lw_stoch_conc_ice(:,:,:,nb) * cldamt(:,:,:)
              where (cldamt .gt. 0.) cldamt = 1.                  
               
              if (.not. Cldrad_control%do_specified_strat_clouds) then
                Cld_spec%nrndlw_band(:,:,nb) = ncldlvls(:,:)
                Lsc_microphys%lw_stoch_cldamt(:,:,:,nb) = cldamt
              endif
            end do

!---------------------------------------------------------------------
!    call cloud_summary3 for each sw band, using the band-dependent
!    cloud inputs, to obtain band-dependent values of liquid and ice
!    size and concentration.
!---------------------------------------------------------------------
            do nb=1,size(Lsc_microphys%sw_stoch_conc_ice,4)
              call cloud_summary3 (                            &
                is, js, land, &
                Cldrad_control%using_fu2007, &
                ql_stoch_sw2(:,:,:,nb), &
                qi_stoch_sw2(:,:,:,nb), qa_stoch_sw2(:,:,:,nb),&
                qn_stoch_sw2(:,:,:,nb), &
                press(:,:,1:kx), pflux, temp, ncldlvls, &
                cldamt, Cld_spec%lwp_sw_band(:,:,:,nb), &
                Cld_spec%iwp_sw_band(:,:,:,nb),   &
                Cld_spec%reff_liq_sw_band(:,:,:,nb), &
                Cld_spec%reff_ice_sw_band(:,:,:,nb), &
                conc_drop= Lsc_microphys%sw_stoch_conc_drop(:,:,:,nb), &
                conc_ice = Lsc_microphys%sw_stoch_conc_ice(:,:,:,nb), &
                size_drop =Lsc_microphys%sw_stoch_size_drop(:,:,:,nb), &
                size_ice = Lsc_microphys%sw_stoch_size_ice(:,:,:,nb), &
       droplet_number = Lsc_microphys%sw_stoch_droplet_number(:,:,:,nb))
              
              !now that the vertical cloud fraction has been used to
              !properly calculate the in-cloud particle size, rescale
              !the concentrations and cloud amounts to that the cloud
              !amount is unity in any partially cloudy sub-column. 
              !
              !This is necessary so that the radiation code will not
              !do cloud fraction weights of cloudy and clear sky fluxes.
              !
              !The rescaling of the concentrations is necessary so that the
              !total optical depth of the layer is constant.  Note that this
              !works because cloud extinction is linear in the concentration
              Lsc_microphys%sw_stoch_conc_drop(:,:,:,nb) = &
                   Lsc_microphys%sw_stoch_conc_drop(:,:,:,nb) * cldamt(:,:,:)     
              Lsc_microphys%sw_stoch_conc_ice(:,:,:,nb) = &
                   Lsc_microphys%sw_stoch_conc_ice(:,:,:,nb) * cldamt(:,:,:)
              where (cldamt .gt. 0.) cldamt = 1.                  
               
              if (.not. Cldrad_control%do_specified_strat_clouds) then
                Cld_spec%ncldsw_band(:,:,nb) = ncldlvls(:,:)
                Lsc_microphys%sw_stoch_cldamt(:,:,:,nb) = cldamt
              endif
            end do
         endif ! (one_generator_call)
       endif  ! (do_stochastic_clouds)

!---------------------------------------------------------------------
!    if microphysically-based radiative properties are not needed, call
!    cloud_summary3 without the Lsc_microphys% optional arguments.
!----------------------------------------------------------------------
        else  ! (not micro)

!--------------------------------------------------------------------
!    define the cloud thickness to be 1 at those points with cloud
!    present.
!---------------------------------------------------------------------
          where (Cld_spec%cloud_area(:,:,:) > 0.0) 
            Cld_spec%cld_thickness(:,:,:) = 1
          end where
          call cloud_summary3 (is, js, land,  &
                               Cldrad_control%using_fu2007, &      
                               Cld_spec%cloud_water, &
                               Cld_spec%cloud_ice, Cld_spec%cloud_area,&
                               Cld_spec%cloud_droplet, &
                               press(:,:,1:kx), pflux, temp, ncldlvls, &
                               cldamt, Cld_spec%lwp,   &
                               Cld_spec%iwp, Cld_spec%reff_liq,   &
                               Cld_spec%reff_ice)
             cldamt = MIN (cldamt, 1.0)
          if (.not. Cldrad_control%do_specified_strat_clouds) then
            Cld_spec%ncldsw        = ncldlvls
            Cld_spec%nrndlw        = ncldlvls         
            Cld_spec%camtsw        = cldamt           
            Cld_spec%crndlw        = cldamt
            Lsc_microphys%cldamt   = cldamt            
          endif
        endif

!----------------------------------------------------------------------
!    in gcm or sa_gcm mode, all clouds are assumed to be randomly 
!    overlapped. in columns mode, no change is made to the specified 
!    input characteristics.
!----------------------------------------------------------------------
        if (.not. Cldrad_control%do_specified_strat_clouds) then
          Cld_spec%nmxolw        = 0 
          Cld_spec%cmxolw        = 0.0E+00
        endif

!---------------------------------------------------------------------
!    define cloud specification properties when max-random overlap is
!    assumed. in this case cloud in adjacent layers is assumed to be
!    part of the same cloud.
!---------------------------------------------------------------------
      else if (Cldrad_control%do_max_random_overlap) then  

!----------------------------------------------------------------------
!    microphysically-based radiative properties are not implemented
!    with the max-random overlap assumption.
!----------------------------------------------------------------------
        if (Cldrad_control%do_pred_cld_microphys .or. &
            Cldrad_control%do_presc_cld_microphys) then
          call error_mesg ('strat_clouds_W_mod', &
               'must use random overlap cloud assumption with strat '//&
              'clouds when microphysics are desired', FATAL)

!---------------------------------------------------------------------
!    if microphysically-based radiative properties are not needed, call
!    cloud_summary3 without the Lsc_microphys% optional arguments.
!----------------------------------------------------------------------
        else
          call cloud_summary3 (is, js, land,  &
                               Cldrad_control%using_fu2007, &    
                               Cld_spec%cloud_water, &
                               Cld_spec%cloud_ice, Cld_spec%cloud_area,&
                               Cld_spec%cloud_droplet, &
                               press(:,:,1:kx), pflux, temp, ncldlvls, &
                               Cld_spec%camtsw, Cld_spec%lwp,   &
                               Cld_spec%iwp, Cld_spec%reff_liq,   &
                               Cld_spec%reff_ice,  &
                               ktop=ktop, kbot=kbtm)

!---------------------------------------------------------------------
!    when only bulk properties are returned, they are in cloud space,
!    and must be converted to physical space before being stored in 
!    Cld_spec. random overlap and max overlap properties are assigned 
!    according to the cloud thickness - multi layer clouds are assumed 
!    to be max overlap.
!-------------------------------------------------------------------
          do j=1, size(press,2)
            do i=1, size(press,1)
              Cld_spec%ncldsw(i,j) = ncldlvls(i,j)
              do kc=1, Cld_spec%ncldsw(i,j)         
                do k=ktop(i,j,kc), kbtm(i,j,kc)
                  if (ktop(i,j,kc) == kbtm(i,j,kc)) then
                    Cld_spec%crndlw(i,j,k) = Cld_spec%camtsw(i,j,k)
                    Cld_spec%cmxolw(i,j,k) = 0.0             
                    Cld_spec%cld_thickness(i,j,k) = 1
                  else
                    Cld_spec%cmxolw(i,j,k) = Cld_spec%camtsw(i,j,k)
                    Cld_spec%crndlw(i,j,k) = 0.0
                    Cld_spec%cld_thickness(i,j,k) = kbtm(i,j,kc) -    &
                                                    ktop(i,j,kc) + 1
                  endif
                end do
                if (ktop(i,j,kc) == kbtm(i,j,kc)) then
                  Cld_spec%nrndlw(i,j) = Cld_spec%nrndlw(i,j) + 1
                else
                  Cld_spec%nmxolw(i,j) = Cld_spec%nmxolw(i,j) + 1
                endif
              end do
            end do
          end do
        endif ! (do_pred_micro or do_presc_micro)
      endif ! (do_random_overlap)

!---------------------------------------------------------------------



end subroutine strat_clouds_amt  



!#####################################################################
! <SUBROUTINE NAME="obtain_bulk_lw_strat">
!  <OVERVIEW>
!   obtain_bulk_lw_strat defines bulk longwave cloud radiative 
!    properties for the klein strat cloud scheme. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   obtain_bulk_lw_strat defines bulk longwave cloud radiative 
!    properties for the klein strat cloud scheme.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_lw_strat (is, ie, js, je, Cld_spec, Cldrad_props)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!  </IN>
!  <INOUT NAME="cldrad_properties" TYPE="microphys_type">
!   cloud radiative properties on model grid
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_lw_strat (is, ie, js, je, Cld_spec, Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_lw_strat defines bulk longwave cloud radiative 
!    properties for the klein strat cloud scheme.
!---------------------------------------------------------------------

integer,                      intent(in)    :: is, ie, js, je
type(cld_specification_type), intent(in)    :: Cld_spec
type(cldrad_properties_type), intent(inout) :: Cldrad_props

!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      Cld_spec     cloud specification arrays defining the 
!                   location, water paths and effective particle
!                   sizes of clouds that are present, provides 
!                   input to this subroutine
!                   [ cld_specification_type ]
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %emrndlw   longwave cloud emissivity for 
!                               randomly overlapped clouds
!                               in each of the longwave
!                               frequency bands  [ dimensionless ]
!                    %emmxolw   longwave cloud emissivity for 
!                               maximally overlapped clouds
!                               in each of the longwave 
!                               frequency bands  [ dimensionless ]
!
!---------------------------------------------------------------------
 
!-------------------------------------------------------------------
!   local variables:

      real, dimension (size(Cld_spec%lwp,1), size(Cld_spec%lwp,2),  &
                       size(Cld_spec%lwp,3)) :: emcld

      integer       :: max_cld
      integer       :: i, j, k

!-------------------------------------------------------------------
!   local variables:
!
!         emcld      longwave cloud emissivity [ dimensionless ]
!         max_cld    maximum number of clouds in any column in the
!                    window
!         i,j,k      do-loop indices
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('strat_clouds_W_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!   find maximum number of clouds in any column in the window.
!---------------------------------------------------------------------
      max_cld = MAXVAL(Cld_spec%ncldsw(:,:))

!---------------------------------------------------------------------
!    if cloud is present in the window, call lw_emissivity to compute 
!    the longwave emissivity. otherwise, leave the emissivity arrays 
!    with their previously initialized values.
!---------------------------------------------------------------------
      if (max_cld > 0) then
!---------------------------------------------------------------------
!    call lw_emissivity to obtain the longwave cloud emissivity.
!---------------------------------------------------------------------
        call lw_emissivity (is, js, Cld_spec%lwp, Cld_spec%iwp,  &
                         Cld_spec%reff_liq_lim, Cld_spec%reff_ice_lim,&
                            Cld_spec%ncldsw, emcld)

!---------------------------------------------------------------------
!    define both the random and max overlap cloud emissivities to be
!    that value returned from lw_emissivity.
!-------------------------------------------------------------------
        do k=1,size(Cld_spec%lwp,3)
          do j=1,size(Cld_spec%lwp,2)
            do i=1,size(Cld_spec%lwp,1)
              Cldrad_props%emrndlw(i,j,k,:,1) = emcld(i,j,k)
              Cldrad_props%emmxolw(i,j,k,:,1) = emcld(i,j,k)
            end do
          end do
        end do
      endif

!--------------------------------------------------------------------


end subroutine obtain_bulk_lw_strat



!#####################################################################
! <SUBROUTINE NAME="obtain_bulk_sw_strat">
!  <OVERVIEW>
!   obtain_bulk_lw_strat defines bulk shortwave cloud radiative 
!    properties for the klein strat cloud scheme. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   obtain_bulk_lw_strat defines bulk shortwave cloud radiative 
!    properties for the klein strat cloud scheme.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call obtain_bulk_sw_strat (is, ie, js, je, cosz, Cld_spec, Cldrad_props)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="cosz" TYPE="real">
!   cosine of the solar zenith angle
!  </IN>
!  <IN NAME="Cld_spec" TYPE="cld_specification_type">
!   cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!  </IN>
!  <INOUT NAME="cldrad_properties" TYPE="microphys_type">
!   cloud radiative properties on model grid
!  </INOUT>
! </SUBROUTINE>
!
subroutine obtain_bulk_sw_strat (is, ie, js, je, cosz, Cld_spec,   &
                                 Cldrad_props)

!---------------------------------------------------------------------
!    obtain_bulk_sw_strat defines bulk shortwave cloud radiative 
!    properties for the klein strat cloud scheme.
!---------------------------------------------------------------------
 
integer,                      intent(in)    ::  is, ie, js, je
real, dimension(:,:),         intent(in)    ::  cosz
type(cld_specification_type), intent(in)    ::  Cld_spec
type(cldrad_properties_type), intent(inout) ::  Cldrad_props
 
!--------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      cosz         cosine of the zenith angle  [ dimensionless ]
!      Cld_spec     cloud specification arrays defining the 
!                   location, amount and type (hi, middle, lo)
!                   of clouds that are present, provides input 
!                   to this subroutine
!                   [ cld_specification_type ]
!
!   intent(inout) variables:
!
!      Cldrad_props      cloud radiative properties on model grid,
!                        [ cldrad_properties_type ]
!
!               the following components of this variable are output 
!               from this routine:
!
!                    %cirabsw   absorptivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cirrfsw   reflectivity of clouds in the 
!                               infrared frequency band
!                               [ dimensionless ]
!                    %cvisrfsw  reflectivity of clouds in the 
!                               visible frequency band
!                               [ dimensionless ]
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables:

      integer   :: max_cld

!---------------------------------------------------------------------  
!   local variables:
!
!          max_cld    maximum number of clouds in any column in the
!                     window
!
!----------------------------------------------------------------------

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('strat_clouds_W_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!   find maximum number of clouds in any column in the window.
!---------------------------------------------------------------------
      max_cld  = MAXVAL(Cld_spec%ncldsw(:,:))

!---------------------------------------------------------------------
!    if cloud is present in the window, call sw_optical_properties to 
!    compute cloud optical properties and then radiative properties. 
!    otherwise, leave the arrays with their previously initialized 
!    values.
!---------------------------------------------------------------------
      if (max_cld > 0) then
        call sw_optical_properties (Cld_spec%ncldsw, Cld_spec%lwp,   &
                                  Cld_spec%iwp, Cld_spec%reff_liq_lim, &
                                    Cld_spec%reff_ice_lim, cosz,   &
                                    Cldrad_props%cvisrfsw, &
                                    Cldrad_props%cirrfsw,  &
                                    Cldrad_props%cirabsw)
      endif   

!-------------------------------------------------------------------


end subroutine obtain_bulk_sw_strat

!####################################################################
! <SUBROUTINE NAME="strat_clouds_W_end">
!  <OVERVIEW>
!    strat_clouds_W_end is the destructor for strat_clouds_W_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    strat_clouds_W_end is the destructor for strat_clouds_W_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call strat_clouds_W_end
!  </TEMPLATE>
! </SUBROUTINE>
subroutine strat_clouds_W_end
       
!----------------------------------------------------------------------
!    strat_clouds_W_end is the destructor for strat_clouds_W_mod.
!----------------------------------------------------------------------
        
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('strat_clouds_W_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
! close cloud_generator
!---------------------------------------------------------------------
      deallocate (lats, lons)
      if (do_stochastic_clouds) &
                call cloud_generator_end()

!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.
       
!--------------------------------------------------------------------
 
 
end subroutine strat_clouds_W_end



!#################################################################




                    end module strat_clouds_W_mod



!FDOC_TAG_GFDL

                 module uw_clouds_W_mod
! <CONTACT EMAIL="fei.liu@noaa.gov">
!   fil
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!          uw shallow convection cloud radiative properties module
!   
! </OVERVIEW>
! <DESCRIPTION>
!   
! </DESCRIPTION>
!

use  time_manager_mod, only: time_type
use           mpp_mod, only: input_nml_file
use           fms_mod, only: open_namelist_file, file_exist,   &
                             check_nml_error, error_mesg,   &
                             close_file, FATAL, NOTE, &
                             WARNING, mpp_pe, mpp_root_pe, &
                             write_version_number, stdlog
use     constants_mod, only: DENS_H2O, RDGAS, TFREEZE
use rad_utilities_mod, only: longwave_control_type, Lw_control, &
                             shortwave_control_type, Sw_control,&
                             microphysics_type,  &
                             microrad_properties_type, &
                             cld_specification_type, &
                             cloudrad_control_type, Cldrad_control

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!          uw shallow convection cloud radiative properties module
!
!--------------------------------------------------------------------



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

   character(len=128)  :: version =  '$Id: uw_clouds_W.F90,v 17.0.6.2 2010/09/07 16:17:19 wfc Exp $'
   character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          uw_clouds_W_init,   &
          uw_clouds_W_end , uw_clouds_amt

!---------------------------------------------------------------------
!-------- namelist  ---------

logical   :: dummy = .true.


namelist /uw_clouds_W_nml /     &
                                     dummy                          


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------

real, parameter :: K_LAND  = 1.143
real, parameter :: K_OCEAN = 1.077
real, parameter :: N_LAND  = 250.E+06
real, parameter :: N_OCEAN = 100.E+06
real, parameter :: N_MIN   = 1.0e06
real, parameter :: QMIN    = 1.0e-10
real, parameter :: QAMIN   = 1.0e-2

  logical :: module_is_initialized = .false.
!----------------------------------------------------------------------
!----------------------------------------------------------------------




contains 





! <SUBROUTINE NAME="uw_clouds_W_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call uw_clouds_W_init  (pref, lonb, latb, axes, Time)
!
!  </TEMPLATE>
!  <IN NAME="pref" TYPE="real">
! 
!  </IN>
!  <IN NAME="lonb" TYPE="real">
! 
!  </IN>
!  <IN NAME="latb" TYPE="real">
! 
!  </IN>
!  <IN NAME="axes" TYPE="integer">
! 
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
! 
!  </IN>
! </SUBROUTINE>
!
subroutine uw_clouds_W_init  (pref, lonb, latb, axes, Time)

real, dimension(:,:),  intent(in) :: pref
real, dimension(:,:),  intent(in) :: lonb, latb
integer, dimension(4), intent(in) :: axes
type(time_type),       intent(in) :: Time

      integer            :: unit, ierr, io, logunit

     if (module_is_initialized) return
!---------------------------------------------------------------------
!-----  read namelist  ------
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=uw_clouds_W_nml, iostat=io)
      ierr = check_nml_error(io,"uw_clouds_W_nml")
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ()
        ierr=1; do while (ierr /= 0)
        read (unit, nml=uw_clouds_W_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'uw_clouds_W_nml')
        enddo
10      call close_file (unit)
      endif
#endif

      if ( mpp_pe() == mpp_root_pe() ) then
         call write_version_number(version, tagname)
         logunit = stdlog()
         write (logunit,nml=uw_clouds_W_nml)
      endif

!---------------------------------------------------------------------

       module_is_initialized = .true.


end subroutine uw_clouds_W_init

! <SUBROUTINE NAME="uw_clouds_W_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call uw_clouds_W_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine uw_clouds_W_end
       
!----------------------------------------------------------------------
!    uw_clouds_W_end is the destructor for uw_clouds_W_mod.
!----------------------------------------------------------------------
       
!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.
       
!--------------------------------------------------------------------


end subroutine uw_clouds_W_end


!#################################################################


!---------------------------------------------------------------------

! <SUBROUTINE NAME="uw_clouds_amt">
!  <OVERVIEW>
!    uw_clouds_amt defines the distribution of cloud water and cloud ice 
!    amounts [ g / m**3 ] and liquid and ice particle sizes and total cloud 
!    fraction for the clouds associated with uw shallow convection. these 
!    values will later be combined with other cloud fields to produce the 
!    cloud radiative properties that will be seen by the radiation package.
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    uw_clouds_amt defines the distribution of cloud water and cloud ice 
!    amounts [ g / m**3 ] and liquid and ice particle sizes and total cloud 
!    fraction for the clouds associated with uw shallow convection. these 
!    values will later be combined with other cloud fields to produce the 
!    cloud radiative properties that will be seen by the radiation package.
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call uw_clouds_amt (is, ie, js, je, Shallow_microphys)   
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
! 
!  </IN>
!  <IN NAME="ie" TYPE="integer">
! 
!  </IN>
!  <IN NAME="js" TYPE="integer">
! 
!  </IN>
!  <IN NAME="je" TYPE="integer">
! 
!  </IN>
!  <INOUT NAME="Shallow_microphys" TYPE="microphysics_type">
! 
!  </INOUT>
! </SUBROUTINE>
!
subroutine uw_clouds_amt (is, ie, js, je,   &
                   shallow_cloud_area, shallow_liquid, shallow_ice, &
                   shallow_droplet_number, land, pfull, tkel, &
                   Shallow_microphys)

!---------------------------------------------------------------------
!    uw_clouds_amt defines the distribution of cloud water and cloud ice 
!    amounts [ g / m**3 ] and liquid and ice particle sizes and total cloud 
!    fraction for the clouds associated with uw shallow convection. these 
!    values will later be combined with other cloud fields to produce the 
!    cloud radiative properties that will be seen by the radiation package.
!----------------------------------------------------------------------

integer,                 intent(in)    :: is,ie,js,je
real, dimension(:,:,:),  intent(in)    :: shallow_cloud_area,  &
                                          shallow_liquid, shallow_ice, &
                                          shallow_droplet_number
real, dimension(:,:),    intent(in)    :: land
real, dimension(:,:,:),  intent(in)    :: pfull, tkel
type(microphysics_type), intent(inout) :: Shallow_microphys

!--------------------------------------------------------------------------
!   local variables:

      real, dimension (size(shallow_liquid,1),                             &
                       size(shallow_liquid,2),                             &
                       size(shallow_liquid,3)) ::  liq_local, area_local,  &
                                                   ice_local, rho
      real, dimension (size(shallow_liquid,1),                             &
                       size(shallow_liquid,2)) ::  k_ratio, ndrops
      integer     :: ix, jx, kx
      integer     :: i, j, k

!----------------------------------------------------------------------
!    define vertical index.
!----------------------------------------------------------------------
      ix = size(Shallow_microphys%size_drop,1)
      jx = size(Shallow_microphys%size_drop,2)
      kx = size(Shallow_microphys%size_drop,3)

!---------------------------------------------------------------------
!    define k_ratio as appropriate mix of land and ocean values.
!----------------------------------------------------------------------
      k_ratio(:,:) = K_LAND*land(:,:) + K_OCEAN*(1.0 - land(:,:))
      ndrops(:,:)  = N_LAND*land(:,:) + N_OCEAN*(1.0 - land(:,:))
      
!---------------------------------------------------------------------
!    limit shallow cloud area and cloud amount so that non-zero clouds 
!    exist only in boxes with non-zero cloud areas.
!---------------------------------------------------------------------
      do k=1,kx                                      
        do j=1,jx
          do i=1,ix
            area_local(i,j,k) = 0.
            if ( (shallow_cloud_area(i,j,k) > QAMIN) .and.  &
                 (shallow_liquid(i,j,k) > QMIN) ) then
              liq_local(i,j,k) = shallow_liquid(i,j,k)
              area_local(i,j,k) = shallow_cloud_area(i,j,k)
            else
              liq_local(i,j,k) = 0.0                     
            endif

            if ( (shallow_cloud_area(i,j,k) > QAMIN) .and.  &
                 (shallow_ice(i,j,k) > QMIN)) then
              ice_local(i,j,k) = shallow_ice(i,j,k)
              area_local(i,j,k) = shallow_cloud_area(i,j,k)
            else
              ice_local(i,j,k) = 0.0                     
            endif
          end do
        end do
      end do
          
!----------------------------------------------------------------------
!    define droplet diameter based on cloud amount and droplet number. 
!    use formula as in cloud_rad_mod.
!----------------------------------------------------------------------
      if (Cldrad_control%do_liq_num) then
      do k=1,kx
        do j=1,jx
          do i=1,ix
            if (liq_local(i,j,k) > QMIN) then
              Shallow_microphys%size_drop(i,j,k)  =  2.0* &
                       (k_ratio(i,j)*620350.49*(liq_local(i,j,k)/DENS_H2O/ &
                       MAX(shallow_droplet_number(i,j,k), N_MIN*   &
                               max(area_local(i,j,k), QAMIN)/ &
                       (pfull(i,j,k)/RDGAS/tkel(i,j,k))))**(1./3.) )
            else
              Shallow_microphys%size_drop(i,j,k)  =  0.0 
            endif
          end do
        end do
      end do
      Shallow_microphys%droplet_number = shallow_droplet_number
      else
!----------------------------------------------------------------------
!  case of non-prognostic droplet number
!----------------------------------------------------------------------
      do k=1,kx
        do j=1,jx
          do i=1,ix
            if (liq_local(i,j,k) > QMIN) then
              Shallow_microphys%size_drop(i,j,k)  =    &
                 2.0* k_ratio(i,j)*620350.49*(pfull(i,j,k)*  &
                 shallow_liquid(i,j,k)/area_local(i,j,k)/RDGAS/  &
                 tkel(i,j,k)/DENS_H2O/ndrops(i,j))**(1./3.)
            else
              Shallow_microphys%size_drop(i,j,k)  =  0.0 
            endif
              Shallow_microphys%droplet_number(i,j,k) =   &
                                        ndrops(i,j)/(pfull(i,j,k)/  &
                                                    (RDGAS*tkel(i,j,k)))
          end do
        end do
      end do
      endif

!--------------------------------------------------------------------
!    if ice crystals are present, define their effective size, which
!    is a function of temperature. for ice clouds the effective radius
!    is taken from the formulation in Donner (1997, J. Geophys. Res., 
!    102, pp. 21745-21768) which is based on Heymsfield and Platt (1984)
!    with enhancement for particles smaller than 20 microns.  
!
!              T Range (K)               Reff (microns) 
!     -------------------------------    --------------
!
!     tfreeze-25. < T                      100.6           
!     tfreeze-30. < T <= Tfreeze-25.        80.8         
!     tfreeze-35. < T <= Tfreeze-30.        93.5             
!     tfreeze-40. < T <= Tfreeze-35.        63.9            
!     tfreeze-45. < T <= Tfreeze-40.        42.5           
!     tfreeze-50. < T <= Tfreeze-45.        39.9         
!     Tfreeze-55  < T <= Tfreeze-50         21.6          
!                   T <= Tfreeze-55.        20.2        
!
!--------------------------------------------------------------------
      do k=1,kx
        do j=1,jx
          do i=1,ix
      if (Cldrad_control%using_fu2007) then
!+yim Fu's parameterization of dge
        Shallow_microphys%size_ice(i,j,k) =   &
                            47.05 + 0.6624*(tkel(i,j,k) - TFREEZE) +  &
                            0.001741*(tkel(i,j,k)-TFREEZE)**2 
      else ! (using_fu2007)
            if (ice_local(i,j,k) > QMIN) then
              if (tkel(i,j,k) > TFREEZE - 25. ) then
                Shallow_microphys%size_ice(i,j,k) = 100.6    
              else if (tkel(i,j,k) >  TFREEZE - 30. .and. &
                       tkel(i,j,k) <= TFREEZE - 25.) then
                Shallow_microphys%size_ice(i,j,k) = 80.8       
              else if (tkel(i,j,k) >  TFREEZE - 35. .and. &
                       tkel(i,j,k) <= TFREEZE - 30.) then
                Shallow_microphys%size_ice(i,j,k)  = 93.5     
              else if (tkel(i,j,k) >  TFREEZE - 40. .and. &
                       tkel(i,j,k) <= TFREEZE - 35.) then
                Shallow_microphys%size_ice(i,j,k) = 63.9      
              else if (tkel(i,j,k) >  TFREEZE - 45. .and. &
                       tkel(i,j,k) <= TFREEZE - 40.) then
                Shallow_microphys%size_ice(i,j,k) = 42.5    
              else if (tkel(i,j,k) >  TFREEZE - 50. .and. &
                       tkel(i,j,k) <= TFREEZE - 45.) then
                Shallow_microphys%size_ice(i,j,k) = 39.9       
              else if (tkel(i,j,k) >  TFREEZE - 55. .and. &
                       tkel(i,j,k) <= TFREEZE - 50.) then
                Shallow_microphys%size_ice(i,j,k) = 21.6        
              else
                Shallow_microphys%size_ice(i,j,k) = 20.2        
              end if
            else
              Shallow_microphys%size_ice(i,j,k) = 0.0
            endif
      endif  ! (using_fu2007)
          end do
        end do
      end do

!---------------------------------------------------------------------
!    convert the cloud and ice amounts from kg(h2o) / kg(air) to 
!    g(h2o) / m**3, as required for use in the microphys_rad routines
!    which compute cloud radiative properties.
!---------------------------------------------------------------------
      rho(:,:,:) = pfull(:,:,1:kx)/(RDGAS*tkel(:,:,1:kx))
      Shallow_microphys%conc_drop = 1.0e03*rho*liq_local  
      Shallow_microphys%conc_ice  = 1.0e03*rho* ice_local  

!---------------------------------------------------------------------
!    define the cloud area to be that after adjustment for trivial cloud
!    amounts.
!---------------------------------------------------------------------
      Shallow_microphys%cldamt = area_local


!---------------------------------------------------------------------



end subroutine uw_clouds_amt  



!####################################################################


                     end module uw_clouds_W_mod



                 module zetac_clouds_W_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="Stephen.Klein@noaa.gov">
!  sak
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    zetac_clouds_W_mod obtains the cloud specification variables
!    for the zetac cloud parameterization from microphys_cloud_mod
!    and makes them available to the radiation package.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!   shared modules:
use mpp_mod,                only: input_nml_file
use fms_mod,                only: open_namelist_file, mpp_pe, &
                                  mpp_root_pe, stdlog,  fms_init, &
                                  write_version_number, file_exist, &
                                  check_nml_error, error_mesg,   &
                                  FATAL, close_file
use constants_mod,          only: GRAV, constants_init

!   shared radiation package modules:

use rad_utilities_mod,      only: rad_utilities_init, &
                                  cld_specification_type, &
                                  microphysics_type

!   cloud parameterization module:

use microphys_cloud_mod,     only: microphys_cloud_init, microphys_cloud

!--------------------------------------------------------------------

implicit none
private

!--------------------------------------------------------------------
!    zetac_clouds_W_mod obtains the cloud specification variables
!    for the zetac cloud parameterization from microphys_cloud_mod
!    and makes them available to the radiation package.
!--------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: zetac_clouds_W.F90,v 17.0.4.1 2010/08/30 20:33:33 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public          &
          zetac_clouds_W_init, zetac_clouds_amt, zetac_clouds_W_end

!---------------------------------------------------------------------
!-------- namelist  ---------

integer   :: dummy = 0


namelist /zetac_clouds_W_nml /                      &
                                 dummy


!----------------------------------------------------------------------
!----  public data -------


!----------------------------------------------------------------------
!----  private data -------


logical :: module_is_initialized = .false.  ! module is initialized ?


!----------------------------------------------------------------------
!----------------------------------------------------------------------



                              contains 



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!#####################################################################
! <SUBROUTINE NAME="zetac_clouds_W_init">
!  <OVERVIEW>
!    zetac_clouds_W_init is the constructor for zetac_clouds_W_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    zetac_clouds_W_init is the constructor for zetac_clouds_W_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call zetac_clouds_W_init
!  </TEMPLATE>
! </SUBROUTINE>
!  
subroutine zetac_clouds_W_init 

!---------------------------------------------------------------------
!    zetac_clouds_W_init is the constructor for zetac_clouds_W_mod.
!---------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables:

      integer   ::   unit, ierr, io, logunit

!--------------------------------------------------------------------
!   local variables:
!
!      unit     io unit for reading nml file and writing logfile
!      ierr     error code
!      io       error status returned from io operation  
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    if routine has already been executed, exit.
!---------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that modules used by this module that are not called later
!    have already been initialized.
!---------------------------------------------------------------------
      call fms_init
      call rad_utilities_init
      call constants_init
      call microphys_cloud_init

!---------------------------------------------------------------------
!    read namelist.         
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=zetac_clouds_W_nml, iostat=io)
      ierr = check_nml_error(io,"zetac_clouds_W_nml")
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read (unit, nml=zetac_clouds_W_nml, iostat=io, end=10) 
        ierr = check_nml_error (io, 'zetac_clouds_W_nml')
        enddo                       
10      call close_file (unit)      
      endif                         
#endif

!----------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit = stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                 write (logunit, nml=zetac_clouds_W_nml)

!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.

!----------------------------------------------------------------------


end subroutine zetac_clouds_W_init



!######################################################################
! <SUBROUTINE NAME="zetac_clouds_amt">
!  <OVERVIEW>
!    zetac_clouds_amt defines the location, amount (cloud fraction), 
!    and number of clouds present on the model grid, in addition to
!    liquid and ice-water paths, cloud thickness, and effective drop 
!    and crystal sizes. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    zetac_clouds_amt defines the location, amount (cloud fraction), 
!    and number of clouds present on the model grid, in addition to
!    liquid and ice-water paths, cloud thickness, and effective drop 
!    and crystal sizes. if a microphysically-based cloud parameter-
!    ization is being used, particle sizes and concentrations are also
!    provided.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call zetac_clouds_amt (is, ie, js, je, z_half, z_full, land, &
!                             phalf, deltaz, Cld_spec, Lsc_microphys)
!  </TEMPLATE>
!  <IN NAME="is, ie, js, je" TYPE="integer">
!   starting/ending subdomain i,j indices of data in
!                   the physics_window being integrated
!  </IN>
!  <IN NAME="pflux" TYPE="real">
!   pressure values at flux levels (average of pressure values at
!   model grid points
!  </IN>
!  <IN NAME="press" TYPE="real">
!   pressure values at model grid points. surface 
!                   pressure is stored at index value nlev+1
!  </IN>
!  <IN NAME="temp" TYPE="real">
!    temperature at model levels (1:nlev), to be used
!                   in cloud calculations
!  </IN>
!  <IN NAME="land" TYPE="real">
!   fraction of grid box covered by land
!  </IN>
!  <INOUT NAME="Cld_spec" TYPE="cld_specification_type">
!   cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!  </INOUT>
!  <INOUT NAME="Lsc_microphys" TYPE="microphys_type">
!   microphysics_type variable containing the size,
!                   concentration and fraction of the four condensate 
!                   types (cloud drop, cloud ice, rain, snow) in the 
!                   grid box, present when microphysically-based
!                   cloud radiation properties are desired.
!  </INOUT>
! </SUBROUTINE>
!
subroutine zetac_clouds_amt (is, ie, js, je, z_half, z_full, land, &
                             phalf, deltaz,  &
                             Cld_spec, Lsc_microphys)

!---------------------------------------------------------------------
!    zetac_clouds_amt defines the location, amount (cloud fraction), 
!    and number of clouds present on the model grid, in addition to
!    liquid and ice-water paths, cloud thickness, and effective drop 
!    and crystal sizes. if a microphysically-based cloud parameter-
!    ization is being used, particle sizes and concentrations are also
!    provided.
!----------------------------------------------------------------------

integer,                      intent(in)        :: is, ie, js, je
real,    dimension(:,:,:),    intent(in)        :: z_half, z_full, &
                                                   phalf, deltaz
real,    dimension(:,:),      intent(in)        :: land
type(cld_specification_type), intent(inout)     :: Cld_spec      
type(microphysics_type),      intent(inout)     :: Lsc_microphys

!----------------------------------------------------------------------
!   intent(in) variables:
!
!      is,ie,js,je  starting/ending subdomain i,j indices of data in 
!                   the physics_window being integrated
!      pflux        average of pressure at adjacent model levels
!                   [ (kg /( m s^2) ] 
!      press        pressure at model levels (1:nlev), surface 
!                   pressure is stored at index value nlev+1
!                   [ (kg /( m s^2) ]
!      temp         temperature at model levels (1:nlev), to be used
!                   in cloud calculations
!                   [ deg K ]
!      land         fraction of grid box covered by land
!                   [ non-dimensional ]
!
!   intent(inout), optional variables:
!
!      Cld_spec     cld_specification_type variable containing the 
!                   cloud specification input fields needed by the 
!                   radiation package
!
!               the following elements of Cld_spec are defined here:
!
!                  %cmxolw  fraction of maximally overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %crndlw  fraction of randomly overlapped clouds
!                           seen by the longwave radiation 
!                           [ dimensionless ]
!                  %camtsw  cloud fraction seen by the shortwave
!                           radiation; the sum of the maximally
!                           overlapped and randomly overlapped 
!                           longwave cloud fractions  [ dimensionless ]
!                  %nmxolw  number of maximally overlapped longwave 
!                           clouds in each grid column.
!                  %nrndlw  number of randomly overlapped longwave 
!                           clouds in each grid column.
!                  %ncldsw  number of clouds seen by the shortwave
!                           radiation in each grid column.
!                  %cloud_thickness
!                           number of model layers over which the cloud
!                           in this grid box extends
!                  %lwp     liquid water path 
!                           [ kg / m^2 ]
!                  %iwp     ice water path
!                           [ kg / m^2 ]
!                  %reff_liq
!                           effective drop radius [ microns ]
!                  %reff_ice
!                           effective ice particle size [ microns ]
!
!      Lsc_microphys
!                   microphysics_type variable containing the size,
!                   concentration and fraction of the four condensate 
!                   types (cloud drop, cloud ice, rain, snow) in the 
!                   grid box, present when microphysically-based
!                   cloud radiation properties are desired.
!
!               the following components of this variable are output 
!               from this routine when microphysically-based properties
!               are desired:
!
!                  %conc_ice  ice particle concentration [ g /m^3 ]
!                  %conc_drop cloud droplet concentration [ g /m^3 ]
!                  %size_ice  ice particle effective diameter 
!                  [ microns ]
!                  %size_drop cloud droplet effective diameter
!                  [ microns ]
!
!----------------------------------------------------------------------

!-------------------------------------------------------------------
!    local variables

      integer :: idim, jdim, kdim
      integer :: i, j
      real, dimension (size(z_full,1), size(z_full,2),   &
                       size(z_full,3)) ::    deltap, diam_ice, diam_liq

!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('zetac_clouds_W_mod',   &
             'module has not been initialized', FATAL )
      endif


      idim = size (z_full,1)
      jdim = size (z_full,2)
      kdim = size (z_full,3)

      where ( Cld_spec%cloud_area > 0.0 ) 
        Cld_spec%cld_thickness = 1
      elsewhere
        Cld_spec%cld_thickness = 0
      endwhere         
 
      do i=1,idim
        do j=1,jdim
          Cld_spec%ncldsw(i,j) = sum( Cld_spec%cld_thickness(i,j,:) )
        enddo
      enddo

      Cld_spec%nrndlw = Cld_spec%ncldsw
      Cld_spec%nmxolw = 0 
      Cld_spec%camtsw = Cld_spec%cloud_area  
      Cld_spec%crndlw = Cld_spec%cloud_area
      Cld_spec%cmxolw = 0.0

      deltap = phalf(:,:,2:kdim+1)  - phalf(:,:,1:kdim)

      Cld_spec%lwp = deltap/GRAV*Cld_spec%cloud_water
      Cld_spec%iwp = deltap/GRAV*Cld_spec%cloud_ice

      call microphys_cloud (z_half, z_full, diam_liq, diam_ice)

      Lsc_microphys%size_drop = diam_liq
      Lsc_microphys%size_ice  = diam_ice
      Lsc_microphys%conc_drop = Cld_spec%lwp*1.0e3/deltaz
      Lsc_microphys%conc_ice  = Cld_spec%iwp*1.0e3/deltaz
      Lsc_microphys%cldamt    = Cld_spec%cloud_area 


!---------------------------------------------------------------------



end subroutine zetac_clouds_amt  




!####################################################################
! <SUBROUTINE NAME="zetac_clouds_W_end">
!  <OVERVIEW>
!    zetac_clouds_W_end is the destructor for zetac_clouds_W_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    zetac_clouds_W_end is the destructor for zetac_clouds_W_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call zetac_clouds_W_end
!  </TEMPLATE>
! </SUBROUTINE>
subroutine zetac_clouds_W_end
       
!----------------------------------------------------------------------
!    zetac_clouds_W_end is the destructor for zetac_clouds_W_mod.
!----------------------------------------------------------------------
        
!---------------------------------------------------------------------
!    be sure module has been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized ) then
        call error_mesg ('zetac_clouds_W_mod',   &
             'module has not been initialized', FATAL )
      endif

!---------------------------------------------------------------------
!    mark the module as not initialized.
!---------------------------------------------------------------------
      module_is_initialized = .false.
       
!--------------------------------------------------------------------
 
 
end subroutine zetac_clouds_W_end



!#################################################################




                    end module zetac_clouds_W_mod



  MODULE SHALLOW_CONV_MOD

!=======================================================================
! --- SHALLOW CONVECTION MODULE - GFDL SPECTRAL MODEL VERSION
!=======================================================================

 use  Sat_Vapor_Pres_Mod, ONLY: compute_qs, lookup_es_des
 use  mpp_mod,            only: input_nml_file
 use  Fms_Mod,            ONLY: FILE_EXIST, ERROR_MESG, FATAL,   &
                                CHECK_NML_ERROR, OPEN_NAMELIST_FILE,      &
                                CLOSE_FILE, mpp_pe, mpp_root_pe, &
                                write_version_number, stdlog

 use constants_mod, only: Hlv, Cp_Air, RDgas, RVgas, Kappa, grav

!---------------------------------------------------------------------
 implicit none
 private
!---------------------------------------------------------------------

 public  :: SHALLOW_CONV, SHALLOW_CONV_INIT
 public  :: MYLCL

!---------------------------------------------------------------------

 character(len=128) :: version = '$Id: shallow_conv.F90,v 17.0.4.1 2010/08/30 20:33:35 wfc Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

 logical :: module_is_initialized = .false.

!---------------------------------------------------------------------
! --- CONSTANTS
!---------------------------------------------------------------------

  real :: Hlv_by_Cp, Cp_by_RDgas, omkappa, dovcns, d622, d378
  real :: crtkons
  real, parameter :: p00 = 1000.0E2
  integer  :: kctopm1, kctopm2  

  real, allocatable, dimension(:) :: rhcrit, rhmax, rhmin, delrhc

!---------------------------------------------------------------------
! --- NAMELIST
!---------------------------------------------------------------------

  logical ::  lipps    = .false. 
  logical ::  ldetran  = .true. 
  real    ::  theqvcr  =    0.0
  real    ::  pshalow  =  750.0E2
  real    ::  akhsc0   =    5.0
  real    ::  crthum   =    0.85
  real    ::  hc       =    1.0
  integer ::  kctop    =    3

 
 NAMELIST / shallow_conv_nml /    &
         lipps, ldetran,  theqvcr, pshalow, akhsc0, kctop, crthum, hc

!---------------------------------------------------------------------

 contains

!#######################################################################
!#######################################################################

 SUBROUTINE SHALLOW_CONV_INIT( kx )

!=======================================================================
! ***** INITIALIZE SHALLOW CONVECTION
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!     kx     - Number of levels in vertical
!---------------------------------------------------------------------
 integer, intent(in) :: kx
 
!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
 integer :: unit, io, ierr, logunit
 
!=====================================================================

  if (module_is_initialized) return

!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=shallow_conv_nml, iostat=io)
  ierr = check_nml_error(io,"shallow_conv_nml")
#else
  if( FILE_EXIST( 'input.nml' ) ) then
! -------------------------------------
   unit = OPEN_NAMELIST_FILE ( )
   ierr = 1
   do while( ierr .ne. 0 )
   READ ( unit,  nml = shallow_conv_nml, iostat = io, end = 10 ) 
   ierr = CHECK_NML_ERROR(io,'shallow_conv_nml')
   end do
10 continue
   CALL CLOSE_FILE ( unit )
! -------------------------------------
  end if
#endif

!------- write version number and namelist ---------

  if ( mpp_pe() == mpp_root_pe() ) then
       call write_version_number(version, tagname)
       logunit = stdlog()
       WRITE( logunit, nml = shallow_conv_nml ) 
  endif

!---------------------------------------------------------------------
! --- Initialize constants
!---------------------------------------------------------------------

  d622        = RDgas / RVgas
  d378        = 1.0 - d622
  Hlv_by_Cp   = Hlv / Cp_Air
  Cp_by_RDgas = Cp_Air / RDgas
  omkappa     = 1.0 - Kappa
  dovcns      = -0.5 * grav / RDgas

!----------------------------------------------------

              crtkons = -1.0 * theqvcr * RDgas / grav
  if( lipps ) crtkons = 0.0

!----------------------------------------------------

  kctopm1 = kctop - 1                                                                                           
  kctopm2 = kctop - 2   

!----------------------------------------------------

  allocate( rhcrit(kx) ) 
  allocate(  rhmax(kx) ) 
  allocate(  rhmin(kx) ) 
  allocate( delrhc(kx) ) 

  rhcrit = crthum
  rhmax  = hc                                                    
  rhmin  = 2.0 * rhcrit - hc - 1.0e-15                          
  delrhc = 1.0 / ( rhmax - rhmin )

!-------------------------------------------------------------------
  module_is_initialized = .true.
!---------------------------------------------------------------------

!=====================================================================
  end SUBROUTINE SHALLOW_CONV_INIT

!#######################################################################

  SUBROUTINE SHALLOW_CONV_END
!-------------------------------------------------------------------
  module_is_initialized = .false.
!---------------------------------------------------------------------

  end SUBROUTINE SHALLOW_CONV_END

!#######################################################################
  SUBROUTINE SHALLOW_CONV( Temp, qmix0, pfull, phalf, akhsc, kbot )

!=======================================================================
! --- SHALLOW CONVECTION
!=======================================================================
!----------------------------------------------------------------------
! Arguments (Intent in)
!       Temp    -  Temperature
!       qmix0   -  Specific humidity
!       pfull   -  Pressure at full levels
!       phalf   -  Pressure at half levels
!       kbot    -  OPTIONAL; lowest model level index (integer)
!----------------------------------------------------------------------
  real, intent(in), dimension(:,:,:) :: Temp, qmix0, pfull, phalf

  integer, intent(in), OPTIONAL, dimension(:,:) :: kbot

!----------------------------------------------------------------------
! Arguments (Intent out)
!       akhsc  -  mixing coefficient for heat and moisture
!                 due to shallow convection
!----------------------------------------------------------------------
  real, intent(out), dimension(:,:,:) :: akhsc

!----------------------------------------------------------------------
! --- local
!----------------------------------------------------------------------
  real,    dimension(SIZE(Temp,1),SIZE(Temp,2)) ::                &
           plcl, rhumjmp, rhumscl,  xy1, xy2, xy3

  integer, dimension(SIZE(Temp,1),SIZE(Temp,2)) ::                &
           ksiglcl

  real,    dimension(SIZE(Temp,1),SIZE(Temp,2),SIZE(Temp,3)) ::   &
           qmix,  dphalf, qsat,  qsat2, rhum, theta, thetav, buoy, xyz1 

  integer, dimension(SIZE(Temp,1),SIZE(Temp,2),SIZE(Temp,3)) ::   &
           kbuoy 

 integer :: k, kx, kxm, kxp, i, ix, j, jx

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

  ix  = SIZE(Temp,1)
  jx  = SIZE(Temp,2)
  kx  = SIZE(Temp,3)

  kxm = kx - 1
  kxp = kx + 1

!=======================================================================
! --- MOISTURE VARIABLES
!=======================================================================

  qmix = qmix0
  qmix = MAX( qmix, 1.0E-6 )
  qmix = MIN( qmix, 0.2    )

! --- saturation mixing ratio 
  call compute_qs (Temp, pfull, qsat)

! --- relative humidity
  call compute_qs (Temp, pfull, qsat2, q=qmix)
  rhum = qmix / qsat2

!=======================================================================
! --- POTENTIAL TEMPERATURE
!=======================================================================

  theta  = Temp  * ( ( p00 / pfull )**Kappa )

!=======================================================================
! --- CALCULATE THE LIFTING CONDENSATION LEVEL, IE CLOUB BASE
!=======================================================================

  if( PRESENT( kbot ) ) then
     do j = 1,jx
     do i = 1,ix
        k = kbot(i,j)
             xy1(i,j) =      Temp(i,j,k)
             xy2(i,j) = MIN( qmix(i,j,k), qsat(i,j,k) )
             xy3(i,j) =     pfull(i,j,k)
     end do
     end do
  else
             xy1(:,:) =      Temp(:,:,kx)
             xy2(:,:) = MIN( qmix(:,:,kx), qsat(:,:,kx) )
             xy3(:,:) =     pfull(:,:,kx)
  end if

  CALL MYLCL( xy1, xy2, xy3, phalf, plcl, ksiglcl )

!=======================================================================
! --- INITALIZE
!=======================================================================

  kbuoy   = kxp
  akhsc   = 0.0
 
!=======================================================================
! --- BUOYANCY
!=======================================================================

!---------------------------------------------------------------------
! --- DEFAULT:
! --- BASED ON EQUIVALENT POTENTIAL TEMPERATURE GRADIENT 
!---------------------------------------------------------------------

  if( .not. lipps ) then
! %%%%%%%%%%%%%%%%%%%%%%%

! --- Vertical differential of pressure 
  dphalf(:,:,1:kxm) = pfull(:,:,2:kx) - pfull(:,:,1:kxm)

  if( PRESENT( kbot ) ) then
  dphalf(:,:,1:kxm) = MAX( dphalf(:,:,1:kxm), 1.0e-5 )
  end if

! --- Equivalent potential temperature
  xyz1    = ( Hlv_by_Cp * qmix ) / Temp
! thetav = theta * (1.0 + xyz1 )
  thetav = theta * EXP( xyz1 )

! --- Equivalent potential temperature gradient
  xyz1(:,:,2:kx)  =     thetav(:,:,2:kx)  - thetav(:,:,1:kxm) 
  xyz1(:,:,2:kx)  =       xyz1(:,:,2:kx)  / dphalf(:,:,1:kxm)
  buoy(:,:,2:kxm) = 0.5*( xyz1(:,:,2:kxm) +   xyz1(:,:,3:kx) )

! %%%%%%%%%%%%%%%%%%%%%%%
  endif

!---------------------------------------------------------------------
! --- OPTION:
! --- BUOYANCY ALA FRANK LIPPS 
!---------------------------------------------------------------------

  if( lipps ) then
! %%%%%%%%%%%%%%%%%%%%%%%

! --- Virtual potential temperature gardient
  thetav = theta * ( 1.0 + 0.608 * qmix )

! --- Buoyancy
  do k = kctopm2,kxm
! -------------------
  xy1(:,:) = Hlv / ( Cp_Air*RVgas*Temp(:,:,k)*Temp(:,:,k) ) + 1.0 / qsat(:,:,k)

  xy2(:,:) = ( grav / ( Cp_Air*Temp(:,:,k) ) ) *                              &  
             ( Hlv / ( RVgas*Temp(:,:,k) ) - Cp_by_RDgas ) / xy1(:,:)

  xy3(:,:) = ( thetav(:,:,k+1) - thetav(:,:,k )  ) / phalf(:,:,k+1) +     &
             ( thetav(:,:,k  ) - thetav(:,:,k-1) ) / phalf(:,:,k  )

  buoy(:,:,k) = ( hlv / ( Cp_Air*Temp(:,:,k) ) - 1.608 ) * xy2(:,:)
  buoy(:,:,k) =    buoy(:,:,k) - dovcns*pfull(:,:,k) * xy3(:,:) / Temp(:,:,k)
! -------------------
  end do

! %%%%%%%%%%%%%%%%%%%%%%%
  endif

!=======================================================================
! --- COMPUTE THE LEVEL OF NO BUOYANCY 
! --- RETAIN ONLY THE LOWEST CONTIGUOUS BUOYANT SHALLOW CONVECTIVE LAYER.
!=======================================================================

  do k = kctopm1,kxm
! -------------------
  where ( ( pfull(:,:,k) >= pshalow   ) .and.    &
          ( pfull(:,:,k) <= plcl(:,:) ) .and.    &
          (  buoy(:,:,k) >= crtkons   ) )  
            kbuoy(:,:,k) =  k 
  endwhere
! -------------------
  end do

  do k = kctopm1,kxm
! -------------------
  where( ( pfull(:,:,k)   <  plcl(:,:) ) .and.   &
         ( kbuoy(:,:,k)   == kxp       ) .and.   &
         ( kbuoy(:,:,k-1) == k-1       ) )   
           kbuoy(:,:,k-1) =  kxp
  endwhere
! -------------------
  end do

!=======================================================================
! --- SHALLOW CONVECTION WILL OCCUR AT LEVELS WHERE KBUOY <= KSIGLCL
!=======================================================================

  do k = kctopm1,kxm
! -------------------
  where( kbuoy(:,:,k) <= ksiglcl(:,:) ) 
         akhsc(:,:,k+1) =  akhsc0
  endwhere
! -------------------
  end do

!=======================================================================
! --- DETRAINMENT THRU INVERSION LAYER
!=======================================================================

!---------------------------------------------------------------------
! --- DEFAULT:
! --- ENHANCED DETRAINMENT THRU INVERSION LAYER.
!---------------------------------------------------------------------

  if( ldetran) then
! %%%%%%%%%%%%%%%%%%%%%%%%

  do k = kctopm1,kxm
! -------------------
  where( ( kbuoy(:,:,k)   == k       ) .and.   &
         ( kbuoy(:,:,k-1) == kxp     ) .and.   &
         ( pfull(:,:,k)   >= pshalow ) ) 
           akhsc(:,:,k)   =  0.2 * akhsc0
           akhsc(:,:,k+1) =  0.6 * akhsc0
  endwhere
! -------------------
  end do

  do k = kctopm1,kxm
! -------------------
  where( ( pfull(:,:,k)   <= plcl(:,:) ) .and.  &
         ( pfull(:,:,k+1) >  plcl(:,:) ) .and.  &
         ( kbuoy(:,:,k)   == k         )  )
           akhsc(:,:,k+1) =  0.2 * akhsc0
  endwhere
! -------------------
  end do

! %%%%%%%%%%%%%%%%%%%%%%%%
  endif

!---------------------------------------------------------------------
! --- OPTION:
! --- NORMAL DETRAINMENT THRU INVERSION LAYER
!---------------------------------------------------------------------

  if( .not. ldetran ) then
! %%%%%%%%%%%%%%%%%%%%%%%%

  rhumscl = 0.0
  rhumjmp = 0.0

  do k = kctopm1,kxm
! -------------------
  where( ( kbuoy(:,:,k)   == k       ) .and.    &
         (  buoy(:,:,k-1) <  crtkons ) .and.    &
         (  buoy(:,:,k)   >= crtkons ) ) 
         rhumjmp(:,:) =   rhum(:,:,k) -   rhum(:,:,k-1)
         rhumscl(:,:) =     delrhc(k) * ( rhum(:,:,k) - rhmin(k) )
  endwhere
! -------------------
  end do

  rhumscl = MIN( 1.0, rhumscl )
  rhumscl = MAX( 0.0, rhumscl )
  rhumjmp = MIN( 1.0, rhumjmp )
  rhumjmp = MAX( 0.0, rhumjmp )

  do k = kctopm1,kxm
! -------------------
  where( ( kbuoy(:,:,k)   == k       ) .and.   &
         ( kbuoy(:,:,k-1) == kxp     ) .and.   &
         ( pfull(:,:,k)   >= pshalow ) ) 
           akhsc(:,:,k)   =  akhsc0 * rhumscl(:,:) * rhumjmp(:,:)
  endwhere
! -------------------
  end do

! %%%%%%%%%%%%%%%%%%%%%%%%
  endif

!=======================================================================
! --- CONFINE SHALLOW CONVECTION TO ( pshalow <= p <= plcl )
!=======================================================================

  do k = kctopm1,kxm
! -------------------
  where ( ( pfull(:,:,k) <= pshalow   ) .or.    &
          ( pfull(:,:,k) >= plcl(:,:) ) )  
            akhsc(:,:,k+1) =  0.0 
  endwhere
! -------------------
  end do

!=======================================================================
  end SUBROUTINE SHALLOW_CONV

!#######################################################################

  SUBROUTINE MYLCL ( tlparc, qlparc, plparc, phalf, plcl, kbase )

!=======================================================================
! ***** COMPUTE LCL ( CLOUD BASE )
!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!       tlparc   Initial parcel temperature
!       qlparc   Initial parcel mixing ratio
!      plparc   Initial parcel pressure
!       phalf    Pressure at half levels
! Arguments (Intent out)
!       plcl     Pressure at LCL
!       kbase    Index of LCL in column
!---------------------------------------------------------------------
  real,    intent(in),  dimension(:,:)   :: tlparc, qlparc, plparc
  real,    intent(in),  dimension(:,:,:) :: phalf
  real,    intent(out), dimension(:,:)   :: plcl
  integer, intent(out), dimension(:,:)   :: kbase

!---------------------------------------------------------------------
!  (Intent local)
!---------------------------------------------------------------------
  integer, parameter :: iter_max = 10      
  real,    parameter :: small    = 1.0E-2 

  real,    dimension(size(tlparc,1),size(tlparc,2)) ::    &
           tlcl, tlclo, clclo, esat, esato, desato, xy1, xy2

 logical, dimension(size(tlparc,1),size(tlparc,2)) ::  &
           non_cnvg

  integer :: k, kx, n, iter

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

! --- Index of lowest model level, etc
  kx  = size( phalf, 3 ) - 1

! --- Initial guess for temperature at LCL
  tlclo = tlparc

! --- Compute constant factor
  clclo = ( 1.0 + d622/qlparc ) / plparc
  clclo = kappa*LOG( clclo )
  clclo =       EXP( clclo )
  clclo =    tlclo * clclo

! --- Start with all points non-convergent
  non_cnvg = .true.

! $$$$$$$$$$$$$$$$$$$$
  do iter = 1,iter_max
! $$$$$$$$$$$$$$$$$$$$

! --- Compute saturation vapor pressure and derivative
  call lookup_es_des (tlclo, esato, desato)

! --- Compute new guess for temperature at LCL
  where (non_cnvg)
     xy1  = kappa * clclo * desato
     xy2  = omkappa*LOG( esato )
     xy2  = EXP(  xy2 )
     tlcl = ( xy1 * tlclo - clclo * esato ) / ( xy1 - xy2 )
     xy2  = abs( tlcl - tlclo )
  end where

! --- Test for convergence
  where (non_cnvg .and. xy2 <= small)
     esat = esato
     non_cnvg = .false.
  endwhere
  n = COUNT( non_cnvg )

  if( n .eq. 0 ) go to 1000

! --- Shift for next iteration
  tlclo = tlcl

! $$$$$$$$$$$$$$$$$$$$
  end do
! $$$$$$$$$$$$$$$$$$$$
       CALL ERROR_MESG ('MYLCL in SHALLOW_CONV_MOD',  &
                        'ITERATION LOOP FOR LCL FAILED', FATAL)
 1000 continue

! --- Compute pressure at LCL
  plcl = ( 1.0 + d622 / qlparc ) * esat

! --- Bound plcl 
  plcl(:,:) = MAX( plcl(:,:), pshalow      )
  plcl(:,:) = MIN( plcl(:,:),  plparc(:,:) )

! --- Find index of LCL
  do k = 2,kx
  where ( ( plcl(:,:) >= phalf(:,:,k  ) ) .and.   &
          ( plcl(:,:) <= phalf(:,:,k+1) ) )  
           kbase(:,:) = k
  end where
  end do

!=======================================================================
  end SUBROUTINE MYLCL

!#######################################################################
!#######################################################################
  end MODULE SHALLOW_CONV_MOD




MODULE CONV_CLOSURES_MOD

! use Sat_Vapor_Pres_Mod, ONLY: ESCOMP, DESCOMP
! use      Constants_Mod, ONLY: tfreeze,HLv,HLf,HLs,CP_AIR,GRAV,Kappa,rdgas,rvgas
  use fms_mod,              only: write_version_number
  use  conv_utilities_k_mod,only: sd_copy_k, adi_cloud_k, extend_sd_k,&
                                  adicloud, sounding, uw_params
  use  conv_plumes_k_mod,   only: cumulus_plume_k, cumulus_tend_k, &
                                  cplume, ctend, cpnlist

!---------------------------------------------------------------------
  implicit none
  private

!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: conv_closures.F90,v 17.0.2.1.4.1 2010/03/17 20:27:10 wfc Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
  logical            :: module_is_initialized=.false.  ! module initialized ?

!---------------------------------------------------------------------
!-------  interfaces --------

  public  :: cclosure_bretherton, cclosure_relaxcbmf, cclosure_emanuel, &
             cclosure_implicit, cclosure_relaxwfn, &
             conv_closures_init, conv_closures_end

  character(len=11) :: mod_name = 'conv_closures'

  public cclosure
  type cclosure
     real    :: cbmf, wrel, ufrc, scaleh, dcin, dcape, dwfn, wfn
     integer :: igauss
     real    :: rkfre, rmaxfrac, rbuoy, tau_sh, tau_dp, wcrit_min
     real    :: maxcldfrac
  end type cclosure
 
contains

!#####################################################################
!#####################################################################

  function erfccc(x)
    !--------------------------------------------------------------
    ! This numerical recipes routine calculates the complementary
    ! error function.
    !--------------------------------------------------------------
   
    real :: erfccc
    real, intent(in) :: x 
    real :: t,z
   
    z=abs(x)      
    t=1./(1.+0.5*z)
   
    erfccc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t*      &
         (.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t*    &
         (1.48851587+t*(-.82215223+t*.17087277)))))))))
    
    if (x.lt.0.) erfccc=2.-erfccc
    
  end function erfccc

!#####################################################################
!#####################################################################

  subroutine solvecbmf(alpha, beta, x)
    !Newton iteration solving Eq. x = beta * exp (-alpha * x)
    implicit none
    real,    intent(in)    :: alpha, beta
    real,    intent(inout) :: x
    
    integer :: iteration, niteration=5, id_check
    real    :: dydx, x0, y0

    x0=1.
    do iteration = 1,niteration
       y0   = x0 - beta * exp(-alpha * x0)
       dydx = 1. + beta * alpha * exp(-alpha * x0)
       x0   = x0 - y0 / dydx
       if (abs(y0) < 0.0001) then
          x=x0; id_check=0
       else
          id_check=1
       end if
    end do
    if (id_check==1) then
      x=1.
      print*, 'ID_CHECK=1, in solvecbmfffffffffffff'
    endif
    
  end subroutine solvecbmf

!#####################################################################
!#####################################################################

  subroutine cclosure_bretherton(tkeavg, cpn, sd, Uw_p,  ac, cc, &
                                 cbmf_unmod)
  
    implicit none
    real,           intent(in)    :: tkeavg
    type(cpnlist),  intent(in)    :: cpn
    type(sounding), intent(in)    :: sd
    type(uw_params), intent(inout)    :: Uw_p
    type(adicloud), intent(in)    :: ac
    type(cclosure), intent(inout) :: cc
    real,   intent(out), optional :: cbmf_unmod
    
    real    :: sigmaw, wcrit, erfarg, cbmf, wexp, ufrc, wtw
    real    :: rmfk1=0.3, rmfk2=5.0, rmfk3=3.0

    cc%cbmf=0.; cc%wrel=0.; cc%ufrc=0.;
    if(cc%igauss.eq.0)then     !Use cin and pbl tke
       cbmf = rmfk1* ac % rho0lcl * sqrt(tkeavg) * exp(-rmfk2* ac % cin/tkeavg)
       wexp = rmfk3* sqrt(tkeavg) !Updraft vertical velocity at release height depends on tke

    elseif(cc%igauss.eq.1)then !Use cin and gaussian distribution of w
       wcrit  = sqrt(2. * ac % cin * cc%rbuoy)
       sigmaw = sqrt(cc%rkfre * tkeavg)
       wcrit = max(wcrit, cc%wcrit_min*sigmaw)
       cbmf   = ac % rho0lcl * sigmaw / 2.5066 * exp(-0.5*((wcrit/sigmaw)**2.))

      if (present (cbmf_unmod)) then
        cbmf_unmod = MAX(0.0, cbmf)
      endif
  
       !Diagnose updraft fraction sqrt(2.) = 1.4142
       erfarg=wcrit / (1.4142 * sigmaw)
       if(erfarg.lt.20.)then
          ufrc = min(cc%maxcldfrac, cc%rmaxfrac, 0.5*erfccc(erfarg))
       else
          ufrc = 0.
       endif

       if(ufrc.gt.0.0) then !Diagnose expected value of cloud base vertical velocity
           wexp = cbmf / ac % rho0lcl / ufrc
       else
          wexp = 0.
          cbmf = 0.
       endif
    endif

    wtw = wexp * wexp - 2 * ac % cin * cc%rbuoy !used for the runs of xx-hv1_amip and tropical storm 
    if(wtw.le.0.) then
       cc%wrel=0.; 
    else
       cc%wrel=sqrt(wtw)
    end if

    cc%cbmf=cbmf
    cc%wrel=min(cc%wrel, 50.)!cc%ufrc=min(cc%rmaxfrac, cc%ufrc)
    cbmf = (sd%ps(0) - ac%plcl ) * 0.25 / sd%delt / Uw_p%GRAV
    if (cc%cbmf .gt. cbmf) cc%cbmf = cbmf
    if (cc%wrel .gt. 0.) then
      cc%ufrc=cc%cbmf / cc%wrel /ac % rho0lcl
    else
      cc%ufrc=0.
    end if
    if (cc%ufrc > cc%maxcldfrac) then
       cc%ufrc = cc%maxcldfrac
       cc%cbmf = cc%wrel*ac%rho0lcl*cc%ufrc
    end if   

!    cc%cbmf=cbmf
!    cc%ufrc=ufrc
!
!    cbmf = (sd%ps(0) - ac%plcl ) * 0.25 / sd%delt / Uw_p%GRAV
!    if (cc%cbmf .gt. cbmf .and. cc%wrel .gt. 0) then
!       cc%cbmf = cbmf
!       cc%ufrc = cc%cbmf / wexp /ac % rho0lcl
!    end if
!    cc%wrel=min(cc%wrel, 50.)
!    cc%ufrc=min(cc%rmaxfrac, cc%ufrc)

    return

  end subroutine cclosure_bretherton

!#####################################################################
!#####################################################################

  subroutine cclosure_implicit(tkeavg, cpn, sd, Uw_p, ac, cc, delt, rkm, &
       do_coldT, sd1, ac1, cc1, cp1, ct1, ier, ermesg)
    implicit none
    real,           intent(in)    :: tkeavg, delt, rkm
    type(cpnlist),  intent(in)    :: cpn
    type(sounding), intent(in)    :: sd
    type(uw_params), intent(inout)    :: Uw_p
    type(adicloud), intent(in)    :: ac
    type(cclosure), intent(inout) :: cc, cc1
    type(sounding), intent(inout) :: sd1
    type(adicloud), intent(inout) :: ac1
    type(cplume),   intent(inout) :: cp1
    type(ctend),    intent(inout) :: ct1
    logical,        intent(in)    :: do_coldT
    integer,        intent(out)     :: ier
    character(len=256), intent(out) :: ermesg

    logical :: dofast=.false., doice=.true.

    real :: cbmf0=0.001, alpha, beta, phi

    call cclosure_bretherton(tkeavg, cpn, sd, Uw_p, ac, cc)
    if(cc%cbmf.eq.0.) then
      cc % dcin=0.
      return
    end if

    call cumulus_plume_k(cpn, sd, ac, cp1, rkm, cbmf0, cc%wrel, cc%scaleh, Uw_p, ier, ermesg)
    if (ier /= 0) then
      ermesg = 'Called from cclosure_implicit : '// trim(ermesg)
      return
    endif
    if(cp1%ltop.lt.cp1%krel+2 .or. cp1%let.le.cp1%krel+1) then
       cc % dcin=0.
       return
    else
       call cumulus_tend_k(cpn, sd, Uw_p, cp1, ct1, do_coldT)
       call sd_copy_k(sd, sd1)
       sd1 % t  = sd1 % t  + ct1%tten  * delt
       sd1 % qv = sd1 % qv + ct1%qvten * delt
       sd1 % ql = sd1 % ql + ct1%qlten * delt
       sd1 % qi = sd1 % qi + ct1%qiten * delt
       sd1 % qa = sd1 % qa + ct1%qaten * delt
       sd1 % qn = sd1 % qn + ct1%qnten * delt
       sd1 % u  = sd1 % u  + ct1%uten  * delt
       sd1 % v  = sd1 % v  + ct1%vten  * delt

       call extend_sd_k(sd1, sd%pblht, doice, Uw_p)

       call adi_cloud_k(sd1%zs(1), sd1%ps(1), sd1%hl(1), sd1%thc(1), sd1%qct(1), sd1, Uw_p, dofast, doice, ac1)

       cc % dcin=(ac1%cin-ac%cin)/cbmf0

       alpha  = (2. * cc%rbuoy) / (2. * cc%rkfre * tkeavg) * cc % cbmf * cc % dcin
       beta   = 1.  ! ac % rho0lcl * sqrt(cc%rkfre * tkeavg) / 2.5066
       phi    = 1.
       if (alpha .gt. 0.) then
          call solvecbmf(alpha, beta, phi)
          cc % cbmf = phi * cc % cbmf
       end if
    end if

  end subroutine cclosure_implicit

!#####################################################################
!#####################################################################

  subroutine cclosure_relaxcbmf(tkeavg, cpn, sd, Uw_p, ac, cc, delt)
  
    implicit none
    real,           intent(in)    :: tkeavg, delt
    type(cpnlist),  intent(in)    :: cpn
    type(sounding), intent(in)    :: sd
    type(uw_params), intent(in)    :: Uw_p
    type(adicloud), intent(in)    :: ac
    type(cclosure), intent(inout) :: cc
    
    real    :: sigmaw, wcrit, erfarg, wexp, wtw
    real    :: cbmfs, tmp
    
    cc%wrel=0.; cc%ufrc=0.;   

    wcrit  = sqrt(2. * ac % cin * cc%rbuoy)
    sigmaw = sqrt(cc%rkfre * tkeavg)
    cbmfs  = ac % rho0lcl * sigmaw / 2.5066 * exp(-0.5*((wcrit/sigmaw)**2.))

    tmp    = delt/cc%tau_sh
    cc%cbmf= max((cc%cbmf+tmp*cbmfs)/(1.+tmp),0.0)

    !Diagnose updraft fraction
    erfarg=wcrit / (1.4142 * sigmaw)
    if(erfarg.lt.20.)then
       cc%ufrc = min(cc%maxcldfrac, cc%rmaxfrac, 0.5*erfccc(erfarg))
    else
       cc%ufrc = 0.
    endif

    if(cc%ufrc.gt.0.001)then !Diagnose expected value of cloud base vertical velocity
       wexp = cc%cbmf / ac % rho0lcl / cc%ufrc
    else
       wexp = 0.
       cc%cbmf = 0.
    endif

    wexp=min(wexp, 50.)
    wtw = wexp * wexp - 2 * ac % cin * cc%rbuoy
    if(wtw.le.0.) then
       cc%wrel=0.; 
    else
       cc%wrel=sqrt(wtw)
    end if

    return

  end subroutine cclosure_relaxcbmf

!#####################################################################
!#####################################################################

  subroutine cclosure_emanuel(tkeavg, cpn, sd, Uw_p, ac, cc, delt)
  
    implicit none
    real,           intent(in)    :: tkeavg, delt
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    type(sounding), intent(in)    :: sd
    type(adicloud), intent(in)    :: ac
    type(cclosure), intent(inout) :: cc
    
    integer :: k
    real    :: ufrc=0.01
    real    :: dtmin, dpsum, dtpbl, damps
    real    :: cbmf
    real    :: dtmax    = 0.9    ! MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
                                 ! A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC
    real    :: damp     = 0.1    ! ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF
    real    :: alpha    = 0.1    ! APPROACH TO QUASI-EQUILIBRIUM

    cbmf=cc%cbmf; cc%cbmf=0.; cc%wrel=0.; cc%ufrc=0.;

    dpsum=0.; dtpbl=0.
    do k=1, ac%klcl-1
       dtpbl=dtpbl+(ac%thv(k)-sd%thv(k))*sd%exner(k)*sd%dp(k)
       dpsum=dpsum+sd%dp(k);
    end do
    dtpbl=dtpbl/dpsum
    dtmin=(ac%thvlcl-ac%thv0lcl)+dtpbl+dtmax

    damps=damp*delt/300.
    cbmf =(1.-damps)*cbmf+0.1*alpha*dtmin
    cc%cbmf=max(cbmf,0.0)
    cc%wrel=cbmf / ac % rho0lcl / ufrc
    cc%ufrc=ufrc

    return

  end subroutine cclosure_emanuel

!#####################################################################
!#####################################################################

  subroutine cclosure_relaxwfn(tkeavg, cpn, sd, Uw_p, ac, cc, cp, ct, delt, rkm, &
       do_coldT, sd1, ac1, cc1, cp1, ct1, ier, ermesg)
    implicit none
    real,           intent(in)    :: tkeavg, delt, rkm
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    type(sounding), intent(in)    :: sd
    type(adicloud), intent(in)    :: ac
    type(cclosure), intent(inout) :: cc, cc1
    type(sounding), intent(inout) :: sd1
    type(adicloud), intent(inout) :: ac1
    type(cplume),   intent(inout) :: cp, cp1
    type(ctend),    intent(inout) :: ct, ct1
    logical,        intent(in)    :: do_coldT
    integer,        intent(out)   :: ier
    character(len=256), intent(out) :: ermesg
    logical :: dofast=.false., doice=.true.


    integer :: k
    real    :: cbmf0=0.0001, delp, cbmf_old, tmp, cbmfs

    cbmf_old= cc%cbmf
    call cclosure_bretherton(tkeavg, cpn, sd, Uw_p, ac, cc)

    call cumulus_plume_k(cpn, sd,  ac, cp, rkm, cbmf0, cc%wrel, cc%scaleh, Uw_p, ier, ermesg)
    if (ier /= 0) then
      ermesg = 'Called from cclosure_relaxwfn : '//trim(ermesg)
      return
    endif
    if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
       cc % dcin=0.
       return
    else
       call cumulus_tend_k(cpn, sd, Uw_p, cp, ct, do_coldT)
       call sd_copy_k(sd, sd1)
       sd1 % t  = sd1 % t  + ct%tten  * delt
       sd1 % qv = sd1 % qv + ct%qvten * delt
       sd1 % ql = sd1 % ql + ct%qlten * delt
       sd1 % qi = sd1 % qi + ct%qiten * delt
       sd1 % qa = sd1 % qa + ct%qaten * delt
       sd1 % qn = sd1 % qn + ct%qnten * delt
       sd1 % u  = sd1 % u  + ct%uten  * delt
       sd1 % v  = sd1 % v  + ct%vten  * delt

       call extend_sd_k(sd1, sd%pblht, doice, Uw_p)

       call adi_cloud_k(sd1%zs(1), sd1%ps(1), sd1%hl(1), sd1%thc(1), sd1%qct(1), sd1, Uw_p, dofast, doice, ac1)
       cc % dcin=(ac1%cin-ac%cin)/cbmf0
       cc % dcape=(ac1%cape-ac%cape)/cbmf0

       call cumulus_plume_k(cpn, sd1, ac1, cp1, rkm, cbmf0, cc%wrel, cc%scaleh, Uw_p, ier, ermesg)
       if (ier /= 0) then
         ermesg = 'Called from cclosure_relaxwfn 2nd call : '//trim(ermesg)
       endif

       cc%dwfn=0.; cc%wfn=0.; delp=0.;
       do k=cp1%krel, cp1%let
          cc % wfn  = cc % wfn  + 0.5*(cp %wu(k)*cp %wu(k)) * cp%dp(k)
          cc % dwfn = cc % dwfn + 0.5*(cp1%wu(k)*cp1%wu(k) - cp%wu(k)*cp%wu(k)) * cp%dp(k)
          delp      = delp + cp%dp(k)
       end do
       cc % wfn  = cc % wfn  / delp 
       cc % dwfn = cc % dwfn / delp / cbmf0

       cbmfs = - cc%wfn  / cc % dwfn

       tmp    = delt/cc%tau_sh
       cc%cbmf= (cbmf_old+tmp*cbmfs)/(1.+tmp)

       cc % cbmf = max(cc%cbmf,0.)


    end if

  end subroutine cclosure_relaxwfn

!#####################################################################
!#####################################################################
subroutine conv_closures_init

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.
    


end subroutine conv_closures_init
!#####################################################################
!#####################################################################
subroutine conv_closures_end

      module_is_initialized = .false.


end subroutine conv_closures_end

!#####################################################################
!#####################################################################

end MODULE CONV_CLOSURES_MOD



MODULE CONV_PLUMES_MOD


!---------------------------------------------------------------------
  implicit none
  private

!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: conv_plumes.F90,v 15.0 2007/08/14 03:56:03 fms Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------


  character(len=11) :: mod_name = 'conv_plumes'


!contains

!#####################################################################
!#####################################################################



end MODULE CONV_PLUMES_MOD


#include <fms_platform.h>
MODULE CONV_PLUMES_k_MOD

  use  aer_ccn_act_k_mod,   only: aer_ccn_act_k
  use  conv_utilities_k_mod,only: findt_k, exn_k, qsat_k, adicloud, sounding, uw_params
  use Sat_Vapor_Pres_k_Mod, ONLY: compute_qs_k

!---------------------------------------------------------------------
  implicit none
  private

!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: conv_plumes_k.F90,v 17.0.2.1.2.1.4.1 2010/03/17 20:27:10 wfc Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

  public  :: cp_init_k, cp_end_k, cp_clear_k, ct_init_k, ct_end_k,  &
             ct_clear_k, cumulus_plume_k, cumulus_tend_k

  character(len=11) :: mod_name = 'conv_plumes'

  public cwetdep_type
  type cwetdep_type
   character(len=200) :: scheme
   real :: Henry_constant
   real :: Henry_variable
   real :: frac_in_cloud
   real :: alpha_r
   real :: alpha_s
   logical :: Lwetdep, Lgas, Laerosol, Lice
  end type cwetdep_type

  public cpnlist
  type cpnlist
     integer :: mixing_assumption, mp_choice
     real :: rle, rpen, rmaxfrac, wmin, rbuoy, rdrag, frac_drs, bigc
     real :: auto_th0, auto_rate, tcrit, cldhgt_max, atopevap, rad_crit,  &
             wtwmin_ratio, deltaqc0, emfrac_max, wrel_min,                        &
             Nl_land, Nl_ocean, r_thresh, qi_thresh, peff, rh0, cfrac,hcevap, weffect,t00
     logical :: do_ice, do_ppen, do_forcedlifting, do_pevap, do_pdfpcp, isdeep, use_online_aerosol
     logical :: do_auto_aero, do_pmadjt, do_emmax, do_pnqv, do_weffect, do_qctflx_zero,do_detran_zero
     character(len=32), dimension(:), _ALLOCATABLE  :: tracername _NULL
     character(len=32), dimension(:), _ALLOCATABLE  :: tracer_units _NULL
     type(cwetdep_type), dimension(:), _ALLOCATABLE :: wetdep _NULL
  end type cpnlist

  public cplume
  type cplume
     integer :: ltop, let, krel
     real    :: cush, cldhgt, prel, zrel
     real    :: maxcldfrac
     real, _ALLOCATABLE :: thcu  (:) _NULL, qctu  (:) _NULL, uu    (:) _NULL
     real, _ALLOCATABLE :: vu    (:) _NULL, qlu   (:) _NULL, qiu   (:) _NULL
     real, _ALLOCATABLE :: pptr  (:) _NULL, ppti  (:) _NULL, wu    (:) _NULL
     real, _ALLOCATABLE :: umf   (:) _NULL, emf   (:) _NULL, thvu  (:) _NULL
     real, _ALLOCATABLE :: rei   (:) _NULL, fer   (:) _NULL, fdr   (:) _NULL
     real, _ALLOCATABLE :: dp    (:) _NULL, thc   (:) _NULL, qct   (:) _NULL
     real, _ALLOCATABLE :: ql    (:) _NULL, qi    (:) _NULL, qa    (:) _NULL
     real, _ALLOCATABLE :: u     (:) _NULL, v     (:) _NULL, p     (:) _NULL
     real, _ALLOCATABLE :: ps    (:) _NULL, ufrc  (:) _NULL, thvtop(:) _NULL
     real, _ALLOCATABLE :: thvbot(:) _NULL, fdrsat(:) _NULL, z     (:) _NULL
     real, _ALLOCATABLE :: qn    (:) _NULL, qnu   (:) _NULL, zs    (:) _NULL
     real, _ALLOCATABLE :: hlu   (:) _NULL, hl    (:) _NULL, clu   (:) _NULL
     real, _ALLOCATABLE :: ciu   (:) _NULL, buo   (:) _NULL, t     (:) _NULL
     real, _ALLOCATABLE :: crate (:) _NULL, prate (:) _NULL, peff  (:) _NULL
!++++yim
     real, _ALLOCATABLE :: tr  (:,:) _NULL, tru (:,:) _NULL, tru_dwet(:,:) _NULL
     real, _ALLOCATABLE :: pptn  (:) _NULL
  end type cplume

  public ctend
  type ctend
     integer :: botlev, toplev
     real    :: rain, snow, denth, uav, vav, conint, freint,  &
                dtint, dqint, dqtmp, dting
     real, _ALLOCATABLE :: uten  (:) _NULL, vten  (:) _NULL, tten  (:) _NULL
     real, _ALLOCATABLE :: qvten (:) _NULL, qlten (:) _NULL, qiten (:) _NULL
     real, _ALLOCATABLE :: qaten (:) _NULL, thcten(:) _NULL, qctten(:) _NULL
     real, _ALLOCATABLE :: qvdiv (:) _NULL, qldiv (:) _NULL, qidiv (:) _NULL
     real, _ALLOCATABLE :: thcflx(:) _NULL, qctflx(:) _NULL
     real, _ALLOCATABLE :: umflx (:) _NULL, vmflx (:) _NULL, qvflx (:) _NULL
     real, _ALLOCATABLE :: qlflx (:) _NULL, qiflx (:) _NULL, qaflx (:) _NULL
     real, _ALLOCATABLE :: qnflx (:) _NULL, qnten (:) _NULL, pflx  (:) _NULL
     real, _ALLOCATABLE :: hlflx (:) _NULL, hlten (:) _NULL
     real, _ALLOCATABLE :: tevap (:) _NULL, qevap (:) _NULL
     real, _ALLOCATABLE :: qldet (:) _NULL, qidet (:) _NULL, qadet (:) _NULL
     real, _ALLOCATABLE :: qndet (:) _NULL
!++++yim
     real, _ALLOCATABLE :: trflx(:,:) _NULL,trten (:,:) _NULL, trwet(:,:) _NULL
  end type ctend

contains

!#####################################################################
!#####################################################################

!++++yim
  subroutine cp_init_k(kd, num_tracers, cp)
!++++yim    
    integer, intent(in) :: kd, num_tracers
    type(cplume), intent(inout) :: cp
    
    allocate ( cp%hlu   (0:kd)); cp%hlu   =0.;
    allocate ( cp%thcu  (0:kd)); cp%thcu  =0.;
    allocate ( cp%qctu  (0:kd)); cp%qctu  =0.;
    allocate ( cp%uu    (0:kd)); cp%uu    =0.;
    allocate ( cp%vu    (0:kd)); cp%vu    =0.;
    allocate ( cp%qlu   (0:kd)); cp%qlu   =0.;
    allocate ( cp%qiu   (0:kd)); cp%qiu   =0.;
    allocate ( cp%clu   (0:kd)); cp%clu   =0.;
    allocate ( cp%ciu   (0:kd)); cp%ciu   =0.;
    allocate ( cp%buo   (0:kd)); cp%buo   =0.;
    allocate ( cp%t     (0:kd)); cp%t     =0.;
    allocate ( cp%crate (0:kd)); cp%crate =0.;
    allocate ( cp%prate (0:kd)); cp%prate =0.;
    allocate ( cp%qnu   (0:kd)); cp%qnu   =0.;
    allocate ( cp%pptn  (1:kd)); cp%pptn  =0.;
    allocate ( cp%pptr  (1:kd)); cp%pptr  =0.;
    allocate ( cp%ppti  (1:kd)); cp%ppti  =0.;
    allocate ( cp%wu    (0:kd)); cp%wu    =0.;
    allocate ( cp%umf   (0:kd)); cp%umf   =0.;
    allocate ( cp%emf   (0:kd)); cp%emf   =0.;
    allocate ( cp%thvu  (1:kd)); cp%thvu  =0.;
    allocate ( cp%rei   (1:kd)); cp%rei   =0.;
    allocate ( cp%fer   (1:kd)); cp%fer   =0.;
    allocate ( cp%fdr   (1:kd)); cp%fdr   =0.;
    allocate ( cp%dp    (1:kd)); cp%dp    =0.;
    allocate ( cp%hl    (1:kd)); cp%hl    =0.;
    allocate ( cp%thc   (1:kd)); cp%thc   =0.;
    allocate ( cp%qct   (1:kd)); cp%qct   =0.;
    allocate ( cp%u     (1:kd)); cp%u     =0.;
    allocate ( cp%v     (1:kd)); cp%v     =0.;
    allocate ( cp%ql    (1:kd)); cp%ql    =0.;
    allocate ( cp%qi    (1:kd)); cp%qi    =0.;
    allocate ( cp%qa    (1:kd)); cp%qa    =0.;
    allocate ( cp%qn    (1:kd)); cp%qn    =0.;
    allocate ( cp%p     (1:kd)); cp%p     =0.;
    allocate ( cp%ps    (0:kd)); cp%ps    =0.;
    allocate ( cp%z     (1:kd)); cp%z     =0.;
    allocate ( cp%zs    (0:kd)); cp%zs    =0.;
    allocate ( cp%ufrc  (1:kd)); cp%ufrc  =0.;
    allocate ( cp%thvbot(1:kd)); cp%thvbot=0.;
    allocate ( cp%thvtop(1:kd)); cp%thvtop=0.;
    allocate ( cp%fdrsat(1:kd)); cp%fdrsat=0.;
    allocate ( cp%peff  (1:kd)); cp%peff  =0.;
!++++yim
    allocate ( cp%tr(1:kd,1:num_tracers)); cp%tr=0.;
    allocate ( cp%tru(0:kd,1:num_tracers)); cp%tru=0.;
    allocate ( cp%tru_dwet(0:kd,1:num_tracers)); cp%tru_dwet=0.;
  end subroutine cp_init_k

!#####################################################################
!#####################################################################

  subroutine cp_end_k (cp)
    type(cplume), intent(inout) :: cp
    deallocate (cp%thcu, cp%qctu, cp%uu, cp%vu, cp%qlu, cp%qiu,  &
                cp%pptr, cp%ppti, cp%wu, cp%umf, cp%emf, cp%thvu,  &
                cp%rei, cp%fer, cp%fdr, cp%dp, cp%thc, cp%qct, cp%u, &
                cp%v, cp%p, cp%ps, cp%ufrc, cp%thvbot, cp%thvtop, &
                cp%fdrsat, cp%peff, cp%qnu, cp%ql, cp%qi, cp%qa, cp%qn, &
                cp%pptn, cp%z, cp%zs, cp%hl, cp%hlu, cp%clu, cp%ciu, &
                cp%buo, cp%t, cp%crate, cp%prate, cp%tr, cp%tru, &
                cp%tru_dwet)
  end subroutine cp_end_k

!#####################################################################
!#####################################################################

  subroutine cp_clear_k (cp)
    type(cplume), intent(inout) :: cp
    cp%thcu  =0.;    cp%qctu  =0.;    cp%uu    =0.;    cp%vu    =0.;
    cp%qlu   =0.;    cp%qiu   =0.;    cp%qnu   =0.;    cp%pptr  =0.;
    cp%ppti  =0.;    cp%wu    =0.;    cp%umf   =0.;    cp%emf   =0.;
    cp%thvu  =0.;    cp%rei   =0.;    cp%fer   =0.;    cp%fdr   =0.;
    cp%dp    =0.;    cp%thc   =0.;    cp%qct   =0.;    cp%u     =0.;
    cp%v     =0.;    cp%ql    =0.;    cp%qi    =0.;    cp%qa    =0.; 
    cp%qn    =0.;    cp%p     =0.;    cp%ps    =0.;
    cp%ufrc  =0.;    cp%thvbot=0.;    cp%thvtop=0.;    cp%hlu   =0.;
    cp%fdrsat=0.;    cp%z     =0.;    cp%zs    =0.;    cp%hl    =0.;
    cp%clu   =0.;    cp%ciu   =0.;    cp%buo   =0.;    cp%t     =0.;
    cp%crate =0.;    cp%prate =0.;    cp%peff  =0.;
!++++yim
    cp%pptn  =0.;    cp%tr    =0.;    cp%tru   =0.;    cp%tru_dwet = 0.
  end subroutine cp_clear_k

!#####################################################################
!#####################################################################

!++++yim
  subroutine ct_init_k (kd, num_tracers, ct)
!++++yim
    integer, intent(in) :: kd, num_tracers
    type(ctend), intent(inout) :: ct
    allocate ( ct%uten  (1:kd)); ct%uten  =0.;
    allocate ( ct%vten  (1:kd)); ct%vten  =0.;
    allocate ( ct%tten  (1:kd)); ct%tten  =0.;
    allocate ( ct%qvten (1:kd)); ct%qvten =0.;
    allocate ( ct%qlten (1:kd)); ct%qlten =0.;
    allocate ( ct%qiten (1:kd)); ct%qiten =0.;
    allocate ( ct%qaten (1:kd)); ct%qaten =0.;
    allocate ( ct%qnten (1:kd)); ct%qnten =0.;
    allocate ( ct%qldet (1:kd)); ct%qldet =0.;
    allocate ( ct%qidet (1:kd)); ct%qidet =0.;
    allocate ( ct%qadet (1:kd)); ct%qadet =0.;
    allocate ( ct%qndet (1:kd)); ct%qndet =0.;
    allocate ( ct%hlten (1:kd)); ct%hlten =0.;
    allocate ( ct%thcten(1:kd)); ct%thcten=0.;
    allocate ( ct%qctten(1:kd)); ct%qctten=0.;
    allocate ( ct%qvdiv (1:kd)); ct%qvdiv =0.;
    allocate ( ct%qldiv (1:kd)); ct%qldiv =0.;
    allocate ( ct%qidiv (1:kd)); ct%qidiv =0.;
    allocate ( ct%hlflx (0:kd)); ct%hlflx =0.;
    allocate ( ct%thcflx(0:kd)); ct%thcflx=0.;
    allocate ( ct%qctflx(0:kd)); ct%qctflx=0.;
    allocate ( ct%qvflx (0:kd)); ct%qvflx =0.;
    allocate ( ct%qlflx (0:kd)); ct%qlflx =0.;
    allocate ( ct%qiflx (0:kd)); ct%qiflx =0.;
    allocate ( ct%qaflx (0:kd)); ct%qaflx =0.;
    allocate ( ct%qnflx (0:kd)); ct%qnflx =0.;
    allocate ( ct%umflx (0:kd)); ct%umflx =0.;
    allocate ( ct%vmflx (0:kd)); ct%vmflx =0.;
    allocate ( ct%pflx  (1:kd)); ct%pflx  =0.;
    allocate ( ct%tevap (1:kd)); ct%tevap =0.;
    allocate ( ct%qevap (1:kd)); ct%qevap =0.;
!++++yim
    allocate ( ct%trflx  (0:kd,1:num_tracers)); ct%trflx  =0.;
    allocate ( ct%trten  (1:kd,1:num_tracers)); ct%trten  =0.;
    allocate ( ct%trwet  (1:kd,1:num_tracers)); ct%trwet  =0.;
  end subroutine ct_init_k

!#####################################################################
!#####################################################################

  subroutine ct_end_k (ct)
    type(ctend), intent(inout) :: ct
    deallocate (ct%uten, ct%vten, ct%tten, ct%qvten, ct%qlten,  &
                ct%qiten, ct%qaten, ct%qnten, ct%hlten, ct%thcten, &
                ct%qldet, ct%qidet, ct%qadet, ct%qndet,            &
                ct%qctten, ct%qvdiv, ct%qldiv, ct%qidiv, ct%hlflx, &
                ct%thcflx, ct%qctflx, ct%qvflx, ct%qlflx, ct%qiflx, &
                ct%qaflx, ct%qnflx, ct%umflx, ct%vmflx, ct%pflx, &
                ct%tevap, ct%qevap, ct%trflx, ct%trten, ct%trwet)
  end subroutine ct_end_k

!#####################################################################
!#####################################################################

  subroutine ct_clear_k(ct)
    type(ctend), intent(inout) :: ct
    
    ct%uten  =0.;    ct%vten  =0.;    ct%tten  =0.;
    ct%qvten =0.;    ct%qlten =0.;    ct%qiten =0.;
    ct%qaten =0.;    ct%qnten =0.;    ct%thcten=0.;
    ct%qctten=0.;    
    ct%qldet =0.;    ct%qidet =0.;    ct%qadet =0.;
    ct%qndet =0.;    
    ct%qvdiv =0.;    ct%qldiv =0.;    ct%qidiv =0.;
    ct%thcflx=0.;    ct%qctflx=0.;    ct%qvflx =0.;
    ct%qlflx =0.;    ct%qiflx =0.;    ct%qaflx =0.;    ct%qnflx =0.;
    ct%umflx =0.;    ct%vmflx =0.;    ct%pflx  =0.;
    ct%hlflx =0.;    ct%hlten =0.;
    ct%denth =0.;    ct%rain  =0.;    ct%snow  =0.;    
    ct%tevap =0.;    ct%qevap =0.;
    ct%dting =0.;
!++++yim
    ct%trflx =0.;    ct%trten =0.;    ct%trwet =0.
  end subroutine ct_clear_k

!#####################################################################
!#####################################################################

  subroutine mixing_k (cpn, z0, p0, hl0, thc0, qct0, hlu, thcu, qctu, &
                       wu, scaleh, rei, fer, fdr, fdrsat, rho0j, rkm, &
                       Uw_p, umfkm1, dp, dt)       
  
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    real,           intent(in)    :: z0, p0, hl0, thc0, qct0 !envirn. properties at level k
    real,           intent(in)    :: hlu, thcu, qctu, wu !updraft properties at level k-1
    real,           intent(in)    :: scaleh, rkm
    real,           intent(in)    :: umfkm1, dp, dt
    real,           intent(inout) :: rei, fer, fdr, fdrsat, rho0j
    
    real    :: excessu, excess0, hlfs, qtfs, thvfs,  &
               xbuo0, xsat, xs, xs1, xs2
    real    :: thj, qvj, qlj, qij, qse, thvj, thv0j
    real    :: aquad, bquad, cquad, ee2, ud2
    real    :: emmax

!-----A.  Entrainment and Detrainment
!     first, to determine fraction (xsat) of mixture that is to be detrained out 
!     of clouds, i.e., the mixture with negative buoyancy. We consider a thin 
!     layer between two interfaces, so using mid-point value to represent the 
!     mean value of the layer. The properties of updraft at midpoint is assumed
!     to be undiluted from the lower interface.  

!-----calculate fraction of mixture that is just saturated

    excessu = qctu - qsat_k((hlu-Uw_p%grav*z0)/Uw_p%cp_air, p0,Uw_p) 
              excessu = max(excessu,0.0)
    excess0 = qct0 - qsat_k((hl0-Uw_p%grav*z0)/Uw_p%cp_air, p0, Uw_p) 

    if(excessu*excess0.le.0)then
       xsat = -excessu/(excess0-excessu)
    else
       xsat = 1.0
    endif
    hlfs =(1.-xsat)*hlu  + xsat*hl0
    qtfs =(1.-xsat)*qctu + xsat*qct0
    call findt_k (z0,p0,hlfs,qtfs, thj, qvj, qlj, qij, qse, thvfs, &
                  cpn%do_ice, Uw_p)
    call findt_k (z0,p0,hlu, qctu, thj, qvj, qlj, qij, qse, thvj, &
                  cpn%do_ice, Uw_p)   
    call findt_k (z0,p0,hl0, qct0, thj, qvj, qlj, qij, qse, thv0j, &
                  cpn%do_ice, Uw_p)   
    rho0j = p0/(Uw_p%rdgas*thv0j*exn_k(p0,Uw_p))

!-----calculate fraction of mixture with zero buoyancy
    if(thvfs.ge.thv0j) then
       xbuo0=xsat
    else if(thvj.le.thv0j) then
       xbuo0=0.
    else
       xbuo0=xsat*(thvj-thv0j)/(thvj-thvfs)
    endif

    !-----calculate fraction of mixture with negative buoyancy but can 
    !     penetrate a critical distance lc=rle*scaleh
    if(thvfs.ge.thv0j.or.xsat.le.0.05) then
       xs=xsat !mixture has to be saturated
    else
       aquad = wu**2.
       bquad = -(2.*wu**2. + 2.*cpn%rbuoy*Uw_p%grav*cpn%rle*scaleh*&
                                              (thvj-thvfs)/thv0j/xsat)
       cquad = wu**2. - 2.*cpn%rbuoy*Uw_p%grav*cpn%rle*scaleh* &
                                                        (1-thvj/thv0j)
       call roots(aquad,bquad,cquad,xs1,xs2)
       xs=min(xs1,xs2)
    endif
    xs=min(xs,xsat)
    xs=max(xbuo0,xs)
    xs=min(1.0,xs)
    
    ee2     = xs**2.
    ud2     = 1. - 2.*xs + xs**2.
    rei     = rkm/scaleh/Uw_p%grav/rho0j  !make entrainment rate in unit of 1/Pa
    fer     = rei * ee2
    fdr     = rei * ud2

 if(cpn%do_emmax) then
    emmax = cpn%emfrac_max * dp / dt / Uw_p%GRAV
    if ((fer-fdr)*dp*umfkm1 .gt. emmax) then
       rei = emmax / dp / umfkm1 / (ee2-ud2)
       fer = rei * ee2
       fdr = rei * ud2
    end if
 end if

    fdrsat  = rei * (ud2-(1. - 2.*xsat + xsat**2.))

    if (fdr.ne.0) then
       fdrsat  = min(fdrsat/fdr, 1.)
    else
       fdrsat  = 0.
    end if
    fdrsat  = max(fdrsat, cpn%frac_drs)

  end subroutine mixing_k

!#####################################################################
!#####################################################################

  subroutine cumulus_plume_k (cpn, sd, ac, cp, rkm, cbmf, wrel, scaleh,&
                              Uw_p, ier, ermesg)       
  

    type(cpnlist),      intent(in)    :: cpn
    type(uw_params),    intent(inout) :: Uw_p
    type(sounding),     intent(in)    :: sd
    type(adicloud),     intent(in)    :: ac
    real,               intent(in)    :: rkm, cbmf, wrel, scaleh
    type(cplume),       intent(inout) :: cp
    integer,            intent(out)   :: ier
    character(len=*),   intent(out)   :: ermesg

    real, dimension(4)            :: totalmass
    integer                       :: tym
    real                          :: drop
   
    integer :: k, klm, km1, krel, let, ltop
    real    :: thv0rel, wtw, wtwtop
    real    :: thj, qvj, qlj, qij, qse, rhos0j, rho0j
    real    :: bogtop, bogbot, delbog, drage, expfac
    real    :: zrel, prel, nu, leff, qrj, qsj, temp
    real    :: qctu_new, hlu_new, qlu_new, qiu_new, clu_new, ciu_new
    real    :: scaleh1
    real    :: qct_env_k, hl_env_k
    real    :: t_mid, tv_mid, air_density, total_condensate,   &
               total_rain, total_snow, delta_tracer, delta_qn, wrel2, gamma
    real    :: cflim
    integer :: n
    logical :: kbelowlet

    ier = 0
    ermesg = ' '
    tym = size(totalmass,1)
    call cp_clear_k (cp)
    cp%p=sd%p; cp%ps=sd%ps; cp%dp=sd%dp; cp%u=sd%u; cp%v=sd%v;
    cp%hl=sd%hl; cp%thc=sd%thc; cp%qct=sd%qct; 
    cp%ql=sd%ql; cp%qi=sd%qi; cp%qa=sd%qa; cp%qn=sd%qn;
!++++yim
    cp%tr=sd%tr;
    cp%thvbot=sd%thvbot; cp%thvtop=sd%thvtop;
    cp%z=sd%z; cp%zs=sd%zs;

    wtw  = wrel*wrel
    wtwtop =  cpn%wtwmin_ratio * wtw

    delta_qn =0.

    !determine release height and parcel properties (krel, prel, thv0rel, thvurel)
    if(ac % plcl .gt. sd % pinv)then
       krel    = sd % kinv
       prel    = sd % pinv
       zrel    = sd % zinv
       thv0rel = sd % thvinv
    else
       krel    = ac % klcl
       prel    = ac % plcl
       zrel    = ac % zlcl
       thv0rel = ac % thv0lcl
    endif

    cp%krel=krel
    cp%prel=prel
    cp%zrel=zrel

    !(krel-1) represents the bottom of the updraft
    call findt_k (zrel,prel,ac%hlsrc,ac%qctsrc, thj, qvj, qlj,  &
                  qij, qse, cp%thvu(krel-1), cpn%do_ice, Uw_p)   
    cp%ps   (krel-1) = max(prel, cp%ps(krel)+1.) !prel
    cp%hlu  (krel-1) = ac % hlsrc
    cp%thcu (krel-1) = ac % thcsrc
    cp%qctu (krel-1) = ac % qctsrc
    cp%uu   (krel-1) = ac % usrc
    cp%vu   (krel-1) = ac % vsrc
    cp%umf  (krel-1) = cbmf*sd%rho(krel-1)/ac%rho0lcl
    cp%wu   (krel-1) = wrel
    cp%ufrc (krel-1) = cp%umf(krel-1)/(sd%rho(krel-1)*cp%wu(krel-1))
    cp%tru  (krel-1,:) = cp%tr(1,:)
    !==================================================
    !     yim's CONVECTIVE NUCLEATION
    !==================================================
    totalmass(1)=     sd%am1(krel-1); !totalmass(1)=aerol;
    totalmass(2)=     sd%am2(krel-1); !totalmass(2)=0.;
    totalmass(3)=     sd%am3(krel-1); !totalmass(3)=0.;
    totalmass(4)=     sd%am4(krel-1); !totalmass(4)=0.;
    if (SUM(totalmass(:)) /= 0.0 .and. cpn%use_online_aerosol) then
      wrel2 = wrel*cpn%wrel_min
      call aer_ccn_act_k(thj*exn_k(prel,Uw_p), prel, wrel2, totalmass, &
                         tym, drop, ier, ermesg)
      if (ier /= 0) then
        return
      endif
      cp%qnu(krel-1) = drop * 1.0e6 / (prel /    &
                      (Uw_p%rdgas*cp%thvu(krel-1)*exn_k(prel,Uw_p)))
    else
      drop = 0.
      cp%qnu(krel-1) = 0.0
    endif


    !(krel) represents the first partial updraft layer
    cp%z      (krel) = (cp%zs(krel-1) + cp%zs(krel))*0.5
    cp%p      (krel) = (cp%ps(krel-1) + cp%ps(krel))*0.5
    cp%dp     (krel) =  cp%ps(krel-1) - cp%ps(krel)   
    cp%thvbot (krel) = thv0rel
    if(krel.ne. sd % kinv) then
       cp%hl  (krel) = cp%hl (krel)+sd%sshl (krel)*  &
                                                (cp%p(krel)-sd%p(krel))
       cp%thc (krel) = cp%thc(krel)+sd%ssthc(krel)*   &
                                                (cp%p(krel)-sd%p(krel))
       cp%qct (krel) = cp%qct(krel)+sd%ssqct(krel)* &
                                               (cp%p(krel)-sd%p(krel))
       call findt_k (cp%z(krel),cp%p(krel),cp%hl(krel), cp%qct(krel), &
                     thj, qvj, qlj, qij, qse, cp%thvu(krel),  &
                     cpn%do_ice, Uw_p)
    endif

    !Compute updraft properties above the LCL
    kbelowlet=.true.
    let=krel
    klm=sd%ktopconv-1
    do k=krel,klm
       km1=k-1
       hl_env_k  = cp%hl(k)
       qct_env_k = cp%qct(k)

       !Calculation entrainment and detrainment rate
       if (cpn%mixing_assumption.eq.0) then
          scaleh1 = scaleh
          call mixing_k (cpn, cp%z(k), cp%p(k), hl_env_k, cp%thc(k), &
                         qct_env_k, cp%hlu(km1), cp%thcu(km1),  &
                         cp%qctu(km1), cp%wu(km1), scaleh1, cp%rei(k), &
                         cp%fer(k), cp%fdr(k), cp%fdrsat(k), rho0j, &
                         rkm, Uw_p, cp%umf(km1), cp%dp(k), sd%delt)      
       else if (cpn%mixing_assumption.eq.1) then
          temp         = sqrt(cp%ufrc(km1)) !scaleh for fixed length scale
          rho0j        = sd%rho(k)
          cp%rei(k)    = rkm/temp/Uw_p%grav/rho0j
          cp%fer(k)    = cp%rei(k)
          cp%fdr(k)    = 0.
          cp%fdrsat(k) = 0.
       else if (cpn%mixing_assumption.eq.2) then
          gamma=0.0065
          scaleh1 = cpn%t00/gamma*(1.-(cp%p(k)/100000.)**(Uw_p%rdgas*gamma/Uw_p%grav))
          scaleh1 = max (1000., scaleh1-sd%zs(0))
          call mixing_k (cpn, cp%z(k), cp%p(k), hl_env_k, cp%thc(k), &
                         qct_env_k, cp%hlu(km1), cp%thcu(km1),  &
                         cp%qctu(km1), cp%wu(km1), scaleh1, cp%rei(k), &
                         cp%fer(k), cp%fdr(k), cp%fdrsat(k), rho0j, &
                         rkm, Uw_p, cp%umf(km1), cp%dp(k), sd%delt)
       else
          scaleh1 = max (1000., cp%z(k)-sd%zs(0))
          call mixing_k (cpn, cp%z(k), cp%p(k), hl_env_k, cp%thc(k), &
                         qct_env_k, cp%hlu(km1), cp%thcu(km1),      &
                         cp%qctu(km1), cp%wu(km1), scaleh1, cp%rei(k), &
                         cp%fer(k), cp%fdr(k), cp%fdrsat(k), rho0j, &
                         rkm, Uw_p, cp%umf(km1), cp%dp(k), sd%delt)
       end if

       !Calculate the mass flux
       cp%umf(k)=cp%umf(km1)*exp(cp%dp(k)*(cp%fer(k)-cp%fdr(k)))
       cp%emf(k)=0.0

       !Thermodynamics for the dilute plume
       cp%hlu (k)=hl_env_k -(hl_env_k -cp%hlu (km1))*  &
                                            exp(-cp%fer(k)*cp%dp(k))
       cp%qctu(k)=qct_env_k-(qct_env_k-cp%qctu(km1))*  &
                                            exp(-cp%fer(k)*cp%dp(k))
       cp%qnu (k)=cp%qn (k)-(cp%qn (k)-cp%qnu (km1))*  &
                                            exp(-cp%fer(k)*cp%dp(k))
       cp%tru (k,:)=cp%tr (k,:)-(cp%tr (k,:)-cp%tru (km1,:))*  &
                                            exp(-cp%fer(k)*cp%dp(k))
       if(cp%fer(k)*cp%dp(k).lt.1.e-4)then
          cp%uu(k)=cp%uu(km1) - sd%dudp(k)*cp%dp(k)
          cp%vu(k)=cp%vu(km1) - sd%dvdp(k)*cp%dp(k)
       else
          cp%uu(k)=cp%u(k)-cpn%bigc*sd%dudp(k)/cp%fer(k)-  &
                   exp(-cp%fer(k)*cp%dp(k))* &
                  (cp%u(k)-cpn%bigc*sd%dudp(k)/cp%fer(k) - cp%uu(km1))
          cp%vu(k)=cp%v(k)-cpn%bigc*sd%dvdp(k)/cp%fer(k)-  &
                   exp(-cp%fer(k)*cp%dp(k))* &
                  (cp%v(k)-cpn%bigc*sd%dvdp(k)/cp%fer(k) - cp%vu(km1))
       endif
       if (cpn%mp_choice.eq.0) then
          call micro_donner_k (cpn, cp%zs(k), cp%ps(k), cp%hlu(k), &
                               cp%qctu(k), cp%zs(km1), cp%qlu(km1), &
                               cp%clu(km1), cp%qiu(km1), cp%ciu(km1), &
                               cp%wu(km1), cp%crate(k), cp%prate(k),   &
                               qrj, qsj, qlu_new, clu_new, qiu_new, &
                               ciu_new, hlu_new, qctu_new, temp, &
                               cpn%do_ice, Uw_p)
       else if (cpn%mp_choice.eq.1) then
          call precipitation_k (cp%zs(k), cp%ps(k), cp%hlu(k), &
                                cp%qctu(k), cp%qnu(k), cpn, qrj, qsj, &
                                hlu_new, qctu_new, qlu_new, qiu_new, &
                                clu_new, ciu_new, temp, cpn%do_ice, &
                                delta_qn, Uw_p, kbelowlet)        
       else if (cpn%mp_choice.eq.2) then
          call precip_new_k    (cp%zs(k), cp%ps(k), cp%hlu(k), &
                                cp%qctu(k), cp%qnu(k), cpn, qrj, qsj, &
                                hlu_new, qctu_new, qlu_new, qiu_new, &
                                clu_new, ciu_new, temp, cpn%do_ice, &
                                delta_qn, Uw_p, kbelowlet, sd%land, sd%delt, cp%wu(km1))
       else if (cpn%mp_choice.eq.3) then
          call precip3_k       (cp%zs(k), cp%ps(k), cp%hlu(k), &
                                cp%qctu(k), cp%qnu(k), cpn, qrj, qsj, &
                                hlu_new, qctu_new, qlu_new, qiu_new, &
                                clu_new, ciu_new, temp, cpn%do_ice, &
                                delta_qn, Uw_p, kbelowlet)        
       end if

       cp%qctu(k)=qctu_new
       cp%hlu (k)=hlu_new
       cp%qlu (k)=qlu_new
       cp%qiu (k)=qiu_new
       cp%clu (k)=clu_new
       cp%ciu (k)=ciu_new
       cp%peff(k)=(qrj+qsj)/max(qlu_new+qiu_new+qrj+qsj,1.e-28);

       cp%thvu(k)=temp/exn_k(cp%ps(k),Uw_p)*(1.+Uw_p%zvir*(cp%qctu(k)-cp%qlu(k)-cp%qiu(k))-cp%qlu(k)-cp%qiu(k))
       cp%buo (k)=cp%thvu(k)-cp%thvtop(k)
       cp%t   (k)=temp
       nu = max(min((268. - temp)/20.,1.0),0.0)
       leff = (1-nu)*Uw_p%HLv + nu*Uw_p%HLs
       cp%thcu(k)=temp/exn_k(cp%ps(k),Uw_p)

       !Calculate vertical velocity
!!$       bogbot = (cp%thvu(km1)/cp%thvbot(k) - 1.)
!!$       if(bogbot.gt.0.)then
!!$          bogbot =  bogbot /cpn%rbuoy
!!$       else
!!$          bogbot =  bogbot*cpn%rbuoy
!!$       endif
!!$       bogtop = (cp%thvu(k)/cp%thvtop(k) - 1.)
!!$       if(bogtop.gt.0.)then
!!$          bogtop =  bogtop /cpn%rbuoy
!!$       else
!!$          bogtop =  bogtop*cpn%rbuoy
!!$       endif

       bogbot = (cp%thvu(km1)/cp%thvbot(k) - 1.)
       bogbot =  bogbot*cpn%rbuoy
       bogtop = (cp%thvu(k)/cp%thvtop(k) - 1.)
       bogtop =  bogtop*cpn%rbuoy

       if(bogbot.gt.0.and.bogtop.gt.0) then
          let = k
          kbelowlet = .true.
       else
          kbelowlet = .false.
       end if

       delbog = bogtop - bogbot
       drage = cp%fer(k) * ( 1. + cpn%rdrag )
       expfac = exp(-2.* drage * cp%dp(k))
       if(drage * cp%dp(k).gt.1.e-3) then
          wtw = wtw*expfac + (delbog + (1.-expfac) *               &
               (bogbot+delbog/(-2.*drage*cp%dp(k))))/(rho0j*drage)
       else
          wtw = wtw + cp%dp(k) * (bogbot+bogtop)/rho0j
       endif
       wtwtop = max( cpn%wtwmin_ratio * wtw, wtwtop )

       if (cpn%do_forcedlifting) then
          if (wtw.le.0. .and. k <= ac%klfc) then
             wtw=wrel*wrel
!         else if (wtw.le.0.) then
           else if (wtw.le.wtwtop) then
             exit
          end if
       else
!         if(wtw.le.0.) exit
          if(wtw.le.wtwtop) exit
       end if

       cp%wu(k) = sqrt(wtw)
       if(cp%wu(k).gt.100.)then
          print *, 'Very big wu in UW-ShCu',bogbot,bogtop,expfac,cp%fer(k)
          return
       endif
       
       rhos0j     = cp%ps(k)/(Uw_p%rdgas*0.5*(cp%thvbot(k+1)+  &
                                    cp%thvtop(k))*exn_k(cp%ps(k),Uw_p))
       cp%ufrc(k) = cp%umf(k)/(rhos0j*max(cp%wu(k), cpn%wmin))
       cflim = MIN(cpn%rmaxfrac, cp%maxcldfrac)
       if(cp%ufrc(k).gt.cflim        )then
          cp%ufrc(k) = cflim
          cp%umf (k) = cflim         * rhos0j * cp%wu(k)
          cp%fdr (k) = cp%fer(k)-log(cp%umf(k)/cp%umf(km1))/cp%dp(k)
       endif
       cp%pptr(k) = qrj*cp%umf(k)
       cp%ppti(k) = qsj*cp%umf(k)
       cp%pptn(k) = delta_qn*cp%umf(k)
!temperature (at full level)    
       t_mid = 0.5 * (cp%t(k) + cp%t(km1))
! virtual temperature (at full level)
       tv_mid = 0.5 * ( cp%t(k) * (1+Uw_p%zvir*(cp%qctu(k)-  &
                                               cp%qlu(k)-cp%qiu(k))) &
               + cp%t(km1) * (1+Uw_p%zvir*(cp%qctu(km1)-   &
                                             cp%qlu(km1)-cp%qiu(km1))) )
! air density (kg/m3)
       air_density = 0.5*(cp%ps(km1)+cp%ps(k)) / (Uw_p%rdgas*tv_mid)
       total_condensate = cp%qlu(k) + cp%qiu(k) + qrj + qsj ! kg/kg
       total_rain = qrj * air_density ! kg/m3
       total_snow = qsj * air_density ! kg/m3
       if (total_rain+total_snow > 0.) then
          do n=1,size(cp%tru,2)
             if (cpn%wetdep(n)%Lwetdep) then
                call wet_deposition_0D( cpn%wetdep(n)%Henry_constant, &
                                        cpn%wetdep(n)%Henry_variable, &
                                        cpn%wetdep(n)%frac_in_cloud, &
                                        cpn%wetdep(n)%alpha_r, &
                                        cpn%wetdep(n)%alpha_s, &
                                        t_mid, cp%ps(km1), cp%ps(k), &
                                        air_density, &
                                        total_condensate, total_rain, total_snow, &
                                        cp%tru(k,n), &
                                        cpn%wetdep(n)%Lgas, cpn%wetdep(n)%Laerosol, cpn%wetdep(n)%Lice, &
                                        delta_tracer )
                cp%tru_dwet(k,n) = -delta_tracer ! tracer source from wet deposition (negative=sink)
                cp%tru(k,n) = cp%tru(k,n) - delta_tracer ! adjust in-cloud concentration for wet dep
             end if
       end do
       end if
       
    enddo !End of Updraft Loop

    ltop = k 
    cp%umf (ltop) = 0.
    cp%pptr(ltop) = 0.
    cp%ppti(ltop) = 0.
    cp%pptn(ltop) = 0.
    cp%peff(ltop) = 0.

    cp%let    = let
    cp%ltop   = ltop
    cp%cldhgt = sd%z(ltop)-ac%zlcl
    !Restriction of convection too deep or too shallow
    if(cp%cldhgt.ge.cpn%cldhgt_max .or. ltop.lt.krel+2 .or.   &
                                                   let.le.krel+1) then
       return
    endif

    !convective scale height
    cp % cush=sd%z(ltop) - sd%zs(0)

    if (cpn%do_ppen) then !Calculate penetrative entrainment
       call penetrative_mixing_k(cpn, sd, Uw_p, cp) 
    else
       cp%fdr(ltop) = 1./sd%dp(ltop)
    end if

    if (cpn%mixing_assumption.eq.1) then
       cp%fdr(ltop)    = 1./sd%dp(ltop)
       cp%fdrsat(ltop) = 1.
    end if

  end subroutine cumulus_plume_k


!++++yim
  subroutine precipitation_k (zs, ps, hlu, qctu, qnu, cpn, qrj, qsj, &
                              hlu_new, qctu_new, qlu_new, qiu_new, &
                              clu_new, ciu_new, temp, doice, delta_qn, &
                              Uw_p, kbelowlet)       
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    real,           intent(in)    :: zs, ps, hlu, qctu
    real,           intent(inout)    :: qnu, delta_qn
    real,           intent(inout) :: qrj, qsj, hlu_new, qctu_new,  &
                                     qlu_new, qiu_new, clu_new,  &
                                     ciu_new, temp
    logical,        intent(in)    :: doice, kbelowlet

    real    :: thj, qvj, qlj, qij, qse, thvj, nu, exnj,  &
               auto_th, leff, pcp, qctmp, deltaqc, auto_th2

    !Precip at the flux level
    call findt_k (zs,ps,hlu,qctu,thj,qvj,qlj,qij,qse,thvj,doice, &
                  Uw_p)  
    exnj=exn_k(ps,Uw_p)
    temp=thj*exnj-273.15
    if (temp.ge.0.0) then
       auto_th=cpn%auto_th0
    else
       auto_th=cpn%auto_th0*(1.0-temp/cpn%tcrit)
    end if
    auto_th=max(auto_th,0.0)

    if (.not.kbelowlet) auto_th=1.e10

    temp=temp+273.15

  if (.not.cpn%do_auto_aero) then
    qctmp   = qlj+qij;
    if (cpn%do_pdfpcp) then
       deltaqc = min(cpn%deltaqc0, auto_th)
       if (qctmp .lt. (auto_th - deltaqc)) then
          pcp = 0.
       else if (qctmp .lt. (auto_th + deltaqc)) then
          pcp = (qctmp + deltaqc - auto_th)**2./(4.*deltaqc)
       else
          pcp = qctmp-auto_th
       end if
    else
       pcp = max(qctmp-auto_th,0.)
    end if
    qctmp = 1./max(qctmp,1.e-28)
    qrj = pcp*qlj*qctmp
    qsj = pcp*qij*qctmp
    nu  = max(min((268. - temp)/20.,1.0),0.0)
 
    if (qlj.le.0) then
       delta_qn = -qnu
       qnu = 0
    else
       delta_qn = qnu * qrj * qctmp
       qnu      = qnu - delta_qn
    end if
 else
      auto_th2 = max (4.18667e-15*qnu*cpn%rad_crit**3., 0.0)
      if((qlj+qij).gt.auto_th)then
        qsj = (qlj+qij-auto_th)*qij/(qlj+qij)
        nu = max(min((268. - temp)/20.,1.0),0.0)
      else
        qsj = 0.0
        nu  = 0.0
      endif
 
      if(qlj .gt. auto_th2)then
        qrj = qlj-auto_th2
        nu = max(min((268. - temp)/20.,1.0),0.0)
!++++yim in-cloud removal of dropelts
        delta_qn = qnu
        if (qlj .gt. 0.) then
          qnu = qnu*auto_th2/qlj
        else
          qnu = 0.
        end if
        delta_qn = delta_qn - qnu
      else
        qrj = 0.0
        nu  = 0.0
        delta_qn = 0.
      endif
 end if

    leff     = (1-nu)*Uw_p%HLv + nu*Uw_p%HLs
    qctu_new = qctu - (qrj + qsj)
    hlu_new  = hlu  + (qrj + qsj)*leff
    qlu_new  = qlj - qrj
    qiu_new  = qij - qsj
    clu_new  = qlu_new
    ciu_new  = qiu_new

    return
    
  end subroutine precipitation_k


  subroutine precip3_k (zs, ps, hlu, qctu, qnu, cpn, qrj, qsj, &
                              hlu_new, qctu_new, qlu_new, qiu_new, &
                              clu_new, ciu_new, temp, doice, delta_qn, &
                              Uw_p, kbelowlet)       
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    real,           intent(in)    :: zs, ps, hlu, qctu
    real,           intent(inout)    :: qnu, delta_qn
    real,           intent(inout) :: qrj, qsj, hlu_new, qctu_new,  &
                                     qlu_new, qiu_new, clu_new,  &
                                     ciu_new, temp
    logical,        intent(in)    :: doice, kbelowlet

    real    :: thj, qvj, qlj, qij, qse, thvj, nu, exnj,  &
               auto_th, leff, pcp, qctmp, deltaqc

    !Precip at the flux level
    call findt_k (zs,ps,hlu,qctu,thj,qvj,qlj,qij,qse,thvj,doice, &
                  Uw_p)  
    exnj=exn_k(ps,Uw_p)
    temp=thj*exnj-273.15
    if (temp.ge.0.0) then
       auto_th=cpn%auto_th0
    else
       auto_th=cpn%auto_th0*(1.0-temp/cpn%tcrit)
    end if
    auto_th=max(auto_th,0.0)

    if (.not.kbelowlet) auto_th=1.e10

    temp=temp+273.15

    qctmp   = qlj+qij; 
    if (cpn%do_pdfpcp) then
       deltaqc = min(cpn%deltaqc0, auto_th)
       if (qctmp .lt. (auto_th - deltaqc)) then
          pcp = 0.
       else if (qctmp .lt. (auto_th + deltaqc)) then
          pcp = (qctmp + deltaqc - auto_th)**2./(4.*deltaqc)
       else
          pcp = qctmp-auto_th
       end if
    else
       pcp = max(qctmp-auto_th,0.)
    end if
    pcp = qctmp*cpn%peff

    qctmp = 1./max(qctmp,1.e-28)
    qrj = pcp*qlj*qctmp
    qsj = pcp*qij*qctmp
    nu  = max(min((268. - temp)/20.,1.0),0.0)
    
    if (qlj.le.0) then
       delta_qn = -qnu
       qnu = 0
    else
       delta_qn = qnu * qrj * qctmp
       qnu      = qnu - delta_qn
    end if

    leff     = (1-nu)*Uw_p%HLv + nu*Uw_p%HLs
    qctu_new = qctu - (qrj + qsj)
    hlu_new  = hlu  + (qrj + qsj)*leff
    qlu_new  = qlj - qrj
    qiu_new  = qij - qsj
    clu_new  = qlu_new
    ciu_new  = qiu_new

    return
    
  end subroutine precip3_k



  subroutine precip_new_k    (zs, ps, hlu, qctu, qnu, cpn, qrj, qsj, &
                              hlu_new, qctu_new, qlu_new, qiu_new, &
                              clu_new, ciu_new, temp, doice, delta_qn, &
                              Uw_p, kbelowlet, land, delt, wu)
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    real,           intent(in)    :: zs, ps, hlu, qctu, land, delt, wu
    real,           intent(inout)    :: qnu, delta_qn
    real,           intent(inout) :: qrj, qsj, hlu_new, qctu_new,  &
                                     qlu_new, qiu_new, clu_new,  &
                                     ciu_new, temp
    logical,        intent(in)    :: doice, kbelowlet

    real    :: thj, qvj, qlj, qij, qse, thvj, nu, exnj,  &
               auto_th, leff, pcp, qctmp
    real    :: Nl, fliq, ql0, qi0

    !Precip at the flux level
    call findt_k (zs,ps,hlu,qctu,thj,qvj,qlj,qij,qse,thvj,doice, &
                  Uw_p)  
    exnj=exn_k(ps,Uw_p)
    temp=thj*exnj
    qctmp = qlj+qij; 
    if (qctmp > 0.0) then
       Nl = cpn%Nl_land*land + cpn%Nl_ocean*(1.-land) !Nl is mixing ratio=(1/m3)/(kg/m3)
       fliq = qlj/qctmp;

       !ql0=(4./3.*pi*1000) * (12.e-6)^3. * (100.e6) = 7.238e-4kg/kg
       ql0 =4188.79 * (cpn%r_thresh)**3. * Nl !4188.79=4/3*pi*1000; Nl=N/rho=N0/rho0;
       if (temp.ge.248.) then
          qi0 =cpn%qi_thresh
       else
          qi0 =cpn%qi_thresh*min(max(1.0+(248.-temp)/(cpn%tcrit+25.15),0.0),1.0)
       end if

       if (qij.eq.0.0) then
          auto_th=ql0
       else if (qlj.eq.0.0) then
          auto_th=qi0
       else
          auto_th=ql0*fliq+qi0*(1.-fliq)
       end if

       if (cpn%do_weffect) then
          auto_th=auto_th*(max(wu,1.))**cpn%weffect
       end if

       if (.not.kbelowlet) auto_th=1.e10

!       pcp = max(qctmp-auto_th,0.)*cpn%peff*delt/(1.+cpn%peff*delt)
!       pcp = max(qctmp-auto_th,0.)*cpn%peffdelt
       pcp = max(qctmp-auto_th,0.)

       qrj = pcp*fliq
       qsj = pcp*(1.-fliq)
       nu  = max(min((268. - temp)/20.,1.0),0.0)
    
       if (qlj.le.0) then
          delta_qn = -qnu
          qnu = 0
       else
          delta_qn = qnu * qrj / qctmp
          qnu      = qnu - delta_qn
       end if
       leff     = (1-nu)*Uw_p%HLv + nu*Uw_p%HLs
       qctu_new = qctu - (qrj + qsj)
       hlu_new  = hlu  + (qrj + qsj)*leff
       qlu_new  = qlj - qrj
       qiu_new  = qij - qsj
       clu_new  = qlu_new
       ciu_new  = qiu_new
    else
       qrj      = 0.
       qsj      = 0.
       qctu_new = qctu
       hlu_new  = hlu  
       qlu_new  = qlj 
       qiu_new  = qij 
       clu_new  = qlu_new
       ciu_new  = qiu_new
    end if

    return
    
  end subroutine precip_new_k



  subroutine micro_donner_k (cpn, zs, ps, hlu, qctu, zs1, qlu1, clu1, &
                             qiu1, ciu1, w1, cr12, pr12, qrj, qsj, &
                             qlu_new, clu_new, qiu_new, ciu_new, &
                             hlu_new, qctu_new, temp, doice, Uw_p)       
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    real,           intent(in)    :: zs, ps, hlu, qctu
    real,           intent(in)    :: zs1, qlu1, clu1, qiu1, ciu1, w1
    real,           intent(inout) :: qrj, qsj, cr12, pr12
    real,           intent(inout) :: qlu_new, clu_new, qiu_new, &
                                     ciu_new, hlu_new, qctu_new, temp
    logical,        intent(in)    :: doice

    real    :: thj, qvj, qlj, qij, qse, thvj, nu, leff
    real    :: dt_micro, rw1, cw1, drwa, drwb, flw, rw2, cw2, pw2, dcw

    call findt_k (zs,ps,hlu,qctu,thj,qvj,qlj,qij,qse,thvj,doice, &
                  Uw_p)   
    temp = thj*exn_k(ps,Uw_p)
    if (doice) then
      nu   = max(min((268. - temp)/20.,1.0),0.0)
    else
      nu = 0.
    endif

    leff = (1.-nu)*Uw_p%HLv + nu*Uw_p%HLs
    if (qlj+qij .gt. 0.0) then
       flw  = qlj/(qlj+qij)
    else
       qrj      = 0.
       qsj      = 0.
       qlu_new  = 0.
       qiu_new  = 0.
       qctu_new = qctu
       hlu_new  = hlu
       clu_new  = 0.
       ciu_new  = 0.
       return
    end if

    cw1 = clu1 + ciu1

    rw1 = qlu1 + qiu1 - cw1
    rw1 = max(rw1, 0.0)

    cw2 = qlj + qij - rw1

    dcw = cw2 - cw1; 

    dt_micro = (zs - zs1) / w1

    cr12 = dcw/dt_micro

    drwa = cpn%auto_rate * (cw2 - cpn%auto_th0) * dt_micro

    drwa=min(max(drwa, 0.0), cw2-cpn%auto_th0)

    cw2 = cw2 - drwa

    drwb = 5.26e-03 * cw2 * (rw1**0.875) * dt_micro

    drwb=min(max(drwb, 0.0), cw2)

    cw2 = cw2 - drwb

    rw2 = rw1 + drwa + drwb

    rw2 = max(rw2, 0.0)

    pw2 = 5.1*(rw2**1.125)*dt_micro/100.

    pw2 =min(pw2, rw2)

    pw2 = min(pw2, qlj + qij)

    pr12=pw2/dt_micro
   
    rw2 =rw2-pw2

    qrj = pw2*flw
    qsj = pw2*(1.-flw)

    qlu_new  = qlj - qrj
    qiu_new  = qij - qsj
    qctu_new = qctu - (qrj + qsj)
    hlu_new  = hlu  + (qrj + qsj)*leff

    cw2 = max(qlu_new + qiu_new -rw2, 0.0)
    clu_new = cw2*flw
    ciu_new  = cw2*(1. - flw)

    if (qlu_new .lt. 0. .or. qiu_new .lt. 0. .or. clu_new .lt. 0.0 .or.&
        ciu_new .lt. 0.0) then
       print*, qlu_new, qiu_new, clu_new, ciu_new,   &
                             qrj, qsj, qlj, qij, '??????????????????'
    end if
    return
    
  end subroutine micro_donner_k



!#####################################################################
!#####################################################################

  subroutine penetrative_mixing_k(cpn, sd, Uw_p, cp)
    type(cpnlist),  intent(in)    :: cpn
    type(sounding), intent(in)    :: sd
    type(uw_params),   intent(inout) :: Uw_p
    type(cplume),   intent(inout) :: cp

    integer :: k, ltop, let
    real    :: rhos0j, bogtop, bogbot
    real    :: aquad, bquad, cquad, xs1, xs2, ppen
    real    :: thj, qvj, qse, thvj, qctulet, hlulet, umflet
    real    :: dqct1, dqct2, qctflxkm1, tmp

    ltop=cp%ltop
    let =cp%let

    cp % emf (ltop)  = 0.0
    cp % fdr (ltop)  = 0.0
    cp % hlu (ltop)  = cp % hl (ltop)
    cp % qctu(ltop)  = cp % qct(ltop)
    cp % qlu (ltop)  = cp % ql (ltop)
    cp % qiu (ltop)  = cp % qi (ltop)
    cp % tru (ltop,:)= cp % tr (ltop,:)

    qctulet = cp%qctu(let)
    hlulet  = cp%hlu (let)
    umflet  = cp%umf (let)

    do k=ltop-1,let,-1

       cp%fdr(k)  = 0.
       cp%qlu(k)  = cp%ql(k)
       cp%qiu(k)  = cp%qi(k)

       rhos0j = cp%ps(k) /(Uw_p%rdgas*0.5*   &
                     (cp%thvbot(k+1)+cp%thvtop(k))*exn_k(cp%ps(k),Uw_p))
       if(k.eq.ltop-1)then
          !Calculate ppen
!!$          bogbot = (cp%thvu(k)/cp%thvbot(ltop) - 1.)/cpn%rbuoy
!!$          if(bogbot.gt.0.)then
!!$             bogbot =  bogbot /cpn%rbuoy
!!$          else
!!$             bogbot =  bogbot*cpn%rbuoy
!!$          endif
!!$          bogtop = (cp%thvu(ltop)/cp%thvtop(ltop) - 1.)/cpn%rbuoy
!!$          if(bogtop.gt.0.)then
!!$             bogtop =  bogtop /cpn%rbuoy
!!$          else
!!$             bogtop =  bogtop*cpn%rbuoy
!!$          endif

          bogbot = (cp%thvu(k)/cp%thvbot(ltop) - 1.)
          bogbot =  bogbot*cpn%rbuoy
          bogtop = (cp%thvu(ltop)/cp%thvtop(ltop) - 1.)
          bogtop =  bogtop*cpn%rbuoy

          aquad = (bogtop - bogbot) / (cp%ps(ltop)-cp%ps(k))
          bquad = 2*bogbot
          cquad = -cp%wu(k) * cp%ps(k) /   &
                      (Uw_p%rdgas*cp%thvbot(ltop)*exn_k(cp%ps(k),Uw_p))
          call roots(aquad,bquad,cquad,xs1,xs2)
          if(xs1.le.0..and.xs2.le.0.)then
             ppen = max(xs1,xs2)
          else
             ppen = min(xs1,xs2)
          endif
          ppen = min(0.,max(-cp%dp(k+1),ppen))
          if(xs1.eq.-9.99e33.or.xs2.eq.-9.99e33) ppen=0.
          !Calculate returning mass flux
          cp%emf (k)=max(cp%umf(k)*ppen*cp%rei(ltop)*  &
                                                 cpn%rpen,-0.1*rhos0j)
          cp%hlu (k)=cp%hl (ltop)+sd%sshl (ltop)*(cp%ps(k)-cp%p(ltop))
          cp%qctu(k)=cp%qct(ltop)+sd%ssqct(ltop)*(cp%ps(k)-cp%p(ltop))
          cp%tru(k,:)=cp%tr(ltop,:)+sd%sstr(ltop,:)*   &
                                                 (cp%ps(k)-cp%p(ltop))
       else
          cp%emf (k)=max(cp%emf(k+1)-cp%umf(k)*cp%dp(k+1)*  &
                                      cp%rei(k+1)*cpn%rpen,-0.1*rhos0j)
          if (cp%emf(k).ne.0) then
            cp%hlu (k)=(cp%hlu (k+1)*cp%emf(k+1)+cp%hl (k+1)* &
                                        (cp%emf(k)-cp%emf(k+1)))/cp%emf(k)
            cp%qctu(k)=(cp%qctu(k+1)*cp%emf(k+1)+cp%qct(k+1)*  &
                                        (cp%emf(k)-cp%emf(k+1)))/cp%emf(k)
            cp%tru(k,:)=(cp%tru(k+1,:)*cp%emf(k+1)+cp%tr(k+1,:)* &
                                        (cp%emf(k)-cp%emf(k+1)))/cp%emf(k)
          endif
       endif
       cp%umf(k)=0.0 
    enddo

    k=let
    cp%fdr (k) = 1./sd%dp(k)
    
 if (cpn%do_pmadjt) then
    dqct1=cp%qctu(k-1)-(cp%qct(k)  +sd%ssqct(k)  *(sd%ps(k-1)-sd%p(k)))
    dqct2=cp%qctu(k)  -(cp%qct(k)  +sd%ssqct(k)  *(sd%ps(k)-sd%p(k)))
    qctflxkm1=cp%umf(k-1)*dqct1
    if ((cp%emf(k)*dqct2.gt.qctflxkm1).and.(qctflxkm1.gt.0.).and.(dqct2.lt.0)) then
       tmp=qctflxkm1/dqct2/cp%emf(k)
       cp%emf=cp%emf*tmp
    end if

    tmp=umflet-cp%emf(k)
    if (tmp.gt.0) then
       qctulet = (umflet*qctulet - cp%emf(k)*cp%qctu(k))/tmp
       hlulet  = (umflet*hlulet  - cp%emf(k)*cp%hlu (k))/tmp
    else
       qctulet = cp%qctu(k)
       hlulet  = cp%hlu (k)
    end if
    call findt_k (cp%zs(k), cp%ps(k), hlulet, qctulet, thj, qvj,       &
                  cp%qlu(k), cp%qiu(k), qse, thvj, cpn%do_ice, Uw_p)
 end if

  end subroutine penetrative_mixing_k

!#####################################################################
!#####################################################################

  subroutine cumulus_tend_k(cpn, sd, Uw_p, cp, ct, do_coldT)
  
    type(cpnlist),  intent(in)    :: cpn
    type(uw_params),  intent(inout)    :: Uw_p
    type(sounding), intent(in)    :: sd
    type(cplume),   intent(inout) :: cp
    type(ctend),    intent(inout) :: ct
    logical,        intent(in)    :: do_coldT

    integer :: k, krel, ltop, kp1, km1, ktop, i
    real    :: dpsum, qtdef, hldef, umftmp, qlutmp, qiutmp, qnutmp, fdrtmp
    real, dimension(size(cp%tr,2)) :: trdef
    real    :: dpevap, x1, x2, x3, xx1, xx2, xx3, q1, q2, emftmp
    real    :: dqt

    call ct_clear_k (ct);

    krel=cp%krel
    ltop=cp%ltop

    ! Calculate Fluxes of heat, moisture, momentum
    dpsum = 0.0
    do k = 1, krel-1
       dpsum = dpsum + sd%dp(k)
    enddo

    qtdef = max(0.,cp%umf(krel)*(cp%qctu(krel) - cp%qct(krel)))
    trdef(:) = max(0.,cp%umf(krel)*(cp%tru(krel,:) - cp%tr(krel,:)))
    !yy1  = min(0.,umf(krel)*(thcu(krel) - thc0(krel)))
    hldef = min(0.,cp%umf(krel)*(cp%hlu (krel) - cp%hl (krel)))
    do k=1,krel-1
!      ct%hlflx (k)=0.0; 
       ct%hlflx (k)=0.0; !ct%hlflx (k-1) + hldef*sd%dp(k)/dpsum;
!      ct%thcflx(k)=0.0; !thcflx(k)=thcflx(k-1) + yy1*dp(k)/dpsum
       ct%qctflx(k)=ct%qctflx(k-1) + qtdef*sd%dp(k)/dpsum;
       ct%thcflx(k)=0.0;
       ct%trflx(k,:)=ct%trflx(k-1,:) + trdef(:)*sd%dp(k)/dpsum
       ct%qlflx(k)=0.0;
       ct%qiflx(k)=0.0;
       ct%qnflx(k)=0.0;
       ct%umflx(k)=0.0;
       ct%vmflx(k)=0.0;
       cp%pptr (k)=0.0; 
       cp%ppti (k)=0.0;
       cp%pptn (k)=0.0;
    enddo

    if (cpn%do_qctflx_zero) then
       do k=1,krel-1
          ct%qctflx(k) =0.;
          ct%trflx (k,:)=0.;
       end do
    end if

    do k = krel,ltop-1 !pzhu do k = krel,ltop
       kp1 = k+1

       ct%hlflx (k)= cp%umf(k)*(cp%hlu (k)-(cp%hl (kp1)+  &
                       sd%sshl (kp1)*(sd%ps(k)-sd%p(kp1)))) + &
                       cp%emf(k) * (cp%hlu (k)-  &
                           (cp%hl (k)+sd%sshl (k)*(sd%ps(k)-sd%p(k))))
       ct%thcflx(k)= cp%umf(k)*(cp%thcu(k)-(cp%thc(kp1)+  &
                        sd%ssthc(kp1)*(sd%ps(k)-sd%p(kp1)))) + &
                       cp%emf(k) * (cp%thcu(k)-  &
                            (cp%thc(k)+sd%ssthc(k)*(sd%ps(k)-sd%p(k))))
       ct%qctflx(k)= cp%umf(k)*(cp%qctu(k)-(cp%qct(kp1)+  &
                        sd%ssqct(kp1)*(sd%ps(k)-sd%p(kp1)))) + &
                       cp%emf(k) * (cp%qctu(k)-  &
                            (cp%qct(k)+sd%ssqct(k)*(sd%ps(k)-sd%p(k))))
       
       ct%umflx(k) =cp%umf(k) * (cp%uu(k) - cp%u(kp1))  +   &
                                      cp%emf(k) * (cp%u(kp1) -cp%u(k))
       ct%vmflx(k) =cp%umf(k) * (cp%vu(k) - cp%v(kp1))  +  &
                                      cp%emf(k) * (cp%v(kp1) -cp%v(k))

       ct%qlflx(k) =cp%umf(k) * (cp%qlu(k)- cp%ql(kp1)) +   &
                                      cp%emf(k) * (cp%ql(kp1)-cp%ql(k))
       ct%qiflx(k) =cp%umf(k) * (cp%qiu(k)- cp%qi(kp1)) +   &
                                      cp%emf(k) * (cp%qi(kp1)-cp%qi(k))
       ct%qaflx(k) =cp%umf(k) * (1.       - cp%qa(kp1)) +   &
                                       cp%emf(k) * (cp%qa(kp1)-cp%qa(k))
       ct%qnflx(k) =cp%umf(k) * (cp%qnu(k)- cp%qn(kp1)) +  &
                                      cp%emf(k) * (cp%qn(kp1)-cp%qn(k))

!++++yim
       ct%trflx(k,:) =cp%umf(k) * (cp%tru(k,:)- (cp%tr(kp1,:)+  &
                             sd%sstr(kp1,:)*(sd%ps(k)-sd%p(kp1))) ) + &
                       cp%emf(k) * (cp%tru(kp1,:)-   &
                         (cp%tr(k,:)+sd%sstr(k,:)*(sd%ps(k)-sd%p(k))) )
       ct%qvflx(k) =ct%qctflx(k)-ct%qlflx(k)-ct%qiflx(k)
    enddo

    do k = 2,ltop
       km1 = k-1
       kp1 = k+1
       x1=sd%p(k)   -sd%ps(k)
       x2=sd%ps(km1)-sd%p (k)
       x3=sd%ps(km1)-sd%ps(k)
       umftmp = (cp%umf(km1)*x1+cp%umf(k)*x2)/x3
       emftmp = (cp%emf(km1)*x1+cp%emf(k)*x2)/x3
       qlutmp = (cp%qlu(km1)*x1+cp%qlu(k)*x2)/x3
       qiutmp = (cp%qiu(km1)*x1+cp%qiu(k)*x2)/x3
       qnutmp = (cp%qnu(km1)*x1+cp%qnu(k)*x2)/x3

       fdrtmp = cp%fdrsat(k)*cp%fdr(k)
       ct%qldet(k) =  Uw_p%grav*(umftmp       )*(fdrtmp*(qlutmp-sd%ql(k)))
       ct%qidet(k) =  Uw_p%grav*(umftmp       )*(fdrtmp*(qiutmp-sd%qi(k)))
       ct%qadet(k) =  Uw_p%grav*(umftmp-emftmp)*(fdrtmp*(1.    -sd%qa(k)))
       ct%qndet(k) =  Uw_p%grav*(umftmp       )*(fdrtmp*(qnutmp-sd%qn(k)))

       x1 =sd%ps(k)  -sd%p (kp1)
       x2 =sd%p (k)  -sd%ps(k)
       x3 =sd%p (k)  -sd%p (kp1)
       xx1=sd%ps(km1)-sd%p (k)
       xx2=sd%p (km1)-sd%ps(km1)
       xx3=sd%p (km1)-sd%p (k)

       q2=(sd%ql(k)  *x1  + sd%ql(kp1)*x2  )/x3
       q1=(sd%ql(km1)*xx1 + sd%ql(k)  *xx2 )/xx3
       ct%qlten(k) = - Uw_p%grav*(umftmp * (sd%ql(k)-q2      )/x2 + &
                                  emftmp * (q1      -sd%ql(k))/xx1 )

       q2=(sd%qi(k)  *x1  + sd%qi(kp1)*x2  )/x3
       q1=(sd%qi(km1)*xx1 + sd%qi(k)  *xx2 )/xx3
       ct%qiten(k) = - Uw_p%grav*(umftmp * (sd%qi(k)-q2      )/x2 + &
                                  emftmp * (q1      -sd%qi(k))/xx1 )

       q2=(sd%qa(k)  *x1  + sd%qa(kp1)*x2  )/x3
       q1=(sd%qa(km1)*xx1 + sd%qa(k)  *xx2 )/xx3
       ct%qaten(k) = - Uw_p%grav*(umftmp * (sd%qa(k)-q2      )/x2 + &
                                  emftmp * (q1      -sd%qa(k))/xx1 )

       q2=(sd%qn(k)  *x1  + sd%qn(kp1)*x2  )/x3
       q1=(sd%qn(km1)*xx1 + sd%qn(k)  *xx2 )/xx3
       ct%qnten(k) = - Uw_p%grav*(umftmp * (sd%qn(k)-q2      )/x2 + &
                                  emftmp * (q1      -sd%qn(k))/xx1 )
    end do

    ct%qlten = ct%qlten + ct%qldet 
    ct%qiten = ct%qiten + ct%qidet
    ct%qaten = ct%qaten + ct%qadet
    ct%qnten = ct%qnten + ct%qndet

    if (cpn%do_detran_zero) then
       ct%qlten = 0.
       ct%qiten = 0.
       ct%qaten = 0.
       ct%qnten = 0.
    end if

    ! Calculate model tendencies
    do k = 1,ltop
       km1 = k-1
       kp1 = k+1
       ct%uten (k) = (ct%umflx(km1)-ct%umflx(k))*Uw_p%grav/sd%dp(k)
       ct%vten (k) = (ct%vmflx(km1)-ct%vmflx(k))*Uw_p%grav/sd%dp(k)

       ct%thcten(k) = (ct%thcflx(km1) - ct%thcflx(k))*   &
                                                   Uw_p%grav/sd%dp(k)
!      ct%hlten (k) = (ct%hlflx (km1) - ct%hlflx (k)   &
!            +(cp%pptr(k) + cp%ppti(k)) *sd%leff(k))*Uw_p%grav/sd%dp(k)
       ct%hlten (k) = (ct%hlflx (km1) - ct%hlflx (k) +   &
                       Uw_p%HLv*cp%pptr(k) + Uw_p%HLs*cp%ppti(k))* &
                                                      Uw_p%grav/sd%dp(k)
       ct%qctten(k) = (ct%qctflx(km1) - ct%qctflx(k) -   &
                           cp%pptr(k) - cp%ppti(k)) *Uw_p%grav/sd%dp(k)
       ct%qvten (k) = ct%qctten(k)-ct%qlten(k)-ct%qiten(k)
       ct%pflx  (k) = cp%pptr(k) + cp%ppti(k)

!      ct%tten  (k) = (ct%hlten(k)+sd%leff(k)*  &
!                                (ct%qlten(k)+ct%qiten(k)))/Uw_p%cp_air
       ct%tten  (k) = (ct%hlten(k)+Uw_p%HLv*ct%qlten(k)+    &
                                      Uw_p%HLs*ct%qiten(k))/Uw_p%cp_air
       ct%trten(k,:) = (ct%trflx(km1,:)-ct%trflx(k,:))*   &
                                                    Uw_p%grav/sd%dp(k)
       ct%trwet(k,:) = cp%tru_dwet(k,:) *cp%umf(k)*Uw_p%grav/sd%dp(k)

    enddo

    do k = cp%let,ltop
       if (ct%qctten(k).gt.0 .and. ct%qvten(k).lt.0) then
          qlutmp     =(1.-sd%nu(k))*ct%qvten(k)
          qiutmp     =    sd%nu(k) *ct%qvten(k)
          ct%qlten(k)=ct%qlten(k)+qlutmp
          ct%qiten(k)=ct%qiten(k)+qiutmp
          ct%qvten(k)=0.
          ct%tten (k)=ct%tten(k)+(Uw_p%HLv*qlutmp+Uw_p%HLs*qiutmp)/Uw_p%cp_air
       end if
    end do

    ct%dtint=0.; ct%dqint=0.; ct%conint=0.; ct%freint=0.; !dpsum=0.;

    ct%qlflx(ltop)=(1.-cpn%atopevap)*ct%qlflx(ltop-1);
    ct%qiflx(ltop)=(1.-cpn%atopevap)*ct%qiflx(ltop-1);
    ktop=ltop

    do k = 1,ktop
       km1 = k-1
       ct%qldiv(k) = -(ct%qlflx(k) - ct%qlflx(km1) +   &
                                       cp%pptr(k))* Uw_p%grav/sd%dp(k)
       ct%qidiv(k) = -(ct%qiflx(k) - ct%qiflx(km1) +   &
                                       cp%ppti(k))* Uw_p%grav/sd%dp(k)
    end do

    do k = 1,ltop
       km1 = k-1
       ct%qvdiv(k) = -(ct%qvflx(k) - ct%qvflx(km1))* Uw_p%grav/sd%dp(k)
       ct%dtint    = ct%dtint    + ct%tten (k)*Uw_p%cp_air/sd%leff(k)* &
                                                    sd%dp(k)/Uw_p%grav
       ct%dqint    = ct%dqint    + ct%qvten(k)* sd%dp(k)/Uw_p%grav
       ct%conint   = ct%conint   + ct%qldiv(k)* sd%dp(k)/Uw_p%grav
       ct%freint   = ct%freint   + ct%qidiv(k)* sd%dp(k)/Uw_p%grav
    end do

    if (do_coldT) then
       do k = 1,ltop
          if (sd%coldT) then
             ct%tten(k)=ct%tten(k)+cp%pptr(k)*Uw_p%HLf*Uw_p%grav/  &
                                                   sd%dp(k)/Uw_p%cp_air
             cp%ppti(k)=cp%ppti(k)+cp%pptr(k)
             cp%pptr(k)=0.
          else
             ct%tten(k)=ct%tten(k)-cp%ppti(k)*Uw_p%HLf*Uw_p%grav/  &
                                                   sd%dp(k)/Uw_p%cp_air
             cp%pptr(k)=cp%pptr(k)+cp%ppti(k)
             cp%ppti(k)=0.
          end if
          ct%snow  = ct%snow  + cp%ppti(k)
          ct%rain  = ct%rain  + cp%pptr(k)
       end do
       if (cpn%do_pevap .and. ct%snow+ct%rain > 0.) then
          call precip_evap (sd, cp, cpn, ct, Uw_p, dpevap)
          ct%tten (:)=ct%tten (:)+ct%tevap(:)
          ct%qvten(:)=ct%qvten(:)+ct%qevap(:)
          if (sd%coldT) then
             ct%snow  = ct%snow - dpevap
          else
             ct%rain  = ct%rain - dpevap
          end if
       end if
    end if

    if(cpn%do_pnqv) then
       do k = sd%kmax,3,-1
          dqt  =  ct%qvten(k) * sd%delt
          if (dqt.lt.0 .and. sd%qv(k)+dqt.lt.1.e-10) then
             fdrtmp = -(sd%qv(k)-1.e-10)/sd%delt - ct%qvten(k)
             ct%qvten(k) = ct%qvten(k) + fdrtmp
             dpsum = 0.0
             do i = k-1,1,-1
                dpsum = dpsum + sd%dp(i)
             enddo
             do i = k-1,1,-1
                ct%qvten(i) = ct%qvten(i) - fdrtmp*sd%dp(k)/dpsum
             enddo
          end if
       end do
    end if

    ct%dting=0.;
    ct%denth=0.; ct%dqtmp=0.; ct%uav=0.;ct%vav=0.; dpsum=0.;
    do k = 1,sd%kmax! ltop
       ct%denth = ct%denth + (Uw_p%cp_air*ct%tten(k)-Uw_p%HLv*ct%qlten(k)-Uw_p%HLs*ct%qiten(k))*sd%dp(k)/Uw_p%grav
       ct%dqtmp = ct%dqtmp + (ct%qvten(k) + ct%qlten(k) + ct%qiten(k))*sd%dp(k)/Uw_p%grav
       ct%uav   = ct%uav   + ct%uten(k)*sd%dp(k)/Uw_p%grav
       ct%vav   = ct%vav   + ct%vten(k)*sd%dp(k)/Uw_p%grav
       ct%dting = ct%dting + Uw_p%cp_air*ct%tten(k)*sd%dp(k)/Uw_p%grav
!       dpsum    = dpsum    + sd%dp(k)
     end do
     ct%denth = ct%denth - Uw_p%HLv*ct%rain - Uw_p%HLs*ct%snow
     ct%dqtmp = ct%dqtmp + ct%rain + ct%snow

  end subroutine cumulus_tend_k

!#####################################################################
!#####################################################################

 subroutine roots(a,b,c,r1,r2)
   real a,b,c,r1,r2,q
   
   if(a.eq.0)then            ! form b*x + c = 0
      if(b.eq.0)then         ! failure: c = 0
         r1 = -9.99e33
      else                   ! b*x + c = 0
         r1 = -c / b
      endif
      r2 = r1
   else
      if(b.eq.0.)then        ! form a*x**2 + c = 0
         if(a*c.gt.0.)then   ! failure: x**2 = -c/a < 0
            r1 =  -9.99e33
         else                ! x**2 = -c/a
            r1 = sqrt(-c/a)
         endif
         r2 = -r1
      else 
         if((b**2. - 4.*a*c).lt.0.)then ! failure, no real(r8) roots
            r1 =  -9.99e33
            r2 = -r1
         else
            q = - 0.5 * ( b + sign(1.0,b) * sqrt(b**2. - 4.*a*c) )
            r1 = q/a
            r2 = c/q
         endif
      endif
   endif
   return
 end subroutine roots

!#####################################################################
!#####################################################################

  SUBROUTINE precip_evap (sd, cp, cpn, ct, Uw_p, dpevap)

    implicit none
    
    type(sounding), intent(in)      :: sd
    type(cplume),   intent(in)      :: cp
    type(cpnlist),  intent(in)      :: cpn
    type(ctend),    intent(inout)   :: ct
    type(uw_params),intent(inout)   :: Uw_p
    real,           intent(inout)   :: dpevap

    real, parameter :: cem    = 0.054
    real, parameter :: ceta   = -544.0E-6
    real, parameter :: d622   = 287.04/461.50
    real, parameter :: d378   = 1.0-d622

    real, dimension(size(sd%t)) :: mass, temp_new, qvap_new, pptp, pflx, pflx_evap
    real    :: prec, def, evef, prec_mmph, pfac, emx, dpcu, HL, dqs, qs
    real    :: hcevap, cfrac

    integer :: k, ier

    cfrac     = cpn%cfrac
    hcevap    = cpn%hcevap

    pflx      = 0.0
    pflx_evap = 0.0
    qvap_new  = sd%qv
    temp_new  = sd%t

    if (sd%coldT) then
       HL=Uw_p%HLs
    else
       HL=Uw_p%HLv
    end if

    !pptp (unit: kg/m2 or mm) - precipitated water in the layer dp
    pptp   = (cp%pptr(:)+cp%ppti(:))*sd%delt
    mass   = sd%dp/Uw_p%grav
    dpcu   = 0.0
    dpevap = 0.0
    do k = cp%ltop, 2, -1
       dpcu = dpcu + pptp(k)
       prec = MAX(dpcu - dpevap, 0.0 )

! --- Compute precipitation efficiency factor
       prec_mmph = prec * 3600.0 / sd%delt
       pfac      = SQRT( sd%p(k) / sd%ps(0) )
       emx       = SQRT( cem * cfrac * prec_mmph * pfac )   
       evef      = 1.0 - EXP( ceta * sd%delt * emx ) 

       def=0. !Evaporate precip where needed
       if ( sd%rh(k) <= hcevap .and. prec > 0.0 ) then
          call compute_qs_k (sd%t(k), sd%p(k), Uw_p%epsilo, Uw_p%zvir, &
                             qs, ier, dqsdT=dqs) 
          def=(hcevap*sd%qs(k) - sd%qv(k))/(1.+(HL*hcevap*dqs/Uw_p%Cp_Air ))
          def=evef*def
          def=MIN( def, prec/mass(k) )
       else
          def=0.0
       end if
       pflx_evap(k)= def * mass(k)
       dpevap      = dpevap + pflx_evap(k)
       qvap_new(k) = sd%qv(k) + def
       temp_new(k) = sd%t (k) - (def * HL/Uw_p%Cp_Air)
       pflx    (k) = prec
    end do
    dpevap      = min(dpevap, dpcu) / sd%delt
    ct%tevap(:) = (temp_new(:) - sd%t (:))/sd%delt
    ct%qevap(:) = (qvap_new(:) - sd%qv(:))/sd%delt
  
  end SUBROUTINE PRECIP_EVAP

!#####################################################################
!#####################################################################

end MODULE CONV_PLUMES_k_MOD




MODULE CONV_UTILITIES_MOD
  
use      Constants_Mod, ONLY:   tfreeze, HLv, HLf, HLs, CP_AIR, GRAV, &
                                Kappa,rdgas,rvgas
use fms_mod,            only:   mpp_pe, mpp_root_pe
use conv_utilities_k_mod, only: uw_params_init_k, uw_params
! use conv_utilities_k_mod, only: sd_init_k, sd_copy_k, sd_end_k, &
!                                 ac_init_k, ac_clear_k, ac_end_k, &
!                                 uw_params_init_k, uw_params, &
!                                 pack_sd_k, extend_sd_k, adi_cloud_k,&
!                                 qsat_k, qses_k, exn_k, conden_k, &
!                                 findt_k,                      &
!                                 pack_sd_lsm_k, sounding, adicloud

!---------------------------------------------------------------------
  implicit none
  private

!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: conv_utilities.F90,v 17.0 2009/07/21 02:58:03 fms Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

! public  :: sd_init, sd_copy, sd_end, ac_init, ac_clear, ac_end, qsat, qses, exn, &
  public  ::   &
       uw_params_init
!      uw_params_init, &
!      conden, findt, pack_sd, pack_sd_lsm, extend_sd, adi_cloud

  real, parameter :: p00   = 1.E5
  real, parameter :: epsilo= rdgas/rvgas      !ratio of h2o to dry air molecular weights 
  real, parameter :: zvir  = rvgas/rdgas - 1. !rh2o/rair - 1
  real, parameter :: tkmin = -160 + tfreeze   ! tcmin from sat_vapor_pres.f90
  real, parameter :: tkmax =  100 + tfreeze   ! tcmax from sat_vapor_pres.f90

  character(len=7) :: mod_name = 'conv_utilities'

contains

!#####################################################################
!#####################################################################

  subroutine uw_params_init (Uw_p)

  type(uw_params), intent(inout) :: Uw_p
  
    integer :: me, root_pe
    
    me = mpp_pe()
    root_pe = mpp_root_pe()
    call uw_params_init_k (hlv, hls, hlf, cp_air, grav, kappa, rdgas, &
                           p00, epsilo, zvir, tkmin, tkmax, me,  &
                                                           root_pe,Uw_p)
    
  end subroutine uw_params_init

!#####################################################################
!#####################################################################



end MODULE CONV_UTILITIES_MOD


#include <fms_platform.h>

MODULE CONV_UTILITIES_k_MOD
  
  use Sat_Vapor_Pres_k_Mod, ONLY: compute_qs_k

!---------------------------------------------------------------------
  implicit none
  private

!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: conv_utilities_k.F90,v 17.0.4.1.4.1 2010/03/17 20:27:10 wfc Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!---------------------------------------------------------------------
!-------  interfaces --------

  public  :: sd_init_k, sd_copy_k, sd_end_k, ac_init_k, ac_clear_k,  &
             ac_end_k, qsat_k, qses_k, exn_k, exn_init_k, exn_end_k, &
             findt_k, findt_init_k, findt_end_k, uw_params_init_k, &
             conden_k, pack_sd_k, pack_sd_lsm_k, extend_sd_k,  &
             adi_cloud_k, check_tracer_realizability, qt_parcel_k





 public sounding
 type sounding
    logical  :: coldT
    integer  :: kmax, kinv, ktoppbl, ktopconv
    real     :: psfc, pinv, zinv, thvinv, land, pblht, qint, delt, rhav, tke
    real, _ALLOCATABLE :: t     (:)_NULL, qv   (:)_NULL, u     (:)_NULL
    real, _ALLOCATABLE :: v     (:)_NULL, ql   (:)_NULL, qi    (:)_NULL
    real, _ALLOCATABLE :: qa    (:)_NULL, thc  (:)_NULL, qct   (:)_NULL
    real, _ALLOCATABLE :: thv   (:)_NULL, rh   (:)_NULL, p     (:)_NULL
    real, _ALLOCATABLE :: z     (:)_NULL, dp   (:)_NULL, dz    (:)_NULL
    real, _ALLOCATABLE :: rho   (:)_NULL, nu   (:)_NULL, leff  (:)_NULL
    real, _ALLOCATABLE :: exner (:)_NULL, ps   (:)_NULL, exners(:)_NULL
    real, _ALLOCATABLE :: zs    (:)_NULL, ssthc(:)_NULL, ssqct (:)_NULL
    real, _ALLOCATABLE :: dudp  (:)_NULL, dvdp (:)_NULL, thvbot(:)_NULL
    real, _ALLOCATABLE :: thvtop(:)_NULL, qn   (:)_NULL, qs    (:)_NULL
    real, _ALLOCATABLE :: am1   (:)_NULL, am2  (:)_NULL, am3   (:)_NULL
    real, _ALLOCATABLE :: am4   (:)_NULL
    real, _ALLOCATABLE :: hl    (:)_NULL, sshl (:)_NULL, hm    (:)_NULL
    real, _ALLOCATABLE :: hms   (:)_NULL
!++++yim     
    real, _ALLOCATABLE :: tr    (:,:)_NULL, sstr(:,:)_NULL
 end type sounding

 public adicloud
 type adicloud
   real     :: usrc, vsrc, hlsrc, thcsrc, qctsrc
    integer  :: klcl, klfc, klnb
    real     :: plcl, zlcl, thvlcl, thv0lcl, rho0lcl
    real     :: plfc, plnb, cape, cin
    real, _ALLOCATABLE :: t  (:)_NULL, qv  (:)_NULL, ql  (:)_NULL
    real, _ALLOCATABLE :: qi (:)_NULL, thc (:)_NULL, qct (:)_NULL
    real, _ALLOCATABLE :: thv(:)_NULL, nu  (:)_NULL, leff(:)_NULL
    real, _ALLOCATABLE :: hl (:)_NULL, buo (:)_NULL
 end type adicloud

 public uw_params
 type uw_params
   real  :: hlv, hls, hlf, cp_air, grav, kappa, rdgas, p00, epsilo,  &
            zvir, tkmin, tkmax
   integer :: me
   logical :: master
 end type uw_params

! Lookup table dimension and ranges for findt_k
! These values should not be changed without a careful evaluation
! of the accuracy implications (cjg).

    integer, parameter :: nta = 1700
    real, parameter :: tamin =  120.0
    real, parameter :: tamax =  700.0

    integer, parameter :: np1 = 300
    real, parameter :: p1min = 10.0e2
    real, parameter :: p1max = 100.0e2
    integer, parameter :: np2 = 1000
    real, parameter :: p2min = 100.0e2
    real, parameter :: p2max = 1100.0e2
 
    real dta, dp1, dp2
    real rdta, rdp1, rdp2
    real(kind=4), allocatable :: ta_lookup(:,:,:)
    logical :: ta_lookup_allocated = .false.
 
! Lookup table for exn_k function (cjg)

    integer, parameter :: npex = 100000
    real, parameter :: pexmin = 10.0e2
    real, parameter :: pexmax = 1100.0e2

    real dpex, rdpex
    real(kind=4), allocatable :: ex_lookup(:)
    logical :: ex_lookup_allocated = .false.

contains

!#####################################################################
!#####################################################################

  subroutine uw_params_init_k (hlv, hls, hlf, cp_air, grav, kappa,  &
                               rdgas, p00, epsilo, zvir, tkmin,  &
                               tkmax, me, root_pe, Uw_p)
    real, intent(in) :: hlv, hls, hlf, cp_air, grav, kappa, rdgas,  &
                        p00, epsilo, zvir, tkmin, tkmax
    integer, intent(in) :: me, root_pe
    type(uw_params), intent(inout) :: Uw_p

    Uw_p%hlv = hlv
    Uw_p%hls = hls
    Uw_p%hlf = hlf
    Uw_p%cp_air = cp_air
    Uw_p%grav   = grav  
    Uw_p%kappa  = kappa 
    Uw_p%rdgas  = rdgas 
    Uw_p%p00    = p00   
    Uw_p%epsilo = epsilo
    Uw_p%zvir   = zvir  
    Uw_p%tkmin  = tkmin
    Uw_p%tkmax  = tkmax 
    Uw_p%me     = me
    Uw_p%master = (me == root_pe)

  end subroutine uw_params_init_k

!#####################################################################
!#####################################################################

  subroutine sd_init_k(kd, num_tracers, sd)
    integer, intent(in) :: kd, num_tracers
    type(sounding), intent(inout) :: sd
    
    sd%coldT    = .false.
    sd%kmax     = kd
    sd%kinv     = 0
    sd%ktoppbl  = 0
    sd%ktopconv = 0
    sd%psfc     = 0.0
    sd%pinv     = 0.0
    sd%zinv     = 0.0
    sd%thvinv   = 0.0
    sd%land     = 0.0
    sd%pblht    = 0.0
    sd%qint     = 0.0
    sd%delt     = 0.0
    sd%rhav     = 0.0
    sd%tke      = 0.0
    allocate ( sd%t     (1:kd)); sd%t     =0.;
    allocate ( sd%qv    (1:kd)); sd%qv    =0.;
    allocate ( sd%u     (1:kd)); sd%u     =0.;
    allocate ( sd%v     (1:kd)); sd%v     =0.;
    allocate ( sd%qs    (1:kd)); sd%qs    =0.;
    allocate ( sd%ql    (1:kd)); sd%ql    =0.;
    allocate ( sd%qi    (1:kd)); sd%qi    =0.;
    allocate ( sd%qa    (1:kd)); sd%qa    =0.;
    allocate ( sd%qn    (1:kd)); sd%qn    =0.;
    allocate ( sd%thc   (1:kd)); sd%thc   =0.;
    allocate ( sd%qct   (1:kd)); sd%qct   =0.;
    allocate ( sd%thv   (1:kd)); sd%thv   =0.;
    allocate ( sd%rh    (1:kd)); sd%rh    =0.;
    allocate ( sd%p     (1:kd)); sd%p     =0.;
    allocate ( sd%z     (1:kd)); sd%z     =0.;
    allocate ( sd%dp    (1:kd)); sd%dp    =0.;
    allocate ( sd%dz    (1:kd)); sd%dz    =0.;
    allocate ( sd%rho   (1:kd)); sd%rho   =0.;
    allocate ( sd%nu    (1:kd)); sd%nu    =0.;
    allocate ( sd%leff  (1:kd)); sd%leff  =0.;
    allocate ( sd%exner (1:kd)); sd%exner =0.;
    allocate ( sd%ps    (0:kd)); sd%ps    =0.;
    allocate ( sd%zs    (0:kd)); sd%zs    =0.;
    allocate ( sd%exners(0:kd)); sd%exners=0.;
    allocate ( sd%ssthc (1:kd)); sd%ssthc =0.;
    allocate ( sd%ssqct (1:kd)); sd%ssqct =0.;
    allocate ( sd%dudp  (1:kd)); sd%dudp  =0.;
    allocate ( sd%dvdp  (1:kd)); sd%dvdp  =0.;
    allocate ( sd%thvbot(1:kd)); sd%thvbot=0.;
    allocate ( sd%thvtop(1:kd)); sd%thvtop=0.;
    allocate ( sd%am1   (1:kd)); sd%am1   =0.;
    allocate ( sd%am2   (1:kd)); sd%am2   =0.;
    allocate ( sd%am3   (1:kd)); sd%am3   =0.;
    allocate ( sd%am4   (1:kd)); sd%am4   =0.;
    allocate ( sd%hl    (1:kd)); sd%hl    =0.;
    allocate ( sd%hm    (1:kd)); sd%hm    =0.;
    allocate ( sd%hms   (1:kd)); sd%hms   =0.;
    allocate ( sd%sshl  (1:kd)); sd%sshl  =0.;
!++++yim
    allocate ( sd%tr  (1:kd,1:num_tracers)); sd%tr  =0.;
    allocate ( sd%sstr  (1:kd,1:num_tracers)); sd%sstr  =0.;
    
  end subroutine sd_init_k

!#####################################################################
!#####################################################################

  subroutine sd_copy_k(sd, sd1)
    type(sounding), intent(in)    :: sd
    type(sounding), intent(inout) :: sd1
    
    sd1% ktopconv = sd % ktopconv
    sd1% kmax = sd % kmax
    sd1% land = sd % land
    sd1% coldT= sd % coldT
    sd1%p     = sd%p;    sd1%z     =sd%z;
    sd1%ps    = sd%ps;   sd1%zs    =sd%zs;
    sd1%t     = sd%t;    sd1%qv    =sd%qv;
    sd1%u     = sd%u;    sd1%v     =sd%v;
    sd1%ql    = sd%ql;   sd1%qi    =sd%qi;
    sd1%qa    = sd%qa;   sd1%qn    =sd%qn;    
    sd1%am1   = sd%am1;  sd1%am2   =sd%am2; 
    sd1%am3   = sd%am3;  sd1%am4   =sd%am4;
    sd1%hl    = sd%hl;   sd1%sshl  =sd%sshl;
    sd1%hm    = sd%hm;   sd1%hms   =sd%hms;
!++++yim
    sd1%tr  =sd%tr
  end subroutine sd_copy_k

!#####################################################################
!#####################################################################

  subroutine sd_end_k(sd)
    type(sounding), intent(inout) :: sd
    deallocate ( sd%t, sd%qv, sd%u, sd%v, sd%ql, sd%qi, sd%qa, sd%thc, sd%qct,&
         sd%thv, sd%rh, sd%p, sd%z, sd%dp, sd%dz, sd%rho, sd%nu, sd%leff,     &
         sd%exner, sd%ps, sd%exners, sd%zs, sd%ssthc, sd%ssqct, sd%dudp,      &
         sd%dvdp, sd%thvbot, sd%thvtop, sd%qn, sd%am1, sd%am2, sd%am3, sd%am4,&
         sd%qs, sd%hl, sd%hm, sd%hms, sd%sshl, sd%tr, sd%sstr)
  end subroutine sd_end_k

!#####################################################################
!#####################################################################

  subroutine ac_init_k(kd, ac)
    integer, intent(in) :: kd
    type(adicloud), intent(inout) :: ac
    
    ac%usrc    = 0.0
    ac%vsrc    = 0.0
    ac%hlsrc   = 0.0
    ac%thcsrc  = 0.0
    ac%qctsrc  = 0.0
    ac%klcl    = 0
    ac%klfc    = 0
    ac%klnb    = 0
    ac%plcl    = 0.0
    ac%zlcl    = 0.0
    ac%thvlcl  = 0.0
    ac%thv0lcl = 0.0
    ac%rho0lcl = 0.0
    ac%plfc    = 0.0
    ac%plnb    = 0.0
    ac%cape    = 0.0
    ac%cin     = 0.0
    allocate ( ac%t     (1:kd)); ac%t    =0.;
    allocate ( ac%qv    (1:kd)); ac%qv   =0.;
    allocate ( ac%ql    (1:kd)); ac%ql   =0.;
    allocate ( ac%qi    (1:kd)); ac%qi   =0.;
    allocate ( ac%thc   (1:kd)); ac%thc  =0.;
    allocate ( ac%qct   (1:kd)); ac%qct  =0.;
    allocate ( ac%thv   (1:kd)); ac%thv  =0.;
    allocate ( ac%nu    (1:kd)); ac%nu   =0.;
    allocate ( ac%leff  (1:kd)); ac%leff =0.;
    allocate ( ac%hl    (1:kd)); ac%hl   =0.;
    allocate ( ac%buo   (1:kd)); ac%buo  =0.;
  end subroutine ac_init_k

!#####################################################################
!#####################################################################

  subroutine ac_clear_k(ac)
    type(adicloud), intent(inout) :: ac
    ac%t    =0.;    ac%qv   =0.;    ac%ql   =0.;
    ac%qi   =0.;    ac%thc  =0.;    ac%qct  =0.;
    ac%thv  =0.;    ac%nu   =0.;    ac%leff =0.; ac%hl   =0.;
    ac%buo  =0.;
  end subroutine ac_clear_k

!#####################################################################
!#####################################################################

  subroutine ac_end_k(ac)
    type(adicloud), intent(inout) :: ac
    deallocate (ac%t, ac%qv, ac%ql, ac%qi, ac%thc, ac%qct,  &
                ac%thv, ac%nu, ac%leff, ac%hl, ac%buo )
  end subroutine ac_end_k

!#####################################################################
!#####################################################################

  subroutine pack_sd_k (land, coldT, delt, pmid, pint, zmid, zint, &
                      u, v, t, qv, ql, qi, qa, qn, am1, am2, am3, am4,&
                        tracers, sd, Uw_p)

    real,    intent(in)              :: land
    logical, intent(in)              :: coldT
    real,    intent(in)              :: delt
    real, intent(in), dimension(:)   :: pmid, zmid !pressure&height@mid level
    real, intent(in), dimension(:)   :: pint, zint !pressure&height@ interface level
    real, intent(in), dimension(:)   :: u, v       !wind profile (m/s)
    real, intent(in), dimension(:)   :: t, qv      !temperature and specific humidity
    real, intent(in), dimension(:)   :: ql, qi, qa, qn !cloud tracers
    real, intent(in), dimension(:)   :: am1, am2, am3, am4  ! aerosal species
    real, intent(in), dimension(:,:) :: tracers        !env. tracers    
    type(sounding), intent(inout)    :: sd
    type(uw_params), intent(inout)    :: Uw_p

!++++yim
    integer :: k, nk, m
    real, parameter :: ptopconv = 3000.

    !Pack environmental sounding; layers are numbered from bottom up!=
    sd % kmax   = size(t)
    sd % land   = land
    sd % coldT  = coldT
    sd % delt   = delt
    sd % ps(0)  = pint(sd%kmax+1);
    sd % zs(0)  = zint(sd%kmax+1);
    sd % ktopconv = 1

    do k=1, sd%kmax
       nk=sd%kmax-k+1
       sd % p     (k) = pmid(nk)
       sd % z     (k) = zmid(nk);
       sd % ps    (k) = pint(nk); 
       sd % zs    (k) = zint(nk); 
       sd % t     (k) = t   (nk)
       !prevent negative values for qv,ql,qi,qa,qn
       sd % qv    (k) = max(qv(nk), 4.e-10) 
       sd % ql    (k) = max(ql(nk), 0.)
       sd % qi    (k) = max(qi(nk), 0.)
       sd % qa    (k) = max(qa(nk), 0.)
       sd % qn    (k) = max(qn(nk), 0.)
       sd % u     (k) = u(nk)
       sd % v     (k) = v(nk)
       !yim's aerosol
       sd % am1  (k) = am1(nk)
       sd % am2  (k) = am2(nk)
       sd % am3  (k) = am3(nk)
       sd % am4  (k) = am4(nk)
!++++yim
       do m=1, size(tracers,2)
          sd % tr (k,m) = tracers (nk,m)
       end do
       if (sd % p (k) > ptopconv) sd % ktopconv = k
    end do
  end subroutine pack_sd_k

!#####################################################################
!#####################################################################

  subroutine extend_sd_k(sd, pblht, doice, Uw_p)
    type(sounding), intent(inout) :: sd
    real, intent(in)              :: pblht
    logical, intent(in)           :: doice
    type(uw_params), intent(inout)    :: Uw_p

    integer :: k, kl, ktoppbl
    real    :: sshl0a, sshl0b, ssthc0a, ssthc0b, ssqct0a, ssqct0b
    real    :: hl0bot, thc0bot, qct0bot, hl0top, thc0top, qct0top
    real    :: thj, qvj, qlj, qij, qse, dpsum
    real, dimension(size(sd%tr,2)) :: sstr0a, sstr0b

    sd % exners(0) = exn_k(sd%ps(0),Uw_p);
    if (doice) then
       sd%nu(:)= max(min((268. - sd % t(:))/20.,1.0),0.0);
    else
       sd%nu(:)=0.
    end if
    sd % leff(:) = (1-sd%nu(:))*Uw_p%HLv + sd%nu(:)*Uw_p%HLs
    sd % qct (:) = sd%qv(:)+sd%ql(:)+sd%qi(:)
    sd % hl  (:) = Uw_p%cp_air*sd%t(:)+Uw_p%grav*sd%z(:)-  &
                   sd%leff(:)*(sd%ql(:)+sd%qi(:))
    sd % qint = 0.
    sd % rhav = 0.; dpsum=0.
    do k=1, sd%ktopconv !sd%kmax
       sd % dp    (k) = sd%ps(k-1)-sd%ps(k)
       sd % dz    (k) = sd%zs(k)  -sd%zs(k-1)
       sd % exner (k) = exn_k(sd%p (k), Uw_p)
       sd % exners(k) = exn_k(sd%ps(k),Uw_p)
       sd % thc   (k) = sd%t(k) / sd%exner(k) 
       sd % qs    (k) = qsat_k(sd%t(k), sd%p(k),Uw_p, qv=sd%qv(k))
       sd % rh    (k) = min(sd%qv(k)/sd%qs(k),1.)
       sd % thv   (k) = sd%t(k)/sd%exner(k) *   &
                        (1.+Uw_p%zvir*sd%qv(k)-sd%ql(k)-sd%qi(k))
       sd % rho   (k) = sd % p(k)/     &
                        (Uw_p%rdgas * sd % thv(k) * sd % exner(k))
       sd % qint      =sd % qint + sd%qct(k)*sd%dp(k)
       if (sd%p(k) .gt. 40000) then
          sd % rhav = sd % rhav+ sd%rh (k)*sd%dp(k)
          dpsum      = dpsum + sd%dp(k)
       end if
    end do
    sd % qint = sd % qint / Uw_p%grav
    sd % rhav = sd % rhav / dpsum
    sd % hm  (:) = Uw_p%cp_air*sd%t(:)+Uw_p%grav*sd%z(:)+sd%leff(:)*sd%qv(:)
    sd % hms (:) = Uw_p%cp_air*sd%t(:)+Uw_p%grav*sd%z(:)+sd%leff(:)*sd%qs(:)

   !Finite-Volume intepolation
    kl=sd%ktopconv !sd%kmax-1
    sshl0b  = (sd%hl (2)-sd%hl (1))/(sd%p(2)-sd%p(1))
    ssthc0b = (sd%thc(2)-sd%thc(1))/(sd%p(2)-sd%p(1))
    ssqct0b = (sd%qct(2)-sd%qct(1))/(sd%p(2)-sd%p(1))
    sstr0b(:) = (sd%tr(2,:)-sd%tr(1,:))/(sd%p(2)-sd%p(1))

    do k=2,kl
       sshl0a  = (sd%hl (k)-sd%hl (k-1))/(sd%p(k)-sd%p(k-1))
       if(sshl0a.gt.0)then
          sd%sshl (k-1) = max(0.,min(sshl0a,sshl0b))
       else
          sd%sshl (k-1) = min(0.,max(sshl0a,sshl0b))
       endif
       sshl0b = sshl0a
       ssthc0a = (sd%thc(k)-sd%thc(k-1))/(sd%p(k)-sd%p(k-1))
       if(ssthc0a.gt.0)then
          sd%ssthc(k-1) = max(0.,min(ssthc0a,ssthc0b))
       else
          sd%ssthc(k-1) = min(0.,max(ssthc0a,ssthc0b))
       endif
       ssthc0b = ssthc0a
       ssqct0a = (sd%qct(k)-sd%qct(k-1))/(sd%p(k)-sd%p(k-1))
       if(ssqct0a.gt.0)then
          sd%ssqct(k-1) = max(0.,min(ssqct0a,ssqct0b))
       else
          sd%ssqct(k-1) = min(0.,max(ssqct0a,ssqct0b))
       endif
       ssqct0b = ssqct0a
       sstr0a(:) = (sd%tr(k,:)-sd%tr(k-1,:))/(sd%p(k)-sd%p(k-1))
       where (sstr0a(:) > 0)
          sd%sstr(k-1,:) = max(0.,min(sstr0a(:),sstr0b(:)))
       elsewhere
          sd%sstr(k-1,:) = min(0.,max(sstr0a(:),sstr0b(:)))
       end where
       sstr0b(:) = sstr0a(:)
    enddo
    do k = 2,kl-1 !wind shear
       sd%dudp(k) = (sd%u(k+1)-sd%u(k-1))/(sd%p(k+1)-sd%p(k-1))
       sd%dvdp(k) = (sd%v(k+1)-sd%v(k-1))/(sd%p(k+1)-sd%p(k-1))
    end do
    sd%sshl (kl)=sd%sshl (kl-1)
    sd%ssthc(kl)=sd%ssthc(kl-1)
    sd%ssqct(kl)=sd%ssqct(kl-1)
    sd%sstr(kl,:)=sd%sstr(kl-1,:)

    do k = 1,sd%ktopconv !kl cannot be pver since ps0(pver)=0
       hl0bot  = sd%hl (k)+sd%sshl (k)*(sd%ps(k-1)-sd%p(k))
       thc0bot = sd%thc(k)+sd%ssthc(k)*(sd%ps(k-1)-sd%p(k))
       qct0bot = sd%qct(k)+sd%ssqct(k)*(sd%ps(k-1)-sd%p(k))
       call findt_k(sd%zs(k-1),sd%ps(k-1),hl0bot,qct0bot,thj,  &
                    qvj,qlj,qij,qse,sd%thvbot(k),doice, Uw_p)
       hl0top  = sd%hl (k)+sd%sshl (k)*(sd%ps(k)-sd%p(k))
       thc0top = sd%thc(k)+sd%ssthc(k)*(sd%ps(k)-sd%p(k))
       qct0top = sd%qct(k)+sd%ssqct(k)*(sd%ps(k)-sd%p(k))
       call findt_k(sd%zs(k),sd%ps(k),hl0top,qct0top,thj,  &
                    qvj,qlj,qij,qse,sd%thvtop(k),doice, Uw_p)
    enddo

    ktoppbl=1;
    do k = 2, kl-1
       if ((pblht+sd%zs(0)+1.-sd%zs(k))*(pblht+sd%zs(0)+1.-sd%zs(k+1)).lt.0.) then
          ktoppbl=k; exit;
       endif
    end do
    !given a layer index k (here k=kinv); !its bottom interface 
    !level pressure is ps0(k-1) [here ps0(kinv-1)] and its bottom
    !interface level virt. pot. temperature is thv(k) [thv0bot(kinv)]
    sd % ktoppbl = ktoppbl
    sd % kinv    = ktoppbl+1 
    sd % pinv    = sd % ps    (sd % kinv-1) 
    sd % zinv    = sd % zs    (sd % kinv-1) 
    sd % thvinv  = sd % thvbot(sd % kinv)
    sd % pblht   = pblht
  end subroutine extend_sd_k

!#####################################################################
!#####################################################################

  subroutine adi_cloud_k (zsrc, psrc, hlsrc, thcsrc, qctsrc, sd,   &
                          Uw_p, dofast, doice, ac, rmuz)
  
    real, intent(inout) :: zsrc, psrc, hlsrc, thcsrc, qctsrc
    type(sounding), intent(in)    :: sd 
    type(uw_params), intent(inout)    :: Uw_p
    logical,        intent(in)    :: dofast, doice
    type(adicloud), intent(inout) :: ac
    real, intent(in), optional :: rmuz
    
    integer :: k, kl, klcl
    real    :: qs
    real    :: hl0lcl, thc0lcl, qct0lcl, thv0lcl, rho0lcl
    real    :: cin, cinlcl, plfc, thvubot, thvutop
    real    :: thj, qvj, qlj, qij, qse, thvj
    real    :: cape, plnb, chi, tmp, rhtmp
    real    :: alpha

    call ac_clear_k(ac);
    ac%klcl=0; ac%klfc=0; ac%klnb=0; 
    ac%plcl=0.; ac%zlcl=0.; ac%thvlcl=0.; ac%thv0lcl=0; ac%rho0lcl=0.;
    ac%plfc=0.; ac%plnb=0.; ac%cape=0.; ac%cin=0.;

!!$!below is pzhu's version now commented out
!!$    esrc=qctsrc*psrc/100./(qctsrc+epsilo)             ! water vapor pressure
!!$    tdsrc=tfreeze/(1-tfreeze*rvgas*log(esrc/6.11)/HLv)! dew-point of source air
!!$    temsrc=thcsrc*exn(psrc)                           ! temperature of source air
!!$    zlcl=123.5*(temsrc-tdsrc)+zsrc                    ! from sea-level
!!$    tlcl=temsrc-0.0098*(zlcl-zsrc)
!!$    ac % zlcl =zlcl
!!$    ac % plcl =psrc*(tlcl/temsrc)**(1./Kappa)


    !calculate lifted condensation level of air at parcel origin level
    !(within 0.2% of formula of Bolton, mon. wea. rev.,1980)
    call findt_k(zsrc, psrc, hlsrc, qctsrc, thj, qvj,    &
                 qlj, qij, qse, thvj, doice, Uw_p)
    tmp=thj*exn_k(psrc,Uw_p)
    rhtmp=min(qctsrc/qse,1.)
    chi=tmp/(1669.0-122.0*rhtmp-tmp)
    ac%plcl=psrc*(rhtmp**chi); !Emanuel's calculation, results nearly identical to RAS

    klcl=0;  !klcl is the layer containing the LCL, i.e., ps0(klcl)<=plcl(i,j)
    do k=1,sd % ktopconv-1
       if(sd%ps(k).le.ac%plcl) then
          klcl=k; 
          ac%zlcl=sd%zs(k)-(ac%plcl-sd%ps(k))/sd%dp(k)*sd%dz(k);
          exit
       else
          klcl   =sd % ktopconv
          ac%zlcl=sd % zs(klcl)
       end if
    end do
    if (sd%ps(1).le.ac%plcl) then
       klcl=2; ac%plcl=sd%ps(1); ac%zlcl=sd%zs(1); 
    end if
    ac % klcl=klcl; 

    if (dofast.and.(ac%klcl.eq.0 .or. ac%plcl.gt.sd%ps(1) .or. ac%plcl.lt.20000.)) return;

    call findt_k(ac%zlcl, ac%plcl, hlsrc, qctsrc, thj,   &
                 qvj, qlj, qij, qse, ac%thvlcl, doice, Uw_p)
    ac % hlsrc  = hlsrc
    ac % thcsrc = thcsrc
    ac % qctsrc = qctsrc

    hl0lcl  = sd%hl (klcl)+sd%sshl (klcl)*(ac%plcl-sd%p(klcl))
    thc0lcl = sd%thc(klcl)+sd%ssthc(klcl)*(ac%plcl-sd%p(klcl))
    qct0lcl = sd%qct(klcl)+sd%ssqct(klcl)*(ac%plcl-sd%p(klcl))
    call findt_k(ac%zlcl,ac%plcl,hl0lcl,qct0lcl,thj,qvj,  &
                 qlj,qij,qse,thv0lcl, doice, Uw_p)
    rho0lcl = ac%plcl/(Uw_p%rdgas*thv0lcl*exn_k(ac%plcl,Uw_p))
    ac % thv0lcl= thv0lcl
    ac % rho0lcl= rho0lcl


    kl=sd % ktopconv-1

    if (present(rmuz)) then
      if (rmuz /= 0.0) then
        do k=1,kl
         call findt_k(sd%zs(k),sd%ps(k), hlsrc, qctsrc, thj, ac%qv(k), &
                      ac%ql(k), ac%qi(k), qs, ac%thv(k), doice, Uw_p)
         ac%t(k) = thj*exn_k(sd%ps(k),Uw_p)
         alpha = MIN(1.0, rmuz*(sd%zs(k+1) - sd%zs(k)))
         hlsrc = (1.0-alpha)*hlsrc + alpha*sd%hl(k+1)
         qctsrc =(1.0-alpha)*qctsrc + alpha*sd%qct(k+1)
       end do
    else
      do k=1,kl
        call findt_k(sd%zs(k),sd%ps(k), hlsrc, qctsrc, thj, ac%qv(k), &
                     ac%ql(k), ac%qi(k), qs, ac%thv(k), doice, Uw_p)
        ac%t(k) = thj*exn_k(sd%ps(k),Uw_p)
      end do
    endif
  else
    do k=1,kl
       call findt_k(sd%zs(k),sd%ps(k), hlsrc, qctsrc, thj, ac%qv(k), &
                    ac%ql(k), ac%qi(k), qs, ac%thv(k), doice, Uw_p)
       ac%t(k) = thj*exn_k(sd%ps(k),Uw_p)
       ac%buo(k) = ac%thv(k) - sd%thvtop(k)
    end do
  endif


    !Determine the convective inhibition (CIN)
    CIN = 0.
    cinlcl = 0.
    plfc   = 0.

    !define CIN based on LFC  
    do k = sd % kinv, kl-1
       if(k.eq.klcl-1) then !klcl-1 < layer < klcl
          thvubot=ac % thv (k); thvutop=ac % thvlcl
          call getcin_k(sd%ps(k),sd%thvtop(k),ac%plcl,  &
                        thv0lcl,thvubot,thvutop,plfc,cin,Uw_p)
          cinlcl = cin
          thvubot=thvutop; thvutop=ac % thv (k+1)
          call getcin_k(ac%plcl,thv0lcl,sd%ps(k+1),sd%thvtop(k+1),  &
                        thvubot,thvutop,plfc,cin,Uw_p)
          if(plfc.gt.0. .and. plfc.lt.ac%plcl) exit
       else
          thvubot=ac % thv (k); thvutop=ac % thv (k+1)
          call getcin_k(sd%ps(k),sd%thvtop(k),sd%ps(k+1),  &
                        sd%thvtop(k+1),thvubot,thvutop,plfc, cin, Uw_p)
          if(plfc.gt.0. .and. plfc.lt.ac%plcl) exit
       endif
    enddo
 
    ac % cin =cin; !CIN has been estimated
    ac % plfc=plfc;

    if (dofast .and. (ac%plfc .lt. 500.) ) return; !miz

    !calculate cape=================
    if (ac%plfc.eq.0.0) then
       ac%cape=0.0;
       ac%plnb=0.0;
    else
       ac % klfc=0; !klfc is the layer containing the plfc, i.e., ps0(klfc)<=plfc(i,j)
       do k=1,kl 
          if(sd%ps(k).le.ac%plfc) then
             ac % klfc=max(k,2); exit
          end if
       end do
       plnb = 0.; cape=0.0;
       do k = ac % klfc-1, kl !for m45l48: sd%kmax
          thvubot=ac % thv (k); thvutop=ac % thv (k+1)
          call getcape_k(sd%ps(k),sd%thvtop(k),sd%ps(k+1),  &
                         sd%thvtop(k+1),thvubot,thvutop,plnb,cape,Uw_p)
          if(plnb.gt.0.) exit
       enddo
       ac%cape=cape
       ac%plnb=plnb
    end if

  end subroutine adi_cloud_k

!#####################################################################
!#####################################################################

 function qsat_k(temp, p,Uw_p, qv)
   real, intent(in)    :: temp, p
   type(uw_params), intent(inout) :: Uw_p
   real, intent(in), optional :: qv
   real :: qsat_k, t
   integer :: ier
 
   t = min(max(temp,Uw_p%tkmin),Uw_p%tkmax)
   if (present(qv)) then
     call compute_qs_k (t, p, Uw_p%epsilo, Uw_p%zvir, qsat_k, ier, &
                                                               q = qv)
   else
     call compute_qs_k (t, p, Uw_p%epsilo, Uw_p%zvir, qsat_k, ier)
   endif
 
   return
   end function qsat_k


!#####################################################################
!#####################################################################

  subroutine qses_k(temp, p, qs, es,Uw_p                     )
   real, intent(in)    :: temp, p
   type(uw_params), intent(inout) :: Uw_p
   real, intent(inout) :: qs, es
   real :: t
   integer :: ier

   t = min(max(temp,Uw_p%tkmin),Uw_p%tkmax)
   call compute_qs_k (t, p, Uw_p%epsilo, Uw_p%zvir, qs, ier)
  
   return
   end subroutine qses_k


!#####################################################################
!#####################################################################

! Subroutine to initialize the lookup table used to speed up
! the computation of the exner function (cjg)
 
  subroutine exn_init_k(Uw_p)       
 
    type(uw_params), intent(in) :: Uw_p
    

    integer k
    real p

!   Initialize 1d lookup table for exner function

  if ( .not. ex_lookup_allocated) then
!   if ( allocated(ex_lookup) ) deallocate(ex_lookup)
    allocate( ex_lookup(npex) )

    dpex = (pexmax-pexmin)/(npex-1)
    rdpex = 1.0 / dpex
    do k=1,npex
      p = (k-1)*dpex + pexmin
      ex_lookup(k) = (p/Uw_p%p00) ** Uw_p%kappa
    end do
    ex_lookup_allocated = .true.
 endif

  end subroutine exn_init_k

!#####################################################################
!#####################################################################

  subroutine exn_end_k()
 
    if ( allocated(ex_lookup) ) deallocate(ex_lookup)
    ex_lookup_allocated = .false.
 
  end subroutine exn_end_k
 
!#####################################################################
!#####################################################################

! Subroutine to compute the exner function using a lookup
! table for better performance (cjg)

  function exn_k(p,Uw_p)      
 
    real :: exn_k
    real, intent(in)  :: p
    type(uw_params), intent(inout) :: Uw_p

    integer k, kp1
    real w

    k = 0
    if ( p-pexmin.gt.0.0 ) k = int( (p-pexmin)*rdpex ) + 1
 
    if ( k.ge.1 .and.  k.lt.npex ) then
      kp1 = k+1
      w = ( p  - (k-1)*dpex  - pexmin  )*rdpex
      exn_k = (1-w)*ex_lookup(k) + w*ex_lookup(kp1)
    else
      exn_k = (p/Uw_p%p00) ** Uw_p%kappa
    end if
 
  end function exn_k

! Old subroutine that doesn't use a lookup table

! function exn_k(p,Uw_p)
!   real :: exn_k
!   real, intent(in)  :: p
!  type(uw_params), intent(inout) :: Uw_p
!   exn_k = (p/Uw_p%p00) ** Uw_p%Kappa
! end function exn_k

!#####################################################################
!#####################################################################

  subroutine conden_k(p,thc,qt,th,qv,ql,qi,qs,thv, Uw_p)
    real,     intent(in)  :: p, thc, qt
   type(uw_params), intent(inout) :: Uw_p
    real,     intent(out) :: th, qv, ql, qi, qs, thv
    real      tc, exn, leff, nu, qc, temps, tc1
    integer   iteration, id_check
    integer :: niteration = 5

    exn = (p/Uw_p%p00)**Uw_p%Kappa
    tc = thc * exn
    nu = max(min((268.-tc)/20.,1.0),0.0);
    leff = (1-nu)*Uw_p%HLv + nu*Uw_p%HLs
  
    temps = tc
    qs=qsat_k(temps,p,Uw_p)
    
    if(qs.gt.qt) then
       id_check=0
    else
       do iteration = 1,niteration
          temps = temps + ((tc-temps)*Uw_p%cp_air/leff + (qt -qs))/        &
               (Uw_p%cp_air/leff + Uw_p%epsilo*leff*qs/Uw_p%rdgas/temps/temps)
          qs = qsat_k(temps,p,Uw_p)
       enddo
       tc1=temps-leff/Uw_p%cp_air*(qt-qs)
       if(abs(tc1-tc).lt.1.0) then
          id_check=0
       else
          id_check=1; print*,'ID_CHECK=11111111111111111111111111111111'
       endif
    endif
    qc = max(qt-qs, 0.)
    qv = qt - qc
    ql = (1-nu)*qc
    qi = nu*qc !temps=tc+leff/Uw_p%cp_air*qc
    th = temps/exn
    thv=th*(1.+Uw_p%zvir*qv-ql-qi)
  end subroutine conden_k

!#####################################################################
!#####################################################################
! Subroutine to initialize lookup tables used to speed up findt (cjg)

  subroutine findt_init_k (Uw_p)                               
 
    implicit none

!   real, intent(in) :: epsilo, hlv, hls, cp_air, tkmin, tkmax
    type(uw_params), intent(inout) :: Uw_p

    integer i, k
    real ta, p, t

!   Allocate memory to hold lookup table

  if (.not. ta_lookup_allocated) then
!   if ( allocated(ta_lookup) ) deallocate(ta_lookup)
    allocate( ta_lookup(nta,np1+np2,0:1) )

!   Initialize 2d look up tables for temperature conversion

    dta = (tamax-tamin)/(nta-1)
    rdta = 1.0 / dta
    dp1 = (p1max-p1min)/(np1-1)
    rdp1 = 1.0 / dp1
    dp2 = (p2max-p2min)/(np2-1)
    rdp2 = 1.0 / dp2

    do i=1,nta
      ta = (i-1)*dta + tamin
      do k=1,np1
        p = (k-1)*dp1 + p1min
         call solve_ta_k(ta,p,t,0,Uw_p)
         ta_lookup(i,k,0) = t
         call solve_ta_k(ta,p,t,1,Uw_p)
         ta_lookup(i,k,1) = t
       end do
       do k=np1+1,np1+np2
         p = (k-np1-1)*dp2 + p2min
         call solve_ta_k(ta,p,t,0,Uw_p)
         ta_lookup(i,k,0) = t
         call solve_ta_k(ta,p,t,1,Uw_p)
         ta_lookup(i,k,1) = t
       end do
     end do
     ta_lookup_allocated = .true.
  endif

  end subroutine findt_init_k
 
!#####################################################################
!#####################################################################

  subroutine findt_end_k()
 
    if ( allocated(ta_lookup) ) deallocate(ta_lookup)
    ta_lookup_allocated = .false.

  end subroutine findt_end_k

!#####################################################################
!#####################################################################

  subroutine getcin_k(pbot,thv0bot,ptop,thv0top,thvubot,  &
                      thvutop,plfc,cin,Uw_p)
    
    real,    intent(in)    :: pbot,thv0bot,ptop,thv0top,thvubot,thvutop
    real,    intent(inout) :: plfc,cin
    real                   :: frc, rhom, delp
   type(uw_params), intent(inout) :: Uw_p

    delp=(pbot-ptop)
    rhom = pbot/(Uw_p%rdgas*thv0bot*exn_k(pbot,Uw_p))+ptop/  &
           (Uw_p%rdgas*thv0top*exn_k(ptop,Uw_p))

    if(thvubot.gt.thv0bot.and.thvutop.gt.thv0top)then
       !Both top and bottom positively buoyant
       plfc = pbot
    elseif(thvubot.le.thv0bot.and.thvutop.le.thv0top)then 
       !Both top and bottom negatively buoyant
       cin  = cin  - ((thvubot/thv0bot-1.)+(thvutop/thv0top-1.)) * delp / rhom
    elseif(thvutop.le.thv0top.and.thvubot.gt.thv0bot)then
       !Top negatively buoyant; Bottom positively buoyant
       frc  = (thvutop/thv0top-1.)/((thvutop/thv0top-1.)-(thvubot/thv0bot-1.))
       delp = (ptop+frc*delp) - ptop
       cin  = cin - (thvutop/thv0top-1.) * delp / rhom
    else                                                  
       !Top positively buoyant; Bottom negatively buoyant
       frc = (thvubot/thv0bot-1.)/((thvubot/thv0bot-1.)-(thvutop/thv0top-1.))
       plfc = pbot - frc * (pbot-ptop)
       delp = pbot - plfc
       cin  = cin - (thvubot/thv0bot-1.) * delp / rhom
    endif
  end subroutine getcin_k

!#####################################################################
!#####################################################################

  subroutine getcape_k (pbot,thv0bot,ptop,thv0top,thvubot,  &
                        thvutop,plnb,cape,Uw_p)
   
    real,    intent(in)    :: pbot,thv0bot,ptop,thv0top,thvubot,thvutop
    real,    intent(inout) :: plnb,cape
   type(uw_params), intent(inout) :: Uw_p
    real                   :: frc, rhom, delp

    delp=(pbot-ptop)
    rhom = pbot/(Uw_p%rdgas*thv0bot*exn_k(pbot,Uw_p))+ptop/  &
           (Uw_p%rdgas*thv0top*exn_k(ptop,Uw_p))

    if(thvubot.gt.thv0bot.and.thvutop.gt.thv0top)then
       !Both top and bottom positively buoyant
       cape = cape + ((thvubot/thv0bot - 1.) + (thvutop/thv0top - 1.))*&
              delp/rhom
    elseif(thvubot.le.thv0bot.and.thvutop.le.thv0top)then 
       !Both top and bottom negatively buoyant
       plnb = pbot
    elseif(thvutop.le.thv0top.and.thvubot.gt.thv0bot)then
       !Top negatively buoyant; Bottom positively buoyant
       frc  = (thvubot/thv0bot-1.)/((thvubot/thv0bot-1.)-  &
              (thvutop/thv0top-1.))
       plnb = pbot - frc * (pbot-ptop)
       delp = pbot - plnb
       cape = cape + (thvubot/thv0bot-1.) * delp / rhom
    else                                                  
       !Top positively buoyant; Bottom negatively buoyant
       frc  = (thvutop/thv0top-1.)/((thvutop/thv0top-1.)- &
               (thvubot/thv0bot-1.))
       delp = (ptop+frc*delp) - ptop
       cape = cape + (thvutop/thv0top-1.) * delp / rhom
    endif

  end subroutine getcape_k


!###################################################################
!###################################################################

subroutine pack_sd_lsm_k (do_lands, land, coldT, dt, pf, ph, zf, zh, &
                          t, qv, tracers, sd)

  logical,            intent(in)    :: do_lands
  real,               intent(in)    :: land
  logical,            intent(in)    :: coldT
  real,               intent(in)    :: dt
  real, dimension(:), intent(in)    :: pf, ph, zf, zh, t, qv
!++++yim
  real, dimension(:,:), intent(in)    :: tracers
  type(sounding),     intent(inout) :: sd

!++++yim
  real, parameter :: ptopconv = 3000.
  integer :: k, nk, kmax, m

  kmax=size(t)
  sd % kmax   = kmax
  if (do_lands) then
    sd % land   = land  
    sd % coldT  = coldT    
  else
    sd % land   = 0.
    sd % coldT  = .false.
  endif 
  sd % delt   = dt   
  sd % ps(0)  = ph(kmax+1)
  sd % zs(0)  = zh(kmax+1)
  sd % ktopconv = 1

  do k=1, kmax
     nk=kmax-k+1
     sd % p (k) = pf(nk)
     sd % z (k) = zf(nk)
     sd % ps(k) = ph(nk)
     sd % zs(k) = zh(nk)
     sd % t (k) = t (nk)
     sd % qv(k) = max(qv(nk)/(1.+qv(nk)), 4.e-10) !for donner_deep where mixing-ratio passed in
     sd % ql(k) = 0.
     sd % qi(k) = 0.
     sd % qa(k) = 0.
     sd % qn(k) = 0.
     sd % u (k) = 0.
     sd % v (k) = 0.
     if (sd % p (k) > ptopconv) sd % ktopconv = k
!++++yim
       do m=1, size(tracers,2)
          sd % tr (k,m) = tracers (nk,m)
       end do
  end do

end subroutine pack_sd_lsm_k

!###################################################################
!###################################################################

! subroutine findt_k(z,p,hl,qt,th,qv,ql,qi,qs,thv,doice, Uw_p)
  subroutine findt_new_k(z,p,hl,qt,th,qv,ql,qi,qs,thv,doice, Uw_p)

      implicit none

      real, intent(in)  :: z, p, hl, qt
      real, intent(out) :: th, qv, ql, qi, qs, thv
      logical, intent(in) :: doice
      type(uw_params), intent(inout) :: Uw_p

      real hh, temp, temp_unsat, temp_sat, temp1, temp2, dtemp
      real tempmin, tempmax
      real f, f1, fmin, fmax
      real es, nu, leff, qc

      integer n, nmax
      integer hflag
      logical lbracket

      hflag = 1
      if (doice) hflag = 2

!     Definitely unsaturated case
!     The unsaturated temperature (temp_unsat) is always lower or equal 
!     to the actual temperature (temp). 
!     Therefore qs(temp_unsat) <= qs(temp), since qs(T) is monotically
!     increasing with T.

      temp = (hl-Uw_p%grav*z)/Uw_p%cp_air
      call qses_k(temp,p,qs,es,Uw_p)
      if ( qs.gt.qt ) then
        ql  = 0.
        qi  = 0.
        qv  = qt
        th  = temp/exn_k(p,Uw_p)
        thv = th*(1.+Uw_p%zvir*qv-ql-qi)
        return
      end if
      temp_unsat = temp

!     Possibly saturated case
!     Absolute bounds on the temperature

      hh = hl - Uw_p%grav*z
      tempmin = max( temp_unsat - 1.0, Uw_p%tkmin )
      tempmax = min( temp_unsat + Uw_p%hls*(qt-qs)/Uw_p%cp_air + 1.0,  &
                     Uw_p%tkmax )
      fmin = saturated_k(tempmin,hh,qt,p,hflag,Uw_p)
      fmax = saturated_k(tempmax,hh,qt,p,hflag,Uw_p)

!     The bounds on temperature are likely to be too large,
!     so we need to bracket the solution first. 
!     We search for the root closest to tempmin.

      lbracket = .false.
      dtemp = 10.0

!     Is the initial bracket good enough ?

      if ( tempmax-tempmin.le.dtemp ) then
        if ( fmin*fmax.le.0.0 ) then
          lbracket = .true.
          temp1 = tempmin
          temp2 = tempmax
        else
          dtemp = tempmax - tempmin
        endif
      endif

!     If not refine it

      do while (.not.lbracket .and. dtemp.ge.0.2)
      temp1 = tempmin
      temp2 = tempmax
      f1 = saturated_k(temp1,hh,qt,p,hflag,Uw_p)
      nmax = int( (temp2-temp1)/dtemp ) + 1
      temp = temp1
      do n=1,nmax
        temp = MIN(temp + dtemp, tempmax)
        f = saturated_k(temp,hh,qt,p,hflag,Uw_p)
        if (f1*f.le.0) then
          temp2 = temp
          lbracket = .true.
          exit
        endif
        temp1 = temp
        f1 = f
      enddo
      dtemp = 0.5 * dtemp
      enddo

!     Did we make it ?

      if (lbracket) then

!       Now find the root within the bracket

        temp_sat = zriddr_k(saturated_k,temp1,temp2,hh,qt,p,hflag,1.e-3,Uw_p)

!       Choose between one of the two choices, the highest value is temp

        if (temp_sat .gt. temp_unsat ) then
          temp = temp_sat
        else
          temp = temp_unsat
        endif

        call qses_k(temp,p,qs,es,Uw_p)
        if (doice) then
          nu = max(min((268.-temp)/20.,1.0),0.0)
        else
          nu = 0.0
        endif
        leff = (1.-nu)*Uw_p%hlv + nu*Uw_p%hls

        qc = max(qt-qs, 0.)
        qv = qt - qc
        ql = (1.-nu)*qc
        qi = nu*qc
        th = temp/exn_k(p,Uw_p)
        thv=th*(1.+Uw_p%zvir*qv-ql-qi)
        return

      else

!RSH2    write(*,*) 'WARNING findt_new_k: not bracketed'
!        write(*,*) 'Not bracketed i = ',i
!RSH :: need to properly process this error condition (if in fact it is
!       possible to occur)
!       write(*,*) 'Not bracketed temp1, temp2, dtemp, f1, f, tempmin&
!                    & tempmax, fmin, fmax = ', &
!               temp1, temp2, dtemp, f1, f, tempmin, tempmax, fmin, fmax
        temp = temp_unsat
        qv = qt
        ql = 0.0
        qi = 0.0
        th = temp/exn_k(p,Uw_p)
        thv=th*(1.+Uw_p%zvir*qv)
        return
        
      endif

      end subroutine findt_new_k
!     end subroutine findt_k

!     -----------------------------------------------------------------
!     To diagnose temp from hl and qt, we need to find the zero
!     of this function

      real function saturated_k(temp,hh,qt,p,hflag,Uw_p)
      implicit none

      real, intent(in) :: temp, hh, qt, p
      type(uw_params), intent(inout) :: Uw_p
  
      integer, intent(in) :: hflag

      real es, qs, leff, nu

      call qses_k(temp,p,qs,es,Uw_p)

      select case (hflag)
        case (0)
          leff = Uw_p%hls
        case (1)
          leff = Uw_p%hlv
        case (2)
          nu = max(min((268.0-temp)/20.,1.0),0.0)
          leff = (1.0-nu)*Uw_p%hlv + nu*Uw_p%hls
      end select
      saturated_k = hh - Uw_p%cp_air*temp + Leff*(qt-qs)

      return
      end function saturated_k

!###################################################################
!###################################################################
! Newest findt subroutine (cjg). Comparable in accuracy with
! the revised version (findt_new_k), but substantially
! faster thanks to the use of lookup tables.

! subroutine findt_fast_k(z,p,hl,qt,th,qv,ql,qi,qs,thv,doice, Uw_p)
  subroutine findt_k(z,p,hl,qt,th,qv,ql,qi,qs,thv,doice, Uw_p)

    implicit none

    real, intent(in)  :: z, p, hl, qt
    real, intent(out) :: th, qv, ql, qi, qs, thv
    logical, intent(in) :: doice
    type(uw_params), intent(inout) :: Uw_p

    integer i, il, ii, k
    integer ip1, kp1
    integer hflag

    real hh, tl, tal, tai, t0, t1, temp, temp_unsat, temp_sat
    real es
    real qc, nu, leff

    real u, w

    hflag = 1
    if (doice) hflag = 2

!   Definitely unsaturated case
!   The unsaturated temperature (temp_unsat) is always lower or equal 
!   to the actual temperature (temp). 
!   Therefore qs(temp_unsat) <= qs(temp), since qs(T) is monotically
!   increasing with T.

    tl = (hl-Uw_p%grav*z)/Uw_p%cp_air
    call qses_k(tl,p,qs,es,Uw_p)
    if ( qs.gt.qt .or. tl >= 372.9 ) then
      ql  = 0.
      qi  = 0.
      qv  = qt
      th  = tl/exn_k(p,Uw_p)          
      thv = th*(1.+Uw_p%zvir*qv-ql-qi)
      return
    end if
    temp_unsat = tl

!   Compute temperature assuming saturated air

    tai = ( hl - Uw_p%grav*z + Uw_p%hls*qt ) / Uw_p%cp_air
    tal = ( hl - Uw_p%grav*z + Uw_p%hlv*qt ) / Uw_p%cp_air

!   Are we within the lookup table range?

    il = 0
    if ( tal.gt.tamin ) il = int( (tal-tamin)*rdta ) + 1
    ii = 0
    if ( tai.gt.tamin ) ii = int( (tai-tamin)*rdta ) + 1
    k = 0
    if ( p.gt.p1min .and. p.le.p1max ) then
      k = int( (p-p1min)*rdp1 ) + 1
    else if ( p.gt.p2min ) then
      k = int( (p-p2min)*rdp2 ) + np1 + 1
    end if

    if (       il.ge.1 .and. il.lt.nta  &
         .and. ii.ge.1 .and. ii.lt.nta  &
         .and.  k.ge.1 .and.  k.lt.np1+np2 ) then

!     Inside lookup table range

!     Use bi-linear interpolation from lookup table values

      if (hflag.eq.2) then

!       Mixed phase case

!       Use bi-linear interpolation to find temperature values
!       from look up tabled

        kp1 = k+1
        if ( k.le.np1 ) then
          w = ( p  - (k-1)*dp1  - p1min  )*rdp1
        else
          w = ( p  - (k-np1-1)*dp2  - p2min  )*rdp2
        endif

!       t0 is the temperature assuming pure ice condensate

        i = ii
        ip1 = i+1
        u = ( tai - (i-1)*dta - tamin )*rdta
        t0 =   (1-u)*(1-w) * ta_lookup(i  ,k  ,0) &
             + (1-u)*w     * ta_lookup(i  ,kp1,0) &
             + u    *(1-w) * ta_lookup(ip1,k  ,0) &
             + u    *w     * ta_lookup(ip1,kp1,0)

!       t1 is the temperature assuming pure liquid condensate

        i = il
        ip1 = i+1
        u = ( tal - (i-1)*dta - tamin )*rdta
        t1 =   (1-u)*(1-w) * ta_lookup(i  ,k  ,1) &
             + (1-u)*w     * ta_lookup(i  ,kp1,1) &
             + u    *(1-w) * ta_lookup(ip1,k  ,1) &
             + u    *w     * ta_lookup(ip1,kp1,1)

!       Do either t0 or t1 fall inside the mixed phase temperature range?

        if (      (t0.ge.248.0 .and. t0.le.268.0)  &
             .or. (t1.ge.248.0 .and. t1.le.268.0) ) then

!         Yes, use t0 and t1 as initial brackets for the root. Because
!         t0 and t1 are derived from lookup tables, the actual bracket
!         must be increased slightly

          hh = hl - Uw_p%grav*z
          temp_sat = zriddr_k(sat1_k,t1-0.01,t0+0.01,hh,qt,p,hflag,1.e-3, &
                              Uw_p)

        elseif ( t0.lt.248.0 .and. t1.lt.248.0 ) then

!         No, the condensate is definitely pure ice

          temp_sat = t0

        elseif ( t0.gt.268.0 .and. t1.gt.268.0 ) then

!         No, the condensate is definitely pure liquid

          temp_sat = t1

        else

         write(*,*) 'WARNING findt_fast_k: never get there'

        endif

      else  ! hflag.ne.2

!     Not mixed phase case: hflag = 0 : ice only
!                           hflag = 1 : liquid only (doice = .false.)

      i = il
      ip1 = i+1
      kp1 = k+1
      u = ( tal - (i-1)*dta - tamin )*rdta
      if ( k.le.np1 ) then
        w = ( p  - (k-1)*dp1  - p1min  )*rdp1
      else
        w = ( p  - (k-np1-1)*dp2  - p2min  )*rdp2
      endif

      temp_sat =   (1-u)*(1-w) * ta_lookup(i  ,k  ,hflag) &
                 + (1-u)*w     * ta_lookup(i  ,kp1,hflag) &
                 + u    *(1-w) * ta_lookup(ip1,k  ,hflag) &
                 + u    *w     * ta_lookup(ip1,kp1,hflag)

      endif

    else

!     Outside lookup table range: use root finding algorithm

      call solve_hl_k(z,p,hl,qt,temp_sat,hflag,Uw_p)

    endif

!   Choose between one of the two choices (temp_unsat, temp_sat):
!   the highest value is temp

    temp = max( temp_unsat, temp_sat )

!   Compute output variables

    call qses_k(temp,p,qs,es,Uw_p)
    if (doice) then
      nu = max(min((268.-temp)/20.,1.0),0.0)
    else
      nu = 0.0
    endif
    leff = (1.-nu)*Uw_p%hlv + nu*Uw_p%hls

    qc = max(qt-qs, 0.)
    qv = qt - qc
    ql = (1.-nu)*qc
    qi = nu*qc
    th = temp/exn_k(p,Uw_p)
    thv=th*(1.+Uw_p%zvir*qv-ql-qi)

    return

!  end subroutine findt_fast_k
  end subroutine findt_k

!     -----------------------------------------------------------------
!     Subroutine to solve for temp as a function of z, p, hl, qt

      subroutine solve_hl_k(z,p,hl,qt,temp,hflag,Uw_p)
      implicit none

      real, intent(in)  :: z, p, hl, qt
      real, intent(out) :: temp
      integer, intent(in) :: hflag
      type(uw_params), intent(inout) :: Uw_p

      real hh, temp_unsat, temp_sat, temp1, temp2, dtemp
      real tempmin, tempmax
      real f, f1, fmin, fmax
      real qs, es

      integer n, nmax
      logical lbracket

!     Definitely unsaturated case
!     The unsaturated temperature (temp_unsat) is always lower or equal 
!     to the actual temperature (temp). 
!     Therefore qs(temp_unsat) <= qs(temp), since qs(T) is monotically
!     increasing with T.

      temp = (hl-Uw_p%grav*z)/Uw_p%cp_air
      call qses_k(temp,p,qs,es,Uw_p)        
      if ( qs.gt.qt ) return

!     Absolute bounds on the temperature. Return immediately
!     if the bounds are outside the range of the saturation vapor 
!     pressure lookup tables.

      tempmin = temp - 1.0
      tempmax = temp + Uw_p%hls*(qt-qs)/Uw_p%cp_air + 1.0

      if ( tempmin.lt.Uw_p%tkmin .and. tempmax.lt.Uw_p%tkmin ) then
        temp = (hl-Uw_p%grav*z+Uw_p%hls*max(qt-qs,0.))/Uw_p%cp_air
        return
      endif

      if ( tempmin.gt.Uw_p%tkmax .and. tempmax.gt.Uw_p%tkmax ) then
        temp = (hl-Uw_p%grav*z+Uw_p%hlv*max(qt-qs,0.))/Uw_p%cp_air
        return
      endif

      temp_unsat = temp
      hh = hl - Uw_p%grav*z
      fmin = sat1_k(tempmin,hh,qt,p,hflag,Uw_p)
      fmax = sat1_k(tempmax,hh,qt,p,hflag,Uw_p)  

!     The bounds on temperature are likely to be too large,
!     so we need to bracket the solution first. 
!     We search for the root closest to tempmin.

      lbracket = .false.
      dtemp = 10.0

!     Is the initial bracket good enough ?

      if ( tempmax-tempmin.le.dtemp ) then
        if ( fmin*fmax.le.0.0 ) then
          lbracket = .true.
          temp1 = tempmin
          temp2 = tempmax
        else
          dtemp=tempmax-tempmin
        endif
      endif

!     If not refine it

      do while (.not.lbracket .and. dtemp.ge.0.2)
      temp1 = tempmin
      temp2 = tempmax
      f1 = sat1_k(temp1,hh,qt,p,hflag,Uw_p)  
      nmax = int( (temp2-temp1)/dtemp ) + 1
      temp = temp1
      do n=1,nmax
        temp = min(temp + dtemp, tempmax)
        f = sat1_k(temp,hh,qt,p,hflag,Uw_p)
        if (f1*f.le.0) then
          temp2 = temp
          lbracket = .true.
          exit
        endif
        temp1 = temp
        f1 = f
      enddo
      dtemp = 0.5 * dtemp
      enddo

!     Did we manage to bracket the root ?

      if (lbracket) then

!       Yes, now find the root within the bracket

        temp_sat = zriddr_k(sat1_k,temp1,temp2,hh,qt,p,hflag,1.e-3, &
                            Uw_p)   

!       Choose between one of the two choices (temp_unsat, temp_sat):
!       the highest value is temp

        temp = max( temp_unsat, temp_sat )

      else

        if (Uw_p%me == 0) then
        write(*,'(a,4e20.12)') 'WARNING solve_hl_k: not bracketed',z,p,hl,qt
        endif
        temp = temp_unsat
        
      endif

      return
      end subroutine solve_hl_k

!     -----------------------------------------------------------------
!     Subroutine to solve for temp as a function of ta, p

      subroutine solve_ta_k(ta,p,t,hflag,Uw_p)
      implicit none

      real, intent(in)  :: ta, p
      real, intent(out) :: t
      integer, intent(in) :: hflag
      type(uw_params), intent(inout) :: Uw_p

      real temp, temp1, temp2, dtemp
      real tempmin, tempmax
      real f, f1, fmin, fmax

      integer n, nmax
      logical lbracket

!     Absolute bounds on the temperature

      tempmin = Uw_p%tkmin
      tempmax = ta + 1.0
      fmin = sat2_k(tempmin,ta,p,0.0,hflag,Uw_p)  
      fmax = sat2_k(tempmax,ta,p,0.0,hflag,Uw_p)

!     The bounds on temperature are likely to be too large,
!     so we need to bracket the solution first. 
!     We search for the root closest to tempmin.

      lbracket = .false.
      dtemp = 50.0

!     Is the initial bracket good enough ?

      if ( tempmax-tempmin.le.dtemp ) then
        if ( fmin*fmax.le.0.0 ) then
          lbracket = .true.
          temp1 = tempmin
          temp2 = tempmax
        else
          dtemp=tempmax-tempmin
        endif
      endif

!     If not refine it

      do while (.not.lbracket .and. dtemp.ge.0.1)
      temp1 = tempmin
      temp2 = tempmax
      f1 = sat2_k(temp1,ta,p,0.0,hflag,Uw_p)
      nmax = int( (temp2-temp1)/dtemp ) + 1
      temp = temp1
      do n=1,nmax
        temp = min(temp + dtemp, tempmax)
        f = sat2_k(temp,ta,p,0.0,hflag,Uw_p)
        if (f1*f.le.0) then
          temp2 = temp
          lbracket = .true.
          exit
        endif
        temp1 = temp
        f1 = f
      enddo
      dtemp = 0.5 * dtemp
      enddo

!     Did we manage to bracket the root ?

      if (lbracket) then

!       Yes, now find the root within the bracket
        t = zriddr_k(sat2_k,temp1,temp2,ta,p,0.0,hflag,1.e-10,Uw_p)
!                    epsilo,hlv,hls,cp_air,tkmin,tkmax)
        return

      else

!       No, bracketing failed
        write(*,*) 'WARNING solve_ta_k: not bracketed'
        t = -999.0
        return
        
      endif

      end subroutine solve_ta_k

!     -----------------------------------------------------------------
!     To diagnose temp from hl and qt, we need to find the zero
!     of this function

      real function sat1_k(temp,hh,qt,p,hflag,Uw_p)  
      implicit none

      real, intent(in) :: temp, hh, qt, p
      integer, intent(in) :: hflag
      type(uw_params), intent(inout) :: Uw_p

      integer ier
      real qs, leff, nu
      real t

!     In-line qses computation here for better performance
      t = min(max(temp,Uw_p%tkmin),Uw_p%tkmax)
!   INLINING ????
      call compute_qs_k (t, p, Uw_p%epsilo, Uw_p%zvir, qs, ier)

      select case (hflag)
        case (0)
          leff = Uw_p%hls
        case (1)
          leff = Uw_p%hlv
        case (2)
          nu = max(min((268.0-temp)/20.,1.0),0.0)
          leff = (1.0-nu)*Uw_p%hlv + nu*Uw_p%hls
      end select
      sat1_k = hh - Uw_p%cp_air*temp + leff*(qt-qs)

      return
      end function sat1_k

!     -----------------------------------------------------------------
!     To diagnose temp from ta and p, we need to find the zero
!     of this function

      real function sat2_k(temp,ta,p,tmp,hflag, Uw_p)
      implicit none

      real, intent(in) :: temp, ta, p, tmp
      integer, intent(in) :: hflag
      type(uw_params), intent(inout) :: Uw_p

      integer ier
      real qs, leff, nu
      real t

!     In-line qses computation here for better performance
      t = min(max(temp,Uw_p%tkmin),Uw_p%tkmax)
!   INLINING ????
      call compute_qs_k (t, p, Uw_p%epsilo, Uw_p%zvir, qs, ier)

      select case (hflag)
        case (0)
          leff = Uw_p%hls
        case (1)
          leff = Uw_p%hlv
        case (2)
          nu = max(min((268.0-temp)/20.,1.0),0.0)
          leff = (1.0-nu)*Uw_p%hlv + nu*Uw_p%hls
      end select
      sat2_k = ta - temp - leff/Uw_p%cp_air*qs

      return
      end function sat2_k

!     -----------------------------------------------------------------
!     Function to find zero of function 'saturated' using Ridders'
!     method

      real function zriddr_k(func, x1,x2,ya,yb,yc,ld,xacc,Uw_p)
      implicit none

      integer maxit
      real unused
      type(uw_params) Uw_p
      parameter (maxit=60,unused=-1.11e30)

      real func
      external func

      real x1,x2,xacc
      real ya,yb,yc
      integer ld
      
      integer j
      real fh,fl,fm,fnew,s,xh,xl,xm,xnew

      fl=func       (x1,ya,yb,yc,ld,Uw_p)
      fh=func       (x2,ya,yb,yc,ld,Uw_p)
      if((fl.gt.0..and.fh.lt.0.).or.(fl.lt.0..and.fh.gt.0.))then
        xl=x1
        xh=x2
        zriddr_k=unused
        do j=1,maxit
          xm=0.5*(xl+xh)
          fm=func       (xm,ya,yb,yc,ld,Uw_p)
          s=sqrt(fm**2-fl*fh)
          if(s.eq.0.)return
          xnew=xm+(xm-xl)*(sign(1.,fl-fh)*fm/s)
          if (abs(xnew-zriddr_k).le.xacc) return
          zriddr_k=xnew
          fnew=func       (zriddr_k,ya,yb,yc,ld,Uw_p)
          if (fnew.eq.0.) return
          if(sign(fm,fnew).ne.fm) then
            xl=xm
            fl=fm
            xh=zriddr_k
            fh=fnew
          else if(sign(fl,fnew).ne.fl) then
            xh=zriddr_k
            fh=fnew
          else if(sign(fh,fnew).ne.fh) then
            xl=zriddr_k
            fl=fnew
          else
!            write(*,*) 'WARNING: never get here in zriddr'
!            write(*,*) 'WARNING zriddr_k: never get there'
          endif
          if(abs(xh-xl).le.xacc) return
        enddo
!       write(*,*) 'WARNING zriddr_k: exceeded maximum iterations'
!        write(*,*) 'WARNING: zriddr exceed maximum iterations'
!  need to properly handle error condition
!        write(*,*) 'WARNING: zriddr exceed maximum iterations', &
!         x1, x2, xl, xh
      else if (fl.eq.0.) then
        zriddr_k=x1
      else if (fh.eq.0.) then
        zriddr_k=x2
      else
!        write(*,*) 'WARNING zriddr_k: root must be bracketed'
!        write(*,*) 'WARNING: root must be bracketed in zriddr'
      endif

      return
      end function zriddr_k

!######################################################################

!++lwh
subroutine check_tracer_realizability(kmax, ntr, dt, &
                                             tracers, trten, trwet)
!---------------------------------------------------------------------
!  Check for tracer realizability. If convective tendencies would
!  produce negative tracer mixing ratios, scale down tracer tendency
!  terms uniformly for this tracer throughout convective column. This is
!  equivalent to limiting the cell areas.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  Dummy arguments
!---------------------------------------------------------------------
integer,                 intent(in)     :: kmax, ntr
real,                    intent(in)     :: dt 
real, dimension(kmax,ntr), &
                         intent(in)     :: tracers        
real,dimension(kmax,ntr),intent(inout)  :: trten, trwet

!---------------------------------------------------------------------
!   intent(in) variables:
!     tracers        tracer mixing ratios
!                    [ kg(tracer) / kg (dry air) ]
!     kmax           number of model layers in large-scale model
!     dt             physics time step [ sec ]
!
!   intent(inout) variables:
!     trten          tracer tendency
!     trwet          tracer wet deposition tendency
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  Local variables
!---------------------------------------------------------------------

   integer :: n,k
   real, dimension(kmax) :: tracer0, trtend, trtendw, tracer1, tracer1w
   real :: ratio, tracer_max, tracer_min

!---------------------------------------------------------------------
!   local variables:
!
!     tracers        tracer mixing ratios of tracers transported by the
!                    donner deep convection parameterization
!                    [ tracer units, e.g., kg(tracer) / kg (dry air) ]
!     tracer0        column tracer mixing ratios before convection
!     trtend         column tracer mixing ratio tendencies due to convection [ (tracer units) / s ]
!     tracer1        column tracer mixing ratios after convection
!     k, n     do-loop indices
!     ratio          ratio by which tracer convective tendencies need to 
!                    be reduced to permit realizability (i.e., to prevent
!                    negative tracer mixing ratios)
!
!---------------------------------------------------------------------

   do n = 1,ntr
      
      tracer0(:)  = tracers(:,n)
      trtend(:)   = trten(:,n)
      trtendw(:)  = trtend(:) + trwet(:,n)
      tracer1(:)  = tracer0 + dt * trtend(:)
      tracer1w(:) = tracer0 + dt * trtendw(:)

      tracer_min = 1.e20
      tracer_max = -1.e20

      do k = 1,kmax
         if (trtend(k) /= 0.) then
            tracer_max = max(tracer0(k),tracer_max)
            tracer_min = min(tracer0(k),tracer_min)
         end if
      end do
 
      ratio = 1.
      do k = 1,kmax
         if (tracer0(k)>0. .and. tracer1w(k)<0. ) then
            ratio = MIN( ratio,tracer0(k)/(-trtendw(k)*dt) )
         end if
         if (tracer1(k)<tracer_min .and. trtend(k) /= 0.0 ) then
            ratio = MIN( ratio,(tracer0(k)-tracer_min)/(-trtend(k)*dt) )
         end if
         if (tracer1(k)>tracer_max  .and. trtend(k) /= 0.0 ) then
            ratio = MIN( ratio,(tracer_max-tracer0(k))/(trtend(k)*dt) )
         end if
      end do
      ratio = MAX(0.,MIN(1.,ratio))
      if (ratio /= 1.) then
         trten(:,n) =  trten(:,n)*ratio
         trwet(:,n) =  trwet(:,n)*ratio
      end if
   end do


end subroutine check_tracer_realizability
!--lwh

!#####################################################################
subroutine qt_parcel_k (qs, qstar, pblht, tke, land, gama, pblht0, tke0, lofactor0, &
     lochoice, qt, lofactor)
    real,    intent(in)    :: qs, qstar, pblht, tke, land, gama, pblht0, tke0, lofactor0
    integer, intent(in)    :: lochoice
    real,    intent(inout) :: qt, lofactor

    real :: qttmp

    if (lochoice .eq. 0) then
       lofactor = 1. - land * (1. - lofactor0)
    elseif (lochoice .eq. 1) then
       lofactor = pblht0 / max(pblht,  pblht0)
    elseif (lochoice .eq. 2) then
       lofactor = tke0   / max(tke, tke0  )
    elseif (lochoice .eq. 3) then
       lofactor = tke0   / max(tke, tke0  )
       lofactor = sqrt(lofactor)
    else
       lofactor = 1.
    end if

    qttmp = qt*(1. + gama * land)
    qt    = max(qt, min(qttmp, qs))
 
  end subroutine qt_parcel_k


end MODULE CONV_UTILITIES_k_MOD



MODULE DEEP_CONV_MOD

  use      fms_mod,         only : write_version_number
  use      Constants_Mod,   ONLY : tfreeze,HLv,HLf,HLs,CP_AIR,GRAV,Kappa,rdgas,rvgas
  use  conv_utilities_mod,  only : uw_params_init
  use  conv_utilities_k_mod,only : sd_init_k, sd_copy_k, sd_end_k,  &
                                   ac_init_k, ac_clear_k, ac_end_k, &
                                   pack_sd_k, adi_cloud_k, extend_sd_k,&
                                   exn_init_k, exn_end_k, findt_init_k,&
                                   findt_end_k, &
                                   adicloud, sounding, uw_params

  use  conv_plumes_k_mod,   only : cp_init_k, cp_end_k, cp_clear_k, &
                                   ct_init_k, ct_end_k, ct_clear_k, &
                                   cumulus_tend_k, cumulus_plume_k, &
                                   cplume, ctend, cpnlist

  use  conv_closures_mod,   only : cclosure_bretherton,   &
                                   cclosure_relaxcbmf, &
                                   cclosure_relaxwfn,  &
                                   cclosure_implicit, cclosure


!---------------------------------------------------------------------
  implicit none
  private
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: deep_conv.F90,v 17.0.2.1.4.1 2010/03/17 20:27:10 wfc Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-------  interfaces --------

  public  :: dpconv0, dpconv1, dpconv2, dpconv3, DEEP_CONV_INIT, DEEP_CONV_END

  logical         :: module_is_initialized = .false.

  character(len=7) :: mod_name = 'deep_conv'

  public deepc
  type deepc
     real, dimension(7)  :: rkm_dp
     real, dimension(7)  :: rat_dp
     real, dimension(50) :: rkm
     real, dimension(50) :: rat
     real, dimension(50) :: hgt
     real    :: omeg_th
     real    :: cape_th 
     real    :: tau_dp  
     real    :: cbmf_d  
     real    :: cwfn_d
     real    :: deepdepth
     integer :: ideep_closure
     integer :: mixing_assumption
     logical :: do_generation
     logical :: do_ppen
     logical :: do_pevap
  end type deepc

contains

!#####################################################################
!#####################################################################

  subroutine cpn_copy(cpn, dpn)
    type(cpnlist), intent(in)    :: cpn
    type(cpnlist), intent(inout) :: dpn

    dpn % rle              = cpn % rle
    dpn % rpen             = cpn % rpen
    dpn % rmaxfrac         = cpn % rmaxfrac
    dpn % wmin             = cpn % wmin
    dpn % rbuoy            = cpn % rbuoy
    dpn % rdrag            = cpn % rdrag  
    dpn % frac_drs         = cpn % frac_drs
    dpn % bigc             = cpn % bigc    
    dpn % auto_th0         = cpn % auto_th0
    dpn % auto_rate        = cpn % auto_rate
    dpn % tcrit            = cpn % tcrit  
    dpn % cldhgt_max       = cpn % cldhgt_max
    dpn % do_ice           = cpn % do_ice
    dpn % do_ppen          = cpn % do_ppen
    dpn % do_pevap         = cpn % do_pevap
    dpn % mixing_assumption= cpn % mixing_assumption
    dpn % mp_choice        = cpn % mp_choice
    dpn % do_forcedlifting = cpn % do_forcedlifting
    dpn % atopevap         = cpn % atopevap
    dpn % wtwmin_ratio     = cpn % wtwmin_ratio

  end subroutine cpn_copy

!#####################################################################
!#####################################################################

  subroutine dpconv0(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, do_ice, &
       omeg_avg, rkm_sh, cp1, ct1, cbmf_deep, ocode, ier, ermesg)
    implicit none

    type(deepc),     intent(inout)  :: dpc
    type(cpnlist),   intent(in)     :: cpn
    type(uw_params), intent(inout)  :: Uw_p
    type(sounding),  intent(in)     :: sd
    type(adicloud),  intent(in)     :: ac
    type(cclosure),  intent(in)     :: cc
    logical,         intent(in)     :: do_coldT
    logical,         intent(in)     :: do_ice
    type(cplume),    intent(inout)  :: cp, cp1
    type(ctend),     intent(inout)  :: ct, ct1
    real,            intent(inout)  :: cbmf_deep, ocode, rkm_sh, omeg_avg
    integer,            intent(out)   :: ier
    character(len=256), intent(out)   :: ermesg


    type(cpnlist) :: dpn
    real          :: rkm_dp, zcldtop

    if ( (ocode.ne.0) .or. (omeg_avg .gt.dpc%omeg_th)) then
       ocode=6; return
    end if

    call cpn_copy(cpn, dpn)
    dpn % do_ppen   = dpc % do_ppen
    dpn % do_pevap  = dpc % do_pevap
    rkm_dp  = dpc%rkm_dp(1) *  rkm_sh
    zcldtop = sd%z(cp%ltop)

    call cp_clear_k(cp1);
    call ct_clear_k(ct1);
    call cumulus_plume_k(dpn, sd, ac, cp1, rkm_dp, cbmf_deep, cc%wrel, zcldtop, Uw_p, ier, ermesg)
    if(cp1%ltop.lt.cp1%krel+2 .or. cp1%let.le.cp1%krel+1) then
       ocode=6; return
    else
       call cumulus_tend_k(dpn, sd, Uw_p, cp1, ct1, do_coldT)
    end if
 
  end subroutine dpconv0


!#####################################################################
!#####################################################################

  subroutine dpconv1(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, do_ice, sd1, ac1, &
       cc1, cp1, ct1, ocode, ier, ermesg)
    implicit none

    type(deepc),     intent(inout)  :: dpc
    type(cpnlist),   intent(in)     :: cpn
    type(uw_params), intent(inout)  :: Uw_p
    type(sounding),  intent(in)     :: sd
    type(adicloud),  intent(inout)  :: ac
    logical,         intent(in)     :: do_coldT
    logical,         intent(in)     :: do_ice
    type(sounding),  intent(inout)  :: sd1
    type(adicloud),  intent(inout)  :: ac1
    type(cclosure),  intent(inout)  :: cc,cc1
    type(cplume),    intent(inout)  :: cp,cp1
    type(ctend),     intent(inout)  :: ct,ct1
    real,            intent(inout)  :: ocode
    integer,            intent(out)   :: ier
    character(len=256), intent(out)   :: ermesg

    integer :: i, ksrc
    real    :: cbmf0, cbmfs, cbmf_max, dcape, scaleh, wrel, tmp, cbmf, rkm
    real    :: zsrc, psrc, thcsrc, hlsrc, qctsrc, pdeet1, pdeet2

    type(cpnlist) :: dpn

    call cpn_copy(cpn, dpn)

    dpn % do_ppen          = .false.
    dpn % rmaxfrac         = 1000000.
    dpn % rbuoy            = 0.66666
    dpn % rdrag            = 3.0
    dpn % auto_th0         = 0.5e-3
    dpn % auto_rate        = 1.0e-3
    dpn % mixing_assumption= 1
    dpn % mp_choice        = 1
    dpn % do_forcedlifting = .true.

!!$    zsrc  =sd%zs (1);
!!$    psrc  =sd%ps (1); thcsrc=sd%thc(1)
!!$    hlsrc =cc%xhlsrc
!!$    qctsrc=cc%xqtsrc
!!$    call adi_cloud(zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, .false., do_ice, ac1)
!!$    cc % dcape=(ac1%cape-cc%xcape)/sd%delt

    pdeet1=ac%plfc - ac%plnb
    pdeet2=ac%plfc - ac%plcl

    if  ((ac%cape  <= dpc%cape_th )                    .or.  &
!        (cc%dcape <= 0.  .and. dpc%do_dcape_closure ) .or.  &
         (pdeet1   <= 500.e02                        ) .or.  &
         (ac%cin   >= 100.))                           then
       dpc%cbmf_d=0.; 
       ocode=6; 
       return
    end if
 
    ksrc=2
    zsrc  =sd%zs (ksrc);
    psrc  =sd%ps (ksrc);    thcsrc=sd%thc(ksrc)
    qctsrc=sd%qct(ksrc)
    hlsrc =sd%hl (ksrc)
    call adi_cloud_k(zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, Uw_p, .false., do_ice, ac)

    cbmf0=0.0001; dpc%cbmf_d=0.; wrel=0.5; scaleh=1000.

    cbmf=1000000.*wrel;
    do i=1, size(dpc%rkm_dp(:))
       call ct_clear_k(ct)
       call cp_clear_k(cp)
       rkm = dpc%rkm_dp(i)
       call cumulus_plume_k(dpn, sd, ac, cp, rkm, cbmf, wrel, scaleh, Uw_p, ier, ermesg)
       if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
          dpc%cbmf_d=0.; ocode=6; return
       end if
       call cumulus_tend_k(dpn, sd, Uw_p, cp, ct, do_coldT)
       ct1%tten  = ct1%tten  + ct%tten  * dpc%rat_dp(i)
       ct1%qvten = ct1%qvten + ct%qvten * dpc%rat_dp(i)
       ct1%qlten = ct1%qlten + ct%qlten * dpc%rat_dp(i)
       ct1%qiten = ct1%qiten + ct%qiten * dpc%rat_dp(i)
       ct1%qaten = ct1%qaten + ct%qaten * dpc%rat_dp(i)
       ct1%qnten = ct1%qnten + ct%qnten * dpc%rat_dp(i)
       ct1%uten  = ct1%uten  + ct%uten  * dpc%rat_dp(i)
       ct1%vten  = ct1%vten  + ct%vten  * dpc%rat_dp(i)
       ct1%pflx  = ct1%pflx  + ct%pflx  * dpc%rat_dp(i)
       ct1%hlflx = ct1%hlflx + ct%hlflx * dpc%rat_dp(i)
       ct1%qctflx= ct1%qctflx+ ct%qctflx* dpc%rat_dp(i)
!       ct1%tevap = ct1%tevap + ct%tevap * dpc%rat_dp(i)
!       ct1%qevap = ct1%qevap + ct%qevap * dpc%rat_dp(i)
       ct1%rain  = ct1%rain  + ct%rain  * dpc%rat_dp(i)
       ct1%snow  = ct1%snow  + ct%snow  * dpc%rat_dp(i)
       ct1%denth = ct1%denth + ct%denth * dpc%rat_dp(i)

       cp1%ufrc  = cp1%ufrc  + cp%ufrc  * dpc%rat_dp(i)
       cp1%qlu   = cp1%qlu   + cp%qlu   * dpc%rat_dp(i)
       cp1%qiu   = cp1%qiu   + cp%qiu   * dpc%rat_dp(i)
       cp1%qnu   = cp1%qnu   + cp%qnu   * dpc%rat_dp(i)
       cp1%umf   = cp1%umf   + cp%umf   * dpc%rat_dp(i)
       cp1%wu    = cp1%wu    + cp%wu    * dpc%rat_dp(i)
       cp1%fdrsat= cp1%fdrsat+ cp%fdrsat* dpc%rat_dp(i)
       cp1%fdr   = cp1%fdr   + cp%fdr   * dpc%rat_dp(i)
    end do

    call sd_copy_k(sd, sd1)
    tmp      = cbmf0 / cbmf
    sd1 % t  = sd1 % t  + ct1%tten  * sd%delt * tmp
    sd1 % qv = sd1 % qv + ct1%qvten * sd%delt * tmp
    sd1 % ql = sd1 % ql + ct1%qlten * sd%delt * tmp
    sd1 % qi = sd1 % qi + ct1%qiten * sd%delt * tmp
    sd1 % qa = sd1 % qa + ct1%qaten * sd%delt * tmp
    sd1 % qn = sd1 % qn + ct1%qnten * sd%delt * tmp
    sd1 % u  = sd1 % u  + ct1%uten  * sd%delt * tmp
    sd1 % v  = sd1 % v  + ct1%vten  * sd%delt * tmp

    call extend_sd_k(sd1,sd%pblht, do_ice, Uw_p)
    
    call adi_cloud_k(sd1%zs(ksrc), sd1%ps(ksrc), sd1%hl(ksrc), sd1%thc(ksrc), sd1%qct(ksrc), &
         sd1, Uw_p, .false., do_ice, ac1)
    dcape=(ac%cape-ac1%cape)/cbmf0
    if (dcape <= 0.) then
       dpc%cbmf_d=0.; ocode=6; return
    end if

    if (dpc%ideep_closure.eq.1) then
       cbmfs = (ac%cape - dpc%cape_th) / dcape / (dpc%tau_dp/sd%delt)
    else if (dpc%ideep_closure.eq.2) then
       cbmfs = cc%dcape / dcape 
    else
       cbmfs = 0.0
    end if
!!$       call cumulus_plume_k(dpn, sd1, ac1, cp1, rkm_dp, cbmf0, cc%wrel, cc%scaleh)
!!$       cc%dwfn=0.; cc%wfn=0.; delp=0.;
!!$       do k=cp1%krel, cp1%let
!!$          cc % wfn  = cc % wfn  + 0.5*(cp %wu(k)*cp %wu(k)) * cp%dp(k)
!!$          cc % dwfn = cc % dwfn + 0.5*(cp1%wu(k)*cp1%wu(k) - cp%wu(k)*cp%wu(k)) * cp%dp(k)
!!$          delp      = delp + cp%dp(k)
!!$       end do
!!$       cc % wfn  = cc % wfn  / delp 
!!$       cc % dwfn = cc % dwfn / delp / cbmf0
!!$       if (do_cape_closure) then
!!$          cbmfs = - ac%cape / cc % dcape / (dpc%tau_dp/sd%delt)
!!$        elseif (do_relaxwfn) then
!!$          cbmfs = - cc%wfn  / cc % dwfn  / (dpc%tau_dp/sd%delt)
!!$       else
!!$          cbmfs = - cc%wfn  / cc % dwfn
!!$          tmp   = sd%delt/dpc%tau_dp
!!$          cbmfs = (cbmf_old+tmp*cbmfs)/(1.+tmp)
!!$       end if

    cbmf_max=(sd%ps(0) - sd%ps(cp%krel))*(0.25/sd%delt)/Grav
    dpc%cbmf_d = max(min(cbmfs, cbmf_max), 0.)
 
    if(dpc%cbmf_d.lt.1.e-10) then 
       dpc%cbmf_d=0.; ocode=6; return
    end if

    tmp       = dpc%cbmf_d/ cbmf
    ct1%tten  = ct1%tten  * tmp
    ct1%qvten = ct1%qvten * tmp
    ct1%qlten = ct1%qlten * tmp
    ct1%qiten = ct1%qiten * tmp
    ct1%qaten = ct1%qaten * tmp
    ct1%qnten = ct1%qnten * tmp
    ct1%uten  = ct1%uten  * tmp
    ct1%vten  = ct1%vten  * tmp
    ct1%pflx  = ct1%pflx  * tmp
    ct1%hlflx = ct1%hlflx * tmp
    ct1%qctflx= ct1%qctflx* tmp
!    ct1%tevap = ct1%tevap * tmp
!    ct1%qevap = ct1%qevap * tmp
    ct1%rain  = ct1%rain  * tmp
    ct1%snow  = ct1%snow  * tmp
    ct1%denth = ct1%denth * tmp

!    call cumulus_plume_k(dpn, sd, ac, cp1, rkm_dp, dpc%cbmf_d, cc%wrel, 10000.)
!    call cumulus_tend_k(dpn, sd, cp1, ct1, do_coldT)

  end subroutine dpconv1


!#####################################################################
!#####################################################################


  subroutine dpconv2(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, do_ice, sd1, ac1, &
       cc1, cp1, ct1, cbmf_deep, ocode, ier, ermesg)
    implicit none

    type(deepc),     intent(inout)  :: dpc
    type(cpnlist),   intent(in)     :: cpn
    type(uw_params), intent(inout)  :: Uw_p
    type(sounding),  intent(in)     :: sd
    type(adicloud),  intent(inout)  :: ac
    logical,         intent(in)     :: do_coldT
    logical,         intent(in)     :: do_ice
    type(sounding),  intent(inout)  :: sd1
    type(adicloud),  intent(inout)  :: ac1
    type(cclosure),  intent(inout)  :: cc,cc1
    type(cplume),    intent(inout)  :: cp,cp1
    type(ctend),     intent(inout)  :: ct,ct1
    real,            intent(inout)  :: ocode, cbmf_deep
    integer,            intent(out)   :: ier
    character(len=256), intent(out)   :: ermesg

    integer :: k, ksrc, n
    real    :: cbmf0, cbmfs, cbmf_max, dcape, scaleh, wrel, tmp, rkm
    real    :: cwfn_d, dcwfn, rat, ratsum, zcldtop
    type(cpnlist) :: dpn

    call cpn_copy(cpn, dpn)
    dpn % do_ppen   = dpc % do_ppen
    dpn % do_pevap  = dpc % do_pevap
    dpn % mixing_assumption = dpc % mixing_assumption

    if (ocode.ne.0) then
       return
    end if

    call sd_copy_k(sd, sd1)
    call extend_sd_k(sd1,sd%pblht, do_ice, Uw_p)

    dpc%cbmf_d  = 0.; 
    dpc%cwfn_d  = 0.;
    dpc%rat     = 0.; 
    dpc%rkm     = 0.; 
    dpc%hgt     = 0.; 
    scaleh      = 0.;
    ratsum      = 0.;
    cbmf0       = 0.0001; 
    wrel        = cc%wrel; 
    rkm         = dpc%rkm_dp(1);
    zcldtop     = sd%z(cp%ltop); 

    do n=1, sd%kmax
       scaleh        = zcldtop
       dpc%hgt(n)    = scaleh
       dpc%rkm(n)    = rkm/scaleh
       rat           = dpc%rkm(n)
       dpc%rat(n)    = rat
       
       if (dpc%do_generation) then
          do k=1,cp%ltop
             sd1 % qv(k) = sd1 % qs(k)
          end do
          call extend_sd_k(sd1,sd%pblht, do_ice, Uw_p)
          sd1 % thvtop(:) = sd % thvtop(:)
          sd1 % thvbot(:) = sd % thvbot(:)
       end if

       call cumulus_plume_k(dpn, sd1, ac, cp, rkm, cbmf0, wrel, scaleh, Uw_p, ier, ermesg)
       if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
          dpc%cbmf_d=0.; ocode=6; return
       end if

       zcldtop   = sd%z(cp%ltop)
       if (zcldtop.le.scaleh) then
          exit
       end if

       call cumulus_tend_k(dpn, sd, Uw_p, cp, ct, do_coldT)

       ct1%tten  = ct1%tten  + ct%tten  * rat
       ct1%qvten = ct1%qvten + ct%qvten * rat
       ct1%qlten = ct1%qlten + ct%qlten * rat
       ct1%qiten = ct1%qiten + ct%qiten * rat
       ct1%qaten = ct1%qaten + ct%qaten * rat
       ct1%qnten = ct1%qnten + ct%qnten * rat
       ct1%uten  = ct1%uten  + ct%uten  * rat
       ct1%vten  = ct1%vten  + ct%vten  * rat
       ct1%tevap = ct1%tevap + ct%tevap * rat
       ct1%qevap = ct1%qevap + ct%qevap * rat
       ct1%pflx  = ct1%pflx  + ct%pflx  * rat
       ct1%hlflx = ct1%hlflx + ct%hlflx * rat
       ct1%qctflx= ct1%qctflx+ ct%qctflx* rat
       ct1%rain  = ct1%rain  + ct%rain  * rat
       ct1%snow  = ct1%snow  + ct%snow  * rat
       ct1%denth = ct1%denth + ct%denth * rat

       cp1%ufrc  = cp1%ufrc  + cp%ufrc  * rat
       cp1%qlu   = cp1%qlu   + cp%qlu   * rat
       cp1%qiu   = cp1%qiu   + cp%qiu   * rat
       cp1%qnu   = cp1%qnu   + cp%qnu   * rat
       cp1%umf   = cp1%umf   + cp%umf   * rat
       cp1%wu    = cp1%wu    + cp%wu    * rat
       cp1%fdrsat= cp1%fdrsat+ cp%fdrsat* rat
       cp1%fdr   = cp1%fdr   + cp%fdr   * rat

       tmp       = maxval(cp%wu(:))
       dpc%cwfn_d= max(dpc%cwfn_d, tmp*tmp)

       ratsum    = ratsum + rat
    end do

    if (n > 1) then
       rat       = 1./ratsum
       dpc%rat   = dpc%rat*rat
       ct1%tten  = ct1%tten  * rat
       ct1%qvten = ct1%qvten * rat
       ct1%qlten = ct1%qlten * rat
       ct1%qiten = ct1%qiten * rat
       ct1%qaten = ct1%qaten * rat
       ct1%qnten = ct1%qnten * rat
       ct1%uten  = ct1%uten  * rat
       ct1%vten  = ct1%vten  * rat
       ct1%tevap = ct1%tevap * rat
       ct1%qevap = ct1%qevap * rat
       ct1%pflx  = ct1%pflx  * rat
       ct1%hlflx = ct1%hlflx * rat
       ct1%qctflx= ct1%qctflx* rat
       ct1%rain  = ct1%rain  * rat
       ct1%snow  = ct1%snow  * rat
       ct1%denth = ct1%denth * rat
       
       cp1%ufrc  = cp1%ufrc  * rat
       cp1%qlu   = cp1%qlu   * rat
       cp1%qiu   = cp1%qiu   * rat
       cp1%qnu   = cp1%qnu   * rat
       cp1%umf   = cp1%umf   * rat
       cp1%wu    = cp1%wu    * rat
       cp1%fdrsat= cp1%fdrsat* rat
       cp1%fdr   = cp1%fdr   * rat       
    end if


    if (dpc%ideep_closure.eq.0) then
       cbmfs = cbmf_deep
    else 
       call sd_copy_k(sd, sd1)
       sd1 % t  = sd1 % t  + ct1%tten  * sd%delt
       sd1 % qv = sd1 % qv + ct1%qvten * sd%delt
       sd1 % ql = sd1 % ql + ct1%qlten * sd%delt
       sd1 % qi = sd1 % qi + ct1%qiten * sd%delt
       sd1 % qa = sd1 % qa + ct1%qaten * sd%delt
       sd1 % qn = sd1 % qn + ct1%qnten * sd%delt
       sd1 % u  = sd1 % u  + ct1%uten  * sd%delt
       sd1 % v  = sd1 % v  + ct1%vten  * sd%delt
       call extend_sd_k(sd1,sd%pblht, do_ice, Uw_p)
       ksrc=1
       call adi_cloud_k(sd1%zs(ksrc), sd1%ps(ksrc), sd1%hl(ksrc), sd1%thc(ksrc), sd1%qct(ksrc), &
            sd1, Uw_p, .false., do_ice, ac1)
       if (dpc%ideep_closure.eq.1) then
          dcape = (ac%cape - ac1%cape)/cbmf0
          if (dcape <= 0.) then
             dpc%cbmf_d=0.; ocode=6; return
          end if
          cbmfs = (ac%cape - dpc%cape_th) / dcape / (dpc%tau_dp/sd%delt)
       else if (dpc%ideep_closure.eq.2) then
          call cumulus_plume_k(dpn, sd1, ac1, cp, rkm, cbmf0, wrel, scaleh, Uw_p, ier, ermesg)
          tmp    = maxval(cp%wu(:))
          cwfn_d = tmp*tmp
          dcwfn=(dpc%cwfn_d - cwfn_d)  /cbmf0
          cbmfs = (dpc%cwfn_d - 0.) / dcwfn / (dpc%tau_dp/sd%delt)
       end if
    end if

    cbmf_max=(sd%ps(0) - sd%ps(cp%krel))*(0.25/sd%delt)/Grav
    dpc%cbmf_d = max(min(cbmfs, cbmf_max), 0.)
 
    if(dpc%cbmf_d.lt.1.e-10) then 
       dpc%cbmf_d=0.; ocode=6; return
    end if

    tmp       = dpc%cbmf_d/ cbmf0
    ct1%tten  = ct1%tten  * tmp
    ct1%qvten = ct1%qvten * tmp
    ct1%qlten = ct1%qlten * tmp
    ct1%qiten = ct1%qiten * tmp
    ct1%qaten = ct1%qaten * tmp
    ct1%qnten = ct1%qnten * tmp
    ct1%uten  = ct1%uten  * tmp
    ct1%vten  = ct1%vten  * tmp
    ct1%tevap = ct1%tevap * tmp
    ct1%qevap = ct1%qevap * tmp
    ct1%pflx  = ct1%pflx  * tmp
    ct1%hlflx = ct1%hlflx * tmp
    ct1%qctflx= ct1%qctflx* tmp
    ct1%rain  = ct1%rain  * tmp
    ct1%snow  = ct1%snow  * tmp
    ct1%denth = ct1%denth * tmp

    cp1%ufrc  = cp1%ufrc  * tmp
    cp1%umf   = cp1%umf   * tmp

  end subroutine dpconv2

!#####################################################################
!#####################################################################

  subroutine dpconv3(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, do_ice, &
       omeg_avg, rkm_sh, sd1, ac1, cp1, ct1, cbmf_deep, ocode, ier, ermesg)
    implicit none

    type(deepc),     intent(inout)  :: dpc
    type(cpnlist),   intent(in)     :: cpn
    type(uw_params), intent(inout)  :: Uw_p
    type(sounding),  intent(in)     :: sd
    type(adicloud),  intent(in)     :: ac
    type(cclosure),  intent(in)     :: cc
    logical,         intent(in)     :: do_coldT
    logical,         intent(in)     :: do_ice
    real,            intent(in)     :: rkm_sh, omeg_avg
    type(sounding),  intent(inout)  :: sd1
    type(adicloud),  intent(inout)  :: ac1
    type(cplume),    intent(inout)  :: cp, cp1
    type(ctend),     intent(inout)  :: ct, ct1
    real,            intent(inout)  :: cbmf_deep, ocode
    integer,            intent(out)   :: ier
    character(len=256), intent(out)   :: ermesg

    type(cpnlist) :: dpn
    real          :: rkm_dp, zcldtop, cbmf0, dcapedm, cbmf_max, tmp
    integer       :: ksrc

    zcldtop = sd%z(cp%ltop)
    if ( (ocode.ne.0) .or. (ac%cape  <= dpc%cape_th) .or. zcldtop < dpc%deepdepth) then
       ocode=6; return
    end if

    call cpn_copy(cpn, dpn)
    dpn % do_ppen   = dpc % do_ppen
    dpn % do_pevap  = dpc % do_pevap
    rkm_dp  = dpc%rkm_dp(1) *  rkm_sh

    cbmf0 = 0.0001
    call cp_clear_k(cp1);
    call ct_clear_k(ct1);
    call cumulus_plume_k(dpn, sd, ac, cp1, rkm_dp, cbmf0, cc%wrel, zcldtop, Uw_p, ier, ermesg)
    if(cp1%ltop.lt.cp1%krel+2 .or. cp1%let.le.cp1%krel+1) then
       ocode=6; return
    else
       call cumulus_tend_k(dpn, sd, Uw_p, cp1, ct1, do_coldT)
    end if

    call sd_copy_k(sd, sd1)
    tmp      = 1.
    sd1 % t  = sd1 % t  + ct1%tten  * sd%delt * tmp
    sd1 % qv = sd1 % qv + ct1%qvten * sd%delt * tmp
    sd1 % ql = sd1 % ql + ct1%qlten * sd%delt * tmp
    sd1 % qi = sd1 % qi + ct1%qiten * sd%delt * tmp
    sd1 % qa = sd1 % qa + ct1%qaten * sd%delt * tmp
    sd1 % qn = sd1 % qn + ct1%qnten * sd%delt * tmp
    sd1 % u  = sd1 % u  + ct1%uten  * sd%delt * tmp
    sd1 % v  = sd1 % v  + ct1%vten  * sd%delt * tmp

    call extend_sd_k(sd1,sd%pblht, do_ice, Uw_p)

    ksrc=1
    call adi_cloud_k(sd1%zs(ksrc), sd1%ps(ksrc), sd1%hl(ksrc), sd1%thc(ksrc), sd1%qct(ksrc), &
         sd1, Uw_p, .false., do_ice, ac1)
    dcapedm=(ac%cape-ac1%cape)/cbmf0

    if (dcapedm <= 0.) then
       cbmf_deep=0.; ocode=6; return
    else
       cbmf_deep= (ac%cape - dpc%cape_th) / dcapedm / (dpc%tau_dp/sd%delt)
    end if

    cbmf_max=(sd%ps(0) - sd%ps(cp%krel))*(0.25/sd%delt)/Grav
    cbmf_deep = max(min(cbmf_deep, cbmf_max), 0.)
 
    if(cbmf_deep.lt.1.e-10) then 
       cbmf_deep=0.; ocode=6; return
    end if

    call cumulus_plume_k(dpn, sd, ac, cp1, rkm_dp, cbmf_deep, cc%wrel, zcldtop, Uw_p, ier, ermesg)
    if(cp1%ltop.lt.cp1%krel+2 .or. cp1%let.le.cp1%krel+1) then
       ocode=6; return
    else
       call cumulus_tend_k(dpn, sd, Uw_p, cp1, ct1, do_coldT)
    end if
    
  end subroutine dpconv3


!#####################################################################
!#####################################################################

subroutine DEEP_CONV_INIT

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized = .true.
    


end subroutine DEEP_CONV_INIT
!#####################################################################
!#####################################################################
subroutine DEEP_CONV_END

      module_is_initialized = .false.


end subroutine DEEP_CONV_END

!#####################################################################
!#####################################################################

end MODULE DEEP_CONV_MOD


#include <fms_platform.h>
MODULE UW_CONV_MOD

  use           mpp_mod, only : mpp_pe, mpp_root_pe, stdlog
  use      Constants_Mod, ONLY: tfreeze,HLv,HLf,HLs,CP_AIR,GRAV,Kappa,rdgas,rvgas
  use   Diag_Manager_Mod, ONLY: register_diag_field, send_data
  use   Time_Manager_Mod, ONLY: time_type, get_time 
  use           mpp_mod, only : input_nml_file
  use           fms_mod, only : write_version_number, open_namelist_file, check_nml_error,&
                                FILE_EXIST, ERROR_MESG,  &
                                lowercase, &
                                CLOSE_FILE, FATAL
  use  field_manager_mod, only: MODEL_ATMOS
  use  tracer_manager_mod, only: get_tracer_names, query_method, &
                                 get_tracer_index, NO_TRACER
  use  sat_vapor_pres_mod,only : sat_vapor_pres_init
  use atmos_tracer_utilities_mod, only : get_wetdep_param

  use  rad_utilities_mod, only : aerosol_type
  
  use  aer_ccn_act_mod, only :   aer_ccn_act_init
  use  conv_utilities_mod,only :   uw_params_init
  use  conv_utilities_k_mod,only : sd_init_k, sd_copy_k, sd_end_k,  &
                                   ac_init_k, ac_clear_k, ac_end_k, &
                                   pack_sd_k, adi_cloud_k, extend_sd_k,&
                                   exn_init_k, exn_end_k, findt_init_k,&
                                   findt_end_k, &
                                   check_tracer_realizability, &
                                   qt_parcel_k, &
                                   adicloud, sounding, uw_params

  use  conv_plumes_k_mod,only    : cp_init_k, cp_end_k, cp_clear_k, &
                                   ct_init_k, ct_end_k, ct_clear_k, &
                                   cumulus_tend_k, cumulus_plume_k, &
                                   cplume, ctend, cpnlist, cwetdep_type

  use  conv_closures_mod,only    : cclosure_bretherton,   &
                                   cclosure_relaxcbmf, &
                                   cclosure_relaxwfn,  &
                                   cclosure_implicit, cclosure

  use  deep_conv_mod,only        : deepc, dpconv0, dpconv1, dpconv2, dpconv3

!---------------------------------------------------------------------
  implicit none
  private
!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------

  character(len=128) :: version = '$Id: uw_conv.F90,v 18.0.2.1.6.1 2011/12/12 19:30:45 Peter.Phillipps Exp $'
  character(len=128) :: tagname = '$Name:  $'

!---------------------------------------------------------------------
!-------  interfaces --------

  public  :: uw_conv, uw_conv_init, uw_conv_end

  real, parameter :: aday = 1.
  real, parameter :: mv = -999.
  logical         :: module_is_initialized = .false.

  character(len=7) :: mod_name = 'uw_conv'

  !namelist parameters for UW convection scheme
  integer :: iclosure = 0      ! 0: Bretherton UWShCu orginal / -CIN/TKE based
                               ! 1: Emanuel-Rayment: quasiequilibrium PBL
  real    :: rkm_sh   = 16.0   ! fractional lateral mixing rate for shallow
  real    :: cldhgt_max   = 4.e3
  real    :: cbmf_dp_frac = 0.0
  real    :: landfact_m   = 0.0
  integer :: idpchoice = 0  
  logical :: do_deep = .false.
  logical :: do_relaxcape = .false.
  logical :: do_relaxwfn  = .false.
  logical :: do_coldT = .true.
  logical :: do_lands = .false.
  logical :: do_uwcmt = .false.   
  logical :: do_fast  = .false.
  logical :: do_ice   = .true.
  logical :: do_ppen  = .true.
  logical :: do_forcedlifting = .false.
  real    :: atopevap = 0.
  logical :: apply_tendency = .true.
  logical :: prevent_unreasonable = .true.
  real    :: aerol = 1.e-12
  real    :: gama     = 1.0    ! 
  real    :: tkemin   = 1.e-6
  real    :: wmin_ratio = 0.
  logical :: use_online_aerosol = .false.
  logical :: use_sub_seasalt = .true.
  logical :: do_auto_aero = .false.
  logical :: do_rescale   = .false.
  logical :: do_debug     = .false.
  integer :: cush_choice  = 0
  real    :: pcp_min      = 3e-5
  real    :: pcp_max      = 1.5e-3
  real    :: rhav_ocean   = 0.8
  real    :: rhav_land    = 0.8
  real    :: rh0          = 0.8
  real    :: cush_ref     = 0.
  real    :: pblht0 = 500.
  real    :: tke0 = 1.
  real    :: lofactor0 = 1.
  integer :: lochoice  = 0
  real    :: wrel_min = 1.
  real    :: om_to_oc = 1.67
  real    :: sea_salt_scale = 0.1
  logical :: do_qctflx_zero = .false.
  logical :: do_detran_zero = .false.

  NAMELIST / uw_conv_nml / iclosure, rkm_sh, cldhgt_max, cbmf_dp_frac, &
       do_deep, idpchoice, do_relaxcape, do_relaxwfn, do_coldT, do_lands, do_uwcmt,       &
       do_fast, do_ice, do_ppen, do_forcedlifting, &
       atopevap, apply_tendency, prevent_unreasonable, aerol, gama, tkemin,    &
       wmin_ratio, use_online_aerosol, use_sub_seasalt, landfact_m, pblht0, tke0, lofactor0, lochoice, &
       do_auto_aero, do_rescale, wrel_min, om_to_oc, sea_salt_scale,                  &
       do_debug, cush_choice, pcp_min, pcp_max, cush_ref,   &
       rhav_ocean, rhav_land, rh0, do_qctflx_zero, do_detran_zero

  !namelist parameters for UW convective plume
  real    :: rle      = 0.10   ! for critical stopping distance for entrainment
  real    :: rpen     = 5.0    ! for entrainment efficiency
  real    :: rmaxfrac = 0.05   ! maximum allowable updraft fraction
  real    :: wmin     = 0.0    ! maximum allowable updraft fraction
  real    :: rbuoy    = 1.0    ! for nonhydrostatic pressure effects on updraft
  real    :: rdrag    = 1.0 
  real    :: frac_drs = 0.0    ! 
  real    :: bigc     = 0.7    ! for momentum transfer
  real    :: auto_th0 = 0.5e-3 ! threshold for precipitation
  real    :: auto_rate= 1.e-3
  real    :: tcrit    = -45.0  ! critical temperature 
  real    :: deltaqc0 = 0.5e-3 
  logical :: do_pdfpcp= .false.
  logical :: do_pmadjt= .false.
  logical :: do_emmax = .false.
  logical :: do_pnqv  = .false.
  real    :: rad_crit = 14.0   ! critical droplet radius
  real    :: emfrac_max = 1.0
  integer :: mixing_assumption = 0
  integer :: mp_choice = 1
  real    :: Nl_land   = 300.e6
  real    :: Nl_ocean  = 100.e6
  real    :: qi_thresh = 1.e-4
  real    :: r_thresh  = 12.e-6
  logical :: do_pevap = .false.
  real    :: cfrac     = 0.05
  real    :: hcevap    = 0.8
  logical :: do_weffect = .false.
  real    :: weffect    = 0.5
  real    :: peff       = 1.0
  real    :: t00        = 295

  NAMELIST / uw_plume_nml / rle, rpen, rmaxfrac, wmin, rbuoy, rdrag, frac_drs, bigc, &
       auto_th0, auto_rate, tcrit, deltaqc0, do_pdfpcp, do_pmadjt, do_emmax, do_pnqv, rad_crit, emfrac_max, &
       mixing_assumption, mp_choice, Nl_land, Nl_ocean, qi_thresh, r_thresh, do_pevap, cfrac, hcevap, &
       do_weffect, weffect, peff, t00
  !namelist parameters for UW convective closure
  integer :: igauss   = 1      ! options for cloudbase massflux closure
                               ! 1: cin/gaussian closure, using TKE to compute CIN.
                               ! 2: cin/gaussian closure, using W* to compute CIN.
                               ! 0: cin/tke mapse-style closure; 
  real    :: rkfre    = 0.05   ! vertical velocity variance as fraction of tke
  real    :: tau_sh   = 7200.  ! 
  real    :: wcrit_min= 0.

  NAMELIST / uw_closure_nml / igauss, rkfre, tau_sh, wcrit_min


!========Option for deep convection=======================================
  real, dimension(7) :: rkm_dp
  data  rkm_dp / 0.302, 0.232, 0.168, 0.121, 0.092, 0.067, 0.030 /
  real, dimension(7) :: rat_dp    
  data  rat_dp / 0.292, 0.076, 0.102, 0.093, 0.088, 0.157, 0.192 /
  integer :: ideep_closure       = 0
  integer :: mixing_assumption_d = 0
  logical :: do_generation = .false.
  logical :: do_ppen_d   = .true.
  logical :: do_pevap_d  = .false.
  real    :: cape_th   = 0.
  real    :: omeg_th   = 0.
  real    :: tau_dp    = 7200.
  real    :: rpen_d    = 5.0

  NAMELIST / deep_conv_nml / rkm_dp, rat_dp, ideep_closure,     &
       do_generation, cape_th, omeg_th, tau_dp, mixing_assumption_d, &
       do_ppen_d, rpen_d, do_pevap_d
!========Option for deep convection=======================================

!------------------------------------------------------------------------

  integer :: nqv, nql, nqi, nqa ,nqn
  logical :: do_qn = .false.    ! use droplet number tracer field ?

  integer :: id_tdt_uwc, id_qdt_uwc, id_prec_uwc, id_snow_uwc,               &
       id_cin_uwc, id_cbmf_uwc, id_tke_uwc, id_plcl_uwc, id_zinv_uwc,  &
       id_cush_uwc, id_pct_uwc, id_pcb_uwc, id_plfc_uwc, id_enth_uwc,  &
       id_qldt_uwc, id_qidt_uwc, id_qadt_uwc, id_qndt_uwc, id_cmf_uwc, id_wu_uwc,   &
       id_fer_uwc,  id_fdr_uwc, id_fdrs_uwc, id_cqa_uwc, id_cql_uwc,   &
       id_cqi_uwc,  id_cqn_uwc, id_hlflx_uwc, id_qtflx_uwc,           &
       id_cape_uwc, id_dcin_uwc, id_dcape_uwc, id_dwfn_uwc, id_rhav_uwc,&
       id_ocode_uwc, id_plnb_uwc, id_wrel_uwc, id_ufrc_uwc, id_qtmp_uwc,&
       id_tdt_pevap_uwc, id_qdt_pevap_uwc, id_xhlsrc_uwc, id_xqtsrc_uwc,&
       id_qldet_uwc, id_qidet_uwc, id_qadet_uwc, id_qtdt_uwc, id_dting_uwc, &
       id_cfq_uwc, id_fdp_uwc, id_hmo_uwc, id_hms_uwc, id_abu_uwc, id_peo_uwc


  integer, allocatable :: id_tracerdt_uwc(:), id_tracerdt_uwc_col(:), &
                          id_tracerdtwet_uwc(:), id_tracerdtwet_uwc_col(:)

!========Option for deep convection=======================================
  integer :: id_tdt_uwd, id_qdt_uwd, id_qtdt_uwd, id_prec_uwd, id_snow_uwd,   &
       id_cbmf_uwd, id_enth_uwd, id_qldt_uwd, id_qidt_uwd,             &
       id_qndt_uwd, id_qadt_uwd, id_cmf_uwd, id_wu_uwd, id_fer_uwd,    &
       id_fdr_uwd, id_fdrs_uwd, id_cqa_uwd, id_cql_uwd, id_cqi_uwd,    &
       id_cqn_uwd, id_hlflx_uwd, id_qtflx_uwd, id_dcin_uwd,            &
       id_dcape_uwd, id_dwfn_uwd, id_ocode_uwd,                        &
       id_tdt_pevap_uwd, id_qdt_pevap_uwd
!========Option for deep convection=======================================

  type(cwetdep_type), dimension(:), allocatable :: wetdep
  type(uw_params),  save  :: Uw_p
  character(len=32), dimension(:), allocatable   :: tracername 
  character(len=32), dimension(:), allocatable   :: tracer_units 

contains

!#####################################################################
!#####################################################################

  SUBROUTINE UW_CONV_INIT(do_strat, axes, Time, kd, tracers_in_uw)
    logical,         intent(in) :: do_strat
    integer,         intent(in) :: axes(4), kd
    type(time_type), intent(in) :: Time
    logical,         intent(in) :: tracers_in_uw(:)
    
!---------------------------------------------------------------------
!  intent(in) variables:
!
!      tracers_in_uw 
!                   logical array indicating which of the activated 
!                   tracers are to be transported by UW convection
!
!-------------------------------------------------------------------

    integer   :: unit, io
    
    integer   :: ntracers, n, nn, ierr, logunit
    logical   :: flag
    character(len=200) :: text_in_scheme, control
     real :: frac_junk
 
    ntracers = count(tracers_in_uw)

    call uw_params_init   (Uw_p)

!   Initialize lookup tables needed for findt and exn
!   sat_vapor_pres needs to be initialized if not already done
    call sat_vapor_pres_init     
    call exn_init_k (Uw_p)
    call findt_init_k (Uw_p)

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=uw_closure_nml, iostat=io)
      ierr = check_nml_error(io,'uw_closure_nml')
      read (input_nml_file, nml=uw_conv_nml, iostat=io)
      ierr = check_nml_error(io,'uw_conv_nml')
      read (input_nml_file, nml=uw_plume_nml, iostat=io)
      ierr = check_nml_error(io,'uw_plume_nml')
      read (input_nml_file, nml=deep_conv_nml, iostat=io)
      ierr = check_nml_error(io,'deep_conv_nml')
#else   
    if( FILE_EXIST( 'input.nml' ) ) then
       unit = OPEN_NAMELIST_FILE ()
       io = 1
       do while ( io .ne. 0 )
          READ( unit, nml = uw_closure_nml, iostat = io, end = 10 )
          ierr = check_nml_error(io,'uw_closure_nml')
       end do
10     call close_file ( unit )

       unit = OPEN_NAMELIST_FILE ()
       io = 1
       do while ( io .ne. 0 )
          READ( unit, nml = uw_conv_nml, iostat = io, end = 20 )
          ierr = check_nml_error(io,'uw_conv_nml')
       end do
20     call close_file ( unit )
       
       unit = OPEN_NAMELIST_FILE ()
       io = 1
       do while ( io .ne. 0 )
          READ( unit, nml = uw_plume_nml, iostat = io, end = 30 )
          ierr = check_nml_error(io,'uw_plume_nml')
       end do
30     call close_file ( unit )

!========Option for deep convection=======================================
       unit = OPEN_NAMELIST_FILE ()
       io = 1
       do while ( io .ne. 0 )
          READ( unit, nml = deep_conv_nml, iostat = io, end = 40 )
          ierr = check_nml_error(io,'deep_conv_nml')
       end do
40     call close_file ( unit )
!========Option for deep convection=======================================
    end if
#endif
    call write_version_number (version, tagname)
    logunit = stdlog()
    WRITE( logunit, nml = uw_closure_nml )
    WRITE( logunit, nml = uw_conv_nml )
    WRITE( logunit, nml = uw_plume_nml )
    WRITE( logunit, nml = deep_conv_nml )

    if ( use_online_aerosol ) call aer_ccn_act_init

    nqv = get_tracer_index ( MODEL_ATMOS, 'sphum' )
    nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
    nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
    nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
    nqn = get_tracer_index ( MODEL_ATMOS, 'liq_drp' )
    if (nqn /= NO_TRACER) do_qn = .true.
    if (ntracers > 0) then
      allocate ( tracername   (ntracers) )
      allocate ( tracer_units (ntracers) )
      allocate ( wetdep       (ntracers) )
      nn = 1
      do n=1,size(tracers_in_uw(:))
         if (tracers_in_uw(n)) then
             call get_tracer_names (MODEL_ATMOS, n,  &
                                    name = tracername(nn), &
                                    units = tracer_units(nn))
             flag = query_method( 'wet_deposition', MODEL_ATMOS, n, &
                                  text_in_scheme, control )
             call get_wetdep_param( text_in_scheme, control, &
                                    wetdep(nn)%scheme, &
                                    wetdep(nn)%Henry_constant, &
                                    wetdep(nn)%Henry_variable, &
                                    frac_junk, &
                                    wetdep(nn)%alpha_r, &
                                    wetdep(nn)%alpha_s, &
                                    wetdep(nn)%Lwetdep, &
                                    wetdep(nn)%Lgas, &
                                    wetdep(nn)%Laerosol, &
                                    wetdep(nn)%Lice, &
                                    frac_in_cloud_uw=wetdep(nn)%frac_in_cloud )
             wetdep(nn)%scheme = lowercase( wetdep(nn)%scheme )
             nn = nn + 1
          endif
       end do
    endif

    id_xhlsrc_uwc = register_diag_field (mod_name,'xhlsrc_uwc', axes(1:2), Time, &
         'xhlsrc', 'J/kg' )
    id_xqtsrc_uwc = register_diag_field (mod_name,'xqtsrc_uwc', axes(1:2), Time, &
         'xqtsrc', 'kg/kg' )

    id_tdt_pevap_uwc = register_diag_field ( mod_name, 'tdt_pevap_uwc', axes(1:3), Time, &
         'Temperature tendency due to pevap from uw_conv', 'K/s', missing_value=mv )
    id_qdt_pevap_uwc = register_diag_field ( mod_name, 'qdt_pevap_uwc', axes(1:3), Time, &
         'Spec. humidity tendency due to pevap from uw_conv', 'kg/kg/s', missing_value=mv)

    id_tdt_uwc = register_diag_field ( mod_name, 'tdt_uwc', axes(1:3), Time, &
         'Temperature tendency from uw_conv', 'K/s', missing_value=mv )
    id_qdt_uwc = register_diag_field ( mod_name, 'qdt_uwc', axes(1:3), Time, &
         'Spec. humidity tendency from uw_conv', 'kg/kg/s', missing_value=mv)
    id_cmf_uwc = register_diag_field ( mod_name, 'cmf_uwc', axes(1:3), Time, &
         'Cloud vert. mass flux from uw_conv', 'kg/m2/s', missing_value=mv)
    id_cfq_uwc = register_diag_field ( mod_name, 'cfq_uwc', axes(1:3), Time,   &
         'Convective frequency', 'none', missing_value=mv)
    id_peo_uwc = register_diag_field ( mod_name, 'peo_uwc', axes(1:3), Time,   &
         'Convective precipitation efficiency', 'none', missing_value=mv)
    id_hmo_uwc = register_diag_field ( mod_name, 'hmo_uwc', axes(1:3), Time,   &
         'moist static energy', 'J/kg', missing_value=mv)
    id_hms_uwc = register_diag_field ( mod_name, 'hms_uwc', axes(1:3), Time,   &
         'moist static energy', 'J/kg', missing_value=mv)
    id_abu_uwc = register_diag_field ( mod_name, 'abu_uwc', axes(1:3), Time,   &
         'adiabatic buoyancy', 'K', missing_value=mv)
    id_wu_uwc = register_diag_field ( mod_name, 'wu_uwc', axes(1:3), Time,   &
         'Updraft vert. velocity from uw_conv', 'm/s', missing_value=mv)
    id_fer_uwc = register_diag_field ( mod_name, 'fer_uwc', axes(1:3), Time, &
         'Fractional entrainment rate from uw_conv', '1/Pa', missing_value=mv)
    id_fdr_uwc = register_diag_field ( mod_name, 'fdr_uwc', axes(1:3), Time, &
         'Fractional detrainment rate from uw_conv', '1/Pa', missing_value=mv)
    id_fdrs_uwc = register_diag_field (mod_name,'fdrs_uwc', axes(1:3), Time, &
         'Detrainment rate for sat. air from uw_conv', '1/Pa', missing_value=mv)
    id_cqa_uwc = register_diag_field ( mod_name, 'cqa_uwc', axes(1:3), Time, &
         'Updraft fraction from uw_conv', 'none', missing_value=mv)
    id_cql_uwc = register_diag_field ( mod_name, 'cql_uwc', axes(1:3), Time, &
         'Updraft liquid from uw_conv', 'kg/kg', missing_value=mv)
    id_cqi_uwc = register_diag_field ( mod_name, 'cqi_uwc', axes(1:3), Time, &
         'Updraft ice from uw_conv', 'kg/kg', missing_value=mv)
    id_cqn_uwc = register_diag_field ( mod_name, 'cqn_uwc', axes(1:3), Time, &
         'Updraft liquid drop from uw_conv', '/kg', missing_value=mv)
    id_hlflx_uwc=register_diag_field (mod_name,'hlflx_uwc',axes(1:3),Time, &
         'Liq.wat.pot.temp. flux from uw_conv', 'W/m2', missing_value=mv)
    id_qtflx_uwc = register_diag_field (mod_name,'qtflx_uwc',axes(1:3),Time, &
         'Total water flux from uw_conv', 'W/m2', missing_value=mv)
    id_prec_uwc = register_diag_field (mod_name,'prec_uwc', axes(1:2), Time, &
         'Precipitation rate from uw_conv', 'kg/m2/sec',                     &
         interp_method = "conserve_order1" )
    id_snow_uwc = register_diag_field (mod_name,'snow_uwc', axes(1:2), Time, &
         'Frozen precip. rate from uw_conv', 'kg/m2/sec',                       &
         interp_method = "conserve_order1" )
    id_cin_uwc = register_diag_field ( mod_name, 'cin_uwc', axes(1:2), Time, &
         'CIN from uw_conv', 'm2/s2' )
    id_cape_uwc= register_diag_field ( mod_name,'cape_uwc', axes(1:2), Time, &
         'CAPE from uw_conv', 'm2/s2' )
    id_rhav_uwc= register_diag_field ( mod_name,'rhav_uwc', axes(1:2), Time, &
         'Vertically averaged RH from uw_conv', '%' )
    id_cbmf_uwc = register_diag_field (mod_name,'cbmf_uwc', axes(1:2), Time, &
         'Cloud-base mass flux from uw_conv', 'kg/m2/s' )
    id_wrel_uwc = register_diag_field (mod_name,'wrel_uwc', axes(1:2), Time, &
         'Release level vertical velocity from uw_conv', 'm/s' )
    id_ufrc_uwc = register_diag_field (mod_name,'ufrc_uwc', axes(1:2), Time, &
         'Release level updraft fraction from uw_conv', 'none' )
    id_tke_uwc = register_diag_field ( mod_name, 'tke_uwc', axes(1:2), Time, &
         'PBL mean TKE from uw_conv', 'm2/s2' )
    id_plcl_uwc = register_diag_field (mod_name,'plcl_uwc', axes(1:2), Time, &
         'LCL pressure from uw_conv', 'hPa' )
    id_plfc_uwc = register_diag_field (mod_name,'plfc_uwc', axes(1:2), Time, &
         'LFC pressure from uw_conv', 'hPa' )
    id_plnb_uwc = register_diag_field (mod_name,'plnb_uwc', axes(1:2), Time, &
         'LNB pressure from uw_conv', 'hPa' )
    id_zinv_uwc = register_diag_field (mod_name,'zinv_uwc', axes(1:2), Time, &
         'Inversion pressure from uw_conv', 'm' )
    id_pct_uwc = register_diag_field ( mod_name, 'pct_uwc', axes(1:2), Time, &
         'Cloud-top pressure from uw_conv', 'hPa' )
    id_pcb_uwc = register_diag_field ( mod_name, 'pcb_uwc', axes(1:2), Time, &
         'Cloud-base pressure from uw_conv', 'hPa' )
    id_cush_uwc = register_diag_field (mod_name,'cush_uwc', axes(1:2), Time, &
         'Convective scale height from uw_conv', 'm' )
    id_dcin_uwc = register_diag_field (mod_name, 'dcin_uwc', axes(1:2), Time, &
         'dCIN/cbmf from uw_conv', 'm2/s2/(kg/m2/s)' )
    id_dcape_uwc= register_diag_field (mod_name, 'dcape_uwc', axes(1:2), Time, &
         'dCAPE/cbmf from uw_conv', 'm2/s2/(kg/m2/s)' )
    id_dwfn_uwc = register_diag_field (mod_name, 'dwfn_uwc',  axes(1:2), Time, &
         'dwfn/cbmf from uw_conv', '(m2/s2)/(kg/m2/s)' )
    id_enth_uwc = register_diag_field (mod_name,'enth_uwc', axes(1:2), Time, &
         'Column-integrated enthalpy tendency from uw_conv', 'W/m2' )
    id_qtmp_uwc = register_diag_field (mod_name,'qtmp_uwc', axes(1:2), Time, &
         'Column-integrated water tendency from uw_conv', 'kg/m2/s' )
    id_dting_uwc = register_diag_field (mod_name,'dting_uwc', axes(1:2), Time, &
         'Column-integrated heating rate from uw_conv', 'W/m2' )
    id_ocode_uwc = register_diag_field (mod_name,'ocode_uwc', axes(1:2), Time, &
         'Out code from uw_conv', 'none' )
    id_fdp_uwc = register_diag_field ( mod_name, 'fdp_uwc',   axes(1:2), Time,   &
         'Deep convective frequency', 'none', missing_value=mv)
    if ( do_strat ) then
       id_qldt_uwc= register_diag_field (mod_name,'qldt_uwc',axes(1:3),Time, &
            'Liquid water tendency from uw_conv', 'kg/kg/s', missing_value=mv)
       id_qidt_uwc= register_diag_field (mod_name,'qidt_uwc',axes(1:3),Time, &
            'Ice water tendency from uw_conv', 'kg/kg/s', missing_value=mv)
       id_qadt_uwc= register_diag_field (mod_name,'qadt_uwc',axes(1:3),Time, &
            'CLD fraction tendency from uw_conv', '1/s', missing_value=mv )
       id_qndt_uwc= register_diag_field (mod_name,'qndt_uwc',axes(1:3),Time, &
            'Cloud droplet number fraction tendency from uw_conv', '#/kg/s', missing_value=mv )
       id_qldet_uwc = register_diag_field (mod_name,'qldet_uwc',axes(1:3),Time, &
            'ql detrainment', 'kg/kg/s', missing_value=mv)
       id_qidet_uwc = register_diag_field (mod_name,'qidet_uwc',axes(1:3),Time, &
            'qi detrainment', 'kg/kg/s', missing_value=mv)
       id_qadet_uwc = register_diag_field (mod_name,'qadet_uwc',axes(1:3),Time, &
            'qa detrainment', '1/s', missing_value=mv)
       id_qtdt_uwc= register_diag_field (mod_name,'qtdt_uwc',axes(1:3),Time, &
            'Total water tendency from uw_conv', 'kg/kg/s', missing_value=mv)
    end if

!========Option for deep convection=======================================
    if (do_deep) then
       id_tdt_pevap_uwd = register_diag_field ( mod_name, 'tdt_pevap_uwd', axes(1:3), Time, &
            'Temperature tendency due to pevap from deep_conv', 'K/s', missing_value=mv )
       id_qdt_pevap_uwd = register_diag_field ( mod_name, 'qdt_pevap_uwd', axes(1:3), Time, &
            'Spec. humidity tendency due to pevap from deep_conv', 'kg/kg/s', missing_value=mv)

       id_tdt_uwd = register_diag_field ( mod_name, 'tdt_uwd', axes(1:3), Time, &
            'Temperature tendency from deep_conv', 'K/s', missing_value=mv )
       id_qdt_uwd = register_diag_field ( mod_name, 'qdt_uwd', axes(1:3), Time, &
            'Spec. humidity tendency from deep_conv', 'kg/kg/s', missing_value=mv)
       id_qtdt_uwd= register_diag_field ( mod_name, 'qtdt_uwd', axes(1:3), Time, &
            'Total water spec. humidity tendency from deep_conv', 'kg/kg/s', missing_value=mv)
       id_cmf_uwd = register_diag_field ( mod_name, 'cmf_uwd', axes(1:3), Time, &
            'Cloud vert. mass flux from deep_conv', 'kg/m2/s', missing_value=mv)
       id_wu_uwd = register_diag_field ( mod_name, 'wu_uwd', axes(1:3), Time,   &
            'Updraft vert. velocity from deep_conv', 'm/s', missing_value=mv)
       id_fer_uwd = register_diag_field ( mod_name, 'fer_uwd', axes(1:3), Time, &
         'Fractional entrainment rate from deep_conv', '1/Pa', missing_value=mv)
       id_fdr_uwd = register_diag_field ( mod_name, 'fdr_uwd', axes(1:3), Time, &
            'Fractional detrainment rate from deep_conv', '1/Pa', missing_value=mv)
       id_fdrs_uwd = register_diag_field (mod_name,'fdrs_uwd', axes(1:3), Time, &
            'Detrainment rate for sat. air from deep_conv', '1/Pa', missing_value=mv)
       id_cqa_uwd = register_diag_field ( mod_name, 'cqa_uwd', axes(1:3), Time, &
            'Updraft fraction from deep_conv', 'none', missing_value=mv)
       id_cql_uwd = register_diag_field ( mod_name, 'cql_uwd', axes(1:3), Time, &
         'Updraft liquid from deep_conv', 'kg/kg', missing_value=mv)
       id_cqi_uwd = register_diag_field ( mod_name, 'cqi_uwd', axes(1:3), Time, &
            'Updraft ice from deep_conv', 'kg/kg', missing_value=mv)
       id_cqn_uwd = register_diag_field ( mod_name, 'cqn_uwd', axes(1:3), Time, &
            'Updraft liquid drop from deep_conv', '/kg', missing_value=mv)
       id_hlflx_uwd=register_diag_field (mod_name,'hlflx_uwd',axes(1:3),Time, &
            'Liq.wat.pot.temp. flux from deep_conv', 'W/m2', missing_value=mv)
       id_qtflx_uwd = register_diag_field (mod_name,'qtflx_uwd',axes(1:3),Time, &
            'Total water flux from deep_conv', 'W/m2', missing_value=mv)
       id_prec_uwd = register_diag_field (mod_name,'prec_uwd', axes(1:2), Time, &
            'Precipitation rate from deep_conv', 'kg/m2/sec' )
       id_snow_uwd = register_diag_field (mod_name,'snow_uwd', axes(1:2), Time, &
            'Frozen precip. rate from deep_conv', 'kg/m2/sec' )
       id_cbmf_uwd = register_diag_field (mod_name,'cbmf_uwd', axes(1:2), Time, &
            'Cloud-base mass flux from deep_conv', 'kg/m2/s' )
       id_dcape_uwd= register_diag_field (mod_name, 'dcape_uwd', axes(1:2), Time, &
            'dCAPE/cbmf from deep_conv', 'm2/s2/(kg/m2/s)' )
       id_dwfn_uwd = register_diag_field (mod_name, 'dwfn_uwd',  axes(1:2), Time, &
            'dwfn/cbmf from deep_conv', '(m2/s2)/(kg/m2/s)' )
       id_enth_uwd = register_diag_field (mod_name,'enth_uwd', axes(1:2), Time, &
            'Column-integrated enthalpy tendency from deep_conv', 'K/s' )
       id_ocode_uwd = register_diag_field (mod_name,'ocode_uwd', axes(1:2), Time, &
            'Out code from deep_conv', 'none' )
       if ( do_strat ) then
          id_qldt_uwd= register_diag_field (mod_name,'qldt_uwd',axes(1:3),Time, &
               'Liquid water tendency from deep_conv', 'kg/kg/s', missing_value=mv)
          id_qidt_uwd= register_diag_field (mod_name,'qidt_uwd',axes(1:3),Time, &
               'Ice water tendency from deep_conv', 'kg/kg/s', missing_value=mv)
          id_qadt_uwd= register_diag_field (mod_name,'qadt_uwd',axes(1:3),Time, &
               'CLD fraction tendency from deep_conv', '1/s', missing_value=mv )
       end if
    end if
!========Option for deep convection=======================================


    if ( ntracers>0 ) then
      allocate(id_tracerdt_uwc(ntracers), id_tracerdt_uwc_col(ntracers) )
       allocate(id_tracerdtwet_uwc(ntracers), id_tracerdtwet_uwc_col(ntracers))
      do nn = 1,ntracers
         id_tracerdt_uwc(nn) = &
            register_diag_field (mod_name, trim(tracername(nn))//'dt_uwc', &
                                    axes(1:3), Time, &
                                  trim(tracername(nn)) //' tendency from uw_conv', &
                                  trim(tracer_units(nn))//'/s', missing_value=mv)
            id_tracerdt_uwc_col(nn) = &
              register_diag_field (mod_name, trim(tracername(nn))//'dt_uwc_col', &
                                     axes(1:2), Time, &
                                   trim(tracername(nn)) //' column tendency from uw_conv', &
                                   trim(tracer_units(nn))//'*(kg/m2)/s', missing_value=mv)
           id_tracerdtwet_uwc(nn) = &
              register_diag_field (mod_name, trim(tracername(nn))//'dt_uwc_wet', &
                                    axes(1:3), Time, &
                                   trim(tracername(nn)) //' tendency from uw_conv wetdep', &
                                   trim(tracer_units(nn))//'/s', missing_value=mv)
            id_tracerdtwet_uwc_col(nn) = &
              register_diag_field (mod_name, trim(tracername(nn))//'dt_uwc_wet_col', &
                                   axes(1:2), Time, &
                                   trim(tracername(nn)) //' column tendency from uw_conv wetdep', &
                                   trim(tracer_units(nn))//'*(kg/m2)/s', missing_value=mv)
        end do
     end if

    module_is_initialized = .true.

    
  end SUBROUTINE UW_CONV_INIT

!#####################################################################
!#####################################################################

  subroutine uw_conv_end
    call exn_end_k
    call findt_end_k
    module_is_initialized = .FALSE.
  end subroutine uw_conv_end

!#####################################################################
!#####################################################################

  SUBROUTINE uw_conv(is, js, Time, tb, qv, ub, vb, pmid, pint,zmid,  & !input
       zint, q, omega, delt, pblht, ustar, bstar, qstar, land, coldT,& !input
       asol,                                                         & !input
       cush, do_strat,  skip_calculation, max_available_cf,          & !input
       tten, qvten, qlten, qiten, qaten, qnten,                      & !output
       uten, vten, rain, snow,                                       & !output
       cmf, hlflx, qtflx, pflx, liq_pflx, ice_pflx, cldql, cldqi, cldqa,cldqn, cbmfo,  & !output
        tracers, trtend, uw_wetdep)

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!
!     SHALLOW CONVECTION SCHEME
!     Described in Bretherton et. al (MWR, April 2004)
!     For info contact Ming Zhao: ming.zhao@noaa.gov
!
!     Inputs: see below
!
!     Outputs: see below
!
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    implicit none

    type(time_type), intent(in)  :: Time
    integer,         intent(in)  :: is, js
    real,            intent(in)  :: delt 

    real, intent(in), dimension(:,:,:)   :: ub,vb !wind profile (m/s)
    real, intent(in), dimension(:,:,:)   :: zint  !height@model interfaces(m)
    real, intent(in), dimension(:,:,:)   :: pint  !pressure@model interfaces(pa)
    real, intent(in), dimension(:,:,:)   :: tb    !temperature profile (K)
    real, intent(in), dimension(:,:,:)   :: qv    !specific humidity profile (kg/kg)
    real, intent(in), dimension(:,:,:,:) :: q     !specific humidity profile (kg/kg)
    real, intent(in), dimension(:,:,:)   :: pmid  !pressure@model mid-levels (pa)
    real, intent(in), dimension(:,:,:)   :: zmid  !height@model mid-levels (m)
    real, intent(in), dimension(:,:,:)   :: omega !omega (Pa/s)
    real, intent(in), dimension(:,:)     :: land  !land fraction
    real, intent(in), dimension(:,:,:)   :: max_available_cf !  largest
                                     ! realizable value for uw cld frac
                                   ! after accounting for deep cld frac
    logical,intent(in), dimension(:,:)   :: skip_calculation ! do not
                                                 ! calculate where .true.
    logical,intent(in)                   :: do_strat !logical flag
    logical,intent(in), dimension(:,:)   :: coldT    !logical flag

    real, intent(in),    dimension(:,:)  :: pblht, ustar, bstar, qstar !pbl height...
    real, intent(inout), dimension(:,:)  :: cush  ! convective scale height (m) 

    type(aerosol_type),  intent (in)     :: asol
   
    real, intent(out), dimension(:,:,:)  :: tten,qvten              ! T,qv tendencies
    real, intent(out), dimension(:,:,:)  :: qlten,qiten,qaten,qnten ! q tendencies
    real, intent(out), dimension(:,:,:)  :: uten,vten               ! u,v tendencies
   
    real, intent(out), dimension(:,:,:)  :: cldql,cldqi,cldqa, cldqn!in-updraft q
    real, intent(out), dimension(:,:,:)  :: cmf    ! mass flux at level above layer (kg/m2/s)
    real, intent(out), dimension(:,:,:)  :: pflx   ! precipitation flux removed from a layer
    real, intent(out), dimension(:,:,:)  :: liq_pflx   ! liq precipitation flux removed from a layer
    real, intent(out), dimension(:,:,:)  :: ice_pflx   ! solid precipitation flux removed from a layer
    real, intent(out), dimension(:,:,:)  :: hlflx ! theta_l flux
    real, intent(out), dimension(:,:,:)  :: qtflx  ! qt  flux
    real, intent(out), dimension(:,:)    :: rain, snow
    real, intent(inout), dimension(:,:)  :: cbmfo  ! cloud-base mass flux
    real, intent(in),  dimension(:,:,:,:)  :: tracers         ! env. tracers
    real, intent(out), dimension(:,:,:,:)  :: trtend          ! calculated tracer tendencies
    real, intent(out), dimension(:,:,:)  :: uw_wetdep       ! calculated wet depostion for tracers

    integer i, j, k, kl, klm, nk, naer, na, n

    real rhos0j
    real hlsrc, thcsrc, qctsrc, tmp, lofactor
    real zsrc, psrc, cbmf_shallow, cbmf_old, cbmf_deep, rkm_sh1, omeg_avg, dpsum
    real, dimension(size(tb,1),size(tb,2)) :: &
         plcl,       &     ! pressure of lifting condensation level (Pa)
         plfc,       &     ! pressure of level of free convection (Pa)
         plnb,       &     ! pressure of level of neutral buoyancy (Pa)
         cino,       &     ! cin (m2/s2)
         capeo,      &     ! cape(m2/s2)
         tkeo,       &     ! tke (m2/s2)
         wrelo,      &     ! release level vertical velocity (m/s)
         ufrco,      &     ! cloud-base updraft fraction
         zinvo,      &     ! surface driven mixed-layer height
         denth,      &     
         dqtmp,      &
         dting,      &
         dcino,      &     ! dcin (m2/s2)
         dcapeo,     &     ! dcape(m2/s2)
         dwfno,      &     ! dwfn(m2/s2)
         ocode,      &
         xhlsrc,     &
         xqtsrc,     &
         rhavo,      &
         fdp

    real, dimension(size(tb,1),size(tb,2),size(tb,3)) :: wuo,fero,fdro,fdrso, tten_pevap, qvten_pevap
    real, dimension(size(tb,1),size(tb,2),size(tb,3)) :: qldet, qidet, qadet, cfq, peo, hmo, hms, abu

    real, dimension(size(tb,1),size(tb,2))            :: scale_uw
    real :: qtin, dqt, temp_1

!========Option for deep convection=======================================
    real, dimension(size(tb,1),size(tb,2),size(tb,3)) :: uten_d, vten_d, tten_d, &
         qvten_d, qlten_d, qiten_d, qaten_d, qnten_d, cmf_d, pflx_d, hlflx_d, qtflx_d, qtten_d, &
         wuo_d, fero_d, fdro_d, fdrso_d, cldql_d, cldqi_d, cldqa_d, cldqn_d, tten_pevap_d, qvten_pevap_d
    real, dimension(size(tb,1),size(tb,2)) :: rain_d, snow_d, dcape_d, dwfn_d, denth_d, cbmf_d
!========Option for deep convection=======================================

    real, dimension(size(tb,3)) :: am1, am2, am3, am4, am5, qntmp
    
    real, dimension(size(tb,1),size(tb,2),size(tb,3)) :: pmass    ! layer mass (kg/m2)
    real, dimension(size(tb,1),size(tb,2))            :: tempdiag ! temporary diagnostic variable
    real, dimension(size(tracers,1),size(tracers,2),size(tracers,3),size(tracers,4))  :: trwet 
    ! calculated tracer wet deposition tendencies

    integer imax, jmax, kmax
    integer kd, ntracers
    
    logical used
    type(sounding)          :: sd, sd1
    type(adicloud)          :: ac, ac1
    type(cclosure)          :: cc, cc1
    type(cplume)            :: cp, cp1
    type(ctend)             :: ct, ct1
    type(cpnlist)           :: cpn
    type(deepc)             :: dpc
    integer ::  ier
    character(len=256) :: ermesg

    kd = size(tracers,3)
    ntracers = size(tracers,4)
    call sd_init_k(kd,ntracers,sd);
    call sd_init_k(kd,ntracers,sd1);
    call ac_init_k(kd,ac);
    call ac_init_k(kd,ac1);
    call cp_init_k(kd,ntracers,cp)
    call cp_init_k(kd,ntracers,cp1)
    call ct_init_k(kd,ntracers,ct)
    call ct_init_k(kd,ntracers,ct1)
    !pack namelist parameters into plume and closure structure
    cpn % do_qctflx_zero = do_qctflx_zero
    cpn % do_detran_zero = do_detran_zero
    cpn % rle       = rle
    cpn % rpen      = rpen
    cpn % rmaxfrac  = rmaxfrac
    cpn % wmin      = wmin
    cpn % rbuoy     = rbuoy
    cpn % rdrag     = rdrag  
    cpn % frac_drs  = frac_drs
    cpn % bigc      = bigc    
    cpn % auto_th0  = auto_th0
    cpn % deltaqc0  = deltaqc0
    cpn % do_pdfpcp = do_pdfpcp
    cpn % do_pmadjt = do_pmadjt
    cpn % do_emmax  = do_emmax
    cpn % do_pnqv   = do_pnqv
    cpn % emfrac_max= emfrac_max
    cpn % auto_rate = auto_rate
    cpn % tcrit     = tcrit  
    cpn % cldhgt_max= cldhgt_max
    cpn % do_ice    = do_ice
    cpn % do_ppen   = do_ppen
    cpn % do_pevap  = do_pevap
    cpn % hcevap    = hcevap
    cpn % cfrac     = cfrac
    cpn % mixing_assumption= mixing_assumption
    cpn % mp_choice = mp_choice
    cpn % Nl_land   = Nl_land
    cpn % Nl_ocean  = Nl_ocean
    cpn % qi_thresh = qi_thresh
    cpn % r_thresh  = r_thresh
    cpn % peff      = peff
    cpn % t00       = t00
    cpn % rh0       = rh0
    cpn % do_forcedlifting= do_forcedlifting
    cpn % atopevap  = atopevap
    cpn % wtwmin_ratio = wmin_ratio*wmin_ratio
    cpn % do_auto_aero = do_auto_aero
    cpn % rad_crit = rad_crit
    cpn % wrel_min = wrel_min
    cpn % do_weffect = do_weffect
    cpn % weffect    = weffect
    cpn % use_online_aerosol = use_online_aerosol
    if (ntracers > 0) then
      allocate ( cpn%tracername   (ntracers) )
      allocate ( cpn%tracer_units (ntracers) )
      allocate ( cpn%wetdep       (ntracers) )
      cpn%tracername(:) = tracername(:)
      cpn%tracer_units(:) = tracer_units(:)
      cpn%wetdep(:)%scheme = wetdep(:)%scheme
      cpn%wetdep(:)%Henry_constant = wetdep(:)%Henry_constant
      cpn%wetdep(:)%Henry_variable = wetdep(:)%Henry_variable
      cpn%wetdep(:)%frac_in_cloud = wetdep(:)%frac_in_cloud
      cpn%wetdep(:)%alpha_r = wetdep(:)%alpha_r
      cpn%wetdep(:)%alpha_s = wetdep(:)%alpha_s
      cpn%wetdep(:)%Lwetdep = wetdep(:)%Lwetdep
      cpn%wetdep(:)%Lgas = wetdep(:)%Lgas
      cpn%wetdep(:)%Laerosol = wetdep(:)%Laerosol
      cpn%wetdep(:)%Lice = wetdep(:)%Lice
    endif
    cc  % igauss    = igauss
    cc  % rkfre     = rkfre
    cc  % rmaxfrac  = rmaxfrac
    cc  % wcrit_min = wcrit_min
    cc  % rbuoy     = rbuoy
    cc  % tau_sh    = tau_sh
!========Option for deep convection=======================================
    dpc % rkm_dp  = rkm_dp
    dpc % rat_dp  = rat_dp
    dpc % cape_th = cape_th
    dpc % omeg_th = omeg_th
    dpc % tau_dp  = tau_dp
    dpc % ideep_closure = ideep_closure
    dpc % do_generation = do_generation
    dpc % mixing_assumption = mixing_assumption_d
    dpc % do_ppen   =  do_ppen_d
    dpc % do_pevap  =  do_pevap_d
!========Option for deep convection=======================================
    imax  = size( tb, 1 )
    jmax  = size( tb, 2 )
    kmax  = size( tb, 3 )
    sd % kmax=kmax

    kl=kmax-1
    klm=kl-1

   !initialize 3D variables outside the loop

    tten=0.; qvten=0.; qlten=0.; qiten=0.; qaten=0.; qnten=0.;
    uten=0.; vten =0.; rain =0.; snow =0.; plcl =0.; plfc=0.; plnb=0.;  
    cldqa=0.; cldql=0.; cldqi=0.; cldqn=0.;
    hlflx=0.; qtflx=0.; pflx=0.; am1=0.; am2=0.; am3=0.; am4=0.;
    tten_pevap=0.; qvten_pevap=0.;
    ice_pflx = 0. ; liq_pflx = 0.

    cino=0.; capeo=0.; tkeo=0.; wrelo=0.; ufrco=0.; zinvo=0.; wuo=0.; peo=0.; 
    fero=0.; fdro=0.; fdrso=0.; cmf=0.; denth=0.;  dqtmp=0.; ocode=0;
    dcapeo=0.; dcino=0.; dwfno=0.; xhlsrc=0.; xqtsrc=0.; fdp=0.;
    trtend=0.; qldet=0.; qidet=0.; qadet=0.; rhavo=0.; hmo=0.; hms=0.; abu=0.;
    trwet = 0.
    dting = 0.

    naer = size(asol%aerosol,4)

!========Option for deep convection=======================================
    if (do_deep) then
       tten_d=0.; qvten_d=0.; qlten_d=0.; qiten_d=0.; qaten_d=0.; qnten_d=0.;
       uten_d=0.; vten_d =0.; rain_d =0.; snow_d =0.; qtten_d=0.;
       cldqa_d=0.; cldql_d=0.; cldqi_d=0.; cldqn_d=0.;
       hlflx_d=0.; qtflx_d=0.; pflx_d=0.; 
       wuo_d=0.; fero_d=0.; fdro_d=0.; fdrso_d=0.; 
       cmf_d=0.; 
       denth_d=0.; cbmf_d=0.; dcape_d=0.; dcino=0.; dwfn_d=0.;
       tten_pevap_d=0.; qvten_pevap_d=0.;
    end if
!========Option for deep convection=======================================

    do j = 1, jmax
       do i=1, imax

         do k=1,kmax
           pmass(i,j,k) = (pint(i,j,k+1) - pint(i,j,k))/GRAV
         enddo
    !relaxation TKE back to 0 with time-scale of disscale
    !tkeavg = ustar(i,j)*bstar(i,j)*disscale 
    !dissipate tke with length-scale of disscale
    !tkeavg=(ustar(i,j)*bstar(i,j)*disscale)**(2./3.)
    !below following Holtslag and Boville 1993

         if (pblht(i,j).lt.0.) then
           temp_1=0.0
         elseif (pblht(i,j).gt.5000.) then
           temp_1=5000.
         else
           temp_1=pblht(i,j)
         endif
         temp_1=ustar(i,j)**3.+0.6*ustar(i,j)*bstar(i,j)*temp_1
         if (temp_1 .gt. 0.) temp_1 = 0.5*temp_1**(2./3.)
         tkeo(i,j) = MAX (tkemin, temp_1)

         if (skip_calculation(i,j)) then
           ocode(i,j) = 6
           go to 100
         endif
         call clearit(ac, cc, cp, ct, cp1, ct1);

! restrict grid-box area available to shallow convection to that which 
! is not involved with deep convection
          cp%maxcldfrac = minval(max_available_cf(i,j,:))
          cc%maxcldfrac = cp%maxcldfrac

          cc%scaleh = cush(i,j); 
          cush(i,j) = -1.;
          if(cc%scaleh.le.0.0) cc%scaleh=1000.

          am1(:) = 0.; am2(:) = 0.; am3(:) = 0.; am4(:) = 0.; am5(:) = 0.;

          do k=1,kmax
            tmp=1. / (zint(i,j,k)-zint(i,j,k+1)) * 1.0e9 * 1.0e-12
            if(use_online_aerosol) then
              do na = 1,naer
                if(asol%aerosol_names(na) == 'so4' .or. &
                   asol%aerosol_names(na) == 'so4_anthro' .or. &
                   asol%aerosol_names(na) == 'so4_natural') then
                           am1(k)=am1(k)+asol%aerosol(i,j,k,na)*tmp
                else if(asol%aerosol_names(na) == 'omphilic' .or. &
                        asol%aerosol_names(na) == 'omphobic') then
                           am4(k)=am4(k)+asol%aerosol(i,j,k,na)*tmp
                else if(asol%aerosol_names(na) == 'bcphilic' .or. &
                        asol%aerosol_names(na) == 'bcphobic' .or. &
                        asol%aerosol_names(na) == 'dust1' .or. &
                        asol%aerosol_names(na) == 'dust2' .or. &
                        asol%aerosol_names(na) == 'dust3' ) then
                           am2(k)=am2(k)+asol%aerosol(i,j,k,na)*tmp
                else if(asol%aerosol_names(na) == 'seasalt1' .or. &
                        asol%aerosol_names(na) == 'seasalt2') then
                           am3(k)=am3(k)+asol%aerosol(i,j,k,na)*tmp
                else if(asol%aerosol_names(na) == 'seasalt3' .or. &
                        asol%aerosol_names(na) == 'seasalt4' .or. &
                        asol%aerosol_names(na) == 'seasalt5' ) then
                           am5(k)=am5(k)+asol%aerosol(i,j,k,na)*tmp
                end if
              end do
              am2(k)=am2(k)+am3(k)+am4(k)
              if(.not. use_sub_seasalt) am3(k)=am3(k)+am5(k)
            else
              am1(k)= asol%aerosol(i,j,k,2)*tmp
              am2(k)= asol%aerosol(i,j,k,1)*tmp
              am3(k)= sea_salt_scale*asol%aerosol(i,j,k,5)*tmp
              am4(k)= om_to_oc*asol%aerosol(i,j,k,3)*tmp
            endif
          end do

!========Pack column properties into a sounding structure====================

          if (do_qn) then
             qntmp(:)=q(i,j,:,nqn)
          else
             qntmp(:)=0.
          end if
          call pack_sd_k(land(i,j), coldT(i,j), delt, pmid(i,j,:), pint(i,j,:),     &
               zmid(i,j,:), zint(i,j,:), ub(i,j,:), vb(i,j,:), tb(i,j,:),   &
               q(i,j,:,nqv), q(i,j,:,nql), q(i,j,:,nqi), q(i,j,:,nqa), qntmp,       &
               am1(:), am2(:), am3(:), am4(:), tracers(i,j,:,:), sd, Uw_p)

!========Finite volume intepolation==========================================

          call extend_sd_k(sd,  pblht(i,j),do_ice, Uw_p)
          sd%tke = tkeo(i,j)
          zinvo (i,j) = sd%zinv


!========Find source air, and do adiabatic cloud lifting======================

          zsrc  =sd%zs (1)
          psrc  =sd%ps (1)
          thcsrc=sd%thc(1)
          qctsrc=sd%qct(1)
          hlsrc =sd%hl (1)
          rkm_sh1=rkm_sh
          if (do_lands) then
            !wstar   = (ustar(i,j)*bstar(i,j)*pblht(i,j))**(1./3.)
             cpn % auto_th0 = auto_th0 * (1. + landfact_m * sd%land)
             call qt_parcel_k (sd%qs(1), qstar(i,j), pblht(i,j), sd%tke, sd%land, gama, &
                  pblht0, tke0, lofactor0, lochoice, qctsrc, lofactor)
             rkm_sh1 = rkm_sh   * lofactor
          end if

          if (cush_choice.eq.1) then
             if (sd%land.gt.0.3) then
                tmp=0;
                do k=1,sd % ktoppbl
                   tmp=max(tmp, sd%hm(k))
                end do
                do k=1,sd % ktoppbl
                   if (tmp.eq.sd%hm(k)) then
                      zsrc  =sd%zs (k)
                      psrc  =sd%ps (k)
                      thcsrc=sd%thc(k)
                      tmp = min(sd%qct(k)+gama*sd%qs(k), sd%qs(k))
                      qctsrc=max(qctsrc, tmp)
                      hlsrc =sd%hl (k)
                      exit
                   end if
                end do
                sd%tke = max(sd%tke, tke0)
                tkeo(i,j)=sd%tke
             end if
          else if (cush_choice.eq.2) then
             lofactor = 1. - sd%land * (1. - lofactor0)
             rkm_sh1=rkm_sh1*lofactor
          else if (cush_choice.eq.6) then
             lofactor = 1. - sd%land * (1. - lofactor0)
             rkm_sh1=rkm_sh1*lofactor
          end if

          call adi_cloud_k(zsrc, psrc, hlsrc, thcsrc, qctsrc, sd, Uw_p, do_fast, do_ice, ac)
          ac % usrc = sd%u(sd%ktoppbl)
          ac % vsrc = sd%v(sd%ktoppbl)
          if (ac%plfc.eq.0) ac%plfc=psrc
          if (ac%plnb.eq.0) ac%plnb=psrc
          plcl (i,j) = ac%plcl
          plfc (i,j) = ac%plfc
          plnb (i,j) = ac%plnb
          cino (i,j) = ac%cin
          capeo(i,j) = ac%cape
          xhlsrc(i,j)= ac%hlsrc; 
          xqtsrc(i,j)= ac%qctsrc; 
          rhavo(i,j) = sd%rhav;
          do k = 1,kmax
             nk = kmax+1-k
             hmo  (i,j,nk) = sd%hm(k);
             hms  (i,j,nk) = sd%hms(k);
             abu  (i,j,nk) = ac%buo(k);
          end do

          if (do_fast) then
!             if (ac%klcl.eq.0 .or. ac%plcl.gt.sd%ps(1) .or. ac%plcl.lt.20000.) then
             if (ac%klcl.eq.0 .or. ac%plcl.eq.sd%ps(1) .or. ac%plcl.lt.20000.) then
                ocode(i,j)=1; goto 100 !cycle;
             end if
             if (ac%plfc.lt.500.) then
                ocode(i,j)=2; goto 100 !cycle;
             end if
          end if

!========Cumulus closure to determine cloud base mass flux===================

          cbmf_old=cbmfo(i,j); cc%cbmf=cbmf_old;

          if (iclosure.eq.0) then
             call cclosure_bretherton(sd%tke, cpn, sd, Uw_p, ac, cc)
          else if (iclosure.eq.1) then
             call cclosure_implicit(sd%tke, cpn, sd, Uw_p, ac, cc, delt, rkm_sh1, &
                  do_coldT, sd1, ac1, cc1, cp, ct, ier, ermesg) 
             if (ier /= 0) then
               call error_mesg ('subroutine uw_conv iclosure=1 ', ermesg, FATAL)
             endif
          else if (iclosure.eq.2) then
             call cclosure_relaxwfn(sd%tke, cpn, sd, Uw_p, ac, cc, cp, ct, delt,  &
                  rkm_sh1, do_coldT, sd1, ac1, cc1, cp1, ct1, ier, ermesg)
             if (ier /= 0) then
               call error_mesg ('subroutine uw_conv iclosure=2 ', ermesg, FATAL)
             endif
          end if

          cbmfo(i,j) = cc%cbmf
          wrelo(i,j) = cc%wrel
          ufrco(i,j) = cc%ufrc


          if (.not.do_fast) then
             if (ac%klcl.eq.0 .or. ac%plcl.eq.sd%ps(1) .or. ac%plcl.lt.20000.) then
!             if (ac%klcl.eq.0 .or. ac%plcl.lt.20000.) then
                ocode(i,j)=1; goto 100 !cycle;
             end if
             if (ac%plfc.lt.500.) then
                ocode(i,j)=2; goto 100 !cycle;
             end if
          end if

          if(cc%cbmf.lt.1.e-6 .or. cc%wrel.eq.0.) then
             ocode(i,j)=3; goto 100 !cycle;
          end if

!========Do shallow cumulus plume calculation================================

          cpn%isdeep=.false.

          cbmf_deep    = min(cbmf_dp_frac * cc%cbmf * cc%cbmf / cc%wrel, cc%cbmf*0.9)
          cbmf_shallow = cc%cbmf - cbmf_deep

          cpn%do_ppen=do_ppen
          cpn%rpen   =rpen
          call cumulus_plume_k(cpn, sd, ac, cp, rkm_sh1, cbmf_shallow, cc%wrel, cc%scaleh, Uw_p, ier, ermesg)
          if (ier /= 0) then
            call error_mesg ('subroutine uw_conv', ermesg, FATAL)
          endif
          if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
             ocode(i,j)=4; goto 100 !cycle;
          end if
          if(cp%cldhgt.ge.cldhgt_max) then
             ocode(i,j)=5; goto 100 !cycle;
          end if

          if (cush_choice.eq.6) then
             do k=1,sd % kmax
                tmp=cp%cush+sd%zs(0)
                if ((tmp+1.-sd%zs(k))*(tmp+1.-sd%zs(k+1)).lt.0.) then 
                   tmp = sd%p(k+1); exit
                end if
             end do
             if (ac%plfc.gt.0.and.ac%plnb.gt.0.and.(ac%plfc-ac%plnb).gt.0.and.ac%plnb.lt.sd%ps(0)*0.5 &
                 .and.tmp.lt.ac%plfc.and.tmp.gt.ac%plnb.and.tmp.lt.sd%ps(0)) then
                cpn%isdeep=.true.
                cpn%do_ppen=do_ppen_d
                cpn%rpen   =rpen_d
                rkm_sh1=max(rkm_dp(1)*(1.-(ac%plfc-tmp)/(ac%plfc-ac%plnb)),0.001)

                lofactor = 1. - sd%land * (1. - lofactor0)
                rkm_sh1=rkm_sh1*lofactor
                call cumulus_plume_k(cpn, sd, ac, cp, rkm_sh1, cbmf_shallow, cc%wrel, cc%scaleh, Uw_p, ier, ermesg)
                if (ier /= 0) then
                  call error_mesg ('subroutine uw_conv cush_choice=6', ermesg, FATAL)
                endif

                if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
                   ocode(i,j)=4; goto 100 !cycle;
                end if
                if(cp%cldhgt.ge.cldhgt_max) then
                   ocode(i,j)=5; goto 100 !cycle;
                end if
             end if
          elseif (cush_choice.eq.2) then
             if ((ac%plfc-ac%plnb).gt.sd%ps(0) .and. (sd%rhav.gt.rh0)) then
                cpn%isdeep=.true.
                cpn%do_ppen=do_ppen_d
                cpn%rpen   =rpen_d
                rkm_sh1    =rkm_dp(1)
                lofactor = 1. - sd%land * (1. - lofactor0)
                rkm_sh1=rkm_sh1*lofactor
                call cumulus_plume_k(cpn, sd, ac, cp, rkm_sh1, cbmf_shallow, cc%wrel, cc%scaleh, Uw_p, ier, ermesg)
                if (ier /= 0) then
                  call error_mesg ('subroutine uw_conv cush_choice=2', ermesg, FATAL)
                endif

                if(cp%ltop.lt.cp%krel+2 .or. cp%let.le.cp%krel+1) then
                   ocode(i,j)=4; goto 100 !cycle;
                end if
                if(cp%cldhgt.ge.cldhgt_max) then
                   ocode(i,j)=5; goto 100 !cycle;
                end if
             end if
          end if

          if (cpn%isdeep .EQV. .true.) then 
             fdp(i,j) = 1
          else
             fdp(i,j) = 0
          end if

          cush(i,j)=cp%cush


!========Calculate cumulus produced tendencies===============================

          call cumulus_tend_k(cpn, sd, Uw_p, cp, ct, do_coldT)

!test
!          cpn%rpen = 0;
!          cpn%do_ppen=do_ppen
!          call cumulus_plume_k(cpn, sd, ac, cp1, rkm_sh1, cbmf_shallow, cc%wrel, cc%scaleh, Uw_p)
!          call cumulus_tend_k(cpn, sd, Uw_p, cp1, ct1, do_coldT)
!test


!========Unpack convective tendencies========================================
          do k = 1,cp%ltop
             nk = kmax+1-k
             uten  (i,j,nk) = ct%uten (k)
             vten  (i,j,nk) = ct%vten (k)
             qlten (i,j,nk) = ct%qlten(k)
             qiten (i,j,nk) = ct%qiten(k)
             qaten (i,j,nk) = ct%qaten(k)
             qnten (i,j,nk) = ct%qnten(k)
             qldet (i,j,nk) = ct%qldet(k)
             qidet (i,j,nk) = ct%qidet(k)
             qadet (i,j,nk) = ct%qadet(k)
             qvten (i,j,nk) = ct%qvten(k)
             pflx  (i,j,nk) = ct%pflx (k)
             ice_pflx(i,j,nk) = cp%ppti(k)
             liq_pflx(i,j,nk) = cp%pptr(k)
             tten  (i,j,nk) = ct%tten (k)
             rhos0j = sd%ps(k)/(rdgas*0.5*(cp%thvbot(k+1)+cp%thvtop(k))*sd%exners(k))
             hlflx(i,j,nk) = ct%hlflx(k)
             qtflx (i,j,nk) = rhos0j*HLv*ct%qctflx(k)
             tten_pevap (i,j,nk) = ct%tevap (k)
             qvten_pevap(i,j,nk) = ct%qevap (k)
             
             cldqa (i,j,nk) = cp%ufrc(k)
             cldql (i,j,nk) = cp%qlu(k)
             cldqi (i,j,nk) = cp%qiu(k)
             cldqn (i,j,nk) = cp%qnu(k)
             cmf   (i,j,nk) = cp%umf(k)
             wuo   (i,j,nk) = cp%wu (k)
             peo   (i,j,nk) = cp%peff(k)
             fero  (i,j,nk) = cp%fer(k)
             fdro  (i,j,nk) = cp%fdr(k)
             fdrso (i,j,nk) = cp%fdrsat(k)*cp%umf(k)
          enddo

! make sure the predicted tracer tendencies do not produce negative
! tracers due to convective tendencies. if necessary, adjust the 
! tendencies.
          call check_tracer_realizability (kmax, size(trtend,4), delt, &
                                           cp%tr, ct%trten, ct%trwet) 
          do k = 1,cp%ltop
             nk = kmax+1-k
             do n = 1, size(trtend,4)
               trtend(i,j,nk,n) = ct%trten(k,n) + ct%trwet(k,n)
               trwet(i,j,nk,n)  = ct%trwet(k,n)
             enddo
          enddo
          snow  (i,j)  = ct%snow
          rain  (i,j)  = ct%rain
          denth (i,j)  = ct%denth
          dqtmp (i,j)  = ct%dqtmp
          dting (i,j)  = ct%dting

!========Option for deep convection=======================================
100       if (do_deep) then
             if (idpchoice.eq.0) then
                omeg_avg=0.; dpsum=0.
                do k = 1,sd%kmax
                   if (sd%p(k) .gt. 50000.) then
                      omeg_avg  = omeg_avg + omega(i,j,k)*sd%dp(k)
                      dpsum = dpsum + sd%dp(k)
                   end if
                end do
                omeg_avg = omeg_avg/dpsum * 864.
                call  dpconv0(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, &
                     do_ice, omeg_avg, rkm_sh1, cp1, ct1, cbmf_deep, ocode(i,j), ier, ermesg)
             else if (idpchoice.eq.1) then
                call  dpconv1(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, &
                     do_ice, sd1, ac1, cc1, cp1, ct1, ocode(i,j), ier, ermesg)
             else if (idpchoice.eq.2) then
                call  dpconv2(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, &
                     do_ice, sd1, ac1, cc1, cp1, ct1, cbmf_deep, ocode(i,j), ier, ermesg)
             else if (idpchoice.eq.3) then
                call  dpconv3(dpc, cpn, Uw_p, sd, ac, cc, cp, ct, do_coldT, &
                     do_ice, omeg_avg, rkm_sh1, sd1, ac1, cp1, ct1, cbmf_deep, ocode(i,j), ier, ermesg)
             end if
             if (ier /= 0) then
               call error_mesg ('uw_conv calling dpconv', ermesg, FATAL)
             endif
             if(ocode(i,j).eq.6) cycle;
             do k = 1,kmax !cp1%ltop
                nk = kmax+1-k
                uten_d  (i,j,nk) = ct1%uten (k)
                vten_d  (i,j,nk) = ct1%vten (k)
                qlten_d (i,j,nk) = ct1%qlten(k)
                qiten_d (i,j,nk) = ct1%qiten(k)
                qaten_d (i,j,nk) = ct1%qaten(k) 
                qnten_d (i,j,nk) = ct1%qnten(k) 
                qvten_d (i,j,nk) = ct1%qvten(k)
                qtten_d (i,j,nk) = ct1%qctten(k)
                pflx_d  (i,j,nk) = ct1%pflx (k)
                tten_d  (i,j,nk) = ct1%tten (k)
                hlflx_d (i,j,nk) = ct1%hlflx(k) 
                qtflx_d (i,j,nk) = ct1%qctflx(k)
                cldqa_d (i,j,nk) = cp1%ufrc(k)
                cldql_d (i,j,nk) = cp1%qlu(k)
                cldqi_d (i,j,nk) = cp1%qiu(k)
                cldqn_d (i,j,nk) = cp1%qnu(k)
                cmf_d   (i,j,nk) = cp1%umf(k)
                tten_pevap_d (i,j,nk) = ct1%tevap (k)
                qvten_pevap_d(i,j,nk) = ct1%qevap (k)
                wuo_d   (i,j,nk) = cp1%wu (k)
                fero_d  (i,j,nk) = cp1%fer(k)
                fdro_d  (i,j,nk) = cp1%fdr(k) 
                fdrso_d (i,j,nk) = cp1%fdrsat(k)*cp1%fdr(k)*cp1%umf(k)
             enddo
             snow_d  (i,j)  = ct1%snow
             rain_d  (i,j)  = ct1%rain
             cbmf_d  (i,j)  = cbmf_deep
             !denth_d (i,j)  = ct1%denth
             !dcape_d (i,j)  = cc%dcape
             !dwfn_d  (i,j)  = cc%dwfn

!========Option for deep convection=======================================
            
             uten  (i,j,:) = uten  (i,j,:) + uten_d  (i,j,:)
             vten  (i,j,:) = vten  (i,j,:) + vten_d  (i,j,:)
             qlten (i,j,:) = qlten (i,j,:) + qlten_d (i,j,:)
             qiten (i,j,:) = qiten (i,j,:) + qiten_d (i,j,:)
             qaten (i,j,:) = qaten (i,j,:) + qaten_d (i,j,:) 
             qnten (i,j,:) = qnten (i,j,:) + qnten_d (i,j,:) 
             qvten (i,j,:) = qvten (i,j,:) + qvten_d (i,j,:)
             pflx  (i,j,:) = pflx  (i,j,:) + pflx_d  (i,j,:)
             tten  (i,j,:) = tten  (i,j,:) + tten_d  (i,j,:)
             hlflx (i,j,:) = hlflx (i,j,:) + hlflx_d (i,j,:) 
             qtflx (i,j,:) = qtflx (i,j,:) + qtflx_d (i,j,:)
             cmf   (i,j,:) = cmf   (i,j,:) + cmf_d   (i,j,:)
             !wuo   (i,j,:) = wuo   (i,j,:) 
             !fero  (i,j,:) = fero  (i,j,:) 
             !fdro  (i,j,:) = fdro  (i,j,:)  
             !fdrso (i,j,:) = fdrso (i,j,:) 
             !do n = 1, size(trtend,4)
             !   trtend(i,j,:,n) = trtend(i,j,:,n) 
             !enddo
             snow  (i,j)  = snow  (i,j) + snow_d  (i,j)
             rain  (i,j)  = rain  (i,j) + rain_d  (i,j)
             !denth (i,j)  = denth (i,j) 
             !cbmfo (i,j)  = cc%cbmf
             !dcapeo(i,j)  = cc%dcape
             !dwfno (i,j)  = cc%dwfn
          end if
!========Option for deep convection=======================================

       enddo
    enddo

    call sd_end_k(sd)
    call sd_end_k(sd1)
    call ac_end_k(ac)
    call ac_end_k(ac1)
    call cp_end_k(cp)
    call cp_end_k(cp1)
    call ct_end_k(ct)
    call ct_end_k(ct1)
    if (_ALLOCATED ( cpn%tracername    ))  deallocate ( cpn%tracername    )
    if (_ALLOCATED ( cpn%tracer_units  ))  deallocate ( cpn%tracer_units  )
    if (_ALLOCATED ( cpn%wetdep        ))  deallocate ( cpn%wetdep        )
    if (.not.do_uwcmt) then
       uten=0.;
       vten=0.;
    end if

    if ( prevent_unreasonable ) then
      scale_uw=HUGE(1.0)
      do k=1,kmax
        do j=1,jmax
          do i=1,imax
            if ((q(i,j,k,nqa) + qaten(i,j,k)*delt) .lt. 0. .and. (qaten(i,j,k).ne.0.)) then
              qaten(i,j,k) = -1.*q(i,j,k,nqa)/delt
            end if
            if ((q(i,j,k,nqa) + qaten(i,j,k)*delt) .gt. 1. .and. (qaten(i,j,k).ne.0.)) then
              qaten(i,j,k)= (1. - q(i,j,k,nqa))/delt
            end if
 
            if ((q(i,j,k,nql) + qlten(i,j,k)*delt) .lt. 0. .and. (qlten(i,j,k).ne.0.)) then
              tten (i,j,k) = tten(i,j,k) -(q(i,j,k,nql)/delt+qlten(i,j,k))*HLv/Cp_Air
              qvten(i,j,k) = qvten(i,j,k)+(q(i,j,k,nql)/delt+qlten(i,j,k))
              qlten(i,j,k) = qlten(i,j,k)-(q(i,j,k,nql)/delt+qlten(i,j,k))
            end if
 
            if ((q(i,j,k,nqi) + qiten(i,j,k)*delt) .lt. 0. .and. (qiten(i,j,k).ne.0.)) then
              tten (i,j,k) = tten(i,j,k) -(q(i,j,k,nqi)/delt+qiten(i,j,k))*HLs/Cp_Air
              qvten(i,j,k) = qvten(i,j,k)+(q(i,j,k,nqi)/delt+qiten(i,j,k))
    
              qiten(i,j,k) = qiten(i,j,k)-(q(i,j,k,nqi)/delt+qiten(i,j,k))
            end if

            if (do_qn) then
              if ((q(i,j,k,nqn) + qnten(i,j,k)*delt) .lt. 0. .and. (qnten(i,j,k).ne.0.)) then
                qnten(i,j,k) = qnten(i,j,k)-(q(i,j,k,nqn)/delt+qnten(i,j,k))
              end if
            endif
    !rescaling to prevent negative specific humidity for each grid point
            if (do_rescale) then
              qtin =  q(i,j,k,nqv)
              dqt  =  qvten(i,j,k) * delt
              if ( dqt.lt.0 .and. qtin+dqt.lt.1.e-10 ) then
                temp_1 = max( 0.0, -(qtin-1.e-10)/dqt )
              else
                temp_1 = 1.0
              endif
    !scaling factor for each column is the minimum value within that column
              scale_uw(i,j) = min( temp_1, scale_uw(i,j))
            endif
          enddo
        enddo
      enddo

!     where ((tracers(:,:,:,:) + trtend(:,:,:,:)*delt) .lt. 0.)
!        trtend(:,:,:,:) = -tracers(:,:,:,:)/delt
!     end where

      if (do_rescale) then
      !scale tendencies
        do k=1,kmax
          do j=1,jmax
            do i=1,imax
              uten (i,j,k)  = scale_uw(i,j) * uten (i,j,k)
              vten (i,j,k)  = scale_uw(i,j) * vten (i,j,k)
              tten (i,j,k)  = scale_uw(i,j) * tten (i,j,k)
              qvten(i,j,k)  = scale_uw(i,j) * qvten(i,j,k)
              qlten(i,j,k)  = scale_uw(i,j) * qlten(i,j,k)
              qiten(i,j,k)  = scale_uw(i,j) * qiten(i,j,k)
              qaten(i,j,k)  = scale_uw(i,j) * qaten(i,j,k)
              if (do_qn) qnten(i,j,k) = scale_uw(i,j) * qnten(i,j,k)
              if (k.eq.kmax) then
                rain(i,j) = scale_uw(i,j) * rain(i,j)
                snow(i,j) = scale_uw(i,j) * snow(i,j)
              endif
            end do
          end do
        end do
      end if
    endif


    do k=1,kmax
      do j=1,jmax
        do i=1,imax
          cfq(i,j,k) = 0
          if (wuo(i,j,k) .gt. 0.) then
            cfq(i,j,k) = 1
          endif
        enddo
      enddo
    enddo

    !diagnostic output
    used = send_data( id_xhlsrc_uwc,       xhlsrc,             Time, is, js)
    used = send_data( id_xqtsrc_uwc,       xqtsrc,             Time, is, js)
    used = send_data( id_tdt_pevap_uwc,    tten_pevap*aday , Time, is, js, 1)
    used = send_data( id_qdt_pevap_uwc,    qvten_pevap*aday, Time, is, js, 1)

    used = send_data( id_tdt_uwc,    tten*aday , Time, is, js, 1)
    used = send_data( id_qdt_uwc,    qvten*aday, Time, is, js, 1)
    used = send_data( id_cmf_uwc,    cmf,          Time, is, js, 1)
    used = send_data( id_cfq_uwc,    cfq,          Time, is, js, 1)
    used = send_data( id_wu_uwc,     wuo,          Time, is, js, 1)
    used = send_data( id_peo_uwc,    peo,          Time, is, js, 1)
    used = send_data( id_fer_uwc,    fero,         Time, is, js, 1)
    used = send_data( id_fdr_uwc,    fdro,         Time, is, js, 1)
    used = send_data( id_fdrs_uwc,   fdrso,        Time, is, js, 1)
    used = send_data( id_cqa_uwc,    cldqa,        Time, is, js, 1)
    used = send_data( id_cql_uwc,    cldql,        Time, is, js, 1)
    used = send_data( id_cqi_uwc,    cldqi,        Time, is, js, 1)
    used = send_data( id_cqn_uwc,    cldqn,        Time, is, js, 1)
    used = send_data( id_hlflx_uwc, hlflx,       Time, is, js, 1)
    used = send_data( id_qtflx_uwc,  qtflx,        Time, is, js, 1)
    used = send_data( id_hmo_uwc,    hmo,          Time, is, js, 1)
    used = send_data( id_hms_uwc,    hms,          Time, is, js, 1)
    used = send_data( id_abu_uwc,    abu,          Time, is, js, 1)
   
    used = send_data( id_prec_uwc, (rain+snow)*aday, Time, is, js )
    used = send_data( id_snow_uwc, (snow)*aday,      Time, is, js )
    used = send_data( id_cin_uwc,  (cino),             Time, is, js )
    used = send_data( id_cape_uwc, (capeo),            Time, is, js )
    used = send_data( id_rhav_uwc, (rhavo),            Time, is, js )
    used = send_data( id_tke_uwc,  (tkeo),             Time, is, js )
    used = send_data( id_cbmf_uwc, (cbmfo),            Time, is, js )
    used = send_data( id_wrel_uwc, (wrelo),            Time, is, js )
    used = send_data( id_ufrc_uwc, (ufrco),            Time, is, js )
    used = send_data( id_plcl_uwc, (plcl*0.01),        Time, is, js )
    used = send_data( id_plfc_uwc, (plfc*0.01),        Time, is, js )
    used = send_data( id_plnb_uwc, (plnb*0.01),        Time, is, js )
    used = send_data( id_zinv_uwc, (zinvo),            Time, is, js )
    used = send_data( id_cush_uwc, (cush),             Time, is, js )
    used = send_data( id_dcin_uwc, (dcino),            Time, is, js )
    used = send_data( id_dcape_uwc,(dcapeo),           Time, is, js )
    used = send_data( id_dwfn_uwc, (dwfno),            Time, is, js )
    used = send_data( id_enth_uwc, (denth),            Time, is, js )
    used = send_data( id_qtmp_uwc, (dqtmp),            Time, is, js )
    used = send_data( id_dting_uwc,(dting),            Time, is, js )
    used = send_data( id_ocode_uwc,(ocode),            Time, is, js )
    used = send_data( id_fdp_uwc,  (fdp),              Time, is, js )
   
    if ( do_strat ) then
       used = send_data( id_qldt_uwc, qlten*aday,    Time, is, js, 1)
       used = send_data( id_qidt_uwc, qiten*aday,    Time, is, js, 1)
       used = send_data( id_qadt_uwc, qaten*aday,    Time, is, js, 1)
       used = send_data( id_qndt_uwc, qnten*aday,    Time, is, js, 1)
       used = send_data( id_qldet_uwc,  qldet*aday,  Time, is, js, 1)
       used = send_data( id_qidet_uwc,  qidet*aday,  Time, is, js, 1)
       used = send_data( id_qadet_uwc,  qadet*aday,  Time, is, js, 1)
       used = send_data( id_qtdt_uwc,(qvten+qlten+qiten)*aday,Time, is, js, 1)
    end if

    if ( allocated(id_tracerdt_uwc) ) then
       do n = 1,size(id_tracerdt_uwc)
          used = send_data( id_tracerdt_uwc(n), trtend(:,:,:,n), Time, is, js, 1)
       end do
    end if
    if ( allocated(id_tracerdt_uwc_col) ) then
       do n = 1,size(id_tracerdt_uwc_col)
          if ( id_tracerdt_uwc_col(n) > 0 ) then
            tempdiag = 0.
            do k = 1,kmax
               tempdiag(:,:) = tempdiag(:,:) + trtend(:,:,k,n) * pmass(:,:,k)
            end do
            used = send_data( id_tracerdt_uwc_col(n), tempdiag(:,:), Time, is, js)
          end if
       end do
    end if
    if ( allocated(id_tracerdtwet_uwc) ) then
       do n = 1,size(id_tracerdtwet_uwc)
          used = send_data( id_tracerdtwet_uwc(n), trwet(:,:,:,n), Time, is, js, 1)
       end do
    end if
    if ( allocated(id_tracerdtwet_uwc_col) ) then
       uw_wetdep = 0.
       do n = 1,size(id_tracerdtwet_uwc_col)
          if ( id_tracerdtwet_uwc_col(n) > 0 ) then
             tempdiag = 0.
             do k = 1,kmax
               tempdiag(:,:) = tempdiag(:,:) + trwet(:,:,k,n) * pmass(:,:,k)
            end do
            used = send_data( id_tracerdtwet_uwc_col(n), tempdiag(:,:), Time, is, js)
            uw_wetdep(:,:,n) = tempdiag(:,:)
          end if
       end do
    end if

!========Option for deep convection=======================================
    if (do_deep) then
       used=send_data( id_tdt_pevap_uwd,    tten_pevap_d*aday , Time, is, js, 1)
       used=send_data( id_qdt_pevap_uwd,    qvten_pevap_d*aday, Time, is, js, 1)
       used=send_data( id_tdt_uwd,   tten_d*aday , Time, is, js, 1)
       used=send_data( id_qdt_uwd,   qvten_d*aday, Time, is, js, 1)
       used=send_data( id_qtdt_uwd,  qtten_d*aday, Time, is, js, 1)
       used=send_data( id_cmf_uwd,   cmf_d,          Time, is, js, 1)
       used=send_data( id_wu_uwd,    wuo_d,          Time, is, js, 1)
       used=send_data( id_fer_uwd,   fero_d,         Time, is, js, 1)
       used=send_data( id_fdr_uwd,   fdro_d,         Time, is, js, 1)
       used=send_data( id_fdrs_uwd,  fdrso_d,        Time, is, js, 1)
       used=send_data( id_cqa_uwd,   cldqa_d,        Time, is, js, 1)
       used=send_data( id_cql_uwd,   cldql_d,        Time, is, js, 1)
       used=send_data( id_cqi_uwd,   cldqi_d,        Time, is, js, 1)
       used=send_data( id_cqn_uwd,   cldqn_d,        Time, is, js, 1)
       used=send_data( id_hlflx_uwd, hlflx_d,        Time, is, js, 1)
       used=send_data( id_qtflx_uwd, qtflx_d,        Time, is, js, 1)
      
       used=send_data( id_prec_uwd, (rain_d+snow_d)*aday,Time, is, js )
       used=send_data( id_snow_uwd, (snow_d)*aday,       Time, is, js )
       used=send_data( id_cbmf_uwd, (cbmf_d),              Time, is, js )
       used=send_data( id_dcape_uwd,(dcape_d),             Time, is, js )
       used=send_data( id_dwfn_uwd, (dwfn_d),              Time, is, js )
       used=send_data( id_enth_uwd, (denth_d),             Time, is, js )
             
       if ( do_strat ) then
          used=send_data( id_qldt_uwd, qlten_d*aday,     Time, is, js, 1)
          used=send_data( id_qidt_uwd, qiten_d*aday,     Time, is, js, 1)
          used=send_data( id_qadt_uwd, qaten_d*aday,     Time, is, js, 1)
       end if
    end if
!========Option for deep convection=======================================


    if (.not.apply_tendency) then
       uten=0.; vten=0.; tten=0.; qvten=0.; cmf=0.; rain=0.; snow=0.;
       qlten=0.; qiten=0.; qaten=0.; qnten=0.;
    end if

  END SUBROUTINE UW_CONV

!#####################################################################
!#####################################################################

  subroutine clearit(ac, cc, cp, ct, cp1, ct1)

    type(adicloud), intent(inout) :: ac
    type(cclosure), intent(inout) :: cc
    type(cplume),   intent(inout) :: cp,cp1
    type(ctend),    intent(inout) :: ct,ct1

    call ac_clear_k(ac); 
    ac%klcl =0;  ac%klfc =0;  ac%klnb =0; 

    cc%wrel=0.; cc%ufrc=0.; cc%scaleh=0.;

    call cp_clear_k(cp)
    call ct_clear_k(ct);
    call cp_clear_k(cp1);
    call ct_clear_k(ct1);

  end subroutine clearit


!#####################################################################

end MODULE UW_CONV_MOD


module shallow_physics_mod
use mpp_mod, only: input_nml_file

use  fms_mod, only: open_namelist_file, file_exist,   &
                    close_file, check_nml_error,      &
                    error_mesg, FATAL, WARNING,       &
                    write_version_number, stdlog,     &
                    mpp_pe, mpp_root_pe

use time_manager_mod, only: time_type

implicit none
private

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

public :: shallow_physics_init,    &
          shallow_physics,         &
          shallow_physics_end

interface shallow_physics_init
   module procedure shallow_physics_init_1d, shallow_physics_init_2d
end interface
!========================================================================
! version information 
character(len=128) :: version = '$Id: shallow_physics.F90,v 17.0.4.1 2010/08/30 20:33:35 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!========================================================================

real, allocatable, dimension(:,:) :: h_eq

real    :: kappa_m, kappa_t

logical :: module_is_initialized = .false.

!========================================================================
! namelist 

real    :: fric_damp_time  = -20.0
real    :: therm_damp_time = -10.0
real    :: h_0             = 3.e04
real    :: h_monsoon       = 2.e04
real    :: lon_monsoon     =  90.0
real    :: lat_monsoon     =  25.0
real    :: width_monsoon   =  15.0
real    :: h_itcz          = 1.e05
real    :: width_itcz      =  4.0
logical :: no_forcing      = .false.

namelist /shallow_physics_nml/ fric_damp_time, therm_damp_time, &
                               h_0, h_monsoon, width_monsoon,   &
                               lon_monsoon, lat_monsoon,        &
                               width_itcz, h_itcz, no_forcing

contains

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

subroutine shallow_physics_init_2d (axes, Time, lon, lat) 
integer, intent(in) :: axes(4)
type(time_type), intent(in) :: Time
real, intent(in) :: lon(:,:), lat(:,:)  ! longitude and latitude in radians

integer :: i, j, unit, ierr, io, logunit
real    :: xm, ym, dm, di
real    :: lon_m, lat_m, width_m, width_i, deg2rad

! cannot initialize the module more than once
  if (module_is_initialized) then
    call error_mesg ('shallow_physics_init', &
                     'module has already been initialized ', FATAL)
  endif

! read the namelist
#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=shallow_physics_nml, iostat=io)
   ierr = check_nml_error(io,"shallow_physics_nml")
#else
  if (file_exist('input.nml')) then
    unit = open_namelist_file ()
    ierr=1
    do while (ierr /= 0)
      read  (unit, nml=shallow_physics_nml, iostat=io, end=10)
      ierr = check_nml_error (io, 'shallow_physics_nml')
    enddo
    10 call close_file (unit)
  endif
#endif

! write version info and namelist to logfile

  call write_version_number (version, tagname)
  logunit = stdlog()
  write(logunit,nml=shallow_physics_nml)

! damping times < 0 are in days (convert to seconds)

  if (fric_damp_time  < 0.0)  fric_damp_time = -  fric_damp_time*86400
  if (therm_damp_time < 0.0) therm_damp_time = - therm_damp_time*86400

! compute damping coefficients

  kappa_m = 0.0
  kappa_t = 0.0
  if ( fric_damp_time .ne. 0.0) kappa_m = 1./fric_damp_time
  if (therm_damp_time .ne. 0.0) kappa_t = 1./therm_damp_time

! global storage

  allocate ( h_eq(size(lon,1),size(lon,2)) )

! convert namelist variables in degrees to radians

  deg2rad = acos(0.0)/90.
  lon_m = lon_monsoon * deg2rad
  lat_m = lat_monsoon * deg2rad
  width_m = width_monsoon * deg2rad
  width_i = width_itcz    * deg2rad

! compute constants

  do j = 1, size(lon,2)
  do i = 1, size(lon,1)
     xm = (lon(i,j) - lon_m)/(width_m*2.)
     ym = (lat(i,j) - lat_m)/width_m
     dm =  xm*xm + ym*ym
     di = (lat(i,j)/width_i)**2
     h_eq(i,j) = h_0 + h_monsoon*max(1.e-10, exp(-dm)) + h_itcz*exp(-di)
  enddo
  enddo

  module_is_initialized = .true.

end subroutine shallow_physics_init_2d

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

subroutine shallow_physics_init_1d (axes, Time, lon, lat) 
integer, intent(in) :: axes(4)
type(time_type), intent(in) :: Time
real, intent(in) :: lon(:), lat(:)  ! longitude and latitude in radians

real, dimension(size(lon),size(lat)) :: lon2, lat2

   lon2 = spread(lon,2,size(lat))
   lat2 = spread(lat,1,size(lon))
   call shallow_physics_init_2d (axes, Time, lon2, lat2)

end subroutine shallow_physics_init_1d

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

subroutine shallow_physics ( is, ie, js, je, timelev, dt, Time,    &
                             um, vm, hm, u, v, h, u_dt, v_dt, h_dt )

integer,         intent(in) :: is, ie, js, je, timelev
real,            intent(in) :: dt
type(time_type), intent(in) :: Time
real, intent(in)   , dimension(is:ie,js:je) :: um, vm, hm, u, v, h
real, intent(inout), dimension(is:ie,js:je) :: u_dt, v_dt, h_dt

integer :: i, j

  if (.not.module_is_initialized) then
    call error_mesg ('shallow_physics', &
                     'module has not been initialized ', FATAL)
  endif

  if (no_forcing) return

! choose which time level is used to compute forcing

  select case (timelev)
     case(-1)
         ! previous time level (tau-1)
         do j = js, je
         do i = is, ie
            u_dt(i,j) = u_dt(i,j) - kappa_m *  um(i,j)
            v_dt(i,j) = v_dt(i,j) - kappa_m *  vm(i,j)
            h_dt(i,j) = h_dt(i,j) - kappa_t * (hm(i,j) - h_eq(i,j))
         enddo
         enddo
     case(0)
         ! current time level (tau)
         do j = js, je
         do i = is, ie
            u_dt(i,j) = u_dt(i,j) - kappa_m *  u(i,j)
            v_dt(i,j) = v_dt(i,j) - kappa_m *  v(i,j)
            h_dt(i,j) = h_dt(i,j) - kappa_t * (h(i,j) - h_eq(i,j))
         enddo
         enddo
     case(+1)
         ! next time level (tau+1)
         do j = js, je
         do i = is, ie
            u_dt(i,j) = u_dt(i,j)*(1.-kappa_m*dt) - kappa_m *  um(i,j)
            v_dt(i,j) = v_dt(i,j)*(1.-kappa_m*dt) - kappa_m *  vm(i,j)
            h_dt(i,j) = h_dt(i,j)*(1.-kappa_t*dt) - kappa_t * (hm(i,j)-h_eq(i,j))
         enddo
         enddo
     case default
         call error_mesg ('shallow_physics', &
                          'invalid value for timelev argument', FATAL)
  end select

end subroutine shallow_physics

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

subroutine shallow_physics_end

  if (.not.module_is_initialized) then
    call error_mesg ('shallow_physics_end', &
                     'module has not been initialized ', WARNING)
    return
  endif

! release global storage

  deallocate ( h_eq )

  module_is_initialized = .false.

end subroutine shallow_physics_end

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

end module shallow_physics_mod


!FDOC_TAG_GFDL
  MODULE STABLE_BL_TURB_MOD

!=======================================================================
 use           mpp_mod, only: input_nml_file
 use           fms_Mod, ONLY: FILE_EXIST, OPEN_NAMELIST_FILE,          &
                              ERROR_MESG, FATAL, mpp_pe, mpp_root_pe,  &
                              CLOSE_FILE,                              &
                              check_nml_error, write_version_number,   &
                              stdlog
 use  Diag_Manager_Mod, ONLY: register_diag_field, send_data
 use  Time_Manager_Mod, ONLY: time_type
 use     Constants_Mod, ONLY: cp_air, hlv, hls, grav, vonkarm, tfreeze,&
                              rdgas, rvgas, omega
 use Monin_Obukhov_Mod, ONLY: stable_mix

 implicit none
 private
 public :: STABLE_BL_TURB, STABLE_BL_TURB_INIT, STABLE_BL_TURB_END


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  character(len=128) :: version = '$Id: stable_bl_turb.F90,v 18.0.4.2 2010/09/07 16:17:19 wfc Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
  logical            :: module_is_initialized = .false.
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!---------------------------------------------------------------------
! --- CONSTANTS
!---------------------------------------------------------------------

  real :: oalsm, oalsh
  real, parameter :: d608 = (rvgas-rdgas)/rdgas
  
!---------------------------------------------------------------------
! --- NAMELIST
!---------------------------------------------------------------------

  real    :: akmax        = 1.e4 ! maximum diffusion coefficient value 
                                 !  (m2/s)
  real    :: alpha        = 0.5
  real    :: alsm         = 150.0
  real    :: alsh         = 150.0
  real    :: fmin         = 5.0e-5
  real    :: hpbl_cap     = 1000.
  real    :: ri_crit      = 0.2
  real    :: diff_min     = 0.001
  real    :: winddifmin   = 0.01
  real    :: small        = 1.e-5
  real    :: b_louis      = 9.4
  real    :: cmstar_louis = 7.4
  real    :: chstar_louis = 5.3
       
  NAMELIST / stable_bl_turb_nml / akmax, alpha, alsm, alsh, fmin, &
                                  hpbl_cap, diff_min, ri_crit

!---------------------------------------------------------------------
! DIAGNOSTICS FIELDS 
!---------------------------------------------------------------------

integer :: id_z_sbl, id_f_sbl

character(len=14) :: mod_name = 'stable_bl_turb'

real :: missing_value = -999.

!---------------------------------------------------------------------
 contains

!#######################################################################

! <SUBROUTINE NAME="STABLE_BL_TURB">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  STABLE_BL_TURB(is, js, Time, temp, qv,  ql,  qi,  um,  vm,
!                zhalf, zfull, u_star, b_star, lat, 
!                akm, akh, vspblcap, kbot )
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!       Starting integer for longitude window (used for diagnostics)
!  </IN>
!  <IN NAME="js" TYPE="integer">
!       Starting integer for latitude window (used for diagnostics)
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!       Time type variable (for diagnostics)
!  </IN>
!  <IN NAME="temp" TYPE="real">
!       Temperature (K)
!  </IN>
!  <IN NAME="qv" TYPE="real">
!       Water vapor specific humidity (kg/kg)
!  </IN>
!  <IN NAME="ql" TYPE="real">
!       Cloud liquid water specific humidity (kg/kg)
!  </IN>
!  <IN NAME="qi" TYPE="real">
!       Cloud ice water specific humidity (kg/kg)
!  </IN>
!  <IN NAME="um" TYPE="real">
!       Zonal wind velocity (m/s)
!  </IN>
!  <IN NAME="vm" TYPE="real">
!       Meridional wind velocity (m/s)
!  </IN>
!  <IN NAME="zhalf" TYPE="real">
!       Geopotential height of half levels (m)
!  </IN>
!  <IN NAME="zfull" TYPE="real">
!       Geopotential height of full levels (m)
!  </IN>
!  <IN NAME="u_star" TYPE="real">
!       Surface friction velocity (m/s)
!  </IN>
!  <IN NAME="b_star" TYPE="real">
!       Surface buoyancy scale (m/s2)
!  </IN>
!  <IN NAME="lat" TYPE="real">
!       Latitude (radians)
!  </IN>
!  <OUT NAME="akm" TYPE="real">
!       Momentum vertical diffusion coefficient (m2/s)
!  </OUT>
!  <OUT NAME="akh" TYPE="real">
!       Heat/Tracer vertical diffusion coefficient (m2/s)
!  </OUT>
!  <IN NAME="vspblcap" TYPE="real">
!       Cap to height of very stable enhanced PBL mixing, coming
!       from any other module (m)
!
!       In usual application this might be entrain_mod. This is also
!       an optional argument. 
!  </IN>
!  <IN NAME="kbot" TYPE="integer">
!       Integer indicating the lowest level above ground (integer)
!       
!       This optional argument is used only for eta coordinate model.
!  </IN>
! </SUBROUTINE>
!
 subroutine STABLE_BL_TURB( is, js, Time, temp, qv,  ql,  qi,  um,  vm,&
                            zhalf, zfull, u_star, b_star, lat,         &
                            akm, akh, vspblcap, kbot )

!=======================================================================
!---------------------------------------------------------------------
! Arguments (Intent in)
!
!       is, js   -  Starting indices for window
!       Time     -  Time used for diagnostics [time_type]
!       temp     -  temperature (K)
!       qv       -  specific humidity of water vapor (kg/kg)
!       ql       -  specific humidity of cloud liquid (kg/kg)
!       qi       -  specific humidity of cloud ice (kg/kg)
!       um, vm   -  Wind components (m/s)
!       u_star   -  surface friction velocity (m/s)
!       b_star   -  surface buoyancy (m/s2)
!       lat      -  latitude in radians
!       zhalf    -  Height at half levels (m)
!       zfull    -  Height at full levels (m)
!
!      --------------
!      optional input
!      --------------
!
!      vspblcap  cap to height of very stable PBL mixing, coming
!                from any other module (m) (in usual application
!                this might be entrain_mod or edt mod)
!
!      kbot      integer indicating the lowest true layer of atmosphere
!                this is used only for eta coordinate model
!
!---------------------------------------------------------------------
! Arguments (Intent out)
!       akm  -  mixing coefficient for momentum
!       akh  -  mixing coefficient for heat and moisture
!---------------------------------------------------------------------

  type(time_type), intent(in)                    :: Time
  integer,         intent(in)                    :: is, js
  real,            intent(in),  dimension(:,:)   :: u_star, b_star, lat
  real,            intent(in),  dimension(:,:,:) :: temp, qv, ql, qi
  real,            intent(in),  dimension(:,:,:) :: um, vm 
  real,            intent(in),  dimension(:,:,:) :: zhalf,  zfull
  real,            intent(out), dimension(:,:,:) :: akm,    akh

  real,     intent(in),   dimension(:,:), optional :: vspblcap
  integer,  intent(in),   dimension(:,:), optional :: kbot
  
!---------------------------------------------------------------------

  real, dimension(SIZE(um,1),SIZE(um,2),SIZE(um,3)-1) ::             &
        dsdzh, shear, buoync, Ri, Ritmp, fm, fh, lm, lh, xxm1, xxm2, &
        phi, zfunc, cmtmp, chtmp, fmtmp, fhtmp

  real, dimension(SIZE(um,1),SIZE(um,2),SIZE(um,3))  :: mask, hleff
  real, dimension(SIZE(um,1),SIZE(um,2),SIZE(um,3))  :: zfull_ag, slv
  real, dimension(SIZE(um,1),SIZE(um,2),SIZE(um,3)+1):: zhalf_ag

  real, dimension(SIZE(um,1),SIZE(um,2)) ::  zsurf,  &
        fcor, hpbl, z_sbl, f_sbl

  integer :: ix, jx, kx, i, j, k,  kxm
  integer :: shape1(1), shape3(3)
  logical :: used

!=======================================================================
! --- Initalize
!=======================================================================

! --- Check to see if STABLE_BL_TURB has been initialized
  if( .not. module_is_initialized ) CALL ERROR_MESG( ' STABLE_BL_TURB',                          &
       ' STABLE_BL_TURB_INIT has not been called', FATAL)

! --- Zero out output arrays
    akm(:,:,:) = 0.0
    akh(:,:,:) = 0.0
  z_sbl(:,:)   = 0.0
  f_sbl(:,:)   = 0.0
  
! --- Set dimensions etc
  ix  = SIZE( um, 1 )
  jx  = SIZE( um, 2 )
  kx  = SIZE( um, 3 )
  kxm = kx - 1

  shape1 =    ix * jx * kxm
  shape3 = (/ ix,  jx,  kxm /)

!====================================================================
! --- COMPUTE HEIGHT ABOVE SURFACE            
!====================================================================


       mask = 1.0
                   
       if (present(kbot)) then
            do j=1,jx
            do i=1,ix
                 zsurf(i,j) = zhalf(i,j,kbot(i,j)+1)
                 if (kbot(i,j).lt.kx) then
                    do k = kbot(i,j)+1,kx
                       mask(i,j,k) = 0.0
                    enddo
                 end if      
            enddo
            enddo
       else
            zsurf(:,:) = zhalf(:,:,kx+1)
       end if

       do k = 1, kx
            zfull_ag(:,:,k) = zfull(:,:,k) - zsurf(:,:)
            zhalf_ag(:,:,k) = zhalf(:,:,k) - zsurf(:,:)
       end do
       zhalf_ag(:,:,kx+1) = zhalf(:,:,kx+1) - zsurf(:,:)
       
!====================================================================
! --- DYNAMIC HEIGHT - also height relative to the surface     
!====================================================================

  fcor(:,:) = 2.0 * omega * SIN( lat(:,:) )
  fcor(:,:) = ABS( fcor(:,:) )
  fcor(:,:) = MAX( fcor(:,:), fmin )
  hpbl(:,:) = alpha * u_star(:,:) / fcor(:,:)

! --- bound
  hpbl(:,:) = MIN( hpbl(:,:), hpbl_cap )
  
! --- cap from entrainment turbulence
  if (present(vspblcap)) hpbl(:,:) = MIN( hpbl(:,:), vspblcap )
  
! --- height relative to the surface
! --- zfunc = zhalf_ag / hpbl, where stable conditions exist
! ---       = 1.0 for unstable conditions

  zfunc = 1.0
  do k = 1, kxm
      where( b_star(:,:) < 0.0) 
           zfunc(:,:,k) = min(1.,max(0.,zhalf_ag(:,:,k+1)/             &
                                     max(0.1,hpbl(:,:))))
      endwhere
  enddo
    
!====================================================================
! --- COMPUTE LIQUID WATER VIRTUAL STATIC ENERGY             
!====================================================================

   hleff   = (min(1.,max(0.,0.05*(temp   -tfreeze+20.)))*hlv + &
              min(1.,max(0.,0.05*(tfreeze -temp      )))*hls)
     
   slv     = cp_air*temp + grav*zfull_ag - hleff*(ql + qi)
   slv     = slv*(1+d608*(qv+ql+qi))
       
!====================================================================
! --- COMPUTE RICHARDSON NUMBER                 
!====================================================================

! --- D( )/DZ OPERATOR  
  
  dsdzh(:,:,1:kxm) = 1.0 / (zfull_ag(:,:,1:kxm) - zfull_ag(:,:,2:kx))

! --- WIND SHEAR SQUARED

  xxm1(:,:,1:kxm) = dsdzh(:,:,1:kxm)*( um(:,:,1:kxm) - um(:,:,2:kx) )
  xxm2(:,:,1:kxm) = dsdzh(:,:,1:kxm)*( vm(:,:,1:kxm) - vm(:,:,2:kx) )



  shear(:,:,:) = xxm1(:,:,:)*xxm1(:,:,:) + xxm2(:,:,:)*xxm2(:,:,:)

  where (shear .lt. (dsdzh*winddifmin*dsdzh*winddifmin)) 
         shear = dsdzh*winddifmin*dsdzh*winddifmin
  end where         

! --- BUOYANCY 
  xxm1(:,:,1:kxm) =       slv(:,:,1:kxm) - slv(:,:,2:kx) 
  xxm2(:,:,1:kxm) = 0.5*( slv(:,:,1:kxm) + slv(:,:,2:kx) )
 
 
  buoync(:,:,:) = grav * dsdzh(:,:,:) * xxm1(:,:,:) / xxm2(:,:,:)

! --- RICHARDSON NUMBER

  Ri(:,:,:) = buoync(:,:,:) / shear(:,:,:)   

!====================================================================
! --- MASK OUT UNDERGROUND VALUES FOR ETA COORDINATE
!====================================================================

  if( PRESENT( kbot ) ) then
     shear(:,:,1:kxm) =  shear(:,:,1:kxm) * mask(:,:,2:kx) 
    buoync(:,:,1:kxm) = buoync(:,:,1:kxm) * mask(:,:,2:kx) 
        Ri(:,:,1:kxm) =     Ri(:,:,1:kxm) * mask(:,:,2:kx) 
  endif

!====================================================================
! --- MIXING LENGTHS                 
!====================================================================

 do k = 1,kxm
   xxm1(:,:,k) = 1.0 / (vonkarm*zhalf_ag(:,:,k+1))
 end do 

  lm(:,:,:) = 1.0 / ( xxm1(:,:,1:kxm) + oalsm )
  lh(:,:,:) = 1.0 / ( xxm1(:,:,1:kxm) + oalsh )

!====================================================================
! --- STABILITY FUNCTIONS : STABLE SIDE       
!
! Note the very stable form of stability function acquired from 
! monin obukhov is weighted with the traditional stable form
! (phi = 1 + zeta/zeta_crit  or fm = (1 - Ri/Ricrit)**2)
! For Ricrit   = 0.2, phi retains the usual 1 + 5*zeta form.
!
! For heights greater than hpbl, the usual form is used.  For heights
! less than hpbl, the weight of the traditional form is given by
! zfunc which is linear in z/hpbl (see code above).
!====================================================================

  Ritmp = Ri
  where (Ritmp .lt. small) Ritmp = small

  CALL STABLE_MIX( Ritmp, phi)

  phi = (1-zfunc)*phi + zfunc* ((1-min(1.,(Ritmp/ri_crit)))**2.)
  
  fm(:,:,:) = phi(:,:,:)
  fh(:,:,:) =  fm(:,:,:) 
  
!====================================================================
! --- STABILITY FUNCTIONS : UNSTABLE SIDE (Louis 1979)
!
! f = 1.  - b * Ri / (1 + c*sqrt(-Ri))
!
! where b = 9.4 and
!
!              l * l * b * ( (  (1+(dz/z))**(1/3) - 1 )**(3/2))
! c = C_star * --------------------------------------------------
!              sqrt(z) * (dz**3/2)  
!
! where C_star(momentum) = 7.4, and C_star(heat) = 5.3
!     
!====================================================================
 
  Ritmp = Ri
  where (Ri .gt. 0.) Ritmp = 0.  
  
  zfunc(:,:,1:kxm) = 1.+(1./(dsdzh(:,:,1:kxm)*zhalf_ag(:,:,2:(kxm+1))))
  zfunc = zfunc **(1./3.) - 1.
  zfunc = zfunc **1.5
  zfunc = zfunc /  sqrt(zhalf_ag(:,:,2:(kxm+1))) 
  zfunc = zfunc * ( dsdzh(:,:,1:kxm) ** 1.5 )
  
  cmtmp =  cmstar_louis*lm(:,:,:)*lm(:,:,:)*b_louis*zfunc(:,:,:)
  chtmp =  chstar_louis*lh(:,:,:)*lh(:,:,:)*b_louis*zfunc(:,:,:)
  fmtmp(:,:,:) = 1. - (b_louis*Ritmp/(1.+cmtmp*sqrt(-1.*Ritmp)))
  fhtmp(:,:,:) = 1. - (b_louis*Ritmp/(1.+chtmp*sqrt(-1.*Ritmp)))
  
  where (Ri .lt. small)
      fm = fmtmp
      fh = fhtmp
  end where      
 
!====================================================================
! --- MIXING COEFFICENTS                 
!====================================================================

  shear(:,:,:) = SQRT( shear(:,:,:) )

! --- Momentum
  xxm1(:,:,:)    = lm(:,:,:) * lm(:,:,:) * fm(:,:,:)
   akm(:,:,2:kx) = xxm1(:,:,1:kxm) * shear(:,:,1:kxm) 
  where (akm .lt. diff_min) akm = 0.0
  where (akm .gt. akmax) akm = akmax
  
! --- Heat and Moisture
  xxm1(:,:,:)    = lh(:,:,:) * lh(:,:,:) * fh(:,:,:)
   akh(:,:,2:kx) = xxm1(:,:,1:kxm) * shear(:,:,1:kxm)
  where (akh .lt. diff_min) akh = 0.0
  where (akh .gt. akmax) akh = akmax

!====================================================================
! --- Extra diagnostics
!====================================================================

  where( b_star(:,:)  < 0.0 .and. hpbl (:,:) > 0.0 )
          z_sbl(:,:) = hpbl(:,:)
          f_sbl(:,:) = 1.0
  endwhere
  
  if ( id_z_sbl > 0 ) then
     used = send_data ( id_z_sbl, z_sbl, Time, is, js )
  endif
  if ( id_f_sbl > 0 ) then
     used = send_data ( id_f_sbl, f_sbl, Time, is, js )
  endif
  
!=======================================================================
  end subroutine STABLE_BL_TURB

!#######################################################################

! <SUBROUTINE NAME="STABLE_BL_TURB_INIT">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!     Initializes stable_bl_turb_mod: Reads and records namelist, 
!     sets up netcdf output if desired.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  STABLE_BL_TURB_INIT ( axes, Time )
!
!  </TEMPLATE>
!  <IN NAME=" axes" TYPE="integer">
!   Vector of axes integers
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   Time variable 
!  </IN>
! </SUBROUTINE>
!
 subroutine STABLE_BL_TURB_INIT ( axes, Time )
!=======================================================================
                   
 integer,         intent(in) :: axes(4)
 type(time_type), intent(in) :: Time

 integer :: unit, io, ierr

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

!---------------------------------------------------------------------
! --- Read namelist
!---------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=stable_bl_turb_nml, iostat=io)
  ierr = check_nml_error(io,'stable_bl_turb_nml')
#else   
! -------------------------------------
  if( FILE_EXIST( 'input.nml' ) ) then
   unit = OPEN_NAMELIST_FILE ( file = 'input.nml')
   ierr = 1
   do while( ierr .ne. 0 )
   READ ( unit,  nml = stable_bl_turb_nml, iostat = io, end = 10 ) 
   ierr = check_nml_error (io, 'stable_bl_turb_nml')
   end do
10 continue
   CALL CLOSE_FILE( unit )
! -------------------------------------
  end if
#endif

!---------------------------------------------------------------------
! --- Output version
!---------------------------------------------------------------------

  if ( mpp_pe() == mpp_root_pe() ) then
       call write_version_number(version, tagname)
       unit = stdlog()
       WRITE( unit, nml = stable_bl_turb_nml ) 
  endif

!---------------------------------------------------------------------
! --- CONSTANTS
!---------------------------------------------------------------------

  oalsm = 1.0 / alsm
  oalsh = 1.0 / alsh

!---------------------------------------------------------------------
! --- initialize quantities for diagnostics output
!---------------------------------------------------------------------

   id_z_sbl = register_diag_field ( mod_name, &
     'z_sbl', axes(1:2), Time, &
     'Depth of stable boundary layer',              'm' )

   id_f_sbl = register_diag_field ( mod_name, &
     'f_sbl', axes(1:2), Time, &
     'Frequency of stable boundary layer',          ' ' )

!---------------------------------------------------------------------
 module_is_initialized = .true.
!=======================================================================
 end subroutine STABLE_BL_TURB_INIT

!#######################################################################

! <SUBROUTINE NAME="STABLE_BL_TURB_END">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!    Closes down stable_bl_turb.  
!  </DESCRIPTION>
!  <TEMPLATE>
!   call STABLE_BL_TURB_END
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine STABLE_BL_TURB_END

!---------------------------------------------------------------------
 module_is_initialized = .false.
!=======================================================================
 end subroutine STABLE_BL_TURB_END

!#######################################################################
  end MODULE STABLE_BL_TURB_MOD


!FDOC_TAG_GFDL
module strat_cloud_mod
  ! <CONTACT EMAIL="Stephen.Klein@noaa.gov">
  !   Stephen Klein
  ! </CONTACT>
  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
  ! <OVERVIEW>
  !   Code to compute time tendencies of stratiform clouds and diagnoses
  !   rain and snow flux with prognostic scheme.
  !   
  ! </OVERVIEW>
  ! <DESCRIPTION>
  !
  !
  !       The prognostic scheme returns the time tendencies of liquid,
  !       ice, and saturated volume fraction that are suspended in 
  !       stratiform clouds.  The scheme diagnoses the fluxes of rain
  !       and snow in saturated and unsaturated areas.
  !
  !       The prognostic cloud scheme is responsible for determing
  !       cloud volume fractions, condensed water tendencies, and
  !       the stratiform precipitation rate.  It includes processes
  !       for evaporation, condensation, deposition, and sublimation
  !       of cloud water, conversion of cloud water to precipitation,
  !       evaporation of falling precipitation, the bergeron-findeisan 
  !       process, freezing of cloud liquid, accretion of cloud water 
  !       by precipitation, and melting of falling precipitation.
  !
  !       This scheme is based on the experience the author had 
  !       at the ECMWF in 1997. The saturated volume fraction formalism 
  !       and type of solution follow directly from the scheme of Tiedtke
  !       (1993): Monthly Weather Review, Volume 121, pages 3040-3061.
  !       The form of most of the microphysics follows Rotstayn , 1997:
  !       Quart. J. Roy. Met. Soc. vol 123, pages 1227-1282. The partial
  !       precipitation area formulism follows Jakob and Klein, 2000:
  !       Quart. J. Roy. Met. Soc. vol 126, pages 2525-2544. 
  !
  !       The statistical cloud scheme treatment, which is used as
  !       a replacement for the Tiedtke cloud fraction scheme, is based
  !       on a number of publications: Tompkins, A., 2002: J. Atmos. 
  !       Sci., 59, 1917-1942, Klein et al., 2005: J. Geophys. Res., 
  !       110, D15S06, doi:10.1029/2004JD005017. 
  ! </DESCRIPTION>
  !

! <DATASET NAME="strat_cloud.res">
!   native format of the restart file
! </DATASET>
! <DATASET NAME="strat_cloud.res.nc">
!   netcdf format of the restart file
! </DATASET>


! <INFO>
!   <REFERENCE>           
!The saturation volume fraction formalism comes from:
!
!Tiedtke, M., 1993: Representation of clouds in large-scale models. Mon. Wea. Rev., 121, 3040-3061.
!
! </REFERENCE>
!   <REFERENCE>           
!The form of most of the microphysics follows:
!
!Rotstayn, L., 1997: A physically based scheme for the treatment of stratiform clouds and precipitation in large-scale models. 
!I: Description and evaluation of microphysical processes. Quart. J. Roy. Met. Soc. 123, 1227-1282. 
! </REFERENCE>
!   <COMPILER NAME="">     </COMPILER>
!   <PRECOMP FLAG="">      </PRECOMP>
!   <LOADER FLAG="">       </LOADER>
!   <TESTPROGRAM NAME="">  </TESTPROGRAM>
!   <BUG>                  </BUG>
!   <NOTE> 
!1. qmin should be chosen such that the range of {qmin, max(qa,ql,qi)} is resolved by the precision of the numbers used.
!   (default = 1.E-10)
!   </NOTE>

!   <NOTE> 
!2. Dmin will be MACHINE DEPENDENT and occur when
!   </NOTE>

!   <NOTE> 
!a. 1. -exp(-Dmin) = 0. instead of Dmin in the limit of very small Dmin
!   </NOTE>

!AND

!   <NOTE> 
!b. 1. - exp(-D) < D for all D > Dmin
!   </NOTE>
!   <FUTURE>               </FUTURE>

! </INFO>

  use  sat_vapor_pres_mod, only : compute_qs
  use             mpp_mod, only : input_nml_file
  use             fms_mod, only : file_exist, open_namelist_file,  &
                                  error_mesg, FATAL, NOTE,         &
                                  mpp_pe, mpp_root_pe, close_file, &
                                  read_data, write_data,           &
                                  check_nml_error, &
                                  write_version_number, stdlog, &
                                  open_restart_file, open_ieee32_file, &
                                  mpp_error
  use  fms_io_mod,         only : get_restart_io_mode, &
                                  register_restart_field, restart_file_type, &
                                  save_restart, restore_state, get_mosaic_tile_file
  use  constants_mod,      only : rdgas,rvgas,hlv,hlf,hls,      &
                                  cp_air,grav,tfreeze,dens_h2o
  use  cloud_rad_mod,      only : cloud_rad_init
  use  diag_manager_mod,   only : register_diag_field, send_data
  use  time_manager_mod,   only : time_type, get_date
  use cloud_generator_mod, only : do_cloud_generator,  &
                                  cloud_generator_init,         &
                                  compute_overlap_weighting
  use beta_dist_mod,       only : beta_dist_init, beta_dist_end, &
                                  incomplete_beta
  use  rad_utilities_mod,  only : aerosol_type
  use  aer_ccn_act_mod,    only : aer_ccn_act_wpdf, aer_ccn_act_init
  use  aer_in_act_mod,     only : Jhete_dep
  use  mpp_mod,            only : mpp_clock_id, mpp_clock_begin, &
                                  mpp_clock_end, CLOCK_LOOP

  implicit none
  integer, private :: sc_loop, sc_pre_loop, sc_post_loop

  public  strat_cloud_init,    &
       strat_cloud,         &
       strat_cloud_end,     &
       strat_cloud_sum,     &
       strat_cloud_avg,     &
       do_strat_cloud,      &
       strat_cloud_on,      &
       strat_cloud_restart

  !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !              GLOBAL STORAGE VARIABLES
  !
  !     radturbten    The sum of radiation and turbulent tendencies
  !                   for each grid box. (K/sec)
  !


  !
  !     ------ data for cloud averaging code ------
  !

  real,    allocatable, dimension (:,:,:) :: qlsum, qisum, cfsum
  integer, allocatable, dimension (:,:)   :: nsum
  !
  !     ------ constants used by the scheme -------
  !

  real, parameter :: d608 = (rvgas-rdgas) / rdgas
  real, parameter :: d622 = rdgas / rvgas
  real, parameter :: d378 = 1. - d622
  !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !
  !       DECLARE CONSTANTS AND SET DEFAULT VALUES FOR PARAMETERS OF 
  !       THE SCHEME
  !
  !
  !
  !                  PHYSICAL CONSTANTS USED IN THE SCHEME
  !
  !
  !         constant              definition                  unit
  !       ------------   -----------------------------   ---------------
  !
  !           grav       gravitational acceleration      m/(s*s)
  !
  !           hlv        latent heat of vaporization     J/kg condensate
  !
  !           hlf        latent heat of fusion           J/kg condensate
  !
  !           hls        latent heat of sublimation      J/kg condensate
  !
  !           rdgas      gas constant of dry air         J/kg air/K
  !
  !           rvgas      gas constant of water vapor     J/kg air/K
  !
  !           cp_air     specific heat of air at         J/kg air/K
  !                      constant pressure
  !
  !           d622       rdgas divided by rvgas          dimensionless
  !
  !           d378       One minus d622                  dimensionless
  !
  !           tfreeze    Triple point of water           K
  !
  !           dens_h2o   Density of pure liquid          kg/(m*m*m)
  !
  !
  !
  !
  !                          PARAMETERS OF THE SCHEME 
  !
  !
  !         parameter              definition                  unit
  !       ------------   -----------------------------   ---------------
  !
  !            U00       threshold relative humidity     fraction
  !                      for cloud formation 
  !
  !       u00_profile    should low-level u00 ECMWF profile be applied?
  !
  !       rthresh        liquid cloud drop radius        microns
  !                      threshold for autoconversion
  !
  !       use_kk_auto    Should one use the Khairoutdinv and Kogan (2000)
  !                      autoconversion formula?
  !
  !       N_land         fixed number of cloud drops     1/(m*m*m)
  !                      per unit volume in liquid 
  !                      clouds on land
  !
  !       N_ocean        fixed number of cloud drops     1/(m*m*m)
  !                      per unit volume in liquid 
  !                      clouds over ocean
  !
  !       rho_ice        mass density of ice crystals    kg/(m*m*m)
  !
  !       ELI            collection efficiency of        dimensionless
  !                      cloud liquid by falling ice
  !
  !       U_evap         critical relative humidity      fraction
  !                      above which rain does not
  !                      evaporate
  !
  !       eros_scale     normal erosion rate constant    1/sec
  !                      cloud destruction
  !
  !       eros_choice    should enhanced erosion in      logical
  !                      turbulent conditions be done?
  !
  !       eros_scale_c   erosion rate constant for       1/sec
  !                      convective conditions
  !
  !       eros_scale_t   erosion rate constant for       1/sec
  !                      cloud destruction for
  !                      turbulent conditions
  !
  !       mc_thresh      Convective mass-flux            kg/m2/sec
  !                      threshold for enhanced
  !                      erosion to turn on.
  !
  !       diff_thresh    Diffusion coefficient           m2/s
  !                      threshold for enhanced
  !                      erosion to turn on.
  !
  !       super_choice   Should should excess vapor      logical
  !                      in supersaturated conditions    
  !                      be put into cloud water (true) 
  !                      or precipitation fluxes (false)
  !                 
  !       tracer_advec   Are cloud liquid,ice and        logical
  !                      fraction advected by the
  !                      grid resolved motion?
  !
  !       qmin           minimum permissible value of    kg condensate/
  !                      cloud liquid, cloud ice,        kg air
  !                      saturated volume fraction,
  !                      or rain and snow areas
  !
  !                      NOTE: qmin should be chosen
  !                      such that the range of
  !                      {qmin, max(qa,ql,qi)} is
  !                      resolved by the precision 
  !                      of the numbers used.
  !
  !       Dmin           minimum permissible             dimensionless
  !                      dissipation in analytic 
  !                      integration of qa, ql, qi
  !                      equations. This constant
  !                      only affects the method by
  !                      which the prognostic equations
  !                      are integrated.
  !
  !                      NOTE: Dmin will be MACHINE 
  !                      DEPENDENT and occur when 
  !                      a. 1. -exp(-Dmin)  = 0. 
  !                         instead of Dmin in the 
  !                         limit of very small Dmin
  !
  !                      AND 
  !
  !                      b. 1. - exp(-D) < D for
  !                         all D > Dmin
  !
  !       do_average     Average stratiform cloud properties
  !                      before computing clouds used by radiation?
  !
  !       strat_cloud_on Is the stratiform cloud scheme
  !                      operating? 
  !
  !       do_budget_diag Are any of the budget diagnostics
  !                      requested from this run?
  !                          
  !       num_strat_pts  number of grid points where 
  !                      instantaneous output will be 
  !                      saved to file strat.data
  !
  !                      num_strat_pts <= max_strat_pts
  !       
  !       max_strat_pts  maximum number of strat pts
  !                      for instantaneous output
  !
  !       strat_pts      "num_strat_pts" pairs of grid
  !                      indices, e.g., the global 
  !                      indices for i,j.
  !
  !       overlap        value of the overlap parameter
  !                      from cloud rad
  !                      overlap = 1 is maximum-random
  !                      overlap = 2 is random
  !
  !     do_old_snowmelt  Should the cloud scheme be run with
  !                      the snowmelt bug?
  !
  !       do_liq_num     Should the prognostic droplet number
  !                      concentration be used?
  ! 
  !     do_pdf_clouds    Should the statistical cloud scheme
  !                      be used?  
  ! 
  !         betaP        the p parameter in the beta distribution
  !
  !      qthalfwidth     The fraction of qtbar (mean total water in the
  !                      grid box) that the maximum and minimum of the 
  !                      distribution differ from qtbar. That is, total 
  !                      water at the sub-grid scale may take on values 
  !                      anywhere between (1.-qthalfwidth)*qtbar and 
  !                      (1.+qthalfwidth)*qtbar
  !
  !      nsublevels      This is the number of sub-levels to be used
  !                      for sub-grid scale vertical structure to
  !                      clouds. If equal to 1, then no vertical
  !                      sub-grid scale structure is calculated.
  !
  !      kmap, kord      Quantities related to the PPM vertical inter-
  !                      polation calculation.
  !
  !                      THIS IS ONLY USED WITH DIAGNOSTIC VARIANCE
  
  real              :: U00            =  0.80
  logical           :: u00_profile    =  .false.
  real              :: rthresh        =  10.
  logical           :: use_kk_auto    =  .false.
  logical           :: use_online_aerosol = .false.
  logical           :: use_sub_seasalt = .true.
  real              :: sea_salt_scale =  0.1
  real              :: om_to_oc       =  1.67
  real              :: N_land         =  250.E+06
  real              :: N_ocean        =  100.E+06
  real              :: var_limit      = 0.0
  real,   parameter :: rho_ice        =  100.
  real,   parameter :: ELI            =  0.7
  real              :: U_evap         =  1.0
  real              :: eros_scale     =  1.E-06
  logical           :: eros_choice    =  .false.
  real              :: eros_scale_c   =  8.E-06
  real              :: eros_scale_t   =  5.E-05
  real              :: mc_thresh      =  0.001
  real              :: diff_thresh    =  1.0
  logical           :: super_choice   =  .false.
  logical           :: tracer_advec   =  .false.
  real              :: qmin           =  1.E-10
  real              :: Dmin           =  1.E-08
  logical           :: do_average     =  .false.
  logical           :: strat_cloud_on =  .false.
  logical           :: do_budget_diag =  .false.
  integer,parameter :: max_strat_pts  =  5
  integer           :: num_strat_pts  =  0
  integer,dimension(2,max_strat_pts) :: strat_pts = 0
  integer           :: overlap        =  2
  real              :: efact          = 0.0
  real              :: vfact          = 1.0
  real              :: iwc_crit       = 0.
  real              :: vfall_const2   = 3.29
  real              :: vfall_exp2     = 0.16
  real              :: cfact          = 1.0
  logical           :: do_old_snowmelt= .false.
  logical           :: do_liq_num   = .false.
  logical           :: do_dust_berg   = .false.
  real              :: N_min          = 1.E6
  logical           :: do_pdf_clouds  = .false.
  real              :: qthalfwidth    = 0.1
  integer           :: nsublevels     = 1
  integer           :: kmap           = 1
  integer           :: kord           = 7
  integer           :: betaP          = 5
  real              :: num_mass_ratio1= 1.
  real              :: num_mass_ratio2= 1.

  !
  !-----------------------------------------------------------------------
  !-------------------- diagnostics fields -------------------------------

  integer :: id_droplets,  id_droplets_col, id_sulfate,  &
             id_droplets_wtd, id_ql_wt, &
             id_seasalt_sub, id_seasalt_sup, id_om
  integer :: id_aliq,         id_aice,            id_aall,       &
       id_rvolume,      id_autocv,          id_vfall 
  integer :: id_qldt_cond,    id_qldt_eros,       id_qldt_fill,  &
       id_qldt_accr,    id_qldt_evap,       id_qldt_freez, &
       id_qldt_berg,    id_qldt_destr,      id_qldt_rime,  &
       id_qldt_auto,    id_qndt_cond,       id_qndt_evap,  &
       id_qndt_fill,    id_qndt_destr,      id_qndt_super, &
       id_debug1, id_debug2, id_debug3, id_debug4,         &
       id_lsf_strat, id_lcf_strat, id_mfls_strat

  integer :: id_rain_clr,     id_rain_cld,        id_a_rain_clr, &
       id_a_rain_cld,   id_rain_evap,       id_liq_adj
  integer :: id_qidt_fall,    id_qidt_fill,       id_qidt_melt,  &
       id_qidt_dep,     id_qidt_subl,       id_qidt_eros,  &
       id_qidt_destr
  integer :: id_snow_clr,     id_snow_cld,        id_a_snow_clr, &
       id_a_snow_cld,   id_snow_subl,       id_snow_melt,  &
       id_ice_adj
  integer :: id_ql_eros_col,  id_ql_cond_col,   id_ql_evap_col,  &
       id_ql_accr_col,  id_ql_auto_col,   id_ql_fill_col,  &
       id_ql_berg_col,  id_ql_destr_col,  id_ql_rime_col,  &       
       id_ql_freez_col    
  integer :: id_qn_cond_col,  id_qn_evap_col,  id_qn_fill_col, &
       id_qn_destr_col,  id_qn_super_col
  integer :: id_rain_evap_col,id_liq_adj_col
  integer :: id_qi_fall_col,  id_qi_fill_col,   id_qi_subl_col,  &
       id_qi_melt_col,  id_qi_destr_col,  id_qi_eros_col,  &
       id_qi_dep_col
  integer :: id_snow_subl_col,id_snow_melt_col, id_ice_adj_col
  integer :: id_qadt_lsform,  id_qadt_eros,     id_qadt_fill,    &
       id_qadt_rhred,   id_qadt_destr,   &
       id_qadt_lsdiss,  id_qadt_super   
  integer :: id_qa_lsform_col,id_qa_eros_col,   id_qa_fill_col,  &
       id_qa_rhred_col, id_qa_destr_col, &
       id_qa_lsdiss_col,id_qa_super_col
  integer :: id_a_precip_cld, id_a_precip_clr

  !--- for netcdf restart
  type(restart_file_type), pointer, save :: Str_restart => NULL()
  type(restart_file_type), pointer, save :: Til_restart => NULL()
  logical                                :: in_different_file = .false.
  logical                                :: do_netcdf_restart = .true.

  character(len=5) :: mod_name = 'strat'
  real :: missing_value = -999.

  !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !
  !       CREATE NAMELIST
  !

! <NAMELIST NAME="strat_cloud_nml">
!  <DATA NAME="U00" UNITS="" TYPE="real" DIM="" DEFAULT="">
!     Threshold relative humidity for cloud formation by large-scale condensation. (default = 0.80) 
!  </DATA>
!  <DATA NAME="u00_profile" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! Should low-level u00 ECMWF profile be applied? (default = .false.) 
!  </DATA>
!  <DATA NAME="rthresh" UNITS="microns" TYPE="real" DIM="" DEFAULT="">
!  Liquid cloud drop radius threshold for autoconversion. (default = 10.)
!  </DATA>
!  <DATA NAME="use_kk_auto" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! Should the Khairoutdinov and Kogan (2000) autoconversion be used? ( default = .false.)
!  </DATA>
!  <DATA NAME="N_land" UNITS="1/(m*m*m)" TYPE="real" DIM="" DEFAULT="">
! Fixed number of cloud drops per unit volume in liquid clouds on land. ( default = 250.E+06)
!  </DATA>
!  <DATA NAME="N_ocean" UNITS="1/(m*m*m)" TYPE="real" DIM="" DEFAULT="">
!  Fixed number of cloud drops per unit volume in liquid clouds over ocean. ( default = 100.E+06)
!  </DATA>
!  <DATA NAME="U_evap" UNITS="fraction" TYPE="real" DIM="" DEFAULT="">
!    Critical relative humidity above which rain does not evaporate. (default = 1.0) 
!  </DATA>
!  <DATA NAME="eros_scale" UNITS="1/sec" TYPE="real" DIM="" DEFAULT="">
! Normal erosion rate constant cloud destruction (default = 1.E-06) 
!  </DATA>
!  <DATA NAME="eros_choice" UNITS="" TYPE="real" DIM="" DEFAULT="">
! Should enhanced erosion in turbulent conditions be done? (default = .false.)
!  </DATA>
!  <DATA NAME="eros_scale_c" UNITS="1/sec" TYPE="real" DIM="" DEFAULT="">
!  Erosion rate constant for convective conditions. (default = 8.E-05)
!  </DATA>
!  <DATA NAME="eros_scale_t" UNITS="1/sec" TYPE="real" DIM="" DEFAULT="">
! Erosion rate constant for cloud destruction for turbulent conditions. (default = 5.E-05)
!  </DATA>
!  <DATA NAME="mc_thresh" UNITS="kg/m2/sec" TYPE="real" DIM="" DEFAULT="">
!  Convective mass-flux threshold for enhanced erosion to turn on. (default = 0.001) 
!  </DATA>
!  <DATA NAME="diff_thresh" UNITS="m2/s" TYPE="real" DIM="" DEFAULT="">
!  Diffusion coefficient threshold for enhanced erosion to turn on. (default = 1.0) 
!  </DATA>
!  <DATA NAME="super_choice" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! Should should excess vapor in supersaturated conditions be put into cloud water (true) or precipitation fluxes (false)?
! (default = .false.) 
!  </DATA>
!  <DATA NAME="tracer_advec" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! Are cloud liquid,ice and fraction advected by the grid resolved motion? (default = .false.) 
!  </DATA>
!  <DATA NAME="qmin" UNITS="kg condensate/kg air" TYPE="real" DIM="" DEFAULT="">
!  Minimum permissible value of cloud liquid, cloud ice, saturated volume fraction, or rain and snow areas.

! NOTE: qmin should be chosen such that the range of {qmin, max(qa,ql,qi)} is resolved by the precision of the numbers used.
! (default = 1.E-10) 
!  </DATA>
!  <DATA NAME="Dmin" UNITS="Dimensionless" TYPE="real" DIM="" DEFAULT="">
! Minimum permissible dissipation in analytic integration of qa, ql, qi equations. This constant only affects the method 
! by which the prognostic equations are integrated.

!NOTE: Dmin will be MACHINE DEPENDENT and occur when

!a. 1. -exp(-Dmin) = 0. instead of Dmin in the limit of very small Dmin

!AND

!b. 1. - exp(-D) < D for all D > Dmin

!(default = 1.E-08) 
!  </DATA>
!  <DATA NAME="num_strat_pts" UNITS="" TYPE="integer" DIM="" DEFAULT="">
! Number of grid points where instantaneous output will be saved to file strat.data

!num_strat_pts <= max_strat_pts

!(default = 0)
!  </DATA>
!  <DATA NAME="strat_pts" UNITS="" TYPE="integer" DIM="" DEFAULT="">
!num_strat_pts" pairs of grid indices, e.g., the global indices for i,j. (default = 0) 
!  </DATA>
!  <DATA NAME="efact" UNITS="" TYPE="real" DIM="" DEFAULT="">
! (default = 0.0) 
!  </DATA>
!  <DATA NAME="do_old_snowmelt" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! Should the old version of snow melting, which has a bug,be run? (default = .false.) 
!  </DATA>
!  <DATA NAME="do_liq_num" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!  Should the prognostic droplet number code be run? (default = .false.) 
!  </DATA>
!  <DATA NAME="do_pdf_clouds" UNITS="" TYPE="logical" DIM="" DEFAULT="">
! Should the statistical cloud scheme be run? (default = .false.) 
!  </DATA>
!  <DATA NAME="qthalfwidth" UNITS="none" TYPE="real" DIM="" DEFAULT="">
! Half-width to the qt PDF - used only if do_pdf_clouds is true and diagnostic variance(default = 0.1) 
!  </DATA>
!  <DATA NAME="nsublevels" UNITS="none" TYPE="integer" DIM="" DEFAULT="">
! Number of sublevels to vertical sub-grid cloud structure - used only if do_pdf_cloud is true (default = 1) 
!  </DATA>
!  <DATA NAME="kmap" UNITS="none" TYPE="integer" DIM="" DEFAULT="">
! PPM partial remap integer - used only if do_pdf_cloud is true and if vertical subgrid structure is used(default = 1) 
!  </DATA>
!  <DATA NAME="kord" UNITS="none" TYPE="integer" DIM="" DEFAULT="">
! PPM method number - used only if do_pdf_cloud is true and if vertical subgrid structure is used (default = 7) 
!  </DATA>
!  <DATA NAME="betaP" UNITS="none" TYPE="integer" DIM="" DEFAULT="">
! p-parameter to the beta distribution - used only if do_pdf_clouds is true (default = 5) 
!  </DATA>
!  <DATA NAME="iwc_crit" UNITS="kg/m3" TYPE="real" DIM="" DEFAULT="0.">
! critical ice-water content below which to apply alternate fall speed formula
!  </DATA>
!  <DATA NAME="vfall_const2" UNITS="kg/m3" TYPE="real" DIM="" DEFAULT="3.29">
! factor for alternate fall speed formula
!  </DATA>
!  <DATA NAME="vfall_exp2" UNITS="kg/m3" TYPE="real" DIM="" DEFAULT="0.16">
! exponent for alternate fall speed formula
!  </DATA>
! </NAMELIST>

  NAMELIST /strat_cloud_nml/   &
       U00,u00_profile,rthresh,use_kk_auto, var_limit,  &
       use_online_aerosol,sea_salt_scale,om_to_oc,N_land, &
       use_sub_seasalt,&
       N_ocean,U_evap,eros_scale,eros_choice,   &
       eros_scale_c,eros_scale_t,mc_thresh,     &
       diff_thresh,super_choice,tracer_advec,   &
       qmin,Dmin,num_strat_pts,strat_pts,efact,vfact, cfact, &
       do_old_snowmelt, do_pdf_clouds, betaP,   &
       qthalfwidth,nsublevels,kmap,kord, do_liq_num, do_dust_berg, &
       N_min, num_mass_ratio1, num_mass_ratio2, &
       iwc_crit, vfall_const2, vfall_exp2
       
  !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !
  !       DECLARE VERSION NUMBER OF SCHEME
  !

  Character(len=128) :: Version = '$Id: strat_cloud.F90,v 17.0.2.1.2.1.2.1.2.1.6.1.2.2 2010/09/07 14:45:41 wfc Exp $'
  Character(len=128) :: Tagname = '$Name: hiram_20101115_bw $'
  logical            :: module_is_initialized = .false.
  integer, dimension(1) :: restart_versions = (/ 1 /)
  integer               :: vers
  !        

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !
  !       The module contains the following subroutines:
  !
  !
  !       strat_cloud_init    read namelist file, open logfile, initialize
  !                     constants and fields, read restart file
  !
  !       diag_field_init 
  !                     initializes diagnostic fields
  !
  !       strat_cloud   calculations of the cloud scheme are performed 
  !                     here
  !
  !       add_strat_tend  
  !                     Adds a field to radturbten. This subroutine is 
  !                     needed because of the method to calculate the 
  !                     radiative and turbulent tendencies.
  !
  !       subtract_strat_tend 
  !                     Subtracts a field from radturbten.
  !
  !       strat_cloud_end     writes out restart data to a restart file.
  !
  !       strat_cloud_sum
  !                     sum cloud scheme variables
  !
  !       strat_cloud_avg
  !                     return average of summed cloud scheme variables
  !
  !       do_strat_cloud
  !                     logical flag, is the scheme on?
  !

        logical :: cloud_generator_on

CONTAINS



  !#######################################################################
  !#######################################################################


  ! <SUBROUTINE NAME="strat_cloud_init">
  !  <OVERVIEW>
  !   
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !       Initializes strat_cloud.  Reads namelist, calls cloud_rad_init,
  !       reads restart (if present), initializes netcdf output.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !   call strat_cloud_init(axes,Time,idim,jdim,kdim)
  !                
  !  </TEMPLATE>
  !  <IN NAME="axes" TYPE="integer">
  !       Axes integer vector used for netcdf initialization.
  !  </IN>
  !  <IN NAME="Time" TYPE="time_type">
  !       Time type variable used for netcdf.
  !  </IN>
  !  <IN NAME="idim" TYPE="integer">
  !       Size of first array (usually longitude) dimension.
  !  </IN>
  !  <IN NAME="jdim" TYPE="integer">
  !       Size of second array (usually latitude) dimension.
  !  </IN>
  !  <IN NAME="kdim" TYPE="integer">
  !       Size of vertical array (usually height) dimension.
  !  </IN>
  ! </SUBROUTINE>
  !
  subroutine strat_cloud_init(axes,Time,idim,jdim,kdim)


    !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    !       This subroutine reads the namelist file, opens a logfile, 
    !       and initializes the physical constants of the routine.
    !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    !
    !
    !       VARIABLES
    !
    !
    !       ------
    !       INPUT:
    !       ------
    !
    !         variable              definition                  unit
    !       ------------   -----------------------------   ---------------
    !
    !       axes           integers corresponding to the
    !                      x,y,z,z_half axes types
    !
    !       Time           time type variable
    !
    !       idim,jdim      number of points in first 
    !                      and second dimensions
    !
    !       kdim           number of points in vertical
    !                      dimension
    !
    !
    !       -------------------
    !       INTERNAL VARIABLES:
    !       -------------------
    !
    !         variable              definition                  unit
    !       ------------   -----------------------------   ---------------
    !
    !       unit           unit number for namelist and
    !                      restart file
    !
    !       io             internal variable for reading
    !                      of namelist file
    !
    !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !


    !        
    !       user Interface variables
    !       ------------------------
    !

    integer, intent (in)                   :: idim,jdim,kdim,axes(4)
    type(time_type), intent(in)            :: Time

    !
    !       Internal variables
    !       ------------------
    !

    integer                                :: id_restart
    integer                                :: unit,io,ierr, logunit
    integer                                :: vers2
    character(len=4)                       :: chvers
    character(len=64)                      :: restart_file, fname
    !-----------------------------------------------------------------------
    !       
    !
    if(module_is_initialized) then
      return
    else
      module_is_initialized = .true.
    endif
    !-----------------------------------------------------------------------
    !
    !       Namelist functions

    !       ----- read namelist -----
#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=strat_cloud_nml, iostat=io)
    ierr = check_nml_error(io,"strat_cloud_nml")
#else
    if ( file_exist('input.nml')) then
       unit = open_namelist_file ()
       ierr=1; do while (ierr /= 0)
       read  (unit, nml=strat_cloud_nml, iostat=io, end=10)
       ierr = check_nml_error(io,'strat_cloud_nml')
       enddo
10     call close_file (unit)
    endif
#endif
    call get_restart_io_mode(do_netcdf_restart)

 !write namelist variables to logfile
 if ( mpp_pe() == mpp_root_pe() ) then
    call write_version_number(Version, Tagname)
    logunit = stdlog()
    write (logunit,nml=strat_cloud_nml)
 endif

!-----------------------------------------------------------------------
!    qthalfwidth must be greater than 0.001
!-----------------------------------------------------------------------
        if (qthalfwidth .lt. 1.e-03) then
          call error_mesg ( 'strat_cloud_mod', &
           'qthalfwidth must be greater than 0.001', FATAL)
        endif

!-----------------------------------------------------------------------
!    nsublevels must be greater than 0
!-----------------------------------------------------------------------
        if (nsublevels .lt. 1) then
          call error_mesg ( 'strat_cloud_mod', &
           'nsublevels must be greater than 0', FATAL)
        endif

 !-----------------------------------------------------------------------
 !
 !       initialize qmin, N_land, N_ocean and selected physical constants
 !       in cloud_rad_mod

 if (do_liq_num) then 
   call cloud_rad_init(axes,Time,qmin_in=qmin,N_land_in=N_land,&
        N_ocean_in=N_ocean,prog_droplet_in=do_liq_num,overlap_out=overlap)
 else
   call cloud_rad_init(axes,Time,qmin_in=qmin,N_land_in=N_land,&
        N_ocean_in=N_ocean,overlap_out=overlap)
 endif
 !-----------------------------------------------------------------------
 !
 !       initialize strat_cloud_on to true

     strat_cloud_on = .TRUE.

 !-----------------------------------------------------------------------
 !
 !       initialize the beta distribution module if needed
 
 if (do_pdf_clouds) call beta_dist_init
 
 call cloud_generator_init
 cloud_generator_on = do_cloud_generator()

 if (do_liq_num) call aer_ccn_act_init
 !-----------------------------------------------------------------------
 !
 !       Read Restart file


 !set up stratiform cloud storage
 !           PRINT *, idim, jdim
 allocate(nsum(idim, jdim),      &
      qlsum(idim,jdim,kdim), &
      qisum(idim,jdim,kdim), &
      cfsum(idim,jdim,kdim)  )

 !--- register fields to be written and/or read.
 
 if(do_netcdf_restart) then
      restart_file = 'strat_cloud.res.nc'
      call get_mosaic_tile_file(restart_file, fname, .false. ) 
      allocate(Str_restart)
      if(trim(restart_file) == trim(fname)) then
         Til_restart => Str_restart
         in_different_file = .false.
      else
         in_different_file = .true.
         allocate(Til_restart)
      endif
      id_restart = register_restart_field(Str_restart, restart_file, 'vers', vers, no_domain=.true.)
      id_restart = register_restart_field(Til_restart, restart_file, 'nsum', nsum)
      id_restart = register_restart_field(Til_restart, restart_file, 'qlsum', qlsum)
      id_restart = register_restart_field(Til_restart, restart_file, 'qisum', qisum)
      id_restart = register_restart_field(Til_restart, restart_file, 'cfsum', cfsum)
 endif

 !see if restart file exists
 if (file_exist('INPUT/strat_cloud.res.nc') ) then
    if(mpp_pe() == mpp_root_pe() ) call mpp_error ('strat_cloud_mod', &
         'Reading netCDF formatted restart file: INPUT/strat_cloud.res.nc', NOTE)
    !--- make sure do_netcdf_restart is true.
    if(.not. do_netcdf_restart) call error_mesg ('strat_cloud_mod', &
         'netcdf format restart file INPUT/strat_cloud.res.nc exist, but do_netcdf_restart is false.', FATAL)
    call restore_state(Str_restart)
    if(in_different_file) call restore_state(Til_restart)
 else
    If (file_exist('INPUT/strat_cloud.res')) Then
       unit = open_restart_file (FILE='INPUT/strat_cloud.res', &
            ACTION='read')
       if(mpp_pe() == mpp_root_pe() ) call mpp_error ('strat_cloud_mod', &
            'Reading native formatted restart file.', NOTE)
       read (unit, iostat=io, err=142) vers, vers2

142    continue
       if (io == 0) then

          !--------------------------------------------------------------------
          !    if eor is not encountered, then the file includes radturbten.
          !    that data is not needed, simply continue by reading next record.
          !--------------------------------------------------------------------
          call error_mesg ('strat_cloud_mod',  &
               'reading pre-version number strat_cloud.res file, &
               &ignoring radturbten', NOTE)

          !--------------------------------------------------------------------
          !    the file is a newer one with a version number included. read the 
          !    version number. if it is not a valid version, stop execution with
          !    a message.
          !--------------------------------------------------------------------
       else
          if (.not. any(vers == restart_versions) ) then
             write (chvers, '(i4)') vers
             call error_mesg ('strat_cloud_mod',  &
                  'restart version ' // chvers//' cannot be read &
                  &by this version of strat_cloud_mod.', FATAL)
          endif
       endif
       call read_data (unit, nsum)
       call read_data (unit, qlsum)
       call read_data (unit, qisum)
       call read_data (unit, cfsum)
       call close_file (unit)
    else
       qlsum=0.0; qisum=0.0; cfsum=0.0; nsum=0
    endif
 endif
 vers = restart_versions(size(restart_versions(:)))

 !-----------------------------------------------------------------------
 !
 !       Setup Diagnostics

 call diag_field_init(axes,Time)

 !-----------------------------------------------------------------------

!rab:  set up clocks
  sc_pre_loop = mpp_clock_id('strat_cloud:  vertical loop setup      ', grain=CLOCK_LOOP)
  sc_loop     = mpp_clock_id('strat_cloud:  main vertical level loop ', grain=CLOCK_LOOP)
  sc_post_loop= mpp_clock_id('strat_cloud:  diagnostic send-data     ', grain=CLOCK_LOOP)

end subroutine strat_cloud_init


!#######################################################################
!#######################################################################


! <SUBROUTINE NAME="diag_field_init">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!         Initializes netcdf diagnostics.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diag_field_init (axes,Time)
!
!  </TEMPLATE>
!  <IN NAME="axes" TYPE="integer">
!         Integer array containing axes integers.
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!         Time 
!  </IN>
! </SUBROUTINE>
!
subroutine diag_field_init (axes,Time)


 integer,         intent(in) :: axes(4)
 type(time_type), intent(in) :: Time

 integer, dimension(3) :: half = (/1,2,4/)


 ! assorted items

 id_droplets = register_diag_field ( mod_name, 'droplets', &
      axes(1:3), Time, 'Droplet number conentration',     &
      '/m3', missing_value=missing_value )

 id_droplets_wtd = register_diag_field ( mod_name, 'droplets_wtd', &
      axes(1:3), Time, 'Droplet number conc*Cld liq',     &
      'kg/(kg*m3)', mask_variant = .true., missing_value=missing_value )

 id_ql_wt = register_diag_field ( mod_name, 'ql_wt', &
      axes(1:3), Time, 'Cld liq for weighting droplet conc',     &
      'kg/kg', mask_variant = .true., missing_value=missing_value )

 id_droplets_col = register_diag_field ( mod_name, 'droplets_col', &
      axes(1:2), Time, 'Droplet number column burden',     &
      '/m2', missing_value=missing_value )

 id_sulfate = register_diag_field ( mod_name, 'sulfate', &
      axes(1:3), Time, 'sulfate mass conentration',     &
      'ug so4/m3', missing_value=missing_value )
 
 id_seasalt_sub = register_diag_field ( mod_name, 'seasalt_sub', &
      axes(1:3), Time, 'sub-micron sea salt mass conentration',     &
      'ug/m3', missing_value=missing_value )
 
 id_seasalt_sup = register_diag_field ( mod_name, 'seasalt_sup', &
      axes(1:3), Time, 'super-micron sea salt mass conentration',     &
      'ug/m3', missing_value=missing_value )
 
 id_om = register_diag_field ( mod_name, 'OM', &
      axes(1:3), Time, 'OM mass conentration',     &
     'ug/m3', missing_value=missing_value )

 id_aall = register_diag_field ( mod_name, 'aall', axes(1:3),   &
      Time, 'Cloud fraction for all clouds at midtimestep',     &
      'dimensionless', missing_value=missing_value )

 id_aliq = register_diag_field ( mod_name, 'aliq', axes(1:3),   &
      Time, 'Cloud fraction for liquid clouds', 'dimensionless',&
      missing_value=missing_value )

 id_aice = register_diag_field ( mod_name, 'aice', axes(1:3),   &
      Time, 'Cloud fraction for ice clouds', 'dimensionless',   &
      missing_value=missing_value )

 id_rvolume = register_diag_field ( mod_name, 'rv', axes(1:3),  &
      Time, 'Cloud liquid mean volume radius', 'microns',       &
      missing_value=missing_value )

 id_autocv = register_diag_field ( mod_name, 'aauto', axes(1:3),&
      Time, 'Cloud fraction where autoconversion is occurring', &
      'dimensionless', missing_value=missing_value )

 id_vfall = register_diag_field ( mod_name, 'vfall', axes(1:3), &
      Time, 'Ice crystal fall speed', 'meters/second',          &
      missing_value=missing_value )


 !liquid water tendencies
 id_lsf_strat = register_diag_field ( mod_name, &
      'lsf_strat', axes(1:3), Time, &
      'Condensation/deposition frequency from LS', &
      'none', missing_value=missing_value               )

 id_lcf_strat = register_diag_field ( mod_name, &
      'lcf_strat', axes(1:3), Time, &
      'Convection frequency from LS', &
      'none', missing_value=missing_value               )

 id_mfls_strat = register_diag_field ( mod_name, &
      'mfls_strat', axes(1:3), Time, &
      'Convective mass flux from LS', &
      'Pascal/s', missing_value=missing_value               )

 id_qldt_cond = register_diag_field ( mod_name, &
      'qldt_cond', axes(1:3), Time, &
      'Liquid water specific humidity tendency from LS condensation', &
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_evap = register_diag_field ( mod_name, &
      'qldt_evap', axes(1:3), Time, &
      'Liquid water specific humidity tendency from LS evaporation', &
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_eros = register_diag_field ( mod_name, &
      'qldt_eros', axes(1:3), Time, &
      'Liquid water specific humidity tendency from erosion',   &
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_berg = register_diag_field ( mod_name, &
      'qldt_berg', axes(1:3), Time, &
      'Liquid water specific humidity tendency from Bergeron process',&
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_freez = register_diag_field ( mod_name, &
      'qldt_freez', axes(1:3), Time, &
      'Liquid water specific humidity tendency from homogenous freezing',&
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_rime = register_diag_field ( mod_name, &
      'qldt_rime', axes(1:3), Time, &
      'Liquid water specific humidity tendency from riming',    &
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_accr = register_diag_field ( mod_name, &
      'qldt_accr', axes(1:3), Time, &
      'Liquid water specific humidity tendency from accretion', &
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_auto = register_diag_field ( mod_name, &
      'qldt_auto', axes(1:3), Time, &
      'Liquid water specific humidity tendency from autoconversion',&
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_fill = register_diag_field ( mod_name, &
      'qldt_fill', axes(1:3), Time, &
      'Liquid water specific humidity tendency from filler',    &
      'kg/kg/sec', missing_value=missing_value               )

 id_qldt_destr = register_diag_field ( mod_name, &
      'qldt_destr', axes(1:3), Time, &
      'Liquid water specific humidity tendency from cloud destruction',&
      'kg/kg/sec', missing_value=missing_value               )


!cloud droplet number tendencies

 id_qndt_cond = register_diag_field ( mod_name, &
       'qndt_cond', axes(1:3), Time, &
       'Cloud droplet tendency from LS condensation', &
       '#/kg/sec', missing_value=missing_value               )

 id_qndt_evap = register_diag_field ( mod_name, &
       'qndt_evap', axes(1:3), Time, &
       'Cloud droplet tendency from LS evaporation', &
       '#/kg/sec', missing_value=missing_value               )

 id_qndt_fill = register_diag_field ( mod_name, &
       'qndt_fill', axes(1:3), Time, &
       'Cloud droplet tendency from filler', &
       '#/kg/sec', missing_value=missing_value               )

 id_qndt_destr = register_diag_field ( mod_name, &
       'qndt_destr', axes(1:3), Time, &
       'Cloud droplet tendency from cloud destruction', &
       '#/kg/sec', missing_value=missing_value               )

 id_qndt_super = register_diag_field ( mod_name, &
       'qndt_super', axes(1:3), Time, &
       'Cloud droplet tendency from supersaturation formation', &
       '#/kg/sec', missing_value=missing_value               )

 id_debug1 = register_diag_field ( mod_name, 'debug1', &
       axes(1:3), Time, 'Droplet number conentration',     &
       '/m3', missing_value=missing_value )
 
 id_debug2 = register_diag_field ( mod_name, 'debug2', &
       axes(1:3), Time, 'Droplet number conentration',     &
       '/m3', missing_value=missing_value )
 
 id_debug3 = register_diag_field ( mod_name, 'debug3', &
       axes(1:3), Time, 'Droplet number conentration',     &
       '/m3', missing_value=missing_value )
 
 id_debug4 = register_diag_field ( mod_name, 'debug4', &
       axes(1:3), Time, 'Droplet number conentration',     &
       '/m3', missing_value=missing_value )

 !rain stuff


 id_liq_adj = register_diag_field ( mod_name, &
      'liq_adj', axes(1:3), Time, &
      'Liquid condensation rate from removal of supersaturation',&
      'kg/kg/sec', missing_value=missing_value               )

 id_rain_clr = register_diag_field ( mod_name, &
      'rain_clr', axes(half), Time, &
      'Clear sky rain rate averaged to grid box mean',          &
      'kg/m2/s', missing_value=missing_value                 )

 id_rain_cld = register_diag_field ( mod_name, &
      'rain_cld', axes(half), Time, &
      'cloudy sky rain rate averaged to grid box mean',         &
      'kg/m2/s', missing_value=missing_value                 )

 id_a_rain_clr = register_diag_field ( mod_name, &
      'a_rain_clr', axes(half), Time, &
      'Clear sky rain fractional coverage',                     &
      'fraction', missing_value=missing_value                 )

 id_a_rain_cld = register_diag_field ( mod_name, &
      'a_rain_cld', axes(half), Time, &
      'cloudy sky rain fractional coverage',                    &
      'fraction', missing_value=missing_value                 )

 id_rain_evap = register_diag_field ( mod_name, &
      'rain_evap', axes(1:3), Time, &
      'Water vapor tendency from rain evaporation',             &
      'kg/kg/sec', missing_value=missing_value               )

 id_a_precip_clr = register_diag_field ( mod_name, &
      'a_precip_clr', axes(half), Time, &
      'Clear sky precip fractional coverage',                   &
      'fraction', missing_value=missing_value                 )

 id_a_precip_cld = register_diag_field ( mod_name, &
      'a_precip_cld', axes(half), Time, &
      'cloudy sky precip fractional coverage',                  &
      'fraction', missing_value=missing_value                 )


 !ice water tendencies


 id_qidt_dep = register_diag_field ( mod_name, &
      'qidt_dep', axes(1:3), Time, &
      'Ice water specific humidity tendency from LS deposition', &
      'kg/kg/sec', missing_value=missing_value               )

 id_qidt_subl = register_diag_field ( mod_name, &
      'qidt_subl', axes(1:3), Time, &
      'Ice water specific humidity tendency from LS sublimation', &
      'kg/kg/sec', missing_value=missing_value               )

 id_qidt_fall = register_diag_field ( mod_name, &
      'qidt_fall', axes(1:3), Time, &
      'Ice water specific humidity tendency from ice settling', &
      'kg/kg/sec', missing_value=missing_value               )

 id_qidt_eros = register_diag_field ( mod_name, &
      'qidt_eros', axes(1:3), Time, &
      'Ice water specific humidity tendency from erosion',      &
      'kg/kg/sec', missing_value=missing_value               )

 id_qidt_melt = register_diag_field ( mod_name, &
      'qidt_melt', axes(1:3), Time, &
      'Ice water specific humidity tendency from melting to rain',&
      'kg/kg/sec', missing_value=missing_value               )

 id_qidt_fill = register_diag_field ( mod_name, &
      'qidt_fill', axes(1:3), Time, &
      'Ice water specific humidity tendency from filler',       &
      'kg/kg/sec', missing_value=missing_value               )

 id_qidt_destr = register_diag_field ( mod_name, &
      'qidt_destr', axes(1:3), Time, &
      'Ice water specific humidity tendency from cloud destruction',&
      'kg/kg/sec', missing_value=missing_value               )



 !snow stuff


 id_ice_adj = register_diag_field ( mod_name, &
      'ice_adj', axes(1:3), Time, &
      'Frozen condensation rate from removal of supersaturation', &
      'kg/kg/sec', missing_value=missing_value               )

 id_snow_clr = register_diag_field ( mod_name, &
      'snow_clr', axes(half), Time, &
      'Clear sky snow rate averaged to grid box mean',          &
      'kg/m2/s', missing_value=missing_value                 )

 id_snow_cld = register_diag_field ( mod_name, &
      'snow_cld', axes(half), Time, &
      'cloudy sky snow rate averaged to grid box mean',         &
      'kg/m2/s', missing_value=missing_value                 )

 id_a_snow_clr = register_diag_field ( mod_name, &
      'a_snow_clr', axes(half), Time, &
      'Clear sky snow fractional coverage',                     &
      'fraction', missing_value=missing_value                 )

 id_a_snow_cld = register_diag_field ( mod_name, &
      'a_snow_cld', axes(half), Time, &
      'cloudy sky snow fractional coverage',                    &
      'fraction', missing_value=missing_value                 )

 id_snow_subl = register_diag_field ( mod_name, &
      'snow_subl', axes(1:3), Time, &
      'Water vapor tendency from snow sublimation',             &
      'kg/kg/sec', missing_value=missing_value               )

 id_snow_melt = register_diag_field ( mod_name, &
      'snow_melt', axes(1:3), Time, &
      'Rain water tendency from snow melting',                  &
      'kg/kg/sec', missing_value=missing_value               )


 !cloud fraction tendencies

 id_qadt_lsform = register_diag_field ( mod_name, &
      'qadt_lsform', axes(1:3), Time, &
      'cloud fraction tendency from LS condensation',                 &
      '1/sec', missing_value=missing_value               )

 id_qadt_lsdiss = register_diag_field ( mod_name, &
      'qadt_lsdiss', axes(1:3), Time, &
      'cloud fraction tendency from LS evaporation',                 &
      '1/sec', missing_value=missing_value               )

 id_qadt_rhred = register_diag_field ( mod_name, &
      'qadt_rhred', axes(1:3), Time, &
      'cloud fraction tendency from RH limiter',                      &
      '1/sec', missing_value=missing_value               )

 id_qadt_eros = register_diag_field ( mod_name, &
      'qadt_eros', axes(1:3), Time, &
      'cloud fraction tendency from erosion',                   &
      '1/sec', missing_value=missing_value               )

 id_qadt_fill = register_diag_field ( mod_name, &
      'qadt_fill', axes(1:3), Time, &
      'cloud fraction tendency from filler',                    &
      '1/sec', missing_value=missing_value               )

 id_qadt_super = register_diag_field ( mod_name, &
      'qadt_super', axes(1:3), Time, &
      'cloud fraction tendency from supersaturation formation', &
      '1/sec', missing_value=missing_value               )

 id_qadt_destr = register_diag_field ( mod_name, &
      'qadt_destr', axes(1:3), Time, &
      'cloud fraction tendency from cloud destruction',             &
      '1/sec', missing_value=missing_value               )


 !column integrated liquid tendencies


 id_ql_cond_col = register_diag_field ( mod_name, &
      'ql_cond_col', axes(1:2), Time, &
      'Column integrated condensation',                         &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_evap_col = register_diag_field ( mod_name, &
      'ql_evap_col', axes(1:2), Time, &
      'Column integrated evaporation',                          &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_eros_col = register_diag_field ( mod_name, &
      'ql_eros_col', axes(1:2), Time, &
      'Column integrated liquid erosion',                       &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_accr_col = register_diag_field ( mod_name, &
      'ql_accr_col', axes(1:2), Time, &
      'Column integrated accretion',                            &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_berg_col = register_diag_field ( mod_name, &
      'ql_berg_col', axes(1:2), Time, &
      'Column integrated Bergeron process',                     &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_freez_col = register_diag_field ( mod_name, &
      'ql_freez_col', axes(1:2), Time, &
      'Column integrated homogeneous freezing',                 &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_destr_col = register_diag_field ( mod_name, &
      'ql_destr_col', axes(1:2), Time, &
      'Column integrated liquid destruction',                   &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_rime_col = register_diag_field ( mod_name, &
      'ql_rime_col', axes(1:2), Time, &
      'Column integrated riming',                               &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_auto_col = register_diag_field ( mod_name, &
      'ql_auto_col', axes(1:2), Time, &
      'Column integrated autoconversion',                       &
      'kg/m2/sec', missing_value=missing_value               )

 id_ql_fill_col = register_diag_field ( mod_name, &
      'ql_fill_col', axes(1:2), Time, &
      'Column integrated liquid filler',                        &
      'kg/m2/sec', missing_value=missing_value               )

 id_liq_adj_col = register_diag_field ( mod_name, &
      'liq_adj_col', axes(1:2), Time, &
      'Column integrated liquid condensation by adjustment',    &
      'kg/m2/sec', missing_value=missing_value               )

 id_rain_evap_col = register_diag_field ( mod_name, &
      'rain_evap_col', axes(1:2), Time, &
      'Column integrated rain evaporation',                     &
      'kg/m2/sec', missing_value=missing_value               )

 !column integrated cloud droplet number tendencies

 id_qn_cond_col = register_diag_field ( mod_name, &
      'qn_cond_col', axes(1:2), Time, &
      'Column integrated drop number condensation',             &
      'kg/m2/sec', missing_value=missing_value               )

 id_qn_evap_col = register_diag_field ( mod_name, &
      'qn_evap_col', axes(1:2), Time, &
      'Column integrated drop number evaporation',              &
      'kg/m2/sec', missing_value=missing_value               )

 id_qn_fill_col = register_diag_field ( mod_name, &
      'qn_fill_col', axes(1:2), Time, &
      'Column integrated drop number filler',                   &
      'kg/m2/sec', missing_value=missing_value               )

 id_qn_destr_col = register_diag_field ( mod_name, &
      'qn_destr_col', axes(1:2), Time, &
      'Column integrated drop number destruction',              &
      'kg/m2/sec', missing_value=missing_value               )

 id_qn_super_col = register_diag_field ( mod_name, &
      'qn_super_col', axes(1:2), Time, &
      'Column integrated drop number supersaturation',          &
      'kg/m2/sec', missing_value=missing_value               )

 !column integrated ice tendencies


 id_qi_fall_col = register_diag_field ( mod_name, &
      'qi_fall_col', axes(1:2), Time, &
      'Column integrated ice settling',                         &
      'kg/m2/sec', missing_value=missing_value               )

 id_qi_fill_col = register_diag_field ( mod_name, &
      'qi_fill_col', axes(1:2), Time, &
      'Column integrated ice filler',                           &
      'kg/m2/sec', missing_value=missing_value               )

 id_qi_eros_col = register_diag_field ( mod_name, &
      'qi_eros_col', axes(1:2), Time, &
      'Column integrated ice erosion',                          &
      'kg/m2/sec', missing_value=missing_value               )

 id_qi_dep_col = register_diag_field ( mod_name, &
      'qi_dep_col', axes(1:2), Time, &
      'Column integrated large-scale deposition',               &
      'kg/m2/sec', missing_value=missing_value               )

 id_qi_subl_col = register_diag_field ( mod_name, &
      'qi_subl_col', axes(1:2), Time, &
      'Column integrated large-scale sublimation',              &
      'kg/m2/sec', missing_value=missing_value               )

 id_qi_destr_col = register_diag_field ( mod_name, &
      'qi_destr_col', axes(1:2), Time, &
      'Column integrated ice destruction',                      &
      'kg/m2/sec', missing_value=missing_value               )

 id_qi_melt_col = register_diag_field ( mod_name, &
      'qi_melt_col', axes(1:2), Time, &
      'Column integrated ice melting',                          &
      'kg/m2/sec', missing_value=missing_value               )

 id_ice_adj_col = register_diag_field ( mod_name, &
      'ice_adj_col', axes(1:2), Time, &
      'Column integrated frozen condesation by adjustment',     &
      'kg/m2/sec', missing_value=missing_value               )

 id_snow_subl_col = register_diag_field ( mod_name, &
      'snow_subl_col', axes(1:2), Time, &
      'Column integrated snow sublimation',                     &
      'kg/m2/sec', missing_value=missing_value               )

 id_snow_melt_col = register_diag_field ( mod_name, &
      'snow_melt_col', axes(1:2), Time, &
      'Column integrated snow melting',                         &
      'kg/m2/sec', missing_value=missing_value               )


 !column integrated cloud fraction tendencies


 id_qa_lsform_col = register_diag_field ( mod_name, &
      'qa_lsform_col', axes(1:2), Time, &
      'Column integrated large-scale formation',                &
      'kg/m2/sec', missing_value=missing_value               )

 id_qa_lsdiss_col = register_diag_field ( mod_name, &
      'qa_lsdiss_col', axes(1:2), Time, &
      'Column integrated large-scale dissipation',                &
      'kg/m2/sec', missing_value=missing_value               )

 id_qa_rhred_col = register_diag_field ( mod_name, &
      'qa_rhred_col', axes(1:2), Time, &
      'Column integrated RH reduction',                         &
      'kg/m2/sec', missing_value=missing_value               )

 id_qa_eros_col = register_diag_field ( mod_name, &
      'qa_eros_col', axes(1:2), Time, &
      'Column integrated cloud fraction erosion',               &
      'kg/m2/sec', missing_value=missing_value               )

 id_qa_fill_col = register_diag_field ( mod_name, &
      'qa_fill_col', axes(1:2), Time, &
      'Column integrated cloud fraction filler',                &
      'kg/m2/sec', missing_value=missing_value               )

 id_qa_super_col = register_diag_field ( mod_name, &
      'qa_super_col', axes(1:2), Time, &
      'Column integrated cloud fraction supersaturation'//      &
      ' formation', 'kg/m2/sec', missing_value=missing_value    )

 id_qa_destr_col = register_diag_field ( mod_name, &
      'qa_destr_col', axes(1:2), Time, &
      'Column integrated cloud fraction destruction',           &
      'kg/m2/sec', missing_value=missing_value               )


 !-----------------------------------------------------------------------
 !
 !       set diagnostic flag

 do_budget_diag = .false.
 if ( id_qldt_cond     > 0 .or. id_qldt_eros     > 0 .or. &
      id_qldt_fill     > 0 .or. id_qldt_accr     > 0 .or. &
      id_qldt_evap     > 0 .or. id_qldt_freez    > 0 .or. &
      id_qldt_berg     > 0 .or. id_qldt_destr    > 0 .or. &
      id_qldt_rime     > 0 .or. id_qldt_auto     > 0 .or. &
      id_qndt_cond     > 0 .or. id_qndt_evap     > 0 .or. &
      id_qndt_fill     > 0 .or. id_qndt_destr    > 0 .or. &
      id_qndt_super    > 0 .or.                           &
      id_debug1        > 0 .or. id_debug2        > 0 .or. &
      id_droplets      > 0 .or. id_sulfate       > 0 .or. &
      id_droplets_wtd  > 0 .or. id_ql_wt         > 0 .or. &
      id_seasalt_sub   > 0 .or. id_seasalt_sup   > 0 .or. &
      id_om            > 0 .or. id_droplets_col  > 0 .or. &
      id_lsf_strat     > 0 .or. id_lcf_strat     > 0 .or. &
      id_mfls_strat    > 0 ) then
    do_budget_diag = .true.
 end if
 if ( id_rain_clr      > 0 .or. id_rain_cld      > 0 .or. &
      id_a_rain_clr    > 0 .or. id_a_rain_cld    > 0 .or. &
      id_rain_evap     > 0 .or. id_liq_adj       > 0) then
    do_budget_diag = .true.
 end if
 if ( id_qidt_fall     > 0 .or. id_qidt_fill     > 0 .or. &
      id_qidt_melt     > 0 .or. id_qidt_dep      > 0 .or. &
      id_qidt_subl     > 0 .or. id_qidt_eros     > 0 .or. &
      id_qidt_destr    > 0) then
    do_budget_diag = .true.
 end if
 if ( id_snow_clr      > 0 .or. id_snow_cld      > 0 .or. &
      id_a_snow_clr    > 0 .or. id_a_snow_cld    > 0 .or. &
      id_snow_subl     > 0 .or. id_snow_melt     > 0 .or. &
      id_ice_adj       > 0 ) then
    do_budget_diag = .true.
 end if
 if ( id_ql_eros_col   > 0 .or. id_ql_cond_col   > 0 .or. &
      id_ql_evap_col   > 0 .or. id_ql_accr_col   > 0 .or. &
      id_ql_auto_col   > 0 .or. id_ql_fill_col   > 0 .or. &
      id_ql_berg_col   > 0 .or. id_ql_destr_col  > 0 .or. &
      id_ql_rime_col   > 0 .or. id_ql_freez_col  > 0) then
    do_budget_diag = .true.
 end if
 if ( id_qn_cond_col   > 0 .or. id_qn_evap_col   > 0 .or. &
      id_qn_fill_col   > 0 .or. id_qn_destr_col  > 0 .or. &
      id_qn_super_col  > 0) then
    do_budget_diag = .true.
 end if
 if ( id_rain_evap_col > 0 .or. id_liq_adj_col   > 0 ) then
    do_budget_diag = .true. 
 end if
 if ( id_qi_fall_col   > 0 .or. id_qi_fill_col   > 0 .or. &
      id_qi_subl_col   > 0 .or. id_qi_melt_col   > 0 .or. &
      id_qi_destr_col  > 0 .or. id_qi_eros_col   > 0 .or. &
      id_qi_dep_col    > 0) then
    do_budget_diag = .true.
 end if
 if ( id_snow_subl_col > 0 .or. id_snow_melt_col > 0 .or. &
      id_ice_adj_col   > 0 ) then
    do_budget_diag = .true.
 end if
 if ( id_qadt_lsform   > 0 .or. id_qadt_eros     > 0 .or. &
      id_qadt_fill     > 0 .or. id_qadt_rhred    > 0 .or. &
      id_qadt_destr    > 0 .or. id_qa_lsdiss_col > 0 .or. &
      id_qadt_lsdiss   > 0 .or. id_qadt_super    > 0 .or. &
      id_qa_lsform_col > 0 .or. id_qa_super_col  > 0 .or. &
      id_qa_eros_col   > 0 .or. id_qa_fill_col   > 0 .or. &
      id_qa_rhred_col  > 0 .or. id_qa_destr_col  > 0) then
    do_budget_diag = .true.
 end if
 if ( id_a_precip_cld  > 0 .or. id_a_precip_clr  > 0 ) then
    do_budget_diag = .true.
 end if

!----------------------------------------------------------------------



end subroutine diag_field_init


!#######################################################################
!#######################################################################


! <SUBROUTINE NAME="strat_cloud">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!       
!  </DESCRIPTION>
!  <TEMPLATE>
!   call strat_cloud(Time,is,ie,js,je,dtcloud,pfull,phalf,radturbten2, 
!                   T,qv,ql,qi,qa,omega,Mc,diff_t,LAND,              
!                   ST,SQ,SL,SI,SA,surfrain,                         
!                   surfsnow,qrat,ahuco,MASK, 
!                    qn, SN, Aerosol)
!
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!         Time
!  </IN>
!  <IN NAME="is" TYPE="integer">
!         Indice of starting point in the longitude direction of the slab being passed to strat_cloud
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!         Indice of ending point in the longitude direction of the slab being passed 
!  </IN>
!  <IN NAME="js" TYPE="integer">
!         Indice of starting point in the latitude direction of the slab being passed
!  </IN>
!  <IN NAME="je" TYPE="integer">
!         Indice of ending point in the latitude direction of the slab being passed 
!  </IN>
!  <IN NAME="dtcloud" TYPE="real">
!         Physics time step (sec)
!  </IN>
!  <IN NAME="pfull" TYPE="real">
!         Pressure on model full levels (Pa)
!  </IN>
!  <IN NAME="phalf" TYPE="real">
!         Pressure on model half levels (Pa)
!  </IN>
!  <IN NAME="radturbten2" TYPE="real">
!         Sum of the tendencies of temperature from turbulence and radiation schemes (K/s)
!  </IN>
!  <IN NAME="T" TYPE="real">
!         Temperature (K)         
!  </IN>
!  <IN NAME="qv" TYPE="real">
!         Water vapor specific humidity (kg vapor/kg air)
!  </IN>
!  <IN NAME="ql" TYPE="real">
!         Grid-box mean liquid water specific humidity (kg liquid/kg air)
!  </IN>
!  <IN NAME="qi" TYPE="real">
!         Grid-box mean ice water specific humidity (kg ice/kg air)
!  </IN>
!  <IN NAME="qa" TYPE="real">
!         Cloud fraction (3d array and a prognostic variable) (fraction)
!  </IN>
!  <IN NAME="qn" TYPE="real">
!         Cloud droplet number (3d array and a prognostic variable) (#/kg air)
!  </IN>
!  <IN NAME="omega" TYPE="real">
!         Vertical pressure velocity (Pa/sec)
!  </IN>
!  <IN NAME="Mc" TYPE="real">
!         Cumulus mass flux (defined positive as upward) (kg air/m2/sec)
!  </IN>
!  <IN NAME="diff_t" TYPE="real">
!         Vertical diffusion coefficient for temperature and tracer from vertical diffusion scheme (m2/sec) 
!  </IN>
!  <IN NAME="LAND" TYPE="real">
!         Fraction of surface that contains land (fraction)
!  </IN>
!  <OUT NAME="ST" TYPE="real">
!         Change in temperature due to strat_cloud (K) 
!  </OUT>
!  <OUT NAME="SQ" TYPE="real">
!         Change in water vapor due to strat_cloud (kg vapor/kg air) 
!  </OUT>
!  <OUT NAME="SL" TYPE="real">
!         Change in cloud liquid due to strat_cloud (kg liquid/kg air)
!  </OUT>
!  <OUT NAME="SI" TYPE="real">
!         Change in cloud ice due to strat_cloud (kg ice/kg air)
!  </OUT>
!  <OUT NAME="SA" TYPE="real">
!         Change in cloud fraction due to strat_cloud (fraction)
!  </OUT>
!  <OUT NAME="SN" TYPE="real">
!         Change in cloud droplet number due to strat_cloud (fraction)
!  </OUT>
!  <OUT NAME="surfrain" TYPE="real">
!         Surface rain fall over time step dtcloud (kg liquid/m2)
!  </OUT>
!  <OUT NAME="surfsnow" TYPE="real">
!         Surface snow fall over time step dtcloud (kg ice/m2)
!  </OUT>
!  <OUT NAME="rain3d" TYPE="real">
!         3D rain fall over time step dtcloud (kg liquid/m2)
!  </OUT>
!  <OUT NAME="snow3d" TYPE="real">
!         3D snow fall over time step dtcloud (kg ice/m2)
!  </OUT>
!  <IN NAME="qrat" TYPE="real">
!         Ratio of large-scale specific humidity to specific humidity in 
!         environment outside convective system (from donner_deep) 
!         
!         Will be equal to 1 for all normal AM2 operations (i.e. donner_deep is not activated)              
!         
!         Note that index 1 is nearest ground
!
!  </IN>
!  <IN NAME="ahuco" TYPE="real">
!         The fraction of the grid box containing either cumulus cells or the mesoscale circulation (from donner_deep).
!
!         Will be equal to 0 for all normal AM2 operations (i.e. donner_deep is not activated)              
!         
!         Note that index 1 is nearest ground
!
!  </IN>
!  <IN NAME="MASK" TYPE="real">
!         Optional input real array indicating the point is above the surface
!         if equal to 1.0 and indicating the point is below the surface if 
!         equal to 0.
!
!         Used only in eta vertical coordinate model.
!  </IN>
! </SUBROUTINE>
!


subroutine strat_cloud(Time,is,ie,js,je,dtcloud,pfull,phalf,radturbten2,&
    T,qv,ql,qi,qa,omega,Mc,diff_t,LAND,              &
    ST,SQ,SL,SI,SA,rain3d,snow3d,snowclr3d,surfrain,     &
    surfsnow,qrat,ahuco,limit_conv_cloud_frac,MASK, &
    qn, Aerosol, SN)


  !        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !
  !
  !       VARIABLES
  !
  !
  !
  !       ------
  !       INPUT:
  !       ------
  !
  !         variable              definition                  unit
  !       ------------   -----------------------------   ---------------
  !
  !       Time           time type variable 
  !
  !       is,ie          starting and ending i indices 
  !                      for data window
  !
  !       js,je          starting and ending j indices 
  !                      for data window
  !
  !       dtcloud        time between this call and      s
  !                      the next call to strat_cloud
  !
  !       pfull          pressure at full model levels   Pa
  !                      IMPORTANT NOTE: p(j)<p(j+1)
  !
  !       phalf          pressure at half model levels   Pa
  !                      phalf(j)<pfull(j)<phalf(j+1)
  !
  !       T              temperature                     K
  !
  !       qv             specific humidity of water      kg vapor/kg air
  !                      vapor
  !
  !       ql             specific humidity of cloud      kg condensate/
  !                      liquid                          kg air
  !
  !       qi             specific humidity of cloud      kg condensate/
  !                      ice                             kg air
  !
  !       qa             saturated volume fraction       fraction
  !
  !       qn             cloud droplet number            #/kg air
  !
  !       qrat           ratio of large-scale spec       fraction
  !                      humidity to spec humidity
  !                      in environment outside
  !                      convective system (from
  !                      donner_deep) 
  !                      index 1 nearest ground
  !
  !       ahuco          fraction, cell+meso, from       fraction
  !                      donner_deep
  !                      index 1 nearest ground
  !
  !       omega          vertical pressure velocity      Pa/s
  !
  !       Mc             Cumulus mass flux defined       kg/(m*m)/s
  !                      on full levels
  !
  !       diff_t         Vertical diffusion coefficient  (m*m)/s
  !                      for temperature and tracer
  !
  !       LAND           the fraction of the grid box    fraction
  !                      covered by land
  !                               
  !
  !       -------
  !       OUTPUT:
  !       -------
  !
  !         variable              definition                  unit
  !       ------------   -----------------------------   ---------------
  !
  !       ST             temperature change due to       K
  !                      all stratiform processes
  !
  !       SQ             water vapor change due to       kg vapor/kg air
  !                      all stratiform processes
  !
  !       SL             cloud liquid change due to      kg condensate/
  !                      all stratiform processes        kg air
  !
  !       SI             cloud ice change due to         kg condensate/
  !                      all stratiform processes        kg air
  !
  !       SA             saturated volume fraction       fraction
  !                      change due to all stratiform 
  !                      processes
  !
  !       SN             cloud droplet number            #/kg air
  !                      change due to all stratiform 
  !                      processes
  !
  !       surfrain       rain that falls through the     kg condensate/
  !                      bottom of the column over       (m*m)
  !                      the time dtcloud
  !
  !       surfsnow       snow that falls through the     kg condensate/
  !                      bottom of the column over       (m*m)
  !                      the time dtcloud
  !
  !       rain3d         rain that falls through the     kg condensate/
  !                      each of the model layer         (m*m)/sec
  !
  !       snow3d         snow that falls through the     kg condensate/
  !                      each of the model layer         (m*m)/sec
  !
  !
  !       ---------------
  !       optional INPUT:
  !       ---------------
  !
  !         variable              definition                  unit
  !       ------------   -----------------------------   ---------------
  !
  !
  !       MASK           real array indicating the 
  !                      point is above the surface
  !                      if equal to 1.0 and 
  !                      indicating the point is below
  !                      the surface if equal to 0.
  !
  !       -------------------
  !       INTERNAL VARIABLES:
  !       -------------------
  !
  !         variable              definition                  unit
  !       ------------   -----------------------------   ---------------
  !
  !       kdim           number of vertical levels
  !
  !       j              model vertical level being 
  !                      processed
  !
  !       ipt,jpt        i and j point indice used only
  !                      in instantaneous diag-
  !                      nostic output
  !
  !       i,unit,nn      temporary integers used in
  !                      instantaneous diagnostic
  !                      output.
  !
  !       inv_dtcloud    1 / dtcloud                     1/sec
  !
  !       airdens        air density                     kg air/(m*m*m)
  !
  !       qs             saturation specific humidity    kg vapor/kg air
  !
  !       dqsdT          T derivative of qs              kg vapor/kg air/K
  !
  !       gamma          (L/cp)*dqsdT                    dimensionless
  !
  !       rain_clr       grid mean flux of rain enter-   kg condensate/
  !                      ing the grid box from above     (m*m)/s
  !                      and entering the unsaturated 
!                      portion of the grid box
!
!       rain_cld       grid mean flux of rain enter-   kg condensate/
!                      ing the grid box from above     (m*m)/s
!                      and entering the saturated 
!                      portion of the grid box
!
!       a_rain_clr     fraction of grid box occupied   fraction
!                      by rain_clr
!
!       a_rain_cld     fraction of grid box occupied   fraction
!                      by rain_cld
!
!       snow_cld       flux of ice entering the        kg condensate/
!                      saturated portion of the        (m*m)/s
!                      grid box from above by means
!                      of gravitational settling 
!
!       snow_clr       flux of ice outside of cloud    kg condensate/
!                      entering the unsaturated        (m*m)/s
!                      portion of the grid box from      
!                      above
!
!       a_snow_clr     area fraction of grid box       fraction
!                      covered by snow flux in
!                      unsaturated air
!
!       a_snow_cld     area fraction of grid box       fraction
!                      covered by the snow flux in
!                      saturated air
!
!       deltpg         pressure thickness of grid box  kg air/(m*m)
!                      divided by gravity
!
!       U              grid box relative humidity      fraction
!
!       U00p           critical relative humidity      fraction
!                      which is a function of pressure 
!
!       dqs_ls         change in saturation specific   kg vapor/kg air
!                      due to large-scale processes,
!                      such as large-scale vertical
!                      motion, compensating convective
!                      mass flux, or radiative cooling
!
!       da_ls          change in saturated volume      fraction
!                      fraction due to large-scale
!                      processes
!
!       C_dt           product of A and dtcloud in     dimensionless in 
!                      in the analytic integration     qa integration
!                      of the qa equation, or C and
!                      dtcloud in the analytic         kg condensate/
!                      integration of the ql and qi    kg air in ql or 
!                      equations.                      qi integration
!
!       D_dt           product of B and dtcloud in     dimensionless in
!                      in the analytic integration     qa, ql, and qi
!                      of the qa equation, or D and    integration
!                      dtcloud in the analytic         
!                      integration of the ql and qi    
!                      equations.                      
!
!       qceq           equilibrium value of cloud      dimensionless or
!                      fraction or cloud condensate    kg condensate /
!                      that the analytic integration   kg air
!                      approaches                      
!
!       qcbar          mean value of cloud fraction    dimensionless or
!                      or cloud condensate over the    kg condensate /
!                      t0 to t0 + dtcloud interval     kg air
!
!       qc0            value of cloud fraction or      dimensionless or
!                      cloud condensate at the         kg condensate /
!                      initial time                    kg air
!        
!       qc1            value of cloud fraction or      dimensionless or
!                      cloud condensate at the final   kg condensate /
!                      time                            kg air
!       
!       D1_dt          first sink in either ql or qi   dimensionless
!                      equation. This is analogous to
!                      D_dt.  In ql equation, this 
!                      sink represents the conversion
!                      of cloud liquid to rain. In the
!                      qi equation it represents the
!                      settling of ice crystals.
!
!       D2_dt          second sink in ql or qi         dimensionless
!                      equation. This is analogous 
!                      to D_dt. In ql equation this
!                      sink represents the conversion
!                      of cloud liquid to ice. In the
!                      qi equation this sink 
!                      represents the melting of 
!                      cloud ice into rain.
!
!       D_eros         Sink in ql, qi and qa equation  dimensionless
!                      due to turbulent erosion of
!                      cloud sides
! 
!       ql_upd         updated value of ql             kg condensate/
!                                                      kg air
!       
!       qi_upd         updated value of qi             kg condensate/
!                                                      kg air
!
!       qa_upd         updated value of qa             fraction
!
!       qa_mean        qa + SA; semi-implicit          fraction
!                      saturated volume fraction
!
!       qa_mean_lst    qa_mean of the level above      fraction
!
!       ql_mean        ql + positive increment         kg condensate/
!                      of ql; i.e. a sort of           kg air
!                      intermediate ql
!
!       qi_mean        ql + positive increment         kg condensate/
!                      of qi; i.e. a sort of           kg air
!                      intermediate qi
!
!       dcond_ls       change in condensate due to     kg condensate/
!                      non-convective condensation.    kg air
!                      After phase determination,
!                      this variable refers only to
!                      liquid condensation.
!
!       dcond_ls_ice   change in ice due to            kg condensate/
!                      non-convective condensation.    kg air
!
!       da_cld2clr     fraction of the area in which   fraction
!                      rain/snow in saturated volume 
!                      above falls into unsaturated 
!                      volume in the current layer.
!
!       da_clr2cld     as in da_cld2clr except for     fraction
!                      the transfer from unsaturated
!                      to saturated volume
!
!       dprec_cld2clr  grid mean flux that is trans-   kg condensate/
!                      ferred from rain/snow in        (m*m)/s
!                      saturated volume to rain/snow 
!                      in unsaturated volume at layer 
!                      interfaces.
!
!       dprec_clr2cld  as in dprec_cld2clr except for  kg condensate/
!                      the transfer from unsaturated   (m*m)/s
!                      to saturated volume.
!
!       N              fixed number of cloud drops     1/(m*m*m)
!                      per unit volume in liquid
!                      clouds
!     
!       rad_liq        mean volume radius of liquid    microns
!                      cloud drops
!
!       A_plus_B       sum of vapor diffusion factor   m*s/kg
!                      and thermal conductivity factor
!                      which is used in various 
!                      microphysical formula for the 
!                      evaporation of rain and snow
!
!       Vfall          fall speed of ice crystals      m/s
!
!       lamda_f        slope factor in the SIZE        1/m
!                      distribution of ice crystals
!
!       U_clr          relative humidity in the clear  fraction
!                      portion of the grid box.
!
!       tmp1,tmp2,tmp3 temporary numbers used at 
!                      several points within the
!                      subroutine
!
!
!                STATISTICAL CLOUD SCHEME VARIABLES
!
!       qag            equilibrium value of cloud      dimensionless 
!                      fraction for statistical 
!                      cloud scheme           
!
!       qcg            equilibrium value of cloud      kg condensate /
!                      condensate that PDF clouds      kg air
!                      wants                          
!
!       qcg_ice        equilibrium value of cloud      kg condensate /
!                      ice condensate that PDF clouds  kg air
!                      wants
!
!       qvg            equilibrium value of water      kg vapor /
!                      vapor in the clear portion      kg air
!                      of the grid box that PDF 
!                      clouds wants                          
!
!       qtbar          total water specific humidity   kg water /
!                      which is equal to the sum of    kg air
!                      liquid water, ice water, and
!                      water vapor
!
!       deltaQ         the width of the total water    kg water /
!                      subgrid distribution (= qtmax   kg air
!                      minus qtmin)
!
!       qtmin          the minimum value to the total  kg water /
!                      sub-grid scale distribution     kg air
!
!       qs_norm        the difference between the      dimensionless
!                      saturation specific humidity    
!                      and qtmin normalized by deltaQ
!
!       icbp           the value of the incomplete     dimensionless
!                      beta function evaluated with
!                      x=qs_norm, p=betaP, and q=betaP
!
!       icbp1          the value of the incomplete     dimensionless
!                      beta function evaluated with                  
!                      x=qs_norm, p=betaP+1, and 
!                      q=betaP
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!


!        
!       user Interface variables
!       ------------------------
!

        type(time_type), intent (in)           :: Time
        integer, intent (in)                   :: is,ie,js,je
        real, intent (in)                      :: dtcloud
        real, intent (in),    dimension(:,:,:) :: pfull,phalf
        real, intent (in),    dimension(:,:,:) :: T,qv,ql,qi,qa,omega
        real, intent (in),    dimension(:,:,:) :: Mc, diff_t
        real, intent (in),    dimension(:,:,:) :: qrat,ahuco
        logical, intent(in)                    :: limit_conv_cloud_frac
        real, intent (in),    dimension(:,:)   :: LAND
        real, intent (in),    dimension(:,:,:) :: radturbten2
        real, intent (out),   dimension(:,:,:) :: ST,SQ,SL,SI,SA
        real, intent (out),   dimension(:,:)   :: surfrain,surfsnow
        real, intent (in), optional, dimension(:,:,:) :: MASK
        real, intent (in),  optional, dimension(:,:,:) :: qn
        real, intent (out),   dimension(:,:,:) :: rain3d
        real, intent (out),   dimension(:,:,:) :: snow3d
        real, intent (out),   dimension(:,:,:) :: snowclr3d
        type(aerosol_type), intent (in), optional      :: Aerosol  
        real, intent (out), optional, dimension(:,:,:) :: SN

!
!       Internal variables
!       ------------------
!

        integer                                        :: idim,jdim,kdim
        integer                                        :: id,jd,ns
        integer                                        :: j,ipt,jpt
        integer                                        :: i,unit,nn        
        real                                           :: inv_dtcloud, Si0
        real                                           :: icbp, icbp1, pnorm
        real, dimension(size(T,1),size(T,2),size(T,3)) :: airdens
        real, dimension(size(T,1),size(T,2),size(T,3)) :: qs,dqsdT
        real, dimension(size(T,1),size(T,2),size(T,3)) :: gamma
        real, dimension(size(T,1),size(T,2),size(T,3)) :: A_plus_B
        real, dimension(4,size(T,1),size(T,2),size(T,3)) :: qta4,qtqsa4
        real, dimension(size(T,1),size(T,2),size(T,3)) :: delp
        real, dimension(size(T,1),size(T,2))   :: rain_clr,rain_cld
        real, dimension(size(T,1),size(T,2))   :: a_rain_clr,a_rain_cld
        real, dimension(size(T,1),size(T,2))   :: snow_clr,snow_cld
        real, dimension(size(T,1),size(T,2))   :: a_snow_clr,a_snow_cld
        real, dimension(size(T,1),size(T,2))   :: deltpg,U,U00p
        real, dimension(size(T,1),size(T,2))   :: dqs_ls,da_ls
!rab        real, dimension(size(T,1),size(T,2))   :: C_dt, D_dt
        real, dimension(size(T,1),size(T,2))   :: D1_dt,D2_dt,D_eros
        real, dimension(size(T,1),size(T,2))   :: qcg_ice, qvg
!rab        real, dimension(size(T,1),size(T,2))   :: qceq, qcbar, qcg, qag
        real, dimension(size(T,1),size(T,2))   :: qcg, qag
!rab        real, dimension(size(T,1),size(T,2))   :: qagtmp,qcgtmp,qvgtmp
!rab        real, dimension(size(T,1),size(T,2))   :: qc1, qc0
        real, dimension(size(T,1),size(T,2))   :: ql_upd,qi_upd,qa_upd, qn_upd
        real, dimension(size(T,1),size(T,2))   :: ql_mean,qi_mean, qn_mean
        real, dimension(size(T,1),size(T,2))   :: qa_mean,qa_mean_lst
        real, dimension(size(T,1),size(T,2))   :: dcond_ls,dcond_ls_ice
        real, dimension(size(T,1),size(T,2))   :: N,rad_liq, N3D_col
        real, dimension(size(T,1),size(T,2),size(T,3)) :: N3D, &
                                                        concen_dust_sub
        real, dimension(size(T,1),size(T,2))   :: Vfall,iwc,lamda_f
        real, dimension(size(T,1),size(T,2))   :: U_clr
!RSH: intended for s release:
!       real, dimension(size(T,1),size(T,2))   :: tmp1,tmp2,tmp3,tmp5,dr        op1,crystal, tmp6
        real, dimension(size(T,1),size(T,2))   :: tmp1,tmp2,tmp3,tmp5,drop1,crystal
!RSH end block
        real, dimension(size(T,1),size(T,2))   :: qtbar,deltaQ
        real, dimension(size(T,1),size(T,2))   :: qtmin,qs_norm          

        !diagnostic variables
        real, allocatable, dimension(:,:,:) :: &
             qldt_cond,  qldt_evap, qldt_berg, qldt_freez,&
             qldt_rime,  qldt_accr, qldt_auto, qldt_fill, &
             qldt_destr, qldt_eros, liq_adj,     rain_evap,            &
             qidt_dep,   qidt_subl, qidt_fill, &
             qidt_melt,  qidt_fall, qidt_destr,  qidt_eros, ice_adj,   &
             snow_subl,  snow_melt, qadt_lsform, qadt_eros, qadt_rhred,&
             qadt_destr, qadt_fill, qadt_lsdiss, qadt_super           ,&
             qndt_cond, qndt_evap, qndt_fill, qndt_destr, qndt_super,  &
             debug1, debug2, debug3, debug4,                           &
             lsf_strat, lcf_strat, mfls_strat
        real, allocatable, dimension(:,:,:) :: &
             rain_clr_diag,     rain_cld_diag,    a_rain_clr_diag, &
             a_rain_cld_diag,   snow_clr_diag,    snow_cld_diag,   &
             a_snow_clr_diag,   a_snow_cld_diag,  mask3,           &
             a_precip_clr_diag, a_precip_cld_diag
        real, allocatable, dimension(:,:,:) :: areaall, arealiq,   &
             areaice, areaautocv, rvolume, vfalldiag
        logical :: used

        integer            :: k
        real               :: thickness, up_strat, wp2 ! cjg
        real, dimension(size(T,1),size(T,2),size(T,3),4) :: totalmass1
!rab - variables necessary to clean up strat_cloud....
        real               :: freeze_pt, tmp1s, tmp2s, tmp3s, snow_fact
        real               :: qc0s, qc1s, qceqs, qcbars, C_dts, D_dts
        real               :: qagtmps,qcgtmps,qvgtmps

     call mpp_clock_begin(sc_pre_loop)
!-----------------------------------------------------------------------
!       
!
     if (.not.module_is_initialized) then
       call error_mesg('strat_cloud','strat_cloud is not initialized',FATAL)
     endif

!-----------------------------------------------------------------------
!       
!       allocate space for diagnostic variables if needed
!

     if (id_aall > 0) then
             if (allocated(areaall)) deallocate (areaall)
             allocate(areaall(size(T,1),size(T,2),size(T,3)))
             areaall(:,:,:) = 0.0
     end if
     if (id_aliq > 0 .or. id_rvolume > 0) then
             if (allocated(arealiq)) deallocate (arealiq)
             allocate(arealiq(size(T,1),size(T,2),size(T,3)))
             arealiq(:,:,:) = 0.0
     end if
     if (id_aice > 0 .or. id_vfall > 0) then
             if (allocated(areaice)) deallocate (areaice)
             allocate(areaice(size(T,1),size(T,2),size(T,3)))
             areaice(:,:,:) = 0.0
     end if
     if (id_rvolume > 0) then
             if (allocated(rvolume)) deallocate (rvolume)
             allocate(rvolume(size(T,1),size(T,2),size(T,3)))
             rvolume(:,:,:) = 0.0
     end if
     if (id_autocv > 0) then
             if (allocated(areaautocv)) deallocate (areaautocv)
             allocate(areaautocv(size(T,1),size(T,2),size(T,3)))
             areaautocv(:,:,:) = 0.0
     end if
     if (id_vfall > 0) then
             if (allocated(vfalldiag)) deallocate (vfalldiag)
             allocate(vfalldiag(size(T,1),size(T,2),size(T,3)))
             vfalldiag(:,:,:) = 0.0
     end if

     if (allocated(debug1)) deallocate (debug1)
     if (allocated(debug2)) deallocate (debug2)
     if (allocated(debug3)) deallocate (debug3)
     if (allocated(debug4)) deallocate (debug4)
     if (id_debug1 > 0) then
      allocate(debug1(size(T,1),size(T,2),size(T,3)))
               debug1       = 0.
     endif
     if (id_debug2 > 0) then
      allocate(debug2(size(T,1),size(T,2),size(T,3)))
               debug2       = 0.
     endif
     if (id_debug3 > 0) then
      allocate(debug3(size(T,1),size(T,2),size(T,3)))
               debug3       = 0.
     endif
     if (id_debug4 > 0) then
      allocate(debug4(size(T,1),size(T,2),size(T,3)))
               debug4       = 0.
     endif

     if (allocated(lsf_strat)) deallocate (lsf_strat)
     if (allocated(lcf_strat)) deallocate (lcf_strat)
     if (allocated(mfls_strat)) deallocate (mfls_strat)
     if (max(id_lsf_strat,id_lcf_strat,id_mfls_strat) > 0) then
       allocate(lsf_strat(size(T,1),size(T,2),size(T,3)))
                lsf_strat = 0.
       allocate(lcf_strat(size(T,1),size(T,2),size(T,3)))
                lcf_strat = 0.
       allocate(mfls_strat(size(T,1),size(T,2),size(T,3)))
                mfls_strat = 0.
     endif

     if (allocated(qndt_cond))         deallocate (qndt_cond)
     if (allocated(qndt_evap))         deallocate (qndt_evap)
     if (allocated(qndt_fill))         deallocate (qndt_fill)
     if (allocated(qndt_destr))        deallocate (qndt_destr)
     if (allocated(qndt_super))        deallocate (qndt_super)
     if (max(id_qndt_cond,id_qn_cond_col) > 0) then
       allocate(qndt_cond(size(T,1),size(T,2),size(T,3)))
                qndt_cond       = 0.
     endif
     if (max(id_qndt_evap,id_qn_evap_col) > 0) then
       allocate(qndt_evap(size(T,1),size(T,2),size(T,3)))
                qndt_evap       = 0.
     endif
     if (max(id_qndt_fill,id_qn_fill_col,id_qldt_fill) > 0) then
       allocate(qndt_fill(size(T,1),size(T,2),size(T,3)))
                qndt_fill       = 0.
     endif
     if (max(id_qndt_destr,id_qn_destr_col) > 0) then
       allocate(qndt_destr(size(T,1),size(T,2),size(T,3)))
                qndt_destr      = 0.
     endif
     if (max(id_qndt_super,id_qn_super_col) > 0) then
       allocate(qndt_super(size(T,1),size(T,2),size(T,3)))
                qndt_super      = 0.
     endif

     if (allocated(qldt_cond))         deallocate (qldt_cond)
     if (allocated(qldt_evap))         deallocate (qldt_evap)
     if (allocated(qldt_eros))         deallocate (qldt_eros)
     if (allocated(qldt_berg))         deallocate (qldt_berg)
     if (allocated(qldt_freez))        deallocate (qldt_freez)
     if (allocated(qldt_rime))         deallocate (qldt_rime)
     if (allocated(qldt_accr))         deallocate (qldt_accr)
     if (allocated(qldt_auto))         deallocate (qldt_auto)
     if (allocated(qldt_fill))         deallocate (qldt_fill)
     if (allocated(qldt_destr))        deallocate (qldt_destr)
     if (allocated(rain_evap))         deallocate (rain_evap)
     if (allocated(liq_adj))           deallocate (liq_adj)
     if (allocated(qidt_dep))          deallocate (qidt_dep)
     if (allocated(qidt_eros))         deallocate (qidt_eros)
     if (allocated(qidt_fall))         deallocate (qidt_fall)
     if (allocated(qidt_fill))         deallocate (qidt_fill)
     if (allocated(qidt_subl))         deallocate (qidt_subl)
     if (allocated(qidt_melt))         deallocate (qidt_melt)
     if (allocated(qidt_destr))        deallocate (qidt_destr)
     if (allocated(snow_melt))         deallocate (snow_melt)
     if (allocated(ice_adj))           deallocate (ice_adj)
     if (allocated(snow_subl))         deallocate (snow_subl)
     if (allocated(qadt_lsform))       deallocate (qadt_lsform)
     if (allocated(qadt_lsdiss))       deallocate (qadt_lsdiss)
     if (allocated(qadt_eros))         deallocate (qadt_eros)
     if (allocated(qadt_rhred))        deallocate (qadt_rhred)
     if (allocated(qadt_destr))        deallocate (qadt_destr)
     if (allocated(qadt_fill))         deallocate (qadt_fill)
     if (allocated(qadt_super))        deallocate (qadt_super)
     if (allocated(rain_cld_diag))     deallocate (rain_cld_diag)
     if (allocated(rain_clr_diag))     deallocate (rain_clr_diag)
     if (allocated(a_rain_cld_diag))   deallocate (a_rain_cld_diag)
     if (allocated(a_rain_clr_diag))   deallocate (a_rain_clr_diag)
     if (allocated(snow_cld_diag))     deallocate (snow_cld_diag)
     if (allocated(snow_clr_diag))     deallocate (snow_clr_diag)
     if (allocated(a_snow_cld_diag))   deallocate (a_snow_cld_diag)
     if (allocated(a_snow_clr_diag))   deallocate (a_snow_clr_diag)
     if (allocated(a_precip_cld_diag)) deallocate (a_precip_cld_diag)
     if (allocated(a_precip_clr_diag)) deallocate (a_precip_clr_diag)
     if (max(id_qldt_cond,id_ql_cond_col) > 0) then
       allocate(qldt_cond(size(T,1),size(T,2),size(T,3)))
                qldt_cond         = 0.
     endif
     if (max(id_qldt_evap,id_ql_evap_col) > 0) then
       allocate(qldt_evap(size(T,1),size(T,2),size(T,3)))
                qldt_evap         = 0.
     endif
     if (max(id_qldt_eros,id_ql_eros_col) > 0) then
       allocate(qldt_eros(size(T,1),size(T,2),size(T,3)))
                qldt_eros         = 0.
     endif
     if (max(id_qldt_berg,id_ql_berg_col) > 0) then
       allocate(qldt_berg(size(T,1),size(T,2),size(T,3)))
                qldt_berg         = 0.
     endif
     if (max(id_qldt_freez,id_ql_freez_col) > 0) then
       allocate(qldt_freez(size(T,1),size(T,2),size(T,3)))
                qldt_freez        = 0.
     endif
     if (max(id_qldt_rime,id_ql_rime_col) > 0) then
       allocate(qldt_rime(size(T,1),size(T,2),size(T,3)))
                qldt_rime         = 0.
     endif
     if (max(id_qldt_accr,id_ql_accr_col) > 0) then
       allocate(qldt_accr(size(T,1),size(T,2),size(T,3)))
                qldt_accr         = 0.
     endif
     if (max(id_qldt_auto,id_ql_auto_col) > 0) then
       allocate(qldt_auto(size(T,1),size(T,2),size(T,3)))
                qldt_auto         = 0.
     endif
     if (max(id_qldt_fill,id_ql_fill_col) > 0) then
       allocate(qldt_fill(size(T,1),size(T,2),size(T,3)))
                qldt_fill         = 0.
     endif
     if (max(id_qldt_destr,id_ql_destr_col) > 0) then
       allocate(qldt_destr(size(T,1),size(T,2),size(T,3)))
                qldt_destr        = 0.
     endif

     if (max(id_rain_evap,id_rain_evap_col) > 0) then
       allocate(rain_evap(size(T,1),size(T,2),size(T,3)))
                rain_evap         = 0.
     endif
     if (max(id_liq_adj,id_liq_adj_col,id_ice_adj,id_ice_adj_col)  > 0) then
       allocate(liq_adj(size(T,1),size(T,2),size(T,3)))
                liq_adj           = 0.
     endif
     if (max(id_snow_melt,id_snow_melt_col) > 0) then
       allocate(snow_melt(size(T,1),size(T,2),size(T,3)))
                snow_melt         = 0.
     endif
     if (max(id_ice_adj,id_ice_adj_col) > 0) then
       allocate(ice_adj(size(T,1),size(T,2),size(T,3)))
                ice_adj           = 0.
     endif
     if (max(id_snow_subl,id_snow_subl_col) > 0) then
       allocate(snow_subl(size(T,1),size(T,2),size(T,3)))
                snow_subl         = 0.
     endif

     if (max(id_qidt_dep,id_qi_dep_col) > 0) then
       allocate(qidt_dep(size(T,1),size(T,2),size(T,3)))
                qidt_dep          = 0.
     endif
     if (max(id_qidt_eros,id_qi_eros_col) > 0) then
       allocate(qidt_eros(size(T,1),size(T,2),size(T,3)))
                qidt_eros         = 0.
     endif
     if (max(id_qidt_fall,id_qi_fall_col) > 0) then
       allocate(qidt_fall(size(T,1),size(T,2),size(T,3)))
                qidt_fall         = 0.
     endif
     if (max(id_qidt_fill,id_qi_fill_col) > 0) then
       allocate(qidt_fill(size(T,1),size(T,2),size(T,3)))
                qidt_fill         = 0.
     endif
     if (max(id_qidt_subl,id_qi_subl_col) > 0) then
       allocate(qidt_subl(size(T,1),size(T,2),size(T,3)))
                qidt_subl         = 0.
     endif
     if (max(id_qidt_melt,id_qi_melt_col) > 0) then
       allocate(qidt_melt(size(T,1),size(T,2),size(T,3)))
                qidt_melt         = 0.
     endif
     if (max(id_qidt_destr,id_qi_destr_col) > 0) then
       allocate(qidt_destr(size(T,1),size(T,2),size(T,3)))
                qidt_destr        = 0.
     endif
     if (max(id_qadt_lsform,id_qa_lsform_col) > 0) then
       allocate(qadt_lsform(size(T,1),size(T,2),size(T,3)))
                qadt_lsform       = 0.
     endif
     if (max(id_qadt_lsdiss,id_qa_lsdiss_col) > 0) then
       allocate(qadt_lsdiss(size(T,1),size(T,2),size(T,3)))
                qadt_lsdiss       = 0.
     endif
     if (max(id_qadt_eros,id_qa_eros_col) > 0) then
       allocate(qadt_eros(size(T,1),size(T,2),size(T,3)))
                qadt_eros         = 0.
     endif
     if (max(id_qadt_rhred,id_qa_rhred_col) > 0) then
       allocate(qadt_rhred(size(T,1),size(T,2),size(T,3)))
                qadt_rhred        = 0.
     endif
     if (max(id_qadt_destr,id_qa_destr_col) > 0) then
       allocate(qadt_destr(size(T,1),size(T,2),size(T,3)))
                qadt_destr        = 0.
     endif
     if (max(id_qadt_fill,id_qa_fill_col) > 0) then
       allocate(qadt_fill(size(T,1),size(T,2),size(T,3)))
                qadt_fill         = 0.
     endif
     if (max(id_qadt_super,id_qa_super_col) > 0) then
       allocate(qadt_super(size(T,1),size(T,2),size(T,3)))
                qadt_super        = 0.
     endif

     if (id_rain_cld   > 0) then
       allocate(rain_cld_diag(size(T,1),size(T,2),size(T,3)+1))
                rain_cld_diag     = 0.
     endif
     if (id_rain_clr    > 0) then
       allocate(rain_clr_diag(size(T,1),size(T,2),size(T,3)+1))
                rain_clr_diag     = 0.
     endif
     if (id_a_rain_cld  > 0) then
       allocate(a_rain_cld_diag(size(T,1),size(T,2),size(T,3)+1))
                a_rain_cld_diag   = 0.
     endif
     if (id_a_rain_clr  > 0) then
       allocate(a_rain_clr_diag(size(T,1),size(T,2),size(T,3)+1))
                a_rain_clr_diag   = 0.
     endif
     if (id_snow_cld    > 0) then
       allocate(snow_cld_diag(size(T,1),size(T,2),size(T,3)+1))
                snow_cld_diag     = 0.
     endif
     if (id_snow_clr    > 0) then
       allocate(snow_clr_diag(size(T,1),size(T,2),size(T,3)+1))
                snow_clr_diag     = 0.
     endif
     if (id_a_snow_cld  > 0) then
       allocate(a_snow_cld_diag(size(T,1),size(T,2),size(T,3)+1))
                a_snow_cld_diag   = 0.
     endif
     if (id_a_snow_clr  > 0) then
       allocate(a_snow_clr_diag(size(T,1),size(T,2),size(T,3)+1))
                a_snow_clr_diag   = 0.
     endif
     if (id_a_precip_cld> 0) then
       allocate(a_precip_cld_diag(size(T,1),size(T,2),size(T,3)+1))
                a_precip_cld_diag = 0.
     endif
     if (id_a_precip_clr> 0) then
       allocate(a_precip_clr_diag(size(T,1),size(T,2),size(T,3)+1))
                a_precip_clr_diag = 0.
     endif

!-----------------------------------------------------------------------
!
!       initialize select variables to zero. The variables reset
!       are:
!
!       (1) changes of prognostic variables
!
!       (2) variables dealing with the rain/snow fluxes. 
!
!       (3) qa_mean of the level above the top level.
!        
!       (4) diagnostic output fields

        ST = 0.
        SQ = 0.
        SL = 0.
        SI = 0.
        SA = 0.
        if (present(SN)) SN = 0.
   
        rain_cld   = 0.
        rain_clr   = 0.
        a_rain_cld = 0.
        a_rain_clr = 0.
        snow_cld   = 0.
        snow_clr   = 0.
        a_snow_clr = 0.
        a_snow_cld = 0.
        
        qa_mean_lst= 0.

        dcond_ls      = 0.
        dcond_ls_ice  = 0.
        qcg           = 0.
        qcg_ice       = 0.
        
                     
!-----------------------------------------------------------------------
!
!       Determine dimensions of slab

        idim = SIZE(T,1)
        jdim = SIZE(T,2)
        kdim = SIZE(T,3)
        
!-----------------------------------------------------------------------
!
!       compute inverse time step

        inv_dtcloud = 1.0 / dtcloud

!-----------------------------------------------------------------------
!
!       Calculate saturation specific humidity and its temperature 
!       derivative, and thermal conductivity plus vapor diffusivity
!       factor.
!
!       These are calculated according to the formulas:
!
!   (1)  qs   = d622*esat/ [pfull  -  (1.-d622)*esat]
!
!   (2) dqsdT = d622*pfull*(desat/dT)/[pfull-(1.-d622)*esat]**2.
!
!   (3) gamma = (L/cp) * dqsdT
!       
!       where d622 = rdgas/rvgas; esat = saturation vapor pressure;
!       and desat/dT is the temperature derivative of esat.
!       Note that in the calculation of gamma, 
!
!            {             hlv          for T > tfreeze             }
!       L =  { 0.05*(T-tfreeze+20.)*hlv + 0.05*(tfreeze-T)*hls      }
!            {                          for tfreeze-20.< T < tfreeze}
!            {             hls          for T < tfreeze-20.         }
!
!       This linear form is chosen because at tfreeze-20. es = esi, and
!       at tfreeze, es = esl, with linear interpolation in between.
!
!       The conductivity/diffusivity factor, A_plus_B is given by:
!
!   (4) A_plus_B =   { (hlv/Ka/T)*((hlv/rvgas/T)-1.) } + 
!
!                    { (rvgas*T/chi*esat) }
!
!       where Ka is the thermal conductivity of air = 0.024 J/m/s/K
!       and chi is the diffusitivy of water vapor in air which is
!       given by
!
!   (5) chi = 2.21 E-05 (m*m)/s  * (1.E+05)/pfull
!
!       where p is the pressure in Pascals.
!    
!
!       Note that qs, dqsdT, and gamma do not have their proper values
!       until all of the following code has been executed.  That
!       is qs and dqsdT are used to store intermediary results
!       in forming the full solution.

        !calculate water saturated vapor pressure from table
        !and store temporarily in the variable gamma
        !calculate qs and dqsdT
        if (do_pdf_clouds) then 
             call compute_qs( T-((hlv*ql+hls*qi)/cp_air), pfull, qs, &
                             dqsdT=dqsdT, esat=gamma )
        else
             call compute_qs( T, pfull, qs, dqsdT=dqsdT, esat=gamma )
        end if
                     
        !compute A_plus_B
        A_plus_B = ( (hlv/0.024/T) * ((hlv/rvgas/T)-1.) ) +            &
           (rvgas*T*pfull/2.21/gamma)  
         
        !calculate gamma
        if (do_pdf_clouds) then
        gamma = dqsdT *(min(1.,max(0.,0.05*(T-((hlv*ql+hls*qi)/cp_air) &
                                             -tfreeze+20.)))*hlv +     &
                        min(1.,max(0.,0.05*(tfreeze -T+((hlv*ql+hls*qi)&
                                              /cp_air)   )))*hls)/cp_air
        else
        gamma = dqsdT *(min(1.,max(0.,0.05*(T-tfreeze+20.)))*hlv +     &
                        min(1.,max(0.,0.05*(tfreeze -T   )))*hls)/cp_air
        end if             
!-----------------------------------------------------------------------
!
!       Calculate air density

!       airdens = pfull / (rdgas * T * (1. + d608*qv  - ql - qi) )
        airdens = pfull / (rdgas * T * (1.   - ql - qi) )
        where (qrat .gt. 0.) 
             airdens = pfull / (rdgas * T *(1.+(d608*qv/qrat)-ql-qi) )
        end where

!-----------------------------------------------------------------------
!
!       Assign cloud droplet number based on land or ocean point.
        
        N = N_land*LAND + N_ocean*(1.-LAND)

!---------------------------------------------------------------------
!   call aerosol_effects to include impact of aerosols on the cloud
!   droplet number and the bergeron process, if these effects activated.
!---------------------------------------------------------------------
        if (do_liq_num .or. do_dust_berg) then
       call aerosol_effects (is, js, Time, phalf, airdens, T, &
                            concen_dust_sub, totalmass1, Aerosol, mask)
        endif


!-----------------------------------------------------------------------
!
!       Is a sub-vertical grid scale distribution going to be neededed?  
!       If yes, then do ppm fits
!
        if (do_pdf_clouds) then
        
        !initialize quantities
        do j = 1, kdim
             delp(:,:,j) = phalf(:,:,j+1)-phalf(:,:,j)
        enddo     
        qta4(1,:,:,:) = max(qmin,qv+ql+qi)
        qtqsa4(1,:,:,:) = qta4(1,:,:,:)-qs
        
        if (nsublevels.gt.1) then
            do id = 1,idim
                call ppm2m_sak(qta4(:,id,:,:),delp(id,:,:),kdim,kmap,1,jdim,0,kord)
                call ppm2m_sak(qtqsa4(:,id,:,:),delp(id,:,:),kdim,kmap,1,jdim,0,kord)
            enddo                
        else
            qta4(2,:,:,:) = qta4(1,:,:,:)
            qta4(3,:,:,:) = qta4(1,:,:,:)
            qta4(4,:,:,:) = 0.
            qtqsa4(2,:,:,:) = qtqsa4(1,:,:,:)
            qtqsa4(3,:,:,:) = qtqsa4(1,:,:,:)
            qtqsa4(4,:,:,:) = 0.   
        end if

        end if  !end of do_pdf_clouds section

!rab - statements moved outside of large loop
!      they have no bearing on the overall cloud physics
!      they are merely diagnostic values
!
     if (.not. do_pdf_clouds) then

      if (max(id_qadt_fill,id_qa_fill_col) > 0) then
        where (qa .le. qmin) 
          qadt_fill = -qa * inv_dtcloud
        endwhere
      endif

      if (max(id_qidt_fill,id_qi_fill_col) > 0) then
        where (qi.le.qmin .or. qa.le.qmin) 
          qidt_fill = -qi * inv_dtcloud
        endwhere
      endif

        if (.not. do_liq_num) then
          N3D = 0.
          if (max(id_qldt_fill,id_ql_fill_col) > 0) then
            where (ql .le. qmin .or. qa .le. qmin) 
              qldt_fill = -ql * inv_dtcloud
            endwhere
          endif
        else
          N3D = qn*airdens*1.e-6
          if (id_debug1 > 0) debug1 = min(qa,1.)
          do j=1,kdim
           do k=1,jdim
            do i=1,idim
             if (ql(i,k,j).le.qmin .or. qa(i,k,j).le.qmin .or. qn(i,k,j).le.qmin) then
              N3D(i,k,j) = 0.
              if (max(id_qldt_fill,id_ql_fill_col) > 0) qldt_fill(i,k,j) = -ql(i,k,j) * inv_dtcloud
              if (max(id_qndt_fill,id_qn_fill_col) > 0) qndt_fill(i,k,j) = -qn(i,k,j) * inv_dtcloud
              if (id_debug1 > 0) debug1(i,k,j) = 0.
             endif
            enddo
           enddo
          enddo
        endif

     else

      if (max(id_qidt_fill,id_qi_fill_col) > 0) then 
        where (qi .le. qmin) 
          qidt_fill = -qi * inv_dtcloud
        endwhere
      endif

        if (.not. do_liq_num) then
          N3D = 0.
          if (max(id_qldt_fill,id_ql_fill_col) > 0) then
            where (ql .le. qmin) 
              qldt_fill = -ql * inv_dtcloud
            endwhere
          endif
        else
          N3D = qn*airdens*1.e-6
          if (id_debug1   > 0) debug1 = min(qa,1.)
          do j=1,kdim
           do k=1,jdim
            do i=1,idim
             if (ql(i,k,j).le.qmin .or. qn(i,k,j).le.qmin) then
              N3D(i,k,j) = 0.
              if (max(id_qldt_fill,id_ql_fill_col) > 0) qldt_fill(i,k,j) = -ql(i,k,j) * inv_dtcloud
! Should this just be id_qndt_fill  + id_qn_fill_col ?
!ORIGINAL:    if (id_qldt_fill  > 0) &
              if (max(id_qldt_fill,id_qndt_fill,id_qndt_fill) > 0) &
                            qndt_fill(i,k,j) = -qn(i,k,j) * inv_dtcloud
              if (id_debug1    > 0) debug1(i,k,j) = 0.
             endif
            enddo
           enddo
          enddo
        endif
     endif
!rab - end of statements moved outside large loop

     call mpp_clock_end(sc_pre_loop)
     call mpp_clock_begin(sc_loop)
!-----------------------------------------------------------------------
!
!       Enter the large loop over vertical levels.  Level 1 is the top
!       level of the column and level kdim is the bottom of the model.
!       If MASK is present, each column may not have kdim valid levels.
!
        rain3d = 0.
        snow3d = 0.
        snowclr3d = 0.

        DO j = 1, kdim

       
!-----------------------------------------------------------------------
!
!       Calculate pressure thickness of level and relative humidity 

        !calculate difference in pressure across the grid box divided
        !by gravity
        deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
         
        !calculate GRID box mean relative humidity 
        !       U = min(max(0.,qv(:,:,j)/qs(:,:,j)),1.)
 
        U = 0.
        where (qrat(:,:,j) .gt. 0.)
           U = min(max(0.,(qv(:,:,j)/(qrat(:,:,j)*qs(:,:,j)))),1.)
        end where
        
!-----------------------------------------------------------------------
!
!       Account for the fact that other processes may have created
!       negative tracer or extremely small values of tracer fields.
!       The general reason for the extremely small values of the 
!       tracer fields is due to vertical diffusion, advection of 
!       condensate or cumulus induced subsidence (also a form of 
!       advection) of condensate.
!
!       In this step any values of the prognostic variables which are 
!       less than qmin are reset to zero, while conserving total 
!       moisture.
!
!       Note that this is done slightly different for the Tiedtke
!       cloud fraction than it is for pdf clouds. In the former, 
!       the filling requires that cloud liquid, cloud ice, and 
!       cloud fraction are greater than qmin. For PDF clouds, 
!       cloud fraction need not be considered since it is diagnosed
!       below from the PDF clouds
!
    if (.not. do_pdf_clouds) then

        do k=1,jdim
         do i=1,idim
          qa_upd(i,k) = qa(i,k,j)      
          qi_upd(i,k) = qi(i,k,j)      
          ql_upd(i,k) = ql(i,k,j)      

          if (qa(i,k,j) .le. qmin) then
             SA(i,k,j)   = SA(i,k,j) - qa(i,k,j)
             qa_upd(i,k) = 0.
          end if
!       Correct for qa > RH, which is not permitted under the 
!       assumption that the cloudy air is saturated and the temperature 
!       inside and outside of the cloud are about the same.
          if (qa_upd(i,k) .gt. U(i,k)) then
             if (max(id_qadt_rhred,id_qa_rhred_col) > 0 ) qadt_rhred(i,k,j) = (qa_upd(i,k)-U(i,k)) * inv_dtcloud
             SA(i,k,j)   = SA(i,k,j) + U(i,k) - qa_upd(i,k)
             qa_upd(i,k) = U(i,k)      
          end if
        
          if (.not. do_liq_num) then
            if (ql(i,k,j) .le. qmin .or. qa(i,k,j) .le. qmin) then
             SL(i,k,j)   = SL(i,k,j) - ql(i,k,j)
             SQ(i,k,j)   = SQ(i,k,j) + ql(i,k,j)
             ST(i,k,j)   = ST(i,k,j) - hlv*ql(i,k,j)/cp_air
             ql_upd(i,k) = 0.
            end if
          else
            qn_upd(i,k) = qn(i,k,j)
            if (ql(i,k,j) .le. qmin .or. qa(i,k,j) .le. qmin .or. qn(i,k,j) .le. qmin) then
             SL(i,k,j)   = SL(i,k,j) - ql(i,k,j)
             SQ(i,k,j)   = SQ(i,k,j) + ql(i,k,j)
             ST(i,k,j)   = ST(i,k,j) - hlv*ql(i,k,j)/cp_air
             SN(i,k,j)   = SN(i,k,j) - qn(i,k,j)
             ql_upd(i,k) = 0.
             qn_upd(i,k) = 0.
            endif
          endif

          if (qi(i,k,j) .le. qmin .or. qa(i,k,j) .le. qmin) then
             SI(i,k,j)   = SI(i,k,j) - qi(i,k,j)
             SQ(i,k,j)   = SQ(i,k,j) + qi(i,k,j)
             ST(i,k,j)   = ST(i,k,j) - hls*qi(i,k,j)/cp_air
             qi_upd(i,k) = 0.
          endif
         enddo
        enddo
        
    else

        do k=1,jdim
         do i=1,idim
          ql_upd(i,k) = ql(i,k,j)
          qi_upd(i,k) = qi(i,k,j)

          if (.not. do_liq_num) then
           if (ql(i,k,j) .le. qmin) then
             SL(i,k,j)   = SL(i,k,j) - ql(i,k,j)
             SQ(i,k,j)   = SQ(i,k,j) + ql(i,k,j)
             ST(i,k,j)   = ST(i,k,j) - hlv*ql(i,k,j)/cp_air
             ql_upd(i,k) = 0.
           endif
          else
           qn_upd(i,k) = qn(i,k,j)
           if (ql(i,k,j) .le. qmin .or. qn(i,k,j) .le. qmin) then
             SL(i,k,j)   = SL(i,k,j) - ql(i,k,j)
             SQ(i,k,j)   = SQ(i,k,j) + ql(i,k,j)
             ST(i,k,j)   = ST(i,k,j) - hlv*ql(i,k,j)/cp_air
             SN(i,k,j)   = SN(i,k,j) - qn(i,k,j)
             ql_upd(i,k) = 0.
             qn_upd(i,k) = 0.
           endif
          endif

          if (qi(i,k,j) .le. qmin) then
             SI(i,k,j)   = SI(i,k,j) - qi(i,k,j)
             SQ(i,k,j)   = SQ(i,k,j) + qi(i,k,j)
             ST(i,k,j)   = ST(i,k,j) - hls*qi(i,k,j)/cp_air
             qi_upd(i,k) = 0.
          endif
         end do
        end do
        
    end if !for do_pdf_clouds
        
        
!----------------------------------------------------------------------!
!                                                                      !
!                                                                      !
!                                                                      !
!                 NON-CONVECTIVE CONDENSATION                          !
!                                                                      !
!                                                                      !
!                                                                      !
!                         METHOD 1                                     !
!                                                                      !
!                                                                      !
!                  TIEDTKE (1993) CLOUD FRACTION                       !
!                                                                      !
!       ANALYTIC INTEGRATION OF SATURATED VOLUME FRACTION EQUATION     !
!                                                                      !
!                                                                      !
!
!       Do non-convective condensation following Tiedtke, pages 3044-5.
!       In this formulation stratiform clouds are only formed/destroyed 
!       when there is upward or downward motion to support/destroy it. 
!
!       The first step is to compute the change in qs due to large-
!       scale processes, dqs_ls.   In Tiedtke, it has contributions from 
!       large-scale uplift, convection induced compensating subsidence,
!       turbulence cooling and radiative cooling.  dqs_ls has the form:
!
!               (((omega+ grav*Mc)/airdens/cp)+radturbten)*dqsdT*dtcloud
!   (6) dqs_ls= --------------------------------------------------------
!                  1.  +   ( qa +  (da_ls/2.) ) * gamma
!
!       Here da_ls is the increase in cloud fraction due to non-
!       convective processes.  Because this increase is also a function
!       of dqs_ls, a quadratic equation must be solved for dqs_ls in
!       the case that da_ls is not equal to zero.
!
!       Note that if the PDF cloud scheme is active the Tiedtke large-
!       scale condensation is bypassed.

    if (.not.do_pdf_clouds) then

     do k=1,jdim
      do i=1,idim
        dqs_ls(i,k) =(((omega(i,k,j)+grav*Mc(i,k,j))/airdens(i,k,j)/cp_air)+&
                 radturbten2(i,k,j))*dtcloud*dqsdT(i,k,j)

        !compute pressure dependent U00 following ECMWF formula if 
        !desired
        U00p(i,k) = U00
        if (u00_profile) then
             if (pfull(i,k,j) .gt. 0.8*phalf(i,k,KDIM+1)) then
                    U00p(i,k) = U00 + (1.-U00)* &
                         (((pfull(i,k,j)-(0.8*phalf(i,k,KDIM+1))) &
                                    /    (0.2*phalf(i,k,KDIM+1)) )**2.)
             endif
        end if       

!ljd
!       modify u00p to account for humidity in convective system
!       See "Tiedtke u00 adjustment" notes, 10/22/02
!ljd
 
        u00p(i,k)=u00p(i,k)+(1.-u00p(i,k))*ahuco(i,k,j)

        if (dqs_ls(i,k).le.0. .and. U(i,k).ge.U00p(i,k) .and. qa_upd(i,k).lt.1.) then
             tmp1s = sqrt( (1.+qa_upd(i,k)*gamma(i,k,j))**2. - (1.-qa_upd(i,k)) * &
                    (1.-qa_upd(i,k))*gamma(i,k,j)*dqs_ls(i,k)/qs(i,k,j)/         &
                    max(1.-U(i,k),qmin) ) - (1.+qa_upd(i,k)*gamma(i,k,j))
             tmp1s = -1. * tmp1s / ((1.-qa_upd(i,k))*(1.-qa_upd(i,k))*gamma(i,k,j)/&
                    qs(i,k,j)/max(1.-U(i,k),qmin)/2.)
             dqs_ls(i,k) = min(tmp1s,dqs_ls(i,k)/(1.+0.5*(1.+qa_upd(i,k))*gamma(i,k,j)))
        else
             dqs_ls(i,k) = dqs_ls(i,k)/(1.+qa_upd(i,k)*gamma(i,k,j))
        endif
      
!       The next step is to compute the change in saturated volume
!       fraction due to non-convective condensation, da_ls.   This 
!       occurs in two conditions:
!
!       (a)  dqs_ls < 0. and U00 < U < 1., where U00 is the threshold
!            relative humidity for non-convective condensation. Note 
!            that if U is greater than or equal to 1., ideally qa = 1,
!            and da_ls = 0.  However this may not be the case for 
!            numerical reasons so this must be assured after analytic 
!            integration of the qa equation.
!
!            For these cases the change in saturated volume fraction is:
!
!   (7)      da_ls = - (1.-qa)*(1.-qa)*dqs_ls/2./qs/(1.-U)
!
!            This formula arises from the assumption that vapor is uni-
!            formly distributed in the range [qv_clr - (qs - qv_clr),qs]
!            where qv_clr is the amount of vapor in the unsaturated 
!            volume and is given from the following equation:
!
!   (8)      qv  =   qa * qs      +   (1.-qa) * qv_clr
!          
!            Implicit in equation (7) is the following assumption:
!            As qsat changes, the distribution of qv+ql+qi 
!            remains constant.  That is as qsat rises, portions where
!            qv+ql+qi > qsat+dqsat remain saturated.  This can only
!            occur if it is assumed that ql+qi evaporate-sublimate or
!            condense-deposit to keep qv = qsat. 
!
!       (b)  dqs_ls > 0.  Ideally some portion of the cloud should
!            evaporate however this is not accounted for at present.
!            

        !compute formula for da_ls
!       where (dqs_ls .le. 0. .and. U .ge. U00p)
!            da_ls = -0.5 * (1.-qa_upd) * (1.-qa_upd) * dqs_ls /       &
!             qs(:,:,j) / max(1.-U,qmin)
!       elsewhere
!            da_ls = 0.
!       end where 
 
        da_ls(i,k) = 0.
        if ((dqs_ls(i,k).le.0. .and. U(i,k).ge.U00p(i,k)) .and. &
              (qa_upd(i,k)+ahuco(i,k,j).le.1.)) then
             da_ls(i,k) = -0.5 * (1.-qa_upd(i,k)-ahuco(i,k,j)) * (1.-qa_upd(i,k)-    &
                ahuco(i,k,j))    * dqs_ls(i,k)/   qs(i,k,j) / max(1.-U(i,k),qmin)
        endif
      enddo
     enddo

!       Turbulent erosion of clouds
!
!       As in Tiedtke (1993) this is calculated using the eros_scale
!       parameter as:
!
!   (9) dql/dt    =  - qa * eros_scale * (qs - qv) * (ql/ ql+qi )
!
!  (10) dqi/dt    =  - qa * eros_scale * (qs - qv) * (qi/ ql+qi )
!
!  (11) dqa/dt    =  - qa * eros_scale * (qs - qv) * (qa/ ql+qi )
!
!       for which the erosion sink term (B in equation 13) is
!
!  (12) B = qa * eros_scale * (qs - qv) / (ql + qi)  
!
!
!       Theory for eros_scale
!
!       If eros_choice equals false, then a single erosion time scale
!       is used in all conditions (eros_scale).  If eros_choice equals
!       true then it is assumed that the timescale for turbulent 
!       evaporation is a function of the conditions in the grid box.  
!       Specifically, if the flow is highly turbulent then the scale is 
!       short, and eros_scale is large.  Likewise if convection is 
!       occurring, then it is assumed that the erosion term is larger 
!       than backround conditions. 
!
!       Here are the typical values for the timescales and the 
!       switches used:
!
!         Mixing type      eros_scale (sec-1)          Indicator
!       ----------------   ------------------     --------------------
!
!       Background            1.e-06              always present
!       Convective layers     5.e-06              Mc > Mc_thresh
!       Turbulent  layers     5.e-05              diff_t > diff_thresh
!

     do k=1,jdim
      do i=1,idim
        !Background erosion scale
        tmp2s = eros_scale

        !Do enhanced erosion in convective or turbulent layers?
        !
        !              IMPORTANT NOTE
        !                
        !Note that convection is considered first, so that if 
        !turbulence and convection occur in the same layer, the
        !erosion rate for turbulence is selected.                
        !
        
        if (eros_choice) then
             !Enhanced erosion in convective layers
             if (Mc(i,k,j) .gt. mc_thresh) tmp2s = eros_scale_c
        
             !Enhanced erosion in turbulent layers
             if (diff_t(i,k,j).gt.diff_thresh  .or.  &
                 diff_t(i,k,min(j+1,KDIM)).gt.diff_thresh) &
                   tmp2s = eros_scale_t
        end if   !for erosion choice

        if (ql_upd(i,k) .gt. qmin .or. qi_upd(i,k) .gt. qmin) then
          D_eros(i,k)=qa_upd(i,k) * tmp2s * dtcloud * qs(i,k,j) *      &
                      (1.-U(i,k)) / (qi_upd(i,k) + ql_upd(i,k))
          if (pfull(i,k,j) .gt. 400.e02) then
             D_eros(i,k)=D_eros(i,k)+efact*D_eros(i,k)*((pfull(i,k,kdim)-  &
                       pfull(i,k,j))/(pfull(i,k,kdim)-400.e02))
          else
             D_eros(i,k)=D_eros(i,k)+efact*D_eros(i,k)
          endif
        else
          D_eros(i,k) = 0.
        endif
      enddo
     enddo
     
!    
!       The next step is to analytically integrate the saturated volume
!       fraction equation.  This follows the Tiedtke approach
!
!       The qa equation is written in the form:
!
!  (13) dqa/dt    =   (1.-qa) * A   -  qa * B 
!
!       Note that over the physics time step, A, B are assumed to be 
!       constants.
!
!       Defining qa(t) = qa0 and qa(t+dtcloud) = qa1, the analytic
!       solution of the above equation is:
!
!  (14) qa1 = qaeq -  (qaeq - qa0) * exp (-(A+B)*dtcloud)
! 
!       where qaeq is the equilibrium cloud fraction that is approached
!       with an time scale of 1/(A+B),
!
!  (15) qaeq  =  A/(A+B)
!
!
!       To diagnose the magnitude of each of the right hand terms of
!       (13) integrated over the time step, define the average cloud
!       fraction in the interval t to t + dtcloud qabar as:
!
!  (16) qabar  = qaeq - [ (qa1-qa0) / ( dtcloud * (A+B) ) ]
! 
!       from which the magnitudes of the A and B terms integrated
!       over the time step are:
!
!       A * (1-qabar)    and    -B * (qabar)
!
!       Additional notes on this analytic integration:
!
!       1.   For large-scale cloud formation or destruction from 
!            the dqs_ls term the contributions to A or B are defined
!            from:
!
!  (19)      A_ls * (1. - qa) = da_ls / dtcloud      if da_ls >= 0.
! 
!  (20)      B_ls * qa        = da_ls / dtcloud      if da_ls < 0.
!
!       2.   Note that to reduce the number of variables, the following
!            equivalency exists:
!
!               Ql or Qi equation              Qa equation
!             --------------------         -------------------
! 
!                     C_dt                        A_dt
!                     D_dt                        B_dt
!                     qceq                        qaeq
!                     qcbar                       qabar
!                     qc1                         qa1
!                     qc0                         qa0
!
!       3.   Qa goes to zero only in the case of ql and qi less than or
!            equal to qmin; see 'cloud destruction code' near the end of 
!            this loop over levels.
!
     do k=1,jdim
      do i=1,idim
        !compute C_dt; This is assigned to the large-scale source term
        !following (18). Reset D_dt.
        C_dts = da_ls(i,k)/max((1.-qa_upd(i,k)),qmin)
        D_dts = D_eros(i,k)
  
        !do analytic integration      
        qc0s   = qa_upd(i,k)
        if ( (C_dts.gt.Dmin) .or. (D_dts.gt.Dmin) ) then
             qceqs  = C_dts  / (C_dts + D_dts)
             qc1s   = qceqs - (qceqs - qc0s) * exp ( -1.*(C_dts+D_dts) )
             qcbars = qceqs - ((qc1s - qc0s)/ (C_dts + D_dts))
        else
             qceqs  = qc0s   
             qc1s   = qc0s   
             qcbars = qc0s  
        endif

        !set total tendency term and update cloud fraction    
        if (limit_conv_cloud_frac) then
!RSH     limit cloud area to be no more than that which is not being
!        taken by convective clouds
          qc1s = MIN(qc1s, 1.0 -ahuco(i,k,j))
        endif
        SA(i,k,j)  = SA(i,k,j) + qc1s - qc0s
        qa_upd(i,k)     = qc1s
        
        if (max(id_qadt_lsform,id_qa_lsform_col) > 0) qadt_lsform(i,k,j) =  C_dts * (1.-qcbars) * inv_dtcloud 
        if (max(id_qadt_eros,id_qa_eros_col)  > 0) qadt_eros  (i,k,j) =  D_dts *     qcbars  * inv_dtcloud
        tmp5(i,k) = C_dts * (1.-qcbars)

!       The next step is to calculate the change in condensate
!       due to non-convective condensation, dcond_ls. Note that this is
!       not the final change but is used only to apportion condensate
!       change between phases. According to Tiedtke 1993 this takes the
!       form:
!
!  (21) dcond_ls = -1. * (qa +  0.5*da_ls) * dqs_ls
!
!       Here the 0.5*da_ls represents using a midpoint cloud fraction.
!       This is accomplished by using the variable qcbar.

        dcond_ls(i,k) = -1. * qcbars * dqs_ls(i,k)
      enddo
     enddo
            

!----------------------------------------------------------------------!
!                                                                      !
!                                                                      !
!                                                                      !
!                 NON-CONVECTIVE CONDENSATION                          !
!                                                                      !
!                                                                      !
!                                                                      !
!                         METHOD 2                                     !
!                                                                      !
!                                                                      !
!                STATISTICAL CLOUD FRACTION                            !
!                                                                      !
!                                                                      !

    else                   !for doing PDF cloud scheme
    

        !set Tiedtke erosion term to zero            
        D_eros = 0.
        
        !compute pdf cloud fraction and condensate
        ! 
        !Note that the SYMMETRIC beta distribution is used here.
        !
        !
        ! Initialize grid-box mean values of cloud fraction (qag),
        ! cloud condensate(qcg), and clear sky water vapor (qvg)

        qcg = 0.
        qvg = 0.
        qag = 0.
        
        !Create loop over sub-levels within a grid box
        do ns = 1, nsublevels
        
             !calculate normalized vertical level
             ! 0. = top of gridbox
             ! 1. = bottom of gridbox
        
             pnorm =  (real(ns) - 0.5 )/real(nsublevels)
        
             !First step is to calculating the minimum (qtmin)
             !of the total water distribution and 
             !the width of the qt distribution (deltaQ)
             !
             !For diagnostic variance this is set to (1.-qthalfwidth)*qtbar
             !and 2*qthalfwidth*qtbar, respectively, where qtbar is the
             !mean total water in the grid box.        
             !
             !

             qtbar = qta4(2,:,:,j)+pnorm*( (qta4(3,:,:,j)-qta4(2,:,:,j)) + &
                                       qta4(4,:,:,j)*(1-pnorm) )
             
             qtbar = max(qmin,qtbar)
             deltaQ = 2.*qthalfwidth*qtbar
             qtmin = (1.-qthalfwidth)*qtbar
        
             !From this the variable normalized saturation specific
             !humidity qs_norm is calculated.
             !
             !  qs_norm = (qs(Tl) - qtmin)/(qtmax-qtmin)
             !
             !          = 0.5  - (qtbar - qs(Tl))/deltaQ
             !
             !Note that if qs_norm > 1., the grid box is fully clear.
             !If qs_norm < 0., the grid box is fully cloudy.
        
             qs_norm = qtqsa4(2,:,:,j)+  &
                       pnorm*( (qtqsa4(3,:,:,j)-qtqsa4(2,:,:,j)) + &
                       qtqsa4(4,:,:,j)*(1-pnorm) )
      
             qs_norm = 0.5 - ( qs_norm/deltaQ )
             
             !Calculation of cloud fraction (qagtmp), cloud condensate 
             !(qcgtmp), and water vapor in clear air part of the grid 
             !box (qvgtmp)
             !
             !Formulas (from Tompkins, and personal derivations):
             !
             !  Define icbp  = incomplete_beta(qs_norm,p,q)
             !         icbp1 = incomplete_beta(qs_norm,p+1,q)
             !
             !  qagtmp = 1. - icbp
             !
             !  qcgtmp = aThermo * {  (qtbar-qtmin)*(1.-icbp1) - 
             !                       qs_norm*deltaQ*(1.-icbp ) }
             !
             !
             !  qvgtmp = qtmin + (p/(p+q))*(icbp1/icbp)*deltaQ
             !
             !  
             ! where aThermo = 1./(1.+(L/cp)*dqsdT)
             !
             ! note that in the qvg formula below the factor of 0.5
             ! is equal to (p/(p+q)).
             !

             do jd = 1,jdim
             do id = 1,idim
        
             if (qs_norm(id,jd).le.1.) then
                 
                 icbp = incomplete_beta(max(0.,qs_norm(id,jd)), &
                                      p = betaP    , q = betaP)
                 icbp1= incomplete_beta(max(0.,qs_norm(id,jd)), &
                                      p = betaP + 1, q = betaP)
                 qagtmps = 1.-icbp
                 qcgtmps = (qtbar(id,jd)-qtmin(id,jd))*(1.-icbp1)&
                               - qs_norm(id,jd)*deltaQ(id,jd)*(1.-icbp)    
                 qcgtmps = qcgtmps/(1.+gamma(id,jd,j))
                 qvgtmps = qtmin(id,jd) + &
                               0.5*(icbp1/max(icbp,qmin))*deltaQ(id,jd)
             
                 !bound very very small cloud fractions which may
                 !cause negative cloud condensates due to roundoff 
                 !errors or similar errors in the beta table lookup.
                 if((qagtmps.lt.0.).or.(qcgtmps.le.0.))then
                      qagtmps = 0.
                      qcgtmps = 0.
                      qvgtmps = qtbar(id,jd)
                 end if
                 
             else             
                 qagtmps = 0.
                 qcgtmps = 0.
                 qvgtmps = qtbar(id,jd)             
             end if
    
             !sum vertically
             !
             !note special averaging of clear-sky water vapor
             !this is weighting clear-sky relative humidity by the 
             !clear-sky fraction
         
             qag(id,jd) = qag(id,jd) + qagtmps
             qcg(id,jd) = qcg(id,jd) + qcgtmps
             qvg(id,jd) = qvg(id,jd)+(1.-qagtmps)*min(max(qvgtmps/max(qmin, &
                       (qtbar(id,jd)+((qs_norm(id,jd)-0.5)*deltaQ(id,jd)))),0.),1.)
        
             !compute grid-box average cloud fraction, cloud condensate
             !and water vapor
        
             if (nsublevels.gt.1 .and. ns.eq.nsublevels) then
                  qag(id,jd) = qag(id,jd) / real(nsublevels)
                  qcg(id,jd) = qcg(id,jd) / real(nsublevels)
             
                  !note special averaging of clear-sky water vapor
                  if ((1.-qag(id,jd)).gt.qmin) then
                      qvg(id,jd) =qvg(id,jd)/real(nsublevels)/&
                                  (1.-qag(id,jd))
                      qvg(id,jd) =qvg(id,jd) * qs(id,jd,j)
                  else
                      qvg(id,jd) = qs(id,jd,j)
                  end if
             elseif (nsublevels.eq.1) then
                  ! for nsublevels = 1, qag and qcg already hold their
                  ! final values
                  qvg(id,jd) = qvgtmps
             end if
             enddo
             enddo
             
        enddo !for number of sublevels loop
             
        !do adjustment of cloud fraction
!rab        qc0 = qa(:,:,j)
!rab        qc1 = qag

        !set total tendency term and update cloud fraction    
        SA(:,:,j)  = SA(:,:,j) + qag - qa(:,:,j)
        qa_upd     = qag

        if (max(id_qadt_lsform,id_qa_lsform_col) > 0) qadt_lsform(:,:,j) =  max(qag-qa(:,:,j),0.) * inv_dtcloud 
        if (max(id_qadt_lsdiss,id_qa_lsdiss_col) > 0) qadt_lsdiss(:,:,j) =  max(qa(:,:,j)-qag,0.) * inv_dtcloud

        !define da_ls and tmp5 needed when do_liq_num = .true. (cjg)
        da_ls = max(qag-qa(:,:,j),0.)
        tmp5 = max(qag-qa(:,:,j),0.)

        !compute large-scale condensation / evaporation
        dcond_ls = qcg - (ql_upd + qi_upd)

    end if    !for doing PDF clouds

!       The next step is the apportionment on the non-convective 
!       condensation between liquid and ice phases. Following the
!       suggestion of Rostayn (2000), all condensation at temperatures
!       greater than -40C is in liquid form as ice nuclei are generally 
!       limited in the atmosphere. The droplets may subsequently be 
!       converted to ice by the Bergeron-Findeisan mechanism.  
!
!       One problem with this formulation is that the proper saturation
!       vapor pressure is not used for cold clouds as it should be
!       liquid saturation in the case of first forming liquid, but
!       change to ice saturation as the cloud glaciates.  The current
!       use of ice saturation beneath -20C thus crudely mimics the
!       result that nearly all stratiform clouds are glaciated for
!       temperatures less than -15C.
!
!       In the case of large-scale evaporation (dcond_ls<0.), it is
!       assumed that cloud liquid will evaporate faster than cloud
!       ice because if both are present in the same volume the
!       saturation vapor pressure over the droplet is higher than 
!       that over the ice crystal.
!
!       The fraction of large-scale condensation that is liquid
!       is stored in the temporary variable tmp1.   

        do k=1,jdim
         do i=1,idim
          !assume liquid fractionation 
          tmp1s = 1.

          if (dcond_ls(i,k) .ge. 0.) then

           !For cases of cloud condensation where temperatures are
           !less than -40C create only ice
           if (T(i,k,j) .lt. tfreeze-40.) then
             tmp1s = 0.
           endif

          else

           if (qi_upd(i,k).gt.qmin) then

            if (ql_upd(i,k).gt.qmin) then
             !For cases of cloud evaporation of mixed phase clouds
             !set liquid evaporation to preferentially occur first
             tmp1s = min(-1.*dcond_ls(i,k),ql_upd(i,k))/max(-1.*dcond_ls(i,k),qmin)
            else
             !do evaporation of pure ice cloud
             tmp1s = 0.
            endif

           endif

          endif
          !calculate partitioning among liquid and ice to dcond_ls
          dcond_ls_ice(i,k) = (1.-tmp1s) * dcond_ls(i,k)
          dcond_ls(i,k)     = tmp1s * dcond_ls(i,k)      
         enddo
        enddo

!       The next step is to compute semi-implicit qa,ql,qi which are 
!       used in many of the formulas below.  This gives a somewhat 
!       implicitness to the scheme. In this calculation an estimate 
!       is made of what the cloud fields would be in the absence of 
!       cloud microphysics and cloud erosion.
!
!       In the case of the Tiedtke cloud scheme, the mean cloud 
!       condensate is incremented if large-scale condensation is 
!       occuring. For cloud fraction, the value from the analytic 
!       integration above is used.
!
!       For the statistical cloud scheme these are set equal to the
!       values diagnosed from the beta-distribution apart from the
!       corrections for mixed phase clouds.

        qa_mean = qa_upd
        if (.not. do_pdf_clouds) then
             ql_mean = ql_upd + max(dcond_ls    ,0.)        
             qi_mean = qi_upd + max(dcond_ls_ice,0.)
        else
             ql_mean = max(ql_upd + dcond_ls    ,qmin)
             qi_mean = max(qi_upd + dcond_ls_ice,qmin)  
        end if
        if (do_liq_num) then 
!yim's CCN activation
          do k = 1,jdim
            do i = 1,idim
              if ( da_ls(i,k) > 0.0 ) then
                up_strat = -1.*(((omega(i,k,j)+grav*Mc(i,k,j))/ &
                                           airdens(i,k,j)/grav) + &
                                  radturbten2(i,k,j)*cp_air/grav)
                          
!-->cjg: modification
!               call aer_ccn_act (T(i,k,j), pfull(i,k,j), up_strat, &
!                                 totalmass1(i,k,j,:), drop1(i,k))
                thickness = deltpg(i,k) / airdens(i,k,j)
                wp2 = 2.0/(3.0*0.548**2)* &
                      (0.5*(diff_t(i,k,j) + diff_t(i,k,min(j+1,KDIM)))/&
                                                         thickness )**2
                wp2 = MAX (wp2, var_limit**2)
!rab take care of it when writing diags....
!rab                debug2(i,k,j) = wp2**0.5
                if (id_debug2 > 0) debug2(i,k,j) = wp2
                if (id_debug3 > 0) debug3(i,k,j) = 1.
                call aer_ccn_act_wpdf (T(i,k,j), pfull(i,k,j), &
                                       up_strat, wp2,    &
                                       totalmass1(i,k,j,:), drop1(i,k))
                if (id_debug3 > 0) debug3(i,k,j) = drop1(i,k)
                if (id_debug2 > 0) debug2(i,k,j) = 1.
!<--cjg: end of modification
                qn_mean(i,k) = qn_upd(i,k) + max(tmp5(i,k),0.)*  &
                               drop1(i,k)*1.e6/airdens(i,k,j)
              else
                drop1(i,k) = 0.                
                qn_mean(i,k) = qn_upd(i,k)
              endif
            end do
          end do        
        endif


    
        !compute diagnostics for cloud fraction
        if (id_aall > 0) areaall(:,:,j) = qa_mean
!       if (id_aliq > 0 .or. id_rvolume > 0) then
        if (max(id_aliq,id_rvolume) > 0) then
              where (ql_mean .gt. qmin) arealiq(:,:,j) = qa_mean
        end if
!       if (id_aice > 0 .or. id_vfall > 0) then
        if (max(id_aice,id_vfall) > 0) then
              where (qi_mean .gt. qmin) areaice(:,:,j) = qa_mean
        end if              

  
!-----                                                            -----! 
!                                                                      !
!                                  END OF                              !
!                                                                      !
!                        NON-CONVECTIVE CONDENSATION                   !
!                                                                      !
!                                 SECTION                              !
!                                                                      !
!                                                                      !
!                                                                      !
!----------------------------------------------------------------------!



!-----------------------------------------------------------------------
!
!
!
!            TRANSFER OF RAIN FLUXES AND SNOW FLUXES BETWEEN 
!      
!           SATURATED AND UNSATURATED PORTIONS OF THE GRID BOX
!
!                           AT LAYER INTERFACES
!                           
!
!       Do transfer of rain and snow fluxes between clear and cloud 
!       portions of the grid box. This formulism follows the rain/snow
!       parameterization developed by Jakob and Klein (2000).  It 
!       treats the grid mean flux of rain and snow separately according 
!       to the portion that exists in unsaturated air and the portion 
!       that exists in saturated air.  At the top of each level, some 
!       precipitation that was in unsaturated air in the levels above 
!       may enter saturated air and vice versa. These transfers are 
!       calculated here under an assumption for the overlap between 
!       precipitation area and saturated area at the same and adjacent 
!       levels.
!
!       For rain, the area of the grid box in which rain in saturated 
!       air of the level above enters unsaturated air in the current 
!       level is called da_cld2clr and is given by 
!       maximum(a_rain_cld - qa , 0.) in the case of maximum overlap of
!       rain_cld and qa, but equal to a_rain_cld*(1.-qa) in the case of
!       random overlap of cloud and precipitation. The grid mean flux of 
!       rain which is transfered from saturated air to unsaturated air 
!       is given by rain_cld*da_cld2clr/a_rain_cld.
!
!       The area of the grid box where rain in unsaturated air of the
!       level above enters saturated air in the current level is
!       called da_clr2cld and is given by
!       maximum(0.,mininum(a_rain_clr,qa(j)-qa(j-1))) in the case of
!       maximum overlap of cloud and rain_clr, but equal to a_rain_clr*
!       qa for the case of random overlap of cloud and precipitation.  
!       The grid mean flux of rain transfered from unsaturated air to 
!       saturated air is given by rain_clr*da_clr2cld/a_rain_clr.
!
!       NOTE: the overlap assumption used is set by the namelist 
!             variable in cloud_rad
!
!       Overlap values are:      1  = maximum
!                                2  = random
!
!       If cloud_generator is on, the overlap choice is taken from
!       there, by computing a quantity alpha, which is weighting 
!       between maximum and random overlap solutions.
!
!                alpha = 1 ---> maximum,
!                alpha = 0 ---> random
!
!       alpha is stored in tmp3.
!       tmp1 has the maximum overlap solution
!       tmp2 has the random overlap solution
       
!
        if (cloud_generator_on) then
             if (j.gt.1) then
                  tmp3 = compute_overlap_weighting(qa_mean_lst,qa_mean,&
                         pfull(:,:,j-1),pfull(:,:,j))
                  tmp3 = min(1.,max(0.,tmp3))       
             else
                  tmp3 = 0.0
             end if
        end if      
!
!
!       Rain transfers are done first
!

        call cloud_clear_xfer (tmp3, qa_mean, qa_mean_lst, a_rain_clr, a_rain_cld, rain_clr, rain_cld)
!
!       Snow transfers are done second, in a manner exactly like that
!       done for the rain fluxes
!

        call cloud_clear_xfer (tmp3, qa_mean, qa_mean_lst, a_snow_clr, a_snow_cld, snow_clr, snow_cld)

   
               
!-----------------------------------------------------------------------
!
!
!                        MELTING OF CLEAR SKY SNOW FLUX
!
!
!       Melting of falling ice to rain occurs when T > tfreeze. The 
!       amount of melting is limited to the melted amount that would 
!       cool the temperature to tfreeze.
!
!       In the snowmelt bug version, the temperature of melting was 
!       tfreeze + 2. like the original Tiedtke (1993) paper, instead of 
!       tfreeze.

        snow_fact=0.
        if (do_old_snowmelt) snow_fact=2.
     do k=1,jdim
      do i=1,idim
        !compute grid mean change in snow flux to cool the
        !grid box to tfreeze and store in temporary variable tmp1
        tmp1s = cp_air*(T(i,k,j)-tfreeze-snow_fact)*deltpg(i,k)*inv_dtcloud/hlf
        
        ! If snow_clr > tmp1, then the amount of snow melted is
        ! limited to tmp1, otherwise melt snow_clr.  The amount
        ! melted is stored in tmp2
        tmp2s = max(min(snow_clr(i,k),tmp1s),0.)     

        ST(i,k,j) = ST(i,k,j) - hlf*tmp2s*dtcloud/deltpg(i,k)/cp_air                
        rain_clr(i,k)  = rain_clr(i,k) + tmp2s
        
        !raise a_rain_clr to a_snow_clr IF AND only IF melting occurs
        !and a_rain_clr < a_snow_clr
        if (tmp2s .gt. 0. .and. a_snow_clr(i,k) .gt. qmin)  &
             a_rain_clr(i,k) = max(a_rain_clr(i,k),a_snow_clr(i,k))

        ! If all of the snow has melted, then zero out a_snow_clr
        if (snow_clr(i,k).lt.tmp1s .and. a_snow_clr(i,k).gt.qmin) then
             snow_clr(i,k) = 0.
             a_snow_clr(i,k) = 0.
        else
             snow_clr(i,k) = snow_clr(i,k) - tmp2s          
        endif

        if (max(id_snow_melt,id_snow_melt_col) > 0) snow_melt(i,k,j) = tmp2s/deltpg(i,k)             
             
!-----------------------------------------------------------------------
!
!
!                        MELTING OF CLOUDY SKY SNOW FLUX
!
!
!       Melting of falling ice to rain occurs when T > tfreeze. The 
!       amount of melting is limited to the melted amount that would 
!       cool the temperature to tfreeze.
!

        if (.not.do_old_snowmelt) then

        !compute grid mean change in snow flux to cool the
        !grid box to tfreeze and store in temporary variable tmp1
        !
        !note that tmp1 already has the value of this variable 
        !from the clear-sky melt calculation, so one does not need
        !to repeat the calculation here.
        !
        !However, note that clear-sky snow melt may have already 
        !reduced the temperature of the grid box - this snow melt is in 
        !variable tmp2 from lines above. Thus the amount that one
        !can melt is less.
        
        tmp1s = tmp1s - tmp2s
        
        ! If snow_cld > tmp1, then the amount of snow melted is
        ! limited to tmp1, otherwise melt snow_cld.  The amount
        ! melted is stored in tmp2
        tmp2s = max(min(snow_cld(i,k),tmp1s),0.)     

        ST(i,k,j) = ST(i,k,j) - hlf*tmp2s*dtcloud/deltpg(i,k)/cp_air                
        rain_cld(i,k)  = rain_cld(i,k) + tmp2s
        
        !raise a_rain_cld to a_snow_cld IF AND only IF melting occurs
        !and a_rain_cld < a_snow_cld
        if (tmp2s .gt. 0. .and. a_snow_cld(i,k) .gt. qmin) &
             a_rain_cld(i,k) = max(a_rain_cld(i,k),a_snow_cld(i,k))

        ! If all of the snow has melted, then zero out a_snow_cld
        if (snow_cld(i,k).lt.tmp1s .and. a_snow_cld(i,k).gt.qmin) then
             snow_cld(i,k) = 0.
             a_snow_cld(i,k) = 0.
        else
             snow_cld(i,k) = snow_cld(i,k) - tmp2s          
        endif

        if (max(id_snow_melt,id_snow_melt_col) > 0) snow_melt(i,k,j) =  snow_melt(i,k,j) + &
                                                tmp2s/deltpg(i,k)

        end if  !for snowmelt bugfix
       enddo
      enddo
                            
!----------------------------------------------------------------------!
!
!
!              COMPUTE SLOPE FACTOR FOR ICE MICROPHYSICS                  
!
!       [The following microphysics follows that of Rotstayn (1997)]
!       The number concentration of ice crystals of diameter D in the
!       SIZE interval D to D+dD is assumed to be 
!       distributed as in a Marshall Palmer distribution :
!
!  (22) N(D)dD = Nof * Exp( - lamda_f * D)
!
!       The slope factor and intercept are not assumed to be constant,
!       but the slope factor is
!
!  (23) lamda_f = 1.6X10^(3.+0.023(tfreeze-T))
!
!       Integration of (22) over all particle sizes with a constant
!       density of ice crystals , rho_ice, and assumed spherical shape
!       yields a relationship between the intercept parameter and qi
!
!  (24) Nof = airdens*qi_local*(lamda_f^4)/pi*rho_ice
!       
!
!       For the calculation of riming and sublimation of snow, 
!       lamda_f is needed, so it is calculated here.
!
!       Also qi_mean is updated here with the flux of ice that falls 
!       into the cloudy portion of the grid box from above. This permits
!       the Bergeron and riming process to know about the ice that falls
!       into the grid box in the same time step.

        !Increment qi_mean by the ice flux entering the
        !the grid box. To convert ice_flux to units of condensate by
        !multiply by dtcloud and dividing by the mass per unit area 
        !of the grid box. Implicit here is the assumption that the
        !ice entering the cloud will be spread instantaneously over
        !all of the cloudy area.
        qi_mean = qi_mean + snow_cld*dtcloud/deltpg        

        !snow falling into cloud reduces the amount that
        !falls out of cloud: a loss of cloud ice from settling
        !is defined to be positive
        if (max(id_qidt_fall,id_qi_fall_col) > 0) qidt_fall(:,:,j)= -1.*snow_cld/deltpg
         
        !compute lamda_f
        lamda_f = 1.6 * 10**(3.+0.023*(tfreeze-T(:,:,j)))
        

!----------------------------------------------------------------------!
!                                                                      !
!                                                                      !
!                                                                      !
!                       LIQUID PHASE MICROPHYSICS                      !
!                                                                      !
!                                 AND                                  !
!                                                                      !
!                  ANALYTIC INTEGRATION OF QL EQUATION                 !
!                                                                      !
!                                                                      !
!                                                                      !
!       Accretion
!
!       The parameterization of collection of cloud liquid drops by
!       rain drops follows the parameterization of Rotstayn (1997).
!       The parameterization starts with the continous-collection 
!       equation of drops by a rain drop of diameter D, falling with
!       speed V(D).   The fall speed of rain drops is taken from
!       Gunn and Kinzer(1949):
!
!  (25) V(D) = 141.4 (m**0.5,s-1) * sqrt(D) * (rho_ref/airdens)**0.5
!
!       where D is the radius of the rain drops in meters. Here
!       rho_ref is a reference air density.  This formula is generally
!       good for 1 mm < D < 4 mm.
!
!       The distribution of rain drops by SIZE follows a Marshall-
!       Palmer distribution:
!
!  (26) N(D) dD = Nor * Exp (- lamda *D)
!
!       where N(D)dD is the number of rain drops with SIZE D in the
!       interval D to D+dD, Nor is the intercept (assumed fixed at
!       8E+04 (1/m*m*m*m).  lamda is the slope intercept parameter
!       and with (21) it can be shown that lamda is a function of
!       the rain rate.
!
!       With these assumptions the local rate of accretion of cloud
!       liquid reduces to:
!
!  (27) dl/dt_local = - CB*Eco*((rain_rate_local/dens_h2o)**(7/9))*
!                        
!                       (rho_ref/airdens)**(1/9)   * ql_local
!
!       where CB is the accretion constant:
! 
!       CB = 65.772565 [(m)**(-7/9)] * [(s)**(-2/9)]
!
!       AND Eco is the collection efficiency of a cloud droplet by a 
!       rain droplet.   A good fit to the Table 8.2 of Rogers and Yau 
!       (1988) for rain drops between SIZE 1mm and 3mm is:
!
!  (28) Eco = rad_liq**2 / (rad_liq**2 + 20.5 microns**2) .
!
!       In generalizing to grid mean conditions (27) becomes:
!
!  (29) dl/dt = - (arain_cld/qa_mean) * CB * Eco * 
!
!                 [(rain_cld/a_rain_cld/dens_h2o)**(7/9)] * ql
!        
!       Note that the very weak dependence on air density is
!       neglected at this point.
!
!       The particle sizes are computed from the following equation
!
!  (30) rad_liq = (3*airdens*ql/(4*pi*liq_dens*qa*N)^(1/3)
!
!       
!       For numerical treatment we write (25) as:
!
!       dl/dt = - D_acc * l 
!
!       and if we do so:
!
!  (31) D_acc   =  (arain_cld/qa_mean) * CB * Eco * 
!
!                 [(rain_cld/a_rain_cld/dens_h2o)**(7/9)] 
!
!       In the work below, D_acc is added to D1_dt, the first processes
!       contributing to the depletion of cloud liquid in the analytic
!       integration.  D1_dt represents the conversion of liquid to rain.

        if (.not. do_liq_num) then
        !compute rad_liq.  The constant below is equal to  
        !1.E+06 * (3/4*pi)^(1/3), where the 1E+06 is
        !the factor to convert meters to microns.
        
          rad_liq= 620350.49 *( (airdens(:,:,j)*ql_mean/ &
                        max(qa_mean,qmin)/N/dens_h2o)**(1./3.))

        !do not let very small cloud fractions contribution to
        !autoconversion or accretion
          where (qa_mean .le. qmin) rad_liq = 0.
        else        
!yim The 1st place droplet number is used
          rad_liq= 620350.49 *( (ql_mean/max(qn_mean,qmin)/dens_h2o)**(1./3.))
          !do not let very small cloud fractions contribution to
          !autoconversion or accretion
          where (qa_mean .le. qmin .or. qn_upd .le.qmin) rad_liq = 0.
        endif
        
        if (id_rvolume > 0) rvolume(:,:,j) = rad_liq*arealiq(:,:,j)

        !compute accretion D term
        D1_dt =  dtcloud * 65.772565 * (a_rain_cld/max(qa_mean,qmin))* &
                 ( rad_liq*rad_liq / (rad_liq*rad_liq+20.5) ) *        &
                 ((rain_cld/max(a_rain_cld,qmin)/dens_h2o)**(7./9.))
            
        if (max(id_qldt_accr,id_ql_accr_col)  > 0) qldt_accr(:,:,j) = D1_dt
    
!       Autoconversion
!
!       The autoconversion parameterization follow that of Manton
!       and Cotton (1977).  This formula has been used in Chen and
!       Cotton (1987) and is used in the CSIRO GCM (Rotstayn 1997)
!       and the LMD GCM (Boucher, Le Treut and Baker 1995).  In this
!       formulation the time rate of change of grid mean liquid is
!
!  (32) dl/dt= -CA * qa * [(ql/qa)^(7/3)] * [(N*dens_h2o)^(-1/3)] 
!
!               * H(rad_liq - rthresh)
!
!       where N is the number of cloud droplets per cubic metre,
!       rthresh is a particle radius threshold needed to for autoconv-
!       ersion to occur, H is the Heaviside function, and CA is
!       a constant which is:
!
!  (33) CA =  0.104 * grav * Ec * (airdens)^(4/3) / mu 
!        
!       where grav is gravitational acceleration, Ec is the collection
!       efficiency, airdens is the density of air, and mu is the 
!       dynamic viscosity of air.   This constant is evaluated 
!       ignoring the temperature dependence of mu and with a fixed 
!       airdens of 1 kg/m3.
!
!       With   Ec = 0.55        (standard choice - see references)
!            grav = 9.81        m/(s*s)
!         airdens = 1.00        kg air/(m*m*m)
!              mu = 1.717  E-05 kg condensate/(m*s) 
!
!              CA = 32681. [(kg air)^(4/3)]/kg liq/m/s
!
!
!       For numerical treatment we write (32) as:
!
!       dl/dt = - D_aut * l 
!
!       and if we do so:
!
!  (34) D_aut   =   CA * [(N*dens_h2o)^(-1/3)] * [(ql/qa)^(4/3)] * &
!                   H(r-rthresh)
!
!       In the work below, D_aut is temporarily stored in the variable
!       tmp1 before being added to D1_dt.  D1_dt represents the 
!       conversion of liquid to rain.
!
!       Following Rotstayn, autoconversion is limited to the amount that
!       would reduce the local liquid cloud condensate to the critical
!       value at which autoconversion begins. This limiter is likely to
!       be invoked frequently and is computed from
!
!  (35) D_dt = log( (rad_liq/rthresh)**3. )
!
!       This limiter is stored in tmp2.
!
!
!
!       -------------------------------------------------
!
!       Khairoutdinov and Kogan (2000) Autoconversion
!
!       Reference: Khairoutdinov, M. and Y. Kogan, 2000: A new cloud 
!                  physics parameterization in a large-eddy simulation
!                  model of marine stratocumulus. Mon. Wea. Rev., 128,
!                  229-243.
!
!       If the namelist parameter use_kk_auto = true, then the 
!       Khairoutdinov and Kogan (KK) autoconversion parameterization
!       is used in place of the Manton and Cotton formula described
!       above.
!
!       In SI units this formula is:
!
!  (32A) dl/dt= -CA * qa * [(ql/qa)^(2.47)] * [(N)^(-1.79)] 
!
!
!       where N is the number of cloud droplets per cubic metre
!       and CA is a constant which is:
!
!  (33A) CA =  7.4188E+13 (kg condensate/kg air)**(-1.47)
!                         (# drops/meters**3)**(1.79)
!                         seconds**(-1) 
!        
!       For numerical treatment we write (32A) as:
!
!       dl/dt = - D_aut * l 
!
!       and if we do so:
!
!  (34A) D_aut   =   CA * [(N)^(-1.79)] * [(ql/qa)^(1.47)]
!

        if (do_liq_num) then
          if (use_kk_auto) then
!*************************yim's version based on Khairoutdinov and Kogan (2000)
!The second place N is used
          tmp1 = dtcloud * 1350. *  &
        (1.e-6*max(qn_mean*airdens(:,:,j),max(qa_mean,qmin)*N_min))**(-1.79)*  &
         (ql_mean)**(1.47)*max(qa_mean,qmin)**(0.32)
!         tmp1 = dtcloud * 1350. *  &
!                (1.e-6*max(qn_mean,N_min)*airdens(:,:,j))**(-1.79)*  &
!                (ql_mean)**(1.47)*max(qa_mean,qmin)**(0.32)
!**************************
          else
!yim fall back to M & C using qn
             !compute autoconversion sink as in (34)
             tmp1 = 32681. * dtcloud * ((max(qn_mean,qmin)*airdens(:,:,j)*dens_h2o)**(-1./3.))*       &
                       (ql_mean**(4./3.))/max(qa_mean,qmin)
  
             !compute limiter as in (35)
             tmp2 =max(3*log(max(rad_liq,qmin)/rthresh),0.)
  
             !limit autoconversion to the limiter
             tmp1 = min(tmp1,tmp2)
          endif
       else
        if ( use_kk_auto ) then
             tmp1 = 0.
             !compute autoconversion sink as in (34A)
             where (ql_mean.gt.qmin)
                  tmp1 = 7.4188E+13 * dtcloud *  (N**(-1.79))*         &
                    ((ql_mean/max(qa_mean,qmin))**(1.47))
             endwhere
        else
             !compute autoconversion sink as in (34)
             tmp1 = 32681. * dtcloud * ((N*dens_h2o)**(-1./3.))*       &
                    ((ql_mean/max(qa_mean,qmin))**(4./3.))
        
             !compute limiter as in (35)
             tmp2 =max(3*log(max(rad_liq,qmin)/rthresh),0.)

             !limit autoconversion to the limiter
             tmp1 = min(tmp1,tmp2)

        endif
        endif


        !add autoconversion to D1_dt
        D1_dt = D1_dt + tmp1

        !auto conversion will change a_rain_cld upto area of cloud
        where (tmp1 .gt. Dmin) a_rain_cld = qa_mean

        if (max(id_qldt_auto,id_ql_auto_col) > 0) qldt_auto(:,:,j) = tmp1        

        if ( id_autocv > 0 ) then
             where ( rad_liq .gt. rthresh ) areaautocv(:,:,j) = qa_mean       
        end if
        

!       Bergeron-Findeisan Process 
!
!       where ice and liquid coexist, the differential saturation
!       vapor pressure between liquid and ice phases encourages
!       the growth of ice crystals at the expense of liquid droplets.
!
!       Rotstayn (2000) derive an equation for the growth of ice by
!       starting with the vapor deposition equation for an ice crystal
!       and write it in terms of ice specific humidity as:
!
!                 {(Ni/airdens)**2/3}*7.8
!  (36) dqi/dt =  ------------------------  X [(esl-esi)/esi] X
!                 [rhoice**1/3]* A_plus_B
!
!                 ((max(qi,Mio*Ni/airdens))**(1/3))*
!
!       Here Ni is the ice crystal number which is taken from the 
!       parameterization of Meyers et al. :
!
!  (37) Ni = 1000 * exp( (12.96* [(esl-esi)/esi]) - 0.639 )
!
!       The use of the maximum operator assumed that there is a 
!       background ice crystal always present on which deposition can 
!       occur.  Mio is an initial ice crystal mass taken to be 10-12kg.
!
!       Figure 9.3 of Rogers and Yau (1998) shows the nearly linear
!       variation of [(esl-esi)/esi] from 0. at 273.16K to 0.5 at 
!       233.16K.  Analytically this is parameterized as (tfreeze-T)/80.
!
!
!       Generalizing (36) to grid mean conditions and writing it in 
!       terms of a loss of cloud liquid yields:
!
!                  (1000*exp((12.96*(tfreeze-T)/80)-0.639)/airdens)**2/3
!  (38) dql/dt = - ----------------------------------------------------- 
!                           [rhoice**1/3]* A_plus_B * ql
!
!       *qa*7.8*((max(qi/qa,Mio*Ni/airdens))**(1/3))*[(tfreeze-T)/80]*ql
!
!       Note that the density of ice is set to 700 kg m3 the value 
!       appropriate for pristine ice crystals.  This value is 
!       necessarily different than the value of ice used in the riming 
!       and sublimation part of the code which is for larger particles 
!       which have much lower densities.
        
        if (do_dust_berg) then
        crystal=0.
        do k = 1,jdim
                do i = 1,idim
                if ( (T(i,k,j) .lt. tfreeze) .and. (ql_mean(i,k) .gt. qmin)      &
                                        .and. (qa_mean(i,k) .gt. qmin))         then
                                Si0=1+0.0125*(tfreeze-T(i,k,j))
                                call Jhete_dep(T(i,k,j),Si0,concen_dust_sub(i,k,j),crystal(i,k))
                                if (id_debug4 > 0) debug4(i,k,j) = 1.                                      
                endif
                end do
          end do

         if (max(id_qndt_cond,id_qn_cond_col) > 0) qndt_cond(:,:,j) = crystal
         if (max(id_qndt_evap,id_qn_evap_col) > 0) then
           qndt_evap(:,:,j) = 0.
           where (T(:,:,j).lt.tfreeze .and. ql_mean.gt.qmin .and. qa_mean.gt.qmin)              
            qndt_evap(:,:,j) = 1.e-3*exp((12.96*0.0125*(tfreeze-T(:,:,j)))-0.639)
           end where
         endif
 
       !do Bergeron process
       D2_dt = 0.0
       where (T(:,:,j) .lt. tfreeze .and. ql_mean .gt. qmin .and. qa_mean .gt. qmin)              
             D2_dt =  dtcloud * qa_mean * ((1.e6*crystal(:,:)/airdens(:,:,j))**(2./ &
                      3.))* 7.8* ((max(qi_mean/qa_mean,1.E-12*1.e6*   &
                      crystal(:,:)     &
                      /airdens(:,:,j)))**(1./3.))*0.0125*              &
                      (tfreeze-T(:,:,j))/((700.**(1./3.))*       &
                      A_plus_B(:,:,j)*ql_mean)
       end where

    else
        !do Bergeron process
        D2_dt = 0.0        
        where (T(:,:,j) .lt. tfreeze .and. ql_mean .gt. qmin .and. qa_mean .gt. qmin)           
             D2_dt =  dtcloud * qa_mean * ((cfact*1000.*exp((12.96*0.0125*   &
                      (tfreeze-T(:,:,j)))-0.639)/airdens(:,:,j))**(2./ &
                      3.))* 7.8* ((max(qi_mean/qa_mean,1.E-12*cfact*1000.*   &
                      exp((12.96*0.0125*(tfreeze-T(:,:,j)))-0.639)     &
                      /airdens(:,:,j)))**(1./3.))*0.0125*              &
                      (tfreeze-T(:,:,j))/((700.**(1./3.))*             &
                      A_plus_B(:,:,j)*ql_mean)
        end where

      endif

        if (max(id_qldt_berg,id_ql_berg_col) > 0) qldt_berg(:,:,j) = D2_dt
       
!       Accretion of cloud liquid by ice ('Riming')
!       
!       [The below follows Rotstayn]
!       Accretion of cloud liquid by ice ('Riming') is derived in
!       the same way as the accretion of cloud liquid by rain. That
!       is the continous-collection equation for the growth of an
!       ice crystal is integrated over all ice crystal sizes. This
!       calculation assumes all crystals fall at the mass weighted
!       fall speed, Vfall.  This yields the following equation after
!       accounting for the area of the interaction
!
!  (39) dql/dt = -  ( a_snow_cld / qa/a_snow_cld ) *
!                   ( ELI * lamda_f * snow_cld / 2/ rho_ice ) * ql 
!
!
!       Note that in the version with the snowmelt bug, riming was
!       prevented when temperatures were in excess of freezing.

        !add in accretion of cloud liquid by ice
        tmp1 = 0.0
        if (do_old_snowmelt) then
             where ((a_snow_cld.gt.qmin) .and. (ql_mean.gt.qmin) .and. &
                    (   qa_mean.gt.qmin) .and. (T(:,:,j) .lt. tfreeze) )            
                 tmp1 = dtcloud*0.5*ELI*lamda_f*snow_cld/qa_mean/rho_ice              
             end where
        else
             where ((a_snow_cld.gt.qmin) .and. (ql_mean.gt.qmin) .and. &
                    (   qa_mean.gt.qmin) )            
                 tmp1 = dtcloud*0.5*ELI*lamda_f*snow_cld/qa_mean/rho_ice              
             end where
        end if        
        
        D2_dt = D2_dt + tmp1

        if (max(id_qldt_rime,id_ql_rime_col) > 0) qldt_rime(:,:,j) = tmp1

!       Freezing of cloud liquid to cloud ice occurs when
!       the temperature is less than -40C. At these very cold temper-
!       atures it is assumed that homogenous freezing of cloud liquid
!       droplets will occur.   To accomplish this numerically in one 
!       time step:
!
!  (40) D*dtcloud =  ln( ql / qmin ).
!
!       With this form it is guaranteed that if this is the only
!       process acting that ql = qmin after one integration.
!
               
        !do homogeneous freezing
        where ( T(:,:,j).lt.tfreeze-40..and.(ql_mean.gt.qmin).and.     &
               (qa_mean.gt.qmin))
             D2_dt = log ( ql_mean / qmin )
        end where
        
        if (max(id_qldt_freez,id_qldt_rime,id_qldt_berg,id_ql_freez_col,  &
                id_ql_rime_col,id_ql_berg_col) > 0) then
          do k=1,jdim
           do i=1,idim
             if (T(i,k,j).lt.(tfreeze-40.).and.(ql_mean(i,k).gt.qmin)    &
               .and.(qa_mean(i,k).gt.qmin)) then
               if (max(id_qldt_freez,id_ql_freez_col) > 0) qldt_freez(i,k,j) = D2_dt(i,k)
               if (max(id_qldt_rime,id_ql_rime_col) > 0) qldt_rime (i,k,j) = 0.
               if (max(id_qldt_berg,id_ql_berg_col) > 0) qldt_berg (i,k,j) = 0.     
             endif
           enddo
          enddo
        end if
  
!       Analytic integration of ql equation
!
!
!       The next step is to analytically integrate the cloud liquid
!       condensate equation.  This follows the Tiedtke approach.
!
!       The qc equation is written in the form:
!
!  (41) dqc/dt    =   C   -  qc * D   
!
!       Note that over the physics time step, C and D are assumed to 
!       be constants.
!
!       Defining qc(t) = qc0 and qc(t+dtcloud) = qc1, the analytic
!       solution of the above equation is:
!
!  (42) qc1 = qceq -  (qceq - qc0) * exp (-D*dtcloud)
! 
!       where qceq is the equilibrium cloud condensate that is approached
!       with an time scale of 1/D,
!
!  (43) qceq  =   C / D 
!
!
!       To diagnose the magnitude of each of the right hand terms of
!       (41) integrated over the time step, define the average cloud
!       condensate in the interval t to t + dtcloud qcbar as:
!
!  (44) qcbar  = qceq - [ (qc1-qc0) / ( dtcloud * D ) ]
! 
!       from which the magnitudes of the C and D terms integrated
!       over the time step are:
!
!       C   and   -D * (qcbar)
!   
!
!       Additional notes on this analytic integration:
!
!       1.   Because of finite machine precision it is required that
!            D*dt is greater than a minimum value.  This minimum
!            alue occurs where 1. - exp(-D*dt) = 0. instead of 
!            D*dt.  This value will be machine dependent. See discussion
!            at top of code for Dmin.
!

        !C_dt is set to large-scale condensation. Sink of cloud liquid 
        !is set to the sum of D1 (liquid to rain component), and D2 
        !(liquid to ice component), D_eros (erosion), and large-scale 
        !evaporation (note use of ql mean).        

        do k=1,jdim
        do i=1,idim
        C_dts = max(dcond_ls(i,k),0.)
        D_dts = D1_dt(i,k) + D2_dt(i,k) + D_eros(i,k) +                                &
               (max(-1.*dcond_ls(i,k),0.)/max(ql_mean(i,k),qmin)) 
                             
        !do analytic integration      
        qc0s   = ql_upd(i,k)
        if ( D_dts.gt.Dmin ) then
             qceqs  = C_dts   /  D_dts
             qc1s   = qceqs - (qceqs - qc0s) * exp ( -1.* D_dts )
             qcbars = qceqs - ((qc1s - qc0s)/ D_dts)
        else
             qceqs  = qc0s + C_dts   
             qc1s   = qc0s + C_dts
             qcbars = qc0s + 0.5*C_dts
        endif

        !set total tendency term and update cloud
        !Note that the amount of SL calculated here is stored in tmp1.
        SL(i,k,j)  = SL(i,k,j) + qc1s - qc0s
        ql_upd(i,k)     = qc1s

        !compute the amount each term contributes to the change     
!rab        Dterm  = -D_dt *      qcbar

!       Apportion SL between various processes.  This is necessary to
!       account for how much the temperature changes due to various
!       phase changes.   For example:
!
!       liquid to ice   = (D2/D)*(-Dterm)
!
!       liquid to rain  = (D1/D)*(-Dterm) 
!
!       (no phase change but needed to know how much to increment 
!        rainflux)
!
!       vapor to liquid = - { ((-dcond_ls/ql_mean)+D_eros)/D}*(-Dterm) 
!                        where dcond_ls < 0 
!                                  
!                         but
!
!                        dcond_ls  -(D_eros/D)*(-Dterm)
!                        where dcond_ls > 0
!

        !initialize tmp2 to hold (-Dterm)/D
!rab        tmp2 = -Dterm/max(D_dt,Dmin)
        tmp2(i,k) = D_dts*qcbars/max(D_dts,Dmin)
        
        !do phase changes from large-scale processes and boundary
        !layer condensation/evaporation
 
        ST(i,k,j) = ST(i,k,j) + (hlv*max(dcond_ls(i,k),0.)/cp_air) -          &
             (hlv*(max(-1.*dcond_ls(i,k),0.) /max(ql_mean(i,k),qmin))*tmp2(i,k)/cp_air)
   
        SQ(i,k,j) = SQ(i,k,j) -      max(dcond_ls(i,k),0.)     +            &
                  (max(-1.*dcond_ls(i,k),0.) /max(ql_mean(i,k),qmin))*tmp2(i,k)
            
        !add in liquid to ice and cloud erosion to temperature tendency
        ST(i,k,j) = ST(i,k,j) + (hlf*D2_dt(i,k)-hlv*D_eros(i,k))*tmp2(i,k)/cp_air

        !cloud evaporation adds to water vapor
        SQ(i,k,j) = SQ(i,k,j) + D_eros(i,k)*tmp2(i,k)
             
        !add conversion of liquid to rain to the rainflux
        rain_cld(i,k) = rain_cld(i,k) +D1_dt(i,k)*tmp2(i,k)*deltpg(i,k)*inv_dtcloud
     
        !save liquid converted to ice into tmp3 and increment qi_mean
        tmp3(i,k)    = tmp2(i,k)*D2_dt(i,k)
        qi_mean(i,k) = qi_mean(i,k) + tmp3(i,k)
        enddo
        enddo
     
        
        if (do_liq_num) then
!******************************************************************

!       Analytic integration of qn equation
!
!       The qn equation is written in the form:
!
!  (m1) dqc/dt    =   (1 - qabar) * A * qc^   -  qc * D
!                 =   C - qc * D
!
!       where  qc^ is the large-scale qn calculated from the
!       activation parameterization.   Note that over the physics
!       time step, C and D are assumed to be constants.
!
!       Defining qc(t) = qc0 and qc(t+dtcloud) = qc1, the analytic
!       solution of the above equation is:
!
!  (m2) qc1 = qceq -  (qceq - qc0) * exp (-D*dtcloud)
! 
!       where qceq is the equilibrium cloud droplet number that is approached
!       with an time scale of 1/D,
!
!  (m3) qceq  = C / D
!
!
!       To diagnose the magnitude of each of the right hand terms of
!       (m1) integrated over the time step, define the average cloud
!       condensate in the interval t to t + dtcloud qcbar as:
!
!  (m4) qcbar  = qceq - [ (qc1-qc0) / ( dtcloud * D ) ]
! 
!       from which the magnitudes of the C and D terms integrated
!       over the time step are:
!
!       C and -D * (qcbar)
!

!Calculate C_dt
!       C_dt=max(tmp5,0.)*drop1*1.e6/airdens(:,:,j)
!For replying the review, substract autoconversion
!        D_dt = D1_dt + D2_dt + D_eros 

        !do analytic integration      
!       where ( (D_dt.gt.Dmin) ) 
!            qc0   = qn_upd
!            qceq  = C_dt  / max(D_dt, Dmin)
!            qc1   = qceq - (qceq - qc0) * exp ( -1.* D_dt )
!            qcbar = qceq - ((qc1 - qc0)/ max(D_dt, Dmin))
!       elsewhere
!            qc0   = qn_upd
!            qceq  = qc0 + C_dt   
!            qc1   = qc0 + C_dt
!            qcbar = qc0 + 0.5*C_dt
!       end where

         if (max(id_qndt_cond,id_qn_cond_col) > 0) qndt_cond(:,:,j) = 0.

          do k=1,jdim
            do i=1,idim
!Calculate C_dt
              C_dts=max(tmp5(i,k),0.)*drop1(i,k)*1.e6/airdens(i,k,j)
              D_dts =  num_mass_ratio1*D1_dt(i,k) + (num_mass_ratio2*D2_dt(i,k) + D_eros(i,k))
              qc0s = qn_upd(i,k)
              if (D_dts > Dmin) then
                qceqs = C_dts / D_dts
                qc1s  = qceqs - (qceqs - qc0s)* exp(-1.*D_dts)
                qcbars = qceqs - ((qc1s -qc0s)/D_dts)
              else
                qceqs  = qc0s + C_dts
                qc1s   = qc0s + C_dts
                qcbars = qc0s + 0.5*C_dts
              endif
        !set total tendency term and update cloud
        !Note that the amount of SN calculated here is stored in tmp1.
              SN(i,k,j)  = SN(i,k,j) + qc1s - qc0s
              qn_upd(i,k)     = qc1s


        !compute the amount each term contributes to the change 
!        where ( C_dt .gt. 0 )
!                Cterm  =  C_dt             
!                Dterm  =  D_dt *      qcbar 
!        elsewhere
!                Cterm  =  0.             
!                Dterm  =  D_dt *      qcbar 
!        end where

         if (max(id_qndt_cond,id_qn_cond_col) > 0) then
          if ( C_dts.gt. 0 ) qndt_cond(i,k,j)  =  C_dts
         endif

         if (max(id_qndt_evap,id_qn_evap_col) > 0) qndt_evap(i,k,j) = D_dts * qcbars !Dterm
            end do
          end do

        endif  ! (do_liq_num)

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


!
!       diagnostics for cloud liquid tendencies
!       

        if (max(id_qldt_cond,id_ql_cond_col) > 0) qldt_cond(:,:,j)  = max(dcond_ls,0.) *inv_dtcloud
        if (max(id_qldt_evap,id_ql_evap_col) > 0) qldt_evap(:,:,j)  = (max(0.,-1.*dcond_ls )/max(ql_mean,   &
                                 qmin))           *tmp2*inv_dtcloud
        if (max(id_qldt_accr,id_ql_accr_col) > 0) qldt_accr(:,:,j)  = qldt_accr (:,:,j)*tmp2*inv_dtcloud
        if (max(id_qldt_auto,id_ql_auto_col) > 0) qldt_auto(:,:,j)  = qldt_auto (:,:,j)*tmp2*inv_dtcloud
        if (max(id_qldt_eros,id_ql_eros_col) > 0) qldt_eros(:,:,j)  = D_eros           *tmp2*inv_dtcloud 
        if (max(id_qldt_berg,id_ql_berg_col) > 0) qldt_berg(:,:,j)  = qldt_berg (:,:,j)*tmp2*inv_dtcloud
        if (max(id_qldt_rime,id_ql_rime_col) > 0) qldt_rime(:,:,j)  = qldt_rime (:,:,j)*tmp2*inv_dtcloud
        if (max(id_qldt_freez,id_ql_freez_col) > 0) qldt_freez(:,:,j) = qldt_freez(:,:,j)*tmp2*inv_dtcloud
        if (max(id_qndt_cond,id_qn_cond_col) > 0) qndt_cond(:,:,j)  = qndt_cond(:,:,j)*inv_dtcloud 
        if (max(id_qndt_evap,id_qn_evap_col) > 0) qndt_evap(:,:,j)  = qndt_evap(:,:,j)*inv_dtcloud 
        


!-----                                                            -----! 
!                                                                      !
!                                END OF                                !
!                                                                      !
!                       LIQUID PHASE MICROPHYSICS                      !
!                                                                      !
!                                 AND                                  !
!                                                                      !
!                  ANALYTIC INTEGRATION OF QL EQUATION                 !
!                                                                      !
!                               SECTION                                !
!                                                                      !
!                                                                      !
!                                                                      !
!----------------------------------------------------------------------!
!----------------------------------------------------------------------!
!                                                                      !
!                                                                      !
!                                                                      !
!                        ICE PHASE MICROPHYSICS                        !
!                                                                      !
!                                 AND                                  !
!                                                                      !
!                  ANALYTIC INTEGRATION OF QI EQUATION                 !
!                                                                      !
!                                                                      !
!                                                                      !
!       Ice settling
!
!       Ice settling is treated as in Heymsfield Donner 1990. 
!       The mass weighted fall speed is parameterized as in equation
!       #49.
!
!       In terms of the analytic integration with respect qi of Tiedtke,
!       the flux in from the top of the grid layer is equated to the
!       source term, and the flux out of the bottom of the layer is 
!       equated to the sink term:
!
!  (47) C_dt =  snow_cld * dtcloud * grav / deltp
!
!  (48) D_dt =  airdens * grav * Vfall * dtcloud / deltp
!
!       All ice crystals are assumed to fall with the same fall speed
!       which is given as in Heymsfield and Donner (1990) as:
!
!  (49) Vfall = 3.29 * ( (airdens*qi_mean/qa_mean)**0.16)
!
!       which is the formula in Heymsfield and Donner.  Note however
!       that because this is uncertain, sensitivity runs will be made
!       with different formulations. Note that when Vfall is computed 
!       the source incremented qi, qi_mean, is used.  This gives some 
!       implicitness to the scheme.

        !compute Vfall
        iwc = airdens(:,:,j)*qi_mean/max(qa_mean,qmin)
        where (iwc >= iwc_crit)
           Vfall = vfact*3.29 * iwc**0.16
        elsewhere
           Vfall = vfact*vfall_const2 * iwc**vfall_exp2
        end where

        if (id_vfall > 0) vfalldiag(:,:,j) = Vfall(:,:)*areaice(:,:,j)

        !add to ice source the settling ice flux from above
        !also note that tmp3 contains the source
        !of liquid converted to ice from above
        tmp3 = tmp3 + snow_cld*dtcloud/deltpg
        
        !Compute settling of ice. The result is multiplied by 
        !dtcloud/deltp to convert to units of D_dt.  
        !Note that if tracers are not advected then this is done
        !relative to the local vertical motion.
        if (tracer_advec) then
             tmp1 = 0.
        else
             tmp1 = omega(:,:,j)
        end if 
        
        where (qi_mean .gt. qmin .and. qa_mean .gt. qmin)
             D1_dt      = max(0.,((airdens(:,:,j)*Vfall)+(tmp1/grav))* &
                          dtcloud/deltpg )
             a_snow_cld = qa_mean     
        elsewhere
             D1_dt      = 0.
             snow_cld   = 0.
             a_snow_cld = 0.    
        end where 

        
!       Melting of in-cloud ice
!
!       Melting occurs where the temperature is greater than Tfreezing. 
!       This is an instaneous process such that no stratiform ice will
!       remain in the grid at the end of the timestep. 
!       No ice settles out of the grid box (i.e. D1 is set to zero) when
!       the amount of ice to be melted is less than that that would
!       bring the grid box to the freezing point.
!
!       The ice that melts becomes rain.  This is because if an ice
!       crystal of dimension ~100 microns and mass density of 100 kg/m2
!       melts it will become a droplet of SIZE 40 microns which is 
!       clearly a drizzle SIZE drop.  Ice crystals at temperatures near 
!       freezing are assumed to be this large, consistent with the 
!       assumption of particle SIZE temperature dependence.
!

        !compute grid mean change in cloud ice to cool the
        !grid box to 0C and store in temporary variable tmp1
        tmp1 = cp_air*(T(:,:,j)-tfreeze)/hlf

        ! If qi_mean > tmp1, then the amount of ice melted is
        ! limited to tmp1, otherwise melt all qi_mean.  The amount
        ! melted is stored in tmp2
        tmp2  = max(min(qi_mean,tmp1),0.)     
        D2_dt = max(0.,log(max(qi_mean,qmin)/max(qi_mean-tmp2,qmin)))
            
        !melting of ice creates area to a_rain_cld
        where (D2_dt .gt. Dmin) 
             a_rain_cld = qa_mean
        endwhere
                  
        !If all of the ice can melt, then don't permit any ice to fall
        !out of the grid box and set a_snow_cld to zero.
        where (qi_mean .lt. tmp1 .and. qi_mean .gt. qmin) 
             D1_dt = 0.
             snow_cld = 0.
             a_snow_cld = 0.
        end where
         
!       Analytic integration of qi equation
!
!       This repeats the procedure done for the ql equation.
!       See above notes for detail.

        !At this point C_dt already includes the source of cloud ice 
        !falling from above as well as liquid converted to ice. 
        !Therefore add in large_scale deposition.
        !
        !Compute D_dt which has contributions from D1_dt (ice settling)
        !and D2_dt (ice melting), D_eros (cloud erosion), and large-
        !scale sublimation (note use of qi mean).

      do k=1,jdim
       do i=1,idim
        C_dts = tmp3(i,k) + max(dcond_ls_ice(i,k),0.)
        D_dts =  D1_dt(i,k) + D2_dt(i,k) + D_eros(i,k) +                               &
                (max(-1.*dcond_ls_ice(i,k),0.)/max(qi_mean(i,k),qmin))
        
        !do analytic integration      
        qc0s   = qi_upd(i,k)
        if ( D_dts.gt.Dmin ) then
             qceqs  = C_dts / D_dts
             qc1s   = qceqs - (qceqs - qc0s) * exp ( -1.* D_dts )
             qcbars = qceqs - ((qc1s - qc0s)/D_dts)
        else
             qceqs  = qc0s + C_dts   
             qc1s   = qc0s + C_dts
             qcbars = qc0s + 0.5*C_dts
        endif

        !set total tendency term and update cloud
        !Note that the amount of SL calculated here is stored in tmp1.
        SI(i,k,j)  = SI(i,k,j) + qc1s - qc0s
        qi_upd(i,k)     = qc1s

        !compute the amount each term contributes to the change     
!rab        Dterm  = -D_dt *          qcbar 
      
!       Apportion SI between various processes.  This is necessary to
!       account for how much the temperature and water vapor changes 
!       due to various phase changes.   For example:
!
!       ice settling = (D1/D)*(-Dterm)*deltp/grav/dtcloud
!                     
!       vapor to ice =
!           -{ ((-dcond_ls_ice/qi_mean)+D_eros)/ D }*(-Dterm) 
!           where dcond_ls_ice  < 0. 
!
!           but
!       
!           dcond_ls_ice -(D_eros/D)* (-Dterm)
!
!           where dcond_ls_ice > 0.
!       
!       melting of ice = (D2/D)*(-Dterm)*deltp/grav/dtcloud
!

        !initialize tmp2 to hold (-Dterm)/D
!rab        tmp2 = -Dterm/max(D_dt,Dmin)
        tmp2s = D_dts*qcbars/max(D_dts,Dmin)
        
        !do phase changes from large-scale processes 
        ST(i,k,j) = ST(i,k,j) +  hls*max(dcond_ls_ice(i,k),0.)/cp_air -    &
         hls*(max(-1.*dcond_ls_ice(i,k),0.)/max(qi_mean(i,k),qmin))*tmp2s/cp_air
       
        SQ(i,k,j) = SQ(i,k,j) -      max(dcond_ls_ice(i,k),0.)    +         &
             (max(-1.*dcond_ls_ice(i,k),0.)/max(qi_mean(i,k),qmin))*tmp2s
     
        !cloud erosion changes temperature and vapor
        ST(i,k,j) = ST(i,k,j) - hls*D_eros(i,k)* tmp2s/cp_air
        SQ(i,k,j) = SQ(i,k,j) +     D_eros(i,k)* tmp2s

        !add settling ice flux to snow_cld 
        snow_cld(i,k) = D1_dt(i,k)*tmp2s*deltpg(i,k)*inv_dtcloud
       
        !add melting of ice to temperature tendency
        ST(i,k,j) = ST(i,k,j) - hlf*D2_dt(i,k)*tmp2s/cp_air

        !add melting of ice to the rainflux
        rain_cld(i,k) = rain_cld(i,k) + D2_dt(i,k)*tmp2s*deltpg(i,k)*inv_dtcloud

!
!       diagnostics for cloud ice tendencies
!       
        
        if (max(id_qidt_dep,id_qi_dep_col) > 0) &
                qidt_dep (i,k,j) = max(dcond_ls_ice(i,k),0.)*inv_dtcloud
        if (max(id_qidt_subl,id_qi_subl_col) > 0) &
                qidt_subl(i,k,j) = (max(0.,-1.*dcond_ls_ice(i,k))/ &
                        max(qi_mean(i,k),qmin))*tmp2s*inv_dtcloud
        if (max(id_qidt_melt,id_qi_melt_col) > 0) &
                qidt_melt(i,k,j) = D2_dt(i,k) *tmp2s*inv_dtcloud
        if (max(id_qidt_eros,id_qi_eros_col) > 0) &
                qidt_eros(i,k,j) = D_eros(i,k)*tmp2s*inv_dtcloud       

        if (max(id_lsf_strat,id_lcf_strat,id_mfls_strat) > 0) then
            tmp1s = max(dcond_ls_ice(i,k),0.)*inv_dtcloud
            if ( (qldt_cond(i,k,j) + tmp1s) .gt. 0. ) lsf_strat(:,:,j) = 1.
        endif
       enddo
      enddo

        
!-----                                                            -----! 
!                                                                      !
!                                END OF                                !
!                                                                      !
!                        ICE PHASE MICROPHYSICS                        !
!                                                                      !
!                                 AND                                  !
!                                                                      !
!                  ANALYTIC INTEGRATION OF QI EQUATION                 !
!                                                                      !
!                                 SECTION                              !
!                                                                      !
!                                                                      !
!                                                                      !
!----------------------------------------------------------------------!



!-----------------------------------------------------------------------
!
!
!
!                       RAIN EVAPORATION
!                           
!
!       Rain evaporation is derived by integration of the growth 
!       equation of a droplet over the assumed Marshall-Palmer 
!       distribution of rain drops (equation #22).  This leads to the 
!       following formula:
!
!  (50) dqv/dt_local =  56788.636 * {rain_rate/dens_h2o}^(11/18) *(1-U)/
!
!                      ( SQRT(airdens)* A_plus_B)
!
!       Numerically this equation integrated by use of time-centered
!       values for qs and qv.   This leads to the solution:
!
!  (51) qv_clr(t+1)-qv_clr(t) = K3 *[qs(t)-qv_clr(t)]/
!                               {1.+0.5*K3*(1+gamma)}
!       where 
!
!       K3= 56788.636 * dtcloud * {rain_rate_local/dens_h2o}^(11/18) /
!           ( SQRT(airdens)* A_plus_B * qs)
!
!       and gamma is given by (3). Note that in (51), it is made 
!       explicit that it is the vapor concentration in the unsaturated 
!       part of the grid box that is used in the rain evaporation 
!       formula.
!
!       Now there are several limiters to this formula. First,
!       you cannot evaporate more than is available in a time step.
!       The amount available for evaporation locally is 
!       (rain_clr/a_rain_clr)*(grav*dtcloud/deltp).   Second, to
!       avoid supersaturating the box or exceeding the critical
!       relative humidity above which rain does not evaporate, 
!       the amount of evaporation is limited.
!
!       Finally rain evaporation occurs only if the relative humidity
!       in the unsaturated portion of the grid box, U_clr, is less
!       then a threshold, U_evap.   U_evap, will not necessarily be
!       one.   For example, stratiform precipitation in convective
!       regions rarely saturates subcloud air because of the presence
!       of downdrafts.  If the convection scheme does not have down-
!       drafts then it doesn't make sense to allow the sub-cloud layer
!       to saturate. U_clr may be solved from (8) as:
!
!  (52) U_clr = ( U - qa ) / (1. - qa)
!
!       Some variables are temporarily stored in tmp1.
!
!       Note that for pdf clouds the relative humidity in the clear part
!       of the grid box can be calculated exactly from the beta distr-
!       ibution. 

      do k=1,jdim
       do i=1,idim
        !compute U_clr
        if (.not. do_pdf_clouds) then 
             U_clr(i,k) =  (U(i,k)-qa_mean(i,k))/max((1.-qa_mean(i,k)),qmin)
        else
             U_clr(i,k) = qvg(i,k)/qs(i,k,j)
        end if
        
        !keep U_clr > 0. and U_clr < 1.
        U_clr(i,k) = min(max(U_clr(i,k),0.),1.)
        
        !compute K3
        tmp1s = 56788.636 * dtcloud * ((rain_clr(i,k)/max(a_rain_clr(i,k),qmin)/  &
             dens_h2o)**(11./18.))/SQRT(airdens(i,k,j))/A_plus_B(i,k,j)&
             /qs(i,k,j)

        !compute local change in vapor mixing ratio due to 
        !rain evaporation
        tmp1s = tmp1s*qs(i,k,j)*(1.-U_clr(i,k))/(1.+0.5*tmp1s*(1.+gamma(i,k,j)))

        !limit change in qv to the amount that would raise the relative
        !humidity to U_evap in the clear portion of the grid box
        tmp1s = min(tmp1s,((1.-qa_mean(i,k))/max(a_rain_clr(i,k),qmin))*qs(i,k,j)* &
               max(0.,U_evap-U_clr(i,k))/(1.+(U_evap*(1.-qa_mean(i,k))+qa_mean(i,k))* &
               gamma(i,k,j)) )
        
        !do limiter by amount available
        tmp1s= tmp1s*a_rain_clr(i,k)*deltpg(i,k)*inv_dtcloud
        tmp2s= max(min(rain_clr(i,k),tmp1s),0.)
    
        SQ(i,k,j) = SQ(i,k,j) +     tmp2s*dtcloud/deltpg(i,k)
        ST(i,k,j) = ST(i,k,j) - hlv*tmp2s*dtcloud/deltpg(i,k)/cp_air
        
        !if all of the rain evaporates set things to zero.    
        if (tmp1s.gt.rain_clr(i,k).and.a_rain_clr(i,k).gt.qmin) then
             rain_clr(i,k) = 0.
             a_rain_clr(i,k) = 0.
        else
             rain_clr(i,k) = rain_clr(i,k) - tmp2s   
        endif
        
        if (max(id_rain_evap,id_rain_evap_col) > 0) rain_evap(i,k,j) = tmp2s/deltpg(i,k)
!rab       enddo 
!rab      enddo 

!-----------------------------------------------------------------------
!
!
!
!                              SNOW SUBLIMATION
!                           
!
!       Sublimation of cloud ice
!
!       [The following follows Rotstayn (1997)]
!       Given the assumptions of the Marshall-Palmer distribution of
!       ice crystals (18), the crystal growth equation as a function
!       of the humidity of the air and the diffusivity of water vapor
!       and thermal conductivity of air is integrated over all crystal
!       sizes.   This yields:
!
!  (53) dqi/dt_local = - a_snow_clr* K3 * (qs - qv_clr)
!
!       where the leading factor of a_snow_clr is the portion of the
!       grid box undergoing sublimation. K3 is given by
!
!  (54) K3 = (4/(pi*rho_air*qs*rho_ice*A_plus_B))*
!            ((snow_clr/a_snow_clr/3.29)**1.16 ) *
!           [ 0.65*lamda_f^2 + 
!             198.92227 * (airdens)^0.5 * 
!             ((snow_clr/a_snow_clr)**(1/14.5)) * lamda_f^(3/2) ]
!
!       Note that equation (53) is identical to equation (30) of 
!       Rotstayn.
!
!       Numerically this is integrated as in rain evaporation.


!rab      do k=1,jdim
!rab       do i=1,idim
        !compute K3
        tmp1s = dtcloud * (4./3.14159/rho_ice/airdens(i,k,j)/           &
               A_plus_B(i,k,j)/qs(i,k,j))*((snow_clr(i,k)/max(a_snow_clr(i,k),   &
               qmin)/3.29)**(1./1.16))*(0.65*lamda_f(i,k)*lamda_f(i,k) +         &
               198.92227*lamda_f(i,k)*SQRT(airdens(i,k,j)*lamda_f(i,k))*         &
               ( (snow_clr(i,k)/max(a_snow_clr(i,k),qmin))**(1./14.5) )  )

        !compute local change in vapor mixing ratio due to 
        !snow sublimation
        tmp1s = tmp1s*qs(i,k,j)*(1.-U_clr(i,k))/(1.+0.5*tmp1s*(1.+gamma(i,k,j)))

        !limit change in qv to the amount that would raise the relative
        !humidity to U_evap in the clear portion of the grid box
        tmp1s = min(tmp1s,((1.-qa_mean(i,k))/max(a_snow_clr(i,k),qmin))*qs(i,k,j)* &
               max(0.,U_evap-U_clr(i,k))/(1.+(U_evap*(1.-qa_mean(i,k))+qa_mean(i,k))* &
               gamma(i,k,j)) )
        
        !do limiter by amount available
        tmp1s= tmp1s*a_snow_clr(i,k)*deltpg(i,k)*inv_dtcloud
        tmp2s= max(min(snow_clr(i,k),tmp1s),0.)
    
        SQ(i,k,j) = SQ(i,k,j) +     tmp2s*dtcloud/deltpg(i,k)
        ST(i,k,j) = ST(i,k,j) - hls*tmp2s*dtcloud/deltpg(i,k)/cp_air
        
        !if all of the snow sublimates set things to zero.    
        if (tmp1s.gt.snow_clr(i,k).and.a_snow_clr(i,k).gt.qmin) then
             snow_clr(i,k) = 0.
             a_snow_clr(i,k) = 0.
        else
             snow_clr(i,k) = snow_clr(i,k) - tmp2s     
        endif
         
        if (max(id_snow_subl,id_snow_subl_col) > 0) snow_subl(i,k,j) = tmp2s/deltpg(i,k)
       enddo 
      enddo 

!-----------------------------------------------------------------------
!
!       Adjustment to try to prevent negative water vapor. Adjustment
!       will not remove more condensate than available. Cloud amount
!       is not adjusted. This is left for the remainder of the
!       desctruction code. (cjg)

        if (max(id_qadt_destr,id_qa_destr_col) > 0) qadt_destr(:,:,j) = qadt_destr(:,:,j) + SA(:,:,j)*inv_dtcloud
        if (max(id_qldt_destr,id_ql_destr_col) > 0) qldt_destr(:,:,j) = qldt_destr(:,:,j) + SL(:,:,j)*inv_dtcloud
        if (max(id_qidt_destr,id_qi_destr_col) > 0) qidt_destr(:,:,j) = qidt_destr(:,:,j) + SI(:,:,j)*inv_dtcloud
        if (max(id_qndt_destr,id_qn_destr_col) > 0) qndt_destr(:,:,j) = qndt_destr(:,:,j) + SN(:,:,j)*inv_dtcloud

        do k=1,jdim
         do i=1,idim
          tmp1s = qv(i,k,j) + SQ(i,k,j)
          tmp2s = 0.0
          tmp3s = 0.0
          if ( tmp1s.lt.0.0 ) then
           if (T(i,k,j).le.tfreeze-40.) then
            tmp2s = min( -tmp1s, ql_upd(i,k) )        ! liquid to evaporate
            tmp3s = min( -tmp1s-tmp2s, qi_upd(i,k) )   ! ice to sublimate
           else
            tmp3s = min( -tmp1s, qi_upd(i,k) )        ! ice to sublimate
            tmp2s = min( -tmp1s-tmp3s, ql_upd(i,k) )   ! liquid to evaporate
           end if
           ql_upd(i,k) = ql_upd(i,k) - tmp2s
           qi_upd(i,k) = qi_upd(i,k) - tmp3s
           SL(i,k,j) = SL(i,k,j) - tmp2s
           SI(i,k,j) = SI(i,k,j) - tmp3s
           SQ(i,k,j) = SQ(i,k,j) + tmp2s + tmp3s
           ST(i,k,j) = ST(i,k,j) - hlv*tmp2s/cp_air - hls*tmp3s/cp_air
          end if
         enddo
        enddo

!-----------------------------------------------------------------------
!       Cloud Destruction occurs where both ql and qi are .le. qmin, 
!       or if qa is .le. qmin. In this case, ql, qi, and qa are set to 
!       zero conserving moisture and energy.

        if (.not.do_liq_num) then
          do k=1,jdim
           do i=1,idim
            if ((ql_upd(i,k) .le. qmin .and. qi_upd(i,k) .le. qmin)               &
               .or. (qa_upd(i,k) .le. qmin)) then
             SL(i,k,j) = SL(i,k,j) - ql_upd(i,k)
             SI(i,k,j) = SI(i,k,j) - qi_upd(i,k)
             SQ(i,k,j) = SQ(i,k,j) + ql_upd(i,k) + qi_upd(i,k)
             ST(i,k,j) = ST(i,k,j) - (hlv*ql_upd(i,k) + hls*qi_upd(i,k))/cp_air
             SA(i,k,j) = SA(i,k,j) - qa_upd(i,k)
             ql_upd(i,k) = 0.0
             qi_upd(i,k) = 0.0
             qa_upd(i,k) = 0.0
            endif
           enddo
          enddo
        else
          do k=1,jdim
           do i=1,idim
            if ((ql_upd(i,k) .le. qmin .and. qi_upd(i,k) .le. qmin)               &
               .or. (qa_upd(i,k) .le. qmin)) then
             SL(i,k,j) = SL(i,k,j) - ql_upd(i,k)
             SI(i,k,j) = SI(i,k,j) - qi_upd(i,k)
             SQ(i,k,j) = SQ(i,k,j) + ql_upd(i,k) + qi_upd(i,k)
             ST(i,k,j) = ST(i,k,j) - (hlv*ql_upd(i,k) + hls*qi_upd(i,k))/cp_air
             SA(i,k,j) = SA(i,k,j) - qa_upd(i,k)
             SN(i,k,j) = SN(i,k,j) - qn_upd(i,k)
             ql_upd(i,k) = 0.0
             qi_upd(i,k) = 0.0
             qa_upd(i,k) = 0.0
             qn_upd(i,k) = 0.0
            endif
           enddo
          enddo
        endif  

        if (max(id_qadt_destr,id_qa_destr_col) > 0) qadt_destr(:,:,j) = qadt_destr(:,:,j) - SA(:,:,j)*inv_dtcloud
        if (max(id_qldt_destr,id_ql_destr_col) > 0) qldt_destr(:,:,j) = qldt_destr(:,:,j) - SL(:,:,j)*inv_dtcloud
        if (max(id_qidt_destr,id_qi_destr_col) > 0) qidt_destr(:,:,j) = qidt_destr(:,:,j) - SI(:,:,j)*inv_dtcloud
        if (max(id_qndt_destr,id_qn_destr_col) > 0) qndt_destr(:,:,j) = qndt_destr(:,:,j) - SN(:,:,j)*inv_dtcloud

!-----------------------------------------------------------------------
!
!       Adjustment.  Due to numerical errors in detrainment or advection
!       sometimes the current state of the grid box may be super-
!       saturated. Under the assumption that the temperature is constant
!       in the grid box and that q <= qs, the excess vapor is condensed. 
!       
!       What happens to the condensed water vapor is determined by the
!       namelist parameter super_choice.
!
!       If super_choice = .false. (default), then the condensed water is
!       is added to the precipitation fluxes.  If super_choice = .true.,
!       then the condensed water is added to the cloud condensate field.
!       Note that in this case the cloud fraction is raised to one.
!
!       The phase partitioning depends on super_choice; if super_choice
!       is false then at T < -20C, snow is produced.  If super_choice
!       is true, then at T < -40C, ice is produced.  The latter choice 
!       is consistent with that done in the large-scale condensation
!       section above.        
!
!       If pdf clouds are operating then this section is bypassed - 
!       as statistical clouds should remove supersaturation according
!       to the beta distribution used.
             
        if (.not.do_pdf_clouds) then
               
!       Old code

!       !estimate current qs
!       tmp2 = qs(:,:,j)+dqsdT(:,:,j)*ST(:,:,j)
!
!       !compute excess over saturation
!       tmp1 = max(0.,qv(:,:,j)+SQ(:,:,j)-tmp2)/(1.+gamma(:,:,j))
 
!       New more accurate version

!RSH 9/18/09: should be within the super_choice if block:
        ! updated temperature in tmp1
        tmp1 = T(:,:,j) + ST(:,:,j)

        ! updated qs in tmp2, updated gamma in tmp3, updated dqsdT in tmp5
        call compute_qs(tmp1, pfull(:,:,j), tmp2, dqsdT=tmp5)
 
!RSH intended for s block:
!   use blended L  between 0 and -20 C, both in expression below for
!    temp1 , and in the ST terms which follow below to avoid 
!    inconsistency and non-saturated conditions after calculation.
        tmp3 = tmp5 *(min(1.,max(0.,0.05*(tmp1-tfreeze+20.)))*hlv +     &
                      min(1.,max(0.,0.05*(tfreeze -tmp1   )))*hls)/cp_air

!         do k=1,jdim
!          do i=1,idim
!       if (tmp1(i,k) <= tfreeze - 20.) then
!         tmp6(i,k) = hls
!       else if (tmp1(i,k) >= tfreeze) then
!         tmp6(i,k) = hlv
!       else
!         tmp6(i,k) = 0.05*((tfreeze-tmp1(i,k))*hls + (tmp1(i,k)-tfreeze        +20.)*hlv)
!       endif
!       end do
!       end do
!       tmp3 = tmp5 * tmp6/cp_air
!RSH end block

        !compute excess over saturation
        tmp1 = max(0.,qv(:,:,j)+SQ(:,:,j)-tmp2)/(1.+tmp3)

!rab - save off tmp1 for diagnostic ice/liq adjustment fields in liq_adj array
        if (max(id_ice_adj,id_ice_adj_col,id_liq_adj,id_liq_adj_col) .gt. 0) &
               liq_adj(:,:,j) = tmp1*inv_dtcloud

        !change vapor content
        SQ(:,:,j)=SQ(:,:,j)-tmp1

        if (super_choice) then
        
             ! Put supersaturation into cloud

             !cloud fraction source diagnostic
             if (max(id_qadt_super,id_qa_super_col) > 0) then
               where (tmp1 .gt. 0.)
                 qadt_super(:,:,j)  = (1.-qa_upd) * inv_dtcloud
               endwhere
             endif

!yim 11/7/07
             if (do_liq_num) then
               do k=1,jdim
                 do i=1,idim
                   if (T(i,k,j) > tfreeze - 40. .and. &
                        tmp1(i,k) > 0.0) then
                     qn_upd(i,k) = qn_upd(i,k) + drop1(i,k)*1.0e6/  &
                                    airdens(i,k,j)*(1. - qa_upd(i,k))
                     SN(i,k,j) = SN(i,k,j) + drop1(i,k)*1.e6/  &
                                   airdens(i,k,j)*(1.-qa_upd(i,k))
                     if (max(id_qndt_super,id_qn_super_col) > 0)  &
                        qndt_super(i,k,j) = qndt_super(i,k,j) +   &
                                                drop1(i,k)*1.e6 / &
                            airdens(i,k,j)*(1.-qa_upd(i,k))*inv_dtcloud
                     endif
                  end do
               end do
             endif

             !add in excess to cloud condensate, change cloud area and 
             !increment temperature
             do k=1,jdim
              do i=1,idim
               if(tmp1(i,k).gt.0) then
                if (T(i,k,j) .le. tfreeze-40.)then
                  qi_upd(i,k)   = qi_upd(i,k) + tmp1(i,k)
                  SI(i,k,j) = SI(i,k,j) + tmp1(i,k)
!RSH intended for s:
                  ST(i,k,j) = ST(i,k,j) + hls*tmp1(i,k)/cp_air
! probably need to partition ql and qi in same way as L here for 
!  entropy conservation
!                 ST(i,k,j) = ST(i,k,j) + tmp6(i,k)*tmp1(i,k)/cp_air
!RSH end block
                else   ! where (T(i,k,j) .gt. tfreeze-40.)
                  ql_upd(i,k)   = ql_upd(i,k) + tmp1(i,k)
                  SL(i,k,j) = SL(i,k,j) + tmp1(i,k)
!RSH intended for s:
                  ST(i,k,j) = ST(i,k,j) + hlv*tmp1(i,k)/cp_air        
! probably need to partition ql and qi in same way as L here for 
!  entropy conservation
!                 ST(i,k,j) = ST(i,k,j) + tmp6(i,k)*tmp1(i,k)/cp_air    
!RSH end block
                endif
                if (limit_conv_cloud_frac) then
                  tmp2s = ahuco(i,k,j)
                else
                  tmp2s = 0.
                endif
                SA(i,k,j) = SA(i,k,j) + (1.-qa_upd(i,k)-tmp2s)
                qa_upd(i,k) = 1. - tmp2s
               endif
              enddo
             enddo

        else

             !Put supersaturation into precip

             !add in excess to precipitation fluxes, change their area 
             !and increment temperature
             do k=1,jdim
              do i=1,idim
               if(tmp1(i,k).gt.0) then
                if (T(i,k,j) .le. tfreeze-20.) then
                  snow_cld(i,k) = snow_cld(i,k) + qa_mean(i,k) *tmp1(i,k)*deltpg(i,k)*inv_dtcloud
                  snow_clr(i,k) = snow_clr(i,k) + (1.-qa_mean(i,k))*tmp1(i,k)*deltpg(i,k)*      &
                                                             inv_dtcloud
                  a_snow_cld(i,k) = qa_mean(i,k)
                  a_snow_clr(i,k) = 1.-qa_mean(i,k)
                  ST(i,k,j)  = ST(i,k,j) + hls*tmp1(i,k)/cp_air
                else   ! where (T(i,k,j) .gt. tfreeze-20.)
                  rain_cld(i,k) = rain_cld(i,k) + qa_mean(i,k) *tmp1(i,k)*deltpg(i,k)*inv_dtcloud
                  rain_clr(i,k) = rain_clr(i,k) + (1.-qa_mean(i,k))*tmp1(i,k)*deltpg(i,k)*      &
                                                             inv_dtcloud
                  a_rain_cld(i,k) = qa_mean(i,k)
                  a_rain_clr(i,k) = 1.-qa_mean(i,k)
                  ST(i,k,j)  = ST(i,k,j) + hlv*tmp1(i,k)/cp_air
                endif
               endif
              enddo
             enddo

        end if !super choice
        
        end if !for do_pdf_clouds
                      
!-----------------------------------------------------------------------
!       Final clean up to remove numerical noise
!

        if (max(id_qadt_destr,id_qa_destr_col) > 0) qadt_destr(:,:,j) = qadt_destr(:,:,j) + SA(:,:,j)*inv_dtcloud
        if (max(id_qldt_destr,id_ql_destr_col) > 0) qldt_destr(:,:,j) = qldt_destr(:,:,j) + SL(:,:,j)*inv_dtcloud
        if (max(id_qidt_destr,id_qi_destr_col) > 0) qidt_destr(:,:,j) = qidt_destr(:,:,j) + SI(:,:,j)*inv_dtcloud
        if (max(id_qndt_destr,id_qn_destr_col) > 0) qndt_destr(:,:,j) = qndt_destr(:,:,j) + SN(:,:,j)*inv_dtcloud

        do k=1,jdim
         do i=1,idim
          ql_upd(i,k) = ql(i,k,j) + SL(i,k,j)
          if ( abs(ql_upd(i,k)) .le. qmin  &
                .and. qv(i,k,j)+SQ(i,k,j)+ql_upd(i,k) > 0.0 ) then
            SL(i,k,j) = -ql(i,k,j)
            SQ(i,k,j) = SQ(i,k,j) + ql_upd(i,k)
            ST(i,k,j) = ST(i,k,j) - hlv*ql_upd(i,k)/cp_air
            ql_upd(i,k) = 0.0
          endif

          qi_upd(i,k) = qi(i,k,j) + SI(i,k,j)
          if ( abs(qi_upd(i,k)) .le. qmin  &
                .and. qv(i,k,j)+SQ(i,k,j)+qi_upd(i,k) > 0.0 ) then
            SI(i,k,j) = -qi(i,k,j)
            SQ(i,k,j) = SQ(i,k,j) + qi_upd(i,k)
            ST(i,k,j) = ST(i,k,j) - hls*qi_upd(i,k)/cp_air
            qi_upd(i,k) = 0.0
          endif

          qa_upd(i,k) = qa(i,k,j) + SA(i,k,j)
          if ( abs(qa_upd(i,k)) .le. qmin ) then
            SA(i,k,j) = -qa(i,k,j)
            qa_upd(i,k) = 0.0
          endif
         enddo
        enddo

        if (max(id_qadt_destr,id_qa_destr_col) > 0) qadt_destr(:,:,j) = qadt_destr(:,:,j) - SA(:,:,j)*inv_dtcloud
        if (max(id_qldt_destr,id_ql_destr_col) > 0) qldt_destr(:,:,j) = qldt_destr(:,:,j) - SL(:,:,j)*inv_dtcloud
        if (max(id_qidt_destr,id_qi_destr_col) > 0) qidt_destr(:,:,j) = qidt_destr(:,:,j) - SI(:,:,j)*inv_dtcloud
        if (max(id_qndt_destr,id_qn_destr_col) > 0) qndt_destr(:,:,j) = qndt_destr(:,:,j) - SN(:,:,j)*inv_dtcloud

!-----------------------------------------------------------------------
!
!       Save qa_mean of current level into qa_mean_lst.   This is used
!       in transferring rain and snow fluxes between levels.

        qa_mean_lst = qa_mean
        
!-----------------------------------------------------------------------
!
!       add the ice falling out from cloud to qidt_fall
        
        if (max(id_qidt_fall,id_qi_fall_col) > 0) qidt_fall(:,:,j) = qidt_fall(:,:,j) +    & 
                                         (snow_cld/deltpg)
        
!-----------------------------------------------------------------------
!
!       save profiles of rain and snow 
!
        rain3d(:,:,j+1) = rain_clr(:,:) + rain_cld(:,:)
        snow3d(:,:,j+1) = snow_clr(:,:) + snow_cld(:,:)
        snowclr3d(:,:,j+1) = snow_clr(:,:)

!-----------------------------------------------------------------------
!
!       Save rain and snow diagnostics

        if (id_rain_clr   > 0) rain_clr_diag(:,:,j+1)     = rain_clr
        if (id_rain_cld   > 0) rain_cld_diag(:,:,j+1)     = rain_cld
        if (id_a_rain_clr > 0) a_rain_clr_diag(:,:,j+1)   = a_rain_clr
        if (id_a_rain_cld > 0) a_rain_cld_diag(:,:,j+1)   = a_rain_cld
        if (id_snow_clr   > 0) snow_clr_diag(:,:,j+1)     = snow_clr
        if (id_snow_cld   > 0) snow_cld_diag(:,:,j+1)     = snow_cld
        if (id_a_snow_clr > 0) a_snow_clr_diag(:,:,j+1)   = a_snow_clr
        if (id_a_snow_cld > 0) a_snow_cld_diag(:,:,j+1)   = a_snow_cld
        if (id_a_precip_clr > 0) a_precip_clr_diag(:,:,j+1) = max(a_rain_clr,a_snow_clr)
        if (id_a_precip_cld > 0) a_precip_cld_diag(:,:,j+1) = max(a_rain_cld,a_snow_cld)

!-----------------------------------------------------------------------
!
!
!       Put rain and ice fluxes into surfrain and surfsnow if the
!       grid point is at the bottom of a column.   If MASK is not
!       present then this code is executed only if j .eq. kdim.
!       IF MASK is present some grid points may be beneath ground. 
!       If a given grid point is at the bottom of the column then
!       the surface values of rain and snow must be created.
!       Also if the MASK is present then the code forces all tenden-
!       cies below ground to be zero. Note that MASK = 1. equals above
!       ground point, MASK = 0. equals below ground point.

        if (present(MASK)) then

             !zero out all tendencies below ground
             ST(:,:,j)=MASK(:,:,j)*ST(:,:,j)
             SQ(:,:,j)=MASK(:,:,j)*SQ(:,:,j)
             SL(:,:,j)=MASK(:,:,j)*SL(:,:,j)
             SI(:,:,j)=MASK(:,:,j)*SI(:,:,j)
             SA(:,:,j)=MASK(:,:,j)*SA(:,:,j)
             if (do_liq_num) then
               SN(:,:,j)=MASK(:,:,j)*SN(:,:,j)
             endif
 
             if (j .lt. kdim) then
                  
                  !bottom of true points in columns which contain some
                  !dummy points
                  where(MASK(:,:,j) .eq. 1. .and. MASK(:,:,j+1) .eq. 0.)
                       surfrain = dtcloud*(rain_clr+rain_cld)
                       surfsnow = dtcloud*(snow_clr+snow_cld)
                       rain_clr = 0.
                       rain_cld = 0.
                       snow_clr = 0.
                       snow_cld = 0.
                       a_rain_clr = 0.
                       a_rain_cld = 0.
                       a_snow_clr = 0.
                       a_snow_cld = 0.
                  end where

             else

                  !bottom of column for those columns which contain no
                  !dummy points
                  where(MASK(:,:,j) .eq. 1.)
                       surfrain = dtcloud*(rain_clr+rain_cld)
                       surfsnow = dtcloud*(snow_clr+snow_cld)
                       rain_clr = 0.
                       rain_cld = 0.
                       snow_clr = 0.
                       snow_cld = 0.
                       a_rain_clr = 0.
                       a_rain_cld = 0.
                       a_snow_clr = 0.
                       a_snow_cld = 0.                  
                  end where

             end if

        else

             !do code if we are at bottom of column
             if (j .eq. kdim) then
                  surfrain = dtcloud*(rain_clr+rain_cld)
                  surfsnow = dtcloud*(snow_clr+snow_cld)
             end if

        end if 
                  

!-----------------------------------------------------------------------
!
!       END LOOP OVER VERTICAL LEVELS
!

        enddo
     call mpp_clock_end(sc_loop)
     call mpp_clock_begin(sc_post_loop)




!-----------------------------------------------------------------------
!
!       INSTANTANEOUS OUTPUT DIAGNOSTICS
!
     
        if (num_strat_pts > 0) then
         do nn=1,num_strat_pts
          if (strat_pts(1,nn) >= is .and. strat_pts(1,nn) <= ie .and.  &
             strat_pts(2,nn) >= js .and. strat_pts(2,nn) <= je) then
                ipt=strat_pts(1,nn); jpt=strat_pts(2,nn)
                i=ipt-is+1; j=jpt-js+1
                unit = open_ieee32_file ('strat.data', action='append')
                write (unit) ipt,jpt,     ql(i,j,:)+SL(i,j,:)
                write (unit) ipt,jpt,     qi(i,j,:)+SI(i,j,:)
                write (unit) ipt,jpt,     qa(i,j,:)+SA(i,j,:)
                write (unit) ipt,jpt,      T(i,j,:)+ST(i,j,:) 
                write (unit) ipt,jpt,     qv(i,j,:)+SQ(i,j,:)
                write (unit) ipt,jpt,     pfull(i,j,:)
                call close_file(unit)
          endif
         enddo
        endif


!-----------------------------------------------------------------------
!
!       DIAGNOSTICS
!
!rab - perform the assignments for ice/liq adjustments diagnostics
        if (max(id_ice_adj,id_ice_adj_col,id_liq_adj,id_liq_adj_col) .gt. 0) then
          freeze_pt=40.
          if (.not. super_choice) freeze_pt=20.
          where (T .le. tfreeze-freeze_pt)
           ice_adj = liq_adj
           liq_adj = 0.
          endwhere
        endif

        used = send_data ( id_droplets, N3D, Time, is, js, 1, rmask=mask )
        used = send_data ( id_droplets_wtd, N3D*ql, Time, is, js, 1, &
                                                     mask = N3D > 0.0 )
        used = send_data ( id_ql_wt, ql, Time, is, js, 1, &
                                                      mask = N3D > 0.0)
        used = send_data ( id_aall, areaall, Time, is, js, 1, rmask=mask )
        used = send_data ( id_aliq, arealiq, Time, is, js, 1, rmask=mask )
        used = send_data ( id_aice, areaice, Time, is, js, 1, rmask=mask )
        used = send_data ( id_rvolume, rvolume, Time, is, js, 1, rmask=mask )
        used = send_data ( id_autocv, areaautocv, Time, is, js, 1, rmask=mask )
        used = send_data ( id_vfall, vfalldiag, Time, is, js, 1, rmask=mask )  

        if (do_budget_diag) then
         !------- set up half level mask --------
         if (allocated(mask3)) deallocate (mask3)
         allocate(mask3(size(T,1),size(T,2),size(T,3)+1))
         mask3(:,:,1:(kdim+1)) = 1.
         if (present(mask)) then
             where (mask(:,:,1:kdim) <= 0.5)
                  mask3(:,:,2:(kdim+1)) = 0.
             end where
         endif
        endif
        
     !cloud liquid, droplet number and rain diagnostics
        used = send_data ( id_qldt_cond, qldt_cond, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_evap, qldt_evap, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_eros, qldt_eros, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_accr, qldt_accr, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_auto, qldt_auto, Time, is, js, 1, rmask=mask )
        used = send_data ( id_liq_adj, liq_adj, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_fill, qldt_fill, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_berg, qldt_berg, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_freez, qldt_freez, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_rime, qldt_rime, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qldt_destr, qldt_destr, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qndt_cond, qndt_cond, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qndt_evap, qndt_evap, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qndt_fill, qndt_fill, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qndt_destr, qndt_destr, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qndt_super, qndt_super, Time, is, js, 1, rmask=mask )
        used = send_data ( id_debug1, debug1, Time, is, js, 1, rmask=mask )

        if ( id_debug2 > 0 ) then
          debug2=debug2**0.5
          used = send_data ( id_debug2, debug2, Time, is, js, 1, rmask=mask )
        endif

        used = send_data ( id_debug3, debug3, Time, is, js, 1, rmask=mask )
        used = send_data ( id_debug4, debug4, Time, is, js, 1, rmask=mask )
        used = send_data ( id_rain_evap, rain_evap, Time, is, js, 1, rmask=mask )
        used = send_data ( id_rain_clr, rain_clr_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_a_rain_clr, a_rain_clr_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_rain_cld, rain_cld_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_a_rain_cld, a_rain_cld_diag, Time, is, js, 1,rmask=mask3 )
        used = send_data ( id_a_precip_clr, a_precip_clr_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_a_precip_cld, a_precip_cld_diag, Time, is, js, 1,rmask=mask3 )
       
        used = send_data ( id_lsf_strat, lsf_strat, Time, is, js, 1, rmask=mask )
      
        if ( max(id_lcf_strat,id_mfls_strat) > 0 ) then
          where (omega(:,:,j)+grav*Mc(:,:,j) .lt. 0 .and. lsf_strat(:,:,j) .eq.1)
             lcf_strat(:,:,j) = 1.
             mfls_strat(:,:,j) = omega(:,:,j)+grav*Mc(:,:,j)
          end where
          used = send_data ( id_lcf_strat, lcf_strat, Time, is, js, 1, rmask=mask )
          used = send_data ( id_mfls_strat, mfls_strat, Time, is, js, 1, rmask=mask )
        end if

     !ice and snow diagnostics        
        used = send_data ( id_qidt_dep, qidt_dep, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qidt_subl, qidt_subl, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qidt_eros, qidt_eros, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qidt_fall, qidt_fall, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qidt_melt, qidt_melt, Time, is, js, 1, rmask=mask )
        used = send_data ( id_ice_adj, ice_adj, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qidt_destr, qidt_destr, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qidt_fill, qidt_fill, Time, is, js, 1, rmask=mask )
        used = send_data ( id_snow_clr, snow_clr_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_a_snow_clr, a_snow_clr_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_snow_cld, snow_cld_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_a_snow_cld, a_snow_cld_diag, Time, is, js, 1, rmask=mask3 )
        used = send_data ( id_snow_subl, snow_subl, Time, is, js, 1, rmask=mask )
        used = send_data ( id_snow_melt, snow_melt, Time, is, js, 1, rmask=mask )


     !cloud fraction diagnostics        
        used = send_data ( id_qadt_lsform, qadt_lsform, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qadt_lsdiss, qadt_lsdiss, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qadt_rhred, qadt_rhred, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qadt_eros, qadt_eros, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qadt_fill, qadt_fill, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qadt_super, qadt_super, Time, is, js, 1, rmask=mask )
        used = send_data ( id_qadt_destr, qadt_destr, Time, is, js, 1, rmask=mask )
        
           
        !-------write out column integrated diagnostics------!

!yim: in-cloud droplet column burden

        if (id_droplets_col > 0) then
          if (present (qn)) then
            if (do_liq_num ) then
              N3D_col(:,:) = 0.
              do k = 1, kdim
                do j=1,jdim
                  do i=1,idim
                    deltpg(i,j) = (phalf(i,j,k+1)-phalf(i,j,k))/grav
                    if (present(MASK)) then
                      deltpg(i,j)=deltpg(i,j)*MASK(i,j,k)
                    endif
                    if (ql(i,j,k) > qmin .and. &
                        qa(i,j,k) > qmin .and. &
                        qn(i,j,k) > qmin ) then      
                       N3D_col(i,j) = N3D_col(i,j) + qn(i,j,k)*  &
                                      airdens(i,j,k)*deltpg(i,j)*  &
                                      1.e-6/min(qa(i,j,k),1.)
                    endif
                  end do
                end do
              end do
              used = send_data ( id_droplets_col, N3D_col, Time, is, js)
            endif
          endif
        endif

        !liquid and rain diagnostics
        if ( id_ql_cond_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_cond    (:,:,j) = qldt_cond   (:,:,j)*deltpg        
             enddo
             do j = kdim-1, 1, -1
                  qldt_cond    (:,:,kdim) = qldt_cond    (:,:,kdim) &
                                          + qldt_cond    (:,:,j)
             enddo
             used = send_data ( id_ql_cond_col, qldt_cond(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_evap_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_evap    (:,:,j) = qldt_evap   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qldt_evap    (:,:,kdim) = qldt_evap    (:,:,kdim) &
                                          + qldt_evap    (:,:,j)             
             enddo
             used = send_data ( id_ql_evap_col, qldt_evap(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_eros_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_eros    (:,:,j) = qldt_eros   (:,:,j)*deltpg             
             enddo
             do j = kdim-1, 1, -1
                  qldt_eros    (:,:,kdim) = qldt_eros    (:,:,kdim) &
                                          + qldt_eros    (:,:,j)
             enddo
             used = send_data ( id_ql_eros_col, qldt_eros(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_accr_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_accr    (:,:,j) = qldt_accr   (:,:,j)*deltpg             
             enddo
             do j = kdim-1, 1, -1
                  qldt_accr    (:,:,kdim) = qldt_accr    (:,:,kdim) &
                                          + qldt_accr    (:,:,j)
             enddo
             used = send_data ( id_ql_accr_col, qldt_accr(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_auto_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_auto    (:,:,j) = qldt_auto   (:,:,j)*deltpg             
             enddo
             do j = kdim-1, 1, -1
                  qldt_auto    (:,:,kdim) = qldt_auto    (:,:,kdim) &
                                          + qldt_auto    (:,:,j)
             enddo
             used = send_data ( id_ql_auto_col, qldt_auto(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_berg_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_berg    (:,:,j) = qldt_berg   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qldt_berg    (:,:,kdim) = qldt_berg    (:,:,kdim) &
                                          + qldt_berg    (:,:,j)
             enddo
             used = send_data ( id_ql_berg_col, qldt_berg(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_freez_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_freez   (:,:,j) = qldt_freez  (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qldt_freez   (:,:,kdim) = qldt_freez   (:,:,kdim) &
                                          + qldt_freez   (:,:,j)
             enddo
             used = send_data ( id_ql_freez_col, qldt_freez(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_destr_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_destr   (:,:,j) = qldt_destr  (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qldt_destr   (:,:,kdim) = qldt_destr   (:,:,kdim) &
                                          + qldt_destr   (:,:,j)
             enddo
             used = send_data ( id_ql_destr_col, qldt_destr(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_rime_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_rime    (:,:,j) = qldt_rime   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qldt_rime    (:,:,kdim) = qldt_rime    (:,:,kdim) &
                                          + qldt_rime    (:,:,j)
             enddo
             used = send_data ( id_ql_rime_col, qldt_rime(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ql_fill_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qldt_fill    (:,:,j) = qldt_fill   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qldt_fill    (:,:,kdim) = qldt_fill    (:,:,kdim) &
                                          + qldt_fill    (:,:,j)
             enddo
             used = send_data ( id_ql_fill_col, qldt_fill(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_liq_adj_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  liq_adj      (:,:,j) = liq_adj     (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  liq_adj      (:,:,kdim) = liq_adj      (:,:,kdim) &
                                          + liq_adj      (:,:,j)
             enddo
             used = send_data ( id_liq_adj_col, liq_adj(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_rain_evap_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  rain_evap    (:,:,j) = rain_evap   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  rain_evap    (:,:,kdim) = rain_evap    (:,:,kdim) &
                                          + rain_evap    (:,:,j)
             enddo
             used = send_data ( id_rain_evap_col, rain_evap(:,:,kdim), &
                                  Time, is, js )
        endif
   
        !drop number diagnostics
        if ( id_qn_cond_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qndt_cond    (:,:,j) = qndt_cond   (:,:,j)*deltpg        
             enddo
             do j = kdim-1, 1, -1
                  qndt_cond    (:,:,kdim) = qndt_cond    (:,:,kdim) &
                                          + qndt_cond    (:,:,j)
             enddo
             used = send_data ( id_qn_cond_col, qndt_cond(:,:,kdim), &
                                  Time, is, js )
        endif

        if ( id_qn_evap_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qndt_evap    (:,:,j) = qndt_evap   (:,:,j)*deltpg        
             enddo
             do j = kdim-1, 1, -1
                  qndt_evap    (:,:,kdim) = qndt_evap    (:,:,kdim) &
                                          + qndt_evap    (:,:,j)
             enddo
             used = send_data ( id_qn_evap_col, qndt_evap(:,:,kdim), &
                                  Time, is, js )
        endif

        if ( id_qn_fill_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qndt_fill    (:,:,j) = qndt_fill   (:,:,j)*deltpg        
             enddo
             do j = kdim-1, 1, -1
                  qndt_fill    (:,:,kdim) = qndt_fill    (:,:,kdim) &
                                          + qndt_fill    (:,:,j)
             enddo
             used = send_data ( id_qn_fill_col, qndt_fill(:,:,kdim), &
                                  Time, is, js )
        endif

        if ( id_qn_destr_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qndt_destr    (:,:,j) = qndt_destr   (:,:,j)*deltpg        
             enddo
             do j = kdim-1, 1, -1
                  qndt_destr    (:,:,kdim) = qndt_destr    (:,:,kdim) &
                                          + qndt_destr    (:,:,j)
             enddo
             used = send_data ( id_qn_destr_col, qndt_destr(:,:,kdim), &
                                  Time, is, js )
        endif

        if ( id_qn_super_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qndt_super    (:,:,j) = qndt_super   (:,:,j)*deltpg        
             enddo
             do j = kdim-1, 1, -1
                  qndt_super    (:,:,kdim) = qndt_super    (:,:,kdim) &
                                          + qndt_super    (:,:,j)
             enddo
             used = send_data ( id_qn_super_col, qndt_super(:,:,kdim), &
                                  Time, is, js )
        endif
   
        !ice and snow diagnostics   
        if ( id_qi_fall_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_fall    (:,:,j) = qidt_fall   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_fall    (:,:,kdim) = qidt_fall    (:,:,kdim) &
                                          + qidt_fall    (:,:,j)
             enddo
             used = send_data ( id_qi_fall_col, qidt_fall(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_qi_fill_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_fill    (:,:,j) = qidt_fill   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_fill    (:,:,kdim) = qidt_fill    (:,:,kdim) &
                                          + qidt_fill    (:,:,j)
             enddo
             used = send_data ( id_qi_fill_col, qidt_fill(:,:,kdim), &
                                          Time, is, js )
        endif
   
        if ( id_qi_dep_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_dep     (:,:,j) = qidt_dep    (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_dep     (:,:,kdim) = qidt_dep     (:,:,kdim)    &
                                          + qidt_dep     (:,:,j)
             enddo
             used = send_data ( id_qi_dep_col, qidt_dep(:,:,kdim),     &
                                  Time, is, js )
        endif
   
        if ( id_qi_subl_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_subl    (:,:,j) = qidt_subl   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_subl    (:,:,kdim) = qidt_subl    (:,:,kdim) &
                                          + qidt_subl    (:,:,j)
             enddo
             used = send_data ( id_qi_subl_col, qidt_subl(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_qi_eros_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_eros    (:,:,j) = qidt_eros   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_eros    (:,:,kdim) = qidt_eros    (:,:,kdim) &
                                          + qidt_eros    (:,:,j)
             enddo
             used = send_data ( id_qi_eros_col, qidt_eros(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_qi_destr_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_destr   (:,:,j) = qidt_destr  (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_destr   (:,:,kdim) = qidt_destr   (:,:,kdim) &
                                          + qidt_destr   (:,:,j)
             enddo
             used = send_data ( id_qi_destr_col, qidt_destr(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_qi_melt_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qidt_melt    (:,:,j) = qidt_melt   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qidt_melt    (:,:,kdim) = qidt_melt    (:,:,kdim) &
                                          + qidt_melt    (:,:,j)
             enddo
             used = send_data ( id_qi_melt_col, qidt_melt(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_ice_adj_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  ice_adj     (:,:,j)  = ice_adj     (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  ice_adj      (:,:,kdim) = ice_adj      (:,:,kdim) &
                                          + ice_adj      (:,:,j)
             enddo
             used = send_data ( id_ice_adj_col,  ice_adj(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_snow_melt_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  snow_melt    (:,:,j) = snow_melt   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  snow_melt    (:,:,kdim) = snow_melt    (:,:,kdim) &
                                          + snow_melt    (:,:,j)
             enddo
             used = send_data ( id_snow_melt_col, snow_melt(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_snow_subl_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  snow_subl    (:,:,j) = snow_subl   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  snow_subl    (:,:,kdim) = snow_subl    (:,:,kdim) &
                                          + snow_subl    (:,:,j)
             enddo
             used = send_data ( id_snow_subl_col, snow_subl(:,:,kdim), &
                                  Time, is, js )
        endif


        !cloud fraction and volume diagnostics
        if ( id_qa_lsform_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_lsform  (:,:,j) = qadt_lsform (:,:,j)*deltpg             
             enddo
             do j = kdim-1, 1, -1
                  qadt_lsform  (:,:,kdim) = qadt_lsform  (:,:,kdim) &
                                          + qadt_lsform  (:,:,j)
             enddo
             used = send_data (id_qa_lsform_col, qadt_lsform(:,:,kdim),&
                                  Time, is, js )
        endif

        if ( id_qa_lsdiss_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_lsdiss  (:,:,j) = qadt_lsdiss (:,:,j)*deltpg             
             enddo
             do j = kdim-1, 1, -1
                  qadt_lsdiss  (:,:,kdim) = qadt_lsdiss  (:,:,kdim) &
                                          + qadt_lsdiss  (:,:,j)
             enddo
             used = send_data (id_qa_lsdiss_col, qadt_lsdiss(:,:,kdim),&
                                  Time, is, js )
        endif

        if ( id_qa_rhred_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_rhred   (:,:,j) = qadt_rhred  (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qadt_rhred   (:,:,kdim) = qadt_rhred   (:,:,kdim) &
                                          + qadt_rhred   (:,:,j)
             enddo
             used = send_data ( id_qa_rhred_col, qadt_rhred(:,:,kdim), &
                                  Time, is, js )
        endif

        if ( id_qa_eros_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_eros    (:,:,j) = qadt_eros   (:,:,j)*deltpg             
             enddo
             do j = kdim-1, 1, -1
                  qadt_eros    (:,:,kdim) = qadt_eros    (:,:,kdim) &
                                          + qadt_eros    (:,:,j)
             enddo
             used = send_data ( id_qa_eros_col, qadt_eros(:,:,kdim), &
                                  Time, is, js )
        endif
   
        if ( id_qa_fill_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_fill    (:,:,j) = qadt_fill   (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qadt_fill    (:,:,kdim) = qadt_fill    (:,:,kdim) &
                                          + qadt_fill    (:,:,j)
             enddo
             used = send_data ( id_qa_fill_col, qadt_fill(:,:,kdim), &
                                  Time, is, js )
        endif
           
        if ( id_qa_super_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_super   (:,:,j) = qadt_super  (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qadt_super   (:,:,kdim) = qadt_super   (:,:,kdim) &
                                          + qadt_super   (:,:,j)
             enddo
             used = send_data ( id_qa_super_col, qadt_super(:,:,kdim), &
                                  Time, is, js )
        endif
                 
        if ( id_qa_destr_col > 0 ) then
             do j = 1, kdim
                  deltpg = (phalf(:,:,j+1)-phalf(:,:,j))/grav
                  if (present(MASK)) deltpg=deltpg*MASK(:,:,j)
                  qadt_destr   (:,:,j) = qadt_destr  (:,:,j)*deltpg
             enddo
             do j = kdim-1, 1, -1
                  qadt_destr   (:,:,kdim) = qadt_destr   (:,:,kdim) &
                                          + qadt_destr   (:,:,j)
             enddo
             used = send_data ( id_qa_destr_col, qadt_destr(:,:,kdim), &
                                  Time, is, js )
        endif


        !other stuff

        
   
        !---------------------------------
        !deallocate space for diagnostics

        if (allocated(areaall))  deallocate(areaall)
        if (allocated(arealiq)) deallocate(arealiq)
        if (allocated(areaice)) deallocate(areaice)
        if (allocated(rvolume)) deallocate(rvolume)
        if (allocated(areaautocv)) deallocate(areaautocv)
        if (allocated(vfalldiag)) deallocate(vfalldiag)
        if (allocated(qndt_cond)) deallocate (qndt_cond)
        if (allocated(qndt_evap)) deallocate (qndt_evap)
        if (allocated(qndt_fill)) deallocate (qndt_fill)
        if (allocated(qndt_destr)) deallocate (qndt_destr)
        if (allocated(qndt_super)) deallocate (qndt_super)
        if (allocated(qldt_cond)) deallocate (qldt_cond)
        if (allocated(qldt_evap)) deallocate (qldt_evap)
        if (allocated(qldt_eros)) deallocate (qldt_eros)
        if (allocated(qldt_fill)) deallocate (qldt_fill)
        if (allocated(qldt_accr)) deallocate (qldt_accr)
        if (allocated(qldt_auto)) deallocate (qldt_auto)
        if (allocated(qldt_freez)) deallocate (qldt_freez)
        if (allocated(qldt_berg)) deallocate (qldt_berg)
        if (allocated(qldt_destr)) deallocate (qldt_destr)
        if (allocated(qldt_rime)) deallocate (qldt_rime)
        if (allocated(rain_clr_diag)) deallocate (rain_clr_diag)
        if (allocated(rain_cld_diag)) deallocate (rain_cld_diag)
        if (allocated(a_rain_clr_diag)) deallocate (a_rain_clr_diag)
        if (allocated(a_rain_cld_diag)) deallocate (a_rain_cld_diag)
        if (allocated(liq_adj)) deallocate (liq_adj)
        if (allocated(rain_evap)) deallocate (rain_evap)
        if (allocated(qidt_fall)) deallocate (qidt_fall)
        if (allocated(qidt_fill)) deallocate (qidt_fill)
        if (allocated(qidt_melt)) deallocate (qidt_melt)
        if (allocated(qidt_dep)) deallocate (qidt_dep)
        if (allocated(qidt_subl)) deallocate (qidt_subl)
        if (allocated(qidt_eros)) deallocate (qidt_eros)
        if (allocated(qidt_destr)) deallocate (qidt_destr)
        if (allocated(snow_clr_diag)) deallocate (snow_clr_diag)
        if (allocated(snow_cld_diag)) deallocate (snow_cld_diag)
        if (allocated(a_snow_clr_diag)) deallocate (a_snow_clr_diag)
        if (allocated(a_snow_cld_diag)) deallocate (a_snow_cld_diag)
        if (allocated(snow_subl)) deallocate (snow_subl)
        if (allocated(snow_melt)) deallocate (snow_melt)
        if (allocated(ice_adj)) deallocate (ice_adj)
        if (allocated(qadt_lsform)) deallocate (qadt_lsform)
        if (allocated(qadt_lsdiss)) deallocate (qadt_lsdiss)
        if (allocated(qadt_eros)) deallocate (qadt_eros)
        if (allocated(qadt_fill)) deallocate (qadt_fill)
        if (allocated(qadt_super)) deallocate (qadt_super)
        if (allocated(qadt_rhred)) deallocate (qadt_rhred)
        if (allocated(qadt_destr)) deallocate (qadt_destr)
        if (allocated(a_precip_cld_diag)) deallocate (a_precip_cld_diag)
        if (allocated(a_precip_clr_diag)) deallocate (a_precip_clr_diag)
        if (allocated(mask3)) deallocate (mask3)
        if (allocated(lsf_strat)) deallocate (lsf_strat)
        if (allocated(lcf_strat)) deallocate (lcf_strat)
        if (allocated(mfls_strat)) deallocate (mfls_strat)

     call mpp_clock_end(sc_post_loop)
        
!-----------------------------------------------------------------------
!
!
!       end of subroutine



end subroutine strat_cloud



!#####################################################################

subroutine aerosol_effects (is, js, Time, phalf, airdens, T, &
                            concen_dust_sub, totalmass1, Aerosol, mask)

integer, intent (in)                   :: is,js
type(time_type), intent (in)           :: Time
real, dimension(:,:,:), intent(in )   :: phalf, airdens, T 
real, dimension(:,:,:), intent(out)        :: concen_dust_sub
real, dimension(:,:,:,:), intent(out)            :: totalmass1
type(aerosol_type), intent (in), optional      :: Aerosol  
real, intent (in), optional, dimension(:,:,:) :: mask

      real, dimension(size(T,1),size(T,2),size(T,3)) :: pthickness
      real, dimension(size(T,1),size(T,2),size(T,3)) :: concen, &
                                    concen_all_sub, &
                                    concen_ss_sub, concen_ss_sup,&
                                    concen_om, concen_na, concen_an
      integer  :: i,j,k,  na , s
      integer  :: idim, jdim, kdim
      logical :: used

      idim = size(T,1)
      jdim = size(T,2)
      kdim = size(T,3)

      concen_dust_sub(:,:,:) = 0.
      totalmass1(:,:,:,:) = 0.

      if (id_sulfate > 0) then
        concen_an(:,:,:) = 0.
        concen_na(:,:,:) = 0.
        concen(:,:,:) = 0.
      endif

      if (use_online_aerosol) then
        concen_ss_sub(:,:,:) = 0.
        concen_ss_sup(:,:,:) = 0.
        concen_all_sub(:,:,:) = 0.
      endif

      do k = 1,kdim
        do j = 1,jdim
          do i = 1,idim
            if (phalf(i,j,k) < 1.0) then
              pthickness(i,j,k) = (phalf(i,j,k+1) - phalf(i,j,k))/&
                                               grav/airdens(i,j,k)
            else
              pthickness(i,j,k) = log(phalf(i,j,k+1)/ &
                            phalf(i,j,k))*8.314*T(i,j,k)/(9.8*0.02888)
            end if
          end do
        end do
      end do

     if (present (Aerosol)) then
       if (do_liq_num) then
         if (use_online_aerosol) then
           do na = 1,size(Aerosol%aerosol,4)               
             if (trim(Aerosol%aerosol_names(na)) == 'so4' .or. &
                 trim(Aerosol%aerosol_names(na)) == 'so4_anthro' .or.&
                 trim(Aerosol%aerosol_names(na)) == 'so4_natural')  &
                                                                 then
               do k = 1,kdim
                 do j = 1,jdim
                   do i = 1,idim
                     totalmass1(i,j,k,1) = totalmass1(i,j,k,1) + &
                                           Aerosol%aerosol(i,j,k,na)
                   end do
                 end do
               end do
             else if(trim(Aerosol%aerosol_names(na)) == 'omphilic' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'omphobic') &
                                                                 then
               do k = 1,kdim
                 do j = 1,jdim
                   do i = 1,idim
                     totalmass1(i,j,k,4) = totalmass1(i,j,k,4) +  &
                                           Aerosol%aerosol(i,j,k,na)
                   end do
                 end do
               end do
             else if(trim(Aerosol%aerosol_names(na)) == 'seasalt1' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'seasalt2') &
                                                                   then
               do k = 1,kdim
                 do j = 1,jdim
                   do i = 1,idim
                     concen_ss_sub(i,j,k) = concen_ss_sub(i,j,k) +  &
                                            Aerosol%aerosol(i,j,k,na)
                   end do
                 end do
               end do
             else if(trim(Aerosol%aerosol_names(na)) == 'seasalt3' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'seasalt4' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'seasalt5')  &
                                                                  then
               do k = 1,kdim
                 do j = 1,jdim
                   do i = 1,idim
                     concen_ss_sup(i,j,k) = concen_ss_sup(i,j,k) +  &
                                            Aerosol%aerosol(i,j,k,na)
                   end do
                 end do
               end do
             else if(trim(Aerosol%aerosol_names(na)) == 'bcphilic' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'bcphobic' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'dust1' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'dust2' .or.&
                     trim(Aerosol%aerosol_names(na)) == 'dust3')  &
                                                                  then
               do k = 1,kdim
                 do j = 1,jdim
                   do i = 1,idim
                     concen_all_sub(i,j,k) = concen_all_sub(i,j,k) +  &
                                             Aerosol%aerosol(i,j,k,na)
                   end do
                 end do
               end do
             endif
             if (do_dust_berg) then
               if (trim(Aerosol%aerosol_names(na)) == 'dust1' .or. &
                   trim(Aerosol%aerosol_names(na)) == 'dust2' .or. &
                   trim( Aerosol%aerosol_names(na)) == 'dust3') then
                 do k = 1,kdim
                   do j = 1,jdim
                     do i = 1,idim
                       concen_dust_sub(i,j,k) =    &
                                           concen_dust_sub(i,j,k) +   &
                                              Aerosol%aerosol(i,j,k,na)
                     end do
                   end do
                 end do
               endif
             endif
           end do
!        endif
!      endif
          
!       if (do_liq_num) then
!         if (use_online_aerosol) then
           do k = 1,kdim
             do j = 1,jdim
               do i = 1,idim
                 totalmass1(i,j,k,3) = concen_ss_sub(i,j,k)
                 totalmass1(i,j,k,2) = concen_all_sub(i,j,k) + &
                                       totalmass1(i,j,k,4) + &
                                       concen_ss_sub(i,j,k)
               end do
             end do
           end do
           if (use_sub_seasalt) then
           else
             do k = 1,kdim
               do j = 1,jdim
                 do i = 1,idim
                   totalmass1(i,j,k,3) = concen_ss_sub(i,j,k) +  &
                                                  concen_ss_sup(i,j,k)
                 end do
               end do
             end do
           endif

           if (id_sulfate > 0) then
             do k = 1,kdim
               do j = 1,jdim
                 do i = 1,idim
                   concen(i,j,k) = 0.7273*totalmass1(i,j,k,1)/  &
                                       pthickness(i,j,k)*1.0e9
                 end do
               end do
             end do
           endif
         
           do k = 1,kdim
             do j = 1,jdim
               do i = 1,idim
                 concen_ss_sub(i,j,k) = concen_ss_sub(i,j,k)/  &
                                              pthickness(i,j,k)*1.0e9
                 concen_ss_sup(i,j,k) = concen_ss_sup(i,j,k)/  &
                                              pthickness(i,j,k)*1.0e9
               end do
             end do
           end do

         else  ! (use_online_aerosol)
           if (do_dust_berg) then
!     YMice submicron dust (NO. 14 to NO. 18)
             do s = 14,18
               do k = 1,kdim
                 do j = 1,jdim
                   do i = 1,idim
                     concen_dust_sub(i,j,k) = concen_dust_sub(i,j,k)+ &
                                              Aerosol%aerosol(i,j,k,s)
                   end do
                 end do
               end do
             end do
           endif

           if (id_sulfate > 0) then
             do k = 1,kdim
               do j = 1,jdim
                 do i = 1,idim
!     anthro. and natural sulfate concentration (ug so4/m3)
                   concen_an(i,j,k) = 0.7273*Aerosol%aerosol(i,j,k,1)/&
                                                pthickness(i,j,k)*1.0e9
                   concen_na(i,j,k) = 0.7273*Aerosol%aerosol(i,j,k,2)/&
                                                pthickness(i,j,k)*1.0e9
                   concen(i,j,k) = concen_an(i,j,k) + concen_na(i,j,k)
                 end do
               end do
             end do
           endif

           do k = 1,kdim
             do j = 1,jdim
               do i = 1,idim
!offline
! NO. 1 natural Sulfate; NO. 2 anthro. sulfate; NO. 3 Sea Salt; NO. 4 Or        ganics
                 totalmass1(i,j,k,1) = Aerosol%aerosol(i,j,k,2)
                 totalmass1(i,j,k,2) = Aerosol%aerosol(i,j,k,1)
                 totalmass1(i,j,k,3) = sea_salt_scale*  &
                                       Aerosol%aerosol(i,j,k,5)
                 totalmass1(i,j,k,4) = om_to_oc*  &
                                       Aerosol%aerosol(i,j,k,3)
               end do
             end do
           end do
         endif ! (use_online_aerosol)

         do na = 1, 4
           do k = 1,kdim
             do j = 1,jdim
               do i = 1,idim
                 totalmass1(i,j,k,na) = totalmass1(i,j,k,na)/  &
                                        pthickness(i,j,k)*1.0e9*1.0e-12
               end do
             end do
           end do
         end do
         if (do_dust_berg) then
           do k = 1,kdim
             do j = 1,jdim
               do i = 1,idim
! submicron dust concentration (ug/m3) (NO. 2 to NO. 4)
                 concen_dust_sub(i,j,k) = concen_dust_sub(i,j,k)/ &
                                              pthickness(i,j,k)*1.0e9 
               end do
             end do
           end do
         endif

         if (id_sulfate > 0) then
           used = send_data ( id_sulfate, concen, Time, is, js, 1,&
                              rmask=mask )
         end if

         if (use_online_aerosol) then
           if (id_seasalt_sub > 0) then
             used = send_data (id_seasalt_sub, concen_ss_sub, Time, &
                               is, js, 1, rmask=mask )
           endif
   
           if (id_seasalt_sup > 0) then
             used = send_data (id_seasalt_sup, concen_ss_sup, Time, &
                               is, js, 1, rmask=mask )
           endif
         endif

         if (id_om > 0) then
           do k = 1,kdim
             do j = 1,jdim
               do i = 1,idim
                 concen_om(i,j,k) = totalmass1(i,j,k,2)*1.0e12
               end do
             end do
           end do
           used = send_data (id_om, concen_om, Time, is, js, 1,&
                             rmask=mask )
         endif
       endif  ! (do_liq_num)
     endif ! (Present(Aerosol))

!----------------------------------------------------------------------


end subroutine aerosol_effects


!#######################################################################
!#######################################################################


! <SUBROUTINE NAME="strat_cloud_end">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!   This writes out a restart (if needed).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call strat_cloud_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine strat_cloud_end()

  integer                                :: unit

!        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!       This subroutine writes out radturbten to a restart file.
!        
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  if(.not. module_is_initialized) return
       
  if( do_netcdf_restart) then
    call strat_cloud_restart

  else
    if (mpp_pe() == mpp_root_pe()) then
       call mpp_error ('strat_cloud_mod', 'Writing native formatted restart file.', NOTE)
    endif
    unit = open_restart_file ('RESTART/strat_cloud.res', ACTION='write')
    if (mpp_pe() == mpp_root_pe()) then
       write (unit) restart_versions(size(restart_versions(:)))
    endif
    call write_data (unit, nsum)
    call write_data (unit, qlsum)
    call write_data (unit, qisum)
    call write_data (unit, cfsum)
    call close_file (unit)
  endif
!
    !-------------------------------------------
    ! end beta distribution module if used

  if (do_pdf_clouds) call beta_dist_end
  module_is_initialized = .false.

end subroutine strat_cloud_end


!#######################################################################
!#######################################################################
! <SUBROUTINE NAME="strat_cloud_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine strat_cloud_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

  if( do_netcdf_restart) then
     if (mpp_pe() == mpp_root_pe()) then
        call mpp_error ('strat_cloud_mod', 'Writing netCDF formatted restart file: RESTART/strat_cloud.res.nc', NOTE)
     endif
     call save_restart(Str_restart, timestamp)
     if(in_different_file) call  save_restart(Til_restart, timestamp)
  else
    call error_mesg ('strat_cloud_mod', &
         'Native intermediate restart files are not supported.', FATAL)
  endif

end subroutine strat_cloud_restart
! </SUBROUTINE> NAME="strat_cloud_restart"
 

!#######################################################################
!#######################################################################


! <SUBROUTINE NAME="strat_cloud_sum">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!     This increments cloud variables for passing to radiation.
!     It is expected that this will become obsolete soon.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  strat_cloud_sum (is, js, ql, qi, cf)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!        Starting integer for longitude window.
!  </IN>
!  <IN NAME="js" TYPE="integer">
!        Starting integer for latitude window.
!  </IN>
!  <IN NAME="ql" TYPE="real">
!        Cloud liquid water specific humidity (kg/kg)
!  </IN>
!  <IN NAME="qi" TYPE="real">
!        Cloud ice water specific humidity (kg/kg)
!  </IN>
!  <IN NAME="cf" TYPE="real">
!        Cloud fraction (fraction, 0-1)
!  </IN>
! </SUBROUTINE>
!
 subroutine strat_cloud_sum (is, js, ql, qi, cf)


!-----------------------------------------------------------------------
   integer, intent(in)                   :: is, js
      real, intent(in), dimension(:,:,:) :: ql, qi, cf
!-----------------------------------------------------------------------
   integer :: ie, je

   if(.not.module_is_initialized) then
     call error_mesg('strat_cloud_sum','strat_cloud is not initialized',FATAL)
   endif

   ie = is + SIZE(ql,1) - 1
   je = js + SIZE(ql,2) - 1
     
!--------- use time-averaged or instantaneous clouds -----------

  if (do_average) then
       nsum(is:ie,js:je)   =  nsum(is:ie,js:je)   +  1
       qlsum(is:ie,js:je,:) = qlsum(is:ie,js:je,:) + ql
       qisum(is:ie,js:je,:) = qisum(is:ie,js:je,:) + qi
       cfsum(is:ie,js:je,:) = cfsum(is:ie,js:je,:) + cf
  else
       nsum(is:ie,js:je)   =  1
       qlsum(is:ie,js:je,:) = ql
       qisum(is:ie,js:je,:) = qi
       cfsum(is:ie,js:je,:) = cf
  endif

!-----------------------------------------------------------------------


 end subroutine strat_cloud_sum


!#######################################################################
!#######################################################################


! <SUBROUTINE NAME="strat_cloud_avg">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!      Averaging routine for cloud variables to be passed to radiation.
!      Expected to be removed shortly.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call  strat_cloud_avg (is, js, ql, qi, cf, ierr)
!
!  </TEMPLATE>
!  <IN NAME="is" TYPE="integer">
!      Starting integer for longitude window.
!  </IN>
!  <IN NAME="js" TYPE="integer">
!      Starting integer for latitude window.
!  </IN>
!  <OUT NAME="ql" TYPE="real">
!      Cloud liquid water specific humidity (kg/kg)
!  </OUT>
!  <OUT NAME="qi" TYPE="real">
!      Cloud ice water specific humidity (kg/kg)
!  </OUT>
!  <OUT NAME="cf" TYPE="real">
!      Cloud fraction (0-1)
!  </OUT>
!  <OUT NAME="ierr" TYPE="integer">
!      Error integer.
!  </OUT>
! </SUBROUTINE>
!
 subroutine strat_cloud_avg (is, js, ql, qi, cf, ierr)


!-----------------------------------------------------------------------
   integer, intent(in)                    :: is, js
   real, intent(out), dimension(:,:,:) :: ql, qi, cf
   integer, intent(out)                   :: ierr
!-----------------------------------------------------------------------
   integer :: ie, je, num, k
!-----------------------------------------------------------------------
      
   if(.not.module_is_initialized) then
     call error_mesg('strat_cloud_avg','strat_cloud is not initialized',FATAL)
   endif

   if (SIZE(ql,3) /= SIZE(qlsum,3)) then
     call error_mesg ('strat_cloud_avg in strat_cloud_mod',  &
                              'input argument has the wrong SIZE',FATAL)
   endif

   ie = is + SIZE(ql,1) - 1
   je = js + SIZE(ql,2) - 1
   num = count(nsum(is:ie,js:je) == 0)

   if (num > 0) then

!     ----- no average, return error flag -----

      ierr = 1

   else

!     ----- compute average -----

      do k = 1, SIZE(ql,3)
        ql(:,:,k) = qlsum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
        qi(:,:,k) = qisum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
        cf(:,:,k) = cfsum(is:ie,js:je,k) / float(nsum(is:ie,js:je))
      enddo
      ierr = 0

   endif

    nsum(is:ie,js:je)   = 0
   qlsum(is:ie,js:je,:) = 0.0
   qisum(is:ie,js:je,:) = 0.0
   cfsum(is:ie,js:je,:) = 0.0

!-----------------------------------------------------------------------


 end subroutine strat_cloud_avg


!#######################################################################
!#######################################################################


! <FUNCTION NAME="do_strat_cloud">
!  <OVERVIEW>
!   
!  </OVERVIEW>
!  <DESCRIPTION>
!     Logical function to indicate whether or not strat_cloud is running.
!  </DESCRIPTION>
!  <TEMPLATE>
!   result =  do_strat_cloud ( ) result (answer)
!
!  </TEMPLATE>
! </FUNCTION>
!
 function do_strat_cloud ( ) result (answer)


   logical :: answer
   answer = strat_cloud_on


 end function do_strat_cloud


!#######################################################################
!#######################################################################


!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  ppm2m_sak --- Piecewise parabolic method for fields
!
! !INTERFACE:
 subroutine ppm2m_sak(a4, delp, km, kmap, i1, i2, iv, kord)

 implicit none

! !INPUT PARAMETERS:
 integer, intent(in):: iv      ! iv =-1: winds
                               ! iv = 0: positive definite scalars
                               ! iv = 1: others
 integer, intent(in):: i1      ! Starting longitude
 integer, intent(in):: i2      ! Finishing longitude
 integer, intent(in):: km      ! vertical dimension
 integer, intent(in):: kmap    ! partial remap to start
 integer, intent(in):: kord    ! Order (or more accurately method no.):
                               ! 
 real, intent(in):: delp(i1:i2,km)     ! layer pressure thickness

! !INPUT/OUTPUT PARAMETERS:
 real, intent(inout):: a4(4,i1:i2,km)  ! Interpolated values

! !DESCRIPTION:
!
!   Perform the piecewise parabolic method 
! 
! !REVISION HISTORY: 
!   ??.??.??    Lin        Creation
!   02.04.04    Sawyer     Newest release from FVGCM
! 
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
! local arrays:
      real   dc(i1:i2,km)
      real   h2(i1:i2,km)
      real delq(i1:i2,km)
      real  df2(i1:i2,km)
      real   d4(i1:i2,km)

! local scalars:
      integer i, k, km1, lmt
      integer it
      real fac
      real a1, a2, c1, c2, c3, d1, d2
      real qmax, qmin, cmax, cmin
      real qm, dq, tmp
      real qmp, pmp
      real lac

      km1 = km - 1
       it = i2 - i1 + 1

      do k=max(2,kmap-2),km
         do i=i1,i2
            delq(i,k-1) =   a4(1,i,k) - a4(1,i,k-1)
              d4(i,k  ) = delp(i,k-1) + delp(i,k)
         enddo
      enddo
 
      do k=max(2,kmap-2),km1
         do i=i1,i2
            c1  = (delp(i,k-1)+0.5*delp(i,k))/d4(i,k+1)
            c2  = (delp(i,k+1)+0.5*delp(i,k))/d4(i,k)
            tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) /      &
                                    (d4(i,k)+delp(i,k+1))
            qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k)
            qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))
             dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp)
            df2(i,k) = tmp
         enddo
      enddo

!-----------------------------------------------------------
! 4th order interpolation of the provisional cell edge value
!-----------------------------------------------------------

      do k=max(3,kmap), km1
      do i=i1,i2
        c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k)
        a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1))
        a2 = d4(i,k+1) / (d4(i,k) + delp(i,k))
        a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(d4(i,k-1)+d4(i,k+1)) *    &
                  ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) -          &
                                delp(i,k-1)*a1*dc(i,k  ) )
      enddo
      enddo

      if(km>8 .and. kord>3) call steepz_sak(i1, i2, km, kmap, a4, df2, dc, delq, delp, d4)

! Area preserving cubic with 2nd deriv. = 0 at the boundaries
! Top
      if ( kmap <= 2 ) then
      do i=i1,i2
         d1 = delp(i,1)
         d2 = delp(i,2)
         qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2)
         dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2)
         c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) )
         c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2)
         a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
         a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2)
         dc(i,1) =  a4(1,i,1) - a4(2,i,1)
! No over- and undershoot condition
         cmax = max(a4(1,i,1), a4(1,i,2))
         cmin = min(a4(1,i,1), a4(1,i,2))
         a4(2,i,2) = max(cmin,a4(2,i,2))
         a4(2,i,2) = min(cmax,a4(2,i,2))
      enddo
      endif

! Bottom
! Area preserving cubic with 2nd deriv. = 0 at the surface
      do i=i1,i2
         d1 = delp(i,km)
         d2 = delp(i,km1)
         qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2)
         dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2)
         c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1)))
         c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2)
         a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1)
         a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km)
         dc(i,km) = a4(3,i,km) -  a4(1,i,km)
! No over- and under-shoot condition
         cmax = max(a4(1,i,km), a4(1,i,km1))
         cmin = min(a4(1,i,km), a4(1,i,km1))
         a4(2,i,km) = max(cmin,a4(2,i,km))
         a4(2,i,km) = min(cmax,a4(2,i,km))
      enddo

      do k=max(1,kmap),km1
         do i=i1,i2
            a4(3,i,k) = a4(2,i,k+1)
         enddo
      enddo

! Enforce monotonicity of the "slope" within the top layer
      if ( kmap <= 2 ) then
      do i=i1,i2
         if ( a4(2,i,1) * a4(1,i,1) <= 0. ) then 
              a4(2,i,1) = 0.
                dc(i,1) = a4(1,i,1)
         endif
         if ( dc(i,1) * (a4(2,i,2) - a4(1,i,1)) <= 0. ) then
! Setting DC==0 will force piecewise constant distribution after
! calling kmppm_sak
              dc(i,1) = 0.
         endif
      enddo
      endif

! Enforce constraint on the "slope" at the surface

      do i=i1,i2
         if( a4(3,i,km) * a4(1,i,km) <= 0. ) then
!            a4(3,i,km) = 0.
!              dc(i,km) =  -a4(1,i,km)
               dc(i,km) = 0.
         endif
         if( dc(i,km) * (a4(1,i,km) - a4(2,i,km)) <= 0. ) then
             dc(i,km) = 0.
         endif
      enddo
 
!-----------------------------------------------------------
! f(s) = AL + s*[(AR-AL) + A6*(1-s)]         ( 0 <= s  <= 1 )
!-----------------------------------------------------------
! Top 2 and bottom 2 layers always use monotonic mapping
      if ( kmap <= 2 ) then
      do k=1,2
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
            call kmppm_sak(dc(i1,k), a4(1,i1,k), it, 0)
      enddo
      endif

      if(kord >= 7) then
!-----------------------
! Huynh's 2nd constraint
!-----------------------
      do k=max(2,kmap-1), km1
         do i=i1,i2
! Method#1
!           h2(i,k) = delq(i,k) - delq(i,k-1)
! Method#2
!           h2(i,k) = 2.*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1))
!    &               / ( delp(i,k)+0.5*(delp(i,k-1)+delp(i,k+1)) )
!    &               * delp(i,k)**2
! Method#3
            h2(i,k) = dc(i,k+1) - dc(i,k-1)
         enddo
      enddo

      if( kord == 7 ) then
         fac = 1.5           ! original quasi-monotone
      else
         fac = 0.125         ! full monotone
      endif

      do k=max(3,kmap), km-2
        do i=i1,i2
! Right edges
!        qmp   = a4(1,i,k) + 2.0*delq(i,k-1)
!        lac   = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
!
         pmp   = 2.*dc(i,k)
         qmp   = a4(1,i,k) + pmp
         lac   = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k)
         qmin  = min(a4(1,i,k), qmp, lac)
         qmax  = max(a4(1,i,k), qmp, lac)
         a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax)
! Left  edges
!        qmp   = a4(1,i,k) - 2.0*delq(i,k)
!        lac   = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
!
         qmp   = a4(1,i,k) - pmp
         lac   = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k)
         qmin  = min(a4(1,i,k), qmp, lac)
         qmax  = max(a4(1,i,k), qmp, lac)
         a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax)
! Recompute A6
         a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
        enddo
! Additional constraint to ensure positivity when kord=7
         if (iv == 0 .and. kord == 7) then
             call kmppm_sak(dc(i1,k), a4(1,i1,k), it, 2)
         endif
      enddo

      else
 
         lmt = kord - 3
         lmt = max(0, lmt)
         if (iv == 0) lmt = min(2, lmt)

      do k=max(3,kmap), km-2
      if( kord /= 4) then
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
      endif
         call kmppm_sak(dc(i1,k), a4(1,i1,k), it, lmt)
      enddo
      endif

      do k=km1,km
         do i=i1,i2
            a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
         enddo
         call kmppm_sak(dc(i1,k), a4(1,i1,k), it, 0)
      enddo
!EOC
 end subroutine ppm2m_sak
!-----------------------------------------------------------------------

!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  kmppm_sak --- Perform piecewise parabolic method in vertical
!
! !INTERFACE:
 subroutine kmppm_sak(dm, a4, itot, lmt)

 implicit none

! !INPUT PARAMETERS:
      real, intent(in):: dm(*)     ! the linear slope
      integer, intent(in) :: itot      ! Total Longitudes
      integer, intent(in) :: lmt       ! 0: Standard PPM constraint
                                       ! 1: Improved full monotonicity constraint (Lin)
                                       ! 2: Positive definite constraint
                                       ! 3: do nothing (return immediately)
! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout) :: a4(4,*)   ! PPM array
                                           ! AA <-- a4(1,i)
                                           ! AL <-- a4(2,i)
                                           ! AR <-- a4(3,i)
                                           ! A6 <-- a4(4,i)

! !DESCRIPTION:
!
! !REVISION HISTORY: 
!    00.04.24   Lin       Last modification
!    01.03.26   Sawyer    Added ProTeX documentation
!    02.04.04   Sawyer    Incorporated newest FVGCM version
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:

      real, parameter:: r12 = 1./12.
      real qmp
      real da1, da2, a6da
      real fmin
      integer i

! Developer: S.-J. Lin, NASA-GSFC
! Last modified: Apr 24, 2000

      if ( lmt == 3 ) return

      if(lmt == 0) then
! Standard PPM constraint
      do i=1,itot
      if(dm(i) == 0.) then
         a4(2,i) = a4(1,i)
         a4(3,i) = a4(1,i)
         a4(4,i) = 0.
      else
         da1  = a4(3,i) - a4(2,i)
         da2  = da1**2
         a6da = a4(4,i)*da1
         if(a6da < -da2) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         elseif(a6da > da2) then
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
      endif
      enddo

      elseif (lmt == 1) then

! Improved full monotonicity constraint (Lin 2003)
! Note: no need to provide first guess of A6 <-- a4(4,i)
      do i=1, itot
           qmp = 2.*dm(i)
         a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp)
         a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp)
         a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) )
      enddo

      elseif (lmt == 2) then

! Positive definite constraint
      do i=1,itot
      if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then
      fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12
         if( fmin < 0. ) then
         if(a4(1,i)<a4(3,i) .and. a4(1,i)<a4(2,i)) then
            a4(3,i) = a4(1,i)
            a4(2,i) = a4(1,i)
            a4(4,i) = 0.
         elseif(a4(3,i) > a4(2,i)) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         else
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
         endif
      endif
      enddo

      endif

!EOC
 end subroutine kmppm_sak
!-----------------------------------------------------------------------

!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  steepz_sak --- Calculate attributes for PPM
!
! !INTERFACE:
 subroutine steepz_sak(i1, i2, km, kmap, a4, df2, dm, dq, dp, d4)

   implicit none

! !INPUT PARAMETERS:
      integer, intent(in) :: km                   ! Total levels
      integer, intent(in) :: kmap                 ! 
      integer, intent(in) :: i1                   ! Starting longitude
      integer, intent(in) :: i2                   ! Finishing longitude
      real, intent(in) ::  dp(i1:i2,km)       ! grid size
      real, intent(in) ::  dq(i1:i2,km)       ! backward diff of q
      real, intent(in) ::  d4(i1:i2,km)       ! backward sum:  dp(k)+ dp(k-1) 
      real, intent(in) :: df2(i1:i2,km)       ! first guess mismatch
      real, intent(in) ::  dm(i1:i2,km)       ! monotonic mismatch

! !INPUT/OUTPUT PARAMETERS:
      real, intent(inout) ::  a4(4,i1:i2,km)  ! first guess/steepened

!
! !DESCRIPTION:
!   This is complicated stuff related to the Piecewise Parabolic Method
!   and I need to read the Collela/Woodward paper before documenting
!   thoroughly.
!
! !REVISION HISTORY: 
!   ??.??.??    Lin?       Creation
!   01.03.26    Sawyer     Added ProTeX documentation
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      integer i, k
      real alfa(i1:i2,km)
      real    f(i1:i2,km)
      real  rat(i1:i2,km)
      real  dg2

! Compute ratio of dq/dp
      do k=max(2,kmap-1),km
         do i=i1,i2
            rat(i,k) = dq(i,k-1) / d4(i,k)
         enddo
      enddo

! Compute F
      do k=max(2,kmap-1),km-1
         do i=i1,i2
            f(i,k) =   (rat(i,k+1) - rat(i,k))                          &
                     / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) )
         enddo
      enddo

      do k=max(3,kmap),km-2
         do i=i1,i2
         if(f(i,k+1)*f(i,k-1)<0. .and. df2(i,k)/=0.) then
            dg2 = (f(i,k+1)-f(i,k-1))*((dp(i,k+1)-dp(i,k-1))**2          &
                   + d4(i,k)*d4(i,k+1) )
            alfa(i,k) = max(0., min(0.5, -0.1875*dg2/df2(i,k))) 
         else
            alfa(i,k) = 0.
         endif
         enddo
      enddo

      do k=max(4,kmap+1),km-2
         do i=i1,i2
            a4(2,i,k) = (1.-alfa(i,k-1)-alfa(i,k)) * a4(2,i,k) +         &
                        alfa(i,k-1)*(a4(1,i,k)-dm(i,k))    +             &
                        alfa(i,k)*(a4(1,i,k-1)+dm(i,k-1))
         enddo
      enddo

!EOC
 end subroutine steepz_sak
!-----------------------------------------------------------------------

        subroutine cloud_clear_xfer (tmp3, qa_mean, qa_mean_lst, a_clr, a_cld, clr, cld)
        real, dimension(:,:), intent(in) :: tmp3, qa_mean, qa_mean_lst
        real, dimension(:,:), intent(inout) :: a_clr, a_cld, clr, cld
        real :: cld2clr, clr2cld, prec_cld2clr, prec_clr2cld, tmp1, tmp2
        integer :: k,i,kdim,idim

        idim = size(tmp3,1)
        kdim = size(tmp3,2)

        do k=1,kdim
         do i=1,idim
        !-------------------------------
        !compute cloud to clear transfer
          if (overlap .eq. 1)                                            &
             cld2clr= min(a_cld(i,k),max(0.,a_cld(i,k) - qa_mean(i,k))   )

          if (overlap .eq. 2)                                            &
             cld2clr= min(a_cld(i,k),max(0.,a_cld(i,k)*(1.-qa_mean(i,k))))

          if (cloud_generator_on) then
             tmp1 =      min(a_cld(i,k),max(0.,a_cld(i,k) - qa_mean(i,k))   )
             tmp2 =      min(a_cld(i,k),max(0.,a_cld(i,k)*(1.-qa_mean(i,k))))
             cld2clr=min(a_cld(i,k),max(0.,tmp3(i,k)*tmp1+(1.-tmp3(i,k))*tmp2))
          end if

        !-------------------------------
        !compute clear to cloud transfer
          if (overlap .eq. 1)                                            &
             clr2cld = min(max(qa_mean(i,k)-qa_mean_lst(i,k),0.),a_clr(i,k))
          if (overlap .eq. 2)                                            &
             clr2cld = min(max( a_clr(i,k)*qa_mean(i,k),0.),a_clr(i,k))

          if (cloud_generator_on) then
             tmp1 =       min(max(qa_mean(i,k)-qa_mean_lst(i,k),0.),a_clr(i,k))
             tmp2 =       min(max( a_clr(i,k)*qa_mean(i,k),0.),a_clr(i,k))
             clr2cld=min(a_clr(i,k),max(0.,tmp3(i,k)*tmp1+(1.-tmp3(i,k))*tmp2))
          end if

        !---------------------------------
        !calculate precipitation transfers
          prec_cld2clr = cld(i,k)*(cld2clr/max(a_cld(i,k),qmin))
          prec_clr2cld = clr(i,k)*(clr2cld/max(a_clr(i,k),qmin))

        !----------------
        !add in transfers
          a_clr(i,k) = a_clr(i,k) + cld2clr - clr2cld
          a_cld(i,k) = a_cld(i,k) - cld2clr + clr2cld
          clr(i,k)   = clr(i,k) + prec_cld2clr - prec_clr2cld
          cld(i,k)   = cld(i,k) - prec_cld2clr + prec_clr2cld
         enddo
        enddo

        end subroutine cloud_clear_xfer

!

!#######################################################################
!#######################################################################



end module strat_cloud_mod


module topo_drag_mod

!=======================================================================
! TOPOGRAPHIC DRAG CLOSURE -- Garner (2005)
!=======================================================================

!-----------------------------------------------------------------------
!  Calculates horizontal velocity tendency due to topographic drag
!-----------------------------------------------------------------------

use          mpp_mod, only: input_nml_file
use          fms_mod, only: file_exist, open_namelist_file,            &
                            close_file, error_mesg, FATAL, NOTE,       &
                            mpp_pe, mpp_root_pe, stdout, stdlog,       &
                            check_nml_error, write_version_number
use       fms_io_mod, only: read_data, field_size
use       fms_io_mod, only: register_restart_field, restart_file_type
use       fms_io_mod, only: save_restart, restore_state
use    constants_mod, only: Grav, Cp_Air, Rdgas, Pi, Radian
use horiz_interp_mod, only: horiz_interp_type, horiz_interp_init, &
                            horiz_interp_new, horiz_interp, horiz_interp_del

implicit none

private

character(len=128) :: version = '$Id: topo_drag.F90,v 17.0.6.1 2010/08/30 20:39:47 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

logical :: module_is_initialized = .false.

! horizontal array size

integer :: nlon, nlat

! arrays defined by topo_drag_init:

real, allocatable, dimension(:,:) :: t11, t21, t12, t22    ! drag tensor
real, allocatable, dimension(:,:) :: hmin, hmax

! parameters:

real, parameter :: u0=1.0       ! arbitrary velocity scale for diagnostics
real, parameter :: xl=80.0e3    ! arbitrary horiz length scale for diagnostics
real, parameter :: ro=1.2       ! arbitrary density scale for diagnostics
real, parameter :: lapse=Grav/Cp_Air ! adiabatic lapse rate
real, parameter :: tiny=1.0e-8

real, parameter :: resolution=30.0 ! # of points per degree in topo datasets

integer, parameter :: ipts=360*resolution
integer, parameter :: jpts=180*resolution

!--- for netcdf restart
type(restart_file_type), save :: Top_restart

! parameters in namelist (topo_drag_nml):

real :: &
   frcrit=0.7   &      ! critical value of Froude number for nonlinear flow
  ,anonlin=7.0  &      ! amplitude of nonpropagating drag
  ,gamma=0.4    &      ! exponent in aspect ratio power law
  ,epsi=0.0     &      ! exponent in distribution power law
  ,beta=0.5     &      ! bluntness of topographic features
  ,h_frac=0.0   &      ! ratio of min to max subgrid mountain height
  ,zref_fac=1.0 &      ! adjusts level separating breaking/laminar flow
  ,no_drag_frac=0.05 & ! fraction of lower atmosphere with no breaking
  ,tboost=1.0 &        ! surface T boost to improve PBL height estimate
  ,pcut=0.0            ! high-level cutoff pressure for momentum forcing
logical :: &
   do_conserve_energy=.true. &! conserve total energy?
  ,keep_residual_flux=.true.  ! redistribute residual pseudomomentum?

NAMELIST /topo_drag_nml/                                               &
  frcrit, anonlin, beta, gamma, epsi,                                  &
  h_frac, zref_fac, no_drag_frac, tboost, pcut,                        &
  do_conserve_energy, keep_residual_flux

public topo_drag, topo_drag_init, topo_drag_end
public topo_drag_restart

contains

!#######################################################################

subroutine topo_drag                                                   &
                                     ( is, js, delt, uwnd, vwnd, atmp, &
                                           pfull, phalf, zfull, zhalf, &
                          dtaux, dtauy, dtemp, taux, tauy, taus, kbot )

integer, intent(in) :: is, js
real,    intent(in) :: delt
integer, intent(in), optional, dimension(:,:) :: kbot

! INPUT
! -----

! UWND     Zonal wind (dimensioned IDIM x JDIM x KDIM)
! VWND     Meridional wind (dimensioned IDIM x JDIM x KDIM)
! ATMP     Temperature at full levels (IDIM x JDIM x KDIM)
! PFULL    Pressure at full levels (IDIM x JDIM x KDIM)
! PHALF    Pressure at half levels (IDIM x JDIM x KDIM+1)
! ZFULL    Height at full levels (IDIM x JDIM x KDIM)
! ZHALF    Height at half levels (IDIM x JDIM x KDIM+1)

real, intent(in), dimension(:,:,:) :: uwnd, vwnd, atmp
real, intent(in), dimension(:,:,:) :: pfull, phalf, zfull, zhalf

! OUTPUT
! ------

! DTAUX,DTAUY  Tendency of the vector wind in m/s^2 (IDIM x JDIM x KDIM)
! DTEMP        Tendency of the temperature in K/s (IDIM x JDIM x KDIM)
! TAUX,TAUY    Base momentum flux in kg/m/s^2 (IDIM x JDIM) for diagnostics
! TAUS         clipped saturation momentum flux (IDIM x JDIM x KDIM) for diagnostics

real, intent(out), dimension(:,:)   :: taux, tauy
real, intent(out), dimension(:,:,:) :: dtaux, dtauy, dtemp, taus

integer, dimension(size(zfull,1),size(zfull,2)) :: ktop, kcut
real,    dimension(size(zhalf,1),size(zhalf,2),size(zhalf,3)) :: tausat

! work arrays

real, dimension(size(zfull,1),size(zfull,2)) :: taub, taul, taup, taun
real, dimension(size(zfull,1),size(zfull,2)) :: frulo, fruhi, frunl, rnorm

integer :: idim
integer :: jdim
integer :: k, kdim

  idim = size(uwnd,1)
  jdim = size(uwnd,2)
  kdim = size(uwnd,3)

! estimate height of pbl

  call get_pbl ( atmp, zfull, pfull, phalf, ktop, kcut )

! calculate base flux

  call base_flux (                                                     &
                                             is, js, uwnd, vwnd, atmp, &
                                             taux, tauy, dtaux, dtauy, &
                                               taub, taul, taup, taun, &
                                           frulo, fruhi, frunl, rnorm, &
                                            zfull, zhalf, pfull, ktop )

! calculate saturation flux profile

  call satur_flux (                                                    &
                                                     uwnd, vwnd, atmp, &
                                       taux, tauy, taup, taub, tausat, &
                                                  frulo, fruhi, frunl, &
                        dtaux, dtauy, zfull, pfull, phalf, ktop, kcut )

! calculate momentum tendency

  call topo_drag_tend (                                                &
                                               delt, uwnd, vwnd, atmp, &
                                       taux, tauy, taul, taun, tausat, &
                dtaux, dtauy, dtemp, zfull, zhalf, pfull, phalf, ktop )

! put saturation flux profile into 'taus' for diagnostics

  do k=1,kdim
     taus(:,:,k) = 0.5*rnorm(:,:)*(tausat(:,:,k) + tausat(:,:,k+1))
  enddo

! put total drag into 'taux,tauy' for diagnostics

  taup = taup - tausat(:,:,1)
  taub = (taup + taun)/taul
  taux = taux*taub
  tauy = tauy*taub

end subroutine topo_drag

!=======================================================================
                                  
subroutine base_flux (                                                 &
                                             is, js, uwnd, vwnd, atmp, &
                                             taux, tauy, dtaux, dtauy, &
                                               taub, taul, taup, taun, &
                                           frulo, fruhi, frunl, rnorm, &
                                            zfull, zhalf, pfull, ktop )

integer, intent(in) :: is, js
real, intent(in),  dimension(:,:,:) :: uwnd, vwnd, atmp
real, intent(in),  dimension(:,:,:) :: zfull, zhalf, pfull
real, intent(out), dimension(:,:)   :: taux, tauy
real, intent(out), dimension(:,:,:) :: dtaux, dtauy
real, intent(out), dimension(:,:)   :: taub, taul, taup, taun
real, intent(out), dimension(:,:)   :: frulo, fruhi, frunl, rnorm
integer, intent(in), dimension(:,:) :: ktop

integer :: i, idim, id
integer :: j, jdim, jd
integer :: k, kdim

real :: usat, bfreq2, bfreq, dphdz, vtau
real :: dzhalf, density
real :: frmin, frmax, frumin, frumax, fruclp, fru0, frusat
real :: rnormal, gterm

  idim = size(uwnd,1)
  jdim = size(uwnd,2)
  kdim = size(uwnd,3)

! compute base flux

  do j=1,jdim
     jd = js+j-1
     do i=1,idim
        id = is+i-1
        k = ktop(i,j)

        dzhalf = zfull(i,j,k-1) - zfull(i,j,k)
        density = (pfull(i,j,k) - pfull(i,j,k-1))/(Grav*dzhalf)
        bfreq2 = Grav*((atmp(i,j,k-1) - atmp(i,j,k))/dzhalf + lapse)/  & 
                  (0.5*(atmp(i,j,k-1) + atmp(i,j,k)))
        bfreq = sqrt(max(tiny, bfreq2))

        taux(i,j) = (uwnd(i,j,k)*t11(id,jd) + vwnd(i,j,k)*t21(id,jd))  &
                                                         *bfreq*density
        tauy(i,j) = (uwnd(i,j,k)*t12(id,jd) + vwnd(i,j,k)*t22(id,jd))  &
                                                         *bfreq*density
        taub(i,j) = max(tiny, sqrt(taux(i,j)**2 + tauy(i,j)**2))

!       min/max Froude numbers based on surface flow

        vtau = max(tiny, -(uwnd(i,j,k)*taux(i,j)                       &
                         + vwnd(i,j,k)*tauy(i,j))/taub(i,j))
        frmax = hmax(id,jd)*bfreq / vtau
        frmin = hmin(id,jd)*bfreq / vtau

!       linear momentum flux associated with min/max Froude numbers

        dphdz = bfreq / vtau
        usat = density/ro * vtau / sqrt(dphdz*xl)
        frusat = frcrit*usat

        frumin = frmin*usat         ! linear momentum flux
        frumax = frmax*usat
        frumax = max(frumax,frumin + tiny)
        fruclp = min(frumax,max(frumin,frusat))
        fru0 = (u0/vtau)*usat

!       total drag in linear limit

        rnormal = (frumax**(2.0*gamma - epsi)                          &
                 - frumin**(2.0*gamma - epsi))/(2.0*gamma - epsi) 
        rnormal = fru0**gamma * ro/rnormal  

        gterm = (frumax**(gamma - epsi - beta)                         &
               - fruclp**(gamma - epsi - beta))/(gamma - epsi - beta)
        gterm = gterm*frusat**beta

        taul(i,j) =                                                    &
                    (frumax**(2.0 + gamma - epsi)                      &
                   - frumin**(2.0 + gamma - epsi))/(2.0 + gamma - epsi)

!       separate propagating and nonpropagating parts of total drag

        taup(i,j) =                                                    &
                 ( (fruclp**(2.0 + gamma - epsi)                       &       
                  - frumin**(2.0 + gamma - epsi))/(2.0 + gamma - epsi) &
                                                    + frusat**2*gterm )

        taun(i,j) = anonlin*usat/(1.0 + beta)*                         &
                 ( (frumax**(1.0 + gamma - epsi)                       &
                  - fruclp**(1.0 + gamma - epsi))/(1.0 + gamma - epsi) &
                                                       - frusat*gterm )

        fruhi(i,j) = frumax
        frulo(i,j) = frumin
        frunl(i,j) = frusat
        rnorm(i,j) = rnormal

     enddo
  enddo

! wind component opposite the drag at full levels (stored as 'dtaux')

  do k=1,kdim
     do j=1,jdim
        do i=1,idim
           dtaux(i,j,k) =                                              &
             -(uwnd(i,j,k)*taux(i,j) + vwnd(i,j,k)*tauy(i,j))/taub(i,j)
        enddo
     enddo
  enddo

end subroutine base_flux

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

subroutine satur_flux (                                                &
                                                     uwnd, vwnd, atmp, &
                                       taux, tauy, taup, taub, tausat, &
                                                  frulo, fruhi, frunl, &
                        dtaux, dtauy, zfull, pfull, phalf, ktop, kcut )

real, intent(in),  dimension (:,:,:) :: uwnd, vwnd, atmp
real, intent(in),  dimension (:,:,:) :: dtaux, dtauy
real, intent(in),  dimension (:,:,:) :: zfull, pfull, phalf
real, intent(in),  dimension (:,:)   :: taux, tauy, taup
real, intent(out), dimension (:,:)   :: taub
real, intent(out), dimension (:,:,:) :: tausat
real, intent(in),  dimension (:,:)   :: frulo, fruhi, frunl
integer, intent(in), dimension (:,:) :: ktop, kcut

real, dimension(size(zfull,1),size(zfull,2)) :: usat

real :: dzhalf, gterm, gterm0, density
real :: bfreq2, bfreq, vtau, dphdz
real :: frumin, frumax, fruclp, frusat, frusat0, fruclp0

integer :: i, idim
integer :: j, jdim
integer :: k, kdim, k1

  idim = size(uwnd,1)
  jdim = size(uwnd,2)
  kdim = size(uwnd,3)

! get vertical profile of propagating part of momentum flux

  usat = frunl/frcrit

  do k=kdim,2,-1
     do j=1,jdim
        do i=1,idim

!          buoyancy frequency, velocity and density at half levels

           dzhalf = zfull(i,j,k-1) - zfull(i,j,k)
           density = (pfull(i,j,k) - pfull(i,j,k-1))/(Grav*dzhalf)
           bfreq2 = Grav*                                              &
                       ((atmp(i,j,k-1) - atmp(i,j,k))/dzhalf + lapse)/ & 
                   (0.5*(atmp(i,j,k-1) + atmp(i,j,k)))
           bfreq = sqrt(max(tiny, bfreq2))
           
           vtau = max(tiny, 0.5*(dtaux(i,j,k-1) + dtaux(i,j,k)))

!          min/max and critical momentum flux values at half levels

           dphdz = bfreq / vtau
           usat(i,j) = min(usat(i,j),                                  &
                      sqrt(density/ro * vtau/sqrt(dphdz*xl)))
           frusat = frcrit*usat(i,j)

           frumin = frulo(i,j)
           frumax = fruhi(i,j)
           fruclp = min(frumax,max(frumin,frusat))
           frusat0 = frunl(i,j)
           fruclp0 = min(frumax,max(frumin,frusat0))

!          propagating part of momentum flux (from WKB or EP)

           gterm0 = (frumax**(gamma - epsi - beta)                     &
                - fruclp0**(gamma - epsi - beta))/(gamma - epsi - beta)
           gterm = (fruclp0**(gamma - epsi)                            &
                               - fruclp**(gamma - epsi))/(gamma - epsi)

           tausat(i,j,k) =                                             &
                 ( (fruclp**(2.0 + gamma - epsi)                       &
                  - frumin**(2.0 + gamma - epsi))/(2.0 + gamma - epsi) &
                         + frusat**2.0*(gterm0*frusat0**beta + gterm) )
        enddo
     enddo
  enddo

! make propagating flux constant with height in zero-drag top layer

  tausat(:,:,1) = tausat(:,:,2)

  k1 = maxval(kcut)
  do k=3,k1
     where (k <= kcut)
        tausat(:,:,k) = tausat(:,:,1)
     endwhere
  enddo

! make propagating flux constant with height in zero-drag surface layer

  k1 = minval(ktop)
  do k=kdim+1,k1+1,-1
     where (k > ktop)
        tausat(:,:,k) = taup
     endwhere
  enddo

! redistribute residual forcing

  if ( keep_residual_flux ) then
     taub(:,:) = tausat(:,:,1)/(phalf(:,:,kdim+1) - phalf(:,:,1))
     do k=1,kdim
        tausat(:,:,k) = tausat(:,:,k)                                  &
                        - taub(:,:)*(phalf(:,:,kdim+1) - phalf(:,:,k))
     enddo
  endif

endsubroutine satur_flux

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

subroutine topo_drag_tend (                                            &
                                               delt, uwnd, vwnd, atmp, &
                                       taux, tauy, taul, taun, tausat, &
                dtaux, dtauy, dtemp, zfull, zhalf, pfull, phalf, ktop )

real, intent(in) :: delt
real, intent(in), dimension(:,:,:)   :: uwnd, vwnd, atmp
real, intent(in), dimension(:,:,:)   :: zfull, zhalf, pfull, phalf
real, intent(in), dimension(:,:)     :: taux, tauy, taul, taun
real, intent(in), dimension(:,:,:)   :: tausat
real, intent(inout),dimension(:,:,:) :: dtaux, dtauy, dtemp
integer, intent(in), dimension (:,:) :: ktop

real, parameter :: bfmin=0.7e-2, bfmax=1.7e-2  ! min/max buoyancy freq [1/s]
real, parameter :: vvmin=1.0                   ! minimum surface wind [m/s]

integer,dimension(size(zfull,1),size(zfull,2)) :: kref
real :: dzhalf, zlast, rscale, phase, bfreq, bfreq2, vtau
real :: gfac, gfac1, dp, weight, wtsum

integer :: i, idim
integer :: j, jdim
integer :: k, kdim, kr

  idim = size(uwnd,1)
  jdim = size(uwnd,2)
  kdim = size(uwnd,3)

! find reference level for non-propagating drag (z ~ pi U/N)

  do j=1,jdim
     do i=1,idim
        k = ktop(i,j)
        phase = 0.0
        zlast = zhalf(i,j,k)
        do while (phase <= Pi*zref_fac .and. k > 1)
           k = k-1
           vtau = 0.5*(dtaux(i,j,k-1) + dtaux(i,j,k))
           dzhalf = zfull(i,j,k-1) - zfull(i,j,k)
           bfreq2 = Grav*                                              &
                       ((atmp(i,j,k-1) - atmp(i,j,k))/dzhalf + lapse)/ &
                   (0.5*(atmp(i,j,k-1) + atmp(i,j,k)))
           bfreq = sqrt(max(tiny, bfreq2))
           rscale = max(bfmin, min(bfmax, bfreq))/max(vvmin, vtau)
           dzhalf = zfull(i,j,k-1) - zlast
           phase = phase + dzhalf*rscale
           zlast = zfull(i,j,k-1)
        enddo
        kref(i,j) = k
     enddo
  enddo

! CALCULATE DECELERATION DUE TO PROPAGATING DRAG (~-rho^-1 dtau/dz)

  do k=1,kdim
     do j=1,jdim
        do i=1,idim
          dp = phalf(i,j,k+1) - phalf(i,j,k)
          gfac = tausat(i,j,k+1) - tausat(i,j,k)
          gfac1 = gfac*Grav/(dp*taul(i,j))
          dtaux(i,j,k) = gfac1*taux(i,j)
          dtauy(i,j,k) = gfac1*tauy(i,j)
        enddo
     enddo
  enddo

! CALCULATE DECELERATION DUE TO NON-PROPAGATING DRAG

  do j=1,jdim
     do i=1,idim
        kr = kref(i,j)
        dp = phalf(i,j,kdim+1) - phalf(i,j,kr)
        gfac = taun(i,j)*Grav/(dp*taul(i,j))
        wtsum = 0.0
        do k=kr,kdim
           weight = pfull(i,j,k) - phalf(i,j,kr)
           wtsum = wtsum + weight
        enddo
        do k=kr,kdim
           weight = pfull(i,j,k) - phalf(i,j,kr)
           gfac1 = gfac*weight/wtsum
           dtaux(i,j,k) = dtaux(i,j,k) + gfac1*taux(i,j)
           dtauy(i,j,k) = dtauy(i,j,k) + gfac1*tauy(i,j)
        enddo
     enddo
  enddo

! CALCULATE HEATING TO CONSERVE TOTAL ENERGY

  if (do_conserve_energy) then
     dtemp = -((uwnd + 0.5*delt*dtaux)*dtaux                           &
             + (vwnd + 0.5*delt*dtauy)*dtauy)/Cp_Air
  else
     dtemp = 0.0
  endif

end subroutine topo_drag_tend

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

subroutine get_pbl ( atmp, zfull, pfull, phalf, ktop, kcut )

integer, intent(out), dimension(:,:) :: ktop, kcut
real, intent(in), dimension(:,:,:)   :: atmp
real, intent(in), dimension(:,:,:)   :: zfull, pfull, phalf

real, dimension(size(pfull,1),size(pfull,2)) :: pbot, tbot, zbot

integer :: i, idim
integer :: j, jdim
integer :: k, kdim

  idim = size(atmp,1)
  jdim = size(atmp,2)
  kdim = size(atmp,3)

  do j=1,jdim
     do i=1,idim
        pbot(i,j) = (1.0 - no_drag_frac)*phalf(i,j,kdim+1)
        tbot(i,j) = atmp(i,j,kdim) + tboost
        zbot(i,j) = zfull(i,j,kdim)
     enddo
  enddo

! find highest model level in no-drag surface layer

  ktop = kdim-1

  do k=kdim-2,2,-1
     where ( pfull(:,:,k) <= pbot(:,:) .and.                           &
           tbot(:,:) - atmp(:,:,k) > lapse*(zfull(:,:,k) - zbot(:,:)) )
        ktop = k
     endwhere
  enddo

! find lowest model level in no-drag top layer

  kcut = 1

  do k=2,kdim
     where ( pfull(:,:,k) <= pcut )
        kcut = k
     endwhere
  enddo

end subroutine get_pbl

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

subroutine topo_drag_init (lonb, latb)

real, intent(in), dimension(:,:) :: lonb, latb

character(len=128) :: msg
character(len=64)  :: restart_file='topo_drag.res.nc'
character(len=64)  :: topography_file='INPUT/postopog_2min_hp150km.nc'
character(len=64)  :: dragtensor_file='INPUT/dragelements_2min_hp150km.nc'
character(len=3)   :: tensornames(4) = (/ 't11', 't21', 't12', 't22' /)

real, parameter :: bfscale=1.0e-2      ! buoyancy frequency scale [1/s]

real, allocatable, dimension(:)   :: xdat, ydat
real, allocatable, dimension(:,:) :: zdat, zout
type (horiz_interp_type) :: Interp
real :: exponent

integer :: n
integer :: io, ierr, unit_nml, logunit
integer :: i, j
integer :: siz(4)
integer :: id_restart

  if (module_is_initialized) return

  nlon = size(lonb,1)-1
  nlat = size(latb,2)-1

! read namelist

#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=topo_drag_nml, iostat=io)
   ierr = check_nml_error(io,'topo_drag_nml')
#else   
  if( file_exist( 'input.nml' ) ) then
     unit_nml = open_namelist_file ( )
     ierr = 1
     do while ( ierr /= 0 )
        read( unit_nml, nml = topo_drag_nml, iostat = io, end = 10 )
        ierr = check_nml_error (io, 'topo_drag_nml')
     end do
 10  call close_file ( unit_nml )
  endif
#endif

! write version number and namelist to logfile

  call write_version_number (version, tagname)
  logunit = stdlog()
  if (mpp_pe() == mpp_root_pe())                                       &
                                    write (logunit, nml=topo_drag_nml)

  allocate (t11(nlon,nlat))
  allocate (t21(nlon,nlat))
  allocate (t12(nlon,nlat))
  allocate (t22(nlon,nlat))
  allocate (hmin(nlon,nlat))
  allocate (hmax(nlon,nlat))

  if (gamma == beta + epsi) gamma = gamma + tiny

! read restart file

  id_restart = register_restart_field(Top_restart, restart_file, 't11', t11)
  id_restart = register_restart_field(Top_restart, restart_file, 't21', t21)
  id_restart = register_restart_field(Top_restart, restart_file, 't12', t12)
  id_restart = register_restart_field(Top_restart, restart_file, 't22', t22)
  id_restart = register_restart_field(Top_restart, restart_file, 'hmin', hmin)
  id_restart = register_restart_field(Top_restart, restart_file, 'hmax', hmax)
  restart_file = 'INPUT/'//trim(restart_file)
  if ( file_exist(restart_file) ) then

     if (mpp_pe() == mpp_root_pe()) then
        write ( msg, '("Reading restart file: ",a40)' ) restart_file
        call error_mesg('topo_drag_mod', msg, NOTE)
     endif
     call restore_state(Top_restart)

  else if (file_exist(topography_file) .and.                           &
           file_exist(dragtensor_file)) then

!    read and interpolate topography datasets

     if (mpp_pe() == mpp_root_pe()) then
        write ( msg, '("Reading topography file: ",a)')              &
                                                        trim(topography_file)
        call error_mesg('topo_drag_mod', msg, NOTE)
     endif

     ! check for correct field size in topography
     call field_size (topography_file, 'hpos', siz)
     if (siz(1) /= ipts .or. siz(2) /= jpts) then
         call error_mesg('topo_drag_mod', 'Field \"hpos\" in file '// &
                   trim(topography_file)//' has the wrong size', FATAL)
     endif
     
     allocate (xdat(ipts+1))
     allocate (ydat(jpts+1))
     allocate (zdat(ipts,jpts))
     allocate (zout(nlon,nlat))

     do i=1,ipts+1
        xdat(i) = (i-1)/resolution / Radian
     enddo
     do j=1,jpts+1
        ydat(j) = (-90.0 + (j-1)/resolution) / Radian
     enddo

     ! initialize horizontal interpolation
     ! Note: interp_method will be conservative for lat/lon grid
     !       and bilinear for all other grids
     call horiz_interp_init
     call horiz_interp_new ( Interp, xdat, ydat, lonb, latb )

     call read_data (topography_file, 'hpos', zdat, no_domain=.true.)

     exponent = 2.0 - gamma
     zdat = max(0.0, zdat)**exponent
     
     call horiz_interp ( Interp, zdat, zout )

     hmax = abs(zout)**(1.0/exponent) * sqrt(2.0/exponent)
     hmin = hmax*h_frac

     if (mpp_pe() == mpp_root_pe()) then
        write ( msg, '("Reading drag tensor file: ",a)')             &
                                                        trim(dragtensor_file)
        call error_mesg('topo_drag_mod', msg, NOTE)
     endif

     ! check for correct field size in tensor file
     call field_size (dragtensor_file, tensornames(1), siz)
     if (siz(1) /= ipts .or. siz(2) /= jpts) then
         call error_mesg('topo_drag_mod', 'Field \"'//tensornames(1)// &
         '\" in file '//trim(dragtensor_file)//' has the wrong size', FATAL)
     endif

     do n=1,4
        call read_data (dragtensor_file, tensornames(n), zdat, no_domain=.true.)
        call horiz_interp ( Interp, zdat, zout )
       !call horiz_interp ( zdat, xdat, ydat, lonb, latb, zout,        &
       !                                 interp_method='conservative' )
        if ( tensornames(n) == 't11' ) then
           t11 = zout/bfscale
        else if ( tensornames(n) == 't21' ) then
           t21 = zout/bfscale
        else if ( tensornames(n) == 't12' ) then
           t12 = zout/bfscale
        else if ( tensornames(n) == 't22' ) then
           t22 = zout/bfscale
        endif
     enddo

     deallocate (zdat, zout)
     call horiz_interp_del ( Interp )

  else

     call ERROR_MESG ('topo_drag_init',                                &
                'No sub-grid orography available for topo_drag', FATAL)

  endif

  module_is_initialized = .true.

end subroutine topo_drag_init

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

subroutine topo_drag_end

! writes static arrays to restart file

  if (mpp_pe() == mpp_root_pe() ) then
     call error_mesg('topo_drag_mod', 'Writing netCDF formatted restart file: RESTART/topo_drag.res.nc', NOTE)
  endif

  call topo_drag_restart

  module_is_initialized = .false.

end subroutine topo_drag_end

!#######################################################################
! <SUBROUTINE NAME="topo_drag_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine topo_drag_restart(timestamp)
   character(len=*), intent(in), optional :: timestamp

   call save_restart(Top_restart, timestamp)

end subroutine topo_drag_restart
! </SUBROUTINE>

!#######################################################################

endmodule topo_drag_mod



module vert_diff_mod

!=======================================================================
!
!                         VERTICAL DIFFUSION MODULE
!
!      Routines for computing the tendencies due to vertical diffusion
!
!=======================================================================

use   constants_mod, only:  GRAV, RDGAS, RVGAS, CP_AIR

use         fms_mod, only:  error_mesg, FATAL, uppercase, &
                            write_version_number, stdlog, &
                            mpp_pe, mpp_root_pe 

use   field_manager_mod, only: MODEL_ATMOS, MODEL_LAND, MODEL_ICE
use  tracer_manager_mod, only: query_method, get_number_tracers, &
     get_tracer_index, get_tracer_names, NO_TRACER

use mpp_mod, only: mpp_chksum, stdout

implicit none
private


! public interfaces
!=======================================================================
public :: vert_diff_init,          &
          vert_diff_end,           &
          gcm_vert_diff,               &
          gcm_vert_diff_down,          &
          gcm_vert_diff_up,            &
          vert_diff,                   &
          surf_diff_type

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

! form of interfaces
!=======================================================================


type surf_diff_type

  real, pointer, dimension(:,:) :: dtmass  => NULL(),   &
                                   dflux_t => NULL(),   &
                                   delta_t => NULL(),   &
                                   delta_u => NULL(),   &
                                   delta_v => NULL(), &
                                   sst_miz => NULL()
  real, pointer, dimension(:,:,:) :: dflux_tr => NULL(),& ! tracer flux tendency
                                     delta_tr => NULL()   ! tracer tendency
end type surf_diff_type


real,    allocatable, dimension(:,:,:) :: e_global, f_t_global, f_q_global 

! storage compartment for tracer vert. diffusion options, and for f
! coefficient if necessary
type :: tracer_data_type
   real, pointer :: f(:,:,:) => NULL() ! f coefficient field
   logical :: do_vert_diff
   logical :: do_surf_exch
end type tracer_data_type
! tracer diffusion options and storage for f coefficients
type(tracer_data_type), allocatable :: tracers(:)

      
logical :: do_conserve_energy = .true.
logical :: use_virtual_temp_vert_diff, do_mcm_plev
integer :: sphum, mix_rat

!--------------------- version number ---------------------------------

character(len=128) :: version = '$Id: vert_diff.F90,v 17.0.4.1 2010/03/17 20:27:10 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized = .false.

real, parameter :: d608 = (RVGAS-RDGAS)/RDGAS

contains

!#######################################################################

subroutine vert_diff_init (Tri_surf, idim, jdim, kdim,    &
                               do_conserve_energy_in,         &
                               use_virtual_temp_vert_diff_in, &
                               do_mcm_plev_in )

 type(surf_diff_type), intent(inout) :: Tri_surf
 integer,              intent(in)    :: idim, jdim, kdim
 logical,              intent(in)    :: do_conserve_energy_in
 logical, optional,    intent(in)    :: use_virtual_temp_vert_diff_in
 logical, optional,    intent(in)    :: do_mcm_plev_in

 integer :: ntprog ! number of prognostic tracers in the atmosphere
 character(len=32)  :: tr_name ! tracer name
 character(len=128) :: scheme  ! tracer diffusion scheme
 integer :: n, logunit

    call write_version_number ( version, tagname )

! get the number of prognostic tracers
    call get_number_tracers( MODEL_ATMOS, num_prog=ntprog)

! get the tracer number for specific humidity
    sphum = get_tracer_index( MODEL_ATMOS, 'sphum')
    mix_rat=get_tracer_index( MODEL_ATMOS, 'mix_rat')
    if(sphum /= NO_TRACER .and. mix_rat /= NO_TRACER) then
      call error_mesg('gcm_vert_diff_init','sphum and mix_rat cannot both'// &
                      'be present in the field_table at the same time', FATAL)
    endif

    logunit = stdlog()
    if (mpp_pe() == mpp_root_pe()) then
      write (logunit,'(a,i12)') 'Tracer number for specific humidity =',sphum
      write (logunit,'(a,i12)') 'Tracer number for mixing ratio      =',mix_rat
    endif

    if(sphum==NO_TRACER) sphum=mix_rat

    if(present(use_virtual_temp_vert_diff_in)) then
      use_virtual_temp_vert_diff = use_virtual_temp_vert_diff_in
    else
      use_virtual_temp_vert_diff = .false.
    endif
    if(present(do_mcm_plev_in)) then
      do_mcm_plev = do_mcm_plev_in
    else
      do_mcm_plev = .false.
    endif

 if (.not. module_is_initialized) then

    if (allocated(  e_global ))    deallocate (  e_global )
    if (allocated(f_t_global ))    deallocate (f_t_global )
    if (allocated(f_q_global ))    deallocate (f_q_global )

    allocate(  e_global (idim, jdim, kdim-1)) ;   e_global = 0.0
    allocate(f_t_global (idim, jdim, kdim-1)) ; f_t_global = 0.0 
    allocate(f_q_global (idim, jdim, kdim-1)) ; f_q_global = 0.0

    module_is_initialized = .true.

 endif

 call alloc_surf_diff_type ( Tri_surf, idim, jdim, ntprog )
 
 do_conserve_energy = do_conserve_energy_in

 ! allocate data storage for tracers
 allocate ( tracers(ntprog) )
 do n = 1,ntprog
    ! skip tracers diffusion if it is turned off in the field table
    tracers(n)%do_vert_diff = .true. 
    if (query_method('diff_vert',MODEL_ATMOS,n,scheme)) then
       tracers(n)%do_vert_diff = (uppercase(scheme) /= 'NONE')
    endif
    ! do not exchange tracer with surface if it is not present in either land or
    ! ice model
    if (n==sphum) then
       tracers(n)%do_vert_diff = .false.
       tracers(n)%do_surf_exch = .false.
    else
       call get_tracer_names ( MODEL_ATMOS, n, tr_name )
       tracers(n)%do_surf_exch = &
            get_tracer_index ( MODEL_LAND, tr_name ) /= NO_TRACER .or.&
            get_tracer_index ( MODEL_ICE,  tr_name ) /= NO_TRACER
    endif
    ! if tracer goes through surface flux, allocate memory to hold f
    ! between downward and upward sweeps
    if(tracers(n)%do_surf_exch)&
         allocate(tracers(n)%f(idim,jdim,kdim-1))
 enddo

 write(logunit,*)'Tracer vertical diffusion properties:'
 do n = 1,ntprog
    call get_tracer_names(MODEL_ATMOS, n, tr_name)
    write(logunit,100)tr_name,tracers(n)%do_vert_diff,tracers(n)%do_surf_exch
 enddo
100 FORMAT('Tracer :',a32,': do_tr_vert_diff=',L1,' : do_tr_surf_exch=',L1)

end subroutine vert_diff_init

!#######################################################################

subroutine alloc_surf_diff_type ( Tri_surf, idim, jdim, ntprog )

type(surf_diff_type), intent(inout) :: Tri_surf
integer,              intent(in)    :: idim, jdim, ntprog

    allocate( Tri_surf%dtmass    (idim, jdim) ) ; Tri_surf%dtmass  = 0.0
    allocate( Tri_surf%dflux_t   (idim, jdim) ) ; Tri_surf%dflux_t = 0.0
    allocate( Tri_surf%delta_t   (idim, jdim) ) ; Tri_surf%delta_t = 0.0
    allocate( Tri_surf%delta_u   (idim, jdim) ) ; Tri_surf%delta_u = 0.0
    allocate( Tri_surf%delta_v   (idim, jdim) ) ; Tri_surf%delta_v = 0.0
    allocate( Tri_surf%sst_miz   (idim, jdim) ) ; Tri_surf%sst_miz = 280.0 !miz
    allocate( Tri_surf%dflux_tr  (idim, jdim, ntprog) ) ; Tri_surf%dflux_tr = 0.0
    allocate( Tri_surf%delta_tr  (idim, jdim, ntprog) ) ; Tri_surf%delta_tr = 0.0

end subroutine alloc_surf_diff_type

!#######################################################################

subroutine dealloc_surf_diff_type ( Tri_surf )

type(surf_diff_type), intent(inout) :: Tri_surf

      deallocate( Tri_surf%dtmass    )
      deallocate( Tri_surf%dflux_t   )
      deallocate( Tri_surf%delta_t   )
      deallocate( Tri_surf%delta_u   )
      deallocate( Tri_surf%delta_v   )
      deallocate( Tri_surf%sst_miz   )!miz
      deallocate( Tri_surf%dflux_tr  )
      deallocate( Tri_surf%delta_tr  )

end subroutine dealloc_surf_diff_type

!#######################################################################

subroutine vert_diff_end

  integer :: n

  if (module_is_initialized) then

    if (allocated(   e_global ))    deallocate (   e_global)
    if (allocated( f_t_global ))    deallocate ( f_t_global)
    if (allocated( f_q_global ))    deallocate ( f_q_global)

    if(allocated(tracers)) then
       do n = 1,size(tracers(:))
          if ( associated(tracers(n)%f) ) deallocate(tracers(n)%f)
       enddo
       deallocate(tracers)
    endif
  endif
  module_is_initialized = .false.


end subroutine vert_diff_end

!#######################################################################

subroutine gcm_vert_diff_down (is, js, delt,                &
                          u, v, t, q, tr,                   &
                          diff_m, diff_t, p_half, p_full,   &
                          z_full, tau_u, tau_v,             &
                          dtau_du, dtau_dv,                 &
                          dt_u, dt_v, dt_t, dt_q, dt_tr,    &
                          dissipative_heat, Tri_surf,       &
                          kbot                              )

integer, intent(in)                        :: is, js
real,    intent(in)                        :: delt
real,    intent(in)   , dimension(:,:,:)   :: u, v, t, q,     &
                                              diff_m, diff_t, &
                                              p_half, p_full, &
                                              z_full
real,    intent(in)   , dimension(:,:,:,:) :: tr
real,    intent(in)   , dimension(:,:)     :: dtau_du, dtau_dv
real,    intent(inout), dimension(:,:)     :: tau_u, tau_v
real,    intent(inout), dimension(:,:,:)   :: dt_u, dt_v, dt_t
real,    intent(in),    dimension(:,:,:)   :: dt_q
real,    intent(inout), dimension(:,:,:,:) :: dt_tr
real,    intent(out)  , dimension(:,:,:)   :: dissipative_heat
type(surf_diff_type), intent(inout)        :: Tri_surf

integer, intent(in)   , dimension(:,:), optional :: kbot

! ---- local vars
real, dimension(size(u,1),size(u,2),size(u,3)) :: &
     tt, mu, nu, e, a, b, c, g, f_tr
real, dimension(size(u,1),size(u,2)) ::           &
     f_t_delt_n1, f_q_delt_n1, f_tr_delt_n1, flux_tr, dflux_dtr, &
     mu_delt_n, nu_n, e_n1, delta_t_n, delta_q_n, delta_tr_n, &
            delta_u_n, delta_v_n
real    :: gcp
integer :: i, j, n, kb, ie, je, ntr, nlev

!-----------------------------------------------------------------------

  if(.not. module_is_initialized) call error_mesg ('gcm_vert_diff_down in vert_diff_mod',  &
      'the initialization routine gcm_vert_diff_init has not been called', &
       FATAL)
    
 ie = is + size(t,1) -1
 je = js + size(t,2) -1
 ntr  = size(tr,4)
 nlev = size(mu,3)
 
 gcp       = GRAV/CP_AIR
 tt  = t + z_full*gcp   ! the vertical gradient of tt determines the
                        ! diffusive flux of temperature

 call compute_mu (p_half, mu)
 call compute_nu (diff_m, p_half, p_full, z_full, t, q, nu) 

!  diffuse u-momentum and v_momentum
 call uv_vert_diff (delt, mu, nu, u, v, dtau_du, dtau_dv, tau_u, tau_v,  &
                    dt_u, dt_v, dt_t, delta_u_n, delta_v_n,         &
                    dissipative_heat, kbot)
                            
!  recompute nu for a different diffusivity
 call compute_nu   (diff_t, p_half, p_full, z_full, t, q, nu)

 ! calculate e, the same for all tracers since their diffusivities are 
 ! the same, and mu_delt_n, nu_n, e_n1
 call compute_e (delt, mu, nu, e, a, b, c, g)
 do j = 1,size(mu,2)
 do i = 1,size(mu,1)
    kb = nlev ; if(present(kbot)) kb=kbot(i,j)
    mu_delt_n(i,j) = mu(i,j,kb  )*delt
         nu_n(i,j) = nu(i,j,kb  )
         e_n1(i,j) = e (i,j,kb-1)
 enddo
 enddo

 do n = 1,ntr
    ! calculate f_tr, f_tr_delt_n1, delta_tr_n for this tracer
    if(.not.tracers(n)%do_vert_diff) cycle ! skip non-diffusive tracers
    call explicit_tend (mu, nu, tr(:,:,:,n), dt_tr(:,:,:,n))
    call compute_f (dt_tr(:,:,:,n), b, c, g, f_tr)
    do j = 1,size(mu,2)
    do i = 1,size(mu,1)
       kb = nlev ; if(present(kbot)) kb=kbot(i,j)
       f_tr_delt_n1(i,j) = f_tr (i,j,kb-1)*delt
       delta_tr_n(i,j)   = dt_tr(i,j,kb,n)*delt
    enddo
    enddo

    ! store information needed by flux_exchange module
    Tri_surf%delta_tr(is:ie,js:je,n) = &
         delta_tr_n(:,:) + mu_delt_n(:,:)*nu_n(:,:)*f_tr_delt_n1(:,:)
    Tri_surf%dflux_tr(is:ie,js:je,n) = -nu_n(:,:)*(1.0 - e_n1(:,:))

    if(tracers(n)%do_surf_exch) then
       ! store f for future use on upward sweep
       tracers(n)%f(is:ie,js:je,:) = f_tr(:,:,:)
    else
       ! upward sweep of tridaigonal solver for tracers that do not exchange 
       ! with surface
       flux_tr  (:,:) = 0.0 ! surface flux of tracer
       dflux_dtr(:,:) = 0.0 ! d(sfc flux)/d(tr atm)
       call diff_surface ( &
            mu_delt_n(:,:), nu_n(:,:), e_n1(:,:), f_tr_delt_n1(:,:), &
            dflux_dtr(:,:), flux_tr(:,:), 1.0, delta_tr_n(:,:) )
       call vert_diff_up ( &
            delt, e(:,:,:), f_tr(:,:,:), delta_tr_n(:,:), dt_tr(:,:,:,n), &
            kbot )
    endif
 enddo

! NOTE: actually e used in the tracer calculations above, and e_global
! calculated in the vert_diff_down_2 below are the same, since they only
! depend on mu and nu.

!  downward sweep of tridiagonal solver for temperature and specific humidity
 call vert_diff_down_2                            & 
         (delt, mu, nu, tt, q, dt_t, dt_q,        &  
         e_global             (is:ie,js:je,:),    &
         f_t_global           (is:ie,js:je,:),    &
         f_q_global           (is:ie,js:je,:),    &
         mu_delt_n, nu_n, e_n1, f_t_delt_n1, f_q_delt_n1, &
         delta_t_n, delta_q_n, kbot)

! store information needed by flux_exchange module

    Tri_surf%delta_t (is:ie,js:je) = delta_t_n + mu_delt_n*nu_n*f_t_delt_n1
    Tri_surf%dflux_t (is:ie,js:je) = -nu_n*(1.0 - e_n1)
    if (sphum/=NO_TRACER) then
       Tri_surf%delta_tr (is:ie,js:je,sphum) = delta_q_n + mu_delt_n*nu_n*f_q_delt_n1
       Tri_surf%dflux_tr (is:ie,js:je,sphum) = -nu_n*(1.0 - e_n1)
    endif
    Tri_surf%dtmass  (is:ie,js:je) = mu_delt_n
    Tri_surf%delta_u (is:ie,js:je) = delta_u_n
    Tri_surf%delta_v (is:ie,js:je) = delta_v_n

!-----------------------------------------------------------------------

end subroutine gcm_vert_diff_down

!#######################################################################

subroutine gcm_vert_diff_up (is, js, delt, Tri_surf, dt_t, dt_q, dt_tr, kbot)

integer, intent(in)                      :: is, js
real,    intent(in)                      :: delt
type(surf_diff_type), intent(in)         :: Tri_surf
real,    intent(out),   dimension(:,:,:) :: dt_t, dt_q
real,    intent(out),   dimension(:,:,:,:) :: dt_tr
integer, intent(in),    dimension(:,:), optional :: kbot

 ! ---- local vars
 integer :: ie, je, n
 real    :: surf_delta_q(size(dt_t,1),size(dt_t,2))

 ie = is + size(dt_t,1) -1
 je = js + size(dt_t,2) -1

! outunit = stdout()
!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'e_global',mpp_chksum(e_global(is:ie,js:je,:))
!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'f_t_global',mpp_chksum(f_t_global(is:ie,js:je,:))
!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'Tri_surf%deta_t',mpp_chksum(Tri_surf%delta_t(is:ie,js:je))

 call vert_diff_up (delt ,                              &
                    e_global          (is:ie,js:je,:) , &
                    f_t_global        (is:ie,js:je,:) , &
                    Tri_surf%delta_t  (is:ie,js:je) ,   &
                    dt_t, kbot )

!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'dt_t',mpp_chksum(dt_t)

 if(sphum/=NO_TRACER) then
    surf_delta_q = Tri_surf%delta_tr (is:ie,js:je,sphum)
 else
    surf_delta_q = 0.0
 endif

!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'surf_delta_q',mpp_chksum(surf_delta_q)
!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'f_q_global',mpp_chksum(f_q_global(is:ie,js:je,:))

 call vert_diff_up (delt ,                              &
                    e_global          (is:ie,js:je,:) , &
                    f_q_global        (is:ie,js:je,:) , &
                    surf_delta_q ,                      &
                    dt_q, kbot )

!checksums! write(outunit,'("CHECKSUM::",A32," = ",Z20)')'dt_q',mpp_chksum(dt_q)

 do n = 1,size(dt_tr,4)
    ! skip tracers if diffusion scheme turned off
    if (tracers(n)%do_vert_diff.and.tracers(n)%do_surf_exch) then
       call vert_diff_up (delt ,                           &
                    e_global           (is:ie,js:je,:) ,   &
                    tracers(n)%f       (is:ie,js:je,:) ,   &
                    Tri_surf%delta_tr  (is:ie,js:je,n) ,   &
                    dt_tr(:,:,:,n), kbot )
    endif
 enddo

end subroutine gcm_vert_diff_up

!#######################################################################

subroutine gcm_vert_diff (delt, u, v, t, q, tr,                    &
                          diff_m, diff_t, p_half, p_full, z_full,  &
                          dtau_du, dtau_dv, dsens_datmos, devap_datmos, &
                          sens, evap, tau_u, tau_v,                &
                          dt_u, dt_v, dt_t, dt_q, dt_tr,           &
                          dissipative_heat, kbot      )

!  one-step diffusion call for gcm in which there is no implicit dependence of 
!    surface fluxes on surface temperature

real,    intent(in)                          :: delt
real,    intent(in)   , dimension(:,:,:)     :: u, v, t, q, p_half, p_full, &
                                                z_full, diff_m, diff_t
real,    intent(in)   , dimension(:,:,:,:)   :: tr
real,    intent(in)   , dimension(:,:)       :: dtau_du, dtau_dv, dsens_datmos, &
                                                devap_datmos
real,    intent(inout), dimension(:,:)       :: tau_u, tau_v, sens, evap
real,    intent(inout), dimension(:,:,:)     :: dt_u, dt_v, dt_t, dt_q
real,    intent(inout), dimension(:,:,:,:)   :: dt_tr
real,    intent(out)  , dimension(:,:,:)     :: dissipative_heat

integer, intent(in)   , dimension(:,:), optional :: kbot

real, dimension(size(u,1),size(u,2),size(u,3)) :: mu, nu
real, dimension(size(u,1),size(u,2))           :: delta_u_n, delta_v_n


!-----------------------------------------------------------------------

 call compute_mu (p_half, mu)

 call compute_nu (diff_m, p_half, p_full, z_full, t, q, nu) 
 
 call uv_vert_diff (delt, mu, nu, u, v, dtau_du, dtau_dv, tau_u, tau_v, &
                    dt_u, dt_v, dt_t, delta_u_n, delta_v_n,        &
                    dissipative_heat, kbot)
                    
 call compute_nu   (diff_t, p_half, p_full, z_full, t, q, nu)

 call tq_vert_diff (delt, mu, nu, t, q, z_full,  &
                    dsens_datmos, devap_datmos,  &
                    sens, evap, dt_t, dt_q, kbot )

 call tr_vert_diff (delt, mu, nu, tr, dt_tr, kbot )

end subroutine gcm_vert_diff

!#######################################################################

subroutine vert_diff (delt, xi, t, q, diff, p_half, p_full, z_full, &
                      flux, dflux_datmos, factor, dt_xi, kbot)

! one-step diffusion of a single field 

real,    intent(in)                          :: delt
real,    intent(in)   , dimension(:,:,:)     :: xi, t, q, diff, p_half, p_full, z_full
real,    intent(inout), dimension(:,:)       :: flux
real,    intent(in)   , dimension(:,:)       :: dflux_datmos
real,    intent(in)                          :: factor
real,    intent(inout), dimension(:,:,:)     :: dt_xi

integer, intent(in)   , dimension(:,:), optional :: kbot

real, dimension(size(xi,1),size(xi,2),size(xi,3)  ) :: mu, nu
real, dimension(size(xi,1),size(xi,2),size(xi,3)-1) :: e, f

real, dimension(size(xi,1),size(xi,2))  :: mu_delt_n, nu_n, e_n1,  &
                                           f_delt_n1, delta_xi_n

!-----------------------------------------------------------------------

 call compute_mu    (p_half, mu)

 call compute_nu    (diff, p_half, p_full, z_full, t, q, nu) 

 call vert_diff_down &
     (delt, mu, nu, xi, dt_xi, e, f, mu_delt_n, nu_n, e_n1,  &
      f_delt_n1, delta_xi_n, kbot)

 call diff_surface (mu_delt_n, nu_n, e_n1, f_delt_n1,     &
                    dflux_datmos, flux, factor, delta_xi_n)

 call vert_diff_up (delt, e, f, delta_xi_n, dt_xi, kbot)

end subroutine vert_diff


!#######################################################################

subroutine uv_vert_diff (delt, mu, nu, u, v,  &
                         dtau_du, dtau_dv, tau_u, tau_v, dt_u, dt_v, dt_t, &
                          delta_u_n, delta_v_n, dissipative_heat, kbot )

real,    intent(in)                        :: delt
real,    intent(in)   , dimension(:,:,:)   :: u, v, mu, nu
real,    intent(in)   , dimension(:,:)     :: dtau_du, dtau_dv
real,    intent(inout), dimension(:,:)     :: tau_u, tau_v
real,    intent(inout), dimension(:,:,:)   :: dt_u, dt_v, dt_t
real,    intent(out)  , dimension(:,:,:)   :: dissipative_heat
real,    intent(out)  , dimension(:,:)     :: delta_u_n, delta_v_n

! Note (IH) 
!   delta_u_n = dt_u/delt at lowest model level, and similarly
!   for delta_v_n  -- it is convenient to output them separately

integer, intent(in)   , dimension(:,:), optional :: kbot

real, dimension(size(u,1),size(u,2)) :: mu_delt_n, nu_n, e_n1,    &
                                        f_u_delt_n1, f_v_delt_n1
                                        
real, dimension(size(u,1),size(u,2),size(u,3)) :: dt_u_temp, dt_v_temp

real, dimension(size(u,1),size(u,2),size(u,3)-1) :: e, f_u, f_v

real    :: half_delt, cp_inv


!-----------------------------------------------------------------------

 half_delt = 0.5*delt
 cp_inv    = 1.0/CP_AIR
 
 if (do_conserve_energy) then
   dt_u_temp = dt_u
   dt_v_temp = dt_v
 endif
 
 call vert_diff_down_2 &
     (delt, mu, nu, u, v, dt_u, dt_v, e, f_u, f_v, &
      mu_delt_n, nu_n, e_n1, f_u_delt_n1, f_v_delt_n1,  &
      delta_u_n, delta_v_n, kbot)        

 call diff_surface (mu_delt_n, nu_n, e_n1, f_u_delt_n1, &
                    dtau_du, tau_u, 1.0, delta_u_n)
 call diff_surface (mu_delt_n, nu_n, e_n1, f_v_delt_n1, &
                    dtau_dv, tau_v, 1.0, delta_v_n)

 call vert_diff_up (delt, e, f_u, delta_u_n, dt_u, kbot)
 call vert_diff_up (delt, e, f_v, delta_v_n, dt_v, kbot)

 if (do_conserve_energy) then
    dt_u_temp = dt_u - dt_u_temp
    dt_v_temp = dt_v - dt_v_temp
    dissipative_heat = - cp_inv*( (u + half_delt*dt_u_temp)*dt_u_temp &
                                 +(v + half_delt*dt_v_temp)*dt_v_temp )
    dt_t = dt_t + dissipative_heat
 else
    dissipative_heat = 0.0
 endif

!-----------------------------------------------------------------------

end subroutine uv_vert_diff

!#######################################################################

subroutine tq_vert_diff (delt, mu, nu, t, q,  z_full, &
                         dsens_datmos, devap_datmos, sens, evap, &
                         dt_t, dt_q, kbot)
                         

real,    intent(in)                        :: delt
real,    intent(in)   , dimension(:,:,:)   :: t, q, z_full, mu, nu
real,    intent(in)   , dimension(:,:)     :: dsens_datmos, devap_datmos
real,    intent(inout), dimension(:,:)     :: sens, evap
real,    intent(inout), dimension(:,:,:)   :: dt_t, dt_q

integer, intent(in)   , dimension(:,:), optional :: kbot

real, dimension(size(t,1),size(t,2)) :: mu_delt_n, nu_n,          &
                                        e_n1, f_t_delt_n1, f_q_delt_n1, &
                                        delta_t_n, delta_q_n

real, dimension(size(t,1),size(t,2),size(t,3)-1) :: e, f_t, f_q
real, dimension(size(t,1),size(t,2),size(t,3)  ) :: tt

real    :: gcp
!-----------------------------------------------------------------------

 gcp = GRAV/CP_AIR
 tt  = t + z_full*gcp
  
 call vert_diff_down_2 &
     (delt, mu, nu, tt, q, dt_t, dt_q, e, f_t, f_q,    &
      mu_delt_n, nu_n, e_n1, f_t_delt_n1, f_q_delt_n1, &
      delta_t_n, delta_q_n, kbot)


 call diff_surface (mu_delt_n, nu_n, e_n1, f_t_delt_n1,  &
                    dsens_datmos, sens, CP_AIR, delta_t_n)

 call diff_surface (mu_delt_n, nu_n, e_n1, f_q_delt_n1,  &
                    devap_datmos, evap, 1.0, delta_q_n)

 call vert_diff_up (delt, e, f_t, delta_t_n, dt_t, kbot)
 call vert_diff_up (delt, e, f_q, delta_q_n, dt_q, kbot)


!-----------------------------------------------------------------------

end subroutine tq_vert_diff

!#######################################################################

subroutine tr_vert_diff (delt, mu, nu, tr, dt_tr, kbot )

real,    intent(in)                        :: delt
real,    intent(in)   , dimension(:,:,:)   :: mu, nu
real,    intent(in)   , dimension(:,:,:,:) :: tr
real,    intent(inout), dimension(:,:,:,:) :: dt_tr

integer, intent(in)   , dimension(:,:), optional :: kbot

real, dimension(size(tr,1),size(tr,2)) :: mu_delt_n, nu_n, e_n1

real, dimension(size(tr,1),size(tr,2)) :: f_delt_n1, delta_tr_n
real, dimension(size(tr,1),size(tr,2)) :: dflux_dtr, flux
real, dimension(size(tr,1),size(tr,2),size(tr,3)-1) :: ftr
real, dimension(size(tr,1),size(tr,2),size(tr,3)-1) :: etr
real, dimension(size(tr,1),size(tr,2),size(tr,3)) :: a, b, c, g
integer :: i, j, kb, n, ntr, nlev
character(len=128) :: scheme
!-----------------------------------------------------------------------

 ntr  = size(tr,4) ! number of prognostic tracers

 dflux_dtr = 0.0
 call compute_e (delt, mu, nu, etr, a, b, c, g)
 if (present(kbot)) then
   do j=1,size(tr,2)
   do i=1,size(tr,1)
      kb = kbot(i,j)
      mu_delt_n(i,j) =  mu(i,j,kb  )*delt
           nu_n(i,j) =  nu(i,j,kb  )
           e_n1(i,j) = etr(i,j,kb-1)
   enddo
   enddo
 else
   nlev = size(mu,3)
   mu_delt_n(:,:) =  mu(:,:,nlev  )*delt
        nu_n(:,:) =  nu(:,:,nlev  )
        e_n1(:,:) = etr(:,:,nlev-1)
 endif
  
 do n = 1, ntr
   if ( n == sphum .or. n == mix_rat) cycle
   if (query_method('diff_vert',MODEL_ATMOS,n,scheme)) then
     if(uppercase(trim(scheme)) == 'NONE') cycle
   endif
   call explicit_tend (mu, nu, tr(:,:,:,n), dt_tr(:,:,:,n))
   call compute_f (dt_tr(:,:,:,n), b, c, g, ftr)
   if (present(kbot)) then
     do j=1,size(tr,2)
     do i=1,size(tr,1)
       kb = kbot(i,j)
       f_delt_n1(i,j)  =   ftr(i,j,kb-1)*delt
       delta_tr_n(i,j) = dt_tr(i,j,kb,n)*delt
     enddo
     enddo
   else
      f_delt_n1(:,:) =   ftr(:,:,nlev-1)*delt
     delta_tr_n(:,:) = dt_tr(:,:,nlev  ,n)*delt
   endif
   flux = 0.0
   call diff_surface (mu_delt_n, nu_n, e_n1, f_delt_n1, dflux_dtr, flux, 1.0, delta_tr_n)

! If flux needs to be saved then it should be made a module variable.
! vert_diff_init must allocate it and then call assign_tracer_field
! to set a pointer in tracer_manager_mod. It can be allocated as a
! 3 dimensional array with the 3'd index for tracer number.

   call vert_diff_up (delt, etr, ftr, delta_tr_n, dt_tr(:,:,:,n), kbot)
 end do

!-----------------------------------------------------------------------

end subroutine tr_vert_diff

!#######################################################################

subroutine vert_diff_down &
      (delt, mu, nu, tr, dt_tr, e, f, mu_delt_n, nu_n,  &
       e_n1, f_delt_n1, delta_tr_n, kbot)

!-----------------------------------------------------------------------

real,    intent(in)                         :: delt
real,    intent(in)    , dimension(:,:,:)   :: mu, nu
real,    intent(in)    , dimension(:,:,:)   :: tr
real,    intent(inout) , dimension(:,:,:)   :: dt_tr
real,    intent(out)   , dimension(:,:,:)   :: e
real,    intent(out)   , dimension(:,:,:)   :: f
real,    intent(out)   , dimension(:,:)     :: mu_delt_n, nu_n, e_n1
real,    intent(out)   , dimension(:,:)     :: f_delt_n1, delta_tr_n

integer, intent(in),    dimension(:,:), optional :: kbot

real, dimension(size(tr,1),size(tr,2),size(tr,3)) :: a, b, c, g

integer :: i, j, kb, nlev

!-----------------------------------------------------------------------

 call explicit_tend (mu, nu, tr, dt_tr)

 call compute_e  (delt, mu, nu, e, a, b, c, g)

 call compute_f (dt_tr, b, c, g, f)


 if (present(kbot)) then
    do j=1,size(tr,2)
    do i=1,size(tr,1)
        kb = kbot(i,j)
        mu_delt_n(i,j) =  mu(i,j,kb  )*delt
             nu_n(i,j) =  nu(i,j,kb  )
             e_n1(i,j) =   e(i,j,kb-1)
    enddo
    enddo
    do j=1,size(tr,2)
    do i=1,size(tr,1)
        kb = kbot(i,j)
         f_delt_n1(i,j) =     f(i,j,kb-1)*delt
        delta_tr_n(i,j) = dt_tr(i,j,kb  )*delt
    enddo
    enddo
 else
        nlev = size(mu,3)
        mu_delt_n(:,:) =       mu(:,:,nlev  )*delt
             nu_n(:,:) =       nu(:,:,nlev  )
             e_n1(:,:) =        e(:,:,nlev-1)
        f_delt_n1(:,:) =        f(:,:,nlev-1)*delt
       delta_tr_n(:,:) =    dt_tr(:,:,nlev  )*delt
 endif



!-----------------------------------------------------------------------

end subroutine vert_diff_down

!#######################################################################

subroutine vert_diff_down_2 &
      (delt, mu, nu, xi_1, xi_2, dt_xi_1, dt_xi_2, e, f_1, f_2, &
       mu_delt_n, nu_n, e_n1, f_1_delt_n1, f_2_delt_n1,         &
       delta_1_n, delta_2_n, kbot)

!-----------------------------------------------------------------------

real,    intent(in)                       :: delt
real,    intent(in)    , dimension(:,:,:) :: mu, nu, xi_1, xi_2
real,    intent(in)    , dimension(:,:,:) :: dt_xi_1, dt_xi_2
real,    intent(out)   , dimension(:,:,:) :: e, f_1, f_2
real,    intent(out)   , dimension(:,:)   :: mu_delt_n, nu_n, e_n1,    &
                                             f_1_delt_n1, f_2_delt_n1, &
                                             delta_1_n, delta_2_n

integer, intent(in),    dimension(:,:), optional :: kbot

real, dimension(size(xi_1,1),size(xi_1,2),size(xi_1,3)) :: a, b, c, g, &
                                                      dt_xi_11, dt_xi_22

integer :: i, j, kb, nlev

!-----------------------------------------------------------------------

! local copy of input 
  dt_xi_11 = dt_xi_1
  dt_xi_22 = dt_xi_2

 call explicit_tend (mu, nu, xi_1, dt_xi_11)
 call explicit_tend (mu, nu, xi_2, dt_xi_22)

 call compute_e (delt, mu, nu, e, a, b, c, g)

 call compute_f (dt_xi_11, b, c, g, f_1)
 call compute_f (dt_xi_22, b, c, g, f_2)

 if (present(kbot)) then
    do j=1,size(xi_1,2)
    do i=1,size(xi_1,1)
        kb = kbot(i,j)
        mu_delt_n(i,j)  =      mu(i,j,kb  )*delt
             nu_n(i,j)  =      nu(i,j,kb  )
            e_n1(i,j)  =       e(i,j,kb-1)
     f_1_delt_n1(i,j)  =     f_1(i,j,kb-1)*delt
     f_2_delt_n1(i,j)  =     f_2(i,j,kb-1)*delt
        delta_1_n(i,j)  = dt_xi_11(i,j,kb  )*delt
        delta_2_n(i,j)  = dt_xi_22(i,j,kb  )*delt
    enddo
    enddo
 else
        nlev = size(mu,3)
        mu_delt_n(:,:)  =      mu(:,:,nlev  )*delt
             nu_n(:,:)  =      nu(:,:,nlev  )
            e_n1(:,:)  =       e(:,:,nlev-1)
     f_1_delt_n1(:,:)  =     f_1(:,:,nlev-1)*delt
     f_2_delt_n1(:,:)  =     f_2(:,:,nlev-1)*delt
        delta_1_n(:,:)  = dt_xi_11(:,:,nlev  )*delt
        delta_2_n(:,:)  = dt_xi_22(:,:,nlev  )*delt
 endif



!-----------------------------------------------------------------------

end subroutine vert_diff_down_2

!#######################################################################

subroutine diff_surface (mu_delt, nu, e_n1, f_delt_n1,  &
                         dflux_datmos, flux, factor, delta_xi)

!-----------------------------------------------------------------------

real, intent(in)   , dimension(:,:) :: mu_delt, nu, e_n1, f_delt_n1,  &
                                       dflux_datmos
real, intent(inout), dimension(:,:) :: flux, delta_xi
real, intent(in) :: factor

!-----------------------------------------------------------------------

 real, dimension(size(flux,1),size(flux,2)) :: dflux
 real :: fff

 fff = 1.0/factor

 dflux    = - nu*(1.0 - e_n1)
 delta_xi = delta_xi + mu_delt*nu*f_delt_n1

 delta_xi = (delta_xi + mu_delt*flux*fff)/&
                      (1.0 - mu_delt*(dflux + dflux_datmos*fff))  

 flux     = flux + dflux_datmos*delta_xi


!-----------------------------------------------------------------------

end subroutine diff_surface

!#######################################################################

subroutine vert_diff_up (delt, e, f, delta_xi_n, dt_xi, kbot)

!-----------------------------------------------------------------------

real,    intent(in)                      :: delt
real,    intent(in),    dimension(:,:,:) :: e, f
real,    intent(in) ,   dimension(:,:)   :: delta_xi_n
real,    intent(out),   dimension(:,:,:) :: dt_xi
integer, intent(in),    dimension(:,:), optional :: kbot

integer :: i, j, k, kb, nlev
!-----------------------------------------------------------------------

 if (present(kbot)) then
     do j = 1, size(dt_xi,2)
     do i = 1, size(dt_xi,1)
         kb = kbot(i,j)
         dt_xi(i,j,kb) = delta_xi_n(i,j)/delt
         do k = kb -1, 1, -1
           dt_xi(i,j,k) = e(i,j,k)*dt_xi(i,j,k+1) + f(i,j,k)
         end do
     end do
     end do
 else
    nlev = size(dt_xi,3)
    dt_xi(:,:,nlev) = delta_xi_n/delt
    do k = size(dt_xi,3)-1, 1, -1
      dt_xi(:,:,k) = e(:,:,k)*dt_xi(:,:,k+1) + f(:,:,k)
    end do
 endif

!-----------------------------------------------------------------------

end subroutine vert_diff_up

!#######################################################################

subroutine compute_e (delt, mu, nu, e, a, b, c, g)

!-----------------------------------------------------------------------

real,    intent(in)                       :: delt
real,    intent(in)    , dimension(:,:,:) :: mu, nu
real,    intent(out)   , dimension(:,:,:) :: e, a, b, c, g

integer :: k, nlev

!-----------------------------------------------------------------------

 nlev = size(mu,3)

 a(:,:,1:nlev-1) = - mu(:,:,1:nlev-1)*nu(:,:,2:nlev)*delt
 a(:,:,nlev    ) =   0.0
 c(:,:,2:nlev  ) = - mu(:,:,2:nlev  )*nu(:,:,2:nlev)*delt
 c(:,:,1       ) =   0.0

 b = 1.0 - a - c

 e(:,:,1)   =   - a(:,:,1)/b(:,:,1)
 do  k= 2, nlev - 1
    g(:,:,k) = 1.0/(b(:,:,k) + c(:,:,k)*e(:,:,k-1))
    e(:,:,k) = - a(:,:,k)*g(:,:,k)
 enddo

!-----------------------------------------------------------------------

end subroutine compute_e

!#######################################################################

subroutine compute_f (dt_xi, b, c, g, f)

!-----------------------------------------------------------------------
real,    intent(in)    , dimension(:,:,:) :: dt_xi, b, c, g
real,    intent(out)   , dimension(:,:,:) :: f

integer :: k
!-----------------------------------------------------------------------

 f(:,:,1) =   dt_xi(:,:,1)/b(:,:,1)

 do  k = 2, size(b,3)-1
    f(:,:,k) = (dt_xi(:,:,k) - c(:,:,k)*f(:,:,k-1))*g(:,:,k)
 enddo

!-----------------------------------------------------------------------

end subroutine compute_f

!#######################################################################

subroutine explicit_tend (mu, nu, xi, dt_xi)

!-----------------------------------------------------------------------

real,    intent(in)    , dimension(:,:,:) :: mu, nu, xi
real,    intent(inout) , dimension(:,:,:) :: dt_xi

real, dimension(size(xi,1),size(xi,2),size(xi,3)) :: fluxx

integer :: nlev

!-----------------------------------------------------------------------

 nlev = size(mu,3)

 fluxx(:,:,1)      = 0.0
 fluxx(:,:,2:nlev) = nu(:,:,2:nlev)*(xi(:,:,2:nlev) - xi(:,:,1:nlev-1))

 dt_xi(:,:,1:nlev-1) = dt_xi(:,:,1:nlev-1) +  &
    mu(:,:,1:nlev-1)*(fluxx(:,:,2:nlev) - fluxx(:,:,1:nlev-1))
 dt_xi(:,:,nlev)     = dt_xi(:,:,nlev) - mu(:,:,nlev)*fluxx(:,:,nlev)

!-----------------------------------------------------------------------

end subroutine explicit_tend

!#######################################################################

subroutine compute_mu (p_half, mu)

!-----------------------------------------------------------------------
real,    intent(in)    , dimension(:,:,:) :: p_half
real,    intent(out)   , dimension(:,:,:) :: mu

integer :: nlev
!-----------------------------------------------------------------------

nlev = size(mu,3)

mu(:,:,1:nlev) = GRAV / (p_half(:,:,2:nlev+1) -p_half(:,:,1:nlev))

!-----------------------------------------------------------------------

end subroutine compute_mu


!#######################################################################

subroutine compute_nu (diff, p_half, p_full, z_full, t, q, nu)

!-----------------------------------------------------------------------
real,    intent(in)    , dimension(:,:,:) :: diff, p_half, p_full, &
                                             z_full, t, q
real,    intent(out)   , dimension(:,:,:) :: nu

real, dimension(size(t,1),size(t,2),size(t,3)) :: rho_half, tt
integer :: nlev
!-----------------------------------------------------------------------

nlev = size(nu,3)

if ( use_virtual_temp_vert_diff ) then
  tt = t * (1.0 + d608*q)           ! virtual temperature
else
  tt = t ! Take out virtual temperature effect here to mimic supersource
endif

rho_half(:,:,2:nlev) =  &         ! density at half levels
      2.0*p_half(:,:,2:nlev)/(RDGAS*(tt(:,:,2:nlev)+tt(:,:,1:nlev-1)))

if(do_mcm_plev) then
  nu(:,:,2:nlev) = GRAV*rho_half(:,:,2:nlev)*rho_half(:,:,2:nlev)*diff(:,:,2:nlev)/ &
                    (p_full(:,:,2:nlev)-p_full(:,:,1:nlev-1))
else
  nu(:,:,2:nlev) = rho_half(:,:,2:nlev)*diff(:,:,2:nlev) /  &
                    (z_full(:,:,1:nlev-1)-z_full(:,:,2:nlev))
endif
!-----------------------------------------------------------------------

end subroutine compute_nu

!#######################################################################

end module vert_diff_mod




module vert_diff_driver_mod

!-----------------------------------------------------------------------
!   module performs vertical diffusion of atmospheric variables
!-----------------------------------------------------------------------

use    vert_diff_mod, only:  surf_diff_type,     &
                             vert_diff_init, &
                             gcm_vert_diff_down, &
                             gcm_vert_diff_up,   &
                             vert_diff_end


use diag_manager_mod, only:  register_diag_field, send_data

use time_manager_mod, only:  time_type

use          mpp_mod, only:  input_nml_file
use          fms_mod, only:  file_exist, open_namelist_file, error_mesg,  &
                             check_nml_error, FATAL, mpp_pe, mpp_root_pe, &
                             close_file, write_version_number, stdlog

use    constants_mod, only:  CP_AIR, GRAV

use   field_manager_mod, only: MODEL_ATMOS
use  tracer_manager_mod, only: get_number_tracers, get_tracer_names, &
                               NO_TRACER

!-----------------------------------------------------------------------

implicit none
private

public :: vert_diff_driver_down, vert_diff_driver_up,  &
          vert_diff_driver_init, vert_diff_driver_end
public :: surf_diff_type


!-----------------------------------------------------------------------
!---- namelist ----

logical :: do_conserve_energy         = .false.
logical :: do_mcm_no_neg_q            = .false.
logical :: use_virtual_temp_vert_diff = .true.
logical :: do_mcm_plev                = .false.
logical :: do_mcm_vert_diff_tq        = .false.

namelist /vert_diff_driver_nml/ do_conserve_energy,         &
                                do_mcm_no_neg_q,            &
                                use_virtual_temp_vert_diff, &
                                do_mcm_plev, do_mcm_vert_diff_tq

!-----------------------------------------------------------------------
! tracer storage is used 
type :: tracer_storage_type
   integer :: id_tr_dt     = 0 ! diag id of the tracer tendency due 
                               ! to vert diff
   integer :: id_tr_dt_int = 0 ! diag id of the vertically-integrated 
                               ! tracer tendency
   real, pointer :: &
        buffer(:,:,:) => NULL() ! buffer for tendency calculations
end type
type(tracer_storage_type), allocatable :: tr_store(:)

real, allocatable, dimension(:,:,:) :: dt_t_save, dt_q_save

!-------------------- diagnostics fields -------------------------------

integer :: id_tdt_vdif, id_qdt_vdif, id_udt_vdif, id_vdt_vdif,  &
           id_sens_vdif, id_evap_vdif,                          &
           id_tdt_diss_vdif, id_diss_heat_vdif

real :: missing_value = -999.

character(len=9), parameter :: mod_name = 'vert_diff'

!-----------------------------------------------------------------------
!---- version number ----

character(len=128) :: version = '$Id: vert_diff_driver.F90,v 17.0.4.1 2010/08/30 20:33:36 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

logical :: module_is_initialized = .false.


contains

!#######################################################################

 subroutine vert_diff_driver_down (is, js, Time, delt, p_half, p_full, &
                                   z_full, diff_mom, diff_heat,        &
                                   u, v, t, q, trs,                    &
                                   dtau_du, dtau_dv, tau_x, tau_y,     &
                                   dt_u, dt_v, dt_t, dt_q, dt_trs,     &
                                   Surf_diff,  mask, kbot              )

integer, intent(in)                     :: is, js
type(time_type),   intent(in)           :: Time
real, intent(in)                        :: delt
real, intent(in)   , dimension(:,:,:)   :: p_half, p_full, z_full,  &
                                           diff_mom, diff_heat
real, intent(in),    dimension(:,:,:)   :: u, v, t, q
real, intent(in),    dimension(:,:,:,:) :: trs
real, intent(in),    dimension(:,:)     :: dtau_du, dtau_dv

real, intent(inout), dimension(:,:)     :: tau_x, tau_y
real, intent(inout), dimension(:,:,:)   :: dt_u, dt_v, dt_t, dt_q
real, intent(inout), dimension(:,:,:,:) :: dt_trs

type(surf_diff_type), intent(inout)     :: Surf_diff

real   , intent(in), dimension(:,:,:), optional :: mask
integer, intent(in), dimension(:,:),   optional :: kbot

real, dimension(size(t,1),size(t,2),size(t,3)) :: tt, dpg, q_2
real, dimension(size(t,1),size(t,2),size(t,3)) :: dissipative_heat
integer :: k, ntp, tr
logical :: used
real, dimension(size(t,1),size(t,2)) :: diag2
integer :: ie, je

!-----------------------------------------------------------------------

  if (.not. module_is_initialized) call error_mesg       &
                  ('vert_diff_driver_mod',  &
                   'vert_diff_driver_init must be called first', FATAL)

!-----------------------------------------------------------------------

  ntp = size(dt_trs,4) ! number of prognostic tracers
  if (size(trs,4) < ntp) call error_mesg ('vert_diff_driver', &
             'Number of tracers .lt. number of tracer tendencies',FATAL)

  ie = is + size(t,1) -1
  je = js + size(t,2) -1


    if(do_mcm_vert_diff_tq) then
      dt_t_save(is:ie,js:je,:) = dt_t
      dt_q_save(is:ie,js:je,:) = dt_q
      dt_t = 0.0
      dt_q = 0.0
    endif

!-----------------------------------------------------------------------
!---- to do diagnostics on dt_t, dt_q, dt_u, and dt_v at this point add 
!-----in the negative value of the field.  Note that the multiplication
!---- by 2 is necessary to get the correct value because sum_diag_phys
!---- is called twice for this single field
!-----------------------------------------------------------------------




!------- diagnostics for uwnd_diff -------
    if ( id_udt_vdif > 0 ) then
       used = send_data ( id_udt_vdif, -2.*dt_u, Time, is, js, 1, &
                          rmask=mask )
    endif

!------- diagnostics for vwnd_diff -------
    if ( id_vdt_vdif > 0 ) then
       used = send_data ( id_vdt_vdif, -2.*dt_v, Time, is, js, 1, &
                          rmask=mask )
    endif


!------- diagnostics for dt/dt_diff -------
    if ( id_tdt_vdif > 0 ) then
       used = send_data ( id_tdt_vdif, -3.*dt_t, Time, is, js, 1, &
                           rmask=mask )
    endif
    
!------- diagnostics for dq/dt_diff -------
    if ( id_qdt_vdif > 0 ) then
       used = send_data ( id_qdt_vdif, -2.*dt_q, Time, is, js, 1, &
                          rmask=mask )
    endif

    ! store values of tracer tendencies before the vertical diffusion, if 
    ! requested -- availability of storage serves as an indicatior that 
    ! storing is necessary
    do tr = 1,size(tr_store(:))
       if( associated(tr_store(tr)%buffer) ) &
            tr_store(tr)%buffer(is:ie,js:je,:) = dt_trs(:,:,:,tr)
    enddo

!-----------------------------------------------------------------------
!---- local temperature ----
!     (avoids divid by zero when computing virtual temp)

   tt = t
   if (present(mask)) where (mask < 0.5) tt = 200.

!-----------------------------------------------------------------------
!---- momentum diffusion ----
!---- heat/moisture diffusion (down only) ----
!---- tracer diffusion (no surface flux) ----

 q_2 = q
 if (do_mcm_no_neg_q) then
   where (q_2 < 0.0)  q_2 = 0.0
 endif

 call gcm_vert_diff_down (is, js, delt, u, v, tt, q_2, trs(:,:,:,1:ntp), &
                          diff_mom, diff_heat, p_half, p_full, z_full,   &
                          tau_x, tau_y, dtau_du, dtau_dv,                &
                          dt_u, dt_v, dt_t, dt_q, dt_trs(:,:,:,1:ntp), &
                          dissipative_heat, Surf_diff,  kbot           )

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!---- to do diagnostics on dt_u, and dt_v at this point add 
!-----in the value of the field.  Note that the multiplication
!---- by 2 is necessary to get the correct value because sum_diag_phys
!---- is called twice for this single field
!-----------------------------------------------------------------------

!------ preliminary calculations for vert integrals -----
    if ( id_sens_vdif > 0 .or. id_evap_vdif > 0 .or. id_diss_heat_vdif > 0 ) then
            do k = 1, size(p_half,3)-1
               dpg(:,:,k) = (p_half(:,:,k+1)-p_half(:,:,k))/GRAV
            enddo
            if (present(mask)) dpg = dpg*mask
    endif
    

!------- diagnostics for sens_diff -------
    if ( id_sens_vdif > 0 ) then
!         --- compute column changes ---
          diag2 = sum( dt_t*dpg, 3 )
          used = send_data ( id_sens_vdif, -2.*CP_AIR*diag2, Time, is, js )
    endif

!------- diagnostics for evap_diff -------
    if ( id_evap_vdif > 0 ) then
!         --- compute column changes ---
          diag2 = sum( dt_q*dpg, 3 )
          used = send_data ( id_evap_vdif, -2.*diag2, Time, is, js )
    endif
    
    

!------- diagnostics for uwnd_diff -------
    if ( id_udt_vdif > 0 ) then
       used = send_data ( id_udt_vdif, 2.*dt_u, Time, is, js, 1, &
                          rmask=mask )
    endif

!------- diagnostics for vwnd_diff -------
    if ( id_vdt_vdif > 0 ) then
       used = send_data ( id_vdt_vdif, 2.*dt_v, Time, is, js, 1, &
                          rmask=mask )
    endif
    
!------- diagnostics for dissipative heating -------
    if ( id_tdt_diss_vdif > 0 ) then
       used = send_data ( id_tdt_diss_vdif, dissipative_heat, Time, &
                          is, js, 1, &
                          rmask=mask)
    endif

!------- diagnostics for dt/dt_diff -------
    if ( id_tdt_vdif > 0 ) then
       used = send_data ( id_tdt_vdif, -3.*dissipative_heat, Time, is, js, 1, &
                           rmask=mask )
    endif

!------- diagnostics for vertically integrated dissipative heating -------
    if ( id_diss_heat_vdif > 0 ) then
          diag2 = sum( CP_AIR*dissipative_heat*dpg, 3 )
          used = send_data ( id_diss_heat_vdif, diag2, Time, is, js )
    endif

!-----------------------------------------------------------------------

 end subroutine vert_diff_driver_down

!#######################################################################

 subroutine vert_diff_driver_up (is, js, Time, delt, p_half, &
                                 Surf_diff, dt_t, dt_q, dt_tr, mask, kbot)

 integer,           intent(in)            :: is, js
 type(time_type),   intent(in)            :: Time
 real,    intent(in)                      :: delt
 real,    intent(in),    dimension(:,:,:) :: p_half
 type(surf_diff_type),   intent(in)       :: Surf_diff
 real,    intent(inout), dimension(:,:,:) :: dt_t, dt_q
 real,    intent(inout), dimension(:,:,:,:) :: dt_tr
 real   , intent(in), dimension(:,:,:), optional :: mask
 integer, intent(in),    dimension(:,:), optional :: kbot

 integer :: k, tr
 logical :: used
 real, dimension(size(p_half,1),size(p_half,2),size(p_half,3)-1) :: dpg
 real, dimension(size(p_half,1),size(p_half,2)) :: diag2
 integer :: ie, je

!-----------------------------------------------------------------------
    ie = is + size(p_half,1) -1
    je = js + size(p_half,2) -1
!-----------------------------------------------------------------------

    call gcm_vert_diff_up (is, js, delt, Surf_diff, dt_t, dt_q, dt_tr, kbot)


!-----------------------------------------------------------------------
!---- to do diagnostics on dt_t and dt_q at this point add in the
!---- the postive value of the field.  Note that the multiplication
!---- by 2 is necessary to get the correct value because sum_diag_phys
!---- is called twice for this single field
!-----------------------------------------------------------------------
!------- diagnostics for dt/dt_diff -------

    if ( id_tdt_vdif > 0 ) then
       used = send_data ( id_tdt_vdif, 3.*dt_t, Time, is, js, 1, &
                          rmask=mask )
    endif

!------- diagnostics for dq/dt_diff -------
    if ( id_qdt_vdif > 0 ) then
       used = send_data ( id_qdt_vdif, 2.*dt_q, Time, is, js, 1, &
                          rmask=mask )
    endif

!------ preliminary calculations for vert integrals -----
    if ( id_sens_vdif > 0 .or. id_evap_vdif > 0 ) then
            do k = 1, size(p_half,3)-1
               dpg(:,:,k) = (p_half(:,:,k+1)-p_half(:,:,k))/GRAV
            enddo
            if (present(mask)) dpg = dpg*mask
    endif

!------- diagnostics for sens_diff -------
    if ( id_sens_vdif > 0 ) then
!         --- compute column changes ---
          diag2 = sum( dt_t*dpg, 3 )
          used = send_data ( id_sens_vdif, 2.*CP_AIR*diag2, Time, is, js )
    endif

!------- diagnostics for evap_diff -------
    if ( id_evap_vdif > 0 ) then
!         --- compute column changes ---
          diag2 = sum( dt_q*dpg, 3 )
          used = send_data ( id_evap_vdif, 2.*diag2, Time, is, js )
    endif

!------- diagnostics of tracer tendencies ------- 
    do tr = 1, size(tr_store(:))
       if(tr_store(tr)%id_tr_dt > 0) then
          used = send_data(tr_store(tr)%id_tr_dt, &
               dt_tr(:,:,:,tr)-tr_store(tr)%buffer(is:ie,js:je,:),Time,is,js)
       endif
       
       if(tr_store(tr)%id_tr_dt_int > 0) then
          diag2 = sum((dt_tr(:,:,:,tr)-tr_store(tr)%buffer(is:ie,js:je,:))*dpg,3)
          used = send_data(tr_store(tr)%id_tr_dt_int, diag2, Time, is, js)
       endif
    enddo

    if(do_mcm_vert_diff_tq) then
      dt_t = dt_t + dt_t_save(is:ie,js:je,:)
      dt_q = dt_q + dt_q_save(is:ie,js:je,:)
    endif

!-----------------------------------------------------------------------

 end subroutine vert_diff_driver_up

!#######################################################################

 subroutine vert_diff_driver_init ( Surf_diff, idim, jdim, kdim,  &
                                    axes, Time )

 type(surf_diff_type), intent(inout) :: Surf_diff
 integer             , intent(in)    :: idim, jdim, kdim, axes(4)
 type(time_type)     , intent(in)    :: Time

 integer :: unit, io, ierr, tr, logunit
 integer :: ntprog ! number of prognostic tracers in the atmosphere
 character(len=32)  :: name, units ! name of the tracer
 character(len=128) :: longname    ! long name of the tracer

!-----------------------------------------------------------------------
!------ read namelist ------

#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=vert_diff_driver_nml, iostat=io)
   ierr = check_nml_error(io,'vert_diff_driver_nml')
#else   
   if ( file_exist('input.nml')) then
      unit = open_namelist_file ()
      ierr=1; do while (ierr /= 0)
         read  (unit, nml=vert_diff_driver_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'vert_diff_driver_nml')
      enddo
 10   call close_file (unit)
   endif
#endif

!--------- write version number and namelist ------------------

   call write_version_number ( version, tagname )
   logunit = stdlog()
   if(mpp_pe() == mpp_root_pe() ) write(logunit,nml=vert_diff_driver_nml)

!-------- initialize gcm vertical diffusion ------

   call vert_diff_init (Surf_diff, idim, jdim, kdim, do_conserve_energy, &
                        use_virtual_temp_vert_diff, do_mcm_plev)

!-----------------------------------------------------------------------

   if(do_mcm_vert_diff_tq) then
     allocate(dt_t_save(idim,jdim,kdim)) ; dt_t_save = 0.0
     allocate(dt_q_save(idim,jdim,kdim)) ; dt_q_save = 0.0
   endif

!--------------- initialize diagnostic fields --------------------

   id_tdt_vdif = &
   register_diag_field ( mod_name, 'tdt_vdif', axes(1:3), Time, &
                        'Temperature tendency from vert diff',  &
                        'deg_K/s', missing_value=missing_value  )

   id_qdt_vdif = &
   register_diag_field ( mod_name, 'qdt_vdif', axes(1:3), Time, &
                        'Spec humidity tendency from vert diff',&
                        'kg/kg/s', missing_value=missing_value  )

   id_udt_vdif = &
   register_diag_field ( mod_name, 'udt_vdif', axes(1:3), Time, &
                        'Zonal wind tendency from vert diff',   &
                        'm/s2', missing_value=missing_value     )

   id_vdt_vdif = &
   register_diag_field ( mod_name, 'vdt_vdif', axes(1:3), Time,    &
                        'Meridional wind tendency from vert diff', &
                        'm/s2', missing_value=missing_value        )

   id_sens_vdif = &
   register_diag_field ( mod_name, 'sens_vdif', axes(1:2), Time,  &
                        'Integrated heat flux from vert diff',    &
                        'W/m2' )

   id_evap_vdif = &
   register_diag_field ( mod_name, 'evap_vdif', axes(1:2), Time,    &
                        'Integrated moisture flux from vert diff',  &
                        'kg/m2/s' )

   id_tdt_diss_vdif = &
   register_diag_field ( mod_name, 'tdt_diss_vdif', axes(1:3), Time,  &
                        'Dissipative heating from vert_diff', 'deg_K/s', &
                         missing_value=missing_value  ) 

   id_diss_heat_vdif = &
   register_diag_field ( mod_name, 'diss_heat_vdif', axes(1:2), Time,  &
                        'Integrated dissipative heating from vert diff',  &
                        'W/m2' )

   ! initialize diagnostics tracers
   call get_number_tracers(MODEL_ATMOS, num_prog=ntprog)
   allocate(tr_store(ntprog))
   do tr = 1,ntprog
      call get_tracer_names( MODEL_ATMOS, tr, name, longname, units )
      tr_store(tr)%id_tr_dt = &
        register_diag_field ( mod_name, trim(name)//'dt_vdif', axes(1:3), Time, &
           'Tendency of '//trim(longname)//' from vert diff', trim(units)//'/s')
      tr_store(tr)%id_tr_dt_int = &
        register_diag_field ( mod_name, trim(name)//'dt_vint_vdif', axes(1:2), Time, &
           'Integrated tendency of '//trim(longname)//' from vert diff',&
           trim(units)//' kg/(m2 s)')

      if(tr_store(tr)%id_tr_dt>0 .or.tr_store(tr)%id_tr_dt_int>0 ) &
           allocate(tr_store(tr)%buffer(idim,jdim,kdim))
   enddo

!-----------------------------------------------------------------------

   module_is_initialized = .true.

!-----------------------------------------------------------------------

 end subroutine vert_diff_driver_init

!#######################################################################

 subroutine vert_diff_driver_end

   integer :: tr ! tracer index

   call vert_diff_end
   if(do_mcm_vert_diff_tq) deallocate(dt_t_save, dt_q_save)
   ! deallocate tracer diagnostics storage
   do tr = 1,size(tr_store(:))
      if(associated(tr_store(tr)%buffer)) &
           deallocate(tr_store(tr)%buffer)
   enddo
   deallocate(tr_store)

!-----------------------------------------------------------------------

   module_is_initialized = .false.

!-----------------------------------------------------------------------
 end subroutine vert_diff_driver_end

!#######################################################################

end module vert_diff_driver_mod




module vert_turb_driver_mod

!-----------------------------------------------------------------------
!
!       driver for compuing vertical diffusion coefficients
!
!         choose either:
!              1) mellor-yamada 2.5 (with tke)
!              2) non-local K scheme
!              3) entrainment and diagnostic turbulence (edt) from
!                 Bretherton and Grenier
!
!-----------------------------------------------------------------------
!---------------- modules ---------------------


use      my25_turb_mod, only: my25_turb_init, my25_turb_end,  &
                              my25_turb, tke_surf, get_tke,   &
                              my25_turb_restart

use    diffusivity_mod, only: diffusivity, molecular_diff

use            edt_mod, only: edt_init, edt, edt_end

use    strat_cloud_mod, only: strat_cloud_on

use   shallow_conv_mod, only: shallow_conv_init, shallow_conv

use stable_bl_turb_mod, only: stable_bl_turb_init, stable_bl_turb

use        entrain_mod, only: entrain_init, entrain, entrain_end

use   diag_manager_mod, only: register_diag_field, send_data

use   time_manager_mod, only: time_type, get_time, operator(-)

use      constants_mod, only: rdgas, rvgas, kappa
 
use            mpp_mod, only: input_nml_file
use            fms_mod, only: mpp_pe, mpp_root_pe, stdlog, &
                              error_mesg, open_namelist_file, file_exist, &
                              check_nml_error, close_file, FATAL, &
                              write_version_number
 

use  field_manager_mod, only: MODEL_ATMOS

use tracer_manager_mod, only: get_tracer_index

implicit none
private

!---------------- interfaces ---------------------

public   vert_turb_driver_init, vert_turb_driver_end, vert_turb_driver
public   vert_turb_driver_restart


!-----------------------------------------------------------------------
!--------------------- version number ----------------------------------

character(len=128) :: version = '$Id: vert_turb_driver.F90,v 17.0.4.1 2010/08/30 20:33:36 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized = .false.

!-----------------------------------------------------------------------
 real, parameter :: p00    = 1000.0E2
 real, parameter :: p00inv = 1./p00
 real, parameter :: d622   = rdgas/rvgas
 real, parameter :: d378   = 1.-d622
 real, parameter :: d608   = d378/d622

!---------------- private data -------------------

 real :: gust_zi = 1000.   ! constant for computed gustiness (meters)

 integer :: nql, nqi, nqa    !  tracer indices for stratiform clouds

!-----------------------------------------------------------------------
!-------------------- namelist -----------------------------------------

 logical :: do_shallow_conv  = .false.
 logical :: do_mellor_yamada = .true.
 logical :: do_diffusivity         = .false.
 logical :: do_molecular_diffusion = .false.
 logical :: do_edt                 = .false.
 logical :: do_stable_bl     = .false.
 logical :: use_tau          = .true.
 logical :: do_entrain    = .false.
 logical :: do_simple = .false. 

 character(len=24) :: gust_scheme  = 'constant' ! valid schemes are:
                                                !   => 'constant'
                                                !   => 'beljaars'
 real              :: constant_gust = 1.0
 real              :: gust_factor   = 1.0
 
 namelist /vert_turb_driver_nml/ do_shallow_conv, do_mellor_yamada, &
                                 gust_scheme, constant_gust, use_tau, &
                                 do_molecular_diffusion, do_stable_bl, &
                                 do_diffusivity, do_edt, do_entrain, &
                                 gust_factor, do_simple

!-------------------- diagnostics fields -------------------------------

integer :: id_tke,    id_lscale, id_lscale_0, id_z_pbl, id_gust,  &
           id_diff_t, id_diff_m, id_diff_sc, id_z_full, id_z_half,&
           id_uwnd,   id_vwnd,   id_diff_t_stab, id_diff_m_stab,  &
           id_diff_t_entr, id_diff_m_entr    

real :: missing_value = -999.

character(len=9) :: mod_name = 'vert_turb'

!-----------------------------------------------------------------------

contains

!#######################################################################

subroutine vert_turb_driver (is, js, Time, Time_next, dt, tdtlw,     &
                             frac_land,   &
                             p_half, p_full, z_half, z_full, u_star,   &
                             b_star, q_star, rough, lat, convect,      &
                             u, v, t, q, r, um, vm, tm, qm, rm,        &
                             udt, vdt, tdt, qdt, rdt, diff_t, diff_m,  &
                             gust, z_pbl, mask, kbot                   )

!-----------------------------------------------------------------------
integer,         intent(in)         :: is, js
type(time_type), intent(in)         :: Time, Time_next
   real,         intent(in)         :: dt
   real, intent(in), dimension(:,:) :: frac_land, u_star, b_star,  &
                                       q_star, rough, lat
logical, intent(in), dimension(:,:) :: convect       
   real, intent(in), dimension(:,:,:) :: tdtlw, p_half, p_full, &
                                         z_half, z_full, &
                                         u, v, t, q, um, vm, tm, qm, &
                                         udt, vdt, tdt, qdt
   real, intent(in) ,   dimension(:,:,:,:) :: r, rm, rdt
   real, intent(out),   dimension(:,:,:) :: diff_t, diff_m
   real, intent(out),   dimension(:,:)   :: gust, z_pbl 
   real, intent(in),optional, dimension(:,:,:) :: mask
integer, intent(in),optional, dimension(:,:) :: kbot
!-----------------------------------------------------------------------
real   , dimension(size(t,1),size(t,2),size(t,3))   :: ape, thv
logical, dimension(size(t,1),size(t,2),size(t,3)+1) :: lmask
real   , dimension(size(t,1),size(t,2),size(t,3)+1) :: el, diag3
real   , dimension(size(t,1),size(t,2),size(t,3)+1) :: tke
real   , dimension(size(t,1),size(t,2))             :: stbltop
real   , dimension(size(t,1),size(t,2))             :: el0, vspblcap
real   , dimension(size(diff_t,1),size(diff_t,2), &
                                  size(diff_t,3))   :: diff_sc,     &
                                                       diff_t_stab, &
                                                       diff_m_stab, &
       diff_t_entr, &
       diff_m_entr, &
       use_entr
real   , dimension(size(t,1),size(t,2),size(t,3))   :: tt, qq, uu, vv
real   , dimension(size(t,1),size(t,2),size(t,3))   :: qlin, qiin, qain
real    :: dt_tke
integer :: ie, je, nlev, sec, day, nt
logical :: used
!-----------------------------------------------------------------------
!----------------------- vertical turbulence ---------------------------
!-----------------------------------------------------------------------

      if (.not. module_is_initialized)  call error_mesg  &
                     ('vert_turb_driver in vert_turb_driver_mod',  &
                      'initialization has not been called', FATAL)

     nlev = size(p_full,3)
     ie = is + size(p_full,1) - 1
     je = js + size(p_full,2) - 1

!-----------------------------------------------------------------------
!---- set up state variable used by this module ----

      if (use_tau) then
      !-- variables at time tau
          uu = u
          vv = v
          tt = t
          qq = q
      else
      !-- variables at time tau+1
          uu = um + dt*udt
          vv = vm + dt*vdt
          tt = tm + dt*tdt
          qq = qm + dt*qdt
      endif

      !------ setup cloud variables: ql & qi & qa -----
      if (strat_cloud_on) then
           nt=size(r,4)
           if (nt == 0 .or. nt < max(nql,nqi,nqa))                    &
        call error_mesg ('vert_turb_driver',                  & 
                     'number of tracers less than nql or nqi or nqa', &
      FATAL) 
           if (use_tau) then
                qlin (:,:,:)=r(:,:,:,nql)
                qiin (:,:,:)=r(:,:,:,nqi)
                qain (:,:,:)=r(:,:,:,nqa)
           else
                qlin (:,:,:)=rm(:,:,:,nql)+rdt(:,:,:,nql)*dt
                qiin (:,:,:)=rm(:,:,:,nqi)+rdt(:,:,:,nqi)*dt
                qain (:,:,:)=rm(:,:,:,nqa)+rdt(:,:,:,nqa)*dt
           endif
      else
           qlin = 0.0
           qiin = 0.0
           qain = 0.0
      end if

!--------------------------------------------------------------------

!--------------------------------------------------------------------
! initialize output

   diff_t = 0.0
   diff_m = 0.0
   z_pbl = -999.0
   
!-------------------------------------------------------------------
! initiallize variables   
   vspblcap = 0.0   
   
!-----------------------------------------------------------------------
if (do_mellor_yamada) then

!    ----- virtual temp ----------
     ape(:,:,:)=(p_full(:,:,:)*p00inv)**(-kappa)
     if(do_simple) then 
       thv(:,:,:)=tt(:,:,:)*ape(:,:,:)
     else
       thv(:,:,:)=tt(:,:,:)*(qq(:,:,:)*d608+1.0)*ape(:,:,:)
     endif  
     if (present(mask)) where (mask < 0.5) thv = 200.

 endif

!---------------------------
 if (do_mellor_yamada) then
!---------------------------

!    ----- time step for prognostic tke calculation -----
     call get_time (Time_next-Time, sec, day)
     dt_tke = real(sec+day*86400)

!    --------------------- update tke-----------------------------------
!    ---- compute surface tke --------
!    ---- compute tke, master length scale (el0),  -------------
!    ---- length scale (el), and vert mix coeffs (diff_t,diff_m) ----

     call tke_surf  (is, js, u_star, kbot=kbot)



     if ( id_z_pbl > 0 ) then
     !------ compute pbl depth from k_profile if diagnostic needed -----
     call my25_turb (is, js, dt_tke, frac_land, p_half, p_full, thv, uu, vv, &
                     z_half, z_full, rough,   &
                     el0, el, diff_m, diff_t, &
                     mask=mask, kbot=kbot, &
                     ustar=u_star,bstar=b_star,h=z_pbl)
     else
     call my25_turb (is, js, dt_tke, frac_land, p_half, p_full, thv, uu, vv, &
                     z_half, z_full, rough,   &
                     el0, el, diff_m, diff_t, &
                     mask=mask, kbot=kbot)
     end if

!---------------------------
 else if (do_diffusivity) then
!--------------------------------------------------------------------
!----------- compute molecular diffusion, if desired  ---------------

    if (do_molecular_diffusion) then
      call molecular_diff (tt, p_half, diff_m, diff_t)
    else
      diff_m = 0.0
      diff_t = 0.0
    endif

!---------------------------
!------------------- non-local K scheme --------------


    call diffusivity ( tt, qq, uu, vv, p_full, p_half, z_full, z_half,   &
                       u_star, b_star, z_pbl, diff_m, diff_t, &
                       kbot = kbot)

!---------------------------
else if (do_edt) then
!----------------------------

!    ----- time step for prognostic tke calculation -----
      call get_time (Time_next-Time, sec, day)
      dt_tke = real(sec+day*86400)
 

      tke = 0.0

    call edt(is,ie,js,je,dt_tke,Time_next,tdtlw, u_star,b_star,q_star, &
             tt,qq,  &
             qlin,qiin,qain,uu,vv,z_full,p_full,z_half,p_half,stbltop, &
             diff_m,diff_t,z_pbl,kbot=kbot,tke=tke)


 endif
 


 
!------------------------------------------------------------------
! --- boundary layer entrainment parameterization

   if( do_entrain ) then

       call entrain(is,ie,js,je,Time_next,tdtlw, convect,u_star,b_star,&
                    tt,qq, &
            qlin,qiin,qain,uu,vv,z_full,p_full,z_half,p_half,diff_m,   &
    diff_t,diff_m_entr,diff_t_entr,use_entr,z_pbl,vspblcap,    &
    kbot=kbot)
   
   endif

!-----------------------------------------------------------------------
! --- stable boundary layer parameterization

   if( do_stable_bl ) then

        if (do_entrain) then

CALL STABLE_BL_TURB( is, js, Time_next, tt, qq, qlin, qiin, uu,&
                     vv, z_half, z_full, u_star, b_star, lat,  &
     diff_m_stab, diff_t_stab,                 &
     vspblcap = vspblcap, kbot=kbot)
     
            diff_m = use_entr*diff_m_entr + (1-use_entr)*diff_m_stab
            diff_t = use_entr*diff_t_entr + (1-use_entr)*diff_t_stab
    
            !for diagnostic purposes only, save the stable_bl_turb
            !coefficient only where it was used
    
            diff_m_stab = (1-use_entr)*diff_m_stab
            diff_t_stab = (1-use_entr)*diff_t_stab    
         
else

CALL STABLE_BL_TURB( is, js, Time_next, tt, qq, qlin, qiin, uu,&
                     vv, z_half, z_full, u_star, b_star, lat,  &
     diff_m_stab, diff_t_stab,kbot=kbot)
     
            diff_m = diff_m +  MAX( diff_m_stab - diff_m, 0.0 )
            diff_t = diff_t +  MAX( diff_t_stab - diff_t, 0.0 )
    
end if
        
    endif
   
!-----------------------------------------------------------------------
!------------------ shallow convection ???? ----------------------------

   if (do_shallow_conv) then
        call shallow_conv (tt, qq, p_full, p_half, diff_sc, kbot)
        diff_t = diff_t + diff_sc
   endif

!-----------------------------------------------------------------------
!------------- define gustiness ------------

     if ( trim(gust_scheme) == 'constant' ) then
          gust = constant_gust
     else if ( trim(gust_scheme) == 'beljaars' ) then
!    --- from Beljaars (1994) and Beljaars and Viterbo (1999) ---
          where (b_star > 0.)
             gust = gust_factor * (u_star*b_star*gust_zi)**(1./3.)
          elsewhere
             gust = 0.
          endwhere
     endif

!-----------------------------------------------------------------------
!------------------------ diagnostics section --------------------------

if (do_mellor_yamada) then

!     --- set up local mask for fields with surface data ---
      if ( present(mask) ) then
         lmask(:,:,1)        = .true.
         lmask(:,:,2:nlev+1) = mask(:,:,1:nlev) > 0.5
      else
         lmask = .true.
      endif

!------- tke --------------------------------
      if ( id_tke > 0 ) then
         call get_tke(is,ie,js,je,tke)
         used = send_data ( id_tke, tke, Time_next, is, js, 1, &
                            mask=lmask )
      endif

!------- length scale (at half levels) ------
      if ( id_lscale > 0 ) then
         used = send_data ( id_lscale, el, Time_next, is, js, 1,  &
                            mask=lmask )
      endif

!------- master length scale -------
      if ( id_lscale_0 > 0 ) then
         used = send_data ( id_lscale_0, el0, Time_next, is, js )
      endif

end if

if (do_edt) then 
    
!     --- set up local mask for fields with surface data ---
    if ( present(mask) ) then
          lmask(:,:,1)        = .true.
          lmask(:,:,2:nlev+1) = mask(:,:,1:nlev) > 0.5
     else   
        lmask = .true.
       endif

!------- tke --------------------------------
      if ( id_tke > 0 ) then
        used = send_data ( id_tke, tke, Time_next, is, js, 1,     &
                          mask=lmask )
      endif
 
end if

!------- boundary layer depth -------
      if ( id_z_pbl > 0 ) then
         used = send_data ( id_z_pbl, z_pbl, Time_next, is, js )
      endif

!------- gustiness -------
      if ( id_gust > 0 ) then
         used = send_data ( id_gust, gust, Time_next, is, js )
      endif


!------- output diffusion coefficients ---------

  if ( id_diff_t > 0 .or. id_diff_m > 0 .or. id_diff_sc > 0 .or. &
       id_diff_t_stab > 0 .or. id_diff_m_stab > 0 .or.           &
       id_diff_t_entr > 0 .or. id_diff_m_entr > 0  ) then
!       --- set up local mask for fields without surface data ---
        if (present(mask)) then
            lmask(:,:,1:nlev) = mask(:,:,1:nlev) > 0.5
            lmask(:,:,nlev+1) = .false.
        else
            lmask(:,:,1:nlev) = .true.
            lmask(:,:,nlev+1) = .false.
        endif
!       -- dummy data at surface --
        diag3(:,:,nlev+1)=0.0
  endif

!------- diffusion coefficient for heat/moisture -------
   if ( id_diff_t > 0 ) then
      diag3(:,:,1:nlev) = diff_t(:,:,1:nlev)
      used = send_data ( id_diff_t, diag3, Time_next, is, js, 1, mask=lmask )
   endif

!------- diffusion coefficient for momentum -------
   if ( id_diff_m > 0 ) then
      diag3(:,:,1:nlev) = diff_m(:,:,1:nlev)
      used = send_data ( id_diff_m, diag3, Time_next, is, js, 1, mask=lmask )
   endif

!------- diffusion coefficient for shallow conv -------
 if (do_shallow_conv) then
   if ( id_diff_sc > 0 ) then
      diag3(:,:,1:nlev) = diff_sc(:,:,1:nlev)
      used = send_data ( id_diff_sc, diag3, Time_next, is, js, 1, mask=lmask)
   endif
 endif

!------- diffusion coefficients for stable boudary layer -------
   if (do_stable_bl) then
!------- for heat/moisture -------
    if ( id_diff_t_stab > 0 ) then
       diag3(:,:,1:nlev) = diff_t_stab(:,:,1:nlev)
      used = send_data ( id_diff_t_stab, diag3, Time_next, is, js, 1, mask=lmask )
  endif
!------- for momentum -------
    if ( id_diff_m_stab > 0 ) then
       diag3(:,:,1:nlev) = diff_m_stab(:,:,1:nlev)
     used = send_data ( id_diff_m_stab, diag3, Time_next, is, js, 1, mask=lmask )
    endif
 endif

!------- diffusion coefficients for entrainment module -------
 if (do_entrain) then
      if ( id_diff_t_entr > 0 ) then
       diag3(:,:,1:nlev) = diff_t_entr(:,:,1:nlev)
      used = send_data ( id_diff_t_entr, diag3, Time_next, is, js, 1, mask=lmask )
      endif
      if ( id_diff_m_entr > 0 ) then
       diag3(:,:,1:nlev) = diff_m_entr(:,:,1:nlev)
      used = send_data ( id_diff_m_entr, diag3, Time_next, is, js, 1, mask=lmask )
      endif
 endif

!--- geopotential height relative to the surface on full and half levels ----

   if ( id_z_half > 0 ) then
      !--- set up local mask for fields with surface data ---
      if ( present(mask) ) then
         lmask(:,:,1)        = .true.
         lmask(:,:,2:nlev+1) = mask(:,:,1:nlev) > 0.5
      else
         lmask = .true.
      endif
      used = send_data ( id_z_half, z_half, Time_next, is, js, 1, mask=lmask )
   endif
   
   if ( id_z_full > 0 ) then
      used = send_data ( id_z_full, z_full, Time_next, is, js, 1, rmask=mask)
   endif
   
!--- zonal and meridional wind on mass grid -------

   if ( id_uwnd > 0 ) then
      used = send_data ( id_uwnd, uu, Time_next, is, js, 1, rmask=mask)
   endif
  
   if ( id_vwnd > 0 ) then
      used = send_data ( id_vwnd, vv, Time_next, is, js, 1, rmask=mask)
   endif
  
 
   
!-----------------------------------------------------------------------

end subroutine vert_turb_driver

!#######################################################################

subroutine vert_turb_driver_init (lonb, latb, id, jd, kd, axes, Time, &
                                  doing_edt, doing_entrain)

!-----------------------------------------------------------------------
   real, dimension(:,:), intent(in) :: lonb, latb
   integer,         intent(in) :: id, jd, kd, axes(4)
   type(time_type), intent(in) :: Time
   logical,         intent(out) :: doing_edt, doing_entrain
!-----------------------------------------------------------------------
   integer, dimension(3) :: full = (/1,2,3/), half = (/1,2,4/)
   integer :: ierr, unit, io, logunit

      if (module_is_initialized)  &
          call error_mesg  &
                   ('vert_turb_driver_init in vert_turb_driver_mod',  &
                    'attempting to call initialization twice', FATAL)

!-----------------------------------------------------------------------
!--------------- read namelist ------------------

#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=vert_turb_driver_nml, iostat=io)
   ierr = check_nml_error(io,'vert_turb_driver_nml')
#else   
      if (file_exist('input.nml')) then
         unit = open_namelist_file (file='input.nml')
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=vert_turb_driver_nml, iostat=io, end=10)
            ierr = check_nml_error (io, 'vert_turb_driver_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!---------- output namelist --------------------------------------------

      logunit = stdlog()
      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           write (logunit,nml=vert_turb_driver_nml)
      endif

!     --- check namelist option ---
      if ( trim(gust_scheme) /= 'constant' .and. &
           trim(gust_scheme) /= 'beljaars' ) call error_mesg &
         ('vert_turb_driver_mod', 'invalid value for namelist '//&
          'variable GUST_SCHEME', FATAL)

      if (do_molecular_diffusion .and. do_mellor_yamada)  &
         call error_mesg ( 'vert_turb_driver_mod', 'cannot activate '//&
              'molecular diffusion with mellor_yamada', FATAL)
 
       if (do_molecular_diffusion .and. do_edt)  &
         call error_mesg ( 'vert_turb_driver_mod', 'cannot activate '//&
           'molecular diffusion with EDT', FATAL)

!-----------------------------------------------------------------------
        
       if (strat_cloud_on) then
! get tracer indices for stratiform cloud variables
          nql = get_tracer_index ( MODEL_ATMOS, 'liq_wat' )
          nqi = get_tracer_index ( MODEL_ATMOS, 'ice_wat' )
          nqa = get_tracer_index ( MODEL_ATMOS, 'cld_amt' )
          if (mpp_pe() == mpp_root_pe()) &
                 write (logunit,'(a,3i4)') 'Stratiform cloud tracer indices: nql,nqi,nqa =',nql,nqi,nqa
          if (min(nql,nqi,nqa) <= 0) call error_mesg ('moist_processes', &
                         'stratiform cloud tracer(s) not found', FATAL)
          if (nql == nqi .or. nqa == nqi .or. nql == nqa) call error_mesg ('moist_processes',  &
       'tracers indices cannot be the same (i.e., nql=nqi=nqa).', FATAL)
      endif

!----------------------------------------------------------------------

      if (do_mellor_yamada) call my25_turb_init (id, jd, kd)

      if (do_shallow_conv)  call shallow_conv_init (kd)

      if (do_stable_bl)     call stable_bl_turb_init ( axes, Time )

      if (do_edt)           call edt_init (lonb, latb, axes,Time,id,jd,kd)

      if (do_entrain)       call entrain_init (lonb, latb, axes,Time,id,jd,kd)
      
!-----------------------------------------------------------------------
!----- initialize diagnostic fields -----

   id_uwnd = register_diag_field ( mod_name, 'uwnd', axes(full), Time, &
        'zonal wind on mass grid', 'meters/second' ,                   &
         missing_value=missing_value    )

   id_vwnd = register_diag_field ( mod_name, 'vwnd', axes(full), Time, &
        'meridional wind on mass grid', 'meters/second' ,              &
        missing_value=missing_value    )

   id_z_full = &
   register_diag_field ( mod_name, 'z_full', axes(full), Time,    &
        'geopotential height relative to surface at full levels', &
         'meters' , missing_value=missing_value    )

   id_z_half = &
   register_diag_field ( mod_name, 'z_half', axes(half), Time,    &
        'geopotential height relative to surface at half levels', &
        'meters' , missing_value=missing_value    )

if (do_mellor_yamada) then

   id_tke = &
   register_diag_field ( mod_name, 'tke', axes(half), Time,      &
                        'turbulent kinetic energy',  'm2/s2'   , &
                        missing_value=missing_value               )

   id_lscale = &
   register_diag_field ( mod_name, 'lscale', axes(half), Time,    &
                        'turbulent length scale',  'm'   ,        &
                        missing_value=missing_value               )

   id_lscale_0 = &
   register_diag_field ( mod_name, 'lscale_0', axes(1:2), Time,   &
                        'master length scale',  'm'               )
endif

 if (do_edt) then
 
   id_tke = &
   register_diag_field ( mod_name, 'tke', axes(half), Time,      &
                         'turbulent kinetic energy',  'm2/s2'   , &
                         missing_value=missing_value               )
 
  end if

   id_z_pbl = &
   register_diag_field ( mod_name, 'z_pbl', axes(1:2), Time,       &
                        'depth of planetary boundary layer',  'm'  )

   id_gust = &
   register_diag_field ( mod_name, 'gust', axes(1:2), Time,        &
                        'wind gustiness in surface layer',  'm/s'  )

   id_diff_t = &
   register_diag_field ( mod_name, 'diff_t', axes(half), Time,    &
                        'vert diff coeff for temp',  'm2/s'   ,   &
                        missing_value=missing_value               )

   id_diff_m = &
   register_diag_field ( mod_name, 'diff_m', axes(half), Time,      &
                        'vert diff coeff for momentum',  'm2/s'   , &
                        missing_value=missing_value               )

if (do_shallow_conv) then

   id_diff_sc = &
   register_diag_field ( mod_name, 'diff_sc', axes(half), Time,      &
                        'vert diff coeff for shallow conv', 'm2/s' , &
                        missing_value=missing_value               )
endif

if (do_stable_bl) then
  id_diff_t_stab = &
    register_diag_field ( mod_name, 'diff_t_stab', axes(half), Time,       &
                       'vert diff coeff for temp',  'm2/s',                &
                        missing_value=missing_value               )

  id_diff_m_stab = &
    register_diag_field ( mod_name, 'diff_m_stab', axes(half), Time,       &
                       'vert diff coeff for momentum',  'm2/s',            &
                       missing_value=missing_value               )
 endif


if (do_entrain) then
  id_diff_m_entr = &
    register_diag_field ( mod_name, 'diff_m_entr', axes(half), Time,        &
            'momentum vert diff coeff from entrainment module',  'm2/s',    &
                        missing_value=missing_value               )

  id_diff_t_entr = &
    register_diag_field ( mod_name, 'diff_t_entr', axes(half), Time,        &
            'heat vert diff coeff from entrainment module',  'm2/s',        &
                        missing_value=missing_value               )

 endif


!-----------------------------------------------------------------------

   doing_edt = do_edt
   doing_entrain = do_entrain
   module_is_initialized =.true.

!-----------------------------------------------------------------------

end subroutine vert_turb_driver_init


!#######################################################################

subroutine vert_turb_driver_end

!-----------------------------------------------------------------------
      if (do_mellor_yamada) call my25_turb_end
      if (do_edt) call edt_end
      if (do_entrain) call entrain_end
      module_is_initialized =.false.

!-----------------------------------------------------------------------

end subroutine vert_turb_driver_end

!#######################################################################
! <SUBROUTINE NAME="vert_turb_driver_restart">
!
! <DESCRIPTION>
! write out restart file.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
subroutine vert_turb_driver_restart(timestamp)
  character(len=*), intent(in), optional :: timestamp

   if (do_mellor_yamada) call my25_turb_restart(timestamp)
end subroutine vert_turb_driver_restart
! </SUBROUTINE> NAME="vert_turb_driver_restart"


end module vert_turb_driver_mod



module atmos_nudge_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only: check_nml_error, close_file, &
                   stdlog, mpp_pe, mpp_root_pe, write_version_number, &
                   error_mesg, FATAL, WARNING
use time_manager_mod, only: time_type, set_time, get_date, &
                            operator( + ), operator( < )
use data_override_mod,only: data_override
use diag_manager_mod, only: register_diag_field, send_data
use mpp_mod, only: mpp_min,mpp_max

implicit none
private

public :: atmos_nudge_init, get_atmos_nudge, atmos_nudge_end, do_ps

character(len=128), parameter :: version = '$Id: atmos_nudge.F90,v 17.0.4.1.2.1 2010/09/07 18:39:55 pjp Exp $'
character(len=128), parameter :: tagname = '$Name: hiram_20101115_bw $'

logical :: module_is_initialized = .false.

integer :: freq = 0   ! frequency in seconds
real ::  u_tau = -1.  ! relaxation time in seconds (no insertion if < 0)
real ::  v_tau = -1.
real ::  t_tau = -1.
real ::  q_tau = -1.
real :: ps_tau = -1.
integer :: skip_top_v = 2            ! momentum
integer :: skip_bot_v = 0
integer :: skip_top_t = 0            ! temperature
integer :: skip_bot_t = 21
integer :: skip_top_q = 8            ! specific humidity
integer :: skip_bot_q = 0

namelist /atmos_nudge_nml/ freq, u_tau, v_tau, t_tau, q_tau, ps_tau, &
                           skip_top_v, skip_bot_v,               &
                           skip_top_t, skip_bot_t,               &
                           skip_top_q, skip_bot_q

type(time_type) :: Time_next
integer :: id_udt, id_vdt, id_tdt, id_qdt, id_psdt
logical :: do_u, do_v, do_t, do_q, do_ps

contains

!-----------------------------------------------------------------------

subroutine get_atmos_nudge(Time, dt, beglon, endlon, beglat, endlat, nlev,  &
                           ng, ps, u, v, t, q, psdt, udt, vdt, tdt, qdt )
type (time_type),       intent(in)    :: Time
real,                   intent(in)    :: dt

integer, intent(in):: beglon, endlon, beglat, endlat, nlev, ng

real, intent(inout):: ps(beglon:endlon, beglat:endlat)
real, intent(inout):: psdt(beglon:endlon, beglat:endlat)

real, intent(inout):: u(beglon:endlon, beglat:endlat, nlev)
real, intent(inout):: v(beglon:endlon, beglat:endlat, nlev)
real, intent(inout):: t(beglon:endlon, beglat-ng:endlat+ng, nlev)
real, intent(inout):: q(beglon:endlon, beglat-ng:endlat+ng, nlev)

real, intent(inout):: udt(beglon:endlon, beglat:endlat, nlev)
real, intent(inout):: vdt(beglon:endlon, beglat:endlat, nlev)
real, intent(inout):: tdt(beglon:endlon, beglat:endlat, nlev)
real, intent(inout):: qdt(beglon:endlon, beglat:endlat, nlev)

real ::  obs(beglon:endlon, beglat:endlat, nlev)
real :: tend(beglon:endlon, beglat:endlat, nlev)
real ::  obs2(beglon:endlon, beglat:endlat)
real :: tend2(beglon:endlon, beglat:endlat)
real :: factor(nlev,3)
logical :: sent, done
integer :: i,j,k

   if (.not.module_is_initialized) then
       call error_mesg ('atmos_nudge_mod', 'module not initialized', FATAL)
   endif

 ! no data forcing override
   if (freq <= 0) then
       return
   endif

 ! is it time for data forcing
   if (Time < Time_next) then
       return
   endif
   Time_next = Time_next + set_time(freq)

! vertically dependent Tau
! very crude - zero at top/bottom + linear increase with level downward/upward

   factor = 1.

!------------------------------------------------------------------
! Momentum:
   if (skip_top_v > 0) then
      factor(1,1) = 0.
      do k = 2, skip_top_v
         factor(k,1) = factor(k-1,1) + 1./real(skip_top_v)
      enddo
   endif
   if (skip_bot_v > 0) then
      factor(nlev,1) = 0.
      do k = nlev-1, nlev-skip_bot_v+1, -1
         factor(k,1) = factor(k+1,1) + 1./real(skip_bot_v)
      enddo
   endif

! temperature
   if (skip_top_t > 0) then
      factor(1,2) = 0.
      do k = 2, skip_top_t
         factor(k,2) = factor(k-1,2) + 1./real(skip_top_t)
      enddo
   endif
   if (skip_bot_t > 0) then
         factor(nlev-skip_bot_t-1,2) = 0.5
         factor(nlev-skip_bot_t,  2) = 0.25
      do k=nlev-skip_bot_t+1,nlev
         factor(k,2) = 0.
      enddo
   endif
   
! Specific humidity
   if (skip_top_q > 0) then
      do k = 1, skip_top_q
         factor(k,3) = 0.
      enddo
         factor(skip_top_q+1,3) = 0.25
         factor(skip_top_q+2,3) = 0.5
   endif
   if (skip_bot_q > 0) then
      factor(nlev,3) = 0.
      do k = nlev-1, nlev-skip_bot_q+1, -1
         factor(k,3) = factor(k+1,3) + 1./real(skip_bot_q)
      enddo
   endif
!------------------------------------------------------------------

! zonal wind component
   if (do_u .or. id_udt>0) then
       call data_override ('ATM', 'u_obs', obs, Time, override=done)
       if (.not.done) call override_error (Time,'zonal wind')
   endif
   if (do_u) then
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = (obs(i,j,k) - u(i,j,k)) / (u_tau + dt) * factor(k,1)
                   u(i,j,k) = u(i,j,k) + dt*tend(i,j,k)
                 udt(i,j,k) = udt(i,j,k) + tend(i,j,k)
             enddo
          enddo
       enddo
   else
       if (id_udt > 0) then
!          tend = 0.
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
! Report the error if not nudging
                tend(i,j,k) = u(i,j,k) - obs(i,j,k)
             enddo
          enddo
       enddo
       endif
   endif
   if (id_udt > 0) sent = send_data (id_udt, tend, Time) ! masking?

! meridional wind component
   if (do_v .or. id_vdt>0) then
       call data_override ('ATM', 'v_obs', obs, Time, override=done)
       if (.not.done) call override_error (Time,'meridional wind')
   endif
   if (do_v) then
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = (obs(i,j,k) - v(i,j,k)) / (v_tau + dt) * factor(k,1)
                   v(i,j,k) = v(i,j,k) + dt*tend(i,j,k)
                 vdt(i,j,k) = vdt(i,j,k) + tend(i,j,k)
             enddo
          enddo
       enddo
   else
       if (id_vdt > 0) then
!          tend = 0.
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = v(i,j,k) - obs(i,j,k)
             enddo
          enddo
       enddo
       endif
   endif
   if (id_vdt > 0) sent = send_data (id_vdt, tend, Time) ! masking?

! temperature
   if (do_t .or. id_tdt>0) then
       call data_override ('ATM', 't_obs', obs, Time, override=done)
       if (.not.done) call override_error (Time,'temperature')
   endif
   if (do_t) then
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = (obs(i,j,k) - t(i,j,k)) / (t_tau + dt) * factor(k,2)
                   t(i,j,k) = t(i,j,k) + dt*tend(i,j,k)
                 tdt(i,j,k) = tdt(i,j,k) + tend(i,j,k)
             enddo
          enddo
       enddo
   else
       if (id_tdt > 0) then
!          tend = 0.
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = t(i,j,k) - obs(i,j,k)
             enddo
          enddo
       enddo
       endif
   endif
   if (id_tdt > 0) sent = send_data (id_tdt, tend, Time) ! masking?

! specific humidity
   if (do_q .or. id_qdt>0) then
       call data_override ('ATM', 'q_obs', obs, Time, override=done)
       if (.not.done) call override_error (Time,'specific humidity')
   endif
   if (do_q) then
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = (max(1.e-8,obs(i,j,k)) - q(i,j,k)) / (q_tau + dt) * factor(k,3)
                   q(i,j,k) = q(i,j,k) + dt*tend(i,j,k)
                 qdt(i,j,k) = qdt(i,j,k) + tend(i,j,k)
             enddo
          enddo
       enddo
   else
       if (id_qdt > 0) then
!          tend = 0.
       do k=1,nlev
          do j=beglat,endlat
             do i=beglon,endlon
                tend(i,j,k) = q(i,j,k) - obs(i,j,k)
             enddo
          enddo
       enddo
       endif
   endif
   if (id_qdt > 0) sent = send_data (id_qdt, tend, Time) ! masking?

! surface pressure
   if (do_ps .or. id_psdt>0) then
       call data_override ('ATM', 'ps_obs', obs2, Time, override=done)
       if (.not.done) call override_error (Time,'surface pressure')
   endif
   if (do_ps) then
       do j=beglat,endlat
          do i=beglon,endlon
             tend2(i,j) = (obs2(i,j) - ps(i,j)) / (ps_tau + dt)
                ps(i,j) = ps(i,j) + dt*tend2(i,j)
              psdt(i,j) = psdt(i,j) + tend2(i,j)
          enddo
       enddo
   else
       if (id_psdt > 0) then
!          tend2 = 0.
          do j=beglat,endlat
             do i=beglon,endlon
                tend2(i,j) = ps(i,j) - obs2(i,j)
             enddo
          enddo
       endif
   endif
   if (id_psdt > 0) sent = send_data (id_psdt, tend2, Time) ! masking?
!if (mpp_pe()==mpp_root_pe()) print *, 'Leaving atmos_nudge'

end subroutine get_atmos_nudge

!-----------------------------------------------------------------------

subroutine atmos_nudge_init ( Time, axes, flag )
type (time_type),      intent(in)  :: Time
integer, dimension(3), intent(in)  :: axes
logical, optional,     intent(out) :: flag
integer :: ierr, io, unit, logunit
real :: eps
character(len=64) :: desc
real :: missing_value = -1.e10

 ! read namelist
#ifdef INTERNAL_FILE_NML
   read (input_nml_file, nml=atmos_nudge_nml, iostat=io)
   ierr = check_nml_error(io, 'atmos_nudge_nml')
#else
   unit = open_namelist_file()
   ierr=1  
   do while (ierr /= 0)
     read (unit, nml=atmos_nudge_nml, iostat=io, end=10) 
     ierr = check_nml_error (io, 'atmos_nudge_nml')
   enddo   
10 call close_file (unit)
#endif
   call write_version_number (version, tagname)
   logunit=stdlog()
   if (mpp_pe() == mpp_root_pe()) write (logunit, nml=atmos_nudge_nml)

 ! initialize flags
   eps = 1.e-10
   do_u  = .false.; if ( u_tau > -eps) do_u  = .true.
   do_v  = .false.; if ( v_tau > -eps) do_v  = .true.
   do_t  = .false.; if ( t_tau > -eps) do_t  = .true.
   do_q  = .false.; if ( q_tau > -eps) do_q  = .true.
   do_ps = .false.; if (ps_tau > -eps) do_ps = .true.

 ! namelist dummy checks
 ! if no overrides turned on then set freq = 0
   if (freq > 0) then
       if ( .not.do_u .and. .not.do_v .and. .not.do_t .and. &
            .not.do_q .and. .not.do_ps ) then
!           call error_mesg ('atmos_nudge_mod', 'no variables specified '//&
!                            'for override, resetting freq = 0', WARNING)
!           freq = 0
            call error_mesg ('atmos_nudge_mod', 'no variables specified '//&
                             'for override', WARNING)
       endif
   else
       if ( do_u .or. do_v .or. do_t .or.  do_q .or. do_ps ) then
            call error_mesg ('atmos_nudge_mod', 'variables specified '//&
                             'for override when freq = 0', FATAL)
       endif
       freq = 0
   endif

 ! return flag = true when override is needed
   if (present(flag)) then
       flag = freq .gt. 0
   endif

 ! what is the next time for data insertion

   Time_next = Time + set_time(freq)

 ! initialize diagnostics

   desc = ' tendency due to data override/insertion'

   id_udt = register_diag_field ('atmos_nudge', 'udt_nudge', axes, Time, &
                                 'zonal wind'//trim(desc), 'm/s2', missing_value=missing_value)
   id_vdt = register_diag_field ('atmos_nudge', 'vdt_nudge', axes, Time, &
                                 'meridional wind'//trim(desc), 'm/s2',missing_value=missing_value)
   id_tdt = register_diag_field ('atmos_nudge', 'tdt_nudge', axes, Time, &
                                 'temperature'//trim(desc), 'degK/s',missing_value=missing_value)
   id_qdt = register_diag_field ('atmos_nudge', 'qdt_nudge', axes, Time, &
                                 'specific humidity'//trim(desc), 'kg/kg/s',missing_value=missing_value)
   id_psdt = register_diag_field ('atmos_nudge', 'psdt_nudge', axes(1:2), Time, &
                                 'surface pressure'//trim(desc), 'Pa/s',missing_value=missing_value)

   module_is_initialized = .true.

end subroutine atmos_nudge_init

!-----------------------------------------------------------------------

subroutine atmos_nudge_end

    u_tau = -1.
    v_tau = -1.
    t_tau = -1.
    q_tau = -1.
   ps_tau = -1.
   module_is_initialized = .false.

end subroutine atmos_nudge_end

!-----------------------------------------------------------------------

subroutine override_error ( Time, field )
type (time_type), intent(in) :: Time
character(len=*), intent(in) :: field
integer :: date(6)
character(len=19) :: cdate

! private routine for handling data override errors
! prints out field name and time of error

   call get_date (Time,date(1),date(2),date(3),date(4),date(5),date(6))
   write (cdate,'(i4,5(a1,i2.2))') date(1),'-',date(2),'-',date(3),' ', &
                                  date(4),':',date(5),':',date(6)
   call error_mesg ('atmos_nudge_mod', &
     'data override not done for '//trim(field)//', date = '//cdate, FATAL)

end subroutine override_error

!#######################################################################

end module atmos_nudge_mod


module interpolator_mod
!
! Purpose: Module to interpolate climatology data to model grid.
!
! author: William Cooke William.Cooke@noaa.gov
!

use mpp_mod,           only : mpp_error, &
                              FATAL,     &
                              mpp_pe,    &
                              mpp_init,  &
                              mpp_exit,  &
                              mpp_npes,  &
                              WARNING,   &
                              NOTE
use mpp_io_mod,        only : mpp_open,          &
                              mpp_close,         &
                              mpp_get_times,     &
                              mpp_get_atts,      &
                              mpp_get_info,      &
                              mpp_read,          &
                              mpp_get_axes,      &
                              mpp_get_axis_data, &
                              mpp_get_fields,    &
                              fieldtype,         &
                              atttype,           &
                              axistype,          &
                              MPP_RDONLY,        &
                              MPP_NETCDF,        &
                              MPP_MULTI,         &
                              MPP_APPEND,        &
                              MPP_SINGLE
use mpp_domains_mod,   only : mpp_domains_init,      &
                              mpp_update_domains,    &
                              mpp_define_domains,    &
                              mpp_global_field,      &
                              domain2d,              &
                              mpp_define_layout,     &
                              mpp_get_compute_domain
use diag_manager_mod,  only : diag_manager_init, get_base_time, &
                              register_diag_field, send_data, &
                              diag_axis_init
use fms_mod,           only : lowercase, write_version_number, &
                              fms_init, &
                              file_exist, mpp_root_pe, stdlog
use horiz_interp_mod,  only : horiz_interp_type, &
                              horiz_interp_new,  &
                              horiz_interp_init, &
                              assignment(=), &
                              horiz_interp,      &
                              horiz_interp_del
use time_manager_mod,  only : time_type,   &
                              set_time,    &
                              set_date,    &
                              get_date,    &
                              get_calendar_type, &
                              JULIAN, NOLEAP, &
                              get_date_julian, set_date_no_leap, &
                              set_date_julian, get_date_no_leap, &
                              print_date, &
                              operator(+), &
                              operator(-), &
                              operator(*), &
                              operator(>), &
                              operator(<), &
                              assignment(=), &
                              decrement_time
use time_interp_mod,   only : time_interp, YEAR
use constants_mod,     only : grav, PI

implicit none
private 

public interpolator_init, &
       interpolator,      &
       interpolate_type_eq, &
       obtain_interpolator_time_slices, &
       unset_interpolator_time_flag, &
       interpolator_end,  &
       init_clim_diag,    &
       query_interpolator,&
       read_data

interface interpolator
   module procedure interpolator_4D
   module procedure interpolator_3D
   module procedure interpolator_2D
   module procedure interpolator_4D_no_time_axis
   module procedure interpolator_3D_no_time_axis
   module procedure interpolator_2D_no_time_axis
end interface 

interface assignment(=)
   module procedure interpolate_type_eq
end interface

interface interp_weighted_scalar
   module procedure interp_weighted_scalar_1D
   module procedure interp_weighted_scalar_2D
end interface interp_weighted_scalar
character(len=128) :: version = &
'$Id: interpolator.F90,v 17.0.2.1.4.1.6.1.2.1.2.1 2010/09/03 12:59:12 pjp Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized = .false.
logical            :: clim_diag_initialized = .false.

type, public  :: interpolate_type
private
!Redundant data between fields
!All climatology data
real, pointer            :: lat(:) =>NULL()
real, pointer            :: lon(:) =>NULL()
real, pointer            :: latb(:) =>NULL()
real, pointer            :: lonb(:) =>NULL()
real, pointer            :: levs(:) =>NULL()
real, pointer            :: halflevs(:) =>NULL()
type(horiz_interp_type)  :: interph
type(time_type), pointer :: time_slice(:) =>NULL() ! An array of the times within the climatology.
integer                  :: unit          ! Unit number on which file is being read.
character(len=64)        :: file_name     ! Climatology filename
integer                  :: TIME_FLAG     ! Linear or seaonal interpolation?
integer                  :: level_type    ! Pressure or Sigma level
integer                  :: is,ie,js,je
integer                  :: vertical_indices ! direction of vertical 
                                              ! data axis
logical                  :: climatological_year ! Is data for year = 0000?

!Field specific data  for nfields
type(fieldtype),   pointer :: field_type(:) =>NULL()   ! NetCDF field type
character(len=64), pointer :: field_name(:) =>NULL()   ! name of this field
integer,           pointer :: time_init(:,:) =>NULL()  ! second index is the number of time_slices being kept. 2 or ntime.
integer,           pointer :: mr(:) =>NULL()           ! Flag for conversion of climatology to mixing ratio. 
integer,           pointer :: out_of_bounds(:) =>NULL()! Flag for when surface pressure is out of bounds.
!++lwh
integer,           pointer :: vert_interp(:) =>NULL()  ! Flag for type of vertical interpolation.
!--lwh
real,              pointer :: data(:,:,:,:,:) =>NULL() ! (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields)

real,              pointer :: pmon_pyear(:,:,:,:) =>NULL()
real,              pointer :: pmon_nyear(:,:,:,:) =>NULL()
real,              pointer :: nmon_nyear(:,:,:,:) =>NULL()
real,              pointer :: nmon_pyear(:,:,:,:) =>NULL()
!integer                    :: indexm, indexp, climatology
integer,dimension(:),  pointer :: indexm =>NULL() 
integer,dimension(:),  pointer :: indexp =>NULL()
integer,dimension(:),  pointer :: climatology =>NULL() 

type(time_type), pointer :: clim_times(:,:) => NULL()
logical :: separate_time_vary_calc
real :: tweight, tweight1, tweight2, tweight3
integer :: itaum, itaup
end type interpolate_type


integer :: ndim, nvar,natt,ntime
integer :: nlat,nlatb,nlon,nlonb,nlev,nlevh
integer ::          len, ntime_in, num_fields
type(axistype), allocatable :: axes(:)
type(axistype),save          :: time_axis
type(fieldtype), allocatable :: varfields(:)

! pletzer real, allocatable :: time_in(:)
! sjs real, allocatable :: climdata(:,:,:), climdata2(:,:,:)

character(len=32) :: name, units       
integer           :: sense

integer, parameter :: max_diag_fields = 30

! flags to indicate direction of vertical axis in  data file
integer, parameter :: INCREASING_DOWNWARD = 1, INCREASING_UPWARD = -1
!++lwh
! Flags to indicate whether the time interpolation should be linear or some other scheme for seasonal data.
! NOTIME indicates that data file has no time axis.
integer, parameter :: LINEAR = 1, SEASONAL = 2, BILINEAR = 3, NOTIME = 4

! Flags to indicate where climatology pressure levels are pressure or sigma levels
integer, parameter :: PRESSURE = 1, SIGMA = 2 

! Flags to indicate whether the climatology units are mixing ratio (kg/kg) or column integral (kg/m2).
! Vertical interpolation scheme requires mixing ratio at this time.
integer, parameter :: NO_CONV = 1, KG_M2 = 2 

! Flags to indicate what to do when the model surface pressure exceeds the  climatology surface pressure level.
integer, parameter, public :: CONSTANT = 1, ZERO = 2 

! Flags to indicate the type of vertical interpolation
integer, parameter, public :: INTERP_WEIGHTED_P = 10, INTERP_LINEAR_P = 20, INTERP_LOG_P = 30
!--lwh

integer :: num_clim_diag = 0
character(len=64) :: climo_diag_name(max_diag_fields)
integer :: climo_diag_id(max_diag_fields), hinterp_id(max_diag_fields)
real ::  missing_value = -1.e10
! sjs integer :: itaum, itaup

logical :: read_all_on_init = .false.
integer :: verbose = 0  

namelist /interpolator_nml/    &
                             read_all_on_init, verbose

contains

!#####################################################################

subroutine interpolate_type_eq (Out, In)

type(interpolate_type), intent(in) :: In
type(interpolate_type), intent(inout) :: Out


     if (associated(In%lat))      Out%lat      =>  In%lat
     if (associated(In%lon))      Out%lon      =>  In%lon
     if (associated(In%latb))     Out%latb     =>  In%latb
     if (associated(In%lonb))     Out%lonb     =>  In%lonb
     if (associated(In%levs))     Out%levs     =>  In%levs
     if (associated(In%halflevs)) Out%halflevs =>  In%halflevs

     Out%interph = In%interph
     if (associated(In%time_slice)) Out%time_slice =>  In%time_slice
     Out%unit = In%unit
     Out%file_name = In%file_name
     Out%time_flag = In%time_flag
     Out%level_type = In%level_type
     Out%is = In%is
     Out%ie = In%ie
     Out%js = In%js
     Out%je = In%je
     Out%vertical_indices = In%vertical_indices
     Out%climatological_year = In%climatological_year
     Out%field_type => In%field_type
     if (associated(In%field_name   )) Out%field_name    =>  In%field_name
     if (associated(In%time_init    )) Out%time_init     =>  In%time_init 
     if (associated(In%mr           )) Out%mr            =>  In%mr         
     if (associated(In%out_of_bounds)) Out%out_of_bounds =>  In%out_of_bounds
     if (associated(In%vert_interp  )) Out%vert_interp   =>  In%vert_interp  
     if (associated(In%data         )) Out%data          =>  In%data  
     if (associated(In%pmon_pyear   )) Out%pmon_pyear    =>  In%pmon_pyear
     if (associated(In%pmon_nyear   )) Out%pmon_nyear    =>  In%pmon_nyear
     if (associated(In%nmon_nyear   )) Out%nmon_nyear    =>  In%nmon_nyear
     if (associated(In%nmon_pyear   )) Out%nmon_pyear    =>  In%nmon_pyear
     if (associated(In%indexm       )) Out%indexm        =>  In%indexm    
     if (associated(In%indexp       )) Out%indexp        =>  In%indexp    
     if (associated(In%climatology  )) Out%climatology   =>  In%climatology
     if (associated(In%clim_times   )) Out%clim_times    =>  In%clim_times
      Out%separate_time_vary_calc = In%separate_time_vary_calc
      Out%tweight = In%tweight
      Out%tweight1 = In%tweight1
      Out%tweight2 = In%tweight2
      Out%tweight3 = In%tweight3
      Out%itaum = In%itaum
      Out%itaup = In%itaup



end subroutine interpolate_type_eq 



 
!#######################################################################
!
subroutine interpolator_init( clim_type, file_name, lonb_mod, latb_mod, &
                              data_names, data_out_of_bounds,           &
                              vert_interp, clim_units, single_year_file)
type(interpolate_type), intent(inout) :: clim_type
character(len=*), intent(in)            :: file_name
real            , intent(in)            :: lonb_mod(:,:), latb_mod(:,:)
character(len=*), intent(in) , optional :: data_names(:)
!++lwh
integer         , intent(in)            :: data_out_of_bounds(:) 
integer         , intent(in), optional  :: vert_interp(:) 
!--lwh
character(len=*), intent(out), optional :: clim_units(:)
logical,          intent(out), optional :: single_year_file
!
! INTENT IN
!  file_name  :: Climatology filename
!  lonb_mod   :: The corners of the model grid-box longitudes.
!  latb_mod   :: The corners of the model grid_box latitudes.
!  data_names :: A list of the names of components within the climatology file which you wish to read.
!  data_out_of_bounds :: A list of the flags that are to be used in determining what to do if the pressure levels in the model
!                        go out of bounds from those of the climatology.
!  vert_interp:: Flag to determine type of vertical interpolation
!
! INTENT OUT
!  clim_type  :: An interpolate type containing the necessary file and field data to be passed to the interpolator routine.
!  clim_units :: A list of the units for the components listed in data_names.
!

integer                      :: unit
character(len=64)            :: src_file
!++lwh
real                         :: dlat, dlon
!--lwh
type(time_type)              :: base_time
logical                      :: NAME_PRESENT
real                         :: dtr,tpi
integer                      :: fileday, filemon, fileyr, filehr, filemin,filesec, m,m1
character(len= 20)           :: fileunits
real, dimension(:), allocatable  :: alpha
integer   :: j, i
logical :: non_monthly
character(len=24) :: file_calendar
integer :: model_calendar
integer :: yr, mo, dy, hr, mn, sc
integer :: n
type(time_type) :: Julian_time, Noleap_time
real, allocatable :: time_in(:)

if (.not. module_is_initialized) then
  call fms_init
  call diag_manager_init
  call horiz_interp_init
endif

clim_type%separate_time_vary_calc = .false.

tpi = 2.0*PI ! 4.*acos(0.)
dtr = tpi/360.

num_fields = 0

!--------------------------------------------------------------------
! open source file containing fields to be interpolated
!--------------------------------------------------------------------
src_file = 'INPUT/'//trim(file_name)

if(file_exist(trim(src_file))) then
   call mpp_open( unit, trim(src_file), action=MPP_RDONLY, &
                  form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_SINGLE )
else
!Climatology file doesn't exist, so exit
   call mpp_error(FATAL,'Interpolator_init : Data file '//trim(src_file)//' does not exist')
endif

!Find the number of variables (nvar) in this file
call mpp_get_info(unit, ndim, nvar, natt, ntime)
clim_type%unit      = unit
clim_type%file_name = trim(file_name)

num_fields = nvar
if(present(data_names)) num_fields= size(data_names(:))

! -------------------------------------------------------------------
! Allocate space for the number of axes in the data file.
! -------------------------------------------------------------------
allocate(axes(ndim))
call mpp_get_axes(unit, axes, time_axis)

nlon=0 ! Number of longitudes (center-points) in the climatology.
nlat=0 ! Number of latitudes (center-points) in the climatology.
nlev=0 ! Number of levels (center-points) in the climatology.
nlatb=0 ! Number of longitudes (boundaries) in the climatology.
nlonb=0 ! Number of latitudes (boundaries) in the climatology.
nlevh=0 ! Number of levels (boundaries) in the climatology.

clim_type%level_type = 0 ! Default value

!++lwh
! -------------------------------------------------------------------
! For 2-D fields, set a default value of nlev=nlevh=1
! -------------------------------------------------------------------
nlev = 1
nlevh = 1
!--lwh
        clim_type%vertical_indices = 0  ! initial value

do i = 1, ndim
  call mpp_get_atts(axes(i), name=name,len=len,units=units,  &
                    calendar=file_calendar, sense=sense)
  select case(name)
    case('lat')
      nlat=len
      allocate(clim_type%lat(nlat))
      call mpp_get_axis_data(axes(i),clim_type%lat)
      select case(units(1:6))
        case('degree')
          clim_type%lat = clim_type%lat*dtr
        case('radian')
        case default  
          call mpp_error(FATAL, "interpolator_init : Units for lat not recognised in file "//file_name)
      end select
    case('lon')
      nlon=len
      allocate(clim_type%lon(nlon))
      call mpp_get_axis_data(axes(i),clim_type%lon)
      select case(units(1:6))
        case('degree')
          clim_type%lon = clim_type%lon*dtr
        case('radian')
        case default  
          call mpp_error(FATAL, "interpolator_init : Units for lon not recognised in file "//file_name)
      end select
    case('latb')
      nlatb=len
      allocate(clim_type%latb(nlatb))
      call mpp_get_axis_data(axes(i),clim_type%latb)
      select case(units(1:6))
        case('degree')
          clim_type%latb = clim_type%latb*dtr
        case('radian')
        case default  
          call mpp_error(FATAL, "interpolator_init : Units for latb not recognised in file "//file_name)
      end select
    case('lonb')
      nlonb=len
      allocate(clim_type%lonb(nlonb))
      call mpp_get_axis_data(axes(i),clim_type%lonb)
      select case(units(1:6))
        case('degree')
          clim_type%lonb = clim_type%lonb*dtr
        case('radian')
        case default  
          call mpp_error(FATAL, "interpolator_init : Units for lonb not recognised in file "//file_name)
      end select
    case('pfull')
      nlev=len
      allocate(clim_type%levs(nlev))
      call mpp_get_axis_data(axes(i),clim_type%levs)
      clim_type%level_type = PRESSURE
  ! Convert to Pa
      if( chomp(units) == "mb" .or. chomp(units) == "hPa") then
         clim_type%levs = clim_type%levs * 100.
      end if
! define the direction of the vertical data axis
! switch index order if necessary so that indx 1 is at lowest pressure,
! index nlev at highest pressure.
      if( sense == 1 ) then
        clim_type%vertical_indices = INCREASING_UPWARD
          allocate (alpha(nlev))
          do n = 1, nlev
          alpha(n) = clim_type%levs(nlev-n+1)
          end do
          do n = 1, nlev
          clim_type%levs(n) = alpha(n)
          end do
          deallocate (alpha)
      else 
        clim_type%vertical_indices = INCREASING_DOWNWARD
      endif
      
    case('phalf')
      nlevh=len
      allocate(clim_type%halflevs(nlevh))
      call mpp_get_axis_data(axes(i),clim_type%halflevs)
      clim_type%level_type = PRESSURE
  ! Convert to Pa
      if( chomp(units) == "mb" .or. chomp(units) == "hPa") then
         clim_type%halflevs = clim_type%halflevs * 100.
      end if
! define the direction of the vertical data axis
! switch index order if necessary so that indx 1 is at lowest pressure,
! index nlev at highest pressure.
      if( sense == 1 ) then
        clim_type%vertical_indices = INCREASING_UPWARD
          allocate (alpha(nlevh))
          do n = 1, nlevh
          alpha(n) = clim_type%halflevs(nlevh-n+1)
          end do
          do n = 1, nlevh
          clim_type%halflevs(n) = alpha(n)
          end do
          deallocate (alpha)
      else 
        clim_type%vertical_indices = INCREASING_DOWNWARD
      endif
    case('sigma_full')
      nlev=len
      allocate(clim_type%levs(nlev))
      call mpp_get_axis_data(axes(i),clim_type%levs)
      clim_type%level_type = SIGMA
    case('sigma_half')
      nlevh=len
      allocate(clim_type%halflevs(nlevh))
      call mpp_get_axis_data(axes(i),clim_type%halflevs)
      clim_type%level_type = SIGMA
  
    case('time')
      model_calendar = get_calendar_type() 
      fileday = 0
      filemon = 0
      fileyr = 0
      filehr = 0
      filemin= 0
      filesec = 0
      select case(units(:3))
        case('day')
          fileunits = units(12:) !Assuming "days since YYYY-MM-DD HH:MM:SS"
          read(fileunits(1:4)  , *)  fileyr
          read(fileunits(6:7)  , *)  filemon
          read(fileunits(9:10) , *)  fileday
          read(fileunits(12:13), *)  filehr
          read(fileunits(15:16), *)  filemin
          read(fileunits(18:19), *)  filesec
        case('mon')
          fileunits = units(14:) !Assuming "months since YYYY-MM-DD HH:MM:SS"
          read(fileunits(1:4)  , *)  fileyr
          read(fileunits(6:7)  , *)  filemon
          read(fileunits(9:10) , *)  fileday
          read(fileunits(12:13), *)  filehr
          read(fileunits(15:16), *)  filemin
          read(fileunits(18:19), *)  filesec
        case default
          call mpp_error(FATAL,'Interpolator_init : Time units not recognised in file '//file_name)
      end select

       clim_type%climatological_year = (fileyr == 0)

      if (.not. clim_type%climatological_year) then

!----------------------------------------------------------------------
!    if file date has a non-zero year in the base time, determine that
!    base_time based on the netcdf info.
!----------------------------------------------------------------------
        if ( (model_calendar == JULIAN .and.   &
              trim(file_calendar) == 'julian')  .or. &
              (model_calendar == NOLEAP .and.   &
               trim(file_calendar) == 'noleap') )  then
          call mpp_error (NOTE, 'interpolator_mod: Model and file&
                    & calendars are the same for file ' //   &
                    & trim(file_name) // '; no calendar conversion  &
                    &needed')
          base_time = set_date (fileyr, filemon, fileday, filehr, &
                                filemin,filesec)
        else if ( (model_calendar == JULIAN .and.   &
                   trim(file_calendar) == 'noleap')) then  
          call mpp_error (NOTE, 'interpolator_mod: Using julian &
                            &model calendar and noleap file calendar&
                            & for file ' // trim(file_name) //   &
                            &'; calendar conversion needed')
          base_time = set_date_no_leap (fileyr, filemon, fileday,  &
                                        filehr, filemin, filesec)
        else if ( (model_calendar == NOLEAP .and.   &
                   trim(file_calendar) == 'julian')) then  
          call mpp_error (NOTE, 'interpolator_mod: Using noleap &
                            &model calendar and julian file calendar&
                            & for file ' // trim(file_name) //  &
                            &'; calendar conversion needed')
          base_time = set_date_julian (fileyr, filemon, fileday,  &
                                       filehr, filemin, filesec)
        else
          call mpp_error (FATAL , 'interpolator_mod: Model and file&
               & calendars ( ' // trim(file_calendar) // ' ) differ  &
               &for file ' // trim(file_name) // ';  this calendar  &
               &conversion not currently available')
        endif

      else

!! if the year is specified as '0000', then the file is intended to 
!! apply to all years -- the time variables within the file refer to
!! the displacement from the start of each year to the time of the
!! associated data. Time interpolation is to be done with interface 
!! time_interp_list, with the optional argument modtime=YEAR. base_time
!! is set to an arbitrary value here; it's only use will be as a 
!! timestamp for optionally generated diagnostics.

        base_time = get_base_time ()
      endif


      ntime_in = 1
      if (ntime > 0) then
        allocate(time_in(ntime), clim_type%time_slice(ntime))
        allocate(clim_type%clim_times(12,(ntime+11)/12))
        time_in = 0.0
        clim_type%time_slice = set_time(0,0) + base_time
        clim_type%clim_times = set_time(0,0) + base_time
        call mpp_get_times(clim_type%unit, time_in)
        ntime_in = ntime
! determine whether the data is a continuous set of monthly values or
! a series of annual cycles spread throughout the period of data
        non_monthly = .false.
        do n = 1, ntime-1
!  Assume that the times in the data file correspond to days only.
          if (time_in(n+1) > (time_in(n) + 32)) then
            non_monthly = .true.
            exit
          endif
        end do
        if (clim_type%climatological_year) then
          call mpp_error (NOTE, 'interpolator_mod :'  // &
          trim(file_name) // ' is a year-independent climatology file') 
        else
          call mpp_error (NOTE, 'interpolator_mod :' // &
            trim(file_name) // ' is a timeseries file') 
        endif

        do n = 1, ntime
!Assume that the times in the data file correspond to days only.
            

          if (clim_type%climatological_year) then
!! RSH NOTE:
!! for this case, do not add base_time. time_slice will be sent to
!! time_interp_list with the optional argument modtime=YEAR, so that
!! the time that is needed in time_slice is the displacement into the
!! year, not the displacement from a base_time.
            clim_type%time_slice(n) = &
                set_time(INT( ( time_in(n) - INT(time_in(n)) ) * 86400 ),INT(time_in(n)))
          else

!--------------------------------------------------------------------
!    if fileyr /= 0 (i.e., climatological_year=F),
!    then define the times associated with each time-
!    slice. if calendar conversion between data file and model calendar
!    is needed, do it so that data from the file is associated with the
!    same calendar time in the model. here the time_slice needs to 
!    include the base_time; values will be generated relative to the 
!    "real" time.
!--------------------------------------------------------------------
            if ( (model_calendar == JULIAN .and.   &
                  trim(file_calendar) == 'julian')  .or. &
                 (model_calendar == NOLEAP .and.   &
                  trim(file_calendar) == 'noleap') )  then

!---------------------------------------------------------------------
!    no calendar conversion needed.
!---------------------------------------------------------------------
              clim_type%time_slice(n) = &
                 set_time(INT( ( time_in(n) - INT(time_in(n)) ) * 86400 ),INT(time_in(n)))  &
                  + base_time

!---------------------------------------------------------------------
!    convert file times from noleap to julian.
!---------------------------------------------------------------------
            else if ( (model_calendar == JULIAN .and.   &
                       trim(file_calendar) == 'noleap')) then  
              Noleap_time = set_time (0, INT(time_in(n))) + base_time
              call get_date_no_leap (Noleap_time, yr, mo, dy, hr,  &
                                     mn, sc)
              clim_type%time_slice(n) = set_date_julian (yr, mo, dy,  &
                                                         hr, mn, sc)
              if (n == 1) then
                call print_date (clim_type%time_slice(1), &
                        str= 'for file ' // trim(file_name) // ', the &
                              &first time slice is mapped to :')
              endif
              if (n == ntime) then
                call print_date (clim_type%time_slice(ntime), &
                         str= 'for file ' // trim(file_name) // ', the &
                               &last time slice is mapped to:')
              endif
  

!---------------------------------------------------------------------
!    convert file times from julian to noleap.
!---------------------------------------------------------------------
            else if ( (model_calendar == NOLEAP .and.   &
                       trim(file_calendar) == 'julian')) then  
              Julian_time = set_time (0, INT(time_in(n))) + base_time
              call get_date_julian (Julian_time, yr, mo, dy, hr, mn, sc)
              clim_type%time_slice(n) = set_date_no_leap (yr, mo, dy, &
                                                          hr, mn, sc)
              if (n == 1) then
                call print_date (clim_type%time_slice(1), &
                         str= 'for file ' // trim(file_name) // ', the &
                               &first time slice is mapped to :')
              endif
              if (n == ntime) then
                call print_date (clim_type%time_slice(ntime), &
                         str= 'for file ' // trim(file_name) // ', the &
                               &last time slice is mapped to:')
              endif

!---------------------------------------------------------------------
!    any other calendar combinations would have caused a fatal error 
!    above.
!---------------------------------------------------------------------
            endif
          endif

          m = (n-1)/12 +1 ; m1 = n- (m-1)*12
          clim_type%clim_times(m1,m) = clim_type%time_slice(n)
        enddo
      else
        allocate(time_in(1), clim_type%time_slice(1))
        allocate(clim_type%clim_times(1,1))
        time_in = 0.0
        clim_type%time_slice = set_time(0,0) + base_time
        clim_type%clim_times(1,1) = set_time(0,0) + base_time
      endif
      deallocate(time_in)
  end select ! case(name)
enddo


! -------------------------------------------------------------------
! For 2-D fields, allocate levs and halflevs here
!  code is still needed for case when only halflevs are in data file.
! -------------------------------------------------------------------
    if( .not. associated(clim_type%levs) ) then
        allocate( clim_type%levs(nlev) )
        clim_type%levs = 0.0        
    endif  
    if( .not. associated(clim_type%halflevs) )  then
        allocate( clim_type%halflevs(nlev+1) )
        clim_type%halflevs(1) = 0.0
        if (clim_type%level_type == PRESSURE) then
          clim_type%halflevs(nlev+1) = 1013.25* 100.0   ! MKS
        else if (clim_type%level_type == SIGMA   ) then
          clim_type%halflevs(nlev+1) = 1.0
        endif
        do n=2,nlev
           clim_type%halflevs(n) = 0.5*(clim_type%levs(n) + &
                                         clim_type%levs(n-1))
        end do
    endif
deallocate(axes)


! In the case where only the midpoints of the longitudes are defined we force the definition
! of the boundaries to be half-way between the midpoints.
if (.not. associated(clim_type%lon) .and. .not. associated(clim_type%lonb)) &
   call mpp_error(FATAL,'Interpolator_init : There appears to be no longitude axis in file '//file_name)

if (.not. associated(clim_type%lonb) ) then

  if (size(clim_type%lon(:)) /= 1) then
    allocate(clim_type%lonb(size(clim_type%lon(:))+1))
    dlon = (clim_type%lon(2)-clim_type%lon(1))/2.0
    clim_type%lonb(1) = clim_type%lon(1) - dlon
    clim_type%lonb(2:) = clim_type%lon(1:) + dlon
  else

!! this is the case for zonal mean data, lon = 1, lonb not present 
!! in file.

    allocate(clim_type%lonb(2))
    clim_type%lonb(1) = -360.*dtr
    clim_type%lonb(2) = 360.0*dtr
    clim_type%lon(1) = 0.0
  endif    
endif

!clim_type%lonb=clim_type%lonb*dtr 
! This assumes the lonb are in degrees in the NetCDF file!

if (.not. associated(clim_type%lat) .and. .not. associated(clim_type%latb)) &
   call mpp_error(FATAL,'Interpolator_init : There appears to be no latitude axis in file '//file_name)
! In the case where only the grid midpoints of the latitudes are defined we force the 
! definition of the boundaries to be half-way between the midpoints.
if (.not. associated(clim_type%latb) ) then
   allocate(clim_type%latb(nlat+1))
   dlat = (clim_type%lat(2)-clim_type%lat(1)) * 0.5
!  clim_type%latb(1) = min( 90., max(-90., clim_type%lat(1) - dlat) )
   clim_type%latb(1) = min( PI/2., max(-PI/2., clim_type%lat(1) - dlat) )
   clim_type%latb(2:nlat) = ( clim_type%lat(1:nlat-1) + clim_type%lat(2:nlat) ) * 0.5
   dlat = ( clim_type%lat(nlat) - clim_type%lat(nlat-1) ) * 0.5
!  clim_type%latb(nlat+1) = min( 90., max(-90., clim_type%lat(nlat) + dlat) )
   clim_type%latb(nlat+1) = min( PI/2., max(-PI/2., clim_type%lat(nlat) + dlat) )
endif
!clim_type%latb=clim_type%latb*dtr

!Assume that the horizontal interpolation within a file is the same for each variable.

 call horiz_interp_new (clim_type%interph, &
                        clim_type%lonb, clim_type%latb, &
                        lonb_mod, latb_mod)

!--------------------------------------------------------------------
!  allocate the variable clim_type%data . This will be the climatology 
!  data horizontally interpolated, so it will be on the model horizontal
!  grid, but it will still be on the climatology vertical grid.
!--------------------------------------------------------------------

select case(ntime)
 case (13:)
! This may  be data that does not have a continous time-line
! i.e. IPCC data where decadal data is present but we wish to retain 
! the seasonal nature of the data.
!! RSH: the following test will not always work; instead use the
!! RSH: non-monthly variable to test on.
!RSHlast_time = clim_type%time_slice(1) + ( ntime -1 ) * &
!RSH        ( clim_type%time_slice(2) - clim_type%time_slice(1) )

!RSHif ( last_time < clim_type%time_slice(ntime)) then

 if (non_monthly) then
! We have a broken time-line. e.g. We have monthly data but only for years ending in 0. 1960,1970 etc.
!   allocate(clim_type%data(size(lonb_mod(:))-1, size(latb_mod(:))-1, nlev, 2, num_fields))
   allocate(clim_type%pmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
   allocate(clim_type%pmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
   allocate(clim_type%nmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
   allocate(clim_type%nmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
   clim_type%pmon_pyear = 0.0
   clim_type%pmon_nyear = 0.0
   clim_type%nmon_nyear = 0.0
   clim_type%nmon_pyear = 0.0
   clim_type%TIME_FLAG = BILINEAR
else
! We have a continuous time-line so treat as for 5-12 timelevels as below.
   if ( .not. read_all_on_init) then
   allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields))
   else
   allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, &
               ntime, num_fields))
   endif
   clim_type%data = 0.0
   clim_type%TIME_FLAG = LINEAR
endif


!++lwh
 case (1:12)
!--lwh
! We have more than 4 timelevels 
! Assume we have monthly or higher time resolution datasets (climatology or time series)
! So we only need to read 2 datasets and apply linear temporal interpolation.
   if ( .not. read_all_on_init) then
   allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields))
   else
   allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, &
               ntime, num_fields))
   endif
   clim_type%data = 0.0
   clim_type%TIME_FLAG = LINEAR
!++lwh
!case (1:4) 
! Assume we have seasonal data and read in all the data.
! We can apply sine curves to these data.
 
!  allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, ntime, num_fields))
!  clim_type%data = 0.0
!  clim_type%TIME_FLAG = SEASONAL
!--lwh
! case (default)
 case(:0)
   clim_type%TIME_FLAG = NOTIME
   allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields))
end select


!------------------------------------------------------------------
!    Allocate space for the single time level of the climatology on its 
!    grid size.
!----------------------------------------------------------------------

   if(clim_type%TIME_FLAG .eq. LINEAR ) then
   allocate(clim_type%time_init(num_fields,2))
   else
   allocate(clim_type%time_init(num_fields,ntime))
   endif
   allocate (clim_type%indexm(num_fields),   &
             clim_type%indexp(num_fields),   &
             clim_type%climatology(num_fields))
   clim_type%time_init(:,:) = 0
   clim_type%indexm(:)      = 0
   clim_type%indexp(:)      = 0
   clim_type%climatology(:) = 0
   

allocate(clim_type%field_name(num_fields))
allocate(clim_type%field_type(num_fields))
allocate(clim_type%mr(num_fields))
allocate(clim_type%out_of_bounds(num_fields))
clim_type%out_of_bounds(:)=0
allocate(clim_type%vert_interp(num_fields))
clim_type%vert_interp(:)=0
!--------------------------------------------------------------------
!Allocate the space for the fields within the climatology data file.
allocate(varfields(nvar))
!--------------------------------------------------------------------
! Get the variable names out of the file.
call mpp_get_fields(clim_type%unit, varfields)

if(present(data_names)) then

!++lwh
   if ( size(data_out_of_bounds(:)) /= size(data_names(:)) .and. size(data_out_of_bounds(:)) /= 1 ) &
      call mpp_error(FATAL,'interpolator_init : The size of the data_out_of_bounds array must be 1&
                            & or size(data_names)')
   if (present(vert_interp)) then
      if( size(vert_interp(:)) /= size(data_names(:)) .and. size(vert_interp(:)) /= 1 ) &
      call mpp_error(FATAL,'interpolator_init : The size of the vert_interp array must be 1&
                            & or size(data_names)')
   endif
! Only read the fields named in data_names
   do j=1,size(data_names(:))
      NAME_PRESENT = .FALSE.
      do i=1,nvar
         call mpp_get_atts(varfields(i),name=name,ndim=ndim,units=units)
         if( name == data_names(j) ) then
            units=chomp(units)
            if (mpp_pe() == 0 ) write(*,*) 'Initializing src field : ',trim(name)
            clim_type%field_name(j) = name
            clim_type%field_type(j) = varfields(i)
            clim_type%mr(j)         = check_climo_units(units)
            NAME_PRESENT = .TRUE.
            if (present(clim_units)) clim_units(j) = units
            clim_type%out_of_bounds(j) = data_out_of_bounds( MIN(j,SIZE(data_out_of_bounds(:))) )
            if( clim_type%out_of_bounds(j) /= CONSTANT .and. &
                clim_type%out_of_bounds(j) /= ZERO ) &
               call mpp_error(FATAL,"Interpolator_init: data_out_of_bounds must be&
                                    & set to ZERO or CONSTANT")               
            if( present(vert_interp) ) then
               clim_type%vert_interp(j) = vert_interp( MIN(j,SIZE(vert_interp(:))) )
               if( clim_type%vert_interp(j) /= INTERP_WEIGHTED_P .and. &
                   clim_type%vert_interp(j) /= INTERP_LINEAR_P ) &
                  call mpp_error(FATAL,"Interpolator_init: vert_interp must be&
                                       & set to INTERP_WEIGHTED_P or INTERP_LINEAR_P")
            else
               clim_type%vert_interp(j) = INTERP_WEIGHTED_P
            end if
         endif
      enddo
      if(.not. NAME_PRESENT) &
         call mpp_error(FATAL,'interpolator_init : Check names of fields being passed. ' &
                              //trim(data_names(j))//' does not exist.')
   enddo
else

   if ( size(data_out_of_bounds(:)) /= nvar .and. size(data_out_of_bounds(:)) /= 1 ) &
      call mpp_error(FATAL,'interpolator_init : The size of the out of bounds array must be 1&
                           & or the number of fields in the climatology dataset')
   if ( present(vert_interp) ) then
      if (size(vert_interp(:)) /= nvar .and. size(vert_interp(:)) /= 1 ) & 
      call mpp_error(FATAL,'interpolator_init : The size of the vert_interp array must be 1&
                           & or the number of fields in the climatology dataset')
   endif

! Read all the fields within the climatology data file.
   do i=1,nvar
      call mpp_get_atts(varfields(i),name=name,ndim=ndim,units=units)
         if (mpp_pe() ==0 ) write(*,*) 'Initializing src field : ',trim(name)
         clim_type%field_name(i) = lowercase(trim(name))
         clim_type%field_type(i) = varfields(i)
         clim_type%mr(i)         = check_climo_units(units)
         if (present(clim_units)) clim_units(i) = units
         clim_type%out_of_bounds(i) = data_out_of_bounds( MIN(i,SIZE(data_out_of_bounds(:))) )
         if( clim_type%out_of_bounds(i) /= CONSTANT .and. &
             clim_type%out_of_bounds(i) /= ZERO ) &
            call mpp_error(FATAL,"Interpolator_init: data_out_of_bounds must be&
                                 & set to ZERO or CONSTANT")
         if( present(vert_interp) ) then
            clim_type%vert_interp(i) = vert_interp( MIN(i,SIZE(vert_interp(:))) )
            if( clim_type%vert_interp(i) /= INTERP_WEIGHTED_P .and. &
                clim_type%vert_interp(i) /= INTERP_LINEAR_P ) &
               call mpp_error(FATAL,"Interpolator_init: vert_interp must be&
                                    & set to INTERP_WEIGHTED_P or INTERP_LINEAR_P")
         else
            clim_type%vert_interp(i) = INTERP_WEIGHTED_P
         end if
   end do
!--lwh
endif

deallocate(varfields)


if( clim_type%TIME_FLAG .eq. SEASONAL ) then
! Read all the data at this point.
   do i=1,num_fields
      do n = 1, ntime
         call read_data( clim_type, clim_type%field_type(i), &
                         clim_type%data(:,:,:,n,i), n, i, base_time )
      enddo
   enddo
endif

if( clim_type%TIME_FLAG .eq. LINEAR  .and. read_all_on_init) then
! Read all the data at this point.
   do i=1,num_fields
      do n = 1, ntime
         call read_data( clim_type, clim_type%field_type(i), &
                         clim_type%data(:,:,:,n,i), n, i, base_time )
      enddo
   enddo

   call mpp_close (unit)
endif

if( clim_type%TIME_FLAG .eq. NOTIME ) then
! Read all the data at this point.
   do i=1,num_fields
     call read_data_no_time_axis( clim_type, clim_type%field_type(i), &
                                  clim_type%data(:,:,:,1,i), i )
   enddo
   call mpp_close (unit)
endif

if (present (single_year_file)) then
  single_year_file = clim_type%climatological_year
endif

module_is_initialized = .true.

call write_version_number (version, tagname)

end subroutine interpolator_init
!
!#######################################################################
!
function check_climo_units(units)
! Function to check the units that the climatology data is using. 
! This is needed to allow for conversion of datasets to mixing ratios which is what the 
! vertical interpolation scheme requires
! The default is to assume no conversion is needed.
! If the units are those of a column burden (kg/m2) then conversion to mixing ratio is flagged.
!
character(len=*), intent(in) :: units

integer :: check_climo_units

check_climo_units = NO_CONV
select case(chomp(units))
  case('kg/m2', 'kg/m^2', 'kg/m**2', 'kg m^-2', 'kg m**-2')
     check_climo_units = KG_M2  
  case('molecules/cm2/s', 'molecule/cm2/s', 'molec/cm2/s')
     check_climo_units = KG_M2  
  case('kg/m2/s')
     check_climo_units = KG_M2  
end select

end function check_climo_units
!
!#######################################################################
!
subroutine init_clim_diag(clim_type, mod_axes, init_time)
!
! Routine to register diagnostic fields for the climatology file. 
! This routine calculates the domain decompostion of the climatology fields 
! for later export through send_data.
! The ids created here are for column burdens that will diagnose the vertical interpolation routine.
! climo_diag_id : 'module_name = climo' is intended for use with the model vertical resolution.
! hinterp_id    : 'module_name = 'hinterp' is intended for use with the climatology vertical resolution.

! INTENT INOUT :
!    clim_type : The interpolate type containing the names of the fields in the climatology file.
!
! INTENT IN    :
!   mod_axes   : The axes of the model.
!   init_time  : The model initialization time.
!
type(interpolate_type), intent(inout)  :: clim_type
integer               , intent(in)     :: mod_axes(:)
type(time_type)       , intent(in)     :: init_time

integer :: axes(2),nxd,nyd,ndivs,i
type(domain2d) :: domain
integer :: domain_layout(2), iscomp, iecomp,jscomp,jecomp


if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "init_clim_diag : You must call interpolator_init before calling init_clim_diag")


ndivs = mpp_npes()
nxd = size(clim_type%lon(:))
nyd = size(clim_type%lat(:))

! Define the domain decomposition of the climatology file. This may be (probably is) different from the model domain.
call mpp_define_layout ((/1,nxd,1,nyd/), ndivs, domain_layout)
call mpp_define_domains((/1,nxd,1,nyd/),domain_layout, domain,xhalo=0,yhalo=0)  
call mpp_get_compute_domain (domain, iscomp, iecomp, jscomp, jecomp)
   axes(1) = diag_axis_init(clim_type%file_name(1:5)//'x',clim_type%lon,units='degrees',cart_name='x',domain2=domain)
   axes(2) = diag_axis_init(clim_type%file_name(1:5)//'y',clim_type%lat,units='degrees',cart_name='y',domain2=domain)
clim_type%is = iscomp
clim_type%ie = iecomp
clim_type%js = jscomp
clim_type%je = jecomp

!init_time = set_date(1980,1,1,0,0,0)

if ((num_clim_diag + size(clim_type%field_name(:))) .gt. max_diag_fields )  &
   call mpp_error(FATAL, "init_clim_diag : Trying to set up too many diagnostic fields for the climatology data")
do i=1,size(clim_type%field_name(:))
climo_diag_name(i+num_clim_diag) = clim_type%field_name(i)
climo_diag_id(i+num_clim_diag) =  register_diag_field('climo',clim_type%field_name(i),axes(1:2),init_time,&
                                'climo_'//clim_type%field_name(i), 'kg/kg', missing_value)
hinterp_id(i+num_clim_diag) =  register_diag_field('hinterp',clim_type%field_name(i),mod_axes(1:2),init_time,&
                                'interp_'//clim_type%field_name(i),'kg/kg' , missing_value)
enddo
! Total number of climatology diagnostics (num_clim_diag). This can be from multiple climatology fields with different spatial axes. 
! It is simply a holder for the diagnostic indices.
num_clim_diag = num_clim_diag+size(clim_type%field_name(:))

clim_diag_initialized = .true.

end subroutine init_clim_diag



!----------------------------------------------------------------------------

subroutine obtain_interpolator_time_slices (clim_type, Time)

!  Makes sure that appropriate time slices are available for interpolation 
!  on this time step
!
! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init
!
! INTENT IN
!   Time        : The model time that you wish to interpolate to.

type(interpolate_type), intent(inout)  :: clim_type
type(time_type)       , intent(in)  :: Time

integer :: taum, taup
integer :: modyear, modmonth, modday, modhour, modminute, modsecond
integer :: climyear, climmonth, climday, climhour, climminute, climsecond
integer :: year1, month1, day, hour, minute, second
integer :: climatology, m
type(time_type) :: t_prev, t_next
type(time_type), dimension(2) :: month
integer :: indexm, indexp, yearm, yearp
integer :: i, n


    if (clim_type%climatological_year) then
!++lwh
       if (size(clim_type%time_slice) > 1) then
          call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup, modtime=YEAR )
       else
          taum = 1
          taup = 1
          clim_type%tweight = 0.
       end if
!--lwh
    else
       call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup )
    endif


    if(clim_type%TIME_FLAG .eq. BILINEAR ) then
      ! Check if delta-time is greater than delta of first two climatology time-slices.
      if ( (Time - clim_type%time_slice(taum) ) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) .or. &
           (clim_type%time_slice(taup)  - Time) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) ) then
      ! The difference between the model time and the last climatology time-slice previous to the model time.
      ! We need 2 time levels.
        clim_type%itaum=0
        clim_type%itaup=0
      ! Assume this is monthly data. So we need to get the data applicable to the model date but substitute 
      ! the climatology year into the appropriate place.

     
      ! We need to get the previous months data for the climatology year before 
      ! and after the model year.
        call get_date(Time, modyear, modmonth, modday, modhour, modminute, modsecond)
        call get_date(clim_type%time_slice(taum), climyear, climmonth, climday, climhour, climminute, climsecond)

        climatology = 1
        do m = 1, size(clim_type%clim_times(:,:),2)
          !Assume here that a climatology is for 1 year and consists of 12 months starting in January.
          call get_date(clim_type%clim_times(1,m), year1, month1, day, hour, minute, second)
          if (year1 == climyear) climatology = m 
        enddo
        do m = 1,12
          !Find which month we are trying to look at and set clim_date[mp] to the dates spanning that.
          call get_date(clim_type%clim_times(m,climatology), year1, month1, day, hour, minute, second)
          if ( month1 == modmonth ) then
!RSHBUGFX   if ( modday <= day ) then 
            if ( modday <  day ) then 
              indexm = m-1 ; indexp = m
            else
              indexm = m ; indexp = m+1
            endif
          endif
        
        enddo
        if ( indexm == 0 ) then 
          indexm = 12
          yearm = modyear - 1
        else
          yearm = modyear
        endif
          call get_date(clim_type%time_slice(indexm+(climatology-1)*12), &
                        climyear, climmonth, climday, climhour, climminute, climsecond)
          month(1) = set_date(yearm, indexm, climday, climhour, climminute, climsecond)
        if ( indexp == 13 ) then
          indexp = 1
          yearp = modyear + 1
        else
          yearp = modyear
        endif
          call get_date(clim_type%time_slice(indexp+(climatology-1)*12), &
                        climyear, climmonth, climday, climhour, climminute, climsecond)
          month(2) = set_date(yearp, indexp, climday, climhour, climminute, climsecond)
        
        call time_interp(Time, month, clim_type%tweight3, taum, taup ) ! tweight3 is the time weight between the months.

        month(1) = clim_type%time_slice(indexm+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexm+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_prev = set_date(yearm, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_prev, month, clim_type%tweight1, taum, taup ) !tweight1 is the time weight between the climatology years.
        month(1) = clim_type%time_slice(indexp+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexp+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_next = set_date(yearp, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_next, month, clim_type%tweight2, taum, taup ) !tweight1 is the time weight between the climatology years.

        if (indexm == clim_type%indexm(1) .and.  &
            indexp == clim_type%indexp(1) .and. &
            climatology == clim_type%climatology(1)) then
        else
          clim_type%indexm(:) = indexm
          clim_type%indexp(:) = indexp
          clim_type%climatology(:) = climatology
          do i=1, size(clim_type%field_name(:))
            call read_data(clim_type,clim_type%field_type(i),  &
             clim_type%pmon_pyear(:,:,:,i),   &
             clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
! Read the data for the next month in the previous climatology.
            call read_data(clim_type,clim_type%field_type(i),  &
             clim_type%nmon_pyear(:,:,:,i),   &
             clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
            call read_data(clim_type,clim_type%field_type(i),  &
              clim_type%pmon_nyear(:,:,:,i),  &
              clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
            call read_data(clim_type,clim_type%field_type(i),  &
              clim_type%nmon_nyear(:,:,:,i),  &
              clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
          end do
        endif



      else ! We are within a climatology data set
        

        do i=1, size(clim_type%field_name(:))
          if (taum /= clim_type%time_init(i,1) .or. &
              taup /= clim_type%time_init(i,2) ) then
 
     
            call read_data(clim_type,clim_type%field_type(i),   &
                           clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
! Read the data for the next month in the previous climatology.
            call read_data(clim_type,clim_type%field_type(i),   &
                           clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
            clim_type%time_init(i,1) = taum
            clim_type%time_init(i,2) = taup
          endif
        end do

!       clim_type%pmon_nyear = 0.0
!       clim_type%nmon_nyear = 0.0

! set to zero so when next return to bilinear section will be sure to
! have proper data (relevant when running fixed_year case for more than
! one year in a single job)
          clim_type%indexm(:) = 0       
          clim_type%indexp(:) = 0        
          clim_type%climatology(:) = 0             


!       clim_type%tweight3 = 0.0 ! This makes [pn]mon_nyear irrelevant. Set them to 0 to test.
        clim_type%tweight1 = 0.0 
        clim_type%tweight2 = 0.0 
        clim_type%tweight3 = clim_type%tweight                                          
      endif
    endif   !(BILINEAR)

    if(clim_type%TIME_FLAG .eq. LINEAR  .and.   &
        (.not. read_all_on_init) ) then
! We need 2 time levels. Check we have the correct data.
      clim_type%itaum=0
      clim_type%itaup=0
      do n=1,size(clim_type%time_init,2)
        if (clim_type%time_init(1,n) .eq. taum ) clim_type%itaum = n
        if (clim_type%time_init(1,n) .eq. taup ) clim_type%itaup = n
      enddo

      if (clim_type%itaum.eq.0 .and. clim_type%itaup.eq.0) then
!Neither time is set so we need to read 2 time slices.
!Set up 
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
    do i=1, size(clim_type%field_name(:))
    call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
          clim_type%time_init(i,1) = taum
          clim_type%itaum = 1
    call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
          clim_type%time_init(i,2) = taup
          clim_type%itaup = 2
    end do
      endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
      if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
 call mpp_error(FATAL,'interpolator_timeslice : No data from the previous climatology time &
                         & but we have the next time. How did this happen?')
      endif
      if (clim_type%itaum.ne.0 .and. clim_type%itaup.eq.0) then
!We have the previous time step but not the next time step data
        clim_type%itaup = 1
        if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
    do i=1, size(clim_type%field_name(:))
        call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
        clim_type%time_init(i,clim_type%itaup)=taup
     end do
      endif


    endif! TIME_FLAG

    clim_type%separate_time_vary_calc = .true.

!-------------------------------------------------------------------


end subroutine obtain_interpolator_time_slices 


!#####################################################################

subroutine unset_interpolator_time_flag (clim_type)

type(interpolate_type), intent(inout) :: clim_type


      clim_type%separate_time_vary_calc = .false.


end subroutine unset_interpolator_time_flag 



!#####################################################################

!---------------------------------------------------------------------

subroutine interpolator_4D(clim_type, Time, phalf, interp_data,  &
                           field_name, is,js, clim_units)
!
! Return 4-D field interpolated to model grid and time
!
! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init
!
! INTENT IN
!   field_name  : The name of a field that you wish to interpolate.
!                 all variables within this interpolate_type variable
!                 will be interpolated on this call. field_name may
!                 be any one of the variables.
!   Time        : The model time that you wish to interpolate to.
!   phalf       : The half level model pressure field.
!   is, js      : The indices of the physics window.
!
! INTENT OUT
!   interp_data : The model fields with the interpolated climatology data.
!   clim_units  : The units of field_name
!
type(interpolate_type), intent(inout)  :: clim_type
character(len=*)      , intent(in)  :: field_name
type(time_type)       , intent(in)  :: Time
real, dimension(:,:,:), intent(in)  :: phalf
real, dimension(:,:,:,:), intent(out) :: interp_data
integer               , intent(in) , optional :: is,js
character(len=*)      , intent(out), optional :: clim_units
integer :: taum, taup, ilon
real :: hinterp_data(size(interp_data,1),size(interp_data,2),size(clim_type%levs(:)),size(clim_type%field_name(:)))
real :: p_fact(size(interp_data,1),size(interp_data,2))
real :: col_data(size(interp_data,1),size(interp_data,2),   &
                           size(clim_type%field_name(:)))
real :: pclim(size(clim_type%halflevs(:)))
integer :: istart,iend,jstart,jend
logical :: result, found
logical :: found_field=.false.
integer :: modyear, modmonth, modday, modhour, modminute, modsecond
integer :: climyear, climmonth, climday, climhour, climminute, climsecond
integer :: year1, month1, day, hour, minute, second
integer :: climatology, m
type(time_type) :: t_prev, t_next
type(time_type), dimension(2) :: month
integer :: indexm, indexp, yearm, yearp
integer :: i, j, k, n


if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "interpolator_4D : You must call interpolator_init before calling interpolator")

   do n=2,size(clim_type%field_name(:))
     if (clim_type%vert_interp(n) /= clim_type%vert_interp(n-1) .or. &
      clim_type%out_of_bounds(n) /= clim_type%out_of_bounds(n-1)) then
       if (mpp_pe() == mpp_root_pe() ) then
         print *, 'processing file ' // trim(clim_type%file_name)
       endif
       call mpp_error (FATAL, 'interpolator_mod: &
               &cannot use 4D interface to interpolator for this file')
     endif
   end do
     



istart = 1
if (present(is)) istart = is
iend = istart - 1 + size(interp_data,1)

jstart = 1
if (present(js)) jstart = js
jend = jstart - 1 + size(interp_data,2)

  do i= 1,size(clim_type%field_name(:))
!!++lwh
   if ( field_name == clim_type%field_name(i) ) then
!--lwh
    found_field=.true.
    exit 
 endif
end do
   i = 1

    if(present(clim_units)) then
      call mpp_get_atts(clim_type%field_type(i),units=clim_units)
      clim_units = chomp(clim_units)
    endif




!----------------------------------------------------------------------
!   skip the time interpolation portion of this routine if subroutine
!   obtain_interpolator_time_slices has already been called on this
!   stewp for this interpolate_type variable.
!----------------------------------------------------------------------

if ( .not. clim_type%separate_time_vary_calc) then     
!   print *, 'TIME INTERPOLATION NOT SEPARATED 4d--',  &
!                                trim(clim_type%file_name), mpp_pe()

    if (clim_type%climatological_year) then
!++lwh
       if (size(clim_type%time_slice) > 1) then
          call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup, modtime=YEAR )
       else
          taum = 1
          taup = 1
          clim_type%tweight = 0.
       end if
!--lwh
    else
       call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup )
    endif


    if(clim_type%TIME_FLAG .eq. BILINEAR ) then
      ! Check if delta-time is greater than delta of first two climatology time-slices.
      if ( (Time - clim_type%time_slice(taum) ) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) .or. &
           (clim_type%time_slice(taup)  - Time) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) ) then
      ! The difference between the model time and the last climatology time-slice previous to the model time.
      ! We need 2 time levels.
        clim_type%itaum=0
        clim_type%itaup=0
      ! Assume this is monthly data. So we need to get the data applicable to the model date but substitute 
      ! the climatology year into the appropriate place.

     
      ! We need to get the previous months data for the climatology year before 
      ! and after the model year.
        call get_date(Time, modyear, modmonth, modday, modhour, modminute, modsecond)
        call get_date(clim_type%time_slice(taum), climyear, climmonth, climday, climhour, climminute, climsecond)

        climatology = 1
        do m = 1, size(clim_type%clim_times(:,:),2)
          !Assume here that a climatology is for 1 year and consists of 12 months starting in January.
          call get_date(clim_type%clim_times(1,m), year1, month1, day, hour, minute, second)
          if (year1 == climyear) climatology = m 
        enddo
        do m = 1,12
          !Find which month we are trying to look at and set clim_date[mp] to the dates spanning that.
          call get_date(clim_type%clim_times(m,climatology), year1, month1, day, hour, minute, second)
          if ( month1 == modmonth ) then
!RSHBUGFX   if ( modday <= day ) then 
            if ( modday <  day ) then 
              indexm = m-1 ; indexp = m
            else
              indexm = m ; indexp = m+1
            endif
          endif
        
        enddo
        if ( indexm == 0 ) then 
          indexm = 12
          yearm = modyear - 1
        else
          yearm = modyear
        endif
          call get_date(clim_type%time_slice(indexm+(climatology-1)*12), &
                        climyear, climmonth, climday, climhour, climminute, climsecond)
          month(1) = set_date(yearm, indexm, climday, climhour, climminute, climsecond)
        if ( indexp == 13 ) then
          indexp = 1
          yearp = modyear + 1
        else
          yearp = modyear
        endif
          call get_date(clim_type%time_slice(indexp+(climatology-1)*12), &
                        climyear, climmonth, climday, climhour, climminute, climsecond)
          month(2) = set_date(yearp, indexp, climday, climhour, climminute, climsecond)
        
        call time_interp(Time, month, clim_type%tweight3, taum, taup ) ! tweight3 is the time weight between the months.

        month(1) = clim_type%time_slice(indexm+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexm+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_prev = set_date(yearm, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_prev, month, clim_type%tweight1, taum, taup ) !tweight1 is the time weight between the climatology years.
        month(1) = clim_type%time_slice(indexp+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexp+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_next = set_date(yearp, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_next, month, clim_type%tweight2, taum, taup ) !tweight1 is the time weight between the climatology years.

        if (indexm == clim_type%indexm(1) .and.  &
            indexp == clim_type%indexp(1) .and. &
            climatology == clim_type%climatology(1)) then
        else
          clim_type%indexm(:) = indexm
          clim_type%indexp(:) = indexp
          clim_type%climatology(:) = climatology
          do i=1, size(clim_type%field_name(:))
            call read_data(clim_type,clim_type%field_type(i),  &
             clim_type%pmon_pyear(:,:,:,i),   &
             clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
! Read the data for the next month in the previous climatology.
            call read_data(clim_type,clim_type%field_type(i),  &
             clim_type%nmon_pyear(:,:,:,i),   &
             clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
            call read_data(clim_type,clim_type%field_type(i),  &
              clim_type%pmon_nyear(:,:,:,i),  &
              clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
            call read_data(clim_type,clim_type%field_type(i),  &
              clim_type%nmon_nyear(:,:,:,i),  &
              clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
          end do
        endif



      else ! We are within a climatology data set
        

        do i=1, size(clim_type%field_name(:))
          if (taum /= clim_type%time_init(i,1) .or. &
              taup /= clim_type%time_init(i,2) ) then
 
     
            call read_data(clim_type,clim_type%field_type(i),   &
                           clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
! Read the data for the next month in the previous climatology.
            call read_data(clim_type,clim_type%field_type(i),   &
                           clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
            clim_type%time_init(i,1) = taum
            clim_type%time_init(i,2) = taup
          endif
        end do

!       clim_type%pmon_nyear = 0.0
!       clim_type%nmon_nyear = 0.0

! set to zero so when next return to bilinear section will be sure to
! have proper data (relevant when running fixed_year case for more than
! one year in a single job)
          clim_type%indexm(:) = 0       
          clim_type%indexp(:) = 0        
          clim_type%climatology(:) = 0             


!       clim_type%tweight3 = 0.0 ! This makes [pn]mon_nyear irrelevant. Set them to 0 to test.
        clim_type%tweight1 = 0.0 
        clim_type%tweight2 = 0.0 
        clim_type%tweight3 = clim_type%tweight                                          
      endif
    endif   !(BILINEAR)

    if(clim_type%TIME_FLAG .eq. LINEAR  .and.   &
        (.not. read_all_on_init) ) then
! We need 2 time levels. Check we have the correct data.
      clim_type%itaum=0
      clim_type%itaup=0
      do n=1,size(clim_type%time_init,2)
        if (clim_type%time_init(1,n) .eq. taum ) clim_type%itaum = n
        if (clim_type%time_init(1,n) .eq. taup ) clim_type%itaup = n
      enddo

      if (clim_type%itaum.eq.0 .and. clim_type%itaup.eq.0) then
!Neither time is set so we need to read 2 time slices.
!Set up 
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
    do i=1, size(clim_type%field_name(:))
    call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
          clim_type%time_init(i,1) = taum
          clim_type%itaum = 1
    call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
          clim_type%time_init(i,2) = taup
          clim_type%itaup = 2
    end do
      endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
      if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
 call mpp_error(FATAL,'interpolator_3D : No data from the previous climatology time &
                         & but we have the next time. How did this happen?')
      endif
      if (clim_type%itaum.ne.0 .and. clim_type%itaup.eq.0) then
!We have the previous time step but not the next time step data
        clim_type%itaup = 1
        if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
    do i=1, size(clim_type%field_name(:))
        call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
        clim_type%time_init(i,clim_type%itaup)=taup
     end do
      endif


    endif! TIME_FLAG


endif ! (.not. separate_time_vary_calc)


select case(clim_type%TIME_FLAG)
  case (LINEAR)
    do n=1, size(clim_type%field_name(:))
      hinterp_data(:,:,:,n) = (1-clim_type%tweight)*  &
                clim_type%data(istart:iend,jstart:jend,:,clim_type%itaum,n)  +  &
                                 clim_type%tweight*   &
                clim_type%data(istart:iend,jstart:jend,:,clim_type%itaup,n)
    end do
! case (SEASONAL)
! Do sine fit to data at this point
  case (BILINEAR)
    do n=1, size(clim_type%field_name(:))
      hinterp_data(:,:,:,n) = (1-clim_type%tweight1)*(1-clim_type%tweight3)*   &
                   clim_type%pmon_pyear(istart:iend,jstart:jend,:,n) + &
                              (1-clim_type%tweight2)*clim_type%tweight3*    &
                   clim_type%nmon_pyear(istart:iend,jstart:jend,:,n) + &
                               clim_type%tweight1* (1-clim_type%tweight3)*  &
                   clim_type%pmon_nyear(istart:iend,jstart:jend,:,n) + &
                               clim_type%tweight2* clim_type%tweight3*   &
                   clim_type%nmon_nyear(istart:iend,jstart:jend,:,n)
    
    end do

end select
    
select case(clim_type%level_type)
  case(PRESSURE)
    p_fact = 1.0
  case(SIGMA)
    p_fact = maxval(phalf,3)! max pressure in the column !(:,:,size(phalf,3))
end select

col_data(:,:,:)=0.0
     do i= 1, size(clim_type%field_name(:))

select case(clim_type%mr(i))
  case(NO_CONV)
    do k = 1,size(hinterp_data,3)
   col_data(:,:,i) = col_data(:,:,i) + hinterp_data(:,:,k,i)* &
      (clim_type%halflevs(k+1)-clim_type%halflevs(k))/grav
    enddo
    
  case(KG_M2)
    do k = 1,size(hinterp_data,3)
       col_data(:,:,i) = col_data(:,:,i) + hinterp_data(:,:,k,i)
       hinterp_data(:,:,k,i) = hinterp_data(:,:,k,i)/ &
         ((clim_type%halflevs(k+1)-clim_type%halflevs(k))*p_fact)
    enddo
end select
    enddo

     do i= 1, size(clim_type%field_name(:))
found = .false.
do j = 1,size(climo_diag_name(:))
  if (climo_diag_name(j) .eq. clim_type%field_name(i)) then
    found = .true.
    exit
  endif
enddo

if (found) then
  if (hinterp_id(j) > 0 ) then
       result = send_data(hinterp_id(j),col_data(:,:,i),Time)
  endif
endif

  end do

   i = 1

!++lwh
do j = 1, size(phalf,2)
   do ilon=1,size(phalf,1)
      pclim = p_fact(ilon,j)*clim_type%halflevs
      if ( maxval(phalf(ilon,j,:)) > maxval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model surface pressure&
                             & is greater than climatology surface pressure for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( maxloc(pclim) ) = maxval( phalf(ilon,j,:) )
!           case(ZERO)
!              pclim( maxloc(pclim)) = 0
         end select
      endif
      if ( minval(phalf(ilon,j,:)) < minval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model top pressure&
                             & is less than climatology top pressure for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( minloc(pclim) ) = minval( phalf(ilon,j,:) )
!           case(ZERO)
!              pclim( maxloc(pclim)) = 0
         end select
      endif
      select case(clim_type%vert_interp(i))
         case(INTERP_WEIGHTED_P)
            call interp_weighted_scalar(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:,:),interp_data(ilon,j,:,:))
         case(INTERP_LINEAR_P)
          do n=1, size(clim_type%field_name(:))
            call interp_linear(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:,n),interp_data(ilon,j,:,n))
          end do
!        case(INTERP_LOG)
      end select
   enddo
enddo

!--lwh
     do i= 1, size(clim_type%field_name(:))

select case(clim_type%mr(i))
  case(KG_M2)
    do k = 1,size(interp_data,3)
       interp_data(:,:,k,i) = interp_data(:,:,k,i)*(phalf(:,:,k+1)-phalf(:,:,k))
    enddo
end select

     end do

if( .not. found_field) then !field name is not in interpolator file.ERROR.
  call mpp_error(FATAL,"Interpolator: the field name is not contained in this &
                   &intepolate_type: "//trim(field_name))
endif
end subroutine interpolator_4D
!
!#######################################################################
!#######################################################################
!
subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js, clim_units)
!
! Return 3-D field interpolated to model grid and time
!
! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init
!
! INTENT IN
!   field_name  : The name of the field that you wish to interpolate.
!   Time        : The model time that you wish to interpolate to.
!   phalf       : The half level model pressure field.
!   is, js      : The indices of the physics window.
!
! INTENT OUT
!   interp_data : The model field with the interpolated climatology data.
!   clim_units  : The units of field_name
!
type(interpolate_type), intent(inout)  :: clim_type
character(len=*)      , intent(in)  :: field_name
type(time_type)       , intent(in)  :: Time
real, dimension(:,:,:), intent(in)  :: phalf
real, dimension(:,:,:), intent(out) :: interp_data
integer               , intent(in) , optional :: is,js
character(len=*)      , intent(out), optional :: clim_units
integer :: taum, taup, ilon
real :: hinterp_data(size(interp_data,1),size(interp_data,2),size(clim_type%levs(:)))
real :: p_fact(size(interp_data,1),size(interp_data,2))
real :: col_data(size(interp_data,1),size(interp_data,2))
real :: pclim(size(clim_type%halflevs(:)))
integer :: istart,iend,jstart,jend
logical :: result, found
logical :: found_field=.false.
integer :: modyear, modmonth, modday, modhour, modminute, modsecond
integer :: climyear, climmonth, climday, climhour, climminute, climsecond
integer :: year1, month1, day, hour, minute, second
integer :: climatology, m
type(time_type) :: t_prev, t_next
type(time_type), dimension(2) :: month
integer :: indexm, indexp, yearm, yearp
integer :: i, j, k, n



if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "interpolator_3D : You must call interpolator_init before calling interpolator")

istart = 1
if (present(is)) istart = is
iend = istart - 1 + size(interp_data,1)

jstart = 1
if (present(js)) jstart = js
jend = jstart - 1 + size(interp_data,2)

do i= 1,size(clim_type%field_name(:))
!++lwh
  if ( field_name == clim_type%field_name(i) ) then
!--lwh
    found_field=.true.
    if(present(clim_units)) then
      call mpp_get_atts(clim_type%field_type(i),units=clim_units)
      clim_units = chomp(clim_units)
    endif

!----------------------------------------------------------------------
!   skip the time interpolation portion of this routine if subroutine
!   obtain_interpolator_time_slices has already been called on this
!   stewp for this interpolate_type variable.
!----------------------------------------------------------------------


if ( .not. clim_type%separate_time_vary_calc) then     
!   print *, 'TIME INTERPOLATION NOT SEPARATED 3d--',  &
!                                trim(clim_type%file_name), mpp_pe()
    if (clim_type%climatological_year) then
!++lwh
       if (size(clim_type%time_slice) > 1) then
          call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup, modtime=YEAR )
       else
          taum = 1
          taup = 1
          clim_type%tweight = 0.
       end if
!--lwh
    else
       call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup )
    endif

!   if(clim_type%TIME_FLAG .ne. LINEAR ) then
    if(clim_type%TIME_FLAG .ne. LINEAR .or. read_all_on_init ) then
      clim_type%itaum=taum
      clim_type%itaup=taup
    endif

    if(clim_type%TIME_FLAG .eq. BILINEAR ) then
      ! Check if delta-time is greater than delta of first two climatology time-slices.
      if ( (Time - clim_type%time_slice(taum) ) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) .or. &
           (clim_type%time_slice(taup)  - Time) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) ) then
      ! The difference between the model time and the last climatology time-slice previous to the model time.
      ! We need 2 time levels.
        clim_type%itaum=0
        clim_type%itaup=0
      ! Assume this is monthly data. So we need to get the data applicable to the model date but substitute 
      ! the climatology year into the appropriate place.

     
      ! We need to get the previous months data for the climatology year before 
      ! and after the model year.
        call get_date(Time, modyear, modmonth, modday, modhour, modminute, modsecond)
        call get_date(clim_type%time_slice(taum), climyear, climmonth, climday, climhour, climminute, climsecond)

        climatology = 1
        do m = 1, size(clim_type%clim_times(:,:),2)
          !Assume here that a climatology is for 1 year and consists of 12 months starting in January.
          call get_date(clim_type%clim_times(1,m), year1, month1, day, hour, minute, second)
          if (year1 == climyear) climatology = m 
        enddo
        do m = 1,12
          !Find which month we are trying to look at and set clim_date[mp] to the dates spanning that.
          call get_date(clim_type%clim_times(m,climatology), year1, month1, day, hour, minute, second)
          if ( month1 == modmonth ) then
!RSHBUGFX   if ( modday <= day ) then 
            if ( modday <  day ) then 
              indexm = m-1 ; indexp = m
            else
              indexm = m ; indexp = m+1
            endif
          endif
        
        enddo
        if ( indexm == 0 ) then 
          indexm = 12
          yearm = modyear - 1
        else
          yearm = modyear
        endif
        call get_date(clim_type%time_slice(indexm+(climatology-1)*12), &
                      climyear, climmonth, climday, climhour, climminute, climsecond)
        month(1) = set_date(yearm, indexm, climday, climhour, climminute, climsecond)
        if ( indexp == 13 ) then
          indexp = 1
          yearp = modyear + 1
        else
          yearp = modyear
        endif
        call get_date(clim_type%time_slice(indexp+(climatology-1)*12), &
                      climyear, climmonth, climday, climhour, climminute, climsecond)
        month(2) = set_date(yearp, indexp, climday, climhour, climminute, climsecond)
        
        call time_interp(Time, month, clim_type%tweight3, taum, taup ) ! tweight3 is the time weight between the months.

        month(1) = clim_type%time_slice(indexm+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexm+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_prev = set_date(yearm, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_prev, month, clim_type%tweight1, taum, taup ) !tweight1 is the time weight between the climatology years.

        month(1) = clim_type%time_slice(indexp+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexp+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_next = set_date(yearp, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_next, month, clim_type%tweight2, taum, taup ) !tweight1 is the time weight between the climatology years.



        if (indexm == clim_type%indexm(i) .and.  &
          indexp == clim_type%indexp(i) .and. &
          climatology == clim_type%climatology(i)) then
        else
          clim_type%indexm(i) = indexm
          clim_type%indexp(i) = indexp
          clim_type%climatology(i) = climatology
          call read_data(clim_type,clim_type%field_type(i),  &
            clim_type%pmon_pyear(:,:,:,i),  &
            clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
! Read the data for the next month in the previous climatology.
          call read_data(clim_type,clim_type%field_type(i),  &
            clim_type%nmon_pyear(:,:,:,i),   &
            clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
          call read_data(clim_type,clim_type%field_type(i),   &
            clim_type%pmon_nyear(:,:,:,i),  &
            clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
          call read_data(clim_type,clim_type%field_type(i),  &
            clim_type%nmon_nyear(:,:,:,i),  &
            clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
        endif




      else ! We are within a climatology data set
        
        if (taum /= clim_type%time_init(i,1) .or. &
            taup /= clim_type%time_init(i,2) ) then
 
          call read_data(clim_type,clim_type%field_type(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
! Read the data for the next month in the previous climatology.
          call read_data(clim_type,clim_type%field_type(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
!RSHbug   clim_type%pmon_nyear = 0.0
!RSHbug   clim_type%nmon_nyear = 0.0

!         clim_type%pmon_nyear(:,:,:,i) = 0.0
!         clim_type%nmon_nyear(:,:,:,i) = 0.0

! set to zero so when next return to bilinear section will be sure to
! have proper data (relevant when running fixed_year case for more than
! one year in a single job)
          clim_type%indexm(i) = 0       
          clim_type%indexp(i) = 0        
          clim_type%climatology(i) = 0             


          clim_type%time_init(i,1) = taum
          clim_type%time_init(i,2) = taup
        endif
!       clim_type%tweight3 = 0.0 ! This makes [pn]mon_nyear irrelevant. Set them to 0 to test.
        clim_type%tweight1 = 0.0 ; clim_type%tweight2 = 0.0
        clim_type%tweight3 = clim_type%tweight                                          
      endif

    endif ! (BILINEAR)


    if(clim_type%TIME_FLAG .eq. LINEAR  .and.   &
        (.not. read_all_on_init) ) then
! We need 2 time levels. Check we have the correct data.
      clim_type%itaum=0
      clim_type%itaup=0
      do n=1,size(clim_type%time_init,2)
        if (clim_type%time_init(i,n) .eq. taum ) clim_type%itaum = n
        if (clim_type%time_init(i,n) .eq. taup ) clim_type%itaup = n
      enddo

      if (clim_type%itaum.eq.0 .and. clim_type%itaup.eq.0) then
!Neither time is set so we need to read 2 time slices.
!Set up 
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
    call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
          clim_type%time_init(i,1) = taum
          clim_type%itaum = 1
    call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
          clim_type%time_init(i,2) = taup
          clim_type%itaup = 2
      endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
      if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
 call mpp_error(FATAL,'interpolator_3D : No data from the previous climatology time &
                         & but we have the next time. How did this happen?')
      endif
      if (clim_type%itaum.ne.0 .and. clim_type%itaup.eq.0) then
!We have the previous time step but not the next time step data
        clim_type%itaup = 1
        if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
        call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
        clim_type%time_init(i,clim_type%itaup)=taup
      endif


    endif! TIME_FLAG

    endif   !( .not. clim_type%separate_time_vary_calc) 
select case(clim_type%TIME_FLAG)
  case (LINEAR)
    hinterp_data = (1-clim_type%tweight) * clim_type%data(istart:iend,jstart:jend,:,clim_type%itaum,i) + &
                       clim_type%tweight * clim_type%data(istart:iend,jstart:jend,:,clim_type%itaup,i)
! case (SEASONAL)
! Do sine fit to data at this point
  case (BILINEAR)
    hinterp_data = &
    (1-clim_type%tweight1)  * (1-clim_type%tweight3) * clim_type%pmon_pyear(istart:iend,jstart:jend,:,i) + &
    (1-clim_type%tweight2)  *    clim_type%tweight3  * clim_type%nmon_pyear(istart:iend,jstart:jend,:,i) + &
         clim_type%tweight1 * (1-clim_type%tweight3) * clim_type%pmon_nyear(istart:iend,jstart:jend,:,i) + &
         clim_type%tweight2 *     clim_type%tweight3 * clim_type%nmon_nyear(istart:iend,jstart:jend,:,i)
    


end select

select case(clim_type%level_type)
  case(PRESSURE)
    p_fact = 1.0
  case(SIGMA)
    p_fact = maxval(phalf,3)! max pressure in the column !(:,:,size(phalf,3))
end select

col_data(:,:)=0.0
select case(clim_type%mr(i))
  case(NO_CONV)
    do k = 1,size(hinterp_data,3)
   col_data(:,:) = col_data(:,:) + hinterp_data(:,:,k)* &
      (clim_type%halflevs(k+1)-clim_type%halflevs(k))/grav
    enddo
    
  case(KG_M2)
    do k = 1,size(hinterp_data,3)
       col_data(:,:) = col_data(:,:) + hinterp_data(:,:,k)
       hinterp_data(:,:,k) = hinterp_data(:,:,k)/ &
         ((clim_type%halflevs(k+1)-clim_type%halflevs(k))*p_fact)
    enddo
end select

found = .false.
do j = 1,size(climo_diag_name(:))
  if (climo_diag_name(j) .eq. clim_type%field_name(i)) then
    found = .true.
    exit
  endif
enddo

if (found) then
  if (hinterp_id(j) > 0 ) then
       result = send_data(hinterp_id(j),col_data,Time)
  endif
endif


!++lwh
do j = 1, size(phalf,2)
   do ilon=1,size(phalf,1)
      pclim = p_fact(ilon,j)*clim_type%halflevs
      if ( maxval(phalf(ilon,j,:)) > maxval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model surface pressure&
                             & is greater than climatology surface pressure for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( maxloc(pclim) ) = maxval( phalf(ilon,j,:) )
!           case(ZERO)
!              pclim( maxloc(pclim)) = 0
         end select
      endif
      if ( minval(phalf(ilon,j,:)) < minval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model top pressure&
                             & is less than climatology top pressure for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( minloc(pclim) ) = minval( phalf(ilon,j,:) )
!           case(ZERO)
!              pclim( maxloc(pclim)) = 0
         end select
      endif
      select case(clim_type%vert_interp(i))
         case(INTERP_WEIGHTED_P)
            call interp_weighted_scalar(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:),interp_data(ilon,j,:))
         case(INTERP_LINEAR_P)
            call interp_linear(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:),interp_data(ilon,j,:))
!        case(INTERP_LOG)
      end select
   enddo
enddo

!--lwh

select case(clim_type%mr(i))
  case(KG_M2)
    do k = 1,size(interp_data,3)
       interp_data(:,:,k) = interp_data(:,:,k)*(phalf(:,:,k+1)-phalf(:,:,k))
    enddo
end select

  endif !field_name
enddo !End of i loop
if( .not. found_field) then !field name is not in interpolator file.ERROR.
  call mpp_error(FATAL,"Interpolator: the field name is not contained in this &
                   &intepolate_type: "//trim(field_name))
endif
end subroutine interpolator_3D
!
!#######################################################################
!
!++lwh
subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, clim_units)
!
! Return 2-D field interpolated to model grid and time
!
!
! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init
!
! INTENT IN
!   field_name  : The name of the field that you wish to interpolate.
!   Time        : The model time that you wish to interpolate to.
!   is, js      : The indices of the physics window.
!
! INTENT OUT
!   interp_data : The model field with the interpolated climatology data.
!   clim_units  : The units of field_name
!
type(interpolate_type), intent(inout)  :: clim_type
character(len=*)      , intent(in)     :: field_name
type(time_type)       , intent(in)     :: Time
real, dimension(:,:),   intent(out)    :: interp_data
integer               , intent(in) , optional :: is,js
character(len=*)      , intent(out), optional :: clim_units
integer :: taum, taup
real :: hinterp_data(size(interp_data,1),size(interp_data,2),size(clim_type%levs(:)))
integer :: istart,iend,jstart,jend
logical :: result, found
logical :: found_field=.false.
integer :: modyear, modmonth, modday, modhour, modminute, modsecond
integer :: climyear, climmonth, climday, climhour, climminute, climsecond
integer :: year1, month1, day, hour, minute, second
integer :: climatology, m
type(time_type) :: t_prev, t_next
type(time_type), dimension(2) :: month
integer :: indexm, indexp, yearm, yearp
integer :: j, i, n

if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "interpolator_2D : You must call interpolator_init before calling interpolator")

istart = 1
if (present(is)) istart = is
iend = istart - 1 + size(interp_data,1)

jstart = 1
if (present(js)) jstart = js
jend = jstart - 1 + size(interp_data,2)

do i= 1,size(clim_type%field_name(:))
!++lwh
  if ( field_name == clim_type%field_name(i) ) then
!--lwh

    found_field=.true.

    if(present(clim_units)) then
      call mpp_get_atts(clim_type%field_type(i),units=clim_units)
      clim_units = chomp(clim_units)
    endif


!----------------------------------------------------------------------
!   skip the time interpolation portion of this routine if subroutine
!   obtain_interpolator_time_slices has already been called on this
!   stewp for this interpolate_type variable.
!----------------------------------------------------------------------

if ( .not. clim_type%separate_time_vary_calc) then     
!   print *, 'TIME INTERPOLATION NOT SEPARATED 2d--',  &
!                                   trim(clim_type%file_name), mpp_pe()
    if (clim_type%climatological_year) then
!++lwh
       if (size(clim_type%time_slice) > 1) then
          call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup, modtime=YEAR )
       else
          taum = 1
          taup = 1
          clim_type%tweight = 0.
       end if
!--lwh
    else
       call time_interp(Time, clim_type%time_slice, clim_type%tweight, taum, taup )
    endif

! If the climatology file has seasonal, a split time-line or has all the data 
! read in then enter this loop.
! 
    if(clim_type%TIME_FLAG .ne. LINEAR .or. read_all_on_init) then
      clim_type%itaum=taum
      clim_type%itaup=taup
    endif

!    if(clim_type%TIME_FLAG .eq. BILINEAR ) then
!      ! Check if delta-time is greater than delta of first two climatology time-slices.
!      if ( (Time - clim_type%time_slice(taum) ) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) .or. &
!           (clim_type%time_slice(taup)  - Time) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) ) then
!      ! The difference between the model time and the last climatology time-slice previous to the model time.
!      ! We need 2 time levels. Check we have the correct data.
!        itaum=0
!        itaup=0
!      ! Assume this is monthly data. So we need to get the data applicable to the model date but substitute 
!      ! the climatology year into the appropriate place.
!      
!        call get_date(Time, modyear, modmonth, modday, modhour, modminute, modsecond)
!        call get_date(clim_type%time_slice(taum), climyear, climmonth, climday, climhour, climminute, climsecond)
!        clim_datem = set_date(climyear, modmonth, modday, modhour, modminute, modsecond)
!        call time_interp(clim_datem, clim_type%time_slice, tweight1, taum1, taup1 )
!
!
!        call get_date(clim_type%time_slice(taup), climyear, climmonth, climday, climhour, climminute, climsecond)
!        clim_datep = set_date(climyear, modmonth, modday, modhour, modminute, modsecond)
!
!
!      endif
!
!    endif
    if(clim_type%TIME_FLAG .eq. BILINEAR ) then
      ! Check if delta-time is greater than delta of first two climatology time-slices.
      if ( (Time - clim_type%time_slice(taum) ) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) .or. &
           (clim_type%time_slice(taup)  - Time) > ( clim_type%time_slice(2)- clim_type%time_slice(1) ) ) then
      ! The difference between the model time and the last climatology time-slice previous to the model time.
      ! We need 2 time levels.
        clim_type%itaum=0
        clim_type%itaup=0
      ! Assume this is monthly data. So we need to get the data applicable to the model date but substitute 
      ! the climatology year into the appropriate place.

     
      ! We need to get the previous months data for the climatology year before 
      ! and after the model year.
        call get_date(Time, modyear, modmonth, modday, modhour, modminute, modsecond)
        call get_date(clim_type%time_slice(taum), climyear, climmonth, climday, climhour, climminute, climsecond)

        climatology = 1
        do m = 1, size(clim_type%clim_times(:,:),2)
          !Assume here that a climatology is for 1 year and consists of 12 months starting in January.
          call get_date(clim_type%clim_times(1,m), year1, month1, day, hour, minute, second)
          if (year1 == climyear) climatology = m 
        enddo
        do m = 1,12
          !Find which month we are trying to look at and set clim_date[mp] to the dates spanning that.
          call get_date(clim_type%clim_times(m,climatology), year1, month1, day, hour, minute, second)
          if ( month1 == modmonth ) then
!RSHBUGFX   if ( modday <= day ) then 
            if ( modday <  day ) then 
              indexm = m-1 ; indexp = m
            else
              indexm = m ; indexp = m+1
            endif
          endif
        
        enddo
        if ( indexm == 0 ) then 
          indexm = 12
          yearm = modyear - 1
        else
          yearm = modyear
        endif
        call get_date(clim_type%time_slice(indexm+(climatology-1)*12), &
                      climyear, climmonth, climday, climhour, climminute, climsecond)
        month(1) = set_date(yearm, indexm, climday, climhour, climminute, climsecond)
        if ( indexp == 13 ) then
          indexp = 1
          yearp = modyear + 1
        else
          yearp = modyear
        endif
        call get_date(clim_type%time_slice(indexp+(climatology-1)*12), &
                      climyear, climmonth, climday, climhour, climminute, climsecond)
        month(2) = set_date(yearp, indexp, climday, climhour, climminute, climsecond)
        
        call time_interp(Time, month, clim_type%tweight3, taum, taup ) ! tweight3 is the time weight between the months.

        month(1) = clim_type%time_slice(indexm+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexm+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_prev = set_date(yearm, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_prev, month, clim_type%tweight1, taum, taup ) !tweight1 is the time weight between the climatology years.

        month(1) = clim_type%time_slice(indexp+(climatology-1)*12)
        month(2) = clim_type%time_slice(indexp+climatology*12)
        call get_date(month(1), climyear, climmonth, climday, climhour, climminute, climsecond)
        t_next = set_date(yearp, climmonth, climday, climhour, climminute, climsecond)
        call time_interp(t_next, month, clim_type%tweight2, taum, taup ) !tweight1 is the time weight between the climatology years.



        if (indexm == clim_type%indexm(i) .and.  &
          indexp == clim_type%indexp(i) .and. &
          climatology == clim_type%climatology(i)) then
        else
          clim_type%indexm(i) = indexm
          clim_type%indexp(i) = indexp
          clim_type%climatology(i) = climatology
          call read_data(clim_type,clim_type%field_type(i),  &
            clim_type%pmon_pyear(:,:,:,i),  &
            clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
! Read the data for the next month in the previous climatology.
          call read_data(clim_type,clim_type%field_type(i),  &
            clim_type%nmon_pyear(:,:,:,i),   &
            clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
          call read_data(clim_type,clim_type%field_type(i),   &
            clim_type%pmon_nyear(:,:,:,i),  &
            clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
          call read_data(clim_type,clim_type%field_type(i),  &
            clim_type%nmon_nyear(:,:,:,i),  &
            clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
        endif




      else ! We are within a climatology data set
        
        if (taum /= clim_type%time_init(i,1) .or. &
            taup /= clim_type%time_init(i,2) ) then
 
          call read_data(clim_type,clim_type%field_type(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
! Read the data for the next month in the previous climatology.
          call read_data(clim_type,clim_type%field_type(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
!RSHbug   clim_type%pmon_nyear = 0.0
!RSHbug   clim_type%nmon_nyear = 0.0

!         clim_type%pmon_nyear(:,:,:,i) = 0.0
!         clim_type%nmon_nyear(:,:,:,i) = 0.0

! set to zero so when next return to bilinear section will be sure to
! have proper data (relevant when running fixed_year case for more than
! one year in a single job)
          clim_type%indexm(i) = 0       
          clim_type%indexp(i) = 0        
          clim_type%climatology(i) = 0             


          clim_type%time_init(i,1) = taum
          clim_type%time_init(i,2) = taup
        endif
!       clim_type%tweight3 = 0.0 ! This makes [pn]mon_nyear irrelevant. Set them to 0 to test.
        clim_type%tweight1 = 0.0 ; clim_type%tweight2 = 0.0
        clim_type%tweight3 = clim_type%tweight                                          
      endif

    endif ! (BILINEAR)

    if(clim_type%TIME_FLAG .eq. LINEAR .and. &
        (.not. read_all_on_init) ) then
! We need 2 time levels. Check we have the correct data.
      clim_type%itaum=0
      clim_type%itaup=0
      do n=1,size(clim_type%time_init,2)
        if (clim_type%time_init(i,n) .eq. taum ) clim_type%itaum = n
        if (clim_type%time_init(i,n) .eq. taup ) clim_type%itaup = n
      enddo

      if (clim_type%itaum.eq.0 .and. clim_type%itaup.eq.0) then
      !Neither time is set so we need to read 2 time slices.
      !Set up 
      ! field(:,:,:,1) as the previous time slice.
      ! field(:,:,:,2) as the next time slice.
        call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
          clim_type%time_init(i,1) = taum
          clim_type%itaum = 1
        call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
          clim_type%time_init(i,2) = taup
          clim_type%itaup = 2
      endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
      if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
      ! Can't think of a situation where we would have the next time level but not the previous.
        call mpp_error(FATAL,'interpolator_2D : No data from the previous climatology time but we have&
                            & the next time. How did this happen?')
      endif
      if (clim_type%itaum.ne.0 .and. clim_type%itaup.eq.0) then
      !We have the previous time step but not the next time step data
        clim_type%itaup = 1
        if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
        call read_data(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
        clim_type%time_init(i,clim_type%itaup)=taup
      endif
    endif! TIME_FLAG .eq. LINEAR .and. (.not. read_all_on_init)

  endif ! (.not. separate_time_vary_calc)



select case(clim_type%TIME_FLAG)
  case (LINEAR)
    hinterp_data = (1-clim_type%tweight)*clim_type%data(istart:iend,jstart:jend,:,clim_type%itaum,i) &
                     + clim_type%tweight*clim_type%data(istart:iend,jstart:jend,:,clim_type%itaup,i)
! case (SEASONAL)
! Do sine fit to data at this point
  case (BILINEAR)
    hinterp_data = &
    (1-clim_type%tweight1)  * (1-clim_type%tweight3) * clim_type%pmon_pyear(istart:iend,jstart:jend,:,i) + &
    (1-clim_type%tweight2)  *    clim_type%tweight3  * clim_type%nmon_pyear(istart:iend,jstart:jend,:,i) + &
         clim_type%tweight1 * (1-clim_type%tweight3) * clim_type%pmon_nyear(istart:iend,jstart:jend,:,i) + &
         clim_type%tweight2 *     clim_type%tweight3 * clim_type%nmon_nyear(istart:iend,jstart:jend,:,i)

end select

found = .false.
do j = 1,size(climo_diag_name(:))
  if (climo_diag_name(j) .eq. clim_type%field_name(i)) then
    found = .true.
    exit
  endif
enddo

if (found) then
  if (hinterp_id(j) > 0 ) then
       result = send_data(hinterp_id(j),hinterp_data,Time)
  endif
endif

  interp_data(:,:) = hinterp_data(:,:,1)

  endif !field_name
enddo !End of i loop

if( .not. found_field) then !field name is not in interpolator file.ERROR.
  call mpp_error(FATAL,"Interpolator: the field name is not contained in this &
                   &intepolate_type: "//trim(field_name))
endif
end subroutine interpolator_2D
!--lwh
!
!#######################################################################

subroutine interpolator_4D_no_time_axis(clim_type, phalf, interp_data, field_name, is,js, clim_units)

! Return 4-D field interpolated to model grid

! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init

! INTENT IN
!   field_name  : The name of a field that you wish to interpolate.
!                 all variables within this interpolate_type variable
!                 will be interpolated on this call. field_name may
!                 be any one of the variables.
!   phalf       : The half level model pressure field.
!   is, js      : The indices of the physics window.

! INTENT OUT
!   interp_data : The model fields
!   clim_units  : The units of field_name

type(interpolate_type), intent(inout)  :: clim_type
character(len=*)      , intent(in)  :: field_name
real, dimension(:,:,:), intent(in)  :: phalf
real, dimension(:,:,:,:), intent(out) :: interp_data
integer               , intent(in) , optional :: is,js
character(len=*)      , intent(out), optional :: clim_units
integer :: ilon
real :: hinterp_data(size(interp_data,1),size(interp_data,2),size(clim_type%levs(:)),size(clim_type%field_name(:)))
real :: p_fact(size(interp_data,1),size(interp_data,2))
real :: pclim(size(clim_type%halflevs(:)))
integer :: istart,iend,jstart,jend
logical :: result
logical :: found_field=.false.
integer :: i, j, k, n

if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "interpolator_4D_no_time_axis : You must call interpolator_init before calling interpolator")

do n=2,size(clim_type%field_name(:))
  if (clim_type%vert_interp(n) /= clim_type%vert_interp(n-1) .or. &
   clim_type%out_of_bounds(n) /= clim_type%out_of_bounds(n-1)) then
    if (mpp_pe() == mpp_root_pe() ) then
      print *, 'processing file ' // trim(clim_type%file_name)
    endif
    call mpp_error (FATAL, 'interpolator_mod: &
            &cannot use 4D interface to interpolator for this file')
  endif
end do

istart = 1
if (present(is)) istart = is
iend = istart - 1 + size(interp_data,1)

jstart = 1
if (present(js)) jstart = js
jend = jstart - 1 + size(interp_data,2)

do i= 1,size(clim_type%field_name(:))
  if ( field_name == clim_type%field_name(i) ) then
    found_field=.true.
    exit 
  endif
end do
i = 1

if(present(clim_units)) then
  call mpp_get_atts(clim_type%field_type(i),units=clim_units)
  clim_units = chomp(clim_units)
endif

do n=1, size(clim_type%field_name(:))
  hinterp_data(:,:,:,n) = clim_type%data(istart:iend,jstart:jend,:,1,n)
end do
    
select case(clim_type%level_type)
  case(PRESSURE)
    p_fact = 1.0
  case(SIGMA)
    p_fact = maxval(phalf,3)! max pressure in the column !(:,:,size(phalf,3))
end select

    do i= 1, size(clim_type%field_name(:))
      select case(clim_type%mr(i))
      case(KG_M2)
        do k = 1,size(hinterp_data,3)
          hinterp_data(:,:,k,i) = hinterp_data(:,:,k,i)/((clim_type%halflevs(k+1)-clim_type%halflevs(k))*p_fact)
        enddo
      end select
    enddo

   i = 1

do j = 1, size(phalf,2)
   do ilon=1,size(phalf,1)
      pclim = p_fact(ilon,j)*clim_type%halflevs
      if ( maxval(phalf(ilon,j,:)) > maxval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model surface pressure&
                             & is greater than surface pressure of input data for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( maxloc(pclim) ) = maxval( phalf(ilon,j,:) )
         end select
      endif
      if ( minval(phalf(ilon,j,:)) < minval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model top pressure&
                             & is less than top pressure of input data for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( minloc(pclim) ) = minval( phalf(ilon,j,:) )
         end select
      endif
      select case(clim_type%vert_interp(i))
         case(INTERP_WEIGHTED_P)
            call interp_weighted_scalar(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:,:),interp_data(ilon,j,:,:))
         case(INTERP_LINEAR_P)
          do n=1, size(clim_type%field_name(:))
            call interp_linear(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:,n),interp_data(ilon,j,:,n))
          end do
      end select
   enddo
enddo

     do i= 1, size(clim_type%field_name(:))

select case(clim_type%mr(i))
  case(KG_M2)
    do k = 1,size(interp_data,3)
       interp_data(:,:,k,i) = interp_data(:,:,k,i)*(phalf(:,:,k+1)-phalf(:,:,k))
    enddo
end select

     end do

if( .not. found_field) then !field name is not in interpolator file.ERROR.
  call mpp_error(FATAL,"Interpolator: the field name is not contained in this &
                   &intepolate_type: "//trim(field_name))
endif
end subroutine interpolator_4D_no_time_axis

!#######################################################################

subroutine interpolator_3D_no_time_axis(clim_type, phalf, interp_data, field_name, is,js, clim_units)

! Return 3-D field interpolated to model grid

! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init

! INTENT IN
!   field_name  : The name of the field that you wish to interpolate.
!   phalf       : The half level model pressure field.
!   is, js      : The indices of the physics window.

! INTENT OUT
!   interp_data : The model field with the interpolated climatology data.
!   clim_units  : The units of field_name

type(interpolate_type), intent(inout)  :: clim_type
character(len=*)      , intent(in)  :: field_name
real, dimension(:,:,:), intent(in)  :: phalf
real, dimension(:,:,:), intent(out) :: interp_data
integer               , intent(in) , optional :: is,js
character(len=*)      , intent(out), optional :: clim_units
real :: tweight, tweight1, tweight2, tweight3
integer :: taum, taup, ilon
real :: hinterp_data(size(interp_data,1),size(interp_data,2),size(clim_type%levs(:)))
real :: p_fact(size(interp_data,1),size(interp_data,2))
real :: pclim(size(clim_type%halflevs(:)))
integer :: istart,iend,jstart,jend
logical :: result
logical :: found_field=.false.
integer :: i, j, k, n

if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "interpolator_3D_no_time_axis : You must call interpolator_init before calling interpolator")

istart = 1
if (present(is)) istart = is
iend = istart - 1 + size(interp_data,1)

jstart = 1
if (present(js)) jstart = js
jend = jstart - 1 + size(interp_data,2)

do i= 1,size(clim_type%field_name(:))
  if ( field_name == clim_type%field_name(i) ) then
    found_field=.true.
    if(present(clim_units)) then
      call mpp_get_atts(clim_type%field_type(i),units=clim_units)
      clim_units = chomp(clim_units)
    endif

    hinterp_data = clim_type%data(istart:iend,jstart:jend,:,1,i)

select case(clim_type%level_type)
  case(PRESSURE)
    p_fact = 1.0
  case(SIGMA)
    p_fact = maxval(phalf,3)! max pressure in the column !(:,:,size(phalf,3))
end select

select case(clim_type%mr(i))
  case(KG_M2)
    do k = 1,size(hinterp_data,3)
       hinterp_data(:,:,k) = hinterp_data(:,:,k)/((clim_type%halflevs(k+1)-clim_type%halflevs(k))*p_fact)
    enddo
end select

do j = 1, size(phalf,2)
   do ilon=1,size(phalf,1)
      pclim = p_fact(ilon,j)*clim_type%halflevs
      if ( maxval(phalf(ilon,j,:)) > maxval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model surface pressure&
                             & is greater than climatology surface pressure for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( maxloc(pclim) ) = maxval( phalf(ilon,j,:) )
         end select
      endif
      if ( minval(phalf(ilon,j,:)) < minval(pclim) ) then
         if (verbose > 3) then
         call mpp_error(NOTE,"Interpolator: model top pressure&
                             & is less than climatology top pressure for "&
                             // trim(clim_type%file_name))
         endif
         select case(clim_type%out_of_bounds(i))
            case(CONSTANT)
               pclim( minloc(pclim) ) = minval( phalf(ilon,j,:) )
         end select
      endif
      select case(clim_type%vert_interp(i))
         case(INTERP_WEIGHTED_P)
            call interp_weighted_scalar(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:),interp_data(ilon,j,:))
         case(INTERP_LINEAR_P)
            call interp_linear(pclim, phalf(ilon,j,:),hinterp_data(ilon,j,:),interp_data(ilon,j,:))
      end select
   enddo
enddo

select case(clim_type%mr(i))
  case(KG_M2)
    do k = 1,size(interp_data,3)
       interp_data(:,:,k) = interp_data(:,:,k)*(phalf(:,:,k+1)-phalf(:,:,k))
    enddo
end select

  endif !field_name
enddo !End of i loop
if( .not. found_field) then !field name is not in interpolator file.ERROR.
  call mpp_error(FATAL,"Interpolator: the field name is not contained in this &
                   &intepolate_type: "//trim(field_name))
endif
end subroutine interpolator_3D_no_time_axis

!#######################################################################

subroutine interpolator_2D_no_time_axis(clim_type, interp_data, field_name, is, js, clim_units)

! Return 2-D field interpolated to model grid

! INTENT INOUT
!   clim_type   : The interpolate type previously defined by a call to interpolator_init

! INTENT IN
!   field_name  : The name of the field that you wish to interpolate.
!   is, js      : The indices of the physics window.

! INTENT OUT
!   interp_data : The model field with the interpolated climatology data.
!   clim_units  : The units of field_name

type(interpolate_type), intent(inout)  :: clim_type
character(len=*)      , intent(in)     :: field_name
real, dimension(:,:),   intent(out)    :: interp_data
integer               , intent(in) , optional :: is,js
character(len=*)      , intent(out), optional :: clim_units
real :: tweight, tweight1, tweight2, tweight3
integer :: taum, taup, ilon
real :: hinterp_data(size(interp_data,1),size(interp_data,2),size(clim_type%levs(:)))
real :: p_fact(size(interp_data,1),size(interp_data,2))
integer :: istart,iend,jstart,jend
logical :: result
logical :: found_field=.false.
integer :: j, k, i, n

if (.not. module_is_initialized .or. .not. associated(clim_type%lon)) &
   call mpp_error(FATAL, "interpolator_2D_no_time_axis : You must call interpolator_init before calling interpolator")

istart = 1
if (present(is)) istart = is
iend = istart - 1 + size(interp_data,1)

jstart = 1
if (present(js)) jstart = js
jend = jstart - 1 + size(interp_data,2)

do i= 1,size(clim_type%field_name(:))
  if ( field_name == clim_type%field_name(i) ) then

    found_field=.true.

    if(present(clim_units)) then
      call mpp_get_atts(clim_type%field_type(i),units=clim_units)
      clim_units = chomp(clim_units)
    endif

    hinterp_data = clim_type%data(istart:iend,jstart:jend,:,1,i)

    interp_data(:,:) = hinterp_data(:,:,1)

  endif !field_name
enddo !End of i loop

if( .not. found_field) then !field name is not in interpolator file.ERROR.
  call mpp_error(FATAL,"Interpolator: the field name is not contained in this &
                   &intepolate_type: "//trim(field_name))
endif

end subroutine interpolator_2D_no_time_axis

!#######################################################################
!
subroutine interpolator_end(clim_type)
! Subroutine to deallocate the interpolate type clim_type.
!
! INTENT INOUT
!  clim_type : allocate type whose components will be deallocated.
!
type(interpolate_type), intent(inout) :: clim_type
integer :: logunit

logunit=stdlog()
if ( mpp_pe() == mpp_root_pe() ) then
   write (logunit,'(/,(a))') 'Exiting interpolator, have a nice day ...'
end if

if (associated (clim_type%lat     )) deallocate(clim_type%lat)
if (associated (clim_type%lon     )) deallocate(clim_type%lon)
if (associated (clim_type%latb    )) deallocate(clim_type%latb)
if (associated (clim_type%lonb    )) deallocate(clim_type%lonb)
if (associated (clim_type%levs    )) deallocate(clim_type%levs)
if (associated (clim_type%halflevs)) deallocate(clim_type%halflevs) 
call horiz_interp_del(clim_type%interph)
if (associated (clim_type%time_slice)) deallocate(clim_type%time_slice)
if (associated (clim_type%field_type)) deallocate(clim_type%field_type)
if (associated (clim_type%field_name)) deallocate(clim_type%field_name)
if (associated (clim_type%time_init )) deallocate(clim_type%time_init)
if (associated (clim_type%mr        )) deallocate(clim_type%mr)
if (associated (clim_type%data)) then
  deallocate(clim_type%data)
endif
if (associated (clim_type%pmon_pyear)) then
  deallocate(clim_type%pmon_pyear)
  deallocate(clim_type%pmon_nyear)
  deallocate(clim_type%nmon_nyear)
  deallocate(clim_type%nmon_pyear)
endif

!! RSH mod   
if(  .not. (clim_type%TIME_FLAG .eq. LINEAR  .and.    &
!     read_all_on_init)) .or. clim_type%TIME_FLAG .eq. BILINEAR  ) then
      read_all_on_init)  ) then
 call mpp_close(clim_type%unit)
endif


module_is_initialized = .false.

end subroutine interpolator_end
!
!#######################################################################
!
subroutine read_data(clim_type,src_field, hdata, nt,i, Time)
!
!  INTENT IN
!    clim_type : The interpolate type which contains the data 
!    src_field : The field type 
!    nt        : The index of the time slice of the climatology that you wish to read.
!    i         : The index of the field name that you are trying to read. (optional)
!    Time      : The model time. Used for diagnostic purposes only. (optional)
!
!  INTENT OUT
!
!    hdata     : The horizontally interpolated climatology field. This 
!                field will still be on the climatology vertical grid.
!
type(interpolate_type)   , intent(in)  :: clim_type
type(fieldtype)          , intent(in)  :: src_field
integer                  , intent(in)  :: nt
real                     , intent(out) :: hdata(:,:,:)
integer        , optional, intent(in)  :: i
type(time_type), optional, intent(in)  :: Time

integer   :: k, km
! sjs
real, allocatable :: climdata(:,:,:), climdata2(:,:,:)

      allocate(climdata(size(clim_type%lon(:)),size(clim_type%lat(:)), &
                        size(clim_type%levs(:))))

      call mpp_read(clim_type%unit,src_field, climdata,nt)

!  if vertical index increases upward, flip the data so that lowest
!  pressure level data is at index 1, rather than the highest pressure
!  level data. the indices themselves were previously flipped.
      if (clim_type%vertical_indices == INCREASING_UPWARD) then
        allocate(climdata2(size(clim_type%lon(:)),   &
                           size(clim_type%lat(:)), &
                           size(clim_type%levs(:))))
        km = size(clim_type%levs(:))
        do k=1, km                      
          climdata2(:,:,k) = climdata(:,:,km+1-k)
        end do
        climdata = climdata2
        deallocate (climdata2)
      endif

      call horiz_interp(clim_type%interph, climdata, hdata)
      if (clim_diag_initialized) &
        call diag_read_data(clim_type,climdata,i, Time)
      deallocate(climdata)


end subroutine read_data

!#######################################################################

subroutine read_data_no_time_axis(clim_type,src_field, hdata, i)

!  INTENT IN
!    clim_type : The interpolate type which contains the data 
!    src_field : The field type 
!    i         : The index of the field name that you are trying to read. (optional)

!  INTENT OUT

!    hdata     : The horizontally interpolated climatology field. This 
!                field will still be on the climatology vertical grid.

type(interpolate_type)   , intent(in)  :: clim_type
type(fieldtype)          , intent(in)  :: src_field
real                     , intent(out) :: hdata(:,:,:)
integer        , optional, intent(in)  :: i

integer   :: k, km
! sjs
real, allocatable :: climdata(:,:,:), climdata2(:,:,:)

      allocate(climdata(size(clim_type%lon(:)),size(clim_type%lat(:)), size(clim_type%levs(:))))

      call mpp_read(clim_type%unit,src_field, climdata)

!  if vertical index increases upward, flip the data so that lowest
!  pressure level data is at index 1, rather than the highest pressure
!  level data. the indices themselves were previously flipped.
      if (clim_type%vertical_indices == INCREASING_UPWARD) then
        allocate(climdata2(size(clim_type%lon(:)),   &
                           size(clim_type%lat(:)), &
                           size(clim_type%levs(:))))
        km = size(clim_type%levs(:))
        do k=1, km                      
          climdata2(:,:,k) = climdata(:,:,km+1-k)
        end do
        climdata = climdata2
        deallocate (climdata2)
      endif

      call horiz_interp(clim_type%interph, climdata, hdata)
      deallocate(climdata)

end subroutine read_data_no_time_axis

!#######################################################################
!
subroutine diag_read_data(clim_type,model_data, i, Time)
!
! A routine to diagnose the data read in by read_data
!
!  INTENT IN
!    clim_type  : The interpolate type.
!    model_data : The data read in from file that is being diagnosed.
!    i          : The index of the field name that you are diagnosing.
!    Time       : The model time
!
type(interpolate_type), intent(in) :: clim_type
real                  , intent(in) :: model_data(:,:,:)
integer               , intent(in) :: i
type(time_type)       , intent(in) :: Time

integer :: j,k
real :: col_data(size(model_data,1),size(model_data,2))
logical :: result, found


found = .false.
do j = 1,size(climo_diag_name(:))
  if (climo_diag_name(j) .eq. clim_type%field_name(i)) then
      found = .true.
      exit
  endif
enddo

if(found) then
  if(climo_diag_id(j)>0) then
  col_data(:,:)=0.0
    do k=1,size(model_data,3)
      col_data(:,:) = col_data(:,:) + &
        model_data(:,:,k)* &
        (clim_type%halflevs(k+1)-clim_type%halflevs(k))/grav
    enddo
    result = send_data(climo_diag_id(j),col_data(clim_type%is:clim_type%ie,clim_type%js:clim_type%je),Time)
  endif
endif

end subroutine diag_read_data
!
!#######################################################################
!
!++lwh
subroutine query_interpolator( clim_type, nfields, field_names )
!
! Query an interpolate_type variable to find the number of fields and field names. 
!
type(interpolate_type), intent(in)                    :: clim_type
integer, intent(out), optional                        :: nfields
character(len=*), dimension(:), intent(out), optional :: field_names

if( present( nfields ) )     nfields     = SIZE( clim_type%field_name(:) )
if( present( field_names ) ) field_names = clim_type%field_name

end subroutine query_interpolator
!--lwh
!
!#######################################################################
!
function chomp(string)
!
! A function to remove CHAR(0) from the end of strings read from NetCDF files.
!
character(len=*), intent(in) :: string
character(len=64) :: chomp

integer :: len

len = len_trim(string)
if (string(len:len) == CHAR(0)) len = len -1

chomp = string(:len)

end function chomp
!
!#################################################################
!
 subroutine interp_weighted_scalar_2D (grdin, grdout, datin, datout )
real, intent(in),  dimension(:) :: grdin, grdout
real, intent(in),  dimension(:,:) :: datin
real, intent(out), dimension(:,:) :: datout

integer :: j, k, n

if (size(grdin(:)).ne. (size(datin,1)+1)) &
 call mpp_error(FATAL,'interp_weighted_scalar : input data and pressure do not have the same number of levels')
if (size(grdout(:)).ne. (size(datout,1 )+1)) &
 call mpp_error(FATAL,'interp_weighted_scalar : output data and pressure do not have the same number of levels')

  do k = 1, size(datout,1 )
   datout(k,:) = 0.0

     do j = 1, size(datin,1 )

        if ( grdin(j)   <= grdout(k) .and. &
             grdin(j+1) >= grdout(k) .and. &
             grdin(j+1) <= grdout(k+1) ) then

          do n= 1, size(datin,2)
           datout(k,n) = datout(k,n) + datin(j,n)*(grdin(j+1)-grdout(k))
          end do

        else if ( grdin(j)   >= grdout(k)   .and. &
                  grdin(j)   <= grdout(k+1) .and. &
                  grdin(j+1) >= grdout(k+1) ) then

          do n= 1, size(datin,2)
           datout(k,n) = datout(k,n) + datin(j,n)*(grdout(k+1)-grdin(j))
          end do

        else if ( grdin(j)   >= grdout(k)   .and. &
                  grdin(j+1) <= grdout(k+1) ) then

          do n= 1, size(datin,2)
           datout(k,n) = datout(k,n) + datin(j,n)*(grdin(j+1)-grdin(j))
          end do

        else if ( grdin(j)   <= grdout(k)   .and. &
                  grdin(j+1) >= grdout(k+1) ) then

          do n= 1, size(datin,2)
          datout(k,n) = datout(k,n) + datin(j,n)*(grdout(k+1)-grdout(k))

          end do
        endif

     enddo

     do n= 1, size(datin,2)
       datout(k,n) = datout(k,n)/(grdout(k+1)-grdout(k))
     end do

  enddo

end subroutine interp_weighted_scalar_2D


!---------------------------------------------------------------------
 
 subroutine interp_weighted_scalar_1D (grdin, grdout, datin, datout )
real, intent(in),  dimension(:) :: grdin, grdout, datin
real, intent(out), dimension(:) :: datout

integer :: j, k

if (size(grdin(:)).ne. (size(datin(:))+1)) &
 call mpp_error(FATAL,'interp_weighted_scalar : input data and pressure do not have the same number of levels')
if (size(grdout(:)).ne. (size(datout(:))+1)) &
 call  mpp_error(FATAL,'interp_weighted_scalar : output data and pressure do not have the same number of levels')

  do k = 1, size(datout(:))
   datout(k) = 0.0

     do j = 1, size(datin(:))

        if ( grdin(j)   <= grdout(k) .and. &
             grdin(j+1) >= grdout(k) .and. &
             grdin(j+1) <= grdout(k+1) ) then

           datout(k) = datout(k) + datin(j)*(grdin(j+1)-grdout(k))

        else if ( grdin(j)   >= grdout(k)   .and. &
                  grdin(j)   <= grdout(k+1) .and. &
                  grdin(j+1) >= grdout(k+1) ) then

           datout(k) = datout(k) + datin(j)*(grdout(k+1)-grdin(j))

        else if ( grdin(j)   >= grdout(k)   .and. &
                  grdin(j+1) <= grdout(k+1) ) then

           datout(k) = datout(k) + datin(j)*(grdin(j+1)-grdin(j))

        else if ( grdin(j)   <= grdout(k)   .and. &
                  grdin(j+1) >= grdout(k+1) ) then

           datout(k) = datout(k) + datin(j)*(grdout(k+1)-grdout(k))

        endif

     enddo

     datout(k) = datout(k)/(grdout(k+1)-grdout(k))

  enddo

end subroutine interp_weighted_scalar_1D
!
!#################################################################
!
subroutine interp_linear ( grdin, grdout, datin, datout )
real, intent(in),  dimension(:) :: grdin, grdout, datin
real, intent(out), dimension(:) :: datout

integer :: j, k, n
real    :: wt


if (size(grdin(:)).ne. (size(datin(:))+1)) &
 call mpp_error(FATAL,'interp_linear : input data and pressure do not have the same number of levels')
if (size(grdout(:)).ne. (size(datout(:))+1)) &
 call mpp_error(FATAL,'interp_linear : output data and pressure do not have the same number of levels')


  n = size(grdin(:))

  do k= 1, size(datout(:))

   ! ascending grid values
     if (grdin(1) < grdin(n)) then
         do j = 2, size(grdin(:))-1
           if (grdout(k) <= grdin(j)) exit
         enddo
   ! descending grid values
     else
         do j = size(grdin(:)), 3, -1
           if (grdout(k) <= grdin(j-1)) exit
         enddo
     endif

   ! linear interpolation
     wt = (grdout(k)-grdin(j-1)) / (grdin(j)-grdin(j-1))
!print '(a,2i3,4f6.1)', 'k,j=',k,j,grdout(k),grdin(j-1),grdin(j),wt
   ! constant value extrapolation
   ! wt = min(max(wt,0.),1.)

     datout(k) = (1.-wt)*datin(j-1) + wt*datin(j)
     
  enddo

end subroutine interp_linear
!
!########################################################################

end module interpolator_mod
!
!#######################################################################
!
#ifdef test_interp
program test

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#endif

use mpp_mod
use mpp_io_mod
use mpp_domains_mod
use fms_mod
use time_manager_mod
use diag_manager_mod!, only : diag_axis_init, file_exist, MPP_NPES, &
                    !  MPP_PE, REGISTER_DIAG_FIELD, SEND_DATA, SET_DATE,&
                    !  SET_TIME

use interpolator_mod
!use sulfate_mod
!use ozone_mod
use constants_mod, only : grav, constants_init, PI
use time_interp_mod, only : time_interp_init

implicit none
integer, parameter :: nsteps_per_day = 8, ndays = 16
real, parameter :: delt = 1.0/nsteps_per_day
! integer, parameter :: nxd = 144, nyd = 90, ntsteps = 240, two_delt = 2*delt
integer, parameter :: nxd = 20, nyd = 40, ntsteps = nsteps_per_day*ndays, two_delt = 2*delt
integer :: delt_days, delt_secs
integer, parameter :: max_fields = 20 ! maximum number of fields to be interpolated

integer :: i,k,n,level
integer :: unit, io_status
integer :: ndivs
integer :: jscomp, jecomp, iscomp, iecomp, isd,ied,jsd,jed
integer :: numfields, domain_layout(2)
integer :: num_nbrs, nbins,axes(3), interp_diagnostic_id
integer :: column_diagnostic_id1, column_diagnostic_id(max_fields)

real ::  missing_value = -1.e10

character(len=1) :: dest_grid
character(len=128) :: src_file, file_out, title, units, colaer
logical :: vector_field=.false., result

type(axistype), allocatable, dimension(:)  :: axes_out, axes_src
type(axistype) :: time_axis
type(fieldtype), allocatable, dimension(:) :: fields
type(fieldtype) :: dest_field(max_fields), src_field(max_fields), field_geolon_t, &
     field_geolat_t, field_geolon_c, field_geolat_c
type(atttype), allocatable, dimension(:) :: global_atts
type(domain2d) :: domain
type(time_type) :: model_time

type(interpolate_type) :: o3, aerosol

real, dimension(:,:), allocatable :: col_data
real, dimension(:,:,:), allocatable :: model_data, p_half, p_full
real, dimension(:), allocatable :: latb_mod(:,:),lonb_mod(:,:),lon_mod(:),lat_mod(:)
real :: dx,dy
real :: dtr,tpi
real :: p_bot,p_top,lambda
character(len=64) :: names(13)
data names(:) /"so4_anthro","so4_natural","organic_carbon","black_carbon","sea_salt",&
"anthro_dust_0.2","anthro_dust_0.8","anthro_dust_2.0","anthro_dust_8.0",&
"natural_dust_0.2","natural_dust_0.8","natural_dust_2.0","natural_dust_8.0"/

integer :: out_of_bounds(1)
data out_of_bounds / CONSTANT/!, CONSTANT/!, CONSTANT, CONSTANT, CONSTANT, CONSTANT, CONSTANT, CONSTANT, CONSTANT, &
!ZERO, ZERO, ZERO, ZERO /

namelist /interpolator_nml/ src_file

! initialize communication modules

delt_days = INT(delt)
delt_secs = INT(delt*86400.0) - delt_days*86400.0

write(*,*) delt, delt_days,delt_secs

call mpp_init
call mpp_io_init
call mpp_domains_init
call set_calendar_type(JULIAN)
call diag_manager_init
call constants_init
call time_interp_init

level = 18
tpi = 2.0*PI !4.*acos(0.)
dtr = tpi/360.

src_file = 'src_file'  ! input file containing fields to be interpolated


model_time = set_date(1979,12,1,0,0,0)

!if (numfields.ne.2.and.vector_field) call mpp_error(FATAL,'2 components of vector field not specified')
!if (numfields.gt.1.and..not.vector_field) call mpp_error(FATAL,'only 1 scalar at a time')
!if (numfields .gt. max_fields) call mpp_error(FATAL,'max num fields exceeded')

!--------------------------------------------------------------------
! namelist input
!--------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=interpolator_nml, iostat=io)
  ierr = check_nml_error(io, 'interpolator_nml')
#else
  call mpp_open(unit, 'input.nml',  action=MPP_RDONLY, form=MPP_ASCII)
  read  (unit, interpolator_nml,iostat=io_status)
  if (io_status .gt. 0) then
    call mpp_error(FATAL,'=>Error reading interpolator_nml')
  endif
call mpp_close(unit)
#endif

! decompose model grid points
! mapping can get expensive so we distribute the task at this level

ndivs = mpp_npes()

call mpp_define_layout ((/1,nxd,1,nyd/), ndivs, domain_layout)
call mpp_define_domains((/1,nxd,1,nyd/),domain_layout, domain,xhalo=0,yhalo=0)  
call mpp_get_data_domain(domain,isd,ied,jsd,jed)
call mpp_get_compute_domain (domain, iscomp, iecomp, jscomp, jecomp)

allocate(lonb_mod(nxd+1,nyd+1),lon_mod(nxd))
allocate(latb_mod(nxd+1,nyd+1),lat_mod(nyd))
allocate(col_data(isd:ied,jsd:jed)) ; col_data = 0.0
allocate(p_half(isd:ied,jsd:jed,level+1),p_full(isd:ied,jsd:jed,level))
p_top = 1.0
p_bot = 101325.0 !Model level in Pa
lambda = -1.0*log(p_top/p_bot)/(level+1)

p_half(:,:,level+1) = p_bot
do i=level,1,-1
  p_half(:,:,i)=p_half(:,:,i+1)*exp(-1.0*lambda)
enddo
do i=1,level
  p_full(:,:,i)=(p_half(:,:,i+1)+p_half(:,:,i))/2.0
enddo

allocate(model_data(isd:ied,jsd:jed,level))

dx = 360./nxd
dy = 180./nyd
do i = 1,nxd+1
  lonb_mod(i,:) = (i-1)*dx 
enddo
do i = 1,nyd+1
  latb_mod(:,i) = -90. + (i-1)*dy 
enddo
do i=1,nxd
  lon_mod(i)=(lonb_mod(i+1,1)+lonb_mod(i,1))/2.0
enddo
do i=1,nyd
  lat_mod(i)=(latb_mod(1,i+1)+latb_mod(1,i))/2.0
enddo

lonb_mod = lonb_mod * dtr
latb_mod = latb_mod * dtr

   axes(1) = diag_axis_init('x',lon_mod,units='degrees',cart_name='x',domain2=domain)
   axes(2) = diag_axis_init('y',lat_mod,units='degrees',cart_name='y',domain2=domain)
   axes(3) = diag_axis_init('z',p_full(isd,jsd,:),units='mb',cart_name='z')

interp_diagnostic_id =  register_diag_field('interp','ozone',axes(1:3),model_time,&
                                'interpolated_ozone_clim', 'kg/kg', missing_value)      
column_diagnostic_id1 =  register_diag_field('interp','colozone',axes(1:2),model_time,&
                                'column_ozone_clim', 'kg/m2', missing_value)      

do i=1,size(names(:))
colaer = 'col'//trim(names(i))
column_diagnostic_id(i) =  register_diag_field('interp',colaer,axes(1:2),model_time,&
                                'column_aerosol_clim', 'kg/m2', missing_value)      
enddo


call ozone_init(o3,lonb_mod(isd:ied+1,jsd:jed+1), latb_mod(isd:ied+1,jsd:jed+1), axes, model_time, &
                data_out_of_bounds=out_of_bounds)
call init_clim_diag(o3, axes, model_time)
call sulfate_init(aerosol,lonb_mod(isd:ied+1,jsd:jed+1), latb_mod(isd:ied+1,jsd:jed+1), names, &
                data_out_of_bounds=(/CONSTANT/) )
call init_clim_diag(aerosol, axes, model_time)

do n=1,ntsteps
  if( mpp_pe() == mpp_root_pe() ) write(*,*) n

  call get_ozone(o3,model_time,p_half,model_data)

  if(interp_diagnostic_id>0) &
       result = send_data(interp_diagnostic_id,&
            model_data(iscomp:iecomp,jscomp:jecomp,:),model_time)

  if(column_diagnostic_id1>0) then

    col_data(iscomp:iecomp,jscomp:jecomp)=0.0
    do k=1,level
       col_data(iscomp:iecomp,jscomp:jecomp)= col_data(iscomp:iecomp,jscomp:jecomp)+ &
          model_data(iscomp:iecomp,jscomp:jecomp,k)* &
          (p_half(iscomp:iecomp,jscomp:jecomp,k+1)-p_half(iscomp:iecomp,jscomp:jecomp,k))/grav
    enddo
       result = send_data(column_diagnostic_id1,col_data(:,:),model_time)
  endif



  do i=1,size(names(:))

call get_anthro_sulfate(aerosol,model_time,p_half,names(i),model_data,clim_units=units)

    if(column_diagnostic_id(i)>0) then

      col_data(iscomp:iecomp,jscomp:jecomp)=0.0
      do k=1,level
        if (trim(units) .eq. 'kg/m^2') then
           col_data(iscomp:iecomp,jscomp:jecomp)= col_data(iscomp:iecomp,jscomp:jecomp)+ &
              model_data(iscomp:iecomp,jscomp:jecomp,k)
        else
           col_data(iscomp:iecomp,jscomp:jecomp)= col_data(iscomp:iecomp,jscomp:jecomp)+ &
              model_data(iscomp:iecomp,jscomp:jecomp,k)* &
              (p_half(iscomp:iecomp,jscomp:jecomp,k+1)-p_half(iscomp:iecomp,jscomp:jecomp,k))/grav
        endif
      enddo
      result = send_data(column_diagnostic_id(i),&
      col_data(iscomp:iecomp,jscomp:jecomp),model_time)
    endif

  enddo

   model_time = model_time + set_time(delt_secs,delt_days)      

   if (n.eq. ntsteps) call diag_manager_end(model_time)

enddo

call interpolator_end(aerosol)
call interpolator_end(o3)

deallocate(lonb_mod, lon_mod, latb_mod,lat_mod, col_data, p_half, p_full, model_data)

call mpp_exit

contains
!
!#######################################################################
!
subroutine sulfate_init(aerosol,lonb, latb, names, data_out_of_bounds, vert_interp, units)
type(interpolate_type), intent(inout)         :: aerosol
real,                   intent(in)            :: lonb(:,:),latb(:,:)
character(len=64),      intent(in)            :: names(:)
integer,                intent(in)            :: data_out_of_bounds(:) 
integer,                intent(in), optional  :: vert_interp(:)
character(len=*),       intent(out),optional  :: units(:)

if (.not. file_exist("INPUT/aerosol.climatology.nc") ) return
call interpolator_init( aerosol, "aerosol.climatology.nc", lonb, latb, &
                        data_names=names, data_out_of_bounds=data_out_of_bounds, &
                        vert_interp=vert_interp, clim_units=units )

end subroutine sulfate_init
!
!#######################################################################
!
subroutine get_anthro_sulfate( sulfate, model_time, p_half, name, model_data, is, js, clim_units )
type(interpolate_type), intent(inout) :: sulfate
type(time_type), intent(in) :: model_time
real, intent(in)           :: p_half(:,:,:)
character(len=*), intent(in) :: name
character(len=*), intent(out), optional :: clim_units
real, intent(out) :: model_data(:,:,:)
integer, intent(in), optional :: is,js

call interpolator( sulfate, model_time, p_half, model_data, name, is, js, clim_units)

end subroutine get_anthro_sulfate
!
!#######################################################################
!
subroutine ozone_init( o3, lonb, latb, axes, model_time, data_out_of_bounds, vert_interp )
real,                  intent(in)           :: lonb(:,:),latb(:,:)
integer,               intent(in)           :: axes(:)
type(time_type),       intent(in)           :: model_time
type(interpolate_type),intent(inout)        :: o3
integer,               intent(in)           :: data_out_of_bounds(:)
integer,               intent(in), optional :: vert_interp(:)

if (.not. file_exist("INPUT/o3.climatology.nc") ) return
call interpolator_init( o3, "o3.climatology.nc", lonb, latb, &
                        data_out_of_bounds=data_out_of_bounds, vert_interp=vert_interp )

end subroutine ozone_init
!
!#######################################################################
!
subroutine get_ozone( o3, model_time, p_half, model_data, is, js )
type(interpolate_type),intent(inout) :: o3
type(time_type), intent(in) :: model_time
real, intent(in)           :: p_half(:,:,:)
real, intent(out) :: model_data(:,:,:)
integer, intent(in), optional :: is,js

call interpolator( o3, model_time, p_half, model_data, "ozone", is, js)

end subroutine get_ozone

end program test

#endif


module atmos_age_tracer_mod
! <CONTACT EMAIL="William.Cooke@noaa.gov">
!   William Cooke
! </CONTACT>

! <REVIEWER EMAIL="Larry.Horowitz@noaa.gov">
!   Larry Horowitz
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code implements an age-of-air tracer.
! </OVERVIEW>

! <DESCRIPTION>
!     This code implements an age-of-air tracer, based on that in
!     the stratospheric chemistry code.
! </DESCRIPTION>

!-----------------------------------------------------------------------

use              fms_mod, only : file_exist,           &
                                 field_exist,          &
                                 write_version_number, &
                                 mpp_pe,               &
                                 mpp_root_pe,          &
                                 lowercase,   &
                                 error_mesg,           &
                                 FATAL,WARNING, NOTE,  &
                                 stdlog
use     time_manager_mod, only : time_type
use     diag_manager_mod, only : send_data,            &
                                 register_static_field
use   tracer_manager_mod, only : get_tracer_index,     &
                                 query_method
use    field_manager_mod, only : MODEL_ATMOS,          &
                                 parse
use     interpolator_mod, only : interpolate_type,     &
                                 interpolator_init,    &
                                 interpolator_end,     &
                                 interpolator,         &
                                 CONSTANT,             &
                                 INTERP_WEIGHTED_P  



implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_age_tracer, atmos_age_tracer_init, atmos_age_tracer_end

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------
! namelist /atmos_age_tracer_nml/  


!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'

!--- identification numbers for  diagnostic fields and axes ----

integer :: id_emiss

logical :: module_is_initialized=.FALSE.
real, parameter :: trop_age_cutoff = 0.1, trop_age_sq = trop_age_cutoff**2
real, parameter :: sec_per_day = 86400., &
                   age_relax_time = 10., & ! timescale for relaxation to zero in trop (days)
                   k_relax = 1./(age_relax_time*sec_per_day), & ! (1/sec)
                   days_per_year = 365.25, &
                   k_aging = 1./(days_per_year*sec_per_day) ! increase age at 1 yr/yr (convert to yr/sec)

!---- version number -----
character(len=128) :: version = '$Id: atmos_age_tracer.F90,v 16.0.2.1.4.1.2.1.4.1 2010/03/17 20:27:11 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################
!<SUBROUTINE NAME="atmos_age_tracer">
!<OVERVIEW>
! The routine that calculate the sources and sinks of age tracer.
!</OVERVIEW>
!<DESCRIPTION>
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_age_tracer (lon, lat, pwt, age, age_dt, Time, kbot)
!</TEMPLATE>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     Longitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!     Latitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     The pressure weighting array. = dP/grav
!   </IN>
!   <IN NAME="age" TYPE="real" DIM="(:,:,:)">
!     The array of the age tracer
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>

!   <OUT NAME="age_dt" TYPE="real" DIM="(:,:,:)">
!     The array of the tendency of the age tracer
!   </OUT>
 subroutine atmos_age_tracer (lon, lat, pwt, age, age_dt, Time, kbot)

!-----------------------------------------------------------------------
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:,:) :: pwt, age
   real, intent(out), dimension(:,:,:) :: age_dt
   type(time_type), intent(in)         :: Time     
   integer, intent(in),  dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
   real, dimension(size(age,1),size(age,2),size(age,3)) ::  &
         source, sink
   integer :: j,k,id,jd,kd
   real :: dagesq(size(age,1))
!-----------------------------------------------------------------------

!<ERROR MSG="tropchem_driver_init must be called first." STATUS="FATAL">
!   Tropchem_driver_init needs to be called before tracer_driver.
!</ERROR>
   if (.not. module_is_initialized)  &
      call error_mesg ('atmos_age_tracer','atmos_age_tracer_init must be called first.', FATAL)

   id=size(age,1); jd=size(age,2); kd=size(age,3)

!----------- compute age tracer source and sink------------
!
!  Increase at the rate of 1 per second outside the troposphere.
!  Results expressed in years. Relax towards zero with a 10 
!  day timescale in the troposphere, denoted by DAGESQ less than 0.01 
!
   sink = 0.
   source = 0.
   do k = 1,kd
   do j = 1,jd
      dagesq(:) = (age(:,j,k) - age(:,j,kd))**2

      where (dagesq(:) < trop_age_sq) 
           sink(:,j,k) = -age(:,j,k)*k_relax
      elsewhere
           source(:,j,k) = k_aging
      end where

   end do
   end do


!------- tendency ------------------

   age_dt=source+sink
      

!-----------------------------------------------------------------------

 end subroutine atmos_age_tracer
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_age_tracer_init">
!<OVERVIEW>
! The constructor routine for the age tracer module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to initialize the age tracer module.
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_age_tracer_init (r, axes, Time, nage, lonb_mod, latb_mod, phalf, mask)
!</TEMPLATE>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>
!   <IN NAME="lonb_mod" TYPE="real" DIM="(:,:)">
!     The longitude corners for the local domain.
!   </IN>
!   <IN NAME="latb_mod" TYPE="real" DIM="(:,:)">
!     The latitude corners for the local domain.
!   </IN>
!   <IN NAME="phalf" TYPE="real" DIM="(:,:,:)">
!     Pressure on the model half levels (Pa)
!   </IN>
 subroutine atmos_age_tracer_init( r, axes, Time, nage, &
                                   lonb_mod, latb_mod, phalf, mask)

!-----------------------------------------------------------------------
!
!   r    = tracer fields dimensioned as (nlon,nlat,nlev,ntrace)
!   mask = optional mask (0. or 1.) that designates which grid points
!          are above (=1.) or below (=0.) the ground dimensioned as
!          (nlon,nlat,nlev).
!
!-----------------------------------------------------------------------
real,             intent(inout), dimension(:,:,:,:) :: r
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
real,             intent(in),    dimension(:,:)     :: lonb_mod
real,             intent(in),    dimension(:,:)     :: latb_mod
real,             intent(in),    dimension(:,:,:)   :: phalf
integer,          intent(out)                       :: nage
real, intent(in), dimension(:,:,:), optional        :: mask

!
!-----------------------------------------------------------------------
!
      integer :: n
      integer :: flag_file, flag_spec
      character(len=64) :: control='', name='', filename='', specname=''
      type(interpolate_type) :: init_conc
      logical :: tracer_initialized

      if (module_is_initialized) return

!---- write namelist ------------------

      call write_version_number (version, tagname)
!     if ( mpp_pe() == mpp_root_pe() ) &
!       write ( stdlog(), nml=atmos_age_tracer_nml )
 
      nage = -1
      n = get_tracer_index(MODEL_ATMOS,'AGE' )
!     if (n>0) nage = n
      if (n>0) then
        nage = n

!-----------------------------------------------------------------------
!     ... Initial conditions
!-----------------------------------------------------------------------
      tracer_initialized = .false.
      if ( field_exist('INPUT/atmos_tracers.res.nc', 'age') .or. &
           field_exist('INPUT/fv_tracer.res.nc', 'age') .or. &
           field_exist('INPUT/tracer_age.res', 'age') ) then
         tracer_initialized = .true.
      end if
      if(.not. tracer_initialized) then
!     if((.not. tracer_initialized) .and. (nage /= -1)) then
         if( query_method('init_conc',MODEL_ATMOS,n,name,control) ) then
            if( trim(name) == 'file' ) then
               flag_file = parse(control, 'file',filename)
               flag_spec = parse(control, 'name',specname)

               if( flag_file>0 ) then
                  call interpolator_init( init_conc,trim(filename),lonb_mod,latb_mod,&
                                          data_out_of_bounds=(/CONSTANT/), &
                                          vert_interp=(/INTERP_WEIGHTED_P/) )
                  if( flag_spec > 0 ) then
                     specname = lowercase(specname)
                  else
                     specname = 'age'
                  end if
                  call interpolator(init_conc, Time, phalf,r(:,:,:,n),trim(specname))                  
               end if
            end if
         end if
      end if
    endif



      module_is_initialized = .TRUE.

!-----------------------------------------------------------------------

 end subroutine atmos_age_tracer_init
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_age_tracer_end">
!<OVERVIEW>
!  The destructor routine for the age tracer module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits. 
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_age_tracer_end
!</TEMPLATE>
 subroutine atmos_age_tracer_end
 
      module_is_initialized = .FALSE.

 end subroutine atmos_age_tracer_end
!</SUBROUTINE>


end module atmos_age_tracer_mod





Module atmos_carbon_aerosol_mod

! <CONTACT EMAIL="Shekar.Reddy@noaa.gov">
!   Shekar Reddy
! </CONTACT>
use mpp_mod, only: input_nml_file 
use fms_mod,                    only : file_exist, close_file, &
                                       write_version_number, &
                                       mpp_pe, mpp_root_pE, &
                                       open_namelist_file,  &
                                       check_nml_error, error_mesg,  &
                                       stdlog, FATAL, NOTE, WARNING
use time_manager_mod,           only : time_type, &
                                       days_in_month, days_in_year, &
                                       set_date, set_time, get_date_julian, &
                                       print_date, get_date, &
                                       operator(>), operator(+), operator(-)
use time_interp_mod,            only:  fraction_of_year, &
                                       time_interp_init
use diag_manager_mod,           only : send_data, register_diag_field, &
                                       diag_manager_init, get_base_time
use tracer_manager_mod,         only : get_tracer_index, &
                                       set_tracer_atts
use field_manager_mod,          only : MODEL_ATMOS
use atmos_tracer_utilities_mod, only : wet_deposition,       &
                                       dry_deposition
use interpolator_mod,           only:  interpolate_type, interpolator_init, &
                                       obtain_interpolator_time_slices,&
                                       unset_interpolator_time_flag, &
                                       interpolator, interpolator_end, &
                                       CONSTANT, INTERP_WEIGHTED_P
use constants_mod,              only : PI, GRAV, RDGAS
implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_carbon_aerosol_driver,   &
        atmos_carbon_aerosol_init, &
        atmos_carbon_aerosol_time_vary, &
        atmos_carbon_aerosol_endts, &
        atmos_carbon_aerosol_end

!-----------------------------------------------------------------------
! tracer number for carbonaceous aerosols
integer :: nbcphobic=0
integer :: nbcphilic=0
integer :: nomphobic=0
integer :: nomphilic=0

!--- identification numbers for  diagnostic fields and axes ----
integer :: id_bcphob_emis, id_bcphil_emis, id_omphob_emis, id_omphil_emis
integer :: id_om_emis_col, id_bc_emis_col
integer :: id_om_emis_colv2, id_bc_emis_colv2
integer :: id_bcphob_sink, id_omphob_sink
integer :: id_emisbb, id_omemisbb_col
integer :: id_bcemisbf, id_bcemisbb, id_bcemissh, id_bcemisff, id_bcemisav
integer :: id_omemisbf, id_omemisbb, id_omemissh, id_omemisff, id_omemisbg, id_omemisoc
!----------------------------------------------------------------------
!--- Interpolate_type variable containing all the information needed to
! interpolate the emission provided in the netcdf input file.
type(interpolate_type),save  ::bcff_aerosol_interp
type(interpolate_type),save  ::bcbb_aerosol_interp
type(interpolate_type),save  ::bcbf_aerosol_interp
type(interpolate_type),save  ::bcsh_aerosol_interp
type(interpolate_type),save  ::bcav_aerosol_interp
type(interpolate_type),save  ::omff_aerosol_interp
type(interpolate_type),save  ::ombb_aerosol_interp
type(interpolate_type),save  ::ombf_aerosol_interp
type(interpolate_type),save  ::omsh_aerosol_interp
type(interpolate_type),save  ::omna_aerosol_interp
type(interpolate_type),save  ::omss_aerosol_interp
! Initial calendar time for model
type(time_type) :: model_init_time

! Difference between model initial time and source timeseries applied
! at model initial time
type(time_type), save :: bcff_offset
type(time_type), save :: bcbb_offset
type(time_type), save :: bcbf_offset
type(time_type), save :: bcsh_offset
type(time_type), save :: bcav_offset
type(time_type), save :: omff_offset
type(time_type), save :: ombb_offset
type(time_type), save :: ombf_offset
type(time_type), save :: omsh_offset
type(time_type), save :: omna_offset
type(time_type), save :: omss_offset

! timeseries which is mapped to model initial time
type(time_type), save :: bcff_entry
type(time_type), save :: bcbb_entry
type(time_type), save :: bcbf_entry
type(time_type), save :: bcsh_entry
type(time_type), save :: bcav_entry
type(time_type), save :: omff_entry
type(time_type), save :: ombb_entry
type(time_type), save :: ombf_entry
type(time_type), save :: omsh_entry
type(time_type), save :: omna_entry
type(time_type), save :: omss_entry

! The model initial time is later than the XXX_dataset_entry time  ?
logical, save    :: bcff_negative_offset
logical, save    :: bcbb_negative_offset
logical, save    :: bcbf_negative_offset
logical, save    :: bcsh_negative_offset
logical, save    :: bcav_negative_offset
logical, save    :: omff_negative_offset
logical, save    :: ombb_negative_offset
logical, save    :: ombf_negative_offset
logical, save    :: omsh_negative_offset
logical, save    :: omna_negative_offset
logical, save    :: omss_negative_offset

integer, save    :: bcff_time_serie_type
integer, save    :: bcbb_time_serie_type
integer, save    :: bcbf_time_serie_type
integer, save    :: bcsh_time_serie_type
integer, save    :: bcav_time_serie_type
integer, save    :: omff_time_serie_type
integer, save    :: ombb_time_serie_type
integer, save    :: ombf_time_serie_type
integer, save    :: omsh_time_serie_type
integer, save    :: omna_time_serie_type
integer, save    :: omss_time_serie_type
!----------------------------------------------------------------------
!-------- namelist  ---------
character(len=80) :: bcff_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: bcbb_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: bcbf_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: bcsh_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: bcav_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: omff_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: ombb_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: ombf_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: omsh_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: omna_filename = 'carbon_aerosol_emission.nc'
character(len=80) :: omss_filename = 'gocart_emission.nc'

integer :: i
character(len=80), save, dimension(1) :: bcff_emission_name = (/' '/)
character(len=80), save, dimension(6) :: bcbb_emission_name = (/(' ',i=1,6)/)
character(len=80), save, dimension(1) :: bcbf_emission_name = (/' '/)
character(len=80), save, dimension(1) :: bcsh_emission_name = (/' '/)
character(len=80), save, dimension(1) :: bcav_emission_name = (/' '/)
character(len=80), save, dimension(1) :: omff_emission_name = (/' '/)
character(len=80), save, dimension(6) :: ombb_emission_name = (/(' ',i=1,6)/)
character(len=80), save, dimension(1) :: ombf_emission_name = (/' '/)
character(len=80), save, dimension(1) :: omsh_emission_name = (/' '/)
character(len=80), save, dimension(1) :: omna_emission_name = (/' '/)
character(len=80), save, dimension(1) :: omss_emission_name = (/' '/)

character(len=80), dimension(1) :: bcff_input_name = (/' '/)
character(len=80), dimension(6) :: bcbb_input_name = (/(' ',i=1,6)/)
character(len=80), dimension(1) :: bcbf_input_name = (/' '/)
character(len=80), dimension(1) :: bcsh_input_name = (/' '/)
character(len=80), dimension(1) :: bcav_input_name = (/' '/)
character(len=80), dimension(1) :: omff_input_name = (/' '/)
character(len=80), dimension(6) :: ombb_input_name = (/(' ',i=1,6)/)
character(len=80), dimension(1) :: ombf_input_name = (/' '/)
character(len=80), dimension(1) :: omsh_input_name = (/' '/)
character(len=80), dimension(1) :: omna_input_name = (/' '/)
character(len=80), dimension(1) :: omss_input_name = (/' '/)
! Default values for carbon_aerosol_nml
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! FOSSIL FUEL source can be either:
! for black carbon: 'cooke_and_wilson_1996' 
!                   'cooke_1999' 
!                   'bond_2004'
character(len=80)     :: bcff_source = ' '
character(len=80)     :: bcff_time_dependency_type = 'constant'
integer, dimension(6) :: bcff_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fossil fuel emission 
! for organic matter: 'cooke_1999' 
!                     'bond_2004'
character(len=80)     :: omff_source = ' '
character(len=80)     :: omff_time_dependency_type = 'constant'
integer, dimension(6) :: omff_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BIOMASS BURNING emissions can be either
! for black carbon: 'cooke_and_wilson_1996' 
!                   'bond_2004' 
!                   'GEIA level 1 and 2'
!                   'AEROCOM level 1 to 6'
character(len=80)     :: bcbb_source = ' '
character(len=80)     :: bcbb_time_dependency_type = 'constant'
integer, dimension(6) :: bcbb_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
! open biomass burning emission
! for organic matter: 'cooke_and_wilson_1996' 
!                     'bond_2004' 
!                     'GEIA level 1 and 2'
!                     'AEROCOM level 1 to 6'
character(len=80)     :: ombb_source = ' '
character(len=80)     :: ombb_time_dependency_type = 'constant'
integer, dimension(6) :: ombb_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! biofuel emission        
! for black carbon     'bond_2004' 
character(len=80)     :: bcbf_source = ' '
character(len=80)     :: bcbf_time_dependency_type = 'constant'
integer, dimension(6) :: bcbf_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ship emissions based on V. Eyrig
character(len=80)     :: bcsh_source = ' '
character(len=80)     :: bcsh_time_dependency_type
integer, dimension(6) :: bcsh_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! aircraft emissions based on Steven L. Baughcum
character(len=80)     :: bcav_source = ' '
character(len=80)     :: bcav_time_dependency_type = 'constant'
integer, dimension(6) :: bcav_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
! Emission index from Henricks et al., Simulating the global atmospheric
! black carbon cycle: a revisit to the contribution of aircraft emissions,
! Atmos. Chem. Phys., 4, 252102541, 2004.
real :: bc_aircraft_EI = 4.e-5   ! kg BC /kg fuel
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! biofuel emission for organic matter:  'bond_2004' 
character(len=80)     :: ombf_source = ' '
character(len=80)     :: ombf_time_dependency_type = 'constant'
integer, dimension(6) :: ombf_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ship emissions based on V. Eyrig
character(len=80)     :: omsh_source = ' '
character(len=80)     :: omsh_time_dependency_type = 'constant'
integer, dimension(6) :: omsh_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! for natural emssion: Gunther et al., 1996 inventory
character(len=80)     :: omna_source = ' '
character(len=80)     :: omna_time_dependency_type = 'constant'
integer, dimension(6) :: omna_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! for sea spray emssion: based on ODowd et al., A combined organic-inorganic sea-spray source function, Geophys. Res. Lett., v35, L01801, doi:10.1029/2007GL030331, 2008
character(len=80)     :: omss_source = ' '
character(len=80)     :: omss_time_dependency_type = 'constant'
integer, dimension(6) :: omss_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
real, save :: coef_omss_emis
real :: omss_coef=-999.
!!!!!!!!!!!!!!!!!!!!!!!!!!
namelist /carbon_aerosol_nml/ &
 bcff_source, bcff_input_name, bcff_filename, &
  bcff_time_dependency_type, bcff_dataset_entry, &
 bcbb_source, bcbb_input_name, bcbb_filename, &
  bcbb_time_dependency_type, bcbb_dataset_entry, &
 bcbf_source, bcbf_input_name, bcbf_filename, &
  bcbf_time_dependency_type, bcbf_dataset_entry, &
 bcsh_source, bcsh_input_name, bcsh_filename, &
  bcsh_time_dependency_type, bcsh_dataset_entry, &
 bcav_source, bcav_input_name, bcav_filename, &
  bcav_time_dependency_type, bcav_dataset_entry, bc_aircraft_EI, &
 omff_source, omff_input_name, omff_filename, &
  omff_time_dependency_type, omff_dataset_entry, &
 ombb_source, ombb_input_name, ombb_filename, &
  ombb_time_dependency_type, ombb_dataset_entry, &
 ombf_source, ombf_input_name, ombf_filename, &
  ombf_time_dependency_type, ombf_dataset_entry, &
 omsh_source, omsh_input_name, omsh_filename, &
  omsh_time_dependency_type, omsh_dataset_entry, &
 omna_source, omna_input_name, omna_filename, &
  omna_time_dependency_type, omna_dataset_entry, &
 omss_source, omss_input_name, omss_filename, &
  omss_time_dependency_type, omss_dataset_entry, omss_coef

character(len=6), parameter :: module_name = 'tracer'

logical :: module_is_initialized = .FALSE.
logical :: used

!---- version number -----
character(len=128) :: version = '$Id: atmos_carbon_aerosol.F90,v 17.0.2.1.2.1.6.1.2.1.6.1.2.2.2.2 2010/08/30 20:39:47 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

type(time_type)                        :: bcff_time
type(time_type)                        :: bcbb_time
type(time_type)                        :: bcbf_time
type(time_type)                        :: bcsh_time
type(time_type)                        :: bcav_time
type(time_type)                        :: omff_time
type(time_type)                        :: ombb_time
type(time_type)                        :: ombf_time
type(time_type)                        :: omsh_time
type(time_type)                        :: omna_time
type(time_type)                        :: omss_time



contains

!#######################################################################

subroutine atmos_carbon_aerosol_driver(lon, lat, land, pfull,phalf, &
                               z_half, z_pbl, &
                               t_surf, w10m, &
                               T, pwt, &
                               bcphob, bcphob_dt,  &
                               bcphil, bcphil_dt,  &
                               omphob, omphob_dt, &
                               omphil, omphil_dt, &
                               model_time, is, ie, js, je )

!-----------------------------------------------------------------------
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:)   :: land
   real, intent(in),  dimension(:,:)   :: z_pbl
   real, intent(in),  dimension(:,:,:) :: z_half
   real, intent(in),  dimension(:,:)   :: w10m, t_surf  ! ocean sea surface temperature and 10 meter wind speed
   real, intent(in),  dimension(:,:,:) :: pwt,pfull,phalf,T
   real, intent(in),  dimension(:,:,:) :: bcphob,bcphil
   real, intent(in),  dimension(:,:,:) :: omphob,omphil
   real, intent(out), dimension(:,:,:) :: bcphob_dt,bcphil_dt
   real, intent(out), dimension(:,:,:) :: omphob_dt,omphil_dt
type(time_type), intent(in)            :: model_time
integer, intent(in)                    :: is, ie, js, je
!-----------------------------------------------------------------------

real  dtr,bltop,z1,z2,del
real, dimension(size(bcphob,3)) :: fa1, fa2
real, dimension(size(bcphob,3),6) :: fbb
integer :: lf, nlevel_fire
real, dimension(6) :: alt_fire_min, alt_fire_max
! Lower altitude of injection from wild fires 
! These values correspond to the AEROCOM input data (cf. Dentener, ACP, 2006)
integer, parameter :: nlevel_fire_AEROCOM = 6
! Modified GEIA dataset proposed by Reddy and Boucher, J. Geophys. Res., 2004
integer, parameter :: nlevel_fire_GEIA    = 2
real, dimension(nlevel_fire_AEROCOM) :: &
      alt_fire_min_AEROCOM=(/0.,100.,500.,1000.,2000.,3000./)
real, dimension(nlevel_fire_GEIA) :: &
      alt_fire_min_GEIA=(/0.,300./)
! Upper altitude of injection from wild fires 
real, dimension(nlevel_fire_AEROCOM) :: &
      alt_fire_max_AEROCOM=(/100.,500.,1000.,2000.,3000.,6000./)
real, dimension(nlevel_fire_GEIA) :: &
      alt_fire_max_GEIA=(/300.,1500./)
real :: ze1 = 100.
real :: ze2 = 300.
integer        :: i, j,l, id,jd,kd,k
REAL,PARAMETER :: frac_bc_phobic = 0.8
REAL,PARAMETER :: frac_bc_philic = 0.2
REAL,PARAMETER :: frac_om_phobic = 0.5
REAL,PARAMETER :: frac_om_philic = 0.5
real  :: sst, Schm, SchmCO2, AKw

!
!-------------------------------------------------------------------------
real, dimension(size(bcphob,1),size(bcphob,2)) :: bcemisff_l1, bcemisff_l2
real, dimension(size(omphob,1),size(omphob,2)) :: omemisff_l1, omemisff_l2
real, dimension(size(bcphob,1),size(bcphob,2),6) :: bcemisbb
real, dimension(size(omphob,1),size(omphob,2),6) :: omemisbb

real,dimension(size(bcphob,1),size(bcphob,2)) ::  emisob, omemisob_2d
real,dimension(size(bcphob,1),size(bcphob,2),size(bcphob,3)) ::&
   bcphob_emis, bcphil_emis, bcphob_sink, bcemisob, bcemisff, bcemisav
real,dimension(size(omphob,1),size(omphob,2),size(omphob,3)) ::&
   omphob_emis, omphil_emis, omphob_sink, omemisob, omemisff
real, dimension(size(bcphob,1),size(bcphob,2)) ::          &
   bcemisbf, bcemissh
real, dimension(size(omphob,1),size(omphob,2)) ::          &
   omemisbf, omemissh, omemisbg, dmso, omemisocean
real,dimension(size(bcphob,1),size(bcphob,2)) :: bc_emis, om_emis
!
!-----------------------------------------------------------------------
!
      id=size(bcphob,1); jd=size(bcphob,2); kd=size(bcphob,3)

      dtr= PI/180.

!----------- compute black carbon source ------------

    bcphob_dt = 0.0
    bcphil_dt = 0.0
    omphob_dt = 0.0
    omphil_dt = 0.0
! emission rates (kg/m2/s)
    bcemisff_l1(:,:) = 0.0
    bcemisff_l2(:,:) = 0.0
    bcemisff(:,:,:)  = 0.0
    bcemisbb(:,:,:)  = 0.0
    bcemisob(:,:,:)  = 0.0
    emisob(:,:) = 0.
    omemisob_2d(:,:) = 0.
    bcemisbf(:,:)    = 0.0
    bcemissh(:,:)    = 0.0
    bcemisav(:,:,:)  = 0.0

    bcphob_emis(:,:,:) = 0.0
    bcphil_emis(:,:,:) = 0.0
    bcphob_sink(:,:,:) = 0.0
    omphob_emis(:,:,:) = 0.0
    omphil_emis(:,:,:) = 0.0
    omphob_sink(:,:,:) = 0.0

    omemisff_l1(:,:) = 0.0
    omemisff_l2(:,:) = 0.0
    omemisff(:,:,:)  = 0.0
    omemisbb(:,:,:)  = 0.0
    omemisob(:,:,:)  = 0.0
    omemisbf(:,:)    = 0.0
    omemissh(:,:)    = 0.0
    omemisbg(:,:)    = 0.0
    dmso(:,:)        = 0.0
    omemisocean(:,:) = 0.0

    if ( trim(bcff_source) .ne. ' ') then
     call interpolator(bcff_aerosol_interp, bcff_time, bcemisff_l1, &
          trim(bcff_emission_name(1)), is, js)
   endif

   if ( trim(bcbb_source).ne.' ') then
    nlevel_fire = 1
    alt_fire_min(:) = 0.0
    alt_fire_max(:) = 0.0
    select case (trim(bcbb_source))
      case ('cooke_and_wilson_1996')
        call interpolator(bcbb_aerosol_interp, bcbb_time, bcemisbb(:,:,1), &
                         trim(bcbb_emission_name(1)), is, js)
      case ('bond_2004') 
        call interpolator(bcbb_aerosol_interp, bcbb_time, bcemisbb(:,:,1), &
                         trim(bcbb_emission_name(1)), is, js)
      case ('gocart_2007') 
        call interpolator(bcbb_aerosol_interp, bcbb_time, bcemisbb(:,:,1), &
                         trim(bcbb_emission_name(1)), is, js)
      case ('RETRO') 
        call interpolator(bcbb_aerosol_interp, bcbb_time, bcemisbb(:,:,1), &
                         trim(bcbb_emission_name(1)), is, js)
      case ('GEIA')
        nlevel_fire = nlevel_fire_GEIA
        alt_fire_min(1:nlevel_fire_GEIA) = alt_fire_min_GEIA(1:nlevel_fire_GEIA)
        alt_fire_max(1:nlevel_fire_GEIA) = alt_fire_max_GEIA(1:nlevel_fire_GEIA)
        do lf=1, nlevel_fire 
          call interpolator(bcbb_aerosol_interp, bcbb_time, bcemisbb(:,:,lf), &
                         trim(bcbb_emission_name(lf)), is, js)
        enddo
      case ('AEROCOM') 
! Wildfire emissions at 6 levels from 0 to 6 km
! (cf. AEROCOM web site or Dentener et al., ACPD, 2006)
        nlevel_fire = nlevel_fire_AEROCOM
        alt_fire_min(1:nlevel_fire_AEROCOM) = &
                 alt_fire_min_AEROCOM(1:nlevel_fire_AEROCOM)
        alt_fire_max(1:nlevel_fire_AEROCOM) = &
                 alt_fire_max_AEROCOM(1:nlevel_fire_AEROCOM)
        do lf=1, nlevel_fire 
          call interpolator(bcbb_aerosol_interp, bcbb_time, bcemisbb(:,:,lf), &
                        trim(bcbb_emission_name(lf)), is, js)
        enddo
    end select
   endif
   if ( trim(bcbf_source).ne. ' ') then
     call interpolator(bcbf_aerosol_interp, bcbf_time, bcemisbf, &
                       trim(bcbf_emission_name(1)), is, js)
   endif

   if ( trim(bcsh_source).ne. ' ') then
     call interpolator(bcsh_aerosol_interp, bcsh_time, bcemissh, &
                  trim(bcsh_emission_name(1)), is, js)
   endif
   if ( trim(bcav_source).ne. ' ') then
     call interpolator(bcav_aerosol_interp, bcav_time, phalf, bcemisav, &
                         trim(bcav_emission_name(1)), is, js)
   endif
   if ( trim(omff_source).ne. ' ') then
     call interpolator(omff_aerosol_interp, omff_time, omemisff_l1, &
                      trim(omff_emission_name(1)), is, js)
   endif
   if ( trim(ombb_source).ne. ' ') then
    omemisbb(:,:,:) = 0.0
    nlevel_fire = 1
    alt_fire_min(:) = 0.0
    alt_fire_max(:) = 0.0
    select case (trim(ombb_source))
      case ('cooke_and_wilson_1996')
        call interpolator(ombb_aerosol_interp, ombb_time, omemisbb(:,:,1), &
                           trim(ombb_emission_name(1)), is, js)
        omemisbb(:,:,1) = omemisbb(:,:,1)*7.0
      case ('bond_2004') 
        call interpolator(ombb_aerosol_interp, ombb_time, omemisbb(:,:,1), &
                       trim(ombb_emission_name(1)), is, js)
      case ('gocart_2007')
        call interpolator(ombb_aerosol_interp, ombb_time, omemisbb(:,:,1), &
                       trim(ombb_emission_name(1)), is, js)
      case ('RETRO')
        call interpolator(ombb_aerosol_interp, ombb_time, omemisbb(:,:,1), &
                       trim(ombb_emission_name(1)), is, js)
      case ('GEIA')
        nlevel_fire = nlevel_fire_GEIA
        alt_fire_min(1:nlevel_fire_GEIA) = alt_fire_min_GEIA(1:nlevel_fire_GEIA)
        alt_fire_max(1:nlevel_fire_GEIA) = alt_fire_max_GEIA(1:nlevel_fire_GEIA)
! GEIA emission inventory scaled by ATSR fire counts (Reddy and Boucher, 2004)
! There are 2 levels of emission
        do lf=1, nlevel_fire
          call interpolator(ombb_aerosol_interp, ombb_time, omemisbb(:,:,lf), &
                       trim(ombb_emission_name(lf)), is, js)
        enddo
      case ('AEROCOM')
        nlevel_fire = nlevel_fire_AEROCOM
        alt_fire_min(1:nlevel_fire_AEROCOM) = &
              alt_fire_min_AEROCOM(1:nlevel_fire_AEROCOM)
        alt_fire_max(1:nlevel_fire_AEROCOM) = &
              alt_fire_max_AEROCOM(1:nlevel_fire_AEROCOM)
! Wildfire emissions at 6 levels from 0 to 6 km
! (cf. AEROCOM web site or Dentener et al., ACPD, 2006)
        do lf=1, nlevel_fire
          call interpolator(ombb_aerosol_interp, ombb_time, omemisbb(:,:,lf), &
                        trim(ombb_emission_name(lf)), is, js)
        enddo
    end select
   endif
   if ( trim(ombf_source).ne. ' ') then
     call interpolator(ombf_aerosol_interp, ombf_time, omemisbf, &
                       trim(ombf_emission_name(1)), is, js)
   endif
   if ( trim(omsh_source).ne. ' ') then
     call interpolator(omsh_aerosol_interp, omsh_time, omemissh, &
                  trim(omsh_emission_name(1)), is, js)
   endif
   if ( trim(omna_source).ne. ' ') then
     call interpolator(omna_aerosol_interp, omna_time, omemisbg, &
                       trim(omna_emission_name(1)), is, js)
   endif
   if ( trim(omss_source).ne. ' ') then
     call interpolator(omss_aerosol_interp, omss_time, dmso, &
                       trim(omss_emission_name(1)), is, js)
     do j = 1, jd
     do i = 1, id
       SST = t_surf(i,j)-273.15     ! Sea surface temperature [Celsius]
       if (land(i,j).lt.1) then
!  < Schmidt number (Saltzman et al., 1993) >
         Schm = 2674.0 - 147.12*SST + 3.726*(SST**2) - 0.038*(SST**3)
         Schm = max(1., Schm)
! ---  Liss and Merlivat (1986) -----------
         SchmCO2 = 600.
         if (w10m(i,j) .le. 3.6) then
           AKw = 0.17 * w10m(i,j)
         else if (w10m(i,j) .le. 13.) then
           AKw = 2.85 * w10m(i,j) - 9.65
              else
           AKw = 5.90 * w10m(i,j) - 49.3
         end if
         if (w10m(i,j) .le. 3.6) then
           AKw = AKw * ((SchmCO2/Schm) ** 0.667)
         else
           AKw = AKw * sqrt(SchmCO2/Schm)
         end if
         omemisocean(i,j) = coef_omss_emis*AKw/100./3600. * 1.e-6*(1.-land(i,j))
       end if

     enddo
     enddo


   endif
!
    do j = 1, jd
      do i = 1, id

! --- For fosil fuel emissions, calculate the fraction of emission for
! --- each vertical levels
        fa1(:) = 0.
        fa2(:) = 0.
        do l = kd,2,-1
          Z1 = z_half(i,j,l+1)-z_half(i,j,kd+1)
          Z2 = z_half(i,j,l)-z_half(i,j,kd+1)
          if (Z2.ge.0.and.Z1.lt.ze1) then
            if (Z1.gt.0) then
              if (Z2.lt.ze1) then
                fa1(l)=(Z2-Z1)/ze1
              else
                fa1(l)=(ze1-Z1)/ze1
              endif
            else
              if (Z2.le.ze1) then
                fa1(l)=Z2/ze1
              else
                fa1(l)=1.
              endif
            endif
          endif
          
          if (Z2.ge.ze1.and.z1.lt.ze2) then
            if (Z1.gt.Ze1) then
              if (Z2.lt.ze2) then
                fa2(l)=(z2-z1)/(ze2-ze1)
              else
                fa2(l)=(ze2-z1)/(ze2-ze1)
              endif
            else
              if (Z2.le.ze2) then
                fa2(l)=(z2-ze1)/(ze2-ze1)
              else
                fa2(l)=1.
              endif
            endif
          endif
          if (Z1.gt.Ze2) exit
        enddo
!
! Calculate fraction of emission at every levels for open fires
!
        fbb(:,:)=0.
!
! In case of multiple levels, which are fixed
!
        if (nlevel_fire .gt. 1) then
          do l = kd,2,-1
            Z1 = z_half(i,j,l+1)-z_half(i,j,kd+1)
            Z2 = z_half(i,j,l)-z_half(i,j,kd+1)
            do lf=1,nlevel_fire
              del=alt_fire_max(lf)-alt_fire_min(lf)
              if (del.gt.0. .and. &
                  Z1.lt.alt_fire_max(lf).and.Z2.gt.alt_fire_min(lf) ) then
                if (Z1.ge.alt_fire_min(lf)) then
                  if (Z2 .lt. alt_fire_max(lf)) then
                    fbb(l,lf)=(Z2-Z1)/del
                  else
                    fbb(l,lf)=(alt_fire_max(lf)-z1)/del
                  endif
                else
                  if (Z2.le.alt_fire_max(lf)) then
                    fbb(l,lf) = (Z2-alt_fire_min(lf))/del
                  else
                    fbb(l,lf)=1.
                  endif
                endif
              endif
            enddo
          enddo
        else
!
! --- Inject equally through the boundary layer -------
!
          bltop = z_pbl(i,j)
          do l = kd,1,-1
            z1=z_half(i,j,l+1)-z_half(i,j,kd+1)
            z2=z_half(i,j,l)-z_half(i,j,kd+1)
            if (bltop.lt.z1) exit
            if (bltop.ge.z2) fbb(l,1)=(z2-z1)/bltop
            if (bltop.gt.z1.and.bltop.lt.z2) fbb(l,1) = (bltop-z1)/bltop
          enddo
        endif
! Fossil fuel emission
        bcemisff(i,j,:)=fa1(:) * bcemisff_l1(i,j) + fa2(:) * bcemisff_l2(i,j)
        omemisff(i,j,:)=fa1(:) * omemisff_l1(i,j) + fa2(:) * omemisff_l2(i,j)
! Open biomass burning fires emission
        do lf =1, nlevel_fire
          bcemisob(i,j,:)= bcemisob(i,j,:) + fbb(:,lf)*bcemisbb(i,j,lf)
          omemisob(i,j,:)= omemisob(i,j,:) + fbb(:,lf)*omemisbb(i,j,lf)
        enddo
! Biogenic
! Bio-fuel (if not included in fossil fuel inevntory)
! International shipping
        bcphob_emis(i,j,kd) =  bcemisbf(i,j) + bcemissh(i,j)
        omphob_emis(i,j,kd) =  omemisbf(i,j) + omemissh(i,j) + &
           omemisbg(i,j) + omemisocean(i,j)
        bcphob_emis(i,j,:)= bcphob_emis(i,j,:) + &
           bc_aircraft_EI * bcemisav(i,j,:)    + &
           bcemisff(i,j,:) + bcemisob(i,j,:)
        omphob_emis(i,j,:)= omphob_emis(i,j,:) + omemisff(i,j,:) + &
           omemisob(i,j,:)

        do l=1,kd
          emisob(i,j) = emisob(i,j) + bcemisob(i,j,l) + omemisob(i,j,l)
          omemisob_2d(i,j) = omemisob_2d(i,j) + omemisob(i,j,l)
        end do

        bcphil_emis(i,j,:) = bcphob_emis(i,j,:) * frac_bc_philic/pwt(i,j,:)
        omphil_emis(i,j,:) = omphob_emis(i,j,:) * frac_om_philic/pwt(i,j,:)
        bcphob_emis(i,j,:) = bcphob_emis(i,j,:) * frac_bc_phobic/pwt(i,j,:)
        omphob_emis(i,j,:) = omphob_emis(i,j,:) * frac_om_phobic/pwt(i,j,:)
!
      enddo
    enddo

!------- compute black carbon phobic sink --------------
!
!  BCphob has a half-life time of 1.0days 
!   (corresponds to an e-folding time of 1.44 days)
!
!  sink = 1./(86400.*1.44) = 8.023e-6

    bcphob_sink(:,:,:) = 0.0
    where (bcphob > 0.0)
        bcphob_sink = 8.038e-6*bcphob
    elsewhere
        bcphob_sink = 0.0
    endwhere
!

!------- tendency ------------------

    bcphob_dt = bcphob_emis - bcphob_sink
    bcphil_dt = bcphil_emis + bcphob_sink
!
!------- compute organic carbon sink --------------
!
!  OCphob has a half-life time of 2.0days 
!   (corresponds to an e-folding time of 2.88 days)
!
!  sink = 1./(86400.*1.44) = 8.023e-6
!
    omphob_sink(:,:,:) = 0.0
    where (omphob >= 0.0)
       omphob_sink = 8.023e-6*omphob
    elsewhere
       omphob_sink = 0.0
    endwhere

!------- tendency ------------------

      omphob_dt = omphob_emis - omphob_sink
      omphil_dt = omphil_emis + omphob_sink

!-----------------------------------------------------------------


!
! Send registered results to diag manager
!
      if (id_bc_emis_col > 0) then
! column emissions for bc and om

        bc_emis = 0.
        do k=1,kd
          bc_emis(is:ie,js:je) = bc_emis(is:ie,js:je) +  &
               bcphob_emis(is:ie,js:je,k) + bcphil_emis(is:ie,js:je,k)
        end do

        used = send_data ( id_bc_emis_col, bc_emis, model_time, &
              is_in=is,js_in=js)
      endif
 
      if (id_om_emis_col > 0) then
! column emissions for bc and om

        om_emis = 0.
        do k=1,kd
          om_emis(is:ie,js:je) = om_emis(is:ie,js:je) +  &
              omphob_emis(is:ie,js:je,k) + omphil_emis(is:ie,js:je,k)
        end do

        used = send_data ( id_om_emis_col, om_emis, model_time, &
              is_in=is,js_in=js)
      endif

!
! Send registered results to diag manager
!
      if (id_bc_emis_colv2 > 0) then
! column emissions for bc (corrected cmip units)

        bc_emis = 0.
        do k=1,kd
          bc_emis(is:ie,js:je) = bc_emis(is:ie,js:je) + pwt(is:ie,js:je,k)*&
               (bcphob_emis(is:ie,js:je,k) + bcphil_emis(is:ie,js:je,k))
        end do
        used = send_data ( id_bc_emis_colv2, bc_emis, model_time, &
              is_in=is,js_in=js)
      endif
 
      if (id_om_emis_colv2 > 0) then
! column emissions for om (corrected cmip units)

        om_emis = 0.
        do k=1,kd
          om_emis(is:ie,js:je) = om_emis(is:ie,js:je) + pwt(is:ie,js:je,k)* &
              (omphob_emis(is:ie,js:je,k) + omphil_emis(is:ie,js:je,k))
        end do
        used = send_data ( id_om_emis_colv2, om_emis, model_time, &
              is_in=is,js_in=js)
      endif

!-----------------------------------------------------------------

      if (id_bcphob_emis > 0) then
        used = send_data ( id_bcphob_emis, bcphob_emis, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_bcphil_emis > 0) then
        used = send_data ( id_bcphil_emis, bcphil_emis, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_omphob_emis > 0) then
        used = send_data ( id_omphob_emis, omphob_emis, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_omphil_emis > 0) then
        used = send_data ( id_omphil_emis, omphil_emis, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_bcphob_sink > 0) then
        used = send_data ( id_bcphob_sink, bcphob_sink, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_omphob_sink > 0) then
        used = send_data ( id_omphob_sink, omphob_sink, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_bcemisbf > 0) then
        used = send_data ( id_bcemisbf, bcemisbf, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_emisbb > 0) then
        used = send_data ( id_emisbb, emisob, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_omemisbb_col > 0) then
        used = send_data ( id_omemisbb_col, omemisob_2d, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_bcemisbb > 0) then
        used = send_data ( id_bcemisbb, bcemisob, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_bcemissh > 0) then
        used = send_data ( id_bcemissh, bcemissh, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_bcemisff > 0) then
        used = send_data ( id_bcemisff, bcemisff, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_bcemisav > 0) then
        used = send_data ( id_bcemisav, bcemisav*bc_aircraft_EI, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_omemisbf > 0) then
        used = send_data ( id_omemisbf, omemisbf, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_omemisbb > 0) then
        used = send_data ( id_omemisbb, omemisob, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_omemissh > 0) then
        used = send_data ( id_omemissh, omemissh, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_omemisff > 0) then
        used = send_data ( id_omemisff, omemisff, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif
      if (id_omemisbg > 0) then
        used = send_data ( id_omemisbg, omemisbg, model_time, &
              is_in=is,js_in=js)
      endif
      if (id_omemisoc > 0) then
        used = send_data ( id_omemisoc, omemisocean, model_time, &
              is_in=is,js_in=js)
      endif
!
 end subroutine atmos_carbon_aerosol_driver

!#######################################################################
!<SUBROUTINE NAME ="atmos_carbon_aerosol_init">

!<OVERVIEW>
! Subroutine to initialize the carbon aerosol module.
!</OVERVIEW>
!<DESCRIPTION>
! This subroutine querys the tracer manager to find the indices for the 
! various carbonaceous aerosol tracers. It also registers the emission 
! fields for diagnostic purposes.
!  
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_carbon_aerosol_init (lonb, latb, r, axes, Time, mask)
!</TEMPLATE>
!   <IN NAME="lonb" TYPE="real" DIM="(:,:)">
!     The longitudes for the local domain.
!   </IN>
!   <IN NAME="latb" TYPE="real" DIM="(:,:)">
!     The latitudes for the local domain.
!   </IN>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>

 subroutine atmos_carbon_aerosol_init (lonb, latb, axes, Time, mask)

!-----------------------------------------------------------------------
real, dimension(:,:),    intent(in) :: lonb, latb
integer        , intent(in)                        :: axes(4)
type(time_type), intent(in)                        :: Time
real,            intent(in),    dimension(:,:,:), optional :: mask
character(len=7), parameter :: mod_name = 'tracers'
integer :: n
integer ::  unit, ierr, io, logunit


   if (module_is_initialized) return
!----------------------------------
!namelist files
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=carbon_aerosol_nml, iostat=io)
        ierr = check_nml_error(io,'carbon_aerosol_nml')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=carbon_aerosol_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'carbon_aerosol_nml')
        end do
10      call close_file (unit)
#endif
      endif
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit=stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=carbon_aerosol_nml)

!--------------------------------------------------------
!------namelist

!----- set initial value of carbon ------------

   n = get_tracer_index(MODEL_ATMOS,'bcphob')
   if (n>0) then
      nbcphobic = n
      call set_tracer_atts(MODEL_ATMOS,'bcphob','hphobic_bc','mmr')
      if (nbcphobic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (*,30) 'Hydrophobic BC',nbcphobic
      if (nbcphobic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (logunit,30) 'Hydrophobic BC',nbcphobic
   endif

   n = get_tracer_index(MODEL_ATMOS,'bcphil')
   if (n>0) then
      nbcphilic=n
      call set_tracer_atts(MODEL_ATMOS,'bcphil','hphilic_bc','mmr')
      if (nbcphilic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (*,30) 'Hydrophilic BC',nbcphilic
      if (nbcphilic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (logunit,30) 'Hydrophilic BC',nbcphilic
   endif

   n = get_tracer_index(MODEL_ATMOS,'omphob')
   if (n>0) then
      nomphobic=n
      call set_tracer_atts(MODEL_ATMOS,'omphob','phobic_om','mmr')
      if (nomphobic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (*,30) 'Hydrophobic OC',nomphobic
      if (nomphobic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (logunit,30) 'Hydrophobic OC',nomphobic
   endif

   n = get_tracer_index(MODEL_ATMOS,'omphil')
   if (n>0) then
      nomphilic=n
      call set_tracer_atts(MODEL_ATMOS,'omphil','philic_om','mmr')
      if (nomphilic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (*,30) 'Hydrophilic OC',nomphilic
      if (nomphilic > 0 .and. mpp_pe() == mpp_root_pe()) &
          write (logunit,30) 'Hydrophilic OC',nomphilic
   endif

30        format (A,' was initialized as tracer number ',i2)
!
!   Register Emissions as static fields (monthly)
!
     id_bcphob_emis = register_diag_field ( mod_name,           &
                    'bcphob_emis', axes(1:3),Time,          &
                    'BC phobic emission rate', 'kg/m2/sec' )

     id_bcphil_emis = register_diag_field ( mod_name,           &
                    'bcphil_emis', axes(1:3),Time,          &
                    'BC phylic emission rate', 'kg/m2/sec' )

     id_omphob_emis = register_diag_field ( mod_name,           &
                    'omphob_emis', axes(1:3),Time,          &
                    'OM phobic emission rate', 'kg/m2/sec' )

     id_omphil_emis = register_diag_field ( mod_name,           &
                    'omphil_emis', axes(1:3),Time,          &
                    'OM phylic emission rate', 'kg/m2/sec' )

     id_bc_emis_col = register_diag_field ( mod_name,           &
                    'bc_emis_col', axes(1:2),Time,          &
                    'total BC column emission rate', 'kg/m2/sec' )

     id_om_emis_col = register_diag_field ( mod_name,           &
                    'om_emis_col', axes(1:2),Time,          &
                    'total OM column emission rate', 'kg/m2/sec' )

     id_bc_emis_colv2 = register_diag_field ( mod_name,           &
                    'bc_emis_colv2', axes(1:2),Time,          &
                    'total BC column emission rate', 'kg/m2/sec' )

     id_om_emis_colv2 = register_diag_field ( mod_name,           &
                    'om_emis_colv2', axes(1:2),Time,          &
                    'total OM column emission rate', 'kg/m2/sec' )

     id_bcphob_sink = register_diag_field ( mod_name,           &
                    'bcphob_sink', axes(1:3),Time,          &
                    'BC phobic sink rate', 'kg/m2/sec' )

     id_omphob_sink = register_diag_field ( mod_name,           &
                    'omphob_sink', axes(1:3),Time,          &
                    'OM phobic sink rate', 'kg/m2/sec' )

     id_bcemisbf    = register_diag_field ( mod_name,           &
                    'bcemisbf', axes(1:2),Time,                 &
                    'BC biofuel emission', 'kg/m2/sec' )

     id_emisbb    = register_diag_field ( mod_name,           &
                    'emisbb', axes(1:2),Time,                 &
                    'column BC + OM open biomass burning emission', 'kg/m2/sec' )

     id_omemisbb_col    = register_diag_field ( mod_name,           &
                    'omemisbb_col', axes(1:2),Time,                 &
                    'column OM open biomass burning emission', 'kg/m2/sec' )

     id_bcemisbb    = register_diag_field ( mod_name,           &
                    'bcemisbb', axes(1:3),Time,                 &
                    'BC open biomass burning emission', 'kg/m2/sec' )

     id_bcemissh    = register_diag_field ( mod_name,           &
                    'bcemissh', axes(1:2),Time,                 &
                    'BC shipping emission', 'kg/m2/sec' )

     id_bcemisff    = register_diag_field ( mod_name,           &
                    'bcemisff', axes(1:3),Time,                 &
                    'BC fossil fuel emission', 'kg/m2/sec' )

     id_bcemisav    = register_diag_field ( mod_name,           &
                    'bcemisav', axes(1:3),Time,                 &
                    'BC aircraft emission', 'kg/m2/sec' )

     id_omemisbf    = register_diag_field ( mod_name,           &
                    'omemisbf', axes(1:2),Time,                 &
                    'OM biofuel emission', 'kg/m2/sec' )

     id_omemisbb    = register_diag_field ( mod_name,           &
                    'omemisbb', axes(1:3),Time,                 &
                    'OM open biomass burning emission', 'kg/m2/sec' )

     id_omemissh    = register_diag_field ( mod_name,           &
                    'omemissh', axes(1:2),Time,                 &
                    'OM shipping emission', 'kg/m2/sec' )

     id_omemisff    = register_diag_field ( mod_name,           &
                    'omemisff', axes(1:3),Time,                 &
                    'OM fossil fuel emission', 'kg/m2/sec' )

     id_omemisbg    = register_diag_field ( mod_name,           &
                    'omemisbg', axes(1:2),Time,                 &
                    'OM biogenic emission over land', 'kg/m2/sec' )

     id_omemisoc    = register_diag_field ( mod_name,           &
                    'omemisoc', axes(1:2),Time,                 &
                    'OM biogenic emission over ocean', 'kg/m2/sec' )

!----------------------------------------------------------------------
!    initialize namelist entries
!----------------------------------------------------------------------
        bcff_offset = set_time (0,0)
        bcbb_offset = set_time (0,0)
        bcbf_offset = set_time (0,0)
        bcsh_offset = set_time (0,0)
        bcav_offset = set_time (0,0)
        omff_offset = set_time (0,0)
        ombb_offset = set_time (0,0)
        ombf_offset = set_time (0,0)
        omsh_offset = set_time (0,0)
        omna_offset = set_time (0,0)
        omss_offset = set_time (0,0)

        bcff_entry = set_time (0,0)
        bcbb_entry = set_time (0,0)
        bcbf_entry = set_time (0,0)
        bcsh_entry = set_time (0,0)
        bcav_entry = set_time (0,0)
        omff_entry = set_time (0,0)
        ombb_entry = set_time (0,0)
        ombf_entry = set_time (0,0)
        omsh_entry = set_time (0,0)
        omna_entry = set_time (0,0)
        omss_entry = set_time (0,0)

        bcff_negative_offset = .false.
        bcbb_negative_offset = .false.
        bcbf_negative_offset = .false.
        bcsh_negative_offset = .false.
        bcav_negative_offset = .false.
        omff_negative_offset = .false.
        ombb_negative_offset = .false.
        ombf_negative_offset = .false.
        omsh_negative_offset = .false.
        omna_negative_offset = .false.
        omss_negative_offset = .false.

        bcff_time_serie_type = 1
        bcbb_time_serie_type = 1
        bcbf_time_serie_type = 1
        bcsh_time_serie_type = 1
        bcav_time_serie_type = 1
        omff_time_serie_type = 1
        ombb_time_serie_type = 1
        ombf_time_serie_type = 1
        omsh_time_serie_type = 1
        omna_time_serie_type = 1
        omss_time_serie_type = 1
!----------------------------------------------------------------------
!    define the model base time  (defined in diag_table)
!----------------------------------------------------------------------
        model_init_time = get_base_time()
   if ( trim(bcff_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(bcff_time_dependency_type) == 'constant' ) then
        bcff_time_serie_type = 1
        bcff_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcff are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for bcff is selected.
!---------------------------------------------------------------------
      else if (trim(bcff_time_dependency_type) == 'time_varying') then
        bcff_time_serie_type = 3
        if (bcff_dataset_entry(1) == 1 .and. &
            bcff_dataset_entry(2) == 1 .and. &
            bcff_dataset_entry(3) == 1 .and. &
            bcff_dataset_entry(4) == 0 .and. &
            bcff_dataset_entry(5) == 0 .and. &
            bcff_dataset_entry(6) == 0 ) then
          bcff_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcff_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          bcff_entry  = set_date (bcff_dataset_entry(1), &
                                  bcff_dataset_entry(2), &
                                  bcff_dataset_entry(3), &
                                  bcff_dataset_entry(4), &
                                  bcff_dataset_entry(5), &
                                  bcff_dataset_entry(6))
        endif
        call print_date (bcff_entry , str= &
          'Data from bcff timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        bcff_offset = bcff_entry - model_init_time
        if (model_init_time > bcff_entry) then
          bcff_negative_offset = .true.
        else
          bcff_negative_offset = .false.
        endif
      else if (trim(bcff_time_dependency_type) == 'fixed_year') then
        bcff_time_serie_type = 2
        if (bcff_dataset_entry(1) == 1 .and. &
            bcff_dataset_entry(2) == 1 .and. &
            bcff_dataset_entry(3) == 1 .and. &
            bcff_dataset_entry(4) == 0 .and. &
            bcff_dataset_entry(5) == 0 .and. &
            bcff_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set bcff_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcff_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        bcff_entry  = set_date (bcff_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'bcff is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcff correspond to year :', &
                    bcff_dataset_entry(1)
        endif
     endif
     select case (trim(bcff_source))
       case ('cooke_and_wilson_1996')
         if (trim(bcff_input_name(1)) .eq. ' ') then
           bcff_emission_name(1)='bcff_cw96'
         else
           bcff_emission_name(1)=trim(bcff_input_name(1))
         endif
      case ('cooke_1999')
         if (trim(bcff_input_name(1)) .eq. ' ') then
           bcff_emission_name(1)='bcff_cooke99'
         else
           bcff_emission_name(1)=trim(bcff_input_name(1))
         endif
      case ('bond_2004') 
         if (trim(bcff_input_name(1)) .eq. ' ') then
           bcff_emission_name(1)='bcff_bond'
         else
           bcff_emission_name(1)=trim(bcff_input_name(1))
         endif
      case ('gocart_2007') 
         if (trim(bcff_input_name(1)) .eq. ' ') then
           bcff_emission_name(1)='bc_anthro'
         else
           bcff_emission_name(1)=trim(bcff_input_name(1))
         endif
      case ('AEROCOM') 
         if (trim(bcff_input_name(1)) .eq. ' ') then
           bcff_emission_name(1)='BC1ff'
         else
           bcff_emission_name(1)=trim(bcff_input_name(1))
         endif
     end select
     call interpolator_init (bcff_aerosol_interp,             &
                             trim(bcff_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = bcff_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
   endif
   if ( trim(bcbb_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(bcbb_time_dependency_type) == 'constant' ) then
        bcbb_time_serie_type = 1
        bcbb_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcbb are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for bcbb is selected.
!---------------------------------------------------------------------
      else if (trim(bcbb_time_dependency_type) == 'time_varying') then
        bcbb_time_serie_type = 3
        if (bcbb_dataset_entry(1) == 1 .and. &
            bcbb_dataset_entry(2) == 1 .and. &
            bcbb_dataset_entry(3) == 1 .and. &
            bcbb_dataset_entry(4) == 0 .and. &
            bcbb_dataset_entry(5) == 0 .and. &
            bcbb_dataset_entry(6) == 0 ) then
          bcbb_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcbb_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          bcbb_entry  = set_date (bcbb_dataset_entry(1), &
                                  bcbb_dataset_entry(2), &
                                  bcbb_dataset_entry(3), &
                                  bcbb_dataset_entry(4), &
                                  bcbb_dataset_entry(5), &
                                  bcbb_dataset_entry(6))
        endif
        call print_date (bcbb_entry , str= &
          'Data from bcbb timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        bcbb_offset = bcbb_entry - model_init_time
        if (model_init_time > bcbb_entry) then
          bcbb_negative_offset = .true.
        else
          bcbb_negative_offset = .false.
        endif
      else if (trim(bcbb_time_dependency_type) == 'fixed_year') then
        bcbb_time_serie_type = 2
        if (bcbb_dataset_entry(1) == 1 .and. &
            bcbb_dataset_entry(2) == 1 .and. &
            bcbb_dataset_entry(3) == 1 .and. &
            bcbb_dataset_entry(4) == 0 .and. &
            bcbb_dataset_entry(5) == 0 .and. &
            bcbb_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set bcbb_dataset_entry when using fixed_year source', FATAL)
        endif
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcbb_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        bcbb_entry  = set_date (bcbb_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'bcbb is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcbb correspond to year :', &
                    bcbb_dataset_entry(1)
        endif
     endif
     select case (trim(bcbb_source))
       case ('cooke_and_wilson_1996')
         if (trim(bcbb_input_name(1)) .eq. ' ') then
           bcbb_emission_name(1)='bcbb_cw96'
         else
           bcbb_emission_name(1)=trim(bcbb_input_name(1))
         endif
         call interpolator_init (bcbb_aerosol_interp,           &
           trim(bcbb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=bcbb_emission_name(1:1), vert_interp=(/INTERP_WEIGHTED_P/))
      case ('bond_2004') 
         if (trim(bcbb_input_name(1)) .eq. ' ') then
           bcbb_emission_name(1)='bcob_bond'
         else
           bcbb_emission_name(1)=trim(bcbb_input_name(1))
         endif
         call interpolator_init (bcbb_aerosol_interp,           &
           trim(bcbb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=bcbb_emission_name(1:1), vert_interp=(/INTERP_WEIGHTED_P/))
      case ('gocart_2007') 
         if (trim(bcbb_input_name(1)) .eq. ' ') then
           bcbb_emission_name(1)='bc_biobur'
         else
           bcbb_emission_name(1)=trim(bcbb_input_name(1))
         endif
         call interpolator_init (bcbb_aerosol_interp,           &
           trim(bcbb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=bcbb_emission_name(1:1), vert_interp=(/INTERP_WEIGHTED_P/))
       case ('GEIA')
         if (trim(bcbb_input_name(1)) .eq. ' ') then
           bcbb_emission_name(1)='bc_geia1'
           bcbb_emission_name(2)='bc_geia2'
         else
           bcbb_emission_name(1)=trim(bcbb_input_name(1))
           bcbb_emission_name(2)=trim(bcbb_input_name(2))
         endif
         call interpolator_init (bcbb_aerosol_interp,           &
           trim(bcbb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=bcbb_emission_name(1:2),vert_interp=(/INTERP_WEIGHTED_P/))
       case ('AEROCOM')
         if (trim(bcbb_input_name(1)) .eq. ' ') then
           bcbb_emission_name(1)='GFED_BC_l1'
           bcbb_emission_name(2)='GFED_BC_l2'
           bcbb_emission_name(3)='GFED_BC_l3'
           bcbb_emission_name(4)='GFED_BC_l4'
           bcbb_emission_name(5)='GFED_BC_l5'
           bcbb_emission_name(6)='GFED_BC_l6'
         else
           bcbb_emission_name(1)(:)=trim(bcbb_input_name(1)(:))
           bcbb_emission_name(2)(:)=trim(bcbb_input_name(2)(:))
           bcbb_emission_name(3)(:)=trim(bcbb_input_name(3)(:))
           bcbb_emission_name(4)(:)=trim(bcbb_input_name(4)(:))
           bcbb_emission_name(5)(:)=trim(bcbb_input_name(5)(:))
           bcbb_emission_name(6)(:)=trim(bcbb_input_name(6)(:))
         endif
         call interpolator_init (bcbb_aerosol_interp,           &
           trim(bcbb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=bcbb_emission_name(1:6),vert_interp=(/INTERP_WEIGHTED_P/))
     end select
   endif
   if ( trim(bcsh_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(bcsh_time_dependency_type) == 'constant' ) then
        bcsh_time_serie_type = 1
        bcsh_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcsh are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for bcsh is selected.
!---------------------------------------------------------------------
      else if (trim(bcsh_time_dependency_type) == 'time_varying') then
        bcsh_time_serie_type = 3
        if (bcsh_dataset_entry(1) == 1 .and. &
            bcsh_dataset_entry(2) == 1 .and. &
            bcsh_dataset_entry(3) == 1 .and. &
            bcsh_dataset_entry(4) == 0 .and. &
            bcsh_dataset_entry(5) == 0 .and. &
            bcsh_dataset_entry(6) == 0 ) then
          bcsh_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcsh_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          bcsh_entry  = set_date (bcsh_dataset_entry(1), &
                                  bcsh_dataset_entry(2), &
                                  bcsh_dataset_entry(3), &
                                  bcsh_dataset_entry(4), &
                                  bcsh_dataset_entry(5), &
                                  bcsh_dataset_entry(6))
        endif
        call print_date (bcsh_entry , str= &
          'Data from bcsh timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        bcsh_offset = bcsh_entry - model_init_time
        if (model_init_time > bcsh_entry) then
          bcsh_negative_offset = .true.
        else
          bcsh_negative_offset = .false.
        endif
      else if (trim(bcsh_time_dependency_type) == 'fixed_year') then
        bcsh_time_serie_type = 2
        if (bcsh_dataset_entry(1) == 1 .and. &
            bcsh_dataset_entry(2) == 1 .and. &
            bcsh_dataset_entry(3) == 1 .and. &
            bcsh_dataset_entry(4) == 0 .and. &
            bcsh_dataset_entry(5) == 0 .and. &
            bcsh_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set bcsh_dataset_entry when using fixed_year source', FATAL)
        endif
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcsh_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        bcsh_entry  = set_date (bcsh_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'bcsh is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcsh correspond to year :', &
                    bcsh_dataset_entry(1)
        endif
     endif
     if (trim(bcsh_input_name(1)) .eq. ' ') then
       bcsh_emission_name(1)='bc_ship'
     else
       bcsh_emission_name(1)=trim(bcsh_input_name(1))
     endif

     call interpolator_init (bcsh_aerosol_interp,             &
                             trim(bcsh_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = bcsh_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
   endif
   if ( trim(bcav_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(bcav_time_dependency_type) == 'constant' ) then
        bcav_time_serie_type = 1
        bcav_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcav are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for bcav is selected.
!---------------------------------------------------------------------
      else if (trim(bcav_time_dependency_type) == 'time_varying') then
        bcav_time_serie_type = 3
        if (bcav_dataset_entry(1) == 1 .and. &
            bcav_dataset_entry(2) == 1 .and. &
            bcav_dataset_entry(3) == 1 .and. &
            bcav_dataset_entry(4) == 0 .and. &
            bcav_dataset_entry(5) == 0 .and. &
            bcav_dataset_entry(6) == 0 ) then
          bcav_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcav_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          bcav_entry  = set_date (bcav_dataset_entry(1), &
                                  bcav_dataset_entry(2), &
                                  bcav_dataset_entry(3), &
                                  bcav_dataset_entry(4), &
                                  bcav_dataset_entry(5), &
                                  bcav_dataset_entry(6))
        endif
        call print_date (bcav_entry , str= &
          'Data from bcav timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        bcav_offset = bcav_entry - model_init_time
        if (model_init_time > bcav_entry) then
          bcav_negative_offset = .true.
        else
          bcav_negative_offset = .false.
        endif
      else if (trim(bcav_time_dependency_type) == 'fixed_year') then
        bcav_time_serie_type = 2
        if (bcav_dataset_entry(1) == 1 .and. &
            bcav_dataset_entry(2) == 1 .and. &
            bcav_dataset_entry(3) == 1 .and. &
            bcav_dataset_entry(4) == 0 .and. &
            bcav_dataset_entry(5) == 0 .and. &
            bcav_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set bcav_dataset_entry when using fixed_year source', FATAL)
        endif
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcav_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        bcav_entry  = set_date (bcav_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'bcav is defined from a single annual cycle - no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcav correspond to year :', bcav_dataset_entry(1)
        endif
     endif
     if (trim(bcav_input_name(1)) .eq. ' ') then
       bcav_emission_name(1)='bc_aircraft'
     else
       bcav_emission_name(1)=trim(bcav_input_name(1))
     endif
     call interpolator_init (bcav_aerosol_interp,             &
                             trim(bcav_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = bcav_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
   endif
   if ( trim(bcbf_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(bcbf_time_dependency_type) == 'constant' ) then
        bcbf_time_serie_type = 1
        bcbf_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcbf are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for bcbf is selected.
!---------------------------------------------------------------------
      else if (trim(bcbf_time_dependency_type) == 'time_varying') then
        bcbf_time_serie_type = 3
        if (bcbf_dataset_entry(1) == 1 .and. &
            bcbf_dataset_entry(2) == 1 .and. &
            bcbf_dataset_entry(3) == 1 .and. &
            bcbf_dataset_entry(4) == 0 .and. &
            bcbf_dataset_entry(5) == 0 .and. &
            bcbf_dataset_entry(6) == 0 ) then
          bcbf_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcbf_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          bcbf_entry  = set_date (bcbf_dataset_entry(1), &
                                  bcbf_dataset_entry(2), &
                                  bcbf_dataset_entry(3), &
                                  bcbf_dataset_entry(4), &
                                  bcbf_dataset_entry(5), &
                                  bcbf_dataset_entry(6))
        endif
        call print_date (bcbf_entry , str= &
          'Data from bcbf timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        bcbf_offset = bcbf_entry - model_init_time
        if (model_init_time > bcbf_entry) then
          bcbf_negative_offset = .true.
        else
          bcbf_negative_offset = .false.
        endif
      else if (trim(bcbf_time_dependency_type) == 'fixed_year') then
        bcbf_time_serie_type = 2
        if (bcbf_dataset_entry(1) == 1 .and. &
            bcbf_dataset_entry(2) == 1 .and. &
            bcbf_dataset_entry(3) == 1 .and. &
            bcbf_dataset_entry(4) == 0 .and. &
            bcbf_dataset_entry(5) == 0 .and. &
            bcbf_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set bcbf_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to bcbf_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        bcbf_entry  = set_date (bcbf_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'bcbf is defined from a single annual cycle - no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'bcbf correspond to year :', &
                    bcbf_dataset_entry(1)
        endif
     endif
     if (trim(bcbf_input_name(1)) .eq. ' ') then
       bcbf_emission_name(1)='bcbf_bond'
     else
       bcbf_emission_name(1)=trim(bcbf_input_name(1))
     endif
     call interpolator_init (bcbf_aerosol_interp,             &
                             trim(bcbf_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = bcbf_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
   endif
   if ( trim(omff_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(omff_time_dependency_type) == 'constant' ) then
        omff_time_serie_type = 1
        omff_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omff are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for omff is selected.
!---------------------------------------------------------------------
      else if (trim(omff_time_dependency_type) == 'time_varying') then
        omff_time_serie_type = 3
        if (omff_dataset_entry(1) == 1 .and. &
            omff_dataset_entry(2) == 1 .and. &
            omff_dataset_entry(3) == 1 .and. &
            omff_dataset_entry(4) == 0 .and. &
            omff_dataset_entry(5) == 0 .and. &
            omff_dataset_entry(6) == 0 ) then
          omff_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omff_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          omff_entry  = set_date (omff_dataset_entry(1), &
                                  omff_dataset_entry(2), &
                                  omff_dataset_entry(3), &
                                  omff_dataset_entry(4), &
                                  omff_dataset_entry(5), &
                                  omff_dataset_entry(6))
        endif
        call print_date (omff_entry , str= &
          'Data from omff timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        omff_offset = omff_entry - model_init_time
        if (model_init_time > omff_entry) then
          omff_negative_offset = .true.
        else
          omff_negative_offset = .false.
        endif
      else if (trim(omff_time_dependency_type) == 'fixed_year') then
        omff_time_serie_type = 2
        if (omff_dataset_entry(1) == 1 .and. &
            omff_dataset_entry(2) == 1 .and. &
            omff_dataset_entry(3) == 1 .and. &
            omff_dataset_entry(4) == 0 .and. &
            omff_dataset_entry(5) == 0 .and. &
            omff_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set omff_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omff_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        omff_entry  = set_date (omff_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'omff is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omff correspond to year :', &
                    omff_dataset_entry(1)
        endif
     endif
     select case (trim(omff_source))
      case ('cooke_1999')
         if (trim(omff_input_name(1)) .eq. ' ') then
           omff_emission_name(1)='omff_cooke99'
         else
           omff_emission_name(1)=trim(omff_input_name(1))
         endif
      case ('bond_2004') 
         if (trim(omff_input_name(1)) .eq. ' ') then
           omff_emission_name(1)='omff_bond'
         else
           omff_emission_name(1)=trim(omff_input_name(1))
         endif
      case ('gocart_2007') 
         if (trim(omff_input_name(1)) .eq. ' ') then
           omff_emission_name(1)='om_anthro'
         else
           omff_emission_name(1)=trim(omff_input_name(1))
         endif
      case ('AEROCOM') 
         if (trim(omff_input_name(1)) .eq. ' ') then
           omff_emission_name(1)='POMff'
         else
           omff_emission_name(1)=trim(omff_input_name(1))
         endif
     end select
     call interpolator_init (omff_aerosol_interp,           &
       trim(omff_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
       data_names=omff_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
   endif
   if ( trim(ombb_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(ombb_time_dependency_type) == 'constant' ) then
        ombb_time_serie_type = 1
        ombb_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'ombb are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for ombb is selected.
!---------------------------------------------------------------------
      else if (trim(ombb_time_dependency_type) == 'time_varying') then
        ombb_time_serie_type = 3
        if (ombb_dataset_entry(1) == 1 .and. &
            ombb_dataset_entry(2) == 1 .and. &
            ombb_dataset_entry(3) == 1 .and. &
            ombb_dataset_entry(4) == 0 .and. &
            ombb_dataset_entry(5) == 0 .and. &
            ombb_dataset_entry(6) == 0 ) then
          ombb_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ombb_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          ombb_entry  = set_date (ombb_dataset_entry(1), &
                                  ombb_dataset_entry(2), &
                                  ombb_dataset_entry(3), &
                                  ombb_dataset_entry(4), &
                                  ombb_dataset_entry(5), &
                                  ombb_dataset_entry(6))
        endif
        call print_date (ombb_entry , str= &
          'Data from ombb timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        ombb_offset = ombb_entry - model_init_time
        if (model_init_time > ombb_entry) then
          ombb_negative_offset = .true.
        else
          ombb_negative_offset = .false.
        endif
      else if (trim(ombb_time_dependency_type) == 'fixed_year') then
        ombb_time_serie_type = 2
        if (ombb_dataset_entry(1) == 1 .and. &
            ombb_dataset_entry(2) == 1 .and. &
            ombb_dataset_entry(3) == 1 .and. &
            ombb_dataset_entry(4) == 0 .and. &
            ombb_dataset_entry(5) == 0 .and. &
            ombb_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set ombb_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ombb_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        ombb_entry  = set_date (ombb_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'ombb is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'ombb correspond to year :', &
                    ombb_dataset_entry(1)
        endif
     endif
     select case (trim(ombb_source))
       case ('cooke_and_wilson_1996')
         if (trim(ombb_input_name(1)) .eq. ' ') then
           ombb_emission_name(1)='ombb_cw96'
         else
           ombb_emission_name(1)=trim(ombb_input_name(1))
         endif
         call interpolator_init (ombb_aerosol_interp,           &
           trim(ombb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=ombb_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
      case ('bond_2004') 
         if (trim(ombb_input_name(1)) .eq. ' ') then
           ombb_emission_name(1)='omob_bond'
         else
           ombb_emission_name(1)=trim(ombb_input_name(1))
         endif
         call interpolator_init (ombb_aerosol_interp,           &
           trim(ombb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=ombb_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
      case ('gocart_2007') 
         if (trim(ombb_input_name(1)) .eq. ' ') then
           ombb_emission_name(1)='om_biobur'
         else
           ombb_emission_name(1)=trim(ombb_input_name(1))
         endif
         call interpolator_init (ombb_aerosol_interp,           &
           trim(ombb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=ombb_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
       case ('GEIA')
         if (trim(ombb_input_name(1)) .eq. ' ') then
           ombb_emission_name(1)='om_geia1'
           ombb_emission_name(2)='om_geia2'
         else
           ombb_emission_name(1)=trim(ombb_input_name(1))
           ombb_emission_name(2)=trim(ombb_input_name(2))
         endif
         call interpolator_init (ombb_aerosol_interp,           &
           trim(ombb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=ombb_emission_name(1:2),vert_interp=(/INTERP_WEIGHTED_P/))
       case ('AEROCOM')
         if (trim(ombb_input_name(1)) .eq. ' ') then
           ombb_emission_name(1)='GFED_OM_l1'
           ombb_emission_name(2)='GFED_OM_l2'
           ombb_emission_name(3)='GFED_OM_l3'
           ombb_emission_name(4)='GFED_OM_l4'
           ombb_emission_name(5)='GFED_OM_l5'
           ombb_emission_name(6)='GFED_OM_l6'
         else
           ombb_emission_name(1)=trim(ombb_input_name(1))
           ombb_emission_name(2)=trim(ombb_input_name(2))
           ombb_emission_name(3)=trim(ombb_input_name(3))
           ombb_emission_name(4)=trim(ombb_input_name(4))
           ombb_emission_name(5)=trim(ombb_input_name(5))
           ombb_emission_name(6)=trim(ombb_input_name(6))
         endif
         call interpolator_init (ombb_aerosol_interp,           &
           trim(ombb_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
           data_names=ombb_emission_name(1:6),vert_interp=(/INTERP_WEIGHTED_P/))
     end select
   endif
   if ( trim(ombf_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(ombf_time_dependency_type) == 'constant' ) then
        ombf_time_serie_type = 1
        ombf_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'ombf are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for ombf is selected.
!---------------------------------------------------------------------
      else if (trim(ombf_time_dependency_type) == 'time_varying') then
        ombf_time_serie_type = 3
        if (ombf_dataset_entry(1) == 1 .and. &
            ombf_dataset_entry(2) == 1 .and. &
            ombf_dataset_entry(3) == 1 .and. &
            ombf_dataset_entry(4) == 0 .and. &
            ombf_dataset_entry(5) == 0 .and. &
            ombf_dataset_entry(6) == 0 ) then
          ombf_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ombf_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          ombf_entry  = set_date (ombf_dataset_entry(1), &
                                  ombf_dataset_entry(2), &
                                  ombf_dataset_entry(3), &
                                  ombf_dataset_entry(4), &
                                  ombf_dataset_entry(5), &
                                  ombf_dataset_entry(6))
        endif
        call print_date (ombf_entry , str= &
          'Data from ombf timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        ombf_offset = ombf_entry - model_init_time
        if (model_init_time > ombf_entry) then
          ombf_negative_offset = .true.
        else
          ombf_negative_offset = .false.
        endif
      else if (trim(ombf_time_dependency_type) == 'fixed_year') then
        ombf_time_serie_type = 2
        if (ombf_dataset_entry(1) == 1 .and. &
            ombf_dataset_entry(2) == 1 .and. &
            ombf_dataset_entry(3) == 1 .and. &
            ombf_dataset_entry(4) == 0 .and. &
            ombf_dataset_entry(5) == 0 .and. &
            ombf_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set ombf_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ombf_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        ombf_entry  = set_date (ombf_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'ombf is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'ombf correspond to year :', &
                    ombf_dataset_entry(1)
        endif
     endif
     if (trim(ombf_input_name(1)) .eq. ' ') then
       ombf_emission_name(1)='ombf_bond'
     else
       ombf_emission_name(1)=trim(ombf_input_name(1))
     endif
     call interpolator_init (ombf_aerosol_interp,           &
       trim(ombf_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
       data_names=ombf_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
   endif
   if ( trim(omsh_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(omsh_time_dependency_type) == 'constant' ) then
        omsh_time_serie_type = 1
        omsh_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omsh are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for omsh is selected.
!---------------------------------------------------------------------
      else if (trim(omsh_time_dependency_type) == 'time_varying') then
        omsh_time_serie_type = 3
        if (omsh_dataset_entry(1) == 1 .and. &
            omsh_dataset_entry(2) == 1 .and. &
            omsh_dataset_entry(3) == 1 .and. &
            omsh_dataset_entry(4) == 0 .and. &
            omsh_dataset_entry(5) == 0 .and. &
            omsh_dataset_entry(6) == 0 ) then
          omsh_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omsh_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          omsh_entry  = set_date (omsh_dataset_entry(1), &
                                  omsh_dataset_entry(2), &
                                  omsh_dataset_entry(3), &
                                  omsh_dataset_entry(4), &
                                  omsh_dataset_entry(5), &
                                  omsh_dataset_entry(6))
        endif
        call print_date (omsh_entry , str= &
          'Data from omsh timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        omsh_offset = omsh_entry - model_init_time
        if (model_init_time > omsh_entry) then
          omsh_negative_offset = .true.
        else
          omsh_negative_offset = .false.
        endif
      else if (trim(omsh_time_dependency_type) == 'fixed_year') then
        omsh_time_serie_type = 2
        if (omsh_dataset_entry(1) == 1 .and. &
            omsh_dataset_entry(2) == 1 .and. &
            omsh_dataset_entry(3) == 1 .and. &
            omsh_dataset_entry(4) == 0 .and. &
            omsh_dataset_entry(5) == 0 .and. &
            omsh_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set omsh_dataset_entry when using fixed_year source', FATAL)
        endif
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omsh_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        omsh_entry  = set_date (omsh_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'omsh is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omsh correspond to year :', &
                    omsh_dataset_entry(1)
        endif
     endif
     if (trim(omsh_input_name(1)) .eq. ' ') then
       omsh_emission_name(1)='om_ship'
     else
       omsh_emission_name(1)=trim(omsh_input_name(1))
     endif
     call interpolator_init (omsh_aerosol_interp,           &
       trim(omsh_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
       data_names=omsh_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
   endif
   if ( trim(omna_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(omna_time_dependency_type) == 'constant' ) then
        omna_time_serie_type = 1
        omna_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omna are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for omna is selected.
!---------------------------------------------------------------------
      else if (trim(omna_time_dependency_type) == 'time_varying') then
        omna_time_serie_type = 3
        if (omna_dataset_entry(1) == 1 .and. &
            omna_dataset_entry(2) == 1 .and. &
            omna_dataset_entry(3) == 1 .and. &
            omna_dataset_entry(4) == 0 .and. &
            omna_dataset_entry(5) == 0 .and. &
            omna_dataset_entry(6) == 0 ) then
          omna_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omna_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          omna_entry  = set_date (omna_dataset_entry(1), &
                                  omna_dataset_entry(2), &
                                  omna_dataset_entry(3), &
                                  omna_dataset_entry(4), &
                                  omna_dataset_entry(5), &
                                  omna_dataset_entry(6))
        endif
        call print_date (omna_entry , str= &
          'Data from omna timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        omna_offset = omna_entry - model_init_time
        if (model_init_time > omna_entry) then
          omna_negative_offset = .true.
        else
          omna_negative_offset = .false.
        endif
      else if (trim(omna_time_dependency_type) == 'fixed_year') then
        omna_time_serie_type = 2
        if (omna_dataset_entry(1) == 1 .and. &
            omna_dataset_entry(2) == 1 .and. &
            omna_dataset_entry(3) == 1 .and. &
            omna_dataset_entry(4) == 0 .and. &
            omna_dataset_entry(5) == 0 .and. &
            omna_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set omna_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omna_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        omna_entry  = set_date (omna_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'omna is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omna correspond to year :', &
                    omna_dataset_entry(1)
        endif
     endif
     if (trim(omna_input_name(1)) .eq. ' ') then
       omna_emission_name(1)='omemisnat'
     else
       omna_emission_name(1)=trim(omna_input_name(1))
     endif
     call interpolator_init (omna_aerosol_interp,           &
       trim(omna_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
       data_names=omna_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
   endif
   if ( trim(omss_source) .ne. ' ') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(omss_time_dependency_type) == 'constant' ) then
        omss_time_serie_type = 1
        omss_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omss are constant in atmos_carbon_aerosol module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for omss is selected.
!---------------------------------------------------------------------
      else if (trim(omss_time_dependency_type) == 'time_varying') then
        omss_time_serie_type = 3
        if (omss_dataset_entry(1) == 1 .and. &
            omss_dataset_entry(2) == 1 .and. &
            omss_dataset_entry(3) == 1 .and. &
            omss_dataset_entry(4) == 0 .and. &
            omss_dataset_entry(5) == 0 .and. &
            omss_dataset_entry(6) == 0 ) then
          omss_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omss_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          omss_entry  = set_date (omss_dataset_entry(1), &
                                  omss_dataset_entry(2), &
                                  omss_dataset_entry(3), &
                                  omss_dataset_entry(4), &
                                  omss_dataset_entry(5), &
                                  omss_dataset_entry(6))
        endif
        call print_date (omss_entry , str= &
          'Data from omss timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        omss_offset = omss_entry - model_init_time
        if (model_init_time > omss_entry) then
          omss_negative_offset = .true.
        else
          omss_negative_offset = .false.
        endif
      else if (trim(omss_time_dependency_type) == 'fixed_year') then
        omss_time_serie_type = 2
        if (omss_dataset_entry(1) == 1 .and. &
            omss_dataset_entry(2) == 1 .and. &
            omss_dataset_entry(3) == 1 .and. &
            omss_dataset_entry(4) == 0 .and. &
            omss_dataset_entry(5) == 0 .and. &
            omss_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_carbon_aerosol_mod', &
            'must set omss_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to omss_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        omss_entry  = set_date (omss_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_carbon_aerosol_mod', &
           'omss is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'omss correspond to year :', &
                    omss_dataset_entry(1)
        endif
     endif
     if (trim(omss_input_name(1)) .eq. ' ') then
       omss_emission_name(1)='DMSo'
     else
       omss_emission_name(1)=trim(omss_input_name(1))
     endif
     call interpolator_init (omss_aerosol_interp,           &
       trim(omss_filename), lonb, latb, data_out_of_bounds=(/CONSTANT/), &
       data_names=omss_emission_name(1:1),vert_interp=(/INTERP_WEIGHTED_P/))
     if (omss_coef .le. -990) then
       coef_omss_emis = 1.
     else
       coef_omss_emis = omss_coef
     endif
   endif


   call write_version_number (version, tagname)
   module_is_initialized = .TRUE.

!-----------------------------------------------------------------------

end subroutine atmos_carbon_aerosol_init



!######################################################################

subroutine atmos_carbon_aerosol_time_vary (model_time)


type(time_type), intent(in) :: model_time


    integer ::  yr, dum, mo_yr, mo, dy, hr, mn, sc, dayspmn


    if ( trim(bcff_source) .ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the bcff data set from which data is to be 
!    taken. if bcff is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(bcff_time_serie_type .eq. 3) then
       if (bcff_negative_offset) then
         bcff_time = model_time - bcff_offset
       else
         bcff_time = model_time + bcff_offset
       endif
     else 
       if(bcff_time_serie_type .eq. 2 ) then
         call get_date (bcff_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(bcff_entry)
           if (dayspmn /= 29) then
             bcff_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             bcff_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           bcff_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         bcff_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                                   (bcff_aerosol_interp, bcff_time)
   endif

   if ( trim(bcbb_source).ne.' ') then

!--------------------------------------------------------------------
!    define the time in the bcbb data set from which data is to be 
!    taken. if bcbb is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(bcbb_time_serie_type .eq. 3) then
       if (bcbb_negative_offset) then
         bcbb_time = model_time - bcbb_offset
       else
         bcbb_time = model_time + bcbb_offset
       endif
     else 
       if(bcbb_time_serie_type .eq. 2 ) then
         call get_date (bcbb_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(bcbb_entry)
           if (dayspmn /= 29) then
             bcbb_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             bcbb_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           bcbb_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         bcbb_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                       (bcbb_aerosol_interp, bcbb_time)
   endif

   if ( trim(bcbf_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the bcbf data set from which data is to be 
!    taken. if bcbf is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(bcbf_time_serie_type .eq. 3) then
       if (bcbf_negative_offset) then
         bcbf_time = model_time - bcbf_offset
       else
         bcbf_time = model_time + bcbf_offset
       endif
     else 
       if(bcbf_time_serie_type .eq. 2 ) then
         call get_date (bcbf_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(bcbf_entry)
           if (dayspmn /= 29) then
             bcbf_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             bcbf_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           bcbf_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         bcbf_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                 (bcbf_aerosol_interp, bcbf_time)
   endif

   if ( trim(bcsh_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the bcsh data set from which data is to be 
!    taken. if bcsh is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(bcsh_time_serie_type .eq. 3) then
       if (bcsh_negative_offset) then
         bcsh_time = model_time - bcsh_offset
       else
         bcsh_time = model_time + bcsh_offset
       endif
     else 
       if(bcsh_time_serie_type .eq. 2 ) then
         call get_date (bcsh_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(bcsh_entry)
           if (dayspmn /= 29) then
             bcsh_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             bcsh_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           bcsh_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         bcsh_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                    (bcsh_aerosol_interp, bcsh_time)
   endif

   if ( trim(bcav_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the bcav data set from which data is to be 
!    taken. if bcav is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(bcav_time_serie_type .eq. 3) then
       if (bcav_negative_offset) then
         bcav_time = model_time - bcav_offset
       else
         bcav_time = model_time + bcav_offset
       endif
     else 
       if(bcav_time_serie_type .eq. 2 ) then
         call get_date (bcav_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(bcav_entry)
           if (dayspmn /= 29) then
             bcav_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             bcav_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           bcav_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         bcav_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                     (bcav_aerosol_interp, bcav_time)
   endif

   if ( trim(omff_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the omff data set from which data is to be 
!    taken. if omff is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(omff_time_serie_type .eq. 3) then
       if (omff_negative_offset) then
         omff_time = model_time - omff_offset
       else
         omff_time = model_time + omff_offset
       endif
     else 
       if(omff_time_serie_type .eq. 2 ) then
         call get_date (omff_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(omff_entry)
           if (dayspmn /= 29) then
             omff_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             omff_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           omff_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         omff_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                     (omff_aerosol_interp, omff_time)
   endif

   if ( trim(ombb_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the ombb data set from which data is to be 
!    taken. if ombb is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(ombb_time_serie_type .eq. 3) then
       if (ombb_negative_offset) then
         ombb_time = model_time - ombb_offset
       else
         ombb_time = model_time + ombb_offset
       endif
     else 
       if(ombb_time_serie_type .eq. 2 ) then
         call get_date (ombb_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(ombb_entry)
           if (dayspmn /= 29) then
             ombb_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             ombb_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           ombb_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         ombb_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                  (ombb_aerosol_interp, ombb_time)
   endif

   if ( trim(ombf_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the ombf data set from which data is to be 
!    taken. if ombf is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(ombf_time_serie_type .eq. 3) then
       if (ombf_negative_offset) then
         ombf_time = model_time - ombf_offset
       else
         ombf_time = model_time + ombf_offset
       endif
     else 
       if(ombf_time_serie_type .eq. 2 ) then
         call get_date (ombf_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(ombf_entry)
           if (dayspmn /= 29) then
             ombf_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             ombf_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           ombf_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         ombf_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                 (ombf_aerosol_interp, ombf_time)
   endif

   if ( trim(omsh_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the omsh data set from which data is to be 
!    taken. if omsh is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(omsh_time_serie_type .eq. 3) then
       if (omsh_negative_offset) then
         omsh_time = model_time - omsh_offset
       else
         omsh_time = model_time + omsh_offset
       endif
     else 
       if(omsh_time_serie_type .eq. 2 ) then
         call get_date (omsh_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(omsh_entry)
           if (dayspmn /= 29) then
             omsh_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             omsh_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           omsh_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         omsh_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                       (omsh_aerosol_interp, omsh_time)
   endif

   if ( trim(omna_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the omna data set from which data is to be 
!    taken. if omna is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(omna_time_serie_type .eq. 3) then
       if (omna_negative_offset) then
         omna_time = model_time - omna_offset
       else
         omna_time = model_time + omna_offset
       endif
     else 
       if(omna_time_serie_type .eq. 2 ) then
         call get_date (omna_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(omna_entry)
           if (dayspmn /= 29) then
             omna_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             omna_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           omna_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         omna_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                                     (omna_aerosol_interp, omna_time)
   endif
   if ( trim(omss_source).ne. ' ') then
!--------------------------------------------------------------------
!    define the time in the omss data set from which data is to be 
!    taken. if omss is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(omss_time_serie_type .eq. 3) then
       if (omss_negative_offset) then
         omss_time = model_time - omss_offset
       else
         omss_time = model_time + omss_offset
       endif
     else 
       if(omss_time_serie_type .eq. 2 ) then
         call get_date (omss_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(omss_entry)
           if (dayspmn /= 29) then
             omss_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             omss_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           omss_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         omss_time = model_time
       endif
     endif
     call obtain_interpolator_time_slices   &
                                      (omss_aerosol_interp, omss_time)
  endif


end subroutine atmos_carbon_aerosol_time_vary 


!######################################################################

subroutine atmos_carbon_aerosol_endts 


   if ( trim(bcff_source) .ne. ' ') then
     call unset_interpolator_time_flag (bcff_aerosol_interp)
   endif

   if ( trim(bcbb_source).ne.' ') then
     call unset_interpolator_time_flag (bcbb_aerosol_interp)
   endif

   if ( trim(bcbf_source).ne. ' ') then
     call unset_interpolator_time_flag (bcbf_aerosol_interp)
   endif

   if ( trim(bcsh_source).ne. ' ') then
     call unset_interpolator_time_flag (bcsh_aerosol_interp)
   endif

   if ( trim(bcav_source).ne. ' ') then
     call unset_interpolator_time_flag (bcav_aerosol_interp)
   endif

   if ( trim(omff_source).ne. ' ') then
     call unset_interpolator_time_flag (omff_aerosol_interp)
   endif

   if ( trim(ombb_source).ne. ' ') then
     call unset_interpolator_time_flag (ombb_aerosol_interp)
   endif

   if ( trim(ombf_source).ne. ' ') then
     call unset_interpolator_time_flag (ombf_aerosol_interp)
   endif

   if ( trim(omsh_source).ne. ' ') then
     call unset_interpolator_time_flag (omsh_aerosol_interp)
   endif

   if ( trim(omna_source).ne. ' ') then
     call unset_interpolator_time_flag (omna_aerosol_interp)
   endif

   if ( trim(omss_source).ne. ' ') then
     call unset_interpolator_time_flag (omss_aerosol_interp)
  endif


end subroutine atmos_carbon_aerosol_endts 


!######################################################################


!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_carbon_aerosol_end">
!<OVERVIEW>
!  The destructor routine for the carbon module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits. 
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_carbon_aero_end
!</TEMPLATE>
 subroutine atmos_carbon_aerosol_end
      call interpolator_end ( bcff_aerosol_interp)
      call interpolator_end ( bcbb_aerosol_interp)
      call interpolator_end ( bcbf_aerosol_interp)
      call interpolator_end ( bcsh_aerosol_interp)
      call interpolator_end ( bcav_aerosol_interp)
      call interpolator_end ( omff_aerosol_interp)
      call interpolator_end ( ombb_aerosol_interp)
      call interpolator_end ( ombf_aerosol_interp)
      call interpolator_end ( omsh_aerosol_interp)
      call interpolator_end ( omna_aerosol_interp)
      call interpolator_end ( omss_aerosol_interp)
      module_is_initialized = .FALSE.

 end subroutine atmos_carbon_aerosol_end
!</SUBROUTINE>
!#######################################################################
end module atmos_carbon_aerosol_mod


module atmos_ch3i_mod


use mpp_mod, only: input_nml_file 
use            fms_mod, only : file_exist,   &
                               write_version_number, &
                               error_mesg, &
                               FATAL, &
                               NOTE, &
                               mpp_pe,  &
                               mpp_root_pe, &
                               lowercase,   &
                               open_namelist_file, &
                               check_nml_error, &
                               close_file,   &
                               stdlog
use  field_manager_mod, only : MODEL_ATMOS,          &
                               parse
use tracer_manager_mod, only : get_tracer_index,     &
                               get_tracer_names,     &
                               query_method
use   time_manager_mod, only : time_type
use   diag_manager_mod, only : send_data,            &
                               register_diag_field
use   interpolator_mod, only : interpolate_type,     &
                               interpolator_init,    &
                               obtain_interpolator_time_slices, &
                               unset_interpolator_time_flag, &
                               interpolator_end,     &
                               interpolator,         &
                               query_interpolator,   &
                               CONSTANT,             &
                               INTERP_WEIGHTED_P  
use      constants_mod, only : WTMAIR, &
                               AVOGNO, &
                               SECONDS_PER_DAY
implicit none

private
public :: atmos_ch3i_init, atmos_ch3i_time_vary, atmos_ch3i,  &
          atmos_ch3i_endts, atmos_ch3i_end

!-----------------------------------------------------------------------
!     ... namelist
!-----------------------------------------------------------------------
character(len=128) :: conc_filename = ''

namelist /atmos_ch3i_nml/    &
   conc_filename

logical :: has_emissions                      
character(len=128) :: emis_filename
type(interpolate_type), save :: ch3i_emissions, input_conc

character(len=128), allocatable :: field_names(:)

integer :: id_emissions, id_loss, id_j_ch3i, ind_ch3i
real, parameter :: g_to_kg    = 1.e-3,    & !conversion factor (kg/g)
                   m2_to_cm2  = 1.e4        !conversion factor (cm2/m2)
real, parameter :: emis_cons = WTMAIR * g_to_kg * m2_to_cm2 / AVOGNO        
real, parameter :: boltz = 1.38044e-16      ! Boltzmann's Constant (erg/K)


character(len=7), parameter :: module_name = 'tracers'
!---- version number -----
character(len=128) :: version = '$Id: atmos_ch3i.F90,v 18.0.2.1 2010/08/30 20:33:36 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical :: module_is_initialized = .FALSE.

contains

subroutine atmos_ch3i_init( lonb_mod, latb_mod, axes, Time, mask )

!-----------------------------------------------------------------------
!
!   mask = optional mask (0. or 1.) that designates which grid points
!          are above (=1.) or below (=0.) the ground dimensioned as
!          (nlon,nlat,nlev).
!
!-----------------------------------------------------------------------
   real, intent(in), dimension(:,:) :: lonb_mod
   real, intent(in), dimension(:,:) :: latb_mod
   type(time_type), intent(in) :: Time
   integer        , intent(in) :: axes(4)
   real, intent(in),    dimension(:,:,:), optional :: mask

!-----------------------------------------------------------------------

   integer ::  unit, nfields, flag_file
   integer :: ierr, io, logunit

   character(len=128) :: tracer_name, tracer_units, name, control

   if (module_is_initialized) then
      return
   end if

   ind_ch3i = get_tracer_index(MODEL_ATMOS, 'ch3i')

!-----------------------------------------------------------------------
!     ... write version number
!-----------------------------------------------------------------------
   call write_version_number(version, tagname)

!-----------------------------------------------------------------------
!     ... read namelist
!-----------------------------------------------------------------------
   if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=atmos_ch3i_nml, iostat=io)
     ierr = check_nml_error(io, 'atmos_ch3i_nml')
#else
     unit = open_namelist_file ()
     ierr=1; do while (ierr /= 0)
     read  (unit, nml=atmos_ch3i_nml, iostat=io, end=10)
     ierr = check_nml_error(io, 'atmos_ch3i_nml')
     enddo
10   call close_file (unit)
#endif
   endif

  
   logunit=stdlog()
   if(mpp_pe() == mpp_root_pe()) then       
      write(logunit, nml=atmos_ch3i_nml)
   endif
     
!-----------------------------------------------------------------------
!     ... set up emissions
!-----------------------------------------------------------------------
   has_emissions = .false.
   if( query_method('emissions',MODEL_ATMOS,ind_ch3i,name,control) ) then
      if( trim(name) == 'file' ) then
         flag_file = parse(control, 'file',emis_filename)
         if (flag_file > 0) then
            has_emissions = .true.
            call interpolator_init( ch3i_emissions, trim(emis_filename), &
                                    lonb_mod, latb_mod,  &
                                    data_out_of_bounds=(/CONSTANT/) )
            call query_interpolator(ch3i_emissions,nfields=nfields)
            allocate( field_names(nfields) )
            call query_interpolator(ch3i_emissions,field_names=field_names)
            id_emissions = register_diag_field( module_name, 'ch3i_emis', axes(1:2), &
                                                Time, 'ch3i_emis', 'molec/cm2/s' )
         else
            call error_mesg('atmos_ch3i_init','CH3I emission file not specified in field table',FATAL)
         end if
      else 
         call error_mesg('atmos_ch3i_init','CH3I emission file not specified in field table',FATAL)
      end if
   else
      call error_mesg('atmos_ch3i_init','No emissions specified for CH3I in field table',NOTE)
   end if

!-----------------------------------------------------------------------
!     ... set up tracer concentrations
!-----------------------------------------------------------------------
   if (conc_filename /= '') then
      call interpolator_init( input_conc,trim(conc_filename), lonb_mod, latb_mod,&
                              data_out_of_bounds=(/CONSTANT/), &
                              vert_interp=(/INTERP_WEIGHTED_P/) )
   end if


   call get_tracer_names( MODEL_ATMOS,ind_ch3i,tracer_name,units=tracer_units)
   id_loss =register_diag_field( module_name, 'ch3i_loss', axes(1:3), Time, 'ch3i_loss', TRIM(tracer_units)//'/s' )
   id_j_ch3i =register_diag_field( module_name, 'j_ch3i', axes(1:3), Time, 'j_ch3i', '/s' )

   module_is_initialized = .true.

end subroutine atmos_ch3i_init


!#####################################################################

subroutine atmos_ch3i_time_vary (Time)


type(time_type), intent(in) :: Time

      if (has_emissions) then
        call obtain_interpolator_time_slices (ch3i_emissions, Time)  
      endif
      if (conc_filename /= '') then
        call obtain_interpolator_time_slices (input_conc, Time)  
      endif

end subroutine atmos_ch3i_time_vary


!######################################################################

subroutine atmos_ch3i_endts              


      if (has_emissions) then
        call unset_interpolator_time_flag (ch3i_emissions)  
      endif
      if (conc_filename /= '') then
        call unset_interpolator_time_flag (input_conc)  
      endif

end subroutine atmos_ch3i_endts


!-----------------------------------------------------------------------

subroutine atmos_ch3i( lon, lat, land, pwt, ch3i, ch3i_dt,       &
                       Time, phalf, pfull, t, is, js, dt,    &
                       z_half, z_full, q, tsurf, albedo, coszen, &
                       Time_next, kbot)

real, intent(in),    dimension(:,:)            :: lon, lat
real, intent(in),    dimension(:,:)            :: land
real, intent(in),    dimension(:,:,:)          :: pwt
real, intent(in),    dimension(:,:,:)          :: ch3i
real, intent(out),   dimension(:,:,:)          :: ch3i_dt
type(time_type), intent(in)                    :: Time, Time_next     
integer, intent(in)                            :: is,js
real, intent(in),    dimension(:,:,:)          :: phalf,pfull,t
real, intent(in)                               :: dt !to be passed into chemdr
real, intent(in),    dimension(:,:,:)          :: z_half !height in meters at half levels
real, intent(in),    dimension(:,:,:)          :: z_full !height in meters at full levels
real, intent(in),    dimension(:,:,:)          :: q !specific humidity at current time step in kg/kg
real, intent(in),    dimension(:,:)            :: tsurf !surface temperature
real, intent(in),    dimension(:,:)            :: albedo
real, intent(in),    dimension(:,:)            :: coszen
integer, intent(in),  dimension(:,:), optional :: kbot

!-----------------------------------------------------------------------

logical :: used
integer :: i, j, k, id, jd, kd, kb
real, dimension(size(ch3i,1),size(ch3i,2),size(ch3i,3)) :: &
   conc_o3, conc_oh, j_ch3i, k_ch3i_oh, &
   emis_source, ch3i_loss, &
   air_dens
real, dimension(size(ch3i,1),size(ch3i,2)) :: emis,temp_data

!   <ERROR MSG="tracer_driver_init must be called first." STATUS="FATAL">
!     Tracer_driver_init needs to be called before tracer_driver.
!   </ERROR>
if (.not. module_is_initialized)  &
   call error_mesg ('atmos_ch3i','atmos_ch3i_init must be called first1', FATAL)

id=size(ch3i,1); jd=size(ch3i,2); kd=size(ch3i,3)

!-----------------------------------------------------------------------
!     ... Get emissions
!-----------------------------------------------------------------------
emis_source(:,:,:) = 0.
emis(:,:) = 0.
if (has_emissions) then
   do k = 1,size(field_names)
      call interpolator( ch3i_emissions, Time, temp_data, field_names(k), is, js )
      emis(:,:) = emis(:,:) + temp_data(:,:)
   end do
   if (present(kbot)) then
      do j=1,jd
         do i=1,id
            kb=kbot(i,j)
            emis_source(i,j,kb) = emis(i+is,j+js)/pwt(i,j,kb) * emis_cons
         enddo
      enddo
   else
      emis_source(:,:,kd) = emis(:,:)/pwt(:,:,kd) * emis_cons
   end if
   used = send_data(id_emissions,emis,Time,is_in=is,js_in=js)
end if

!-----------------------------------------------------------------------
!     ... Get tracer concentrations
!-----------------------------------------------------------------------
call interpolator(input_conc, Time, phalf, conc_o3, 'ox')
call interpolator(input_conc, Time, phalf, conc_oh, 'oh')

air_dens(:,:,:) = 10. * pfull(:,:,:) / (boltz*t(:,:,:)) ! molec/cm3
conc_oh(:,:,:) = conc_oh(:,:,:) * air_dens(:,:,:) ! convert VMR to molec/cm3

!-----------------------------------------------------------------------
!     ... reaction rates
!-----------------------------------------------------------------------
k_ch3i_oh(:,:,:) = 2.9e-12 * exp( -1100./t(:,:,:) ) ! s^-1
do k = 1,kd
   where( coszen(:,:) > 0. )
      j_ch3i(:,:,k) = 2./(4.*SECONDS_PER_DAY) ! s^-1
   elsewhere
      j_ch3i(:,:,k) = 0.
   endwhere
end do
ch3i_loss(:,:,:) = ( j_ch3i(:,:,:) + k_ch3i_oh(:,:,:)*conc_oh(:,:,:) ) &
                 * ch3i(:,:,:) ! VMR/s
used = send_data( id_loss, ch3i_loss, Time, is_in=is, js_in=js )
used = send_data( id_j_ch3i, j_ch3i, Time, is_in=is, js_in=js )

ch3i_dt(:,:,:) = emis_source(:,:,:) - ch3i_loss(:,:,:)


end subroutine atmos_ch3i

!-----------------------------------------------------------------------

subroutine atmos_ch3i_end

   deallocate( field_names )
   module_is_initialized = .FALSE.

end subroutine atmos_ch3i_end

end module atmos_ch3i_mod


module atmos_co2_mod
! <CONTACT EMAIL="rdslater@splash.princeton.edu">
!   Richard D. Slater
! </CONTACT>

! <REVIEWER EMAIL="none@nowhere.dot">
!   none yet
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
! </OVERVIEW>

! <DESCRIPTION>
! </DESCRIPTION>


use mpp_mod, only: input_nml_file 
use              fms_mod, only : file_exist, write_version_number,    &
                                 mpp_pe, mpp_root_pe,                 &
                                 close_file, stdlog, stdout,          &
                                 check_nml_error, error_mesg,         &
                                 open_namelist_file, FATAL, NOTE, WARNING

use   tracer_manager_mod, only : get_tracer_index, tracer_manager_init
use    field_manager_mod, only : MODEL_ATMOS
use     diag_manager_mod, only : register_diag_field, send_data
use     time_manager_mod, only : time_type
use        constants_mod, only : WTMCO2, WTMAIR, WTMC
use    data_override_mod, only : data_override
use              mpp_mod, only : mpp_pe, mpp_root_pe


implicit none

private

!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_co2_sourcesink
public  atmos_co2_emissions
public  atmos_co2_rad
public  atmos_co2_gather_data
public  atmos_co2_flux_init
public  atmos_co2_init
public  atmos_co2_end

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------

character(len=48), parameter    :: mod_name = 'atmos_co2_mod'

integer, save   :: ind_co2_flux = 0
integer, save   :: ind_co2  = 0
integer, save   :: ind_sphum = 0
integer         :: id_co2restore, id_pwt, id_co2_mol_emiss, id_co2_emiss_orig
real            :: radiation_co2_dvmr = -1

!---------------------------------------------------------------------
!-------- namelist  ---------

real     :: restore_tscale   = -1
integer  :: restore_klimit   = -1
logical  :: do_co2_restore   = .false.
logical  :: co2_radiation_override = .false.
logical  :: do_co2_emissions = .false.

namelist /atmos_co2_nml/  &
          do_co2_restore, restore_tscale, restore_klimit,  &
          co2_radiation_override, do_co2_emissions

!-----------------------------------------------------------------------
!
!  When initializing additional tracers, the user needs to make the
!  following changes.
!
!  Add an integer variable below for each additional tracer. This should
!  be initialized to zero. 
!
!  Add id_tracername for each additional tracer. These are used in
!  initializing and outputting the tracer fields.
!
!-----------------------------------------------------------------------

!PUBLIC VARIABLES
public :: co2_radiation_override, do_co2_emissions

logical :: module_is_initialized = .FALSE.


!---- version number -----
character(len=128) :: version = '$$'
character(len=128) :: tagname = '$$'
!-----------------------------------------------------------------------

contains

!#######################################################################

!<SUBROUTINE NAME ="atmos_co2_sourcesink">
!<OVERVIEW>
!  A subroutine to calculate the internal sources and sinks of carbon dioxide.
!
! do_co2_restore   = logical to turn co2_restore on/off: default = .false.
! restore_co2_dvmr = partial pressure of co2 to which to restore  (mol/mol)
! restore_klimit   = atmospheric level to which to restore starting from top
! restore_tscale   = timescale in seconds with which to restore
!
!</OVERVIEW>
!<DESCRIPTION>
! A routine to calculate the sources and sinks of carbon dixoide.
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_co2_sourcesink (Time, dt,  pwt, co2, sphum, co2_restore)
!
!</TEMPLATE>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="dt" TYPE="real">
!     Model timestep.
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     The pressure weighting array. = dP/grav (kg/m2)
!   </IN>
!   <IN NAME="co2" TYPE="real" DIM="(:,:,:)">
!     The array of the carbon dioxide mixing ratio (kg co2/kg moist air)
!   </IN>
!   <IN NAME="sphum" TYPE="real" DIM="(:,:,:)">
!     The array of the specific humidity mixing ratio (kg/kg)
!   </IN>

!   <OUT NAME="co2_restore" TYPE="real" DIM="(:,:,:)">
!     The array of the restoring tendency of the carbon dioxide mixing ratio.
!   </OUT>
!

subroutine atmos_co2_sourcesink(Time, dt, pwt, co2, sphum, co2_restore)

   type (time_type),      intent(in)   :: Time
   real, intent(in)                    :: dt
   real, intent(in),  dimension(:,:,:) :: pwt          ! kg/m2
   real, intent(in),  dimension(:,:,:) :: co2          ! moist mmr
   real, intent(in),  dimension(:,:,:) :: sphum        
   real, intent(out), dimension(:,:,:) :: co2_restore
!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_sourcesink'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'


integer   :: i,j,k,id,jd,kd, logunit
logical   :: sent
logical   :: used
real      :: restore_co2_dvmr = -1

!-----------------------------------------------------------------------

id=size(co2,1); jd=size(co2,2); kd=min(size(co2,3),restore_klimit)

co2_restore(:,:,:)=0.0

logunit=stdlog()
if (ind_co2 > 0 .and. do_co2_restore) then

! input is in dvmr (mol/mol)
  call data_override('ATM', 'co2_dvmr_restore', restore_co2_dvmr, Time, override=used)
  if (.not. used) then
    call error_mesg (trim(error_header), ' data override needed for co2_dvmr_restore ', FATAL)
  endif
!  if (mpp_pe() == mpp_root_pe() ) &
!      write (logunit,*)' atmos_co2_sourcesink: mean restore co2_dvmr   = ', restore_co2_dvmr


  if (restore_tscale .gt. 0 .and. restore_co2_dvmr .ge. 0.0) then
! co2mmr = (wco2/wair) * co2vmr;  wet_mmr is approximated as dry_mmr * (1-Q)
    do k=1,kd
      do j=1,jd
        do i=1,id
! convert restore_co2_dvmr to wet mmr and get tendency
          co2_restore(i,j,k) = (restore_co2_dvmr * (WTMCO2/WTMAIR) * (1.0 - &
                           sphum(i,j,k)) - co2(i,j,k))/restore_tscale
        enddo
      enddo
    enddo

! restoring diagnostic in moles co2/m2/sec 
! pwt is moist air, so no need to divide by 1-sphum here
    if (id_co2restore > 0) sent = send_data (id_co2restore, co2_restore  *  &
                                         pwt / (WTMCO2*1.e-3), Time)
  endif

!else
!  if (mpp_pe() == mpp_root_pe() ) &
!      write (logunit,*)' atmos_co2_sourcesink: CO2 restoring not active: ',do_co2_restore
endif

!! add pwt as a diagnostic
if (id_pwt > 0) sent = send_data (id_pwt, pwt, Time)


end subroutine atmos_co2_sourcesink
!</SUBROUTINE >


!#######################################################################

!<SUBROUTINE NAME ="atmos_co2_rad">

!<OVERVIEW>
! Subroutine to get global avg co2 to be used in radiation.
! input co2 field is from data override 
!</OVERVIEW>

 subroutine atmos_co2_rad(Time, radiation_co2_dvmr)

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!
   type (time_type),      intent(in)    :: Time
   real,                  intent(inout) :: radiation_co2_dvmr
!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_rad'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
integer :: logunit
logical   :: used
!-----------------------------------------------------------------------

logunit=stdlog()

if (ind_co2 > 0 .and. co2_radiation_override) then

! input is in dvmr (mol/mol)
  call data_override('ATM', 'co2_dvmr_rad', radiation_co2_dvmr, Time, override=used)
  if (.not. used) then
    call error_mesg (trim(error_header), ' data override needed for co2_dvmr_rad ', FATAL)
  endif
!  if (mpp_pe() == mpp_root_pe() ) &
!      write (logunit,*)' atmos_co2_rad       : mean radiation co2_dvmr = ', radiation_co2_dvmr

!else
!  if (mpp_pe() == mpp_root_pe() ) &
!      write (logunit,*)' atmos_co2_rad: CO2 radiation override not active: ',co2_radiation_override
endif


!-----------------------------------------------------------------------

end subroutine atmos_co2_rad
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME ="atmos_co2_emissions">
!<OVERVIEW>
!  A subroutine to calculate the internal sources and sinks of carbon dioxide
!  from input co2 emissions data.
!
! do_co2_emissions   = logical to activate using co2 emissions: default = .false.
!
!</OVERVIEW>
!<DESCRIPTION>
! A routine to calculate the sources and sinks of carbon dixoide from co2 emissions.
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_co2_emissions (Time, dt,  pwt, co2, sphum, co2_emiss_dt, kbot)
!
!</TEMPLATE>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="dt" TYPE="real">
!     Model timestep.
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     The pressure weighting array. = dP/grav (kg/m2)
!   </IN>
!   <IN NAME="co2" TYPE="real" DIM="(:,:,:)">
!     The array of the carbon dioxide mixing ratio (kg co2/kg moist air)
!   </IN>
!   <IN NAME="sphum" TYPE="real" DIM="(:,:,:)">
!     The array of the specific humidity mixing ratio (kg/kg)
!   </IN>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>

!   <OUT NAME="co2_emiss_dt" TYPE="real" DIM="(:,:,:)">
!     The array of the restoring tendency of the carbon dioxide emissions
!   </OUT>
!
!

subroutine atmos_co2_emissions(is, ie, js, je, Time, dt, pwt, co2, sphum, co2_emiss_dt, kbot)

   integer, intent(in)                 :: is, ie, js, je
   type (time_type),      intent(in)   :: Time
   real, intent(in)                    :: dt
   real, intent(in),  dimension(:,:,:) :: pwt          ! kg/m2
   real, intent(in),  dimension(:,:,:) :: co2          ! moist mmr
   real, intent(in),  dimension(:,:,:) :: sphum        
   real, intent(out), dimension(:,:,:) :: co2_emiss_dt 
   integer, intent(in),  dimension(:,:), optional :: kbot
!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_emissions'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'


integer   :: i,j,k,id,jd,kd,kb, logunit
logical   :: sent
real, dimension(size(co2,1),size(co2,2),size(co2,3)) ::  co2_emis_source
real      ::  co2_emis2d(is:ie, js:je)
logical   :: used


!---------------------------------------------------------------------------------------
! Original IPCC AR5 historical CO2 emissions converted to kg C/m2/sec 
! Assume scenario input will be in same format/units
!---------------------------------------------------------------------------------------

id=size(co2,1); jd=size(co2,2); kd=size(co2,3)

co2_emis2d(:,:)=0.0
co2_emis_source(:,:,:)=0.0
co2_emiss_dt(:,:,:)=0.0

logunit=stdlog()
if (ind_co2 > 0 .and. do_co2_emissions) then

  call data_override('ATM', 'co2_emiss', co2_emis2d, Time, override=used)
  if (id_co2_emiss_orig > 0) sent = send_data (id_co2_emiss_orig, co2_emis2d, Time)

  if (.not. used) then
    call error_mesg (trim(error_header), ' data override needed for co2 emission ', FATAL)
  endif

! lowest model layer
    do j=1,jd
      do i=1,id
        co2_emis_source(i,j,kd) = co2_emis2d(i,j) * (WTMCO2/WTMC) / pwt(i,j,kd)
      enddo
    enddo
  
  co2_emiss_dt = co2_emis_source

! co2 mol emission diagnostic in moles CO2/m2/sec 
  if (id_co2_mol_emiss > 0) sent = send_data (id_co2_mol_emiss,   &
                 co2_emiss_dt(:,:,kd)*pwt(:,:,kd)/(WTMCO2*1.e-3), Time)

endif


end subroutine atmos_co2_emissions
!</SUBROUTINE >


!#######################################################################

!<SUBROUTINE NAME ="atmos_co2_gather_data">
!<OVERVIEW>
!  A subroutine to gather fields needed for calculating the CO2 gas flux
!</OVERVIEW>
!

subroutine atmos_co2_gather_data (gas_fields, tr_bot)

use coupler_types_mod, only: coupler_2d_bc_type, ind_pcair

implicit none

!-----------------------------------------------------------------------

type(coupler_2d_bc_type), intent(inout) :: gas_fields
real, dimension(:,:,:), intent(in)      :: tr_bot

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_gather_data'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!-----------------------------------------------------------------------

!-----------------------------------------------------------------------

! 2008/06/17 JPD/jgj: OCMIP calculation expects pco2 in dry vmr (mol/mol) units 
! atm co2 is in moist mass mixing ratio (kg co2/kg moist air)
! tr_bot: co2 bottom layer moist mass mixing ratio
! convert to dry_mmr and then to dry_vmr for ocean model.
! dry_mmr = wet_mmr / (1-Q); co2vmr = (wair/wco2) * co2mmr

if (ind_co2_flux .gt. 0) then
  gas_fields%bc(ind_co2_flux)%field(ind_pcair)%values(:,:) = (tr_bot(:,:,ind_co2) / &
       (1.0 - tr_bot(:,:,ind_sphum))) * (WTMAIR/gas_fields%bc(ind_co2_flux)%mol_wt)
endif

end subroutine atmos_co2_gather_data
!</SUBROUTINE >

!#######################################################################


!#######################################################################

!<SUBROUTINE NAME ="atmos_co2_flux_init">

!<OVERVIEW>
! Subroutine to initialize the carbon dioxide flux
!</OVERVIEW>

 subroutine atmos_co2_flux_init

use atmos_ocean_fluxes_mod, only: aof_set_coupler_flux

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

integer :: n

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_flux_init'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

integer :: logunit

if ( .not. module_is_initialized) then

!----- set initial value of carbon ------------

  call tracer_manager_init      ! need to call here since the ocean pes never call it
  n = get_tracer_index(MODEL_ATMOS,'co2')
  if (n > 0) then
    ind_co2 = n
    if (ind_co2 > 0) then
      logunit=stdout()
      write (logunit,*) trim(note_header), ' CO2 was initialized as tracer number ', ind_co2
      logunit=stdlog()
      write (logunit,*) trim(note_header), ' CO2 was initialized as tracer number ', ind_co2
    endif
  endif
  module_is_initialized = .TRUE.
endif

!
!       initialize coupler flux
!

if (ind_co2 > 0) then
  ind_co2_flux = aof_set_coupler_flux('co2_flux',                       &
       flux_type = 'air_sea_gas_flux', implementation = 'ocmip2',       &
       atm_tr_index = ind_co2,                                          &
       mol_wt = WTMCO2, param = (/ 9.36e-07, 9.7561e-06 /),              &
       caller = trim(mod_name) // '(' // trim(sub_name) // ')')
endif

!-----------------------------------------------------------------------

end subroutine atmos_co2_flux_init
!</SUBROUTINE>


!#######################################################################

!<SUBROUTINE NAME ="atmos_co2_init">

!<OVERVIEW>
! Subroutine to initialize the carbon dioxide module.
!</OVERVIEW>

 subroutine atmos_co2_init (Time, axes)

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

type(time_type),  intent(in)                        :: Time
integer, dimension(3), intent(in)                   :: axes

!
!-----------------------------------------------------------------------
!     local variables
!         unit       io unit number used to read namelist file
!         ierr       error code
!         io         error status returned from io operation
!-----------------------------------------------------------------------
!
integer :: ierr, unit, io, logunit
integer :: n
real    :: missing_value = -1.e10
character(len=64) :: desc
!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_init'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'


     if (module_is_initialized) return

     call write_version_number (version, tagname)

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=atmos_co2_nml, iostat=io)
        ierr = check_nml_error(io,'atmos_co2_nml')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=atmos_co2_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'atmos_co2_nml')
        end do
10      call close_file (unit)
#endif
      endif

!---------------------------------------------------------------------
!    write namelist to logfile.
!---------------------------------------------------------------------
      logunit=stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=atmos_co2_nml)

!----- set initial value of carbon ------------

n = get_tracer_index(MODEL_ATMOS,'co2')
if (n > 0) then
  ind_co2 = n
    logunit=stdout()
    write (logunit,*) trim(note_header), ' CO2 was initialized as tracer number ', ind_co2
    logunit=stdlog()
    write (logunit,*) trim(note_header), ' CO2 was initialized as tracer number ', ind_co2

 ! initialize diagnostics

   desc = ' restoring tendency'

   id_co2restore  = register_diag_field ('atmos_co2_restoring', 'co2_restore', axes, Time, &
                   'CO2'//trim(desc), 'moles co2/m2/s',missing_value=missing_value)

   desc = ' pressure weighting array = dP/grav'
   id_pwt    = register_diag_field ('atmos_co2', 'pwt', axes, Time, &
                   trim(desc), 'kg/m2',missing_value=missing_value)

   desc = ' mol emission'
   id_co2_mol_emiss = register_diag_field ('atmos_co2_emissions', 'co2_mol_emission', axes(1:2), Time, &
                      'CO2'//trim(desc), 'moles co2/m2/s',missing_value=missing_value)

   desc = ' emission_orig'
   id_co2_emiss_orig = register_diag_field ('atmos_co2_emissions', 'co2_emissions_orig', axes(1:2), Time, &
                   'CO2'//trim(desc), 'kg C/m2/s',missing_value=missing_value)

!
!       get the index for sphum
!

  ind_sphum = get_tracer_index(MODEL_ATMOS,'sphum')
  if (ind_sphum .le. 0) then
    call error_mesg (trim(error_header), ' Could not find index for sphum', FATAL)
  endif

endif

logunit=stdlog()
if (.not.(ind_co2 > 0 .and. do_co2_restore)) then
   if (mpp_pe() == mpp_root_pe() ) &
     write (logunit,*)' CO2 restoring not active:do_co2_restore= ',do_co2_restore
endif

if (.not.(ind_co2 > 0 .and. co2_radiation_override)) then
   if (mpp_pe() == mpp_root_pe() ) &
     write (logunit,*)' CO2 radiation override not active:co2_radiation_override= ',co2_radiation_override
endif

if (.not.(ind_co2 > 0 .and. do_co2_emissions)) then
   if (mpp_pe() == mpp_root_pe() ) &
     write (logunit,*)' not using CO2 emissions: do_co2_emissions= ',do_co2_emissions
endif

call write_version_number (version, tagname)
module_is_initialized = .TRUE.


!-----------------------------------------------------------------------

end subroutine atmos_co2_init
!</SUBROUTINE>


!<SUBROUTINE NAME ="atmos_co2_end">
subroutine atmos_co2_end

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_co2_end'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

   module_is_initialized = .FALSE.

end subroutine atmos_co2_end
!</SUBROUTINE>


end module atmos_co2_mod


module atmos_convection_tracer_mod
! <CONTACT EMAIL="rsh@gfdl.noaa.gov">
!   Richard Hemler
! </CONTACT>

! <REVIEWER EMAIL="lwh@gfdl.noaa.gov">
!                    
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code allows the incorporation of an arbitrarily-specified   
!     tracer for testing within the donner_deep module.
!
!    This module is to serve as a testbed for assessing convective 
!    transport of tracers. 
! </OVERVIEW>

! <DESCRIPTION>
!   This module presents an implementation of an arbirary tracer, 
!   including its convective transport by the donner_deep module.
! </DESCRIPTION>

!-----------------------------------------------------------------------

use              fms_mod,       only : file_exist, &
                                       write_version_number, &
                                       error_mesg, &
                                       FATAL,WARNING,NOTE, &
                                       mpp_pe, mpp_root_pe, stdlog
use     time_manager_mod,       only : time_type
use     diag_manager_mod,       only : send_data,            &
                                       register_static_field
use   tracer_manager_mod,       only : get_tracer_index
use    field_manager_mod,       only : MODEL_ATMOS
use atmos_tracer_utilities_mod, only : wet_deposition,       &
                                       dry_deposition


implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_cnvct_tracer_sourcesink,  &
        atmos_convection_tracer_init,        &
        atmos_convection_tracer_end

!-----------------------------------------------------------------------
!----------- namelist -------------------

integer  :: ncopies_cnvct_trcr = 9

namelist /atmos_convection_tracer_nml/  &
                                        ncopies_cnvct_trcr

!-----------------------------------------------------------------------

!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'


!--- identification numbers for  diagnostic fields and axes ----

integer :: id_emiss

logical :: module_is_initialized=.FALSE.


!---- version number -----
character(len=128) :: version = '$Id: atmos_convection_tracer.F90,v 17.0.4.1 2010/03/17 20:27:11 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################
!<SUBROUTINE NAME="atmos_cnvct_tracer_sourcesink">
!<OVERVIEW>
! The routine that calculate the sources and sinks of the 
! convection tracer.
!</OVERVIEW>
!<DESCRIPTION>
! This is an implementation of an arbitrarily-specified tracer.
! At this time it is assumed to have no source or sink.
!
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_cnvct_tracer_sourcesink (lon, lat, land, pwt, convtr, 
!                                         convtr_dt, Time, is, ie, 
!                                         js, je, kbot)
!</TEMPLATE>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     Longitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!     Latitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="land" TYPE="real" DIM="(:,:)">
!     Land/sea mask.
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     The pressure weighting array. = dP/grav
!   </IN>
!   <IN NAME="convtr" TYPE="real" DIM="(:,:,:)">
!     The array of the convection tracer mixing ratio.
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="is, ie, js, je" TYPE="integer">
!     Local domain boundaries.
!   </IN>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>

!   <OUT NAME="convtr_dt" TYPE="real" DIM="(:,:,:)">
!     The array of the tendency of the convection tracer mixing ratio.
!   </OUT>
 subroutine atmos_cnvct_tracer_sourcesink (lon, lat, land, pwt,&
                                                convtr, convtr_dt,  &
                                                Time, is, ie, js, je, &
                                                kbot)

!-----------------------------------------------------------------------
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:)   :: land
   real, intent(in),  dimension(:,:,:) :: pwt, convtr
   real, intent(out), dimension(:,:,:) :: convtr_dt
     type(time_type), intent(in) :: Time     
   integer,           intent(in)       :: is, ie, js, je
integer, intent(in),  dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
   real, dimension(size(convtr,1),size(convtr,2),size(convtr,3)) ::  &
         source, sink
!-----------------------------------------------------------------------


!------  define source and sink of convection_tracer -------
!
!   it is currently assumed that the convection tracer has no source
!   or sink

      source = 0.
      sink   = 0.

!------- tendency ------------------

      convtr_dt = source + sink
      

!-----------------------------------------------------------------------

 end subroutine atmos_cnvct_tracer_sourcesink
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_convection_tracer_init">
!<OVERVIEW>
! The constructor routine for the convection tracer module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to initialize the convection tracer module.
!</DESCRIPTION>
!<TEMPLATE>
!call convection_tracer_init (r, phalf, mask, axes, Time)
!</TEMPLATE>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
!   <IN NAME="phalf" TYPE="real" DIM="(:,:,:)">
!      pressure at model interface levels
!   </IN>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>
 subroutine atmos_convection_tracer_init (r, phalf, axes, Time, &
                                          nconvect, mask)

!-----------------------------------------------------------------------
!
!   r    = tracer fields dimensioned as (nlon,nlat,nlev,ntrace)
!   mask = optional mask (0. or 1.) that designates which grid points
!          are above (=1.) or below (=0.) the ground dimensioned as
!          (nlon,nlat,nlev).
!
!-----------------------------------------------------------------------
real,             intent(inout), dimension(:,:,:,:) :: r
real,             intent(in),    dimension(:,:,:)   :: phalf
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
integer, dimension(:), pointer                         :: nconvect
real, intent(in), dimension(:,:,:), optional        :: mask

integer :: n
character(len=64) ::  search_name (10)
character(len=4) ::  chname
integer :: nn
!
!-----------------------------------------------------------------------
!
      real, dimension (size(r,1), size(r,2), size(r,3)) :: xgcm, pfull

      real :: xba = 1.0
      integer :: nlev, k, logunit
      character(len=64) :: filename

      nlev = size(r,3)

!---------------------------------------------------------------------
      if (module_is_initialized) return

!---- write namelist ------------------

      call write_version_number (version, tagname)
      logunit=stdlog()
      if ( mpp_pe() == mpp_root_pe() ) &
        write ( logunit, nml=atmos_convection_tracer_nml )

!----- set initial value of convection tracer ------------

       if (ncopies_cnvct_trcr > 9) then
         call error_mesg ('atmos_convection_tracer_mod', &
         'currently no more than 9 copies of the convection tracer '//&
                                             'are allowed', FATAL)
       endif
       allocate (nconvect(ncopies_cnvct_trcr))
       nconvect = -1
 
       
        do nn=1,ncopies_cnvct_trcr
          write (chname,'(i1)') nn
          if (nn > 1) then
          search_name(nn) = 'cnvct_trcr_'// trim(chname)
          else
          search_name(nn) = 'cnvct_trcr'
          endif

       n = get_tracer_index(MODEL_ATMOS,search_name(nn) )
       if (n>0) then
         nconvect(nn)=n
         if (nconvect(nn) > 0 .and. mpp_pe() == mpp_root_pe()) write (*,30) trim(search_name(nn))  ,nconvect(nn)
         if (nconvect(nn) > 0 .and. mpp_pe() == mpp_root_pe()) write (logunit,30) trim(search_name(nn))  ,nconvect(nn)
       endif

      end do

  30        format (A,' was initialized as tracer number ',i2)
!

! Register a static field for the emissions of your tracer
     id_emiss = register_static_field ( 'tracers',                    &
                     'rnemiss', axes(1:2),       &
                     'rnemiss', 'g/m2/s')

!---------------------------------------------------------------------
!    if a convection_tracer.res file exists, it will have been prev-
!    iously processed. there is no need to do anything here.
!---------------------------------------------------------------------
      do nn = 1, ncopies_cnvct_trcr 
        if (nconvect(nn) > 0) then
          filename = 'INPUT/tracer_' //trim(search_name(nn)) // '.res'
          if (file_exist (filename)) then

!--------------------------------------------------------------------
!    if a .res file does not exist, initialize the convection_tracer.
!--------------------------------------------------------------------
          else   
            do k=1, nlev
              pfull(:,:,k) = 0.5*(phalf(:,:,k) + phalf(:,:,k+1))
            end do
            do k=1,nlev
              xgcm(:,:,k) = xba*  &
                           exp((pfull(:,:,k) - pfull(:,:,1))/       &
                               (pfull(:,:,1) - pfull(:,:,nlev)))
            end do
            do k=1,nlev
              r(:,:,nlev+1-k, nconvect(nn)) = xgcm(:,:,k)
            end do
          endif  ! (file_exist) 
        endif
      end do



      module_is_initialized = .TRUE.


!-----------------------------------------------------------------------

 end subroutine atmos_convection_tracer_init
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_convection_tracer_end">
!<OVERVIEW>
!  The destructor routine for the convection tracer module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine marks the module as uninitialized and exits. 
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_convection_tracer_end
!</TEMPLATE>
 subroutine atmos_convection_tracer_end
 
      module_is_initialized = .FALSE.

 end subroutine atmos_convection_tracer_end
!</SUBROUTINE>


end module atmos_convection_tracer_mod





module atmos_dust_mod
! <DESCRIPTION>
!   This module evaluates the change of mass mixing ratio for mineral dust
!   particles due to their emission from preferential sources, and the removal
!   by gravitational settling. The dust particles are transported as dry
!   particles. No hygroscopic growth is considered.
!   The size distribution of sea salt ranges from 0.1 to 10 um (dry radius)
!   and is divided into 5 bins. For each bin, the volume size distribution
!   dV/dlnr is considered constant.
! </DESCRIPTION>
! <CONTACT EMAIL="Paul.Ginouxe@noaa.gov">
!   Paul Ginoux
! </CONTACT>
!-----------------------------------------------------------------------

use mpp_mod, only: input_nml_file 
use              fms_mod, only : file_exist, &
                                 write_version_number, &
                                 mpp_pe, &
                                 mpp_root_pE, &
                                 close_file,           &
                                 open_namelist_file, file_exist,    &
                                 check_nml_error, error_mesg,  &
                                 stdlog
use     time_manager_mod, only : time_type
use     diag_manager_mod, only : send_data,            &
                                 register_diag_field
use   tracer_manager_mod, only : get_tracer_index, &
                                 set_tracer_atts
use    field_manager_mod, only : MODEL_ATMOS
use atmos_tracer_utilities_mod, only : wet_deposition,       &
                                 dry_deposition
use interpolator_mod,    only:  interpolate_type, interpolator_init, &
                                obtain_interpolator_time_slices, &
                                unset_interpolator_time_flag, &
                                interpolator, interpolator_end, &
                                CONSTANT, INTERP_WEIGHTED_P
use     constants_mod, only : PI, GRAV, RDGAS, DENS_H2O, PSTD_MKS, WTMAIR


implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_dust_sourcesink, atmos_dust_init, atmos_dust_end, &
        atmos_dust_time_vary, atmos_dust_endts

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------

!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'

integer :: ndust=0  ! tracer number for dust
!--- identification numbers for  diagnostic fields and axes ----

integer :: id_dust_emis(5), id_dust_setl(5)
integer :: id_dust_source

!--- Arrays to help calculate tracer sources/sinks ---
type(interpolate_type),save         ::  dust_source_interp


logical :: module_is_initialized=.FALSE.
logical :: used

real, save :: u_ts
real, save :: ch

!---------------------------------------------------------------------
!-------- namelist  ---------
character(len=32)  :: dust_source_filename = 'dust_source_1x1.nc'
character(len=32)  :: dust_source_name(1) = 'source'
real :: uthresh=-999.
real :: coef_emis =-999.

namelist /dust_nml/  dust_source_filename, dust_source_name, uthresh, coef_emis

!---- version number -----
character(len=128) :: version = '$Id: atmos_dust.F90,v 18.0.2.1 2010/08/30 20:39:47 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################
!<SUBROUTINE NAME="atmos_dust_sourcesink">
!<OVERVIEW>
! The routine that calculate the sources and sinks of dust.
!</OVERVIEW>
 subroutine atmos_dust_sourcesink (i_DU,ra,rb,dustref,dustden, &
       lon, lat, frac_land, pwt, &
       zhalf, pfull, w10m, t, rh, &
       dust, dust_dt, dust_emis, dust_setl, Time, is,ie,js,je,kbot)

!-----------------------------------------------------------------------
   integer, intent(in)                 :: i_DU
   real, intent(in)                    :: ra
   real, intent(in)                    :: rb
   real, intent(in)                    :: dustref
   real, intent(in)                    :: dustden
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:)   :: frac_land
   real, intent(in),  dimension(:,:)   :: w10m
   real, intent(out),  dimension(:,:)  :: dust_setl, dust_emis
   real, intent(in),  dimension(:,:,:) :: pwt, dust
   real, intent(in),  dimension(:,:,:) :: zhalf, pfull, t, rh
   real, intent(out), dimension(:,:,:) :: dust_dt
   type(time_type), intent(in) :: Time     
   integer, intent(in),  dimension(:,:), optional :: kbot
integer, intent(in)                    :: is, ie, js, je
!-----------------------------------------------------------------------
integer  i, j, k, id, jd, kd, kb
!----------------------------------------------
!     Dust parameters
!----------------------------------------------
      real, dimension(5) ::   frac_s

      real, dimension(size(dust,3)) :: setl
      real, dimension(size(dust,1),size(dust,2)) :: u_ts_2d, source

      real, parameter :: small_value = 1.e-20
      real, parameter :: mtcm = 100.            ! meter to cm
      real, parameter :: mtv  = 1. ! factor conversion for mixing ratio of dust
      real, parameter :: ptmb = 0.01     ! pascal to mb

      real :: rhb, rcm
      real :: ratio_r, rho_wet_dust, viscosity, free_path, C_c, vdep
      real :: rho_air
      real :: rwet
!-----------------------------------
!    SET-Up  DATA
!-----------------------------------

!yim: per pag 2/1/08
!     data frac_s/0.1,0.225,0.225,0.225,0.225/
      data frac_s/0.05,0.1125,0.225,0.225,0.225/

!-----------------------------------------------------------------------

      id=size(dust,1); jd=size(dust,2); kd=size(dust,3)

     u_ts_2d(:,:) = u_ts 
!----------- compute dust emission ------------
      dust_emis(:,:)   = 0.0
      dust_setl(:,:)   = 0.0
      dust_dt(:,:,:) = 0.0

!----------- dust sources on local grid
     source(:,:)=0.0
     call interpolator(dust_source_interp, Time, source, &
                       trim(dust_source_name(1)), is, js)
! Send the dust source data to the diag_manager for output.
     if (id_dust_source > 0 ) &
          used = send_data ( id_dust_source, source , Time )

      where ( frac_land.gt.0.1 .and. w10m .gt. u_ts_2d )
          dust_emis = CH * frac_s(i_DU)*source * frac_land &
             * w10m**2 * (w10m - u_ts_2d)
      endwhere
      dust_dt(:,:,kd)=dust_dt(:,:,kd)+dust_emis(:,:)/pwt(:,:,kd)*mtv

! Send the emission data to the diag_manager for output.
      if (id_dust_emis(i_DU) > 0 ) then
        used = send_data ( id_dust_emis(i_DU), dust_emis, Time, &
              is_in=is,js_in=js )
      endif

         rcm=dustref*mtcm            ! Particles radius in centimeters
!------------------------------------------
!       Solve at the model TOP (layer plev-10)
!------------------------------------------
      do j=1,jd
        do i=1,id
          setl(:)=0.
          if (present(kbot)) then
              kb=kbot(i,j)
          else
             kb=kd
          endif
          do k=1,kb
              rhb=amin1(0.99,rh(i,j,k))
              rhb=amax1(0.01,rhb)
!----------------------------------------------------------
!     Aerosol growth with relative humidity
!----------------------------------------------------------

            rwet=dustref  ! Add any particle growth here
            ratio_r=(dustref/rwet)**3.   ! Ratio dry over wet radius cubic power
            rho_wet_dust=ratio_r*dustden+(1.-ratio_r)*DENS_H2O     ! Density of wet aerosol [kg/m3]
            viscosity = 1.458E-6 * t(i,j,k)**1.5/(t(i,j,k)+110.4)     ! Dynamic viscosity
            free_path=6.6e-8*t(i,j,k)/293.15*(PSTD_MKS/pfull(i,j,k))
            C_c=1. + free_path/dustref* &          ! Slip correction [none]
                  (1.257+0.4*exp(-1.1*dustref/free_path))
            Vdep=2./9.*C_c*GRAV*rho_wet_dust*rwet**2./viscosity   ! Settling velocity [m/s]
            rho_air = pfull(i,j,k)/t(i,j,k)/RDGAS      ! Air density [kg/m3]
            if (dust(i,j,k).gt.0.) then
              setl(k)=dust(i,j,k)*rho_air/mtv*vdep    ! settling flux [kg/m2/s]
            endif
          enddo
          dust_dt(i,j,1)=dust_dt(i,j,1)-setl(1)/pwt(i,j,1)*mtv
          dust_dt(i,j,2:kb)=dust_dt(i,j,2:kb) &
             + ( setl(1:kb-1) - setl(2:kb) )/pwt(i,j,2:kb)*mtv
          dust_setl(i,j)=setl(kb)
        enddo
      enddo 

! Send the settling data to the diag_manager for output.
      if (id_dust_setl(i_DU) > 0 ) then
        used = send_data ( id_dust_setl(i_DU), dust_setl, Time, &
              is_in=is,js_in=js )
      endif


!-----------------------------------------------------------------------

 end subroutine atmos_dust_sourcesink
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_dust_init">
!<OVERVIEW>
! The constructor routine for the dust module.
!</OVERVIEW>
 subroutine atmos_dust_init (lonb, latb, axes, Time, mask)
!-----------------------------------------------------------------------
real, intent(in),    dimension(:,:)               :: lonb, latb
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
real, intent(in), dimension(:,:,:), optional        :: mask
character(len=7), parameter :: mod_name = 'tracers'
integer :: n, m, logunit
!
!-----------------------------------------------------------------------
!
      integer  unit,ierr, io
      character(len=1)  :: numb(5)
      data numb/'1','2','3','4','5'/


      if (module_is_initialized) return

      call write_version_number (version, tagname)
!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=dust_nml, iostat=io)
        ierr = check_nml_error(io,'dust_nml')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=dust_nml, iostat=io, end=10)
        ierr = check_nml_error(io, 'dust_nml')
        end do
10      call close_file (unit)
#endif
      endif

      if (uthresh .le. -990) then
        u_ts = 0.
      else
        u_ts=uthresh
      endif
      if (coef_emis .le. -990) then
        ch = 1.0e-10
      else
        ch = coef_emis
      endif
!----- set initial value of dust ------------
    logunit=stdlog()
    do m=1,5

       n = get_tracer_index(MODEL_ATMOS,'dust'//numb(m))
       if (n>0) then
         ndust=n
         call set_tracer_atts(MODEL_ATMOS,'dust'//numb(m),'dust'//numb(m),'mmr')
         if (ndust > 0 .and. mpp_pe() == mpp_root_pe()) then
                write (*,30) 'dust'//numb(m),ndust
                write (logunit,30) 'dust '//numb(m),ndust
         endif       
       endif


  30        format (A,' was initialized as tracer number ',i2)
! Register a diagnostic field : emission of dust
     id_dust_emis(m) = register_diag_field ( mod_name,            &
                     'dust'//numb(m)//'_emis', axes(1:2),Time,  &
                     'dust'//numb(m)//'_emis', 'kg/m2/s',       &
                     missing_value=-999.  )

! Register a diagnostic field : settling of dust
     id_dust_setl(m) = register_diag_field ( mod_name,            &
                     'dust'//numb(m)//'_setl', axes(1:2),Time,  &
                     'dust'//numb(m)//'_setl', 'kg/m2/s',       &
                     missing_value=-999.  )
enddo
!
     id_dust_source  = register_diag_field ( mod_name,             &
                      'DU_source',axes(1:2),Time,                    &
                      'DU_source', 'none')

     call interpolator_init (dust_source_interp, trim(dust_source_filename),  &
                             lonb, latb,&
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = dust_source_name, &
                             vert_interp=(/INTERP_WEIGHTED_P/) )


     call write_version_number (version, tagname)

      module_is_initialized = .TRUE.

!-----------------------------------------------------------------------

 end subroutine atmos_dust_init
!</SUBROUTINE>

!######################################################################

subroutine atmos_dust_time_vary (Time)


type(time_type), intent(in) :: Time

      call obtain_interpolator_time_slices (dust_source_interp, Time)


end subroutine atmos_dust_time_vary 


!######################################################################

subroutine atmos_dust_endts              


      call unset_interpolator_time_flag (dust_source_interp)


end subroutine atmos_dust_endts 



!#######################################################################
!<SUBROUTINE NAME="atmos_dust_end">
!<OVERVIEW>
!  The destructor routine for the dust module.
!</OVERVIEW>
 subroutine atmos_dust_end

      call interpolator_end (dust_source_interp)
      module_is_initialized = .FALSE.

 end subroutine atmos_dust_end
!</SUBROUTINE>

end module atmos_dust_mod


module atmos_radon_mod
! <CONTACT EMAIL="William.Cooke@noaa.gov">
!   William Cooke
! </CONTACT>

! <REVIEWER EMAIL="Larry.Horowitz@noaa.gov">
!   Larry Horowitz
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code allows the implementation of an extremely simplified 
!     radon tracer in the FMS framework.
!
!    It should be taken as the implementation of a very simple tracer 
!   which bears some characteristics of radon.
! </OVERVIEW>

! <DESCRIPTION>
!   This module presents an implementation of a tracer.
!   It should be taken as representing radon only in a rudimentary manner.
! </DESCRIPTION>

!-----------------------------------------------------------------------

use              fms_mod, only : file_exist, &
                                 write_version_number, &
                                 mpp_pe, &
                                 mpp_root_pe, &
                                 error_mesg, &
                                 FATAL,WARNING, NOTE, &
                                 stdlog
use     time_manager_mod, only : time_type
use     diag_manager_mod, only : send_data,            &
                                 register_static_field
use   tracer_manager_mod, only : get_tracer_index
use    field_manager_mod, only : MODEL_ATMOS
use atmos_tracer_utilities_mod, only : wet_deposition,       &
                                 dry_deposition


implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_radon_sourcesink, atmos_radon_init, atmos_radon_end

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------
integer  :: ncopies_radon = 9
 
namelist /atmos_radon_nml/  &
                            ncopies_radon


!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'

!--- identification numbers for  diagnostic fields and axes ----

integer :: id_emiss

logical :: module_is_initialized=.FALSE.


!---- version number -----
character(len=128) :: version = '$Id: atmos_radon.F90,v 17.0.4.1 2010/03/17 20:27:11 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################
!<SUBROUTINE NAME="atmos_radon_sourcesink">
!<OVERVIEW>
! The routine that calculate the sources and sinks of radon.
!</OVERVIEW>
!<DESCRIPTION>
! This is a very rudimentary implementation of radon.
!
! It is assumed that the Rn222 flux is 3.69e-21 kg/m*m/sec over land 
! for latitudes < 60N
!
!   Between 60N and 70N the source  = source * .5
!
!  Rn222 has a half-life time of 3.83 days, which corresponds to an 
!  e-folding time of 5.52 days.
!
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_radon_sourcesink (lon, lat, land, pwt, radon, radon_dt, 
!                              Time, kbot)
!</TEMPLATE>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     Longitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!     Latitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="land" TYPE="real" DIM="(:,:)">
!     Land/sea mask.
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     The pressure weighting array. = dP/grav
!   </IN>
!   <IN NAME="radon" TYPE="real" DIM="(:,:,:)">
!     The array of the radon mixing ratio.
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>

!   <OUT NAME="radon_dt" TYPE="real" DIM="(:,:,:)">
!     The array of the tendency of the radon mixing ratio.
!   </OUT>
 subroutine atmos_radon_sourcesink (lon, lat, land, pwt, radon, radon_dt,  &
                              Time, kbot)

!-----------------------------------------------------------------------
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:)   :: land
   real, intent(in),  dimension(:,:,:) :: pwt, radon
   real, intent(out), dimension(:,:,:) :: radon_dt
     type(time_type), intent(in) :: Time     
integer, intent(in),  dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
   real, dimension(size(radon,1),size(radon,2),size(radon,3)) ::  &
         source, sink
logical, dimension(size(radon,1),size(radon,2)) ::  maskeq,masknh
   real  radon_flux, dtr, deg60, deg70, deg300, deg336
integer  i,j,kb,id,jd,kd
!-----------------------------------------------------------------------

      id=size(radon,1); jd=size(radon,2); kd=size(radon,3)

      dtr=acos(0.0)/90.
      deg60=60.*dtr; deg70=70.*dtr; deg300=300.*dtr; deg336=336.*dtr

!----------- compute radon source ------------
!
!  rn222 flux is 3.69e-21 kg/m*m/sec over land for latitudes lt 60n
!   between 60n and 70n the source  = source * .5
!
!  molecular wt. of air is 28.9644 gm/mole
!  molecular wt. of radon is 222 gm/mole
!  scaling facter to get reasonable mixing ratio is 1.e+21
!
!  source = 3.69e-21 * g * 28.9644 * 1.e+21/(pwt * 222.) or
!
!  source = g * .4814353 / pwt
!
!  must initialize all rn to .001
!

      radon_flux = 3.69e-21 * 28.9644 * 1.e+21 / 222.
      source = 0.0
      maskeq = (land > 0.5) .and. lat > -deg60 .and. lat < deg60
      masknh = (land > 0.5) .and. lat >= deg60 .and. lat < deg70

      if (present(kbot)) then
          do j=1,jd
          do i=1,id
             kb=kbot(i,j)
             if (maskeq(i,j)) source(i,j,kb)=radon_flux/pwt(i,j,kb)
             if (masknh(i,j)) source(i,j,kb)=0.5*radon_flux/pwt(i,j,kb)
          enddo
          enddo
      else
          where (maskeq) source(:,:,kd)=radon_flux/pwt(:,:,kd)
          where (masknh) source(:,:,kd)=0.5*radon_flux/pwt(:,:,kd)
          where (masknh .and. lon > deg300 .and. lon < deg336)  &
               source(:,:,kd)=0.0
      endif


!------- compute radon sink --------------
!
!  rn222 has a half-life time of 3.83days 
!   (corresponds to an e-folding time of 5.52 days)
!
!  sink = 1./(86400.*5.52) = 2.09675e-6
!

    where (radon(:,:,:) >= 0.0)
       sink(:,:,:) = -2.09675e-6*radon(:,:,:)
    elsewhere
       sink(:,:,:) = 0.0
    endwhere

!------- tendency ------------------

      radon_dt=source+sink
      

!-----------------------------------------------------------------------

 end subroutine atmos_radon_sourcesink
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_radon_init">
!<OVERVIEW>
! The constructor routine for the radon module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to initialize the radon module.
!</DESCRIPTION>
!<TEMPLATE>
!call radon_init (r, mask, axes, Time)
!</TEMPLATE>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>
 subroutine atmos_radon_init (r, axes, Time, nradon, mask)

!-----------------------------------------------------------------------
!
!   r    = tracer fields dimensioned as (nlon,nlat,nlev,ntrace)
!   mask = optional mask (0. or 1.) that designates which grid points
!          are above (=1.) or below (=0.) the ground dimensioned as
!          (nlon,nlat,nlev).
!
!-----------------------------------------------------------------------
real,             intent(inout), dimension(:,:,:,:) :: r
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
integer, dimension(:), pointer                         :: nradon
real, intent(in), dimension(:,:,:), optional        :: mask

integer :: n
!
!-----------------------------------------------------------------------
!
      integer  logunit
      character(len=64) ::  search_name
      character(len=4) ::  chname
      integer :: nn

      if (module_is_initialized) return

!---- write namelist ------------------

      call write_version_number (version, tagname)
      logunit=stdlog()
      if ( mpp_pe() == mpp_root_pe() ) &
        write ( logunit, nml=atmos_radon_nml )
 
      if (ncopies_radon > 9) then
        call error_mesg ('atmos_radonm_mod', &
          'currently no more than 9 copies of the radon tracer '//&
                                               'are allowed', FATAL)
      endif
      allocate (nradon(ncopies_radon))
      nradon = -1

      do nn=1,ncopies_radon
        write (chname,'(i1)') nn
        if (nn > 1) then
          search_name = 'radon_'// trim(chname)
        else
          search_name = 'radon'
        endif
!----- set initial value of radon ------------

       n = get_tracer_index(MODEL_ATMOS,search_name)
       if (n>0) then
         nradon(nn)=n
         if (nradon(nn) > 0 .and. mpp_pe() == mpp_root_pe()) write (*,30) trim(search_name), nradon(nn)
         if (nradon(nn) > 0 .and. mpp_pe() == mpp_root_pe()) write (logunit,30) trim(search_name), nradon(nn)
       endif

      end do

  30        format (A,' was initialized as tracer number ',i2)
!

! Register a static field for the emissions of your tracer
     id_emiss = register_static_field ( 'tracers',                    &
                     'rnemiss', axes(1:2),       &
                     'rnemiss', 'g/m2/s')

      module_is_initialized = .TRUE.


!-----------------------------------------------------------------------

 end subroutine atmos_radon_init
!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_radon_end">
!<OVERVIEW>
!  The destructor routine for the radon module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits. 
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_radon_end
!</TEMPLATE>
 subroutine atmos_radon_end
 
      module_is_initialized = .FALSE.

 end subroutine atmos_radon_end
!</SUBROUTINE>


end module atmos_radon_mod





module atmos_sea_salt_mod
! <DESCRIPTION>
!   This module evaluates the change of mass mixing ratio of sea salt
!   particles due to their emission at the ocean surface, and the removal by
!   gravitational settling. The sea salt particles are transported as dry
!   particles. Therefore, some conversion from wet to dry and vice-et-versa
!   are consdered.
!   The size distribution of sea salt ranges from 0.1 to 10 um (dry radius)
!   and is divided into 5 bins. For each bin, the volume size distribution
!   dV/dlnr is considered constant.
! </DESCRIPTION>
! <CONTACT EMAIL="Paul.Ginouxe@noaa.gov">
!   Paul Ginoux
! </CONTACT>
! 
!
!-----------------------------------------------------------------------
use mpp_mod, only: input_nml_file 
use              fms_mod, only : file_exist, &
                                 write_version_number, &
                                 close_file,              &
                                 mpp_pe, &
                                 mpp_root_pe, &
                                 open_namelist_file, file_exist,    &
                                 check_nml_error, error_mesg,  &
                                 stdlog
use     time_manager_mod, only : time_type
use     diag_manager_mod, only : send_data,            &
                                 register_diag_field
use   tracer_manager_mod, only : get_tracer_index
use    field_manager_mod, only : MODEL_ATMOS
use        constants_mod, only : PI, GRAV,RDGAS, DENS_H2O, PSTD_MKS, WTMAIR
implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_sea_salt_sourcesink, atmos_sea_salt_init, atmos_sea_salt_end

!-----------------------------------------------------------------------
!----------- namelist -------------------
character(len=80) :: scheme = " "
real, save :: coef1
real, save :: coef2
!---------------------------------------------------------------------
real :: coef_emis1=-999.
real :: coef_emis2=-999.
real :: critical_land_fraction = 1.0  ! sea-salt aerosol production  
                                      ! occurs in grid cells with
                                      ! land fraction .lt. this value

namelist /ssalt_nml/  scheme, coef_emis1, coef_emis2, &
                      critical_land_fraction
!-----------------------------------------------------------------------

!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'

integer :: nseasalt=0  ! tracer number for sea_salt
!--- identification numbers for  diagnostic fields and axes ----

integer :: id_SS_emis(5), id_SS_setl(5)

logical :: module_is_initialized=.FALSE.
logical :: used

!---- version number -----
character(len=128) :: version = '$Id: atmos_sea_salt.F90,v 17.0.2.1.4.2.2.1 2010/08/30 20:33:36 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains

!#######################################################################
!<SUBROUTINE NAME="atmos_sea_salt_sourcesink">
!<OVERVIEW>
! The routine that calculate the emission and settling of sea_salt.
!</OVERVIEW>
 subroutine atmos_sea_salt_sourcesink (i_SS,ra,rb,ssaltref,ssaltden, &
       lon, lat, frac_land, pwt, &
       zhalf, pfull, w10m, t, rh, &
       seasalt, seasalt_dt, dt, SS_setl, SS_emis, Time, is,ie,js,je,kbot)

!-----------------------------------------------------------------------
   integer, intent(in)                 :: i_SS
   real, intent(in)                    :: ra
   real, intent(in)                    :: rb
   real, intent(in)                    :: dt
   real, intent(in)                    :: ssaltref
   real, intent(in)                    :: ssaltden
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:)   :: frac_land
   real, intent(in),  dimension(:,:)   :: w10m
   real, intent(out),  dimension(:,:)   :: SS_setl, SS_emis
   real, intent(in),  dimension(:,:,:) :: pwt, seasalt
   real, intent(in),  dimension(:,:,:) :: zhalf, pfull, t, rh
   real, intent(out), dimension(:,:,:) :: seasalt_dt
   type(time_type), intent(in) :: Time     
   integer, intent(in),  dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
real, dimension(size(seasalt,3)) :: SS_conc0, SS_conc1
integer  i, j, k, id, jd, kd, kb, ir, irh
integer, intent(in)                    :: is, ie, js, je
!----------------------------------------------
!     Sea-Salt parameters
!----------------------------------------------
      real, dimension(size(seasalt,3)) :: setl

      real, parameter :: small_value = 1.e-20
      real, parameter :: mtv  = 1.    ! factor connversion for mixing ratio
      integer, parameter :: nrh= 65   ! number of RH in look-up table
      integer, parameter :: nr = 10   ! number of integration points 
                                      ! The difference with nr=100 & nr=5 < 1e-3
      integer :: istep, nstep, logunit
      real, parameter :: ptmb = 0.01     ! pascal to mb
      integer, parameter :: nstep_max = 5  !Maximum number of cyles for settling
      real :: step
      real :: rhb, betha
      real :: rho_wet_salt, viscosity, free_path, C_c
      real :: rho_air, Bcoef
      real :: r, dr, rmid, rwet, seasalt_flux
      real :: a1, a2
      real, dimension(size(pfull,3))  :: vdep
      real, dimension(nrh) :: rho_table, growth_table
!! Sea salt hygroscopic growth factor from 35 to 99% RH
!! We start at the deliquescence point of sea-salt for RH=37%
!! Any lower RH doesn't affect dry properties
!! Reference: Tang et al., JGR, v102(D19), 23,269-23,275, 1997. 
      data growth_table/1.000, 1.000, 1.396, &
       1.413, 1.428, 1.441, 1.454, 1.466, 1.478, 1.490, 1.501, 1.512, &
       1.523, 1.534, 1.545, 1.555, 1.566, 1.577, 1.588, 1.599, 1.610, &
       1.621, 1.632, 1.644, 1.655, 1.667, 1.679, 1.692, 1.704, 1.717, &
       1.730, 1.743, 1.757, 1.771, 1.786, 1.801, 1.816, 1.832, 1.849, &
       1.866, 1.884, 1.903, 1.923, 1.944, 1.966, 1.990, 2.014, 2.041, &
       2.069, 2.100, 2.134, 2.170, 2.210, 2.255, 2.306, 2.363, 2.430, &
       2.509, 2.605, 2.723, 2.880, 3.087, 3.402, 3.919, 5.048/
!! Seal salt density for 65 RH values from 35% to 99% [g/cm3]
      data rho_table/2.160, 2.160, 1.490, &
       1.475, 1.463, 1.452, 1.441, 1.432, 1.422, 1.414, 1.406, 1.398, &
       1.390, 1.382, 1.375, 1.368, 1.361, 1.354, 1.347, 1.341, 1.334, &
       1.328, 1.322, 1.315, 1.309, 1.303, 1.297, 1.291, 1.285, 1.279, &
       1.273, 1.267, 1.261, 1.255, 1.249, 1.243, 1.237, 1.231, 1.225, &
       1.219, 1.213, 1.207, 1.201, 1.195, 1.189, 1.183, 1.176, 1.170, &
       1.163, 1.156, 1.150, 1.142, 1.135, 1.128, 1.120, 1.112, 1.103, &
       1.094, 1.084, 1.074, 1.063, 1.051, 1.038, 1.025, 1.011/

      betha = growth_table(46)  ! Growth factor at 80% RH
!-----------------------------------------------------------------------

      id=size(seasalt,1); jd=size(seasalt,2); kd=size(seasalt,3)

      SS_emis(:,:)      = 0.0
      SS_setl(:,:)      = 0.0
      seasalt_dt(:,:,:) = 0.0
      seasalt_flux = 0.
      if (scheme .ne. "Smith") then 
! Smith et al. (1993) derived an expression for the sea-salt flux
! by assuming that particle size spectra measured at a height of 10 m
! on the ocast of the Outer Hevrides islands with prevailing winds from
! the ocean present a balance between production and loss. They approximate
! the flux by the sum of two lognormal distributions.
! 
! seasalt_flux is the flux of dry particles by bubble bursting .
! Monahan et al. (1986) established a formula for the flux of wet
! particles by bubble bursting. The radius needs to be converted
! into dry assuming an equilibrium relative humidity above water RH=80%
! Using Tang (1996) formula the sea-salt hygroscopic growth betha=2.009
! at RH=80 (cf. Fitzegrald and Hoppel, JGR, v103 D13, 16085-16102, 1998)
! Also, Monahan et al. (1986) formula is defined for radius in units of
! micrometers
! The flux of particles is converted into mass flux. The cube of the
! radius disappear by cancelation with r^3 in Monahan formula. However
! there is 1/betha3 remaining multiply by betha from the integrand, such
! that finally 1/betha^2 remained. 
!
        r = ra* 1.e6
        dr= (rb - ra)/float(nr)* 1.e6
        seasalt_flux=0.
        do ir=1,nr
          rmid=r+dr*0.5   ! Dry radius
          r=r+dr
          Bcoef=(coef1-alog10(betha*rmid))/coef2
          seasalt_flux = seasalt_flux + &
             1.373*4./3.*pi*ssaltden/betha**2*1.e-18* &
             (1.+0.057*(betha*rmid)**1.05)*dr*      &
             10**(1.19*exp(-(Bcoef**2)))
        enddo
      endif

      logunit=stdlog()
      if (present(kbot)) then
   
        if (scheme .eq. "Smith") then
          if (mpp_pe() == mpp_root_pe()) write (logunit,*) "Smith parameterization for sea-salt production"
          do j=1,jd
            do i=1,id
              kb=kbot(i,j)
!              if (frac_land(i,j).lt.1.) then
              if (frac_land(i,j).lt.critical_land_fraction) then
!------------------------------------------------------------------
!    Surface emission of sea salt
!------------------------------------------------------------------
! Smith et al. (1993)
                seasalt_flux = 0.0
                a1=exp(0.155*w10m(i,j)+5.595)
                a2=exp(2.2082*sqrt(w10m(i,j))-3.3986)
                r = ra* 1.e6
                dr= (rb - ra)/float(nr)* 1.e6
                do ir=1,nr
                  rmid=r+dr*0.5   ! Dry radius
                  r=r+dr
                  seasalt_flux = seasalt_flux + &
                     4.188e-18*rmid**3*ssaltden*betha*( &
                    + coef1*a1*exp(-3.1*(alog(betha*rmid/2.1))**2) &
                    + coef2*a2*exp(-3.3*(alog(betha*rmid/9.2))**2) )
                enddo
                SS_emis(i,j) = seasalt_flux*(1.-frac_land(i,j))
                seasalt_dt(i,j,kb)=amax1(0.,SS_emis(i,j)/pwt(i,j,kb)*mtv)
              endif
            enddo
          enddo
        else  
          do j=1,jd
            do i=1,id
              kb=kbot(i,j)
              if (frac_land(i,j).lt.critical_land_fraction) then
! Monahan et . (1986)
                SS_emis(i,j) = seasalt_flux*(1.-frac_land(i,j))*w10m(i,j)**3.41
                seasalt_dt(i,j,kb)=amax1(0.,SS_emis(i,j)/pwt(i,j,kb)*mtv)
              endif 
            enddo
          enddo
        endif
      else

!------------------------------------------------------------------
!    Surface emission of sea salt
!------------------------------------------------------------------
        if (scheme .eq. "Smith") then
          if (mpp_pe() == mpp_root_pe()) write (logunit,*) "Smith parameterization for sea-salt production"
! Smith et al. (1993)
          do j=1,jd
            do i=1,id
!              if (frac_land(i,j).lt.1.) then
              if (frac_land(i,j).lt.critical_land_fraction) then
                seasalt_flux = 0.0
                a1=exp(0.155*w10m(i,j)+5.595)
                a2=exp(2.2082*sqrt(w10m(i,j))-3.3986)
                r = ra* 1.e6
                dr= (rb - ra)/float(nr)* 1.e6
                do ir=1,nr
                  rmid=r+dr*0.5   ! Dry radius
                  r=r+dr
                  seasalt_flux = seasalt_flux + &
                     4.188e-18*rmid**3*ssaltden*betha*( &
                         + coef1*a1*exp(-3.1*(alog(betha*rmid/2.1))**2) &
                         + coef2*a2*exp(-3.3*(alog(betha*rmid/9.2))**2) )
                enddo
                SS_emis(i,j) = seasalt_flux*(1.-frac_land(i,j))
                seasalt_dt(i,j,kd)=SS_emis(i,j)/pwt(i,j,kd)*mtv
              endif
            enddo
          enddo
        else
! Monahan et . (1986)
!         where (frac_land(:,:).lt.1.0 )
          where (frac_land(:,:).lt.critical_land_fraction )
            SS_emis(:,:) = seasalt_flux*(1.-frac_land(:,:))*w10m(:,:)**3.41
            seasalt_dt(:,:,kd)=SS_emis(:,:)/pwt(:,:,kd)*mtv
          endwhere
        endif
      endif

! Send the emission data to the diag_manager for output.
      if (id_SS_emis(i_SS) > 0 ) then
        used = send_data ( id_SS_emis(i_SS), SS_emis, Time, &
              is_in=is,js_in=js )
      endif

!------------------------------------------
!       Solve at the model TOP (layer plev-10)
!------------------------------------------
        do j=1,jd
          do i=1,id
            if (present(kbot)) then
              kb=kbot(i,j)
            else
              kb=kd
            endif
!
! Determine the maximum timestep to avoid particles settling more than 1 layer
!
            nstep=1
            do k=1,kb
              rhb=amin1(0.99,rh(i,j,k))
              rhb=amax1(0.001,rhb)
              irh=max0(1,int(rhb*100.-34.))
              rho_wet_salt=rho_table(irh)*1000. !Density of wet sea-salt [kg/m3]
              rwet=ssaltref*growth_table(irh) ! Radius of wet sea-salt [m]
              viscosity = 1.458E-6 * t(i,j,k)**1.5/(t(i,j,k)+110.4)
              free_path=6.6e-8*t(i,j,k)/293.15*(PSTD_MKS/pfull(i,j,k))
              C_c=1. + free_path/ssaltref* &            ! Slip correction [none]
                    (1.257+0.4*exp(-1.1*ssaltref/free_path))
              Vdep(k)=2./9.*C_c*GRAV*rho_wet_salt*rwet**2./viscosity
              step = (zhalf(i,j,k)-zhalf(i,j,k+1)) / vdep(k) / 2.
              nstep = max(nstep, int( dt/ step) )
!!! To avoid spending too much time on cycling the settling in case
!!! of very large particles falling through a tiny layer, impose
!!! maximum speed for the selected nstep_max. This is not physically
!!! correct, but as these particles are very large there will be removed
!!! fast enough to not change significantly their lifetime. The proper
!!! way would be to implement semi-lagrangian technique.
              if (nstep.gt.nstep_max) then
                nstep = nstep_max
                vdep(k)=(zhalf(i,j,k)-zhalf(i,j,k+1))*nstep / 2. /dt
              endif
            enddo
            step = dt / nstep

            SS_conc1(:) = seasalt(i,j,:) 
            do istep = 1, nstep
              SS_conc0(:) = SS_conc1(:) 
              do k=1,kb
                rho_air = pfull(i,j,k)/t(i,j,k)/RDGAS ! Air density [kg/m3]
                if (SS_conc0(k).gt.0.) then
!!!               settling flux [kg/m2/s]
                  setl(k)=SS_conc0(k)*rho_air/mtv*vdep(k) 
                else
                  setl(k)=0.
                endif
              enddo
              SS_setl(i,j)=SS_setl(i,j)+setl(kb)*step
              SS_conc1(1) = SS_conc0(1) - setl(1)/pwt(i,j,1)*mtv * step
              SS_conc1(2:kb)= SS_conc0(2:kb) &
              + ( setl(1:kb-1) - setl(2:kb) )/pwt(i,j,2:kb)*mtv * step
              where (SS_conc1 < 0 ) SS_conc1=0.0
            enddo
            seasalt_dt(i,j,:)=seasalt_dt(i,j,:)+ (SS_conc1(:)-seasalt(i,j,:))/dt
            SS_setl(i,j)=SS_setl(i,j)/dt
          enddo
        enddo 

! Send the settling data to the diag_manager for output.
      if (id_SS_setl(i_SS) > 0 ) then
        used = send_data ( id_SS_setl(i_SS), SS_setl, Time, &
              is_in=is,js_in=js )
      endif


!-----------------------------------------------------------------------

 end subroutine atmos_sea_salt_sourcesink
!</SUBROUTINE>

!#######################################################################
!<SUBROUTINE NAME="atmos_sea_salt_init">
!<OVERVIEW>
! The constructor routine for the sea_salt module.
!</OVERVIEW>
 subroutine atmos_sea_salt_init (lonb, latb, axes, Time, mask)
!-----------------------------------------------------------------------
real, intent(in),    dimension(:,:)                 :: lonb, latb
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
real, intent(in), dimension(:,:,:), optional        :: mask
character(len=7), parameter :: mod_name = 'tracers'
integer :: n, m
!
!-----------------------------------------------------------------------
!
      integer  unit,ierr,io,logunit
      character(len=1) :: numb(5)
      data numb/'1','2','3','4','5'/

      if (module_is_initialized) return

!-----------------------------------------------------------------------
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=ssalt_nml, iostat=io)
        ierr = check_nml_error(io,'ssalt_nml')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=ssalt_nml, iostat=io, end=10)
        ierr = check_nml_error(io, 'ssalt_nml')
        end do
10      call close_file (unit)
#endif
      endif
!--------- write version and namelist to standard log ------------
      call write_version_number ( version, tagname )
      logunit=stdlog()
      if ( mpp_pe() == mpp_root_pe() ) &
        write ( logunit, nml=ssalt_nml )
      if (scheme .eq. "Smith") then
        if (coef_emis1 .le. -990) then
          coef1 = 1.0
        else
          coef1 = coef_emis1
        endif
        if (coef_emis2 .le. -990) then
          coef2 = 1.0
        else
          coef2 = coef_emis2
        endif
      else
        if (coef_emis1 .le. -990) then
          coef1 = 0.38
        else
          coef1 = coef_emis1
        endif
        if (coef_emis2 .le. -990) then
          coef2 = 0.65
        else
          coef2 = coef_emis2
        endif
      endif


!----- set initial value of sea_salt ------------
       do m=1,5
       n = get_tracer_index(MODEL_ATMOS,'seasalt'//numb(m))
       if (n>0) then
         nseasalt=n
         if (nseasalt > 0 .and. mpp_pe() == mpp_root_pe()) write (*,30) 'Sea-salt',nseasalt
         if (nseasalt > 0 .and. mpp_pe() == mpp_root_pe()) write (logunit,30) 'Sea-salt',nseasalt
       endif
!

! Register a diagnostic field : emission of seasalt
       id_SS_emis(m) = register_diag_field ( mod_name,             &
                     'ssalt'//numb(m)//'_emis', axes(1:2),Time,          &
                     'ssalt'//numb(m)//'_emis', 'kg/m2/s',      &
                     missing_value=-999.  )

! Register a diagnostic field : settling of seasalt
       id_SS_setl(m) = register_diag_field ( mod_name,              &
                     'ssalt'//numb(m)//'_setl', axes(1:2),Time,        &
                     'ssalt'//numb(m)//'_setl', 'kg/m2/s',      &
                     missing_value=-999.  )
      enddo

      module_is_initialized = .TRUE.
 
  30        format (A,' was initialized as tracer number ',i2)

!-----------------------------------------------------------------------

 end subroutine atmos_sea_salt_init
!</SUBROUTINE>

!#######################################################################
!<SUBROUTINE NAME="atmos_sea_salt_end">
!<OVERVIEW>
!  The destructor routine for the sea_salt module.
!</OVERVIEW>
 subroutine atmos_sea_salt_end
 
      module_is_initialized = .FALSE.

 end subroutine atmos_sea_salt_end
!</SUBROUTINE>


end module atmos_sea_salt_mod


module atmos_soa_mod
! <DESCRIPTION>
!   This module is an implementation of Secondary organic aerosols (SOA)
!   from anthropogenic activities, and is based on Tie et al. (JGR, 2003).
!   The only souce of SOA is due to the oxydation of C4H10 by OH.
!   The concentrations of these 2 gas species are read as input.
! </DESCRIPTION>
! <WARNING>
!  To save space only the actual month of input files are kept in memory. 
!  This implies that the "atmos_SOA_init" should be executed at the begining 
!  of each month. In other words, the script should not run more than 1 month
!  without a restart.
! </WARNING>
! <CONTACT EMAIL="Paul.Ginouxe@noaa.gov">
!   Paul Ginoux
! </CONTACT>
!-----------------------------------------------------------------------

use mpp_mod, only: input_nml_file 
use                    fms_mod, only : file_exist,              &
                                       write_version_number,    &
                                       mpp_pe,                  &
                                       mpp_root_pE,             &
                                       close_file,              &
                                       stdlog,                  &
                                       check_nml_error, error_mesg, &
                                       open_namelist_file, FATAL
use           time_manager_mod, only : time_type
use           diag_manager_mod, only : send_data,               &
                                       register_diag_field,     &
                                       register_static_field
use         tracer_manager_mod, only : get_tracer_index,        &
                                       set_tracer_atts
use          field_manager_mod, only : MODEL_ATMOS
use              constants_mod, only : PI, GRAV, RDGAS, WTMAIR
use           interpolator_mod, only:  interpolate_type,  &
                                       interpolator_init, &
                                       obtain_interpolator_time_slices,&
                                       unset_interpolator_time_flag, &
                                       interpolator, interpolator_end, &
                                       CONSTANT, INTERP_WEIGHTED_P

implicit none

private
!-----------------------------------------------------------------------
!----- interfaces -------
!
public  atmos_SOA_init, atmos_SOA_end, atmos_SOA_chem, &
        atmos_SOA_time_vary, atmos_soa_endts

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------

!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'

integer :: nSOA = 0  ! tracer number for Secondary Organic Aerosol 

!--- identification numbers for  diagnostic fields and axes ----
integer ::   id_OH_conc            = 0
integer ::   id_C4H10_conc         = 0
integer ::   id_SOA_chem           = 0
integer ::   id_SOA_chem_col       = 0

type(interpolate_type),save         ::  gas_conc_interp
character(len=32)  :: gas_conc_filename = 'gas_conc_3D.nc'
character(len=32), dimension(2) :: gas_conc_name
data gas_conc_name/'OH','C4H10'/

namelist /secondary_organics_nml/ gas_conc_filename, gas_conc_name

logical :: module_is_initialized=.FALSE.
logical :: used

!---- version number -----
character(len=128) :: version = '$Id: atmos_soa.F90,v 18.0.2.1 2010/08/30 20:39:47 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################

!<SUBROUTINE NAME="atmos_SOA_init">
!<OVERVIEW>
! The constructor routine for the soa module.
!</OVERVIEW>
 subroutine atmos_SOA_init ( lonb, latb, nlev, axes, Time, mask)
!-----------------------------------------------------------------------
real,             intent(in), dimension(:,:)        :: lonb, latb
integer,          intent(in)                        :: nlev
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
real, intent(in), dimension(:,:,:), optional        :: mask
character(len=7), parameter :: mod_name = 'tracers'
!
!-----------------------------------------------------------------------
!
      integer  unit,io,ierr, logunit
      character(len=3) :: SOA_tracer
!
      data SOA_tracer/'SOA'/

!
      if (module_is_initialized) return
!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=secondary_organics_nml, iostat=io)
        ierr = check_nml_error(io,'secondary_organics_nml')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=secondary_organics_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'secondary_organics_nml')
        end do
10      call close_file (unit)
#endif
      endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit=stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=secondary_organics_nml)

!----- set initial value of soa ------------

      nSOA = get_tracer_index(MODEL_ATMOS,'SOA')
      if (nSOA > 0) then
         call set_tracer_atts(MODEL_ATMOS,'SOA','SOA','mmr')
         if (nSOA > 0 .and. mpp_pe() == mpp_root_pe()) &
                 write (*,30) SOA_tracer,nsoa
         if (nSOA > 0 .and. mpp_pe() == mpp_root_pe()) &
                 write (logunit,30) SOA_tracer,nsoa
      endif


  30   format (A,' was initialized as tracer number ',i2)

     call interpolator_init (gas_conc_interp, trim(gas_conc_filename),  &
                             lonb, latb,&        
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = gas_conc_name, & 
                             vert_interp=(/INTERP_WEIGHTED_P/) )
      if (id_OH_conc .eq. 0 ) &
        id_OH_conc    = register_diag_field ( mod_name,           &
                      'OH_SOA_conc',axes(1:3),Time,                        &
                      'Hydroxyl radical concentration',           &
                      'molec.cm-3')

      id_C4H10_conc    = register_diag_field ( mod_name,           &
                      'C4H10_mmr',axes(1:3),Time,                        &
                      'nButane concentration',           &
                      'mmr')

      id_SOA_chem    = register_diag_field ( mod_name,       &
                      'SOA_chem',axes(1:3),Time,            &
                      'SOA production by C4H10 + OH',        &
                      'kg/m2/s')

      id_SOA_chem_col= register_diag_field ( mod_name,       &
                      'SOA_chem_col',axes(1:2),Time,            &
                      'column SOA production by C4H10 + OH',        &
                      'kg/m2/s')

      call write_version_number (version, tagname)

      module_is_initialized = .TRUE.

!-----------------------------------------------------------------------
 end subroutine atmos_SOA_init




!#####################################################################

subroutine atmos_SOA_time_vary (Time)

type(time_type), intent(in) :: Time


      call obtain_interpolator_time_slices (gas_conc_interp, Time)

end subroutine atmos_SOA_time_vary


!#####################################################################

subroutine atmos_SOA_endts             


      call unset_interpolator_time_flag (gas_conc_interp)


end subroutine atmos_SOA_endts



!#####################################################################

!</SUBROUTINE>

!#######################################################################
!<SUBROUTINE NAME="atmos_SOA_end">
!<OVERVIEW>
!  The destructor routine for the soa module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits. 
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_SOA_end
!</TEMPLATE>
 subroutine atmos_SOA_end

      call interpolator_end (gas_conc_interp)
      module_is_initialized = .FALSE.

 end subroutine atmos_SOA_end
!</SUBROUTINE>
!-----------------------------------------------------------------------
      SUBROUTINE atmos_SOA_chem(pwt,temp,pfull, phalf, dt, &
                          jday,hour,minute,second,lat,lon, &
                          SOA, SOA_dt, Time,is,ie,js,je,kbot)

! ****************************************************************************
      real, intent(in),    dimension(:,:,:)          :: pwt
      real, intent(in),    dimension(:,:,:)          :: temp,pfull,phalf
      real, intent(in)                               :: dt
      integer, intent(in)                            :: jday, hour,minute,second
      real, intent(in),  dimension(:,:)              :: lat, lon  ! [radian]
      real, intent(in),    dimension(:,:,:)          :: SOA
      real, intent(out),   dimension(:,:,:)          :: SOA_dt
      type(time_type), intent(in)                    :: Time
      integer, intent(in),  dimension(:,:), optional :: kbot
      integer, intent(in)                            :: is,ie,js,je
! Working vectors
      real, dimension(size(SOA,1),size(SOA,2),size(SOA,3)) :: &
               SOA_chem, OH_conc, C4H10_conc
      real, dimension(size(SOA,1),size(SOA,2)) :: &
               SOA_prod, &
               xu, dayl, h, hl, hc, hred, fac_OH, fact_OH
      real, parameter                            :: wtm_C = 12.
      real, parameter                            :: wtm_C4H10 = 58.
      real, parameter                            :: yield = 0.1
      real, parameter                            :: small_value=1.e-21
      real, parameter                            :: A0 = 0.006918
      real, parameter                            :: A1 = 0.399912
      real, parameter                            :: A2 = 0.006758
      real, parameter                            :: A3 = 0.002697
      real, parameter                            :: B1 = 0.070257
      real, parameter                            :: B2 = 0.000907
      real, parameter                            :: B3 = 0.000148
      real                                       :: decl, hd, x
      integer :: i,j,k,id,jd,kd
      integer                                    :: istep, nstep
! Local grid sizes
      id=size(SOA,1); jd=size(SOA,2); kd=size(SOA,3)

      OH_conc(:,:,:)=0.  ! molec/cm3
      call interpolator(gas_conc_interp, Time, phalf, OH_conc, &
                       trim(gas_conc_name(1)), is, js)

      C4H10_conc(:,:,:)=0.0
      call interpolator(gas_conc_interp, Time, phalf, C4H10_conc, &
                       trim(gas_conc_name(2)), is, js)
      C4H10_conc(:,:,:)=C4H10_conc(:,:,:)*WTM_C4H10/WTMAIR

      x = 2. *pi *float(jday-1)/365.
      decl = A0 - A1*cos(  X) + B1*sin(  X) - A2*cos(2.*X) + B2*sin(2.*X) &
           - A3*cos(3.*X) + B3*sin(3.*X)
      xu(:,:) = -tan(lat(:,:))*tan(decl)
      where ( xu > -1 .and. xu < 1 ) dayl=acos(xu)/pi
      where ( xu <= -1 ) dayl = 1.
      where ( xu >= 1 ) dayl = 0.
!   Calculate normalization factors for OH and NO3 such that
!   the diurnal average respect the monthly input values.
      hd=0.
      fact_OH(:,:)  = 0.
      nstep = int(24.*3600./dt)
      do istep=1,nstep
        hd=hd+dt/3600./24.
        hl(:,:) = pi*(1.-dayl(:,:))
        hc(:,:) = pi*(1.+dayl(:,:))
        h(:,:)=2.*pi*mod(hd+lon(:,:)/2./pi,1.)
        where ( h.ge.hl .and. h.lt.hc )
! Daytime
          hred=(h-hl)/(hc-hl)
          fact_OH  = fact_OH + amax1(0.,sin(pi*hred)/2.)/nstep
        endwhere
      enddo


      hd=amax1(0.,amin1(1.,(hour+minute/60.+second/3600.)/24.))
      hl(:,:) = pi*(1.-dayl(:,:))
      hc(:,:) = pi*(1.+dayl(:,:))
      h(:,:)=2.*pi*mod(hd+lon(:,:)/2./pi,1.)
      fac_OH(:,:)  = 0.
      where ( h.ge.hl .and. h.lt.hc )
! Daytime
          hred=(h-hl)/(hc-hl)
          fac_OH  = amax1(0.,sin(pi*hred)/2.)/fact_OH
      elsewhere
! Nightime
          fac_OH  = 0.
      endwhere

      do i=1,id
        do j=1,jd
          do k=1,kd 
            SOA_dt(i,j,k) = 1.55E-11 * exp( -540./temp(i,j,k) ) *yield &
                * C4H10_conc(i,j,k)*OH_conc(i,j,k)*fac_oh(i,j)
          enddo
        enddo
      enddo

      SOA_chem(:,:,:)=SOA_dt(:,:,:)*pwt(:,:,:)

      if (id_SOA_chem > 0) then
        used = send_data ( id_SOA_chem, &
              SOA_chem, Time,is_in=is,js_in=js,ks_in=1)
      endif

! column production of SOA 


      SOA_prod = 0.
      do k=1,kd
        SOA_prod(is:ie,js:je) = SOA_prod(is:ie,js:je) +  &
                                             SOA_chem(is:ie,js:je,k)
      end do

      if (id_SOA_chem_col > 0) then
        used = send_data ( id_SOA_chem_col, &
                           SOA_prod, Time,is_in=is,js_in=js)
      endif


end subroutine atmos_SOA_chem


end module atmos_SOA_mod


module atmos_sulfate_mod
! <DESCRIPTION>
!   This module is an implementation of sulfate chemistry. It contains
!   tracer emissions and chemistry. The chemistry is partly based on MOZART.
!   The change of concentration of SO2, DMS, SO4, MSA and H2O2 are
!   calculated using monthly mean concentration of OH, HO2, jH2O2, NO3, O3,
!   pH. The emissions include:
!     - DMS from seawater
!     - SO2 by fossil fuel, biomass burning, non-eruptive volcanoes and aircraft
!     - SO4 by fossil fuel
! </DESCRIPTION>
! <WARNING>
!  To save space only the actual month of input files are kept in memory.
!  This implies that the "atmos_sulfate_init" should be executed at the begining
!  of each month. In other words, the script should not run more than 1 month
!  without a restart.
! </WARNING>
! <CONTACT EMAIL="Paul.Ginouxe@noaa.gov">
!   Paul Ginoux
! </CONTACT>
!-----------------------------------------------------------------------

use mpp_mod, only: input_nml_file 
use                    fms_mod, only : file_exist,              &
                                       write_version_number,    &
                                       mpp_pe,                  &
                                       mpp_root_pE,             &
                                       close_file,              &
                                       stdlog,                  &
                                       check_nml_error, error_mesg, &
                                       open_namelist_file, FATAL, NOTE, WARNING

use           time_manager_mod, only : time_type, &
                                       days_in_month, days_in_year, &
                                       set_date, set_time, get_date_julian, &
                                       print_date, get_date, &
                                       operator(>), operator(+), operator(-)
use time_interp_mod,            only:  fraction_of_year, &
                                       time_interp_init
use           diag_manager_mod, only : send_data,               &
                                       register_diag_field,     &
                                       register_static_field,   &
                                       diag_manager_init, get_base_time
use         tracer_manager_mod, only : get_tracer_index,        &
                                       set_tracer_atts
use          field_manager_mod, only : MODEL_ATMOS
use           interpolator_mod, only:  interpolate_type, interpolator_init, &
                                      obtain_interpolator_time_slices, &
                                      unset_interpolator_time_flag, &
                                       interpolator, interpolator_end,     &
                                       CONSTANT, INTERP_WEIGHTED_P
use              constants_mod, only : PI, GRAV, RDGAS, WTMAIR

implicit none

private
!-----------------------------------------------------------------------
!----- interfaces -------
!
public  atmos_sulfate_init, atmos_sulfate_end, &
        atmos_sulfate_time_vary, atmos_sulfate_endts, &
        atmos_DMS_emission, atmos_SOx_emission, atmos_SOx_chem

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------

!--- Arrays to help calculate tracer sources/sinks ---

character(len=6), parameter :: module_name = 'tracer'

integer :: nSO4 = 0  ! tracer number for Sulfate               = SO4=
integer :: nDMS = 0  ! tracer number for Dimethyl sulfide      = CH3SCH3
integer :: nSO2 = 0  ! tracer number for Sulfur dioxide        = SO2
integer :: nMSA = 0  ! tracer number for Methane sulfonic acid = CH3SO3H
integer :: nH2O2= 0  ! tracer number for Hydrogen peroxyde     = H2O2

real , parameter :: WTM_S     = 32.0
real , parameter :: WTM_O3    = 48.0
real , parameter :: WTM_SO2   = 64.0
real , parameter :: WTM_SO4   = 96.0
real , parameter :: WTM_NH4_2SO4   = 132.00
real , parameter :: WTM_DMS   = 62.0
real , parameter :: WTM_MSA   = 96.0

!--- identification numbers for  diagnostic fields and axes ----
integer ::   id_OH                  = 0
integer ::   id_HO2                 = 0
integer ::   id_NO3                 = 0
integer ::   id_jH2O2               = 0
integer ::   id_O3                  = 0
integer ::   id_pH                  = 0

integer ::   id_DMSo                = 0
integer ::   id_DMS_emis            = 0
integer ::   id_DMS_emis_cmip       = 0
integer ::   id_SO2_emis            = 0
integer ::   id_SO4_emis            = 0
integer ::   id_DMS_chem            = 0
integer ::   id_SO2_chem            = 0
integer ::   id_SO4_chem            = 0
integer ::   id_SO4_oh_prod         = 0
integer ::   id_SO4_o3_prod         = 0
integer ::   id_SO4_h2o2_prod       = 0
integer ::   id_MSA_chem            = 0
integer ::   id_H2O2_chem           = 0
integer ::   id_so2_aircraft        = 0
integer ::   id_so2_cont_volc       = 0
integer ::   id_so2_expl_volc       = 0
integer ::   id_so2_biobur          = 0
integer ::   id_so2_ship            = 0
integer ::   id_so2_road            = 0
integer ::   id_so2_domestic        = 0
integer ::   id_so2_industry        = 0
integer ::   id_so2_power           = 0
integer ::   id_so2_off_road        = 0
integer ::   id_so2_ff              = 0

type(interpolate_type),save         ::  gas_conc_interp
type(interpolate_type),save         ::  aerocom_emission_interp
type(interpolate_type),save         ::  gocart_emission_interp
type(interpolate_type),save         ::  anthro_emission_interp
type(interpolate_type),save         ::  biobur_emission_interp
type(interpolate_type),save         ::  ship_emission_interp
type(interpolate_type),save         ::  aircraft_emission_interp
! type(interpolate_type),save         ::  cont_volc_emission_interp
! type(interpolate_type),save         ::  expl_volc_emission_interp
! Initial calendar time for model
type(time_type) :: model_init_time
type(time_type), save :: gas_conc_offset
type(time_type), save :: anthro_offset
type(time_type), save :: biobur_offset
type(time_type), save :: ship_offset
type(time_type), save :: aircraft_offset
! type(time_type), save :: cont_volc_offset
! type(time_type), save :: expl_volc_offset

type(time_type), save :: gas_conc_entry
type(time_type), save :: anthro_entry
type(time_type), save :: biobur_entry
type(time_type), save :: ship_entry
type(time_type), save :: aircraft_entry
! type(time_type), save :: cont_volc_entry
! type(time_type), save :: expl_volc_entry

logical, save    :: gas_conc_negative_offset
logical, save    :: anthro_negative_offset
logical, save    :: biobur_negative_offset
logical, save    :: ship_negative_offset
logical, save    :: aircraft_negative_offset
! logical, save    :: cont_volc_negative_offset
! logical, save    :: expl_volc_negative_offset

integer, save    :: gas_conc_time_serie_type
integer, save    :: anthro_time_serie_type
integer, save    :: biobur_time_serie_type
integer, save    :: ship_time_serie_type
integer, save    :: aircraft_time_serie_type
! integer, save    :: cont_volc_time_serie_type
! integer, save    :: expl_volc_time_serie_type

character(len=80)  :: runtype = 'default'

character(len=80)  :: gocart_emission_filename = 'gocart_emission.nc'
character(len=80), dimension(6) :: gocart_emission_name
data gocart_emission_name/'DMSo','SO2_GEIA1','SO2_GEIA2', &
                       'SO4_GEIA1','SO4_GEIA2','SO2_biobur'/

integer, parameter :: num_volc_levels = 12
character(len=80)  :: cont_volc_source = ' '
character(len=80)  :: expl_volc_source = ' '
real :: volc_altitude_edges(num_volc_levels+1) = 1.e3 * (/ &
  0.,0.1,0.2,0.5,1.,2.,3.,4.,5.,6.,7.,8.,20. /) ! m

character(len=80)  :: aerocom_emission_filename = 'aerocom_emission.nc'
integer, parameter :: std_aerocom_emission=18, &
                      max_aerocom_emission=std_aerocom_emission+2*num_volc_levels
character(len=80), dimension(max_aerocom_emission)  :: aerocom_emission_name = (/ &
         'SO2_RoadTransport         ', 'SO2_Off-road              ', &
         'SO2_Domestic              ', 'SO2_Industry              ', &
         'SO2_International_Shipping', 'SO2_Powerplants           ', &
         'SO2_cont_volc             ', 'alt_cont_volc_low         ', &
         'alt_cont_volc_high        ', 'SO2_expl_volc             ', &
         'alt_expl_volc_low         ', 'alt_expl_volc_high        ', &
         'GFED_SO2_l1               ', 'GFED_SO2_l2               ', &
         'GFED_SO2_l3               ', 'GFED_SO2_l4               ', &
         'GFED_SO2_l5               ', 'GFED_SO2_l6               ', &
         'SO2_cont_volc_l01         ', 'SO2_cont_volc_l02         ', &
         'SO2_cont_volc_l03         ', 'SO2_cont_volc_l04         ', &
         'SO2_cont_volc_l05         ', 'SO2_cont_volc_l06         ', &
         'SO2_cont_volc_l07         ', 'SO2_cont_volc_l08         ', &
         'SO2_cont_volc_l09         ', 'SO2_cont_volc_l10         ', &
         'SO2_cont_volc_l11         ', 'SO2_cont_volc_l12         ', &
         'SO2_expl_volc_l01         ', 'SO2_expl_volc_l02         ', &
         'SO2_expl_volc_l03         ', 'SO2_expl_volc_l04         ', &
         'SO2_expl_volc_l05         ', 'SO2_expl_volc_l06         ', &
         'SO2_expl_volc_l07         ', 'SO2_expl_volc_l08         ', &
         'SO2_expl_volc_l09         ', 'SO2_expl_volc_l10         ', &
         'SO2_expl_volc_l11         ', 'SO2_expl_volc_l12         '/)

character(len=80)  :: gas_conc_source   = ' '
character(len=80)  :: gas_conc_filename = 'gas_conc_3D.nc'
character(len=80), dimension(6) :: gas_conc_name
data gas_conc_name/'OH','HO2','NO3','O3','jH2O2','pH'/
character(len=80)     :: gas_conc_time_dependency_type
integer, dimension(6) :: gas_conc_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)

character(len=80)  :: anthro_source   = ' '
character(len=80)  :: anthro_filename = 'aero_anthro_emission_1979_2006.nc'
character(len=80), dimension(2) :: anthro_emission_name
data anthro_emission_name/'so2_anthro','so4_anthro'/
character(len=80)     :: anthro_time_dependency_type
integer, dimension(6) :: anthro_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)

character(len=80)  :: biobur_source   = ' '
character(len=80)  :: biobur_filename = 'aero_biobur_emission_1979_2006.nc'
character(len=80), dimension(2) :: biobur_emission_name
data biobur_emission_name/'so2_biobur','so4_biobur'/
character(len=80)     :: biobur_time_dependency_type
integer, dimension(6) :: biobur_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)

character(len=80)  :: ship_source   = ' '
character(len=80)  :: ship_filename = 'aero_ship_emission_1979_2006.nc'
character(len=80), dimension(2) :: ship_emission_name
data ship_emission_name/'so2_ship','so4_ship'/
character(len=80)     :: ship_time_dependency_type
integer, dimension(6) :: ship_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)

character(len=80)  :: aircraft_source = ' '
character(len=80)  :: aircraft_filename = 'aircraft_emission.nc'
character(len=80)  :: aircraft_emission_name(1)
data aircraft_emission_name/'fuel'/
character(len=80)     :: aircraft_time_dependency_type
integer, dimension(6) :: aircraft_dataset_entry  = (/ 1, 1, 1, 0, 0, 0 /)
real :: so2_aircraft_EI = 1.e-3  ! kg of SO2/kg of fuel

namelist /simple_sulfate_nml/  &
      runtype,                         &
      aerocom_emission_filename, aerocom_emission_name,  &
      gocart_emission_filename, gocart_emission_name,  &
      gas_conc_source, gas_conc_name, gas_conc_filename,        &
        gas_conc_time_dependency_type, gas_conc_dataset_entry, &
      anthro_source, anthro_emission_name, anthro_filename,        &
        anthro_time_dependency_type, anthro_dataset_entry, &
      biobur_source, biobur_emission_name, biobur_filename,        &
        biobur_time_dependency_type, biobur_dataset_entry, &
      ship_source, ship_emission_name, ship_filename,        &
        ship_time_dependency_type, ship_dataset_entry, &
      aircraft_source, aircraft_emission_name, aircraft_filename, &
        aircraft_time_dependency_type, aircraft_dataset_entry, so2_aircraft_EI,&
      cont_volc_source, expl_volc_source

type(time_type) :: anthro_time, biobur_time, ship_time, aircraft_time
type(time_type)        :: gas_conc_time

!trim(runtype) 
!biomass_only; fossil_fuels_only, natural_only, anthrop

logical :: module_is_initialized=.FALSE.
logical :: used

!---- version number -----
character(len=128) :: version = '$Id: atmos_sulfate.F90,v 18.0.2.1.2.1.2.1 2010/08/30 20:33:36 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################

!<SUBROUTINE NAME="atmos_sulfate_init">
!<OVERVIEW>
! The constructor routine for the sulfate module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to initialize the sulfate module.
!</DESCRIPTION>
 subroutine atmos_sulfate_init ( lonb, latb, nlev, axes, Time, mask)

!-----------------------------------------------------------------------
real, intent(in),    dimension(:,:)                 :: lonb, latb
integer, intent(in)                                 :: nlev
type(time_type),  intent(in)                        :: Time
integer,          intent(in)                        :: axes(4)
real, intent(in), dimension(:,:,:), optional        :: mask
character(len=7), parameter :: mod_name = 'tracers'
integer :: n, m, nsulfate
!
!----------------------------------------------------------------------
!  local variables:

      integer   ::   ierr

!---------------------------------------------------------------------
!    local variables:
!
!         unit       io unit number used to read namelist file
!         ierr       error code
!         io         error status returned from io operation
!         n          do-loop index
!
!---------------------------------------------------------------------

!-----------------------------------------------------------------------
!
      integer  unit,io, logunit
      character(len=12) :: SOx_tracer(5)
!
!     1. DMS       = Dimethyl sulfide            = CH3SCH3
!     2. SO2       = Sulfur dioxide              = SO2     
!     3. SO4       = Sulfate                     = SO4=   
!     4. MSA       = Methane sulfonic acid       = CH3SO3H
!     5. H2O2      = Hydrogen peroxyde           = H2O2
!                                                                      
      data SOx_tracer/'simpleDMS', &
                      'simpleSO2', &
                      'simpleSO4', &
                      'simpleMSA', &
                      'simpleH2O2' /
      
      if (module_is_initialized) return


!---- write namelist ------------------

      call write_version_number (version, tagname)

!    read namelist.
!-----------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=simple_sulfate_nml, iostat=io)
        ierr = check_nml_error(io,'simple_sulfate_nml')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=simple_sulfate_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'simple_sulfate_nml')
        end do
10      call close_file (unit)
#endif
      endif

!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit=stdlog()
      if (mpp_pe() == mpp_root_pe() ) &
                          write (logunit, nml=simple_sulfate_nml)


!----- set initial value of sulfate ------------

     do m=1,size(SOx_tracer)

       n = get_tracer_index(MODEL_ATMOS,SOx_tracer(m))
       if (n>0) then
         nsulfate=n
        call set_tracer_atts(MODEL_ATMOS,SOx_tracer(m),SOx_tracer(m),'vmr')
         if (nsulfate > 0 .and. mpp_pe() == mpp_root_pe()) &
                 write (logunit,30) SOx_tracer(m),nsulfate
       endif
     enddo


  30   format (A,' was initialized as tracer number ',i2)

!----------------------------------------------------------------------
!    initialize namelist entries
!----------------------------------------------------------------------
        gas_conc_offset = set_time (0,0)
        anthro_offset   = set_time (0,0)
        biobur_offset   = set_time (0,0)
        ship_offset     = set_time (0,0)
        aircraft_offset = set_time (0,0)

        gas_conc_entry  = set_time (0,0)
        anthro_entry    = set_time (0,0)
        biobur_entry    = set_time (0,0)
        ship_entry      = set_time (0,0)
        aircraft_entry  = set_time (0,0)

        gas_conc_negative_offset = .false.
        anthro_negative_offset   = .false.
        biobur_negative_offset   = .false.
        ship_negative_offset     = .false.
        aircraft_negative_offset = .false.

        gas_conc_time_serie_type = 1
        anthro_time_serie_type   = 1
        biobur_time_serie_type   = 1
        ship_time_serie_type     = 1
        aircraft_time_serie_type = 1
!----------------------------------------------------------------------
!    define the model base time  (defined in diag_table)
!----------------------------------------------------------------------
        model_init_time = get_base_time()
       call interpolator_init (aerocom_emission_interp, &
                             trim(aerocom_emission_filename),  &
                             lonb, latb,&
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = aerocom_emission_name, &
                             vert_interp=(/INTERP_WEIGHTED_P/) )
       call interpolator_init (gocart_emission_interp, &
                             trim(gocart_emission_filename),  &
                             lonb, latb,&
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = gocart_emission_name, &
                             vert_interp=(/INTERP_WEIGHTED_P/) )
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(gas_conc_time_dependency_type) == 'constant' ) then
        gas_conc_time_serie_type = 1
        gas_conc_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'gas_conc are constant in sulfate module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for gas_conc is selected.
!---------------------------------------------------------------------
      else if (trim(gas_conc_time_dependency_type) == 'time_varying') then
        gas_conc_time_serie_type = 3
        if (gas_conc_dataset_entry(1) == 1 .and. &
            gas_conc_dataset_entry(2) == 1 .and. &
            gas_conc_dataset_entry(3) == 1 .and. &
            gas_conc_dataset_entry(4) == 0 .and. &
            gas_conc_dataset_entry(5) == 0 .and. &
            gas_conc_dataset_entry(6) == 0 ) then
          gas_conc_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to gas_conc_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          gas_conc_entry  = set_date (gas_conc_dataset_entry(1), &
                                  gas_conc_dataset_entry(2), &
                                  gas_conc_dataset_entry(3), &
                                  gas_conc_dataset_entry(4), &
                                  gas_conc_dataset_entry(5), &
                                  gas_conc_dataset_entry(6))
        endif
        call print_date (gas_conc_entry , str= &
          'Data from gas_conc timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        gas_conc_offset = gas_conc_entry - model_init_time
        if (model_init_time > gas_conc_entry) then
          gas_conc_negative_offset = .true.
        else
          gas_conc_negative_offset = .false.
        endif
      else if (trim(gas_conc_time_dependency_type) == 'fixed_year') then
        gas_conc_time_serie_type = 2
        if (gas_conc_dataset_entry(1) == 1 .and. &
            gas_conc_dataset_entry(2) == 1 .and. &
            gas_conc_dataset_entry(3) == 1 .and. &
            gas_conc_dataset_entry(4) == 0 .and. &
            gas_conc_dataset_entry(5) == 0 .and. &
            gas_conc_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_sulfate_mod', &
            'must set gas_conc_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to gas_conc_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        gas_conc_entry  = set_date (gas_conc_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_sulfate_mod', &
           'gas_conc is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'gas_conc correspond to year :', &
                    gas_conc_dataset_entry(1)
        endif
     endif
     call interpolator_init (gas_conc_interp, trim(gas_conc_filename),  &
                             lonb, latb,&
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = gas_conc_name, &
                             vert_interp=(/INTERP_WEIGHTED_P/) )
      if (trim(anthro_source) .eq. 'do_anthro') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(anthro_time_dependency_type) == 'constant' ) then
        anthro_time_serie_type = 1
        anthro_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'anthro are constant in sulfate module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for anthro is selected.
!---------------------------------------------------------------------
      else if (trim(anthro_time_dependency_type) == 'time_varying') then
        anthro_time_serie_type = 3
        if (anthro_dataset_entry(1) == 1 .and. &
            anthro_dataset_entry(2) == 1 .and. &
            anthro_dataset_entry(3) == 1 .and. &
            anthro_dataset_entry(4) == 0 .and. &
            anthro_dataset_entry(5) == 0 .and. &
            anthro_dataset_entry(6) == 0 ) then
          anthro_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to anthro_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          anthro_entry  = set_date (anthro_dataset_entry(1), &
                                  anthro_dataset_entry(2), &
                                  anthro_dataset_entry(3), &
                                  anthro_dataset_entry(4), &
                                  anthro_dataset_entry(5), &
                                  anthro_dataset_entry(6))
        endif
        call print_date (anthro_entry , str= &
          'Data from anthro timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        anthro_offset = anthro_entry - model_init_time
        if (model_init_time > anthro_entry) then
          anthro_negative_offset = .true.
        else
          anthro_negative_offset = .false.
        endif
      else if (trim(anthro_time_dependency_type) == 'fixed_year') then
        anthro_time_serie_type = 2
        if (anthro_dataset_entry(1) == 1 .and. &
            anthro_dataset_entry(2) == 1 .and. &
            anthro_dataset_entry(3) == 1 .and. &
            anthro_dataset_entry(4) == 0 .and. &
            anthro_dataset_entry(5) == 0 .and. &
            anthro_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_sulfate_mod', &
            'must set anthro_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to anthro_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        anthro_entry  = set_date (anthro_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_sulfate_mod', &
           'anthro is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'anthro correspond to year :', &
                    anthro_dataset_entry(1)
        endif
     endif
     call interpolator_init (anthro_emission_interp,             &
                             trim(anthro_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = anthro_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
     endif ! end do_anthro

    if (trim(biobur_source) .eq. 'do_biobur') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(biobur_time_dependency_type) == 'constant' ) then
        biobur_time_serie_type = 1
        biobur_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'biobur are constant in sulfate module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for biobur is selected.
!---------------------------------------------------------------------
      else if (trim(biobur_time_dependency_type) == 'time_varying') then
        biobur_time_serie_type = 3
        if (biobur_dataset_entry(1) == 1 .and. &
            biobur_dataset_entry(2) == 1 .and. &
            biobur_dataset_entry(3) == 1 .and. &
            biobur_dataset_entry(4) == 0 .and. &
            biobur_dataset_entry(5) == 0 .and. &
            biobur_dataset_entry(6) == 0 ) then
          biobur_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to biobur_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          biobur_entry  = set_date (biobur_dataset_entry(1), &
                                  biobur_dataset_entry(2), &
                                  biobur_dataset_entry(3), &
                                  biobur_dataset_entry(4), &
                                  biobur_dataset_entry(5), &
                                  biobur_dataset_entry(6))
        endif
        call print_date (biobur_entry , str= &
          'Data from biobur timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        biobur_offset = biobur_entry - model_init_time
        if (model_init_time > biobur_entry) then
          biobur_negative_offset = .true.
        else
          biobur_negative_offset = .false.
        endif
      else if (trim(biobur_time_dependency_type) == 'fixed_year') then
        biobur_time_serie_type = 2
        if (biobur_dataset_entry(1) == 1 .and. &
            biobur_dataset_entry(2) == 1 .and. &
            biobur_dataset_entry(3) == 1 .and. &
            biobur_dataset_entry(4) == 0 .and. &
            biobur_dataset_entry(5) == 0 .and. &
            biobur_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_sulfate_mod', &
            'must set biobur_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to biobur_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        biobur_entry  = set_date (biobur_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_sulfate_mod', &
           'biobur is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'biobur correspond to year :', &
                    biobur_dataset_entry(1)
        endif
     endif
     call interpolator_init (biobur_emission_interp,             &
                             trim(biobur_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = biobur_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
     endif

     if (trim(ship_source) .eq. 'do_ship') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(ship_time_dependency_type) == 'constant' ) then
        ship_time_serie_type = 1
        ship_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'ship are constant in sulfate module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for ship is selected.
!---------------------------------------------------------------------
      else if (trim(ship_time_dependency_type) == 'time_varying') then
        ship_time_serie_type = 3
        if (ship_dataset_entry(1) == 1 .and. &
            ship_dataset_entry(2) == 1 .and. &
            ship_dataset_entry(3) == 1 .and. &
            ship_dataset_entry(4) == 0 .and. &
            ship_dataset_entry(5) == 0 .and. &
            ship_dataset_entry(6) == 0 ) then
          ship_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ship_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          ship_entry  = set_date (ship_dataset_entry(1), &
                                  ship_dataset_entry(2), &
                                  ship_dataset_entry(3), &
                                  ship_dataset_entry(4), &
                                  ship_dataset_entry(5), &
                                  ship_dataset_entry(6))
        endif
        call print_date (ship_entry , str= &
          'Data from ship timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        ship_offset = ship_entry - model_init_time
        if (model_init_time > ship_entry) then
          ship_negative_offset = .true.
        else
          ship_negative_offset = .false.
        endif
      else if (trim(ship_time_dependency_type) == 'fixed_year') then
        ship_time_serie_type = 2
        if (ship_dataset_entry(1) == 1 .and. &
            ship_dataset_entry(2) == 1 .and. &
            ship_dataset_entry(3) == 1 .and. &
            ship_dataset_entry(4) == 0 .and. &
            ship_dataset_entry(5) == 0 .and. &
            ship_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_sulfate_mod', &
            'must set ship_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to ship_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        ship_entry  = set_date (ship_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_sulfate_mod', &
           'ship is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'ship correspond to year :', &
                    ship_dataset_entry(1)
        endif
     endif
     call interpolator_init (ship_emission_interp,             &
                             trim(ship_filename),           &
                             lonb, latb,                        &
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = ship_emission_name,        &
                             vert_interp=(/INTERP_WEIGHTED_P/)  )
    endif

    if (trim(aircraft_source) .eq. 'do_aircraft') then
!---------------------------------------------------------------------
!    Set time for input file base on selected time dependency.
!---------------------------------------------------------------------
      if (trim(aircraft_time_dependency_type) == 'constant' ) then
        aircraft_time_serie_type = 1
        aircraft_offset = set_time(0, 0)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'aircraft are constant in sulfate module'
        endif
!---------------------------------------------------------------------
!    a dataset entry point must be supplied when the time dependency
!    for aircraft is selected.
!---------------------------------------------------------------------
      else if (trim(aircraft_time_dependency_type) == 'time_varying') then
        aircraft_time_serie_type = 3
        if (aircraft_dataset_entry(1) == 1 .and. &
            aircraft_dataset_entry(2) == 1 .and. &
            aircraft_dataset_entry(3) == 1 .and. &
            aircraft_dataset_entry(4) == 0 .and. &
            aircraft_dataset_entry(5) == 0 .and. &
            aircraft_dataset_entry(6) == 0 ) then
          aircraft_entry = model_init_time
        else
!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to aircraft_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
          aircraft_entry  = set_date (aircraft_dataset_entry(1), &
                                  aircraft_dataset_entry(2), &
                                  aircraft_dataset_entry(3), &
                                  aircraft_dataset_entry(4), &
                                  aircraft_dataset_entry(5), &
                                  aircraft_dataset_entry(6))
        endif
        call print_date (aircraft_entry , str= &
          'Data from aircraft timeseries at time:')
        call print_date (model_init_time , str= &
          'This data is mapped to model time:')
        aircraft_offset = aircraft_entry - model_init_time
        if (model_init_time > aircraft_entry) then
          aircraft_negative_offset = .true.
        else
          aircraft_negative_offset = .false.
        endif
      else if (trim(aircraft_time_dependency_type) == 'fixed_year') then
        aircraft_time_serie_type = 2
        if (aircraft_dataset_entry(1) == 1 .and. &
            aircraft_dataset_entry(2) == 1 .and. &
            aircraft_dataset_entry(3) == 1 .and. &
            aircraft_dataset_entry(4) == 0 .and. &
            aircraft_dataset_entry(5) == 0 .and. &
            aircraft_dataset_entry(6) == 0 ) then
           call error_mesg ('atmos_sulfate_mod', &
            'must set aircraft_dataset_entry when using fixed_year source', FATAL)
        endif

!----------------------------------------------------------------------
!    define the offset from model base time (obtained from diag_table)
!    to aircraft_dataset_entry as a time_type variable.
!----------------------------------------------------------------------
        aircraft_entry  = set_date (aircraft_dataset_entry(1), &
                                  2,1,0,0,0)
        call error_mesg ('atmos_sulfate_mod', &
           'aircraft is defined from a single annual cycle &
                &- no interannual variation', NOTE)
        if (mpp_pe() == mpp_root_pe() ) then
          print *, 'aircraft correspond to year :', &
                    aircraft_dataset_entry(1)
        endif
     endif

     call interpolator_init (aircraft_emission_interp, &
                             trim(aircraft_filename),  &
                             lonb, latb,&
                             data_out_of_bounds=  (/CONSTANT/), &
                             data_names = aircraft_emission_name, &
                             vert_interp=(/INTERP_WEIGHTED_P/) )
   endif

! Register diagnostic fields
   id_DMS_emis   = register_diag_field ( mod_name,                           &
                   'simpleDMS_emis', axes(1:2),Time,                         &
                   'simpleDMS_emis', 'kgS/m2/s',                             &
                    missing_value=-999.  )
   id_DMS_emis_cmip   = register_diag_field ( mod_name,                                   &
                   'simpleDMS_emis_cmip', axes(1:2),Time,                                 &
                   'simpleDMS_emis_cmip', 'kgDMS/m2/s',                                     &
                    missing_value=-999.  )
   id_SO2_emis   = register_diag_field ( mod_name,                           &
                   'simpleSO2_emis', axes(1:3),Time,                         &
                   'simpleSO2_emis', 'kgS/m2/s',                             &
                    missing_value=-999.  )
   id_SO4_emis   = register_diag_field ( mod_name,                           &
                   'simpleSO4_emis', axes(1:3),Time,                         &
                   'simpleSO4_emis', 'kgS/m2/s',                             &
                    missing_value=-999.  )
   id_DMSo       = register_diag_field ( mod_name,                           &
                   'DMSo',axes(1:2),Time,                                    &
                   'Dimethylsulfide seawater concentration',                 &
                   'nM/L')
   id_ph          = register_diag_field ( mod_name,                          &
                   'pH_simple_sulfate',axes(1:3),Time,                       &
                   'pH in simple-sulfate',                                   &
                   'none')
   id_O3           = register_diag_field ( mod_name,                         &
                   'O3_simple_sulfate',axes(1:3),Time,                       &
                   'O3 in simple-sulfate',                                   &
                   'none')
   id_SO2_aircraft = register_diag_field ( mod_name,                         &
                   'simpleSO2_aircraft_emis',axes(1:3),Time,                 &
                   'simpleSO2 emission by aircraft',                         &
                   'kgS/m2/s')
   id_SO2_biobur  = register_diag_field ( mod_name,                          &
                   'simpleSO2_biobur_emis',axes(1:3),Time,                   &
                   'simpleSO2 emission from biomass burning',                &
                   'kgS/m2/s')
   id_SO2_cont_volc = register_diag_field ( mod_name,                        &
                   'simpleSO2_cont_volc_emis',axes(1:3),Time,                &
                   'simpleSO2 emission from non-eruptive volcanoes',         &
                   'kgS/m2/s')
   id_SO2_expl_volc = register_diag_field ( mod_name,                        &
                   'simpleSO2_expl_volc_emis',axes(1:3),Time,                &
                   'simpleSO2 emission from eruptive volcanoes',             &
                   'kgS/m2/s')
   id_SO2_ship      = register_diag_field ( mod_name,                        &
                   'simpleSO2_ship_emis',axes(1:3),Time,                     &
                   'simpleSO2 emission from international shipping',         &
                   'kgS/m2/s')
   id_SO2_road      = register_diag_field ( mod_name,                        &
                   'simpleSO2_road_emis',axes(1:3),Time,                     &
                   'simpleSO2 emission from road transport',                 &
                   'kgS/m2/s')
   id_SO2_domestic = register_diag_field ( mod_name,                         &
                   'simpleSO2_domestic_emis',axes(1:3),Time,                 &
                   'simpleSO2 emission from domestic fossil fuel burning',   &
                   'kgS/m2/s')
   id_SO2_industry = register_diag_field ( mod_name,                         &
                   'simpleSO2_industry_emis',axes(1:3),Time,                 &
                   'simpleSO2 emission from industrial fossil fuel burning', &
                   'kgS/m2/s')
   id_SO2_power   = register_diag_field ( mod_name,                          &
                   'simpleSO2_power_emis',axes(1:3),Time,                    &
                   'simpleSO2 emission from power plants',                   &
                   'kgS/m2/s')
   id_SO2_off_road = register_diag_field ( mod_name,                         &
                   'simpleSO2_off_road_emis',axes(1:3),Time,                 &
                   'simpleSO2 emission from off-road transport',             &
                   'kgS/m2/s')
   id_SO2_ff      = register_diag_field ( mod_name,                          &
                   'simpleSO2_ff_emis',axes(1:3),Time,                       &
                   'simpleSO2 emission from fossil fuel burning',            &
                   'kgS/m2/s')
   id_NO3        = register_diag_field ( mod_name,                           &
                   'simpleNO3_diurnal',axes(1:3),Time,                       &
                   'Time varying NO3 concentration',                         &
                   'molec.cm-3')
   id_OH         = register_diag_field ( mod_name,                           &
                   'OH_simple_sulfate',axes(1:3),Time,                       &
                   'Varying Hydroxyl radical concentration',                 &
                   'molec.cm-3')
   id_jH2O2         = register_diag_field ( mod_name,                        &
                   'jH2O2_simple_sulfate',axes(1:3),Time,                    &
                   'Varying H2O2 photodissociation',                         &
                   's-1')
   id_HO2         = register_diag_field ( mod_name,                          &
                   'HO2_simple_sulfate',axes(1:3),Time,                      &
                   'Varying Hydroperoxyl radical concentration',             &
                   'molec.cm-3')
   id_DMS_chem   = register_diag_field ( mod_name,                           &
                   'simpleDMS_chem',axes(1:3),Time,                          &
                   'simpleDMS chemical production',                          &
                   'kgS/m2/s')
   id_SO2_chem   = register_diag_field ( mod_name,                           &
                   'simpleSO2_chem',axes(1:3),Time,                          &
                   'simpleSO2 chemical production',                          &
                   'kgS/m2/s')
   id_SO4_chem   = register_diag_field ( mod_name,                           &
                   'simpleSO4_chem',axes(1:3),Time,                          &
                   'simpleSO4 chemical production',                          &
                   'kgS/m2/s')
   id_SO4_oh_prod= register_diag_field ( mod_name,                           &
                   'simpleSO4_oh_prod',axes(1:3),Time,                       &
                   'simpleSO4 gas phase production',                         &
                   'kgS/m2/s')
   id_SO4_o3_prod= register_diag_field ( mod_name,                           &
                   'simpleSO4_o3_prod',axes(1:3),Time,                       &
                   'simpleSO4 aqueous phase production SO2+O3',              &
                   'kgS/m2/s')
   id_SO4_h2o2_prod= register_diag_field ( mod_name,                         &
                   'simpleSO4_h2o2_prod',axes(1:3),Time,                     &
                   'simpleSO4 aqueous phase production SO2+H2O2',            &
                   'kgS/m2/s')
   id_MSA_chem   = register_diag_field ( mod_name,                           &
                   'simpleMSA_chem',axes(1:3),Time,                          &
                   'simpleMSA chemical production',                          &
                   'kgS/m2/s')
   id_H2O2_chem   = register_diag_field ( mod_name,                          &
                   'simpleH2O2_chem',axes(1:3),Time,                         &
                   'simpleH2O2 chemical production',                         &
                   'kgH2O2/m2/s')

   call write_version_number (version, tagname)

   module_is_initialized = .TRUE.

!-----------------------------------------------------------------------
 end subroutine atmos_sulfate_init



!######################################################################

subroutine atmos_sulfate_time_vary (model_time)


type(time_type), intent(in) :: model_time

      integer :: yr,dum, mo_yr, mo, dy, hr, mn, sc, dayspmn


      call obtain_interpolator_time_slices (gocart_emission_interp, &
                                                           model_time)

      call obtain_interpolator_time_slices (aerocom_emission_interp, &
                                                           model_time)

      if (trim(anthro_source) .eq. 'do_anthro') then
!--------------------------------------------------------------------
!    define the time in the anthro data set from which data is to be 
!    taken. if anthro is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
          if(anthro_time_serie_type .eq. 3) then
            if (anthro_negative_offset) then
              anthro_time = model_time - anthro_offset
            else
              anthro_time = model_time + anthro_offset
            endif
          else
            if(anthro_time_serie_type .eq. 2 ) then
              call get_date (anthro_entry, yr, dum,dum,dum,dum,dum)
              call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
              if (mo ==2 .and. dy == 29) then
                dayspmn = days_in_month(anthro_entry)
                if (dayspmn /= 29) then
                  anthro_time = set_date (yr, mo, dy-1, hr, mn, sc)
                else
                  anthro_time = set_date (yr, mo, dy, hr, mn, sc)
                endif
              else
                anthro_time = set_date (yr, mo, dy, hr, mn, sc)
              endif
            else
              anthro_time = model_time
            endif
          endif
          call obtain_interpolator_time_slices &
                      (anthro_emission_interp, anthro_time)

      endif 

      if (trim(biobur_source) .eq. 'do_biobur') then
!--------------------------------------------------------------------
!    define the time in the biobur data set from which data is to be 
!    taken. if biobur is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
          if(biobur_time_serie_type .eq. 3) then
            if (biobur_negative_offset) then
              biobur_time = model_time - biobur_offset
            else
              biobur_time = model_time + biobur_offset
            endif
          else
            if(biobur_time_serie_type .eq. 2 ) then
              call get_date (biobur_entry, yr, dum,dum,dum,dum,dum)
              call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
              if (mo ==2 .and. dy == 29) then
                dayspmn = days_in_month(biobur_entry)
                if (dayspmn /= 29) then
                  biobur_time = set_date (yr, mo, dy-1, hr, mn, sc)
                else
                  biobur_time = set_date (yr, mo, dy, hr, mn, sc)
                endif
              else
                biobur_time = set_date (yr, mo, dy, hr, mn, sc)
              endif
            else
              biobur_time = model_time
            endif
          endif
          call obtain_interpolator_time_slices &
                            (biobur_emission_interp, biobur_time)

      endif 

      if (trim(ship_source) .eq. 'do_ship') then
!--------------------------------------------------------------------
!    define the time in the ship data set from which data is to be 
!    taken. if ship is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
          if(ship_time_serie_type .eq. 3) then
            if (ship_negative_offset) then
              ship_time = model_time - ship_offset
            else
              ship_time = model_time + ship_offset
            endif
          else
            if(ship_time_serie_type .eq. 2 ) then
              call get_date (ship_entry, yr, dum,dum,dum,dum,dum)
              call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
              if (mo ==2 .and. dy == 29) then
                dayspmn = days_in_month(ship_entry)
                if (dayspmn /= 29) then
                  ship_time = set_date (yr, mo, dy-1, hr, mn, sc)
                else
                  ship_time = set_date (yr, mo, dy, hr, mn, sc)
                endif
              else
                ship_time = set_date (yr, mo, dy, hr, mn, sc)
              endif
            else
              ship_time = model_time
            endif
          endif
          call obtain_interpolator_time_slices &
              (ship_emission_interp, ship_time)

        endif
!
! Aircraft emissions
      if (trim(aircraft_source) .eq. 'do_aircraft') then
        if(aircraft_time_serie_type .eq. 3) then
          if (aircraft_negative_offset) then
            aircraft_time = model_time - aircraft_offset
          else
            aircraft_time = model_time + aircraft_offset
          endif
        else
          if(aircraft_time_serie_type .eq. 2 ) then
            call get_date (aircraft_entry, yr, dum,dum,dum,dum,dum)
            call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
            if (mo ==2 .and. dy == 29) then
              dayspmn = days_in_month(aircraft_entry)
              if (dayspmn /= 29) then
                aircraft_time = set_date (yr, mo, dy-1, hr, mn, sc)
              else
                aircraft_time = set_date (yr, mo, dy, hr, mn, sc)
              endif
            else
              aircraft_time = set_date (yr, mo, dy, hr, mn, sc)
            endif
          else
            aircraft_time = model_time
          endif
        endif

!
          call obtain_interpolator_time_slices &
                         (aircraft_emission_interp, aircraft_time)
      endif


!--------------------------------------------------------------------
!    define the time in the gas_conc data set from which data is to be 
!    taken. if gas_conc is not time-varying, it is simply model_time.
!---------------------------------------------------------------------
     if(gas_conc_time_serie_type .eq. 3) then
       if (gas_conc_negative_offset) then
         gas_conc_time = model_time - gas_conc_offset
       else
         gas_conc_time = model_time + gas_conc_offset
       endif
     else
       if(gas_conc_time_serie_type .eq. 2 ) then
         call get_date (gas_conc_entry, yr, dum,dum,dum,dum,dum)
         call get_date (model_time, mo_yr, mo, dy, hr, mn, sc)
         if (mo ==2 .and. dy == 29) then
           dayspmn = days_in_month(gas_conc_entry)
           if (dayspmn /= 29) then
             gas_conc_time = set_date (yr, mo, dy-1, hr, mn, sc)
           else
             gas_conc_time = set_date (yr, mo, dy, hr, mn, sc)
           endif
         else
           gas_conc_time = set_date (yr, mo, dy, hr, mn, sc)
         endif
       else
         gas_conc_time = model_time
       endif
     endif

      call obtain_interpolator_time_slices &
                          (gas_conc_interp, gas_conc_time)

end subroutine atmos_sulfate_time_vary 




!######################################################################

subroutine atmos_sulfate_endts                    


      call unset_interpolator_time_flag (gocart_emission_interp)

      call unset_interpolator_time_flag (aerocom_emission_interp)

      if (trim(anthro_source) .eq. 'do_anthro') then
          call unset_interpolator_time_flag (anthro_emission_interp)
      endif 

      if (trim(biobur_source) .eq. 'do_biobur') then
          call unset_interpolator_time_flag (biobur_emission_interp)
      endif 

      if (trim(ship_source) .eq. 'do_ship') then
          call unset_interpolator_time_flag (ship_emission_interp)
      endif

      if (trim(aircraft_source) .eq. 'do_aircraft') then
          call unset_interpolator_time_flag (aircraft_emission_interp)
      endif

      call unset_interpolator_time_flag (gas_conc_interp)


end subroutine atmos_sulfate_endts         



!</SUBROUTINE>

!#######################################################################

!<SUBROUTINE NAME="atmos_sulfate_end">
!<OVERVIEW>
!  The destructor routine for the sulfate module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits. 
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_sulfate_end
!</TEMPLATE>
 subroutine atmos_sulfate_end

        call interpolator_end (aerocom_emission_interp) 
        call interpolator_end (gocart_emission_interp) 
        call interpolator_end (gas_conc_interp) 
        call interpolator_end (anthro_emission_interp) 
        call interpolator_end (biobur_emission_interp) 
        call interpolator_end (ship_emission_interp) 
        call interpolator_end (aircraft_emission_interp) 
        module_is_initialized = .FALSE.

 end subroutine atmos_sulfate_end
!</SUBROUTINE>
!#######################################################################
!</SUBROUTINE>
!<SUBROUTINE NAME="atmos_DMS_emission">
!<OVERVIEW>
! The constructor routine for the sulfate module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to calculate dimethyl sulfide emission form the ocean
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_DMS_emission (r, mask, axes, Time)
!</TEMPLATE>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>
subroutine atmos_DMS_emission (lon, lat, area, frac_land, t_surf_rad, w10m, &
       pwt, DMS_dt, Time, is,ie,js,je,kbot)
!
      real, intent(in),    dimension(:,:)           :: lon, lat
      real, intent(in),    dimension(:,:)           :: frac_land
      real, intent(in),    dimension(:,:)           :: t_surf_rad
      real, intent(in),    dimension(:,:)           :: w10m
      real, intent(in),    dimension(:,:)           :: area
      real, intent(in),    dimension(:,:,:)         :: pwt
      real, intent(out),   dimension(:,:,:)         :: DMS_dt
      type(time_type), intent(in)                   :: Time    
      integer, intent(in)                           :: is, ie, js, je
      integer, intent(in), dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
      real, dimension(size(DMS_dt,1),size(DMS_dt,2)) :: DMSo, DMS_emis
      integer                                        :: i, j, id, jd, kd
      real                                           :: sst, Sc, conc, w10 
      real                                           :: ScCO2, Akw
      real, parameter                                :: Sc_min=1.

      id=size(dms_dt,1); jd=size(dms_dt,2); kd=size(dms_dt,3)

      dms_dt(:,:,:) =0.0

      DMSo(:,:)=0.0
      call interpolator(gocart_emission_interp, Time, DMSo, &
                       trim(gocart_emission_name(1)), is, js)
! --- Send the DMS data to the diag_manager for output.
      if (id_DMSo > 0 ) &
          used = send_data ( id_DMSo, DMSo, Time, is_in=is, js_in=js )

! ****************************************************************************
! *  If frac_land < 0.5: DMS_emis = seawaterDMS * transfer velocity.         *
! *  Otherwise,  DMS_emis = 0.                                               *
! ****************************************************************************
!

      do j = 1, jd
      do i = 1, id
       SST = t_surf_rad(i,j)-273.15     ! Sea surface temperature [Celsius]
       if (frac_land(i,j).le.0.5) then

!  < Schmidt number for DMS (Saltzman et al., 1993) >
        Sc = 2674.0 - 147.12*SST + 3.726*(SST**2) - 0.038*(SST**3)
        Sc = max(Sc_min, Sc)

! ****************************************************************************
! *  Calculate transfer velocity in cm/hr  (AKw)                             *
! *                                                                          *
! *  Tans et al. transfer velocity (1990) for CO2 at 25oC (Erickson, 1993)   *
! *                                                                          *
! *  Tans et al. assumed AKW=0 when W10<=3. I modified it to let             *
! *  DMS emit at low windseeds too. Chose 3.6m/s as the threshold.           *
! *                                                                          *
! *  Schmidt number for CO2:       Sc = 600  (20oC, fresh water)             *
! *                                Sc = 660  (20oC, seawater)                *
! *                                Sc = 428  (25oC, Erickson 93)             *
! ****************************************************************************
!

        CONC = DMSo(i,j)

        W10  = W10M(i,j)

! ---  Tans et al. (1990) -----------------
!       ScCO2 = 428.
!       if (W10 .le. 3.6) then
!        AKw = 1.0667 * W10
!       else
!        AKw = 6.4 * (W10 - 3.)
!       end if

! ---  Wanninkhof (1992) ------------------
!       ScCO2 = 660.
!       AKw = 0.31 * W10**2

! ---  Liss and Merlivat (1986) -----------
        ScCO2 = 600.
        if (W10 .le. 3.6) then
         AKw = 0.17 * W10
        else if (W10 .le. 13.) then
         AKw = 2.85 * W10 - 9.65
        else
         AKw = 5.90 * W10 - 49.3
        end if
!------------------------------------------

        if (W10 .le. 3.6) then
         AKw = AKw * ((ScCO2/Sc) ** 0.667)
        else
         AKw = AKw * sqrt(ScCO2/Sc)
        end if

! ****************************************************************************
! *  Calculate emission flux in kg/m2/s                                  *
! *                                                                          *
! *   AKw is in cm/hr:             AKw/100/3600    -> m/sec.                 *
! *   CONC is in nM/L (nM/dm3):    CONC*1E-12*1000 -> kmole/m3.              *
! *   WTM_DMS          : kgDMS/kmol.                                         *
! *   DMS_EMIS         : kgDMS/m2/s.                                         *
! ****************************************************************************
!
        DMS_emis(i,j) = AKw/100./3600. * CONC*1.e-12*1000.* WTM_DMS &
            * (1.-frac_land(i,j))
!
       else                !  frac_land <> 1 (water)
        DMS_emis(i,j) = 0.

       end if              ! -- if frac_land = 1.

      end do
      end do
!--------------------------------------------------------------------
! Update DMS concentration in level kd (where emission occurs)
!--------------------------------------------------------------------
      dms_dt(:,:,kd)=DMS_emis(:,:)/pwt(:,:,kd)* WTMAIR/WTM_DMS
!------------------------------------------------------------------
! DIAGNOSTICS:      DMS surface emission in kg/m2/s     
!--------------------------------------------------------------------
      if (id_DMS_emis > 0) then
        used = send_data ( id_DMS_emis, dms_emis*WTM_S/WTM_DMS, Time, &
              is_in=is,js_in=js )
      endif
      if (id_DMS_emis_cmip > 0) then
        used = send_data ( id_DMS_emis_cmip, dms_emis, Time, &
              is_in=is,js_in=js )
      endif

end subroutine atmos_DMS_emission
!#######################################################################
!</SUBROUTINE>
!<SUBROUTINE NAME="atmos_SO2_emission">
!<OVERVIEW>
! The constructor routine for the sulfate module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to calculate SO2 emission from volcanoes, biomass burning,
! anthropogenic sources, aircraft.
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_SO2_emission ()
!</TEMPLATE>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace).
!   </INOUT>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>
subroutine atmos_SOx_emission (lon, lat, area, frac_land, &
       z_pbl, zhalf, phalf, pwt, SO2_dt, SO4_dt, model_time, is,ie,js,je,kbot)
!
! This subroutine calculates the tendencies of SO2 and SO4 due to
! their emissions.
! The inventories are based from AEROCOM (cf. Dentener, ACPD, 2006)
! except the aircraft emission.
! The emission of SO4 is assumed to be fe=2.5% of all sulfur emission
! (cf. Dentener, ACPD, 2006). NB. Some authors consider 5%
!
      real, intent(in),    dimension(:,:)           :: lon, lat
      real, intent(in),    dimension(:,:)           :: frac_land
      real, intent(in),    dimension(:,:)           :: area
      real, intent(in),    dimension(:,:)           :: z_pbl
      real, intent(in),    dimension(:,:,:)         :: zhalf, phalf
      real, intent(in),    dimension(:,:,:)         :: pwt
      real, intent(out),   dimension(:,:,:)         :: SO2_dt, SO4_dt
      type(time_type), intent(in)                   :: model_time
      integer, intent(in)                           :: is, ie, js, je
      integer, intent(in), dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
      integer, parameter :: nlevel_fire = 6
      real, dimension(size(SO4_dt,1),size(SO4_dt,2),size(SO4_dt,3)) :: SO4_emis
      real, dimension(size(SO2_dt,1),size(SO2_dt,2),size(SO2_dt,3)) :: SO2_emis
      real, dimension(size(SO2_dt,1),size(SO2_dt,2),size(SO2_dt,3)) :: &
        so2_aircraft,so2_emis_cont_volc, so2_emis_expl_volc, so2_emis_biobur, &
        so2_emis_ship, so2_emis_road, so2_emis_domestic, so2_emis_industry, &
        so2_emis_power, so2_emis_off_road, so2_emis_ff
! Input emission fields
      real, dimension(size(SO2_dt,1),size(SO2_dt,2)) :: &
             SO2_ff1, SO2_ff2, SO4_ff1, SO4_ff2,&
             SO2_RoadTransport,                         &
             SO2_Off_road,                              &
             SO2_Domestic,                              &
             SO2_Industry,                              &
             SO2_Ship, SO4_ship,                        &
             SO2_Powerplants
      real, dimension(size(SO2_dt,1),size(SO2_dt,2),num_volc_levels) :: &
             SO2_cont_volc,                             &
             SO2_expl_volc
      real, dimension(size(SO2_dt,1),size(SO2_dt,2),nlevel_fire) :: &
             SO2_biobur
! Factors of vertical distribution of emissions
      real, dimension(size(SO2_dt,3)) :: fbb, fa1, fa2, fcv, fev
      real, dimension(size(SO2_dt,3),nlevel_fire) :: ff
! Lower altitude of injection of SO2 from wild fires 
! These values correspond to the AEROCOM input data (cf. Dentener, ACPD, 2006)
      real, dimension(nlevel_fire) :: &
             alt_fire_min=(/0.,100.,500.,1000.,2000.,3000./)
! Upper altitude of injection of SO2 from wild fires 
! These values correspond to the AEROCOM input data (cf. Dentener, ACPD, 2006)
      real, dimension(nlevel_fire) :: &
             alt_fire_max=(/100.,500.,1000.,2000.,3000.,6000./)
! Altitude of injection of surafce anthropogenic emissions
      real :: ze1
! Altitude of injection of SO2 from industries and power plants.   
      real :: ze2
! Emission factor for SO4
      real, parameter :: fe = 0.025

      real :: z1, z2, bltop, fbt, del
      integer  :: i, j, l, id, jd, kd, il, lf
      integer :: ivolc_lev

      id=size(SO2_dt,1); jd=size(SO2_dt,2); kd=size(SO2_dt,3)
!
! Initialize
!
      SO2_dt(:,:,:) = 0.0
      SO4_dt(:,:,:) = 0.0
      SO2_emis(:,:,:) = 0.0
      SO4_emis(:,:,:) = 0.0
! GOCART emissions
      SO2_ff1(:,:)=0.0
      SO2_ff2(:,:)=0.0
      SO4_ff1(:,:)=0.0
      SO4_ff2(:,:)=0.0
! AEROCOM emissions
      SO2_RoadTransport(:,:)=0.0
      SO2_Off_road(:,:)=0.0
      SO2_Domestic(:,:)=0.0
      SO2_Industry(:,:)=0.0
      SO2_Ship(:,:)=0.0
      SO4_Ship(:,:)=0.0
      SO2_Powerplants(:,:)=0.0
      SO2_aircraft(:,:,:)=0.0
      SO2_biobur(:,:,:)=0.0

      SO2_cont_volc(:,:,:)=0.0
      SO2_expl_volc(:,:,:)=0.0
! Arrays for output diagnostics
      so2_aircraft(:,:,:)=0.0
      so2_emis_cont_volc(:,:,:)=0.0
      so2_emis_expl_volc(:,:,:)=0.0
      so2_emis_biobur(:,:,:)=0.0
      so2_emis_ship(:,:,:)=0.0
      so2_emis_road(:,:,:)=0.0
      so2_emis_domestic(:,:,:)=0.0
      so2_emis_industry(:,:,:)=0.0
      so2_emis_power(:,:,:)=0.0
      so2_emis_off_road(:,:,:)=0.0
      so2_emis_ff(:,:,:)=0.0
!
      select case ( trim(runtype))
        case ('gocart')
          if (trim(anthro_source) .eq. 'do_anthro') then
            call interpolator(gocart_emission_interp, model_time, SO2_ff1, &
                         trim(gocart_emission_name(2)), is, js)
            call interpolator(gocart_emission_interp, model_time, SO2_ff2, &
                         trim(gocart_emission_name(3)), is, js)
            call interpolator(gocart_emission_interp, model_time, SO4_ff1, &
                         trim(gocart_emission_name(4)), is, js)
            call interpolator(gocart_emission_interp, model_time, SO4_ff2, &
                         trim(gocart_emission_name(5)), is, js)
          endif
          if (trim(biobur_source) .eq. 'do_biobur') then 
            call interpolator(gocart_emission_interp, model_time, &
                         SO2_biobur(:,:,1),trim(gocart_emission_name(6)), is, js)
          endif
        case ('aerocom')
          if (trim(anthro_source) .eq. 'do_anthro') then
            call interpolator(aerocom_emission_interp, model_time, &
                         SO2_RoadTransport,trim(aerocom_emission_name(1)),is, js)
            call interpolator(aerocom_emission_interp, model_time, SO2_Off_road, &
                         trim(aerocom_emission_name(2)), is, js)
            call interpolator(aerocom_emission_interp, model_time, SO2_Domestic, &
                         trim(aerocom_emission_name(3)), is, js)
            call interpolator(aerocom_emission_interp, model_time, SO2_Industry, &
                         trim(aerocom_emission_name(4)), is, js)
            call interpolator(aerocom_emission_interp, model_time, SO2_ship, &
                         trim(aerocom_emission_name(5)), is, js)
            call interpolator(aerocom_emission_interp, model_time, &
                         SO2_Powerplants, trim(aerocom_emission_name(6)), is, js)
          endif
          if (trim(biobur_source) .eq. 'do_biobur') then
! Wildfire emissions at 6 levels from 0 to 6 km
! (cf. AEROCOM web site or Dentener et al., ACPD, 2006)
            do il=1,nlevel_fire
              call interpolator(aerocom_emission_interp, model_time, &
                         SO2_biobur(:,:,il), &
                         trim(aerocom_emission_name(12+il)), is, js)
            enddo
          endif
        case default
          if (trim(anthro_source) .eq. 'do_anthro') then
            call interpolator(anthro_emission_interp, anthro_time, SO2_ff1(:,:), &
                     trim(anthro_emission_name(1)), is, js)
            call interpolator(anthro_emission_interp, anthro_time, SO4_ff1(:,:), &
                     trim(anthro_emission_name(2)), is, js)
          endif
          if (trim(biobur_source) .eq. 'do_biobur') then
            call interpolator(biobur_emission_interp, biobur_time, SO2_biobur(:,:,1), &
                     trim(biobur_emission_name(1)), is, js)
          endif
          if (trim(ship_source) .eq. 'do_ship') then
            call interpolator(ship_emission_interp, ship_time, SO2_ship(:,:), &
                     trim(ship_emission_name(1)), is, js)
            call interpolator(ship_emission_interp, ship_time, SO4_ship(:,:), &
                     trim(ship_emission_name(2)), is, js)
          endif

      end select
!
! Aircraft emissions
      if (trim(aircraft_source) .eq. 'do_aircraft') then
        call interpolator(aircraft_emission_interp, aircraft_time, &
                     phalf, SO2_aircraft, &
                     trim(aircraft_emission_name(1)), is, js)
      endif
!
! Continuous volcanoes
!
      if (trim(cont_volc_source) .eq. 'do_cont_volc') then
        do ivolc_lev = 1,num_volc_levels
           call interpolator( aerocom_emission_interp, model_time, SO2_cont_volc(:,:,ivolc_lev), &
                              trim(aerocom_emission_name(std_aerocom_emission+ivolc_lev)), is, js )
        end do
      endif
!
! Explosive volcanoes
!
      if (trim(expl_volc_source) .eq. 'do_expl_volc') then
        do ivolc_lev = 1,num_volc_levels
           call interpolator( aerocom_emission_interp, model_time, SO2_expl_volc(:,:,ivolc_lev), &
!                             trim(expl_volc_emission_name(ivolc_lev)), is, js )
                              trim(aerocom_emission_name(std_aerocom_emission+num_volc_levels+ivolc_lev)), is, js )
        end do
      endif

      do j = 1, jd
      do i = 1, id

! --- Assuming biomass burning emission within the PBL -------
        fbb(:) = 0.
        ze1=100.
        ze2=500.
        fbt=0.
        bltop = z_pbl(i,j)
        do l = kd,1,-1
          z1=zhalf(i,j,l+1)-zhalf(i,j,kd+1)
          z2=zhalf(i,j,l)-zhalf(i,j,kd+1)
          if (bltop.lt.z1) exit
          if (bltop.ge.z2) fbb(l)=(z2-z1)/bltop
          if (bltop.gt.z1.and.bltop.lt.z2) fbb(l) = (bltop-z1)/bltop
        enddo
! --- Assuming anthropogenic source L1 emitted below Ze1, and L2
!     emitted between Ze1 and Ze2.
        ff(:,:)=0.
        if (runtype.eq.'aerocom') then
          do l = kd,2,-1
            Z1 = zhalf(i,j,l+1)-zhalf(i,j,kd+1)
            Z2 = zhalf(i,j,l)-zhalf(i,j,kd+1)
            do lf=1,nlevel_fire
              del=alt_fire_max(lf)-alt_fire_min(lf)
              if (del.gt.0. .and. &
                  Z1.lt.alt_fire_max(lf).and.Z2.gt.alt_fire_min(lf) ) then
                if (Z1.ge.alt_fire_min(lf)) then
                  if (Z2 .lt. alt_fire_max(lf)) then
                    ff(l,lf)=(Z2-Z1)/del
                  else
                    ff(l,lf)=(alt_fire_max(lf)-z1)/del
                  endif
                else
                  if (Z2.le.alt_fire_max(lf)) then
                    ff(l,lf) = (Z2-alt_fire_min(lf))/del
                  else
                    ff(l,lf)=1.
                  endif
                endif
              endif
            enddo
          enddo
        endif
! --- Volcanic SO2 source ----
! --- For continuous and explosive volcanoes, calculate the fraction of emission
! --- for each vertical level
      if (trim(cont_volc_source) == 'do_cont_volc') then
        do ivolc_lev = 1,num_volc_levels
          fcv(:)=0.
          do l = kd,2,-1
            Z1 = zhalf(i,j,l+1)-zhalf(i,j,kd+1)
            Z2 = zhalf(i,j,l)-zhalf(i,j,kd+1)
            del=volc_altitude_edges(ivolc_lev+1)-volc_altitude_edges(ivolc_lev)
            if (del>0. .and. &
                Z1<volc_altitude_edges(ivolc_lev+1) .and. Z2>volc_altitude_edges(ivolc_lev) ) then
              if (Z1 >= volc_altitude_edges(ivolc_lev)) then
                if (Z2 < volc_altitude_edges(ivolc_lev+1)) then
                  fcv(l)=(Z2-Z1)/del
                else
                  fcv(l)=(volc_altitude_edges(ivolc_lev+1)-Z1)/del
                endif
              else
                if (Z2 <= volc_altitude_edges(ivolc_lev+1)) then
                  fcv(l)=(Z2-volc_altitude_edges(ivolc_lev))/del
                else
                  fcv(l)=1.
                endif
              endif
            endif
          enddo
          so2_emis_cont_volc(i,j,:) = so2_emis_cont_volc(i,j,:) + fcv(:) * SO2_cont_volc(i,j,ivolc_lev)
        end do
      endif
! --- For explosive volcanoes, calculate the fraction of emission for
! --- each vertical levels
      if (trim(expl_volc_source) == 'do_expl_volc') then 
        do ivolc_lev = 1,num_volc_levels
          fev(:)=0.
          do l = kd,2,-1
            Z1 = zhalf(i,j,l+1)-zhalf(i,j,kd+1)
            Z2 = zhalf(i,j,l)-zhalf(i,j,kd+1)
            del=volc_altitude_edges(ivolc_lev+1)-volc_altitude_edges(ivolc_lev)
            if (del>0. .and. &
                Z1<volc_altitude_edges(ivolc_lev+1).and.Z2>volc_altitude_edges(ivolc_lev) ) then
              if (Z1 >= volc_altitude_edges(ivolc_lev)) then
                if (Z2 < volc_altitude_edges(ivolc_lev+1)) then
                  fev(l)=(Z2-Z1)/del
                else
                  fev(l)=(volc_altitude_edges(ivolc_lev+1)-Z1)/del
                endif
              else
                if (Z2 <= volc_altitude_edges(ivolc_lev+1)) then
                  fev(l)=(Z2-volc_altitude_edges(ivolc_lev))/del
                else
                  fev(l)=1.
                endif
              endif
            endif
          enddo
          so2_emis_expl_volc(i,j,:) = so2_emis_expl_volc(i,j,:) + fev(:) * SO2_expl_volc(i,j,ivolc_lev)
        end do
      endif
! --- For fosil fuel emissions, calculate the fraction of emission for
! --- each vertical levels
        fa1(:) = 0.
        fa2(:) = 0.
        do l = kd,2,-1
          Z1 = zhalf(i,j,l+1)-zhalf(i,j,kd+1)
          Z2 = zhalf(i,j,l)-zhalf(i,j,kd+1)
          if (Z2.ge.0.and.Z1.lt.ze1) then
            if (Z1.gt.0) then
              if (Z2.lt.ze1) then
                fa1(l)=(Z2-Z1)/ze1
              else
                fa1(l)=(ze1-Z1)/ze1
              endif
            else
              if (Z2.le.ze1) then
                fa1(l)=Z2/ze1
              else
                fa1(l)=1.
              endif
            endif
          endif

          if (Z2.ge.ze1.and.z1.lt.ze2) then
            if (Z1.gt.Ze1) then
              if (Z2.lt.ze2) then
                fa2(l)=(z2-z1)/(ze2-ze1)
              else
                fa2(l)=(ze2-z1)/(ze2-ze1)
              endif
            else
              if (Z2.le.ze2) then
                fa2(l)=(z2-ze1)/(ze2-ze1)
              else
                fa2(l)=1.
              endif
            endif
          endif
          if (Z1.gt.Ze2) exit
        enddo
! SO2_emis: [kgSO2/m2/s]
!       Assuming that 1g of SO2 is emitted from 1kg of fuel: 1.e-3
        SO2_emis(i,j,:) = so2_aircraft_EI * SO2_aircraft(i,j,:) &
             + so2_emis_cont_volc(i,j,:) + so2_emis_expl_volc(i,j,:)
!
        select case (trim(runtype))
          case ('aerocom')
            do lf = 1, nlevel_fire
              so2_emis_biobur(i,j,:) = so2_emis_biobur(i,j,:) + &
                                       ff(:,lf)*SO2_biobur(i,j,lf)
            enddo
            so2_emis_road(i,j,:)     = fa1(:) * SO2_RoadTransport(i,j)
            so2_emis_off_road(i,j,:) = fa1(:) * SO2_off_Road(i,j)
            so2_emis_domestic(i,j,:) = fa1(:) * SO2_domestic(i,j)
            so2_emis_ship(i,j,:)     = fa1(:) * SO2_ship(i,j)
            so2_emis_industry(i,j,:) = fa2(:) * SO2_industry(i,j)
            so2_emis_power(i,j,:)    = fa2(:) * SO2_Powerplants(i,j)

            SO2_emis(i,j,:) = SO2_emis(i,j,:) + so2_emis_biobur(i,j,:)

            so2_emis_ff(i,j,:) =                                  &
                 + so2_emis_road(i,j,:)                           &
                 + so2_emis_off_road(i,j,:)                       &
                 + so2_emis_domestic(i,j,:)                       &
                 + so2_emis_ship(i,j,:)                           &
                 + so2_emis_industry(i,j,:)                       &
                 + so2_emis_power(i,j,:)
             SO2_emis(i,j,:) = SO2_emis(i,j,:) + so2_emis_ff(i,j,:)
          case ('gocart')
!
! GOCART assumes continent based emission index for sulfate:
!    Anthropogenic SOx emission from GEIA 1985.
!    Assuming:   Europe:      5.0% SOx emission is SO4;
!                US + Canada: 1.4% SOx emission is SO4;
!                The rest:    2.5% SOx emission is SO4.
            so2_emis_ff(i,j,:)=fa1(:) * SO2_ff1(i,j) + fa2(:) * SO2_ff2(i,j)
            so2_emis_biobur(i,j,:) = fbb(:) * SO2_biobur(i,j,1)
            SO2_emis(i,j,:) = SO2_emis(i,j,:) &
               + so2_emis_biobur(i,j,:)       &
               + so2_emis_ff(i,j,:)
            SO4_emis(i,j,:) = &
               fa1(:) * SO4_ff1(i,j) + fa2(:) * SO4_ff2(i,j)
          case default
            so2_emis_ff(i,j,:)=fa1(:) * SO2_ff1(i,j) + fa2(:) * SO2_ff2(i,j)
            so2_emis_biobur(i,j,:) = fbb(:) * SO2_biobur(i,j,1)
            so2_emis_ship(i,j,:)     = fa1(:) * SO2_ship(i,j)
            SO2_emis(i,j,:) = SO2_emis(i,j,:) &
               + so2_emis_biobur(i,j,:)       &
!++lwh
               + so2_emis_ship(i,j,:)         &
!--lwh
               + so2_emis_ff(i,j,:)
            SO4_emis(i,j,:) = fa1(:)*(SO4_ff1(i,j)+SO4_ship(i,j))
        end select

      end do   ! end i loop
      end do   ! end j loop
!
      SO2_dt(:,:,:)= SO2_emis(:,:,:)/pwt(:,:,:)*WTMAIR/WTM_SO2
      SO4_dt(:,:,:)= SO4_emis(:,:,:)/pwt(:,:,:)*WTMAIR/WTM_SO4

!------------------------------------------------------------------
! DIAGNOSTICS:      SO2 and SO4 emission in kg/timestep
!--------------------------------------------------------------------
      if (id_so2_emis > 0) then
        used = send_data ( id_so2_emis, so2_emis*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js,ks_in=1)
      endif
      if (id_so2_aircraft > 0) then
        used = send_data ( id_so2_aircraft, &
              so2_aircraft*so2_aircraft_EI*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_cont_volc > 0) then
        used = send_data ( id_so2_cont_volc, so2_emis_cont_volc*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_expl_volc > 0) then
        used = send_data ( id_so2_expl_volc, so2_emis_expl_volc*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_biobur > 0) then
        used = send_data ( id_so2_biobur, so2_emis_biobur*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js,ks_in=1)
      endif
      if (id_so2_ship > 0) then
        used = send_data ( id_so2_ship, so2_emis_ship*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_road > 0) then
        used = send_data ( id_so2_road, so2_emis_road*WTM_S/WTM_so2,  &
               model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_domestic > 0) then
        used = send_data ( id_so2_domestic, so2_emis_domestic*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_industry > 0) then
        used = send_data ( id_so2_industry, so2_emis_industry*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_power > 0) then
        used = send_data ( id_so2_power, so2_emis_power*WTM_S/WTM_so2, &
              model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_off_road > 0) then
        used = send_data ( id_so2_Off_road, so2_emis_off_road*WTM_S/WTM_so2, &
               model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so2_ff > 0) then
        used = send_data ( id_so2_ff, so2_emis_ff*WTM_S/WTM_so2, &
               model_time, is_in=is,js_in=js, ks_in=1)
      endif
      if (id_so4_emis > 0) then
        used = send_data ( id_so4_emis, so4_emis*WTM_S/WTM_so4, model_time, &
              is_in=is,js_in=js,ks_in=1)
      endif

end subroutine atmos_SOx_emission
!</SUBROUTINE>
!-----------------------------------------------------------------------
!#######################################################################
      subroutine atmos_SOx_chem(pwt,temp,pfull, phalf, dt, lwc, &
        jday,hour,minute,second,lat,lon, &
        SO2, SO4, DMS, MSA, H2O2, &
        SO2_dt, SO4_dt, DMS_dt, MSA_dt, H2O2_dt, &
        model_time,is,ie,js,je,kbot)
!
      real, intent(in)                   :: dt
      integer, intent(in)                :: jday, hour,minute,second
      real, intent(in),  dimension(:,:)  :: lat, lon  ! [radi
      real, intent(in), dimension(:,:,:) :: pwt
      real, intent(in), dimension(:,:,:) :: lwc
      real, intent(in), dimension(:,:,:) :: temp, pfull, phalf
      real, intent(in), dimension(:,:,:) :: SO2, SO4, DMS, MSA, H2O2
      real, intent(out),dimension(:,:,:) :: SO2_dt,SO4_dt,DMS_dt,MSA_dt,H2O2_dt

      type(time_type), intent(in)                    :: model_time
      integer, intent(in),  dimension(:,:), optional :: kbot
      integer, intent(in)                            :: is,ie,js,je
! Working vectors
      integer :: i,j,k,id,jd,kd
      integer                                    :: istep, nstep
!!! Input fields from interpolator
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: pH
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: O3_mmr
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: no3_conc
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: oh_conc
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: jh2o2
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: ho2_conc
!!! Time varying fields
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: no3_diurnal
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: oh_diurnal
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) ::jh2o2_diurnal
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: ho2_diurnal
      real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) :: &
               SO4_oh_prod, SO4_o3_prod, SO4_h2o2_prod

      real, dimension(size(pfull,1),size(pfull,2)) :: &
               xu, dayl, h, hl, hc, hred
      real, dimension(size(pfull,1),size(pfull,2)) :: fac_NO3, fact_NO3
      real, dimension(size(pfull,1),size(pfull,2)) :: fac_OH , fact_OH 
      real, dimension(size(pfull,1),size(pfull,2)) :: fac_HO2            
      real, parameter                            :: A0 = 0.006918
      real, parameter                            :: A1 = 0.399912
      real, parameter                            :: A2 = 0.006758
      real, parameter                            :: A3 = 0.002697
      real, parameter                            :: B1 = 0.070257
      real, parameter                            :: B2 = 0.000907
      real, parameter                            :: B3 = 0.000148
      real                                       :: decl, hd, x
      real :: f, f1, tk, rho_air
      real :: SO2_0,SO4_0,MSA_0,DMS_0,H2O2_0    ! initial concentrations
      real :: xSO2,xSO4,xMSA,xDMS,xH2O2,xno3,xo3,xoh,xho2,xjh2o2 ! update conc.
      real :: rk0, rk1, rk2, rk3  ! kinetic rates
      real :: work1, xk, xe, x2, xph
      real :: heh2o2, h2o2g, rah2o2, px, heso2, so2g, heo3, o3g, rao3
      real :: pso4a, pso4b
      real :: xlwc, xhnm, ccc1, ccc2
      real :: pmsa, pso2, ph2o2    ! chemical production terms
      real :: ldms, lso2, lh2o2          ! chemical loss terms
      real :: o2
      real, parameter        :: small_value=1.e-21
      real, parameter        :: t0 = 298.
      real, parameter        :: Ra = 8314./101325.
      real, parameter        :: xkw = 1.e-14 ! water acidity
      real, parameter        :: const0 = 1.e3/6.022e23


! Local grid sizes
      id=size(pfull,1) ; jd=size(pfull,2) ; kd=size(pfull,3)

      so2_dt(:,:,:) = 0.0
      so4_dt(:,:,:) = 0.0
      dms_dt(:,:,:) = 0.0
      msa_dt(:,:,:) = 0.0
      h2o2_dt(:,:,:) = 0.0
      SO4_h2o2_prod(:,:,:)=0.0
      SO4_o3_prod(:,:,:)=0.0
      SO4_oh_prod(:,:,:)=0.0


      OH_conc(:,:,:)=1.e5  ! molec/cm3
      call interpolator(gas_conc_interp, gas_conc_time, phalf, OH_conc, &
                       trim(gas_conc_name(1)), is, js)

      HO2_conc(:,:,:)=1.e6  ! molec/cm3
      call interpolator(gas_conc_interp, gas_conc_time, phalf, HO2_conc, &
                       trim(gas_conc_name(2)), is, js)

      NO3_conc(:,:,:)=0.0  ! molec/cm3
      call interpolator(gas_conc_interp, gas_conc_time, phalf, NO3_conc, &
                       trim(gas_conc_name(3)), is, js)

      O3_mmr(:,:,:)=0  ! Ozone mass mixing ratio
      call interpolator(gas_conc_interp, gas_conc_time, phalf, O3_mmr, &
                       trim(gas_conc_name(4)), is, js)
      O3_mmr(:,:,:)=O3_mmr(:,:,:)*WTM_O3/WTMAIR

      jH2O2(:,:,:)=1.e-6 ! s-1
      call interpolator(gas_conc_interp, gas_conc_time, phalf, jH2O2, &
                       trim(gas_conc_name(5)), is, js)

      pH(:,:,:)=1.e-5
      call interpolator(gas_conc_interp, gas_conc_time, phalf, pH, &
                       trim(gas_conc_name(6)), is, js)

      x = 2. *pi *float(jday-1)/365.
      decl = A0 - A1*cos(  X) + B1*sin(  X) - A2*cos(2.*X) + B2*sin(2.*X) &
           - A3*cos(3.*X) + B3*sin(3.*X)
      xu(:,:) = -tan(lat(:,:))*tan(decl)

      where ( xu > -1 .and. xu < 1 ) dayl=acos(xu)/pi
      where ( xu <= -1 ) dayl = 1.
      where ( xu >= 1 ) dayl = 0.
!   Calculate normalization factors for OH and NO3 such that
!   the diurnal average respect the monthly input values.
      hd=0.
      fact_OH(:,:)  = 0.
      fact_NO3(:,:) = 0.
      nstep = int(24.*3600./dt)
      do istep=1,nstep
        hd=hd+dt/3600./24.
        hl(:,:) = pi*(1.-dayl(:,:))
        hc(:,:) = pi*(1.+dayl(:,:))
        h(:,:)=2.*pi*mod(hd+lon(:,:)/2./pi,1.)
        where ( h.ge.hl .and. h.lt.hc )
! Daytime
          hred=(h-hl)/(hc-hl)
          fact_OH  = fact_OH + amax1(0.,sin(pi*hred)/2.)/nstep
        elsewhere
! Nightime
          fact_NO3 = fact_NO3 + amax1(0.,amin1(1.,(1.-dayl)))/nstep
        endwhere
      enddo

      hd=amax1(0.,amin1(1.,(hour+minute/60.+second/3600.)/24.))
      hl(:,:) = pi*(1.-dayl(:,:))
      hc(:,:) = pi*(1.+dayl(:,:))
      h(:,:)=2.*pi*mod(hd+lon(:,:)/2./pi,1.)
      fac_OH(:,:)  = 0.
      fac_NO3(:,:) = 0.
      fac_HO2(:,:) = 1.
      where ( h.ge.hl .and. h.lt.hc )
! Daytime
          fac_NO3 = 0.
          hred=(h-hl)/(hc-hl)
          fac_OH  = amax1(0.,sin(pi*hred)/2.)/fact_OH
      elsewhere
! Nightime
          fac_NO3 = amax1(0.,amin1(1.,(1.-dayl)))/fact_NO3
          fac_OH  = 0.
      endwhere


! < Factor to convert AIRDEN from kgair/m3 to molecules/cm3: >
      f  = 1000. / WTMAIR * 6.022e23 * 1.e-6

      do k = 1, kd
      do j = 1, jd
      do i = 1, id
       tk    = temp(i,j,k)
       rho_air = pfull(i,j,k)/tk/RDGAS             ! Air density [kg/m3]
       xhnm  = rho_air * f
       O2    = xhnm * 0.21
       xlwc  = lwc(i,j,k)*rho_air *1.e-3
       DMS_0 = max(0.,DMS(i,j,k))
       MSA_0 = max(0.,MSA(i,j,k))
       SO4_0 = max(0.,SO4(i,j,k))
       SO2_0 = max(0.,SO2(i,j,k))
       H2O2_0= max(0.,H2O2(i,j,k))
       xSO2  = SO2_0
       xSO4  = SO4_0
       xH2O2 = H2O2_0
       xDMS  = DMS_0
       xMSA  = MSA_0
       xph   = max(1.e-7,       pH(i,j,k))
       xoh   = max(0.         , OH_conc(i,j,k)  *fac_OH(i,j))
       xho2  = max(0.         , HO2_conc(i,j,k) *fac_HO2(i,j))
       xjh2o2= max(0.         , jH2O2(i,j,k)    *fac_OH(i,j))
       xno3  = max(0.         , NO3_conc(i,j,k) *fac_NO3(i,j))
       xo3   = max(small_value, O3_mmr(i,j,k))
       oh_diurnal(i,j,k)=xoh
       no3_diurnal(i,j,k)=xno3
       ho2_diurnal(i,j,k)=xho2
       jh2o2_diurnal(i,j,k)=xjh2o2
! ****************************************************************************
! *  H2O2 production by HO2 + HO2 reactions
! ****************************************************************************
       PH2O2=(2.2e-13*exp(619./tk)+xhnm*1.9e-33*exp(980./tk))* xHO2**2 /xhnm
! ****************************************************************************
! *  H2O2 loss by OH and photodissociation
! ****************************************************************************
       LH2O2= ( 2.9e-12*exp(-160./tk)* xOH + xjH2O2 )
       if (LH2O2 .gt. 0.) then
         xH2O2= H2O2_0 * exp(-LH2O2*dt) + PH2O2*(1.-exp(-LH2O2*dt))/LH2O2
       else
         xH2O2= H2O2_0 + PH2O2 * dt
       endif
! ****************************************************************************
! *  (1) DMS + OH:  RK1 - addition channel;  RK2 - abstraction channel.      *
! ****************************************************************************
       rk1 = (1.7e-42 * exp(7810./TK) * O2) /   &
              (1. + 5.5e-31 * exp(7460./TK) * O2 ) * xoh
       rk2 = 1.2e-11*exp(-260./TK) * xoh
! ****************************************************************************
! *  (2) DMS + NO3 (only happen at night):                                   *
! ****************************************************************************
!  < XNO3 fields are in molecules/cm3.        >
        rk3 = 1.9e-13 * exp(500./TK) * xno3
! ****************************************************************************
! *  Update DMS concentration after gas phase chemistry                      *
! ****************************************************************************
       LDMS = RK1 + RK2 + RK3
       if ( LDMS .gt. 0. ) then
         xDMS = DMS_0 * exp( - LDMS*dt)
       endif
! ****************************************************************************
! *  Update MSA concentration after gas phase chemistry                      *
! ****************************************************************************
       PMSA = RK1*0.25 * xDMS
       xMSA = MSA_0 + PMSA * dt
! ****************************************************************************
! *  SO2 oxydation by OH
! ****************************************************************************
       PSO2 = ( RK1*0.75 + RK2 + RK3 ) * xDMS
       rk0 = 3.0E-31 * (300./TK)**3.3
       rk1 = rk0 * xhnm / 1.5e-12
       f1 = ( 1.+ ( log10(rk1) )**2 )**(-1)
       LSO2 = ( rk0 * xhnm / (1.+ rk1) ) * 0.6**f1 * xoh
! ****************************************************************************
! *  Update SO2 concentration after gas phase chemistry                      *
! ****************************************************************************
       xSO2 = SO2_0 + dt * ( PSO2 - LSO2 * SO2_0)
       if (xSO2 .lt. 0.) then
        xSO2 = SO2_0 * exp(-LSO2*dt) + PSO2 * (1.-exp(-LSO2*dt)) / LSO2
       end if
! ****************************************************************************
! *  Update SO4 concentration after gas phase chemistry                      *
! ****************************************************************************
       xso4 = SO4_0 + LSO2*xso2 * dt
! ****************************************************************************
! < Cloud chemistry (above 258K): >
       work1 = (t0 - tk)/(tk*t0)
!-----------------------------------------------------------------------
!         ... h2o2
!-----------------------------------------------------------------------
       xk = 7.4e4   *exp( 6621.* work1 )
       xe = 2.2e-12 *exp(-3730.* work1 )
       heh2o2  = xk*(1. + xe/xph)
       px = heh2o2 * Ra * tk * xlwc
       h2o2g = xh2o2 /(1.+px) 
!-----------------------------------------------------------------------
!         ... so2
!-----------------------------------------------------------------------
       xk = 1.23   * exp(3120. * work1 )
       xe = 1.7e-2 * exp(2090. * work1 ) 
       x2 = 6.0e-8 * exp(1120. * work1 )
       heso2 = xk*(1. + xe/xph *(1. + x2/xph) ) 
!       heso2 = 1.e2 ! xk*(1. + xe/xph *(1. + x2/xph) )
       px = heso2 * Ra * tk * xlwc
       so2g = xso2/(1.+px)
!-----------------------------------------------------------------------
!         ... o3
!-----------------------------------------------------------------------
       xk = 1.15e-2 * exp( 2560. * work1 )
       heo3 = xk
       px = heo3 * Ra * tk *xlwc
       o3g = xo3 / (1.+px) 
!-----------------------------------------------
!       ... Aqueous phase reaction rates
!           SO2 + H2O2 -> SO4
!           SO2 + O3   -> SO4
!-----------------------------------------------

!------------------------------------------------------------------------
!       ... S(IV) (HSO3) + H2O2
!------------------------------------------------------------------------
            rah2o2 = 8.e4 * EXP( -3650.*work1 )  / (.1 + xph)

!------------------------------------------------------------------------
!        ... S(IV)+ O3
!------------------------------------------------------------------------
            rao3   = 4.39e11 * EXP(-4131./tk)  &
                  + 2.56e3  * EXP(-996. /tk) /xph

!-----------------------------------------------------------------
!       ... Prediction after aqueous phase
!       so4
!       When Cloud is present
!
!       S(IV) + H2O2 = S(VI)
!       S(IV) + O3   = S(VI)
!
!       reference:
!           (1) Seinfeld
!           (2) Benkovitz
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!       ... S(IV) + H2O2 = S(VI)
!-----------------------------------------------------------------
       ccc1=0.
       ccc2=0.
       if( xlwc >= 1.e-8 ) then                    ! when cloud is present
               pso4a = rah2o2 * heh2o2*h2o2g  &
                             * heso2 *so2g            ! [M/s]
               pso4a = pso4a       &                    ! [M/s] =  [mole/L(w)/s]
                    * xlwc       &                    ! [mole/L(a)/s]
                    / const0     &                    ! [/L(a)/s]
                    / xhnm                            ! [mixing ratio/s]

          ccc1 = pso4a*dt
          ccc1 = max(min(ccc1,xso2,xh2o2), 0.)
          xso4 = xso4 + ccc1
          xh2o2 = max(xh2o2 - ccc1, small_value)
          xso2 =  max(xso2  - ccc1, small_value)
!          ccc1 = max(ccc1, 0.)
!          if( xh2o2 > xso2 ) then
!              if( ccc1 > xso2 ) then
!                  xso4  = xso4 + xso2
!                  xso2  = small_value
!                  xh2o2 = xh2o2 - xso2
!              else
!                  xso4  = xso4  + ccc1
!                  xh2o2 = xh2o2 - ccc1
!                  xso2  = xso2  - ccc1
!              end if
!          else
!               if( ccc1 > xh2o2 ) then
!                   xso4  = xso4 + xh2o2
!                   xso2  = xso2 - xh2o2
!                   xh2o2 = small_value
!               else
!                   xso4  = xso4  + ccc1
!                   xh2o2 = xh2o2 - ccc1
!                   xso2  = xso2  - ccc1
!               end if
!          end if


!-----------------------------------------------
!       ... S(IV) + O3 = S(VI)
!-----------------------------------------------
           pso4b = rao3 * heo3*o3g * heso2*so2g       ! [M/s]
           pso4b = pso4b        &        ! [M/s] =  [mole/L(w)/s]
                * xlwc        &        ! [mole/L(a)/s]
                / const0      &        ! [/L(a)/s]
                / xhnm                 ! [mixing ratio/s]
 
           ccc2 = pso4b*dt
            ccc2 = max(min(ccc2, xso2), 0.)               ! mozart2
            xso4 = xso4 + ccc2                           ! mozart2
            xso2 = max(xso2 - ccc2, small_value)         ! mozart2
!          ccc2 = max(ccc2, 0.)
!          if( ccc2 > xso2 ) then
!             xso4 = xso4 + xso2
!             xso2 = small_value
!          else
!             xso4 = xso4  + ccc2
!             xso2 = xso2  - ccc2
!             xso2 = max(xso2, small_value)
!          end if
       end if
       MSA_dt(i,j,k) = (xMSA-MSA_0)/dt
       DMS_dt(i,j,k) = (xDMS-DMS_0)/dt
       SO2_dt(i,j,k) = (xso2-SO2_0)/dt
       SO4_dt(i,j,k) = (xso4-SO4_0)/dt
       H2O2_dt(i,j,k)= (xh2o2-H2O2_0)/dt
       SO4_oh_prod(i,j,k)=LSO2*xso2
       SO4_o3_prod(i,j,k)=ccc2/dt
       SO4_h2o2_prod(i,j,k)=ccc1/dt
      end do
      end do
      end do
      if ( id_NO3 > 0) then
        used = send_data ( id_NO3, NO3_diurnal, &
                           model_time,is_in=is,js_in=js,ks_in=1)
      endif
      if ( id_OH > 0) then
        used = send_data ( id_OH, OH_diurnal, &
                           model_time, is_in=is, js_in=js,ks_in=1 )
      endif
      if ( id_HO2 > 0) then
        used = send_data ( id_HO2, HO2_diurnal, &
                           model_time, is_in=is, js_in=js,ks_in=1 )
      endif
      if ( id_jH2O2 > 0) then
        used = send_data ( id_jH2O2, jH2O2_diurnal, &
                           model_time, is_in=is, js_in=js,ks_in=1 )
      endif
      if (id_ph > 0) then
        used = send_data ( id_ph, ph, &
                           model_time,is_in=is,js_in=js,ks_in=1)
      endif
      if (id_o3 > 0) then
        used = send_data ( id_o3, o3_mmr, &
                           model_time,is_in=is,js_in=js,ks_in=1)
      endif

      if (id_SO2_chem > 0) then
        used = send_data ( id_SO2_chem, &
              SO2_dt*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif

      if (id_SO4_chem > 0) then
        used = send_data ( id_SO4_chem, &
              SO4_dt*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif

      if (id_SO4_oh_prod > 0) then
        used = send_data ( id_SO4_oh_prod, &
              SO4_oh_prod*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif
      if (id_SO4_o3_prod > 0) then
        used = send_data ( id_SO4_o3_prod, &
              SO4_o3_prod*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif
      if (id_SO4_h2o2_prod > 0) then
        used = send_data ( id_SO4_h2o2_prod, &
              SO4_h2o2_prod*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif

      if (id_DMS_chem > 0) then
        used = send_data ( id_DMS_chem, &
              DMS_dt*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif

      if (id_MSA_chem > 0) then
        used = send_data ( id_MSA_chem, &
              MSA_dt*pwt*WTM_S/WTMAIR, model_time,is_in=is,js_in=js,ks_in=1)
      endif

      if (id_H2O2_chem > 0) then
        used = send_data ( id_H2O2_chem, &
              H2O2_dt*pwt, model_time,is_in=is,js_in=js,ks_in=1)
      endif
end subroutine atmos_SOx_chem

end module atmos_sulfate_mod



module atmos_sulfur_hex_mod
! <CONTACT EMAIL="Jeffrey.Greenblatt@noaa.gov">
!   Jeff Greenblatt
! </CONTACT>

! <REVIEWER EMAIL="William.Cooke@noaa.gov">
!   William Cooke
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code allows the implementation of sulfur hexafluoride
!     tracer in the FMS framework.
! </OVERVIEW>

! <DESCRIPTION>

! </DESCRIPTION>

! <DATASET NAME="Sulfur hexaflouride emissions">
!
! Monthly.emissions contains the estimated global emission rate of SF6 in
! Gg/yr for 62 months between December 1988 and January 1994, inclusive.
! These are based on the annual estimates of Levin and Hesshaimer
! (submitted), and have been linearly interpolated to monthly values. The
! last half of 1993 has been extrapolated using the trend for the previous 12
! months. 
!
!   The dataset can be obtained from the contact person above.
! </DATASET>  
! <INFO>

!   <REFERENCE>
!Levin, I. and V. Hessahimer: Refining of atmospheric
! transport model entries by the globally observed passive tracer
! distributions of 85Krypton and Sulfur Hexafluoride (SF6). Submitted to the
! Journal of Geophysical Research.
! </REFERENCE>
!</INFO>

use              fms_mod, only : file_exist,           &
!                                 open_file,            &
                                 mpp_pe,               &
                                 mpp_root_pe,          &
                                 stdlog, stdout,       &
                                 close_file,           &
                                 write_version_number
use              mpp_mod, only : get_unit
use     time_manager_mod, only : time_type,            &
                                 set_date,             &
                                 operator( > ),        &
                                 operator( < ),        &
                                 operator( >= )
use     diag_manager_mod, only : send_data,            &
                                 register_diag_field,  &
                                 register_static_field
use   tracer_manager_mod, only : get_tracer_index
use    field_manager_mod, only : MODEL_ATMOS
use atmos_tracer_utilities_mod, only : interp_emiss
use        constants_mod, only : grav, PI

implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_sf6_sourcesink, atmos_sulfur_hex_init, atmos_sulfur_hex_end

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------
!
!  When initializing additional tracers, the user needs to make the
!  following changes.
!
!  Add an integer variable below for each additional tracer. This should
!  be initialized to zero. 
!
!-----------------------------------------------------------------------

! tracer number for radon
integer :: nsf6     =0


!--- identification numbers for  diagnostic fields and axes ----

integer :: id_emiss

!--- Arrays to help calculate tracer sources/sinks ---
real, allocatable, dimension(:,:) :: sf6_grid

integer, parameter :: NUM_SF6_RATE = 62 !number of entries in file 'monthly.emissions'
type sf6_rate_type
  type(time_type) :: Time
  real :: rate
end type sf6_rate_type
type(sf6_rate_type), dimension(NUM_SF6_RATE) :: sf6_rate

character(len=6), parameter :: module_name = 'tracer'

logical :: module_is_initialized=.FALSE.
logical :: used

!---- version number -----
character(len=128) :: version = '$Id: atmos_sulfur_hex.F90,v 17.0.4.1 2010/03/17 20:27:11 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains

!#######################################################################
!<SUBROUTINE NAME="atmos_sf6_sourcesink">
!<OVERVIEW>
! A routine to calculate the sources and sinks of sulfur hexafluoride.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to calculate the sources and sinks of sulfur hexafluoride.
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_sf6_sourcesink (lon, lat, land, pwt, sf6, sf6_dt, 
!        Time, is, ie, js, je, kbot)
!
!</TEMPLATE>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     Longitude of the centre of the model gridcells.
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!     Latitude of the centre of the model gridcells.
!   </IN>
!   <IN NAME="land" TYPE="real" DIM="(:,:)">
!     Land/sea mask.
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     The pressure weighting array. = dP/grav
!   </IN>
!   <IN NAME="sf6" TYPE="real" DIM="(:,:,:)">
!     The array of the sulfur hexafluoride mixing ratio.
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="is, ie, js, je" TYPE="integer">
!     Local domain boundaries.
!   </IN>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>

!   <OUT NAME="sf6_dt" TYPE="real" DIM="(:,:,:)">
!     The array of the tendency of the sulfur hexafluoride mixing ratio.
!   </OUT>
!
subroutine atmos_sf6_sourcesink (lon, lat, land, pwt, sf6, sf6_dt, &
        Time, is, ie, js, je, kbot)
!-----------------------------------------------------------------------
   real, intent(in),  dimension(:,:)   :: lon, lat
   real, intent(in),  dimension(:,:)   :: land
   real, intent(in),  dimension(:,:,:) :: pwt, sf6
   real, intent(out), dimension(:,:,:) :: sf6_dt
     type(time_type), intent(in) :: Time     
integer, intent(in),  dimension(:,:), optional :: kbot
integer, intent(in)                    :: is, ie, js, je
!-----------------------------------------------------------------------
   real, dimension(size(sf6,1),size(sf6,2),size(sf6,3)) ::  &
         source, sink
integer :: i,j,kb,kd, id,jd
real :: rate ! sf6 interpolated emission rate
!-----------------------------------------------------------------------

      id=size(sf6,1); jd=size(sf6,2); kd=size(sf6,3)

source=0.0
! Interpolate SF6 global emission rate from sf6_rate (time dependent). For now
! just use first or last entry if time falls outside the bounds of the table.

      if (Time < sf6_rate(1)%Time) then
        rate=0. !previously sf6_rate(1)%Rate
      else
        if (Time > sf6_rate(size(sf6_rate(:)))%Time) then
          rate=sf6_rate(size(sf6_rate(:)))%Rate !just keep fixed past end of array
        else
          do i=1,size(sf6_rate(:))-1 !This can be optimized with efficient search
            if (Time >= sf6_rate(i)%Time .and. Time < sf6_rate(i+1)%Time) then
              rate=sf6_rate(i)%Rate
              exit
            endif
          enddo
        endif
      endif

      if (present(kbot)) then
          do j=1,jd
          do i=1,id
             kb=kbot(i,j)
             source(i,j,kb)=sf6_grid(i,j+js-1)*rate/pwt(i,j,kb)
          enddo
          enddo
      else
          do j=1,jd
            source(:,j,kd)=sf6_grid(:,j+js-1)*rate/pwt(:,j,kd)
          enddo
      endif
      
      sink=0.0

      sf6_dt=source+sink

end subroutine atmos_sf6_sourcesink
!</SUBROUTINE>

!#######################################################################
!<SUBROUTINE NAME="atmos_sulfur_hex_init">
!<OVERVIEW>
! The constructor routine for the sulfur hexafluoride module.
!</OVERVIEW>
!<DESCRIPTION>
! A routine to initialize the sulfur hexafluoride module.
!</DESCRIPTION>
!<TEMPLATE>
!call atmos_sulfur_hex_init (lonb, latb, r, axes, Time, mask)
!</TEMPLATE>
!   <IN NAME="lonb" TYPE="real" DIM="(:,:)">
!     The longitude corners for the local domain.
!   </IN>
!   <IN NAME="latb" TYPE="real" DIM="(:,:)">
!     The latitude corners for the local domain.
!   </IN>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>

 subroutine atmos_sulfur_hex_init (lonb, latb, r, axes, Time, mask)

!-----------------------------------------------------------------------
!
!   r    = tracer fields dimensioned as (nlon,nlat,nlev,ntrace)
!   mask = optional mask (0. or 1.) that designates which grid points
!          are above (=1.) or below (=0.) the ground dimensioned as
!          (nlon,nlat,nlev).
!
!-----------------------------------------------------------------------
real,            intent(in),    dimension(:,:)             :: lonb, latb
real,            intent(inout), dimension(:,:,:,:)         :: r
real,            intent(in),    dimension(:,:,:), optional :: mask
type(time_type), intent(in)                                :: Time
integer        , intent(in)                                :: axes(4)

integer :: n
!-----------------------------------------------------------------------
!
!  When initializing additional tracers, the user needs to make changes 
!  to two namelists. 
!
!  In what is core_namelist in the run_script (atmos_*_input.nml)
!  ntrace and ntprog need to be changed in &atmosphere_nml so that 
!  the number is the numbers of tracers in this module plus 
!  one (specific humidity I believe)
!
!  In what is phys_namelist in the run_script ( atmos_param_*_input.nml)
!  the namelist &tracer_driver_nml needs to be extended with numbers 
!  corresponding to each tracer. Thes numbers should be positive and 
!  non-zero.
!
!-----------------------------------------------------------------------
      integer  logunit, outunit

      if (module_is_initialized) return

!---- write namelist ------------------

      call write_version_number (version, tagname)

      n = get_tracer_index(MODEL_ATMOS,'sf6')
      if (n>0) then
        nsf6=n
        logunit=stdlog()
        outunit=stdout()
        if (nsf6 > 0 .and. mpp_pe() == mpp_root_pe()) write (outunit,30) 'SF6',nsf6
        if (nsf6 > 0 .and. mpp_pe() == mpp_root_pe()) write (logunit,30) 'SF6',nsf6
      endif

  30        format (A,' was initialized as tracer number ',i2)
      !Read in emission files
      

     id_emiss = register_static_field ( 'tracers',                    &
                     'sf6emiss', axes(1:2),       &
                     'sulfhexemiss', 'g/m2/s')

   allocate (sf6_grid(size(lonb,1)-1,size(latb,2)-1))


      call sf6_init(Time)

      module_is_initialized = .TRUE.
!-----------------------------------------------------------------------
 end subroutine atmos_sulfur_hex_init
!</SUBROUTINE>



!######################################################################

subroutine sf6_init(Time)
type(time_type), intent(in) :: Time
!-------------------------------------------------
!-------------------------------------------------
      integer      :: i,j,unit !,imon,irec,n,io
      real         :: dtr,deg_90, deg_180, gxdeg, gydeg
      real         :: GEIA(720, 360)
      integer, parameter :: k6=selected_int_kind(6) ! find kind sufficient for 6 digit integer precision
      integer(kind=k6) :: t ! temporary time variable of kind k6
      integer      :: y,m,d ! calendar vars
!-------------------------------------------------
      real :: MW_air=28.9644 ! molecular wt. of air (gm/mole)
      real :: MW_sf6=86.0 ! molecular wt. of sf6 (gm/mole) PLEASE CHECK!
      logical :: used

      dtr=PI/180.
      deg_90= -90.*dtr; deg_180= -180.*dtr ! -90 and -180 degrees are the southwest boundaries 
                                           ! of the emission field you are reading in.

! Read in GEIA SF6 emission distribution grid and determine sizes:
!
! GEIA grid arrangement (taken from snf's togasp.f code documentation):
!     i  = 1 is centered at 179.75w
!     i increases eastward
!     j  = 1 is centered at 89.75s
!     j increases northward
!
!       88.5s - | - - - | - - - | - - - | - -
!               | (1,3) | (2,3) | (3,3) |
!       89s   - | - - - | - - - | - - - | - -
!               | (1,2) | (2,2) | (3,2) |
!       89.5s - | - - - | - - - | - - - | - -
!               | (1,1) | (2,1) | (3,1) |
!       90s -   | - - - | - - - | - - - |
!              180w   179.5w  179w    178.5w

      unit = get_unit()
      open(unit,file='distribution.grid', form='formatted',action='read')
      do j = 1, 360 !rearrange input array so begins at 0 E
        read(unit,'(5e16.8)') (GEIA(I,J), I=361,720)
        read(unit,'(5e16.8)') (GEIA(I,J), I=  1,360)
      end do
      close(unit) 

      gxdeg=360./size(GEIA,1)*dtr
      gydeg=180./size(GEIA,2)*dtr

      call interp_emiss (GEIA, deg_180, deg_90, gxdeg, gydeg, sf6_grid)

! Note: must do scaling of global integral to 3.1828e-2 (for kg/m2/s) or 2750.
! (for kg/m2/day), according to S.-M. Fan.

! Scale to same units as used for radon (see radon_sourcesink):

      sf6_grid=sf6_grid * grav * MW_air / MW_sf6

! Now read in emission rate table. Comments from README file supplied by
! Song-Miao Fan:
! "Monthly.emissions contains the estimated global emission rate of SF6 in
! Gg/yr for 62 months between December 1988 and January 1994, inclusive.
! These are based on the annual estimates of Levin and Hesshaimer
! (submitted), and have been linearly interpolated to monthly values. The
! last half of 1993 has been extrapolated using the trend for the previous 12
! months. (Ref: Levin, I. and V. Hessahimer: Refining of atmospheric
! transport model entries by the globally observed passive tracer
! distributions of 85Krypton and Sulfur Hexafluoride (SF6). Submitted to the
! Journal of Geophysical Research)."
!
! Units are Gg/yr. When multiplied by sf6_grid cell, units will be kg/m2/s.
!
! Note time is in integer YYMMDD format, which must be converted to Time_type
! for storage in the sf6_rate array.
!
      unit = get_unit()
      open(unit,file='monthly.emissions', form='formatted',action='read')
      do j = 1, size(sf6_rate(:))
        read(unit,'(i6,2x,f7.5)') t, sf6_rate(j)%rate
! convert YYMMDD into components:
        y=int(t/10000)
        m=int((t-y*10000)/100)
        d=mod(t,100)
! shift start year to 1981 (start date 1981.12.15):
        y=y-88+1981 ! y was 2-digit year
! now convert to time_type format and store:
        sf6_rate(j)%Time=set_date(y, m, d)
      end do
      close(unit) 

         if (id_emiss > 0 ) &
         used = send_data ( id_emiss, sf6_grid, Time )
         
      end subroutine sf6_init

!######################################################################
!<SUBROUTINE NAME="sulfur_hex_end">
!<OVERVIEW>
!  The destructor routine for the sulfur hexafluoride module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine is the exit routine for the sulfur hexafluoride module.
! </DESCRIPTION>
!<TEMPLATE>
! call atmos_sulfur_hex_end
!</TEMPLATE>

 subroutine atmos_sulfur_hex_end
 
      module_is_initialized = .FALSE.

 end subroutine atmos_sulfur_hex_end
!</SUBROUTINE>


end module atmos_sulfur_hex_mod





module atmos_tracer_driver_mod
! <CONTACT EMAIL="William.Cooke@noaa.gov">
!   William Cooke
! </CONTACT>

! <REVIEWER EMAIL="Matthew.Harrison@noaa.gov">
!   Matt Harrison
! </REVIEWER>

! <REVIEWER EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code allows the user to easily add tracers to the FMS framework.
! </OVERVIEW>

! <DESCRIPTION>
!
!     This code allows a user to easily implement tracer code in the FMS
!     framework.  The tracer and tracer tendency arrays are supplied along
!     with longtitude,  latitude, wind, temperature, and pressure
!     information which allows a  user to implement sources and sinks of the
!     tracer which depend on these parameters.
!
!     In the following example, radon being implemented in the atmosphere
!     will be used as an example of how to implement a tracer in the FMS
!     framework.
!
!     Within the global scope of tracer_driver_mod a use
!     statement should be inserted for each tracer to be added.
!<PRE>      use radon_mod, only : radon_sourcesink, radon_init, radon_end </PRE>
!     
!     An integer parameter, which  will be used as an identifier for the
!     tracer, should be assigned.
!<PRE>
!      integer :: nradon 
!</PRE>
!     Within tracer_driver_init a call to the tracer manager is needed in
!     order  to identify which tracer it has set the tracer as.
!<PRE>
!      nradon = get_tracer_index(MODEL_ATMOS,'radon')
!</PRE>
!     Here MODEL_ATMOS is a parameter defined in field_manager. 
!          'radon' is the name of the tracer within the field_table.
!     
!     If the tracer exists then the integer returned will be positive and it
!     can be used to call the initialization routines for the individual
!     tracers.
!<PRE>
!      if (nradon > 0) then
!           call radon_init(Argument list)
!      endif
!</PRE>     
!
!     Within tracer_driver the user can also use the identifier to surround
!     calls to the source-sink routines for the tracer of interest.
!
!<PRE>
!      if (nradon > 0 .and. nradon <= nt) then
!          call radon_sourcesink (Argument list)
!          rdt(:,:,:,nradon)=rdt(:,:,:,nradon)+rtnd(:,:,:)
!      endif
!</PRE>
!
!     It is the users responsibility to add the tendency generated by the
!     sourcesink routine.
!      
!     Within tracer_driver_end the user can add calls to the
!     terminators for the appropriate source sink routines.
!
!<PRE>      call radon_end</PRE>
!
!     This may simply be a deallocation statement or a routine to send
!     output to the logfile stating that the termination routine has been
!     called.
!
! <NOTE>
! This code has been modified by Paul.Ginoux@noaa.gov in 2005
! to include the following aerosols:
!  - SO4 with a simplified SOx chemistry
!  - sea salt with a size distributon splitted into 5 bins
!  - mineral dust with a size distributon splitted into 5 bins
!  - carbonaceous aerosols with new emissions by Shekar.Reddy@noaa.gov
! </NOTE>
!
! </DESCRIPTION>


!-----------------------------------------------------------------------

use fms_mod,               only : file_exist, &
                                  write_version_number, &
                                  error_mesg, &
                                  FATAL, &
                                  mpp_pe, &
                                  mpp_root_pe, &
                                  stdlog, &
                                  mpp_clock_id, &
                                  mpp_clock_begin, &
                                  mpp_clock_end, &
                                  CLOCK_MODULE
use time_manager_mod,      only : time_type, &
                                  get_date, get_date_julian, &
                                  real_to_time_type
use diag_manager_mod,      only : register_diag_field, send_data
use astronomy_mod,         only : astronomy_init, diurnal_solar
use tracer_manager_mod,    only : get_tracer_index,   &
                                  get_number_tracers, &
                                  get_tracer_names,   &
                                  get_tracer_indices
use field_manager_mod,     only : MODEL_ATMOS
use atmos_tracer_utilities_mod, only :                     &
                                  dry_deposition,     &
                                  dry_deposition_time_vary, &
                                  dry_deposition_endts,     &
                                  atmos_tracer_utilities_init, &
                                  get_rh, get_w10m, get_cldf, &
                                  sjl_fillz
use constants_mod,         only : grav, WTMAIR
use atmos_radon_mod,       only : atmos_radon_sourcesink,   &
                                  atmos_radon_init,         &
                                  atmos_radon_end
use atmos_carbon_aerosol_mod, only : &
                                  atmos_carbon_aerosol_time_vary,  &
                                  atmos_carbon_aerosol_endts,      &
                                  atmos_carbon_aerosol_driver,  &
                                  atmos_carbon_aerosol_init,&
                                  atmos_carbon_aerosol_end
use atmos_convection_tracer_mod,only: &
                                  atmos_convection_tracer_init, &
                                  atmos_cnvct_tracer_sourcesink, &
                                  atmos_convection_tracer_end
use atmos_sulfur_hex_mod,  only : atmos_sf6_sourcesink,     &
                                  atmos_sulfur_hex_init,    &
                                  atmos_sulfur_hex_end
use atmos_ch3i_mod,        only : atmos_ch3i, &
                                  atmos_ch3i_init, &
                                  atmos_ch3i_time_vary, &
                                  atmos_ch3i_endts, &
                                  atmos_ch3i_end
use atmos_sea_salt_mod,    only : atmos_sea_salt_sourcesink,     &
                                  atmos_sea_salt_init,    &
                                  atmos_sea_salt_end
use atmos_dust_mod,        only : atmos_dust_sourcesink,     &
                                  atmos_dust_init,    &
                                  atmos_dust_time_vary,    &
                                  atmos_dust_endts,        &
                                  atmos_dust_end
use atmos_sulfate_mod,     only : atmos_sulfate_init, &
                                  atmos_sulfate_time_vary, &
                                  atmos_sulfate_endts,     &
                                  atmos_sulfate_end, &
                                  atmos_DMS_emission, &
                                  atmos_SOx_emission, &
                                  atmos_SOx_chem
use atmos_soa_mod,         only : atmos_SOA_init, &
                                  atmos_SOA_time_vary, &
                                  atmos_SOA_endts, &
                                  atmos_SOA_end, &
                                  atmos_SOA_chem
use tropchem_driver_mod,   only : tropchem_driver, &
                                  tropchem_driver_time_vary, &
                                  tropchem_driver_endts, &
                                  tropchem_driver_init
use strat_chem_driver_mod, only : strat_chem, strat_chem_driver_init
use atmos_age_tracer_mod,  only : atmos_age_tracer_init, atmos_age_tracer, &
                                  atmos_age_tracer_end
use atmos_co2_mod,         only : atmos_co2_sourcesink,   &
                                  atmos_co2_emissions,          &
                                  atmos_co2_gather_data,        &
                                  atmos_co2_flux_init,          &
                                  atmos_co2_init,               &
                                  atmos_co2_end

use interpolator_mod,      only : interpolate_type

implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  atmos_tracer_driver,            &
        atmos_tracer_driver_init,       &
        atmos_tracer_driver_time_vary,       &
        atmos_tracer_driver_endts,       &
        atmos_tracer_driver_end,        &
        atmos_tracer_flux_init,         &
        atmos_tracer_driver_gather_data

!-----------------------------------------------------------------------
!----------- namelist -------------------
!-----------------------------------------------------------------------
!
!  When initializing additional tracers, the user needs to make the
!  following changes.
!
!  Add an integer variable below for each additional tracer. 
!  This should be initialized to zero. 
!
!-----------------------------------------------------------------------

! Indices for timing the various chemistry routines
integer :: radon_clock = 0
integer :: convect_clock = 0
integer :: age_tracer_clock = 0
integer :: stratozone_clock = 0
integer :: tropchem_clock = 0
integer :: carbon_clock = 0
integer :: dust_clock = 0
integer :: seasalt_clock = 0
integer :: sulfur_clock = 0
integer :: SOA_clock = 0
integer :: sf6_clock = 0
integer :: ch3i_clock = 0
integer :: co2_clock = 0

logical :: do_tropchem = .false.  ! Do tropospheric chemistry?
logical :: do_coupled_stratozone = .FALSE. !Do stratospheric chemistry?

integer, dimension(6) :: itime   ! JA's time (simpler than model time) 
integer :: nsphum  ! Specific humidity parameter

integer :: no3 = 0
integer :: no3ch = 0
integer :: nextinct = 0
integer :: naerosol = 0
integer :: nbcphobic =0
integer :: nbcphilic =0
integer :: nomphobic =0
integer :: nomphilic =0
integer :: nclay     =0
integer :: nsilt     =0
integer :: nseasalt1 =0
integer :: nseasalt2 =0
integer :: nseasalt3 =0
integer :: nseasalt4 =0
integer :: nseasalt5 =0
integer :: ndust1    =0
integer :: ndust2    =0
integer :: ndust3    =0
integer :: ndust4    =0
integer :: ndust5    =0
integer :: nsf6      =0
integer :: nDMS      =0
integer :: nSO2      =0
integer :: nSO4      =0
integer :: nMSA      =0
integer :: nSOA      =0
integer :: nH2O2     =0
integer :: nch3i     =0
integer :: nage      =0
integer :: nco2      =0
integer :: nNH4NO3   =0
integer :: nNH4      =0
integer :: nDMS_cmip =0
integer :: nSO2_cmip =0

real    :: ozon(11,48),cosp(14),cosphc(48),photo(132,14,11,48),   &
           solardata(1801),chlb(90,15),ozb(144,90,12),tropc(151,9),  &
           dfdage(90,48,8),anoy(90,48)


integer, dimension(:), pointer :: nradon
integer, dimension(:), pointer :: nconvect

integer :: nt     ! number of activated tracers
integer :: ntp    ! number of activated prognostic tracers

logical :: use_tau=.false.

character(len=6), parameter :: module_name = 'tracer'
character(len=7), parameter :: mod_name = 'tracers'

logical :: module_is_initialized = .FALSE.

type(interpolate_type), allocatable :: drydep_data(:)

integer, allocatable :: local_indices(:) 
! This is the array of indices for the local model. 
! local_indices(1) = 5 implies that the first local tracer is the fifth
! tracer in the tracer_manager.
  
integer :: id_om_ddep, id_bc_ddep, id_ssalt_ddep, id_dust_ddep, &
           id_nh4_ddep_cmip
integer :: id_ssalt_emis, id_dust_emis
integer :: id_nh4no3_col, id_nh4_col
integer :: id_nh4no3_cmip, id_nh4_cmip
integer :: id_nh4no3_cmipv2, id_nh4_cmipv2
integer :: id_so2_cmip, id_dms_cmip
integer :: id_so2_cmipv2, id_dms_cmipv2

!-----------------------------------------------------------------------
type(time_type) :: Time

!---- version number -----
character(len=128) :: version = '$Id: atmos_tracer_driver.F90,v 18.0.4.2.2.2 2010/09/07 14:05:09 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains

!#######################################################################

! <SUBROUTINE NAME="atmos_tracer_driver">
!   <OVERVIEW>
!     A routine which allows tracer code to be called.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine calls the source sink routines for atmospheric
!     tracers. This is the interface between the dynamical core of the 
!     model and the tracer code. It should supply all the necessary 
!     information to a user that they need in order to calculate the 
!     tendency of that tracer with respect to emissions or chemical losses.
!
!   </DESCRIPTION>
!   <TEMPLATE>
!     call atmos_tracer_driver (is, ie, js, je, Time, lon, lat, land, phalf, pfull, r,  &
!                           u, v, t, q, u_star, rdt, rm, rdiag, kbot)
!   </TEMPLATE>
!   <IN NAME="is, ie, js, je" TYPE="integer">
!     Local domain boundaries.
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     Longitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!     Latitude of the centre of the model gridcells
!   </IN>
!   <IN NAME="land" TYPE="logical" DIM="(:,:)">
!     Land/sea mask.
!   </IN>
!   <IN NAME="phalf" TYPE="real" DIM="(:,:,:)">
!     Pressures on the model half levels.
!   </IN>
!   <IN NAME="pfull" TYPE="real" DIM="(:,:,:)">
!     Pressures on the model full levels.
!   </IN>
!   <IN NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     The tracer array in the component model.
!   </IN>
!   <IN NAME="u" TYPE="real" DIM="(:,:,:)">
!     Zonal wind speed.
!   </IN>
!   <IN NAME="v" TYPE="real" DIM="(:,:,:)">
!     Meridonal wind speed.
!   </IN>
!   <IN NAME="t" TYPE="real" DIM="(:,:,:)">
!     Temperature.
!   </IN>
!   <IN NAME="q" TYPE="real" DIM="(:,:,:)">
!     Specific humidity. This may also be accessible as a
!                        portion of the tracer array.
!   </IN>
!   <IN NAME="u_star" TYPE="real" DIM="(:,:)">
!     Friction velocity :: 
!     The magnitude of the wind stress is density*(ustar**2)
!     The drag coefficient for momentum is u_star**2/(u**2+v**2)
!   </IN>
!   <INOUT NAME="rdt" TYPE="real" DIM="(:,:,:,:)">
!     The tendency of the tracer array in the compenent
!     model. The tendency due to sources and sinks computed
!     in the individual tracer routines should be added to
!     this array before exiting tracer_driver.
!   </INOUT>
!   <IN NAME="rm" TYPE="real" DIM="(:,:,:,:)">
!     The tracer array in the component model for the previous timestep.
!   </IN>
!++amf
!   <IN NAME="flux_sw_down_vis_dir" TYPE="real" DIM="(:,:)">
!     Visible direct radiation at the surface in W / m2
!   </IN>
!   <IN NAME="flux_sw_down_vis_dif" TYPE="real" DIM="(:,:)">
!     Visible diffuse radiation at the surface in W / m2
!   </IN>
!--amf
!   <INOUT NAME="rdiag" TYPE="real" DIM="(:,:,:,:)">
!     The array of diagnostic tracers. As these may be changed within the
!     tracer routines for diagnostic purposes, they need to be writable.
!   </INOUT>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>
 subroutine atmos_tracer_driver (is, ie, js, je, Time, lon, lat,  &
                           area, z_pbl, rough_mom, &
                           land, phalf, pfull,     &
                           u, v, t, q, r,          &
                           rm, rdt, dt,     &
                           u_star, b_star, q_star, &
                           z_half, z_full,&
                           t_surf_rad, albedo, &
                           Time_next, &
                           flux_sw_down_vis_dir, &
                           flux_sw_down_vis_dif, &
                           mask, &
                           kbot)

!-----------------------------------------------------------------------
integer, intent(in)                           :: is, ie, js, je
type(time_type), intent(in)                   :: Time
real, intent(in),    dimension(:,:)           :: lon, lat
real, intent(in),    dimension(:,:)           :: u_star, b_star, q_star
real, intent(in),    dimension(:,:)           :: land
real, intent(in),    dimension(:,:)           :: area, z_pbl, rough_mom
real, intent(in),    dimension(:,:,:)         :: phalf, pfull
real, intent(in),    dimension(:,:,:)         :: u, v, t, q
real, intent(inout), dimension(:,:,:,:)       :: r
real, intent(inout), dimension(:,:,:,:)       :: rm
real, intent(inout), dimension(:,:,:,:)       :: rdt
real, intent(in)                              :: dt !timestep(used in chem_interface)
real, intent(in),    dimension(:,:,:)         :: z_half !height in meters at half levels
real, intent(in),    dimension(:,:,:)         :: z_full !height in meters at full levels
real, intent(in),    dimension(:,:)           :: t_surf_rad !surface temperature
real, intent(in),    dimension(:,:)           :: albedo
real, intent(in), dimension(:,:)              :: flux_sw_down_vis_dir
real, intent(in), dimension(:,:)              :: flux_sw_down_vis_dif
type(time_type), intent(in)                   :: Time_next
integer, intent(in), dimension(:,:), optional :: kbot
real, intent(in), dimension(:,:,:),  optional :: mask

!-----------------------------------------------------------------------
! Local variables
!-----------------------------------------------------------------------
real, dimension(size(r,1),size(r,2),size(r,3)) :: rtnd, pwt, ozone, o3_prod, &
                                                  aerosol, rho
real, dimension(size(r,1),size(r,2),size(r,3)) :: rtndso2, rtndso4
real, dimension(size(r,1),size(r,2),size(r,3)) :: rtnddms, rtndmsa, rtndh2o2
real, dimension(size(r,1),size(r,2),size(r,3)) :: rtndbcphob, rtndbcphil
real, dimension(size(r,1),size(r,2),size(r,3)) :: rtndomphob, rtndomphil
real, dimension(size(r,1),size(r,2),size(r,3)) :: rtndco2, rtndco2_emis
real, dimension(size(r,1),size(r,2),size(rdt,4)) :: dsinku
real, dimension(size(r,1),size(r,2)) ::  w10m_ocean, w10m_land
integer :: year,month,day,hour,minute,second
integer :: jday
real, dimension(size(rdt,1),size(rdt,2),size(rdt,3),size(rdt,4)) :: chem_tend
real, dimension(size(r,1),size(r,2))           :: coszen, fracday, half_day
real :: rrsun
real, dimension(size(r,1),size(r,2),size(r,3)) :: cldf ! cloud fraction
real, dimension(size(r,1),size(r,2),size(r,3)) :: rh  ! relative humidity
real, dimension(size(r,1),size(r,2),size(r,3)) :: lwc ! liq water content
real, dimension(size(r,1),size(r,2),size(r,3),size(r,4)) :: tracer
real, dimension(size(r,1),size(r,3)) :: dp, temp
real, dimension(size(r,1),size(r,2),5) ::  ssalt_settl, dust_settl              
real, dimension(size(r,1),size(r,2),5) ::  ssalt_emis, dust_emis                
real, dimension(size(r,1),size(r,2)) ::  all_salt_settl, all_dust_settl         
real, dimension(size(r,1),size(r,2)) ::  suma

integer :: j, k, id, jd, kd, nt
integer :: nqq  ! index of specific humidity
integer :: nql  ! index of cloud liquid specific humidity
integer :: nqi  ! index of cloud ice water specific humidity
integer :: nqa  ! index of cloud amount
integer :: n, nnn
logical :: used


!-----------------------------------------------------------------------

!   <ERROR MSG="tracer_driver_init must be called first." STATUS="FATAL">
!     Tracer_driver_init needs to be called before tracer_driver.
!   </ERROR>
      if (.not. module_is_initialized)  &
      call error_mesg ('Tracer_driver','tracer_driver_init must be called first.', FATAL)

!-----------------------------------------------------------------------
     id=size(r,1);jd=size(r,2);kd=size(r,3); nt=size(r,4)

      nqa = get_tracer_index(MODEL_ATMOS,'cld_amt')
      nqi = get_tracer_index(MODEL_ATMOS,'ice_wat')
      nql = get_tracer_index(MODEL_ATMOS,'liq_wat')
      nqq = get_tracer_index(MODEL_ATMOS,'sphum')

      ssalt_settl = 0.
      ssalt_emis = 0.
      dust_settl = 0.
      dust_emis = 0.
!------------------------------------------------------------------------
! Make local copies of all the tracers
!------------------------------------------------------------------------
!++lwh
      if (use_tau) then
        do n = 1,nt
          tracer(:,:,:,n) = r(:,:,:,n)
!------------------------------------------------------------------------
! For tracers other than specific humdity, cloud amount, ice water and &
! liquid water fill eventual negative values
!------------------------------------------------------------------------
          if (n /= nqq .and. n/=nqa .and. n/=nqi .and. n/=nql) then
            do j=1,jd
              do k=1,kd
                temp(:,k) = tracer(:,j,k,n)
                dp(:,k) = phalf(:,j,k+1)-phalf(:,j,k)
              enddo
              call sjl_fillz(id,kd,1,temp,dp)
              do k=1,kd
                tracer(:,j,k,n) = temp(:,k)
              enddo
            enddo
            if (n <= ntp) then
               rdt(:,:,:,n) = rdt(:,:,:,n) + (tracer(:,:,:,n)-r(:,:,:,n))/dt
            end if
          endif
        end do
      else
        do n = 1,nt
          if (n <= ntp) then
             tracer(:,:,:,n)=rm(:,:,:,n)+rdt(:,:,:,n)*dt
          else
             tracer(:,:,:,n)=r(:,:,:,n)
          end if
          if (n /= nqq .and. n/=nqa .and. n/=nqi .and. n/=nql) then
            do j=1,jd
              do k=1,kd
                temp(:,k) = tracer(:,j,k,n)
                dp(:,k) = phalf(:,j,k+1)-phalf(:,j,k)
              enddo
              call sjl_fillz(id,kd,1,temp,dp)
              do k=1,kd
                tracer(:,j,k,n) = temp(:,k)
              enddo
            enddo
            if (n <= ntp) then
               rdt(:,:,:,n) = (tracer(:,:,:,n) - rm(:,:,:,n)) /dt
            end if
          end if
        end do
      end if
!--lwh

!------------------------------------------------------------------------
! Rediagnose meteoroligical variables. Note these parameterizations
! are not consistent with those used elsewhere in the GCM
!------------------------------------------------------------------------

!-----------------------------------------------------------------------
!-----------Calculate relative humidity
!-----------------------------------------------------------------------
      call get_rh(t,q,pfull,rh,mask)
!-----------------------------------------------------------------------
!--------- Calculate wind speed at 10 meters
!-----------------------------------------------------------------------
      call get_w10m(z_full(:,:,kd) - z_half(:,:,kd+1), &
                    u(:,:,kd), v(:,:,kd), &
                    rough_mom, u_star, b_star, q_star, &
                    w10m_ocean, w10m_land, Time, is, js)
!-----------------------------------------------------------------------
!------Cloud liquid water content
!-----------------------------------------------------------------------
      if (nqi > 0) then
        lwc(:,:,:)=max(tracer(:,:,:,nqi),0.) 
      else
        lwc(:,:,:) = 0.0
      endif
      if (nql > 0) lwc(:,:,:) = lwc(:,:,:) + max(tracer(:,:,:,nql),0.) 
!-----------------------------------------------------------------------
!--------- Cloud fraction -----------------------------
!-----------------------------------------------------------------------
      if (nqa > 0 ) then
!-----  cloud fraction is a prognostic variable ------------
        cldf(:,:,:)= max(0.,min(1.,tracer(:,:,:,nqa) ))
      else
!-----   cloud fraction estimated from RH-------------
        call get_cldf(phalf(:,:,kd+1),pfull,rh,cldf)
      endif
!-----------------------------------------------------------------------
!--------- Get Julian data
!-----------------------------------------------------------------------
      call get_date_julian(Time, year, month, jday, hour, minute, second)
!-----------------------------------------------------------------------
!--------- Get current date
!-----------------------------------------------------------------------
      call get_date(Time, year, month, day, hour, minute, second)

! Calculate cosine of solar zenith angle
!
       call diurnal_solar( lat, lon, Time, coszen, fracday, &
                           rrsun, dt_time=real_to_time_type(dt), &
                           half_day_out=half_day )

!------------------------------------------------------------------------
! Get air mass in layer (in kg/m2), equal to dP/g
!------------------------------------------------------------------------
      do k=1,kd
         pwt(:,:,k)=(phalf(:,:,k+1)-phalf(:,:,k))/grav
         rho(:,:,k) = pwt(:,:,k)/(z_half(:,:,k) - z_half(:,:,k+1))
      enddo

!------------------------------------------------------------------------
! For tracers other than specific humdity, cloud amount, ice water and &
! liquid water calculate flux at surface due to dry deposition
!------------------------------------------------------------------------
!++lwh
      do n=1,ntp
         if (n /= nqq .and. n/=nqa .and. n/=nqi .and. n/=nql) then
            call dry_deposition( n, is, js, u(:,:,kd), v(:,:,kd), t(:,:,kd), &
                                 pwt(:,:,kd), pfull(:,:,kd), &
                                 z_half(:,:,kd)-z_half(:,:,kd+1), u_star, &
                                 (land > 0.5), dsinku(:,:,n), &
                                 tracer(:,:,kd,n), Time, lon, half_day, &
                                 drydep_data(n) )
            rdt(:,:,kd,n) = rdt(:,:,kd,n) - dsinku(:,:,n)
         end if
      enddo

      if (id_om_ddep > 0) then
        used  = send_data (id_om_ddep,  &
         pwt(:,:,kd)*(dsinku(:,:,nomphilic) + dsinku(:,:,nomphobic)),  &
                                              Time, is_in=is, js_in=js)
      endif
      if (id_bc_ddep > 0) then
        used  = send_data (id_bc_ddep,  &
         pwt(:,:,kd)*(dsinku(:,:,nbcphilic) + dsinku(:,:,nbcphobic)),  &
                                               Time, is_in=is, js_in=js)
      endif
      if (id_nh4_ddep_cmip > 0) then
        used  = send_data (id_nh4_ddep_cmip,  &
        0.018*1.0e03*pwt(:,:,kd)*(dsinku(:,:,nNH4NO3) + dsinku(:,:,nNH4))/WTMAIR,  &
                                              Time, is_in=is, js_in=js)
      endif

!----------------------------------------------------------------------
!   output the nh4no3 and nh4 loads.
!----------------------------------------------------------------------
      if(id_nh4_col > 0) then
        suma = 0.
        do k=1,kd
          suma(:,:) = suma(:,:) + pwt(:,:,k)*(tracer(:,:,k,nNH4) + &
                           tracer(:,:,k,nNH4NO3))
        end do
        used  = send_data (id_nh4_col,  &
               0.018*1.0e03*suma(:,:)/WTMAIR,  &
                                              Time, is_in=is, js_in=js)
      endif
      if(id_nh4no3_col > 0) then
        suma = 0.
        do k=1,kd
          suma(:,:) = suma(:,:) + pwt(:,:,k)*tracer(:,:,k,nNH4NO3)
        end do
        used  = send_data (id_nh4no3_col,  &
                  0.062*1.0e03*suma(:,:)/WTMAIR,  &
                                              Time, is_in=is, js_in=js)
      endif

!----------------------------------------------------------------------
!   output the tracer fields needed for CMIP.
!----------------------------------------------------------------------
      if (id_nh4_cmip > 0) then
        used  = send_data (id_nh4_cmip,  &
               0.018*1.0e03* (tracer(:,:,:,nNH4NO3) + &
                              tracer(:,:,:,nNH4)) /WTMAIR,  &
                                          Time, is_in=is, js_in=js, ks_in=1)
      endif
      if (id_nh4_cmipv2 > 0) then
        used  = send_data (id_nh4_cmipv2,  &
               0.018*1.0e03*rho(:,:,:)* (tracer(:,:,:,nNH4NO3) + &
                              tracer(:,:,:,nNH4)) /WTMAIR,  &
                                          Time, is_in=is, js_in=js, ks_in=1)
      endif
      if(id_nh4no3_cmip > 0) then
        used  = send_data (id_nh4no3_cmip,  &
                0.062*1.0e03*tracer(:,:,:,nNH4NO3)/WTMAIR,  &
                                         Time, is_in=is, js_in=js, ks_in=1)
     endif
      if(id_nh4no3_cmipv2 > 0) then
        used  = send_data (id_nh4no3_cmipv2,  &
                0.062*1.0e03*rho(:,:,:)*tracer(:,:,:,nNH4NO3)/WTMAIR,  &
                                         Time, is_in=is, js_in=js, ks_in=1)
     endif
     if(id_so2_cmip > 0) then
       used  = send_data (id_so2_cmip,  &
                 0.064*1.0e03*tracer(:,:,:,nSO2_cmip)/WTMAIR,  &
                                         Time, is_in=is, js_in=js, ks_in=1)
     endif
     if(id_so2_cmipv2 > 0) then
       used  = send_data (id_so2_cmipv2,  &
               0.064*1.0e03*rho(:,:,:)*tracer(:,:,:,nSO2_cmip)/WTMAIR,  &
                                         Time, is_in=is, js_in=js, ks_in=1)
     endif
     if(id_dms_cmip > 0) then
       used  = send_data (id_dms_cmip,  &
                0.062*1.0e03*tracer(:,:,:,nDMS_cmip)/WTMAIR,  &
                                         Time, is_in=is, js_in=js, ks_in=1)
     endif
     if(id_dms_cmipv2 > 0) then
       used  = send_data (id_dms_cmipv2,  &
                0.062*1.0e03*rho(:,:,:)*tracer(:,:,:,nDMS_cmip)/WTMAIR,  &
                                         Time, is_in=is, js_in=js, ks_in=1)
     endif

!------------------------------------------------------------------------
! Compute radon source-sink tendency
!------------------------------------------------------------------------
    call mpp_clock_begin (radon_clock)
    do nnn = 1, size(nradon(:))
     if (nradon(nnn) > 0) then
       if (nradon(nnn) > nt) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for radon', FATAL)
         call atmos_radon_sourcesink (lon,lat,land,pwt,tracer(:,:,:,nradon(nnn)),  &
                                 rtnd, Time, kbot)
       rdt(:,:,:,nradon(nnn))=rdt(:,:,:,nradon(nnn))+rtnd(:,:,:)
    endif
 
   end do
   call mpp_clock_end (radon_clock)

!------------------------------------------------------------------------
! Compute convection tracer source-sink tendency
!------------------------------------------------------------------------
   call mpp_clock_begin (convect_clock)
   do nnn = 1, size(nconvect(:))
     if (nconvect(nnn) > 0) then
       if (nconvect(nnn) > nt) call error_mesg ('Tracer_driver', &
           'Number of tracers .lt. number for convection tracer', FATAL)
       call atmos_cnvct_tracer_sourcesink (lon,lat,land,pwt,  &
                                       tracer(:,:,:,nconvect(nnn)),  &
                                       rtnd, Time, is, ie, js, je,kbot)
       rdt(:,:,:,nconvect(nnn))=rdt(:,:,:,nconvect(nnn))+rtnd(:,:,:)
     endif
   end do
   call mpp_clock_end (convect_clock)

!------------------------------------------------------------------------
! Stratospheric chemistry
!------------------------------------------------------------------------
  if(do_coupled_stratozone) then
    call mpp_clock_begin (stratozone_clock)
    itime(:) = 0
    call get_date(time,itime(1),itime(2),itime(3),itime(4),itime(5),itime(6))

    call strat_chem(lon,lat,r,rdt,pfull,t,itime,is,ie,js,je,dt,coszen,  &
!    ozon,cosp,cosphc,photo,solardata,chlb,ozb,dfdage,tropc,anoy,        &
    nsphum,chem_tend,ozone,o3_prod,aerosol,mpp_pe())
!
! The water vapour tendency is included here, partially coupling the 
! chemistry to the radiation
! 
      rdt(:,:,:,:) = rdt(:,:,:,:) + chem_tend(:,:,:,1:ntp) 
      if(nt.gt.(ntp+1))  then
! Modify the diagnostic tracers.
        tracer(:,:,:,no3)      = ozone(:,:,:) 
        tracer(:,:,:,no3ch)    = o3_prod(:,:,:) 
        if (naerosol > 0 ) tracer(:,:,:,naerosol) = aerosol(:,:,:) 
      endif
    call mpp_clock_end (stratozone_clock)
  endif

!------------------------------------------------------------------------
! Tropospheric chemistry
!------------------------------------------------------------------------
   if ( do_tropchem ) then
!------------------------------------------------------------------------
! Compute age tracer source-sink tendency
!------------------------------------------------------------------------
      if (nage > 0) then
        call mpp_clock_begin (age_tracer_clock)
        if (nage > nt) call error_mesg ('Tracer_driver', &
           'Number of tracers .lt. number for age tracer', FATAL)
        call atmos_age_tracer( lon, lat, pwt,  &
                               tracer(:,:,:,nage),  &
                               rtnd, Time, kbot)
          rdt(:,:,:,nage)=rdt(:,:,:,nage)+rtnd(:,:,:)
        call mpp_clock_end (age_tracer_clock)
      endif

      call mpp_clock_begin (tropchem_clock)
      call tropchem_driver( lon, lat, land, pwt, &
                            tracer(:,:,:,1:ntp),chem_tend, &
                            Time, phalf, pfull, t, is, ie, js, je, dt, &
                            z_half, z_full, q, t_surf_rad, albedo, coszen, rrsun, &
                            area, w10m_ocean, &
                            flux_sw_down_vis_dir, flux_sw_down_vis_dif, & 
                            half_day, &
                            Time_next, tracer(:,:,:,MIN(ntp+1,nt):nt), kbot)
      rdt(:,:,:,:) = rdt(:,:,:,:) + chem_tend(:,:,:,:)
      call mpp_clock_end (tropchem_clock)
   endif

!! RSH 4/8/04
!! note that if there are no diagnostic tracers, that argument in the
!! call to sourcesink should be made optional and omitted in the calls
!! below. note the switch in argument order to make this argument
!! optional.
    if (nt == ntp) then  ! implies no diagnostic tracers
!   if(do_tropchem) then
!      if(present(kbot)) then
!        call sourcesink(lon,lat,land,pwt,r+rdt*dt,chem_tend,Time,phalf,pfull,t,is,js,je,dt,&
!                          z_half, z_full,q,t_surf_rad,albedo,coszen, Time_next,&
!                          u,v,u_star,&
!                          kbot)
!      else
!       call sourcesink(lon,lat,land,pwt,r+rdt*dt,chem_tend,Time,phalf,pfull,t,is,js,je,dt, &
!                          z_half, z_full,q, t_surf_rad, albedo, coszen, Time_next, &
!                          u,v,u_star,&
!                          )
!      endif
!      rdt(:,:,:,:) = rdt(:,:,:,:) + chem_tend(:,:,:,:)
!   endif        
      else   ! case of diagnostic tracers being present
!   if(do_tropchem) then
!      if(present(kbot)) then
!        call sourcesink(lon,lat,land,pwt,r+rdt*dt,chem_tend,Time,phalf,pfull,t,is,js,je,dt,&
!                          z_half, z_full,q,t_surf_rad,albedo,coszen, Time_next,&
!                          u,v,u_star,&
!       rdiag=rm(:,:,:,nt+1:ntp),  &  ! (the diagnostic tracers)
!                   kbot=kbot)
!      else
!       call sourcesink(lon,lat,land,pwt,r+rdt*dt,chem_tend,Time,phalf,pfull,t,is,js,je,dt, &
!                          z_half, z_full,q, t_surf_rad, albedo, coszen, Time_next, &
!                          u,v,u_star,&
!        rdiag=rm(:,:,:,nt+1:ntp),  & ! (the diagnostic tracers)
!                          )
!      endif
!      rdt(:,:,:,:) = rdt(:,:,:,:) + chem_tend(:,:,:,:)
!   endif        
   endif  ! (no diagnostic tracers)

!------------------------------------------------------------------------
!   carbonaceous aerosols
!------------------------------------------------------------------------
   if (nbcphobic > 0 .and. nbcphilic > 0 .and. &
       nomphobic > 0 .and. nomphilic > 0) then
         if (nbcphobic > ntp .or. nbcphilic > ntp) &
            call error_mesg ('Tracer_driver', &
            'Number of tracers .lt. number for black carbon', FATAL)
     call mpp_clock_begin (carbon_clock)
     call atmos_carbon_aerosol_driver(lon,lat,land,pfull,phalf,z_half,z_pbl, &
                                      t_surf_rad, w10m_ocean, &
                                      T, pwt, &
                                      tracer(:,:,:,nbcphobic), rtndbcphob, &
                                      tracer(:,:,:,nbcphilic), rtndbcphil, &
                                      tracer(:,:,:,nomphobic), rtndomphob, &
                                      tracer(:,:,:,nomphilic), rtndomphil, &
                                      Time,is,ie,js,je)
      rdt(:,:,:,nbcphobic)=rdt(:,:,:,nbcphobic)+rtndbcphob(:,:,:)
      rdt(:,:,:,nbcphilic)=rdt(:,:,:,nbcphilic)+rtndbcphil(:,:,:)
      rdt(:,:,:,nomphobic)=rdt(:,:,:,nomphobic)+rtndomphob(:,:,:)
      rdt(:,:,:,nomphilic)=rdt(:,:,:,nomphilic)+rtndomphil(:,:,:)
      call mpp_clock_end (carbon_clock)
   endif
!------------------------------------------------------------------------
! Mineral Dust 
!------------------------------------------------------------------------
   call mpp_clock_begin (dust_clock)
   if (ndust1 > 0) then
         if (ndust1 > ntp ) call error_mesg ('Tracer_driver', &
                   'Number of tracers .lt. number for dust', FATAL)
         call atmos_dust_sourcesink (&
              1, 0.1e-6, 1.0e-6, 0.75e-6, 2500., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_land, t, rh, &
              tracer(:,:,:,ndust1), rtnd, dust_emis(:,:,1), &
              dust_settl(:,:,1), Time, &
              is,ie,js,je, kbot)
      rdt(:,:,:,ndust1)=rdt(:,:,:,ndust1)+rtnd(:,:,:)
   endif

   if (ndust2 > 0) then
         if (ndust2 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for dust', FATAL)
         call atmos_dust_sourcesink (&
              2, 1.e-6, 2.e-6, 1.5e-6, 2650., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_land, t, rh, &
              tracer(:,:,:,ndust2), rtnd, dust_emis(:,:,2), &
              dust_settl(:,:,2), Time, &
              is,ie,js,je, kbot)
      rdt(:,:,:,ndust2)=rdt(:,:,:,ndust2)+rtnd(:,:,:)
   endif

   if (ndust3 > 0) then
         if (ndust3 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for dust', FATAL)
         call atmos_dust_sourcesink (&
              3, 2.e-6, 3.e-6, 2.5e-6, 2650., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_land, t, rh, &
              tracer(:,:,:,ndust3), rtnd, dust_emis(:,:,3), &
              dust_settl(:,:,3), Time, &
              is,ie,js,je, kbot)
      rdt(:,:,:,ndust3)=rdt(:,:,:,ndust3)+rtnd(:,:,:)
   endif

   if (ndust4 > 0) then
         if (ndust4 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for dust', FATAL)
         call atmos_dust_sourcesink (&
              4, 3.e-6, 6.e-6, 4.5e-6, 2650., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_land, t, rh, &
              tracer(:,:,:,ndust4), rtnd, dust_emis(:,:,4), &
              dust_settl(:,:,4), Time, &
              is,ie,js,je, kbot)
      rdt(:,:,:,ndust4)=rdt(:,:,:,ndust4)+rtnd(:,:,:)
   endif

   if (ndust5 > 0) then
         if (ndust5 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for dust', FATAL)
         call atmos_dust_sourcesink (&
              5, 6.e-6, 10.e-6, 8.e-6, 2650., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_land, t, rh, &
              tracer(:,:,:,ndust5), rtnd, dust_emis(:,:,5), &
              dust_settl(:,:,5), Time, &
              is,ie,js,je, kbot)
      rdt(:,:,:,ndust5)=rdt(:,:,:,ndust5)+rtnd(:,:,:)
   endif
   if (id_dust_ddep > 0) then
     all_dust_settl(:,:) = dust_settl(:,:,1) +  &
                dust_settl(:,:,2) +  dust_settl(:,:,3) +  &
                dust_settl(:,:,4) +  dust_settl(:,:,5)
     used  = send_data (id_dust_ddep,  all_dust_settl(:,:) + &
        pwt(:,:,kd)*(dsinku(:,:,ndust1) + dsinku(:,:,ndust2) + &
                     dsinku(:,:,ndust3) + dsinku(:,:,ndust4) + &
                      dsinku(:,:,ndust5)), Time, is_in=is, js_in=js)
   endif
   if (id_dust_emis > 0) then
     used  = send_data (id_dust_emis,  &
                 dust_emis(:,:,1) + dust_emis(:,:,2) + &
                 dust_emis(:,:,3) + dust_emis(:,:,4) + &
                 dust_emis(:,:,5), Time, is_in=is, js_in=js)
   endif
   call mpp_clock_end (dust_clock)

!------------------------------------------------------------------------
!sea salt
!------------------------------------------------------------------------
   call mpp_clock_begin (seasalt_clock)
   if (nseasalt1 > 0) then
         if (nseasalt1 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for sea salt', FATAL)
         rtnd(:,:,:) = 0.
         call atmos_sea_salt_sourcesink ( &
              1, 0.1e-6,0.5e-6,0.3e-6, 2200., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_ocean, t, rh, &
              tracer(:,:,:,nseasalt1), rtnd, dt, &
               ssalt_settl(:,:,1), ssalt_emis(:,:,1), &
              Time,is,ie,js,je, kbot)
      rdt(:,:,:,nseasalt1)=rdt(:,:,:,nseasalt1)+rtnd(:,:,:)
   endif
   if (nseasalt2 > 0) then
         if (nseasalt2 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for sea salt', FATAL)
         rtnd(:,:,:) = 0.
         call atmos_sea_salt_sourcesink ( &
              2, 0.5e-6,1.0e-6,0.75e-6, 2200., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_ocean, t, rh, &
              tracer(:,:,:,nseasalt2), rtnd, dt, &
               ssalt_settl(:,:,2), ssalt_emis(:,:,2), &
              Time,is,ie,js,je, kbot)
      rdt(:,:,:,nseasalt2)=rdt(:,:,:,nseasalt2)+rtnd(:,:,:)
   endif
   if (nseasalt3 > 0) then
         if (nseasalt3 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for sea salt', FATAL)
         rtnd(:,:,:) = 0.
         call atmos_sea_salt_sourcesink ( &
              3, 1.e-6,2.5e-6,1.75e-6, 2200., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_ocean, t, rh, &
              tracer(:,:,:,nseasalt3), rtnd, dt, &
               ssalt_settl(:,:,3), ssalt_emis(:,:,3), &
              Time,is,ie,js,je, kbot)
      rdt(:,:,:,nseasalt3)=rdt(:,:,:,nseasalt3)+rtnd(:,:,:)
   endif
   if (nseasalt4 > 0) then
         if (nseasalt4 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for sea salt', FATAL)
         rtnd(:,:,:) = 0.
         call atmos_sea_salt_sourcesink ( &
              4, 2.5e-6,5.0e-6,3.75e-6, 2200., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_ocean, t, rh, &
              tracer(:,:,:,nseasalt4), rtnd, dt, &
               ssalt_settl(:,:,4), ssalt_emis(:,:,4), &
              Time,is,ie,js,je, kbot)
      rdt(:,:,:,nseasalt4)=rdt(:,:,:,nseasalt4)+rtnd(:,:,:)
   endif
   if (nseasalt5 > 0) then
         if (nseasalt5 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for sea salt', FATAL)
         rtnd(:,:,:) = 0.
         call atmos_sea_salt_sourcesink ( &
              5, 5.e-6,10.0e-6,7.5e-6, 2200., &
              lon,lat,land,pwt, &
              z_half, pfull, w10m_ocean, t, rh, &
              tracer(:,:,:,nseasalt5), rtnd, dt, &
               ssalt_settl(:,:,5), ssalt_emis(:,:,5), &
              Time,is,ie,js,je, kbot)
      rdt(:,:,:,nseasalt5)=rdt(:,:,:,nseasalt5)+rtnd(:,:,:)
   endif
   if (id_ssalt_ddep > 0) then
     all_salt_settl(:,:) = ssalt_settl(:,:,1) + ssalt_settl(:,:,2) +  &
                         ssalt_settl(:,:,3) + ssalt_settl(:,:,4) + &
                         ssalt_settl(:,:,5)
     used  = send_data (id_ssalt_ddep, all_salt_settl(:,:) + &
         pwt(:,:,kd)*(dsinku(:,:,nseasalt1) + dsinku(:,:,nseasalt2) + &
                      dsinku(:,:,nseasalt3) + dsinku(:,:,nseasalt4) + &
                      dsinku(:,:,nseasalt5)), Time, is_in=is, js_in=js)
   endif
   if (id_ssalt_emis > 0) then
     used  = send_data (id_ssalt_emis,  &
                    ssalt_emis(:,:,1) + ssalt_emis(:,:,2) + &
                    ssalt_emis(:,:,3) + ssalt_emis(:,:,4) + &
                    ssalt_emis(:,:,5), Time, is_in=is, js_in=js)
   endif
   call mpp_clock_end (seasalt_clock)

!------------------------------------------------------------------------
! Sulfur chemistry
!------------------------------------------------------------------------
   if (nDMS > 0 .and. nSO2 > 0 .and. nSO4 > 0 .and. nMSA > 0 ) then
      if (nDMS > ntp ) call error_mesg ('Tracer_driver', &
                     'Number of tracers .lt. number for DMS', FATAL)
      if (nSO2 > ntp ) call error_mesg ('Tracer_driver', &
                     'Number of tracers .lt. number for SO2', FATAL)
      if (nSO4 > ntp ) call error_mesg ('Tracer_driver', &
                     'Number of tracers .lt. number for SO4', FATAL)

      call mpp_clock_begin (sulfur_clock)
      call atmos_DMS_emission(lon, lat, area, land, t_surf_rad, &
             w10m_ocean, pwt, rtnddms, Time, is,ie,js,je,kbot)
      rdt(:,:,kd,nDMS) = rdt(:,:,kd,nDMS) + rtnddms(:,:,kd)
      call atmos_SOx_emission(lon, lat, area, land, &
             z_pbl, z_half, phalf, pwt, rtndso2, rtndso4, &
             Time, is,ie,js,je,kbot)
      rdt(:,:,:,nSO2) = rdt(:,:,:,nSO2) + rtndso2(:,:,:)
      rdt(:,:,:,nSO4) = rdt(:,:,:,nSO4) + rtndso4(:,:,:)
      call atmos_SOx_chem( pwt, t, pfull, phalf, dt, lwc, &
                jday,hour,minute,second,lat,lon,    &
                tracer(:,:,:,nSO2), tracer(:,:,:,nSO4), tracer(:,:,:,nDMS), &
                tracer(:,:,:,nMSA), tracer(:,:,:,nH2O2), &
                rtndso2, rtndso4, rtnddms, rtndmsa, rtndh2o2, &
                Time,is,ie,js,je,kbot)
      rdt(:,:,:,nSO2) = rdt(:,:,:,nSO2) + rtndso2(:,:,:)
      rdt(:,:,:,nSO4) = rdt(:,:,:,nSO4) + rtndso4(:,:,:)
      rdt(:,:,:,nDMS) = rdt(:,:,:,nDMS) + rtnddms(:,:,:)
      rdt(:,:,:,nMSA) = rdt(:,:,:,nMSA) + rtndmsa(:,:,:)
      rdt(:,:,:,nH2O2) = rdt(:,:,:,nH2O2) + rtndh2o2(:,:,:)
      call mpp_clock_end (sulfur_clock)
   endif

!------------------------------------------------------------------------
! Secondary organic aerosols
!------------------------------------------------------------------------
   if (nSOA > 0 ) then
      if (nSOA > ntp ) call error_mesg ('Tracer_driver', &
                     'Number of tracers .lt. number for SOA', FATAL)

      call mpp_clock_begin (SOA_clock)
      call atmos_SOA_chem(pwt,t,pfull,phalf,dt, &
                jday,hour,minute,second,lat,lon,    &
                tracer(:,:,:,nSOA),rtnd, Time,is,ie,js,je,kbot )

      rdt(:,:,:,nSOA)=rdt(:,:,:,nSOA)+rtnd(:,:,:)
      call mpp_clock_end (SOA_clock)

   endif

!------------------------------------------------------------------------
! Sulfur hexafluoride (SF6)
!------------------------------------------------------------------------
   if (nsf6 > 0) then
         if (nsf6 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers .lt. number for sulfur hexafluoride', FATAL)
         call mpp_clock_begin (sf6_clock)
         call atmos_sf6_sourcesink (lon,lat,land,pwt,r(:,:,:,nsf6),  &
                                 rtnd, Time,is,ie,js,je, kbot)
      rdt(:,:,:,nsf6)=rdt(:,:,:,nsf6)+rtnd(:,:,:)
         call mpp_clock_end (sf6_clock)
   endif

   if (nch3i > 0) then
         if (nch3i > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers < number for ch3i', FATAL)
         call mpp_clock_begin (ch3i_clock)
         call atmos_ch3i( lon, lat, land, pwt, &
                          r(:,:,:,nch3i)+dt*rdt(:,:,:,nch3i), rtnd,  &
                          Time, phalf, pfull, t, is, js, dt, &
                          z_half, z_full,q, t_surf_rad, albedo, coszen, &
                          Time_next, kbot)
         rdt(:,:,:,nch3i) = rdt(:,:,:,nch3i) + rtnd(:,:,:)
         call mpp_clock_end (ch3i_clock)
   endif

!------------------------------------------------------------------------
! Compute CO2 source-sink tendency:  tracer(:,:,:,nco2) is in moist mmr
!  atmos_co2_sourcesink will convert to dry vmr and return rtnd as moist mmr
!------------------------------------------------------------------------
   if (nco2 > 0 ) then
         if (nco2 > ntp ) call error_mesg ('Tracer_driver', &
                            'Number of tracers < number for co2', FATAL)
         call mpp_clock_begin (co2_clock)
         call atmos_co2_emissions (is, ie, js, je, Time, dt, pwt, tracer(:,:,:,nco2),     &
                                   tracer(:,:,:,nsphum), rtndco2_emis, kbot)
         rdt(:,:,:,nco2)=rdt(:,:,:,nco2)+rtndco2_emis(:,:,:)

         call atmos_co2_sourcesink (Time, dt, pwt, tracer(:,:,:,nco2),     &
                                    tracer(:,:,:,nsphum), rtndco2)
         rdt(:,:,:,nco2)=rdt(:,:,:,nco2)+rtndco2(:,:,:)
         call mpp_clock_end (co2_clock)
   endif

!------------------------------------------------------------------------
! Save diagnostic tracer concentrations back to tracer array
!------------------------------------------------------------------------
   if (nt > ntp) then
      r(:,:,:,ntp+1:nt) = tracer(:,:,:,ntp+1:nt)
   end if

 end subroutine atmos_tracer_driver
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="atmos_tracer_driver_init">
!   <OVERVIEW>
!     Subroutine to initialize the tracer driver module.
!   </OVERVIEW>
!   <DESCRIPTION>
!   The purpose of the arguments here are for passing on to the individual
!   tracer code. The user may wish to provide initial values which can be
!   implemented in the initialization part of the tracer code. Remember that
!   the tracer manager will provide a simple fixed or exponential profile if
!   the user provides data for this within the field table. However if a more
!   complicated profile is required then it should be set up in the
!   initialization section of the user tracer code.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call atmos_tracer_driver_init (lonb,latb, r, mask, axes, Time)
!   </TEMPLATE>
!   <IN NAME="lonb" TYPE="real" DIM="(:,:)">
!     The longitude corners for the local domain.
!   </IN>
!   <IN NAME="latb" TYPE="real" DIM="(:,:)">
!     The latitude corners for the local domain.
!   </IN>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask (0. or 1.) that designates which grid points
!           are above (=1.) or below (=0.) the ground dimensioned as
!           (nlon,nlat,nlev).
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array dimensioned as
!      (nlon, nlat, nlev, ntime)
!   </IN>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer fields dimensioned as (nlon,nlat,nlev,ntrace). 
!   </INOUT>
 subroutine atmos_tracer_driver_init (lonb, latb, r, axes, Time, phalf, mask)

!-----------------------------------------------------------------------
           real, intent(in),    dimension(:,:)             :: lonb, latb
           real, intent(inout), dimension(:,:,:,:)         :: r
type(time_type), intent(in)                                :: Time
        integer, intent(in)                                :: axes(4)
           real, intent(in),    dimension(:,:,:)           :: phalf
           real, intent(in),    dimension(:,:,:), optional :: mask

!-----------------------------------------------------------------------
! Local variables
!-----------------------------------------------------------------------
      integer :: nbr_layers
   
!-----------------------------------------------------------------------
!
!  When initializing additional tracers, the user needs to make changes 
!
!-----------------------------------------------------------------------

      if (module_is_initialized) return

      call write_version_number (version, tagname)

!---------------------------------------------------------------------
!  make sure that astronomy_mod has been initialized (if radiation
!  not being called in this run, it will not have previously been 
!  initialized).
!---------------------------------------------------------------------
      call astronomy_init

!If we wish to automatically register diagnostics for wet and dry 
! deposition, do it now.
      call atmos_tracer_utilities_init(lonb, latb, axes, Time)

!----- set initial value of radon ------------

      call atmos_radon_init(r, axes, Time, nradon, mask)
      radon_clock = mpp_clock_id( 'Tracer: Radon', &
           grain=CLOCK_MODULE )

!----- initialize the convection tracer ------------

      call atmos_convection_tracer_init(r, phalf, axes, Time, &
                                        nconvect,  mask)
      convect_clock = mpp_clock_id( 'Tracer: Convection tracer', &
           grain=CLOCK_MODULE )

!----- initialize the age tracer ------------

      call atmos_age_tracer_init( r, axes, Time, nage, lonb, latb, phalf, mask)
      age_tracer_clock = mpp_clock_id( 'Tracer: Age tracer', grain=CLOCK_MODULE )

      call get_number_tracers (MODEL_ATMOS, num_tracers=nt, &
                               num_prog=ntp)


!------------------------------------------------------------------------
! Initialize stratospheric chemistry
!------------------------------------------------------------------------
      nsphum   = get_tracer_index(MODEL_ATMOS,'sphum')
      no3      = get_tracer_index(MODEL_ATMOS,'O3')
      no3ch    = get_tracer_index(MODEL_ATMOS,'O3_chem')
      nextinct = get_tracer_index(MODEL_ATMOS,'Extinction')
      naerosol = get_tracer_index(MODEL_ATMOS,'Aerosol')
!
!  Set up photolysis rates etc.
!
      do_coupled_stratozone = strat_chem_driver_init()
      stratozone_clock = mpp_clock_id( 'Tracer: Stratospheric Ozone', &
           grain=CLOCK_MODULE )
         

!------------------------------------------------------------------------
! Initialize tropospheric chemistry
!------------------------------------------------------------------------
      allocate( drydep_data(nt) )
      do_tropchem = tropchem_driver_init(r,mask,axes,Time,lonb,latb,phalf,drydep_data)
      tropchem_clock = mpp_clock_id( 'Tracer: Tropospheric chemistry', &
           grain=CLOCK_MODULE )

! ----------Interactive traceres--------------------
! If any of the interactive tracers are activated, get the 
! tracer number and initialize it.
!      ntraceer= get_tracer_index(MODEL_ATMOS,'tracer_name')
!      if (ntracer > 0) then
!        call {tracer}_init(lonb, latb, r, axes, Time, mask)
!      endif


!    get tracer indices
      nbcphobic = get_tracer_index(MODEL_ATMOS,'bcphob')
      nbcphilic = get_tracer_index(MODEL_ATMOS,'bcphil')
      nomphobic = get_tracer_index(MODEL_ATMOS,'omphob')
      nomphilic = get_tracer_index(MODEL_ATMOS,'omphil')
      ndust1    = get_tracer_index(MODEL_ATMOS,'dust1')
      ndust2    = get_tracer_index(MODEL_ATMOS,'dust2')
      ndust3    = get_tracer_index(MODEL_ATMOS,'dust3')
      ndust4    = get_tracer_index(MODEL_ATMOS,'dust4')
      ndust5    = get_tracer_index(MODEL_ATMOS,'dust5')
      nseasalt1 = get_tracer_index(MODEL_ATMOS,'ssalt1')
      nseasalt2 = get_tracer_index(MODEL_ATMOS,'ssalt2')
      nseasalt3 = get_tracer_index(MODEL_ATMOS,'ssalt3')
      nseasalt4 = get_tracer_index(MODEL_ATMOS,'ssalt4')
      nseasalt5 = get_tracer_index(MODEL_ATMOS,'ssalt5')
      nDMS      = get_tracer_index(MODEL_ATMOS,'simpleDMS')
      nSO2      = get_tracer_index(MODEL_ATMOS,'simpleSO2')
      nSO4      = get_tracer_index(MODEL_ATMOS,'simpleSO4')
      nMSA      = get_tracer_index(MODEL_ATMOS,'simpleMSA')
      nH2O2     = get_tracer_index(MODEL_ATMOS,'simpleH2O2')
      nnH4NO3   = get_tracer_index(MODEL_ATMOS,'nh4no3')
      nnH4      = get_tracer_index(MODEL_ATMOS,'nh4')
      nSOA      = get_tracer_index(MODEL_ATMOS,'SOA')
      nsf6      = get_tracer_index(MODEL_ATMOS,'sf6')
      nch3i     = get_tracer_index(MODEL_ATMOS,'ch3i')
      nco2      = get_tracer_index(MODEL_ATMOS,'co2')
      nDMS_cmip = get_tracer_index(MODEL_ATMOS,'DMS')
      nSO2_cmip = get_tracer_index(MODEL_ATMOS,'so2')

! Number of vertical layers
      nbr_layers=size(r,3)

! initialize the tracers
!carbonaceous aerosols
      if (nbcphobic > 0 .or. nbcphilic >0 .or.  &
          nomphobic > 0 .or. nomphilic >0 ) then
        call atmos_carbon_aerosol_init(lonb, latb, axes, Time, mask)
        carbon_clock = mpp_clock_id( 'Tracer: Carbonaceous aerosol', &
                       grain=CLOCK_MODULE )

      endif
!dust aerosols
      if (ndust1 > 0.or.ndust2 > 0.or.ndust3 > 0 &
        .or.ndust4 > 0.or.ndust5 > 0 ) then
        call atmos_dust_init (lonb, latb, axes, Time, mask)
        dust_clock = mpp_clock_id( 'Tracer: Dust aerosol', &
                     grain=CLOCK_MODULE )
      endif
!sea salt
      if (nseasalt1 > 0.or.nseasalt2 > 0.or.nseasalt3 > 0 &
        .or.nseasalt4 > 0.or.nseasalt5 > 0 ) then
        call atmos_sea_salt_init (lonb, latb, axes, Time, mask)
        seasalt_clock = mpp_clock_id( 'Tracer: Seasalt aerosol', &
                        grain=CLOCK_MODULE )
      endif
!sulfur cycle
      if (nDMS > 0 .or. nSO2 > 0 .or. nSO4 > 0 &
                   .or. nMSA > 0 .or. nH2O2 > 0 ) then
        call atmos_sulfate_init ( lonb, latb, nbr_layers, axes, Time, mask)
        sulfur_clock = mpp_clock_id( 'Tracer: Sulfur', &
                       grain=CLOCK_MODULE )
      endif
!SOA
      if ( nSOA > 0 ) then
        call atmos_SOA_init ( lonb, latb, nbr_layers, axes, Time, mask)
        SOA_clock = mpp_clock_id( 'Tracer: SOA', &
                    grain=CLOCK_MODULE )
      endif
!sf6
      if (nsf6 > 0) then
        call atmos_sulfur_hex_init (lonb, latb, r, axes, Time, mask)
        sf6_clock = mpp_clock_id( 'Tracer: SF6', &
                    grain=CLOCK_MODULE )
      endif
!ch3i
      if (nch3i > 0) then
        call atmos_ch3i_init (lonb, latb, axes, Time, mask)
        ch3i_clock = mpp_clock_id( 'Tracer: CH3I', &
                     grain=CLOCK_MODULE )
      endif

!co2
      if (nco2 > 0) then
      call atmos_co2_init ( Time, axes(1:3))
        co2_clock = mpp_clock_id( 'Tracer: CO2', &
                    grain=CLOCK_MODULE )
      endif

      call get_number_tracers (MODEL_ATMOS, num_tracers=nt, &
                               num_prog=ntp)

      id_om_ddep = register_diag_field (mod_name, &
          'om_ddep', axes(1:2), Time, &
          'total dry deposition of om', 'kg/m2/s')

      id_bc_ddep = register_diag_field (mod_name, &
          'bc_ddep', axes(1:2), Time, &
          'total dry deposition of bc', 'kg/m2/s')

      id_ssalt_ddep = register_diag_field (mod_name, &
          'ssalt_ddep', axes(1:2), Time, &
          'dry deposition and settling of seasalt', 'kg/m2/s')

      id_ssalt_emis = register_diag_field (mod_name, &
          'ssalt_emis', axes(1:2), Time, &
          'total emission of seasalt', 'kg/m2/s')

      id_dust_ddep = register_diag_field (mod_name, &
          'dust_ddep', axes(1:2), Time, &
          'dry deposition and settling of dust', 'kg/m2/s')

      id_dust_emis = register_diag_field (mod_name, &
          'dust_emis', axes(1:2), Time, &
          'total emission of dust', 'kg/m2/s')

      id_nh4_ddep_cmip = register_diag_field (mod_name, &
          'tot_nh4_ddep_cmip', axes(1:2), Time, &
          'total dry deposition of ammonium', 'kg/m2/s')

      id_nh4no3_col = register_diag_field (mod_name, &
          'tot_no3_col', axes(1:2), Time, &
          'total aerosol load of nitrate', 'kg/m2')

      id_nh4_col  = register_diag_field (mod_name, &
          'tot_nh4_col', axes(1:2), Time, &
          'total aerosol load of ammonium', 'kg/m2')

      id_nh4no3_cmip = register_diag_field (mod_name, &
          'tot_no3', axes(1:3), Time, &
          'total nitrate', 'kg/m3')

      id_nh4_cmip  = register_diag_field (mod_name, &
          'tot_nh4', axes(1:3), Time, &
          'total ammonium', 'kg/m3')

      id_nh4no3_cmipv2 = register_diag_field (mod_name, &
          'tot_no3v2', axes(1:3), Time, &
          'total nitrate', 'kg/m3')

      id_nh4_cmipv2  = register_diag_field (mod_name, &
          'tot_nh4v2', axes(1:3), Time, &
          'total ammonium', 'kg/m3')

      id_so2_cmip  = register_diag_field (mod_name, &
          'so2_cmip', axes(1:3), Time, &
          'SO2', 'kg/m3')

      id_dms_cmip  = register_diag_field (mod_name, &
          'dms_cmip', axes(1:3), Time, &
          'DMS', 'kg/m3')

      id_so2_cmipv2  = register_diag_field (mod_name, &
          'so2_cmipv2', axes(1:3), Time, &
          'SO2', 'kg/m3')

      id_dms_cmipv2  = register_diag_field (mod_name, &
          'dms_cmipv2', axes(1:3), Time, &
          'DMS', 'kg/m3')

      module_is_initialized = .TRUE.

 end subroutine atmos_tracer_driver_init



!#####################################################################

subroutine atmos_tracer_driver_time_vary (Time)

type(time_type), intent(in) :: Time

      if (nbcphobic > 0 .and. nbcphilic > 0 .and. &
          nomphobic > 0 .and. nomphilic > 0) then
        call atmos_carbon_aerosol_time_vary (Time)
      endif

      if (nch3i > 0) then
        call atmos_ch3i_time_vary (Time)
      endif

      if (ndust1 > 0.or.ndust2 > 0.or.ndust3 > 0 &
          .or.ndust4 > 0.or.ndust5 > 0 ) then
        call atmos_dust_time_vary (Time)
      endif

      if (nSOA > 0 ) then
        call atmos_SOA_time_vary (Time)
      endif

      if (nDMS > 0 .or. nSO2 > 0 .or. nSO4 > 0 &
                   .or. nMSA > 0 .or. nH2O2 > 0 ) then
        call atmos_sulfate_time_vary (Time)
      endif

      call dry_deposition_time_vary (drydep_data, Time)

      if (do_tropchem) then
        call tropchem_driver_time_vary (Time)
      endif



end subroutine atmos_tracer_driver_time_vary




!#####################################################################

subroutine atmos_tracer_driver_endts

      if (do_tropchem) then
        call tropchem_driver_endts
      endif
      if (nbcphobic > 0 .and. nbcphilic > 0 .and. &
          nomphobic > 0 .and. nomphilic > 0) then
        call atmos_carbon_aerosol_endts
      endif
      if (nch3i > 0) then
        call atmos_ch3i_endts
      endif
      if (ndust1 > 0.or.ndust2 > 0.or.ndust3 > 0 &
          .or.ndust4 > 0.or.ndust5 > 0 ) then
        call atmos_dust_endts
      endif
      if (nSOA > 0 ) then
        call atmos_soa_endts
      endif
      if (nDMS > 0 .or. nSO2 > 0 .or. nSO4 > 0 &
                   .or. nMSA > 0 .or. nH2O2 > 0 ) then
        call atmos_sulfate_endts
      endif
      call dry_deposition_endts (drydep_data)

end subroutine atmos_tracer_driver_endts




!#####################################################################


! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="atmos_tracer_driver_end">
!   <OVERVIEW>
!     Subroutine to terminate the tracer driver module.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Termination routine for tracer_driver. It should also call
!     the destructors for the individual tracer routines.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call atmos_tracer_driver_end
!   </TEMPLATE>
 subroutine atmos_tracer_driver_end

!-----------------------------------------------------------------------
integer :: logunit
      if (mpp_pe() /= mpp_root_pe()) return

      logunit=stdlog()
      write (logunit,'(/,(a))') 'Exiting tracer_driver, have a nice day ...'

      call atmos_radon_end
      call atmos_sulfur_hex_end
      call atmos_convection_tracer_end
      call atmos_dust_end     
      call atmos_sea_salt_end 
      call atmos_sulfate_end
      call atmos_SOA_end      
      call atmos_carbon_aerosol_end
      if (nch3i > 0) then
        call atmos_ch3i_end
      endif
      call atmos_age_tracer_end      
      call atmos_co2_end

      module_is_initialized = .FALSE.

!-----------------------------------------------------------------------

 end subroutine atmos_tracer_driver_end
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="atmos_tracer_flux_init">
!   <OVERVIEW>
!     Subroutine to initialize the ocean-atmosphere gas flux modules
!   </OVERVIEW>
!   <DESCRIPTION>
!     Subroutine to initialize the ocean-atmosphere gas flux modules
!   </DESCRIPTION>

subroutine atmos_tracer_flux_init

call atmos_co2_flux_init

return

end subroutine atmos_tracer_flux_init
! </SUBROUTINE>

!######################################################################
! <SUBROUTINE NAME="atmos_tracer_driver_gather_data">
!   <OVERVIEW>
!     Subroutine to terminate the tracer driver module.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Termination routine for tracer_driver. It should also call
!     the destructors for the individual tracer routines.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call atmos_tracer_driver_gather_data
!   </TEMPLATE>
 subroutine atmos_tracer_driver_gather_data(gas_fields, tr_bot)

use coupler_types_mod, only: coupler_2d_bc_type

type(coupler_2d_bc_type), intent(inout) :: gas_fields
real, dimension(:,:,:), intent(in)      :: tr_bot

!-----------------------------------------------------------------------

  call atmos_co2_gather_data(gas_fields, tr_bot)

!-----------------------------------------------------------------------

 end subroutine atmos_tracer_driver_gather_data
! </SUBROUTINE>

!######################################################################


end module atmos_tracer_driver_mod




module atmos_tracer_utilities_mod
! <CONTACT EMAIL="William.Cooke@noaa.gov">
!   William Cooke
! </CONTACT>

! <REVIEWER EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code provides some utility routines for atmospheric tracers in the FMS framework.
! </OVERVIEW>
! <DESCRIPTION>
!    This module gives utility routines which can be used to provide 
!    consistent removal mechanisms for atmospheric tracers. 
!
!    In particular it provides schemes for wet and dry deposiiton that 
!    can be easily utilized.
!
! </DESCRIPTION>


use            fms_mod, only : lowercase, &
                               write_version_number, &
                               stdlog, &
                               mpp_pe, &
                               mpp_root_pe, &
                               error_mesg, &
                               NOTE, FATAL
use   time_manager_mod, only : time_type
use   diag_manager_mod, only : send_data, &
                               register_diag_field
use tracer_manager_mod, only : query_method, &
                               get_tracer_names, &
                               get_number_tracers, &
                               MAX_TRACER_FIELDS
use  field_manager_mod, only : MODEL_ATMOS, parse
use   horiz_interp_mod, only : horiz_interp_type, horiz_interp_init, &
                               horiz_interp_new, horiz_interp, horiz_interp_del
use  monin_obukhov_mod, only : mo_profile
use      constants_mod, only : GRAV, &     ! acceleration due to gravity [m/s2]
                               RDGAS, &    ! gas constant for dry air [J/kg/deg]
                               PI, &
                               DENS_H2O, & ! Water density [kg/m3]
                               WTMH2O, &   ! Water molecular weight [g/mole]
                               WTMAIR, &   ! Air molecular weight [g/mole]
                               AVOGNO      ! Avogadro's number
use   interpolator_mod, only : interpolator,  &
                               obtain_interpolator_time_slices, &
                               unset_interpolator_time_flag, &
                               interpolate_type
use      astronomy_mod, only : universal_time

implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  wet_deposition,    &
        dry_deposition,    &
        dry_deposition_time_vary,    &
        dry_deposition_endts,        &
        interp_emiss,      &
        atmos_tracer_utilities_end, &
        atmos_tracer_utilities_init, &
        get_wetdep_param, &
        get_rh,   &
        get_w10m, &
        get_cldf, &
        sjl_fillz

!---- version number -----
logical :: module_is_initialized = .FALSE.

character(len=128) :: version = '$Id: atmos_tracer_utilities.F90,v 17.0.2.1.2.1.4.1 2010/03/17 20:27:11 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

character(len=7), parameter :: mod_name = 'tracers'
integer, parameter :: max_tracers = MAX_TRACER_FIELDS
!-----------------------------------------------------------------------
!--- identification numbers for  diagnostic fields and axes ----
integer :: id_tracer_ddep(max_tracers), id_tracer_dvel(max_tracers), &
           id_tracer_wdep_ls(max_tracers),   id_tracer_wdep_cv(max_tracers),  &
           id_tracer_wdep_lsin(max_tracers), id_tracer_wdep_cvin(max_tracers),&
           id_tracer_wdep_lsbc(max_tracers), id_tracer_wdep_cvbc(max_tracers),&
           id_tracer_reevap_ls(max_tracers), id_tracer_reevap_cv(max_tracers)
integer :: id_tracer_ddep_cmip(max_tracers)
integer :: id_w10m, id_delm
character(len=32),  dimension(max_tracers) :: tracer_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_units     = ' '
character(len=128), dimension(max_tracers) :: tracer_longnames = ' '
character(len=32),  dimension(max_tracers) :: tracer_wdep_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_wdep_units     = ' '
character(len=128), dimension(max_tracers) :: tracer_wdep_longnames = ' '
character(len=32),  dimension(max_tracers) :: tracer_ddep_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_dvel_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_ddep_units     = ' '
character(len=32),  dimension(max_tracers) :: tracer_dvel_units     = ' '
character(len=128), dimension(max_tracers) :: tracer_ddep_longnames = ' '
character(len=128), dimension(max_tracers) :: tracer_dvel_longnames = ' '
real, allocatable :: blon_out(:,:), blat_out(:,:)
!----------------parameter values for the diagnostic units--------------
real, parameter :: mw_air = WTMAIR/1000.  ! Convert from [g/mole] to [kg/mole]
real, parameter :: mw_h2o = WTMH2O/1000.  ! Convert from [g/mole] to [kg/mole]
real, parameter :: twopi = 2*PI

type wetdep_type
   character (len=200) :: scheme, text_in_scheme, control
   real  :: Henry_constant
   real  :: Henry_variable
   real  :: frac_in_cloud
   real  :: alpha_r
   real  :: alpha_s
   logical :: Lwetdep, Lgas, Laerosol, Lice
end type wetdep_type

type(wetdep_type), dimension(:), allocatable :: Wetdep


type drydep_type
   character (len=200) :: scheme, name, control
   real  :: land_dry_dep_vel
   real  :: sea_dry_dep_vel
   logical :: Ldrydep
end type drydep_type

type(drydep_type), dimension(:), allocatable :: Drydep


contains

!
! ######################################################################
!
!<SUBROUTINE NAME="atmos_tracer_utilities_init">
!<OVERVIEW>
! This is a routine to create and register the dry and wet deposition 
! fields of the tracers.
!</OVERVIEW>
!<DESCRIPTION>
!  This routine creates diagnostic names for dry and wet deposition fields of the tracers.
!  It takes the tracer name and appends "ddep" for the dry deposition field and "wdep" for 
!  the wet deposition field. This names can then be entered in the diag_table for 
!  diagnostic output of the tracer dry and wet deposition. The module name associated with
!  these fields in "tracers". The units of the deposition fields are assumed to be kg/m2/s.
!</DESCRIPTION>
!<TEMPLATE>
! call atmos_tracer_utilities_init(lonb,latb, mass_axes, Time)
!</TEMPLATE>
!   <IN NAME="lonb" TYPE="real" DIM="(:,:)">
!     The longitude corners for the local domain.
!   </IN>
!   <IN NAME="latb" TYPE="real" DIM="(:,:)">
!     The latitude corners for the local domain.
!   </IN>
!   <IN NAME="mass_axes" TYPE="integer" DIM="(3)">
!     The axes relating to the tracer array.
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>

subroutine atmos_tracer_utilities_init(lonb, latb, mass_axes, Time)

! Routine to initialize the tracer identification numbers. 
! This registers the 2D fields for the wet and dry deposition.
real, dimension(:,:),  intent(in) :: lonb, latb
integer, dimension(3), intent(in) :: mass_axes
type(time_type),       intent(in) :: Time

integer :: ntrace
character(len=20) :: units =''
!
integer :: n, logunit
character(len=128) :: name

logical  :: flag

! Make local copies of the local domain dimensions for use 
! in interp_emiss.
      allocate ( blon_out(size(lonb,1),size(lonb,2)))
      allocate ( blat_out(size(latb,1),size(latb,2)))
!      allocate ( data_out(size(lonb(:))-1, size(latb(:))-1))
      blon_out = lonb
      blat_out = latb
      
      do n = 1, max_tracers
         write ( tracer_names(n),     100 ) n
         write ( tracer_longnames(n), 102 ) n
         tracer_units(n) = 'none'
      enddo
  100 format ('tr',i3.3)
  102 format ('tracer ',i3.3)

call get_number_tracers(MODEL_ATMOS, num_tracers= ntrace)

   if (ntrace > 0) then
     allocate (Wetdep(ntrace))
     allocate (Drydep(ntrace))
   endif
   do n = 1, ntrace
!--- set tracer tendency names where tracer names have changed ---

call get_tracer_names(MODEL_ATMOS,n,tracer_names(n),tracer_longnames(n),tracer_units(n))
      write (name,100) n
      if (trim(tracer_names(n)) /= name) then
          tracer_ddep_names(n) = trim(tracer_names(n)) //'_ddep'
          tracer_dvel_names(n) = trim(tracer_names(n)) //'_dvel'
          tracer_wdep_names(n) = trim(tracer_names(n)) //'_wdep'
      endif
      write (name,102) n
      if (trim(tracer_longnames(n)) /= name) then
          tracer_wdep_longnames(n) = &
                  trim(tracer_longnames(n)) // ' wet deposition for tracers'
          tracer_ddep_longnames(n) = &
                  trim(tracer_longnames(n)) // ' dry deposition for tracers'
          tracer_dvel_longnames(n) = &
                  trim(tracer_longnames(n)) // ' dry deposition velocity for tracers'
      endif

      select case (trim(tracer_units(n)))
        case ('mmr')
          units = 'kg/m2/s'
        case ('kg/kg')
          units = 'kg/m2/s'
        case ('vmr')
          units = 'mole/m2/s'
        case ('mol/mol')
          units = 'mole/m2/s'
        case ('mole/mole')
          units = 'mole/m2/s'
        case default
          units = trim(tracer_units(n))//' kg/(m2 s)'
          call error_mesg('atmos_tracer_utilities_init',&
          ' Dry dep units set to '//trim(units)//' in atmos_tracer_utilities for '//trim(tracer_names(n)),&
           NOTE)
      end select

    
      flag = query_method ('wet_deposition',MODEL_ATMOS,n, &
                            Wetdep(n)%text_in_scheme,Wetdep(n)%control)
      call get_wetdep_param(Wetdep(n)%text_in_scheme,  &
                            Wetdep(n)%control,&
                            Wetdep(n)%scheme, &
                            Wetdep(n)%Henry_constant,  &
                            Wetdep(n)%Henry_variable, &
                            Wetdep(n)%frac_in_cloud, &
                            Wetdep(n)%alpha_r, Wetdep(n)%alpha_s, &
                            Wetdep(n)%Lwetdep, Wetdep(n)%Lgas, &
                            Wetdep(n)%Laerosol, Wetdep(n)%Lice )

      Drydep(n)%Ldrydep = query_method ('dry_deposition', MODEL_ATMOS,&
                                  n,Drydep(n)%name, Drydep(n)%control)


      call get_drydep_param(Drydep(n)%name,Drydep(n)%control,  &
                         Drydep(n)%scheme,Drydep(n)%land_dry_dep_vel,  &
                                             Drydep(n)%sea_dry_dep_vel)


! Register the dry deposition of the n tracers
     id_tracer_ddep(n) = register_diag_field ( mod_name,                    &
            trim(tracer_ddep_names(n)), mass_axes(1:2), Time,               &
            trim(tracer_ddep_longnames(n)),                                 &
            trim(units), missing_value=-999.     )
     id_tracer_ddep_cmip(n) = register_diag_field ( mod_name,               &
            trim(tracer_ddep_names(n))//'_cmip', mass_axes(1:2), Time,      &
            trim(tracer_ddep_longnames(n)),                                 &
           'kg/m2/s', missing_value=-999.     )
! Register the dry deposition of the n tracers
     id_tracer_dvel(n) = register_diag_field ( mod_name,                    &
            trim(tracer_dvel_names(n)), mass_axes(1:2), Time,               &
            trim(tracer_dvel_longnames(n)),                                 &
            'm/s', missing_value=-999.     )
! Register the wet deposition of the n tracers by large scale clouds
     id_tracer_wdep_ls(n) = register_diag_field ( mod_name,                 &
            trim(tracer_wdep_names(n))//'_ls', mass_axes(1:2), Time,        &
            trim(tracer_wdep_longnames(n))//' in large scale',              &
            trim(units), missing_value=-999.    )
! Register the wet deposition of the n tracers by convective clouds
     id_tracer_wdep_cv(n) = register_diag_field ( mod_name,               &
              trim(tracer_wdep_names(n))//'_cv', mass_axes(1:2), Time, &
              trim(tracer_wdep_longnames(n))//' in convective scheme',                   &
              trim(units), missing_value=-999.    )
! Register in-cloud rainout by large scale clouds
     id_tracer_wdep_lsin(n) = register_diag_field ( mod_name,               &
            trim(tracer_wdep_names(n))//'_lsin', mass_axes(1:2), Time,      &
            trim(tracer_wdep_longnames(n))//' in_cloud by lscale precip',   &
            trim(units), missing_value=-999.    )
! Register below-cloud washout by large scale clouds
     id_tracer_wdep_lsbc(n) = register_diag_field ( mod_name,               &
            trim(tracer_wdep_names(n))//'_lsbc', mass_axes(1:2), Time,      &
            trim(tracer_wdep_longnames(n))//' below_cloud by lscale precip',&
            trim(units), missing_value=-999.  )
! Register in-cloud re-evaporation by large scale clouds
     id_tracer_reevap_ls(n) = register_diag_field ( mod_name,               &
            trim(tracer_names(n))//'_reevap_ls', mass_axes(1:3), Time,      &
            trim(tracer_longnames(n))//' re-evap by lscale clouds',         &
            trim(units), missing_value=-999.    )
! Register in-cloud rainout by convective clouds
! Register in-cloud rainout of the n tracers by convective clouds
     id_tracer_wdep_cvin(n) = register_diag_field ( mod_name,               &
            trim(tracer_wdep_names(n))//'_cvin', mass_axes(1:2), Time,      &
            trim(tracer_wdep_longnames(n))//' in_cloud by conv precip',     &
            trim(units), missing_value=-999.    )
! Register below-cloud washout by convective clouds
     id_tracer_wdep_cvbc(n) = register_diag_field ( mod_name,               &
            trim(tracer_wdep_names(n))//'_cvbc', mass_axes(1:2), Time,      &
            trim(tracer_wdep_longnames(n))//' below_cloud by conv precip',  &
            trim(units), missing_value=-999.  )
! Register re-evaporation by convective clouds
     id_tracer_reevap_cv(n) = register_diag_field ( mod_name,               &
            trim(tracer_names(n))//'_reevap_cv', mass_axes(1:3), Time,      &
            trim(tracer_longnames(n))//' re-evap by conv precip',         &
            trim(units), missing_value=-999.    )
   enddo
! Register scaling factor to calculate wind speed at 10 meters
   id_delm   = register_diag_field ( mod_name,                &
               'delm', mass_axes(1:2),Time,                   &
               'Scaling factor', 'none',                      &
                missing_value=-999.                           )
! Register the wind speed at 10 meters
   id_w10m   = register_diag_field ( mod_name,                &
               'w10m', mass_axes(1:2),Time,                   &
               'Wind speed at 10 meters', 'm/s',              &
                missing_value=-999.                           )

 
      call write_version_number (version, tagname)

    if ( mpp_pe() == mpp_root_pe() ) then
         logunit=stdlog()
         call write_namelist_values (logunit,ntrace)
    endif

      module_is_initialized = .TRUE.

end subroutine atmos_tracer_utilities_init


!####################################################################

subroutine dry_deposition_time_vary (drydep_data, Time)

type(time_type), intent(in) :: Time
type(interpolate_type), dimension(:), intent(inout) :: drydep_data

      integer :: n


      do n=1,size(drydep_data,1)
        if (Drydep(n)%Ldrydep .and. Drydep(n)%scheme == 'file') then
          call obtain_interpolator_time_slices (drydep_data(n), Time)
        endif
      end do

end subroutine dry_deposition_time_vary 



!####################################################################

subroutine dry_deposition_endts (drydep_data)                          

type(interpolate_type), dimension(:), intent(inout) :: drydep_data

      integer :: n

      do n=1, size(drydep_data,1)     
        call unset_interpolator_time_flag (drydep_data(n))
      end do


end subroutine dry_deposition_endts       



!####################################################################

!</SUBROUTINE>
!
!#######################################################################
!
subroutine write_namelist_values (unit, ntrace)
    integer, intent(in) :: unit, ntrace
    integer :: n

    write (unit,10)
    do n = 1, ntrace
       write (unit,11) trim(tracer_wdep_names(n)),     &
                       trim(tracer_wdep_longnames(n)), &
                       trim(tracer_wdep_units(n))
       write (unit,11) trim(tracer_ddep_names(n)),     &
                       trim(tracer_ddep_longnames(n)), &
                       trim(tracer_ddep_units(n))
       write (unit,11) trim(tracer_dvel_names(n)),     &
                       trim(tracer_dvel_longnames(n)), &
                       'm/s'
    enddo

 10 format (' &TRACER_DIAGNOSTICS_NML', &
          /,'    TRACER:  names  longnames  (units)')
 11 format (a16,2x,a,2x,'(',a,')')

 end subroutine write_namelist_values

!
!#######################################################################
!
!<SUBROUTINE NAME = "dry_deposition">
subroutine dry_deposition( n, is, js, u, v, T, pwt, pfull, dz, &
                           u_star, landmask, dsinku, tracer, Time, &
                           lon, half_day, &
                           drydep_data )
!
!<OVERVIEW>
! Routine to calculate the fraction of tracer to be removed by dry 
! deposition.
!</OVERVIEW>
!<DESCRIPTION>
! There are three types of dry deposition coded.
!
! 1) Wind driven derived dry deposition velocity.
!
! 2) Fixed dry deposition velocity.
! 
! 3) Dry deposition velocities read in from input file
! 
! The theory behind the wind driven dry deposition velocity calculation
! assumes that the deposition can be modeled as a parallel resistance type 
! problem.
!
!  Total resistance to HNO3-type dry deposition, 
!<PRE>       R = Ra + Rb
!  resisa = aerodynamic resistance
!  resisb = surface resistance (laminar layer + uptake)
!         = 5/u*  [s/cm]        for neutral stability
!      Vd = 1/R
!</PRE>
! For the fixed dry deposition velocity, there is no change in the 
! deposition velocity but the variation of the depth of the surface 
! layer implies that there is variation in the amount deposited.
!
! To utilize this section of code add one of the following lines as 
! a method for the tracer of interest in the field table.
!<PRE>
! "dry_deposition","wind_driven","surfr=XXX"
!     where XXX is the total resistance defined above.
!
! "dry_deposition","fixed","land=XXX, sea=YYY"
!     where XXX is the dry deposition velocity (m/s) over land
!       and YYY is the dry deposition velocity (m/s) over sea.
!
! "dry_deposition","file","FILENAME.NC"
!     where FILENAME.NC is the NetCDF file name.
!</PRE>
!</DESCRIPTION>
!<TEMPLATE>
! call dry_deposition( n, is, js, u, v, T, pwt, pfull, dz,
!                      u_star, landmask, dsinku, tracer, Time, drydep_data)
!</TEMPLATE>
!
!  <IN NAME="n" TYPE="integer">
!    The tracer number.
!  </IN>
!  <IN NAME="is, js" TYPE="integer">
!    Start indices for array (computational indices).
!  </IN>
!  <IN NAME="u" TYPE="real" DIM="(:,:)">
!    U wind field.
!  </IN>
!  <IN NAME="v" TYPE="real" DIM="(:,:)">
!    V wind field.
!  </IN>
!  <IN NAME="T" TYPE="real" DIM="(:,:)">
!    Temperature.
!  </IN>
!  <IN NAME="pwt" TYPE="real" DIM="(:,:)">
!     Pressure differential of half levels.
!  </IN>
!  <IN NAME="pfull" TYPE="real" DIM="(:,:)">
!     Full pressure levels.
!  </IN>
!  <IN NAME="u_star" TYPE="real" DIM="(:,:)">
!     Friction velocity.
!  </IN>
!  <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     Longitude.
!  </IN>
!  <IN NAME="landmask" TYPE="logical">
!     Land - sea mask.
!  </IN>
!  <INOUT NAME="drydep_data" TYPE="interpolate_type">
!     Dry deposition data interpolated from input file.
!  </INOUT>
!
!  <OUT NAME="dsinku" TYPE="real" DIM="(:,:)">
!    The amount of tracer in the surface layer which is dry deposited per second.
!  </OUT>
!
integer, intent(in)                 :: n, is, js
real, intent(in), dimension(:,:)    :: u, v, T, pwt, pfull, u_star, tracer, dz
real, intent(in), dimension(:,:)    :: lon, half_day
logical, intent(in), dimension(:,:) :: landmask
type(time_type), intent(in)         :: Time
type(interpolate_type),intent(inout)  :: drydep_data
real, intent(out), dimension(:,:)   :: dsinku

real,dimension(size(u,1),size(u,2))   :: hwindv,frictv,resisa,drydep_vel
integer :: i,j, flagsr, id, jd
real    :: land_dry_dep_vel, sea_dry_dep_vel, surfr
real    :: diag_scale
real    :: factor_tmp, gmt, dv_on, dv_off, dayfrac, vd_night, vd_day, loc_angle
logical :: used, diurnal
integer :: flag_species, flag_diurnal
character(len=10) ::units,names
character(len=80) :: name,control,scheme, speciesname,dummy

! Default zero
dsinku = 0.0
if (.not. Drydep(n)%Ldrydep) return
name =Drydep(n)%name
control = Drydep(n)%control
scheme = Drydep(n)%scheme
land_dry_dep_vel = Drydep(n)%land_dry_dep_vel
sea_dry_dep_vel = Drydep(n)%sea_dry_dep_vel

! delta z = dp/(rho * grav)
! delta z = RT/g*dp/p    pwt = dp/g
!dz(:,:) = pwt(:,:)*rdgas*T(:,:)/pfull(:,:)
id=size(pfull,1); jd=size(pfull,2)


  select case(lowercase(scheme))
  
    case('wind_driven')
! Calculate horizontal wind velocity and aerodynamic resistance:
!   where xxfm=(u*/u) is drag coefficient, Ra=u/(u*^2), 
!   and  u*=sqrt(momentum flux)  is friction velocity.
!
!****  Compute dry sinks (loss frequency, need modification when 
!****    different vdep values are to be used for species)
        flagsr=parse(control,'surfr',surfr)
        if(flagsr == 0) surfr=500.
        hwindv=sqrt(u**2+v**2)
        frictv=u_star
        resisa=hwindv/(u_star*u_star)
        where (frictv .lt. 0.1) frictv=0.1
        dsinku = (1./(surfr/frictv + resisa))/dz
        drydep_vel(:,:) = 0.

    case('fixed')
! For the moment let's try to calculate the delta-z of the bottom 
! layer and using a simple dry deposition velocity times the 
! timestep, idt, calculate the fraction of the lowest layer which 
! deposits.
       where (landmask(:,:))
! dry dep value over the land surface
         drydep_vel(:,:) = land_dry_dep_vel
      elsewhere
! dry dep value over the sea surface
         drydep_vel(:,:) = sea_dry_dep_vel
      endwhere
      dsinku(:,:) = drydep_vel(:,:) / dz(:,:)

    case('file')
        flag_species = parse(control,'name',speciesname)
        if(flag_species>0) then
           name = trim(speciesname)
        else
           call get_tracer_names(MODEL_ATMOS,n,name)
        endif
        flag_diurnal = parse(control,'diurnal',dummy)
        diurnal = (flag_diurnal > 0)
        call interpolator( drydep_data, Time, drydep_vel, trim(name), is, js )

        if (diurnal) then
           do j = 1,jd
           do i = 1,id
! half_day is between 0 and pi, so dv_off btwn 0 to pi, dv_on btwn -pi and 0
              dv_off = MIN( 1.2*half_day(i,j), PI )
              dv_on = -dv_off
              dayfrac = dv_off/PI
! apply the mean dep vel during polar day or polar night (or nearby)
              if (dv_off > 0 .and. dv_off < PI  ) then
                 vd_night = MIN(0.001, 0.5*drydep_vel(i,j))
                 vd_day = ( drydep_vel(i,j)-vd_night*(1.-dayfrac) ) / dayfrac
                 gmt = universal_time(Time)
                 loc_angle = gmt + lon(i,j) - PI
                 if (loc_angle >= PI) loc_angle = loc_angle - twopi
                 if (loc_angle < -PI) loc_angle = loc_angle + twopi
                 if( loc_angle >= dv_off .or. loc_angle <= dv_on ) then
                    drydep_vel(i,j) = vd_night
                 else
                    factor_tmp = loc_angle - dv_on
                    factor_tmp = factor_tmp / MAX(2*dv_off,1.e-6)
                    drydep_vel(i,j) = 0.5*PI*sin(factor_tmp*PI)*(vd_day-vd_night) + vd_night
                 end if
              end if
           end do
           end do
        end if !(diurnal)

        dsinku(:,:) = drydep_vel(:,:) / dz(:,:)
    case('default')
        drydep_vel(:,:) = 0.
  end select

dsinku(:,:) = MAX(dsinku(:,:), 0.0E+00)
where(tracer>0)
  dsinku=dsinku*tracer
elsewhere
  dsinku=0.0
endwhere

! Now save the dry deposition to the diagnostic manager
! delta z = dp/(rho * grav)
! delta z *rho  = dp/g
! tracer(kgtracer/kgair) * dz(m)* rho(kgair/m3) = kgtracer/m2
! so rho drops out of the equation
    if (id_tracer_ddep(n) > 0 ) then
      call get_tracer_names(MODEL_ATMOS,n,names,units=units)
      select case (trim(units))
        case ('vmr')
          diag_scale = mw_air
        case ('mol/mol')
          diag_scale = mw_air
        case ('mole/mole')
          diag_scale = mw_air
        case default
          diag_scale = 1.
      end select
      used = send_data ( id_tracer_ddep(n), dsinku*pwt/diag_scale, Time, &
          is_in =is,js_in=js)
    endif
    if (id_tracer_ddep_cmip(n) > 0 ) then
      call get_tracer_names(MODEL_ATMOS,n,names,units=units)
      select case (trim(names))
        case ('so2')
          diag_scale = mw_air/0.064
        case ('so4')
          diag_scale = mw_air/0.096
        case ('dms')
          diag_scale = mw_air/0.062
        case ('nh3')
          diag_scale = mw_air/0.017
        case default
          diag_scale = 1.
        end select
       used = send_data ( id_tracer_ddep_cmip(n), dsinku*pwt/diag_scale,Time, &
           is_in =is,js_in=js)
    endif
    if (id_tracer_dvel(n) > 0 ) then
      used = send_data ( id_tracer_dvel(n), drydep_vel, Time, &
          is_in =is,js_in=js)
    end if
end subroutine dry_deposition
!</SUBROUTINE>
!
!#######################################################################
!
!<SUBROUTINE NAME = "wet_deposition">
!<TEMPLATE>
!CALL wet_deposition( n, T, pfull, phalf, zfull, zhalf, &
!                     rain, snow, qdt, cloud, rain3d, snow3d, &
!                     tracer, tracer_dt, Time, cloud_param, is, js, dt )
!</TEMPLATE>
subroutine wet_deposition( n, T, pfull, phalf, zfull, zhalf, &
                           rain, snow, qdt, cloud, cloud_frac, rain3d, snow3d, &
                           tracer, tracer_dt, Time, cloud_param, &
                           is, js, dt, sum_wdep_out )
!      
!<OVERVIEW>
! Routine to calculate the fraction of tracer removed by wet deposition
!</OVERVIEW>
!
!<IN NAME="n" TYPE="integer">
!   Tracer number
!</IN>
!<IN NAME="is, js" TYPE="integer">
!   start indices for array (computational indices)
!</IN>
!<IN NAME="T" TYPE="real" DIM="(:,:,:)">
!   Temperature
!</IN>
!<IN NAME="pfull" TYPE="real" DIM="(:,:,:)">
!   Full level pressure field (Pa)
!</IN>
!<IN NAME="phalf" TYPE="real" DIM="(:,:,:)">
!   Half level pressure field (Pa)
!</IN>
!<IN NAME="zfull" TYPE="real" DIM="(:,:,:)">
!   Full level height field (m)
!</IN>
!<IN NAME="zhalf" TYPE="real" DIM="(:,:,:)">
!   Half level height field (m)
!</IN>
!<IN NAME="rain" TYPE="real" DIM="(:,:)">
!   Precipitation in the form of rain
!</IN>
!<IN NAME="snow" TYPE="real" DIM="(:,:)">
!   Precipitation in the form of snow
!</IN>
!<IN NAME="qdt" TYPE="real" DIM="(:,:,:)">
!   The tendency of the specific humidity (+ condenstate) due to the cloud parametrization (kg/kg/s)
!</IN>
!<IN NAME="cloud" TYPE="real" DIM="(:,:,:)">
!   Cloud amount (liquid + ice) (kg/kg)
!</IN>
!<IN NAME="cloud_frac" TYPE="real" DIM="(:,:,:)">
!   Cloud area fraction
!</IN>
!<IN NAME="rain3d" TYPE="real" DIM="(:,:,:)">
!   Precipitation in the form of rain (kg/m2/s)
!</IN>
!<IN NAME="snow3d" TYPE="real" DIM="(:,:,:)">
!   Precipitation in the form of snow (kg/m2/s)
!</IN>
!<IN NAME="tracer" TYPE="real" DIM="(:,:,:)">
!   The tracer field 
!</IN>
!<IN NAME="Time" TYPE="type(time_type)">
!   The time structure for submitting wet deposition as a diagnostic
!</IN>
!<IN NAME="cloud_param" TYPE="character">
!   Is this a convective (convect) or large scale (lscale) cloud parametrization?
!</IN>
!<IN NAME="dt" TYPE="real">
!   The model timestep (in seconds)
!</IN>
!<OUT NAME="tracer_dt" TYPE="real" DIM="(:,:,:)">
!   The tendency of the tracer field due to wet deposition
!</OUT>
!<DESCRIPTION>
! Schemes allowed here are 
!
! 1) Deposition removed in the same fractional amount as the modeled precipitation rate is to 
!    a standardized precipitation rate.
!    Basically this scheme assumes that a fractional area of the gridbox is affected by 
!    precipitation and that this precipitation rate is due to a cloud of standardized cloud 
!    liquid water content. Removal is constant throughout the column where precipitation is occuring.
!
! 2) Removal according to Henry's Law. This law states that the ratio of the concentation in 
!    cloud water and the partial pressure in the interstitial air is a constant. If tracer
!    is in VMR, the units for Henry's constant are mole/L/Pa (normally it is mole/L/atm).
!    Parameters for a large number of species can be found at
!    http://www.mpch-mainz.mpg.de/~sander/res/henry.html
!
! 3) Aerosol removal, using specified in-cloud tracer fraction

! 4) Similar as 3) with some lwh modifications
!
! To utilize this section of code add one of the following lines as 
! a method for the tracer of interest in the field table.
!<PRE>
! "wet_deposition","henry","henry=XXX, dependence=YYY"
!     where XXX is the Henry's constant for the tracer in question
!       and YYY is the temperature dependence of the Henry's Law constant.
!
! "wet_deposition","fraction","lslwc=XXX, convlwc=YYY"
!     where XXX is the liquid water content of a standard large scale cloud
!       and YYY is the liquid water content of a standard convective cloud.
!</PRE>

!</DESCRIPTION>

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
integer,          intent(in)                     :: n, is, js
real,             intent(in),  dimension(:,:,:)  :: T, pfull,phalf, zfull, zhalf, qdt, cloud, tracer
real,             intent(in),  dimension(:,:,:)  :: cloud_frac
real,             intent(in),  dimension(:,:)    :: rain, snow
character(len=*), intent(in)                     :: cloud_param
type (time_type), intent(in)                     :: Time
real,             intent(out), dimension(:,:,:)  :: tracer_dt
real,             intent(in)                     :: dt
real,             intent(in),  dimension(:,:,:)  :: rain3d, snow3d
real,             intent(out),  dimension(:,:), optional :: sum_wdep_out

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
real, dimension(size(T,1),size(T,2),size(pfull,3)) :: &
      Htemp, xliq, n_air, rho_air, pwt, zdel, precip3d,scav_fact3d
real, dimension(size(T,1),size(T,2)) :: &
      temp_factor, scav_factor, washout, sum_wdep, &
      w_h2o, K1, K2, beta, f_a, &
      wdep_in, wdep_bc, fluxr,fluxs, tracer_flux
real, dimension(size(T,1),size(T,2),size(pfull,3)) :: &
      in_temp, bc_temp, dt_temp, reevap_fraction, reevap_diag
integer, dimension(size(T,1),size(T,2)) :: &
      ktopcd, kendcd
real, dimension(size(rain3d,1),size(rain3d,2),size(rain3d,3)) :: rainsnow3d

integer :: i, j, k, kk, id, jd, kd, flaglw

real, dimension(size(T,3)) :: conc

real :: conc_rain, conc_rain_total, conc_sat

real, parameter ::  DENS_SNOW = 500.    ! Snow density [kg/m3]
real, parameter ::  RGAS      = 8.3143  ! ideal gas constant Pa m3/mol/K

real    :: &
      Henry_constant, Henry_variable, &
      clwc, wash, premin, prenow, hwtop, &
      diag_scale

real, parameter :: &
      inv298p15 = 1./298.15, &     ! 1/K
      kboltz = 1.38E-23,         & ! J/K
      rain_diam  = 1.89e-3,     &  ! mean diameter of rain drop (m)
      rain_vterm = 7.48,        &  ! rain drop terminal velocity (m/s)
      vk_air = 6.18e-6,         &  ! kinematic viscosity of air (m^2/s)
      d_g = 1.12e-5,            &  ! diffusive coefficient (m^2/s)
      geo_fac = 6.,             &  ! geometry factor (surface area/volume = geo_fac/diameter)
      cm3_2_m3 = 1.e-6             ! m3/cm3

real :: &
      k_g,                       & ! mass transfer coefficient (m/s)
      stay,                      & ! fraction
      fall_time                    ! fall time through layer (s)

real :: f_a0, scav_factor0, sa_drop0, fgas0
real :: frac_in_cloud, frac_int, ph
real , parameter :: &
      R_r = 0.001, &               ! radius of cloud-droplets for rain
      R_s = 0.001, &               ! radius of cloud-droplets for snow
      frac_int_gas = 1.0,   &
      frac_int_aerosol= 0.5

real :: alpha_r, alpha_s

logical :: &
      used, &
      Lwetdep, Lgas, Laerosol, Lice
character(len=200) :: &
      tracer_name, control, scheme, units, &
      text_in_scheme

!-----------------------------------------------------------------------

    ktopcd = 0
    kendcd = 0

    tracer_dt   = 0.
    wdep_in     = 0.
    wdep_bc     = 0.
    beta        = 0.
    reevap_fraction = 0.
    reevap_diag = 0.
    tracer_flux = 0.

    sum_wdep = 0.

    id = size(T,1)
    jd = size(T,2)
    kd = size(T,3)

    call get_tracer_names(MODEL_ATMOS,n,tracer_name, units = units)
    if ( .not. Wetdep(n)%Lwetdep) return
     text_in_scheme = Wetdep(n)%text_in_scheme
     control = Wetdep(n)%control
     scheme = Wetdep(n)%scheme
     Henry_constant = Wetdep(n)%Henry_constant
     Henry_variable = Wetdep(n)%Henry_variable
     frac_in_cloud = Wetdep(n)%frac_in_cloud
     alpha_r = Wetdep(n)%alpha_r
     alpha_s = Wetdep(n)%alpha_s
     Lwetdep = Wetdep(n)%Lwetdep
     Lgas    = Wetdep(n)%Lgas
     Laerosol = Wetdep(n)%Laerosol
     Lice    = Wetdep(n)%Lice

    rho_air(:,:,:) = pfull(:,:,:) / ( T(:,:,:)*RDGAS ) ! kg/m3
!   Lice = .not. (scheme=='henry_noice' .or. scheme=='henry_below_noice' .or. &
!                 scheme=='aerosol_noice' .or. scheme=='aerosol_below_noice' )
    if (Lice) then
       rainsnow3d(:,:,:) = rain3d(:,:,:) + snow3d(:,:,:)
    else
       rainsnow3d(:,:,:) = rain3d(:,:,:)
    end if
    do k=1,kd
       precip3d(:,:,k) = rainsnow3d(:,:,k+1)-rainsnow3d(:,:,k)
       pwt(:,:,k)  = ( phalf(:,:,k+1) - phalf(:,:,k) )/GRAV ! kg/m2
       zdel(:,:,k) = zhalf(:,:,k) - zhalf(:,:,k+1) ! m
    end do
!
!+++ pag: 
!
if(lowercase(scheme)=='wdep_gas' .or. lowercase(scheme)=='wdep_aerosol') then
      ph = 5.0
!  cloud liquid water content
      xliq(:,:,:) = 0.5E-3                           !default value
      if(trim(cloud_param) .eq. 'convect') then
         xliq(:,:,:) = 1.0e-3
      elseif(trim(cloud_param) .eq. 'lscale') then
         xliq(:,:,:) = 0.5e-3
      endif

!                    
! tracer == gas      
!             
      if(lowercase(scheme)=="wdep_gas") THEN
          frac_int = frac_int_gas
          do k = 1, kd
            do j = 1, jd
              do i = 1, id
                Htemp(i,j,k)=henry_constant &
                          *exp(-Henry_variable*(1./298.-1./T(i,j,k)))
                K1(i,j)=1.2e-2*exp(-2010*(1/298.-1/T(i,j,k)))
                K2(i,j)=6.6e-8*exp(-1510*(1/298.-1/T(i,j,k)))
                HTemp(i,j,k)=Htemp(i,j,k)*(1 + K1(i,j) &
                           /10.**(-ph) + K1(i,j)*K2(i,j)/(10.**(-ph))**2)
                f_a(i,j) = Htemp(i,j,k)/101.325*RGAS &
                           *T(i,j,k)*xliq(i,j,k)*rho_air(i,j,k)/DENS_H2O
                scav_fact3d(i,j,k)=f_a(i,j)/(1.+f_a(i,j))
              enddo
            enddo
          enddo
      elseif(lowercase(scheme)=="wdep_aerosol") THEN
          frac_int = frac_int_aerosol
          scav_fact3d(:,:,:)=frac_in_cloud
      else
      print *,' Aerosol number =',n,' tracer_name=',tracer_name,' scheme=',text_in_scheme
      print *, 'Please check "am2p12.ft'
      call ERROR_MESG('wet_deposition', 'Tracer is neither aerosol NOR gas.', FATAL )
    endif
!                    
!in cloud scavenging
!
        do k=1,kd
          do j = 1, jd
            do i = 1, id
              beta(i,j)  = MAX( 0.0, precip3d(i,j,k)/pwt(i,j,k)/xliq(i,j,k))
              in_temp(i,j,k) = (exp(-beta(i,j)*scav_fact3d(i,j,k)*dt)-1.0)
              if ( tracer(i,j,k) .gt. 0.) then
                wdep_in(i,j)=wdep_in(i,j) &
                             - in_temp(i,j,k)*tracer(i,j,k)*pwt(i,j,k)
                tracer_dt(i,j,k) = tracer_dt(i,j,k) &
                                   - in_temp(i,j,k)*tracer(i,j,k)/dt
              endif
!                    
!--reevaporation     
!    calculation of fracion of aerosols to-be
!    reevaporated to the atmosphere:

              beta(i,j)=precip3d(i,j,k)
              if (beta(i,j) < 0.) then
                beta(i,j) = beta(i,j)/rainsnow3d(i,j,k)
              endif
              if (rainsnow3d(i,j,k+1) == 0. ) then 
!--reevaporation total
                beta(i,j)=MIN(MAX(0.,-beta(i,j)),1.)
              else
                beta(i,j)=MIN(MAX(0.,-beta(i,j))*frac_int,1.)
              endif
! reevporating to atmosphere
              reevap_diag(i,j,k)=beta(i,j)*wdep_in(i,j)
              wdep_in(i,j) = wdep_in(i,j)*(1.-beta(i,j))
              tracer_dt(i,j,k) = tracer_dt(i,j,k) &
                                 - reevap_diag(i,j,k)/pwt(i,j,k)/dt
            enddo
          enddo
        enddo
! Below cloud scavenging
        do k=1,kd
          do j = 1, jd
            do i = 1, id
              fluxs(i,j) = (snow3d(i,j,k+1)+snow3d(i,j,k))/2.0
              fluxr(i,j) = (rain3d(i,j,k+1)+rain3d(i,j,k))/2.0
              bc_temp(i,j,k) = 3./4.*dt* &
                       (fluxr(i,j)*alpha_r/R_r/DENS_H2O &
                        + fluxs(i,j)*alpha_s/R_s/DENS_SNOW)
              if ( tracer(i,j,k) .gt. 0. ) then
                wdep_bc(i,j)=wdep_bc(i,j) &
                             + bc_temp(i,j,k)*tracer(i,j,k)*pwt(i,j,k)
                tracer_dt(i,j,k) = tracer_dt(i,j,k) &
                                   + bc_temp(i,j,k)*tracer(i,j,k)/dt
              endif
            enddo
          enddo
        enddo
!
!  end wdep_gas or wdep_aerosol
!
    else  

! Calculate fraction of precipitation reevaporated in layer
     do k=1,kd
       where( rainsnow3d(:,:,k) > 0. .and. precip3d(:,:,k) < 0. )
          reevap_fraction(:,:,k) = &
             -precip3d(:,:,k) / (rainsnow3d(:,:,k)) ! fraction
       end where
! Assume that the tracer reevaporation fraction is 50% of the precip
! reevaporation fraction, except when fraction = 100%
!      where( reevap_fraction(:,:,k) < 1. )
!         reevap_fraction(:,:,k) = 0.5*reevap_fraction(:,:,k)
!      end where
    end do
!  cloud liquid water content
!   xliq = 0.5E-3                           !default value
!   if(trim(cloud_param) .eq. 'convect') then
!      xliq = 1.0e-3
!   elseif(trim(cloud_param) .eq. 'lscale') then
!      xliq = 0.5e-3
!   endif

! Lgas = lowercase(scheme)=='henry' .or. lowercase(scheme)=='henry_below' .or. &
!        lowercase(scheme)=='henry_noice' .or. lowercase(scheme)=='henry_below_noice'
! Laerosol = lowercase(scheme)=='aerosol' .or. lowercase(scheme)=='aerosol_below' .or. &
!            lowercase(scheme)=='aerosol_noice' .or. lowercase(scheme)=='aerosol_below_noice'
! Assume that the aerosol reevaporation fraction is 50% of the precip
! reevaporation fraction, except when fraction = 100%
if( Lgas ) then
   frac_int = frac_int_gas
elseif( Laerosol ) then
   frac_int = frac_int_aerosol
else
   frac_int = 1.
end if

if( Lgas .or. Laerosol ) then
! units = VMR
!
! Henry_constant (mole/L/Pa) = [X](aq) / Px(g) 
! where [X](aq) is the concentration of tracer X in precipitation (mole/L)
!       Px(g) is the partial pressure of the tracer in the air (Pa)
!
! VMR (total) = VMR (gas) + VMR (aq)
!             = VMR (gas) + [X] * L
!
! where L = cloud liquid amount (kg H2O/mole air)
!
! Using Henry's Law, [X] = H * Px = H * VMR(gas) * Pfull
!
! So, VMR (total) =  VMR(gas) * [ 1 + H * Pfull * L ]
! 
! VMR(gas) = VMR(total) / [1 + H * Pfull * L]
!
! [X] = H * Pfull * VMR(total) / [ 1 + H * Pfull * L]
!
! Following Giorgi and Chameides, JGR, 90(D5), 1985, the first-order loss
! rate constant (s^-1) of X due to wet deposition equals:
!
! k = W_X / n_X
!
! where W_x = the loss rate (molec/cm3/s), and n_X = the number density (molec/cm3)
! 
! W_X = [X] * W_H2O / (55 mole/L)
! n_x = VMR(total) * n_air (molec/cm3) = VMR(total) * P/(kT) * 1E-6 m3/cm3
! 
! where P = atmospheric pressure (Pa)
!       k = Boltzmann's constant = 1.38E-23 J/K
!       T = temperature (K)
!       W_H2O = removal rate of water (molec/cm3/s)
! 
!             [X] * W_H2O / 55         
! So, k = ------------------------------
!         VMR(total) * P/(kT) * 1E-6
! 
!         W_H2O    H * VMR(total) * P / [ 1 + H * P *L ]
!       = ----- * ---------------------------------------
!          55          VMR(total) * P/(kT) * 1E-6
! 
!         W_H2O     H * kT * 1E6
!       = ----- *  -------------    
!          55      1 + H * P * L 
!
!         W_H2O     1     1     H * P * L
!       = ----- * ----- * - * -------------
!          55     n_air   L   1 + H * P * L
!
! where W_H2O = precip3d (kg/m2/s) * (AVOGNO/mw_h2o) (molec/kg) / zdel (m) * 1E-6 m3/cm3
!
   if( (Lgas .and. Henry_constant > 0) .or. Laerosol ) then
      in_temp(:,:,:) = 0.
      bc_temp(:,:,:) = 0.
      do k=1,kd
! Calculate the temperature dependent Henry's Law constant
         scav_factor(:,:) = 0.0
         xliq(:,:,k)  = MAX( cloud(:,:,k) * mw_air, 0. ) ! (kg H2O)/(mole air)
         n_air(:,:,k) = pfull(:,:,k) / (kboltz*T(:,:,k)) * cm3_2_m3 ! molec/cm3
         if (Lgas) then
            temp_factor(:,:) = 1/T(:,:,k)-inv298p15
            Htemp(:,:,k) = Henry_constant * &
                           exp( Henry_variable*temp_factor )
            f_a(:,:) = Htemp(:,:,k) * pfull(:,:,k) * xliq(:,:,k) ! / cloud_frac
            scav_factor(:,:) = f_a(:,:) / ( 1.+f_a(:,:) )
         else if (Laerosol) then
            scav_factor(:,:) = frac_in_cloud
         end if
!        where (precip3d(:,:,k) > 0.0)
         where (precip3d(:,:,k) > 0. .and. xliq(:,:,k) > 0.)
            w_h2o(:,:) = precip3d(:,:,k) * (AVOGNO/mw_h2o) / zdel(:,:,k) * cm3_2_m3 ! molec/cm3/s
            beta(:,:) = w_h2o(:,:) * mw_h2o  / (n_air(:,:,k) * xliq(:,:,k))
            in_temp(:,:,k) = beta(:,:) * scav_factor(:,:) ! 1/s
           endwhere
      enddo 
!-----------------------------------------------------------------
! Below-cloud wet scavenging
!-----------------------------------------------------------------
      if( lowercase(scheme)=='henry_below' .or. lowercase(scheme)=='henry_below_noice') then
         k_g = d_g/rain_diam * &
               ( 2. + 0.6 * sqrt( rain_diam*rain_vterm/vk_air ) * (vk_air/d_g)**(1./3.) )
         do i = 1,id
         do j = 1,jd
            conc(:) = tracer(i,j,:) * n_air(i,j,:) / cm3_2_m3 ! Convert from VMR to molec/m3
            do kk = 1,kd      
               stay = 1.
               if( precip3d(i,j,kk) > 0. ) then
                  conc_rain_total = 0.
                  stay = zfull(i,j,kk) / (rain_vterm * dt)
                  stay = min( stay, 1. )
                  do k = kk,kd
                     f_a0 = Htemp(i,j,k) * pfull(i,j,k) * xliq(i,j,kk) * n_air(i,j,kk)/n_air(i,j,k)
                     scav_factor0 = f_a0 / ( 1.+f_a0 )
                     conc_sat = conc(k) * scav_factor0 ! molec/m3 <== (xeqca1)
                     sa_drop0 = geo_fac / rain_diam * xliq(i,j,kk) * n_air(i,j,kk) / &
                                ( DENS_H2O * AVOGNO * cm3_2_m3 ) ! (m2 H2O) / (m3 air)
                     fgas0 = conc(k) * k_g ! molec/m2/s
                     fall_time = zdel(i,j,k) / rain_vterm ! sec
                     conc_rain = fgas0 * sa_drop0 * fall_time ! molec/m3 <== (xca1)
                     conc_rain_total = conc_rain_total + conc_rain ! molec/m3 <== (all1)
                     if ( conc_rain_total < conc_sat ) then
                        conc(k) = max( conc(k)-conc_rain, 0. )
                     end if
                  end do
                  conc(kk) = conc(kk) / n_air(i,j,kk) * cm3_2_m3 ! Convert to VMR
                  conc(kk) = tracer(i,j,kk) - conc(kk)
                  if ( conc(kk) /= 0. .and. tracer(i,j,kk) /= 0. ) then
                     fall_time = zdel(i,j,kk)/rain_vterm
                     bc_temp(i,j,kk) = bc_temp(i,j,kk) + &
                                       conc(kk) / (tracer(i,j,kk) * fall_time) * stay ! 1/s
                  end if
               end if         
            end do
         end do
         end do

      else if ( lowercase(scheme) == 'aerosol_below' .or. lowercase(scheme) == 'aerosol_below_noice') then

        do k=1,kd
           fluxs = (snow3d(:,:,k+1)+snow3d(:,:,k))/2.0
           fluxr = (rain3d(:,:,k+1)+rain3d(:,:,k))/2.0
           bc_temp(:,:,k) = 3./4. * &
                       (fluxr(:,:)*alpha_r/R_r/DENS_H2O + &
                        fluxs(:,:)*alpha_s/R_s/DENS_SNOW)
         end do

      end if


      do k = 1,kd
         wdep_in(:,:) = wdep_in(:,:) - &
                        in_temp(:,:,k)*tracer(:,:,k)*pwt(:,:,k)
         wdep_bc(:,:) = wdep_bc(:,:) - &
                        bc_temp(:,:,k)*tracer(:,:,k)*pwt(:,:,k)
      enddo
      dt_temp(:,:,:) = 1. - exp( -bc_temp(:,:,:)*dt ) & ! fractional loss/timestep
                          * ( cloud_frac(:,:,:)*exp( -in_temp(:,:,:)*dt ) + (1-cloud_frac(:,:,:)) )
      tracer_dt(:,:,:) = dt_temp(:,:,:) / dt !+ve loss frequency (1/sec)
    endif

else if(lowercase(scheme)=='fraction') then
   tracer_dt = 0.0
!-----------------------------------------------------------------------
!
!     Compute areal fractions experiencing wet deposition:
!
!     Set minimum precipitation rate below which no wet removal
!     occurs to 0.01 cm/day ie 1.16e-6 mm/sec (kg/m2/s)
   premin=1.16e-6
!
!     Large scale cloud liquid water content (kg/m3)
!     and below cloud washout efficiency (cm-1):
   flaglw =parse(control,'lslwc',clwc)
   if (flaglw == 0 ) clwc=0.5e-3
   wash=1.0  
!
!     When convective adjustment occurs, use convective cloud liquid water content:
!
    if(trim(cloud_param) .eq. 'convect') then
      flaglw = parse(control,'convlwc',clwc)
      if (flaglw == 0) clwc=2.0e-3
      wash=0.3 
   end if
!
   do j=1,size(rain,2)
   do i=1,size(rain,1)
      tracer_dt(i,j,:)=0.0
      washout(i,j)=0.0
      prenow = rain(i,j) + snow(i,j)
      if(prenow .gt. premin) then      
!
! Assume that the top of the cloud is where the highest model level 
! specific humidity is reduced. And the the bottom of the cloud is the
! lowest model level where specific humidity is reduced.
!
         ktopcd(i,j) = 0
         do k = kd,1,-1
            if (qdt(i,j,k) < 0.0 ) ktopcd(i,j) = k
         enddo
         kendcd(i,j) = 0
         do k = 1,kd
            if (qdt(i,j,k) < 0.0 ) kendcd(i,j) = k
         enddo
!
!     Thickness of precipitating cloud deck:
!
         if(ktopcd(i,j).gt.1) then
            hwtop = 0.0
            do k=ktopcd(i,j),kendcd(i,j)
               hwtop=hwtop+(phalf(i,j,k+1)-phalf(i,j,k))*rdgas*T(i,j,k)/grav/pfull(i,j,k)
            enddo
            do k=ktopcd(i,j),kendcd(i,j)
!     Areal fraction affected by precip clouds (max = 0.5):
               tracer_dt(i,j,k)=prenow/(clwc*hwtop)
            end do  
          endif

         washout(i,j)=prenow*wash
          endif
   end do
   end do
          endif

! Now multiply by the tracer mixing ratio to get the actual tendency.
tracer_dt(:,:,:) = MIN( MAX(tracer_dt(:,:,:), 0.0E+00), 0.5/dt)
where (tracer > 0.)
   tracer_dt = tracer_dt*tracer
else where
   tracer_dt = 0.
end where

!++lwh
!
! Re-evaporation
!
do k = 1,kd
   where (reevap_fraction(:,:,k) > 0.) 
      reevap_diag(:,:,k) = reevap_fraction(:,:,k) * tracer_flux(:,:)
! tracer reevaporation fraction is reduced from precip reevaporation,
! except when complete reevaporation occurs
      where( reevap_fraction(:,:,k) < 1. )
         reevap_diag(:,:,k) = reevap_diag(:,:,k) * frac_int
      end where
      tracer_dt(:,:,k) = tracer_dt(:,:,k) - reevap_diag(:,:,k) / pwt(:,:,k)
   end where
   tracer_flux(:,:) = tracer_flux(:,:) + tracer_dt(:,:,k)*pwt(:,:,k)
end do
!--lwh
!
endif ! End branching pag/lwh
!
! Output diagnostics in kg/m2/s (if MMR) or mole/m2/s (if VMR)
if(trim(units) .eq. 'mmr') then
   diag_scale = 1.
        elseif(trim(units) .eq. 'vmr') then
   diag_scale = mw_air ! kg/mole
else
   write(*,*) ' Tracer number =',n,' tracer_name=',tracer_name
   write(*,*) ' scheme=',text_in_scheme
   write(*,*) ' control=',control
   write(*,*) ' scheme=',scheme
   write(*,*) 'Please check field table'
   write(*,*) 'tracers units =',trim(units),'it should be either  mmr or vmr!'
!  <ERROR MSG="Unsupported tracer units" STATUS="FATAL">
!     Tracer units must be either VMR or MMR
!  </ERROR>
   call error_mesg('wet_deposition', 'Unsupported tracer units.', FATAL )
          endif


! Column integral of wet deposition
sum_wdep = 0.
do k=1,kd
   sum_wdep = sum_wdep + tracer_dt(:,:,k)*pwt(:,:,k)/diag_scale
end do

if (present (sum_wdep_out))  sum_wdep_out = sum_wdep

if(trim(cloud_param) == 'lscale') then
   if (id_tracer_reevap_ls(n) > 0 ) then
      used = send_data ( id_tracer_reevap_ls(n), reevap_diag/diag_scale, Time ,is,js,1)
   endif
   if (id_tracer_wdep_ls(n) > 0 ) then
      used = send_data ( id_tracer_wdep_ls(n), sum_wdep, Time, is_in =is, js_in=js )
   endif
   if (id_tracer_wdep_lsin(n) > 0 ) then
       used = send_data ( id_tracer_wdep_lsin(n), wdep_in/diag_scale, Time, is_in=is, js_in=js )
   endif
   if (id_tracer_wdep_lsbc(n) > 0 ) then
      used = send_data ( id_tracer_wdep_lsbc(n), wdep_bc/diag_scale, Time, is_in=is, js_in=js )
   endif

else if(trim(cloud_param) == 'convect') then
   if (id_tracer_reevap_cv(n) > 0 ) then
      used = send_data ( id_tracer_reevap_cv(n), reevap_diag/diag_scale, Time ,is,js,1)
   endif
   if(id_tracer_wdep_cv(n) > 0) then
      used = send_data( id_tracer_wdep_cv(n), sum_wdep, Time, is_in=is, js_in=js)
   endif
   if (id_tracer_wdep_cvin(n) > 0 ) then
       used = send_data ( id_tracer_wdep_cvin(n), wdep_in/diag_scale, Time, is_in=is, js_in=js)
   endif
   if (id_tracer_wdep_cvbc(n) > 0 ) then
      used = send_data ( id_tracer_wdep_cvbc(n), wdep_bc/diag_scale, Time, is_in=is, js_in=js)
   endif
endif

end subroutine wet_deposition
!</SUBROUTINE>
!
!#######################################################################
!
subroutine get_drydep_param(text_in_scheme,text_in_param,scheme,land_dry_dep_vel,sea_dry_dep_vel)
!
! Subroutine to initialiize the parameters for the dry deposition scheme.
! If the dry dep scheme is 'fixed' then the dry_deposition velocity value
! has to be set.
! If the dry dep scheme is 'wind_driven' then the dry_deposition
! velocity value will be calculated. So set to a dummy value of 0.0
! INTENT IN
!  text_in_scheme   : The text that has been parsed from tracer table as 
!                     the dry deposition scheme to be used.
!  text_in_param    : The parameters that are associated with the dry 
!                     deposition scheme.
! INTENT OUT
!  scheme           : The scheme that is being used.
!  land_dry_dep_vel : Dry deposition velocity over the land
!  sea_dry_dep_vel  : Dry deposition velocity over the sea
!
character(len=*), intent(in)    :: text_in_scheme, text_in_param
character(len=*), intent(out)   :: scheme
real, intent(out)               :: land_dry_dep_vel, sea_dry_dep_vel

integer :: flag

!Default
scheme                  = 'None'
land_dry_dep_vel=0.0
sea_dry_dep_vel=0.0

if(lowercase(trim(text_in_scheme(1:4))).eq.'wind') then
scheme                  = 'Wind_driven'
land_dry_dep_vel=0.0
sea_dry_dep_vel=0.0
endif

if(lowercase(trim(text_in_scheme(1:5))).eq.'fixed') then
scheme                 = 'fixed'
flag=parse(text_in_param,'land',land_dry_dep_vel)
flag=parse(text_in_param,'sea', sea_dry_dep_vel)
endif

if(lowercase(trim(text_in_scheme(1:4))).eq.'file') then
   scheme = 'file'
   land_dry_dep_vel = 0.
   sea_dry_dep_vel=0.
endif

end subroutine get_drydep_param
!
!#######################################################################
!
!<SUBROUTINE NAME="get_wetdep_param">
!<TEMPLATE>
!CALL get_wetdep_param(text_in_scheme, text_in_param, scheme,&
!                      henry_constant, henry_temp, &
!                      frac_in_cloud, alpha_r, alpha_s)
!</TEMPLATE>
subroutine get_wetdep_param(text_in_scheme,text_in_param,scheme,&
                            henry_constant, henry_temp, &
                            frac_in_cloud,alpha_r,alpha_s, &
                            Lwetdep, Lgas, Laerosol, Lice, &
                            frac_in_cloud_uw, frac_in_cloud_donner)
!<OVERVIEW>
! Routine to initialize the parameters for the wet deposition scheme.
!</OVERVIEW>
!
! shm has modified this subroutine to include additional parameters:
!      frac_in_cloud, alpha_r, and alpha_s
!
! INTENT IN
!<IN NAME="text_in_scheme" TYPE="character">
!   Text read from the tracer table which provides information on which
!                   wet deposition scheme to use.
!</IN>
!<IN NAME="text_in_param" TYPE="character">
!   Parameters associated with the wet deposition scheme. These will be
!                   parsed in this routine.
!</IN>
!<OUT NAME="scheme" TYPE="character">
!   Wet deposition scheme to use.
!   Choices are: None, Fraction, Henry, Henry_below, Aerosol, Aerosol_below,
!                wdep_aerosol, wdep_gas
!</OUT>
!<OUT NAME="henry_constant" TYPE="real">
!   Henry's Law constant for the tracer (see wet_deposition for explanation of Henry's Law)
!</OUT>
!<OUT NAME="henry_temp" TYPE="real">
!   The temperature dependence of the Henry's Law constant.
!</OUT>
!<OUT NAME="frac_in_cloud" TYPE="real">
!   In-cloud fraction for aerosols
!</OUT>
!<OUT NAME="alpha_r" TYPE="real">
!   Controls below-cloud aerosol scavenging by rain
!</OUT>
!<OUT NAME="alpha_s" TYPE="real">
!   Controls below-cloud aerosol scavenging by snow
!</OUT>
!<OUT NAME="Lwetdep" TYPE="logical">
!   Does tracer have wet removal?
!</OUT>
!<OUT NAME="Lgas" TYPE="logical">
!   Is tracer a gas?
!</OUT>
!<OUT NAME="Laerosol" TYPE="logical">
!   Is tracer an aerosol?
!</OUT>
!<OUT NAME="Lice" TYPE="logical">
!   Is tracer removed by snow (or just rain)?
!</OUT>


character(len=*), intent(in)    :: text_in_scheme, text_in_param
character(len=*), intent(out)   :: scheme
real, intent(out)               :: henry_constant, henry_temp
real, intent(out)               :: frac_in_cloud, alpha_r, alpha_s
logical, intent(out)            :: Lwetdep, Lgas, Laerosol, Lice
real, intent(out), optional     :: frac_in_cloud_uw, frac_in_cloud_donner

integer :: flag

!Default
scheme                  = 'None'
henry_constant= 0.
henry_temp    = 0.
frac_in_cloud = 0.
alpha_r       = 0.
alpha_s       = 0.
Lwetdep = .false.
Lgas = .false.
Laerosol = .false.

if (present(frac_in_cloud_uw))     frac_in_cloud_uw = 0.
if (present(frac_in_cloud_donner)) frac_in_cloud_donner = 0.

if( trim(lowercase(text_in_scheme)) == 'fraction' ) then
   scheme                 = 'Fraction'
else if( trim(lowercase(text_in_scheme)) == 'henry' .or. &
         trim(lowercase(text_in_scheme)) == 'henry_below' .or. &
         trim(lowercase(text_in_scheme)) == 'henry_noice' .or. &
         trim(lowercase(text_in_scheme)) == 'henry_below_noice' ) then
   if( trim(lowercase(text_in_scheme)) == 'henry' ) then
      scheme                 = 'henry'
   else if ( trim(lowercase(text_in_scheme)) == 'henry_below' ) then
      scheme                 = 'henry_below'
   else if ( trim(lowercase(text_in_scheme)) == 'henry_noice' ) then
      scheme                 = 'henry_noice'
   else if ( trim(lowercase(text_in_scheme)) == 'henry_below_noice' ) then
      scheme                 = 'henry_below_noice'
   end  if
   flag=parse(text_in_param,'henry',     henry_constant)
   flag=parse(text_in_param,'dependence',henry_temp    )
   Lgas = .true.
else if( trim(lowercase(text_in_scheme)) == 'aerosol' .or. &
         trim(lowercase(text_in_scheme)) == 'aerosol_below' .or. &
         trim(lowercase(text_in_scheme)) == 'aerosol_noice' .or. &
         trim(lowercase(text_in_scheme)) == 'aerosol_below_noice' ) then
   if( trim(lowercase(text_in_scheme)) == 'aerosol' ) then
      scheme                 = 'aerosol'
   else if ( trim(lowercase(text_in_scheme)) == 'aerosol_below' ) then
      scheme                 = 'aerosol_below'
   else if ( trim(lowercase(text_in_scheme)) == 'aerosol_noice' ) then
      scheme                 = 'aerosol_noice'
   else if ( trim(lowercase(text_in_scheme)) == 'aerosol_below_noice' ) then
      scheme                 = 'aerosol_below_noice'
   end if
   flag=parse(text_in_param,'frac_incloud',frac_in_cloud)
   if (present(frac_in_cloud_uw)) then
      flag=parse(text_in_param,'frac_incloud_uw',frac_in_cloud_uw)
      if (flag == 0) then
         frac_in_cloud_uw = frac_in_cloud
      end if
   end if
   if (present(frac_in_cloud_donner)) then
      flag=parse(text_in_param,'frac_incloud_donner',   &
                                                frac_in_cloud_donner)
      if (flag == 0) then
         frac_in_cloud_donner = frac_in_cloud
      end if
   end if
   flag=parse(text_in_param,'alphar',alpha_r)
   flag=parse(text_in_param,'alphas',alpha_s)
   Laerosol = .true.
end if
if( trim(lowercase(text_in_scheme)) == 'wdep_aerosol') scheme= 'wdep_aerosol'
if ( trim(lowercase(text_in_scheme)) == 'wdep_gas' ) scheme= 'wdep_gas'
if (scheme .eq. 'wdep_aerosol' .or. scheme .eq. 'wdep_gas') then
   flag=parse(text_in_param,'frac_incloud',frac_in_cloud)
   flag=parse(text_in_param,'alphar',alpha_r)
   flag=parse(text_in_param,'alphas',alpha_s)
end if

Lice = .not. ( scheme=='henry_noice' .or. scheme=='henry_below_noice' .or. &
               scheme=='aerosol_noice' .or. scheme=='aerosol_below_noice' )
Lwetdep = scheme /= 'None'

end subroutine get_wetdep_param
!</SUBROUTINE>
!
!#######################################################################
!
!<SUBROUTINE NAME="interp_emiss">
subroutine interp_emiss(global_source, start_lon, start_lat, &
                        lon_resol, lat_resol, data_out)
!
!<OVERVIEW>
! A routine to interpolate emission fields of arbitrary resolution onto the 
! resolution of the model.
!</OVERVIEW>
!<DESCRIPTION>
! Routine to interpolate emission fields (or any 2D field) to the model 
! resolution. The local section of the global field is returned to the 
! local processor.
!</DESCRIPTION>
! 
!<TEMPLATE>
! call interp_emiss(global_source, start_lon, start_lat, &
!                        lon_resol, lat_resol, data_out)
!</TEMPLATE>
! INTENT IN
!<IN NAME="global_source" TYPE="real" DIM="(:,:)">
!  Global emission field.
!</IN>
!<IN NAME="start_lon" TYPE="real">
!  Longitude of starting point of emission field 
!  (in radians). This is the westernmost boundary of the 
!  global field.
!</IN>
!<IN NAME="start_lat" TYPE="real">
!  Latitude of starting point of emission field
!  (in radians). This is the southern boundary of the 
!  global field.
!</IN>
!<IN NAME="lon_resol" TYPE="real">
!  Longitudinal resolution of the emission data (in radians).
!</IN>
!<IN NAME="lat_resol" TYPE="real">
!  Latitudinal resolution of the emission data (in radians).
!</IN>
! 
! INTENT OUT
!<OUT NAME="data_out" TYPE="real" DIM="(:,:)">
!  Interpolated emission field on the local PE. 
!</OUT>

real, intent(in)  :: global_source(:,:)
real, intent(in)  :: start_lon,start_lat,lon_resol,lat_resol
real, intent(out) :: data_out(:,:)

integer :: i, j, nlon_in, nlat_in
real :: blon_in(size(global_source,1)+1)
real :: blat_in(size(global_source,2)+1)
type (horiz_interp_type) :: Interp
! Set up the global surface boundary condition longitude-latitude boundary values

   nlon_in = size(global_source,1)
   nlat_in = size(global_source,2)
! For some reason the input longitude needs to be incremented by 180 degrees.
   do i = 1, nlon_in+1
      blon_in(i) = start_lon + float(i-1)*lon_resol + PI
   enddo
      if (abs(blon_in(nlon_in+1)-blon_in(1)-twopi) < epsilon(blon_in)) &
              blon_in(nlon_in+1)=blon_in(1)+twopi

   do j = 2, nlat_in
      blat_in(j) = start_lat + float(j-1)*lat_resol
   enddo
      blat_in(1)         = -0.5*PI
      blat_in(nlat_in+1) =  0.5*PI

! Now interpolate the global data to the model resolution
   call horiz_interp_init
   call horiz_interp_new (Interp, blon_in, blat_in, &
                                  blon_out, blat_out)
   call horiz_interp (Interp, global_source, data_out)
   call horiz_interp_del ( Interp )


end subroutine interp_emiss
!</SUBROUTINE>
! ######################################################################
!

      subroutine GET_RH (T,Q,P,RH,mask)
!***********************************************************************
!  SUBROUTINE GET_RH
!  PURPOSE
!     VECTOR COMPUTATION OF RELATIVE HUMIDITY
!  DESCRIPTION OF PARAMETERS
!     T        TEMPERATURE VECTOR (DEG K)
!     P        PRESSURE VECTOR (Pa)
!     Q        SPECIFIC HUMIDITY (kg/kg)
!     RH       RELATIVE HUMIDITY
!     MASK     EARTH SURFACE BELOW GROUND (in pressure coordinates)
!
!***********************************************************************
!

      Real, parameter :: ONE    = 1.
      Real, parameter :: ZP622  = 0.622
      Real, parameter :: Z1P0S1 = 1.00001
      Real, parameter :: Z1P622 = 1.622
      Real, parameter :: Z138P9 = 138.90001
      Real, parameter :: Z198P9 = 198.99999
      Real, parameter :: Z200   = 200.0
      Real, parameter :: Z337P9 = 337.9

      real, intent(in), dimension(:,:,:) :: T !temp at curr time step [ deg k ]
      real, intent(in), dimension(:,:,:) :: P !pressure at full levels [ Pa ]
      real, intent(in), dimension(:,:,:) :: Q !specific humidity at current time step  [ kg / kg ]
      real, intent(in), dimension(:,:,:), optional :: mask !
      real, intent(out), dimension(:,:,:) :: RH !relative humidity [0-1]

! Dynamic Work Space
! ------------------
      real :: A1622
      real, dimension(size(q,1),size(q,2),size(q,3)) :: e1, e2, tq, qs
      integer, dimension(size(q,1),size(q,2),size(q,3)) :: i1, i2
      integer :: i,j,k

!
      real, dimension(67) :: EST1
      data EST1/       0.31195E-02, 0.36135E-02, 0.41800E-02, &
          0.48227E-02, 0.55571E-02, 0.63934E-02, 0.73433E-02, &
          0.84286E-02, 0.96407E-02, 0.11014E-01, 0.12582E-01, &
          0.14353E-01, 0.16341E-01, 0.18574E-01, 0.21095E-01, &
          0.23926E-01, 0.27096E-01, 0.30652E-01, 0.34629E-01, &
          0.39073E-01, 0.44028E-01, 0.49546E-01, 0.55691E-01, &
          0.62508E-01, 0.70077E-01, 0.78700E-01, 0.88128E-01, &
          0.98477E-01, 0.10983E+00, 0.12233E+00, 0.13608E+00, &
          0.15121E+00, 0.16784E+00, 0.18615E+00, 0.20627E+00, &
          0.22837E+00, 0.25263E+00, 0.27923E+00, 0.30838E+00, &
          0.34030E+00, 0.37520E+00, 0.41334E+00, 0.45497E+00, &
          0.50037E+00, 0.54984E+00, 0.60369E+00, 0.66225E+00, &
          0.72589E+00, 0.79497E+00, 0.86991E+00, 0.95113E+00, &
          0.10391E+01, 0.11343E+01, 0.12372E+01, 0.13484E+01, &
          0.14684E+01, 0.15979E+01, 0.17375E+01, 0.18879E+01, &
          0.20499E+01, 0.22241E+01, 0.24113E+01, 0.26126E+01, &
          0.28286E+01, 0.30604E+01, 0.33091E+01, 0.35755E+01/
!
      real, dimension(72)  :: EST2
      data EST2/ &
          0.38608E+01, 0.41663E+01, 0.44930E+01, 0.48423E+01, &
          0.52155E+01, 0.56140E+01, 0.60394E+01, 0.64930E+01, &
          0.69767E+01, 0.74919E+01, 0.80406E+01, 0.86246E+01, &
          0.92457E+01, 0.99061E+01, 0.10608E+02, 0.11353E+02, &
          0.12144E+02, 0.12983E+02, 0.13873E+02, 0.14816E+02, &
          0.15815E+02, 0.16872E+02, 0.17992E+02, 0.19176E+02, &
          0.20428E+02, 0.21750E+02, 0.23148E+02, 0.24623E+02, &
          0.26180E+02, 0.27822E+02, 0.29553E+02, 0.31378E+02, &
          0.33300E+02, 0.35324E+02, 0.37454E+02, 0.39696E+02, &
          0.42053E+02, 0.44531E+02, 0.47134E+02, 0.49869E+02, &
          0.52741E+02, 0.55754E+02, 0.58916E+02, 0.62232E+02, &
          0.65708E+02, 0.69351E+02, 0.73168E+02, 0.77164E+02, &
          0.81348E+02, 0.85725E+02, 0.90305E+02, 0.95094E+02, &
          0.10010E+03, 0.10533E+03, 0.11080E+03, 0.11650E+03, &
          0.12246E+03, 0.12868E+03, 0.13517E+03, 0.14193E+03, &
          0.14899E+03, 0.15634E+03, 0.16400E+03, 0.17199E+03, &
          0.18030E+03, 0.18895E+03, 0.19796E+03, 0.20733E+03, &
          0.21708E+03, 0.22722E+03, 0.23776E+03, 0.24871E+03/
!
      real, dimension(139) :: EST
      EQUIVALENCE (EST(1)  , EST1(1)), (EST(68),EST2(1))
!***********************************************************************
!
      A1622   = ONE  / Z1P622
      TQ = T - Z198P9
      I1(:,:,:) = 1
      I2(:,:,:) = 1
      where ( T < Z200 ) TQ = Z1P0S1
      where ( T > Z337P9 ) TQ = Z138P9
      IF (present(mask)) THEN
        where ( mask > 0. )
          I1 = int(TQ)
          I2 = I1 + 1
        end where
      else
        I1 = int(TQ)
        I2 = I1 + 1
      endif
      do i=1,size(q,1)
        do j=1,size(q,2)
          do k=1,size(q,3)
            E1(i,j,k) =  EST( I1(i,j,k) )
            E2(i,j,k) =  EST( I2(i,j,k) )
          enddo
        enddo
     enddo
      QS(:,:,:) = TQ(:,:,:) - float(I1(:,:,:))
      QS(:,:,:) = E1(:,:,:) + QS(:,:,:) * ( E2(:,:,:)-E1(:,:,:) )
      E1(:,:,:) = (0.01 * P(:,:,:)) * A1622
      where ( E1 < QS ) QS = E1
      if (present(mask)) then
        where ( mask > 0. )  QS = ZP622 * QS / ( P * 0.01)
      else
        QS(:,:,:) = ZP622 * QS(:,:,:) / ( P(:,:,:) * 0.01)
      endif
      RH(:,:,:) = Q(:,:,:)/QS(:,:,:)

end subroutine GET_RH

! ######################################################################
!
subroutine get_w10m(z_full, u, v, rough_mom,u_star, b_star, q_star, &
       w10m_ocean, w10m_land, Time, is,js)

real, intent(in),    dimension(:,:) :: z_full, u, v
real, intent(in),    dimension(:,:)   :: rough_mom
real, intent(in),    dimension(:,:)   :: u_star, b_star, q_star
type(time_type), intent(in)           :: Time
integer, intent(in)                   :: is,js

logical :: used

real, intent(out),   dimension(:,:)   :: w10m_ocean, w10m_land
real, dimension(size(u,1),size(u,2)) ::  del_m
real, dimension(size(u,1),size(u,2)) ::  del_h
real, dimension(size(u,1),size(u,2)) ::  del_q
! Reference heights for momentum and heat [m]
real, parameter :: zrefm = 10.
real, parameter :: zrefh = 2.
real, parameter :: scaling_factor=1.

     w10m_ocean(:,:)    = 0.0
     w10m_land (:,:)    = 0.0
     del_m(:,:)   = 0.0

      call mo_profile(zrefm, zrefh, z_full, &
           rough_mom, rough_mom, rough_mom, &
           u_star, b_star, q_star, &
           del_m, del_h, del_q )
!-----------------------------------------------------------------
!       ... Wind speed at anemometer level (10 meters above ground)
!-----------------------------------------------------------------
      w10m_ocean(:,:)=sqrt(u(:,:)**2 +v(:,:)**2 )*del_m(:,:)
      w10m_land (:,:)=sqrt(u(:,:)**2 +v(:,:)**2 )*del_m(:,:)*scaling_factor

! Send the scaling factor
      if (id_delm > 0 ) then
        used = send_data ( id_delm, del_m, Time, is_in=is,js_in=js )
      endif

! Send the 10m wind speed data to the diag_manager for output.
      if (id_w10m > 0 ) then
        used = send_data ( id_w10m, w10m_land, Time, is_in=is,js_in=js )
      endif

end subroutine get_w10m

! ######################################################################
!
subroutine get_cldf(ps, pfull, rh, cldf)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!
!!! This subroutine estimates the cloud fraction "cldf" for
!!! each grid box using an empirical function of the relative
!!! humidity in that grid box, following Sundqvist et al., Mon. Weather Rev.,
!!! v117, 164101657, 1989:
!!!
!!!             cldf = 1 - sqrt[ 1 - (RH - RH0)/(1 - RH0) ]
!!!
!!! where RH is the relative humidity and RH0 is the threshold relative
!!! humidity for condensation specified as a function of pressure based
!!! on Xu and Krueger, Mon. Weather Rev., v119, 342-367, 1991.
!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      real, intent(in),  dimension(:,:)   :: ps
      real, intent(in),  dimension(:,:,:) :: pfull
      real, intent(in),  dimension(:,:,:) :: rh
      real, intent(out), dimension(:,:,:) :: cldf
      real, parameter :: zrt = 0.6
      real, parameter :: zrs = 0.99
      integer           :: i,j,k, id, jd, kd
      real              :: p, r, r0, b0
      id=size(pfull,1); jd=size(pfull,2); kd=size(pfull,3)

      do k = 1, kd
      do j = 1, jd
      do i = 1, id
       P = pfull(i,j,k)
       R = RH(i,j,k)
       R0 = ZRT + (ZRS-ZRT) * exp(1.-(PS(i,j)/P)**2.5)
       B0 = (R-R0) / (1.-R0)
       if (R .lt.R0) B0 = 0.
       if (B0.gt.1.) B0 = 1.
       CLDF(i,j,k) = 1.-sqrt(1.-B0)
      end do
      end do
      end do

end subroutine get_cldf

!######################################################################
!<SUBROUTINE NAME="tracer_utilities_end">
!<OVERVIEW>
!  The destructor routine for the tracer utilities module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits. 
! </DESCRIPTION>

subroutine atmos_tracer_utilities_end
 

   deallocate(blon_out, blat_out)
   module_is_initialized = .FALSE.

 end subroutine atmos_tracer_utilities_end
!</SUBROUTINE>

! ######################################################################
! !IROUTINE: sjl_fillz --- Fill from neighbors below and above
!
! !INTERFACE:
 subroutine sjl_fillz(im, km, nq, q, dp)

 implicit none

! !INPUT PARAMETERS:
   integer,  intent(in):: im                ! No. of longitudes
   integer,  intent(in):: km                ! No. of levels
   integer,  intent(in):: nq                ! Total number of tracers

   real, intent(in)::  dp(im,km)       ! pressure thickness
! !INPUT/OUTPUT PARAMETERS:
   real, intent(inout) :: q(im,km,nq)   ! tracer mixing ratio

! !DESCRIPTION:
!   Check for "bad" data and fill from east and west neighbors
!
! !BUGS:
!   Currently this routine only performs the east-west fill algorithm.
!   This is because the N-S fill is very hard to do in a reproducible
!   fashion when the problem is decomposed by latitudes.
!
! !REVISION HISTORY:
!   00.04.01   Lin        Creation
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
   integer i, k, ic
   real qup, qly, dup

   do ic=1,nq
! Top layer
      do i=1,im
         if( q(i,1,ic) < 0.) then
             q(i,2,ic) = q(i,2,ic) + q(i,1,ic)*dp(i,1)/dp(i,2)
             q(i,1,ic) = 0.
          endif
      enddo

! Interior
      do k=2,km-1
         do i=1,im
         if( q(i,k,ic) < 0. ) then
! Borrow from above
             qup =  q(i,k-1,ic)*dp(i,k-1)
             qly = -q(i,k  ,ic)*dp(i,k  )
             dup =  min( 0.75*qly, qup )        !borrow no more than 75% from top
             q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1)
! Borrow from below: q(i,k,ic) is still negative at this stage
             q(i,k+1,ic) = q(i,k+1,ic) + (dup-qly)/dp(i,k+1)
             q(i,k  ,ic) = 0.
          endif
          enddo
      enddo

! Bottom layer
      k = km
      do i=1,im
         if( q(i,k,ic) < 0.) then
! Borrow from above
             qup =  q(i,k-1,ic)*dp(i,k-1)
             qly = -q(i,k  ,ic)*dp(i,k  )
             dup =  min( qly, qup )
             q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1)
             q(i,k,ic) = 0.
          endif
      enddo
   enddo
end subroutine sjl_fillz

end module atmos_tracer_utilities_mod


        module aer_ccn_act_mod

use fms_mod,             only: error_mesg, FATAL, open_namelist_file, &
                               mpp_pe, mpp_root_pe, stdlog, &
                               file_exist, write_version_number, &
                               check_nml_error, close_file
use mpp_mod,             only: input_nml_file, get_unit
use aer_ccn_act_k_mod,   only: aer_ccn_act_k, aer_ccn_act2_k, &
                               aer_ccn_act_wpdf_k, aer_ccn_act_k_init, &
                               aer_ccn_act_k_end

implicit none
private
    private Loading
      
    public aer_ccn_act, aer_ccn_act2, aer_ccn_act_wpdf, &
           aer_ccn_act_init, aer_ccn_act_end

!--------------------- version number ---------------------------------

character(len=128) :: version = '$Id: aer_ccn_act.F90,v 18.0.2.1 2010/08/30 20:39:47 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!---------------- private data -------------------


!-----------------------------------------------------------------------
!-------------------- namelist -----------------------------------------

logical  :: nooc = .false.   ! include organic aerosols as ccns ?
real     :: sul_concen = 0.1
real     :: low_concen = 0.1
real     :: high_concen = 1.
 !Parameters for look-up tables
 
real ::  lowup=0.3 !m/s
real ::  highup=10.

! earlier values: lowup2 = 0.001, highmass2 = 1000., highmass3 = 1000.
!real ::  lowup2=0.0001 !m/s
real ::  lowup2=0.01   !m/s
real ::  highup2=0.3
real ::  lowmass2=0.01 !ug m-3
!real ::  highmass2=1000.
real ::  highmass2=100.
real ::  lowmass3=0.01 !ug m-3
!real ::  highmass3=1000.
real ::  highmass3=100.
real ::  lowmass4=0.01 !ug m-3
real ::  highmass4=100.
real ::  lowmass5=0.01 !ug m-3
real ::  highmass5=100.
real :: lowT2=243.15 !K
real :: highT2=308.15

namelist /aer_ccn_act_nml/ nooc, sul_concen, low_concen, high_concen, &
                           lowup, highup, lowup2, highup2, lowmass2, &
                           highmass2, lowmass3, highmass3,  &
                           lowmass4, highmass4, lowmass5, highmass5, &
                           lowT2, highT2


logical :: module_is_initialized  = .false.
 
contains

subroutine aer_ccn_act (T1, P1, Updraft1, TotalMass, Drop)
real, dimension(:), intent(inout) :: TotalMass
real, intent(in) :: T1, P1, Updraft1
real, intent(inout) :: Drop
    
  integer :: tym, ier
  character(len=256) :: ermesg

  if(.not. module_is_initialized) call aer_ccn_act_init()

  tym = size (totalmass,1)

  call aer_ccn_act_k (T1, P1, Updraft1, TotalMass, tym, Drop, ier,  &
                      ermesg)
  if (ier /= 0) call error_mesg ('aer_ccn_act', ermesg, FATAL)

  
end subroutine aer_ccn_act

subroutine aer_ccn_act2 (T1, P1, Updraft1, TotalMass, mu,airdens,Nc,qc,qt,qe,tc,te,Drop)

!T1 temperature (K)
!P1 pressure (Pa)
!Updraft1 updraft velocity (m/s)
!TotalMass aerosol mass ()
!mu entrainment coef. (/s)
!airdens air density (kg/m3 air)
!Nc droplet mixing ratio (#/kg air)
!qc in-cloud vapor mixing ratio (kg water/kg air)
!qt in-cloud total water mixing ratio qc + ql (kg water/kg air)
!qe environment vapor mixing ratio (kg water/kg air)
!tc in-cloud temperature (K)
!te environment temperature (K)
!Drop droplet number concentration (#/cc)

real, dimension(:), intent(in) :: TotalMass
real, intent(in) :: T1, P1, Updraft1, mu,airdens, Nc, qc, qt, qe, tc, te
real, intent(inout) :: Drop

  integer :: tym, ier
  character(len=256) :: ermesg
        
  if(.not. module_is_initialized) call aer_ccn_act_init()
  tym = size (totalmass,1)

  call aer_ccn_act2_k (T1, P1, Updraft1, TotalMass, tym, mu,  &
                       airdens,Nc,qc,qt,qe,tc,te,Drop, ier, ermesg)
  if (ier /= 0) call error_mesg ('aer_ccn_act2', ermesg, FATAL)

end subroutine aer_ccn_act2

!-->cjg: addition
!
! Additional subroutines to compute CCN activation by integrating
! over an assumed subgrid-scale PDF of w

subroutine aer_ccn_act_wpdf(T, p, wm, wp2, totalmass, drop)

! Compute CCN activation assuming a normal distribution of w
! given by its mean (wm) and second moment (wp2)

real, intent(in)    :: T, p, wm, wp2
real, intent(inout) :: totalmass(4)
real, intent(out)   :: drop

  integer :: tym, ier
  character(len=256) :: ermesg

  if(.not. module_is_initialized) call aer_ccn_act_init()
  tym = size (totalmass,1)

   call aer_ccn_act_wpdf_k (T, p, wm, wp2, totalmass, tym,           &
                            drop, ier, ermesg)
  if (ier /= 0) call error_mesg ('aer_ccn_act_wpdf', ermesg, FATAL)

end subroutine aer_ccn_act_wpdf


subroutine aer_ccn_act_init ()

!--------------------------------------------------------------------  
!  local variables:
      
      integer   ::   unit, ierr, io, logunit
      integer, parameter :: res = 20 !
      real, dimension(res,res,res,res,res) :: droplets

      integer, parameter :: res2 = 20 !
      real, dimension(res2,res2,res2,res2,res2) :: droplets2

      if (module_is_initialized) return

!--------------------------------------------------------------------- 
!    read namelist.
!--------------------------------------------------------------------
      if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=aer_ccn_act_nml, iostat=io)
        ierr = check_nml_error(io,'aer_ccn_act_nmliostat=io')
#else
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=aer_ccn_act_nml, iostat=io,  &
               end=10)
        ierr = check_nml_error(io,'aer_ccn_act_nml')
        end do
10      call close_file (unit)   
#endif
      endif                      
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!--------------------------------------------------------------------
       call write_version_number (version, tagname)
       logunit=stdlog()
       if (mpp_pe() == mpp_root_pe() ) &
                        write (logunit, nml=aer_ccn_act_nml)

       call Loading( droplets, droplets2)

       call aer_ccn_act_k_init (droplets,   &
                      droplets2, res, res2, nooc,  &
                       sul_concen, low_concen, high_concen, &
                       lowup, highup, lowup2, highup2, lowmass2, &
                       highmass2, lowmass3, highmass3,  &
                       lowmass4, highmass4, lowmass5, highmass5, &
                      lowT2, highT2  )
       module_is_initialized  = .true.

end subroutine aer_ccn_act_init


subroutine Loading(droplets, droplets2)

real, dimension(:,:,:,:,:), intent(out) :: droplets, droplets2
real xx
integer i, j, k, l, m, unit
integer res, res2

  res = size(droplets,1)
  res2 = size(droplets2,1)
  unit = get_unit()
  open(unit, FILE='INPUT/droplets.dat')
  do k=1,res
    do i=1,res
      do j=1, res
        do l=1, res
        do m=1, res
          read(unit,*) xx
          droplets(m,l,j,i,k)=xx
        end do
        end do
      end do
    end do
  end do
  close(unit)

  unit = get_unit()
  open(unit, FILE='INPUT/droplets2.dat')
  do k=1,res2
    do i=1,res2
      do j=1, res2
        do l=1, res2
        do m=1, res2
          read(unit,*) xx
          droplets2(m,l,j,i,k)=xx
        end do
        end do
      end do
    end do
  end do
  close(unit)

end subroutine Loading


subroutine aer_ccn_act_end()

  call aer_ccn_act_k_end 
  module_is_initialized  = .false.

end subroutine aer_ccn_act_end

end module aer_ccn_act_mod


        module aer_ccn_act_k_mod

implicit none
private
    private    CalcG,  erff, CalcAlphaGamma, CalcBeta
      
    public aer_ccn_act_k, aer_ccn_act2_k, aer_ccn_act_wpdf_k,  &
           aer_ccn_act_k_init, aer_ccn_act_k_end

!--------------------- version number ---------------------------------

character(len=128) :: version = '$Id: aer_ccn_act_k.F90,v 17.0.2.1.4.1 2010/03/17 20:27:11 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!---------------- private data -------------------

  integer, parameter :: TY = 3  !  Number of aerosol types
  integer, parameter :: MD = 2  !  Number of lognormal modes

  real :: T = 283.15 !  Temperature (K)
  real :: P = 0.800e5 !  Pressure (Pa)
  real, parameter :: R = 8.314  !  Gas constant (J mol-1 K-1)
  real, parameter :: ZERO = 273.15 !  Zero degree C (K)
  real, parameter :: ATM = 1.01325e5 !  Standard atmosphere pressure (Pa)
  real, parameter :: PI = 3.1415926
  real, parameter :: eps = 1.e-5  ! epsilon used to prevent index
                                     ! calculation errors

  
!NO 1 Ammonium Sulfate  NO 2 Sea Salt NO 3 Organics
  
  real, dimension(TY) :: B_term = (/0.7822,0.6342,1.3764/) ! 2 * 0.3492/(Bprim)**(1/3)
  real, dimension(TY) :: Mass_scal = (/0.15896,0.198,0.1241/) ! scaling mass (ug m-3)

  real, dimension(MD) :: N = (/340., 60./) ! Total Number Concen (cm-3)
  real, dimension(MD) :: Dm = (/0.01, 0.07/) ! Geometric mean diameter (micron)
  real, dimension(MD) :: LNSIGMA = (/0.47, 0.6931/) ! ln( Sigma (St. Dev.) )

  logical :: nooc

!Parameters for look-up tables

  integer :: res, res2
  real    :: sul_concen, low_concen, high_concen
  real    :: lowup, highup, lowup2, highup2, lowmass2, &
             highmass2, lowmass3, highmass3,  &
             lowmass4, highmass4, lowmass5, highmass5, &
             lowT2, highT2

! real ::  lowup=0.3 !m/s
! real ::  highup=10.

! real ::  lowup2=0.0001 !m/s
! real ::  lowup2=0.05   !m/s
! real ::  highup2=0.3
! real ::  lowmass2=0.01 !ug m-3
! real ::  highmass2=1000.
! real ::  highmass2=100.
! real ::  lowmass3=0.01 !ug m-3
! real ::  highmass3=1000.
! real ::  highmass3=100.
! real :: lowT2=243.15 !K
! real :: highT2=308.15

real, dimension(:,:,:,:,:), allocatable  :: droplets, droplets2

!-----------------------------------------------------------------------
!-------------------- namelist -----------------------------------------

logical :: module_is_initialized  = .false.
 
contains

subroutine aer_ccn_act_k_init      &
             (droplets_in, droplets2_in, res_in, res2_in, nooc_in,  &
              sul_concen_in, low_concen_in, high_concen_in, &
              lowup_in, highup_in, lowup2_in, highup2_in, lowmass2_in, &
              highmass2_in, lowmass3_in, highmass3_in,  &
              lowmass4_in, highmass4_in, lowmass5_in, highmass5_in, &
              lowT2_in, highT2_in)     

real, dimension(:,:,:,:,:), intent(in) :: droplets_in
real, dimension(:,:,:,:,:), intent(in) :: droplets2_in
integer, intent(in) :: res_in, res2_in
logical, intent(in) :: nooc_in
real, intent(in)    :: sul_concen_in, low_concen_in, high_concen_in
real, intent(in)    :: lowup_in, highup_in, lowup2_in, highup2_in,  &
                       lowmass2_in, highmass2_in, lowmass3_in,  &
                       highmass3_in, lowmass4_in, highmass4_in,  &
                       lowmass5_in, highmass5_in, lowT2_in, highT2_in

    if (module_is_initialized) return

    res = res_in
    res2 = res2_in

    allocate (droplets (res, res,res,res,res))
    allocate (droplets2 (res2, res2,res2,res2,res2))

    droplets = droplets_in
    droplets2 = droplets2_in
    nooc = nooc_in
    sul_concen = sul_concen_in
    low_concen = low_concen_in
    high_concen = high_concen_in
    lowup = lowup_in
    highup = highup_in
    lowup2 = lowup2_in
    highup2 = highup2_in
    lowmass3 = lowmass3_in
    highmass3 = highmass3_in
    lowmass4 = lowmass4_in
    highmass4 = highmass4_in
    lowmass5 = lowmass5_in
    highmass5 = highmass5_in
    lowmass2 = lowmass2_in
    highmass2 = highmass2_in
    lowT2 = lowT2_in
    highT2 = highT2_in

    module_is_initialized = .true.


end subroutine aer_ccn_act_k_init



subroutine aer_ccn_act_k (T1, P1, Updraft1, TotalMass, tym,      &      
                          Drop, ier, ermesg)
integer, intent(in) :: tym
real, dimension(tym), intent(inout) :: TotalMass
real, intent(in) :: T1, P1, Updraft1
real, intent(inout) :: Drop
integer, intent(out) :: ier
character(len=*), intent(out) :: ermesg
    
real tmass, tmass2, tmass3, tmass4, updr
integer nomass, nomass2, nomass3, nomass4, noup
        
  ier = 0
  ermesg = '  '

  if ( .not. module_is_initialized) then
    ier = 1
    ermesg = 'aer_ccn_act_k: module has not been initialized before &
                                &first call'
    return
  endif
  if (tym /=  4) then
    ier = 2
    ermesg = 'aer_ccn_act_k:dimension of TotalMass is incorrect'
    return
  endif
  
  if (nooc) TotalMass(4) = 0.

  tmass=(TotalMass(1)+TotalMass(3)+TotalMass(4))*1.e12
    
  if (Updraft1>lowup2 .and. tmass>lowmass2) then

    tmass3=TotalMass(2)*1.e12
    if(TotalMass(1)*1.e12<sul_concen) then
      if (tmass3<low_concen) then
        tmass=TotalMass(1)*1.e12
        tmass2=0.
      else if (tmass3>high_concen) then
        tmass2=TotalMass(1)*1.e12
        tmass=0.
      else
        tmass=TotalMass(1)*1.e12* &
                      (high_concen-tmass3)/(high_concen-low_concen)
        tmass2=TotalMass(1)*1.e12* &
                      (tmass3-low_concen)/(high_concen-low_concen)
      end if
    else
      tmass2=TotalMass(1)*1.e12
      tmass=0.
    end if
   
    tmass3=TotalMass(3)*1.e12
    tmass4=TotalMass(4)*1.e12
    
    if (Updraft1>highup2) then
    
      updr=max(min(Updraft1,highup-eps),lowup)
    
      noup= log(updr/lowup)/log(highup/lowup)*(res2-1.)

      tmass=max(min(tmass,highmass2-eps),lowmass2)
      nomass= log(tmass/lowmass2)/log(highmass2/lowmass2)*(res2-1.)

      tmass2=max(min(tmass2,highmass3-eps),lowmass3)
      nomass2= log(tmass2/lowmass3)/log(highmass3/lowmass3)*(res2-1.)
    
      tmass3=max(min(tmass3,highmass4-eps),lowmass4)
      nomass3= log(tmass3/lowmass4)/log(highmass4/lowmass4)*(res2-1.)
 
      tmass4=max(min(tmass4,highmass5-eps),lowmass5)
      nomass4= log(tmass4/lowmass5)/log(highmass5/lowmass5)*(res2-1.)

      Drop = 0.166667*(droplets2(noup+1,nomass4+1,nomass3+1,nomass2+1,nomass+1)+&
                       droplets2(noup+1,nomass4+1,nomass3+1,nomass2+1,nomass+2)+ &
                       droplets2(noup+1,nomass4+1,nomass3+1,nomass2+2,nomass+1)+ &
                       droplets2(noup+1,nomass4+1,nomass3+2,nomass2+1,nomass+1)+ &
                       droplets2(noup+1,nomass4+2,nomass3+1,nomass2+1,nomass+1)+ &
                       droplets2(noup+2,nomass4+1,nomass3+1,nomass2+1,nomass+1))
  
    else

      updr=max(min(Updraft1,highup2-eps),lowup2)
    
      noup= log(updr/lowup2)/log(highup2/lowup2)*(res-1.)

      tmass=max(min(tmass,highmass2-eps),lowmass2)
      nomass= log(tmass/lowmass2)/log(highmass2/lowmass2)*(res-1.)

      tmass2=max(min(tmass2,highmass3-eps),lowmass3)
      nomass2= log(tmass2/lowmass3)/log(highmass3/lowmass3)*(res-1.)
    
      tmass3=max(min(tmass3,highmass4-eps),lowmass4)
      nomass3= log(tmass3/lowmass4)/log(highmass4/lowmass4)*(res-1.)

      tmass4=max(min(tmass4,highmass5-eps),lowmass5)
      nomass4= log(tmass4/lowmass5)/log(highmass5/lowmass5)*(res-1.)

      Drop = 0.166667*(droplets(noup+1,nomass4+1,nomass3+1,nomass2+1,nomass+1)+&
                       droplets(noup+1,nomass4+1,nomass3+1,nomass2+1,nomass+2)+ &
                       droplets(noup+1,nomass4+1,nomass3+1,nomass2+2,nomass+1)+ &
                       droplets(noup+1,nomass4+1,nomass3+2,nomass2+1,nomass+1)+ &
                       droplets(noup+1,nomass4+2,nomass3+1,nomass2+1,nomass+1)+ &
                       droplets(noup+2,nomass4+1,nomass3+1,nomass2+1,nomass+1))
  
    endif
  
  
  else
  
    Drop=0.
  
  endif
  
end subroutine aer_ccn_act_k

subroutine aer_ccn_act2_k (T1, P1, Updraft1, TotalMass, tym, mu, &
                           airdens,Nc,qc,qt,qe,tc,te,Drop, ier, ermesg)

!T1 temperature (K)
!P1 pressure (Pa)
!Updraft1 updraft velocity (m/s)
!TotalMass aerosol mass ()
!mu entrainment coef. (/s)
!airdens air density (kg/m3 air)
!Nc droplet mixing ratio (#/kg air)
!qc in-cloud vapor mixing ratio (kg water/kg air)
!qt in-cloud total water mixing ratio qc + ql (kg water/kg air)
!qe environment vapor mixing ratio (kg water/kg air)
!tc in-cloud temperature (K)
!te environment temperature (K)
!Drop droplet number concentration (#/cc)

integer, intent(in) :: tym
real, dimension(tym), intent(in) :: TotalMass
real, intent(in) :: T1, P1, Updraft1, mu,airdens, Nc, qc, qt, qe, tc, te
real, intent(inout) :: Drop
integer, intent(out) :: ier
character(len=*), intent(out) :: ermesg

real :: G, alpha, gamma, Smax
real :: Diam, beta, Le_cpa, Dcut
integer :: i, j
        
  ier = 0
  ermesg = '  '
  if ( .not. module_is_initialized) then
    ier = 1
    ermesg = 'aer_ccn_act2_k: module has not been initialized before &
                                &first call'
    return
  endif
  if (tym /= 4) then
    ier = 2
    ermesg = ' aer_ccn_act2_k:dimension of TotalMass is incorrect'
    return
  endif

  Drop=0.
  
  if (Nc > 0.) then    
    T = T1
    P = P1

    call CalcAlphaGamma(alpha, gamma)
    call CalcBeta(beta, Le_cpa)
              
! Diam  average diameter of droplets (micron)
    if (qt > qc) then
      Diam= ((qt-qc)/Nc*1.91e15)**(1./3.)    
    else
      Diam= 20.
    endif

!set the upper and lower limits of Diam
    if (Diam < 10.) Diam=10.
  
    call calcG(Diam, G)
    
    Smax=(alpha-gamma*mu*(qt-qe)*airdens+beta*mu*(Le_cpa*(qc-qe)+(tc-te)))*Updraft1/ &
         (gamma)/(0.5*3.1415*1.e3*G*Diam*1.e-6*Nc*airdens)
  
    if (Smax>0.) then
      do i=1,TY
        Dcut=B_term(i)/T/(Smax**(2./3.))
        do j=1, MD
          Drop=Drop+TotalMass(i)/Mass_scal(i)*N(j)*0.5* &
               (1.-erff(log(Dcut/Dm(j))/LNSIGMA(j)*0.707107))      
        end do
      end do
    endif
  endif

end subroutine aer_ccn_act2_k

!-->cjg: addition
!
! Additional subroutines to compute CCN activation by integrating
! over an assumed subgrid-scale PDF of w

subroutine aer_ccn_act_wpdf_k (T, p, wm, wp2, totalmass, tym, drop,  &
                               ier, ermesg)

! Compute CCN activation assuming a normal distribution of w
! given by its mean (wm) and second moment (wp2)

integer,          intent(in)    :: tym
real,             intent(in)    :: T, p, wm, wp2
real,             intent(inout) :: totalmass(tym)
real,             intent(out)   :: drop
integer,          intent(out)   :: ier
character(len=*), intent(out)   :: ermesg

!  Paranmeters

real, parameter    :: wp2_eps = 0.0001 ! w variance threshold
integer, parameter :: npoints = 64     ! # for Gauss-Hermite quadrature
real, parameter    :: wmin =  0.0      ! min w for ccn_act
real, parameter    :: wmax = 10.0      ! max w for ccn_act

!  Internal

real(kind=8), dimension(npoints) :: x, w
integer init

logical lintegrate
integer i, ia, ib
real wtmp
real(kind=8) :: tmp, a, b, sum1, sum2

save init, x, w

data init/0/


  ier = 0
  ermesg = '  '
  if ( .not. module_is_initialized) then
    ier = 1
    ermesg = 'aer_ccn_act_wpdf _k: module has not been initialized &
                                             &before first call'
    return
  endif
  if (tym /=  4) then
    ier = 2
    ermesg = 'aer_ccn_act_wpdf_k:dimension of TotalMass is incorrect'
    return
  endif

! On first call, initialize arrays with abscissas and weights for
! integration

if ( init .eq. 0 ) then
  call ghquad( npoints, x, w )
  init = 1
endif

! Determine whether integration is needed to compute number
! of activated drops. lintegrate = .true. indicates that
! numerical integration is to be performed.

lintegrate = .false.
if ( wp2 .gt. wp2_eps ) then

  ! Integration bounds: from wmin to wmax (0 to 10 m/s)

  tmp = 1.0d0 / sqrt(2.0 * wp2 ) 
  a = (wmin - wm ) * tmp
  b = (wmax - wm ) * tmp

  ! Locate indices within integration bounds

  call dlocate( x, npoints, a, ia )
  call dlocate( x, npoints, b, ib )

  ! ia (ib) is zero if a (b) is smaller than the lowest abscissa.
  ! In that case, start the integration with the first abscissa.
!  ia = max(ia,1)
!  ib = max(ib,1)
  ia = min(max(ia,1),size(x))
  ib = min(max(ib,1),size(x))

  if ( ib .gt. ia ) lintegrate = .true.

endif

! Compute number of activated drops.

if (lintegrate) then

  ! Perform integration

  sum1 = 0.0d0
  sum2 = 0.0d0
  tmp = sqrt(2.0 * wp2 )
  do i=ia,ib
    wtmp = tmp * x(i) + wm
    call aer_ccn_act_k( T, p, wtmp, totalmass, TYm, drop, ier, ermesg )
    if (ier /= 0) return
    sum1 = sum1 + w(i)*drop
    sum2 = sum2 + w(i)
  enddo

  ! Normalize

  drop = sum1 / sum2

else

  ! No integration, use single point evaluation

  call aer_ccn_act_k( T, p, wm, totalmass, TYm, drop, ier, ermesg )
  if (ier /= 0) return

endif


end subroutine aer_ccn_act_wpdf_k

subroutine dlocate(xx,n,x,j)

! Subroutine to locate the position of element in an ordered array

integer,      intent(in)  :: n
real(kind=8), intent(in)  :: x, xx(n)
integer,      intent(out) :: j
integer jl,jm,ju

jl=0
ju=n+1
do while (ju-jl.gt.1)
  jm=(ju+jl)/2
  if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm)))then
    jl=jm
  else
    ju=jm
  endif
enddo
j=jl

return
end subroutine dlocate

subroutine ghquad( n, x, w )

! This subroutine returns double precision abscissas [x(1:n)] and
! weights [w(1:n)] of a n-point Gauss-Hermite quadrature formula,
! with n = {8, 12, 16, 24, 32, 48, 64, 96}.
! 
! The values of the absicssas and weights were computed offline 
! using subroutine 'gaussq' from netlib.org

integer, intent(in)       :: n
real(kind=8), intent(out) :: x(n), w(n)

select case (n)

  case(  8)
    x(1:n/2) =                                      &
    (/                                              &
      -0.2930637420257D+01, -0.1981656756696D+01,   &
      -0.1157193712447D+01, -0.3811869902073D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.1996040722114D-03,  0.1707798300741D-01,   &
       0.2078023258149D+00,  0.6611470125582D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 12)
    x(1:n/2) =                                      &
    (/                                              &
      -0.3889724897870D+01, -0.3020637025121D+01,   &
      -0.2279507080501D+01, -0.1597682635153D+01,   &
      -0.9477883912402D+00, -0.3142403762544D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.2658551684356D-06,  0.8573687043588D-04,   &
       0.3905390584629D-02,  0.5160798561588D-01,   &
       0.2604923102642D+00,  0.5701352362625D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 16)
    x(1:n/2) =                                      &
    (/                                              &
      -0.4688738939306D+01, -0.3869447904860D+01,   &
      -0.3176999161980D+01, -0.2546202157847D+01,   &
      -0.1951787990916D+01, -0.1380258539199D+01,   &
      -0.8229514491447D+00, -0.2734810461382D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.2654807474011D-09,  0.2320980844865D-06,   &
       0.2711860092538D-04,  0.9322840086242D-03,   &
       0.1288031153551D-01,  0.8381004139899D-01,   &
       0.2806474585285D+00,  0.5079294790166D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 24)
    x(1:n/2) =                                      &
    (/                                              &
      -0.6015925561426D+01, -0.5259382927668D+01,   &
      -0.4625662756424D+01, -0.4053664402448D+01,   &
      -0.3520006813035D+01, -0.3012546137566D+01,   &
      -0.2523881017011D+01, -0.2049003573662D+01,   &
      -0.1584250010962D+01, -0.1126760817611D+01,   &
      -0.6741711070372D+00, -0.2244145474725D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.1664368496489D-15,  0.6584620243078D-12,   &
       0.3046254269988D-09,  0.4018971174941D-07,   &
       0.2158245704902D-05,  0.5688691636404D-04,   &
       0.8236924826884D-03,  0.7048355810073D-02,   &
       0.3744547050323D-01,  0.1277396217846D+00,   &
       0.2861795353464D+00,  0.4269311638687D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 32)
    x(1:n/2) =                                      &
    (/                                              &
      -0.7125813909831D+01, -0.6409498149270D+01,   &
      -0.5812225949516D+01, -0.5275550986516D+01,   &
      -0.4777164503503D+01, -0.4305547953351D+01,   &
      -0.3853755485471D+01, -0.3417167492819D+01,   &
      -0.2992490825002D+01, -0.2577249537732D+01,   &
      -0.2169499183606D+01, -0.1767654109463D+01,   &
      -0.1370376410953D+01, -0.9765004635897D+00,   &
      -0.5849787654359D+00, -0.1948407415694D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.7310676427384D-22,  0.9231736536518D-18,   &
       0.1197344017093D-14,  0.4215010211326D-12,   &
       0.5933291463397D-10,  0.4098832164771D-08,   &
       0.1574167792546D-06,  0.3650585129562D-05,   &
       0.5416584061820D-04,  0.5362683655280D-03,   &
       0.3654890326654D-02,  0.1755342883157D-01,   &
       0.6045813095591D-01,  0.1512697340766D+00,   &
       0.2774581423025D+00,  0.3752383525928D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 48)
    x(1:n/2) =                                      &
    (/                                              &
      -0.8975315081932D+01, -0.8310752190705D+01,   &
      -0.7759295519766D+01, -0.7266046554164D+01,   &
      -0.6810064578074D+01, -0.6380564096186D+01,   &
      -0.5971072225014D+01, -0.5577316981224D+01,   &
      -0.5196287718792D+01, -0.4825757228133D+01,   &
      -0.4464014546934D+01, -0.4109704603561D+01,   &
      -0.3761726490228D+01, -0.3419165969364D+01,   &
      -0.3081248988645D+01, -0.2747308624822D+01,   &
      -0.2416760904873D+01, -0.2089086660944D+01,   &
      -0.1763817579895D+01, -0.1440525220138D+01,   &
      -0.1118812152402D+01, -0.7983046277786D+00,   &
      -0.4786463375945D+00, -0.1594929358489D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.7935551460774D-35,  0.5984612693314D-30,   &
       0.3685036080151D-26,  0.5564577468902D-23,   &
       0.3188387323505D-20,  0.8730159601187D-18,   &
       0.1315159622658D-15,  0.1197589865479D-13,   &
       0.7046932581546D-12,  0.2815296537838D-10,   &
       0.7930467495165D-09,  0.1622514135896D-07,   &
       0.2468658993670D-06,  0.2847258691735D-05,   &
       0.2528599027748D-04,  0.1751504318012D-03,   &
       0.9563923198194D-03,  0.4153004911978D-02,   &
       0.1444496157498D-01,  0.4047967698460D-01,   &
       0.9182229707929D-01,  0.1692044719456D+00,   &
       0.2539615426648D+00,  0.3110010303780D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 64)
    x(1:n/2) =                                      &
    (/                                              &
      -0.1052612316796D+02, -0.9895287586830D+01,   &
      -0.9373159549647D+01, -0.8907249099965D+01,   &
      -0.8477529083380D+01, -0.8073687285010D+01,   &
      -0.7689540164040D+01, -0.7321013032781D+01,   &
      -0.6965241120551D+01, -0.6620112262636D+01,   &
      -0.6284011228775D+01, -0.5955666326799D+01,   &
      -0.5634052164350D+01, -0.5318325224633D+01,   &
      -0.5007779602199D+01, -0.4701815647408D+01,   &
      -0.4399917168228D+01, -0.4101634474567D+01,   &
      -0.3806571513945D+01, -0.3514375935741D+01,   &
      -0.3224731291992D+01, -0.2937350823005D+01,   &
      -0.2651972435431D+01, -0.2368354588632D+01,   &
      -0.2086272879882D+01, -0.1805517171466D+01,   &
      -0.1525889140210D+01, -0.1247200156943D+01,   &
      -0.9692694230712D+00, -0.6919223058100D+00,   &
      -0.4149888241211D+00, -0.1383022449870D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.5535706535857D-48,  0.1679747990108D-42,   &
       0.3421138011256D-38,  0.1557390624630D-34,   &
       0.2549660899113D-31,  0.1929103595465D-28,   &
       0.7861797788926D-26,  0.1911706883301D-23,   &
       0.2982862784280D-21,  0.3152254566504D-19,   &
       0.2351884710676D-17,  0.1280093391322D-15,   &
       0.5218623726591D-14,  0.1628340730710D-12,   &
       0.3959177766948D-11,  0.7615217250145D-10,   &
       0.1173616742322D-08,  0.1465125316476D-07,   &
       0.1495532936727D-06,  0.1258340251031D-05,   &
       0.8788499230850D-05,  0.5125929135786D-04,   &
       0.2509836985131D-03,  0.1036329099508D-02,   &
       0.3622586978534D-02,  0.1075604050988D-01,   &
       0.2720312895369D-01,  0.5873998196410D-01,   &
       0.1084983493062D+00,  0.1716858423491D+00,   &
       0.2329947860627D+00,  0.2713774249413D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case( 96)
    x(1:n/2) =                                      &
    (/                                              &
      -0.1311613002166D+02, -0.1252923074668D+02,   &
      -0.1204480674113D+02, -0.1161362082884D+02,   &
      -0.1121687519420D+02, -0.1084488807385D+02,   &
      -0.1049185453928D+02, -0.1015395127471D+02,   &
      -0.9828492746192D+01, -0.9513501769412D+01,   &
      -0.9207469353372D+01, -0.8909210581460D+01,   &
      -0.8617773244215D+01, -0.8332377307170D+01,   &
      -0.8052373330720D+01, -0.7777213031061D+01,   &
      -0.7506427894428D+01, -0.7239613294008D+01,   &
      -0.6976416464285D+01, -0.6716527240497D+01,   &
      -0.6459670819555D+01, -0.6205602024718D+01,   &
      -0.5954100706412D+01, -0.5704968013526D+01,   &
      -0.5458023340071D+01, -0.5213101801819D+01,   &
      -0.4970052133167D+01, -0.4728734920353D+01,   &
      -0.4489021106217D+01, -0.4250790715903D+01,   &
      -0.4013931763628D+01, -0.3778339308797D+01,   &
      -0.3543914636027D+01, -0.3310564538524D+01,   &
      -0.3078200688047D+01, -0.2846739077725D+01,   &
      -0.2616099526362D+01, -0.2386205234770D+01,   &
      -0.2156982386193D+01, -0.1928359784146D+01,   &
      -0.1700268521938D+01, -0.1472641679023D+01,   &
      -0.1245414039907D+01, -0.1018521831948D+01,   &
      -0.7919024787540D+00, -0.5654943662667D+00,   &
      -0.3392366188789D+00, -0.1130688831515D+00    &
    /)
    x(n/2+1:n) = -x(n/2:1:-1)
    w(1:n/2) =                                      &
    (/                                              &
       0.1315337147701D-74,  0.3480841387719D-68,   &
       0.4468702421681D-63,  0.1093382473752D-58,   &
       0.8733732835919D-55,  0.3022293931502D-51,   &
       0.5383222506970D-48,  0.5537064819783D-45,   &
       0.3568938561781D-42,  0.1531798964711D-39,   &
       0.4587401665859D-37,  0.9946800059220D-35,   &
       0.1608873207938D-32,  0.1989546894270D-30,   &
       0.1919970706795D-28,  0.1471241554974D-26,   &
       0.9085965647049D-25,  0.4580601098550D-23,   &
       0.1906260188688D-21,  0.6612951176481D-20,   &
       0.1928879326837D-18,  0.4766831171186D-17,   &
       0.1004905149157D-15,  0.1818169130493D-14,   &
       0.2838767395169D-13,  0.3843681724877D-12,   &
       0.4533303374584D-11,  0.4676010385985D-10,   &
       0.4233593783511D-09,  0.3375584731128D-08,   &
       0.2377366214757D-07,  0.1482969405005D-06,   &
       0.8213544547833D-06,  0.4048233178777D-05,   &
       0.1779180591822D-04,  0.6985432444541D-04,   &
       0.2454180927305D-03,  0.7726958216817D-03,   &
       0.2183131976097D-02,  0.5541631289439D-02,   &
       0.1265137511280D-01,  0.2600034027124D-01,   &
       0.4813990673109D-01,  0.8035395008064D-01,   &
       0.1209831168625D+00,  0.1643796305985D+00,   &
       0.2016130134792D+00,  0.2232700234975D+00    &
    /)
    w(n/2+1:n) = w(n/2:1:-1)

  case default
     stop 'ghquad: invalid value of n'

end select

return
end subroutine ghquad

!
!<--cjg: end of addition


subroutine CalcG(Dp, G)

real, intent(inout) :: Dp
real, intent(inout) :: G
real :: rhow = 1.0e3  ! density of water (Kg m-3)
real :: Mw = 0.018  ! molecular weight of water (Kg mol-1)
real :: alpc = 1.0  ! mass accomodation coef. 
real :: alpt = 0.97  ! thermal accomodation coef.
!real :: alpc = 0.042  ! mass accomodation coef. 
!real :: alpt = 1.  ! thermal accomodation coef.
!real :: alpc = 0.2  ! mass accomodation coef. 
!real :: alpt = 1.  ! thermal accomodation coef.
real :: delt = 2.16e-1 !thermal jump (micron)
real :: delv = 1.096e-1 !vapor jump (micron)
real vpres, Dv, ka, Le, mass, heat, TC
      
      
      Dv = 0.211/(P/ATM)*(T/ZERO)**1.94*1e-4  ! diffusivity of water vapor (m2 s-1)
      Dv = Dv/(Dp/(Dp+delv*2.)+2*Dv/(alpc*(Dp*1e-6))*(2.*PI*Mw/R/T)**0.5)
      ka = 1e-3*(4.39+0.071*T)  ! thermal conductivity (J m-1 s-1 K-1)
      ka = ka/(Dp/(Dp+delt*2.)+2*ka/(alpt*(Dp*1e-6)*1.007e3*P)*(2.*PI*R*T/0.028965)**0.5)
      TC = T-ZERO
      vpres = (6.107799961+TC*(4.436518521e-1+TC*(1.428945805e-2+TC*(2.650648471e-4 &
              +TC*(3.031240396e-6+TC*(2.034080948e-8+6.136820929e-11*TC))))))*1e2  ! saturated water vapor pressure(Pa)
      Le = 597.3*(ZERO/T)**(0.167+3.67e-4*T)*4.182*1e3  ! latent heat of water (J Kg -1) 
      
      mass = rhow*R*T/(vpres*Dv*Mw)
      heat = Le*rhow/(ka*T)*(Le*Mw/T/R-1)
!      print *, Dv, vpres, Mw, rhow, mass, heat
      G = 4./(mass+heat) ! (m2 s-1)
end subroutine CalcG

recursive function erff(x) RESULT(y)

! Error function from Numerical Recipes.
! erf(x) = 1 - erfc(x)

real dumerfc, x
real t, z, y


  z = abs(x)
  t = 1.0 / ( 1.0 + 0.5 * z )

  dumerfc =     t * exp(-z * z - 1.26551223 + t *      &
            ( 1.00002368 + t * ( 0.37409196 + t *    &
            ( 0.09678418 + t * (-0.18628806 + t *    &
            ( 0.27886807 + t * (-1.13520398 + t *    &
            ( 1.48851587 + t * (-0.82215223 + t * 0.17087277 )))))))))

  if ( x.lt.0.0 ) dumerfc = 2.0 - dumerfc
 
  y = 1.0 - dumerfc

end function erff


subroutine CalcAlphaGamma(alpha, gamma)

  real, intent(inout) :: alpha, gamma
  real rhoa ! density of air (Kg m-3)
  real :: Cpa = 1.007e3 ! specific heat of air (J Kg-1 K-1)
  real :: Mw = 0.018  ! molecular weight of water (Kg mol-1)
  real :: Ma = 0.028965  ! molecular weight of air (Kg mol-1)
  real :: g = 9.815 ! gravitational acceleration (m s-2) 
  real vpres, Dv, ka, Le, TC
  
  rhoa = P*Ma/R/T  ! (Kg m-3)
  Dv = 0.211/(P/ATM)*(T/ZERO)**1.94*1e-4  ! diffusivity of water vapor (m2 s-1)
!  Dv = Dv/(1+2*Dv/(alpc*Dp)*(2.*PI*Mw/R/T)**0.5)
  ka = 1e-3*(4.39+0.071*T)  ! thermal conductivity (J m-1 s-1 K-1)
  TC = T-ZERO
  vpres = (6.107799961+TC*(4.436518521e-1+TC*(1.428945805e-2+TC*(2.650648471e-4 &
          +TC*(3.031240396e-6+TC*(2.034080948e-8+6.136820929e-11*TC))))))*1e2  ! saturated water vapor pressure (Pa)
  Le = 597.3*(ZERO/T)**(0.167+3.67e-4*T)*4.182*1e3  ! latent heat of water (J Kg -1)
  alpha = g*Mw*Le/(Cpa*R*T**2.)-g*Ma/(R*T) ! (m-1)
  gamma = R*T/(vpres*Mw)+Mw*Le**2./(Cpa*P*Ma*T) ! (m3 Kg-1)
end subroutine CalcAlphaGamma

subroutine CalcBeta(beta, Le_cpa)

  real, intent(inout) :: beta, Le_cpa 
  real rhoa ! density of air (Kg m-3)
  real :: Cpa = 1.007e3 ! specific heat of air (J Kg-1 K-1)
  real :: Mw = 0.018  ! molecular weight of water (Kg mol-1)
  real :: Ma = 0.028965  ! molecular weight of air (Kg mol-1)
  real vpres, Dv, ka, Le, TC
  
  rhoa = P*Ma/R/T  ! (Kg m-3)
  Dv = 0.211/(P/ATM)*(T/ZERO)**1.94*1e-4  ! diffusivity of water vapor (m2 s-1)
!      Dv = Dv/(1+2*Dv/(alpc*Dp)*(2.*PI*Mw/R/T)**0.5)
  ka = 1e-3*(4.39+0.071*T)  ! thermal conductivity (J m-1 s-1 K-1)
  TC = T-ZERO
  vpres = (6.107799961+TC*(4.436518521e-1+TC*(1.428945805e-2+TC*(2.650648471e-4 &
          +TC*(3.031240396e-6+TC*(2.034080948e-8+6.136820929e-11*TC))))))*1e2  ! saturated water vapor pressure (Pa)
  Le = 597.3*(ZERO/T)**(0.167+3.67e-4*T)*4.182*1e3  ! latent heat of water (J Kg -1)
  Le_cpa = Le/Cpa
  beta = Mw*Le/(R*T**2.) ! (K-1)
end subroutine CalcBeta

subroutine aer_ccn_act_k_end()

  module_is_initialized = .false.

end subroutine aer_ccn_act_k_end

end module aer_ccn_act_k_mod


        module aer_in_act_mod

implicit none
      private 
      public Jhomo_wat, Jhete_dep, Jhomo_aer, &
                       aer_in_act_init, aer_in_act_end

!Parameters for look-up tables

integer, parameter :: tpDIM = 3 ! Dimension of temperature (K)
integer, parameter :: tp2DIM = 3 ! Dimension of temperature (K)
integer, parameter :: msDIM = 5 ! Dimension of scaled sub-micron dust mass
integer, parameter :: upDIM = 5 ! Dimension of updraft velocity (m/s)
real, parameter :: unitmass = 0.11 ! (ug/m3), one unit mass

real, dimension(tpDIM) :: tp = (/243.15, 253.15, 263.15/)
real, dimension(tp2DIM) :: tp2 = (/233.15, 223.15, 213.15/)   
real, dimension(tpDIM) :: a1 = (/1.416, 1.5809, 1.5171/)
real, dimension(tpDIM) :: a2 = (/3.7909, 6.4407, 8.184/)   
real, dimension(tp2DIM) :: b1 = (/0.1068, 0., -0.1016/)
real, dimension(tp2DIM) :: b2 = (/2.2905, 1.3846, 0.5668/)
real, dimension(tp2DIM) :: b3 = (/6.1191, 4.9161, 4.1684/)
real, dimension(tp2DIM) :: c1 = (/7.2759, 10.532, 17.628/)
real, dimension(tp2DIM) :: c2 = (/1.4301, 1.346, 1.3038/)
real, dimension(tp2DIM) :: d1 = (/0.2423, 0.4259, 0.6952/)
real, dimension(tp2DIM) :: d2 = (/-1.1814, -1.3778, -1.6693/)
real, dimension(tp2DIM) :: d3 = (/1.0016, 0.9998, 1.0114/)
real, dimension(tp2DIM) :: e1 = (/0.1412, 0.1541, 0.163/)
real, dimension(tp2DIM) :: e2 = (/0.3923, 0.3397, 0.3124/)
real, dimension(tp2DIM) :: e3 = (/-0.0819, -0.0269, 0.0009/)
real, dimension(tp2DIM) :: f = (/16., 19.6, 20.2/)
real, dimension(msDIM) :: ms = (/100.,10.,1.,0.1,0.01/) ! The last dimension is for mass threshold.
real, dimension(upDIM) :: up = (/0.1,0.05,0.01,0.005,0.001/)
real, dimension(tpDIM,msDIM,upDIM) :: crystal2

character(len=128) :: version = '$Id: aer_in_act.F90,v 15.0.4.1.4.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical :: module_is_initialized  = .false.

contains

subroutine Jhete_dep (temp,Si,concen_dust_sub,crystal)
   real, intent(in) :: temp,Si,concen_dust_sub
   real, intent(out) :: crystal

   real dust

   if(.not. module_is_initialized) call aer_in_act_init()
   
   crystal=0.
   dust=concen_dust_sub/unitmass
   if (temp>243.15) then
      crystal=dust*min(exp(12.96*(Si-1)-0.639)*5.73e-4, 0.0091)
   else if (temp>223.15) then
      crystal=dust*min(exp(12.96*(Si-1.1))**0.3*9.09e-3, 0.0091)
   else if (Si<(6.5217e-3*(temp-273.15)+1.6276)) then
      crystal=min(max(exp(1.5*(Si-1.11))-1.,0.),0.05)*dust*18.12
   endif
end subroutine Jhete_dep

subroutine Jhomo_aer (dtcloud, temp, rh, updraft, aer, crystal)
   real, dimension(3), intent(inout) :: aer
   real, intent(in) :: dtcloud, temp, rh, updraft
   real, intent(out) :: crystal

   real totalnumber, ai, aw, J, Nhomo
   integer no_tp2
   
   crystal=0.
   
   if (temp<=237.15) then
      if (temp>228.15) then
         no_tp2 = 1
      else if (temp>218.15) then
         no_tp2 = 2
      else
         no_tp2 = 3
      endif
   Nhomo=c1(no_tp2)*updraft**c2(no_tp2)
!density sulfate 1.7418e3, sea-salt 2.17e3, OC 1.362e3      
!here only particles between 0.1 and 1 micron are considered. Smaller particles do not
!have a chance to freeze.
!Size dist. is the same as used in the prognostic paper.
   totalnumber=19.1*(aer(1)/1.48e-13 + aer(2)/1.85e-13 + aer(3)/1.16e-13)
   
   ai=exp((210368.+131.438*temp-3.32373e6/temp-41729.1*log(temp))/(8.314*temp))
   aw=min(rh-ai,0.34)
!homo. nucl. rate (cm-3 sec-1); from Koop et al. (2000)
   if(aw>0.26) then
      J=10.**(-906.7+8502*aw-26924*aw**2.+29180*aw**3.);
   else
      J=0;
   endif
!the volume-average diamter is 0.204 micron (4.46e-15 cm3)
   crystal=min(Nhomo,totalnumber*(1.-exp(-1.*J*dtcloud*4.46e-15)))
   endif
end subroutine Jhomo_aer

subroutine Jhomo_wat (T, J)
!return homogeneous nucleation rate constant J (cm-3 s-1) as a
!function of temperature T (K)
   real, intent(in) :: T
   real, intent(out) :: J
   real :: TT
   
   TT = T - 273.15

   if (TT>=-50 .and. TT<-30) then
      J=-0.0001536*TT**4-0.0265*TT**3
      J=J-1.7439*TT**2-52.6611*TT-606.3952
      J=10**J
   else if (TT<-50) then
      TT=-50;
      J=-0.0001536*TT**4-0.0265*TT**3
      J=J-1.7439*TT**2-52.6611*TT-606.3952
      J=10**J
   else
      J=0.
   endif
end subroutine Jhomo_wat

subroutine aer_in_act_init ()
   module_is_initialized  = .true.
end subroutine aer_in_act_init

subroutine aer_in_act_end ()
   module_is_initialized  = .false.
end subroutine aer_in_act_end

end module aer_in_act_mod


     module strat_chem_driver_mod


use mpp_mod, only: input_nml_file 
use              fms_mod, only : file_exist, &
                                 check_nml_error,  &
                                 close_file, open_namelist_file, &
                                 stdlog, write_version_number, &
                                 error_mesg, FATAL
use              mpp_io_mod, only: mpp_open, mpp_close, &
                       MPP_NATIVE, MPP_RDONLY, MPP_DELETE

use   tracer_manager_mod, only : get_tracer_index, NO_TRACER
use    field_manager_mod, only : MODEL_ATMOS

use                mpp_mod, only: mpp_pe, mpp_root_pe, stdout
use constants_mod, only : PI, TFREEZE, GRAV, PSTD_MKS, RDGAS

use STRAT_CHEM_MOD, only : chemistry, zen2, dcly_dt, sediment
     implicit none

private
!----------- ****** VERSION NUMBER ******* ---------------------------

character(len=128)  :: version =  '$Id: strat_chem_driver.F90,v 18.0.2.1 2010/08/30 20:33:36 wfc Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'
logical             :: module_is_initialized = .FALSE.

!-------  interfaces --------

public   strat_chem_driver_init,   strat_chem, strat_chem_driver_end


!----------- namelist -------------------


integer     :: fixed_chem_year= 0   ! 

real        :: n2o_foto_accel= 1.0     !      

logical     :: do_coupled_stratozone = .false.  ! Do I want to use this routine?

namelist / strat_chem_nml /         &
                   fixed_chem_year, n2o_foto_accel, do_coupled_stratozone 





     logical               :: run_startup = .true.
     real  ::   ozon(11,48),cosp(14),cosphc(48),photo(132,14,11,48),    &
           solardata(1801),chlb(90,15),ozb(144,90,12),tropc(151,9),    &
           dfdage(90,48,8),anoy(90,48)
     integer :: mype

!  When initializing additional tracers, the user needs to make the
!  following changes.
!
!  Add an integer variable below for each additional tracer. 
!  This should be initialized to zero. 
!
!-----------------------------------------------------------------------

integer :: nsphum = 0
integer :: nliq_wat = 0
integer :: nice_wat = 0
integer :: ncld_amt = 0
integer :: nhno3 = 0
integer :: nn2o5 = 0
integer :: nh2o2 = 0
integer :: nhcl = 0
integer :: nhocl = 0
integer :: nclono2 = 0
integer :: nh2co = 0
integer :: noy = 0
integer :: nhobr = 0
integer :: nhno4 = 0
integer :: nhbr = 0
integer :: nbrono2 = 0
integer :: nch3ooh = -1
integer :: nco = 0
integer :: nnoy = 0
integer :: ncly = 0
integer :: nbry = 0
integer :: nch4 = 0
integer :: nstrath2o = 0
integer :: nn2o = 0
integer :: nage = 0
integer :: no3 = 0
integer :: no3ch = 0
integer :: nextinct = 0
integer :: naerosol = 0

     CONTAINS

function strat_chem_driver_init()
 logical :: strat_chem_driver_init

      integer                 :: unit, ierr, io, logunit
!---------------------------------------------------------------------
!    read strat_chem namelist.
!---------------------------------------------------------------------


         if (file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
           read (input_nml_file, nml=strat_chem_nml, iostat=io)
           ierr = check_nml_error(io,'strat_chem_nml')
#else
           unit =  open_namelist_file ( )
           ierr=1; do while (ierr /= 0)
           read (unit, nml=strat_chem_nml, iostat=io, end=10)
           ierr = check_nml_error (io, 'strat_chem_nml')
           enddo
 10        call close_file (unit)
#endif
         endif

     strat_chem_driver_init = do_coupled_stratozone
     
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      logunit=stdlog()
      if (mpp_pe() == mpp_root_pe()) write (logunit, nml=strat_chem_nml)
 
      module_is_initialized = .true.

      if (.not. do_coupled_stratozone) return
!---------------------------------------------------------------------

      call chem_startup
      
end function strat_chem_driver_init

subroutine strat_chem_driver_end

      module_is_initialized = .false.

end subroutine strat_chem_driver_end

     subroutine chem_startup()
!
! Obtains chemical lower boundary condition and arrays for photolysis 
! rate calculation
!



      real age(90,48,12)
      integer lev,ipz,icz,lv,nc,jl,ir
!
!   local variables: 

      integer                 :: unit, outunit

      if(run_startup) then
         run_startup = .false.


      nsphum    = get_tracer_index(MODEL_ATMOS,'sphum')    !Tracer #1
      nliq_wat  = get_tracer_index(MODEL_ATMOS,'liq_wat')   !Tracer #2
      nice_wat  = get_tracer_index(MODEL_ATMOS,'ice_wat')   !Tracer #3
      ncld_amt  = get_tracer_index(MODEL_ATMOS,'cld_amt')   !Tracer #4
      nhno3     = get_tracer_index(MODEL_ATMOS,'HNO3')      !Tracer #5
      nn2o5     = get_tracer_index(MODEL_ATMOS,'N2O5')      !Tracer #6
      nh2o2     = get_tracer_index(MODEL_ATMOS,'H2O2')      !Tracer #7
      nhcl      = get_tracer_index(MODEL_ATMOS,'HCl')       !Tracer #8
      nhocl     = get_tracer_index(MODEL_ATMOS,'HOCl')      !Tracer #9
      nclono2   = get_tracer_index(MODEL_ATMOS,'ClONO2')    !Tracer #10
      nh2co     = get_tracer_index(MODEL_ATMOS,'H2CO')      !Tracer #11
      noy       = get_tracer_index(MODEL_ATMOS,'Oy')        !Tracer #12
      nhobr     = get_tracer_index(MODEL_ATMOS,'HOBr')      !Tracer #13
      nhno4     = get_tracer_index(MODEL_ATMOS,'HNO4')      !Tracer #14
      nhbr      = get_tracer_index(MODEL_ATMOS,'HBr')       !Tracer #15
      nbrono2   = get_tracer_index(MODEL_ATMOS,'BrONO2')    !Tracer #16
      nch3ooh   = get_tracer_index(MODEL_ATMOS,'CH3OOH')    !Tracer #17
      nco       = get_tracer_index(MODEL_ATMOS,'CO')        !Tracer #18
      nnoy      = get_tracer_index(MODEL_ATMOS,'NOy')       !Tracer #19
      ncly      = get_tracer_index(MODEL_ATMOS,'Cly')       !Tracer #20
      nbry      = get_tracer_index(MODEL_ATMOS,'Bry')       !Tracer #21
      nch4      = get_tracer_index(MODEL_ATMOS,'CH4')       !Tracer #22
      nstrath2o = get_tracer_index(MODEL_ATMOS,'StratH2O')  !Tracer #23
      nn2o      = get_tracer_index(MODEL_ATMOS,'N2O')       !Tracer #24
      nage      = get_tracer_index(MODEL_ATMOS,'Age')       !Tracer #25
      no3       = get_tracer_index(MODEL_ATMOS,'O3')        !Tracer #26
      no3ch     = get_tracer_index(MODEL_ATMOS,'O3_chem')   !Tracer #27
      nextinct  = get_tracer_index(MODEL_ATMOS,'Extinction')!Tracer #28
      naerosol  = get_tracer_index(MODEL_ATMOS,'Aerosol')   !Tracer #29

      if ( nliq_wat  == NO_TRACER .or. nice_wat  == NO_TRACER .or. &
           ncld_amt  == NO_TRACER .or. nhno3     == NO_TRACER .or. &
           nn2o5     == NO_TRACER .or. nh2o2     == NO_TRACER .or. &
           nhcl      == NO_TRACER .or. nhocl     == NO_TRACER .or. &
           nclono2   == NO_TRACER .or. nh2co     == NO_TRACER .or. &
           noy       == NO_TRACER .or. nhobr     == NO_TRACER .or. &
           nhno4     == NO_TRACER .or. nhbr      == NO_TRACER .or. &
           nbrono2   == NO_TRACER .or. nch3ooh   == NO_TRACER .or. &
           nco       == NO_TRACER .or. nnoy      == NO_TRACER .or. &
           ncly      == NO_TRACER .or. nbry      == NO_TRACER .or. &
           nch4      == NO_TRACER .or. nstrath2o == NO_TRACER .or. &
           nn2o      == NO_TRACER .or. nage      == NO_TRACER .or. &
           no3       == NO_TRACER .or. no3ch     == NO_TRACER ) &
         call error_mesg ('Strat_chem_driver', &
                          'A necessary tracer is missing from the field_table &
                          &and thus will not allow strat_chem to run correctly.', FATAL)  

!  read in chemical lower boundary 
!  
         outunit = stdout()
         call mpp_open( unit, 'INPUT/chemlbf',action=MPP_RDONLY )
         if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'INPUT/chemlbf'
         DO NC = 1,15                                           
           READ(unit,'(6E13.6)') (CHLB(JL,NC),JL=1,90) 
         ENDDO                                                          
         READ(unit,'(6E13.6)') OZB  
         read(unit,'(6e13.6)') tropc
         call mpp_close(unit)
!
!  read in photolysis files
!         
         call mpp_open( unit, 'INPUT/photolsmax', action=MPP_RDONLY )
         if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'INPUT/photolsmax'
         DO LEV = 1,48                                            
         DO IPZ = 1,11                                               
         DO ICZ = 1,14                                               
         READ(unit,'(I4,E12.4,2F10.4,5(/6E12.4),/3E12.4)') &
           LV,OZON(IPZ,LEV),COSP(ICZ),COSPHC(LEV), &
           (PHOTO(IR,ICZ,IPZ,LEV),IR=1,33)
         READ(unit,'(5(6E12.4/),3E12.4)')   &
           (PHOTO(IR,ICZ,IPZ,LEV),IR=34,66)
         enddo
         enddo
         enddo
         call mpp_close(unit)
         call mpp_open( unit, 'INPUT/photolsmin', action=MPP_RDONLY )
         if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'INPUT/photolsmin'
         DO LEV = 1,48                                            
         DO IPZ = 1,11                                               
         DO ICZ = 1,14                                               
         READ(unit,'(I4,E12.4,2F10.4,5(/6E12.4),/3E12.4)') &
           LV,OZON(IPZ,LEV),COSP(ICZ),COSPHC(LEV), &
           (PHOTO(IR,ICZ,IPZ,LEV),IR=67,99)
         READ(unit,'(5(6E12.4/),3E12.4)')   &
           (PHOTO(IR,ICZ,IPZ,LEV),IR=100,132)
         enddo
         enddo
         enddo
         call mpp_close(unit)
         call mpp_open( unit, 'INPUT/solar_f107.dat', action=MPP_RDONLY )
         if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'INPUT/solar_f107.dat'
         read(unit,'(f6.0,5f7.0)') solardata
         call mpp_close(unit)
         DO LEV = 1,48                                              
         DO IPZ = 1,11                                               
         DO ICZ = 1,14                                               
         DO IR = 1,132                                                
         PHOTO(IR,ICZ,IPZ,LEV) = ALOG(PHOTO(IR,ICZ,IPZ,LEV)+1.E-30)     
         enddo
         enddo
         enddo
         enddo
!
!  read in data for Cly and Bry computation
!         
         call mpp_open( unit, 'INPUT/dfdage.dat', action=MPP_RDONLY )
         if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'INPUT/dfdage.dat'
         read(unit,'(6e13.6)') age
         read(unit,'(6e13.6)') dfdage
         call mpp_close(unit)
!
!  read in data for NOy tropospheric relaxation
!         
         call mpp_open( unit, 'INPUT/noy_annual.dat', action=MPP_RDONLY )
         if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'INPUT/noy_annual.dat'
         read(unit,'(6e13.6)') anoy
         call mpp_close(unit)
     endif



     return
     end   subroutine chem_startup

     subroutine strat_chem(alon,alat,chems,dchems,pfull,temp,itime,    &
       is,ie,js,je,dt,coszen,&
       nsphum,chem_tend,ozone,o3_prod,aerosol,mype)
     real, intent(in), dimension(:,:,:,:)  :: chems
     real, intent(in), dimension(:,:,:,:)  :: dchems
     real, intent(in), dimension(:,:,:)    :: pfull, temp 
     real, intent(in), dimension(:,:)      :: alon,alat,coszen
     real, intent(in)                      :: dt
     real, intent(out), dimension(:,:,:,:) :: chem_tend
     real, intent(out), dimension(:,:,:)   :: ozone, o3_prod, aerosol
     integer, intent(in)                   :: is,ie,js,je,nsphum,mype
     integer, intent(inout), dimension(6)  :: itime
!
     integer :: nc,il,jl,kl,merids,lats,levs
     integer :: ipts           
!
     real, dimension(size(pfull,1),size(pfull,2),size(pfull,3)) ::     &
                               ozcol,anat,aice,alats,cly,bry,age
     real, dimension(size(pfull,1)) :: h2o,h2o_tend,dagesq

     real  ::   cozen(ie-is+1,je-js+1),vtemp(size(pfull,1)),           &
                rho(size(pfull,1)),dy(size(pfull,1),21),               &
                ch_tend(size(pfull,1),21),                             &
                drad,darg,delta,cdx,cozi,cozj1,cozj2,const,const2,xc,  &
                vtau10,fact2,cond,extinct
!
     if(.not. do_coupled_stratozone) return ! You do not want to do stratospheric chemistry
     merids = size(pfull,1)
     lats = size(pfull,2)
     levs = size(pfull,3)
     drad = 3.141592653589793/180.        
     const =  287.056*273.16/(1.01325*9.81)                 
     const2 = 2.693e19 *273.16/101325.

     chem_tend(:,:,:,:) = 0.0
!wfc Comment out for now
!     drad = PI/180.        
!     const =  RDGAS*TFREEZE/(PSTD_MKS*1.e-5*GRAV)                 
!     const2 = 2.693e19 *TFREEZE/PSTD_MKS
!

!  change model time to fit in with chemical time
      
    if( fixed_chem_year > 0 )  itime(1) = fixed_chem_year
!    if(mpp_pe()==mpp_root_pe()) print *,' time', itime

!
! Compute cosine of solar zenith angle
!
     call zen2 (itime,dt,drad,darg,delta,cdx)
     do jl = 1,je-js+1     
     do il = 1,ie-is+1
     cozi = cos(darg+alon(il,jl))
     cozj1 = cos(alat(il,jl))*cos(delta)                                 
     cozj2 = sin(alat(il,jl))*sin(delta)             
     cozen(il,jl) = cozj2 + cozj1*cozi
     enddo
     enddo
!
! Calculate overhead ozone columns for photolysis
! Allow for transport problems with a 1 e-15 minimum for ozone.
!
     do jl = 1,je-js+1
     do il = 1,ie-is+1
     xc = chems(il,jl,1,no3) 
     if(xc.lt.1.0e-15) xc = 1.0e-15
     ozcol(il,jl,1) = xc*const*pfull(il,jl,1)
     do kl = 2,levs
     xc =  sqrt(chems(il,jl,kl,no3)*chems(il,jl,kl-1,no3)) 
     if(xc.lt.1.0e-15) xc = 1.0e-15
     ozcol(il,jl,kl) = ozcol(il,jl,kl-1) +                    &
        const*(pfull(il,jl,kl) - pfull(il,jl,kl-1))*xc         
     enddo
     enddo
     enddo
!=========================================================================
! Do main loop over model levels
!
!==========================================================================

     do 1000 kl = 1,levs
     do jl = js,je    
!
!  Set up inverse temperature and density for use in the chemical model
!  CHEMISTRY computes the chemical change for one model timestep, one latitude
!  row at a time and converts this into a rate of change chem_tend
!  chems isn't necessarily positive definite, depending on the transport 
!  scheme, so the values are set to zero within the chemistry scheme
!  and the concentration is relaxed to zero with a 1-day timescale 
!
     do il = is,ie
     vtemp(il) = 1.0/temp(il,jl,kl)
     rho(il) = const2*pfull(il,jl,kl)*vtemp(il)
     dy(il,1 ) = chems(il,jl,kl,nhno3    ) + dchems(il,jl,kl,nhno3    )*dt
     dy(il,2 ) = chems(il,jl,kl,nn2o5    ) + dchems(il,jl,kl,nn2o5    )*dt
     dy(il,3 ) = chems(il,jl,kl,nh2o2    ) + dchems(il,jl,kl,nh2o2    )*dt
     dy(il,4 ) = chems(il,jl,kl,nhcl     ) + dchems(il,jl,kl,nhcl     )*dt
     dy(il,5 ) = chems(il,jl,kl,nhocl    ) + dchems(il,jl,kl,nhocl    )*dt
     dy(il,6 ) = chems(il,jl,kl,nclono2  ) + dchems(il,jl,kl,nclono2  )*dt
     dy(il,7 ) = chems(il,jl,kl,nh2co    ) + dchems(il,jl,kl,nh2co    )*dt
     dy(il,8 ) = chems(il,jl,kl,noy      ) + dchems(il,jl,kl,noy      )*dt
     dy(il,9 ) = chems(il,jl,kl,nhobr    ) + dchems(il,jl,kl,nhobr    )*dt
     dy(il,10) = chems(il,jl,kl,nhno4    ) + dchems(il,jl,kl,nhno4    )*dt
     dy(il,11) = chems(il,jl,kl,nhbr     ) + dchems(il,jl,kl,nhbr     )*dt
     dy(il,12) = chems(il,jl,kl,nbrono2  ) + dchems(il,jl,kl,nbrono2  )*dt
     dy(il,13) = chems(il,jl,kl,nch3ooh  ) + dchems(il,jl,kl,nch3ooh  )*dt
     dy(il,14) = chems(il,jl,kl,nco      ) + dchems(il,jl,kl,nco      )*dt
     dy(il,15) = chems(il,jl,kl,nnoy     ) + dchems(il,jl,kl,nnoy     )*dt
     dy(il,16) = chems(il,jl,kl,ncly     ) + dchems(il,jl,kl,ncly     )*dt
     dy(il,17) = chems(il,jl,kl,nbry     ) + dchems(il,jl,kl,nbry     )*dt
     dy(il,18) = chems(il,jl,kl,nch4     ) + dchems(il,jl,kl,nch4     )*dt
     dy(il,19) = chems(il,jl,kl,nstrath2o) + dchems(il,jl,kl,nstrath2o)*dt
     dy(il,20) = chems(il,jl,kl,nn2o     ) + dchems(il,jl,kl,nn2o     )*dt
     dy(il,21) = chems(il,jl,kl,nage     ) + dchems(il,jl,kl,nage     )*dt
     h2o_tend(il) = 0.0
     do nc = 1,21
     ch_tend(il,nc) = 0.0
     if(dy(il,nc).lt.0.0) then
        ch_tend(il,nc) = -dy(il,nc)/86400.0
        dy(il,nc) = 0.0
     endif
     enddo
     if(dy(il,8).lt.1.0e-15) dy(il,8) = 1.0e-15
     if(dy(il,15).lt.1.0e-15) dy(il,15) = 1.0e-15
!
! Set water vapour values from the main model after converting to vmr or
! use stratospheric h2o: chems(...,23), which includes sedimented terms. 
! 
!  Note: values are separated into gas and solid phases in the heterogeneous 
!  chemistry subroutine
!
     h2o(il) = chems(il,jl,kl,nsphum)*1.61
!     cond = chems(il,jl,kl,2) + chems(il,jl,kl,3)
      cond = chems(il,jl,kl,nliq_wat) + chems(il,jl,kl,nice_wat)
    h2o(il) = h2o(il) + cond*1.61
     if(h2o(il) < 1.0e-7) h2o(il) = 1.0e-7
!     dagesq(il) = (chems(il,jl,levs,25) - chems(il,jl,kl,25))**2
     dagesq(il) = (chems(il,jl,levs,nage) - chems(il,jl,kl,nage))**2
!
!  No more than 5 ppmv water in the extra-tropical lower stratosphere
!
     if(h2o(il) > 5.0e-6.and.dagesq(il) > 0.01.and.pfull(il,jl,kl) > 1.0e4) &
         h2o(il) = 5.0e-6
     ozone(il,jl,kl) = chems(il,jl,kl,no3)!26)
     o3_prod(il,jl,kl) = chems(il,jl,kl,no3ch)!27)
     extinct = 0.0
     if (nextinct > 0 ) extinct = chems(il,jl,kl,nextinct)*1000.0
     if(extinct.eq.0.0) then
       aerosol(il,jl,kl) = 0.0
     elseif(extinct <= 4.0e-3) then
       aerosol(il,jl,kl) = 4.25e-6*extinct**0.68
     elseif(extinct > 4.0e-3.and.extinct <= 2.0e-2) then
       aerosol(il,jl,kl) = 1.223e-5*extinct**0.875
     elseif(extinct > 2.0e-2) then
       aerosol(il,jl,kl) = 2.0e-5*extinct 
     endif
     enddo
     call chemistry (alon(:,jl),alat(:,jl),jl,kl,dy,h2o,dagesq,ozcol(:,jl,kl),  &
       pfull(:,jl,kl),rho,temp(:,jl,kl),vtemp,cozen(:,jl),cdx,chlb,       &
       ozb(:,:,itime(2)),anat(:,jl,kl),aice(:,jl,kl),photo,solardata,     &
       ozon,cosp,cosphc,anoy,aerosol(:,jl,kl),dt,merids,ch_tend,   &
       ozone(:,jl,kl), o3_prod(:,jl,kl),h2o_tend,mype,itime)

     do il = 1,merids

!     do nc = 1,21
!     chem_tend(il,jl,kl,nc+4     ) = ch_tend(il,nc)
     chem_tend(il,jl,kl,nhno3    ) = ch_tend(il,1 )
     chem_tend(il,jl,kl,nn2o5    ) = ch_tend(il,2 )
     chem_tend(il,jl,kl,nh2o2    ) = ch_tend(il,3 )
     chem_tend(il,jl,kl,nhcl     ) = ch_tend(il,4 )
     chem_tend(il,jl,kl,nhocl    ) = ch_tend(il,5 )
     chem_tend(il,jl,kl,nclono2  ) = ch_tend(il,6 )
     chem_tend(il,jl,kl,nh2co    ) = ch_tend(il,7 )
     chem_tend(il,jl,kl,noy      ) = ch_tend(il,8 )
     chem_tend(il,jl,kl,nhobr    ) = ch_tend(il,9 )
     chem_tend(il,jl,kl,nhno4    ) = ch_tend(il,10)
     chem_tend(il,jl,kl,nhbr     ) = ch_tend(il,11)
     chem_tend(il,jl,kl,nbrono2  ) = ch_tend(il,12)
     chem_tend(il,jl,kl,nch3ooh  ) = ch_tend(il,13)
     chem_tend(il,jl,kl,nco      ) = ch_tend(il,14)
     chem_tend(il,jl,kl,nnoy     ) = ch_tend(il,15)
     chem_tend(il,jl,kl,ncly     ) = ch_tend(il,16)
     chem_tend(il,jl,kl,nbry     ) = ch_tend(il,17)
     chem_tend(il,jl,kl,nch4     ) = ch_tend(il,18)
     chem_tend(il,jl,kl,nstrath2o) = ch_tend(il,19)
     chem_tend(il,jl,kl,nn2o     ) = ch_tend(il,20)
     chem_tend(il,jl,kl,nage     ) = ch_tend(il,21)
!     enddo
     chem_tend(il,jl,kl,nsphum) = h2o_tend(il)/1.61
!     chem_tend(il,jl,kl,2:4) = 0.0
     chem_tend(il,jl,kl,nliq_wat) = 0.0
     chem_tend(il,jl,kl,nice_wat) = 0.0
     chem_tend(il,jl,kl,ncld_amt) = 0.0
!
!  Relax tracer 23 to the total vmr of PSC
!  Relax Oy to 2e-6 if it exceeds this value in the upper mesosphere
!
     chem_tend(il,jl,kl,nstrath2o) = (aice(il,jl,kl) + 3.0*anat(il,jl,kl)  -  &
                 chems(il,jl,kl,nstrath2o))/21600.0 !23 <- nstrath2o
 !    if(pfull(il,jl,kl) < 10.0.and.chems(il,jl,kl,noy) > 2.0e-6)    &
 !        chem_tend(il,jl,kl,noy) = (2.0e-6  - chems(il,jl,kl,noy))/21600.0
     enddo
     enddo
1000 continue
! 
! compute rate of change of Cly and Bry
!
     fact2 = 1.00
     do kl = 1,levs
     alats(:,:,kl) = 1.0 + (90.0 - alat(:,:))*89.0/180.0
     enddo
     age(:,:,:) = chems(:,:,:,nage)!25)
     cly(:,:,:) = chems(:,:,:,ncly)!20)
     bry(:,:,:) = chems(:,:,:,nbry)!21)
     CALL DCLY_DT(age,dfdage,tropc,alats,cly,bry,chem_tend(:,:,:,ncly),  &
        chem_tend(:,:,:,nbry),fact2,merids,lats,levs,itime)
!
!  set rates of change of Cly and Bry to zero at night, and double during
!  the daytime
!
     do jl = 1,je-js+1
     do il = 1,merids
     if(cozen(il,jl).gt.0.0) then
         chem_tend(il,jl,:,ncly) = 2.*chem_tend(il,jl,:,ncly)
         chem_tend(il,jl,:,nbry) = 2.*chem_tend(il,jl,:,nbry)
     else
         chem_tend(il,jl,:,ncly) = 0.0
         chem_tend(il,jl,:,nbry) = 0.0
     endif
     enddo
     enddo
!
!  Rainout of HNO3, Cly and Bry in the troposphere; relax age of air to zero 
!  also in troposphere, defined by delta Age < 0.1
!
     vtau10 = 1.0/(10.0*86400.0)
     do kl = 1,levs
     do jl = 1,je-js+1
     do il = 1,merids
     dagesq(il) = (chems(il,jl,levs,nage) - chems(il,jl,kl,nage))**2
     if (dagesq(il).lt.1.0e-2)  then
          chem_tend(il,jl,kl,ncly) = (1.0e-13 - chems(il,jl,kl,ncly))*vtau10
          chem_tend(il,jl,kl,nbry) = (1.0e-15 - chems(il,jl,kl,nbry))*vtau10
          chem_tend(il,jl,kl,nage) = - chems(il,jl,kl,nage)*vtau10
     endif
     enddo
     enddo
     enddo
!
! sediment nat and ice
!
     ipts = merids*lats
     CALL SEDIMENT(anat,aice,chem_tend(:,:,:,nnoy),chem_tend(:,:,:,nstrath2o),   &
         chem_tend(:,:,:,nhno3),ipts,levs,pfull,dt,mype)
     return
     end subroutine strat_chem

     end module strat_chem_driver_mod


MODULE STRAT_CHEM_MOD
! automatic conversion to free f90 compatible form 
! free.pl strat_chem_model.f  
! linewidth: 72
! file names: strat_chem_model.f 
!
!23456789-123456789-123456789-123456789-123456789-123456789-123456789-23
!/
!/ THIS MODIFICATION SET FOR THE UNIFIED MODEL IS A 
!/ REAL STRATOSPHERIC CHEMICAL MODEL         
!/ WRITTEN BY J AUSTIN (10/02/94); MODIFIED 26/7/95 FOR 49 LEVEL MODEL  
!/ REVISED FOR CLIMATE LENGTH INTEGRATIONS 24/9/96
!/ REVISED FOR PARALLEL CODE 13/11/97
!/ REVISED CHEMICAL MODEL 14/1/98
!/ REVISED CHEMICAL MODEL WITH MAINZ ANALYTIC SCHEME 1/5/99
!/ REVISED INTEGRATION SCHEME AFTER STEILET AL. 1998 14/6/99
!/ UPDATED TO VN4.5 64 LEVELS J. AUSTIN 27/1/00
!/ UPDATED CH4 OXIDATION, TROPOSPHERIC CHEMISTRY 14/2/02
!/ UPDATED FOR USE IN THE FMS, 15/12/03
!/ REVISED, 13/10/04: SIMPLIFIED PSCs, IMPROVED LONG-LIVED TRACERS,
!/      AGE OF AIR PARAMETERISATION FOR HALOGEN RATES OF CHANGE
!/

implicit none
private

public CHEMISTRY, ZEN2, DCLY_DT, SEDIMENT

contains

      SUBROUTINE CHEMISTRY (ALON, ALAT, JLZ, KL, DY, H2O, DAGESQ, OZCOL, &
        PRESS, RHO, TEMP, VTEMP, COZEN, CDX, CHLB, OZB, BNAT, BICE, PHOTO, &
        SOLARDATA, OZON, COSP, COSPHC, ANOY, AEROSOL, DT, MERIDS, CH_TEND, &
        OZONE, O3_PROD, H2O_TEND, MYPE, ITIME)
! """" ----------------------------------------------------------------*
! VERSION NUMBER   : 1   DATE:  6/10/1989.
!   NOTES          : CODE REWRITTEN TO SOLVE EQUATIONS MORE DIRECTLY
!                  : IN FAMILY MODE TO COMPARE MODEL RESULTS
! VERSION NUMBER   : 2   DATE:  1/06/1990.
!   NOTES          : REACTION SET SIMPLIFIED TO REDUCE CPU TIME
! VERSION NUMBER   : 3   DATE: 02/04/1993.
!   NOTES          : REVISED HETEROGENEOUS REACTION SCHEME
! VERSION NUMBER   : 4   DATE: 09/02/1994ET SEQ.
!   NOTES          : ADAPTED FOR USE IN THE UNIFIED MODEL
! VERSION NUMBER   : 5   DATE: 15/12/2003
!   NOTES          : ADAPTED FOR USE IN THE FMS               
! VERSION NUMBER   : 6   DATE: 23/03/2006
!   NOTES          : CONVERTED TO f90 FOR USE IN THE FMS               
! """" ----------------------------------------------------------------*
! PURPOSE          : TO INTEGRATE A ZERO-DIMENSION(POINT) CHEMICAL      
!                    MODEL ALONG A PREDETERMINED TRAJECTORY FOR A       
!                    TIME PERIOD IDT
! METHOD           : USES THE EULER BACKWARD INTEGRATION SCHEME         
! INPUT/OUTPUT LIST:
!     JLX          = LAT.  NUMBER (NEEDED FORERROR DIAGNOSTICS)        
!     KL           = LEVEL NUMBER (NEEDED FOR PHOTOLYSIS RATES)         
!     DT           = INTEGRATION TIMESTEP
!     DY           = ARRAY OF FAMILY CONCENTRATIONS
!     OZCOL        = OZONE COLUMN ABOVE PARTICLE
!     FACT         = RATIO OF OZONE TO OY (FOR PHOTOLYSIS RATES)        
!     RHO          = AIR DENSITY AT THE PARTICLE
!     TEMP         = TEMPERATURE AT THE PARTICLE
!     CHEMINC      = INCREMENTS TO FAMILY CONCENTRATIONS      
!                    AFTER THIS CALL TO OAERO
!
!  SUBPROGRAM CALLS:
!     REACTION_RATES  - CALCULATES REACTION RATES (CALLED ONCE) 
!     PSC/GAMMA_AER/HETRATES - CALCULATE HETEROGENEOUS REACTION RATES
!     PHOTO   - CALCULATES PHOTODISSOCIATION RATES (CALLED ONCE)        
!----------------------------------------------------------------------*
      IMPLICIT NONE
      

      integer ::  nchem, jimpl, ihet, nhet, irx, irx4
      PARAMETER (NCHEM=21,JIMPL=18,IHET=72,NHET=9)
      PARAMETER (IRX=33,IRX4=IRX*4) 

      integer, intent(in) :: MERIDS, JLZ, KL, MYPE
      integer, intent(in) :: ITIME(6)
      real, intent(in)    :: CDX, DT
      real, intent(in), dimension(MERIDS) :: ALON, ALAT,   &
                           DAGESQ, OZCOL, PRESS, RHO, &
                           TEMP, VTEMP, COZEN, &
                           AEROSOL
      real, intent(in), dimension(MERIDS,NCHEM) :: DY
      real, intent(in), dimension(90,15) :: CHLB
      real, intent(in), dimension(144,90) :: OZB
      real, intent(in) :: PHOTO(132,14,11,48)
      real, intent(in) :: SOLARDATA(1801)
      real, intent(in) :: OZON(11,48)
      real, intent(inout) :: COSP(14)
      real, intent(inout) :: COSPHC(48)
      real, intent(in) :: ANOY(90,48)

      real, intent(inout), dimension(MERIDS)       :: H2O, BNAT, BICE, OZONE, O3_PROD, H2O_TEND
      real, intent(inout), dimension(MERIDS,NCHEM) :: CH_TEND
              
!----------------------------------------------------------------------*
! VARIABLES PASSED TO OR FROM HIGHER SUBROUTINES
!----------------------------------------------------------------------*


      INTEGER :: ISTEP_CHEM, IC, IL, ILX, JLX, IZ, NC, KLX, IR, &
                 ITX, ITNO, ITIME_LEFT, IT, IM, IDX, ICYC, IDAYS, LEAPD,&
                 JMOD, ISC
      REAL :: AGESQ
      INTEGER :: IMON(12)
!----------------------------------------------------------------------*
! VARIABLES FOR THIS SUBROUTINE
!----------------------------------------------------------------------*
#define _ALLOC

#ifdef _ALLOC
     REAL, ALLOCATABLE, DIMENSION(:,:) :: RATES, FOTO
     REAL, ALLOCATABLE, DIMENSION(:,:) :: DYY, DYZ, DQT, DPT, RAT, &
              DYZ1, DYY0, DYY1, COND, GAMMA
#else
     REAL :: RATES(MERIDS,IHET+NHET-1)
     REAL :: FOTO(MERIDS,IRX4)
     REAL :: DYY(MERIDS,NCHEM)
     REAL :: DYZ(MERIDS,JIMPL)
     REAL :: DQT(MERIDS,NCHEM)
     REAL :: DPT(MERIDS,NCHEM)
     REAL :: RAT(MERIDS,3)
     REAL :: DYZ1(MERIDS,JIMPL)
     REAL :: DYY0(MERIDS,NCHEM)
     REAL :: DYY1(MERIDS,NCHEM)
     REAL :: COND(MERIDS,3)
     REAL :: GAMMA(MERIDS,NHET)
#endif
     REAL, DIMENSION(MERIDS) ::  CLOX, BROX, ANOZ, H2O1, H2O0, DP1, DQ1, &
            H2SO4, TICE, WH2SO4, AM, AW, ALIQ, RMEAN, ASAT, RNAT, RICE, RTT

     REAL :: DVDT, CH4, AN2O, CH4TR, AN2OTR, ANAT, AICE, VTAU10, VTAU100, &
            VTAUYR, FACT, DELT, SUM, RATIO1, RATIO2, ANUM, ADEN, ANOX, DAX, &
            DA1, DA2, DD1, DB1, DB2, DD2, DDNUM, DA3, DC2, DC3, DD3, R1, R2, &
            DD13, VDDNUM, DAC2, DA12, DD12, CLX, TAU, RAT1, BX1, AX, BX, CX, &
            XYZ, DQT1, DQT2, DQT3, T0, T1, BRX, DIFF, VRHO, BX2, &
            RATIO, X1, X2, SOL, FRAC, SOLARTIME, SOLAR27, DX1, D11, D27, F11, &
            F27, PI, O2, H2, minusT0
      DATA  PI/3.141592653589793/
      DATA  O2/0.2095/,H2/0.5E-6/                                
      DATA  ISTEP_CHEM/900/ ! Chemical timestep (s)
      DATA  ANAT,AICE/10.0, 10.0/
      DATA  IMON/0,31,59,90,120,151,181,212,243,273,304,334/
!
!  ISC IS THE SRES SCENARIO FOR CH4 AND N2O
!  1 = A1B, 2 = A2, 3 = B1, 4 = timeslice
!
      DATA  ISC/1/
! ---------------------------------------------------------------------*
!                                                                       
!   THE ARRAYS DYY AND DYZ CONTAIN THE SPECIES AMOUNTS.  THE SPECIES    
!   DYY ARE CALCULATEDEXPLICITLY, WHILE THE SPECIES DYZ ARE FOUND      
!   IMPLICITLY USING PHOTOCHEMICALEQUILIBRIUM AND RELATED APPROACHES.  
!   THE VALUES IN DYZ ARE RECALCULATED AFRESH FOREVERY CALL TO OAERO.  
!   THE ORDER OF THE SPECIES CONTAINED IN THE ARRAYS DYY AND DYZ IS:    
!      DYY                                                              
!    1. HNO3     2. N2O5   3. H2O2    4. HCL    5. HOCL  6. CLONO2      
!    7. H2CO     8. OY     9. HOBR   10. HNO4  11. HBR  12. BRONO2      
!   13. CH3OOH  14. CO    15. NAT+NY 16. CLY   17. BRY  18. CH4  
!   19. Strat H2O 20. N2O 21. AGE  
!                                                                       
!      DYZ                                                              
!    1.   O3      2.  O3P    3.  O1D    4.  NO      5.  NO2    6. NO3   
!    7.   OH      8.  HO2    9.  H     10.  CL     11.  CLO   12. BR    
!   13.   BRO    14.  CL2O2 15.  BRCL  16.  CH3O2  17.  HONO  18. N
!----------------------------------------------------------------------*

#ifdef _ALLOC
     allocate(RATES(MERIDS,IHET+NHET-1))
     allocate(FOTO(MERIDS,IRX4))
     allocate(DYY(MERIDS,NCHEM))
     allocate(DYZ(MERIDS,JIMPL))
     allocate(DQT(MERIDS,NCHEM))
     allocate(DPT(MERIDS,NCHEM))
     allocate(RAT(MERIDS,3))
     allocate(DYZ1(MERIDS,JIMPL))
     allocate(DYY0(MERIDS,NCHEM))
     allocate(DYY1(MERIDS,NCHEM))
     allocate(COND(MERIDS,3))
     allocate(GAMMA(MERIDS,NHET))
#endif
!
! Set PSCs initially to zero
!
     DO IL = 1,MERIDS
       BNAT(IL) = 0.0
       BICE(IL) = 0.0
     ENDDO
!
! FIND CONCENTRATIONS AND TRENDS OF CH4 AND N2O, ACCORDING TO THE SRES SCENARIO
!
      CALL GHGS(ITIME,ISC,CH4,AN2O,CH4TR,AN2OTR)
!   
!  RELAX TOWARDS SPECIFIC LOWER BOUNDARY VALUES WITH A TIMESCALE OF 10 DAYS
!  (SPECIES 1-15) SPECIES 16-21 ARE TREATED DIFFERENTLY
!                   
      VTAU10 = 1.0/(10.0*86400.0)
      VTAU100 = 0.1*VTAU10
      VTAUYR = 1.0/(365.25*86400.0)
      IF(KL.EQ.48) THEN                                                  
        DO IC = 1,15                                            
          IF(IC.EQ.8) THEN
            DO IL = 1,MERIDS                                            
              ILX = 1 + ALON(IL)*72/PI
              JLX = 1 + (PI*0.5 + ALAT(IL))*89.0/PI
              IF(ILX.GT.144) ILX = ILX - 144 
              CH_TEND(IL,IC) = (OZB(ILX,JLX) - DY(IL,IC))*VTAU10      
            ENDDO
          ELSE             
            DO IL = 1,MERIDS                                            
              JLX = 1 + (PI*0.5 + ALAT(IL))*89.0/PI
              CH_TEND(IL,IC) = (CHLB(JLX,IC) - DY(IL,IC))*VTAU10     
            ENDDO
          ENDIF
        ENDDO                                             
        DO IL = 1,MERIDS
          CH_TEND(IL,16) = - DY(IL,16)*VTAU10     
          CH_TEND(IL,17) = - DY(IL,17)*VTAU10     
          CH_TEND(IL,18) = (CH4 - DY(IL,18))*VTAU10     
          CH_TEND(IL,19) = (3.0E-6 - DY(IL,19))*VTAU10     
          CH_TEND(IL,20) = (AN2O - DY(IL,20))*VTAU10     
        ENDDO
        RETURN
      ENDIF             
!----------------------------------------------------------------------*
!   NO CHANGE TO CHEMICAL CONCENTRATIONS IN THE TOP LEVELS,EXCEPT 
!   FOR AGE
!
!----------------------------------------------------------------------*
!      IF(PRESS(1).LT.8.0) THEN
!        DO IL = 1,MERIDS                                            
!        CH_TEND(IL,21) = VTAUYR     
!       ENDDO
!        RETURN
!     ENDIF
!----------------------------------------------------------------------*
!   RESTRICT THE ACTUAL CHEMICAL MODEL TO STRATOSPHERIC AND 
!   MESOSPHERIC AIR
!----------------------------------------------------------------------*
      DO IL = 1,MERIDS                                               
        DO IZ = 1,NCHEM                                                
          DYY(IL,IZ) = DY(IL,IZ)*RHO(IL)                                    
        ENDDO                  
        H2O(IL) = H2O(IL)*RHO(IL)
        DYZ(IL,1) = OZONE(IL)*RHO(IL)
        DYZ1(IL,1) = OZONE(IL)*RHO(IL)
!        IF(PRESS(IL).LT.10.0.AND.OZONE(IL).GT.1.0E-5) THEN
!          DYZ(IL,1) = 1.0E-5*RHO(IL)
!          DYZ1(IL,1) = DYZ(IL,1)
!        ENDIF                                            
        DO IZ = 2,JIMPL                                                
          DYZ(IL,IZ) = 0.                                                   
          DYZ1(IL,IZ) = 0.                                                  
        ENDDO
      ENDDO                                                   
!----------------------------------------------------------------------*
!   CALL SUBROUTINES FOR TEMPERATURE DEPENDENT RATES, HETEROGENEOUS RATES 
!   AND  FOR PHOTOLYSIS RATES (ONCE PER CALL TO CHEMISTRY)
!   PASS THE PRESSURE IN PA INTO THE OTHER CHEMISTRY S/RS
!----------------------------------------------------------------------*
      CALL REACTION_RATES (RHO,TEMP,VTEMP,PRESS,RATES,MERIDS,IHET,NHET)
      IF(KL.GT.10.AND.KL.LT.28) THEN
        DO IL = 1,MERIDS
!
!  Set H2SO4 as an analytical function of age, peaking at 0.5 ppbv
!
          X1 = 3.0*(ALOG10(PRESS(IL)) - 3.5)**2
          X2 = 3.0/(10.0*DYY(IL,21) + 1.0)*(DYY(IL,21) - 1.0)**2
          H2SO4(IL) = (0.01 + 0.49*EXP(-X1-X2))*1.0E-9*RHO(IL)
        ENDDO
        CALL PSC(TEMP,PRESS,RHO,DYY,H2O,H2SO4,ANAT,AICE,COND,TICE,      &
           WH2SO4,AM,AW,ALIQ,RMEAN,ASAT,RNAT,RICE,MERIDS,NCHEM,MYPE)
        DO IL = 1,MERIDS
          BNAT(IL) = COND(IL,2)/RHO(IL)
          BICE(IL) = COND(IL,3)/RHO(IL)
        ENDDO
        CALL GAMMA_AER(TEMP,PRESS,RHO,DYY,H2O,WH2SO4,AM,AW,RMEAN,GAMMA, &
           RTT,MERIDS,NCHEM,NHET,MYPE)
        CALL HETRATES(TEMP,PRESS,RHO,DYY,H2O,TICE,ANAT,AICE,AEROSOL,    &
           RMEAN,RNAT,RICE,GAMMA,RTT,RATES,IHET,NHET,MERIDS,NCHEM,MYPE)       
      ENDIF
!
      DO NC=1,NCHEM                                                  
        DO IL = 1,MERIDS                                               
          DYY0(IL,NC) = DYY(IL,NC) ! save amounts after natice subtract 
          H2O0(IL) = H2O(IL) 
        ENDDO
      ENDDO                                                
      KLX = KL
      CALL PHOTO_RATES(VTEMP,OZCOL,COZEN,KLX,PHOTO,OZON,COSP,COSPHC,         &
                        MERIDS,IRX,IRX4,FOTO,MYPE)
! ---------------------------------------------------------------------*
!  INCLUDE VARIATIONS IN 11-YR CYCLE AND 27-DAY SOLAR CYCLE AND MULTIPLY 
!  FOTO BY SUN-EARTH DISTANCE TERM (CDX). 
!     IM....NO. OF MONTHS SINCE DEC 1949: USED TO DETERMINE SOLAR F10.7 FLUX.
!     SOLARTIME....TIME AFTER 1 JAN 1960 FOR (ARBITRARY) MIN OF 27 DAY CYCLE
!     ASSUME 12EQUAL MONTHS PER YEAR OF 365.25 DAYS
!  PHOTOLYSIS RATES ARE TAKEN TO BE LINEARLY RELATED TO THE F10.7 FLUX 
!  SOLAR MAX AND SOLAR MIN PHOTO RATES REFER TO APPROX F10.7 FLUX OF 
!  208.1 AND 72.0, CORRESPONDING TO THE YEARS 1991 AND 1996.
! ------------------------------------------------------------------
!
      IF(ISC.EQ.4) THEN
        FACT = 0.0
        SOL = 140.05
      ELSE
        IDAYS = (ITIME(1) - 1960)*365 + IMON(ITIME(2)) + ITIME(3)
        LEAPD = (ITIME(1) - 1960)/4
        JMOD = 4*LEAPD + 1960
        IF(ITIME(2).LT.3.AND.JMOD.EQ.ITIME(1)) LEAPD = LEAPD - 1
        FRAC = FLOAT(ITIME(4)*60 + ITIME(5))/1440.0
        SOLARTIME = FLOAT(IDAYS + LEAPD) + FRAC 
        ICYC = SOLARTIME/27
        SOLAR27 = (SOLARTIME - 27.0*ICYC)/27.0
        FACT = SIN(SOLAR27*2*PI)
        DX1 =  SOLARTIME*12.0/365.25 + 0.5       
        IDX = DX1
        DX1 = DX1 - IDX
        IM = 120 + IDX
        IF(IM.LT.1) IM = 1
        IF(IM.GT.1800) IM = 1800
        SOL = 0.1*(SOLARDATA(IM+1)*DX1 + (1.0 - DX1)*SOLARDATA(IM))
      ENDIF
      DO IR = 1,IRX
        DO IL = 1,MERIDS
          D11 = FOTO(IL,IR) - FOTO(IL,IR+IRX*2)
          D27 = FOTO(IL,IR+IRX) - FOTO(IL,IR+IRX*3)
          F11 = FOTO(IL,IR+IRX*2) + (SOL - 72.0)*D11/136.1
          F27 = FOTO(IL,IR+IRX*3) + (SOL - 72.0)*D27/136.1
          FOTO(IL,IR) = CDX*(F11 + F27*FACT) 
          IF(FOTO(IL,IR).LT.0.0) FOTO(IL,IR) = 0.0
        ENDDO
      ENDDO
! ---------------------------------------------------------------------*
! --- ITX    : TIMESTEP NUMBER                                          
! ---   IT     : ITERATION LOOP COUNTER                                 
! ---                                                                   
! ---   FIRST COMPUTE N + NO + NO2 + NO3 (ANOZ), CL + CLO (CLOX) AND        
! ---   BR + BRO + BRCL (BROX)                                          
! ---                                                                   
! ---------------------------------------------------------------------*
!
      ITX = 0
      ITNO = 6
      ITIME_LEFT = NINT(DT)
      DO 1100
!
      IF(ITIME_LEFT .LE. ISTEP_CHEM) THEN
        DELT = REAL(ITIME_LEFT)
        ITIME_LEFT = 0
      ELSE
        DELT = REAL(ISTEP_CHEM)
        ITIME_LEFT = ITIME_LEFT - ISTEP_CHEM
      ENDIF
      DVDT = 1.0/DELT
      ITX = ITX + 1
      IF (ITX .GE. 2) ITNO = 2
      DO 1000 IT = 1,ITNO
        DO 200 IL = 1,MERIDS
          SUM = DYY(IL,1) + 2.*DYY(IL,2) + DYY(IL,6) + DYY(IL,12) +          &
                DYY(IL,10)
          ANOZ(IL) = DYY(IL,15) - SUM
          IF(ANOZ(IL).LT.0.)  ANOZ(IL) = 0.
          DYZ(IL,5) = ANOZ(IL)
          IF(DYY(IL,1).GT.DYY(IL,15)) DYY(IL,1) = DYY(IL,15)
          SUM = DYY(IL,4) + DYY(IL,5) + DYY(IL,6)
          CLOX(IL) = DYY(IL,16) - SUM
          IF(CLOX(IL).LT.0.)  CLOX(IL) = 0.
          SUM = DYY(IL,12) + DYY(IL,11) + DYY(IL,9)
          BROX(IL) = DYY(IL,17) - SUM
          IF(BROX(IL).LT.0.)  BROX(IL) = 0.
  200   ENDDO
!----------------------------------------------------------------------*
!---
!---         COMPUTE PHOTOCHEMICAL EQUILIBRIUM FOR THE O1D/O3 AND       
!---         O3P/O3 RATIOS
!----------------------------------------------------------------------*
        DO 900 IL=1,MERIDS
          ANUM = (FOTO(IL,2) + FOTO(IL,28)*DYY(IL,20)/DYY(IL,8))
          ADEN =                                                            &
               (RATES(IL,3) + RATES(IL,9)*H2O(IL) +                         &
               RATES(IL,30)*DYY(IL,18) + RATES(IL,66)*DYY(IL,20) +          &
               RATES(IL,70)*DYY(IL,20))
          RATIO2 = ANUM/ADEN
          ANUM = RATES(IL,3)*RATIO2 + FOTO(IL,3) +                          &
                 (2.*FOTO(IL,1)*O2*RHO(IL) + DYZ(IL,5)*FOTO(IL,4) +         &
                  DYZ(IL,4)*FOTO(IL,31) +                                   &
                  DYZ(IL,6)*FOTO(IL,6) + RATES(IL,51)*DYZ(IL,7)**2)/        &
                  DYZ(IL,1)
          ADEN = RATES(IL, 1)           + RATES(IL, 2)*DYZ(IL, 1) +          &
                 RATES(IL, 5)*DYZ(IL,5) + RATES(IL,11)*DYZ(IL, 8) +          &
                 RATES(IL,12)*DYZ(IL,7) + RATES(IL,21)*DYZ(IL,11) +          &
                 RATES(IL,24)*DYY(IL,6) + RATES(IL,44)*DYY(IL, 9)           
          RATIO1 = ANUM/ADEN
          SUM = 1. + RATIO1 + RATIO2
          RAT(IL,1) = 1./SUM
          DYZ(IL,1) = DYY(IL,8)*RAT(IL,1)
          DYZ(IL,2) = RATIO1*DYZ(IL,1)
          DYZ(IL,3) = RATIO2*DYZ(IL,1)
          RAT(IL,2) = RATIO1*RAT(IL,1)
          RAT(IL,3) = RATIO2*RAT(IL,1)
          IF(DYZ(IL,1).LT.1.0E-15*RHO(IL)) THEN
            XYZ = 1.0E-15*RHO(IL) - DYZ(IL,1)
            DYZ(IL,1) = 1.0E-15*RHO(IL)
            DYZ(IL,2) = DYZ(IL,2) + XYZ
            RAT(IL,1) = DYZ(IL,1)/DYY(IL,8)
            RAT(IL,2) = DYZ(IL,2)/DYY(IL,8)
            RAT(IL,3) = 1.0 - RAT(IL,1) - RAT(IL,2)
            IF(RAT(IL,3).LT.0.0) RAT(IL,3) = 0.0
          ENDIF
  900   ENDDO
!----------------------------------------------------------------------*
!--
!---         APPLY PHOTOCHEMICAL EQUILIBRIUM FOR NO3 SUBJECT TO
!---        ENOUGH NOZ BEING PRESENT
!----------------------------------------------------------------------*
        DO 910 IL = 1,MERIDS
          ADEN = RATES(IL,7)*DYZ(IL,5) + FOTO(IL,6) + FOTO(IL,7) +          &
                 RATES(IL,53)*DYZ(IL,4) + RATES(IL,58)*DYZ(IL,5) +          &
                 2.*RATES(IL,59)*DYZ(IL,6) + RATES(IL,62)*DYY(IL,7)            
          IF(ADEN.LT.DVDT.AND.FOTO(IL,6).NE.0.) ADEN = DVDT                 
          IF(ADEN.NE.0.) THEN
            ANUM = (FOTO(IL,8) + RATES(IL,8))*DYY(IL,2) +                   &
              RATES(IL,19)*DYZ(IL, 7)*DYY(IL,1) +                           &
              RATES(IL, 6)*DYZ(IL, 5)*DYZ(IL,1) +                           &
             (RATES(IL,24)*DYZ(IL, 2) + FOTO(IL,12))*DYY(IL,6) +            &
               FOTO(IL,17)*DYY(IL,12)
            DYZ(IL,6) = ANUM/ADEN
            IF(DYZ(IL,6).GT.(0.5*ANOZ(IL))) DYZ(IL,6) = 0.5*ANOZ(IL)
          ENDIF           
!----------------------------------------------------------------------*
!---        APPLY PHOTOCHEMICAL EQUILIBRIUM FOR N SUBJECT TO         
!---       ENOUGH NOZ BEING PRESENT
!---
!----------------------------------------------------------------------*
          ADEN = RATES(IL,67)*DYZ(IL,4) + RATES(IL,68)*O2*RHO(IL) +         &
                 RATES(IL,71)*DYZ(IL,5)
          ANUM = FOTO(IL,31)*DYZ(IL,4)
          DYZ(IL,18) = ANUM/ADEN
          IF(DYZ(IL,18).GT.(0.5*ANOZ(IL))) DYZ(IL,18) = 0.5*ANOZ(IL)
!----------------------------------------------------------------------*
!---
!---    COMPUTE NO/NO2 RATIO ASSUMING PHOTOCHEMICAL EQUILIBRIUM         
!---
! ---   SOLVE SIMULTANEOUSEQUATIONS
! ---      DA1*NO - DA2*NO2 = DD1
! ---    - DB1*NO + DB2*NO2 = DD2
! ---
! ---       DA1*NO......THE RATE OF LOSS TERM OF NO
! ---       DA2*NO2.....THE RATE OF PRODUCTION OF NO FROM NO2
! ---       DB1*NO......THE RATE OF PRODUCTION OF NO2 FROM NO
! ---       DB2*NO2.....THE RATE OF LOSS TERM OF NO2
! ---       DD1.........THE TOTAL PRODUCTION TERM (P) FOR NO LESS
! ---                   CONTRIBUTIONS FROM NO2
! ---       DD2.........THE TOTAL PRODUCTION TERM (P) FOR NO2 LESS
! ---                   CONTRIBUTIONS FROM NO
! ---------------------------------------------------------------------*
          ANOX = ANOZ(IL) - DYZ(IL,6) - DYZ(IL,18)
          DAX = RATES(IL, 4)*DYZ(IL, 1) + RATES(IL,18)*DYZ(IL, 8) +          &
                RATES(IL,22)*DYZ(IL,11) + RATES(IL,43)*DYZ(IL,13) +         &
                RATES(IL,53)*DYZ(IL,6) + RATES(IL,55)*DYZ(IL,16) +          &
                RATES(IL,64)*DYZ(IL,2)          
          DA1 = DAX + RATES(IL,65)*DYZ(IL,7) + RATES(IL,67)*DYZ(IL,18) +    &
                FOTO(IL,31)
          DA2 = FOTO(IL,4) + RATES(IL,5)*DYZ(IL,2) +                        &
                RATES(IL,58)*DYZ(IL,6)
          DD1 = FOTO(IL,7)*DYZ(IL,6) + FOTO(IL,26)*DYZ(IL,17) +             &
                RATES(IL,68)*DYZ(IL,18)*O2*RHO(IL) +                        &
                2.*RATES(IL,66)*DYY(IL,20)*DYZ(IL,3)
          DB1 = DAX + RATES(IL,53)*DYZ(IL,6)
          DB2 = DA2 + RATES(IL, 6)*DYZ(IL, 1) + RATES(IL, 7)*DYZ(IL, 6) +    &
                      RATES(IL,17)*DYZ(IL, 7) + RATES(IL,23)*DYZ(IL,11) +    &
                      RATES(IL,40)*DYZ(IL,13) + RATES(IL,49)*DYZ(IL, 8) +   &
                      RATES(IL,71)*DYZ(IL,18)
          DD2 = RATES(IL, 8)*DYY(IL,2) + FOTO(IL, 5)*DYY(IL,1) +             &
                 FOTO(IL, 6)*DYZ(IL,6) + FOTO(IL, 8)*DYY(IL,2) +             &
               (RATES(IL,50)*DYZ(IL,7) + FOTO(IL,25) + RATES(IL,63))*       &
              DYY(IL,10) + 2.*RATES(IL,59)*DYZ(IL,6)**2 +                   &
              RATES(IL,60)*DYZ(IL,7)*DYZ(IL,17)
          DDNUM = DD2*DA1 + DB1*DD1
          IF(DDNUM.NE.0.) THEN
            RATIO = (DB2*DD1 + DA2*DD2)/DDNUM
          ELSE
            RATIO = 0.
          ENDIF
          DYZ(IL,5) = ANOX/(1. + RATIO)
          DYZ(IL,4) = RATIO*DYZ(IL,5)
  910   ENDDO
!----------------------------------------------------------------------*
!---
!---    COMPUTE THE BR/BRO AND BR/BRCL RATIO FROM THE EQUATIONS         
!---
! ---   SOLVE THREE WAY SIMULTANEOUSEQUATIONS                          
! ---      DA1*BR - DA2*BRO - DA3*BRCL = DD1                            
! ---    - DB1*BR + DB2*BRO            = DD2                            
! ---             - DC2*BRO + DC3*BRCL = DD3                            
! ---
! ---------------------------------------------------------------------*
        DO 930 IL = 1,MERIDS
          DA1 = RATES(IL,39)*DYZ(IL, 1) + RATES(IL,45)*DYZ(IL,8) +           &
                RATES(IL,46)*DYY(IL, 7)
          DA2 = RATES(IL,41)*DYZ(IL,11) + RATES(IL,43)*DYZ(IL,4) +           &
                 FOTO(IL,19)
          DA3 =  FOTO(IL,24)
          DD1 = RATES(IL,    47)*DYZ(IL, 7)*DYY(IL,11) +                     &
             2.*RATES(IL,IHET+7)*DYY(IL,11)*DYY(IL, 9) +                     &
                 FOTO(IL,    17)*DYY(IL,12)            +                     &
                 FOTO(IL,    18)*DYY(IL, 9)
          DB1 = RATES(IL,    39)*DYZ(IL, 1)
          DB2 = DA2 + RATES(IL,40)*DYZ(IL, 5) + RATES(IL,42)*DYZ(IL,8) +     &
                      RATES(IL,48)*DYZ(IL,11)
          DD2 = RATES(IL,44)*DYZ(IL, 2)*DYY(IL,9)
          DC2 = RATES(IL,48)*DYZ(IL,11)
          DC3 = DA3
          DD3 = RATES(IL,IHET+5)*DYY(IL, 9)*DYY(IL,4) +                      &
                RATES(IL,IHET+6)*DYY(IL,11)*DYY(IL,5)
!
          R1 = 0.0
          R2 = 0.0
          DD13 = DD1*DC3 + DD3*DA3
          DDNUM = DD13*DB1 + DD2*DA1*DC3
          IF(DDNUM.GT.0.0) THEN
            VDDNUM = 1.0/DDNUM
            DAC2 = DA2*DC3 + DC2*DA3
            R1 = (DD13*DB2 + DD2*DAC2)*VDDNUM
            DA12 = DA1*DB2 - DA2*DB1
            IF(DA12.LT.0.0) DA12 = 0.0
            DD12 = DA1*DD2 + DB1*DD1
            R2 = (DD12*DC2 + DD3*DA12)*VDDNUM
          ENDIF
          IF (FOTO(IL,24).GT.0.0) THEN    
            DYZ(IL,13) = BROX(IL)/(1. + R1 + R2)
            DYZ(IL,12) = R1*DYZ(IL,13)
            DYZ(IL,15) = R2*DYZ(IL,13)
          ELSE
            DYZ(IL,13) = 0.0
            DYZ(IL,12) = 0.0
            DYZ(IL,15) = BROX(IL)
          ENDIF
  930   ENDDO
!----------------------------------------------------------------------*
!---
!---    COMPUTE CL/CLO RATIO ASSUMING PHOTOCHEMICAL EQUILIBRIUM         
!---
! ---   SOLVE SIMULTANEOUS EQUATIONS
! ---      DA1*CL - DA2*CLO = DD1
! ---    - DB1*CL + DB2*CLO = DD2
! ---
! ---------------------------------------------------------------------*
        DO 940 IL = 1,MERIDS
          DA1 = RATES(IL,20)*DYZ(IL, 1) + RATES(IL,25)*DYY(IL,18) +         &
                RATES(IL,27)*DYZ(IL, 8) + RATES(IL,33)*DYY(IL, 7)      
          DA2 = RATES(IL,21)*DYZ(IL, 2) + RATES(IL,22)*DYZ(IL, 4) +         &
                RATES(IL,29)*DYZ(IL, 7) + RATES(IL,41)*DYZ(IL,13)      
          DD1 = RATES(IL,26)*DYZ(IL, 7)*DYY(IL,4) + FOTO(IL,15)*DYY(IL,5) +  &
              2.*FOTO(IL,16)*DYZ(IL,14) +  FOTO(IL,12)*DYY(IL,6) +           &
                 FOTO(IL,24)*DYZ(IL,15) +  FOTO(IL,33)*DYY(IL,4)
          DB1 = RATES(IL,20)*DYZ(IL, 1)
          DB2 = RATES(IL,21)*DYZ(IL, 2) + RATES(IL,22)*DYZ(IL, 4)    +       &
                RATES(IL,23)*DYZ(IL, 5) + RATES(IL,28)*DYZ(IL, 8)    +       &
               (RATES(IL,29) + RATES(IL,69))*DYZ(IL, 7) +                   &
                RATES(IL,37)*DYZ(IL,11)*2. +                                &
               (RATES(IL,41) + RATES(IL,48))*DYZ(IL,13)
          DD2 = RATES(IL,24)*DYZ(IL, 2)*DYY(IL,6) +                          &
             2.*RATES(IL,38)*DYZ(IL,14)
          DDNUM = DD2*DA1 + DB1*DD1
          IF(DDNUM.NE.0.) THEN
            RATIO = (DB2*DD1 + DA2*DD2)/DDNUM
          ELSE
            RATIO = 0.
          ENDIF
          CLX = CLOX(IL) - DYZ(IL,15)
          IF(CLX.LT.0.0) CLX = 0.0
          IF(FOTO(IL,15).GT.0.0)  THEN
            TAU = RATES(IL,37)/(FOTO(IL,16) + RATES(IL,38))                
            RAT1 = TAU*DYZ(IL,11)
            DYZ(IL,11) = CLX/(1. + RATIO + 2.*RAT1)
            RAT1 = TAU*DYZ(IL,11)
            DYZ(IL,11) = CLX/(1. + RATIO + 2.*RAT1)
            DYZ(IL,10) = DYZ(IL,11)*RATIO
            DYZ(IL,14) = DYZ(IL,11)*RAT1
          ELSE
            DYZ(IL,10) = 0.
            DYZ(IL,11) = 0.
            DYZ(IL,14) = CLX*0.5
          ENDIF
  940   ENDDO
!----------------------------------------------------------------------*
!---
!---    COMPUTE HO2 AND OH ASSUMING PHOTOCHEMICAL EQUILIBRIUM           
!---
! ---   SOLVE SIMULTANEOUSEQUATIONS
! ---      DA1*OH - DA2*HO2 = DD1
! ---    - DB1*OH + DB2*HO2 = DD2
! ---
! ---------------------------------------------------------------------*
        DO 950 IL = 1,MERIDS
          BX1 = RATES(IL,17)*DYZ(IL, 5) +                                   &
                RATES(IL,19)*DYY(IL, 1) + RATES(IL,26)*DYY(IL, 4) +         &
                RATES(IL,31)*DYY(IL,18) + RATES(IL,50)*DYY(IL,10) +         &
                RATES(IL,57)*DYY(IL,13) + RATES(IL,60)*DYZ(IL,17) +         &
                RATES(IL,65)*DYZ(IL,4) + RATES(IL,69)*DYZ(IL,11)
          BX2 = RATES(IL,27)*DYZ(IL,10) + RATES(IL,28)*DYZ(IL,11) +         &
                RATES(IL,42)*DYZ(IL,13) + RATES(IL,45)*DYZ(IL,12) +         &
                RATES(IL,49)*DYZ(IL, 5) + RATES(IL,56)*DYZ(IL,16)
          DB1 = RATES(IL,10)*DYZ(IL, 1) + RATES(IL,12)*DYZ(IL, 2) +         &
                RATES(IL,29)*DYZ(IL,11) + RATES(IL,32)*DYY(IL, 7) +         &
                RATES(IL,36)*DYY(IL,3) +  RATES(IL,47)*DYY(IL,11) +         &
                RATES(IL,52)*DYY(IL,14) + RATES(IL,54)*H2*RHO(IL)
          DA1 = DB1 + BX1 + RATES(IL,16)*DYZ(IL, 8) +                       &
                 (RATES(IL,35) + RATES(IL,51))*DYZ(IL,7)*2.
          DA2 = RATES(IL,11)*DYZ(IL, 2) + RATES(IL,15)*DYZ(IL,1) +          &
                RATES(IL,18)*DYZ(IL, 4)
          DB2 = RATES(IL,16)*DYZ(IL, 7) + RATES(IL,34)*DYZ(IL,8)*2. +       &
                DA2 + BX2
          DD1 = DYZ(IL,3)*(2.*RATES(IL, 9)*H2O(IL) +                        &
                              RATES(IL,30)*DYY(IL,18)) +                    &
                RATES(IL,44)*DYZ(IL,2)*DYY(IL,9) +                          &
                2.*RATES(IL,61)*DYZ(IL,16)**2 +                             &
                 FOTO(IL, 5)*DYY(IL, 1) +  FOTO(IL,15)*DYY(IL, 5) +         &
              2.*FOTO(IL,11)*DYY(IL, 3) +  FOTO(IL,18)*DYY(IL, 9) +         &
                FOTO(IL,26)*DYZ(IL,17) +                                    &
! FOTO(IL,27) IS TAKEN AS A PROXY FOR CH3O2 + HV --> H2CO + OH      
                FOTO(IL,27)*(DYZ(IL,16)+DYY(IL,13)) +                       &
                FOTO(IL,32)*H2O(IL)
          DD2 = (RATES(IL,33)*DYZ(IL,10) +                                  &
                RATES(IL,46)*DYZ(IL,12) + FOTO(IL,13)*2.0)*DYY(IL,7) +      &
                RATES(IL,55)*DYZ(IL,4)*DYZ(IL,16) +                         &
                RATES(IL,62)*DYZ(IL,6)*DYY(IL,7) +                          &
                RATES(IL,63)*DYY(IL,10) + FOTO(IL,25)*DYY(IL,10) +          &
                FOTO(IL,27)*DYY(IL,13) +                                    &
                FOTO(IL,32)*H2O(IL)  +  FOTO(IL,33)*DYY(IL,4) +             &
                FOTO(IL,32)*DYY(IL,18)*1.53/1.83
          DDNUM = DB2*DD1 + DA2*DD2
          IF(DD1.NE.0.0.AND.DD2.NE.0.0) THEN
            RATIO2 = (DD2*DA1 + DB1*DD1)/DDNUM
            AX = 4.*(RATES(IL,16)*RATIO2 + RATES(IL,34)*RATIO2**2 +        &
                  RATES(IL,35) + RATES(IL,51))
            BX = BX1 + RATIO2*BX2
            CX = DD1 + DD2
            IF(CX.LT.0.) CX = 0.0
            IF(BX.LT.0.) BX = 0.0
            IF(BX.EQ.0.) THEN
              DYZ(IL,7) = SQRT(2.*CX/AX)
            ELSE
              DYZ(IL,7) = (-BX + SQRT(BX**2 + 2.*AX*CX))/AX
            ENDIF
            DYZ(IL,8) = RATIO2*DYZ(IL,7)
          ELSE
            DYZ(IL,7) = 0.0
            DYZ(IL,8) = 0.0
          ENDIF
          RATIO1 = RATES(IL,12)*DYZ(IL,2)/(RATES(IL,14) +                   &
                   RATES(IL,13)*DYZ(IL,1))
          DYZ(IL,9) = RATIO1*DYZ(IL,7)
  950   ENDDO
!----------------------------------------------------------------------*
!---
!---    COMPUTE CH3O2 AND HONO ASSUMING PHOTOCHEMICAL EQUILIBRIUM           
!---
!----------------------------------------------------------------------*
        DO 960 IL = 1,MERIDS
          AX = 4.*RATES(IL,61)
!
! FOTO(IL,27) IS TAKEN AS A PROXY FOR CH3O2 + HV --> H2CO + OH
!
          BX = RATES(IL,55)*DYZ(IL,4) + RATES(IL,56)*DYZ(IL,8) +            &
               FOTO(IL,27)
          CX = (RATES(IL,25)*DYZ(IL,10) + RATES(IL,30)*DYZ(IL,3) +          &
                RATES(IL,31)*DYZ(IL,7) + FOTO(IL,32)*1.53/1.83)*DYY(IL,18) + &
                RATES(IL,57)*DYZ(IL,7)*DYY(IL,13)
          IF(CX.LT.0.) CX = 0.0
          IF(BX.LT.0.) BX = 0.0
          IF(BX.EQ.0.) THEN
            DYZ(IL,16) = SQRT(2.*CX/AX)
          ELSE
            DYZ(IL,16) = (-BX + SQRT(BX**2 + 2.*AX*CX))/AX
          ENDIF
  960   ENDDO!CONTINUE
        DO 970 IL = 1,MERIDS
          DDNUM = RATES(IL,60)*DYZ(IL,7) + FOTO(IL,26)
          IF(DDNUM.NE.0.0)  THEN
            DYZ(IL,17) = RATES(IL,65)*DYZ(IL,7)*DYZ(IL,4)/DDNUM
          ELSE
            DYZ(IL,17) = RATES(IL,65)*DYZ(IL,4)/RATES(IL,60)
          ENDIF
  970   ENDDO!CONTINUE
        IF(IT.EQ.1.AND.ITX.EQ.1) THEN
          DO IC = 1,JIMPL
            DO IL = 1,MERIDS
              DYZ1(IL,IC) = DYZ(IL,IC)
            ENDDO
          ENDDO
        ELSE
          DO IC = 1,JIMPL
            DO IL = 1,MERIDS
              XYZ = (DYZ(IL,IC) + DYZ1(IL,IC))*0.5
              DYZ(IL,IC) = XYZ
              DYZ1(IL,IC) = XYZ
            ENDDO
          ENDDO
        ENDIF
!----------------------------------------------------------------------*
!   INTEGRATE MODEL FOR SINGLE TIMESTEP OF LENGTH DT
! --- THE CHEMISTRY SCHEME CALCULATES DESTRUCTION AND
! --- PRODUCTION TERMS READY FOR AN INTEGRATION OF THE FORM
! ---
! ---                 Y = P/Q + (Y - P/Q)*EXP(-Q.DT)
! ---
! ---EXCEPT WHERE Q.DT IS SMALL, WHERE 
! ---   
! ---                 Y = (Y/DT + P)/(Q + 1/DT)
! ---
! --- (FIRST ORDER EULER BACKWARD SCHEME) IS USED.
! ---
! ---   DQT : TOTAL DESTRUCTION RATE (FOR EACH EXPLICIT SPECIES)        
! ---   DPT : TOTAL PRODUCTION RATE (FOR EACH EXPLICIT SPECIES)         
! ---
! ---------------------------------------------------------------------*
        DO 990 IL = 1,MERIDS
          JLX = 1 + (PI*0.5 + ALAT(IL))*89.0/PI
!
!   HNO3
!
          DPT(IL,1) = RATES(IL,17)*DYZ(IL,5)*DYZ(IL,7) +                    &
                      RATES(IL,62)*DYZ(IL,6)*DYY(IL,7) +                    &
                      RATES(IL,IHET+1)*DYY(IL, 2)*DYY(IL, 4)    +           &
                      RATES(IL,IHET+2)*H2O(IL)*DYY(IL, 2)*2. +              &
                      RATES(IL,IHET+3)*H2O(IL)*DYY(IL, 6)    +              &
                      RATES(IL,IHET+4)*DYY(IL, 6)*DYY(IL, 4)
!
!  The HNO3 production term from heterogeneous reaction BrONO2 + H2O
!  is sometimes rather fast leading to too much HNO3 extrapolated to the 
!  full timestep. Hence this term is neglected since it should be small in 
!  any case.      
!     *            RATES(IL,IHET+8)*DYY(IL,12)*H2O(IL)  
!
          DQT(IL,1) = RATES(IL,19)*DYZ(IL,7) + FOTO(IL,5)            
!       
!   N2O5
!
          DPT(IL,2) = RATES(IL,7)*DYZ(IL,5)*DYZ(IL,6)
          DQT(IL,2) = RATES(IL,8) + FOTO(IL,8) +                            &
                      RATES(IL,IHET+1)*DYY(IL, 4) +                         &
                      RATES(IL,IHET+2)*H2O(IL)
!
!  H2O2
!
          DPT(IL,3) = RATES(IL,34)*DYZ(IL,8)**2 +                           &
                      RATES(IL,35)*DYZ(IL,7)**2
          DQT(IL,3) = FOTO(IL,11) + RATES(IL,36)*DYZ(IL,7)
!
!  HCl
!
          DPT(IL,4) = DYZ(IL,10)*(RATES(IL,27)*DYZ(IL, 8)  +                &
                                  RATES(IL,33)*DYY(IL, 7)  +                &
                                  RATES(IL,25)*DYY(IL,18)) +                &
                      RATES(IL,69)*DYZ(IL,11)*DYZ(IL,7)
          DQT(IL,4) = RATES(IL,    26)*DYZ(IL, 7)    +                      &
                      RATES(IL,  IHET)*DYY(IL, 5)    +                      &
                      RATES(IL,IHET+1)*DYY(IL, 2)    +                      &
                      RATES(IL,IHET+4)*DYY(IL, 6)    +                      &
                      RATES(IL,IHET+5)*DYY(IL, 9)    +  FOTO(IL,33)
!
!  HOCl
!
          DPT(IL,5) = RATES(IL,    28)*DYZ(IL,11)*DYZ(IL, 8) +              &
                      RATES(IL,IHET+3)*DYY(IL, 6)*H2O(IL)
          DQT(IL,5) = FOTO(IL,15)                 +                         &
                      RATES(IL,  IHET)*DYY(IL, 4) +                         &
                      RATES(IL,IHET+6)*DYY(IL,11)
!
!  ClONO2
!
          DPT(IL,6) = RATES(IL,23)*DYZ(IL,11)*DYZ(IL,5)
          DQT(IL,6) = RATES(IL,24)*DYZ(IL, 2) + FOTO(IL,12) +               &
                      RATES(IL,IHET+3)*H2O(IL) +                            &
                      RATES(IL,IHET+4)*DYY(IL, 4)
!
!  H2CO
!
          DPT(IL,7) = DYZ(IL,16)*(RATES(IL,55)*DYZ(IL,4) +                  &
                    2.*RATES(IL,61)*DYZ(IL,16)) + FOTO(IL,27)*DYY(IL,13)
          DQT(IL,7) = FOTO(IL,13) + FOTO(IL,14) +                           &
                      RATES(IL,32)*DYZ(IL, 7) + RATES(IL,33)*DYZ(IL,10) +   &
                      RATES(IL,46)*DYZ(IL,12) + RATES(IL,62)*DYZ(IL,6)          
!
! Oy
!
          DPT(IL,8) = RATES(IL,51)*DYZ(IL,7)**2 +                           &
                   2.*FOTO(IL,1)*O2*RHO(IL) + FOTO(IL, 4)*DYZ(IL, 5) +      &
                      FOTO(IL,19)*DYZ(IL,13) + FOTO(IL,28)*DYY(IL,20)    
          DQT1 = RAT(IL,1)*                                                 &
                (RATES(IL, 4)*DYZ(IL, 4) +                                  &
                RATES(IL,10)*DYZ(IL, 7) + RATES(IL,13)*DYZ(IL, 9) +         &
                RATES(IL,15)*DYZ(IL, 8) + RATES(IL,20)*DYZ(IL,10) +         &
                RATES(IL,39)*DYZ(IL,12))
!     &      RATES(IL,15)*DYZ(IL, 8) + RATES(IL,20)*DYZ(IL,10))
          DQT2 = RAT(IL,2)*                                                 &
            (2.*RATES(IL, 2)*DYZ(IL, 1) + RATES(IL, 5)*DYZ(IL, 5) +         &
                RATES(IL,11)*DYZ(IL, 8) + RATES(IL,12)*DYZ(IL, 7) +         &
                RATES(IL,21)*DYZ(IL,11) + RATES(IL,24)*DYY(IL, 6) +         &
                RATES(IL,44)*DYY(IL,9)  + RATES(IL,64)*DYZ(IL, 4))
          DQT3 = RAT(IL,3)*                                                 &
               (RATES(IL, 9)*H2O(IL) +                                      &
                RATES(IL,30)*DYY(IL,18))
!      DQT4 = RATES(IL,39)*OZONE(IL)*ISTEP_CHEM
!      IF(DQT4.GT.1.0) DQT4 = 1.0 
!      DQT(IL,8) = DQT1 + DQT2 + DQT3 + DQT4*DYZ(IL,12)/(ISTEP_CHEM*OZONE(IL))
          DQT(IL,8) = DQT1 + DQT2 + DQT3 
!
!  HOBr
!
          DPT(IL,9) = RATES(IL,    42)*DYZ(IL,13)*DYZ(IL, 8) +              &
                      RATES(IL,IHET+8)*H2O(IL)*DYY(IL,12)
          DQT(IL,9) = FOTO(IL,18) + RATES(IL,44)*DYZ(IL,2) +                &
                      RATES(IL,IHET+5)*DYY(IL, 4)          +                &
                      RATES(IL,IHET+7)*DYY(IL,11)
!  
!  HNO4
!
          DPT(IL,10) = RATES(IL,49)*DYZ(IL,8)*DYZ(IL,5)
          DQT(IL,10) = FOTO(IL,25) + RATES(IL,50)*DYZ(IL,7) +               &
                       RATES(IL,63)
!
!  HBr
!
          DPT(IL,11) = RATES(IL,45)*DYZ(IL,12)*DYZ(IL,8) +                  &
                       RATES(IL,46)*DYZ(IL,12)*DYY(IL,7)
          DQT(IL,11) = RATES(IL,    47)*DYZ(IL, 7) +                        &
                       RATES(IL,IHET+6)*DYY(IL, 5) +                        &
                       RATES(IL,IHET+7)*DYY(IL, 9)
!
!  BrONO2
!
          DPT(IL,12) = RATES(IL,40)*DYZ(IL,13)*DYZ(IL,5)
          DQT(IL,12) = FOTO(IL,17) + RATES(IL,IHET+8)*H2O(IL)
!
!  CH3OOH
!
          DPT(IL,13) = RATES(IL,56)*DYZ(IL,16)*DYZ(IL,8)
          DQT(IL,13) = FOTO(IL,27) + RATES(IL,57)*DYZ(IL,7)
!
! CO
!
          DPT(IL,14) = DYY(IL,7)*                                           &
                  (RATES(IL,32)*DYZ(IL,7) + RATES(IL,33)*DYZ(IL,10) +       &
                   RATES(IL,46)*DYZ(IL,12) + RATES(IL,62)*DYZ(IL,6) +       &
                   FOTO(IL,13) + FOTO(IL,14))
          DQT(IL,14) = RATES(IL,52)*DYZ(IL,7)
!
!  NOY + NAT: Normal Stratospheric terms, relax towards ANOY in the 
!  troposphere
!
          AGESQ = 1.0E-2
          IF(DAGESQ(IL).LT.AGESQ) THEN
            DPT(IL,15) = ANOY(JLX,KL)*RHO(IL)*VTAU10
            DQT(IL,15) = VTAU10
          ELSE
            DPT(IL,15) = 2.*RATES(IL,66)*DYZ(IL,3)*DYY(IL,20)
            DQT(IL,15) = 2.*DYZ(IL,18)*                                     &
                   (RATES(IL,67)*DYZ(IL,4)+RATES(IL,71)*DYZ(IL,5))/DYY(IL,15)
          ENDIF
!
!  Cly: solved separately after call to chemistry; set to zero here
!
          DPT(IL,16) = 0.0
          DQT(IL,16) = 0.0
!
!  Bry: solved separately after call to chemistry; set to zero here
!
          DPT(IL,17) = 0.0
          DQT(IL,17) = 0.0
!
!  CH4: Production rate assumes relaxation to a uniform tropospheric value 
!  with a 10 day time scale
!  DAGESQ < 0.01 is used to denote the troposphere. 
!
          IF(DAGESQ(IL).LT.AGESQ) THEN
            DPT(IL,18) = CH4*VTAU10*RHO(IL)
            DQT(IL,18) = VTAU10 
          ELSE
            DPT(IL,18) = 0.0
!  
! Mesospheric loss of CH4 by lyman alpha photolysis is taken to be the H2O 
! photolysis rate weighted by the ratio of the cross sections
! 
            DQT(IL,18) = RATES(IL,25)*DYZ(IL,10) + RATES(IL,30)*DYZ(IL,3) +   &
                         RATES(IL,31)*DYZ(IL,7) + FOTO(IL,32)*1.53/1.83
          ENDIF
!
!  h2ostrat: not used
!
          DPT(IL,19) = 0.0
          DQT(IL,19) = 0.0
!
!  N2O: Production rate assumes relaxation to a uniform tropospheric value 
!  with a 10 day time scale
!  DAGESQ < 0.01 is used to denote the troposphere. 
!
          IF(DAGESQ(IL).LT.AGESQ) THEN
            DPT(IL,20) = AN2O*VTAU10*RHO(IL)
            DQT(IL,20) = VTAU10
          ELSE
            DPT(IL,20) = RATES(IL,71)*DYZ(IL,5)*DYZ(IL,18)
            DQT(IL,20) = (RATES(IL,66)+RATES(IL,70))*DYZ(IL,3) +           &
                          FOTO(IL,28)
          ENDIF
!
!  AGE OF AIR: Increase at the rate of 1 per second outside the troposphere.
!  Results expressed in years. Relax towards zero with a 10 
!  day timescale in the troposphere, denoted by DAGESQ less than 0.01 
!
          IF(DAGESQ(IL).LT.AGESQ) THEN
            DPT(IL,21) = 0.0
            DQT(IL,21) = VTAU10
          ELSE
            DPT(IL,21) = VTAUYR*RHO(IL)
            DQT(IL,21) = 0.0
          ENDIF
!
!  H2O + ICE
!
          DP1(IL) = DYZ(IL,7)*( RATES(IL,16)*DYZ(IL,8) +                    &
             RATES(IL,19)*DYY(IL,1) + RATES(IL,26)*DYY(IL,4) +              &
             RATES(IL,31)*DYY(IL,18) + RATES(IL,32)*DYY(IL,7) +             &
             RATES(IL,36)*DYY(IL,3) + RATES(IL,50)*DYY(IL,10) +             &
             RATES(IL,47)*DYY(IL,11) +                                      &
             RATES(IL,51)*DYZ(IL,7) + RATES(IL,54)*H2*RHO(IL) +             &
             RATES(IL,57)*DYY(IL,13) + RATES(IL,60)*DYZ(IL,17) )
          DQ1(IL) = FOTO(IL,32) + RATES(IL,9)*DYZ(IL,3)
  990   ENDDO
! ---------------------------------------------------------------------*
! ---
! ---  INTEGRATE NCHEM SPECIES EXPLICITLY
! ---
! ---------------------------------------------------------------------*
        DO 980 NC = 1,NCHEM
          DO  IL = 1,MERIDS
            T0 = DQT(IL,NC)/DVDT
            IF(T0 .LT. 1.0E-6) THEN 
              DYY1(IL,NC) = (DYY(IL,NC)*DVDT + DPT(IL,NC))/(DQT(IL,NC)+DVDT)
! The following line changes answers but should be equivalent to the above..
!              DYY1(IL,NC) = (DYY(IL,NC) + DPT(IL,NC)/DVDT)/(T0+1.0)
            ELSE
              minusT0 = -1.0*T0
              T1 = DPT(IL,NC)/DQT(IL,NC)
!              DYY1(IL,NC) = T1 + (DYY(IL,NC) - T1)*EXP(-1.0*T0)
              DYY1(IL,NC) = T1 + (DYY(IL,NC) - T1)*EXP(minusT0)
            ENDIF
          ENDDO
  980   ENDDO!CONTINUE 
        DO  IL = 1,MERIDS
          H2O1(IL) = (H2O(IL)*DVDT + DP1(IL))/(DQ1(IL)+DVDT)
!
! SPECIAL CODE TO ENSURE THAT THE BROMINE SPECIES ARE UNDER CONTROL DURING
! THE RAPIDLY VARYING PERIOD AT DAWN AND DUSK
!
          BRX = DYY1(IL,9) + DYY1(IL,11) + DYY1(IL,12) + DYZ(IL,12) +       &
                DYZ(IL,13) + DYZ(IL,15)
          IF(DYY1(IL,17).EQ.0.0) THEN
            RATIO = 0.0
          ELSE
            RATIO = BRX/DYY1(IL,17)
          ENDIF
          IF(RATIO.GT.1.0) THEN
            DYY1(IL,9) = DYY1(IL,9)/RATIO
            DYY1(IL,11) = DYY1(IL,11)/RATIO
            DYY1(IL,12) = DYY1(IL,12)/RATIO
            DYZ(IL,12) = DYZ(IL,12)/RATIO
            DYZ(IL,13) = DYZ(IL,13)/RATIO
            DYZ(IL,15) = DYZ(IL,15)/RATIO
          ENDIF
!
!  SPECIAL CODE TO ENSURE THAT THE HETEROGENEOUS SCHEME DOES NOT PRODUCE
! EXCESSIVE HNO3. IF HNO3 EXCEEDS NOy - 2.*N2O5 SET HNO3 TO  NOy - 2.*N2O5
!
          DIFF = DYY1(IL,15) - 2.0*DYY1(IL,2)
          IF (DYY1(IL,1).GT.DIFF) DYY1(IL,1) = DIFF
        ENDDO
 1000 ENDDO
!
!  COMPUTE INCREMENT TO O3_CHEM DIAGNOSTIC TRACER
!
      DO IL = 1,MERIDS
        O3_PROD(IL) = O3_PROD(IL) +                                     &
             (DPT(IL,8) - DQT(IL,8)*DYY(IL,8))*RAT(IL,1)*DELT/RHO(IL)
      ENDDO
      IF(ITIME_LEFT .GT. 0) THEN
        DO NC = 1,NCHEM
          DO IL = 1,MERIDS
            DYY(IL,NC) = DYY1(IL,NC)
            H2O(IL) = H2O1(IL)
          ENDDO
        ENDDO
        CYCLE
      ELSE
        EXIT
      ENDIF
 1100 ENDDO
! ---------------------------------------------------------------------*
! ---
! --- COMPUTE CHEMICAL INCREMENTS FOR THIS SUPER-TIMESTEP   
! ---
! ---------------------------------------------------------------------*
!
!  GET CHEM TENDENCY AND CONVERT TO MIXING RATIOS
!
      DO IL = 1,MERIDS
        VRHO = 1.0/(RHO(IL)*DT)
        DO NC = 1,NCHEM
          CH_TEND(IL,NC) = CH_TEND(IL,NC) +                             &
                           (DYY1(IL,NC) - DYY0(IL,NC))*VRHO
       ENDDO
          H2O_TEND(IL) = H2O_TEND(IL) + (H2O1(IL) - H2O0(IL))*VRHO
      ENDDO
!
! SET OZONE CONCENTRATION
!
      DO IL = 1,MERIDS
        OZONE(IL) = DYZ(IL,1)/RHO(IL)
      ENDDO
!
#ifdef _ALLOC
      deallocate(RATES)
      deallocate(FOTO)
      deallocate(DYY)
      deallocate(DYZ)
      deallocate(DQT)
      deallocate(DPT)
      deallocate(RAT)
      deallocate(DYZ1)
      deallocate(DYY0)
      deallocate(DYY1)
      deallocate(COND)
      deallocate(GAMMA)
#endif
      RETURN
END SUBROUTINE CHEMISTRY
!         
SUBROUTINE DCLY_DT(age,dfdage,tropc,tracer1,cly,bry,dclydt,dbrydt, &
           agefact2,merids,lats,levels,itime)       
!----------------------------------------------------------------------*
!      age:  Age of air since stratospheric entry in years.                
!
!      The order of dfdage array elements is:
!
!      1. CFC11 as a fraction of its tropospheric concentration.        
!      2.-7.  CFC12, CFC113, CCL4, CH3CL, CH3CCL3, HCFC22 
!      8  Bry as a fraction of its tropospheric concentration
!
!      TROPC contains the tropospheric concentrations for 1950.0-2100.0 
!      at annual intervals. The species are ordered as dfdage elements 1-7 
!      and Total organic Cl and Br.
!----------------------------------------------------------------------*
      IMPLICIT NONE
      
      integer, intent(in) :: MERIDS,LATS,LEVELS,itime(6) 
      REAL, intent(in) :: age(merids,lats,levels),dfdage(90,48,8),TROPC(151,9), &
            cly(merids,lats,levels),bry(merids,lats,levels),         &
            tracer1(merids,lats,levels)
      REAL, intent(inout) :: dclydt(merids,lats,levels), &
            dbrydt(merids,lats,levels)
      REAL, intent(in) :: AGEFACT2
            
      
      INTEGER MDAY(12)
      INTEGER IANN,IMON,IDAY,IMON1,IT1,IT2,IC,KL,JL, &
              IL,IY,IY1,IM,MX
      REAL  CLWEIGHT(7),                    &
            dfdtau(merids,lats,8),          &
            cfc(merids,lats,9),cfct(9,2)

      REAL  YSTART,TFACT,AGEFACT1,DX1,DX2,TIME,DT1,DT2,SUM1,   &
            SUM2,FACTOR,YY,Y1,Y2,clytot,brytot
      DATA MDAY/31,28,31,30,31,30,31,31,30,31,30,31/
      DATA YSTART/1950.0/
      DATA CLWEIGHT/ 3.0, 2.0, 3.0, 4.0, 1.0, 3.0, 1.0 / 
!
!      Interpolate between months for TAB array
!
      iann = itime(1)
      imon = itime(2)
      iday = itime(3)
      tfact = 1.0/(365.25*86400.0)
!
! agefact1 and agefact2 are fudge factors, to correct for low model 
! atmospheric age in the computation of the halogen rates of change.
!
      agefact1 = 1.25
      DX1 = IDAY/MDAY(IMON)
      IF(IMON.EQ.2.AND.4*(IANN/4).EQ.IANN) DX1 = IDAY/29.0
      DX2 = 1.0 - DX1
      IMON1 = IMON + 1
      IF(IMON1.EQ.13) IMON1 = 1
!
!  Compute multiplying factor for missing CFCs, and include factor for 
!  conversion of rates to a per second rate. 
!
      TIME = REAL(IANN) + (REAL(imon)-1.0)/12.0
      IT1 = INT(TIME - YSTART) + 1
      IF(IT1 .LT. 1) IT1 = 1
      IF(IT1 .GT. 150) IT1 = 150
      IT2 = IT1 + 1
      DT1 = TIME - REAL(IT1) - (YSTART - 1.0)
      DT2 = 1.0 - DT1
      sum1 = 0.0
      sum2 = 0.0
      do ic = 1,7
        sum1 = sum1 + clweight(ic)*tropc(it1,ic)
        sum2 = sum2 + clweight(ic)*tropc(it2,ic)
      enddo
      factor = (dt2*tropc(it1,8) + dt1*tropc(it2,8))*tfact/             &
                (sum1*dt2 + sum2*dt1)
      do 500 kl = 1,levels
!----------------------------------------------------------------------*
!  determine age and dfdage at air parcel positions using tracer
!----------------------------------------------------------------------*
        do jl = 1,lats
          do il = 1,merids
            yy = tracer1(il,jl,kl)
            IF(YY.LT.1.)  YY =  1.01
            IF(YY.GT.89.99) YY = 89.99
            IY = YY
            Y1 = YY - IY
            Y2 = 1. - Y1
            IY1 = IY + 1
            do ic = 1,8
            dfdtau(il,jl,ic) = y2*dfdage(iy,kl,ic) + y1*dfdage(iy1,kl,ic)
            enddo
          enddo
        enddo
!----------------------------------------------------------------------*
!  compute CFCs at time t - age
!----------------------------------------------------------------------*
!      DO 100 JL = 1,lats
!      DO 100 IL = 1,merids
        DO JL = 1,lats
          DO IL = 1,merids
            DO IM = 1,2
              MX = IM + IMON - 1
              IF(MX.EQ.13) MX = 1
              TIME = REAL(IANN) + (REAL(MX)-1.0)/12.0 - age(IL,JL,kl)*agefact1  
!
!      Interpolate the tropospheric gas concs in time
!
              IT1 = INT(TIME - YSTART) + 1
              IF(IT1 .LT. 1) IT1 = 1
              IF(IT1 .GT. 150) IT1 = 150
              IT2 = IT1 + 1
              DT1 = TIME - REAL(IT1) - (YSTART - 1.0)
              DT2 = 1.0 - DT1
              DO IC=1,9
                CFCT(IC,IM) = TROPC(IT1,IC)*DT2 + TROPC(IT2,IC)*DT1                
              ENDDO! IC
            ENDDO! IM
            DO IC = 1,9
              CFC(IL,JL,IC) =  CFCT(IC,1)*DX2 +  CFCT(IC,2)*DX1  
            ENDDO !IC
          ENDDO
        ENDDO
! 100  CONTINUE
!----------------------------------------------------------------------*
!  Finally compute dclydt and dbrydt
!----------------------------------------------------------------------*
        do jl = 1,lats
          do il = 1,merids
            dclydt(il,jl,kl) = 0.0
            do ic = 1,7
              dclydt(il,jl,kl) = dclydt(il,jl,kl) +             &
                  1.0e-12*factor*dfdtau(il,jl,ic)*clweight(ic)* &
                  cfc(il,jl,ic)*agefact2
            enddo
            clytot = cfc(il,jl,8)*1.0e-12
            if(cly(il,jl,kl).ge.clytot) dclydt(il,jl,kl) = 0.0
            dbrydt(il,jl,kl) = 1.0e-12*tfact*dfdtau(il,jl,8)*cfc(il,jl,9)
            brytot = 1.0e-12*cfc(il,jl,9)
            if(bry(il,jl,kl).ge.brytot) dbrydt(il,jl,kl) = 0.0
          enddo
        enddo
 500  ENDDO
      RETURN
END SUBROUTINE DCLY_DT
!
SUBROUTINE REACTION_RATES (RHO,TEMP,VTEMP,PRESS,RATES,            &
                           MERIDS,IHET,NHET)
!-------------------------------------------------------------------------
!
!   THIS SUBROUTINE DETERMINES THE HOMOGENEOUS GAS PHASE REACTION RATES
!
!-------------------------------------------------------------------------
IMPLICIT NONE
INTEGER  , intent(in) :: MERIDS,IHET,NHET
REAL, intent(in), dimension(MERIDS) ::  RHO,TEMP,VTEMP,PRESS
REAL, intent(inout) :: RATES(MERIDS,IHET+NHET-1)
!
INTEGER  IL,IC
REAL TEMP3(MERIDS)
!
REAL  O2,R0,R1,RX,RX1,RX2
!
  DATA O2/0.2095/      
!
  DO IL = 1,MERIDS
    TEMP3(IL) = TEMP(IL)/300.0
  ENDDO   
!
!  RATES TAKEN FROM JPL 2006 
!
  DO IL = 1,MERIDS
!   REACTION 1 O+O2+M --> O3+M
      RATES(IL,1) = 6.0E-34*TEMP3(IL)**(-2.40)*O2*RHO(IL)*RHO(IL)       
!   REACTION 2 O+O3 --> O2+O2
      RATES(IL,2) = 8.0E-12*EXP(-2060*VTEMP(IL))
!   REACTION 3 OSD+M --> O+M N2 & O2 3RD BODY RATES ALLOWED FOR       
      RATES(IL,3) = RHO(IL)*(6.93E-12*EXP(70*VTEMP(IL)) +              &
                               1.677E-11*EXP(110*VTEMP(IL)))
!   REACTION 4 NO+O3 --> NO2+O2
      RATES(IL,4) = 3.0E-12*EXP(-1500*VTEMP(IL))
!   REACTION 5 NO2+O --> NO+O2
      RATES(IL,5) = 5.1E-12*EXP(210*VTEMP(IL))
!   REACTION 6 NO2+O3 --> NO3+O2
      RATES(IL,6) = 1.2E-13*EXP(-2450*VTEMP(IL))
!   REACTION 7 NO2+NO3 + M --> N2O5 + M
      R0 = 2.0E-30*RHO(IL)*TEMP3(IL)**(-4.4)
      R1 = 1.4E-12*TEMP3(IL)**(-0.7)
      RX = ALOG10(R0/R1)
      RATES(IL,7) =(R0/(1.0 + R0/R1))*                                &
                          (0.6**(1.0/(1.0 + (RX*RX))))
!   REACTION 8 N2O5+M --> NO3+NO2+M
      RATES(IL,8) = RATES(IL,7)/(2.7E-27*EXP(11000.0*VTEMP(IL)))
!   REACTION 9 OSD+H2O --> OH+OH
      RATES(IL,9) = 1.63E-10*EXP(60.0*VTEMP(IL))
!   REACTION 10 OH+O3 --> HO2+O2
      RATES(IL,10) = 1.7E-12*EXP(-940.0*VTEMP(IL))
!   REACTION 11 O+HO2 --> OH+O2
      RATES(IL,11) = 3.0E-11*EXP(200.0*VTEMP(IL))
!   REACTION 12 O+OH --> H+O2
      RATES(IL,12) = 2.2E-11*EXP(120.0*VTEMP(IL))
!   REACTION 13 H+O3 --> OH+O2
      RATES(IL,13) = 1.4E-10*EXP(-470.0*VTEMP(IL))
!   REACTION 14 H+O2+M --> HO2+M : MULTIPLIED BY O2 NUMBER DENSITY    
      R0 = 4.4E-32*RHO(IL)*TEMP3(IL)**(-1.3)
      R1 = 4.7E-11*TEMP3(IL)**(-0.2)
      RX = ALOG10(R0/R1)
      RATES(IL,14) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
      RATES(IL,14) = RATES(IL,14)*O2*RHO(IL)
!   REACTION 15 HO2+O3 --> OH+O2+O2
      RATES(IL,15) = 1.0E-14*EXP(-490.0*VTEMP(IL))
!   REACTION 16 OH+HO2 --> H2O+O2
      RATES(IL,16) = 4.8E-11*EXP(250.0*VTEMP(IL))
!   REACTION 17 OH+NO2+M --> HONO2+M
!   INCLUDE ALSO OH+NO2+M --> HOONO + M
      R0 = 1.8E-30*RHO(IL)*TEMP3(IL)**(-3.0)
      R1 = 2.8E-11
      RX = ALOG10(R0/R1)
      RATES(IL,17) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
      R0 = 9.1E-32*RHO(IL)*TEMP3(IL)**(-3.9)
      R1 = 4.2E-11*TEMP3(IL)**(-0.5)
      RX = ALOG10(R0/R1)
      RATES(IL,17) = RATES(IL,17) + (R0/(1.0 + R0/R1))*           &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 18 NO+HO2 --> NO2+OH
      RATES(IL,18) = 3.5E-12*EXP(250.0*VTEMP(IL))
!   REACTION 19 OH+HNO3 --> H2O+NO3 : SPECIAL TREATMENT               
      RX1 = 6.5E-34*RHO(IL)*EXP(1335.0*VTEMP(IL))            
      RX2 = 2.7E-17*EXP(2199.0*VTEMP(IL))            
      RATES(IL,19) =  2.4E-14*EXP(460.0*VTEMP(IL)) +                        &
                      RX1/(1.0 + RX1/RX2)           
!   REACTION 20 CL+O3 --> CLO+O2
      RATES(IL,20) = 2.3E-11*EXP(-200.0*VTEMP(IL))
!   REACTION 21 O+CLO --> CL+O2
      RATES(IL,21) = 2.8E-11*EXP(85.0*VTEMP(IL))
!   REACTION 22 CLO+NO --> NO2+CL
      RATES(IL,22) = 6.4E-12*EXP(290.0*VTEMP(IL))
!   REACTION 23 CLO+NO2+M --> CLONO2+M
      R0 = 1.8E-31*RHO(IL)*TEMP3(IL)**(-3.4)
      R1 = 1.5E-11*TEMP3(IL)**(-1.9)
      RX = ALOG10(R0/R1)
      RATES(IL,23) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 24 O+CLONO2--> CLO+NO3
      RATES(IL,24) = 2.9E-12*EXP(-800.0*VTEMP(IL))
!   REACTION 25 CL+CH4 (+O2) --> HCL+CH3O2
      RATES(IL,25) = 7.3E-12*EXP(-1280.0*VTEMP(IL))
!   REACTION 26 OH+HCL --> H2O+CL
      RATES(IL,26) = 2.6E-12*EXP(-350.0*VTEMP(IL))
!   REACTION 27 CL+HO2 --> HCL+O2
      RATES(IL,27) = 1.8E-11*EXP(170.0*VTEMP(IL))
!   REACTION 28 CLO+HO2 --> HOCL+O2
      RATES(IL,28) = 2.7E-12*EXP(220.0*VTEMP(IL))
!   REACTION 29 CLO+OH --> HO2+CL
      RATES(IL,29) = 7.4E-12*EXP(270.0*VTEMP(IL))
!   REACTION 30 OSD+CH4 --> OH + CH3O2
      RATES(IL,30) = 1.5E-10*EXP(0.0*VTEMP(IL))
!   REACTION 31 OH+CH4 --> H2O + CH3O2
      RATES(IL,31) = 2.45E-12*EXP(-1775.0*VTEMP(IL))
!   REACTION 32 H2CO+OH (+O2) --> H2O + HO2 + CO
      RATES(IL,32) = 5.5E-12*EXP(125.0*VTEMP(IL))
!   REACTION 33 H2CO+CL (+O2) --> HCL+ HO2 + CO        
      RATES(IL,33) = 8.1E-11*EXP(-30.0*VTEMP(IL))
!   REACTION 34 HO2+HO2 --> H2O2+O2
      RATES(IL,34) = 3.5E-13*EXP(430.0*VTEMP(IL)) +                        &
                     1.7E-33*EXP(1000.0*VTEMP(IL))*RHO(IL)                
!   REACTION 35 OH+OH+M --> H2O2+M
      R0 = 6.9E-31*RHO(IL)*TEMP3(IL)**(-1.0)
      R1 = 2.6E-11*TEMP3(IL)**0.0
      RX = ALOG10(R0/R1)
      RATES(IL,35) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 36 OH+H2O2 --> HO2+H2O
      RATES(IL,36) = 2.9E-12*EXP(-160.0*VTEMP(IL))
!   REACTION 37 CLO+CLO+M --> CL2O2 + M
      R0 = 1.6E-32*RHO(IL)*TEMP3(IL)**(-4.5)
      R1 = 2.0E-12*TEMP3(IL)**(-2.4)
      RX = ALOG10(R0/R1)
      RATES(IL,37) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 38 CL2O2+M --> 2CLO + M
      RATES(IL,38) = RATES(IL,37)/(9.3E-28*EXP(8835.0*VTEMP(IL)))  
!   REACTION 39 BR + O3 --> BRO + O2
      RATES(IL,39) = 1.7E-11*EXP(-800.0*VTEMP(IL))
!   REACTION 40 BRO + NO2 + M --> BRONO2 + M
      R0 = 5.2E-31*RHO(IL)*TEMP3(IL)**(-3.2)
      R1 = 6.9E-12*TEMP3(IL)**(-2.9)
      RX = ALOG10(R0/R1)
      RATES(IL,40) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 41 BRO + CLO --> BR + CL + 02
      RATES(IL,41) =  2.3E-12*EXP(260.0*VTEMP(IL))   
!   REACTION 42 BRO + HO2 --> HOBR + O2
      RATES(IL,42) = 4.5E-12*EXP(460.0*VTEMP(IL))
!   REACTION 43 BRO + NO --> BR + NO2
      RATES(IL,43) = 8.8E-12*EXP(260.0*VTEMP(IL))
!   REACTION 44 HOBR + O --> BRO + OH
      RATES(IL,44) = 1.2E-10*EXP(-430.0*VTEMP(IL))
!   REACTION 45 BR + HO2 --> HBR + O2
      RATES(IL,45) = 4.8E-12*EXP(-310.0*VTEMP(IL))
!   REACTION 46 BR + H2CO (+O2) --> HBR + HO2 + CO
      RATES(IL,46) = 1.7E-11*EXP(-800.0*VTEMP(IL))
!   REACTION 47 HBR + OH --> BR + H2O
      RATES(IL,47) = 5.5E-12*EXP(200.0*VTEMP(IL))
!   REACTION 48 BRO + CLO --> BRCL + O2
      RATES(IL,48) = 4.1E-13*EXP(290.0*VTEMP(IL))
!   REACTION 49 HO2 + NO2 + M --> HNO4 + M
      R0 = 2.0E-31*RHO(IL)*TEMP3(IL)**(-3.4)
      R1 = 2.9E-12*TEMP3(IL)**(-1.1)
      RX = ALOG10(R0/R1)
      RATES(IL,49) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 50 HNO4 + OH --> H2O + NO2 + O2
      RATES(IL,50) = 1.3E-12*EXP(380.0*VTEMP(IL))
!
! REACTIONS ADDED FOR TROPOSPHERIC CHEMISTRY
!
!   REACTION 51 OH + OH --> H2O + O
      RATES(IL,51) = 1.8E-12
!   REACTION 52 CO + OH (+O2) --> HO2 +CO2
      R0 = 5.9E-33*RHO(IL)*TEMP3(IL)**(-1.4)
      R1 = 1.1E-12*TEMP3(IL)**(1.3)
      RX = ALOG10(R0/R1)
      RATES(IL,52) =    (R0/(1.0 + R0/R1))*                           &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
      R0 = 1.5E-13*TEMP3(IL)**0.6
      R1 = 2.1E9*TEMP3(IL)**(6.1)/RHO(IL)       
      RX = ALOG10(R0/R1)       
      RATES(IL,52) = RATES(IL,52)+ (R0/(1.0 + R0/R1))*                 &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 53 NO3 + NO --> 2NO2
      RATES(IL,53) = 1.5E-11*EXP(170.0*VTEMP(IL))
!   REACTION 54 H2 + OH (+O2) --> HO2 + H2O
      RATES(IL,54) = 5.5E-12*EXP(-2000.0*VTEMP(IL))
!   REACTION 55 CH3O2 + NO (+O2) --> H2CO + NO2 + HO2
      RATES(IL,55) = 2.8E-12*EXP(300.0*VTEMP(IL))
!   REACTION 56 CH3O2 + HO2 --> CH3OOH + O2
      RATES(IL,56) = 4.1E-13*EXP(750.0*VTEMP(IL))
!   REACTION 57 CH3OOH + OH --> CH3O2 + H2O 
      RATES(IL,57) = 3.8E-12*EXP(200.0*VTEMP(IL))
!   REACTION 58 NO2 + NO3 --> NO + NO2 + O2
      RATES(IL,58) = 4.5E-14*EXP(-1260.0*VTEMP(IL))
!   REACTION 59 NO3 + NO3 --> 2NO2 + O2 
      RATES(IL,59) = 8.5E-13*EXP(-2450.0*VTEMP(IL))
!   REACTION 60 OH + HONO --> H2O + NO2
      RATES(IL,60) = 1.8E-11*EXP(-390.0*VTEMP(IL))
!   REACTION 61 CH3O2 + CH3O2 --> 2H2CO + 2OH
      RATES(IL,61) = 9.5E-14*EXP(390.0*VTEMP(IL))
!   REACTION 62 NO3 + HCHO (+O2) --> HNO3 + CO + HO2
      RATES(IL,62) = 5.8E-16
!   REACTION 63 HO2NO2 + M --> HO2 + NO2
      RATES(IL,63) = RATES(IL,49)*4.762E26*EXP(-10900*VTEMP(IL))
!   REACTION 64 NO + O + M --> NO2 + M
      R0 = 9.0E-31*RHO(IL)*TEMP3(IL)**(-1.5)
      R1 = 3.0E-11
      RX = ALOG10(R0/R1)
      RATES(IL,64) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 65 OH + NO + M --> HONO + M
      R0 = 7.0E-31*RHO(IL)*TEMP3(IL)**(-2.6)
      R1 = 3.6E-11*TEMP3(IL)**(-0.1)
      RX = ALOG10(R0/R1)
      RATES(IL,65) =(R0/(1.0 + R0/R1))*                               &
                          (0.6**(1.0/(1.0 + (RX*RX)))) 
!   REACTION 66 N2O + OSD --> 2NO
      RATES(IL,66) = 6.7E-11*EXP(20.0*VTEMP(IL))
!   REACTION 67 N + NO --> N2 + O
      RATES(IL,67) = 2.1E-11*EXP(100.0*VTEMP(IL))
!   REACTION 68 N + O2 --> NO + O
      RATES(IL,68) = 1.5E-11*EXP(-3600.0*VTEMP(IL))
!   REACTION 69 CLO+OH --> --> HCL+O2
      RATES(IL,69) = 6.0E-13*EXP(-230.0*VTEMP(IL))
!   REACTION 70 N2O + OSD --> N2 + O2
      RATES(IL,70) = 4.7E-11*EXP(20.0*VTEMP(IL))
!   REACTION 71 N + NO2 --> N2O + O
      RATES(IL,71) = 5.8E-12*EXP(220.0*VTEMP(IL))
  ENDDO
  DO IC=IHET,IHET+NHET-1
    DO IL=1,MERIDS
      RATES(IL,IC) = 0.0                                            
    ENDDO
  ENDDO
  RETURN
END SUBROUTINE REACTION_RATES

SUBROUTINE PSC(TEMP,PRESS,RHO,DYY,H2O,H2SO4,ANAT,AICE,COND,TICE,  &
           WH2SO4,AM,AW,ALIQ,RMEAN,ASAT,RNAT,RICE,MERIDS,NCHEM,MYPE)
!---------------------------------------------------------------------------
!  CALCULATES IMPORTANT TERMS FOR BINARY AEROSOL/SAT/NAT/ICE SCHEME.
! THE MAIN OUTPUT IS THE SURFACE AREA OR PARTICLE RADIUS
!----------------------------------------------------------------------------
IMPLICIT NONE
INTEGER, intent(in)                           :: MERIDS,NCHEM,MYPE
REAL, intent(in)                              :: ANAT, AICE
REAL, intent(in),    dimension(MERIDS)        :: PRESS, RHO, TEMP, H2SO4

REAL, intent(inout), dimension(MERIDS)        :: H2O, TICE, WH2SO4, AM, AW, &
                                                 ALIQ, RMEAN, ASAT, RNAT, RICE
REAL, intent(inout), dimension(MERIDS,3)      :: COND
REAL, intent(inout), dimension(MERIDS, NCHEM) :: DYY

INTEGER IL
REAL DENS(MERIDS),VHET(MERIDS,4),WF(MERIDS,2),PH2O(MERIDS)
REAL AVGDR,RR,PI,ADROP,SIGMAL,TSAT,ABT,AMT,BMT,PX,C2,   &
     A1,A2,A3,A4,C3,C4,CLIMIT,P0H2O,Y1,Y2,T1,RMODE,RMODESAT,SANAT
!----------------------------------------------------------------------------
!
! AVGDR IS THE RECIPROCAL OF THE AVOGADRO CONSTANT
! RR IS THE GAS CONSTANT
!
!----------------------------------------------------------------------------
  DATA AVGDR,RR/1.66056547E-24, 8.3144/,PI/3.1415926536/
!----------------------------------------------------------------------------
!
!   ADROP, ANAT AND AICE ARE THE (FIXED) NUMBER OF DROPS OR PARTICLES PER CC
!   IN THE POLAR STRATOSPHERC CLOUDS. A LOG NORMAL SIZE DISTRIBUTION IS ASSUMED
!   WITH SIGMA = 1.8 GIVING LOG(SIGMA)**2 = 0.3455  
!
!----------------------------------------------------------------------------
  DATA ADROP/10.0/,SIGMAL/0.34549316/      
!          
    DO 40 IL=1,MERIDS
!----------------------------------------------------------------------------
!
! COMPUTE SOLID CONDENSED MATTER: COND(IL,1:3) -- SAT, NAT, ICE
!               
!----------------------------------------------------------------------------
      PH2O(IL) = H2O(IL)*PRESS(IL)/(RHO(IL)*101325.0)
      COND(IL,1) = 0.0
      COND(IL,2) = 0.0
      COND(IL,3) = 0.0
      TSAT = 3236.0/(11.502 - ALOG10(PH2O(IL)*760.0))           
      IF(TEMP(IL).LT.TSAT) COND(IL,1) = H2SO4(IL)        
      ABT = 39.1104 - 11397.0/TEMP(IL) + 9.179E-3*TEMP(IL)                
      AMT = -2.7836 - 8.8E-4*TEMP(IL)
      BMT = -2.1249 + ALOG10(PH2O(IL)*101325.0)
      PX = AMT*BMT + ABT
      C2 = DYY(IL,1) - (RHO(IL)*100.0/PRESS(IL))*10.0**(PX)
      IF(C2.GT.0.0) COND(IL,2) = C2
      TICE(IL) = 2668.70/(10.4310 - ALOG10(760.0*PH2O(IL)))               
      A1 = 7.5502 - 2668.7/TEMP(IL)
      C3 = H2O(IL) - (RHO(IL)*101325.0/PRESS(IL))*10.0**(A1)          
      C4 = (RHO(IL)*101325.0/PRESS(IL))*10.0**(A1)          
      IF(C3.GT.0.0) COND(IL,3) = C3
      DYY(IL,1) = DYY(IL,1) - COND(IL,2)
      DYY(IL,15) = DYY(IL,15) - COND(IL,2) 
      CLIMIT = RHO(IL)*1.E-15
      IF(DYY(IL,15).LT.CLIMIT) DYY(IL,15) = CLIMIT
      H2O(IL) = H2O(IL) - COND(IL,3) 
 40 ENDDO!CONTINUE
!-------------------------------------------------------------------------
!
!  COMPUTE WEIGHT % H2SO4. FROM TABAZADEHET AL., GRL, 24, 1931-1934, 1997.
!  TABLE A1 OF SHIAET AL. JGR, 106, 24,529-24,274, 2001
!
!-------------------------------------------------------------------------
    DO 50 IL = 1,MERIDS
      P0H2O =EXP(18.452406985 - 3505.1578807/TEMP(IL) -                &
             330918.55082/(TEMP(IL)**2) + 12725068.262/(TEMP(IL)**3))    
      AW(IL) = H2O(IL)*PRESS(IL)*0.01/(RHO(IL)*P0H2O)
      IF(AW(IL).LE.0.05) THEN
        Y1 = 12.37208932*AW(IL)**(-0.16125516114) - 30.490657554*AW(IL)  &
            -  2.1133114241
        Y2 = 13.455394705*AW(IL)**(-0.1921312255) - 34.285174607*AW(IL)        &
            - 1.7620073078
      ELSEIF(AW(IL).LT.0.85.AND.AW(IL).GT.0.05) THEN
        Y1 = 11.820654354*AW(IL)**(-0.20786404244) - 4.807306373*AW(IL)   &
            -  5.1727540348
        Y2 = 12.891938068*AW(IL)**(-0.23233847708) - 6.4261237757*AW(IL)   &
            - 4.9005471319
      ELSE
        Y1 = -180.06541028*AW(IL)**(-0.38601102592)                     &
            - 93.317846778*AW(IL) + 273.88132245
        Y2 = -176.95814097*AW(IL)**(-0.36257048154)                     &
             - 90.469744201*AW(IL) + 267.45509988
      ENDIF              
      AM(IL) = Y1 + (TEMP(IL) - 190.0)*(Y2 - Y1)/70.0
      WH2SO4(IL) = 9800.0*AM(IL)/(98.0*AM(IL) + 1000.0)
      WF(IL,1) = 0.01*WH2SO4(IL) 
      WF(IL,2) = 0.0
 50 ENDDO!CONTINUE
!---------------------------------------------------------------------------
!
!  COMPUTE DENSITY OF BINARY AEROSOL        
!
!---------------------------------------------------------------------------
    CALL DENSITY(WF,TEMP,DENS,MERIDS)
!---------------------------------------------------------------------------
!
!  COMPUTE VOLUME OF BINARY AEROSOL/SAT/NAT/ICE 
!  1.6, 1.35 and 0.928  are the densities of SAT, NAT and ICE     
!
!---------------------------------------------------------------------------
    DO 100 IL=1,MERIDS
      T1 = H2SO4(IL)*PRESS(IL)/(RHO(IL)*TEMP(IL)*RR)
      VHET(IL,1) = T1*98.076E-6/(WF(IL,1)*DENS(IL))             
      VHET(IL,2) = COND(IL,1)*170.1*AVGDR/1.6
      VHET(IL,3) = COND(IL,2)*117.1*AVGDR/1.35
      VHET(IL,4) = COND(IL,3)*18.02*AVGDR/0.928
100 ENDDO
!---------------------------------------------------------------------------
!
!  COMPUTE PARTICLE PARAMETERS FROM WHICH THE HETEROGENEOUS REACTION RATES
!  ARE DETERMINED; ASSUME SURFACE AREA FROM SAT IS LIMITED BY NAT AMOUNT   
!
!---------------------------------------------------------------------------
    A1 =EXP(-4.5*SIGMAL)
    A2 =EXP(0.5*SIGMAL)
    A3 =EXP(2.0*SIGMAL)
    A4 = 1.33333333*PI*ADROP
    DO 150 IL=1,MERIDS
      RMODE = (VHET(IL,1)*A1/A4)**0.33333333
      RMEAN(IL) = RMODE*A2
      ALIQ(IL) = 3.0*A4*(RMODE**2)*A3
      IF(RMEAN(IL).LT.1.0E-12) RMEAN(IL) = 1.0E-12
      RMODESAT = (VHET(IL,2)*A1/A4)**0.33333333
      ASAT(IL) = 3.0*A4*(RMODESAT**2)*A3
      RNAT(IL) = (VHET(IL,3)/(1.33333333*PI*ANAT))**0.33333333
      RICE(IL) = (VHET(IL,4)/(1.33333333*PI*AICE))**0.33333333
      SANAT = 4.0*PI*ANAT*RNAT(IL)**2
      ASAT(IL) = ASAT(IL) - SANAT
      ALIQ(IL) = ALIQ(IL) - SANAT
      IF(ASAT(IL).LT.0.0) ASAT(IL) = 0.0
      IF(ALIQ(IL).LT.0.0) ALIQ(IL) = 0.0
150 ENDDO
    RETURN
END SUBROUTINE PSC
!
SUBROUTINE GAMMA_AER(TEMP,PRESS,RHO,DYY,H2O,WH2SO4,AM,AW,RMEAN,   &
                     GAMMA,RTT,MERIDS,NCHEM,NHET,MYPE)
!-------------------------------------------------------------------------
!
! SUBROUTINE TO CALCULATE REACTION PROBABILITIES ON SULPHATE AEROSOL
! BASED ON JPL'03 RECOMMENDATION
!  
!-------------------------------------------------------------------------
  IMPLICIT NONE
  INTEGER, intent(in) ::  MERIDS,NCHEM,NHET,MYPE
  REAL, intent(in) :: TEMP(MERIDS),PRESS(MERIDS),RHO(MERIDS),DYY(MERIDS,NCHEM), &
        H2O(MERIDS),WH2SO4(MERIDS),AW(MERIDS),AM(MERIDS),           &
        RMEAN(MERIDS)
  REAL, intent(inout) :: RTT(MERIDS), GAMMA(MERIDS,NHET)
!
  INTEGER  IL
  REAL  AMH2SO4(MERIDS),XH2SO4(MERIDS),VISC(MERIDS),AACID(MERIDS),  &
        TEMP2(MERIDS)
!-------------------------------------------------------------------------
!  
! CALCULATE H2SO4 MOLARITY (AMH2SO4), MOLE FRACTION (XH2SO4), 
!  VISCOSITY (VISC) AND ACID ACTIVITY (AACID)
!  TABLE A2 OF SHIAET AL. JGR, 106, 24,529-24,274, 2001.
! 
!-------------------------------------------------------------------------
  REAL  T2,Z1,Z2,Z3,RHOX,AA,X,T1,T3,AKH,AKH2O,AKHYDR,DIFF,SCLONO2,  &
         CCLONO2,GAMMAB1,HHCL,AKHCL,Q1,RQ,A1,FCLONO2,GAMMARXN,      &
         GAMMABHCL,GAMMAS,FHCL,GAMMASP,GAMMABHCLP,GAMMAB,GCLONO2,   &
         SHOCL,HHOCL,FHOCL,WT,AK0,AK1,AK2,T0,HCLONO2,   &
         AMHCL,AKHOCL,CHOCL
!
!  The parameterisations used here break down below about 185K, so the
!  temperature is here limited to 185K and above (TEMP2).
!
    DO IL = 1,MERIDS
      TEMP2(IL) = TEMP(IL)
      IF(TEMP2(IL).LT.185.0) TEMP2(IL) = 185.0
      RTT(IL) = SQRT(TEMP(IL))
    ENDDO
    DO 20 IL = 1,MERIDS
      T2 = TEMP2(IL)**2
      Z1 = 0.12364 - 5.6E-7*T2
      Z2 = -0.02954 + 1.814E-7*T2
      Z3 = 2.343E-3 - 1.487E-6*TEMP2(IL) - 1.324E-8*T2
      RHOX = 1.0 + Z1*AM(IL) + Z2*AM(IL)**1.5 + Z3*AM(IL)**2
      AMH2SO4(IL) = RHOX*WH2SO4(IL)/9.8
      XH2SO4(IL) = WH2SO4(IL)/                                          &
         (WH2SO4(IL) + (100.0 - WH2SO4(IL))*98.0/18.0)
      AA = 169.5 + 5.18*WH2SO4(IL) - 0.0825*WH2SO4(IL)**2 +             &
           3.27E-3*WH2SO4(IL)**3 
      T0 = 144.11 + 0.166*WH2SO4(IL) - 0.015*WH2SO4(IL)**2 +            &
           2.18E-4*WH2SO4(IL)**3
      X = TEMP2(IL)**(-1.43) 
      VISC(IL) = AA*X*EXP(448.0/(TEMP2(IL) - T0))
      T1 = 60.51 - 0.095*WH2SO4(IL) + 0.0077*WH2SO4(IL)**2              &
           - 1.61E-5*WH2SO4(IL)**3
      T2 =  (-805.89 + 253.05*WH2SO4(IL)**0.076)/RTT(IL)  
      T3 =   (1.76 + 2.52E-4*WH2SO4(IL)**2)*RTT(IL)
      AACID(IL) =EXP(T1 + T2 - T3)
 20 ENDDO!CONTINUE
!-------------------------------------------------------------------------
!
!  CALCULATE REACTION PROBABILITES FOR CLONO2 + H2O AND CLONO2 + HCL AND 
!  HENRY'S LAW COEFFICIENTS.
!  TABLE A3 OF SHIAET AL. JGR, 106, 24,529-24,274, 2001.
!
!  The following formulation for the water activity is from Shi et al.,
!  but the differences between their parameterisation and that calculated
!  using the actua model H2O is not large.
!
!      awx = exp((-69.775*xh2so4(il) - 18253.7*xh2so4(il)**2 + 
!     2     31072.2*xh2so4(il)**3 - 25668.8*xh2so4(il)**4)*
!     3     (1.0/temp(il) - 26.9033/(temp(il)**2)))      
!      AKHYDR = AWx*(AKH2O + AKH*AACID(IL))
!
!-------------------------------------------------------------------------
    DO 30 IL = 1,MERIDS
      AKH = 1.22E12*EXP(-6200.0/TEMP2(IL))
      AKH2O = 1.95E10*EXP(-2800.0/TEMP2(IL))     
      AKHYDR = AW(IL)*(AKH2O + AKH*AACID(IL))
      DIFF = 5.0E-8*TEMP2(IL)/VISC(IL)
      SCLONO2 = 0.306 + 24.0/TEMP2(IL)
      HCLONO2 = 1.6E-6*EXP(4710.0/TEMP2(IL) - SCLONO2*AMH2SO4(IL))
      CCLONO2 = 1474.*TEMP2(IL)**0.5
      GAMMAB1 = (4.0*HCLONO2*0.082*TEMP2(IL)/CCLONO2)*                  &
                (DIFF*AKHYDR)**0.5
!
      HHCL = (0.094 - 0.61*XH2SO4(IL) + 1.2*XH2SO4(IL)**2)*             &
        EXP(-8.68 + (8515. - 10718.*XH2SO4(IL)**0.7)/TEMP2(IL))
      AMHCL = HHCL*DYY(IL,4)*PRESS(IL)/(RHO(IL)*101325.0)
      AKHCL = 7.9E11*AACID(IL)*DIFF*AMHCL
      Q1 = (DIFF/(AKHYDR + AKHCL))**0.5
      RQ = RMEAN(IL)/Q1
      A1 = RQ + 0.312*RQ**2
      FCLONO2 = A1/(3.0 + A1)
      GAMMARXN = FCLONO2*GAMMAB1*(1.0 + AKHCL/AKHYDR)**0.5
      GAMMABHCL = GAMMARXN*AKHCL/(AKHCL + AKHYDR)
      GAMMAS = 66.12*EXP(-1374./TEMP2(IL))*HCLONO2*AMHCL
      IF(DYY(IL,4).NE.0.0) THEN
        FHCL = 1.0/(1.0 + 0.612*(GAMMAS + GAMMABHCL)*DYY(IL,6)/DYY(IL,4))
      ELSE
        FHCL = 0.0
      ENDIF
      GAMMASP = FHCL*GAMMAS
      GAMMABHCLP = FHCL*GAMMABHCL     
      GAMMAB = GAMMABHCLP + GAMMARXN*AKHYDR/(AKHCL + AKHYDR)
      GCLONO2 = 1.0/(1.0 + 1.0/(GAMMASP + GAMMAB))
      GAMMA(IL,5) = GCLONO2*(GAMMASP + GAMMABHCLP)/                     &
            (GAMMASP + GAMMAB)
      GAMMA(IL,4) = GCLONO2 - GAMMA(IL,5)
!-------------------------------------------------------------------------
!
!  CALCULATE REACTION PROBABILITES FOR HOCL + HCL AND HENRY'S LAW COEFFICIENTS.
!  TABLE A4 OF SHIAET AL. JGR, 106, 24,529-24,274, 2001.
!
!-------------------------------------------------------------------------
      SHOCL = 0.0776 + 59.18/TEMP2(IL)
      HHOCL = 1.91E-6*EXP(5862.4/TEMP2(IL) - SHOCL*AMH2SO4(IL))
      DIFF = 6.4E-8 *TEMP2(IL)/VISC(IL) 
      AKHOCL = 1.25E9*AACID(IL)*DIFF*AMHCL
      CHOCL = 2009.*RTT(IL)
      Q1 = (DIFF/AKHOCL)**0.5
      RQ = RMEAN(IL)/Q1
      A1 = RQ + 0.312*RQ**2
      FHOCL = A1/(3.0 + A1)
      GAMMARXN = (FHOCL*4.0*HHOCL*0.082*TEMP2(IL)/CHOCL)*               &
                 (DIFF*AKHOCL)**0.5
      GAMMA(IL,1) = 1.0/(1.0 + 1.0/(GAMMARXN*FHCL))
 30 ENDDO!CONTINUE
!-------------------------------------------------------------------------
!
!  CALCULATE REACTION PROBABILITES FOR N2O5 + H2O 
!  ROBINSONET AL. JGR, 102, 3583-3601, 1997.
!
!-------------------------------------------------------------------------
    DO 40 IL = 1,MERIDS
      WT = WH2SO4(IL)
      IF(WH2SO4(IL).GT.80.0) WT = 80.0
      AK0 = -25.5265 - 0.133188*WT + 0.00930846*WT**2 -                 &
              9.0194E-5*WT**3  
      AK1 = 9283.76 + 115.345*WT - 5.19258*WT**2 +                      &
           0.0483464*WT**3  
      AK2 = -851801. - 22191.2*WT + 766.916*WT**2 -                     &
           6.85427*WT**3
      GAMMA(IL,3) =EXP(AK0 + AK1/TEMP2(IL) + AK2/(TEMP2(IL)**2))  
 40 ENDDO!CONTINUE
!-------------------------------------------------------------------------
!
!  REACTION PROBABILITES FOR 
!       N2O5 + HCL
!       HOBR + HCL
!       HOCL + HBR 
!  NO RECOMMENDATION IN JPL '03, ASSUMED ZERO
!
!-------------------------------------------------------------------------
    DO IL = 1,MERIDS
      GAMMA(IL,2) = 0.0
      GAMMA(IL,6) = 0.0
      GAMMA(IL,7) = 0.0
    ENDDO
!-------------------------------------------------------------------------
!
!  REACTION PROBABILITES FOR HOBR + HBR 
!  ABBATT, JGR, 100, 14009-14017, 1995. 
!
!-------------------------------------------------------------------------
    DO IL = 1,MERIDS
      GAMMA(IL,8) = 0.25
    ENDDO
!-------------------------------------------------------------------------
!
!  REACTION PROBABILITES FOR BRONO2 + H2O 
!  USE JPL '03 RECOMMENDATION (HANSON PERS. COMM.)
!
!-------------------------------------------------------------------------
    DO IL = 1,MERIDS
      GAMMA(IL,9) = 1.0/(1.2422 + 1.0/(0.114 +EXP(29.24 -              &
                    0.396*WH2SO4(IL))))
    ENDDO
    RETURN
END SUBROUTINE GAMMA_AER
!
SUBROUTINE HETRATES(TEMP,PRESS,RHO,DYY,H2O,TICE,ANAT,AICE,ALIQ,        &
        RMEAN,RNAT,RICE,GAMMA,RTT,RATES,IHET,NHET,MERIDS,NCHEM,MYPE)

IMPLICIT NONE
!------------------------------------------------------------------------
!
!  This subroutine computes the equivalent 2nd order reaction rates for 
!  the heterogeneous reactions on aerosol, nat and ice.
!
!------------------------------------------------------------------------
      
  INTEGER, intent(in) :: IHET, NHET, MERIDS, NCHEM, MYPE
  REAL, intent(in) ::  TEMP(MERIDS),PRESS(MERIDS),RHO(MERIDS), &
       DYY(MERIDS,NCHEM), H2O(MERIDS),TICE(MERIDS),            &
       ALIQ(MERIDS),RMEAN(MERIDS),RNAT(MERIDS),RICE(MERIDS),   &
       GAMMA(MERIDS,NHET), RTT(MERIDS)
  REAL, intent(inout) :: RATES(MERIDS,IHET+NHET-1)
!
  INTEGER INN(9),IC,IL
  REAL AMW(9),GNAT(9),GICE(9),                          &
       CHEMC(MERIDS,NHET),CONST(NHET),                              &
       G2NAT(MERIDS,NHET),DELT(MERIDS),SICE(MERIDS)
!
  REAL  ANAT,AICE,PI,ANUM,ADEN
  DATA AMW/52.45, 108.00, 108.00, 97.45, 97.45, 96.91,              &
           52.45, 96.91, 141.91/               
!------------------------------------------------------------------------
!  AMW = MOLECULAR WEIGHT OF GAS PHASE SPECIES
!------------------------------------------------------------------------
  DATA PI/3.141592653589793/    
  DATA GNAT/0.1, 3.0E-3, 4.0E-4, 4.0E-3, 0.2,                    &
            0.0, 0.0, 0.0, 0.0/
  DATA GICE/0.2, 0.03, 0.02, 0.3, 0.3, 0.3,                         &
            0.03, 0.1, 0.3/
  DATA INN/4,4,0,0,4,4,11,11,0/
!------------------------------------------------------------------------
!  INN = INDEX NUMBER OF LIQUID/SOLID PHASE SPECIES (0= H2O)
!-------------------------------------------------------------------------
!     REACTION 70 HOCL + HCL --> H2O + CL2 (HETEROGENEOUS)              
!     REACTION 71 N2O5 + HCL --> HNO3 + CLNO2 (HETEROGENEOUS)           
!     REACTION 72 N2O5+H2O --> 2HNO3 (HETEROGENEOUS)
!     REACTION 73 CLONO2+H2O --> HOCL+HNO3 (HETEROGENEOUS)              
!     REACTION 74 CLONO2+HCL --> CL2+HNO3 (HETEROGENEOUS)               
!     REACTION 75 HOBR + HCL --> BRCL + H2O (HETEROGENEOUS)             
!     REACTION 76 HOCL + HBR --> BRCL + H2O (HETEROGENEOUS)             
!     REACTION 77 HOBR + HBR --> 2BR + H2O (HETEROGENEOUS)              
!     REACTION 78 BRONO2 + H2O --> HOBR + HNO3 (HETEROGENEOUS)
!     (THE FIRST MOLECULE ON THE LEFT HAND SIDE IS IN THE GAS PHASE,
!     THE SECOND MOLECULE IS IN THE LIQUID/SOLID PHASE)         
!
!-------------------------------------------------------------------------
!
!    aliq is the liquid surface area. const is sqrt(8R/(pi*mw)) for the
!    gaseous phase species, with the mean molecular
!    speed equal to const*sqrt(temp)
!
!-------------------------------------------------------------------------
    DO 60 IC = 1,NHET
      CONST(IC) = SQRT(8.0*8.3144E7/(PI*AMW(IC)))
      DO 50 IL = 1,MERIDS
        IF(INN(IC).EQ.0) THEN
          CHEMC(IL,IC) = H2O(IL)
        ELSE
          CHEMC(IL,IC) = DYY(IL,INN(IC))
        ENDIF
        RATES(IL,IHET-1+IC) =  0.0 
 50   ENDDO
 60 ENDDO
!-------------------------------------------------------------------------
!
!    Reactions IHET to IHET+NHET-1 on NAT
!
!-------------------------------------------------------------------------
    DO IC = 1,NHET
      DO IL = 1,MERIDS
        G2NAT(IL,IC) = GNAT(IC)
      ENDDO
    ENDDO
    DO 110 IL=1,MERIDS
      DELT(IL) = TEMP(IL) - TICE(IL)
      SICE(IL) =  10**(2668.70*(1.0/TEMP(IL) - 1.0/TICE(IL)))      
      IF (SICE(IL) .GT. 3.0) SICE(IL) = 3.0
      G2NAT(IL,4) =EXP(-9.03 + 2.81*SICE(IL))
      G2NAT(IL,5) = 1.0/(4.3478 + 1.4241*EXP(0.518*DELT(IL)))             
110 ENDDO
!
    DO IC=1,NHET
      DO IL=1,MERIDS
        ANUM = PI*CONST(IC)*RTT(IL)*G2NAT(IL,IC)*ANAT*RNAT(IL)**2
        ADEN = CHEMC(IL,IC)
        IF(ADEN.GT.0.0.AND.ANUM.GT.0.0)                               &
            RATES(IL,IHET-1+IC) =  ANUM/ADEN
      ENDDO
    ENDDO
!-------------------------------------------------------------------------
!
!    Reactions IHET to IHET+NHET-1 on ICE
!
!------------------------------------------------------------------------ 
    DO IC=1,NHET
      DO IL=1,MERIDS
        ANUM = PI*CONST(IC)*RTT(IL)*GICE(IC)*AICE*RICE(IL)**2  
        ADEN = CHEMC(IL,IC)                
        IF(ADEN.GT.0.0.AND.ANUM.GT.0.0)                               &
           RATES(IL,IHET-1+IC) = ANUM/ADEN 
      ENDDO
    ENDDO
!-------------------------------------------------------------------------
!
!    Reactions IHET to IHET+NHET-1 on AEROSOL
!    aliq is the liquid surface area. const is sqrt(8R/(pi*mw)) for the
!    gaseous phase species, with the mean molecular speed equal to 
!        const*sqrt(temp)
!
!-------------------------------------------------------------------------
    DO IC = 1,NHET
      DO IL = 1,MERIDS
        IF(CHEMC(IL,IC).GT.0.0)                                       &
           RATES(IL,IHET+IC-1) =  RATES(IL,IHET+IC-1) +               &
           0.25*GAMMA(IL,IC)*CONST(IC)*RTT(IL)*ALIQ(IL)/CHEMC(IL,IC)
      ENDDO
    ENDDO
!    
    RETURN
END SUBROUTINE HETRATES
!
SUBROUTINE DENSITY(WF,T,DENS,MERIDS)
IMPLICIT NONE
!
!    Density of ternary solution in g cm-3
!
  INTEGER, intent(in)    :: MERIDS
  REAL,    intent(in )   :: WF(MERIDS,2), T(MERIDS)
  REAL,    intent(inout) :: DENS(MERIDS)

  INTEGER IL
  REAL X(22),AMR(3)
  REAL W,WH,T2,V1,A1,A2,VS,VN,VMCAL
  DATA X/2.393284E-02,-4.359335E-05,7.961181E-08,0.0,-0.198716351,   &
         1.39564574E-03,-2.020633E-06,0.51684706,-3.0539E-03,        &
         4.505475E-06,-0.30119511,1.840408E-03,-2.7221253742E-06,    &
        -0.11331674116,8.47763E-04,-1.22336185E-06,0.3455282,        &
        -2.2111E-03,3.503768245E-06,-0.2315332,1.60074E-03,          &
        -2.5827835E-06/
  DATA AMR/0.05550622,0.01019576,0.01586899/
    DO 100 IL=1,MERIDS
      W = WF(IL,1) + WF(IL,2)
      WH = 1.0 - W
      T2 = T(IL)**2
      V1 = X(1) + X(2)*T(IL) + X(3)*T2 + X(4)*T2*T(IL)
      A1 = X(8) + X(9)*T(IL) + X(10)*T2
      A2 = X(11) + X(12)*T(IL) + X(13)*T2
      VS = X(5) + X(6)*T(IL) + X(7)*T2 + A1*W + A2*W**2
      A1 = X(17) + X(18)*T(IL) + X(19)*T2
      A2 = X(20) + X(21)*T(IL) + X(22)*T2
      VN = X(14) + X(15)*T(IL) + X(16)*T2 + A1*W + A2*W**2
      VMCAL = WH*V1*AMR(1) + VS*WF(IL,1)*AMR(2) + VN*WF(IL,2)*AMR(3)
      DENS(IL) = 1.0E-3/VMCAL
100 ENDDO
!
  RETURN
END SUBROUTINE DENSITY
     
SUBROUTINE PHOTO_RATES (VTEMP,OZONX,COSPHI,KL,PHOTO,OZON,COSP,    &
                        COSPHC,MERIDS,IRX,IRX4,FOTO,MYPE)
!---------------------------------------------------------------------- 
!   THIS SUBROUTINE CALCULATES THE PHOTOLYSIS RATES USING A LOOK-UP     
!   TABLE. THE RATES ARE PUT INTO FOTO AND ARE AS FOLLOWS               
!   1.  O2 + HV --> 2O
!   2.  O3 + HV --> OSD + O2
!   3.  O3 + HV --> O3P + O2
!   4.  NO2 + HV --> NO + O
!   5.  HNO3 + HV --> OH + NO2 (300K) (LATER OVERWRITTEN WITH VALUE     
!   6.  NO3 + HV --> NO2 + O
!   7.  NO3 + HV --> NO + O2
!   8.  N2O5 + HV --> NO2 + NO3  (300K)  (LATER OVERWRITTEN WITH VALUE  
!   9.  N2O5 + HV --> NO2 + NO3  (250K)               AT TEMP)          
!  10.  N2O5 + HV --> NO2 + NO3  (200K)
!  11.  H2O2 + HV --> 2OH
!  12.  CLONO2 + HV --> CL + NO3 (300K) (LATER OVERWRITTEN WITH VALUE   
!  13.  H2CO + HV --> H + HCO --> 2H + CO
!  14.  H2CO + HV --> H2 + CO
!  15.  HOCL + HV --> OH + CL
!  16.  CL2O2 + HV --> CLO2 + CL
!  17.  BRONO2 + HV --> BR + NO3
!  18.  HOBR + HV --> OH + BR
!  19.  BRO + HV --> BR + O
!  20.  HNO3 + HV --> OH + NO2 (250K)
!  21.  HNO3 + HV --> OH + NO2 (200K)
!  22.  CLONO2 + HV --> CL + NO3 (250K)
!  23.  CLONO2 + HV --> CL + NO3 (200K)
!  24.  BRCL + HV --> BR + CL
!  25.  HNO4 + HV --> HO2 + NO2
!  26.  HONO + HV --> OH + NO
!  27.  CH3OOH + HV --> H2CO + HO2 + OH
!  28.  N2O + HV --> N2 + OSD  (300K)  (LATER OVERWRITTEN WITH VALUE  
!  29.  N2O + HV --> N2 + OSD  (250K)               AT TEMP)          
!  30.  N2O + HV --> N2 + OSD  (200K)
!  31.  NO + HV --> N + O
!  32.  H2O + HV --> H + OH
!  33.  HCL + HV --> H + CL
!---------------------------------------------------------------------- 
IMPLICIT NONE
  INTEGER, intent(in) :: MERIDS,IRX,IRX4,MYPE, KL
  REAL, intent(in) :: PHOTO(IRX4,14,11,48), OZON(11,48),      &
       VTEMP(MERIDS),OZONX(MERIDS),COSPHI(MERIDS)
  REAL, intent(inout) ::   COSP(14), FOTO(MERIDS,IRX4), COSPHC(48)


  REAL  X1(MERIDS),X2(MERIDS),Y1(MERIDS),Y2(MERIDS),Z1(MERIDS),       &
        Z2(MERIDS),OZON1(MERIDS),OZON2(MERIDS),           &
        COSP1(MERIDS),COSP2(MERIDS)  
  INTEGER IL,ICOX,IOX,IR,IM
  INTEGER IOZ(MERIDS),ICOZ(MERIDS)    
  LOGICAL LCOZ(MERIDS)
!
!      REAL  ALG,CX1,AX1,BX1,CX2,AX1,BX2,AX3,BX3,XX,ZZ,P1,P2,XX2,AX2,CX3  
  REAL  ALG,CX1,AX1,BX1,CX2,AX2,BX2,CX3,AX3,BX3,XX,ZZ,P1,P2,XX2  
!    
!
     IF(KL.EQ.48) COSPHC(KL) = COSPHC(2)
     COSP(1) = -COSPHC(KL)*0.5
     COSP(2) = -COSPHC(KL)*0.25
     DO 110 IL = 1,MERIDS
       LCOZ(IL) = COSPHI(IL).GT.(-COSPHC(KL))
 110 ENDDO
     DO 120 IL = 1,MERIDS
       ICOZ(IL) = 1
       COSP1(IL) = COSP(1)
       COSP2(IL) = COSP(2)
 120 ENDDO
     DO 140 ICOX =  2,13
       DO 130 IL = 1,MERIDS
         IF(COSPHI(IL).GT.COSP(ICOX))  THEN
           ICOZ(IL) = ICOX
           COSP1(IL) = COSP(ICOX)
           COSP2(IL) = COSP(ICOX+1)
         ENDIF
 130   ENDDO
 140 ENDDO
!
!  INTERPOLATE LINEARLY IN COSPHI AND LINEARLY IN
!  OZONE AMOUNT FOR THE LOG OF THE PHOTODISSOCIATION RATE.              
!
     DO 150 IL = 1,MERIDS
       IOZ(IL) = 1
       OZON1(IL) = OZON(1,KL)
       OZON2(IL) = OZON(2,KL)
 150 ENDDO
     DO 170 IOX = 2,10
       DO 160 IL = 1,MERIDS
         IF(OZONX(IL).GT.OZON(IOX,KL))  THEN
           IOZ(IL) = IOX
           OZON1(IL) = OZON(IOX,KL)
           OZON2(IL) = OZON(IOX+1,KL)
         ENDIF
 160   ENDDO
 170 ENDDO
     DO 190 IL = 1,MERIDS
       X1(IL) = OZONX(IL) - OZON1(IL)
       X2(IL) = OZON2(IL) - OZONX(IL)
       XX = X1(IL) + X2(IL)
       IF(XX.EQ.0.0) THEN
         WRITE(6,*) 'TEST 1 ', MYPE
         WRITE(6,*) IL,KL,X1(IL),X2(IL),OZONX(IL),OZON1(IL),             &
                    OZON2(IL),IOZ(IL)
       ENDIF
       Y1(IL) = 1./(X1(IL) + X2(IL))
       Z1(IL) = COSPHI(IL) - COSP1(IL)
       Z2(IL) = COSP2(IL) - COSPHI(IL)
       ZZ = Z1(IL) + Z2(IL)
       IF(ZZ.EQ.0.0) THEN
         WRITE(6,*) 'TEST 2 ', MYPE
         WRITE(6,*) IL,KL,Z1(IL),Z2(IL),COSPHI(IL),COSP1(IL),            &
                    COSP2(IL),ICOZ(IL)
       ENDIF
       Y2(IL) = 1./ZZ
 190 ENDDO
     DO 200 IL = 1,MERIDS
       X1(IL) = X1(IL)*Y1(IL)
       X2(IL) = X2(IL)*Y1(IL)
       Z1(IL) = Z1(IL)*Y2(IL)
       Z2(IL) = Z2(IL)*Y2(IL)
 200 ENDDO
     DO 220 IR = 1,IRX4
       DO 210 IL = 1,MERIDS
         FOTO(IL,IR) = 0.
 210   ENDDO
 220 ENDDO
     DO 240 IL = 1,MERIDS
       IF(LCOZ(IL))  THEN
         DO 230 IR = 1,IRX4
           P1 = PHOTO(IR,ICOZ(IL)+1,IOZ(IL)+1,KL)*X1(IL) +                 &
                X2(IL)*PHOTO(IR,ICOZ(IL)+1,IOZ(IL),KL)
           P2 = PHOTO(IR,ICOZ(IL),IOZ(IL)+1,KL)*X1(IL) +                   &
             X2(IL)*PHOTO(IR,ICOZ(IL),IOZ(IL),KL)
           ALG =  P1*Z1(IL) + P2*Z2(IL)
           FOTO(IL,IR) = ALG
 230     ENDDO
       ENDIF
 240 ENDDO
!
!  PHOTODISSOCIATION RATES FOR TEMPERATURE DEPENDENT N2O5 CROSS-SECTION 
!  FIT A QUADRATIC TO THE VALUES AT 300K, 250K AND 200K                 
!
     DO 250 IL = 1,MERIDS
       IF(LCOZ(IL))  THEN
         XX = 5.0 - VTEMP(IL)*1000.0
         XX2 = XX*XX
         DO 245 IM = 0,3
           CX1 = FOTO(IL,10+IRX*IM)
           AX1 = (9.*FOTO(IL,8+IRX*IM) - 15.*FOTO(IL,9+IRX*IM) +             &
                  6.*CX1)*0.1
           BX1 = FOTO(IL,9+IRX*IM) - AX1 - CX1
           FOTO(IL,8+IRX*IM) = AX1*XX2 + BX1*XX + CX1
           CX2 = FOTO(IL,21+IRX*IM)      
           AX2 = (9.*FOTO(IL,5+IRX*IM) - 15.*FOTO(IL,20+IRX*IM) +            &
                  6.*CX2)*0.1
           BX2 = FOTO(IL,20+IRX*IM) - AX2 - CX2
           FOTO(IL,5+IRX*IM) = AX2*XX2 + BX2*XX + CX2
           CX3 = FOTO(IL,23+IRX*IM)      
           AX3 = (9.*FOTO(IL,12+IRX*IM) - 15.*FOTO(IL,22+IRX*IM) +           &
                  6.*CX3)*0.1
           BX3 = FOTO(IL,22+IRX*IM) - AX3 - CX3
           FOTO(IL,12+IRX*IM) = AX3*XX2 + BX3*XX + CX3
           CX1 = FOTO(IL,30+IRX*IM)
           AX1 = (9.*FOTO(IL,28+IRX*IM) - 15.*FOTO(IL,29+IRX*IM) +           &
                  6.*CX1)*0.1
           BX1 = FOTO(IL,29+IRX*IM) - AX1 - CX1
           FOTO(IL,28+IRX*IM) = AX1*XX2 + BX1*XX + CX1
 245     ENDDO
       ENDIF
 250 ENDDO
     DO 300 IL = 1,MERIDS
       IF(LCOZ(IL))  THEN  
         DO IM = 0,3
           DO IR = 1,IRX
             IF(FOTO(IL,IR+IM*IRX).GT.10.0) FOTO(IL,IR+IM*IRX) = 10.0
             IF(FOTO(IL,IR+IM*IRX).LT.-100.0) FOTO(IL,IR+IM*IRX) = -100.0
             FOTO(IL,IR+IM*IRX) =EXP(FOTO(IL,IR+IM*IRX))  
           ENDDO
         ENDDO
       ENDIF 
 300 ENDDO
     RETURN
END SUBROUTINE PHOTO_RATES
!/ ----------------------------------------------------------------     
!      
SUBROUTINE ZEN2(ITIME,DT,DRAD,DARG,DELTA,CDX)         
!
!  THIS SUBROUTINE CALCULATES THE COSINE OF THE SOLAR ZENITH ANGLE,     
!  COZEN, ALLOWING FOR LEAP YEARS AND THEELLIPTICITY OF THEEARTH'S    
!  ORBIT.
! ELONG IS THE LONGITUDE IN DEG.E. ,XLAT THE LATITUDE NORTH. GMT IS   
!  THE G.M.T. AND DAY IS THE DAY IN THE MONTH. TIMING INFO. IS GIVEN BY 
!  ITIME.
!
IMPLICIT NONE
INTEGER, intent(in) :: ITIME(6)
REAL, intent(in)    :: DT,DRAD
REAL, intent(inout)   :: DARG,DELTA,CDX

REAL DGMT,DP,D1,D2,DF1,DTY,DR,DET,    &
      DAL1,DAL,CD1,DTD
!
INTEGER  IYEAR,IMON,IDAY
!
    IYEAR = ITIME(1)
    IMON = ITIME(2)
    IDAY = ITIME(3)
    DGMT = ITIME(4) + ITIME(5)/60.0 + (ITIME(6) + 0.5*DT)/3600.0
    IF(DGMT.LT.24.)  GOTO 5
    DGMT = DGMT - 24.
    IDAY = IDAY + 1.
  5 DP = 365.*IYEAR + IDAY + 31.*(IMON-1.)
    IF(IMON - 2)  10,10,20
 10 D1 = (IYEAR - 1.)*0.25
    D2 = (IYEAR - 1.)*1.E-2 + 1.
    DF1 = DP + INT(D1) - INT(0.75*INT(D2))
    GOTO 30
 20 D1 = 4.E-1*IMON + 2.3
    D2 = IYEAR*1.E-2
    DF1 = DP - INT(D1) + INT(25.*D2) - INT(0.75*(INT(D2) + 1.))       
 30 DTY = (DF1 - 693960.)/36525.
    DTD = 100.*DTY
    DR = (2.7969668E02 + 3.6000768925E04*DTY + 3.03E-4*DTY*DTY)*    &
      DRAD
    DET = (-9.32701E01  - 1.42E-1*DTD)*SIN(DR) + (-4.3194497E02 +    &
      3.3E-2*DTD)*COS(DR) + 5.965E02*SIN(2.*DR) - 2.*COS(2.*DR)       &
    + 4.2E00*SIN(3.*DR) + 1.93E01*COS(3.*DR) - 1.28E01*SIN(4.*DR)   
    DAL1 = DET*DRAD/240.0
    DAL = DR - DAL1
!
!  DELTA IS THE SOLAR DECLINATION AND COZEN IS THE COSINE OF THE SOLAR  
!  ZENITH ANGLE
!
    DELTA = ATAN(4.336E-1*SIN(DAL))
    DARG = (DGMT - 12.0)*15.*DRAD + DAL1
    CD1 = DTD*DRAD*360.0
    CDX = 1.00011 + 0.034221*COS(CD1) + 0.001280*SIN(CD1) +            &
          0.000719*COS(2.*CD1) + 0.000077*SIN(2.*CD1)                 
    RETURN
END SUBROUTINE ZEN2
!
SUBROUTINE SEDIMENT(ANAT,AICE,ANOY,AH2O,AHNO3,P_FIELD,LEVELS,     &
                    PRESS,DT,MYPE)      
!
!  CALCULATES SEDIMENTATION RATES OF TYPE I AND TYPE 2 PARTICLES               
!  AND VERTICALLY ADVECTS MODEL NAT AND ICE
!
  INTEGER, intent(in) ::  P_FIELD, LEVELS, MYPE
  REAL, intent(inout) :: ANAT(P_FIELD,LEVELS),AICE(P_FIELD,LEVELS), &
       ANOY(P_FIELD,LEVELS),AH2O(P_FIELD,LEVELS),                   &
       AHNO3(P_FIELD,LEVELS)
  REAL, intent(in) :: PRESS(P_FIELD,LEVELS)
  REAL, intent(in) :: DT   


  REAL  SNATS(P_FIELD,LEVELS),SICES(P_FIELD,LEVELS),                 &
        F1(P_FIELD,LEVELS),F2(P_FIELD,LEVELS), &
        PNAT(P_FIELD),PICE(P_FIELD),PNAT2(P_FIELD),PICE2(P_FIELD),        &
        ANAT2(P_FIELD,LEVELS),AICE2(P_FIELD,LEVELS),                 &
        ANATMAX(P_FIELD),AICEMAX(P_FIELD)
!
!  DATA: V1 IS SEDIMENTATION VELOCITY (M/S)
!  OF ICE PARTICLES V2 IS SEDIMENTATION VELOCITY OF         
!  NAT PARTICLES, ASSUMED RADII R1, R2.
!  AM1, AM2 ARE THE MOLECULAR WEIGHTS AND RHO1, RHO2 ARE THE DENSITIES 
!  OF THE PSCs IN G/CM3
!
!      DATA  V1, V2/1.27E-2, 1.39E-4/
!      DATA  R1, R2/7.0E-6, 0.5E-6/
!      DATA AM1,AM2/18.0,117.0/
!      DATA RHO1,RHO2/0.928, 1.35/
  REAL ::   V1=1.27E-2,  V2=1.39E-4
  REAL ::   R1=7.0E-6,   R2=0.5E-6
  REAL ::  AM1=18.0,    AM2=117.0
  REAL :: RHO1=0.928,  RHO2=1.35
  REAL :: RATIO, TEMP, PFRAC, DZ, CONST, D1, D2, FIXNAT, FIXICE
  INTEGER :: KL, JL

!
!  CALCULATE FRACTION OF NAT PARTICLES USED AS TYPE 2 CORES (F1)               
!  AND FRACTION OF NAT PARTICLES THAT REMAIN AS TYPE 1 CORES (F2)              
!  DETERMINE MAXIMUM NAT AND ICE TO APPLY LIMITERS TO ADVECTED AMOUNTS
!
    ANATMAX(:) = 0.0
    AICEMAX(:) = 0.0
    RATIO = AM1*RHO2/(AM2*RHO1)*(R2/R1)**3
    DO 20 KL = 1,LEVELS 
      DO 10 JL = 1,P_FIELD 
        IF(AICE(JL,KL).LT.1.0E-18) THEN 
          AICE(JL,KL) = 0.       
        ENDIF
        IF(ANAT(JL,KL).LT.1.0E-18)  THEN
          ANAT(JL,KL) = 0.
          F1(JL,KL) = 0.
          F2(JL,KL) = 0.
        ELSE
          F1(JL,KL) = AICE(JL,KL)*RATIO/ANAT(JL,KL)
          IF(F1(JL,KL).GT.1.0)  F1(JL,KL) = 1.0
          F2(JL,KL) = 1.0 - F1(JL,KL)
        ENDIF
        IF(ANAT(JL,KL).GT.ANATMAX(JL)) ANATMAX(JL) = ANAT(JL,KL)
        IF(AICE(JL,KL).GT.AICEMAX(JL)) AICEMAX(JL) = AICE(JL,KL)
 10   ENDDO
 20 ENDDO
!
! VERTICALLY ADVECT NAT AND ICE. NOTE THAT PART OF NAT IS ADVECTED             
! AT TYPE 2 RATE AND THE REMAINDER AT TYPE 1 RATE. CALCULATE DESCENT IN
!  1 TIMESTEP; USE APPROXIMATE VERTICAL DISPLACEMENT BETWEEN LAYERS
!
    TEMP = 195.0
    PNAT(:) = 0.0
    PICE(:) = 0.0
    DO 50 KL = 2,LEVELS
      DO 40 JL = 1,P_FIELD
        PFRAC = PRESS(JL,KL)/PRESS(JL,KL-1)
        DZ = 29.26*TEMP*ALOG(PFRAC)
        CONST = DT/DZ
        D1 = ANAT(JL,KL) - ANAT(JL,KL-1)
        D2 = AICE(JL,KL) - AICE(JL,KL-1)         
        SNATS(JL,KL) = -CONST*D1*(V1*F1(JL,KL) + V2*F2(JL,KL))
        SICES(JL,KL) = -CONST*D2*V1
        PNAT(JL) = PNAT(JL) + PRESS(JL,KL)*ANAT(JL,KL)
        PICE(JL) = PICE(JL) + PRESS(JL,KL)*AICE(JL,KL)
 40   ENDDO!CONTINUE
 50 ENDDO!CONTINUE
!
!  set sedimented nat and ice to zero at top and bottom
!
    SNATS(:,1) = 0.0
    SICES(:,1) = 0.0 
    SNATS(:,LEVELS) = 0.0
    SICES(:,LEVELS) = 0.0
    DO 70 KL = 1,LEVELS
      DO 60 JL = 1,P_FIELD
        ANAT2(JL,KL) = ANAT(JL,KL) + SNATS(JL,KL)
        AICE2(JL,KL) = AICE(JL,KL) + SICES(JL,KL)
!
!  APPLY LIMITERS TO NEW NAT AND ICE
!
        IF(ANAT2(JL,KL).LT.0.0) ANAT2(JL,KL) = 0.0
        IF(AICE2(JL,KL).LT.0.0) AICE2(JL,KL) = 0.0
        IF(ANAT2(JL,KL).GT.ANATMAX(JL)) ANAT2(JL,KL) = ANATMAX(JL)
        IF(AICE2(JL,KL).GT.AICEMAX(JL)) AICE2(JL,KL) = AICEMAX(JL)
 60   ENDDO!CONTINUE
 70 ENDDO!CONTINUE
!
! APPLY MASS FIXER
!
    PNAT2(:) = 0.0
    PICE2(:) = 0.0
    DO 90 KL = 1,LEVELS
      DO 80 JL = 1,P_FIELD
        PNAT2(JL) = PNAT2(JL) + PRESS(JL,KL)*ANAT2(JL,KL)
        PICE2(JL) = PICE2(JL) + PRESS(JL,KL)*AICE2(JL,KL)
 80   ENDDO!CONTINUE
 90 ENDDO!CONTINUE
    DO 110 JL = 1,P_FIELD
      IF(PNAT2(JL).EQ.0.0) THEN 
        FIXNAT = 1.0
      ELSE 
        FIXNAT = PNAT(JL)/PNAT2(JL)
      ENDIF
      IF(PICE2(JL).EQ.0.0) THEN
        FIXICE = 1.0
      ELSE
        FIXICE = PICE(JL)/PICE2(JL)
      ENDIF
      DO 100 KL = 1,LEVELS
        ANAT2(JL,KL) = ANAT2(JL,KL)*FIXNAT 
        AICE2(JL,KL) = AICE2(JL,KL)*FIXICE 
100   ENDDO
110 ENDDO
!
!  ADJUST NOY AND H2O TENDENCY FIELDS
!
    DO KL = 1,LEVELS
      DO JL = 1,P_FIELD
        ANOY(JL,KL) = ANOY(JL,kl) + (ANAT2(JL,KL) - ANAT(JL,KL))/DT 
        AHNO3(JL,KL) = AHNO3(JL,kl) + (ANAT2(JL,KL) - ANAT(JL,KL))/DT 
        AH2O(JL,KL) = AH2O(JL,KL) + (AICE2(JL,KL) - AICE(JL,KL))/DT 
     ENDDO
   ENDDO
   RETURN
END SUBROUTINE SEDIMENT
!
SUBROUTINE GHGS(ITIME,ISC,CH4,AN2O,CH4TR,AN2OTR)
!
!  FINDS THE CONCENTRATIONS OF THE GHGS CH4 AND N2O ACCORDING TO THE TIME 
!  ITIME AND SCENARIO ISC, CHOSEN FROM SRES
!
  INTEGER, intent(in) :: ITIME(6),ISC
  REAL, intent(inout) :: CH4,AN2O,CH4TR,AN2OTR

  REAL TIMEN2O(22),AN2O_A1B(22),AN2O_A2(22),AN2O_B1(22)
  REAL TIMECH4(36),CH4_A1B(36),CH4_A2(36),CH4_B1(36)
  REAL TIME, SECS, X1,X2, Z1, C1, C2
  INTEGER IMON(12), IT
  DATA  IMON/0,31,59,90,120,151,181,212,243,273,304,334/
  DATA TIMEN2O/                                                     &
     1950.5, 1976.5, 1980.5, 1984.5, 1988.5, 1990.5,                &
     1992.5, 1994.5, 1996.5, 1998.5, 2000.5, 2010.5,                &
     2020.5, 2030.5, 2040.5, 2050.5, 2060.5, 2070.5,                &
     2080.5, 2090.5, 2100.5, 2500.5/
  DATA AN2O_A1B/                                                    &
     278.0,  299.0,  301.0,  303.0,  305.0,  309.6,                 &
     311.0,  312.0,  312.4,  314.0,  316.0,  324.0,                 &
     331.0,  338.0,  344.0,  350.0,  356.0,  360.0,                 &
     365.0,  368.0,  372.0,  372.0/
  DATA AN2O_A2/                                                     &
     278.0,  299.0,  301.0,  303.0,  305.0,  309.6,                 &
     311.0,  312.0,  312.4,  314.0,  316.0,  325.0,                 &
     335.0,  347.0,  360.0,  373.0,  387.0,  401.0,                 &
     416.0,  432.0,  447.0,  447.0/
  DATA AN2O_B1/                                                     &
     278.0,  299.0,  301.0,  303.0,  305.0,  309.6,                 &
     311.0,  312.0,  312.4,  314.0,  316.0,  324.0,                 &
     333.0,  341.0,  349.0,  357.0,  363.0,  368.0,                 &
     371.0,  374.0,  375.0,  375.0/
  DATA TIMECH4/                                                     &
     1950.5, 1952.5, 1954.5, 1956.5, 1958.5, 1960.5,                &
     1962.5, 1964.5, 1966.5, 1968.5, 1970.5, 1972.5,                &
     1974.5, 1976.5, 1978.5, 1980.5, 1982.5, 1984.5,                &
     1986.5, 1988.5, 1990.5, 1992.5, 1994.5, 1996.5,                &
     1998.5, 2000.5, 2010.5, 2020.5, 2030.5, 2040.5,                &
     2050.5, 2060.5, 2070.5, 2080.5, 2090.5, 2100.5/
  DATA CH4_A1B/                                                     &
     1147.5, 1163.8, 1182.1, 1202.4, 1224.2, 1247.5,                &
     1272.2, 1298.4, 1326.0, 1355.3, 1386.0, 1417.5,                &
     1449.3, 1481.5, 1514.0, 1547.1, 1580.9, 1614.2,                &
     1644.9, 1671.6, 1694.3, 1714.0, 1721.0, 1728.0,                &
     1745.0, 1760.0, 1871.0, 2026.0, 2202.0, 2337.0,                &
     2400.0, 2386.0, 2301.0, 2191.0, 2078.0, 1974.0/
  DATA CH4_A2/                                                      &
     1147.5, 1163.8, 1182.1, 1202.4, 1224.2, 1247.5,                &
     1272.2, 1298.4, 1326.0, 1355.3, 1386.0, 1417.5,                &
     1449.3, 1481.5, 1514.0, 1547.1, 1580.9, 1614.2,                &
     1644.9, 1671.6, 1694.3, 1714.0, 1721.0, 1728.0,                &
     1745.0, 1760.0, 1861.0, 1997.0, 2163.0, 2357.0,                &
     2562.0, 2779.0, 3011.0, 3252.0, 3493.0, 3731.0/
  DATA CH4_B1/                                                      &
     1147.5, 1163.8, 1182.1, 1202.4, 1224.2, 1247.5,                &
     1272.2, 1298.4, 1326.0, 1355.3, 1386.0, 1417.5,                &
     1449.3, 1481.5, 1514.0, 1547.1, 1580.9, 1614.2,                &
     1644.9, 1671.6, 1694.3, 1714.0, 1721.0, 1728.0,                &
     1745.0, 1760.0, 1827.0, 1891.0, 1927.0, 1919.0,                &
     1881.0, 1836.0, 1797.0, 1741.0, 1663.0, 1574.0/
!
    TIME = ITIME(1) + (IMON(ITIME(2)) + ITIME(3))/365.0
    IF(ISC.EQ.4) TIME = ITIME(1) + 0.5
    IF(TIME.LT.1950.5) TIME = 1950.5
    IF(TIME.GT.2100.5) TIME = 2100.5
    SECS = 365.25*86400.0
    DO IT = 2,22
      IF(TIMEN2O(IT).GT.TIME) THEN
        X1 = TIMEN2O(IT) - TIME
        X2 = TIME - TIMEN2O(IT-1)
        Z1 = X1 + X2
        IF(ISC.EQ.1) THEN
          C1 = AN2O_A1B(IT-1)
          C2 = AN2O_A1B(IT)
        ELSEIF(ISC.EQ.2) THEN
          C1 = AN2O_A2(IT-1)
          C2 = AN2O_A2(IT)
        ELSEIF(ISC.EQ.3) THEN
          C1 = AN2O_B1(IT-1)
          C2 = AN2O_B1(IT)
        ELSEIF(ISC.EQ.4) THEN
          C1 = AN2O_A1B(IT-1)
          C2 = AN2O_A1B(IT)
        ENDIF
        AN2O = (X1*C1 + X2*C2)/Z1
        AN2OTR = (C2 - C1)/(AN2O*SECS*Z1)
        GOTO 10
      ENDIF
    ENDDO
 10 DO IT = 2,36
      IF(TIMECH4(IT).GT.TIME) THEN
        X1 = TIMECH4(IT) - TIME
        X2 = TIME - TIMECH4(IT-1)
        Z1 = X1 + X2
        IF(ISC.EQ.1) THEN
          C1 = CH4_A1B(IT-1)
          C2 = CH4_A1B(IT)
        ELSEIF(ISC.EQ.2) THEN
          C1 = CH4_A2(IT-1)
          C2 = CH4_A2(IT)
        ELSEIF(ISC.EQ.3) THEN
          C1 = CH4_B1(IT-1)
          C2 = CH4_B1(IT)
        ELSEIF(ISC.EQ.4) THEN
          C1 = CH4_A1B(IT-1)
          C2 = CH4_A1B(IT)
        ENDIF
        CH4 = (X1*C1 + X2*C2)/Z1
        CH4TR = (C2 - C1)/(CH4*SECS*Z1)
        GOTO 20
      ENDIF
    ENDDO
 20 AN2O = AN2O*1.0E-9
    CH4 = CH4*1.0E-9
    RETURN
END SUBROUTINE GHGS
!/ ----------------------------------------------------------------            
END MODULE STRAT_CHEM_MOD


      module MO_EXP_PROD_LOSS_MOD

implicit none
character(len=128), parameter :: version     = '$Id: moz.mat.F90,v 18.0 2010/03/02 23:34:49 fms Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

      subroutine exp_prod_loss( prod, loss, y, rxt, het_rates )

      use CHEM_MODS_MOD, only : clscnt1, rxntot, hetcnt
      use MO_GRID_MOD,   only : pcnstm1

      implicit none

!--------------------------------------------------------------------
!     ... Dummy args                                                                      
!--------------------------------------------------------------------
      real, dimension(:,:), intent(out) :: &
            prod, &
            loss
      real, intent(in)    ::  y(:,:)
      real, intent(in)    ::  rxt(:,:)
      real, intent(in)    ::  het_rates(:,:)


!--------------------------------------------------------------------
!       ... Loss and production for Explicit method
!--------------------------------------------------------------------

      loss(:,1) = ((rxt(:,47) +rxt(:,48))* y(:,3) + rxt(:,4))* y(:,4)
      prod(:,1) = 0.
      loss(:,2) = (rxt(:,64)* y(:,3) +rxt(:,63)* y(:,17) +rxt(:,191)* y(:,71)) &
                 * y(:,12)
      prod(:,2) = 0.
      loss(:,3) = ((rxt(:,72) +rxt(:,73))* y(:,17))* y(:,16)
      prod(:,3) = 0.
      loss(:,4) = (rxt(:,100)* y(:,17))* y(:,29)
      prod(:,4) = 0.
      loss(:,5) = (rxt(:,144)* y(:,17))* y(:,42)
      prod(:,5) = 0.
      loss(:,6) = (rxt(:,74)* y(:,3) +rxt(:,83)* y(:,17))* y(:,61)
      prod(:,6) =.050*rxt(:,64)*y(:,12)*y(:,3)
      loss(:,7) = (rxt(:,46)* y(:,3) + (rxt(:,56) +rxt(:,217))* y(:,11) +rxt(:,218) &
                 * y(:,70) +rxt(:,223)* y(:,77) + rxt(:,14))* y(:,83)
      prod(:,7) = (rxt(:,63)*y(:,12) +rxt(:,83)*y(:,61) +rxt(:,100)*y(:,29) + &
                 rxt(:,144)*y(:,42))*y(:,17)

      end subroutine exp_prod_loss

      end module MO_EXP_PROD_LOSS_MOD

      module MO_IMP_PROD_LOSS_MOD

      contains

      subroutine imp_prod_loss( prod, loss, y, rxt, het_rates )

      use CHEM_MODS_MOD, only : clscnt4, rxntot, hetcnt, clsze
      use MO_GRID_MOD,   only : pcnstm1

      implicit none

!--------------------------------------------------------------------
!     ... Dummy args                                                                      
!--------------------------------------------------------------------
      real, dimension(:), intent(out) :: &
            prod, &
            loss
      real, intent(in)    ::  y(:)
      real, intent(in)    ::  rxt(:)
      real, intent(in)    ::  het_rates(:)



!--------------------------------------------------------------------
!       ... Loss and production for Implicit method
!--------------------------------------------------------------------


         loss(67) = (rxt(43)* y(2) +rxt(50)* y(6) +rxt(52)* y(7) +rxt(77)* y(17) &
                  +rxt(78)* y(18) +rxt(85)* y(20) +rxt(99)* y(21) +rxt(110)* y(30) &
                  +rxt(119)* y(34) +rxt(121)* y(35) +rxt(138)* y(41) +rxt(161)* y(57) &
                  +rxt(186)* y(71) +rxt(200)* y(78) +rxt(184)* y(82) + rxt(2) &
                  + rxt(3))* y(1)
         prod(67) = (.100*rxt(99)*y(21) +.200*rxt(119)*y(34) +.200*rxt(121)*y(35)) &
                 *y(1) + (.300*rxt(94)*y(25) +.300*rxt(131)*y(38))*y(18) +rxt(42)*y(2)
         loss(15) = ((rxt(47) +rxt(48))* y(4) +rxt(64)* y(12) +rxt(74)* y(61) +rxt(46) &
                 * y(83) + rxt(44) + rxt(45))* y(3)
         prod(15) =rxt(2)*y(1)
         loss(68) = (rxt(43)* y(1) +rxt(213)* y(6) +rxt(51)* y(7) +rxt(75)* y(17) &
                  +rxt(76)* y(18) +rxt(190)* y(70) +rxt(187)* y(72) +rxt(205)* y(75) &
                  + rxt(42))* y(2)
         prod(68) = (rxt(142) +rxt(143)*y(6) +rxt(214)*y(7))*y(5) + (rxt(3) + &
                 .765*rxt(138)*y(41))*y(1) + (rxt(44) +rxt(45))*y(3) +rxt(5)*y(6) &
                  +rxt(6)*y(7) +.890*rxt(9)*y(8) +rxt(82)*y(17)*y(17) +rxt(40)*y(79)
         loss(14) = (rxt(143)* y(6) +rxt(214)* y(7) + rxt(142))* y(5)
         prod(14) =rxt(5)*y(6)
         loss(70) = (rxt(50)* y(1) +rxt(213)* y(2) +rxt(143)* y(5) +rxt(59)* y(8) &
                  +rxt(65)* y(13) +rxt(49)* y(18) +rxt(87)* y(22) +rxt(92)* y(25) &
                  +rxt(113)* y(33) + (rxt(122) +rxt(123))* y(36) +rxt(129)* y(38) &
                  +rxt(101)* y(39) +rxt(145)* y(43) +rxt(107)* y(51) +rxt(150)* y(54) &
                  +rxt(155)* y(56) +rxt(164)* y(58) +rxt(188)* y(72) +rxt(204)* y(79) &
                  + rxt(5))* y(6)
         prod(70) = (rxt(6) +rxt(51)*y(2) +rxt(211)*y(8))*y(7) +2.000*rxt(47)*y(4) &
                 *y(3) +rxt(142)*y(5) +.110*rxt(9)*y(8)
         loss(76) = (rxt(52)* y(1) +rxt(51)* y(2) +rxt(214)* y(5) +rxt(54)* y(8) &
                  +rxt(57)* y(17) +rxt(60)* y(18) +rxt(93)* y(25) +rxt(135)* y(38) &
                  +rxt(189)* y(72) +rxt(201)* y(79) + rxt(6))* y(7)
         prod(76) = (rxt(49)*y(18) +rxt(50)*y(1) +2.000*rxt(59)*y(8) +rxt(65)*y(13) + &
                 rxt(87)*y(22) +rxt(92)*y(25) +rxt(101)*y(39) +rxt(107)*y(51) + &
                 .920*rxt(113)*y(33) +rxt(122)*y(36) +rxt(129)*y(38) +rxt(145)*y(43) + &
                 rxt(150)*y(54) +1.206*rxt(155)*y(56) +rxt(164)*y(58) + &
                 rxt(188)*y(72) +rxt(204)*y(79) +rxt(213)*y(2))*y(6) + (.890*rxt(9) + &
                 rxt(53)*y(18) +rxt(114)*y(33) +rxt(124)*y(36) +rxt(130)*y(38) + &
                 rxt(139)*y(41) +1.206*rxt(156)*y(56) +rxt(162)*y(57) + &
                 rxt(165)*y(58) +rxt(181)*y(64) +2.000*rxt(212)*y(8))*y(8) &
                  + (rxt(10) +rxt(62) +rxt(61)*y(17))*y(10) + (rxt(7) +rxt(55) + &
                 rxt(216)*y(68))*y(11) + (rxt(30) +.400*rxt(160)*y(17) + &
                 .400*rxt(161)*y(1))*y(57) + (.600*rxt(19) +rxt(97))*y(27) &
                  + (rxt(20) +rxt(136))*y(32) +rxt(8)*y(9) +rxt(153)*y(28)*y(17) &
                  +.206*rxt(157)*y(56)*y(18)
         loss(65) = (rxt(59)* y(6) + (rxt(54) +rxt(211))* y(7) + 2.*rxt(212)* y(8) &
                  +rxt(70)* y(15) +rxt(53)* y(18) +rxt(86)* y(20) +rxt(154)* y(21) &
                  +rxt(91)* y(23) +rxt(114)* y(33) +rxt(124)* y(36) +rxt(130)* y(38) &
                  +rxt(139)* y(41) +rxt(159)* y(55) +rxt(156)* y(56) +rxt(162)* y(57) &
                  +rxt(165)* y(58) +rxt(181)* y(64) + rxt(9) + rxt(141))* y(8)
         prod(65) = (rxt(58)*y(9) +.500*rxt(174)*y(32) +rxt(175)*y(27))*y(17) &
                  + (rxt(7) +rxt(55))*y(11) + (rxt(34) +rxt(190)*y(2))*y(70) &
                  +rxt(52)*y(7)*y(1) +.400*rxt(19)*y(27) +rxt(37)*y(77)
         loss(39) = (rxt(58)* y(17) + rxt(8))* y(9)
         prod(39) = (rxt(141) +rxt(70)*y(15) +rxt(91)*y(23) +rxt(159)*y(55))*y(8) &
                  + (2.000*rxt(140) +2.000*rxt(56)*y(83) +2.000*rxt(217)*y(83) + &
                 rxt(216)*y(68))*y(11) + (rxt(218)*y(83) +rxt(219)*y(68))*y(70) &
                  +rxt(57)*y(17)*y(7) +rxt(223)*y(83)*y(77)
         loss(19) = (rxt(61)* y(17) + rxt(10) + rxt(62))* y(10)
         prod(19) =rxt(60)*y(18)*y(7)
         loss(29) = (rxt(216)* y(68) + (rxt(56) +rxt(217))* y(83) + rxt(7) + rxt(55) &
                  + rxt(140))* y(11)
         prod(29) =rxt(54)*y(8)*y(7)
         loss(64) = (rxt(65)* y(6) + 2.*(rxt(66) +rxt(67))* y(13) +rxt(68)* y(18) &
                  +rxt(95)* y(25) +rxt(116)* y(33) +rxt(126)* y(36) +rxt(132)* y(38) &
                  +rxt(103)* y(39) +rxt(147)* y(43) +rxt(167)* y(58))* y(13)
         prod(64) = (rxt(92)*y(6) +.900*rxt(95)*y(13) +2.000*rxt(98)*y(25) + &
                 rxt(117)*y(33) +rxt(127)*y(36) +rxt(133)*y(38) +rxt(168)*y(58))*y(25) &
                  + (rxt(63)*y(17) +.750*rxt(64)*y(3) +rxt(191)*y(71))*y(12) &
                  +.310*rxt(85)*y(20)*y(1) +.700*rxt(69)*y(17)*y(14) +rxt(16)*y(23) &
                  +rxt(18)*y(26) +.400*rxt(19)*y(27) +.300*rxt(23)*y(34) +rxt(27) &
                 *y(45)
         loss(25) = (rxt(69)* y(17) + rxt(11))* y(14)
         prod(25) =rxt(68)*y(18)*y(13)
         loss(74) = (rxt(70)* y(8) +rxt(71)* y(17) +rxt(196)* y(71) +rxt(207)* y(78) &
                  + rxt(12) + rxt(13))* y(15)
         prod(74) = (rxt(65)*y(6) +2.000*rxt(66)*y(13) +rxt(67)*y(13) +rxt(95)*y(25) + &
                 .700*rxt(103)*y(39) +1.200*rxt(116)*y(33) +.880*rxt(126)*y(36) + &
                 2.000*rxt(132)*y(38) +rxt(147)*y(43) +.700*rxt(167)*y(58))*y(13) &
                  + (.540*rxt(85)*y(20) +.600*rxt(99)*y(21) +rxt(110)*y(30) + &
                 .800*rxt(119)*y(34) +.700*rxt(121)*y(35) +1.326*rxt(138)*y(41))*y(1) &
                  + (rxt(87)*y(22) +.550*rxt(113)*y(33) +.250*rxt(122)*y(36) + &
                 rxt(129)*y(38) +rxt(150)*y(54) +.072*rxt(155)*y(56))*y(6) &
                  + (.300*rxt(69)*y(14) +.500*rxt(96)*y(26) +.500*rxt(106)*y(30) + &
                 rxt(172)*y(47) +.500*rxt(174)*y(32) +rxt(175)*y(27))*y(17) &
                  + (.600*rxt(114)*y(33) +.250*rxt(124)*y(36) +rxt(130)*y(38) + &
                 .072*rxt(156)*y(56))*y(8) + (.600*rxt(117)*y(33) + &
                 .250*rxt(127)*y(36) +rxt(133)*y(38))*y(25) +.250*rxt(64)*y(12)*y(3) &
                  +rxt(11)*y(14) +.008*rxt(157)*y(56)*y(18) +rxt(17)*y(24) &
                  +1.340*rxt(21)*y(35) +2.000*rxt(134)*y(38)*y(38) +rxt(26)*y(46) &
                  +rxt(33)*y(49) +rxt(32)*y(50) +2.000*rxt(109)*y(52) +rxt(30)*y(57) &
                  +.690*rxt(31)*y(60)
         loss(75) = (rxt(77)* y(1) +rxt(75)* y(2) +rxt(57)* y(7) +rxt(58)* y(9) &
                  +rxt(61)* y(10) +rxt(63)* y(12) +rxt(69)* y(14) +rxt(71)* y(15) &
                  + (rxt(72) +rxt(73))* y(16) + 2.*(rxt(82) +rxt(197))* y(17) +rxt(81) &
                 * y(18) +rxt(80)* y(19) +rxt(84)* y(20) +rxt(111)* y(21) +rxt(90) &
                 * y(23) +rxt(89)* y(24) +rxt(96)* y(26) +rxt(175)* y(27) +rxt(153) &
                 * y(28) +rxt(100)* y(29) +rxt(106)* y(30) +rxt(112)* y(31) +rxt(174) &
                 * y(32) +rxt(118)* y(34) +rxt(120)* y(35) +rxt(128)* y(37) +rxt(105) &
                 * y(40) +rxt(137)* y(41) +rxt(144)* y(42) +rxt(148)* y(44) +rxt(149) &
                 * y(45) +rxt(152)* y(46) +rxt(172)* y(47) +rxt(173)* y(48) +rxt(177) &
                 * y(49) +rxt(176)* y(50) +rxt(163)* y(53) +rxt(158)* y(55) +rxt(160) &
                 * y(57) +rxt(169)* y(59) +rxt(171)* y(60) +rxt(83)* y(61) +rxt(178) &
                 * y(62) + (rxt(179) +rxt(180))* y(64) +rxt(183)* y(65) +rxt(192) &
                 * y(68) + (rxt(195) +rxt(210))* y(72) +rxt(208)* y(76))* y(17)
         prod(75) = (rxt(78)*y(18) +.330*rxt(85)*y(20) +.270*rxt(99)*y(21) + &
                 .120*rxt(110)*y(30) +.080*rxt(119)*y(34) +.215*rxt(121)*y(35) + &
                 1.156*rxt(138)*y(41) +rxt(184)*y(82))*y(1) + (.300*rxt(69)*y(14) + &
                 .500*rxt(89)*y(24) +.500*rxt(105)*y(40) +.100*rxt(128)*y(37))*y(17) &
                  + (2.000*rxt(46)*y(83) +.750*rxt(64)*y(12) +rxt(74)*y(61))*y(3) &
                  + (rxt(49)*y(6) +rxt(53)*y(8) +rxt(76)*y(2))*y(18) + (rxt(38) + &
                 rxt(205)*y(2))*y(75) +rxt(8)*y(9) +rxt(11)*y(14) +2.000*rxt(15)*y(19) &
                  +rxt(17)*y(24) +rxt(18)*y(26) +.660*rxt(22)*y(35) +rxt(24)*y(40) &
                  +rxt(25)*y(44) +rxt(26)*y(46) +rxt(29)*y(59) +rxt(35)*y(69)
         loss(71) = (rxt(78)* y(1) +rxt(76)* y(2) +rxt(49)* y(6) +rxt(60)* y(7) &
                  +rxt(53)* y(8) +rxt(68)* y(13) +rxt(81)* y(17) + 2.*rxt(79)* y(18) &
                  +rxt(88)* y(22) +rxt(94)* y(25) +rxt(115)* y(33) +rxt(125)* y(36) &
                  +rxt(131)* y(38) +rxt(102)* y(39) +rxt(146)* y(43) +rxt(151)* y(54) &
                  +rxt(157)* y(56) +rxt(166)* y(58) +rxt(193)* y(71) +rxt(194)* y(72) &
                  +rxt(206)* y(78) +rxt(203)* y(79))* y(18)
         prod(71) = (rxt(72)*y(16) +rxt(83)*y(61) +rxt(71)*y(15) +rxt(77)*y(1) + &
                 rxt(80)*y(19) +.250*rxt(106)*y(30) +.200*rxt(128)*y(37) + &
                 rxt(160)*y(57) +rxt(172)*y(47) +rxt(173)*y(48) +.500*rxt(174)*y(32) + &
                 rxt(176)*y(50) +.600*rxt(177)*y(49) +rxt(195)*y(72))*y(17) &
                  + (rxt(65)*y(6) +2.000*rxt(66)*y(13) +.900*rxt(95)*y(25) + &
                 rxt(103)*y(39) +rxt(116)*y(33) +.730*rxt(126)*y(36) +rxt(132)*y(38) + &
                 rxt(147)*y(43) +rxt(167)*y(58))*y(13) + (.190*rxt(85)*y(20) + &
                 .060*rxt(99)*y(21) +.120*rxt(110)*y(30) +.060*rxt(119)*y(34) + &
                 .275*rxt(121)*y(35) +.102*rxt(138)*y(41) +rxt(161)*y(57))*y(1) &
                  + (rxt(87)*y(22) +rxt(101)*y(39) +rxt(113)*y(33) + &
                 .470*rxt(122)*y(36) +rxt(145)*y(43) +.794*rxt(155)*y(56) + &
                 1.500*rxt(164)*y(58))*y(6) + (rxt(70)*y(15) +rxt(114)*y(33) + &
                 .470*rxt(124)*y(36) +.794*rxt(156)*y(56) +rxt(162)*y(57) + &
                 1.500*rxt(165)*y(58))*y(8) + (rxt(12) +rxt(196)*y(71) + &
                 rxt(207)*y(78))*y(15) + (rxt(117)*y(33) +.470*rxt(127)*y(36) + &
                 1.500*rxt(168)*y(58))*y(25) + (.200*rxt(64)*y(12) +rxt(74)*y(61)) &
                 *y(3) + (rxt(10) +rxt(62))*y(10) + (rxt(108) +rxt(109))*y(52) &
                  +rxt(11)*y(14) +.794*rxt(157)*y(56)*y(18) +rxt(16)*y(23) +rxt(17) &
                 *y(24) +1.340*rxt(21)*y(35) +1.200*rxt(104)*y(39)*y(39) +rxt(24) &
                 *y(40) +rxt(25)*y(44) +2.000*rxt(33)*y(49) +rxt(32)*y(50) +rxt(28) &
                 *y(55) +rxt(30)*y(57) +rxt(31)*y(60) +rxt(185)*y(82)
         loss(10) = (rxt(80)* y(17) + rxt(15))* y(19)
         prod(10) =rxt(197)*y(17)*y(17) +rxt(79)*y(18)*y(18)
         loss(50) = (rxt(85)* y(1) +rxt(86)* y(8) +rxt(84)* y(17))* y(20)
         prod(50) = (.070*rxt(99)*y(21) +.119*rxt(138)*y(41))*y(1) +.700*rxt(23)*y(34)
         loss(47) = (rxt(99)* y(1) +rxt(154)* y(8) +rxt(111)* y(17))* y(21)
         prod(47) = 0.
         loss(41) = (rxt(87)* y(6) +rxt(88)* y(18))* y(22)
         prod(41) = (rxt(84)*y(20) +.500*rxt(89)*y(24))*y(17)
         loss(51) = (rxt(91)* y(8) +rxt(90)* y(17) + rxt(16))* y(23)
         prod(51) = (rxt(87)*y(22) +rxt(101)*y(39) +.270*rxt(145)*y(43))*y(6) &
                  + (.500*rxt(85)*y(20) +.040*rxt(119)*y(34))*y(1) &
                  + (.500*rxt(105)*y(40) +rxt(173)*y(48))*y(17) &
                  + (.800*rxt(103)*y(13) +1.600*rxt(104)*y(39))*y(39) +rxt(17)*y(24) &
                  +rxt(24)*y(40)
         loss(32) = (rxt(89)* y(17) + rxt(17))* y(24)
         prod(32) =rxt(88)*y(22)*y(18)
         loss(62) = (rxt(92)* y(6) +rxt(93)* y(7) +rxt(95)* y(13) +rxt(94)* y(18) &
                  + 2.*rxt(98)* y(25) +rxt(117)* y(33) +rxt(127)* y(36) +rxt(168) &
                 * y(58))* y(25)
         prod(62) = (rxt(91)*y(23) +.530*rxt(124)*y(36) +rxt(130)*y(38) + &
                 rxt(159)*y(55))*y(8) + (.530*rxt(122)*y(36) +rxt(129)*y(38) + &
                 rxt(150)*y(54))*y(6) + (rxt(90)*y(23) +.500*rxt(96)*y(26) + &
                 rxt(158)*y(55))*y(17) + (.260*rxt(126)*y(36) +rxt(132)*y(38))*y(13) &
                  + (.600*rxt(19) +rxt(97))*y(27) +.530*rxt(127)*y(36)*y(25) &
                  +.300*rxt(23)*y(34) +1.340*rxt(21)*y(35) +2.000*rxt(134)*y(38)*y(38) &
                  +rxt(27)*y(45) +rxt(26)*y(46) +rxt(32)*y(50) +rxt(28)*y(55)
         loss(30) = (rxt(96)* y(17) + rxt(18))* y(26)
         prod(30) = (.700*rxt(94)*y(25) +.700*rxt(131)*y(38))*y(18)
         loss(33) = (rxt(175)* y(17) + rxt(19) + rxt(97))* y(27)
         prod(33) =rxt(93)*y(25)*y(7)
         loss(17) = (rxt(153)* y(17))* y(28)
         prod(17) =rxt(86)*y(20)*y(8)
         loss(20) = (rxt(110)* y(1) +rxt(106)* y(17))* y(30)
         prod(20) = 0.
         loss(6) = (rxt(112)* y(17))* y(31)
         prod(6) = 0.
         loss(35) = (rxt(174)* y(17) + rxt(20) + rxt(136))* y(32)
         prod(35) =rxt(135)*y(38)*y(7)
         loss(60) = (rxt(113)* y(6) +rxt(114)* y(8) +rxt(116)* y(13) +rxt(115)* y(18) &
                  +rxt(117)* y(25))* y(33)
         prod(60) = (rxt(111)*y(21) +1.640*rxt(137)*y(41) +.500*rxt(171)*y(60))*y(17) &
                  +1.700*rxt(139)*y(41)*y(8)
         loss(58) = (rxt(119)* y(1) +rxt(118)* y(17) + rxt(23))* y(34)
         prod(58) = (.320*rxt(113)*y(6) +.350*rxt(114)*y(8) +.260*rxt(116)*y(13) + &
                 .350*rxt(117)*y(25))*y(33) + (.039*rxt(155)*y(6) + &
                 .039*rxt(156)*y(8) +.039*rxt(157)*y(18))*y(56) &
                  + (.200*rxt(99)*y(21) +.442*rxt(138)*y(41))*y(1) +.402*rxt(31)*y(60)
         loss(56) = (rxt(121)* y(1) +rxt(120)* y(17) + rxt(21) + rxt(22))* y(35)
         prod(56) = (.230*rxt(113)*y(6) +.250*rxt(114)*y(8) +.190*rxt(116)*y(13) + &
                 .250*rxt(117)*y(25))*y(33) + (.167*rxt(155)*y(6) + &
                 .167*rxt(156)*y(8) +.167*rxt(157)*y(18))*y(56) &
                  + (.400*rxt(99)*y(21) +1.122*rxt(138)*y(41))*y(1) +.288*rxt(31) &
                 *y(60)
         loss(61) = ((rxt(122) +rxt(123))* y(6) +rxt(124)* y(8) +rxt(126)* y(13) &
                  +rxt(125)* y(18) +rxt(127)* y(25))* y(36)
         prod(61) = (rxt(118)*y(34) +.500*rxt(120)*y(35) +.200*rxt(128)*y(37))*y(17)
         loss(21) = (rxt(128)* y(17))* y(37)
         prod(21) =rxt(125)*y(36)*y(18)
         loss(63) = (rxt(129)* y(6) +rxt(135)* y(7) +rxt(130)* y(8) +rxt(132)* y(13) &
                  +rxt(131)* y(18) +rxt(133)* y(25) + 2.*rxt(134)* y(38))* y(38)
         prod(63) = (.500*rxt(120)*y(35) +.500*rxt(128)*y(37) +.800*rxt(177)*y(49)) &
                 *y(17) + (rxt(20) +rxt(136))*y(32) +.200*rxt(99)*y(21)*y(1) &
                  +.660*rxt(21)*y(35)
         loss(40) = (rxt(101)* y(6) +rxt(103)* y(13) +rxt(102)* y(18) + 2.*rxt(104) &
                 * y(39))* y(39)
         prod(40) = (rxt(100)*y(29) +.500*rxt(105)*y(40))*y(17)
         loss(22) = (rxt(105)* y(17) + rxt(24))* y(40)
         prod(22) =rxt(102)*y(39)*y(18)
         loss(48) = (rxt(138)* y(1) +rxt(139)* y(8) +rxt(137)* y(17))* y(41)
         prod(48) = 0.
         loss(45) = (rxt(145)* y(6) +rxt(147)* y(13) +rxt(146)* y(18))* y(43)
         prod(45) = (rxt(144)*y(42) +1.330*rxt(112)*y(31) +rxt(148)*y(44))*y(17)
         loss(23) = (rxt(148)* y(17) + rxt(25))* y(44)
         prod(23) =rxt(146)*y(43)*y(18)
         loss(37) = (rxt(149)* y(17) + rxt(27))* y(45)
         prod(37) = (.820*rxt(145)*y(6) +.820*rxt(147)*y(13))*y(43) &
                  +.100*rxt(137)*y(41)*y(17) +.820*rxt(25)*y(44)
         loss(24) = (rxt(152)* y(17) + rxt(26))* y(46)
         prod(24) =rxt(151)*y(54)*y(18)
         loss(34) = (rxt(172)* y(17))* y(47)
         prod(34) = (rxt(67)*y(13) +.300*rxt(103)*y(39) +.250*rxt(116)*y(33) + &
                 .250*rxt(126)*y(36) +.300*rxt(167)*y(58))*y(13)
         loss(18) = (rxt(173)* y(17))* y(48)
         prod(18) = (.200*rxt(103)*y(13) +.400*rxt(104)*y(39))*y(39)
         loss(42) = (rxt(177)* y(17) + rxt(33))* y(49)
         prod(42) = (.530*rxt(122)*y(6) +.530*rxt(124)*y(8) +.260*rxt(126)*y(13) + &
                 .530*rxt(127)*y(25))*y(36) + (.250*rxt(164)*y(6) + &
                 .250*rxt(165)*y(8) +.100*rxt(167)*y(13) +.250*rxt(168)*y(25))*y(58) &
                  +rxt(108)*y(52)
         loss(55) = (rxt(176)* y(17) + rxt(32))* y(50)
         prod(55) = (.220*rxt(122)*y(6) +.220*rxt(124)*y(8) +.230*rxt(126)*y(13) + &
                 .220*rxt(127)*y(25))*y(36) + (.250*rxt(164)*y(6) + &
                 .250*rxt(165)*y(8) +.100*rxt(167)*y(13) +.250*rxt(168)*y(25))*y(58) &
                  + (.500*rxt(89)*y(24) +.500*rxt(174)*y(32))*y(17)
         loss(28) = (rxt(107)* y(6))* y(51)
         prod(28) =.750*rxt(106)*y(30)*y(17)
         loss(11) = ( + rxt(108) + rxt(109))* y(52)
         prod(11) =rxt(107)*y(51)*y(6)
         loss(31) = (rxt(163)* y(17))* y(53)
         prod(31) = (.370*rxt(113)*y(6) +.400*rxt(114)*y(8) +.300*rxt(116)*y(13) + &
                 .400*rxt(117)*y(25))*y(33) + (.400*rxt(160)*y(17) + &
                 .400*rxt(161)*y(1))*y(57)
         loss(44) = (rxt(150)* y(6) +rxt(151)* y(18))* y(54)
         prod(44) = (rxt(149)*y(45) +rxt(152)*y(46))*y(17)
         loss(54) = (rxt(159)* y(8) +rxt(158)* y(17) + rxt(28))* y(55)
         prod(54) = (.250*rxt(122)*y(6) +.250*rxt(124)*y(8) +.240*rxt(126)*y(13) + &
                 .250*rxt(127)*y(25))*y(36) + (.250*rxt(164)*y(6) + &
                 .250*rxt(165)*y(8) +.100*rxt(167)*y(13) +.250*rxt(168)*y(25))*y(58) &
                  + (.950*rxt(119)*y(34) +.800*rxt(121)*y(35))*y(1) &
                  + (rxt(153)*y(28) +rxt(176)*y(50))*y(17)
         loss(43) = (rxt(155)* y(6) +rxt(156)* y(8) +rxt(157)* y(18))* y(56)
         prod(43) =rxt(154)*y(21)*y(8)
         loss(52) = (rxt(161)* y(1) +rxt(162)* y(8) +rxt(160)* y(17) + rxt(30))* y(57)
         prod(52) = (.080*rxt(113)*y(33) +rxt(123)*y(36) +.794*rxt(155)*y(56))*y(6) &
                  + (.794*rxt(156)*y(8) +.794*rxt(157)*y(18))*y(56)
         loss(59) = (rxt(164)* y(6) +rxt(165)* y(8) +rxt(167)* y(13) +rxt(166)* y(18) &
                  +rxt(168)* y(25))* y(58)
         prod(59) = (rxt(163)*y(53) +rxt(169)*y(59) +.500*rxt(171)*y(60))*y(17)
         loss(12) = ((rxt(169) +rxt(170))* y(17) + rxt(29))* y(59)
         prod(12) =rxt(166)*y(58)*y(18)
         loss(36) = (rxt(171)* y(17) + rxt(31))* y(60)
         prod(36) =rxt(115)*y(33)*y(18)
         loss(8) = (rxt(178)* y(17))* y(62)
         prod(8) = (rxt(179)*y(17) +.750*rxt(180)*y(17) +rxt(181)*y(8))*y(64)
         loss(1) = 0.
         prod(1) =rxt(178)*y(62)*y(17)
         loss(13) = (rxt(181)* y(8) + (rxt(179) +rxt(180))* y(17))* y(64)
         prod(13) = 0.
         loss(5) = (rxt(183)* y(17) + rxt(182))* y(65)
         prod(5) = 0.
         loss(2) = 0.
         prod(2) = 0.
         loss(3) = 0.
         prod(3) =rxt(182)*y(65)
         loss(69) = (rxt(216)* y(11) +rxt(192)* y(17) +rxt(215)* y(69) +rxt(219) &
                 * y(70) +rxt(220)* y(75))* y(68)
         prod(69) = (rxt(191)*y(12) +rxt(193)*y(18) +rxt(196)*y(15))*y(71) &
                  +rxt(210)*y(72)*y(17)
         loss(38) = (rxt(215)* y(68) +rxt(221)* y(76) + rxt(35))* y(69)
         prod(38) =rxt(194)*y(72)*y(18) +rxt(218)*y(83)*y(70)
         loss(46) = (rxt(190)* y(2) +rxt(219)* y(68) +rxt(218)* y(83) + rxt(34)) &
                 * y(70)
         prod(46) =rxt(189)*y(72)*y(7)
         loss(57) = (rxt(186)* y(1) +rxt(191)* y(12) +rxt(196)* y(15) +rxt(193)* y(18) &
                 )* y(71)
         prod(57) = (rxt(187)*y(2) +rxt(188)*y(6) +rxt(195)*y(17) +rxt(202)*y(79)) &
                 *y(72) + (rxt(192)*y(17) +rxt(216)*y(11))*y(68) +rxt(35)*y(69) &
                  +rxt(34)*y(70) +2.000*rxt(36)*y(73) +2.000*rxt(41)*y(74) +rxt(39) &
                 *y(80)
         loss(66) = (rxt(187)* y(2) +rxt(188)* y(6) +rxt(189)* y(7) + (rxt(195) + &
                 rxt(210))* y(17) +rxt(194)* y(18) + 2.*rxt(198)* y(72) + (rxt(202) + &
                 rxt(209))* y(79))* y(72)
         prod(66) =rxt(186)*y(71)*y(1) +rxt(190)*y(70)*y(2) +2.000*rxt(199)*y(73)
         loss(7) = ( + rxt(36) + rxt(199))* y(73)
         prod(7) =rxt(198)*y(72)*y(72)
         loss(9) = ( + rxt(41))* y(74)
         prod(9) = (rxt(215)*y(69) +rxt(219)*y(70))*y(68)
         loss(49) = (rxt(205)* y(2) +rxt(220)* y(68) +rxt(222)* y(76) + rxt(38)) &
                 * y(75)
         prod(49) =rxt(203)*y(79)*y(18) +rxt(223)*y(83)*y(77)
         loss(53) = (rxt(208)* y(17) +rxt(221)* y(69) +rxt(222)* y(75))* y(76)
         prod(53) = (rxt(206)*y(18) +rxt(207)*y(15))*y(78)
         loss(16) = (rxt(223)* y(83) + rxt(37))* y(77)
         prod(16) =rxt(201)*y(79)*y(7)
         loss(72) = (rxt(200)* y(1) +rxt(207)* y(15) +rxt(206)* y(18))* y(78)
         prod(72) = (rxt(40) +rxt(202)*y(72) +rxt(204)*y(6))*y(79) + (rxt(38) + &
                 2.000*rxt(222)*y(76))*y(75) +rxt(208)*y(76)*y(17) +rxt(37)*y(77) &
                  +rxt(39)*y(80)
         loss(73) = (rxt(204)* y(6) +rxt(201)* y(7) +rxt(203)* y(18) + (rxt(202) + &
                 rxt(209))* y(72) + rxt(40))* y(79)
         prod(73) =rxt(200)*y(78)*y(1) +rxt(205)*y(75)*y(2)
         loss(26) = ( + rxt(39))* y(80)
         prod(26) =rxt(220)*y(75)*y(68) +rxt(221)*y(76)*y(69) +rxt(209)*y(79)*y(72)
         loss(4) = ( + rxt(224))* y(81)
         prod(4) =rxt(63)*y(17)*y(12)
         loss(27) = (rxt(184)* y(1) + rxt(185))* y(82)
         prod(27) = (rxt(73)*y(16) +rxt(75)*y(2))*y(17) +.200*rxt(64)*y(12)*y(3) &
                  +rxt(12)*y(15)

      end subroutine imp_prod_loss

      end module MO_IMP_PROD_LOSS_MOD

      module MO_RODAS_PROD_LOSS_MOD

      contains

      subroutine rodas_prod_loss( prod, loss, y, rxt, het_rates )

      use CHEM_MODS_MOD, only : clscnt5, rxntot, hetcnt, clsze
      use MO_GRID_MOD,   only : pcnstm1

      implicit none

!--------------------------------------------------------------------
!     ... Dummy args                                                                      
!--------------------------------------------------------------------
      real, dimension(:), intent(out) :: &
            prod, &
            loss
      real, intent(in)    ::  y(:)
      real, intent(in)    ::  rxt(:)
      real, intent(in)    ::  het_rates(:)


      end subroutine rodas_prod_loss

      end module MO_RODAS_PROD_LOSS_MOD

      module MO_INDPRD_MOD

      private
      public :: indprd

      contains

      subroutine indprd( class, prod, y, extfrc, rxt )

      implicit none

!--------------------------------------------------------------------
!       ... Dummy arguments
!--------------------------------------------------------------------
      integer, intent(in) :: class
      real, intent(in)    :: y(:,:)
      real, intent(in)    :: rxt(:,:)
      real, intent(in)    :: extfrc(:,:)
      real, intent(inout) :: prod(:,:)

!--------------------------------------------------------------------
!       ... "Independent" production for Explicit species
!--------------------------------------------------------------------
      if( class == 1 ) then
         prod(:,1) =rxt(:,214)*y(:,7)*y(:,5)
                                                                                          
         prod(:,2) =.080*rxt(:,85)*y(:,20)*y(:,1)
                                                                                          
         prod(:,3) = (.560*rxt(:,85)*y(:,20) +.300*rxt(:,99)*y(:,21) + &
                 .500*rxt(:,110)*y(:,30) +.050*rxt(:,119)*y(:,34) + &
                 .200*rxt(:,121)*y(:,35) +.323*rxt(:,138)*y(:,41))*y(:,1) &
                  + (rxt(:,12) +rxt(:,13) +rxt(:,70)*y(:,8) +rxt(:,71)*y(:,17) + &
                 rxt(:,196)*y(:,71) +rxt(:,207)*y(:,78))*y(:,15) &
                  + (.220*rxt(:,122)*y(:,6) +.220*rxt(:,124)*y(:,8) + &
                 .110*rxt(:,126)*y(:,13) +.220*rxt(:,127)*y(:,25))*y(:,36) &
                  + (rxt(:,164)*y(:,6) +rxt(:,165)*y(:,8) +.400*rxt(:,167)*y(:,13) + &
                 rxt(:,168)*y(:,25))*y(:,58) + (rxt(:,28) +rxt(:,158)*y(:,17) + &
                 rxt(:,159)*y(:,8))*y(:,55) + (rxt(:,33) +.400*rxt(:,177)*y(:,17)) &
                 *y(:,49) +rxt(:,16)*y(:,23) +.700*rxt(:,23)*y(:,34) +1.340*rxt(:,22) &
                 *y(:,35) +rxt(:,30)*y(:,57)
                                                                                          
         prod(:,4) = 0.
                                                                                          
         prod(:,5) = 0.
                                                                                          
         prod(:,6) =rxt(:,13)*y(:,15)
                                                                                          
         prod(:,7) = (rxt(:,58)*y(:,9) +rxt(:,61)*y(:,10) +rxt(:,69)*y(:,14) + &
                 rxt(:,71)*y(:,15) +rxt(:,80)*y(:,19) +rxt(:,81)*y(:,18) + &
                 rxt(:,82)*y(:,17) +rxt(:,89)*y(:,24) +rxt(:,90)*y(:,23) + &
                 rxt(:,96)*y(:,26) +.500*rxt(:,120)*y(:,35) +rxt(:,148)*y(:,44) + &
                 rxt(:,149)*y(:,45) +rxt(:,152)*y(:,46) +rxt(:,158)*y(:,55) + &
                 rxt(:,169)*y(:,59) +rxt(:,170)*y(:,59) +rxt(:,183)*y(:,65) + &
                 rxt(:,192)*y(:,68) +rxt(:,208)*y(:,76))*y(:,17) &
                  + (rxt(:,215)*y(:,69) +rxt(:,220)*y(:,75))*y(:,68) &
                  + (rxt(:,221)*y(:,69) +rxt(:,222)*y(:,75))*y(:,76)
                                                                                          
!--------------------------------------------------------------------
!       ... "Independent" production for Implicit species
!--------------------------------------------------------------------
      else if( class == 4 ) then
         prod(:,67) = 0.
                                                                                          
         prod(:,15) =rxt(:,4)*y(:,4)
                                                                                          
         prod(:,68) =2.000*rxt(:,1)
                                                                                          
         prod(:,14) = 0.
                                                                                          
         prod(:,70) = 0.
                                                                                          
         prod(:,76) = 0.
                                                                                          
         prod(:,65) = 0.
                                                                                          
         prod(:,39) = 0.
                                                                                          
         prod(:,19) = 0.
                                                                                          
         prod(:,29) = 0.
                                                                                          
         prod(:,64) = 0.
                                                                                          
         prod(:,25) = 0.
                                                                                          
         prod(:,74) = 0.
                                                                                          
         prod(:,75) =rxt(:,14)*y(:,83)
                                                                                          
         prod(:,71) = 0.
                                                                                          
         prod(:,10) = 0.
                                                                                          
         prod(:,50) = 0.
                                                                                          
         prod(:,47) = 0.
                                                                                          
         prod(:,41) = 0.
                                                                                          
         prod(:,51) = 0.
                                                                                          
         prod(:,32) = 0.
                                                                                          
         prod(:,62) = 0.
                                                                                          
         prod(:,30) = 0.
                                                                                          
         prod(:,33) = 0.
                                                                                          
         prod(:,17) = 0.
                                                                                          
         prod(:,20) = 0.
                                                                                          
         prod(:,6) = 0.
                                                                                          
         prod(:,35) = 0.
                                                                                          
         prod(:,60) = 0.
                                                                                          
         prod(:,58) = 0.
                                                                                          
         prod(:,56) = 0.
                                                                                          
         prod(:,61) = 0.
                                                                                          
         prod(:,21) = 0.
                                                                                          
         prod(:,63) = 0.
                                                                                          
         prod(:,40) = 0.
                                                                                          
         prod(:,22) = 0.
                                                                                          
         prod(:,48) = 0.
                                                                                          
         prod(:,45) = 0.
                                                                                          
         prod(:,23) = 0.
                                                                                          
         prod(:,37) = 0.
                                                                                          
         prod(:,24) = 0.
                                                                                          
         prod(:,34) = 0.
                                                                                          
         prod(:,18) = 0.
                                                                                          
         prod(:,42) = 0.
                                                                                          
         prod(:,55) = 0.
                                                                                          
         prod(:,28) = 0.
                                                                                          
         prod(:,11) = 0.
                                                                                          
         prod(:,31) = 0.
                                                                                          
         prod(:,44) = 0.
                                                                                          
         prod(:,54) = 0.
                                                                                          
         prod(:,43) = 0.
                                                                                          
         prod(:,52) = 0.
                                                                                          
         prod(:,59) = 0.
                                                                                          
         prod(:,12) = 0.
                                                                                          
         prod(:,36) = 0.
                                                                                          
         prod(:,8) = 0.
                                                                                          
         prod(:,1) = 0.
                                                                                          
         prod(:,13) = 0.
                                                                                          
         prod(:,5) = 0.
                                                                                          
         prod(:,2) = 0.
                                                                                          
         prod(:,3) = 0.
                                                                                          
         prod(:,69) = 0.
                                                                                          
         prod(:,38) = 0.
                                                                                          
         prod(:,46) = 0.
                                                                                          
         prod(:,57) = 0.
                                                                                          
         prod(:,66) = 0.
                                                                                          
         prod(:,7) = 0.
                                                                                          
         prod(:,9) = 0.
                                                                                          
         prod(:,49) = 0.
                                                                                          
         prod(:,53) = 0.
                                                                                          
         prod(:,16) = 0.
                                                                                          
         prod(:,72) = 0.
                                                                                          
         prod(:,73) = 0.
                                                                                          
         prod(:,26) = 0.
                                                                                          
         prod(:,4) = 0.
                                                                                          
         prod(:,27) =rxt(:,14)*y(:,83)
                                                                                          
      end if                                                                              
                                                                                          
      end subroutine INDPRD                                                               
                                                                                          
      end module MO_INDPRD_MOD                                                                

      module MO_IMP_LIN_MATRIX_MOD

      contains

      subroutine imp_linmat01( mat, y, rxt, het_rates )
!----------------------------------------------
!       ... Linear Matrix entries for Implicit species
!----------------------------------------------

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, hetcnt, imp_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(in)    ::  het_rates(hetcnt)
      real, intent(inout) ::  mat(imp_nzcnt)

         mat(560) = -( rxt(2) + rxt(3) )
         mat(578) = rxt(42)

         mat(38) = -( rxt(44) + rxt(45) + rxt(46)*y(83) + rxt(47)*y(4) + rxt(48)*y(4) &
                      + rxt(64)*y(12) + rxt(74)*y(61) )
         mat(536) = rxt(2)

         mat(579) = -( rxt(42) )
         mat(561) = rxt(3)
         mat(637) = rxt(5)
         mat(821) = rxt(6)
         mat(510) = .890*rxt(9)
         mat(715) = rxt(40)
         mat(41) = rxt(44) + rxt(45)
         mat(35) = rxt(142)

         mat(34) = -( rxt(142) )
         mat(611) = rxt(5)

         mat(639) = -( rxt(5) )
         mat(823) = rxt(6)
         mat(512) = .110*rxt(9)
         mat(36) = rxt(142)
         mat(42) = 2.000*rxt(47)*y(4)

         mat(829) = -( rxt(6) )
         mat(113) = rxt(7) + rxt(55)
         mat(172) = rxt(8)
         mat(516) = .890*rxt(9)
         mat(62) = rxt(10) + rxt(62)
         mat(135) = .600*rxt(19) + rxt(97)
         mat(147) = rxt(20) + rxt(136)
         mat(311) = rxt(30)

         mat(507) = -( rxt(9) + rxt(141) )
         mat(111) = rxt(7) + rxt(55)
         mat(132) = .400*rxt(19)
         mat(233) = rxt(34)
         mat(49) = rxt(37)

         mat(169) = -( rxt(8) )
         mat(109) = 2.000*rxt(140) + 2.000*rxt(56)*y(83) + 2.000*rxt(217)*y(83)
         mat(488) = rxt(141)
         mat(229) = rxt(218)*y(83)
         mat(47) = rxt(223)*y(83)

         mat(59) = -( rxt(10) + rxt(62) )

         mat(108) = -( rxt(7) + rxt(55) + rxt(140) + rxt(56)*y(83) + rxt(217)*y(83) )

         mat(298) = rxt(16)
         mat(116) = rxt(18)
         mat(131) = .400*rxt(19)
         mat(362) = .300*rxt(23)
         mat(159) = rxt(27)
         mat(790) = rxt(63)*y(12)
         mat(40) = .750*rxt(64)*y(12)
         mat(349) = rxt(191)*y(12)

         mat(89) = -( rxt(11) )

         mat(738) = -( rxt(12) + rxt(13) )
         mat(92) = rxt(11)
         mat(127) = rxt(17)
         mat(345) = 1.340*rxt(21)
         mat(87) = rxt(26)
         mat(309) = rxt(30)
         mat(154) = .690*rxt(31)
         mat(334) = rxt(32)
         mat(196) = rxt(33)
         mat(25) = 2.000*rxt(109)
         mat(44) = .250*rxt(64)*y(12)

         mat(801) = -( rxt(63)*y(12) + rxt(72)*y(16) + rxt(73)*y(16) + rxt(83)*y(61) &
                      + rxt(100)*y(29) + rxt(144)*y(42) )
         mat(171) = rxt(8)
         mat(93) = rxt(11)
         mat(21) = 2.000*rxt(15)
         mat(128) = rxt(17)
         mat(118) = rxt(18)
         mat(346) = .660*rxt(22)
         mat(78) = rxt(24)
         mat(83) = rxt(25)
         mat(88) = rxt(26)
         mat(28) = rxt(29)
         mat(168) = rxt(35)
         mat(280) = rxt(38)
         mat(45) = 2.000*rxt(46)*y(83) + .750*rxt(64)*y(12) + rxt(74)*y(61)

         mat(60) = rxt(10) + rxt(62)
         mat(91) = rxt(11)
         mat(735) = rxt(12)
         mat(300) = rxt(16)
         mat(126) = rxt(17)
         mat(344) = 1.340*rxt(21)
         mat(77) = rxt(24)
         mat(82) = rxt(25)
         mat(326) = rxt(28)
         mat(308) = rxt(30)
         mat(153) = rxt(31)
         mat(333) = rxt(32)
         mat(195) = 2.000*rxt(33)
         mat(24) = rxt(108) + rxt(109)
         mat(99) = rxt(185)
         mat(43) = .200*rxt(64)*y(12) + rxt(74)*y(61)
         mat(797) = rxt(72)*y(16) + rxt(83)*y(61)

         mat(19) = -( rxt(15) )

         mat(355) = .700*rxt(23)



         mat(296) = -( rxt(16) )
         mat(124) = rxt(17)
         mat(76) = rxt(24)

         mat(122) = -( rxt(17) )

         mat(130) = .600*rxt(19) + rxt(97)
         mat(340) = 1.340*rxt(21)
         mat(361) = .300*rxt(23)
         mat(86) = rxt(26)
         mat(158) = rxt(27)
         mat(324) = rxt(28)
         mat(331) = rxt(32)

         mat(114) = -( rxt(18) )

         mat(129) = -( rxt(19) + rxt(97) )




         mat(140) = -( rxt(20) + rxt(136) )


         mat(359) = -( rxt(23) )
         mat(150) = .402*rxt(31)

         mat(338) = -( rxt(21) + rxt(22) )
         mat(149) = .288*rxt(31)



         mat(142) = rxt(20) + rxt(136)
         mat(341) = .660*rxt(21)

         mat(769) = rxt(100)*y(29)

         mat(74) = -( rxt(24) )


         mat(773) = rxt(144)*y(42)

         mat(79) = -( rxt(25) )

         mat(156) = -( rxt(27) )
         mat(80) = .820*rxt(25)

         mat(84) = -( rxt(26) )



         mat(193) = -( rxt(33) )
         mat(23) = rxt(108)

         mat(330) = -( rxt(32) )


         mat(22) = -( rxt(108) + rxt(109) )



         mat(323) = -( rxt(28) )


         mat(304) = -( rxt(30) )


         mat(26) = -( rxt(29) )

         mat(148) = -( rxt(31) )




         mat(6) = -( rxt(182) )


         mat(5) = rxt(182)

         mat(352) = rxt(191)*y(12)

         mat(163) = -( rxt(35) )
         mat(228) = rxt(218)*y(83)

         mat(230) = -( rxt(34) + rxt(218)*y(83) )

         mat(348) = -( rxt(191)*y(12) )
         mat(232) = rxt(34)
         mat(165) = rxt(35)
         mat(12) = 2.000*rxt(36)
         mat(95) = rxt(39)
         mat(18) = 2.000*rxt(41)

         mat(13) = 2.000*rxt(199)

         mat(11) = -( rxt(36) + rxt(199) )

         mat(17) = -( rxt(41) )

         mat(273) = -( rxt(38) )
         mat(48) = rxt(223)*y(83)


         mat(46) = -( rxt(37) + rxt(223)*y(83) )

         mat(50) = rxt(37)
         mat(278) = rxt(38)
         mat(96) = rxt(39)
         mat(719) = rxt(40)

         mat(720) = -( rxt(40) )

         mat(94) = -( rxt(39) )

         mat(4) = -( rxt(224) )
         mat(742) = rxt(63)*y(12)

         mat(97) = -( rxt(185) )
         mat(724) = rxt(12)
         mat(39) = .200*rxt(64)*y(12)
         mat(758) = rxt(73)*y(16)


      end subroutine imp_linmat01

      subroutine imp_linmat( mat, y, rxt, het_rates )
!----------------------------------------------
!       ... Linear Matrix entries for Implicit species
!----------------------------------------------

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, hetcnt, imp_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(in)    ::  het_rates(hetcnt)
      real, intent(inout) ::  mat(imp_nzcnt)

      call imp_linmat01( mat, y, rxt, het_rates )

      end subroutine imp_linmat

      end module MO_IMP_LIN_MATRIX_MOD

      module MO_ROD_LIN_MATRIX_MOD

      contains

      subroutine rod_linmat( mat, y, rxt, het_rates )
!----------------------------------------------
!       ... Linear Matrix entries for Implicit species
!----------------------------------------------

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, hetcnt, rod_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(in)    ::  het_rates(hetcnt)
      real, intent(inout) ::  mat(rod_nzcnt)


      end subroutine rod_linmat

      end module MO_ROD_LIN_MATRIX_MOD

      module MO_IMP_NLN_MATRIX_MOD

      contains

      subroutine imp_nlnmat01( mat, y, rxt )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, imp_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(inout) ::  mat(imp_nzcnt)


!----------------------------------------------
!       ... Local variables
!----------------------------------------------

!----------------------------------------------
!       ... Complete matrix entries Implicit species
!----------------------------------------------

         mat(560) = -(rxt(43)*y(2) + rxt(50)*y(6) + rxt(52)*y(7) + rxt(77)*y(17) &
                      + rxt(78)*y(18) + rxt(85)*y(20) + rxt(99)*y(21) + rxt(110)*y(30) &
                      + rxt(119)*y(34) + rxt(121)*y(35) + rxt(138)*y(41) + rxt(161) &
                      *y(57) + rxt(184)*y(82) + rxt(186)*y(71) + rxt(200)*y(78))
         mat(578) = -rxt(43)*y(1)
         mat(636) = -rxt(50)*y(1)
         mat(820) = -rxt(52)*y(1)
         mat(793) = -rxt(77)*y(1)
         mat(680) = -rxt(78)*y(1)
         mat(289) = -rxt(85)*y(1)
         mat(249) = -rxt(99)*y(1)
         mat(65) = -rxt(110)*y(1)
         mat(364) = -rxt(119)*y(1)
         mat(343) = -rxt(121)*y(1)
         mat(265) = -rxt(138)*y(1)
         mat(307) = -rxt(161)*y(1)
         mat(98) = -rxt(184)*y(1)
         mat(351) = -rxt(186)*y(1)
         mat(695) = -rxt(200)*y(1)

         mat(560) = mat(560) + .100*rxt(99)*y(21) + .200*rxt(119)*y(34)  &
                      + .200*rxt(121)*y(35)
         mat(680) = mat(680) + .300*rxt(94)*y(25) + .300*rxt(131)*y(38)
         mat(249) = mat(249) + .100*rxt(99)*y(1)
         mat(437) = .300*rxt(94)*y(18)
         mat(364) = mat(364) + .200*rxt(119)*y(1)
         mat(343) = mat(343) + .200*rxt(121)*y(1)
         mat(450) = .300*rxt(131)*y(18)


         mat(579) = -(rxt(43)*y(1) + rxt(51)*y(7) + rxt(75)*y(17) + rxt(76)*y(18) &
                      + rxt(187)*y(72) + rxt(190)*y(70) + rxt(205)*y(75) + rxt(213) &
                      *y(6))
         mat(561) = -rxt(43)*y(2)
         mat(821) = -rxt(51)*y(2)
         mat(794) = -rxt(75)*y(2)
         mat(681) = -rxt(76)*y(2)
         mat(527) = -rxt(187)*y(2)
         mat(235) = -rxt(190)*y(2)
         mat(276) = -rxt(205)*y(2)
         mat(637) = -rxt(213)*y(2)

         mat(561) = mat(561) + .765*rxt(138)*y(41)
         mat(35) = rxt(143)*y(6) + rxt(214)*y(7)
         mat(637) = mat(637) + rxt(143)*y(5)
         mat(821) = mat(821) + rxt(214)*y(5)
         mat(794) = mat(794) + 2.000*rxt(82)*y(17)
         mat(266) = .765*rxt(138)*y(1)

         mat(34) = -(rxt(143)*y(6) + rxt(214)*y(7))
         mat(611) = -rxt(143)*y(5)
         mat(803) = -rxt(214)*y(5)

         mat(639) = -(rxt(49)*y(18) + rxt(50)*y(1) + rxt(59)*y(8) + rxt(65)*y(13) &
                      + rxt(87)*y(22) + rxt(92)*y(25) + rxt(101)*y(39) + rxt(107) &
                      *y(51) + rxt(113)*y(33) + (rxt(122) + rxt(123)) * y(36) + rxt(129) &
                      *y(38) + rxt(143)*y(5) + rxt(145)*y(43) + rxt(150)*y(54) + rxt(155) &
                      *y(56) + rxt(164)*y(58) + rxt(188)*y(72) + rxt(204)*y(79) &
                      + rxt(213)*y(2))
         mat(683) = -rxt(49)*y(6)
         mat(563) = -rxt(50)*y(6)
         mat(512) = -rxt(59)*y(6)
         mat(478) = -rxt(65)*y(6)
         mat(188) = -rxt(87)*y(6)
         mat(438) = -rxt(92)*y(6)
         mat(179) = -rxt(101)*y(6)
         mat(104) = -rxt(107)*y(6)
         mat(399) = -rxt(113)*y(6)
         mat(417) = -(rxt(122) + rxt(123)) * y(6)
         mat(451) = -rxt(129)*y(6)
         mat(36) = -rxt(143)*y(6)
         mat(222) = -rxt(145)*y(6)
         mat(210) = -rxt(150)*y(6)
         mat(203) = -rxt(155)*y(6)
         mat(380) = -rxt(164)*y(6)
         mat(529) = -rxt(188)*y(6)
         mat(717) = -rxt(204)*y(6)
         mat(581) = -rxt(213)*y(6)

         mat(581) = mat(581) + rxt(51)*y(7)
         mat(823) = rxt(51)*y(2) + rxt(211)*y(8)
         mat(512) = mat(512) + rxt(211)*y(7)

         mat(829) = -(rxt(51)*y(2) + rxt(52)*y(1) + rxt(54)*y(8) + rxt(57)*y(17) &
                      + rxt(60)*y(18) + rxt(93)*y(25) + rxt(135)*y(38) + rxt(189) &
                      *y(72) + rxt(201)*y(79) + rxt(214)*y(5))
         mat(587) = -rxt(51)*y(7)
         mat(569) = -rxt(52)*y(7)
         mat(516) = -rxt(54)*y(7)
         mat(802) = -rxt(57)*y(7)
         mat(689) = -rxt(60)*y(7)
         mat(442) = -rxt(93)*y(7)
         mat(455) = -rxt(135)*y(7)
         mat(535) = -rxt(189)*y(7)
         mat(723) = -rxt(201)*y(7)
         mat(37) = -rxt(214)*y(7)

         mat(569) = mat(569) + rxt(50)*y(6) + .400*rxt(161)*y(57)
         mat(587) = mat(587) + rxt(213)*y(6)
         mat(645) = rxt(50)*y(1) + rxt(213)*y(2) + 2.000*rxt(59)*y(8) + rxt(65)*y(13)  &
                      + rxt(49)*y(18) + rxt(87)*y(22) + rxt(92)*y(25) + .920*rxt(113) &
                      *y(33) + rxt(122)*y(36) + rxt(129)*y(38) + rxt(101)*y(39)  &
                      + rxt(145)*y(43) + rxt(107)*y(51) + rxt(150)*y(54)  &
                      + 1.206*rxt(155)*y(56) + rxt(164)*y(58) + rxt(188)*y(72)  &
                      + rxt(204)*y(79)
         mat(516) = mat(516) + 2.000*rxt(59)*y(6) + 4.000*rxt(212)*y(8) + rxt(53) &
                      *y(18) + rxt(114)*y(33) + rxt(124)*y(36) + rxt(130)*y(38)  &
                      + rxt(139)*y(41) + 1.206*rxt(156)*y(56) + rxt(162)*y(57)  &
                      + rxt(165)*y(58) + rxt(181)*y(64)
         mat(62) = rxt(61)*y(17)
         mat(113) = rxt(216)*y(68)
         mat(482) = rxt(65)*y(6)
         mat(802) = mat(802) + rxt(61)*y(10) + rxt(153)*y(28) + .400*rxt(160)*y(57)
         mat(689) = mat(689) + rxt(49)*y(6) + rxt(53)*y(8) + .206*rxt(157)*y(56)
         mat(192) = rxt(87)*y(6)
         mat(442) = mat(442) + rxt(92)*y(6)
         mat(54) = rxt(153)*y(17)
         mat(403) = .920*rxt(113)*y(6) + rxt(114)*y(8)
         mat(421) = rxt(122)*y(6) + rxt(124)*y(8)
         mat(455) = mat(455) + rxt(129)*y(6) + rxt(130)*y(8)
         mat(183) = rxt(101)*y(6)
         mat(271) = rxt(139)*y(8)
         mat(226) = rxt(145)*y(6)
         mat(107) = rxt(107)*y(6)
         mat(214) = rxt(150)*y(6)
         mat(206) = 1.206*rxt(155)*y(6) + 1.206*rxt(156)*y(8) + .206*rxt(157)*y(18)
         mat(311) = .400*rxt(161)*y(1) + rxt(162)*y(8) + .400*rxt(160)*y(17)
         mat(384) = rxt(164)*y(6) + rxt(165)*y(8)
         mat(33) = rxt(181)*y(8)
         mat(609) = rxt(216)*y(11)
         mat(535) = mat(535) + rxt(188)*y(6)
         mat(723) = mat(723) + rxt(204)*y(6)

         mat(507) = -(rxt(53)*y(18) + (rxt(54) + rxt(211)) * y(7) + rxt(59)*y(6) &
                      + rxt(70)*y(15) + rxt(86)*y(20) + rxt(91)*y(23) + rxt(114)*y(33) &
                      + rxt(124)*y(36) + rxt(130)*y(38) + rxt(139)*y(41) + rxt(154) &
                      *y(21) + rxt(156)*y(56) + rxt(159)*y(55) + rxt(162)*y(57) &
                      + rxt(165)*y(58) + rxt(181)*y(64) + 4.*rxt(212)*y(8))
         mat(678) = -rxt(53)*y(8)
         mat(818) = -(rxt(54) + rxt(211)) * y(8)
         mat(634) = -rxt(59)*y(8)
         mat(729) = -rxt(70)*y(8)
         mat(288) = -rxt(86)*y(8)
         mat(299) = -rxt(91)*y(8)
         mat(397) = -rxt(114)*y(8)
         mat(415) = -rxt(124)*y(8)
         mat(449) = -rxt(130)*y(8)
         mat(264) = -rxt(139)*y(8)
         mat(248) = -rxt(154)*y(8)
         mat(202) = -rxt(156)*y(8)
         mat(325) = -rxt(159)*y(8)
         mat(306) = -rxt(162)*y(8)
         mat(379) = -rxt(165)*y(8)
         mat(31) = -rxt(181)*y(8)

         mat(558) = rxt(52)*y(7)
         mat(576) = rxt(190)*y(70)
         mat(818) = mat(818) + rxt(52)*y(1)
         mat(170) = rxt(58)*y(17)
         mat(791) = rxt(58)*y(9) + rxt(175)*y(27) + .500*rxt(174)*y(32)
         mat(132) = rxt(175)*y(17)
         mat(143) = .500*rxt(174)*y(17)
         mat(233) = rxt(190)*y(2)

         mat(169) = -(rxt(58)*y(17))
         mat(768) = -rxt(58)*y(9)

         mat(809) = rxt(57)*y(17)
         mat(488) = rxt(70)*y(15) + rxt(91)*y(23) + rxt(159)*y(55)
         mat(109) = rxt(216)*y(68)
         mat(725) = rxt(70)*y(8)
         mat(768) = mat(768) + rxt(57)*y(7)
         mat(295) = rxt(91)*y(8)
         mat(322) = rxt(159)*y(8)
         mat(592) = rxt(216)*y(11) + rxt(219)*y(70)
         mat(229) = rxt(219)*y(68)

         mat(59) = -(rxt(61)*y(17))
         mat(751) = -rxt(61)*y(10)

         mat(805) = rxt(60)*y(18)
         mat(648) = rxt(60)*y(7)

         mat(108) = -(rxt(216)*y(68))
         mat(590) = -rxt(216)*y(11)

         mat(806) = rxt(54)*y(8)
         mat(486) = rxt(54)*y(7)

         mat(475) = -(rxt(65)*y(6) + (4.*rxt(66) + 4.*rxt(67)) * y(13) + rxt(68)*y(18) &
                      + rxt(95)*y(25) + rxt(103)*y(39) + rxt(116)*y(33) + rxt(126) &
                      *y(36) + rxt(132)*y(38) + rxt(147)*y(43) + rxt(167)*y(58))
         mat(633) = -rxt(65)*y(13)
         mat(677) = -rxt(68)*y(13)
         mat(435) = -rxt(95)*y(13)
         mat(178) = -rxt(103)*y(13)
         mat(396) = -rxt(116)*y(13)
         mat(414) = -rxt(126)*y(13)
         mat(448) = -rxt(132)*y(13)
         mat(221) = -rxt(147)*y(13)
         mat(378) = -rxt(167)*y(13)

         mat(557) = .310*rxt(85)*y(20)
         mat(633) = mat(633) + rxt(92)*y(25)
         mat(475) = mat(475) + .900*rxt(95)*y(25)
         mat(90) = .700*rxt(69)*y(17)
         mat(790) = .700*rxt(69)*y(14)
         mat(287) = .310*rxt(85)*y(1)
         mat(435) = mat(435) + rxt(92)*y(6) + .900*rxt(95)*y(13) + 4.000*rxt(98)*y(25)  &
                      + rxt(117)*y(33) + rxt(127)*y(36) + rxt(133)*y(38) + rxt(168) &
                      *y(58)
         mat(396) = mat(396) + rxt(117)*y(25)
         mat(414) = mat(414) + rxt(127)*y(25)
         mat(448) = mat(448) + rxt(133)*y(25)
         mat(378) = mat(378) + rxt(168)*y(25)

         mat(89) = -(rxt(69)*y(17))
         mat(757) = -rxt(69)*y(14)

         mat(457) = rxt(68)*y(18)
         mat(653) = rxt(68)*y(13)

         mat(738) = -(rxt(70)*y(8) + rxt(71)*y(17) + rxt(196)*y(71) + rxt(207)*y(78))
         mat(514) = -rxt(70)*y(15)
         mat(800) = -rxt(71)*y(15)
         mat(354) = -rxt(196)*y(15)
         mat(702) = -rxt(207)*y(15)

         mat(567) = .540*rxt(85)*y(20) + .600*rxt(99)*y(21) + rxt(110)*y(30)  &
                      + .800*rxt(119)*y(34) + .700*rxt(121)*y(35) + 1.326*rxt(138) &
                      *y(41)
         mat(643) = rxt(65)*y(13) + rxt(87)*y(22) + .550*rxt(113)*y(33)  &
                      + .250*rxt(122)*y(36) + rxt(129)*y(38) + rxt(150)*y(54)  &
                      + .072*rxt(155)*y(56)
         mat(514) = mat(514) + .600*rxt(114)*y(33) + .250*rxt(124)*y(36) + rxt(130) &
                      *y(38) + .072*rxt(156)*y(56)
         mat(480) = rxt(65)*y(6) + (4.000*rxt(66)+2.000*rxt(67))*y(13) + rxt(95)*y(25)  &
                      + 1.200*rxt(116)*y(33) + .880*rxt(126)*y(36) + 2.000*rxt(132) &
                      *y(38) + .700*rxt(103)*y(39) + rxt(147)*y(43) + .700*rxt(167) &
                      *y(58)
         mat(92) = .300*rxt(69)*y(17)
         mat(800) = mat(800) + .300*rxt(69)*y(14) + .500*rxt(96)*y(26) + rxt(175) &
                      *y(27) + .500*rxt(106)*y(30) + .500*rxt(174)*y(32) + rxt(172) &
                      *y(47)
         mat(687) = .008*rxt(157)*y(56)
         mat(292) = .540*rxt(85)*y(1)
         mat(252) = .600*rxt(99)*y(1)
         mat(190) = rxt(87)*y(6)
         mat(440) = rxt(95)*y(13) + .600*rxt(117)*y(33) + .250*rxt(127)*y(36)  &
                      + rxt(133)*y(38)
         mat(117) = .500*rxt(96)*y(17)
         mat(133) = rxt(175)*y(17)
         mat(67) = rxt(110)*y(1) + .500*rxt(106)*y(17)
         mat(145) = .500*rxt(174)*y(17)
         mat(401) = .550*rxt(113)*y(6) + .600*rxt(114)*y(8) + 1.200*rxt(116)*y(13)  &
                      + .600*rxt(117)*y(25)
         mat(367) = .800*rxt(119)*y(1)
         mat(345) = .700*rxt(121)*y(1)
         mat(419) = .250*rxt(122)*y(6) + .250*rxt(124)*y(8) + .880*rxt(126)*y(13)  &
                      + .250*rxt(127)*y(25)
         mat(453) = rxt(129)*y(6) + rxt(130)*y(8) + 2.000*rxt(132)*y(13) + rxt(133) &
                      *y(25) + 4.000*rxt(134)*y(38)
         mat(181) = .700*rxt(103)*y(13)
         mat(269) = 1.326*rxt(138)*y(1)
         mat(224) = rxt(147)*y(13)
         mat(138) = rxt(172)*y(17)
         mat(212) = rxt(150)*y(6)
         mat(205) = .072*rxt(155)*y(6) + .072*rxt(156)*y(8) + .008*rxt(157)*y(18)
         mat(382) = .700*rxt(167)*y(13)


      end subroutine imp_nlnmat01

      subroutine imp_nlnmat02( mat, y, rxt )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, imp_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(inout) ::  mat(imp_nzcnt)


!----------------------------------------------
!       ... Local variables
!----------------------------------------------

!----------------------------------------------
!       ... Complete matrix entries Implicit species
!----------------------------------------------

         mat(801) = -(rxt(57)*y(7) + rxt(58)*y(9) + rxt(61)*y(10) + rxt(69)*y(14) &
                      + rxt(71)*y(15) + rxt(75)*y(2) + rxt(77)*y(1) + rxt(80)*y(19) &
                      + rxt(81)*y(18) + (4.*rxt(82) + 4.*rxt(197)) * y(17) + rxt(84) &
                      *y(20) + rxt(89)*y(24) + rxt(90)*y(23) + rxt(96)*y(26) + rxt(105) &
                      *y(40) + rxt(106)*y(30) + rxt(111)*y(21) + rxt(112)*y(31) &
                      + rxt(118)*y(34) + rxt(120)*y(35) + rxt(128)*y(37) + rxt(137) &
                      *y(41) + rxt(148)*y(44) + rxt(149)*y(45) + rxt(152)*y(46) &
                      + rxt(153)*y(28) + rxt(158)*y(55) + rxt(160)*y(57) + rxt(163) &
                      *y(53) + rxt(169)*y(59) + rxt(171)*y(60) + rxt(172)*y(47) &
                      + rxt(173)*y(48) + rxt(174)*y(32) + rxt(175)*y(27) + rxt(176) &
                      *y(50) + rxt(177)*y(49) + rxt(178)*y(62) + (rxt(179) + rxt(180) &
                      ) * y(64) + rxt(183)*y(65) + rxt(192)*y(68) + (rxt(195) + rxt(210) &
                      ) * y(72) + rxt(208)*y(76))
         mat(828) = -rxt(57)*y(17)
         mat(171) = -rxt(58)*y(17)
         mat(61) = -rxt(61)*y(17)
         mat(93) = -rxt(69)*y(17)
         mat(739) = -rxt(71)*y(17)
         mat(586) = -rxt(75)*y(17)
         mat(568) = -rxt(77)*y(17)
         mat(21) = -rxt(80)*y(17)
         mat(688) = -rxt(81)*y(17)
         mat(293) = -rxt(84)*y(17)
         mat(128) = -rxt(89)*y(17)
         mat(301) = -rxt(90)*y(17)
         mat(118) = -rxt(96)*y(17)
         mat(78) = -rxt(105)*y(17)
         mat(68) = -rxt(106)*y(17)
         mat(253) = -rxt(111)*y(17)
         mat(10) = -rxt(112)*y(17)
         mat(368) = -rxt(118)*y(17)
         mat(346) = -rxt(120)*y(17)
         mat(73) = -rxt(128)*y(17)
         mat(270) = -rxt(137)*y(17)
         mat(83) = -rxt(148)*y(17)
         mat(160) = -rxt(149)*y(17)
         mat(88) = -rxt(152)*y(17)
         mat(53) = -rxt(153)*y(17)
         mat(327) = -rxt(158)*y(17)
         mat(310) = -rxt(160)*y(17)
         mat(121) = -rxt(163)*y(17)
         mat(28) = -rxt(169)*y(17)
         mat(155) = -rxt(171)*y(17)
         mat(139) = -rxt(172)*y(17)
         mat(58) = -rxt(173)*y(17)
         mat(146) = -rxt(174)*y(17)
         mat(134) = -rxt(175)*y(17)
         mat(335) = -rxt(176)*y(17)
         mat(197) = -rxt(177)*y(17)
         mat(16) = -rxt(178)*y(17)
         mat(32) = -(rxt(179) + rxt(180)) * y(17)
         mat(7) = -rxt(183)*y(17)
         mat(608) = -rxt(192)*y(17)
         mat(534) = -(rxt(195) + rxt(210)) * y(17)
         mat(321) = -rxt(208)*y(17)

         mat(568) = mat(568) + rxt(78)*y(18) + .330*rxt(85)*y(20) + .270*rxt(99)*y(21)  &
                      + .120*rxt(110)*y(30) + .080*rxt(119)*y(34) + .215*rxt(121) &
                      *y(35) + 1.156*rxt(138)*y(41) + rxt(184)*y(82)
         mat(586) = mat(586) + rxt(76)*y(18) + rxt(205)*y(75)
         mat(644) = rxt(49)*y(18)
         mat(515) = rxt(53)*y(18)
         mat(93) = mat(93) + .300*rxt(69)*y(17)
         mat(801) = mat(801) + .300*rxt(69)*y(14) + .500*rxt(89)*y(24) + .100*rxt(128) &
                      *y(37) + .500*rxt(105)*y(40)
         mat(688) = mat(688) + rxt(78)*y(1) + rxt(76)*y(2) + rxt(49)*y(6) + rxt(53) &
                      *y(8)
         mat(293) = mat(293) + .330*rxt(85)*y(1)
         mat(253) = mat(253) + .270*rxt(99)*y(1)
         mat(128) = mat(128) + .500*rxt(89)*y(17)
         mat(68) = mat(68) + .120*rxt(110)*y(1)
         mat(368) = mat(368) + .080*rxt(119)*y(1)
         mat(346) = mat(346) + .215*rxt(121)*y(1)
         mat(73) = mat(73) + .100*rxt(128)*y(17)
         mat(78) = mat(78) + .500*rxt(105)*y(17)
         mat(270) = mat(270) + 1.156*rxt(138)*y(1)
         mat(280) = rxt(205)*y(2)
         mat(100) = rxt(184)*y(1)

         mat(684) = -(rxt(49)*y(6) + rxt(53)*y(8) + rxt(60)*y(7) + rxt(68)*y(13) &
                      + rxt(76)*y(2) + rxt(78)*y(1) + 4.*rxt(79)*y(18) + rxt(81)*y(17) &
                      + rxt(88)*y(22) + rxt(94)*y(25) + rxt(102)*y(39) + rxt(115) &
                      *y(33) + rxt(125)*y(36) + rxt(131)*y(38) + rxt(146)*y(43) &
                      + rxt(151)*y(54) + rxt(157)*y(56) + rxt(166)*y(58) + rxt(193) &
                      *y(71) + rxt(194)*y(72) + rxt(203)*y(79) + rxt(206)*y(78))
         mat(640) = -rxt(49)*y(18)
         mat(513) = -rxt(53)*y(18)
         mat(824) = -rxt(60)*y(18)
         mat(479) = -rxt(68)*y(18)
         mat(582) = -rxt(76)*y(18)
         mat(564) = -rxt(78)*y(18)
         mat(797) = -rxt(81)*y(18)
         mat(189) = -rxt(88)*y(18)
         mat(439) = -rxt(94)*y(18)
         mat(180) = -rxt(102)*y(18)
         mat(400) = -rxt(115)*y(18)
         mat(418) = -rxt(125)*y(18)
         mat(452) = -rxt(131)*y(18)
         mat(223) = -rxt(146)*y(18)
         mat(211) = -rxt(151)*y(18)
         mat(204) = -rxt(157)*y(18)
         mat(381) = -rxt(166)*y(18)
         mat(353) = -rxt(193)*y(18)
         mat(530) = -rxt(194)*y(18)
         mat(718) = -rxt(203)*y(18)
         mat(699) = -rxt(206)*y(18)

         mat(564) = mat(564) + rxt(77)*y(17) + .190*rxt(85)*y(20) + .060*rxt(99)*y(21)  &
                      + .120*rxt(110)*y(30) + .060*rxt(119)*y(34) + .275*rxt(121) &
                      *y(35) + .102*rxt(138)*y(41) + rxt(161)*y(57)
         mat(640) = mat(640) + rxt(65)*y(13) + rxt(87)*y(22) + rxt(113)*y(33)  &
                      + .470*rxt(122)*y(36) + rxt(101)*y(39) + rxt(145)*y(43)  &
                      + .794*rxt(155)*y(56) + 1.500*rxt(164)*y(58)
         mat(513) = mat(513) + rxt(70)*y(15) + rxt(114)*y(33) + .470*rxt(124)*y(36)  &
                      + .794*rxt(156)*y(56) + rxt(162)*y(57) + 1.500*rxt(165)*y(58)
         mat(479) = mat(479) + rxt(65)*y(6) + 4.000*rxt(66)*y(13) + .900*rxt(95)*y(25)  &
                      + rxt(116)*y(33) + .730*rxt(126)*y(36) + rxt(132)*y(38)  &
                      + rxt(103)*y(39) + rxt(147)*y(43) + rxt(167)*y(58)
         mat(735) = rxt(70)*y(8) + rxt(71)*y(17) + rxt(196)*y(71) + rxt(207)*y(78)
         mat(797) = mat(797) + rxt(77)*y(1) + rxt(71)*y(15) + rxt(80)*y(19)  &
                      + .250*rxt(106)*y(30) + .500*rxt(174)*y(32) + .200*rxt(128) &
                      *y(37) + rxt(172)*y(47) + rxt(173)*y(48) + .600*rxt(177)*y(49)  &
                      + rxt(176)*y(50) + rxt(160)*y(57) + rxt(195)*y(72)
         mat(684) = mat(684) + .794*rxt(157)*y(56)
         mat(20) = rxt(80)*y(17)
         mat(291) = .190*rxt(85)*y(1)
         mat(251) = .060*rxt(99)*y(1)
         mat(189) = mat(189) + rxt(87)*y(6)
         mat(439) = mat(439) + .900*rxt(95)*y(13) + rxt(117)*y(33) + .470*rxt(127) &
                      *y(36) + 1.500*rxt(168)*y(58)
         mat(66) = .120*rxt(110)*y(1) + .250*rxt(106)*y(17)
         mat(144) = .500*rxt(174)*y(17)
         mat(400) = mat(400) + rxt(113)*y(6) + rxt(114)*y(8) + rxt(116)*y(13)  &
                      + rxt(117)*y(25)
         mat(366) = .060*rxt(119)*y(1)
         mat(344) = .275*rxt(121)*y(1)
         mat(418) = mat(418) + .470*rxt(122)*y(6) + .470*rxt(124)*y(8) + .730*rxt(126) &
                      *y(13) + .470*rxt(127)*y(25)
         mat(72) = .200*rxt(128)*y(17)
         mat(452) = mat(452) + rxt(132)*y(13)
         mat(180) = mat(180) + rxt(101)*y(6) + rxt(103)*y(13) + 2.400*rxt(104)*y(39)
         mat(268) = .102*rxt(138)*y(1)
         mat(223) = mat(223) + rxt(145)*y(6) + rxt(147)*y(13)
         mat(137) = rxt(172)*y(17)
         mat(57) = rxt(173)*y(17)
         mat(195) = .600*rxt(177)*y(17)
         mat(333) = rxt(176)*y(17)
         mat(204) = mat(204) + .794*rxt(155)*y(6) + .794*rxt(156)*y(8) + .794*rxt(157) &
                      *y(18)
         mat(308) = rxt(161)*y(1) + rxt(162)*y(8) + rxt(160)*y(17)
         mat(381) = mat(381) + 1.500*rxt(164)*y(6) + 1.500*rxt(165)*y(8) + rxt(167) &
                      *y(13) + 1.500*rxt(168)*y(25)
         mat(353) = mat(353) + rxt(196)*y(15)
         mat(530) = mat(530) + rxt(195)*y(17)
         mat(699) = mat(699) + rxt(207)*y(15)

         mat(19) = -(rxt(80)*y(17))
         mat(746) = -rxt(80)*y(19)

         mat(746) = mat(746) + 2.000*rxt(197)*y(17)
         mat(646) = 2.000*rxt(79)*y(18)

         mat(283) = -(rxt(84)*y(17) + rxt(85)*y(1) + rxt(86)*y(8))
         mat(776) = -rxt(84)*y(20)
         mat(544) = -rxt(85)*y(20)
         mat(493) = -rxt(86)*y(20)

         mat(544) = mat(544) + .070*rxt(99)*y(21) + .119*rxt(138)*y(41)
         mat(242) = .070*rxt(99)*y(1)
         mat(258) = .119*rxt(138)*y(1)

         mat(241) = -(rxt(99)*y(1) + rxt(111)*y(17) + rxt(154)*y(8))
         mat(542) = -rxt(99)*y(21)
         mat(774) = -rxt(111)*y(21)
         mat(491) = -rxt(154)*y(21)

         mat(185) = -(rxt(87)*y(6) + rxt(88)*y(18))
         mat(616) = -rxt(87)*y(22)
         mat(660) = -rxt(88)*y(22)

         mat(770) = rxt(84)*y(20) + .500*rxt(89)*y(24)
         mat(282) = rxt(84)*y(17)
         mat(123) = .500*rxt(89)*y(17)

         mat(296) = -(rxt(90)*y(17) + rxt(91)*y(8))
         mat(777) = -rxt(90)*y(23)
         mat(494) = -rxt(91)*y(23)

         mat(545) = .500*rxt(85)*y(20) + .040*rxt(119)*y(34)
         mat(621) = rxt(87)*y(22) + rxt(101)*y(39) + .270*rxt(145)*y(43)
         mat(465) = .800*rxt(103)*y(39)
         mat(777) = mat(777) + .500*rxt(105)*y(40) + rxt(173)*y(48)
         mat(284) = .500*rxt(85)*y(1)
         mat(186) = rxt(87)*y(6)
         mat(356) = .040*rxt(119)*y(1)
         mat(177) = rxt(101)*y(6) + .800*rxt(103)*y(13) + 3.200*rxt(104)*y(39)
         mat(76) = .500*rxt(105)*y(17)
         mat(219) = .270*rxt(145)*y(6)
         mat(56) = rxt(173)*y(17)

         mat(122) = -(rxt(89)*y(17))
         mat(762) = -rxt(89)*y(24)

         mat(655) = rxt(88)*y(22)
         mat(184) = rxt(88)*y(18)

         mat(433) = -(rxt(92)*y(6) + rxt(93)*y(7) + rxt(94)*y(18) + rxt(95)*y(13) &
                      + 4.*rxt(98)*y(25) + rxt(117)*y(33) + rxt(127)*y(36) + rxt(168) &
                      *y(58))
         mat(631) = -rxt(92)*y(25)
         mat(815) = -rxt(93)*y(25)
         mat(675) = -rxt(94)*y(25)
         mat(473) = -rxt(95)*y(25)
         mat(394) = -rxt(117)*y(25)
         mat(412) = -rxt(127)*y(25)
         mat(376) = -rxt(168)*y(25)

         mat(631) = mat(631) + .530*rxt(122)*y(36) + rxt(129)*y(38) + rxt(150)*y(54)
         mat(504) = rxt(91)*y(23) + .530*rxt(124)*y(36) + rxt(130)*y(38) + rxt(159) &
                      *y(55)
         mat(473) = mat(473) + .260*rxt(126)*y(36) + rxt(132)*y(38)
         mat(788) = rxt(90)*y(23) + .500*rxt(96)*y(26) + rxt(158)*y(55)
         mat(297) = rxt(91)*y(8) + rxt(90)*y(17)
         mat(433) = mat(433) + .530*rxt(127)*y(36)
         mat(115) = .500*rxt(96)*y(17)
         mat(412) = mat(412) + .530*rxt(122)*y(6) + .530*rxt(124)*y(8) + .260*rxt(126) &
                      *y(13) + .530*rxt(127)*y(25)
         mat(446) = rxt(129)*y(6) + rxt(130)*y(8) + rxt(132)*y(13) + 4.000*rxt(134) &
                      *y(38)
         mat(209) = rxt(150)*y(6)
         mat(324) = rxt(159)*y(8) + rxt(158)*y(17)


      end subroutine imp_nlnmat02

      subroutine imp_nlnmat03( mat, y, rxt )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, imp_nzcnt

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(inout) ::  mat(imp_nzcnt)


!----------------------------------------------
!       ... Local variables
!----------------------------------------------

!----------------------------------------------
!       ... Complete matrix entries Implicit species
!----------------------------------------------

         mat(114) = -(rxt(96)*y(17))
         mat(760) = -rxt(96)*y(26)

         mat(654) = .700*rxt(94)*y(25) + .700*rxt(131)*y(38)
         mat(422) = .700*rxt(94)*y(18)
         mat(443) = .700*rxt(131)*y(18)

         mat(129) = -(rxt(175)*y(17))
         mat(763) = -rxt(175)*y(27)

         mat(807) = rxt(93)*y(25)
         mat(424) = rxt(93)*y(7)

         mat(51) = -(rxt(153)*y(17))
         mat(749) = -rxt(153)*y(28)

         mat(485) = rxt(86)*y(20)
         mat(281) = rxt(86)*y(8)

         mat(63) = -(rxt(106)*y(17) + rxt(110)*y(1))
         mat(752) = -rxt(106)*y(30)
         mat(537) = -rxt(110)*y(30)

         mat(8) = -(rxt(112)*y(17))
         mat(744) = -rxt(112)*y(31)

         mat(140) = -(rxt(174)*y(17))
         mat(765) = -rxt(174)*y(32)

         mat(808) = rxt(135)*y(38)
         mat(444) = rxt(135)*y(7)

         mat(392) = -(rxt(113)*y(6) + rxt(114)*y(8) + rxt(115)*y(18) + rxt(116)*y(13) &
                      + rxt(117)*y(25))
         mat(629) = -rxt(113)*y(33)
         mat(502) = -rxt(114)*y(33)
         mat(673) = -rxt(115)*y(33)
         mat(471) = -rxt(116)*y(33)
         mat(431) = -rxt(117)*y(33)

         mat(502) = mat(502) + 1.700*rxt(139)*y(41)
         mat(786) = rxt(111)*y(21) + 1.640*rxt(137)*y(41) + .500*rxt(171)*y(60)
         mat(246) = rxt(111)*y(17)
         mat(261) = 1.700*rxt(139)*y(8) + 1.640*rxt(137)*y(17)
         mat(152) = .500*rxt(171)*y(17)

         mat(359) = -(rxt(118)*y(17) + rxt(119)*y(1))
         mat(784) = -rxt(118)*y(34)
         mat(551) = -rxt(119)*y(34)

         mat(551) = mat(551) + .200*rxt(99)*y(21) + .442*rxt(138)*y(41)
         mat(627) = .320*rxt(113)*y(33) + .039*rxt(155)*y(56)
         mat(500) = .350*rxt(114)*y(33) + .039*rxt(156)*y(56)
         mat(469) = .260*rxt(116)*y(33)
         mat(671) = .039*rxt(157)*y(56)
         mat(245) = .200*rxt(99)*y(1)
         mat(429) = .350*rxt(117)*y(33)
         mat(390) = .320*rxt(113)*y(6) + .350*rxt(114)*y(8) + .260*rxt(116)*y(13)  &
                      + .350*rxt(117)*y(25)
         mat(260) = .442*rxt(138)*y(1)
         mat(201) = .039*rxt(155)*y(6) + .039*rxt(156)*y(8) + .039*rxt(157)*y(18)

         mat(338) = -(rxt(120)*y(17) + rxt(121)*y(1))
         mat(782) = -rxt(120)*y(35)
         mat(549) = -rxt(121)*y(35)

         mat(549) = mat(549) + .400*rxt(99)*y(21) + 1.122*rxt(138)*y(41)
         mat(625) = .230*rxt(113)*y(33) + .167*rxt(155)*y(56)
         mat(498) = .250*rxt(114)*y(33) + .167*rxt(156)*y(56)
         mat(468) = .190*rxt(116)*y(33)
         mat(669) = .167*rxt(157)*y(56)
         mat(244) = .400*rxt(99)*y(1)
         mat(428) = .250*rxt(117)*y(33)
         mat(389) = .230*rxt(113)*y(6) + .250*rxt(114)*y(8) + .190*rxt(116)*y(13)  &
                      + .250*rxt(117)*y(25)
         mat(259) = 1.122*rxt(138)*y(1)
         mat(200) = .167*rxt(155)*y(6) + .167*rxt(156)*y(8) + .167*rxt(157)*y(18)

         mat(411) = -((rxt(122) + rxt(123)) * y(6) + rxt(124)*y(8) + rxt(125)*y(18) &
                      + rxt(126)*y(13) + rxt(127)*y(25))
         mat(630) = -(rxt(122) + rxt(123)) * y(36)
         mat(503) = -rxt(124)*y(36)
         mat(674) = -rxt(125)*y(36)
         mat(472) = -rxt(126)*y(36)
         mat(432) = -rxt(127)*y(36)

         mat(787) = rxt(118)*y(34) + .500*rxt(120)*y(35) + .200*rxt(128)*y(37)
         mat(360) = rxt(118)*y(17)
         mat(339) = .500*rxt(120)*y(17)
         mat(70) = .200*rxt(128)*y(17)

         mat(69) = -(rxt(128)*y(17))
         mat(753) = -rxt(128)*y(37)

         mat(649) = rxt(125)*y(36)
         mat(404) = rxt(125)*y(18)

         mat(447) = -(rxt(129)*y(6) + rxt(130)*y(8) + rxt(131)*y(18) + rxt(132)*y(13) &
                      + rxt(133)*y(25) + 4.*rxt(134)*y(38) + rxt(135)*y(7))
         mat(632) = -rxt(129)*y(38)
         mat(505) = -rxt(130)*y(38)
         mat(676) = -rxt(131)*y(38)
         mat(474) = -rxt(132)*y(38)
         mat(434) = -rxt(133)*y(38)
         mat(816) = -rxt(135)*y(38)

         mat(556) = .200*rxt(99)*y(21)
         mat(789) = .500*rxt(120)*y(35) + .500*rxt(128)*y(37) + .800*rxt(177)*y(49)
         mat(247) = .200*rxt(99)*y(1)
         mat(341) = .500*rxt(120)*y(17)
         mat(71) = .500*rxt(128)*y(17)
         mat(194) = .800*rxt(177)*y(17)

         mat(176) = -(rxt(101)*y(6) + rxt(102)*y(18) + rxt(103)*y(13) + 4.*rxt(104) &
                      *y(39))
         mat(615) = -rxt(101)*y(39)
         mat(659) = -rxt(102)*y(39)
         mat(461) = -rxt(103)*y(39)

         mat(769) = .500*rxt(105)*y(40)
         mat(75) = .500*rxt(105)*y(17)

         mat(74) = -(rxt(105)*y(17))
         mat(754) = -rxt(105)*y(40)

         mat(650) = rxt(102)*y(39)
         mat(174) = rxt(102)*y(18)

         mat(257) = -(rxt(137)*y(17) + rxt(138)*y(1) + rxt(139)*y(8))
         mat(775) = -rxt(137)*y(41)
         mat(543) = -rxt(138)*y(41)
         mat(492) = -rxt(139)*y(41)

         mat(218) = -(rxt(145)*y(6) + rxt(146)*y(18) + rxt(147)*y(13))
         mat(620) = -rxt(145)*y(43)
         mat(663) = -rxt(146)*y(43)
         mat(464) = -rxt(147)*y(43)

         mat(773) = 1.330*rxt(112)*y(31) + rxt(148)*y(44)
         mat(9) = 1.330*rxt(112)*y(17)
         mat(81) = rxt(148)*y(17)

         mat(79) = -(rxt(148)*y(17))
         mat(755) = -rxt(148)*y(44)

         mat(651) = rxt(146)*y(43)
         mat(215) = rxt(146)*y(18)

         mat(156) = -(rxt(149)*y(17))
         mat(767) = -rxt(149)*y(45)

         mat(614) = .820*rxt(145)*y(43)
         mat(460) = .820*rxt(147)*y(43)
         mat(767) = mat(767) + .100*rxt(137)*y(41)
         mat(255) = .100*rxt(137)*y(17)
         mat(216) = .820*rxt(145)*y(6) + .820*rxt(147)*y(13)

         mat(84) = -(rxt(152)*y(17))
         mat(756) = -rxt(152)*y(46)

         mat(652) = rxt(151)*y(54)
         mat(207) = rxt(151)*y(18)

         mat(136) = -(rxt(172)*y(17))
         mat(764) = -rxt(172)*y(47)

         mat(459) = 2.000*rxt(67)*y(13) + .250*rxt(116)*y(33) + .250*rxt(126)*y(36)  &
                      + .300*rxt(103)*y(39) + .300*rxt(167)*y(58)
         mat(386) = .250*rxt(116)*y(13)
         mat(405) = .250*rxt(126)*y(13)
         mat(175) = .300*rxt(103)*y(13)
         mat(371) = .300*rxt(167)*y(13)

         mat(55) = -(rxt(173)*y(17))
         mat(750) = -rxt(173)*y(48)

         mat(456) = .200*rxt(103)*y(39)
         mat(173) = .200*rxt(103)*y(13) + .800*rxt(104)*y(39)

         mat(193) = -(rxt(177)*y(17))
         mat(771) = -rxt(177)*y(49)

         mat(617) = .530*rxt(122)*y(36) + .250*rxt(164)*y(58)
         mat(489) = .530*rxt(124)*y(36) + .250*rxt(165)*y(58)
         mat(462) = .260*rxt(126)*y(36) + .100*rxt(167)*y(58)
         mat(425) = .530*rxt(127)*y(36) + .250*rxt(168)*y(58)
         mat(406) = .530*rxt(122)*y(6) + .530*rxt(124)*y(8) + .260*rxt(126)*y(13)  &
                      + .530*rxt(127)*y(25)
         mat(372) = .250*rxt(164)*y(6) + .250*rxt(165)*y(8) + .100*rxt(167)*y(13)  &
                      + .250*rxt(168)*y(25)

         mat(330) = -(rxt(176)*y(17))
         mat(781) = -rxt(176)*y(50)

         mat(624) = .220*rxt(122)*y(36) + .250*rxt(164)*y(58)
         mat(497) = .220*rxt(124)*y(36) + .250*rxt(165)*y(58)
         mat(467) = .230*rxt(126)*y(36) + .100*rxt(167)*y(58)
         mat(781) = mat(781) + .500*rxt(89)*y(24) + .500*rxt(174)*y(32)
         mat(125) = .500*rxt(89)*y(17)
         mat(427) = .220*rxt(127)*y(36) + .250*rxt(168)*y(58)
         mat(141) = .500*rxt(174)*y(17)
         mat(409) = .220*rxt(122)*y(6) + .220*rxt(124)*y(8) + .230*rxt(126)*y(13)  &
                      + .220*rxt(127)*y(25)
         mat(374) = .250*rxt(164)*y(6) + .250*rxt(165)*y(8) + .100*rxt(167)*y(13)  &
                      + .250*rxt(168)*y(25)

         mat(102) = -(rxt(107)*y(6))
         mat(612) = -rxt(107)*y(51)

         mat(759) = .750*rxt(106)*y(30)
         mat(64) = .750*rxt(106)*y(17)


         mat(610) = rxt(107)*y(51)
         mat(101) = rxt(107)*y(6)

         mat(119) = -(rxt(163)*y(17))
         mat(761) = -rxt(163)*y(53)

         mat(540) = .400*rxt(161)*y(57)
         mat(613) = .370*rxt(113)*y(33)
         mat(487) = .400*rxt(114)*y(33)
         mat(458) = .300*rxt(116)*y(33)
         mat(761) = mat(761) + .400*rxt(160)*y(57)
         mat(423) = .400*rxt(117)*y(33)
         mat(385) = .370*rxt(113)*y(6) + .400*rxt(114)*y(8) + .300*rxt(116)*y(13)  &
                      + .400*rxt(117)*y(25)
         mat(303) = .400*rxt(161)*y(1) + .400*rxt(160)*y(17)

         mat(208) = -(rxt(150)*y(6) + rxt(151)*y(18))
         mat(619) = -rxt(150)*y(54)
         mat(662) = -rxt(151)*y(54)

         mat(772) = rxt(149)*y(45) + rxt(152)*y(46)
         mat(157) = rxt(149)*y(17)
         mat(85) = rxt(152)*y(17)

         mat(323) = -(rxt(158)*y(17) + rxt(159)*y(8))
         mat(780) = -rxt(158)*y(55)
         mat(496) = -rxt(159)*y(55)

         mat(547) = .950*rxt(119)*y(34) + .800*rxt(121)*y(35)
         mat(623) = .250*rxt(122)*y(36) + .250*rxt(164)*y(58)
         mat(496) = mat(496) + .250*rxt(124)*y(36) + .250*rxt(165)*y(58)
         mat(466) = .240*rxt(126)*y(36) + .100*rxt(167)*y(58)
         mat(780) = mat(780) + rxt(153)*y(28) + rxt(176)*y(50)
         mat(426) = .250*rxt(127)*y(36) + .250*rxt(168)*y(58)
         mat(52) = rxt(153)*y(17)
         mat(357) = .950*rxt(119)*y(1)
         mat(337) = .800*rxt(121)*y(1)
         mat(408) = .250*rxt(122)*y(6) + .250*rxt(124)*y(8) + .240*rxt(126)*y(13)  &
                      + .250*rxt(127)*y(25)
         mat(329) = rxt(176)*y(17)
         mat(373) = .250*rxt(164)*y(6) + .250*rxt(165)*y(8) + .100*rxt(167)*y(13)  &
                      + .250*rxt(168)*y(25)


      end subroutine imp_nlnmat03

      subroutine imp_nlnmat04( mat, y, rxt )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, imp_nzcnt

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(inout) ::  mat(imp_nzcnt)


!----------------------------------------------
!       ... Local variables
!----------------------------------------------

!----------------------------------------------
!       ... Complete matrix entries Implicit species
!----------------------------------------------

         mat(198) = -(rxt(155)*y(6) + rxt(156)*y(8) + rxt(157)*y(18))
         mat(618) = -rxt(155)*y(56)
         mat(490) = -rxt(156)*y(56)
         mat(661) = -rxt(157)*y(56)

         mat(490) = mat(490) + rxt(154)*y(21)
         mat(240) = rxt(154)*y(8)

         mat(304) = -(rxt(160)*y(17) + rxt(161)*y(1) + rxt(162)*y(8))
         mat(778) = -rxt(160)*y(57)
         mat(546) = -rxt(161)*y(57)
         mat(495) = -rxt(162)*y(57)

         mat(622) = .080*rxt(113)*y(33) + rxt(123)*y(36) + .794*rxt(155)*y(56)
         mat(495) = mat(495) + .794*rxt(156)*y(56)
         mat(666) = .794*rxt(157)*y(56)
         mat(388) = .080*rxt(113)*y(6)
         mat(407) = rxt(123)*y(6)
         mat(199) = .794*rxt(155)*y(6) + .794*rxt(156)*y(8) + .794*rxt(157)*y(18)

         mat(375) = -(rxt(164)*y(6) + rxt(165)*y(8) + rxt(166)*y(18) + rxt(167)*y(13) &
                      + rxt(168)*y(25))
         mat(628) = -rxt(164)*y(58)
         mat(501) = -rxt(165)*y(58)
         mat(672) = -rxt(166)*y(58)
         mat(470) = -rxt(167)*y(58)
         mat(430) = -rxt(168)*y(58)

         mat(785) = rxt(163)*y(53) + rxt(169)*y(59) + .500*rxt(171)*y(60)
         mat(120) = rxt(163)*y(17)
         mat(27) = rxt(169)*y(17)
         mat(151) = .500*rxt(171)*y(17)

         mat(26) = -((rxt(169) + rxt(170)) * y(17))
         mat(747) = -(rxt(169) + rxt(170)) * y(59)

         mat(647) = rxt(166)*y(58)
         mat(370) = rxt(166)*y(18)

         mat(148) = -(rxt(171)*y(17))
         mat(766) = -rxt(171)*y(60)

         mat(656) = rxt(115)*y(33)
         mat(387) = rxt(115)*y(18)

         mat(15) = -(rxt(178)*y(17))
         mat(745) = -rxt(178)*y(62)

         mat(483) = rxt(181)*y(64)
         mat(745) = mat(745) + (rxt(179)+.750*rxt(180))*y(64)
         mat(29) = rxt(181)*y(8) + (rxt(179)+.750*rxt(180))*y(17)


         mat(741) = rxt(178)*y(62)
         mat(14) = rxt(178)*y(17)

         mat(30) = -((rxt(179) + rxt(180)) * y(17) + rxt(181)*y(8))
         mat(748) = -(rxt(179) + rxt(180)) * y(64)
         mat(484) = -rxt(181)*y(64)

         mat(6) = -(rxt(183)*y(17))
         mat(743) = -rxt(183)*y(65)



         mat(602) = -(rxt(192)*y(17) + rxt(215)*y(69) + rxt(216)*y(11) + rxt(219) &
                      *y(70) + rxt(220)*y(75))
         mat(795) = -rxt(192)*y(68)
         mat(166) = -rxt(215)*y(68)
         mat(112) = -rxt(216)*y(68)
         mat(236) = -rxt(219)*y(68)
         mat(277) = -rxt(220)*y(68)

         mat(733) = rxt(196)*y(71)
         mat(795) = mat(795) + rxt(210)*y(72)
         mat(682) = rxt(193)*y(71)
         mat(352) = rxt(196)*y(15) + rxt(193)*y(18)
         mat(528) = rxt(210)*y(17)

         mat(163) = -(rxt(215)*y(68) + rxt(221)*y(76))
         mat(591) = -rxt(215)*y(69)
         mat(313) = -rxt(221)*y(69)

         mat(658) = rxt(194)*y(72)
         mat(519) = rxt(194)*y(18)

         mat(230) = -(rxt(190)*y(2) + rxt(219)*y(68))
         mat(571) = -rxt(190)*y(70)
         mat(593) = -rxt(219)*y(70)

         mat(810) = rxt(189)*y(72)
         mat(520) = rxt(189)*y(7)

         mat(348) = -(rxt(186)*y(1) + rxt(193)*y(18) + rxt(196)*y(15))
         mat(550) = -rxt(186)*y(71)
         mat(670) = -rxt(193)*y(71)
         mat(727) = -rxt(196)*y(71)

         mat(574) = rxt(187)*y(72)
         mat(626) = rxt(188)*y(72)
         mat(110) = rxt(216)*y(68)
         mat(783) = rxt(192)*y(68) + rxt(195)*y(72)
         mat(596) = rxt(216)*y(11) + rxt(192)*y(17)
         mat(522) = rxt(187)*y(2) + rxt(188)*y(6) + rxt(195)*y(17) + rxt(202)*y(79)
         mat(710) = rxt(202)*y(72)

         mat(525) = -(rxt(187)*y(2) + rxt(188)*y(6) + rxt(189)*y(7) + rxt(194)*y(18) &
                      + (rxt(195) + rxt(210)) * y(17) + 4.*rxt(198)*y(72) + (rxt(202) &
                      + rxt(209)) * y(79))
         mat(577) = -rxt(187)*y(72)
         mat(635) = -rxt(188)*y(72)
         mat(819) = -rxt(189)*y(72)
         mat(679) = -rxt(194)*y(72)
         mat(792) = -(rxt(195) + rxt(210)) * y(72)
         mat(713) = -(rxt(202) + rxt(209)) * y(72)

         mat(559) = rxt(186)*y(71)
         mat(577) = mat(577) + rxt(190)*y(70)
         mat(234) = rxt(190)*y(2)
         mat(350) = rxt(186)*y(1)


         mat(517) = 2.000*rxt(198)*y(72)


         mat(588) = rxt(215)*y(69) + rxt(219)*y(70)
         mat(161) = rxt(215)*y(68)
         mat(227) = rxt(219)*y(68)

         mat(273) = -(rxt(205)*y(2) + rxt(220)*y(68) + rxt(222)*y(76))
         mat(572) = -rxt(205)*y(75)
         mat(594) = -rxt(220)*y(75)
         mat(314) = -rxt(222)*y(75)

         mat(664) = rxt(203)*y(79)
         mat(708) = rxt(203)*y(18)

         mat(315) = -(rxt(208)*y(17) + rxt(221)*y(69) + rxt(222)*y(75))
         mat(779) = -rxt(208)*y(76)
         mat(164) = -rxt(221)*y(76)
         mat(274) = -rxt(222)*y(76)

         mat(726) = rxt(207)*y(78)
         mat(667) = rxt(206)*y(78)
         mat(690) = rxt(207)*y(15) + rxt(206)*y(18)


         mat(804) = rxt(201)*y(79)
         mat(705) = rxt(201)*y(7)

         mat(700) = -(rxt(200)*y(1) + rxt(206)*y(18) + rxt(207)*y(15))
         mat(565) = -rxt(200)*y(78)
         mat(685) = -rxt(206)*y(78)
         mat(736) = -rxt(207)*y(78)

         mat(641) = rxt(204)*y(79)
         mat(798) = rxt(208)*y(76)
         mat(531) = rxt(202)*y(79)
         mat(278) = 2.000*rxt(222)*y(76)
         mat(319) = rxt(208)*y(17) + 2.000*rxt(222)*y(75)
         mat(719) = rxt(204)*y(6) + rxt(202)*y(72)

         mat(720) = -(rxt(201)*y(7) + (rxt(202) + rxt(209)) * y(72) + rxt(203)*y(18) &
                      + rxt(204)*y(6))
         mat(826) = -rxt(201)*y(79)
         mat(532) = -(rxt(202) + rxt(209)) * y(79)
         mat(686) = -rxt(203)*y(79)
         mat(642) = -rxt(204)*y(79)

         mat(566) = rxt(200)*y(78)
         mat(584) = rxt(205)*y(75)
         mat(279) = rxt(205)*y(2)
         mat(701) = rxt(200)*y(1)


         mat(589) = rxt(220)*y(75)
         mat(162) = rxt(221)*y(76)
         mat(518) = rxt(209)*y(79)
         mat(272) = rxt(220)*y(68)
         mat(312) = rxt(221)*y(69)
         mat(706) = rxt(209)*y(72)


         mat(97) = -(rxt(184)*y(1))
         mat(538) = -rxt(184)*y(82)

         mat(570) = rxt(75)*y(17)
         mat(758) = rxt(75)*y(2)


      end subroutine imp_nlnmat04

      subroutine imp_nlnmat_finit( mat, lmat, dti )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, imp_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  dti
      real, intent(in)    ::  lmat(imp_nzcnt)
      real, intent(inout) ::  mat(imp_nzcnt)


!----------------------------------------------
!       ... Local variables
!----------------------------------------------

!----------------------------------------------
!       ... Complete matrix entries Implicit species
!----------------------------------------------

         mat(   4) = lmat(   4)
         mat(   5) = lmat(   5)
         mat(   6) = mat(   6) + lmat(   6)
         mat(  11) = lmat(  11)
         mat(  12) = lmat(  12)
         mat(  13) = lmat(  13)
         mat(  17) = lmat(  17)
         mat(  18) = lmat(  18)
         mat(  19) = mat(  19) + lmat(  19)
         mat(  21) = mat(  21) + lmat(  21)
         mat(  22) = lmat(  22)
         mat(  23) = lmat(  23)
         mat(  24) = lmat(  24)
         mat(  25) = lmat(  25)
         mat(  26) = mat(  26) + lmat(  26)
         mat(  28) = mat(  28) + lmat(  28)
         mat(  34) = mat(  34) + lmat(  34)
         mat(  35) = mat(  35) + lmat(  35)
         mat(  36) = mat(  36) + lmat(  36)
         mat(  38) = lmat(  38)
         mat(  39) = lmat(  39)
         mat(  40) = lmat(  40)
         mat(  41) = lmat(  41)
         mat(  42) = lmat(  42)
         mat(  43) = lmat(  43)
         mat(  44) = lmat(  44)
         mat(  45) = lmat(  45)
         mat(  46) = lmat(  46)
         mat(  47) = lmat(  47)
         mat(  48) = lmat(  48)
         mat(  49) = lmat(  49)
         mat(  50) = lmat(  50)
         mat(  59) = mat(  59) + lmat(  59)
         mat(  60) = lmat(  60)
         mat(  62) = mat(  62) + lmat(  62)
         mat(  74) = mat(  74) + lmat(  74)
         mat(  76) = mat(  76) + lmat(  76)
         mat(  77) = lmat(  77)
         mat(  78) = mat(  78) + lmat(  78)
         mat(  79) = mat(  79) + lmat(  79)
         mat(  80) = lmat(  80)
         mat(  82) = lmat(  82)
         mat(  83) = mat(  83) + lmat(  83)
         mat(  84) = mat(  84) + lmat(  84)
         mat(  86) = lmat(  86)
         mat(  87) = lmat(  87)
         mat(  88) = mat(  88) + lmat(  88)
         mat(  89) = mat(  89) + lmat(  89)
         mat(  91) = lmat(  91)
         mat(  92) = mat(  92) + lmat(  92)
         mat(  93) = mat(  93) + lmat(  93)
         mat(  94) = lmat(  94)
         mat(  95) = lmat(  95)
         mat(  96) = lmat(  96)
         mat(  97) = mat(  97) + lmat(  97)
         mat(  99) = lmat(  99)
         mat( 108) = mat( 108) + lmat( 108)
         mat( 109) = mat( 109) + lmat( 109)
         mat( 111) = lmat( 111)
         mat( 113) = mat( 113) + lmat( 113)
         mat( 114) = mat( 114) + lmat( 114)
         mat( 116) = lmat( 116)
         mat( 118) = mat( 118) + lmat( 118)
         mat( 122) = mat( 122) + lmat( 122)
         mat( 124) = lmat( 124)
         mat( 126) = lmat( 126)
         mat( 127) = lmat( 127)
         mat( 128) = mat( 128) + lmat( 128)
         mat( 129) = mat( 129) + lmat( 129)
         mat( 130) = lmat( 130)
         mat( 131) = lmat( 131)
         mat( 132) = mat( 132) + lmat( 132)
         mat( 135) = lmat( 135)
         mat( 140) = mat( 140) + lmat( 140)
         mat( 142) = lmat( 142)
         mat( 147) = lmat( 147)
         mat( 148) = mat( 148) + lmat( 148)
         mat( 149) = lmat( 149)
         mat( 150) = lmat( 150)
         mat( 153) = lmat( 153)
         mat( 154) = lmat( 154)
         mat( 156) = mat( 156) + lmat( 156)
         mat( 158) = lmat( 158)
         mat( 159) = lmat( 159)
         mat( 163) = mat( 163) + lmat( 163)
         mat( 165) = lmat( 165)
         mat( 168) = lmat( 168)
         mat( 169) = mat( 169) + lmat( 169)
         mat( 171) = mat( 171) + lmat( 171)
         mat( 172) = lmat( 172)
         mat( 193) = mat( 193) + lmat( 193)
         mat( 195) = mat( 195) + lmat( 195)
         mat( 196) = lmat( 196)
         mat( 228) = lmat( 228)
         mat( 229) = mat( 229) + lmat( 229)
         mat( 230) = mat( 230) + lmat( 230)
         mat( 232) = lmat( 232)
         mat( 233) = mat( 233) + lmat( 233)
         mat( 273) = mat( 273) + lmat( 273)
         mat( 278) = mat( 278) + lmat( 278)
         mat( 280) = mat( 280) + lmat( 280)
         mat( 296) = mat( 296) + lmat( 296)
         mat( 298) = lmat( 298)
         mat( 300) = lmat( 300)
         mat( 304) = mat( 304) + lmat( 304)
         mat( 308) = mat( 308) + lmat( 308)
         mat( 309) = lmat( 309)
         mat( 311) = mat( 311) + lmat( 311)
         mat( 323) = mat( 323) + lmat( 323)
         mat( 324) = mat( 324) + lmat( 324)
         mat( 326) = lmat( 326)
         mat( 330) = mat( 330) + lmat( 330)
         mat( 331) = lmat( 331)
         mat( 333) = mat( 333) + lmat( 333)
         mat( 334) = lmat( 334)
         mat( 338) = mat( 338) + lmat( 338)
         mat( 340) = lmat( 340)
         mat( 341) = mat( 341) + lmat( 341)
         mat( 344) = mat( 344) + lmat( 344)
         mat( 345) = mat( 345) + lmat( 345)
         mat( 346) = mat( 346) + lmat( 346)
         mat( 348) = mat( 348) + lmat( 348)
         mat( 349) = lmat( 349)
         mat( 352) = mat( 352) + lmat( 352)
         mat( 355) = lmat( 355)
         mat( 359) = mat( 359) + lmat( 359)
         mat( 361) = lmat( 361)
         mat( 362) = lmat( 362)
         mat( 488) = mat( 488) + lmat( 488)
         mat( 507) = mat( 507) + lmat( 507)
         mat( 510) = lmat( 510)
         mat( 512) = mat( 512) + lmat( 512)
         mat( 516) = mat( 516) + lmat( 516)
         mat( 536) = lmat( 536)
         mat( 560) = mat( 560) + lmat( 560)
         mat( 561) = mat( 561) + lmat( 561)
         mat( 578) = mat( 578) + lmat( 578)
         mat( 579) = mat( 579) + lmat( 579)
         mat( 611) = mat( 611) + lmat( 611)
         mat( 637) = mat( 637) + lmat( 637)
         mat( 639) = mat( 639) + lmat( 639)
         mat( 715) = lmat( 715)
         mat( 719) = mat( 719) + lmat( 719)
         mat( 720) = mat( 720) + lmat( 720)
         mat( 724) = lmat( 724)
         mat( 735) = mat( 735) + lmat( 735)
         mat( 738) = mat( 738) + lmat( 738)
         mat( 742) = lmat( 742)
         mat( 758) = mat( 758) + lmat( 758)
         mat( 769) = mat( 769) + lmat( 769)
         mat( 773) = mat( 773) + lmat( 773)
         mat( 790) = mat( 790) + lmat( 790)
         mat( 797) = mat( 797) + lmat( 797)
         mat( 801) = mat( 801) + lmat( 801)
         mat( 821) = mat( 821) + lmat( 821)
         mat( 823) = mat( 823) + lmat( 823)
         mat( 829) = mat( 829) + lmat( 829)
         mat(   1) = 0.
         mat(   2) = 0.
         mat(   3) = 0.
         mat( 103) = 0.
         mat( 105) = 0.
         mat( 106) = 0.
         mat( 167) = 0.
         mat( 182) = 0.
         mat( 187) = 0.
         mat( 191) = 0.
         mat( 213) = 0.
         mat( 217) = 0.
         mat( 220) = 0.
         mat( 225) = 0.
         mat( 231) = 0.
         mat( 237) = 0.
         mat( 238) = 0.
         mat( 239) = 0.
         mat( 243) = 0.
         mat( 250) = 0.
         mat( 254) = 0.
         mat( 256) = 0.
         mat( 262) = 0.
         mat( 263) = 0.
         mat( 267) = 0.
         mat( 275) = 0.
         mat( 285) = 0.
         mat( 286) = 0.
         mat( 290) = 0.
         mat( 294) = 0.
         mat( 302) = 0.
         mat( 305) = 0.
         mat( 316) = 0.
         mat( 317) = 0.
         mat( 318) = 0.
         mat( 320) = 0.
         mat( 328) = 0.
         mat( 332) = 0.
         mat( 336) = 0.
         mat( 342) = 0.
         mat( 347) = 0.
         mat( 358) = 0.
         mat( 363) = 0.
         mat( 365) = 0.
         mat( 369) = 0.
         mat( 377) = 0.
         mat( 383) = 0.
         mat( 391) = 0.
         mat( 393) = 0.
         mat( 395) = 0.
         mat( 398) = 0.
         mat( 402) = 0.
         mat( 410) = 0.
         mat( 413) = 0.
         mat( 416) = 0.
         mat( 420) = 0.
         mat( 436) = 0.
         mat( 441) = 0.
         mat( 445) = 0.
         mat( 454) = 0.
         mat( 463) = 0.
         mat( 476) = 0.
         mat( 477) = 0.
         mat( 481) = 0.
         mat( 499) = 0.
         mat( 506) = 0.
         mat( 508) = 0.
         mat( 509) = 0.
         mat( 511) = 0.
         mat( 521) = 0.
         mat( 523) = 0.
         mat( 524) = 0.
         mat( 526) = 0.
         mat( 533) = 0.
         mat( 539) = 0.
         mat( 541) = 0.
         mat( 548) = 0.
         mat( 552) = 0.
         mat( 553) = 0.
         mat( 554) = 0.
         mat( 555) = 0.
         mat( 562) = 0.
         mat( 573) = 0.
         mat( 575) = 0.
         mat( 580) = 0.
         mat( 583) = 0.
         mat( 585) = 0.
         mat( 595) = 0.
         mat( 597) = 0.
         mat( 598) = 0.
         mat( 599) = 0.
         mat( 600) = 0.
         mat( 601) = 0.
         mat( 603) = 0.
         mat( 604) = 0.
         mat( 605) = 0.
         mat( 606) = 0.
         mat( 607) = 0.
         mat( 638) = 0.
         mat( 657) = 0.
         mat( 665) = 0.
         mat( 668) = 0.
         mat( 691) = 0.
         mat( 692) = 0.
         mat( 693) = 0.
         mat( 694) = 0.
         mat( 696) = 0.
         mat( 697) = 0.
         mat( 698) = 0.
         mat( 703) = 0.
         mat( 704) = 0.
         mat( 707) = 0.
         mat( 709) = 0.
         mat( 711) = 0.
         mat( 712) = 0.
         mat( 714) = 0.
         mat( 716) = 0.
         mat( 721) = 0.
         mat( 722) = 0.
         mat( 728) = 0.
         mat( 730) = 0.
         mat( 731) = 0.
         mat( 732) = 0.
         mat( 734) = 0.
         mat( 737) = 0.
         mat( 740) = 0.
         mat( 796) = 0.
         mat( 799) = 0.
         mat( 811) = 0.
         mat( 812) = 0.
         mat( 813) = 0.
         mat( 814) = 0.
         mat( 817) = 0.
         mat( 822) = 0.
         mat( 825) = 0.
         mat( 827) = 0.
         mat(   1) = -dti
         mat(   2) = -dti
         mat(   3) = -dti
         mat(   4) = mat(   4) - dti
         mat(   6) = mat(   6) - dti
         mat(   8) = mat(   8) - dti
         mat(  11) = mat(  11) - dti
         mat(  15) = mat(  15) - dti
         mat(  17) = mat(  17) - dti
         mat(  19) = mat(  19) - dti
         mat(  22) = mat(  22) - dti
         mat(  26) = mat(  26) - dti
         mat(  30) = mat(  30) - dti
         mat(  34) = mat(  34) - dti
         mat(  38) = mat(  38) - dti
         mat(  46) = mat(  46) - dti
         mat(  51) = mat(  51) - dti
         mat(  55) = mat(  55) - dti
         mat(  59) = mat(  59) - dti
         mat(  63) = mat(  63) - dti
         mat(  69) = mat(  69) - dti
         mat(  74) = mat(  74) - dti
         mat(  79) = mat(  79) - dti
         mat(  84) = mat(  84) - dti
         mat(  89) = mat(  89) - dti
         mat(  94) = mat(  94) - dti
         mat(  97) = mat(  97) - dti
         mat( 102) = mat( 102) - dti
         mat( 108) = mat( 108) - dti
         mat( 114) = mat( 114) - dti
         mat( 119) = mat( 119) - dti
         mat( 122) = mat( 122) - dti
         mat( 129) = mat( 129) - dti
         mat( 136) = mat( 136) - dti
         mat( 140) = mat( 140) - dti
         mat( 148) = mat( 148) - dti
         mat( 156) = mat( 156) - dti
         mat( 163) = mat( 163) - dti
         mat( 169) = mat( 169) - dti
         mat( 176) = mat( 176) - dti
         mat( 185) = mat( 185) - dti
         mat( 193) = mat( 193) - dti
         mat( 198) = mat( 198) - dti
         mat( 208) = mat( 208) - dti
         mat( 218) = mat( 218) - dti
         mat( 230) = mat( 230) - dti
         mat( 241) = mat( 241) - dti
         mat( 257) = mat( 257) - dti
         mat( 273) = mat( 273) - dti
         mat( 283) = mat( 283) - dti
         mat( 296) = mat( 296) - dti
         mat( 304) = mat( 304) - dti
         mat( 315) = mat( 315) - dti
         mat( 323) = mat( 323) - dti
         mat( 330) = mat( 330) - dti
         mat( 338) = mat( 338) - dti
         mat( 348) = mat( 348) - dti
         mat( 359) = mat( 359) - dti
         mat( 375) = mat( 375) - dti
         mat( 392) = mat( 392) - dti
         mat( 411) = mat( 411) - dti
         mat( 433) = mat( 433) - dti
         mat( 447) = mat( 447) - dti
         mat( 475) = mat( 475) - dti
         mat( 507) = mat( 507) - dti
         mat( 525) = mat( 525) - dti
         mat( 560) = mat( 560) - dti
         mat( 579) = mat( 579) - dti
         mat( 602) = mat( 602) - dti
         mat( 639) = mat( 639) - dti
         mat( 684) = mat( 684) - dti
         mat( 700) = mat( 700) - dti
         mat( 720) = mat( 720) - dti
         mat( 738) = mat( 738) - dti
         mat( 801) = mat( 801) - dti
         mat( 829) = mat( 829) - dti

      end subroutine imp_nlnmat_finit

      subroutine imp_nlnmat( mat, y, rxt, lmat, dti )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, imp_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  dti
      real, intent(in)    ::  lmat(imp_nzcnt)
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(inout) ::  mat(imp_nzcnt)

      call imp_nlnmat01( mat, y, rxt )
      call imp_nlnmat02( mat, y, rxt )
      call imp_nlnmat03( mat, y, rxt )
      call imp_nlnmat04( mat, y, rxt )
      call imp_nlnmat_finit( mat, lmat, dti )

      end subroutine imp_nlnmat

      end module MO_IMP_NLN_MATRIX_MOD

      module MO_ROD_NLN_MATRIX_MOD

      contains

      subroutine rod_nlnmat( mat, y, rxt, lmat, dti )

      use MO_GRID_MOD,   only : pcnstm1
      use CHEM_MODS_MOD, only : rxntot, rod_nzcnt, clsze

      implicit none

!----------------------------------------------
!       ... Dummy args
!----------------------------------------------
      real, intent(in)    ::  dti
      real, intent(in)    ::  lmat(rod_nzcnt)
      real, intent(in)    ::  y(pcnstm1)
      real, intent(in)    ::  rxt(rxntot)
      real, intent(inout) ::  mat(rod_nzcnt)


      end subroutine rod_nlnmat

      end module MO_ROD_NLN_MATRIX_MOD

      module MO_IMP_FACTOR_MOD

      contains
                                                                        
      subroutine imp_lu_fac01( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(1) = 1. / lu(1)
                                                                        
         lu(2) = 1. / lu(2)
                                                                        
         lu(3) = 1. / lu(3)
                                                                        
         lu(4) = 1. / lu(4)
                                                                        
         lu(6) = 1. / lu(6)
         lu(7) = lu(7) * lu(6)
         lu(801) = lu(801) - lu(7) * lu(743)
                                                                        
         lu(8) = 1. / lu(8)
         lu(9) = lu(9) * lu(8)
         lu(10) = lu(10) * lu(8)
         lu(773) = lu(773) - lu(9) * lu(744)
         lu(801) = lu(801) - lu(10) * lu(744)
                                                                        
         lu(11) = 1. / lu(11)
         lu(12) = lu(12) * lu(11)
         lu(13) = lu(13) * lu(11)
         lu(522) = lu(522) - lu(12) * lu(517)
         lu(525) = lu(525) - lu(13) * lu(517)
                                                                        
         lu(15) = 1. / lu(15)
         lu(16) = lu(16) * lu(15)
         lu(32) = lu(32) - lu(16) * lu(29)
         lu(515) = lu(515) - lu(16) * lu(483)
         lu(801) = lu(801) - lu(16) * lu(745)
                                                                        
         lu(17) = 1. / lu(17)
         lu(18) = lu(18) * lu(17)
         lu(165) = lu(165) - lu(18) * lu(161)
         lu(232) = lu(232) - lu(18) * lu(227)
         lu(596) = lu(596) - lu(18) * lu(588)
                                                                        
         lu(19) = 1. / lu(19)
         lu(20) = lu(20) * lu(19)
         lu(21) = lu(21) * lu(19)
         lu(684) = lu(684) - lu(20) * lu(646)
         lu(688) = lu(688) - lu(21) * lu(646)
         lu(797) = lu(797) - lu(20) * lu(746)
         lu(801) = lu(801) - lu(21) * lu(746)
                                                                        
         lu(22) = 1. / lu(22)
         lu(23) = lu(23) * lu(22)
         lu(24) = lu(24) * lu(22)
         lu(25) = lu(25) * lu(22)
         lu(103) = - lu(23) * lu(101)
         lu(105) = - lu(24) * lu(101)
         lu(106) = - lu(25) * lu(101)
         lu(617) = lu(617) - lu(23) * lu(610)
         lu(640) = lu(640) - lu(24) * lu(610)
         lu(643) = lu(643) - lu(25) * lu(610)
                                                                        
         lu(26) = 1. / lu(26)
         lu(27) = lu(27) * lu(26)
         lu(28) = lu(28) * lu(26)
         lu(375) = lu(375) - lu(27) * lu(370)
         lu(383) = - lu(28) * lu(370)
         lu(672) = lu(672) - lu(27) * lu(647)
         lu(688) = lu(688) - lu(28) * lu(647)
         lu(785) = lu(785) - lu(27) * lu(747)
         lu(801) = lu(801) - lu(28) * lu(747)
                                                                        
         lu(30) = 1. / lu(30)
         lu(31) = lu(31) * lu(30)
         lu(32) = lu(32) * lu(30)
         lu(33) = lu(33) * lu(30)
         lu(507) = lu(507) - lu(31) * lu(484)
         lu(515) = lu(515) - lu(32) * lu(484)
         lu(516) = lu(516) - lu(33) * lu(484)
         lu(791) = lu(791) - lu(31) * lu(748)
         lu(801) = lu(801) - lu(32) * lu(748)
         lu(802) = lu(802) - lu(33) * lu(748)
                                                                        
         lu(34) = 1. / lu(34)
         lu(35) = lu(35) * lu(34)
         lu(36) = lu(36) * lu(34)
         lu(37) = lu(37) * lu(34)
         lu(637) = lu(637) - lu(35) * lu(611)
         lu(639) = lu(639) - lu(36) * lu(611)
         lu(645) = lu(645) - lu(37) * lu(611)
         lu(821) = lu(821) - lu(35) * lu(803)
         lu(823) = lu(823) - lu(36) * lu(803)
         lu(829) = lu(829) - lu(37) * lu(803)
                                                                        
         lu(38) = 1. / lu(38)
         lu(39) = lu(39) * lu(38)
         lu(40) = lu(40) * lu(38)
         lu(41) = lu(41) * lu(38)
         lu(42) = lu(42) * lu(38)
         lu(43) = lu(43) * lu(38)
         lu(44) = lu(44) * lu(38)
         lu(45) = lu(45) * lu(38)
         lu(538) = lu(538) - lu(39) * lu(536)
         lu(557) = lu(557) - lu(40) * lu(536)
         lu(561) = lu(561) - lu(41) * lu(536)
         lu(563) = lu(563) - lu(42) * lu(536)
         lu(564) = lu(564) - lu(43) * lu(536)
         lu(567) = lu(567) - lu(44) * lu(536)
         lu(568) = lu(568) - lu(45) * lu(536)
                                                                        
         lu(46) = 1. / lu(46)
         lu(47) = lu(47) * lu(46)
         lu(48) = lu(48) * lu(46)
         lu(49) = lu(49) * lu(46)
         lu(50) = lu(50) * lu(46)
         lu(707) = - lu(47) * lu(705)
         lu(708) = lu(708) - lu(48) * lu(705)
         lu(712) = - lu(49) * lu(705)
         lu(719) = lu(719) - lu(50) * lu(705)
         lu(809) = lu(809) - lu(47) * lu(804)
         lu(811) = - lu(48) * lu(804)
         lu(818) = lu(818) - lu(49) * lu(804)
         lu(825) = - lu(50) * lu(804)
                                                                        
                                                                        
      end subroutine imp_lu_fac01
                                                                        
      subroutine imp_lu_fac02( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(51) = 1. / lu(51)
         lu(52) = lu(52) * lu(51)
         lu(53) = lu(53) * lu(51)
         lu(54) = lu(54) * lu(51)
         lu(285) = - lu(52) * lu(281)
         lu(293) = lu(293) - lu(53) * lu(281)
         lu(294) = - lu(54) * lu(281)
         lu(496) = lu(496) - lu(52) * lu(485)
         lu(515) = lu(515) - lu(53) * lu(485)
         lu(516) = lu(516) - lu(54) * lu(485)
         lu(780) = lu(780) - lu(52) * lu(749)
         lu(801) = lu(801) - lu(53) * lu(749)
         lu(802) = lu(802) - lu(54) * lu(749)
                                                                        
         lu(55) = 1. / lu(55)
         lu(56) = lu(56) * lu(55)
         lu(57) = lu(57) * lu(55)
         lu(58) = lu(58) * lu(55)
         lu(177) = lu(177) - lu(56) * lu(173)
         lu(180) = lu(180) - lu(57) * lu(173)
         lu(182) = - lu(58) * lu(173)
         lu(465) = lu(465) - lu(56) * lu(456)
         lu(479) = lu(479) - lu(57) * lu(456)
         lu(481) = - lu(58) * lu(456)
         lu(777) = lu(777) - lu(56) * lu(750)
         lu(797) = lu(797) - lu(57) * lu(750)
         lu(801) = lu(801) - lu(58) * lu(750)
                                                                        
         lu(59) = 1. / lu(59)
         lu(60) = lu(60) * lu(59)
         lu(61) = lu(61) * lu(59)
         lu(62) = lu(62) * lu(59)
         lu(684) = lu(684) - lu(60) * lu(648)
         lu(688) = lu(688) - lu(61) * lu(648)
         lu(689) = lu(689) - lu(62) * lu(648)
         lu(797) = lu(797) - lu(60) * lu(751)
         lu(801) = lu(801) - lu(61) * lu(751)
         lu(802) = lu(802) - lu(62) * lu(751)
         lu(824) = lu(824) - lu(60) * lu(805)
         lu(828) = lu(828) - lu(61) * lu(805)
         lu(829) = lu(829) - lu(62) * lu(805)
                                                                        
         lu(63) = 1. / lu(63)
         lu(64) = lu(64) * lu(63)
         lu(65) = lu(65) * lu(63)
         lu(66) = lu(66) * lu(63)
         lu(67) = lu(67) * lu(63)
         lu(68) = lu(68) * lu(63)
         lu(539) = - lu(64) * lu(537)
         lu(560) = lu(560) - lu(65) * lu(537)
         lu(564) = lu(564) - lu(66) * lu(537)
         lu(567) = lu(567) - lu(67) * lu(537)
         lu(568) = lu(568) - lu(68) * lu(537)
         lu(759) = lu(759) - lu(64) * lu(752)
         lu(793) = lu(793) - lu(65) * lu(752)
         lu(797) = lu(797) - lu(66) * lu(752)
         lu(800) = lu(800) - lu(67) * lu(752)
         lu(801) = lu(801) - lu(68) * lu(752)
                                                                        
         lu(69) = 1. / lu(69)
         lu(70) = lu(70) * lu(69)
         lu(71) = lu(71) * lu(69)
         lu(72) = lu(72) * lu(69)
         lu(73) = lu(73) * lu(69)
         lu(411) = lu(411) - lu(70) * lu(404)
         lu(413) = - lu(71) * lu(404)
         lu(418) = lu(418) - lu(72) * lu(404)
         lu(420) = - lu(73) * lu(404)
         lu(674) = lu(674) - lu(70) * lu(649)
         lu(676) = lu(676) - lu(71) * lu(649)
         lu(684) = lu(684) - lu(72) * lu(649)
         lu(688) = lu(688) - lu(73) * lu(649)
         lu(787) = lu(787) - lu(70) * lu(753)
         lu(789) = lu(789) - lu(71) * lu(753)
         lu(797) = lu(797) - lu(72) * lu(753)
         lu(801) = lu(801) - lu(73) * lu(753)
                                                                        
         lu(74) = 1. / lu(74)
         lu(75) = lu(75) * lu(74)
         lu(76) = lu(76) * lu(74)
         lu(77) = lu(77) * lu(74)
         lu(78) = lu(78) * lu(74)
         lu(176) = lu(176) - lu(75) * lu(174)
         lu(177) = lu(177) - lu(76) * lu(174)
         lu(180) = lu(180) - lu(77) * lu(174)
         lu(182) = lu(182) - lu(78) * lu(174)
         lu(659) = lu(659) - lu(75) * lu(650)
         lu(665) = - lu(76) * lu(650)
         lu(684) = lu(684) - lu(77) * lu(650)
         lu(688) = lu(688) - lu(78) * lu(650)
         lu(769) = lu(769) - lu(75) * lu(754)
         lu(777) = lu(777) - lu(76) * lu(754)
         lu(797) = lu(797) - lu(77) * lu(754)
         lu(801) = lu(801) - lu(78) * lu(754)
                                                                        
         lu(79) = 1. / lu(79)
         lu(80) = lu(80) * lu(79)
         lu(81) = lu(81) * lu(79)
         lu(82) = lu(82) * lu(79)
         lu(83) = lu(83) * lu(79)
         lu(216) = lu(216) - lu(80) * lu(215)
         lu(218) = lu(218) - lu(81) * lu(215)
         lu(223) = lu(223) - lu(82) * lu(215)
         lu(225) = - lu(83) * lu(215)
         lu(657) = - lu(80) * lu(651)
         lu(663) = lu(663) - lu(81) * lu(651)
         lu(684) = lu(684) - lu(82) * lu(651)
         lu(688) = lu(688) - lu(83) * lu(651)
         lu(767) = lu(767) - lu(80) * lu(755)
         lu(773) = lu(773) - lu(81) * lu(755)
         lu(797) = lu(797) - lu(82) * lu(755)
         lu(801) = lu(801) - lu(83) * lu(755)
                                                                        
         lu(84) = 1. / lu(84)
         lu(85) = lu(85) * lu(84)
         lu(86) = lu(86) * lu(84)
         lu(87) = lu(87) * lu(84)
         lu(88) = lu(88) * lu(84)
         lu(208) = lu(208) - lu(85) * lu(207)
         lu(209) = lu(209) - lu(86) * lu(207)
         lu(212) = lu(212) - lu(87) * lu(207)
         lu(213) = - lu(88) * lu(207)
         lu(662) = lu(662) - lu(85) * lu(652)
         lu(675) = lu(675) - lu(86) * lu(652)
         lu(687) = lu(687) - lu(87) * lu(652)
         lu(688) = lu(688) - lu(88) * lu(652)
         lu(772) = lu(772) - lu(85) * lu(756)
         lu(788) = lu(788) - lu(86) * lu(756)
         lu(800) = lu(800) - lu(87) * lu(756)
         lu(801) = lu(801) - lu(88) * lu(756)
                                                                        
         lu(89) = 1. / lu(89)
         lu(90) = lu(90) * lu(89)
         lu(91) = lu(91) * lu(89)
         lu(92) = lu(92) * lu(89)
         lu(93) = lu(93) * lu(89)
         lu(475) = lu(475) - lu(90) * lu(457)
         lu(479) = lu(479) - lu(91) * lu(457)
         lu(480) = lu(480) - lu(92) * lu(457)
         lu(481) = lu(481) - lu(93) * lu(457)
         lu(677) = lu(677) - lu(90) * lu(653)
         lu(684) = lu(684) - lu(91) * lu(653)
         lu(687) = lu(687) - lu(92) * lu(653)
         lu(688) = lu(688) - lu(93) * lu(653)
         lu(790) = lu(790) - lu(90) * lu(757)
         lu(797) = lu(797) - lu(91) * lu(757)
         lu(800) = lu(800) - lu(92) * lu(757)
         lu(801) = lu(801) - lu(93) * lu(757)
                                                                        
                                                                        
      end subroutine imp_lu_fac02
                                                                        
      subroutine imp_lu_fac03( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(94) = 1. / lu(94)
         lu(95) = lu(95) * lu(94)
         lu(96) = lu(96) * lu(94)
         lu(165) = lu(165) - lu(95) * lu(162)
         lu(167) = - lu(96) * lu(162)
         lu(275) = - lu(95) * lu(272)
         lu(278) = lu(278) - lu(96) * lu(272)
         lu(316) = - lu(95) * lu(312)
         lu(319) = lu(319) - lu(96) * lu(312)
         lu(522) = lu(522) - lu(95) * lu(518)
         lu(531) = lu(531) - lu(96) * lu(518)
         lu(596) = lu(596) - lu(95) * lu(589)
         lu(605) = - lu(96) * lu(589)
         lu(710) = lu(710) - lu(95) * lu(706)
         lu(719) = lu(719) - lu(96) * lu(706)
                                                                        
         lu(97) = 1. / lu(97)
         lu(98) = lu(98) * lu(97)
         lu(99) = lu(99) * lu(97)
         lu(100) = lu(100) * lu(97)
         lu(560) = lu(560) - lu(98) * lu(538)
         lu(564) = lu(564) - lu(99) * lu(538)
         lu(568) = lu(568) - lu(100) * lu(538)
         lu(578) = lu(578) - lu(98) * lu(570)
         lu(582) = lu(582) - lu(99) * lu(570)
         lu(586) = lu(586) - lu(100) * lu(570)
         lu(731) = - lu(98) * lu(724)
         lu(735) = lu(735) - lu(99) * lu(724)
         lu(739) = lu(739) - lu(100) * lu(724)
         lu(793) = lu(793) - lu(98) * lu(758)
         lu(797) = lu(797) - lu(99) * lu(758)
         lu(801) = lu(801) - lu(100) * lu(758)
                                                                        
         lu(102) = 1. / lu(102)
         lu(103) = lu(103) * lu(102)
         lu(104) = lu(104) * lu(102)
         lu(105) = lu(105) * lu(102)
         lu(106) = lu(106) * lu(102)
         lu(107) = lu(107) * lu(102)
         lu(541) = - lu(103) * lu(539)
         lu(563) = lu(563) - lu(104) * lu(539)
         lu(564) = lu(564) - lu(105) * lu(539)
         lu(567) = lu(567) - lu(106) * lu(539)
         lu(569) = lu(569) - lu(107) * lu(539)
         lu(617) = lu(617) - lu(103) * lu(612)
         lu(639) = lu(639) - lu(104) * lu(612)
         lu(640) = lu(640) - lu(105) * lu(612)
         lu(643) = lu(643) - lu(106) * lu(612)
         lu(645) = lu(645) - lu(107) * lu(612)
         lu(771) = lu(771) - lu(103) * lu(759)
         lu(796) = - lu(104) * lu(759)
         lu(797) = lu(797) - lu(105) * lu(759)
         lu(800) = lu(800) - lu(106) * lu(759)
         lu(802) = lu(802) - lu(107) * lu(759)
                                                                        
         lu(108) = 1. / lu(108)
         lu(109) = lu(109) * lu(108)
         lu(110) = lu(110) * lu(108)
         lu(111) = lu(111) * lu(108)
         lu(112) = lu(112) * lu(108)
         lu(113) = lu(113) * lu(108)
         lu(488) = lu(488) - lu(109) * lu(486)
         lu(499) = - lu(110) * lu(486)
         lu(507) = lu(507) - lu(111) * lu(486)
         lu(511) = - lu(112) * lu(486)
         lu(516) = lu(516) - lu(113) * lu(486)
         lu(592) = lu(592) - lu(109) * lu(590)
         lu(596) = lu(596) - lu(110) * lu(590)
         lu(598) = - lu(111) * lu(590)
         lu(602) = lu(602) - lu(112) * lu(590)
         lu(609) = lu(609) - lu(113) * lu(590)
         lu(809) = lu(809) - lu(109) * lu(806)
         lu(814) = - lu(110) * lu(806)
         lu(818) = lu(818) - lu(111) * lu(806)
         lu(822) = - lu(112) * lu(806)
         lu(829) = lu(829) - lu(113) * lu(806)
                                                                        
         lu(114) = 1. / lu(114)
         lu(115) = lu(115) * lu(114)
         lu(116) = lu(116) * lu(114)
         lu(117) = lu(117) * lu(114)
         lu(118) = lu(118) * lu(114)
         lu(433) = lu(433) - lu(115) * lu(422)
         lu(435) = lu(435) - lu(116) * lu(422)
         lu(440) = lu(440) - lu(117) * lu(422)
         lu(441) = - lu(118) * lu(422)
         lu(446) = lu(446) - lu(115) * lu(443)
         lu(448) = lu(448) - lu(116) * lu(443)
         lu(453) = lu(453) - lu(117) * lu(443)
         lu(454) = - lu(118) * lu(443)
         lu(675) = lu(675) - lu(115) * lu(654)
         lu(677) = lu(677) - lu(116) * lu(654)
         lu(687) = lu(687) - lu(117) * lu(654)
         lu(688) = lu(688) - lu(118) * lu(654)
         lu(788) = lu(788) - lu(115) * lu(760)
         lu(790) = lu(790) - lu(116) * lu(760)
         lu(800) = lu(800) - lu(117) * lu(760)
         lu(801) = lu(801) - lu(118) * lu(760)
                                                                        
         lu(119) = 1. / lu(119)
         lu(120) = lu(120) * lu(119)
         lu(121) = lu(121) * lu(119)
         lu(305) = - lu(120) * lu(303)
         lu(310) = lu(310) - lu(121) * lu(303)
         lu(391) = - lu(120) * lu(385)
         lu(402) = - lu(121) * lu(385)
         lu(430) = lu(430) - lu(120) * lu(423)
         lu(441) = lu(441) - lu(121) * lu(423)
         lu(470) = lu(470) - lu(120) * lu(458)
         lu(481) = lu(481) - lu(121) * lu(458)
         lu(501) = lu(501) - lu(120) * lu(487)
         lu(515) = lu(515) - lu(121) * lu(487)
         lu(552) = - lu(120) * lu(540)
         lu(568) = lu(568) - lu(121) * lu(540)
         lu(628) = lu(628) - lu(120) * lu(613)
         lu(644) = lu(644) - lu(121) * lu(613)
         lu(785) = lu(785) - lu(120) * lu(761)
         lu(801) = lu(801) - lu(121) * lu(761)
                                                                        
         lu(122) = 1. / lu(122)
         lu(123) = lu(123) * lu(122)
         lu(124) = lu(124) * lu(122)
         lu(125) = lu(125) * lu(122)
         lu(126) = lu(126) * lu(122)
         lu(127) = lu(127) * lu(122)
         lu(128) = lu(128) * lu(122)
         lu(185) = lu(185) - lu(123) * lu(184)
         lu(186) = lu(186) - lu(124) * lu(184)
         lu(187) = - lu(125) * lu(184)
         lu(189) = lu(189) - lu(126) * lu(184)
         lu(190) = lu(190) - lu(127) * lu(184)
         lu(191) = - lu(128) * lu(184)
         lu(660) = lu(660) - lu(123) * lu(655)
         lu(665) = lu(665) - lu(124) * lu(655)
         lu(668) = - lu(125) * lu(655)
         lu(684) = lu(684) - lu(126) * lu(655)
         lu(687) = lu(687) - lu(127) * lu(655)
         lu(688) = lu(688) - lu(128) * lu(655)
         lu(770) = lu(770) - lu(123) * lu(762)
         lu(777) = lu(777) - lu(124) * lu(762)
         lu(781) = lu(781) - lu(125) * lu(762)
         lu(797) = lu(797) - lu(126) * lu(762)
         lu(800) = lu(800) - lu(127) * lu(762)
         lu(801) = lu(801) - lu(128) * lu(762)
                                                                        
                                                                        
      end subroutine imp_lu_fac03
                                                                        
      subroutine imp_lu_fac04( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(129) = 1. / lu(129)
         lu(130) = lu(130) * lu(129)
         lu(131) = lu(131) * lu(129)
         lu(132) = lu(132) * lu(129)
         lu(133) = lu(133) * lu(129)
         lu(134) = lu(134) * lu(129)
         lu(135) = lu(135) * lu(129)
         lu(433) = lu(433) - lu(130) * lu(424)
         lu(435) = lu(435) - lu(131) * lu(424)
         lu(436) = - lu(132) * lu(424)
         lu(440) = lu(440) - lu(133) * lu(424)
         lu(441) = lu(441) - lu(134) * lu(424)
         lu(442) = lu(442) - lu(135) * lu(424)
         lu(788) = lu(788) - lu(130) * lu(763)
         lu(790) = lu(790) - lu(131) * lu(763)
         lu(791) = lu(791) - lu(132) * lu(763)
         lu(800) = lu(800) - lu(133) * lu(763)
         lu(801) = lu(801) - lu(134) * lu(763)
         lu(802) = lu(802) - lu(135) * lu(763)
         lu(815) = lu(815) - lu(130) * lu(807)
         lu(817) = - lu(131) * lu(807)
         lu(818) = lu(818) - lu(132) * lu(807)
         lu(827) = - lu(133) * lu(807)
         lu(828) = lu(828) - lu(134) * lu(807)
         lu(829) = lu(829) - lu(135) * lu(807)
                                                                        
         lu(136) = 1. / lu(136)
         lu(137) = lu(137) * lu(136)
         lu(138) = lu(138) * lu(136)
         lu(139) = lu(139) * lu(136)
         lu(180) = lu(180) - lu(137) * lu(175)
         lu(181) = lu(181) - lu(138) * lu(175)
         lu(182) = lu(182) - lu(139) * lu(175)
         lu(381) = lu(381) - lu(137) * lu(371)
         lu(382) = lu(382) - lu(138) * lu(371)
         lu(383) = lu(383) - lu(139) * lu(371)
         lu(400) = lu(400) - lu(137) * lu(386)
         lu(401) = lu(401) - lu(138) * lu(386)
         lu(402) = lu(402) - lu(139) * lu(386)
         lu(418) = lu(418) - lu(137) * lu(405)
         lu(419) = lu(419) - lu(138) * lu(405)
         lu(420) = lu(420) - lu(139) * lu(405)
         lu(479) = lu(479) - lu(137) * lu(459)
         lu(480) = lu(480) - lu(138) * lu(459)
         lu(481) = lu(481) - lu(139) * lu(459)
         lu(797) = lu(797) - lu(137) * lu(764)
         lu(800) = lu(800) - lu(138) * lu(764)
         lu(801) = lu(801) - lu(139) * lu(764)
                                                                        
         lu(140) = 1. / lu(140)
         lu(141) = lu(141) * lu(140)
         lu(142) = lu(142) * lu(140)
         lu(143) = lu(143) * lu(140)
         lu(144) = lu(144) * lu(140)
         lu(145) = lu(145) * lu(140)
         lu(146) = lu(146) * lu(140)
         lu(147) = lu(147) * lu(140)
         lu(445) = - lu(141) * lu(444)
         lu(447) = lu(447) - lu(142) * lu(444)
         lu(449) = lu(449) - lu(143) * lu(444)
         lu(452) = lu(452) - lu(144) * lu(444)
         lu(453) = lu(453) - lu(145) * lu(444)
         lu(454) = lu(454) - lu(146) * lu(444)
         lu(455) = lu(455) - lu(147) * lu(444)
         lu(781) = lu(781) - lu(141) * lu(765)
         lu(789) = lu(789) - lu(142) * lu(765)
         lu(791) = lu(791) - lu(143) * lu(765)
         lu(797) = lu(797) - lu(144) * lu(765)
         lu(800) = lu(800) - lu(145) * lu(765)
         lu(801) = lu(801) - lu(146) * lu(765)
         lu(802) = lu(802) - lu(147) * lu(765)
         lu(813) = - lu(141) * lu(808)
         lu(816) = lu(816) - lu(142) * lu(808)
         lu(818) = lu(818) - lu(143) * lu(808)
         lu(824) = lu(824) - lu(144) * lu(808)
         lu(827) = lu(827) - lu(145) * lu(808)
         lu(828) = lu(828) - lu(146) * lu(808)
         lu(829) = lu(829) - lu(147) * lu(808)
                                                                        
         lu(148) = 1. / lu(148)
         lu(149) = lu(149) * lu(148)
         lu(150) = lu(150) * lu(148)
         lu(151) = lu(151) * lu(148)
         lu(152) = lu(152) * lu(148)
         lu(153) = lu(153) * lu(148)
         lu(154) = lu(154) * lu(148)
         lu(155) = lu(155) * lu(148)
         lu(389) = lu(389) - lu(149) * lu(387)
         lu(390) = lu(390) - lu(150) * lu(387)
         lu(391) = lu(391) - lu(151) * lu(387)
         lu(392) = lu(392) - lu(152) * lu(387)
         lu(400) = lu(400) - lu(153) * lu(387)
         lu(401) = lu(401) - lu(154) * lu(387)
         lu(402) = lu(402) - lu(155) * lu(387)
         lu(669) = lu(669) - lu(149) * lu(656)
         lu(671) = lu(671) - lu(150) * lu(656)
         lu(672) = lu(672) - lu(151) * lu(656)
         lu(673) = lu(673) - lu(152) * lu(656)
         lu(684) = lu(684) - lu(153) * lu(656)
         lu(687) = lu(687) - lu(154) * lu(656)
         lu(688) = lu(688) - lu(155) * lu(656)
         lu(782) = lu(782) - lu(149) * lu(766)
         lu(784) = lu(784) - lu(150) * lu(766)
         lu(785) = lu(785) - lu(151) * lu(766)
         lu(786) = lu(786) - lu(152) * lu(766)
         lu(797) = lu(797) - lu(153) * lu(766)
         lu(800) = lu(800) - lu(154) * lu(766)
         lu(801) = lu(801) - lu(155) * lu(766)
                                                                        
         lu(156) = 1. / lu(156)
         lu(157) = lu(157) * lu(156)
         lu(158) = lu(158) * lu(156)
         lu(159) = lu(159) * lu(156)
         lu(160) = lu(160) * lu(156)
         lu(217) = - lu(157) * lu(216)
         lu(220) = - lu(158) * lu(216)
         lu(221) = lu(221) - lu(159) * lu(216)
         lu(225) = lu(225) - lu(160) * lu(216)
         lu(256) = - lu(157) * lu(255)
         lu(262) = - lu(158) * lu(255)
         lu(263) = - lu(159) * lu(255)
         lu(270) = lu(270) - lu(160) * lu(255)
         lu(463) = - lu(157) * lu(460)
         lu(473) = lu(473) - lu(158) * lu(460)
         lu(475) = lu(475) - lu(159) * lu(460)
         lu(481) = lu(481) - lu(160) * lu(460)
         lu(619) = lu(619) - lu(157) * lu(614)
         lu(631) = lu(631) - lu(158) * lu(614)
         lu(633) = lu(633) - lu(159) * lu(614)
         lu(644) = lu(644) - lu(160) * lu(614)
         lu(662) = lu(662) - lu(157) * lu(657)
         lu(675) = lu(675) - lu(158) * lu(657)
         lu(677) = lu(677) - lu(159) * lu(657)
         lu(688) = lu(688) - lu(160) * lu(657)
         lu(772) = lu(772) - lu(157) * lu(767)
         lu(788) = lu(788) - lu(158) * lu(767)
         lu(790) = lu(790) - lu(159) * lu(767)
         lu(801) = lu(801) - lu(160) * lu(767)
                                                                        
         lu(163) = 1. / lu(163)
         lu(164) = lu(164) * lu(163)
         lu(165) = lu(165) * lu(163)
         lu(166) = lu(166) * lu(163)
         lu(167) = lu(167) * lu(163)
         lu(168) = lu(168) * lu(163)
         lu(231) = - lu(164) * lu(228)
         lu(232) = lu(232) - lu(165) * lu(228)
         lu(236) = lu(236) - lu(166) * lu(228)
         lu(237) = - lu(167) * lu(228)
         lu(238) = - lu(168) * lu(228)
         lu(315) = lu(315) - lu(164) * lu(313)
         lu(316) = lu(316) - lu(165) * lu(313)
         lu(318) = - lu(166) * lu(313)
         lu(319) = lu(319) - lu(167) * lu(313)
         lu(321) = lu(321) - lu(168) * lu(313)
         lu(521) = - lu(164) * lu(519)
         lu(522) = lu(522) - lu(165) * lu(519)
         lu(528) = lu(528) - lu(166) * lu(519)
         lu(531) = lu(531) - lu(167) * lu(519)
         lu(534) = lu(534) - lu(168) * lu(519)
         lu(595) = - lu(164) * lu(591)
         lu(596) = lu(596) - lu(165) * lu(591)
         lu(602) = lu(602) - lu(166) * lu(591)
         lu(605) = lu(605) - lu(167) * lu(591)
         lu(608) = lu(608) - lu(168) * lu(591)
         lu(667) = lu(667) - lu(164) * lu(658)
         lu(670) = lu(670) - lu(165) * lu(658)
         lu(682) = lu(682) - lu(166) * lu(658)
         lu(685) = lu(685) - lu(167) * lu(658)
         lu(688) = lu(688) - lu(168) * lu(658)
                                                                        
                                                                        
      end subroutine imp_lu_fac04
                                                                        
      subroutine imp_lu_fac05( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(169) = 1. / lu(169)
         lu(170) = lu(170) * lu(169)
         lu(171) = lu(171) * lu(169)
         lu(172) = lu(172) * lu(169)
         lu(233) = lu(233) - lu(170) * lu(229)
         lu(238) = lu(238) - lu(171) * lu(229)
         lu(239) = - lu(172) * lu(229)
         lu(299) = lu(299) - lu(170) * lu(295)
         lu(301) = lu(301) - lu(171) * lu(295)
         lu(302) = - lu(172) * lu(295)
         lu(325) = lu(325) - lu(170) * lu(322)
         lu(327) = lu(327) - lu(171) * lu(322)
         lu(328) = - lu(172) * lu(322)
         lu(507) = lu(507) - lu(170) * lu(488)
         lu(515) = lu(515) - lu(171) * lu(488)
         lu(516) = lu(516) - lu(172) * lu(488)
         lu(598) = lu(598) - lu(170) * lu(592)
         lu(608) = lu(608) - lu(171) * lu(592)
         lu(609) = lu(609) - lu(172) * lu(592)
         lu(712) = lu(712) - lu(170) * lu(707)
         lu(722) = - lu(171) * lu(707)
         lu(723) = lu(723) - lu(172) * lu(707)
         lu(729) = lu(729) - lu(170) * lu(725)
         lu(739) = lu(739) - lu(171) * lu(725)
         lu(740) = - lu(172) * lu(725)
         lu(791) = lu(791) - lu(170) * lu(768)
         lu(801) = lu(801) - lu(171) * lu(768)
         lu(802) = lu(802) - lu(172) * lu(768)
         lu(818) = lu(818) - lu(170) * lu(809)
         lu(828) = lu(828) - lu(171) * lu(809)
         lu(829) = lu(829) - lu(172) * lu(809)
                                                                        
         lu(176) = 1. / lu(176)
         lu(177) = lu(177) * lu(176)
         lu(178) = lu(178) * lu(176)
         lu(179) = lu(179) * lu(176)
         lu(180) = lu(180) * lu(176)
         lu(181) = lu(181) * lu(176)
         lu(182) = lu(182) * lu(176)
         lu(183) = lu(183) * lu(176)
         lu(465) = lu(465) - lu(177) * lu(461)
         lu(475) = lu(475) - lu(178) * lu(461)
         lu(478) = lu(478) - lu(179) * lu(461)
         lu(479) = lu(479) - lu(180) * lu(461)
         lu(480) = lu(480) - lu(181) * lu(461)
         lu(481) = lu(481) - lu(182) * lu(461)
         lu(482) = lu(482) - lu(183) * lu(461)
         lu(621) = lu(621) - lu(177) * lu(615)
         lu(633) = lu(633) - lu(178) * lu(615)
         lu(639) = lu(639) - lu(179) * lu(615)
         lu(640) = lu(640) - lu(180) * lu(615)
         lu(643) = lu(643) - lu(181) * lu(615)
         lu(644) = lu(644) - lu(182) * lu(615)
         lu(645) = lu(645) - lu(183) * lu(615)
         lu(665) = lu(665) - lu(177) * lu(659)
         lu(677) = lu(677) - lu(178) * lu(659)
         lu(683) = lu(683) - lu(179) * lu(659)
         lu(684) = lu(684) - lu(180) * lu(659)
         lu(687) = lu(687) - lu(181) * lu(659)
         lu(688) = lu(688) - lu(182) * lu(659)
         lu(689) = lu(689) - lu(183) * lu(659)
         lu(777) = lu(777) - lu(177) * lu(769)
         lu(790) = lu(790) - lu(178) * lu(769)
         lu(796) = lu(796) - lu(179) * lu(769)
         lu(797) = lu(797) - lu(180) * lu(769)
         lu(800) = lu(800) - lu(181) * lu(769)
         lu(801) = lu(801) - lu(182) * lu(769)
         lu(802) = lu(802) - lu(183) * lu(769)
                                                                        
         lu(185) = 1. / lu(185)
         lu(186) = lu(186) * lu(185)
         lu(187) = lu(187) * lu(185)
         lu(188) = lu(188) * lu(185)
         lu(189) = lu(189) * lu(185)
         lu(190) = lu(190) * lu(185)
         lu(191) = lu(191) * lu(185)
         lu(192) = lu(192) * lu(185)
         lu(284) = lu(284) - lu(186) * lu(282)
         lu(286) = - lu(187) * lu(282)
         lu(290) = - lu(188) * lu(282)
         lu(291) = lu(291) - lu(189) * lu(282)
         lu(292) = lu(292) - lu(190) * lu(282)
         lu(293) = lu(293) - lu(191) * lu(282)
         lu(294) = lu(294) - lu(192) * lu(282)
         lu(621) = lu(621) - lu(186) * lu(616)
         lu(624) = lu(624) - lu(187) * lu(616)
         lu(639) = lu(639) - lu(188) * lu(616)
         lu(640) = lu(640) - lu(189) * lu(616)
         lu(643) = lu(643) - lu(190) * lu(616)
         lu(644) = lu(644) - lu(191) * lu(616)
         lu(645) = lu(645) - lu(192) * lu(616)
         lu(665) = lu(665) - lu(186) * lu(660)
         lu(668) = lu(668) - lu(187) * lu(660)
         lu(683) = lu(683) - lu(188) * lu(660)
         lu(684) = lu(684) - lu(189) * lu(660)
         lu(687) = lu(687) - lu(190) * lu(660)
         lu(688) = lu(688) - lu(191) * lu(660)
         lu(689) = lu(689) - lu(192) * lu(660)
         lu(777) = lu(777) - lu(186) * lu(770)
         lu(781) = lu(781) - lu(187) * lu(770)
         lu(796) = lu(796) - lu(188) * lu(770)
         lu(797) = lu(797) - lu(189) * lu(770)
         lu(800) = lu(800) - lu(190) * lu(770)
         lu(801) = lu(801) - lu(191) * lu(770)
         lu(802) = lu(802) - lu(192) * lu(770)
                                                                        
         lu(193) = 1. / lu(193)
         lu(194) = lu(194) * lu(193)
         lu(195) = lu(195) * lu(193)
         lu(196) = lu(196) * lu(193)
         lu(197) = lu(197) * lu(193)
         lu(377) = - lu(194) * lu(372)
         lu(381) = lu(381) - lu(195) * lu(372)
         lu(382) = lu(382) - lu(196) * lu(372)
         lu(383) = lu(383) - lu(197) * lu(372)
         lu(413) = lu(413) - lu(194) * lu(406)
         lu(418) = lu(418) - lu(195) * lu(406)
         lu(419) = lu(419) - lu(196) * lu(406)
         lu(420) = lu(420) - lu(197) * lu(406)
         lu(434) = lu(434) - lu(194) * lu(425)
         lu(439) = lu(439) - lu(195) * lu(425)
         lu(440) = lu(440) - lu(196) * lu(425)
         lu(441) = lu(441) - lu(197) * lu(425)
         lu(474) = lu(474) - lu(194) * lu(462)
         lu(479) = lu(479) - lu(195) * lu(462)
         lu(480) = lu(480) - lu(196) * lu(462)
         lu(481) = lu(481) - lu(197) * lu(462)
         lu(505) = lu(505) - lu(194) * lu(489)
         lu(513) = lu(513) - lu(195) * lu(489)
         lu(514) = lu(514) - lu(196) * lu(489)
         lu(515) = lu(515) - lu(197) * lu(489)
         lu(556) = lu(556) - lu(194) * lu(541)
         lu(564) = lu(564) - lu(195) * lu(541)
         lu(567) = lu(567) - lu(196) * lu(541)
         lu(568) = lu(568) - lu(197) * lu(541)
         lu(632) = lu(632) - lu(194) * lu(617)
         lu(640) = lu(640) - lu(195) * lu(617)
         lu(643) = lu(643) - lu(196) * lu(617)
         lu(644) = lu(644) - lu(197) * lu(617)
         lu(789) = lu(789) - lu(194) * lu(771)
         lu(797) = lu(797) - lu(195) * lu(771)
         lu(800) = lu(800) - lu(196) * lu(771)
         lu(801) = lu(801) - lu(197) * lu(771)
                                                                        
         lu(198) = 1. / lu(198)
         lu(199) = lu(199) * lu(198)
         lu(200) = lu(200) * lu(198)
         lu(201) = lu(201) * lu(198)
         lu(202) = lu(202) * lu(198)
         lu(203) = lu(203) * lu(198)
         lu(204) = lu(204) * lu(198)
         lu(205) = lu(205) * lu(198)
         lu(206) = lu(206) * lu(198)
         lu(243) = - lu(199) * lu(240)
         lu(244) = lu(244) - lu(200) * lu(240)
         lu(245) = lu(245) - lu(201) * lu(240)
         lu(248) = lu(248) - lu(202) * lu(240)
         lu(250) = - lu(203) * lu(240)
         lu(251) = lu(251) - lu(204) * lu(240)
         lu(252) = lu(252) - lu(205) * lu(240)
         lu(254) = - lu(206) * lu(240)
         lu(495) = lu(495) - lu(199) * lu(490)
         lu(498) = lu(498) - lu(200) * lu(490)
         lu(500) = lu(500) - lu(201) * lu(490)
         lu(507) = lu(507) - lu(202) * lu(490)
         lu(512) = lu(512) - lu(203) * lu(490)
         lu(513) = lu(513) - lu(204) * lu(490)
         lu(514) = lu(514) - lu(205) * lu(490)
         lu(516) = lu(516) - lu(206) * lu(490)
         lu(622) = lu(622) - lu(199) * lu(618)
         lu(625) = lu(625) - lu(200) * lu(618)
         lu(627) = lu(627) - lu(201) * lu(618)
         lu(634) = lu(634) - lu(202) * lu(618)
         lu(639) = lu(639) - lu(203) * lu(618)
         lu(640) = lu(640) - lu(204) * lu(618)
         lu(643) = lu(643) - lu(205) * lu(618)
         lu(645) = lu(645) - lu(206) * lu(618)
         lu(666) = lu(666) - lu(199) * lu(661)
         lu(669) = lu(669) - lu(200) * lu(661)
         lu(671) = lu(671) - lu(201) * lu(661)
         lu(678) = lu(678) - lu(202) * lu(661)
         lu(683) = lu(683) - lu(203) * lu(661)
         lu(684) = lu(684) - lu(204) * lu(661)
         lu(687) = lu(687) - lu(205) * lu(661)
         lu(689) = lu(689) - lu(206) * lu(661)
                                                                        
         lu(208) = 1. / lu(208)
         lu(209) = lu(209) * lu(208)
         lu(210) = lu(210) * lu(208)
         lu(211) = lu(211) * lu(208)
         lu(212) = lu(212) * lu(208)
         lu(213) = lu(213) * lu(208)
         lu(214) = lu(214) * lu(208)
         lu(220) = lu(220) - lu(209) * lu(217)
         lu(222) = lu(222) - lu(210) * lu(217)
         lu(223) = lu(223) - lu(211) * lu(217)
         lu(224) = lu(224) - lu(212) * lu(217)
         lu(225) = lu(225) - lu(213) * lu(217)
         lu(226) = lu(226) - lu(214) * lu(217)
         lu(262) = lu(262) - lu(209) * lu(256)
         lu(267) = - lu(210) * lu(256)
         lu(268) = lu(268) - lu(211) * lu(256)
         lu(269) = lu(269) - lu(212) * lu(256)
         lu(270) = lu(270) - lu(213) * lu(256)
         lu(271) = lu(271) - lu(214) * lu(256)
         lu(473) = lu(473) - lu(209) * lu(463)
         lu(478) = lu(478) - lu(210) * lu(463)
         lu(479) = lu(479) - lu(211) * lu(463)
         lu(480) = lu(480) - lu(212) * lu(463)
         lu(481) = lu(481) - lu(213) * lu(463)
         lu(482) = lu(482) - lu(214) * lu(463)
         lu(631) = lu(631) - lu(209) * lu(619)
         lu(639) = lu(639) - lu(210) * lu(619)
         lu(640) = lu(640) - lu(211) * lu(619)
         lu(643) = lu(643) - lu(212) * lu(619)
         lu(644) = lu(644) - lu(213) * lu(619)
         lu(645) = lu(645) - lu(214) * lu(619)
         lu(675) = lu(675) - lu(209) * lu(662)
         lu(683) = lu(683) - lu(210) * lu(662)
         lu(684) = lu(684) - lu(211) * lu(662)
         lu(687) = lu(687) - lu(212) * lu(662)
         lu(688) = lu(688) - lu(213) * lu(662)
         lu(689) = lu(689) - lu(214) * lu(662)
         lu(788) = lu(788) - lu(209) * lu(772)
         lu(796) = lu(796) - lu(210) * lu(772)
         lu(797) = lu(797) - lu(211) * lu(772)
         lu(800) = lu(800) - lu(212) * lu(772)
         lu(801) = lu(801) - lu(213) * lu(772)
         lu(802) = lu(802) - lu(214) * lu(772)
                                                                        
                                                                        
      end subroutine imp_lu_fac05
                                                                        
      subroutine imp_lu_fac06( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(218) = 1. / lu(218)
         lu(219) = lu(219) * lu(218)
         lu(220) = lu(220) * lu(218)
         lu(221) = lu(221) * lu(218)
         lu(222) = lu(222) * lu(218)
         lu(223) = lu(223) * lu(218)
         lu(224) = lu(224) * lu(218)
         lu(225) = lu(225) * lu(218)
         lu(226) = lu(226) * lu(218)
         lu(465) = lu(465) - lu(219) * lu(464)
         lu(473) = lu(473) - lu(220) * lu(464)
         lu(475) = lu(475) - lu(221) * lu(464)
         lu(478) = lu(478) - lu(222) * lu(464)
         lu(479) = lu(479) - lu(223) * lu(464)
         lu(480) = lu(480) - lu(224) * lu(464)
         lu(481) = lu(481) - lu(225) * lu(464)
         lu(482) = lu(482) - lu(226) * lu(464)
         lu(621) = lu(621) - lu(219) * lu(620)
         lu(631) = lu(631) - lu(220) * lu(620)
         lu(633) = lu(633) - lu(221) * lu(620)
         lu(639) = lu(639) - lu(222) * lu(620)
         lu(640) = lu(640) - lu(223) * lu(620)
         lu(643) = lu(643) - lu(224) * lu(620)
         lu(644) = lu(644) - lu(225) * lu(620)
         lu(645) = lu(645) - lu(226) * lu(620)
         lu(665) = lu(665) - lu(219) * lu(663)
         lu(675) = lu(675) - lu(220) * lu(663)
         lu(677) = lu(677) - lu(221) * lu(663)
         lu(683) = lu(683) - lu(222) * lu(663)
         lu(684) = lu(684) - lu(223) * lu(663)
         lu(687) = lu(687) - lu(224) * lu(663)
         lu(688) = lu(688) - lu(225) * lu(663)
         lu(689) = lu(689) - lu(226) * lu(663)
         lu(777) = lu(777) - lu(219) * lu(773)
         lu(788) = lu(788) - lu(220) * lu(773)
         lu(790) = lu(790) - lu(221) * lu(773)
         lu(796) = lu(796) - lu(222) * lu(773)
         lu(797) = lu(797) - lu(223) * lu(773)
         lu(800) = lu(800) - lu(224) * lu(773)
         lu(801) = lu(801) - lu(225) * lu(773)
         lu(802) = lu(802) - lu(226) * lu(773)
                                                                        
         lu(230) = 1. / lu(230)
         lu(231) = lu(231) * lu(230)
         lu(232) = lu(232) * lu(230)
         lu(233) = lu(233) * lu(230)
         lu(234) = lu(234) * lu(230)
         lu(235) = lu(235) * lu(230)
         lu(236) = lu(236) * lu(230)
         lu(237) = lu(237) * lu(230)
         lu(238) = lu(238) * lu(230)
         lu(239) = lu(239) * lu(230)
         lu(521) = lu(521) - lu(231) * lu(520)
         lu(522) = lu(522) - lu(232) * lu(520)
         lu(524) = - lu(233) * lu(520)
         lu(525) = lu(525) - lu(234) * lu(520)
         lu(527) = lu(527) - lu(235) * lu(520)
         lu(528) = lu(528) - lu(236) * lu(520)
         lu(531) = lu(531) - lu(237) * lu(520)
         lu(534) = lu(534) - lu(238) * lu(520)
         lu(535) = lu(535) - lu(239) * lu(520)
         lu(573) = - lu(231) * lu(571)
         lu(574) = lu(574) - lu(232) * lu(571)
         lu(576) = lu(576) - lu(233) * lu(571)
         lu(577) = lu(577) - lu(234) * lu(571)
         lu(579) = lu(579) - lu(235) * lu(571)
         lu(580) = - lu(236) * lu(571)
         lu(583) = - lu(237) * lu(571)
         lu(586) = lu(586) - lu(238) * lu(571)
         lu(587) = lu(587) - lu(239) * lu(571)
         lu(595) = lu(595) - lu(231) * lu(593)
         lu(596) = lu(596) - lu(232) * lu(593)
         lu(598) = lu(598) - lu(233) * lu(593)
         lu(599) = - lu(234) * lu(593)
         lu(601) = - lu(235) * lu(593)
         lu(602) = lu(602) - lu(236) * lu(593)
         lu(605) = lu(605) - lu(237) * lu(593)
         lu(608) = lu(608) - lu(238) * lu(593)
         lu(609) = lu(609) - lu(239) * lu(593)
         lu(812) = - lu(231) * lu(810)
         lu(814) = lu(814) - lu(232) * lu(810)
         lu(818) = lu(818) - lu(233) * lu(810)
         lu(819) = lu(819) - lu(234) * lu(810)
         lu(821) = lu(821) - lu(235) * lu(810)
         lu(822) = lu(822) - lu(236) * lu(810)
         lu(825) = lu(825) - lu(237) * lu(810)
         lu(828) = lu(828) - lu(238) * lu(810)
         lu(829) = lu(829) - lu(239) * lu(810)
                                                                        
         lu(241) = 1. / lu(241)
         lu(242) = lu(242) * lu(241)
         lu(243) = lu(243) * lu(241)
         lu(244) = lu(244) * lu(241)
         lu(245) = lu(245) * lu(241)
         lu(246) = lu(246) * lu(241)
         lu(247) = lu(247) * lu(241)
         lu(248) = lu(248) * lu(241)
         lu(249) = lu(249) * lu(241)
         lu(250) = lu(250) * lu(241)
         lu(251) = lu(251) * lu(241)
         lu(252) = lu(252) * lu(241)
         lu(253) = lu(253) * lu(241)
         lu(254) = lu(254) * lu(241)
         lu(493) = lu(493) - lu(242) * lu(491)
         lu(495) = lu(495) - lu(243) * lu(491)
         lu(498) = lu(498) - lu(244) * lu(491)
         lu(500) = lu(500) - lu(245) * lu(491)
         lu(502) = lu(502) - lu(246) * lu(491)
         lu(505) = lu(505) - lu(247) * lu(491)
         lu(507) = lu(507) - lu(248) * lu(491)
         lu(509) = - lu(249) * lu(491)
         lu(512) = lu(512) - lu(250) * lu(491)
         lu(513) = lu(513) - lu(251) * lu(491)
         lu(514) = lu(514) - lu(252) * lu(491)
         lu(515) = lu(515) - lu(253) * lu(491)
         lu(516) = lu(516) - lu(254) * lu(491)
         lu(544) = lu(544) - lu(242) * lu(542)
         lu(546) = lu(546) - lu(243) * lu(542)
         lu(549) = lu(549) - lu(244) * lu(542)
         lu(551) = lu(551) - lu(245) * lu(542)
         lu(553) = - lu(246) * lu(542)
         lu(556) = lu(556) - lu(247) * lu(542)
         lu(558) = lu(558) - lu(248) * lu(542)
         lu(560) = lu(560) - lu(249) * lu(542)
         lu(563) = lu(563) - lu(250) * lu(542)
         lu(564) = lu(564) - lu(251) * lu(542)
         lu(567) = lu(567) - lu(252) * lu(542)
         lu(568) = lu(568) - lu(253) * lu(542)
         lu(569) = lu(569) - lu(254) * lu(542)
         lu(776) = lu(776) - lu(242) * lu(774)
         lu(778) = lu(778) - lu(243) * lu(774)
         lu(782) = lu(782) - lu(244) * lu(774)
         lu(784) = lu(784) - lu(245) * lu(774)
         lu(786) = lu(786) - lu(246) * lu(774)
         lu(789) = lu(789) - lu(247) * lu(774)
         lu(791) = lu(791) - lu(248) * lu(774)
         lu(793) = lu(793) - lu(249) * lu(774)
         lu(796) = lu(796) - lu(250) * lu(774)
         lu(797) = lu(797) - lu(251) * lu(774)
         lu(800) = lu(800) - lu(252) * lu(774)
         lu(801) = lu(801) - lu(253) * lu(774)
         lu(802) = lu(802) - lu(254) * lu(774)
                                                                        
         lu(257) = 1. / lu(257)
         lu(258) = lu(258) * lu(257)
         lu(259) = lu(259) * lu(257)
         lu(260) = lu(260) * lu(257)
         lu(261) = lu(261) * lu(257)
         lu(262) = lu(262) * lu(257)
         lu(263) = lu(263) * lu(257)
         lu(264) = lu(264) * lu(257)
         lu(265) = lu(265) * lu(257)
         lu(266) = lu(266) * lu(257)
         lu(267) = lu(267) * lu(257)
         lu(268) = lu(268) * lu(257)
         lu(269) = lu(269) * lu(257)
         lu(270) = lu(270) * lu(257)
         lu(271) = lu(271) * lu(257)
         lu(493) = lu(493) - lu(258) * lu(492)
         lu(498) = lu(498) - lu(259) * lu(492)
         lu(500) = lu(500) - lu(260) * lu(492)
         lu(502) = lu(502) - lu(261) * lu(492)
         lu(504) = lu(504) - lu(262) * lu(492)
         lu(506) = - lu(263) * lu(492)
         lu(507) = lu(507) - lu(264) * lu(492)
         lu(509) = lu(509) - lu(265) * lu(492)
         lu(510) = lu(510) - lu(266) * lu(492)
         lu(512) = lu(512) - lu(267) * lu(492)
         lu(513) = lu(513) - lu(268) * lu(492)
         lu(514) = lu(514) - lu(269) * lu(492)
         lu(515) = lu(515) - lu(270) * lu(492)
         lu(516) = lu(516) - lu(271) * lu(492)
         lu(544) = lu(544) - lu(258) * lu(543)
         lu(549) = lu(549) - lu(259) * lu(543)
         lu(551) = lu(551) - lu(260) * lu(543)
         lu(553) = lu(553) - lu(261) * lu(543)
         lu(555) = - lu(262) * lu(543)
         lu(557) = lu(557) - lu(263) * lu(543)
         lu(558) = lu(558) - lu(264) * lu(543)
         lu(560) = lu(560) - lu(265) * lu(543)
         lu(561) = lu(561) - lu(266) * lu(543)
         lu(563) = lu(563) - lu(267) * lu(543)
         lu(564) = lu(564) - lu(268) * lu(543)
         lu(567) = lu(567) - lu(269) * lu(543)
         lu(568) = lu(568) - lu(270) * lu(543)
         lu(569) = lu(569) - lu(271) * lu(543)
         lu(776) = lu(776) - lu(258) * lu(775)
         lu(782) = lu(782) - lu(259) * lu(775)
         lu(784) = lu(784) - lu(260) * lu(775)
         lu(786) = lu(786) - lu(261) * lu(775)
         lu(788) = lu(788) - lu(262) * lu(775)
         lu(790) = lu(790) - lu(263) * lu(775)
         lu(791) = lu(791) - lu(264) * lu(775)
         lu(793) = lu(793) - lu(265) * lu(775)
         lu(794) = lu(794) - lu(266) * lu(775)
         lu(796) = lu(796) - lu(267) * lu(775)
         lu(797) = lu(797) - lu(268) * lu(775)
         lu(800) = lu(800) - lu(269) * lu(775)
         lu(801) = lu(801) - lu(270) * lu(775)
         lu(802) = lu(802) - lu(271) * lu(775)
                                                                        
                                                                        
      end subroutine imp_lu_fac06
                                                                        
      subroutine imp_lu_fac07( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(273) = 1. / lu(273)
         lu(274) = lu(274) * lu(273)
         lu(275) = lu(275) * lu(273)
         lu(276) = lu(276) * lu(273)
         lu(277) = lu(277) * lu(273)
         lu(278) = lu(278) * lu(273)
         lu(279) = lu(279) * lu(273)
         lu(280) = lu(280) * lu(273)
         lu(315) = lu(315) - lu(274) * lu(314)
         lu(316) = lu(316) - lu(275) * lu(314)
         lu(317) = - lu(276) * lu(314)
         lu(318) = lu(318) - lu(277) * lu(314)
         lu(319) = lu(319) - lu(278) * lu(314)
         lu(320) = - lu(279) * lu(314)
         lu(321) = lu(321) - lu(280) * lu(314)
         lu(573) = lu(573) - lu(274) * lu(572)
         lu(574) = lu(574) - lu(275) * lu(572)
         lu(579) = lu(579) - lu(276) * lu(572)
         lu(580) = lu(580) - lu(277) * lu(572)
         lu(583) = lu(583) - lu(278) * lu(572)
         lu(584) = lu(584) - lu(279) * lu(572)
         lu(586) = lu(586) - lu(280) * lu(572)
         lu(595) = lu(595) - lu(274) * lu(594)
         lu(596) = lu(596) - lu(275) * lu(594)
         lu(601) = lu(601) - lu(276) * lu(594)
         lu(602) = lu(602) - lu(277) * lu(594)
         lu(605) = lu(605) - lu(278) * lu(594)
         lu(606) = - lu(279) * lu(594)
         lu(608) = lu(608) - lu(280) * lu(594)
         lu(667) = lu(667) - lu(274) * lu(664)
         lu(670) = lu(670) - lu(275) * lu(664)
         lu(681) = lu(681) - lu(276) * lu(664)
         lu(682) = lu(682) - lu(277) * lu(664)
         lu(685) = lu(685) - lu(278) * lu(664)
         lu(686) = lu(686) - lu(279) * lu(664)
         lu(688) = lu(688) - lu(280) * lu(664)
         lu(709) = - lu(274) * lu(708)
         lu(710) = lu(710) - lu(275) * lu(708)
         lu(715) = lu(715) - lu(276) * lu(708)
         lu(716) = - lu(277) * lu(708)
         lu(719) = lu(719) - lu(278) * lu(708)
         lu(720) = lu(720) - lu(279) * lu(708)
         lu(722) = lu(722) - lu(280) * lu(708)
         lu(812) = lu(812) - lu(274) * lu(811)
         lu(814) = lu(814) - lu(275) * lu(811)
         lu(821) = lu(821) - lu(276) * lu(811)
         lu(822) = lu(822) - lu(277) * lu(811)
         lu(825) = lu(825) - lu(278) * lu(811)
         lu(826) = lu(826) - lu(279) * lu(811)
         lu(828) = lu(828) - lu(280) * lu(811)
                                                                        
         lu(283) = 1. / lu(283)
         lu(284) = lu(284) * lu(283)
         lu(285) = lu(285) * lu(283)
         lu(286) = lu(286) * lu(283)
         lu(287) = lu(287) * lu(283)
         lu(288) = lu(288) * lu(283)
         lu(289) = lu(289) * lu(283)
         lu(290) = lu(290) * lu(283)
         lu(291) = lu(291) * lu(283)
         lu(292) = lu(292) * lu(283)
         lu(293) = lu(293) * lu(283)
         lu(294) = lu(294) * lu(283)
         lu(356) = lu(356) - lu(284) * lu(355)
         lu(357) = lu(357) - lu(285) * lu(355)
         lu(358) = - lu(286) * lu(355)
         lu(362) = lu(362) - lu(287) * lu(355)
         lu(363) = - lu(288) * lu(355)
         lu(364) = lu(364) - lu(289) * lu(355)
         lu(365) = - lu(290) * lu(355)
         lu(366) = lu(366) - lu(291) * lu(355)
         lu(367) = lu(367) - lu(292) * lu(355)
         lu(368) = lu(368) - lu(293) * lu(355)
         lu(369) = - lu(294) * lu(355)
         lu(494) = lu(494) - lu(284) * lu(493)
         lu(496) = lu(496) - lu(285) * lu(493)
         lu(497) = lu(497) - lu(286) * lu(493)
         lu(506) = lu(506) - lu(287) * lu(493)
         lu(507) = lu(507) - lu(288) * lu(493)
         lu(509) = lu(509) - lu(289) * lu(493)
         lu(512) = lu(512) - lu(290) * lu(493)
         lu(513) = lu(513) - lu(291) * lu(493)
         lu(514) = lu(514) - lu(292) * lu(493)
         lu(515) = lu(515) - lu(293) * lu(493)
         lu(516) = lu(516) - lu(294) * lu(493)
         lu(545) = lu(545) - lu(284) * lu(544)
         lu(547) = lu(547) - lu(285) * lu(544)
         lu(548) = - lu(286) * lu(544)
         lu(557) = lu(557) - lu(287) * lu(544)
         lu(558) = lu(558) - lu(288) * lu(544)
         lu(560) = lu(560) - lu(289) * lu(544)
         lu(563) = lu(563) - lu(290) * lu(544)
         lu(564) = lu(564) - lu(291) * lu(544)
         lu(567) = lu(567) - lu(292) * lu(544)
         lu(568) = lu(568) - lu(293) * lu(544)
         lu(569) = lu(569) - lu(294) * lu(544)
         lu(777) = lu(777) - lu(284) * lu(776)
         lu(780) = lu(780) - lu(285) * lu(776)
         lu(781) = lu(781) - lu(286) * lu(776)
         lu(790) = lu(790) - lu(287) * lu(776)
         lu(791) = lu(791) - lu(288) * lu(776)
         lu(793) = lu(793) - lu(289) * lu(776)
         lu(796) = lu(796) - lu(290) * lu(776)
         lu(797) = lu(797) - lu(291) * lu(776)
         lu(800) = lu(800) - lu(292) * lu(776)
         lu(801) = lu(801) - lu(293) * lu(776)
         lu(802) = lu(802) - lu(294) * lu(776)
                                                                        
         lu(296) = 1. / lu(296)
         lu(297) = lu(297) * lu(296)
         lu(298) = lu(298) * lu(296)
         lu(299) = lu(299) * lu(296)
         lu(300) = lu(300) * lu(296)
         lu(301) = lu(301) * lu(296)
         lu(302) = lu(302) * lu(296)
         lu(361) = lu(361) - lu(297) * lu(356)
         lu(362) = lu(362) - lu(298) * lu(356)
         lu(363) = lu(363) - lu(299) * lu(356)
         lu(366) = lu(366) - lu(300) * lu(356)
         lu(368) = lu(368) - lu(301) * lu(356)
         lu(369) = lu(369) - lu(302) * lu(356)
         lu(473) = lu(473) - lu(297) * lu(465)
         lu(475) = lu(475) - lu(298) * lu(465)
         lu(476) = - lu(299) * lu(465)
         lu(479) = lu(479) - lu(300) * lu(465)
         lu(481) = lu(481) - lu(301) * lu(465)
         lu(482) = lu(482) - lu(302) * lu(465)
         lu(504) = lu(504) - lu(297) * lu(494)
         lu(506) = lu(506) - lu(298) * lu(494)
         lu(507) = lu(507) - lu(299) * lu(494)
         lu(513) = lu(513) - lu(300) * lu(494)
         lu(515) = lu(515) - lu(301) * lu(494)
         lu(516) = lu(516) - lu(302) * lu(494)
         lu(555) = lu(555) - lu(297) * lu(545)
         lu(557) = lu(557) - lu(298) * lu(545)
         lu(558) = lu(558) - lu(299) * lu(545)
         lu(564) = lu(564) - lu(300) * lu(545)
         lu(568) = lu(568) - lu(301) * lu(545)
         lu(569) = lu(569) - lu(302) * lu(545)
         lu(631) = lu(631) - lu(297) * lu(621)
         lu(633) = lu(633) - lu(298) * lu(621)
         lu(634) = lu(634) - lu(299) * lu(621)
         lu(640) = lu(640) - lu(300) * lu(621)
         lu(644) = lu(644) - lu(301) * lu(621)
         lu(645) = lu(645) - lu(302) * lu(621)
         lu(675) = lu(675) - lu(297) * lu(665)
         lu(677) = lu(677) - lu(298) * lu(665)
         lu(678) = lu(678) - lu(299) * lu(665)
         lu(684) = lu(684) - lu(300) * lu(665)
         lu(688) = lu(688) - lu(301) * lu(665)
         lu(689) = lu(689) - lu(302) * lu(665)
         lu(788) = lu(788) - lu(297) * lu(777)
         lu(790) = lu(790) - lu(298) * lu(777)
         lu(791) = lu(791) - lu(299) * lu(777)
         lu(797) = lu(797) - lu(300) * lu(777)
         lu(801) = lu(801) - lu(301) * lu(777)
         lu(802) = lu(802) - lu(302) * lu(777)
                                                                        
         lu(304) = 1. / lu(304)
         lu(305) = lu(305) * lu(304)
         lu(306) = lu(306) * lu(304)
         lu(307) = lu(307) * lu(304)
         lu(308) = lu(308) * lu(304)
         lu(309) = lu(309) * lu(304)
         lu(310) = lu(310) * lu(304)
         lu(311) = lu(311) * lu(304)
         lu(391) = lu(391) - lu(305) * lu(388)
         lu(397) = lu(397) - lu(306) * lu(388)
         lu(398) = - lu(307) * lu(388)
         lu(400) = lu(400) - lu(308) * lu(388)
         lu(401) = lu(401) - lu(309) * lu(388)
         lu(402) = lu(402) - lu(310) * lu(388)
         lu(403) = lu(403) - lu(311) * lu(388)
         lu(410) = - lu(305) * lu(407)
         lu(415) = lu(415) - lu(306) * lu(407)
         lu(416) = - lu(307) * lu(407)
         lu(418) = lu(418) - lu(308) * lu(407)
         lu(419) = lu(419) - lu(309) * lu(407)
         lu(420) = lu(420) - lu(310) * lu(407)
         lu(421) = lu(421) - lu(311) * lu(407)
         lu(501) = lu(501) - lu(305) * lu(495)
         lu(507) = lu(507) - lu(306) * lu(495)
         lu(509) = lu(509) - lu(307) * lu(495)
         lu(513) = lu(513) - lu(308) * lu(495)
         lu(514) = lu(514) - lu(309) * lu(495)
         lu(515) = lu(515) - lu(310) * lu(495)
         lu(516) = lu(516) - lu(311) * lu(495)
         lu(552) = lu(552) - lu(305) * lu(546)
         lu(558) = lu(558) - lu(306) * lu(546)
         lu(560) = lu(560) - lu(307) * lu(546)
         lu(564) = lu(564) - lu(308) * lu(546)
         lu(567) = lu(567) - lu(309) * lu(546)
         lu(568) = lu(568) - lu(310) * lu(546)
         lu(569) = lu(569) - lu(311) * lu(546)
         lu(628) = lu(628) - lu(305) * lu(622)
         lu(634) = lu(634) - lu(306) * lu(622)
         lu(636) = lu(636) - lu(307) * lu(622)
         lu(640) = lu(640) - lu(308) * lu(622)
         lu(643) = lu(643) - lu(309) * lu(622)
         lu(644) = lu(644) - lu(310) * lu(622)
         lu(645) = lu(645) - lu(311) * lu(622)
         lu(672) = lu(672) - lu(305) * lu(666)
         lu(678) = lu(678) - lu(306) * lu(666)
         lu(680) = lu(680) - lu(307) * lu(666)
         lu(684) = lu(684) - lu(308) * lu(666)
         lu(687) = lu(687) - lu(309) * lu(666)
         lu(688) = lu(688) - lu(310) * lu(666)
         lu(689) = lu(689) - lu(311) * lu(666)
         lu(785) = lu(785) - lu(305) * lu(778)
         lu(791) = lu(791) - lu(306) * lu(778)
         lu(793) = lu(793) - lu(307) * lu(778)
         lu(797) = lu(797) - lu(308) * lu(778)
         lu(800) = lu(800) - lu(309) * lu(778)
         lu(801) = lu(801) - lu(310) * lu(778)
         lu(802) = lu(802) - lu(311) * lu(778)
                                                                        
         lu(315) = 1. / lu(315)
         lu(316) = lu(316) * lu(315)
         lu(317) = lu(317) * lu(315)
         lu(318) = lu(318) * lu(315)
         lu(319) = lu(319) * lu(315)
         lu(320) = lu(320) * lu(315)
         lu(321) = lu(321) * lu(315)
         lu(522) = lu(522) - lu(316) * lu(521)
         lu(527) = lu(527) - lu(317) * lu(521)
         lu(528) = lu(528) - lu(318) * lu(521)
         lu(531) = lu(531) - lu(319) * lu(521)
         lu(532) = lu(532) - lu(320) * lu(521)
         lu(534) = lu(534) - lu(321) * lu(521)
         lu(574) = lu(574) - lu(316) * lu(573)
         lu(579) = lu(579) - lu(317) * lu(573)
         lu(580) = lu(580) - lu(318) * lu(573)
         lu(583) = lu(583) - lu(319) * lu(573)
         lu(584) = lu(584) - lu(320) * lu(573)
         lu(586) = lu(586) - lu(321) * lu(573)
         lu(596) = lu(596) - lu(316) * lu(595)
         lu(601) = lu(601) - lu(317) * lu(595)
         lu(602) = lu(602) - lu(318) * lu(595)
         lu(605) = lu(605) - lu(319) * lu(595)
         lu(606) = lu(606) - lu(320) * lu(595)
         lu(608) = lu(608) - lu(321) * lu(595)
         lu(670) = lu(670) - lu(316) * lu(667)
         lu(681) = lu(681) - lu(317) * lu(667)
         lu(682) = lu(682) - lu(318) * lu(667)
         lu(685) = lu(685) - lu(319) * lu(667)
         lu(686) = lu(686) - lu(320) * lu(667)
         lu(688) = lu(688) - lu(321) * lu(667)
         lu(691) = - lu(316) * lu(690)
         lu(696) = - lu(317) * lu(690)
         lu(697) = - lu(318) * lu(690)
         lu(700) = lu(700) - lu(319) * lu(690)
         lu(701) = lu(701) - lu(320) * lu(690)
         lu(703) = - lu(321) * lu(690)
         lu(710) = lu(710) - lu(316) * lu(709)
         lu(715) = lu(715) - lu(317) * lu(709)
         lu(716) = lu(716) - lu(318) * lu(709)
         lu(719) = lu(719) - lu(319) * lu(709)
         lu(720) = lu(720) - lu(320) * lu(709)
         lu(722) = lu(722) - lu(321) * lu(709)
         lu(727) = lu(727) - lu(316) * lu(726)
         lu(732) = - lu(317) * lu(726)
         lu(733) = lu(733) - lu(318) * lu(726)
         lu(736) = lu(736) - lu(319) * lu(726)
         lu(737) = - lu(320) * lu(726)
         lu(739) = lu(739) - lu(321) * lu(726)
         lu(783) = lu(783) - lu(316) * lu(779)
         lu(794) = lu(794) - lu(317) * lu(779)
         lu(795) = lu(795) - lu(318) * lu(779)
         lu(798) = lu(798) - lu(319) * lu(779)
         lu(799) = - lu(320) * lu(779)
         lu(801) = lu(801) - lu(321) * lu(779)
         lu(814) = lu(814) - lu(316) * lu(812)
         lu(821) = lu(821) - lu(317) * lu(812)
         lu(822) = lu(822) - lu(318) * lu(812)
         lu(825) = lu(825) - lu(319) * lu(812)
         lu(826) = lu(826) - lu(320) * lu(812)
         lu(828) = lu(828) - lu(321) * lu(812)
                                                                        
                                                                        
      end subroutine imp_lu_fac07
                                                                        
      subroutine imp_lu_fac08( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(323) = 1. / lu(323)
         lu(324) = lu(324) * lu(323)
         lu(325) = lu(325) * lu(323)
         lu(326) = lu(326) * lu(323)
         lu(327) = lu(327) * lu(323)
         lu(328) = lu(328) * lu(323)
         lu(331) = lu(331) - lu(324) * lu(329)
         lu(332) = - lu(325) * lu(329)
         lu(333) = lu(333) - lu(326) * lu(329)
         lu(335) = lu(335) - lu(327) * lu(329)
         lu(336) = - lu(328) * lu(329)
         lu(340) = lu(340) - lu(324) * lu(337)
         lu(342) = - lu(325) * lu(337)
         lu(344) = lu(344) - lu(326) * lu(337)
         lu(346) = lu(346) - lu(327) * lu(337)
         lu(347) = - lu(328) * lu(337)
         lu(361) = lu(361) - lu(324) * lu(357)
         lu(363) = lu(363) - lu(325) * lu(357)
         lu(366) = lu(366) - lu(326) * lu(357)
         lu(368) = lu(368) - lu(327) * lu(357)
         lu(369) = lu(369) - lu(328) * lu(357)
         lu(376) = lu(376) - lu(324) * lu(373)
         lu(379) = lu(379) - lu(325) * lu(373)
         lu(381) = lu(381) - lu(326) * lu(373)
         lu(383) = lu(383) - lu(327) * lu(373)
         lu(384) = lu(384) - lu(328) * lu(373)
         lu(412) = lu(412) - lu(324) * lu(408)
         lu(415) = lu(415) - lu(325) * lu(408)
         lu(418) = lu(418) - lu(326) * lu(408)
         lu(420) = lu(420) - lu(327) * lu(408)
         lu(421) = lu(421) - lu(328) * lu(408)
         lu(433) = lu(433) - lu(324) * lu(426)
         lu(436) = lu(436) - lu(325) * lu(426)
         lu(439) = lu(439) - lu(326) * lu(426)
         lu(441) = lu(441) - lu(327) * lu(426)
         lu(442) = lu(442) - lu(328) * lu(426)
         lu(473) = lu(473) - lu(324) * lu(466)
         lu(476) = lu(476) - lu(325) * lu(466)
         lu(479) = lu(479) - lu(326) * lu(466)
         lu(481) = lu(481) - lu(327) * lu(466)
         lu(482) = lu(482) - lu(328) * lu(466)
         lu(504) = lu(504) - lu(324) * lu(496)
         lu(507) = lu(507) - lu(325) * lu(496)
         lu(513) = lu(513) - lu(326) * lu(496)
         lu(515) = lu(515) - lu(327) * lu(496)
         lu(516) = lu(516) - lu(328) * lu(496)
         lu(555) = lu(555) - lu(324) * lu(547)
         lu(558) = lu(558) - lu(325) * lu(547)
         lu(564) = lu(564) - lu(326) * lu(547)
         lu(568) = lu(568) - lu(327) * lu(547)
         lu(569) = lu(569) - lu(328) * lu(547)
         lu(631) = lu(631) - lu(324) * lu(623)
         lu(634) = lu(634) - lu(325) * lu(623)
         lu(640) = lu(640) - lu(326) * lu(623)
         lu(644) = lu(644) - lu(327) * lu(623)
         lu(645) = lu(645) - lu(328) * lu(623)
         lu(788) = lu(788) - lu(324) * lu(780)
         lu(791) = lu(791) - lu(325) * lu(780)
         lu(797) = lu(797) - lu(326) * lu(780)
         lu(801) = lu(801) - lu(327) * lu(780)
         lu(802) = lu(802) - lu(328) * lu(780)
                                                                        
         lu(330) = 1. / lu(330)
         lu(331) = lu(331) * lu(330)
         lu(332) = lu(332) * lu(330)
         lu(333) = lu(333) * lu(330)
         lu(334) = lu(334) * lu(330)
         lu(335) = lu(335) * lu(330)
         lu(336) = lu(336) * lu(330)
         lu(361) = lu(361) - lu(331) * lu(358)
         lu(363) = lu(363) - lu(332) * lu(358)
         lu(366) = lu(366) - lu(333) * lu(358)
         lu(367) = lu(367) - lu(334) * lu(358)
         lu(368) = lu(368) - lu(335) * lu(358)
         lu(369) = lu(369) - lu(336) * lu(358)
         lu(376) = lu(376) - lu(331) * lu(374)
         lu(379) = lu(379) - lu(332) * lu(374)
         lu(381) = lu(381) - lu(333) * lu(374)
         lu(382) = lu(382) - lu(334) * lu(374)
         lu(383) = lu(383) - lu(335) * lu(374)
         lu(384) = lu(384) - lu(336) * lu(374)
         lu(412) = lu(412) - lu(331) * lu(409)
         lu(415) = lu(415) - lu(332) * lu(409)
         lu(418) = lu(418) - lu(333) * lu(409)
         lu(419) = lu(419) - lu(334) * lu(409)
         lu(420) = lu(420) - lu(335) * lu(409)
         lu(421) = lu(421) - lu(336) * lu(409)
         lu(433) = lu(433) - lu(331) * lu(427)
         lu(436) = lu(436) - lu(332) * lu(427)
         lu(439) = lu(439) - lu(333) * lu(427)
         lu(440) = lu(440) - lu(334) * lu(427)
         lu(441) = lu(441) - lu(335) * lu(427)
         lu(442) = lu(442) - lu(336) * lu(427)
         lu(446) = lu(446) - lu(331) * lu(445)
         lu(449) = lu(449) - lu(332) * lu(445)
         lu(452) = lu(452) - lu(333) * lu(445)
         lu(453) = lu(453) - lu(334) * lu(445)
         lu(454) = lu(454) - lu(335) * lu(445)
         lu(455) = lu(455) - lu(336) * lu(445)
         lu(473) = lu(473) - lu(331) * lu(467)
         lu(476) = lu(476) - lu(332) * lu(467)
         lu(479) = lu(479) - lu(333) * lu(467)
         lu(480) = lu(480) - lu(334) * lu(467)
         lu(481) = lu(481) - lu(335) * lu(467)
         lu(482) = lu(482) - lu(336) * lu(467)
         lu(504) = lu(504) - lu(331) * lu(497)
         lu(507) = lu(507) - lu(332) * lu(497)
         lu(513) = lu(513) - lu(333) * lu(497)
         lu(514) = lu(514) - lu(334) * lu(497)
         lu(515) = lu(515) - lu(335) * lu(497)
         lu(516) = lu(516) - lu(336) * lu(497)
         lu(555) = lu(555) - lu(331) * lu(548)
         lu(558) = lu(558) - lu(332) * lu(548)
         lu(564) = lu(564) - lu(333) * lu(548)
         lu(567) = lu(567) - lu(334) * lu(548)
         lu(568) = lu(568) - lu(335) * lu(548)
         lu(569) = lu(569) - lu(336) * lu(548)
         lu(631) = lu(631) - lu(331) * lu(624)
         lu(634) = lu(634) - lu(332) * lu(624)
         lu(640) = lu(640) - lu(333) * lu(624)
         lu(643) = lu(643) - lu(334) * lu(624)
         lu(644) = lu(644) - lu(335) * lu(624)
         lu(645) = lu(645) - lu(336) * lu(624)
         lu(675) = lu(675) - lu(331) * lu(668)
         lu(678) = lu(678) - lu(332) * lu(668)
         lu(684) = lu(684) - lu(333) * lu(668)
         lu(687) = lu(687) - lu(334) * lu(668)
         lu(688) = lu(688) - lu(335) * lu(668)
         lu(689) = lu(689) - lu(336) * lu(668)
         lu(788) = lu(788) - lu(331) * lu(781)
         lu(791) = lu(791) - lu(332) * lu(781)
         lu(797) = lu(797) - lu(333) * lu(781)
         lu(800) = lu(800) - lu(334) * lu(781)
         lu(801) = lu(801) - lu(335) * lu(781)
         lu(802) = lu(802) - lu(336) * lu(781)
         lu(815) = lu(815) - lu(331) * lu(813)
         lu(818) = lu(818) - lu(332) * lu(813)
         lu(824) = lu(824) - lu(333) * lu(813)
         lu(827) = lu(827) - lu(334) * lu(813)
         lu(828) = lu(828) - lu(335) * lu(813)
         lu(829) = lu(829) - lu(336) * lu(813)
                                                                        
         lu(338) = 1. / lu(338)
         lu(339) = lu(339) * lu(338)
         lu(340) = lu(340) * lu(338)
         lu(341) = lu(341) * lu(338)
         lu(342) = lu(342) * lu(338)
         lu(343) = lu(343) * lu(338)
         lu(344) = lu(344) * lu(338)
         lu(345) = lu(345) * lu(338)
         lu(346) = lu(346) * lu(338)
         lu(347) = lu(347) * lu(338)
         lu(393) = - lu(339) * lu(389)
         lu(394) = lu(394) - lu(340) * lu(389)
         lu(395) = - lu(341) * lu(389)
         lu(397) = lu(397) - lu(342) * lu(389)
         lu(398) = lu(398) - lu(343) * lu(389)
         lu(400) = lu(400) - lu(344) * lu(389)
         lu(401) = lu(401) - lu(345) * lu(389)
         lu(402) = lu(402) - lu(346) * lu(389)
         lu(403) = lu(403) - lu(347) * lu(389)
         lu(432) = lu(432) - lu(339) * lu(428)
         lu(433) = lu(433) - lu(340) * lu(428)
         lu(434) = lu(434) - lu(341) * lu(428)
         lu(436) = lu(436) - lu(342) * lu(428)
         lu(437) = lu(437) - lu(343) * lu(428)
         lu(439) = lu(439) - lu(344) * lu(428)
         lu(440) = lu(440) - lu(345) * lu(428)
         lu(441) = lu(441) - lu(346) * lu(428)
         lu(442) = lu(442) - lu(347) * lu(428)
         lu(472) = lu(472) - lu(339) * lu(468)
         lu(473) = lu(473) - lu(340) * lu(468)
         lu(474) = lu(474) - lu(341) * lu(468)
         lu(476) = lu(476) - lu(342) * lu(468)
         lu(477) = - lu(343) * lu(468)
         lu(479) = lu(479) - lu(344) * lu(468)
         lu(480) = lu(480) - lu(345) * lu(468)
         lu(481) = lu(481) - lu(346) * lu(468)
         lu(482) = lu(482) - lu(347) * lu(468)
         lu(503) = lu(503) - lu(339) * lu(498)
         lu(504) = lu(504) - lu(340) * lu(498)
         lu(505) = lu(505) - lu(341) * lu(498)
         lu(507) = lu(507) - lu(342) * lu(498)
         lu(509) = lu(509) - lu(343) * lu(498)
         lu(513) = lu(513) - lu(344) * lu(498)
         lu(514) = lu(514) - lu(345) * lu(498)
         lu(515) = lu(515) - lu(346) * lu(498)
         lu(516) = lu(516) - lu(347) * lu(498)
         lu(554) = - lu(339) * lu(549)
         lu(555) = lu(555) - lu(340) * lu(549)
         lu(556) = lu(556) - lu(341) * lu(549)
         lu(558) = lu(558) - lu(342) * lu(549)
         lu(560) = lu(560) - lu(343) * lu(549)
         lu(564) = lu(564) - lu(344) * lu(549)
         lu(567) = lu(567) - lu(345) * lu(549)
         lu(568) = lu(568) - lu(346) * lu(549)
         lu(569) = lu(569) - lu(347) * lu(549)
         lu(630) = lu(630) - lu(339) * lu(625)
         lu(631) = lu(631) - lu(340) * lu(625)
         lu(632) = lu(632) - lu(341) * lu(625)
         lu(634) = lu(634) - lu(342) * lu(625)
         lu(636) = lu(636) - lu(343) * lu(625)
         lu(640) = lu(640) - lu(344) * lu(625)
         lu(643) = lu(643) - lu(345) * lu(625)
         lu(644) = lu(644) - lu(346) * lu(625)
         lu(645) = lu(645) - lu(347) * lu(625)
         lu(674) = lu(674) - lu(339) * lu(669)
         lu(675) = lu(675) - lu(340) * lu(669)
         lu(676) = lu(676) - lu(341) * lu(669)
         lu(678) = lu(678) - lu(342) * lu(669)
         lu(680) = lu(680) - lu(343) * lu(669)
         lu(684) = lu(684) - lu(344) * lu(669)
         lu(687) = lu(687) - lu(345) * lu(669)
         lu(688) = lu(688) - lu(346) * lu(669)
         lu(689) = lu(689) - lu(347) * lu(669)
         lu(787) = lu(787) - lu(339) * lu(782)
         lu(788) = lu(788) - lu(340) * lu(782)
         lu(789) = lu(789) - lu(341) * lu(782)
         lu(791) = lu(791) - lu(342) * lu(782)
         lu(793) = lu(793) - lu(343) * lu(782)
         lu(797) = lu(797) - lu(344) * lu(782)
         lu(800) = lu(800) - lu(345) * lu(782)
         lu(801) = lu(801) - lu(346) * lu(782)
         lu(802) = lu(802) - lu(347) * lu(782)
                                                                        
         lu(348) = 1. / lu(348)
         lu(349) = lu(349) * lu(348)
         lu(350) = lu(350) * lu(348)
         lu(351) = lu(351) * lu(348)
         lu(352) = lu(352) * lu(348)
         lu(353) = lu(353) * lu(348)
         lu(354) = lu(354) * lu(348)
         lu(506) = lu(506) - lu(349) * lu(499)
         lu(508) = - lu(350) * lu(499)
         lu(509) = lu(509) - lu(351) * lu(499)
         lu(511) = lu(511) - lu(352) * lu(499)
         lu(513) = lu(513) - lu(353) * lu(499)
         lu(514) = lu(514) - lu(354) * lu(499)
         lu(523) = - lu(349) * lu(522)
         lu(525) = lu(525) - lu(350) * lu(522)
         lu(526) = - lu(351) * lu(522)
         lu(528) = lu(528) - lu(352) * lu(522)
         lu(530) = lu(530) - lu(353) * lu(522)
         lu(533) = - lu(354) * lu(522)
         lu(557) = lu(557) - lu(349) * lu(550)
         lu(559) = lu(559) - lu(350) * lu(550)
         lu(560) = lu(560) - lu(351) * lu(550)
         lu(562) = - lu(352) * lu(550)
         lu(564) = lu(564) - lu(353) * lu(550)
         lu(567) = lu(567) - lu(354) * lu(550)
         lu(575) = - lu(349) * lu(574)
         lu(577) = lu(577) - lu(350) * lu(574)
         lu(578) = lu(578) - lu(351) * lu(574)
         lu(580) = lu(580) - lu(352) * lu(574)
         lu(582) = lu(582) - lu(353) * lu(574)
         lu(585) = - lu(354) * lu(574)
         lu(597) = - lu(349) * lu(596)
         lu(599) = lu(599) - lu(350) * lu(596)
         lu(600) = - lu(351) * lu(596)
         lu(602) = lu(602) - lu(352) * lu(596)
         lu(604) = - lu(353) * lu(596)
         lu(607) = - lu(354) * lu(596)
         lu(633) = lu(633) - lu(349) * lu(626)
         lu(635) = lu(635) - lu(350) * lu(626)
         lu(636) = lu(636) - lu(351) * lu(626)
         lu(638) = - lu(352) * lu(626)
         lu(640) = lu(640) - lu(353) * lu(626)
         lu(643) = lu(643) - lu(354) * lu(626)
         lu(677) = lu(677) - lu(349) * lu(670)
         lu(679) = lu(679) - lu(350) * lu(670)
         lu(680) = lu(680) - lu(351) * lu(670)
         lu(682) = lu(682) - lu(352) * lu(670)
         lu(684) = lu(684) - lu(353) * lu(670)
         lu(687) = lu(687) - lu(354) * lu(670)
         lu(692) = - lu(349) * lu(691)
         lu(694) = - lu(350) * lu(691)
         lu(695) = lu(695) - lu(351) * lu(691)
         lu(697) = lu(697) - lu(352) * lu(691)
         lu(699) = lu(699) - lu(353) * lu(691)
         lu(702) = lu(702) - lu(354) * lu(691)
         lu(711) = - lu(349) * lu(710)
         lu(713) = lu(713) - lu(350) * lu(710)
         lu(714) = - lu(351) * lu(710)
         lu(716) = lu(716) - lu(352) * lu(710)
         lu(718) = lu(718) - lu(353) * lu(710)
         lu(721) = - lu(354) * lu(710)
         lu(728) = - lu(349) * lu(727)
         lu(730) = - lu(350) * lu(727)
         lu(731) = lu(731) - lu(351) * lu(727)
         lu(733) = lu(733) - lu(352) * lu(727)
         lu(735) = lu(735) - lu(353) * lu(727)
         lu(738) = lu(738) - lu(354) * lu(727)
         lu(790) = lu(790) - lu(349) * lu(783)
         lu(792) = lu(792) - lu(350) * lu(783)
         lu(793) = lu(793) - lu(351) * lu(783)
         lu(795) = lu(795) - lu(352) * lu(783)
         lu(797) = lu(797) - lu(353) * lu(783)
         lu(800) = lu(800) - lu(354) * lu(783)
         lu(817) = lu(817) - lu(349) * lu(814)
         lu(819) = lu(819) - lu(350) * lu(814)
         lu(820) = lu(820) - lu(351) * lu(814)
         lu(822) = lu(822) - lu(352) * lu(814)
         lu(824) = lu(824) - lu(353) * lu(814)
         lu(827) = lu(827) - lu(354) * lu(814)
                                                                        
                                                                        
      end subroutine imp_lu_fac08
                                                                        
      subroutine imp_lu_fac09( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(359) = 1. / lu(359)
         lu(360) = lu(360) * lu(359)
         lu(361) = lu(361) * lu(359)
         lu(362) = lu(362) * lu(359)
         lu(363) = lu(363) * lu(359)
         lu(364) = lu(364) * lu(359)
         lu(365) = lu(365) * lu(359)
         lu(366) = lu(366) * lu(359)
         lu(367) = lu(367) * lu(359)
         lu(368) = lu(368) * lu(359)
         lu(369) = lu(369) * lu(359)
         lu(393) = lu(393) - lu(360) * lu(390)
         lu(394) = lu(394) - lu(361) * lu(390)
         lu(396) = lu(396) - lu(362) * lu(390)
         lu(397) = lu(397) - lu(363) * lu(390)
         lu(398) = lu(398) - lu(364) * lu(390)
         lu(399) = lu(399) - lu(365) * lu(390)
         lu(400) = lu(400) - lu(366) * lu(390)
         lu(401) = lu(401) - lu(367) * lu(390)
         lu(402) = lu(402) - lu(368) * lu(390)
         lu(403) = lu(403) - lu(369) * lu(390)
         lu(432) = lu(432) - lu(360) * lu(429)
         lu(433) = lu(433) - lu(361) * lu(429)
         lu(435) = lu(435) - lu(362) * lu(429)
         lu(436) = lu(436) - lu(363) * lu(429)
         lu(437) = lu(437) - lu(364) * lu(429)
         lu(438) = lu(438) - lu(365) * lu(429)
         lu(439) = lu(439) - lu(366) * lu(429)
         lu(440) = lu(440) - lu(367) * lu(429)
         lu(441) = lu(441) - lu(368) * lu(429)
         lu(442) = lu(442) - lu(369) * lu(429)
         lu(472) = lu(472) - lu(360) * lu(469)
         lu(473) = lu(473) - lu(361) * lu(469)
         lu(475) = lu(475) - lu(362) * lu(469)
         lu(476) = lu(476) - lu(363) * lu(469)
         lu(477) = lu(477) - lu(364) * lu(469)
         lu(478) = lu(478) - lu(365) * lu(469)
         lu(479) = lu(479) - lu(366) * lu(469)
         lu(480) = lu(480) - lu(367) * lu(469)
         lu(481) = lu(481) - lu(368) * lu(469)
         lu(482) = lu(482) - lu(369) * lu(469)
         lu(503) = lu(503) - lu(360) * lu(500)
         lu(504) = lu(504) - lu(361) * lu(500)
         lu(506) = lu(506) - lu(362) * lu(500)
         lu(507) = lu(507) - lu(363) * lu(500)
         lu(509) = lu(509) - lu(364) * lu(500)
         lu(512) = lu(512) - lu(365) * lu(500)
         lu(513) = lu(513) - lu(366) * lu(500)
         lu(514) = lu(514) - lu(367) * lu(500)
         lu(515) = lu(515) - lu(368) * lu(500)
         lu(516) = lu(516) - lu(369) * lu(500)
         lu(554) = lu(554) - lu(360) * lu(551)
         lu(555) = lu(555) - lu(361) * lu(551)
         lu(557) = lu(557) - lu(362) * lu(551)
         lu(558) = lu(558) - lu(363) * lu(551)
         lu(560) = lu(560) - lu(364) * lu(551)
         lu(563) = lu(563) - lu(365) * lu(551)
         lu(564) = lu(564) - lu(366) * lu(551)
         lu(567) = lu(567) - lu(367) * lu(551)
         lu(568) = lu(568) - lu(368) * lu(551)
         lu(569) = lu(569) - lu(369) * lu(551)
         lu(630) = lu(630) - lu(360) * lu(627)
         lu(631) = lu(631) - lu(361) * lu(627)
         lu(633) = lu(633) - lu(362) * lu(627)
         lu(634) = lu(634) - lu(363) * lu(627)
         lu(636) = lu(636) - lu(364) * lu(627)
         lu(639) = lu(639) - lu(365) * lu(627)
         lu(640) = lu(640) - lu(366) * lu(627)
         lu(643) = lu(643) - lu(367) * lu(627)
         lu(644) = lu(644) - lu(368) * lu(627)
         lu(645) = lu(645) - lu(369) * lu(627)
         lu(674) = lu(674) - lu(360) * lu(671)
         lu(675) = lu(675) - lu(361) * lu(671)
         lu(677) = lu(677) - lu(362) * lu(671)
         lu(678) = lu(678) - lu(363) * lu(671)
         lu(680) = lu(680) - lu(364) * lu(671)
         lu(683) = lu(683) - lu(365) * lu(671)
         lu(684) = lu(684) - lu(366) * lu(671)
         lu(687) = lu(687) - lu(367) * lu(671)
         lu(688) = lu(688) - lu(368) * lu(671)
         lu(689) = lu(689) - lu(369) * lu(671)
         lu(787) = lu(787) - lu(360) * lu(784)
         lu(788) = lu(788) - lu(361) * lu(784)
         lu(790) = lu(790) - lu(362) * lu(784)
         lu(791) = lu(791) - lu(363) * lu(784)
         lu(793) = lu(793) - lu(364) * lu(784)
         lu(796) = lu(796) - lu(365) * lu(784)
         lu(797) = lu(797) - lu(366) * lu(784)
         lu(800) = lu(800) - lu(367) * lu(784)
         lu(801) = lu(801) - lu(368) * lu(784)
         lu(802) = lu(802) - lu(369) * lu(784)
                                                                        
         lu(375) = 1. / lu(375)
         lu(376) = lu(376) * lu(375)
         lu(377) = lu(377) * lu(375)
         lu(378) = lu(378) * lu(375)
         lu(379) = lu(379) * lu(375)
         lu(380) = lu(380) * lu(375)
         lu(381) = lu(381) * lu(375)
         lu(382) = lu(382) * lu(375)
         lu(383) = lu(383) * lu(375)
         lu(384) = lu(384) * lu(375)
         lu(394) = lu(394) - lu(376) * lu(391)
         lu(395) = lu(395) - lu(377) * lu(391)
         lu(396) = lu(396) - lu(378) * lu(391)
         lu(397) = lu(397) - lu(379) * lu(391)
         lu(399) = lu(399) - lu(380) * lu(391)
         lu(400) = lu(400) - lu(381) * lu(391)
         lu(401) = lu(401) - lu(382) * lu(391)
         lu(402) = lu(402) - lu(383) * lu(391)
         lu(403) = lu(403) - lu(384) * lu(391)
         lu(412) = lu(412) - lu(376) * lu(410)
         lu(413) = lu(413) - lu(377) * lu(410)
         lu(414) = lu(414) - lu(378) * lu(410)
         lu(415) = lu(415) - lu(379) * lu(410)
         lu(417) = lu(417) - lu(380) * lu(410)
         lu(418) = lu(418) - lu(381) * lu(410)
         lu(419) = lu(419) - lu(382) * lu(410)
         lu(420) = lu(420) - lu(383) * lu(410)
         lu(421) = lu(421) - lu(384) * lu(410)
         lu(433) = lu(433) - lu(376) * lu(430)
         lu(434) = lu(434) - lu(377) * lu(430)
         lu(435) = lu(435) - lu(378) * lu(430)
         lu(436) = lu(436) - lu(379) * lu(430)
         lu(438) = lu(438) - lu(380) * lu(430)
         lu(439) = lu(439) - lu(381) * lu(430)
         lu(440) = lu(440) - lu(382) * lu(430)
         lu(441) = lu(441) - lu(383) * lu(430)
         lu(442) = lu(442) - lu(384) * lu(430)
         lu(473) = lu(473) - lu(376) * lu(470)
         lu(474) = lu(474) - lu(377) * lu(470)
         lu(475) = lu(475) - lu(378) * lu(470)
         lu(476) = lu(476) - lu(379) * lu(470)
         lu(478) = lu(478) - lu(380) * lu(470)
         lu(479) = lu(479) - lu(381) * lu(470)
         lu(480) = lu(480) - lu(382) * lu(470)
         lu(481) = lu(481) - lu(383) * lu(470)
         lu(482) = lu(482) - lu(384) * lu(470)
         lu(504) = lu(504) - lu(376) * lu(501)
         lu(505) = lu(505) - lu(377) * lu(501)
         lu(506) = lu(506) - lu(378) * lu(501)
         lu(507) = lu(507) - lu(379) * lu(501)
         lu(512) = lu(512) - lu(380) * lu(501)
         lu(513) = lu(513) - lu(381) * lu(501)
         lu(514) = lu(514) - lu(382) * lu(501)
         lu(515) = lu(515) - lu(383) * lu(501)
         lu(516) = lu(516) - lu(384) * lu(501)
         lu(555) = lu(555) - lu(376) * lu(552)
         lu(556) = lu(556) - lu(377) * lu(552)
         lu(557) = lu(557) - lu(378) * lu(552)
         lu(558) = lu(558) - lu(379) * lu(552)
         lu(563) = lu(563) - lu(380) * lu(552)
         lu(564) = lu(564) - lu(381) * lu(552)
         lu(567) = lu(567) - lu(382) * lu(552)
         lu(568) = lu(568) - lu(383) * lu(552)
         lu(569) = lu(569) - lu(384) * lu(552)
         lu(631) = lu(631) - lu(376) * lu(628)
         lu(632) = lu(632) - lu(377) * lu(628)
         lu(633) = lu(633) - lu(378) * lu(628)
         lu(634) = lu(634) - lu(379) * lu(628)
         lu(639) = lu(639) - lu(380) * lu(628)
         lu(640) = lu(640) - lu(381) * lu(628)
         lu(643) = lu(643) - lu(382) * lu(628)
         lu(644) = lu(644) - lu(383) * lu(628)
         lu(645) = lu(645) - lu(384) * lu(628)
         lu(675) = lu(675) - lu(376) * lu(672)
         lu(676) = lu(676) - lu(377) * lu(672)
         lu(677) = lu(677) - lu(378) * lu(672)
         lu(678) = lu(678) - lu(379) * lu(672)
         lu(683) = lu(683) - lu(380) * lu(672)
         lu(684) = lu(684) - lu(381) * lu(672)
         lu(687) = lu(687) - lu(382) * lu(672)
         lu(688) = lu(688) - lu(383) * lu(672)
         lu(689) = lu(689) - lu(384) * lu(672)
         lu(788) = lu(788) - lu(376) * lu(785)
         lu(789) = lu(789) - lu(377) * lu(785)
         lu(790) = lu(790) - lu(378) * lu(785)
         lu(791) = lu(791) - lu(379) * lu(785)
         lu(796) = lu(796) - lu(380) * lu(785)
         lu(797) = lu(797) - lu(381) * lu(785)
         lu(800) = lu(800) - lu(382) * lu(785)
         lu(801) = lu(801) - lu(383) * lu(785)
         lu(802) = lu(802) - lu(384) * lu(785)
                                                                        
         lu(392) = 1. / lu(392)
         lu(393) = lu(393) * lu(392)
         lu(394) = lu(394) * lu(392)
         lu(395) = lu(395) * lu(392)
         lu(396) = lu(396) * lu(392)
         lu(397) = lu(397) * lu(392)
         lu(398) = lu(398) * lu(392)
         lu(399) = lu(399) * lu(392)
         lu(400) = lu(400) * lu(392)
         lu(401) = lu(401) * lu(392)
         lu(402) = lu(402) * lu(392)
         lu(403) = lu(403) * lu(392)
         lu(432) = lu(432) - lu(393) * lu(431)
         lu(433) = lu(433) - lu(394) * lu(431)
         lu(434) = lu(434) - lu(395) * lu(431)
         lu(435) = lu(435) - lu(396) * lu(431)
         lu(436) = lu(436) - lu(397) * lu(431)
         lu(437) = lu(437) - lu(398) * lu(431)
         lu(438) = lu(438) - lu(399) * lu(431)
         lu(439) = lu(439) - lu(400) * lu(431)
         lu(440) = lu(440) - lu(401) * lu(431)
         lu(441) = lu(441) - lu(402) * lu(431)
         lu(442) = lu(442) - lu(403) * lu(431)
         lu(472) = lu(472) - lu(393) * lu(471)
         lu(473) = lu(473) - lu(394) * lu(471)
         lu(474) = lu(474) - lu(395) * lu(471)
         lu(475) = lu(475) - lu(396) * lu(471)
         lu(476) = lu(476) - lu(397) * lu(471)
         lu(477) = lu(477) - lu(398) * lu(471)
         lu(478) = lu(478) - lu(399) * lu(471)
         lu(479) = lu(479) - lu(400) * lu(471)
         lu(480) = lu(480) - lu(401) * lu(471)
         lu(481) = lu(481) - lu(402) * lu(471)
         lu(482) = lu(482) - lu(403) * lu(471)
         lu(503) = lu(503) - lu(393) * lu(502)
         lu(504) = lu(504) - lu(394) * lu(502)
         lu(505) = lu(505) - lu(395) * lu(502)
         lu(506) = lu(506) - lu(396) * lu(502)
         lu(507) = lu(507) - lu(397) * lu(502)
         lu(509) = lu(509) - lu(398) * lu(502)
         lu(512) = lu(512) - lu(399) * lu(502)
         lu(513) = lu(513) - lu(400) * lu(502)
         lu(514) = lu(514) - lu(401) * lu(502)
         lu(515) = lu(515) - lu(402) * lu(502)
         lu(516) = lu(516) - lu(403) * lu(502)
         lu(554) = lu(554) - lu(393) * lu(553)
         lu(555) = lu(555) - lu(394) * lu(553)
         lu(556) = lu(556) - lu(395) * lu(553)
         lu(557) = lu(557) - lu(396) * lu(553)
         lu(558) = lu(558) - lu(397) * lu(553)
         lu(560) = lu(560) - lu(398) * lu(553)
         lu(563) = lu(563) - lu(399) * lu(553)
         lu(564) = lu(564) - lu(400) * lu(553)
         lu(567) = lu(567) - lu(401) * lu(553)
         lu(568) = lu(568) - lu(402) * lu(553)
         lu(569) = lu(569) - lu(403) * lu(553)
         lu(630) = lu(630) - lu(393) * lu(629)
         lu(631) = lu(631) - lu(394) * lu(629)
         lu(632) = lu(632) - lu(395) * lu(629)
         lu(633) = lu(633) - lu(396) * lu(629)
         lu(634) = lu(634) - lu(397) * lu(629)
         lu(636) = lu(636) - lu(398) * lu(629)
         lu(639) = lu(639) - lu(399) * lu(629)
         lu(640) = lu(640) - lu(400) * lu(629)
         lu(643) = lu(643) - lu(401) * lu(629)
         lu(644) = lu(644) - lu(402) * lu(629)
         lu(645) = lu(645) - lu(403) * lu(629)
         lu(674) = lu(674) - lu(393) * lu(673)
         lu(675) = lu(675) - lu(394) * lu(673)
         lu(676) = lu(676) - lu(395) * lu(673)
         lu(677) = lu(677) - lu(396) * lu(673)
         lu(678) = lu(678) - lu(397) * lu(673)
         lu(680) = lu(680) - lu(398) * lu(673)
         lu(683) = lu(683) - lu(399) * lu(673)
         lu(684) = lu(684) - lu(400) * lu(673)
         lu(687) = lu(687) - lu(401) * lu(673)
         lu(688) = lu(688) - lu(402) * lu(673)
         lu(689) = lu(689) - lu(403) * lu(673)
         lu(787) = lu(787) - lu(393) * lu(786)
         lu(788) = lu(788) - lu(394) * lu(786)
         lu(789) = lu(789) - lu(395) * lu(786)
         lu(790) = lu(790) - lu(396) * lu(786)
         lu(791) = lu(791) - lu(397) * lu(786)
         lu(793) = lu(793) - lu(398) * lu(786)
         lu(796) = lu(796) - lu(399) * lu(786)
         lu(797) = lu(797) - lu(400) * lu(786)
         lu(800) = lu(800) - lu(401) * lu(786)
         lu(801) = lu(801) - lu(402) * lu(786)
         lu(802) = lu(802) - lu(403) * lu(786)
                                                                        
         lu(411) = 1. / lu(411)
         lu(412) = lu(412) * lu(411)
         lu(413) = lu(413) * lu(411)
         lu(414) = lu(414) * lu(411)
         lu(415) = lu(415) * lu(411)
         lu(416) = lu(416) * lu(411)
         lu(417) = lu(417) * lu(411)
         lu(418) = lu(418) * lu(411)
         lu(419) = lu(419) * lu(411)
         lu(420) = lu(420) * lu(411)
         lu(421) = lu(421) * lu(411)
         lu(433) = lu(433) - lu(412) * lu(432)
         lu(434) = lu(434) - lu(413) * lu(432)
         lu(435) = lu(435) - lu(414) * lu(432)
         lu(436) = lu(436) - lu(415) * lu(432)
         lu(437) = lu(437) - lu(416) * lu(432)
         lu(438) = lu(438) - lu(417) * lu(432)
         lu(439) = lu(439) - lu(418) * lu(432)
         lu(440) = lu(440) - lu(419) * lu(432)
         lu(441) = lu(441) - lu(420) * lu(432)
         lu(442) = lu(442) - lu(421) * lu(432)
         lu(473) = lu(473) - lu(412) * lu(472)
         lu(474) = lu(474) - lu(413) * lu(472)
         lu(475) = lu(475) - lu(414) * lu(472)
         lu(476) = lu(476) - lu(415) * lu(472)
         lu(477) = lu(477) - lu(416) * lu(472)
         lu(478) = lu(478) - lu(417) * lu(472)
         lu(479) = lu(479) - lu(418) * lu(472)
         lu(480) = lu(480) - lu(419) * lu(472)
         lu(481) = lu(481) - lu(420) * lu(472)
         lu(482) = lu(482) - lu(421) * lu(472)
         lu(504) = lu(504) - lu(412) * lu(503)
         lu(505) = lu(505) - lu(413) * lu(503)
         lu(506) = lu(506) - lu(414) * lu(503)
         lu(507) = lu(507) - lu(415) * lu(503)
         lu(509) = lu(509) - lu(416) * lu(503)
         lu(512) = lu(512) - lu(417) * lu(503)
         lu(513) = lu(513) - lu(418) * lu(503)
         lu(514) = lu(514) - lu(419) * lu(503)
         lu(515) = lu(515) - lu(420) * lu(503)
         lu(516) = lu(516) - lu(421) * lu(503)
         lu(555) = lu(555) - lu(412) * lu(554)
         lu(556) = lu(556) - lu(413) * lu(554)
         lu(557) = lu(557) - lu(414) * lu(554)
         lu(558) = lu(558) - lu(415) * lu(554)
         lu(560) = lu(560) - lu(416) * lu(554)
         lu(563) = lu(563) - lu(417) * lu(554)
         lu(564) = lu(564) - lu(418) * lu(554)
         lu(567) = lu(567) - lu(419) * lu(554)
         lu(568) = lu(568) - lu(420) * lu(554)
         lu(569) = lu(569) - lu(421) * lu(554)
         lu(631) = lu(631) - lu(412) * lu(630)
         lu(632) = lu(632) - lu(413) * lu(630)
         lu(633) = lu(633) - lu(414) * lu(630)
         lu(634) = lu(634) - lu(415) * lu(630)
         lu(636) = lu(636) - lu(416) * lu(630)
         lu(639) = lu(639) - lu(417) * lu(630)
         lu(640) = lu(640) - lu(418) * lu(630)
         lu(643) = lu(643) - lu(419) * lu(630)
         lu(644) = lu(644) - lu(420) * lu(630)
         lu(645) = lu(645) - lu(421) * lu(630)
         lu(675) = lu(675) - lu(412) * lu(674)
         lu(676) = lu(676) - lu(413) * lu(674)
         lu(677) = lu(677) - lu(414) * lu(674)
         lu(678) = lu(678) - lu(415) * lu(674)
         lu(680) = lu(680) - lu(416) * lu(674)
         lu(683) = lu(683) - lu(417) * lu(674)
         lu(684) = lu(684) - lu(418) * lu(674)
         lu(687) = lu(687) - lu(419) * lu(674)
         lu(688) = lu(688) - lu(420) * lu(674)
         lu(689) = lu(689) - lu(421) * lu(674)
         lu(788) = lu(788) - lu(412) * lu(787)
         lu(789) = lu(789) - lu(413) * lu(787)
         lu(790) = lu(790) - lu(414) * lu(787)
         lu(791) = lu(791) - lu(415) * lu(787)
         lu(793) = lu(793) - lu(416) * lu(787)
         lu(796) = lu(796) - lu(417) * lu(787)
         lu(797) = lu(797) - lu(418) * lu(787)
         lu(800) = lu(800) - lu(419) * lu(787)
         lu(801) = lu(801) - lu(420) * lu(787)
         lu(802) = lu(802) - lu(421) * lu(787)
                                                                        
         lu(433) = 1. / lu(433)
         lu(434) = lu(434) * lu(433)
         lu(435) = lu(435) * lu(433)
         lu(436) = lu(436) * lu(433)
         lu(437) = lu(437) * lu(433)
         lu(438) = lu(438) * lu(433)
         lu(439) = lu(439) * lu(433)
         lu(440) = lu(440) * lu(433)
         lu(441) = lu(441) * lu(433)
         lu(442) = lu(442) * lu(433)
         lu(447) = lu(447) - lu(434) * lu(446)
         lu(448) = lu(448) - lu(435) * lu(446)
         lu(449) = lu(449) - lu(436) * lu(446)
         lu(450) = lu(450) - lu(437) * lu(446)
         lu(451) = lu(451) - lu(438) * lu(446)
         lu(452) = lu(452) - lu(439) * lu(446)
         lu(453) = lu(453) - lu(440) * lu(446)
         lu(454) = lu(454) - lu(441) * lu(446)
         lu(455) = lu(455) - lu(442) * lu(446)
         lu(474) = lu(474) - lu(434) * lu(473)
         lu(475) = lu(475) - lu(435) * lu(473)
         lu(476) = lu(476) - lu(436) * lu(473)
         lu(477) = lu(477) - lu(437) * lu(473)
         lu(478) = lu(478) - lu(438) * lu(473)
         lu(479) = lu(479) - lu(439) * lu(473)
         lu(480) = lu(480) - lu(440) * lu(473)
         lu(481) = lu(481) - lu(441) * lu(473)
         lu(482) = lu(482) - lu(442) * lu(473)
         lu(505) = lu(505) - lu(434) * lu(504)
         lu(506) = lu(506) - lu(435) * lu(504)
         lu(507) = lu(507) - lu(436) * lu(504)
         lu(509) = lu(509) - lu(437) * lu(504)
         lu(512) = lu(512) - lu(438) * lu(504)
         lu(513) = lu(513) - lu(439) * lu(504)
         lu(514) = lu(514) - lu(440) * lu(504)
         lu(515) = lu(515) - lu(441) * lu(504)
         lu(516) = lu(516) - lu(442) * lu(504)
         lu(556) = lu(556) - lu(434) * lu(555)
         lu(557) = lu(557) - lu(435) * lu(555)
         lu(558) = lu(558) - lu(436) * lu(555)
         lu(560) = lu(560) - lu(437) * lu(555)
         lu(563) = lu(563) - lu(438) * lu(555)
         lu(564) = lu(564) - lu(439) * lu(555)
         lu(567) = lu(567) - lu(440) * lu(555)
         lu(568) = lu(568) - lu(441) * lu(555)
         lu(569) = lu(569) - lu(442) * lu(555)
         lu(632) = lu(632) - lu(434) * lu(631)
         lu(633) = lu(633) - lu(435) * lu(631)
         lu(634) = lu(634) - lu(436) * lu(631)
         lu(636) = lu(636) - lu(437) * lu(631)
         lu(639) = lu(639) - lu(438) * lu(631)
         lu(640) = lu(640) - lu(439) * lu(631)
         lu(643) = lu(643) - lu(440) * lu(631)
         lu(644) = lu(644) - lu(441) * lu(631)
         lu(645) = lu(645) - lu(442) * lu(631)
         lu(676) = lu(676) - lu(434) * lu(675)
         lu(677) = lu(677) - lu(435) * lu(675)
         lu(678) = lu(678) - lu(436) * lu(675)
         lu(680) = lu(680) - lu(437) * lu(675)
         lu(683) = lu(683) - lu(438) * lu(675)
         lu(684) = lu(684) - lu(439) * lu(675)
         lu(687) = lu(687) - lu(440) * lu(675)
         lu(688) = lu(688) - lu(441) * lu(675)
         lu(689) = lu(689) - lu(442) * lu(675)
         lu(789) = lu(789) - lu(434) * lu(788)
         lu(790) = lu(790) - lu(435) * lu(788)
         lu(791) = lu(791) - lu(436) * lu(788)
         lu(793) = lu(793) - lu(437) * lu(788)
         lu(796) = lu(796) - lu(438) * lu(788)
         lu(797) = lu(797) - lu(439) * lu(788)
         lu(800) = lu(800) - lu(440) * lu(788)
         lu(801) = lu(801) - lu(441) * lu(788)
         lu(802) = lu(802) - lu(442) * lu(788)
         lu(816) = lu(816) - lu(434) * lu(815)
         lu(817) = lu(817) - lu(435) * lu(815)
         lu(818) = lu(818) - lu(436) * lu(815)
         lu(820) = lu(820) - lu(437) * lu(815)
         lu(823) = lu(823) - lu(438) * lu(815)
         lu(824) = lu(824) - lu(439) * lu(815)
         lu(827) = lu(827) - lu(440) * lu(815)
         lu(828) = lu(828) - lu(441) * lu(815)
         lu(829) = lu(829) - lu(442) * lu(815)
                                                                        
                                                                        
      end subroutine imp_lu_fac09
                                                                        
      subroutine imp_lu_fac10( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(447) = 1. / lu(447)
         lu(448) = lu(448) * lu(447)
         lu(449) = lu(449) * lu(447)
         lu(450) = lu(450) * lu(447)
         lu(451) = lu(451) * lu(447)
         lu(452) = lu(452) * lu(447)
         lu(453) = lu(453) * lu(447)
         lu(454) = lu(454) * lu(447)
         lu(455) = lu(455) * lu(447)
         lu(475) = lu(475) - lu(448) * lu(474)
         lu(476) = lu(476) - lu(449) * lu(474)
         lu(477) = lu(477) - lu(450) * lu(474)
         lu(478) = lu(478) - lu(451) * lu(474)
         lu(479) = lu(479) - lu(452) * lu(474)
         lu(480) = lu(480) - lu(453) * lu(474)
         lu(481) = lu(481) - lu(454) * lu(474)
         lu(482) = lu(482) - lu(455) * lu(474)
         lu(506) = lu(506) - lu(448) * lu(505)
         lu(507) = lu(507) - lu(449) * lu(505)
         lu(509) = lu(509) - lu(450) * lu(505)
         lu(512) = lu(512) - lu(451) * lu(505)
         lu(513) = lu(513) - lu(452) * lu(505)
         lu(514) = lu(514) - lu(453) * lu(505)
         lu(515) = lu(515) - lu(454) * lu(505)
         lu(516) = lu(516) - lu(455) * lu(505)
         lu(557) = lu(557) - lu(448) * lu(556)
         lu(558) = lu(558) - lu(449) * lu(556)
         lu(560) = lu(560) - lu(450) * lu(556)
         lu(563) = lu(563) - lu(451) * lu(556)
         lu(564) = lu(564) - lu(452) * lu(556)
         lu(567) = lu(567) - lu(453) * lu(556)
         lu(568) = lu(568) - lu(454) * lu(556)
         lu(569) = lu(569) - lu(455) * lu(556)
         lu(633) = lu(633) - lu(448) * lu(632)
         lu(634) = lu(634) - lu(449) * lu(632)
         lu(636) = lu(636) - lu(450) * lu(632)
         lu(639) = lu(639) - lu(451) * lu(632)
         lu(640) = lu(640) - lu(452) * lu(632)
         lu(643) = lu(643) - lu(453) * lu(632)
         lu(644) = lu(644) - lu(454) * lu(632)
         lu(645) = lu(645) - lu(455) * lu(632)
         lu(677) = lu(677) - lu(448) * lu(676)
         lu(678) = lu(678) - lu(449) * lu(676)
         lu(680) = lu(680) - lu(450) * lu(676)
         lu(683) = lu(683) - lu(451) * lu(676)
         lu(684) = lu(684) - lu(452) * lu(676)
         lu(687) = lu(687) - lu(453) * lu(676)
         lu(688) = lu(688) - lu(454) * lu(676)
         lu(689) = lu(689) - lu(455) * lu(676)
         lu(790) = lu(790) - lu(448) * lu(789)
         lu(791) = lu(791) - lu(449) * lu(789)
         lu(793) = lu(793) - lu(450) * lu(789)
         lu(796) = lu(796) - lu(451) * lu(789)
         lu(797) = lu(797) - lu(452) * lu(789)
         lu(800) = lu(800) - lu(453) * lu(789)
         lu(801) = lu(801) - lu(454) * lu(789)
         lu(802) = lu(802) - lu(455) * lu(789)
         lu(817) = lu(817) - lu(448) * lu(816)
         lu(818) = lu(818) - lu(449) * lu(816)
         lu(820) = lu(820) - lu(450) * lu(816)
         lu(823) = lu(823) - lu(451) * lu(816)
         lu(824) = lu(824) - lu(452) * lu(816)
         lu(827) = lu(827) - lu(453) * lu(816)
         lu(828) = lu(828) - lu(454) * lu(816)
         lu(829) = lu(829) - lu(455) * lu(816)
                                                                        
         lu(475) = 1. / lu(475)
         lu(476) = lu(476) * lu(475)
         lu(477) = lu(477) * lu(475)
         lu(478) = lu(478) * lu(475)
         lu(479) = lu(479) * lu(475)
         lu(480) = lu(480) * lu(475)
         lu(481) = lu(481) * lu(475)
         lu(482) = lu(482) * lu(475)
         lu(507) = lu(507) - lu(476) * lu(506)
         lu(509) = lu(509) - lu(477) * lu(506)
         lu(512) = lu(512) - lu(478) * lu(506)
         lu(513) = lu(513) - lu(479) * lu(506)
         lu(514) = lu(514) - lu(480) * lu(506)
         lu(515) = lu(515) - lu(481) * lu(506)
         lu(516) = lu(516) - lu(482) * lu(506)
         lu(524) = lu(524) - lu(476) * lu(523)
         lu(526) = lu(526) - lu(477) * lu(523)
         lu(529) = lu(529) - lu(478) * lu(523)
         lu(530) = lu(530) - lu(479) * lu(523)
         lu(533) = lu(533) - lu(480) * lu(523)
         lu(534) = lu(534) - lu(481) * lu(523)
         lu(535) = lu(535) - lu(482) * lu(523)
         lu(558) = lu(558) - lu(476) * lu(557)
         lu(560) = lu(560) - lu(477) * lu(557)
         lu(563) = lu(563) - lu(478) * lu(557)
         lu(564) = lu(564) - lu(479) * lu(557)
         lu(567) = lu(567) - lu(480) * lu(557)
         lu(568) = lu(568) - lu(481) * lu(557)
         lu(569) = lu(569) - lu(482) * lu(557)
         lu(576) = lu(576) - lu(476) * lu(575)
         lu(578) = lu(578) - lu(477) * lu(575)
         lu(581) = lu(581) - lu(478) * lu(575)
         lu(582) = lu(582) - lu(479) * lu(575)
         lu(585) = lu(585) - lu(480) * lu(575)
         lu(586) = lu(586) - lu(481) * lu(575)
         lu(587) = lu(587) - lu(482) * lu(575)
         lu(598) = lu(598) - lu(476) * lu(597)
         lu(600) = lu(600) - lu(477) * lu(597)
         lu(603) = - lu(478) * lu(597)
         lu(604) = lu(604) - lu(479) * lu(597)
         lu(607) = lu(607) - lu(480) * lu(597)
         lu(608) = lu(608) - lu(481) * lu(597)
         lu(609) = lu(609) - lu(482) * lu(597)
         lu(634) = lu(634) - lu(476) * lu(633)
         lu(636) = lu(636) - lu(477) * lu(633)
         lu(639) = lu(639) - lu(478) * lu(633)
         lu(640) = lu(640) - lu(479) * lu(633)
         lu(643) = lu(643) - lu(480) * lu(633)
         lu(644) = lu(644) - lu(481) * lu(633)
         lu(645) = lu(645) - lu(482) * lu(633)
         lu(678) = lu(678) - lu(476) * lu(677)
         lu(680) = lu(680) - lu(477) * lu(677)
         lu(683) = lu(683) - lu(478) * lu(677)
         lu(684) = lu(684) - lu(479) * lu(677)
         lu(687) = lu(687) - lu(480) * lu(677)
         lu(688) = lu(688) - lu(481) * lu(677)
         lu(689) = lu(689) - lu(482) * lu(677)
         lu(693) = - lu(476) * lu(692)
         lu(695) = lu(695) - lu(477) * lu(692)
         lu(698) = - lu(478) * lu(692)
         lu(699) = lu(699) - lu(479) * lu(692)
         lu(702) = lu(702) - lu(480) * lu(692)
         lu(703) = lu(703) - lu(481) * lu(692)
         lu(704) = - lu(482) * lu(692)
         lu(712) = lu(712) - lu(476) * lu(711)
         lu(714) = lu(714) - lu(477) * lu(711)
         lu(717) = lu(717) - lu(478) * lu(711)
         lu(718) = lu(718) - lu(479) * lu(711)
         lu(721) = lu(721) - lu(480) * lu(711)
         lu(722) = lu(722) - lu(481) * lu(711)
         lu(723) = lu(723) - lu(482) * lu(711)
         lu(729) = lu(729) - lu(476) * lu(728)
         lu(731) = lu(731) - lu(477) * lu(728)
         lu(734) = - lu(478) * lu(728)
         lu(735) = lu(735) - lu(479) * lu(728)
         lu(738) = lu(738) - lu(480) * lu(728)
         lu(739) = lu(739) - lu(481) * lu(728)
         lu(740) = lu(740) - lu(482) * lu(728)
         lu(791) = lu(791) - lu(476) * lu(790)
         lu(793) = lu(793) - lu(477) * lu(790)
         lu(796) = lu(796) - lu(478) * lu(790)
         lu(797) = lu(797) - lu(479) * lu(790)
         lu(800) = lu(800) - lu(480) * lu(790)
         lu(801) = lu(801) - lu(481) * lu(790)
         lu(802) = lu(802) - lu(482) * lu(790)
         lu(818) = lu(818) - lu(476) * lu(817)
         lu(820) = lu(820) - lu(477) * lu(817)
         lu(823) = lu(823) - lu(478) * lu(817)
         lu(824) = lu(824) - lu(479) * lu(817)
         lu(827) = lu(827) - lu(480) * lu(817)
         lu(828) = lu(828) - lu(481) * lu(817)
         lu(829) = lu(829) - lu(482) * lu(817)
                                                                        
         lu(507) = 1. / lu(507)
         lu(508) = lu(508) * lu(507)
         lu(509) = lu(509) * lu(507)
         lu(510) = lu(510) * lu(507)
         lu(511) = lu(511) * lu(507)
         lu(512) = lu(512) * lu(507)
         lu(513) = lu(513) * lu(507)
         lu(514) = lu(514) * lu(507)
         lu(515) = lu(515) * lu(507)
         lu(516) = lu(516) * lu(507)
         lu(525) = lu(525) - lu(508) * lu(524)
         lu(526) = lu(526) - lu(509) * lu(524)
         lu(527) = lu(527) - lu(510) * lu(524)
         lu(528) = lu(528) - lu(511) * lu(524)
         lu(529) = lu(529) - lu(512) * lu(524)
         lu(530) = lu(530) - lu(513) * lu(524)
         lu(533) = lu(533) - lu(514) * lu(524)
         lu(534) = lu(534) - lu(515) * lu(524)
         lu(535) = lu(535) - lu(516) * lu(524)
         lu(559) = lu(559) - lu(508) * lu(558)
         lu(560) = lu(560) - lu(509) * lu(558)
         lu(561) = lu(561) - lu(510) * lu(558)
         lu(562) = lu(562) - lu(511) * lu(558)
         lu(563) = lu(563) - lu(512) * lu(558)
         lu(564) = lu(564) - lu(513) * lu(558)
         lu(567) = lu(567) - lu(514) * lu(558)
         lu(568) = lu(568) - lu(515) * lu(558)
         lu(569) = lu(569) - lu(516) * lu(558)
         lu(577) = lu(577) - lu(508) * lu(576)
         lu(578) = lu(578) - lu(509) * lu(576)
         lu(579) = lu(579) - lu(510) * lu(576)
         lu(580) = lu(580) - lu(511) * lu(576)
         lu(581) = lu(581) - lu(512) * lu(576)
         lu(582) = lu(582) - lu(513) * lu(576)
         lu(585) = lu(585) - lu(514) * lu(576)
         lu(586) = lu(586) - lu(515) * lu(576)
         lu(587) = lu(587) - lu(516) * lu(576)
         lu(599) = lu(599) - lu(508) * lu(598)
         lu(600) = lu(600) - lu(509) * lu(598)
         lu(601) = lu(601) - lu(510) * lu(598)
         lu(602) = lu(602) - lu(511) * lu(598)
         lu(603) = lu(603) - lu(512) * lu(598)
         lu(604) = lu(604) - lu(513) * lu(598)
         lu(607) = lu(607) - lu(514) * lu(598)
         lu(608) = lu(608) - lu(515) * lu(598)
         lu(609) = lu(609) - lu(516) * lu(598)
         lu(635) = lu(635) - lu(508) * lu(634)
         lu(636) = lu(636) - lu(509) * lu(634)
         lu(637) = lu(637) - lu(510) * lu(634)
         lu(638) = lu(638) - lu(511) * lu(634)
         lu(639) = lu(639) - lu(512) * lu(634)
         lu(640) = lu(640) - lu(513) * lu(634)
         lu(643) = lu(643) - lu(514) * lu(634)
         lu(644) = lu(644) - lu(515) * lu(634)
         lu(645) = lu(645) - lu(516) * lu(634)
         lu(679) = lu(679) - lu(508) * lu(678)
         lu(680) = lu(680) - lu(509) * lu(678)
         lu(681) = lu(681) - lu(510) * lu(678)
         lu(682) = lu(682) - lu(511) * lu(678)
         lu(683) = lu(683) - lu(512) * lu(678)
         lu(684) = lu(684) - lu(513) * lu(678)
         lu(687) = lu(687) - lu(514) * lu(678)
         lu(688) = lu(688) - lu(515) * lu(678)
         lu(689) = lu(689) - lu(516) * lu(678)
         lu(694) = lu(694) - lu(508) * lu(693)
         lu(695) = lu(695) - lu(509) * lu(693)
         lu(696) = lu(696) - lu(510) * lu(693)
         lu(697) = lu(697) - lu(511) * lu(693)
         lu(698) = lu(698) - lu(512) * lu(693)
         lu(699) = lu(699) - lu(513) * lu(693)
         lu(702) = lu(702) - lu(514) * lu(693)
         lu(703) = lu(703) - lu(515) * lu(693)
         lu(704) = lu(704) - lu(516) * lu(693)
         lu(713) = lu(713) - lu(508) * lu(712)
         lu(714) = lu(714) - lu(509) * lu(712)
         lu(715) = lu(715) - lu(510) * lu(712)
         lu(716) = lu(716) - lu(511) * lu(712)
         lu(717) = lu(717) - lu(512) * lu(712)
         lu(718) = lu(718) - lu(513) * lu(712)
         lu(721) = lu(721) - lu(514) * lu(712)
         lu(722) = lu(722) - lu(515) * lu(712)
         lu(723) = lu(723) - lu(516) * lu(712)
         lu(730) = lu(730) - lu(508) * lu(729)
         lu(731) = lu(731) - lu(509) * lu(729)
         lu(732) = lu(732) - lu(510) * lu(729)
         lu(733) = lu(733) - lu(511) * lu(729)
         lu(734) = lu(734) - lu(512) * lu(729)
         lu(735) = lu(735) - lu(513) * lu(729)
         lu(738) = lu(738) - lu(514) * lu(729)
         lu(739) = lu(739) - lu(515) * lu(729)
         lu(740) = lu(740) - lu(516) * lu(729)
         lu(792) = lu(792) - lu(508) * lu(791)
         lu(793) = lu(793) - lu(509) * lu(791)
         lu(794) = lu(794) - lu(510) * lu(791)
         lu(795) = lu(795) - lu(511) * lu(791)
         lu(796) = lu(796) - lu(512) * lu(791)
         lu(797) = lu(797) - lu(513) * lu(791)
         lu(800) = lu(800) - lu(514) * lu(791)
         lu(801) = lu(801) - lu(515) * lu(791)
         lu(802) = lu(802) - lu(516) * lu(791)
         lu(819) = lu(819) - lu(508) * lu(818)
         lu(820) = lu(820) - lu(509) * lu(818)
         lu(821) = lu(821) - lu(510) * lu(818)
         lu(822) = lu(822) - lu(511) * lu(818)
         lu(823) = lu(823) - lu(512) * lu(818)
         lu(824) = lu(824) - lu(513) * lu(818)
         lu(827) = lu(827) - lu(514) * lu(818)
         lu(828) = lu(828) - lu(515) * lu(818)
         lu(829) = lu(829) - lu(516) * lu(818)
                                                                        
         lu(525) = 1. / lu(525)
         lu(526) = lu(526) * lu(525)
         lu(527) = lu(527) * lu(525)
         lu(528) = lu(528) * lu(525)
         lu(529) = lu(529) * lu(525)
         lu(530) = lu(530) * lu(525)
         lu(531) = lu(531) * lu(525)
         lu(532) = lu(532) * lu(525)
         lu(533) = lu(533) * lu(525)
         lu(534) = lu(534) * lu(525)
         lu(535) = lu(535) * lu(525)
         lu(560) = lu(560) - lu(526) * lu(559)
         lu(561) = lu(561) - lu(527) * lu(559)
         lu(562) = lu(562) - lu(528) * lu(559)
         lu(563) = lu(563) - lu(529) * lu(559)
         lu(564) = lu(564) - lu(530) * lu(559)
         lu(565) = lu(565) - lu(531) * lu(559)
         lu(566) = lu(566) - lu(532) * lu(559)
         lu(567) = lu(567) - lu(533) * lu(559)
         lu(568) = lu(568) - lu(534) * lu(559)
         lu(569) = lu(569) - lu(535) * lu(559)
         lu(578) = lu(578) - lu(526) * lu(577)
         lu(579) = lu(579) - lu(527) * lu(577)
         lu(580) = lu(580) - lu(528) * lu(577)
         lu(581) = lu(581) - lu(529) * lu(577)
         lu(582) = lu(582) - lu(530) * lu(577)
         lu(583) = lu(583) - lu(531) * lu(577)
         lu(584) = lu(584) - lu(532) * lu(577)
         lu(585) = lu(585) - lu(533) * lu(577)
         lu(586) = lu(586) - lu(534) * lu(577)
         lu(587) = lu(587) - lu(535) * lu(577)
         lu(600) = lu(600) - lu(526) * lu(599)
         lu(601) = lu(601) - lu(527) * lu(599)
         lu(602) = lu(602) - lu(528) * lu(599)
         lu(603) = lu(603) - lu(529) * lu(599)
         lu(604) = lu(604) - lu(530) * lu(599)
         lu(605) = lu(605) - lu(531) * lu(599)
         lu(606) = lu(606) - lu(532) * lu(599)
         lu(607) = lu(607) - lu(533) * lu(599)
         lu(608) = lu(608) - lu(534) * lu(599)
         lu(609) = lu(609) - lu(535) * lu(599)
         lu(636) = lu(636) - lu(526) * lu(635)
         lu(637) = lu(637) - lu(527) * lu(635)
         lu(638) = lu(638) - lu(528) * lu(635)
         lu(639) = lu(639) - lu(529) * lu(635)
         lu(640) = lu(640) - lu(530) * lu(635)
         lu(641) = lu(641) - lu(531) * lu(635)
         lu(642) = lu(642) - lu(532) * lu(635)
         lu(643) = lu(643) - lu(533) * lu(635)
         lu(644) = lu(644) - lu(534) * lu(635)
         lu(645) = lu(645) - lu(535) * lu(635)
         lu(680) = lu(680) - lu(526) * lu(679)
         lu(681) = lu(681) - lu(527) * lu(679)
         lu(682) = lu(682) - lu(528) * lu(679)
         lu(683) = lu(683) - lu(529) * lu(679)
         lu(684) = lu(684) - lu(530) * lu(679)
         lu(685) = lu(685) - lu(531) * lu(679)
         lu(686) = lu(686) - lu(532) * lu(679)
         lu(687) = lu(687) - lu(533) * lu(679)
         lu(688) = lu(688) - lu(534) * lu(679)
         lu(689) = lu(689) - lu(535) * lu(679)
         lu(695) = lu(695) - lu(526) * lu(694)
         lu(696) = lu(696) - lu(527) * lu(694)
         lu(697) = lu(697) - lu(528) * lu(694)
         lu(698) = lu(698) - lu(529) * lu(694)
         lu(699) = lu(699) - lu(530) * lu(694)
         lu(700) = lu(700) - lu(531) * lu(694)
         lu(701) = lu(701) - lu(532) * lu(694)
         lu(702) = lu(702) - lu(533) * lu(694)
         lu(703) = lu(703) - lu(534) * lu(694)
         lu(704) = lu(704) - lu(535) * lu(694)
         lu(714) = lu(714) - lu(526) * lu(713)
         lu(715) = lu(715) - lu(527) * lu(713)
         lu(716) = lu(716) - lu(528) * lu(713)
         lu(717) = lu(717) - lu(529) * lu(713)
         lu(718) = lu(718) - lu(530) * lu(713)
         lu(719) = lu(719) - lu(531) * lu(713)
         lu(720) = lu(720) - lu(532) * lu(713)
         lu(721) = lu(721) - lu(533) * lu(713)
         lu(722) = lu(722) - lu(534) * lu(713)
         lu(723) = lu(723) - lu(535) * lu(713)
         lu(731) = lu(731) - lu(526) * lu(730)
         lu(732) = lu(732) - lu(527) * lu(730)
         lu(733) = lu(733) - lu(528) * lu(730)
         lu(734) = lu(734) - lu(529) * lu(730)
         lu(735) = lu(735) - lu(530) * lu(730)
         lu(736) = lu(736) - lu(531) * lu(730)
         lu(737) = lu(737) - lu(532) * lu(730)
         lu(738) = lu(738) - lu(533) * lu(730)
         lu(739) = lu(739) - lu(534) * lu(730)
         lu(740) = lu(740) - lu(535) * lu(730)
         lu(793) = lu(793) - lu(526) * lu(792)
         lu(794) = lu(794) - lu(527) * lu(792)
         lu(795) = lu(795) - lu(528) * lu(792)
         lu(796) = lu(796) - lu(529) * lu(792)
         lu(797) = lu(797) - lu(530) * lu(792)
         lu(798) = lu(798) - lu(531) * lu(792)
         lu(799) = lu(799) - lu(532) * lu(792)
         lu(800) = lu(800) - lu(533) * lu(792)
         lu(801) = lu(801) - lu(534) * lu(792)
         lu(802) = lu(802) - lu(535) * lu(792)
         lu(820) = lu(820) - lu(526) * lu(819)
         lu(821) = lu(821) - lu(527) * lu(819)
         lu(822) = lu(822) - lu(528) * lu(819)
         lu(823) = lu(823) - lu(529) * lu(819)
         lu(824) = lu(824) - lu(530) * lu(819)
         lu(825) = lu(825) - lu(531) * lu(819)
         lu(826) = lu(826) - lu(532) * lu(819)
         lu(827) = lu(827) - lu(533) * lu(819)
         lu(828) = lu(828) - lu(534) * lu(819)
         lu(829) = lu(829) - lu(535) * lu(819)
                                                                        
         lu(560) = 1. / lu(560)
         lu(561) = lu(561) * lu(560)
         lu(562) = lu(562) * lu(560)
         lu(563) = lu(563) * lu(560)
         lu(564) = lu(564) * lu(560)
         lu(565) = lu(565) * lu(560)
         lu(566) = lu(566) * lu(560)
         lu(567) = lu(567) * lu(560)
         lu(568) = lu(568) * lu(560)
         lu(569) = lu(569) * lu(560)
         lu(579) = lu(579) - lu(561) * lu(578)
         lu(580) = lu(580) - lu(562) * lu(578)
         lu(581) = lu(581) - lu(563) * lu(578)
         lu(582) = lu(582) - lu(564) * lu(578)
         lu(583) = lu(583) - lu(565) * lu(578)
         lu(584) = lu(584) - lu(566) * lu(578)
         lu(585) = lu(585) - lu(567) * lu(578)
         lu(586) = lu(586) - lu(568) * lu(578)
         lu(587) = lu(587) - lu(569) * lu(578)
         lu(601) = lu(601) - lu(561) * lu(600)
         lu(602) = lu(602) - lu(562) * lu(600)
         lu(603) = lu(603) - lu(563) * lu(600)
         lu(604) = lu(604) - lu(564) * lu(600)
         lu(605) = lu(605) - lu(565) * lu(600)
         lu(606) = lu(606) - lu(566) * lu(600)
         lu(607) = lu(607) - lu(567) * lu(600)
         lu(608) = lu(608) - lu(568) * lu(600)
         lu(609) = lu(609) - lu(569) * lu(600)
         lu(637) = lu(637) - lu(561) * lu(636)
         lu(638) = lu(638) - lu(562) * lu(636)
         lu(639) = lu(639) - lu(563) * lu(636)
         lu(640) = lu(640) - lu(564) * lu(636)
         lu(641) = lu(641) - lu(565) * lu(636)
         lu(642) = lu(642) - lu(566) * lu(636)
         lu(643) = lu(643) - lu(567) * lu(636)
         lu(644) = lu(644) - lu(568) * lu(636)
         lu(645) = lu(645) - lu(569) * lu(636)
         lu(681) = lu(681) - lu(561) * lu(680)
         lu(682) = lu(682) - lu(562) * lu(680)
         lu(683) = lu(683) - lu(563) * lu(680)
         lu(684) = lu(684) - lu(564) * lu(680)
         lu(685) = lu(685) - lu(565) * lu(680)
         lu(686) = lu(686) - lu(566) * lu(680)
         lu(687) = lu(687) - lu(567) * lu(680)
         lu(688) = lu(688) - lu(568) * lu(680)
         lu(689) = lu(689) - lu(569) * lu(680)
         lu(696) = lu(696) - lu(561) * lu(695)
         lu(697) = lu(697) - lu(562) * lu(695)
         lu(698) = lu(698) - lu(563) * lu(695)
         lu(699) = lu(699) - lu(564) * lu(695)
         lu(700) = lu(700) - lu(565) * lu(695)
         lu(701) = lu(701) - lu(566) * lu(695)
         lu(702) = lu(702) - lu(567) * lu(695)
         lu(703) = lu(703) - lu(568) * lu(695)
         lu(704) = lu(704) - lu(569) * lu(695)
         lu(715) = lu(715) - lu(561) * lu(714)
         lu(716) = lu(716) - lu(562) * lu(714)
         lu(717) = lu(717) - lu(563) * lu(714)
         lu(718) = lu(718) - lu(564) * lu(714)
         lu(719) = lu(719) - lu(565) * lu(714)
         lu(720) = lu(720) - lu(566) * lu(714)
         lu(721) = lu(721) - lu(567) * lu(714)
         lu(722) = lu(722) - lu(568) * lu(714)
         lu(723) = lu(723) - lu(569) * lu(714)
         lu(732) = lu(732) - lu(561) * lu(731)
         lu(733) = lu(733) - lu(562) * lu(731)
         lu(734) = lu(734) - lu(563) * lu(731)
         lu(735) = lu(735) - lu(564) * lu(731)
         lu(736) = lu(736) - lu(565) * lu(731)
         lu(737) = lu(737) - lu(566) * lu(731)
         lu(738) = lu(738) - lu(567) * lu(731)
         lu(739) = lu(739) - lu(568) * lu(731)
         lu(740) = lu(740) - lu(569) * lu(731)
         lu(794) = lu(794) - lu(561) * lu(793)
         lu(795) = lu(795) - lu(562) * lu(793)
         lu(796) = lu(796) - lu(563) * lu(793)
         lu(797) = lu(797) - lu(564) * lu(793)
         lu(798) = lu(798) - lu(565) * lu(793)
         lu(799) = lu(799) - lu(566) * lu(793)
         lu(800) = lu(800) - lu(567) * lu(793)
         lu(801) = lu(801) - lu(568) * lu(793)
         lu(802) = lu(802) - lu(569) * lu(793)
         lu(821) = lu(821) - lu(561) * lu(820)
         lu(822) = lu(822) - lu(562) * lu(820)
         lu(823) = lu(823) - lu(563) * lu(820)
         lu(824) = lu(824) - lu(564) * lu(820)
         lu(825) = lu(825) - lu(565) * lu(820)
         lu(826) = lu(826) - lu(566) * lu(820)
         lu(827) = lu(827) - lu(567) * lu(820)
         lu(828) = lu(828) - lu(568) * lu(820)
         lu(829) = lu(829) - lu(569) * lu(820)
                                                                        
                                                                        
      end subroutine imp_lu_fac10
                                                                        
      subroutine imp_lu_fac11( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
         lu(579) = 1. / lu(579)
         lu(580) = lu(580) * lu(579)
         lu(581) = lu(581) * lu(579)
         lu(582) = lu(582) * lu(579)
         lu(583) = lu(583) * lu(579)
         lu(584) = lu(584) * lu(579)
         lu(585) = lu(585) * lu(579)
         lu(586) = lu(586) * lu(579)
         lu(587) = lu(587) * lu(579)
         lu(602) = lu(602) - lu(580) * lu(601)
         lu(603) = lu(603) - lu(581) * lu(601)
         lu(604) = lu(604) - lu(582) * lu(601)
         lu(605) = lu(605) - lu(583) * lu(601)
         lu(606) = lu(606) - lu(584) * lu(601)
         lu(607) = lu(607) - lu(585) * lu(601)
         lu(608) = lu(608) - lu(586) * lu(601)
         lu(609) = lu(609) - lu(587) * lu(601)
         lu(638) = lu(638) - lu(580) * lu(637)
         lu(639) = lu(639) - lu(581) * lu(637)
         lu(640) = lu(640) - lu(582) * lu(637)
         lu(641) = lu(641) - lu(583) * lu(637)
         lu(642) = lu(642) - lu(584) * lu(637)
         lu(643) = lu(643) - lu(585) * lu(637)
         lu(644) = lu(644) - lu(586) * lu(637)
         lu(645) = lu(645) - lu(587) * lu(637)
         lu(682) = lu(682) - lu(580) * lu(681)
         lu(683) = lu(683) - lu(581) * lu(681)
         lu(684) = lu(684) - lu(582) * lu(681)
         lu(685) = lu(685) - lu(583) * lu(681)
         lu(686) = lu(686) - lu(584) * lu(681)
         lu(687) = lu(687) - lu(585) * lu(681)
         lu(688) = lu(688) - lu(586) * lu(681)
         lu(689) = lu(689) - lu(587) * lu(681)
         lu(697) = lu(697) - lu(580) * lu(696)
         lu(698) = lu(698) - lu(581) * lu(696)
         lu(699) = lu(699) - lu(582) * lu(696)
         lu(700) = lu(700) - lu(583) * lu(696)
         lu(701) = lu(701) - lu(584) * lu(696)
         lu(702) = lu(702) - lu(585) * lu(696)
         lu(703) = lu(703) - lu(586) * lu(696)
         lu(704) = lu(704) - lu(587) * lu(696)
         lu(716) = lu(716) - lu(580) * lu(715)
         lu(717) = lu(717) - lu(581) * lu(715)
         lu(718) = lu(718) - lu(582) * lu(715)
         lu(719) = lu(719) - lu(583) * lu(715)
         lu(720) = lu(720) - lu(584) * lu(715)
         lu(721) = lu(721) - lu(585) * lu(715)
         lu(722) = lu(722) - lu(586) * lu(715)
         lu(723) = lu(723) - lu(587) * lu(715)
         lu(733) = lu(733) - lu(580) * lu(732)
         lu(734) = lu(734) - lu(581) * lu(732)
         lu(735) = lu(735) - lu(582) * lu(732)
         lu(736) = lu(736) - lu(583) * lu(732)
         lu(737) = lu(737) - lu(584) * lu(732)
         lu(738) = lu(738) - lu(585) * lu(732)
         lu(739) = lu(739) - lu(586) * lu(732)
         lu(740) = lu(740) - lu(587) * lu(732)
         lu(795) = lu(795) - lu(580) * lu(794)
         lu(796) = lu(796) - lu(581) * lu(794)
         lu(797) = lu(797) - lu(582) * lu(794)
         lu(798) = lu(798) - lu(583) * lu(794)
         lu(799) = lu(799) - lu(584) * lu(794)
         lu(800) = lu(800) - lu(585) * lu(794)
         lu(801) = lu(801) - lu(586) * lu(794)
         lu(802) = lu(802) - lu(587) * lu(794)
         lu(822) = lu(822) - lu(580) * lu(821)
         lu(823) = lu(823) - lu(581) * lu(821)
         lu(824) = lu(824) - lu(582) * lu(821)
         lu(825) = lu(825) - lu(583) * lu(821)
         lu(826) = lu(826) - lu(584) * lu(821)
         lu(827) = lu(827) - lu(585) * lu(821)
         lu(828) = lu(828) - lu(586) * lu(821)
         lu(829) = lu(829) - lu(587) * lu(821)
                                                                        
         lu(602) = 1. / lu(602)
         lu(603) = lu(603) * lu(602)
         lu(604) = lu(604) * lu(602)
         lu(605) = lu(605) * lu(602)
         lu(606) = lu(606) * lu(602)
         lu(607) = lu(607) * lu(602)
         lu(608) = lu(608) * lu(602)
         lu(609) = lu(609) * lu(602)
         lu(639) = lu(639) - lu(603) * lu(638)
         lu(640) = lu(640) - lu(604) * lu(638)
         lu(641) = lu(641) - lu(605) * lu(638)
         lu(642) = lu(642) - lu(606) * lu(638)
         lu(643) = lu(643) - lu(607) * lu(638)
         lu(644) = lu(644) - lu(608) * lu(638)
         lu(645) = lu(645) - lu(609) * lu(638)
         lu(683) = lu(683) - lu(603) * lu(682)
         lu(684) = lu(684) - lu(604) * lu(682)
         lu(685) = lu(685) - lu(605) * lu(682)
         lu(686) = lu(686) - lu(606) * lu(682)
         lu(687) = lu(687) - lu(607) * lu(682)
         lu(688) = lu(688) - lu(608) * lu(682)
         lu(689) = lu(689) - lu(609) * lu(682)
         lu(698) = lu(698) - lu(603) * lu(697)
         lu(699) = lu(699) - lu(604) * lu(697)
         lu(700) = lu(700) - lu(605) * lu(697)
         lu(701) = lu(701) - lu(606) * lu(697)
         lu(702) = lu(702) - lu(607) * lu(697)
         lu(703) = lu(703) - lu(608) * lu(697)
         lu(704) = lu(704) - lu(609) * lu(697)
         lu(717) = lu(717) - lu(603) * lu(716)
         lu(718) = lu(718) - lu(604) * lu(716)
         lu(719) = lu(719) - lu(605) * lu(716)
         lu(720) = lu(720) - lu(606) * lu(716)
         lu(721) = lu(721) - lu(607) * lu(716)
         lu(722) = lu(722) - lu(608) * lu(716)
         lu(723) = lu(723) - lu(609) * lu(716)
         lu(734) = lu(734) - lu(603) * lu(733)
         lu(735) = lu(735) - lu(604) * lu(733)
         lu(736) = lu(736) - lu(605) * lu(733)
         lu(737) = lu(737) - lu(606) * lu(733)
         lu(738) = lu(738) - lu(607) * lu(733)
         lu(739) = lu(739) - lu(608) * lu(733)
         lu(740) = lu(740) - lu(609) * lu(733)
         lu(796) = lu(796) - lu(603) * lu(795)
         lu(797) = lu(797) - lu(604) * lu(795)
         lu(798) = lu(798) - lu(605) * lu(795)
         lu(799) = lu(799) - lu(606) * lu(795)
         lu(800) = lu(800) - lu(607) * lu(795)
         lu(801) = lu(801) - lu(608) * lu(795)
         lu(802) = lu(802) - lu(609) * lu(795)
         lu(823) = lu(823) - lu(603) * lu(822)
         lu(824) = lu(824) - lu(604) * lu(822)
         lu(825) = lu(825) - lu(605) * lu(822)
         lu(826) = lu(826) - lu(606) * lu(822)
         lu(827) = lu(827) - lu(607) * lu(822)
         lu(828) = lu(828) - lu(608) * lu(822)
         lu(829) = lu(829) - lu(609) * lu(822)
                                                                        
         lu(639) = 1. / lu(639)
         lu(640) = lu(640) * lu(639)
         lu(641) = lu(641) * lu(639)
         lu(642) = lu(642) * lu(639)
         lu(643) = lu(643) * lu(639)
         lu(644) = lu(644) * lu(639)
         lu(645) = lu(645) * lu(639)
         lu(684) = lu(684) - lu(640) * lu(683)
         lu(685) = lu(685) - lu(641) * lu(683)
         lu(686) = lu(686) - lu(642) * lu(683)
         lu(687) = lu(687) - lu(643) * lu(683)
         lu(688) = lu(688) - lu(644) * lu(683)
         lu(689) = lu(689) - lu(645) * lu(683)
         lu(699) = lu(699) - lu(640) * lu(698)
         lu(700) = lu(700) - lu(641) * lu(698)
         lu(701) = lu(701) - lu(642) * lu(698)
         lu(702) = lu(702) - lu(643) * lu(698)
         lu(703) = lu(703) - lu(644) * lu(698)
         lu(704) = lu(704) - lu(645) * lu(698)
         lu(718) = lu(718) - lu(640) * lu(717)
         lu(719) = lu(719) - lu(641) * lu(717)
         lu(720) = lu(720) - lu(642) * lu(717)
         lu(721) = lu(721) - lu(643) * lu(717)
         lu(722) = lu(722) - lu(644) * lu(717)
         lu(723) = lu(723) - lu(645) * lu(717)
         lu(735) = lu(735) - lu(640) * lu(734)
         lu(736) = lu(736) - lu(641) * lu(734)
         lu(737) = lu(737) - lu(642) * lu(734)
         lu(738) = lu(738) - lu(643) * lu(734)
         lu(739) = lu(739) - lu(644) * lu(734)
         lu(740) = lu(740) - lu(645) * lu(734)
         lu(797) = lu(797) - lu(640) * lu(796)
         lu(798) = lu(798) - lu(641) * lu(796)
         lu(799) = lu(799) - lu(642) * lu(796)
         lu(800) = lu(800) - lu(643) * lu(796)
         lu(801) = lu(801) - lu(644) * lu(796)
         lu(802) = lu(802) - lu(645) * lu(796)
         lu(824) = lu(824) - lu(640) * lu(823)
         lu(825) = lu(825) - lu(641) * lu(823)
         lu(826) = lu(826) - lu(642) * lu(823)
         lu(827) = lu(827) - lu(643) * lu(823)
         lu(828) = lu(828) - lu(644) * lu(823)
         lu(829) = lu(829) - lu(645) * lu(823)
                                                                        
         lu(684) = 1. / lu(684)
         lu(685) = lu(685) * lu(684)
         lu(686) = lu(686) * lu(684)
         lu(687) = lu(687) * lu(684)
         lu(688) = lu(688) * lu(684)
         lu(689) = lu(689) * lu(684)
         lu(700) = lu(700) - lu(685) * lu(699)
         lu(701) = lu(701) - lu(686) * lu(699)
         lu(702) = lu(702) - lu(687) * lu(699)
         lu(703) = lu(703) - lu(688) * lu(699)
         lu(704) = lu(704) - lu(689) * lu(699)
         lu(719) = lu(719) - lu(685) * lu(718)
         lu(720) = lu(720) - lu(686) * lu(718)
         lu(721) = lu(721) - lu(687) * lu(718)
         lu(722) = lu(722) - lu(688) * lu(718)
         lu(723) = lu(723) - lu(689) * lu(718)
         lu(736) = lu(736) - lu(685) * lu(735)
         lu(737) = lu(737) - lu(686) * lu(735)
         lu(738) = lu(738) - lu(687) * lu(735)
         lu(739) = lu(739) - lu(688) * lu(735)
         lu(740) = lu(740) - lu(689) * lu(735)
         lu(798) = lu(798) - lu(685) * lu(797)
         lu(799) = lu(799) - lu(686) * lu(797)
         lu(800) = lu(800) - lu(687) * lu(797)
         lu(801) = lu(801) - lu(688) * lu(797)
         lu(802) = lu(802) - lu(689) * lu(797)
         lu(825) = lu(825) - lu(685) * lu(824)
         lu(826) = lu(826) - lu(686) * lu(824)
         lu(827) = lu(827) - lu(687) * lu(824)
         lu(828) = lu(828) - lu(688) * lu(824)
         lu(829) = lu(829) - lu(689) * lu(824)
                                                                        
         lu(700) = 1. / lu(700)
         lu(701) = lu(701) * lu(700)
         lu(702) = lu(702) * lu(700)
         lu(703) = lu(703) * lu(700)
         lu(704) = lu(704) * lu(700)
         lu(720) = lu(720) - lu(701) * lu(719)
         lu(721) = lu(721) - lu(702) * lu(719)
         lu(722) = lu(722) - lu(703) * lu(719)
         lu(723) = lu(723) - lu(704) * lu(719)
         lu(737) = lu(737) - lu(701) * lu(736)
         lu(738) = lu(738) - lu(702) * lu(736)
         lu(739) = lu(739) - lu(703) * lu(736)
         lu(740) = lu(740) - lu(704) * lu(736)
         lu(799) = lu(799) - lu(701) * lu(798)
         lu(800) = lu(800) - lu(702) * lu(798)
         lu(801) = lu(801) - lu(703) * lu(798)
         lu(802) = lu(802) - lu(704) * lu(798)
         lu(826) = lu(826) - lu(701) * lu(825)
         lu(827) = lu(827) - lu(702) * lu(825)
         lu(828) = lu(828) - lu(703) * lu(825)
         lu(829) = lu(829) - lu(704) * lu(825)
                                                                        
         lu(720) = 1. / lu(720)
         lu(721) = lu(721) * lu(720)
         lu(722) = lu(722) * lu(720)
         lu(723) = lu(723) * lu(720)
         lu(738) = lu(738) - lu(721) * lu(737)
         lu(739) = lu(739) - lu(722) * lu(737)
         lu(740) = lu(740) - lu(723) * lu(737)
         lu(800) = lu(800) - lu(721) * lu(799)
         lu(801) = lu(801) - lu(722) * lu(799)
         lu(802) = lu(802) - lu(723) * lu(799)
         lu(827) = lu(827) - lu(721) * lu(826)
         lu(828) = lu(828) - lu(722) * lu(826)
         lu(829) = lu(829) - lu(723) * lu(826)
                                                                        
         lu(738) = 1. / lu(738)
         lu(739) = lu(739) * lu(738)
         lu(740) = lu(740) * lu(738)
         lu(801) = lu(801) - lu(739) * lu(800)
         lu(802) = lu(802) - lu(740) * lu(800)
         lu(828) = lu(828) - lu(739) * lu(827)
         lu(829) = lu(829) - lu(740) * lu(827)
                                                                        
         lu(801) = 1. / lu(801)
         lu(802) = lu(802) * lu(801)
         lu(829) = lu(829) - lu(802) * lu(828)
                                                                        
         lu(829) = 1. / lu(829)
                                                                        
                                                                        
      end subroutine imp_lu_fac11
                                                                        
      subroutine imp_lu_fac( lu )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(imp_nzcnt)
                                                                        
      call imp_lu_fac01( lu )
      call imp_lu_fac02( lu )
      call imp_lu_fac03( lu )
      call imp_lu_fac04( lu )
      call imp_lu_fac05( lu )
      call imp_lu_fac06( lu )
      call imp_lu_fac07( lu )
      call imp_lu_fac08( lu )
      call imp_lu_fac09( lu )
      call imp_lu_fac10( lu )
      call imp_lu_fac11( lu )
                                                                        
      end subroutine imp_lu_fac
                                                                        
      end module MO_IMP_FACTOR_MOD

      module MO_ROD_FACTOR_MOD

      contains
                                                                        
      subroutine rod_lu_fac( lu )
                                                                        
      use CHEM_MODS_MOD, only : rod_nzcnt, clsze
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(inout) ::   lu(rod_nzcnt)
                                                                        
                                                                        
      end subroutine rod_lu_fac
                                                                        
      end module MO_ROD_FACTOR_MOD

      module MO_IMP_SOLVE_MOD

      contains
                                                                        
      subroutine imp_lu_slv01( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze, clscnt4
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(imp_nzcnt)
      real, intent(inout) ::   b(clscnt4)
                                                                        
!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
                                                                        
!-----------------------------------------------------------------------
!       ... Solve L * y = b
!-----------------------------------------------------------------------
                                                                        
                                                                        
                                                                        
                                                                        
         b(75) = b(75) - lu(7) * b(5)
                                                                        
         b(45) = b(45) - lu(9) * b(6)
         b(75) = b(75) - lu(10) * b(6)
                                                                        
         b(57) = b(57) - lu(12) * b(7)
         b(66) = b(66) - lu(13) * b(7)
                                                                        
         b(75) = b(75) - lu(16) * b(8)
                                                                        
         b(57) = b(57) - lu(18) * b(9)
                                                                        
         b(71) = b(71) - lu(20) * b(10)
         b(75) = b(75) - lu(21) * b(10)
                                                                        
         b(42) = b(42) - lu(23) * b(11)
         b(71) = b(71) - lu(24) * b(11)
         b(74) = b(74) - lu(25) * b(11)
                                                                        
         b(59) = b(59) - lu(27) * b(12)
         b(75) = b(75) - lu(28) * b(12)
                                                                        
         b(65) = b(65) - lu(31) * b(13)
         b(75) = b(75) - lu(32) * b(13)
         b(76) = b(76) - lu(33) * b(13)
                                                                        
         b(68) = b(68) - lu(35) * b(14)
         b(70) = b(70) - lu(36) * b(14)
         b(76) = b(76) - lu(37) * b(14)
                                                                        
         b(27) = b(27) - lu(39) * b(15)
         b(64) = b(64) - lu(40) * b(15)
         b(68) = b(68) - lu(41) * b(15)
         b(70) = b(70) - lu(42) * b(15)
         b(71) = b(71) - lu(43) * b(15)
         b(74) = b(74) - lu(44) * b(15)
         b(75) = b(75) - lu(45) * b(15)
                                                                        
         b(39) = b(39) - lu(47) * b(16)
         b(49) = b(49) - lu(48) * b(16)
         b(65) = b(65) - lu(49) * b(16)
         b(72) = b(72) - lu(50) * b(16)
                                                                        
         b(54) = b(54) - lu(52) * b(17)
         b(75) = b(75) - lu(53) * b(17)
         b(76) = b(76) - lu(54) * b(17)
                                                                        
         b(51) = b(51) - lu(56) * b(18)
         b(71) = b(71) - lu(57) * b(18)
         b(75) = b(75) - lu(58) * b(18)
                                                                        
         b(71) = b(71) - lu(60) * b(19)
         b(75) = b(75) - lu(61) * b(19)
         b(76) = b(76) - lu(62) * b(19)
                                                                        
         b(28) = b(28) - lu(64) * b(20)
         b(67) = b(67) - lu(65) * b(20)
         b(71) = b(71) - lu(66) * b(20)
         b(74) = b(74) - lu(67) * b(20)
         b(75) = b(75) - lu(68) * b(20)
                                                                        
         b(61) = b(61) - lu(70) * b(21)
         b(63) = b(63) - lu(71) * b(21)
         b(71) = b(71) - lu(72) * b(21)
         b(75) = b(75) - lu(73) * b(21)
                                                                        
         b(40) = b(40) - lu(75) * b(22)
         b(51) = b(51) - lu(76) * b(22)
         b(71) = b(71) - lu(77) * b(22)
         b(75) = b(75) - lu(78) * b(22)
                                                                        
         b(37) = b(37) - lu(80) * b(23)
         b(45) = b(45) - lu(81) * b(23)
         b(71) = b(71) - lu(82) * b(23)
         b(75) = b(75) - lu(83) * b(23)
                                                                        
         b(44) = b(44) - lu(85) * b(24)
         b(62) = b(62) - lu(86) * b(24)
         b(74) = b(74) - lu(87) * b(24)
         b(75) = b(75) - lu(88) * b(24)
                                                                        
         b(64) = b(64) - lu(90) * b(25)
         b(71) = b(71) - lu(91) * b(25)
         b(74) = b(74) - lu(92) * b(25)
         b(75) = b(75) - lu(93) * b(25)
                                                                        
         b(57) = b(57) - lu(95) * b(26)
         b(72) = b(72) - lu(96) * b(26)
                                                                        
         b(67) = b(67) - lu(98) * b(27)
         b(71) = b(71) - lu(99) * b(27)
         b(75) = b(75) - lu(100) * b(27)
                                                                        
         b(42) = b(42) - lu(103) * b(28)
         b(70) = b(70) - lu(104) * b(28)
         b(71) = b(71) - lu(105) * b(28)
         b(74) = b(74) - lu(106) * b(28)
         b(76) = b(76) - lu(107) * b(28)
                                                                        
         b(39) = b(39) - lu(109) * b(29)
         b(57) = b(57) - lu(110) * b(29)
         b(65) = b(65) - lu(111) * b(29)
         b(69) = b(69) - lu(112) * b(29)
         b(76) = b(76) - lu(113) * b(29)
                                                                        
         b(62) = b(62) - lu(115) * b(30)
         b(64) = b(64) - lu(116) * b(30)
         b(74) = b(74) - lu(117) * b(30)
         b(75) = b(75) - lu(118) * b(30)
                                                                        
         b(59) = b(59) - lu(120) * b(31)
         b(75) = b(75) - lu(121) * b(31)
                                                                        
         b(41) = b(41) - lu(123) * b(32)
         b(51) = b(51) - lu(124) * b(32)
         b(55) = b(55) - lu(125) * b(32)
         b(71) = b(71) - lu(126) * b(32)
         b(74) = b(74) - lu(127) * b(32)
         b(75) = b(75) - lu(128) * b(32)
                                                                        
         b(62) = b(62) - lu(130) * b(33)
         b(64) = b(64) - lu(131) * b(33)
         b(65) = b(65) - lu(132) * b(33)
         b(74) = b(74) - lu(133) * b(33)
         b(75) = b(75) - lu(134) * b(33)
         b(76) = b(76) - lu(135) * b(33)
                                                                        
         b(71) = b(71) - lu(137) * b(34)
         b(74) = b(74) - lu(138) * b(34)
         b(75) = b(75) - lu(139) * b(34)
                                                                        
         b(55) = b(55) - lu(141) * b(35)
         b(63) = b(63) - lu(142) * b(35)
         b(65) = b(65) - lu(143) * b(35)
         b(71) = b(71) - lu(144) * b(35)
         b(74) = b(74) - lu(145) * b(35)
         b(75) = b(75) - lu(146) * b(35)
         b(76) = b(76) - lu(147) * b(35)
                                                                        
         b(56) = b(56) - lu(149) * b(36)
         b(58) = b(58) - lu(150) * b(36)
         b(59) = b(59) - lu(151) * b(36)
         b(60) = b(60) - lu(152) * b(36)
         b(71) = b(71) - lu(153) * b(36)
         b(74) = b(74) - lu(154) * b(36)
         b(75) = b(75) - lu(155) * b(36)
                                                                        
         b(44) = b(44) - lu(157) * b(37)
         b(62) = b(62) - lu(158) * b(37)
         b(64) = b(64) - lu(159) * b(37)
         b(75) = b(75) - lu(160) * b(37)
                                                                        
         b(53) = b(53) - lu(164) * b(38)
         b(57) = b(57) - lu(165) * b(38)
         b(69) = b(69) - lu(166) * b(38)
         b(72) = b(72) - lu(167) * b(38)
         b(75) = b(75) - lu(168) * b(38)
                                                                        
         b(65) = b(65) - lu(170) * b(39)
         b(75) = b(75) - lu(171) * b(39)
         b(76) = b(76) - lu(172) * b(39)
                                                                        
         b(51) = b(51) - lu(177) * b(40)
         b(64) = b(64) - lu(178) * b(40)
         b(70) = b(70) - lu(179) * b(40)
         b(71) = b(71) - lu(180) * b(40)
         b(74) = b(74) - lu(181) * b(40)
         b(75) = b(75) - lu(182) * b(40)
         b(76) = b(76) - lu(183) * b(40)
                                                                        
         b(51) = b(51) - lu(186) * b(41)
         b(55) = b(55) - lu(187) * b(41)
         b(70) = b(70) - lu(188) * b(41)
         b(71) = b(71) - lu(189) * b(41)
         b(74) = b(74) - lu(190) * b(41)
         b(75) = b(75) - lu(191) * b(41)
         b(76) = b(76) - lu(192) * b(41)
                                                                        
         b(63) = b(63) - lu(194) * b(42)
         b(71) = b(71) - lu(195) * b(42)
         b(74) = b(74) - lu(196) * b(42)
         b(75) = b(75) - lu(197) * b(42)
                                                                        
         b(52) = b(52) - lu(199) * b(43)
         b(56) = b(56) - lu(200) * b(43)
         b(58) = b(58) - lu(201) * b(43)
         b(65) = b(65) - lu(202) * b(43)
         b(70) = b(70) - lu(203) * b(43)
         b(71) = b(71) - lu(204) * b(43)
         b(74) = b(74) - lu(205) * b(43)
         b(76) = b(76) - lu(206) * b(43)
                                                                        
         b(62) = b(62) - lu(209) * b(44)
         b(70) = b(70) - lu(210) * b(44)
         b(71) = b(71) - lu(211) * b(44)
         b(74) = b(74) - lu(212) * b(44)
         b(75) = b(75) - lu(213) * b(44)
         b(76) = b(76) - lu(214) * b(44)
                                                                        
         b(51) = b(51) - lu(219) * b(45)
         b(62) = b(62) - lu(220) * b(45)
         b(64) = b(64) - lu(221) * b(45)
         b(70) = b(70) - lu(222) * b(45)
         b(71) = b(71) - lu(223) * b(45)
         b(74) = b(74) - lu(224) * b(45)
         b(75) = b(75) - lu(225) * b(45)
         b(76) = b(76) - lu(226) * b(45)
                                                                        
         b(53) = b(53) - lu(231) * b(46)
         b(57) = b(57) - lu(232) * b(46)
         b(65) = b(65) - lu(233) * b(46)
         b(66) = b(66) - lu(234) * b(46)
         b(68) = b(68) - lu(235) * b(46)
         b(69) = b(69) - lu(236) * b(46)
         b(72) = b(72) - lu(237) * b(46)
         b(75) = b(75) - lu(238) * b(46)
         b(76) = b(76) - lu(239) * b(46)
                                                                        
         b(50) = b(50) - lu(242) * b(47)
         b(52) = b(52) - lu(243) * b(47)
         b(56) = b(56) - lu(244) * b(47)
         b(58) = b(58) - lu(245) * b(47)
         b(60) = b(60) - lu(246) * b(47)
         b(63) = b(63) - lu(247) * b(47)
         b(65) = b(65) - lu(248) * b(47)
         b(67) = b(67) - lu(249) * b(47)
         b(70) = b(70) - lu(250) * b(47)
         b(71) = b(71) - lu(251) * b(47)
         b(74) = b(74) - lu(252) * b(47)
         b(75) = b(75) - lu(253) * b(47)
         b(76) = b(76) - lu(254) * b(47)
                                                                        
         b(50) = b(50) - lu(258) * b(48)
         b(56) = b(56) - lu(259) * b(48)
         b(58) = b(58) - lu(260) * b(48)
         b(60) = b(60) - lu(261) * b(48)
         b(62) = b(62) - lu(262) * b(48)
         b(64) = b(64) - lu(263) * b(48)
         b(65) = b(65) - lu(264) * b(48)
         b(67) = b(67) - lu(265) * b(48)
         b(68) = b(68) - lu(266) * b(48)
         b(70) = b(70) - lu(267) * b(48)
         b(71) = b(71) - lu(268) * b(48)
         b(74) = b(74) - lu(269) * b(48)
         b(75) = b(75) - lu(270) * b(48)
         b(76) = b(76) - lu(271) * b(48)
                                                                        
                                                                        
      end subroutine imp_lu_slv01
                                                                        
      subroutine imp_lu_slv02( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze, clscnt4
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(imp_nzcnt)
      real, intent(inout) ::   b(clscnt4)
                                                                        
!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
                                                                        
!-----------------------------------------------------------------------
!       ... Solve L * y = b
!-----------------------------------------------------------------------
         b(53) = b(53) - lu(274) * b(49)
         b(57) = b(57) - lu(275) * b(49)
         b(68) = b(68) - lu(276) * b(49)
         b(69) = b(69) - lu(277) * b(49)
         b(72) = b(72) - lu(278) * b(49)
         b(73) = b(73) - lu(279) * b(49)
         b(75) = b(75) - lu(280) * b(49)
                                                                        
         b(51) = b(51) - lu(284) * b(50)
         b(54) = b(54) - lu(285) * b(50)
         b(55) = b(55) - lu(286) * b(50)
         b(64) = b(64) - lu(287) * b(50)
         b(65) = b(65) - lu(288) * b(50)
         b(67) = b(67) - lu(289) * b(50)
         b(70) = b(70) - lu(290) * b(50)
         b(71) = b(71) - lu(291) * b(50)
         b(74) = b(74) - lu(292) * b(50)
         b(75) = b(75) - lu(293) * b(50)
         b(76) = b(76) - lu(294) * b(50)
                                                                        
         b(62) = b(62) - lu(297) * b(51)
         b(64) = b(64) - lu(298) * b(51)
         b(65) = b(65) - lu(299) * b(51)
         b(71) = b(71) - lu(300) * b(51)
         b(75) = b(75) - lu(301) * b(51)
         b(76) = b(76) - lu(302) * b(51)
                                                                        
         b(59) = b(59) - lu(305) * b(52)
         b(65) = b(65) - lu(306) * b(52)
         b(67) = b(67) - lu(307) * b(52)
         b(71) = b(71) - lu(308) * b(52)
         b(74) = b(74) - lu(309) * b(52)
         b(75) = b(75) - lu(310) * b(52)
         b(76) = b(76) - lu(311) * b(52)
                                                                        
         b(57) = b(57) - lu(316) * b(53)
         b(68) = b(68) - lu(317) * b(53)
         b(69) = b(69) - lu(318) * b(53)
         b(72) = b(72) - lu(319) * b(53)
         b(73) = b(73) - lu(320) * b(53)
         b(75) = b(75) - lu(321) * b(53)
                                                                        
         b(62) = b(62) - lu(324) * b(54)
         b(65) = b(65) - lu(325) * b(54)
         b(71) = b(71) - lu(326) * b(54)
         b(75) = b(75) - lu(327) * b(54)
         b(76) = b(76) - lu(328) * b(54)
                                                                        
         b(62) = b(62) - lu(331) * b(55)
         b(65) = b(65) - lu(332) * b(55)
         b(71) = b(71) - lu(333) * b(55)
         b(74) = b(74) - lu(334) * b(55)
         b(75) = b(75) - lu(335) * b(55)
         b(76) = b(76) - lu(336) * b(55)
                                                                        
         b(61) = b(61) - lu(339) * b(56)
         b(62) = b(62) - lu(340) * b(56)
         b(63) = b(63) - lu(341) * b(56)
         b(65) = b(65) - lu(342) * b(56)
         b(67) = b(67) - lu(343) * b(56)
         b(71) = b(71) - lu(344) * b(56)
         b(74) = b(74) - lu(345) * b(56)
         b(75) = b(75) - lu(346) * b(56)
         b(76) = b(76) - lu(347) * b(56)
                                                                        
         b(64) = b(64) - lu(349) * b(57)
         b(66) = b(66) - lu(350) * b(57)
         b(67) = b(67) - lu(351) * b(57)
         b(69) = b(69) - lu(352) * b(57)
         b(71) = b(71) - lu(353) * b(57)
         b(74) = b(74) - lu(354) * b(57)
                                                                        
         b(61) = b(61) - lu(360) * b(58)
         b(62) = b(62) - lu(361) * b(58)
         b(64) = b(64) - lu(362) * b(58)
         b(65) = b(65) - lu(363) * b(58)
         b(67) = b(67) - lu(364) * b(58)
         b(70) = b(70) - lu(365) * b(58)
         b(71) = b(71) - lu(366) * b(58)
         b(74) = b(74) - lu(367) * b(58)
         b(75) = b(75) - lu(368) * b(58)
         b(76) = b(76) - lu(369) * b(58)
                                                                        
         b(62) = b(62) - lu(376) * b(59)
         b(63) = b(63) - lu(377) * b(59)
         b(64) = b(64) - lu(378) * b(59)
         b(65) = b(65) - lu(379) * b(59)
         b(70) = b(70) - lu(380) * b(59)
         b(71) = b(71) - lu(381) * b(59)
         b(74) = b(74) - lu(382) * b(59)
         b(75) = b(75) - lu(383) * b(59)
         b(76) = b(76) - lu(384) * b(59)
                                                                        
         b(61) = b(61) - lu(393) * b(60)
         b(62) = b(62) - lu(394) * b(60)
         b(63) = b(63) - lu(395) * b(60)
         b(64) = b(64) - lu(396) * b(60)
         b(65) = b(65) - lu(397) * b(60)
         b(67) = b(67) - lu(398) * b(60)
         b(70) = b(70) - lu(399) * b(60)
         b(71) = b(71) - lu(400) * b(60)
         b(74) = b(74) - lu(401) * b(60)
         b(75) = b(75) - lu(402) * b(60)
         b(76) = b(76) - lu(403) * b(60)
                                                                        
         b(62) = b(62) - lu(412) * b(61)
         b(63) = b(63) - lu(413) * b(61)
         b(64) = b(64) - lu(414) * b(61)
         b(65) = b(65) - lu(415) * b(61)
         b(67) = b(67) - lu(416) * b(61)
         b(70) = b(70) - lu(417) * b(61)
         b(71) = b(71) - lu(418) * b(61)
         b(74) = b(74) - lu(419) * b(61)
         b(75) = b(75) - lu(420) * b(61)
         b(76) = b(76) - lu(421) * b(61)
                                                                        
         b(63) = b(63) - lu(434) * b(62)
         b(64) = b(64) - lu(435) * b(62)
         b(65) = b(65) - lu(436) * b(62)
         b(67) = b(67) - lu(437) * b(62)
         b(70) = b(70) - lu(438) * b(62)
         b(71) = b(71) - lu(439) * b(62)
         b(74) = b(74) - lu(440) * b(62)
         b(75) = b(75) - lu(441) * b(62)
         b(76) = b(76) - lu(442) * b(62)
                                                                        
         b(64) = b(64) - lu(448) * b(63)
         b(65) = b(65) - lu(449) * b(63)
         b(67) = b(67) - lu(450) * b(63)
         b(70) = b(70) - lu(451) * b(63)
         b(71) = b(71) - lu(452) * b(63)
         b(74) = b(74) - lu(453) * b(63)
         b(75) = b(75) - lu(454) * b(63)
         b(76) = b(76) - lu(455) * b(63)
                                                                        
         b(65) = b(65) - lu(476) * b(64)
         b(67) = b(67) - lu(477) * b(64)
         b(70) = b(70) - lu(478) * b(64)
         b(71) = b(71) - lu(479) * b(64)
         b(74) = b(74) - lu(480) * b(64)
         b(75) = b(75) - lu(481) * b(64)
         b(76) = b(76) - lu(482) * b(64)
                                                                        
         b(66) = b(66) - lu(508) * b(65)
         b(67) = b(67) - lu(509) * b(65)
         b(68) = b(68) - lu(510) * b(65)
         b(69) = b(69) - lu(511) * b(65)
         b(70) = b(70) - lu(512) * b(65)
         b(71) = b(71) - lu(513) * b(65)
         b(74) = b(74) - lu(514) * b(65)
         b(75) = b(75) - lu(515) * b(65)
         b(76) = b(76) - lu(516) * b(65)
                                                                        
         b(67) = b(67) - lu(526) * b(66)
         b(68) = b(68) - lu(527) * b(66)
         b(69) = b(69) - lu(528) * b(66)
         b(70) = b(70) - lu(529) * b(66)
         b(71) = b(71) - lu(530) * b(66)
         b(72) = b(72) - lu(531) * b(66)
         b(73) = b(73) - lu(532) * b(66)
         b(74) = b(74) - lu(533) * b(66)
         b(75) = b(75) - lu(534) * b(66)
         b(76) = b(76) - lu(535) * b(66)
                                                                        
         b(68) = b(68) - lu(561) * b(67)
         b(69) = b(69) - lu(562) * b(67)
         b(70) = b(70) - lu(563) * b(67)
         b(71) = b(71) - lu(564) * b(67)
         b(72) = b(72) - lu(565) * b(67)
         b(73) = b(73) - lu(566) * b(67)
         b(74) = b(74) - lu(567) * b(67)
         b(75) = b(75) - lu(568) * b(67)
         b(76) = b(76) - lu(569) * b(67)
                                                                        
         b(69) = b(69) - lu(580) * b(68)
         b(70) = b(70) - lu(581) * b(68)
         b(71) = b(71) - lu(582) * b(68)
         b(72) = b(72) - lu(583) * b(68)
         b(73) = b(73) - lu(584) * b(68)
         b(74) = b(74) - lu(585) * b(68)
         b(75) = b(75) - lu(586) * b(68)
         b(76) = b(76) - lu(587) * b(68)
                                                                        
         b(70) = b(70) - lu(603) * b(69)
         b(71) = b(71) - lu(604) * b(69)
         b(72) = b(72) - lu(605) * b(69)
         b(73) = b(73) - lu(606) * b(69)
         b(74) = b(74) - lu(607) * b(69)
         b(75) = b(75) - lu(608) * b(69)
         b(76) = b(76) - lu(609) * b(69)
                                                                        
         b(71) = b(71) - lu(640) * b(70)
         b(72) = b(72) - lu(641) * b(70)
         b(73) = b(73) - lu(642) * b(70)
         b(74) = b(74) - lu(643) * b(70)
         b(75) = b(75) - lu(644) * b(70)
         b(76) = b(76) - lu(645) * b(70)
                                                                        
         b(72) = b(72) - lu(685) * b(71)
         b(73) = b(73) - lu(686) * b(71)
         b(74) = b(74) - lu(687) * b(71)
         b(75) = b(75) - lu(688) * b(71)
         b(76) = b(76) - lu(689) * b(71)
                                                                        
         b(73) = b(73) - lu(701) * b(72)
         b(74) = b(74) - lu(702) * b(72)
         b(75) = b(75) - lu(703) * b(72)
         b(76) = b(76) - lu(704) * b(72)
                                                                        
         b(74) = b(74) - lu(721) * b(73)
         b(75) = b(75) - lu(722) * b(73)
         b(76) = b(76) - lu(723) * b(73)
                                                                        
         b(75) = b(75) - lu(739) * b(74)
         b(76) = b(76) - lu(740) * b(74)
                                                                        
         b(76) = b(76) - lu(802) * b(75)
                                                                        
                                                                        
      end subroutine imp_lu_slv02
                                                                        
      subroutine imp_lu_slv03( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze, clscnt4
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(imp_nzcnt)
      real, intent(inout) ::   b(clscnt4)
                                                                        
!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
                                                                        
!-----------------------------------------------------------------------
!       ... Solve L * y = b
!-----------------------------------------------------------------------
                                                                        
!-----------------------------------------------------------------------
!       ... Solve U * x = y
!-----------------------------------------------------------------------
         b(76) = b(76) * lu(829)
         b(75) = b(75) - lu(828) * b(76)
         b(74) = b(74) - lu(827) * b(76)
         b(73) = b(73) - lu(826) * b(76)
         b(72) = b(72) - lu(825) * b(76)
         b(71) = b(71) - lu(824) * b(76)
         b(70) = b(70) - lu(823) * b(76)
         b(69) = b(69) - lu(822) * b(76)
         b(68) = b(68) - lu(821) * b(76)
         b(67) = b(67) - lu(820) * b(76)
         b(66) = b(66) - lu(819) * b(76)
         b(65) = b(65) - lu(818) * b(76)
         b(64) = b(64) - lu(817) * b(76)
         b(63) = b(63) - lu(816) * b(76)
         b(62) = b(62) - lu(815) * b(76)
         b(57) = b(57) - lu(814) * b(76)
         b(55) = b(55) - lu(813) * b(76)
         b(53) = b(53) - lu(812) * b(76)
         b(49) = b(49) - lu(811) * b(76)
         b(46) = b(46) - lu(810) * b(76)
         b(39) = b(39) - lu(809) * b(76)
         b(35) = b(35) - lu(808) * b(76)
         b(33) = b(33) - lu(807) * b(76)
         b(29) = b(29) - lu(806) * b(76)
         b(19) = b(19) - lu(805) * b(76)
         b(16) = b(16) - lu(804) * b(76)
         b(14) = b(14) - lu(803) * b(76)
                                                                        
         b(75) = b(75) * lu(801)
         b(74) = b(74) - lu(800) * b(75)
         b(73) = b(73) - lu(799) * b(75)
         b(72) = b(72) - lu(798) * b(75)
         b(71) = b(71) - lu(797) * b(75)
         b(70) = b(70) - lu(796) * b(75)
         b(69) = b(69) - lu(795) * b(75)
         b(68) = b(68) - lu(794) * b(75)
         b(67) = b(67) - lu(793) * b(75)
         b(66) = b(66) - lu(792) * b(75)
         b(65) = b(65) - lu(791) * b(75)
         b(64) = b(64) - lu(790) * b(75)
         b(63) = b(63) - lu(789) * b(75)
         b(62) = b(62) - lu(788) * b(75)
         b(61) = b(61) - lu(787) * b(75)
         b(60) = b(60) - lu(786) * b(75)
         b(59) = b(59) - lu(785) * b(75)
         b(58) = b(58) - lu(784) * b(75)
         b(57) = b(57) - lu(783) * b(75)
         b(56) = b(56) - lu(782) * b(75)
         b(55) = b(55) - lu(781) * b(75)
         b(54) = b(54) - lu(780) * b(75)
         b(53) = b(53) - lu(779) * b(75)
         b(52) = b(52) - lu(778) * b(75)
         b(51) = b(51) - lu(777) * b(75)
         b(50) = b(50) - lu(776) * b(75)
         b(48) = b(48) - lu(775) * b(75)
         b(47) = b(47) - lu(774) * b(75)
         b(45) = b(45) - lu(773) * b(75)
         b(44) = b(44) - lu(772) * b(75)
         b(42) = b(42) - lu(771) * b(75)
         b(41) = b(41) - lu(770) * b(75)
         b(40) = b(40) - lu(769) * b(75)
         b(39) = b(39) - lu(768) * b(75)
         b(37) = b(37) - lu(767) * b(75)
         b(36) = b(36) - lu(766) * b(75)
         b(35) = b(35) - lu(765) * b(75)
         b(34) = b(34) - lu(764) * b(75)
         b(33) = b(33) - lu(763) * b(75)
         b(32) = b(32) - lu(762) * b(75)
         b(31) = b(31) - lu(761) * b(75)
         b(30) = b(30) - lu(760) * b(75)
         b(28) = b(28) - lu(759) * b(75)
         b(27) = b(27) - lu(758) * b(75)
         b(25) = b(25) - lu(757) * b(75)
         b(24) = b(24) - lu(756) * b(75)
         b(23) = b(23) - lu(755) * b(75)
         b(22) = b(22) - lu(754) * b(75)
         b(21) = b(21) - lu(753) * b(75)
         b(20) = b(20) - lu(752) * b(75)
         b(19) = b(19) - lu(751) * b(75)
         b(18) = b(18) - lu(750) * b(75)
         b(17) = b(17) - lu(749) * b(75)
         b(13) = b(13) - lu(748) * b(75)
         b(12) = b(12) - lu(747) * b(75)
         b(10) = b(10) - lu(746) * b(75)
         b(8) = b(8) - lu(745) * b(75)
         b(6) = b(6) - lu(744) * b(75)
         b(5) = b(5) - lu(743) * b(75)
         b(4) = b(4) - lu(742) * b(75)
         b(1) = b(1) - lu(741) * b(75)
                                                                        
         b(74) = b(74) * lu(738)
         b(73) = b(73) - lu(737) * b(74)
         b(72) = b(72) - lu(736) * b(74)
         b(71) = b(71) - lu(735) * b(74)
         b(70) = b(70) - lu(734) * b(74)
         b(69) = b(69) - lu(733) * b(74)
         b(68) = b(68) - lu(732) * b(74)
         b(67) = b(67) - lu(731) * b(74)
         b(66) = b(66) - lu(730) * b(74)
         b(65) = b(65) - lu(729) * b(74)
         b(64) = b(64) - lu(728) * b(74)
         b(57) = b(57) - lu(727) * b(74)
         b(53) = b(53) - lu(726) * b(74)
         b(39) = b(39) - lu(725) * b(74)
         b(27) = b(27) - lu(724) * b(74)
                                                                        
         b(73) = b(73) * lu(720)
         b(72) = b(72) - lu(719) * b(73)
         b(71) = b(71) - lu(718) * b(73)
         b(70) = b(70) - lu(717) * b(73)
         b(69) = b(69) - lu(716) * b(73)
         b(68) = b(68) - lu(715) * b(73)
         b(67) = b(67) - lu(714) * b(73)
         b(66) = b(66) - lu(713) * b(73)
         b(65) = b(65) - lu(712) * b(73)
         b(64) = b(64) - lu(711) * b(73)
         b(57) = b(57) - lu(710) * b(73)
         b(53) = b(53) - lu(709) * b(73)
         b(49) = b(49) - lu(708) * b(73)
         b(39) = b(39) - lu(707) * b(73)
         b(26) = b(26) - lu(706) * b(73)
         b(16) = b(16) - lu(705) * b(73)
                                                                        
         b(72) = b(72) * lu(700)
         b(71) = b(71) - lu(699) * b(72)
         b(70) = b(70) - lu(698) * b(72)
         b(69) = b(69) - lu(697) * b(72)
         b(68) = b(68) - lu(696) * b(72)
         b(67) = b(67) - lu(695) * b(72)
         b(66) = b(66) - lu(694) * b(72)
         b(65) = b(65) - lu(693) * b(72)
         b(64) = b(64) - lu(692) * b(72)
         b(57) = b(57) - lu(691) * b(72)
         b(53) = b(53) - lu(690) * b(72)
                                                                        
         b(71) = b(71) * lu(684)
         b(70) = b(70) - lu(683) * b(71)
         b(69) = b(69) - lu(682) * b(71)
         b(68) = b(68) - lu(681) * b(71)
         b(67) = b(67) - lu(680) * b(71)
         b(66) = b(66) - lu(679) * b(71)
         b(65) = b(65) - lu(678) * b(71)
         b(64) = b(64) - lu(677) * b(71)
         b(63) = b(63) - lu(676) * b(71)
         b(62) = b(62) - lu(675) * b(71)
         b(61) = b(61) - lu(674) * b(71)
         b(60) = b(60) - lu(673) * b(71)
         b(59) = b(59) - lu(672) * b(71)
         b(58) = b(58) - lu(671) * b(71)
         b(57) = b(57) - lu(670) * b(71)
         b(56) = b(56) - lu(669) * b(71)
         b(55) = b(55) - lu(668) * b(71)
         b(53) = b(53) - lu(667) * b(71)
         b(52) = b(52) - lu(666) * b(71)
         b(51) = b(51) - lu(665) * b(71)
         b(49) = b(49) - lu(664) * b(71)
         b(45) = b(45) - lu(663) * b(71)
         b(44) = b(44) - lu(662) * b(71)
         b(43) = b(43) - lu(661) * b(71)
         b(41) = b(41) - lu(660) * b(71)
         b(40) = b(40) - lu(659) * b(71)
         b(38) = b(38) - lu(658) * b(71)
         b(37) = b(37) - lu(657) * b(71)
         b(36) = b(36) - lu(656) * b(71)
         b(32) = b(32) - lu(655) * b(71)
         b(30) = b(30) - lu(654) * b(71)
         b(25) = b(25) - lu(653) * b(71)
         b(24) = b(24) - lu(652) * b(71)
         b(23) = b(23) - lu(651) * b(71)
         b(22) = b(22) - lu(650) * b(71)
         b(21) = b(21) - lu(649) * b(71)
         b(19) = b(19) - lu(648) * b(71)
         b(12) = b(12) - lu(647) * b(71)
         b(10) = b(10) - lu(646) * b(71)
                                                                        
         b(70) = b(70) * lu(639)
         b(69) = b(69) - lu(638) * b(70)
         b(68) = b(68) - lu(637) * b(70)
         b(67) = b(67) - lu(636) * b(70)
         b(66) = b(66) - lu(635) * b(70)
         b(65) = b(65) - lu(634) * b(70)
         b(64) = b(64) - lu(633) * b(70)
         b(63) = b(63) - lu(632) * b(70)
         b(62) = b(62) - lu(631) * b(70)
         b(61) = b(61) - lu(630) * b(70)
         b(60) = b(60) - lu(629) * b(70)
         b(59) = b(59) - lu(628) * b(70)
         b(58) = b(58) - lu(627) * b(70)
         b(57) = b(57) - lu(626) * b(70)
         b(56) = b(56) - lu(625) * b(70)
         b(55) = b(55) - lu(624) * b(70)
         b(54) = b(54) - lu(623) * b(70)
         b(52) = b(52) - lu(622) * b(70)
         b(51) = b(51) - lu(621) * b(70)
         b(45) = b(45) - lu(620) * b(70)
         b(44) = b(44) - lu(619) * b(70)
         b(43) = b(43) - lu(618) * b(70)
         b(42) = b(42) - lu(617) * b(70)
         b(41) = b(41) - lu(616) * b(70)
         b(40) = b(40) - lu(615) * b(70)
         b(37) = b(37) - lu(614) * b(70)
         b(31) = b(31) - lu(613) * b(70)
         b(28) = b(28) - lu(612) * b(70)
         b(14) = b(14) - lu(611) * b(70)
         b(11) = b(11) - lu(610) * b(70)
                                                                        
         b(69) = b(69) * lu(602)
         b(68) = b(68) - lu(601) * b(69)
         b(67) = b(67) - lu(600) * b(69)
         b(66) = b(66) - lu(599) * b(69)
         b(65) = b(65) - lu(598) * b(69)
         b(64) = b(64) - lu(597) * b(69)
         b(57) = b(57) - lu(596) * b(69)
         b(53) = b(53) - lu(595) * b(69)
         b(49) = b(49) - lu(594) * b(69)
         b(46) = b(46) - lu(593) * b(69)
         b(39) = b(39) - lu(592) * b(69)
         b(38) = b(38) - lu(591) * b(69)
         b(29) = b(29) - lu(590) * b(69)
         b(26) = b(26) - lu(589) * b(69)
         b(9) = b(9) - lu(588) * b(69)
                                                                        
                                                                        
      end subroutine imp_lu_slv03
                                                                        
      subroutine imp_lu_slv04( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze, clscnt4
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(imp_nzcnt)
      real, intent(inout) ::   b(clscnt4)
                                                                        
!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
                                                                        
!-----------------------------------------------------------------------
!       ... Solve L * y = b
!-----------------------------------------------------------------------
         b(68) = b(68) * lu(579)
         b(67) = b(67) - lu(578) * b(68)
         b(66) = b(66) - lu(577) * b(68)
         b(65) = b(65) - lu(576) * b(68)
         b(64) = b(64) - lu(575) * b(68)
         b(57) = b(57) - lu(574) * b(68)
         b(53) = b(53) - lu(573) * b(68)
         b(49) = b(49) - lu(572) * b(68)
         b(46) = b(46) - lu(571) * b(68)
         b(27) = b(27) - lu(570) * b(68)
                                                                        
         b(67) = b(67) * lu(560)
         b(66) = b(66) - lu(559) * b(67)
         b(65) = b(65) - lu(558) * b(67)
         b(64) = b(64) - lu(557) * b(67)
         b(63) = b(63) - lu(556) * b(67)
         b(62) = b(62) - lu(555) * b(67)
         b(61) = b(61) - lu(554) * b(67)
         b(60) = b(60) - lu(553) * b(67)
         b(59) = b(59) - lu(552) * b(67)
         b(58) = b(58) - lu(551) * b(67)
         b(57) = b(57) - lu(550) * b(67)
         b(56) = b(56) - lu(549) * b(67)
         b(55) = b(55) - lu(548) * b(67)
         b(54) = b(54) - lu(547) * b(67)
         b(52) = b(52) - lu(546) * b(67)
         b(51) = b(51) - lu(545) * b(67)
         b(50) = b(50) - lu(544) * b(67)
         b(48) = b(48) - lu(543) * b(67)
         b(47) = b(47) - lu(542) * b(67)
         b(42) = b(42) - lu(541) * b(67)
         b(31) = b(31) - lu(540) * b(67)
         b(28) = b(28) - lu(539) * b(67)
         b(27) = b(27) - lu(538) * b(67)
         b(20) = b(20) - lu(537) * b(67)
         b(15) = b(15) - lu(536) * b(67)
                                                                        
         b(66) = b(66) * lu(525)
         b(65) = b(65) - lu(524) * b(66)
         b(64) = b(64) - lu(523) * b(66)
         b(57) = b(57) - lu(522) * b(66)
         b(53) = b(53) - lu(521) * b(66)
         b(46) = b(46) - lu(520) * b(66)
         b(38) = b(38) - lu(519) * b(66)
         b(26) = b(26) - lu(518) * b(66)
         b(7) = b(7) - lu(517) * b(66)
                                                                        
         b(65) = b(65) * lu(507)
         b(64) = b(64) - lu(506) * b(65)
         b(63) = b(63) - lu(505) * b(65)
         b(62) = b(62) - lu(504) * b(65)
         b(61) = b(61) - lu(503) * b(65)
         b(60) = b(60) - lu(502) * b(65)
         b(59) = b(59) - lu(501) * b(65)
         b(58) = b(58) - lu(500) * b(65)
         b(57) = b(57) - lu(499) * b(65)
         b(56) = b(56) - lu(498) * b(65)
         b(55) = b(55) - lu(497) * b(65)
         b(54) = b(54) - lu(496) * b(65)
         b(52) = b(52) - lu(495) * b(65)
         b(51) = b(51) - lu(494) * b(65)
         b(50) = b(50) - lu(493) * b(65)
         b(48) = b(48) - lu(492) * b(65)
         b(47) = b(47) - lu(491) * b(65)
         b(43) = b(43) - lu(490) * b(65)
         b(42) = b(42) - lu(489) * b(65)
         b(39) = b(39) - lu(488) * b(65)
         b(31) = b(31) - lu(487) * b(65)
         b(29) = b(29) - lu(486) * b(65)
         b(17) = b(17) - lu(485) * b(65)
         b(13) = b(13) - lu(484) * b(65)
         b(8) = b(8) - lu(483) * b(65)
                                                                        
         b(64) = b(64) * lu(475)
         b(63) = b(63) - lu(474) * b(64)
         b(62) = b(62) - lu(473) * b(64)
         b(61) = b(61) - lu(472) * b(64)
         b(60) = b(60) - lu(471) * b(64)
         b(59) = b(59) - lu(470) * b(64)
         b(58) = b(58) - lu(469) * b(64)
         b(56) = b(56) - lu(468) * b(64)
         b(55) = b(55) - lu(467) * b(64)
         b(54) = b(54) - lu(466) * b(64)
         b(51) = b(51) - lu(465) * b(64)
         b(45) = b(45) - lu(464) * b(64)
         b(44) = b(44) - lu(463) * b(64)
         b(42) = b(42) - lu(462) * b(64)
         b(40) = b(40) - lu(461) * b(64)
         b(37) = b(37) - lu(460) * b(64)
         b(34) = b(34) - lu(459) * b(64)
         b(31) = b(31) - lu(458) * b(64)
         b(25) = b(25) - lu(457) * b(64)
         b(18) = b(18) - lu(456) * b(64)
                                                                        
         b(63) = b(63) * lu(447)
         b(62) = b(62) - lu(446) * b(63)
         b(55) = b(55) - lu(445) * b(63)
         b(35) = b(35) - lu(444) * b(63)
         b(30) = b(30) - lu(443) * b(63)
                                                                        
         b(62) = b(62) * lu(433)
         b(61) = b(61) - lu(432) * b(62)
         b(60) = b(60) - lu(431) * b(62)
         b(59) = b(59) - lu(430) * b(62)
         b(58) = b(58) - lu(429) * b(62)
         b(56) = b(56) - lu(428) * b(62)
         b(55) = b(55) - lu(427) * b(62)
         b(54) = b(54) - lu(426) * b(62)
         b(42) = b(42) - lu(425) * b(62)
         b(33) = b(33) - lu(424) * b(62)
         b(31) = b(31) - lu(423) * b(62)
         b(30) = b(30) - lu(422) * b(62)
                                                                        
         b(61) = b(61) * lu(411)
         b(59) = b(59) - lu(410) * b(61)
         b(55) = b(55) - lu(409) * b(61)
         b(54) = b(54) - lu(408) * b(61)
         b(52) = b(52) - lu(407) * b(61)
         b(42) = b(42) - lu(406) * b(61)
         b(34) = b(34) - lu(405) * b(61)
         b(21) = b(21) - lu(404) * b(61)
                                                                        
         b(60) = b(60) * lu(392)
         b(59) = b(59) - lu(391) * b(60)
         b(58) = b(58) - lu(390) * b(60)
         b(56) = b(56) - lu(389) * b(60)
         b(52) = b(52) - lu(388) * b(60)
         b(36) = b(36) - lu(387) * b(60)
         b(34) = b(34) - lu(386) * b(60)
         b(31) = b(31) - lu(385) * b(60)
                                                                        
         b(59) = b(59) * lu(375)
         b(55) = b(55) - lu(374) * b(59)
         b(54) = b(54) - lu(373) * b(59)
         b(42) = b(42) - lu(372) * b(59)
         b(34) = b(34) - lu(371) * b(59)
         b(12) = b(12) - lu(370) * b(59)
                                                                        
         b(58) = b(58) * lu(359)
         b(55) = b(55) - lu(358) * b(58)
         b(54) = b(54) - lu(357) * b(58)
         b(51) = b(51) - lu(356) * b(58)
         b(50) = b(50) - lu(355) * b(58)
                                                                        
         b(57) = b(57) * lu(348)
                                                                        
         b(56) = b(56) * lu(338)
         b(54) = b(54) - lu(337) * b(56)
                                                                        
         b(55) = b(55) * lu(330)
         b(54) = b(54) - lu(329) * b(55)
                                                                        
         b(54) = b(54) * lu(323)
         b(39) = b(39) - lu(322) * b(54)
                                                                        
         b(53) = b(53) * lu(315)
         b(49) = b(49) - lu(314) * b(53)
         b(38) = b(38) - lu(313) * b(53)
         b(26) = b(26) - lu(312) * b(53)
                                                                        
         b(52) = b(52) * lu(304)
         b(31) = b(31) - lu(303) * b(52)
                                                                        
         b(51) = b(51) * lu(296)
         b(39) = b(39) - lu(295) * b(51)
                                                                        
         b(50) = b(50) * lu(283)
         b(41) = b(41) - lu(282) * b(50)
         b(17) = b(17) - lu(281) * b(50)
                                                                        
         b(49) = b(49) * lu(273)
         b(26) = b(26) - lu(272) * b(49)
                                                                        
         b(48) = b(48) * lu(257)
         b(44) = b(44) - lu(256) * b(48)
         b(37) = b(37) - lu(255) * b(48)
                                                                        
         b(47) = b(47) * lu(241)
         b(43) = b(43) - lu(240) * b(47)
                                                                        
         b(46) = b(46) * lu(230)
         b(39) = b(39) - lu(229) * b(46)
         b(38) = b(38) - lu(228) * b(46)
         b(9) = b(9) - lu(227) * b(46)
                                                                        
         b(45) = b(45) * lu(218)
         b(44) = b(44) - lu(217) * b(45)
         b(37) = b(37) - lu(216) * b(45)
         b(23) = b(23) - lu(215) * b(45)
                                                                        
         b(44) = b(44) * lu(208)
         b(24) = b(24) - lu(207) * b(44)
                                                                        
         b(43) = b(43) * lu(198)
                                                                        
         b(42) = b(42) * lu(193)
                                                                        
         b(41) = b(41) * lu(185)
         b(32) = b(32) - lu(184) * b(41)
                                                                        
         b(40) = b(40) * lu(176)
         b(34) = b(34) - lu(175) * b(40)
         b(22) = b(22) - lu(174) * b(40)
         b(18) = b(18) - lu(173) * b(40)
                                                                        
         b(39) = b(39) * lu(169)
                                                                        
         b(38) = b(38) * lu(163)
         b(26) = b(26) - lu(162) * b(38)
         b(9) = b(9) - lu(161) * b(38)
                                                                        
         b(37) = b(37) * lu(156)
                                                                        
         b(36) = b(36) * lu(148)
                                                                        
         b(35) = b(35) * lu(140)
                                                                        
         b(34) = b(34) * lu(136)
                                                                        
         b(33) = b(33) * lu(129)
                                                                        
         b(32) = b(32) * lu(122)
                                                                        
         b(31) = b(31) * lu(119)
                                                                        
         b(30) = b(30) * lu(114)
                                                                        
         b(29) = b(29) * lu(108)
                                                                        
         b(28) = b(28) * lu(102)
         b(11) = b(11) - lu(101) * b(28)
                                                                        
         b(27) = b(27) * lu(97)
                                                                        
         b(26) = b(26) * lu(94)
                                                                        
         b(25) = b(25) * lu(89)
                                                                        
         b(24) = b(24) * lu(84)
                                                                        
         b(23) = b(23) * lu(79)
                                                                        
         b(22) = b(22) * lu(74)
                                                                        
         b(21) = b(21) * lu(69)
                                                                        
         b(20) = b(20) * lu(63)
                                                                        
         b(19) = b(19) * lu(59)
                                                                        
         b(18) = b(18) * lu(55)
                                                                        
                                                                        
      end subroutine imp_lu_slv04
                                                                        
      subroutine imp_lu_slv05( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze, clscnt4
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(imp_nzcnt)
      real, intent(inout) ::   b(clscnt4)
                                                                        
!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
                                                                        
!-----------------------------------------------------------------------
!       ... Solve L * y = b
!-----------------------------------------------------------------------
         b(17) = b(17) * lu(51)
                                                                        
         b(16) = b(16) * lu(46)
                                                                        
         b(15) = b(15) * lu(38)
                                                                        
         b(14) = b(14) * lu(34)
                                                                        
         b(13) = b(13) * lu(30)
         b(8) = b(8) - lu(29) * b(13)
                                                                        
         b(12) = b(12) * lu(26)
                                                                        
         b(11) = b(11) * lu(22)
                                                                        
         b(10) = b(10) * lu(19)
                                                                        
         b(9) = b(9) * lu(17)
                                                                        
         b(8) = b(8) * lu(15)
         b(1) = b(1) - lu(14) * b(8)
                                                                        
         b(7) = b(7) * lu(11)
                                                                        
         b(6) = b(6) * lu(8)
                                                                        
         b(5) = b(5) * lu(6)
         b(3) = b(3) - lu(5) * b(5)
                                                                        
         b(4) = b(4) * lu(4)
                                                                        
         b(3) = b(3) * lu(3)
                                                                        
         b(2) = b(2) * lu(2)
                                                                        
         b(1) = b(1) * lu(1)
                                                                        
                                                                        
      end subroutine imp_lu_slv05
                                                                        
      subroutine imp_lu_slv( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : imp_nzcnt, clsze, clscnt4
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(imp_nzcnt)
      real, intent(inout) ::   b(clscnt4)
                                                                        
      call imp_lu_slv01( lu, b )
      call imp_lu_slv02( lu, b )
      call imp_lu_slv03( lu, b )
      call imp_lu_slv04( lu, b )
      call imp_lu_slv05( lu, b )
                                                                        
      end subroutine imp_lu_slv
                                                                        
      end module MO_IMP_SOLVE_MOD

      module MO_ROD_SOLVE_MOD

      contains
                                                                        
      subroutine rod_lu_slv( lu, b )
                                                                        
      use CHEM_MODS_MOD, only : rod_nzcnt, clsze, clscnt5
                                                                        
      implicit none
                                                                        
!-----------------------------------------------------------------------
!       ... Dummy args
!-----------------------------------------------------------------------
      real, intent(in)    ::   lu(rod_nzcnt)
      real, intent(inout) ::   b(clscnt5)
                                                                        
                                                                        
      end subroutine rod_lu_slv
                                                                        
      end module MO_ROD_SOLVE_MOD


      module mo_grid_mod
!---------------------------------------------------------------------
!       ... Basic grid point resolution parameters
!---------------------------------------------------------------------
      implicit none

      save

character(len=128), parameter :: version     = '$Id: moz.mods.F90,v 18.0.2.1 2010/03/25 00:31:42 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      integer, parameter :: &
                pcnst    =    83+1, &     ! number of advected constituents including cloud water
                pcnstm1  =    83, &     ! number of advected constituents excluding cloud water
                plev     =   1, &         ! number of vertical levels
                plevp    = plev+1, &      ! plev plus 1
                plevm    = plev-1, &      ! plev minus 1
                plon     =   1, &         ! number of longitudes
                plat     =   1            ! number of latitudes

      integer, parameter :: &
                pnats    =     0    ! number of non-advected trace species



      integer :: nodes                ! mpi task count
      integer :: plonl                ! longitude tile dimension
      integer :: pplon                ! longitude tile count
      integer :: plnplv               ! plonl * plev

      end module mo_grid_mod

      module chem_mods_mod
!--------------------------------------------------------------
!       ... basic chemistry array parameters
!--------------------------------------------------------------

      use mo_grid_mod, only : pcnstm1
!++lwh
      use mpp_mod,     only : mpp_error, FATAL
!--lwh

      implicit none

      save

      integer, parameter :: hetcnt     =     0, &    ! number of heterogeneous processes
                            phtcnt     =    41, &    ! number of photo processes
                            rxntot     =   224, &    ! number of total reactions
                            gascnt     =   183, &    ! number of gas phase reactions
                            nfs        =     3, &       ! number of "fixed" species
                            relcnt     =     0, &    ! number of relationship species
                            grpcnt     =     0, &    ! number of group members
                            imp_nzcnt  =   829, &     ! number of non-zero implicit matrix entries
                            rod_nzcnt  =     0, &     ! number of non-zero rodas matrix entries
                            extcnt     =     0, &    ! number of species with external forcing
                            clscnt1    =     7, &  ! number of species in explicit class
                            clscnt2    =     0, &  ! number of species in hov class
                            clscnt3    =     0, &  ! number of species in ebi class
                            clscnt4    =    76, &  ! number of species in implicit class
                            clscnt5    =     0, &  ! number of species in rodas class
                            indexm     =     1, &    ! index of total atm density in invariant array
                            ncol_abs   =     2, &    ! number of column densities
                            indexh2o   =     0, &    ! index of water vapor density
                            clsze      = 1       ! loop length for implicit chemistry

      integer ::            ngrp       = 0
      integer ::            drydep_cnt = 0
      integer ::            srfems_cnt = 0
      integer ::            rxt_alias_cnt = 0
      integer, allocatable :: grp_mem_cnt(:)
      integer, allocatable :: rxt_alias_map(:)
      real      :: adv_mass(pcnstm1)
      real      :: nadv_mass(grpcnt)
      character(len=16), allocatable :: rxt_alias_lst(:)
      character(len=8), allocatable  :: drydep_lst(:)
      character(len=8), allocatable  :: srfems_lst(:)
      character(len=8), allocatable  :: grp_lst(:)
      character(len=8)               :: het_lst(max(1,hetcnt))
      character(len=8)               :: extfrc_lst(max(1,extcnt))
      character(len=8)               :: inv_lst(max(1,nfs))

      type solver_class
         integer :: clscnt
         integer :: lin_rxt_cnt
         integer :: nln_rxt_cnt
         integer :: indprd_cnt
         integer :: iter_max
         integer :: cls_rxt_cnt(4)
         integer, pointer :: permute(:)
         integer, pointer :: diag_map(:)
         integer, pointer :: clsmap(:)
      end type solver_class

      type(solver_class) :: explicit, implicit, rodas

      contains

      subroutine endrun(msg)

      implicit none

      character(len=128), intent(in), optional  :: msg
      call mpp_error(FATAL, msg)

      end subroutine endrun 

      subroutine chem_mods_init
!--------------------------------------------------------------
!       ... intialize the class derived type
!--------------------------------------------------------------

      implicit none

      integer :: astat

      explicit%clscnt       =     7
      explicit%indprd_cnt   =    52

      implicit%clscnt       =    76
      implicit%lin_rxt_cnt  =    70
      implicit%nln_rxt_cnt  =   151
      implicit%indprd_cnt   =     3
      implicit%iter_max     =    11

      rodas%clscnt          =     0
      rodas%lin_rxt_cnt     =     0
      rodas%nln_rxt_cnt     =     0
      rodas%indprd_cnt      =     0

      if( explicit%clscnt > 0 ) then
         allocate( explicit%clsmap(explicit%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate explicit%clsmap ; error = ',astat
            call endrun
         end if
         explicit%clsmap(:)  = 0
      end if
      if( implicit%clscnt > 0 ) then
         allocate( implicit%permute(implicit%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate implicit%permute ; error = ',astat
            call endrun
         end if
         implicit%permute(:)  = 0
         allocate( implicit%diag_map(implicit%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate implicit%diag_map ; error = ',astat
            call endrun
         end if
         implicit%diag_map(:)  = 0
         allocate( implicit%clsmap(implicit%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate implicit%clsmap ; error = ',astat
            call endrun
         end if
         implicit%clsmap(:)  = 0
      end if
      if( rodas%clscnt > 0 ) then
         allocate( rodas%permute(rodas%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate rodas%permute ; error = ',astat
            call endrun
         end if
         rodas%permute(:)  = 0
         allocate( rodas%diag_map(rodas%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate rodas%diag_map ; error = ',astat
            call endrun
         end if
         rodas%diag_map(:)  = 0
         allocate( rodas%clsmap(rodas%clscnt),stat=astat )
         if( astat /= 0 ) then
            write(*,*) 'chem_mods_init: failed to allocate rodas%clsmap ; error = ',astat
            call endrun
         end if
         rodas%clsmap(:)  = 0
      end if

      end subroutine chem_mods_init

      end module chem_mods_mod
  
      module M_SPC_ID_MOD
  
      implicit none                                                             
  
      integer, parameter :: id_O3 =   1
      integer, parameter :: id_O =   2
      integer, parameter :: id_O1D =   3
      integer, parameter :: id_N2O =   4
      integer, parameter :: id_N =   5
      integer, parameter :: id_NO =   6
      integer, parameter :: id_NO2 =   7
      integer, parameter :: id_NO3 =   8
      integer, parameter :: id_HNO3 =   9
      integer, parameter :: id_HO2NO2 =  10
      integer, parameter :: id_N2O5 =  11
      integer, parameter :: id_CH4 =  12
      integer, parameter :: id_CH3O2 =  13
      integer, parameter :: id_CH3OOH =  14
      integer, parameter :: id_CH2O =  15
      integer, parameter :: id_CO =  16
      integer, parameter :: id_OH =  17
      integer, parameter :: id_HO2 =  18
      integer, parameter :: id_H2O2 =  19
      integer, parameter :: id_C3H6 =  20
      integer, parameter :: id_ISOP =  21
      integer, parameter :: id_PO2 =  22
      integer, parameter :: id_CH3CHO =  23
      integer, parameter :: id_POOH =  24
      integer, parameter :: id_CH3CO3 =  25
      integer, parameter :: id_CH3COOOH =  26
      integer, parameter :: id_PAN =  27
      integer, parameter :: id_ONIT =  28
      integer, parameter :: id_C2H6 =  29
      integer, parameter :: id_C2H4 =  30
      integer, parameter :: id_C4H10 =  31
      integer, parameter :: id_MPAN =  32
      integer, parameter :: id_ISOPO2 =  33
      integer, parameter :: id_MVK =  34
      integer, parameter :: id_MACR =  35
      integer, parameter :: id_MACRO2 =  36
      integer, parameter :: id_MACROOH =  37
      integer, parameter :: id_MCO3 =  38
      integer, parameter :: id_C2H5O2 =  39
      integer, parameter :: id_C2H5OOH =  40
      integer, parameter :: id_C10H16 =  41
      integer, parameter :: id_C3H8 =  42
      integer, parameter :: id_C3H7O2 =  43
      integer, parameter :: id_C3H7OOH =  44
      integer, parameter :: id_CH3COCH3 =  45
      integer, parameter :: id_ROOH =  46
      integer, parameter :: id_CH3OH =  47
      integer, parameter :: id_C2H5OH =  48
      integer, parameter :: id_GLYALD =  49
      integer, parameter :: id_HYAC =  50
      integer, parameter :: id_EO2 =  51
      integer, parameter :: id_EO =  52
      integer, parameter :: id_HYDRALD =  53
      integer, parameter :: id_RO2 =  54
      integer, parameter :: id_CH3COCHO =  55
      integer, parameter :: id_ISOPNO3 =  56
      integer, parameter :: id_ONITR =  57
      integer, parameter :: id_XO2 =  58
      integer, parameter :: id_XOOH =  59
      integer, parameter :: id_ISOPOOH =  60
      integer, parameter :: id_H2 =  61
      integer, parameter :: id_SO2 =  62
      integer, parameter :: id_SO4 =  63
      integer, parameter :: id_DMS =  64
      integer, parameter :: id_NH3 =  65
      integer, parameter :: id_NH4NO3 =  66
      integer, parameter :: id_NH4 =  67
      integer, parameter :: id_HCl =  68
      integer, parameter :: id_HOCl =  69
      integer, parameter :: id_ClONO2 =  70
      integer, parameter :: id_Cl =  71
      integer, parameter :: id_ClO =  72
      integer, parameter :: id_Cl2O2 =  73
      integer, parameter :: id_Cl2 =  74
      integer, parameter :: id_HOBr =  75
      integer, parameter :: id_HBr =  76
      integer, parameter :: id_BrONO2 =  77
      integer, parameter :: id_Br =  78
      integer, parameter :: id_BrO =  79
      integer, parameter :: id_BrCl =  80
      integer, parameter :: id_LCH4 =  81
      integer, parameter :: id_H =  82
      integer, parameter :: id_H2O =  83
  
  
      end module M_SPC_ID_MOD
                                                                                
      module M_RXT_ID_MOD
                                                                                
      implicit none                                                             
                                                                                
      integer, parameter :: rid_jo2 =    1                                      
      integer, parameter :: rid_jo1d =    2                                     
      integer, parameter :: rid_jo3p =    3                                     
      integer, parameter :: rid_jn2o =    4                                     
      integer, parameter :: rid_jno =    5                                      
      integer, parameter :: rid_jno2 =    6                                     
      integer, parameter :: rid_jn2o5 =    7                                    
      integer, parameter :: rid_jhno3 =    8                                    
      integer, parameter :: rid_jno3 =    9                                     
      integer, parameter :: rid_jho2no2 =   10                                  
      integer, parameter :: rid_jch3ooh =   11                                  
      integer, parameter :: rid_jch2o_a =   12                                  
      integer, parameter :: rid_jch2o_b =   13                                  
      integer, parameter :: rid_jh2o =   14                                     
      integer, parameter :: rid_jh2o2 =   15                                    
      integer, parameter :: rid_jch3cho =   16                                  
      integer, parameter :: rid_jpooh =   17                                    
      integer, parameter :: rid_jch3co3h =   18                                 
      integer, parameter :: rid_jpan =   19                                     
      integer, parameter :: rid_jmpan =   20                                    
      integer, parameter :: rid_jmacr_a =   21                                  
      integer, parameter :: rid_jmacr_b =   22                                  
      integer, parameter :: rid_jmvk =   23                                     
      integer, parameter :: rid_jc2h5ooh =   24                                 
      integer, parameter :: rid_jc3h7ooh =   25                                 
      integer, parameter :: rid_jrooh =   26                                    
      integer, parameter :: rid_jacet =   27                                    
      integer, parameter :: rid_jmgly =   28                                    
      integer, parameter :: rid_jxooh =   29                                    
      integer, parameter :: rid_jonitr =   30                                   
      integer, parameter :: rid_jisopooh =   31                                 
      integer, parameter :: rid_jhyac =   32                                    
      integer, parameter :: rid_jglyald =   33                                  
      integer, parameter :: rid_jclono2 =   34                                  
      integer, parameter :: rid_jhocl =   35                                    
      integer, parameter :: rid_jcl2o2 =   36                                   
      integer, parameter :: rid_jbrono2 =   37                                  
      integer, parameter :: rid_jhobr =   38                                    
      integer, parameter :: rid_jbrcl =   39                                    
      integer, parameter :: rid_jbro =   40                                     
      integer, parameter :: rid_jcl2 =   41                                     
      integer, parameter :: rid_usr1 =   42                                     
      integer, parameter :: rid_o1d_n2 =   44                                   
      integer, parameter :: rid_o1d_o2 =   45                                   
      integer, parameter :: rid_ox_l1 =   46                                    
      integer, parameter :: rid_ox_p1 =   49                                    
      integer, parameter :: rid_usr2 =   54                                     
      integer, parameter :: rid_usr3 =   55                                     
      integer, parameter :: rid_usr4 =   57                                     
      integer, parameter :: rid_usr5 =   58                                     
      integer, parameter :: rid_usr6 =   60                                     
      integer, parameter :: rid_usr7 =   62                                     
      integer, parameter :: rid_ox_p2 =   65                                    
      integer, parameter :: rid_usr8 =   72                                     
      integer, parameter :: rid_usr8a =   73                                    
      integer, parameter :: rid_ox_l2 =   77                                    
      integer, parameter :: rid_ox_l3 =   78                                    
      integer, parameter :: rid_usr9 =   79                                     
      integer, parameter :: rid_usr10 =   84                                    
      integer, parameter :: rid_ox_l4 =   85                                    
      integer, parameter :: rid_ox_p3 =   87                                    
      integer, parameter :: rid_ox_p4 =   92                                    
      integer, parameter :: rid_usr11 =   93                                    
      integer, parameter :: rid_usr12 =   97                                    
      integer, parameter :: rid_ox_l5 =   99                                    
      integer, parameter :: rid_ox_p5 =  101                                    
      integer, parameter :: rid_usr13 =  106                                    
      integer, parameter :: rid_ox_l6 =  110                                    
      integer, parameter :: rid_ox_p6 =  113                                    
      integer, parameter :: rid_ox_l7 =  119                                    
      integer, parameter :: rid_ox_l8 =  121                                    
      integer, parameter :: rid_ox_p7 =  122                                    
      integer, parameter :: rid_ox_p8 =  129                                    
      integer, parameter :: rid_usr14 =  135                                    
      integer, parameter :: rid_usr15 =  136                                    
      integer, parameter :: rid_ox_l9 =  138                                    
      integer, parameter :: rid_usr16 =  140                                    
      integer, parameter :: rid_usr17 =  141                                    
      integer, parameter :: rid_ox_p9 =  145                                    
      integer, parameter :: rid_usr22 =  149                                    
      integer, parameter :: rid_ox_p10 =  150                                   
      integer, parameter :: rid_ox_p11 =  164                                   
      integer, parameter :: rid_usr21 =  170                                    
      integer, parameter :: rid_usr24 =  180                                    
      integer, parameter :: rid_usr25 =  182                                    
      integer, parameter :: rid_strat13 =  184                                  
      integer, parameter :: rid_strat14 =  185                                  
      integer, parameter :: rid_strat20 =  186                                  
      integer, parameter :: rid_strat21 =  187                                  
      integer, parameter :: rid_strat22 =  188                                  
      integer, parameter :: rid_strat23 =  189                                  
      integer, parameter :: rid_strat24 =  190                                  
      integer, parameter :: rid_strat25 =  191                                  
      integer, parameter :: rid_strat26 =  192                                  
      integer, parameter :: rid_strat27 =  193                                  
      integer, parameter :: rid_strat28 =  194                                  
      integer, parameter :: rid_strat29 =  195                                  
      integer, parameter :: rid_strat33 =  196                                  
      integer, parameter :: rid_strat35 =  197                                  
      integer, parameter :: rid_strat37 =  198                                  
      integer, parameter :: rid_strat38 =  199                                  
      integer, parameter :: rid_strat39 =  200                                  
      integer, parameter :: rid_strat40 =  201                                  
      integer, parameter :: rid_strat41 =  202                                  
      integer, parameter :: rid_strat42 =  203                                  
      integer, parameter :: rid_strat43 =  204                                  
      integer, parameter :: rid_strat44 =  205                                  
      integer, parameter :: rid_strat45 =  206                                  
      integer, parameter :: rid_strat46 =  207                                  
      integer, parameter :: rid_strat47 =  208                                  
      integer, parameter :: rid_strat48 =  209                                  
      integer, parameter :: rid_strat69 =  210                                  
      integer, parameter :: rid_strat58 =  211                                  
      integer, parameter :: rid_strat59 =  212                                  
      integer, parameter :: rid_strat64 =  213                                  
      integer, parameter :: rid_strat71 =  214                                  
      integer, parameter :: rid_strat72 =  215                                  
      integer, parameter :: rid_strat73 =  216                                  
      integer, parameter :: rid_strat74 =  217                                  
      integer, parameter :: rid_strat75 =  218                                  
      integer, parameter :: rid_strat76 =  219                                  
      integer, parameter :: rid_strat77 =  220                                  
      integer, parameter :: rid_strat78 =  221                                  
      integer, parameter :: rid_strat79 =  222                                  
      integer, parameter :: rid_strat80 =  223                                  
                                                                                
      integer, parameter :: rid_r0043 =   43                                    
      integer, parameter :: rid_r0047 =   47                                    
      integer, parameter :: rid_r0048 =   48                                    
      integer, parameter :: rid_r0050 =   50                                    
      integer, parameter :: rid_r0051 =   51                                    
      integer, parameter :: rid_r0052 =   52                                    
      integer, parameter :: rid_r0053 =   53                                    
      integer, parameter :: rid_r0056 =   56                                    
      integer, parameter :: rid_r0059 =   59                                    
      integer, parameter :: rid_r0061 =   61                                    
      integer, parameter :: rid_r0063 =   63                                    
      integer, parameter :: rid_r0064 =   64                                    
      integer, parameter :: rid_r0066 =   66                                    
      integer, parameter :: rid_r0067 =   67                                    
      integer, parameter :: rid_r0068 =   68                                    
      integer, parameter :: rid_r0069 =   69                                    
      integer, parameter :: rid_r0070 =   70                                    
      integer, parameter :: rid_r0071 =   71                                    
      integer, parameter :: rid_r0074 =   74                                    
      integer, parameter :: rid_r0075 =   75                                    
      integer, parameter :: rid_r0076 =   76                                    
      integer, parameter :: rid_r0080 =   80                                    
      integer, parameter :: rid_r0081 =   81                                    
      integer, parameter :: rid_r0082 =   82                                    
      integer, parameter :: rid_r0083 =   83                                    
      integer, parameter :: rid_r0086 =   86                                    
      integer, parameter :: rid_r0088 =   88                                    
      integer, parameter :: rid_r0089 =   89                                    
      integer, parameter :: rid_r0090 =   90                                    
      integer, parameter :: rid_r0091 =   91                                    
      integer, parameter :: rid_r0094 =   94                                    
      integer, parameter :: rid_r0095 =   95                                    
      integer, parameter :: rid_r0096 =   96                                    
      integer, parameter :: rid_r0098 =   98                                    
      integer, parameter :: rid_r0100 =  100                                    
      integer, parameter :: rid_r0102 =  102                                    
      integer, parameter :: rid_r0103 =  103                                    
      integer, parameter :: rid_r0104 =  104                                    
      integer, parameter :: rid_r0105 =  105                                    
      integer, parameter :: rid_r0107 =  107                                    
      integer, parameter :: rid_r0108 =  108                                    
      integer, parameter :: rid_r0109 =  109                                    
      integer, parameter :: rid_r0111 =  111                                    
      integer, parameter :: rid_r0112 =  112                                    
      integer, parameter :: rid_r0114 =  114                                    
      integer, parameter :: rid_r0115 =  115                                    
      integer, parameter :: rid_r0116 =  116                                    
      integer, parameter :: rid_r0117 =  117                                    
      integer, parameter :: rid_r0118 =  118                                    
      integer, parameter :: rid_r0120 =  120                                    
      integer, parameter :: rid_r0123 =  123                                    
      integer, parameter :: rid_r0124 =  124                                    
      integer, parameter :: rid_r0125 =  125                                    
      integer, parameter :: rid_r0126 =  126                                    
      integer, parameter :: rid_r0127 =  127                                    
      integer, parameter :: rid_r0128 =  128                                    
      integer, parameter :: rid_r0130 =  130                                    
      integer, parameter :: rid_r0131 =  131                                    
      integer, parameter :: rid_r0132 =  132                                    
      integer, parameter :: rid_r0133 =  133                                    
      integer, parameter :: rid_r0134 =  134                                    
      integer, parameter :: rid_r0137 =  137                                    
      integer, parameter :: rid_r0139 =  139                                    
      integer, parameter :: rid_r0142 =  142                                    
      integer, parameter :: rid_r0143 =  143                                    
      integer, parameter :: rid_r0144 =  144                                    
      integer, parameter :: rid_r0146 =  146                                    
      integer, parameter :: rid_r0147 =  147                                    
      integer, parameter :: rid_r0148 =  148                                    
      integer, parameter :: rid_r0151 =  151                                    
      integer, parameter :: rid_r0152 =  152                                    
      integer, parameter :: rid_r0153 =  153                                    
      integer, parameter :: rid_r0154 =  154                                    
      integer, parameter :: rid_r0155 =  155                                    
      integer, parameter :: rid_r0156 =  156                                    
      integer, parameter :: rid_r0157 =  157                                    
      integer, parameter :: rid_r0158 =  158                                    
      integer, parameter :: rid_r0159 =  159                                    
      integer, parameter :: rid_r0160 =  160                                    
      integer, parameter :: rid_r0161 =  161                                    
      integer, parameter :: rid_r0162 =  162                                    
      integer, parameter :: rid_r0163 =  163                                    
      integer, parameter :: rid_r0165 =  165                                    
      integer, parameter :: rid_r0166 =  166                                    
      integer, parameter :: rid_r0167 =  167                                    
      integer, parameter :: rid_r0168 =  168                                    
      integer, parameter :: rid_r0169 =  169                                    
      integer, parameter :: rid_r0171 =  171                                    
      integer, parameter :: rid_r0172 =  172                                    
      integer, parameter :: rid_r0173 =  173                                    
      integer, parameter :: rid_r0174 =  174                                    
      integer, parameter :: rid_r0175 =  175                                    
      integer, parameter :: rid_r0176 =  176                                    
      integer, parameter :: rid_r0177 =  177                                    
      integer, parameter :: rid_r0178 =  178                                    
      integer, parameter :: rid_r0179 =  179                                    
      integer, parameter :: rid_r0181 =  181                                    
      integer, parameter :: rid_r0183 =  183                                    
      integer, parameter :: rid_r0224 =  224                                    
                                                                                
      end module M_RXT_ID_MOD
                                                                                
      module M_HET_ID_MOD
                                                                                
      implicit none                                                             
                                                                                
                                                                                
      end module M_HET_ID_MOD


      module mo_setrxt_mod

implicit none
      private
      public :: setrxt

character(len=128), parameter :: version     = '$Id: moz.subs.F90,v 17.0.2.1.4.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

!++lwh
      subroutine setrxt( rate, temp, m, plonl, plev, plnplv )
!--lwh

      use chem_mods_mod, only : rxntot
      use mo_jpl_mod,    only : jpl

      implicit none

!-------------------------------------------------------
!       ... Dummy arguments
!-------------------------------------------------------
!++lwh
      integer, intent(in) :: plonl, plev, plnplv
!--lwh
      real, intent(in)    :: temp(plonl,plev), m(plonl,plev)
      real, intent(inout) :: rate(plonl,plev,rxntot)

!-------------------------------------------------------
!       ... Local variables
!-------------------------------------------------------
      real  ::  itemp(plonl,plev), exp_fac(plonl,plev)
      real, dimension(plonl,plev) :: ko, kinf

      rate(:,:,53) = 3.5e-12
      rate(:,:,56) = 0.
      rate(:,:,64) = 1.5e-10
      rate(:,:,74) = 1.1e-10
      rate(:,:,80) = 1.8e-12
      rate(:,:,82) = 1.8e-12
      rate(:,:,96) = 1e-12
      rate(:,:,103) = 2.e-13
      rate(:,:,104) = 6.8e-14
      rate(:,:,108) = 1.e-14
      rate(:,:,114) = 2.4e-12
      rate(:,:,117) = 1.4e-11
      rate(:,:,124) = 2.4e-12
      rate(:,:,127) = 1.4e-11
      rate(:,:,130) = 5.e-12
      rate(:,:,153) = 6.8e-13
      rate(:,:,156) = 2.4e-12
      rate(:,:,160) = 4.5e-11
      rate(:,:,161) = 1.3e-16
      rate(:,:,165) = 2.4e-12
      rate(:,:,175) = 4.e-14
      rate(:,:,176) = 3.e-12
      rate(:,:,177) = 1.e-11
      rate(:,:,224) = 3.17e-8
      itemp(:,:) = 1. / temp(:,:)
      rate(:,:,43) = 8e-12 * exp( -2060. * itemp(:,:) )
      rate(:,:,44) = 2.15e-11 * exp( 110. * itemp(:,:) )
      rate(:,:,45) = 3.3e-11 * exp( 55. * itemp(:,:) )
      rate(:,:,46) = 1.63e-10 * exp( 60. * itemp(:,:) )
      exp_fac(:,:) = exp( 20. * itemp(:,:) )
      rate(:,:,47) = 6.3e-11 * exp_fac(:,:)
      rate(:,:,48) = 4.7e-11 * exp_fac(:,:)
      exp_fac(:,:) = exp( 250. * itemp(:,:) )
      rate(:,:,49) = 3.5e-12 * exp_fac(:,:)
      rate(:,:,81) = 4.8e-11 * exp_fac(:,:)
      rate(:,:,50) = 3e-12 * exp( -1500. * itemp(:,:) )
      rate(:,:,51) = 5.1e-12 * exp( 210. * itemp(:,:) )
      exp_fac(:,:) = exp( -2450. * itemp(:,:) )
      rate(:,:,52) = 1.2e-13 * exp_fac(:,:)
      rate(:,:,212) = 8.5e-13 * exp_fac(:,:)
      exp_fac(:,:) = exp( 170. * itemp(:,:) )
      rate(:,:,59) = 1.5e-11 * exp_fac(:,:)
      rate(:,:,193) = 1.8e-11 * exp_fac(:,:)
      rate(:,:,61) = 1.3e-12 * exp( 380. * itemp(:,:) )
      rate(:,:,63) = 2.45e-12 * exp( -1775. * itemp(:,:) )
      exp_fac(:,:) = exp( 300. * itemp(:,:) )
      rate(:,:,65) = 2.8e-12 * exp_fac(:,:)
      rate(:,:,150) = 2.9e-12 * exp_fac(:,:)
      rate(:,:,66) = 6.03e-13 * exp( -453. * itemp(:,:) )
      rate(:,:,67) = 2.30e-14 * exp( 677. * itemp(:,:) )
      rate(:,:,68) = 4.1e-13 * exp( 750. * itemp(:,:) )
      exp_fac(:,:) = exp( 200. * itemp(:,:) )
      rate(:,:,69) = 3.8e-12 * exp_fac(:,:)
      rate(:,:,76) = 3e-11 * exp_fac(:,:)
      rate(:,:,89) = 3.8e-12 * exp_fac(:,:)
      rate(:,:,105) = 3.8e-12 * exp_fac(:,:)
      rate(:,:,128) = 2.3e-11 * exp_fac(:,:)
      rate(:,:,148) = 3.8e-12 * exp_fac(:,:)
      rate(:,:,152) = 3.8e-12 * exp_fac(:,:)
      rate(:,:,171) = 3.8e-12 * exp_fac(:,:)
      rate(:,:,208) = 5.5e-12 * exp_fac(:,:)
      exp_fac(:,:) = exp( -1900. * itemp(:,:) )
      rate(:,:,70) = 3.4e-13 * exp_fac(:,:)
      rate(:,:,85) = 6.5e-15 * exp_fac(:,:)
      rate(:,:,91) = 1.4e-12 * exp_fac(:,:)
      rate(:,:,71) = 5.5e-12 * exp( 125. * itemp(:,:) )
      rate(:,:,75) = 2.2e-11 * exp( 120. * itemp(:,:) )
      rate(:,:,77) = 1.7e-12 * exp( -940. * itemp(:,:) )
      rate(:,:,78) = 1e-14 * exp( -490. * itemp(:,:) )
      rate(:,:,83) = 2.8e-12 * exp( -1800. * itemp(:,:) )
      rate(:,:,86) = 4.6e-13 * exp( -1156. * itemp(:,:) )
      exp_fac(:,:) = exp( 180. * itemp(:,:) )
      rate(:,:,87) = 4.2e-12 * exp_fac(:,:)
      rate(:,:,107) = 4.2e-12 * exp_fac(:,:)
      rate(:,:,113) = 2.2e-12 * exp_fac(:,:)
      rate(:,:,145) = 4.2e-12 * exp_fac(:,:)
      exp_fac(:,:) = exp( 700. * itemp(:,:) )
      rate(:,:,88) = 7.5e-13 * exp_fac(:,:)
      rate(:,:,102) = 7.5e-13 * exp_fac(:,:)
      rate(:,:,115) = 8.e-13 * exp_fac(:,:)
      rate(:,:,125) = 8.e-13 * exp_fac(:,:)
      rate(:,:,146) = 7.5e-13 * exp_fac(:,:)
      rate(:,:,151) = 8.6e-13 * exp_fac(:,:)
      rate(:,:,157) = 8.e-13 * exp_fac(:,:)
      rate(:,:,166) = 8.e-13 * exp_fac(:,:)
      exp_fac(:,:) = exp( 270. * itemp(:,:) )
      rate(:,:,90) = 5.6e-12 * exp_fac(:,:)
      rate(:,:,92) = 8.1e-12 * exp_fac(:,:)
      rate(:,:,195) = 7.4e-12 * exp_fac(:,:)
      exp_fac(:,:) = exp( 1040. * itemp(:,:) )
      rate(:,:,94) = 4.3e-13 * exp_fac(:,:)
      rate(:,:,131) = 4.30e-13 * exp_fac(:,:)
      exp_fac(:,:) = exp( 500. * itemp(:,:) )
      rate(:,:,95) = 2.0e-12 * exp_fac(:,:)
      rate(:,:,98) = 2.9e-12 * exp_fac(:,:)
      rate(:,:,181) = 1.87e-13 * exp_fac(:,:)
      rate(:,:,99) = 1.05e-14 * exp( -2000. * itemp(:,:) )
      rate(:,:,100) = 8.7e-12 * exp( -1070. * itemp(:,:) )
      rate(:,:,101) = 2.6e-12 * exp( 365. * itemp(:,:) )
      rate(:,:,109) = 1.6e11 * exp( -4150. * itemp(:,:) )
      rate(:,:,110) = 1.2e-14 * exp( -2630. * itemp(:,:) )
      rate(:,:,111) = 2.54e-11 * exp( 410. * itemp(:,:) )
      rate(:,:,112) = 1.55e-11 * exp( -540. * itemp(:,:) )
      exp_fac(:,:) = exp( 400. * itemp(:,:) )
      rate(:,:,116) = 5.e-13 * exp_fac(:,:)
      rate(:,:,126) = 5.e-13 * exp_fac(:,:)
      rate(:,:,167) = 5.e-13 * exp_fac(:,:)
      rate(:,:,118) = 4.13e-12 * exp( 452. * itemp(:,:) )
      rate(:,:,119) = 7.52e-16 * exp( -1521. * itemp(:,:) )
      exp_fac(:,:) = exp( 175. * itemp(:,:) )
      rate(:,:,120) = 1.86e-11 * exp_fac(:,:)
      rate(:,:,163) = 1.86e-11 * exp_fac(:,:)
      rate(:,:,121) = 4.4e-15 * exp( -2500. * itemp(:,:) )
      exp_fac(:,:) = exp( 360. * itemp(:,:) )
      rate(:,:,122) = 2.7e-12 * exp_fac(:,:)
      rate(:,:,123) = 1.3e-13 * exp_fac(:,:)
      rate(:,:,129) = 5.3e-12 * exp_fac(:,:)
      rate(:,:,155) = 2.7e-12 * exp_fac(:,:)
      rate(:,:,164) = 2.7e-12 * exp_fac(:,:)
      exp_fac(:,:) = exp( 640. * itemp(:,:) )
      rate(:,:,132) = 1.3e-12 * exp_fac(:,:)
      rate(:,:,168) = 1.3e-12 * exp_fac(:,:)
      exp_fac(:,:) = exp( 530. * itemp(:,:) )
      rate(:,:,133) = 4.6e-12 * exp_fac(:,:)
      rate(:,:,134) = 2.3e-12 * exp_fac(:,:)
      rate(:,:,137) = 1.2e-11 * exp( 444. * itemp(:,:) )
      rate(:,:,138) = 9.9e-15 * exp( -730. * itemp(:,:) )
      rate(:,:,139) = 5.6e-11 * exp( -650. * itemp(:,:) )
      rate(:,:,142) = 1.5e-11 * exp( -3600. * itemp(:,:) )
      rate(:,:,143) = 2.1e-11 * exp( 100. * itemp(:,:) )
      rate(:,:,144) = 8.7e-12 * exp( -615. * itemp(:,:) )
      rate(:,:,147) = 3.75e-13 * exp( -40. * itemp(:,:) )
      rate(:,:,154) = 3.03e-12 * exp( -446. * itemp(:,:) )
      rate(:,:,158) = 8.4e-13 * exp( 830. * itemp(:,:) )
      exp_fac(:,:) = exp( -1860. * itemp(:,:) )
      rate(:,:,159) = 1.4e-12 * exp_fac(:,:)
      rate(:,:,162) = 1.4e-12 * exp_fac(:,:)
      rate(:,:,169) = 1.90e-12 * exp( 190. * itemp(:,:) )
      rate(:,:,172) = 2.9e-12 * exp( -345. * itemp(:,:) )
      rate(:,:,173) = 6.9e-12 * exp( -230. * itemp(:,:) )
      rate(:,:,179) = 1.1e-11 * exp( -240. * itemp(:,:) )
      rate(:,:,183) = 1.7e-12 * exp( -710. * itemp(:,:) )
      rate(:,:,184) = 1.4e-10 * exp( -470. * itemp(:,:) )
      rate(:,:,186) = 2.3e-11 * exp( -200. * itemp(:,:) )
      rate(:,:,187) = 2.8e-11 * exp( 85. * itemp(:,:) )
      exp_fac(:,:) = exp( 290. * itemp(:,:) )
      rate(:,:,188) = 6.4e-12 * exp_fac(:,:)
      rate(:,:,209) = 4.1e-13 * exp_fac(:,:)
      exp_fac(:,:) = exp( -800. * itemp(:,:) )
      rate(:,:,190) = 2.9e-12 * exp_fac(:,:)
      rate(:,:,200) = 1.7e-11 * exp_fac(:,:)
      rate(:,:,207) = 1.7e-11 * exp_fac(:,:)
      rate(:,:,191) = 7.3e-12 * exp( -1280. * itemp(:,:) )
      rate(:,:,192) = 2.6e-12 * exp( -350. * itemp(:,:) )
      exp_fac(:,:) = exp( 220. * itemp(:,:) )
      rate(:,:,194) = 2.7e-12 * exp_fac(:,:)
      rate(:,:,214) = 5.8e-12 * exp_fac(:,:)
      rate(:,:,196) = 8.1e-11 * exp( -30. * itemp(:,:) )
      exp_fac(:,:) = exp( 260. * itemp(:,:) )
      rate(:,:,202) = 2.3e-12 * exp_fac(:,:)
      rate(:,:,204) = 8.8e-12 * exp_fac(:,:)
      rate(:,:,203) = 4.5e-12 * exp( 460. * itemp(:,:) )
      rate(:,:,205) = 1.2e-10 * exp( -430. * itemp(:,:) )
      rate(:,:,206) = 4.8e-12 * exp( -310. * itemp(:,:) )
      rate(:,:,210) = 6.0e-13 * exp( 230. * itemp(:,:) )
      rate(:,:,211) = 4.5e-14 * exp( -1260. * itemp(:,:) )

      itemp(:,:) = 300. * itemp(:,:)

      ko(:,:) = 2.e-30 * itemp(:,:)**4.4
      kinf(:,:) = 1.4e-12 * itemp(:,:)**.7
      call jpl( rate(1,1,54), m, .6, ko, kinf, plnplv )

      ko(:,:) = 1.8e-30 * itemp(:,:)**3.0
      kinf(:,:) = 2.8e-11
      call jpl( rate(1,1,57), m, .6, ko, kinf, plnplv )

      ko(:,:) = 2.0e-31 * itemp(:,:)**3.4
      kinf(:,:) = 2.9e-12 * itemp(:,:)**1.1
      call jpl( rate(1,1,60), m, .6, ko, kinf, plnplv )

      ko(:,:) = 5.9e-33 * itemp(:,:)**1.4
      kinf(:,:) = 1.1e-12 * itemp(:,:)**(-1.3)
      call jpl( rate(1,1,72), m, .6, ko, kinf, plnplv )

      ko(:,:) = 1.5e-13 * itemp(:,:)**(-0.6)
      kinf(:,:) = 2.1e9 * itemp(:,:)**(-6.1)
      call jpl( rate(1,1,73), m, .6, ko, kinf, plnplv )

      ko(:,:) = 8.e-27 * itemp(:,:)**3.5
      kinf(:,:) = 3.e-11
      call jpl( rate(1,1,84), m, .5, ko, kinf, plnplv )

      ko(:,:) = 9.7e-29 * itemp(:,:)**5.6
      kinf(:,:) = 9.3e-12 * itemp(:,:)**1.5
      call jpl( rate(1,1,93), m, .6, ko, kinf, plnplv )

      ko(:,:) = 1.e-28 * itemp(:,:)**4.5
      kinf(:,:) = 8.8e-12 * itemp(:,:)**0.85
      call jpl( rate(1,1,106), m, .6, ko, kinf, plnplv )

      ko(:,:) = 8.e-27 * itemp(:,:)**3.5
      kinf(:,:) = 3.e-11
      call jpl( rate(1,1,174), m, .5, ko, kinf, plnplv )

      ko(:,:) = 3.3e-31 * itemp(:,:)**4.3
      kinf(:,:) = 1.6e-12
      call jpl( rate(1,1,178), m, 0.6, ko, kinf, plnplv )

      ko(:,:) = 4.4e-32 * itemp(:,:)**1.3
      kinf(:,:) = 4.7e-11 * itemp(:,:)**0.2
      call jpl( rate(1,1,185), m, 0.6, ko, kinf, plnplv )

      ko(:,:) = 1.8e-31 * itemp(:,:)**3.4
      kinf(:,:) = 1.5e-11 * itemp(:,:)**1.9
      call jpl( rate(1,1,189), m, 0.6, ko, kinf, plnplv )

      ko(:,:) = 6.9e-31 * itemp(:,:)**1.0
      kinf(:,:) = 2.6e-11
      call jpl( rate(1,1,197), m, 0.6, ko, kinf, plnplv )

      ko(:,:) = 1.6e-32 * itemp(:,:)**4.5
      kinf(:,:) = 2.0e-12 * itemp(:,:)**2.4
      call jpl( rate(1,1,198), m, 0.6, ko, kinf, plnplv )

      ko(:,:) = 5.2e-31 * itemp(:,:)**3.2
      kinf(:,:) = 6.9e-12 * itemp(:,:)**2.9
      call jpl( rate(1,1,201), m, 0.6, ko, kinf, plnplv )

      ko(:,:) = 9.0e-32 * itemp(:,:)**1.5
      kinf(:,:) = 3.0e-11
      call jpl( rate(1,1,213), m, 0.6, ko, kinf, plnplv )

      end subroutine setrxt

      end module mo_setrxt_mod

      module mo_adjrxt_mod

      private
      public :: adjrxt

      contains

      subroutine adjrxt( rate, inv, m, plnplv )

      use chem_mods_mod, only : nfs, rxntot

      implicit none

!--------------------------------------------------------------------
!       ... Dummy arguments
!--------------------------------------------------------------------
      integer, intent(in) :: plnplv
      real, intent(in)    :: inv(plnplv,nfs)
      real, intent(in)    :: m(plnplv)
      real, intent(inout) :: rate(plnplv,rxntot)

!--------------------------------------------------------------------
!       ... Local variables
!--------------------------------------------------------------------

      rate(:, 44) = rate(:, 44) * inv(:, 2)
      rate(:, 45) = rate(:, 45) * inv(:, 3)
      rate(:, 54) = rate(:, 54) * inv(:, 1)
      rate(:, 55) = rate(:, 55) * inv(:, 1)
      rate(:, 57) = rate(:, 57) * inv(:, 1)
      rate(:, 60) = rate(:, 60) * inv(:, 1)
      rate(:, 62) = rate(:, 62) * inv(:, 1)
      rate(:, 72) = rate(:, 72) * inv(:, 1)
      rate(:, 84) = rate(:, 84) * inv(:, 1)
      rate(:, 93) = rate(:, 93) * inv(:, 1)
      rate(:, 97) = rate(:, 97) * inv(:, 1)
      rate(:,106) = rate(:,106) * inv(:, 1)
      rate(:,108) = rate(:,108) * inv(:, 3)
      rate(:,135) = rate(:,135) * inv(:, 1)
      rate(:,136) = rate(:,136) * inv(:, 1)
      rate(:,142) = rate(:,142) * inv(:, 3)
      rate(:,178) = rate(:,178) * inv(:, 1)
      rate(:,189) = rate(:,189) * inv(:, 1)
      rate(:,197) = rate(:,197) * inv(:, 1)
      rate(:,198) = rate(:,198) * inv(:, 1)
      rate(:,199) = rate(:,199) * inv(:, 1)
      rate(:,201) = rate(:,201) * inv(:, 1)
      rate(:,213) = rate(:,213) * inv(:, 1)
      rate(:, 42) = rate(:, 42) * inv(:, 3) * inv(:, 1)
      rate(:,185) = rate(:,185) * inv(:, 3) * inv(:, 1)
      rate(:, 43) = rate(:, 43) * m(:)
      rate(:, 46) = rate(:, 46) * m(:)
      rate(:, 47) = rate(:, 47) * m(:)
      rate(:, 48) = rate(:, 48) * m(:)
      rate(:, 49) = rate(:, 49) * m(:)
      rate(:, 50) = rate(:, 50) * m(:)
      rate(:, 51) = rate(:, 51) * m(:)
      rate(:, 52) = rate(:, 52) * m(:)
      rate(:, 53) = rate(:, 53) * m(:)
      rate(:, 54) = rate(:, 54) * m(:)
      rate(:, 56) = rate(:, 56) * m(:)
      rate(:, 57) = rate(:, 57) * m(:)
      rate(:, 58) = rate(:, 58) * m(:)
      rate(:, 59) = rate(:, 59) * m(:)
      rate(:, 60) = rate(:, 60) * m(:)
      rate(:, 61) = rate(:, 61) * m(:)
      rate(:, 63) = rate(:, 63) * m(:)
      rate(:, 64) = rate(:, 64) * m(:)
      rate(:, 65) = rate(:, 65) * m(:)
      rate(:, 66) = rate(:, 66) * m(:)
      rate(:, 67) = rate(:, 67) * m(:)
      rate(:, 68) = rate(:, 68) * m(:)
      rate(:, 69) = rate(:, 69) * m(:)
      rate(:, 70) = rate(:, 70) * m(:)
      rate(:, 71) = rate(:, 71) * m(:)
      rate(:, 72) = rate(:, 72) * m(:)
      rate(:, 73) = rate(:, 73) * m(:)
      rate(:, 74) = rate(:, 74) * m(:)
      rate(:, 75) = rate(:, 75) * m(:)
      rate(:, 76) = rate(:, 76) * m(:)
      rate(:, 77) = rate(:, 77) * m(:)
      rate(:, 78) = rate(:, 78) * m(:)
      rate(:, 79) = rate(:, 79) * m(:)
      rate(:, 80) = rate(:, 80) * m(:)
      rate(:, 81) = rate(:, 81) * m(:)
      rate(:, 82) = rate(:, 82) * m(:)
      rate(:, 83) = rate(:, 83) * m(:)
      rate(:, 84) = rate(:, 84) * m(:)
      rate(:, 85) = rate(:, 85) * m(:)
      rate(:, 86) = rate(:, 86) * m(:)
      rate(:, 87) = rate(:, 87) * m(:)
      rate(:, 88) = rate(:, 88) * m(:)
      rate(:, 89) = rate(:, 89) * m(:)
      rate(:, 90) = rate(:, 90) * m(:)
      rate(:, 91) = rate(:, 91) * m(:)
      rate(:, 92) = rate(:, 92) * m(:)
      rate(:, 93) = rate(:, 93) * m(:)
      rate(:, 94) = rate(:, 94) * m(:)
      rate(:, 95) = rate(:, 95) * m(:)
      rate(:, 96) = rate(:, 96) * m(:)
      rate(:, 98) = rate(:, 98) * m(:)
      rate(:, 99) = rate(:, 99) * m(:)
      rate(:,100) = rate(:,100) * m(:)
      rate(:,101) = rate(:,101) * m(:)
      rate(:,102) = rate(:,102) * m(:)
      rate(:,103) = rate(:,103) * m(:)
      rate(:,104) = rate(:,104) * m(:)
      rate(:,105) = rate(:,105) * m(:)
      rate(:,106) = rate(:,106) * m(:)
      rate(:,107) = rate(:,107) * m(:)
      rate(:,110) = rate(:,110) * m(:)
      rate(:,111) = rate(:,111) * m(:)
      rate(:,112) = rate(:,112) * m(:)
      rate(:,113) = rate(:,113) * m(:)
      rate(:,114) = rate(:,114) * m(:)
      rate(:,115) = rate(:,115) * m(:)
      rate(:,116) = rate(:,116) * m(:)
      rate(:,117) = rate(:,117) * m(:)
      rate(:,118) = rate(:,118) * m(:)
      rate(:,119) = rate(:,119) * m(:)
      rate(:,120) = rate(:,120) * m(:)
      rate(:,121) = rate(:,121) * m(:)
      rate(:,122) = rate(:,122) * m(:)
      rate(:,123) = rate(:,123) * m(:)
      rate(:,124) = rate(:,124) * m(:)
      rate(:,125) = rate(:,125) * m(:)
      rate(:,126) = rate(:,126) * m(:)
      rate(:,127) = rate(:,127) * m(:)
      rate(:,128) = rate(:,128) * m(:)
      rate(:,129) = rate(:,129) * m(:)
      rate(:,130) = rate(:,130) * m(:)
      rate(:,131) = rate(:,131) * m(:)
      rate(:,132) = rate(:,132) * m(:)
      rate(:,133) = rate(:,133) * m(:)
      rate(:,134) = rate(:,134) * m(:)
      rate(:,135) = rate(:,135) * m(:)
      rate(:,137) = rate(:,137) * m(:)
      rate(:,138) = rate(:,138) * m(:)
      rate(:,139) = rate(:,139) * m(:)
      rate(:,143) = rate(:,143) * m(:)
      rate(:,144) = rate(:,144) * m(:)
      rate(:,145) = rate(:,145) * m(:)
      rate(:,146) = rate(:,146) * m(:)
      rate(:,147) = rate(:,147) * m(:)
      rate(:,148) = rate(:,148) * m(:)
      rate(:,149) = rate(:,149) * m(:)
      rate(:,150) = rate(:,150) * m(:)
      rate(:,151) = rate(:,151) * m(:)
      rate(:,152) = rate(:,152) * m(:)
      rate(:,153) = rate(:,153) * m(:)
      rate(:,154) = rate(:,154) * m(:)
      rate(:,155) = rate(:,155) * m(:)
      rate(:,156) = rate(:,156) * m(:)
      rate(:,157) = rate(:,157) * m(:)
      rate(:,158) = rate(:,158) * m(:)
      rate(:,159) = rate(:,159) * m(:)
      rate(:,160) = rate(:,160) * m(:)
      rate(:,161) = rate(:,161) * m(:)
      rate(:,162) = rate(:,162) * m(:)
      rate(:,163) = rate(:,163) * m(:)
      rate(:,164) = rate(:,164) * m(:)
      rate(:,165) = rate(:,165) * m(:)
      rate(:,166) = rate(:,166) * m(:)
      rate(:,167) = rate(:,167) * m(:)
      rate(:,168) = rate(:,168) * m(:)
      rate(:,169) = rate(:,169) * m(:)
      rate(:,170) = rate(:,170) * m(:)
      rate(:,171) = rate(:,171) * m(:)
      rate(:,172) = rate(:,172) * m(:)
      rate(:,173) = rate(:,173) * m(:)
      rate(:,174) = rate(:,174) * m(:)
      rate(:,175) = rate(:,175) * m(:)
      rate(:,176) = rate(:,176) * m(:)
      rate(:,177) = rate(:,177) * m(:)
      rate(:,178) = rate(:,178) * m(:)
      rate(:,179) = rate(:,179) * m(:)
      rate(:,180) = rate(:,180) * m(:)
      rate(:,181) = rate(:,181) * m(:)
      rate(:,183) = rate(:,183) * m(:)
      rate(:,184) = rate(:,184) * m(:)
      rate(:,186) = rate(:,186) * m(:)
      rate(:,187) = rate(:,187) * m(:)
      rate(:,188) = rate(:,188) * m(:)
      rate(:,189) = rate(:,189) * m(:)
      rate(:,190) = rate(:,190) * m(:)
      rate(:,191) = rate(:,191) * m(:)
      rate(:,192) = rate(:,192) * m(:)
      rate(:,193) = rate(:,193) * m(:)
      rate(:,194) = rate(:,194) * m(:)
      rate(:,195) = rate(:,195) * m(:)
      rate(:,196) = rate(:,196) * m(:)
      rate(:,197) = rate(:,197) * m(:)
      rate(:,198) = rate(:,198) * m(:)
      rate(:,200) = rate(:,200) * m(:)
      rate(:,201) = rate(:,201) * m(:)
      rate(:,202) = rate(:,202) * m(:)
      rate(:,203) = rate(:,203) * m(:)
      rate(:,204) = rate(:,204) * m(:)
      rate(:,205) = rate(:,205) * m(:)
      rate(:,206) = rate(:,206) * m(:)
      rate(:,207) = rate(:,207) * m(:)
      rate(:,208) = rate(:,208) * m(:)
      rate(:,209) = rate(:,209) * m(:)
      rate(:,210) = rate(:,210) * m(:)
      rate(:,211) = rate(:,211) * m(:)
      rate(:,212) = rate(:,212) * m(:)
      rate(:,213) = rate(:,213) * m(:)
      rate(:,214) = rate(:,214) * m(:)
      rate(:,215) = rate(:,215) * m(:)
      rate(:,216) = rate(:,216) * m(:)
      rate(:,217) = rate(:,217) * m(:)
      rate(:,218) = rate(:,218) * m(:)
      rate(:,219) = rate(:,219) * m(:)
      rate(:,220) = rate(:,220) * m(:)
      rate(:,221) = rate(:,221) * m(:)
      rate(:,222) = rate(:,222) * m(:)
      rate(:,223) = rate(:,223) * m(:)

      end subroutine adjrxt

      end module mo_adjrxt_mod

      module mo_phtadj_mod

      private
      public :: phtadj

      contains

      subroutine phtadj( p_rate, inv, m, plnplv )

      use chem_mods_mod, only : nfs, phtcnt

      implicit none

!--------------------------------------------------------------------
!       ... Dummy arguments
!--------------------------------------------------------------------
      integer, intent(in) :: plnplv
      real, intent(in)    :: inv(plnplv,nfs)
      real, intent(in)    :: m(plnplv)
      real, intent(inout) :: p_rate(plnplv,phtcnt)

!--------------------------------------------------------------------
!       ... Local variables
!--------------------------------------------------------------------
      real    ::  im(plnplv)

      im(:) = 1. / m(:)
      p_rate(:,  1) = p_rate(:,  1)  * inv(:, 3) * im(:)

      end subroutine phtadj

      end module mo_phtadj_mod

      module mo_rxt_mod

      private
      public :: rxt_mod

      contains

      subroutine rxt_mod( rate, het_rates, grp_ratios, plnplv )

      use chem_mods_mod, only : rxntot, hetcnt, grpcnt

      implicit none

!---------------------------------------------------------------------------
!       ... Dummy arguments
!---------------------------------------------------------------------------
      integer, intent(in) ::  plnplv
      real, intent(inout) ::  rate(plnplv,rxntot)
      real, intent(inout) ::  het_rates(plnplv,hetcnt)
      real, intent(in)    ::  grp_ratios(plnplv,grpcnt)


      end subroutine rxt_mod

      end module mo_rxt_mod

      module mo_make_grp_vmr_mod

      private
      public :: mak_grp_vmr

      contains

      subroutine mak_grp_vmr( vmr, group_ratios, group_vmrs, plonl )

      use mo_grid_mod,   only : plev, pcnstm1
      use chem_mods_mod, only : grpcnt

      implicit none

!----------------------------------------------------------------------------
!        ... Dummy arguments
!----------------------------------------------------------------------------
      integer, intent(in) :: plonl
      real, intent(in)    :: vmr(plonl,plev,pcnstm1)
      real, intent(in)    :: group_ratios(plonl,plev,grpcnt)
      real, intent(out)   :: group_vmrs(plonl,plev,grpcnt)

!----------------------------------------------------------------------------
!        ... Local variables
!----------------------------------------------------------------------------

      end subroutine mak_grp_vmr

      end module mo_make_grp_vmr_mod



      module mo_chemdr_mod

      implicit none

      private
      public :: chemdr

!     save

character(len=128), parameter :: version     = '$Id: mo_chemdr.F90,v 17.0.4.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

! <SUBROUTINE NAME="chemdr">
!   <OVERVIEW>
!     Tropospheric chemistry driver
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine calculates chemical production and loss of trace species,
!     using the MOZART chemical mechanism and solver.
!     Species and reactions can be modified using MOZART chemical pre-processor.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call chemdr( vmr, Time, lat, lon, delt, ps, ptop, pmid, pdel, &
!                  zma, zi, cldfr, cwat, tfld, inv_data, sh, &
!                  albedo, coszen, esfact, &
!                  prod_out, loss_out, sulfate, psc, &
!                  do_interactive_h2o, solar_phase, imp_slv_nonconv, plonl )
!   </TEMPLATE>
!   <IN NAME="Time" TYPE="time_type">
!     Model time
!   </INOUT>
!   <IN NAME="lat" TYPE="real" DIM="(:)">
!     The latitudes for the local domain.
!   </IN>
!   <IN NAME="lon" TYPE="real" DIM="(:)">
!     The longitudes for the local domain.
!   </IN>
!   <IN NAME="delt" TYPE="real">
!     Model timestep (s)
!   </IN>
!   <IN NAME="pmid" TYPE="real" DIM="(:,:)">
!     Pressure on the model full levels (Pa)
!   </IN>
!   <IN NAME="pdel" TYPE="real" DIM="(:,:)">
!     Pressure thickness of model layers (Pa)
!   </IN>
!   <IN NAME="ps" TYPE="real" DIM="(:)">
!     Model surface pressure (Pa)
!   </IN>
!   <IN NAME="ptop" TYPE="real" DIM="(:)">
!     Pressure at model top (Pa)
!   </IN>
!   <IN NAME="zma" TYPE="real" DIM="(:,:)">
!     Model full level absolute geopotential heights (m)
!   </IN>
!   <IN NAME="zi" TYPE="real" DIM="(:,:)">
!     Model half level absolute geopotential heights (m)
!   </IN>
!   <IN NAME="coszen" TYPE="real" DIM="(:)">
!     Cosine of solar zenith angle
!   </IN>
!   <IN NAME="albedo" TYPE="real" DIM="(:)">
!     Surface albedo
!   </IN>
!   <IN NAME="cldfr" TYPE="real" DIM="(:,:)">
!     Cloud fraction
!   </IN>
!   <IN NAME="cwat" TYPE="real" DIM="(:,:)">
!     Cloud liquid+ice water (kg/kg)
!   </IN>
!   <IN NAME="cwat" TYPE="real" DIM="(:,:)">
!     Cloud liquid+ice water (kg/kg)
!   </IN>
!   <IN NAME="tfld" TYPE="real" DIM="(:,:)">
!     Model temperature (K)
!   </IN>
!   <IN NAME="sh" TYPE="real" DIM="(:,:)">
!     Model specific humidity (kg/kg)
!   </IN>
!   <IN NAME="sulfate" TYPE="real" DIM="(:,:)">
!     Off-line sulfate aerosol volume mixing ratio (mol/mol)
!   </IN>
!   <IN NAME="psc" TYPE="psc_type">
!     Polar stratospheric cloud amounts
!   </IN>
!   <IN NAME="solar_phase" TYPE="real">
!     Solar cycle phase (1=max, 0=min)
!   </IN>
!   <IN NAME="esfact" TYPE="real">
!     Earth-sun distance factor (r_avg/r)^2
!   </IN>
!   <IN NAME="inv_data" TYPE="real" DIM="(:,:,:)">
!     Volume mixing ratios of "invariant" species (mol/mol)
!   </IN>
!   <IN NAME="do_interactive_h2o" TYPE="logical">
!     Include water vapor sources/sinks?
!   </IN>
!   <INOUT NAME="vmr" TYPE="real" DIM="(:,:,:)">
!     Trace species volume mixing ratio (mol/mol)
!   </INOUT>
!   <OUT NAME="prod_out" TYPE="real" DIM="(:,:,:)">
!     Trace species photochemical production rates (mol/mol/s)
!   </OUT>
!   <OUT NAME="loss_out" TYPE="real" DIM="(:,:,:)">
!     Trace species photochemical loss rates (mol/mol/s)
!   </OUT>
!   <OUT NAME="imp_slv_nonconv" TYPE="real" DIM="(:,:)">
!     Flag for implicit solver non-convergence (fraction)
!   </OUT>
      subroutine chemdr( vmr, &
                         Time, &
                         lat, lon, &
                         delt, &
                         ps, ptop, pmid, pdel, &
                         zma, zi, &
                         cldfr, cwat, tfld, inv_data, sh, &
                         albedo, coszen, esfact, &
                         prod_out, loss_out, jvals_out, rate_const_out, sulfate, psc, &
                         do_interactive_h2o, solar_phase, imp_slv_nonconv, &
                         plonl )
!-----------------------------------------------------------------------
!     ... Chem_solver advances the volumetric mixing ratio
!         forward one time step via a combination of explicit,
!         ebi, hov, fully implicit, and/or rodas algorithms.
!-----------------------------------------------------------------------

      use chem_mods_mod,    only : indexm, nadv_mass, phtcnt, gascnt, rxntot, clscnt1, clscnt4, clscnt5, &
                                   ncol_abs, grpcnt, nfs, extcnt, hetcnt
      use mo_photo_mod,     only : set_ub_col, setcol, photo, &
                                   sundis
      use mo_exp_sol_mod,   only : exp_sol
      use mo_imp_sol_mod,   only : imp_sol
      use mo_rodas_sol_mod, only : rodas_sol
      use mo_usrrxt_mod,    only : usrrxt
      use mo_setinv_mod,    only : setinv
      use mo_setrxt_mod,    only : setrxt
      use mo_adjrxt_mod,    only : adjrxt
      use mo_phtadj_mod,    only : phtadj
      use mo_setsox_mod,    only : setsox
      use mo_chem_utls_mod, only : inti_mr_xform, adjh2o, negtrc, mmr2vmr, vmr2mmr, &
                                   get_spc_ndx, get_grp_mem_ndx
      use time_manager_mod, only : time_type
      use strat_chem_utilities_mod, only : psc_type

      implicit none

!-----------------------------------------------------------------------
!        ... Dummy arguments
!-----------------------------------------------------------------------
      type(time_type), intent(in) :: Time             ! time
      real,    intent(in) ::  lat(:), lon(:)          ! latitude, longitude
      integer, intent(in) ::  plonl
      real,    intent(in) ::  delt                    ! timestep in seconds
      real, intent(inout) ::  vmr(:,:,:)              ! transported species ( vmr )
      real, dimension(:), intent(in) :: &
                              ps, &                   ! surface press ( pascals )
                              ptop, &                 ! model top pressure (pascals)
!                             oro, &                  ! surface orography flag
                              albedo, &               ! surface albedo
                              coszen                  ! cosine of solar zenith angle
!                             tsurf, &                ! surface temperature
!                             phis, &                 ! surf geopot
!                             cldtop                  ! cloud top level ( 1 ... plev )
      real, dimension(:,:), intent(in) :: &
                              pmid, &                 ! midpoint press ( pascals )
                              pdel, &                 ! delta press across midpoints
                              zma, &                  ! abs geopot height at midpoints ( m )
                              cldfr, &                ! cloud fraction
!                             cmfdqr, &               ! dq/dt for convective rainout
!                             nrain, &                ! release of strt precip ( 1/s )
!                             nevapr, &               ! evap precip ( 1/s )
                              cwat, &                 ! total cloud water (kg/kg)
                              tfld, &                 ! midpoint temperature
                              sh, &                   ! specific humidity ( kg/kg )
                              sulfate                 ! sulfate aerosol
      type(psc_type), intent(in) :: &
                              psc                     ! polar stratospheric clouds (PSCs)
      real, intent(in) ::     solar_phase, &          ! solar cycle phase (1=max, 0=min)
                              esfact                  ! earth-sun distance factor (r_avg/r)^2
      real, dimension(:,:), intent(in) :: &
                              zi                      ! abs geopot height at interfaces ( m )
      real, dimension(:,:,:), intent(out) :: &
                              prod_out, &             ! chemical production rate
                              loss_out                ! chemical loss rate
      real, dimension(:,:,:), intent(out) :: &
                              jvals_out               ! photolysis rates (J-values, s^-1)
      real, dimension(:,:,:), intent(out) :: &
                              rate_const_out          ! kinetic rxn rate constants (cm^3 molec^-1 s^-1 for 2nd order)
      real, dimension(:,:,:), intent(in) :: &
                              inv_data                ! invariant species
      real, dimension(:,:), intent(out) :: &
                              imp_slv_nonconv         ! flag for implicit solver non-convergence (fraction)
      logical, intent(in) ::  do_interactive_h2o      ! include h2o sources/sinks

!-----------------------------------------------------------------------
!             ... Local variables
!-----------------------------------------------------------------------
      integer, parameter :: inst = 1, avrg = 2
      integer  ::  k
!     integer  ::  ox_ndx, o3_ndx
      integer  ::  so2_ndx, so4_ndx
      real     ::  invariants(plonl,SIZE(vmr,2),max(1,nfs))
      real     ::  col_dens(plonl,SIZE(vmr,2),max(1,ncol_abs))                  ! column densities (molecules/cm^2)
      real     ::  col_delta(plonl,0:SIZE(vmr,2),max(1,ncol_abs))               ! layer column densities (molecules/cm^2)
      real     ::  het_rates(plonl,SIZE(vmr,2),max(1,hetcnt))
      real     ::  extfrc(plonl,SIZE(vmr,2),max(1,extcnt))
      real     ::  reaction_rates(plonl,SIZE(vmr,2),rxntot)
      real, dimension(plonl,SIZE(vmr,2)) :: &
                   h2ovmr, &             ! water vapor volume mixing ratio
                   mbar, &               ! mean wet atmospheric mass ( amu )
                   zmid                  ! midpoint geopotential in km
      real, dimension(plonl,SIZE(zi,2)) :: &
                   zint                  ! interface geopotential in km
      integer :: plev, plevp, plnplv, num_invar
      integer :: nstep

      plev = SIZE(vmr,2)
      plevp = SIZE(zi,2)
      plnplv = plonl*plev
      num_invar = SIZE(invariants,3)
      nstep = 0
      
      
!-----------------------------------------------------------------------      
!        ... Initialize xform between mass and volume mixing ratios
!-----------------------------------------------------------------------      
      call inti_mr_xform( sh, mbar, plonl )
!-----------------------------------------------------------------------      
!        ... Xform from mmr to vmr
!-----------------------------------------------------------------------      
!     call mmr2vmr( vmr, mmr, mbar, plonl )
!-----------------------------------------------------------------------      
!        ... Xform water vapor from mmr to vmr and adjust in stratosphere
!-----------------------------------------------------------------------      
      call adjh2o( h2ovmr, sh, mbar, vmr, do_interactive_h2o, plonl )
!-----------------------------------------------------------------------      
!        ... Xform geopotential height from m to km 
!            and pressure from hPa to mb
!-----------------------------------------------------------------------      
      do k = 1,plev
         zmid(:,k) = 1.e-3 * zma(:,k)
         zint(:,k) = 1.e-3 * zi(:,k)
      end do
      zint(:,plevp) = 1.e-3 * zi(:,plevp)

      if( nfs > 0 ) then
!-----------------------------------------------------------------------      
!        ... Set the "invariants"
!-----------------------------------------------------------------------      
         call setinv( invariants, tfld, h2ovmr, pmid, inv_data, &
                      do_interactive_h2o, plonl )
      end if
      if( ncol_abs > 0 .and. phtcnt > 0 ) then
!-----------------------------------------------------------------------      
!        ... Xform family ox assuming that all ox is o3
!-----------------------------------------------------------------------      
!        ox_ndx = get_spc_ndx( 'OX' )
!        if( ox_ndx > 0 ) then
!           o3_ndx = get_grp_mem_ndx( 'O3' )
!           if( o3_ndx > 0 ) then
!              vmr(:,:,ox_ndx) = mbar(:,:) * mmr(:,:,ox_ndx) / nadv_mass(o3_ndx)
!           end if
!        end if
!-----------------------------------------------------------------------      
!        ... Set the column densities at the upper boundary
!-----------------------------------------------------------------------      
         call set_ub_col( col_delta, vmr, invariants, pdel, ptop, plonl )
      end if
      if( gascnt > 0 ) then
!-----------------------------------------------------------------------      
!       ...  Set rates for "tabular" and user specified reactions
!-----------------------------------------------------------------------      
         call setrxt( reaction_rates, tfld, invariants(:,:,indexm), plonl, plev, plnplv )
!        call sulf_interp( lat, ip, pmid, caldayn, sulfate, plonl )
         call usrrxt( reaction_rates, tfld, invariants, h2ovmr, pmid, &
                      invariants(:,:,indexm), sulfate, psc, vmr, sh, delt, plonl )
!-----------------------------------------------------------------------      
!       ...  Save reaction rate constants for diagnostic output
!-----------------------------------------------------------------------      
         rate_const_out(:,:,:) = reaction_rates(:,:,phtcnt+1:rxntot)
!-----------------------------------------------------------------------      
!       ...  History output for instantaneous reaction rates
!-----------------------------------------------------------------------      
!        do file = 1,moz_file_cnt
!           if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(9,inst) > 0 ) then
!              do m = 1,hfile(file)%histout_cnt(9,inst)
!                  fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(9,inst)+m-1)
!                  hndx    = hfile(file)%inst_map(hfile(file)%histout_ind(9,inst)+m-1)
!                 call outfld( fldname, reaction_rates(1,1,hndx+phtcnt), plonl, ip, lat, file )
!              end do
!           end if
!-----------------------------------------------------------------------      
!       ...  History output for time averaged reaction rates
!-----------------------------------------------------------------------      
!           do m = 1,hfile(file)%histout_cnt(9,avrg)
!               fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(9,avrg)+m-1)
!               hndx = hfile(file)%timav_map(hfile(file)%histout_ind(9,avrg)+m-1)
!              call outfld( fldname, reaction_rates(1,1,hndx+phtcnt), plonl, ip, lat, file )
!           end do
!        end do
         call adjrxt( reaction_rates, invariants, invariants(:,:,indexm), &
                      plnplv )
      end if
      
      if( phtcnt > 0 ) then
!-----------------------------------------------------------------------
!        ... Compute the photolysis rates
!-----------------------------------------------------------------------      
         if( ncol_abs > 0 ) then
!-----------------------------------------------------------------------      
!             ... Set the column densities
!-----------------------------------------------------------------------      
            call setcol( col_delta, col_dens, pdel, plonl )
         end if
!-----------------------------------------------------------------------      
!             ... Calculate the surface albedo
!-----------------------------------------------------------------------      
!        call srfalb( lat, ip, albs, caldayn, tsurf, plonl )
!-----------------------------------------------------------------------      
!             ... Calculate the photodissociation rates
!-----------------------------------------------------------------------      
         call photo( reaction_rates(:,:,:phtcnt), pmid, pdel, tfld, zmid, &
                     col_dens, &
!                    zen_angle, albs, &
                     coszen, albedo, &
                     cwat, cldfr, &
!                    sunon, sunoff, &
                     esfact, solar_phase, plonl )
!-----------------------------------------------------------------------      
!       ...  History output for instantaneous photo rates
!-----------------------------------------------------------------------      
!        do file = 1,moz_file_cnt
!           if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(8,inst) > 0 ) then
!              do m = 1,hfile(file)%histout_cnt(8,inst)
!                 fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(8,inst)+m-1)
!                  hndx    = hfile(file)%inst_map(hfile(file)%histout_ind(8,inst)+m-1)
!                 call outfld( fldname, reaction_rates(1,1,hndx), plonl, ip, lat, file )
!              end do
!           end if
!-----------------------------------------------------------------------      
!       ...  History output for time averaged photo rates
!-----------------------------------------------------------------------      
!           do m = 1,hfile(file)%histout_cnt(8,avrg)
!               fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(8,avrg)+m-1)
!               hndx    = hfile(file)%timav_map(hfile(file)%histout_ind(8,avrg)+m-1)
!              call outfld( fldname, reaction_rates(1,1,hndx), plonl, ip, lat, file )
!           end do
!        end do
!-----------------------------------------------------------------------      
!       ...  Save photolysis rates for diagnostic output
!-----------------------------------------------------------------------      
         jvals_out(:,:,:) = reaction_rates(:,:,:phtcnt)
!-----------------------------------------------------------------------      
!             ... Adjust the photodissociation rates
!-----------------------------------------------------------------------      
         call phtadj( reaction_rates, invariants, invariants(:,:,indexm), &
                      plnplv )
      end if
      if( hetcnt > 0 ) then
!-----------------------------------------------------------------------
!        ... Compute the heterogeneous rates at time = t(n+1)
!-----------------------------------------------------------------------      
!        call sethet( het_rates, pmid, lat, zmid, phis, &
!                     tfld, cmfdqr, nrain, nevapr, delt, &
!                     invariants(1,1,indexm), vmr, plonl )
!-----------------------------------------------------------------------      
!       ...  History output for instantaneous wet removal rates
!-----------------------------------------------------------------------      
!        do file = 1,moz_file_cnt
!           if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(10,inst) > 0 ) then
!              do m = 1,hfile(file)%histout_cnt(10,inst)
!                 fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(10,inst)+m-1)
!                     hndx    = hfile(file)%inst_map(hfile(file)%histout_ind(10,inst)+m-1)
!                    call outfld( fldname, het_rates(1,1,hndx), plonl, ip, lat, file )
!              end do
!           end if
!-----------------------------------------------------------------------      
!       ...  History output for time averaged wet removal rates
!-----------------------------------------------------------------------      
!           do m = 1,hfile(file)%histout_cnt(10,avrg)
!               fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(10,avrg)+m-1)
!               hndx    = hfile(file)%timav_map(hfile(file)%histout_ind(10,avrg)+m-1)
!              call outfld( fldname, het_rates(1,1,hndx), plonl, ip, lat, file )
!           end do
!        end do
      end if
      if( extcnt > 0 ) then
!-----------------------------------------------------------------------
!        ... Compute the extraneous frcing at time = t(n+1)
!-----------------------------------------------------------------------      
!        call setext( extfrc, lat, ip, zint, cldtop, plonl )
!-----------------------------------------------------------------------      
!       ...  History output for instantaneous external forcing rates
!-----------------------------------------------------------------------      
!        do file = 1,moz_file_cnt
!           if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(11,inst) > 0 ) then
!              do m = 1,hfile(file)%histout_cnt(11,inst)
!                  fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(11,inst)+m-1)
!                  hndx = hfile(file)%inst_map(hfile(file)%histout_ind(11,inst)+m-1)
!                 call outfld( fldname, extfrc(1,1,hndx), plonl, ip, lat, file )
!              end do
!           end if
!-----------------------------------------------------------------------      
!       ...  History output for time averaged external forcing rates
!-----------------------------------------------------------------------      
!           do m = 1,hfile(file)%histout_cnt(11,avrg)
!               fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(11,avrg)+m-1)
!               hndx    = hfile(file)%timav_map(hfile(file)%histout_ind(11,avrg)+m-1)
!              call outfld( fldname, extfrc(1,1,hndx), plonl, ip, lat, file )
!           end do
!        end do
!        do m = 1,max(1,extcnt)
!           do k = 1,SIZE(vmr,2)
!               extfrc(:,k,m) = extfrc(:,k,m) / invariants(:,k,indexm)
!           end do
!        end do
      end if
      if( grpcnt > 0 ) then
!-----------------------------------------------------------------------
!        ... Set the group ratios
!-----------------------------------------------------------------------      
!        call set_grp_ratios( group_ratios, reaction_rates, vmr, mmr, nas, &
!                              mbar, invariants, plonl )
!-----------------------------------------------------------------------
!             ... Modify the reaction rate of any reaction
!           with group member or proportional reactant(s)
!-----------------------------------------------------------------------
!        call rxt_mod( reaction_rates, het_rates, group_ratios, plnplv )
      end if

!=======================================================================
!        ... Call the class solution algorithms
!=======================================================================
      if( clscnt1 > 0 .and. rxntot > 0 ) then
!-----------------------------------------------------------------------
!        ... Solve for "explicit" species
!-----------------------------------------------------------------------
         call exp_sol( vmr, reaction_rates, &
                       het_rates, extfrc, &
                       nstep, delt, &
!                      invariants(1,1,indexm), &
                       prod_out, loss_out, &
                       plonl, plnplv )
      end if
      if( clscnt4 > 0 .and. rxntot > 0 ) then
!-----------------------------------------------------------------------
!        ... Solve for "Implicit" species
!-----------------------------------------------------------------------
         call imp_sol( vmr, reaction_rates, &
                       het_rates, extfrc, &
                       nstep, delt, &
!                      invariants(1,1,indexm), &
                       lat, lon, &
                       prod_out, loss_out, &
                       imp_slv_nonconv, &
                       plonl, plnplv )
      end if
      if( clscnt5 > 0 .and. rxntot > 0 ) then
!-----------------------------------------------------------------------
!        ... Solve for "Rodas" species
!-----------------------------------------------------------------------
         call rodas_sol( vmr, reaction_rates, &
                         het_rates, extfrc, &
                         nstep, delt, &
!                        invariants(1,1,indexm), &
                         plonl, plnplv )
      end if
!-----------------------------------------------------------------------
!       ... Heterogeneous chemistry
!-----------------------------------------------------------------------
      so2_ndx = get_spc_ndx( 'SO2' )
      so4_ndx = get_spc_ndx( 'SO4' )
      if( so2_ndx > 0 .and. so4_ndx > 0 ) then
         call setsox( pmid, plonl, delt, tfld, sh, &
!                     nrain, nevapr, cmfdqr, &
                      cwat, invariants(:,:,indexm), &
                      vmr )
      end if
!-----------------------------------------------------------------------      
!         ... Check for negative values and reset to zero
!-----------------------------------------------------------------------      
!     call negtrc( lat, 'After chemistry ', vmr, plonl )
!-----------------------------------------------------------------------      
!         ... Output instantaneous "wet" advected volume mixing
!-----------------------------------------------------------------------      
!     do file = 1,moz_file_cnt
!        if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(1,inst) > 0 ) then
!           do m = 1,hfile(file)%histout_cnt(1,inst)
!               fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(1,inst)+m-1)
!               hndx    = hfile(file)%inst_map(hfile(file)%histout_ind(1,inst)+m-1)
!              call outfld( fldname, vmr(1,1,hndx), plonl, ip, lat, file )
!           end do
!        end if
!-----------------------------------------------------------------------      
!         ... Output time averaged "wet" advected volume mixing ratios
!-----------------------------------------------------------------------      
!        do m = 1,hfile(file)%histout_cnt(1,avrg)
!            fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(1,avrg)+m-1)
!            hndx    = hfile(file)%timav_map(hfile(file)%histout_ind(1,avrg)+m-1)
!           call outfld( fldname, vmr(1,1,hndx), plonl, ip, lat, file )
!        end do
!     end do
!-----------------------------------------------------------------------      
!         ... Output instantaneous "wet" non-advected volume mixing
!-----------------------------------------------------------------------      
!     group_write(:moz_file_cnt) = hfile(:moz_file_cnt)%wrhstts .and. &
!                                  hfile(:moz_file_cnt)%histout_cnt(2,inst) > 0
!     if( ANY( group_write(:moz_file_cnt) ) .or. &
!         ANY( hfile(:moz_file_cnt)%histout_cnt(2,avrg) > 0 ) ) then
!        call mak_grp_vmr( vmr, group_ratios(1,1,1), group_vmr(1,1,1), plonl )
!     end if
!     do file = 1,moz_file_cnt
!        if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(2,inst) > 0 ) then
!           do m = 1,hfile(file)%histout_cnt(2,inst)
!               fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(2,inst)+m-1)
!               hndx    = hfile(file)%inst_map(hfile(file)%histout_ind(2,inst)+m-1)
!              call outfld( fldname, group_vmr(1,1,hndx), plonl, ip, lat, file )
!           end do
!        end if
!-----------------------------------------------------------------------      
!         ... Output time averaged "wet" non-advected volume mixing ratios
!-----------------------------------------------------------------------      
!        do m = 1,hfile(file)%histout_cnt(2,avrg)
!            fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(2,avrg)+m-1)
!            hndx    = hfile(file)%timav_map(hfile(file)%histout_ind(2,avrg)+m-1)
!           call outfld( fldname, group_vmr(1,1,hndx), plonl, ip, lat, file )
!        end do
!     end do
!-----------------------------------------------------------------------      
!         ... Xform from vmr to mmr
!-----------------------------------------------------------------------      
!     call vmr2mmr( vmr, mmr, nas, group_ratios, mbar, plonl )

      end subroutine chemdr
!</SUBROUTINE>

      end module mo_chemdr_mod



      module mo_chemini_mod

implicit none
      private
      public :: chemini

character(len=128), parameter :: version     = '$Id: mo_chemini.F90,v 16.0.4.1.2.1 2010/03/25 00:36:29 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

      subroutine chemini( file_jval_lut, file_jval_lut_min, use_tdep_jvals, &
                          o3_column_top, jno_scale_factor, verbose )
!-----------------------------------------------------------------------
!       ... Chemistry module intialization
!-----------------------------------------------------------------------

      use MO_PHOTO_MOD,      only : prate_init
      use mo_chem_utls_mod,  only : chem_utls_init
      use mo_usrrxt_mod,     only : usrrxt_init
      use CHEM_MODS_mod,     only : grpcnt, clscnt1, clscnt4, clscnt5, chem_mods_init
      use MO_EXP_SOL_mod,    only : exp_slv_init
      use MO_IMP_SOL_mod,    only : imp_slv_init
      use MO_RODAS_SOL_mod,  only : rodas_slv_init

      use MO_READ_SIM_CHM_mod, only : read_sim_chm

      implicit none

!-----------------------------------------------------------------------
!       ... Dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: file_jval_lut, &
                                      file_jval_lut_min
      logical,          intent(in) :: use_tdep_jvals
      real,             intent(in) :: o3_column_top, &
                                      jno_scale_factor
      integer,          intent(in) :: verbose

!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
      character(len=80) ::   lpath
      character(len=80) ::   mspath
      character(len=32) ::   filename, filename_solarmin
      
      character(len=128) ::  sim
      integer :: sim_file_cnt

!-----------------------------------------------------------------------
!       ... Allocate variables
!-----------------------------------------------------------------------
      call chem_mods_init

!-----------------------------------------------------------------------
!       ... Read sim.dat
!-----------------------------------------------------------------------
      sim = 'INPUT/sim.dat'
      call read_sim_chm( sim, sim_file_cnt )

!-----------------------------------------------------------------------
!       ... Diagnostics initialization
!-----------------------------------------------------------------------
!     call diags_init( tracnam, plonl, platl, pplon )

!-----------------------------------------------------------------------
!       ... Initialize photorate module
!-----------------------------------------------------------------------
!     filename = photo_flsp%nl_filename
!     lpath    = photo_flsp%local_path
!     mspath   = photo_flsp%remote_path
      lpath = 'INPUT/'
      filename = TRIM(file_jval_lut)
      filename_solarmin = TRIM(file_jval_lut_min)
      call prate_init( filename, filename_solarmin, lpath, mspath, &
                       use_tdep_jvals, o3_column_top, jno_scale_factor )

!-----------------------------------------------------------------------
!       ... Read time-independent airplane emissions
!-----------------------------------------------------------------------
!     emires = emis_flsp%hor_res
!     if( emires(1:1) /= '.' ) then
!        emires = '.' // emires
!     end if
!     lpath    = emis_flsp%local_path
!     mspath   = emis_flsp%remote_path
!     filename = 'emissions.aircraft' // TRIM(emires) // '.nc'
!     call airpl_src( filename, lpath, mspath, plonl, platl, pplon )

!-----------------------------------------------------------------------
!       ... Initialize the chem utils module
!-----------------------------------------------------------------------
      call chem_utls_init

!-----------------------------------------------------------------------
!       ... Read time-dependent surface flux dataset
!-----------------------------------------------------------------------
!     call srf_emis_init( plonl, platl, pplon )

!-----------------------------------------------------------------------
!       ... Intialize the het rates module
!-----------------------------------------------------------------------
!     call sethet_init

!-----------------------------------------------------------------------
!       ... Intialize the ext frcing module
!-----------------------------------------------------------------------
!     call setext_init

!-----------------------------------------------------------------------
!       ... Intialize the rxt rate constant module
!-----------------------------------------------------------------------
      call usrrxt_init( verbose )

!-----------------------------------------------------------------------
!       ... Intialize the grp ratios module
!-----------------------------------------------------------------------
!     call set_grp_ratios_init

!-----------------------------------------------------------------------
!       ... Read time-dependent surface variables dataset
!-----------------------------------------------------------------------
!     surfres = surf_flsp%hor_res
!     if( surfres(1:1) /= '.' ) then
!        surfres = '.' // surfres
!     end if
!     filename = 'surfdata' // TRIM(surfres) // '.nc'
!     lpath    = surf_flsp%local_path
!     mspath   = surf_flsp%remote_path
!     call surf_init( filename, lpath, mspath, plonl, platl, pplon )

!-----------------------------------------------------------------------
!       ... Read time-dependent upper boundary values
!-----------------------------------------------------------------------
!     filename = ubc_flsp%nl_filename
!     lpath    = ubc_flsp%local_path
!     mspath   = ubc_flsp%remote_path
!     call ub_init( platl, filename, lpath, mspath )

!-----------------------------------------------------------------------
!       ... Read time-dependent sulfate dataset
!           NOTE : This is now a netcdf dataset
!-----------------------------------------------------------------------
!     filename = 'sulfate.M1.nc'
!     lpath    = sulf_flsp%local_path
!     mspath   = sulf_flsp%remote_path
!     call sulf_init( plonl, platl, pplon, filename, lpath, mspath )

      if( clscnt1 > 0 ) then
!-----------------------------------------------------------------------
!       ... Initialize the explicit solver
!-----------------------------------------------------------------------
         call exp_slv_init
      end if
      if( clscnt4 > 0 ) then
!-----------------------------------------------------------------------
!       ... Initialize the implicit solver
!-----------------------------------------------------------------------
         call imp_slv_init( verbose )
      end if
      if( clscnt5 > 0 ) then
!-----------------------------------------------------------------------
!       ... Initialize the implicit solver
!-----------------------------------------------------------------------
         call rodas_slv_init
      end if

      end subroutine chemini

      end module mo_chemini_mod


      module mo_chem_utls_mod

implicit none
      private
      public :: adjh2o, inti_mr_xform, mmr2vmr, vmr2mmr, negtrc, &
                get_spc_ndx, get_het_ndx, get_extfrc_ndx, &
                has_drydep, has_srfems, get_rxt_ndx, get_grp_ndx, &
                get_grp_mem_ndx, chem_utls_init

!     save

      integer :: ox_ndx, o3_ndx, o1d_ndx, o_ndx
      logical :: do_ox

character(len=128), parameter :: version     = '$Id: mo_chem_utls.F90,v 16.0.4.1.2.1 2010/03/25 00:36:29 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

      subroutine chem_utls_init
!-----------------------------------------------------------------------
!     ... Initialize the chem utils module
!-----------------------------------------------------------------------

      implicit none

      ox_ndx = get_spc_ndx( 'OX' )
      if( ox_ndx > 0 ) then
         o3_ndx  = get_grp_mem_ndx( 'O3' )
         o1d_ndx = get_grp_mem_ndx( 'O1D' )
         o_ndx   = get_grp_mem_ndx( 'O' )
         do_ox   = o3_ndx > 0 .and. o1d_ndx > 0 .and. o_ndx > 0
      else
         o3_ndx  = 1
         o1d_ndx = 1
         o_ndx   = 1
         do_ox = .false.
      end if

      end subroutine chem_utls_init

      subroutine adjh2o( h2o, sh, mbar, vmr, do_interactive_h2o, plonl )
!-----------------------------------------------------------------------
!     ... transform water vapor from mass to volumetric mixing ratio
!-----------------------------------------------------------------------


      implicit none

!-----------------------------------------------------------------------
!       ... dummy arguments
!-----------------------------------------------------------------------
      integer, intent(in) :: plonl
      real, dimension(:,:,:), intent(in)  :: vmr         ! xported species vmr
      real, dimension(:,:),   intent(in)  :: sh          ! specific humidity ( mmr )
      real, dimension(:,:),   intent(in)  :: mbar        ! atmos mean mass
      logical,                intent(in)  :: do_interactive_h2o ! include h2o sources/sinks?
      real, dimension(:,:),   intent(out) :: h2o         ! water vapor vmr

!-----------------------------------------------------------------------
!       ... local variables
!-----------------------------------------------------------------------
      real, parameter :: mh2o = 1. /18.01528

      integer ::   k, ndx_ch4
      real    ::   t_value(plonl)
      integer ::   plev

      plev = SIZE(vmr,2)
!-----------------------------------------------------------------------
!       ... if not using interactive water vapor, adjust model
!           water vapor in stratosphere for source from CH4 oxidation
!-----------------------------------------------------------------------
      ndx_ch4 = get_spc_ndx( 'CH4' )
!++lwh
         do k = 1,plev
            h2o(:,k)   = mbar(:,k) * sh(:plonl,k) * mh2o
            if( .not. do_interactive_h2o .and. ndx_ch4 > 0 ) then
               t_value(:) = 6.e-6 - 2.*vmr(:,k,ndx_ch4)
!              where( t_value(:) > h2o(:,k) )
!                 h2o(:,k) = t_value(:)
!              end where
               h2o(:,k) = MAX(h2o(:,k),t_value(:))
            end if
         end do
!--lwh

      end subroutine adjh2o      

      subroutine inti_mr_xform( sh, mbar, plonl )
!-----------------------------------------------------------------
!       ... initialize mean atmospheric "wet" mass
!-----------------------------------------------------------------


      implicit none

!-----------------------------------------------------------------
!       ... dummy args
!-----------------------------------------------------------------
      integer, intent(in) :: plonl
      real, intent(in)  :: sh(:,:)     ! specific humidity (kg/kg)
      real, intent(out) :: mbar(:,:)   ! mean wet atm mass ( amu )

!-----------------------------------------------------------------
!       ... local variables
!-----------------------------------------------------------------
      real, parameter :: dry_mass = 28.966    ! amu
      real, parameter :: mfac = 1. / .622

      integer :: k
      integer :: plev
      
      plev = size(sh,2)

      do k = 1,plev
         mbar(:,k) = dry_mass
      end do

      end subroutine inti_mr_xform

      subroutine mmr2vmr( vmr, mmr, mbar, plonl )
!-----------------------------------------------------------------
!       ... xfrom from mass to volume mixing ratio
!-----------------------------------------------------------------

      use chem_mods_mod, only : adv_mass
      use mo_grid_mod,   only : pcnstm1, pcnst

      implicit none

!-----------------------------------------------------------------
!       ... dummy args
!-----------------------------------------------------------------
      integer, intent(in) :: plonl
      real, intent(in)  :: mbar(:,:)
      real, intent(in)  :: mmr(:,:,:)
      real, intent(out) :: vmr(:,:,:)

!-----------------------------------------------------------------
!       ... local variables
!-----------------------------------------------------------------
      integer :: k, m
      integer :: plev
      
      plev = size(mbar,2)

      do m = 1,pcnstm1
         if( adv_mass(m) /= 0. ) then
            do k = 1,plev
               vmr(:,k,m) = mbar(:,k) * mmr(:,k,m) / adv_mass(m)
            end do
         end if
      end do

      end subroutine mmr2vmr

      subroutine vmr2mmr( vmr, mmr, nas, grp_ratios, mbar, plonl )
!-----------------------------------------------------------------
!       ... xfrom from mass to volume mixing ratio
!-----------------------------------------------------------------

      use chem_mods_mod, only : adv_mass, nadv_mass, grpcnt
      use mo_grid_mod,   only : pcnstm1, pcnst

      implicit none

!-----------------------------------------------------------------
!       ... dummy args
!-----------------------------------------------------------------
      integer, intent(in) :: plonl
      real, intent(in)  :: mbar(:,:)
      real, intent(in)  :: vmr(:,:,:)
      real, intent(out) :: mmr(:,:,:)
      real, intent(in)  :: grp_ratios(:,:,:)
      real, intent(out) :: nas(:,:,:)

!-----------------------------------------------------------------
!       ... local variables
!-----------------------------------------------------------------
      integer :: k, m
      integer :: plev
      real    :: grp_mass(plonl)            ! weighted group mass

      plev = size(mbar,2)

!-----------------------------------------------------------------
!       ... the non-group species
!-----------------------------------------------------------------
      do m = 1,pcnstm1
         if( adv_mass(m) /= 0. ) then
            do k = 1,plev
               mmr(:,k,m) = adv_mass(m) * vmr(:,k,m) / mbar(:,k)
            end do
         end if
      end do
!-----------------------------------------------------------------
!       ... the "group" species
!-----------------------------------------------------------------
      if( do_ox ) then
         do k = 1,plev
            grp_mass(:)     = grp_ratios(:,k,o3_ndx) * nadv_mass(o3_ndx) &
                              + grp_ratios(:,k,o_ndx) * nadv_mass(o_ndx) &
                              + grp_ratios(:,k,o1d_ndx) * nadv_mass(o1d_ndx)      
            mmr(:,k,ox_ndx)  = grp_mass(:) * vmr(:,k,ox_ndx) / mbar(:,k)
            grp_mass(:)     = mmr(:,k,ox_ndx) / grp_mass(:)
            nas(:,k,o3_ndx)  = nadv_mass(o3_ndx) * grp_ratios(:,k,o3_ndx) * grp_mass(:)
            nas(:,k,o_ndx)   = nadv_mass(o_ndx) * grp_ratios(:,k,o_ndx) * grp_mass(:)
            nas(:,k,o1d_ndx) = nadv_mass(o1d_ndx) * grp_ratios(:,k,o1d_ndx) * grp_mass(:)
         end do
      end if

      end subroutine vmr2mmr

      subroutine negtrc( lat, header, fld, plonl )
!-----------------------------------------------------------------------
!       ... check for negative constituent values and
!           replace with zero value
!-----------------------------------------------------------------------

      use mo_grid_mod,    only : pcnstm1
      use m_tracname_mod, only : tracnam

      implicit none

!-----------------------------------------------------------------------
!       ... dummy arguments
!-----------------------------------------------------------------------
      integer, intent(in)          :: lat                      ! current latitude
      integer, intent(in)          :: plonl
      character(len=*), intent(in) :: header                   ! caller tag
      real, intent(inout)          :: fld(:,:,:)               ! field to check

!-----------------------------------------------------------------------
!       ... local variables
!-----------------------------------------------------------------------
      integer :: m
      integer :: nneg                       ! flag counter

      do m  = 1,pcnstm1
         nneg = count( fld(:,:,m) < 0. )
         if( nneg > 0 ) then
            where( fld(:,:,m) < 0. )
               fld(:,:,m) = 0.
            endwhere
!           if( pdiags%negtrc ) then
!              worst     = minval( fld(:,:,m) )
!              windex(:) = minloc( fld(:,:,m) )
!              iw        = windex(1)
!              kw        = windex(2)
!           end if
         end if
!        if( pdiags%negtrc .and. nneg > 0 ) then
!           write(*,*) header(:len(header)), tracnam(m), ' has ',nneg,' neg values'
!           write(*,*) ' worst =',worst,' @ long = ',iw,' lat = ',lat,' eta = ',kw
!        end if
      end do

      end subroutine negtrc

      integer function get_spc_ndx( spc_name )
!-----------------------------------------------------------------------
!     ... return overall species index associated with spc_name
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : pcnstm1
      use m_tracname_mod, only : tracnam

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: spc_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      get_spc_ndx = -1
      do m = 1,pcnstm1
         if( trim( spc_name ) == trim( tracnam(m) ) ) then
            get_spc_ndx = m
            exit
         end if
      end do

      end function get_spc_ndx

      integer function get_grp_ndx( grp_name )
!-----------------------------------------------------------------------
!     ... return group index associated with spc_name
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : ngrp, grp_lst

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: grp_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      get_grp_ndx = -1
      do m = 1,ngrp
         if( trim( grp_name ) == trim( grp_lst(m) ) ) then
            get_grp_ndx = m
            exit
         end if
      end do

      end function get_grp_ndx

      integer function get_grp_mem_ndx( mem_name )
!-----------------------------------------------------------------------
!     ... return group member index associated with spc_name
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : grpcnt
      use m_tracname_mod, only : natsnam

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: mem_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      get_grp_mem_ndx = -1
      if( grpcnt > 0 ) then
         do m = 1,max(1,grpcnt)
            if( trim( mem_name ) == trim( natsnam(m) ) ) then
               get_grp_mem_ndx = m
               exit
            end if
         end do
      end if

      end function get_grp_mem_ndx

      integer function get_het_ndx( het_name )
!-----------------------------------------------------------------------
!     ... return overall het process index associated with spc_name
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : hetcnt, het_lst

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: het_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      get_het_ndx = -1
      do m = 1,max(1,hetcnt)
         if( trim( het_name ) == trim( het_lst(m) ) ) then
            get_het_ndx = m
            exit
         end if
      end do

      end function get_het_ndx

      integer function get_extfrc_ndx( frc_name )
!-----------------------------------------------------------------------
!     ... return overall external frcing index associated with spc_name
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : extcnt, extfrc_lst

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: frc_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      get_extfrc_ndx = -1
      if( extcnt > 0 ) then
         do m = 1,max(1,extcnt)
            if( trim( frc_name ) == trim( extfrc_lst(m) ) ) then
               get_extfrc_ndx = m
               exit
            end if
         end do
      end if

      end function get_extfrc_ndx

      integer function get_rxt_ndx( rxt_alias )
!-----------------------------------------------------------------------
!     ... return overall external frcing index associated with spc_name
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : rxt_alias_cnt, rxt_alias_lst, rxt_alias_map

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: rxt_alias

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      get_rxt_ndx = -1
      do m = 1,rxt_alias_cnt
         if( trim( rxt_alias ) == trim( rxt_alias_lst(m) ) ) then
            get_rxt_ndx = rxt_alias_map(m)
            exit
         end if
      end do

      end function get_rxt_ndx

      logical function has_drydep( spc_name )
!-----------------------------------------------------------------------
!     ... return logical for species dry deposition
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : drydep_cnt, drydep_lst

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: spc_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      has_drydep = .false.
      do m = 1,drydep_cnt
         if( trim( spc_name ) == trim( drydep_lst(m) ) ) then
            has_drydep = .true.
            exit
         end if
      end do

      end function has_drydep

      logical function has_srfems( spc_name )
!-----------------------------------------------------------------------
!     ... return logical for species surface emission
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : srfems_cnt, srfems_lst

      implicit none

!-----------------------------------------------------------------------
!     ... dummy arguments
!-----------------------------------------------------------------------
      character(len=*), intent(in) :: spc_name

!-----------------------------------------------------------------------
!     ... local variables
!-----------------------------------------------------------------------
      integer :: m

      has_srfems = .false.
      do m = 1,srfems_cnt
         if( trim( spc_name ) == trim( srfems_lst(m) ) ) then
            has_srfems = .true.
            exit
         end if
      end do

      end function has_srfems

      end module mo_chem_utls_mod


      module MO_EXP_SOL_MOD

      implicit none

!     save

      private
      public :: exp_slv_init, exp_sol

      integer, parameter ::  inst = 1, avrg = 2

      integer ::  o3s_ndx, o3inert_ndx
      integer ::  oh_ndx, ho2_ndx, c2h4_ndx, c3h6_ndx, isop_ndx, &
                  mvk_ndx, macr_ndx, c10h16_ndx, no2_ndx, n2o5_ndx, &
                  no3_ndx, ox_ndx
      integer ::  jo1d_ndx, ox_l1_ndx, o1d_n2_ndx, o1d_o2_ndx, ox_l2_ndx, &
                  ox_l3_ndx, ox_l4_ndx, ox_l5_ndx, ox_l6_ndx, ox_l7_ndx, &
                  ox_l8_ndx, ox_l9_ndx, usr4_ndx, usr16_ndx, usr17_ndx
      logical ::  o3s_loss
      logical ::  class_hist_prod = .false.
      logical ::  class_hist_loss = .false.

character(len=128), parameter :: version     = '$Id: mo_exp_slv.F90,v 13.0.14.1.2.1 2010/03/25 00:36:29 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS

      subroutine exp_slv_init
!-----------------------------------------------------------------------      
!       ... Initialize the explicit solver
!-----------------------------------------------------------------------      

      use CHEM_MODS_MOD,   only : clscnt1, explicit
      use mo_chem_utls_mod, only : get_spc_ndx, get_rxt_ndx

      implicit none

!-----------------------------------------------------------------------      
!       ... Local variables
!-----------------------------------------------------------------------      

      o3s_ndx     = get_spc_ndx( 'O3S' )
      o3inert_ndx = get_spc_ndx( 'O3INERT' )
      ox_ndx = get_spc_ndx( 'OX' )
      oh_ndx = get_spc_ndx( 'OH' )
      ho2_ndx = get_spc_ndx( 'HO2' )
      c2h4_ndx = get_spc_ndx( 'C2H4' )
      c3h6_ndx = get_spc_ndx( 'C3H6' )
      isop_ndx = get_spc_ndx( 'ISOP' )
      mvk_ndx = get_spc_ndx( 'MVK' )
      macr_ndx = get_spc_ndx( 'MACR' )
      c10h16_ndx = get_spc_ndx( 'C10H16' )
      no2_ndx = get_spc_ndx( 'NO2' )
      n2o5_ndx = get_spc_ndx( 'N2O5' )
      no3_ndx = get_spc_ndx( 'NO3' )

      jo1d_ndx = get_rxt_ndx( 'jo1d' )
      ox_l1_ndx = get_rxt_ndx( 'ox_l1' )
      ox_l2_ndx = get_rxt_ndx( 'ox_l2' )
      ox_l3_ndx = get_rxt_ndx( 'ox_l3' )
      ox_l4_ndx = get_rxt_ndx( 'ox_l4' )
      ox_l5_ndx = get_rxt_ndx( 'ox_l5' )
      ox_l6_ndx = get_rxt_ndx( 'ox_l6' )
      ox_l7_ndx = get_rxt_ndx( 'ox_l7' )
      ox_l8_ndx = get_rxt_ndx( 'ox_l8' )
      ox_l9_ndx = get_rxt_ndx( 'ox_l9' )
      o1d_n2_ndx = get_rxt_ndx( 'o1d_n2' )
      o1d_o2_ndx = get_rxt_ndx( 'o1d_o2' )
      usr4_ndx = get_rxt_ndx( 'usr4' )
      usr16_ndx = get_rxt_ndx( 'usr16' )
      usr17_ndx = get_rxt_ndx( 'usr17' )

!-----------------------------------------------------------------------      
!       ... Scan for class production to history file(s)
!-----------------------------------------------------------------------      
!     do file = 1,moz_file_cnt
!        do timetype = inst,avrg
!           if( hfile(file)%histout_cnt(14,timetype) > 0 ) then
!              il = hfile(file)%histout_ind(14,timetype)
!              iu = il + hfile(file)%histout_cnt(14,timetype) - 1
!              if( timetype == inst ) then
!                 if( ANY( hfile(file)%inst_map(il:iu)/1000 == 1 ) ) then
!                    class_hist_prod = .true.
!                    exit
!                 end if
!              else if( timetype == avrg ) then
!                 if( ANY( hfile(file)%timav_map(il:iu)/1000 == 1 ) ) then
!                    class_hist_prod = .true.
!                    exit
!                 end if
!              end if
!           end if
!        end do
!        if( class_hist_prod ) then
!           exit
!        end if
!     end do
!-----------------------------------------------------------------------      
!       ... Scan for class loss to history file(s)
!-----------------------------------------------------------------------      
!     do file = 1,moz_file_cnt
!        do timetype = inst,avrg
!           if( hfile(file)%histout_cnt(15,timetype) > 0 ) then
!              il = hfile(file)%histout_ind(15,timetype)
!              iu = il + hfile(file)%histout_cnt(15,timetype) - 1
!              if( timetype == inst ) then
!                 if( ANY( hfile(file)%inst_map(il:iu)/1000 == 1 ) ) then
!                    class_hist_loss = .true.
!                    exit
!                 end if
!              else if( timetype == avrg ) then
!                 if( ANY( hfile(file)%timav_map(il:iu)/1000 == 1 ) ) then
!                    class_hist_loss = .true.
!                    exit
!                 end if
!              end if
!           end if
!        end do
!        if( class_hist_loss ) then
!           exit
!        end if
!     end do

      end subroutine EXP_SLV_INIT

      subroutine EXP_SOL( base_sol, reaction_rates, &
                          het_rates, extfrc, &
                          nstep, delt, &
                          prod_out, loss_out,&
                          plonl, plnplv )
!-----------------------------------------------------------------------
!       ... Exp_sol advances the volumetric mixing ratio
!           forward one time step via the fully explicit
!           Euler scheme
!           Note : This code has o3inert and o3s as the last
!                  two class members;  neither has production
!                  or loss - some dimensionality below has been
!                  altered to acount for this
!-----------------------------------------------------------------------

      use chem_mods_mod,        only : clscnt1, explicit, extcnt, hetcnt, rxntot
      use MO_INDPRD_MOD,        only : INDPRD
      use MO_EXP_PROD_LOSS_MOD, only : EXP_PROD_LOSS
      use mo_grid_mod,          only : pcnstm1

      implicit none
!-----------------------------------------------------------------------
!       ... Dummy arguments
!-----------------------------------------------------------------------
      integer, intent(in) ::  nstep            ! time step index
      integer, intent(in) ::  plonl            ! lon tile dim
      integer, intent(in) ::  plnplv           ! plonl*plev
      real, intent(in)    ::  delt             ! time step in seconds
      real, intent(in)    ::  reaction_rates(plnplv,max(1,rxntot))
      real, intent(in)    ::  het_rates(plnplv,max(1,hetcnt)), &
                              extfrc(plnplv,max(1,extcnt))
      real, intent(inout) ::  base_sol(plnplv,pcnstm1)
      real, intent(out), optional :: prod_out(plnplv,pcnstm1),loss_out(plnplv,pcnstm1)

!-----------------------------------------------------------------------
!       ... Local variables
!-----------------------------------------------------------------------
      integer  ::  k, l, m
      real, dimension(plnplv,max(1,clscnt1)) :: &
                   prod, &
                   loss, &
                   ind_prd

      if( explicit%indprd_cnt /= 0 ) then
!-----------------------------------------------------------------------      
!        ... Put "independent" production in the forcing
!-----------------------------------------------------------------------      
         call indprd( 1, ind_prd, base_sol, extfrc, reaction_rates )
      else
         do m = 1,max(1,clscnt1)
            ind_prd(:,m) = 0.
         end do
      end if
!-----------------------------------------------------------------------      
!       ... Form F(y)
!-----------------------------------------------------------------------      
      call exp_prod_loss( prod, loss, base_sol, reaction_rates, het_rates )

!-----------------------------------------------------------------------      
!       ... Solve for the mixing ratio at t(n+1)
!-----------------------------------------------------------------------      
      do m = 1,clscnt1
         l             = explicit%clsmap(m)
         if( l /= o3s_ndx .and. l /= o3inert_ndx ) then
         base_sol(:,l) = base_sol(:,l) + delt * (prod(:,m) + ind_prd(:,m) - loss(:,m))
         else if( l == o3s_ndx ) then
!-----------------------------------------------------------------------      
!       ... special code for o3s
! NB: The coefficients for O3S loss from rxn with ISOP, MVK, MACR, and C10H16
!     are unity. For the OX loss rate (in IMP_SOL) they are adjusted (downward)
!     to account for the regeneration of OX by these rxns. But here, we
!     consider this regenerated OX to be "tropospheric."  -- lwh 2/01
!     Also include O3S loss from NO2+OH, N2O5+aerosol, NO3+aerosol
!-----------------------------------------------------------------------      
            do k = 1,plnplv
               loss(k,m) = &
                  reaction_rates(k,jo1d_ndx)*reaction_rates(k,ox_l1_ndx) &
                  /(reaction_rates(k,o1d_n2_ndx) + reaction_rates(k,o1d_o2_ndx) &
                    + reaction_rates(k,ox_l1_ndx)) &
                + reaction_rates(k,ox_l2_ndx)*base_sol(k,oh_ndx) &
                + reaction_rates(k,ox_l3_ndx)*base_sol(k,ho2_ndx) &
                + reaction_rates(k,ox_l6_ndx)*base_sol(k,c2h4_ndx) &
                + reaction_rates(k,ox_l4_ndx)*base_sol(k,c3h6_ndx) &
                + reaction_rates(k,ox_l5_ndx)*base_sol(k,isop_ndx) &
                + reaction_rates(k,ox_l7_ndx)*base_sol(k,mvk_ndx) &
                + reaction_rates(k,ox_l8_ndx)*base_sol(k,macr_ndx) &
                + reaction_rates(k,ox_l9_ndx)*base_sol(k,c10h16_ndx) &
                + ((reaction_rates(k,usr4_ndx)*base_sol(k,no2_ndx)*base_sol(k,oh_ndx) &
                   + 3.*reaction_rates(k,usr16_ndx)*base_sol(k,n2o5_ndx) &
                   + 2.*reaction_rates(k,usr17_ndx)*base_sol(k,no3_ndx)) &
                   / max( base_sol(k,ox_ndx), 1.e-20 ))
               base_sol(k,l) = base_sol(k,l)*exp( -delt*loss(k,m) )
               loss(k,m) = loss(k,m) * base_sol(k,l)
            end do
         end if
         if( PRESENT( prod_out ) ) then
            prod_out(:,l) = prod(:,m) + ind_prd(:,m)
         end if
         if( PRESENT( loss_out ) ) then
            loss_out(:,l) = loss(:,m)
         end if
      end do

!-----------------------------------------------------------------------      
!       ... Check for explicit species production and loss output
!           First check instantaneous then time averaged
!-----------------------------------------------------------------------      
!     if( class_hist_prod ) then
!        do file = 1,moz_file_cnt
!           if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(14,1) > 0 ) then
!              do n = 1,hfile(file)%histout_cnt(14,1)
!                 class = hfile(file)%inst_map(hfile(file)%histout_ind(14,1)+n-1)/1000
!                 if( class == 1 ) then
!                    cls_ndx = mod( hfile(file)%inst_map(hfile(file)%histout_ind(14,1)+n-1),1000 )
!                    fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(14,1)+n-1)
!                    wrk(:)  = (prod(:,cls_ndx) + ind_prd(:,cls_ndx)) * hnm(:)
!                    call outfld( fldname, wrk, plonl, ip, lat, file )
!                 end if
!              end do
!           end if
!           if( hfile(file)%histout_cnt(14,2) > 0 ) then
!              do n = 1,hfile(file)%histout_cnt(14,2)
!                 class = hfile(file)%timav_map(hfile(file)%histout_ind(14,2)+n-1)/1000
!                 if( class == 1 ) then
!                    cls_ndx = mod( hfile(file)%timav_map(hfile(file)%histout_ind(14,2)+n-1),1000 )
!                    fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(14,2)+n-1)
!                    wrk(:) = (prod(:,cls_ndx) + ind_prd(:,cls_ndx)) * hnm(:)
!                    call outfld( fldname, wrk, plonl, ip, lat, file )
!                 end if
!              end do
!           end if
!        end do
!     end if
!     if( class_hist_loss ) then
!        do file = 1,moz_file_cnt
!           if( hfile(file)%wrhstts .and. hfile(file)%histout_cnt(15,1) > 0 ) then
!              do n = 1,hfile(file)%histout_cnt(15,1)
!                 class = hfile(file)%inst_map(hfile(file)%histout_ind(15,1)+n-1)/1000
!                 if( class == 1 ) then
!                    cls_ndx = mod( hfile(file)%inst_map(hfile(file)%histout_ind(15,1)+n-1),1000 )
!                    fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(15,1)+n-1)
!                    l       = explicit%clsmap(cls_ndx)
!                    wrk(:)  = loss(:,cls_ndx) * hnm(:)
!                    call outfld( fldname, wrk, plonl, ip, lat, file )
!                 end if
!              end do
!           end if
!           if( hfile(file)%histout_cnt(15,2) > 0 ) then
!              do n = 1,hfile(file)%histout_cnt(15,2)
!                 class = hfile(file)%timav_map(hfile(file)%histout_ind(15,2)+n-1)/1000
!                 if( class == 1 ) then
!                    cls_ndx = mod( hfile(file)%timav_map(hfile(file)%histout_ind(15,2)+n-1),1000 )
!                    fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(15,2)+n-1)
!                    l       = explicit%clsmap(cls_ndx)
!                    wrk(:)  = loss(:,cls_ndx) * hnm(:)
!                    call outfld( fldname, wrk, plonl, ip, lat, file )
!                 end if
!              end do
!           end if
!        end do
!     end if

      end subroutine EXP_SOL

      end module MO_EXP_SOL_MOD


      module MOZ_HOOK_MOD

      use diag_manager_mod, only : register_diag_field, send_data
      use time_manager_mod, only : time_type
      use constants_mod,    only : PI


      implicit none

      private
      public  :: moz_hook_init, moz_hook

!     save

!     real :: csrf

!----------------------------------------------------------------------
!        Set global lightning NOx scaling factor
!----------------------------------------------------------------------
      real :: factor = 1.                  ! user-controlled scaling factor to achieve arbitrary NO prod.
      real :: vdist(16,3)                  ! vertical distribution of lightning
!     real, allocatable :: prod_no(:,:,:,:)
!     real, allocatable :: prod_no_col(:,:,:)
!     real, allocatable :: flash_freq(:,:,:)
      integer :: id_prod_no_col, id_flash_freq
      real :: lat25
      
character(len=128), parameter :: version     = '$Id: mo_hook.F90,v 16.0.4.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS

      subroutine moz_hook_init( lght_no_prd_factor, Time, axes, verbose )
!----------------------------------------------------------------------
!       ... Initialize the chemistry "hook" routine
!----------------------------------------------------------------------

      implicit none

!----------------------------------------------------------------------
!        ... Dummy args
!----------------------------------------------------------------------
      type(time_type), intent(in) :: Time
      integer,         intent(in) :: axes(4)
      real,            intent(in) :: lght_no_prd_factor        ! lightning no production factor
      integer,         intent(in) :: verbose

!----------------------------------------------------------------------
!        ... local variables
!----------------------------------------------------------------------

      if (module_is_initialized) return

      factor = lght_no_prd_factor
      if (verbose >= 2) then
         write(*,*) 'MOZ_HOOK_INIT: Lightning NO production scaling factor = ',factor
      end if

!     csrf = twopi*rearth*rearth/REAL(plong)    ! rearth in m
      lat25 = 25. * PI/180.

!----------------------------------------------------------------------
!       ... vdist(kk,itype) = % of lightning NOx between (kk-1) and (kk)
!           km for profile itype
!----------------------------------------------------------------------
      vdist(:,1) = (/ 20.1, 2.3, 0.8, 1.5, 3.4, 5.3, 3.6, 3.8, &       ! midlat cont
                       5.4, 6.6, 8.3, 9.6,12.8,10.0, 6.2, 0.3 /)
      vdist(:,2) = (/  5.8, 2.9, 2.6, 2.4, 2.2, 2.1, 2.3, 6.1, &       ! trop marine
                      16.5,14.1,13.7,12.8,12.5, 2.8, 0.9, 0.3 /)
      vdist(:,3) = (/  8.2, 1.9, 2.1, 1.6, 1.1, 1.6, 3.0, 5.8, &       ! trop cont
                       7.6, 9.6,10.5,12.3,11.8,12.5, 8.1, 2.3 /)
      id_prod_no_col = register_diag_field('tracers','prod_no_col',axes(1:2),Time, &
                                           'prod_no_col','TgN/y')
      id_flash_freq  = register_diag_field('tracers','flash_freq',axes(1:2),Time, &
                                           'flash_freq','/s')
      module_is_initialized = .true.
      
      end subroutine MOZ_HOOK_INIT


      subroutine moz_hook( cldtop, cldbot, oro, zm, zint, t, &
                           prod_no, area, lat, &
                           Time,is,js )
!----------------------------------------------------------------------
!        ... General purpose chemistry "hook" routine.
!           Update deposition velocity and sulfur input fields,
!           and calculate lightning NOx source & Rn emissions.
!----------------------------------------------------------------------


      implicit none

!----------------------------------------------------------------------
!        ... Dummy args
!----------------------------------------------------------------------
!     integer, intent(in) :: ncdate                  ! date of current step (yyyymmdd)
!     integer, intent(in) :: ncsec                   ! seconds of current step
!     integer, intent(in) :: plonl
!     integer, intent(in) :: platl
!     integer, intent(in) :: pplon
!     real, intent(in) :: caldayh                    ! day of year at midpoint
!     real, intent(in) :: caldayf                    ! day of year at endpoint
      integer, intent(in) :: cldtop(:,:)             ! cloud top level index
      integer, intent(in) :: cldbot(:,:)             ! cloud bottom level index
      real, intent(in) :: oro(:,:)                   ! orography "flag"
      real, intent(in) :: zm(:,:,:)                  ! geopot height above surface at midpoints (m)
      real, intent(in) :: zint(:,:,:)                ! geopot height above surface at interfaces (m)
      real, intent(in) :: t(:,:,:)                   ! temperature
      
      real, intent(out) :: prod_no(:,:,:)            ! production of nox (molec cm^-3 s^-1)
      real, intent(in)  :: area(:,:)                 ! area (m^2)
      real, intent(in) :: lat(:,:)                   ! latitude
      type(time_type), intent(in) :: Time            ! time
      integer, intent(in) :: is, js                  ! lon,lat indices

!----------------------------------------------------------------------
!        ... Local variables
!----------------------------------------------------------------------
      integer, parameter :: land = 1, ocean = 0
      real, parameter    :: dayspy = 365.
      real, parameter    :: secpyr = dayspy * 8.64e4

      integer :: i, j, &
                 cldtind, &         ! level index for cloud top
                 cldbind            ! level index for cloud base > 273K
      integer :: k, kk, zlow_ind, zhigh_ind, itype
!     real    :: glob_flashfreq, &  ! global flash frequency [s-1]
!                glob_noprod        ! global rate of NO production [as TgN/yr]
      real    :: frac_sum
      real       :: zlow, zhigh, zlow_scal, zhigh_scal, fraction
      real, dimension( size(prod_no,1),size(prod_no,2) ) :: &
                 dchgzone, &        ! depth of discharge zone [km]
                 cldhgt, &          ! cloud top height [km]
                 cgic, &            ! Cloud-Ground/Intracloud discharge ratio
                 flash_energy, &    ! Energy of flashes per second
                 glob_prod_no_col   ! Global NO production rate for diagnostics
      real :: prod_no_col(size(prod_no,1),size(prod_no,2))
      real :: flash_freq(size(prod_no,1),size(prod_no,2))  
      logical :: used
      integer :: platl, plonl, plev
!----------------------------------------------------------------------
!         ... Parameters to determine CG/IC ratio [Price and Rind, 1993]
!----------------------------------------------------------------------
      real, parameter  :: ca = .021, cb = -.648, cc = 7.49, cd = -36.54, ce = 64.09


      plonl = size(prod_no,1)
      platl = size(prod_no,2)
      plev  = size(prod_no,3)

!----------------------------------------------------------------------
!        Lightning NO production : Initialize ...
!----------------------------------------------------------------------
      flash_freq(:,:) = 0.
      cldhgt(:,:)     = 0.
      dchgzone(:,:)   = 0.
      cgic(:,:)       = 0.
      flash_energy(:,:) = 0.
      prod_no(:,:,:)    = 0.
      prod_no_col(:,:)  = 0.
      glob_prod_no_col(:,:) = 0.

!----------------------------------------------------------------------
!        Check whether tropchem is active
!----------------------------------------------------------------------
      if (.not. module_is_initialized) return

!--------------------------------------------------------------------------------
!        ... Estimate flash frequency and resulting NO emissions
!           [Price, Penner, Prather, 1997 (JGR)]
!    Lightning only occurs in convective clouds with a discharge zone, i.e.
!    an altitude range where liquid water, ice crystals, and graupel coexist.
!    We test this by examining the temperature at the cloud base.
!    It is assumed that only one thunderstorm occurs per grid box, and its
!    flash frequency is determined by the maximum cloud top height (not the
!    depth of the discharge zone). This is somewhat speculative but yields
!    reasonable results.
!
!       The CG/IC ratio is determined by an empirical formula from Price and
!    Rind [1993]. The average energy of a CG flash is estimated as 6.7e9 J,
!    and the average energy of a IC flash is assumed to be 1/10 of that value.
!       The NO production rate is assumed proportional to the discharge energy
!    with 1e17 N atoms per J. The total number of N atoms is then distributed
!    over the complete column of grid boxes.
!--------------------------------------------------------------------------------
!      do ip = 1,pplon
         do j = 1,platl
            do i = 1,plonl
!--------------------------------------------------------------------------------
!         ... Find cloud top and bottom level above 273K
!--------------------------------------------------------------------------------
               cldtind =  cldtop(i,j) 
               cldbind =  cldbot(i,j) 
               do
                  if( cldbind <= cldtind ) then
                    exit
                  else if ( t(i,j,cldbind) < 273. ) then
                    exit
                  end if
                  cldbind = cldbind - 1
               end do
               if( cldtind < plev .and. cldtind > 0 .and. cldtind < cldbind ) then
!--------------------------------------------------------------------------------
!       ... Compute cloud top height and depth of charging zone
!--------------------------------------------------------------------------------
                  cldhgt(i,j) = 1.e-3*MAX( 0.,zint(i,j,cldtind) )
                  dchgzone(i,j) = cldhgt(i,j)-1.e-3*zm(i,j,cldbind)
!--------------------------------------------------------------------------------
!       ... Compute flash frequency for given cloud top height
!           (flashes storm^-1 min^-1)
!--------------------------------------------------------------------------------
                  if( NINT( oro(i,j) ) == land ) then
                     flash_freq(i,j) = 3.44e-5 * cldhgt(i,j)**4.9 
                  else
                     flash_freq(i,j) = 6.40e-4 * cldhgt(i,j)**1.7
                  end if
!--------------------------------------------------------------------------------
!       ... Compute CG/IC ratio
!           cgic = proportion of CG flashes (=PG from PPP paper)
!--------------------------------------------------------------------------------
                  cgic(i,j) = 1./((((ca*dchgzone(i,j) + cb)*dchgzone(i,j) + cc) &
                                      *dchgzone(i,j) + cd)*dchgzone(i,j) + ce)
                  if( dchgzone(i,j) < 5.5 ) then
                     cgic(i,j) = 0.
                  end if
                  if( dchgzone(i,j) > 14. ) then
                     cgic(i,j) = .02
                  end if
!--------------------------------------------------------------------------------
!       ... Compute flash energy (CG*6.7e9 + IC*6.7e8)
!           and convert to total energy per second
!--------------------------------------------------------------------------------
                  flash_energy(i,j) = cgic(i,j)*6.7e9 + (1. - cgic(i,j))*6.7e8
                  flash_energy(i,j) = flash_energy(i,j)*flash_freq(i,j)/60.

!--------------------------------------------------------------------------------
!         ... Compute number of N atoms produced per second
!           and convert to N atoms per second per cm2 and apply fudge factor
!--------------------------------------------------------------------------------
               prod_no_col(i,j) = 1.e17*flash_energy(i,j) &
                                        / (1.e4*area(i,j)) * factor
!--------------------------------------------------------------------------------
!         ... Compute global NO production rate in TgN/yr:
!           TgN per second: * 14.00674 * 1.65979e-24 * 1.e-12
!             NB: 1.65979e-24 = 1/AVO
!           TgN per year: * secpyr
!--------------------------------------------------------------------------------
               glob_prod_no_col(i,j) = 1.e17*flash_energy(i,j) &
                                        * 14.00674 * 1.65979e-24 * 1.e-12 * secpyr * factor
               end if
            end do
         end do
         if(id_prod_no_col >0) &
            used=send_data(id_prod_no_col,glob_prod_no_col,Time,is_in=is,js_in=js)
         if(id_flash_freq >0) &
            used=send_data(id_flash_freq,flash_freq/60.,Time,is_in=is,js_in=js)
!      end do

!--------------------------------------------------------------------------------
!         ... Accumulate global total, convert to flashes per second
!--------------------------------------------------------------------------------
!     glob_flashfreq = SUM( flash_freq(:,:) )/60.

!--------------------------------------------------------------------------------
!         ... Accumulate global NO production rate
!--------------------------------------------------------------------------------
!     glob_noprod = SUM( glob_prod_no_col(:,:) )
      
!--------------------------------------------------------------------------------
!        ... Gather,scatter global sum
!--------------------------------------------------------------------------------
!#ifdef USE_MPI
!      call MPI_ALLREDUCE( glob_flashfreq, wrk, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mpi_comm_comp, istat )
!      if( istat /= MPI_SUCCESS ) then
!         write(*,*) 'MOZ_HOOK: MPI_ALLREDUCE for flashfreq failed; error = ',istat
!         call ENDRUN
!      end if
!      glob_flashfreq = wrk
!      call MPI_ALLREDUCE( glob_noprod, wrk, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mpi_comm_comp, istat )
!      if( istat /= MPI_SUCCESS ) then
!         write(*,*) 'MOZ_HOOK: MPI_ALLREDUCE for noprod failed; error = ',istat
!         call ENDRUN
!      end if
!      glob_noprod = wrk
!#endif

!      if( masternode ) then
!         write(*,*) ' '
!         write(*,'('' Global flash freq (/s), lightning NOx (TgN/y) = '',2f10.4)') &
!                      glob_flashfreq, glob_noprod
!      end if

!      if( glob_noprod > 0. ) then
!--------------------------------------------------------------------------------
!        ... distribute production up to cloud top [Pickering et al., 1998 (JGR)]
!--------------------------------------------------------------------------------
        ! do ip = 1,pplon
            do j = 1,platl
               do i = 1,plonl
                  cldtind =  cldtop(i,j) 
                   if( prod_no_col(i,j) > 0. ) then
                     if( cldhgt(i,j) > 0. ) then
                        if(  ABS(lat(i,j)) > lat25 ) then
                           itype = 1                              ! midlatitude continental
                        else if ( NINT( oro(i,j) ) == land ) then
                           itype = 3                              ! tropical continental
                        else
                           itype = 2                              ! topical marine
                        end if
                        frac_sum = 0.
                        
                        do k = cldtind,plev
                           zlow       = zint(i,j,k+1) * 1.e-3   ! lower interface height (km)
                           zlow_scal  = zlow * 16./cldhgt(i,j)  ! scale to 16 km convection height
                           zlow_ind   = MAX( 1,INT(zlow_scal)+1 )  ! lowest vdist index to include in layer
                           zhigh      = zint(i,j,k) * 1.e-3     ! upper interface height (km)
                           zhigh_scal = zhigh * 16./cldhgt(i,j) ! height (km) scaled to 16km convection height
                           zhigh_ind  = MAX( 1,MIN( 16,INT(zhigh_scal)+1 ) )  ! highest vdist index to include in layer
                           do kk = zlow_ind,zhigh_ind
                              fraction = MIN( zhigh_scal,REAL(kk) ) &         ! fraction of vdist in this model layer
                                         - MAX( zlow_scal,REAL(kk-1) )
                              fraction = MAX( 0., MIN( 1.,fraction ) )
                              frac_sum = frac_sum + fraction*vdist(kk,itype)
                              prod_no(i,j,k) = prod_no(i,j,k) &         ! sum the fraction of column NOx in layer k
                                             + fraction*vdist(kk,itype)*.01
                           end do
                           prod_no(i,j,k) = prod_no_col(i,j) * prod_no(i,j,k) & ! multiply fraction by column amount
                                               / (1.e5*(zhigh - zlow))                   ! and convert to atom N cm^-3 s^-1
                        end do
                     end if
                  end if
               end do
            end do
       !  end do
      !end if

!--------------------------------------------------------------------------------
!       ... Output lightning no production to history file
!--------------------------------------------------------------------------------
!     do file = 1,match_file_cnt
!        do ip = 1,pplon
!           do j = 1,platl
!              call outfld( 'LNO_PROD', glob_prod_no_col(:,j,ip), plonl, ip, j, file )
!              call outfld( 'FLASHFRQ', flash_freq(:,j,ip), plonl, ip, j, file )
!              call outfld( 'CLDHGT', cldhgt(:,j,ip), plonl, ip, j, file )
!              call outfld( 'DCHGZONE', dchgzone(:,j,ip), plonl, ip, j, file )
!              call outfld( 'CGIC', cgic(:,j,ip), plonl, ip, j, file )
!           end do
!        end do
!     end do

      end subroutine MOZ_HOOK

      end module MOZ_HOOK_MOD



      module mo_imp_sol_mod

      use chem_mods_mod,        only : clscnt4
      use constants_mod,    only : PI

      implicit none

      private
      public :: imp_slv_init, imp_sol

!     save

      integer, parameter ::  inst = 1, avrg = 2
      real, parameter    ::  rel_err      = 1.e-3
      real, parameter    ::  high_rel_err = 1.e-4
!-----------------------------------------------------------------------
!               newton-raphson iteration limits
!-----------------------------------------------------------------------
!     integer, parameter :: cut_limit    = 5
      integer, parameter :: cut_limit    = 8

      integer :: ox_ndx
      integer :: oh_ndx, ho2_ndx, ch3o2_ndx, po2_ndx, ch3co3_ndx, &
                 c2h5o2_ndx, isopo2_ndx, macro2_ndx, mco3_ndx, c3h7o2_ndx, &
                 ro2_ndx, xo2_ndx, no_ndx, no2_ndx, no3_ndx, n2o5_ndx, &
                 c2h4_ndx, c3h6_ndx, isop_ndx, mvk_ndx, c10h16_ndx
      integer :: ox_p1_ndx, ox_p2_ndx, ox_p3_ndx, ox_p4_ndx, ox_p5_ndx, &
                 ox_p6_ndx, ox_p7_ndx, ox_p8_ndx, ox_p9_ndx, ox_p10_ndx, &
                 ox_p11_ndx
      integer :: ox_l1_ndx, ox_l2_ndx, ox_l3_ndx, ox_l4_ndx, ox_l5_ndx, &
                 ox_l6_ndx, ox_l7_ndx, ox_l8_ndx, ox_l9_ndx, usr4_ndx, &
                 usr16_ndx, usr17_ndx
      logical :: do_ox_pl = .true.
      integer :: verbose
      real    :: r2d

      type hst_pl
         integer  ::  cnt(2)
         logical  ::  do_hst(2)
      end type hst_pl

      real, private                      ::   small
      real, private                      ::   epsilon(clscnt4)
      type(hst_pl), private, allocatable ::   imp_hst_prod(:)
      type(hst_pl), private, allocatable ::   imp_hst_loss(:)
      logical, private, allocatable      ::   factor(:)

character(len=128), parameter :: version     = '$Id: mo_imp_slv.F90,v 17.0.4.1.2.1 2010/03/25 00:36:29 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

      subroutine imp_slv_init( verbose_in )
!-----------------------------------------------------------------------
!        ... initialize the implict solver
!-----------------------------------------------------------------------

      use chem_mods_mod,  only : clscnt4, endrun, implicit
      use mo_grid_mod,    only : pcnstm1
      use mo_chem_utls_mod, only : get_spc_ndx, get_rxt_ndx

      implicit none

!-----------------------------------------------------------------------
!       ... Dummy arguments
!-----------------------------------------------------------------------
      integer,          intent(in) :: verbose_in

!-----------------------------------------------------------------------
!        ... local variables
!-----------------------------------------------------------------------
      integer :: m, astat
      integer :: wrk(21)
      real    :: eps(pcnstm1)
      character(len=128) ::  msg

      allocate( factor(implicit%iter_max),stat=astat )
      if( astat /= 0 ) then
         write(msg,*) 'imp_slv_init: failed to allocate factor array; error = ',astat
         call endrun(msg)
      end if
      factor(:) = .true.
      eps(:)    = rel_err
      ox_ndx = get_spc_ndx( 'OX' )
      if( ox_ndx > 0 ) then
         eps(ox_ndx) = high_rel_err
      else
         m = get_spc_ndx( 'O3' )
         if( m > 0 ) then
            eps(m) = high_rel_err
         end if
      end if
      m = get_spc_ndx( 'N' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'NO' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'NO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'NO3' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'HNO3' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'HO2NO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'N2O5' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'ClONO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'BrONO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'OH' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'HO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'Cl' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'ClO' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'Br' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'BrO' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if

      do m = 1,max(1,clscnt4)
         epsilon(m) = eps(implicit%clsmap(m))
      end do

      if( ox_ndx > 0 ) then
         ox_p1_ndx = get_rxt_ndx( 'ox_p1' )
         ox_p2_ndx = get_rxt_ndx( 'ox_p2' )
         ox_p3_ndx = get_rxt_ndx( 'ox_p3' )
         ox_p4_ndx = get_rxt_ndx( 'ox_p4' )
         ox_p5_ndx = get_rxt_ndx( 'ox_p5' )
         ox_p6_ndx = get_rxt_ndx( 'ox_p6' )
         ox_p7_ndx = get_rxt_ndx( 'ox_p7' )
         ox_p8_ndx = get_rxt_ndx( 'ox_p8' )
         ox_p9_ndx = get_rxt_ndx( 'ox_p9' )
         ox_p10_ndx = get_rxt_ndx( 'ox_p10' )
         ox_p11_ndx = get_rxt_ndx( 'ox_p11' )
         wrk(1:11) = (/ ox_p1_ndx, ox_p2_ndx, ox_p3_ndx, ox_p4_ndx, ox_p5_ndx, &
                        ox_p6_ndx, ox_p7_ndx, ox_p8_ndx, ox_p9_ndx, ox_p10_ndx, ox_p11_ndx /)
         if( any( wrk(1:11) < 1 ) ) then
            do_ox_pl = .false.
         end if
         if( do_ox_pl ) then
            ox_l1_ndx = get_rxt_ndx( 'ox_l1' )
            ox_l2_ndx = get_rxt_ndx( 'ox_l2' )
            ox_l3_ndx = get_rxt_ndx( 'ox_l3' )
            ox_l4_ndx = get_rxt_ndx( 'ox_l4' )
            ox_l5_ndx = get_rxt_ndx( 'ox_l5' )
            ox_l6_ndx = get_rxt_ndx( 'ox_l6' )
            ox_l7_ndx = get_rxt_ndx( 'ox_l7' )
            ox_l8_ndx = get_rxt_ndx( 'ox_l8' )
            ox_l9_ndx = get_rxt_ndx( 'ox_l9' )
            usr4_ndx = get_rxt_ndx( 'usr4' )
            usr16_ndx = get_rxt_ndx( 'usr16' )
            usr17_ndx = get_rxt_ndx( 'usr17' )
            wrk(1:12) = (/ ox_l1_ndx, ox_l2_ndx, ox_l3_ndx, ox_l4_ndx, ox_l5_ndx, &
                           ox_l6_ndx, ox_l7_ndx, ox_l8_ndx, ox_l9_ndx, usr4_ndx, &
                           usr16_ndx, usr17_ndx /)
            if( any( wrk(1:12) < 1 ) ) then
               do_ox_pl = .false.
            end if
         end if

         if( do_ox_pl ) then
            oh_ndx = get_spc_ndx( 'OH' )
            ho2_ndx = get_spc_ndx( 'HO2' )
            ch3o2_ndx = get_spc_ndx( 'CH3O2' )
            po2_ndx = get_spc_ndx( 'PO2' )
            ch3co3_ndx = get_spc_ndx( 'CH3CO3' )
            c2h5o2_ndx = get_spc_ndx( 'C2H5O2' )
            macro2_ndx = get_spc_ndx( 'MACRO2' )
            mco3_ndx = get_spc_ndx( 'MCO3' )
            c3h7o2_ndx = get_spc_ndx( 'C3H7O2' )
            ro2_ndx = get_spc_ndx( 'RO2' )
            xo2_ndx = get_spc_ndx( 'XO2' )
            no_ndx = get_spc_ndx( 'NO' )
            no2_ndx = get_spc_ndx( 'NO2' )
            no3_ndx = get_spc_ndx( 'NO3' )
            n2o5_ndx = get_spc_ndx( 'N2O5' )
            c2h4_ndx = get_spc_ndx( 'C2H4' )
            c3h6_ndx = get_spc_ndx( 'C3H6' )
            isop_ndx = get_spc_ndx( 'ISOP' )
            isopo2_ndx = get_spc_ndx( 'ISOPO2' )
            mvk_ndx = get_spc_ndx( 'MVK' )
            c10h16_ndx = get_spc_ndx( 'C10H16' )
            wrk(1:21) = (/ oh_ndx, ho2_ndx, ch3o2_ndx, po2_ndx, ch3co3_ndx, &
                           c2h5o2_ndx, macro2_ndx, mco3_ndx, c3h7o2_ndx, ro2_ndx, &
                           xo2_ndx, no_ndx, no2_ndx, no3_ndx, n2o5_ndx, &
                           c2h4_ndx, c3h6_ndx, isop_ndx, isopo2_ndx, mvk_ndx, c10h16_ndx /)
            if( any( wrk(1:21) < 1 ) ) then
               do_ox_pl = .false.
            end if
         end if
      else
         do_ox_pl = .false.
      end if

!     if( moz_file_cnt > 0 ) then
!        allocate( imp_hst_prod(moz_file_cnt),stat=astat )
!        if( astat /= 0 ) then
!             write(*,*) 'imp_slv_init: Failed to allocate imp_hst_prod array; error = ',astat
!            call endrun
!        end if
!        if( astat /= 0 ) then
!            write(*,*) 'imp_slv_init: Failed to allocate imp_hst_prod array; error = ',astat
!            call endrun
!        end if
!         do file = 1,moz_file_cnt
!            imp_hst_prod(file)%do_hst(:) = .false.
!            imp_hst_prod(file)%cnt(:)    = 0
!         end do
!        allocate( imp_hst_loss(moz_file_cnt),stat=astat )
!        if( astat /= 0 ) then
!            write(*,*) 'imp_slv_init: Failed to allocate imp_hst_loss array; error = ',astat
!            call endrun
!        end if
!         do file = 1,moz_file_cnt
!            imp_hst_loss(file)%do_hst(:) = .false.
!            imp_hst_loss(file)%cnt(:)    = 0
!         end do
!-----------------------------------------------------------------------
!        ... scan for class production to history file(s)
!-----------------------------------------------------------------------
!        do file = 1,moz_file_cnt
!            do timetype = inst,avrg
!              if( hfile(file)%histout_cnt(14,timetype) > 0 ) then
!                  il = hfile(file)%histout_ind(14,timetype)
!                  iu = il + hfile(file)%histout_cnt(14,timetype) - 1
!                  if( timetype == inst ) then
!                     if( any( hfile(file)%inst_map(il:iu)/1000 == 4 ) ) then
!                        imp_hst_prod(file)%do_hst(timetype) = .true.
!                        do m = il,iu
!                           if( hfile(file)%inst_map(m)/1000 == 4 ) then
!                              imp_hst_prod(file)%cnt(timetype) = imp_hst_prod(file)%cnt(timetype) + 1
!                           end if
!                        end do
!                        cycle
!                    end if
!                  else if( timetype == avrg ) then
!                     if( any( hfile(file)%timav_map(il:iu)/1000 == 4 ) ) then
!                        imp_hst_prod(file)%do_hst(timetype) = .true.
!                        do m = il,iu
!                           if( hfile(file)%timav_map(m)/1000 == 4 ) then
!                              imp_hst_prod(file)%cnt(timetype) = imp_hst_prod(file)%cnt(timetype) + 1
!                           end if
!                        end do
!                        exit
!                    end if
!                 end if
!              end if
!           end do
!        end do
!-----------------------------------------------------------------------
!        ... scan for class loss to history file(s)
!-----------------------------------------------------------------------
!        do file = 1,moz_file_cnt
!            do timetype = inst,avrg
!              if( hfile(file)%histout_cnt(15,timetype) > 0 ) then
!                  il = hfile(file)%histout_ind(15,timetype)
!                  iu = il + hfile(file)%histout_cnt(15,timetype) - 1
!                  if( timetype == inst ) then
!                     if( any( hfile(file)%inst_map(il:iu)/1000 == 4 ) ) then
!                        imp_hst_loss(file)%do_hst(timetype) = .true.
!                        do m = il,iu
!                           if( hfile(file)%inst_map(m)/1000 == 4 ) then
!                              imp_hst_loss(file)%cnt(timetype) = imp_hst_loss(file)%cnt(timetype) + 1
!                           end if
!                        end do
!                        cycle
!                    end if
!                  else if( timetype == avrg ) then
!                     if( any( hfile(file)%timav_map(il:iu)/1000 == 4 ) ) then
!                        imp_hst_loss(file)%do_hst(timetype) = .true.
!                        do m = il,iu
!                           if( hfile(file)%timav_map(m)/1000 == 4 ) then
!                              imp_hst_loss(file)%cnt(timetype) = imp_hst_loss(file)%cnt(timetype) + 1
!                           end if
!                        end do
!                        exit
!                    end if
!                 end if
!              end if
!           end do
!        end do
!     end if

      small = 1.e6 * tiny( small )
      r2d = 180./PI

      verbose = verbose_in

      end subroutine imp_slv_init

      subroutine imp_sol( base_sol, reaction_rates, &
                          het_rates, extfrc, &
                          nstep, delt, &
                          lat, lon, &
                          prod_out, loss_out, non_convergence, &
                          plonl, plnplv )
!-----------------------------------------------------------------------
!              ... imp_sol advances the volumetric mixing ratio
!           forward one time step via the fully implicit euler scheme.
!           this source is meant for small l1 cache machines such as
!           the intel pentium and itanium cpus
!-----------------------------------------------------------------------

      use chem_mods_mod,         only : clscnt4, imp_nzcnt, clsze, rxntot, hetcnt, extcnt, implicit
      use m_tracname_mod,        only : tracnam
      use mo_grid_mod,           only : pcnstm1
      use mo_indprd_mod,         only : indprd
      use mo_imp_prod_loss_mod,  only : imp_prod_loss
      use mo_imp_lin_matrix_mod, only : imp_linmat
      use mo_imp_nln_matrix_mod, only : imp_nlnmat
      use mo_imp_factor_mod,     only : imp_lu_fac
      use mo_imp_solve_mod,      only : imp_lu_slv

      implicit none

!-----------------------------------------------------------------------
!             ... dummy args
!-----------------------------------------------------------------------
      integer, intent(in)    :: nstep                     ! time step index (zero based)
      real,    intent(in)    :: lat(:)                    ! latitude
      real,    intent(in)    :: lon(:)                    ! longitude
      integer, intent(in)    :: plonl                     ! longitude tile dimension
      integer, intent(in)    :: plnplv                    ! plonl*plev
      real,    intent(in)    :: delt                      ! time step (seconds)
      real,    intent(in)    :: reaction_rates(plnplv,rxntot)
      real,    intent(in)    :: het_rates(plnplv,max(1,hetcnt)), &
                                extfrc(plnplv,max(1,extcnt))
      real,    intent(out)   :: non_convergence(plnplv)   ! flag for implicit solver non-convergence (fraction)
      real,    intent(inout) :: base_sol(plnplv,pcnstm1)
      real,    intent(inout) :: prod_out(plnplv,pcnstm1),loss_out(plnplv,pcnstm1)

!-----------------------------------------------------------------------
!             ... local variables
!-----------------------------------------------------------------------
      type hst_buff
         real, pointer, dimension(:,:) :: buff
      end type hst_buff

      integer ::   nr_iter, &
                   lev, &
                   indx, &
                   i, &
                   j, &
                   k, &
                   m, &
                   cut_cnt, stp_con_cnt
      real :: interval_done, dt, dti
      real :: max_delta(max(1,clscnt4))
      real, dimension(max(1,imp_nzcnt)) :: &
                   sys_jac, &
                   lin_jac
      real, dimension(max(1,clscnt4)) :: &
                   solution, &
                   forcing, &
                   iter_invariant, &
                   prod, &
                   loss
      real :: lrxt(max(1,rxntot))
      real :: lsol(max(1,pcnstm1))
      real :: lhet(max(1,hetcnt))
      real, dimension(plnplv,max(1,clscnt4)) :: &
                   ind_prd
      logical ::   convergence
      logical ::   frc_mask
      logical ::   converged(max(1,clscnt4))
      integer :: indx_old

!-----------------------------------------------------------------------
!        ... allocate history prod, loss buffers
!-----------------------------------------------------------------------
!     if( moz_file_cnt > 0 ) then
!        allocate( prod_buff(moz_file_cnt), stat=astat )
!         if( astat /= 0 ) then
!            write(*,*) 'imp_slv_init: Failed to allocate prod_buff; error = ',astat
!            call endrun
!         end if
!         do file = 1,moz_file_cnt
!            n = SUM( imp_hst_prod(file)%cnt(:) )
!            if( n > 0 ) then
!              allocate( prod_buff(file)%buff(plnplv,n), stat=astat )
!               if( astat /= 0 ) then
!                  write(*,*) 'imp_slv_init: Failed to allocate prod buff for file = ',file,'; error = ',astat
!                  call endrun
!               end if
!            else
!               nullify( prod_buff(file)%buff )
!            end if
!         end do
!        allocate( loss_buff(moz_file_cnt), stat=astat )
!         if( astat /= 0 ) then
!            write(*,*) 'imp_slv_init: Failed to allocate loss_buff; error = ',astat
!            call endrun
!         end if
!         do file = 1,moz_file_cnt
!            n = SUM( imp_hst_loss(file)%cnt(:) )
!            if( n > 0 ) then
!              allocate( loss_buff(file)%buff(plnplv,n), stat=astat )
!               if( astat /= 0 ) then
!                  write(*,*) 'imp_slv_init: Failed to allocate loss buff for file = ',file,'; error = ',astat
!                  call endrun
!               end if
!            else
!               nullify( loss_buff(file)%buff )
!            end if
!         end do
!     end if

!     if( implicit%indprd_cnt > 0 .or. extcnt > 0 ) then
      if( implicit%indprd_cnt > 0 ) then
!-----------------------------------------------------------------------
!        ... class independent forcing
!-----------------------------------------------------------------------
         call indprd( 4, ind_prd, base_sol, extfrc, reaction_rates )
      else
         do m = 1,max(1,clscnt4)
            ind_prd(:,m) = 0.
         end do
      end if

!-----------------------------------------------------------------------
!        ... Initialize production/loss diagnostics
!-----------------------------------------------------------------------
      do k = 1,clscnt4
         j = implicit%clsmap(k)
         prod_out(:,j) = 0.
         loss_out(:,j) = 0.
      end do

      non_convergence(:) = 0.


level_loop : &
!++lwh
!     do lev = 1,plev
      do lev = 1,plnplv/plonl
!--lwh
lon_tile_loop : &
         do i = 1,plonl
            indx = (lev - 1)*plonl + i
            indx_old = 0
!-----------------------------------------------------------------------
!        ... transfer from base to local work arrays
!-----------------------------------------------------------------------
            do m = 1,rxntot
               lrxt(m) = reaction_rates(indx,m)
            end do
            if( hetcnt > 0 ) then
               do m = 1,hetcnt
                  lhet(m) = het_rates(indx,m)
                end do
            end if
!-----------------------------------------------------------------------
!        ... time step loop
!-----------------------------------------------------------------------
            dt            = delt
            cut_cnt       = 0
            stp_con_cnt   = 0
            interval_done = 0.
time_step_loop : &
            do
               dti = 1. / dt
!-----------------------------------------------------------------------
!        ... transfer from base to local work arrays
!-----------------------------------------------------------------------
               do m = 1,pcnstm1
                  lsol(m) = base_sol(indx,m)
               end do
!-----------------------------------------------------------------------
!        ... transfer from base to class array
!-----------------------------------------------------------------------
               do k = 1,clscnt4
                  j = implicit%clsmap(k)
                  m = implicit%permute(k)
                  solution(m) = lsol(j)
               end do
!-----------------------------------------------------------------------
!        ... set the iteration invariant part of the function f(y)
!        ... if there is "independent" production put it in the forcing
!-----------------------------------------------------------------------
               if( implicit%indprd_cnt > 0 .or. extcnt > 0 ) then
                  do m = 1,clscnt4
                     iter_invariant(m) = dti * solution(m) + ind_prd(indx,m)
                  end do
               else
                  do m = 1,clscnt4
                     iter_invariant(m) = dti * solution(m)
                  end do
               end if
!-----------------------------------------------------------------------
!        ... the linear component
!-----------------------------------------------------------------------
               if( implicit%lin_rxt_cnt > 0 ) then
                  call imp_linmat( lin_jac, lsol, lrxt, lhet )
               else
                  do j = 1,clscnt4
                     m = implicit%diag_map(j)
                     lin_jac(m) = -dti
                  end do
               end if

!=======================================================================
!        the newton-raphson iteration for f(y) = 0
!=======================================================================
iter_loop : &
               do nr_iter = 1,implicit%iter_max
!-----------------------------------------------------------------------
!        ... the non-linear component
!-----------------------------------------------------------------------
                  if( factor(nr_iter) ) then
                     if( implicit%nln_rxt_cnt > 0 ) then
                        call imp_nlnmat( sys_jac, lsol, lrxt, lin_jac, dti )
                     else
                        do m = 1,imp_nzcnt
                           sys_jac(m) = lin_jac(m)
                        end do
                     end if
!-----------------------------------------------------------------------
!         ... factor the "system" matrix
!-----------------------------------------------------------------------
                     call imp_lu_fac( sys_jac )
                  end if
!-----------------------------------------------------------------------
!           ... form f(y)
!-----------------------------------------------------------------------
                  call imp_prod_loss( prod, loss, lsol, lrxt, lhet )
                  do m = 1,clscnt4
                     forcing(m) = solution(m)*dti - (iter_invariant(m) + prod(m) - loss(m))
                  end do
!-----------------------------------------------------------------------
!         ... solve for the mixing ratio at t(n+1)
!-----------------------------------------------------------------------
                  call imp_lu_slv( sys_jac, forcing )
                  do m = 1,clscnt4
                     solution(m) = solution(m) + forcing(m)
                  end do
!-----------------------------------------------------------------------
!            ... convergence measures
!-----------------------------------------------------------------------
                  if( nr_iter > 1 ) then
                     do k = 1,clscnt4
                        m = implicit%permute(k)
                        if( abs(solution(m)) > 1.e-40 ) then
                           max_delta(k) = abs( forcing(m)/solution(m) )
                        else
                           max_delta(k) = 0.
                        end if
                     end do
                  end if
!-----------------------------------------------------------------------
!           ... limit iterate
!-----------------------------------------------------------------------
                  where( solution(:) < 0. )
                     solution(:) = 0.
                     endwhere
!-----------------------------------------------------------------------
!           ... transfer latest solution back to work array
!-----------------------------------------------------------------------
                  do k = 1,clscnt4
                     j = implicit%clsmap(k)
                     m = implicit%permute(k)
                     lsol(j) = solution(m)
                  end do
!-----------------------------------------------------------------------
!            ... check for convergence
!-----------------------------------------------------------------------
                  if( nr_iter > 1 ) then
                     do k = 1,clscnt4
                        m = implicit%permute(k)
                        frc_mask = abs( forcing(m) ) > small
                        if( frc_mask ) then
                           converged(k) =  abs(forcing(m)) <= epsilon(k)*abs(solution(m))
                        else
                           converged(k) =  .true.
                        end if
                     end do
                     convergence = all( converged(:) )
                     if( convergence ) then
                        exit
                     end if
                  end if
               end do iter_loop

!-----------------------------------------------------------------------
!            ... check for newton-raphson convergence
!-----------------------------------------------------------------------
               if( .not. convergence ) then
!-----------------------------------------------------------------------
!           ... non-convergence
!-----------------------------------------------------------------------
!                  if( pdiags%imp_slv ) then
!                     write(*,'('' imp_sol: Time step '',1p,e21.13,'' Failed to converge'')') dt
!                  end if
                  stp_con_cnt = 0
                  if( cut_cnt < cut_limit ) then
                     cut_cnt = cut_cnt + 1
                     dt = .5 * dt
                     cycle
                  else
!                    write(*,'('' imp_sol: failed to converge @ (lon,lat,lev,dt) = '',3i5,1p,e21.13)') indx,lat,lev,dt
                     non_convergence(indx) = non_convergence(indx) + dt/delt
                     if (indx_old /= indx) then
                        if (verbose >= 3) then
                        write(*,105) lon(i)*r2d,lat(i)*r2d,lev,dt
 105                    format('imp_sol: failed to converge @ (lon,lat,lev,dt) = ', 2f8.2,i5,1p,f12.4)
                        end if
                        if (verbose >= 4) then
                           do m = 1,clscnt4
                              if( .not. converged(m)) then
                                 write(*,'(1x,a8,1x,1pe10.3)') &
                                    tracnam(implicit%clsmap(m)), max_delta(m)
                              end if
                           end do
                        end if
                     else
                        if (verbose >= 4) then
                        write(*,105) lon(i)*r2d,lat(i)*r2d,lev,dt
                        end if
                     end if
                     indx_old = indx
                  end if
               end if
!-----------------------------------------------------------------------
!           ... check for interval done
!-----------------------------------------------------------------------
               interval_done = interval_done + dt
               if( abs( delt - interval_done ) <= .0001 ) then
                  exit
               else
!-----------------------------------------------------------------------
!           ... transfer latest solution back to base array
!-----------------------------------------------------------------------
                  if( convergence ) then
                     stp_con_cnt = stp_con_cnt + 1
                  end if
                  do m = 1,pcnstm1
                     base_sol(indx,m) = lsol(m)
                  end do
!++lwh
!-----------------------------------------------------------------------
!        ... Production/loss diagnostics
!-----------------------------------------------------------------------
                  do k = 1,clscnt4
                     j = implicit%clsmap(k)
                     m = implicit%permute(k)
                     prod_out(indx,j) = prod_out(indx,j) + prod(m) * dt/delt
                     loss_out(indx,j) = loss_out(indx,j) + loss(m) * dt/delt
                  end do
!--lwh
                  if( stp_con_cnt >= 2 ) then
                     dt = 2.*dt
                     stp_con_cnt = 0
                     cut_cnt = max( 0,cut_cnt-1 )
                  end if
                  dt = min( dt,delt-interval_done )
!                  if( pdiags%imp_slv ) then
!                     write(*,'('' imp_sol: new time step '',1p,e21.13)') dt
!                  end if
               end if
            end do time_step_loop
!-----------------------------------------------------------------------
!           ... transfer latest solution back to base array
!-----------------------------------------------------------------------
            do k = 1,clscnt4
               j = implicit%clsmap(k)
               m = implicit%permute(k)
               base_sol(indx,j) = solution(m)
!++lwh
!-----------------------------------------------------------------------
!        ... Production/loss diagnostics
!-----------------------------------------------------------------------
               prod_out(indx,j) = prod_out(indx,j) + prod(m) * dt/delt &
                                                   + ind_prd(indx,m)
               loss_out(indx,j) = loss_out(indx,j) + loss(m) * dt/delt
!--lwh
            end do
!-----------------------------------------------------------------------
!           ... check for history prod, loss
!-----------------------------------------------------------------------
! hist_buff_loop : &
!            do file = 1,moz_file_cnt
!               do timetype = inst,avrg
!                  fill_buff = imp_hst_prod(file)%do_hst(timetype)
!                  if( timetype == inst ) then
!                     fill_buff = fill_buff .and. hfile(file)%wrhstts
!                  end if
!                 if( fill_buff ) then
!                     hndx = 0
!                     do n = 1,hfile(file)%histout_cnt(14,timetype)
!                        if( timetype == inst ) then
!                           class = hfile(file)%inst_map(hfile(file)%histout_ind(14,inst)+n-1)/1000
!                        else
!                           class = hfile(file)%timav_map(hfile(file)%histout_ind(14,avrg)+n-1)/1000
!                       end if
!                        if( class == 4 ) then
!                           if( timetype == inst ) then
!                              cls_ndx = mod( hfile(file)%inst_map(hfile(file)%histout_ind(14,inst)+n-1),1000 )
!                           else
!                              cls_ndx = mod( hfile(file)%timav_map(hfile(file)%histout_ind(14,avrg)+n-1),1000 )
!                          end if
!                           hndx = hndx + 1
!                           l = implicit%clsmap(cls_ndx)
!                           if( l == ox_ndx ) then
!-----------------------------------------------------------------------
!         ... ozone production (only valid for the troposphere!)
!-----------------------------------------------------------------------
!                             if( do_ox_pl ) then
!                                k = indx
!                                   prod_buff(file)%buff(k,hndx) = &
!                                    (reaction_rates(k,ox_p1_ndx)*base_sol(k,ho2_ndx) &
!                                    + reaction_rates(k,ox_p2_ndx) *base_sol(k,ch3o2_ndx) &
!                                    + reaction_rates(k,ox_p3_ndx) *base_sol(k,po2_ndx) &
!                                    + reaction_rates(k,ox_p4_ndx) *base_sol(k,ch3co3_ndx) &
!                                    + reaction_rates(k,ox_p5_ndx) *base_sol(k,c2h5o2_ndx) &
!                                    + .88*reaction_rates(k,ox_p6_ndx)*base_sol(k,isopo2_ndx) &
!                                    + .985*reaction_rates(k,ox_p7_ndx)*base_sol(k,macro2_ndx) &
!                                    + reaction_rates(k,ox_p8_ndx)*base_sol(k,mco3_ndx) &
!                                    + reaction_rates(k,ox_p9_ndx)*base_sol(k,c3h7o2_ndx) &
!                                    + reaction_rates(k,ox_p10_ndx)*base_sol(k,ro2_ndx) &
!                                    + reaction_rates(k,ox_p11_ndx)*base_sol(k,xo2_ndx)) * base_sol(k,no_ndx)
!                              end if
!                          else
!                              j = implicit%permute(cls_ndx)
!                             prod_buff(file)%buff(indx,hndx) = prod(j) + ind_prd(indx,j)
!                           end if
!                        end if
!                    end do
!                 end if
!                  fill_buff = imp_hst_loss(file)%do_hst(timetype)
!                  if( timetype == inst ) then
!                     fill_buff = fill_buff .and. hfile(file)%wrhstts
!                  end if
!                 if( fill_buff ) then
!                     hndx = 0
!                     do n = 1,hfile(file)%histout_cnt(15,timetype)
!                        if( timetype == inst ) then
!                           class = hfile(file)%inst_map(hfile(file)%histout_ind(15,inst)+n-1)/1000
!                        else
!                           class = hfile(file)%timav_map(hfile(file)%histout_ind(15,avrg)+n-1)/1000
!                        end if
!                        if( class == 4 ) then
!                           if( timetype == inst ) then
!                              cls_ndx = mod( hfile(file)%inst_map(hfile(file)%histout_ind(15,inst)+n-1),1000 )
!                           else
!                              cls_ndx = mod( hfile(file)%timav_map(hfile(file)%histout_ind(15,avrg)+n-1),1000 )
!                           end if
!                           hndx = hndx + 1
!                           l = implicit%clsmap(cls_ndx)
!                           if( l == ox_ndx ) then
!                             if( do_ox_pl ) then
!-----------------------------------------------------------------------
!         ... ozone destruction (only valid for the troposphere!)
!             also include ox loss from no2+oh, n2o5+aerosol, no3+aerosol
!-----------------------------------------------------------------------
!                                k = indx
!                                   loss_buff(file)%buff(k,hndx) =  reaction_rates(k,ox_l1_ndx) &
!                                   + reaction_rates(k,ox_l2_ndx) *base_sol(k,oh_ndx) &
!                                   + reaction_rates(k,ox_l3_ndx) *base_sol(k,ho2_ndx) &
!                                   + reaction_rates(k,ox_l6_ndx) *base_sol(k,c2h4_ndx) &
!                                   + reaction_rates(k,ox_l4_ndx) *base_sol(k,c3h6_ndx) &
!                                   + .9*reaction_rates(k,ox_l5_ndx) *base_sol(k,isop_ndx) &
!                                   + .8*(reaction_rates(k,ox_l7_ndx)*base_sol(k,mvk_ndx) &
!                                         + reaction_rates(k,ox_l8_ndx)*base_sol(k,macro2_ndx)) &
!                                   + .235*reaction_rates(k,ox_l9_ndx)*base_sol(k,c10h16_ndx) &
!                                   + (reaction_rates(k,usr4_ndx) * base_sol(k,no2_ndx) * base_sol(k,oh_ndx) &
!                                      + 3. * reaction_rates(k,usr16_ndx) * base_sol(k,n2o5_ndx) &
!                                      + 2. * reaction_rates(k,usr17_ndx) * base_sol(k,no3_ndx)) &
!                                     /max( base_sol(k,ox_ndx),1.e-20 )
!                             end if
!                           else
!                              j = implicit%permute(cls_ndx)
!                             loss_buff(file)%buff(indx,hndx) = loss(j)
!                           end if
!                       end if
!                    end do
!                 end if
!              end do
!           end do hist_buff_loop
         end do lon_tile_loop
      end do level_loop

!-----------------------------------------------------------------------
!       ... check for implicit species production and loss output
!           first check production; instantaneous then time averaged
!           then  check loss; instantaneous then time averaged
!-----------------------------------------------------------------------
!     do file = 1,moz_file_cnt
!         do timetype = inst,avrg
!           dump_buff = imp_hst_prod(file)%do_hst(timetype)
!            if( timetype == inst ) then
!               dump_buff = dump_buff .and. hfile(file)%wrhstts
!            end if
!           if( dump_buff ) then
!               hndx = 0
!               do n = 1,hfile(file)%histout_cnt(14,timetype)
!                  if( timetype == inst ) then
!                     class = hfile(file)%inst_map(hfile(file)%histout_ind(14,timetype)+n-1)/1000
!                  else
!                     class = hfile(file)%timav_map(hfile(file)%histout_ind(14,timetype)+n-1)/1000
!                  end if
!                  if( class == 4 ) then
!                     if( timetype == inst ) then
!                        cls_ndx = mod( hfile(file)%inst_map(hfile(file)%histout_ind(14,inst)+n-1),1000 )
!                        fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(14,timetype)+n-1)
!                     else
!                        cls_ndx = mod( hfile(file)%timav_map(hfile(file)%histout_ind(14,avrg)+n-1),1000 )
!                        fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(14,timetype)+n-1)
!                     end if
!                     hndx        = hndx + 1
!                     wrk_buff(:) = prod_buff(file)%buff(:,hndx) * hnm(:)
!                     call outfld( fldname, wrk_buff, plonl, ip, lat, file )
!                 end if
!              end do
!           end if
!           dump_buff = imp_hst_loss(file)%do_hst(timetype)
!            if( timetype == inst ) then
!               dump_buff = dump_buff .and. hfile(file)%wrhstts
!            end if
!           if( dump_buff ) then
!               hndx = 0
!               do n = 1,hfile(file)%histout_cnt(15,timetype)
!                  if( timetype == inst ) then
!                     class = hfile(file)%inst_map(hfile(file)%histout_ind(15,timetype)+n-1)/1000
!                  else
!                     class = hfile(file)%timav_map(hfile(file)%histout_ind(15,timetype)+n-1)/1000
!                  end if
!                  if( class == 4 ) then
!                     if( timetype == inst ) then
!                        cls_ndx = mod( hfile(file)%inst_map(hfile(file)%histout_ind(15,inst)+n-1),1000 )
!                        fldname = hfile(file)%hist_inst(hfile(file)%histout_ind(15,timetype)+n-1)
!                     else
!                        cls_ndx = mod( hfile(file)%timav_map(hfile(file)%histout_ind(15,avrg)+n-1),1000 )
!                        fldname = hfile(file)%hist_timav(hfile(file)%histout_ind(15,timetype)+n-1)
!                     end if
!                     hndx        = hndx + 1
!                     l           = implicit%clsmap(cls_ndx)
!                    wrk_buff(:) = loss_buff(file)%buff(:,hndx) * hnm(:) * base_sol(:,l)
!                     call outfld( fldname, wrk_buff, plonl, ip, lat, file )
!                 end if
!              end do
!           end if
!        end do
!     end do

!     if( allocated( prod_buff ) ) then
!         do file = 1,moz_file_cnt
!            if( associated( prod_buff(file)%buff ) ) then
!               deallocate( prod_buff(file)%buff )
!            end if
!         end do
!         deallocate( prod_buff )
!     end if
!     if( allocated( loss_buff ) ) then
!         do file = 1,moz_file_cnt
!            if( associated( loss_buff(file)%buff ) ) then
!               deallocate( loss_buff(file)%buff )
!            end if
!         end do
!         deallocate( loss_buff )
!     end if

      end subroutine imp_sol

      end module mo_imp_sol_mod


      module MO_JPL_MOD

implicit none
character(len=128), parameter :: version     = '$Id: mo_jpl.F90,v 13.0 2006/03/28 21:16:17 fms Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS

      subroutine JPL( rate, m, factor, ko, kinf,plnplv )
!-----------------------------------------------------------------
!        ... Calculate JPL troe rate
!-----------------------------------------------------------------
      
      implicit none

!-----------------------------------------------------------------
!        ... Dummy args
!-----------------------------------------------------------------
      integer,intent(in)::    plnplv
      real, intent(in)  ::   factor
      real, intent(in)  ::   ko(plnplv)
      real, intent(in)  ::   kinf(plnplv)
      real, intent(in)  ::   m(plnplv)
      real, intent(out) ::   rate(plnplv)

!-----------------------------------------------------------------
!        ... Local variables
!-----------------------------------------------------------------
      real  ::     xpo( SIZE(rate) )
      

      xpo(:)  = ko(:) * m(:) / kinf(:)
      rate(:) = ko(:) / (1. + xpo(:))
      xpo(:)  = LOG10( xpo(:) )
      xpo(:)  = 1. / (1. + xpo(:)*xpo(:))
      rate(:) = rate(:) * factor**xpo(:)

      end subroutine JPL

      end module MO_JPL_MOD


      module MO_PHOTO_MOD
!----------------------------------------------------------------------
!        ... Photolysis interp table and related arrays
!----------------------------------------------------------------------
      use mpp_mod,          only : mpp_error, FATAL
      use mpp_io_mod,       only : mpp_open, MPP_RDONLY, MPP_ASCII,MPP_MULTI, &
                                   MPP_SINGLE, mpp_close
      use time_manager_mod, only : time_type, get_date
      use constants_mod,    only : PI

      implicit none

      private
      public :: prate_init, photo, set_ub_col, setcol, sundis

      save

      integer, parameter :: jdim     = 40
      integer, parameter :: altdim   = 46
      integer, parameter :: zangdim  = 11
      integer, parameter :: o3ratdim = 7
      integer, parameter :: albdim   = 4
      integer, parameter :: t500dim  = 3
      integer, parameter :: t200dim  = 2
      integer, parameter :: tabdim   = jdim*altdim*zangdim*o3ratdim*albdim*t500dim*t200dim

      integer ::  offset(7)
      integer ::  indexer(jdim)
      integer ::  jno_ndx, jpooh_ndx, jc2h5ooh_ndx, jc3h7ooh_ndx, jrooh_ndx, &
                  jch3co3h_ndx, jmpan_ndx, jmacr_a_ndx, jmacr_b_ndx, jonitr_ndx, &
                  jxooh_ndx, jisopooh_ndx, jglyald_ndx, jhyac_ndx, jch3ooh_ndx, &
                  jh2o2_ndx, jpan_ndx, jch3cho_ndx, jho2no2_ndx, &
                  jn2o5_ndx, jo3p_ndx, jno2_ndx, jno3_ndx, &
                  jclono2_ndx, jhocl_ndx, jcl2o2_ndx, jbrono2_ndx, jhobr_ndx, &
                  jbrcl_ndx, jbro_ndx, jcl2_ndx, jh2o_ndx, jn2o_ndx, jhno3_ndx
      integer ::  ox_ndx, o3_ndx
      real    ::  ajl(jdim,altdim,zangdim,o3ratdim,albdim,t500dim,t200dim) = 0., &
                  ajl_solarmin(jdim,altdim,zangdim,o3ratdim,albdim,t500dim,t200dim) = 0.
!RSH  real    ::  ajl2(2,2,2,2,2,2)
      real    ::  vo3(0:80), vo3_solarmin(0:80)
      real    ::  delvo3(0:79)
      real    ::  delz(altdim-1)
      real    ::  delang(zangdim-1)
      real    ::  delv(o3ratdim-1)
      real    ::  delalb(albdim-1)
      real    ::  delt500(t500dim-1)
      real    ::  delt200(t200dim-1)

      real, parameter :: zz(altdim) = &
        (/  0.,  1.,  2.,  3.,  4.,  5.,  6.,  8., 10., 12., 14., 16., 18., 20., 22., &
           24., 26., 28., 30., 32., 34., 36., 38., 40., 42., 44., 46., 48., 50., 52., &
           54., 56., 58., 60., 62., 64., 66., 68., 70., 72., 74., 76., 78., 80., 82., &
           85. /)
      real, parameter :: vcos(zangdim) = &
        (/ -0.07, -0.05, -0.01, 0.01, 0.05, 0.1, 0.2,   0.4,   0.6,  0.8,  1.0 /)
      real, parameter :: xv3(o3ratdim) = (/ .5, .75, 1., 1.25, 1.5, 2., 5. /)
      real, parameter :: albev(albdim) = (/ .05, .2, .5, 1. /)
      real, parameter :: t500(t500dim) = (/ 228., 248., 268. /)
      real, parameter :: t200(t200dim) = (/ 205., 225. /)
      real, parameter :: coszen_min = vcos(1)


      integer, parameter :: &
         TAB_NDX_JO2        = 1,  TAB_NDX_JO1D       = 2, &
         TAB_NDX_JO3P       = 3,  TAB_NDX_JNO2       = 4, &
         TAB_NDX_JNO3       = 5,  TAB_NDX_JN2O5      = 6, &
         TAB_NDX_JN2O5_225  = 7,  TAB_NDX_JN2O5_250  = 8, &
         TAB_NDX_JN2O5_300  = 9,  TAB_NDX_JN2O       = 10, &
         TAB_NDX_JN2O_200   = 11, TAB_NDX_JN2O_250   = 12, &
         TAB_NDX_JN2O_300   = 13, TAB_NDX_JH2O2      = 14, &
         TAB_NDX_JHNO3      = 15, TAB_NDX_JHNO3_200  = 16, &
         TAB_NDX_JHNO3_250  = 17, TAB_NDX_JHNO3_300  = 18, &
         TAB_NDX_JHO2NO2    = 19, TAB_NDX_JCH2Oa     = 20, &
         TAB_NDX_JCH2Ob     = 21, TAB_NDX_JCH3CHO    = 22, &
         TAB_NDX_JMGLY      = 23, TAB_NDX_JACET      = 24, &
         TAB_NDX_JCH3OOH    = 25, TAB_NDX_JPAN       = 26, &
         TAB_NDX_JCLONO2    = 27, TAB_NDX_JCLONO2_200= 28, &
         TAB_NDX_JCLONO2_250= 29, TAB_NDX_JCLONO2_300= 30, &
         TAB_NDX_JBRONO2    = 31, TAB_NDX_JCL2       = 32, &
         TAB_NDX_JMVK       = 33, TAB_NDX_JMACRa     = 34, &
         TAB_NDX_JCL2O2     = 35, TAB_NDX_JHYAC      = 36, &
         TAB_NDX_JHOBR      = 37, TAB_NDX_JBR2       = 38, &
         TAB_NDX_JHOCL      = 39, TAB_NDX_JBRCL      = 40

      logical :: use_tdep_jvals, use_solar_cycle
      real    :: o3_column_top, jno_scale_factor

character(len=128), parameter :: version     = '$Id: mo_photo.F90,v 17.0.2.1.4.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS
      
! <SUBROUTINE NAME="prate_init">
!   <OVERVIEW>
!     Initialize photolysis rate lookup table calculation
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine initializes the calculation of photolysis rates
!     from the TUV lookup table
!   </DESCRIPTION>
!   <TEMPLATE>
!     call prate_init( filename, filename_solarmin, lpath, mspath, use_tdep_jvals_in )
!   </TEMPLATE>
!   <IN NAME="filename" TYPE="character(len=*)">
!     Filename for ASCII lookup table file (if solar cycle used, this is the filename
!     for solar maximum conditions).
!   </IN>
!   <IN NAME="filename_solarmin" TYPE="character(len=*)">
!     Filename for ASCII lookup table file for solar minimum conditions
!     (if solar cycle used)
!   </IN>
!   <IN NAME="lpath" TYPE="character(len=*)">
!     Local directory path for input files
!   </IN>
!   <IN NAME="mspath" TYPE="character(len=*)">
!     Remote directory path for input files (not used)
!   </IN>
!   <IN NAME="use_tdep_jvals_in" TYPE="logical">
!     Does the j-value lookup table contain temperature-dependent photolysis rates?
!   </IN>
!   <IN NAME="o3_column_top_in" TYPE="real">
!     Ozone column above model top (DU)
!   </IN>
!   <IN NAME="jno_scale_factor_in" TYPE="real">
!     Scale factor for NO photolysis rate (jNO)
!   </IN>
      subroutine prate_init( filename, filename_solarmin, lpath, mspath, &
                             use_tdep_jvals_in, o3_column_top_in, jno_scale_factor_in )
!----------------------------------------------------------------------
!     ... Read in the photorate tables and arrays
!         Results are "returned" via the common block photo_tables
!          This is for the new, expanded chemistry (11/21/94)
!----------------------------------------------------------------------
        
      use mo_chem_utls_mod,  only : get_spc_ndx, get_rxt_ndx
      implicit none

!----------------------------------------------------------------------
!        ... Dummy args
!----------------------------------------------------------------------
      character(len=*), intent(in) :: filename, filename_solarmin, lpath, mspath
      logical,          intent(in) :: use_tdep_jvals_in
      real,             intent(in) :: o3_column_top_in, &
                                      jno_scale_factor_in

!----------------------------------------------------------------------
!        ... Local variables
!----------------------------------------------------------------------
      integer    :: it500, it200, izen, ialb, idob
      integer    :: ios
      integer    :: unit
!     integer    :: retval
!     logical    :: cosb
!     real       :: temp(tabdim)
      character(len=128) :: msg

!     unit = navu()
!----------------------------------------------------------------------
!        ... Only masternode gets photorate table
!----------------------------------------------------------------------
!     if( masternode ) then
!        retval = ATTACH( TRIM(lpath) // TRIM( filename ), &
!                         TRIM( mspath ) // TRIM( filename ), &
!                         unit, &
!                         .false., &                 ! non binary dataset
!                         cosb )
!        if( retval /= 0 ) then
!           write(*,*) 'PRATE_INIT: Failure opening file ',TRIM(lpath) // TRIM( filename )
!           write(*,*) 'Error code = ',retval
!           call ENDRUN
!        end if
!        CLOSE( unit )
!     end if
#ifdef USE_MPI
!----------------------------------------------------------------------
!        ... All compute nodes wait for masternode to acquire file
!----------------------------------------------------------------------
!     call MPI_BARRIER( mpi_comm_comp, ios )
!     if( ios /= MPI_SUCCESS ) then
!        write(*,*) 'PRATE_INIT: Mpi barrier failed; error = ',ios
!        call ENDRUN
!     end if
#endif
!----------------------------------------------------------------------
!        ... all compute nodes open file
!----------------------------------------------------------------------
!     OPEN( unit   = unit, &
!           file   = TRIM(lpath) // TRIM(filename), &
!           status = 'old', &
!           form   = 'formatted', &
!           recl   = 4500, &
!          iostat = ios )
!     if( ios /= 0 ) then
!----------------------------------------------------------------------
!        ... Open error exit
!----------------------------------------------------------------------
!        write(6,'('' PRATE_INIT : Error ('',i5,'') opening file '',a)') &
!           ios, TRIM(lpath) // TRIM(filename)
!        call ENDRUN
!     end if

!----------------------------------------------------------------------
!            ... open file using mpp_open
!----------------------------------------------------------------------

      call mpp_open( unit, trim(lpath)//trim(filename), MPP_RDONLY, MPP_ASCII, &
                     threading = MPP_MULTI, fileset = MPP_SINGLE, &
                     recl = 4500)

!----------------------------------------------------------------------
!        ... Readin the reference o3 column and photorate table
!----------------------------------------------------------------------
      read(unit,*,iostat=ios) vo3
      if( ios /= 0 ) then
         msg = ' PRATE_INIT: Failed to read o3 column'
         call ENDRUN(msg)
      end if

      do it500 = 1,t500dim
         do it200 = 1,t200dim
            do izen = 1,zangdim
               do ialb = 1,albdim
                  do idob = 1,o3ratdim
                     read(unit,*,iostat=ios) ajl(:,:,izen,idob,ialb,it500,it200)
                     if( ios /= 0 ) then
                        msg = ' PRATE_INIT: Failed to read photo table; error = '//char(ios)
                        call ENDRUN(msg)
                     end if
                  end do
               end do
            end do
         end do
      end do

!----------------------------------------------------------------------
!        ... Set module variables
!----------------------------------------------------------------------
      delz(:altdim-1) = 1. / (zz(2:altdim) - zz(:altdim-1))
      delvo3(0:79) = vo3(1:80) - vo3(0:79)
      delang(:zangdim-1)  = 1. / (vcos(2:zangdim) - vcos(:zangdim-1))
      delv(:o3ratdim-1)   = 1. / (xv3(2:o3ratdim) - xv3(:o3ratdim-1))
      delalb(:albdim-1)   = 1. / (albev(2:albdim) - albev(:albdim-1))
      delt500(:t500dim-1) = 1. / (t500(2:t500dim) - t500(:t500dim-1))
      delt200(:t200dim-1) = 1. / (t200(2:t200dim) - t200(:t200dim-1))

      offset(1) = jdim
      offset(2) = offset(1)*altdim
      offset(3) = offset(2)*zangdim
      offset(4) = offset(3)*o3ratdim
      offset(5) = offset(4)*albdim
      offset(6) = offset(5)*t500dim
      offset(7) = SUM( offset(1:6) )

!     close( unit )
      call mpp_close( unit )

!-----------------------------------------------------------------
!           ... check whether using solar cycle
!-----------------------------------------------------------------
      if (filename_solarmin == '' .or. filename_solarmin == filename) then
         use_solar_cycle = .false.
      else
         use_solar_cycle = .true.

!----------------------------------------------------------------------
!            ... open file using mpp_open
!----------------------------------------------------------------------
         call mpp_open( unit, trim(lpath)//trim(filename_solarmin), MPP_RDONLY, MPP_ASCII, &
                        threading = MPP_MULTI, fileset = MPP_SINGLE, &
                        recl = 4500)

!----------------------------------------------------------------------
!        ... Readin the reference o3 column and photorate table 
!            for solar minimum
!----------------------------------------------------------------------
         read(unit,*,iostat=ios) vo3_solarmin
         if( ios /= 0 ) then
            msg = ' PRATE_INIT: Failed to read solarmin o3 column'
            call ENDRUN(msg)
         end if

         do it500 = 1,t500dim
         do it200 = 1,t200dim
         do izen = 1,zangdim
         do ialb = 1,albdim
         do idob = 1,o3ratdim
            read(unit,*,iostat=ios) ajl_solarmin(:,:,izen,idob,ialb,it500,it200)
            if( ios /= 0 ) then
               msg = ' PRATE_INIT: Failed to read solarmin photo table; error = '//char(ios)
               call ENDRUN(msg)
            end if
         end do
         end do
         end do
         end do
         end do
         call mpp_close( unit )
      end if

!-----------------------------------------------------------------
!           ... setup mapping array, indexer, from table to model
!-----------------------------------------------------------------
      indexer(TAB_NDX_JO2)      = get_rxt_ndx( 'jo2' )
      indexer(TAB_NDX_JO1D)     = get_rxt_ndx( 'jo1d' )
      indexer(TAB_NDX_JO3P)     = get_rxt_ndx( 'jo3p' )
      indexer(TAB_NDX_JNO2)     = get_rxt_ndx( 'jno2' )
      indexer(TAB_NDX_JNO3)     = get_rxt_ndx( 'jno3' )
      indexer(TAB_NDX_JN2O5)    = get_rxt_ndx( 'jn2o5' )
      indexer(TAB_NDX_JN2O5_225)= 0
      indexer(TAB_NDX_JN2O5_250)= 0
      indexer(TAB_NDX_JN2O5_300)= 0
      indexer(TAB_NDX_JN2O)     = get_rxt_ndx( 'jn2o' )
      indexer(TAB_NDX_JN2O_200) = 0
      indexer(TAB_NDX_JN2O_250) = 0
      indexer(TAB_NDX_JN2O_300) = 0
      indexer(TAB_NDX_JH2O2)    = get_rxt_ndx( 'jh2o2' )
      indexer(TAB_NDX_JHNO3)    = get_rxt_ndx( 'jhno3' )
      indexer(TAB_NDX_JHNO3_200)= 0
      indexer(TAB_NDX_JHNO3_250)= 0
      indexer(TAB_NDX_JHNO3_300)= 0
      indexer(TAB_NDX_JHO2NO2)  = get_rxt_ndx( 'jho2no2' )
      indexer(TAB_NDX_JCH2Oa)   = get_rxt_ndx( 'jch2o_a' )
      indexer(TAB_NDX_JCH2Ob)   = get_rxt_ndx( 'jch2o_b' )
      indexer(TAB_NDX_JCH3CHO)  = get_rxt_ndx( 'jch3cho' )
      indexer(TAB_NDX_JMGLY)    = get_rxt_ndx( 'jmgly' )
      indexer(TAB_NDX_JACET)    = get_rxt_ndx( 'jacet' )
      indexer(TAB_NDX_JCH3OOH)  = get_rxt_ndx( 'jch3ooh' )
      indexer(TAB_NDX_JPAN)     = get_rxt_ndx( 'jpan' )
      indexer(TAB_NDX_JCLONO2)  = get_rxt_ndx( 'jclono2' )
      indexer(TAB_NDX_JCLONO2_200)=0
      indexer(TAB_NDX_JCLONO2_250)=0
      indexer(TAB_NDX_JCLONO2_300)=0
      indexer(TAB_NDX_JBRONO2)  = get_rxt_ndx( 'jbrono2' )
      indexer(TAB_NDX_JCL2)     = get_rxt_ndx( 'jcl2' )
      indexer(TAB_NDX_JMVK)     = get_rxt_ndx( 'jmvk' )
      indexer(TAB_NDX_JMACRa)   = get_rxt_ndx( 'jmacr_a' )
      indexer(TAB_NDX_JCL2O2)   = get_rxt_ndx( 'jcl2o2' )
      indexer(TAB_NDX_JHYAC)    = get_rxt_ndx( 'jhyac' )
      indexer(TAB_NDX_JHOBR)    = get_rxt_ndx( 'jhobr' )
      indexer(TAB_NDX_JBR2)     = get_rxt_ndx( 'jbr2' )
      indexer(TAB_NDX_JHOCL)    = get_rxt_ndx( 'jhocl' )
      indexer(TAB_NDX_JBRCL)    = get_rxt_ndx( 'jbrcl' )

      jno_ndx      = get_rxt_ndx( 'jno' )
      jpooh_ndx    = get_rxt_ndx( 'jpooh' )
      jc2h5ooh_ndx = get_rxt_ndx( 'jc2h5ooh' )
      jc3h7ooh_ndx = get_rxt_ndx( 'jc3h7ooh' )
      jrooh_ndx    = get_rxt_ndx( 'jrooh' )
      jch3co3h_ndx = get_rxt_ndx( 'jch3co3h' )
      jmpan_ndx    = get_rxt_ndx( 'jmpan' )
      jmacr_a_ndx  = get_rxt_ndx( 'jmacr_a' )
      jmacr_b_ndx  = get_rxt_ndx( 'jmacr_b' )
      jonitr_ndx   = get_rxt_ndx( 'jonitr' )
      jxooh_ndx    = get_rxt_ndx( 'jxooh' )
      jisopooh_ndx = get_rxt_ndx( 'jisopooh' )
      jglyald_ndx  = get_rxt_ndx( 'jglyald' )
      jhyac_ndx    = get_rxt_ndx( 'jhyac' )
      jch3ooh_ndx  = get_rxt_ndx( 'jch3ooh' )
      jh2o2_ndx    = get_rxt_ndx( 'jh2o2' )
      jpan_ndx     = get_rxt_ndx( 'jpan' )
      jch3cho_ndx  = get_rxt_ndx( 'jch3cho' )
      jho2no2_ndx  = get_rxt_ndx( 'jho2no2' )
      jn2o5_ndx    = get_rxt_ndx( 'jn2o5' )
      jo3p_ndx     = get_rxt_ndx( 'jo3p' )
      jno2_ndx     = get_rxt_ndx( 'jno2' )
      jno3_ndx     = get_rxt_ndx( 'jno3' )
      jclono2_ndx  = get_rxt_ndx( 'jclono2' )
      jhocl_ndx    = get_rxt_ndx( 'jhocl' )
      jcl2o2_ndx   = get_rxt_ndx( 'jcl2o2' )
      jbrono2_ndx  = get_rxt_ndx( 'jbrono2' )
      jhobr_ndx    = get_rxt_ndx( 'jhobr' )
      jbrcl_ndx    = get_rxt_ndx( 'jbrcl' )
      jbro_ndx     = get_rxt_ndx( 'jbro' )
      jcl2_ndx     = get_rxt_ndx( 'jcl2' )
      jh2o_ndx     = get_rxt_ndx( 'jh2o' )
      jn2o_ndx     = get_rxt_ndx( 'jn2o' )
      jhno3_ndx    = get_rxt_ndx( 'jhno3' )

      ox_ndx = get_spc_ndx( 'OX' )
      o3_ndx = get_spc_ndx( 'O3' )

      use_tdep_jvals   = use_tdep_jvals_in
      o3_column_top    = o3_column_top_in
      jno_scale_factor = jno_scale_factor_in

      end subroutine prate_init
! </SUBROUTINE>


! <SUBROUTINE NAME="PHOTO">
!   <OVERVIEW>
!     Calculate photolysis rates
!   </OVERVIEW>
!   <DESCRIPTION>
!     Calculate photolysis rates from the TUV lookup table
!   </DESCRIPTION>
!   <TEMPLATE>
!     call PHOTO( photos, pmid, pdel, temper, zmid, col_dens, coszen,  & 
!                 srf_alb, lwc, clouds, esfact, solar_phase, plonl )
!   </TEMPLATE>
!   <IN NAME="photos" TYPE="real" DIM="(:,:,:)">
!     Photodissociation rates (s^-1)
!   </IN>
!   <IN NAME="pmid" TYPE="real" DIM="(:,:)">
!     Full level pressures (Pa)
!   </IN>
!   <IN NAME="pdel" TYPE="real" DIM="(:,:)">
!     Half level (interface) pressures (Pa)
!   </IN>
!   <IN NAME="temper" TYPE="real" DIM="(:,:)">
!     Full level temperatures (K)
!   </IN>
!   <IN NAME="zmid" TYPE="real" DIM="(:,:)">
!     Full level absolute geopotential altitudes (km)
!   </IN>
!   <IN NAME="col_dens" TYPE="real" DIM="(:,:,:)">
!     Column densities
!   </IN>
!   <IN NAME="coszen" TYPE="real" DIM="(:)">
!     Cosine of solar zenith angle
!   </IN>
!   <IN NAME="srf_alb" TYPE="real" DIM="(:)">
!     Surface albedo
!   </IN>
!   <IN NAME="lwc" TYPE="real" DIM="(:,:)">
!     Cloud liquid water content (kg/kg)
!   </IN>
!   <IN NAME="clouds" TYPE="real" DIM="(:,:)">
!     Cloud fraction
!   </IN>
!   <IN NAME="esfact" TYPE="real">
!     Earth-sun distance factor
!   </IN>
!   <IN NAME="solar_phase" TYPE="real">
!     Solar cycle phase (1=max, 0=min)
!   </IN>
!   <IN NAME="plonl" TYPE="integer">
!     Size of longitude dimension
!   </IN>
      subroutine PHOTO( photos, pmid, pdel, temper, zmid, &
                        col_dens, &
                        coszen,  & 
                        srf_alb, lwc, clouds, &
                        esfact, solar_phase, &
                        plonl )

      use CHEM_MODS_MOD, only : ncol_abs, phtcnt
!     use M_RXT_ID_MOD

      implicit none

!-----------------------------------------------------------------
!           ... Dummy arguments
!-----------------------------------------------------------------
      integer, intent(in) :: plonl
      real, intent(in) ::   esfact, &                 ! earth sun distance factor
                            solar_phase               ! solar cycle phase (1=max, 0=min)
      real, intent(in) ::   col_dens(:,:,:), &        ! column densities
                            coszen(:), &              ! solar zenith angle
                            srf_alb(:), &             ! surface albedo
                            lwc(:,:), &               ! liquid water content (mass mr)
                            clouds(:,:), &            ! cloud fraction
                            pmid(:,:), &              ! midpoint pressure in pascals
                            pdel(:,:), &              ! del pressure about midpoint in pascals
                            zmid(:,:), &              ! midpoint height
                            temper(:,:)               ! midpoint temperature
      real, intent(out) ::  photos(:,:,:)             ! photodissociation rates

!-----------------------------------------------------------------
!            ... Local variables
!-----------------------------------------------------------------
      integer  ::  i, k, m                 ! indicies
      integer  ::  plev
      logical  ::  zagtz(size(coszen))     ! zenith angle > 0 flag array
      real     ::  t500, t200              ! 500 & 200 mb temperatures
      real, dimension(size(zmid,2)) :: &
                   fac1, &                ! work space for J(no) calc
                   fac2, &                ! work space for J(no) calc
                   colo3, &               ! vertical o3 column density
                   zarg, &                ! vertical height array
                   pline, &               ! vertical pressure array
                   tline, &               ! vertical temperature array
                   cld_line, &            ! vertical cloud array
                   lwc_line, &            ! vertical lwc array
                   eff_alb, &             ! effective albedo from cloud modifications
                   cld_mult               ! clould multiplier
      real, dimension(plonl,size(zmid,2)) :: &
                   tmp, &                        ! wrk array
                   tmp_jch3ooh, &                ! wrk array
                   tmp_jpan, &                   ! wrk array
                   tmp_jh2o2, &                  ! wrk array
                   tmp_jch3cho, &                ! wrk array
                   tmp_jmacr_a, &                ! wrk array
                   tmp_jn2o_200, &               ! wrk array
                   tmp_jn2o_250, &               ! wrk array
                   tmp_jn2o_300, &               ! wrk array
                   tmp_jn2o5_225, &              ! wrk array
                   tmp_jn2o5_250, &              ! wrk array
                   tmp_jn2o5_300, &              ! wrk array
                   tmp_jhno3_200, &              ! wrk array
                   tmp_jhno3_250, &              ! wrk array
                   tmp_jhno3_300, &              ! wrk array
                   tmp_jclono2_200, &            ! wrk array
                   tmp_jclono2_250, &            ! wrk array
                   tmp_jclono2_300, &            ! wrk array
                   wgt200, wgt225, wgt250, wgt300, &     ! wrk array
                   tmp_jno
      real    ::   prates(jdim,size(zmid,2))        ! photorates matrix

      plev = SIZE(zmid,2)
!-----------------------------------------------------------------
!        ... Zero all photorates
!-----------------------------------------------------------------
      do m = 1,max(1,phtcnt)
         do k = 1,plev
            photos(:,k,m) = 0.
         end do
      end do
      do k = 1,plev
         tmp_jch3ooh(:,k)     = 0.
         tmp_jpan(:,k)        = 0.
         tmp_jh2o2(:,k)       = 0.
         tmp_jch3cho(:,k)     = 0.
         tmp_jmacr_a(:,k)     = 0.
         tmp_jno(:,k)         = 0.
         tmp_jn2o_200(:,k)    = 0.
         tmp_jn2o_250(:,k)    = 0.
         tmp_jn2o_300(:,k)    = 0.
         tmp_jn2o5_225(:,k)   = 0.
         tmp_jn2o5_250(:,k)   = 0.
         tmp_jn2o5_300(:,k)   = 0.
         tmp_jhno3_200(:,k)   = 0.
         tmp_jhno3_250(:,k)   = 0.
         tmp_jhno3_300(:,k)   = 0.
         tmp_jclono2_200(:,k) = 0.
         tmp_jclono2_250(:,k) = 0.
         tmp_jclono2_300(:,k) = 0.
      end do
      zagtz(:) = coszen(:) >= coszen_min

      do i = 1,plonl
         if( zagtz(i) ) then
!           secant = 1. / coszen(i)
!           if( secant <= 50. ) then
!           if( coszen(i) >= coszen_min ) then
            zarg(:)     = zmid(i,:)
            colo3(:)    = col_dens(i,:,1)
            pline(:)    = pmid(i,:)
            fac1(:)     = pdel(i,:)
            tline(:)    = temper(i,:)
            lwc_line(:) = lwc(i,:)
            cld_line(:) = clouds(i,:)
            call cloud_mod( coszen(i), cld_line, lwc_line, fac1, srf_alb(i), &
                            eff_alb, cld_mult )
            call T_INT( pline, tline, t500, t200 )
            call PHOTO_INTERP( zarg, coszen(i), colo3, eff_alb, t500, &
                               t200, solar_phase, prates )
            do m = 1,jdim
               if( indexer(m) > 0 ) then
                  photos(i,:,indexer(m)) = esfact *prates(m,:) * cld_mult(:)
               else
                  select case( m )
                     case( TAB_NDX_JCH3OOH )
                        tmp_jch3ooh(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JH2O2 )
                        tmp_jh2o2(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JCH3CHO )
                        tmp_jch3cho(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JPAN )
                        tmp_jpan(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JMACRa )
                        tmp_jmacr_a(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JN2O_200 )
                        tmp_jn2o_200(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JN2O_250 )
                        tmp_jn2o_250(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JN2O_300 )
                        tmp_jn2o_300(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JN2O5_225 )
                        tmp_jn2o5_225(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JN2O5_250 )
                        tmp_jn2o5_250(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JN2O5_300 )
                        tmp_jn2o5_300(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JHNO3_200 )
                        tmp_jhno3_200(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JHNO3_250 )
                        tmp_jhno3_250(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JHNO3_300 )
                        tmp_jhno3_300(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JCLONO2_200 )
                        tmp_jclono2_200(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JCLONO2_250 )
                        tmp_jclono2_250(i,:) = esfact *prates(m,:) * cld_mult(:)
                     case( TAB_NDX_JCLONO2_300 )
                        tmp_jclono2_300(i,:) = esfact *prates(m,:) * cld_mult(:)
                  end select
               end if
            end do
!-----------------------------------------------------------------
!        ... Calculate J(no) from formula
!-----------------------------------------------------------------
            if (coszen(i) > 0. ) then
               fac1(:) = 1.e-8  * (col_dens(i,:,2)/coszen(i))**.38
               fac2(:) = 5.e-19 * col_dens(i,:,1) / coszen(i)
               if( jno_ndx > 0 ) then
                  photos(i,:,jno_ndx) = 4.5e-6 * esfact * exp( -(fac1(:) + fac2(:)) ) &
                                               * cld_mult(:) * jno_scale_factor
               else
                  tmp_jno(i,:) = 4.5e-6 * esfact * exp( -(fac1(:) + fac2(:)) ) &
                                        * cld_mult(:) * jno_scale_factor
               end if
            end if
!-----------------------------------------------------------------
!        ... ho2no2 near-IR photolysis
!-----------------------------------------------------------------
            if (jho2no2_ndx > 0) then
               photos(i,:,jho2no2_ndx) = photos(i, :, jho2no2_ndx) + &
                    1.e-5 * esfact * cld_mult(:)
            endif
!        end if
         end if
      end do

!-----------------------------------------------------------------
!        ... Set J(pooh) from J(ch3ooh)
!                J(c2h5ooh) from J(ch3ooh)
!                J(c3h7ooh) from J(ch3ooh)
!                J(rooh) from J(ch3ooh)
!                J(ch3coooh) = .28 * J(h2o2)
!                J(mpan) from J(pan)
!                J(macr_a) and J(macr_b) = 1/2 * J(macr_total)
!               J(onitr) from j(ch3cho)
!               J(xooh) from J(ch3ooh)
!               J(isopooh) from J(ch3ooh)
!                J(glyald) = 3 * J(ch3cho)
!               J(hyac) from J(ch3cho)
!-----------------------------------------------------------------
      if( jch3ooh_ndx > 0 ) then
         tmp(:,:) = photos(:,:,jch3ooh_ndx)
      else
         tmp(:,:) = tmp_jch3ooh(:,:)
      end if
      if( jpooh_ndx > 0 ) then
         photos(:,:,jpooh_ndx)    = tmp(:,:)
      end if
      if( jc2h5ooh_ndx > 0 ) then
         photos(:,:,jc2h5ooh_ndx) = tmp(:,:)
      end if
      if( jc3h7ooh_ndx > 0 ) then
         photos(:,:,jc3h7ooh_ndx) = tmp(:,:)
      end if
      if( jrooh_ndx > 0 ) then
         photos(:,:,jrooh_ndx)    = tmp(:,:)
      end if
      if( jxooh_ndx > 0 ) then
        photos(:,:,jxooh_ndx)    = tmp(:,:)
      end if
      if( jisopooh_ndx > 0 ) then
         photos(:,:,jisopooh_ndx) = tmp(:,:)
      end if
      if( jch3co3h_ndx > 0 ) then
         if( jh2o2_ndx > 0 ) then
            photos(:,:,jch3co3h_ndx) = .28 * photos(:,:,jh2o2_ndx)
         else
            photos(:,:,jch3co3h_ndx) = .28 * tmp_jh2o2(:,:)
         end if
      end if
      if( jmpan_ndx > 0 ) then
         if( jpan_ndx > 0 ) then
            photos(:,:,jmpan_ndx)    = photos(:,:,jpan_ndx)
         else
            photos(:,:,jmpan_ndx)    = tmp_jpan(:,:)
         end if
      end if
      if( jmacr_a_ndx > 0 ) then
         photos(:,:,jmacr_a_ndx)  = .5 * photos(:,:,jmacr_a_ndx)
      end if
      if( jmacr_b_ndx > 0 ) then
         if( jmacr_a_ndx > 0 ) then
            photos(:,:,jmacr_b_ndx)  = photos(:,:,jmacr_a_ndx)
         else
            photos(:,:,jmacr_b_ndx)  = .5 * tmp_jmacr_a(:,:)
         end if
      end if
      if( jonitr_ndx > 0 ) then
         if( jch3cho_ndx > 0 ) then
            photos(:,:,jonitr_ndx)   = photos(:,:,jch3cho_ndx)
         else
            photos(:,:,jonitr_ndx)   = tmp_jch3cho(:,:)
         end if
      end if
      if( jglyald_ndx > 0 ) then
         if( jch3cho_ndx > 0 ) then
            photos(:,:,jglyald_ndx)  = 3. * photos(:,:,jch3cho_ndx)
         else
            photos(:,:,jglyald_ndx)   = 3. *tmp_jch3cho(:,:)
         end if
      end if
      if( jh2o_ndx > 0 ) then
         if( jno_ndx > 0 ) then
            photos(:,:,jh2o_ndx) = 0.1*photos(:,:,jno_ndx)
         else
            photos(:,:,jh2o_ndx) = 0.1*tmp_jno(:,:)
         end if
      end if
      if( jn2o_ndx > 0 .and. use_tdep_jvals ) then
         wgt200(:,:)  = MIN( 1.,MAX( 0.,(250.-temper(:,:))/50. ) )
         wgt300(:,:)  = MIN( 1.,MAX( 0.,(temper(:,:)-250.)/50. ) )
         wgt250(:,:)  = 1. - wgt200(:,:) - wgt300(:,:)
         photos(:,:,jn2o_ndx)    = wgt200(:,:)*tmp_jn2o_200(:,:) + &
                                   wgt250(:,:)*tmp_jn2o_250(:,:) + &
                                   wgt300(:,:)*tmp_jn2o_300(:,:)
      end if
      if( jn2o5_ndx > 0 .and. use_tdep_jvals ) then
         wgt225(:,:)  = MIN( 1.,MAX( 0.,(250.-temper(:,:))/25. ) )
         wgt300(:,:)  = MIN( 1.,MAX( 0.,(temper(:,:)-250.)/50. ) )
         wgt250(:,:)  = 1. - wgt225(:,:) - wgt300(:,:)
         photos(:,:,jn2o5_ndx)   = wgt225(:,:)*tmp_jn2o5_225(:,:) + &
                                   wgt250(:,:)*tmp_jn2o5_250(:,:) + &
                                   wgt300(:,:)*tmp_jn2o5_300(:,:)
      end if
      if( jhno3_ndx > 0 .and. use_tdep_jvals ) then
         wgt200(:,:)  = MIN( 1.,MAX( 0.,(250.-temper(:,:))/50. ) )
         wgt300(:,:)  = MIN( 1.,MAX( 0.,(temper(:,:)-250.)/50. ) )
         wgt250(:,:)  = 1. - wgt200(:,:) - wgt300(:,:)
         photos(:,:,jhno3_ndx)   = wgt200(:,:)*tmp_jhno3_200(:,:) + &
                                   wgt250(:,:)*tmp_jhno3_250(:,:) + &
                                   wgt300(:,:)*tmp_jhno3_300(:,:)
      end if
      if( jclono2_ndx > 0 .and. use_tdep_jvals ) then
         wgt200(:,:)  = MIN( 1.,MAX( 0.,(250.-temper(:,:))/50. ) )
         wgt300(:,:)  = MIN( 1.,MAX( 0.,(temper(:,:)-250.)/50. ) )
         wgt250(:,:)  = 1. - wgt200(:,:) - wgt300(:,:)
         photos(:,:,jclono2_ndx) = wgt200(:,:)*tmp_jclono2_200(:,:) + &
                                   wgt250(:,:)*tmp_jclono2_250(:,:) + &
                                   wgt300(:,:)*tmp_jclono2_300(:,:)
      end if

      end subroutine PHOTO
! </SUBROUTINE>

      subroutine cloud_mod( coszen, clouds, lwc, delp, srf_alb, &
                            eff_alb, cld_mult )
!-----------------------------------------------------------------------
!         ... Cloud alteration factors for photorates and albedo
!-----------------------------------------------------------------------


      implicit none

      real, parameter :: gi = 1./9.80616

!-----------------------------------------------------------------------
!         ... Dummy arguments
!-----------------------------------------------------------------------
      real, intent(in)    ::  coszen             ! cosine of zenith angle
      real, intent(in)    ::  srf_alb            ! surface albedo
      real, intent(in)    ::  clouds(:)          ! cloud fraction
      real, intent(in)    ::  lwc(:)             ! liquid water content (mass mr)
      real, intent(in)    ::  delp(:)            ! del press about midpoint in pascals
      real, intent(out)   ::  eff_alb(:)         ! effective albedo
      real, intent(out)   ::  cld_mult(:)        ! photolysis mult factor

!-----------------------------------------------------------------------
!         ... Local variables
!-----------------------------------------------------------------------
      integer :: k
      integer :: plev, plevm
      real    :: coschi
      real    :: del_lwp(SIZE(clouds,1))
      real    :: del_tau(SIZE(clouds,1))
      real    :: above_tau(SIZE(clouds,1))
      real    :: below_tau(SIZE(clouds,1))
      real    :: above_cld(SIZE(clouds,1))
      real    :: below_cld(SIZE(clouds,1))
      real    :: above_tra(SIZE(clouds,1))
      real    :: below_tra(SIZE(clouds,1))
      real    :: fac1(SIZE(clouds,1))
      real    :: fac2(SIZE(clouds,1))
      
      plev = SIZE(clouds,1)
      plevm = plev-1
!---------------------------------------------------------
!        ... Modify lwc for cloud fraction and form
!            liquid water path for each layer
!---------------------------------------------------------
      where( clouds(:) /= 0. )
         del_lwp(:) = gi * lwc(:) * delp(:) * 1.e3 / clouds(:)
      elsewhere
         del_lwp(:) = 0.
      endwhere
!---------------------------------------------------------
!            ... Form tau for each model layer
!---------------------------------------------------------
      where( clouds(:) /= 0. )
         del_tau(:) = del_lwp(:) *.155 * clouds(:)**1.5
      elsewhere
         del_tau(:) = 0.
      end where
!---------------------------------------------------------
!            ... Form integrated tau from top down
!---------------------------------------------------------
      above_tau(1) = 0.
      do k = 1,plevm
         above_tau(k+1) = del_tau(k) + above_tau(k)
      end do
!---------------------------------------------------------
!            ... Form integrated tau from bottom up
!---------------------------------------------------------
      below_tau(plev) = 0.
      do k = plevm,1,-1
         below_tau(k) = del_tau(k+1) + below_tau(k+1)
      end do
!---------------------------------------------------------
!        ... Form vertically averaged cloud cover above and below
!---------------------------------------------------------
      above_cld(1) = 0.
      do k = 1,plevm
         above_cld(k+1) = clouds(k) * del_tau(k) + above_cld(k)
      end do
      do k = 2,plev
         if( above_tau(k) /= 0. ) then
            above_cld(k) = above_cld(k) / above_tau(k)
         else
            above_cld(k) = above_cld(k-1)
         end if
      end do
      below_cld(plev) = 0.
      do k = plevm,1,-1
         below_cld(k) = clouds(k+1) * del_tau(k+1) + below_cld(k+1)
      end do
      do k = plevm,1,-1
         if( below_tau(k) /= 0. ) then
            below_cld(k) = below_cld(k) / below_tau(k)
         else
            below_cld(k) = below_cld(k+1)
         end if
      end do
!---------------------------------------------------------
!        ... Modify above_tau and below_tau via jfm
!---------------------------------------------------------
      where( above_cld(2:plev) /= 0. )
         above_tau(2:plev) = above_tau(2:plev) / above_cld(2:plev)
      end where
      where( below_cld(:plevm) /= 0. )
         below_tau(:plevm) = below_tau(:plevm) / below_cld(:plevm)
      end where
      where( above_tau(2:plev) < 5. )
            above_cld(2:plev) = 0.
      end where
      where( below_tau(:plevm) < 5. )
         below_cld(:plevm) = 0.
      end where
!---------------------------------------------------------
!        ... Form transmission factors
!---------------------------------------------------------
      above_tra(:) = 11.905 / (9.524 + above_tau(:))
      below_tra(:) = 11.905 / (9.524 + below_tau(:))
!---------------------------------------------------------
!        ... Form effective albedo
!---------------------------------------------------------
      where( below_cld(:) /= 0. )
         eff_alb(:) = srf_alb + below_cld(:) * (1. - below_tra(:)) &
                                             * (1. - srf_alb)
      elsewhere
         eff_alb(:) = srf_alb
      end where
      coschi = max( coszen,.5 )
      where( del_lwp(:)*.155 < 5. )
         fac1(:) = 0.
      elsewhere
         fac1(:) = 1.4 * coschi - 1.
      end where
      fac2(:)     = MIN( 0.,1.6*coschi*above_tra(:) - 1. )
      cld_mult(:) = 1. + fac1(:) * clouds(:) + fac2(:) * above_cld(:)
      cld_mult(:) = MAX( .05,cld_mult(:) )

      end subroutine cloud_mod

      subroutine T_INT( p, t, t500, t200 )
!----------------------------------------------------------------
!        ... Interpolate for temperature on 500 and 200mb surfaces
!----------------------------------------------------------------


      implicit none

!----------------------------------------------------------------
!        ... Dummy args
!----------------------------------------------------------------
      real, intent(in)  ::  p(:)              ! pressure in pascals
      real, intent(in)  ::  t(:)              ! temperature on grid
      real, intent(out) ::  t500, t200        ! temp at 500 and 200mb

!----------------------------------------------------------------
!        ... Local variables
!----------------------------------------------------------------
      integer :: k, k1
      real    :: delp
      integer :: plev, plevp, plevm
      
      plev = SIZE(p)
      plevp = plev+1
      plevm = plev-1

      if( p(plev) < 500.e2 ) then
         t500 = t(plev)
         k1 = plevp
      else
         do k = plevm,1,-1
            if( p(k) < 500.e2 ) then
               k1 = k
               exit
            end if
         end do
         delp = LOG( 500.e2/p(k) ) / LOG( p(k+1)/p(k) )
         t500 = t(k) + delp * (t(k+1) - t(k))
      end if
      do k = k1-1,1,-1
         if( p(k) < 200.e2 ) then
            exit
         end if
      end do
      delp = LOG( 200.e2/p(k) ) / LOG( p(k+1)/p(k) )
      t200 = t(k) + delp * (t(k+1) - t(k))

      end subroutine T_INT

      subroutine PHOTO_INTERP( zin, cin, vin, albin, t500in, &
                               t200in, solar_phase, ajout )
!----------------------------------------------------------------------
!           ... Loglinear interpolation for the photodissociation rates
!            Note: this subroutine computes photorates for a vertical
!                  column at a given longitude and latitude
!           This routine uses a six parameter table via a Taylor
!           series expansion. 
!           Stacy Walters, Sep 30, 1996.  Changed code to strictly limit
!           the 200mb and 500mb temperature interpolation to the table
!           endpoints; i.e. no extrapolation beyond the table is allowed.
!----------------------------------------------------------------------


      implicit none

!----------------------------------------------------------------------
!        ... Dummy arguments
!----------------------------------------------------------------------
      real, intent(in)  ::   zin(:), &              ! geo height of midpoints
                             cin, &                 ! cosine solar zenith angle
                             vin(:), &              ! o3 column density
                             albin(:), &            ! surface albedo
                             t500in, &              ! temp on 500mb surface
                             t200in, &              ! temp on 200mb surface
                             solar_phase            ! phase of solar cycle (1=max, 0=min)
      real, intent(out) ::   ajout(:,:)             ! photodissociation rates

!----------------------------------------------------------------------
!        ... Local variables
!----------------------------------------------------------------------
      integer  ::  plev
      integer  ::  iz, is, iv, ial, nn, it500, it200
      integer  ::  izp1, isp1, ivp1, ialp1, it500p1, it200p1
      integer  ::  i, k
      integer  ::  izl
      integer, dimension(SIZE(zin)) :: altind, ratind, albind
      real     ::  wght0
      real     ::  v3std
      real     ::  dels(6)
      real, dimension(SIZE(zin)) :: v3rat
      real     :: ajout_tmp
!RSH ADD HERE:
      real    ::  ajl2(2,2,2,2,2,2)
      
      plev = SIZE(zin)

!----------------------------------------------------------------------
!        ... Find the zenith angle index ( same for all levels )
!----------------------------------------------------------------------
      do is = 1,zangdim
         if( vcos(is) > cin ) then
            exit
         end if
      end do
      is       = MAX( MIN( is,zangdim ) - 1,1 )
      isp1     = is + 1
      dels(2)  = MIN( 1.,MAX( 0.,(cin - vcos(is)) * delang(is) ) )
      if (dels(2) > 0.5) then
         dels(2) = 1. - dels(2)
         isp1 = is
         is   = isp1 + 1
      end if

!----------------------------------------------------------------------
!        ... Find the 500mb temp index ( same for all levels )
!----------------------------------------------------------------------
      do it500 = 1,t500dim
         if( t500(it500) > t500in ) then
            exit
         end if
      end do
      it500    = MAX( MIN( it500,t500dim ) - 1,1 )
      it500p1  = it500 + 1
      dels(5)  = MIN( 1.,MAX( 0.,(t500in - t500(it500)) * delt500(it500) ) )
      if (dels(5) > 0.5) then
         dels(5) = 1. - dels(5)
         it500p1  = it500
         it500    = it500p1 + 1
      end if

!----------------------------------------------------------------------
!        ... Find the 200mb temp index ( same for all levels )
!----------------------------------------------------------------------
      it200 = 1
      it200p1 = 2
      dels(6)  = MIN( 1.,MAX( 0.,(t200in - t200(it200)) * delt200(it200) )) 
      if (dels(6) > 0.5) then
         dels(6) = 1. - dels(6)
         it200    = 2
         it200p1  = 1
      end if

      izl = 1
      do k = plev,1,-1
!----------------------------------------------------------------------
!        ... Find albedo indicies
!----------------------------------------------------------------------
         do ial = 1,albdim
            if( albev(ial) > albin(k) ) then
               exit
            end if
         end do
         albind(k) = MAX( MIN( ial,albdim ) - 1,1 )
!----------------------------------------------------------------------
!        ... Find level indicies
!----------------------------------------------------------------------
         do iz = izl,altdim
            if( zz(iz) > zin(k) ) then
               izl = iz
               exit
            end if
         end do
         altind(k) = MAX( MIN( iz,altdim ) - 1,1 )
!----------------------------------------------------------------------
!        ... Find "o3 ratio" indicies
!----------------------------------------------------------------------
         i        = MAX( MIN( 79,INT( zin(k) ) ),0 )
         v3std    = vo3(i) + (zin(k) - REAL(i)) * delvo3(i)
         v3rat(k) = vin(k) / v3std
         do iv = 1,o3ratdim
            if( xv3(iv) > v3rat(k) ) then
               exit
            end if
         end do
         ratind(k) = MAX( MIN( iv,o3ratdim ) - 1,1 )
      end do
Vert_loop : &
      do k = 1,plev
!----------------------------------------------------------------------
!        ... Interval deltas and primary weight
!----------------------------------------------------------------------
         iz    = altind(k)
         izp1  = iz + 1
         dels(1)  = MIN( 1.,MAX( 0.,(zin(k) - zz(iz)) * delz(iz) ) )
         if (dels(1) > 0.5) then
            dels(1) = 1. - dels(1)
            izp1 = iz
            iz   = izp1 + 1
         end if
         iv    = ratind(k)
         ivp1  = iv + 1
         dels(3)  = MIN( 1.,MAX( 0.,(v3rat(k) - xv3(iv)) * delv(iv) ) )
         if (dels(3) > 0.5) then
            dels(3) = 1. - dels(3)
            ivp1 = iv
            iv   = ivp1 + 1
         end if
         ial   = albind(k)
         ialp1 = ial + 1
         dels(4)  = MIN( 1.,MAX( 0.,(albin(k) - albev(ial)) * delalb(ial) ) )
         if (dels(4) > 0.5) then
            dels(4) = 1. - dels(4)
            ialp1 = ial
            ial   = ialp1 + 1
         end if
         wght0    = 1. - SUM( dels )
Rate_loop : &
         do nn = 1,jdim
            ajout(nn,k) = wght0     * ajl(nn,iz,is,iv,ial,it500,it200) &
                          + dels(1) * ajl(nn,izp1,is,iv,ial,it500,it200) &
                          + dels(2) * ajl(nn,iz,isp1,iv,ial,it500,it200) &
                          + dels(3) * ajl(nn,iz,is,ivp1,ial,it500,it200) &
                          + dels(4) * ajl(nn,iz,is,iv,ialp1,it500,it200) &
                          + dels(5) * ajl(nn,iz,is,iv,ial,it500p1,it200) &
                          + dels(6) * ajl(nn,iz,is,iv,ial,it500,it200p1)
            ajl2(:,:,:,:,:,:) = ajl(nn,(/iz,izp1/),(/is,isp1/),(/iv,ivp1/),(/ial,ialp1/), &
                                    (/it500,it500p1/),(/it200,it200p1/))
            ajout(nn,k) = MAX( MIN( ajout(nn,k), MAXVAL(ajl2) ), MINVAL(ajl2) )
            ajout(nn,k) = EXP( ajout(nn,k) )
         end do Rate_loop
         if (use_solar_cycle .and. solar_phase /= 1.) then
            do nn = 1,jdim
               ajout_tmp = wght0     * ajl_solarmin(nn,iz,is,iv,ial,it500,it200) &
                           + dels(1) * ajl_solarmin(nn,izp1,is,iv,ial,it500,it200) &
                           + dels(2) * ajl_solarmin(nn,iz,isp1,iv,ial,it500,it200) &
                           + dels(3) * ajl_solarmin(nn,iz,is,ivp1,ial,it500,it200) &
                           + dels(4) * ajl_solarmin(nn,iz,is,iv,ialp1,it500,it200) &
                           + dels(5) * ajl_solarmin(nn,iz,is,iv,ial,it500p1,it200) &
                           + dels(6) * ajl_solarmin(nn,iz,is,iv,ial,it500,it200p1)
               ajl2(:,:,:,:,:,:) = ajl_solarmin(nn,(/iz,izp1/),(/is,isp1/),(/iv,ivp1/),(/ial,ialp1/), &
                                                (/it500,it500p1/),(/it200,it200p1/))
               ajout_tmp = MAX( MIN( ajout_tmp, MAXVAL(ajl2) ), MINVAL(ajl2) )
               ajout_tmp = EXP( ajout_tmp )
               ajout(nn,k) = ajout(nn,k) + (ajout_tmp-ajout(nn,k)) * (1.-solar_phase)
               ajout(nn,k) = MAX(ajout(nn,k),0.)
            end do
         end if
      end do Vert_loop

      end subroutine PHOTO_INTERP

      subroutine set_ub_col( col_delta, vmr, invariants, pdel, ptop, plonl )
!---------------------------------------------------------------
!        ... Set the column densities at the upper boundary
!---------------------------------------------------------------

      use CHEM_MODS_MOD, only : ncol_abs

      implicit none

!---------------------------------------------------------------
!        ... Dummy args
!---------------------------------------------------------------
      integer, intent(in) ::  plonl
      real, intent(out)   ::  col_delta(:,0:,:)  ! /cm**2
      real, intent(in)    ::  vmr(:,:,:), &               ! xported species vmr
                              invariants(:,:,:), &        ! invariant species
                              pdel(:,:), &                ! pressure thickness of model layers (Pa)
                              ptop(:)                     ! model top pressure (Pa)

!---------------------------------------------------------------
!        NOTE: xfactor = 10.*R/(K*g) in cgs units.
!              The factor 10. is to convert pdel
!              from pascals to dyne/cm**2.
!---------------------------------------------------------------
      real, parameter :: pa_to_dyncm2 = 10. !unit = (dyn/cm2)/pa
      real, parameter :: mw_air = 28.9644   !g/mole
      real, parameter :: grav = 981.         !cm/s2
      real, parameter :: navo = 6.023e23   ! molec/mole
      real, parameter :: xfactor = pa_to_dyncm2 * navo /(grav * mw_air)
      integer :: k, spc_ndx
      integer :: plev
      
      plev = SIZE(invariants,2)

!---------------------------------------------------------------
!        ... Assign column density at the upper boundary
!            The first column is O3 and the second is O2.
!            Add O3 column above top of model.
!---------------------------------------------------------------
      spc_ndx = ox_ndx
      if( spc_ndx < 1 ) then
         spc_ndx = o3_ndx
      end if
      if( spc_ndx > 0 ) then
         col_delta(:,0,1) = 2.687e16*o3_column_top
         do k = 1,plev
            col_delta(:,k,1) = xfactor * pdel(:,k) * vmr(:,k,spc_ndx) ! O3
         end do
      end if
!     col_delta(:,0,2) = 2.8e22
      col_delta(:,0,2) = xfactor * ptop(:) * invariants(:,plev,3)/invariants(:,plev,1)
      do k = 1,plev
         col_delta(:,k,2) = xfactor * pdel(:,k) * invariants(:,k,3)/invariants(:,k,1) ! O2
      end do

      end subroutine set_ub_col

      subroutine setcol( col_delta, col_dens, pdel, plonl )
!---------------------------------------------------------------
!             ... Set the column densities
!---------------------------------------------------------------

      use CHEM_MODS_MOD, only : ncol_abs

      implicit none

!---------------------------------------------------------------
!             ... Dummy arguments
!---------------------------------------------------------------
      integer, intent(in) :: plonl
!     real, intent(in)  ::   vmr(plonl,plev,pcnstm1)           ! xported species vmr
      real, intent(in)  ::   pdel(:,:)                         ! delta about midpoints
      real, intent(in)  ::   col_delta(:,0:,:)                 ! layer column densities (molecules/cm^2)
      real, intent(out) ::   col_dens(:,:,:)                   ! column densities ( /cm**2 )

!---------------------------------------------------------------
!        The local variables
!---------------------------------------------------------------
      integer  ::   k, km1      ! alt indicies
      integer  ::   spc_ndx
      integer  ::   plev
      
!---------------------------------------------------------------
!        NOTE: xfactor = 10.*R/(K*g) in cgs units.
!              The factor 10. is to convert pdel
!              from pascals to dyne/cm**2.
!---------------------------------------------------------------
!     real, parameter :: xfactor = 2.8704e21/(9.80616*1.38044)

      plev = SIZE(pdel,2)

!---------------------------------------------------------------
!           ... Compute column densities down to the
!           current eta index in the calling routine.
!           The first column is O3 and the second is O2.
!---------------------------------------------------------------
      spc_ndx = ox_ndx
      if( spc_ndx < 1 ) then
         spc_ndx = o3_ndx
      end if
      if( spc_ndx > 0 ) then
         col_dens(:,1,1) = col_delta(:,0,1) + .5 * col_delta(:,1,1)
         do k = 2,plev
            km1 = k - 1
            col_dens(:,k,1) = col_dens(:,km1,1) + .5 * (col_delta(:,km1,1) + col_delta(:,k,1))
         end do
      end if
      col_dens(:,1,2) = col_delta(:,0,2) + .5 * col_delta(:,1,2)
      do k = 2,plev
         km1 = k - 1
         col_dens(:,k,2) = col_dens(:,km1,2) + .5 * (col_delta(:,km1,2) + col_delta(:,k,2))
      end do

      end subroutine SETCOL


      real function SUNDIS( Time )
!-----------------------------------------------------------------------------
!=  PURPOSE:                                                                 =*
!=  Calculate Earth-Sun distance variation for a given date.  Based on       =*
!=  Fourier coefficients originally from:  Spencer, J.W., 1971, Fourier      =*
!=  series representation of the position of the sun, Search, 2:172          =*
!-----------------------------------------------------------------------------*
!=  PARAMETERS:                                                              =*
!=  IDATE  - INTEGER, specification of the date, from YYMMDD              (I)=*
!=  ESRM2  - REAL, variation of the Earth-sun distance                    (O)=*
!=           ESRM2 = (average e/s dist)^2 / (e/s dist on day IDATE)^2        =*
!-----------------------------------------------------------------------------*
!=  EDIT HISTORY:                                                            =*
!=  01/95  Changed computation of trig function values                       =*
!-----------------------------------------------------------------------------*
!= 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;  either version 2 of the license, or (at your   =*
!= option) any later version.                                                =*
!= The TUV package is distributed in the hope that it will be useful, but    =*
!= WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTIBI-  =*
!= LITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public     =*
!= License for more details.                                                 =*
!= To obtain a copy of the GNU General Public License, write to:             =*
!= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.   =*
!-----------------------------------------------------------------------------*
!= To contact the authors, please mail to:                                   =*
!= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA  or =*
!= send email to:  sasha@ucar.edu                                            =*
!-----------------------------------------------------------------------------*
!= Copyright (C) 1994,95,96  University Corporation for Atmospheric Research =*
!-----------------------------------------------------------------------------


      implicit none

!-----------------------------------------------------------------------------
!        ... Dummy arguments
!-----------------------------------------------------------------------------
      type(time_type), intent(in) :: Time             ! time

!-----------------------------------------------------------------------------
!        ... Local variables
!-----------------------------------------------------------------------------
      integer :: iyear, imonth, iday, ihour, iminute, isecond
      integer :: mday, month, jday
      integer, save :: imn(12) = (/ 31,28,31,30,31,30,31,31,30,31,30,31 /)
      real    :: dayn, thet0
      real    :: sinth, costh, sin2th, cos2th
      character(len=128) :: msg
      
!-----------------------------------------------------------------------------
!         ... Parse date to find day number (Julian day)
!-----------------------------------------------------------------------------
      call get_date( Time, iyear, imonth, iday, ihour, iminute, isecond )
      if( imonth > 12 ) then
         write(msg,*) 'Month in date exceeds 12, month = ',imonth
         call endrun(msg)
      end if

      if( MOD(iyear,4) == 0 ) then
         imn(2) = 29
      else
         imn(2) = 28
      end if

      if( iday > imn(imonth) ) then
         write(msg,*) 'Day in date exceeds days in month, day = ',iday,', month = ',imonth
         call endrun(msg)
      end if

      mday = 0
      do month = 1,imonth-1
         mday = mday + imn(month)                     
      end do
      jday = mday + iday
      dayn = REAL(jday - 1) + .5

!-----------------------------------------------------------------------------
!         ... Define angular day number and compute esrm2:
!-----------------------------------------------------------------------------
      thet0 = 2.*PI*dayn/365.

!-----------------------------------------------------------------------------
!         ... Calculate SIN(2*thet0), COS(2*thet0) 
!-----------------------------------------------------------------------------
      sinth   = SIN( thet0 )
      costh   = COS( thet0 )
      sin2th  = 2.*sinth*costh
      cos2th  = costh*costh - sinth*sinth
      SUNDIS  = 1.000110 + .034221*costh  +  .001280*sinth + .000719*cos2th +  .000077*sin2th

      end function SUNDIS


      subroutine endrun(msg)

      character(len=128), intent(in) :: msg
      call mpp_error(FATAL, msg)
      
      end subroutine endrun        

      end module MO_PHOTO_MOD


      module MO_READ_SIM_CHM_MOD

      use mpp_mod,    only : mpp_error, FATAL
      use mpp_io_mod, only : mpp_open, MPP_RDONLY, MPP_ASCII,MPP_MULTI, &
                             MPP_SINGLE, mpp_close

implicit none
character(len=128), parameter :: version     = '$Id: mo_read_sim_chm.F90,v 13.0.14.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS
        
      subroutine READ_SIM_CHM( sim_data_flsp, &
                               sim_file_cnt )
!--------------------------------------------------------
!            ... Initialize chemistry modules
!--------------------------------------------------------

      use CHEM_MODS_MOD,     only : explicit, implicit, rodas, grpcnt, &
                                nadv_mass, adv_mass, pcnstm1, &
                                drydep_cnt, drydep_lst, &
                                srfems_cnt, srfems_lst, &
                                hetcnt, het_lst, extcnt, extfrc_lst, &
                                rxt_alias_cnt, rxt_alias_lst, rxt_alias_map, &
                                ngrp, grp_mem_cnt, grp_lst
      use M_TRACNAME_MOD,    only : tracnam, natsnam

      implicit none

!--------------------------------------------------------
!            ... Dummy args
!--------------------------------------------------------
      integer, intent(out) :: sim_file_cnt
      character(len=32), intent(in) :: sim_data_flsp

!--------------------------------------------------------
!            ... Local variables
!--------------------------------------------------------
      integer, parameter :: inst = 1, avrg = 2
      integer, parameter :: max_hst_ind = 17
      integer  ::  ios, funit
      character(len=128) :: msg

!     funit = NAVU()
!--------------------------------------------------------
!            ... Open chem input unit
!--------------------------------------------------------
!     OPEN( unit = funit, &
!           file = TRIM( sim_data_flsp ), &
!           status = 'old', &
!           recl   = 2048, &
!           iostat = ios )
!     if( ios /= 0 ) then
!        write(*,*) ' READ_SIM_CHM: Failed to open file ',TRIM( sim_data_flsp )
!        write(*,*) ' Error code = ',ios
!        call ENDRUN
!     end if
      
      call mpp_open( funit, trim(sim_data_flsp), MPP_RDONLY,MPP_ASCII, threading = MPP_MULTI, &
                     fileset=MPP_SINGLE, recl = 2048)

        
!--------------------------------------------------------
!        ... Read map info from data file
!--------------------------------------------------------
      if( explicit%clscnt > 0 ) then
         read(funit,'(4i4)',iostat=ios) explicit%cls_rxt_cnt
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read explicit cls_rxt_cnt; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) explicit%clsmap
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read explicit clscnt; error = ', ios
            call ENDRUN(msg)
         end if
      end if
      if( implicit%clscnt > 0 ) then
         read(funit,'(4i4)',iostat=ios) implicit%cls_rxt_cnt
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read implicit cls_rxt_cnt; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) implicit%clsmap
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read implicit clscnt; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) implicit%permute
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read implicit permute; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) implicit%diag_map
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read implicit diag_map; error = ', ios
            call ENDRUN(msg)
         end if
      end if
      if( rodas%clscnt > 0 ) then
         read(funit,'(4i4)',iostat=ios) rodas%cls_rxt_cnt
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read rodas cls_rxt_cnt; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) rodas%clsmap
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read rodas clscnt; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) rodas%permute
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read rodas permute; error = ', ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) rodas%diag_map
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read rodas diag_map; error = ', ios
            call ENDRUN(msg)
         end if
      end if
      if( pcnstm1 > 0 ) then
         read(funit,*,iostat=ios) adv_mass(:pcnstm1)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read adv_mass; error = ', ios
            call ENDRUN(msg)
         end if
      end if
      if( grpcnt > 0 ) then
         read(funit,*,iostat=ios) nadv_mass(:grpcnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read nadv_mass; error = ', ios
            call ENDRUN(msg)
         end if
      end if
      if( pcnstm1 > 0 ) then
         read(funit,'(10a8)',iostat=ios) tracnam(:pcnstm1)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read tracnam; error = ', ios
            call ENDRUN(msg)
         end if
      end if
      if( grpcnt > 0 ) then
         read(funit,'(i4)',iostat=ios) ngrp
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read ngrp; error = ',ios
            call ENDRUN(msg)
         end if
         allocate( grp_mem_cnt(ngrp),stat=ios )
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to allocate grp_mem_cnt; error = ',ios
            call ENDRUN(msg)
         end if
         allocate( grp_lst(ngrp),stat=ios )
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to allocate grp_lst; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) grp_mem_cnt(:ngrp)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read grp_mem_cnt; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(10a8)',iostat=ios) grp_lst(:ngrp)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read grp_lst; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(10a8)',iostat=ios) natsnam(1:grpcnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read natsnam; error = ',ios
            call ENDRUN(msg)
         end if
      end if
      read(funit,'(i4)',iostat=ios) srfems_cnt
      if( ios /= 0 ) then
         write(msg,*) 'READ_SIM_CHM: Failed to read srfems_cnt; error = ',ios
            call ENDRUN(msg)
         end if
      if( srfems_cnt > 0 ) then
         allocate( srfems_lst(srfems_cnt),stat=ios )
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to allocate srfems_lst; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(10a8)',iostat=ios) srfems_lst(1:srfems_cnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read srfems_lst; error = ',ios
            call ENDRUN(msg)
         end if
      end if
      read(funit,'(i4)',iostat=ios) drydep_cnt
      if( ios /= 0 ) then
         write(msg,*) 'READ_SIM_CHM: Failed to read drydep_cnt; error = ',ios
            call ENDRUN(msg)
      end if
      if( drydep_cnt > 0 ) then
         allocate( drydep_lst(drydep_cnt),stat=ios )
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to allocate drydep_lst; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(10a8)',iostat=ios) drydep_lst(1:drydep_cnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read drydep_lst; error = ',ios
            call ENDRUN(msg)
         end if
      end if
      if( hetcnt > 0 ) then
         read(funit,'(10a8)',iostat=ios) het_lst(1:hetcnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read het_lst; error = ',ios
            call ENDRUN(msg)
         end if
      end if
      if( extcnt > 0 ) then
         read(funit,'(10a8)',iostat=ios) extfrc_lst(1:extcnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read extfrc_lst; error = ',ios
            call ENDRUN(msg)
         end if
      end if
      read(funit,'(i4)',iostat=ios) rxt_alias_cnt
      if( ios /= 0 ) then
         write(msg,*) 'READ_SIM_CHM: Failed to read rxt_alias_cnt; error = ',ios
            call ENDRUN(msg)
      end if
      if( rxt_alias_cnt > 0 ) then
         allocate( rxt_alias_lst(rxt_alias_cnt),stat=ios )
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to allocate rxt_alias_lst; error = ',ios
            call ENDRUN(msg)
         end if
         allocate( rxt_alias_map(rxt_alias_cnt),stat=ios )
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to allocate rxt_alias_map; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(5a16)',iostat=ios) rxt_alias_lst(1:rxt_alias_cnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read rxt_alias_lst; error = ',ios
            call ENDRUN(msg)
         end if
         read(funit,'(20i4)',iostat=ios) rxt_alias_map(1:rxt_alias_cnt)
         if( ios /= 0 ) then
            write(msg,*) 'READ_SIM_CHM: Failed to read rxt_alias_map; error = ',ios
            call ENDRUN(msg)
      end if
      end if

!     read(funit,'(i4)',iostat=ios) moz_file_cnt
!     if( ios /= 0 ) then
!        write(msg,*) 'READ_SIM_CHM: Failed to read moz_file_cnt; error = ',ios
!            call ENDRUN(msg)
!     end if
!     sim_file_cnt = MAX( moz_file_cnt,match_file_cnt )
!     do file = 1,moz_file_cnt
!        read(funit,'(10i4)',iostat=ios) hfile(file)%histout_cnt(:,:)
!        if( ios /= 0 ) then
!           write(msg,*) 'READ_SIM_CHM: Failed to read histout_cnt for file ',file,'; error = ',ios
!            call ENDRUN(msg)
!        end if
!     end do

!     do file = 1,sim_file_cnt
!        do k = 1,hstdim
!            if( hstinst(file)%list(k) == ' ' ) then
!               exit
!            end if
!        end do
!        hfile(file)%match_cnt(1) = k - 1
!        do k = 1,hstdim
!            if( hsttimav(file)%list(k) == ' ' ) then
!               exit
!            end if
!        end do
!        hfile(file)%match_cnt(2) = k - 1
!        do i = inst,avrg
!           moz_cnt(i) = SUM( hfile(file)%histout_cnt(:,i) )
!        end do
!        hfile(file)%mxoutflds = MAX( hfile(file)%match_cnt(1)+moz_cnt(1), &
!                                     hfile(file)%match_cnt(2)+moz_cnt(2) )
!        ALLOCATE( minst(hfile(file)%mxoutflds), mtimav(hfile(file)%mxoutflds), stat=astat )
!        if( astat /= 0 ) then
!           write(msg,*) 'READ_SIM_CHM: Failed to allocate minst,mtimav; error = ',astat
!            call ENDRUN(msg)
!        end if
!        ALLOCATE( hfile(file)%outinst(hfile(file)%mxoutflds), &
!                  hfile(file)%outtimav(hfile(file)%mxoutflds), stat=astat )
!        if( astat /= 0 ) then
!           write(msg,*) 'READ_SIM_CHM: Failed to allocate outinst,outtimav for file ',file,'; error = ',astat
!            call ENDRUN(msg)
!        end if
!        minst(:)  = 0
!        mtimav(:) = 0
!        if( hfile(file)%match_cnt(1) > 0 ) then
!           hfile(file)%outinst(:hfile(file)%match_cnt(1)) = hstinst(file)%list(:hfile(file)%match_cnt(1))
!        end if
!        if( hfile(file)%match_cnt(2) > 0 ) then
!           hfile(file)%outtimav(:hfile(file)%match_cnt(2)) = hsttimav(file)%list(:hfile(file)%match_cnt(2))
!        end if

!        do i = inst,avrg
!           end = hfile(file)%match_cnt(i)
!            endi = 0
!           do k = 1,max_hst_ind
!               if( hfile(file)%histout_cnt(k,i) /= 0 ) then
!                  start  = end + 1
!                  end    = start + hfile(file)%histout_cnt(k,i) - 1
!                  starti = endi + 1
!                  endi   = starti + hfile(file)%histout_cnt(k,i) - 1
!                  hfile(file)%histout_ind(k,i) = starti
!                  if( i == inst ) then
!                    read(funit,'(4a32)',iostat=ios) hfile(file)%outinst(start:end)
!                    read(funit,'(20i4)',iostat=ios) minst(starti:endi)
!                  else if( i == avrg ) then
!                    read(funit,'(4a32)',iostat=ios) hfile(file)%outtimav(start:end)
!                    read(funit,'(20i4)',iostat=ios) mtimav(starti:endi)
!                  end if
!               end if
!           end do
!            if( endi > 0 ) then
!               if( i == inst ) then
!                  ALLOCATE( hfile(file)%hist_inst(end), stat=astat )
!                  if( astat /= 0 ) then
!                     write(msg,*) ' READ_SIM_CHM: Failed to allocate hist_ind for file ',file,'; error = ',astat
!                     call ENDRUN(msg)
!                  end if
!                  hfile(file)%hist_inst(:end-hfile(file)%match_cnt(i)) = &
!                           hfile(file)%outinst(hfile(file)%match_cnt(i)+1:end)
!                  ALLOCATE( hfile(file)%inst_map(endi), stat=astat )
!                  if( astat /= 0 ) then
!                     write(msg,*) ' READ_SIM_CHM: Failed to allocate inst_map for file ',file,'; error = ',astat
!                    call ENDRUN(msg)
!                  end if
!                  hfile(file)%inst_map(:endi) = minst(:endi)
!               else if( i == avrg ) then
!                  ALLOCATE( hfile(file)%hist_timav(end), stat=astat )
!                  if( astat /= 0 ) then
!                     write(msg,*) ' READ_SIM_CHM: Failed to allocate hist_timav for file ',file,'; error = ',astat
!                     call ENDRUN(msg)
!                  end if
!                  hfile(file)%hist_timav(:end-hfile(file)%match_cnt(i)) = &
!                         hfile(file)%outtimav(hfile(file)%match_cnt(i)+1:end)
!                  ALLOCATE( hfile(file)%timav_map(endi), stat=astat )
!                  if( astat /= 0 ) then
!                     write(msg,*) ' READ_SIM_CHM: Failed to allocate timav_map for file ',file,'; error = ',astat
!                     call ENDRUN(msg)
!                  end if
!                  hfile(file)%timav_map(:endi) = mtimav(:endi)
!               end if
!            end if
!        end do
!         DEALLOCATE( minst, mtimav )
!     end do
!     read(funit,'(i3)') ndiags

      call mpp_close( funit )

      write(*,*) '---------------------------------------------------------------------------------'
      write(*,*) ' '

      end subroutine READ_SIM_CHM

      subroutine ENDRUN(msg)
         character(len=128), intent(in) :: msg
         call mpp_error(FATAL, msg)
      end subroutine ENDRUN        

      end module MO_READ_SIM_CHM_MOD


      module mo_rodas_sol_mod

      use chem_mods_mod, only : clscnt5

      implicit none

      private
      public :: rodas_slv_init, rodas_sol

!     save

      integer :: ox_ndx
      integer :: oh_ndx, ho2_ndx, ch3o2_ndx, po2_ndx, ch3co3_ndx, &
                 c2h5o2_ndx, isopo2_ndx, macro2_ndx, mco3_ndx, c3h7o2_ndx, &
                 ro2_ndx, xo2_ndx, no_ndx, no2_ndx, no3_ndx, n2o5_ndx, &
                 c2h4_ndx, c3h6_ndx, isop_ndx, mvk_ndx, c10h16_ndx, n_ndx
      real :: epsilon(max(1,clscnt5))
      real :: err_wghts(max(1,clscnt5))

character(len=128), parameter :: version     = '$Id: mo_rodas_slv.F90,v 14.0.10.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

      subroutine rodas_slv_init
!-----------------------------------------------------------------------      
!        ... initialize the implict solver
!-----------------------------------------------------------------------      

      use chem_mods_mod,  only : rodas
      use mo_grid_mod,    only : pcnstm1
      use mo_chem_utls_mod, only : get_spc_ndx, get_rxt_ndx

      implicit none

!-----------------------------------------------------------------------      
!        ... local variables
!-----------------------------------------------------------------------      
      real, parameter :: rel_err      = 1.e-2
      real, parameter :: high_rel_err = 1.e-3
      integer :: m
      real    :: eps(pcnstm1)
      real    :: wghts(pcnstm1)

      eps(:) = rel_err
      ox_ndx = get_spc_ndx( 'OX' )
      if( ox_ndx > 0 ) then
         eps(ox_ndx) = high_rel_err
      else
         m = get_spc_ndx( 'O3' )
         if( m > 0 ) then
            eps(m) = high_rel_err
         end if
      end if
      m = get_spc_ndx( 'NO' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'NO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'NO3' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'HNO3' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'HO2NO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'N2O5' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'OH' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if
      m = get_spc_ndx( 'HO2' )
      if( m > 0 ) then
         eps(m) = high_rel_err
      end if

      wghts(:) = 1.
      n_ndx = get_spc_ndx( 'N' )
      if( n_ndx > 0 ) then
         wghts(n_ndx) = 0.
      end if
      do m = 1,rodas%clscnt
         epsilon(m)   = eps(rodas%clsmap(m))
         err_wghts(m) = wghts(rodas%clsmap(m))
      end do

      end subroutine rodas_slv_init

      subroutine rodas_sol( base_sol, reaction_rates, &
                            het_rates, extfrc, &
                            nstep, delt, &
                            plonl, plnplv )
!-----------------------------------------------------------------------
!              ... rodas_sol advances the volumetric mixing ratio
!           forward one time step via the implicit runge-kutta rosenbrock scheme
!-----------------------------------------------------------------------

      use chem_mods_mod,           only : rod_nzcnt, clscnt5, clsze, &
                                      rxntot, hetcnt, extcnt, rodas
      use mo_grid_mod,             only : pcnstm1
      use mo_indprd_mod,           only : indprd
      use mo_rodas_prod_loss_mod,  only : rodas_prod_loss
      use mo_rod_lin_matrix_mod,   only : rod_linmat
      use mo_rod_nln_matrix_mod,   only : rod_nlnmat
      use mo_rod_factor_mod,       only : rod_lu_fac
      use mo_rod_solve_mod,        only : rod_lu_slv

      implicit none

!-----------------------------------------------------------------------
!             ... dummy arguments
!-----------------------------------------------------------------------
      integer, intent(in) ::   nstep                     ! time step index (zero based)
      integer, intent(in) ::   plonl                     ! longitude tile dimension
      integer, intent(in) ::   plnplv                    ! plonl*plev
      real, intent(in)    ::   delt                      ! time step (s)
      real, intent(in)    ::   reaction_rates(plnplv,rxntot)
      real, intent(in)    ::   het_rates(plnplv,max(1,hetcnt)), &
                               extfrc(plnplv,max(1,extcnt))
      real, intent(inout) ::   base_sol(plnplv,pcnstm1)

!-----------------------------------------------------------------------
!             ... local variables
!-----------------------------------------------------------------------
      integer, parameter :: att_limit = 5
      real, parameter    :: hmin      = 1.
      real, parameter    :: min_val   = 1.e-30
      real, parameter    :: con3      = 8./3.

      integer ::   isec, j, k, m
      integer ::   lev, indx
      integer ::   attempts, failures, step_fail_cnt
      real    ::   con1, con2
      real, dimension(max(1,rod_nzcnt)) :: sys_jac, lin_jac
      real, dimension(max(1,clscnt5))   :: yn, prod, loss, &
                                                 u1, u2, u3, u4, &
                                                 ind_prd
      real, dimension(plnplv,max(1,clscnt5))  :: gl_ind_prd
      real, dimension(max(1,rxntot))    :: lrxt
      real, dimension(max(1,hetcnt))    :: lhet
      real, dimension(max(1,pcnstm1))   :: lsol, y_temp
      real, dimension(max(1,clscnt5))         :: spc_err
      real    ::   err
      real    ::   hfull, hinv, interval
      real    ::   h
      logical ::   interval_done

!-----------------------------------------------------------------------      
!        ... if there is "independent" production put it in the forcing
!        ... set the iteration invariant part of the function f(y)
!-----------------------------------------------------------------------      
      if( rodas%indprd_cnt /= 0 .or. extcnt > 0 ) then
         call indprd( 5, gl_ind_prd, base_sol, extfrc, reaction_rates )
      else
         do m = 1,max(1,clscnt5)
            gl_ind_prd(:,m) = 0.
         end do
      end if
level_loop : &
!++lwh
!     do lev = 1,plev
      do lev = 1,plnplv/plonl
!--lwh
lon_tile_loop : &
         do isec = 1,plonl
            indx = (lev - 1)*plonl + isec
            h    = delt
            hinv = 1./h
            interval      = 0.
            step_fail_cnt = 0
            do m = 1,rxntot
               lrxt(m) = reaction_rates(indx,m) 
            end do
            if( hetcnt > 0 ) then
               do m = 1,hetcnt
                  lhet(m) = het_rates(indx,m) 
                end do
            end if
            if( rodas%indprd_cnt /= 0 .or. extcnt > 0 ) then
               do m = 1,max(1,clscnt5)
                  ind_prd(m) = gl_ind_prd(indx,m) 
               end do
            end if
!-----------------------------------------------------------------------      
!        ... full timestep loop
!-----------------------------------------------------------------------      
full_time_step_loop : &
            do
               interval_done = .false.
               failures      = 0
!-----------------------------------------------------------------------      
!        ... transfer from base to local work arrays
!-----------------------------------------------------------------------      
               do m = 1,pcnstm1
                  lsol(m)   = base_sol(indx,m) 
                  y_temp(m) = lsol(m)
               end do
!----------------------------------------------------------------------      
!        ... store values at t(n)
!-----------------------------------------------------------------------      
               do k = 1,clscnt5
                  j       = rodas%clsmap(k)
                  m       = rodas%permute(k)
                  yn(m) = lsol(j)
               end do
!-----------------------------------------------------------------------      
!        ... attemp step size
!-----------------------------------------------------------------------      
sub_step_loop : &
               do attempts = 1,att_limit
                  con1 = 2.*hinv
                  con2 = 4.*hinv
!-----------------------------------------------------------------------      
!        ... the linear component
!-----------------------------------------------------------------------      
                  if( rodas%lin_rxt_cnt > 0 ) then
                     call rod_linmat( lin_jac, lsol, lrxt, lhet )
                  end if
!-----------------------------------------------------------------------      
!        ... the non-linear component
!-----------------------------------------------------------------------      
                     call rod_nlnmat( sys_jac, lsol, lrxt, lin_jac, con1 )
!-----------------------------------------------------------------------      
!         ... factor the "system" matrix
!-----------------------------------------------------------------------      
                  call rod_lu_fac( sys_jac )
!-----------------------------------------------------------------------      
!           ... form dy/dt = prod - loss
!-----------------------------------------------------------------------      
                  call rodas_prod_loss( prod, loss, lsol, lrxt, lhet )
                   if( rodas%indprd_cnt > 0 .or. extcnt > 0 ) then
                     do m = 1,clscnt5
                        u1(m) = loss(m) - (prod(m) + ind_prd(m))
                     end do
                  else
                     do m = 1,clscnt5
                        u1(m) = loss(m) - prod(m)
                     end do
                  end if
                  do m = 1,clscnt5
                     u2(m) = u1(m)
                  end do
!-----------------------------------------------------------------------      
!           ... solve for the first intermediate
!-----------------------------------------------------------------------      
                  call rod_lu_slv( sys_jac, u1 )
!-----------------------------------------------------------------------      
!           ... solve for the second intermediate
!-----------------------------------------------------------------------      
                  do m = 1,clscnt5
                     u2(m) = u2(m) - con2*u1(m)
                  end do
                  call rod_lu_slv( sys_jac, u2 )
!-----------------------------------------------------------------------      
!           ... solve for the third intermediate
!-----------------------------------------------------------------------      
                  do k = 1,clscnt5
                     j = rodas%clsmap(k)
                     m = rodas%permute(k)
                     lsol(j) = yn(m) + 2.*u1(m)
                  end do
                  call rodas_prod_loss( prod, loss, lsol, lrxt, lhet )
                   if( rodas%indprd_cnt > 0 .or. extcnt > 0 ) then
                     do m = 1,clscnt5
                        u3(m) = loss(m) - (prod(m) + ind_prd(m) + hinv*(u1(m) - u2(m)))
                     end do
                  else
                     do m = 1,clscnt5
                        u3(m) = loss(m) - (prod(m) + hinv*(u1(m) - u2(m)))
                     end do
                  end if
                  call rod_lu_slv( sys_jac, u3 )
!-----------------------------------------------------------------------      
!           ... solve for the fourth intermediate
!-----------------------------------------------------------------------      
                  do k = 1,clscnt5
                     j = rodas%clsmap(k)
                     m = rodas%permute(k)
                     lsol(j) = yn(m) + 2.*u1(m) + u3(m)
                  end do
                  call rodas_prod_loss( prod, loss, lsol, lrxt, lhet )
                   if( rodas%indprd_cnt > 0 .or. extcnt > 0 ) then
                     do m = 1,clscnt5
                        u4(m) = loss(m) - (prod(m) + ind_prd(m) + hinv*(u1(m) - u2(m) - con3*u3(m)))
                     end do
                  else
                     do m = 1,clscnt5
                        u4(m) = loss(m) - (prod(m) + hinv*(u1(m) - u2(m) - con3*u3(m)))
                     end do
                  end if
                  call rod_lu_slv( sys_jac, u4 )
!-----------------------------------------------------------------------      
!           ... form y(n+1) from intermediates
!-----------------------------------------------------------------------      
                  do k = 1,clscnt5
                     j = rodas%clsmap(k)
                     m = rodas%permute(k)
                     lsol(j) = yn(m) + 2.*u1(m) + u3(m) + u4(m)
                  end do
!-----------------------------------------------------------------------      
!           ... form estimated trunc error
!-----------------------------------------------------------------------      
                  err = 0.
                  do k = 1,clscnt5
                     j = rodas%clsmap(k)
                     m = rodas%permute(k)
                     if( lsol(j) > min_val ) then
                        spc_err(k) = err_wghts(k) * u4(m) / (epsilon(k)*lsol(j))
                        err        = err + spc_err(k)*spc_err(k)
                        end if
                     end do
                  err = sqrt( err/real(clscnt5) )
                  if( err < 1. ) then
                     if( h == delt ) then
                        interval_done = .true.
                        hfull         = h
                        exit
                     end if
                     interval  = interval + h
                     h        = h * min( 10.,max( .1,1./(err**.33) ) )
                     h         = max( hmin,h )
                     hfull     = h
                     if( abs( interval - delt ) > 1.e-6*delt ) then
                        h    = min( delt-interval,h )
                        hinv = 1. / h
                     end if
                     exit
                  else
                     if( h == hmin ) then
                        interval      = interval + h
                        hfull         = h
                        step_fail_cnt = step_fail_cnt + 1
                        exit
                     end if
                     failures = failures + 1
                     if( attempts == att_limit ) then
                        interval = interval + h
                     end if
                     if( failures >= 2 ) then
                        h = .1 * h
                     else
                        h = h * min( 10.,max( .1,.5/(err**.33) ) )
                     end if
                     h = max( hmin,h )
                     h = min( delt-interval,h )
                     hinv = 1. / h
                     if( attempts == att_limit ) then
                        hfull         = h
                        step_fail_cnt = step_fail_cnt + 1
                        exit
                     end if
                     do m = 1,pcnstm1
                        lsol(m) = y_temp(m)
                     end do
                  end if
               end do sub_step_loop
               do m = 1,pcnstm1
                  base_sol(indx,m) = lsol(m)
               end do
               if( interval_done .or. abs( interval - delt ) <= 1.e-6*delt ) then
                  h = min( hfull,delt )
                  exit
               end if
            end do full_time_step_loop
         end do lon_tile_loop
      end do level_loop

      end subroutine rodas_sol

      end module mo_rodas_sol_mod


      module MO_SETINV_MOD

implicit none
character(len=128), parameter :: version     = '$Id: mo_setinv.F90,v 16.0.4.1 2010/03/25 00:31:41 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS

      subroutine setinv( invariants, tfld, h2ovmr, pmid, inv_data, &
                         do_interactive_h2o, plonl )
!-----------------------------------------------------------------
!        ... Set the invariant densities (molecules/cm**3)
!-----------------------------------------------------------------
      
      implicit none

!-----------------------------------------------------------------
!        ... Dummy arguments
!-----------------------------------------------------------------
      integer, intent(in)  :: plonl
      real,    intent(in)  :: tfld(:,:)           ! temperature
      real,    intent(in)  :: h2ovmr(:,:)         ! water vapor vmr
      real,    intent(in)  :: pmid(:,:)           ! pressure
      real,    intent(in)  :: inv_data(:,:,:)     ! invariants
      logical, intent(in)  :: do_interactive_h2o  ! include h2o sources/sinks?
      real,    intent(out) :: invariants(:,:,:)   ! invariant array
!-----------------------------------------------------------------
!        .. Local variables
!-----------------------------------------------------------------
      real, parameter ::  boltz = 1.38044e-16      ! erg/K

      integer :: k,j,n
      integer :: plev
      
      plev = SIZE(tfld,2)

!-----------------------------------------------------------------
!        NOTE: Invariants are in cgs density units.
!              The pmid array is in pascals and must be
!              mutiplied by 10. to yield dynes/cm**2.
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!       ... Set M, N2, O2, and H2O densities
!-----------------------------------------------------------------
      do k = 1,plev
         invariants(:,k,1) = 10. * pmid(:,k) / (boltz*tfld(:,k))
         invariants(:,k,2) = .79 * invariants(:,k,1)
         invariants(:,k,3) = .21 * invariants(:,k,1)
         if (do_interactive_h2o) then
            n=3
         else
            n=4
            invariants(:,k,n) = h2ovmr(:,k) * invariants(:,k,1)
         end if
         do j = 1, size(invariants,3)-n
            invariants(:,k,j+n) = inv_data(:,k,j) * invariants(:,k,1)
         enddo
      end do

      end subroutine SETINV

      end module MO_SETINV_MOD


      module MO_SETSOX_MOD

implicit none
character(len=128), parameter :: version     = '$Id: mo_setsox.F90,v 16.0.4.1 2010/03/17 20:27:12 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      CONTAINS

      subroutine setsox( press, plonl, dtime, tfld, qfld, &
                         lwc, xhnm, &
                         qin )

!-----------------------------------------------------------------------      
!          ... Compute heterogeneous reactions of SOX
!
!       (0) using initial PH to calculate PH
!           (a) HENRY's law constants
!           (b) PARTIONING
!           (c) PH values
!
!       (1) using new PH to repeat
!           (a) HENRY's law constants
!           (b) PARTIONING
!           (c) REACTION rates
!           (d) PREDICTION
!-----------------------------------------------------------------------      

      use mo_chem_utls_mod, only : get_spc_ndx

      implicit none
!-----------------------------------------------------------------------      
!      ... Dummy arguments
!-----------------------------------------------------------------------      
      integer, intent(in)  ::    plonl               ! number of local longitude points
      real, intent(in)     ::    dtime               ! time step (sec)
      real, intent(inout)  ::    qin(:,:,:)          ! xported species ( vmr )
      real, intent(in)     ::    xhnm(:,:)           ! total atms density ( /cm**3)
      real, dimension(:,:), intent(in) ::  &
                               tfld, &               ! temperature
                               qfld, &               ! specific humidity( kg/kg )
                               lwc,  &               ! cloud liquid water content (kg/kg)
                               press                 ! midpoint pressure ( Pa )

!-----------------------------------------------------------------------      
!      ... Local variables
!
!           xhno3 ... in mixing ratio
!-----------------------------------------------------------------------      
      integer, parameter :: itermax = 20
      real, parameter ::  ph0 = 5.0  ! INITIAL PH VALUES
      real, parameter ::  const0 = 1.e3/6.023e23
      real, parameter ::  xa0 = 11.,   &
                          xb0 = -.1,   &
                          xa1 = 1.053, &
                          xb1 = -4.368,&
                          xa2 = 1.016, &
                          xb2 = -2.54, &
                          xa3 = .816e-32, &
                          xb3 = .259
      real, parameter ::  kh0 = 9.e3, &           ! HO2(g)          -> Ho2(a)
                          kh1 = 2.05e-5, &        ! HO2(a)          -> H+ + O2-
                          kh2 = 8.6e5,   &        ! HO2(a) + ho2(a) -> h2o2(a) + o2
                          kh3 = 1.e8,    &        ! HO2(a) + o2-    -> h2o2(a) + o2
                          Ra = 8314./101325., &   ! universal constant   (atm)/(M-K)
                          xkw = 1.e-14            ! water acidity
      real, parameter :: small_value = 1.e-20

      integer    ::      k, i, iter
      integer    ::      plev
      real       ::      wrk, delta
      real       ::      xph0, xk, xe, x2
      real       ::      tz, xl, px, qz, pz, es, qs, patm
      real       ::      Eso2, Eso4, Ehno3, Eco2, Eh2o, Enh3
      real       ::      hno3g, nh3g, so2g, h2o2g, co2g, o3g
      real       ::      rah2o2, rao3, pso4, ccc
      real       ::      xx0, yy1, xkp
      real       ::      cnh3, chno3, com, com1, com2, xra
      real       ::      RH
      integer    ::      ox_ndx, hno3_ndx, h2o2_ndx, so2_ndx, so4_ndx, &
                         nh3_ndx, nh4no3_ndx, ho2_ndx

!-----------------------------------------------------------------------      
!            for Ho2(g) -> H2o2(a) formation 
!            schwartz JGR, 1984, 11589
!-----------------------------------------------------------------------      
      real       ::      kh4    ! kh2+kh3
      real       ::      xam    ! air density /cm3
      real       ::      ho2s   ! ho2s = ho2(a)+o2-
      real       ::      r1h2o2 ! prod(h2o2) by ho2 in mole/L(w)/s
      real       ::      r2h2o2 ! prod(h2o2) by ho2 in mix/s

      real, dimension(SIZE(tfld,1),SIZE(tfld,2))  :: &
                         xhno3, xh2o2, xso2, xso4,&
                         xnh3, xo3,         &
                         xlwc, cfact,       &
                         xph, xant, xho2,         &
                         hehno3, &            ! henry law const for hno3
                         heh2o2, &            ! henry law const for h2o2
                         heso2,  &            ! henry law const for so2
                         henh3,  &            ! henry law const for nh3
                         heo3                 ! henry law const for nh3
      real, dimension(plonl)  :: &
                         t_fac
      logical :: converged


      ox_ndx = get_spc_ndx( 'OX' )
      hno3_ndx = get_spc_ndx( 'HNO3' )
      h2o2_ndx = get_spc_ndx( 'H2O2' )
      so2_ndx = get_spc_ndx( 'SO2' )
      so4_ndx = get_spc_ndx( 'SO4' )
      nh3_ndx = get_spc_ndx( 'NH3' )
      nh4no3_ndx = get_spc_ndx( 'NH4NO3' )
      ho2_ndx = get_spc_ndx( 'HO2' )

      plev = SIZE(tfld,2)
      
!-----------------------------------------------------------------
!       ... NOTE: The press array is in pascals and must be
!                 mutiplied by 10 to yield dynes/cm**2.
!-----------------------------------------------------------------

!==================================================================
!       ... First set the PH
!==================================================================
!      ... Initial values
!           The values of so2, so4 are after (1) SLT, and CHEM
!-----------------------------------------------------------------
      xph0 = 10.**(-ph0)                      ! initial PH value
      do k = 1,plev
!        precip(:,k) = cmfdqr(:,k) + rain(:,k) - evapr(:,k)
      end do

      do k = 1,plev
          cfact(1:,k) = xhnm(1:,k) &             ! /cm3(a)  
                            * 1.e6          &             ! /m3(a)
                            * 1.38e-23/287. &             ! Kg(a)/m3(a)
                            * 1.e-3                       ! Kg(a)/L(a)
      end do

      do k = 1,plev
         xph(:,k) = xph0                                    ! initial PH value
         xlwc(:,k) = lwc(:,k) *cfact(:,k)           ! cloud water  L(water)/L(air)
!        xrain(:,k) = rain(:,k) *cfact(:,k)         ! RAIN  water  L(water)/L(air)
         if( hno3_ndx > 0 ) then
            xhno3(:,k) = qin(:,k,hno3_ndx)                  ! mixing ratio
         else
            xhno3(:,k) = 0.
         end if
         if( h2o2_ndx > 0 ) then
            xh2o2(:,k) = qin(:,k,h2o2_ndx)                  ! mixing ratio
         else
            xh2o2(:,k) = 0.
         end if
         if( so2_ndx > 0 ) then
            xso2(:,k) = qin(:,k,so2_ndx)                   ! mixing ratio
         else
            xso2(:,k) = 0.
         end if
         if( so4_ndx > 0 ) then
            xso4(:,k) = qin(:,k,so4_ndx)                   ! mixing ratio
         else
            xso4(:,k) = 0.
         end if
         if( nh3_ndx > 0 ) then
            xnh3(:,k) = qin(:,k,nh3_ndx)                   ! mixing ratio
         else
            xnh3(:,k) = 0.
         end if
         if( nh4no3_ndx > 0 ) then
            xant(:,k) = qin(:,k,nh4no3_ndx)                   ! mixing ratio
         else
            xant(:,k) = 0.
         end if
         if( ox_ndx > 0 ) then
            xo3(:,k) = qin(:,k,ox_ndx)                    ! mixing ratio
         else
            xo3(:,k) = 0.
         end if
         if( ho2_ndx > 0 ) then
            xho2(:,k) = qin(:,k,ho2_ndx)                   ! mixing ratio
         else
            xho2(:,k) = 0.
         end if
      end do 

!-----------------------------------------------------------------
!       ... Temperature dependent Henry constants
!-----------------------------------------------------------------
      do k = 1,plev                                             !! plev loop for STEP 0
         do i = 1,plonl
            xl = xlwc(i,k) 
            if( xl >= 1.e-8 ) then
               t_fac(i) = 1. / tfld(i,k) - 1. / 298.
!-----------------------------------------------------------------------      
!        ... hno3
!-----------------------------------------------------------------------      
               do iter = 1,itermax
                  xk = 2.1e5 *EXP( 8700.*t_fac(i) )
                  xe = 15.4
                  hehno3(i,k)  = xk*(1. + xe/xph(i,k))
!-----------------------------------------------------------------------      
!         ... h2o2
!-----------------------------------------------------------------------      
                  xk = 7.4e4   *EXP( 6621.*t_fac(i) )
                  xe = 2.2e-12 *EXP(-3730.*t_fac(i) )
                  heh2o2(i,k)  = xk*(1. + xe/xph(i,k))
!-----------------------------------------------------------------------      
!          ... so2
!-----------------------------------------------------------------------      
                  xk = 1.23  *EXP( 3120.*t_fac(i) )
                  xe = 1.7e-2*EXP( 2090.*t_fac(i) )
                  x2 = 6.0e-8*EXP( 1120.*t_fac(i) )
                  wrk = xe/xph(i,k)
                  heso2(i,k)  = xk*(1. + wrk*(1. + x2/xph(i,k)))
!-----------------------------------------------------------------------      
!          ... nh3
!-----------------------------------------------------------------------      
                  xk = 58.   *EXP( 4085.*t_fac(i) )
                  xe = 1.7e-5*EXP(-4325.*t_fac(i) )
                  henh3(i,k)  = xk*(1. + xe*xph(i,k)/xkw)
!-----------------------------------------------------------------
!       ... Partioning and effect of pH 
!-----------------------------------------------------------------
                  pz = .01*press(i,k)       !! pressure in mb
                  tz = tfld(i,k)
                  patm = pz/1013.
                  xam  = press(i,k)/(1.38e-23*tz)  !air density /M3
!-----------------------------------------------------------------
!        ... hno3
!-----------------------------------------------------------------
                  px = hehno3(i,k) * Ra * tz * xl
                  hno3g = xhno3(i,k)/(1. + px)
                  xk = 2.1e5 *EXP( 8700.*t_fac(i) )
                  xe = 15.4
                  Ehno3 = xk*xe*hno3g *patm
!-----------------------------------------------------------------
!          ... so2
!-----------------------------------------------------------------
                  px = heso2(i,k) * Ra * tz * xl
                  so2g =  xso2(i,k)/(1.+ px)
                  xk = 1.23  *EXP( 3120.*t_fac(i) )
                  xe = 1.7e-2*EXP( 2090.*t_fac(i) )
                  Eso2 = xk*xe*so2g *patm
!-----------------------------------------------------------------
!          ... nh3
!-----------------------------------------------------------------
                  px = henh3(i,k) * Ra * tz * xl
                  nh3g = xnh3(i,k)/(1.+ px)
                  xk = 58.   *EXP( 4085.*t_fac(i) )
                  xe = 1.7e-5*EXP( -4325.*t_fac(i) )
                  Enh3 = xk*xe*nh3g/xkw *patm
!-----------------------------------------------------------------
!        ... h2o effects
!-----------------------------------------------------------------
                  Eh2o = xkw
!-----------------------------------------------------------------
!        ... co2 effects
!-----------------------------------------------------------------
                  co2g = 330.e-6                            !330 ppm = 330.e-6 atm
                  xk = 3.1e-2*EXP( 2423.*t_fac(i) )
                  xe = 4.3e-7*EXP(-913. *t_fac(i) )
                  Eco2 = xk*xe*co2g  *patm
!-----------------------------------------------------------------
!        ... PH cal
!-----------------------------------------------------------------
                  com2 = (Eh2o + Ehno3 + Eso2 + Eco2)  &
                       / (1. + Enh3 )
                  com2 = MAX( com2,1.e-20 )
                  xph(i,k) = SQRT( com2 )
!-----------------------------------------------------------------
!         ... Add so4 effect
!-----------------------------------------------------------------
                  Eso4 = xso4(i,k)*xhnm(i,k)   &         ! /cm3(a)
                        *const0/xl
                  xph(i,k) =  MIN( 1.e-2,MAX( 1.e-7,xph(i,k) + 2.*Eso4 ) )
                  if( iter > 1 ) then
                     if ( ABS(delta) > 1.e-40 ) then
                        delta = ABS( (xph(i,k) - delta)/delta )
                     else
                        delta = 0.
                     end if
                     converged = delta < .01
                     if( converged ) then
                        exit
                     else
                        delta = xph(i,k)
                     end if
                  else
                     delta = xph(i,k)
                  end if
               end do
               if( .not. converged ) then
                  write(*,*) 'SETSOX: pH failed to converge @ (',i,',',k,'), % change=', &
                              100.*delta
               end if
            else
               xph(i,k) =  1.e-7
            end if
         end do
      end do  ! end plev loop for STEP 0
!     do file = 1,match_file_cnt
!     call OUTFLD( 'PH', xph,  plonl, ip, lat, file )
!     ENDDO

!==============================================================
!          ... Now use the actual PH
!==============================================================
      do k = 1,plev
         do i = 1,plonl
            t_fac(i) = 1. / tfld(i,k) - 1. / 298.
            tz = tfld(i,k)
            xl = xlwc(i,k)
            patm = press(i,k)/101300.        ! press is in pascal
            xam  = press(i,k)/(1.38e-23*tz)  ! air density /M3

!-----------------------------------------------------------------
!         ... hno3
!-----------------------------------------------------------------
            xk = 2.1e5 *EXP( 8700.*t_fac(i) )
            xe = 15.4
            hehno3(i,k)  = xk*(1. + xe/xph(i,k))

!-----------------------------------------------------------------
!        ... h2o2
!-----------------------------------------------------------------
            xk = 7.4e4   *EXP( 6621.*t_fac(i) )
            xe = 2.2e-12 *EXP(-3730.*t_fac(i) )
            heh2o2(i,k)  = xk*(1. + xe/xph(i,k))

!-----------------------------------------------------------------
!         ... so2
!-----------------------------------------------------------------
            xk = 1.23  *EXP( 3120.*t_fac(i) )
            xe = 1.7e-2*EXP( 2090.*t_fac(i) )
            x2 = 6.0e-8*EXP( 1120.*t_fac(i) )

            wrk = xe/xph(i,k)
            heso2(i,k)  = 1.e2  !xk*(1. + wrk*(1. + x2/xph(i,k)))

!-----------------------------------------------------------------
!          ... nh3
!-----------------------------------------------------------------
            xk = 58.   *EXP( 4085.*t_fac(i) )
            xe = 1.7e-5*EXP(-4325.*t_fac(i) )
            henh3(i,k)  = xk*(1. + xe*xph(i,k)/xkw)

!-----------------------------------------------------------------
!        ... o3
!-----------------------------------------------------------------
            xk = 1.15e-2 *EXP( 2560.*t_fac(i) )
            heo3(i,k) = xk

!------------------------------------------------------------------------
!       ... for Ho2(g) -> H2o2(a) formation 
!           schwartz JGR, 1984, 11589
!------------------------------------------------------------------------
            kh4 = (kh2 + kh3*kh1/xph(i,k)) / ((1. + kh1/xph(i,k))**2)
            ho2s = kh0*xho2(i,k)*patm*(1. + kh1/xph(i,k))  ! ho2s = ho2(a)+o2-
            r1h2o2 = kh4*ho2s*ho2s                         ! prod(h2o2) in mole/L(w)/s
            r2h2o2 = r1h2o2*xlwc(i,k)  &                   ! mole/L(w)/s   * L(w)/fm3(a) = mole/fm3(a)/s
                           *const0     &                   ! mole/fm3(a)/s * 1.e-3       = mole/cm3(a)/s
                           /xam                            ! /cm3(a)/s    / air-den     = mix-ratio/s
            xh2o2(i,k) = xh2o2(i,k) + r2h2o2*dtime         ! updated h2o2 by het production

!-----------------------------------------------
!       ... Partioning 
!-----------------------------------------------
!------------------------------------------------------------------------
!        ... h2o2
!------------------------------------------------------------------------
            px = heh2o2(i,k) * Ra * tz * xl
            h2o2g =  xh2o2(i,k)/(1.+ px)

!------------------------------------------------------------------------
!         ... so2
!------------------------------------------------------------------------
            px = heso2(i,k) * Ra * tz * xl
            so2g =  xso2(i,k)/(1.+ px)

!------------------------------------------------------------------------
!         ... o3 ============
!------------------------------------------------------------------------
            px = heo3(i,k) * Ra * tz * xl
            o3g =  xo3(i,k)/(1.+ px)

!-----------------------------------------------
!       ... Aqueous phase reaction rates
!           SO2 + H2O2 -> SO4
!           SO2 + O3   -> SO4
!-----------------------------------------------
          
!------------------------------------------------------------------------
!       ... S(IV) (HSO3) + H2O2
!------------------------------------------------------------------------
            rah2o2 = 8.e4 * EXP( -3650.*t_fac(i) )  &
                   / (.1 + xph(i,k))

!------------------------------------------------------------------------
!        ... S(IV)+ O3
!------------------------------------------------------------------------
            rao3   = 4.39e11 * EXP(-4131./tz)  &
                  + 2.56e3  * EXP(-996. /tz) /xph(i,k)

!-----------------------------------------------------------------
!       ... Prediction after aqueous phase
!       so4
!       When Cloud is present 
!   
!       S(IV) + H2O2 = S(VI)
!       S(IV) + O3   = S(VI)
!
!       reference:
!           (1) Seinfeld
!           (2) Benkovitz
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!       ... S(IV) + H2O2 = S(VI)
!-----------------------------------------------------------------
            if( xl >= 1.e-8 ) then                          ! when cloud is present
               pso4 = rah2o2 * heh2o2(i,k)*h2o2g  &
                             * heso2(i,k) *so2g             ! [M/s]
               pso4 = pso4       &                          ! [M/s] =  [mole/L(w)/s]
                    * xlwc(i,k)  &                          ! [mole/L(a)/s]
                    / const0     &                          ! [/L(a)/s]
                    / xhnm(i,k)                             ! [mixing ratio/s]

          ccc = pso4*dtime


               ccc = MAX( MIN( ccc, xso2(i,k), xh2o2(i,k) ), 0. )
                  xso4(i,k)  = xso4(i,k)  + ccc
               xh2o2(i,k) = MAX( xh2o2(i,k) - ccc, small_value )
               xso2(i,k)  = MAX( xso2(i,k)  - ccc, small_value )

!-----------------------------------------------
!       ... S(IV) + O3 = S(VI)
!-----------------------------------------------
               pso4 = rao3 * heo3(i,k)*o3g * heso2(i,k)*so2g       ! [M/s]
               pso4 = pso4        &                                ! [M/s] =  [mole/L(w)/s]
                    * xlwc(i,k)   &                                ! [mole/L(a)/s]
                    / const0      &                                ! [/L(a)/s]
                    / xhnm(i,k)                                    ! [mixing ratio/s]

          ccc = pso4*dtime

               ccc = MAX( MIN( ccc, xso2(i,k) ), 0. )
                  xso4(i,k)  = xso4(i,k)  + ccc
               xso2(i,k)  = MAX( xso2(i,k)  - ccc, small_value )
            end if                                               ! when cloud is present

!-----------------------------------------------------------------
!       ... Formation of NH4+ + SO4=
!           to balance 1 SO4= should take 2 NH4+
!           According to Dentener and Crutzen (1994) JAC 331
!           the neutralization of sulfuric acid by NH3
!           is (NH4)1.5 H0.5(SO4)
!-----------------------------------------------------------------

!-----------------------------------------------------------------
!       ... Formation of AMMONIUM NITRATE (ANT)
!           Calculate reaction coefficient NH3(g)+HNO3(g)=NH4(+)NO3(-) 
!                                                   Kp(ppb**2)
!      * Kp is calculated according to
!        Stelson and Seinfeld Atm. Env 16 983, 1982
!        Seinfeld (1986) 
!-----------------------------------------------------------------
            qz = qfld(i,k)             ! H2O mass mxing ratio Kg/Kg
            pz = .01*press(i,k)        ! pressure in mb
 
!-----------------------------------------------------------------
!        ... Calculate RH
!-----------------------------------------------------------------
            wrk = tz - 273.
            es = 6.11*10.**(7.63*wrk/(241.9 + wrk))            ! Magnus EQ
            qs = .622*es/pz                                    ! sat mass mix (H2O)
            RH = 100.*qz/qs                                    ! relative huminity(%)
            RH = MIN( 100.,MAX( RH,0. ) )
  
            xx0 = xa0 + xb0*RH

            if( RH >= 90. ) then
               yy1 = xa1*EXP( xb1/xx0 )
            else
               yy1 = xa2*EXP( xb2/xx0 )
            end if            

            xkp = yy1*(xa3*EXP( xb3*tz )/.7) &    ! ppb**2
                    * 1.e-18                      ! mixing ratio

            cnh3 = xnh3(i,k)
            chno3 = xhno3(i,k)
            com = cnh3*chno3

            com1 = (cnh3 + chno3)**2 - 4.*(cnh3*chno3 - xkp)
            com1 = MAX( com1,1.e-30 )

            if( com >= xkp ) then   ! NH4NO3 is formed
               xra = .5*(cnh3 + chno3 - SQRT(com1))
!-----------------------------------------------------------------
!        ... xra =0.0 for not forming ANT
!-----------------------------------------------------------------
!               xra = 0.

               xant(i,k) = MAX( xant(i,k) + xra, small_value )
               xnh3(i,k) = MAX( xnh3(i,k) - xra, small_value )
               xhno3(i,k)= MAX( xhno3(i,k)- xra, small_value )
            end if

!-----------------------------------------------------------------
!      ... Washout SO2, SO4 and NH3
!-----------------------------------------------------------------
            xso4(i,k)  = MAX( xso4(i,k), small_value )
            xant(i,k)  = MAX( xant(i,k), small_value )
            xnh3(i,k)  = MAX( xnh3(i,k), small_value )
            xso2(i,k)  = MAX( xso2(i,k), small_value )
         end do
      end do

!==============================================================
!       ... Update the mixing ratios
!==============================================================
      do k = 1,plev
         if( so2_ndx > 0 ) then
            qin(:,k,so2_ndx) =  MAX( xso2(:,k), small_value )
         end if
         if( so4_ndx > 0 ) then
            qin(:,k,so4_ndx) =  MAX( xso4(:,k), small_value )
         end if
         if( h2o2_ndx > 0 ) then
            qin(:,k,h2o2_ndx) =  MAX( xh2o2(:,k), small_value ) 
         end if
         if( nh3_ndx > 0 ) then
            qin(:,k,nh3_ndx) =  MAX( xnh3(:,k), small_value )
         end if
         if( nh4no3_ndx > 0 ) then
            qin(:,k,nh4no3_ndx) =  MAX( xant(:,k), small_value )
         end if
         if( hno3_ndx > 0 ) then
            qin(:,k,hno3_ndx) =  MAX( xhno3(:,k), small_value )
         end if
      end do 
 
      end subroutine SETSOX

      end module MO_SETSOX_MOD


      module mo_usrrxt_mod

      use sat_vapor_pres_mod, only : compute_qs
      use constants_mod, only : rdgas, rvgas
      use strat_chem_utilities_mod, only : psc_type, strat_chem_get_gamma, &
                                           strat_chem_get_hetrates
      
implicit none
      private
      public :: usrrxt_init, usrrxt

!     save

      integer :: usr1_ndx, usr2_ndx, usr3_ndx, usr5_ndx, usr6_ndx, usr7_ndx, &
                 usr8_ndx, usr9_ndx, usr11_ndx, usr12_ndx, usr14_ndx, usr15_ndx, &
                 usr16_ndx, usr17_ndx, usr21_ndx, usr22_ndx, &
                 usr24_ndx, usr25_ndx, &
                 so4_ndx, h2o_ndx, hcl_ndx, clono2_ndx, hbr_ndx, &
                 strat37_ndx, strat38_ndx, strat72_ndx, strat73_ndx, strat74_ndx, &
                 strat75_ndx, strat76_ndx, strat77_ndx, strat78_ndx, strat79_ndx, &
                 strat80_ndx

      real, parameter :: d622 = rdgas/rvgas
      real, parameter :: d378 = 1. - d622     

character(len=128), parameter :: version     = '$Id: mo_usrrxt.F90,v 17.0.4.2.2.1.2.1 2010/03/25 00:36:29 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      contains

      subroutine usrrxt_init( verbose )
!-----------------------------------------------------------------
!        ... Intialize the user reaction constants module
!-----------------------------------------------------------------

      use mo_chem_utls_mod, only : get_rxt_ndx, get_spc_ndx

      implicit none

!-----------------------------------------------------------------------
!       ... Dummy arguments
!-----------------------------------------------------------------------
      integer,          intent(in) :: verbose

      usr1_ndx = get_rxt_ndx( 'usr1' )
      usr2_ndx = get_rxt_ndx( 'usr2' )
      usr3_ndx = get_rxt_ndx( 'usr3' )
      usr5_ndx = get_rxt_ndx( 'usr5' )
      usr6_ndx = get_rxt_ndx( 'usr6' )
      usr7_ndx = get_rxt_ndx( 'usr7' )
      usr8_ndx = get_rxt_ndx( 'usr8' )
      usr9_ndx = get_rxt_ndx( 'usr9' )
      usr11_ndx = get_rxt_ndx( 'usr11' )
      usr12_ndx = get_rxt_ndx( 'usr12' )
      usr14_ndx = get_rxt_ndx( 'usr14' )
      usr15_ndx = get_rxt_ndx( 'usr15' )
      usr16_ndx = get_rxt_ndx( 'usr16' )
      usr17_ndx = get_rxt_ndx( 'usr17' )
      usr21_ndx = get_rxt_ndx( 'usr21' )
      usr22_ndx = get_rxt_ndx( 'usr22' )
      usr24_ndx = get_rxt_ndx( 'usr24' )
      usr25_ndx = get_rxt_ndx( 'usr25' )
      strat37_ndx = get_rxt_ndx( 'strat37' )
      strat38_ndx = get_rxt_ndx( 'strat38' )
      strat72_ndx = get_rxt_ndx( 'strat72' )
      strat73_ndx = get_rxt_ndx( 'strat73' )
      strat74_ndx = get_rxt_ndx( 'strat74' )
      strat75_ndx = get_rxt_ndx( 'strat75' )
      strat76_ndx = get_rxt_ndx( 'strat76' )
      strat77_ndx = get_rxt_ndx( 'strat77' )
      strat78_ndx = get_rxt_ndx( 'strat78' )
      strat79_ndx = get_rxt_ndx( 'strat79' )
      strat80_ndx = get_rxt_ndx( 'strat80' )

      so4_ndx = get_spc_ndx( 'SO4' )
      h2o_ndx = get_spc_ndx( 'H2O' )
      hcl_ndx = get_spc_ndx( 'HCl' )
      clono2_ndx = get_spc_ndx( 'ClONO2' )
      hbr_ndx = get_spc_ndx( 'HBr' )

      if (verbose >= 2) then
      write(*,*) 'usrrxt_init: diagnostics '
      write(*,'(10i5)') usr1_ndx, usr2_ndx, usr3_ndx, usr5_ndx, usr6_ndx, usr7_ndx, &
                 usr8_ndx, usr9_ndx, usr11_ndx, usr12_ndx, usr14_ndx, usr15_ndx, &
                 usr16_ndx, usr17_ndx, usr21_ndx, usr22_ndx, &
                 usr24_ndx, usr25_ndx, &
                 strat37_ndx, strat38_ndx, strat72_ndx, strat73_ndx, strat74_ndx, &
                 strat75_ndx, strat76_ndx, strat77_ndx, strat78_ndx, strat79_ndx, &
                 strat80_ndx
      end if

      end subroutine usrrxt_init

      subroutine usrrxt( rxt, temp, invariants, h2ovmr, pmid, m, &
                         sulfate, psc, qin, sh, delt, plonl )
!-----------------------------------------------------------------
!        ... set the user specified reaction rates
!-----------------------------------------------------------------

      use chem_mods_mod, only : nfs, rxntot, indexh2o
      use constants_mod, only : PI
      use m_rxt_id_mod

      implicit none

!-----------------------------------------------------------------
!        ... dummy arguments
!-----------------------------------------------------------------
      integer, intent(in) :: plonl
      real,    intent(in) :: qin(:,:,:)            ! transported species ( vmr )
      real,    intent(in) :: temp(:,:), &          ! temperature
                             m(:,:), &             ! total atm density
                             sulfate(:,:), &       ! sulfate aerosol vmr
                             h2ovmr(:,:), &        ! water vapor vmr
                             pmid(:,:), &          ! midpoint pressure in pa
                             sh(:,:), &            ! specific humidity
                             invariants(:,:,:)     ! invariants density
      type(psc_type), intent(in) :: &
                             psc                   ! polar stratospheric clouds (PSCs)
      real,    intent(in) :: delt                  ! timestep (sec)
      real, intent(inout) :: rxt(:,:,:)            ! gas phase rates
      
!-----------------------------------------------------------------
!        ... local variables
!-----------------------------------------------------------------
      real, parameter :: boltz = 1.38044e-16            ! erg / k
      real, parameter :: avo   = 6.023e23               ! molecules/mole
!-----------------------------------------------------------------
!        ... density of sulfate aerosol
!-----------------------------------------------------------------
!     real, parameter :: gam1 = 0.04                    ! n2o5+sul ->2hno3
      real, parameter :: gam1 = 0.10                    ! n2o5+sul ->2hno3
      real, parameter :: gam4 = 0.05                    ! NH3 +SUL ->NH4SO4 (Dentener 1994)
      real, parameter :: wso4 = 98.
      real, parameter :: den  = 1.15                    ! each molecule of so4(aer) density g/cm3
!-------------------------------------------------
!         ... volume of sulfate particles
!           assuming mean rm 
!           continient 0.05um  0.07um  0.09um
!           ocean      0.09um  0.25um  0.37um
!                      0.16um                  blake jgr,7195, 1995
!-------------------------------------------------
      real, parameter :: rm1  = 0.16*1.e-4                   ! mean radii in cm
      real, parameter :: fare = 4.*3.14*rm1*rm1              ! each mean particle(r=0.1u) area   cm2/cm3
      real, parameter :: dg   = 0.1                          ! mole diffusion =0.1 cm2 (Dentener, 1993)

      integer  ::  k
      real     ::  amas
      real, dimension( SIZE(temp,1) ) :: &
                   tp, &                    ! 300/t
                   tinv, &                  ! 1/t
                   ko, &
                   kinf, &
                   fc, &
                   xr, &                    ! factor to increase particle radii depending on rel hum
                   sur, &                   ! sulfate particle surface area (cm^2/cm^3)
                   exp_fac, &               ! vector exponential
                   tmp_hcl, &               ! temporary array for HCl VMR
                   tmp_clono2, &            ! temporary array for ClONO2 VMR
                   tmp_hbr                  ! temporary array for HBr VMR
      integer, parameter :: nhet_strat = 9
      real, dimension(SIZE(temp,1), nhet_strat) :: &
                   gamma_strat, &           ! reaction probabilities for strat. het. rxns
                   hetrates_strat           ! effective second-order reaction rates for strat. het. rxns
      integer ::   plev
      real, dimension(SIZE(temp,1),SIZE(temp,2)) :: &
                   relhum                   ! relative humidity
      INTEGER :: tmp_indexh2o

      plev = SIZE(temp,2)
      
      amas = 4.*PI*rm1**3*den/3.            ! each mean particle(r=0.1u) mass (g)
!-----------------------------------------------------------------
!        ... o + o2 + m --> o3 + m
!-----------------------------------------------------------------
      do k = 1,plev
         tinv(:)           = 1. / temp(:,k)
         tp(:)             = 300. * tinv(:)
         if( usr1_ndx > 0 ) then
            rxt(:,k,usr1_ndx) = 6.e-34 * tp(:)**2.4
         end if
#ifdef IBM
!-----------------------------------------------------------------
!        ... n2o5 + m --> no2 + no3 + m
!-----------------------------------------------------------------
         if( usr3_ndx > 0 ) then
            if( usr2_ndx > 0 ) then
               call vexp( exp_fac, -11000.*tinv, plonl )
               rxt(:,k,usr3_ndx) = rxt(:,k,usr2_ndx) * 3.704e26 * exp_fac(:)
            else
               rxt(:,k,usr3_ndx) = 0.
            end if
         end if

!-----------------------------------------------------------------
!        set rates for:
!         ... hno3 + oh --> no3 + h2o
!           ho2no2 + m --> ho2 + no2 + m
!           co + oh --> co2 + ho2
!-----------------------------------------------------------------
         if( usr5_ndx > 0 ) then
            call vexp( exp_fac, 1335.*tinv, plonl )
            ko(:) = m(:,k) * 6.5e-34 * exp_fac(:)
            call vexp( exp_fac, 2199.*tinv, plonl )
            ko(:) = ko(:) / (1. + ko(:)/(2.7e-17*exp_fac(:)))
            call vexp( exp_fac, 460.*tinv, plonl )
            rxt(:,k,usr5_ndx) = ko(:) + 2.4e-14*exp_fac(:)
         end if
         if( usr7_ndx > 0 ) then
            if( usr6_ndx > 0 ) then
               call vexp( exp_fac, -10900.*tinv, plonl )
               rxt(:,k,usr7_ndx) = rxt(:,k,usr6_ndx) * exp_fac(:) / 2.1e-27
            else
               rxt(:,k,usr7_ndx) = 0.
            end if
         end if
!        if( usr8_ndx > 0 ) then
!           rxt(:,k,usr8_ndx) = 1.5e-13 * (1. + 6.e-7*boltz*m(:,k)*temp(:,k))
!        end if

!-----------------------------------------------------------------
!        ... ho2 + ho2 --> h2o2
!        note: this rate involves the water vapor number density
!-----------------------------------------------------------------
         if( usr9_ndx > 0 ) then
            if( indexh2o > 0 ) then
               tmp_indexh2o = indexh2o
               call vexp( exp_fac, 2200.*tinv, plonl )
               fc(:)   = 1. + 1.4e-21 * invariants(:,k,tmp_indexh2o) * exp_fac(:)
            else if( h2o_ndx > 0 ) then
               call vexp( exp_fac, 2200.*tinv, plonl )
               fc(:)   = 1. + 1.4e-21 * qin(:,k,h2o_ndx) * m(:,k) * exp_fac(:)
            else
               fc(:) = 1.
            end if
            call vexp( exp_fac, 430.*tinv, plonl )
            ko(:)   = 3.5e-13 * exp_fac(:)
            call vexp( exp_fac, 1000.*tinv, plonl )
            kinf(:) = 1.7e-33 * m(:,k) * exp_fac(:)
            rxt(:,k,usr9_ndx) = (ko(:) + kinf(:)) * fc(:)
         end if

!-----------------------------------------------------------------
!            ... mco3 + no2 -> mpan
!-----------------------------------------------------------------
         if( usr14_ndx > 0 ) then
            rxt(:,k,usr14_ndx) = 9.3e-12 * tp(:) / m(:,k)
         end if

!-----------------------------------------------------------------
!        ... pan + m --> ch3co3 + no2 + m
!-----------------------------------------------------------------
         call vexp( exp_fac, -14000.*tinv, plonl )
         if( usr12_ndx > 0 ) then
            if( usr11_ndx > 0 ) then
               rxt(:,k,usr12_ndx) = rxt(:,k,usr11_ndx) * 1.111e28 * exp_fac(:)
            else
               rxt(:,k,usr12_ndx) = 0.
            end if
         end if

!-----------------------------------------------------------------
!        ... mpan + m --> mco3 + no2 + m
!-----------------------------------------------------------------
         if( usr15_ndx > 0 ) then
            if( usr14_ndx > 0 ) then
               rxt(:,k,usr15_ndx) = rxt(:,k,usr14_ndx) * 1.111e28 * exp_fac(:)
            else
               rxt(:,k,usr15_ndx) = 0.
            end if
         end if

!-----------------------------------------------------------------
!       ... xooh + oh -> h2o + oh
!-----------------------------------------------------------------
         if( usr21_ndx > 0 ) then
            call vexp( exp_fac, 253.*tinv, plonl )
            rxt(:,k,usr21_ndx) = temp(:,k)**2 * 7.69e-17 * exp_fac(:)
         end if

!-----------------------------------------------------------------
!       ... ch3coch3 + oh -> ro2 + h2o
!-----------------------------------------------------------------
         if( usr22_ndx > 0 ) then
            call vexp( exp_fac, -2000.*tinv, plonl )
            rxt(:,k,usr22_ndx) = 3.82e-11 * exp_fac(:) + 1.33e-13
         end if
!-----------------------------------------------------------------
!       ... DMS + OH -> .75 * SO2
!-----------------------------------------------------------------
         if( usr24_ndx > 0 ) then
            call vexp( exp_fac, 5820.*tinv, plonl )
            call vexp( xr, 6280.*tinv, plonl )
            ko(:) = 1. + 5.0e-30 * xr * m(:,k) * 0.21
            rxt(:,k,usr24_ndx) = 1.0e-39 * exp_fac * m(:,k) * 0.21 / ko(:)
         end if

!-----------------------------------------------------------------
!        ... Cl2O2 + M -> 2*ClO + M
!-----------------------------------------------------------------
         if( strat38_ndx > 0 ) then
            if( strat37_ndx > 0 ) then
               call vexp( exp_fac, -8835.*tinv, plonl )
               rxt(:,k,strat38_ndx) = rxt(:,k,strat37_ndx) * 1.075e27 * exp_fac(:)
            else
               rxt(:,k,strat38_ndx) = 0.
            end if
         end if
#else
!-----------------------------------------------------------------
!        ... n2o5 + m --> no2 + no3 + m
!-----------------------------------------------------------------
         if( usr3_ndx > 0 ) then
            if( usr2_ndx > 0 ) then
               rxt(:,k,usr3_ndx) = rxt(:,k,usr2_ndx) * 3.704e26 * exp( -11000.*tinv(:) )
            else
               rxt(:,k,usr3_ndx) = 0.
            end if
         end if

!-----------------------------------------------------------------
!        set rates for:
!         ... hno3 + oh --> no3 + h2o
!           ho2no2 + m --> ho2 + no2 + m
!           co + oh --> co2 + ho2
!-----------------------------------------------------------------
         if( usr5_ndx > 0 ) then
            ko(:) = m(:,k) * 6.5e-34 * exp( 1335.*tinv(:) )
            ko(:) = ko(:) / (1. + ko(:)/(2.7e-17*exp( 2199.*tinv(:) )))
            rxt(:,k,usr5_ndx) = ko(:) + 2.4e-14*exp( 460.*tinv(:) )
         end if
         if( usr7_ndx > 0 ) then
            if( usr6_ndx > 0 ) then
               rxt(:,k,usr7_ndx) = rxt(:,k,usr6_ndx) * exp( -10900.*tinv(:) )/ 2.1e-27
            else
               rxt(:,k,usr7_ndx) = 0.
            end if
         end if
!        if( usr8_ndx > 0 ) then
!           rxt(:,k,usr8_ndx) = 1.5e-13 * (1. + 6.e-7*boltz*m(:,k)*temp(:,k))
!        end if

!-----------------------------------------------------------------
!        ... ho2 + ho2 --> h2o2
!        note: this rate involves the water vapor number density
!-----------------------------------------------------------------
         if( usr9_ndx > 0 ) then
            if( indexh2o > 0 ) then
               tmp_indexh2o = indexh2o
               fc(:)   = 1. + 1.4e-21 * invariants(:,k,tmp_indexh2o) * exp( 2200.*tinv(:) )
            else if( h2o_ndx > 0 ) then
               fc(:)   = 1. + 1.4e-21 * qin(:,k,h2o_ndx) * m(:,k) * exp( 2200.*tinv(:) )
            else
               fc(:) = 1.
            end if
            ko(:)   = 3.5e-13 * exp( 430.*tinv(:) )
            kinf(:) = 1.7e-33 * m(:,k) * exp( 1000.*tinv(:) )
            rxt(:,k,usr9_ndx) = (ko(:) + kinf(:)) * fc(:)
         end if

!-----------------------------------------------------------------
!            ... mco3 + no2 -> mpan
!-----------------------------------------------------------------
         if( usr14_ndx > 0 ) then
            rxt(:,k,usr14_ndx) = 9.3e-12 * tp(:) / m(:,k)
         end if

!-----------------------------------------------------------------
!        ... pan + m --> ch3co3 + no2 + m
!-----------------------------------------------------------------
         exp_fac(:) = exp( -14000.*tinv(:) )
         if( usr12_ndx > 0 ) then
            if( usr11_ndx > 0 ) then
               rxt(:,k,usr12_ndx) = rxt(:,k,usr11_ndx) * 1.111e28 * exp_fac(:)
            else
               rxt(:,k,usr12_ndx) = 0.
            end if
         end if

!-----------------------------------------------------------------
!        ... mpan + m --> mco3 + no2 + m
!-----------------------------------------------------------------
         if( usr15_ndx > 0 ) then
            if( usr14_ndx > 0 ) then
               rxt(:,k,usr15_ndx) = rxt(:,k,usr14_ndx) * 1.111e28 * exp_fac(:)
            else
               rxt(:,k,usr15_ndx) = 0.
            end if
         end if

!-----------------------------------------------------------------
!       ... xooh + oh -> h2o + oh
!-----------------------------------------------------------------
         if( usr21_ndx > 0 ) then
            rxt(:,k,usr21_ndx) = temp(:,k)**2 * 7.69e-17 * exp( 253.*tinv(:) )
         end if

!-----------------------------------------------------------------
!       ... ch3coch3 + oh -> ro2 + h2o
!-----------------------------------------------------------------
         if( usr22_ndx > 0 ) then
            rxt(:,k,usr22_ndx) = 3.82e-11 * exp( -2000.*tinv(:) ) &
                                 + 1.33e-13
         end if
!-----------------------------------------------------------------
!       ... DMS + OH -> .75 * SO2
!-----------------------------------------------------------------
         if( usr24_ndx > 0 ) then
            ko(:) = 1. + 5.0e-30 * exp( 6280.*tinv(:) ) * m(:,k) * 0.21
            rxt(:,k,usr24_ndx) = 1.0e-39 * exp( 5820.*tinv(:) ) &
                                 * m(:,k) * 0.21 / ko(:)
         end if

!-----------------------------------------------------------------
!        ... Cl2O2 + M -> 2*ClO + M
!-----------------------------------------------------------------
         if( strat38_ndx > 0 ) then
            if( strat37_ndx > 0 ) then
               rxt(:,k,strat38_ndx) = rxt(:,k,strat37_ndx) * 1.075e27 * exp( -8835.*tinv(:) )
            else
               rxt(:,k,strat38_ndx) = 0.
            end if
         end if
#endif
         if( usr16_ndx > 0 .or. usr17_ndx > 0 .or. usr25_ndx > 0 ) then
!-----------------------------------------------------------------
!         ... n2o5 --> 2*hno3
!             no3 --> hno3
!-----------------------------------------------------------------
!        ... first compute the relative humidity
!-----------------------------------------------------------------
!           call aqsat( temp(1,k), pmid(1,k), satv, satq, plonl, &
!                       plonl, 1, 1, 1 )
!           relhum(:) = .622 * h2ovmr(:,k) / satq(:)
!           relhum(:) = max( 0.,min( 1.,relhum(:) ) )
            call rh_calc( pmid(:,k), temp(:,k), sh(:,k), relhum(:,k) )
!-------------------------------------------------------------------------
!         ... estimate humidity effect on aerosols (from shettle and fenn, 1979)
!           xr is a factor of the increase aerosol radii with hum (hum=0., factor=1)
!-------------------------------------------------------------------------
            xr(:)     = .999151 + relhum(:,k)*(1.90445 + relhum(:,k)*(-6.35204 + relhum(:,k)*5.32061))
!-------------------------------------------------------------------------
!         ... estimate sulfate particles surface area (cm2/cm3) in each grid
!-------------------------------------------------------------------------
            if( so4_ndx > 0 ) then
               sur(:)    = qin(:,k,so4_ndx)
            else
               sur(:)    = sulfate(:,k)
            end if
            sur(:)    = sur(:)*m(:,k)/avo*wso4 &              ! xform mixing ratio to g/cm3
                        / amas &                                    ! xform g/cm3 to num particels/cm3
                        * fare &                                    ! xform num particels/cm3 to cm2/cm3
                        * xr(:)*xr(:)                               ! humidity factor
!-----------------------------------------------------------------
!        ... compute the "aerosol" reaction rates
!-----------------------------------------------------------------
!             k = gam * a * velo/4
!
!       where velo = sqrt[ 8*bk*t/pi/(w/av) ]
!             bk = 1.381e-16
!             av = 6.02e23
!             w  = 108 (n2o5)  ho2(33)  ch2o (30)  nh3(15)  
!
!       so that velo = 1.40e3*sqrt(t)  (n2o5)   gama=0.1
!       so that velo = 2.53e3*sqrt(t)  (ho2)    gama>0.2
!       so that velo = 2.65e3*sqrt(t)  (ch2o)   gama>0.022
!       so that velo = 3.75e3*sqrt(t)  (nh3)    gama=0.4
!--------------------------------------------------------
!           xr(:) = .25 * gam1 * sur(:) * 1.40e3 * sqrt( temp(:,k) )
            xr(:) = 1./(rm1/dg + 4./(gam1+1.e-30)/(1.40e3 * sqrt( temp(:,k))))*sur(:)
            if( usr16_ndx > 0 ) then
               rxt(:,k,usr16_ndx) = xr(:)
            end if
            if( usr17_ndx > 0 ) then
               rxt(:,k,usr17_ndx) = xr(:)
            end if
            if( usr25_ndx > 0 ) then
               rxt(:,k,usr25_ndx) = &
                  1./(rm1/dg + 4./(gam4+1.e-30)/(3.75e3 * sqrt( temp(:,k))))*sur(:)
            end if
         end if

         if( strat72_ndx > 0 .or. strat73_ndx > 0 .or. strat74_ndx > 0 .or. &
             strat75_ndx > 0 .or. strat76_ndx > 0 .or. strat77_ndx > 0 .or. &
             strat78_ndx > 0 .or. strat79_ndx > 0 .or. strat80_ndx > 0 ) then

            if (hcl_ndx>0) then
               tmp_hcl(:) = qin(:,k,hcl_ndx)
            else
               tmp_hcl(:) = 0.
            end if
            if (clono2_ndx>0) then
               tmp_clono2(:) = qin(:,k,clono2_ndx)
            else
               tmp_clono2(:) = 0.
            end if
            if (hbr_ndx>0) then
               tmp_hbr(:) = qin(:,k,hbr_ndx)
            else
               tmp_hbr(:) = 0.
            end if
            call strat_chem_get_gamma( temp(:,k), pmid(:,k), m(:,k), &
                                       tmp_hcl, tmp_clono2, &
                                       psc, k, gamma_strat )
            call strat_chem_get_hetrates( temp(:,k), tmp_hcl, tmp_hbr, h2ovmr(:,k), &
                                          m(:,k), psc, gamma_strat, k, delt, hetrates_strat )
            
            if( strat72_ndx > 0 ) then
               rxt(:,k,strat72_ndx) = hetrates_strat(:,1)
            end if
            if( strat73_ndx > 0 ) then
               rxt(:,k,strat73_ndx) = hetrates_strat(:,2)
            end if
            if( strat74_ndx > 0 ) then
               rxt(:,k,strat74_ndx) = hetrates_strat(:,3)
            end if
            if( strat75_ndx > 0 ) then
               rxt(:,k,strat75_ndx) = hetrates_strat(:,4)
            end if
            if( strat76_ndx > 0 ) then
               rxt(:,k,strat76_ndx) = hetrates_strat(:,5)
            end if
            if( strat77_ndx > 0 ) then
               rxt(:,k,strat77_ndx) = hetrates_strat(:,6)
            end if
            if( strat78_ndx > 0 ) then
               rxt(:,k,strat78_ndx) = hetrates_strat(:,7)
            end if
            if( strat79_ndx > 0 ) then
               rxt(:,k,strat79_ndx) = hetrates_strat(:,8)
            end if
            if( strat80_ndx > 0 ) then
               rxt(:,k,strat80_ndx) = hetrates_strat(:,9)
            end if

         end if

      end do

      end subroutine usrrxt

      subroutine rh_calc(pmid, temp, sh, rh)
              
        implicit none
        
        real, intent(in), dimension(:) :: pmid, temp, sh
        real, intent(out), dimension(:) :: rh
        
!-----------------------------------------------------------------------
!       Calculate RELATIVE humidity.
!       This is calculated according to the formula:
!
!       RH   = qv / (epsilon*esat/ [pfull  -  (1.-epsilon)*esat])
!
!       Where epsilon = Rdgas/RVgas = d622
!
!       and where 1- epsilon = d378
!
!       Note that rh does not have its proper value
!       until all of the following code has been executed.  That
!       is, rh is used to store intermediary results
!       in forming the full solution.
!-----------------------------------------------------------------------
        
!-----------------------------------------------------------------------
!calculate water saturated specific humidity
!-----------------------------------------------------------------------
        call compute_qs (temp, pmid, rh, q = sh)
        
!-----------------------------------------------------------------------
!calculate rh
!-----------------------------------------------------------------------
        rh(:)= sh(:) / rh(:)
        
      end subroutine rh_calc
        
      end module mo_usrrxt_mod



      module m_tracname_mod
!-----------------------------------------------------------
!       ... List of advected and non-advected trace species, and
!           surface fluxes for the advected species.
!-----------------------------------------------------------

      use mo_grid_mod,   only : pcnst
      use chem_mods_mod, only : grpcnt

      implicit none

character(len=128), parameter :: version     = '$Id: m_tracname.F90,v 13.0.14.1 2010/03/25 00:31:42 pjp Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
logical                       :: module_is_initialized = .false.

      save

      character(len=8) :: tracnam(pcnst)          ! species names
      character(len=8) :: natsnam(max(1,grpcnt))  ! names of non-advected trace species

      end module m_tracname_mod


module strat_chem_utilities_mod

use       mpp_io_mod, only : mpp_open, mpp_close, MPP_RDONLY
use          mpp_mod, only : mpp_pe, mpp_root_pe, stdout
use          fms_mod, only : file_exist, open_namelist_file, close_file, &
                             error_mesg, FATAL
use    constants_mod, only : PI, DEG_TO_RAD, AVOGNO, PSTD_MKS, SECONDS_PER_DAY
use time_manager_mod, only : time_type, get_date, days_in_month, days_in_year, &
                             set_date, increment_time, set_time, &
                             operator(>), operator(<), operator(-), operator(+)
!++lwh
use interpolator_mod, only : interpolate_type, interpolator_init, &
                             obtain_interpolator_time_slices, &
                             unset_interpolator_time_flag, &
                             interpolator, interpolator_end, &
                             CONSTANT, INTERP_WEIGHTED_P
use time_interp_mod, only  : time_interp_init, time_interp
use diag_manager_mod, only : get_base_time

!--lwh

implicit none
private

integer, parameter :: nlon_input=144, nlat_input=90, nlev_input=48, &
                      nspecies_age=8, nspecies_lbc=15, &
                      ntime_tropc=151, year_start_tropc=1950, nspecies_tropc=9
! real, parameter :: agefact1 = 1.5, &
!                    agefact2 = 1.25
real, parameter :: clweight(7) = (/ 3., 2., 3., 4., 1., 3., 1. /)

real :: tropc(ntime_tropc,nspecies_tropc)
!++lwh
type(time_type) :: tropc_Time(ntime_tropc), cfc_entry, cfc_offset
logical :: time_varying_cfc_lbc, negative_offset_cfc

! real :: dfdage(nlat_input,nlev_input,nspecies_age)
! real :: lat_input(nlat_input)
real, parameter :: days_per_year = 365.25, &
                   tfact = 1./(days_per_year*SECONDS_PER_DAY)
! integer :: jstart
real :: age_factor, dclydt_factor
!--lwh

type psc_type
   private
   real, dimension(:,:), pointer :: &
      tice=>NULL(), wh2so4=>NULL(), am=>NULL(), aw=>NULL(), &
      aliq=>NULL(), rmean=>NULL(), asat=>NULL(), rnat=>NULL(), rice=>NULL()
   real, dimension(:,:,:), pointer :: &
      cond=>NULL()
   real :: adrop, anat, aice
end type psc_type

!++lwh
type(interpolate_type), save  :: dfdage_interp
character(len=32), save  :: dfdage_filename = "dfdage3.dat.nc"
character(len=32), dimension(nspecies_age), save :: dfdage_name = &      ! kerr
      (/ "dfdage_cfc11  ", "dfdage_cfc12  ", "dfdage_cfc113 ", "dfdage_ccl4   ", &
         "dfdage_ch3cl  ", "dfdage_ch3ccl3", "dfdage_hcfc22 ", "dfdage_bry    " /)
!--lwh

! For extra H2O calculation
real, dimension(:), allocatable :: ch4_value
type(time_type), dimension(:), allocatable :: ch4_time
logical :: fixed_ch4_lbc_time = .false.
type(time_type) :: ch4_entry

!-----------------------------------------------------------------------
!     ... interfaces
!-----------------------------------------------------------------------
public strat_chem_utilities_init, strat_chem_dcly_dt, strat_chem_get_aerosol, &
       strat_chem_dcly_dt_time_vary, strat_chem_dcly_dt_endts, &
       strat_chem_get_h2so4, strat_chem_get_psc, strat_chem_destroy_psc, &
       strat_chem_get_gamma, strat_chem_get_hetrates, strat_chem_psc_sediment, &
       strat_chem_get_extra_h2o, &
       psc_type


!---- version number -----
character(len=128), parameter :: version     = ''
character(len=128), parameter :: tagname     = ''

logical :: module_is_initialized=.false.

CONTAINS

subroutine strat_chem_utilities_init( lonb, latb, age_factor_in, dclydt_factor_in, &
                                      set_min_h2o_strat, ch4_filename, ch4_scale_factor, &
                                      fixed_ch4_lbc_time_in, ch4_entry_in, &
                                      cfc_lbc_filename, time_varying_cfc_lbc_in, cfc_lbc_dataset_entry )

   implicit none
! dummy arguments
   real,             intent(in), dimension(:,:) :: lonb,latb
   real,             intent(in)                 :: age_factor_in, dclydt_factor_in
   logical,          intent(in)                 :: set_min_h2o_strat
   character(len=*), intent(in)                 :: ch4_filename
   real,             intent(in)                 :: ch4_scale_factor
   logical,          intent(in)                 :: fixed_ch4_lbc_time_in
   type(time_type),  intent(in)                 :: ch4_entry_in
   character(len=*), intent(in)                 :: cfc_lbc_filename
   logical,          intent(in)                 :: time_varying_cfc_lbc_in
   integer,          intent(in), dimension(:)   :: cfc_lbc_dataset_entry
   
! local variables
   real :: chlb_dummy(nlat_input,nspecies_lbc), &
           ozb_dummy(nlon_input, nlat_input, 12)
   integer :: unit, nc, n, year, outunit
   type(time_type) :: Model_init_time
   
   if (module_is_initialized) return

!-----------------------------------------------------------------------
!     ... initialize time_interp
!-----------------------------------------------------------------------
   call time_interp_init

!-----------------------------------------------------------------------
!     ... set scale factors for age of air and dcly/dt
!-----------------------------------------------------------------------
   age_factor = age_factor_in
   dclydt_factor = dclydt_factor_in

!-----------------------------------------------------------------------
!     ... read in chemical lower boundary 
!-----------------------------------------------------------------------
   call mpp_open( unit, 'INPUT/' // TRIM(cfc_lbc_filename),action=MPP_RDONLY )
   outunit= stdout()
   if (mpp_pe() == mpp_root_pe()) WRITE(outunit,*) 'reading INPUT/' // TRIM(cfc_lbc_filename)
   do nc = 1,15                                           
     read(unit,'(6E13.6)') chlb_dummy(:,nc)
   end do
   read(unit,'(6E13.6)') ozb_dummy
   read(unit,'(6e13.6)') tropc
   call mpp_close(unit)

!++lwh
!---------------------------------------------------------------------
!    convert the time stamps of the tropc series to time_type variables.     
!---------------------------------------------------------------------
   time_varying_cfc_lbc = time_varying_cfc_lbc_in
   Model_init_time = get_base_time()
   if ( cfc_lbc_dataset_entry(1) == 1 .and. &
        cfc_lbc_dataset_entry(2) == 1 .and. &
        cfc_lbc_dataset_entry(3) == 1 .and. &
        cfc_lbc_dataset_entry(4) == 0 .and. &
        cfc_lbc_dataset_entry(5) == 0 .and. &
        cfc_lbc_dataset_entry(6) == 0 ) then
      cfc_entry = Model_init_time
   else
      cfc_entry = set_date( cfc_lbc_dataset_entry(1), &
                            cfc_lbc_dataset_entry(2), &
                            cfc_lbc_dataset_entry(3), &
                            cfc_lbc_dataset_entry(4), &
                            cfc_lbc_dataset_entry(5), &
                            cfc_lbc_dataset_entry(6) )
   end if         
   if (time_varying_cfc_lbc) then
      cfc_offset = cfc_entry - Model_init_time
      if (Model_init_time > cfc_entry) then
         negative_offset_cfc = .true.
      else
         negative_offset_cfc = .false.
      end if
   end if

   do n = 1,ntime_tropc
      year = year_start_tropc + (n-1)
      tropc_Time(n) = set_date(year,1,1,0,0,0)
   end do
!--lwh


!++lwh -- replace dfdage ASCII file with NetCDF via interpolator

!  read in data for Cly and Bry computation
!  call mpp_open( unit, 'INPUT/ageair_fms_90.dat', action=MPP_RDONLY )
!  if (mpp_pe() == mpp_root_pe()) &
!     write(stdout(),*) 'strat_chem_utilities_init: Reading from INPUT/ageair_fms_90.dat'
!  read(unit,'(6e13.6)') age_dummy
!  read(unit,'(6e13.6)') dfdage
!  call mpp_close(unit)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!  THIS CODE WILL NOT WORK CORRECTLY FOR CUBED SPHERE  !!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  jstart = 0   
!  do j = 1,nlat_input
!     lat_input(j) = ( -90. + (180./(nlat_input-1))*(j-1) ) * DEG_TO_RAD
!     if (lat_input(j) >= latb(1,1) .and. lat_input(j) <= latb(1,2)) jstart = j
!  end do
!  if (mpp_pe() == mpp_root_pe()) &
!     write(stdout(),*) 'strat_chem_utilities_init: jstart=',jstart,' on PE ',mpp_pe()
!

   call interpolator_init (dfdage_interp,  &
                           dfdage_filename, lonb, latb,  &
                           data_names=dfdage_name(:),   &
                           data_out_of_bounds=(/CONSTANT/), &
                           vert_interp=(/INTERP_WEIGHTED_P/) )  

   if (set_min_h2o_strat) then
      call strat_chem_extra_h2o_init( ch4_filename, ch4_scale_factor, &
                                      fixed_ch4_lbc_time_in, ch4_entry_in )
   end if

   module_is_initialized = .true.


end subroutine strat_chem_utilities_init



!#####################################################################

subroutine strat_chem_dcly_dt_time_vary(Time)


type(time_type), intent(in) :: Time

      call obtain_interpolator_time_slices (dfdage_interp, Time)

end subroutine strat_chem_dcly_dt_time_vary



!#####################################################################

subroutine strat_chem_dcly_dt_endts              

      call unset_interpolator_time_flag (dfdage_interp)

end subroutine strat_chem_dcly_dt_endts



!#####################################################################

!++lwh
subroutine strat_chem_dcly_dt(Time, phalf, is, js, age, cly, bry, dclydt, dbrydt)
!--lwh

implicit none

! dummy arguments

type(time_type),        intent(in)  :: Time
!++lwh
integer,                intent(in)  :: is, js
real, dimension(:,:,:), intent(in)  :: phalf, age, cly, bry
!--lwh
real, dimension(:,:,:), intent(out) :: dclydt, dbrydt

! local variables

integer :: iyear, imon, iday, ihour, imin, isec
real :: dt1, factor, extra_seconds
integer :: it1,it2
integer :: ic, i, j, k, il, jl, kl
real :: clytot, brytot
!++lwh
! real, dimension(size(age,1),size(age,2),nspecies_age) :: dfdtau
real, dimension(size(age,1),size(age,2),size(age,3),nspecies_age) :: dfdage
type(time_type) :: cfc_Time, cfc_base_Time
!--lwh
real, dimension(size(age,1),size(age,2),nspecies_tropc) :: cfc

call get_date( Time, iyear, imon, iday, ihour, imin, isec )

il = size(age,1)
jl = size(age,2)
kl = size(age,3)

!-----------------------------------------------------------------------
!     ... Compute multiplying factor for missing CFCs, and include factor
!         for conversion of rates to a per second rate. 
!-----------------------------------------------------------------------

! time0 = iyear + REAL(imon-1)/12.
! it1 = INT(time0-year_start_tropc) + 1
! it1 = min(max(it1,1),ntime_tropc-1)
! it2 = it1+1
! dt1 = time0 - (year_start_tropc-1) - it1

! sum1 = 0.
! sum2 = 0.
! do ic = 1,7
!    sum1 = sum1 + clweight(ic) * tropc(it1,ic)
!    sum2 = sum2 + clweight(ic) * tropc(it2,ic)
! end do
! factor = ((1-dt1)*tropc(it1,8) + dt1*tropc(it2,8))*tfact / (sum1*(1-dt1) + sum2*dt1)

! monthfrac = REAL(iday)/REAL(days_in_month(Time))
! imon2 = MOD(imon,12) + 1


!++lwh -- Read in dfdage from NetCDF file via interpolator
call interpolator (dfdage_interp, Time, phalf, dfdage, dfdage_name(1), is, js)
!--lwh

if (time_varying_cfc_lbc) then
   if (negative_offset_cfc) then
      cfc_base_Time = Time - cfc_offset
   else
      cfc_base_Time = Time + cfc_offset
   end  if
else
   cfc_base_Time = cfc_entry
end if

level_loop: &
do k = 1,kl


!++lwh -- Switch to reading from NetCDF file via interpolator (above)
! Copy dfdage to locally indexed variable
!  do j = 1,jl
!  do ic = 1,8
!     dfdtau(:,j,ic) = dfdage(j+jstart-1+js-1,k,ic)
!  end do
!  end do
!--lwh

!-----------------------------------------------------------------------
!     ... Compute CFCs at time t - age
!-----------------------------------------------------------------------

   do j = 1,jl
   do i = 1,il
!++lwh
! Time-interpolate tropospheric CFC concentrations
!     time0 = iyear + (imon+monthfrac-1)/12. - age(i,j,k)*age_factor
!     it1 = INT(time0-year_start_tropc) + 1
!     it1 = min(max(it1,1),ntime_tropc-1)
!     it2 = it1 + 1
!     dt1 = time0 - (year_start_tropc-1) - it1
!     cfc(i,j,:) = tropc(it1,:)*(1-dt1) + tropc(it2,:)*dt1

      extra_seconds = age(i,j,k)*age_factor / tfact
      
      cfc_Time = increment_time( cfc_base_Time, -NINT(extra_seconds), 0)
      if (cfc_Time < tropc_Time(1)) then
         cfc_Time = tropc_Time(1)
      else if (cfc_Time > tropc_Time(ntime_tropc)) then
         cfc_Time = tropc_Time(ntime_tropc)
      end if
      call time_interp( cfc_Time, tropc_Time(:), dt1, it1, it2 )
      cfc(i,j,:) = tropc(it1,:)*(1-dt1) + tropc(it2,:)*dt1
!--lwh

      factor = cfc(i,j,8) / SUM(cfc(i,j,1:7)*clweight(1:7))
      dclydt(i,j,k) = 0.
      do ic = 1,7
         dclydt(i,j,k) = dclydt(i,j,k) &
                       + factor * 1.e-12 * tfact * dclydt_factor &
!++lwh
!                      * dfdtau(i,j,ic) * clweight(ic) * cfc(i,j,ic)
                       * dfdage(i,j,k,ic) * clweight(ic) * cfc(i,j,ic)
!--lwh
      end do
      clytot = 1.e-12*cfc(i,j,8)
      if (cly(i,j,k) >= clytot) dclydt(i,j,k) = 0.
!++lwh
!     dbrydt(i,j,k) = 1.e-12 * tfact * dfdtau(i,j,8)*cfc(i,j,9)
      dbrydt(i,j,k) = 1.e-12 * tfact * dfdage(i,j,k,8)*cfc(i,j,9)
!--lwh
      brytot = 1.e-12*cfc(i,j,9)
      if (bry(i,j,k) >= brytot) dbrydt(i,j,k) = 0.
   end do
   end do
   
end do level_loop


end subroutine strat_chem_dcly_dt


! <SUBROUTINE NAME="strat_chem_get_aerosol">
!   <OVERVIEW>
!     Estimate stratospheric aerosol surface area based on aerosol extinction.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Estimate stratospheric aerosol surface area based on aerosol extinction.
!     This subroutine is called from tropchem_driver. Aerosol extinction in
!     band 4 (centered at 1um) is saved as a diagnostic tracer in swresf.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call strat_chem_get_aerosol (extinct, aerosol)
!   </TEMPLATE>
!   <IN NAME="extinct" TYPE="real" DIM="(:,:,:)">
!     Aerosol extinction for band 4 centered at 1 um (in units of 1/m)
!   </IN>
!   <OUT NAME="aerosol" TYPE="real" DIM="(:,:,:)">
!     Volcanic aerosol surface area (cm2/cm3)
!   </OUT>


subroutine strat_chem_get_aerosol( extinct, aerosol )

implicit none

! dummy arguments

real, dimension(:,:,:), intent(in)  :: extinct
real, dimension(:,:,:), intent(out) :: aerosol

! local variables

real, dimension(size(extinct,1),size(extinct,2)) :: extinct_local
integer :: k

do k = 1,size(extinct,3)

   extinct_local(:,:) = extinct(:,:,k) * 1.e3 ! convert to 1/km
   where( extinct_local(:,:) <= 0. )
      aerosol(:,:,k) = 0.
   elsewhere( extinct_local(:,:) <= 4.e-3 )
      aerosol(:,:,k) = 4.25e-6 * extinct_local(:,:)**0.68
   elsewhere( extinct_local(:,:) <= 2.e-2 )
      aerosol(:,:,k) = 1.223e-5 * extinct_local(:,:)**0.875
   elsewhere
      aerosol(:,:,k) = 2.e-5 * extinct_local(:,:)
   end where

end do

end subroutine strat_chem_get_aerosol


! <SUBROUTINE NAME="strat_chem_get_h2so4">
!   <OVERVIEW>
!     Set stratospheric H2SO4
!   </OVERVIEW>
!   <DESCRIPTION>
!     Set stratospheric H2SO4 as an analytical function of age, peaking at 0.5 ppbv
!   </DESCRIPTION>
!   <TEMPLATE>
!     call strat_chem_get_h2so4( press, age, h2so4 )
!   </TEMPLATE>
!   <IN NAME="press" TYPE="real" DIM="(:,:)">
!     Pressure on model full levels (Pa)
!   </IN>
!   <IN NAME="age" TYPE="real" DIM="(:,:)">
!     Age-of-air tracer (yrs)
!   </IN>
!   <OUT NAME="h2so4" TYPE="real" DIM="(:,:)">
!     Sulfuric acid (H2SO4) VMR (mol/mol)
!   </OUT>
subroutine strat_chem_get_h2so4(press, age, h2so4)

implicit none

! Dummy arguments

real, dimension(:,:), intent(in)  :: press, age
real, dimension(:,:), intent(out) :: h2so4

! Local variables

integer :: i, k, il, kl
real :: x1, x2


il = size(press,1)
kl = size(press,2)

do k = 1,kl
   do i=1,il

        x1 = 3.*(log10(press(i,k)) - 3.5)**2
        x2 = 3./(10.*age(i,k) + 1.) * (age(i,k) - 1.)**2
        h2so4(i,k) = (0.01 + 0.49*exp(-x1-x2))*1.e-9

   end do
end do

end subroutine strat_chem_get_h2so4



! <SUBROUTINE NAME="strat_chem_get_psc">
!   <OVERVIEW>
!     Set up stratospheric PSCs
!   </OVERVIEW>
!   <DESCRIPTION>
!     Set up stratospheric PSCs
!   </DESCRIPTION>
!   <TEMPLATE>
!     call strat_chem_get_psc( temp, press, hno3, h2o, h2so4, strat_aerosol, psc, psv_vmr_out )
!   </TEMPLATE>
!   <IN NAME="temp" TYPE="real" DIM="(:,:)">
!     Temperature (K)
!   </IN>
!   <IN NAME="press" TYPE="real" DIM="(:,:)">
!     Pressure on model full levels (Pa)
!   </IN>
!   <INOUT NAME="hno3" TYPE="real" DIM="(:,:)">
!     Nitric acid (HNO3) VMR (mol/mol)
!   </INOUT>
!   <INOUT NAME="h2o" TYPE="real" DIM="(:,:)">
!     Water (H2O) VMR (mol/mol)
!   </INOUT>
!   <IN NAME="h2so4" TYPE="real" DIM="(:,:)">
!     Sulfuric acid (H2SO4) VMR (mol/mol)
!   </IN>
!   <IN NAME="strat_aerosol" TYPE="real" DIM="(:,:)">
!     Stratospheric aerosol (liquid)
!   </IN>
!   <OUT NAME="psc" TYPE="psc_type">
!     PSC properties
!   </OUT>
!   <OUT NAME="psc_vmr_out" TYPE="real" DIM="(:,:)" OPTIONAL>
!     PSC VMR (mol/mol)
!   </OUT>

subroutine strat_chem_get_psc( temp, press, hno3, h2o, h2so4, strat_aerosol, psc, psc_vmr_out )

implicit none

! Dummy arguments

real, dimension(:,:), intent(in)    :: temp, press, h2so4, strat_aerosol
real, dimension(:,:), intent(inout) :: hno3, h2o
type(psc_type),       intent(out)   :: psc
real, dimension(:,:,:), intent(out), optional :: psc_vmr_out

! Local variables
integer :: il, kl, i, k
real :: rho(size(temp,1)), &
        DENS(size(temp,1)), &
        VHET(size(temp,1),4), &
        WF(size(temp,1),2)
real :: PH2O, &                    ! H2O partial pressure (atm)
        TSAT,ABT,AMT,BMT,PX,C2, &
        A1,A2,A3,A4,C3,P0H2O,Y1,Y2,T1,RMODE,RMODESAT,SANAT
!----------------------------------------------------------------------------
!
! AVGDR IS THE RECIPROCAL OF THE AVOGADRO CONSTANT
! RR IS THE GAS CONSTANT
!
!----------------------------------------------------------------------------
real, parameter :: AVGDR = 1/AVOGNO, &
                   RR = 8.3144
!----------------------------------------------------------------------------
!
!   ADROP, ANAT AND AICE ARE THE (FIXED) NUMBER OF DROPS OR PARTICLES PER CC
!   IN THE POLAR STRATOSPHERC CLOUDS. A LOG NORMAL SIZE DISTRIBUTION IS ASSUMED
!   WITH SIGMA = 1.8 GIVING LOG(SIGMA)**2 = 0.3455
!
!----------------------------------------------------------------------------
real, parameter :: SIGMAL=0.34549316


real, parameter ::  boltz = 1.38044e-16      ! erg/K


il = size(temp,1)
kl = size(temp,2)

allocate( psc%cond(il,kl,3), &
          psc%tice(il,kl), psc%wh2so4(il,kl), psc%am(il,kl), &
          psc%aw(il,kl), psc%aliq(il,kl), psc%rmean(il,kl), &
          psc%asat(il,kl), psc%rnat(il,kl), psc%rice(il,kl) )

!
!----------------------------------------------------------------------------
!
! COMPUTE SOLID CONDENSED MATTER: COND(IL,1:3) -- SAT, NAT, ICE
!
!----------------------------------------------------------------------------
psc%cond(:,:,1:3) = 0.
psc%adrop = 10.
psc%anat  = 10.
psc%aice  = 10.

do k = 1,kl
   do i=1,il
      rho(i) = 10. * press(i,k) / (boltz * temp(i,k))  ! molec/cm3
      PH2O = h2o(i,k)*press(i,k)/PSTD_MKS
      TSAT = 3236.0 / (11.502 - LOG10(PH2O*760.0))
      IF(temp(i,k) < TSAT) psc%cond(i,k,1) = h2so4(i,k)

      ABT = 39.1104 - 11397.0/temp(i,k) + 9.179E-3*temp(i,k)
      AMT = -2.7836 - 8.8E-4*temp(i,k)
      BMT = -2.1249 + LOG10(PH2O*PSTD_MKS)
      PX = AMT*BMT + ABT
      C2 = hno3(i,k) - 100./press(i,k) * 10.**PX
      IF(C2 > 0.) psc%cond(i,k,2) = C2

      psc%tice(i,k) = 2668.70/(10.4310 - LOG10(760.0*PH2O))
      A1 = 7.5502 - 2668.7/temp(i,k)
      C3 = h2o(i,k) - PSTD_MKS/press(i,k) * 10.**A1
!     C4 = PSTD_MKS/press(i,k) * 10.**A1
      IF(C3 > 0.) psc%cond(i,k,3) = C3

      hno3(i,k) = hno3(i,k) - psc%cond(i,k,2)
!     DYY(i,k,15) = DYY(i,k,15) - psc%cond(i,k,2)
!     CLIMIT = rho(i)*1. E-15
!     DYY(i,k,15) = MAX(DYY(i,k,15),CLIMIT)
      h2o(i,k) = h2o(i,k) - psc%cond(i,k,3)
   end do
!-------------------------------------------------------------------------
!
!  COMPUTE WEIGHT % H2SO4. FROM TABAZADEH ET AL., GRL, 24, 1931-1934, 1997.
!  TABLE A1 OF SHIA ET AL. JGR, 106, 24,529-24,274, 2001
!
!-------------------------------------------------------------------------
   do i = 1,IL
! Saturation water vapor pressure (in mbar)
      P0H2O = EXP(18.452406985 - 3505.1578807/temp(i,k) - &
         330918.55082/temp(i,k)**2 + 12725068.262/temp(i,k)**3)
! Water activity
      psc%aw(i,k) = h2o(i,k)*press(i,k)*0.01/P0H2O
!++lwh
      psc%aw(i,k) = MAX( MIN(psc%aw(i,k), 1.), 0.01 )
!--lwh
      IF (psc%aw(i,k) <= 0.05) THEN
         Y1 = 12.37208932*psc%aw(i,k)**(-0.16125516114) - 30.490657554*psc%aw(i,k) - 2.1133114241
         Y2 = 13.455394705*psc%aw(i,k)**(-0.1921312255) - 34.285174607*psc%aw(i,k) - 1.7620073078
      ELSEIF(psc%aw(i,k) < 0.85) THEN
         Y1 = 11.820654354*psc%aw(i,k)**(-0.20786404244) - 4.807306373*psc%aw(i,k) -  5.1727540348
         Y2 = 12.891938068*psc%aw(i,k)**(-0.23233847708) - 6.4261237757*psc%aw(i,k) - 4.9005471319
      ELSE
         Y1 = -180.06541028*psc%aw(i,k)**(-0.38601102592) - 93.317846778*psc%aw(i,k) + 273.88132245
         Y2 = -176.95814097*psc%aw(i,k)**(-0.36257048154) - 90.469744201*psc%aw(i,k) + 267.45509988
      ENDIF
! Sulfuric acid molality
!++lwh
!     psc%am(i,k) = Y1 + (temp(i,k) - 190.)*(Y2 - Y1)/70.
      psc%am(i,k) = (temp(i,k) - 190.)/70.
      psc%am(i,k) = MAX( MIN(psc%am(i,k), 1.), 0. )
      psc%am(i,k) = Y1 + psc%am(i,k)*(Y2 - Y1)
!--lwh
! Sulfuric acid weight percent
      psc%wh2so4(i,k) = 9800.*psc%am(i,k)/(98.*psc%am(i,k) + 1000.)
      WF(i,1) = 0.01*psc%wh2so4(i,k)
      WF(i,2) = 0.0
   end do
!---------------------------------------------------------------------------
!
!  COMPUTE DENSITY OF BINARY AEROSOL
!
!---------------------------------------------------------------------------
   CALL DENSITY(WF,temp(:,k),DENS)
!---------------------------------------------------------------------------
!
!  COMPUTE VOLUME OF BINARY AEROSOL/SAT/NAT/ICE
!  1.6, 1.35 and 0.928  are the densities of SAT, NAT and ICE
!
!---------------------------------------------------------------------------
   do i=1,IL
     T1 = h2so4(i,k)*press(i,k)/(rho(i)*temp(i,k)*RR)
     VHET(i,1) = T1*98.076E-6/(WF(i,1)*DENS(I))
     VHET(i,2) = psc%cond(i,k,1)*rho(i)*170.1*AVGDR/1.6
     VHET(i,3) = psc%cond(i,k,2)*rho(i)*117.1*AVGDR/1.35
     VHET(i,4) = psc%cond(i,k,3)*rho(i)*18.02*AVGDR/0.928
   end do
!---------------------------------------------------------------------------
!
!  COMPUTE PARTICLE PARAMETERS FROM WHICH THE HETEROGENEOUS REACTION RATES
!  ARE DETERMINED; ASSUME SURFACE AREA FROM SAT IS LIMITED BY NAT AMOUNT
!
!---------------------------------------------------------------------------
   A1 = EXP(-4.5*SIGMAL)
   A2 = EXP(0.5*SIGMAL)
   A3 = EXP(2.0*SIGMAL)
   A4 = 1.33333333*PI*psc%adrop
   do i=1,IL
     RMODE = (VHET(i,1)*A1/A4)**0.33333333
     psc%rmean(i,k) = MAX(RMODE*A2, 1.e-12)
!    psc%aliq(i,k) = 3.0*A4*(RMODE**2)*A3
     psc%aliq(i,k) = strat_aerosol(i,k)
     RMODESAT = (VHET(i,2)*A1/A4)**0.33333333
     psc%asat(i,k) = 3.0*A4*(RMODESAT**2)*A3
     psc%rnat(i,k) = (VHET(i,3)/(1.33333333*PI*psc%anat))**0.33333333
     psc%rice(i,k) = (VHET(i,4)/(1.33333333*PI*psc%aice))**0.33333333
     SANAT = 4.*PI * psc%anat * psc%rnat(i,k)**2
     psc%asat(i,k) = MAX(psc%asat(i,k) - SANAT, 0.)
!    psc%aliq(i,k) = MAX(psc%aliq(i,k) - SANAT, 0.)
   end do
end do

if (present(psc_vmr_out)) then
   psc_vmr_out(:,:,:) = psc%cond(:,:,:)
end if

end subroutine strat_chem_get_psc


subroutine strat_chem_destroy_psc( psc )

implicit none

! Dummy arguments

type(psc_type),   intent(inout)   :: psc


deallocate( psc%cond, psc%tice, psc%wh2so4, psc%am, &
            psc%aw, psc%aliq, psc%rmean, &
            psc%asat, psc%rnat, psc%rice )

end subroutine strat_chem_destroy_psc


subroutine strat_chem_get_gamma(temp, press, rho, hcl, clono2, psc, k, gamma)
!-------------------------------------------------------------------------
!
! SUBROUTINE TO CALCULATE REACTION PROBABILITIES ON SULPHATE AEROSOL
! BASED ON JPL'03 RECOMMENDATION
!
!-------------------------------------------------------------------------
IMPLICIT NONE


! dummy arguments
REAL, dimension(:),   intent(in)  :: temp, press, rho, hcl, clono2
type(psc_type),       intent(in)  :: psc
integer,              intent(in)  :: k
REAL, dimension(:,:), intent(out) :: gamma

! local variables

integer :: i,il
REAL, dimension(size(temp,1)) :: AMH2SO4, XH2SO4, VISC, AACID, TEMP2, RTT
REAL :: T2,Z1,Z2,Z3,RHOX,AA,X,T1,T3,AKH,AKH2O,AKHYDR,DIFF,SCLONO2, &
        CCLONO2,GAMMAB1,HHCL,AKHCL,Q1,RQ,A1,FCLONO2,GAMMARXN,      &
        GAMMABHCL,GAMMAS,FHCL,GAMMASP,GAMMABHCLP,GAMMAB,GCLONO2,   &
        SHOCL,HHOCL,FHOCL,WT,AK0,AK1,AK2,T0,HCLONO2,   &
        AMHCL,AKHOCL,CHOCL

!  The parameterisations used here break down below about 185K, so the
!  temperature is here limited to 185K and above (TEMP2).

   il = size(temp,1)

!-------------------------------------------------------------------------
!
! CALCULATE H2SO4 MOLARITY (AMH2SO4), MOLE FRACTION (XH2SO4),
!  VISCOSITY (VISC) AND ACID ACTIVITY (AACID)
!  TABLE A2 OF SHIA ET AL. JGR, 106, 24,529-24,274, 2001.
!
!-------------------------------------------------------------------------
   TEMP2(:) = MAX(temp(:),185.)
   RTT(:) = SQRT(temp(:))

long_loop: &
   do i = 1,il
      T2 = TEMP2(I)**2
      Z1 = 0.12364 - 5.6E-7*T2
      Z2 = -0.02954 + 1.814E-7*T2
      Z3 = 2.343E-3 - 1.487E-6*TEMP2(I) - 1.324E-8*T2
      RHOX = 1.0 + Z1*psc%am(i,k) + Z2*psc%am(i,k)**1.5 + Z3*psc%am(i,k)**2
      AMH2SO4(I) = RHOX*psc%wh2so4(i,k)/9.8
      XH2SO4(I) = psc%wh2so4(i,k)/(psc%wh2so4(i,k) + (100.0 - psc%wh2so4(i,k))*98.0/18.0)
      AA = 169.5 + 5.18*psc%wh2so4(i,k) - 0.0825*psc%wh2so4(i,k)**2 + 3.27E-3*psc%wh2so4(i,k)**3
      T0 = 144.11 + 0.166*psc%wh2so4(i,k) - 0.015*psc%wh2so4(i,k)**2 + 2.18E-4*psc%wh2so4(i,k)**3
      X = TEMP2(I)**(-1.43)
      VISC(I) = AA*X*EXP(448.0/(TEMP2(I) - T0))
      T1 = 60.51 - 0.095*psc%wh2so4(i,k) + 0.0077*psc%wh2so4(i,k)**2 - 1.61E-5*psc%wh2so4(i,k)**3
      T2 =  (-805.89 + 253.05*psc%wh2so4(i,k)**0.076)/RTT(I)
      T3 =   (1.76 + 2.52E-4*psc%wh2so4(i,k)**2)*RTT(I)
      AACID(I) = EXP(T1 + T2 - T3)
!-------------------------------------------------------------------------
!
!  CALCULATE REACTION PROBABILITES FOR CLONO2 + H2O AND CLONO2 + HCL AND
!  HENRY'S LAW COEFFICIENTS.
!  TABLE A3 OF SHIA ET AL. JGR, 106, 24,529-24,274, 2001.
!
!  The following formulation for the water activity is from Shi et al.,
!  but the differences between their parameterisation and that calculated
!  using the actual model H2O is not large.
!
!      awx = exp((-69.775*xh2so4(il) - 18253.7*xh2so4(il)**2 +   &
!           31072.2*xh2so4(il)**3 - 25668.8*xh2so4(il)**4)*      &
!           (1.0/temp(il) - 26.9033/(temp(il)**2)))
!      AKHYDR = AWx*(AKH2O + AKH*AACID(IL))
!
!-------------------------------------------------------------------------
      AKH = 1.22E12*EXP(-6200.0/TEMP2(I))
      AKH2O = 1.95E10*EXP(-2800.0/TEMP2(I))
      AKHYDR = psc%aw(i,k)*(AKH2O + AKH*AACID(I))
      DIFF = 5.0E-8*TEMP2(I)/VISC(I)
      SCLONO2 = 0.306 + 24.0/TEMP2(I)
      HCLONO2 = 1.6E-6*EXP(4710.0/TEMP2(I) - SCLONO2*AMH2SO4(I))
      CCLONO2 = 1474.*TEMP2(I)**0.5
      GAMMAB1 = (4.0*HCLONO2*0.082*TEMP2(I)/CCLONO2) * (DIFF*AKHYDR)**0.5

      HHCL = (0.094 - 0.61*XH2SO4(I) + 1.2*XH2SO4(I)**2)* &
         EXP(-8.68 + (8515. - 10718.*XH2SO4(I)**0.7)/TEMP2(I))
      AMHCL = HHCL*hcl(i)*press(I)/PSTD_MKS
      AKHCL = 7.9E11*AACID(I)*DIFF*AMHCL
      Q1 = (DIFF/(AKHYDR + AKHCL))**0.5
      RQ = psc%rmean(i,k)/Q1
      A1 = RQ + 0.312*RQ**2
      FCLONO2 = A1/(3.0 + A1)
      GAMMARXN = FCLONO2*GAMMAB1*(1.0 + AKHCL/AKHYDR)**0.5
      GAMMABHCL = GAMMARXN*AKHCL/(AKHCL + AKHYDR)
      GAMMAS = 66.12* EXP(-1374./TEMP2(I))*HCLONO2*AMHCL
      IF( hcl(i) /= 0. ) THEN
       FHCL = 1.0/(1.0 + 0.612*(GAMMAS + GAMMABHCL)*clono2(i)/hcl(i))
      ELSE
       FHCL = 0.0
      ENDIF
      GAMMASP = FHCL*GAMMAS
      GAMMABHCLP = FHCL*GAMMABHCL
      GAMMAB = GAMMABHCLP + GAMMARXN*AKHYDR/(AKHCL + AKHYDR)
      GCLONO2 = 1.0/(1.0 + 1.0/(GAMMASP + GAMMAB))
      gamma(i,5) = GCLONO2*(GAMMASP + GAMMABHCLP) / (GAMMASP + GAMMAB)
      gamma(i,4) = GCLONO2 - gamma(i,5)

!-------------------------------------------------------------------------
!
!  CALCULATE REACTION PROBABILITES FOR HOCL + HCL AND HENRY'S LAW COEFFICIENTS.
!  TABLE A4 OF SHIA ET AL. JGR, 106, 24,529-24,274, 2001.
!
!-------------------------------------------------------------------------
      SHOCL = 0.0776 + 59.18/TEMP2(I)
      HHOCL = 1.91E-6*EXP(5862.4/TEMP2(I) - SHOCL*AMH2SO4(I))
      DIFF = 6.4E-8 *TEMP2(I)/VISC(I)
      AKHOCL = 1.25E9*AACID(I)*DIFF*AMHCL
      CHOCL = 2009.*RTT(I)
      Q1 = (DIFF/AKHOCL)**0.5
      RQ = psc%rmean(i,k)/Q1
      A1 = RQ + 0.312*RQ**2
      FHOCL = A1/(3.0 + A1)
      GAMMARXN = (FHOCL*4.0*HHOCL*0.082*TEMP2(I)/CHOCL) * (DIFF*AKHOCL)**0.5
      gamma(i,1) = 1.0/(1.0 + 1.0/(GAMMARXN*FHCL))

!-------------------------------------------------------------------------
!
!  CALCULATE REACTION PROBABILITES FOR N2O5 + H2O
!  ROBINSON ET AL. JGR, 102, 3583-3601, 1997.
!
!-------------------------------------------------------------------------
      WT = MIN( psc%wh2so4(i,k), 80. )
      AK0 = -25.5265 - 0.133188*WT + 0.00930846*WT**2 - 9.0194E-5*WT**3
      AK1 = 9283.76 + 115.345*WT - 5.19258*WT**2 + 0.0483464*WT**3
      AK2 = -851801. - 22191.2*WT + 766.916*WT**2 - 6.85427*WT**3
      gamma(i,3) = EXP(AK0 + AK1/TEMP2(I) + AK2/(TEMP2(I)**2))
   end do long_loop

!-------------------------------------------------------------------------
!
!  REACTION PROBABILITES FOR
!       N2O5 + HCL
!       HOBR + HCL
!       HOCL + HBR
!  NO RECOMMENDATION IN JPL '03, ASSUMED ZERO
!
!-------------------------------------------------------------------------
   gamma(:,2) = 0.
   gamma(:,6) = 0.
   gamma(:,7) = 0.

!-------------------------------------------------------------------------
!
!  REACTION PROBABILITES FOR HOBR + HBR
!  ABBATT, JGR, 100, 14009-14017, 1995.
!
!-------------------------------------------------------------------------
   gamma(:,8) = 0.25

!-------------------------------------------------------------------------
!
!  REACTION PROBABILITES FOR BRONO2 + H2O
!  USE JPL '03 RECOMMENDATION (HANSON PERS. COMM.)
!
!-------------------------------------------------------------------------
   gamma(:,9) = 1.0/(1.2422 + 1.0/(0.114 + EXP(29.24 - 0.396*psc%wh2so4(:,k))))

end subroutine strat_chem_get_gamma

subroutine strat_chem_get_hetrates( temp, hcl, hbr, h2o, rho, psc, gamma, k, tstep, rates )

implicit none
!------------------------------------------------------------------------
!
!  This subroutine computes the equivalent 2nd order reaction rates for
!  the heterogeneous reactions on aerosol, nat and ice.
!
!------------------------------------------------------------------------


! dummy arguments

INTEGER,              intent(in)  :: k
REAL, dimension(:),   intent(in)  :: temp, &   ! temperature (K)
                                     hcl, &    ! HCl volume mixing ratio (VMR)
                                     hbr, &    ! HBr VMR
                                     h2o, &    ! water vapor VMR
                                     rho       ! atmospheric density (molec/cm3)
REAL, dimension(:,:), intent(in)  :: gamma     ! reaction probabilities
type(psc_type),       intent(in)  :: psc       ! polar stratospheric clouds (PSCs)
real,                 intent(in) ::  tstep     ! timestep (sec)
REAL, dimension(:,:), intent(out) :: rates     ! heterogeneous reaction rate constants (molec^-1 cm^3 s^-1)

! local variables

integer, parameter :: nhet_data = 9
INTEGER :: i, ic, IL, NHET
REAL, dimension(size(temp)) :: CHEMC, &        ! chemical species number density (molec/cm3)
                               G2NAT, &        ! reaction probabilities on NAT
                               DELT, &         ! temperature excess over ice saturation (K)
                               SICE, &         ! 
                               RTT, &
                               VEL1, &
                               VEL2
REAL :: VCONST, ANUM, ADEN, MW2, area, afac1, adsorb_frac

real, dimension(nhet_data), parameter :: &
         AMW = (/ 52.45, 108.00, 108.00, 97.45, 97.45, 96.91, 52.45, 96.91, 141.91 /), &
!------------------------------------------------------------------------
!  AMW = MOLECULAR WEIGHT OF GAS PHASE SPECIES
!------------------------------------------------------------------------
         GNAT = (/0.1, 3.0E-3, 4.0E-4, 4.0E-3, 0.2, 0.0, 0.0, 0.0, 0.0 /), &
         GICE = (/0.2, 0.03, 0.02, 0.3, 0.3, 0.3, 0.03, 0.1, 0.3 /)
integer, parameter :: &
         HET_H2O=0, HET_HCL=1, HET_HBR=2
integer, dimension(nhet_data), parameter :: &
         INN = (/ HET_HCL,HET_HCL,HET_H2O,HET_H2O,HET_HCL,HET_HCL,HET_HBR,HET_HBR,HET_H2O /)
real, parameter :: small_conc = 1.e-20, &
                   mw_hcl = 36.46, &
                   mw_hbr = 80.91, &
                   mw_h2o = 18.01, &
                   adsorb_sites = 1.e15 ! adsorption sites per cm^2
!------------------------------------------------------------------------
!  INN = INDEX NUMBER OF LIQUID/SOLID PHASE SPECIES (0= H2O)
!-------------------------------------------------------------------------
!     REACTION 70 HOCL + HCL --> H2O + CL2 (HETEROGENEOUS)
!     REACTION 71 N2O5 + HCL --> HNO3 + CLNO2 (HETEROGENEOUS)
!     REACTION 72 N2O5+H2O --> 2HNO3 (HETEROGENEOUS)
!     REACTION 73 CLONO2+H2O --> HOCL+HNO3 (HETEROGENEOUS)
!     REACTION 74 CLONO2+HCL --> CL2+HNO3 (HETEROGENEOUS)
!     REACTION 75 HOBR + HCL --> BRCL + H2O (HETEROGENEOUS)
!     REACTION 76 HOCL + HBR --> BRCL + H2O (HETEROGENEOUS)
!     REACTION 77 HOBR + HBR --> 2BR + H2O (HETEROGENEOUS)
!     REACTION 78 BRONO2 + H2O --> HOBR + HNO3 (HETEROGENEOUS)
!     (THE FIRST MOLECULE ON THE LEFT HAND SIDE IS IN THE GAS PHASE,
!     THE SECOND MOLECULE IS IN THE LIQUID/SOLID PHASE)
!-------------------------------------------------------------------------
   IL = size(temp)
   NHET = size(gamma,2)

   RTT(:) = sqrt(temp(:))
   DELT(:) = temp(:) - psc%tice(:,k)
   SICE(:) = 10**(2668.70*(1.0/temp(:) - 1.0/psc%tice(:,k)))
   SICE(:) = MIN( SICE(:), 3. )

   do ic = 1,NHET
      VCONST = sqrt(8.0*8.3144E7/(PI*AMW(ic)))
      select case (ic)
         case(4)
            G2NAT(:) = EXP(-9.03 + 2.81*SICE(:))
         case(5)
            G2NAT(:) = 1.0/(4.3478 + 1.4241*EXP(0.518*DELT(:)))
         case default
            G2NAT(:) = GNAT(ic)
      end select
      select case (INN(ic))
         case(HET_H2O)
            CHEMC(:) = h2o(:)*rho(:)
            mw2 = mw_h2o
         case(HET_HCL)
            CHEMC(:) = hcl(:)*rho(:)
            mw2 = mw_hcl
         case(HET_HBR)
            CHEMC(:) = hbr(:)*rho(:)
            mw2 = mw_hbr
      end select
      VEL1(:) = VCONST * RTT(:)
      VEL2(:) = sqrt(8.*8.3144E7/(pi*mw2)) * RTT(:)
      rates(:,ic) =  0.

      select case (INN(ic))
         case(HET_H2O)

            do i=1,IL
               ADEN = CHEMC(i)
               if (ADEN > small_conc) then
!-------------------------------------------------------------------------
!    Reactions on NAT
!-------------------------------------------------------------------------
                  area = 4.*PI * psc%anat * psc%rnat(i,k)**2
                  ANUM = 0.25*VEL1(i)*G2NAT(i) * area
                  IF(ANUM > 0.) rates(i,ic) =  ANUM/ADEN
!-------------------------------------------------------------------------
!    Reactions on ICE
!------------------------------------------------------------------------
                  area = 4.*PI * psc%aice * psc%rice(i,k)**2
                  ANUM = 0.25*VEL1(i)*GICE(ic) * area
                  IF(ANUM > 0.) rates(i,ic) = rates(i,ic) + ANUM/ADEN
!-------------------------------------------------------------------------
!    Reactions on LIQUID AEROSOL
!    aliq is the liquid surface area. const is sqrt(8R/(pi*mw)) for the
!    gaseous phase species, with the mean molecular speed equal to
!        const*sqrt(temp)
!-------------------------------------------------------------------------
                  ANUM = 0.25*VEL1(i)*gamma(i,ic) * psc%aliq(i,k)
                  if (ANUM > 0.) rates(i,ic) = rates(i,ic) + ANUM / ADEN
               end if
            end do

         case(HET_HCL,HET_HBR)

            do i=1,IL
!-------------------------------------------------------------------------
!    Reactions on NAT
!-------------------------------------------------------------------------
               area = 4.*PI * psc%anat * psc%rnat(i,k)**2
               ANUM = 0.25*VEL1(i)*G2NAT(i)
               if (ANUM>0. .and. area>0.) then
                  afac1 = 0.25*VEL2(i)*tstep*area
!                 adsorb_frac = MIN(0.5*afac1, 1.)
                  adsorb_frac = 1. - (1./afac1)*(1.-exp(-afac1))
                  rates(i,ic) =  ANUM*adsorb_frac/adsorb_sites
               end if
!-------------------------------------------------------------------------
!    Reactions on ICE
!------------------------------------------------------------------------
               area = 4.*PI * psc%aice * psc%rice(i,k)**2
               ANUM = 0.25*VEL1(i)*GICE(ic)
               if(ANUM>0. .and. area>0.) then
                  afac1 = 0.25*VEL2(i)*tstep*area
!                 adsorb_frac = MIN(0.5*afac1, 1.)
                  adsorb_frac = 1. - (1./afac1)*(1.-exp(-afac1))
                  rates(i,ic) = rates(i,ic) + ANUM*adsorb_frac/adsorb_sites
               end if
!-------------------------------------------------------------------------
!    Reactions on LIQUID AEROSOL
!    aliq is the liquid surface area. const is sqrt(8R/(pi*mw)) for the
!    gaseous phase species, with the mean molecular speed equal to
!        const*sqrt(temp)
!-------------------------------------------------------------------------
               area = psc%aliq(i,k)
               ANUM = 0.25*VEL1(i)*gamma(i,ic)
               if(ANUM>0. .and. area>0.) then
                  afac1 = 0.25*VEL2(i)*tstep*area
!                 adsorb_frac = MIN(0.5*afac1, 1.)
                  adsorb_frac = 1. - (1./afac1)*(1.-exp(-afac1))
                  rates(i,ic) = rates(i,ic) + ANUM*adsorb_frac/adsorb_sites
               end if
            end do

      end select

   end do

end subroutine strat_chem_get_hetrates


subroutine DENSITY(WF,T,DENS)
implicit none
!
!    Density of ternary solution in g cm-3
!

! dummy arguments
REAL, intent(in)  :: WF(:,:),T(:)
REAL, intent(out) :: DENS(:)

! local variables
INTEGER :: I
REAL :: W,WH,T2,V1,A1,A2,VS,VN,VMCAL

real, parameter :: &
       X(22) = (/ 2.393284E-02,-4.359335E-05,7.961181E-08,0.0,-0.198716351, &
                  1.39564574E-03,-2.020633E-06,0.51684706,-3.0539E-03,      &
                  4.505475E-06,-0.30119511,1.840408E-03,-2.7221253742E-06,  &
                 -0.11331674116,8.47763E-04,-1.22336185E-06,0.3455282,      &
                 -2.2111E-03,3.503768245E-06,-0.2315332,1.60074E-03,        &
                 -2.5827835E-06 /), &
       AMR(3) = (/ 0.05550622,0.01019576,0.01586899 /)

   DO I = 1,SIZE(T)
      W = WF(I,1) + WF(I,2)
      WH = 1.0 - W
      T2 = T(I)**2
      V1 = X(1) + X(2)*T(I) + X(3)*T2 + X(4)*T2*T(I)
      A1 = X(8) + X(9)*T(I) + X(10)*T2
      A2 = X(11) + X(12)*T(I) + X(13)*T2
      VS = X(5) + X(6)*T(I) + X(7)*T2 + A1*W + A2*W**2
      A1 = X(17) + X(18)*T(I) + X(19)*T2
      A2 = X(20) + X(21)*T(I) + X(22)*T2
      VN = X(14) + X(15)*T(I) + X(16)*T2 + A1*W + A2*W**2
      VMCAL = WH*V1*AMR(1) + VS*WF(I,1)*AMR(2) + VN*WF(I,2)*AMR(3)
      DENS(I) = 1.0E-3/VMCAL
   END DO

end subroutine DENSITY


subroutine strat_chem_psc_sediment( psc, pfull, dt, dpsc )      

implicit none
!------------------------------------------------------------------------
!
!  This subroutine calculates sedimentation rates of Type I and Type II
!  particles and vertically advects model NAT and ice
!
!------------------------------------------------------------------------


! dummy arguments
!
!  CALCULATES SEDIMENTATION RATES OF TYPE I AND TYPE 2 PARTICLES               
!  AND VERTICALLY ADVECTS MODEL NAT AND ICE                                    
!
REAL, dimension(:,:,:),   intent(in)  :: pfull
REAL, dimension(:,:,:,:), intent(in)  :: psc
REAL,                     intent(in)  :: dt
REAL, dimension(:,:,:,:), intent(out) :: dpsc

! local variables

real, dimension(SIZE(pfull,3)) :: ANAT, AICE, SNATS, SICES, F1, F2, ANAT2, AICE2
real :: PNAT,PICE,PNAT2,PICE2
real :: ANATMAX,AICEMAX
integer :: i, j, k, il, jl, kl
real :: temp, pfrac, dz, const, d1, d2, FIXNAT, FIXICE
!                                                                              
!  V1 = SEDIMENTATION VELOCITY (M/S) OF ICE PARTICLES
!  V2 = SEDIMENTATION VELOCITY OF NAT PARTICLES
!  R1, R2 = ASSUMED RADII
!  AM1, AM2 = MOLECULAR WEIGHTS
!  RHO1, RHO2 = DENSITIES OF THE PSCs (G/CM3)
!                                                                              
real, parameter :: V1=1.27E-2, V2=1.39E-4
real, parameter :: R1=7.0E-6, R2=0.5E-6
real, parameter :: AM1=18.0, AM2=117.0
real, parameter :: RHO1=0.928, RHO2=1.35
real, parameter :: RATIO = AM1*RHO2/(AM2*RHO1)*(R2/R1)**3

il = SIZE(pfull,1)
jl = SIZE(pfull,2)
kl = SIZE(pfull,3)

!                                                                              
!  CALCULATE FRACTION OF NAT PARTICLES USED AS TYPE 2 CORES (F1)               
!  AND FRACTION OF NAT PARTICLES THAT REMAIN AS TYPE 1 CORES (F2)              
!  DETERMINE MAXIMUM NAT AND ICE TO APPLY LIMITERS TO ADVECTED AMOUNTS
!                                                                              
Lat_loop : &
   DO j = 1,jl 
Lon_loop : &
   DO i = 1,il 
      ANAT(:) = psc(i,j,:,2)
      AICE(:) = psc(i,j,:,3)
      where(AICE(:) < 1.0E-18)
         AICE(:) = 0.
      end where
      where(ANAT(:) < 1.0E-18)
         ANAT(:) = 0.
         F1(:) = 0.
         F2(:) = 0.
      elsewhere
         F1(:) = AICE(:)*RATIO/ANAT(:)
         F1(:) = MIN(1.,F1(:))
         F2(:) = 1.0 - F1(:)
      end where
      ANATMAX = maxval(ANAT(:))
      AICEMAX = maxval(AICE(:))
!
! VERTICALLY ADVECT NAT AND ICE. NOTE THAT PART OF NAT IS ADVECTED
! AT TYPE 2 RATE AND THE REMAINDER AT TYPE 1 RATE. CALCULATE DESCENT IN
!  1 TIMESTEP; USE APPROXIMATE VERTICAL DISPLACEMENT BETWEEN LAYERS
!
      TEMP = 195.
      PNAT = 0.
      PICE = 0.
      DO k = 2,kl
         PFRAC = pfull(i,j,k)/pfull(i,j,k-1)
         DZ = 29.26*TEMP*LOG(PFRAC)
         CONST = dt/DZ                                              
         D1 = ANAT(k) - ANAT(k-1)
         D2 = AICE(k) - AICE(k-1)         
         SNATS(k) = -CONST*D1*(V1*F1(k) + V2*F2(k))
         SICES(k) = -CONST*D2*V1
         PNAT = PNAT + pfull(i,j,k)*ANAT(k)
         PICE = PICE + pfull(i,j,k)*AICE(k)
      END DO
!
!  set sedimented nat and ice to zero at top and bottom
!
      SNATS(1) = 0.0
      SICES(1) = 0.0 
      SNATS(kl) = 0.0
      SICES(kl) = 0.0
      ANAT2(:) = ANAT(:) + SNATS(:)
      AICE2(:) = AICE(:) + SICES(:)
!
!  APPLY LIMITERS TO NEW NAT AND ICE
!
      ANAT2(:) = MAX( MIN(ANAT2(:),ANATMAX), 0. )
      AICE2(:) = MAX( MIN(AICE2(:),AICEMAX), 0. )
!
! APPLY MASS FIXER
!
      PNAT2 = 0.0
      PICE2 = 0.0
      DO k = 1,kl
         PNAT2 = PNAT2 + pfull(i,j,k)*ANAT2(k)
         PICE2 = PICE2 + pfull(i,j,k)*AICE2(k)
      END DO
      IF(PNAT2 == 0.) THEN 
         FIXNAT = 1.0
      ELSE 
         FIXNAT = PNAT/PNAT2
      ENDIF
      IF(PICE2 == 0.) THEN
         FIXICE = 1.0
      ELSE
         FIXICE = PICE/PICE2
      ENDIF
      ANAT2(:) = ANAT2(:)*FIXNAT 
      AICE2(:) = AICE2(:)*FIXICE 
!
!  ADJUST NOY AND H2O TENDENCY FIELDS
!
!     ANOY(j,:) = ANOY(j,:) + (ANAT2(:) - ANAT(:))/dt 
!     AHNO3(j,:) = AHNO3(j,:) + (ANAT2(:) - ANAT(:))/dt 
!     AH2O(j,:) = AH2O(j,:) + (AICE2(:) - AICE(:))/dt 

!  ADJUST PSC FIELDS
      dpsc(i,j,:,1) = 0.
      dpsc(i,j,:,2) = ANAT2(:) - ANAT(:)
      dpsc(i,j,:,3) = AICE2(:) - AICE(:)


   end do Lon_loop
   end do Lat_loop

end subroutine strat_chem_psc_sediment


! <SUBROUTINE NAME="strat_chem_get_extra_h2o">
!   <OVERVIEW>
!     Set minimum allowed stratospheric water
!   </OVERVIEW>
!   <DESCRIPTION>
!     Constrain stratospheric H2O to be greater than or equal to 2*CH4
!   </DESCRIPTION>
!   <TEMPLATE>
!     call strat_chem_get_extra_h2o( h2o, age, ch4, Time, extra_h2o )
!   </TEMPLATE>
!   <IN NAME="h2o" TYPE="real" DIM="(:,:)">
!     Total H2O volume mixing ratio (mol/mol)
!   </IN>
!   <IN NAME="age" TYPE="real" DIM="(:,:)">
!     Age-of-air tracer (yrs)
!   </IN>
!   <IN NAME="ch4" TYPE="real" DIM="(:,:)">
!     Methane volume mixing ratio (mol/mol)
!   </IN>
!   <IN NAME="age" TYPE="time_type">
!     Current model time
!   </IN>
!   <OUT NAME="extra_h2o" TYPE="real" DIM="(:,:)">
!     Additional stratospheric H2O VMR (mol/mol)
!   </OUT>
subroutine strat_chem_get_extra_h2o( h2o, age, ch4, Time, extra_h2o )

implicit none

! Dummy arguments

real, dimension(:,:), intent(in)  :: h2o, age, ch4
type(time_type),      intent(in)  :: Time
real, dimension(:,:), intent(out) :: extra_h2o

! Local variables

integer :: i, k, il, kl, index1, index2
real :: frac, ch4_trop, min_h2o
type(time_type) :: time_trop


il = size(h2o,1)
kl = size(h2o,2)

do k = 1,kl
do i=1,il

   if (fixed_ch4_lbc_time) then
      time_trop = ch4_entry
   else
      time_trop = increment_time( Time, -NINT(age(i,k)/tfact), 0)
   end if
   call time_interp( time_trop, ch4_time(:), frac, index1, index2 )
   ch4_trop = ch4_value(index1) + frac*(ch4_value(index2)-ch4_value(index1))
   min_h2o = 2. * MAX( 0., ch4_trop - ch4(i,k) )
   if (age(i,k) > 0.1) then
      extra_h2o(i,k) = MAX( 0., min_h2o - h2o(i,k) )
   else
      extra_h2o(i,k) = 0.
   end if

end do
end do

end subroutine strat_chem_get_extra_h2o



! <SUBROUTINE NAME="strat_chem_extra_h2o_init">
!   <OVERVIEW>
!     Initialize minimum stratospheric water calculation
!   </OVERVIEW>
!   <DESCRIPTION>
!     Initialize constraint of stratospheric H2O to be greater than or equal to 2*CH4
!   </DESCRIPTION>
!   <TEMPLATE>
!     call strat_chem_extra_h2o_init()
!   </TEMPLATE>
!   <IN NAME="ch4_filename" TYPE="character">
!     Methane timeseries filename
!   </IN>
!   <IN NAME="ch4_scale_factor" TYPE="real">
!     Methane timeseries scale factor to convert to VMR (mol/mol)
!   </IN>
subroutine strat_chem_extra_h2o_init( ch4_filename, ch4_scale_factor, &
                                      fixed_ch4_lbc_time_in, ch4_entry_in )

implicit none

! Dummy arguments

character(len=*), intent(in) :: ch4_filename
real, intent(in)             :: ch4_scale_factor
logical, intent(in)          :: fixed_ch4_lbc_time_in
type(time_type), intent(in)  :: ch4_entry_in

! Local variables
character(len=64) :: filename
integer :: flb, series_length, n, year, diy
real :: extra_seconds
real, dimension(:), allocatable :: input_time
type(time_type) :: Year_t

fixed_ch4_lbc_time = fixed_ch4_lbc_time_in
ch4_entry = ch4_entry_in


filename = 'INPUT/' // trim(ch4_filename)
if( file_exist(filename) ) then
   flb = open_namelist_file( filename )
   read(flb, FMT='(i12)') series_length
   allocate( ch4_value(series_length), &
             input_time(series_length), &
             ch4_time(series_length) )
   do n = 1,series_length
      read (flb, FMT = '(2f12.4)') input_time(n), ch4_value(n)
   end do
   ch4_value(:) = ch4_value(:) * ch4_scale_factor
   call close_file( flb )
!---------------------------------------------------------------------
!    convert the time stamps of the series to time_type variables.     
!---------------------------------------------------------------------
   do n=1,series_length
      year = INT(input_time(n))
      Year_t = set_date(year,1,1,0,0,0)
      diy = days_in_year(Year_t)
      extra_seconds = (input_time(n) - year)*diy*SECONDS_PER_DAY 
      ch4_time(n) = Year_t + set_time(NINT(extra_seconds), 0)
   end do
   deallocate(input_time)
else
   call error_mesg ('strat_chem_extra_h2o_init', &
                    'Failed to find input file '//trim(filename), FATAL)
end if

end subroutine strat_chem_extra_h2o_init


end module strat_chem_utilities_mod


module tropchem_driver_mod
!
! <CONTACT EMAIL="Larry.Horowitz@noaa.gov">
!   Larry W. Horowitz
! </CONTACT>

! <OVERVIEW>
!     This code calculates tracer tendencies due to tropospheric chemistry
! </OVERVIEW>

! <DESCRIPTION>
!
! This code calculates chemical production and loss of tracers due
! to tropospheric chemistry. It also includes dry deposition, upper
! boundary conditions, emissions. Off-line sulfate concentrations are
! read in for use in calculating heterogeneous reaction rates (if SO4
! is not included as a tracer).
!
! This module is only activated if do_tropchem=T in tropchem_driver_nml
!
! </DESCRIPTION>


!-----------------------------------------------------------------------

use                    mpp_mod, only : input_nml_file 
use                    fms_mod, only : file_exist,   &
                                       field_exist, &
                                       write_version_number, &
                                       mpp_pe,  &
                                       mpp_root_pe, &
                                       lowercase,   &
                                       open_namelist_file, &
                                       close_file,   &
                                       stdlog, &
                                       check_nml_error, &
                                       error_mesg, &
                                       FATAL, &
                                       WARNING, &
                                       NOTE
use           time_manager_mod, only : time_type, &
                                       get_date, &
                                       set_date, &
                                       set_time, &
                                       days_in_year, &
                                       real_to_time_type, &
                                       time_type_to_real, &
                                       operator(+), operator(-)
use           diag_manager_mod, only : send_data,            &
                                       register_diag_field,  &
                                       register_static_field, &
                                       get_base_time
use         tracer_manager_mod, only : get_tracer_index,     &
                                       get_tracer_names,     &
                                       query_method,         &
                                       check_if_prognostic,  &
                                       NO_TRACER
use          field_manager_mod, only : MODEL_ATMOS,          &
                                       parse
use atmos_tracer_utilities_mod, only : dry_deposition
use              constants_mod, only : grav, rdgas, WTMAIR, WTMH2O, AVOGNO, &
                                       PI, DEG_TO_RAD, SECONDS_PER_DAY
use                    mpp_mod, only : mpp_clock_id,         &
                                       mpp_clock_begin,      &
                                       mpp_clock_end
use           interpolator_mod, only : interpolate_type,     &
                                        interpolate_type_eq, &
                                       interpolator_init,    &
                                    obtain_interpolator_time_slices, &
                                    unset_interpolator_time_flag, &
                                       interpolator_end,     &
                                       interpolator,         &
                                       query_interpolator,   &
                                       init_clim_diag,       &
                                       CONSTANT,             &
                                       INTERP_WEIGHTED_P  
use            time_interp_mod, only : time_interp_init, time_interp
use              mo_chemdr_mod, only : chemdr
use             mo_chemini_mod, only : chemini
use             M_TRACNAME_MOD, only : tracnam         
use                MO_GRID_MOD, only : pcnstm1 
use              CHEM_MODS_MOD, only : phtcnt, gascnt
use               MOZ_HOOK_MOD, only : moz_hook_init
use   strat_chem_utilities_mod, only : strat_chem_utilities_init, &
                                       strat_chem_dcly_dt, &
                                       strat_chem_dcly_dt_time_vary, &
                                       strat_chem_dcly_dt_endts, &
                                       strat_chem_get_aerosol, &
                                       psc_type, &
                                       strat_chem_get_h2so4, &
                                       strat_chem_get_psc, &
                                       strat_chem_destroy_psc, &
                                       strat_chem_psc_sediment, &
                                       strat_chem_get_extra_h2o
use           mo_chem_utls_mod, only : get_spc_ndx
use          atmos_sulfate_mod, only : atmos_sulfate_init, &
                                       atmos_sulfate_time_vary, &
                                       atmos_DMS_emission
use       esfsw_parameters_mod, only: Solar_spect, esfsw_parameters_init 
use astronomy_mod,         only : diurnal_solar, universal_time
use horiz_interp_mod, only: horiz_interp_type, horiz_interp_init, &
                            horiz_interp_new, horiz_interp
use fms_io_mod, only: read_data


implicit none

private

!-----------------------------------------------------------------------
!     ... interfaces
!-----------------------------------------------------------------------
public  tropchem_driver, tropchem_driver_init,  &
        tropchem_driver_time_vary, tropchem_driver_endts

!-----------------------------------------------------------------------
!     ...  declare type that will store the field infomation for the 
!          emission file
!-----------------------------------------------------------------------
type,public :: field_init_type
   character(len=64), pointer :: field_names(:)
end type field_init_type


!-----------------------------------------------------------------------
!     ... namelist
!-----------------------------------------------------------------------
integer, parameter :: maxinv = 100
real               :: relaxed_dt = SECONDS_PER_DAY*10.,     & ! relaxation timescale (sec) for the upper boundary values
                      relaxed_dt_lbc = SECONDS_PER_DAY*10., & ! relaxation timescale (sec) for the lower boundary values
                      ub_pres = 100.e2,               & ! pressure (Pa) above which to apply chemical upper boundary conditions
                      lb_pres = 950.e2                  ! pressure (Pa) below which to apply chemical lower boundary conditions
character(len=64)  :: file_sulfate = 'sulfate.nc',    & ! NetCDF file for sulfate concentrations
                      file_conc = 'conc_all.nc',      & ! NetCDF file for tracer concentrations (initial and fixed)
                      file_emis_1 = 'emissions.',     & ! NetCDF file name (beginning) for emissions
                      file_emis_2 = '.nc',            & ! NetCDF file name (end) for emissions
                      file_emis3d_1 = 'emissions3d.', & ! NetCDF file name (beginning) for 3-D emissions
                      file_emis3d_2 = '.nc',          & ! NetCDF file name (end) for 3-D emissions
                      file_ub = 'ub_vals.nc'            ! NetCDF file for chemical upper boundary conditions
character(len=64)  :: file_dry = 'depvel.nc',         & ! NetCDF file for dry deposition velocities
                      file_aircraft = 'aircraft.nc',  & ! NetCDF file for aircraft emissions
                      file_jval_lut = 'jvals.v5',     & ! ascii file for photolysis rate lookup table
                      file_jval_lut_min = ''            ! ascii file for photolysis rate LUT (for solar min)
character(len=10), dimension(maxinv) :: inv_list =''    ! list of invariant (fixed) tracers
real               :: lght_no_prd_factor = 1.           ! lightning NOx scale factor
real               :: strat_chem_age_factor = 1.        ! scale factor for age of air
real               :: strat_chem_dclydt_factor = 1.     ! scale factor for dcly/dt
logical            :: do_tropchem = .false.             ! Do tropospheric chemistry?
logical            :: use_tdep_jvals = .false.          ! Use explicit temperature dependence for photolysis rates
real               :: o3_column_top = 10.               ! O3 column above model top (DU)
real               :: jno_scale_factor = 1.             ! scale factor for NO photolysis rate (jNO)
logical            :: repartition_water_tracers = .false. ! Allow PSC scheme to act on total water (vapor+condensed)
logical            :: allow_negative_cosz = .false.     ! Allow negative values for cosine of solar zenith angle
logical            :: allow_psc_settling_type1 = .false.! Allow Type-I (NAT) PSCs to settle
logical            :: allow_psc_settling_type2 = .false.! Allow Type-II (ice) PSCs to settle
logical            :: force_cly_conservation = .false.  ! Force chemical conservation of Cly
logical            :: rescale_cly_components = .false.  ! Rescale individual Cly components to total Cly VMR
logical            :: set_min_h2o_strat = .false.       
! Don't allow total water concentration in the stratosphere to fall below 2*CH4_trop
character(len=64)  :: ch4_filename = 'ch4_gblannualdata'! Methane timeseries filename
real               :: ch4_scale_factor = 1.             ! Methane scale factor to convert to VMR (mol/mol)
character(len=64)  :: cfc_lbc_filename = 'chemlbf'      ! Input file for CFC lower boundary conditions
logical            :: time_varying_cfc_lbc = .true.     ! Allow time variation of CFC lower boundary conditions
integer, dimension(6) :: cfc_lbc_dataset_entry = (/ 1, 1, 1, 0, 0, 0 /) ! Entry date for CFC lower boundary condition file
real               :: Tdaily_clim = 297.                ! climatological T for use in MEGAN gamma_age calc
real               :: Pdaily_clim = 420.                ! climatological PPFD for MEGAN light correction 
!++amf/van
integer, parameter :: nveg=5, npft=17, nmos=12          ! number of vegetation types, pfts, and months
!--amf/van
integer            :: verbose = 3                       ! level of diagnostic output
 
namelist /tropchem_driver_nml/    &
                               relaxed_dt, &
                               relaxed_dt_lbc, &
                               ub_pres, &
                               lb_pres, &
                               file_sulfate, &
                               file_conc, &
                               file_emis_1, &
                               file_emis_2, &
                               file_emis3d_1, &
                               file_emis3d_2, &
                               file_ub, &
                               file_dry, &
                               inv_list, & 
                               file_aircraft,&
                               lght_no_prd_factor, &
                               strat_chem_age_factor, &
                               strat_chem_dclydt_factor, &
                               do_tropchem, &
                               use_tdep_jvals, &
                               file_jval_lut, &
                               file_jval_lut_min, &
                               o3_column_top, &
                               jno_scale_factor, &
                               repartition_water_tracers, &
                               allow_negative_cosz, &
                               allow_psc_settling_type1, &
                               allow_psc_settling_type2, &
                               force_cly_conservation, &
                               rescale_cly_components, &
                               set_min_h2o_strat, &
                               ch4_filename, &
                               ch4_scale_factor, &
                               cfc_lbc_filename, &
                               time_varying_cfc_lbc, &
                               cfc_lbc_dataset_entry, &
                               Tdaily_clim, &
                               Pdaily_clim, &
                               verbose

character(len=7), parameter :: module_name = 'tracers'
real, parameter :: g_to_kg    = 1.e-3,    & !conversion factor (kg/g)
                   m2_to_cm2  = 1.e4,     & !conversion factor (cm2/m2)
                   twopi      = 2.*PI
real, parameter :: emis_cons = WTMAIR * g_to_kg * m2_to_cm2 / AVOGNO
logical, dimension(pcnstm1) :: has_emis = .false., &      ! does tracer have surface emissions?
                               has_emis3d = .false., &    ! does tracer have 3-D emissions?
                               has_xactive_emis = .false., & ! does tracer have interactive emissions?
                               diurnal_emis = .false., &   ! diurnally varying emissions?
                               diurnal_emis3d = .false.    ! diurnally varying 3-D emissions?

type(interpolate_type),dimension(pcnstm1), save :: inter_emis, &
                                                   inter_emis3d, &
                                                   inter_aircraft_emis
type(interpolate_type), save :: airc_default
type(field_init_type),dimension(pcnstm1) :: emis_field_names, &
                                            emis3d_field_names
logical, dimension(pcnstm1) :: has_ubc = .false., &
                               has_lbc = .false., &
                               fixed_lbc_time = .false.
type(time_type), dimension(pcnstm1) :: lbc_entry
logical, dimension(pcnstm1) :: has_airc = .false.
character(len=64),dimension(pcnstm1) :: ub_names, airc_names
real, parameter :: small = 1.e-50
integer :: sphum_ndx=0, cl_ndx=0, clo_ndx=0, hcl_ndx=0, hocl_ndx=0, clono2_ndx=0, &
           cl2o2_ndx=0, cl2_ndx=0, clno2_ndx=0, br_ndx=0, bro_ndx=0, hbr_ndx=0, &
           hobr_ndx=0, brono2_ndx=0, brcl_ndx=0, &
           hno3_ndx=0, o3_ndx=0, &
           no_ndx=0, no2_ndx=0, no3_ndx=0, n_ndx=0, n2o5_ndx=0, ho2no2_ndx=0, &
           pan_ndx=0, onit_ndx=0, mpan_ndx=0, isopno3_ndx=0, onitr_ndx=0, &
           extinct_ndx=0, noy_ndx=0, cly_ndx=0, bry_ndx=0, ch4_ndx=0, &
           dms_ndx=0
logical :: do_interactive_h2o = .false.         ! Include chemical sources/sinks of water vapor?
real, parameter :: solarflux_min = 1.09082, &   ! solar minimum flux (band 18) [W/m2]
                   solarflux_max = 1.14694      ! solar maximum flux (band 18) [W/m2]

!-----------------------------------------------------------------------
!     ... identification numbers for diagnostic fields
!-----------------------------------------------------------------------
integer :: id_sul, id_temp, id_dclydt, id_dbrydt, id_dclydt_chem, &
           id_psc_sat, id_psc_nat, id_psc_ice, id_volc_aer, &
           id_imp_slv_nonconv, id_srf_o3, id_coszen, id_h2o_chem
integer :: inqa, inql, inqi !index of the three water species(nqa, nql, nqi)
integer :: age_ndx ! index of age tracer
logical :: module_is_initialized=.false.

integer, dimension(pcnstm1) :: indices, id_prod, id_loss, id_chem_tend, &
                               id_emis, id_emis3d, id_xactive_emis, &
                               id_ub, id_lb, id_airc
integer :: id_so2_emis_cmip, id_nh3_emis_cmip
integer :: id_co_emis_cmip, id_no_emis_cmip
integer :: id_co_emis_cmip2, id_no_emis_cmip2
integer :: id_so2_emis_cmip2, id_nh3_emis_cmip2
integer :: id_glaiage, id_gtemp, id_glight, id_tsfc, id_fsds, id_ctas, id_cfsds
integer :: isop_oldmonth = 0
logical :: newmonth            
logical :: has_ts_avg = .true.   ! currently reading in from monthly mean files.
integer, dimension(phtcnt)  :: id_jval
integer, dimension(gascnt)  :: id_rate_const

type(interpolate_type), save :: conc       ! used to read in the concentration of OH and CH4
type(interpolate_type), save :: sulfate    ! used to read in the data for sulate
type(interpolate_type), save :: ub_default ! used for the upper bound data
type(interpolate_type),dimension(pcnstm1), save :: ub

type :: lb_type
   real, dimension(:), pointer :: gas_value
   type(time_type), dimension(:), pointer :: gas_time
end type lb_type
type(lb_type), dimension(pcnstm1) :: lb

type(interpolate_type), save :: drydep_data_default
integer :: clock_id,ndiag

real, allocatable, dimension(:,:,:) :: ecisop, pctpft   !emission capacities, % pft
real, allocatable, dimension(:,:,:,:) :: mlai ! monthly lai for each pft (could eventually tie to LM3)
real, allocatable, dimension(:,:) :: emisop_month !isop emissions with monthly lai & age gammas applied
real, allocatable, dimension(:,:) :: diag_gamma_lai_age   ! for combined lai and age gammas
real, allocatable, dimension(:,:) :: diag_gamma_light, diag_gamma_temp  ! for gamma light / T
real, allocatable, dimension(:,:) :: diag_climtas, diag_climfsds ! climatological tas and fsds

!if set up to read from restart file, then these would be 2D arrays.. for now, use mm clim. values
!real, allocatable, dimension(:,:) :: ts_avg   ! surface air T, averaged over some period (K) 
!real, allocatable, dimension(:,:) :: fsds_avg  ! avg shortwave down in visible (W/m2) 

!monthly mean sfc air T and sw down at surface, from C. Wiedinmyer 2/18/09 - Sheffield inputs (Princeton)
! CW provided 1948-2000; current input files take 1980-2000 average
real, allocatable, dimension(:,:,:) :: ts_avg  ! climatological monthly mean surface air T
real, allocatable, dimension(:,:,:) :: fsds_avg  ! climat. montly mean total shortwave down (W/m2)

type (horiz_interp_type), save :: Interp


!---- version number ---------------------------------------------------
character(len=128), parameter :: version     = '$Id: tropchem_driver.F90,v 17.0.2.1.6.1.2.1.2.1.4.1.2.1 2010/09/07 15:09:58 wfc Exp $'
character(len=128), parameter :: tagname     = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

contains


!#######################################################################

! <SUBROUTINE NAME="tropchem_driver">
!   <OVERVIEW>
!     Tropospheric chemistry driver.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine calculates the sources and sinks of tracers
!     due to tropospheric chemistry. It is called from atmos_tracer_driver.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call tropchem_driver (lon, lat, land, pwt, r, chem_dt,           &
!                           Time, phalf, pfull, t, is, ie, js, je, dt, &
!                           z_half, z_full, q, tsurf, albedo, coszen,  &
!                           area, w10m, flux_sw_down_vis_dir, flux_sw_down_vis_dif, &
!                           half_day, &
!                           Time_next, rdiag,  kbot)
!   </TEMPLATE>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!     The longitudes for the local domain.
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!     The latitudes for the local domain.
!   </IN>
!   <IN NAME="land" TYPE="real" DIM="(:,:)">
!     The latitudes for the local domain.
!   </IN>
!   <IN NAME="pwt" TYPE="real" DIM="(:,:,:)">
!     Pressure weighting (air mass) for each layer (kg/m2)
!   </IN>
!   <IN NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer mixing ratios (tropchem tracers in VMR)
!   </IN>
!   <IN NAME="Time, Time_next" TYPE="time_type">
!     Model time
!   </IN>
!   <IN NAME="phalf" TYPE="real" DIM="(:,:,:)">
!     Pressure on the model half levels (Pa)
!   </IN>
!   <IN NAME="pfull" TYPE="real" DIM="(:,:,:)">
!     Pressure on the model full levels (Pa)
!   </IN>
!   <IN NAME="t" TYPE="real" DIM="(:,:,:)">
!     Temperature.
!   </IN>
!   <IN NAME="is, js" TYPE="integer">
!     Local domain start indices
!   </IN>
!   <IN NAME="ie, je" TYPE="integer">
!     Local domain end indices
!   </IN>
!   <IN NAME="dt" TYPE="real">
!     Model physics timestep (s)
!   </IN>
!   <IN NAME="z_half" TYPE="real" DIM="(:,:,:)">
!     Height at model half levels (m)
!   </IN>
!   <IN NAME="z_full" TYPE="real" DIM="(:,:,:)">
!     Height at model full levels (m)
!   </IN>
!   <IN NAME="q" TYPE="real" DIM="(:,:,:)">
!     Specific humidity (kg/kg)
!   </IN>
!   <IN NAME="tsurf" TYPE="real" DIM="(:,:)">
!     Surface temperature (K)
!   </IN>
!   <IN NAME="albedo" TYPE="real" DIM="(:,:)">
!     Surface albedo
!   </IN>
!   <IN NAME="coszen" TYPE="real" DIM="(:,:)">
!     Cosine of the solar zenith angle
!   </IN>
!   <IN NAME="area" TYPE="real" DIM="(:,:)">
!     Grid box area (m^2)
!   </IN>
!   <IN NAME="w10m" TYPE="real" DIM="(:,:)">
!     Windspeed at 10m (m/s)
!   </IN>
!   <IN NAME="flux_sw_down_vis_dir" TYPE="real" DIM="(:,:)">
!     Surface downward visible radiation (W/m2)
!   </IN>
!   <IN NAME="flux_sw_down_vis_dif" TYPE="real" DIM="(:,:)">
!     Surface downward visible radiation (W/m2)
!   </IN>
!   <IN NAME="half_day" TYPE="real" DIM="(:,:)">
!     Half-day length  (dimensionless; 0 to pi)
!   </IN>
!   <OUT NAME="chem_dt" TYPE="real" DIM="(:,:,:,:)">
!     Tracer tendencies from tropospheric chemistry (VMR/s)
!   </OUT>
!   <INOUT NAME="rdiag" TYPE="real" DIM="(:,:,:,:)">
!     Diagnostic tracer mixing ratios (tropchem tracers in VMR),
!     updated on output
!   </INOUT>
!   <IN NAME="kbot" TYPE="integer, optional" DIM="(:,:)">
!     Integer array describing which model layer intercepts the surface.
!   </IN>

subroutine tropchem_driver( lon, lat, land, pwt, r, chem_dt,                 &
                            Time, phalf, pfull, t, is, ie, js, je, dt,       &
                            z_half, z_full, q, tsurf, albedo, coszen, rrsun, &
                            area, w10m, flux_sw_down_vis_dir, flux_sw_down_vis_dif, &
                            half_day, &
                            Time_next, rdiag,  kbot )

!-----------------------------------------------------------------------
   real, intent(in),    dimension(:,:)            :: lon, lat
   real, intent(in),    dimension(:,:)            :: land    ! land fraction
   real, intent(in),    dimension(:,:,:)          :: pwt
   real, intent(in),    dimension(:,:,:,:)        :: r
   real, intent(out),   dimension(:,:,:,:)        :: chem_dt
   type(time_type), intent(in)                    :: Time, Time_next     
   integer, intent(in)                            :: is, ie, js, je
   real, intent(in),    dimension(:,:,:)          :: phalf,pfull,t
   real, intent(in)                               :: dt      ! timestep (s)
   real, intent(in),    dimension(:,:,:)          :: z_half  ! height in meters at half levels
   real, intent(in),    dimension(:,:,:)          :: z_full  ! height in meters at full levels
   real, intent(in),    dimension(:,:,:)          :: q       ! specific humidity at current time step (kg/kg)
   real, intent(in),    dimension(:,:)            :: tsurf   ! surface temperature (K)
   real, intent(in),    dimension(:,:)            :: albedo  ! surface albedo
   real, intent(in),    dimension(:,:)            :: coszen  ! cosine of solar zenith angle
   real, intent(in)                               :: rrsun   ! earth-sun distance factor (r_avg/r)^2
   real, intent(in),    dimension(:,:)            :: area    ! grid box area (m^2)
   real, intent(in),    dimension(:,:)            :: w10m    ! wind speed at 10m (m/s)
   real, intent(in), dimension(:,:)               :: flux_sw_down_vis_dir !W/m2 direct visible sfc flux
   real, intent(in), dimension(:,:)               :: flux_sw_down_vis_dif !W/m2 diffuse visible sfc flux
   real, intent(in), dimension(:,:)               :: half_day! half-day length (0 to pi)   
   real, intent(inout), dimension(:,:,:,:)        :: rdiag   ! diagnostic tracer concentrations
   integer, intent(in),  dimension(:,:), optional :: kbot
!-----------------------------------------------------------------------
   real, dimension(size(r,1),size(r,2),size(r,3)) :: sulfate_data
!   real, dimension(size(r,1),size(r,2),size(r,3)) :: ub_temp,rno
   real, dimension(size(r,1),size(r,2),size(r,3),maxinv) :: inv_data
   real, dimension(size(r,1),size(r,2)) :: emis
   real, dimension(size(r,1),size(r,2), pcnstm1) :: emisz
   real, dimension(size(r,1),size(r,2),size(r,3)) :: emis3d, xactive_emis
   real, dimension(size(r,1),size(r,2),size(r,3)) :: age, cly0, cly, cly_ratio, &
                                                     bry, dclydt, dbrydt, noy, &
                                                     extinct, strat_aerosol
   real, dimension(size(r,1),size(r,2),size(r,3),3) :: psc_vmr_save, dpsc_vmr
   real, dimension(size(r,1),size(r,2)) :: tsfcair, pwtsfc, flux_sw_down_vis
   integer :: i,j,k,n,kb,id,jd,kd,ninv,ntp, index1, index2
!  integer :: nno,nno2
   integer :: inv_index
   integer :: plonl
   logical :: used
   real :: scale_factor, frac
   real,  dimension(size(r,1),size(r,3)) :: pdel, h2so4, h2o_temp, qlocal, cloud_water
   real, dimension(size(r,1),size(r,2),size(r,3),pcnstm1)  :: r_temp, r_in, emis_source, r_ub, airc_emis
   real, dimension(size(r,1),size(r,2),size(r,3)) :: tend_tmp, extra_h2o
   real, dimension(pcnstm1) :: r_lb
   real, dimension(size(land,1), size(land,2)) :: oro ! 0 and 1 rep. of land
   real, dimension(size(r,1),size(r,2)) :: coszen_local, fracday_local
   real :: rrsun_local
   real, dimension(size(r,1),size(r,2),size(r,3),pcnstm1) :: prod, loss
   real, dimension(size(r,1),size(r,2),size(r,3),phtcnt) :: jvals
   real, dimension(size(r,1),size(r,2),size(r,3),gascnt) :: rate_constants
   real, dimension(size(r,1),size(r,2),size(r,3)) :: imp_slv_nonconv
   real :: solar_phase
   type(psc_type) :: psc
   type(time_type) :: lbc_Time
!-----------------------------------------------------------------------

!<ERROR MSG="tropchem_driver_init must be called first." STATUS="FATAL">
!   Tropchem_driver_init needs to be called before tracer_driver.
!</ERROR>
   if (.not. module_is_initialized)  &
      call error_mesg ('Tropchem_driver','tropchem_driver_init must be called first.', FATAL)

   ntp = size(r,4)
   plonl = size(r,1)

   where(land(:,:) >= 0.5)
      oro(:,:) = 1.
   elsewhere
      oro(:,:) = 0.
   endwhere

   id=size(r,1); jd=size(r,2); kd=size(r,3)
   
   ninv=0
   do n = 1, size(inv_list)
      if(inv_list(n) /= '') then
         ninv = ninv + 1
      else
         exit
      end if
   end do
 
   emis_source(:,:,:,:) = 0.0
   airc_emis(:,:,:,:) = 0.0

   tsfcair(:,:) = t(:,:,kd)
   pwtsfc(:,:) = t(:,:,kd)
   do n = 1, pcnstm1
!-----------------------------------------------------------------------
!     ... read in the surface emissions, using interpolator
!-----------------------------------------------------------------------
      if (has_emis(n)) then
         call read_2D_emis_data( inter_emis(n), emis, Time, &
                                 emis_field_names(n)%field_names, &
                                 diurnal_emis(n), coszen, half_day, lon, &
                                 is, js, id_emis(n) )
         if (tracnam(n) == 'NO') then
           emisz(:,:,n) = emis(:,:)
           if (id_no_emis_cmip > 0) then
             used = send_data(id_no_emis_cmip,emis*1.0e04*0.030/AVOGNO,Time, &
                                                  is_in=is,js_in=js)
           endif
         endif
         if (tracnam(n) == 'CO') then
           emisz(:,:,n) = emis(:,:)
           if (id_co_emis_cmip > 0) then
             used = send_data(id_co_emis_cmip,emis*1.0e04*0.028/AVOGNO,Time, &
                                                  is_in=is,js_in=js)
           endif
         endif
         if (tracnam(n) == 'SO2') then
           emisz(:,:,n) = emis(:,:)
           if (id_so2_emis_cmip > 0) then
             used = send_data(id_so2_emis_cmip,emis*1.0e04*0.064/AVOGNO,Time, &
                                                  is_in=is,js_in=js)
           endif
         endif
         if (tracnam(n) == 'NH3') then
           emisz(:,:,n) = emis(:,:)
           if (id_nh3_emis_cmip > 0) then
             used = send_data(id_nh3_emis_cmip,emis*1.0e04*0.017/AVOGNO,Time, &
                                                  is_in=is,js_in=js)
           endif
         endif

         if (present(kbot)) then
            do j=1,jd
               do i=1,id
                  kb=kbot(i,j)
                  emis_source(i,j,kb,n) = emis(i,j)/pwt(i,j,kb) * emis_cons
               end do
            end do
         else
            emis_source(:,:,kd,n) = emis(:,:)/pwt(:,:,kd) * emis_cons
         end if
      end if

!-----------------------------------------------------------------------
!     ... read in the 3-D emissions, using interpolator
!-----------------------------------------------------------------------
      if (has_emis3d(n)) then
         call read_3D_emis_data( inter_emis3d(n), emis3d, Time, phalf, &
                                 emis3d_field_names(n)%field_names, &
                                 diurnal_emis3d(n), coszen, half_day, lon, &
                                 is, js, id_emis3d(n) )
      
         emis_source(:,:,:,n) = emis_source(:,:,:,n) &
                              + emis3d(:,:,:)/pwt(:,:,:) * emis_cons
         if (tracnam(n) == 'SO2') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + emis3d(:,:,k)
           end do
         endif
         if (tracnam(n) == 'NO') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + emis3d(:,:,k)
           end do
         endif
         if (tracnam(n) == 'CO') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + emis3d(:,:,k)
           end do
         endif
         if (tracnam(n) == 'NH3') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + emis3d(:,:,k)
           end do
         endif
      end if

!-----------------------------------------------------------------------
!     ... calculate interactive emissions
!-----------------------------------------------------------------------
!     if (has_xactive_emis(n)) then
      if ( has_xactive_emis(n) .or. id_xactive_emis(n)>0 ) then
         select case (trim(tracnam(n)))
         case ('ISOP')

            flux_sw_down_vis = flux_sw_down_vis_dir+flux_sw_down_vis_dif

            call calc_xactive_isop ( n, Time, lon, lat, oro, pwtsfc, is, js, &
                 area, land, tsfcair, flux_sw_down_vis, &
                 coszen, emis, id_gamma_lai_age=id_glaiage, &
                 id_gamma_temp=id_gtemp, id_gamma_light=id_glight, &
                 id_tsfcair=id_tsfc, id_fsdvd=id_fsds, &
                 id_climtas=id_ctas, id_climfsds=id_cfsds, id_emis_diag=id_xactive_emis(n) )
            if (has_xactive_emis(n)) then
               if (present(kbot)) then
                  do j=1,jd
                     do i=1,id
                        kb=kbot(i,j)

                        emis_source(i,j,kb,n) = emis_source(i,j,kb,n) &
                                              + emis(i,j)/pwt(i,j,kb)*emis_cons

                     end do
                  end do
               else
                  emis_source(:,:,kd,n) = emis_source(:,:,kd,n) &
                                        + emis(:,:)/pwt(:,:,kd) * emis_cons
               end if
            end if
         case ('DMS')
            call calc_xactive_emis( n, Time, lon, lat, pwt, is, ie, js, je, &
                 area, land, tsurf, w10m, xactive_emis, &
                 kbot=kbot, id_emis_diag=id_xactive_emis(n) )
            if (has_xactive_emis(n)) then
               emis_source(:,:,:,n) = emis_source(:,:,:,n) + xactive_emis(:,:,:)
            end if
         case default
            if (has_xactive_emis(n)) then
            call error_mesg ('tropchem_driver','Interactive emissions not defined for species: '//trim(tracnam(n)), FATAL)
            end if
         end select
      end if

!-----------------------------------------------------------------------
!     ... read in the aircraft emissions
!-----------------------------------------------------------------------
      if(has_airc(n)) then
         call interpolator( inter_aircraft_emis(n), Time, phalf, &
                            airc_emis(:,:,:,n), trim(airc_names(n)),is,js)
         if(id_airc(n) > 0)&
              used = send_data(id_airc(n),airc_emis(:,:,:,n),Time, is_in=is, js_in=js)
    
         if (tracnam(n) == 'CO') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + airc_emis(:,:,k,n)
           end do
         endif
         if (tracnam(n) == 'NO') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + airc_emis(:,:,k,n)
           end do
         endif
         if (tracnam(n) == 'SO2') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + airc_emis(:,:,k,n)
           end do
         endif
         if (tracnam(n) == 'NH3') then
           do k=1, size(emis3d,3)
           emisz(:,:,n) = emisz(:,:,n) + airc_emis(:,:,k,n)
           end do
         endif
         airc_emis(:,:,:,n) = airc_emis(:,:,:,n)/pwt(:,:,:)*emis_cons
!     end if
      end if
         if (tracnam(n) == 'NO') then
           if (id_no_emis_cmip2 > 0) then
             used = send_data(id_no_emis_cmip2,emisz(:,:,n)*1.0e04*0.030/AVOGNO,Time, &
                                                 is_in=is,js_in=js)
           endif
         endif
         if (tracnam(n) == 'CO') then
           if (id_co_emis_cmip2 > 0) then
             used = send_data(id_co_emis_cmip2,emisz(:,:,n)*1.0e04*0.028/AVOGNO,Time, &
                                                 is_in=is,js_in=js)
           endif
         endif
         if (tracnam(n) == 'SO2') then
           if (id_so2_emis_cmip2 > 0) then
             used = send_data(id_so2_emis_cmip2,emisz(:,:,n)*1.0e04*0.064/AVOGNO,Time, &
                                                 is_in=is,js_in=js)
           endif
         endif
         if (tracnam(n) == 'NH3') then
           if (id_nh3_emis_cmip2 > 0) then
             used = send_data(id_nh3_emis_cmip2,emisz(:,:,n)*1.0e04*0.017/AVOGNO,Time, &
                                                  is_in=is,js_in=js)
           endif
         endif
   end do

!-----------------------------------------------------------------------
!     ... read in the concentrations of "invariant" (i.e., prescribed)
!         species
!-----------------------------------------------------------------------
   do n = 1,ninv
      call interpolator( conc, Time, phalf, inv_data(:,:,:,n), &
                         trim(inv_list(n)), is, js)
      inv_index = get_tracer_index( MODEL_ATMOS, trim(inv_list(n)) ) - ntp
      rdiag(:,:,:,inv_index) = inv_data(:,:,:,n)
   end do
      
!-----------------------------------------------------------------------
!     ... read in the sulfate aerosol concentrations
!-----------------------------------------------------------------------
   call interpolator(sulfate, Time, phalf, sulfate_data, 'sulfate', is,js)
   used = send_data(id_sul, sulfate_data, Time, is_in=is, js_in=js)

!  call mpp_clock_begin(clock_id)

   chem_dt(:,:,:,:) =0.
    
!-----------------------------------------------------------------------
!     ... assign concentrations of prognostic (r) and diagnostic (rdiag)
!         species to r_temp
!-----------------------------------------------------------------------
   do n = 1,pcnstm1
      if(indices(n) <= ntp) then
         r_temp(:,:,:,n) = r(:,:,:,indices(n))
      else
         r_temp(:,:,:,n) = rdiag(:,:,:,indices(n)-ntp)
      end if
   end do

!-----------------------------------------------------------------------
!     ... convert to H2O VMR
!-----------------------------------------------------------------------
   if (sphum_ndx > 0) then
      r_temp(:,:,:,sphum_ndx) = r_temp(:,:,:,sphum_ndx) * WTMAIR / WTMH2O
   end if

!-----------------------------------------------------------------------
!     ... convert volcanic aerosol extinction into aerosol surface area
!-----------------------------------------------------------------------
   if (extinct_ndx > 0 .and. extinct_ndx <= ntp) then
      extinct(:,:,:) = r(:,:,:,extinct_ndx)
   else if (extinct_ndx > ntp) then
      extinct(:,:,:) = rdiag(:,:,:,extinct_ndx-ntp)
   else
      extinct(:,:,:) = 0.
   end if
   call strat_chem_get_aerosol( extinct, strat_aerosol )

!-----------------------------------------------------------------------
!     ... get age of air
!-----------------------------------------------------------------------
   if(age_ndx > 0 .and. age_ndx <= ntp) then
      age(:,:,:) = r(:,:,:,age_ndx)
   else
      age(:,:,:) = 0.
   end if

!-----------------------------------------------------------------------
!     ... Chemical families
!-----------------------------------------------------------------------
   cly0(:,:,:) = 0.
   if (cl_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,cl_ndx)
   end if
   if (clo_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,clo_ndx)
   end if
   if (hcl_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,hcl_ndx)
   end if
   if (hocl_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,hocl_ndx)
   end if
   if (clono2_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,clono2_ndx)
   end if
   if (cl2o2_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,cl2o2_ndx)*2
   end if
   if (cl2_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,cl2_ndx)*2
   end if
   if (clno2_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,clno2_ndx)
   end if
   if (brcl_ndx>0) then
      cly0(:,:,:) = cly0(:,:,:) + r_temp(:,:,:,brcl_ndx)
   end if

!-----------------------------------------------------------------------
!     ... cosine of solar zenith angle
!-----------------------------------------------------------------------
   if (allow_negative_cosz) then
      call diurnal_solar( lat, lon, Time, coszen_local, fracday_local, &
                          rrsun_local, dt_time=real_to_time_type(dt), &
                          allow_negative_cosz=.true. )
   else
      coszen_local(:,:) = coszen(:,:)
      rrsun_local = rrsun
   end if

   r_temp(:,:,:,:) = MAX(r_temp(:,:,:,:),small)
  
   do j = 1,jd
      do k = 1,kd
         pdel(:,k) = phalf(:,j,k+1) - phalf(:,j,k)
      end do
      qlocal(:,:) = q(:,j,:)
      
!-----------------------------------------------------------------------
!     ... get stratospheric h2so4
!-----------------------------------------------------------------------
      call strat_chem_get_h2so4( pfull(:,j,:), age(:,j,:), h2so4 )

!-----------------------------------------------------------------------
!     ... compute PSC amounts
!-----------------------------------------------------------------------
      if (sphum_ndx>0) then
         h2o_temp(:,:) = r_temp(:,j,:,sphum_ndx)
      else
         h2o_temp(:,:) = qlocal(:,:) * WTMAIR/WTMH2O
      end if
      cloud_water(:,:) = MAX(r(:,j,:,inql)+r(:,j,:,inqi),0.)
      if (repartition_water_tracers) then
         h2o_temp(:,:) = h2o_temp(:,:) + cloud_water(:,:) * WTMAIR/WTMH2O
      end if
      if (set_min_h2o_strat) then
         call strat_chem_get_extra_h2o( h2o_temp, age(:,j,:), r_temp(:,j,:,ch4_ndx), Time, extra_h2o(:,j,:) )
         h2o_temp(:,:) = h2o_temp(:,:) + extra_h2o(:,j,:)
      end if

      call strat_chem_get_psc( t(:,j,:), pfull(:,j,:), &
                               r_temp(:,j,:,hno3_ndx), h2o_temp(:,:), &
                               h2so4, strat_aerosol(:,j,:), psc, psc_vmr_out=psc_vmr_save(:,j,:,:) )

      if (repartition_water_tracers) then
         cloud_water(:,:) = MAX(0.,cloud_water(:,:) - psc_vmr_save(:,j,:,3)*WTMH2O/WTMAIR) ! reduce cloud_water by amount of type-II
         h2o_temp(:,:) = h2o_temp(:,:) - cloud_water(:,:) * WTMAIR/WTMH2O                  ! PSC remaining water is present as vapor
      end if
      if (sphum_ndx>0) then
         r_temp(:,j,:,sphum_ndx) = h2o_temp(:,:)
      end if
      qlocal(:,:) = h2o_temp(:,:) * WTMH2O/WTMAIR
      r_in(:,j,:,:) = r_temp(:,j,:,:)

!-----------------------------------------------------------------------
!     ... get solar cycle phase (use radiation band #18)
!-----------------------------------------------------------------------
      solar_phase = Solar_spect%solflxbandref(Solar_spect%nbands)
      solar_phase = (solar_phase-solarflux_min)/(solarflux_max-solarflux_min)

!-----------------------------------------------------------------------
!     ... call chemistry driver
!-----------------------------------------------------------------------
      call chemdr(r_temp(:,j,:,:),             & ! species volume mixing ratios (VMR)
!                 0,                           & ! time step index
                  Time_next,                   & ! time
                  lat(:,j),                    & ! latitude
                  lon(:,j),                    & ! longitude
                  dt,                          & ! timestep in seconds
                  phalf(:,j,SIZE(phalf,3)),    & ! surface press ( pascals )  
                  phalf(:,j,1),                & ! model top pressure (pascals)
                  pfull(:,j,:),                & ! midpoint press ( pascals )
                  pdel,                        & ! delta press across midpoints
!                 oro(:,j),                    & ! surface orography flag
!                 tsurf(:,j),                  & ! surface temperature
                  z_full(:,j,:),               & ! height at midpoints ( m )
                  z_half(:,j,:),               & ! height at interfaces ( m )
                  MAX(r(:,j,:,inqa),0.),       & ! cloud fraction
                  cloud_water(:,:),            & ! total cloud water (kg/kg)
                  t(:,j,:),                    & ! temperature
                  inv_data(:,j,:,:),           & ! invariant species
                  qlocal(:,:),                 & ! specific humidity ( kg/kg )
                  albedo(:,j),                 & ! surface albedo
                  coszen_local(:,j),           & ! cosine of solar zenith angle
                  rrsun_local,                 & ! earth-sun distance factor
                  prod(:,j,:,:),               & ! chemical production rate
                  loss(:,j,:,:),               & ! chemical loss rate
                  jvals(:,j,:,:),              & ! photolysis rates (s^-1)
                  rate_constants(:,j,:,:),     & ! kinetic rxn rate constants (cm^3 molec^-1 s^-1 for 2nd order)
                  sulfate_data(:,j,:),         & ! sulfate aerosol
                  psc,                         & ! polar stratospheric clouds (PSCs)
                  do_interactive_h2o,          & ! include h2o sources/sinks?
                  solar_phase,                 & ! solar cycle phase (1=max, 0=min)
                  imp_slv_nonconv(:,j,:),      & ! flag for non-convergence of implicit solver
                  plonl )                        ! number of longitudes
      

      call strat_chem_destroy_psc( psc )

   end do

   r_temp(:,:,:,:) = MAX( r_temp(:,:,:,:), small )
   if (allow_psc_settling_type1 .or. allow_psc_settling_type2) then
      call strat_chem_psc_sediment( psc_vmr_save, pfull, dt, dpsc_vmr )
      if (.not. allow_psc_settling_type1) dpsc_vmr(:,:,:,2) = 0.
      if (.not. allow_psc_settling_type2) dpsc_vmr(:,:,:,3) = 0.
   end if

!-----------------------------------------------------------------------
!     ... output diagnostics
!-----------------------------------------------------------------------
   do n = 1,pcnstm1
      if(id_prod(n)>0) then
         used = send_data(id_prod(n),prod(:,:,:,n),Time,is_in=is,js_in=js)
      end if
      if(id_loss(n)>0) then
         used = send_data(id_loss(n),loss(:,:,:,n),Time,is_in=is,js_in=js)
      end if
      
      if (n == sphum_ndx) then
         scale_factor = WTMAIR/WTMH2O
! add PSC ice back to H2O
!         if (repartition_water_tracers) then
!           r_temp(:,:,:,n) = r_temp(:,:,:,n) + &
!                             MAX( 0.,psc_vmr_save(:,:,:,3) - MAX(r(:,:,:,inql)+r(:,:,:,inqi),0.)*scale_factor ) + &
!                             dpsc_vmr(:,:,:,3)
!        else
!           r_temp(:,:,:,n) = r_temp(:,:,:,n) + psc_vmr_save(:,:,:,3)+dpsc_vmr(:,:,:,3)
!        end if
!        if (set_min_h2o_strat) then
!           r_temp(:,:,:,n) = MAX( r_temp(:,:,:,n) - extra_h2o(:,:,:), small )
!        end if
      else
         scale_factor = 1.
      end if

!     if (n == hno3_ndx) then
!        r_temp(:,:,:,n) = r_temp(:,:,:,n) + psc_vmr_save(:,:,:,2)+dpsc_vmr(:,:,:,2) ! add PSC NAT back to gas-phase HNO3
!     end if

!-----------------------------------------------------------------------
!     ... compute tendency
!-----------------------------------------------------------------------
      tend_tmp(:,:,:) = ( r_temp(:,:,:,n) - r_in(:,:,:,n) )/dt
      if(indices(n) <= ntp) then
!-----------------------------------------------------------------------
!     ... prognostic species
!-----------------------------------------------------------------------
!        tend_tmp(:,:,:) = ( r_temp(:,:,:,n) - MAX(r(:,:,:,indices(n))*scale_factor,small) )/dt
         chem_dt(:,:,:,indices(n)) = airc_emis(:,:,:,n) + emis_source(:,:,:,n) + tend_tmp(:,:,:)
      else
!-----------------------------------------------------------------------
!     ... diagnostic species
!-----------------------------------------------------------------------
!        tend_tmp(:,:,:) = ( r_temp(:,:,:,n) - MAX(rdiag(:,:,:,indices(n)-ntp)*scale_factor,small) )/dt
         rdiag(:,:,:,indices(n)-ntp) = r_temp(:,:,:,n)
      end if
!-----------------------------------------------------------------------
!     ... output diagnostic tendency
!-----------------------------------------------------------------------
      if(id_chem_tend(n)>0) then
         used = send_data( id_chem_tend(n), tend_tmp(:,:,:), Time, is_in=is,js_in=js)
      end if
     
!-----------------------------------------------------------------------
!     ... apply upper boundary condition
!-----------------------------------------------------------------------
      if(has_ubc(n)) then
         call interpolator(ub(n), Time, phalf, r_ub(:,:,:,n), trim(ub_names(n)), is, js)
         if(id_ub(n)>0) then
            used = send_data(id_ub(n), r_ub(:,:,:,n), Time, is_in=is, js_in=js)
         end if
         where (pfull(:,:,:) < ub_pres)            
            chem_dt(:,:,:,indices(n)) = (r_ub(:,:,:,n) - r(:,:,:,indices(n))) / relaxed_dt
         endwhere
      end if

!-----------------------------------------------------------------------
!     ... apply lower boundary condition
!-----------------------------------------------------------------------
      if(has_lbc(n)) then
         if (fixed_lbc_time(n)) then
            lbc_Time = lbc_entry(n)
         else
            lbc_Time = Time
         end if
         call time_interp( lbc_Time, lb(n)%gas_time(:), frac, index1, index2 )
         r_lb(n) = lb(n)%gas_value(index1) + frac*( lb(n)%gas_value(index2) - lb(n)%gas_value(index1) )
         if(id_lb(n)>0) then
            used = send_data(id_lb(n), r_lb(n), Time)
         end if
         where (pfull(:,:,:) > lb_pres)
            chem_dt(:,:,:,indices(n)) = (r_lb(n) - r(:,:,:,indices(n))) / relaxed_dt_lbc
         endwhere
      end if

   end do
!-----------------------------------------------------------------------
!     ... surface concentration diagnostics
!-----------------------------------------------------------------------
      if ( o3_ndx>0 ) then
         used = send_data(id_srf_o3, r_temp(:,:,size(r_temp,3),o3_ndx), Time, is_in=is, js_in=js)
      end if

   
!-----------------------------------------------------------------------
!     ... special case(nox = no + no2)
!-----------------------------------------------------------------------
!  nno = get_tracer_index(MODEL_ATMOS,'no')
!  nno2 = get_tracer_index(MODEL_ATMOS,'no2')
!  if((nno /= 0) .and. (nno2 /= 0)) then
!     rno(:,:,:) = r(:,:,:,nno)/ MAX((r(:,:,:,nno) + r(:,:,:,nno2)),1.e-30)
     
!     call interpolator(ub, Time,phalf,ub_temp,'nox',is,js)

!     where(pfull(:,:,:) < ub_pres)
!        chem_dt(:,:,:,nno) =((rno(:,:,:)*ub_temp(:,:,:))-r(:,:,:,nno)) / relaxed_dt
!        chem_dt(:,:,:,nno2) = (((1.-rno(:,:,:))*ub_temp(:,:,:))-r(:,:,:,nno2)) / &
!             relaxed_dt
!     endwhere
!  end if

!-----------------------------------------------------------------------
!     ... Chemical families (Cly)
!-----------------------------------------------------------------------
   cly(:,:,:) = 0.
   if (cl_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,cl_ndx)
   end if
   if (clo_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,clo_ndx)
   end if
   if (hcl_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,hcl_ndx)
   end if
   if (hocl_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,hocl_ndx)
   end if
   if (clono2_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,clono2_ndx)
   end if
   if (cl2o2_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,cl2o2_ndx)*2
   end if
   if (cl2_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,cl2_ndx)*2
   end if
   if (clno2_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,clno2_ndx)
   end if
   if (brcl_ndx>0) then
      cly(:,:,:) = cly(:,:,:) + r_temp(:,:,:,brcl_ndx)
   end if

!-----------------------------------------------------------------------
!     ... Cly chemical tendency diagnostic
!-----------------------------------------------------------------------
   if (id_dclydt_chem>0) then
      used = send_data(id_dclydt_chem, (cly(:,:,:)-cly0(:,:,:))/dt, Time, is_in=is, js_in=js)
   end if

!-----------------------------------------------------------------------
!     ... Cly conservation
!-----------------------------------------------------------------------
   if (force_cly_conservation .or. rescale_cly_components) then
      if (rescale_cly_components) then
         cly_ratio(:,:,:) = r(:,:,:,cly_ndx) / MAX( cly(:,:,:), small )
         cly(:,:,:) = r(:,:,:,cly_ndx)
      else if (force_cly_conservation) then
         cly_ratio(:,:,:) = cly0(:,:,:) / MAX( cly(:,:,:), small )
         cly(:,:,:) = cly0(:,:,:)
      end if
      if (cl_ndx>0) then
         r_temp(:,:,:,cl_ndx) = r_temp(:,:,:,cl_ndx) * cly_ratio(:,:,:)
      end if
      if (clo_ndx>0) then
         r_temp(:,:,:,clo_ndx) = r_temp(:,:,:,clo_ndx) * cly_ratio(:,:,:)
      end if
      if (hcl_ndx>0) then
         r_temp(:,:,:,hcl_ndx) = r_temp(:,:,:,hcl_ndx) * cly_ratio(:,:,:)
      end if
      if (hocl_ndx>0) then
         r_temp(:,:,:,hocl_ndx) = r_temp(:,:,:,hocl_ndx) * cly_ratio(:,:,:)
      end if
      if (clono2_ndx>0) then
         r_temp(:,:,:,clono2_ndx) = r_temp(:,:,:,clono2_ndx) * cly_ratio(:,:,:)
      end if
      if (cl2o2_ndx>0) then
         r_temp(:,:,:,cl2o2_ndx) = r_temp(:,:,:,cl2o2_ndx) * cly_ratio(:,:,:)
      end if
      if (cl2_ndx>0) then
         r_temp(:,:,:,cl2_ndx) = r_temp(:,:,:,cl2_ndx) * cly_ratio(:,:,:)
      end if
      if (clno2_ndx>0) then
         r_temp(:,:,:,clno2_ndx) = r_temp(:,:,:,clno2_ndx) * cly_ratio(:,:,:)
      end if
      if (brcl_ndx>0) then
         r_temp(:,:,:,brcl_ndx) = r_temp(:,:,:,brcl_ndx) * cly_ratio(:,:,:)
      end if
   end if

!-----------------------------------------------------------------------
!     ... Chemical families (Bry, NOy)
!-----------------------------------------------------------------------
   bry(:,:,:) = 0.
   noy(:,:,:) = 0.
   if (clono2_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,clono2_ndx)
   end if
   if (br_ndx>0) then
      bry(:,:,:) = bry(:,:,:) + r_temp(:,:,:,br_ndx)
   end if
   if (bro_ndx>0) then
      bry(:,:,:) = bry(:,:,:) + r_temp(:,:,:,bro_ndx)
   end if
   if (hbr_ndx>0) then
      bry(:,:,:) = bry(:,:,:) + r_temp(:,:,:,hbr_ndx)
   end if
   if (hobr_ndx>0) then
      bry(:,:,:) = bry(:,:,:) + r_temp(:,:,:,hobr_ndx)
   end if
   if (brono2_ndx>0) then
      bry(:,:,:) = bry(:,:,:) + r_temp(:,:,:,brono2_ndx)
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,brono2_ndx)
   end if
   if (brcl_ndx>0) then
      bry(:,:,:) = bry(:,:,:) + r_temp(:,:,:,brcl_ndx)
   end if
   if (n_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,n_ndx)
   end if
   if (no_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,no_ndx)
   end if
   if (no2_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,no2_ndx)
   end if
   if (no3_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,no3_ndx)
   end if
   if (hno3_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,hno3_ndx)
   end if
   if (n2o5_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,n2o5_ndx)*2
   end if
   if (ho2no2_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,ho2no2_ndx)
   end if
   if (pan_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,pan_ndx)
   end if
   if (mpan_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,mpan_ndx)
   end if
   if (onit_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,onit_ndx)
   end if
   if (isopno3_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,isopno3_ndx)
   end if
   if (onitr_ndx>0) then
      noy(:,:,:) = noy(:,:,:) + r_temp(:,:,:,onitr_ndx)
   end if

!-----------------------------------------------------------------------
!     ... stratospheric Cly and Bry source
!-----------------------------------------------------------------------
   if(age_ndx > 0 .and. age_ndx <= ntp) then
      call strat_chem_dcly_dt(Time, phalf, is, js, age, cly, bry, dclydt, dbrydt)
      do k = 1,kd
         where( coszen(:,:) > 0. )
            dclydt(:,:,k) = 2*dclydt(:,:,k)
            dbrydt(:,:,k) = 2*dbrydt(:,:,k)
         elsewhere
            dclydt(:,:,k) = 0.
            dbrydt(:,:,k) = 0.
         end where
      end do
   else
      dclydt(:,:,:) = 0.
      dbrydt(:,:,:) = 0.
   end if
   if (cl_ndx>0) then
      chem_dt(:,:,:,indices(cl_ndx)) = chem_dt(:,:,:,indices(cl_ndx)) + dclydt(:,:,:)
      used = send_data(id_dclydt, dclydt, Time, is_in=is, js_in=js)
   end if
   if (br_ndx>0) then
      chem_dt(:,:,:,indices(br_ndx)) = chem_dt(:,:,:,indices(br_ndx)) + dbrydt(:,:,:)
      used = send_data(id_dbrydt, dbrydt, Time, is_in=is, js_in=js)
   end if
   
!-----------------------------------------------------------------------
!     ... Set diagnostic tracers for chemical families
!-----------------------------------------------------------------------
   if (noy_ndx > ntp) then
      rdiag(:,:,:,noy_ndx-ntp) = noy(:,:,:)
   end if
   if (cly_ndx > ntp) then
      rdiag(:,:,:,cly_ndx-ntp) = cly(:,:,:) + dclydt(:,:,:)*dt
   else if (cly_ndx > 0) then
      chem_dt(:,:,:,cly_ndx) = dclydt(:,:,:)
   end if
   if (bry_ndx > ntp) then
      rdiag(:,:,:,bry_ndx-ntp) = bry(:,:,:) + dbrydt(:,:,:)*dt
   end if

!-----------------------------------------------------------------------
!     ... Photolysis rates
!-----------------------------------------------------------------------
   do n = 1,phtcnt
      if(id_jval(n)>0) then
         used = send_data(id_jval(n),jvals(:,:,:,n),Time,is_in=is,js_in=js)
      end if
   end do

!-----------------------------------------------------------------------
!     ... Kinetic reaction rates
!-----------------------------------------------------------------------
   do n = 1,gascnt
      if(id_rate_const(n)>0) then
         used = send_data(id_rate_const(n),rate_constants(:,:,:,n),Time,is_in=is,js_in=js)
      end if
   end do

!-----------------------------------------------------------------------
!     ... Output diagnostics
!-----------------------------------------------------------------------
   used = send_data(id_volc_aer, strat_aerosol, Time, is_in=is, js_in=js)
   used = send_data(id_psc_sat, psc_vmr_save(:,:,:,1), Time, is_in=is, js_in=js)
   used = send_data(id_psc_nat, psc_vmr_save(:,:,:,2), Time, is_in=is, js_in=js)
   used = send_data(id_psc_ice, psc_vmr_save(:,:,:,3), Time, is_in=is, js_in=js)
   if (id_h2o_chem>0) then
      if (sphum_ndx>0) then
         used = send_data(id_h2o_chem, r_temp(:,:,:,sphum_ndx), Time, is_in=is, js_in=js)
      else
         used = send_data(id_h2o_chem, q(:,:,:)*WTMAIR/WTMH2O, Time, is_in=is, js_in=js)
      end if
   end if      
   used = send_data(id_coszen, coszen_local(:,:), Time, is_in=is, js_in=js)
   used = send_data(id_imp_slv_nonconv,imp_slv_nonconv(:,:,:),Time,is_in=is,js_in=js)

!-----------------------------------------------------------------------
!     ... convert H2O VMR tendency to specific humidity tendency
!-----------------------------------------------------------------------
   if (sphum_ndx > 0) then
      n = indices(sphum_ndx)
      chem_dt(:,:,:,n) = chem_dt(:,:,:,n) * WTMH2O / WTMAIR
!     chem_dt(:,:,:,n) = 0.
   end if

!  call mpp_clock_end(clock_id)
   
!-----------------------------------------------------------------------
    
end subroutine tropchem_driver
!</SUBROUTINE>

!#######################################################################

! <FUNCTION NAME="tropchem_driver_init">
!   <OVERVIEW>
!     Initializes the tropospheric chemistry driver.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine initializes the tropospheric chemistry module.
!     It is called from atmos_tracer_driver_init.
!     Data sets are read in for dry deposition, upper boundary conditions,
!     and emissions. Off-line sulfate concentrations are also read in for
!     use in calculating heterogeneous reaction rates (if SO4 is not
!     included as a tracer).
!   </DESCRIPTION>
!   <TEMPLATE>
!     Ltropchem = tropchem_driver_init( r, mask, axes, Time, &
!                                       lonb_mod, latb_mod, phalf, &
!                                       drydep_data )
!   </TEMPLATE>
!   <IN NAME="mask" TYPE="real, optional" DIM="(:,:,:)">
!      optional mask that designates which grid points
!      are above (1) or below (0) the ground
!   </IN>
!   <IN NAME="axes" TYPE="integer" DIM="(4)">
!     The axes relating to the tracer array
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>
!   <IN NAME="lonb_mod" TYPE="real" DIM="(:,:)">
!     The longitude corners for the local domain.
!   </IN>
!   <IN NAME="latb_mod" TYPE="real" DIM="(:,:)">
!     The latitude corners for the local domain.
!   </IN>
!   <IN NAME="phalf" TYPE="real" DIM="(:,:,:)">
!     Pressure on the model half levels (Pa)
!   </IN>
!   <OUT NAME="drydep_data" TYPE="interpolate_type" DIM="(:)">
!     Tracer dry deposition velocities
!   </OUT>
!   <OUT NAME="Ltropchem" TYPE="logical">
!     Do tropospheric chemistry? (Output as function value)
!   </OUT>
!   <INOUT NAME="r" TYPE="real" DIM="(:,:,:,:)">
!     Tracer mixing ratios (tropchem tracers in VMR)
!   </INOUT>

function tropchem_driver_init( r, mask, axes, Time, &
                               lonb_mod, latb_mod, phalf, &
                               drydep_data ) result(Ltropchem)

!-----------------------------------------------------------------------
!
!   r    = tracer fields dimensioned as (nlon,nlat,nlev,ntrace)
!   mask = optional mask (0. or 1.) that designates which grid points
!          are above (=1.) or below (=0.) the ground dimensioned as
!          (nlon,nlat,nlev).
!
!-----------------------------------------------------------------------
   real, intent(inout), dimension(:,:,:,:) :: r
   real, intent(in),    dimension(:,:,:), optional :: mask
   type(time_type), intent(in) :: Time
   integer        , intent(in) :: axes(4)
   real, intent(in), dimension(:,:) :: lonb_mod
   real, intent(in), dimension(:,:) :: latb_mod
   real, intent(in),dimension(:,:,:) :: phalf
   type(interpolate_type), intent(out) :: drydep_data(:)

   logical :: Ltropchem
   integer :: flag_file, flag_spec, flag_fixed
   integer :: n,i
   integer :: ierr, io, logunit
   character(len=64) :: nc_file,filename,specname
   character(len=256) :: control=''
   character(len=64) :: name=''
   type(interpolate_type) :: init_conc
   character(len=64),dimension(pcnstm1) :: emis_files = '', &
                                           emis3d_files = '', &
                                           conc_files = '', &
                                           ub_files = '', &
                                           lb_files = '', &
                                           dry_files, &
                                           wet_ind, &
                                           conc_names, &
                                           dry_names, &
                                           airc_files
   logical :: tracer_initialized

   integer :: unit
   character(len=16) ::  fld

   integer :: flb, series_length, year, diy
   real :: input_time
   real :: scale_factor, extra_seconds, fixed_year
   type(time_type) :: Year_t
!
!-----------------------------------------------------------------------
!
   if (module_is_initialized) return

!-----------------------------------------------------------------------
!     ... write version number
!-----------------------------------------------------------------------
   call write_version_number(version, tagname)
    
!-----------------------------------------------------------------------
!     ... read namelist
!-----------------------------------------------------------------------
   if(file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=tropchem_driver_nml, iostat=io)
      ierr = check_nml_error(io,'tropchem_driver_nml')
#else
      unit = open_namelist_file('input.nml')
      ierr=1; do while (ierr /= 0)
      read(unit, nml = tropchem_driver_nml, iostat=io, end=10)
      ierr = check_nml_error (io, 'tropchem_driver_nml')
      end do
10    call close_file(unit)
#endif
   end if
  
   logunit = stdlog()
   if(mpp_pe() == mpp_root_pe()) then       
      write(logunit, nml=tropchem_driver_nml)
      verbose = verbose + 1
   end if

   Ltropchem = do_tropchem
   if (.not. Ltropchem) then
      return
   end if
     
!-----------------------------------------------------------------------
!     ... Setup sulfate input/interpolation
!-----------------------------------------------------------------------
   call interpolator_init( sulfate, trim(file_sulfate), lonb_mod, latb_mod, &
                           data_out_of_bounds=(/CONSTANT/),      &
                           vert_interp=(/INTERP_WEIGHTED_P/) )

!-----------------------------------------------------------------------
!     ... Initialize chemistry driver
!-----------------------------------------------------------------------
   call chemini( file_jval_lut, file_jval_lut_min, use_tdep_jvals, &
                 o3_column_top, jno_scale_factor, verbose )
   
!-----------------------------------------------------------------------
!     ... set initial value of indices
!-----------------------------------------------------------------------
   indices(:) = 0
   do i=1,pcnstm1
      n = get_tracer_index(MODEL_ATMOS, tracnam(i))
      if (trim(tracnam(i)) == 'H2O') then
         if (n <= 0) then
            n = get_tracer_index(MODEL_ATMOS, 'sphum')
         end if
         sphum_ndx = i
         do_interactive_h2o = .true.
      end if
      if (n >0) then
         indices(i) = n
         if (indices(i) > 0 .and. mpp_pe() == mpp_root_pe()) then 
            write(*,30) tracnam(i),indices(i)
            write(logunit,30) trim(tracnam(i)),indices(i)
         end if
      else
!<ERROR MSG="Tropospheric chemistry tracer not found in field table" STATUS="WARNING">
!   A tropospheric chemistry tracer was not included in the field table
!</ERROR>
         call error_mesg ('tropchem_driver_init', trim(tracnam(i)) // ' is not found', WARNING)
      end if
   end do
30 format (A,' was initialized as tracer number ',i3)

   cl_ndx     = get_spc_ndx('Cl')
   clo_ndx    = get_spc_ndx('ClO')
   hcl_ndx    = get_spc_ndx('HCl')
   hocl_ndx   = get_spc_ndx('HOCl')
   clono2_ndx = get_spc_ndx('ClONO2')
   cl2o2_ndx  = get_spc_ndx('Cl2O2')
   cl2_ndx    = get_spc_ndx('Cl2')
   clno2_ndx  = get_spc_ndx('ClNO2')
   br_ndx     = get_spc_ndx('Br')
   bro_ndx    = get_spc_ndx('BrO')
   hbr_ndx    = get_spc_ndx('HBr')
   hobr_ndx   = get_spc_ndx('HOBr')
   brono2_ndx = get_spc_ndx('BrONO2')
   brcl_ndx   = get_spc_ndx('BrCl')
   hno3_ndx   = get_spc_ndx('HNO3')
   no_ndx     = get_spc_ndx('NO')
   no2_ndx    = get_spc_ndx('NO2')
   no3_ndx    = get_spc_ndx('NO3')
   n_ndx      = get_spc_ndx('N')
   n2o5_ndx   = get_spc_ndx('N2O5')
   ho2no2_ndx = get_spc_ndx('HO2NO2')
   pan_ndx    = get_spc_ndx('PAN')
   onit_ndx   = get_spc_ndx('ONIT')
   mpan_ndx   = get_spc_ndx('MPAN')
   isopno3_ndx= get_spc_ndx('ISOPNO3')
   onitr_ndx  = get_spc_ndx('ONITR')
   o3_ndx     = get_spc_ndx('O3')
   ch4_ndx    = get_spc_ndx('CH4')
   dms_ndx    = get_spc_ndx('DMS')

   extinct_ndx = get_tracer_index(MODEL_ATMOS, 'Extinction')
   noy_ndx     = get_tracer_index(MODEL_ATMOS, 'NOy')
   cly_ndx     = get_tracer_index(MODEL_ATMOS, 'Cly')
   bry_ndx     = get_tracer_index(MODEL_ATMOS, 'Bry')

!-----------------------------------------------------------------------
!     ... Check Cly settings
!-----------------------------------------------------------------------
   if (rescale_cly_components) then
      if (cly_ndx == NO_TRACER .or. .not. check_if_prognostic(MODEL_ATMOS,cly_ndx)) then
         call error_mesg ('tropchem_driver_init', &
                          'rescale_cly_components=T requires Cly to be registered as a prognostic tracer', FATAL)
      end if
      if (force_cly_conservation) then
         call error_mesg ('tropchem_driver_init', &
                          'rescale_cly_components=T incompatible with force_cly_conservation=T setting', FATAL)
      end if
   end if

!-----------------------------------------------------------------------
!     ... Setup dry deposition
!-----------------------------------------------------------------------
   call tropchem_drydep_init( dry_files, dry_names, &
                              lonb_mod, latb_mod, &
                              drydep_data )

!-----------------------------------------------------------------------
!     ... Setup upper boundary condition data
!-----------------------------------------------------------------------
   call interpolator_init( ub_default, trim(file_ub), lonb_mod, latb_mod, &
                           data_out_of_bounds=(/CONSTANT/),          &
                           vert_interp=(/INTERP_WEIGHTED_P/) )

!-----------------------------------------------------------------------
!     ... Set up concentration input/interpolation
!-----------------------------------------------------------------------
   call interpolator_init( conc, trim(file_conc), lonb_mod, latb_mod, &
                           data_out_of_bounds=(/CONSTANT/),&
                           vert_interp=(/INTERP_WEIGHTED_P/) )

!-----------------------------------------------------------------------
!     ... Set up aircraft emissions interpolation
!-----------------------------------------------------------------------
   call interpolator_init( airc_default, trim(file_aircraft), lonb_mod, latb_mod,&
                           data_out_of_bounds=(/CONSTANT/), &
                           vert_interp=(/INTERP_WEIGHTED_P/))

!-----------------------------------------------------------------------
!     ... Setup emissions input/interpolation
!-----------------------------------------------------------------------
   do i = 1,pcnstm1
      nc_file = trim(file_emis_1)//lowercase(trim(tracnam(i)))//trim(file_emis_2)
      call init_emis_data( inter_emis(i), MODEL_ATMOS, 'emissions', indices(i), nc_file, &
                           lonb_mod, latb_mod, emis_field_names(i), &
                           has_emis(i), diurnal_emis(i), axes, Time )
      if( has_emis(i) ) emis_files(i) = trim(nc_file)
        
!-----------------------------------------------------------------------
!     ... Vertically-distributed emissions
!-----------------------------------------------------------------------
      nc_file = trim(file_emis3d_1)//lowercase(trim(tracnam(i)))//trim(file_emis3d_2)
      call init_emis_data( inter_emis3d(i), MODEL_ATMOS, 'emissions3d', indices(i), nc_file, &
                           lonb_mod, latb_mod, emis3d_field_names(i), &
                           has_emis3d(i), diurnal_emis3d(i), axes, Time )
      if( has_emis3d(i) ) emis3d_files(i) = trim(nc_file)

!-----------------------------------------------------------------------
!     ... Interactive emissions
!-----------------------------------------------------------------------
      call init_xactive_emis( MODEL_ATMOS, 'xactive_emissions', indices(i), tracnam(i), &
                              axes, Time, lonb_mod, latb_mod, phalf, &
                              has_xactive_emis(i), id_xactive_emis(i), mask )

!-----------------------------------------------------------------------
!     ... Upper boundary condition
!-----------------------------------------------------------------------
      if( query_method('upper_bound', MODEL_ATMOS,indices(i),name,control) ) then
         if( trim(name)=='file' ) then
            flag_file = parse(control, 'file',filename)
            flag_spec = parse(control, 'name',specname)

            if( flag_file > 0 .and. trim(filename) /= trim(file_ub) ) then
               ub_files(i) = trim(filename)
               call interpolator_init(ub(i), trim(filename), lonb_mod, latb_mod, &
                       data_out_of_bounds=(/CONSTANT/),          &
                       vert_interp=(/INTERP_WEIGHTED_P/))
            else
               ub_files(i) = trim(file_ub)
               ub(i) = ub_default
            end if
            if(flag_spec > 0) then
               ub_names(i) = trim(specname)
            else
               ub_names(i) = trim(lowercase(tracnam(i)))
            end if

            has_ubc(i) = .true.
              
         end if
      end if

!-----------------------------------------------------------------------
!     ... Lower boundary condition
!-----------------------------------------------------------------------
      lbc_entry(i) = get_base_time()     
      if( query_method('lower_bound', MODEL_ATMOS,indices(i),name,control) ) then
         if( trim(name)=='file' ) then
            flag_file = parse(control, 'file', filename)
            flag_spec = parse(control, 'factor', scale_factor)
            flag_fixed = parse(control, 'fixed_year', fixed_year)
            if( flag_file > 0 ) then
               lb_files(i) = 'INPUT/' // trim(filename)
               if( file_exist(lb_files(i)) ) then
                  flb = open_namelist_file( lb_files(i) )
                  read(flb, FMT='(i12)') series_length
                  allocate( lb(i)%gas_value(series_length), &
                            lb(i)%gas_time(series_length) )
!---------------------------------------------------------------------
!    convert the time stamps of the series to time_type variables.     
!---------------------------------------------------------------------
                  do n = 1,series_length
                     read (flb, FMT = '(2f12.4)') input_time, lb(i)%gas_value(n)
                     year = INT(input_time)
                     Year_t = set_date(year,1,1,0,0,0)
                     diy = days_in_year (Year_t)
                     extra_seconds = (input_time - year)*diy*SECONDS_PER_DAY 
                     lb(i)%gas_time(n) = Year_t + set_time(NINT(extra_seconds), 0)
                  end do
                  if (flag_spec > 0) then
                     lb(i)%gas_value(:) = lb(i)%gas_value(:) * scale_factor
                  end if
                  call close_file( flb )
                  if( flag_fixed > 0 ) then
                     fixed_lbc_time(i) = .true.
                     year = INT(fixed_year)
                     Year_t = set_date(year,1,1,0,0,0)
                     diy = days_in_year (Year_t)
                     extra_seconds = (fixed_year - year)*diy*SECONDS_PER_DAY 
                     lbc_entry(i) = Year_t + set_time(NINT(extra_seconds), 0)
                  end if
               else
                  call error_mesg ('tropchem_driver_init', &
                                   'Failed to find input file '//trim(lb_files(i)), FATAL)
               end if
            else
               call error_mesg ('tropchem_driver_init', 'Tracer '//trim(lowercase(tracnam(i)))// &
                                ' has lower_bound specified without a filename', FATAL)
            end if
            has_lbc(i) = .true.
         end if
      end if

!-----------------------------------------------------------------------
!     ... Initial conditions
!-----------------------------------------------------------------------
      tracer_initialized = .false.
      if ( field_exist('INPUT/atmos_tracers.res.nc', lowercase(tracnam(i))) .or. &
           field_exist('INPUT/fv_tracer.res.nc', lowercase(tracnam(i))) .or. &
           field_exist('INPUT/tracer_'//trim(lowercase(tracnam(i)))//'.res', lowercase(tracnam(i))) ) then
         tracer_initialized = .true.
      end if

      if(.not. tracer_initialized) then
         if( query_method('init_conc',MODEL_ATMOS,indices(i),name,control) ) then
            if( trim(name) == 'file' ) then
               flag_file = parse(control, 'file',filename)
               flag_spec = parse(control, 'name',specname)

               if( flag_file>0 .and. trim(filename) /= trim(file_conc) ) then
                  conc_files(i) = trim(filename)
                  call interpolator_init( init_conc,trim(filename),lonb_mod,latb_mod,&
                                          data_out_of_bounds=(/CONSTANT/), &
                                          vert_interp=(/INTERP_WEIGHTED_P/) )
               else
                  conc_files(i) = trim(file_conc)
                  init_conc = conc
               end if
                  
               if( flag_spec > 0 ) then
                  conc_names(i) = trim(lowercase(specname))
                  specname = lowercase(specname)
               else
                  conc_names(i) = trim(lowercase(tracnam(i)))
                  specname = trim(lowercase(tracnam(i)))
               end if
                  
               call interpolator(init_conc, Time, phalf,r(:,:,:,indices(i)),trim(specname))
            end if
         end if
      end if
             
!-----------------------------------------------------------------------
!     ... Aircraft emissions
!-----------------------------------------------------------------------
      if( query_method('aircraft_emis',MODEL_ATMOS,indices(i),name,control) ) then
         has_airc(i) = .true.
         if( trim(name) == 'file' ) then
            flag_file = parse(control,'file',filename)
            flag_spec = parse(control,'name',specname)

            if( flag_file >0 .and. trim(filename) /= trim(lowercase(file_aircraft)) ) then
               airc_files(i) = trim(filename)
               call interpolator_init( inter_aircraft_emis(i),trim(filename), lonb_mod, latb_mod, &
                                       data_out_of_bounds=(/CONSTANT/), &
                                       vert_interp=(/INTERP_WEIGHTED_P/) )
            else
               airc_files(i) = trim(file_aircraft)
               inter_aircraft_emis(i) = airc_default
            end if
               
            if( flag_spec >0 ) then
               airc_names(i) = trim(specname)
            else
               airc_names(i) = trim(lowercase(tracnam(i)))
            end if
         end if
      end if

             
!-----------------------------------------------------------------------
!     ... Wet deposition
!-----------------------------------------------------------------------
      if( query_method('wet_deposition',MODEL_ATMOS,indices(i),name,control) ) then
         wet_ind(i) = 'This species has wet deposition'
      else
         wet_ind(i) = ''
      end if
         
   end do
   
!-----------------------------------------------------------------------
!     ... Print out settings for tracer
!-----------------------------------------------------------------------
   if( mpp_pe() == mpp_root_pe() ) then
      write(logunit,*) '---------------------------------------------------------------------------------------'
      do i = 1,pcnstm1
         write(logunit,*) 'The tracname index is ',i
         write(logunit,*) 'The tracname is ',tracnam(i)
         if(check_if_prognostic(MODEL_ATMOS,indices(i))) then
            write(logunit,*) 'This is a prognostic tracer.'
         else
            write(logunit,*) 'This is a diagnostic tracer.'
         end if
         if(has_emis(i)) then
            write(logunit,*)'Emissions from file: ',trim(emis_files(i))
         end if
         if(has_emis3d(i)) then
            write(logunit,*)'3-D Emissions from file: ',trim(emis3d_files(i))
         end if
         if(has_ubc(i)) then
            write(logunit,*)'Upper BC from file: ',trim(ub_files(i)), &
                             ', with the name of ',trim(ub_names(i))
         end if
         if(has_lbc(i)) then
            write(logunit,*)'Lower BC from file: ',trim(lb_files(i))
            if (fixed_lbc_time(i)) then
               write(logunit,*) '... with fixed year'
            end if
         end if
         if(conc_files(i) /= '') then
            write(logunit,*)'Concentration from file: ',trim(conc_files(i)), &
                             ', with the name of ',trim(conc_names(i))
         end if
         if(dry_files(i) /= '') then
            write(logunit,*)'Dry deposition velocity from file: ',trim(dry_files(i)), &
                             ' with the name of '//trim(dry_names(i))
         end if
         if(wet_ind(i) /= '') then
            write(logunit,*) wet_ind(i)
         end if
         if(has_airc(i)) then
            write(logunit,*)'Aircraft emissions from file: ',trim(airc_files(i)), &
                             ' with the name of '//trim(airc_names(i))
         end if
         write(logunit,*) '---------------------------------------------------------------------------------------'
      end do
   end if


!-----------------------------------------------------------------------
!     ... Get the index number for the cloud variables
!-----------------------------------------------------------------------
   inqa = get_tracer_index(MODEL_ATMOS,'cld_amt') ! cloud fraction
   inql = get_tracer_index(MODEL_ATMOS,'liq_wat') ! cloud liquid specific humidity
   inqi = get_tracer_index(MODEL_ATMOS,'ice_wat') ! cloud ice water specific humidity
      
   age_ndx = get_tracer_index(MODEL_ATMOS,'age')  ! age tracer

!-----------------------------------------------------------------------
!     ... Call the chemistry hook init routine
!-----------------------------------------------------------------------
   call moz_hook_init( lght_no_prd_factor, Time, axes, verbose )

!-----------------------------------------------------------------------
!     ... Initializations for stratospheric chemistry
!-----------------------------------------------------------------------
!++lwh
   if (set_min_h2o_strat) then
      if (ch4_ndx>0) then
         if (.not. has_lbc(ch4_ndx)) then
            call error_mesg ('Tropchem_driver','set_min_h2o_strat=T, but LBC not set for CH4', FATAL)
         end if
      else
         call error_mesg ('Tropchem_driver','set_min_h2o_strat=T, but CH4 not included in chemistry solver', FATAL)
      end if
   end if
   call strat_chem_utilities_init( lonb_mod, latb_mod, &
                                   strat_chem_age_factor, strat_chem_dclydt_factor, &
                                   set_min_h2o_strat, ch4_filename, ch4_scale_factor, &
                                   fixed_lbc_time(ch4_ndx), lbc_entry(ch4_ndx), &
                                   cfc_lbc_filename, time_varying_cfc_lbc, cfc_lbc_dataset_entry )
!--lwh
   id_dclydt      = register_diag_field( module_name, 'cly_chem_dt', axes(1:3), Time, 'cly_chem_dt', 'VMR/s' )
   id_dclydt_chem = register_diag_field( module_name, 'cly_chem_dt_diag', axes(1:3), Time, 'cly_chem_dt_diag', 'VMR/s' )
   id_dbrydt      = register_diag_field( module_name, 'bry_chem_dt', axes(1:3), Time, 'bry_chem_dt', 'VMR/s' )

   id_volc_aer = register_diag_field( module_name, 'volc_aer_SA', axes(1:3), Time, 'volcanic_aerosol_surface_area', 'cm2/cm3' )
   id_psc_sat  = register_diag_field( module_name, 'psc_sat', axes(1:3), Time, 'psc_sat', 'VMR' )
   id_psc_nat  = register_diag_field( module_name, 'psc_nat', axes(1:3), Time, 'psc_nat', 'VMR' )
   id_psc_ice  = register_diag_field( module_name, 'psc_ice', axes(1:3), Time, 'psc_ice', 'VMR' )
   id_h2o_chem = register_diag_field( module_name, 'h2o_chem', axes(1:3), Time, 'h2o_chem', 'VMR' )

!-----------------------------------------------------------------------
!     ... Initialize additional diagnostics
!-----------------------------------------------------------------------
   id_sul = register_diag_field( module_name, 'sulfate', axes(1:3), Time, 'sulfate', 'VMR' )
   id_coszen = register_diag_field( module_name, 'coszen_tropchem', axes(1:2), Time, &
                                             'cosine_sza_tropchem', 'none' )
   id_imp_slv_nonconv = register_diag_field( module_name, 'imp_slv_nonconv', axes(1:3), Time, &
                                             'tropchem_implicit_solver_not_converged', 'VMR' )
   id_srf_o3 = register_diag_field( module_name, 'o3_srf', axes(1:2), Time, 'o3_srf', 'VMR' )

!-----------------------------------------------------------------------
!     ... Register diagnostic fields for species tendencies
!-----------------------------------------------------------------------
   id_co_emis_cmip =     &
        register_diag_field( module_name, 'co_emis_cmip', axes(1:2), &
                             Time, 'co_emis_cmip', 'kg/m2/s')
   id_no_emis_cmip =     &
        register_diag_field( module_name, 'no_emis_cmip', axes(1:2), &
                            Time, 'no_emis_cmip', 'kg/m2/s')  
   id_so2_emis_cmip =     &
        register_diag_field( module_name, 'so2_emis_cmip', axes(1:2), &
                             Time, 'so2_emis_cmip', 'kg/m2/s')
   id_nh3_emis_cmip =     &
        register_diag_field( module_name, 'nh3_emis_cmip', axes(1:2), &
                            Time, 'nh3_emis_cmip', 'kg/m2/s')  

   id_co_emis_cmip2 =     &
        register_diag_field( module_name, 'co_emis_cmip2', axes(1:2), &
                             Time, 'co_emis_cmip2', 'kg/m2/s')
   id_no_emis_cmip2 =     &
        register_diag_field( module_name, 'no_emis_cmip2', axes(1:2), &
                            Time, 'no_emis_cmip2', 'kg/m2/s')  
   id_so2_emis_cmip2 =     &
        register_diag_field( module_name, 'so2_emis_cmip2', axes(1:2), &
                             Time, 'so2_emis_cmip2', 'kg/m2/s')
   id_nh3_emis_cmip2 =     &
        register_diag_field( module_name, 'nh3_emis_cmip2', axes(1:2), &
                            Time, 'nh3_emis_cmip2', 'kg/m2/s')  

   do i=1,pcnstm1
      id_chem_tend(i) = register_diag_field( module_name, trim(tracnam(i))//'_chem_dt', axes(1:3), &
                                             Time, trim(tracnam(i))//'_chem_dt','VMR/s' )
      id_prod(i) = register_diag_field( module_name, trim(tracnam(i))//'_prod', axes(1:3), &
                                        Time, trim(tracnam(i))//'_prod','VMR/s')
      id_loss(i) = register_diag_field( module_name, trim(tracnam(i))//'_loss', axes(1:3), &
                                        Time, trim(tracnam(i))//'_loss','VMR/s')
      if( has_emis(i) ) then
         id_emis(i) = register_diag_field( module_name, trim(tracnam(i))//'_emis', axes(1:2), &
                                           Time, trim(tracnam(i))//'_emis', 'molec/cm2/s')
      else
         id_emis(i) = 0
      end if
      if( has_emis3d(i) ) then
         id_emis3d(i) = register_diag_field( module_name, trim(tracnam(i))//'_emis3d', axes(1:3), &
                                             Time, trim(tracnam(i))//'_emis3d', 'molec/cm2/s')
      else
         id_emis3d(i) = 0
      end if
!     if( has_xactive_emis(i) ) then
         select case (trim(tracnam(i)))
         case ('ISOP')
               id_glaiage = register_diag_field( module_name, 'gamma_lai_age', axes(1:2), &
                    Time, 'gamma_lai_age', 'unitless' )
               id_gtemp = register_diag_field( module_name, 'gamma_temp', axes(1:2), &
                    Time, 'gamma_temp', 'unitless' )
               id_glight = register_diag_field( module_name, 'gamma_light', axes(1:2), &
                    Time, 'gamma_light', 'unitless' )
               id_tsfc = register_diag_field( module_name, 'tsfcair', axes(1:2), &
                    Time, 'tsfcair', 'K' )
               id_fsds = register_diag_field( module_name, 'fsdvd', axes(1:2), &
                    Time, 'fsdvd', 'W/m2' )
               id_ctas = register_diag_field( module_name, 'clim_tas', axes(1:2), &
                    Time, 'clim_tas', 'K' )
               id_cfsds = register_diag_field( module_name, 'clim_fsds', axes(1:2), &
                    Time, 'clim_fsds', 'umol/m2/s PAR' )
         case default
         end select
!     else
!        id_xactive_emis(i) = 0
!     end if
      if( has_ubc(i) ) then
         id_ub(i) = register_diag_field( module_name, trim(tracnam(i))//'_up', axes(1:3), &
                                         Time, trim(tracnam(i))//'_up','VMR' )
      else
         id_ub(i) = 0
      end if
      if( has_lbc(i) ) then
         id_lb(i) = register_diag_field( module_name, trim(tracnam(i))//'_lbc', &
                                         Time, trim(tracnam(i))//'_lbc','VMR' )
      else
         id_lb(i) = 0
      end if
      if( has_airc(i) ) then
         id_airc(i) = register_diag_field( module_name, trim(tracnam(i))//'_airc_emis', axes(1:3), &
                                           Time, trim(tracnam(i))//'_airc_emis','molec/cm2/s' )
      else
         id_airc(i) = 0
      end if
   end do

!-----------------------------------------------------------------------
!     ... Register diagnostic fields for photolysis rates
!-----------------------------------------------------------------------
   do i=1,phtcnt
      write(fld,'(''jval_'',I3.3,8x)') i
      id_jval(i) = register_diag_field( module_name, TRIM(fld), axes(1:3), Time, TRIM(fld),'1/s')
   end do

!-----------------------------------------------------------------------
!     ... Register diagnostic fields for kinetic rate constants
!-----------------------------------------------------------------------
   do i=1,gascnt
      write(fld,'(''k_rxn'',I3.3,8x)') i
      id_rate_const(i) = register_diag_field( module_name, TRIM(fld), axes(1:3), Time, TRIM(fld),'cm3/molec/s')
   end do

!-----------------------------------------------------------------------
!     ... initialize time_interp
!-----------------------------------------------------------------------
   call time_interp_init
      

!-----------------------------------------------------------------------
!     ... initialize esfsw_parameters
!-----------------------------------------------------------------------
   call esfsw_parameters_init

!-----------------------------------------------------------------------
!     ... initialize mpp clock id
!-----------------------------------------------------------------------
!  clock_id = mpp_clock_id('Chemistry')
      
   module_is_initialized = .true.
      
      
!-----------------------------------------------------------------------
      
end function tropchem_driver_init
!</FUNCTION>
 
!#####################################################################

subroutine tropchem_driver_time_vary (Time)

type(time_type), intent(in) :: Time

      integer :: yr, mo,day, hr,min, sec
      integer :: n

      do n=1, size(inter_emis,1)
        if (has_emis(n)) then
          call obtain_interpolator_time_slices (inter_emis(n), Time)
        endif
      end do

      do n=1, size(inter_emis3d,1)
        if (has_emis3d(n)) then
          call obtain_interpolator_time_slices (inter_emis3d(n), Time)
        endif
      end do

      do n=1, size(inter_aircraft_emis,1)
        if (has_airc(n)) then
          call obtain_interpolator_time_slices   &
                                         (inter_aircraft_emis(n), Time)
        endif
      end do

      call obtain_interpolator_time_slices (conc, Time)

      call obtain_interpolator_time_slices (sulfate, Time)

      do n=1, size(ub,1)
        if (has_ubc(n)) then
          call obtain_interpolator_time_slices (ub(n), Time)
        endif
      end do

      call strat_chem_dcly_dt_time_vary (Time)

!----------------------------------------------------------------------
!    determine if this time step starts a new month; if so, then
!    new interactive isoprene emission data is needed, and the 
!    necessary flag is set.
!----------------------------------------------------------------------
      do n=1,pcnstm1
        if ( has_xactive_emis(n) .or. id_xactive_emis(n)>0 ) then
          select case (trim(tracnam(n)))
            case ('ISOP')
              call get_date(Time,yr,mo,day,hr,min,sec)  !model GMT
              newmonth = ( mo /= isop_oldmonth )
              if (newmonth) then
                isop_oldmonth = mo
              endif
            case ('DMS')
              call atmos_sulfate_time_vary (Time)
            case default
          end select
        endif
      end do
             

end subroutine tropchem_driver_time_vary 
      



!#####################################################################

subroutine tropchem_driver_endts


      integer :: n

      do n=1, size(inter_emis,1)
        if (has_emis(n)) then
          call unset_interpolator_time_flag(inter_emis(n))
         endif
      end do

      do n=1, size(inter_emis3d,1)
        if (has_emis3d(n)) then
         call unset_interpolator_time_flag(inter_emis3d(n))
        endif
      end do

      do n=1, size(inter_aircraft_emis,1)
        if (has_airc(n)) then
          call unset_interpolator_time_flag(inter_aircraft_emis(n))
        endif
      end do

      call unset_interpolator_time_flag(conc)           
      call unset_interpolator_time_flag(sulfate)         

      do n=1, size(ub,1)
        if (has_ubc(n)) then
          call unset_interpolator_time_flag(ub(n))
        endif
      end do

      call strat_chem_dcly_dt_endts               



end subroutine tropchem_driver_endts


!######################################################################

subroutine tropchem_driver_end

!-----------------------------------------------------------------------
!     ... initialize mpp clock id
!-----------------------------------------------------------------------
      
   module_is_initialized = .false.
      
      
!-----------------------------------------------------------------------
      
end subroutine tropchem_driver_end

!#######################################################################

! <SUBROUTINE NAME="read_2D_emis_data">
!   <OVERVIEW>
!     Read emissions file
!   </OVERVIEW>
!   <DESCRIPTION>
!     Reads tracer surface emissions from a NetCDF file
!   </DESCRIPTION>
!   <TEMPLATE>
!     call read_2D_emis_data( emis_type, emis, Time, &
!                             field_names, &
!                             Ldiurnal, coszen, half_day, lon, &
!                             is, js, id_emis_diag ) 
!   </TEMPLATE>

subroutine read_2D_emis_data( emis_type, emis, Time, &
                              field_names, &
                              Ldiurnal, coszen, half_day, lon, &
                              is, js, id_emis_diag )
    
   type(interpolate_type),intent(inout) :: emis_type
   real, dimension(:,:),intent(out) :: emis
   type(time_type),intent(in) :: Time
   character(len=*),dimension(:), intent(in) :: field_names
   logical, intent(in) :: Ldiurnal
   real, dimension(:,:), intent(in) :: coszen, half_day, lon
   integer, intent(in) :: is, js
   integer, intent(in),optional :: id_emis_diag ! id for diagnostic


   integer :: i, j, k
   logical :: used
   real, dimension(size(emis,1),size(emis,2)) :: temp_data
   real :: diurnal_scale_factor, gmt, iso_on, iso_off, dayfrac
   real :: local_angle, factor_tmp

   emis(:,:) = 0.
   temp_data(:,:) = 0.
   do k = 1,size(field_names)
      call interpolator(emis_type,Time,temp_data,field_names(k),is,js)
      emis(:,:) = emis(:,:) + temp_data(:,:)
   end do

   if (Ldiurnal) then
      do j=1,size(emis,2)
      do i=1,size(emis,1)
         if( coszen(i,j) < 0. ) then
            diurnal_scale_factor = 0.
         else
            iso_off = .8 * half_day(i,j)
            iso_on  = -iso_off
            dayfrac = iso_off/PI
            gmt = universal_time(Time)
            local_angle = gmt + lon(i,j) - PI
            if (local_angle >= PI) local_angle = local_angle - twopi
            if (local_angle < -PI) local_angle = local_angle + twopi
            if( local_angle >= iso_off .or. local_angle <= iso_on ) then
               diurnal_scale_factor = 0.
            else
               factor_tmp = local_angle - iso_on
               factor_tmp = factor_tmp / MAX(2.*iso_off,1.e-6)
               diurnal_scale_factor = 2. / dayfrac * (sin(PI*factor_tmp))**2
            end if
         end if
         emis(i,j) = emis(i,j) * diurnal_scale_factor
      end do
      end do
   end if

   if (present(id_emis_diag)) then
      if (id_emis_diag > 0) then
         used = send_data(id_emis_diag,emis,Time,is_in=is,js_in=js)
      end if
   end if
end subroutine read_2D_emis_data
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="read_3D_emis_data">
!   <OVERVIEW>
!     Read emissions file
!   </OVERVIEW>
!   <DESCRIPTION>
!     Reads tracer 3-D emissions from a NetCDF file
!   </DESCRIPTION>
!   <TEMPLATE>
!     call read_3D_emis_data( emis_type, emis, Time, phalf, &
!                             field_names, &
!                             Ldiurnal, coszen, half_day, lon, &
!                             is, js, id_emis_diag ) 
!   </TEMPLATE>

subroutine read_3D_emis_data( emis_type, emis, Time, phalf, &
                              field_names, &
                              Ldiurnal, coszen, half_day, lon, &
                              is, js, id_emis_diag )
    
   type(interpolate_type),intent(inout) :: emis_type
   real, dimension(:,:,:),intent(in) :: phalf
   real, dimension(:,:,:),intent(out) :: emis
   type(time_type),intent(in) :: Time
   character(len=*),dimension(:), intent(in) :: field_names
   logical, intent(in) :: Ldiurnal
   real, dimension(:,:), intent(in) :: coszen, half_day, lon
   integer, intent(in) :: is, js
   integer, intent(in),optional :: id_emis_diag ! id for diagnostic


   integer :: i, j, k
   logical :: used
   real, dimension(size(emis,1),size(emis,2),size(emis,3)) :: temp_data
   real :: diurnal_scale_factor, gmt, iso_on, iso_off, dayfrac
   real :: local_angle, factor_tmp

   emis(:,:,:) = 0.
   temp_data(:,:,:) = 0.
   do k = 1,size(field_names)
      call interpolator(emis_type,Time,phalf,temp_data,field_names(k),is,js)
      emis(:,:,:) = emis(:,:,:) + temp_data(:,:,:)
   end do
   if (Ldiurnal) then
      do j=1,size(emis,2)
      do i=1,size(emis,1)
         if( coszen(i,j) < 0. ) then
            diurnal_scale_factor = 0.
         else
            iso_off = .8 * half_day(i,j)
            iso_on  = -iso_off
            dayfrac = iso_off/PI
            gmt = universal_time(Time)
            local_angle = gmt + lon(i,j) + PI
            if (local_angle >= PI) local_angle = local_angle - twopi
            if (local_angle < -PI) local_angle = local_angle + twopi
            if( local_angle >= iso_off .or. local_angle <= iso_on ) then
               diurnal_scale_factor = 0.
            else
               factor_tmp = local_angle - iso_on
               factor_tmp = factor_tmp / MAX(2.*iso_off,1.e-6)
               diurnal_scale_factor = 2. / dayfrac * (sin(PI*factor_tmp))**2
            end if
         end if
         emis(i,j,:) = emis(i,j,:) * diurnal_scale_factor
      end do
      end do
   end if

   if (present(id_emis_diag)) then
      if (id_emis_diag > 0) then
         used = send_data(id_emis_diag,emis,Time,is_in=is,js_in=js)
      end if
   end if
end subroutine read_3D_emis_data
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="calc_xactive_emis">
!   <OVERVIEW>
!     Calculates interactive emissions
!   </OVERVIEW>
!   <DESCRIPTION>
!     Calculates interactive emissions
!   </DESCRIPTION>
!   <TEMPLATE>
!     call calc_xactive_emis( index, emis, Time, is, js, id_emis_diag ) 
!   </TEMPLATE>

subroutine calc_xactive_emis( index, Time, lon, lat, pwt, is, ie, js, je, &
                              area, land, tsurf, w10m, emis, &
                              kbot, id_emis_diag )
    
   integer,intent(in) :: index
   type(time_type),intent(in) :: Time
   real, intent(in), dimension(:,:) :: lon, lat
   real, intent(in), dimension(:,:,:) :: pwt
   integer, intent(in) :: is, ie, js, je
   real, intent(in), dimension(:,:) :: area    ! grid box area (m^2)
   real, intent(in), dimension(:,:) :: land    ! land fraction
   real, intent(in), dimension(:,:) :: tsurf   ! surface temperature (K)
   real, intent(in), dimension(:,:) :: w10m    ! wind speed at 10m (m/s)
   real, dimension(:,:,:),intent(out) :: emis  ! VMR/s
   integer, intent(in), dimension(:,:), optional :: kbot
   integer, intent(in),optional :: id_emis_diag ! id for diagnostic

   logical :: used

   
   if (index == dms_ndx) then
      call atmos_DMS_emission( lon, lat, area, land, tsurf, w10m, pwt, &
                               emis, Time, is, ie, js, je, kbot )
   else
      call error_mesg ('calc_xactive_emis', &
                       'Interactive emissions not defined for species: '//trim(tracnam(index)), FATAL)
   end if

   if (present(id_emis_diag)) then
      if (id_emis_diag > 0) then
         used = send_data( id_emis_diag, emis, Time, is_in=is, js_in=js)
      end if
   end if
end subroutine calc_xactive_emis
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="init_emis_data">
!   <OVERVIEW>
!     Open emissions file
!   </OVERVIEW>
!   <DESCRIPTION>
!     Opens NetCDF file of tracer surface emissions for reading,
!     and set up interpolation to model grid/time
!   </DESCRIPTION>
!   <TEMPLATE>
!     call init_emis_data( emis_type, model, method_type, index, file_name, &
!                          lonb_mod, latb_mod, field_type, flag, diurnal )
!   </TEMPLATE>

subroutine init_emis_data( emis_type, model, method_type, index, file_name, &
                           lonb_mod, latb_mod, field_type, flag, diurnal, &
                           axes, Time )
    
   type(interpolate_type),intent(inout) :: emis_type
   integer, intent(in) :: model,index
   character(len=*),intent(in) :: method_type
   character(len=*),intent(inout) ::file_name
   real,intent(in),dimension(:,:) :: lonb_mod,latb_mod
   type(field_init_type),intent(out) :: field_type
   logical, intent(out) :: flag, diurnal
   integer        , intent(in)  :: axes(4)
   type(time_type), intent(in)  :: Time
    
   character(len=64) :: name, control
   integer :: nfields
   integer :: flag_name, flag_file, flag_diurnal
   character(len=64) :: emis_name, emis_file, control_diurnal

   flag = .false.
   diurnal = .false.
   control = ''
   if( query_method(trim(method_type),model,index,name,control) ) then
      if( trim(name) == 'file' ) then
         flag = .true.
         flag_file = parse(control, 'file', emis_file)
         flag_name = parse(control, 'name', emis_name)
         flag_diurnal = parse(control, 'diurnal', control_diurnal)
         if(flag_file > 0) then
            file_name = emis_file
         else if (flag_name > 0) then
            select case (trim(method_type))
               case ('emissions3d')
                  file_name  = trim(file_emis3d_1)//trim(emis_name)//trim(file_emis3d_2)
               case default
                  file_name  = trim(file_emis_1)//trim(emis_name)//trim(file_emis_2)
            end select
         end if
         diurnal = (flag_diurnal > 0)

         call interpolator_init( emis_type, trim(file_name), &
                                 lonb_mod, latb_mod,  &
                                 data_out_of_bounds=(/CONSTANT/), &
                                 vert_interp=(/INTERP_WEIGHTED_P/) )
         call query_interpolator(emis_type,nfields=nfields)
         allocate(field_type%field_names(nfields))
         call query_interpolator(emis_type,field_names=field_type%field_names)
      end if
   end if
end subroutine init_emis_data
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="init_xactive_emis">
!   <OVERVIEW>
!     Set up interactive emission calculations
!   </OVERVIEW>
!   <DESCRIPTION>
!     Set up interactive emission calculations
!   </DESCRIPTION>
!   <TEMPLATE>
!     call init_xactive_emis( model, method_type, index, species, &
!                             axes, Time, lonb_mod, latb_mod, phalf, &
!                             flag, mask )
!   </TEMPLATE>

subroutine init_xactive_emis( model, method_type, index, species, &
                              axes, Time, lonb_mod, latb_mod, phalf, &
                              flag, id_xemis, mask )
    
   integer,         intent(in)  :: model, index
   character(len=*),intent(in)  :: method_type, species
   integer        , intent(in)  :: axes(4)
   type(time_type), intent(in)  :: Time
   real,            intent(in), dimension(:,:)   :: lonb_mod,latb_mod
   real,            intent(in), dimension(:,:,:) :: phalf
   real,            intent(in), dimension(:,:,:), optional :: mask
   logical,         intent(out) :: flag
   integer,         intent(out) :: id_xemis
    
   character(len=64) :: name, control
   integer :: nhalf, nfull

   flag = .false.
   control = ''
   nhalf = SIZE(phalf,3)
   nfull = nhalf - 1

   flag = query_method(trim(method_type),model,index,name,control)
   
!  if (flag) then
      select case (trim(species))
         case ('DMS')
            id_xemis = &
               register_diag_field( module_name, trim(species)//'_xactive_emis', axes(1:3), &
                                    Time, trim(species)//'_xactive_emis', 'VMR/s')
            if (flag .or. id_xemis>0) then
               call atmos_sulfate_init( lonb_mod, latb_mod, nfull, axes, Time, mask )
            end if
         case ('ISOP')
            id_xemis = &
               register_diag_field( module_name, trim(species)//'_xactive_emis', axes(1:2), &
                                    Time, trim(species)//'_xactive_emis', 'molecules/cm2/s')
            if (flag .or. id_xemis>0) then
               call isop_xactive_init( lonb_mod, latb_mod, axes )
            end if
         case default
            if (flag) then
               call error_mesg ('init_xactive_emis','Interactive emissions not defined for species: '//trim(species), FATAL)
            else
               id_xemis = 0
            end if
      end select
!  end if

end subroutine init_xactive_emis
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="isop_xactive_init">
!   <OVERVIEW>
!     Initialize interactive isoprene emissions
!   </OVERVIEW>
!   <DESCRIPTION>
!     Initialize interactive isoprene emissions: read in emission capacities,
!     LAI for each pft, percentage pft in each grid cell, climatological (1980-2000)
!     monthly mean surface air temp + downward short wave radiation from 
!     Sheffield et al., J. clim, 2006  (obtained from Christine Wiedinmyer, NCAR,
!     Feb, 2009.  Also allocate and initialize arrays needed for diagnostics, etc.
!     Updated to MEGAN v2.1 amf/van
!   </DESCRIPTION>
!   <TEMPLATE>
!     call isop_xactive_init( lonb_mod, latb_mod, axes )
!   </TEMPLATE>

subroutine isop_xactive_init( lonb, latb, axes )

  real, intent(in), dimension(:,:)   :: lonb,latb
  integer        , intent(in)  :: axes(4)
  integer :: nlon, nlat, i, m
!parameters for input file
!number of vegetation types for emission capacities

!++amf/van updated to megan2.1 nveg = 5 types above
! integer, parameter :: nveg=6, npft=17, nmos=12
!--amf/van
  integer, parameter :: nlonin = 720, nlatin = 360
  integer, parameter :: metlonin = 360, metlatin= 180
  real, dimension(nlonin) :: inlon, lonpft, lonlai
  real, dimension(nlatin) :: inlat, latpft, latlai
  real, dimension(nlonin+1) :: inlone, lonpfte, lonlaie
  real, dimension(nlatin+1) :: inlate, latpfte, latlaie
  real, dimension(metlonin) :: metlon
  real, dimension(metlatin) :: metlat
  real, dimension(metlonin+1) :: metlone
  real, dimension(metlatin+1) :: metlate
  integer, dimension(npft) :: pft
  integer, dimension(nmos) :: mos
  real :: edgew,edges,edgen,edgee,dlon,dlat
  character(len=19), parameter :: ecfile = 'INPUT/megan.ISOP.nc'       ! amf/van
  character(len=25), parameter :: laifile = 'INPUT/mksrf_lai.060929.nc'
  character(len=25), parameter :: pftfile = 'INPUT/mksrf_pft.060929.nc'
  character(len=35), parameter :: tasfile = 'INPUT/tas_monthly_clim_1980-2000.nc'
  character(len=37), parameter :: dswfile = 'INPUT/dswrf_monthly_clim_1980-2000.nc'
  character(len=3) :: vegnames(nveg) = (/ 'ntr', 'btr', 'crp', 'grs', 'shr' /)    !amf/van
  character(len=5) :: pftnames(npft) = (/ 'pft01','pft02','pft03','pft04','pft05','pft06', &
       'pft07','pft08','pft09','pft10','pft11','pft12','pft13','pft14','pft15','pft16','pft17' /)
  character(len=5) :: lainames(npft) = (/ 'lai01','lai02','lai03','lai04','lai05','lai06', &
       'lai07','lai08','lai09','lai10','lai11','lai12','lai13','lai14','lai15','lai16','lai17' /)
  character(len=5) :: tasnames(nmos) = (/ 'tas01','tas02','tas03','tas04','tas05','tas06', &
       'tas07','tas08','tas09','tas10','tas11','tas12' /)
  character(len=5) :: dswnames(nmos) = (/ 'dsw01','dsw02','dsw03','dsw04','dsw05','dsw06', &
       'dsw07','dsw08','dsw09','dsw10','dsw11','dsw12' /)
  integer :: id_ec(nveg), id_pft(npft), id_lai(npft), id_tas(nmos), id_dsw(nmos)  
  real, dimension(nlonin,nlatin) :: datain
  real, dimension(nlonin,nlatin,npft) :: datapft
  real, dimension(nlonin,nlatin,npft,nmos) :: datalai
  real, dimension(metlonin,metlatin,nmos) :: tas, dswrf
  logical :: used

  nlon = size(lonb,1)-1
  nlat = size(latb,2)-1

!allocate dimensions of array for storing emission capacities (model grid)
  allocate(ecisop(nlon,nlat,nveg))
  allocate(pctpft(nlon,nlat,npft))
  allocate(mlai(nlon,nlat,npft,nmos))      ! monthly mean LAI
  allocate(emisop_month(nlon,nlat))        ! emission capacities adjusted w/ monthly gamma_lai and gamma_age
  allocate(diag_gamma_lai_age(nlon,nlat))
  allocate(diag_gamma_light(nlon,nlat))
  allocate(diag_gamma_temp(nlon,nlat))
  allocate(diag_climtas(nlon,nlat))
  allocate(diag_climfsds(nlon,nlat))
  allocate(ts_avg(nlon,nlat,nmos))
  allocate(fsds_avg(nlon,nlat,nmos))

!Initalize arrays
  emisop_month(:,:) = 0.
  diag_gamma_lai_age(:,:) = 0.
  diag_gamma_light(:,:) = 0.
  diag_gamma_temp(:,:) = 0.
  diag_climtas(:,:) = 0.
  diag_climfsds(:,:) = 0.
! always get gamma age / gamma lai at start of run.
! newmonth = .true.     

!  --- check existence of input file containing isoprene emission capacities --------
  if (file_exist(ecfile)) then
      
!set up for input grid
     if(mpp_pe() == mpp_root_pe()) call error_mesg ('isop_xactive_init',  &
          'Reading NetCDF formatted input file: iso_bvoc.nc', NOTE)
      
! amf/van -- new file only has lat lon centers, not boundaries...
!read in lat & lon boundaries from input file and convert to radians
!no.domain = true tells it all fields are in one global file (as opposed to e.g., one per cube face)
     call read_data (ecfile, 'lon', inlon, no_domain=.true.)
     call read_data (ecfile, 'lat', inlat, no_domain=.true.)
     inlon = inlon*DEG_TO_RAD
     inlat = inlat*DEG_TO_RAD
     dlat = inlat(2)-inlat(1)
     dlon = inlon(2)-inlon(1)
     inlone(1:nlonin) = inlon-(dlon/2.)
     inlone(nlonin+1) = inlon(nlonin)+(dlon/2.)
     inlate(1:nlatin) = inlat-(dlat/2.)
     inlate(nlatin+1) = inlat(nlatin)+(dlat/2.)

!     print*, 'lat,lon edges for new megan.isop.nc file: ', inlate, inlone
     
     call horiz_interp_init
     call horiz_interp_new ( Interp, inlone, inlate, lonb, latb )

! loop over vegnames
     do i = 1, nveg 
!register diagnostic field
        id_ec(i) = register_static_field( 'tracers', vegnames(i), axes(1:2), &
             vegnames(i), 'molec/cm2/s')
!read this field
        call read_data (ecfile, vegnames(i), datain, no_domain=.true.)
        call horiz_interp (Interp, datain, ecisop(:,:,i), verbose=verbose)
!send data to diagnostic
        if (id_ec(i) > 0) then
           used = send_data(id_ec(i),ecisop(:,:,i)) 
        endif
     end do
    
  else 
     print*, 'what is ecfile ', ecfile
     call error_mesg ('isop_xactive_init',  &
          'ecfile does not exist.', FATAL)
  endif

!  --- check existence of input file containing % pft --------
  if (file_exist(pftfile)) then
      
!set up for input grid
     if(mpp_pe() == mpp_root_pe()) call error_mesg ('isop_xactive_init',  &
          'Reading NetCDF formatted input file: mksrf_pft.060929.nc', NOTE)
      
!read in lat & lon from input file, get boundaries and convert to radians
     call read_data (pftfile, 'lon', lonpft, no_domain=.true.)
     call read_data (pftfile, 'lat', latpft, no_domain=.true.)
     call read_data (pftfile, 'EDGEW', edgew, no_domain=.true.)
     call read_data (pftfile, 'EDGES', edges, no_domain=.true.)
     call read_data (pftfile, 'EDGEE', edgee, no_domain=.true.)
     call read_data (pftfile, 'EDGEN', edgen, no_domain=.true.)

     lonpfte(1) = edgew
     latpfte(1) = edges
     latpfte(nlatin+1) = edgen
     lonpfte(nlonin+1) = edgee
     
     dlon = 2.*(lonpft(1)-edgew)
     dlat = 2.*(latpft(1)-edges)

     do i = 2, nlatin 
        latpfte(i) = latpfte(i-1)+dlat
     end do

     do i = 2, nlonin
        lonpfte(i) = lonpfte(i-1)+dlon
     end do     

     lonpfte = lonpfte*DEG_TO_RAD
     latpfte = latpfte*DEG_TO_RAD
     
     call horiz_interp_init
     call horiz_interp_new ( Interp, lonpfte, latpfte, lonb, latb )

     call read_data (pftfile, 'pft', pft, no_domain=.true.)

!read pct_pft field 
     call read_data (pftfile, 'PCT_PFT', datapft, no_domain=.true.)

! loop over vegnames
     do i = 1, npft       
!register diagnostic field
        id_pft(i) = register_static_field( 'tracers', pftnames(i), axes(1:2), &
             pftnames(i), 'unitless')
        call horiz_interp (Interp, datapft(:,:,i), pctpft(:,:,i), verbose=verbose)
!send data to diagnostic
        if (id_pft(i) > 0) then
           used = send_data(id_pft(i),pctpft(:,:,i)) 
        endif
     end do
!scale pctpft from percentage to fraction 
     pctpft(:,:,:) = .01 * pctpft(:,:,:)
    
  else 
     call error_mesg ('isop_xactive_init',  &
          'pftfile does not exist.', FATAL)
  endif

!  --- check existence of input file containing monthly lai, for each pft --------
  if (file_exist(laifile)) then
      
!set up for input grid
     if(mpp_pe() == mpp_root_pe()) call error_mesg ('isop_xactive_init',  &
          'Reading NetCDF formatted input file: mksrf_lai.060929.nc', NOTE)
      
!read in lat & lon from input file, get boundaries and convert to radians
     call read_data (laifile, 'lon', lonlai, no_domain=.true.)
     call read_data (laifile, 'lat', latlai, no_domain=.true.)

! get lat/lon edges
     lonlaie(1) = edgew
     latlaie(1) = edges
     latlaie(nlatin+1) = edgen
     lonlaie(nlonin+1) = edgee
     
     dlon = 2.*(lonlai(1)-edgew)
     dlat = 2.*(latlai(1)-edges)

     do i = 2, nlatin 
        latlaie(i) = latlaie(i-1)+dlat
     end do

     do i = 2, nlonin
        lonlaie(i) = lonlaie(i-1)+dlon
     end do     

     lonlaie = lonlaie*DEG_TO_RAD
     latlaie = latlaie*DEG_TO_RAD
     
     call horiz_interp_init
     call horiz_interp_new ( Interp, lonlaie, latlaie, lonb, latb )

! read in pft and time dimensions from lai file
     call read_data (laifile, 'time', mos, no_domain=.true.)

! loop over vegnames
     do i = 1, npft 
        call read_data (laifile,lainames(i),datalai(:,:,i,:), no_domain=.true.)
        do m = 1, nmos
            call horiz_interp (Interp, datalai(:,:,i,m), mlai(:,:,i,m), verbose=verbose)
!store diagnostics for one month only - choose July for now
            if (m .eq. 7) then 
!register diagnostic field
               id_lai(i) = register_static_field( 'tracers', lainames(i), axes(1:2), &
                    lainames(i), 'unitless')
!send data to diagnostic
               if (id_lai(i) > 0) then
                  used = send_data(id_lai(i),mlai(:,:,i,m))
               endif
            endif
         end do
      end do
    
   else 
      call error_mesg ('isop_xactive_init',  &
           'laifile does not exist', FATAL)
   endif

!  --- check existence of input file containing climatological (1980-2000) monthly air surface temp --------
  if (file_exist(tasfile)) then
      
!set up for input grid
     if(mpp_pe() == mpp_root_pe()) call error_mesg ('isop_xactive_init',  &
          'Reading NetCDF formatted input file: tas_monthly_clim_1980-2000.nc', NOTE)
      
!read in lat & lon from input file, get boundaries and convert to radians
     call read_data (tasfile, 'lon', metlon, no_domain=.true.)
     call read_data (tasfile, 'lat', metlat, no_domain=.true.)
     
     dlon = 0.5*(metlon(1)-metlon(2))
     dlat = 0.5*(metlat(2)-metlat(1))

     do i = 1, metlatin 
        metlate(i) = metlat(i)-dlat
     end do

     metlate(metlatin+1) = metlat(metlatin)+dlat

     do i = 1, metlonin
        metlone(i) = metlon(i)-dlon
     end do     
     metlone(metlonin+1) = metlon(metlonin)+dlon

     metlone = metlone*DEG_TO_RAD
     metlate = metlate*DEG_TO_RAD
     
     call horiz_interp_init
     call horiz_interp_new ( Interp, metlone, metlate, lonb, latb )

     call read_data (tasfile, 'time', mos, no_domain=.true.) 
     call read_data (tasfile,'tas_clim', tas(:,:,:), no_domain=.true.)
        
     do m = 1, nmos
        call horiz_interp (Interp, tas(:,:,m), ts_avg(:,:,m), verbose=verbose) 
!register diagnostic field
        id_tas(m) = register_static_field( 'tracers', tasnames(m), axes(1:2), &
             tasnames(m), 'unitless')
!send data to diagnostic
        if (id_tas(m) > 0) then
           used = send_data(id_tas(m),ts_avg(:,:,m))
        endif
     end do
  else 
     call error_mesg ('isop_xactive_init',  &
          tasfile, NOTE)
     call error_mesg ('isop_xactive_init',  &
          'tasfile does not exist', FATAL)

  endif

!  --- check existence of input file containing climatological (1980-2000) monthly surface down SW radiation --------
  if (file_exist(dswfile)) then
      
!set up for input grid
     if(mpp_pe() == mpp_root_pe()) call error_mesg ('isop_xactive_init',  &
          'Reading NetCDF formatted input file: dswrf_monthly_clim_1980-2000.nc', NOTE)
      
!read in lat & lon from input file, get boundaries and convert to radians
     call read_data (dswfile, 'lon', metlon, no_domain=.true.)
     call read_data (dswfile, 'lat', metlat, no_domain=.true.)
     
     dlon = 0.5*(metlon(1)-metlon(2))
     dlat = 0.5*(metlat(2)-metlat(1))

     do i = 1, metlatin 
        metlate(i) = metlat(i)-dlat
     end do

     metlate(metlatin+1) = metlat(metlatin)+dlat

     do i = 1, metlonin
        metlone(i) = metlon(i)-dlon
     end do     
     metlone(metlonin+1) = metlon(metlonin)+dlon

     metlone = metlone*DEG_TO_RAD
     metlate = metlate*DEG_TO_RAD
     
     call horiz_interp_init
     call horiz_interp_new ( Interp, metlone, metlate, lonb, latb )

     call read_data (dswfile, 'time', mos, no_domain=.true.)
     call read_data (dswfile,'dswrf_clim', dswrf(:,:,:), no_domain=.true.)
        
     do m = 1, nmos
        call horiz_interp (Interp, dswrf(:,:,m), fsds_avg(:,:,m), verbose=verbose)
!register diagnostic field
        id_dsw(m) = register_static_field( 'tracers', dswnames(m), axes(1:2), &
             dswnames(m), 'unitless')
!send data to diagnostic
        if (id_dsw(m) > 0) then
           used = send_data(id_dsw(m),fsds_avg(:,:,m))
        endif
     end do
    
  else 
     call error_mesg ('isop_xactive_init',  &
          'dswfile does not exist', FATAL)
  endif

end subroutine isop_xactive_init

!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="calc_xactive_isop">
!   <OVERVIEW>
!     Calculates interactive isoprene emissions
!   </OVERVIEW>
!   <DESCRIPTION>
!     Calculates interactive isoprene emissions using algorithms from 
!      PCEEA MEGAN model in Guenther, ACP, 2006.
!      Note - gamma soil moisture is assumed constant (at one)
!   </DESCRIPTION>
!   <TEMPLATE>
!     call calc_xactive_isop( index, Time, lon, lat, oro, pwtsfc, is, js, &
!                              area, land, tsfcair, flux_sw_down_vis, &
!                              coszen, emis,   id_gamma_lai_age, &
!                                 id_gamma_temp, id_gamma_light, &
!                                 id_tsfcair, id_fsdvd, id_climtas, id_climfsds, id_emis_diag ) 
!   </TEMPLATE>
             
subroutine calc_xactive_isop( index, Time, lon, lat, oro, pwtsfc, is, js, &
                              area, land, tsfcair, flux_sw_down_vis, &
                              coszen, emis,   id_gamma_lai_age, &
                              id_gamma_temp, id_gamma_light, id_tsfcair, &
                              id_fsdvd, id_climtas, id_climfsds, id_emis_diag ) 
    
   integer,intent(in) :: index
   type(time_type),intent(in) :: Time
   real, intent(in), dimension(:,:) :: lon, lat
   real, intent(in), dimension(:,:) :: pwtsfc
   integer, intent(in) :: is, js 
   real, intent(in), dimension(:,:) :: area    ! grid box area (m^2)
   real, intent(in), dimension(:,:) :: land    ! land fraction
   real, intent(in), dimension(:,:) :: oro     ! land = 1; ocean = 0
   real, intent(in), dimension(:,:) :: tsfcair   ! surface temperature (K)
   real, intent(in), dimension(:,:) :: flux_sw_down_vis !W/m2 visible (direct+diffuse) sfc flux
   real, intent(in), dimension(:,:) :: coszen  ! cosine of solar zenith angle
   real, dimension(:,:),intent(out) :: emis  ! 
   integer, intent(in), optional :: id_gamma_lai_age, id_gamma_temp, id_gamma_light
   integer, intent(in), optional :: id_climtas, id_climfsds
   integer, intent(in), optional :: id_emis_diag, id_tsfcair
   integer, intent(in),optional ::  id_fsdvd ! id for diagnostic
   real    :: calday
   type(time_type) :: Year_t
   integer :: yr, mo, day, hr, min, sec
   logical :: used
   integer :: ie, je

   ie = is + size(land,1) -1
   je = js + size(land,2) -1

   call get_date(Time,yr,mo,day,hr,min,sec)  !model GMT

!update gamma age and gamma once per month
   if (newmonth) then 
!     if( mpp_pe() == mpp_root_pe() ) then 
!        print *, 'pts_proc, oldmonth', pts_processed, isop_oldmonth
!        print *, 'time', yr,mo,day,hr,min,sec
!        print*, 'AMF calc_xactive_isop: calling get_monthly_gammas'
!        print*, 'id_gamma_lai_age = ', id_gamma_lai_age
!        print*, 'sum(diag_gamma_lai_age', sum(diag_gamma_lai_age(:,:))
!     end if
      
      call get_monthly_gammas( lon, lat, oro, is, js, mo, &
                               id_gamma_lai_age )
!     if( mpp_pe() == mpp_root_pe() ) then 
!        print *, 'pts_proc, oldmonth AFTER', pts_processed, isop_oldmonth
!        print*, 'AMF calc_xactive_isop: after call to  get_monthly_gammas'
!        print*, 'id_gamma_lai_age = ', id_gamma_lai_age
!        print*, 'AMF sum(diag_gamma_lai_age)', sum(diag_gamma_lai_age(:,:))
!     end if

   end if

!Get Julian date (fraction) = calday
   Year_t = set_date(yr,1,1,0,0,0)
   calday = time_type_to_real( Time-Year_t) / SECONDS_PER_DAY

!  if( mpp_pe() == mpp_root_pe() ) then
!     print*, 'AMF: calday = ', calday
!  end if

! get isoprene emissions for this timestep
   call get_isop_emis( lon, lat, is, js, calday, mo, tsfcair, flux_sw_down_vis, &
                       coszen, area, pwtsfc, emis )

!accumulate isoprene emissions in diagnostic - units should be molec/cm2/s
   if (present(id_emis_diag)) then
      if (id_emis_diag > 0) then
         used = send_data( id_emis_diag, emis, Time, is_in=is, js_in=js)
      end if
   end if

! also store sw visible direct at surface and surface air temperature diagnostics
   if (present(id_fsdvd)) then 
      if (id_fsdvd > 0) then 
         used = send_data( id_fsdvd, flux_sw_down_vis, Time, is_in=is, js_in=js)
      end if
   end if

   if (present(id_tsfcair)) then 
      if (id_tsfcair > 0) then 
         used = send_data( id_tsfcair, tsfcair, Time, is_in=is, js_in=js)
      end if
   end if

   if (present(id_gamma_light)) then 
      if (id_gamma_light > 0) then 
         used = send_data( id_gamma_light, diag_gamma_light(is:ie,js:je), Time, is_in=is, js_in=js)
      end if
   end if

   if (present(id_gamma_temp)) then 
      if (id_gamma_temp > 0) then 
         used = send_data( id_gamma_temp, diag_gamma_temp(is:ie,js:je), Time, is_in=is, js_in=js)
      end if
   end if

   if (present(id_climtas)) then 
      if (id_climtas > 0) then 
         used = send_data( id_climtas, diag_climtas(is:ie,js:je), Time, is_in=is, js_in=js)
      end if
   end if

   if (present(id_climfsds)) then 
      if (id_climfsds > 0) then 
         used = send_data( id_climfsds, diag_climfsds(is:ie,js:je), Time, is_in=is, js_in=js)
      end if
   end if

!store combined diagnostic of gamma_lai * gamma_age, summed over each vegetation type
   if (present(id_gamma_lai_age)) then
      if (id_gamma_lai_age > 0) then
!         if( mpp_pe() == mpp_root_pe() ) then 
!            print*, 'AMF calc_xactive_isop: after call to send_data for glaiage'
!            print*, 'id_gamma_lai_age = ', id_gamma_lai_age
!            print*, 'sum(diag_gamma_lai_age', sum(diag_gamma_lai_age(:,:))
!         end if
         used = send_data( id_gamma_lai_age, diag_gamma_lai_age(is:ie,js:je), Time, is_in=is, js_in=js)
              
      end if
   end if

end subroutine calc_xactive_isop

!</SUBROUTINE>



!#######################################################################

! <SUBROUTINE NAME="get_isop_emis">
!   <OVERVIEW>
!     Get isop emissions for this time step
!   </OVERVIEW>
!   <DESCRIPTION>
!     amf Feb 2009
!     This subroutine calculates isoprene emissions according to
!     the MEGAN PCEEA model [Guenther et al., ACP 6, 3181-3210, 2006.]
!     as implemented in mozart4_v4.5 by J.-F. Lamarque and G. Pfister
!     (bvoc_emissions mozart routine)
!   </DESCRIPTION>
!   <TEMPLATE>
!     get_isop_emis( lon, lat, is, js, calday, mo, tsfcair, flux_sw_down_vis, &
!                          coszen, area, pwtsfc, emis )
!   </TEMPLATE>
!   <IN NAME="lon" TYPE="real" DIM="(:,:)">
!      longitude value for each i,j grid cell 
!   </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)">
!      latitude value for each i,j grid cell 
!   </IN>
!   <IN NAME="is" TYPE="integer">
!      beginning i for location of this group of 
!      grid cells within global grid, used in diag manager 
!   </IN>
!   <IN NAME="js" TYPE="integer">
!      beginning j for location of this group of 
!      grid cells within global grid, used in diag manager 
!   </IN>
!   <IN NAME="calday" TYPE="real">
!      Fractional Julian day of year (model GMT)
!   </IN>
!   <IN NAME="mo" TYPE="integer">
!     current month
!   </IN>
!   <IN NAME="tsfcair" TYPE="real" DIM="(:,:)">
!      surface air temperature (K)
!   </IN>
!   <IN NAME="flux_sw_down_vis" TYPE="real" DIM="(:,:)">
!      downward visible shortwave radiation (W/m2)
!   </IN>
!   <IN NAME="coszen" TYPE="real" DIM="(:,:)">
!     Cosine of the solar zenith angle
!   </IN>
!   <IN NAME="area" TYPE="real" DIM="(:,:)">
!     Grid cell area (m^2)
!   </IN>
!   <IN NAME="pwtsfc" TYPE="real" DIM="(:,:)">
!     kg/m2 of air in the surface layer
!   </IN>
!   <IN NAME="emis" TYPE="real" DIM="(:,:)">
!     isoprene emissions for this timestep
!     (molec/cm2/s)
!   </IN>

subroutine get_isop_emis( lon, lat, is, js, calday, mo, tsfcair, flux_sw_down_vis, &
                          coszen, area, pwtsfc, emis )
!-------------------------------------------------------------------------------------
!       ... biogenic voc isoprene emissions
!-------------------------------------------------------------------------------------  

      implicit none

      real, intent(in), dimension(:,:) :: lon, lat
      integer, intent(in) :: is, js, mo  
      real, intent(in)    :: calday          
      real, intent(in), dimension(:,:)  :: coszen     
      real, intent(in), dimension(:,:)  :: tsfcair        ! surface temperature
      real, intent(in), dimension(:,:)  :: flux_sw_down_vis !W/m2 direct visible sfc flux
      real, intent(in), dimension(:,:)  :: area      ! grid box area (m^2)
      real, intent(in), dimension(:,:)  :: pwtsfc    ! kg/m2 air in surface layer
      real, intent(out), dimension(:,:) :: emis      ! output emissions for this time step

!-------------------------------------------------------------------------------------
!       ... local variables
!-------------------------------------------------------------------------------------
      real, parameter :: ctm1   =  80.   ! p 3192 Guenther et al ACP 2006
      real, parameter :: ctm2   = 200.   ! same as above
      real, parameter :: const0 = 4.766    ! to convert W/m2 to micromoles/m2/s for PAR (C. Wiedinmyer, 2/18/09)
      real, parameter :: rho_iso = 0.96  ! to account for deposition to canopy
      real, parameter :: gamma_sm = 1.   ! soil moisture - eventually estimate as f(sm, wilting point)

      integer :: i, j, nlon, nlat
      real    :: ppfd, x, Eopt, Ptoa, phi
      real    :: Topt
      real    :: fac_par, fac_tmp
      real    :: Tdaily, Pdaily 
      real    :: t_diff
    
      nlon = size(lon,1)
      nlat = size(lat,2)
      do j = 1,nlat
         do i = 1,nlon

!-------------------------------------------------------------------------------------
!       ... PAR correction
!                Guenther et al ACP 2006 Eqns 11, 12, 13
!           Note - this does not include separation of sunny/shady - could add.
!-------------------------------------------------------------------------------------
!Currently tests to see if we have read in the climatological surface air & downward shortwave
! could eventually change to use values saved during run (e.g., previous week to month values for
! each grid cell)
!Note the factor of 0.5 to convert from total shortwave to PPFD
! vs. AM3 which has visible component available.
         if( has_ts_avg ) then  
            Pdaily =  fsds_avg(i+is-1,j+js-1,mo) * const0 * 0.5 
            Tdaily  = ts_avg(i+is-1,j+js-1,mo)
         else
            Pdaily = Pdaily_clim * const0 * 0.5
            Tdaily = Tdaily_clim
         end if
         ppfd   = flux_sw_down_vis(i,j) * const0

         Ptoa = 3000. + 99.* cos( twopi*(calday - 10.)/365. )    !Guenther et al Eqn 13


! Guenther eqns 11a/b 
         if (coszen(i,j) <= 0.) then 
            fac_par = 0.   
         else
            phi = ppfd / (coszen(i,j)*Ptoa)   ! Eqn 12

!-------------------------------------------------------------------------------------
!  phi can get > 1 and then fac_par gets negative with the above equation
!  set phi=1 if phi> 1 as recommended by Alex (MZ4 code)
!-------------------------------------------------------------------------------------
            phi = min( phi,1. )   
            !Eqn 11b - note typo in MZ4 - 2.49 instead of 2.46
            fac_par = coszen(i,j)*(2.46 * (1. + .0005 *(Pdaily - 400.))*phi - .9*phi*phi) 
         end if

!-------------------------------------------------------------------------------------
!       ... temperature correction  equation 14
!           Topt from equation 8
!           p. 3192 Guenther et al 2006
!-------------------------------------------------------------------------------------
         t_diff  = Tdaily - Tdaily_clim
         Topt    = 313. + 0.6*t_diff                     !Eqn 8
         x       = (tsfcair(i,j) - Topt)/(tsfcair(i,j)*Topt*.00831)
         Eopt    = 1.75 * exp( .08*t_diff )
!Eqn 14 --  gammaT
         fac_tmp = Eopt * (ctm2 * exp( ctm1*x ))/(ctm2 - ctm1*(1. - exp( ctm2*x )))  

!-------------------------------------------------------------------------------------
!     emisop_month contains regridded potential emissions including 
!                  application of gamma LAI and gamma AGE for this month 
!     ... change units from microg/m2/h to mol/cm2/s
!      units of MZ4 input file incorrectly labled as mol/cm2/s... 
!-------------------------------------------------------------------------------------
         emis(i,j) = emisop_month(i+is-1,j+js-1) * fac_par * fac_tmp *  2.46e8
         diag_gamma_temp(i+is-1,j+js-1) = fac_tmp
         diag_gamma_light(i+is-1,j+js-1) = fac_par
         diag_climtas(i+is-1,j+js-1) = Tdaily
         diag_climfsds(i+is-1,j+js-1) = Pdaily

!        if( mpp_pe() == mpp_root_pe() ) then
!           print*, 'AMF: i,j,gt,gl,emis = ', i,j,fac_tmp,fac_par, emis(i,j)
!           print*, 'AMF: calday = ', calday
!        endif
      end do !lon
   end do !lat

!-------------------------------------------------------------------------------------
!        AMF - apply uniform canopy deposition and soil moisture corrections
!              from Guenther et al 2006 - could eventually parameterize these
!                    (neither included in MZ4)
!-------------------------------------------------------------------------------------
   emis(:,:) =  emis(:,:) * rho_iso * gamma_sm 

end subroutine get_isop_emis
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="get_monthly_gammas">
!   <OVERVIEW>
!     Each month, update isoprene emissions to include scaling from 
!     gamma_age and gamma_lai
!   </OVERVIEW>
!   <DESCRIPTION>
!     amf Feb 2009
!     This subroutine calculates gamma_age and gamma_lai and applies them
!     for each LAI and PFT, aggregating to the 6 vegetation types for the
!     isoprene emission capacities, following
!     the MEGAN PCEEA model [Guenther et al., ACP 6, 3181-3210, 2006.]
!     as implemented in mozart4_v4.5 by J.-F. Lamarque and G. Pfister
!     (interp_map_bvoc mozart routine)
!   </DESCRIPTION>
!   <TEMPLATE>
!     get_monthly_gammas( lon, lat, oro, is, js, &
!                                   month, id_gamma_lai_age )  
!   </TEMPLATE>

!removed fsds since not used... 
subroutine get_monthly_gammas( lon, lat, oro, is, js, &
                                   month, id_gamma_lai_age )

      implicit none

      real, intent(in), dimension(:,:) :: lon, lat
      real, intent(in), dimension(:,:) :: oro     ! land = 1; ocean = 0
      integer, intent(in) :: is, js    
      integer, intent(in)      :: month
      integer, intent(in),optional :: id_gamma_lai_age  !id for diagnostic
  
!-------------------------------------------------------------------------------------
!       ... local variables
!-------------------------------------------------------------------------------------
      integer                  :: i, j, n, nlon, nlat, nl, nu
      integer                  :: pft_li(nveg)
      integer                  :: pft_lu(nveg)
!      real                     :: wrk_area  
      real                     :: total_iso
      real                     :: work_iso(nveg)    !amf/van
      real                     :: ts_wrk
      real                     :: total_work_gamma

!++amf/van
      real                     :: work_gamma(nveg)  ! for diagnostic
      real                     :: lai_fac(npft)  ! npft = 17 (mksrf files)
      real                     :: lai_work(npft,nmos)
      logical                  :: age_work(npft)
!--amf/van

      nlon = size(lon,1)
      nlat = size(lat,2)

!       if( mpp_pe() == mpp_root_pe() ) then 
!          print*, 'AMF get_monthly_gammas: made it here'
!       end if
      
!++amf/van
      age_work(:) = .true.
      age_work((/2,3,5,6,10/)) = .false.

! hardwired indices for matching pfts to ecs 
! pfts 2-4   fine leaf 
! pfts 5-9   broadleaf
! pfts 10-12 shrubs 
! pfts 13-15 grass
! pfts 16-17 crops

      pft_li(:) = (/ 2,5,10,13,16 /)
      pft_lu(1:nveg-1) = (/ 4,9,12,15 /)
      pft_lu(nveg) = npft
!--amf/van
      do j = 1,nlat
         do i = 1,nlon
            total_iso = 0. 
            total_work_gamma = 0.
            if (has_ts_avg) then
              ts_wrk = ts_avg(i,j,month)
            end if

!-----------------------------------------------------------------
!       ... no emissions for ocean grid point 
!-----------------------------------------------------------------
            if( oro(i,j) .eq. 1 ) then
                
!++amv/van
            lai_work(:,:) = mlai(i,j,:,:)
            lai_fac(:) = calc_gamma_lai_age( lai_work, ts_wrk, month, age_work)

            do n = 1, nveg
              nl = pft_li(n)  !beginning index for the pfts that fall within this veg type for n types in ecisop
              nu = pft_lu(n)  !end index
              work_iso(n) = dot_product( lai_fac (nl:nu), pctpft(i,j,nl:nu)) * ecisop(i,j,n)
              work_gamma(n) = dot_product( lai_fac (nl:nu), pctpft(i,j,nl:nu))
            end do
            total_work_gamma = total_work_gamma + sum(work_gamma)
            total_iso = total_iso + sum(work_iso)
        
!--amf/van
              emisop_month(i,j) = total_iso
              diag_gamma_lai_age(i,j) = total_work_gamma
!             if( mpp_pe() == mpp_root_pe() ) then
!                print*, 'AMF: i,j,oro, work_iso, emis ', i,j,oro(i,j), work_iso, emisop_month(i,j)
!             end if
          end if ! land box
        end do !lon
      end do !lat

end subroutine get_monthly_gammas
!</SUBROUTINE


!#######################################################################

! <FUNCTION NAME="calc_gamma_lai_age">
!   <OVERVIEW>
!     Monthly exchange ratio from MEGAN
!   </OVERVIEW>
!   <DESCRIPTION>
!     amf Feb 2009
!     This subroutine calculates gamma_age and gamma_lai according to
!     the MEGAN PCEEA model [Guenther et al., ACP 6, 3181-3210, 2006.]
!     as implemented in mozart4_v4.5 by J.-F. Lamarque and G. Pfister
!     (their fac_lai function)
!   </DESCRIPTION>
!   <TEMPLATE>
!     work_iso  = calc_gamma_lai_age( clai, ts_wrk, month, doage )
!   </TEMPLATE>
!   <IN NAME="clai" TYPE="real" DIM="(:)">
!      12 monthly values for lai for current grid cell
!   </IN>
!   <IN NAME="ts_wrk" TYPE="real">
!     the climatological monthly mean surface T for this i, j, m (K)
!   </IN>
!   <IN NAME="month" TYPE="integer">
!     current month
!   </IN>
!   <IN NAME="doage" TYPE="integer">
!     1 = calculate gamma age; 0 = don't
!   </IN>


function calc_gamma_lai_age(clai, ts_wrk, month, doage )

!AMF - COULD ADD OPTION TO USE AVERAGE TS AND FSDS OVER
! PAST MONTH /WEEKS -- would need to save to restart file  
! NOTE - MZ4 FAC_LAI DOESN"T SEEM TO USE FSDS_AVG, NOR DOES IT IN GUENTHER'S EQNS, 
! SO ELIMINATE FROM THIS FUNCTION

  implicit none

  logical, intent(in) :: doage(:)         !calculate gamma_age?,  amf/van
  integer, intent(in) :: month            !current month index
  real, intent(in) :: ts_wrk              ! currently = climatological sfc T for ea i,j,m
  real, intent(in) :: clai(:,:)           ! monthly lai for this grid cell,   amf/van
  
!-------------------------------------------------------------------------------------
!       ... local variables
!-------------------------------------------------------------------------------------
! ggp: equations 18 and 19 from Guenther et al. include a dependence of ti and tm on temperature
! of preceding timestep (i.e. month here); not considered here. 
! ggp/lamar: instead of using a constant ti and tm, it can be calculated based on information 
! of monthly average temperature
!-------------------------------------------------------------------------------------

!! amf: time step in days btw previous month's LAI and current month's LAI (p3192 guenther)
      integer, parameter :: t(12) = (/ 31,31,28,31,30,31,30,31,31,30,31,30 /)

      integer :: n
      integer :: mnthm1
      real    :: x
      real    :: wrk
      real    :: gamma
      real    :: lai_n, lai_p      ! amf/van
      real    :: Fnew
      real    :: Fgro
      real    :: Fmat
      real    :: Fsen              ! amf/van
      real    :: ti, tm  ! ti = # days btw budbreak and induction of isoprene emissions
                         ! tm = # days btw budbreak + initiation of peak isop emissions rates

!-------------------------------------------------------------------------------------
!       ... function declarations
!-------------------------------------------------------------------------------------
      real    :: calc_gamma_lai_age(npft)    ! amf/van

      if( month > 1 ) then      ! amf/van
         mnthm1 = month - 1
      else
         mnthm1 = 12
      end if

!-------------------------------------------------------------------------------------
!       ... calculations following equations 17&18 in Guenther et al. [2006]
!           -- getting terms needed for gamma age
!-------------------------------------------------------------------------------------
      if( has_ts_avg ) then
         if( ts_wrk <= 303. ) then
            ti = 5. + 0.7*(300. - ts_wrk)                     !eqn 18a (see corrigendum)
         else        
            ti = 2.9                                          ! eqn 18b (corrigendum)
         end if
      else
         ti = 5. + 0.7*(300. - Tdaily_clim)                   ! Tdaily_clim in tropchem_driver_nml
      end if
      tm = 2.3*ti                                             ! Eq 19 

!++amf/van
      calc_gamma_lai_age(1) = 0.
      do n = 2, npft
       if (doage(n)) then
        Fnew = 0.
        Fgro = 0.
        Fmat = 0.
        Fsen = 0.
        lai_n = clai(n, month)
        lai_p = clai(n, mnthm1)
        if( lai_n == lai_p ) then                  !previous LAI = current LAI  - p.392 G06
         Fmat = 0.8
         Fsen = 0.1
         Fgro = 0.1
      else if( lai_p > lai_n ) then              !LAip > LAIc
         Fsen = (lai_p - lai_n) / lai_p
         Fmat = 1. - Fsen
      else if( lai_p < lai_n ) then              !LAIp < LAIc
         Fsen = 0.
         x    = lai_p/lai_n
!--amf/van
         wrk  = 1. - x                                        ! = Fnew
         if( t(month) <= tm ) then
            Fmat =  x                                         ! Eqn 17c
         else
            Fmat = x + (((t(month) - tm)/t(month) ) * wrk)    ! Eqn 17d
         end if
         if( t(month) <= ti ) then
            Fnew = wrk                                        ! Eqn 17a
            Fgro = 1. - (Fnew + Fmat)                         ! Eqn 17e
         else
            Fnew = (ti/t(month)) * wrk                        ! Eqn 17b
            Fgro = 1. - (Fnew + Fmat)                         ! Eqn 17e
         end if
      end if

!-------------------------------------------------------------------------------------
!       ... equations 15 and 16 in Guenther et al. [2006]
!            -- get gamma age
!-------------------------------------------------------------------------------------
      gamma   = .05*Fnew + .6*Fgro + 1.125*Fmat + Fsen   !!  Eq 16
      else
        gamma   = 1.
      end if

!-------------------------------------------------------------------------------------
!     gamma_age ("gamma" below) * gamma_lai where gamma_lai is from Eqn 15 
!-------------------------------------------------------------------------------------
      calc_gamma_lai_age(n) = gamma * .49 * clai(n,month) / sqrt( 1. + 0.2 * clai(n, month)*clai(n, month) )

      end do
  

end function calc_gamma_lai_age

!</FUNCTION>
!############################################################################

! <SUBROUTINE NAME="tropchem_drydep_init">
!   <OVERVIEW>
!     Open dry deposition file
!   </OVERVIEW>
!   <DESCRIPTION>
!     Opens NetCDF file of tracer dry deposition velocities for reading,
!     and set up interpolation to model grid/time
!   </DESCRIPTION>
!   <TEMPLATE>
!     call tropchem_drydep_init( dry_files, dry_names, &
!                                lonb_mod, latb_mod, &
!                                drydep_data )
!   </TEMPLATE>

subroutine tropchem_drydep_init( dry_files, dry_names, &
                                 lonb_mod, latb_mod, &
                                 drydep_data )

!-----------------------------------------------------------------------

   real,                   intent(in),  dimension(:,:) :: lonb_mod, latb_mod
   character(len=64),      intent(out), dimension(:) :: dry_files, dry_names
   type(interpolate_type), intent(out)               :: drydep_data(:)

!-----------------------------------------------------------------------

   integer :: i
   integer :: flag_file, flag_spec
   character(len=64) :: filename,specname
   character(len=64) :: name='', control=''

!-----------------------------------------------------------------------

!---------- Set interpolator type for dry deposition
   call interpolator_init( drydep_data_default, trim(file_dry), lonb_mod, latb_mod, &
                           data_out_of_bounds=(/CONSTANT/), &
                           vert_interp=(/INTERP_WEIGHTED_P/))

   do i = 1,pcnstm1
      dry_files(i) = ''
      dry_names(i) = ''
      if( query_method('dry_deposition',MODEL_ATMOS,indices(i),name,control) )then
         if( trim(name) == 'file' ) then
            flag_file = parse(control, 'file',filename)
            flag_spec = parse(control, 'name',specname)
            if(flag_file > 0 .and. trim(filename) /= trim(file_dry)) then
               dry_files(i) = trim(filename)
               call interpolator_init( drydep_data(indices(i)), trim(filename), lonb_mod, latb_mod,&
                                       data_out_of_bounds=(/CONSTANT/), &
                                       vert_interp=(/INTERP_WEIGHTED_P/))
            else
               dry_files(i) = trim(file_dry)
               drydep_data(indices(i)) = drydep_data_default

            end if
            if(flag_spec >0) then
               dry_names(i) = trim(specname)
            else
               dry_names(i) = trim(lowercase(tracnam(i)))
            end if
         end if
      end if
   end do

end subroutine tropchem_drydep_init
!</SUBROUTINE>

!############################################################################
end module tropchem_driver_mod



module vert_advection_mod

!-------------------------------------------------------------------------------

use fms_mod, only: error_mesg, FATAL, write_version_number, stdout
use mpp_mod, only: mpp_sum, mpp_max            ,mpp_pe,mpp_sync

implicit none
private

public :: vert_advection, vert_advection_end
! for optional argument: scheme
integer, parameter, public :: SECOND_CENTERED          = 101
integer, parameter, public :: FOURTH_CENTERED          = 102
integer, parameter, public :: FINITE_VOLUME_LINEAR     = 103
integer, parameter, public :: FINITE_VOLUME_PARABOLIC  = 104
integer, parameter, public :: FINITE_VOLUME_PARABOLIC2 = 105
integer, parameter, public :: SECOND_CENTERED_WTS      = 106
integer, parameter, public :: FOURTH_CENTERED_WTS      = 107
integer, parameter, public :: VAN_LEER_LINEAR = FINITE_VOLUME_LINEAR
! for optional argument: form
integer, parameter, public :: FLUX_FORM = 201, ADVECTIVE_FORM = 202
! for optional argument: flags
integer, parameter, public :: WEIGHTED_TENDENCY=1
integer, parameter, public :: OUTFLOW_BOUNDARY=2

character(len=128), parameter :: version = '$Id: vert_advection.F90,v 17.0 2009/07/21 03:00:04 fms Exp $'
character(len=128), parameter :: tagname = '$Name: hiram_20101115_bw $'

logical :: module_is_initialized = .false.

interface vert_advection
   module procedure vert_advection_1d, vert_advection_2d, vert_advection_3d
end interface

! buffers for coefficients used by the parabolic scheme
  real, allocatable :: zwts(:,:,:,:), dzs(:,:,:)
  integer :: nlons = 0, nlats = 0, nlevs = 0

! for cfl diagnostics with finite volume schemes
  real    :: cflmaxc = 0.
  real    :: cflmaxx = 0.
  integer :: cflerr  = 0

contains

!-------------------------------------------------------------------------------

 subroutine vert_advection_3d ( dt, w, dz, r, rdt, mask, scheme, form, flags )

 real, intent(in)                    :: dt
 real, intent(in),  dimension(:,:,:) :: w, dz, r
 real, intent(out), dimension(:,:,:) :: rdt
 real,    intent(in), optional :: mask(:,:,:)
 integer, intent(in), optional :: scheme, form, flags

! INPUT
!   dt  = time step in seconds
!   w   = advecting velocity at the vertical boundaries of the grid boxes
!         does not assume velocities at top and bottom are zero
!         units = [units of dz / second]
!   dz  = depth of model layers in arbitrary units (usually pressure)
!   r   = advected quantity in arbitrary units
!
! OUTPUT
!   rdt = advective tendency for quantity "r" (units depend on optional flags argument)
!           the default units = [units of r / second]
!           if flags=WEIGHTED_TENDENCY then units = [units of r * units of dz / second]
!
! OPTIONAL INPUT
!   mask   = mask for below ground layers,
!            where mask > 0 for layers above ground
!   scheme = differencing scheme, use one of these values:
!               SECOND_CENTERED = second-order centered
!               FOURTH_CENTERED = fourth-order centered
!               SECOND_CENTERED_WTS = second-order centered (assuming unequal level spacing)
!               FOURTH_CENTERED_WTS = fourth-order centered (assuming unequal level spacing)
!               FINITE_VOLUME_LINEAR    = piecewise linear, finite volume (van Leer)
!               VAN_LEER_LINEAR         = same as FINITE_VOLUME_LINEAR
!               FINITE_VOLUME_PARABOLIC = piecewise parabolic, finite volume (PPM)
!               FINITE_VOLUME_PARABOLIC2 = piecewise parabolic, finite volume (PPM)
!                                          using relaxed montonicity constraint (Lin,2003)
!   form   = form of equations, use one of these values:
!               FLUX_FORM      = solves for -d(wr)/dt
!               ADVECTIVE_FORM = solves for -w*d(r)/dt
!   flags  = additional optional flags
!               WEIGHTED_TENDENCY = output tendency (rdt) has units = [units of r * units of dz / second]
!               OUTFLOW_BOUNDARY  = advection is computed at the top and bottom for outflow boundaries
!                                   this option is only valid for finite volume schemes
!
! NOTE
!   size(w,3) == size(dz,3)+1 == size(r,3)+1 == size(rdt,3)+1 == size(mask,3)+1

 real, dimension(size(r,1),size(r,2),size(r,3)) :: slp, r_left, r_right
 real, dimension(size(w,1),size(w,2),size(w,3)) :: flux
 real, dimension(0:3,size(r,1),size(r,2),size(r,3)) :: zwt
 real    :: xx, a, b, rm, r6, rst, wt
 real    :: tt, c1, c2
 real    :: small = 1.e-6
 logical :: test_1
 logical :: do_weighted_dt, do_outflow_bnd
 integer :: i, j, k, ks, ke, kstart, kend, iflags
 integer :: diff_scheme, eqn_form

 real :: cn, rsum, dzsum, dtw
 integer :: kk

 if(.not.module_is_initialized) then
   call write_version_number(version, tagname)
   module_is_initialized = .true.
 endif

 ! set default values for optional arguments
   diff_scheme = VAN_LEER_LINEAR
   eqn_form    = FLUX_FORM
   if (present(scheme)) diff_scheme = scheme
   if (present(form))   eqn_form    = form
 ! set optional flags
   iflags = 0; if (present(flags)) iflags = flags
   do_weighted_dt = btest(iflags,0)
   do_outflow_bnd = btest(iflags,1)
   

 ! note: size(r,3)+1 = size(w,3)
   if (size(w,3) /= size(r,3)+1) &
      call error_handler ('vertical dimension of input arrays inconsistent')

 ! vertical indexing
   ks = 1; ke = size(r,3)

 ! start and end indexing for finite volume fluxes
   kstart = ks+1;  kend = ke
   if (do_outflow_bnd) then
       kstart = ks;  kend = ke+1
   endif

 ! set fluxes at boundaries
 ! most likely w = 0 at these points
 ! but for outflow boundaries set flux to zero

   if (do_outflow_bnd) then
       flux(:,:,ks)   = 0.
       flux(:,:,ke+1) = 0.
   else
       flux(:,:,ks)   = w(:,:,ks)  *r(:,:,ks)
       flux(:,:,ke+1) = w(:,:,ke+1)*r(:,:,ke)
   endif

   select case (diff_scheme)

   !------ 2nd-order centered scheme assuming variable grid spacing ------
      case (SECOND_CENTERED_WTS)
         do k = ks+1, ke
         do j = 1, size(r,2)
         do i = 1, size(r,1)
            wt = dz(i,j,k-1)/(dz(i,j,k-1)+dz(i,j,k))
            rst = r(i,j,k-1) + wt*(r(i,j,k)-r(i,j,k-1))
            flux(i,j,k) = w(i,j,k)*rst
         enddo
         enddo
         enddo

   !------ 2nd-order centered scheme assuming uniform grid spacing ------
      case (SECOND_CENTERED)
         do k = ks+1, ke
         do j = 1, size(r,2)
         do i = 1, size(r,1)
            rst = 0.5*(r(i,j,k)+r(i,j,k-1))
            flux(i,j,k) = w(i,j,k)*rst
         enddo
         enddo
         enddo

   !------ 4th-order centered scheme assuming variable grid spacing ------
      case (FOURTH_CENTERED_WTS)
         call compute_weights ( dz, zwt )
         call slope_z ( r, dz, slp, limit=.false., linear=.false. )
         if (present(mask)) then
          ! second order if adjacent to ground
            do k = ks+2, ke-1
            do j = 1, size(r,2)
            do i = 1, size(r,1)
               if (mask(i,j,k+1) > small) then
                  rst = r(i,j,k-1) + zwt(1,i,j,k)*(r(i,j,k)-r(i,j,k-1)) &
                        - zwt(2,i,j,k)*slp(i,j,k) + zwt(3,i,j,k)*slp(i,j,k-1)
               else
                  rst = r(i,j,k-1) + zwt(0,i,j,k)*(r(i,j,k)-r(i,j,k-1))
               endif
            flux(i,j,k) = w(i,j,k)*rst
            enddo
            enddo
            enddo
         else
          ! no mask: always fourth order
            do k = ks+2, ke-1
            do j = 1, size(r,2)
            do i = 1, size(r,1)
               rst = r(i,j,k-1) + zwt(1,i,j,k)*(r(i,j,k)-r(i,j,k-1)) &
                        - zwt(2,i,j,k)*slp(i,j,k) + zwt(3,i,j,k)*slp(i,j,k-1)
               flux(i,j,k) = w(i,j,k)*rst
            enddo
            enddo
            enddo
         endif
         ! second order at top and bottom
         do j = 1, size(r,2)
         do i = 1, size(r,1)
            wt  = dz(i,j,ks)/(dz(i,j,ks)+dz(i,j,ks+1))
            rst = r(i,j,ks) + wt*(r(i,j,ks+1)-r(i,j,ks))
            flux(i,j,ks+1) = w(i,j,ks+1)*rst
            wt  = dz(i,j,ke-1)/(dz(i,j,ke-1)+dz(i,j,ke))
            rst = r(i,j,ke-1) + wt*(r(i,j,ke)-r(i,j,ke-1))
            flux(i,j,ke) = w(i,j,ke)*rst
         enddo
         enddo

   !------ 4th-order centered scheme assuming uniform grid spacing ------
      case (FOURTH_CENTERED)
         c1 = 7./12.;  c2 = 1./12.
         if (present(mask)) then
          ! second order if adjacent to ground
            do k = ks+2, ke-1
            do j = 1, size(r,2)
            do i = 1, size(r,1)
               if (mask(i,j,k+1) > small) then
                  rst = c1*(r(i,j,k)+r(i,j,k-1)) - c2*(r(i,j,k+1)+r(i,j,k-2))
               else
                  rst = 0.5*(r(i,j,k)+r(i,j,k-1))
               endif
               flux(i,j,k) = w(i,j,k)*rst
            enddo
            enddo
            enddo
         else
          ! no mask: always fourth order
            do k = ks+2, ke-1
            do j = 1, size(r,2)
            do i = 1, size(r,1)
               rst = c1*(r(i,j,k)+r(i,j,k-1)) - c2*(r(i,j,k+1)+r(i,j,k-2))
               flux(i,j,k) = w(i,j,k)*rst
            enddo
            enddo
            enddo
         endif
         ! second order at top and bottom
         do j = 1, size(r,2)
         do i = 1, size(r,1)
            rst = 0.5*(r(i,j,ks+1)+r(i,j,ks  ))
            flux(i,j,ks+1) = w(i,j,ks+1)*rst
            rst = 0.5*(r(i,j,ke  )+r(i,j,ke-1))
            flux(i,j,ke) = w(i,j,ke)*rst
         enddo
         enddo

   !------ finite volume scheme using piecewise linear method ------
      case (FINITE_VOLUME_LINEAR)
       ! slope along the z-axis
         call slope_z ( r, dz, slp )
         do k = kstart, kend
         do j = 1, size(r,2)
         do i = 1, size(r,1)
            if (w(i,j,k) >= 0.) then
               if (k == ks) cycle ! inflow
               cn = dt*w(i,j,k)/dz(i,j,k-1)
               rst = r(i,j,k-1) + 0.5*slp(i,j,k-1)*(1.-cn)
            else
               if (k == ke+1) cycle ! inflow
               cn = -dt*w(i,j,k)/dz(i,j,k)
               rst = r(i,j,k  ) - 0.5*slp(i,j,k  )*(1.-cn)
            endif
            flux(i,j,k) = w(i,j,k)*rst
            if (cn > 1.) cflerr = cflerr+1
            cflmaxc = max(cflmaxc,cn)
            cflmaxx = cflmaxc ! same for linear scheme
         enddo
         enddo
         enddo

   !------ finite volume scheme using piecewise parabolic method (PPM) ------
      case (FINITE_VOLUME_PARABOLIC:FINITE_VOLUME_PARABOLIC2)
         call compute_weights ( dz, zwt )
         call slope_z ( r, dz, slp, linear=.false. )
         do k = ks+2, ke-1
         do j = 1, size(r,2)
         do i = 1, size(r,1)
            r_left(i,j,k) = r(i,j,k-1) + zwt(1,i,j,k)*(r(i,j,k)-r(i,j,k-1)) &
                   - zwt(2,i,j,k)*slp(i,j,k) + zwt(3,i,j,k)*slp(i,j,k-1)        
            r_right(i,j,k-1) = r_left(i,j,k)
            ! coming out of this loop, all we need is r_left and r_right
         enddo
         enddo
         enddo

         ! boundary values  ! masks ???????

         do j = 1, size(r,2)
         do i = 1, size(r,1)
           r_left (i,j,ks+1) = r(i,j,ks+1) - 0.5*slp(i,j,ks+1)
           r_right(i,j,ke-1) = r(i,j,ke-1) + 0.5*slp(i,j,ke-1)

         ! pure upstream advection near boundary
         ! r_left (i,j,ks) = r(i,j,ks)
         ! r_right(i,j,ks) = r(i,j,ks)
         ! r_left (i,j,ke) = r(i,j,ke)
         ! r_right(i,j,ke) = r(i,j,ke)

         ! make linear assumption near boundary
         ! NOTE: slope is zero at ks and ks therefore
         !       this reduces to upstream advection near boundary
           r_left (i,j,ks) = r(i,j,ks) - 0.5*slp(i,j,ks)
           r_right(i,j,ks) = r(i,j,ks) + 0.5*slp(i,j,ks)
           r_left (i,j,ke) = r(i,j,ke) - 0.5*slp(i,j,ke)
           r_right(i,j,ke) = r(i,j,ke) + 0.5*slp(i,j,ke)
         enddo
         enddo

     ! monotonicity constraint

       if (diff_scheme == FINITE_VOLUME_PARABOLIC2) then
         ! limiters from Lin (2003), Equation 6 (relaxed constraint)
           do k = ks, ke
           do j = 1, size(r,2)
           do i = 1, size(r,1)
              r_left (i,j,k) = r(i,j,k) - sign( min(abs(slp(i,j,k)),abs(r_left (i,j,k)-r(i,j,k))), slp(i,j,k) )
              r_right(i,j,k) = r(i,j,k) + sign( min(abs(slp(i,j,k)),abs(r_right(i,j,k)-r(i,j,k))), slp(i,j,k) )
           enddo
           enddo
           enddo
       else
         ! limiters from Colella and Woodward (1984), Equation 1.10
           do k = ks, ke
           do j = 1, size(r,2)
           do i = 1, size(r,1)
              test_1 = (r_right(i,j,k)-r(i,j,k))*(r(i,j,k)-r_left(i,j,k)) <= 0.0
              if (test_1) then
                 r_left(i,j,k)  = r(i,j,k)
                 r_right(i,j,k) = r(i,j,k)
              endif
              if (k == ks .or. k == ke) cycle
              rm = r_right(i,j,k) - r_left(i,j,k)
              a = rm*(r(i,j,k) - 0.5*(r_right(i,j,k) + r_left(i,j,k)))
              b = rm*rm/6.
              if (a >  b) r_left (i,j,k) = 3.0*r(i,j,k) - 2.0*r_right(i,j,k)
              if (a < -b) r_right(i,j,k) = 3.0*r(i,j,k) - 2.0*r_left (i,j,k)
           enddo
           enddo
           enddo
       endif

         ! compute fluxes at interfaces

           tt = 2./3.
           do k = kstart, kend
           do j = 1, size(r,2)
           do i = 1, size(r,1)
              if (w(i,j,k) >= 0.) then
                  if (k == ks) cycle ! inflow
                  cn = dt*w(i,j,k)/dz(i,j,k-1)
                  kk = k-1
                  ! extension for Courant numbers > 1
                  if (cn > 1.) then
                      rsum = 0.
                      dzsum = 0.
                      dtw = dt*w(i,j,k)
                      do while (dzsum+dz(i,j,kk) < dtw)
                         if (kk == 1) then
                             exit
                         endif
                         dzsum = dzsum + dz(i,j,kk)
                          rsum =  rsum +  r(i,j,kk)
                         kk = kk-1
                      enddo
                      xx = (dtw-dzsum)/dz(i,j,kk)
                  else
                      xx = cn
                  endif
                  rm = r_right(i,j,kk) - r_left(i,j,kk)
                  r6 = 6.0*(r(i,j,kk) - 0.5*(r_right(i,j,kk) + r_left(i,j,kk)))
                  if (kk == ks) r6 = 0.
                  rst = r_right(i,j,kk) - 0.5*xx*(rm - (1.0 - tt*xx)*r6)
                  ! extension for Courant numbers > 1
                  if (cn > 1.) rst = (xx*rst + rsum)/cn
              else
                  if (k == ke+1) cycle ! inflow
                  cn = - dt*w(i,j,k)/dz(i,j,k)
                  kk = k
                  ! extension for Courant numbers > 1
                  if (cn > 1.) then
                      rsum = 0.
                      dzsum = 0.
                      dtw = -dt*w(i,j,k)
                      do while (dzsum+dz(i,j,kk) < dtw)
                         if (kk == ks) then
                             exit
                         endif
                         dzsum = dzsum + dz(i,j,kk)
                          rsum =  rsum +  r(i,j,kk)
                         kk = kk+1
                      enddo
                      xx = (dtw-dzsum)/dz(i,j,kk)
                  else
                      xx = cn
                  endif
                  rm = r_right(i,j,kk) - r_left(i,j,kk)
                  r6 = 6.0*(r(i,j,kk) - 0.5*(r_right(i,j,kk) + r_left(i,j,kk)))
                  if (kk == ke) r6 = 0.
                  rst = r_left(i,j,kk) + 0.5*xx*(rm + (1.0 - tt*xx)*r6)
                  ! extension for Courant numbers > 1
                  if (cn > 1.) rst = (xx*rst + rsum)/cn
              endif
              flux(i,j,k) = w(i,j,k)*rst
              if (xx > 1.) cflerr = cflerr+1
              cflmaxx = max(cflmaxx,xx)
              cflmaxc = max(cflmaxc,cn)
           enddo
           enddo
           enddo


      case default
        ! ERROR
          call error_handler ('invalid value for optional argument scheme')
   end select


 ! vertical advective tendency

   select case (eqn_form)
      case (FLUX_FORM)
         if (do_weighted_dt) then
            do k = ks, ke
               rdt (:,:,k) = - (flux(:,:,k+1) - flux (:,:,k)) 
            enddo
         else
            do k = ks, ke
               rdt (:,:,k) = - (flux(:,:,k+1) - flux (:,:,k))  / dz(:,:,k)
            enddo
         endif
      case (ADVECTIVE_FORM)
         if (do_weighted_dt) then
            do k = ks, ke
               rdt (:,:,k) = - (flux(:,:,k+1) - flux (:,:,k) - &
                            r(:,:,k)*(w(:,:,k+1)-w(:,:,k)))
            enddo
         else
            do k = ks, ke
               rdt (:,:,k) = - (flux(:,:,k+1) - flux (:,:,k) - &
                            r(:,:,k)*(w(:,:,k+1)-w(:,:,k))) / dz(:,:,k)
            enddo
         endif
      case default
        ! ERROR
          call error_handler ('invalid value for optional argument form')
   end select


 end subroutine vert_advection_3d

!-------------------------------------------------------------------------------

 subroutine vert_advection_end

  integer :: outunit
  ! deallocate storage
    if (allocated(zwts)) deallocate(zwts)
    if (allocated(dzs))  deallocate(dzs)

  ! cfl diagnostics
    call mpp_max (cflmaxc)
    call mpp_max (cflmaxx)
    call mpp_sum (cflerr) ! integer sum
    if (cflmaxc > 0.) then
        outunit = stdout()
        write (outunit,10) cflmaxc, cflmaxx, cflerr
    endif
 10 format (/,' Vertical advection (atmosphere):',    &
            /,'     maximum CFL =',f10.6,'; ',f10.6,  &
            /,'     number of CFL errors =',i5,/)
        
 end subroutine vert_advection_end

!-------------------------------------------------------------------------------

 subroutine slope_z ( r, dz, slope, limit, linear )
 real, intent(in),  dimension(:,:,:) :: r, dz
 real, intent(out), dimension(:,:,:) :: slope
 logical, intent(in), optional :: limit, linear

!real    :: grad(size(r,1),size(r,2),2:size(r,3))
 real    :: grad(2:size(r,3))
 real    :: rmin, rmax
 integer :: i, j, k, n
 logical :: limiters, dolinear

  limiters = .true.
  if (present(limit))  limiters = limit
  dolinear = .true.
  if (present(linear)) dolinear = linear

  n = size(r,3)

! compute slope (weighted for unequal levels)

  do j = 1, size(r,2)
  do i = 1, size(r,1)

     do k = 2, n
       grad(k) = (r(i,j,k)-r(i,j,k-1))/(dz(i,j,k)+dz(i,j,k-1))
     enddo
     if (dolinear) then
         do k = 2, n-1
           slope(i,j,k) = (grad(k+1)+grad(k))*dz(i,j,k)
         enddo
     else
         do k = 2, n-1
           slope(i,j,k) = (grad(k+1)*(2.*dz(i,j,k-1)+dz(i,j,k)) + &
                           grad(k  )*(2.*dz(i,j,k+1)+dz(i,j,k)))  &
                          *dz(i,j,k)/(dz(i,j,k-1)+dz(i,j,k)+dz(i,j,k+1))
         enddo
     endif
     slope(i,j,1) = 2.*grad(2)*dz(i,j,1)
     slope(i,j,n) = 2.*grad(n)*dz(i,j,n)

   ! apply limiters to slope
     if (limiters) then
        do k = 1, n
          if (k >= 2 .and. k <= n-1) then
            rmin = min(r(i,j,k-1), r(i,j,k), r(i,j,k+1))
            rmax = max(r(i,j,k-1), r(i,j,k), r(i,j,k+1))
            slope(i,j,k) = sign(1.,slope(i,j,k)) *  &
                   min( abs(slope(i,j,k)), 2.*(r(i,j,k)-rmin), 2.*(rmax-r(i,j,k)) )
          else
         !else if (k == 1) then               ! always slope=0
         !  rmin = min(r(i,j,k), r(i,j,k+1))
         !  rmax = max(r(i,j,k), r(i,j,k+1))
         !else if (k == n) then
         !  rmin = min(r(i,j,k-1), r(i,j,k))
         !  rmax = max(r(i,j,k-1), r(i,j,k))
            slope(i,j,k) = 0.
          endif
        enddo
     endif

  enddo
  enddo

 end subroutine slope_z

!-------------------------------------------------------------------------------

 subroutine compute_weights ( dz, zwt )
 real, intent(in),  dimension(:,:,:)    :: dz
 real, intent(out), dimension(0:,:,:,:) :: zwt
 real    :: denom1, denom2, denom3, denom4, num3, num4, x, y
 integer :: i, j, k
 logical :: redo

! check the size of stored coefficients
! need to reallocate if size has changed
   if (nlons /= size(dz,1) .or. nlats /= size(dz,2) .or.  nlevs /= size(dz,3)) then
      if (allocated(zwts)) deallocate(zwts)
      if (allocated(dzs))  deallocate(dzs)
      nlons = size(dz,1)
      nlats = size(dz,2)
      nlevs = size(dz,3)
      allocate (zwts(0:3,nlons,nlats,nlevs))
      allocate (dzs (nlons,nlats,nlevs))
      dzs = -1.
   endif
   
! coefficients/weights for computing values at grid box interfaces
! only recompute coefficients for a column when layer depth has changed

   do j = 1, size(dz,2)
   do i = 1, size(dz,1)

    redo = .false.
    do k=1,size(dz,3)
      if (dz(i,j,k) /= dzs(i,j,k)) then
        redo = .true.
        exit
      endif
    enddo

   if (redo) then
     do k = 3, size(dz,3)-1
       denom1 = 1.0/(dz(i,j,k-1) + dz(i,j,k))
       denom2 = 1.0/(dz(i,j,k-2) + dz(i,j,k-1) + dz(i,j,k) + dz(i,j,k+1))
       denom3 = 1.0/(2*dz(i,j,k-1) +   dz(i,j,k))  
       denom4 = 1.0/(  dz(i,j,k-1) + 2*dz(i,j,k))  
       num3   = dz(i,j,k-2) + dz(i,j,k-1)          
       num4   = dz(i,j,k)   + dz(i,j,k+1)        
       x      = num3*denom3 - num4*denom4        
       y      = 2.0*dz(i,j,k-1)*dz(i,j,k) ! everything up to this point is just
                                          ! needed to compute x1,x1,x3                      
       zwt(0,i,j,k) = dz(i,j,k-1)*denom1                ! = 1/2 in equally spaced case
       zwt(1,i,j,k) = zwt(0,i,j,k) + x*y*denom1*denom2  ! = 1/2 in equally spaced case
       zwt(2,i,j,k) = dz(i,j,k-1)*num3*denom3*denom2    ! = 1/6 ''
       zwt(3,i,j,k) = dz(i,j,k)*num4*denom4*denom2      ! = 1/6 ''
     enddo
     dzs(i,j,:) = dz(i,j,:)
     zwts(0:3,i,j,:) = zwt(0:3,i,j,:)
   else

   ! use previously computed coefficients
     zwt(0:3,i,j,:) = zwts(0:3,i,j,:)
   endif

   enddo
   enddo


 end subroutine compute_weights

!-------------------------------------------------------------------------------
!--------------------------- overloaded versions -------------------------------

 subroutine vert_advection_1d ( dt, w, dz, r, rdt, mask, scheme, form, flags )
 
 real, intent(in)                :: dt
 real, intent(in),  dimension(:) :: w, dz, r
 real, intent(out), dimension(:) :: rdt
 real,    intent(in), optional :: mask(:)
 integer, intent(in), optional :: scheme, form, flags

 real, dimension(1,1,size(r,1)) :: dz3, r3, rdt3, mask3
 real, dimension(1,1,size(w,1)) :: w3

  ! input
    w3 (1,1,:) = w
    dz3(1,1,:) = dz
    r3 (1,1,:) = r

    if (present(mask)) then
       mask3(1,1,:) = mask
       call vert_advection_3d ( dt, w3, dz3, r3, rdt3, mask=mask3, scheme=scheme, form=form, flags=flags )
    else
       call vert_advection_3d ( dt, w3, dz3, r3, rdt3, scheme=scheme, form=form, flags=flags )
    endif

  ! output
    rdt = rdt3(1,1,:)

 end subroutine vert_advection_1d

!-------------------------------------------------------------------------------

 subroutine vert_advection_2d ( dt, w, dz, r, rdt, mask, scheme, form, flags )

 real, intent(in)                  :: dt
 real, intent(in),  dimension(:,:) :: w, dz, r
 real, intent(out), dimension(:,:) :: rdt
 real,    intent(in), optional :: mask(:,:)
 integer, intent(in), optional :: scheme, form, flags

 real, dimension(size(r,1),1,size(r,2)) :: dz3, r3, rdt3, mask3
 real, dimension(size(w,1),1,size(w,2)) :: w3

  ! input
    w3 (:,1,:) = w
    dz3(:,1,:) = dz
    r3 (:,1,:) = r

    if (present(mask)) then
       mask3(:,1,:) = mask
       call vert_advection_3d ( dt, w3, dz3, r3, rdt3, mask=mask3, scheme=scheme, form=form, flags=flags )
    else
       call vert_advection_3d ( dt, w3, dz3, r3, rdt3, scheme=scheme, form=form, flags=flags )
    endif

  ! output
    rdt = rdt3(:,1,:)

 end subroutine vert_advection_2d

!-------------------------------------------------------------------------------

 subroutine error_handler ( message )
 character(len=*), intent(in) :: message

   call error_mesg ('vert_advection', trim(message), FATAL)

!  print *, 'FATAL ERROR in vert_advection'
!  print *, trim(message)
!  stop 111

 end subroutine error_handler

!-------------------------------------------------------------------------------

end module vert_advection_mod



!
!  coupler_main couples component models and controls the time integration
!
program coupler_main
!-----------------------------------------------------------------------
!                   GNU General Public License                        
!                                                                      
! This program is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
! <CONTACT EMAIL="Bruce.Wyman@noaa.gov"> Bruce Wyman </CONTACT>
! <CONTACT EMAIL="V.Balaji@noaa.gov"> V. Balaji </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!  A main program that couples component models for atmosphere, ocean, land, 
!  and sea ice on independent grids. 
! </OVERVIEW>

! <DESCRIPTION>
!  This version couples model components representing atmosphere, ocean, land 
!  and sea ice on independent grids. Each model component is represented by a 
!  data type giving the instantaneous model state.
!
!  The component models are coupled to allow implicit vertical diffusion of 
!  heat and moisture at the interfaces of the atmosphere, land, and ice models. 
!  As a result, the atmosphere, land, and ice models all use the same time step. 
!  The atmospheric model has been separated into down and up calls that 
!  correspond to the down and up sweeps of the standard tridiagonal elimination.
!
!  The ocean interface uses explicit mixing. Fluxes to and from the ocean must
!  be passed through the ice model. This includes atmospheric fluxes as well as 
!  fluxes from the land to the ocean (runoff).
!
!  This program contains the model's main time loop. Each iteration of the 
!  main time loop is one coupled (slow) time step. Within this slow time step 
!  loop is a fast time step loop, using the atmospheric time step, where the
!  tridiagonal vertical diffusion equations are solved. Exchange between sea 
!  ice and ocean occurs once every slow timestep.
!
! <PRE>
!      MAIN PROGRAM EXAMPLE
!      --------------------
!
!         DO slow time steps (ocean)
!
!              call flux_ocean_to_ice
!
!              call ICE_SLOW_UP
!
!              DO fast time steps (atmos)
!
!                   call flux_calculation
!
!                   call ATMOS_DOWN
!
!                   call flux_down_from_atmos
!
!                   call LAND_FAST
!
!                   call ICE_FAST
!
!                   call flux_up_to_atmos
!
!                   call ATMOS_UP
!
!              END DO
!
!              call ICE_SLOW_DN
!
!              call flux_ice_to_ocean
!
!              call OCEAN
!
!         END DO

!  </PRE>

! </DESCRIPTION>
! <INFO>
!   <NOTE>
!     <PRE>
!   1.If no value is set for current_date, start_date, or calendar (or default value 
!     specified) then the value from restart file "INPUT/coupler.res" will be used. 
!     If neither a namelist value or restart file value exist the program will fail. 
!   2.The actual run length will be the sum of months, days, hours, minutes, and 
!     seconds. A run length of zero is not a valid option. 
!   3.The run length must be an intergal multiple of the coupling timestep dt_cpld. 
!     </PRE>
!   </NOTE>

!   <ERROR MSG="no namelist value for current_date " STATUS="FATAL">
!     A namelist value for current_date must be given if no restart file for
!     coupler_main (INPUT/coupler.res) is found. 
!   </ERROR>
!   <ERROR MSG="invalid namelist value for calendar" STATUS="FATAL">
!     The value of calendar must be 'julian', 'noleap', or 'thirty_day'. 
!     See the namelist documentation. 
!   </ERROR>
!   <ERROR MSG="no namelist value for calendar" STATUS="FATAL">
!     If no restart file is present, then a namelist value for calendar 
!     must be specified. 
!   </ERROR>
!   <ERROR MSG="initial time is greater than current time" STATUS="FATAL">
!     If a restart file is present, then the namelist value for either 
!     current_date or start_date was incorrectly set. 
!   </ERROR>
!   <ERROR MSG="run length must be multiple of ocean time step " STATUS="FATAL">
!     There must be an even number of ocean time steps for the requested run length. 
!   </ERROR>
!   <ERROR MSG="final time does not match expected ending time " STATUS="WARNING">
!     This error should probably not occur because of checks done at initialization time. 
!   </ERROR>

! </INFO>

  use constants_mod,           only: constants_init

  use time_manager_mod,        only: time_type, set_calendar_type, set_time
  use time_manager_mod,        only: set_date, get_date, days_in_month, month_name
  use time_manager_mod,        only: operator(+), operator(-), operator (<)
  use time_manager_mod,        only: operator (>), operator ( /= ), operator ( / )
  use time_manager_mod,        only: operator (*), THIRTY_DAY_MONTHS, JULIAN
  use time_manager_mod,        only: NOLEAP, NO_CALENDAR, INVALID_CALENDAR
  use time_manager_mod,        only: date_to_string, increment_date
  use time_manager_mod,        only: operator(>=), operator(<=), operator(==)

  use fms_mod,                 only: open_namelist_file, field_exist, file_exist, check_nml_error
  use fms_mod,                 only: uppercase, error_mesg, write_version_number
  use fms_mod,                 only: fms_init, fms_end, stdout
  use fms_mod,                 only: read_data, write_data

  use fms_io_mod,              only: fms_io_exit
  use fms_io_mod,              only: restart_file_type, register_restart_field, save_restart

  use diag_manager_mod,        only: diag_manager_init, diag_manager_end, diag_grid_end
  use diag_manager_mod,        only: DIAG_OCEAN, DIAG_OTHER, DIAG_ALL, get_base_date
  use diag_manager_mod,        only: diag_manager_set_time_end

  use field_manager_mod,       only: MODEL_ATMOS, MODEL_LAND, MODEL_ICE

  use tracer_manager_mod,      only: tracer_manager_init, get_tracer_index
  use tracer_manager_mod,      only: get_number_tracers, get_tracer_names, NO_TRACER

  use coupler_types_mod,       only: coupler_types_init

  use data_override_mod,       only: data_override_init

!
! model interfaces used to couple the component models:
!               atmosphere, land, ice, and ocean
!

  use atmos_model_mod,         only: atmos_model_init, atmos_model_end
  use atmos_model_mod,         only: update_atmos_model_down
  use atmos_model_mod,         only: update_atmos_model_up
  use atmos_model_mod,         only: atmos_data_type
  use atmos_model_mod,         only: land_ice_atmos_boundary_type
  use atmos_model_mod,         only: atmos_data_type_chksum
  use atmos_model_mod,         only: lnd_ice_atm_bnd_type_chksum
  use atmos_model_mod,         only: lnd_atm_bnd_type_chksum
  use atmos_model_mod,         only: ice_atm_bnd_type_chksum
  use atmos_model_mod,         only: atmos_model_restart

  use land_model_mod,          only: land_model_init, land_model_end
  use land_model_mod,          only: land_data_type, atmos_land_boundary_type
  use land_model_mod,          only: update_land_model_fast, update_land_model_slow
  use land_model_mod,          only: atm_lnd_bnd_type_chksum
  use land_model_mod,          only: land_data_type_chksum
  use land_model_mod,          only: land_model_restart

  use ice_model_mod,           only: ice_model_init, ice_model_end
  use ice_model_mod,           only: update_ice_model_slow_up
  use ice_model_mod,           only: update_ice_model_fast
  use ice_model_mod,           only: update_ice_model_slow_dn
  use ice_model_mod,           only: ice_data_type, land_ice_boundary_type
  use ice_model_mod,           only: ocean_ice_boundary_type, atmos_ice_boundary_type
  use ice_model_mod,           only: ice_model_restart
  use ice_model_mod,           only: ice_data_type_chksum, ocn_ice_bnd_type_chksum
  use ice_model_mod,           only: atm_ice_bnd_type_chksum, lnd_ice_bnd_type_chksum

  use ocean_model_mod,         only: update_ocean_model, ocean_model_init
  use ocean_model_mod,         only: ocean_model_end, ocean_public_type, ocean_state_type, ice_ocean_boundary_type
  use ocean_model_mod,         only: ocean_model_restart
  use ocean_model_mod,         only: ocean_public_type_chksum, ice_ocn_bnd_type_chksum
!
! flux_ calls translate information between model grids - see flux_exchange.f90
!

  use flux_exchange_mod,       only: flux_exchange_init
  use flux_exchange_mod,       only: sfc_boundary_layer
  use flux_exchange_mod,       only: generate_sfc_xgrid
  use flux_exchange_mod,       only: flux_down_from_atmos
  use flux_exchange_mod,       only: flux_up_to_atmos
  use flux_exchange_mod,       only: flux_land_to_ice
  use flux_exchange_mod,       only: flux_ice_to_ocean
  use flux_exchange_mod,       only: flux_ocean_to_ice
  use flux_exchange_mod,       only: flux_check_stocks, flux_init_stocks, flux_ice_to_ocean_stocks, flux_ocean_from_ice_stocks

  use atmos_tracer_driver_mod, only: atmos_tracer_driver_gather_data

  use mpp_mod,                 only: mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_chksum
  use mpp_mod,                 only: mpp_init, mpp_pe, mpp_npes, mpp_root_pe, MAXPES
  use mpp_mod,                 only: stderr, stdlog, mpp_error, NOTE, FATAL, WARNING
  use mpp_mod,                 only: mpp_set_current_pelist, mpp_declare_pelist
  use mpp_mod,                 only: input_nml_file

  use mpp_io_mod,              only: mpp_open, mpp_close, mpp_io_clock_on
  use mpp_io_mod,              only: MPP_NATIVE, MPP_RDONLY, MPP_DELETE

  use mpp_domains_mod,         only: mpp_broadcast_domain

  use memutils_mod,            only: print_memuse_stats

  implicit none

!-----------------------------------------------------------------------

  character(len=128) :: version = '$Id: coupler_main.F90,v 18.0.4.1.4.1.2.1 2010/08/31 14:38:01 z1l Exp $'
  character(len=128) :: tag = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
!---- model defined-types ----

  type (atmos_data_type) :: Atm
  type  (land_data_type) :: Land
  type   (ice_data_type) :: Ice
  ! allow members of ocean type to be aliased (ap)
  type (ocean_public_type), target :: Ocean
  type (ocean_state_type),  pointer :: Ocean_state => NULL()

  type(atmos_land_boundary_type)     :: Atmos_land_boundary
  type(atmos_ice_boundary_type)      :: Atmos_ice_boundary
  type(land_ice_atmos_boundary_type) :: Land_ice_atmos_boundary
  type(land_ice_boundary_type)       :: Land_ice_boundary
  type(ice_ocean_boundary_type)      :: Ice_ocean_boundary
  type(ocean_ice_boundary_type)      :: Ocean_ice_boundary

!-----------------------------------------------------------------------
! ----- coupled model time -----

  type (time_type) :: Time, Time_init, Time_end, &
                      Time_step_atmos, Time_step_cpld
  type(time_type) :: Time_atmos, Time_ocean
  integer :: num_atmos_calls, na
  integer :: num_cpld_calls, nc

!------ for intermediate restart
  type(restart_file_type), allocatable :: Ice_bc_restart(:), Ocn_bc_restart(:)
  character(len=64),       allocatable :: ice_bc_restart_file(:), ocn_bc_restart_file(:) 
  integer                              :: num_ice_bc_restart=0, num_ocn_bc_restart=0
  type(time_type)                      :: Time_restart, Time_restart_current, Time_start
  character(len=32)                    :: timestamp

! ----- coupled model initial date -----

  integer :: date_init(6)
  integer :: calendar_type = INVALID_CALENDAR

!-----------------------------------------------------------------------
!------ namelist interface -------

! <NAMELIST NAME="coupler_nml">
!   <DATA NAME="current_date"  TYPE="integer, dimension(6)"  DEFAULT="0">
!     The date that the current integration starts with. 
!   </DATA>
!   <DATA NAME="force_date_from_namelist"  TYPE="logical"  DEFAULT=".false.">
!     Flag that determines whether the namelist variable current_date should 
!     override the date in the restart file INPUT/coupler.res. If the restart 
!     file does not exist then force_date_from_namelist has not effect, the value of current_date 
!     will be used.
!   </DATA>
!   <DATA NAME="calendar"  TYPE="character(maxlen=17)"  DEFAULT="''">
!     The calendar type used by the current integration. Valid values are consistent 
!     with the time_manager module: 'julian', 'noleap', or 'thirty_day'. The value 
!     'no_calendar' can not be used because the time_manager's date  function are used. 
!     All values must be lowercase.
!   </DATA>
!   <DATA NAME="months "  TYPE="integer"  DEFAULT="0">
!     The number of months that the current integration will be run for. 
!   </DATA>
!   <DATA NAME="days "  TYPE="integer"  DEFAULT="0">
!     The number of days that the current integration will be run for. 
!   </DATA>
!   <DATA NAME="hours"  TYPE="integer"  DEFAULT="0">
!     The number of hours that the current integration will be run for. 
!   </DATA>
!   <DATA NAME="minutes "  TYPE="integer"  DEFAULT="0">
!     The number of minutes that the current integration will be run for. 
!   </DATA>
!   <DATA NAME="seconds"  TYPE="integer"  DEFAULT="0">
!     The number of seconds that the current integration will be run for. 
!   </DATA>
!   <DATA NAME="dt_atmos"  TYPE="integer"  DEFAULT="0">
!     Atmospheric model time step in seconds, including the fast coupling with 
!     land and sea ice. 
!   </DATA>
!   <DATA NAME="dt_cpld"  TYPE="integer"  DEFAULT="0">
!     Time step in seconds for coupling between ocean and atmospheric models: 
!     must be an integral multiple of dt_atmos and dt_ocean. This is the "slow" timestep.
!   </DATA>
!  <DATA NAME="do_atmos, do_ocean, do_ice, do_land, do_flux" TYPE="logical">
!  If true (default), that particular model component (atmos, etc.) is run.
!  If false, the execution of that component is skipped. This is used when
!  ALL the output fields sent by that component to the coupler have been
!  overridden using the data_override feature. For advanced users only:
!  if you're not sure, you should leave these values at TRUE.
!  </DATA> 
!  <DATA NAME="concurrent" TYPE="logical">
!  If true, the ocean executes concurrently with the atmosphere-land-ocean
!   on a separate set of PEs.
!  If false (default), the execution is serial: call atmos... followed by
!  call ocean...
!  If using concurrent execution, you must set one of
!   atmos_npes and ocean_npes, see below.
!  </DATA> 
!  <DATA NAME="atmos_npes, ocean_npes" TYPE="integer">
!  If concurrent is set to true, we use these to set the list of PEs on which
!   each component runs.
!  At least one of them must be set to a number between 0 and NPES.
!  If exactly one of these two is set non-zero, the other is set to the
!   remainder from NPES.
!  If both are set non-zero they must add up to NPES.
!  </DATA> 
!  <DATA NAME="use_lag_fluxes" TYPE="logical">
!  If true, then mom4 is forced with SBCs from one coupling timestep ago
!  If false, then mom4 is forced with most recent SBCs.
!  For a leapfrog MOM coupling with dt_cpld=dt_ocean, lag fluxes
!  can be shown to be stable and current fluxes to be unconditionally unstable.
!  For dt_cpld>dt_ocean there is probably sufficient damping.
!  use_lag_fluxes is set to TRUE by default.
!  </DATA>
!  <DATA NAME="n_mask" TYPE="integer">
!    number of region to be masked out. Its value should be less than MAX_PES.
!  </DATA>
!  <DATA NAME="mask_list(2,MAXPES)" TYPE="integer, dimension(2,MAX_MASK_REGION)">
!    The position of the region to be masked out. mask_list(1,:) is the x-layout position
!    and mask_list(2,:) is y-layout position.  
!  </DATA>
!  <DATA NAME="layout_mask" TYPE="integer, dimension(2)">
!   Processor domain layout for all the component model. layout_mask need to be set when and only 
!   when n_mask is greater than 0 ( some domain region is masked out ). When this namelist is set,
!   it will overload the layout in each component model. The default value is (0,0).
!   Currently we require all the component model has the same layout and same grid size.
!  </DATA>
!  <DATA NAME="restart_interval" TYPE="integer, dimension(6)"  DEFAULT="0">
!     The time interval that write out intermediate restart file. The format is (yr,mo,day,hr,min,sec).
!     When restart_interval is all zero, no intermediate restart file will be written out.
!   </DATA>
!   <NOTE>
!     <PRE>
!     1.If no value is set for current_date, start_date, or calendar (or default value specified) then the value from restart
!       file "INPUT/coupler.res" will be used. If neither a namelist value or restart file value exist the program will fail. 
!     2.The actual run length will be the sum of months, days, hours, minutes, and seconds. A run length of zero is not a
!       valid option. 
!     3.The run length must be an intergal multiple of the coupling timestep dt_cpld. 
!     </PRE>
!   </NOTE>
! </NAMELIST>

  integer, dimension(6) :: restart_interval = (/ 0, 0, 0, 0, 0, 0/)
  integer, dimension(6) :: current_date     = (/ 0, 0, 0, 0, 0, 0 /)
  character(len=17) :: calendar = '                 '
  logical :: force_date_from_namelist = .false.  ! override restart values for date
  integer :: months=0, days=0, hours=0, minutes=0, seconds=0
  integer :: dt_atmos = 0  ! fluxes passed between atmosphere & ice/land
  integer :: dt_cpld  = 0  ! fluxes passed between ice & ocean


  integer ::atmos_npes=0, ocean_npes=0, ice_npes=0, land_npes=0
  logical :: do_atmos =.true., do_land =.true., do_ice =.true., do_ocean=.true.
  logical :: do_flux =.true.
  logical :: concurrent=.FALSE.
  logical :: use_lag_fluxes=.TRUE.
  logical :: do_chksum=.FALSE.
  integer :: layout_mask(2) = (/0 , 0/)
  integer :: n_mask = 0
  integer :: mask_list(2, MAXPES), n, m 
  integer :: check_stocks = 0 ! -1: never 0: at end of run only n>0: every n coupled steps
  integer, parameter :: mp = 2*MAXPES
  data ((mask_list(n,m),n=1, 2),m=1,MAXPES) /mp*0/

  namelist /coupler_nml/ current_date, calendar, force_date_from_namelist, months, days, hours,      &
                         minutes, seconds, dt_cpld, dt_atmos, do_atmos,              &
                         do_land, do_ice, do_ocean, do_flux, atmos_npes, ocean_npes, &
                         ice_npes, land_npes, concurrent, use_lag_fluxes, do_chksum, &
                         n_mask, layout_mask, mask_list, check_stocks, restart_interval

  integer :: initClock, mainClock, termClock

  integer :: newClock0, newClock1, newClock2, newClock3, newClock4, newClock5, newClock6, newClock7, &
             newClock8, newClock9, newClock10, newClock11, newClock12, newClock13, newClock14, newClocka, &
             newClockb, newClockc, newClockd, newClocke, newClockf, newClockg, newClockh

  character(len=80) :: text
  character(len=48), parameter                    :: mod_name = 'coupler_main_mod'
 
  integer :: ensemble_id = 1 , outunit
  integer, allocatable :: ensemble_pelist(:, :) 

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'coupler_main'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!#######################################################################

  call mpp_init()
!these clocks are on the global pelist
  initClock = mpp_clock_id( 'Initialization' )
  mainClock = mpp_clock_id( 'Main loop' )
  termClock = mpp_clock_id( 'Termination' )
  call mpp_clock_begin(initClock)
  
  call fms_init
  call constants_init

  call coupler_init
  if(do_chksum) call coupler_chksum('coupler_init+', 0)

  call mpp_set_current_pelist()

  call mpp_clock_end (initClock) !end initialization

  call mpp_clock_begin(mainClock) !begin main loop

!-----------------------------------------------------------------------
!------ ocean/slow-ice integration loop ------

     if(check_stocks >= 0) then
        call mpp_set_current_pelist()
        call flux_init_stocks(Time, Atm, Land, Ice, Ocean_state)
     endif

if( Atm%pe )then
 call mpp_set_current_pelist(Atm%pelist)
 newClock1 = mpp_clock_id( 'generate_sfc_xgrid' )
endif
call mpp_set_current_pelist()
newClock2 = mpp_clock_id( 'flux_ocean_to_ice' )
newClock3 = mpp_clock_id( 'flux_ice_to_ocean' )
newClock4 = mpp_clock_id( 'flux_check_stocks' ) 
if( Atm%pe )then
 call mpp_set_current_pelist(Atm%pelist)
 newClock5 = mpp_clock_id( 'ATM' )
 newClock6  = mpp_clock_id( '  ATM: update_ice_model_slow_up' )
 newClock7  = mpp_clock_id( '  ATM: atmos loop' )
 newClocka  = mpp_clock_id( '     A-L: atmos_tracer_driver_gather_data' )
 newClockb  = mpp_clock_id( '     A-L: sfc_boundary_layer' )
 newClockc  = mpp_clock_id( '     A-L: udpate_atmos_model_down' )
 newClockd  = mpp_clock_id( '     A-L: flux_down_from_atmos' )
 newClocke  = mpp_clock_id( '     A-L: update_land_model_fast' )
 newClockf  = mpp_clock_id( '     A-L: update_ice_model_fast' )
 newClockg  = mpp_clock_id( '     A-L: flux_up_to_atmos' )
 newClockh  = mpp_clock_id( '     A-L: update_atmos_model_up' )
 newClock8  = mpp_clock_id( '  ATM: update_land_model_slow' )
 newClock9  = mpp_clock_id( '  ATM: flux_land_to_ice' )
 newClock10 = mpp_clock_id( '  ATM: update_ice_model_slow_dn' )
 newClock11 = mpp_clock_id( '  ATM: flux_ice_to_ocean_stocks' )
endif
if( Ocean%is_ocean_pe )then
 call mpp_set_current_pelist(Ocean%pelist)
 newClock12 = mpp_clock_id( 'OCN' )
endif
call mpp_set_current_pelist()
newClock13 = mpp_clock_id( 'intermediate restart' )
newClock14 = mpp_clock_id( 'final flux_check_stocks' )

  do nc = 1, num_cpld_calls
     if(do_chksum) call coupler_chksum('top_of_coupled_loop+', nc)
     if( Atm%pe )then
        call mpp_set_current_pelist(Atm%pelist)
call mpp_clock_begin(newClock1)
        call generate_sfc_xgrid( Land, Ice )
call mpp_clock_end(newClock1)
     end if
     call mpp_set_current_pelist()
     if(do_chksum) then
       if (Atm%pe) then 
         call mpp_set_current_pelist(Atm%pelist)
         call atmos_ice_land_chksum('MAIN_LOOP-', nc)
       endif
       if (Ocean%is_ocean_pe) then 
         call mpp_set_current_pelist(Ocean%pelist)
         call ocean_chksum('MAIN_LOOP-', nc)
       endif
       call mpp_set_current_pelist()
     endif  

     ! Calls to flux_ocean_to_ice and flux_ice_to_ocean are all PE communication
     ! points when running concurrently. The calls are placed next to each other in
     ! concurrent mode to avoid multiple synchronizations within the main loop.
     ! This is only possible in the serial case when use_lag_fluxes.
call mpp_clock_begin(newClock2)
     call flux_ocean_to_ice( Time, Ocean, Ice, Ocean_ice_boundary )
call mpp_clock_end(newClock2)
     if(do_chksum) then
       call coupler_chksum('flux_ocn2ice+', nc)
       if (Atm%pe) then 
         call mpp_set_current_pelist(Atm%pelist)
         call atmos_ice_land_chksum('fluxocn2ice+', nc)
       endif
       if (Ocean%is_ocean_pe) then 
         call mpp_set_current_pelist(Ocean%pelist)
         call ocean_public_type_chksum('fluxocn2ice+', nc, Ocean)
       endif
       call mpp_set_current_pelist()
     endif

call mpp_clock_begin(newClock3)
     ! Update Ice_ocean_boundary; first iteration is supplied by restart     
     if( use_lag_fluxes )then
        call flux_ice_to_ocean( Time, Ice, Ocean, Ice_ocean_boundary )
     end if
call mpp_clock_end(newClock3)

call mpp_clock_begin(newClock4)
     ! Update Ice_ocean_boundary; first iteration is supplied by restart     
     ! To print the value of frazil heat flux at the right time the following block
     ! needs to sit here rather than at the end of the coupler loop.
     if(check_stocks > 0) then
        if(check_stocks*((nc-1)/check_stocks) == nc-1 .AND. nc > 1) then
           call mpp_set_current_pelist()
           call flux_check_stocks(Time=Time, Atm=Atm, Lnd=Land, Ice=Ice, Ocn_state=Ocean_state)
        endif
     endif
call mpp_clock_end(newClock4)

     if( Atm%pe )then
        call mpp_set_current_pelist(Atm%pelist)
call mpp_clock_begin(newClock5)
call mpp_clock_begin(newClock6)
        if (do_ice) call update_ice_model_slow_up( Ocean_ice_boundary, Ice )
call mpp_clock_end(newClock6)
        if(do_chksum) call atmos_ice_land_chksum('update_ice_slow_up+', nc)

        !-----------------------------------------------------------------------
        !   ------ atmos/fast-land/fast-ice integration loop -------

call mpp_clock_begin(newClock7)
        do na = 1, num_atmos_calls
           if(do_chksum) call atmos_ice_land_chksum('top_of_atmos_loop-', (nc-1)*num_atmos_calls+na)

           Time_atmos = Time_atmos + Time_step_atmos

call mpp_clock_begin(newClocka)
           if (do_atmos) then
              call atmos_tracer_driver_gather_data(Atm%fields, Atm%tr_bot)
           endif
call mpp_clock_end(newClocka)

call mpp_clock_begin(newClockb)
           if (do_flux) then
              call sfc_boundary_layer( REAL(dt_atmos), Time_atmos, &
                   Atm, Land, Ice, Land_ice_atmos_boundary )
              if(do_chksum)  call atmos_ice_land_chksum('sfc+', (nc-1)*num_atmos_calls+na)
           end if
call mpp_clock_end(newClockb)

           !      ---- atmosphere down ----

call mpp_clock_begin(newClockc)
           if (do_atmos) &
                call update_atmos_model_down( Land_ice_atmos_boundary, Atm )
call mpp_clock_end(newClockc)
           if(do_chksum) call atmos_ice_land_chksum('update_atmos_down+', (nc-1)*num_atmos_calls+na)

call mpp_clock_begin(newClockd)
           call flux_down_from_atmos( Time_atmos, Atm, Land, Ice, &
                Land_ice_atmos_boundary, &
                Atmos_land_boundary, &
                Atmos_ice_boundary )
call mpp_clock_end(newClockd)
           if(do_chksum) call atmos_ice_land_chksum('flux_down_from_atmos+', (nc-1)*num_atmos_calls+na)

           !      --------------------------------------------------------------

           !      ---- land model ----

call mpp_clock_begin(newClocke)
           if (do_land) &
                call update_land_model_fast( Atmos_land_boundary, Land )
call mpp_clock_end(newClocke)
           if(do_chksum) call atmos_ice_land_chksum('update_land_fast+', (nc-1)*num_atmos_calls+na)

           !      ---- ice model ----
call mpp_clock_begin(newClockf)
           if (do_ice) &
                call update_ice_model_fast( Atmos_ice_boundary, Ice )
call mpp_clock_end(newClockf)
           if(do_chksum) call atmos_ice_land_chksum('update_ice_fast+', (nc-1)*num_atmos_calls+na)

           !      --------------------------------------------------------------
           !      ---- atmosphere up ----

call mpp_clock_begin(newClockg)
           call flux_up_to_atmos( Time_atmos, Land, Ice, Land_ice_atmos_boundary, &
                & Atmos_land_boundary, Atmos_ice_boundary )
call mpp_clock_end(newClockg)
           if(do_chksum) call atmos_ice_land_chksum('flux_up2atmos+', (nc-1)*num_atmos_calls+na)

call mpp_clock_begin(newClockh)
           if (do_atmos) &
                call update_atmos_model_up( Land_ice_atmos_boundary, Atm )
call mpp_clock_end(newClockh)
           if(do_chksum) call atmos_ice_land_chksum('update_atmos_up+', (nc-1)*num_atmos_calls+na)

           !--------------

        enddo
call mpp_clock_end(newClock7)

call mpp_clock_begin(newClock8)
        !   ------ end of atmospheric time step loop -----
        if (do_land) call update_land_model_slow(Atmos_land_boundary,Land)
        !-----------------------------------------------------------------------
call mpp_clock_end(newClock8)
        if(do_chksum) call atmos_ice_land_chksum('update_land_slow+', nc)

        !
        !     need flux call to put runoff and p_surf on ice grid
        !
call mpp_clock_begin(newClock9)
        call flux_land_to_ice( Time, Land, Ice, Land_ice_boundary )
call mpp_clock_end(newClock9)
        if(do_chksum) call atmos_ice_land_chksum('fluxlnd2ice+', nc)

        Atmos_ice_boundary%p = 0.0 ! call flux_atmos_to_ice_slow ?

        !   ------ slow-ice model ------

        if (do_ice) then 
call mpp_clock_begin(newClock10)
           call update_ice_model_slow_dn( Atmos_ice_boundary, &
                & Land_ice_boundary, Ice )
call mpp_clock_end(newClock10)
           if(do_chksum) call atmos_ice_land_chksum('update_ice_slow_dn+', nc)

call mpp_clock_begin(newClock11)
           call flux_ice_to_ocean_stocks(Ice)
call mpp_clock_end(newClock11)
           if(do_chksum) call atmos_ice_land_chksum('fluxice2ocn_stocks+', nc)
        endif
        Time = Time_atmos
call mpp_clock_end(newClock5)
     end if                     !Atm%pe block

     if( .NOT.use_lag_fluxes )then !this will serialize
        call mpp_set_current_pelist()
        call flux_ice_to_ocean( Time, Ice, Ocean, Ice_ocean_boundary )
     end if

     if( Ocean%is_ocean_pe )then
        call mpp_set_current_pelist(Ocean%pelist)
call mpp_clock_begin(newClock12)

        if (do_chksum) call ocean_chksum('update_ocean_model-', nc)
        ! update_ocean_model since fluxes don't change here

        if (do_ocean) &
          call update_ocean_model( Ice_ocean_boundary, Ocean_state,  Ocean, &
                                   Time_ocean, Time_step_cpld )

        if (do_chksum) call ocean_chksum('update_ocean_model+', nc)
        ! Get stocks from "Ice_ocean_boundary" and add them to Ocean stocks.
        ! This call is just for record keeping of stocks transfer and
        ! does not modify either Ocean or Ice_ocean_boundary
        call flux_ocean_from_ice_stocks(Ocean_state, Ocean, Ice_ocean_boundary)

        Time_ocean = Time_ocean +  Time_step_cpld

        !-----------------------------------------------------------------------
        Time = Time_ocean

call mpp_clock_end(newClock12)
     end if

!rabcall mpp_clock_begin(newClock13)
     !--- write out intermediate restart file when needed.
     if( Time >= Time_restart ) then
        Time_restart_current = Time
        Time_restart = increment_date(Time, restart_interval(1), restart_interval(2), &
             restart_interval(3), restart_interval(4), restart_interval(5), restart_interval(6) )
        timestamp = date_to_string(time_restart_current)
        outunit= stdout()
        write(outunit,*) '=> NOTE from program coupler: intermediate restart file is written and ', &
             trim(timestamp),' is appended as prefix to each restart file name'
        if( Atm%pe )then        
           call atmos_model_restart(Atm, timestamp)
           call land_model_restart(timestamp)
           call ice_model_restart(timestamp)
        endif
        if( Ocean%is_ocean_pe) then
           call ocean_model_restart(Ocean_state, timestamp)
        endif
        call coupler_restart(Time, Time_restart_current, timestamp)
     end if

     !--------------
     if(do_chksum) call coupler_chksum('MAIN_LOOP+', nc)
     write( text,'(a,i4)' )'Main loop at coupling timestep=', nc
     call print_memuse_stats(text)
!rabcall mpp_clock_end(newClock13)


  enddo

     call mpp_set_current_pelist()
call mpp_clock_begin(newClock14)
  if(check_stocks >= 0) then
     call mpp_set_current_pelist()
     call flux_check_stocks(Time=Time, Atm=Atm, Lnd=Land, Ice=Ice, Ocn_state=Ocean_state)
  endif
call mpp_clock_end(newClock14)

! Need final update of Ice_ocean_boundary for concurrent restart
!  if( concurrent )then
!      call mpp_set_current_pelist()
!      call flux_ice_to_ocean( Time, Ice, Ocean, Ice_ocean_boundary )
!  endif

  call mpp_set_current_pelist()
!-----------------------------------------------------------------------
  call mpp_clock_end(mainClock)
  call mpp_clock_begin(termClock)

  if(do_chksum) call coupler_chksum('coupler_end-', nc)
  call coupler_end

  call mpp_clock_end(termClock)

  call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. )
  call fms_end

!-----------------------------------------------------------------------

contains

!#######################################################################

  subroutine coupler_init

    use ensemble_manager_mod, only : ensemble_manager_init, get_ensemble_id,ensemble_pelist_setup
    use ensemble_manager_mod, only : get_ensemble_size, get_ensemble_pelist

!-----------------------------------------------------------------------
!   initialize all defined exchange grids and all boundary maps
!-----------------------------------------------------------------------
 
!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

    character(len=64), parameter    :: sub_name = 'coupler_init'
    character(len=256), parameter   :: error_header =                               &
         '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
    character(len=256), parameter   :: warn_header =                                &
         '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
    character(len=256), parameter   :: note_header =                                &
         '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

    integer :: unit,  ierr, io,    m, i, outunit, logunit
    integer :: date(6)
    type (time_type) :: Run_length
    character(len=9) :: month
    integer :: pe, npes

    integer :: ens_siz(4), ensemble_size

    integer :: atmos_pe_start=0, atmos_pe_end=0, &
               ocean_pe_start=0, ocean_pe_end=0
    integer :: n
    integer :: diag_model_subset=DIAG_ALL
    logical :: other_fields_exist
    logical, allocatable :: maskmap(:,:)
    character(len=256) :: err_msg
    integer :: date_restart(6)
    character(len=64)  :: filename, fieldname
    integer :: id_restart, l
!-----------------------------------------------------------------------

!----- write version to logfile -------
    call write_version_number(version, tag)

!----- read namelist -------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, coupler_nml, iostat=io)
#else
    unit = open_namelist_file()
    ierr=1; do while (ierr /= 0)
       read  (unit, nml=coupler_nml, iostat=io, end=10)
       ierr = check_nml_error (io, 'coupler_nml')
    enddo
10  call mpp_close(unit)
#endif

    outunit = stdout()
    logunit = stdlog()
    
!---- when concurrent is set true and mpp_io_nml io_clock_on is set true, the model
!---- will crash with error message "MPP_CLOCK_BEGIN: cannot change pelist context of a clock",
!---- so need to make sure it will not happen
    if(concurrent) then
       if(mpp_io_clock_on()) then
          call error_mesg ('program coupler', 'when coupler_nml variable concurrent is set to true, '// &
              'mpp_io_nml variable io_clock_non can not be set to true.', FATAL )
       endif
    endif
!----- read date and calendar type from restart file -----

    if( file_exist('INPUT/coupler.res') )then
!Balaji: currently written in binary, needs form=MPP_NATIVE
        call mpp_open( unit, 'INPUT/coupler.res', action=MPP_RDONLY )
        read( unit,*,err=999 )calendar_type
        read( unit,* )date_init
        read( unit,* )date
        goto 998 !back to fortran-4
!read old-style coupler.res
999     call mpp_close(unit)
        call mpp_open( unit, 'INPUT/coupler.res', action=MPP_RDONLY, form=MPP_NATIVE )
        read(unit)calendar_type
        read(unit)date
998     call mpp_close(unit)
    else
        force_date_from_namelist = .true.
    endif

!----- use namelist value (either no restart or override flag on) ---

    if ( force_date_from_namelist ) then

        if ( sum(current_date) <= 0 ) then
            call error_mesg ('program coupler',  &
                 'no namelist value for base_date or current_date', FATAL)
        else
            date      = current_date
        endif

!----- override calendar type with namelist value -----

        select case( uppercase(trim(calendar)) )
        case( 'JULIAN' )
            calendar_type = JULIAN
        case( 'NOLEAP' )
            calendar_type = NOLEAP
        case( 'THIRTY_DAY' )
            calendar_type = THIRTY_DAY_MONTHS
        case( 'NO_CALENDAR' )
            calendar_type = NO_CALENDAR
        end select

    endif

    call set_calendar_type (calendar_type, err_msg)
    if(err_msg /= '') then
      call mpp_error(FATAL, 'ERROR in coupler_init: '//trim(err_msg))
    endif

    if( concurrent .AND. .NOT.use_lag_fluxes )call mpp_error( WARNING, &
            'coupler_init: you have set concurrent=TRUE and use_lag_fluxes=FALSE &
            & in coupler_nml. When not using lag fluxes, components &
            & will synchronize at two points, and thus run serially.' )


    !Check with the ensemble_manager module for the size of ensemble
    !and PE counts for each member of the ensemble.
    !
    !NOTE: ensemble_manager_init renames all the output files (restart and diagnostics)
    !      to show which ensemble member they are coming from.
    !      There also need to be restart files for each member of the ensemble in INPUT.
    !
    !NOTE: if the ensemble_size=1 the input/output files will not be renamed.
    !
    
    call ensemble_manager_init() ! init pelists for ensembles
    ens_siz = get_ensemble_size()   
    ensemble_size = ens_siz(1)      
    npes = ens_siz(2)              

    !Check for the consistency of PE counts
    if( concurrent )then
!atmos_npes + ocean_npes must equal npes
        if( atmos_npes.EQ.0 )atmos_npes = npes - ocean_npes
        if( ocean_npes.EQ.0 )ocean_npes = npes - atmos_npes
!both must now be non-zero
        if( atmos_npes.EQ.0 .OR. ocean_npes.EQ.0 ) &
             call mpp_error( FATAL, 'coupler_init: atmos_npes or ocean_npes must be specified for concurrent coupling.' )
        if( atmos_npes+ocean_npes.NE.npes ) &
             call mpp_error( FATAL, 'coupler_init: atmos_npes+ocean_npes must equal npes for concurrent coupling.' )
    else                        !serial timestepping
        if( atmos_npes.EQ.0 )atmos_npes = npes
        if( ocean_npes.EQ.0 )ocean_npes = npes
        if( max(atmos_npes,ocean_npes).EQ.npes )then !overlapping pelists
            ! do nothing
        else                    !disjoint pelists
            if( atmos_npes+ocean_npes.NE.npes ) call mpp_error( FATAL,  &
                 'coupler_init: atmos_npes+ocean_npes must equal npes for serial coupling on disjoint pelists.' )
        end if
    end if    

    allocate( Atm%pelist  (atmos_npes) )
    allocate( Ocean%pelist(ocean_npes) )

    !Set up and declare all the needed pelists
    call ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, Atm%pelist, Ocean%pelist)
    ensemble_id = get_ensemble_id() 
 
    allocate(ensemble_pelist(1:ensemble_size,1:npes))   
    call get_ensemble_pelist(ensemble_pelist) 

    Atm%pe            = ANY(Atm%pelist   .EQ. mpp_pe()) 
    Ocean%is_ocean_pe = ANY(Ocean%pelist .EQ. mpp_pe())  
    Ice%pe  = Atm%pe
    Land%pe = Atm%pe
 
    !Why is the following needed?
    if( Atm%pe )            call mpp_set_current_pelist( Atm%pelist   )
    if( Ocean%is_ocean_pe ) call mpp_set_current_pelist( Ocean%pelist )
    
    !Write out messages on root PEs
    if(mpp_pe().EQ.mpp_root_pe() )then
       write( text,'(a,2i6,a,i2.2)' )'Atmos PE range: ', Atm%pelist(1)  , Atm%pelist(atmos_npes)  ,&
            ' ens_', ensemble_id
       call mpp_error( NOTE, 'coupler_init: '//trim(text) )
       write( text,'(a,2i6,a,i2.2)' )'Ocean PE range: ', Ocean%pelist(1), Ocean%pelist(ocean_npes), &
            ' ens_', ensemble_id
       call mpp_error( NOTE, 'coupler_init: '//trim(text) )
       if( concurrent )then
          call mpp_error( NOTE, 'coupler_init: Running with CONCURRENT coupling.' )

          write( logunit,'(a)' )'Using concurrent coupling...'
          write( logunit,'(a,4i4)' ) &
               'atmos_pe_start, atmos_pe_end, ocean_pe_start, ocean_pe_end=', &
               Atm%pelist(1)  , Atm%pelist(atmos_npes), Ocean%pelist(1), Ocean%pelist(ocean_npes) 
       else
          call mpp_error( NOTE, 'coupler_init: Running with SERIAL coupling.' )
       end if
       if( use_lag_fluxes )then
          call mpp_error( NOTE, 'coupler_init: Sending LAG fluxes to ocean.' )
       else
          call mpp_error( NOTE, 'coupler_init: Sending most recent fluxes to ocean.' )
       end if
    endif

    if( ice_npes.NE.0 ) &
         call mpp_error( WARNING, 'coupler_init: pelists not yet implemented for ice.' )
    if( land_npes.NE.0 ) &
         call mpp_error( WARNING, 'coupler_init: pelists not yet implemented for land.' )

!----- write namelist to logfile -----
    if( mpp_pe() == mpp_root_pe() )write( logunit, nml=coupler_nml )

!----- write current/initial date actually used to logfile file -----

    if ( mpp_pe().EQ.mpp_root_pe() ) &
         write( logunit, 16 )date(1),trim(month_name(date(2))),date(3:6)
16  format ('  current date used = ',i4,1x,a,2i3,2(':',i2.2),' gmt') 

!----- check the value of layout and setup the maskmap for domain layout.
    if( n_mask > 0 ) then
       if(do_atmos .OR. do_land) call mpp_error(FATAL, &
            'program coupler: do_atmos and do_land should be false when n_mask > 0')

       if(concurrent) call mpp_error(FATAL, &
            'program coupler: can not run concurrent run when some regions are masked out')
       if( layout_mask(1)*layout_mask(2) - n_mask .NE. npes ) call mpp_error(FATAL, &
            'program coupler: layout(1)*layout(2) - n_mask should equal to npes when n_mask>0')
       call mpp_error(NOTE, 'program coupler: layout_mask and mask_list is set in coupler_nml, ' // &
                            'the value of layout_mask will override the layout specified in each component model')

       allocate(maskmap(layout_mask(1), layout_mask(2)) )
       maskmap = .TRUE.
       do n=1, n_mask
          if (mask_list(1,n) .gt. layout_mask(1) ) &
             call mpp_error( FATAL, 'program coupler: mask_list elements outside layout defines.' )
          if (mask_list(2,n) .gt. layout_mask(2) ) &
             call mpp_error( FATAL, 'program coupler: mask_list elements outside layout defines.' )
          maskmap(mask_list(1,n),mask_list(2,n)) = .false.
       enddo
       !--- copy maskmap value to each model data type
       allocate(Atm%maskmap(layout_mask(1), layout_mask(2)), Land%maskmap(layout_mask(1), layout_mask(2)) )
       allocate(Ice%maskmap(layout_mask(1), layout_mask(2)), Ocean%maskmap(layout_mask(1), layout_mask(2)))
       Atm%maskmap = maskmap;  Land%maskmap = maskmap
       Ice%maskmap = maskmap;  Ocean%maskmap = maskmap
       deallocate(maskmap)
    else
       if( layout_mask(1)*layout_mask(2) .NE. 0 ) call mpp_error(NOTE, &
            'program coupler: when no region is masked out, layout_mask need not be set' )
    end if

!-----------------------------------------------------------------------
!------ initialize diagnostics manager ------

!jwd Fork here is somewhat dangerous. It relies on "no side effects" from
!    diag_manager_init. diag_manager_init or this section should be 
!    re-architected to guarantee this or remove this assumption.
!    For instance, what follows assumes that get_base_date has the same
!    time for both Atm and Ocean pes. While this should be the case, the
!    possible error condition needs to be checked

    if( Atm%pe )then
        call mpp_set_current_pelist(Atm%pelist)
        if(atmos_npes /= npes)diag_model_subset = DIAG_OTHER  ! change diag_model_subset from DIAG_ALL
    elseif( Ocean%is_ocean_pe )then  ! Error check above for disjoint pelists should catch any problem
        call mpp_set_current_pelist(Ocean%pelist)
        if(ocean_npes /= npes)diag_model_subset = DIAG_OCEAN  ! change diag_model_subset from DIAG_ALL
    end if
    call diag_manager_init(DIAG_MODEL_SUBSET=diag_model_subset)   ! initialize diag_manager for processor subset output
    call print_memuse_stats( 'diag_manager_init' )
!-----------------------------------------------------------------------
!------ reset pelist to "full group" ------

    call mpp_set_current_pelist()
!----- always override initial/base date with diag_manager value -----

    call get_base_date ( date_init(1), date_init(2), date_init(3), &
         date_init(4), date_init(5), date_init(6)  )

!----- use current date if no base date ------

    if ( date_init(1) == 0 ) date_init = date

!----- set initial and current time types ------

    Time_init = set_date (date_init(1), date_init(2), date_init(3), &
         date_init(4), date_init(5), date_init(6))

    Time      = set_date (date(1), date(2), date(3),  &
         date(4), date(5), date(6))

    Time_start = Time

!----- compute the ending time -----

    Time_end = Time
    do m=1,months
       Time_end = Time_end + set_time(0,days_in_month(Time_end))
    end do
    Time_end   = Time_end + set_time(hours*3600+minutes*60+seconds, days)
    !Need to pass Time_end into diag_manager for multiple thread case.
    call diag_manager_set_time_end(Time_end)

    Run_length = Time_end - Time

!--- get the time that last intermediate restart file was written out.
    if (file_exist('INPUT/coupler.intermediate.res')) then
       call mpp_open(unit,'INPUT/coupler.intermediate.res',action=MPP_RDONLY)
       read(unit,*) date_restart
       call mpp_close(unit)
    else
       date_restart = date
    endif

    Time_restart_current = Time
    if(ALL(restart_interval ==0)) then
       Time_restart = increment_date(Time_end, 1, 0, 0, 0, 0, 0)   ! no intermediate restart
    else
       Time_restart = set_date(date_restart(1), date_restart(2), date_restart(3),  &
                               date_restart(4), date_restart(5), date_restart(6) )
       Time_restart = increment_date(Time_restart, restart_interval(1), restart_interval(2), &
            restart_interval(3), restart_interval(4), restart_interval(5), restart_interval(6) )
       if(Time_restart <= Time) call mpp_error(FATAL, &
            '==>Error from program coupler: The first intermediate restart time is no larger than the start time')
    end if

!-----------------------------------------------------------------------
!----- write time stamps (for start time and end time) ------

    call mpp_open( unit, 'time_stamp.out', nohdrs=.TRUE. )

    month = month_name(date(2))
    if ( mpp_pe().EQ.mpp_root_pe() ) write (unit,20) date, month(1:3)

    call get_date (Time_end, date(1), date(2), date(3),  &
         date(4), date(5), date(6))
    month = month_name(date(2))
    if ( mpp_pe().EQ.mpp_root_pe() ) write (unit,20) date, month(1:3)

    call mpp_close(unit)

20  format (6i4,2x,a3)

!-----------------------------------------------------------------------
!----- compute the time steps ------

    Time_step_cpld  = set_time (dt_cpld ,0)
    Time_step_atmos = set_time (dt_atmos,0)

!----- determine maximum number of iterations per loop ------

    num_cpld_calls  = Run_length      / Time_step_cpld
    num_atmos_calls = Time_step_cpld  / Time_step_atmos

!-----------------------------------------------------------------------
!------------------- some error checks ---------------------------------

!----- initial time cannot be greater than current time -------

    if ( Time_init > Time ) call error_mesg ('program coupler',  &
         'initial time is greater than current time', FATAL)

!----- make sure run length is a multiple of ocean time step ------

    if ( num_cpld_calls * Time_step_cpld  /= Run_length )  &
         call error_mesg ('program coupler',  &
         'run length must be multiple of coupled time step', FATAL)

! ---- make sure cpld time step is a multiple of atmos time step ----

    if ( num_atmos_calls * Time_step_atmos /= Time_step_cpld )  &
         call error_mesg ('program coupler',   &
         'cpld time step is not a multiple of the atmos time step', FATAL)

!
!       Initialize the tracer manager. This needs to be done on all PEs,
!       before the individual models are initialized.
!

    call tracer_manager_init
!
!       Initialize the coupler types
!

    call coupler_types_init

!-----------------------------------------------------------------------
!------ initialize component models ------
!------ grid info now comes from grid_spec file

    if( Atm%pe )then
        call mpp_set_current_pelist(Atm%pelist)
!---- atmosphere ----
        call atmos_model_init( Atm, Time_init, Time, Time_step_atmos )
        call print_memuse_stats( 'atmos_model_init' )

!---- land ----------
        call land_model_init( Atmos_land_boundary, Land, Time_init, Time, &
             Time_step_atmos, Time_step_cpld )
        call print_memuse_stats( 'land_model_init' )

!---- ice -----------
        call ice_model_init( Ice, Time_init, Time, Time_step_atmos, Time_step_cpld )
        call print_memuse_stats( 'ice_model_init' )
        call data_override_init(Atm_domain_in = Atm%domain, Ice_domain_in = Ice%domain, Land_domain_in=Land%domain)
    end if
    if( Ocean%is_ocean_pe )then
        call mpp_set_current_pelist(Ocean%pelist)
!---- ocean ---------
        call ocean_model_init( Ocean, Ocean_state, Time_init, Time )
        call print_memuse_stats( 'ocean_model_init' )
        call data_override_init(Ocean_domain_in = Ocean%domain )
    end if
    call mpp_set_current_pelist(ensemble_pelist(ensemble_id,:))

    call mpp_broadcast_domain(Ice%domain)
    call mpp_broadcast_domain(Ocean%domain)
!-----------------------------------------------------------------------
!---- initialize flux exchange module ----
    call flux_exchange_init ( Time, Atm, Land, Ice, Ocean, Ocean_state,&
         atmos_ice_boundary, land_ice_atmos_boundary, &
         land_ice_boundary, ice_ocean_boundary, ocean_ice_boundary, &
         dt_atmos=dt_atmos, dt_cpld=dt_cpld)

    Time_atmos = Time
    Time_ocean = Time

!
!       read in extra fields for the air-sea gas fluxes
!

    if ( Atm%pe ) then
      call mpp_set_current_pelist(Atm%pelist)
      allocate(Ice_bc_restart(Ice%ocean_fluxes%num_bcs))
      allocate(ice_bc_restart_file(Ice%ocean_fluxes%num_bcs))
      do n = 1, Ice%ocean_fluxes%num_bcs  !{
        if(Ice%ocean_fluxes%bc(n)%num_fields .LE. 0) cycle
        filename = trim(Ice%ocean_fluxes%bc(n)%ice_restart_file)
        do l = 1, num_ice_bc_restart
           if(trim(filename) == ice_bc_restart_file(l)) exit
        end do
        if(l>num_ice_bc_restart) then
           num_ice_bc_restart = num_ice_bc_restart + 1
           ice_bc_restart_file(l) = trim(filename)
        end if
        filename = 'INPUT/'//trim(filename)
        other_fields_exist = .false.
        do m = 1, Ice%ocean_fluxes%bc(n)%num_fields  !{
          fieldname = trim(Ice%ocean_fluxes%bc(n)%field(m)%name)
          id_restart = register_restart_field(Ice_bc_restart(l), ice_bc_restart_file(l), &
                       fieldname, Ice%ocean_fluxes%bc(n)%field(m)%values, Ice%domain    )
          if (field_exist(filename, fieldname, Ice%domain) ) then
            other_fields_exist = .true.
            write (outunit,*) trim(note_header), ' Reading restart info for ',         &
                 trim(fieldname), ' from ',  trim(filename)
            call read_data(filename, fieldname, Ice%ocean_fluxes%bc(n)%field(m)%values, Ice%domain)
          elseif (other_fields_exist) then
            call mpp_error(FATAL, trim(error_header) // ' Couldn''t find field ' //     &
                 trim(fieldname) // ' in file ' //trim(filename))
          endif
        enddo  !} m
      enddo  !} n
    endif
    if ( Ocean%is_ocean_pe ) then
      call mpp_set_current_pelist(Ocean%pelist)
      allocate(Ocn_bc_restart(Ocean%fields%num_bcs))
      allocate(ocn_bc_restart_file(Ocean%fields%num_bcs))
      do n = 1, Ocean%fields%num_bcs  !{
        if(Ocean%fields%bc(n)%num_fields .LE. 0) cycle
        filename = trim(Ocean%fields%bc(n)%ocean_restart_file)
        do l = 1, num_ocn_bc_restart
           if(trim(filename) == ocn_bc_restart_file(l)) exit
        end do
        if(l>num_ocn_bc_restart) then
           num_ocn_bc_restart = num_ocn_bc_restart + 1
           ocn_bc_restart_file(l) = trim(filename)
        end if
        filename = 'INPUT/'//trim(filename)
        other_fields_exist = .false.
        do m = 1, Ocean%fields%bc(n)%num_fields  !{
          fieldname = trim(Ocean%fields%bc(n)%field(m)%name)
          id_restart = register_restart_field(Ocn_bc_restart(l), Ocn_bc_restart_file(l), &
                       fieldname, Ocean%fields%bc(n)%field(m)%values, Ocean%domain    )
          if (field_exist(filename, fieldname, Ocean%domain) ) then
            other_fields_exist = .true.
            write (outunit,*) trim(note_header), ' Reading restart info for ',         &
                 trim(fieldname), ' from ', trim(filename)
            call read_data(filename, fieldname, Ocean%fields%bc(n)%field(m)%values, Ocean%domain)
          elseif (other_fields_exist) then
            call mpp_error(FATAL, trim(error_header) // ' Couldn''t find field ' //     &
                 trim(fieldname) // ' in file ' //trim(filename))
          endif
        enddo  !} m
      enddo  !} n
    endif

    call mpp_set_current_pelist()

!-----------------------------------------------------------------------
!---- open and close dummy file in restart dir to check if dir exists --

    call mpp_open( unit, 'RESTART/file' )
    call mpp_close(unit, MPP_DELETE)

    ! Call to daig_grid_end to free up memory used during regional
    ! output setup
    CALL diag_grid_end()

!-----------------------------------------------------------------------
    if(do_chksum) then
      if (Atm%pe) then 
        call mpp_set_current_pelist(Atm%pelist)
        call atmos_ice_land_chksum('coupler_init+', 0)
      endif
      if (Ocean%is_ocean_pe) then 
        call mpp_set_current_pelist(Ocean%pelist)
        call ocean_chksum('coupler_init+', nc)
      endif
      call mpp_set_current_pelist()
    endif  
    call print_memuse_stats('coupler_init')
  end subroutine coupler_init

!#######################################################################

  subroutine coupler_end

!-----------------------------------------------------------------------

    call mpp_set_current_pelist()

!----- check time versus expected ending time ----

    if (Time /= Time_end) call error_mesg ('program coupler',  &
         'final time does not match expected ending time', WARNING)

!-----------------------------------------------------------------------
!the call to fms_io_exit has been moved here
!this will work for serial code or concurrent (disjoint pelists)
!but will fail on overlapping but unequal pelists
    if( Ocean%is_ocean_pe )then
        call mpp_set_current_pelist(Ocean%pelist)
        call ocean_model_end (Ocean, Ocean_state, Time)
    end if
    if( Atm%pe )then
        call mpp_set_current_pelist(Atm%pelist)
        call atmos_model_end (Atm)
        call  land_model_end (Atmos_land_boundary, Land)
        call   ice_model_end (Ice)
    end if

    !----- write restart file ------
    call coupler_restart(Time, Time_restart_current)

    call fms_io_exit
    call diag_manager_end (Time)
    call mpp_set_current_pelist()

!-----------------------------------------------------------------------

  end subroutine coupler_end

  !--- writing restart file that contains running time and restart file writing time.
  subroutine coupler_restart(Time_run, Time_res, time_stamp)
    type(time_type),   intent(in)           :: Time_run, Time_res
    character(len=*), intent(in),  optional :: time_stamp
    character(len=128)                      :: file_run, file_res
    integer :: yr, mon, day, hr, min, sec, date(6), unit

    call mpp_set_current_pelist()

    ! write restart file
    if(present(time_stamp)) then
       file_run = 'RESTART/'//trim(time_stamp)//'.coupler.res'
       file_res = 'RESTART/'//trim(time_stamp)//'.coupler.intermediate.res'
    else
       file_run = 'RESTART/coupler.res'
       file_res = 'RESTART/coupler.intermediate.res'
    endif

    !----- compute current date ------
    call get_date (Time_run, date(1), date(2), date(3),  &
                   date(4), date(5), date(6))
    call mpp_open( unit, file_run, nohdrs=.TRUE. )
    if ( mpp_pe().EQ.mpp_root_pe() )then
        write( unit, '(i6,8x,a)' )calendar_type, &
             '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)'

        write( unit, '(6i6,8x,a)' )date_init, &
             'Model start time:   year, month, day, hour, minute, second'
        write( unit, '(6i6,8x,a)' )date, &
             'Current model time: year, month, day, hour, minute, second'
    end if
    call mpp_close(unit)

    if(Time_res > Time_start) then
       call mpp_open( unit, file_res, nohdrs=.TRUE. )
       if ( mpp_pe().EQ.mpp_root_pe() )then
          call get_date(Time_res ,yr,mon,day,hr,min,sec)
          write( unit, '(6i6,8x,a)' )yr,mon,day,hr,min,sec, &
               'Current intermediate restart time: year, month, day, hour, minute, second'
       end if
       call mpp_close(unit)     
    end if

    if( Ocean%is_ocean_pe )then
        call mpp_set_current_pelist(Ocean%pelist)
        do n = 1, num_ocn_bc_restart
           call save_restart(Ocn_bc_restart(n), time_stamp)
        enddo
    endif
    if( Atm%pe )then
        call mpp_set_current_pelist(Atm%pelist)
        do n = 1, num_ice_bc_restart
           call save_restart(Ice_bc_restart(n), time_stamp)
        enddo
    endif


  end subroutine coupler_restart

!--------------------------------------------------------------------------

  subroutine coupler_chksum(id, timestep)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep

    type :: tracer_ind_type
       integer :: atm, ice, lnd ! indices of the tracer in the respective models
    end type tracer_ind_type
    integer                            :: n_atm_tr, n_lnd_tr, n_exch_tr
    integer                            :: n_atm_tr_tot, n_lnd_tr_tot
    integer                            :: i, tr, n, m, outunit
    type(tracer_ind_type), allocatable :: tr_table(:)
    character(32) :: tr_name

    call get_number_tracers (MODEL_ATMOS, num_tracers=n_atm_tr_tot, &
                             num_prog=n_atm_tr)
    call get_number_tracers (MODEL_LAND, num_tracers=n_lnd_tr_tot, &
                             num_prog=n_lnd_tr)

    ! assemble the table of tracer number translation by matching names of
    ! prognostic tracers in the atmosphere and surface models; skip all atmos.
    ! tracers that have no corresponding surface tracers.
    allocate(tr_table(n_atm_tr))
    n = 1
    do i = 1,n_atm_tr
       call get_tracer_names( MODEL_ATMOS, i, tr_name )
       tr_table(n)%atm = i
       tr_table(n)%ice = get_tracer_index ( MODEL_ICE,  tr_name )
       tr_table(n)%lnd = get_tracer_index ( MODEL_LAND, tr_name )
       if(tr_table(n)%ice/=NO_TRACER.or.tr_table(n)%lnd/=NO_TRACER) &
            n = n+1
    enddo
    n_exch_tr = n-1

100 FORMAT("CHECKSUM::",A32," = ",Z20)
101 FORMAT("CHECKSUM::",A16,a,'%',a," = ",Z20)

    if( Atm%pe )then
       call mpp_set_current_pelist(Atm%pelist)

       outunit = stdout()
       write(outunit,*) 'BEGIN CHECKSUM(Atm):: ', id, timestep
       write(outunit,100) 'atm%t_bot', mpp_chksum(atm%t_bot)
       write(outunit,100) 'atm%z_bot', mpp_chksum(atm%z_bot)
       write(outunit,100) 'atm%p_bot', mpp_chksum(atm%p_bot)
       write(outunit,100) 'atm%u_bot', mpp_chksum(atm%u_bot)
       write(outunit,100) 'atm%v_bot', mpp_chksum(atm%v_bot)
       write(outunit,100) 'atm%p_surf', mpp_chksum(atm%p_surf)
       write(outunit,100) 'atm%gust', mpp_chksum(atm%gust)
       do tr = 1,n_exch_tr
          n = tr_table(tr)%atm
          if(n /= NO_TRACER ) then
             call get_tracer_names( MODEL_ATMOS, tr_table(tr)%atm, tr_name )
             write(outunit,100) 'atm%'//trim(tr_name), mpp_chksum(Atm%tr_bot(:,:,n))
          endif
       enddo
   
       write(outunit,100) 'land%t_surf', mpp_chksum(land%t_surf)
       write(outunit,100) 'land%t_ca', mpp_chksum(land%t_ca)
       write(outunit,100) 'land%rough_mom', mpp_chksum(land%rough_mom)
       write(outunit,100) 'land%rough_heat', mpp_chksum(land%rough_heat)
       write(outunit,100) 'land%rough_scale', mpp_chksum(land%rough_scale)
       do tr = 1,n_exch_tr
          n = tr_table(tr)%lnd
          if(n /= NO_TRACER ) then
             call get_tracer_names( MODEL_ATMOS, tr_table(tr)%atm, tr_name )
             write(outunit,100) 'land%'//trim(tr_name), mpp_chksum(Land%tr(:,:,:,n))
          endif
       enddo
   
       write(outunit,100) 'ice%t_surf', mpp_chksum(ice%t_surf)
       write(outunit,100) 'ice%rough_mom', mpp_chksum(ice%rough_mom)
       write(outunit,100) 'ice%rough_heat', mpp_chksum(ice%rough_heat)
       write(outunit,100) 'ice%rough_moist', mpp_chksum(ice%rough_moist)
       write(outunit,*) 'STOP CHECKSUM(Atm):: ', id, timestep
   
    !endif

    !if( Ocean%is_ocean_pe )then
        !call mpp_set_current_pelist(Ocean%pelist)

       write(outunit,*) 'BEGIN CHECKSUM(Ice):: ', id, timestep
       do n = 1, ice%ocean_fields%num_bcs  !{
          do m = 1, ice%ocean_fields%bc(n)%num_fields  !{
             !write(outunit,101) 'ice%', m, n, mpp_chksum(Ice%ocean_fields%bc(n)%field(m)%values)
             write(outunit,101) 'ice%',trim(ice%ocean_fields%bc(n)%name), &
                  trim(ice%ocean_fields%bc(n)%field(m)%name), mpp_chksum(Ice%ocean_fields%bc(n)%field(m)%values)
          enddo  !} m
       enddo  !} n
       write(outunit,*) 'STOP CHECKSUM(Ice):: ', id, timestep

    endif

    deallocate(tr_table)

    call mpp_set_current_pelist()

  end subroutine coupler_chksum

  !#######################################################################

  subroutine atmos_ice_land_chksum(id, timestep)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep

! This subroutine calls subroutine that will print out checksums of the elements 
! of the appropriate type. 
! For coupled models typically these types are not defined on all processors.
! It is assumed that the appropriate pelist has been set before entering this routine.
! This can be achieved in the following way.
!       if (Atm%pe) then 
!         call mpp_set_current_pelist(Atm%pelist)
!         call atmos_ice_land_chksum('MAIN_LOOP-', nc)
!       endif
! If you are on the global pelist before you enter this routine using the above call, 
! you can return to the global pelist by invoking
!       call mpp_set_current_pelist()
! after you exit. This is only necessary if you need to return to the global pelist.

        call atmos_data_type_chksum(     id, timestep, Atm)
        call ice_data_type_chksum(       id, timestep, Ice)
        call land_data_type_chksum(      id, timestep, Land)
        call atm_ice_bnd_type_chksum(    id, timestep, Atmos_ice_boundary)
        call atm_lnd_bnd_type_chksum(    id, timestep, Atmos_land_boundary)
        call lnd_ice_atm_bnd_type_chksum(id, timestep, Land_ice_atmos_boundary)
        call ocn_ice_bnd_type_chksum(    id, timestep, Ocean_ice_boundary)
        
  end subroutine atmos_ice_land_chksum

  subroutine ocean_chksum(id, timestep)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep

! This subroutine calls subroutine that will print out checksums of the elements 
! of the appropriate type. 
! For coupled models typically these types are not defined on all processors.
! It is assumed that the appropriate pelist has been set before entering this routine.
! This can be achieved in the following way.
!       if (Ocean%is_ocean_pe) then 
!         call mpp_set_current_pelist(Ocean%pelist)
!         call ocean_chksum('MAIN_LOOP-', nc)
!       endif
! If you are on the global pelist before you enter this routine using the above call, 
! you can return to the global pelist by invoking
!       call mpp_set_current_pelist()
! after you exit. This is only necessary if you need to return to the global pelist.

        call ocean_public_type_chksum(id, timestep, Ocean)
        call ice_ocn_bnd_type_chksum( id, timestep, Ice_ocean_boundary)
        
  end subroutine ocean_chksum


  end program coupler_main



module flux_exchange_mod
!-----------------------------------------------------------------------
!                   GNU General Public License                        !                                                                      
! This program is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
! <CONTACT EMAIL="Bruce.Wyman@noaa.gov"> Bruce Wyman </CONTACT>
! <CONTACT EMAIL="V.Balaji@noaa.gov"> V. Balaji </CONTACT>
! <CONTACT EMAIL="Sergey.Malyshev@noaa.gov"> Sergey Malyshev </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   The flux_exchange module provides interfaces to couple the following component 
!   models: atmosphere, ocean, land, and ice. All interpolation between physically 
!   distinct model grids is handled by the exchange grid (xgrid_mod) with the 
!   interpolated quantities being conserved.
! </OVERVIEW>

! <DESCRIPTION>
!  <PRE>
!  1.This version of flux_exchange_mod allows the definition of physically independent
!    grids for atmosphere, land and sea ice. Ice and ocean must share the same physical
!    grid (though the domain decomposition on parallel systems may be different). 
!    Grid information is input through the grid_spec file (URL). The masked region of the
!    land grid and ice/ocean grid must "tile" each other. The masked region of the ice grid
!    and ocean grid must be identical. 
!
!         ATMOSPHERE  |----|----|----|----|----|----|----|----|
!
!               LAND  |---|---|---|---|xxx|xxx|xxx|xxx|xxx|xxx|
!
!                ICE  |xxx|xxx|xxx|xxx|---|---|---|---|---|---|
!
!               OCEAN |xxx|xxx|xxx|xxx|---|---|---|---|---|---|
!
!              where  |xxx| = masked grid point
!         
!
!    The atmosphere, land, and ice grids exchange information using the exchange grid xmap_sfc.
!
!    The land and ice grids exchange runoff data using the exchange grid xmap_runoff.
!
!    Transfer of data between the ice bottom and ocean does not require an exchange 
!    grid as the grids are physically identical. The flux routines will automatically
!    detect and redistribute data if their domain decompositions are different.
!
!    To get information from the atmosphere to the ocean it must pass through the 
!    ice model, first by interpolating from the atmospheric grid to the ice grid, 
!    and then transferring from the ice grid to the ocean grid.

!  2.Each component model must have a public defined data type containing specific 
!    boundary fields. A list of these quantities is located in the NOTES of this document. 
!
!  3.The surface flux of sensible heat and surface evaporation can be implicit functions
!    of surface temperature. As a consequence, the parts of the land and sea-ice models 
!    that update the surface temperature must be called on the atmospheric time step 
!
!  4.The surface fluxes of all other tracers and of momentum are assumed to be explicit
!    functions of all surface parameters 
!
!  5.While no explicit reference is made within this module to the implicit treatment 
!    of vertical diffusion in the atmosphere and in the land or sea-ice models, the 
!    module is designed to allow for simultaneous implicit time integration on both 
!    sides of the surface interface. 
!
!  6.Due to #5, the diffusion part of the land and ice models must be called on the 
!    atmospheric time step.
  
!7. Any field passed from one component to another may be "faked" to a
!   constant value, or to data acquired from a file, using the
!   data_override feature of FMS. The fields to override are runtime
!   configurable, using the text file <tt>data_table</tt> for input.
!   See the data_override_mod documentation for more details.
!
!   We DO NOT RECOMMEND exercising the data override capabilities of
!   the FMS coupler until the user has acquired considerable
!   sophistication in running FMS.
!
!   Here is a listing of the override capabilities of the flux_exchange
!   module:
!
!   FROM the atmosphere boundary TO the exchange grid (in sfc_boundary_layer):
!  
!        t_bot, q_bot, z_bot, p_bot, u_bot, v_bot, p_surf, slp, gust
!
!   FROM the ice boundary TO the exchange grid (in sfc_boundary_layer):
!
!        t_surf, rough_mom, rough_heat, rough_moist, albedo, u_surf, v_surf
!     
!   FROM the land boundary TO the exchange grid (in sfc_boundary_layer):
!
!        t_surf, t_ca, q_ca, rough_mom, rough_heat, albedo
!
!   FROM the exchange grid TO land_ice_atmos_boundary (in
!   sfc_boundary_layer):
!
!        t, albedo, land_frac, dt_t, dt_q, u_flux, v_flux, dtaudu, dtaudv,
!        u_star, b_star, rough_mom
!   
!   FROM the atmosphere boundary TO the exchange grid (in
!    flux_down_from_atmos):
!
!        flux_sw, flux_lw, lprec, fprec, coszen, dtmass, delta_t,
!        delta_q, dflux_t, dflux_q
!        
!   FROM the exchange grid TO the land boundary (in
!    flux_down_from_atmos):
!
!    t_flux, q_flux, lw_flux, sw_flux, lprec, fprec, dhdt, dedt, dedq,
!    drdt, drag_q, p_surf
!    
!   FROM the exchange grid TO the ice boundary (in flux_down_from_atmos):
!
!        u_flux, v_flux, t_flux, q_flux, lw_flux, lw_flux_dn, sw_flux,
!        sw_flux_dn, lprec, fprec, dhdt, dedt, drdt, coszen, p 
!
!   FROM the land boundary TO the ice boundary (in flux_land_to_ice):
!
!        runoff, calving
!
!   FROM the ice boundary TO the ocean boundary (in flux_ice_to_ocean):
! 
!        u_flux, v_flux, t_flux, q_flux, salt_flux, lw_flux, sw_flux,
!        lprec, fprec, runoff, calving, p
!        
!   FROM the ocean boundary TO the ice boundary (in flux_ocean_to_ice):
!
!        u, v, t, s, frazil, sea_level
!
!   FROM the ice boundary TO the atmosphere boundary (in flux_up_to_atmos):
!
!        t_surf
!
!   FROM the land boundary TO the atmosphere boundary (in
!    flux_up_to_atmos):
!  
!        t_ca, t_surf, q_ca
!
!  See NOTES below for an explanation of the field names.
!  </PRE>
! </DESCRIPTION>

  use mpp_mod,         only: mpp_npes, mpp_pe, mpp_root_pe, &
       mpp_error, stderr, stdout, stdlog, FATAL, NOTE, mpp_set_current_pelist, &
       mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sum, &
       CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_ROUTINE, lowercase, &
       input_nml_file
                    
  use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_compute_domains, &
                             mpp_global_sum, mpp_redistribute, operator(.EQ.)
  use mpp_domains_mod, only: mpp_get_global_domain, mpp_get_data_domain
  use mpp_domains_mod, only: mpp_set_global_domain, mpp_set_data_domain, mpp_set_compute_domain
  use mpp_domains_mod, only: mpp_deallocate_domain, mpp_copy_domain, domain2d

  use mpp_io_mod,      only: mpp_close, mpp_open, MPP_MULTI, MPP_SINGLE, MPP_OVERWR

!model_boundary_data_type contains all model fields at the boundary.
!model1_model2_boundary_type contains fields that model2 gets
!from model1, may also include fluxes. These are declared by
!flux_exchange_mod and have private components. All model fields in
!model_boundary_data_type may not be exchanged.
!will support 3 types of flux_exchange:
!REGRID: physically distinct grids, via xgrid
!REDIST: same grid, transfer in index space only
!DIRECT: same grid, same decomp, direct copy
  use atmos_model_mod, only: atmos_data_type, land_ice_atmos_boundary_type
  use ocean_model_mod, only: ocean_public_type, ice_ocean_boundary_type
  use ocean_model_mod, only: ocean_state_type
  use ice_model_mod,   only: ice_data_type, land_ice_boundary_type, &
       ocean_ice_boundary_type, atmos_ice_boundary_type, Ice_stock_pe, &
       ice_cell_area => cell_area
  use    land_model_mod, only:  land_data_type, atmos_land_boundary_type

  use  surface_flux_mod, only: surface_flux
  use monin_obukhov_mod, only: mo_profile     

  use xgrid_mod, only: xmap_type, setup_xmap, set_frac_area, &
       put_to_xgrid, get_from_xgrid, &
       xgrid_count, some, conservation_check, xgrid_init, &
       get_ocean_model_area_elements, stock_integrate_2d, &
       stock_move, stock_print


  use diag_integral_mod, only:     diag_integral_field_init, &
       sum_diag_integral_field

  use  diag_manager_mod, only: register_diag_field,  &
       register_static_field, send_data, send_tile_averaged_data

  use  time_manager_mod, only: time_type

  use sat_vapor_pres_mod, only: compute_qs

  use      constants_mod, only: rdgas, rvgas, cp_air, stefan, WTMAIR, HLV, HLF, Radius, PI, CP_OCEAN, &
                                WTMCO2, WTMC

!Balaji
!utilities stuff into use fms_mod
  use fms_mod,                    only: clock_flag_default, check_nml_error, error_mesg
  use fms_mod,                    only: open_namelist_file, write_version_number, string
  use fms_mod,                    only: field_exist, field_size, read_data, get_mosaic_tile_grid

  use data_override_mod,          only: data_override
  use coupler_types_mod,          only: coupler_1d_bc_type
  use atmos_ocean_fluxes_mod,     only: atmos_ocean_fluxes_init, atmos_ocean_fluxes_calc
  use ocean_model_mod,            only: ocean_model_init_sfc, ocean_model_flux_init, ocean_model_data_get
  use coupler_types_mod,          only: coupler_type_copy
  use coupler_types_mod,          only: ind_psurf, ind_u10
  use atmos_tracer_driver_mod,    only: atmos_tracer_flux_init

  use field_manager_mod,          only: MODEL_ATMOS, MODEL_LAND, MODEL_ICE
  use tracer_manager_mod,         only: get_tracer_index
  use tracer_manager_mod,         only: get_tracer_names, get_number_tracers, NO_TRACER

  use stock_constants_mod,        only: NELEMS, ISTOCK_WATER, ISTOCK_HEAT, ISTOCK_SALT
  use stock_constants_mod,        only: ISTOCK_SIDE, ISTOCK_TOP, ISTOCK_BOTTOM , STOCK_UNITS, STOCK_NAMES
  use stock_constants_mod,        only: stocks_file, stocks_report, stocks_report_init
  use stock_constants_mod,        only: Atm_stock, Ocn_stock, Lnd_stock, Ice_stock
  use land_model_mod,             only: Lnd_stock_pe
  use ocean_model_mod,            only: Ocean_stock_pe
  use atmos_model_mod,            only: Atm_stock_pe

#ifdef SCM
! option to override various surface boundary conditions for SCM
  use scm_forc_mod,               only: do_specified_flux, scm_surface_flux,             &
                                        do_specified_tskin, TSKIN,                       &
                                        do_specified_albedo, ALBEDO_OBS,                 &
                                        do_specified_rough_leng, ROUGH_MOM, ROUGH_HEAT,  &
                                        do_specified_land
#endif

  implicit none
  include 'netcdf.inc'
private

  character(len=48), parameter :: module_name = 'flux_exchange_mod'

  public :: flux_exchange_init,   &
     sfc_boundary_layer,   &
     generate_sfc_xgrid,   &
     flux_down_from_atmos, &
     flux_up_to_atmos,     &
     flux_land_to_ice,     &
     flux_ice_to_ocean,    &
     flux_ocean_to_ice,    &
     flux_check_stocks,    &
     flux_init_stocks,     &
     flux_ice_to_ocean_stocks,&
     flux_ocean_from_ice_stocks

!-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: flux_exchange.F90,v 17.0.4.1.2.5.2.1.2.1.2.1.2.4.2.1.2.1 2011/12/12 19:30:45 Peter.Phillipps Exp $'
  character(len=128) :: tag = '$Name:  $'
!-----------------------------------------------------------------------
!---- exchange grid maps -----

type(xmap_type), save :: xmap_sfc, xmap_runoff

integer         :: n_xgrid_sfc,  n_xgrid_runoff

!-----------------------------------------------------------------------
!-------- namelist (for diagnostics) ------

character(len=4), parameter :: mod_name = 'flux'

  integer :: id_drag_moist,  id_drag_heat,  id_drag_mom,     &
     id_rough_moist, id_rough_heat, id_rough_mom,    &
     id_land_mask,   id_ice_mask, id_sst,     &
     id_u_star, id_b_star, id_q_star, id_u_flux, id_v_flux,   &
     id_t_surf, id_t_flux, id_r_flux, id_q_flux, id_slp,      &
     id_t_atm,  id_u_atm,  id_v_atm,  id_wind,                &
     id_t_ref,  id_rh_ref, id_u_ref,  id_v_ref, id_wind_ref,  &
     id_del_h,  id_del_m,  id_del_q,  id_rough_scale,         &
     id_t_ca,   id_q_surf, id_q_atm, id_z_atm, id_p_atm, id_gust, &
     id_t_ref_land, id_rh_ref_land, id_u_ref_land, id_v_ref_land, &
     id_q_ref,  id_q_ref_land, id_q_flux_land, id_rh_ref_cmip

integer :: id_co2_atm_dvmr, id_co2_surf_dvmr

integer, allocatable :: id_tr_atm(:), id_tr_surf(:), id_tr_flux(:), id_tr_mol_flux(:)

logical :: first_static = .true.
logical :: do_init = .true.
integer :: remap_method = 1

real, parameter :: bound_tol = 1e-7

real, parameter :: d622 = rdgas/rvgas
real, parameter :: d378 = 1.0-d622

!--- namelist interface ------------------------------------------------------
! <NAMELIST NAME="flux_exchange_nml">
!   <DATA NAME="z_ref_heat"  TYPE="real"  DEFAULT="2.0">
!    eference height (meters) for temperature and relative humidity 
!    diagnostics (t_ref,rh_ref,del_h,del_q)
!   </DATA>
!   <DATA NAME="z_ref_mom"  TYPE="real"  DEFAULT="10.0">
!    reference height (meters) for momentum diagnostics (u_ref,v_ref,del_m)
!   </DATA>
!   <DATA NAME="ex_u_star_smooth_bug"  TYPE="logical"  DEFAULT="false">
!    By default, the global exchange grid u_star will not be interpolated from 
!    atmospheric grid, this is different from Jakarta behavior and will
!    change answers. So to perserve Jakarta behavior and reproduce answers
!    explicitly set this namelist variable to .true. in input.nml.
!    Talk to mw, ens for details.
!   </DATA>
!   <DATA NAME="do_runoff"  TYPE="logical"  DEFAULT=".TRUE.">
!    Turns on/off the land runoff interpolation to the ocean.
!   </DATA>


  real ::  z_ref_heat =  2.,  &
           z_ref_mom  = 10.
  logical :: ex_u_star_smooth_bug = .false.
  logical :: sw1way_bug = .false.
  logical :: do_area_weighted_flux = .FALSE.
  logical :: debug_stocks = .FALSE.
  logical :: divert_stocks_report = .FALSE.
  logical :: do_runoff = .TRUE.
  logical :: do_forecast = .false.

namelist /flux_exchange_nml/ z_ref_heat, z_ref_mom, ex_u_star_smooth_bug, sw1way_bug, &
         do_area_weighted_flux, debug_stocks, divert_stocks_report, do_runoff, do_forecast
! </NAMELIST>

! ---- allocatable module storage --------------------------------------------
real, allocatable, dimension(:) :: &
     ! NOTE: T canopy is only differet from t_surf over vegetated land
     ex_t_surf,    &   ! surface temperature for radiation calc, degK
     ex_t_surf_miz,&   ! miz
     ex_t_ca,      &   ! near-surface (canopy) air temperature, degK
     ex_p_surf,    &   ! surface pressure
     ex_slp,       &   ! surface pressure

     ex_flux_t,    &   ! sens heat flux
     ex_flux_lw,   &   ! longwave radiation flux

     ex_dhdt_surf, &   ! d(sens.heat.flux)/d(T canopy)
     ex_dedt_surf, &   ! d(water.vap.flux)/d(T canopy)
     ex_dqsatdt_surf, &   ! d(water.vap.flux)/d(q canopy)
     ex_e_q_n,     &
     ex_drdt_surf, &   ! d(LW flux)/d(T surf)
     ex_dhdt_atm,  &   ! d(sens.heat.flux)/d(T atm)
     ex_flux_u,    &   ! u stress on atmosphere
     ex_flux_v,    &   ! v stress on atmosphere
     ex_dtaudu_atm,&   ! d(stress)/d(u)
     ex_dtaudv_atm,&   ! d(stress)/d(v)
     ex_albedo_fix,&
     ex_albedo_vis_dir_fix,&
     ex_albedo_nir_dir_fix,&
     ex_albedo_vis_dif_fix,&
     ex_albedo_nir_dif_fix,&
     ex_old_albedo,&   ! old value of albedo for downward flux calculations
     ex_drag_q,    &   ! q drag.coeff.
     ex_cd_t,      &
     ex_cd_m,      &
     ex_b_star,    &
     ex_u_star,    &
     ex_wind,      &
     ex_z_atm

#ifdef SCM
real, allocatable, dimension(:) :: &
     ex_dhdt_surf_forland, &
     ex_dedt_surf_forland, &
     ex_dedq_surf_forland
#endif

real, allocatable, dimension(:,:) :: &
     ex_tr_surf,    & ! near-surface tracer fields
     ex_flux_tr,    & ! tracer fluxes
     ex_dfdtr_surf, & ! d(tracer flux)/d(surf tracer)
     ex_dfdtr_atm,  & ! d(tracer flux)/d(atm tracer)
     ex_e_tr_n,     & ! coefficient in implicit scheme 
     ex_f_tr_delt_n   ! coefficient in implicit scheme

logical, allocatable, dimension(:) :: &
     ex_avail,     &   ! true where data on exchange grid are available
     ex_land           ! true if exchange grid cell is over land
real, allocatable, dimension(:) :: &
     ex_e_t_n,      &
     ex_f_t_delt_n

integer :: n_atm_tr  ! number of prognostic tracers in the atmos model
integer :: n_atm_tr_tot  ! number of prognostic tracers in the atmos model
integer :: n_lnd_tr  ! number of prognostic tracers in the land model 
integer :: n_lnd_tr_tot  ! number of prognostic tracers in the land model 
integer :: n_exch_tr ! number of tracers exchanged between models

type :: tracer_ind_type
   integer :: atm, ice, lnd ! indices of the tracer in the respective models
end type 
type(tracer_ind_type), allocatable :: tr_table(:) ! table of tracer indices
type :: tracer_exch_ind_type
   integer :: exch = 0  ! exchange grid index
   integer :: ice = 0   ! ice model index
   integer :: lnd = 0   ! land model index
end type tracer_exch_ind_type
type(tracer_exch_ind_type), allocatable :: tr_table_map(:) ! map atm tracers to exchange, ice and land variables
integer :: isphum = NO_TRACER       ! index of specific humidity tracer in tracer table
integer :: ico2   = NO_TRACER       ! index of co2 tracer in tracer table

type(coupler_1d_bc_type), save        :: ex_gas_fields_atm  ! gas fields in atm
                     ! Place holder for various atmospheric fields.
type(coupler_1d_bc_type), save        :: ex_gas_fields_ice  ! gas fields on ice
type(coupler_1d_bc_type), save        :: ex_gas_fluxes      ! gas flux
                     ! Place holder of intermediate calculations, such as
                     ! piston velocities etc.

integer :: ni_atm, nj_atm ! to do atmos diagnostic from flux_ocean_to_ice
real, dimension(3) :: ccc ! for conservation checks
!Balaji, sets boundary_type%xtype
!  REGRID: grids are physically different, pass via exchange grid
!  REDIST: same physical grid, different decomposition, must move data around
!  DIRECT: same physical grid, same domain decomposition, can directly copy data
integer, parameter :: REGRID=1, REDIST=2, DIRECT=3
!Balaji: clocks moved into flux_exchange
  integer :: cplClock, sfcClock, fluxAtmDnClock, fluxLandIceClock, &
             fluxIceOceanClock, fluxOceanIceClock, regenClock, fluxAtmUpClock, &
             cplOcnClock

  logical :: ocn_pe, ice_pe
  integer, allocatable, dimension(:) :: ocn_pelist, ice_pelist

  ! Exchange grid indices
  integer :: X1_GRID_ATM, X1_GRID_ICE, X1_GRID_LND
  integer :: X2_GRID_LND, X2_GRID_ICE
  real    :: Dt_atm, Dt_cpl
  real    :: ATM_PRECIP_NEW

integer ::  runoff_id_diag =-1 
contains

!#######################################################################
! <SUBROUTINE NAME="flux_exchange_init">
!  <OVERVIEW>
!   Initialization routine.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Initializes the interpolation routines,diagnostics and boundary data
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_exchange_init ( Time, Atm, Land, Ice, Ocean, &
!		atmos_ice_boundary, land_ice_atmos_boundary, &
!		land_ice_boundary, ice_ocean_boundary, ocean_ice_boundary, &
!                dt_atmos, dt_cpld )
!		
!  </TEMPLATE>
!  <IN NAME=" Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="Atm" TYPE="atmos_data_type">
!   A derived data type to specify atmosphere boundary data.
!  </IN>
!  <IN NAME="Land" TYPE="land_data_type">
!   A derived data type to specify land boundary data.
!  </IN>
!  <IN NAME="Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </IN>
!  <IN NAME="Ocean" TYPE="ocean_public_type">
!   A derived data type to specify ocean boundary data.
!  </IN>
!  <INOUT NAME="atmos_ice_boundary" TYPE="atmos_ice_boundary_type">
!   A derived data type to specify properties and fluxes passed from atmosphere to ice.
!  </INOUT>
!  <INOUT NAME="land_ice_atmos_boundary" TYPE="land_ice_atmos_boundary_type">
!   A derived data type to specify properties and fluxes passed from exchange grid to
!   the atmosphere, land and ice.
!  </INOUT>
!  <INOUT NAME="land_ice_boundary" TYPE="land_ice_boundary_type">
!   A derived data type to specify properties and fluxes passed from land to ice.
!  </INOUT>
!  <INOUT NAME="ice_ocean_boundary" TYPE="ice_ocean_boundary_type">
!  A derived data type to specify properties and fluxes passed from ice to ocean.
!  </INOUT>
!  <INOUT NAME="ocean_ice_boundary" TYPE="ocean_ice_boundary_type">
!  A derived data type to specify properties and fluxes passed from ocean to ice.
!  </INOUT>
!  <IN NAME="dt_atmos" TYPE="integer">
!  Atmos time step in secs.
!  </IN>
!  <IN NAME="dt_cpld" TYPE="integer">
!  Coupled time step in secs.
!  </IN>

!
subroutine flux_exchange_init ( Time, Atm, Land, Ice, Ocean, Ocean_state,&
       atmos_ice_boundary, land_ice_atmos_boundary, &
       land_ice_boundary, ice_ocean_boundary, ocean_ice_boundary, &
       dt_atmos, dt_cpld )

  type(time_type),                   intent(in)  :: Time
  type(atmos_data_type),             intent(inout)  :: Atm
  type(land_data_type),              intent(in)  :: Land
  type(ice_data_type),               intent(inout)  :: Ice
  type(ocean_public_type),           intent(inout)  :: Ocean
  type(ocean_state_type),            pointer        :: Ocean_state
! All intent(OUT) derived types with pointer components must be 
! COMPLETELY allocated here and in subroutines called from here;
! NO pointer components should have been allocated before entry if the
! derived type has intent(OUT) otherwise they may be lost.
  type(atmos_ice_boundary_type),     intent(inout) :: atmos_ice_boundary
  type(land_ice_atmos_boundary_type),intent(inout) :: land_ice_atmos_boundary
  type(land_ice_boundary_type),      intent(inout) :: land_ice_boundary
  type(ice_ocean_boundary_type),     intent(inout) :: ice_ocean_boundary
  type(ocean_ice_boundary_type),     intent(inout) :: ocean_ice_boundary
  integer, optional,                 intent(in)    :: dt_atmos, dt_cpld

  character(len=64), parameter    :: sub_name = 'flux_exchange_init'
  character(len=256), parameter   :: error_header = '==>Error from ' // trim(module_name) //   &
                                                    '(' // trim(sub_name) // '):'
  character(len=256), parameter   :: warn_header = '==>Warning from ' // trim(module_name) //  &
                                                   '(' // trim(sub_name) // '):'
  character(len=256), parameter   :: note_header = '==>Note from ' // trim(module_name) //     &
                                                   '(' // trim(sub_name) // '):'
  character(len=64),  parameter   :: grid_file = 'INPUT/grid_spec.nc'  
  character(len=256)              :: atm_mosaic_file, tile_file 

  type(domain2d) :: domain2
  integer        :: isg, ieg, jsg, jeg
  integer        :: isc, iec, jsc, jec
  integer        :: isd, ied, jsd, jed
  integer        :: isc2, iec2, jsc2, jec2
  integer        :: nxg, nyg, ioff, joff
  integer        :: unit, ierr, io,  i, j
  integer        :: nlon, nlat, siz(4)
  integer        :: outunit, logunit, size1
  real, dimension(:,:), allocatable :: tmpx(:,:), tmpy(:,:)
  real, dimension(:),   allocatable :: atmlonb, atmlatb
  integer :: is, ie, js, je, kd
  character(32) :: tr_name
  character(len=256) :: string_tmp
  logical       :: found

  integer              :: n, npes_atm, npes_ocn, npes_all
  integer, allocatable :: pelist(:)

!-----------------------------------------------------------------------

!
!       initialize atmos_ocean_fluxes
! Setting up flux types, allocates the arrays.
!

!
!       ocean_tracer_flux_init is called first since it has the meaningful value to set
!       for the input/output file names for the tracer flux values used in restarts. These
!       values could be set in the field table, and this ordering allows this.
!       atmos_tracer_flux_init is called last since it will use the values set in 
!       ocean_tracer_flux_init with the exception of atm_tr_index, which can only
!       be meaningfully set from the atmospheric model (not from the field table)
!

    call ocean_model_flux_init(Ocean_state)
    call atmos_tracer_flux_init
    call atmos_ocean_fluxes_init(ex_gas_fluxes, ex_gas_fields_atm, ex_gas_fields_ice)

!-----------------------------------------------------------------------
    outunit = stdout(); logunit = stdlog()
!----- read namelist -------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, flux_exchange_nml, iostat=io)
#else
    unit = open_namelist_file()
    ierr=1; do while (ierr /= 0)
       read  (unit, nml=flux_exchange_nml, iostat=io, end=10)
       ierr = check_nml_error (io, 'flux_exchange_nml')
    enddo
10  call mpp_close(unit)
#endif

!----- write namelist to logfile -----
    call write_version_number (version, tag)
    if( mpp_pe() == mpp_root_pe() )write( logunit, nml=flux_exchange_nml )

!----- find out number of atmospheric prognostic tracers and index of specific 
!      humidity in the tracer table
  call get_number_tracers (MODEL_ATMOS, num_tracers=n_atm_tr_tot, &
                           num_prog=n_atm_tr)
  call get_number_tracers (MODEL_LAND, num_tracers=n_lnd_tr_tot, &
                           num_prog=n_lnd_tr)

  ! assemble the table of tracer number translation by matching names of
  ! prognostic tracers in the atmosphere and surface models; skip all atmos.
  ! tracers that have no corresponding surface tracers.
  allocate(tr_table(n_atm_tr))
  allocate(tr_table_map(n_atm_tr))
  n = 1
  do i = 1,n_atm_tr
     call get_tracer_names( MODEL_ATMOS, i, tr_name )
     tr_table(n)%atm = i
     tr_table(n)%ice = get_tracer_index ( MODEL_ICE,  tr_name )
     tr_table_map(i)%ice = tr_table(n)%ice
     tr_table(n)%lnd = get_tracer_index ( MODEL_LAND, tr_name )
     tr_table_map(i)%lnd = tr_table(n)%lnd
     if(tr_table(n)%ice/=NO_TRACER.or.tr_table(n)%lnd/=NO_TRACER) then
       tr_table_map(i)%exch = n
       n = n + 1
     endif
  enddo
  n_exch_tr = n - 1
  !
  !     Set up tracer table entries for ocean-atm gas fluxes where the names of tracers in the
  !     atmosphere and ocean may not be equal
  !
  do n = 1, ex_gas_fluxes%num_bcs  !{
    if (ex_gas_fluxes%bc(n)%atm_tr_index .gt. 0) then  !{
      found = .false.
      do i = 1, n_exch_tr  !{
        if (ex_gas_fluxes%bc(n)%atm_tr_index .eq. tr_table(i)%atm) then
          found = .true.
          exit
        endif
      enddo  !} i
      if (.not. found) then
        n_exch_tr = n_exch_tr + 1
        tr_table(n_exch_tr)%atm = ex_gas_fluxes%bc(n)%atm_tr_index
        tr_table(n_exch_tr)%ice = NO_TRACER ! because ocean-atm gas fluxes are not held in the ice model as tracers
        tr_table(n_exch_tr)%lnd = NO_TRACER ! because this would have been found above
        tr_table_map(n_exch_tr)%exch = n_exch_tr
        tr_table_map(n_exch_tr)%ice = tr_table(n_exch_tr)%ice
        tr_table_map(n_exch_tr)%lnd = tr_table(n_exch_tr)%lnd
      endif
    endif  !}
  enddo  !} n
  write(outunit,*) trim(note_header), ' Number of exchanged tracers = ', n_exch_tr
  write(logunit,*) trim(note_header), ' Number of exchanged tracers = ', n_exch_tr
  do i = 1,n_exch_tr
     call get_tracer_names( MODEL_ATMOS, tr_table(i)%atm, tr_name )
     write(outunit,*)'Tracer field name :'//trim(tr_name)
     write(logunit,*)'Tracer field name :'//trim(tr_name)
  enddo

  ! find out which tracer is specific humidity

  ! +fix-me-slm+ specific humidity may not be present if we are running with
  ! dry atmosphere. Besides, model may use mixing ratio ('mix_rat') (?). However,
  ! some atmos code also assumes 'sphum' is present, so for now the following
  ! code may be good enough.

  do i = 1,n_exch_tr
     call get_tracer_names( MODEL_ATMOS, tr_table(i)%atm, tr_name )
     if(lowercase(tr_name)=='sphum') then
        isphum = i
     endif
  ! jgj: find out which exchange tracer is co2
     if(lowercase(tr_name)=='co2') then
        ico2 = i
        write(outunit,*)'Exchange tracer index for '//trim(tr_name),' : ',ico2
     endif
  enddo

  if (isphum==NO_TRACER) then
     call error_mesg('flux_exchange_mod',&
          'tracer "sphum" must be present in the atmosphere', FATAL )
  endif

  if (ico2==NO_TRACER) then
     call error_mesg('flux_exchange_mod',&
          'tracer "co2" not present in the atmosphere', NOTE )
  endif

!--------- read gridspec file ------------------
!only atmos pelists needs to do it here, ocean model will do it elsewhere

    ice_pe = Atm%pe
    ocn_pe = Ocean%is_ocean_pe
    allocate( ice_pelist(size(Atm%pelist)) ) !if ice/land become concurrent, this won't be true...
    ice_pelist(:) = Atm%pelist(:)
    allocate( ocn_pelist(size(Ocean%pelist)) )
    ocn_pelist(:) = Ocean%pelist(:)

    call get_ocean_model_area_elements(Ocean%domain, grid_file)

    if( Atm%pe )then
       call mpp_set_current_pelist(Atm%pelist)

       !
       ! check atmosphere and grid_spec.nc have same atmosphere lat/lon boundaries
       !
       call mpp_get_global_domain(Atm%domain, isg, ieg, jsg, jeg, xsize=nxg, ysize=nyg)
       call mpp_get_compute_domain(Atm%domain, isc, iec, jsc, jec)
       call mpp_get_data_domain(Atm%domain, isd, ied, jsd, jed)
       if(size(Atm%lon_bnd,1) .NE. iec-isc+2 .OR. size(Atm%lon_bnd,2) .NE. jec-jsc+2) then
          call error_mesg ('flux_exchange_mod',  &
              'size of Atm%lon_bnd does not match the Atm computational domain', FATAL)          
       endif
       ioff = lbound(Atm%lon_bnd,1) - isc
       joff = lbound(Atm%lon_bnd,2) - jsc
       if(field_exist(grid_file, "AREA_ATM" ) ) then  ! old grid
          call field_size(grid_file, "AREA_ATM", siz)
          nlon = siz(1)
          nlat = siz(2)          
          
          if (nlon /= nxg .or. nlat /= nyg) then
             if (mpp_pe()==mpp_root_pe()) then
                print *, 'grid_spec.nc has', nlon, 'longitudes,', nlat, 'latitudes; ', &
                     'atmosphere has', nxg, 'longitudes,', &
                     nyg, 'latitudes (see xba.dat and yba.dat)'
             end if
             !   <ERROR MSG="grid_spec.nc incompatible with atmosphere resolution" STATUS="FATAL">
             !      The atmosphere grid size from file grid_spec.nc is not compatible with the atmosphere 
             !      resolution from atmosphere model.
             !   </ERROR>
             call error_mesg ('flux_exchange_mod',  &
                  'grid_spec.nc incompatible with atmosphere resolution', FATAL)
          end if
          allocate( atmlonb(isg:ieg+1) )
          allocate( atmlatb(jsg:jeg+1) )
          call read_data(grid_file, 'xba', atmlonb, no_domain=.true. )
          call read_data(grid_file, 'yba', atmlatb, no_domain=.true. )

          do i=isc, iec+1
             if(abs(atmlonb(i)-Atm%lon_bnd(i+ioff,jsc+joff)*45/atan(1.0))>bound_tol) then
                print *, 'GRID_SPEC/ATMOS LONGITUDE INCONSISTENCY at i= ',i, ': ', &
                     atmlonb(i),  Atm%lon_bnd(i+ioff,jsc+joff)*45/atan(1.0)
                call error_mesg ('flux_exchange_mod', &
                     'grid_spec.nc incompatible with atmosphere longitudes (see xba.dat and yba.dat)'&
                     , FATAL)
             endif
          enddo
          !   <ERROR MSG="grid_spec.nc incompatible with atmosphere longitudes (see xba.dat and yba.dat)" STATUS="FATAL">
          !      longitude from file grid_spec.nc ( from field yba ) is different from the longitude from atmosphere model.
          !   </ERROR>
          do j=jsc, jec+1
             if(abs(atmlatb(j)-Atm%lat_bnd(isc+ioff,j+joff)*45/atan(1.0))>bound_tol) then
                print *, 'GRID_SPEC/ATMOS LATITUDE INCONSISTENCY at j= ',j, ': ', &
                     atmlatb(j),  Atm%lat_bnd(isc+ioff, j+joff)*45/atan(1.0)
                call error_mesg ('flux_exchange_mod', &
                     'grid_spec.nc incompatible with atmosphere latitudes (see xba.dat and yba.dat)'&
                     , FATAL)
             endif
          enddo
          deallocate(atmlonb, atmlatb)
        else if(field_exist(grid_file, "atm_mosaic_file" ) ) then  ! mosaic grid file.
           call read_data(grid_file, 'atm_mosaic_file', atm_mosaic_file)
           call get_mosaic_tile_grid(tile_file, 'INPUT/'//trim(atm_mosaic_file), Atm%domain)          
           call field_size(tile_file, 'area', siz)
           nlon = siz(1); nlat = siz(2)
           if( mod(nlon,2) .NE. 0) call mpp_error(FATAL,  &
                'flux_exchange_mod: atmos supergrid longitude size can not be divided by 2')
           if( mod(nlat,2) .NE. 0) call mpp_error(FATAL,  &
                'flux_exchange_mod: atmos supergrid latitude size can not be divided by 2')
           nlon = nlon/2
           nlat = nlat/2
           if (nlon /= nxg .or. nlat /= nyg) then
             if (mpp_pe()==mpp_root_pe()) then
                print *, 'atmosphere mosaic tile has', nlon, 'longitudes,', nlat, 'latitudes; ', &
                     'atmosphere has', nxg, 'longitudes,', nyg, 'latitudes'
             end if
            call error_mesg ('flux_exchange_mod',  &
                  'atmosphere mosaic tile grid file incompatible with atmosphere resolution', FATAL)
           end if

           call mpp_copy_domain(Atm%domain, domain2)
           call mpp_set_compute_domain(domain2, 2*isc-1, 2*iec+1, 2*jsc-1, 2*jec+1, 2*(iec-isc)+3, 2*(jec-jsc)+3 )
           call mpp_set_data_domain   (domain2, 2*isd-1, 2*ied+1, 2*jsd-1, 2*jed+1, 2*(ied-isd)+3, 2*(jed-jsd)+3 )   
           call mpp_set_global_domain (domain2, 2*isg-1, 2*ieg+1, 2*jsg-1, 2*jeg+1, 2*(ieg-isg)+3, 2*(jeg-jsg)+3 )   
           call mpp_get_compute_domain(domain2, isc2, iec2, jsc2, jec2)
           if(isc2 .NE. 2*isc-1 .OR. iec2 .NE. 2*iec+1 .OR. jsc2 .NE. 2*jsc-1 .OR. jec2 .NE. 2*jec+1) then
              call mpp_error(FATAL, 'flux_exchange_mod: supergrid domain is not set properly')
           endif

           allocate(tmpx(isc2:iec2,jsc2:jec2), tmpy(isc2:iec2,jsc2:jec2) )

           call read_data( tile_file, 'x', tmpx, domain2)
           call read_data( tile_file, 'y', tmpy, domain2)     
           call mpp_deallocate_domain(domain2)

           do j = jsc, jec+1
              do i = isc, iec+1
                 if (abs(tmpx(2*i-1,2*j-1)-Atm%lon_bnd(i+ioff,j+joff)*45/atan(1.0))>bound_tol) then
                    print *, 'GRID_SPEC/ATMOS LONGITUDE INCONSISTENCY at i= ',i, ', j= ', j, ': ', &
                         tmpx(2*i-1,2*j-1),  Atm%lon_bnd(i+ioff,j+joff)*45/atan(1.0)
                    !   <ERROR MSG="grid_spec.nc incompatible with atmosphere longitudes (see xba.dat and yba.dat)" STATUS="FATAL">
                    !      longitude from file grid_spec.nc ( from field xba ) is different from the longitude from atmosphere model.
                    !   </ERROR>
                    call error_mesg ('flux_exchange_mod', &
                         'grid_spec.nc incompatible with atmosphere longitudes (see '//trim(tile_file)//')'&
                         ,FATAL)
                 end if
                 if (abs(tmpy(2*i-1,2*j-1)-Atm%lat_bnd(i+ioff,j+joff)*45/atan(1.0))>bound_tol) then
                    print *, 'GRID_SPEC/ATMOS LATITUDE INCONSISTENCY at i= ',i, ', j= ', j, ': ', &
                         tmpy(2*i-1,2*j-1),  Atm%lat_bnd(i+ioff,j+joff)*45/atan(1.0)
                    !   <ERROR MSG="grid_spec.nc incompatible with atmosphere latitudes (see grid_spec.nc)" STATUS="FATAL">
                    !      latgitude from file grid_spec.nc is different from the latitude from atmosphere model.
                    !   </ERROR>
                    call error_mesg ('flux_exchange_mod', &
                         'grid_spec.nc incompatible with atmosphere latitudes (see '//trim(tile_file)//')'&
                         ,FATAL)
                 end if
              end do
           end do
           deallocate(tmpx, tmpy)
        else
           call mpp_error(FATAL, 'flux_exchange_mod: both AREA_ATMxOCN and ocn_mosaic_file does not exist in '//trim(grid_file))
        end if

 
        call xgrid_init(remap_method)

        call setup_xmap(xmap_sfc, (/ 'ATM', 'OCN', 'LND' /),   &
             (/ Atm%Domain, Ice%Domain, Land%Domain /),        &
             "INPUT/grid_spec.nc", Atm%grid)
        ! exchange grid indices
        X1_GRID_ATM = 1; X1_GRID_ICE = 2; X1_GRID_LND = 3;
        call generate_sfc_xgrid( Land, Ice )
        if (n_xgrid_sfc.eq.1) then
           size1 = 1
        else
           size1 = 0
        endif
        call mpp_sum (size1)
        string_tmp = 'NOTE from flux_exchange: Surface exchange grid size equals one on '// &
                      trim(string(size1))//' of '//trim(string(mpp_npes()))//' processors.'
        write (outunit,'(a)') trim(string_tmp)
        write (logunit,'(a)') trim(string_tmp)

        if (do_runoff) then
           call setup_xmap(xmap_runoff, (/ 'LND', 'OCN' /),       &
                (/ Land%Domain, Ice%Domain /),                    &
                "INPUT/grid_spec.nc"             )
           ! exchange grid indices
           X2_GRID_LND = 1; X2_GRID_ICE = 2;
           n_xgrid_runoff = max(xgrid_count(xmap_runoff),1)
           if (n_xgrid_runoff.eq.1) then
              size1 = 1
           else
              size1 = 0
           endif
           call mpp_sum (size1)
           string_tmp = 'NOTE from flux_exchange: Runoff exchange grid size equals one on '// &
                         trim(string(size1))//' of '//trim(string(mpp_npes()))//' processors.'
           write (outunit,'(a)') trim(string_tmp)
           write (logunit,'(a)') trim(string_tmp)
        endif

!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!----- initialize quantities for global integral package -----

!! call diag_integral_field_init ('prec', 'f6.3')
        call diag_integral_field_init ('evap', 'f6.3')

!-----------------------------------------------------------------------
!----- initialize diagnostic fields -----
!----- all fields will be output on the atmospheric grid -----

        call diag_field_init ( Time, Atm%axes(1:2), Land%axes )
        ni_atm = size(Atm%lon_bnd,1)-1 ! to dimension "diag_atm"
        nj_atm = size(Atm%lon_bnd,2)-1 ! in flux_ocean_to_ice

!Balaji
        
!allocate atmos_ice_boundary
        call mpp_get_compute_domain( Ice%domain, is, ie, js, je )
        kd = size(Ice%ice_mask,3)
        allocate( atmos_ice_boundary%u_flux(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%v_flux(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%u_star(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%t_flux(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%q_flux(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%lw_flux(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%sw_flux_vis_dir(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%sw_flux_vis_dif(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%sw_flux_nir_dir(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%sw_flux_nir_dif(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%lprec(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%fprec(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%dhdt(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%dedt(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%drdt(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%coszen(is:ie,js:je,kd) )
        allocate( atmos_ice_boundary%p(is:ie,js:je,kd) )
! initialize boundary values for override experiments (mjh)
        atmos_ice_boundary%u_flux=0.0
        atmos_ice_boundary%v_flux=0.0
        atmos_ice_boundary%u_star=0.0
        atmos_ice_boundary%t_flux=0.0
        atmos_ice_boundary%q_flux=0.0
        atmos_ice_boundary%lw_flux=0.0
        atmos_ice_boundary%sw_flux_vis_dir=0.0
        atmos_ice_boundary%sw_flux_vis_dif=0.0
        atmos_ice_boundary%sw_flux_nir_dir=0.0
        atmos_ice_boundary%sw_flux_nir_dif=0.0
        atmos_ice_boundary%lprec=0.0
        atmos_ice_boundary%fprec=0.0
        atmos_ice_boundary%dhdt=0.0
        atmos_ice_boundary%dedt=0.0
        atmos_ice_boundary%drdt=0.0
        atmos_ice_boundary%coszen=0.0
        atmos_ice_boundary%p=0.0

!         allocate fields for extra fluxes
! Copying initialized gas fluxes from exchange grid to atmosphere_ice boundary

        call coupler_type_copy(ex_gas_fluxes, atmos_ice_boundary%fluxes, is, ie, js, je, kd,    &
             mod_name, Ice%axes, Time, suffix = '_atm_ice')
  
!allocate land_ice_boundary
        allocate( land_ice_boundary%runoff(is:ie,js:je) )
        allocate( land_ice_boundary%calving(is:ie,js:je) )
        allocate( land_ice_boundary%runoff_hflx(is:ie,js:je) )
        allocate( land_ice_boundary%calving_hflx(is:ie,js:je) )
! initialize values for override experiments (mjh)
        land_ice_boundary%runoff=0.0
        land_ice_boundary%calving=0.0
        land_ice_boundary%runoff_hflx=0.0
        land_ice_boundary%calving_hflx=0.0
!allocate land_ice_atmos_boundary
        call mpp_get_compute_domain( Atm%domain, is, ie, js, je )
        allocate( land_ice_atmos_boundary%t(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%albedo(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%albedo_vis_dir(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%albedo_nir_dir(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%albedo_vis_dif(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%albedo_nir_dif(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%land_frac(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%dt_t(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%dt_tr(is:ie,js:je,n_atm_tr) )
        allocate( land_ice_atmos_boundary%u_flux(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%v_flux(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%dtaudu(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%dtaudv(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%u_star(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%b_star(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%q_star(is:ie,js:je) )
        allocate( land_ice_atmos_boundary%rough_mom(is:ie,js:je) )
! initialize boundary values for override experiments (mjh)
        land_ice_atmos_boundary%t=273.0
        land_ice_atmos_boundary%albedo=0.0
        land_ice_atmos_boundary%albedo_vis_dir=0.0
        land_ice_atmos_boundary%albedo_nir_dir=0.0
        land_ice_atmos_boundary%albedo_vis_dif=0.0
        land_ice_atmos_boundary%albedo_nir_dif=0.0
        land_ice_atmos_boundary%land_frac=0.0
        land_ice_atmos_boundary%dt_t=0.0
        land_ice_atmos_boundary%dt_tr=0.0
        land_ice_atmos_boundary%u_flux=0.0
        land_ice_atmos_boundary%v_flux=0.0
        land_ice_atmos_boundary%dtaudu=0.0
        land_ice_atmos_boundary%dtaudv=0.0
        land_ice_atmos_boundary%u_star=0.0
        land_ice_atmos_boundary%b_star=0.0
        land_ice_atmos_boundary%q_star=0.0
        land_ice_atmos_boundary%rough_mom=0.01

! allocate fields for extra tracers
! The first call is no longer necessary, the fluxes will be passed by the land module
! The 2nd call is useful in the case of a ocean model only simulation
!
        call coupler_type_copy(ex_gas_fields_atm, Atm%fields, is, ie, js, je,                   &
             mod_name, Atm%axes(1:2), Time, suffix = '_atm')

!Balaji: clocks on atm%pe only        
    cplClock = mpp_clock_id( 'Land-ice-atm coupler', flags=clock_flag_default, grain=CLOCK_COMPONENT )
    sfcClock = mpp_clock_id( 'SFC boundary layer', flags=clock_flag_default, grain=CLOCK_SUBCOMPONENT )
    fluxAtmDnClock = mpp_clock_id( 'Flux DN from atm', flags=clock_flag_default, grain=CLOCK_ROUTINE )
    fluxLandIceClock = mpp_clock_id( 'Flux land to ice', flags=clock_flag_default, grain=CLOCK_ROUTINE )
    regenClock = mpp_clock_id( 'XGrid generation', flags=clock_flag_default, grain=CLOCK_ROUTINE )
    fluxAtmUpClock = mpp_clock_id( 'Flux UP to atm', flags=clock_flag_default, grain=CLOCK_ROUTINE )
    end if

    !--- With the consideration of concurrent and series run. Also make sure pelist is monotonically increasing.
    !--- Here we can not simply call mpp_set_current_pelist() because of ensemble. The ocean_pe(n) 
    !--- should either equal to atmos_pe(n) or greater than atmos%pelist(npes_atm)
    npes_ocn = size(Ocean%pelist(:))
    npes_atm = size(Atm%pelist(:))      
    allocate(pelist(npes_ocn+npes_atm))
    pelist(1:npes_atm) = Atm%pelist(1:npes_atm)
    npes_all = npes_atm
    do n = 1, npes_ocn
       if( n <= npes_atm ) then
          if( Ocean%pelist(n) == Atm%pelist(n) ) cycle
       endif
       if( Ocean%pelist(n) < Atm%pelist(npes_atm) ) call mpp_error( FATAL, &
           'flux_exchange_init: ocean%pelist(n) should equal to atm%pelist(n) or greater than any atmos pes' )
       npes_all = npes_all + 1
       pelist(npes_all) = Ocean%pelist(n)
    enddo

    call mpp_set_current_pelist(pelist(1:npes_all) )
    deallocate(pelist)

!ocean_ice_boundary and ice_ocean_boundary must be done on all PES
!domain boundaries will assure no space is allocated on non-relevant PEs.
    call mpp_get_compute_domain( Ice%domain, is, ie, js, je )
!allocate ocean_ice_boundary
    allocate( ocean_ice_boundary%u(is:ie,js:je) )
    allocate( ocean_ice_boundary%v(is:ie,js:je) )
    allocate( ocean_ice_boundary%t(is:ie,js:je) )
    allocate( ocean_ice_boundary%s(is:ie,js:je) )
!frazil and sea_level are optional, if not present they should be nullified
    allocate( ocean_ice_boundary%frazil(is:ie,js:je) )
    allocate( ocean_ice_boundary%sea_level(is:ie,js:je) )
! initialize boundary fields for override experiments (mjh)
    ocean_ice_boundary%u=0.0
    ocean_ice_boundary%v=0.0
    ocean_ice_boundary%t=273.0
    ocean_ice_boundary%s=0.0
    ocean_ice_boundary%frazil=0.0
    ocean_ice_boundary%sea_level=0.0

!
! allocate fields for extra tracers
! Copying gas flux fields from ice to ocean_ice boundary

    call coupler_type_copy(ex_gas_fields_ice, ocean_ice_boundary%fields, is, ie, js, je,        &
         'ice_flux', Ice%axes(1:2), Time, suffix = '_ocn_ice')

!allocate ice_ocean_boundary
    call mpp_get_compute_domain( Ocean%domain, is, ie, js, je )
!ML ocean only requires t, q, lw, sw, fprec, calving
!AMIP ocean needs no input fields
!choice of fields will eventually be done at runtime
!via field_manager
    allocate( ice_ocean_boundary%u_flux   (is:ie,js:je) )
    allocate( ice_ocean_boundary%v_flux   (is:ie,js:je) )
    allocate( ice_ocean_boundary%t_flux   (is:ie,js:je) )
    allocate( ice_ocean_boundary%q_flux   (is:ie,js:je) )
    allocate( ice_ocean_boundary%salt_flux(is:ie,js:je) )
    allocate( ice_ocean_boundary%lw_flux  (is:ie,js:je) )
    allocate( ice_ocean_boundary%sw_flux_vis_dir  (is:ie,js:je) )
    allocate( ice_ocean_boundary%sw_flux_vis_dif  (is:ie,js:je) )
    allocate( ice_ocean_boundary%sw_flux_nir_dir  (is:ie,js:je) )
    allocate( ice_ocean_boundary%sw_flux_nir_dif  (is:ie,js:je) )
    allocate( ice_ocean_boundary%lprec    (is:ie,js:je) )
    allocate( ice_ocean_boundary%fprec    (is:ie,js:je) )
    allocate( ice_ocean_boundary%runoff   (is:ie,js:je) )
    allocate( ice_ocean_boundary%calving  (is:ie,js:je) )
    allocate( ice_ocean_boundary%runoff_hflx   (is:ie,js:je) )
    allocate( ice_ocean_boundary%calving_hflx  (is:ie,js:je) )
    allocate( ice_ocean_boundary%p        (is:ie,js:je) )

!
! allocate fields for extra tracers
!

    call coupler_type_copy(ex_gas_fluxes, ice_ocean_boundary%fluxes, is, ie, js, je,    &
         'ocean_flux', Ocean%axes(1:2), Time, suffix = '_ice_ocn')

    call coupler_type_copy(ex_gas_fields_ice, Ocean%fields, is, ie, js, je,             &
         'ocean_flux', Ocean%axes(1:2), Time, suffix = '_ocn')

!pjp Why are the above not initialized to zero?
! initialize boundary values for override experiments
    ocean_ice_boundary%xtype = REDIST
    if( Ocean%domain.EQ.Ice%domain )ocean_ice_boundary%xtype = DIRECT
    ice_ocean_boundary%xtype = ocean_ice_boundary%xtype


!
! allocate fields amd fluxes for extra tracers for the Ice type
!

    call mpp_get_compute_domain( Ice%domain, is, ie, js, je )
    kd = size(Ice%ice_mask,3)
    call coupler_type_copy(ex_gas_fields_ice, Ice%ocean_fields, is, ie, js, je, kd,     &
         'ice_flux', Ice%axes, Time, suffix = '_ice')

    call coupler_type_copy(ex_gas_fluxes, Ice%ocean_fluxes, is, ie, js, je,             &
         'ice_flux', Ice%axes(1:2), Time, suffix = '_ice')

    call coupler_type_copy(ex_gas_fluxes, Ice%ocean_fluxes_top, is, ie, js, je, kd,     &
         'ice_flux', Ice%axes, Time, suffix = '_ice_top')

!       initialize the Ocean type for extra fields for surface fluxes
! Same allocation of arrays and stuff
!       (this must be done after the Ocean fields are allocated as the fields on the Ocean%fields
!       are read in in this subroutine)
!

    if ( Ocean%is_ocean_pe ) then
      call mpp_set_current_pelist(Ocean%pelist)
      call ocean_model_init_sfc(Ocean_state, Ocean)
    end if
    call mpp_set_current_pelist()

    ! required by stock_move, all fluxes used to update stocks will be zero if dt_atmos,
    ! and dt_cpld are absent
    Dt_atm = 0
    Dt_cpl = 0
    if(present(dt_atmos)) Dt_atm = dt_atmos
    if(present(dt_cpld )) Dt_cpl = dt_cpld
 
    !z1l check the flux conservation.
    if(debug_stocks) call check_flux_conservation(Ice, Ocean, Ice_Ocean_Boundary)


!Balaji
    cplOcnClock = mpp_clock_id( 'Ice-ocean coupler', flags=clock_flag_default, grain=CLOCK_COMPONENT )
    fluxIceOceanClock = mpp_clock_id( 'Flux ice to ocean', flags=clock_flag_default, grain=CLOCK_ROUTINE )
    fluxOceanIceClock = mpp_clock_id( 'Flux ocean to ice', flags=clock_flag_default, grain=CLOCK_ROUTINE )
!---- done ----
    do_init = .false.

  end subroutine flux_exchange_init
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="sfc_boundary_layer">
!  <OVERVIEW>
!   Computes explicit fluxes as well as derivatives that will be used to compute an implicit flux correction. 
!  </OVERVIEW>
!  <DESCRIPTION>
!  <PRE>
!  The following quantities in the land_ice_atmos_boundary_type are computed:
!
!     
!         t_surf_atm = surface temperature (used for radiation)    (K)
!         albedo_atm = surface albedo      (used for radiation)    (nondimensional)
!      rough_mom_atm = surface roughness for momentum (m)
!      land_frac_atm = fractional area of land beneath an atmospheric
!                      grid box 
!         dtaudu_atm, dtaudv_atm = derivatives of wind stress w.r.t. the
!                      lowest level wind speed  (Pa/(m/s))
!         flux_u_atm = zonal wind stress  (Pa)
!         flux_v_atm = meridional wind stress (Pa)
!         u_star_atm = friction velocity (m/s)
!         b_star_atm = buoyancy scale    (m2/s)
!
!         (u_star and b_star are defined so that u_star**2 = magnitude
!           of surface stress divided by density of air at the surface, 
!           and u_star*b_star = buoyancy flux at the surface)
!
!   </PRE>
!  </DESCRIPTION>

!  <TEMPLATE>
!   call sfc_boundary_layer ( dt, Time, Atm, Land, Ice, Boundary )
!		
!  </TEMPLATE>
!  <IN NAME=" dt" TYPE="real">
!   time step. 
!  </IN>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <INOUT NAME="Atm" TYPE="atmos_data_type">
!   A derived data type to specify atmosphere boundary data.
!  </INOUT>
!  <INOUT NAME="Land" TYPE="land_data_type">
!   A derived data type to specify land boundary data.
!  </INOUT>
!  <INOUT NAME="Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </INOUT>
!  <INOUT NAME="Boundary" TYPE="land_ice_atmos_boundary_type">
!   A derived data type to specify properties and fluxes passed from exchange grid to
!   the atmosphere, land and ice.   
!  </INOUT>
!
subroutine sfc_boundary_layer ( dt, Time, Atm, Land, Ice, Land_Ice_Atmos_Boundary )

  real,                  intent(in)  :: dt
  type(time_type),       intent(in)  :: Time
  type(atmos_data_type), intent(inout)  :: Atm
  type(land_data_type),  intent(inout)  :: Land
  type(ice_data_type),   intent(inout)  :: Ice
  type(land_ice_atmos_boundary_type), intent(inout) :: Land_Ice_Atmos_Boundary

  ! ---- local vars ----------------------------------------------------------
  real, dimension(n_xgrid_sfc) :: &
       ex_albedo,     &
       ex_albedo_vis_dir,     &
       ex_albedo_nir_dir,     &
       ex_albedo_vis_dif,     &
       ex_albedo_nir_dif,     &
       ex_land_frac,  &
       ex_t_atm,      & 
       ex_p_atm,      &
       ex_u_atm, ex_v_atm,    &
       ex_gust,       &
       ex_t_surf4,    &
       ex_u_surf, ex_v_surf,  &
       ex_rough_mom, ex_rough_heat, ex_rough_moist, &
       ex_rough_scale,&
       ex_q_star,     &
       ex_cd_q,       &
       ex_ref, ex_ref_u, ex_ref_v, ex_u10, &
       ex_ref2,       &
       ex_t_ref,      &
       ex_qs_ref,     &
       ex_qs_ref_cmip,     &
       ex_del_m,      &
       ex_del_h,      &
       ex_del_q,      &
       ex_seawater,   &
       ex_sst

  real, dimension(n_xgrid_sfc,n_exch_tr) :: ex_tr_atm
! jgj: added for co2_atm diagnostic
  real, dimension(n_xgrid_sfc)           :: ex_co2_atm_dvmr
  real, dimension(size(Land_Ice_Atmos_Boundary%t,1),size(Land_Ice_Atmos_Boundary%t,2)) :: diag_atm
  real, dimension(size(Land_Ice_Atmos_Boundary%t,1),size(Land_Ice_Atmos_Boundary%t,2)) :: frac_seawater
  real, dimension(size(Land%t_ca, 1),size(Land%t_ca,2), size(Land%t_ca,3)) :: diag_land
  real, dimension(size(Ice%t_surf,1),size(Ice%t_surf,2),size(Ice%t_surf,3)) :: sea
  real    :: zrefm, zrefh
  logical :: used
  character(32) :: tr_name ! tracer name
  integer :: tr, n, m ! tracer indices
  integer :: i, ind_flux = 1

  ! [1] check that the module was initialized
!   <ERROR MSG="must call flux_exchange_init first " STATUS="FATAL">
!      flux_exchange_init has not been called before calling sfc_boundary_layer.
!   </ERROR>
  if (do_init) call error_mesg ('flux_exchange_mod',  &
       'must call flux_exchange_init first', FATAL)
!Balaji
  call mpp_clock_begin(cplClock)
  call mpp_clock_begin(sfcClock)
  ! [2] allocate storage for variables that are also used in flux_up_to_atmos
  allocate ( &
       ex_t_surf   (n_xgrid_sfc),  &
       ex_t_surf_miz(n_xgrid_sfc), &
       ex_p_surf   (n_xgrid_sfc),  &
       ex_slp      (n_xgrid_sfc),  &
       ex_t_ca     (n_xgrid_sfc),  &
       ex_dhdt_surf(n_xgrid_sfc),  &
       ex_dedt_surf(n_xgrid_sfc),  &
       ex_dqsatdt_surf(n_xgrid_sfc),  &
       ex_drdt_surf(n_xgrid_sfc),  &
       ex_dhdt_atm (n_xgrid_sfc),  &
       ex_flux_t   (n_xgrid_sfc),  &
       ex_flux_lw  (n_xgrid_sfc),  &
       ex_drag_q   (n_xgrid_sfc),  &
       ex_avail    (n_xgrid_sfc),  &
       ex_f_t_delt_n(n_xgrid_sfc), &

       ex_tr_surf     (n_xgrid_sfc, n_exch_tr), &
       ex_dfdtr_surf  (n_xgrid_sfc, n_exch_tr), &
       ex_dfdtr_atm   (n_xgrid_sfc, n_exch_tr), &
       ex_flux_tr     (n_xgrid_sfc, n_exch_tr), &
       ex_f_tr_delt_n (n_xgrid_sfc, n_exch_tr), &
       ex_e_tr_n      (n_xgrid_sfc, n_exch_tr), &

! MOD these were moved from local ! so they can be passed to flux down
       ex_flux_u(n_xgrid_sfc),    &
       ex_flux_v(n_xgrid_sfc),    &
       ex_dtaudu_atm(n_xgrid_sfc),&
       ex_dtaudv_atm(n_xgrid_sfc),&

! values added for LM3
       ex_cd_t     (n_xgrid_sfc),  &
       ex_cd_m     (n_xgrid_sfc),  &
       ex_b_star   (n_xgrid_sfc),  &
       ex_u_star   (n_xgrid_sfc),  &
       ex_wind     (n_xgrid_sfc),  &
       ex_z_atm    (n_xgrid_sfc),  &

       ex_e_t_n    (n_xgrid_sfc),  &
       ex_e_q_n    (n_xgrid_sfc),  &
       ex_land     (n_xgrid_sfc)   )

#ifdef SCM
  allocate ( &
       ex_dhdt_surf_forland(n_xgrid_sfc), &
       ex_dedt_surf_forland(n_xgrid_sfc), &
       ex_dedq_surf_forland(n_xgrid_sfc)  )
#endif

! Actual allocation of exchange fields for ocean_ice boundary
  do n = 1, ex_gas_fields_ice%num_bcs  !{
    do m = 1, ex_gas_fields_ice%bc(n)%num_fields  !{
      if (associated(ex_gas_fields_ice%bc(n)%field(m)%values)) then  !{
        call mpp_error( FATAL, 'sfc_boundary_layer: ex_gas_fields_ice already allocated.' )
      endif  !}
      allocate ( ex_gas_fields_ice%bc(n)%field(m)%values(n_xgrid_sfc) )
      ex_gas_fields_ice%bc(n)%field(m)%values = 0.0
    enddo  !} m
  enddo  !} n

  do n = 1, ex_gas_fields_atm%num_bcs  !{
    do m = 1, ex_gas_fields_atm%bc(n)%num_fields  !{
      if (associated(ex_gas_fields_atm%bc(n)%field(m)%values)) then  !{
        call mpp_error( FATAL, 'sfc_boundary_layer: ex_gas_fields_atm already allocated.' )
      endif  !}
      allocate ( ex_gas_fields_atm%bc(n)%field(m)%values(n_xgrid_sfc) )
      ex_gas_fields_atm%bc(n)%field(m)%values = 0.0
    enddo  !} m
  enddo  !} n

  do n = 1, ex_gas_fluxes%num_bcs  !{
    do m = 1, ex_gas_fluxes%bc(n)%num_fields  !{
      if (associated(ex_gas_fluxes%bc(n)%field(m)%values)) then  !{
        call mpp_error( FATAL, 'sfc_boundary_layer: ex_gas_fluxes already allocated.' )
      endif  !}
      allocate ( ex_gas_fluxes%bc(n)%field(m)%values(n_xgrid_sfc) )
      ex_gas_fluxes%bc(n)%field(m)%values = 0.0
    enddo  !} m
  enddo  !} n

!
!       Call the atmosphere tracer driver to gather the data needed for extra gas tracers
! For ocean only model

!  call atmos_get_fields_for_flux(Atm)

  ! [3] initialize some values on exchange grid: this is actually a safeguard
  ! against using undefined values
  ex_t_surf   = 200.
  ex_u_surf   =   0.
  ex_v_surf   =   0.
  ex_albedo = 0. ! bw 
  ex_albedo_vis_dir = 0.
  ex_albedo_nir_dir = 0.
  ex_albedo_vis_dif = 0.
  ex_albedo_nir_dif = 0.

  !---- do not use if relax time /= 0 ----
  ex_cd_t = 0.0
  ex_cd_m = 0.0
  ex_cd_q = 0.0
!-----------------------------------------------------------------------
!Balaji: data_override stuff moved from coupler_main
  call data_override ('ATM', 't_bot',  Atm%t_bot , Time)
  call data_override ('ATM', 'z_bot',  Atm%z_bot , Time)
  call data_override ('ATM', 'p_bot',  Atm%p_bot , Time)
  call data_override ('ATM', 'u_bot',  Atm%u_bot , Time)
  call data_override ('ATM', 'v_bot',  Atm%v_bot , Time)
  call data_override ('ATM', 'p_surf', Atm%p_surf, Time)
  call data_override ('ATM', 'slp',    Atm%slp,    Time)
  call data_override ('ATM', 'gust',   Atm%gust,   Time)
!
! jgj: 2008/07/18 
! FV atm advects tracers in moist mass mixing ratio: kg co2 /(kg air + kg water)
! cubed sphere advects moist mass mixing ratio also (per SJ)
! data table co2 overrides for ocean (co2_flux_pcair_atm)
! and land (co2_bot) should be in dry vmr (mol/mol) units.
!  ATM: co2_flux_pcair_atm : to override atm_btm layer to send to ocean
!  ATM: co2_bot            : to override atm_btm layer to send to land

! data override for co2 to be passed to land/photosynthesis (co2_bot)
! land co2 data override is in dry_vmr units, so convert to wet_mmr for land model.
! co2mmr = (wco2/wair) * co2vmr;  wet_mmr = dry_mmr * (1-Q)
!
  do tr = 1,n_atm_tr
     call get_tracer_names( MODEL_ATMOS, tr, tr_name )
     call data_override('ATM', trim(tr_name)//'_bot', Atm%tr_bot(:,:,tr), Time, override=used)
! conversion for land co2 data override from dry vmr to moist mmr
     if (used .and. lowercase(trim(tr_name)).eq.'co2') then
       Atm%tr_bot(:,:,tr) = Atm%tr_bot(:,:,tr) * (WTMCO2/WTMAIR) *    &
                            (1.0 - Atm%tr_bot(:,:,isphum))
     end if
  enddo
! data override for co2 to be passed to ocean (co2_flux_pcair_atm) 
! atmos_co2.F90 already called: converts tr_bot passed to ocean via gas_flux   
! from moist mmr to dry vmr.
  do n = 1, atm%fields%num_bcs  !{
    do m = 1, atm%fields%bc(n)%num_fields  !{
      call data_override('ATM', atm%fields%bc(n)%field(m)%name,      &
           atm%fields%bc(n)%field(m)%values, Time, override = atm%fields%bc(n)%field(m)%override)
      ex_gas_fields_atm%bc(n)%field(m)%override = atm%fields%bc(n)%field(m)%override
    enddo  !} m
  enddo  !} n
  do n = 1, atm%fields%num_bcs  !{
     if (atm%fields%bc(n)%use_atm_pressure) then  !{
        if (.not. atm%fields%bc(n)%field(ind_psurf)%override) then  !{
           atm%fields%bc(n)%field(ind_psurf)%values = Atm%p_surf
        endif  !}
     endif  !}
  enddo  !} n
  call data_override ('ICE', 't_surf',     Ice%t_surf,      Time)
  call data_override ('ICE', 'rough_mom',  Ice%rough_mom,   Time)
  call data_override ('ICE', 'rough_heat', Ice%rough_heat,  Time)
  call data_override ('ICE', 'rough_moist',Ice%rough_moist, Time)
  call data_override ('ICE', 'albedo',     Ice%albedo,      Time)
  call data_override ('ICE', 'albedo_vis_dir', Ice%albedo_vis_dir, Time)
  call data_override ('ICE', 'albedo_nir_dir', Ice%albedo_nir_dir, Time)
  call data_override ('ICE', 'albedo_vis_dif', Ice%albedo_vis_dif, Time)
  call data_override ('ICE', 'albedo_nir_dif', Ice%albedo_nir_dif, Time)
  call data_override ('ICE', 'u_surf',     Ice%u_surf,      Time)
  call data_override ('ICE', 'v_surf',     Ice%v_surf,      Time)
  call data_override ('LND', 't_surf',     Land%t_surf,     Time)
  call data_override ('LND', 't_ca',       Land%t_ca,       Time)
  call data_override ('LND', 'rough_mom',  Land%rough_mom,  Time)
  call data_override ('LND', 'rough_heat', Land%rough_heat, Time)
  call data_override ('LND', 'albedo', Land%albedo,     Time)

! tracer data override
  do tr = 1, n_lnd_tr
     call get_tracer_names( MODEL_LAND, tr, tr_name )
     call data_override('LND', trim(tr_name)//'_surf', Land%tr(:,:,:,tr), Time)
  enddo
  do n = 1, ice%ocean_fields%num_bcs  !{
    do m = 1, ice%ocean_fields%bc(n)%num_fields  !{
      call data_override('ICE', ice%ocean_fields%bc(n)%field(m)%name, ice%ocean_fields%bc(n)%field(m)%values, Time)
      if ( Ice%ocean_fields%bc(n)%field(m)%id_diag > 0 ) then  !{
        used = send_data(Ice%ocean_fields%bc(n)%field(m)%id_diag, Ice%ocean_fields%bc(n)%field(m)%values, Time )
      endif  !}
    enddo  !} m
  enddo  !} n
  call data_override ('LND', 'albedo_vis_dir', Land%albedo_vis_dir,Time)
  call data_override ('LND', 'albedo_nir_dir', Land%albedo_nir_dir,Time)
  call data_override ('LND', 'albedo_vis_dif', Land%albedo_vis_dif,Time)
  call data_override ('LND', 'albedo_nir_dif', Land%albedo_nir_dif,Time)

!---- put atmosphere quantities onto exchange grid ----

  ! [4] put all the qantities we need onto exchange grid
  ! [4.1] put atmosphere quantities onto exchange grid
  if (do_forecast) then
    call put_to_xgrid (Atm%Surf_diff%sst_miz , 'ATM', ex_t_surf_miz, xmap_sfc, remap_method=remap_method)
  endif
  call put_to_xgrid (Atm%t_bot , 'ATM', ex_t_atm , xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%z_bot , 'ATM', ex_z_atm , xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%p_bot , 'ATM', ex_p_atm , xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%u_bot , 'ATM', ex_u_atm , xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%v_bot , 'ATM', ex_v_atm , xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%p_surf, 'ATM', ex_p_surf, xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%slp,    'ATM', ex_slp,    xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%gust,   'ATM', ex_gust,   xmap_sfc, remap_method=remap_method)

! put atmosphere bottom layer tracer data onto exchange grid
  do tr = 1,n_exch_tr
     call put_to_xgrid (Atm%tr_bot(:,:,tr_table(tr)%atm) , 'ATM', ex_tr_atm(:,tr), xmap_sfc, &
          remap_method=remap_method)
  enddo
  do n = 1, Atm%fields%num_bcs  !{
    do m = 1, Atm%fields%bc(n)%num_fields  !{
      call put_to_xgrid (Atm%fields%bc(n)%field(m)%values, 'ATM',            &
           ex_gas_fields_atm%bc(n)%field(m)%values, xmap_sfc, remap_method=remap_method)
    enddo  !} m
  enddo  !} n
  ! slm, Mar 20 2002: changed order in whith the data transferred from ice and land 
  ! grids, to fill t_ca first with t_surf over ocean and then with t_ca from 
  ! land, where it is different from t_surf. It is mostly to simplify 
  ! diagnostic, since surface_flux calculations distinguish between land and 
  ! not-land anyway.

  ! prefill surface values with atmospheric values before putting tracers
  ! from ice or land, so that gradient is 0 if tracers are not filled
  ex_tr_surf = ex_tr_atm

  ! [4.2] put ice quantities onto exchange grid
  ! (assume that ocean quantites are stored in no ice partition)
  ! (note: ex_avail is true at ice and ocean points)
  call put_to_xgrid (Ice%t_surf,      'OCN', ex_t_surf,      xmap_sfc)
  call put_to_xgrid (Ice%rough_mom,   'OCN', ex_rough_mom,   xmap_sfc)
  call put_to_xgrid (Ice%rough_heat,  'OCN', ex_rough_heat,  xmap_sfc)
  call put_to_xgrid (Ice%rough_moist, 'OCN', ex_rough_moist, xmap_sfc)
  call put_to_xgrid (Ice%albedo,      'OCN', ex_albedo,      xmap_sfc)
  call put_to_xgrid (Ice%albedo_vis_dir, 'OCN', ex_albedo_vis_dir, xmap_sfc)
  call put_to_xgrid (Ice%albedo_nir_dir, 'OCN', ex_albedo_nir_dir, xmap_sfc)
  call put_to_xgrid (Ice%albedo_vis_dif, 'OCN', ex_albedo_vis_dif, xmap_sfc)
  call put_to_xgrid (Ice%albedo_nir_dif, 'OCN', ex_albedo_nir_dif, xmap_sfc)
  call put_to_xgrid (Ice%u_surf,      'OCN', ex_u_surf,      xmap_sfc)
  call put_to_xgrid (Ice%v_surf,      'OCN', ex_v_surf,      xmap_sfc)

  do n = 1, ice%ocean_fields%num_bcs  !{
    do m = 1, ice%ocean_fields%bc(n)%num_fields  !{
      call put_to_xgrid (Ice%ocean_fields%bc(n)%field(m)%values, 'OCN',      &
           ex_gas_fields_ice%bc(n)%field(m)%values, xmap_sfc)
    enddo  !} m
  enddo  !} n
  sea = 0.0; sea(:,:,1) = 1.0;
  ex_seawater = 0.0
  call put_to_xgrid (sea,             'OCN', ex_seawater,    xmap_sfc)
  ex_t_ca = ex_t_surf ! slm, Mar 20 2002 to define values over the ocean

  ! [4.3] put land quantities onto exchange grid ----
  call some(xmap_sfc, ex_land, 'LND')
  if (do_forecast) then
    call put_to_xgrid (Land%t_surf,     'LND', ex_t_surf_miz,  xmap_sfc)
    ex_t_ca(:) = ex_t_surf_miz(:)
  end if

  call put_to_xgrid (Land%t_surf,     'LND', ex_t_surf,      xmap_sfc)
  call put_to_xgrid (Land%t_ca,       'LND', ex_t_ca,        xmap_sfc)
  call put_to_xgrid (Land%rough_mom,  'LND', ex_rough_mom,   xmap_sfc)
  call put_to_xgrid (Land%rough_heat, 'LND', ex_rough_heat,  xmap_sfc)
  call put_to_xgrid (Land%rough_heat, 'LND', ex_rough_moist, xmap_sfc)
  call put_to_xgrid (Land%albedo,     'LND', ex_albedo,      xmap_sfc)
  call put_to_xgrid (Land%albedo_vis_dir,     'LND', ex_albedo_vis_dir,   xmap_sfc)
  call put_to_xgrid (Land%albedo_nir_dir,     'LND', ex_albedo_nir_dir,   xmap_sfc)
  call put_to_xgrid (Land%albedo_vis_dif,     'LND', ex_albedo_vis_dif,   xmap_sfc)
  call put_to_xgrid (Land%albedo_nir_dif,     'LND', ex_albedo_nir_dif,   xmap_sfc)
  ex_rough_scale = ex_rough_mom
  call put_to_xgrid(Land%rough_scale, 'LND', ex_rough_scale, xmap_sfc)
 
  do tr = 1,n_exch_tr
     n = tr_table(tr)%lnd
     if(n /= NO_TRACER ) then
        call put_to_xgrid ( Land%tr(:,:,:,n), 'LND', ex_tr_surf(:,tr), xmap_sfc )
     else
        ! do nothing, since ex_tr_surf is prefilled with ex_tr_atm, and therefore
        ! fluxes will be 0
     endif
  enddo

  ex_land_frac = 0.0
  call put_logical_to_real (Land%mask,    'LND', ex_land_frac, xmap_sfc)

#ifdef SCM
  if (do_specified_land) then
       if (do_specified_albedo) then
            ex_albedo = ALBEDO_OBS
            ex_albedo_vis_dir = ALBEDO_OBS
            ex_albedo_nir_dir = ALBEDO_OBS
            ex_albedo_vis_dif = ALBEDO_OBS
            ex_albedo_nir_dif = ALBEDO_OBS
       endif
       if (do_specified_tskin) then
            ex_t_surf = TSKIN
            ex_t_ca   = TSKIN
            ex_tr_surf(:,isphum) = 15.e-3
       endif
       if (do_specified_rough_leng) then
            ex_rough_mom   = ROUGH_MOM
            ex_rough_heat  = ROUGH_HEAT
            ex_rough_moist = ROUGH_HEAT
       endif
  endif
#endif

  if (do_forecast) then
     ex_t_surf = ex_t_surf_miz
  end if

  ! [5] compute explicit fluxes and tendencies at all available points ---
  call some(xmap_sfc, ex_avail)
  call surface_flux (&
       ex_t_atm, ex_tr_atm(:,isphum),  ex_u_atm, ex_v_atm,  ex_p_atm,  ex_z_atm,  &
       ex_p_surf,ex_t_surf, ex_t_ca,  ex_tr_surf(:,isphum),                       &
       ex_u_surf, ex_v_surf,                                           &
       ex_rough_mom, ex_rough_heat, ex_rough_moist, ex_rough_scale,    &
       ex_gust,                                                        &
       ex_flux_t, ex_flux_tr(:,isphum), ex_flux_lw, ex_flux_u, ex_flux_v,         &
       ex_cd_m,   ex_cd_t, ex_cd_q,                                    &
       ex_wind,   ex_u_star, ex_b_star, ex_q_star,                     &
       ex_dhdt_surf, ex_dedt_surf, ex_dfdtr_surf(:,isphum),  ex_drdt_surf,        &
       ex_dhdt_atm,  ex_dfdtr_atm(:,isphum),  ex_dtaudu_atm, ex_dtaudv_atm,       &
       dt,                                                             &
       ex_land, ex_seawater .gt. 0,  ex_avail                          )

#ifdef SCM
! Option to override surface fluxes for SCM
  if (do_specified_flux) then

    call scm_surface_flux ( &
       ex_t_atm, ex_tr_atm(:,isphum),  ex_u_atm, ex_v_atm,  ex_p_atm,  ex_z_atm,  &
       ex_p_surf,ex_t_surf, ex_t_ca,  ex_tr_surf(:,isphum),                       &
       ex_u_surf, ex_v_surf,                                                      &
       ex_rough_mom, ex_rough_heat, ex_rough_moist, ex_rough_scale,               &
       ex_gust,                                                                   &
       ex_flux_t, ex_flux_tr(:,isphum), ex_flux_lw, ex_flux_u, ex_flux_v,         &
       ex_cd_m,   ex_cd_t, ex_cd_q,                                               &
       ex_wind,   ex_u_star, ex_b_star, ex_q_star,                                &
       ex_dhdt_surf, ex_dedt_surf, ex_dfdtr_surf(:,isphum),  ex_drdt_surf,        &
       ex_dhdt_atm,  ex_dfdtr_atm(:,isphum),  ex_dtaudu_atm, ex_dtaudv_atm,       &
       dt,                                                                        &
       ex_land, ex_seawater .gt. 0,  ex_avail,                                    &
       ex_dhdt_surf_forland,  ex_dedt_surf_forland,  ex_dedq_surf_forland  )

  endif
#endif

  zrefm = 10.0
  zrefh = z_ref_heat
  !      ---- optimize calculation ----
  call mo_profile ( zrefm, zrefh, ex_z_atm,   ex_rough_mom, &
       ex_rough_heat, ex_rough_moist,          &
       ex_u_star, ex_b_star, ex_q_star,        &
       ex_del_m, ex_del_h, ex_del_q, ex_avail  )
  ex_u10 = 0.
  where (ex_avail)
     ex_ref_u = ex_u_surf + (ex_u_atm-ex_u_surf) * ex_del_m 
     ex_ref_v = ex_v_surf + (ex_v_atm-ex_v_surf) * ex_del_m
     ex_u10 = sqrt(ex_ref_u**2 + ex_ref_v**2)
  endwhere
  do n = 1, ex_gas_fields_atm%num_bcs  !{
     if (atm%fields%bc(n)%use_10m_wind_speed) then  !{
        if (.not. ex_gas_fields_atm%bc(n)%field(ind_u10)%override) then  !{
           ex_gas_fields_atm%bc(n)%field(ind_u10)%values = ex_u10
        endif  !}
     endif  !}
  enddo  !} n
  ! fill derivatives for all tracers
  ! F = C0*u*rho*delta_q, C0*u*rho is the same for all tracers, copy from sphum
  do tr = 1,n_exch_tr
     if (tr==isphum) cycle
     ex_dfdtr_atm  (:,tr) = ex_dfdtr_atm  (:,isphum)
     ex_dfdtr_surf (:,tr) = ex_dfdtr_surf (:,isphum)
     ex_flux_tr    (:,tr) = ex_dfdtr_surf(:,tr)*(ex_tr_surf(:,tr)-ex_tr_atm(:,tr))
  enddo

! Combine explicit ocean flux and implicit land flux of extra flux fields.

  ! Calculate ocean explicit flux here

  call atmos_ocean_fluxes_calc(ex_gas_fields_atm, ex_gas_fields_ice, ex_gas_fluxes, ex_seawater)

  ! The following statement is a concise version of what's following and worth
  ! looking into in the future.
  ! ex_flux_tr(:,itracer) = ex_gas_fluxes%bc(itracer_ocn)%field(ind_flux)%values(:)
  ! where(ex_seawater.gt.0) ex_flux_tr(:,itracer) = F_ocn
  do n = 1, ex_gas_fluxes%num_bcs  !{
    if (ex_gas_fluxes%bc(n)%atm_tr_index .gt. 0) then  !{
      m = tr_table_map(ex_gas_fluxes%bc(n)%atm_tr_index)%exch
      do i = 1, size(ex_seawater(:))  !{
         if (ex_land(i)) cycle  ! over land, don't do anything
         ! on ocean or ice cells, flux is explicit therefore we zero derivatives. 
         ex_dfdtr_atm(i,m)  = 0.0
         ex_dfdtr_surf(i,m) = 0.0
         if (ex_seawater(i)>0) then
            ! jgj: convert to kg co2/m2/sec for atm
            ex_flux_tr(i,m)    = ex_gas_fluxes%bc(n)%field(ind_flux)%values(i) * ex_gas_fluxes%bc(n)%mol_wt * 1.0e-03
         else 
            ex_flux_tr(i,m) = 0.0 ! pure ice exchange cell
        endif  !}
      enddo  !} i
    endif  !}
  enddo  !} n

  ! [5.2] override tracer fluxes and derivatives
  do tr = 1,n_exch_tr
     if( tr_table(tr)%atm == NO_TRACER ) cycle ! it should never happen, though

     call get_tracer_names( MODEL_ATMOS, tr_table(tr)%atm, tr_name )
     ! [5.2.1] override tracer flux. Note that "sea" and "diag_land" are repeatedly used 
     ! as temporary storage for the values we are overriding fluxes and derivative with, 
     ! over ocean and land respectively
     call data_override ( 'LND', 'ex_flux_'//trim(tr_name), diag_land, Time, override=used )
     if(used) call put_to_xgrid ( diag_land, 'LND', ex_flux_tr(:,tr), xmap_sfc )
     call data_override ( 'ICE', 'ex_flux_'//trim(tr_name), sea, Time, override=used )
     if(used) call put_to_xgrid ( sea, 'OCN', ex_flux_tr(:,tr), xmap_sfc )
     ! [5.2.2] override derivative of flux wrt surface concentration
     call data_override ( 'LND', 'ex_dfd'//trim(tr_name)//'_surf', diag_land, Time, override=used )
     if(used) call put_to_xgrid ( diag_land, 'LND', ex_dfdtr_surf(:,tr), xmap_sfc )
     call data_override ( 'ICE', 'ex_dfd'//trim(tr_name)//'_surf', sea, Time, override=used )
     if(used) call put_to_xgrid ( sea, 'OCN', ex_dfdtr_surf(:,tr), xmap_sfc )
     ! [5.2.3] override derivative of flux wrt atmospheric concentration
     call data_override ( 'LND', 'ex_dfd'//trim(tr_name)//'_atm', diag_land, Time, override=used )
     if(used) call put_to_xgrid ( diag_land, 'LND', ex_dfdtr_atm(:,tr), xmap_sfc )
     call data_override ( 'ICE', 'ex_dfd'//trim(tr_name)//'_atm', sea, Time, override=used )
     if(used) call put_to_xgrid ( sea, 'OCN', ex_dfdtr_atm(:,tr), xmap_sfc )
  enddo

  ! [5.3] override flux and derivatives for sensible heat flux
  ! [5.3.1] override flux
  call data_override ( 'LND', 'ex_flux_t', diag_land, Time, override=used )
  if (used) call put_to_xgrid ( diag_land, 'LND', ex_flux_t, xmap_sfc )
  call data_override ( 'ICE', 'ex_flux_t', sea, Time, override=used )
  if (used) call put_to_xgrid ( sea, 'OCN', ex_flux_t, xmap_sfc )
  ! [5.3.2] override derivative of flux wrt near-surface temperature
  call data_override ( 'LND', 'ex_dhdt_surf', diag_land, Time, override=used )
  if (used) call put_to_xgrid ( diag_land, 'LND', ex_dhdt_surf, xmap_sfc )
  call data_override ( 'ICE', 'ex_dhdt_surf', sea, Time, override=used )
  if (used) call put_to_xgrid ( sea, 'OCN', ex_dhdt_surf, xmap_sfc )
  ! [5.3.3] override derivative of flux wrt atmospheric temperature
  call data_override ( 'LND', 'ex_dhdt_atm', diag_land, Time,override=used )
  if (used) call put_to_xgrid ( diag_land, 'LND', ex_dhdt_atm, xmap_sfc )
  call data_override ( 'ICE', 'ex_dhdt_atm', sea, Time, override=used )
  if (used) call put_to_xgrid ( sea, 'OCN', ex_dhdt_atm, xmap_sfc )

  ! NB: names of the override fields are constructed using tracer name and certain 
  ! prefixes / suffixes. For example, for the tracer named "sphum" (specific humidity) they will be:
  ! "ex_flux_sphum", "ex_dfdsphum_surf", and "ex_dfdsphum_atm".
  ! 
  ! For sensible heat flux names are "ex_flux_t", "ex_dhdt_surf", and "ex_dhdt_atm"; 
  ! despite the name those are actually in energy units, W/m2, W/(m2 degK), and
  ! W/(m2 degK) respectively

  where (ex_avail) ex_drag_q = ex_wind*ex_cd_q
  ! [6] get mean quantities on atmosphere grid
  ! [6.1] compute t surf for radiation
  ex_t_surf4 = ex_t_surf ** 4

  ! [6.2] put relevant quantities onto atmospheric boundary
  call get_from_xgrid (Land_Ice_Atmos_Boundary%t,         'ATM', ex_t_surf4  ,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%albedo,    'ATM', ex_albedo   ,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%albedo_vis_dir,    'ATM',   &
                       ex_albedo_vis_dir   ,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%albedo_nir_dir,    'ATM',   &
                       ex_albedo_nir_dir   ,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%albedo_vis_dif,    'ATM',   &
                       ex_albedo_vis_dif   ,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%albedo_nir_dif,    'ATM',   &
                       ex_albedo_nir_dif   ,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%rough_mom, 'ATM', ex_rough_mom,  xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%land_frac, 'ATM', ex_land_frac,  xmap_sfc)

  call get_from_xgrid (Land_Ice_Atmos_Boundary%u_flux,    'ATM', ex_flux_u,     xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%v_flux,    'ATM', ex_flux_v,     xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%dtaudu,    'ATM', ex_dtaudu_atm, xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%dtaudv,    'ATM', ex_dtaudv_atm, xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%u_star,    'ATM', ex_u_star    , xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%b_star,    'ATM', ex_b_star    , xmap_sfc)
  call get_from_xgrid (Land_Ice_Atmos_Boundary%q_star,    'ATM', ex_q_star    , xmap_sfc)

  if (do_forecast) then
     call get_from_xgrid (Ice%t_surf, 'OCN', ex_t_surf,  xmap_sfc)
  end if

  Land_Ice_Atmos_Boundary%t = Land_Ice_Atmos_Boundary%t ** 0.25
!Balaji: data_override calls moved here from coupler_main
  call data_override('ATM', 't',         Land_Ice_Atmos_Boundary%t,         Time)
  call data_override('ATM', 'albedo',    Land_Ice_Atmos_Boundary%albedo,    Time)

  call data_override('ATM', 'albedo_vis_dir',    Land_Ice_Atmos_Boundary%albedo_vis_dir,    Time)
  call data_override('ATM', 'albedo_nir_dir',    Land_Ice_Atmos_Boundary%albedo_nir_dir,    Time)
  call data_override('ATM', 'albedo_vis_dif',    Land_Ice_Atmos_Boundary%albedo_vis_dif,    Time)
  call data_override('ATM', 'albedo_nir_dif',    Land_Ice_Atmos_Boundary%albedo_nir_dif,    Time)
  call data_override('ATM', 'land_frac', Land_Ice_Atmos_Boundary%land_frac, Time)
  call data_override('ATM', 'dt_t',      Land_Ice_Atmos_Boundary%dt_t,      Time)
  do tr=1,n_atm_tr
     call get_tracer_names(MODEL_ATMOS, tr, tr_name)
     call data_override('ATM', 'dt_'//trim(tr_name), Land_Ice_Atmos_Boundary%dt_tr(:,:,tr), Time)
  enddo
  call data_override('ATM', 'u_flux',    Land_Ice_Atmos_Boundary%u_flux,    Time)
  call data_override('ATM', 'v_flux',    Land_Ice_Atmos_Boundary%v_flux,    Time)
  call data_override('ATM', 'dtaudu',    Land_Ice_Atmos_Boundary%dtaudu,    Time)
  call data_override('ATM', 'dtaudv',    Land_Ice_Atmos_Boundary%dtaudv,    Time)
  call data_override('ATM', 'u_star',    Land_Ice_Atmos_Boundary%u_star,    Time)
  call data_override('ATM', 'b_star',    Land_Ice_Atmos_Boundary%b_star,    Time)
! call data_override('ATM', 'q_star',    Land_Ice_Atmos_Boundary%q_star,    Time)
  call data_override('ATM', 'rough_mom', Land_Ice_Atmos_Boundary%rough_mom, Time)

  ! [6.3] save atmos albedo fix and old albedo (for downward SW flux calculations)
  ! on exchange grid
  ! allocate ( ex_old_albedo(n_xgrid_sfc)  )
  ! ex_old_albedo = ex_albedo
  
!!  STILL NEEDED   ????
!! IS THIS CORRECT ??
  allocate ( ex_albedo_fix(n_xgrid_sfc) )
  ex_albedo_fix = 0.
  call put_to_xgrid (Land_Ice_Atmos_Boundary%albedo, 'ATM',  ex_albedo_fix, xmap_sfc)
  ex_albedo_fix = (1.0-ex_albedo) / (1.0-ex_albedo_fix)

  allocate ( ex_albedo_vis_dir_fix(n_xgrid_sfc) )
  ex_albedo_vis_dir_fix = 0.
  call put_to_xgrid (Land_Ice_Atmos_Boundary%albedo_vis_dir, 'ATM',  &
           ex_albedo_vis_dir_fix, xmap_sfc)
  ex_albedo_vis_dir_fix = (1.0-ex_albedo_vis_dir) /  &
(1.0-ex_albedo_vis_dir_fix)
  allocate ( ex_albedo_nir_dir_fix(n_xgrid_sfc) )
  ex_albedo_nir_dir_fix = 0.
  call put_to_xgrid (Land_Ice_Atmos_Boundary%albedo_nir_dir, 'ATM', &
 ex_albedo_nir_dir_fix, xmap_sfc)
  ex_albedo_nir_dir_fix = (1.0-ex_albedo_nir_dir) /  &
(1.0-ex_albedo_nir_dir_fix)
  allocate ( ex_albedo_vis_dif_fix(n_xgrid_sfc) )
  ex_albedo_vis_dif_fix = 0.
  call put_to_xgrid (Land_Ice_Atmos_Boundary%albedo_vis_dif, 'ATM',   &
        ex_albedo_vis_dif_fix, xmap_sfc)
   ex_albedo_vis_dif_fix = (1.0-ex_albedo_vis_dif) /   &
       (1.0-ex_albedo_vis_dif_fix)
  allocate ( ex_albedo_nir_dif_fix(n_xgrid_sfc) )
  ex_albedo_nir_dif_fix = 0.
  call put_to_xgrid (Land_Ice_Atmos_Boundary%albedo_nir_dif, 'ATM',  &
 ex_albedo_nir_dif_fix, xmap_sfc)
  ex_albedo_nir_dif_fix = (1.0-ex_albedo_nir_dif) /   &
       (1.0-ex_albedo_nir_dif_fix)

#ifdef SCM
  if (do_specified_albedo .and. do_specified_land) then
       ex_albedo_fix = 1.
       ex_albedo_vis_dir_fix = 1.
       ex_albedo_vis_dif_fix = 1.
       ex_albedo_nir_dir_fix = 1.
       ex_albedo_nir_dif_fix = 1.
  endif
#endif

  !=======================================================================
  ! [7] diagnostics section

  !------- save static fields first time only ------
  if (first_static) then

     !------- land fraction ------
     if ( id_land_mask > 0 ) then
        used = send_data ( id_land_mask, Land_Ice_Atmos_Boundary%land_frac, Time )
     endif

     first_static = .false.
  endif

  !------- Atm fields -----------
  do n = 1, Atm%fields%num_bcs  !{
    do m = 1, Atm%fields%bc(n)%num_fields  !{
      if ( Atm%fields%bc(n)%field(m)%id_diag > 0 ) then  !{
        if (atm%fields%bc(n)%use_10m_wind_speed .and. m .eq. ind_u10 .and. .not. Atm%fields%bc(n)%field(m)%override) then  !{
          call get_from_xgrid (Atm%fields%bc(n)%field(m)%values, 'ATM',     &
               ex_gas_fields_atm%bc(n)%field(m)%values, xmap_sfc)
        endif  !}
        if ( Atm%fields%bc(n)%field(m)%id_diag > 0 ) then  !{
           used = send_data(Atm%fields%bc(n)%field(m)%id_diag, Atm%fields%bc(n)%field(m)%values, Time )
        endif  !}
      endif  !}
    enddo  !} m
  enddo  !} n

  !------- drag coeff moisture -----------
  if ( id_wind > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_wind, xmap_sfc)
     used = send_data ( id_wind, diag_atm, Time )
  endif
  !------- drag coeff moisture -----------
  if ( id_drag_moist > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_cd_q, xmap_sfc)
     used = send_data ( id_drag_moist, diag_atm, Time )
  endif

  !------- drag coeff heat -----------
  if ( id_drag_heat > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_cd_t, xmap_sfc)
     used = send_data ( id_drag_heat, diag_atm, Time )
  endif
  
  !------- drag coeff momemtum -----------
  if ( id_drag_mom > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_cd_m, xmap_sfc)
     used = send_data ( id_drag_mom, diag_atm, Time )
  endif
  
  !------- roughness moisture -----------
  if ( id_rough_moist > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_rough_moist, xmap_sfc)
     used = send_data ( id_rough_moist, diag_atm, Time )
  endif
  
  !------- roughness heat -----------
  if ( id_rough_heat > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_rough_heat, xmap_sfc)
     used = send_data ( id_rough_heat, diag_atm, Time )
  endif
  
  !------- roughness momemtum -----------
  used = send_data ( id_rough_mom, Land_Ice_Atmos_Boundary%rough_mom, Time )
  
  !------- friction velocity -----------
  used = send_data ( id_u_star, Land_Ice_Atmos_Boundary%u_star, Time )
  
  !------- bouyancy -----------
  used = send_data ( id_b_star, Land_Ice_Atmos_Boundary%b_star, Time )

  !------- moisture scale -----------
  used = send_data ( id_q_star, Land_Ice_Atmos_Boundary%q_star, Time )

  !-----------------------------------------------------------------------
  !------ diagnostics for fields at bottom atmospheric level ------
  
  if ( id_t_atm > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_t_atm, xmap_sfc)
     used = send_data ( id_t_atm, diag_atm, Time )
  endif
  
  if ( id_u_atm > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_u_atm, xmap_sfc)
     used = send_data ( id_u_atm, diag_atm, Time )
  endif
  
  if ( id_v_atm > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_v_atm, xmap_sfc)
     used = send_data ( id_v_atm, diag_atm, Time )
  endif

  do tr = 1,n_exch_tr
     call get_tracer_names( MODEL_ATMOS, tr_table(tr)%atm, tr_name )
     if ( id_tr_atm(tr) > 0 ) then
        call get_from_xgrid (diag_atm, 'ATM', ex_tr_atm(:,tr), xmap_sfc)
        used = send_data ( id_tr_atm(tr), diag_atm, Time )
     endif
!!jgj: add dryvmr co2_atm
! - slm Mar 25 2010: moved to resolve interdependence of diagnostic fields
     if ( id_co2_atm_dvmr > 0 .and. lowercase(trim(tr_name))=='co2') then
        ex_co2_atm_dvmr = (ex_tr_atm(:,tr) / (1.0 - ex_tr_atm(:,isphum))) * WTMAIR/WTMCO2
        call get_from_xgrid (diag_atm, 'ATM', ex_co2_atm_dvmr, xmap_sfc)
        used = send_data ( id_co2_atm_dvmr, diag_atm, Time )
     endif
  enddo

  ! - slm, Mar 25, 2002
  if ( id_p_atm > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_p_atm, xmap_sfc)
     used = send_data ( id_p_atm, diag_atm, Time )
  endif
  if ( id_z_atm > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_z_atm, xmap_sfc)
     used = send_data ( id_z_atm, diag_atm, Time )
  endif
  if ( id_gust > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_gust, xmap_sfc)
     used = send_data ( id_gust, diag_atm, Time )
  endif

  ! - bw, Sep 17, 2007
  if ( id_slp > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_slp, xmap_sfc)
     used = send_data ( id_slp, diag_atm, Time )
  endif

  !-----------------------------------------------------------------------
  !--------- diagnostics for fields at reference level ---------
  
  if ( id_t_ref > 0 .or. id_rh_ref > 0 .or. &
       id_u_ref > 0 .or. id_v_ref  > 0 .or. id_wind_ref > 0 .or. &
       id_q_ref > 0 .or. id_q_ref_land > 0 .or. &
       id_t_ref_land > 0 .or. id_rh_ref_land > 0 .or. &
       id_rh_ref_cmip >0 .or. &
       id_u_ref_land > 0 .or. id_v_ref_land  > 0 ) then
     
     zrefm = z_ref_mom
     zrefh = z_ref_heat
     !      ---- optimize calculation ----
     if ( id_t_ref <= 0 ) zrefh = zrefm
     
     call mo_profile ( zrefm, zrefh, ex_z_atm,   ex_rough_mom, &
          ex_rough_heat, ex_rough_moist,          &
          ex_u_star, ex_b_star, ex_q_star,        &
          ex_del_m, ex_del_h, ex_del_q, ex_avail  )

     !    ------- reference relative humidity -----------
     if ( id_rh_ref > 0 .or. id_rh_ref_land > 0 .or. &
          id_rh_ref_cmip > 0 .or. &
          id_q_ref > 0 .or. id_q_ref_land >0 ) then
        ex_ref = 1.0e-06
        where (ex_avail) &
           ex_ref   = ex_tr_surf(:,isphum) + (ex_tr_atm(:,isphum)-ex_tr_surf(:,isphum)) * ex_del_q
        if(id_q_ref > 0) then
           call get_from_xgrid (diag_atm, 'ATM', ex_ref, xmap_sfc)
           used = send_data(id_q_ref,diag_atm,Time)
        endif
        if(id_q_ref_land > 0) then
           call get_from_xgrid (diag_land, 'LND', ex_ref, xmap_sfc)
           used = send_tile_averaged_data(id_q_ref_land, diag_land, &
                Land%tile_size, Time, mask=Land%mask)
        endif
        ex_t_ref = 200.
        where (ex_avail) &
           ex_t_ref = ex_t_ca + (ex_t_atm-ex_t_ca) * ex_del_h
        call compute_qs (ex_t_ref, ex_p_surf, ex_qs_ref, q = ex_ref)
        call compute_qs (ex_t_ref, ex_p_surf, ex_qs_ref_cmip,  &
                         q = ex_ref, es_over_liq_and_ice = .true.)
        where (ex_avail) 
! remove cap on relative humidity -- this mod requested by cjg, ljd
!RSH       ex_ref    = MIN(100.,100.*ex_ref/ex_qs_ref)
           ex_ref2   = 100.*ex_ref/ex_qs_ref_cmip
           ex_ref    = 100.*ex_ref/ex_qs_ref
        endwhere

        if ( id_rh_ref_land > 0 ) then
           call get_from_xgrid (diag_land,'LND', ex_ref, xmap_sfc)
           used = send_tile_averaged_data ( id_rh_ref_land, diag_land, &
                Land%tile_size, Time, mask = Land%mask )
        endif
        if(id_rh_ref > 0) then
           call get_from_xgrid (diag_atm, 'ATM', ex_ref, xmap_sfc)
           used = send_data ( id_rh_ref, diag_atm, Time )
        endif
        if(id_rh_ref_cmip > 0) then
           call get_from_xgrid (diag_atm, 'ATM', ex_ref2, xmap_sfc)
           used = send_data ( id_rh_ref_cmip, diag_atm, Time )
        endif
     endif

     !    ------- reference temp -----------
     if ( id_t_ref > 0 .or. id_t_ref_land > 0 ) then
        where (ex_avail) &
           ex_ref = ex_t_ca + (ex_t_atm-ex_t_ca) * ex_del_h
        if (id_t_ref_land > 0) then
           call get_from_xgrid (diag_land, 'LND', ex_ref, xmap_sfc)
           used = send_tile_averaged_data ( id_t_ref_land, diag_land, &
                Land%tile_size, Time, mask = Land%mask )
        endif
        if ( id_t_ref > 0 ) then
           call get_from_xgrid (diag_atm, 'ATM', ex_ref, xmap_sfc)
           used = send_data ( id_t_ref, diag_atm, Time )
        endif
     endif

     !    ------- reference u comp -----------
     if ( id_u_ref > 0 .or. id_u_ref_land > 0) then
        where (ex_avail) &
           ex_ref = ex_u_surf + (ex_u_atm-ex_u_surf) * ex_del_m
        if ( id_u_ref_land > 0 ) then
           call get_from_xgrid ( diag_land, 'LND', ex_ref, xmap_sfc )
           used = send_tile_averaged_data ( id_u_ref_land, diag_land, &
                Land%tile_size, Time, mask = Land%mask )
        endif
        if ( id_u_ref > 0 ) then
           call get_from_xgrid (diag_atm, 'ATM', ex_ref, xmap_sfc)
           used = send_data ( id_u_ref, diag_atm, Time )
        endif
     endif

     !    ------- reference v comp -----------
     if ( id_v_ref > 0 .or. id_v_ref_land > 0 ) then
        where (ex_avail) &
           ex_ref = ex_v_surf + (ex_v_atm-ex_v_surf) * ex_del_m
        if ( id_v_ref_land > 0 ) then
           call get_from_xgrid ( diag_land, 'LND', ex_ref, xmap_sfc )
           used = send_tile_averaged_data ( id_v_ref_land, diag_land, &
                Land%tile_size, Time, mask = Land%mask )
        endif
        if ( id_v_ref > 0 ) then
           call get_from_xgrid (diag_atm, 'ATM', ex_ref, xmap_sfc)
           used = send_data ( id_v_ref, diag_atm, Time )
        endif
     endif

     !    ------- reference-level absolute wind -----------
     if ( id_wind_ref > 0 ) then
        where (ex_avail) &
           ex_ref = sqrt((ex_u_surf + (ex_u_atm-ex_u_surf) * ex_del_m)**2 &
                        +(ex_v_surf + (ex_v_atm-ex_v_surf) * ex_del_m)**2)
        call get_from_xgrid (diag_atm, 'ATM', ex_ref, xmap_sfc)
        used = send_data ( id_wind_ref, diag_atm, Time )
     endif

     !    ------- interp factor for heat ------
     if ( id_del_h > 0 ) then
        call get_from_xgrid (diag_atm, 'ATM', ex_del_h, xmap_sfc)
        used = send_data ( id_del_h, diag_atm, Time )
     endif

     !    ------- interp factor for momentum ------
     if ( id_del_m > 0 ) then
        call get_from_xgrid (diag_atm, 'ATM', ex_del_m, xmap_sfc)
        used = send_data ( id_del_m, diag_atm, Time )
     endif

     !    ------- interp factor for moisture ------
     if ( id_del_q > 0 ) then
        call get_from_xgrid (diag_atm, 'ATM', ex_del_q, xmap_sfc)
        used = send_data ( id_del_q, diag_atm, Time )
     endif

  endif
  ! topographic roughness scale
  if(id_rough_scale>0) then
     call get_from_xgrid (diag_atm, 'ATM',&
          (log(ex_z_atm/ex_rough_mom+1)/log(ex_z_atm/ex_rough_scale+1))**2, xmap_sfc)
     used = send_data(id_rough_scale, diag_atm, Time)
  endif

  ! sst on the atmospheric grid
  if (id_sst > 0) then
      ex_sst = 0.0
      sea(:,:,1) = Ice%t_surf(:,:,1)  ! ocean water temperature
      sea(:,:,2:) = 0.0               ! mask sea-ice
      call put_to_xgrid (sea, 'OCN', ex_sst, xmap_sfc)
      call get_from_xgrid (diag_atm, 'ATM', ex_sst, xmap_sfc)
      ! also need open ocean fraction (ex_seawater defined above)
      call get_from_xgrid (frac_seawater, 'ATM', ex_seawater, xmap_sfc)

      where (frac_seawater > 0.0)
         diag_atm = diag_atm/frac_seawater
         frac_seawater = 1.0
      elsewhere
         diag_atm = 0.0 ! missing value inserted over land and 100% sea-ice
         frac_seawater = 0.0
      endwhere

      used = send_data ( id_sst, diag_atm, Time, rmask=frac_seawater )
  endif

!Balaji
  call mpp_clock_end(sfcClock)
  call mpp_clock_end(cplClock)

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

end subroutine sfc_boundary_layer
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="flux_down_from_atmos">
!  <OVERVIEW>
!   Returns fluxes and derivatives corrected for the implicit treatment of atmospheric 
!   diffusive fluxes, as well as the increments in the temperature and specific humidity 
!   of the lowest atmospheric layer due to all explicit processes as well as the diffusive 
!   fluxes through the top of this layer. 
!  </OVERVIEW>
!  <DESCRIPTION>
!  <PRE>
!    The following elements from Atmos_boundary are used as input: 
!
!        flux_u_atm = zonal wind stress (Pa)  
!        flux_v_atm = meridional wind stress (Pa)
!
!
!    The following elements of Land_boundary are output: 
!
!       flux_t_land = sensible heat flux (W/m2)
!       flux_q_land = specific humidity flux (Kg/(m2 s)
!      flux_lw_land = net longwave flux (W/m2), uncorrected for
!                     changes in surface temperature
!      flux_sw_land = net shortwave flux (W/m2)
!         dhdt_land = derivative of sensible heat flux w.r.t.
!                     surface temperature (on land model grid)  (W/(m2 K)
!         dedt_land = derivative of specific humidity flux w.r.t.
!                     surface temperature (on land model grid)  (Kg/(m2 s K)
!         drdt_land = derivative of upward longwave flux w.r.t.
!                     surface temperature (on land model grid) (W/(m2 K)
!        lprec_land = liquid precipitation, mass for one time step
!                      (Kg/m2)
!        fprec_land = frozen precipitation, mass for one time step
!                      (Kg/m2)
!
!
!    The following elements of Ice_boundary are output: 
!
!        flux_u_ice = zonal wind stress (Pa)
!        flux_v_ice = meridional wind stress (Pa)
!        coszen_ice = cosine of the zenith angle
!
!   </PRE>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_down_from_atmos (Time, Atm, Land, Ice, &
!		Atmos_boundary, Land_boundary, Ice_boundary )
!		
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <INOUT NAME="Atm" TYPE="atmos_data_type">
!   A derived data type to specify atmosphere boundary data.
!  </INOUT>
!  <IN NAME="Land" TYPE="land_data_type">
!   A derived data type to specify land boundary data.
!  </IN>
!  <IN NAME="Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </IN>
!  <IN NAME="Atmos_boundary" TYPE="land_ice_atmos_boundary_type">
!   A derived data type to specify properties and fluxes passed from exchange grid to
!   the atmosphere, land and ice.
!  </IN>
!  <INOUT NAME="Land_boundary" TYPE="atmos_land_boundary_type">
!   A derived data type to specify properties and fluxes passed from atmosphere to land.
!  </INOUT>
!  <INOUT NAME="Ice_boundary" TYPE="atmos_ice_boundary_type">
!   A derived data type to specify properties and fluxes passed from atmosphere to ice.
!  </INOUT>
!
subroutine flux_down_from_atmos (Time, Atm, Land, Ice, &
     Atmos_boundary, Land_boundary, Ice_boundary )

  type(time_type),       intent(in) :: Time
  type(atmos_data_type), intent(inout) :: Atm
  type(land_data_type),  intent(in) :: Land
  type(ice_data_type),   intent(in) :: Ice
  type(land_ice_atmos_boundary_type),intent(in) :: Atmos_boundary
  type(atmos_land_boundary_type),    intent(inout):: Land_boundary
  type(atmos_ice_boundary_type),     intent(inout):: Ice_boundary

  real, dimension(n_xgrid_sfc) :: ex_flux_sw, ex_flux_lwd, &
       ex_flux_sw_dir,  &
                                    ex_flux_sw_dif,  &
      ex_flux_sw_down_vis_dir, ex_flux_sw_down_total_dir,  &
      ex_flux_sw_down_vis_dif, ex_flux_sw_down_total_dif,  &
       ex_flux_sw_vis, &
       ex_flux_sw_vis_dir, &
       ex_flux_sw_vis_dif, &
       ex_lprec, ex_fprec,      &
       ex_tprec, & ! temperature of precipitation, currently equal to atm T
       ex_u_star_smooth,        &
       ex_coszen

  real, dimension(n_xgrid_sfc) :: ex_gamma  , ex_dtmass,  &
       ex_delta_t, ex_delta_u, ex_delta_v, ex_dflux_t

  real, dimension(n_xgrid_sfc,n_exch_tr) :: &
       ex_delta_tr, & ! tracer tendencies
       ex_dflux_tr    ! fracer flux change

  real    :: cp_inv
  logical :: used
  logical :: ov
  integer :: ier

  character(32) :: tr_name ! name of the tracer
  integer :: tr, n, m ! tracer indices

!Balaji
  call mpp_clock_begin(cplClock)
  call mpp_clock_begin(fluxAtmDnClock)
  ov = .FALSE.
!-----------------------------------------------------------------------
!Balaji: data_override calls moved here from coupler_main            
  call data_override ('ATM', 'flux_sw',  Atm%flux_sw, Time)
  call data_override ('ATM', 'flux_sw_dir',  Atm%flux_sw_dir, Time)
  call data_override ('ATM', 'flux_sw_dif',  Atm%flux_sw_dif, Time)
  call data_override ('ATM', 'flux_sw_down_vis_dir',  Atm%flux_sw_down_vis_dir, Time)
  call data_override ('ATM', 'flux_sw_down_vis_dif',  Atm%flux_sw_down_vis_dif, Time)
  call data_override ('ATM', 'flux_sw_down_total_dir',  Atm%flux_sw_down_total_dir, Time)
  call data_override ('ATM', 'flux_sw_down_total_dif',  Atm%flux_sw_down_total_dif, Time)
  call data_override ('ATM', 'flux_sw_vis',  Atm%flux_sw_vis, Time)
  call data_override ('ATM', 'flux_sw_vis_dir',  Atm%flux_sw_vis_dir, Time)
  call data_override ('ATM', 'flux_sw_vis_dif',  Atm%flux_sw_vis_dif, Time)
  call data_override ('ATM', 'flux_lw',  Atm%flux_lw, Time)
  call data_override ('ATM', 'lprec',    Atm%lprec,   Time)
  call data_override ('ATM', 'fprec',    Atm%fprec,   Time)
  call data_override ('ATM', 'coszen',   Atm%coszen,  Time)
  call data_override ('ATM', 'dtmass',   Atm%Surf_Diff%dtmass, Time)
  call data_override ('ATM', 'delta_t',  Atm%Surf_Diff%delta_t, Time)
  call data_override ('ATM', 'dflux_t',  Atm%Surf_Diff%dflux_t, Time)
  do tr = 1,n_atm_tr
     call get_tracer_names(MODEL_ATMOS,tr,tr_name)
     call data_override ('ATM', 'delta_'//trim(tr_name),  Atm%Surf_Diff%delta_tr(:,:,tr), Time)
     call data_override ('ATM', 'dflux_'//trim(tr_name),  Atm%Surf_Diff%dflux_tr(:,:,tr), Time)
  enddo

!---- put atmosphere quantities onto exchange grid ----

  if(sw1way_bug) then
     call put_to_xgrid (Atm%flux_sw, 'ATM', ex_flux_sw, xmap_sfc)
     call put_to_xgrid (Atm%flux_sw_vis, 'ATM', ex_flux_sw_vis, xmap_sfc)
  end if
  ex_flux_sw_dir     = 0.0
  ex_flux_sw_vis_dir = 0.0
  ex_flux_sw_dif     = 0.0
  ex_flux_sw_vis_dif = 0.0
  ex_flux_lwd        = 0.0                           
  call put_to_xgrid (Atm%flux_sw_dir, 'ATM', ex_flux_sw_dir, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_vis_dir, 'ATM', ex_flux_sw_vis_dir, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_dif, 'ATM', ex_flux_sw_dif, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_vis_dif, 'ATM', ex_flux_sw_vis_dif, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_down_vis_dir, 'ATM', ex_flux_sw_down_vis_dir, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_down_total_dir, 'ATM', ex_flux_sw_down_total_dir, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_down_vis_dif, 'ATM', ex_flux_sw_down_vis_dif, xmap_sfc)
  call put_to_xgrid (Atm%flux_sw_down_total_dif, 'ATM', ex_flux_sw_down_total_dif, xmap_sfc)
  call put_to_xgrid (Atm%flux_lw, 'ATM', ex_flux_lwd, xmap_sfc, remap_method=remap_method)
  !  ccc = conservation_check(Atm%lprec, 'ATM', xmap_sfc)
  !  if (mpp_pe()== mpp_root_pe()) print *,'LPREC', ccc

!!$  if(do_area_weighted_flux) then
!!$     call put_to_xgrid (Atm%lprec * AREA_ATM_MODEL,   'ATM', ex_lprec, xmap_sfc)
!!$     call put_to_xgrid (Atm%fprec * AREA_ATM_MODEL,   'ATM', ex_fprec, xmap_sfc)
!!$  else
     call put_to_xgrid (Atm%lprec,   'ATM', ex_lprec, xmap_sfc)
     call put_to_xgrid (Atm%fprec,   'ATM', ex_fprec, xmap_sfc)
     call put_to_xgrid (Atm%t_bot,   'ATM', ex_tprec, xmap_sfc)
!!$  endif

  call put_to_xgrid (Atm%coszen,  'ATM', ex_coszen, xmap_sfc)

  if(ex_u_star_smooth_bug) then
     call put_to_xgrid (Atmos_boundary%u_star, 'ATM', ex_u_star_smooth, xmap_sfc, remap_method=remap_method)
     ex_u_star = ex_u_star_smooth
  endif


! MOD changed the following two lines to put Atmos%surf_diff%delta_u and v
! on exchange grid instead of the stresses themselves so that only the 
! implicit corrections are filtered through the atmospheric grid not the
! stresses themselves
  ex_delta_u = 0.0; ex_delta_v = 0.0
  call put_to_xgrid (Atm%Surf_Diff%delta_u, 'ATM', ex_delta_u, xmap_sfc, remap_method=remap_method)
  call put_to_xgrid (Atm%Surf_Diff%delta_v, 'ATM', ex_delta_v, xmap_sfc, remap_method=remap_method)

  ! MOD update stresses using atmos delta's but derivatives on exchange grid
  ex_flux_u = ex_flux_u + ex_delta_u*ex_dtaudu_atm
  ex_flux_v = ex_flux_v + ex_delta_v*ex_dtaudv_atm

!-----------------------------------------------------------------------
!---- adjust sw flux for albedo variations on exch grid ----
!---- adjust 4 categories (vis/nir dir/dif) separately  ----
  if( sw1way_bug ) then ! to reproduce old results, may remove in the next major release.
!-----------------------------------------------------------------------
!---- adjust sw flux for albedo variations on exch grid ----

     ex_flux_sw = ex_flux_sw * ex_albedo_fix


     ex_flux_sw_vis = ex_flux_sw_vis * ex_albedo_vis_dir_fix
     ex_flux_sw_dir = ex_flux_sw_dir * ex_albedo_vis_dir_fix
     ex_flux_sw_dif = ex_flux_sw_dif * ex_albedo_vis_dif_fix
     ex_flux_sw_vis_dir = ex_flux_sw_vis_dir * ex_albedo_vis_dir_fix
     ex_flux_sw_vis_dif = ex_flux_sw_vis_dif * ex_albedo_vis_dif_fix
  else 
     ex_flux_sw_dir = ex_flux_sw_dir - ex_flux_sw_vis_dir     ! temporarily nir/dir
     ex_flux_sw_dir = ex_flux_sw_dir * ex_albedo_nir_dir_fix  ! fix nir/dir
     ex_flux_sw_vis_dir = ex_flux_sw_vis_dir * ex_albedo_vis_dir_fix ! fix vis/dir
     ex_flux_sw_dir = ex_flux_sw_dir + ex_flux_sw_vis_dir     ! back to total dir

     ex_flux_sw_dif = ex_flux_sw_dif - ex_flux_sw_vis_dif     ! temporarily nir/dif
     ex_flux_sw_dif = ex_flux_sw_dif * ex_albedo_nir_dif_fix  ! fix nir/dif
     ex_flux_sw_vis_dif = ex_flux_sw_vis_dif * ex_albedo_vis_dif_fix ! fix vis/dif
     ex_flux_sw_dif = ex_flux_sw_dif + ex_flux_sw_vis_dif     ! back to total dif

     ex_flux_sw_vis = ex_flux_sw_vis_dir + ex_flux_sw_vis_dif ! legacy, remove later
     ex_flux_sw     = ex_flux_sw_dir     + ex_flux_sw_dif     ! legacy, remove later
  end if

!!$  ex_flux_sw_dir = ex_flux_sw_dir - ex_flux_sw_vis_dir            ! temporarily nir/dir
!!$  ex_flux_sw_dir = ex_flux_sw_dir * ex_albedo_nir_dir_fix         ! fix nir/dir
!!$  ex_flux_sw_vis_dir = ex_flux_sw_vis_dir * ex_albedo_vis_dir_fix ! fix vis/dir
!!$  ex_flux_sw_dir = ex_flux_sw_dir + ex_flux_sw_vis_dir            ! back to total dir
!!$
!!$  ex_flux_sw_dif = ex_flux_sw_dif - ex_flux_sw_vis_dif            ! temporarily nir/dif
!!$  ex_flux_sw_dif = ex_flux_sw_dif * ex_albedo_nir_dif_fix         ! fix nir/dif
!!$  ex_flux_sw_vis_dif = ex_flux_sw_vis_dif * ex_albedo_vis_dif_fix ! fix vis/dif
!!$  ex_flux_sw_dif = ex_flux_sw_dif + ex_flux_sw_vis_dif            ! back to total dif
!!$
!!$  ex_flux_sw_vis = ex_flux_sw_vis_dir + ex_flux_sw_vis_dif        ! legacy, remove later
!!$  ex_flux_sw     = ex_flux_sw_dir     + ex_flux_sw_dif            ! legacy, remove later

  deallocate ( ex_albedo_fix )
  deallocate ( ex_albedo_vis_dir_fix )
  deallocate ( ex_albedo_nir_dir_fix )
  deallocate ( ex_albedo_vis_dif_fix )
  deallocate ( ex_albedo_nir_dif_fix )
!----- compute net longwave flux (down-up) -----
  ! (note: lw up already in ex_flux_lw)

  ex_flux_lw = ex_flux_lwd - ex_flux_lw

!-----------------------------------------------------------------------
!----- adjust fluxes for implicit dependence on atmosphere ----


  call put_to_xgrid (Atm%Surf_Diff%dtmass , 'ATM', ex_dtmass , xmap_sfc )
  call put_to_xgrid (Atm%Surf_Diff%delta_t, 'ATM', ex_delta_t, xmap_sfc )
  call put_to_xgrid (Atm%Surf_Diff%dflux_t, 'ATM', ex_dflux_t, xmap_sfc )
  do tr = 1,n_exch_tr
     n = tr_table(tr)%atm
     call put_to_xgrid (Atm%Surf_Diff%delta_tr(:,:,n), 'ATM', ex_delta_tr(:,tr), xmap_sfc )
     call put_to_xgrid (Atm%Surf_Diff%dflux_tr(:,:,n), 'ATM', ex_dflux_tr(:,tr), xmap_sfc )
  enddo

  cp_inv = 1.0/cp_air

  where(ex_avail)

     ! temperature

     ex_gamma      =  1./ (1.0 - ex_dtmass*(ex_dflux_t + ex_dhdt_atm*cp_inv))
     ex_e_t_n      =  ex_dtmass*ex_dhdt_surf*cp_inv*ex_gamma
     ex_f_t_delt_n = (ex_delta_t + ex_dtmass * ex_flux_t*cp_inv) * ex_gamma    
     
     ex_flux_t     =  ex_flux_t        + ex_dhdt_atm * ex_f_t_delt_n 
     ex_dhdt_surf  =  ex_dhdt_surf     + ex_dhdt_atm * ex_e_t_n   

     ! moisture
!     ex_gamma      =  1./ (1.0 - ex_dtmass*(ex_dflux_q + ex_dedq_atm))
! here it looks like two derivatives with different units are added together,
! but in fact they are not: ex_dedt_surf and ex_dedq_surf defined in complimentary
! regions of exchange grid, so that if one of them is not zero the other is, and
! vice versa.
!     ex_e_q_n      =  ex_dtmass*(ex_dedt_surf+ex_dedq_surf) * ex_gamma
!     ex_f_q_delt_n = (ex_delta_q  + ex_dtmass * ex_flux_q) * ex_gamma    
!     ex_flux_q     =  ex_flux_q    + ex_dedq_atm * ex_f_q_delt_n 
!     ex_dedt_surf  =  ex_dedt_surf + ex_dedq_atm * ex_e_q_n
!     ex_dedq_surf  =  ex_dedq_surf + ex_dedq_atm * ex_e_q_n
     ! moisture vs. surface temperture, assuming saturation
     ex_gamma   =  1.0 / (1.0 - ex_dtmass*(ex_dflux_tr(:,isphum) + ex_dfdtr_atm(:,isphum)))
     ex_e_q_n      =  ex_dtmass * ex_dedt_surf * ex_gamma
     ex_dedt_surf  =  ex_dedt_surf + ex_dfdtr_atm(:,isphum) * ex_e_q_n
  endwhere
  do tr = 1,n_exch_tr
     where(ex_avail)
        ex_gamma   =  1.0 / (1.0 - ex_dtmass*(ex_dflux_tr(:,tr) + ex_dfdtr_atm(:,tr)))

        ex_e_tr_n(:,tr)      =  ex_dtmass*ex_dfdtr_surf(:,tr)*ex_gamma
        ex_f_tr_delt_n(:,tr) = (ex_delta_tr(:,tr)+ex_dtmass*ex_flux_tr(:,tr))*ex_gamma    
     
        ex_flux_tr(:,tr)     =  ex_flux_tr(:,tr) + ex_dfdtr_atm(:,tr)*ex_f_tr_delt_n(:,tr) 
        ex_dfdtr_surf(:,tr)  =  ex_dfdtr_surf(:,tr) + ex_dfdtr_atm(:,tr)*ex_e_tr_n(:,tr)
     endwhere
  enddo
!-----------------------------------------------------------------------
!---- output fields on the land grid -------

  call get_from_xgrid (Land_boundary%t_flux,  'LND', ex_flux_t,    xmap_sfc)
  call get_from_xgrid (Land_boundary%sw_flux, 'LND', ex_flux_sw,   xmap_sfc)
  call get_from_xgrid (Land_boundary%sw_flux_down_vis_dir, 'LND', ex_flux_sw_down_vis_dir,   xmap_sfc)
  call get_from_xgrid (Land_boundary%sw_flux_down_total_dir, 'LND', ex_flux_sw_down_total_dir,   xmap_sfc)
  call get_from_xgrid (Land_boundary%sw_flux_down_vis_dif, 'LND', ex_flux_sw_down_vis_dif,   xmap_sfc)
  call get_from_xgrid (Land_boundary%sw_flux_down_total_dif, 'LND', ex_flux_sw_down_total_dif,   xmap_sfc)
  call get_from_xgrid (Land_boundary%lw_flux, 'LND', ex_flux_lw,   xmap_sfc)
#ifdef SCM
  if (do_specified_land .and. do_specified_flux) then
    call get_from_xgrid (Land_boundary%dhdt,  'LND', ex_dhdt_surf_forland, xmap_sfc)
  else
    call get_from_xgrid (Land_boundary%dhdt,  'LND', ex_dhdt_surf, xmap_sfc)
  endif
#else
  call get_from_xgrid (Land_boundary%dhdt,    'LND', ex_dhdt_surf, xmap_sfc)
#endif
  call get_from_xgrid (Land_boundary%drdt,    'LND', ex_drdt_surf, xmap_sfc)
  call get_from_xgrid (Land_boundary%p_surf,  'LND', ex_p_surf,    xmap_sfc)

  call get_from_xgrid (Land_boundary%lprec,   'LND', ex_lprec,     xmap_sfc)
  call get_from_xgrid (Land_boundary%fprec,   'LND', ex_fprec,     xmap_sfc)
  call get_from_xgrid (Land_boundary%tprec,   'LND', ex_tprec,     xmap_sfc)
!!$  if(do_area_weighted_flux) then
!!$     ! evap goes here???
!!$     do k = 1, size(Land_boundary%lprec, dim=3)
!!$        ! Note: we divide by AREA_ATM_MODEL, which should be the same as
!!$        ! AREA_LND_MODEL (but the latter may not be defined)
!!$        call divide_by_area(data=Land_boundary%lprec(:,:,k), area=AREA_ATM_MODEL)
!!$        call divide_by_area(data=Land_boundary%fprec(:,:,k), area=AREA_ATM_MODEL)
!!$     enddo
!!$  endif

  if(associated(Land_boundary%drag_q)) then
     call get_from_xgrid (Land_boundary%drag_q, 'LND', ex_drag_q,    xmap_sfc)
     call data_override('LND', 'drag_q', Land_boundary%drag_q,  Time )
  endif
  if(associated(Land_boundary%lwdn_flux)) then
     call get_from_xgrid (Land_boundary%lwdn_flux, 'LND', ex_flux_lwd, xmap_sfc)
     call data_override('LND', 'lwdn_flux', Land_boundary%lwdn_flux, Time )
  endif
  if(associated(Land_boundary%cd_m)) then
     call get_from_xgrid (Land_boundary%cd_m, 'LND', ex_cd_m, xmap_sfc)
     call data_override('LND', 'cd_m', Land_boundary%cd_m, Time )
  endif
  if(associated(Land_boundary%cd_t)) then
     call get_from_xgrid (Land_boundary%cd_t, 'LND', ex_cd_t, xmap_sfc)
     call data_override('LND', 'cd_t', Land_boundary%cd_t, Time )
  endif
  if(associated(Land_boundary%bstar)) then
     call get_from_xgrid (Land_boundary%bstar, 'LND', ex_b_star, xmap_sfc)
     call data_override('LND', 'bstar',  Land_boundary%bstar, Time )
  endif
  if(associated(Land_boundary%ustar)) then
     call get_from_xgrid (Land_boundary%ustar, 'LND', ex_u_star, xmap_sfc)
     call data_override('LND', 'ustar',  Land_boundary%ustar, Time )
  endif
  if(associated(Land_boundary%wind)) then
     call get_from_xgrid (Land_boundary%wind, 'LND', ex_wind, xmap_sfc)
     call data_override('LND', 'wind',  Land_boundary%wind, Time )
  endif
  if(associated(Land_boundary%z_bot)) then
     call get_from_xgrid (Land_boundary%z_bot, 'LND', ex_z_atm, xmap_sfc)
     call data_override('LND', 'z_bot',  Land_boundary%z_bot, Time )
  endif

  Land_boundary%tr_flux(:,:,:,:) = 0.0
  Land_boundary%dfdtr(:,:,:,:) = 0.0
  do tr = 1,n_exch_tr
     n = tr_table(tr)%lnd
     if(n /= NO_TRACER ) then
        call get_from_xgrid (Land_boundary%tr_flux(:,:,:,n), 'LND', ex_flux_tr(:,tr), xmap_sfc)
        call get_from_xgrid (Land_boundary%dfdtr(:,:,:,n),   'LND', ex_dfdtr_surf(:,tr), xmap_sfc)
#ifdef SCM
        if (do_specified_land .and. do_specified_flux .and. tr.eq.isphum) then
          call get_from_xgrid (Land_boundary%dfdtr(:,:,:,n),   'LND', ex_dedq_surf_forland(:), xmap_sfc)
        endif
#endif
     endif
  enddo

!  current time is Time: is that ok? not available in land_data_type
!Balaji: data_override calls moved here from coupler_main
  call data_override('LND', 't_flux',  Land_boundary%t_flux,  Time )
  call data_override('LND', 'lw_flux', Land_boundary%lw_flux, Time )
  call data_override('LND', 'sw_flux', Land_boundary%sw_flux, Time )
  call data_override('LND', 'sw_flux_down_vis_dir', Land_boundary%sw_flux_down_vis_dir, Time )
  call data_override('LND', 'sw_flux_down_total_dir', Land_boundary%sw_flux_down_total_dir, Time )
  call data_override('LND', 'sw_flux_down_vis_dif', Land_boundary%sw_flux_down_vis_dif, Time )
  call data_override('LND', 'sw_flux_down_total_dif', Land_boundary%sw_flux_down_total_dif, Time )
  
  call data_override('LND', 'lprec',   Land_boundary%lprec,   Time )
  call data_override('LND', 'fprec',   Land_boundary%fprec,   Time )
  call data_override('LND', 'dhdt',    Land_boundary%dhdt,    Time )
  call data_override('LND', 'drdt',    Land_boundary%drdt,    Time )
  call data_override('LND', 'p_surf',  Land_boundary%p_surf,  Time )
  do tr = 1,n_lnd_tr
     call get_tracer_names(MODEL_LAND, tr, tr_name)
     call data_override('LND', trim(tr_name)//'_flux', Land_boundary%tr_flux(:,:,:,tr), Time)
     call data_override('LND', 'dfd'//trim(tr_name),   Land_boundary%dfdtr  (:,:,:,tr), Time)
  enddo

!-----------------------------------------------------------------------
!---- output fields on the ice grid -------

  call get_from_xgrid (Ice_boundary%t_flux,   'OCN', ex_flux_t,    xmap_sfc)
  call get_from_xgrid (Ice_boundary%q_flux,   'OCN', ex_flux_tr(:,isphum), xmap_sfc)
  call get_from_xgrid (Ice_boundary%sw_flux_vis_dir,  'OCN', ex_flux_sw_vis_dir,   xmap_sfc)
  call get_from_xgrid (Ice_boundary%sw_flux_nir_dir,  'OCN', ex_flux_sw_dir,xmap_sfc)
  Ice_boundary%sw_flux_nir_dir = Ice_boundary%sw_flux_nir_dir - Ice_boundary%sw_flux_vis_dir ! ice & ocean use these 4: dir/dif nir/vis

  call get_from_xgrid (Ice_boundary%sw_flux_vis_dif,  'OCN', ex_flux_sw_vis_dif,   xmap_sfc)
  call get_from_xgrid (Ice_boundary%sw_flux_nir_dif,  'OCN', ex_flux_sw_dif,xmap_sfc)
  Ice_boundary%sw_flux_nir_dif = Ice_boundary%sw_flux_nir_dif - Ice_boundary%sw_flux_vis_dif ! ice & ocean use these 4: dir/dif nir/vis

  call get_from_xgrid (Ice_boundary%lw_flux,  'OCN', ex_flux_lw,   xmap_sfc)
  call get_from_xgrid (Ice_boundary%dhdt,     'OCN', ex_dhdt_surf, xmap_sfc)
  call get_from_xgrid (Ice_boundary%dedt,     'OCN', ex_dedt_surf, xmap_sfc)
  call get_from_xgrid (Ice_boundary%drdt,     'OCN', ex_drdt_surf, xmap_sfc)
  call get_from_xgrid (Ice_boundary%u_flux,   'OCN', ex_flux_u,    xmap_sfc)
  call get_from_xgrid (Ice_boundary%v_flux,   'OCN', ex_flux_v,    xmap_sfc)
  call get_from_xgrid (Ice_boundary%u_star,   'OCN', ex_u_star,    xmap_sfc)
  call get_from_xgrid (Ice_boundary%coszen,   'OCN', ex_coszen,    xmap_sfc)
  call get_from_xgrid (Ice_boundary%p,        'OCN', ex_slp,       xmap_sfc) ! mw mod

  call get_from_xgrid (Ice_boundary%lprec,    'OCN', ex_lprec,     xmap_sfc)
  call get_from_xgrid (Ice_boundary%fprec,    'OCN', ex_fprec,     xmap_sfc)
!!$  if (do_area_weighted_flux) then
!!$     where (AREA_ATM_SPHERE /= 0)
!!$        Ice_boundary%lprec = Ice_boundary%lprec * AREA_ATM_MODEL/AREA_ATM_SPHERE
!!$        Ice_boundary%fprec = Ice_boundary%fprec * AREA_ATM_MODEL/AREA_ATM_SPHERE
!!$     end where
!!$  endif
!!$  if(do_area_weighted_flux) then
!!$     do k = 1, size(Ice_boundary%lprec, dim=3)
!!$        call divide_by_area(data=Ice_boundary%lprec(:,:,k), area=AREA_ATM_SPHERE)
!!$        call divide_by_area(data=Ice_boundary%fprec(:,:,k), area=AREA_ATM_SPHERE)
!!$     enddo
!!$  endif

! Extra fluxes
  do n = 1, Ice_boundary%fluxes%num_bcs  !{
    do m = 1, Ice_boundary%fluxes%bc(n)%num_fields  !{
      call get_from_xgrid (Ice_boundary%fluxes%bc(n)%field(m)%values, 'OCN',  &
           ex_gas_fluxes%bc(n)%field(m)%values, xmap_sfc)
    enddo  !} m
  enddo  !} n

!Balaji: data_override calls moved here from coupler_main
  call data_override('ICE', 'u_flux', Ice_boundary%u_flux,  Time)
  call data_override('ICE', 'v_flux', Ice_boundary%v_flux,  Time)
  call data_override('ICE', 't_flux', Ice_boundary%t_flux,  Time)
  call data_override('ICE', 'q_flux', Ice_boundary%q_flux,  Time)
  call data_override('ICE', 'lw_flux',Ice_boundary%lw_flux, Time)
  call data_override('ICE', 'lw_flux_dn',Ice_boundary%lw_flux, Time, override=ov)
  if (ov) then
    Ice_boundary%lw_flux = Ice_boundary%lw_flux - stefan*Ice%t_surf**4
  endif
  call data_override('ICE', 'sw_flux_nir_dir',Ice_boundary%sw_flux_nir_dir, Time)
  call data_override('ICE', 'sw_flux_vis_dir',Ice_boundary%sw_flux_vis_dir, Time)
  call data_override('ICE', 'sw_flux_nir_dif',Ice_boundary%sw_flux_nir_dif, Time, override=ov)
  call data_override('ICE', 'sw_flux_vis_dif',Ice_boundary%sw_flux_vis_dif, Time)
  call data_override('ICE', 'sw_flux_vis_dir_dn',Ice_boundary%sw_flux_vis_dir, Time, override=ov)
  if (ov) then
    Ice_boundary%sw_flux_vis_dir = Ice_boundary%sw_flux_vis_dir*(1-Ice%albedo_vis_dir)
  endif
  call data_override('ICE', 'sw_flux_vis_dif_dn',Ice_boundary%sw_flux_vis_dif, Time, override=ov)
  if (ov) then
    Ice_boundary%sw_flux_vis_dif = Ice_boundary%sw_flux_vis_dif*(1-Ice%albedo_vis_dif)
  endif
  call data_override('ICE', 'sw_flux_nir_dir_dn',Ice_boundary%sw_flux_nir_dir, Time, override=ov)
  if (ov) then
    Ice_boundary%sw_flux_nir_dir = Ice_boundary%sw_flux_nir_dir*(1-Ice%albedo_nir_dir)
  endif
  call data_override('ICE', 'sw_flux_nir_dif_dn',Ice_boundary%sw_flux_nir_dif, Time, override=ov)
  if (ov) then
    Ice_boundary%sw_flux_nir_dif = Ice_boundary%sw_flux_nir_dif*(1-Ice%albedo_nir_dif)
  endif
  call data_override('ICE', 'lprec',  Ice_boundary%lprec,   Time)
  call data_override('ICE', 'fprec',  Ice_boundary%fprec,   Time)
  call data_override('ICE', 'dhdt',   Ice_boundary%dhdt,    Time)
  call data_override('ICE', 'dedt',   Ice_boundary%dedt,    Time)
  call data_override('ICE', 'drdt',   Ice_boundary%drdt,    Time)
  call data_override('ICE', 'coszen', Ice_boundary%coszen,  Time)
  call data_override('ICE', 'p',      Ice_boundary%p,       Time)

  do n = 1, Ice_boundary%fluxes%num_bcs  !{
    do m = 1, Ice_boundary%fluxes%bc(n)%num_fields  !{
      call data_override('ICE', Ice_boundary%fluxes%bc(n)%field(m)%name,     &
           Ice_boundary%fluxes%bc(n)%field(m)%values, Time)
      if ( Ice_boundary%fluxes%bc(n)%field(m)%id_diag > 0 ) then  !{
        used = send_data(Ice_boundary%fluxes%bc(n)%field(m)%id_diag, Ice_boundary%fluxes%bc(n)%field(m)%values, Time )
      endif  !}
    enddo  !} m
  enddo  !} n

  ! compute stock changes

  ! Atm -> Lnd (precip)
  call stock_move( &
       & FROM = Atm_stock(ISTOCK_WATER),  &
       & TO   = Lnd_stock(ISTOCK_WATER), &
       & DATA = (Land_boundary%lprec + Land_boundary%fprec), &
       & grid_index=X1_GRID_LND, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move PRECIP (Atm->Lnd) ')

  ! Atm -> Lnd (heat)
  call stock_move( &
       & FROM = Atm_stock(ISTOCK_HEAT),  &
       & TO   = Lnd_stock(ISTOCK_HEAT), &
       & DATA = (-Land_boundary%t_flux + Land_boundary%lw_flux +  Land_boundary%sw_flux - Land_boundary%fprec*HLF), &
       & grid_index=X1_GRID_LND, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move HEAT (Atm->Lnd) ')

  ! Atm -> Ice (precip)
  call stock_move( &
       & FROM = Atm_stock(ISTOCK_WATER), &
       & TO   = Ice_stock(ISTOCK_WATER), &
       & DATA = (Ice_boundary%lprec + Ice_boundary%fprec), &
       & grid_index=X1_GRID_ICE, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move PRECIP (Atm->Ice) ')

  ! Atm -> Ice (heat)
  call stock_move( &
       & FROM = Atm_stock(ISTOCK_HEAT), &
       & TO   = Ice_stock(ISTOCK_HEAT), &
       & DATA = (-Ice_boundary%t_flux + Ice_boundary%lw_flux - Ice_boundary%fprec*HLF + Ice_boundary%sw_flux_vis_dir + &
                  Ice_boundary%sw_flux_vis_dif + Ice_boundary%sw_flux_nir_dir + Ice_boundary%sw_flux_nir_dif), &
       & grid_index=X1_GRID_ICE, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move HEAT (Atm->Ice) ')

  deallocate ( ex_flux_u, ex_flux_v, ex_dtaudu_atm, ex_dtaudv_atm)

  !=======================================================================
  !-------------------- diagnostics section ------------------------------

  !------- zonal wind stress -----------
  used = send_data ( id_u_flux, Atmos_boundary%u_flux, Time )

  !------- meridional wind stress -----------
  used = send_data ( id_v_flux, Atmos_boundary%v_flux, Time )

!Balaji
  call mpp_clock_end(fluxAtmDnClock)
  call mpp_clock_end(cplClock)
!=======================================================================

  end subroutine flux_down_from_atmos
! </SUBROUTINE>

!#######################################################################
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
! flux_land_to_ice - translate runoff from land to ice grids                   !
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
! <SUBROUTINE NAME="flux_land_to_ice">
!  <OVERVIEW>
!   Conservative transfer of water and snow discharge from the land model to sea ice/ocean model. 
!  </OVERVIEW>
!  <DESCRIPTION>
!  <PRE>
!    The following elements are transferred from the Land to the Land_ice_boundary: 
!
!        discharge --> runoff (kg/m2)
!        discharge_snow --> calving (kg/m2)
!
!  </PRE>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_land_to_ice(Time, Land, Ice, Land_Ice_Boundary )
!		
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME="Land" TYPE="land_data_type">
!   A derived data type to specify land boundary data.
!  </IN>
!  <IN NAME="Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </IN>
!  <INOUT NAME="Land_Ice_Boundary" TYPE="land_ice_boundary_type">
!   A derived data type to specify properties and fluxes passed from land to ice.
!  </INOUT>
!
subroutine flux_land_to_ice( Time, Land, Ice, Land_Ice_Boundary )
  type(time_type),               intent(in) :: Time
  type(land_data_type),          intent(in) :: Land
  type(ice_data_type),           intent(in) :: Ice
!real, dimension(:,:), intent(out) :: runoff_ice, calving_ice
  type(land_ice_boundary_type),  intent(inout):: Land_Ice_Boundary
  
  integer :: ier
  real, dimension(n_xgrid_runoff) :: ex_runoff, ex_calving, ex_runoff_hflx, ex_calving_hflx
  real, dimension(size(Land_Ice_Boundary%runoff,1),size(Land_Ice_Boundary%runoff,2),1) :: ice_buf
!Balaji
  call mpp_clock_begin(cplClock)
  call mpp_clock_begin(fluxLandIceClock)

  ! ccc = conservation_check(Land%discharge, 'LND', xmap_runoff)
  ! if (mpp_pe()==mpp_root_pe()) print *,'RUNOFF', ccc

if (do_runoff) then
  call put_to_xgrid ( Land%discharge,      'LND', ex_runoff,  xmap_runoff)
  call put_to_xgrid ( Land%discharge_snow, 'LND', ex_calving, xmap_runoff)
  call put_to_xgrid ( Land%discharge_heat,      'LND', ex_runoff_hflx,  xmap_runoff)
  call put_to_xgrid ( Land%discharge_snow_heat, 'LND', ex_calving_hflx, xmap_runoff)
  call get_from_xgrid (ice_buf, 'OCN', ex_runoff,  xmap_runoff)
  Land_Ice_Boundary%runoff = ice_buf(:,:,1);
  call get_from_xgrid (ice_buf, 'OCN', ex_calving, xmap_runoff)
  Land_Ice_Boundary%calving = ice_buf(:,:,1);
  call get_from_xgrid (ice_buf, 'OCN', ex_runoff_hflx,  xmap_runoff)
  Land_Ice_Boundary%runoff_hflx = ice_buf(:,:,1);
  call get_from_xgrid (ice_buf, 'OCN', ex_calving_hflx, xmap_runoff)
  Land_Ice_Boundary%calving_hflx = ice_buf(:,:,1);
!Balaji
  call data_override('ICE', 'runoff' , Land_Ice_Boundary%runoff , Time)
  call data_override('ICE', 'calving', Land_Ice_Boundary%calving, Time)
  call data_override('ICE', 'runoff_hflx' , Land_Ice_Boundary%runoff_hflx , Time)
  call data_override('ICE', 'calving_hflx', Land_Ice_Boundary%calving_hflx, Time)

  ! compute stock increment
  ice_buf(:,:,1) = Land_Ice_Boundary%runoff + Land_Ice_Boundary%calving
  call stock_move(from=Lnd_stock(ISTOCK_WATER), to=Ice_stock(ISTOCK_WATER), &
              & grid_index=X2_GRID_ICE, &
              & data=ice_buf, &
              & xmap=xmap_runoff, &
              & delta_t=Dt_cpl, &
              & from_side=ISTOCK_SIDE, to_side=ISTOCK_SIDE, &
              & radius=Radius, ier=ier, verbose='stock move RUNOFF+CALVING (Lnd->Ice) ')
else   
   Land_Ice_Boundary%runoff = 0.0 
   Land_Ice_Boundary%calving = 0.0
   Land_Ice_Boundary%runoff_hflx = 0.0 
   Land_Ice_Boundary%calving_hflx = 0.0
endif

  call mpp_clock_end(fluxLandIceClock)
  call mpp_clock_end(cplClock)

end subroutine flux_land_to_ice
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="flux_ice_to_ocean">
!  <OVERVIEW>
!   Takes the ice model state (fluxes at the bottom of the ice) and interpolates it to the ocean model grid. 
!  </OVERVIEW>
!  <DESCRIPTION>
!  <PRE>
!   The following quantities are transferred from the Ice to the ice_ocean_boundary_type: 
!
!       flux_u = zonal wind stress (Pa)
!       flux_v = meridional wind stress (Pa)
!       flux_t = sensible heat flux (W/m2)
!       flux_q = specific humidity flux (Kg/m2/s)
!    flux_salt = salt flux (Kg/m2/s)
!      flux_sw = net (down-up) shortwave flux (W/m2)
!      flux_lw = net (down-up) longwave flux (W/m2)
!        lprec = mass of liquid precipitation since last
!                      time step (Kg/m2)
!        fprec = mass of frozen precipitation since last
!                time step (Kg/m2)
!       runoff = mass (?) of runoff since last time step
!                       (Kg/m2)
!       p_surf = surface pressure (Pa)
!  </PRE>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_ice_to_ocean ( Time, Ice, Ocean, Ice_Ocean_Boundary )
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME=" Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </IN>
!  <IN NAME="Ocean" TYPE="ocean_public_type">
!   A derived data type to specify ocean boundary data.
!  </IN>
!  <INOUT NAME="Ice_Ocean_Boundary" TYPE="ice_ocean_boundary_type">
!   A derived data type to specify properties and fluxes passed from ice to ocean.
!  </INOUT>
!
subroutine flux_ice_to_ocean ( Time, Ice, Ocean, Ice_Ocean_Boundary )

  type(time_type),        intent(in) :: Time
  type(ice_data_type),   intent(in)  :: Ice
  type(ocean_public_type), intent(in)  :: Ocean
!  real, dimension(:,:),   intent(out) :: flux_u_ocean,  flux_v_ocean,  &
!                                         flux_t_ocean,  flux_q_ocean,  &
!                                         flux_sw_ocean, flux_lw_ocean, &
!                                         lprec_ocean,   fprec_ocean,   &
!                                         runoff_ocean,  calving_ocean, &
!                                         flux_salt_ocean, p_surf_ocean
  type(ice_ocean_boundary_type), intent(inout) :: Ice_Ocean_Boundary

  integer       :: m
  integer       :: n
  logical       :: used

!Balaji
  call mpp_clock_begin(cplOcnClock)
  call mpp_clock_begin(fluxIceOceanClock)

  if(ASSOCIATED(Ice_Ocean_Boundary%u_flux) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_u, Ice_Ocean_Boundary%u_flux, Ice_Ocean_Boundary%xtype, .FALSE. )

  if(ASSOCIATED(Ice_Ocean_Boundary%v_flux) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_v, Ice_Ocean_Boundary%v_flux, Ice_Ocean_Boundary%xtype, .FALSE. )

  if(ASSOCIATED(Ice_Ocean_Boundary%p     ) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%p_surf, Ice_Ocean_Boundary%p     , Ice_Ocean_Boundary%xtype, .FALSE. )

  ! Extra fluxes
  do n = 1, Ice_Ocean_Boundary%fluxes%num_bcs  !{
     do m = 1, Ice_Ocean_Boundary%fluxes%bc(n)%num_fields  !{
        if ( associated(Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%values) ) then  !{
           call flux_ice_to_ocean_redistribute( Ice, Ocean, Ice%ocean_fluxes%bc(n)%field(m)%values, &
                Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%values, Ice_Ocean_Boundary%xtype, .FALSE. )
        endif  !}
     enddo  !} m
  enddo  !} n

  !--- The following variables may require conserved flux exchange from ice to ocean because the 
  !--- ice area maybe different from ocean area.
  if(ASSOCIATED(Ice_Ocean_Boundary%t_flux) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_t, Ice_Ocean_Boundary%t_flux, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%salt_flux) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_salt, Ice_Ocean_Boundary%salt_flux, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%sw_flux_nir_dir) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_sw_nir_dir, Ice_Ocean_Boundary%sw_flux_nir_dir, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%sw_flux_nir_dif) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_sw_nir_dif, Ice_Ocean_Boundary%sw_flux_nir_dif, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%sw_flux_vis_dir) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_sw_vis_dir, Ice_Ocean_Boundary%sw_flux_vis_dir, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%sw_flux_vis_dif) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_sw_vis_dif, Ice_Ocean_Boundary%sw_flux_vis_dif, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%lw_flux) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_lw, Ice_Ocean_Boundary%lw_flux, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%lprec) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%lprec, Ice_Ocean_Boundary%lprec, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%fprec) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%fprec, Ice_Ocean_Boundary%fprec, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%runoff) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%runoff, Ice_Ocean_Boundary%runoff, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%calving) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%calving, Ice_Ocean_Boundary%calving, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%runoff_hflx) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%runoff_hflx, Ice_Ocean_Boundary%runoff_hflx, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%calving_hflx) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%calving_hflx, Ice_Ocean_Boundary%calving_hflx, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

  if(ASSOCIATED(Ice_Ocean_Boundary%q_flux) ) call flux_ice_to_ocean_redistribute( Ice, Ocean, &
      Ice%flux_q, Ice_Ocean_Boundary%q_flux, Ice_Ocean_Boundary%xtype, do_area_weighted_flux )

!Balaji: moved data_override calls here from coupler_main
  if( ocn_pe )then
      call mpp_set_current_pelist(ocn_pelist)
      call data_override('OCN', 'u_flux',    Ice_Ocean_Boundary%u_flux   , Time )
      call data_override('OCN', 'v_flux',    Ice_Ocean_Boundary%v_flux   , Time )
      call data_override('OCN', 't_flux',    Ice_Ocean_Boundary%t_flux   , Time )
      call data_override('OCN', 'q_flux',    Ice_Ocean_Boundary%q_flux   , Time )
      call data_override('OCN', 'salt_flux', Ice_Ocean_Boundary%salt_flux, Time )
      call data_override('OCN', 'lw_flux',   Ice_Ocean_Boundary%lw_flux  , Time )
      call data_override('OCN', 'sw_flux_nir_dir',   Ice_Ocean_Boundary%sw_flux_nir_dir  , Time )
      call data_override('OCN', 'sw_flux_nir_dif',   Ice_Ocean_Boundary%sw_flux_nir_dif  , Time )
      call data_override('OCN', 'sw_flux_vis_dir',   Ice_Ocean_Boundary%sw_flux_vis_dir  , Time )
      call data_override('OCN', 'sw_flux_vis_dif',   Ice_Ocean_Boundary%sw_flux_vis_dif  , Time )
      call data_override('OCN', 'lprec',     Ice_Ocean_Boundary%lprec    , Time )
      call data_override('OCN', 'fprec',     Ice_Ocean_Boundary%fprec    , Time )
      call data_override('OCN', 'runoff',    Ice_Ocean_Boundary%runoff   , Time )
      call data_override('OCN', 'calving',   Ice_Ocean_Boundary%calving  , Time )
      call data_override('OCN', 'runoff_hflx',    Ice_Ocean_Boundary%runoff_hflx   , Time )
      call data_override('OCN', 'calving_hflx',   Ice_Ocean_Boundary%calving_hflx  , Time )
      call data_override('OCN', 'p',         Ice_Ocean_Boundary%p        , Time )

! Extra fluxes
      do n = 1, Ice_Ocean_Boundary%fluxes%num_bcs  !{
         do m = 1, Ice_Ocean_Boundary%fluxes%bc(n)%num_fields  !{
            call data_override('OCN', Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%name,   &
                  Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%values, Time)
            used = send_data(Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%id_diag,        &
                   Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%values, Time )
         enddo  !} m
      enddo  !} n

!
!       Perform diagnostic output for the fluxes
!

     do n = 1, Ice_Ocean_Boundary%fluxes%num_bcs  !{
       do m = 1, Ice_Ocean_Boundary%fluxes%bc(n)%num_fields  !{
         used = send_data(Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%id_diag,                   &
                Ice_Ocean_Boundary%fluxes%bc(n)%field(m)%values, Time)
       enddo  !} m
     enddo  !} n
   endif
   call mpp_set_current_pelist()

!Balaji
  call mpp_clock_end(fluxIceOceanClock)
  call mpp_clock_end(cplOcnClock)
!-----------------------------------------------------------------------

  end subroutine flux_ice_to_ocean
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="flux_ocean_to_ice">
!  <OVERVIEW>
!   Takes the ocean model state and interpolates it onto the bottom of the ice. 
!  </OVERVIEW>
!  <DESCRIPTION>
!  <PRE>
!    The following quantities are transferred from the Ocean to the ocean_ice_boundary_type: 
!
!        t_surf = surface temperature (deg K)
!        frazil = frazil (???)
!        u_surf = zonal ocean current/ice motion (m/s)
!        v_surf = meridional ocean current/ice motion (m/s
!  </PRE>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_ocean_to_ice ( Time, Ocean, Ice, Ocean_Ice_Boundary)
!  </TEMPLATE>
!  <IN NAME="Time" TYPE="time_type">
!   current time
!  </IN>
!  <IN NAME=" Ocean" TYPE="ocean_public_type">
!   A derived data type to specify ocean boundary data.
!  </IN>
!  <IN NAME="Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </IN>
!  <INOUT NAME="Ocean_Ice_Boundary" TYPE="ocean_ice_boundary_type">
!   A derived data type to specify properties and fluxes passed from ocean to ice.
!  </INOUT>
!
subroutine flux_ocean_to_ice ( Time, Ocean, Ice, Ocean_Ice_Boundary )

  type(time_type),         intent(in)  :: Time
  type(ocean_public_type), intent(in)  :: Ocean
  type(ice_data_type),     intent(in)  :: Ice
!  real, dimension(:,:),   intent(out) :: t_surf_ice, u_surf_ice, v_surf_ice, &
!                                         frazil_ice, s_surf_ice, sea_lev_ice
  type(ocean_ice_boundary_type), intent(inout) :: Ocean_Ice_Boundary
  real, dimension(size(Ocean_Ice_Boundary%t,1),size(Ocean_Ice_Boundary%t,2),size(Ice%part_size,3)) &
       :: ice_frac
  real :: tmp( lbound(Ocean%frazil,1):ubound(Ocean%frazil,1), lbound(Ocean%frazil,2):ubound(Ocean%frazil,2) )
  real, dimension(:), allocatable :: ex_ice_frac
  real, dimension(ni_atm, nj_atm) :: diag_atm
  logical :: used
  integer       :: m
  integer       :: n
  real          :: from_dq 


!Balaji
  call mpp_clock_begin(cplOcnClock)
  call mpp_clock_begin(fluxOceanIceClock)

  select case (Ocean_Ice_Boundary%xtype)
  case(DIRECT)
     !same grid and domain decomp for ocean and ice    
     if( ASSOCIATED(Ocean_Ice_Boundary%u) )Ocean_Ice_Boundary%u = Ocean%u_surf
     if( ASSOCIATED(Ocean_Ice_Boundary%v) )Ocean_Ice_Boundary%v = Ocean%v_surf
     if( ASSOCIATED(Ocean_Ice_Boundary%t) )Ocean_Ice_Boundary%t = Ocean%t_surf
     if( ASSOCIATED(Ocean_Ice_Boundary%s) )Ocean_Ice_Boundary%s = Ocean%s_surf
     if( ASSOCIATED(Ocean_Ice_Boundary%sea_level) )Ocean_Ice_Boundary%sea_level = Ocean%sea_lev
     if( ASSOCIATED(Ocean_Ice_Boundary%frazil) ) then
        if(do_area_weighted_flux) then
           Ocean_Ice_Boundary%frazil = Ocean%frazil * Ocean%area 
           call divide_by_area(data=Ocean_Ice_Boundary%frazil, area=Ice%area)
        else
           Ocean_Ice_Boundary%frazil = Ocean%frazil
        endif
     endif

! Extra fluxes
     do n = 1, Ocean_Ice_Boundary%fields%num_bcs  !{
       do m = 1, Ocean_Ice_Boundary%fields%bc(n)%num_fields  !{
         if ( associated(Ocean_Ice_Boundary%fields%bc(n)%field(m)%values) ) then  !{
           Ocean_Ice_Boundary%fields%bc(n)%field(m)%values = Ocean%fields%bc(n)%field(m)%values
         endif  !}
       enddo  !} m
     enddo  !} n
  case(REDIST)
     !same grid, different domain decomp for ocean and ice    
     if( ASSOCIATED(Ocean_Ice_Boundary%u) )                     &
          call mpp_redistribute(Ocean%Domain, Ocean%u_surf, Ice%Domain, Ocean_Ice_Boundary%u)
     if( ASSOCIATED(Ocean_Ice_Boundary%v) )                     &
          call mpp_redistribute(Ocean%Domain, Ocean%v_surf, Ice%Domain, Ocean_Ice_Boundary%v)
     if( ASSOCIATED(Ocean_Ice_Boundary%t) )                     &
          call mpp_redistribute(Ocean%Domain, Ocean%t_surf, Ice%Domain, Ocean_Ice_Boundary%t)
     if( ASSOCIATED(Ocean_Ice_Boundary%s) )                     &
          call mpp_redistribute(Ocean%Domain, Ocean%s_surf, Ice%Domain, Ocean_Ice_Boundary%s)

     if( ASSOCIATED(Ocean_Ice_Boundary%sea_level) )             &
          call mpp_redistribute(Ocean%Domain, Ocean%sea_lev, Ice%Domain, Ocean_Ice_Boundary%sea_level)

     if( ASSOCIATED(Ocean_Ice_Boundary%frazil) ) then
        if(do_area_weighted_flux) then
           if(Ocean%is_ocean_pe)tmp = Ocean%frazil * Ocean%area 
           call mpp_redistribute( Ocean%Domain, tmp, Ice%Domain, Ocean_Ice_Boundary%frazil)
           if(Ice%pe) call divide_by_area(data=Ocean_Ice_Boundary%frazil, area=Ice%area)
        else
           call mpp_redistribute(Ocean%Domain, Ocean%frazil, Ice%Domain, Ocean_Ice_Boundary%frazil)
        endif
     endif

! Extra fluxes
     do n = 1, Ocean_Ice_Boundary%fields%num_bcs  !{
       do m = 1, Ocean_Ice_Boundary%fields%bc(n)%num_fields  !{
         if ( associated(Ocean_Ice_Boundary%fields%bc(n)%field(m)%values) ) then  !{
           call mpp_redistribute(Ocean%Domain, Ocean%fields%bc(n)%field(m)%values,    &
                Ice%Domain, Ocean_Ice_Boundary%fields%bc(n)%field(m)%values)
         endif  !}
       enddo  !} m
     enddo  !} n
  case DEFAULT
!   <ERROR MSG="Ocean_Ice_Boundary%xtype must be DIRECT or REDIST." STATUS="FATAL">
!     The value of variable xtype of ice_ocean_boundary_type data must be DIRECT or REDIST.
!   </ERROR>
     call mpp_error( FATAL, 'FLUX_OCEAN_TO_ICE: Ocean_Ice_Boundary%xtype must be DIRECT or REDIST.' )
  end select
  if( ice_pe )then
      call mpp_set_current_pelist(ice_pelist)

!Balaji: data_override moved here from coupler_main
      call data_override('ICE', 'u',         Ocean_Ice_Boundary%u,         Time)
      call data_override('ICE', 'v',         Ocean_Ice_Boundary%v,         Time)
      call data_override('ICE', 't',         Ocean_Ice_Boundary%t,         Time)
      call data_override('ICE', 's',         Ocean_Ice_Boundary%s,         Time)
      call data_override('ICE', 'frazil',    Ocean_Ice_Boundary%frazil,    Time)
      call data_override('ICE', 'sea_level', Ocean_Ice_Boundary%sea_level, Time)

! Extra fluxes
      do n = 1, Ocean_Ice_Boundary%fields%num_bcs  !{
         do m = 1, Ocean_Ice_Boundary%fields%bc(n)%num_fields  !{
            call data_override('ICE', Ocean_Ice_Boundary%fields%bc(n)%field(m)%name,    &
                 Ocean_Ice_Boundary%fields%bc(n)%field(m)%values, Time)
         enddo  !} m
      enddo  !} n

!
!       Perform diagnostic output for the ocean_ice_boundary fields
!

     do n = 1, Ocean_Ice_Boundary%fields%num_bcs  !{
       do m = 1, Ocean_Ice_Boundary%fields%bc(n)%num_fields  !{
           used = send_data(Ocean_Ice_Boundary%fields%bc(n)%field(m)%id_diag,                   &
                Ocean_Ice_Boundary%fields%bc(n)%field(m)%values, Time)
       enddo  !} m
     enddo  !} n
   endif

  if( ocn_pe )then
      call mpp_set_current_pelist(ocn_pelist)

!
!       Perform diagnostic output for the ocean fields
!

     do n = 1, Ocean%fields%num_bcs  !{
       do m = 1, Ocean%fields%bc(n)%num_fields  !{
         used = send_data(Ocean%fields%bc(n)%field(m)%id_diag,                                &
                Ocean%fields%bc(n)%field(m)%values, Time)
       enddo  !} m
     enddo  !} n
   endif

   call mpp_set_current_pelist()
  
  if ( id_ice_mask > 0 ) then
     allocate ( ex_ice_frac(n_xgrid_sfc) )
     ice_frac        = 1.
     ice_frac(:,:,1) = 0.
     ex_ice_frac     = 0.
     call put_to_xgrid (ice_frac, 'OCN', ex_ice_frac, xmap_sfc)
     call get_from_xgrid (diag_atm, 'ATM', ex_ice_frac, xmap_sfc)
     used = send_data ( id_ice_mask, diag_atm, Time )
     deallocate ( ex_ice_frac )
  endif

  if(Ice%pe) then
     ! frazil (already in J/m^2 so no need to multiply by Dt_cpl)
     from_dq = 4*PI*Radius*Radius * &
         & SUM( ice_cell_area * Ocean_Ice_Boundary%frazil )
     Ice_stock(ISTOCK_HEAT)%dq(ISTOCK_BOTTOM) = Ice_stock(ISTOCK_HEAT)%dq(ISTOCK_BOTTOM) - from_dq
     Ocn_stock(ISTOCK_HEAT)%dq(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_HEAT)%dq(ISTOCK_SIDE  ) + from_dq
  endif

!Balaji
  call mpp_clock_end(fluxOceanIceClock)
  call mpp_clock_end(cplOcnClock)
!-----------------------------------------------------------------------

  end subroutine flux_ocean_to_ice
! </SUBROUTINE>


!#######################################################################
! <SUBROUTINE NAME="flux_check_stocks">
!  <OVERVIEW>
!   Check stock values. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   Will print out any difference between the integrated flux (in time
!   and space) feeding into a component, and the stock stored in that
!   component.
!  </DESCRIPTION>

  subroutine flux_check_stocks(Time, Atm, Lnd, Ice, Ocn_state)

    type(time_type)       :: Time
    type(atmos_data_type), optional :: Atm
    type(land_data_type), optional  :: Lnd
    type(ice_data_type), optional   :: Ice
    type(ocean_state_type), optional, pointer :: Ocn_state

    real :: ref_value
    integer :: i, ier


    do i = 1, NELEMS

       if(present(Atm)) then
          ref_value = 0
          call Atm_stock_pe(Atm, index=i, value=ref_value)        
          if(i==ISTOCK_WATER .and. Atm%pe ) then
             ! decrease the Atm stock by the precip adjustment to reflect the fact that
             ! after an update_atmos_up call, the precip will be that of the future time step.
             ! Thus, the stock call will represent the (explicit ) precip at 
             ! the beginning of the preceding time step, and the (implicit) evap at the 
             ! end of the preceding time step
             call stock_integrate_2d(Atm%lprec + Atm%fprec, xmap=xmap_sfc, delta_t=Dt_atm, &
                  & radius=Radius, res=ATM_PRECIP_NEW, ier=ier)

             ref_value = ref_value + ATM_PRECIP_NEW
          endif
         
          Atm_stock(i)%q_now = ref_value
       endif

       if(present(Lnd)) then
          ref_value = 0
          call Lnd_stock_pe(Lnd, index=i, value=ref_value)
          Lnd_stock(i)%q_now = ref_value
       endif

       if(present(Ice)) then
          ref_value = 0
          call Ice_stock_pe(Ice, index=i, value=ref_value)
          Ice_stock(i)%q_now = ref_value
       endif

       if(present(Ocn_state)) then
          ref_value = 0
          call Ocean_stock_pe(Ocn_state, index=i, value=ref_value)
          Ocn_stock(i)%q_now = ref_value
       endif
    enddo

    call stocks_report(Time)


  end subroutine flux_check_stocks
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="flux_init_stocks">
!  <OVERVIEW>
!   Initialize stock values. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   This will call the various component stock_pe routines to store the 
!   the initial stock values.
!  </DESCRIPTION>

subroutine flux_init_stocks(Time, Atm, Lnd, Ice, Ocn_state)
  type(time_type) , intent(in) :: Time
  type(atmos_data_type) :: Atm
  type(land_data_type)  :: Lnd
  type(ice_data_type)   :: Ice
  type(ocean_state_type), pointer :: Ocn_state

  integer i, ier

  stocks_file=stdout()
! Divert output file for stocks if requested 
  if(mpp_pe()==mpp_root_pe() .and. divert_stocks_report) then
     call mpp_open( stocks_file, 'stocks.out', action=MPP_OVERWR, threading=MPP_SINGLE, &
          fileset=MPP_SINGLE, nohdrs=.TRUE. )       
  endif
  
    ! Initialize stock values
    do i = 1, NELEMS
       call Atm_stock_pe(   Atm , index=i, value=Atm_stock(i)%q_start)

       if(i==ISTOCK_WATER .and. Atm%pe ) then
          call stock_integrate_2d(Atm%lprec + Atm%fprec, xmap=xmap_sfc, & 
               delta_t=Dt_atm, radius=Radius, res=ATM_PRECIP_NEW, ier=ier) 
          
          Atm_stock(i)%q_start = Atm_stock(i)%q_start + ATM_PRECIP_NEW
       endif

       call Lnd_stock_pe(   Lnd , index=i, value=Lnd_stock(i)%q_start)
       call Ice_stock_pe(   Ice , index=i, value=Ice_stock(i)%q_start)
       call Ocean_stock_pe( Ocn_state , index=i, value=Ocn_stock(i)%q_start)
    enddo


    call stocks_report_init(Time)


end subroutine flux_init_stocks
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="generate_sfc_xgrid">
!  <OVERVIEW>
!   Optimizes the exchange grids by eliminating land and ice partitions with no data. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   Optimizes the exchange grids by eliminating land and ice partitions with no data. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call generate_sfc_xgrid( Land, Ice )
!		
!  </TEMPLATE>
!  <IN NAME=" Land" TYPE="land_data_type">
!   A derived data type to specify land boundary data.
!  </IN>
!  <IN NAME="Ice" TYPE="ice_data_type">
!  A derived data type to specify ice boundary data.
!  </IN>
!
subroutine generate_sfc_xgrid( Land, Ice )
! subroutine to regenerate exchange grid eliminating side 2 tiles with 0 frac area
    type(land_data_type), intent(in) :: Land
    type(ice_data_type),  intent(in) :: Ice

    integer :: isc, iec, jsc, jec

!Balaji
  call mpp_clock_begin(cplClock)
  call mpp_clock_begin(regenClock)

  call mpp_get_compute_domain(Ice%Domain, isc, iec, jsc, jec)

  call set_frac_area (Ice%part_size(isc:iec,jsc:jec,:) , 'OCN', xmap_sfc)
  call set_frac_area (Land%tile_size, 'LND', xmap_sfc)
  n_xgrid_sfc = max(xgrid_count(xmap_sfc),1)

!Balaji
  call mpp_clock_end(regenClock)
  call mpp_clock_end(cplClock)
  return
end subroutine generate_sfc_xgrid
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="flux_up_to_atmos">
!  <OVERVIEW>
!   Corrects the fluxes for consistency with the new surface temperatures in land 
!   and ice models.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Corrects the fluxes for consistency with the new surface temperatures in land 
!   and ice models. Final increments for temperature and specific humidity in the 
!   lowest atmospheric layer are computed and returned to the atmospheric model
!   so that it can finalize the increments in the rest of the atmosphere. 
!  <PRE>
!
!   The following elements of the land_ice_atmos_boundary_type are computed:
!        dt_t  = temperature change at the lowest
!                 atmospheric level (deg k)
!        dt_q  = specific humidity change at the lowest
!                 atmospheric level (kg/kg)
!  </PRE>
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_up_to_atmos ( Time, Land, Ice, Land_Ice_Atmos_Boundary, Land_boundary, Ice_boundary )
!		
!  </TEMPLATE>
!  <IN NAME=" Time" TYPE="time_type">
!   Current time.
!  </IN>
!  <INOUT NAME="Land" TYPE="land_data_type">
!   A derived data type to specify land boundary data.
!  </INOUT>
!  <INOUT NAME="Ice" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </INOUT>
!  <INOUT NAME="Land_Ice_Atmos_Boundary" TYPE="land_ice_atmos_boundary_type">
!   A derived data type to specify properties and fluxes passed from exchange grid to
!   the atmosphere, land and ice. 
!  </INOUT>
!
subroutine flux_up_to_atmos ( Time, Land, Ice, Land_Ice_Atmos_Boundary, Land_boundary, Ice_boundary )

  type(time_type),      intent(in)  :: Time
  type(land_data_type), intent(inout)  :: Land
  type(ice_data_type),  intent(inout)  :: Ice
  type(land_ice_atmos_boundary_type), intent(inout) :: Land_Ice_Atmos_Boundary
  type(atmos_land_boundary_type) :: Land_boundary
  type(atmos_ice_boundary_type)  :: Ice_boundary

  real, dimension(n_xgrid_sfc) ::  &
       ex_t_surf_new, &
       ex_dt_t_surf,  &
       ex_delta_t_n,  &
       ex_t_ca_new,   &
       ex_dt_t_ca
  real, dimension(n_xgrid_sfc,n_exch_tr) :: &
       ex_tr_surf_new,    & ! updated tracer values at the surface
       ex_dt_tr_surf,     & ! tendency of tracers at the surface
       ex_delta_tr_n
! jgj: added for co2_surf diagnostic 
  real, dimension(n_xgrid_sfc) :: &
       ex_co2_surf_dvmr   ! updated CO2 tracer values at the surface (dry vmr)

  real, dimension(size(Land_Ice_Atmos_Boundary%dt_t,1),size(Land_Ice_Atmos_Boundary%dt_t,2)) :: diag_atm, &
       evap_atm
  real, dimension(size(Land_boundary%lprec,1), size(Land_boundary%lprec,2), size(Land_boundary%lprec,3)) :: data_lnd, diag_land
  real, dimension(size(Ice_boundary%lprec,1), size(Ice_boundary%lprec,2), size(Ice_boundary%lprec,3)) :: data_ice
  logical :: used

  integer :: tr       ! tracer index
  character(32) :: tr_name ! tracer name
  integer :: n, i, m, ier


  !Balaji
  call mpp_clock_begin(cplClock)
  call mpp_clock_begin(fluxAtmUpClock)
  !-----------------------------------------------------------------------
  !Balaji: data_override calls moved here from coupler_main
  call data_override ( 'ICE', 't_surf', Ice%t_surf,  Time)
  call data_override ( 'LND', 't_ca',   Land%t_ca,   Time)
  call data_override ( 'LND', 't_surf', Land%t_surf, Time)
  do tr = 1, n_lnd_tr
     call get_tracer_names( MODEL_LAND, tr, tr_name )
     call data_override('LND', trim(tr_name)//'_surf', Land%tr(:,:,:,tr), Time)
  enddo

  !----- compute surface temperature change -----

  ex_t_surf_new = 200.0

  call put_to_xgrid (Ice%t_surf,  'OCN', ex_t_surf_new, xmap_sfc)
  ex_t_ca_new = ex_t_surf_new  ! since it is the same thing over oceans
  call put_to_xgrid (Land%t_ca,   'LND', ex_t_ca_new,   xmap_sfc)
  call put_to_xgrid (Land%t_surf, 'LND', ex_t_surf_new, xmap_sfc)

  !  call escomp(ex_t_ca_new, ex_q_surf_new)
  !  ex_q_surf_new  = d622*ex_q_surf_new/(ex_p_surf-d378*ex_q_surf_new) 
  !  call put_to_xgrid (Land%q_ca, 'LND', ex_q_surf_new, xmap_sfc)

#ifdef SCM
  if (do_specified_flux .and. do_specified_land) then
       ex_t_surf_new = ex_t_surf
       ex_t_ca_new   = ex_t_ca
  endif
#endif

  where (ex_avail)
     ex_dt_t_ca   = ex_t_ca_new   - ex_t_ca   ! changes in near-surface T
     ex_dt_t_surf = ex_t_surf_new - ex_t_surf ! changes in radiative T
  endwhere

  if (do_forecast) then
     where (ex_avail(:) .and. (.not.ex_land(:)))
        ex_dt_t_ca  (:) = 0.
        ex_dt_t_surf(:) = 0.
     end where
  end if

  !-----------------------------------------------------------------------
  !-----  adjust fluxes and atmospheric increments for 
  !-----  implicit dependence on surface temperature -----
  do tr = 1,n_exch_tr
     ! set up updated surface tracer field so that flux to atmos for absent 
     ! tracers is zero
     do i = 1, size(ex_avail(:))
        if(.not.ex_avail(i)) cycle
        if (ex_dfdtr_surf(i,tr)/=0) then
           ex_dt_tr_surf(i,tr) = -ex_flux_tr(i,tr)/ex_dfdtr_surf(i,tr)
        else
           ex_dt_tr_surf(i,tr) = 0
        endif
        ex_tr_surf_new(i,tr) = ex_tr_surf(i,tr)+ex_dt_tr_surf(i,tr)
     enddo
     ! get all tracers available from land, and calculate changes in near-tracer field
     n = tr_table(tr)%lnd
     if(n /= NO_TRACER ) then
        call put_to_xgrid ( Land%tr(:,:,:,n), 'LND', ex_tr_surf_new(:,tr), xmap_sfc )
     endif

     ! get all tracers available from ocean here 

     ! update tracer tendencies in the atmosphere
     where (ex_avail)
        ex_dt_tr_surf(:,tr) = ex_tr_surf_new(:,tr) - ex_tr_surf(:,tr)
        ex_delta_tr_n(:,tr) = ex_f_tr_delt_n(:,tr) + ex_dt_tr_surf(:,tr) * ex_e_tr_n(:,tr)
        ex_flux_tr(:,tr)    = ex_flux_tr(:,tr)     + ex_dt_tr_surf(:,tr) * ex_dfdtr_surf(:,tr)
     endwhere
  enddo

  ! re-calculate fluxes of specific humidity over ocean
  where (ex_avail.and..not.ex_land) 
     ! note that in this region (over ocean) ex_dt_t_surf == ex_dt_t_ca
     ex_delta_tr_n(:,isphum)  = ex_f_tr_delt_n(:,isphum) + ex_dt_t_surf * ex_e_q_n
     ex_flux_tr(:,isphum)     = ex_flux_tr(:,isphum)     + ex_dt_t_surf * ex_dedt_surf
  endwhere

  do tr=1,n_exch_tr
     ! get updated tracer tendency on the atmospheic grid
     n=tr_table(tr)%atm
     call get_from_xgrid (Land_Ice_Atmos_Boundary%dt_tr(:,:,n), 'ATM', ex_delta_tr_n(:,tr), xmap_sfc)
  enddo

  ex_delta_t_n = 0.0

  where(ex_avail)
     ex_flux_t     = ex_flux_t  + ex_dt_t_ca   * ex_dhdt_surf
     ex_flux_lw    = ex_flux_lw - ex_dt_t_surf * ex_drdt_surf
     ex_delta_t_n  = ex_f_t_delt_n  + ex_dt_t_ca*ex_e_t_n
  endwhere

  !-----------------------------------------------------------------------
  !---- get mean quantites on atmospheric grid ----

  call get_from_xgrid (Land_Ice_Atmos_Boundary%dt_t, 'ATM', ex_delta_t_n, xmap_sfc)

  !=======================================================================
  !-------------------- diagnostics section ------------------------------

  !------- new surface temperature -----------
  if ( id_t_surf > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_t_surf_new, xmap_sfc)
     used = send_data ( id_t_surf, diag_atm, Time )
  endif


  ! + slm, Mar 27 2002
  ! ------ new canopy temperature --------
  !   NOTE, that in the particular case of LM2 t_ca is identical to t_surf,
  !   but this will be changed in future version of the land madel
  if ( id_t_ca > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_t_ca_new, xmap_sfc)
     used = send_data ( id_t_ca, diag_atm, Time )
  endif

  !------- updated surface tracer fields ------
  do tr=1,n_exch_tr
     call get_tracer_names( MODEL_ATMOS, tr_table(tr)%atm, tr_name )
     if ( id_tr_surf(tr) > 0 ) then
        call get_from_xgrid (diag_atm, 'ATM', ex_tr_surf_new(:,tr), xmap_sfc)
        used = send_data ( id_tr_surf(tr), diag_atm, Time )
     endif
!!jgj:  add dryvmr co2_surf
! - slm Mar 25, 2010: moved to resolve interdependence of diagnostic fields
     if ( id_co2_surf_dvmr > 0 .and. lowercase(trim(tr_name))=='co2') then
       ex_co2_surf_dvmr = (ex_tr_surf_new(:,tr) / (1.0 - ex_tr_surf_new(:,isphum))) * WTMAIR/WTMCO2
       call get_from_xgrid (diag_atm, 'ATM', ex_co2_surf_dvmr, xmap_sfc)
       used = send_data ( id_co2_surf_dvmr, diag_atm, Time )
     endif
  enddo

  !------- sensible heat flux -----------
  if ( id_t_flux > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_flux_t, xmap_sfc)
     used = send_data ( id_t_flux, diag_atm, Time )
  endif

  !------- net longwave flux -----------
  if ( id_r_flux > 0 ) then
     call get_from_xgrid (diag_atm, 'ATM', ex_flux_lw, xmap_sfc)
     used = send_data ( id_r_flux, diag_atm, Time )
  endif

  !------- tracer fluxes ------------
  ! tr_mol_flux diagnostic will be correct for co2 tracer only. 
  ! will need update code to use correct molar mass for tracers other than co2
  do tr=1,n_exch_tr
     if ( id_tr_flux(tr) > 0 .or. id_tr_mol_flux(tr) > 0 ) then
        call get_from_xgrid (diag_atm, 'ATM', ex_flux_tr(:,tr), xmap_sfc)
        if (id_tr_flux(tr) > 0 ) &
            used = send_data ( id_tr_flux(tr), diag_atm, Time )
        if (id_tr_mol_flux(tr) > 0 ) &
            used = send_data ( id_tr_mol_flux(tr), diag_atm*1000./WTMCO2, Time)
     endif
  enddo

  !-----------------------------------------------------------------------
  !---- accumulate global integral of evaporation (mm/day) -----
  call get_from_xgrid (evap_atm, 'ATM', ex_flux_tr(:,isphum), xmap_sfc)
  if( id_q_flux > 0 ) used = send_data ( id_q_flux, evap_atm, Time)
  if( id_q_flux_land > 0 ) then
     call get_from_xgrid (diag_land, 'LND', ex_flux_tr(:,isphum), xmap_sfc)
     used = send_tile_averaged_data(id_q_flux_land, diag_land, &
          Land%tile_size, Time, mask=Land%mask)
  endif
  call sum_diag_integral_field ('evap', evap_atm*86400.)

  ! compute stock changes

  call get_from_xgrid(data_lnd, 'LND', ex_flux_tr(:,isphum), xmap_sfc)

  ! Lnd -> Atm (evap)
  call stock_move( &
       & TO   = Atm_stock(ISTOCK_WATER), &
       & FROM = Lnd_stock(ISTOCK_WATER), &
       & DATA = data_lnd, &
       & grid_index=X1_GRID_LND, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & to_side=ISTOCK_SIDE, from_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move EVAP (Lnd->ATm) ')

  ! Lnd -> Atm (heat lost through evap)
  call stock_move( &
       & TO   = Atm_stock(ISTOCK_HEAT), &
       & FROM = Lnd_stock(ISTOCK_HEAT), &
       & DATA = data_lnd * HLV, &
       & grid_index=X1_GRID_LND, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & to_side=ISTOCK_SIDE, from_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move EVAP*HLV (Lnd->ATm) ')

  call get_from_xgrid(data_ice, 'OCN', ex_flux_tr(:,isphum), xmap_sfc)

  ! Ice -> Atm (evap)
  call stock_move( &
       & TO   = Atm_stock(ISTOCK_WATER), &
       & FROM = Ice_stock(ISTOCK_WATER), &
       & DATA = data_ice, &
       & grid_index=X1_GRID_ICE, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & to_side=ISTOCK_TOP, from_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move EVAP (Ice->ATm) ')

  ! Ice -> Atm (heat lost through evap)
  call stock_move( &
       & TO   = Atm_stock(ISTOCK_HEAT), &
       & FROM = Ice_stock(ISTOCK_HEAT), &
       & DATA = data_ice * HLV, &
       & grid_index=X1_GRID_ICE, &
       & xmap=xmap_sfc, &
       & delta_t=Dt_atm, &
       & to_side=ISTOCK_TOP, from_side=ISTOCK_TOP, &
       & radius=Radius, ier=ier, verbose='stock move EVAP*HLV (Ice->ATm) ')

  !=======================================================================
  !---- deallocate module storage ----
  deallocate ( &
       ex_t_surf   ,  &
       ex_t_surf_miz, &
       ex_p_surf   ,  &
       ex_slp      ,  &
       ex_t_ca     ,  &
       ex_dhdt_surf,  &
       ex_dedt_surf,  &
       ex_dqsatdt_surf,  &
       ex_drdt_surf,  &
       ex_dhdt_atm ,  &
       ex_flux_t   ,  &
       ex_flux_lw  ,  &
       ex_drag_q   ,  &
       ex_avail    ,  &
       ex_f_t_delt_n, &
       ex_tr_surf  ,  &
       
  ex_dfdtr_surf  , &
       ex_dfdtr_atm   , &
       ex_flux_tr     , &
       ex_f_tr_delt_n , &
       ex_e_tr_n      , &
       
  ex_e_t_n    ,  &
       ex_e_q_n    ,  &
       ! values added for LM3
       ex_cd_t     ,  &
       ex_cd_m     ,  &
       ex_b_star   ,  &
       ex_u_star   ,  &
       ex_wind     ,  &
       ex_z_atm    ,  &
       
  ex_land        )

#ifdef SCM
  deallocate ( &
       ex_dhdt_surf_forland, &
       ex_dedt_surf_forland, &
       ex_dedq_surf_forland  )
#endif

! Extra fluxes
  do n = 1, ex_gas_fields_ice%num_bcs  !{
     do m = 1, ex_gas_fields_ice%bc(n)%num_fields  !{
        deallocate ( ex_gas_fields_ice%bc(n)%field(m)%values )
        nullify ( ex_gas_fields_ice%bc(n)%field(m)%values )
     enddo  !} m
  enddo  !} n

  do n = 1, ex_gas_fields_atm%num_bcs  !{
     do m = 1, ex_gas_fields_atm%bc(n)%num_fields  !{
        deallocate ( ex_gas_fields_atm%bc(n)%field(m)%values )
        nullify ( ex_gas_fields_atm%bc(n)%field(m)%values )
     enddo  !} m
  enddo  !} n

  do n = 1, ex_gas_fluxes%num_bcs  !{
     do m = 1, ex_gas_fluxes%bc(n)%num_fields  !{
        deallocate ( ex_gas_fluxes%bc(n)%field(m)%values )
        nullify ( ex_gas_fluxes%bc(n)%field(m)%values )
     enddo  !} m
  enddo  !} n

!Balaji
  call mpp_clock_end(fluxAtmUpClock)
  call mpp_clock_end(cplClock)

!-----------------------------------------------------------------------

end subroutine flux_up_to_atmos
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="flux_ice_to_ocean_stocks">
!  <OVERVIEW>
!   Updates Ice and Ocean stocks.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Integrate the fluxes over the surface and in time. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_ice_to_ocean_stocks ( Ice )
!		
!  </TEMPLATE>
!  <IN NAME=" Time" TYPE="ice_data_type">
!   A derived data type to specify ice boundary data.
!  </IN>

  subroutine flux_ice_to_ocean_stocks(Ice)

    type(ice_data_type),   intent(in)  :: Ice

    real           :: from_dq

    ! fluxes from ice -> ocean, integrate over surface and in time 

    ! precip - evap
    from_dq = 4*PI*Radius*Radius * Dt_cpl * &
         & SUM( ice_cell_area * (Ice%lprec+Ice%fprec-Ice%flux_q) )
    Ice_stock(ISTOCK_WATER)%dq(ISTOCK_BOTTOM) = Ice_stock(ISTOCK_WATER)%dq(ISTOCK_BOTTOM) - from_dq
    Ocn_stock(ISTOCK_WATER)%dq(ISTOCK_TOP   ) = Ocn_stock(ISTOCK_WATER)%dq(ISTOCK_TOP   ) + from_dq

    ! river
    from_dq = 4*PI*Radius*Radius * Dt_cpl * &
         & SUM( ice_cell_area * (Ice%runoff + Ice%calving) )
    Ice_stock(ISTOCK_WATER)%dq(ISTOCK_BOTTOM) = Ice_stock(ISTOCK_WATER)%dq(ISTOCK_BOTTOM) - from_dq
    Ocn_stock(ISTOCK_WATER)%dq(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_WATER)%dq(ISTOCK_SIDE  ) + from_dq

    ! sensible heat + shortwave + longwave + latent heat
    from_dq = 4*PI*Radius*Radius * Dt_cpl * &
         & SUM( ice_cell_area * ( &
         &   Ice%flux_sw_vis_dir+Ice%flux_sw_vis_dif &
         & + Ice%flux_sw_nir_dir+Ice%flux_sw_nir_dif + Ice%flux_lw &
         & - (Ice%fprec + Ice%calving)*HLF - Ice%flux_t - Ice%flux_q*HLV) )
    Ice_stock(ISTOCK_HEAT)%dq(ISTOCK_BOTTOM) = Ice_stock(ISTOCK_HEAT)%dq(ISTOCK_BOTTOM) - from_dq
    Ocn_stock(ISTOCK_HEAT)%dq(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_HEAT)%dq(ISTOCK_SIDE  ) + from_dq

    ! heat carried by river + pme (assuming reference temperature of 0 degC and river/pme temp = surface temp)
    ! Note: it does not matter what the ref temperature is but it must be consistent with that in OCN and ICE
    from_dq = 4*PI*Radius*Radius * Dt_cpl * &
         & SUM( ice_cell_area * ( &
         & (Ice%lprec+Ice%fprec-Ice%flux_q + Ice%runoff+Ice%calving)*CP_OCEAN*(Ice%t_surf(:,:,1) - 273.15)) )
    Ice_stock(ISTOCK_HEAT)%dq(ISTOCK_BOTTOM) = Ice_stock(ISTOCK_HEAT)%dq(ISTOCK_BOTTOM) - from_dq
    Ocn_stock(ISTOCK_HEAT)%dq(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_HEAT)%dq(ISTOCK_SIDE  ) + from_dq

    !SALT flux
    from_dq = Dt_cpl* SUM( ice_cell_area * ( -Ice%flux_salt )) *4*PI*Radius*Radius
    Ice_stock(ISTOCK_SALT)%dq(ISTOCK_BOTTOM) = Ice_stock(ISTOCK_SALT)%dq(ISTOCK_BOTTOM) - from_dq
    Ocn_stock(ISTOCK_SALT)%dq(ISTOCK_TOP   ) = Ocn_stock(ISTOCK_SALT)%dq(ISTOCK_TOP   ) + from_dq


  end subroutine flux_ice_to_ocean_stocks
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="flux_ocean_from_ice_stocks">
!  <OVERVIEW>
!   Updates Ocean stocks due to input that the Ocean model gets.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This subroutine updates the stocks of Ocean by the amount of input that the Ocean gets from Ice component.
!   Unlike subroutine flux_ice_to_ocean_stocks() that uses Ice%fluxes to update the stocks due to the amount of output from Ice
!   this subroutine uses Ice_Ocean_boundary%fluxes to calculate the amount of input to the Ocean. These fluxes are the ones
!   that Ocean model uses internally to calculate its budgets. Hence there should be no difference between this input and what 
!   Ocean model internal diagnostics uses. 
!   This bypasses the possible mismatch in cell areas between Ice and Ocean in diagnosing the stocks of Ocean
!   and should report a conserving Ocean component regardless of the glitches in fluxes.
!
!   The use of this subroutine in conjunction with  subroutine flux_ice_to_ocean_stocks() will also allow to directly
!   diagnose the amount "stocks lost in exchange" between Ice and Ocean
!
!  </DESCRIPTION>
!  <TEMPLATE>
!   call flux_ocean_from_ice_stocks(ocean_state,Ocean,Ice_Ocean_boundary)
!		
!  </TEMPLATE>
  subroutine flux_ocean_from_ice_stocks(ocean_state,Ocean,Ice_Ocean_boundary)
    type(ocean_state_type),        pointer    :: ocean_state
    type(ocean_public_type),       intent(in) :: Ocean
    type(ice_ocean_boundary_type), intent(in) :: Ice_Ocean_Boundary
    real    :: from_dq, cp_ocn
    real, dimension(:,:), allocatable :: ocean_cell_area, wet, t_surf, t_pme, t_calving, t_runoff, btfHeat
    integer :: isc,iec,jsc,jec


    call mpp_get_compute_domain(Ocean%Domain, isc, iec, jsc, jec)
    allocate(ocean_cell_area(isc:iec, jsc:jec), t_surf(isc:iec, jsc:jec), wet(isc:iec, jsc:jec))
    allocate(t_pme(isc:iec, jsc:jec), t_calving(isc:iec, jsc:jec),t_runoff(isc:iec, jsc:jec),btfHeat(isc:iec, jsc:jec))
    call ocean_model_data_get(ocean_state,Ocean,'area'  , ocean_cell_area,isc,jsc)
    call ocean_model_data_get(ocean_state,Ocean,'mask', wet,isc,jsc )
    call ocean_model_data_get(ocean_state,Ocean,'t_surf', t_surf,isc,jsc )
    call ocean_model_data_get(ocean_state,Ocean,'t_runoff', t_runoff,isc,jsc )
    call ocean_model_data_get(ocean_state,Ocean,'t_pme', t_pme,isc,jsc )
    call ocean_model_data_get(ocean_state,Ocean,'t_calving', t_calving,isc,jsc )
    call ocean_model_data_get(ocean_state,Ocean,'btfHeat', btfHeat,isc,jsc )
    call ocean_model_data_get(ocean_state,Ocean,'c_p', cp_ocn )


    ! fluxes from ice -> ocean, integrate over surface and in time 

    ! precip - evap
    from_dq = SUM( ocean_cell_area * wet * (Ice_Ocean_Boundary%lprec+Ice_Ocean_Boundary%fprec-Ice_Ocean_Boundary%q_flux) )
    Ocn_stock(ISTOCK_WATER)%dq_IN(ISTOCK_TOP   ) = Ocn_stock(ISTOCK_WATER)%dq_IN(ISTOCK_TOP   ) + from_dq * Dt_cpl

    from_dq = SUM( ocean_cell_area * wet * (Ice_Ocean_Boundary%runoff+Ice_Ocean_Boundary%calving) )
    Ocn_stock(ISTOCK_WATER)%dq_IN(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_WATER)%dq_IN(ISTOCK_SIDE  ) + from_dq * Dt_cpl

    ! sensible heat + shortwave + longwave + latent heat

    from_dq = SUM( ocean_cell_area * wet *( Ice_Ocean_Boundary%sw_flux_vis_dir + Ice_Ocean_Boundary%sw_flux_vis_dif &
                                           +Ice_Ocean_Boundary%sw_flux_nir_dir + Ice_Ocean_Boundary%sw_flux_nir_dif &
                                           +Ice_Ocean_Boundary%lw_flux &
                                           - (Ice_Ocean_Boundary%fprec + Ice_Ocean_Boundary%calving)*HLF &
                                           - Ice_Ocean_Boundary%t_flux - Ice_Ocean_Boundary%q_flux*HLV ))

    Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_SIDE  ) + from_dq * Dt_cpl

    ! heat carried by river + pme (assuming reference temperature of 0 degC and river/pme temp = surface temp)
    ! Note: it does not matter what the ref temperature is but it must be consistent with that in OCN and ICE

    from_dq = SUM( ocean_cell_area * wet * cp_ocn *&
                              ((Ice_Ocean_Boundary%lprec+Ice_Ocean_Boundary%fprec-Ice_Ocean_Boundary%q_flux)*t_pme &
                               +Ice_Ocean_Boundary%calving * t_calving &
                               +Ice_Ocean_Boundary%runoff  * t_runoff  ))       
    
    Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_SIDE ) + from_dq * Dt_cpl

!   Bottom heat flux
    from_dq = - SUM( ocean_cell_area * wet * btfHeat)
    
    Ocn_stock(ISTOCK_HEAT)%dq_IN( ISTOCK_BOTTOM ) = Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_BOTTOM ) + from_dq * Dt_cpl

!   Frazil heat

     from_dq =  SUM( ocean_cell_area *wet * Ocean%frazil )
     Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_SIDE  ) = Ocn_stock(ISTOCK_HEAT)%dq_IN(ISTOCK_SIDE ) + from_dq

    !SALT flux
    from_dq = SUM( ocean_cell_area * wet * ( -Ice_Ocean_Boundary%salt_flux))  
    Ocn_stock(ISTOCK_SALT)%dq_IN(ISTOCK_TOP  ) = Ocn_stock(ISTOCK_SALT)%dq_IN(ISTOCK_TOP   ) + from_dq  * Dt_cpl


  end subroutine flux_ocean_from_ice_stocks
! </SUBROUTINE>


!#######################################################################

subroutine put_logical_to_real (mask, id, ex_mask, xmap)

  logical         , intent(in)    :: mask(:,:,:)
  character(len=3), intent(in)    :: id
  real            , intent(inout) :: ex_mask(:)
  type(xmap_type), intent(inout) :: xmap

  !-----------------------------------------------------------------------
  !    puts land or ice model masks (with partitions) onto the
  !    exchange grid as a real array (1.=true, 0.=false)
  !-----------------------------------------------------------------------

  real, dimension(size(mask,1),size(mask,2),size(mask,3)) :: rmask
  
  where (mask)
     rmask = 1.0
  elsewhere
     rmask = 0.0
  endwhere

  call put_to_xgrid(rmask, id, ex_mask, xmap)

end subroutine put_logical_to_real

!#######################################################################

subroutine diag_field_init ( Time, atmos_axes, land_axes )

  type(time_type), intent(in) :: Time
  integer,         intent(in) :: atmos_axes(2)
  integer,         intent(in) :: land_axes(2)

  integer :: iref
  character(len=6) :: label_zm, label_zh
  real, dimension(2) :: trange = (/  100., 400. /), &
       vrange = (/ -400., 400. /), &
       frange = (/ -0.01, 1.01 /)
  character(len=32)  :: name, units ! name of the tracer
  character(len=128) :: longname    ! long name of the tracer
  integer            :: tr          ! tracer index
!-----------------------------------------------------------------------
!  initializes diagnostic fields that may be output from this module
!  (the id numbers may be referenced anywhere in this module)
!-----------------------------------------------------------------------

  !------ labels for diagnostics -------
  !  (z_ref_mom, z_ref_heat are namelist variables)

  iref = int(z_ref_mom+0.5)
  if ( real(iref) == z_ref_mom ) then
     write (label_zm,105) iref
     if (iref < 10) write (label_zm,100) iref
  else
     write (label_zm,110) z_ref_mom
  endif

  iref = int(z_ref_heat+0.5)
  if ( real(iref) == z_ref_heat ) then
     write (label_zh,105) iref
     if (iref < 10) write (label_zh,100) iref
  else
     write (label_zh,110) z_ref_heat
  endif

100 format (i1,' m',3x)
105 format (i2,' m',2x)
110 format (f4.1,' m')

  !--------- initialize static diagnostic fields --------------------

  id_land_mask = &
       register_static_field ( mod_name, 'land_mask', atmos_axes,  &
       'fractional amount of land', 'none', &
       range=frange, interp_method = "conserve_order1" )
  
  !--------- initialize diagnostic fields --------------------

  id_ice_mask = &
       register_diag_field ( mod_name, 'ice_mask', atmos_axes, Time, &
       'fractional amount of sea ice', 'none',  &
       range=frange, interp_method = "conserve_order1" )

  id_sst = &
       register_diag_field ( mod_name, 'sst', atmos_axes, Time, &
       'sea surface temperature', 'deg_k', range=(/271.,350./), &
       mask_variant=.true., missing_value=0.0 )
  
  id_wind = &
       register_diag_field ( mod_name, 'wind', atmos_axes, Time, &
       'wind speed for flux calculations', 'm/s', &
       range=(/0.,vrange(2)/) )
  
  id_drag_moist = &
       register_diag_field ( mod_name, 'drag_moist', atmos_axes, Time, &
       'drag coeff for moisture',    'none'     )
  
  id_drag_heat  = &
       register_diag_field ( mod_name, 'drag_heat', atmos_axes, Time, &
       'drag coeff for heat',    'none'     )
  
  id_drag_mom   = &
       register_diag_field ( mod_name, 'drag_mom',  atmos_axes, Time, &
       'drag coeff for momentum',     'none'     )
  
  id_rough_moist = &
       register_diag_field ( mod_name, 'rough_moist', atmos_axes, Time, &
       'surface roughness for moisture',  'm'  )

  id_rough_heat = &
       register_diag_field ( mod_name, 'rough_heat', atmos_axes, Time, &
       'surface roughness for heat',  'm'  )

  id_rough_mom  = &
       register_diag_field ( mod_name, 'rough_mom',  atmos_axes, Time, &
       'surface roughness for momentum',  'm'  )

  id_u_star     = &
       register_diag_field ( mod_name, 'u_star',     atmos_axes, Time, &
       'friction velocity',   'm/s'   )

  id_b_star     = &
       register_diag_field ( mod_name, 'b_star',     atmos_axes, Time, &
       'buoyancy scale',      'm/s2'   )

  id_q_star     = &
       register_diag_field ( mod_name, 'q_star',     atmos_axes, Time, &
       'moisture scale',      'kg water/kg air'   )

  id_u_flux     = &
       register_diag_field ( mod_name, 'tau_x',      atmos_axes, Time, &
       'zonal wind stress',     'pa'   )

  id_v_flux     = &
       register_diag_field ( mod_name, 'tau_y',      atmos_axes, Time, &
       'meridional wind stress',     'pa'   )

  id_t_surf     = &
       register_diag_field ( mod_name, 't_surf',     atmos_axes, Time, &
       'surface temperature',    'deg_k', &
       range=trange    )

  ! + slm, Mar 25, 2002 -- add diagnositcs for t_ca, q_ca, and q_atm
  id_t_ca       = &
       register_diag_field ( mod_name, 't_ca',     atmos_axes, Time, &
       'canopy air temperature',    'deg_k', &
       range=trange    )

  ! - slm, Mar 25, 2002
  id_z_atm      = &
       register_diag_field ( mod_name, 'z_atm',     atmos_axes, Time, &
       'height of btm level',    'm')

  id_p_atm      = &
       register_diag_field ( mod_name, 'p_atm',     atmos_axes, Time, &
       'pressure at btm level',    'pa')

  ! - bw, Mar 25, 2002 -- added diagnostic slp
  id_slp      = &
       register_diag_field ( mod_name, 'slp',      atmos_axes, Time, &
       'sea level pressure',    'pa')

  id_gust       = &
       register_diag_field ( mod_name, 'gust',     atmos_axes, Time, &
       'gust scale',    'm/s')

  id_t_flux     = &
       register_diag_field ( mod_name, 'shflx',      atmos_axes, Time, &
       'sensible heat flux',     'w/m2'    )

  id_r_flux     = &
       register_diag_field ( mod_name, 'lwflx',      atmos_axes, Time, &
       'net (down-up) longwave flux',   'w/m2'    )

  id_t_atm      = &
       register_diag_field ( mod_name, 't_atm',      atmos_axes, Time, &
       'temperature at btm level',    'deg_k', &
       range=trange     )

  id_u_atm      = &
       register_diag_field ( mod_name, 'u_atm',      atmos_axes, Time, &
       'u wind component at btm level',  'm/s', &
       range=vrange    )

  id_v_atm      = &
       register_diag_field ( mod_name, 'v_atm',      atmos_axes, Time, &
       'v wind component at btm level',  'm/s', &
       range=vrange    )

  id_t_ref      = &
       register_diag_field ( mod_name, 't_ref',      atmos_axes, Time, &
       'temperature at '//label_zh, 'deg_k' , &
       range=trange      )

  id_rh_ref     = &
       register_diag_field ( mod_name, 'rh_ref',     atmos_axes, Time,   &
       'relative humidity at '//label_zh, 'percent' )

  id_rh_ref_cmip = &
       register_diag_field ( mod_name, 'rh_ref_cmip',     atmos_axes, Time,   &
       'relative humidity at '//label_zh, 'percent' )

  id_u_ref      = &
       register_diag_field ( mod_name, 'u_ref',      atmos_axes, Time, &
       'zonal wind component at '//label_zm,  'm/s', &
       range=vrange )

  id_v_ref      = &
       register_diag_field ( mod_name, 'v_ref',      atmos_axes, Time,     &
       'meridional wind component at '//label_zm, 'm/s', &
       range=vrange )

  id_wind_ref = &
       register_diag_field ( mod_name, 'wind_ref',   atmos_axes, Time,     &
       'absolute value of wind at '//label_zm, 'm/s', &
       range=vrange )

  id_del_h      = &
       register_diag_field ( mod_name, 'del_h',      atmos_axes, Time,  &
       'ref height interp factor for heat', 'none' )
  id_del_m      = &
       register_diag_field ( mod_name, 'del_m',      atmos_axes, Time,     &
       'ref height interp factor for momentum','none' )
  id_del_q      = &
       register_diag_field ( mod_name, 'del_q',      atmos_axes, Time,     &
       'ref height interp factor for moisture','none' )

  ! + slm Jun 02, 2002 -- diagnostics of reference values over the land
  id_t_ref_land = &
       register_diag_field ( mod_name, 't_ref_land', Land_axes, Time, &
       'temperature at '//trim(label_zh)//' over land', 'deg_k' , &
       range=trange, missing_value =  -100.0)
  id_rh_ref_land= &
       register_diag_field ( mod_name, 'rh_ref_land', Land_axes, Time,   &
       'relative humidity at '//trim(label_zh)//' over land', 'percent',       &
       missing_value=-999.0)
  id_u_ref_land = &
       register_diag_field ( mod_name, 'u_ref_land',  Land_axes, Time, &
       'zonal wind component at '//trim(label_zm)//' over land',  'm/s', &
       range=vrange, missing_value=-999.0 )
  id_v_ref_land = &
       register_diag_field ( mod_name, 'v_ref_land',  Land_axes, Time,     &
       'meridional wind component at '//trim(label_zm)//' over land', 'm/s', &
       range=vrange, missing_value = -999.0 )
  ! - slm Jun 02, 2002
  id_q_ref = &
       register_diag_field ( mod_name, 'q_ref', atmos_axes, Time,     &
       'specific humidity at '//trim(label_zh), 'kg/kg', missing_value=-1.0)
  id_q_ref_land = &
       register_diag_field ( mod_name, 'q_ref_land', Land_axes, Time, &
       'specific humidity at '//trim(label_zh)//' over land', 'kg/kg',          &
       missing_value=-1.0)

  id_rough_scale = &
       register_diag_field ( mod_name, 'rough_scale', atmos_axes, Time, &
       'topographic scaling factor for momentum drag','1' )
!-----------------------------------------------------------------------

  allocate(id_tr_atm(n_exch_tr))
  allocate(id_tr_surf(n_exch_tr))
  allocate(id_tr_flux(n_exch_tr))
  allocate(id_tr_mol_flux(n_exch_tr))

  do tr = 1, n_exch_tr
     call get_tracer_names( MODEL_ATMOS, tr_table(tr)%atm, name, longname, units )
     id_tr_atm(tr) = register_diag_field (mod_name, trim(name)//'_atm', atmos_axes, Time, &
          trim(longname)//' at btm level', trim(units))
     id_tr_surf(tr) = register_diag_field (mod_name, trim(name)//'_surf', atmos_axes, Time, &
          trim(longname)//' at the surface', trim(units))
     id_tr_flux(tr) = register_diag_field(mod_name, trim(name)//'_flux', atmos_axes, Time, &
          'flux of '//trim(longname), trim(units)//' kg air/(m2 s)')
!! add dryvmr co2_surf and co2_atm
     if ( lowercase(trim(name))=='co2') then
! - slm Mar 25, 2010: moved registration of mol_flux inside 'if' to disable 
! saving incorrect results (mol fluxes for other tracers computed with CO2 molar 
! mass)
       id_tr_mol_flux(tr) = register_diag_field(mod_name, trim(name)//'_mol_flux', atmos_axes, Time, &
            'flux of '//trim(longname), 'mol CO2/(m2 s)')
       id_co2_atm_dvmr = register_diag_field (mod_name, trim(name)//'_atm_dvmr', atmos_axes, Time, &
            trim(longname)//' at btm level', 'mol CO2 /mol air')
       id_co2_surf_dvmr = register_diag_field (mod_name, trim(name)//'_surf_dvmr', atmos_axes, Time, &
            trim(longname)//' at the surface', 'mol CO2 /mol air')
     else
       id_tr_mol_flux(tr) = -1
     endif
  enddo

  id_q_flux = register_diag_field( mod_name, 'evap',       atmos_axes, Time, &
         'evaporation rate',        'kg/m2/s'  )
  id_q_flux_land = register_diag_field( mod_name, 'evap_land', land_axes, Time, &
         'evaporation rate over land',        'kg/m2/s', missing_value=-1.0 )

  end subroutine diag_field_init

!#######################################################################
  subroutine flux_ice_to_ocean_redistribute(ice, ocean, ice_data, ocn_bnd_data, type, do_area_weighted )

    ! Performs a globally conservative flux redistribution across ICE/OCN.
    ! Assumes that the ice/ocn grids are the same. If ocean is present,
    ! then assume different mpp domans and redistribute

    ! should be invoked by all PEs

    type(ice_data_type),              intent(in) :: ice
    type(ocean_public_type),          intent(in) :: ocean
    real, dimension(:,:),             intent(in) :: ice_data
    real, dimension(:,:),            intent(out) :: ocn_bnd_data
    integer,                          intent(in) :: type
    logical,                          intent(in) :: do_area_weighted


    real :: tmp( lbound(ice%lprec, 1):ubound(ice%lprec, 1), lbound(ice%lprec, 2):ubound(ice%lprec, 2) )

    select case(type)
    case(DIRECT)
       if(do_area_weighted) then
          ocn_bnd_data = ice_data * ice%area
          call divide_by_area(data=ocn_bnd_data, area=ocean%area)          
       else
          ocn_bnd_data = ice_data
       endif
    case(REDIST)
       if(do_area_weighted) then
          if( ice%pe ) tmp = ice_data  * ice%area
          call mpp_redistribute(ice%Domain, tmp, ocean%Domain, ocn_bnd_data)
          if(ocean%is_ocean_pe) call divide_by_area(ocn_bnd_data, area=ocean%area) 
       else
          call mpp_redistribute(ice%Domain, ice_data, ocean%Domain, ocn_bnd_data)
       endif
    case DEFAULT
       call mpp_error( FATAL, 'FLUX_ICE_TO_OCEAN: Ice_Ocean_Boundary%xtype must be DIRECT or REDIST.' )
    end select

  end subroutine flux_ice_to_ocean_redistribute

!######################################################################################
! Divide data by area while avoiding zero area elements
  subroutine divide_by_area(data, area)
    real, intent(inout) :: data(:,:)
    real, intent(in)    :: area(:,:)

    if(size(data, dim=1) /= size(area, dim=1) .or. size(data, dim=2) /= size(area, dim=2)) then
       ! no op
       return
    endif

    where(area /= 0) 
       data = data / area
    end where

  end subroutine divide_by_area
!#######################################################################

! This private routine will check flux conservation for routine flux_ice_to_ocean_redistribute
! when do_area_weighted_flux = false and true. 
  subroutine check_flux_conservation(Ice, Ocean, Ice_Ocean_Boundary)
  type(ice_data_type),               intent(inout)  :: Ice
  type(ocean_public_type),           intent(inout)  :: Ocean
  type(ice_ocean_boundary_type),     intent(inout) :: ice_ocean_boundary

  real, allocatable, dimension(:,:) :: ice_data, ocn_data
  real :: ice_sum, area_weighted_sum, non_area_weighted_sum
  integer :: outunit

  outunit = stdout()
  allocate(ice_data(size(Ice%flux_q,1), size(Ice%flux_q,2) ) )
  allocate(ocn_data(size(Ice_Ocean_Boundary%q_flux,1), size(Ice_Ocean_Boundary%q_flux,2) ) )
  call random_number(ice_data)
  ice_sum = sum(ice_data*ice%area)
  call mpp_sum(ice_sum)
  ocn_data = 0
  call flux_ice_to_ocean_redistribute( Ice, Ocean, ice_data, ocn_data, Ice_Ocean_Boundary%xtype, .false.)
  non_area_weighted_sum = sum(ocn_data*ocean%area)
  call mpp_sum(non_area_weighted_sum)
  ocn_data = 0
  call flux_ice_to_ocean_redistribute( Ice, Ocean, ice_data, ocn_data, Ice_Ocean_Boundary%xtype, .true.)
  area_weighted_sum = sum(ocn_data*ocean%area)
  call mpp_sum(area_weighted_sum)  
  write(outunit,*)"NOTE from flux_exchange_mod: check for flux conservation for flux_ice_to_ocean"
  write(outunit,*)"***** The global area sum of random number on ice domain (input data) is ", ice_sum
  write(outunit,*)"***** The global area sum of data after flux_ice_to_ocean_redistribute with "// &
       "do_area_weighted_flux = false is ", non_area_weighted_sum, &
       " and the difference from global input area sum = ", ice_sum - non_area_weighted_sum
  write(outunit,*)"***** The global area sum of data after flux_ice_to_ocean_redistribute with "// &
       "do_area_weighted_flux = true is ", area_weighted_sum, &
       " and the difference from global input area sum = ", ice_sum - area_weighted_sum


  end subroutine check_flux_conservation

! <DIAGFIELDS>
!   <NETCDF NAME="land_mask" UNITS="none">
!     fractional amount of land
!   </NETCDF>
!   <NETCDF NAME="wind" UNITS="m/s">
!     wind speed for flux calculations
!   </NETCDF>
!   <NETCDF NAME="drag_moist" UNITS="none">
!     drag coeff for moisture
!   </NETCDF>
!   <NETCDF NAME="drag_heat" UNITS="none">
!     drag coeff for heat
!   </NETCDF>
!   <NETCDF NAME="drag_mom" UNITS="none">
!     drag coeff for momentum
!   </NETCDF>
!   <NETCDF NAME="rough_moist" UNITS="m">
!     surface roughness for moisture
!   </NETCDF>
!   <NETCDF NAME="rough_heat" UNITS="m">
!     surface roughness for heat
!   </NETCDF>
!   <NETCDF NAME="rough_mom" UNITS="m">
!     surface roughness for momentum
!   </NETCDF>
!   <NETCDF NAME="u_star" UNITS="m/s">
!     friction velocity
!   </NETCDF>
!   <NETCDF NAME="b_star" UNITS="m/s">
!     buoyancy scale
!   </NETCDF>
!   <NETCDF NAME="q_star" UNITS="kg water/kg air">
!     moisture scale
!   </NETCDF>
!   <NETCDF NAME="t_atm" UNITS="deg_k">
!     temperature at btm level
!   </NETCDF>
!   <NETCDF NAME="u_atm" UNITS="m/s">
!     u wind component at btm level
!   </NETCDF>
!   <NETCDF NAME="v_atm" UNITS="m/s">
!     v wind component at btm level
!   </NETCDF>
!   <NETCDF NAME="q_atm" UNITS="kg/kg">
!     specific humidity at btm level
!   </NETCDF>
!   <NETCDF NAME="p_atm" UNITS="pa">
!     pressure at btm level
!   </NETCDF>
!   <NETCDF NAME="z_atm" UNITS="m">
!     height of btm level
!   </NETCDF>
!   <NETCDF NAME="gust" UNITS="m/s">
!     gust scale 
!   </NETCDF>
!   <NETCDF NAME="rh_ref" UNITS="percent">
!     relative humidity at ref height
!   </NETCDF>
!   <NETCDF NAME="t_ref" UNITS="deg_k">
!    temperature at ref height
!   </NETCDF>
!   <NETCDF NAME="u_ref" UNITS="m/s">
!    zonal wind component at ref height
!   </NETCDF>
!   <NETCDF NAME="v_ref" UNITS="m/s">
!    meridional wind component at ref height 
!   </NETCDF>
!   <NETCDF NAME="del_h" UNITS="none">
!    ref height interp factor for heat 
!   </NETCDF>
!   <NETCDF NAME="del_m" UNITS="none">
!    ref height interp factor for momentum 
!   </NETCDF>
!   <NETCDF NAME="del_q" UNITS="none">
!    ref height interp factor for moisture
!   </NETCDF>
!   <NETCDF NAME="tau_x" UNITS="pa">
!    zonal wind stress
!   </NETCDF>
!   <NETCDF NAME="tau_y" UNITS="pa">
!    meridional wind stress
!   </NETCDF>
!   <NETCDF NAME="ice_mask" UNITS="none">
!    fractional amount of sea ice 
!   </NETCDF>
!   <NETCDF NAME="t_surf" UNITS="deg_k">
!     surface temperature
!   </NETCDF>
!   <NETCDF NAME="t_ca" UNITS="deg_k">
!     canopy air temperature
!   </NETCDF>
!   <NETCDF NAME="q_surf" UNITS="kg/kg">
!     surface specific humidity 
!   </NETCDF>
!   <NETCDF NAME="shflx" UNITS="w/m2">
!     sensible heat flux
!   </NETCDF>
!   <NETCDF NAME="evap" UNITS="kg/m2/s">
!     evaporation rate 
!   </NETCDF>
!   <NETCDF NAME="lwflx" UNITS="w/m2">
!    net (down-up) longwave flux 
!   </NETCDF>

! </DIAGFIELDS>

! <INFO>


!   <NOTE>
!   <PRE>
!
!  MAIN PROGRAM EXAMPLE
!  --------------------
!
!       DO slow time steps (ocean)
!
!           call flux_ocean_to_ice
!
!           call ICE_SLOW_UP
!
!
!           DO fast time steps (atmos)
!
!                call sfc_boundary_layer
!
!                call ATMOS_DOWN
!
!                call flux_down_from_atmos
!
!                call LAND_FAST
!
!                call ICE_FAST
!
!                call flux_up_to_atmos
!
!                call ATMOS_UP
!
!           END DO
!
!           call ICE_SLOW_DN
!
!           call flux_ice_to_ocean
!
!           call OCEAN
!
!      END DO
!
!   LAND_FAST and ICE_FAST must update the surface temperature
!
! =======================================================================
!
! REQUIRED VARIABLES IN DEFINED DATA TYPES FOR COMPONENT MODELS
! --------------------------------------------------------------
!
! type (atmos_boundary_data_type) :: Atm
! type (surf_diff_type) :: Atm%Surf_Diff
!
! real, dimension(:)
!
!    Atm%lon_bnd   longitude axis grid box boundaries in radians
!                  must be monotonic
!    Atm%lat_bnd   latitude axis grid box boundaries in radians
!                  must be monotonic
!
! real, dimension(:,:)
!
!    Atm%t_bot     temperature at lowest model level
!    Atm%q_bot     specific humidity at lowest model level
!    Atm%z_bot     height above the surface for the lowest model level (m)
!    Atm%p_bot     pressure at lowest model level (pa)
!    Atm%u_bot     zonal wind component at lowest model level (m/s)
!    Atm%v_bot     meridional wind component at lowest model level (m/s)
!    Atm%p_surf    surface pressure (pa)
!    Atm%slp       sea level pressure (pa)
!    Atm%gust      gustiness factor (m/s)
!    Atm%flux_sw   net shortwave flux at the surface
!    Atm%flux_lw   downward longwave flux at the surface
!    Atm%lprec     liquid precipitation (kg/m2)
!    Atm%fprec     water equivalent frozen precipitation (kg/m2)
!    Atm%coszen    cosine of the zenith angle
!
!   (the following five fields are gathered into a data type for convenience in passing
!   this information through the different levels of the atmospheric model --
!   these fields are rlated to the simultaneous implicit time steps in the
!   atmosphere and surface models -- they are described more fully in
!   flux_exchange.tech.ps and
!   in the documntation for vert_diff_mod
!
!
!    Atm%Surf_Diff%dtmass   = dt/mass where dt = atmospheric time step ((i+1) = (i-1) for leapfrog) (s)
!                           mass = mass per unit area of lowest atmosphehic layer  (Kg/m2))
!    Atm%Surf_Diff%delta_t  increment ((i+1) = (i-1) for leapfrog) in temperature of
!                           lowest atmospheric layer  (K)
!    Atm%Surf_Diff%delta_q  increment ((i+1) = (i-1) for leapfrog) in specific humidity of
!                           lowest atmospheric layer (nondimensional -- Kg/Kg)
!    Atm%Surf_Diff%dflux_t  derivative of implicit part of downward temperature flux at top of lowest
!                           atmospheric layer with respect to temperature
!                           of lowest atmospheric layer (Kg/(m2 s))
!    Atm%Surf_Diff%dflux_q  derivative of implicit part of downward moisture flux at top of lowest
!                           atmospheric layer with respect to specific humidity of
!                           of lowest atmospheric layer (Kg/(m2 s))
!
!
! integer, dimension(4)
!
!    Atm%axes      Axis identifiers returned by diag_axis_init for the
!                  atmospheric model axes: X, Y, Z_full, Z_half.
!
! -----------------------------------------------
!
! type (land_boundary_data_type) :: Land
!
! real, dimension(:)
!
!    Land%lon_bnd     longitude axis grid box boundaries in radians
!                     must be monotonic
!    Land%lat_bnd     latitude axis grid box boundaries in radians
!                     must be monotonic
!
! logical, dimension(:,:,:)
!
!    Land%mask        land/sea mask (true for land)
!    Land%glacier     glacier mask  (true for glacier)
!
! real, dimension(:,:,:)
!
!    Land%tile_size   fractional area of each tile (partition)
!
!    Land%t_surf      surface temperature (deg k)
!    Land%albedo      surface albedo (fraction)
!    Land%rough_mom   surface roughness for momentum (m)
!    Land%rough_heat  surface roughness for heat/moisture (m)
!    Land%stomatal    stomatal resistance
!    Land%snow        snow depth (water equivalent) (kg/m2)
!    Land%water       water depth of the uppermost bucket (kg/m2)
!    Land%max_water   maximum water depth allowed in the uppermost bucket (kg/m2)
!
! -----------------------------------------------
!
!
! type (ice_boundary_data_type) :: Ice
!
! real, dimension(:)
!
!    Ice%lon_bnd       longitude axis grid box boundaries for temperature points
!                      in radians (must be monotonic)
!    Ice%lat_bnd       latitude axis grid box boundaries for temperature points
!                      in radians (must be monotonic)
!    Ice%lon_bnd_uv    longitude axis grid box boundaries for momentum points
!                      in radians (must be monotonic)
!    Ice%lat_bnd_uv    latitude axis grid box boundaries for momentum points
!                      in radians (must be monotonic)
!
! logical, dimension(:,:,:)
!
!    Ice%mask          ocean/land mask for temperature points
!                        (true for ocean, with or without ice)
!    Ice%mask_uv       ocean/land mask for momentum points
!                        (true for ocean, with or without ice)
!    Ice%ice_mask      optional ice mask (true for ice)
!
! real, dimension(:,:,:)
!
!    Ice%part_size     fractional area of each partition of a temperature grid box
!    Ice%part_size_uv  fractional area of each partition of a momentum grid box
!
!    the following fields are located on the ice top grid
!
!    Ice%t_surf        surface temperature (deg k)
!    Ice%albedo        surface albedo (fraction)
!    Ice%rough_mom     surface roughness for momentum (m)
!    Ice%rough_heat    surface roughness for heat/moisture (m)
!    Ice%u_surf        zonal (ocean/ice) current at the surface (m/s)
!    Ice%v_surf        meridional (ocean/ice) current at the surface (m/s)
!
!    the following fields are located on the ice bottom grid
!
!    Ice%flux_u        zonal wind stress (Pa)
!    Ice%flux_v        meridional wind stress (Pa)
!    Ice%flux_t        sensible heat flux (w/m2)
!    Ice%flux_q        specific humidity flux (kg/m2/s)
!    Ice%flux_sw       net (down-up) shortwave flux (w/m2)
!    Ice%flux_lw       net (down-up) longwave flux (w/m2)
!    Ice%lprec         mass of liquid precipitation since last time step (Kg/m2)
!    Ice%fprec         mass of frozen precipitation since last time step (Kg/m2)
!    Ice%runoff        mass of runoff water since last time step (Kg/m2)
!
! -----------------------------------------------
!
! type (ocean_boundary_data_type) :: Ocean
!
! real, dimension(:)
!
!    Ocean%Data%lon_bnd      longitude axis grid box boundaries for temperature
!                            points on the ocean DATA GRID (radians)
!    Ocean%Data%lat_bnd      latitude axis grid box boundaries for temperature
!                            points on the ocean DATA GRID (radians)
!    Ocean%Data%lon_bnd_uv   longitude axis grid box boundaries for momentum
!                            points on the ocean DATA GRID (radians)
!    Ocean%Data%lat_bnd_uv   latitude axis grid box boundaries for momentum
!                            points on the ocean DATA GRID (radians)
!
!    Ocean%Ocean%lon_bnd     longitude axis grid box boundaries for temperature
!                            points on the ocean MODEL GRID (radians)
!    Ocean%Ocean%lat_bnd     latitude axis grid box boundaries for temperature
!                            points on the ocean MODEL GRID (radians)
!    Ocean%Ocean%lon_bnd_uv  longitude axis grid box boundaries for momentum
!                            points on the ocean MODEL GRID (radians)
!    Ocean%Ocean%lat_bnd_uv  latitude axis grid box boundaries for momentum
!                            points on the ocean MODEL GRID (radians)
!
!      Note: The data values in all longitude and latitude grid box boundary
!            array must be monotonic.
!
! logical, dimension(:,:)
!
!    Ocean%Data%mask       ocean/land mask for temperature points on the ocean
!                          DATA GRID (true for ocean)
!    Ocean%Data%mask_uv    ocean/land mask for momentum points on the ocean
!                          DATA GRID (true for ocean)
!
!    Ocean%Ocean%mask      ocean/land mask for temperature points on the ocean
!                          MODEL GRID (true for ocean)
!    Ocean%Ocean%mask_uv   ocean/land mask for momentum points on the ocean
!                          MODEL GRID (true for ocean)
!
! real, dimension(:,:)
!
!    Ocean%t_surf_data  surface temperature on the ocean DATA GRID (deg k)
!
!    Ocean%t_surf       surface temperature on the ocean MODEL GRID (deg k)
!    Ocean%u_surf       zonal ocean current at the surface on the ocean
!                       MODEL GRID (m/s)
!    Ocean%v_surf       meridional ocean current at the surface on the
!                       ocean MODEL GRID (m/s)
!    Ocean%frazil       frazil at temperature points on the ocean MODEL GRID
!
!   </PRE>
!   </NOTE>
! </INFO>

end module flux_exchange_mod



! ============================================================================
module surface_flux_mod
!-----------------------------------------------------------------------
!                   GNU General Public License                        
!                                                                      
! This program is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
!
! <CONTACT EMAIL="Stephen.Klein@noaa.gov">Steve Klein  </CONTACT>
! <CONTACT EMAIL="Isaac.Held@noaa.gov"> Isaac Held </CONTACT>
! <CONTACT EMAIL="Bruce.Wyman@noaa.gov"> Bruce Wyman </CONTACT >

! <REVIEWER EMAIL="V.Balaji@noaa.gov"> V. Balaji </REVIEWER>
! <REVIEWER EMAIL="Sergey.Malyshev@noaa.gov"> Sergey Malyshev </REVIEWER>
! <REVIEWER EMAIL="Elena.Shevliakova@noaa.gov"> Elena Shevliakova </REVIEWER>
!
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
!
! <OVERVIEW>
!  Driver program for the calculation of fluxes on the exchange grids. 
! </OVERVIEW>
!
! <DESCRIPTION>
!
! </DESCRIPTION>
!
! ============================================================================

use             fms_mod, only: FATAL, close_file, mpp_pe, mpp_root_pe, write_version_number
use             fms_mod, only: file_exist, check_nml_error, open_namelist_file, stdlog
use   monin_obukhov_mod, only: mo_drag, mo_profile
use  sat_vapor_pres_mod, only: escomp, descomp
use       constants_mod, only: cp_air, hlv, stefan, rdgas, rvgas, grav, vonkarm
use             mpp_mod, only: input_nml_file

implicit none
private

! ==== public interface ======================================================
public  surface_flux
! ==== end of public interface ===============================================

! <INTERFACE NAME="surface_flux">
!   <OVERVIEW>
!   For the calculation of fluxes on the exchange grids. 
!   </OVERVIEW>
!   <DESCRIPTION>
!   For the calculation of fluxes on the exchange grids. 
!   </DESCRIPTION>
!
!  <IN NAME="t_atm" TYPE="real, dimension(:)" UNITS="Kelvin">
!  Air temp lowest atmospheric level.  
!  </IN>
!  <IN NAME="q_atm" TYPE="real, dimension(:)" UNITS="dimensionless">
!  Mixing ratio at lowest atmospheric level (kg/kg).  
!  </IN>
!  <IN NAME="u_atm" TYPE="real, dimension(:)" UNITS="m/s">
!  Zonal wind velocity at lowest atmospheric level.       
!  </IN>
!  <IN NAME="v_atm" TYPE="real, dimension(:)" UNITS="m/s">
!  Meridional wind velocity at lowest atmospheric level.    
!  </IN>
!  <IN NAME="p_atm" TYPE="real, dimension(:)" UNITS="Pascal">
!  Pressure lowest atmospheric level.    
!  </IN>
!  <IN NAME="z_atm" TYPE="real, dimension(:)" UNITS="m" >
!  Height lowest atmospheric level. 
!  </IN>
!  <IN NAME="p_surf" TYPE="real, dimension(:)" UNITS="Pascal">
!   Pressure at the earth's surface
!  </IN>
!  <IN NAME="t_surf" TYPE="real, dimension(:)" UNITS="Kelvin">
!   Temp at the earth's surface
!  </IN>
!  <IN NAME="t_ca" TYPE="real, dimension(:)" UNITS="Kelvin">
!   Air temp at the canopy 
!  </IN>
!  <OUT NAME="q_surf" TYPE="real, dimension(:)" UNITS="dimensionless">
!  Mixing ratio at earth surface (kg/kg). 
!  </OUT>
!  <IN NAME="u_surf" TYPE="real, dimension(:)" UNITS="m/s">
!  Zonal wind velocity at earth surface.   
!  </IN>
!  <IN NAME="v_surf" TYPE="real, dimension(:)" UNITS="m/s">
!  Meridional wind velocity at earth surface. 
!  </IN>
!  <IN NAME="rough_mom" TYPE="real, dimension(:)" UNITS="m">
!  Momentum roughness length
!  </IN>
!  <IN NAME="rough_heat" TYPE="real, dimension(:)" UNITS="m">
!  Heat roughness length
!  </IN>
!  <IN NAME="rough_moist" TYPE="real, dimension(:)" UNITS="m">
! <Moisture roughness length
!  </IN>
!  <IN NAME="rough_scale" TYPE="real, dimension(:)" UNITS="dimensionless" >
!  Scale factor used to topographic roughness calculation
!  </IN>
!  <IN NAME="gust" TYPE="real, dimension(:)"  UNITS="m/s">
!   Gustiness factor 
!  </IN>
!  <OUT NAME="flux_t" TYPE="real, dimension(:)" UNITS="W/m^2">
!  Sensible heat flux 
!  </OUT>
!  <OUT NAME="flux_q" TYPE="real, dimension(:)" UNITS="kg/(m^2 s)">
!  Evaporative water flux 
!  </OUT>
!  <OUT NAME="flux_r" TYPE="real, dimension(:)" UNITS="W/m^2">
!  Radiative energy flux 
!  </OUT>
!  <OUT NAME="flux_u" TYPE="real, dimension(:)" UNITS="Pa">
!  Zonal momentum flux 
!  </OUT>
!  <OUT NAME="flux_v" TYPE="real, dimension(:)" UNITS="Pa">
! Meridional momentum flux 
!  </OUT>
!  <OUT NAME="cd_m" TYPE="real, dimension(:)" UNITS="dimensionless">
!  Momentum exchange coefficient 
!  </OUT>
!  <OUT NAME="cd_t" TYPE="real, dimension(:)" UNITS="dimensionless">
!  Heat exchange coefficient 
!  </OUT>
!  <OUT NAME="cd_q" TYPE="real, dimension(:)" UNITS="dimensionless">
!  Moisture exchange coefficient 
!  </OUT>
!  <OUT NAME="w_atm" TYPE="real, dimension(:)" UNITS="m/s">
!  Absolute wind at the lowest atmospheric level
!  </OUT>
!  <OUT NAME="u_star" TYPE="real, dimension(:)" UNITS="m/s">
!  Turbulent velocity scale 
!  </OUT>
!  <OUT NAME="b_star" TYPE="real, dimension(:)" UNITS="m/s^2">
!  Turbulent buoyant scale
!  </OUT>
!  <OUT NAME="q_star" TYPE="real, dimension(:)" UNITS="dimensionless">
!  Turbulent moisture scale
!  </OUT>
!  <OUT NAME="dhdt_surf" TYPE="real, dimension(:)" UNITS="(W/m^2)/K">
!  Sensible heat flux temperature sensitivity
!  </OUT>
!  <OUT NAME="dedt_surf" TYPE="real, dimension(:)" UNITS="1/K">
!   Moisture flux temperature sensitivity 
!  </OUT>
!  <OUT NAME="dedq_surf" TYPE="real, dimension(:)" UNITS="(kg/m^2)/s">
!  Moisture flux humidity sensitivity  
!  </OUT>
!  <OUT NAME="drdt_surf" TYPE="real, dimension(:)" UNITS="(W/m^2)/K">
!  Radiative energy flux temperature sensitivity 
!  </OUT>
!  <OUT NAME="dhdt_atm" TYPE="real, dimension(:)" UNITS="(W/m^2)/K">
!  Derivative of sensible heat flux over temp at the lowest atmos level.
!  </OUT>
!  <OUT NAME="dedq_atm" TYPE="real, dimension(:)" UNITS="(kg/m^2/sec)/K">
!  Derivative of water vapor flux over temp at the lowest atmos level.
!  </OUT>
!  <OUT NAME="dtaudu_atm" TYPE="real, dimension(:)" UNITS="Pa/(m/s)">
!  Derivative of zonal wind stress w.r.t the lowest level zonal 
!  wind speed of the atmos
!  </OUT>
!  <OUT NAME="dtaudv_atm" TYPE="real, dimension(:)" UNITS="Pa/(m/s)">
!  Derivative of meridional wind stress w.r.t the lowest level meridional 
!  wind speed of the atmos
!  </OUT>
!  <OUT NAME="dt" TYPE="real">
!  Time step (it is not used presently)
!  </OUT>
!  <IN NAME="land" TYPE="logical, dimension(:)">
!  Indicates where land exists (true if exchange cell is on land). 
!  </IN>
!  <IN NAME="seawater" TYPE="logical, dimension(:)">
!  Indicates where liquid ocean water exists 
!  (true if exchange cell is on liquid ocean water). 
!  </IN>
!  <IN NAME="avail" TYPE="logical, dimension(:)">
!  True where the exchange cell is active.  
!  </IN>


interface surface_flux
!    module procedure surface_flux_0d
    module procedure surface_flux_1d
!    module procedure surface_flux_2d  
end interface
! </INTERFACE>

!-----------------------------------------------------------------------

character(len=*), parameter :: version = '$Id: surface_flux.F90,v 18.0.4.1 2010/08/31 14:38:01 z1l Exp $'
character(len=*), parameter :: tagname = '$Name: hiram_20101115_bw $'
   
logical :: do_init = .true.

real, parameter :: d622   = rdgas/rvgas
real, parameter :: d378   = 1.-d622
real, parameter :: hlars  = hlv/rvgas
real, parameter :: gcp    = grav/cp_air
real, parameter :: kappa  = rdgas/cp_air
real            :: d608   = d378/d622
      ! d608 set to zero at initialization if the use of 
      ! virtual temperatures is turned off in namelist
      
      
! ---- namelist with default values ------------------------------------------
! <NAMELIST NAME="surface_flux_nml">
!   <DATA NAME="no_neg_q"  TYPE="logical"  DEFAULT=".false.">
!    If q_atm_in (specific humidity) is negative (because of numerical truncation),  
!    then override with 0. 
!   </DATA>
!   <DATA NAME="use_virtual_temp"  TYPE="logical"  DEFAULT=".true.">
!    If true, use virtual potential temp to calculate the stability of the surface layer.
!    if false, use potential temp.
!   </DATA>
!   <DATA NAME="alt_gustiness"  TYPE="logical"  DEFAULT=".false.">
!   An alternative formulation for gustiness calculation. 
!   A minimum bound on the wind speed used influx calculations, with the bound 
!   equal to gust_const 
!   </DATA>
!   <DATA NAME="old_dtaudv"  TYPE="logical"  DEFAULT=".false.">
!   The derivative of surface wind stress w.r.t. the zonal wind and
!   meridional wind are approximated by the same tendency.
!   </DATA>
!   <DATA NAME="use_mixing_ratio"  TYPE="logical"  DEFAULT=".false.">
!   An option to provide capability to run the Manabe Climate form of the 
!   surface flux (coded for legacy purposes). 
!   </DATA>
!   <DATA NAME="gust_const"  TYPE=""  DEFAULT="1.0">
!    Constant for alternative gustiness calculation.
!   </DATA>
!   <DATA NAME="gust_min"  TYPE=""  DEFAULT="0.0">
!    Minimum gustiness used when alt_gustiness = false.
!   </DATA>
!   <DATA NAME="ncar_ocean_flux"  TYPE="logical"  DEFAULT=".false.">
!    Use NCAR climate model turbulent flux calculation described by
!    Large and Yeager, NCAR Technical Document, 2004
!   </DATA>
!   <DATA NAME="ncar_ocean_flux_orig"  TYPE="logical"  DEFAULT=".false.">
!    Use NCAR climate model turbulent flux calculation described by
!    Large and Yeager, NCAR Technical Document, 2004, using the original
!    GFDL implementation, which contains a bug in the specification of 
!    the exchange coefficient for the sensible heat.  This option is available
!    for legacy purposes, and is not recommended for new experiments.   
!   </DATA>
!   <DATA NAME="raoult_sat_vap"  TYPE="logical"  DEFAULT=".false.">
!    Reduce saturation vapor pressures to account for seawater salinity.
!   </DATA>
! </NAMELIST>

logical :: no_neg_q              = .false.  ! for backwards compatibility
logical :: use_virtual_temp      = .true. 
logical :: alt_gustiness         = .false.
logical :: old_dtaudv            = .false.
logical :: use_mixing_ratio      = .false.
real    :: gust_const            =  1.0
real    :: gust_min              =  0.0
logical :: ncar_ocean_flux       = .false.
logical :: ncar_ocean_flux_orig  = .false. ! for backwards compatibility 
logical :: raoult_sat_vap        = .false.
logical :: do_simple             = .false.


namelist /surface_flux_nml/ no_neg_q,             &
                            use_virtual_temp,     &
                            alt_gustiness,        &
                            gust_const,           &
                            gust_min,             &
                            old_dtaudv,           &
                            use_mixing_ratio,     &
                            ncar_ocean_flux,      &
                            ncar_ocean_flux_orig, &
                            raoult_sat_vap,       &
                            do_simple       
   


contains


! ============================================================================
! <SUBROUTINE NAME="surface_flux_1d" INTERFACE="surface_flux">
!  <IN NAME="t_atm" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="q_atm" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="u_atm" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="v_atm" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="p_atm" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="z_atm" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="p_surf" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="t_surf" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="t_ca" TYPE="real, dimension(:)"> </IN>
!  <OUT NAME="q_surf" TYPE="real, dimension(:)"> </OUT>
!  <IN NAME="u_surf" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="v_surf" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="rough_mom" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="rough_heat" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="rough_moist" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="rough_scale" TYPE="real, dimension(:)"> </IN>
!  <IN NAME="gust" TYPE="real, dimension(:)"> </IN>
!  <OUT NAME="flux_t" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="flux_q" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="flux_r" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="flux_u" TYPE="real, dimension(:)"></OUT>
!  <OUT NAME="flux_v" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="cd_m" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="cd_t" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="cd_q" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="w_atm" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="u_star" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="b_star" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="q_star" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dhdt_surf" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dedt_surf" TYPE="real, dimension(:)"></OUT>
!  <OUT NAME="dedq_surf" TYPE="real, dimension(:)"></OUT>
!  <OUT NAME="drdt_surf" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dhdt_atm" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dedq_atm" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dtaudu_atm" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dtaudv_atm" TYPE="real, dimension(:)"> </OUT>
!  <OUT NAME="dt" TYPE="real"> </OUT>
!  <IN NAME="land" TYPE="logical, dimension(:)"> </IN>
!  <IN NAME="seawater" TYPE="logical, dimension(:)"> </IN>
!  <IN NAME="avail" TYPE="logical, dimension(:)"> </IN>


!<PUBLICROUTINE INTERFACE="surface_flux">
subroutine surface_flux_1d (                                           &
     t_atm,     q_atm_in,   u_atm,     v_atm,     p_atm,     z_atm,    &
     p_surf,    t_surf,     t_ca,      q_surf,                         &
     u_surf,    v_surf,                                                &
     rough_mom, rough_heat, rough_moist, rough_scale, gust,            &
     flux_t, flux_q, flux_r, flux_u, flux_v,                           &
     cd_m,      cd_t,       cd_q,                                      &
     w_atm,     u_star,     b_star,     q_star,                        &
     dhdt_surf, dedt_surf,  dedq_surf,  drdt_surf,                     &
     dhdt_atm,  dedq_atm,   dtaudu_atm, dtaudv_atm,                    &
     dt,        land,      seawater,     avail  )
!</PUBLICROUTINE>
!  slm Mar 28 2002 -- remove agument drag_q since it is just cd_q*wind
! ============================================================================
  ! ---- arguments -----------------------------------------------------------
  logical, intent(in), dimension(:) :: land,  seawater, avail
  real, intent(in),  dimension(:) :: &
       t_atm,     q_atm_in,   u_atm,     v_atm,              &
       p_atm,     z_atm,      t_ca,                          &
       p_surf,    t_surf,     u_surf,    v_surf,  &
       rough_mom, rough_heat, rough_moist,  rough_scale, gust
  real, intent(out), dimension(:) :: &
       flux_t,    flux_q,     flux_r,    flux_u,  flux_v,    &
       dhdt_surf, dedt_surf,  dedq_surf, drdt_surf,          &
       dhdt_atm,  dedq_atm,   dtaudu_atm,dtaudv_atm,         &
       w_atm,     u_star,     b_star,    q_star,             &
       cd_m,      cd_t,       cd_q
  real, intent(inout), dimension(:) :: q_surf
  real, intent(in) :: dt

  ! ---- local constants -----------------------------------------------------
  ! temperature increment and its reciprocal value for comp. of derivatives
  real, parameter:: del_temp=0.1, del_temp_inv=1.0/del_temp

  ! ---- local vars ----------------------------------------------------------
  real, dimension(size(t_atm(:))) ::                          &
       thv_atm,  th_atm,   tv_atm,    thv_surf,            &
       e_sat,    e_sat1,   q_sat,     q_sat1,    p_ratio,  &
       t_surf0,  t_surf1,  u_dif,     v_dif,               &
       rho_drag, drag_t,    drag_m,   drag_q,    rho,      &
       q_atm,    q_surf0,  dw_atmdu,  dw_atmdv,  w_gust

  integer :: i, nbad


  if (do_init) call surface_flux_init

  !---- use local value of surf temp ----

  t_surf0 = 200.   !  avoids out-of-bounds in es lookup 
  where (avail)
     where (land)
        t_surf0 = t_ca
     elsewhere
        t_surf0 = t_surf
     endwhere
  endwhere

  t_surf1 = t_surf0 + del_temp

  call escomp ( t_surf0, e_sat  )  ! saturation vapor pressure
  call escomp ( t_surf1, e_sat1 )  ! perturbed  vapor pressure

  if(use_mixing_ratio) then
    ! surface mixing ratio at saturation
    q_sat   = d622*e_sat /(p_surf-e_sat )  
    q_sat1  = d622*e_sat1/(p_surf-e_sat1)  
  elseif(do_simple) then                  !rif:(09/02/09)
    q_sat   = d622*e_sat / p_surf
    q_sat1  = d622*e_sat1/ p_surf   
  else
    ! surface specific humidity at saturation
    q_sat   = d622*e_sat /(p_surf-d378*e_sat )  
    q_sat1  = d622*e_sat1/(p_surf-d378*e_sat1)     
  endif

  ! initilaize surface air humidity according to surface type
  where (land)
     q_surf0 = q_surf ! land calculates it
  elsewhere
     q_surf0 = q_sat  ! everything else assumes saturated sfc humidity
  endwhere

  if (raoult_sat_vap) where (seawater) q_surf0 = 0.98 * q_surf0

  ! check for negative atmospheric humidities
  where(avail) q_atm = q_atm_in
  if(no_neg_q) then
     where(avail .and. q_atm_in < 0.0) q_atm = 0.0
  endif

  ! generate information needed by monin_obukhov
  where (avail)
     p_ratio = (p_surf/p_atm)**kappa

     tv_atm  = t_atm  * (1.0 + d608*q_atm)     ! virtual temperature
     th_atm  = t_atm  * p_ratio                ! potential T, using p_surf as refernce
     thv_atm = tv_atm * p_ratio                ! virt. potential T, using p_surf as reference 
     thv_surf= t_surf0 * (1.0 + d608*q_surf0 ) ! surface virtual (potential) T
!     thv_surf= t_surf0                        ! surface virtual (potential) T -- just for testing tun off the q_surf

     u_dif = u_surf - u_atm                    ! velocity components relative to surface
     v_dif = v_surf - v_atm
  endwhere

  if(alt_gustiness) then
     do i = 1, size(avail)
        if (.not.avail(i)) cycle
        w_atm(i) = max(sqrt(u_dif(i)**2 + v_dif(i)**2), gust_const)
        ! derivatives of surface wind w.r.t. atm. wind components
        if(w_atm(i) > gust_const) then
           dw_atmdu(i) = u_dif(i)/w_atm(i)
           dw_atmdv(i) = v_dif(i)/w_atm(i)
        else
           dw_atmdu(i) = 0.0
           dw_atmdv(i) = 0.0
        endif
     enddo
  else
     if (gust_min > 0.0) then 
       where(avail)
         w_gust = max(gust,gust_min) ! minimum gustiness
       end where
     else
       where(avail)
         w_gust = gust
       end where
     endif  
           
     where(avail) 
        w_atm = sqrt(u_dif*u_dif + v_dif*v_dif + w_gust*w_gust)
        ! derivatives of surface wind w.r.t. atm. wind components
        dw_atmdu = u_dif/w_atm
        dw_atmdv = v_dif/w_atm
     endwhere
  endif

  !  monin-obukhov similarity theory 
  call mo_drag (thv_atm, thv_surf, z_atm,                  &
       rough_mom, rough_heat, rough_moist, w_atm,          &
       cd_m, cd_t, cd_q, u_star, b_star, avail             )

  ! override with ocean fluxes from NCAR calculation
  if (ncar_ocean_flux .or. ncar_ocean_flux_orig) then
    call  ncar_ocean_fluxes (w_atm, th_atm, t_surf0, q_atm, q_surf0, z_atm, &
                             seawater, cd_m, cd_t, cd_q, u_star, b_star     )
  end if

  where (avail)
     ! scale momentum drag coefficient on orographic roughness
     cd_m = cd_m*(log(z_atm/rough_mom+1)/log(z_atm/rough_scale+1))**2
     ! surface layer drag coefficients
     drag_t = cd_t * w_atm
     drag_q = cd_q * w_atm
     drag_m = cd_m * w_atm

     ! density
     rho = p_atm / (rdgas * tv_atm)  

     ! sensible heat flux
     rho_drag = cp_air * drag_t * rho
     flux_t = rho_drag * (t_surf0 - th_atm)  ! flux of sensible heat (W/m**2)
     dhdt_surf =  rho_drag                   ! d(sensible heat flux)/d(surface temperature)
     dhdt_atm  = -rho_drag*p_ratio           ! d(sensible heat flux)/d(atmos temperature)

     ! evaporation
     rho_drag  =  drag_q * rho
     flux_q    =  rho_drag * (q_surf0 - q_atm) ! flux of water vapor  (Kg/(m**2 s))

     where (land)
        dedq_surf = rho_drag
        dedt_surf = 0
     elsewhere
        dedq_surf = 0
        dedt_surf =  rho_drag * (q_sat1 - q_sat) *del_temp_inv
     endwhere
        
     dedq_atm  = -rho_drag   ! d(latent heat flux)/d(atmospheric mixing ratio)

     q_star = flux_q / (u_star * rho)             ! moisture scale
     ! ask Chris and Steve K if we still want to keep this for diagnostics
     q_surf = q_atm + flux_q / (rho*cd_q*w_atm)   ! surface specific humidity

     ! upward long wave radiation
     flux_r    =   stefan*t_surf**4               ! (W/m**2)
     drdt_surf = 4*stefan*t_surf**3               ! d(upward longwave)/d(surface temperature)

     ! stresses
     rho_drag   = drag_m * rho
     flux_u     = rho_drag * u_dif   ! zonal      component of stress (Nt/m**2)
     flux_v     = rho_drag * v_dif   ! meridional component of stress 

  elsewhere
     ! zero-out un-available data in output only fields
     flux_t     = 0.0
     flux_q     = 0.0
     flux_r     = 0.0
     flux_u     = 0.0
     flux_v     = 0.0
     dhdt_surf  = 0.0
     dedt_surf  = 0.0
     dedq_surf  = 0.0
     drdt_surf  = 0.0
     dhdt_atm   = 0.0
     dedq_atm   = 0.0
     u_star     = 0.0
     b_star     = 0.0
     q_star     = 0.0
     q_surf     = 0.0
     w_atm      = 0.0
  endwhere

  ! calculate d(stress component)/d(atmos wind component)
  dtaudu_atm = 0.0
  dtaudv_atm = 0.0
  if (old_dtaudv) then
     where(avail)
        dtaudv_atm = -rho_drag
        dtaudu_atm = -rho_drag
     endwhere
  else
     where(avail)
        dtaudu_atm = -cd_m*rho*(dw_atmdu*u_dif + w_atm)
        dtaudv_atm = -cd_m*rho*(dw_atmdv*v_dif + w_atm)
     endwhere
  endif

end subroutine surface_flux_1d
! </SUBROUTINE>

!#######################################################################

subroutine surface_flux_0d (                                                 &
     t_atm_0,     q_atm_0,      u_atm_0,     v_atm_0,   p_atm_0, z_atm_0,    &
     p_surf_0,    t_surf_0,     t_ca_0,      q_surf_0,                       &
     u_surf_0,    v_surf_0,                                                  &
     rough_mom_0, rough_heat_0, rough_moist_0, rough_scale_0, gust_0,        &
     flux_t_0,    flux_q_0,     flux_r_0,    flux_u_0,  flux_v_0,            &
     cd_m_0,      cd_t_0,       cd_q_0,                                      &
     w_atm_0,     u_star_0,     b_star_0,     q_star_0,                      &
     dhdt_surf_0, dedt_surf_0,  dedq_surf_0,  drdt_surf_0,                   &
     dhdt_atm_0,  dedq_atm_0,   dtaudu_atm_0, dtaudv_atm_0,                  &
     dt,          land_0,       seawater_0,  avail_0  )

  ! ---- arguments -----------------------------------------------------------
  logical, intent(in) :: land_0,  seawater_0, avail_0
  real, intent(in) ::                                                  &
       t_atm_0,     q_atm_0,      u_atm_0,     v_atm_0,                &
       p_atm_0,     z_atm_0,      t_ca_0,                              &
       p_surf_0,    t_surf_0,     u_surf_0,    v_surf_0,               &
       rough_mom_0, rough_heat_0, rough_moist_0, rough_scale_0, gust_0
  real, intent(out) ::                                                 &
       flux_t_0,    flux_q_0,     flux_r_0,    flux_u_0,  flux_v_0,    &
       dhdt_surf_0, dedt_surf_0,  dedq_surf_0, drdt_surf_0,            &
       dhdt_atm_0,  dedq_atm_0,   dtaudu_atm_0,dtaudv_atm_0,           &
       w_atm_0,     u_star_0,     b_star_0,    q_star_0,               &
       cd_m_0,      cd_t_0,       cd_q_0
  real, intent(inout) :: q_surf_0
  real, intent(in)    :: dt

  ! ---- local vars ----------------------------------------------------------
  logical, dimension(1) :: land,  seawater, avail
  real, dimension(1) :: &
       t_atm,     q_atm,      u_atm,     v_atm,              &
       p_atm,     z_atm,      t_ca,                          &
       p_surf,    t_surf,     u_surf,    v_surf,             &
       rough_mom, rough_heat, rough_moist,  rough_scale, gust
  real, dimension(1) :: &
       flux_t,    flux_q,     flux_r,    flux_u,  flux_v,    &
       dhdt_surf, dedt_surf,  dedq_surf, drdt_surf,          &
       dhdt_atm,  dedq_atm,   dtaudu_atm,dtaudv_atm,         &
       w_atm,     u_star,     b_star,    q_star,             &
       cd_m,      cd_t,       cd_q
  real, dimension(1) :: q_surf


  avail = .true.

  t_atm(1)       = t_atm_0
  q_atm(1)       = q_atm_0
  u_atm(1)       = u_atm_0
  v_atm(1)       = v_atm_0
  p_atm(1)       = p_atm_0
  z_atm(1)       = z_atm_0
  t_ca(1)        = t_ca_0
  p_surf(1)      = p_surf_0
  t_surf(1)      = t_surf_0
  u_surf(1)      = u_surf_0
  v_surf(1)      = v_surf_0
  rough_mom(1)   = rough_mom_0
  rough_heat(1)  = rough_heat_0
  rough_moist(1) = rough_moist_0
  rough_scale(1) = rough_scale_0
  gust(1)        = gust_0
  q_surf(1)      = q_surf_0
  land(1)        = land_0
  seawater(1)    = seawater_0
  avail(1)       = avail_0

  call surface_flux_1d (                                                 &
       t_atm,     q_atm,      u_atm,     v_atm,     p_atm,     z_atm,    &
       p_surf,    t_surf,     t_ca,      q_surf,                         &
       u_surf,    v_surf,                                                &
       rough_mom, rough_heat, rough_moist, rough_scale, gust,            &
       flux_t, flux_q, flux_r, flux_u, flux_v,                           &
       cd_m,      cd_t,       cd_q,                                      &
       w_atm,     u_star,     b_star,     q_star,                        &
       dhdt_surf, dedt_surf,  dedq_surf,  drdt_surf,                     &
       dhdt_atm,  dedq_atm,   dtaudu_atm, dtaudv_atm,                    &
       dt,        land,      seawater, avail  )

  flux_t_0     = flux_t(1)
  flux_q_0     = flux_q(1)
  flux_r_0     = flux_r(1)
  flux_u_0     = flux_u(1)
  flux_v_0     = flux_v(1)
  dhdt_surf_0  = dhdt_surf(1)
  dedt_surf_0  = dedt_surf(1)
  dedq_surf_0  = dedq_surf(1)
  drdt_surf_0  = drdt_surf(1)
  dhdt_atm_0   = dhdt_atm(1)
  dedq_atm_0   = dedq_atm(1)
  dtaudu_atm_0 = dtaudu_atm(1)
  dtaudv_atm_0 = dtaudv_atm(1)
  w_atm_0      = w_atm(1)
  u_star_0     = u_star(1)
  b_star_0     = b_star(1)
  q_star_0     = q_star(1)
  q_surf_0     = q_surf(1)
  cd_m_0       = cd_m(1)
  cd_t_0       = cd_t(1)
  cd_q_0       = cd_q(1)

end subroutine surface_flux_0d

subroutine surface_flux_2d (                                           &
     t_atm,     q_atm_in,   u_atm,     v_atm,     p_atm,     z_atm,    &
     p_surf,    t_surf,     t_ca,      q_surf,                         &
     u_surf,    v_surf,                                                &
     rough_mom, rough_heat, rough_moist, rough_scale, gust,            &
     flux_t,    flux_q,     flux_r,    flux_u,    flux_v,              &
     cd_m,      cd_t,       cd_q,                                      &
     w_atm,     u_star,     b_star,     q_star,                        &
     dhdt_surf, dedt_surf,  dedq_surf,  drdt_surf,                     &
     dhdt_atm,  dedq_atm,   dtaudu_atm, dtaudv_atm,                    &
     dt,        land,       seawater,  avail  )

  ! ---- arguments -----------------------------------------------------------
  logical, intent(in), dimension(:,:) :: land,  seawater, avail
  real, intent(in),  dimension(:,:) :: &
       t_atm,     q_atm_in,   u_atm,     v_atm,              &
       p_atm,     z_atm,      t_ca,                          &
       p_surf,    t_surf,     u_surf,    v_surf,             &
       rough_mom, rough_heat, rough_moist, rough_scale, gust
  real, intent(out), dimension(:,:) :: &
       flux_t,    flux_q,     flux_r,    flux_u,  flux_v,    &
       dhdt_surf, dedt_surf,  dedq_surf, drdt_surf,          &
       dhdt_atm,  dedq_atm,   dtaudu_atm,dtaudv_atm,         &
       w_atm,     u_star,     b_star,    q_star,             &
       cd_m,      cd_t,       cd_q
  real, intent(inout), dimension(:,:) :: q_surf
  real, intent(in) :: dt

  ! ---- local vars -----------------------------------------------------------
  integer :: j

  do j = 1, size(t_atm,2)
     call surface_flux_1d (                                           &
          t_atm(:,j),     q_atm_in(:,j),   u_atm(:,j),     v_atm(:,j),     p_atm(:,j),     z_atm(:,j),    &
          p_surf(:,j),    t_surf(:,j),     t_ca(:,j),      q_surf(:,j),                                   &
          u_surf(:,j),    v_surf(:,j),                                                                    &
          rough_mom(:,j), rough_heat(:,j), rough_moist(:,j), rough_scale(:,j), gust(:,j),                 &
          flux_t(:,j),    flux_q(:,j),     flux_r(:,j),    flux_u(:,j),    flux_v(:,j),                   &
          cd_m(:,j),      cd_t(:,j),       cd_q(:,j),                                                     &
          w_atm(:,j),     u_star(:,j),     b_star(:,j),     q_star(:,j),                                  &
          dhdt_surf(:,j), dedt_surf(:,j),  dedq_surf(:,j),  drdt_surf(:,j),                               &
          dhdt_atm(:,j),  dedq_atm(:,j),   dtaudu_atm(:,j), dtaudv_atm(:,j),                              &
          dt,             land(:,j),       seawater(:,j),  avail(:,j)  )
  end do
end subroutine surface_flux_2d


! ============================================================================
!  Initialization of the surface flux module--reads the nml.     
!
subroutine surface_flux_init

! ---- local vars ----------------------------------------------------------
  integer :: unit, ierr, io

  ! read namelist
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, surface_flux_nml, iostat=io)
#else
  if ( file_exist('input.nml')) then
     unit = open_namelist_file ()
     ierr=1; 
     do while (ierr /= 0)
        read  (unit, nml=surface_flux_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'surface_flux_nml')
     enddo
10   call close_file (unit)
  endif
#endif

  ! write version number
  call write_version_number(version, tagname)

  unit = stdlog()
  if ( mpp_pe() == mpp_root_pe() )  write (unit, nml=surface_flux_nml)
  
  if(.not. use_virtual_temp) d608 = 0.0
  
  do_init = .false.
  
end subroutine surface_flux_init



!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
! Over-ocean fluxes following Large and Yeager (used in NCAR models)           !
! Original  code: Michael.Winton@noaa.gov
! Update Jul2007: Stephen.Griffies@noaa.gov (ch and ce exchange coeff bugfix)  
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
!
subroutine ncar_ocean_fluxes (u_del, t, ts, q, qs, z, avail, &
                              cd, ch, ce, ustar, bstar       )
real   , intent(in)   , dimension(:) :: u_del, t, ts, q, qs, z
logical, intent(in)   , dimension(:) :: avail
real   , intent(inout), dimension(:) :: cd, ch, ce, ustar, bstar

  real :: cd_n10, ce_n10, ch_n10, cd_n10_rt    ! neutral 10m drag coefficients
  real :: cd_rt                                ! full drag coefficients @ z
  real :: zeta, x2, x, psi_m, psi_h            ! stability parameters
  real :: u, u10, tv, tstar, qstar, z0, xx, stab
  integer, parameter :: n_itts = 2
  integer               i, j

  if(ncar_ocean_flux_orig) then

      do i=1,size(u_del(:))
         if (avail(i)) then
             tv = t(i)*(1+0.608*q(i));
             u = max(u_del(i), 0.5);                                 ! 0.5 m/s floor on wind (undocumented NCAR)
             u10 = u;                                                ! first guess 10m wind

             cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3;                ! L-Y eqn. 6a
             cd_n10_rt = sqrt(cd_n10);
             ce_n10 =                     34.6 *cd_n10_rt/1e3;       ! L-Y eqn. 6b
             stab = 0.5 + sign(0.5,t(i)-ts(i))
             ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3;       ! L-Y eqn. 6c

             cd(i) = cd_n10;                                         ! first guess for exchange coeff's at z
             ch(i) = ch_n10;
             ce(i) = ce_n10;
             do j=1,n_itts                                           ! Monin-Obukhov iteration
                cd_rt = sqrt(cd(i));
                ustar(i) = cd_rt*u;                                   ! L-Y eqn. 7a
                tstar    = (ch(i)/cd_rt)*(t(i)-ts(i));                ! L-Y eqn. 7b
                qstar    = (ce(i)/cd_rt)*(q(i)-qs(i));                ! L-Y eqn. 7c
                bstar(i) = grav*(tstar/tv+qstar/(q(i)+1/0.608));
                zeta     = vonkarm*bstar(i)*z(i)/(ustar(i)*ustar(i)); ! L-Y eqn. 8a
                zeta     = sign( min(abs(zeta),10.0), zeta );         ! undocumented NCAR
                x2 = sqrt(abs(1-16*zeta));                            ! L-Y eqn. 8b
                x2 = max(x2, 1.0);                                    ! undocumented NCAR
                x = sqrt(x2);

                if (zeta > 0) then
                    psi_m = -5*zeta;                                    ! L-Y eqn. 8c
                    psi_h = -5*zeta;                                    ! L-Y eqn. 8c
                else
                    psi_m = log((1+2*x+x2)*(1+x2)/8)-2*(atan(x)-atan(1.0)); ! L-Y eqn. 8d
                    psi_h = 2*log((1+x2)/2);                                ! L-Y eqn. 8e
                end if

                u10 = u/(1+cd_n10_rt*(log(z(i)/10)-psi_m)/vonkarm);       ! L-Y eqn. 9
                cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3;                  ! L-Y eqn. 6a again
                cd_n10_rt = sqrt(cd_n10);
                ce_n10 = 34.6*cd_n10_rt/1e3;                              ! L-Y eqn. 6b again
                stab = 0.5 + sign(0.5,zeta)
                ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3;         ! L-Y eqn. 6c again
                z0 = 10*exp(-vonkarm/cd_n10_rt);                          ! diagnostic

                xx = (log(z(i)/10)-psi_m)/vonkarm;
                cd(i) = cd_n10/(1+cd_n10_rt*xx)**2;                       ! L-Y 10a
                xx = (log(z(i)/10)-psi_h)/vonkarm;
                ch(i) = ch_n10/(1+ch_n10*xx/cd_n10_rt)**2;                !     10b (this code is wrong)  
                ce(i) = ce_n10/(1+ce_n10*xx/cd_n10_rt)**2;                !     10c (this code is wrong)
             end do
         end if
      end do

  else

      do i=1,size(u_del(:))
         if (avail(i)) then
             tv = t(i)*(1+0.608*q(i));
             u = max(u_del(i), 0.5);                                 ! 0.5 m/s floor on wind (undocumented NCAR)
             u10 = u;                                                ! first guess 10m wind

             cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3;                ! L-Y eqn. 6a
             cd_n10_rt = sqrt(cd_n10);
             ce_n10 =                     34.6 *cd_n10_rt/1e3;       ! L-Y eqn. 6b
             stab = 0.5 + sign(0.5,t(i)-ts(i))
             ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3;       ! L-Y eqn. 6c

             cd(i) = cd_n10;                                         ! first guess for exchange coeff's at z
             ch(i) = ch_n10;
             ce(i) = ce_n10;
             do j=1,n_itts                                           ! Monin-Obukhov iteration
                cd_rt = sqrt(cd(i));
                ustar(i) = cd_rt*u;                                   ! L-Y eqn. 7a
                tstar    = (ch(i)/cd_rt)*(t(i)-ts(i));                ! L-Y eqn. 7b
                qstar    = (ce(i)/cd_rt)*(q(i)-qs(i));                ! L-Y eqn. 7c
                bstar(i) = grav*(tstar/tv+qstar/(q(i)+1/0.608));
                zeta     = vonkarm*bstar(i)*z(i)/(ustar(i)*ustar(i)); ! L-Y eqn. 8a
                zeta     = sign( min(abs(zeta),10.0), zeta );         ! undocumented NCAR
                x2 = sqrt(abs(1-16*zeta));                            ! L-Y eqn. 8b
                x2 = max(x2, 1.0);                                    ! undocumented NCAR
                x = sqrt(x2);

                if (zeta > 0) then
                    psi_m = -5*zeta;                                    ! L-Y eqn. 8c
                    psi_h = -5*zeta;                                    ! L-Y eqn. 8c
                else
                    psi_m = log((1+2*x+x2)*(1+x2)/8)-2*(atan(x)-atan(1.0)); ! L-Y eqn. 8d
                    psi_h = 2*log((1+x2)/2);                                ! L-Y eqn. 8e
                end if

                u10 = u/(1+cd_n10_rt*(log(z(i)/10)-psi_m)/vonkarm);       ! L-Y eqn. 9
                cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3;                  ! L-Y eqn. 6a again
                cd_n10_rt = sqrt(cd_n10);
                ce_n10 = 34.6*cd_n10_rt/1e3;                              ! L-Y eqn. 6b again
                stab = 0.5 + sign(0.5,zeta)
                ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3;         ! L-Y eqn. 6c again
                z0 = 10*exp(-vonkarm/cd_n10_rt);                          ! diagnostic

                xx = (log(z(i)/10)-psi_m)/vonkarm;
                cd(i) = cd_n10/(1+cd_n10_rt*xx)**2;                       ! L-Y 10a
                xx = (log(z(i)/10)-psi_h)/vonkarm;
                ch(i) = ch_n10/(1+ch_n10*xx/cd_n10_rt)*sqrt(cd(i)/cd_n10) ! 10b (corrected code)
                ce(i) = ce_n10/(1+ce_n10*xx/cd_n10_rt)*sqrt(cd(i)/cd_n10) ! 10c (corrected code)
             end do
         end if
      end do

  endif

end subroutine ncar_ocean_fluxes


end module surface_flux_mod



module ice_model_mod

use   ice_albedo_mod, only:  ice_albedo_init, ice_albedo

use ocean_albedo_mod, only:  compute_ocean_albedo_new

use  ocean_rough_mod, only:  compute_ocean_roughness, fixed_ocean_roughness

use          fms_mod, only: file_exist, open_restart_file, close_file, &
                            mpp_pe, mpp_root_pe, mpp_npes, write_version_number, stdlog,   &
                            error_mesg, FATAL, check_nml_error, read_data, write_data,     &
                            NOTE, WARNING, field_exist, field_size, get_mosaic_tile_grid, stdout

use fms_io_mod,       only: save_restart, register_restart_field, restart_file_type, &
                            restore_state, set_domain, nullify_domain, query_initialized, &
                            get_restart_io_mode

use mpp_mod,          only: mpp_chksum

#ifdef INTERNAL_FILE_NML
use          mpp_mod, only: input_nml_file
#else
use          fms_mod, only: open_namelist_file
#endif

use    constants_mod, only: hlv, hlf, tfreeze, pi, radius

use  mpp_domains_mod, only: domain1d, domain2d, mpp_define_domains, mpp_get_compute_domain, &
                            mpp_get_compute_domains, mpp_get_domain_components, mpp_get_pelist, &
                            mpp_define_layout, mpp_define_io_domain

use diag_manager_mod, only: diag_axis_init, register_diag_field, send_data

use time_manager_mod, only: time_type, operator(+)

use mosaic_mod,       only: get_mosaic_ntiles, get_mosaic_grid_sizes, calc_mosaic_grid_area
use mosaic_mod,       only: get_mosaic_xgrid_size, get_mosaic_xgrid

use  amip_interp_mod, only: amip_interp_type, amip_interp_new, amip_interp_del, get_amip_ice
use coupler_types_mod,only: coupler_2d_bc_type, coupler_3d_bc_type
implicit none
private

public :: ice_data_type, ocean_ice_boundary_type,               &
          atmos_ice_boundary_type, land_ice_boundary_type,      &
          ice_model_init, ice_model_end, update_ice_model_fast, &
          update_ice_model_slow_up, update_ice_model_slow_dn,   &
          ice_stock_pe, cell_area, ice_model_restart,           &
          ocn_ice_bnd_type_chksum, atm_ice_bnd_type_chksum, &
          lnd_ice_bnd_type_chksum, ice_data_type_chksum

type ice_data_type
  type(domain2d)                        :: Domain

   logical                              :: pe

   real,    pointer, dimension(:)       :: glon_bnd =>NULL(), &
                                           glat_bnd =>NULL(), &
                                           lon_bnd =>NULL() , &
                                           lat_bnd =>NULL()

   real,    pointer, dimension(:,:)     :: glon =>NULL(), &
                                           glat =>NULL(), &
                                           lon =>NULL(), &
                                           lat =>NULL()

   logical, pointer, dimension(:,:)     :: gmask =>NULL(), &
                                           mask =>NULL()

   logical, pointer, dimension(:,:,:)   :: ice_mask =>NULL()

   real,    pointer, dimension(:,:,:,:) :: temp =>NULL()

   real,    pointer, dimension(:,:,:)   :: part_size =>NULL(), &
                                           t_surf =>NULL(), &
                                           albedo =>NULL(), &
                                           albedo_vis_dir =>NULL(), &
                                           albedo_nir_dir =>NULL(), &
                                           albedo_vis_dif =>NULL(), &
                                           albedo_nir_dif =>NULL(), &
                                           rough_mom =>NULL(),&
                                           rough_heat =>NULL(), &
                                           rough_moist =>NULL(),  &
                                           frazil =>NULL(),  &
                                           u_surf =>NULL(),  &
                                           v_surf =>NULL()

   real,    pointer, dimension(:,:,:)   :: flux_u_bot =>NULL(), &
                                           flux_v_bot =>NULL(), &
                                           flux_t_bot =>NULL(),   &
                                           flux_q_bot =>NULL(), &
                                           flux_lh_bot =>NULL(), &
                                           flux_sw_bot =>NULL(), &
                                           flux_sw_vis_bot =>NULL(), &
                                           flux_sw_dir_bot =>NULL(), &
                                           flux_sw_dif_bot =>NULL(), &
                                           flux_sw_vis_dir_bot =>NULL(), &
                                           flux_sw_vis_dif_bot =>NULL(), &
                                           flux_sw_nir_dir_bot =>NULL(), &
                                           flux_sw_nir_dif_bot =>NULL(), &
                                           flux_lw_bot =>NULL(), &
                                           lprec_bot =>NULL(), &
                                           fprec_bot =>NULL(), &
                                           runoff_bot =>NULL()

   real,    pointer, dimension(:,:  )   :: flux_u =>NULL(), &
                                           flux_v =>NULL(), &
                                           flux_t =>NULL(), &
                                           flux_q =>NULL(), &
                                           flux_lh =>NULL(), &
                                           flux_sw =>NULL(), &
                                           flux_sw_vis =>NULL(), &
                                           flux_sw_dir =>NULL(), &
                                           flux_sw_dif =>NULL(), &
                                           flux_sw_vis_dir =>NULL(), &
                                           flux_sw_vis_dif =>NULL(), &
                                           flux_sw_nir_dir =>NULL(), &
                                           flux_sw_nir_dif =>NULL(), &
                                           flux_lw =>NULL(), &
                                           lprec =>NULL(), &
                                           fprec =>NULL(), &
                                           p_surf =>NULL(), &
                                           runoff =>NULL(), &
                                           calving =>NULL(), &
                                           runoff_hflx =>NULL(), &
                                           calving_hflx =>NULL(), &
                                           area =>NULL(), &
                                           flux_salt =>NULL()
  logical, pointer, dimension(:,:) :: maskmap =>NULL()   ! A pointer to an array indicating which
                                                         ! logical processors are actually used for
                                                         ! the ocean code. The other logical
                                                         ! processors would be all land points and
                                                         ! are not assigned to actual processors.
                                                         ! This need not be assigned if all logical
                                                         ! processors are used. This variable is dummy and need 
                                                         ! not to be set, but it is needed to pass compilation.

   integer                              :: avg_kount

   real,    pointer, dimension(:,:,:)   :: thickness =>NULL()

   type (time_type)                     :: Time_Init, Time,  &
                                           Time_step_fast,   &
                                           Time_step_slow
   integer, dimension(3)              :: axes
   type(coupler_3d_bc_type)           :: ocean_fields       ! array of fields used for additional tracers
   type(coupler_2d_bc_type)           :: ocean_fluxes       ! array of fluxes used for additional tracers
   type(coupler_3d_bc_type)           :: ocean_fluxes_top   ! array of fluxes for averaging

end type ice_data_type

type :: ocean_ice_boundary_type
  real, dimension(:,:),   pointer :: u =>NULL(), &
                                     v =>NULL(), &
                                     t =>NULL(), &
                                     s =>NULL(), &
                                     frazil =>NULL(), &
                                     sea_level =>NULL()
  real, dimension(:,:,:), pointer :: data =>NULL()
  integer                         :: xtype
  type(coupler_2d_bc_type)        :: fields     ! array of fields used for additional tracers
end type ocean_ice_boundary_type

type :: atmos_ice_boundary_type
  real, dimension(:,:,:), pointer :: u_flux =>NULL(), &
                                     v_flux =>NULL(), &
                                     u_star =>NULL(), &
                                     t_flux =>NULL(), &
                                     q_flux =>NULL(), &
                                     lw_flux =>NULL(), &
                                     sw_flux_vis_dir =>NULL(), &
                                     sw_flux_vis_dif =>NULL(), &
                                     sw_flux_nir_dir =>NULL(), &
                                     sw_flux_nir_dif =>NULL(), &
                                     lprec =>NULL(), &
                                     fprec =>NULL()
  real, dimension(:,:,:), pointer :: dhdt =>NULL(), &
                                     dedt =>NULL(), &
                                     drdt =>NULL(), &
                                     coszen =>NULL(), &
                                     p =>NULL(), &
                                     data =>NULL()
  integer                         :: xtype
  type(coupler_3d_bc_type)        :: fluxes     ! array of fluxes used for additional tracers
end type atmos_ice_boundary_type

type :: land_ice_boundary_type
  real, dimension(:,:),   pointer :: runoff =>NULL(), &
                                     calving =>NULL(), &
                                     runoff_hflx =>NULL(), &
                                     calving_hflx =>NULL()
  real, dimension(:,:,:), pointer :: data =>NULL()
  integer :: xtype
end type land_ice_boundary_type

character(len=128) :: version = '$Id: ice_model.F90,v 17.0.2.1.2.1.4.1 2010/11/15 18:34:53 bw Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

character(len=80) :: restart_format = 'amip ice model restart format 02'
logical :: module_is_initialized = .false.
logical :: stock_warning_issued  = .false.

! id's for diagnostics
integer :: id_sh, id_lh, id_sw, id_lw, id_snofl, id_rain, &
           id_runoff, id_calving, id_evap, id_fax, id_fay, &
           id_sw_vis, id_sw_dir, id_sw_dif, id_sw_vis_dir, id_sw_vis_dif, &
           id_sw_nir_dir, id_sw_nir_dif
logical :: sent

!-----------------------------------------------------------------------
!
!  use_climo_ice           = use monthly climatological amip ice mask
!  use_annual_ice          = use annual climatology amip ice mask
!  temp_ice_freeze         = temperature at which sea ice melts
!  no_ice                  = run with no ice (only open water)
!  use_leads               = use fraction ice coverage (i.e., leads) if it exists
!  roughness_ice           = constant roughness for all ice
!  specified_ice_thickness = constant thickness for specified ice

integer, parameter :: num_lev  = 1
integer, parameter :: num_part = 2

real    :: diff                     = 2.092  
real    :: thickness_min            = 0.10 
real    :: specified_ice_thickness  = 2.0
real    :: temp_ice_freeze          = -1.66    ! was 271.5
real    :: roughness_ice            = 1.e-4
logical :: no_ice                   = .false.
logical :: use_leads                = .false.
logical :: use_climo_ice            = .false.
logical :: use_annual_ice           = .false.
integer, dimension(2) :: layout     = (/ 0, 0 /)
integer, dimension(2) :: io_layout  = (/ 0, 0 /)
character(len=64) :: interp_method  = "conservative" ! default conservative scheme
logical :: do_netcdf_restart        = .true.
character(len=128) :: axisname_x    = 'xt'  ! x-axis name of temperature grid
character(len=128) :: axisname_y    = 'yt'  ! y-axis name of temperature grid
character(len=128) :: axisname_xb   = 'xb'  ! x-axis bounds name of temperature grid
character(len=128) :: axisname_yb   = 'yb'  ! y-axis bounds name of temperature grid

namelist /ice_model_nml/ do_netcdf_restart, diff, thickness_min, &
                         specified_ice_thickness,                &
                         temp_ice_freeze, roughness_ice,         &
                         use_climo_ice, use_annual_ice,          &
                         no_ice, use_leads, layout, interp_method,  &
                         axisname_x, axisname_y, axisname_xb, axisname_yb, &
                         io_layout

real, parameter :: latent = hlv + hlf
type(amip_interp_type), save :: Amip
real, allocatable, dimension(:,:) ::  cell_area  ! grid cell area; sphere frac.

integer :: id_restart_albedo
integer :: mlon, mlat, npart ! global grid size
type(restart_file_type), save :: Ice_restart

contains

!=============================================================================================
  subroutine ice_model_init( Ice, Time_Init, Time, Time_step_fast, Time_step_slow )
    type(ice_data_type), intent(inout) :: Ice
    type(time_type)    , intent(in)    :: Time_Init, Time, Time_step_fast, Time_step_slow

    real, allocatable, dimension(:,:)   :: geo_lonv, geo_latv, rmask
    real, allocatable, dimension(:,:)   :: geo_lont, geo_latt
    real, allocatable, dimension(:,:,:) :: x_vert_T, y_vert_T
    real, allocatable, dimension(:)     :: glonb, glatb
    real, allocatable, dimension(:)     :: xb, yb ! 1d global grid for diag_mgr
    real, allocatable, dimension(:,:)   :: tmpx, tmpy, garea
    real, allocatable, dimension(:)     :: xgrid_area(:)
    integer, allocatable, dimension(:)  :: i1, j1, i2, j2
    integer                             :: io, ierr, unit, siz(4)
    integer                             :: nlon, nlat, is, ie, js, je, i, j, k
    character(len=80)                   :: control
    character(len=80)                   :: domainname
    character(len=256)                  :: err_mesg
    character(len=64)                   :: fname = 'INPUT/ice_model.res.nc'
    character(len=64)                   :: lvltag
    character(len=256)                  :: grid_file='INPUT/grid_spec.nc'
    character(len=256)                  :: ocean_mosaic, tile_file
    character(len=256)                  :: axo_file      ! atmosXocean exchange grid file
    integer                             :: nx(1), ny(1)
    integer                             :: ntiles, nfile_axo, nxgrid, n, m
    integer                             :: grid_version
    integer, parameter                  :: VERSION_0 = 0  ! grid file with field geolon_t
    integer, parameter                  :: VERSION_1 = 1  ! grid file with field x_T
    integer, parameter                  :: VERSION_2 = 2  ! mosaic file

    if(module_is_initialized) return

#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=ice_model_nml, iostat=io)
    ierr = check_nml_error(io, 'ice_model_nml')
#else
    if ( file_exist( 'input.nml' ) ) then
       unit = open_namelist_file ( )
       ierr = 1
       do while ( ierr /= 0 )
          read ( unit,  nml = ice_model_nml, iostat = io, end = 10 )
          ierr = check_nml_error ( io, 'ice_model_nml' )
       enddo
10     continue
       call close_file (unit)
    endif
#endif

    call get_restart_io_mode(do_netcdf_restart)

    call write_version_number (version, tagname)
    if ( mpp_pe() == mpp_root_pe() ) then
       write (stdlog(), nml=ice_model_nml)
    endif

   !if (num_part /= 2) call error_mesg ('ice_model_init','this version must have num_part = 2', FATAL)
   !if (num_lev  /= 1) call error_mesg ('ice_model_init','this version must have num_lev = 1', FATAL)

    !--- get the grid size 
    if(field_exist(grid_file, 'geolon_t')) then
       grid_version = VERSION_0 
       call field_size( grid_file, 'geolon_t', siz)  
       nlon = siz(1)
       nlat = siz(2)        
    else if(field_exist(grid_file, 'x_T')) then
       grid_version = VERSION_1
       call field_size( grid_file, 'x_T', siz)
       nlon = siz(1)
       nlat = siz(2) 
    else if(field_exist(grid_file, 'ocn_mosaic_file') ) then ! read from mosaic file
       grid_version = VERSION_2
       call read_data(grid_file, "ocn_mosaic_file", ocean_mosaic)
       ocean_mosaic = "INPUT/"//trim(ocean_mosaic)
       ntiles = get_mosaic_ntiles(ocean_mosaic)
       if(ntiles .NE. 1) call error_mesg('ice_model_init', ' ntiles should be 1 for ocean mosaic, contact developer', FATAL)
       call get_mosaic_grid_sizes( ocean_mosaic, nx, ny)
       nlon = nx(1)
       nlat = ny(1)
    else
       call error_mesg('ice_model_init','x_T, geolon_t, ocn_mosaic_file does not exist in file '//trim(grid_file), FATAL )
    end if

    if( nlon .LE. 0 .or. nlat .LE. 0 ) call error_mesg('ice_model_init', 'nlon and nlat should be a positive integer.', FATAL)

    !----- set up global storage and local storage -----
    allocate(Ice%gmask(nlon,nlat),    rmask(nlon,nlat) )
    allocate(geo_lonv(nlon+1,nlat+1), geo_latv(nlon+1,nlat+1) )
    allocate(geo_lont(nlon,  nlat),   geo_latt(nlon,  nlat)   )
    allocate(Ice%glon_bnd(nlon+1),    Ice%glat_bnd(nlat+1)    )
    allocate(Ice%glon(nlon,nlat),     Ice%glat(nlon,nlat)     )
    allocate(glonb(nlon+1), glatb(nlat+1), xb(nlon+1), yb(nlat+1) )

    !-------------------- domain decomposition -----------------------------
    if( layout(1).EQ.0 .AND. layout(2).EQ.0 ) &
         call mpp_define_layout( (/1,nlon,1,nlat/), mpp_npes(), layout )
    if( layout(1).NE.0 .AND. layout(2).EQ.0 )layout(2) = mpp_npes()/layout(1)
    if( layout(1).EQ.0 .AND. layout(2).NE.0 )layout(1) = mpp_npes()/layout(2)
    domainname = 'AMIP Ice'
    call mpp_define_domains( (/1,nlon,1,nlat/), layout, Ice%Domain, name=domainname )
    call mpp_define_io_domain (Ice%Domain, io_layout)
    call set_domain (Ice%Domain)
    call mpp_get_compute_domain( Ice%Domain, is, ie, js, je )

    !---------------- read ice cell areas from grid_spec.nc or ----------------
    !---------------- calculate the area for mosaic grid file  ----------------
    allocate (cell_area(is:ie, js:je))
    cell_area = 0.0
    select case (grid_version)
    case(VERSION_0)
       call read_data(grid_file, "geolon_t",      geo_lont, no_domain=.TRUE. )
       call read_data(grid_file, "geolat_t",      geo_latt, no_domain=.TRUE. )
       call read_data(grid_file, "geolon_vert_t", geo_lonv, no_domain=.TRUE. )
       call read_data(grid_file, "geolat_vert_t", geo_latv, no_domain=.TRUE. )
       call read_data(grid_file, "wet",      rmask,     no_domain=.TRUE.)
       call read_data(grid_file, 'AREA_OCN', cell_area, Ice%Domain)
    case(VERSION_1)
       allocate (x_vert_t(nlon,nlat,4), y_vert_t(nlon,nlat,4) ) 
       call read_data(grid_file, "x_T", geo_lont, no_domain=.TRUE. )
       call read_data(grid_file, "y_T", geo_latt, no_domain=.TRUE. )
       call read_data(grid_file, "x_vert_T", x_vert_t, no_domain=.TRUE.)
       call read_data(grid_file, "y_vert_T", y_vert_t, no_domain=.TRUE. )
       geo_lonv(1:nlon,1:nlat) = x_vert_t(1:nlon,1:nlat,1)
       geo_lonv(nlon+1,1:nlat) = x_vert_t(nlon,1:nlat,2)
       geo_lonv(1:nlon,nlat+1) = x_vert_t(1:nlon,nlat,4)
       geo_lonv(nlon+1,nlat+1) = x_vert_t(nlon,nlat,3)
       geo_latv(1:nlon,1:nlat) = y_vert_t(1:nlon,1:nlat,1)
       geo_latv(nlon+1,1:nlat) = y_vert_t(nlon,1:nlat,2)
       geo_latv(1:nlon,nlat+1) = y_vert_t(1:nlon,nlat,4)
       geo_latv(nlon+1,nlat+1) = y_vert_t(nlon,nlat,3)
       deallocate(x_vert_t, y_vert_t)
       call read_data(grid_file, "wet",      rmask,     no_domain=.TRUE.)
       call read_data(grid_file, 'AREA_OCN', cell_area, Ice%Domain)
    case(VERSION_2)
       call get_mosaic_tile_grid(tile_file, ocean_mosaic, Ice%Domain )
       allocate(tmpx(2*nlon+1, 2*nlat+1), tmpy(2*nlon+1, 2*nlat+1) )
       allocate(garea(nlon,nlat))
       call read_data(tile_file, "x", tmpx, no_domain=.TRUE.)
       call read_data(tile_file, "y", tmpy, no_domain=.TRUE.)
       do j = 1, nlat
          do i = 1, nlon
             geo_lont(i,j) = tmpx(i*2,j*2)
             geo_latt(i,j) = tmpy(i*2,j*2)
          end do
       end do
       do j = 1, nlat+1
          do i = 1, nlon+1
             geo_lonv(i,j) = tmpx(i*2-1,j*2-1)
             geo_latv(i,j) = tmpy(i*2-1,j*2-1)
          end do
       end do

       call calc_mosaic_grid_area(geo_lonv*pi/180., geo_latv*pi/180., garea )
       garea = garea/(4*PI*RADIUS*RADIUS)  ! scale the earth are to be 1

       call field_size(grid_file, "aXo_file", siz)
       nfile_axo = siz(2)
       rmask = 0.0
       do n = 1, nfile_axo
          call read_data(grid_file, "aXo_file", axo_file, level=n)
          axo_file = 'INPUT/'//trim(axo_file)
          nxgrid = get_mosaic_xgrid_size(axo_file)
          allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area(nxgrid))
          call get_mosaic_xgrid(aXo_file, i1, j1, i2, j2, xgrid_area)
          do m = 1, nxgrid
             i = i2(m); j = j2(m)
             rmask(i,j) = rmask(i,j) + xgrid_area(m)
          end do
          deallocate(i1, j1, i2, j2, xgrid_area)
       end do
       rmask = rmask/garea    
       cell_area(is:ie,js:je) = garea(is:ie,js:je)  ! zero out the area of the cell on land, maybe not needed  ! kerr
       do j = js, je
          do i = is, ie
             if(rmask(i,j) == 0.0) cell_area(i,j) = 0.0
          end do
       end do
       deallocate(tmpx, tmpy, garea)
    end select

    !--- xb and yb is for diagnostics --------------------------------------
    xb = sum(geo_lonv,2)/(nlat+1)
    yb = sum(geo_latv,1)/(nlon+1)

    !--- for conservation interpolation, the grid should be rectangular ----
    if(trim(interp_method) == "conservative" ) then
       err_mesg = 'Bilinear interpolation must be used for a tripolar grid'
       do i=1,nlon+1
          if(any(geo_lonv(i,1) /= geo_lonv(i,:)))  &
               call error_mesg ('ice_model_init',err_mesg,FATAL)
       enddo
       do j=1,nlat+1
          if(any(geo_latv(1,j) /= geo_latv(:,j)))  &
               call error_mesg ('ice_model_init',err_mesg,FATAL)
       enddo
    endif
    !--- define the ice data -----------------------------------------------
    Ice%gmask = .false.
    where ( rmask > 0 ) Ice%gmask = .true.

    glonb = geo_lonv(:,1)*pi/180.
    glatb = geo_latv(1,:)*pi/180.
    Ice%glon_bnd = glonb
    Ice%glat_bnd = glatb

    Ice % glon = geo_lont*pi/180.
    Ice % glat = geo_latt*pi/180.

    !-----------------------------------------------------------------------

    allocate ( Ice%lon_bnd     (is:ie+1)                        , &
               Ice%lat_bnd     (js:je+1)                        , &
               Ice%lon         (is:ie, js:je)                   , &
               Ice%lat         (is:ie, js:je)                   , &
               Ice%ice_mask    (is:ie, js:je, num_part)         , &
               Ice%temp        (is:ie, js:je, num_part, num_lev), &
               Ice%part_size   (is:ie, js:je, num_part)         , &
               Ice%albedo      (is:ie, js:je, num_part)         , &
            Ice%albedo_vis_dir (is:ie, js:je, num_part)         , &
            Ice%albedo_nir_dir (is:ie, js:je, num_part)         , &
            Ice%albedo_vis_dif (is:ie, js:je, num_part)         , &
            Ice%albedo_nir_dif (is:ie, js:je, num_part)         , &
               Ice%rough_mom   (is:ie, js:je, num_part)         , &
               Ice%rough_heat  (is:ie, js:je, num_part)         , &
               Ice%rough_moist (is:ie, js:je, num_part)         , &
               Ice%u_surf      (is:ie, js:je, num_part)         , &
               Ice%v_surf      (is:ie, js:je, num_part)         , &
               Ice%thickness   (is:ie, js:je, num_part)         , &
               Ice%mask        (is:ie, js:je) )

    Ice%t_surf => Ice%temp (:,:,:,1)

    Ice%lon_bnd    = Ice%glon_bnd(is:ie+1)
    Ice%lat_bnd    = Ice%glat_bnd(js:je+1)
    Ice%lon        = Ice%glon(is:ie, js:je)
    Ice%lat        = Ice%glat(is:ie, js:je)
    Ice%mask       = Ice%gmask(is:ie, js:je)
    Ice%Time           = Time
    Ice%Time_init      = Time_init
    Ice%Time_step_fast = Time_step_fast
    Ice%Time_step_slow = Time_step_slow
    Ice%avg_kount = 0

    allocate ( Ice%flux_u_bot  (is:ie, js:je, num_part) , &
               Ice%flux_v_bot  (is:ie, js:je, num_part) , &
               Ice%flux_t_bot  (is:ie, js:je, num_part) , &
               Ice%flux_q_bot  (is:ie, js:je, num_part) , &
               Ice%flux_lh_bot (is:ie, js:je, num_part) , &
               Ice%flux_sw_bot (is:ie, js:je, num_part) , &
        Ice%flux_sw_vis_bot    (is:ie, js:je, num_part) , &
        Ice%flux_sw_dir_bot    (is:ie, js:je, num_part) , &
        Ice%flux_sw_dif_bot    (is:ie, js:je, num_part) , &
        Ice%flux_sw_vis_dir_bot(is:ie, js:je, num_part) , &
        Ice%flux_sw_vis_dif_bot(is:ie, js:je, num_part) , &
        Ice%flux_sw_nir_dir_bot(is:ie, js:je, num_part) , &
        Ice%flux_sw_nir_dif_bot(is:ie, js:je, num_part) , &
               Ice%flux_lw_bot (is:ie, js:je, num_part) , &
               Ice%lprec_bot   (is:ie, js:je, num_part) , &
               Ice%fprec_bot   (is:ie, js:je, num_part) , &
               Ice%runoff_bot  (is:ie, js:je, num_part) , &
               Ice%frazil      (is:ie, js:je, num_part)   )

    allocate ( Ice%flux_u    (is:ie, js:je) , &
               Ice%flux_v    (is:ie, js:je) , &
               Ice%flux_t    (is:ie, js:je) , &
               Ice%flux_q    (is:ie, js:je) , &
               Ice%flux_lh   (is:ie, js:je) , &
               Ice%flux_sw   (is:ie, js:je) , &
         Ice%flux_sw_vis     (is:ie, js:je) , &
         Ice%flux_sw_dir     (is:ie, js:je) , &
         Ice%flux_sw_dif     (is:ie, js:je) , &
         Ice%flux_sw_vis_dir (is:ie, js:je) , &
         Ice%flux_sw_vis_dif (is:ie, js:je) , &
         Ice%flux_sw_nir_dir (is:ie, js:je) , &
         Ice%flux_sw_nir_dif (is:ie, js:je) , &
               Ice%flux_lw   (is:ie, js:je) , &
               Ice%lprec     (is:ie, js:je) , &
               Ice%fprec     (is:ie, js:je) , &
               Ice%p_surf    (is:ie, js:je) , &
               Ice%runoff    (is:ie, js:je) , &
               Ice%calving   (is:ie, js:je) , &
             Ice%runoff_hflx (is:ie, js:je) , &
             Ice%calving_hflx(is:ie, js:je) , &
             Ice%area        (is:ie, js:je) , &
               Ice%flux_salt (is:ie, js:je)   )

Ice%area = cell_area  * 4*PI*RADIUS*RADIUS

    !-----------------------------------------------------------------------
    !  -------- read restart --------
if (do_netcdf_restart) call ice_register_restart(Ice, 'ice_model.res.nc')

if (file_exist('INPUT/ice_model.res.nc') ) then
  !if (mpp_pe() == mpp_root_pe()) call error_mesg ('ice_model_mod', &
  !         'Reading NetCDF formatted restart file: INPUT/ice_model.res.nc', NOTE)
   call restore_state(Ice_restart)

   if (.not. query_initialized(Ice_restart, id_restart_albedo)) then
      if (mpp_pe() == mpp_root_pe()) call error_mesg ('ice_model_mod', &
                'Initializing diffuse and direct streams to albedo', NOTE)
    ! initialize ocean values - ice values initialized below
      Ice%albedo_vis_dir(:,:,1) = Ice%albedo(:,:,1)
      Ice%albedo_nir_dir(:,:,1) = Ice%albedo(:,:,1)
      Ice%albedo_vis_dif(:,:,1) = Ice%albedo(:,:,1)
      Ice%albedo_nir_dif(:,:,1) = Ice%albedo(:,:,1)
   endif

else
    if (file_exist('INPUT/ice_model.res')) then
       if (mpp_pe() == mpp_root_pe()) call error_mesg ('ice_model_mod', &
            'Reading native formatted restart file.', NOTE)

       unit = open_restart_file ('INPUT/ice_model.res', 'read')

       read  (unit) control

       ! must use correct restart version with native format
       if (trim(control) /= trim(restart_format)) call error_mesg &
            ('ice_model_init', 'invalid restart format', FATAL)

       read  (unit) mlon, mlat, npart

       !     ---- restart resolution must be consistent with input args ---
       if (mlon /= nlon .or. mlat /= nlat .or. npart /= 2)  &
            call error_mesg ('ice_model_init',           &
            'incorrect resolution on restart', FATAL)

       call read_data ( unit, Ice%part_size  )
       call read_data ( unit, Ice%temp       )
       call read_data ( unit, Ice%thickness  )
       call read_data ( unit, Ice%albedo     )

       call read_data ( unit, Ice%albedo_vis_dir )
       call read_data ( unit, Ice%albedo_nir_dir )
       call read_data ( unit, Ice%albedo_vis_dif )
       call read_data ( unit, Ice%albedo_nir_dif )

       call read_data ( unit, Ice%rough_mom  )
       call read_data ( unit, Ice%rough_heat )
       call read_data ( unit, Ice%rough_moist)
       call read_data ( unit, Ice%u_surf     )
       call read_data ( unit, Ice%v_surf     )
       call read_data ( unit, Ice%frazil     )
       call read_data ( unit, Ice%flux_u_bot )
       call read_data ( unit, Ice%flux_v_bot )

       call close_file (unit)

    else

       !     ----- no restart - no ice -----

       Ice%temp      = tfreeze + temp_ice_freeze
       Ice%thickness = 0.0
       Ice%part_size         = 0.0
       Ice%part_size (:,:,1) = 1.0
       Ice%albedo     = 0.14
     ! initialize ocean values - ice values initialized below
       Ice%albedo_vis_dir(:,:,1) = Ice%albedo(:,:,1)
       Ice%albedo_nir_dir(:,:,1) = Ice%albedo(:,:,1)
       Ice%albedo_vis_dif(:,:,1) = Ice%albedo(:,:,1)
       Ice%albedo_nir_dif(:,:,1) = Ice%albedo(:,:,1)
       Ice%rough_mom  = 0.0004
       Ice%rough_heat = 0.0004
       Ice%rough_moist= 0.0004
       Ice%u_surf     = 0.0
       Ice%v_surf     = 0.0
       Ice%frazil     = 0.0

       !     --- open water roughness (initially fixed) ---

       call fixed_ocean_roughness ( Ice%mask, Ice%rough_mom  (:,:,1), &
            Ice%rough_heat (:,:,1), &
            Ice%rough_moist(:,:,1)  )

    endif
endif

!! set ice partiton values to that of Ice%albedo.
   Ice%albedo_vis_dir(:,:,2) = Ice%albedo(:,:,2)
   Ice%albedo_nir_dir(:,:,2) = Ice%albedo(:,:,2)
   Ice%albedo_vis_dif(:,:,2) = Ice%albedo(:,:,2)
   Ice%albedo_nir_dif(:,:,2) = Ice%albedo(:,:,2)

    !---- initialization of ice mask (actually where ice exists) -----
    Ice%ice_mask = .false.
    where (Ice%mask     (:,:)           .and.     &
         Ice%part_size(:,:,2) > 0.0   .and.     &
         Ice%thickness(:,:,2) >= thickness_min) &
         Ice%ice_mask(:,:,2) = .true.


    call ice_albedo_init (tfreeze)

    if(trim(interp_method) == "conservative") then
       Amip = amip_interp_new ( Ice%lon_bnd,     Ice%lat_bnd,  &
            Ice%mask(:,:),                 &
            interp_method = interp_method, &
            use_climo=use_climo_ice,       &
            use_annual=use_annual_ice     )
    else if(trim(interp_method) == "bilinear") then
       Amip = amip_interp_new ( Ice%lon,     Ice%lat,          &
            Ice%mask(:,:),                 &
            interp_method = interp_method, &
            use_climo=use_climo_ice,       &
            use_annual=use_annual_ice     )
    else
       call error_mesg('ice_model_init', 'interp_method should be conservative or bilinear', &
            FATAL)
    endif

    ! --- diagnostics ---

    call ice_diag_init (Ice, xb, yb)

    !--- release the memory ------------------------------------------------
    deallocate(geo_lonv, geo_latv, geo_lont, geo_latt, glonb, glatb, rmask, xb, yb )
    call nullify_domain()

    module_is_initialized = .true.

  end subroutine ice_model_init
!=============================================================================================
subroutine print_layout (npes, layout, Domain)
integer, intent(in) :: npes, layout(2)
type(domain2d), intent(in) :: Domain
integer, dimension(0:npes-1) :: xsize, ysize
integer :: i, j, xlist(layout(1)), ylist(layout(2))
type (domain1D) :: Xdom, Ydom

call mpp_get_compute_domains   ( Domain, xsize=xsize, ysize=ysize )
call mpp_get_domain_components ( Domain, Xdom, Ydom )
call mpp_get_pelist ( Xdom, xlist )
call mpp_get_pelist ( Ydom, ylist ) 

write (*,100)             
write (*,110) (xsize(xlist(i)),i=1,layout(1))
write (*,120) (ysize(ylist(j)),j=1,layout(2))
                               
100 format ('ICE MODEL DOMAIN DECOMPOSITION')
110 format ('  X-AXIS = ',24i4,/,(11x,24i4))
120 format ('  Y-AXIS = ',24i4,/,(11x,24i4))

end subroutine print_layout
!=============================================================================================
subroutine update_ice_model_fast( Atmos_boundary, Ice )
type(atmos_ice_boundary_type), intent(in) :: Atmos_boundary
type (ice_data_type), intent(inout) :: Ice

real, dimension(size(Ice%flux_u_bot,1),size(Ice%flux_u_bot,2),size(Ice%flux_u_bot,3)) ::  &
      ts_new, gamma, flux_i, t_dt_surf, flux_t_new, flux_q_new, flux_lw_new, flux_sw_new, &
      flux_sw_vis_new, flux_sw_dir_new, flux_sw_dif_new, &
      flux_sw_vis_dir_new, flux_sw_vis_dif_new, &
      flux_u_new, flux_v_new, lprec_new, fprec_new, flux_lh_new

!-----------------------------------------------------------------------
!
!   updates ice model on the atmospheric (fast) time step 
!   averages input quantities to be seen by the ocean
!
!    flux_u  = zonal wind stress
!    flux_v  = meridional wind stress
!    flux_sw = net shortwave radiation (down-up) 
!    flux_sw_vis = net visible shortwave radiation (down-up)
!    flux_sw_dir = net direct shortwave radiation (down-up)
!    flux_sw_dif = net diffuse shortwave radiation (down-up)
!    flux_sw_vis_dir = net visible direct shortwave radiation (down-up)
!    flux_sw_vis_dif = net visible diffuse shortwave radiation (down-up)
!    flux_sw_nir_dir = net near IR direct shortwave radiation (down-up)
!    flux_sw_nir_dif = net near IR diffuse shortwave radiation (down-up)
!    flux_lw = net longwave radiation (down-up) 
!    flux_t  = sensible heat flux
!    flux_q  = specific humidity flux
!    flux_lh = latent heat flux
!    lprec   = liquid precipitiation rate (kg/m2/s)
!    fprec   = frozen precipitiation rate (kg/m2/s)
!    coszen  = cosine of the zenith angle
!
!-----------------------------------------------------------------------
!----- set up local copies of fluxes for modification -----

flux_u_new  = Atmos_boundary%u_flux
flux_v_new  = Atmos_boundary%v_flux
flux_t_new  = Atmos_boundary%t_flux
flux_q_new  = Atmos_boundary%q_flux
flux_lh_new = Atmos_boundary%q_flux*hlv
flux_lw_new = Atmos_boundary%lw_flux
flux_sw_new = Atmos_boundary%sw_flux_vis_dir + Atmos_boundary%sw_flux_vis_dif + &
              Atmos_boundary%sw_flux_nir_dir + Atmos_boundary%sw_flux_nir_dif
flux_sw_vis_new = Atmos_boundary%sw_flux_vis_dir + Atmos_boundary%sw_flux_vis_dif
flux_sw_dir_new = Atmos_boundary%sw_flux_vis_dir + Atmos_boundary%sw_flux_nir_dir
flux_sw_dif_new = Atmos_boundary%sw_flux_vis_dif + Atmos_boundary%sw_flux_nir_dif
flux_sw_vis_dir_new = Atmos_boundary%sw_flux_vis_dir
flux_sw_vis_dif_new = Atmos_boundary%sw_flux_vis_dif
lprec_new   = Atmos_boundary%lprec
fprec_new   = Atmos_boundary%fprec

!----- implicit update of ice surface temperature -----

ts_new = 0.0

where (Ice%ice_mask)
  gamma = diff / max(Ice%thickness,thickness_min)
  flux_i = gamma * (tfreeze + temp_ice_freeze - Ice%t_surf)

  t_dt_surf = (flux_i + Atmos_boundary%lw_flux + &
               Atmos_boundary%sw_flux_vis_dir + &
               Atmos_boundary%sw_flux_vis_dif + &
               Atmos_boundary%sw_flux_nir_dir + &
               Atmos_boundary%sw_flux_nir_dif - &
               Atmos_boundary%t_flux - Atmos_boundary%q_flux*latent)           &
           / (Atmos_boundary%dhdt + Atmos_boundary%dedt*latent + Atmos_boundary%drdt + gamma)

  ts_new = Ice%t_surf + t_dt_surf
  flux_lh_new = flux_lh_new + Atmos_boundary%q_flux*hlf
endwhere

!   ----- compute new fluxes (adjusted for temp change) -----
!              (longwave up has negative sign)

where (Ice%ice_mask .and. ts_new > tfreeze )
  t_dt_surf   = tfreeze - Ice%t_surf
  Ice%t_surf  = tfreeze
  flux_t_new  = flux_t_new  + t_dt_surf * Atmos_boundary%dhdt
  flux_q_new  = flux_q_new  + t_dt_surf * Atmos_boundary%dedt
  flux_lh_new = flux_lh_new + t_dt_surf * Atmos_boundary%dedt*latent
  flux_lw_new = flux_lw_new - t_dt_surf * Atmos_boundary%drdt
endwhere

where (Ice%ice_mask .and. ts_new <= tfreeze)
  Ice%t_surf  = Ice%t_surf  + t_dt_surf
  flux_t_new  = flux_t_new  + t_dt_surf * Atmos_boundary%dhdt
  flux_q_new  = flux_q_new  + t_dt_surf * Atmos_boundary%dedt
  flux_lh_new = flux_lh_new + t_dt_surf * Atmos_boundary%dedt*latent
  flux_lw_new = flux_lw_new - t_dt_surf * Atmos_boundary%drdt
endwhere

!-----------------------------------------------------------------------
!------ update ocean/ice surface parameters --------

!  ---- over ice -----

where (Ice%ice_mask)
  Ice%rough_mom   = roughness_ice
  Ice%rough_heat  = roughness_ice
  Ice%rough_moist = roughness_ice
endwhere

call ice_albedo (Ice%ice_mask, Ice%thickness, Ice%t_surf, Ice%albedo)

!!! EIther define some or all of the additional albedoes in ice_albedo, 
!!! or define them  upon return, based on the values returned.
!call ice_albedo (Ice%ice_mask, Ice%thickness, Ice%t_surf, Ice%albedo, &
!                 Ice%albedo_vis_dir, Ice%albedo_nir_dir,   &
!               Ice%albedo_vis_dif, Ice%albedo_nir_dif)

!! FOR now, simply set all to be the same:
     Ice%albedo_vis_dir = Ice%albedo
     Ice%albedo_nir_dir = Ice%albedo
     Ice%albedo_vis_dif = Ice%albedo
     Ice%albedo_nir_dif = Ice%albedo

!  ---- over ocean -----
!  store values into ice-free partition (n=1)

call compute_ocean_roughness ( Ice%mask,   &       
            Atmos_boundary%u_star(:,:,1),  &
            Ice%rough_mom(:,:,1), Ice%rough_heat(:,:,1), Ice%rough_moist(:,:,1) )

!!! EIther define some or all of the additional albedoes in 
!!   compute_ocean_albedo, or define them  upon return, based on the 
!!   values returned.

!call compute_ocean_albedo ( Ice%mask, Atmos_boundary%coszen(:,:,1), Ice%albedo(:,:,1) )
call compute_ocean_albedo_new ( Ice%mask, Atmos_boundary%coszen(:,:,1), &
                                Ice%albedo_vis_dir(:,:,1), Ice%albedo_vis_dif(:,:,1),      &
                                Ice%albedo_nir_dir(:,:,1), Ice%albedo_nir_dif(:,:,1), Ice%lat )

!-----------------------------------------------------------------------
!----- average fluxes to be used by the ocean model -----
!-----------------------------------------------------------------------

    call sum_bottom_quantities ( Ice, flux_u_new,  flux_v_new,  &
                                      flux_t_new,  flux_q_new,  flux_lh_new,  &
                                      flux_sw_new, flux_lw_new, &
                                      lprec_new,   fprec_new,   &
                                      flux_sw_vis_new, flux_sw_dir_new,&
                                      flux_sw_dif_new,   &
                                      flux_sw_vis_dir_new,&
                                      flux_sw_vis_dif_new )

!-----------------------------------------------------------------------
!--------- advance time -----------------

Ice%Time = Ice%Time + Ice%Time_step_fast

!--------- do diagnostics here ----------

end subroutine update_ice_model_fast
!=============================================================================================

subroutine sum_bottom_quantities ( Ice, flux_u,  flux_v,  &
                                        flux_t,  flux_q,  flux_lh, &
                                        flux_sw, flux_lw, &
                                        lprec,   fprec,   &
                                        flux_sw_vis, flux_sw_dir,&
                                        flux_sw_dif,   &
                                        flux_sw_vis_dir,&
                                        flux_sw_vis_dif )

type (ice_data_type), intent(inout)  :: Ice
real, intent(in), dimension(:,:,:)   :: flux_u,  flux_v,  &
                                        flux_t,  flux_q,  flux_lh, &
                                        flux_sw, flux_lw, &
                                        lprec,   fprec,   &
                                        flux_sw_vis, flux_sw_dir,&
                                        flux_sw_dif,   &
                                        flux_sw_vis_dir,&
                                        flux_sw_vis_dif

if (Ice%avg_kount == 0) call zero_bottom_quantities (Ice)

Ice%flux_u_bot  = Ice%flux_u_bot  + flux_u
Ice%flux_v_bot  = Ice%flux_v_bot  + flux_v
Ice%flux_t_bot  = Ice%flux_t_bot  + flux_t
Ice%flux_q_bot  = Ice%flux_q_bot  + flux_q
Ice%flux_lh_bot = Ice%flux_lh_bot + flux_lh
Ice%flux_sw_bot = Ice%flux_sw_bot + flux_sw
Ice%flux_sw_vis_bot = Ice%flux_sw_vis_bot + flux_sw_vis
Ice%flux_sw_dir_bot = Ice%flux_sw_dir_bot + flux_sw_dir
Ice%flux_sw_dif_bot = Ice%flux_sw_dif_bot + flux_sw_dif
Ice%flux_sw_vis_dir_bot = Ice%flux_sw_vis_dir_bot + flux_sw_vis_dir
Ice%flux_sw_vis_dif_bot = Ice%flux_sw_vis_dif_bot + flux_sw_vis_dif
Ice%flux_sw_nir_dir_bot = Ice%flux_sw_nir_dir_bot + flux_sw_vis_dir
Ice%flux_sw_nir_dif_bot = Ice%flux_sw_nir_dif_bot + flux_sw_vis_dif
Ice%flux_lw_bot = Ice%flux_lw_bot + flux_lw
Ice%lprec_bot   = Ice%lprec_bot   + lprec
Ice%fprec_bot   = Ice%fprec_bot   + fprec

Ice%avg_kount = Ice%avg_kount + 1

end subroutine sum_bottom_quantities
!=============================================================================================
subroutine zero_bottom_quantities ( Ice )
type (ice_data_type), intent(inout) :: Ice

Ice%avg_kount = 0
Ice%flux_u_bot  = 0.0
Ice%flux_v_bot  = 0.0
Ice%flux_t_bot  = 0.0
Ice%flux_q_bot  = 0.0
Ice%flux_lh_bot = 0.0
Ice%flux_sw_bot = 0.0
Ice%flux_sw_vis_bot = 0.0
Ice%flux_sw_dir_bot = 0.0
Ice%flux_sw_dif_bot = 0.0
Ice%flux_sw_vis_dir_bot = 0.0
Ice%flux_sw_vis_dif_bot = 0.0
Ice%flux_sw_nir_dir_bot = 0.0
Ice%flux_sw_nir_dif_bot = 0.0
Ice%flux_lw_bot = 0.0
Ice%lprec_bot   = 0.0
Ice%fprec_bot   = 0.0

end subroutine zero_bottom_quantities
!=============================================================================================
subroutine update_ice_model_slow_up( Ocean_boundary, Ice )
type(ocean_ice_boundary_type), intent(in) :: Ocean_boundary
type(ice_data_type),           intent(inout) :: Ice

call ice_bottom_to_ice_top ( Ice, &
                             Ocean_boundary%t,      &
                             Ocean_boundary%frazil, &
                             Ocean_boundary%u,      &
                             Ocean_boundary%v )

end subroutine update_ice_model_slow_up
!=============================================================================================
subroutine ice_bottom_to_ice_top ( Ice, t_surf_ice_bot, frazil_ice_bot, &
                                   u_surf_ice_bot, v_surf_ice_bot  )

type (ice_data_type), intent(inout) :: Ice
real, dimension(:,:), intent(in)    :: t_surf_ice_bot,  frazil_ice_bot, &
                                       u_surf_ice_bot,  v_surf_ice_bot
!-----------------------------------------------------------------------
!                 pass ocean state through ice
!            store values into ice-free partition (n=1)

where (Ice%part_size(:,:,1) > .00001)
  Ice%temp  (:,:,1,1) = t_surf_ice_bot
  Ice%frazil(:,:,1)   = frazil_ice_bot
  Ice%u_surf(:,:,1)   = u_surf_ice_bot
  Ice%v_surf(:,:,1)   = v_surf_ice_bot
endwhere

 end subroutine ice_bottom_to_ice_top
!=============================================================================================
subroutine update_ice_model_slow_dn( Atmos_boundary, Land_boundary, Ice )
type(atmos_ice_boundary_type), intent(in   ) :: Atmos_boundary
type(land_ice_boundary_type),  intent(in   ) :: Land_boundary
type(ice_data_type),           intent(inout) :: Ice

real, dimension(size(Ice%mask,1),size(Ice%mask,2)) :: frac
real :: frac_cutoff, frac_floor

!-----------------------------------------------------------------------

!----- compute average fluxes -----

   call avg_bottom_quantities ( Ice )

!
! Flux diagnostics
!
  if (id_sh   >0) sent = send_data(id_sh,    Ice%flux_t,  Ice%Time, mask=Ice%mask)
  if (id_lh   >0) sent = send_data(id_lh,    Ice%flux_lh, Ice%Time, mask=Ice%mask)
  if (id_evap >0) sent = send_data(id_evap,  Ice%flux_q,  Ice%Time, mask=Ice%mask)
  if (id_sw   >0) sent = send_data(id_sw,    Ice%flux_sw, Ice%Time, mask=Ice%mask)
  if (id_sw_vis   >0) sent = send_data(id_sw_vis,    Ice%flux_sw_vis, Ice%Time, mask=Ice%mask)
  if (id_sw_dir   >0) sent = send_data(id_sw_dir,    Ice%flux_sw_dir, Ice%Time, mask=Ice%mask)
  if (id_sw_dif   >0) sent = send_data(id_sw_dif,    Ice%flux_sw_dif, Ice%Time, mask=Ice%mask)
  if (id_sw_vis_dir   >0) sent = send_data(id_sw_vis_dir,    Ice%flux_sw_vis_dir, Ice%Time, mask=Ice%mask)
  if (id_sw_vis_dif   >0) sent = send_data(id_sw_vis_dif,    Ice%flux_sw_vis_dif, Ice%Time, mask=Ice%mask)
  if (id_sw_vis_dir   >0) sent = send_data(id_sw_nir_dir,    Ice%flux_sw_nir_dir, Ice%Time, mask=Ice%mask)
  if (id_sw_vis_dif   >0) sent = send_data(id_sw_nir_dif,    Ice%flux_sw_nir_dif, Ice%Time, mask=Ice%mask)
  if (id_lw   >0) sent = send_data(id_lw,    Ice%flux_lw, Ice%Time, mask=Ice%mask)
  if (id_snofl>0) sent = send_data(id_snofl, Ice%fprec,   Ice%Time, mask=Ice%mask)
  if (id_rain >0) sent = send_data(id_rain,  Ice%lprec,   Ice%Time, mask=Ice%mask)

  if (id_fax  >0) sent = send_data(id_fax,   Ice%flux_u,  Ice%Time, mask=Ice%mask)
  if (id_fay  >0) sent = send_data(id_fay,   Ice%flux_v,  Ice%Time, mask=Ice%mask)

!----- quantities from land model ----

  Ice%runoff  = Land_boundary%runoff
  Ice%calving = Land_boundary%calving

  if (id_runoff >0) sent = send_data(id_runoff,  Ice%runoff,  Ice%Time, mask=Ice%mask)
  if (id_calving>0) sent = send_data(id_calving, Ice%calving, Ice%Time, mask=Ice%mask)

!-----------------------------------------------------------------------
!----- modify fluxes to be used by the ocean model -----
!-----------------------------------------------------------------------

!----- where there is ice, ocean will not feel fluxes ? -----

where (Ice%ice_mask(:,:,2))
  Ice%flux_u = 0.0
  Ice%flux_v = 0.0
endwhere

!-----------------------------------------------------------------------
!---- get the specified ice field -----

      call get_amip_ice (Ice%Time, Amip, frac)


!  --- turn off sea-ice ??? ---
   if (no_ice) frac = 0.0

!  --- set constants for determining ice fraction
   if (use_leads) then
       frac_cutoff = 1.e-6 ! machine dependent value
       frac_floor = 0.0
   else
      !--- discretize (0. or 1.) ----
       frac_cutoff = 0.5
       frac_floor = 1.0
   endif

!  --- determine which grid boxes have ice coverage ---
   where ( Ice%mask(:,:) .and. frac > frac_cutoff )
!     --- ice ---
      Ice%part_size(:,:,2) = min(max(frac_floor,frac),1.0)
      Ice%part_size(:,:,1) = 1.0 - Ice%part_size(:,:,2)
      Ice%thickness(:,:,2) = specified_ice_thickness
      Ice%ice_mask (:,:,2) = .true.
   elsewhere
!     --- no ice ---
      Ice%part_size(:,:,1) = 1.0
      Ice%part_size(:,:,2) = 0.0
      Ice%thickness(:,:,2) = 0.0
      Ice%ice_mask (:,:,2) = .false.
   endwhere

end subroutine update_ice_model_slow_dn
!=============================================================================================
subroutine avg_bottom_quantities ( Ice )
type(ice_data_type), intent(inout) :: Ice
real :: divid

!----- compute average fluxes -----

if (Ice%avg_kount == 0) call error_mesg ('avg_bottom_quantities', &
                      'no ocean model fluxes have been averaged', FATAL)

divid = 1./float(Ice%avg_kount)

Ice%flux_u_bot  = Ice%flux_u_bot  * divid
Ice%flux_v_bot  = Ice%flux_v_bot  * divid
Ice%flux_t_bot  = Ice%flux_t_bot  * divid
Ice%flux_q_bot  = Ice%flux_q_bot  * divid
Ice%flux_lh_bot = Ice%flux_lh_bot * divid
Ice%flux_sw_bot = Ice%flux_sw_bot * divid
Ice%flux_sw_vis_bot = Ice%flux_sw_vis_bot * divid
Ice%flux_sw_dir_bot = Ice%flux_sw_dir_bot * divid
Ice%flux_sw_dif_bot = Ice%flux_sw_dif_bot * divid
Ice%flux_sw_vis_dir_bot = Ice%flux_sw_vis_dir_bot * divid
Ice%flux_sw_vis_dif_bot = Ice%flux_sw_vis_dif_bot * divid
Ice%flux_sw_nir_dir_bot = Ice%flux_sw_nir_dir_bot * divid
Ice%flux_sw_nir_dif_bot = Ice%flux_sw_nir_dif_bot * divid
Ice%flux_lw_bot = Ice%flux_lw_bot * divid
Ice%lprec_bot   = Ice%lprec_bot   * divid
Ice%fprec_bot   = Ice%fprec_bot   * divid

Ice%flux_t  = all_avg( Ice%flux_t_bot , Ice%part_size )
Ice%flux_q  = all_avg( Ice%flux_q_bot , Ice%part_size )
Ice%flux_lh = all_avg( Ice%flux_lh_bot, Ice%part_size )
Ice%flux_sw = all_avg( Ice%flux_sw_bot, Ice%part_size )
Ice%flux_sw_vis = all_avg( Ice%flux_sw_vis_bot, Ice%part_size )
Ice%flux_sw_dir = all_avg( Ice%flux_sw_dir_bot, Ice%part_size )
Ice%flux_sw_dif = all_avg( Ice%flux_sw_dif_bot, Ice%part_size )
Ice%flux_sw_vis_dir = all_avg( Ice%flux_sw_vis_dir_bot, Ice%part_size )
Ice%flux_sw_vis_dif = all_avg( Ice%flux_sw_vis_dif_bot, Ice%part_size )
Ice%flux_sw_nir_dir = all_avg( Ice%flux_sw_nir_dir_bot, Ice%part_size )
Ice%flux_sw_nir_dif = all_avg( Ice%flux_sw_nir_dif_bot, Ice%part_size )
Ice%flux_lw = all_avg( Ice%flux_lw_bot, Ice%part_size )
Ice%fprec   = all_avg( Ice%fprec_bot  , Ice%part_size )
Ice%lprec   = all_avg( Ice%lprec_bot  , Ice%part_size )

Ice%flux_u  = all_avg( Ice%flux_u_bot , Ice%part_size )
Ice%flux_v  = all_avg( Ice%flux_v_bot , Ice%part_size )

!--- set count to zero and fluxes will be zeroed before the next sum

Ice%avg_kount = 0

end subroutine avg_bottom_quantities
!=============================================================================================
function all_avg(x,part)
real, dimension(:,:,:) :: x, part
real, dimension(size(x,1), size(x,2)) :: all_avg
integer :: k

if(any(shape(x) /= shape(part))) then
  call error_mesg('all_avg','input arguments "x" and "part" are not dimensioned the same',FATAL)
endif

all_avg = 0.
do k=1,size(x,3)
  all_avg = all_avg + part(:,:,k)*x(:,:,k)
enddo

return
end function all_avg
!=============================================================================================
subroutine ice_model_end(Ice)
type(ice_data_type), intent(inout) :: Ice
character(len=64) :: fname='RESTART/ice_model.res.nc'
integer :: unit, k
character(len=64) :: lvltag

if(.not.module_is_initialized) return
if( do_netcdf_restart) then
   if(mpp_pe() == mpp_root_pe() ) then
      call error_mesg ('ice_model_mod', 'Writing NetCDF formatted restart file: RESTART/ice_model.res.nc', NOTE)
   endif
   call save_restart(Ice_restart)
else

   if(mpp_pe() == mpp_root_pe() ) then
      call error_mesg ('ice_model_mod', 'Writing native formatted restart file.', NOTE)
   endif
  unit = open_restart_file ('RESTART/ice_model.res', 'write')
  if ( mpp_pe() == mpp_root_pe() ) then
    write (unit) restart_format
    write (unit) size(Ice%gmask,1), size(Ice%gmask,2), num_part
  endif

  call set_domain (Ice%Domain)
  call write_data ( unit, Ice%part_size  )
  call write_data ( unit, Ice%temp       )
  call write_data ( unit, Ice%thickness  )
  call write_data ( unit, Ice%albedo     )
! code to output the new albedos
  call write_data ( unit, Ice%albedo_vis_dir )
  call write_data ( unit, Ice%albedo_nir_dir )
  call write_data ( unit, Ice%albedo_vis_dif )
  call write_data ( unit, Ice%albedo_nir_dif )

  call write_data ( unit, Ice%rough_mom  )
  call write_data ( unit, Ice%rough_heat )
  call write_data ( unit, Ice%rough_moist)
  call write_data ( unit, Ice%u_surf     )
  call write_data ( unit, Ice%v_surf     )
  call write_data ( unit, Ice%frazil     )
  call write_data ( unit, Ice%flux_u_bot )
  call write_data ( unit, Ice%flux_v_bot )
  call close_file ( unit )
endif

deallocate(cell_area)
call amip_interp_del(Amip)

module_is_initialized = .false.

end subroutine ice_model_end

 !#######################################################################
  ! <SUBROUTINE NAME="ice_model_restart">
  ! <DESCRIPTION>
  !  dummy routine
  ! </DESCRIPTION>
  subroutine ice_model_restart(time_stamp)
    character(len=*),         intent(in), optional :: time_stamp

    call error_mesg ('ice_model_restart in ice_model_mod', &
                     'intermediate restart capability is not implemented for this model', FATAL)    


  end subroutine ice_model_restart
  ! </SUBROUTINE>

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

subroutine ice_diag_init (Ice, xb, yb)
type(ice_data_type), intent(in) :: Ice
real   , intent(in) :: xb(:), yb(:)

integer :: nlon, nlat
integer :: id_xv, id_yv, id_xb, id_xt, id_yb, id_yt, axv(2), axt(2)
real, parameter :: missing = -1e34

  nlon = size(xb(:))-1
  nlat = size(yb(:))-1

! define axes

 !id_xv = diag_axis_init('xv', xb(2:nlon+1), 'degrees_E', 'X','longitude', &
 !                                 set_name='ice', Domain2=Ice%Domain )
 !id_yv = diag_axis_init('yv', yb(2:nlat+1), 'degrees_N', 'Y','latitude',  &
 !                                 set_name='ice', Domain2=Ice%Domain )
 !axv = (/ id_xv, id_yv /)

  id_xb = diag_axis_init(trim(axisname_xb), xb, 'degrees_E', 'X', 'longitude', &
                                    set_name='ice', Domain2=Ice%Domain )
  id_xt = diag_axis_init(trim(axisname_x), (xb(1:nlon)+xb(2:nlon+1))/2, 'degrees_E', 'X', &
                     'longitude',set_name='ice',edges=id_xb,Domain2=Ice%Domain)
  id_yb = diag_axis_init(trim(axisname_yb), yb, 'degrees_N', 'Y', 'latitude', &
                                   set_name='ice', Domain2=Ice%Domain )
  id_yt = diag_axis_init(trim(axisname_y), (yb(1:nlat)+yb(2:nlat+1))/2, 'degrees_N', 'Y', &
                     'latitude',set_name='ice', edges=id_yb,Domain2=Ice%Domain)
  axt  = (/ id_xt, id_yt /)

! register fields

  id_sh = register_diag_field('ice_model','SH' ,axt, Ice%Time, &
                              'sensible heat flux', 'W/m^2', &
                              missing_value=missing)
  id_lh = register_diag_field('ice_model','LH' ,axt, Ice%Time, &
                             'latent heat flux', 'W/m^2', missing_value=missing)
  id_sw = register_diag_field('ice_model','SW' ,axt, Ice%Time, &
                              'short wave heat flux', 'W/m^2',  &
                              missing_value=missing)
  id_sw_vis = register_diag_field('ice_model','SWvis' ,axt, Ice%Time, &
                              'visible short wave heat flux', 'W/m^2', &
                              missing_value=missing)
  id_sw_dir = register_diag_field('ice_model','SWdir' ,axt, Ice%Time, &
                              'direct short wave heat flux', 'W/m^2',  &
                              missing_value=missing)
  id_sw_dif = register_diag_field('ice_model','SWdif' ,axt, Ice%Time, &
                              'diffuse short wave heat flux', 'W/m^2', &
                              missing_value=missing)
  id_sw_vis_dir = register_diag_field('ice_model','SWvisdir' ,axt, Ice%Time, &
                              'vis dir short wave heat flux', 'W/m^2', &
                              missing_value=missing)
  id_sw_vis_dif = register_diag_field('ice_model','SWvisdif' ,axt, Ice%Time, &
                              'vis diff short wave heat flux', 'W/m^2',  &
                              missing_value=missing)
  id_sw_nir_dir = register_diag_field('ice_model','SWnirdir' ,axt, Ice%Time, &
                              'NIR dir short wave heat flux', 'W/m^2', &
                              missing_value=missing)
  id_sw_nir_dif = register_diag_field('ice_model','SWnirdif' ,axt, Ice%Time, &
                              'NIR diff short wave heat flux', 'W/m^2',  &
                              missing_value=missing)
  id_lw = register_diag_field('ice_model','LW' ,axt, Ice%Time, &
                              'long wave heat flux over ice', 'W/m^2', &
                              missing_value=missing)
  id_snofl = register_diag_field('ice_model','SNOWFL' ,axt, Ice%Time, &
                                 'rate of snow fall', 'kg/(m^2*s)', &
                                 missing_value=missing)
  id_rain  = register_diag_field('ice_model','RAIN' ,axt, Ice%Time, &
                                 'rate of rain fall', 'kg/(m^2*s)', &
                                 missing_value=missing)
  id_runoff= register_diag_field('ice_model','RUNOFF' ,axt, Ice%Time, &
                                 'liquid runoff', 'kg/(m^2*s)', &
                                 missing_value=missing)
  id_calving = register_diag_field('ice_model','CALVING',axt, Ice%Time, &
                                 'frozen runoff', 'kg/(m^2*s)', &
                                 missing_value=missing)
  id_evap = register_diag_field('ice_model','EVAP',axt, Ice%Time, &
                                 'evaporation', 'kg/(m^2*s)', &
                                 missing_value=missing)
! wind stress at t points
  id_fax = register_diag_field('ice_model', 'FA_X', axt, Ice%Time, &
                               'air stress on ice - x component', 'Pa', &
                               missing_value=missing)
  id_fay = register_diag_field('ice_model', 'FA_Y', axt, Ice%Time, &
                               'air stress on ice - y component', 'Pa', &
                               missing_value=missing)

end subroutine ice_diag_init

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

 subroutine ice_register_restart (Ice, restart_file)
 type(ice_data_type), intent(inout) :: Ice
 character(len=*), intent(in) :: restart_file
 integer                      :: id_restart

  !id_restart = register_restart_field (Ice_restart, restart_file, 'mlon',      mlon)
  !id_restart = register_restart_field (Ice_restart, restart_file, 'mlon',      mlat)
  !id_restart = register_restart_field (Ice_restart, restart_file, 'num_part',  num_part)
   id_restart = register_restart_field (Ice_restart, restart_file, 'part_size', Ice%part_size, domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'thickness', Ice%thickness, domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'albedo',    Ice%albedo,    domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'temp_1',    Ice%temp(:,:,:,1), domain=Ice%domain)

   ! albedo streams
   id_restart_albedo = register_restart_field (Ice_restart, restart_file, 'albedo_vis_dir', Ice%albedo_vis_dir, &
                                                 domain=Ice%domain, mandatory=.false.)
   id_restart        = register_restart_field (Ice_restart, restart_file, 'albedo_nir_dir', Ice%albedo_nir_dir, &
                                                 domain=Ice%domain, mandatory=.false.)
   id_restart        = register_restart_field (Ice_restart, restart_file, 'albedo_vis_dif', Ice%albedo_vis_dif, &
                                                 domain=Ice%domain, mandatory=.false.)
   id_restart        = register_restart_field (Ice_restart, restart_file, 'albedo_nir_dif', Ice%albedo_nir_dif, &
                                                 domain=Ice%domain, mandatory=.false.)

   id_restart = register_restart_field (Ice_restart, restart_file, 'rough_mom',   Ice%rough_mom,   domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'rough_heat',  Ice%rough_heat,  domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'rough_moist', Ice%rough_moist, domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'u_surf',      Ice%u_surf,      domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'v_surf',      Ice%v_surf,      domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'frazil',      Ice%frazil,      domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'flux_u_bot',  Ice%flux_u_bot,  domain=Ice%domain)
   id_restart = register_restart_field (Ice_restart, restart_file, 'flux_v_bot',  Ice%flux_v_bot,  domain=Ice%domain)

 end subroutine ice_register_restart

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

! dummy routine
 subroutine ice_stock_pe(Ice, index, value)
 type(ice_data_type), intent(in) :: Ice
 integer, intent(in) :: index
 real, intent(out)   :: value

 value = 0.0
 if(.not.Ice%pe) return

 if(.not.stock_warning_issued) then
   call error_mesg('ice_stock_pe','Stocks not yet implemented. Returning zero.',NOTE)
   stock_warning_issued = .true.
 endif

 end subroutine ice_stock_pe
!=============================================================================================

subroutine ice_data_type_chksum(id, timestep, data_type)
  use fms_mod,                 only: stdout
  use mpp_mod,                 only: mpp_chksum

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(ice_data_type), intent(in) :: data_type
    integer ::   n, m, outunit
    
    outunit = stdout()

100 FORMAT("CHECKSUM::",A32," = ",Z20)
    write(outunit,*) 'BEGIN CHECKSUM(ice_data_type):: ', id, timestep
    write(outunit,100) 'ice_data_type%part_size          ',mpp_chksum(data_type%part_size          )
    write(outunit,100) 'ice_data_type%t_surf             ',mpp_chksum(data_type%t_surf             )
    write(outunit,100) 'ice_data_type%albedo             ',mpp_chksum(data_type%albedo             )
    write(outunit,100) 'ice_data_type%albedo_vis_dir     ',mpp_chksum(data_type%albedo_vis_dir     )
    write(outunit,100) 'ice_data_type%albedo_nir_dir     ',mpp_chksum(data_type%albedo_nir_dir     )
    write(outunit,100) 'ice_data_type%albedo_vis_dif     ',mpp_chksum(data_type%albedo_vis_dif     )
    write(outunit,100) 'ice_data_type%albedo_nir_dif     ',mpp_chksum(data_type%albedo_nir_dif     )
    write(outunit,100) 'ice_data_type%rough_mom          ',mpp_chksum(data_type%rough_mom          )
    write(outunit,100) 'ice_data_type%rough_heat         ',mpp_chksum(data_type%rough_heat         )
    write(outunit,100) 'ice_data_type%rough_moist        ',mpp_chksum(data_type%rough_moist        )
    write(outunit,100) 'ice_data_type%frazil             ',mpp_chksum(data_type%frazil             )
    write(outunit,100) 'ice_data_type%u_surf             ',mpp_chksum(data_type%u_surf             )
    write(outunit,100) 'ice_data_type%v_surf             ',mpp_chksum(data_type%v_surf             )
    write(outunit,100) 'ice_data_type%flux_u_bot         ',mpp_chksum(data_type%flux_u_bot         )
    write(outunit,100) 'ice_data_type%flux_v_bot         ',mpp_chksum(data_type%flux_v_bot         )
    write(outunit,100) 'ice_data_type%flux_t_bot         ',mpp_chksum(data_type%flux_t_bot         )
    write(outunit,100) 'ice_data_type%flux_q_bot         ',mpp_chksum(data_type%flux_q_bot         )
    write(outunit,100) 'ice_data_type%flux_lh_bot        ',mpp_chksum(data_type%flux_lh_bot        )
    write(outunit,100) 'ice_data_type%flux_sw_bot        ',mpp_chksum(data_type%flux_sw_bot        )
    write(outunit,100) 'ice_data_type%flux_sw_vis_bot    ',mpp_chksum(data_type%flux_sw_vis_bot    )
    write(outunit,100) 'ice_data_type%flux_sw_dir_bot    ',mpp_chksum(data_type%flux_sw_dir_bot    )
    write(outunit,100) 'ice_data_type%flux_sw_dif_bot    ',mpp_chksum(data_type%flux_sw_dif_bot    )
    write(outunit,100) 'ice_data_type%flux_sw_vis_dir_bot',mpp_chksum(data_type%flux_sw_vis_dir_bot)
    write(outunit,100) 'ice_data_type%flux_sw_vis_dif_bot',mpp_chksum(data_type%flux_sw_vis_dif_bot)
    write(outunit,100) 'ice_data_type%flux_sw_nir_dir_bot',mpp_chksum(data_type%flux_sw_nir_dir_bot)
    write(outunit,100) 'ice_data_type%flux_sw_nir_dif_bot',mpp_chksum(data_type%flux_sw_nir_dif_bot)
    write(outunit,100) 'ice_data_type%flux_lw_bot        ',mpp_chksum(data_type%flux_lw_bot        )
    write(outunit,100) 'ice_data_type%lprec_bot          ',mpp_chksum(data_type%lprec_bot          )
    write(outunit,100) 'ice_data_type%fprec_bot          ',mpp_chksum(data_type%fprec_bot          )
    write(outunit,100) 'ice_data_type%runoff_bot         ',mpp_chksum(data_type%runoff_bot         )

    write(outunit,100) 'ice_data_type%flux_u             ',mpp_chksum(data_type%flux_u             )
    write(outunit,100) 'ice_data_type%flux_v             ',mpp_chksum(data_type%flux_v             )
    write(outunit,100) 'ice_data_type%flux_t             ',mpp_chksum(data_type%flux_t             )
    write(outunit,100) 'ice_data_type%flux_q             ',mpp_chksum(data_type%flux_q             )
    write(outunit,100) 'ice_data_type%flux_lh            ',mpp_chksum(data_type%flux_lh            )
    write(outunit,100) 'ice_data_type%flux_sw            ',mpp_chksum(data_type%flux_sw            )
    write(outunit,100) 'ice_data_type%flux_sw_vis        ',mpp_chksum(data_type%flux_sw_vis        )
    write(outunit,100) 'ice_data_type%flux_sw_dir        ',mpp_chksum(data_type%flux_sw_dir        )
    write(outunit,100) 'ice_data_type%flux_sw_dif        ',mpp_chksum(data_type%flux_sw_dif        )
    write(outunit,100) 'ice_data_type%flux_sw_vis_dir    ',mpp_chksum(data_type%flux_sw_vis_dir    )
    write(outunit,100) 'ice_data_type%flux_sw_vis_dif    ',mpp_chksum(data_type%flux_sw_vis_dif    )
    write(outunit,100) 'ice_data_type%flux_sw_nir_dir    ',mpp_chksum(data_type%flux_sw_nir_dir    )
    write(outunit,100) 'ice_data_type%flux_sw_nir_dif    ',mpp_chksum(data_type%flux_sw_nir_dif    )
    write(outunit,100) 'ice_data_type%flux_lw            ',mpp_chksum(data_type%flux_lw            )
    write(outunit,100) 'ice_data_type%lprec              ',mpp_chksum(data_type%lprec              )
    write(outunit,100) 'ice_data_type%fprec              ',mpp_chksum(data_type%fprec              )
    write(outunit,100) 'ice_data_type%p_surf             ',mpp_chksum(data_type%p_surf             )
    write(outunit,100) 'ice_data_type%runoff             ',mpp_chksum(data_type%runoff             )
    write(outunit,100) 'ice_data_type%calving            ',mpp_chksum(data_type%calving            )
    write(outunit,100) 'ice_data_type%flux_salt          ',mpp_chksum(data_type%flux_salt          )

    do n = 1, data_type%ocean_fields%num_bcs  !{
       do m = 1, data_type%ocean_fields%bc(n)%num_fields  !{
          !write(outunit,101) 'ice%', m, n, mpp_chksum(Ice%ocean_fields%bc(n)%field(m)%values)
          write(outunit,101) 'ice%',trim(data_type%ocean_fields%bc(n)%name), &
               trim(data_type%ocean_fields%bc(n)%field(m)%name), &
               mpp_chksum(data_type%ocean_fields%bc(n)%field(m)%values)
       enddo  !} m
    enddo  !} n
101 FORMAT("CHECKSUM::",A16,a,'%',a," = ",Z20)

end subroutine ice_data_type_chksum


subroutine ocn_ice_bnd_type_chksum(id, timestep, bnd_type)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(ocean_ice_boundary_type), intent(in) :: bnd_type
    integer ::   n, m, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(ocean_ice_boundary_type):: ', id, timestep
    write(outunit,100) 'ocn_ice_bnd_type%u        ',mpp_chksum(bnd_type%u        )
    write(outunit,100) 'ocn_ice_bnd_type%v        ',mpp_chksum(bnd_type%v        )
    write(outunit,100) 'ocn_ice_bnd_type%t        ',mpp_chksum(bnd_type%t        )
    write(outunit,100) 'ocn_ice_bnd_type%s        ',mpp_chksum(bnd_type%s        )
    write(outunit,100) 'ocn_ice_bnd_type%frazil   ',mpp_chksum(bnd_type%frazil   )
    write(outunit,100) 'ocn_ice_bnd_type%sea_level',mpp_chksum(bnd_type%sea_level)
!    write(outunit,100) 'ocn_ice_bnd_type%data     ',mpp_chksum(bnd_type%data     )
100 FORMAT("CHECKSUM::",A32," = ",Z20)

    do n = 1, bnd_type%fields%num_bcs  !{
       do m = 1, bnd_type%fields%bc(n)%num_fields  !{
          write(outunit,101) 'oibt%',trim(bnd_type%fields%bc(n)%name), &
               trim(bnd_type%fields%bc(n)%field(m)%name), &
               mpp_chksum(bnd_type%fields%bc(n)%field(m)%values)
       enddo  !} m
    enddo  !} n
101 FORMAT("CHECKSUM::",A16,a,'%',a," = ",Z20)

end subroutine ocn_ice_bnd_type_chksum

subroutine atm_ice_bnd_type_chksum(id, timestep, bnd_type)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(atmos_ice_boundary_type), intent(in) :: bnd_type
    integer ::   n, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(atmos_ice_boundary_type):: ', id, timestep
    write(outunit,100) 'atm_ice_bnd_type%u_flux          ',mpp_chksum(bnd_type%u_flux)          
    write(outunit,100) 'atm_ice_bnd_type%v_flux          ',mpp_chksum(bnd_type%v_flux)
    write(outunit,100) 'atm_ice_bnd_type%u_star          ',mpp_chksum(bnd_type%u_star)
    write(outunit,100) 'atm_ice_bnd_type%t_flux          ',mpp_chksum(bnd_type%t_flux)
    write(outunit,100) 'atm_ice_bnd_type%q_flux          ',mpp_chksum(bnd_type%q_flux)
    write(outunit,100) 'atm_ice_bnd_type%lw_flux         ',mpp_chksum(bnd_type%lw_flux)
    write(outunit,100) 'atm_ice_bnd_type%sw_flux_vis_dir ',mpp_chksum(bnd_type%sw_flux_vis_dir)
    write(outunit,100) 'atm_ice_bnd_type%sw_flux_vis_dif ',mpp_chksum(bnd_type%sw_flux_vis_dif)
    write(outunit,100) 'atm_ice_bnd_type%sw_flux_nir_dir ',mpp_chksum(bnd_type%sw_flux_nir_dir)
    write(outunit,100) 'atm_ice_bnd_type%sw_flux_nir_dif ',mpp_chksum(bnd_type%sw_flux_nir_dif)
    write(outunit,100) 'atm_ice_bnd_type%lprec           ',mpp_chksum(bnd_type%lprec)
    write(outunit,100) 'atm_ice_bnd_type%fprec           ',mpp_chksum(bnd_type%fprec)
    write(outunit,100) 'atm_ice_bnd_type%dhdt            ',mpp_chksum(bnd_type%dhdt)
    write(outunit,100) 'atm_ice_bnd_type%dedt            ',mpp_chksum(bnd_type%dedt)
    write(outunit,100) 'atm_ice_bnd_type%drdt            ',mpp_chksum(bnd_type%drdt)
    write(outunit,100) 'atm_ice_bnd_type%coszen          ',mpp_chksum(bnd_type%coszen)
    write(outunit,100) 'atm_ice_bnd_type%p               ',mpp_chksum(bnd_type%p)
!    write(outunit,100) 'atm_ice_bnd_type%data            ',mpp_chksum(bnd_type%data)
100 FORMAT("CHECKSUM::",A32," = ",Z20)
end subroutine atm_ice_bnd_type_chksum

subroutine lnd_ice_bnd_type_chksum(id, timestep, bnd_type)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(land_ice_boundary_type), intent(in) :: bnd_type
    integer ::   n, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(land_ice_boundary_type):: ', id, timestep
    write(outunit,100) 'lnd_ice_bnd_type%runoff  ',mpp_chksum(bnd_type%runoff)
    write(outunit,100) 'lnd_ice_bnd_type%calving ',mpp_chksum(bnd_type%calving)
!    write(outunit,100) 'lnd_ice_bnd_type%data    ',mpp_chksum(bnd_type%data)
100 FORMAT("CHECKSUM::",A32," = ",Z20)
end subroutine lnd_ice_bnd_type_chksum


end module ice_model_mod



module ice_albedo_mod

!=======================================================================
!
!                     ICE SURFACE ALBEDO MODULE
!
!   Routines for computing the surface albedo over ice 
!
!=======================================================================

#ifdef INTERNAL_FILE_NML
use          mpp_mod, only: input_nml_file
#else
use          fms_mod, only: open_namelist_file
#endif

use            fms_mod, only:  error_mesg, file_exist,  &
                               check_nml_error,  &
                               FATAL, close_file, mpp_pe, mpp_root_pe, &
                               write_version_number, stdlog

implicit none
private

!======= public interface =============================================

public  ice_albedo, ice_albedo_init

!--------------------- version number ----------------------------------

character(len=128) :: version = '$Id: ice_albedo.F90,v 17.0.6.1 2010/09/14 19:28:35 pjp Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

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

!     DEFAULT VALUES OF NAMELIST PARAMETERS:

real :: crit_thickness       = 1.00   
real :: t_range              = 10.0

real :: min_ice_alb          = 0.50
real :: max_ice_alb          = 0.80

real :: const_alb            = 0.65


namelist /ice_albedo_nml/  crit_thickness      , &
                           t_range             , &
                           min_ice_alb         , &
                           max_ice_alb         , &
                           const_alb

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

!  OTHER MODULE VARIABLES

real :: temp_ice_freeze

logical :: do_init = .true.

CONTAINS

!#######################################################################

subroutine ice_albedo_init ( t_freeze )

real, intent(in) :: t_freeze

integer  unit, io, ierr

temp_ice_freeze = t_freeze

!------------------- read namelist input -------------------------------

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, nml=ice_albedo_nml, iostat=io)
      ierr = check_nml_error(io, 'ice_albedo_nml')
#else
      if (file_exist('input.nml')) then
         unit = open_namelist_file ('input.nml')
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=ice_albedo_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'ice_albedo_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           unit = stdlog()
           write (unit, nml=ice_albedo_nml)
      endif

  do_init = .false.

end subroutine ice_albedo_init

!#######################################################################

subroutine ice_albedo (ice, thickness, temp, albedo, i1, j1)

!-----------------------------------------------------------------------
!----------- CALCULATE SURFACE ALBEDO OVER ICE ------------------------
!-----------------------------------------------------------------------
!
! INPUT
!     (i1,j1)    = postition in global ice grid of first elements in
!                       the input
!     thickness  = thickness of ice (in meters)
!     alb_ocean  - albedo of open ocean (on ice grid)
!     temp       = surface temperature (in degrees kelvin)
!
!  OUTPUT
!     albedo = surface albedo

logical, intent(in),    dimension(:,:,:) :: ice
real,    intent(in),    dimension(:,:,:) :: temp, thickness
real,    intent(inout), dimension(:,:,:) :: albedo
integer, intent(in), optional :: i1, j1

!-----------------------------------------------------------------------

integer :: is, js, ie, je, n
real :: tcrit
real, dimension(size(temp,1),size(temp,2)) :: thick_ice_alb, alb_ocean

if (do_init) call error_mesg ('ice_albedo',  &
                              'initialization not called', FATAL)

is = 1; if (present(i1)) is = i1
js = 1; if (present(j1)) js = j1

ie = is + size(temp,1) - 1
je = js + size(temp,2) - 1

tcrit = temp_ice_freeze - t_range

!--- first partition assumed to be open ocean ----

 alb_ocean = albedo(:,:,1)

 do n = 2, size(temp,3)

  where(ice(:,:,n) .and. temp(:,:,n) <= tcrit) &
             thick_ice_alb = max_ice_alb
  where(ice(:,:,n) .and. temp(:,:,n) >= temp_ice_freeze) &
             thick_ice_alb = min_ice_alb
  where(ice(:,:,n) .and. temp(:,:,n) <  temp_ice_freeze &
                               .and. temp(:,:,n) > tcrit)  &
     thick_ice_alb = max_ice_alb +  &
           (min_ice_alb - max_ice_alb)*(temp(:,:,n) - tcrit)/t_range


  where (ice(:,:,n).and.thickness(:,:,n) >= crit_thickness)  &
        albedo(:,:,n) = thick_ice_alb
  where (ice(:,:,n).and.thickness(:,:,n) < crit_thickness) &
        albedo(:,:,n) =  alb_ocean + &
      (thick_ice_alb - alb_ocean) *sqrt(thickness(:,:,n)/crit_thickness)

end do

end subroutine ice_albedo

!######################################################################

end module ice_albedo_mod




module ocean_albedo_mod

!=======================================================================
!
!                ocean surface albedo module
!
!   routine for computing the surface albedo over the open ocean
!
!=======================================================================

#ifdef INTERNAL_FILE_NML
use          mpp_mod, only: input_nml_file
#else
use          fms_mod, only: open_namelist_file
#endif

use        fms_mod, only: close_file, &
                          error_mesg, file_exist, check_nml_error, FATAL, &
                          mpp_pe, mpp_root_pe, &
                          write_version_number, stdlog

implicit none
private

public  compute_ocean_albedo, compute_ocean_albedo_new

!-----------------------------------------------------------------------
character(len=256) :: version = '$Id: ocean_albedo.F90,v 17.0.6.1 2010/09/14 19:28:55 pjp Exp $'
character(len=256) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

real    :: const_alb           = 0.10
integer :: ocean_albedo_option = 1

namelist /ocean_albedo_nml/  ocean_albedo_option, &
                             const_alb

! ocean_albedo_option = 1 : used by GFDL Experimental Prediction Group
!                           in 80s and 90s; source not currently documented
!                           (tabulated dependence on zenith angle)
!
! ocean_albedo_option = 2 : used by GFDL Climate Dynamics Group in 80s and 90s
!                           source not currently documented
!                           (tabulated dependence on latitude)
!
! ocean_albedo_option = 3 : simple analytic dependence on zenith angle
!                           used by J. E. Taylor, et. al., 
!                           QJRMS, 1996, Vol. 122, 839-861
!                           albedo = 0.037/[1.1*(cos(Z)**1.4) + 0.15]
!
! ocean_albedo_option = 4 : constant uniform albedo 
!                           set by namelist variable const_alb
!
! ocean_albedo_option = 5 : separate treatment of dif/dir shortwave using
!                           NCAR CCMS3.0 scheme (Briegleb et al, 1986,
!                           J. Clim. and Appl. Met., v. 27, 214-226)

  interface compute_ocean_albedo
     module procedure compute_ocean_albedo_old ! obsolete - remove later
     module procedure compute_ocean_albedo_new
  end interface

!    ocean surface albedo data

!    data used for option 1

         real, dimension(21,20) :: albedo_data
         real, dimension(21)    :: trn
         real, dimension(20)    :: za
         real, dimension(19)    :: dza
         real :: rad2deg
      logical :: first = .true.

!    data used for option 2

         real, dimension(19) :: albedo_mcm
         real, allocatable, dimension(:,:) :: alb2

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


      data  albedo_data (1:21,1:7)                                     &
             / .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
     .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
     .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
     .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
     .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
     .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
     .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
     .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
     .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
     .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
     .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
     .246,.235,.222,.211,.205,.200 /

      data  albedo_data (1:21,8:14)                                    &
             / .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
     .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
     .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
     .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
     .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
     .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
     .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
     .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
     .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
     .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
     .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
     .058,.055,.054,.053,.052,.052 /

      data  albedo_data (1:21,15:20)                                   &
             / .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
     .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
     .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
     .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
     .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
     .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
     .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
     .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
     .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
     .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025 /

      data  trn (1:21)                                             &
             /.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60, &
              .65,.70,.75,.80,.85,.90,.95,1.00/

      data  za (1:20)                                               &
             / 90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58., &
               54.,50.,40.,30.,20.,10., 0. /

      data  dza (1:19) /8*2.0,6*4.0,5*10.0/

      data albedo_mcm (1:19)                                              &
         / 0.206, 0.161, 0.110, 0.097, 0.089, 0.076, 0.068, 0.063,        &
         3*0.060,  0.063, 0.068, 0.076, 0.089, 0.097, 0.110, 0.161, 0.206 / 

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

contains

!#######################################################################

   subroutine compute_ocean_albedo_old (ocean, coszen, albedo, lat)

!-----------------------------------------------------------------------
! input
!     ocean  = logical flag; = true if ocean point
!     coszen = cosine of zenith angle (in radians)
!     lat    = latitude (radians)
!
!  output
!     albedo = surface albedo
!-----------------------------------------------------------------------
      logical, intent(in)  ::  ocean(:,:)
      real,    intent(in)  :: coszen(:,:)
      real,    intent(out) :: albedo(:,:)
      real,    intent(in), optional :: lat(:,:)
!-----------------------------------------------------------------------

   real, dimension(size(ocean,1),size(ocean,2)) :: trans, zen,  &
                                                   dz, dt, dzdt
integer, dimension(size(ocean,1),size(ocean,2)) :: i1, j1

   real, dimension(size(ocean,1),size(ocean,2)) :: cos14

      integer :: i, j

!-----------------------------------------------------------------------
!------------ calculate surface albedo over open water -----------------
!-----------------------------------------------------------------------

   if (first) call ocean_albedo_init(ocean,lat)

if(ocean_albedo_option == 1) then

   trans = 0.537

   where (ocean)
      zen = acos(coszen) * rad2deg
   elsewhere
      zen = 0.0
   endwhere

!---- set up interpolation indices ----

   where (ocean) i1 = 20.*trans + 1.

   where (ocean .and. zen >= 74.) j1 = 0.50*(90.-zen) + 1.
   where (ocean .and. zen <  50.) j1 = 0.10*(50.-zen) + 15.

   where (ocean .and. zen <  74.  &
                .and. zen >= 50.) j1 = 0.25*(74.-zen) + 9.


!---- set albedo to zero at non-sea points ? ----

   where (.not.ocean) albedo = 0.0
   
!---- do interpolation -----

   do j = 1, size(ocean,2)
   do i = 1, size(ocean,1)

      if (ocean(i,j)) then
          dz(i,j)   = -(zen(i,j)-za(j1(i,j)))/dza(j1(i,j))
          dt(i,j)   = 20.*(trans(i,j)-trn(i1(i,j)))
          dzdt(i,j) = dz(i,j) * dt(i,j)

          albedo(i,j) = albedo_data(i1(i,j)  ,j1(i,j)  ) *            &
                                       (1.-dz(i,j)-dt(i,j)+dzdt(i,j)) &
                      + albedo_data(i1(i,j)+1,j1(i,j)  ) *            &
                                       (dt(i,j)-dzdt(i,j))            &
                      + albedo_data(i1(i,j)  ,j1(i,j)+1) *            &
                                       (dz(i,j)-dzdt(i,j))            &
                      + albedo_data(i1(i,j)+1,j1(i,j)+1) *  dzdt(i,j)
       endif

   enddo
   enddo

endif

if(ocean_albedo_option == 2) then
  albedo = alb2
endif

if(ocean_albedo_option == 3) then

   where(coszen .ne. 0.0) 
      cos14 = coszen**1.4
   elsewhere
      cos14 = 0.0
   endwhere

   where(ocean)
      albedo = 0.037/(1.1*cos14 + 0.15)
   endwhere

endif

if(ocean_albedo_option == 4) albedo = const_alb

if (ocean_albedo_option == 5) then
   call error_mesg ('ocean_albedo', &
          'ocean_albedo_option=5 requires new compute_ocean_albedo interface', &
          FATAL)
endif

where (.not.ocean) albedo = 0.0
   
!-----------------------------------------------------------------------

   end subroutine compute_ocean_albedo_old

!#######################################################################
   subroutine compute_ocean_albedo_new (ocean, coszen, albedo_vis_dir, &
                albedo_vis_dif, albedo_nir_dir, albedo_nir_dif, lat)

!-----------------------------------------------------------------------
! input
!     ocean  = logical flag; = true if ocean point
!     coszen = cosine of zenith angle (in radians)
!     lat    = latitude (radians)
!
!  output
!     albedo = surface albedo
!-----------------------------------------------------------------------
      logical, intent(in)  ::  ocean(:,:)
      real,    intent(in)  :: coszen(:,:)
      real,    intent(out) :: albedo_vis_dir(:,:)
      real,    intent(out) :: albedo_vis_dif(:,:)
      real,    intent(out) :: albedo_nir_dir(:,:)
      real,    intent(out) :: albedo_nir_dif(:,:)
      real,    intent(in), optional :: lat(:,:)
!-----------------------------------------------------------------------

   real, dimension(size(ocean,1),size(ocean,2)) :: trans, zen,  &
                                                   dz, dt, dzdt
integer, dimension(size(ocean,1),size(ocean,2)) :: i1, j1

   real, dimension(size(ocean,1),size(ocean,2)) :: cos14

      integer :: i, j

!-----------------------------------------------------------------------
!------------ calculate surface albedo over open water -----------------
!-----------------------------------------------------------------------

   if (first) call ocean_albedo_init(ocean,lat)

if(ocean_albedo_option == 1) then

   trans = 0.537

   where (ocean)
      zen = acos(coszen) * rad2deg
   elsewhere
      zen = 0.0
   endwhere

!---- set up interpolation indices ----

   where (ocean) i1 = 20.*trans + 1.

   where (ocean .and. zen >= 74.) j1 = 0.50*(90.-zen) + 1.
   where (ocean .and. zen <  50.) j1 = 0.10*(50.-zen) + 15.

   where (ocean .and. zen <  74.  &
                .and. zen >= 50.) j1 = 0.25*(74.-zen) + 9.


!---- do interpolation -----

   do j = 1, size(ocean,2)
   do i = 1, size(ocean,1)

      if (ocean(i,j)) then
          dz(i,j)   = -(zen(i,j)-za(j1(i,j)))/dza(j1(i,j))
          dt(i,j)   = 20.*(trans(i,j)-trn(i1(i,j)))
          dzdt(i,j) = dz(i,j) * dt(i,j)

          albedo_vis_dir(i,j) = albedo_data(i1(i,j)  ,j1(i,j)  ) *    &
                                       (1.-dz(i,j)-dt(i,j)+dzdt(i,j)) &
                      + albedo_data(i1(i,j)+1,j1(i,j)  ) *            &
                                       (dt(i,j)-dzdt(i,j))            &
                      + albedo_data(i1(i,j)  ,j1(i,j)+1) *            &
                                       (dz(i,j)-dzdt(i,j))            &
                      + albedo_data(i1(i,j)+1,j1(i,j)+1) *  dzdt(i,j)
       else
          albedo_vis_dir(i,j) = 0.0
       endif
       albedo_vis_dif(i,j) = albedo_vis_dir(i,j)
       albedo_nir_dir(i,j) = albedo_vis_dir(i,j)
       albedo_nir_dif(i,j) = albedo_vis_dir(i,j)

   enddo
   enddo

endif

if(ocean_albedo_option == 2) then
  albedo_vis_dir = alb2
  albedo_vis_dif = alb2
  albedo_nir_dir = alb2
  albedo_nir_dif = alb2
endif

if(ocean_albedo_option == 3) then

   where(coszen .ne. 0.0) 
      cos14 = coszen**1.4
   elsewhere
      cos14 = 0.0
   endwhere

   where(ocean)
      albedo_vis_dir = 0.037/(1.1*cos14 + 0.15)
   endwhere
   albedo_vis_dif = albedo_vis_dir ! this is wrong, use albedo_option=5
   albedo_nir_dir = albedo_vis_dir
   albedo_nir_dif = albedo_vis_dir ! this is wrong, use albedo_option=5

endif

if(ocean_albedo_option == 4) then
  albedo_vis_dir = const_alb
  albedo_vis_dif = const_alb
  albedo_nir_dir = const_alb
  albedo_nir_dif = const_alb
endif

if (ocean_albedo_option == 5) then
  where (coszen .ge. 0.0)
    albedo_vis_dir = 0.026/(coszen**1.7+0.065)                  &
                    +0.15*(coszen-0.10)*(coszen-0.5)*(coszen-1.0)
  elsewhere
    albedo_vis_dir = 0.4075 ! coszen=0 value of above expression
  endwhere
  albedo_vis_dif = 0.06
  albedo_nir_dir = albedo_vis_dir
  albedo_nir_dif = 0.06
endif

where (.not.ocean)
  albedo_vis_dir = 0.0
  albedo_vis_dif = 0.0
  albedo_nir_dir = 0.0
  albedo_nir_dif = 0.0
end where
   
!-----------------------------------------------------------------------

   end subroutine compute_ocean_albedo_new

!#######################################################################

   subroutine ocean_albedo_init(ocean,lat)
   logical, intent(in), optional :: ocean(:,:)
   real,    intent(in), optional :: lat(:,:)

   integer :: unit
   integer :: io ,ierr
   real,    allocatable, dimension(:,:) :: xx
   integer, allocatable, dimension(:,:) :: j1
   integer :: i,j

      rad2deg = 90./asin(1.0)

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=ocean_albedo_nml, iostat=io)
  ierr = check_nml_error(io, 'ocean_albedo_nml')
#else
      if (file_exist('input.nml')) then
         unit = open_namelist_file ('input.nml')
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=ocean_albedo_nml, iostat=io, end=10)
            ierr = check_nml_error(io,'ocean_albedo_nml')
         enddo
  10     call close_file (unit)
      endif
#endif

!------- write version number and namelist ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
           unit = stdlog()
           write (unit, nml=ocean_albedo_nml)
      endif

   if (ocean_albedo_option < 1 .or. ocean_albedo_option > 5)   &
       call error_mesg ('ocean_albedo',                        &
                        'ocean_albedo_option must = 1,2,3,4 or 5', FATAL)

   if(ocean_albedo_option == 2) then
     if ( present(ocean) .and. present(lat) ) then
       allocate (alb2(size(lat,1),size(lat,2)))
       allocate (xx(size(ocean,1),size(ocean,2)))
       allocate (j1(size(ocean,1),size(ocean,2)))
       xx = (rad2deg*lat + 90.0)/10.0
       j1 = int(xx)
       xx = xx - float(j1)
       do j = 1, size(ocean,2)
         do i = 1, size(ocean,1)
           if (ocean(i,j)) then
             alb2(i,j) = albedo_mcm(j1(i,j)+1) + xx(i,j)*(albedo_mcm(j1(i,j)+2) - albedo_mcm(j1(i,j)+1))
           endif
         enddo
       enddo
       deallocate (xx, j1)
     else
       call error_mesg ('ocean_albedo_init', &
         'ocean_albedo_option = 2 but ocean or lat or both are missing', FATAL)
     endif
   endif

   first   = .false.

   end subroutine ocean_albedo_init

!#######################################################################

end module ocean_albedo_mod




module ocean_rough_mod

!-----------------------------------------------------------------------

#ifdef INTERNAL_FILE_NML
use          mpp_mod, only: input_nml_file
#else
use          fms_mod, only: open_namelist_file
#endif

use       fms_mod, only: error_mesg, FATAL, file_exist,  &
                         check_nml_error, mpp_pe, mpp_root_pe, close_file, &
                         write_version_number, stdlog
use constants_mod, only: grav

implicit none
private

public :: compute_ocean_roughness, fixed_ocean_roughness

!-----------------------------------------------------------------------
character(len=256) :: version = '$Id: ocean_rough.F90,v 18.0.4.1 2010/09/14 19:29:20 pjp Exp $'
character(len=256) :: tagname = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------
!----- namelist -----

  real    :: roughness_init = 0.00044   ! not used in this version
  real    :: roughness_min  = 1.e-6
  real    :: charnock       = 0.032
  
  real    :: roughness_mom   = 5.8e-5
  real    :: roughness_heat  = 5.8e-5   ! was 4.00e-4
  real    :: roughness_moist = 5.8e-5
!  real, parameter :: zcoh1 = 0.0       ! Beljaars 1994 values
!  real, parameter :: zcoq1 = 0.0
! real, parameter :: zcoh1 = 1.4e-5
! real, parameter :: zcoq1 = 1.3e-4
  real            :: zcoh1 = 0.0 !miz
  real            :: zcoq1 = 0.0 !miz
  logical :: do_highwind     = .false.
  logical :: do_cap40        = .false.

  character(len=32) :: rough_scheme = 'fixed'   ! possible values:
                                                !   'fixed'
                                                !   'charnock'
                                                !   'beljaars'

namelist /ocean_rough_nml/ roughness_init, roughness_heat,  &
                           roughness_mom,  roughness_moist, &
                           roughness_min,                   &
                           charnock,                        &
                           rough_scheme, do_highwind,       &!miz
                           do_cap40, zcoh1, zcoq1            !sjl


!-----------------------------------------------------------------------

  logical :: do_init = .true.

!-----------------------------------------------------------------------
! ---- constants ----

! ..... high wind speed - rough sea
  real, parameter :: zcom1 = 1.8e-2    ! Charnock's constant
! ..... low wind speed - smooth sea
  real, parameter :: gnu   = 1.5e-5
  real, parameter :: zcom2 = 0.11
  real, parameter :: zcoh2 = 0.40
  real, parameter :: zcoq2 = 0.62


contains

!#######################################################################

 subroutine compute_ocean_roughness ( ocean, u_star,  &
                                      rough_mom, rough_heat, rough_moist )

 logical, intent(in)  :: ocean(:,:)
 real,    intent(in)  :: u_star(:,:)
 real,    intent(out) :: rough_mom(:,:), rough_heat(:,:), rough_moist(:,:)

!-----------------------------------------------------------------------
!  computes ocean roughness for momentum using wind stress
!  and sets roughness for heat/moisture using namelist value
!-----------------------------------------------------------------------

   real, dimension(size(ocean,1),size(ocean,2)) :: ustar2, xx1, xx2, w10 !miz
   real ::  a=0.001, b=0.028 !miz

   if (do_init) call ocean_rough_init


   if (trim(rough_scheme) == 'fixed') then

!  --- set roughness for momentum and heat/moisture ---

      call fixed_ocean_roughness ( ocean, rough_mom, rough_heat, &
                                          rough_moist )


!  --- compute roughness for momentum, heat, moisture ---

   else if (trim(rough_scheme) == 'beljaars' .or. &
            trim(rough_scheme) == 'charnock') then

      where (ocean)
          ustar2(:,:) = max(gnu*gnu,u_star(:,:)*u_star(:,:))          
          xx1(:,:) = gnu / sqrt(ustar2(:,:))
          xx2(:,:) = ustar2(:,:) / grav
      elsewhere
          rough_mom   = 0.0
          rough_heat  = 0.0
          rough_moist = 0.0
      endwhere

      if (trim(rough_scheme) == 'charnock') then
          where (ocean)
              rough_mom  (:,:) = charnock * xx2(:,:)
              rough_mom  (:,:) = max( rough_mom(:,:), roughness_min )
              rough_heat (:,:) = rough_mom  (:,:)
              rough_moist(:,:) = rough_mom  (:,:)
          endwhere
      else if (trim(rough_scheme) == 'beljaars') then
!     --- Beljaars scheme ---

! SJL*** High Wind correction following Moon et al 2007 ***
          if (do_highwind) then

              if ( do_cap40 ) then
     
              where (ocean)
                  w10(:,:) = 2.458 + u_star(:,:)*(20.255-0.56*u_star(:,:))  ! Eq(7) Moon et al.
                  where ( w10(:,:) > 12.5 )
! SJL mods: cap the growth of z0 with w10 up to 40 m/s
!                     rough_mom(:,:) = 0.001*(0.085*min(w10(:,:), 40.) - 0.58)    ! capped Eq(8b) Moon et al.
! z0 (w10=40) = 2.82E-3
                      rough_mom(:,:) = 0.001*(0.085*w10(:,:) - 0.58)    ! Eq(8b) Moon et al.
                      rough_mom(:,:) = min( rough_mom(:,:), 2.82E-3)
                  elsewhere     
                      rough_mom(:,:) = 0.0185/grav*u_star(:,:)**2  ! (8a) Moon et al.
                  endwhere
                  rough_heat (:,:) = zcoh1 * xx2(:,:) + zcoh2 * xx1(:,:)
                  rough_moist(:,:) = zcoq1 * xx2(:,:) + zcoq2 * xx1(:,:)
!             --- lower limit on roughness? ---
                  rough_mom  (:,:) = max( rough_mom  (:,:), roughness_min )
                  rough_heat (:,:) = max( rough_heat (:,:), roughness_min )
                  rough_moist(:,:) = max( rough_moist(:,:), roughness_min )
              endwhere

              else

              where (ocean)
                  w10(:,:) = 2.458 + u_star(:,:)*(20.255-0.56*u_star(:,:))  ! Eq(7) Moon et al.
                  where ( w10(:,:) > 12.5 )
                      rough_mom(:,:) = 0.001*(0.085*w10(:,:) - 0.58)    ! Eq(8b) Moon et al.
                  elsewhere     
                      rough_mom(:,:) = 0.0185/grav*u_star(:,:)**2  ! (8a) Moon et al.
                  endwhere
                  rough_heat (:,:) = zcoh1 * xx2(:,:) + zcoh2 * xx1(:,:)
                  rough_moist(:,:) = zcoq1 * xx2(:,:) + zcoq2 * xx1(:,:)
!             --- lower limit on roughness? ---
                  rough_mom  (:,:) = max( rough_mom  (:,:), roughness_min )
                  rough_heat (:,:) = max( rough_heat (:,:), roughness_min )
                  rough_moist(:,:) = max( rough_moist(:,:), roughness_min )
              endwhere

              endif
! SJL ----------------------------------------------------------------------------------------

          else
          where (ocean)
              rough_mom  (:,:) = zcom1 * xx2(:,:) + zcom2 * xx1(:,:)
              rough_heat (:,:) = zcoh1 * xx2(:,:) + zcoh2 * xx1(:,:)
              rough_moist(:,:) = zcoq1 * xx2(:,:) + zcoq2 * xx1(:,:)
!             --- lower limit on roughness? ---
              rough_mom  (:,:) = max( rough_mom  (:,:), roughness_min )
              rough_heat (:,:) = max( rough_heat (:,:), roughness_min )
              rough_moist(:,:) = max( rough_moist(:,:), roughness_min )
          endwhere
          endif
      endif
   endif

!-----------------------------------------------------------------------

 end subroutine compute_ocean_roughness

!#######################################################################

 subroutine fixed_ocean_roughness ( ocean, rough_mom, rough_heat, rough_moist )

 logical, intent(in)  :: ocean(:,:)
 real,    intent(out) :: rough_mom(:,:), rough_heat(:,:), rough_moist(:,:)

   if (do_init) call ocean_rough_init

    where (ocean)
       rough_mom   = roughness_mom
       rough_heat  = roughness_heat
       rough_moist = roughness_moist
    endwhere

 end subroutine fixed_ocean_roughness

!#######################################################################

 subroutine ocean_rough_init

   integer :: unit, ierr, io

!   ----- read and write namelist -----

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=ocean_rough_nml, iostat=io)
  ierr = check_nml_error(io, 'ocean_rough_nml')
#else
    if ( file_exist('input.nml')) then
          unit = open_namelist_file ('input.nml')
        ierr=1; do while (ierr /= 0)
           read  (unit, nml=ocean_rough_nml, iostat=io, end=10)
           ierr = check_nml_error(io,'ocean_rough_nml')
        enddo
 10     call close_file (unit)
    endif
#endif

!------- write version number and namelist ---------

    if ( mpp_pe() == mpp_root_pe() ) then
         call write_version_number(version, tagname)
         unit = stdlog()
         write (unit,nml=ocean_rough_nml)
         write (unit,11)
    endif

!------ constants -----

    roughness_moist = max (roughness_moist, roughness_min)
    roughness_heat  = max (roughness_heat , roughness_min)
    roughness_mom   = max (roughness_mom  , roughness_min)

    do_init = .false.

11 format (/,'namelist option USE_FIXED_ROUGH is no longer supported', &
           /,'use variable ROUGH_SCHEME instead')

 end subroutine ocean_rough_init

!#######################################################################

end module ocean_rough_mod



module land_constants_mod

use constants_mod, only : rdgas, rvgas, wtmair

implicit none
private

! ==== public interfaces =====================================================
integer, public, parameter :: &
     NBANDS   = 2, & ! number of spectral bands for short-wave radiation calculations
     BAND_VIS = 1, & ! visible radiation (wavelenght range?)
     BAND_NIR = 2    ! near infra-red radiation (wavelenght range?)

real, public, parameter :: d622 = rdgas/rvgas
real, public, parameter :: d378 = 1.0-d622
real, public, parameter :: d608 = d378/d622

real, public, parameter :: Rugas = 8.314472 ! universal gas constant, J K-1 mol-1

real, public, parameter :: seconds_per_year = 86400.0*365.0
real, public, parameter :: mol_C = 12.0e-3 ! molar mass of carbon, kg
real, public, parameter :: mol_air = wtmair/1000.0 ! molar mass of air, kg
real, public, parameter :: mol_CO2 = 44.00995e-3 ! molar mass of CO2,kg
real, public, parameter :: mol_h2o = 18.0e-3 ! molar mass of water, kg
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: land_constants.F90,v 17.0 2009/07/21 03:02:18 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

end module


module land_data_mod

use mpp_mod           , only : mpp_get_current_pelist, mpp_pe
use constants_mod     , only : PI
use mpp_domains_mod   , only : domain2d, mpp_get_compute_domain, &
     mpp_define_layout, mpp_define_domains, mpp_define_io_domain, &
     mpp_get_current_ntile, mpp_get_tile_id, CYCLIC_GLOBAL_DOMAIN, &
     mpp_get_io_domain, mpp_get_pelist, mpp_get_layout
use mpp_mod,            only : mpp_chksum
use fms_mod           , only : write_version_number, mpp_npes, &
                               error_mesg, FATAL, stdout
use time_manager_mod  , only : time_type
use tracer_manager_mod, only : register_tracers, get_tracer_index, NO_TRACER
use field_manager_mod , only : MODEL_LAND
use grid_mod          , only : get_grid_ntiles, get_grid_size, get_grid_cell_vertices, &
     get_grid_cell_centers, get_grid_cell_area, get_grid_comp_area, &
     define_cube_mosaic
use land_tile_mod     , only : land_tile_type, land_tile_list_type, &
     land_tile_list_init, land_tile_list_end, nitems

implicit none
private

! ==== public interfaces =====================================================
public :: land_data_init
public :: land_data_end
public :: lnd            ! global data 

public :: atmos_land_boundary_type ! container for information passed from the 
                         ! atmosphere to land
public :: land_data_type ! container for information passed from land to 
                         ! the atmosphere
! both hold information on land grid (that is, after flux exchange translated 
! it from the atmosphere)
public land_data_type_chksum    ! routine to print checksums for land_data_type
public atm_lnd_bnd_type_chksum  ! routine to print checksums for atmos_land_boundary_type

public :: dealloc_land2cplr ! deallocates a land_data_type structure
public :: realloc_land2cplr ! allocates a land_data_type members for current 
                            ! number of tiles
public :: dealloc_cplr2land ! deallocates an atmos_land_boundary_type structure
public :: realloc_cplr2land ! allocates an atmos_land_boundary_type members 
                            ! for current number of tiles
! NOTE: realloc_* procedures can be called regardless of the current state
! of the argument data structures, since they deallocate data first.

public :: land_state_type
! ==== end of public interfaces ==============================================

! ---- module constants ------------------------------------------------------
character(len=*), parameter :: &
     module_name = 'land_data_mod', &
     version     = '$Id: land_data.F90,v 17.0.2.6.2.1 2010/08/13 16:52:14 wfc Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'

! init_value is used to fill most of the allocated boundary condition arrays.
! It is supposed to be double-precision signaling NaN, to trigger a trap when
! the program is compiled with trapping non-initialized values.  
! See http://ftp.uniovi.es/~antonio/uned/ieee754/IEEE-754references.html
real, parameter :: init_value = Z'FFF0000000000001'

! ---- types -----------------------------------------------------------------
type :: atmos_land_boundary_type
   ! data passed from the coupler to the surface
   real, dimension(:,:,:), pointer :: & ! (lon, lat, tile)
        t_flux    => NULL(), &   ! sensible heat flux, W/m2
        lw_flux   => NULL(), &   ! net longwave radiation flux, W/m2
        lwdn_flux => NULL(), &   ! downward longwave radiation flux, W/m2
        sw_flux   => NULL(), &   ! net shortwave radiation flux, W/m2
        swdn_flux => NULL(), &   ! downward shortwave radiation flux, W/m2
        lprec     => NULL(), &   ! liquid precipitation rate, kg/(m2 s)
        fprec     => NULL(), &   ! frozen precipitation rate, kg/(m2 s)
        tprec     => NULL(), &   ! temperature of precipitation, degK
   ! components of downward shortwave flux, W/m2  
        sw_flux_down_vis_dir   => NULL(), & ! visible direct 
        sw_flux_down_total_dir => NULL(), & ! total direct
        sw_flux_down_vis_dif   => NULL(), & ! visible diffuse
        sw_flux_down_total_dif => NULL(), & ! total diffuse
   ! derivatives of the fluxes
        dhdt      => NULL(), &   ! sensible w.r.t. surface temperature
        dhdq      => NULL(), &   ! sensible w.r.t. surface humidity
        drdt      => NULL(), &   ! longwave w.r.t. surface radiative temperature 
   !
        cd_m      => NULL(), &   ! drag coefficient for momentum, dimensionless
        cd_t      => NULL(), &   ! drag coefficient for tracers, dimensionless
        ustar     => NULL(), &   ! turbulent wind scale, m/s
        bstar     => NULL(), &   ! turbulent buoyancy scale, m/s
        wind      => NULL(), &   ! abs wind speed at the bottom of the atmos, m/s
        z_bot     => NULL(), &   ! height of the bottom atmospheric layer above the surface, m
        drag_q    => NULL(), &   ! product of cd_q by wind
        p_surf    => NULL()      ! surface pressure, Pa

   real, dimension(:,:,:,:), pointer :: & ! (lon, lat, tile, tracer)
        tr_flux => NULL(),   &   ! tracer flux, including water vapor flux
        dfdtr   => NULL()        ! derivative of the flux w.r.t. tracer surface value, 
                                 ! including evap over surface specific humidity

   integer :: xtype             !REGRID, REDIST or DIRECT
end type atmos_land_boundary_type


type :: land_data_type
   ! data passed from the surface to the coupler
   logical :: pe ! data presence indicator for stock calculations
   real, pointer, dimension(:,:,:)   :: &  ! (lon, lat, tile)
        tile_size      => NULL(),  & ! fractional coverage of cell by tile, dimensionless
        t_surf         => NULL(),  & ! ground surface temperature, degK
        t_ca           => NULL(),  & ! canopy air temperature, degK
        albedo         => NULL(),  & ! broadband land albedo [unused?]
        albedo_vis_dir => NULL(),  & ! albedo for direct visible radiation
        albedo_nir_dir => NULL(),  & ! albedo for direct NIR radiation 
        albedo_vis_dif => NULL(),  & ! albedo for diffuse visible radiation 
        albedo_nir_dif => NULL(),  & ! albedo for diffuse NIR radiation
        rough_mom      => NULL(),  & ! surface roughness length for momentum, m
        rough_heat     => NULL(),  & ! roughness length for tracers and heat, m
        rough_scale    => NULL()     ! topographic scaler for momentum drag, m

   real, pointer, dimension(:,:,:,:)   :: &  ! (lon, lat, tile, tracer)
        tr    => NULL()              ! tracers, including canopy air specific humidity

   ! NOTE that in contrast to most of the other fields in this structure, the discharges
   ! hold data per-gridcell, rather than per-tile basis. This, and the order of updates,
   ! have implications for the data reallocation procedure.
   real, pointer, dimension(:,:) :: &  ! (lon, lat)
     discharge           => NULL(),  & ! liquid water flux from land to ocean
     discharge_heat      => NULL(),  & ! sensible heat of discharge (0 C datum)
     discharge_snow      => NULL(),  & ! solid water flux from land to ocean
     discharge_snow_heat => NULL()     ! sensible heat of discharge_snow (0 C datum)

   logical, pointer, dimension(:,:,:):: &
        mask => NULL()               ! true if land

   integer :: axes(2)        ! IDs of diagnostic axes
   type(domain2d) :: domain  ! our computation domain
   logical, pointer :: maskmap(:,:) 
end type land_data_type


! land_state_type combines the general information about state of the land model:
! domain, coordinates, time steps, etc. There is only one variable of this type,
! and it is public in this module.
type :: land_state_type
   integer        :: is,ie,js,je ! compute domain boundaries
   integer        :: nlon,nlat   ! size of global grid
   integer        :: ntprog      ! number of prognostic tracers
   integer        :: isphum      ! index of specific humidity in tracer table
   integer        :: ico2        ! index of carbon dioxide in tracer table
   type(time_type):: dt_fast     ! fast (physical) time step
   type(time_type):: dt_slow     ! slow time step
   type(time_type):: time        ! current time

   real, pointer  :: lon (:,:), lat (:,:) ! domain grid center coordinates, radian
   real, pointer  :: lonb(:,:), latb(:,:) ! domain grid vertices, radian
   real, pointer  :: area(:,:)  ! land area per grid cell, m2
   real, pointer  :: cellarea(:,:)  ! grid cell area, m2
   real, pointer  :: coord_glon(:), coord_glonb(:) ! longitudes for use in diag axis and such, degrees East
   real, pointer  :: coord_glat(:), coord_glatb(:) ! latitudes for use in diag axis and such, degrees North

   ! map of tiles
   type(land_tile_list_type), pointer :: tile_map(:,:)
   
   type(domain2d) :: domain ! our domain -- should be the last since it simplifies
                            ! debugging in totalview
   integer :: nfaces ! number of mosaic faces
   integer :: face  ! the current mosaic face
   integer, allocatable :: pelist(:) ! list of processors that run land model
   integer, allocatable :: io_pelist(:) ! list of processors in our io_domain
   ! if io_domain was not defined, then there is just one element in this
   ! array, and it's equal to current PE
   integer :: io_id     ! suffix in the distributed files.
end type land_state_type

! ---- public module variables -----------------------------------------------
type(land_state_type),save :: lnd


! ---- private module variables ----------------------------------------------
logical :: module_is_initialized =.FALSE.


#define __DEALLOC__(x) if (associated(x)) deallocate(x)

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-



! ============================================================================
subroutine land_data_init(layout, io_layout, time, dt_fast, dt_slow)
  integer, intent(inout) :: layout(2) ! layout of our domains
  integer, intent(inout) :: io_layout(2) ! layout for land model io
  type(time_type), intent(in) :: &
       time,    & ! current model time
       dt_fast, & ! fast (physical) time step
       dt_slow    ! slow time step

  ! ---- local vars
  integer :: nlon, nlat ! size of global grid in lon and lat directions
  integer :: ntiles     ! number of tiles in the mosaic grid 
  integer :: ntracers, ndiag ! non-optional output from register_tracers
  integer, allocatable :: tile_ids(:) ! mosaic tile IDs for the current PE
  integer :: i,j
  type(domain2d), pointer :: io_domain ! our io_domain
  integer :: n_io_pes(2) ! number of PEs in our io_domain along x and y
  integer :: io_id(1)

  ! write the version and tag name to the logfile
  call write_version_number(version, tagname)

  ! define the processor layout information according to the global grid size 
  call get_grid_ntiles('LND',ntiles)
  lnd%nfaces = ntiles
  call get_grid_size('LND',1,nlon,nlat)
  ! set the size of global grid
  lnd%nlon = nlon; lnd%nlat = nlat
  if( layout(1)==0 .AND. layout(2)==0 ) &
       call mpp_define_layout( (/1,nlon,1,nlat/), mpp_npes()/ntiles, layout )
  if( layout(1)/=0 .AND. layout(2)==0 )layout(2) = mpp_npes()/(layout(1)*ntiles)
  if( layout(1)==0 .AND. layout(2)/=0 )layout(1) = mpp_npes()/(layout(2)*ntiles)

  ! define land model domain
  if (ntiles==1) then
     call mpp_define_domains ((/1,nlon, 1, nlat/), layout, lnd%domain, xhalo=1, yhalo=1,&
          xflags = CYCLIC_GLOBAL_DOMAIN, name = 'LAND MODEL')
  else
     call define_cube_mosaic ('LND', lnd%domain, layout, halo=1)
  endif

  ! define io domain
  call mpp_define_io_domain(lnd%domain, io_layout)

  ! set up list of processors for collective io: only the first processor in this
  ! list actually writes data, the rest just send the data to it.
  io_domain=>mpp_get_io_domain(lnd%domain)
  if (associated(io_domain)) then
     call mpp_get_layout(io_domain,n_io_pes)
     allocate(lnd%io_pelist(n_io_pes(1)*n_io_pes(2)))
     call mpp_get_pelist(io_domain,lnd%io_pelist)
     io_id = mpp_get_tile_id(io_domain)
     lnd%io_id = io_id(1)
  else
     allocate(lnd%io_pelist(1))
     lnd%io_pelist(1) = mpp_pe()
     lnd%io_id        = mpp_pe()
  endif
     

  ! get the domain information
  call mpp_get_compute_domain(lnd%domain, lnd%is,lnd%ie,lnd%js,lnd%je)

  ! get the mosaic tile number for this processor: this assumes that there is only one
  ! mosaic tile per PE.
  allocate(tile_ids(mpp_get_current_ntile(lnd%domain)))
  tile_ids = mpp_get_tile_id(lnd%domain)
  lnd%face = tile_ids(1)
  deallocate(tile_ids)

  allocate(lnd%tile_map (lnd%is:lnd%ie, lnd%js:lnd%je))

  allocate(lnd%lonb    (lnd%is:lnd%ie+1, lnd%js:lnd%je+1))
  allocate(lnd%latb    (lnd%is:lnd%ie+1, lnd%js:lnd%je+1))
  allocate(lnd%lon     (lnd%is:lnd%ie,   lnd%js:lnd%je))
  allocate(lnd%lat     (lnd%is:lnd%ie,   lnd%js:lnd%je))
  allocate(lnd%area    (lnd%is:lnd%ie,   lnd%js:lnd%je))
  allocate(lnd%cellarea(lnd%is:lnd%ie,   lnd%js:lnd%je))
  allocate(lnd%coord_glon(nlon), lnd%coord_glonb(nlon+1))
  allocate(lnd%coord_glat(nlat), lnd%coord_glatb(nlat+1))

  ! initialize coordinates
  call get_grid_cell_vertices('LND',lnd%face,lnd%coord_glonb,lnd%coord_glatb)
  call get_grid_cell_centers ('LND',lnd%face,lnd%coord_glon, lnd%coord_glat)
  call get_grid_cell_area    ('LND',lnd%face,lnd%cellarea, domain=lnd%domain)
  call get_grid_comp_area    ('LND',lnd%face,lnd%area,     domain=lnd%domain)
  
  ! set local coordinates arrays -- temporary, till such time as the global arrays
  ! are not necessary
  call get_grid_cell_vertices('LND',lnd%face,lnd%lonb,lnd%latb, domain=lnd%domain)
  call get_grid_cell_centers ('LND',lnd%face,lnd%lon, lnd%lat, domain=lnd%domain)
  ! convert coordinates to radian; note that 1D versions stay in degrees
  lnd%lonb = lnd%lonb*pi/180.0 ; lnd%lon = lnd%lon*pi/180.0
  lnd%latb = lnd%latb*pi/180.0 ; lnd%lat = lnd%lat*pi/180.0
  
  ! initialize land tile map
  do j = lnd%js,lnd%je
  do i = lnd%is,lnd%ie
     call land_tile_list_init(lnd%tile_map(i,j))
  enddo
  enddo

  ! initialize land model tracers, if necessary
  ! register land model tracers and find specific humidity
  call register_tracers ( MODEL_LAND, ntracers, lnd%ntprog, ndiag )
  lnd%isphum = get_tracer_index ( MODEL_LAND, 'sphum' )
  if (lnd%isphum==NO_TRACER) then
     call error_mesg('land_model_init','no required "sphum" tracer',FATAL)
  endif
  lnd%ico2 = get_tracer_index ( MODEL_LAND, 'co2' )
  ! NB: co2 might be absent, in this case ico2 == NO_TRACER

  ! initialize model's time-related parameters
  lnd%time    = time
  lnd%dt_fast = dt_fast
  lnd%dt_slow = dt_slow

  ! initialize the land model processor list
  allocate(lnd%pelist(0:mpp_npes()-1))
  call mpp_get_current_pelist(lnd%pelist)

end subroutine land_data_init

! ============================================================================
subroutine land_data_end()

  integer :: i,j
  
  module_is_initialized = .FALSE.

  ! deallocate land tile map here. 
  do j = lnd%js,lnd%je
  do i = lnd%is,lnd%ie
     call land_tile_list_end(lnd%tile_map(i,j))
  enddo
  enddo

  ! deallocate grid data
  deallocate(lnd%lonb, lnd%latb, lnd%lon, lnd%lat,&
       lnd%area, lnd%cellarea,&
       lnd%coord_glonb, lnd%coord_glon, &
       lnd%coord_glatb, lnd%coord_glat, &       
       lnd%tile_map,&
       lnd%pelist, lnd%io_pelist)

end subroutine land_data_end


! ============================================================================
! allocates boundary data for land domain and current number of tiles
subroutine realloc_land2cplr ( bnd )
  type(land_data_type), intent(inout) :: bnd     ! data to allocate

  ! ---- local vars
  integer :: n_tiles

  call dealloc_land2cplr(bnd, dealloc_discharges=.FALSE.)

  bnd%domain = lnd%domain
  n_tiles = max_n_tiles()


  ! allocate data according to the domain boundaries
  allocate( bnd%mask(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )

  allocate( bnd%tile_size(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%t_surf(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%t_ca(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%tr(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles,lnd%ntprog) )
  allocate( bnd%albedo(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%albedo_vis_dir(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%albedo_nir_dir(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%albedo_vis_dif(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%albedo_nir_dif(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%rough_mom(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%rough_heat(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )
  allocate( bnd%rough_scale(lnd%is:lnd%ie,lnd%js:lnd%je,n_tiles) )

  bnd%mask              = .FALSE.
  bnd%tile_size         = init_value
  bnd%t_surf            = init_value
  bnd%t_ca              = init_value
  bnd%tr                = init_value
  bnd%albedo            = init_value
  bnd%albedo_vis_dir    = init_value
  bnd%albedo_nir_dir    = init_value
  bnd%albedo_vis_dif    = init_value
  bnd%albedo_nir_dif    = init_value
  bnd%rough_mom         = init_value
  bnd%rough_heat        = init_value
  bnd%rough_scale       = init_value

  ! in contrast to the rest of the land boundary condition fields, discharges 
  ! are specified per grid cell, not per tile; therefore they should not be 
  ! re-allocated when the number of tiles changes. In fact, they must not be
  ! changed at all here because their values are assigned in update_land_model_fast,
  ! not in update_land_bc_*, and therefore would be lost if re-allocated.
  if (.not.associated(bnd%discharge)) then
     allocate( bnd%discharge          (lnd%is:lnd%ie,lnd%js:lnd%je) )
     allocate( bnd%discharge_heat     (lnd%is:lnd%ie,lnd%js:lnd%je) )
     allocate( bnd%discharge_snow     (lnd%is:lnd%ie,lnd%js:lnd%je) )
     allocate( bnd%discharge_snow_heat(lnd%is:lnd%ie,lnd%js:lnd%je) )

     ! discharge and discaharge_snow must be, in contrast to the rest of the boundary
     ! values, filled with zeroes. The reason is because not all of the usable elements
     ! are updated by the land model (only coastal points are).
     bnd%discharge           = 0.0
     bnd%discharge_heat      = 0.0
     bnd%discharge_snow      = 0.0
     bnd%discharge_snow_heat = 0.0
  endif
end subroutine realloc_land2cplr


! ============================================================================
! deallocates boundary data memory
! NOTE that the discharges should be deallocated only at the final clean-up
! stage; during the model run they should be preserved unchanged even when
! other fields are reallocated.
subroutine dealloc_land2cplr ( bnd, dealloc_discharges )
  type(land_data_type), intent(inout) :: bnd  ! data to de-allocate
  logical, intent(in) :: dealloc_discharges

  __DEALLOC__( bnd%tile_size )
  __DEALLOC__( bnd%tile_size )
  __DEALLOC__( bnd%t_surf )
  __DEALLOC__( bnd%t_ca )
  __DEALLOC__( bnd%tr )
  __DEALLOC__( bnd%albedo )
  __DEALLOC__( bnd%albedo_vis_dir )
  __DEALLOC__( bnd%albedo_nir_dir )
  __DEALLOC__( bnd%albedo_vis_dif )
  __DEALLOC__( bnd%albedo_nir_dif )
  __DEALLOC__( bnd%rough_mom )
  __DEALLOC__( bnd%rough_heat )
  __DEALLOC__( bnd%rough_scale )
  __DEALLOC__( bnd%mask )

  if (dealloc_discharges) then
     __DEALLOC__( bnd%discharge           )
     __DEALLOC__( bnd%discharge_heat      )
     __DEALLOC__( bnd%discharge_snow      )
     __DEALLOC__( bnd%discharge_snow_heat )
  end if

end subroutine dealloc_land2cplr


! ============================================================================
! allocates boundary data for land domain and current number of tiles;
! initializes data for data override.
! NOTE: previously the body of the procedure was in the flux_exchange_init,
! currently it is called from land_model_init
subroutine realloc_cplr2land( bnd )
  type(atmos_land_boundary_type), intent(inout) :: bnd

  ! ---- local vars
  integer :: kd

  call dealloc_cplr2land(bnd)

  ! allocate data according to the domain boundaries
  kd = max_n_tiles()

  allocate( bnd%t_flux(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%lw_flux(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%sw_flux(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%lprec(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%fprec(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%tprec(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%dhdt(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%dhdq(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%drdt(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%p_surf(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%tr_flux(lnd%is:lnd%ie,lnd%js:lnd%je,kd,lnd%ntprog) )
  allocate( bnd%dfdtr(lnd%is:lnd%ie,lnd%js:lnd%je,kd,lnd%ntprog) )

  allocate( bnd%lwdn_flux(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%swdn_flux(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%sw_flux_down_vis_dir(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%sw_flux_down_total_dir(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%sw_flux_down_vis_dif(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%sw_flux_down_total_dif(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%cd_t(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%cd_m(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%bstar(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%ustar(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%wind(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )
  allocate( bnd%z_bot(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )

  allocate( bnd%drag_q(lnd%is:lnd%ie,lnd%js:lnd%je,kd) )

  bnd%t_flux                 = init_value
  bnd%lw_flux                = init_value
  bnd%sw_flux                = init_value
  bnd%lprec                  = init_value
  bnd%fprec                  = init_value
  bnd%tprec                  = init_value
  bnd%dhdt                   = init_value
  bnd%dhdq                   = init_value
  bnd%drdt                   = init_value
  bnd%p_surf                 = init_value
  bnd%tr_flux                = init_value
  bnd%dfdtr                  = init_value

  bnd%lwdn_flux              = init_value
  bnd%swdn_flux              = init_value
  bnd%sw_flux_down_vis_dir   = init_value
  bnd%sw_flux_down_total_dir = init_value
  bnd%sw_flux_down_vis_dif   = init_value
  bnd%sw_flux_down_total_dif = init_value
  bnd%cd_t                   = init_value
  bnd%cd_m                   = init_value
  bnd%bstar                  = init_value
  bnd%ustar                  = init_value
  bnd%wind                   = init_value
  bnd%z_bot                  = init_value

  bnd%drag_q                 = init_value

end subroutine realloc_cplr2land


! ============================================================================
subroutine dealloc_cplr2land( bnd )
  type(atmos_land_boundary_type), intent(inout) :: bnd

  __DEALLOC__( bnd%t_flux )
  __DEALLOC__( bnd%lw_flux )
  __DEALLOC__( bnd%sw_flux )
  __DEALLOC__( bnd%lprec )
  __DEALLOC__( bnd%fprec )
  __DEALLOC__( bnd%dhdt )
  __DEALLOC__( bnd%dhdq )
  __DEALLOC__( bnd%drdt )
  __DEALLOC__( bnd%p_surf )
  __DEALLOC__( bnd%lwdn_flux )
  __DEALLOC__( bnd%swdn_flux )
  __DEALLOC__( bnd%sw_flux_down_vis_dir )
  __DEALLOC__( bnd%sw_flux_down_total_dir )
  __DEALLOC__( bnd%sw_flux_down_vis_dif )
  __DEALLOC__( bnd%sw_flux_down_total_dif )
  __DEALLOC__( bnd%cd_t )
  __DEALLOC__( bnd%cd_m )
  __DEALLOC__( bnd%bstar )
  __DEALLOC__( bnd%ustar )
  __DEALLOC__( bnd%wind )
  __DEALLOC__( bnd%z_bot )
  __DEALLOC__( bnd%tr_flux )
  __DEALLOC__( bnd%dfdtr )

end subroutine dealloc_cplr2land

! ============================================================================
! get max number of tiles in the domain
function max_n_tiles() result(n)
  integer :: n
  integer :: i,j

  n=1
  do j=lnd%js,lnd%je
  do i=lnd%is,lnd%ie
     n=max(n, nitems(lnd%tile_map(i,j)))
  enddo
  enddo

end function 

!#######################################################################
! <SUBROUTINE NAME="atm_lnd_bnd_type_chksum">
!
! <OVERVIEW>
!  Print checksums of the various fields in the atmos_land_boundary_type.
! </OVERVIEW>

! <DESCRIPTION>
!  Routine to print checksums of the various fields in the atmos_land_boundary_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call atm_lnd_bnd_type_chksum(id, timestep, albt)
! </TEMPLATE>

! <IN NAME="albt" TYPE="type(atmos_land_boundary_type)">
!   Derived-type variable that contains fields in the atmos_land_boundary_type.
! </INOUT>
!
! <IN NAME="id" TYPE="character">
!   Label to differentiate where this routine in being called from.
! </IN>
!
! <IN NAME="timestep" TYPE="integer">
!   An integer to indicate which timestep this routine is being called for.
! </IN>
!
subroutine atm_lnd_bnd_type_chksum(id, timestep, albt)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(atmos_land_boundary_type), intent(in) :: albt
    integer ::   n, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(atmos_land_boundary_type):: ', id, timestep
    write(outunit,100) 'albt%t_flux                ', mpp_chksum( albt%t_flux)
    write(outunit,100) 'albt%lw_flux               ', mpp_chksum( albt%lw_flux)
    write(outunit,100) 'albt%lwdn_flux             ', mpp_chksum( albt%lwdn_flux)
    write(outunit,100) 'albt%sw_flux               ', mpp_chksum( albt%sw_flux)
    write(outunit,100) 'albt%swdn_flux               ', mpp_chksum( albt%swdn_flux)
    write(outunit,100) 'albt%lprec                 ', mpp_chksum( albt%lprec)
    write(outunit,100) 'albt%fprec                 ', mpp_chksum( albt%fprec)
    write(outunit,100) 'albt%tprec                 ', mpp_chksum( albt%tprec)
    write(outunit,100) 'albt%sw_flux_down_vis_dir  ', mpp_chksum( albt%sw_flux_down_vis_dir)
    write(outunit,100) 'albt%sw_flux_down_total_dir', mpp_chksum( albt%sw_flux_down_total_dir)
    write(outunit,100) 'albt%sw_flux_down_vis_dif  ', mpp_chksum( albt%sw_flux_down_vis_dif)
    write(outunit,100) 'albt%sw_flux_down_total_dif', mpp_chksum( albt%sw_flux_down_total_dif)
    write(outunit,100) 'albt%dhdt                  ', mpp_chksum( albt%dhdt)
    write(outunit,100) 'albt%dhdq                  ', mpp_chksum( albt%dhdq)
    write(outunit,100) 'albt%drdt                  ', mpp_chksum( albt%drdt)
    write(outunit,100) 'albt%cd_m                  ', mpp_chksum( albt%cd_m)
    write(outunit,100) 'albt%cd_t                  ', mpp_chksum( albt%cd_t)
    write(outunit,100) 'albt%ustar                 ', mpp_chksum( albt%ustar)
    write(outunit,100) 'albt%bstar                 ', mpp_chksum( albt%bstar)
    write(outunit,100) 'albt%wind                  ', mpp_chksum( albt%wind)
    write(outunit,100) 'albt%z_bot                 ', mpp_chksum( albt%z_bot)
    write(outunit,100) 'albt%drag_q                ', mpp_chksum( albt%drag_q)
    write(outunit,100) 'albt%p_surf                ', mpp_chksum( albt%p_surf)
    do n = 1,size(albt%tr_flux,4)
    write(outunit,100) 'albt%tr_flux               ', mpp_chksum( albt%tr_flux(:,:,:,n))
    enddo
    do n = 1,size(albt%dfdtr,4)
    write(outunit,100) 'albt%dfdtr                 ', mpp_chksum( albt%dfdtr(:,:,:,n))
    enddo

100 FORMAT("CHECKSUM::",A32," = ",Z20)

end subroutine atm_lnd_bnd_type_chksum

! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="land_data_type_chksum">
!
! <OVERVIEW>
!  Print checksums of the various fields in the land_data_type.
! </OVERVIEW>

! <DESCRIPTION>
!  Routine to print checksums of the various fields in the land_data_type.
! </DESCRIPTION>

! <TEMPLATE>
!   call land_data_type_chksum(id, timestep, land)
! </TEMPLATE>

! <IN NAME="land" TYPE="type(land_data_type)">
!   Derived-type variable that contains fields in the land_data_type.
! </INOUT>
!
! <IN NAME="id" TYPE="character">
!   Label to differentiate where this routine in being called from.
! </IN>
!
! <IN NAME="timestep" TYPE="integer">
!   An integer to indicate which timestep this routine is being called for.
! </IN>
!

subroutine land_data_type_chksum(id, timestep, land)
  use fms_mod,                 only: stdout
  use mpp_mod,                 only: mpp_chksum

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(land_data_type), intent(in) :: land
    integer ::   n, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(land_data_type):: ', id, timestep
    write(outunit,100) 'land%tile_size         ',mpp_chksum(land%tile_size)
    write(outunit,100) 'land%t_surf            ',mpp_chksum(land%t_surf)
    write(outunit,100) 'land%t_ca              ',mpp_chksum(land%t_ca)
    write(outunit,100) 'land%albedo            ',mpp_chksum(land%albedo)
    write(outunit,100) 'land%albedo_vis_dir    ',mpp_chksum(land%albedo_vis_dir)
    write(outunit,100) 'land%albedo_nir_dir    ',mpp_chksum(land%albedo_nir_dir)
    write(outunit,100) 'land%albedo_vis_dif    ',mpp_chksum(land%albedo_vis_dif)
    write(outunit,100) 'land%albedo_nir_dif    ',mpp_chksum(land%albedo_nir_dif)
    write(outunit,100) 'land%rough_mom         ',mpp_chksum(land%rough_mom)
    write(outunit,100) 'land%rough_heat        ',mpp_chksum(land%rough_heat)
    write(outunit,100) 'land%rough_scale       ',mpp_chksum(land%rough_scale)

    do n = 1, size(land%tr,4)
    write(outunit,100) 'land%tr                ',mpp_chksum(land%tr(:,:,:,n))
    enddo
    write(outunit,100) 'land%discharge         ',mpp_chksum(land%discharge)
    write(outunit,100) 'land%discharge_snow    ',mpp_chksum(land%discharge_snow)
    write(outunit,100) 'land%discharge_heat    ',mpp_chksum(land%discharge_heat)


100 FORMAT("CHECKSUM::",A32," = ",Z20)
end subroutine land_data_type_chksum

! </SUBROUTINE>


end module land_data_mod


! ============================================================================
! top-level core of the Land Dynamics (LaD) model code
! ============================================================================
module land_model_mod

#include "shared/debug.inc"

use time_manager_mod, only : time_type, get_time, increment_time, time_type_to_real, &
     operator(+)
use mpp_domains_mod, only : domain2d, mpp_get_ntile_count

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use mpp_mod, only : mpp_max, mpp_sum
use fms_mod, only : write_version_number, error_mesg, FATAL, NOTE, mpp_pe, &
     mpp_root_pe, file_exist, check_nml_error, close_file, &
     stdlog, stderr, mpp_clock_id, mpp_clock_begin, mpp_clock_end, string, &
     stdout, CLOCK_FLAG_DEFAULT, CLOCK_COMPONENT, CLOCK_ROUTINE
use field_manager_mod, only : MODEL_LAND
use data_override_mod, only : data_override
use diag_manager_mod, only : diag_axis_init, register_static_field, &
     register_diag_field, send_data
use constants_mod, only : radius, hlf, hlv, hls, tfreeze, pi, rdgas, rvgas, cp_air, &
     stefan
use astronomy_mod, only : diurnal_solar
use sphum_mod, only : qscomp
use tracer_manager_mod, only : NO_TRACER

use land_constants_mod, only : NBANDS, BAND_VIS, BAND_NIR, mol_air, mol_C, mol_co2
use glacier_mod, only : read_glac_namelist, glac_init, glac_end, glac_get_sfc_temp, &
     glac_radiation, glac_diffusion, glac_step_1, glac_step_2, save_glac_restart
use lake_mod, only : read_lake_namelist, lake_init, lake_end, lake_get_sfc_temp, &
     lake_radiation, lake_diffusion, lake_step_1, lake_step_2, save_lake_restart
use soil_mod, only : read_soil_namelist, soil_init, soil_end, soil_get_sfc_temp, &
     soil_radiation, soil_diffusion, soil_step_1, soil_step_2, save_soil_restart
use snow_mod, only : read_snow_namelist, snow_init, snow_end, snow_get_sfc_temp, &
     snow_radiation, snow_diffusion, snow_get_depth_area, snow_step_1, snow_step_2, &
     save_snow_restart
use vegetation_mod, only : read_vegn_namelist, vegn_init, vegn_end, vegn_get_cover, &
     vegn_radiation, vegn_diffusion, vegn_step_1, vegn_step_2, vegn_step_3, &
     update_vegn_slow, save_vegn_restart
use cana_tile_mod, only : canopy_air_mass, canopy_air_mass_for_tracers, cana_tile_heat
use canopy_air_mod, only : read_cana_namelist, cana_init, cana_end, cana_state,&
     cana_step_1, cana_step_2, cana_radiation, cana_roughness, &
     save_cana_restart
use river_mod, only : river_init, river_end, update_river, river_stock_pe, &
     save_river_restart
use topo_rough_mod, only : topo_rough_init, topo_rough_end, update_topo_rough
use soil_tile_mod, only : soil_cover_cold_start, soil_tile_stock_pe, &
                          soil_tile_heat
use vegn_tile_mod, only : vegn_cover_cold_start, vegn_data_rs_min, &
                          update_derived_vegn_data, vegn_tile_stock_pe, &
                          vegn_tile_heat
use lake_tile_mod, only : lake_cover_cold_start, lake_tile_stock_pe, &
                          lake_tile_heat
use glac_tile_mod, only : glac_pars_type, glac_cover_cold_start, &
                          glac_tile_stock_pe, glac_tile_heat
use snow_tile_mod, only : snow_tile_stock_pe, snow_tile_heat
use land_numerics_mod, only : ludcmp, lubksb, nearest, &
     horiz_remap_type, horiz_remap_new, horiz_remap, horiz_remap_del, &
     horiz_remap_print
use land_tile_mod, only : land_tile_type, land_tile_list_type, &
     land_tile_enum_type, new_land_tile, insert, nitems, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=), &
     get_elmt_indices, get_tile_tags
use land_data_mod, only : land_data_type, atmos_land_boundary_type, &
     land_state_type, land_data_init, land_data_end, lnd, &
     dealloc_land2cplr, realloc_land2cplr, &
     dealloc_cplr2land, realloc_cplr2land, &
     land_data_type_chksum, atm_lnd_bnd_type_chksum
use nf_utils_mod,  only : nfu_inq_var, nfu_inq_dim, nfu_get_var
use land_utils_mod, only : put_to_tiles_r0d_fptr
use land_tile_io_mod, only : print_netcdf_error, create_tile_out_file, &
    read_tile_data_r0d_fptr, write_tile_data_r0d_fptr, &
    write_tile_data_i0d_fptr, get_input_restart_name
use land_tile_diag_mod, only : tile_diag_init, tile_diag_end, &
    register_tiled_diag_field, send_tile_data, dump_tile_diag_fields, &
    OP_AVERAGE, OP_SUM
use land_debug_mod, only : land_debug_init, land_debug_end, set_current_point, &
     is_watch_point, get_watch_point, check_temp_range, current_face, &
     get_current_point
use static_vegn_mod, only : write_static_vegn
use land_transitions_mod, only : &
     land_transitions_init, land_transitions_end, land_transitions, &
     save_land_transitions_restart
use stock_constants_mod, only: ISTOCK_WATER, ISTOCK_HEAT, ISTOCK_SALT

implicit none
private

! ==== public interfaces =====================================================
public land_model_init          ! initialize the land model
public land_model_end           ! finish land model calculations
public land_model_restart       ! saves the land model restart(s)
public update_land_model_fast   ! time-step integration
public update_land_model_slow   ! time-step integration
public atmos_land_boundary_type ! data from coupler to land
public land_data_type           ! data from land to coupler
public land_data_type_chksum    ! routine to print checksums for land_data_type
public atm_lnd_bnd_type_chksum  ! routine to print checksums for atmos_land_boundary_type

public :: Lnd_stock_pe          ! return stocks of conservative quantities
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'land', &
     version     = '$Id: land_model.F90,v 17.1.2.8.2.14.2.1.2.1.2.1 2010/08/24 12:11:35 pjp Exp $', &
     tagname     = '$Name:  $'

! ==== module variables ======================================================

! ---- namelist --------------------------------------------------------------
logical :: use_old_conservation_equations  = .false.
logical :: lm2                             = .false.
logical :: do_age                          = .false.
logical :: give_stock_details              = .false.
logical :: use_tfreeze_in_grnd_latent      = .false.
logical :: use_atmos_T_for_precip_T        = .false.
logical :: use_atmos_T_for_evap_T          = .false.
real    :: cpw = 1952.  ! specific heat of water vapor at constant pressure
real    :: clw = 4218.  ! specific heat of water (liquid)
real    :: csw = 2106.  ! specific heat of water (ice)
real    :: min_sum_lake_frac = 1.e-8
real    :: gfrac_tol         = 1.e-6
real    :: discharge_tol = -1.e20
real    :: con_fac_large = 1.e6
real    :: con_fac_small = 1.e-6
integer :: num_c = 0
real    :: tau_snow_T_adj = -1.0 ! time scale of snow temperature adjustment
              ! for the snow-free surface (s); negative means no adjustment
character(16) :: nearest_point_search = 'global' ! specifies where to look for
              ! nearest points for missing data, "global" or "face"
logical :: print_remapping = .FALSE. ! if true, full land cover remapping
              ! information is printed on the cold start
integer :: layout(2) = (/0,0/)
integer :: io_layout(2) = (/0,0/)
namelist /land_model_nml/ use_old_conservation_equations, &
                          lm2, do_age, give_stock_details, &
                          use_tfreeze_in_grnd_latent, &
                          use_atmos_T_for_precip_T, &
                          use_atmos_T_for_evap_T, &
                          cpw, clw, csw, min_sum_lake_frac, &
                          gfrac_tol, discharge_tol, &
                          con_fac_large, con_fac_small, num_c, &
                          tau_snow_T_adj, &
                          nearest_point_search, print_remapping, &
                          layout, io_layout
! ---- end of namelist -------------------------------------------------------

logical  :: module_is_initialized = .FALSE.
logical  :: stock_warning_issued  = .FALSE.
logical  :: update_cana_co2 ! if false, cana_co2 is not updated during the model run.
character(len=256) :: grid_spec_file="INPUT/grid_spec.nc" 
real     :: delta_time ! duration of main land time step (s)
integer  :: num_species
integer  :: num_phys = 2
real,    allocatable :: frac           (:,:)    ! fraction of land in cells
logical, allocatable :: river_land_mask(:,:), missing_rivers(:,:)
real,    allocatable :: no_riv(:,:)

! ---- diag field IDs --------------------------------------------------------
integer :: &
 ! COLUMN        VEGN        SNOW      GLAC/LAKE/SOIL  CANOPY-AIR  RIVER
  id_VWS,                                               id_VWSc,           &
  id_LWS,      id_LWSv,     id_LWSs,     id_LWSg,                          &
  id_FWS,      id_FWSv,     id_FWSs,     id_FWSg,                          &
  id_HS,       id_HSv,      id_HSs,      id_HSg,        id_HSc,            &
  id_precip,                                                               &
  id_hprec,                                                                &
  id_lprec,    id_lprecv,   id_lprecs,   id_lprecg,                        &
  id_hlprec,   id_hlprecv,  id_hlprecs,  id_hlprecg,                       &
  id_fprec,    id_fprecv,   id_fprecs,                                     &
  id_hfprec,   id_hfprecv,  id_hfprecs,                                    &
  id_evap,                                                                 &
  id_hevap,                                                                &
  id_levap,    id_levapv,   id_levaps,   id_levapg,                        &
  id_hlevap,   id_hlevapv,  id_hlevaps,  id_hlevapg,                       &
  id_fevap,    id_fevapv,   id_fevaps,   id_fevapg,                        &
  id_hfevap,   id_hfevapv,  id_hfevaps,  id_hfevapg,                       &
  id_runf,                                                                 &
  id_hrunf,                                                                &
  id_lrunf,                 id_lrunfs,   id_lrunfg,                        &
  id_hlrunf,                id_hlrunfs,  id_hlrunfg,                       &
  id_frunf,                 id_frunfs,                                     &
  id_hfrunf,                id_hfrunfs,                                    &
  id_melt,     id_meltv,    id_melts,    id_meltg,                         &
  id_fsw,      id_fswv,     id_fsws,     id_fswg,                          &
  id_flw,      id_flwv,     id_flws,     id_flwg,                          &
  id_sens,     id_sensv,    id_senss,    id_sensg,                         &
!
  id_e_res_1,  id_e_res_2,                                                 &
  id_cellarea, id_landarea, id_landfrac, id_no_riv,                        &
  id_geolon_t, id_geolat_t,                                                &
  id_frac,     id_area,     id_ntiles,                                     &
  id_dis_liq,  id_dis_ice,  id_dis_heat, id_dis_sink,                      &
  id_z0m,      id_z0s,      id_con_g_h,                                    &
  id_transp,                id_wroff,    id_sroff,                         &
  id_htransp,  id_huptake,  id_hroff,    id_gsnow,    id_gequil,           &
  id_gsnow_old,                                                            &
  id_grnd_flux,                                                            &
  id_soil_water_supply,     id_levapg_max,                                 &
  id_water,    id_snow,                                                    &
  id_Trad,     id_Tca,      id_qca,      id_qco2,     id_qco2_dvmr,        &
  id_swdn_dir, id_swdn_dif, id_swup_dir, id_swup_dif, id_lwdn,             &
  id_fco2,                                                                 &
  id_vegn_cover,    id_cosz,                                               &
  id_albedo_dir,    id_albedo_dif,                                         &
  id_vegn_refl_dir, id_vegn_refl_dif, id_vegn_refl_lw,                     &
  id_vegn_tran_dir, id_vegn_tran_dif, id_vegn_tran_lw,                     &
  id_vegn_sctr_dir,                                                        &
  id_subs_refl_dir, id_subs_refl_dif, id_grnd_T

! ---- global clock IDs
integer :: landClock, landFastClock, landSlowClock


! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),__FILE__,__LINE__)

contains


! ============================================================================
subroutine land_model_init &
     (cplr2land, land2cplr, time_init, time, dt_fast, dt_slow)
! initialize land model using grid description file as an input. This routine
! reads land grid boundaries and area of land from a grid description file

! NOTES: theoretically, the grid description file can specify any regular
! rectangular grid for land, not just lon/lat grid. Therefore the variables
! "xbl" and "ybl" in NetCDF grid spec file are not necessarily lon and lat
! boundaries of the grid.
!   However, at this time the module land_properties assumes that grid _is_
! lon/lat and therefore the entire module also have to assume that the land 
! grid is lon/lat.
!   lon/lat grid is also assumed for the diagnostics, but this is probably not
! so critical. 
  type(atmos_land_boundary_type), intent(inout) :: cplr2land ! boundary data
  type(land_data_type)          , intent(inout) :: land2cplr ! boundary data
  type(time_type), intent(in) :: time_init ! initial time of simulation (?)
  type(time_type), intent(in) :: time      ! current time
  type(time_type), intent(in) :: dt_fast   ! fast time step
  type(time_type), intent(in) :: dt_slow   ! slow time step

  ! ---- local vars ----------------------------------------------------------
  integer :: ncid, varid
  integer :: unit, ierr, io
  integer :: id_lon, id_lat, id_band     ! IDs of land diagnostic axes
  logical :: used                        ! return value of send_data diagnostics routine
  integer :: i,j,k
  type(land_tile_type), pointer :: tile
  type(land_tile_enum_type) :: ce, te
  character(len=256) :: restart_file_name
  logical :: restart_exists
  ! IDs of local clocks
  integer :: landInitClock

  module_is_initialized = .TRUE.

  ! [1] print out version number
  call write_version_number (version, tagname)

  ! initialize land model clocks
  landClock      = mpp_clock_id('Land'               ,CLOCK_FLAG_DEFAULT,CLOCK_COMPONENT)
  landFastClock  = mpp_clock_id('Update-Land-Fast'   ,CLOCK_FLAG_DEFAULT,CLOCK_ROUTINE)
  landSlowClock  = mpp_clock_id('Update-Land-Slow'   ,CLOCK_FLAG_DEFAULT,CLOCK_ROUTINE)
  landInitClock  = mpp_clock_id('Land init'          ,CLOCK_FLAG_DEFAULT,CLOCK_ROUTINE)

  call mpp_clock_begin(landInitClock)

  ! [ ] initialize land debug output
  call land_debug_init()

  ! [ ] initialize tile-specific diagnostics internals
  call tile_diag_init()

  ! [2] read namelists
  ! [2.1] read land model namelist
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=land_model_nml, iostat=io)
     ierr = check_nml_error(io, 'land_model_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file ( )
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=land_model_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'land_model_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit = stdlog()
     write (unit, nml=land_model_nml)
     call close_file (unit)
  endif
  ! [2.2] read sub-model namelists: then need to be read before initialization
  ! because they can affect the way cover and tiling is initialized on cold start.
  call read_soil_namelist()
  call read_vegn_namelist()
  call read_lake_namelist()
  call read_glac_namelist()
  call read_snow_namelist()
  call read_cana_namelist()

  ! [ ] initialize land state data, including grid geometry and processor decomposition
  call land_data_init(layout, io_layout, time, dt_fast, dt_slow)
  delta_time  = time_type_to_real(lnd%dt_fast) ! store in a module variable for convenience

  ! calculate land fraction
  allocate(frac(lnd%is:lnd%ie,lnd%js:lnd%je))
  frac = lnd%area/lnd%cellarea

  ! [5] initialize tiling
  call get_input_restart_name('INPUT/land.res.nc',restart_exists,restart_file_name)
  if(restart_exists) then
     call error_mesg('land_model_init',&
          'reading NetCDF restart "'//trim(restart_file_name)//'"',&
          NOTE)
     ! read map of tiles -- retrieve information from 
     call land_cover_warm_start(restart_file_name,lnd)
     ! initialize land model data
     __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,ncid))
     if (nf_inq_varid(ncid,'lwup',varid)==NF_NOERR) &
          call read_tile_data_r0d_fptr(ncid,'lwup',land_lwup_ptr)
     if (nf_inq_varid(ncid,'e_res_1',varid)==NF_NOERR) &
          call read_tile_data_r0d_fptr(ncid,'e_res_1',land_e_res_1_ptr)
     if (nf_inq_varid(ncid,'e_res_2',varid)==NF_NOERR) &
          call read_tile_data_r0d_fptr(ncid,'e_res_2',land_e_res_2_ptr)
     __NF_ASRT__(nf_close(ncid))
  else
     ! initialize map of tiles -- construct it by combining tiles
     ! from component models
     call error_mesg('land_model_init',&
          'cold-starting land cover map',&
          NOTE)
     call land_cover_cold_start(lnd)
  endif

  ! [6] initialize land model diagnostics -- must be before *_data_init so that
  ! *_data_init can write static fields if necessary
  call land_diag_init( lnd%coord_glonb, lnd%coord_glatb, lnd%coord_glon, lnd%coord_glat, time, lnd%domain, &
       id_lon, id_lat, id_band )
  ! set the land diagnostic axes ids for the flux exchange
  land2cplr%axes = (/id_lon,id_lat/)
  ! send some static diagnostic fields to output
  if ( id_cellarea > 0 ) used = send_data ( id_cellarea, lnd%cellarea, lnd%time )
  if ( id_landarea > 0 ) used = send_data ( id_landarea, lnd%area, lnd%time )
  if ( id_landfrac > 0 ) used = send_data ( id_landfrac, frac,     lnd%time )
  if ( id_geolon_t > 0 ) used = send_data ( id_geolon_t, lnd%lon,  lnd%time )
  if ( id_geolat_t > 0 ) used = send_data ( id_geolat_t, lnd%lat,  lnd%time )

  ! [7] initialize individual sub-models
  num_species = num_phys + num_c
  if (do_age) num_species = num_species + 1

  call soil_init ( id_lon, id_lat, id_band )
  call vegn_init ( id_lon, id_lat, id_band )
  call lake_init ( id_lon, id_lat )
  call glac_init ( id_lon, id_lat )
  call snow_init ( id_lon, id_lat )
  call cana_init ( id_lon, id_lat )
  call topo_rough_init( lnd%time, lnd%lonb, lnd%latb, &
       lnd%domain, id_lon, id_lat)
  allocate (river_land_mask(lnd%is:lnd%ie,lnd%js:lnd%je))
  allocate ( missing_rivers(lnd%is:lnd%ie,lnd%js:lnd%je))
  allocate ( no_riv        (lnd%is:lnd%ie,lnd%js:lnd%je))
  call river_init( lnd%lon, lnd%lat, &
                   lnd%time, lnd%dt_fast, lnd%domain,     &
                   frac, &
                   id_lon, id_lat,                        &
                   river_land_mask                        )
  missing_rivers = frac.gt.0. .and. .not.river_land_mask
  no_riv = 0.
  where (missing_rivers) no_riv = 1.
  if ( id_no_riv > 0 ) used = send_data( id_no_riv, no_riv, lnd%time )
  call land_transitions_init (id_lon, id_lat) 
  ! [8] initialize boundary data
  ! [8.1] allocate storage for the boundary data 
  call realloc_land2cplr ( land2cplr )
  call realloc_cplr2land ( cplr2land )
  ! [8.2] set the land mask to FALSE everywhere -- update_land_bc_fast
  ! will set it to true where necessary
  land2cplr%mask = .FALSE.
  land2cplr%tile_size = 0.0
  ! [8.3] get the current state of the land boundary for the coupler
  ce = first_elmt(lnd%tile_map,                  &
              is=lbound(cplr2land%t_flux,1), &
              js=lbound(cplr2land%t_flux,2)  )
  te = tail_elmt(lnd%tile_map)
  do while(ce /= te)
     ! calculate indices of the current tile in the input arrays;
     ! assume all the cplr2land components have the same lbounds
     call get_elmt_indices(ce,i,j,k)
     ! set this point coordinates as current for debug output
     call set_current_point(i,j,k)
     ! get pointer to current tile
     tile => current_tile(ce)
     ! advance enumerator to the next tile
     ce=next_elmt(ce)

     call update_land_bc_fast (tile, i,j,k, land2cplr, is_init=.true.)
  enddo

  ! [8.4] update topographic roughness scaling
  call update_land_bc_slow( land2cplr )

  ! mask error checking
  do j=lnd%js,lnd%je
  do i=lnd%is,lnd%ie
     if(frac(i,j)>0.neqv.ANY(land2cplr%mask(i,j,:))) then
        call error_mesg('land_model_init','masks are not equal',FATAL)
     endif
  enddo
  enddo

  ! [9] check the properties of co2 exchange with the atmosphere and set appropriate
  ! flags
  if (canopy_air_mass_for_tracers==0.and.lnd%ico2==NO_TRACER) then
     call error_mesg('land_model_init', &
          'canopy_air_mass_for_tracers is set to zero, and CO2 exchange with the atmosphere is not set up: '// &
          'canopy air CO2 concentration will not be updated',NOTE)
     update_cana_co2 = .FALSE.
  else
     update_cana_co2 = .TRUE.
  end if

  call mpp_clock_end(landInitClock)

end subroutine land_model_init


! ============================================================================
subroutine land_model_end (cplr2land, land2cplr)
  type(atmos_land_boundary_type), intent(inout) :: cplr2land
  type(land_data_type)          , intent(inout) :: land2cplr

  ! ---- local vars
  
  module_is_initialized = .FALSE.

  call error_mesg('land_model_end','writing NetCDF restart',NOTE)
  call land_model_restart()

  ! we still want to call the *_end procedures for component models, even
  ! if the number of tiles in this domain is zero, in case they are doing 
  ! something else besides saving the restart, of if they want to save
  ! restart anyway
  call land_transitions_end()
  call glac_end ()
  call lake_end ()
  call soil_end ()
  call snow_end ()
  call vegn_end ()
  call cana_end ()
  call topo_rough_end()
  call river_end()

  deallocate(frac)
  deallocate(river_land_mask, missing_rivers, no_riv)
  call dealloc_land2cplr(land2cplr, dealloc_discharges=.TRUE.)
  call dealloc_cplr2land(cplr2land)

  call tile_diag_end()

  ! deallocate tiles
  call land_data_end()

  ! finish up the land debugging diagnostics
  call land_debug_end
  
end subroutine land_model_end


! ============================================================================
! write land model restarts 
subroutine land_model_restart(timestamp)
  character(*), intent(in), optional :: timestamp ! timestamp to add to the file name
  
  ! ---- local vars
  integer :: tile_dim_length ! length of tile dimension in output files 
                             ! global max of number of tiles per gridcell 
  integer :: i,j,k
  integer :: unit ! netcdf id of the restart file
  character(256) :: timestamp_

  ! [1] count all land tiles and determine the length of tile dimension
  ! sufficient for the current domain
    tile_dim_length = 0
  do j = lnd%js, lnd%je
  do i = lnd%is, lnd%ie
     k = nitems(lnd%tile_map(i,j))
     tile_dim_length = max(tile_dim_length,k)
  enddo
  enddo

  ! [2] calculate the tile dimension length by taking the max across all domains
  call mpp_max(tile_dim_length)
   
  ! [3] create tile output file
  timestamp_=''
  if (present(timestamp)) then
     if(trim(timestamp)/='') timestamp_=trim(timestamp)//'.'
  endif
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp_)//'land.res.nc', &
       lnd%coord_glon, lnd%coord_glat, land_tile_exists, tile_dim_length)
     
  ! [4] write data fields
  ! write fractions and tile tags
  call write_tile_data_r0d_fptr(unit,'frac',land_frac_ptr,'fractional area of tile')
  call write_tile_data_i0d_fptr(unit,'glac',glac_tag_ptr,'tag of glacier tiles')
  call write_tile_data_i0d_fptr(unit,'lake',lake_tag_ptr,'tag of lake tiles')
  call write_tile_data_i0d_fptr(unit,'soil',soil_tag_ptr,'tag of soil tiles')
  call write_tile_data_i0d_fptr(unit,'vegn',vegn_tag_ptr,'tag of vegetation tiles')
  ! write the upward long-wave flux 
  call write_tile_data_r0d_fptr(unit,'lwup',land_lwup_ptr,'upward long-wave flux')
  ! write energy residuals
  call write_tile_data_r0d_fptr(unit,'e_res_1',land_e_res_1_ptr,&
       'energy residual in canopy air energy balance equation', 'W/m2')
  call write_tile_data_r0d_fptr(unit,'e_res_2',land_e_res_2_ptr,&
       'energy residual in canopy energy balance equation', 'W/m2')
  
  ! [5] close file
  __NF_ASRT__(nf_close(unit))

  ! [6] save component models' restarts
  call save_land_transitions_restart(timestamp_)
  call save_glac_restart(tile_dim_length,timestamp_)
  call save_lake_restart(tile_dim_length,timestamp_)
  call save_soil_restart(tile_dim_length,timestamp_)
  call save_snow_restart(tile_dim_length,timestamp_)
  call save_vegn_restart(tile_dim_length,timestamp_)
  call save_cana_restart(tile_dim_length,timestamp_)
  call save_river_restart(timestamp_)

end subroutine land_model_restart

! ============================================================================
subroutine land_cover_cold_start(lnd)
  type(land_state_type), intent(inout) :: lnd

  ! ---- local vars
  real, dimension(:,:,:), pointer :: &
       glac, soil, lake, vegn ! arrays of fractions for respective sub-models
  logical, dimension(lnd%ie-lnd%is+1,lnd%je-lnd%js+1) :: &
       land_mask, valid_data, invalid_data
  integer :: i,j,k,face
  integer :: i0,j0
  integer :: ps,pe ! boundaries of PE list for remapping
  type(horiz_remap_type) :: map

  ! calculate the global land mask
  land_mask = lnd%area > 0

  ! get the global maps of fractional covers for each of the sub-models
  glac=>glac_cover_cold_start(land_mask,lnd%lonb,lnd%latb)
  lake=>lake_cover_cold_start(land_mask,lnd%lonb,lnd%latb,lnd%domain)
  soil=>soil_cover_cold_start(land_mask,lnd%lonb,lnd%latb)
  vegn=>vegn_cover_cold_start(land_mask,lnd%lonb,lnd%latb)

  ! remove any input lake fraction in coastal cells
  where (frac.lt. 1.-gfrac_tol) lake(:,:,1) = 0.
  ! NOTE that the lake area in the coastal cells can be set to non-zero
  ! again by the "ground fraction reconciliation code" below. Strictly
  ! speaking the above line of code should be replaced with the section
  ! commented out with "!-zero" below, but we preserve the old way to avoid
  ! backward incompatibility with older runs. This needs updating in the
  ! future when the decision about what to do with lakes in coastal cells is
  ! made.

  ! reconcile ground fractions with the land mask within compute domain
  valid_data = land_mask.and.(sum(glac,3)+sum(lake,3)+sum(soil,3)>0)
  invalid_data = land_mask.and..not.valid_data

  call get_watch_point(i,j,k,face)
  if (face==lnd%face.and.(lnd%is<=i.and.i<=lnd%ie).and.(lnd%js<=j.and.j<=lnd%je)) then
     write(*,*)'###### land_cover_cold_start: input data #####'
     write(*,'(99(a,i4.2,x))')'i=',i,'j=',j,'face=',lnd%face
     write(*,'(99(a,g,x))')'lon=',lnd%lon(i,j)*180/PI,'lat=',lnd%lat(i,j)*180/PI
     ! calculate local compute domain indices; we assume glac,lake,soil,vegn all
     ! have the same lbounds
     i0 = i-lnd%is+lbound(glac,1); j0 = j-lnd%js+lbound(glac,2)
     __DEBUG2__(lnd%is,lnd%js)
     write(*,'(a,99(a,i4.2,x))')'local indices:','i0=',i0,'j0=',j0
     __DEBUG3__(frac(i,j),land_mask(i0,j0),valid_data(i0,j0))
     __DEBUG1__(glac(i0,j0,:))
     __DEBUG1__(lake(i0,j0,:))
     __DEBUG1__(soil(i0,j0,:))
     __DEBUG1__(vegn(i0,j0,:))
  endif

  if (trim(nearest_point_search)=='global') then
     ps=0 ; pe=size(lnd%pelist)-1
  else if (trim(nearest_point_search)=='face') then
     ! this assumes that the number of PEs is divisible by the number of
     ! mosaic faces. lnd%pelist starts with 0
     ps = size(lnd%pelist)/lnd%nfaces*(lnd%face-1)
     pe = size(lnd%pelist)/lnd%nfaces*lnd%face - 1
  else
     call error_mesg('land_cover_cold_start',&
          'option nearest_point_search="'//trim(nearest_point_search)//&
          '" is illegal, use "global" or "face"',&
          FATAL)
  endif
  call horiz_remap_new(invalid_data,valid_data,lnd%lon,lnd%lat,lnd%domain,&
          lnd%pelist(ps:pe),map)
  if (print_remapping) call horiz_remap_print(map,'land cover remap:')
  call horiz_remap(map,lnd%domain,glac)
  call horiz_remap(map,lnd%domain,lake)
  call horiz_remap(map,lnd%domain,soil)
  call horiz_remap_del(map)

!-zero  ! remove any input lake fraction in coastal cells
!-zero  do j = lnd%js,lnd%je
!-zero  do i = lnd%is,lnd%ie
!-zero     call set_current_point(i,j,1)
!-zero     if (frac(i,j) < 1-gfrac_tol) then
!-zero        lake(i,j,:) = 0.0
!-zero        if(is_watch_point())then
!-zero           write(*,*)'###### land_cover_cold_start: lake fraction is set to zero #####'
!-zero        endif
!-zero     endif
!-zero  enddo
!-zero  enddo
  
  ! reconcile vegetation fractions with the land mask within compute domain
  valid_data = sum(vegn,3) > 0
  invalid_data = .FALSE.
  do j = 1,size(land_mask,2)
  do i = 1,size(land_mask,1)
     if(.not.land_mask(i,j)) cycle ! skip ocean points
     if(valid_data(i,j)) cycle ! don't need to do anything with valid points
     if(sum(glac(i,j,:))+sum(lake(i,j,:))>=1) &
          cycle                ! skip points fully covered by glaciers or lakes
     invalid_data(i,j)=.TRUE.
  enddo
  enddo
  call horiz_remap_new(invalid_data,valid_data,lnd%lon,lnd%lat,lnd%domain,&
       lnd%pelist(ps:pe),map)
  if (print_remapping) call horiz_remap_print(map,'vegetation cover remap:')
  call horiz_remap(map,lnd%domain,vegn)
  call horiz_remap_del(map)
  
  ! create tiles
  do j = 1,size(land_mask,2)
  do i = 1,size(land_mask,1)
     if(.not.land_mask(i,j)) cycle ! skip ocean points
     call set_current_point(i+lnd%is-1,j+lnd%js-1,1)
     call land_cover_cold_start_0d &
          (lnd%tile_map(i+lnd%is-1,j+lnd%js-1),glac(i,j,:),lake(i,j,:),soil(i,j,:),vegn(i,j,:))
     if(nitems(lnd%tile_map(i+lnd%is-1,j+lnd%js-1))==0) then
        call error_mesg('land_cover_cold_start',&
             'No tiles were created for a valid land point', FATAL)
     endif
  enddo
  enddo

  deallocate(glac,lake,soil,vegn)
  
end subroutine land_cover_cold_start

! ============================================================================
subroutine land_cover_cold_start_0d (set,glac0,lake0,soil0,vegn0)
  type(land_tile_list_type), intent(inout) :: set 
  real, dimension(:)       , intent(in) :: &
       glac0,lake0,soil0,vegn0 ! fractions of area

  ! ---- local vars
  real :: glac(size(glac0(:))), lake(size(lake0(:))), &
          soil(size(soil0(:))), vegn(size(vegn0(:)))
  type(land_tile_type), pointer :: tile
  integer :: i,j
  real :: factor ! normalizing factor for the tile areas
  real :: frac
  type(land_tile_enum_type) :: first_non_vegn ! position of first non-vegetated tile in the list

  glac = glac0; lake = lake0; soil = soil0; vegn = vegn0
  if (sum(glac)>1) &
       glac=glac/sum(glac)
  if (sum(lake)+sum(glac)>1)&
       lake = lake*(1-sum(glac))/sum(lake)
  if (sum(lake)<min_sum_lake_frac) lake=0
  if (sum(soil)+sum(glac)+sum(lake)>1)&
       soil = soil*(1-sum(lake)-sum(glac))/sum(soil)
  ! make sure that the sum of the fractions of the soil, lake, and glaciers are 
  ! either one or zero
  factor = sum(soil)+sum(glac)+sum(lake)
  if(factor>0)then
     glac = glac/factor
     lake = lake/factor
     soil = soil/factor
  endif
  if(is_watch_point()) then
     write(*,*)'#### land_cover_cold_start_0d input data ####'
     __DEBUG1__(glac0)
     __DEBUG1__(lake0)
     __DEBUG1__(soil0)
     __DEBUG1__(vegn0)
     __DEBUG1__(factor)
     write(*,*)'#### land_cover_cold_start_0d renormlaized fractions ####'
     __DEBUG1__(glac)
     __DEBUG1__(lake)
     __DEBUG1__(soil)
     __DEBUG1__(vegn)
  endif

  do i = 1,size(glac)
     if (glac(i)>0) then
        tile => new_land_tile(frac=glac(i),glac=i)
        call insert(tile,set)
        if(is_watch_point()) then
           write(*,*)'created glac tile: frac=',glac(i),' tag=',i
        endif
     endif
  enddo
  do i = 1,size(lake)
     if (lake(i)>0) then
        tile => new_land_tile(frac=lake(i),lake=i)
        call insert(tile,set)
        if(is_watch_point()) then
           write(*,*)'created lake tile: frac=',lake(i),' tag=',i
        endif
     endif
  enddo

  factor = sum(soil)*sum(vegn)
  if (factor/=0) factor = 1/factor
  factor = factor*(1-sum(glac)-sum(lake))
  ! vegetation tiles, if any, are inserted in front of non-vegetated tiles;
  ! this really doesn't matter except for the static vegetation override
  ! case with the data saved by lm3v -- there the vegetation tiles are
  ! in front, so it works more consistently where lad2 has more than 
  ! one tile (e.g. glac/soil or lake/soil), if lad2 vegetation tiles are 
  ! also in front of the list. 
  first_non_vegn=first_elmt(set)
  do i = 1,size(soil)
  do j = 1,size(vegn)
     frac = soil(i)*vegn(j)*factor
     if(frac>0) then
        tile  => new_land_tile(frac=frac,soil=i,vegn=j)
        call insert(tile,first_non_vegn)
        if(is_watch_point()) then
           write(*,*)'created soil tile: frac=', frac, ' soil tag=',i, ' veg tag=',j
        endif
     endif
  enddo
  enddo

end subroutine land_cover_cold_start_0d

! ============================================================================
! reads the land restart file and restores the tiling structure from this file
subroutine land_cover_warm_start ( restart_file_name, lnd )
  character(len=*), intent(in) :: restart_file_name
  type(land_state_type), intent(inout) :: lnd
  
  integer, parameter :: INPUT_BUF_SIZE = 1024
  
  ! ---- local vars
  integer, allocatable :: idx(:) ! compressed tile index
  integer, allocatable :: glac(:), lake(:), soil(:), snow(:), cana(:), vegn(:) ! tile tags
  real,    allocatable :: frac(:) ! fraction of land covered by tile
  integer :: ncid ! unit number of the input file
  integer :: ntiles    ! total number of land tiles in the input file
  integer :: bufsize   ! size of the input buffer
  integer :: dimids(1) ! id of tile dimension
  character(NF_MAX_NAME) :: tile_dim_name ! name of the tile dimension and respective variable
  integer :: i,j,k,it
  type(land_tile_type), pointer :: tile;
  integer :: start, count ! slab for reading
  ! netcdf variable IDs
  integer :: id_idx, id_frac, id_glac, id_lake, id_soil, id_vegn
  
  __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,ncid))
  ! allocate the input data
  __NF_ASRT__(nfu_inq_var(ncid,'frac',id=id_frac,varsize=ntiles,dimids=dimids))
   ! allocate input buffers for compression index and the variable
  bufsize=min(INPUT_BUF_SIZE,ntiles)
  allocate(idx (bufsize), glac(bufsize), lake(bufsize), soil(bufsize), &
           snow(bufsize), cana(bufsize), vegn(bufsize), frac(bufsize)  )
  ! get the name of the fist (and only) dimension of the variable 'frac' -- this
  ! is supposed to be the compressed dimension, and associated variable will
  ! hold the compressed indices
  __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),name=tile_dim_name))
  __NF_ASRT__(nfu_inq_var(ncid,tile_dim_name,id=id_idx))
  ! get the IDs of the varables to read
  __NF_ASRT__(nfu_inq_var(ncid,'glac',id=id_glac))
  __NF_ASRT__(nfu_inq_var(ncid,'lake',id=id_lake))
  __NF_ASRT__(nfu_inq_var(ncid,'soil',id=id_soil))
  __NF_ASRT__(nfu_inq_var(ncid,'vegn',id=id_vegn))
  
  do start = 1,ntiles,bufsize
    count = min(bufsize,ntiles-start+1)
    ! read the compressed tile indices
    __NF_ASRT__(nf_get_vara_int(ncid,id_idx,(/start/),(/count/),idx))
    ! read input data -- fractions and tags
    __NF_ASRT__(nf_get_vara_double(ncid,id_frac,(/start/),(/count/),frac))
    __NF_ASRT__(nf_get_vara_int(ncid,id_glac,(/start/),(/count/),glac))
    __NF_ASRT__(nf_get_vara_int(ncid,id_lake,(/start/),(/count/),lake))
    __NF_ASRT__(nf_get_vara_int(ncid,id_soil,(/start/),(/count/),soil))
    __NF_ASRT__(nf_get_vara_int(ncid,id_vegn,(/start/),(/count/),vegn))
  
    ! create tiles
    do it = 1,count
       k = idx(it)
       if (k<0) cycle ! skip negative indices
       i = modulo(k,lnd%nlon)+1; k = k/lnd%nlon
       j = modulo(k,lnd%nlat)+1; k = k/lnd%nlat
       k = k + 1
       if (i<lnd%is.or.i>lnd%ie) cycle
       if (j<lnd%js.or.j>lnd%je) cycle
       ! the size of the tile set at the point (i,j) must be equal to k
       tile=>new_land_tile(frac=frac(it),&
                glac=glac(it),lake=lake(it),soil=soil(it),vegn=vegn(it))
       call insert(tile,lnd%tile_map(i,j))
    enddo
  enddo
  __NF_ASRT__(nf_close(ncid))
  deallocate(idx, glac, lake, soil, snow, cana, vegn, frac)
end subroutine


! ============================================================================
subroutine update_land_model_fast ( cplr2land, land2cplr )
  type(atmos_land_boundary_type), intent(in)    :: cplr2land
  type(land_data_type)          , intent(inout) :: land2cplr

  ! ---- local constants
  ! indices of variables and equations for implicit time stepping solution :
  integer, parameter :: iqc=1, iTc=2, iTv=3, iwl=4, iwf=5

  ! ---- local vars 
  type(land_tile_enum_type) :: ce, te
  type(land_tile_type), pointer :: tile
  
  real :: A(5,5),B0(5),B1(5),B2(5) ! implicit equation matrix and right-hand side vectors
  real :: A00(5,5),B10(5),B00(5) ! copy of the above, only for debugging
  integer :: indx(5) ! permutation vector
  ! linearization coefficients of various fluxes between components of land
  ! surface scheme
  real :: &
       G0,    DGDTg,  &  ! ground heat flux 
       Ha0,   DHaDTc, &  ! sensible heat flux from the canopy air to the atmosphere 
       Ea0,   DEaDqc, &  ! water vapor flux from canopy air to the atmosphere
       fco2_0,Dfco2Dq,&  ! co2 flux from canopy air to the atmosphere
       Hv0,   DHvDTv,   DHvDTc, & ! sens heat flux from vegetation
       Et0,   DEtDTv,   DEtDqc,   DEtDwl,   DEtDwf,  & ! transpiration
       Eli0,  DEliDTv,  DEliDqc,  DEliDwl,  DEliDwf, & ! evaporation of intercepted water
       Esi0,  DEsiDTv,  DEsiDqc,  DEsiDwl,  DEsiDwf, & ! sublimation of intercepted snow
       Hg0,   DHgDTg,   DHgDTc, & ! linearization of the sensible heat flux from ground
       Eg0,   DEgDTg,   DEgDqc, DEgDpsig, & ! linearization of evaporation from ground
       flwv0,  DflwvDTg,  DflwvDTv,& ! linearization of net LW radiation to the canopy
       flwg0,  DflwgDTg,  DflwgDTv,& ! linearization of net LW radiation to the canopy
       vegn_drip_l, vegn_drip_s, & ! drip rate of water and snow, respectively, kg/(m2 s)
       vegn_lai
  
  ! increments of respective variables over time step, results of the implicit
  ! time step:
  real :: delta_qc, delta_Tc, delta_Tv, delta_wl, delta_ws, delta_Tg, delta_psig
  real :: flwg ! updated value of long-wave ground energy balance
  real :: vegn_emis_lw, surf_emis_lw ! emissivities of ground and surface
  real :: vegn_emsn,    surf_emsn    ! emission by vegetation and surface, respectively
  real :: denom ! denominator in the LW radiative balance calculations
  real :: sum0, sum1

  real :: &
       grnd_T, gT, & ! ground temperature and its value used for sensible heat advection
       vegn_T, vT, & ! vegetation (canopy) temperature
       cana_T, cT, & ! canopy air temperature
       evap_T, eT, & ! temperature assigned to vapor going between land and atmosphere
       soil_uptake_T, & ! average temperature of water taken up by the vegetation
       vegn_Wl,  vegn_Ws, & ! water and snow mass of the canopy
       vegn_ifrac, & ! intercepted fraction of liquid or frozen precipitation
       vegn_hcap,      & ! vegetation heat capacity, including intercepted water and snow
       vegn_fco2, & ! co2 flux from the vegetation, kg CO2/(m2 s)
       hlv_Tv, hlv_Tu, & ! latent heat of vaporization at vegn and uptake temperatures, respectively 
       hls_Tv, &         ! latent heat of sublimation at vegn temperature
       grnd_rh,        & ! explicit relative humidity at ground surface
       grnd_rh_psi,    & ! psi derivative of relative humidity at ground surface
       grnd_liq, grnd_ice, grnd_subl, &
       grnd_tf, &  ! temperature of freezing on the ground
       grnd_latent, &
       grnd_flux, &
       grnd_E_min, &
       grnd_E_max, &
       soil_E_min, &
       soil_E_max, &
       soil_beta, &
       RSv(NBANDS), & ! net short-wave radiation balance of the canopy, W/m2
       con_g_h, con_g_v, & ! turbulent cond. between ground and canopy air, for heat and vapor respectively
       snow_area, &
       cana_q, & ! specific humidity of canopy air
       cana_co2, & ! co2 moist mixing ratio in canopy air, kg CO2/kg wet air
       cana_co2_mol, & ! co2 dry mixing ratio in canopy air, mol CO2/mol dry air
       fswg, evapg, sensg, &
       subs_G, subs_G2, Mg_imp, snow_G_Z, snow_G_TZ, &
       snow_avrg_T, delta_T_snow,  & ! vertically-average snow temperature and it's change due to s
       vegn_ovfl_l,  vegn_ovfl_s,  & ! overflow of liquid and solid water from the canopy
       vegn_ovfl_Hl, vegn_ovfl_Hs, & ! heat flux from canopy due to overflow
       delta_fprec, & ! correction of below-canopy solid precip in case it's average T > tfreeze 

       ISa_dn_dir(NBANDS), & ! downward direct sw radiation at the top of the canopy
       ISa_dn_dif(NBANDS), & ! downward diffuse sw radiation at the top of the canopy
       ILa_dn,             & ! downward lw radiation at the top of the canopy
       hprec,              & ! sensible heat flux carried by precipitation
       hevap,              & ! sensible heat flux carried by total evapotranspiration
       land_evap,          & ! total vapor flux from land to atmosphere
       land_sens,          & ! turbulent sensible heat flux from land to atmosphere
       vegn_flw,vegn_sens,snow_sens,snow_levap,snow_fevap,snow_melt,&
       snow_lprec, snow_hlprec,snow_lrunf, precip_s,vegn_levap,vegn_fevap,vegn_uptk,&
       vegn_fsw, vegn_melt,vegn_lprec,vegn_fprec,vegn_hlprec,vegn_hfprec,vegn_LMASS,&
       vegn_FMASS,vegn_HEAT, precip_l,atmos_T,precip_T,pT,snow_fsw,snow_flw,snow_frunf,snow_hlrunf,&
       snow_hfrunf, snow_LMASS,snow_FMASS,snow_HEAT,subs_fsw,subs_flw,subs_sens,&
       subs_DT, subs_M_imp, subs_evap, snow_Tbot, snow_Cbot, snow_C, subs_levap,&
       subs_fevap,subs_melt,subs_lrunf,subs_hlrunf,subs_LMASS,subs_FMASS,&
       glac_LMASS, glac_FMASS, glac_HEAT, lake_LMASS, lake_FMASS, lake_HEAT,  &
       soil_LMASS, soil_FMASS, soil_HEAT,  &
       subs_HEAT,subs_Ttop,subs_Ctop, subs_subl, new_T, cana_VMASS, cana_HEAT
  real :: soil_water_supply ! supply of water to roots, per unit active root biomass, kg/m2
  real :: snow_T, snow_rh, snow_liq, snow_ice, snow_subl
  integer :: i, j, k, i_species
  integer :: ii, jj ! indices for debug output
  integer :: ierr
  logical :: conserve_glacier_mass, snow_active
  real :: subs_z0m, subs_z0s, snow_z0m, snow_z0s, grnd_z0s
  real, dimension(lnd%is:lnd%ie,lnd%js:lnd%je) :: &
       runoff,           & ! total (liquid+snow) runoff accumulated over tiles in cell
       runoff_snow,      & ! runoff snow accumulated over tiles in cell
       runoff_heat,      & ! runoff heat accumulated over tiles in cell
       heat_frac_liq,    & ! fraction of runoff heat in liquid
       discharge_l,      & ! discharge of liquid water to ocean
       discharge_sink      ! container to collect small/negative values for later accounting
  real, dimension(lnd%is:lnd%ie,lnd%js:lnd%je,num_species) :: &
       runoff_c,         & ! runoff of tracers accumulated over tiles in cell
       discharge_c         ! discharge of tracers to ocean
  logical :: used          ! return value of send_data diagnostics routine

  ! variables for data override
  real, allocatable :: phot_co2_data(:,:)  ! buffer for data
  logical           :: phot_co2_overridden ! flag indicating successfull override
  integer :: is,ie,js,je ! horizontal bounds of the override buffer

  ! start clocks
  call mpp_clock_begin(landClock)
  call mpp_clock_begin(landFastClock)

  ! to avoid output of static vegetation after the transitions worked and
  ! changed the tiling structure, static vegetation output is done here.
  call write_static_vegn()

  ! clear the runoff values, for accumulation over the tiles
  runoff = 0 ; runoff_snow = 0 ; runoff_heat = 0 ; runoff_c = 0

  ! override data at the beginning of the time step
  is=lbound(cplr2land%t_flux,1) ; ie = is+size(cplr2land%t_flux,1)-1
  js=lbound(cplr2land%t_flux,2) ; je = js+size(cplr2land%t_flux,2)-1
  allocate(phot_co2_data(is:ie,js:je))
  call data_override('LND','phot_co2',phot_co2_data,lnd%time, &
       override=phot_co2_overridden)

  ! initialize current tile enumerator
  ce = first_elmt(lnd%tile_map, is=is, js=js)
  ! get the end marker (end tile enumerator)
  te = tail_elmt(lnd%tile_map)
  ! main tile loop
  do while(ce /= te)
     ! calculate indices of the current tile in the input arrays;
     ! assume all the cplr2land components have the same lbounds
     call get_elmt_indices(ce,i,j,k)
     ! set this point coordinates as current for debug output
     call set_current_point(i,j,k)
     ! get pointer to current tile
     tile => current_tile(ce)
     ! advance enumerator to the next tile
     ce=next_elmt(ce)

     ! get data from atmosphere
     precip_l = cplr2land%lprec(i,j,k)
     precip_s = cplr2land%fprec(i,j,k)
     atmos_T  = cplr2land%tprec(i,j,k)
     Ha0    =  cplr2land%t_flux(i,j,k)
     DHaDTc =  cplr2land%dhdt  (i,j,k)
     Ea0    = cplr2land%tr_flux(i,j,k, lnd%isphum)
     DEaDqc = cplr2land%dfdtr  (i,j,k, lnd%isphum)
     if (lnd%ico2/=NO_TRACER) then
        fco2_0  = cplr2land%tr_flux(i,j,k, lnd%ico2)
        Dfco2Dq = cplr2land%dfdtr  (i,j,k, lnd%ico2)
     else
        fco2_0  = 0
        Dfco2Dq = 0
     endif
     ISa_dn_dir(BAND_VIS) = cplr2land%sw_flux_down_vis_dir(i,j,k)
     ISa_dn_dir(BAND_NIR) = cplr2land%sw_flux_down_total_dir(i,j,k)&
                           -cplr2land%sw_flux_down_vis_dir(i,j,k)
     ISa_dn_dif(BAND_VIS) = cplr2land%sw_flux_down_vis_dif(i,j,k)
     ISa_dn_dif(BAND_NIR) = cplr2land%sw_flux_down_total_dif(i,j,k)&
                           -cplr2land%sw_flux_down_vis_dif(i,j,k)
     ILa_dn               = cplr2land%lwdn_flux(i,j,k)

     soil_uptake_T = tfreeze ! just to avoid using un-initialized values
     soil_water_supply = 0.0
     if (associated(tile%glac)) then
        call glac_step_1 ( tile%glac, &
             grnd_T, grnd_rh, grnd_liq, grnd_ice, grnd_subl, grnd_tf, &
             snow_G_Z, snow_G_TZ, conserve_glacier_mass  )
        grnd_E_min = -HUGE(grnd_E_min)
        grnd_E_max =  HUGE(grnd_E_max)
        grnd_rh_psi = 0
     else if (associated(tile%lake)) then
        call lake_step_1 ( cplr2land%ustar(i,j,k), cplr2land%p_surf(i,j,k), &
             lnd%lat(i,j), tile%lake, &
             grnd_T, grnd_rh, grnd_liq, grnd_ice, grnd_subl, grnd_tf, &
             snow_G_Z, snow_G_TZ)
        grnd_E_min = -HUGE(grnd_E_min)
        grnd_E_max =  HUGE(grnd_E_max)
        grnd_rh_psi = 0
     else if (associated(tile%soil)) then
        call soil_step_1 ( tile%soil, tile%vegn, tile%diag, &
             grnd_T, soil_uptake_T, soil_beta, soil_water_supply, soil_E_min, soil_E_max, &
             grnd_rh, grnd_rh_psi, grnd_liq, grnd_ice, grnd_subl, grnd_tf, &
             snow_G_Z, snow_G_TZ)
        grnd_E_min = soil_E_min
        grnd_E_max = soil_E_max
        grnd_liq = 0 ! sorry, but solver cannot handle implicit melt anymore
        grnd_ice = 0 ! sorry, but solver cannot handle implicit melt anymore
                     ! no big loss, it's just the surface layer anyway
     else
        call get_current_point(face=ii)
        call error_mesg('update_land_model_fast','none of the surface tiles exist at ('//&
             trim(string(i))//','//trim(string(j))//','//trim(string(k))//&
             ', face='//trim(string(ii))//')',FATAL)
     endif

     subs_subl = grnd_subl

     call snow_step_1 ( tile%snow, snow_G_Z, snow_G_TZ, &
          snow_active, snow_T, snow_rh, snow_liq, snow_ice, &
          snow_subl, snow_area, G0, DGDTg )
     if (snow_active) then
        grnd_T    = snow_T;   grnd_rh   = snow_rh;   grnd_liq  = snow_liq
        grnd_rh_psi = 0
        grnd_ice  = snow_ice; grnd_subl = snow_subl; grnd_tf   = tfreeze
        grnd_E_min = -HUGE(grnd_E_min)
        grnd_E_max =  HUGE(grnd_E_max)
     endif

     call cana_state(tile%cana, cana_T, cana_q, cana_co2)

     if (associated(tile%vegn)) then
     ! Calculate net short-wave radiation input to the vegetation
        RSv    = tile%Sv_dir*ISa_dn_dir + tile%Sv_dif*ISa_dn_dif
        call soil_diffusion(tile%soil, subs_z0s, subs_z0m)
        call snow_diffusion(tile%snow, snow_z0s, snow_z0m)
        grnd_z0s = exp( (1-snow_area)*log(subs_z0s) + snow_area*log(snow_z0s))
        
        ! cana_co2 is moist mass mixing ratio [kg CO2/kg wet air], convert it to dry
        ! volumetric mixing ratio [mol CO2/mol dry air] 
        cana_co2_mol = cana_co2*mol_air/mol_CO2/(1-cana_q)
        if (phot_co2_overridden) cana_co2_mol = phot_co2_data(i,j)
        call vegn_step_1 ( tile%vegn, tile%diag, &
           cplr2land%p_surf(i,j,k), &
           cplr2land%ustar (i,j,k), &
           cplr2land%drag_q(i,j,k), &
           ISa_dn_dir+ISa_dn_dif, RSv, precip_l, precip_s, &
           tile%land_d, tile%land_z0s, tile%land_z0m, grnd_z0s, & 
           soil_beta, soil_water_supply,&
           cana_T, cana_q, cana_co2_mol, &
           ! output
           con_g_h, con_g_v, &
           vegn_T, vegn_Wl, vegn_Ws, & ! temperature, water and snow mass on the canopy
           vegn_ifrac, vegn_lai, &
           vegn_drip_l, vegn_drip_s,& 
           vegn_hcap, & ! total vegetation heat capacity (including intercepted water/snow)
           Hv0,   DHvDTv,   DHvDTc,            & 
           Et0,   DEtDTv,   DEtDqc,   DEtDwl,   DEtDwf,  & 
           Eli0,  DEliDTv,  DEliDqc,  DEliDwl,  DEliDwf, & 
           Esi0,  DEsiDTv,  DEsiDqc,  DEsiDwl,  DEsiDwf  ) 
     else
        RSv    = 0
        con_g_h = con_fac_large ; con_g_v = con_fac_large
        if(associated(tile%glac).and.conserve_glacier_mass.and..not.snow_active) &
             con_g_v = con_fac_small
        vegn_T  = cana_T ; vegn_Wl = 0 ; vegn_Ws = 0
        vegn_ifrac  = 0 ; vegn_lai    = 0
        vegn_drip_l = 0 ; vegn_drip_s = 0
        vegn_hcap = 1.0
        Hv0 =0;  DHvDTv =0;  DHvDTc=0;
        Et0 =0;  DEtDTv =0;  DEtDqc=0;   DEtDwl=0;   DEtDwf=0
        Eli0=0;  DEliDTv=0;  DEliDqc=0;  DEliDwl=0;  DEliDwf=0 
        Esi0=0;  DEsiDTv=0;  DEsiDqc=0;  DEsiDwl=0;  DEsiDwf=0
     endif
     ! calculate net shortwave for ground and canopy
     fswg     = SUM(tile%Sg_dir*ISa_dn_dir + tile%Sg_dif*ISa_dn_dif)
     vegn_fsw = SUM(RSv)
     
     call cana_step_1 (tile%cana, cplr2land%p_surf(i,j,k), con_g_h, con_g_v,   &
          grnd_t, grnd_rh, grnd_rh_psi, &
          Hg0,  DHgDTg, DHgDTc, Eg0, DEgDTg, DEgDqc, DEgDpsig)

! [X.X] using long-wave optical properties, calculate the explicit long-wave 
!       radiative balances and their derivatives w.r.t. temperatures
     vegn_emis_lw = 1 - tile%vegn_refl_lw - tile%vegn_tran_lw
     surf_emis_lw = 1 - tile%surf_refl_lw

     denom = 1-tile%vegn_refl_lw*tile%surf_refl_lw

     vegn_emsn = vegn_emis_lw * stefan * vegn_T**4
     surf_emsn = surf_emis_lw * stefan * grnd_T**4

     flwv0 = ILa_dn * vegn_emis_lw*(1+tile%vegn_refl_lw*tile%surf_refl_lw/denom) &
          + vegn_emsn * (tile%surf_refl_lw*vegn_emis_lw/denom-2) &
          + surf_emsn * vegn_emis_lw/denom
     DflwvDTg = vegn_emis_lw/denom                      * surf_emis_lw * stefan * 4 * grnd_T**3
     DflwvDTv = (tile%surf_refl_lw*vegn_emis_lw/denom-2)* vegn_emis_lw * stefan * 4 * vegn_T**3

     flwg0 = (ILa_dn*tile%vegn_tran_lw + vegn_emsn)*(1-tile%surf_refl_lw)/denom &
          - surf_emsn*(1-tile%vegn_refl_lw)/denom
     DflwgDTg = -(1-tile%vegn_refl_lw)/denom * surf_emis_lw * stefan * 4 * grnd_T**3
     DflwgDTv =  (1-tile%surf_refl_lw)/denom * vegn_emis_lw * stefan * 4 * vegn_T**3

! [X.0] calculate the latent heats of vaporization at appropriate temperatures
     if (use_tfreeze_in_grnd_latent) then
         grnd_latent = hlv + hlf*grnd_subl
       else
         grnd_latent = hlv + (cpw-clw)*(grnd_T-tfreeze) &
                    + (hlf + (clw-csw)*(grnd_T-tfreeze)) * grnd_subl
       endif
     if (use_atmos_T_for_precip_T) then
         precip_T = atmos_T
       else
         precip_T = cana_T
       endif
     if (use_atmos_T_for_evap_T) then
         evap_T = atmos_T
       else
         evap_T = cana_T
       endif
     if (use_old_conservation_equations) then
         hlv_Tv = hlv       - (cpw-clw)*tfreeze + cpw*vegn_T
         hls_Tv = hlv + hlf - (cpw-csw)*tfreeze + cpw*vegn_T
         hlv_Tu = hlv       - (cpw-clw)*tfreeze + cpw*vegn_T - clw*soil_uptake_T
         pT = precip_T
         cT = cana_T
         eT = evap_T
         gT = grnd_T
         vT = vegn_T
       else
         hlv_Tv = hlv    + cpw*(vegn_T-tfreeze)
         hls_Tv = hlf    + hlv_Tv
         hlv_Tu = hlv_Tv - clw*(soil_uptake_T-tfreeze)
         pT = precip_T-tfreeze
         cT = cana_T-tfreeze
         eT = evap_T-tfreeze
         gT = grnd_T-tfreeze
         vT = vegn_T-tfreeze
       endif
     if(is_watch_point()) then
        write(*,*)'#### input data for the matrix ####'
        __DEBUG1__(delta_time)
        __DEBUG4__(vegn_T,vT,vegn_Wl,vegn_Ws)
        __DEBUG3__(grnd_T,gT,grnd_rh)
        __DEBUG3__(cana_T,cT,cana_q)
        __DEBUG2__(evap_T,eT)
        __DEBUG2__(vegn_emis_lw,surf_emis_lw)
        __DEBUG2__(vegn_emsn,surf_emsn)
        __DEBUG4__(precip_l, vegn_drip_l, pT, precip_T)
        __DEBUG2__(precip_s, vegn_drip_s)
        __DEBUG2__(vegn_ifrac, vegn_lai)
        __DEBUG1__(ILa_dn)
        __DEBUG2__(ISa_dn_dir(1),ISa_dn_dir(2))
        __DEBUG2__(ISa_dn_dif(1),ISa_dn_dif(2))
        __DEBUG2__(fswg, vegn_fsw)
        __DEBUG1__(vegn_hcap)
        __DEBUG3__(hlv_Tv, hlv_Tu, hls_Tv)
        __DEBUG2__(G0, DGDTg)
        __DEBUG2__(Ha0, DHaDTc)
        __DEBUG2__(Ea0, DEaDqc)
        __DEBUG3__(Hv0, DHvDTv, DHvDTc)
        __DEBUG5__(Et0,  DEtDTv,  DEtDqc,  DEtDwl,  DEtDwf)
        __DEBUG5__(Eli0, DEliDTv, DEliDqc, DEliDwl, DEliDwf)
        __DEBUG5__(Esi0, DEsiDTv, DEsiDqc, DEsiDwl, DEsiDwf)
        __DEBUG3__(Hg0, DHgDTg, DHgDTc)
        __DEBUG3__(Eg0, DEgDTg, DEgDqc)
        __DEBUG3__(flwv0, DflwvDTg, DflwvDTv)
        __DEBUG3__(flwg0, DflwgDTg, DflwgDTv)
        __DEBUG2__(tile%e_res_1,tile%e_res_2)
     endif

! [X.1] form the system of equations for implicit scheme, such that A*X = B1*delta_Tg+B2*delta_psig+B0
! [X.1.1] equation of canopy air mass balance
     A(iqc,iqc) = canopy_air_mass/delta_time-DEtDqc-DEliDqc-DEsiDqc-DEgDqc+DEaDqc
     A(iqc,iTc) = 0
     A(iqc,iTv) = -DEtDTv-DEliDTv-DEsiDTv
     A(iqc,iwl) = -DEtDwl-DEliDwl-DEsiDwl
     A(iqc,iwf) = -DEtDwf-DEliDwf-DEsiDwf
     B0(iqc)  = Esi0+Eli0+Et0+Eg0-Ea0
     B1(iqc)  = DEgDTg
     B2(iqc)  = DEgDpsig
! [X.1.2] equation of canopy air energy balance
#ifdef USE_DRY_CANA_MASS
     A(iTc,iqc) = canopy_air_mass*cpw*cT/delta_time &
#else
     A(iTc,iqc) = canopy_air_mass*(cpw-cp_air)*cT/delta_time &
#endif
          - cpw*vT*(DEtDqc+DEliDqc+DEsiDqc) - cpw*gT*DEgDqc + cpw*eT*DEaDqc
#ifdef USE_DRY_CANA_MASS
     A(iTc,iTc) = canopy_air_mass*cp_air/delta_time-DHvDTc-DHgDTc+DHaDTc
#else
     A(iTc,iTc) = canopy_air_mass*(cp_air+cana_q*(cpw-cp_air))/delta_time-DHvDTc-DHgDTc+DHaDTc
#endif
     A(iTc,iTv) = -DHvDTv-cpw*vT*(DEtDTv+DEliDTv+DEsiDTv)
     A(iTc,iwl) =        -cpw*vT*(DEtDwl+DEliDwl+DEsiDwl)
     A(iTc,iwf) =        -cpw*vT*(DEtDwf+DEliDwf+DEsiDwf)
     B0(iTc)  = Hv0 + Hg0 - Ha0 + cpw*(vT*(Et0+Eli0+Esi0)+gT*Eg0-eT*Ea0) - tile%e_res_1
     B1(iTc)  = DHgDTg + cpw*gT*DEgDTg
     B2(iTc)  =          cpw*gT*DEgDpsig
! [X.1.3] equation of canopy energy balance
     A(iTv,iqc) = hlv_Tu*DEtDqc + hlv_Tv*DEliDqc + hls_Tv*DEsiDqc
     A(iTv,iTc) = DHvDTc
     A(iTv,iTv) = vegn_hcap/delta_time-DflwvDTv + DHvDTv + &
          hlv_Tu*DEtDTv + hlv_Tv*DEliDTv + hls_Tv*DEsiDTv + clw*vegn_drip_l + csw*vegn_drip_s
     A(iTv,iwl) = clw*vT/delta_time + hlv_Tu*DEtDwl + hlv_Tv*DEliDwl + hls_Tv*DEsiDwl
     A(iTv,iwf) = csw*vT/delta_time + hlv_Tu*DEtDwf + hlv_Tv*DEliDwf + hls_Tv*DEsiDwf
     B0(iTv)  = vegn_fsw + flwv0 - Hv0 - hlv_Tu*Et0 - Hlv_Tv*Eli0 - hls_Tv*Esi0 &
          + clw*precip_l*vegn_ifrac*pT + csw*precip_s*vegn_ifrac*pT &
          - clw*vegn_drip_l*vT - csw*vegn_drip_s*vT - tile%e_res_2
     B1(iTv)  = DflwvDTg
     B2(iTv)  = 0
! [X.1.4] equation of intercepted liquid water mass balance
     A(iwl,iqc) = DEliDqc
     A(iwl,iTc) = 0
     A(iwl,iTv) = DEliDTv
     A(iwl,iwl) = 1.0/delta_time + DEliDwl
     A(iwl,iwf) = DEliDwf
     B0(iwl)  = -Eli0 + precip_l*vegn_ifrac - vegn_drip_l
     B1(iwl)  = 0
     B2(iwl)  = 0
! [X.1.5] equation of intercepted frozen water mass balance
     A(iwf,iqc) = DEsiDqc
     A(iwf,iTc) = 0
     A(iwf,iTv) = DEsiDTv
     A(iwf,iwl) = DEsiDwl
     A(iwf,iwf) = 1.0/delta_time + DEsiDwf
     B0(iwf)  = -Esi0 + precip_s*vegn_ifrac - vegn_drip_s
     B1(iwf)  = 0
     B2(iwf)  = 0
! [X.1.6] if LAI becomes zero (and, therefore, all fluxes from vegetation and their 
! derivatives must be zero too) we get a degenerate case. Still, the drip may be non-zero
! because some water may remain from before leaf drop, and non-zero energy residual can be
! carried over from the previous time step.
! To prevent temperature from going haywire in those cases, we simply replace the equations 
! of canopy energy and mass balance with the following:
! vegn_T + delta_Tv = cana_T + delta_Tc
! delta_Wl = -vegn_drip_l*delta_time
! delta_Ws = -vegn_drip_s*delta_time
! the residual vegn_Wl and vegn_Ws, if any, are taken care of by the overflow calculations 
     if(vegn_hcap==0) then
        ! vegn_T + delta_Tv = cana_T + delta_Tc
        A(iTv,:)   = 0
        A(iTv,iTc) = -1
        A(iTv,iTv) = +1
        B0(iTv) = cana_T - vegn_T
        B1(iTv) = 0
        ! delta_Wl = -vegn_drip_l*delta_time
        A(iwl,:)   = 0
        A(iwl,iwl) = 1
        B0(iwl) = -vegn_drip_l*delta_time
        B1(iwl) = 0
        ! delta_Ws = -vegn_drip_s*delta_time
        A(iwf,:)   = 0
        A(iwf,iwf) = 1
        B0(iwf) = -vegn_drip_s*delta_time
        B1(iwf) = 0
     endif



     if(is_watch_point()) then
        write(*,*)'#### A, B0, B1, B2 ####'
        do ii = 1, size(A,1)
           write(*,'(99g)')(A(ii,jj),jj=1,size(A,2)),B0(ii),B1(ii),B2(ii)
        enddo
     endif

     A00 = A
     B00 = B0
     B10 = B1

! [X.2] solve the system for free terms and delta_Tg and delta_psig terms, getting
!       linear equation for delta_Tg and delta_psig
     call ludcmp(A,indx, ierr)
     if (ierr/=0)&
          write(*,*) 'Matrix is singular',i,j,k
     call lubksb(A,indx,B0)
     call lubksb(A,indx,B1)
     call lubksb(A,indx,B2)

     if(is_watch_point()) then
        write(*,*)'#### solution: B0, B1, B2 ####'
        do ii = 1, size(A,1)
           __DEBUG3__(B0(ii),B1(ii),B2(ii))
        enddo
!!$        write(*,*)'#### solution check ####'
!!$        do ii = 1, size(A,1)
!!$           sum0 = 0; sum1 = 0;
!!$           do jj = 1, size(A,2)
!!$              sum0 = sum0 + A00(ii,jj)*B0(jj)
!!$              sum1 = sum1 + A00(ii,jj)*B1(jj)
!!$           enddo
!!$           write(*,'(99g)')sum0-B00(ii),sum1-B10(ii)
!!$        enddo
     endif
! the result of this solution is a set of expressions for delta_xx in terms
! of delta_Tg and delta_psig: 
! delta_xx(i) = B0(i) + B1(i)*delta_Tg + B2(i)*delta_psig. Note that A, B0, B1 and B2
! are destroyed in the process: A is replaced with LU-decomposition, and
! B0, B1, B2 are replaced with solutions

     ! solve the non-linear equation for energy balance at the surface.

     call land_surface_energy_balance( &
          grnd_T, grnd_liq, grnd_ice, grnd_latent, grnd_Tf, grnd_E_min, &
          grnd_E_max, fswg, &
          flwg0 + b0(iTv)*DflwgDTv, DflwgDTg + b1(iTv)*DflwgDTv, b2(iTv)*DflwgDTv, &
          Hg0   + b0(iTc)*DHgDTc,   DHgDTg   + b1(iTc)*DHgDTc,   b2(iTc)*DHgDTc,   &
          Eg0   + b0(iqc)*DEgDqc,   DEgDTg   + b1(iqc)*DEgDqc,   DEgDpsig + b2(iqc)*DEgDqc,   &
          G0,                       DGDTg, &
          ! output
          delta_Tg, delta_psig, Mg_imp )

! [X.5] calculate final value of other tendencies
     delta_qc = B0(iqc) + B1(iqc)*delta_Tg + B2(iqc)*delta_psig
     delta_Tc = B0(iTc) + B1(iTc)*delta_Tg + B2(iTc)*delta_psig
     delta_Tv = B0(iTv) + B1(iTv)*delta_Tg + B2(iTv)*delta_psig
     delta_wl = B0(iwl) + B1(iwl)*delta_Tg + B2(iwl)*delta_psig
     delta_ws = B0(iwf) + B1(iwf)*delta_Tg + B2(iwf)*delta_psig

! [X.6] calculate updated values of energy balance components used in further 
!       calculations
     flwg       = flwg0 + DflwgDTg*delta_Tg + DflwgDTv*delta_Tv
     evapg      = Eg0   + DEgDTg*delta_Tg   + DEgDpsig*delta_psig + DEgDqc*delta_qc
     sensg      = Hg0   + DHgDTg*delta_Tg   + DHgDTc*delta_Tc
     grnd_flux  = G0    + DGDTg*delta_Tg
     vegn_sens  = Hv0   + DHvDTv*delta_Tv   + DHvDTc*delta_Tc
     vegn_levap = Eli0  + DEliDTv*delta_Tv  + DEliDqc*delta_qc + DEliDwl*delta_wl + DEliDwf*delta_ws
     vegn_fevap = Esi0  + DEsiDTv*delta_Tv  + DEsiDqc*delta_qc + DEsiDwl*delta_wl + DEsiDwf*delta_ws
     vegn_uptk  = Et0   + DEtDTv*delta_Tv   + DEtDqc*delta_qc  + DEtDwl*delta_wl  + DEtDwf*delta_ws
     vegn_flw   = flwv0 + DflwvDTv*delta_Tv + DflwvDTg*delta_Tg
     land_evap  = Ea0   + DEaDqc*delta_qc
     land_sens  = Ha0   + DHaDTc*delta_Tc
! [X.7] calculate energy residuals due to cross-product of time tendencies
#ifdef USE_DRY_CANA_MASS
     tile%e_res_1 = canopy_air_mass*cpw*delta_qc*delta_Tc/delta_time
#else
     tile%e_res_1 = canopy_air_mass*(cpw-cp_air)*delta_qc*delta_Tc/delta_time
#endif
     tile%e_res_2 = delta_Tv*(clw*delta_Wl+csw*delta_Ws)/delta_time
! calculate the final value upward long-wave radiation flux from the land, to be 
! returned to the flux exchange.
     tile%lwup = ILa_dn - vegn_flw - flwg 
 
     if(is_watch_point())then
        write(*,*)'#### ground balance'
        __DEBUG2__(fswg,flwg)
        __DEBUG2__(sensg,evapg*grnd_latent)
        __DEBUG1__(grnd_flux)
        __DEBUG1__(Mg_imp)
        write(*,*)'#### implicit time steps'
        __DEBUG3__(delta_Tg, grnd_T,  grnd_T+delta_Tg )
        __DEBUG1__(delta_psig                         )
        __DEBUG3__(delta_qc, cana_q,  cana_q+delta_qc )
        __DEBUG3__(delta_Tc, cana_T,  cana_T+delta_Tc )
        __DEBUG3__(delta_Tv, vegn_T,  vegn_T+delta_Tv )
        __DEBUG3__(delta_wl, vegn_Wl, vegn_Wl+delta_wl)
        __DEBUG3__(delta_ws, vegn_Ws, vegn_Ws+delta_ws)
        __DEBUG2__(tile%e_res_1, tile%e_res_2)
        write(*,*)'#### resulting fluxes'
        __DEBUG4__(flwg, evapg, sensg, grnd_flux)
        __DEBUG3__(vegn_levap,vegn_fevap,vegn_uptk)
        __DEBUG2__(vegn_sens,vegn_flw)
        __DEBUG1__(Ea0+DEaDqc*delta_qc)
        __DEBUG2__(tile%cana%prog%q,cana_q)
     endif

     call cana_step_2 ( tile%cana, delta_Tc, delta_qc )

     if(associated(tile%vegn)) then
        call vegn_step_2 ( tile%vegn, tile%diag, &
             delta_Tv, delta_wl, delta_ws, &
             vegn_melt,  &
             vegn_ovfl_l,   vegn_ovfl_s, &
             vegn_ovfl_Hl, vegn_ovfl_Hs )
        ! calculate total amount of liquid and solid precipitation below the canopy
        vegn_lprec  = (1-vegn_ifrac)*precip_l + vegn_drip_l + vegn_ovfl_l
        vegn_fprec  = (1-vegn_ifrac)*precip_s + vegn_drip_s + vegn_ovfl_s
        ! calculate heat carried by liquid and solid precipitation below the canopy
        vegn_hlprec = clw*((1-vegn_ifrac)*precip_l*(precip_T-tfreeze) &
                         + vegn_drip_l*(vegn_T+delta_Tv-tfreeze)) &
                         + vegn_ovfl_Hl
        vegn_hfprec = csw*((1-vegn_ifrac)*precip_s*(precip_T-tfreeze) &
                         + vegn_drip_s*(vegn_T+delta_Tv-tfreeze)) &
                         + vegn_ovfl_Hs
        ! make sure the temperature of the snow falling below canopy is below freezing
        ! this correction was introduced in an attempt to fix the problem with fictitious 
        ! heat accumulating in near-zero-mass snow; however it does not seem to make a 
        ! difference.
        if(vegn_hfprec>0)then
           ! solid precipitation from vegetation carries positive energy -- we can't have
           ! that, because that would bring snow T above tfreeze, so convert excess to 
           ! liquid
           delta_fprec = min(vegn_fprec,vegn_hfprec/hlf)
           vegn_fprec = vegn_fprec - delta_fprec
           vegn_lprec = vegn_lprec + delta_fprec
           vegn_hfprec = vegn_hfprec - hlf*delta_fprec
           ! we don't need to correct the vegn_hlprec since the temperature of additional
           ! liquid precip is tfreeze, and therefore its contribution to vegn_hlprec is
           ! exactly zero
        endif
        ! possibly we need to correct for the opposite situation: negative energy carried
        ! by liquid precipitation.
     else
        vegn_lprec  = precip_l
        vegn_fprec  = precip_s
        vegn_hlprec = precip_l*clw*(precip_T-tfreeze)
        vegn_hfprec = precip_s*csw*(precip_T-tfreeze)
        ! the fields below are only used in diagnostics
        vegn_melt   = 0
        vegn_fsw    = 0
     endif

     call snow_step_2 ( tile%snow, &
          snow_subl, vegn_lprec, vegn_fprec, vegn_hlprec, vegn_hfprec, &
          delta_Tg, Mg_imp, evapg, fswg, flwg, sensg, &
          use_tfreeze_in_grnd_latent, &
          ! output:
          subs_DT, subs_M_imp, subs_evap, subs_fsw, subs_flw, subs_sens, &
          snow_fsw, snow_flw, snow_sens, &
          snow_levap, snow_fevap, snow_melt, &
          snow_lprec, snow_hlprec, snow_lrunf, snow_frunf, &
          snow_hlrunf, snow_hfrunf, snow_Tbot, snow_Cbot, snow_C, snow_avrg_T )
     if(is_watch_point()) then
        write(*,*) 'subs_M_imp', subs_M_imp
     endif

     if (snow_active) then
        subs_G = snow_G_Z+snow_G_TZ*subs_DT
     else
        subs_G = 0
     endif
     
     if (associated(tile%glac)) then
        call glac_step_2 &
             ( tile%glac, tile%diag, subs_subl, snow_lprec, snow_hlprec, &
             subs_DT, subs_M_imp, subs_evap, &
             subs_levap, subs_fevap, &
             subs_melt, subs_lrunf, subs_hlrunf, subs_Ttop, subs_Ctop )
     else if (associated(tile%lake)) then
        call lake_step_2 &
             ( tile%lake, tile%diag, subs_subl, snow_lprec, snow_hlprec, &
             subs_DT, subs_M_imp, subs_evap, &
             use_tfreeze_in_grnd_latent, subs_levap, subs_fevap, &
             subs_melt, subs_Ttop, subs_Ctop )
        subs_lrunf = 0.
        subs_hlrunf = 0.
     else if (associated(tile%soil)) then
        call soil_step_2 &
             ( tile%soil, tile%vegn, tile%diag, subs_subl, snow_lprec, snow_hlprec, &
             vegn_uptk, subs_DT, subs_M_imp, subs_evap, &
             use_tfreeze_in_grnd_latent, &
             ! output:
             subs_levap, subs_fevap, &
             subs_melt, subs_lrunf, subs_hlrunf, subs_Ttop, subs_Ctop )
     endif
     
! TEMP FIX: MAIN PROG SHOULD NOT TOUCH CONTENTS OF PROG VARS. ******
! ALSO, DIAGNOSTICS IN COMPONENT MODULES SHOULD _FOLLOW_ THIS ADJUSTMENT******
     IF (LM2) THEN
        tile%snow%prog%T = subs_Ttop
        subs_G2 = 0.
     ELSE
        if (sum(tile%snow%prog(:)%ws)>0)then
           new_T = (subs_Ctop*subs_Ttop +snow_Cbot*snow_Tbot) &
                           / (subs_Ctop+snow_Cbot)
           tile%snow%prog(size(tile%snow%prog))%T = new_T
           if(associated(tile%glac)) tile%glac%prog(1)%T = new_T
           if(associated(tile%lake)) tile%lake%prog(1)%T = new_T
           if(associated(tile%soil)) tile%soil%prog(1)%T = new_T
           subs_G2 = subs_Ctop*(new_T-subs_Ttop)/delta_time
        else
           if(tau_snow_T_adj>=0) then
              delta_T_snow = subs_Ctop*(subs_Ttop-snow_avrg_T)/&
                   (subs_Ctop*tau_snow_T_adj/delta_time+subs_Ctop+snow_C)
              tile%snow%prog(:)%T = snow_avrg_T + delta_T_snow

              new_T = subs_Ttop-snow_C/subs_Ctop*delta_T_snow
              if(associated(tile%glac)) tile%glac%prog(1)%T = new_T
              if(associated(tile%lake)) tile%lake%prog(1)%T = new_T
              if(associated(tile%soil)) tile%soil%prog(1)%T = new_T
              subs_G2 = subs_Ctop*(new_T-subs_Ttop)/delta_time
           else
              subs_G2 = 0.
           endif
        endif
     ENDIF

     vegn_fco2 = 0
     if (associated(tile%vegn)) then
        ! do the calculations that require updated land surface prognostic variables
        call vegn_step_3 (tile%vegn, tile%soil, tile%cana%prog%T, precip_l+precip_s, &
             vegn_fco2, tile%diag)
     endif
     ! update co2 concentration in the canopy air. It would be more consistent to do that
     ! in the same place and fashion as the rest of prognostic variables: that is, have the
     ! vegn_step_1 (and perhaps other *_step_1 procedures) calculate fluxes and their
     ! derivatives, then solve the linear equation(s), and finally have cana_step_2 update
     ! the concentration.
     if(update_cana_co2) then
        tile%cana%prog%co2 = tile%cana%prog%co2 + &
             (vegn_fco2 - fco2_0)/(canopy_air_mass_for_tracers/delta_time+Dfco2Dq)
     endif
     if(is_watch_point())then
        __DEBUG1__(tile%cana%prog%co2)
        __DEBUG3__(fco2_0,Dfco2Dq,vegn_fco2)
     endif
     
     call update_land_bc_fast (tile, i,j,k, land2cplr)

     runoff     (i,j) = runoff     (i,j) + (snow_frunf  + subs_lrunf  + snow_lrunf )*tile%frac
     runoff_heat(i,j) = runoff_heat(i,j) + (snow_hfrunf + subs_hlrunf + snow_hlrunf)*tile%frac
     runoff_snow(i,j) = runoff_snow(i,j) +  snow_frunf * tile%frac
     hprec = (clw*precip_l+csw*precip_s)*(precip_T-tfreeze)
     hevap = cpw*land_evap*(evap_T-tfreeze)

     ! ---- diagnostic section ----------------------------------------------
     call send_tile_data(id_frac,    tile%frac,                          tile%diag)
     call send_tile_data(id_area,    tile%frac*lnd%area(i,j),            tile%diag)
     call send_tile_data(id_ntiles,  1.0,                                tile%diag)     
     call send_tile_data(id_precip,  precip_l+precip_s,                  tile%diag)
     call send_tile_data(id_hprec,   hprec,                              tile%diag)
     call send_tile_data(id_lprec,   precip_l,                           tile%diag)
     call send_tile_data(id_lprecv,  precip_l-vegn_lprec,                tile%diag)
     call send_tile_data(id_lprecs,  vegn_lprec-snow_lprec,              tile%diag)
     call send_tile_data(id_lprecg,  snow_lprec,                         tile%diag)
     call send_tile_data(id_hlprec,  clw*precip_l*(precip_T-tfreeze),    tile%diag)
     call send_tile_data(id_hlprecv, clw*precip_l*(precip_T-tfreeze)-vegn_hlprec, &
                                                                         tile%diag)
     call send_tile_data(id_hlprecs, vegn_hlprec-snow_hlprec,            tile%diag)
     call send_tile_data(id_hlprecg, snow_hlprec,                        tile%diag)
     call send_tile_data(id_fprec,   precip_s,                           tile%diag)
     call send_tile_data(id_fprecv,  precip_s-vegn_fprec,                tile%diag)
     call send_tile_data(id_fprecs,  vegn_fprec,                         tile%diag)
     call send_tile_data(id_hfprec,  csw*precip_s*(precip_T-tfreeze),    tile%diag)
     call send_tile_data(id_hfprecv, csw*precip_s*(precip_T-tfreeze)-vegn_hfprec, &
                                                                         tile%diag)
     call send_tile_data(id_hfprecs, vegn_hfprec,                        tile%diag)
     call send_tile_data(id_evap,    land_evap,                          tile%diag)
     call send_tile_data(id_hevap,   hevap,                              tile%diag)
     call send_tile_data(id_levap,   vegn_levap+snow_levap+subs_levap+vegn_uptk, &
                                                                         tile%diag)
     call send_tile_data(id_levapv,  vegn_levap,                         tile%diag)
     call send_tile_data(id_levaps,  snow_levap,                         tile%diag)
     call send_tile_data(id_levapg,  subs_levap,                         tile%diag)
     call send_tile_data(id_hlevap,  cpw*vegn_levap*(vegn_T-tfreeze) &
                                       +cpw*snow_levap*(snow_T-tfreeze) &
                                       +cpw*subs_levap*(grnd_T-tfreeze), tile%diag)
     call send_tile_data(id_hlevapv, cpw*vegn_levap*(vegn_T-tfreeze),    tile%diag)
     call send_tile_data(id_hlevaps, cpw*snow_levap*(snow_T-tfreeze),    tile%diag)
     call send_tile_data(id_hlevapg, cpw*subs_levap*(grnd_T-tfreeze),    tile%diag)
     call send_tile_data(id_fevap,   vegn_fevap+snow_fevap+subs_fevap,   tile%diag)
     call send_tile_data(id_fevapv,  vegn_fevap,                         tile%diag)
     call send_tile_data(id_fevaps,  snow_fevap,                         tile%diag)
     call send_tile_data(id_fevapg,  subs_fevap,                         tile%diag)
     call send_tile_data(id_hfevap,  cpw*vegn_fevap*(vegn_T-tfreeze) &
                                       +cpw*snow_fevap*(snow_T-tfreeze) &
                                       +cpw*subs_fevap*(grnd_T-tfreeze), tile%diag)
     call send_tile_data(id_hfevapv, cpw*vegn_fevap*(vegn_T-tfreeze),    tile%diag)
     call send_tile_data(id_hfevaps, cpw*snow_fevap*(snow_T-tfreeze),    tile%diag)
     call send_tile_data(id_hfevapg, cpw*subs_fevap*(grnd_T-tfreeze),    tile%diag)
     call send_tile_data(id_runf,    snow_lrunf+snow_frunf+subs_lrunf,   tile%diag)
     call send_tile_data(id_hrunf,   snow_hlrunf+snow_hfrunf+subs_hlrunf,tile%diag)
     call send_tile_data(id_lrunf,   snow_lrunf+subs_lrunf,              tile%diag)
     call send_tile_data(id_lrunfs,  snow_lrunf,                         tile%diag)
     call send_tile_data(id_lrunfg,  subs_lrunf,                         tile%diag)
     call send_tile_data(id_hlrunf,  snow_hlrunf+subs_hlrunf,            tile%diag)
     call send_tile_data(id_hlrunfs, snow_hlrunf,                        tile%diag)
     call send_tile_data(id_hlrunfg, subs_hlrunf,                        tile%diag)
     call send_tile_data(id_frunf,   snow_frunf,                         tile%diag)
     call send_tile_data(id_frunfs,  snow_frunf,                         tile%diag)
     call send_tile_data(id_hfrunf,  snow_hfrunf,                        tile%diag)
     call send_tile_data(id_hfrunfs, snow_hfrunf,                        tile%diag)
     call send_tile_data(id_melt,    vegn_melt+snow_melt+subs_melt,      tile%diag)
     call send_tile_data(id_meltv,   vegn_melt,                          tile%diag)
     call send_tile_data(id_melts,   snow_melt,                          tile%diag)
     call send_tile_data(id_meltg,   subs_melt,                          tile%diag)
     call send_tile_data(id_fsw,     vegn_fsw+snow_fsw+subs_fsw,         tile%diag)
     call send_tile_data(id_fswv,    vegn_fsw,                           tile%diag)
     call send_tile_data(id_fsws,    snow_fsw,                           tile%diag)
     call send_tile_data(id_fswg,    subs_fsw,                           tile%diag)
     call send_tile_data(id_flw,     vegn_flw+snow_flw+subs_flw,         tile%diag)
     call send_tile_data(id_flwv,    vegn_flw,                           tile%diag)
     call send_tile_data(id_flws,    snow_flw,                           tile%diag)
     call send_tile_data(id_flwg,    subs_flw,                           tile%diag)
     call send_tile_data(id_sens,    land_sens,                          tile%diag)
     call send_tile_data(id_sensv,   vegn_sens,                          tile%diag)
     call send_tile_data(id_senss,   snow_sens,                          tile%diag)
     call send_tile_data(id_sensg,   subs_sens,                          tile%diag)
     call send_tile_data(id_e_res_1, tile%e_res_1,                       tile%diag)
     call send_tile_data(id_e_res_2, tile%e_res_2,                       tile%diag)
     call send_tile_data(id_z0m,     land2cplr%rough_mom(i,j,k),         tile%diag)
     call send_tile_data(id_z0s,     land2cplr%rough_heat(i,j,k),        tile%diag)
     call send_tile_data(id_con_g_h, con_g_h,                            tile%diag)
     call send_tile_data(id_transp,  vegn_uptk,                          tile%diag)
     call send_tile_data(id_wroff,   snow_lrunf+subs_lrunf,              tile%diag)
     call send_tile_data(id_sroff,   snow_frunf,                         tile%diag)
     call send_tile_data(id_htransp, cpw*vegn_uptk*(vegn_T-tfreeze),     tile%diag)
     call send_tile_data(id_huptake, clw*vegn_uptk*(soil_uptake_T-tfreeze), &
                                                                         tile%diag)
     call send_tile_data(id_hroff,   snow_hlrunf+subs_hlrunf+snow_hfrunf, &
                                                                         tile%diag)
     call send_tile_data(id_gsnow,   subs_G,                             tile%diag)
     call send_tile_data(id_gsnow_old,   subs_G,                         tile%diag)
     call send_tile_data(id_gequil,  subs_G2,                            tile%diag)
     call send_tile_data(id_grnd_flux, grnd_flux,                        tile%diag)
     call send_tile_data(id_soil_water_supply, soil_water_supply,        tile%diag)
     if(grnd_E_max.lt.0.5*HUGE(grnd_E_Max)) &
         call send_tile_data(id_levapg_max, grnd_E_max,                  tile%diag)
     call send_tile_data(id_Trad,    land2cplr%t_surf(i,j,k),            tile%diag)
     call send_tile_data(id_Tca,     land2cplr%t_ca(i,j,k),              tile%diag)
     call send_tile_data(id_qca,     land2cplr%tr(i,j,k,lnd%isphum),     tile%diag)
     call send_tile_data(id_qco2,    tile%cana%prog%co2,                 tile%diag)
     call send_tile_data(id_qco2_dvmr,&
          tile%cana%prog%co2*mol_air/mol_co2/(1-tile%cana%prog%q),       tile%diag)
     call send_tile_data(id_fco2,    vegn_fco2*mol_C/mol_co2,            tile%diag)
     call send_tile_data(id_swdn_dir, ISa_dn_dir,                        tile%diag)
     call send_tile_data(id_swdn_dif, ISa_dn_dif,                        tile%diag)
     call send_tile_data(id_swup_dir, ISa_dn_dir*tile%land_refl_dir,     tile%diag)
     call send_tile_data(id_swup_dif, ISa_dn_dif*tile%land_refl_dif,     tile%diag)
     call send_tile_data(id_lwdn,     ILa_dn,                            tile%diag)
  enddo

  ! set values of tracer fluxes
  runoff_c(:,:,1) = runoff_snow
  runoff_c(:,:,2) = runoff_heat
  do i_species = num_phys+1, num_species
    runoff_c(:,:,i_species) = 0        ! age, species
    enddo

!=================================================================================
  ! update river state
  call update_river(runoff, runoff_c, discharge_l, discharge_c)
!=================================================================================

  discharge_l = discharge_l/lnd%cellarea
  do i_species = 1, num_species
    discharge_c(:,:,i_species) =  &
            discharge_c(:,:,i_species)/lnd%cellarea
    enddo

  ! pass through to ocean the runoff that was not seen by river module because of land_frac diffs.
  ! need to multiply by gfrac to spread over whole cell
  where (missing_rivers) discharge_l = (runoff-runoff_c(:,:,1))*frac
  do i_species = 1, num_species
    where (missing_rivers) discharge_c(:,:,i_species) = &
                                 runoff_c(:,:,i_species)*frac
    enddo

  ! don't send negatives or insignificant values to ocean. put them in the sink instead.
  ! this code does not seem necessary, and default discharge_tol value should be used.
  discharge_sink = 0.
  where (discharge_l.le.discharge_tol)
      discharge_sink = discharge_sink + discharge_l
      discharge_l    = 0.
    endwhere
  where (discharge_c(:,:,1).le.discharge_tol)
      discharge_sink     = discharge_sink + discharge_c(:,:,1)
      discharge_c(:,:,1) = 0.
    endwhere

  ! find phase partitioning ratio for discharge sensible heat flux
  where (discharge_l.gt.0. .or. discharge_c(:,:,1).gt.0.)
      heat_frac_liq = clw*discharge_l / (clw*discharge_l+csw*discharge_c(:,:,1))
    elsewhere
      heat_frac_liq = 1.
    endwhere

  ! scale up fluxes sent to ocean to compensate for non-ocean fraction of discharge cell.
  ! split heat into liquid and solid streams
  where (frac.lt.1.) 
      land2cplr%discharge           = discharge_l        / (1-frac)
      land2cplr%discharge_snow      = discharge_c(:,:,1) / (1-frac)
      land2cplr%discharge_heat      = heat_frac_liq*discharge_c(:,:,2) / (1-frac)
      land2cplr%discharge_snow_heat =               discharge_c(:,:,2) / (1-frac) &
                                     - land2cplr%discharge_heat
    endwhere

  ce = first_elmt(lnd%tile_map,                  &
              is=lbound(cplr2land%t_flux,1), &
              js=lbound(cplr2land%t_flux,2)  )
  te = tail_elmt(lnd%tile_map)
  do while(ce /= te)
     call get_elmt_indices(ce,i,j,k)
     tile => current_tile(ce)
     ce=next_elmt(ce)
     cana_VMASS = 0. ;                   cana_HEAT = 0.
     vegn_LMASS = 0. ; vegn_FMASS = 0. ; vegn_HEAT = 0.
     snow_LMASS = 0. ; snow_FMASS = 0. ; snow_HEAT = 0.
     subs_LMASS = 0. ; subs_FMASS = 0. ; subs_HEAT = 0.
     glac_LMASS = 0. ; glac_FMASS = 0. ; glac_HEAT = 0.
     lake_LMASS = 0. ; lake_FMASS = 0. ; lake_HEAT = 0.
     soil_LMASS = 0. ; soil_FMASS = 0. ; soil_HEAT = 0.
     if (associated(tile%cana)) then
         call cana_state( tile%cana, cana_q=cana_q )
         cana_VMASS = canopy_air_mass*cana_q
         cana_HEAT  = cana_tile_heat(tile%cana)
  ! NEED TO DEFINE CANA_HEAT **************************************************
       endif
     if (associated(tile%vegn)) then
         call vegn_tile_stock_pe(tile%vegn, vegn_LMASS, vegn_FMASS)
         vegn_HEAT = vegn_tile_heat(tile%vegn)
       endif
     if(associated(tile%snow)) &
         call snow_tile_stock_pe(tile%snow, snow_LMASS, snow_FMASS)
         snow_HEAT = snow_tile_heat(tile%snow)
     if (associated(tile%glac)) then
         call glac_tile_stock_pe(tile%glac, subs_LMASS, subs_FMASS)
         subs_HEAT  = glac_tile_heat(tile%glac)
         glac_LMASS = subs_LMASS
         glac_FMASS = subs_FMASS
         glac_HEAT  = subs_HEAT
       else if (associated(tile%lake)) then
         call lake_tile_stock_pe(tile%lake, subs_LMASS, subs_FMASS)
         subs_HEAT  = lake_tile_heat(tile%lake)
         lake_LMASS = subs_LMASS
         lake_FMASS = subs_FMASS
         lake_HEAT  = subs_HEAT
       else if (associated(tile%soil)) then
         call soil_tile_stock_pe(tile%soil, subs_LMASS, subs_FMASS)
         subs_HEAT  = soil_tile_heat(tile%soil)
         soil_LMASS = subs_LMASS
         soil_FMASS = subs_FMASS
         soil_HEAT  = subs_HEAT
       endif

     call send_tile_data(id_VWS,  cana_VMASS, tile%diag)
     call send_tile_data(id_VWSc, cana_VMASS, tile%diag)
     call send_tile_data(id_LWS,  vegn_LMASS+snow_LMASS+subs_LMASS, tile%diag)
     call send_tile_data(id_LWSv, vegn_LMASS, tile%diag)
     call send_tile_data(id_LWSs, snow_LMASS, tile%diag)
     call send_tile_data(id_LWSg, subs_LMASS, tile%diag)
     call send_tile_data(id_FWS,  vegn_FMASS+snow_FMASS+subs_FMASS, tile%diag)
     call send_tile_data(id_FWSv, vegn_FMASS, tile%diag)
     call send_tile_data(id_FWSs, snow_FMASS, tile%diag)
     call send_tile_data(id_FWSg, subs_FMASS, tile%diag)
     call send_tile_data(id_HS,  vegn_HEAT+snow_HEAT+subs_HEAT+cana_HEAT, tile%diag)
     call send_tile_data(id_HSv, vegn_HEAT, tile%diag)
     call send_tile_data(id_HSs, snow_HEAT, tile%diag)
     call send_tile_data(id_HSg, subs_HEAT, tile%diag)
     call send_tile_data(id_HSc, cana_HEAT, tile%diag)
     call send_tile_data(id_water, subs_LMASS+subs_FMASS, tile%diag)
     call send_tile_data(id_snow,  snow_LMASS+snow_FMASS, tile%diag)
     enddo

  ! advance land model time
  lnd%time = lnd%time + lnd%dt_fast

  ! send the accumulated diagnostics to the output
  call dump_tile_diag_fields(lnd%tile_map, lnd%time)

  if (id_dis_liq > 0)  used = send_data (id_dis_liq,  discharge_l,        lnd%time) 
  if (id_dis_ice > 0)  used = send_data (id_dis_ice,  discharge_c(:,:,1), lnd%time) 
  if (id_dis_heat > 0) used = send_data (id_dis_heat, discharge_c(:,:,2), lnd%time) 
  if (id_dis_sink > 0) used = send_data (id_dis_sink, discharge_sink,     lnd%time) 

  ! deallocate override buffer
  deallocate(phot_co2_data)

  call mpp_clock_end(landFastClock)
  call mpp_clock_end(landClock)
end subroutine update_land_model_fast


! ============================================================================
subroutine update_land_model_slow ( cplr2land, land2cplr )
  type(atmos_land_boundary_type), intent(inout) :: cplr2land
  type(land_data_type)          , intent(inout) :: land2cplr

  ! ---- local vars
  integer :: i,j,k
  type(land_tile_type), pointer :: tile
  type(land_tile_enum_type) :: ce, te

  call mpp_clock_begin(landClock)
  call mpp_clock_begin(landSlowClock)

  call land_transitions( lnd%time )
  call update_vegn_slow( )
  ! send the accumulated diagnostics to the output
  call dump_tile_diag_fields(lnd%tile_map, lnd%time)

  ! land_transitions may have changed the number of tiles per grid cell: reallocate 
  ! boundary conditions, if necessary
  call realloc_cplr2land( cplr2land )
  call realloc_land2cplr( land2cplr )
  ! set the land mask to FALSE everywhere -- update_land_bc_fast will set it to 
  ! true where necessary
  land2cplr%mask = .FALSE.
  land2cplr%tile_size = 0.0

  ! get the current state of the land boundary for the coupler
  ce = first_elmt(lnd%tile_map,                  &
              is=lbound(cplr2land%t_flux,1), &
              js=lbound(cplr2land%t_flux,2)  )
  te = tail_elmt(lnd%tile_map)
  do while(ce /= te)
     ! calculate indices of the current tile in the input arrays;
     ! assume all the cplr2land components have the same lbounds
     call get_elmt_indices(ce,i,j,k)
     ! set this point coordinates as current for debug output
     call set_current_point(i,j,k)
     ! get pointer to current tile
     tile => current_tile(ce)
     ! advance enumerator to the next tile
     ce=next_elmt(ce)

     call update_land_bc_fast (tile, i,j,k, land2cplr, is_init=.true.)
  enddo

  call update_land_bc_slow( land2cplr )

  call mpp_clock_end(landClock)
  call mpp_clock_end(landSlowClock)
end subroutine update_land_model_slow


! ============================================================================
! solve for surface temperature. ensure that melt does not exceed available
! snow or soil ice (which would create energy-balance problems). also ensure
! that melt and temperature are consistent and that evaporation from liquid
! soil water does not exceed exfiltration rate limit, if one is supplied.
! because the possible combinations of active constraints has multiplied
! greatly, we do not allow phase change for any surface (i.e., soil) at which
! we might apply a constraint on Eg.
subroutine land_surface_energy_balance ( &
     ! surface parameters
     grnd_T,          & ! ground temperature
     grnd_liq, grnd_ice, & ! amount of water available for freeze or melt on the surface, kg/m2
     grnd_latent,     & ! specific heat of vaporization for the ground
     grnd_Tf,         & ! ground freezing temperature
     grnd_E_min,      & ! Eg floor of 0 if condensation is prohibited
     grnd_E_max,      & ! exfiltration rate limit, kg/(m2 s)
     ! components of the ground energy balance linearization. Note that those
     ! are full derivatives, which include the response of the other surface
     ! scheme parameters to the change in ground temperature.
     fswg,            & ! net short-wave
     flwg0, DflwgDTg, DflwgDpsig, & ! net long-wave
     Hg0,   DHgDTg,   DHgDpsig,   & ! sensible heat
     Eg0,   DEgDTg,   DEgDpsig,   & ! latent heat
     G0,    DGDTg,    & ! sub-surface heat 
     delta_Tg,        & ! surface temperature change for the time step
     delta_psig,      & 
     Mg_imp          )  ! implicit melt, kg/m2

  real, intent(in) :: & 
     grnd_T,          & ! ground temperature
     grnd_liq, grnd_ice, & ! amount of water available for freeze or melt on the surface
     grnd_latent,     & ! specific heat of vaporization for the ground
     grnd_Tf,         & ! ground freezing temperature
     grnd_E_min,      & ! Eg floor of 0 if condensation is prohibited
     grnd_E_max,      & ! exfiltration rate limit, kg/(m2 s)
     fswg,            & ! net short-wave
     flwg0, DflwgDTg, DflwgDpsig, & ! net long-wave
     Hg0,   DHgDTg,   DHgDpsig,   & ! sensible heat
     Eg0,   DEgDTg,   DEgDpsig,   & ! latent heat
     G0,    DGDTg                   ! sub-surface heat 
  real, intent(out) :: &
     delta_Tg,        & ! change in surface temperature
     delta_psig,      & ! change in surface soil-water matric head
     Mg_imp             ! mass of surface ice melted (or water frozen) during the 
                        ! time step, kg/m2

  real :: grnd_B     ! surface energy balance
  real :: grnd_DBDTg ! full derivative of grnd_B w.r.t. surface temperature
  real :: grnd_DBDpsig ! full derivative of grnd_B w.r.t. surface soil-water matric head
  real :: grnd_E_force, Eg_trial, Eg_check, determinant

  grnd_B      = fswg + flwg0      - Hg0      - grnd_latent*Eg0      - G0
  grnd_DBDTg  =        DflwgDTg   - DHgDTg   - grnd_latent*DEgDTg   - DGDTg
  grnd_DBDpsig =       DflwgDpsig - DHgDpsig - grnd_latent*DEgDpsig

  if(is_watch_point())then
     write(*,*)'#### ground balance input'
     __DEBUG1__(grnd_T)
     __DEBUG2__(grnd_liq, grnd_ice)
     __DEBUG1__(grnd_latent)
     __DEBUG1__(grnd_Tf)
     __DEBUG1__(grnd_E_min)
     __DEBUG1__(grnd_E_max)
     __DEBUG1__(fswg)
     __DEBUG3__(flwg0, DflwgDTg,DflwgDpsig)
     __DEBUG3__(Hg0,   DHgDTg,  DHgDpsig  )
     __DEBUG3__(Eg0,   DEgDTg,  DEgDpsig  )
     __DEBUG2__(G0,    DGDTg)
     write(*,*)'#### end of ground balance input'
     __DEBUG3__(grnd_B, grnd_DBDTg, grnd_DBDpsig)
  endif

  ! determine the ground temperature change under the assumptions that
  ! (1) no phase change occurs at surface (always true for soil now), and
  ! (2) delta_psig is zero (always true for snow, lake, glacier now)
  delta_Tg = - grnd_B/grnd_DBDTg
  delta_psig = 0
  ! calculate phase change on the ground, if necessary
  if     (grnd_ice>0.and.grnd_T+delta_Tg>grnd_Tf) then ! melt > 0
     Mg_imp =  min(grnd_ice,  grnd_DBDTg*(grnd_Tf-grnd_T-delta_Tg)*delta_time/hlf)
  elseif (grnd_liq>0.and.grnd_T+delta_Tg<grnd_Tf) then ! melt < 0
     Mg_imp = -min(grnd_liq, -grnd_DBDTg*(grnd_Tf-grnd_T-delta_Tg)*delta_time/hlf)
  else
     Mg_imp = 0
  endif
  ! adjust temperature change for the phase change
  delta_Tg = -(grnd_B - Mg_imp*hlf/delta_time)/grnd_DBDTg
  Eg_trial = Eg0 + DEgDTg*delta_Tg

  if(is_watch_point())then
     write(*,*)'#### ground balance solution with psig constant:'
     __DEBUG2__(grnd_B, grnd_DBDTg)
     __DEBUG3__(Mg_imp, delta_Tg, delta_psig)
     __DEBUG3__(grnd_E_min, Eg_trial, grnd_E_max)
  endif

  ! Solution above (assuming no change in psig) is acceptable if 
  ! it does not imply unacceptable value of Eg. this is always
  ! true for lake, glacier, snow. If implied Eg is outside prescribed
  ! bounds (a possibility only for soil), then Eg is set at bound (grnd_E_force)
  ! and the required Tg and psig are found. To accomplish this,
  ! we solve the system
  ! grnd_B + grnd_DBDTg*delta_Tg + grnd_DBDpsig*delta_psig = 0
  ! Eg0    +     DEgDTg*delta_Tg +     DEgDpsig*delta_psig = grnd_E_force
  ! There is no need to revisit the solution for phase change, which
  ! is only done explicitly for soil.

  if (Eg_trial.lt.grnd_E_min .or. Eg_trial.gt.grnd_E_max) then
      grnd_E_force = max(grnd_E_min, Eg_trial)
      grnd_E_force = min(grnd_E_max, grnd_E_force)
      determinant = grnd_DBDTg*DEgDpsig-grnd_DBDpsig*DEgDTg
      delta_Tg   = - (DEgDpsig*grnd_B + grnd_DBDpsig*(grnd_E_force-Eg0))/determinant
      delta_psig =   (DEgDTg  *grnd_B + grnd_DBDTg  *(grnd_E_force-Eg0))/determinant
      Eg_check = Eg0 + DEgDTg*delta_Tg + DEgDpsig*delta_psig
      Mg_imp = 0
         if(is_watch_point())then
            write(*,*)'#### trial solution violated Eg limit, new soln:'
            __DEBUG2__(grnd_B,grnd_DBDTg)
            __DEBUG3__(Mg_imp,delta_Tg,delta_psig)
            __DEBUG3__(grnd_E_min, Eg_check, grnd_E_max)
         endif
    endif
end subroutine land_surface_energy_balance


! ============================================================================
subroutine update_land_bc_fast (tile, i,j,k, land2cplr, is_init)
  type(land_tile_type), intent(inout) :: tile
  integer             , intent(in) :: i,j,k
  type(land_data_type), intent(inout) :: land2cplr
  logical, optional :: is_init

  ! ---- local vars
  real :: &
         grnd_T, subs_z0m, subs_z0s, &
                 snow_z0s, snow_z0m, &
         snow_area, snow_depth

  real :: subs_refl_dir(NBANDS), subs_refl_dif(NBANDS) ! direct and diffuse albedos
  real :: subs_refl_lw ! reflectance for thermal radiation
  real :: snow_refl_dir(NBANDS), snow_refl_dif(NBANDS) ! direct and diffuse albedos of snow
  real :: snow_refl_lw ! snow reflectance for thermal radiation
  real :: snow_emis ! snow emissivity
  real :: grnd_emis ! ground emissivity
  ! NOTE :  grnd_emis is used only to satisfy xxxx_radiation interfaces; its value is ignored, but
  ! 1-refl is used instead. snow_emis is used in the the vegn_radiation, but it shouldn't be since
  ! properties of intercepted snowpack are, in general, different from the snow on the ground 
  real :: snow_area_rad ! "snow area for radiation calculations" -- introduced
                        ! to reproduce lm2 behavior
  real :: vegn_refl_lw, vegn_tran_lw ! reflectance and transmittance of vegetation for thermal radiation
  real :: vegn_refl_dif(NBANDS), vegn_tran_dif(NBANDS) ! reflectance and transmittance of vegetation for diffuse light
  real :: vegn_refl_dir(NBANDS), vegn_tran_dir(NBANDS) ! reflectance and transmittance of vegetation for direct light
  real :: vegn_tran_dir_dir(NBANDS) ! (?)
  real :: &
         vegn_Tv,     &
         vegn_cover,  &
         vegn_height, vegn_lai, vegn_sai, vegn_d_leaf, cana_co2
  logical :: do_update

  real :: cosz    ! cosine of solar zenith angle
  real :: fracday ! daytime fraction of time interval
  real :: rrsun   ! earth-sun distance (r) relative to semi-major axis
                  ! of orbital ellipse (a) : (a/r)**2
  integer :: face ! for debugging
  vegn_Tv = 0

  do_update = .not.present(is_init)

  ! on initialization the albedos are calculated for the current time step ( that is, interval
  ! lnd%time, lnd%time+lnd%dt_fast); in the course of the run this subroutine is called
  ! at the end of time step (but before time is advanced) to calculate the radiative properties 
  ! for the _next_ time step
  if (do_update) then
     call diurnal_solar(lnd%lat(i,j), lnd%lon(i,j), lnd%time+lnd%dt_fast, &
          cosz, fracday, rrsun, lnd%dt_fast)
  else
     call diurnal_solar(lnd%lat(i,j), lnd%lon(i,j), lnd%time, &
          cosz, fracday, rrsun, lnd%dt_fast)
  endif
  
  if (associated(tile%glac)) then
     call glac_radiation(tile%glac, cosz, subs_refl_dir, subs_refl_dif, subs_refl_lw, grnd_emis)
     call glac_diffusion(tile%glac, subs_z0s, subs_z0m )
  else if (associated(tile%lake)) then
     call lake_radiation(tile%lake, cosz, subs_refl_dir, subs_refl_dif, subs_refl_lw, grnd_emis)
     call lake_diffusion(tile%lake, subs_z0s, subs_z0m )
  else if (associated(tile%soil)) then
     call soil_radiation(tile%soil, cosz, subs_refl_dir, subs_refl_dif, subs_refl_lw, grnd_emis)
     call soil_diffusion(tile%soil, subs_z0s, subs_z0m )
  else
     call get_current_point(face=face)
     call error_mesg('update_land_model_fast','none of the surface tiles exist at ('//&
             trim(string(i))//','//trim(string(j))//','//trim(string(k))//&
             ', face='//trim(string(face))//')',FATAL)
  endif

  call snow_radiation ( tile%snow%prog(1)%T, cosz, snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis)
  call snow_get_depth_area ( tile%snow, snow_depth, snow_area )
  call snow_diffusion ( tile%snow, snow_z0s, snow_z0m )

  if (associated(tile%vegn)) then
     call update_derived_vegn_data(tile%vegn)
     ! USE OF SNOWPACK RAD PROPERTIES FOR INTERCEPTED SNOW IS ERRONEOUS,
     ! NEEDS TO BE CHANGED. TEMPORARY.
     call vegn_radiation ( tile%vegn, cosz, snow_depth, snow_refl_dif, snow_emis, &
                   vegn_refl_dif, vegn_tran_dif, &
                   vegn_refl_dir, vegn_tran_dir, vegn_tran_dir_dir, &
                   vegn_refl_lw, vegn_tran_lw)
     ! (later see if we can remove vegn_cover from c-a-radiation...) TEMPORARY
     call vegn_get_cover ( tile%vegn, snow_depth, vegn_cover)
     call vegn_diffusion ( tile%vegn, vegn_cover, vegn_height, vegn_lai, vegn_sai, vegn_d_leaf)
  else
     ! set radiative properties for null vegetation
     vegn_refl_dif     = 0
     vegn_tran_dif     = 1
     vegn_refl_dir     = 0
     vegn_tran_dir     = 0
     vegn_tran_dir_dir = 1
     vegn_refl_lw      = 0 
     vegn_tran_lw      = 1
     ! set cover for null vegetation
     vegn_cover        = 0
     ! set other parameters for null vegetation
     vegn_height       = 0
     vegn_lai          = 0
     vegn_sai          = 0
     vegn_d_leaf       = 0
  endif

  ! store the values of long-wave optical properties to be used in the update_land_model_fast
  tile%surf_refl_lw = subs_refl_lw  + (snow_refl_lw  - subs_refl_lw ) * snow_area
  tile%vegn_refl_lw = vegn_refl_lw
  tile%vegn_tran_lw = vegn_tran_lw

  
  if(is_watch_point()) then
     write(*,*) '#### update_land_bc_fast ### checkpoint 1 ####'
     __DEBUG3__(cosz, fracday, rrsun)
     __DEBUG2__(vegn_lai,vegn_sai)
     __DEBUG1__(subs_refl_dif)
     __DEBUG1__(subs_refl_dir)
     __DEBUG1__(vegn_refl_dif)
     __DEBUG1__(vegn_tran_dif)
     __DEBUG1__(vegn_refl_dir)
     __DEBUG1__(vegn_tran_dir)
     __DEBUG1__(vegn_tran_dir_dir)
     __DEBUG2__(vegn_refl_lw,vegn_tran_lw)
     write(*,*) '#### update_land_bc_fast ### end of checkpoint 1 ####'
  endif

  snow_area_rad = snow_area
  if (lm2) then
     if(associated(tile%glac)                    ) snow_area_rad = 0
     if(associated(tile%soil).and.vegn_cover>0.01) snow_area_rad = 1
  endif

  call cana_radiation( lm2, &
       subs_refl_dir, subs_refl_dif, subs_refl_lw, &
       snow_refl_dir, snow_refl_dif, snow_refl_lw, &
       snow_area_rad,  &
       vegn_refl_dir, vegn_refl_dif, vegn_tran_dir, vegn_tran_dif, &
       vegn_tran_dir_dir, vegn_refl_lw, vegn_tran_lw, &
       vegn_cover, &
       tile%Sg_dir, tile%Sg_dif, tile%Sv_dir, tile%Sv_dif, &
       tile%land_refl_dir, tile%land_refl_dif )

  call cana_roughness( lm2, &
     subs_z0m, subs_z0s, &
     snow_z0m, snow_z0s, snow_area, &
     vegn_cover,  vegn_height, vegn_lai, vegn_sai, &
     tile%land_d, tile%land_z0m, tile%land_z0s)

  if(is_watch_point()) then
     write(*,*) '#### update_land_bc_fast ### checkpoint 2 ####'
     write(*,*) 'Sg_dir', tile%Sg_dir
     write(*,*) 'Sg_dif', tile%Sg_dif
     write(*,*) 'Sv_dir', tile%Sv_dir
     write(*,*) 'Sv_dif', tile%Sv_dif
     write(*,*) 'land_albedo_dir', tile%land_refl_dir
     write(*,*) 'land_albedo_dif', tile%land_refl_dif
     write(*,*) 'land_z0m', tile%land_z0m
     write(*,*) '#### update_land_bc_fast ### end of checkpoint 2 ####'
  endif

  land2cplr%t_surf         (i,j,k) = tfreeze
  land2cplr%t_ca           (i,j,k) = tfreeze
  land2cplr%tr             (i,j,k, lnd%isphum) = 0.0
  land2cplr%albedo         (i,j,k) = 0.0
  land2cplr%albedo_vis_dir (i,j,k) = 0.0
  land2cplr%albedo_nir_dir (i,j,k) = 0.0
  land2cplr%albedo_vis_dif (i,j,k) = 0.0
  land2cplr%albedo_nir_dif (i,j,k) = 0.0
  land2cplr%rough_mom      (i,j,k) = 0.1
  land2cplr%rough_heat     (i,j,k) = 0.1

  ! Calculate radiative surface temperature. lwup can't be calculated here
  ! based on the available temperatures because it's a result of the implicit 
  ! time step: lwup = lwup0 + DlwupDTg*delta_Tg + ..., so we have to carry it
  ! from the update_land_fast 
  ! Consequence: since update_landbc_fast is called once at the very beginning of 
  ! every run (before update_land_fast is called) lwup from the previous step 
  ! must be stored in the in the restart for reproducibility
  land2cplr%t_surf(i,j,k) = ( tile%lwup/stefan ) ** 0.25

  if (associated(tile%glac)) call glac_get_sfc_temp(tile%glac, grnd_T)
  if (associated(tile%lake)) call lake_get_sfc_temp(tile%lake, grnd_T)
  if (associated(tile%soil)) call soil_get_sfc_temp(tile%soil, grnd_T)
  if (snow_area > 0)         call snow_get_sfc_temp(tile%snow, grnd_T)

  ! set the boundary conditions for the flux exchange
  land2cplr%mask           (i,j,k) = .TRUE.
  land2cplr%tile_size      (i,j,k) = tile%frac

  call cana_state ( tile%cana, land2cplr%t_ca(i,j,k), &
                               land2cplr%tr(i,j,k,lnd%isphum), cana_co2)
!  land2cplr%t_ca           (i,j,k) = tile%cana%prog%T
!  land2cplr%tr             (i,j,k,lnd%isphum) = tile%cana%prog%q
  if(lnd%ico2/=NO_TRACER) then
     land2cplr%tr(i,j,k,lnd%ico2) = cana_co2
  endif
  land2cplr%albedo_vis_dir (i,j,k) = tile%land_refl_dir(BAND_VIS)
  land2cplr%albedo_nir_dir (i,j,k) = tile%land_refl_dir(BAND_NIR)
  land2cplr%albedo_vis_dif (i,j,k) = tile%land_refl_dif(BAND_VIS)
  land2cplr%albedo_nir_dif (i,j,k) = tile%land_refl_dif(BAND_NIR)
  land2cplr%albedo         (i,j,k) = SUM(tile%land_refl_dir + tile%land_refl_dif)/4 ! incorrect, replace with proper weighting later
  land2cplr%rough_mom      (i,j,k) = tile%land_z0m
  land2cplr%rough_heat     (i,j,k) = tile%land_z0s

  if(is_watch_point()) then
     write(*,*)'#### update_land_bc_fast ### output ####'
     write(*,*)'land2cplr%mask',land2cplr%mask(i,j,k)
     write(*,*)'land2cplr%tile_size',land2cplr%tile_size(i,j,k)
     write(*,*)'land2cplr%t_surf',land2cplr%t_surf(i,j,k)
     write(*,*)'land2cplr%t_ca',land2cplr%t_ca(i,j,k)
     write(*,*)'land2cplr%albedo',land2cplr%albedo(i,j,k)
     write(*,*)'land2cplr%rough_mom',land2cplr%rough_mom(i,j,k)
     write(*,*)'land2cplr%rough_heat',land2cplr%rough_heat(i,j,k)
     write(*,*)'land2cplr%tr',land2cplr%tr(i,j,k,:)
     write(*,*)'#### update_land_bc_fast ### end of output ####'
  endif

  ! ---- diagnostic section
  call send_tile_data(id_vegn_cover, vegn_cover, tile%diag)
  call send_tile_data(id_cosz, cosz, tile%diag)
  call send_tile_data(id_albedo_dir, tile%land_refl_dir, tile%diag)
  call send_tile_data(id_albedo_dif, tile%land_refl_dif, tile%diag)
  call send_tile_data(id_vegn_refl_dir, vegn_refl_dir,     tile%diag)
  call send_tile_data(id_vegn_refl_dif, vegn_refl_dif, tile%diag)
  call send_tile_data(id_vegn_refl_lw,  vegn_refl_lw, tile%diag)
  call send_tile_data(id_vegn_tran_dir, vegn_tran_dir_dir, tile%diag)
  call send_tile_data(id_vegn_tran_dif, vegn_tran_dif, tile%diag)
  call send_tile_data(id_vegn_tran_lw,  vegn_tran_lw, tile%diag)
  call send_tile_data(id_vegn_sctr_dir, vegn_tran_dir,     tile%diag)
  call send_tile_data(id_subs_refl_dir, subs_refl_dir, tile%diag)
  call send_tile_data(id_subs_refl_dif, subs_refl_dif, tile%diag)
  call send_tile_data(id_grnd_T,     grnd_T,     tile%diag)

  ! --- debug section
  call check_temp_range(land2cplr%t_ca(i,j,k),'update_land_bc_fast','T_ca')

end subroutine update_land_bc_fast


! ============================================================================
subroutine update_land_bc_slow (land2cplr)
  type(land_data_type), intent(inout) :: land2cplr

  ! ---- local vars 
  integer :: i,j,k,face ! coordinates of the watch point, for debug printout

  call update_topo_rough(land2cplr%rough_scale)
  where (land2cplr%mask) &
       land2cplr%rough_scale = max(land2cplr%rough_mom,land2cplr%rough_scale)
  call get_watch_point(i,j,k,face)
  if ( lnd%face==face.and.             &
       lnd%is<=i.and.i<=lnd%ie.and.    &
       lnd%js<=j.and.j<=lnd%je.and.    &
       k<=size(land2cplr%rough_scale,3)) then
     write(*,*)'#### update_land_bc_slow ### output ####'
     write(*,*)'land2cplr%rough_scale',land2cplr%rough_scale(i,j,k)
     write(*,*)'#### update_land_bc_slow ### end of output ####'
  endif
    
end subroutine update_land_bc_slow


! ============================================================================
subroutine Lnd_stock_pe(bnd,index,value)

type(land_data_type), intent(in)  :: bnd 
integer             , intent(in)  :: index
real                , intent(out) :: value ! Domain water (Kg) or heat (Joules)

integer :: i,j,n
type(land_tile_enum_type)     :: ce,te
type(land_tile_type), pointer :: tile
character(len=128) :: message
integer :: is,ie,js,je
real :: area_factor, river_value
! *_twd are tile water densities (kg water per m2 of tile)
real twd_gas_cana,               twd_liq_glac, twd_sol_glac, &
     twd_liq_lake, twd_sol_lake, twd_liq_soil, twd_sol_soil, &
     twd_liq_snow, twd_sol_snow, twd_liq_vegn, twd_sol_vegn
! *_gcwd are grid-cell water densities (kg water per m2 of land in grid cell)
real gcwd_cana, gcwd_glac, gcwd_lake, gcwd_soil, gcwd_snow, gcwd_vegn
! v_* are global masses of water
real v_cana, v_glac, v_lake, v_soil, v_snow, v_vegn
real cana_q, a_globe

value = 0.0
v_cana = 0.
v_glac = 0.
v_lake = 0.
v_soil = 0.
v_snow = 0.
v_vegn = 0.
if(.not.bnd%pe) return
is = lnd%is
ie = lnd%ie
js = lnd%js
je = lnd%je

! The following is a dirty getaround
if(lnd%cellarea(is,js) < 1.0) then
  area_factor = 4*pi*radius**2 ! lnd%area is fraction of globe
else
  area_factor = 1.0 ! lnd%area is actual area (m**2)
endif

select case(index)
case(ISTOCK_WATER)
  do j = js, je
  do i = is, ie
    ce = first_elmt(lnd%tile_map(i,j))
    te = tail_elmt (lnd%tile_map(i,j))
    gcwd_cana = 0.0; gcwd_glac = 0.0; gcwd_lake = 0.0
    gcwd_soil = 0.0; gcwd_snow = 0.0; gcwd_vegn = 0.0
    do while(ce /= te)
      tile => current_tile(ce)
      twd_gas_cana = 0.0
      twd_liq_glac = 0.0 ; twd_sol_glac = 0.0
      twd_liq_lake = 0.0 ; twd_sol_lake = 0.0
      twd_liq_soil = 0.0 ; twd_sol_soil = 0.0
      twd_liq_snow = 0.0 ; twd_sol_snow = 0.0
      twd_liq_vegn = 0.0 ; twd_sol_vegn = 0.0
      if(associated(tile%cana)) then
        call cana_state ( tile%cana, cana_q=cana_q )
        twd_gas_cana = canopy_air_mass*cana_q
        endif
      if(associated(tile%glac)) &
        call glac_tile_stock_pe(tile%glac, twd_liq_glac, twd_sol_glac)
      if(associated(tile%lake)) &
        call lake_tile_stock_pe(tile%lake, twd_liq_lake, twd_sol_lake)
      if(associated(tile%soil)) &
        call soil_tile_stock_pe(tile%soil, twd_liq_soil, twd_sol_soil)
      if(associated(tile%snow)) &
        call snow_tile_stock_pe(tile%snow, twd_liq_snow, twd_sol_snow)
      if(associated(tile%vegn)) &
        call vegn_tile_stock_pe(tile%vegn, twd_liq_vegn, twd_sol_vegn)
      gcwd_cana = gcwd_cana +  twd_gas_cana                 * tile%frac
      gcwd_glac = gcwd_glac + (twd_liq_glac + twd_sol_glac) * tile%frac
      gcwd_lake = gcwd_lake + (twd_liq_lake + twd_sol_lake) * tile%frac
      gcwd_soil = gcwd_soil + (twd_liq_soil + twd_sol_soil) * tile%frac
      gcwd_snow = gcwd_snow + (twd_liq_snow + twd_sol_snow) * tile%frac
      gcwd_vegn = gcwd_vegn + (twd_liq_vegn + twd_sol_vegn) * tile%frac
      ce=next_elmt(ce)
    enddo
    v_cana = v_cana + gcwd_cana * lnd%area(i,j)*area_factor
    v_glac = v_glac + gcwd_glac * lnd%area(i,j)*area_factor
    v_lake = v_lake + gcwd_lake * lnd%area(i,j)*area_factor
    v_soil = v_soil + gcwd_soil * lnd%area(i,j)*area_factor
    v_snow = v_snow + gcwd_snow * lnd%area(i,j)*area_factor
    v_vegn = v_vegn + gcwd_vegn * lnd%area(i,j)*area_factor
  enddo
  enddo
  value  = v_cana + v_glac + v_lake + v_soil + v_snow + v_vegn
a_globe = 4. * pi * radius**2
case(ISTOCK_HEAT)
  if(.not.stock_warning_issued) then
    call error_mesg('Lnd_stock_pe','Heat stock not yet implemented',NOTE)
    stock_warning_issued = .true.
  endif
! do j = js, je
! do i = is, ie
!   ce = first_elmt(lnd%tile_map(i,j))
!   te = tail_elmt (lnd%tile_map(i,j))
!   grid_cell_heat_density = 0.0
!   do while(ce /= te)
!     tile => current_tile(ce)
!     tile_heat_density = 0.0
!     if(associated(tile%soil)) then
!       do n=1, size(tile%soil%prog)
!       tile_heat_density = tile_heat_density + (tile%soil%prog(n)%T-tfreeze)* &
!                  (tile%soil%heat_capacity_dry(n)*dz(n) + &
!                   clw*tile%soil%prog(n)%wl             + &
!                   csw*tile%soil%prog(n)%ws)
!       enddo
!       tile_heat_density = tile_heat_density + clw*soil%prog(1)%groundwater*(soil%prog(1)%groundwater_T-tfreeze) ! Why is this outside n loop?
!     endif
!     grid_cell_heat_density = grid_cell_heat_density + tile_heat_density * tile%frac
!     ce=next_elmt(ce)
!   enddo
!   grid_cell_heat = grid_cell_heat_density * lnd%area(i,j)*area_factor
!   value = value + grid_cell_heat
! enddo
! enddo
case(ISTOCK_SALT)
  if(.not.stock_warning_issued) then
    call error_mesg('Lnd_stock_pe','Salt stock not yet implemented',NOTE)
    stock_warning_issued = .true.
  endif
case default
  write(message,'(i2,a,i2,a,i2,a,i2,a)') &
  index,' is an invalid stock index. Must be ISTOCK_WATER or ISTOCK_HEAT or ISTOCK_SALT (',ISTOCK_WATER,' or ',ISTOCK_HEAT,' or ', ISTOCK_SALT,')'
  call error_mesg('Lnd_stock_pe',message,FATAL)
end select

call river_stock_pe(index, river_value)
value = value + river_value

if (index.eq.ISTOCK_WATER.and.give_stock_details) then
    call mpp_sum(river_value, pelist=lnd%pelist)
    call mpp_sum(v_cana, pelist=lnd%pelist)
    call mpp_sum(v_glac, pelist=lnd%pelist)
    call mpp_sum(v_lake, pelist=lnd%pelist)
    call mpp_sum(v_soil, pelist=lnd%pelist)
    call mpp_sum(v_snow, pelist=lnd%pelist)
    call mpp_sum(v_vegn, pelist=lnd%pelist)
    write (message,'(a,f10.5)') 'total land storage:',v_cana/a_globe+v_glac/a_globe+ &
        v_lake/a_globe+v_soil/a_globe+v_snow/a_globe+v_vegn/a_globe+river_value/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '...canopy air:',v_cana/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '......glacier:',v_glac/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '.........lake:',v_lake/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '.........soil:',v_soil/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '.........snow:',v_snow/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '.........vegn:',v_vegn/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
    write (message,'(a,7f10.5)') '.......rivers:',river_value/a_globe
    call error_mesg('Lnd_stock_pe',message,NOTE)
endif

end subroutine Lnd_stock_pe


! ============================================================================
! initialize horizontal axes for land grid so that all sub-modules can use them,
! instead of creating their own
subroutine land_diag_init(clonb, clatb, clon, clat, time, domain, &
     id_lon, id_lat, id_band)
  real, intent(in) :: &
       clonb(:), clatb(:), & ! longitudes and latitudes of grid cells vertices,
                             ! specified for the global grid
       clon(:),  clat(:)     ! lon and lat of respective grid cell centers
  type(time_type), intent(in) :: time ! initial time for diagnostic fields
  type(domain2d), intent(in)  :: domain
  integer, intent(out) :: &
       id_lon, id_lat, id_band   ! IDs of respective diag. manager axes

  ! ---- local vars ----------------------------------------------------------
  integer :: id_lonb, id_latb ! IDs for cell boundaries
  integer :: nlon, nlat       ! sizes of respective axes
  integer :: axes(2)          ! array of axes for 2-D fields
  integer :: i

  nlon = size(clon)
  nlat = size(clat)

  if(mpp_get_ntile_count(lnd%domain)==1) then
     ! grid has just one tile, so we assume that the grid is regular lat-lon
     ! define longitude axes and its edges
     id_lonb = diag_axis_init ( &
          'lonb', clonb, 'degrees_E', 'X', 'longitude edges', &
          set_name='land', domain2=domain )
     id_lon  = diag_axis_init (                                                &
          'lon',  clon, 'degrees_E', 'X',  &
          'longitude', set_name='land',  edges=id_lonb, domain2=domain )

     ! define latitude axes and its edges
     id_latb = diag_axis_init ( &
          'latb', clatb, 'degrees_N', 'Y', 'latitude edges',  &
          set_name='land',  domain2=domain   )
     id_lat = diag_axis_init (                                                &
          'lat',  clat, 'degrees_N', 'Y', &
          'latitude', set_name='land', edges=id_latb, domain2=domain   )
  else
     id_lon = diag_axis_init ( 'grid_xt', (/(real(i),i=1,nlon)/), 'degrees_E', 'X', &
          'T-cell longitude', set_name='land',  domain2=domain, aux='geolon_t' )
     id_lat = diag_axis_init ( 'grid_yt', (/(real(i),i=1,nlat)/), 'degrees_N', 'Y', &
          'T-cell latitude', set_name='land',  domain2=domain, aux='geolat_t' )
  endif
  id_band = diag_axis_init (                                                &
       'band',  (/1.0,2.0/), 'unitless', 'Z', &
       'spectral band', set_name='land' )

  ! set up an array of axes, for convenience
  axes = (/id_lon, id_lat/)

  ! register auxilary coordinate variables

  id_geolon_t = register_static_field ( module_name, 'geolon_t', axes, &
       'longitude of grid cell centers', 'degrees_E', missing_value = -1.0e+20 )
  id_geolat_t = register_static_field ( module_name, 'geolat_t', axes, &
       'latitude of grid cell centers', 'degrees_N', missing_value = -1.0e+20 )

  ! register static diagnostic fields

  id_cellarea = register_static_field ( module_name, 'cell_area', axes, &
       'total area in grid cell', 'm2', missing_value=-1.0 )
  id_landarea = register_static_field ( module_name, 'land_area', axes, &
       'land area in grid cell', 'm2', missing_value=-1.0 )
  id_landfrac = register_static_field ( module_name, 'land_frac', axes, &
       'fraction of land in grid cell','unitless', missing_value=-1.0 ) 
  id_no_riv = register_static_field ( module_name, 'no_riv', axes, &
       'indicator of land without rivers','unitless', missing_value=-1.0 ) 

  ! register regular (dynamic) diagnostic fields

  id_VWS = register_tiled_diag_field ( module_name, 'VWS', axes, time, &
             'vapor storage on land', 'kg/m2', missing_value=-1.0e+20 )
  id_VWSc    = register_tiled_diag_field ( module_name, 'VWSc', axes, time, &
             'vapor mass in canopy air', 'kg/m2', missing_value=-1.0e+20 )
  id_LWS = register_tiled_diag_field ( module_name, 'LWS', axes, time, &
             'liquid storage on land', 'kg/m2', missing_value=-1.0e+20 )
  id_LWSv    = register_tiled_diag_field ( module_name, 'LWSv', axes, time, &
             'liquid interception storage', 'kg/m2', missing_value=-1.0e+20 )
  id_LWSs    = register_tiled_diag_field ( module_name, 'LWSs', axes, time, &
             'liquid storage in snowpack', 'kg/m2', missing_value=-1.0e+20 )
  id_LWSg    = register_tiled_diag_field ( module_name, 'LWSg', axes, time, &
             'liquid ground storage', 'kg/m2', missing_value=-1.0e+20 )
  id_FWS = register_tiled_diag_field ( module_name, 'FWS', axes, time, &
             'frozen storage on land', 'kg/m2', missing_value=-1.0e+20 )
  id_FWSv    = register_tiled_diag_field ( module_name, 'FWSv', axes, time, &
             'frozen interception storage', 'kg/m2', missing_value=-1.0e+20 )
  id_FWSs    = register_tiled_diag_field ( module_name, 'FWSs', axes, time, &
             'frozen storage in snowpack', 'kg/m2', missing_value=-1.0e+20 )
  id_FWSg    = register_tiled_diag_field ( module_name, 'FWSg', axes, time, &
             'frozen ground storage', 'kg/m2', missing_value=-1.0e+20 )
  id_HS = register_tiled_diag_field ( module_name, 'HS', axes, time, &
             'land heat storage', 'J/m2', missing_value=-1.0e+20 )
  id_HSv     = register_tiled_diag_field ( module_name, 'HSv', axes, time, &
             'interception heat storage', 'J/m2', missing_value=-1.0e+20 )
  id_HSs     = register_tiled_diag_field ( module_name, 'HSs', axes, time, &
             'heat storage in snowpack', 'J/m2', missing_value=-1.0e+20 )
  id_HSg     = register_tiled_diag_field ( module_name, 'HSg', axes, time, &
             'ground heat storage', 'J/m2', missing_value=-1.0e+20 )
  id_HSc     = register_tiled_diag_field ( module_name, 'HSc', axes, time, &
             'canopy-air heat storage', 'J/m2', missing_value=-1.0e+20 )

  id_dis_liq   = register_diag_field ( module_name, 'dis_liq', axes, &
       time, 'liquid discharge to ocean', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_dis_ice   = register_diag_field ( module_name, 'dis_ice', axes, &
       time, 'ice discharge to ocean', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_dis_heat   = register_diag_field ( module_name, 'dis_heat', axes, &
       time, 'heat of mass discharge to ocean', 'W/m2', missing_value=-1.0e+20 )
  id_dis_sink   = register_diag_field ( module_name, 'dis_sink', axes, &
       time, 'burial rate of small/negative discharge', 'kg/(m2 s)', missing_value=-1.0e+20 )

  id_precip = register_tiled_diag_field ( module_name, 'precip', axes, time, &
             'precipitation rate', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_hprec = register_tiled_diag_field ( module_name, 'hprec', axes, time, &
             'sensible heat of precipitation', 'W/m2', missing_value=-1.0e+20 )
  id_lprec = register_tiled_diag_field ( module_name, 'lprec_l', axes, time, &
             'rainfall to land', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_lprecv = register_tiled_diag_field ( module_name, 'lprecv', axes, time, &
             'net rainfall to vegetation', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_lprecs = register_tiled_diag_field ( module_name, 'lprecs', axes, time, &
             'rainfall to snow, minus drainage', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_lprecg = register_tiled_diag_field ( module_name, 'lprecg', axes, time, &
             'effective rainfall to ground sfc', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_hlprec  = register_tiled_diag_field ( module_name, 'hlprec', axes, time, &
             'total liq precipitation heat', 'W/m2', missing_value=-1.0e+20)
  id_hlprecv = register_tiled_diag_field ( module_name, 'hlprecv', axes, time, &
             'net liq heat to vegetation', 'W/m2', missing_value=-1.0e+20)
  id_hlprecs = register_tiled_diag_field ( module_name, 'hlprecs', axes, time, &
             'net liq heat to snow', 'W/m2', missing_value=-1.0e+20)
  id_hlprecg = register_tiled_diag_field ( module_name, 'hlprecg', axes, time, &
             'net liq heat to ground sfc', 'W/m2', missing_value=-1.0e+20)
  id_fprec = register_tiled_diag_field ( module_name, 'fprec_l', axes, time, &
             'snowfall to land', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_fprecv = register_tiled_diag_field ( module_name, 'fprecv', axes, time, &
             'net snowfall to vegetation', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_fprecs = register_tiled_diag_field ( module_name, 'fprecs', axes, time, &
             'effective snowfall to snowpack', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_hfprec = register_tiled_diag_field ( module_name, 'hfprec', axes, time, &
             'sens heat of snowfall', 'W/m2', missing_value=-1.0e+20)
  id_hfprecv = register_tiled_diag_field ( module_name, 'hfprecv', axes, time, &
             'net sol heat to vegetation', 'W/m2', missing_value=-1.0e+20)
  id_hfprecs = register_tiled_diag_field ( module_name, 'hfprecs', axes, time, &
             'net sol heat to snow', 'W/m2', missing_value=-1.0e+20)
  id_evap = register_tiled_diag_field ( module_name, 'evap', axes, time, &
             'vapor flux up from land', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_hevap = register_tiled_diag_field ( module_name, 'hevap', axes, time, &
             'sensible heat of evap', 'W/m2', missing_value=-1.0e+20 )
  id_levap   = register_tiled_diag_field ( module_name, 'levap', axes, time, &
             'vapor flux from all liq (inc Tr)', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_levapv = register_tiled_diag_field ( module_name, 'levapv', axes, time, &
             'vapor flux leaving intercepted liquid', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_levaps = register_tiled_diag_field ( module_name, 'levaps', axes, time, &
             'vapor flux leaving snow liquid', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_levapg = register_tiled_diag_field ( module_name, 'levapg', axes, time, &
             'vapor flux from ground liquid', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_hlevap = register_tiled_diag_field ( module_name, 'hlevap', axes, time, &
             'vapor flux heat from liq source', 'W/m2', missing_value=-1.0e+20)
  id_hlevapv = register_tiled_diag_field ( module_name, 'hlevapv', axes, time, &
             'vapor heat from liq interc', 'W/m2', missing_value=-1.0e+20)
  id_hlevaps = register_tiled_diag_field ( module_name, 'hlevaps', axes, time, &
             'vapor heat from snow liq', 'W/m2', missing_value=-1.0e+20)
  id_hlevapg = register_tiled_diag_field ( module_name, 'hlevapg', axes, time, &
             'vapor heat from ground liq', 'W/m2', missing_value=-1.0e+20)
  id_fevap   = register_tiled_diag_field ( module_name, 'fevap', axes, time, &
             'vapor flux from all ice', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_fevapv = register_tiled_diag_field ( module_name, 'fevapv', axes, time, &
             'vapor flux leaving vegn ice', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_fevaps = register_tiled_diag_field ( module_name, 'fevaps', axes, time, &
             'vapor flux leaving snow ice', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_fevapg = register_tiled_diag_field ( module_name, 'fevapg', axes, time, &
             'vapor flux leaving ground ice', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_hfevap = register_tiled_diag_field ( module_name, 'hfevap', axes, time, &
             'vapor flux heat from solid source', 'W/m2', missing_value=-1.0e+20)
  id_hfevapv = register_tiled_diag_field ( module_name, 'hfevapv', axes, time, &
             'vapor heat from sol interc', 'W/m2', missing_value=-1.0e+20)
  id_hfevaps = register_tiled_diag_field ( module_name, 'hfevaps', axes, time, &
             'vapor heat from snow sol', 'W/m2', missing_value=-1.0e+20)
  id_hfevapg = register_tiled_diag_field ( module_name, 'hfevapg', axes, time, &
             'vapor heat from ground sol', 'W/m2', missing_value=-1.0e+20)
  id_runf   = register_tiled_diag_field ( module_name, 'runf', axes, time, &
             'total runoff', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_hrunf   = register_tiled_diag_field ( module_name, 'hrunf', axes, time, &
             'sensible heat of total runoff', 'W/m2', missing_value=-1.0e+20 )
  id_lrunf   = register_tiled_diag_field ( module_name, 'lrunf', axes, time, &
             'total rate of liq runoff', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_lrunfs  = register_tiled_diag_field ( module_name, 'lrunfs', axes, time, &
             'rate of liq runoff via calving', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_lrunfg  = register_tiled_diag_field ( module_name, 'lrunfg', axes, time, &
             'rate of liq runoff, ground', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_hlrunf  = register_tiled_diag_field ( module_name, 'hlrunf', axes, time, &
             'heat of liq runoff', 'W/m2', missing_value=-1.0e+20 )
  id_hlrunfs  = register_tiled_diag_field ( module_name, 'hlrunfs', axes, time, &
             'heat of liq runoff from snow pack', 'W/m2', missing_value=-1.0e+20 )
  id_hlrunfg  = register_tiled_diag_field ( module_name, 'hlrunfg', axes, time, &
             'heat of liq surface runoff', 'W/m2', missing_value=-1.0e+20 )
  id_frunf   = register_tiled_diag_field ( module_name, 'frunf', axes, time, &
             'total rate of solid runoff', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_frunfs  = register_tiled_diag_field ( module_name, 'frunfs', axes, time, &
             'rate of solid calving', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_hfrunf  = register_tiled_diag_field ( module_name, 'hfrunf', axes, time, &
             'heat of total ice runoff', 'W/m2', missing_value=-1.0e+20 )
  id_hfrunfs  = register_tiled_diag_field ( module_name, 'hfrunfs', axes, time, &
             'heat of sol snow runoff', 'W/m2', missing_value=-1.0e+20 )
  id_melt    = register_tiled_diag_field ( module_name, 'melt', axes, time, &
             'total rate of melt', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_meltv   = register_tiled_diag_field ( module_name, 'meltv', axes, time, &
             'rate of melt, interception', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_melts   = register_tiled_diag_field ( module_name, 'melts', axes, time, &
             'rate of snow melt', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_meltg   = register_tiled_diag_field ( module_name, 'meltg', axes, time, &
             'rate of substrate thaw', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_fsw     = register_tiled_diag_field ( module_name, 'fsw', axes, time, &
             'net sw rad to land', 'W/m2', missing_value=-1.0e+20 )
  id_fswv    = register_tiled_diag_field ( module_name, 'fswv', axes, time, &
             'net sw rad to vegetation', 'W/m2', missing_value=-1.0e+20 )
  id_fsws    = register_tiled_diag_field ( module_name, 'fsws', axes, time, &
             'net sw rad to snow', 'W/m2', missing_value=-1.0e+20 )
  id_fswg    = register_tiled_diag_field ( module_name, 'fswg', axes, time, &
             'net sw rad to ground', 'W/m2', missing_value=-1.0e+20 )
  id_flw     = register_tiled_diag_field ( module_name, 'flw', axes, time, &
             'net lw rad to land', 'W/m2', missing_value=-1.0e+20 )
  id_flwv    = register_tiled_diag_field ( module_name, 'flwv', axes, time, &
             'net lw rad to vegetation', 'W/m2', missing_value=-1.0e+20 )
  id_flws    = register_tiled_diag_field ( module_name, 'flws', axes, time, &
             'net lw rad to snow', 'W/m2', missing_value=-1.0e+20 )
  id_flwg    = register_tiled_diag_field ( module_name, 'flwg', axes, time, &
             'net lw rad to ground', 'W/m2', missing_value=-1.0e+20 )
  id_sens    = register_tiled_diag_field ( module_name, 'sens', axes, time, &
             'sens heat flux from land', 'W/m2', missing_value=-1.0e+20 )
  id_sensv   = register_tiled_diag_field ( module_name, 'sensv', axes, time, &
             'sens heat flux from vegn', 'W/m2', missing_value=-1.0e+20 )
  id_senss   = register_tiled_diag_field ( module_name, 'senss', axes, time, &
             'sens heat flux from snow', 'W/m2', missing_value=-1.0e+20 )
  id_sensg   = register_tiled_diag_field ( module_name, 'sensg', axes, time, &
             'sens heat flux from ground', 'W/m2', missing_value=-1.0e+20 )
  id_e_res_1 = register_tiled_diag_field ( module_name, 'e_res_1', axes, time, &
       'canopy air energy residual due to nonlinearities', 'W/m2', missing_value=-1e20)
  id_e_res_2 = register_tiled_diag_field ( module_name, 'e_res_2', axes, time, &
       'canopy energy residual due to nonlinearities', 'W/m2', missing_value=-1e20)
  id_frac = register_tiled_diag_field(module_name,'frac', axes,&
       time, 'fraction of land area', 'unitless', missing_value=-1.0, op=OP_SUM )
  id_area = register_tiled_diag_field(module_name,'area', axes,&
       time, 'area in the grid cell', 'm2', missing_value=-1.0, op=OP_SUM )
  id_ntiles = register_tiled_diag_field(module_name,'ntiles',axes,  &
       time, 'number of tiles', 'unitless', missing_value=-1.0, op=OP_SUM)
  id_z0m     = register_tiled_diag_field ( module_name, 'z0m', axes, time, &
             'momentum roughness of land', 'm', missing_value=-1.0e+20 )
  id_z0s     = register_tiled_diag_field ( module_name, 'z0s', axes, time, &
             'scalar roughness of land', 'm', missing_value=-1.0e+20 )
  id_con_g_h = register_tiled_diag_field ( module_name, 'con_g_h', axes, time, &
       'conductance for sensible heat between ground surface and canopy air', &
       'm/s', missing_value=-1.0 )
  id_transp  = register_tiled_diag_field ( module_name, 'transp', axes, time, &
             'transpiration; = uptake by roots', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_wroff = register_tiled_diag_field ( module_name, 'wroff', axes, time, &
             'rate of liquid runoff to rivers', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_sroff = register_tiled_diag_field ( module_name, 'sroff', axes, time, &
             'rate of solid runoff to rivers', 'kg/(m2 s)', missing_value=-1.0e+20 )
  id_htransp = register_tiled_diag_field ( module_name, 'htransp', axes, time, &
             'heat of transpired vapior', 'W/m2', missing_value=-1.0e+20 )
  id_huptake = register_tiled_diag_field ( module_name, 'huptk', axes, time, &
             'heat of soil water uptake', 'W/m2', missing_value=-1.0e+20 )
  id_hroff = register_tiled_diag_field ( module_name, 'hroff', axes, time, &
             'sensible heat of runoff', 'W/m2', missing_value=-1.0e+20 )
  id_gsnow   = register_tiled_diag_field ( module_name, 'gsnow', axes, time, &
             'sens heat into ground from snow', 'W/m2', missing_value=-1.0e+20 )
  id_gsnow_old=register_tiled_diag_field ( module_name, 'gflux', axes, time, &
             'obsolete, please use "gsnow" instead', 'W/m2', missing_value=-1.0e+20 )
  id_gequil   = register_tiled_diag_field ( module_name, 'gequil', axes, time, &
             'snow-subs equilibration flux', 'W/m2', missing_value=-1.0e+20 )
  id_grnd_flux = register_tiled_diag_field ( module_name, 'grnd_flux', axes, time, &
             'sensible heat into ground from surface', 'W/m2', missing_value=-1.0e+20 )
  id_soil_water_supply = register_tiled_diag_field ( module_name, 'soil_water_supply', axes, time, &
       'maximum rate of soil water supply to vegetation', 'kg/(m2 s)', missing_value=-1e20)
  id_levapg_max = register_tiled_diag_field ( module_name, 'Eg_max', axes, time, &
             'soil_water limit on vapor flux from ground liquid', 'kg/(m2 s)', missing_value=-1.0e+20)
  id_water = register_tiled_diag_field ( module_name, 'water', axes, time, &
             'column-integrated soil water', 'kg/m2', missing_value=-1.0e+20 )
  id_snow = register_tiled_diag_field ( module_name, 'snow', axes, time, &
             'column-integrated snow water', 'kg/m2', missing_value=-1.0e+20 )
  id_Trad    = register_tiled_diag_field ( module_name, 'Trad', axes, time, &
             'radiative sfc temperature', 'degK', missing_value=-1.0e+20 )
  id_Tca     = register_tiled_diag_field ( module_name, 'Tca', axes, time, &
             'canopy-air temperature', 'degK', missing_value=-1.0e+20 )
  id_qca     = register_tiled_diag_field ( module_name, 'qca', axes, time, &
             'canopy-air specific humidity', 'kg/kg', missing_value=-1.0 )
  id_qco2    = register_tiled_diag_field ( module_name, 'qco2', axes, time, &
             'canopy-air CO2 moist mass mixing ratio', 'kg/kg', missing_value=-1.0 )
  id_qco2_dvmr = register_tiled_diag_field ( module_name, 'qco2_dvmr', axes, time, &
             'canopy-air CO2 dry volumetric mixing ratio', 'mol CO2/mol air', missing_value=-1.0 )
  id_fco2    = register_tiled_diag_field ( module_name, 'fco2', axes, time, &
             'flux of CO2 to canopy air', 'kg C/(m2 s)', missing_value=-1.0 )
  id_swdn_dir = register_tiled_diag_field ( module_name, 'swdn_dir', (/id_lon,id_lat,id_band/), time, &
       'downward direct short-wave radiation flux to the land surface', 'W/m2', missing_value=-999.0)
  id_swdn_dif = register_tiled_diag_field ( module_name, 'swdn_dif', (/id_lon,id_lat,id_band/), time, &
       'downward diffuse short-wave radiation flux to the land surface', 'W/m2', missing_value=-999.0)
  id_swup_dir = register_tiled_diag_field ( module_name, 'swup_dir', (/id_lon,id_lat,id_band/), time, &
       'direct short-wave radiation flux reflected by the land surface', 'W/m2', missing_value=-999.0)
  id_swup_dif = register_tiled_diag_field ( module_name, 'swup_dif', (/id_lon,id_lat,id_band/), time, &
       'diffuse short-wave radiation flux reflected by the land surface', 'W/m2', missing_value=-999.0)
  id_lwdn = register_tiled_diag_field ( module_name, 'lwdn', axes, time, &
       'downward long-wave radiation flux to the land surface', 'W/m2', missing_value=-999.0)
  id_vegn_cover = register_tiled_diag_field ( module_name, 'vegn_cover', axes, time, &
             'fraction covered by vegetation', missing_value=-1.0 )
  id_cosz = register_tiled_diag_field ( module_name, 'coszen', axes, time, &
       'cosine of zenith angle', missing_value=-2.0 )
  id_albedo_dir = register_tiled_diag_field ( module_name, 'albedo_dir', &
       (/id_lon,id_lat,id_band/), time, &
       'land surface albedo for direct light', missing_value=-1.0 )
  id_albedo_dif = register_tiled_diag_field ( module_name, 'albedo_dif', &
       (/id_lon,id_lat,id_band/), time, &
       'land surface albedo for diffuse light', missing_value=-1.0 )
  id_vegn_refl_dir = register_tiled_diag_field(module_name, 'vegn_refl_dir', &
       (/id_lon, id_lat, id_band/), time, &
       'black-background canopy reflectivity for direct light',missing_value=-1.0)
  id_vegn_refl_dif = register_tiled_diag_field(module_name, 'vegn_refl_dif', &
       (/id_lon, id_lat, id_band/), time, &
       'black-background canopy reflectivity for diffuse light',missing_value=-1.0)
  id_vegn_refl_lw = register_tiled_diag_field ( module_name, 'vegn_refl_lw', axes, time, &
       'canopy reflectivity for thermal radiation', missing_value=-1.0)
  id_vegn_tran_dir = register_tiled_diag_field(module_name, 'vegn_tran_dir', &
       (/id_lon, id_lat, id_band/), time, &
       'part of direct light that passes through canopy unscattered',missing_value=-1.0)
  id_vegn_tran_dif = register_tiled_diag_field(module_name, 'vegn_tran_dif', &
       (/id_lon, id_lat, id_band/), time, &
       'black-background canopy transmittance for diffuse light',missing_value=-1.0)
  id_vegn_tran_lw = register_tiled_diag_field ( module_name, 'vegn_tran_lw', axes, time, &
       'canopy transmittance for thermal radiation', missing_value=-1.0)
  id_vegn_sctr_dir = register_tiled_diag_field(module_name, 'vegn_sctr_dir', &
       (/id_lon, id_lat, id_band/), time, &
       'part of direct light scattered downward by canopy',missing_value=-1.0)
  id_subs_refl_dir = register_tiled_diag_field(module_name, 'subs_refl_dir', &
       (/id_lon, id_lat, id_band/), time, &
       'substrate reflectivity for direct light',missing_value=-1.0)
  id_subs_refl_dif = register_tiled_diag_field(module_name, 'subs_refl_dif', &
       (/id_lon, id_lat, id_band/), time, &
       'substrate reflectivity for diffuse light',missing_value=-1.0)
  id_grnd_T = register_tiled_diag_field ( module_name, 'Tgrnd', axes, time, &
       'ground surface temperature', 'degK', missing_value=-1.0 )
end subroutine land_diag_init

! the code below defines the accessor routines that are used to access fields of the 
! tile data structure in collective operations, like restart i/o. Fore example, a statement
! DEFINE_LAND_ACCESSOR_0D(real,lwup)
! defines a function "land_lwup_ptr" that, given a tile, returns a pointer to the field
! called "lwup" in this tile. The procedure implementing a collective operation would
! enumerate all the tiles within the domain, call accessor routine for each of them, and
! get or set the value pointed to by the accessor routine.
#define DEFINE_LAND_ACCESSOR_0D(xtype,x) subroutine land_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p;p=>NULL();if(associated(t))p=>t%x;end subroutine

DEFINE_LAND_ACCESSOR_0D(real,frac)
DEFINE_LAND_ACCESSOR_0D(real,lwup)
DEFINE_LAND_ACCESSOR_0D(real,e_res_1)
DEFINE_LAND_ACCESSOR_0D(real,e_res_2)

! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function land_tile_exists(tile)
  type(land_tile_type), pointer :: tile
  land_tile_exists = associated(tile)
end function land_tile_exists

#define DEFINE_TAG_ACCESSOR(x) subroutine  x ## _tag_ptr(t,p);\
type(land_tile_type),pointer::t;integer,pointer::p;p=>NULL();if(associated(t))\
then;if (associated(t%x)) p=>t%x%tag;endif;end subroutine

DEFINE_TAG_ACCESSOR(glac)
DEFINE_TAG_ACCESSOR(lake)
DEFINE_TAG_ACCESSOR(soil)
DEFINE_TAG_ACCESSOR(vegn)

end module land_model_mod
   


module land_tile_mod

use fms_mod, only : error_mesg, FATAL

use land_constants_mod, only : NBANDS
use glac_tile_mod, only : &
     glac_tile_type, new_glac_tile, delete_glac_tile, glac_is_selected, &
     glac_tiles_can_be_merged, merge_glac_tiles, get_glac_tile_tag, &
     glac_tile_stock_pe, glac_tile_heat
use lake_tile_mod, only : &
     lake_tile_type, new_lake_tile, delete_lake_tile, lake_is_selected, &
     lake_tiles_can_be_merged, merge_lake_tiles, get_lake_tile_tag, &
     lake_tile_stock_pe, lake_tile_heat
use soil_tile_mod, only : &
     soil_tile_type, new_soil_tile, delete_soil_tile, soil_is_selected, &
     soil_tiles_can_be_merged, merge_soil_tiles, get_soil_tile_tag, &
     soil_tile_stock_pe, soil_tile_heat
use cana_tile_mod, only : &
     cana_tile_type, new_cana_tile, delete_cana_tile, cana_is_selected, &
     cana_tiles_can_be_merged, merge_cana_tiles, get_cana_tile_tag, &
     cana_tile_stock_pe, cana_tile_carbon, cana_tile_heat
use vegn_tile_mod, only : &
     vegn_tile_type, new_vegn_tile, delete_vegn_tile, vegn_is_selected, &
     vegn_tiles_can_be_merged, merge_vegn_tiles, get_vegn_tile_tag, &
     vegn_tile_stock_pe, vegn_tile_carbon, vegn_tile_heat
use snow_tile_mod, only : &
     snow_tile_type, new_snow_tile, delete_snow_tile, snow_is_selected, &
     snow_tiles_can_be_merged, merge_snow_tiles, get_snow_tile_tag, &
     snow_tile_stock_pe, snow_tile_heat
use land_tile_selectors_mod, only : tile_selector_type, &
     SEL_SOIL, SEL_VEGN, SEL_LAKE, SEL_GLAC, SEL_SNOW, SEL_CANA
use tile_diag_buff_mod, only : &
     diag_buff_type, new_diag_buff, delete_diag_buff

implicit none
private
! ==== public interfaces =====================================================
public :: land_tile_type
public :: land_tile_list_type
public :: land_tile_enum_type
public :: diag_buff_type

! operations with tile
public :: new_land_tile, delete_land_tile
public :: land_tiles_can_be_merged, merge_land_tiles

public :: get_tile_tags ! returns the tags of the sub-model tiles
public :: get_tile_water ! returns liquid and frozen water masses
public :: land_tile_carbon ! returns total carbon in the tile
public :: land_tile_heat ! returns tile heat content

! operations with tile lists and tile list enumerators
public :: land_tile_list_init, land_tile_list_end
public :: first_elmt, tail_elmt
public :: operator(==), operator(/=) ! comparison of two enumerators
public :: next_elmt, prev_elmt ! enumerator advance operations
public :: current_tile ! returns pointer to the tile at a position
public :: insert  ! inserts a tile at a given position, or appends it to a list
public :: erase   ! erases tile at current position
public :: remove  ! removes tile at current position, but does not delete it
public :: get_elmt_indices ! returns i,j,k of current element

public :: empty   ! returns true if the list of tiles is empty
public :: nitems  ! count of items in list

public :: tile_is_selected

public :: print_land_tile_info
public :: print_land_tile_statistics
! ==== end of public interfaces ==============================================
interface new_land_tile
   module procedure land_tile_ctor
   module procedure land_tile_copy_ctor
end interface

interface first_elmt
   module procedure land_tile_list_begin_0d
   module procedure land_tile_list_begin_2d
end interface
interface tail_elmt
   module procedure land_tile_list_end_0d
   module procedure land_tile_list_end_2d
end interface

interface operator(==)
   module procedure enums_are_equal
end interface
interface operator(/=)
   module procedure enums_are_not_equal
end interface

interface insert
   module procedure insert_at_position, insert_in_list
end interface
interface remove
   module procedure remove_at_position, remove_all_from_list
end interface
interface erase
   module procedure erase_at_position, erase_all_from_list
end interface
interface nitems
   module procedure n_items_in_list
end interface


! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: land_tile.F90,v 17.0 2009/07/21 03:02:24 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

! ==== data types ============================================================
! land_tile_type describes the structure of the land model tile; basically
! it is a container for tile-specific data, plus some information common to 
! all of them: fraction of tile area, etc.
type :: land_tile_type
   integer :: tag = 0   ! defines type of the tile 

   real    :: frac      ! fractional tile area, dimensionless
   type(glac_tile_type), pointer :: glac => NULL() ! glacier model data
   type(lake_tile_type), pointer :: lake => NULL() ! lake model data
   type(soil_tile_type), pointer :: soil => NULL() ! soil model data
   type(snow_tile_type), pointer :: snow => NULL() ! snow data
   type(cana_tile_type), pointer :: cana => NULL() ! canopy air data
   type(vegn_tile_type), pointer :: vegn => NULL() ! vegetation model data

   type(diag_buff_type), pointer :: diag => NULL() ! diagnostic data storage
   
   ! data that are carried over from the previous time step
   real :: Sg_dir(NBANDS), Sg_dif(NBANDS) ! fractions of downward direct and 
       ! diffuse short-wave radiation absorbed by ground and snow
   real :: Sv_dir(NBANDS), Sv_dif(NBANDS) ! fractions of downward direct and 
       ! diffuse radiation absorbed by the vegetation.
   real :: land_refl_dir(NBANDS), land_refl_dif(NBANDS)
   
   real :: land_d, land_z0m, land_z0s
   real :: surf_refl_lw ! long-wave reflectivity of the ground surface (possibly snow-covered)
   real :: vegn_refl_lw ! black background long-wave reflectivity of the vegetation canopy
   real :: vegn_tran_lw ! black background long-wave transmissivity of the vegetation canopy

   real :: lwup     = 200.0  ! upward long-wave flux from the entire land (W/m2), the result of
           ! the implicit time step -- used in update_bc_fast to return to the flux exchange.
   real :: e_res_1  = 0.0 ! energy residual in canopy air EB equation
   real :: e_res_2  = 0.0 ! energy residual in canopy EB equation
   real :: runon_l  = 0.0 ! water discharged by rivers into the tile, kg/(m2 s)
   real :: runon_s  = 0.0 ! snow discharged by rivers into the tile, kg/(m2 s)
   real :: runon_H  = 0.0 ! heat carried by water discharged by rivers into the tile, W/m2
   real :: runon_Hl  = 0.0 ! heat carried by water discharged by rivers into the tile, W/m2
   real :: runon_Hs  = 0.0 ! heat carried by water discharged by rivers into the tile, W/m2
end type land_tile_type

! tile_list_type provides a container for the tiles
type :: land_tile_list_type
   private
   type(land_tile_list_node_type), pointer :: head => NULL()
end type land_tile_list_type

! land_tile_enum_type provides a enumerator of tiles -- a data structure
! that allows to walk through all tiles in a container (or a 2D array of 
! containers) without bothering with details of container implementation
type :: land_tile_enum_type
   private
   type(land_tile_list_type), pointer :: &
        tiles(:,:) => NULL()  ! pointer to array of tiles to walk -- may be disassociated
   integer :: i=0,j=0 ! indices in the above array
   integer :: k=0     ! number of the current tile in its container
   integer :: io,jo   ! offsets of indices (to keep track of non-1 ubounds of tiles array)
   type(land_tile_list_node_type), pointer :: node => NULL() ! pointer to the current container node
end type land_tile_enum_type

! private type -- used internally to implement tile lists
type :: land_tile_list_node_type
   type(land_tile_list_node_type), pointer :: prev => NULL()
   type(land_tile_list_node_type), pointer :: next => NULL()
   type(land_tile_type), pointer :: data => NULL()
end type land_tile_list_node_type

! ==== module data ===========================================================
integer :: n_created_land_tiles = 0 ! total number of created tiles
integer :: n_deleted_land_tiles = 0 ! total number of deleted tiles


contains 

! #### land_tile_type and operations #########################################

! ============================================================================
! tile constructor: given a list of sub-model tile tags, creates a land tile
! calls sub-tile constructors from individual component models
function land_tile_ctor(frac,glac,lake,soil,vegn,tag) result(tile)
  real   , optional, intent(in) :: frac ! fractional area of tile
  integer, optional, intent(in) :: &
               glac,lake,soil,vegn ! kinds of respective tiles
  integer, optional, intent(in) :: tag  ! general tile tag
  type(land_tile_type), pointer :: tile ! return value

  ! ---- local vars
  integer :: glac_, lake_, soil_, vegn_
  
  ! initialize internal variables
  glac_ = -1 ; if(present(glac)) glac_ = glac
  lake_ = -1 ; if(present(lake)) lake_ = lake
  soil_ = -1 ; if(present(soil)) soil_ = soil
  vegn_ = -1 ; if(present(vegn)) vegn_ = vegn
  
  allocate(tile)
  ! fill common fields
  tile%frac = 0.0 ; if(present(frac)) tile%frac = frac
  tile%tag  = 0   ; if(present(tag))  tile%tag  = tag

  ! create sub-model tiles
  tile%cana => new_cana_tile()
  if(glac_>=0) tile%glac => new_glac_tile(glac_)
  if(lake_>=0) tile%lake => new_lake_tile(lake_)
  tile%snow => new_snow_tile()
  if(soil_>=0) tile%soil => new_soil_tile(soil_)
  if(vegn_>=0) tile%vegn => new_vegn_tile(vegn_)

  ! create a buffer for diagnostic output
  tile%diag=>new_diag_buff()

  ! increment total number of created files for tile statistics
  n_created_land_tiles = n_created_land_tiles + 1

end function land_tile_ctor


! ============================================================================
function land_tile_copy_ctor(t) result(tile)
  type(land_tile_type), intent(in) :: t    ! tile to copy
  type(land_tile_type), pointer :: tile ! return value

  allocate(tile)
  tile = t ! copy all non-pointer members
  if (associated(t%glac)) tile%glac=>new_glac_tile(t%glac)
  if (associated(t%lake)) tile%lake=>new_lake_tile(t%lake)
  if (associated(t%soil)) tile%soil=>new_soil_tile(t%soil)
  if (associated(t%snow)) tile%snow=>new_snow_tile(t%snow)
  if (associated(t%cana)) tile%cana=>new_cana_tile(t%cana)
  if (associated(t%vegn)) tile%vegn=>new_vegn_tile(t%vegn)

  if (associated(t%diag)) tile%diag=>new_diag_buff(t%diag)
end function land_tile_copy_ctor


! ============================================================================
! tile destructor -- releases memory occupied by the tile;
! calls sub-model tile destructors to free the memory of the components
subroutine delete_land_tile(tile)
  type(land_tile_type), pointer :: tile ! tile to delete

  if (.not.associated(tile)) return

  if (associated(tile%glac)) call delete_glac_tile(tile%glac)
  if (associated(tile%lake)) call delete_lake_tile(tile%lake)
  if (associated(tile%soil)) call delete_soil_tile(tile%soil)
  if (associated(tile%snow)) call delete_snow_tile(tile%snow)
  if (associated(tile%cana)) call delete_cana_tile(tile%cana)
  if (associated(tile%vegn)) call delete_vegn_tile(tile%vegn)
  
  ! deallocate diagnostic storage
  call delete_diag_buff(tile%diag)

  ! release the tile memory
  deallocate(tile)
  
  ! increment the number of deleted files for tile statistics
  n_deleted_land_tiles = n_deleted_land_tiles + 1

end subroutine delete_land_tile


! ============================================================================
! returns tags of the component model tiles
subroutine get_tile_tags(tile,land,glac,lake,soil,snow,cana,vegn)
   type(land_tile_type), intent(in)  :: tile
   integer, optional,    intent(out) :: land,glac,lake,soil,snow,cana,vegn

   if(present(land)) land=tile%tag
   if(present(glac)) then
      glac=-HUGE(glac)
      if (associated(tile%glac)) glac=get_glac_tile_tag(tile%glac)
   endif
   if(present(lake)) then
      lake=-HUGE(lake)
      if (associated(tile%lake)) lake=get_lake_tile_tag(tile%lake)
   endif
   if(present(soil)) then
      soil=-HUGE(soil)
      if (associated(tile%soil)) soil=get_soil_tile_tag(tile%soil)
   endif
   if(present(snow)) then
      snow=-HUGE(snow)
      if (associated(tile%snow)) snow=get_snow_tile_tag(tile%snow)
   endif
   if(present(cana)) then
      cana=-HUGE(cana)
      if (associated(tile%cana)) cana=get_cana_tile_tag(tile%cana)
   endif
   if(present(vegn)) then
      vegn=-HUGE(vegn)
      if (associated(tile%vegn)) vegn=get_vegn_tile_tag(tile%vegn)
   endif
end subroutine


! ============================================================================
! returns totals water and ice masses associated with tile
subroutine get_tile_water(tile, lmass, fmass)
  type(land_tile_type), intent(in) :: tile
  real, intent(out) :: lmass, fmass ! liquid and solid water masses, kg/m2

  ! ---- local vars
  real :: lm, fm

  lmass = 0; fmass = 0
  if (associated(tile%cana)) then
     call cana_tile_stock_pe(tile%cana, lm, fm)
     lmass = lmass+lm ; fmass = fmass + fm
  endif
  if (associated(tile%glac)) then
     call glac_tile_stock_pe(tile%glac, lm, fm)
     lmass = lmass+lm ; fmass = fmass + fm
  endif
  if (associated(tile%lake)) then
     call lake_tile_stock_pe(tile%lake, lm, fm)
     lmass = lmass+lm ; fmass = fmass + fm
  endif
  if (associated(tile%soil)) then
     call soil_tile_stock_pe(tile%soil, lm, fm)
     lmass = lmass+lm ; fmass = fmass + fm
  endif
  if (associated(tile%snow)) then
     call snow_tile_stock_pe(tile%snow, lm, fm)
     lmass = lmass+lm ; fmass = fmass + fm
  endif
  if (associated(tile%vegn)) then
     call vegn_tile_stock_pe(tile%vegn, lm, fm)
     lmass = lmass+lm ; fmass = fmass + fm
  endif

end subroutine


! ============================================================================
! returns total tile carbon, kg C/m2
function land_tile_carbon(tile) result(carbon) ; real carbon
  type(land_tile_type), intent(in) :: tile

  carbon = 0
  if (associated(tile%cana)) &
     carbon = carbon + cana_tile_carbon(tile%cana)
  if (associated(tile%vegn)) &
     carbon = carbon + vegn_tile_carbon(tile%vegn)
end function 


! ============================================================================
! returns total heat content of the tile
function land_tile_heat(tile) result(heat) ; real heat
  type(land_tile_type), intent(in) :: tile

  heat = 0
  if (associated(tile%cana)) &
       heat = heat+cana_tile_heat(tile%cana)
  if (associated(tile%glac)) &
       heat = heat+glac_tile_heat(tile%glac)
  if (associated(tile%lake)) &
       heat = heat+lake_tile_heat(tile%lake)
  if (associated(tile%soil)) &
       heat = heat+soil_tile_heat(tile%soil)
  if (associated(tile%snow)) &
       heat = heat+snow_tile_heat(tile%snow)
  if (associated(tile%vegn)) &
       heat = heat+vegn_tile_heat(tile%vegn)
end function


! ============================================================================
! returns true if two land tiles can be merged 
function land_tiles_can_be_merged(tile1,tile2) result (answer)
   logical :: answer ! returned value
   type(land_tile_type), intent(in) :: tile1, tile2
   
   ! make sure that the two tiles have the same components. For 
   ! uniformity every component is checked, even though snow and
   ! cana are always present in current design
   answer = (associated(tile1%glac).eqv.associated(tile2%glac)).and. &
            (associated(tile1%lake).eqv.associated(tile2%lake)).and. &
            (associated(tile1%soil).eqv.associated(tile2%soil)).and. &
            (associated(tile1%snow).eqv.associated(tile2%snow)).and. &
            (associated(tile1%cana).eqv.associated(tile2%cana)).and. &
            (associated(tile1%vegn).eqv.associated(tile2%vegn))
     
   if (answer.and.associated(tile1%glac)) &
      answer = answer.and.glac_tiles_can_be_merged(tile1%glac,tile2%glac)
   if (answer.and.associated(tile1%lake)) &
      answer = answer.and.lake_tiles_can_be_merged(tile1%lake,tile2%lake)
   if (answer.and.associated(tile1%soil)) &
      answer = answer.and.soil_tiles_can_be_merged(tile1%soil,tile2%soil)
   if (answer.and.associated(tile1%cana)) &
      answer = answer.and.cana_tiles_can_be_merged(tile1%cana,tile2%cana)
   if (answer.and.associated(tile1%snow)) &
      answer = answer.and.snow_tiles_can_be_merged(tile1%snow,tile2%snow)
   if (answer.and.associated(tile1%vegn)) &
      answer = answer.and.vegn_tiles_can_be_merged(tile1%vegn,tile2%vegn)
   
end function

! ============================================================================
! merges the two tiles, putting merged state into the second tile. The first
! tile is unchanged
subroutine merge_land_tiles(tile1,tile2)
  type(land_tile_type), intent(in)    :: tile1
  type(land_tile_type), intent(inout) :: tile2

  ! ---- local vars
  real :: x1,x2

  if(associated(tile1%glac)) &
       call merge_glac_tiles(tile1%glac, tile1%frac, tile2%glac, tile2%frac)
  if(associated(tile1%lake)) &
       call merge_lake_tiles(tile1%lake, tile1%frac, tile2%lake, tile2%frac)
  if(associated(tile1%soil)) &
       call merge_soil_tiles(tile1%soil, tile1%frac, tile2%soil, tile2%frac)
  
  if(associated(tile1%cana)) &
       call merge_cana_tiles(tile1%cana, tile1%frac, tile2%cana, tile2%frac)
  if(associated(tile1%snow)) &
       call merge_snow_tiles(tile1%snow, tile1%frac, tile2%snow, tile2%frac)

  if(associated(tile1%vegn)) &
       call merge_vegn_tiles(tile1%vegn, tile1%frac, tile2%vegn, tile2%frac)

  ! calculate normalized weights
  x1 = tile1%frac/(tile1%frac+tile2%frac)
  x2 = 1.0 - x1

#define __MERGE__(field) tile2%field = x1*tile1%field + x2*tile2%field
  __MERGE__(lwup)
  __MERGE__(e_res_1)
  __MERGE__(e_res_2)
  __MERGE__(runon_l)
  __MERGE__(runon_s)
  __MERGE__(runon_H)
  __MERGE__(runon_Hl)
  __MERGE__(runon_Hs)
#undef __MERGE__

  tile2%frac = tile1%frac + tile2%frac
end subroutine

! #### tile container ########################################################

! ============================================================================
! tile list constructor: initializes essential innards of tile collection
! for future use. In current implementation, it is safe to call this function
! on a tile list more then once
subroutine land_tile_list_init(list)
  type(land_tile_list_type), intent(inout) :: list

  if (.not.associated(list%head)) then
     allocate(list%head)
     list%head%prev=>list%head
     list%head%next=>list%head
  endif
end subroutine land_tile_list_init

! ============================================================================
! tile list destructor: destroys the list of tiles. NOTE that it also destroys
! all the tiles that are still in the list.
subroutine land_tile_list_end(list)
  type(land_tile_list_type), intent(inout) :: list

  if(associated(list%head)) then
     call erase(list)
     deallocate(list%head)
  endif
end subroutine land_tile_list_end

! ============================================================================
subroutine check_tile_list_inited(list)
  type(land_tile_list_type), intent(in) :: list

  if (.not.associated(list%head)) &
     call error_mesg('land_tile_mod','tile container was not initialized before use', FATAL)
     
end subroutine


! ============================================================================
! returns true is the list is empty
function empty(list)
  logical empty
  type(land_tile_list_type), intent(in) :: list

  empty = .not.associated(list%head)
  if (.not.empty) &
       empty = associated(list%head%next,list%head)

end function empty

! ============================================================================
! returns the number of items currently stored in the list
function n_items_in_list(list) result (n)
  type(land_tile_list_type), intent(in) :: list
  integer :: n

  type(land_tile_list_node_type), pointer :: node

  n=0; 
  if(.not.associated(list%head)) return

  node => list%head%next
  do while ( .not.(associated(node,list%head)) )
     n = n+1
     node => node%next
  enddo
end function n_items_in_list

! ============================================================================
subroutine insert_in_list(tile,list)
  type(land_tile_type),           pointer :: tile
  type(land_tile_list_type), intent(inout) :: list

  call insert_at_position(tile,tail_elmt(list))

end subroutine insert_in_list


! ============================================================================
subroutine remove_all_from_list(list)
  type(land_tile_list_type), intent(inout) :: list
  
  type(land_tile_enum_type) :: ce
  ce=first_elmt(list)
  do while(ce/=tail_elmt(list))
     call remove_at_position(ce)
  enddo
end subroutine remove_all_from_list


! ============================================================================
subroutine erase_all_from_list(list)
  type(land_tile_list_type), intent(inout) :: list
  
  type(land_tile_enum_type) :: ce
  ce=first_elmt(list)
  do while(ce/=tail_elmt(list))
     call erase_at_position(ce)
  enddo
end subroutine erase_all_from_list



! #### tile container enumerator #############################################

! ============================================================================
! returns enumerator pointing to the first element of the container
function land_tile_list_begin_0d(list) result(ce)
  type(land_tile_enum_type) :: ce  ! return value
  type(land_tile_list_type), intent(in) :: list

  call check_tile_list_inited(list)
  ce%node=>list%head%next
  ce%i = 1 ; ce%j = 1 ; ce%k = 1 
end function


! ============================================================================
! returns enumerator pointing to the first element of the 2D array of 
! containers 
function land_tile_list_begin_2d(tiles, is, js) result(ce)
  type(land_tile_enum_type) :: ce  ! return value
  type(land_tile_list_type), intent(in), target :: tiles(:,:)
  integer, intent(in), optional :: is,js ! origin of the array
  
  integer :: i,j

  ! list up pointer to the array of containers
  ce%tiles=>tiles

  ! initialize offsets of indices
  ce%io = 0; ce%jo = 0;
  if(present(is)) ce%io = is-lbound(tiles,1)
  if(present(js)) ce%jo = js-lbound(tiles,2)

  ! initialize current position in the array of containers -- find
  ! first non-empty container and list the pointer to the current
  ! container node
  ce%k = 1
  do j = lbound(tiles,2),ubound(tiles,2)
  do i = lbound(tiles,1),ubound(tiles,1)
     call check_tile_list_inited(tiles(i,j))
     ce%node => tiles(i,j)%head%next
     ce%i = i ; ce%j = j
     if(associated(ce%node%data)) return
  enddo
  enddo
end function


! ============================================================================
! returns enumerator pointing to the end of container: actually the next element 
! behind the last element of the container
function land_tile_list_end_0d(list) result (ce)
  type(land_tile_enum_type) :: ce ! return value
  type(land_tile_list_type), intent(in) :: list
  
  call check_tile_list_inited(list)
  ce%node=>list%head
  ce%i = 1 ; ce%j = 1 ; ce%k = nitems(list)+1
end function


! ============================================================================
! returns enumerator pointing to the end of 2D array of containers: actually 
! the next element behind the last element of the last container
function land_tile_list_end_2d(tiles,is,js) result (ce)
  type(land_tile_enum_type) :: ce ! return value
  type(land_tile_list_type), intent(in), target :: tiles(:,:)
  integer, intent(in), optional :: is,js ! lower boundaries of the array

  ! list up pointer to the array of containers
  ce%tiles=>tiles

  ! initialize offsets of indices
  ce%io = 0; ce%jo = 0;
  if(present(is)) ce%io = is-lbound(tiles,1)
  if(present(js)) ce%jo = js-lbound(tiles,2)

  ! initialize current position in the array of containers 
  ce%i = ubound(tiles,1)
  ce%j = ubound(tiles,2)
  ce%k = nitems(tiles(ce%i,ce%j))+1

  ! list the pointer to the current tile
  call check_tile_list_inited(tiles(ce%i,ce%j))
  ce%node=>tiles(ce%i,ce%j)%head

end function


! ============================================================================
! returns enumerator pointing to the next element of the container.
function next_elmt(pos0) result(ce)
  type(land_tile_enum_type) :: ce ! return value
  type(land_tile_enum_type), intent(in) :: pos0

  integer :: is,ie,js,je

  ce = pos0
  ce%node => ce%node%next ; ce%k = ce%k+1
  if(associated(ce%tiles)) then
     is = lbound(ce%tiles,1); ie = ubound(ce%tiles,1)
     js = lbound(ce%tiles,2); je = ubound(ce%tiles,2)
     do while(.not.associated(ce%node%data))
        ce%k = 1; ! reset tile index
        if(ce%i<ie)then
           ce%i = ce%i+1
        else if(ce%j<je) then
           ce%i = is
           ce%j = ce%j + 1
        else
           return
        endif
        call check_tile_list_inited(ce%tiles(ce%i,ce%j))
        ce%node => ce%tiles(ce%i,ce%j)%head%next
     enddo
  endif
end function


! ============================================================================
! returns enumerator pointing to the previous element of the container.
function prev_elmt(pos0) result(ce)
  type(land_tile_enum_type) :: ce ! return value
  type(land_tile_enum_type), intent(in) :: pos0

  integer :: is,ie,js,je

  ce = pos0
  ce%node => ce%node%prev ; ce%k = ce%k - 1
  if(associated(ce%tiles)) then
     is = lbound(ce%tiles,1); ie = ubound(ce%tiles,1)
     js = lbound(ce%tiles,2); je = ubound(ce%tiles,2)
     do while(.not.associated(ce%node%data))
        ce%k = 1; ! reset tile index
        if(ce%i>is)then
           ce%i = ce%i - 1
        else if(ce%j>js) then
           ce%i = ie
           ce%j = ce%j - 1
        else
           return
        endif
        call check_tile_list_inited(ce%tiles(ce%i,ce%j))
        ce%node => ce%tiles(ce%i,ce%j)%head%prev
        ce%k    =  nitems(ce%tiles(ce%i,ce%j))
     enddo
  endif

end function

! ============================================================================
! returns TRUE if both enums refer to the same list node (and, therefore, tile)
! or if both do not refer to anything. 
function enums_are_equal(pos1,pos2) result(ret)
  logical :: ret ! return value
  type(land_tile_enum_type), intent(in) :: pos1,pos2
  
  if(associated(pos1%node)) then
     ret = associated(pos1%node,pos2%node)
  else
     ret = .not.associated(pos2%node)
  endif
end function enums_are_equal

! ============================================================================
! returns TRUE if two enumerators are not equal
function enums_are_not_equal(pos1,pos2) result(ret)
  logical :: ret ! return value
  type(land_tile_enum_type), intent(in) :: pos1,pos2

  ret=.not.enums_are_equal(pos1,pos2)
end function enums_are_not_equal

! ============================================================================
! returns pointer to the tile currently addressed by the enumerator
function current_tile(ce) result(ptr)
  type(land_tile_type), pointer :: ptr ! return value
  type(land_tile_enum_type), intent(in) :: ce 

  ptr => ce%node%data
end function 

! ============================================================================
! returns indices corresponding to the enumerator; for enumerator associated
! with a single tile list (not with 2D array of lists) returned i and j are 
! equal to 1
subroutine get_elmt_indices(ce,i,j,k)
  type(land_tile_enum_type), intent(in) :: ce 
  integer, intent(out), optional :: i,j,k

  if (present(i)) i = ce%i+ce%io
  if (present(j)) j = ce%j+ce%jo
  if (present(k)) k = ce%k

end subroutine

! ============================================================================
! inserts tile at the position indicated by enumerator: in fact right in front 
! of it. 
subroutine insert_at_position(tile,ce)
  type(land_tile_type),         pointer :: tile
  type(land_tile_enum_type), intent(in) :: ce

  ! local vars
  type(land_tile_list_node_type), pointer :: node,n,p

  allocate(node)
  node%data=>tile

  n=>ce%node  ; p=>n%prev

  node%next=>n ; node%prev=>p
  n%prev=>node ; p%next=>node
  
end subroutine insert_at_position

! ============================================================================
subroutine remove_at_position(enum)
  type(land_tile_enum_type), intent(inout) :: enum

  type(land_tile_list_node_type),pointer :: n,p
  type(land_tile_enum_type) :: next
  
  if(.not.associated(enum%node)) &
     call error_mesg('remove_at_position','attempt to remove tail element of a list', FATAL)

  next = next_elmt(enum)
  
  n => enum%node%next
  p => enum%node%prev

  n%prev=>p ; p%next=>n
  deallocate(enum%node)
  
  enum=next
  if(enum%k>1) enum%k = enum%k-1

end subroutine remove_at_position

! ============================================================================
subroutine erase_at_position(ce)
  type(land_tile_enum_type), intent(inout) :: ce

  type(land_tile_type), pointer :: tile

  tile=>current_tile(ce)
  call remove_at_position(ce)
  call delete_land_tile(tile)

end subroutine erase_at_position


! ============================================================================
function tile_is_selected(tile, sel)
! returns true if the tile fits specified selector
  logical :: tile_is_selected
  type(land_tile_type)    , intent(in) :: tile
  type(tile_selector_type), intent(in) :: sel

  tile_is_selected = .FALSE.
  select case(sel%tag)
  case(SEL_SOIL)
     if(associated(tile%soil)) & 
          tile_is_selected = soil_is_selected(tile%soil,sel)
  case(SEL_VEGN)
     if(associated(tile%vegn)) &
          tile_is_selected = vegn_is_selected(tile%vegn,sel)
  case(SEL_LAKE)
     if(associated(tile%lake)) &
          tile_is_selected = lake_is_selected(tile%lake,sel)
  case(SEL_GLAC)
     if(associated(tile%glac)) &
          tile_is_selected = glac_is_selected(tile%glac,sel)
  case(SEL_SNOW)
     if(associated(tile%snow)) &
          tile_is_selected = snow_is_selected(tile%snow,sel)
  case(SEL_CANA)
     if(associated(tile%cana)) &
          tile_is_selected = cana_is_selected(tile%cana,sel)
  case default
     tile_is_selected=.true.
  end select

end function tile_is_selected


! ============================================================================
subroutine print_land_tile_info(tile)
  type(land_tile_type), intent(in) :: tile
  
  write(*,'("(tag =",i3,", frac =",f7.4)',advance='no') tile%tag, tile%frac
  if(associated(tile%lake)) write(*,'(a,i3)',advance='no')', lake =',tile%lake%tag
  if(associated(tile%soil)) write(*,'(a,i3)',advance='no')', soil =',tile%soil%tag
  if(associated(tile%glac)) write(*,'(a,i3)',advance='no')', glac =',tile%glac%tag
  if(associated(tile%snow)) write(*,'(a,i3)',advance='no')', snow =',tile%snow%tag
  if(associated(tile%cana)) write(*,'(a)',advance='no')', cana'
  if(associated(tile%vegn)) write(*,'(a)',advance='no')', vegn'
  write(*,'(")")',advance='no')
  
end subroutine


! ============================================================================
subroutine print_land_tile_statistics()
  write(*,*)'Total number of created land_tiles =',n_created_land_tiles
  write(*,*)'Total number of deleted land_tiles =',n_deleted_land_tiles
end subroutine

end module land_tile_mod


module cana_tile_mod

use land_tile_selectors_mod, only : &
     tile_selector_type
use constants_mod, only : &
     cp_air, tfreeze

implicit none
private

! ==== public interfaces =====================================================
public :: cana_prog_type
public :: cana_tile_type

public :: new_cana_tile, delete_cana_tile
public :: cana_tiles_can_be_merged, merge_cana_tiles
public :: get_cana_tile_tag
public :: cana_is_selected

public :: cana_tile_stock_pe
public :: cana_tile_carbon
public :: cana_tile_heat

! public data:
real, public :: canopy_air_mass = 0.0    ! mass of wet air in the canopy air 
                                         ! space for heat and water vapor, kg/m2
real, public :: canopy_air_mass_for_tracers = 0.0 ! mass of wet air in the canopy air 
                                         ! space for tracers other than water vapor, kg/m2
! Water vapor is bundled with heat and not with other tracers because it is
! tightly coupled with the heat capacity of the canopy air and therefore with
! the equations for heat. We assume that other tracers do not contribute to
! the heat capacity of the canopy air.
real, public :: cpw             = 1952.0 ! specific heat of water vapor at constant pressure, J/(kg K)
! ==== end of public interfaces ==============================================
interface new_cana_tile
   module procedure cana_tile_ctor
   module procedure cana_tile_copy_ctor
end interface

! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: cana_tile.F90,v 18.0 2010/03/02 23:36:42 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

! ==== data types ======================================================
type :: cana_prog_type
  real T
  real q
  real :: co2 ! co2 concentration in canopy air, kg CO2/kg of wet air
end type cana_prog_type

type :: cana_tile_type
   type(cana_prog_type) :: prog
end type cana_tile_type

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! =============================================================================
function cana_tile_ctor() result(ptr)
  type(cana_tile_type), pointer :: ptr ! return value

  allocate(ptr)
end function cana_tile_ctor

! =============================================================================
function cana_tile_copy_ctor(cana) result(ptr)
  type(cana_tile_type), pointer :: ptr ! return value
  type(cana_tile_type), intent(in) :: cana ! return value

  allocate(ptr)
  ptr = cana
end function cana_tile_copy_ctor

! =============================================================================
subroutine delete_cana_tile(cana)
  type(cana_tile_type), pointer :: cana

  deallocate(cana)
end subroutine delete_cana_tile

! =============================================================================
function cana_tiles_can_be_merged(cana1,cana2) result(response)
  logical :: response
  type(cana_tile_type), intent(in) :: cana1,cana2

  response = .TRUE.
end function

! =============================================================================
subroutine merge_cana_tiles(cana1,w1,cana2,w2)
  type(cana_tile_type), intent(in)    :: cana1
  type(cana_tile_type), intent(inout) :: cana2
  real                , intent(in)    :: w1, w2
  
  ! ---- local vars
  real :: x1,x2 ! normalized weights
  real :: HEAT1, HEAT2 ! heat content of the tiles
  
  ! calculate normalized weights
  x1 = w1/(w1+w2)
  x2 = 1-x1
  HEAT1 = canopy_air_mass*(cp_air+(cpw - cp_air)*cana1%prog%q)*cana1%prog%T
  HEAT2 = canopy_air_mass*(cp_air+(cpw - cp_air)*cana2%prog%q)*cana2%prog%T

  cana2%prog%q = cana1%prog%q*x1+cana2%prog%q*x2
  if (canopy_air_mass > 0) then
     cana2%prog%T = (HEAT1*x1+HEAT2*x2)/&
          (canopy_air_mass*(cp_air+(cpw - cp_air)*cana2%prog%q))
  else
     cana2%prog%T = cana1%prog%T*x1+cana2%prog%T*x2
  endif

  cana2%prog%co2 = cana1%prog%co2*x1+cana2%prog%co2*x2
end subroutine

! =============================================================================
! returns tag of the tile
function get_cana_tile_tag(cana) result(tag)
  integer :: tag
  type(cana_tile_type), intent(in) :: cana
  
  tag = 1
end function

! =============================================================================
! returns true if tile fits the specified selector
function cana_is_selected (cana, sel)
  logical cana_is_selected
  type(tile_selector_type),  intent(in) :: sel
  type(cana_tile_type),      intent(in) :: cana

  cana_is_selected = .TRUE.
end function

! =============================================================================
subroutine cana_tile_stock_pe (cana, twd_liq, twd_sol)
  type(cana_tile_type), intent(in) :: cana
  real, intent(out) :: twd_liq, twd_sol

  twd_liq = canopy_air_mass*cana%prog%q; twd_sol = 0
end subroutine

! =============================================================================
function cana_tile_heat (cana) result(heat) ; real heat
  type(cana_tile_type), intent(in) :: cana
  
  heat = canopy_air_mass*(cp_air+(cpw - cp_air)*cana%prog%q)*(cana%prog%T-tfreeze)
end function

! =============================================================================
function cana_tile_carbon (cana) result(c) ; real c
  type(cana_tile_type), intent(in) :: cana

  c = canopy_air_mass_for_tracers * cana%prog%co2
end function 

end module cana_tile_mod


! ============================================================================
! canopy air
! ============================================================================
#include "../shared/debug.inc"

module canopy_air_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : write_version_number, error_mesg, FATAL, NOTE, file_exist, &
     close_file, check_nml_error, &
     mpp_pe, mpp_root_pe, stdlog
use time_manager_mod, only : time_type, time_type_to_real
use constants_mod, only : rdgas, rvgas, cp_air, PI, VONKARM
use sphum_mod, only : qscomp

use nf_utils_mod, only : nfu_inq_var
use land_constants_mod, only : NBANDS,d608,mol_CO2,mol_air
use cana_tile_mod, only : cana_tile_type, cana_prog_type, &
     canopy_air_mass, canopy_air_mass_for_tracers, cpw
use land_tile_mod, only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=)
use land_tile_diag_mod, only : &
     register_tiled_diag_field, send_tile_data, diag_buff_type
use land_data_mod,      only : land_state_type, lnd
use land_tile_io_mod, only : create_tile_out_file, read_tile_data_r0d_fptr, write_tile_data_r0d_fptr, &
     get_input_restart_name, print_netcdf_error
use land_debug_mod, only : is_watch_point, check_temp_range

implicit none
private

! ==== public interfaces =====================================================
public :: read_cana_namelist
public :: cana_init
public :: cana_end
public :: save_cana_restart
public :: cana_radiation
public :: cana_turbulence
public :: cana_roughness
public :: cana_state
public :: cana_step_1
public :: cana_step_2
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), private, parameter :: &
  version = '$Id: canopy_air.F90,v 17.0.2.2.2.1.2.1.2.1 2010/08/24 12:11:35 pjp Exp $', &
  tagname = '$Name:  $', &
  module_name = 'canopy_air_mod'

! options for turbulence parameter calculations
integer, parameter :: TURB_LM3W = 1, TURB_LM3V = 2
! ==== module variables ======================================================

!---- namelist ---------------------------------------------------------------
real :: init_T           = 288.
real :: init_T_cold      = 260.
real :: init_q           = 0.
real :: init_co2         = 350.0e-6 ! ppmv = mol co2/mol of dry air
real :: rav_lit_vi       = 0.       ! litter resistance to vapor per v_idx
character(len=32) :: turbulence_to_use = 'lm3w' ! or lm3v
logical :: save_qco2     = .TRUE.
logical :: sfc_dir_albedo_bug = .FALSE. ! if true, reverts to buggy behavior
! where direct albedo was mistakenly used for part of sub-canopy diffuse light
namelist /cana_nml/ &
  init_T, init_T_cold, init_q, init_co2, turbulence_to_use, &
  canopy_air_mass, canopy_air_mass_for_tracers, cpw, rav_lit_vi, save_qco2, &
  sfc_dir_albedo_bug
!---- end of namelist --------------------------------------------------------

logical            :: module_is_initialized =.FALSE.
type(time_type)    :: time ! *** NOT YET USED
real               :: delta_time      ! fast time step
integer :: turbulence_option ! selected option of turbulence parameters 
     ! calculations

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)


contains


! ============================================================================
subroutine read_cana_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=cana_nml, iostat=io)
     ierr = check_nml_error(io, 'cana_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=cana_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'cana_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit = stdlog()
     write (unit, nml=cana_nml)
  endif
end subroutine read_cana_namelist

! ============================================================================
! initialize canopy air
subroutine cana_init ( id_lon, id_lat )
  integer, intent(in)          :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in)          :: id_lat  ! ID of land latitude (Y) axis

  ! ---- local vars ----------------------------------------------------------
  integer :: unit         ! unit for various i/o
  type(land_tile_enum_type)     :: te,ce ! last and current tile
  type(land_tile_type), pointer :: tile   ! pointer to current tile
  character(len=256) :: restart_file_name
  logical :: restart_exists

  module_is_initialized = .TRUE.

  ! ---- make module copy of time --------------------------------------------
  time       = lnd%time
  delta_time = time_type_to_real(lnd%dt_fast)

  ! ---- initialize cana state -----------------------------------------------
  ! first, set the initial values
  te = tail_elmt (lnd%tile_map)
  ce = first_elmt(lnd%tile_map)
  do while(ce /= te)
     tile=>current_tile(ce)  ! get pointer to current tile
     ce=next_elmt(ce)       ! advance position to the next tile
     
     if (.not.associated(tile%cana)) cycle
     
     if (associated(tile%glac)) then
        tile%cana%prog%T = init_T_cold
     else
        tile%cana%prog%T = init_T
     endif
     tile%cana%prog%q = init_q
     ! convert to kg CO2/kg wet air
     tile%cana%prog%co2 = init_co2*mol_CO2/mol_air*(1-tile%cana%prog%q) 
  enddo

  ! then read the restart if it exists
  call get_input_restart_name('INPUT/cana.res.nc',restart_exists,restart_file_name)
  if (restart_exists) then
     call error_mesg('cana_init',&
          'reading NetCDF restart "'//trim(restart_file_name)//'"',&
          NOTE)
     __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,unit))
     call read_tile_data_r0d_fptr(unit, 'temp'  , cana_T_ptr  )
     call read_tile_data_r0d_fptr(unit, 'sphum' , cana_q_ptr )
     if(nfu_inq_var(unit,'co2')==NF_NOERR) then
        call read_tile_data_r0d_fptr(unit, 'co2', cana_co2_ptr )
     endif
     __NF_ASRT__(nf_close(unit))     
  else
     call error_mesg('cana_init',&
          'cold-starting canopy air',&
          NOTE)
  endif

  ! initialize options, to avoid expensive character comparisons during 
  ! run-time
  if (trim(turbulence_to_use)=='lm3v') then
     turbulence_option = TURB_LM3V
  else if (trim(turbulence_to_use)=='lm3w') then
     turbulence_option = TURB_LM3W
  else
     call error_mesg('cana_init', 'canopy air turbulence option turbulence_to_use="'// &
          trim(turbulence_to_use)//'" is invalid, use "lm3w" or "lm3v"', FATAL)
  endif
  
end subroutine cana_init


! ============================================================================
! release memory
subroutine cana_end ()

  module_is_initialized =.FALSE.

end subroutine cana_end


! ============================================================================
subroutine save_cana_restart (tile_dim_length, timestamp)
  integer, intent(in) :: tile_dim_length ! length of tile dim. in the output file
  character(*), intent(in) :: timestamp ! timestamp to add to the file name

  ! ---- local vars ----------------------------------------------------------
  integer :: unit            ! restart file i/o unit

  call error_mesg('cana_end','writing NetCDF restart',NOTE)
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'cana.res.nc',&
          lnd%coord_glon, lnd%coord_glat, cana_tile_exists, tile_dim_length)

     ! write fields
     call write_tile_data_r0d_fptr(unit,'temp' ,cana_T_ptr,'canopy air temperature','degrees_K')
     call write_tile_data_r0d_fptr(unit,'sphum',cana_q_ptr,'canopy air specific humidity','kg/kg')
     if (save_qco2) then
        call write_tile_data_r0d_fptr(unit,'co2'  ,cana_co2_ptr,'canopy air co2 concentration','(kg CO2)/(kg wet air)')
     endif
     ! close output file
     __NF_ASRT__(nf_close(unit))
end subroutine save_cana_restart


! ============================================================================
! set up constants for linearization of radiative transfer, using information
! provided by soil, snow and vegetation modules.
subroutine cana_radiation (lm2, &
     subs_refl_dir, subs_refl_dif, subs_refl_lw, & 
     snow_refl_dir, snow_refl_dif, snow_refl_lw, & 
     snow_area, &
     vegn_refl_dir, vegn_refl_dif, vegn_tran_dir, vegn_tran_dif, &
     vegn_tran_dir_dir, vegn_refl_lw, vegn_tran_lw,  &
     vegn_cover, &
     Sg_dir, Sg_dif, Sv_dir, Sv_dif, &
     land_albedo_dir, land_albedo_dif )

  logical, intent(in) :: lm2
  real, intent(in) :: &
       subs_refl_dir(NBANDS), subs_refl_dif(NBANDS), subs_refl_lw,  & ! sub-snow reflectances for direct, diffuse, and LW radiation respectively
       snow_refl_dir(NBANDS), snow_refl_dif(NBANDS), snow_refl_lw,  & ! snow reflectances for direct, diffuse, and LW radiation respectively
       snow_area, &
       vegn_refl_dir(NBANDS), vegn_tran_dir(NBANDS), & ! vegn reflectance & transmittance for direct light
       vegn_tran_dir_dir(NBANDS), & !
       vegn_refl_dif(NBANDS), vegn_tran_dif(NBANDS), & ! vegn reflectance & transmittance for diffuse light 
       vegn_refl_lw,  vegn_tran_lw,  & ! vegn reflectance & transmittance for thermal radiation 
       vegn_cover

  real, intent(out) :: &
     Sg_dir(NBANDS), Sg_dif(NBANDS), & ! fraction of downward short-wave absorbed by ground and snow
     Sv_dir(NBANDS), Sv_dif(NBANDS), & ! fraction of downward short-wave absorbed by vegetation
     land_albedo_dir(NBANDS), land_albedo_dif(NBANDS)

  ! ---- local vars
  real :: &
       grnd_refl_dir(NBANDS), & ! SW reflectances of ground surface (by spectral band)
       grnd_refl_dif(NBANDS), & ! SW reflectances of ground surface (by spectral band)
       grnd_refl_lw             ! LW reflectance of ground surface
  real :: &
       subs_up_from_dir(NBANDS), subs_up_from_dif(NBANDS), &
       subs_dn_dir_from_dir(NBANDS),  subs_dn_dif_from_dif(NBANDS), subs_dn_dif_from_dir(NBANDS)

  grnd_refl_dir = subs_refl_dir + (snow_refl_dir - subs_refl_dir) * snow_area
  grnd_refl_dif = subs_refl_dif + (snow_refl_dif - subs_refl_dif) * snow_area
  grnd_refl_lw  = subs_refl_lw  + (snow_refl_lw  - subs_refl_lw ) * snow_area

  ! ---- shortwave -----------------------------------------------------------
  ! allocation to canopy and ground, based on solution for single
  ! vegetation layer of limited cover. both ground and vegetation are gray.
  Sv_dir = 0; Sv_dif = 0
  IF (LM2) THEN

     subs_dn_dir_from_dir = vegn_tran_dir_dir
     subs_dn_dif_from_dir = vegn_tran_dir
     subs_dn_dif_from_dif = vegn_tran_dif
     if (sfc_dir_albedo_bug) then
        subs_up_from_dir = grnd_refl_dir &
             * (subs_dn_dir_from_dir + subs_dn_dif_from_dir)
     else
        subs_up_from_dir = grnd_refl_dir*subs_dn_dir_from_dir + &
                           grnd_refl_dif*subs_dn_dif_from_dir
     endif
     subs_up_from_dif = grnd_refl_dif*subs_dn_dif_from_dif
     land_albedo_dir = subs_up_from_dir+vegn_refl_dir
     land_albedo_dif = subs_up_from_dif+vegn_refl_dif

  ELSE

     subs_dn_dir_from_dir = vegn_tran_dir_dir
     subs_dn_dif_from_dir = (vegn_tran_dir + vegn_refl_dif*grnd_refl_dir*vegn_tran_dir_dir)&
                          / (1 - grnd_refl_dif*vegn_refl_dif)
     subs_dn_dif_from_dif = vegn_tran_dif &
                          / (1 - grnd_refl_dif*vegn_refl_dif)
     if (sfc_dir_albedo_bug) then
        subs_up_from_dir = grnd_refl_dir * (subs_dn_dir_from_dir + subs_dn_dif_from_dir)
     else
        subs_up_from_dir = grnd_refl_dir*subs_dn_dir_from_dir + &
                           grnd_refl_dif*subs_dn_dif_from_dir
     endif
     subs_up_from_dif = grnd_refl_dif*subs_dn_dif_from_dif
     land_albedo_dir  = subs_up_from_dir*vegn_tran_dif + vegn_refl_dir
     land_albedo_dif  = subs_up_from_dif*vegn_tran_dif + vegn_refl_dif

  ENDIF

  Sg_dir = subs_dn_dir_from_dir + subs_dn_dif_from_dir - subs_up_from_dir
  Sg_dif = subs_dn_dif_from_dif - subs_up_from_dif
  Sv_dir = 1 - Sg_dir - land_albedo_dir
  Sv_dif = 1 - Sg_dif - land_albedo_dif

end subroutine cana_radiation


! ============================================================================
subroutine cana_turbulence (u_star,&
     vegn_cover, vegn_height, vegn_lai, vegn_sai, vegn_d_leaf, &
     land_d, land_z0m, land_z0s, grnd_z0s, &
     con_v_h, con_v_v, con_g_h, con_g_v )
  real, intent(in) :: &
       u_star, & ! friction velocity, m/s
       land_d, land_z0m, land_z0s, grnd_z0s, & 
       vegn_cover, vegn_height, &
       vegn_lai, vegn_sai, vegn_d_leaf
  real, intent(out) :: &
       con_v_h, con_v_v, & ! one-sided foliage-cas conductance per unit of ground area
       con_g_h, con_g_v    ! ground-CAS conductance per unit ground area

  !---- local constants
  real, parameter :: a_max = 3
  real, parameter :: leaf_co = 0.01 ! meters per second^(1/2)
                                    ! leaf_co = g_b(z)/sqrt(wind(z)/d_leaf)
  ! ---- local vars 
  real :: a        ! parameter of exponential wind profile within canopy:
                   ! u = u(ztop)*exp(-a*(1-z/ztop))
  real :: height   ! effective height of vegetation
  real :: wind     ! normalized wind on top of canopy, m/s
  real :: Kh_top   ! turbulent exchange coefficient on top of the canopy
  real :: vegn_idx ! total vegetation index = LAI+SAI
  real :: rah_sca  ! ground-SCA resistance
  real :: rav_lit  ! additional resistance of litter to vapor transport

  vegn_idx = vegn_lai+vegn_sai  ! total vegetation index
  select case(turbulence_option)
  case(TURB_LM3W)
     if(vegn_cover > 0) then
        wind  = u_star/VONKARM*log((vegn_height-land_d)/land_z0m) ! normalized wind on top of the canopy
        a     = vegn_cover*a_max
        con_v_h = (2*vegn_lai*leaf_co*(1-exp(-a/2))/a)*sqrt(wind/vegn_d_leaf)
        con_g_h = u_star*a*VONKARM*(1-land_d/vegn_height) &
             / (exp(a*(1-grnd_z0s/vegn_height)) - exp(a*(1-(land_z0s+land_d)/vegn_height)))
     else
        con_v_h = 0
        con_g_h = 0
     endif
  case(TURB_LM3V)
     height = max(vegn_height,0.1) ! effective height of the vegetation
     a = a_max
     wind=u_star/VONKARM*log((height-land_d)/land_z0m) ! normalized wind on top of the canopy
  
     con_v_h = (2*vegn_lai*leaf_co*(1-exp(-a/2))/a)*sqrt(wind/vegn_d_leaf)

     if (land_d > 0.06 .and. vegn_idx > 0.25) then
        Kh_top = VONKARM*u_star*(height-land_d)
        rah_sca = height/a/Kh_top * &
             (exp(a*(1-grnd_z0s/height)) - exp(a*(1-(land_z0m+land_d)/height)))
        rah_sca = min(rah_sca,1250.0)
     else
        rah_sca=0.01
     endif
     con_g_h = 1.0/rah_sca
  end select
! not a good parameterization, but just using for sensitivity analyses now.
! ignores differing biomass and litter turnover rates.
  rav_lit = rav_lit_vi * vegn_idx
  con_g_v = con_g_h/(1.+rav_lit*con_g_h)
  con_v_v = con_v_h
end subroutine

! ============================================================================
! update effective surface roughness lengths for CAS-to-atmosphere fluxes
! and conductances for canopy-to-CAS and ground-to-CAS fluxes
!
! Strategy: Always define a canopy present. Non-vegetated situation is simply
! a limit as vegetation density approaches (but isn't allowed to reach) zero.
! Create expressions for the outputs that reduce to the special
! cases of full canopy cover and no canopy. Full canopy solution is that
! from Bonan (NCAR/TN-417+STR, 1996, p. 63). Thus, setting cover=1 in
! recovers Bonan. Letting cover approach 0 makes con_v_coef go to zero,
! preventing exchange with canopy, and makes con_g_coef go infinite,
! removing sub-canopy resistance and putting all resistance above the
! canopy, where it can be affected by stability adjustments.
!
! ** However, there is still a problem with this formulation when a
! canopy is present, because surface flux (I think) is not told to
! subtract out the resistances associated with con_v_coef and con_g_coef,
! which thus seem to be double-counted. For testing LM2, we should set them
! to zero anyway.
subroutine cana_roughness(lm2, &
     subs_z0m, subs_z0s, &
     snow_z0m, snow_z0s, snow_area, &
     vegn_cover, vegn_height, vegn_lai, vegn_sai, &
     land_d, land_z0m, land_z0s )
  logical, intent(in) :: lm2
  real, intent(in) :: &
       subs_z0m, subs_z0s, snow_z0m, snow_z0s, snow_area, vegn_cover, vegn_height, &
       vegn_lai, vegn_sai
  real, intent(out) :: &
       land_d    ,&
       land_z0m  ,&
       land_z0s

  !---- local constants
  real, parameter :: d_h_max = 2./3.
  real, parameter :: z0m_h_max = 1/7.35

  ! ---- local vars 
  real :: d_h      ! ratio of displacement height to vegetation height
  real :: z0m_h    ! ratio of roughness length to vegetation height
  real :: grnd_z0m, grnd_z0s
  real :: z0s_h, z0s_h_max
  real :: vegn_idx ! total vegetation index = LAI+SAI
  real :: height   ! effective vegetation height

  grnd_z0m = exp( (1-snow_area)*log(subs_z0m) + snow_area*log(snow_z0m))
  grnd_z0s = exp( (1-snow_area)*log(subs_z0s) + snow_area*log(snow_z0s))

  select case(turbulence_option)
  case(TURB_LM3W)
     if(vegn_cover > 0) then
        z0s_h_max = z0m_h_max*grnd_z0s/grnd_z0m ! to ensure cover->0 limit works
        d_h = vegn_cover*d_h_max
        if (lm2) then
           if (vegn_lai.gt.1) then  ! TEMP ***
              z0m_h = z0m_h_max
              z0s_h = z0s_h_max
           else
              z0m_h = grnd_z0m/vegn_height
              z0s_h = grnd_z0s/vegn_height
           endif
        else
           z0m_h = exp( vegn_cover*log(z0m_h_max) + (1-vegn_cover)*log(grnd_z0m/vegn_height))
           z0s_h = exp( vegn_cover*log(z0s_h_max) + (1-vegn_cover)*log(grnd_z0s/vegn_height))
        endif
        land_d   = d_h*vegn_height
        land_z0m = z0m_h*vegn_height
        land_z0s = z0s_h*vegn_height
     else
        land_d   = 0
        land_z0m = grnd_z0m
        land_z0s = grnd_z0s
     endif
     
  case(TURB_LM3V)
     height = max(vegn_height,0.1) ! effective height of the vegetation
     vegn_idx = vegn_lai+vegn_sai  ! total vegetation index
     if(vegn_idx>1e-4) then
        land_d = 1.1*height*log(1+(0.07*vegn_idx)**0.25)
        if(vegn_idx>2.85) then
           land_z0m = 0.3*(height-land_d)
        else
           land_z0m = grnd_z0m + 0.3*height*sqrt(0.07*vegn_idx)
        endif
     else 
        ! bare soil or leaf off
        land_z0m = 0.1 *height
        land_d   = 0.66*height
     endif
     land_z0s = land_z0m*exp(-2.0) 

  end select

end subroutine cana_roughness

! ============================================================================
subroutine cana_state ( cana, cana_T, cana_q, cana_co2 )
  type(cana_tile_type), intent(in)  :: cana
  real, optional      , intent(out) :: cana_T, cana_q, cana_co2

  if (present(cana_T))   cana_T   = cana%prog%T
  if (present(cana_q))   cana_q   = cana%prog%q
  if (present(cana_co2)) cana_co2 = cana%prog%co2
  
end subroutine

! ============================================================================
subroutine cana_step_1 ( cana,&
     p_surf, con_g_h, con_g_v, grnd_T, grnd_rh, grnd_rh_psi, &
     Hge,  DHgDTg, DHgDTc,    &
     Ege,  DEgDTg, DEgDqc, DEgDpsig     )
  type(cana_tile_type), intent(in) :: cana
  real, intent(in) :: &
     p_surf,  & ! surface pressure, Pa
     con_g_h, & ! conductivity between ground and CAS for heat
     con_g_v, & ! conductivity between ground and CAS for vapor
     grnd_T,  & ! ground temperature, degK
     grnd_rh, & ! ground relative humidity
     grnd_rh_psi ! psi derivative of ground relative humidity
  real, intent(out) ::   &
     Hge,  DHgDTg, DHgDTc, & ! linearization of the sensible heat flux from ground
     Ege,  DEgDTg, DEgDqc, DEgDpsig    ! linearization of evaporation from ground

  ! ---- local vars
  real :: rho, grnd_q, qsat, DqsatDTg

  call check_temp_range(grnd_T,'cana_step_1','grnd_T')

  call qscomp(grnd_T,p_surf,qsat,DqsatDTg)
  grnd_q = grnd_rh * qsat

  rho      =  p_surf/(rdgas*cana%prog%T*(1+d608*cana%prog%q))
  Hge      =  rho*cp_air*con_g_h*(grnd_T - cana%prog%T)
  DHgDTg   =  rho*cp_air*con_g_h
  DHgDTc   = -rho*cp_air*con_g_h
  Ege      =  rho*con_g_v*(grnd_q  - cana%prog%q)
  DEgDTg   =  rho*con_g_v*DqsatDTg*grnd_rh
  DEgDqc   = -rho*con_g_v
  DEgDpsig =  rho*con_g_v*qsat*grnd_rh_psi
  if(is_watch_point())then
     write(*,*)'#### cana_step_1 input ####'
     __DEBUG1__(p_surf)
     __DEBUG2__(con_g_h,con_g_v)
     __DEBUG2__(grnd_T,grnd_rh)
     write(*,*)'#### cana_step_1 internals ####'
     __DEBUG4__(rho, grnd_q, qsat, DqsatDTg)
     __DEBUG2__(cana%prog%T,cana%prog%q)
     write(*,*)'#### cana_step_1 output ####'
     __DEBUG3__(Hge,  DHgDTg, DHgDTc)
     __DEBUG4__(Ege,  DEgDTg, DEgDqc, DEgDpsig)
  endif
end subroutine 


! ============================================================================
subroutine cana_step_2 ( cana, delta_Tc, delta_qc )
  type(cana_tile_type), intent(inout) :: cana
  real, intent(in) ::  &
     delta_Tc, & ! change in canopy air temperature
     delta_qc    ! change in canopy air humidity

  cana%prog%T = cana%prog%T + delta_Tc
  cana%prog%q = cana%prog%q + delta_qc
end subroutine cana_step_2

! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function cana_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   cana_tile_exists = associated(tile%cana)
end function cana_tile_exists

! ============================================================================
! accessor functions: given a pointer to a land tile, they return pointer
! to the desired member of the land tile, of NULL if this member does not
! exist.
#define DEFINE_CANA_ACCESSOR_0D(xtype,x) subroutine cana_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p;p=>NULL();if(associated(t))then;if(associated(t%cana))p=>t%cana%prog%x;endif;end subroutine

DEFINE_CANA_ACCESSOR_0D(real,T)
DEFINE_CANA_ACCESSOR_0D(real,q)
DEFINE_CANA_ACCESSOR_0D(real,co2)

end module canopy_air_mod


! ============================================================================
! glac model module
! ============================================================================
module glacier_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod,            only: error_mesg, file_exist,     &
                              check_nml_error, stdlog, write_version_number, &
                              close_file, mpp_pe, mpp_root_pe, FATAL, NOTE
use time_manager_mod,   only: time_type, increment_time, time_type_to_real
use diag_manager_mod,   only: diag_axis_init
use constants_mod,      only: tfreeze, hlv, hlf, dens_h2o, PI

use glac_tile_mod,      only: glac_tile_type, glac_pars_type, glac_prog_type, &
     read_glac_data_namelist, glac_data_thermodynamics, glac_data_hydraulics, &
     glac_data_radiation, glac_data_diffusion, max_lev, cpw, clw, csw

use land_constants_mod, only : &
     NBANDS
use land_tile_mod, only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=)
use land_tile_diag_mod, only : &
     register_tiled_diag_field, send_tile_data, diag_buff_type
use land_data_mod,      only : land_state_type, lnd
use land_io_mod, only : print_netcdf_error
use land_tile_io_mod, only: create_tile_out_file, read_tile_data_r1d_fptr, &
     write_tile_data_r1d_fptr, get_input_restart_name, sync_nc_files
use nf_utils_mod, only : nfu_def_dim, nfu_put_att
use land_debug_mod, only : is_watch_point
implicit none
private

! ==== public interfaces =====================================================
public :: read_glac_namelist
public :: glac_init
public :: glac_end
public :: save_glac_restart
public :: glac_get_sfc_temp
public :: glac_radiation
public :: glac_diffusion
public :: glac_step_1
public :: glac_step_2
! =====end of public interfaces ==============================================



! ==== module constants ======================================================
character(len=*), parameter :: &
       module_name = 'glacier',&
       version     = '$Id: glacier.F90,v 17.0.2.1.2.1 2010/08/24 12:11:35 pjp Exp $',&
       tagname     = '$Name: hiram_20101115_bw $'
 
! ==== module variables ======================================================

!---- namelist ---------------------------------------------------------------
logical :: lm2                   = .true.  ! *** CODE WORKS ONLY FOR .TRUE. !!! ****
logical :: conserve_glacier_mass = .true.
character(len=16):: albedo_to_use = ''  ! or 'brdf-params'
real    :: init_temp            = 260.       ! cold-start glac T
real    :: init_w               = 150.       ! cold-start w(l)/dz(l)
real    :: init_groundwater     =   0.       ! cold-start gw storage
namelist /glac_nml/ lm2, conserve_glacier_mass,  albedo_to_use, &
                    init_temp, init_w, init_groundwater, cpw, clw, csw
!---- end of namelist --------------------------------------------------------

logical         :: module_is_initialized =.FALSE.
logical         :: use_brdf
type(time_type) :: time
real            :: delta_time       ! fast time step

integer         :: num_l            ! # of water layers
real            :: dz    (max_lev)  ! thicknesses of layers
real            :: zfull (max_lev)
real            :: zhalf (max_lev+1)


! ---- diagnostic field IDs
integer :: id_zhalf, id_zfull
integer :: id_lwc, id_swc, id_temp, id_ie, id_sn, id_bf, id_hie, id_hsn, id_hbf

! ==== end of module variables ===============================================

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

contains

! ============================================================================
subroutine read_glac_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: l            ! level iterator

  call read_glac_data_namelist(num_l, dz)

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=glac_nml, iostat=io)
     ierr = check_nml_error(io, 'glac_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=glac_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'glac_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit = stdlog()
     write (unit, nml=glac_nml)
  endif

  ! ---- set up vertical discretization
  zhalf(1) = 0
  do l = 1, num_l;   
     zhalf(l+1) = zhalf(l) + dz(l)
     zfull(l) = 0.5*(zhalf(l+1) + zhalf(l))
  enddo

end subroutine read_glac_namelist


! ============================================================================
! initialize glacier model
subroutine glac_init ( id_lon, id_lat )
  integer, intent(in)  :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in)  :: id_lat  ! ID of land latitude (Y) axis

  ! ---- local vars
  integer :: unit         ! unit for various i/o
  type(land_tile_enum_type)     :: te,ce ! last and current tile list elements
  type(land_tile_type), pointer :: tile  ! pointer to current tile
  character(len=256) :: restart_file_name
  logical :: restart_exists

  module_is_initialized = .TRUE.
  time       = lnd%time
  delta_time = time_type_to_real(lnd%dt_fast)

  ! -------- initialize glac state --------
  call get_input_restart_name('INPUT/glac.res.nc',restart_exists,restart_file_name)
  if (restart_exists) then
     call error_mesg('glac_init',&
          'reading NetCDF restart "'//trim(restart_file_name)//'"',&
          NOTE)
     __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,unit))
     call read_tile_data_r1d_fptr(unit, 'temp'         , glac_temp_ptr  )
     call read_tile_data_r1d_fptr(unit, 'wl'           , glac_wl_ptr )
     call read_tile_data_r1d_fptr(unit, 'ws'           , glac_ws_ptr )
     call read_tile_data_r1d_fptr(unit, 'groundwater'  , glac_gw_ptr )
     call read_tile_data_r1d_fptr(unit, 'groundwater_T', glac_gwT_ptr)
     __NF_ASRT__(nf_close(unit))     
  else
     call error_mesg('glac_init',&
          'cold-starting glacier',&
          NOTE)
     te = tail_elmt (lnd%tile_map)
     ce = first_elmt(lnd%tile_map)
     do while(ce /= te)
        tile=>current_tile(ce) ! get pointer to current tile
        ce=next_elmt(ce)       ! advance position to the next tile
        
        if (.not.associated(tile%glac)) cycle

        if (init_temp.ge.tfreeze.or.lm2) then      ! USE glac TFREEZE HERE
           tile%glac%prog(1:num_l)%wl = init_w*dz(1:num_l)
           tile%glac%prog(1:num_l)%ws = 0
        else
           tile%glac%prog(1:num_l)%wl = 0
           tile%glac%prog(1:num_l)%ws = init_w*dz(1:num_l)
        endif
        tile%glac%prog%T             = init_temp
        tile%glac%prog%groundwater   = init_groundwater
        tile%glac%prog%groundwater_T = init_temp
     enddo
  endif
  
  if (trim(albedo_to_use)=='brdf-params') then
     use_brdf = .true.
  else if (trim(albedo_to_use)=='') then
     use_brdf = .false.
  else
     call error_mesg('glac_init',&
          'option albedo_to_use="'// trim(albedo_to_use)//&
          '" is invalid, use "brdf-params", or nothing ("")',&
          FATAL)
  endif

  if (.not.lm2) then
     call error_mesg('glac_init',&
          'currently only lm2=.TRUE. is supported',&
          FATAL)
  endif

  call glac_diag_init ( id_lon, id_lat, zfull(1:num_l), zhalf(1:num_l+1) )

end subroutine glac_init


! ============================================================================
subroutine glac_end ()

  module_is_initialized =.FALSE.

end subroutine glac_end


! ============================================================================
subroutine save_glac_restart (tile_dim_length, timestamp)
  integer, intent(in) :: tile_dim_length ! length of tile dim. in the output file
  character(*), intent(in) :: timestamp ! timestamp to add to the file name

  integer :: unit ! restart file i/o unit

  call error_mesg('glac_end','writing NetCDF restart',NOTE)
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'glac.res.nc', &
          lnd%coord_glon, lnd%coord_glat, glac_tile_exists, tile_dim_length)

  ! in addition, define vertical coordinate
  if (mpp_pe()==lnd%io_pelist(1)) then
     __NF_ASRT__(nfu_def_dim(unit,'zfull',zfull(1:num_l),'full level','m'))
     __NF_ASRT__(nfu_put_att(unit,'zfull','positive','down'))
  endif
  ! synchronize the output between writers and readers
  call sync_nc_files(unit)
        
  ! write out fields
  call write_tile_data_r1d_fptr(unit,'temp'         ,glac_temp_ptr,'zfull','glacier temperature','degrees_K')
  call write_tile_data_r1d_fptr(unit,'wl'           ,glac_wl_ptr  ,'zfull','liquid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'ws'           ,glac_ws_ptr  ,'zfull','solid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'groundwater'  ,glac_gw_ptr  ,'zfull')
  call write_tile_data_r1d_fptr(unit,'groundwater_T',glac_gwT_ptr ,'zfull')
   
  ! close file
  __NF_ASRT__(nf_close(unit))

end subroutine save_glac_restart


! ============================================================================
! returns glacier surface temperature
subroutine glac_get_sfc_temp ( glac, glac_T )
  type(glac_tile_type), intent(in)  :: glac
  real,                 intent(out) :: glac_T

  glac_T = glac%prog(1)%T
end subroutine glac_get_sfc_temp


! ============================================================================
subroutine glac_radiation ( glac, cosz, &
     glac_refl_dir, glac_refl_dif, glac_refl_lw, glac_emis )
  type(glac_tile_type), intent(in) :: glac
  real, intent(in)  :: cosz
  real, intent(out) :: &
       glac_refl_dir(NBANDS), glac_refl_dif(NBANDS), & ! glacier albedos for direct and diffuse light
       glac_refl_lw,   &  ! glacier reflectance for longwave (thermal) radiation
       glac_emis          ! glacier emissivity

  call glac_data_radiation ( glac, cosz, use_brdf, glac_refl_dir, glac_refl_dif, glac_emis )
  glac_refl_lw = 1 - glac_emis
end subroutine glac_radiation


! ============================================================================
! compute glac-only properties needed to do glac-canopy-atmos energy balance
subroutine glac_diffusion ( glac, glac_z0s, glac_z0m )
  type(glac_tile_type), intent(in) :: glac
  real, intent(out) :: glac_z0s, glac_z0m

  call glac_data_diffusion ( glac, glac_z0s, glac_z0m )
  
end subroutine glac_diffusion


! ============================================================================
! update glac properties explicitly for time step.
! integrate glac-heat conduction equation upward from bottom of glac
! to surface, delivering linearization of surface ground heat flux.
subroutine glac_step_1 ( glac, &
                         glac_T, glac_rh, glac_liq, glac_ice, glac_subl, &
                         glac_tf, glac_G0, &
                         glac_DGDT, conserve_glacier_mass_out )
  type(glac_tile_type),intent(inout) :: glac
  real, intent(out) :: &
       glac_T, &
       glac_rh, glac_liq, glac_ice, glac_subl, &
       glac_tf, & ! freezing temperature of glacier, degK
       glac_G0, &
       glac_DGDT
  logical, intent(out) :: conserve_glacier_mass_out

  ! ---- local vars 
  real                   :: bbb, denom, dt_e
  real, dimension(num_l) :: aaa, ccc, thermal_cond, heat_capacity, vlc, vsc
  integer :: l

! ----------------------------------------------------------------------------
! in preparation for implicit energy balance, determine various measures
! of water availability, so that vapor fluxes will not exceed mass limits
! ----------------------------------------------------------------------------

  conserve_glacier_mass_out = conserve_glacier_mass

  if(is_watch_point()) then
    write(*,*) 'checkpoint gs1 a'
    write(*,*) 'mask    ',  .TRUE.
    write(*,*) 'T       ', glac%prog(1)%T
  endif

  glac_T = glac%prog(1)%T

  if(is_watch_point()) then
     write(*,*) 'checkpoint gs1 b'
     write(*,*) 'mask    ', .TRUE.
     write(*,*) 'glac_T       ', glac_T
  endif

  do l = 1, num_l
     vlc(l) = max(0.0, glac%prog(l)%wl / (dens_h2o * dz(l)))
     vsc(l) = max(0.0, glac%prog(l)%ws / (dens_h2o * dz(l)))
  enddo

  call glac_data_thermodynamics ( glac%pars, vlc(1), vsc(1),  &  
       glac_rh, glac%heat_capacity_dry, thermal_cond )

  do l = 1, num_l
     heat_capacity(l) = glac%heat_capacity_dry(l)*dz(l) &
          + clw*glac%prog(l)%wl + csw*glac%prog(l)%ws
  enddo

  if (lm2) then
     glac_liq = 0
     glac_ice = 1.e6
  else
     glac_liq  = max(glac%prog(1)%wl, 0.0)
     glac_ice  = max(glac%prog(1)%ws, 0.0)
  endif
  if (glac_liq + glac_ice > 0 ) then
     glac_subl = glac_ice / (glac_liq + glac_ice)
  else
     glac_subl = 0
  endif
  
  if(num_l > 1) then
     do l = 1, num_l-1
        dt_e = 2 / ( dz(l+1)/thermal_cond(l+1) &
                + dz(l)/thermal_cond(l)   )
        aaa(l+1) = - dt_e * delta_time / heat_capacity(l+1)
        ccc(l)   = - dt_e * delta_time / heat_capacity(l)
     enddo

     bbb = 1.0 - aaa(num_l)
     denom = bbb
     dt_e = aaa(num_l)*(glac%prog(num_l)%T - glac%prog(num_l-1)%T)
     glac%e(num_l-1) = -aaa(num_l)/denom
     glac%f(num_l-1) = dt_e/denom
     do l = num_l-1, 2, -1
        bbb = 1.0 - aaa(l) - ccc(l)
        denom = bbb + ccc(l)*glac%e(l)
        dt_e = - ( ccc(l)*(glac%prog(l+1)%T - glac%prog(l)%T  ) &
             -aaa(l)*(glac%prog(l)%T   - glac%prog(l-1)%T) )
        glac%e(l-1) = -aaa(l)/denom
        glac%f(l-1) = (dt_e - ccc(l)*glac%f(l))/denom
     enddo
     denom = delta_time/(heat_capacity(1) )
     glac_G0    = ccc(1)*(glac%prog(2)%T- glac%prog(1)%T &
          + glac%f(1)) / denom
     glac_DGDT  = (1 - ccc(1)*(1-glac%e(1))) / denom   
  else  ! one-level case
     denom = delta_time/heat_capacity(1)
     glac_G0    = 0.
     glac_DGDT  = 1. / denom
  endif

  ! set freezing temperature of glaciers
  glac_tf = glac%pars%tfreeze

  if(is_watch_point())then
     write(*,*) 'checkpoint gs1 c'
     write(*,*) 'mask    ', .TRUE.
     write(*,*) 'T       ', glac_T
     write(*,*) 'rh      ', glac_rh
     write(*,*) 'liq     ', glac_liq
     write(*,*) 'ice     ', glac_ice
     write(*,*) 'subl    ', glac_subl
     write(*,*) 'G0      ', glac_G0
     write(*,*) 'DGDT    ', glac_DGDT
     do l = 1, num_l
        write(*,*) 'T(dbg,l)', glac%prog(l)%T
     enddo

  endif
end subroutine glac_step_1


! ============================================================================
! apply boundary flows to glac water and move glac water vertically.
  subroutine glac_step_2 ( glac, diag, glac_subl, snow_lprec, snow_hlprec,  &
                           subs_DT, subs_M_imp, subs_evap, &
                           glac_levap, glac_fevap, glac_melt, &
                           glac_lrunf, glac_hlrunf, glac_Ttop, glac_Ctop )
! *** WARNING!!! MOST OF THIS CODE IS SIMPLY COPIED FROM SOIL FOR POSSIBLE
! FUTURE DEVELOPMENT. (AND SIMILAR CODE IN SOIL MOD HAS BEEN FURTHER DEVELOPED,
! SO THIS IS MAINLY JUNK.) ONLY THE LM2 BRANCHES WORK. FOR LM2, THE SURFACE OF THE
! GLACIER IS EFFECTIVELY SEALED W.R.T. MASS TRANSER: 
! NO LIQUID CAN INFILTRATE, AND NO GLACIER MASS
! CAN ENTER THE ATMOSPHERE. ONLY SUPERFICIAL SNOW PARTICIPATES IN THE WATER
! CYCLE. HOWEVER, SENSIBLE HEAT TRANSFER AND GLACIER MELT CAN OCCUR,
! TO AN UNLIMITED EXTENT, AS NEEDED
! TO KEEP GLACIER AT OR BELOW FREEZING. MELT WATER STAYS IN GLACIER.

  type(glac_tile_type), intent(inout) :: glac
  type(diag_buff_type), intent(inout) :: diag
  real, intent(in) :: &
     glac_subl     !
  real, intent(in) :: &
     snow_lprec, &
     snow_hlprec, &
     subs_DT,       &!
     subs_M_imp,       &! rate of phase change of non-evaporated glac water
     subs_evap
  real, intent(out) :: &
     glac_levap, glac_fevap, glac_melt, &
     glac_lrunf, glac_hlrunf, glac_Ttop, glac_Ctop

  ! ---- local vars ----------------------------------------------------------
  real, dimension(num_l) :: del_t, eee, fff, &
             psi, DThDP, hyd_cond, DKDP, K, DKDPm, DKDPp, grad, &
             vlc, vsc, dW_l, u_minus, u_plus, DPsi, glac_w_fc
  real, dimension(num_l+1) :: flow
  real, dimension(num_l  ) :: div
  real :: &
     lprec_eff, hlprec_eff, tflow, hcap,cap_flow, &
     melt_per_deg, melt,&
     lrunf_sn,lrunf_ie,lrunf_bf, hlrunf_sn,hlrunf_ie,hlrunf_bf, &
     Qout, DQoutDP,&
     tau_gw, c0, c1, c2, x, aaa, bbb, ccc, ddd, xxx, Dpsi_min, Dpsi_max
  logical :: stiff
  real, dimension(num_l-1) :: del_z
  integer :: l
  real :: jj
  ! --------------------------------------------------------------------------

  jj = 1.
  DPsi = 0.0
  c1   = 0.0
  
  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 1 ***** '
     write(*,*) 'mask    ', .TRUE.
     write(*,*) 'subs_evap    ', subs_evap
     write(*,*) 'snow_lprec   ', snow_lprec
     write(*,*) 'subs_M_imp   ', subs_M_imp
     write(*,*) 'theta_s ', glac%pars%w_sat
     do l = 1, num_l
        write(*,'(i2.2,99(a,g))')l,&
             ' T =', glac%prog(l)%T,&
             ' Th=', (glac%prog(l)%ws+glac%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', glac%prog(l)%wl,&
             ' ws=', glac%prog(l)%ws,&
             ' gw=', glac%prog(l)%groundwater
     enddo
     
  endif

  ! ---- record fluxes ---------
  IF (LM2) THEN ! EVAP SHOULD BE ZERO ANYWAY, BUT THIS IS JUST TO BE SURE...
  glac_levap  = 0.
  glac_fevap  = 0.
  ELSE
  glac_levap  = subs_evap*(1-glac_subl)
  glac_fevap  = subs_evap*   glac_subl
  ENDIF
  glac_melt   = subs_M_imp / delta_time

  ! ---- load surface temp change and perform back substitution --------------
  del_t(1) = subs_DT
  glac%prog(1)%T = glac%prog(1)%T + del_t(1)
  if ( num_l > 1) then
    do l = 1, num_l-1
      del_t(l+1) = glac%e(l) * del_t(l) + glac%f(l)
      glac%prog(l+1)%T = glac%prog(l+1)%T + del_t(l+1)
    end do
  end if

  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 2 ***** '
     write(*,*) 'levap=',glac_levap
     write(*,*) 'fevap=',glac_fevap
     write(*,*) 'subs_M_imp=',subs_M_imp
     do l = 1, num_l
        write(*,'(i2.2,x,a,g)') l, 'T', glac%prog(l)%T
     enddo
  endif

IF (LM2) THEN ! *********************************************************
    glac_lrunf  = snow_lprec
    glac_hlrunf = snow_hlprec
ELSE   ! ****************************************************************
  ! ---- extract evap from glac and do implicit melt --------------------
    glac%prog(1)%wl = glac%prog(1)%wl - glac_levap*delta_time
    glac%prog(1)%ws = glac%prog(1)%ws - glac_fevap*delta_time
    hcap = glac%heat_capacity_dry(1)*dz(1) &
                       + clw*glac%prog(1)%wl + csw*glac%prog(1)%ws
    glac%prog(1)%T = glac%prog(1)%T + (   &
                  +((clw-cpw)*glac_levap                              &
                  + (csw-cpw)*glac_fevap)*(glac%prog(1)%T  -tfreeze) &
                                               )*delta_time/ hcap
    glac%prog(1)%wl = glac%prog(1)%wl + subs_M_imp
    glac%prog(1)%ws = glac%prog(1)%ws - subs_M_imp
    glac%prog(1)%T  = tfreeze + (hcap*(glac%prog(1)%T-tfreeze) ) &
                              / ( hcap + (clw-csw)*subs_M_imp )
  ! ---- remainder of mass fluxes and associated sensible heat fluxes --------
  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 3 ***** '
     do l = 1, num_l
        write(*,'(i2.2,99(a,g))') l,&
             ' T =', glac%prog(l)%T,&
             ' wl=', glac%prog(l)%wl,&
             ' ws=', glac%prog(l)%ws
     enddo
  endif

  ! ---- fetch glac hydraulic properties -------------------------------------
  vlc=1;vsc=0
  do l = 1, num_l
     vlc(l) = max(0., glac%prog(l)%wl / (dens_h2o*dz(l)))
     vsc(l) = max(0., glac%prog(l)%ws / (dens_h2o*dz(l)))
  enddo
  call glac_data_hydraulics (glac, vlc, vsc, &
                   psi, DThDP, hyd_cond, DKDP, Dpsi_min, Dpsi_max, tau_gw, &
                   glac_w_fc )
     if(is_watch_point()) then
        write(*,*) ' ***** glac_step_2 checkpoint 3.1 ***** '
        do l = 1, num_l
           write(*,'(i2.2,99(x,a,g))') l, 'vlc', vlc(l),&
                'K  ', hyd_cond(l)
        enddo
     
     endif
    div = 0.
    do l = 1, num_l
      div(l) = 0.15*dens_h2o*dz(l)/tau_gw
    enddo
    lrunf_bf = sum(div)

  ! ---- glac-water flow ----------------------------------------------------
    stiff = all(DThDP.eq.0)
    if (snow_lprec/=0 .and. psi(num_l)>0) then
      lrunf_sn = snow_lprec*min((psi(num_l)/zhalf(num_l))**glac%pars%rsa_exp,1.)
      hlrunf_sn = lrunf_sn*snow_hlprec/snow_lprec
    else
      lrunf_sn = 0.
      hlrunf_sn = 0.
    endif
    lprec_eff = snow_lprec - lrunf_sn
    hlprec_eff = snow_hlprec - hlrunf_sn
    flow(1) = delta_time*lprec_eff
    do l = 1, num_l-1
      del_z(l) = zfull(l+1)-zfull(l)
      K(l) = 0.5*(hyd_cond(l)+hyd_cond(l+1))
      DKDPm(l) = 0. !0.5*DKDP(l)
      DKDPp(l) = 0. ! 0.5*DKDP(l+1)
!        K(l) = hyd_cond(l)
!        DKDPm(l) = DKDP(l)
!        DKDPp(l) = 0
      grad(l)  = jj*(psi(l+1)-psi(l))/del_z(l) - 1
    enddo


    if(is_watch_point()) then
       write(*,*) ' ***** glac_step_2 checkpoint 3.1 ***** '
       do l = 1, num_l
          write(*,'(i2.2,x,a,99g)') l, 'DThDP,hyd_cond,psi,DKDP', &
               DThDP(l), hyd_cond(l), psi(l), DKDP(l)
       enddo
       do l = 1, num_l-1
          write(*,'(i2.2,x,a,99g)') l, 'K,DKDPm,DKDPp,grad,del_z', &
               K(l), DKDPm(l), DKDPp(l), grad(l)
      enddo
    endif

    l = num_l
    xxx = dens_h2o*dz(l)*DThDP(l)/delta_time
    aaa =     - ( jj* K(l-1)/del_z(l-1) - DKDPm(l-1)*grad(l-1))
        bbb = xxx - (- jj*K(l-1)/del_z(l-1) - DKDPp(l-1)*grad(l-1) )
        ddd = - K(l-1) *grad(l-1) - div(l)
    eee(l-1) = -aaa/bbb
    fff(l-1) =  ddd/bbb
    
    if(is_watch_point()) then
       write(*,'(a,i,99g)') 'l,a,b, ,d', l,aaa, bbb,ddd       
    endif


    do l = num_l-1, 2, -1
      xxx = dens_h2o*dz(l)*DThDP(l)/delta_time
      aaa = - ( jj*K(l-1)/del_z(l-1) - DKDPm(l-1)*grad(l-1))
      bbb = xxx-( -jj*K(l-1)/del_z(l-1) - DKDPp(l-1)*grad(l-1)&
                  -jj*K(l  )/del_z(l  ) + DKDPm(l  )*grad(l  ))
      ccc =   - (  jj*K(l  )/del_z(l  ) + DKDPp(l  )*grad(l  ))
      ddd =       K(l)*grad(l) - K(l-1)*grad(l-1) &
                            - div(l)
      eee(l-1) =                    -aaa/(bbb+ccc*eee(l))
      fff(l-1) =  (ddd-ccc*fff(l))/(bbb+ccc*eee(l))
      if(is_watch_point()) then
         write(*,'(a,i,99g)') 'l,a,b,c,d', l,aaa, bbb,ccc,ddd
      endif
    enddo

    l = 1
    xxx = dens_h2o*dz(l)*DThDP(l)/delta_time
    bbb = xxx - ( -jj*K(l  )/del_z(l  ) + DKDPm(l  )*grad(l  ))
    ccc =     - (  jj*K(l  )/del_z(l  ) + DKDPp(l  )*grad(l  ))
    ddd =          flow(1)/delta_time +    K(l)     *grad(l) &
                            - div(l)
    if (stiff) then
      dPsi(l) =  - psi(l)
    else
      dPsi(l) = (ddd-ccc*fff(l))/(bbb+ccc*eee(l))
      dPsi(l) = min (dPsi(l), Dpsi_max)
      dPsi(l) = max (dPsi(l), Dpsi_min)
    endif
    flow(l) = (dPsi(l)*(bbb+ccc*eee(l))+ccc*fff(l) &
                      - K(l)*grad(l))*delta_time
    lrunf_ie         = lprec_eff - flow(l)/delta_time

    if(is_watch_point()) then
       write(*,'(a,i,99g)') 'l,  b,c,d', l, bbb,ccc,ddd

       write(*,*) ' ***** glac_step_2 checkpoint 3.2 ***** '
       write(*,*) 'ie,sn,bf:', lrunf_ie,lrunf_sn,lrunf_bf
       do l = 1, num_l-1
          write(*,'(a,i,99g)') 'l,eee(l),fff(l)', l,eee(l), fff(l)
       enddo
       write(*,*) 'DThDP(1)', DThDP(1)
       write(*,*) 'ddd(1)', ddd
       write(*,*) 'ccc(1)', ccc
       write(*,*) 'bbb(1)', bbb
       write(*,*) 'dPsi(1)', dPsi(1)
       write(*,*) 'Psi(1)', Psi(1)
    endif

    do l = 2, num_l
      dPsi(l) = eee(l-1)*dPsi(l-1) + fff(l-1)
    enddo

    do l = 1, num_l-1
      flow(l+1) = delta_time*( &
           -K(l)*(grad(l)&
           +jj*(DPsi(l+1)-DPsi(l))/ del_z(l)) &
           -grad(l)*(DKDPp(l)*Dpsi(l+1)+ &
                           DKDPm(l)*Dpsi(l) )  )
      dW_l(l) = flow(l) - flow(l+1) - div(l)*delta_time
      glac%prog(l)%wl = glac%prog(l)%wl + dW_l(l)
    enddo
    flow(num_l+1) = 0.
    dW_l(num_l) = flow(num_l) - flow(num_l+1) &
                          - div(num_l)*delta_time
    glac%prog(num_l)%wl = glac%prog(num_l)%wl + dW_l(num_l)
  
  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 3.3 ***** '
     write(*,*) 'psi_sat',glac%pars%psi_sat_ref
     write(*,*) 'Dpsi_max',Dpsi_max
     do l = 1, num_l
        write(*,'(i2.2,99(a,g))')l,&
             ' Th=', (glac%prog(l)%ws+glac%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', glac%prog(l)%wl,&
             ' ws=', glac%prog(l)%ws,&
             'Dpsi=', dPsi(l), &
             'flow=', flow(l)
     enddo
  endif

  if  (snow_hlprec.ne.0.) then
    tflow = tfreeze + snow_hlprec/(clw*snow_lprec)
  else
    tflow = tfreeze
  endif

  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 3.4 ***** '
     write(*,*) ' tfreeze', tfreeze
     write(*,*) ' snow_hlprec', snow_hlprec
  endif

! For initial testing, use top-down-flow weights to advect heat.
  u_minus = 1.
  u_plus  = 0.
  if (flow(1).lt.0.) u_minus(1) = 0.
  hcap = (glac%heat_capacity_dry(num_l)*dz(num_l) &
                              + csw*glac%prog(num_l)%ws)/clw
  aaa = -flow(num_l) * u_minus(num_l)
  bbb =  hcap + glac%prog(num_l)%wl - dW_l(num_l) - aaa
  eee(num_l-1) = -aaa/bbb
  fff(num_l-1) = aaa*(glac%prog(num_l)%T-glac%prog(num_l-1)%T) / bbb

  do l = num_l-1, 2, -1
    hcap = (glac%heat_capacity_dry(l)*dz(l) &
                              + csw*glac%prog(l)%ws)/clw
    aaa = -flow(l)   * u_minus(l)
    ccc =  flow(l+1) * u_plus (l)
    bbb =  hcap + glac%prog(l)%wl - dW_l(l) - aaa - ccc
    eee(l-1) = -aaa / ( bbb +ccc*eee(l) )
    fff(l-1) = (   aaa*(glac%prog(l)%T-glac%prog(l-1)%T)    &
                       + ccc*(glac%prog(l)%T-glac%prog(l+1)%T)    &
                       - ccc*fff(l) ) / ( bbb +ccc*eee(l) )
  enddo
    
  hcap = (glac%heat_capacity_dry(1)*dz(1) + csw*glac%prog(1)%ws)/clw
  aaa = -flow(1) * u_minus(1)
  ccc =  flow(2) * u_plus (1)
  bbb =  hcap + glac%prog(1)%wl - dW_l(1) - aaa - ccc

  del_t(1) =  (  aaa*(glac%prog(1)%T-tflow          ) &
                     + ccc*(glac%prog(1)%T-glac%prog(2)%T) &
                     - ccc*fff(1) ) / (bbb+ccc*eee(1))
  glac%prog(1)%T = glac%prog(1)%T + del_t(1)

  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 3.4.1 ***** '
     write(*,*) 'hcap', hcap
     write(*,*) 'aaa', aaa
     write(*,*) 'bbb', bbb
     write(*,*) 'ccc', ccc
     write(*,*) 'del_t(1)', del_t(1)
     write(*,*) ' T(1)', glac%prog(1)%T
  endif

  do l = 1, num_l-1
    del_t(l+1) = eee(l)*del_t(l) + fff(l)
    glac%prog(l+1)%T = glac%prog(l+1)%T + del_t(l+1)
  enddo

  tflow = glac%prog(num_l)%T

  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 3.5 ***** '
     write(*,*) 'hcap', hcap
     write(*,*) 'cap_flow', cap_flow
     do l = 1, num_l
        write(*,'(i2.2,99(a,g))')l, ' T', glac%prog(l)%T, ' flow ',flow(l)
     enddo
     write(*,*) 'delta_time,tau_gw,c0,c1,c2,x', delta_time,tau_gw,c0,&
          c1,c2,x
     write(*,*) 'level=', num_l+1, ' flow ',flow(num_l+1)
     write(*,*) 'gw(1)',glac%prog(1)%groundwater
  endif

  ! ---- groundwater ---------------------------------------------------------
  ! THIS T AVERAGING IS WRONG, BECAUSE IT NEGLECTS THE MEDIUM  ***
  ! ALSO, FREEZE-THAW IS NEEDED!
  ! PROBABLY THIS SECTION WILL BE DELETED ANYWAY, WITH GW TREATED ABOVE.
    if (lprec_eff.ne.0. .and. flow(1).ge.0. ) then
      hlrunf_ie = lrunf_ie*hlprec_eff/lprec_eff
    else if (flow(1).lt.0. ) then
      hlrunf_ie = hlprec_eff - (flow(1)/delta_time)*clw &
                         *(glac%prog(1)%T-tfreeze)
    else
      hlrunf_ie = 0.
    endif
    hlrunf_bf = clw*sum(div*(glac%prog%T-tfreeze))
    glac_lrunf  = lrunf_sn + lrunf_ie + lrunf_bf
    glac_hlrunf = hlrunf_sn + hlrunf_bf + hlrunf_ie 
  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 3.7 ***** '
     write(*,*) 'hcap', hcap
     write(*,*) 'cap_flow', cap_flow
     do l = 1, num_l
        write(*,'(i2.2,99(a,g))')l, ' T', glac%prog(l)%T
     enddo
  endif
    do l = 1, num_l
    ! ---- compute explicit melt/freeze --------------------------------------
      hcap = glac%heat_capacity_dry(l)*dz(l) &
               + clw*glac%prog(l)%wl + csw*glac%prog(l)%ws
      melt_per_deg = hcap/hlf
      if (glac%prog(l)%ws>0 .and. glac%prog(l)%T>glac%pars%tfreeze) then
        melt =  min(glac%prog(l)%ws, (glac%prog(l)%T-glac%pars%tfreeze)*melt_per_deg)
      else if (glac%prog(l)%wl>0 .and. glac%prog(l)%T<glac%pars%tfreeze) then
        melt = -min(glac%prog(l)%wl, (glac%pars%tfreeze-glac%prog(l)%T)*melt_per_deg)
      else
        melt = 0
      endif

      if(is_watch_point()) then
         write(*,'(a,i,99g)') 'l,T,wl(1),ws(1),melt:', l,glac%prog(l)%T, glac%prog(l)%wl, &
              glac%prog(l)%ws, melt
      endif

      glac%prog(l)%wl = glac%prog(l)%wl + melt
      glac%prog(l)%ws = glac%prog(l)%ws - melt
      glac%prog(l)%T = tfreeze &
         + (hcap*(glac%prog(l)%T-tfreeze) - hlf*melt) &
                              / ( hcap + (clw-csw)*melt )
      if(is_watch_point()) then
         write(*,'(a,i,99g)') 'l,T,wl(1),ws(1):', l,glac%prog(l)%T, glac%prog(l)%wl, &
              glac%prog(l)%ws
      endif

      glac_melt = glac_melt + melt / delta_time
    enddo
  if(is_watch_point()) then
     write(*,*) ' ***** glac_step_2 checkpoint 5 ***** '
     write(*,*) 'i,j,k,melt:',&
          glac_melt*delta_time
     do l = 1, num_l
        write(*,'(i2.2,99(a,g))')l, &
             ' T =', glac%prog(l)%T, &
             ' Th=', (glac%prog(l)%ws+glac%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', glac%prog(l)%wl,&
             ' ws=', glac%prog(l)%ws,&
             ' gw=', glac%prog(l)%groundwater
     enddo
  endif

ENDIF  !*****************************************************************************

  glac_Ttop = glac%prog(1)%T
  glac_Ctop = glac%heat_capacity_dry(1)*dz(1) &
    + clw*glac%prog(1)%wl + csw*glac%prog(1)%ws

! ----------------------------------------------------------------------------
! given solution for surface energy balance, write diagnostic output.
!  

  ! ---- increment time
  time = increment_time(time, int(delta_time), 0)
  
  ! ---- diagnostic section
  call send_tile_data (id_temp, glac%prog%T,     diag )
  call send_tile_data (id_lwc,  glac%prog(1:num_l)%wl/dz(1:num_l), diag )
  call send_tile_data (id_swc,  glac%prog(1:num_l)%ws/dz(1:num_l), diag )
  if (.not.lm2) then
  call send_tile_data (id_ie,   lrunf_ie,        diag )
  call send_tile_data (id_sn,   lrunf_sn,        diag )
  call send_tile_data (id_bf,   lrunf_bf,        diag )
  call send_tile_data (id_hie,  hlrunf_ie,       diag )
  call send_tile_data (id_hsn,  hlrunf_sn,       diag )
  call send_tile_data (id_hbf,  hlrunf_bf,       diag )
  endif

end subroutine glac_step_2

! ============================================================================
subroutine glac_diag_init ( id_lon, id_lat, zfull, zhalf )
  integer,         intent(in) :: id_lon  ! ID of land longitude (X) axis  
  integer,         intent(in) :: id_lat  ! ID of land longitude (X) axis
  real,            intent(in) :: zfull(:)! Full levels, m
  real,            intent(in) :: zhalf(:)! Half levels, m

  ! ---- local vars ----------------------------------------------------------
  integer :: axes(3)

  ! define vertical axis
  id_zhalf = diag_axis_init ( &
       'glac_zhalf', zhalf, 'meters', 'z', 'half level',  -1, set_name='glac' )
  id_zfull = diag_axis_init ( &
       'glac_zfull', zfull, 'meters', 'z', 'full level',  -1, set_name='glac', &
       edges=id_zhalf )

  ! define array of axis indices
  axes = (/ id_lon, id_lat, id_zfull /)

  ! define diagnostic fields
  id_lwc = register_tiled_diag_field ( module_name, 'glac_liq', axes,        &
       Time, 'bulk density of liquid water', 'kg/m3', missing_value=-100.0 )
  id_swc  = register_tiled_diag_field ( module_name, 'glac_ice',  axes,      &
       Time, 'bulk density of solid water', 'kg/m3',  missing_value=-100.0 )
  id_temp  = register_tiled_diag_field ( module_name, 'glac_T',  axes,       &
       Time, 'temperature',            'degK',  missing_value=-100.0 )
if (.not.lm2) then
  id_ie  = register_tiled_diag_field ( module_name, 'glac_rie',  axes(1:2),  &
       Time, 'inf exc runf',            'kg/(m2 s)',  missing_value=-100.0 )
  id_sn  = register_tiled_diag_field ( module_name, 'glac_rsn',  axes(1:2),  &
       Time, 'satn runf',            'kg/(m2 s)',  missing_value=-100.0 )
  id_bf  = register_tiled_diag_field ( module_name, 'glac_rbf',  axes(1:2),  &
       Time, 'baseflow',            'kg/(m2 s)',  missing_value=-100.0 )
  id_hie  = register_tiled_diag_field ( module_name, 'glac_hie',  axes(1:2), &
       Time, 'heat ie runf',            'W/m2',  missing_value=-100.0 )
  id_hsn  = register_tiled_diag_field ( module_name, 'glac_hsn',  axes(1:2), &
       Time, 'heat sn runf',            'W/m2',  missing_value=-100.0 )
  id_hbf  = register_tiled_diag_field ( module_name, 'glac_hbf',  axes(1:2), &
       Time, 'heat bf runf',            'W/m2',  missing_value=-100.0 )
endif

  
end subroutine glac_diag_init

! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function glac_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   glac_tile_exists = associated(tile%glac)
end function glac_tile_exists


! ============================================================================
! accessor functions: given a pointer to a land tile, they return pointer
! to the desired member of the land tile, of NULL if this member does not
! exist.
subroutine glac_temp_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%glac)) ptr=>tile%glac%prog%T
   endif
end subroutine glac_temp_ptr

subroutine glac_wl_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%glac)) ptr=>tile%glac%prog%wl
   endif
end subroutine glac_wl_ptr

subroutine glac_ws_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%glac)) ptr=>tile%glac%prog%ws
   endif
end subroutine glac_ws_ptr

subroutine glac_gw_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%glac)) ptr=>tile%glac%prog%groundwater
   endif
end subroutine glac_gw_ptr

subroutine glac_gwT_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%glac)) ptr=>tile%glac%prog%groundwater_T
   endif
end subroutine glac_gwT_ptr

end module glacier_mod


#include <fms_platform.h>

module glac_tile_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : &
     write_version_number, file_exist, check_nml_error, &
     close_file, stdlog
use constants_mod, only : &
     pi, tfreeze, hlf
use land_constants_mod, only : NBANDS
use land_io_mod, only : &
     init_cover_field
use land_tile_selectors_mod, only : &
     tile_selector_type, SEL_GLAC, register_tile_selector

implicit none
private

! ==== public interfaces =====================================================
public :: glac_prog_type
public :: glac_pars_type
public :: glac_tile_type

public :: new_glac_tile, delete_glac_tile
public :: glac_tiles_can_be_merged, merge_glac_tiles
public :: glac_is_selected
public :: get_glac_tile_tag
public :: glac_tile_stock_pe
public :: glac_tile_heat

public :: read_glac_data_namelist
public :: glac_cover_cold_start

public :: glac_data_radiation
public :: glac_data_diffusion
public :: glac_data_thermodynamics
public :: glac_data_hydraulics

public :: max_lev
! =====end of public interfaces ==============================================
interface new_glac_tile
   module procedure glac_tile_ctor
   module procedure glac_tile_copy_ctor
end interface


! ==== module constants ======================================================
character(len=*), parameter   :: &
     version     = '$Id: glac_tile.F90,v 17.0.2.1.2.1 2010/08/24 12:11:35 pjp Exp $', &
     tagname     = '$Name:  $', &
     module_name = 'glac_tile_mod'

integer, parameter :: max_lev          = 30 ! max number of levels in glacier
integer, parameter :: n_dim_glac_types = 1  ! size of lookup table
real,    parameter :: psi_wilt         = -150.  ! matric head at wilting
real,    parameter :: comp             = 0.001  ! m^-1

! from the modis brdf/albedo product user's guide:
real            :: g_iso  = 1.
real            :: g_vol  = 0.189184
real            :: g_geo  = -1.377622
real            :: g0_iso = 1.0
real            :: g1_iso = 0.0
real            :: g2_iso = 0.0
real            :: g0_vol = -0.007574
real            :: g1_vol = -0.070987
real            :: g2_vol =  0.307588
real            :: g0_geo = -1.284909
real            :: g1_geo = -0.166314
real            :: g2_geo =  0.041840

! ==== types =================================================================
type :: glac_pars_type
  real w_sat
  real awc_lm2
  real k_sat_ref
  real psi_sat_ref
  real chb
  real alpha              ! *** REPLACE LATER BY alpha(layer)
  real heat_capacity_ref
  real thermal_cond_ref
  real :: refl_max_dir(NBANDS), refl_max_dif(NBANDS) ! max reflectance for the direct and diffuse light
  real :: refl_min_dir(NBANDS), refl_min_dif(NBANDS) ! min reflectance for the direct and diffuse light
  real emis_dry
  real emis_sat
  real z0_momentum
  real tau_groundwater
  real rsa_exp         ! riparian source-area exponent
  real tfreeze
end type glac_pars_type

type :: glac_prog_type
  real wl
  real ws
  real T
  real groundwater
  real groundwater_T
end type glac_prog_type

type :: glac_tile_type
   integer :: tag ! kind of the glacier
   type(glac_pars_type)               :: pars
   type(glac_prog_type), pointer :: prog(:)
   real,                 pointer :: w_fc(:)
   real,                 pointer :: w_wilt(:)
   real :: Eg_part_ref
   real :: z0_scalar

   real, pointer :: heat_capacity_dry(:)
   real, pointer :: e(:), f(:)
end type glac_tile_type
! NOTE: When adding or modifying fields of this types, don't forget to change
! the operations on tile (e.g. copy) accordingly
! ==== module data ===========================================================

!---- namelist ---------------------------------------------------------------
real    :: k_over_B              = 2         ! reset to 0 for MCM
real    :: rate_fc               = 0.1/86400 ! 0.1 mm/d drainage rate at FC
real    :: sfc_heat_factor       = 1
integer :: z_sfc_layer           = 0
integer :: num_l                 = 18        ! number of glacier levels
real    :: dz(max_lev)           = (/ &
    0.02, 0.04, 0.04, 0.05, 0.05, 0.1, 0.1, 0.2, 0.2, &
    0.2,   0.4,  0.4,  0.4,  0.4, 0.4,  1.,  1.,  1., &
    0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0. /)
                                             ! thickness (m) of model layers,
                                             ! from top down
logical :: use_lm2_awc           = .false.
logical :: use_lad1_glac         = .false.
real    :: t_range               = 10.0

! from analysis of modis data (ignoring temperature dependence):
  real :: f_iso_cold(NBANDS) = (/ 0.177, 0.265 /)
  real :: f_vol_cold(NBANDS) = (/ 0.100, 0.126 /)
  real :: f_geo_cold(NBANDS) = (/ 0.027, 0.032 /)
  real :: f_iso_warm(NBANDS) = (/ 0.177, 0.265 /)
  real :: f_vol_warm(NBANDS) = (/ 0.100, 0.126 /)
  real :: f_geo_warm(NBANDS) = (/ 0.027, 0.032 /)
  real :: refl_cold_dif(NBANDS), refl_warm_dif(NBANDS)

! ---- remainder are used only for cold start ---------
character(len=16):: glac_to_use  = 'single-tile'
       ! 'multi-tile' for tiled soil [default]
       ! 'single-tile' for geographically varying glacier with single type per
       !     model grid cell
       ! 'uniform' for global constant soil, e.g., to reproduce MCM
logical :: use_single_glac       = .false.   ! true for single global glacier,
                                             ! e.g., to recover MCM
logical :: use_mcm_albedo        = .false.   ! .true. for CLIMAP albedo inputs
logical :: use_single_geo        = .false.   ! .true. for global gw res time,
                                             ! e.g., to recover MCM
integer :: glac_index_constant   = 1         ! index of global constant glacier,
                                             ! used when use_single_glacier
real    :: gw_res_time           = 60.*86400 ! mean groundwater residence time,
                                             ! used when use_single_geo
real    :: rsa_exp_global        = 1.5
real, dimension(n_dim_glac_types) :: &
     dat_w_sat             =(/ 1.000   /),&
     dat_awc_lm2           =(/ 1.000   /),&
     dat_k_sat_ref         =(/ 0.021   /),&
     dat_psi_sat_ref       =(/ -.059   /),&
     dat_chb               =(/   3.5   /),&
     dat_heat_capacity_ref =(/ 1.6e6   /),&
     dat_thermal_cond_ref  =(/   1.8   /),&
     dat_emis_dry          =(/ 0.950   /),&
     dat_emis_sat          =(/ 0.980   /),&
     dat_z0_momentum       =(/  0.01   /),&
     dat_tf_depr           =(/  0.00   /)
real, dimension(n_dim_glac_types, NBANDS) :: &
     dat_refl_max_dir, dat_refl_max_dif, &
     dat_refl_min_dir, dat_refl_min_dif
                      !  VIS    NIR
data dat_refl_max_dir / 0.800, 0.800 /, & 
     dat_refl_max_dif / 0.800, 0.800 /, & 
     dat_refl_min_dir / 0.650, 0.650 /, &
     dat_refl_min_dif / 0.650, 0.650 /
integer, dimension(n_dim_glac_types) :: &
     input_cover_types     =(/ 9 /)
character(len=4), dimension(n_dim_glac_types) :: &
     tile_names            =(/'glac'/)
real, public :: &
     cpw = 1952.0, &  ! specific heat of water vapor at constant pressure
     clw = 4218.0, &  ! specific heat of water (liquid)
     csw = 2106.0     ! specific heat of water (ice)

namelist /glac_data_nml/ &
     glac_to_use, tile_names, input_cover_types, &
     k_over_B,  &
     rate_fc, sfc_heat_factor, z_sfc_layer,          &
     num_l, dz,             &
     use_lm2_awc,   use_lad1_glac, &
     use_single_glac,      use_mcm_albedo,            &
     use_single_geo,        glac_index_constant,         &
     gw_res_time,           rsa_exp_global,      &
     dat_w_sat,             dat_awc_lm2,     &
     dat_k_sat_ref,         &
     dat_psi_sat_ref,               dat_chb,          &
     dat_heat_capacity_ref,         dat_thermal_cond_ref,   &
     dat_refl_max_dir,  dat_refl_max_dif,  &
     dat_refl_min_dir,  dat_refl_min_dif,  &
     dat_emis_dry,              dat_emis_sat,                &
     dat_z0_momentum,           dat_tf_depr, &
     tile_names, input_cover_types, &
     f_iso_cold, f_vol_cold, f_geo_cold, f_iso_warm, f_vol_warm, f_geo_warm 

! ---- end of namelist

integer :: num_sfc_layers

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ============================================================================
subroutine read_glac_data_namelist(glac_n_lev, glac_dz)
  integer, intent(out) :: glac_n_lev
  real,    intent(out) :: glac_dz(:)
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: i
  real    :: z

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=glac_data_nml, iostat=io)
     ierr = check_nml_error(io, 'glac_data_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=glac_data_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'glac_data_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  unit=stdlog()
  write (unit, nml=glac_data_nml)

  refl_cold_dif = g_iso*f_iso_cold + g_vol*f_vol_cold + g_geo*f_geo_cold
  refl_warm_dif = g_iso*f_iso_warm + g_vol*f_vol_warm + g_geo*f_geo_warm

  ! register selectors for tile-specific diagnostics
  do i=1, n_dim_glac_types
     call register_tile_selector(tile_names(i), long_name='',&
          tag = SEL_GLAC, idata1 = i )
  enddo

  ! initialize num_sfc_layers
  z = 0
  num_sfc_layers = 0
  do i = 1, num_l
     z = z + dz(i)
     if (z < z_sfc_layer+1.e-4) num_sfc_layers = i
  enddo

  ! set up output arguments
  glac_n_lev = num_l
  glac_dz = dz
end subroutine 


! ============================================================================
function glac_tile_ctor(tag) result(ptr)
  type(glac_tile_type), pointer :: ptr ! return value
  integer, intent(in)  :: tag ! kind of tile

  allocate(ptr)
  ptr%tag = tag
  ! allocate storage for tile data
  allocate(ptr%prog   (num_l),  &
           ptr%w_fc   (num_l),  &
           ptr%w_wilt (num_l),  &
           ptr%heat_capacity_dry (num_l),  &
           ptr%e      (num_l),  &
           ptr%f      (num_l)   )

  ! set initial values of the tile data
  call glacier_data_init_0d(ptr)
end function glac_tile_ctor
  

! ============================================================================
function glac_tile_copy_ctor(glac) result(ptr)
  type(glac_tile_type), intent(in) :: glac ! return value
  type(glac_tile_type), pointer    :: ptr  ! return value

  allocate(ptr)
  ptr = glac ! copy all non-allocatable data
  ! allocate storage for tile data
  allocate(ptr%prog   (num_l),  &
           ptr%w_fc   (num_l),  &
           ptr%w_wilt (num_l),  &
           ptr%heat_capacity_dry (num_l),  &
           ptr%e      (num_l),  &
           ptr%f      (num_l)   )
  ! copy allocatable data
   ptr%prog(:)   = glac%prog(:)
   ptr%w_fc(:)   = glac%w_fc(:)
   ptr%w_wilt(:) = glac%w_wilt(:)
   ptr%heat_capacity_dry(:) = glac%heat_capacity_dry(:) 
   ptr%e(:)      = glac%e(:)
   ptr%f(:)      = glac%f(:)
 end function glac_tile_copy_ctor


! ============================================================================
subroutine delete_glac_tile(ptr)
  type(glac_tile_type), pointer :: ptr

  deallocate(ptr%prog, ptr%w_fc, ptr%w_wilt, ptr%heat_capacity_dry, &
        ptr%e,  ptr%f)
  deallocate(ptr)
end subroutine delete_glac_tile


! ============================================================================
subroutine glacier_data_init_0d(glac)
  type(glac_tile_type), intent(inout) :: glac

  integer :: k
  k = glac%tag

  glac%pars%w_sat             = dat_w_sat            (k)
  glac%pars%awc_lm2           = dat_awc_lm2          (k)
  glac%pars%k_sat_ref         = dat_k_sat_ref        (k)
  glac%pars%psi_sat_ref       = dat_psi_sat_ref      (k)
  glac%pars%chb               = dat_chb              (k)
  glac%pars%alpha             = 1
  glac%pars%heat_capacity_ref = dat_heat_capacity_ref(k)
  glac%pars%thermal_cond_ref  = dat_thermal_cond_ref (k)
  glac%pars%refl_max_dir      = dat_refl_max_dir     (k,:)
  glac%pars%refl_max_dif      = dat_refl_max_dif     (k,:)
  glac%pars%refl_min_dir      = dat_refl_min_dir     (k,:)
  glac%pars%refl_min_dif      = dat_refl_min_dif     (k,:)
  glac%pars%emis_dry          = dat_emis_dry         (k)
  glac%pars%emis_sat          = dat_emis_sat         (k)
  glac%pars%z0_momentum       = dat_z0_momentum      (k)
  glac%pars%tfreeze           = tfreeze - dat_tf_depr(k)

  glac%pars%tau_groundwater   = 86400*30 ! 30 days
  glac%pars%rsa_exp           = rsa_exp_global

  ! initialize derived data
  if (use_lm2_awc) then
     glac%w_wilt(:) = 0.15
     glac%w_fc  (:) = 0.15 + glac%pars%awc_lm2
  else
     glac%w_wilt(:) = glac%pars%w_sat &
          *(glac%pars%psi_sat_ref/(psi_wilt*glac%pars%alpha))**(1/glac%pars%chb)
     glac%w_fc  (:) = glac%pars%w_sat &
          *(rate_fc/(glac%pars%k_sat_ref*glac%pars%alpha**2))**(1/(3+2*glac%pars%chb))
  endif

  ! below made use of phi_e from parlange via entekhabi
  glac%Eg_part_ref  = (-4*glac%w_fc(1)**2*glac%pars%k_sat_ref*glac%pars%psi_sat_ref*glac%pars%chb &
       /(pi*glac%pars%w_sat)) * (glac%w_fc(1)/glac%pars%w_sat)**(2+glac%pars%chb)   &
       *(2*pi/(3*glac%pars%chb**2*(1+3/glac%pars%chb)*(1+4/glac%pars%chb)))/2

  glac%z0_scalar = glac%pars%z0_momentum * exp(-k_over_B)
  
end subroutine glacier_data_init_0d


! ============================================================================
function glac_cover_cold_start(land_mask, lonb, latb) result (glac_frac)
  logical, intent(in) :: land_mask(:,:)    ! land mask
  real,    intent(in) :: lonb(:,:), latb(:,:) ! boundaries of the grid cells
  real,    pointer    :: glac_frac (:,:,:) ! output: map of fractional coverage

  allocate( glac_frac(size(land_mask,1),size(land_mask,2),n_dim_glac_types))

  call init_cover_field(glac_to_use, 'INPUT/ground_type.nc', 'cover','frac', &
       lonb, latb, glac_index_constant, input_cover_types, glac_frac)
  
end function 

! =============================================================================
function glac_tiles_can_be_merged(glac1,glac2) result(response)
  logical :: response
  type(glac_tile_type), intent(in) :: glac1,glac2

  response = (glac1%tag==glac2%tag)
end function

! =============================================================================
! combine two glacier states with specified weights; the result goes into
! the second one.
! t1 does not change; the properties of t2 (that is, heat capacity, etc) do not 
! change either -- that might be not good in the long run
subroutine merge_glac_tiles(g1,w1,g2,w2)
  type(glac_tile_type), intent(in)    :: g1
  type(glac_tile_type), intent(inout) :: g2     
  real                , intent(in)    :: w1, w2 ! relative weights
  
  ! ---- local vars
  real    :: x1, x2 ! normalized relative weights
  real    :: gw, HEAT1, HEAT2 ! temporaries for groundwater and heat
  integer :: i
  real    :: C1(num_l), C2(num_l) ! heat capacities of dry glacier
  
  ! calculate normalized weights
  x1 = w1/(w1+w2)
  x2 = 1.0 - x1
  
  ! calculate dry heat capacities of the glaciers
  call glac_dry_heat_cap(g1,C1)
  call glac_dry_heat_cap(g2,C2)

  ! combine state variables
  do i = 1,num_l
    ! calculate heat content at this level for both source tiles
    HEAT1 = &
    (C1(i)*dz(i)+clw*g1%prog(i)%wl+csw*g1%prog(i)%ws) * (g1%prog(i)%T-tfreeze)
    HEAT2 = &
    (C2(i)*dz(i)+clw*g2%prog(i)%wl+csw*g2%prog(i)%ws) * (g2%prog(i)%T-tfreeze)
    ! calculate (and assign) combined water mass
    g2%prog(i)%wl = g1%prog(i)%wl*x1 + g2%prog(i)%wl*x2
    g2%prog(i)%ws = g1%prog(i)%ws*x1 + g2%prog(i)%ws*x2
    ! if dry heat capacity of combined glacier is to be changed, update it here
    ! ...
    ! calculate combined temperature, based on total heat content and combined
    ! heat capacity
    g2%prog(i)%T = (HEAT1*x1+HEAT2*x2) / &
      (C2(i)*dz(i)+clw*g2%prog(i)%wl+csw*g2%prog(i)%ws) + tfreeze

    ! calculate combined groundwater content
    gw = g1%prog(i)%groundwater*x1 + g2%prog(i)%groundwater*x2
    ! calculate combined groundwater temperature
    if(gw/=0) then
       g2%prog(i)%groundwater_T = ( &
            g1%prog(i)%groundwater*x1*(g1%prog(i)%groundwater_T-tfreeze) + &
            g2%prog(i)%groundwater*x2*(g2%prog(i)%groundwater_T-tfreeze)   &
            ) / gw + Tfreeze
    else
       g2%prog(i)%groundwater_T = &
            x1*g1%prog(i)%groundwater_T + x2*g2%prog(i)%groundwater_T
    endif
    g2%prog(i)%groundwater = gw
  enddo
  
end subroutine

! =============================================================================
! returns true if tile fits the specified selector
function glac_is_selected(glac, sel)
  logical glac_is_selected
  type(tile_selector_type),  intent(in) :: sel
  type(glac_tile_type),      intent(in) :: glac

  glac_is_selected = (sel%idata1 == glac%tag)
end function 


! ============================================================================
! returns tag of the tile
function get_glac_tile_tag(glac) result(tag)
  integer :: tag
  type(glac_tile_type), intent(in) :: glac
  
  tag = glac%tag
end function

! ============================================================================
! compute glacier thermodynamic properties.
subroutine glac_dry_heat_cap ( glac, heat_capacity_dry)
  type(glac_tile_type), intent(in)  :: glac
  real,                 intent(out) :: heat_capacity_dry(:)

  ! ---- local vars
  integer l

  ! these will eventually be functions of water content (or psi) and T.
  do l = 1, num_sfc_layers
     heat_capacity_dry(l) = sfc_heat_factor*glac%pars%heat_capacity_ref
  enddo
  do l = num_sfc_layers+1, num_l
     heat_capacity_dry(l) = glac%pars%heat_capacity_ref
  enddo

end subroutine 


! ============================================================================
! compute bare-glacier albedos and bare-glacier emissivity
subroutine glac_data_radiation ( glac, cosz, use_brdf, &
                                 glac_refl_dir, glac_refl_dif, glac_emis )
  type(glac_tile_type), intent(in) :: glac
  real,                 intent(in) :: cosz
  logical,              intent(in) :: use_brdf
  real,                 intent(out):: glac_refl_dir(:), glac_refl_dif(:), glac_emis

  ! ---- local vars 
  real  :: blend, t_crit
  real :: warm_value_dir(NBANDS), cold_value_dir(NBANDS)
  real :: warm_value_dif(NBANDS), cold_value_dif(NBANDS)
  real :: zenith_angle, zsq, zcu

  t_crit = tfreeze - t_range
  blend = (glac%prog(1)%T - t_crit) / t_range
  if (blend < 0.0) blend = 0.0
  if (blend > 1.0) blend = 1.0
  if (use_brdf) then
      zenith_angle = acos(cosz)
      zsq = zenith_angle*zenith_angle
      zcu = zenith_angle*zsq
      warm_value_dir = f_iso_warm*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                     + f_vol_warm*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                     + f_geo_warm*(g0_geo+g1_geo*zsq+g2_geo*zcu)
      cold_value_dir = f_iso_cold*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                     + f_vol_cold*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                     + f_geo_cold*(g0_geo+g1_geo*zsq+g2_geo*zcu)
      warm_value_dif = refl_warm_dif
      cold_value_dif = refl_cold_dif
    else
      warm_value_dir = glac%pars%refl_min_dir
      cold_value_dir = glac%pars%refl_max_dir
      warm_value_dif = glac%pars%refl_min_dif
      cold_value_dif = glac%pars%refl_max_dif
    endif
  glac_refl_dir = cold_value_dir + blend*(warm_value_dir-cold_value_dir)
  glac_refl_dif = cold_value_dif + blend*(warm_value_dif-cold_value_dif)
  glac_emis     = glac%pars%emis_dry + blend*(glac%pars%emis_sat-glac%pars%emis_dry)

end subroutine glac_data_radiation


! ============================================================================
! compute bare-glacier roughness
subroutine glac_data_diffusion ( glac, glac_z0s, glac_z0m )
  type(glac_tile_type), intent(in) :: glac
  real,                 intent(out):: glac_z0s, glac_z0m

  ! ---- surface roughness ---------------------------------------------------
  glac_z0s = glac%z0_scalar
  glac_z0m = glac%pars%z0_momentum

end subroutine glac_data_diffusion


! ============================================================================
! compute glacier thermodynamic properties.
subroutine glac_data_thermodynamics ( glac_pars, vlc_sfc, vsc_sfc, &  
     glac_rh, heat_capacity_dry, thermal_cond)
  type(glac_pars_type), intent(in)  :: glac_pars
  real,                 intent(in)  :: vlc_sfc
  real,                 intent(in)  :: vsc_sfc
  real,                 intent(out) :: glac_rh
  real,                 intent(out) :: heat_capacity_dry(:)
  real,                 intent(out) :: thermal_cond(:)

  ! ---- local vars
  integer l

! ----------------------------------------------------------------------------
! in preparation for implicit energy balance, determine various measures
! of water availability, so that vapor fluxes will not exceed mass limits
! ----------------------------------------------------------------------------

  glac_rh = 1

  ! these will eventually be functions of water content (or psi) and T.
  do l = 1, num_sfc_layers
     heat_capacity_dry(l) = sfc_heat_factor*glac_pars%heat_capacity_ref
     thermal_cond(l)  = sfc_heat_factor*glac_pars%thermal_cond_ref
  enddo
  do l = num_sfc_layers+1, num_l
     heat_capacity_dry(l) = glac_pars%heat_capacity_ref
     thermal_cond(l)  = glac_pars%thermal_cond_ref
  enddo

end subroutine 


! ============================================================================
! compute glacier hydraulic properties.
subroutine glac_data_hydraulics (glac, vlc, vsc, &
     psi, DThDP, hyd_cond, DKDP, DPsi_min, DPsi_max, tau_gw, &
     glac_w_fc  )
  type(glac_tile_type),        intent(in)  :: glac
  real,                        intent(in),  dimension(:) :: vlc, vsc
  real,                        intent(out), dimension(:) :: &
       psi, DThDP, hyd_cond, DKDP, glac_w_fc
  real,                        intent(out) :: &
       DPsi_min, DPsi_max, tau_gw

  ! ---- local vars
  integer l
  real,  dimension(num_l) :: vlc_loc
  real :: real1
  logical :: logical1

  ! ---- T-dependence of hydraulic properties --------------------------------
  ! k_sat   = glac%pars%k_sat0   !  * mu(t0)/mu(t), where mu is dynamic viscosity
  ! psi_sat = glac%pars%psi_sat0 !  * exp(c*(psi-psi0)), where c~+/-(?)0.0068
  ! better approach would be to adopt air entrapment model
  ! or at least to scale against surface tension model


  ! ---- water and ice dependence of hydraulic properties --------------------
  ! ---- (T-dependence can be added later)
  hyd_cond = 1; DThDP = 1
  do l = 1, num_l
    hyd_cond(l) = (glac%pars%k_sat_ref*glac%pars%alpha**2)*  &
         ! * mu(T)/mu(t_ref), where mu is dynamic viscosity
          (vlc(l)/glac%pars%w_sat)**(3+2*glac%pars%chb)
    if (hyd_cond(l).lt.1.e-12*glac%pars%k_sat_ref) then
      vlc_loc (l) = glac%pars%w_sat*(1.e-12)**(1./(3+2*glac%pars%chb))
      hyd_cond(l) = 1.e-12*glac%pars%k_sat_ref
      if (vsc(l).eq.0.) then
        DThDP   (l) = -vlc_loc(l)  &
             *(vlc_loc(l)/glac%pars%w_sat)**glac%pars%chb &
             /(glac%pars%psi_sat_ref*glac%pars%chb)
        psi     (l) = (glac%pars%psi_sat_ref/glac%pars%alpha) &
             *(glac%pars%w_sat/vlc_loc(l))**glac%pars%chb &
             + (vlc(l)-vlc_loc (l))/DThDP   (l)
        DKDP    (l) = 0.
      else
        psi     (l) = ((glac%pars%psi_sat_ref/glac%pars%alpha) / 2.2) &
             *(glac%pars%w_sat/vlc_loc(l))**glac%pars%chb
        DKDP    (l) = 0.
        DThDP   (l) = 0.
      endif
    else
      if (vsc(l).eq.0.) then
        real1 = glac%pars%w_sat - vlc(l)
        logical1 = real1.ge.0.
        if (logical1) then
           !              where (vlc(l).le.glac%pars%w_sat)
           psi     (l) = (glac%pars%psi_sat_ref/glac%pars%alpha) &
                *(glac%pars%w_sat/vlc(l))**glac%pars%chb
           DKDP    (l) = -(2+3/glac%pars%chb)*hyd_cond(l) &
                /psi(l)
           DThDP   (l) = -vlc(l)/(psi(l)*glac%pars%chb)
        else
           psi(l) = glac%pars%psi_sat_ref &
                + (vlc(l)-glac%pars%w_sat)/comp
           DThDP(l) = comp
           hyd_cond(l) = glac%pars%k_sat_ref
           DKDP(l) = 0.
        endif
      else
        psi     (l) = ((glac%pars%psi_sat_ref/glac%pars%alpha) / 2.2) &
             *(glac%pars%w_sat/vlc(l))**glac%pars%chb
        DKDP    (l) = 0.
        DThDP   (l) = 0.
      endif
    endif
  enddo

  if (DThDP(1).ne.0.) then
    DPsi_min =            -vlc(1) /DThDP(1)
    DPsi_max = (glac%pars%w_sat-vlc(1))/DThDP(1)
  else
    Dpsi_min = -1.e16
    DPsi_max = -psi(1)
  endif

  glac_w_fc = glac%w_fc

  ! ---- groundwater ---------------------------------------------------------
  tau_gw = glac%pars%tau_groundwater

end subroutine glac_data_hydraulics

! ============================================================================
subroutine glac_tile_stock_pe (glac, twd_liq, twd_sol  )
  type(glac_tile_type),  intent(in)    :: glac
  real,                  intent(out)   :: twd_liq, twd_sol
  integer n
  
  twd_liq = 0.
  twd_sol = 0.
  do n=1, size(glac%prog)
    twd_liq = twd_liq + glac%prog(n)%wl + glac%prog(n)%groundwater
    twd_sol = twd_sol + glac%prog(n)%ws
    enddo

end subroutine glac_tile_stock_pe

! ============================================================================
! returns glacier heat content, J/m2
function glac_tile_heat (glac) result(heat) ; real heat
  type(glac_tile_type),  intent(in)  :: glac

  integer :: i

  heat = 0
  do i = 1, num_l
     heat = heat + &
          (glac%heat_capacity_dry(i)*dz(i) + clw*glac%prog(i)%wl + csw*glac%prog(i)%ws)&
                           *(glac%prog(i)%T-tfreeze) + &
          clw*glac%prog(i)%groundwater*(glac%prog(i)%groundwater_T-tfreeze) - &
          hlf*glac%prog(i)%ws
  enddo
end function

end module glac_tile_mod


! ============================================================================
! lake model module
! ============================================================================
module lake_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : error_mesg, file_exist,  &
     read_data, check_nml_error, &
     stdlog, write_version_number, close_file, mpp_pe, mpp_root_pe, FATAL, NOTE
use time_manager_mod,   only: time_type, increment_time, time_type_to_real
use diag_manager_mod,   only: diag_axis_init, register_diag_field,           &
                              register_static_field, send_data
use constants_mod,      only: tfreeze, hlv, hlf, dens_h2o, PI, grav, vonkarm, &
                              rdgas

use land_constants_mod, only : &
     NBANDS
use land_io_mod, only : read_field
use lake_tile_mod, only : &
     lake_tile_type, lake_pars_type, lake_prog_type, read_lake_data_namelist, &
     lake_data_radiation, lake_data_diffusion, &
     lake_data_thermodynamics, &
     max_lev, cpw,clw,csw, lake_width_inside_lake, large_lake_sill_width
use land_tile_mod, only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=)
use land_tile_diag_mod, only : register_tiled_static_field, &
     register_tiled_diag_field, send_tile_data, diag_buff_type, &
     send_tile_data_r0d_fptr
use land_data_mod,      only : land_state_type, lnd
use land_tile_io_mod, only : print_netcdf_error, create_tile_out_file, &
     read_tile_data_r1d_fptr, write_tile_data_r1d_fptr, sync_nc_files, &
     get_input_restart_name
use nf_utils_mod, only : nfu_inq_var, nfu_def_dim, nfu_put_att
use land_debug_mod, only: is_watch_point
use land_utils_mod, only : put_to_tiles_r0d_fptr

implicit none
private

! ==== public interfaces =====================================================
public :: read_lake_namelist
public :: lake_init
public :: lake_end
public :: save_lake_restart

public :: lake_get_sfc_temp
public :: lake_radiation
public :: lake_diffusion
public :: lake_step_1
public :: lake_step_2

public :: large_dyn_small_stat
! =====end of public interfaces ==============================================


! ==== module constants ======================================================
character(len=*), parameter, private   :: &
    module_name = 'lake',&
    version     = '$Id: lake.F90,v 17.0.2.1.2.1 2010/08/24 12:11:35 pjp Exp $',&
    tagname     = '$Name: hiram_20101115_bw $'

! ==== module variables ======================================================

!---- namelist ---------------------------------------------------------------
real    :: init_temp            = 288.        ! cold-start lake T
real    :: init_w               = 1000.      ! cold-start w(l)/dz(l)
real    :: init_groundwater     =   0.        ! cold-start gw storage
logical :: use_rh_feedback      = .true.
logical :: make_all_lakes_wide  = .false.
logical :: large_dyn_small_stat = .true.
logical :: relayer_in_step_one  = .false.
logical :: float_ice_to_top     = .false.
real    :: min_rat              = 0.4
logical :: do_stratify          = .true.
character(len=16):: albedo_to_use = ''  ! or 'brdf-params'
real    :: K_z_large            = 1.

namelist /lake_nml/ init_temp, init_w,       &
                    init_groundwater, use_rh_feedback, cpw, clw, csw, &
                    make_all_lakes_wide, large_dyn_small_stat, &
                    relayer_in_step_one, float_ice_to_top, &
                    min_rat, do_stratify, albedo_to_use, K_z_large
!---- end of namelist --------------------------------------------------------
real    :: K_z_molec            = 1.4e-7
real    :: tc_molec             = 0.59052 ! dens_h2o*clw*K_z_molec
real    :: tc_molec_ice         = 2.5

logical         :: module_is_initialized =.FALSE.
logical         :: use_brdf
type(time_type) :: time
real            :: delta_time

integer         :: num_l              ! # of water layers
real            :: zfull (max_lev)    ! diag axis, dimensionless layer number
real            :: zhalf (max_lev+1)
real            :: max_rat

! ---- diagnostic field IDs
integer :: id_lwc, id_swc, id_temp, id_ie, id_sn, id_bf, id_hie, id_hsn, id_hbf
integer :: id_evap, id_dz, id_wl, id_ws, id_K_z, id_silld, id_sillw
integer :: id_silld_old, id_sillw_old
! ==== end of module variables ===============================================

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

contains

! ============================================================================
subroutine read_lake_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: l

  call read_lake_data_namelist(num_l)

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=lake_nml, iostat=io)
     ierr = check_nml_error(io, 'lake_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=lake_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'lake_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=lake_nml)
  endif

  ! ---- set up vertical discretization
  zhalf(1) = 0
  do l = 1, num_l;   
     zhalf(l+1) = zhalf(l) + 1.
     zfull(l) = 0.5*(zhalf(l+1) + zhalf(l))
  enddo
  
  max_rat = 1. / min_rat
  if (trim(albedo_to_use)=='brdf-params') then
     use_brdf = .true.
  else if (trim(albedo_to_use)=='') then
     use_brdf = .false.
  else
     call error_mesg('lake_init',&
          'option albedo_to_use="'// trim(albedo_to_use)//&
          '" is invalid, use "brdf-params", or nothing ("")',&
          FATAL)
  endif

end subroutine read_lake_namelist


! ============================================================================
! initialize lake model
subroutine lake_init ( id_lon, id_lat )
  integer, intent(in) :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in) :: id_lat  ! ID of land latitude (Y) axis

  ! ---- local vars 
  integer :: unit         ! unit for various i/o
  type(land_tile_enum_type)     :: te,ce ! last and current tile list elements
  type(land_tile_type), pointer :: tile  ! pointer to current tile
  character(len=256) :: restart_file_name
  logical :: restart_exists
  real, allocatable :: buffer(:,:),bufferc(:,:),buffert(:,:)

  module_is_initialized = .TRUE.
  time       = lnd%time
  delta_time = time_type_to_real(lnd%dt_fast)

allocate(buffer (lnd%is:lnd%ie,lnd%js:lnd%je))
allocate(bufferc(lnd%is:lnd%ie,lnd%js:lnd%je))
allocate(buffert(lnd%is:lnd%ie,lnd%js:lnd%je))

IF (LARGE_DYN_SMALL_STAT) THEN

call read_data('INPUT/river_data.nc', 'connected_to_next', bufferc(:,:), lnd%domain)
call put_to_tiles_r0d_fptr(bufferc, lnd%tile_map, lake_connected_to_next_ptr)

call read_data('INPUT/river_data.nc', 'whole_lake_area', buffer(:,:), lnd%domain)
call put_to_tiles_r0d_fptr(buffer, lnd%tile_map, lake_whole_area_ptr)

call read_data('INPUT/river_data.nc', 'lake_depth_sill', buffer(:,:),  lnd%domain)
call put_to_tiles_r0d_fptr(buffer,  lnd%tile_map, lake_depth_sill_ptr)

! lake_tau is just used here as a flag for 'large lakes'
! sill width of -1 is a flag saying not to allow transient storage
call read_data('INPUT/river_data.nc', 'lake_tau', buffert(:,:),  lnd%domain)
buffer = -1.
!where (bufferc.gt.0.5) buffer = lake_width_inside_lake
where (bufferc.lt.0.5 .and. buffert.gt.1.) buffer = large_lake_sill_width
call put_to_tiles_r0d_fptr(buffer, lnd%tile_map, lake_width_sill_ptr)

ELSE
call read_data('INPUT/river_data.nc', 'whole_lake_area', bufferc(:,:), lnd%domain)

call read_data('INPUT/river_data.nc', 'lake_depth_sill', buffer(:,:), lnd%domain)
where (bufferc.eq.0.)                      buffer = 0.
where (bufferc.gt.0..and.bufferc.lt.2.e10) buffer = max(2., 2.5e-4*sqrt(bufferc))
call put_to_tiles_r0d_fptr(buffer,  lnd%tile_map, lake_depth_sill_ptr)
call put_to_tiles_r0d_fptr(bufferc, lnd%tile_map, lake_whole_area_ptr)

buffer = 4. * buffer
where (bufferc.gt.2.e10) buffer = min(buffer, 60.)
call read_data('INPUT/river_data.nc', 'connected_to_next', bufferc(:,:), lnd%domain)
call put_to_tiles_r0d_fptr(bufferc, lnd%tile_map, lake_connected_to_next_ptr)

where (bufferc.gt.0.5) buffer=lake_width_inside_lake
if (make_all_lakes_wide) buffer = lake_width_inside_lake
call put_to_tiles_r0d_fptr(buffer, lnd%tile_map, lake_width_sill_ptr)
ENDIF

deallocate (buffer, bufferc, buffert)

  ! -------- initialize lake state --------
  te = tail_elmt (lnd%tile_map)
  ce = first_elmt(lnd%tile_map)
  do while(ce /= te)
     tile=>current_tile(ce)  ! get pointer to current tile
     ce=next_elmt(ce)        ! advance position to the next tile
     
     if (.not.associated(tile%lake)) cycle
     
     tile%lake%prog%dz = tile%lake%pars%depth_sill/num_l
     if (init_temp.ge.tfreeze) then
        tile%lake%prog%wl = init_w*tile%lake%prog%dz
        tile%lake%prog%ws = 0
     else
        tile%lake%prog%wl = 0
        tile%lake%prog%ws = init_w*tile%lake%prog%dz
     endif
     tile%lake%prog%T             = init_temp
     tile%lake%prog%groundwater   = init_groundwater
     tile%lake%prog%groundwater_T = init_temp
  enddo

  call get_input_restart_name('INPUT/lake.res.nc',restart_exists,restart_file_name)
  if (restart_exists) then
     call error_mesg('lake_init',&
          'reading NetCDF restart "'//trim(restart_file_name)//'"',&
          NOTE)
     __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,unit))
     if(nfu_inq_var(unit, 'dz')==NF_NOERR) &
          call read_tile_data_r1d_fptr(unit, 'dz', lake_dz_ptr  )
     call read_tile_data_r1d_fptr(unit, 'temp'         , lake_temp_ptr  )
     call read_tile_data_r1d_fptr(unit, 'wl'           , lake_wl_ptr )
     call read_tile_data_r1d_fptr(unit, 'ws'           , lake_ws_ptr )
     call read_tile_data_r1d_fptr(unit, 'groundwater'  , lake_gw_ptr )
     call read_tile_data_r1d_fptr(unit, 'groundwater_T', lake_gwT_ptr)
     __NF_ASRT__(nf_close(unit))     
  else
     call error_mesg('lake_init',&
          'cold-starting lake',&
          NOTE)
  endif

  call lake_diag_init ( id_lon, id_lat )
  ! ---- static diagnostic section
  call send_tile_data_r0d_fptr(id_sillw, lnd%tile_map, lake_width_sill_ptr)
  call send_tile_data_r0d_fptr(id_silld, lnd%tile_map, lake_depth_sill_ptr)

end subroutine lake_init


! ============================================================================
subroutine lake_end ()

  module_is_initialized =.FALSE.

end subroutine lake_end


! ============================================================================
subroutine save_lake_restart (tile_dim_length, timestamp)
  integer, intent(in) :: tile_dim_length ! length of tile dim. in the output file
  character(*), intent(in) :: timestamp ! timestamp to add to the file name

  ! ---- local vars ----------------------------------------------------------
  integer :: unit            ! restart file i/o unit

  call error_mesg('lake_end','writing NetCDF restart',NOTE)
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'lake.res.nc', &
          lnd%coord_glon, lnd%coord_glat, lake_tile_exists, tile_dim_length)

  ! in addition, define vertical coordinate
  if (mpp_pe()==lnd%io_pelist(1)) then
     __NF_ASRT__(nfu_def_dim(unit,'zfull',zfull(1:num_l),'full level','m'))
     __NF_ASRT__(nfu_put_att(unit,'zfull','positive','down'))
  endif
  call sync_nc_files(unit)
  
  ! write out fields
  call write_tile_data_r1d_fptr(unit,'dz'           ,lake_dz_ptr,  'zfull','layer thickness','m')
  call write_tile_data_r1d_fptr(unit,'temp'         ,lake_temp_ptr,'zfull','lake temperature','degrees_K')
  call write_tile_data_r1d_fptr(unit,'wl'           ,lake_wl_ptr  ,'zfull','liquid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'ws'           ,lake_ws_ptr  ,'zfull','solid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'groundwater'  ,lake_gw_ptr  ,'zfull')
  call write_tile_data_r1d_fptr(unit,'groundwater_T',lake_gwT_ptr ,'zfull')
  
  ! close file
  __NF_ASRT__(nf_close(unit))

end subroutine save_lake_restart


! ============================================================================
subroutine lake_get_sfc_temp(lake, lake_T)
  type(lake_tile_type), intent(in) :: lake
  real, intent(out) :: lake_T

  lake_T = lake%prog(1)%T
end subroutine lake_get_sfc_temp


! ============================================================================
! compute lake-only radiation properties
subroutine lake_radiation ( lake, cosz, &
     lake_refl_dir, lake_refl_dif, lake_refl_lw, lake_emis )
  type(lake_tile_type), intent(in) :: lake
  real, intent(in) :: cosz
  real, intent(out) :: lake_refl_dir(NBANDS), lake_refl_dif(NBANDS), lake_refl_lw, lake_emis

  call lake_data_radiation ( lake, cosz, use_brdf, lake_refl_dir, lake_refl_dif, lake_emis )
  lake_refl_lw = 1 - lake_emis
end subroutine lake_radiation


! ============================================================================
! compute lake-only roughness parameters
subroutine lake_diffusion ( lake, lake_z0s, lake_z0m )
  type(lake_tile_type), intent(in) :: lake
  real, intent(out) :: lake_z0s, lake_z0m

  call lake_data_diffusion ( lake, lake_z0s, lake_z0m )
end subroutine lake_diffusion

! ============================================================================
! update lake properties explicitly for time step.
! integrate lake-heat conduction equation upward from bottom of lake
! to surface, delivering linearization of surface ground heat flux.
subroutine lake_step_1 ( u_star_a, p_surf, latitude, lake, &
                         lake_T, &
                         lake_rh, lake_liq, lake_ice, lake_subl, lake_tf, lake_G0, &
                         lake_DGDT )

  real, intent(in)   :: u_star_a, p_surf, latitude
  type(lake_tile_type), intent(inout) :: lake
  real, intent(out)  :: &
       lake_T, &
       lake_rh, lake_liq, lake_ice, lake_subl, &
       lake_tf, & ! freezing temperature of lake, degK
       lake_G0, &
       lake_DGDT

  ! ---- local vars
  real                  :: bbb, denom, dt_e, tc_dz_eff
  real                  :: z_cum, z_mid, dz_mid, rho_t_mid, k_neutral
  real, dimension(num_l):: aaa, ccc, thermal_cond, heat_capacity, dz_alt, &
                            z_alt, rho_t
  integer               :: l
  real                  :: k_star, N_sq, Ri, u_star, z_liq, z_ice, rho_a
  real                  :: lake_depth, lshc1, lshc2
! ----------------------------------------------------------------------------
! in preparation for implicit energy balance, determine various measures
! of water availability, so that vapor fluxes will not exceed mass limits
! ----------------------------------------------------------------------------

  if(is_watch_point()) then
     write(*,*) 'lake_step_1 checkpoint 1'
     write(*,*) 'mask    ', .true.   
     write(*,*) 'T       ', lake_T
     write(*,*) 'rh      ', lake_rh
     write(*,*) 'liq     ', lake_liq
     write(*,*) 'ice     ', lake_ice
     write(*,*) 'subl    ', lake_subl
     write(*,*) 'G0      ', lake_G0
     write(*,*) 'DGDT    ', lake_DGDT
    do l = 1, num_l
      write(*,*) ' level=', l,&
                 ' dz=', lake%prog(l)%dz,&
                 ' T =', lake%prog(l)%T,&
                 ' wl=', lake%prog(l)%wl,&
                 ' ws=', lake%prog(l)%ws, &
                 'K_z=', lake%prog(l)%K_z
      enddo
  endif


  if (relayer_in_step_one) call lake_relayer ( lake )

  lake%prog%K_z = 0.
  lake_T = lake%prog(1)%T
  if (use_rh_feedback) then
      lake_depth = (sum(lake%prog(:)%wl)+sum(lake%prog(:)%ws)) / DENS_H2O
    else
      lake_depth = lake%pars%depth_sill
    endif
  call lake_data_thermodynamics ( lake%pars, lake_depth, lake_rh, &
                                  lake%heat_capacity_dry, thermal_cond )
! Ignore air humidity in converting atmospheric friction velocity to lake value
  rho_a = p_surf/(rdgas*lake_T)
! No momentum transfer through ice cover
  if (lake%prog(1)%ws.le.0.) then
      u_star = u_star_a*sqrt(rho_a/dens_h2o)
      k_star = 2.79e-5*sqrt(sin(abs(latitude)))*u_star**(-1.84)
    else
      u_star = 0.
      k_star = 1.
    endif
! k_star from B. Henderson-Sellers (1985, Appl. Math. Mod., 9)
!  k_star = 2.79e-5*sqrt(sin(abs(latitude)))*u_star**(-1.84)
  z_cum = 0.
  do l = 1, num_l
    heat_capacity(l) = lake%heat_capacity_dry(l) * lake%prog(l)%dz &
            + clw*lake%prog(l)%wl + csw*lake%prog(l)%ws
    dz_alt(l) = (lake%prog(l)%wl + lake%prog(l)%ws)/dens_h2o
    z_alt(l) = z_cum + 0.5*dz_alt(l)
    z_cum = z_cum + dz_alt(l)
! rho_t from hostetler and bartlein (1990), citing Heggen (1983)
! is a call available in fms?
    rho_t(l) = 1. - 1.9549e-5*abs(lake%prog(l)%T-277.)**1.68
    enddo

  lake_liq  = max(lake%prog(1)%wl, 0.)
  lake_ice  = max(lake%prog(1)%ws, 0.)
  if (lake_ice > 0) then
     lake_subl = 1
  else
     lake_subl = 0
  endif

  if(num_l > 1) then
    if (do_stratify) then
        do l = 1, num_l-1
          if (lake%prog(l)%ws.le.0..and.lake%prog(l+1)%ws.le.0.) then
              dz_mid = z_alt(l+1)-z_alt(l)
              z_mid = 0.5 * (z_alt(l)+z_alt(l+1))
              rho_t_mid = 0.5*(rho_t(l)+rho_t(l+1))
              if (k_star*z_mid .lt. 10.) then
                  k_neutral = vonkarm * u_star * z_mid * exp (-k_star * z_mid)
                else
                  k_neutral = 0.
                endif
              N_sq = (grav / rho_t_mid) * (rho_t(l+1)-rho_t(l)) /dz_mid
              if (N_sq .gt. 0. .and. k_neutral.ne.0.) then
                  ! stability function from B. Henderson-Sellers (1985)
                  Ri = 0.05*(-1. + sqrt(1.+40.*N_sq*(vonkarm*z_mid/u_star)**2 &
                                                   *exp(2.*k_star*z_mid)))
                  lake%prog(l)%K_z = k_neutral / (1. + 37.*Ri*Ri) + K_z_molec
                else if (k_neutral.eq.0.) then
                  lake%prog(l)%K_z = K_z_molec
                else  ! arbitrary constant for unstable mixing
                  lake%prog(l)%K_z = K_z_large
                endif
              aaa(l+1) = - lake%prog(l)%K_z * delta_time / (dz_alt(l+1)*dz_mid)
              ccc(l)   = - lake%prog(l)%K_z * delta_time / (dz_alt(l  )*dz_mid)
            else
              z_liq = 0.5*(lake%prog(l)%wl+lake%prog(l+1)%wl)/dens_h2o
              z_ice = 0.5*(lake%prog(l)%ws+lake%prog(l+1)%ws)/dens_h2o
              tc_dz_eff = 1. / (z_liq/tc_molec + z_ice/tc_molec_ice)
              aaa(l+1) = - tc_dz_eff * delta_time / heat_capacity(l+1)
              ccc(l)   = - tc_dz_eff * delta_time / heat_capacity(l)
            endif
          enddo
      else
        do l = 1, num_l-1
          tc_dz_eff = 2 / ( dz_alt(l+1)/thermal_cond(l+1) &
             + dz_alt(l)/thermal_cond(l)   )
          aaa(l+1) = - tc_dz_eff * delta_time / heat_capacity(l+1)
          ccc(l)   = - tc_dz_eff * delta_time / heat_capacity(l)
          enddo
      endif

     bbb = 1.0 - aaa(num_l)
     denom = bbb
     dt_e = aaa(num_l)*(lake%prog(num_l)%T - lake%prog(num_l-1)%T)
     lake%e(num_l-1) = -aaa(num_l)/denom
     lake%f(num_l-1) = dt_e/denom
     do l = num_l-1, 2, -1
        bbb = 1.0 - aaa(l) - ccc(l)
        denom = bbb + ccc(l)*lake%e(l)
        dt_e = - ( ccc(l)*(lake%prog(l+1)%T - lake%prog(l)%T  ) &
                  -aaa(l)*(lake%prog(l)%T   - lake%prog(l-1)%T) )
        lake%e(l-1) = -aaa(l)/denom
        lake%f(l-1) = (dt_e - ccc(l)*lake%f(l))/denom
     end do
     denom = delta_time/(heat_capacity(1) )
     lake_G0    = ccc(1)*(lake%prog(2)%T- lake%prog(1)%T &
          + lake%f(1)) / denom
     lake_DGDT  = (1 - ccc(1)*(1-lake%e(1))) / denom   
  else  ! one-level case
     denom = delta_time/heat_capacity(1)
     lake_G0    = 0.
     lake_DGDT  = 1. / denom
  end if
  
  ! set the freezing temperature of the lake
  lake_tf = tfreeze
  
  if(is_watch_point()) then
     write(*,*) 'lake_step_1 checkpoint 2'
     write(*,*) 'mask    ', .true.   
     write(*,*) 'T       ', lake_T
     write(*,*) 'rh      ', lake_rh
     write(*,*) 'liq     ', lake_liq
     write(*,*) 'ice     ', lake_ice
     write(*,*) 'subl    ', lake_subl
     write(*,*) 'G0      ', lake_G0
     write(*,*) 'DGDT    ', lake_DGDT
    do l = 1, num_l
      write(*,*) ' level=', l,&
                 ' dz=', lake%prog(l)%dz,&
                 ' T =', lake%prog(l)%T,&
                 ' wl=', lake%prog(l)%wl,&
                 ' ws=', lake%prog(l)%ws, &
                 'K_z=', lake%prog(l)%K_z
      enddo
  endif

end subroutine lake_step_1


! ============================================================================
! apply boundary flows to lake water and move lake water vertically.
  subroutine lake_step_2 ( lake, diag, lake_subl, snow_lprec, snow_hlprec,  &
                           subs_DT, subs_M_imp, subs_evap, &
                           use_tfreeze_in_grnd_latent, &
                           lake_levap, lake_fevap, lake_melt, &
                           lake_Ttop, lake_Ctop )
  type(lake_tile_type), intent(inout) :: lake
  type(diag_buff_type), intent(inout) :: diag
  real, intent(in) :: &
     lake_subl     !
  real, intent(in) :: &
     snow_lprec, &
     snow_hlprec, &
     subs_DT,       &!
     subs_M_imp,       &! rate of phase change of non-evaporated lake water
     subs_evap
  logical, intent(in) :: use_tfreeze_in_grnd_latent
  real, intent(out) :: &
     lake_levap, lake_fevap, lake_melt, &
     lake_Ttop, lake_Ctop

  ! ---- local vars
  real, dimension(num_l) :: del_t, eee, fff, &
             psi, DThDP, hyd_cond, DKDP, K, DKDPm, DKDPp, grad, &
             dW_l, u_minus, u_plus, DPsi, lake_w_fc
  real, dimension(num_l+1) :: flow
  real, dimension(num_l  ) :: div
  real :: ice_to_move, h_upper, h_lower, h_to_move_up, &
     lprec_eff, hlprec_eff, hcap, dheat, &
     melt_per_deg, melt, lshc1, lshc2
  real, dimension(num_l-1) :: del_z
  real :: jj
  integer :: l

  jj = 1.
  
  if(is_watch_point()) then
    write(*,*) ' ***** lake_step_2 checkpoint 1 ***** '
    write(*,*) 'mask    ', .true.   
    write(*,*) 'subs_evap    ', subs_evap   
    write(*,*) 'snow_lprec   ', snow_lprec  
    write(*,*) 'subs_M_imp   ', subs_M_imp   
    write(*,*) 'theta_s ', lake%pars%w_sat
    do l = 1, num_l
      write(*,*) ' level=', l,&
                 ' dz=', lake%prog(l)%dz,&
                 ' T =', lake%prog(l)%T,&
                 ' Th=', (lake%prog(l)%ws &
                         +lake%prog(l)%wl)/(dens_h2o*lake%prog(l)%dz),&
                 ' wl=', lake%prog(l)%wl,&
                 ' ws=', lake%prog(l)%ws,&
                 ' gw=', lake%prog(l)%groundwater
      enddo
  endif

  ! ---- record fluxes ---------
  lake_levap  = subs_evap*(1-lake_subl)
  lake_fevap  = subs_evap*   lake_subl
  lake_melt   = subs_M_imp / delta_time

  ! ---- load surface temp change and perform back substitution --------------
  del_t(1) = subs_DT
  lake%prog(1)%T = lake%prog(1)%T + del_t(1)
  if ( num_l > 1) then
    do l = 1, num_l-1
      del_t(l+1) = lake%e(l) * del_t(l) + lake%f(l)
      lake%prog(l+1)%T = lake%prog(l+1)%T + del_t(l+1)
    end do
  end if

  if(is_watch_point()) then
    write(*,*) ' ***** lake_step_2 checkpoint 2 ***** '
    do l = 1, num_l
       write(*,*) 'level=', l, 'T', lake%prog(l)%T
    enddo
  endif

  ! ---- extract evap from lake and do implicit melt --------------------
  lake%prog(1)%wl = lake%prog(1)%wl - lake_levap*delta_time
  lake%prog(1)%ws = lake%prog(1)%ws - lake_fevap*delta_time
  hcap = lake%heat_capacity_dry(1)*lake%prog(1)%dz &
                     + clw*lake%prog(1)%wl + csw*lake%prog(1)%ws
  ! T adjustment for nonlinear terms (del_T)*(del_W)
  dheat = delta_time*(clw*lake_levap+csw*lake_fevap)*del_T(1)
  ! take out extra heat not claimed in advance for evaporation
  if (use_tfreeze_in_grnd_latent) dheat = dheat &
          - delta_time*((cpw-clw)*lake_levap+(cpw-csw)*lake_fevap) &
                                 *(lake%prog(1)%T-del_T(1)-tfreeze)
  lake%prog(1)%T  = lake%prog(1)%T  + dheat/hcap
  lake%prog(1)%wl = lake%prog(1)%wl + subs_M_imp
  lake%prog(1)%ws = lake%prog(1)%ws - subs_M_imp
  lake%prog(1)%T  = tfreeze + (hcap*(lake%prog(1)%T-tfreeze) ) &
                            / ( hcap + (clw-csw)*subs_M_imp )

  if(is_watch_point()) then
     write(*,*) ' ***** lake_step_2 checkpoint 2.1 ***** '
     do l = 1, num_l
        write(*,*) 'level=', l, 'T', lake%prog(l)%T
     enddo
  endif

  ! ---- remainder of mass fluxes and associated sensible heat fluxes --------
  ! note that only liquid inputs are received by  lake from snow pack. any
  ! snow fall just creates a snow pack on top  of lake, even if lake is not
  ! frozen. but snow pack on top of unfrozen lake will interact thermally,
  ! so that either lake freezes or snow melts and falls in.
    flow=1
    flow(1)  = snow_lprec *delta_time
    do l = 1, num_l
      flow(l+1) = 0
      dW_l(l) = flow(l) - flow(l+1)
      lake%prog(l)%wl = lake%prog(l)%wl + dW_l(l)
    enddo

  if(is_watch_point()) then
     write(*,*) ' ***** lake_step_2 checkpoint 3.3 ***** '
     do l = 1, num_l
        write(*,*) ' level=', l,&
             ' wl=', lake%prog(l)%wl,&
             'flow=', flow(l)
     enddo
  endif
  
  hcap = lake%heat_capacity_dry(1)*lake%prog(1)%dz &
                     + clw*(lake%prog(1)%wl-dW_l(1)) + csw*lake%prog(1)%ws
  lake%prog(1)%T = tfreeze + (hcap*(lake%prog(1)%T-tfreeze) +  &
                                 snow_hlprec*delta_time) &
                            / ( hcap + clw*dW_l(1) )

  if(is_watch_point()) then
    write(*,*) ' ***** lake_step_2 checkpoint 3.4 ***** '
    write(*,*) ' tfreeze', tfreeze
    write(*,*) ' snow_hlprec', snow_hlprec
  endif

  do l = 1, num_l
    ! ---- compute explicit melt/freeze --------------------------------------
    hcap = lake%heat_capacity_dry(l)*lake%prog(l)%dz &
             + clw*lake%prog(l)%wl + csw*lake%prog(l)%ws
    melt_per_deg = hcap/hlf
    if (lake%prog(l)%ws>0 .and. lake%prog(l)%T>tfreeze) then
      melt =  min(lake%prog(l)%ws, (lake%prog(l)%T-tfreeze)*melt_per_deg)
    else if (lake%prog(l)%wl>0 .and. lake%prog(l)%T<tfreeze) then
      melt = -min(lake%prog(l)%wl, (tfreeze-lake%prog(l)%T)*melt_per_deg)
    else
      melt = 0
    endif
    lake%prog(l)%wl = lake%prog(l)%wl + melt
    lake%prog(l)%ws = lake%prog(l)%ws - melt
    lake%prog(l)%T = tfreeze &
       + (hcap*(lake%prog(l)%T-tfreeze) - hlf*melt) &
                            / ( hcap + (clw-csw)*melt )
    lake_melt = lake_melt + melt / delta_time
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** lake_step_2 checkpoint 5 ***** '
     do l = 1, num_l
        write(*,*) ' level=', l,&
             ' dz=', lake%prog(l)%dz,&
             ' T =', lake%prog(l)%T,&
             ' Th=', (lake%prog(l)%ws +lake%prog(l)%wl)/(dens_h2o*lake%prog(l)%dz),&
             ' wl=', lake%prog(l)%wl,&
             ' ws=', lake%prog(l)%ws,&
             ' gw=', lake%prog(l)%groundwater
     enddo
  endif

  if (.not.relayer_in_step_one) call lake_relayer ( lake )

  if(is_watch_point()) then
     write(*,*) ' ***** lake_step_2 checkpoint 6 ***** '
     do l = 1, num_l
        write(*,*) ' level=', l,&
             ' dz=', lake%prog(l)%dz,&
             ' T =', lake%prog(l)%T,&
             ' Th=', (lake%prog(l)%ws +lake%prog(l)%wl)/(dens_h2o*lake%prog(l)%dz),&
             ' wl=', lake%prog(l)%wl,&
             ' ws=', lake%prog(l)%ws,&
             ' gw=', lake%prog(l)%groundwater
     enddo
  endif

  if (float_ice_to_top) then
      do l = num_l, 2, -1
        if (lake%prog(l)%ws .gt. 0. .and. lake%prog(l-1)%wl .gt. 0.) then
            ice_to_move = min(lake%prog(l)%ws, lake%prog(l-1)%wl)
            h_upper = (clw*lake%prog(l-1)%wl+csw*lake%prog(l-1)%ws)*lake%prog(l-1)%T
            h_lower = (clw*lake%prog(l  )%wl+csw*lake%prog(l  )%ws)*lake%prog(l  )%T
            lake%prog(l-1)%wl = lake%prog(l-1)%wl - ice_to_move
            lake%prog(l-1)%ws = lake%prog(l-1)%ws + ice_to_move
            lake%prog(l  )%wl = lake%prog(l  )%wl + ice_to_move
            lake%prog(l  )%ws = lake%prog(l  )%ws - ice_to_move
            h_to_move_up = ice_to_move*(csw*lake%prog(l)%T-clw*lake%prog(l-1)%T)
            h_upper  = h_upper + h_to_move_up
            h_lower  = h_lower - h_to_move_up
            lake%prog(l-1)%T = h_upper / (clw*lake%prog(l-1)%wl+csw*lake%prog(l-1)%ws)
            lake%prog(l  )%T = h_lower / (clw*lake%prog(l  )%wl+csw*lake%prog(l  )%ws)
          endif
        enddo
    endif

  if(is_watch_point()) then
     write(*,*) ' ***** lake_step_2 checkpoint 7 ***** '
     do l = 1, num_l
        write(*,*) ' level=', l,&
             ' dz=', lake%prog(l)%dz,&
             ' T =', lake%prog(l)%T,&
             ' Th=', (lake%prog(l)%ws +lake%prog(l)%wl)/(dens_h2o*lake%prog(l)%dz),&
             ' wl=', lake%prog(l)%wl,&
             ' ws=', lake%prog(l)%ws,&
             ' gw=', lake%prog(l)%groundwater
     enddo
  endif


  lake_Ttop = lake%prog(1)%T
  lake_Ctop = lake%heat_capacity_dry(1)*lake%prog(1)%dz &
       + clw*lake%prog(1)%wl + csw*lake%prog(1)%ws

! ----------------------------------------------------------------------------
! given solution for surface energy balance, write diagnostic output.
!  

  ! ---- increment time
  time = increment_time(time, int(delta_time), 0)

  ! ---- diagnostic section
  call send_tile_data (id_dz,   lake%prog%dz,     diag )
  call send_tile_data (id_temp, lake%prog%T,     diag )
  call send_tile_data (id_wl,  lake%prog(1:num_l)%wl, diag )
  call send_tile_data (id_ws,  lake%prog(1:num_l)%ws, diag )
  call send_tile_data (id_lwc,  lake%prog(1:num_l)%wl/lake%prog(1:num_l)%dz, diag )
  call send_tile_data (id_swc,  lake%prog(1:num_l)%ws/lake%prog(1:num_l)%dz, diag )
  call send_tile_data (id_K_z,  lake%prog(1:num_l)%K_z,        diag )
  call send_tile_data (id_evap, lake_levap+lake_fevap, diag )
  call send_tile_data (id_silld_old, lake%pars%depth_sill,diag)
  call send_tile_data (id_sillw_old, lake%pars%width_sill,diag)

end subroutine lake_step_2


! ============================================================================
!
  subroutine lake_relayer ( lake )
  type(lake_tile_type), intent(inout) :: lake

  ! ---- local vars
  integer :: l, l_lowest_thin_layer, l_highest_thick_layer
  real :: new_dz, new_ws, new_wl, new_h, new_T, liq_frac

! now check whether we need to re-layer the lake.
  if ( (lake%prog(1)%wl+lake%prog(1)%ws) &
      /(lake%prog(2)%wl+lake%prog(2)%ws) .gt. max_rat) then
      ! top layer has grown too thick. join two lower layers, and split
      ! top layer into two layers. in special case, just join and
      ! re-split top two layers.
      l_lowest_thin_layer = num_l
      do l = 2, num_l-1
        if (lake%prog(l)%dz.lt.0.99*lake%prog(num_l)%dz) l_lowest_thin_layer = l
        enddo
      if (l_lowest_thin_layer.gt.2) then
          new_dz = lake%prog(l_lowest_thin_layer)%dz &
                  + lake%prog(l_lowest_thin_layer-1)%dz
          new_wl = lake%prog(l_lowest_thin_layer)%wl &
                  + lake%prog(l_lowest_thin_layer-1)%wl
          new_ws = lake%prog(l_lowest_thin_layer)%ws &
                  + lake%prog(l_lowest_thin_layer-1)%ws
          new_h  = ( clw*lake%prog(l_lowest_thin_layer)%wl &
                   + csw*lake%prog(l_lowest_thin_layer)%ws) &
                   *     lake%prog(l_lowest_thin_layer)%T &
                 + ( clw*lake%prog(l_lowest_thin_layer-1)%wl &
                   + csw*lake%prog(l_lowest_thin_layer-1)%ws) &
                   *     lake%prog(l_lowest_thin_layer-1)%T
          new_T = new_h / (clw*new_wl+csw*new_ws)
          lake%prog(l_lowest_thin_layer)%dz = new_dz
          lake%prog(l_lowest_thin_layer)%wl = new_wl
          lake%prog(l_lowest_thin_layer)%ws = new_ws
          lake%prog(l_lowest_thin_layer)%T  = new_T
          do l = l_lowest_thin_layer-1, 3, -1
            lake%prog(l)%dz = lake%prog(l-1)%dz
            lake%prog(l)%wl = lake%prog(l-1)%wl
            lake%prog(l)%ws = lake%prog(l-1)%ws
            lake%prog(l)%T  = lake%prog(l-1)%T
            enddo
          liq_frac = lake%prog(1)%wl / (lake%prog(1)%wl+lake%prog(1)%ws)
          lake%prog(2)%wl =     liq_frac *DENS_H2O*lake%prog(2)%dz
          lake%prog(2)%ws = (1.-liq_frac)*DENS_H2O*lake%prog(2)%dz
          lake%prog(2)%T  = lake%prog(1)%T
          lake%prog(1)%dz = lake%prog(2)%dz
          lake%prog(1)%wl = lake%prog(1)%wl - lake%prog(2)%wl
          lake%prog(1)%ws = lake%prog(1)%ws - lake%prog(2)%ws
        else
          new_wl = lake%prog(1)%wl + lake%prog(2)%wl
          new_ws = lake%prog(1)%ws + lake%prog(2)%ws
          new_h  = ( clw*lake%prog(1)%wl + csw*lake%prog(1)%ws)   &
                                                 * lake%prog(1)%T &
                 + ( clw*lake%prog(2)%wl + csw*lake%prog(2)%ws)    &
                                                 * lake%prog(2)%T
          new_T  = new_h / (clw*new_wl+csw*new_ws)
          liq_frac = new_wl / (new_wl+new_ws)
          lake%prog(2)%dz = lake%prog(3)%dz
          lake%prog(2)%wl =     liq_frac *DENS_H2O*lake%prog(2)%dz
          lake%prog(2)%ws = (1.-liq_frac)*DENS_H2O*lake%prog(2)%dz
          lake%prog(2)%T  = new_T
          lake%prog(1)%dz = lake%prog(2)%dz
          lake%prog(1)%wl = new_wl - lake%prog(2)%wl
          lake%prog(1)%ws = new_ws - lake%prog(2)%ws
          lake%prog(1)%T  = new_T
        endif
    else if(  (lake%prog(1)%wl+lake%prog(1)%ws) &
             /(lake%prog(2)%wl+lake%prog(2)%ws) .lt. min_rat) then
      ! top layer has grown too thin. join with next layer down, and split
      ! a lower layer to maintain number of layers.  in special case, just
      ! join and re-split top two layers.
      l_highest_thick_layer = 2
      do l = num_l, 3, -1
        if (lake%prog(l)%dz.gt.1.01*lake%prog(2)%dz) l_highest_thick_layer = l
        enddo
      new_wl = lake%prog(1)%wl + lake%prog(2)%wl
      new_ws = lake%prog(1)%ws + lake%prog(2)%ws
      new_h  = ( clw*lake%prog(1)%wl + csw*lake%prog(1)%ws)   &
                                             * lake%prog(1)%T &
             + ( clw*lake%prog(2)%wl + csw*lake%prog(2)%ws)    &
                                             * lake%prog(2)%T
      new_T  = new_h / (clw*new_wl+csw*new_ws)
      if (l_highest_thick_layer.gt.2) then
          lake%prog(1)%dz = lake%prog(2)%dz
          lake%prog(1)%wl = new_wl
          lake%prog(1)%ws = new_ws
          lake%prog(1)%T  = new_T
          do l = 2, l_highest_thick_layer-2
            lake%prog(l)%dz = lake%prog(l+1)%dz
            lake%prog(l)%wl = lake%prog(l+1)%wl
            lake%prog(l)%ws = lake%prog(l+1)%ws
            lake%prog(l)%T  = lake%prog(l+1)%T
            enddo
          new_dz = lake%prog(l_highest_thick_layer)%dz / 2.
          new_wl = lake%prog(l_highest_thick_layer)%wl / 2.
          new_ws = lake%prog(l_highest_thick_layer)%ws / 2.
          new_T  = lake%prog(l_highest_thick_layer)%T
          lake%prog(l_highest_thick_layer-1)%dz = new_dz
          lake%prog(l_highest_thick_layer-1)%wl = new_wl
          lake%prog(l_highest_thick_layer-1)%ws = new_ws
          lake%prog(l_highest_thick_layer-1)%T  = new_T
          lake%prog(l_highest_thick_layer)%dz = new_dz
          lake%prog(l_highest_thick_layer)%wl = new_wl
          lake%prog(l_highest_thick_layer)%ws = new_ws
          lake%prog(l_highest_thick_layer)%T  = new_T
        else
          liq_frac = new_wl / (new_wl+new_ws)
          lake%prog(2)%dz = lake%prog(3)%dz / 2.
          lake%prog(2)%wl =     liq_frac *DENS_H2O*lake%prog(2)%dz
          lake%prog(2)%ws = (1.-liq_frac)*DENS_H2O*lake%prog(2)%dz
          lake%prog(2)%T  = new_T
          lake%prog(1)%dz = lake%prog(2)%dz
          lake%prog(1)%wl = new_wl - lake%prog(2)%wl
          lake%prog(1)%ws = new_ws - lake%prog(2)%ws
          lake%prog(1)%T  = new_T          
        endif
    endif
  end subroutine lake_relayer

! ============================================================================
subroutine lake_diag_init ( id_lon, id_lat )
  integer,         intent(in) :: id_lon  ! ID of land longitude (X) axis  
  integer,         intent(in) :: id_lat  ! ID of land longitude (X) axis

  ! ---- local vars
  integer :: axes(3)
  integer :: id_zhalf, id_zfull

  ! define vertical axis
  id_zhalf = diag_axis_init ( &
       'zhalf_lake', zhalf(1:num_l+1), 'meters', 'z', 'half level',  -1, set_name='lake' )
  id_zfull = diag_axis_init ( &
       'zfull_lake', zfull(1:num_l),   'meters', 'z', 'full level',  -1, set_name='lake', &
       edges=id_zhalf )

  ! define array of axis indices
  axes = (/ id_lon, id_lat, id_zfull /)

  ! define static diagnostic fields
  id_sillw = register_tiled_static_field ( module_name, 'lake_width', &
       axes(1:2), 'lake width at outflow', 'm', missing_value=-100.0 )
  id_silld = register_tiled_static_field ( module_name, 'lake_depth', &
       axes(1:2), 'lake depth below sill', 'm', missing_value=-100.0 )

  ! define dynamic diagnostic fields
  id_dz  = register_tiled_diag_field ( module_name, 'lake_dz', axes,         &
       Time, 'nominal layer thickness', 'm', missing_value=-100.0 )
  id_wl  = register_tiled_diag_field ( module_name, 'lake_wl', axes,         &
       Time, 'liquid water mass', 'kg/m2', missing_value=-100.0 )
  id_ws  = register_tiled_diag_field ( module_name, 'lake_ws', axes,         &
       Time, 'solid water mass', 'kg/m2', missing_value=-100.0 )
  id_lwc  = register_tiled_diag_field ( module_name, 'lake_liq',  axes,       &
       Time, 'bulk density of liquid water', 'kg/m3',  missing_value=-100.0 )
  id_swc  = register_tiled_diag_field ( module_name, 'lake_ice',  axes,       &
       Time, 'bulk density of solid water', 'kg/m3',  missing_value=-100.0 )
  id_temp  = register_tiled_diag_field ( module_name, 'lake_T',  axes,        &
       Time, 'temperature',            'degK',  missing_value=-100.0 )
  id_K_z  = register_tiled_diag_field ( module_name, 'lake_K_z', axes,         &
       Time, 'vertical diffusivity', 'm2/s', missing_value=-100.0 )
  id_evap  = register_tiled_diag_field ( module_name, 'lake_evap',  axes(1:2),  &
       Time, 'lake evap',            'kg/(m2 s)',  missing_value=-100.0 )
       
  id_silld_old = register_tiled_diag_field (module_name, 'sill_depth', &
       axes(1:2), Time, 'obsolete, pls use lake_depth (static)','m', &
       missing_value=-100.0 )
  id_sillw_old = register_tiled_diag_field (module_name, 'sill_width', &
       axes(1:2), Time, 'obsolete, pls use lake_width (static)','m', &
       missing_value=-100.0 )

end subroutine lake_diag_init

! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function lake_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   lake_tile_exists = associated(tile%lake)
end function lake_tile_exists


! ============================================================================
! accessor functions: given a pointer to a land tile, they return pointer
! to the desired member of the land tile, of NULL if this member does not
! exist.
subroutine lake_dz_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%prog%dz
   endif
end subroutine lake_dz_ptr

subroutine lake_temp_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%prog%T
   endif
end subroutine lake_temp_ptr

subroutine lake_wl_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%prog%wl
   endif
end subroutine lake_wl_ptr

subroutine lake_ws_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%prog%ws
   endif
end subroutine lake_ws_ptr

subroutine lake_gw_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%prog%groundwater
   endif
end subroutine lake_gw_ptr

subroutine lake_gwT_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%prog%groundwater_T
   endif
end subroutine lake_gwT_ptr

subroutine lake_connected_to_next_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%pars%connected_to_next
   endif
end subroutine lake_connected_to_next_ptr

subroutine lake_depth_sill_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%pars%depth_sill
   endif
end subroutine lake_depth_sill_ptr

subroutine lake_whole_area_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%pars%whole_area
   endif
end subroutine lake_whole_area_ptr

subroutine lake_width_sill_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%lake)) ptr=>tile%lake%pars%width_sill
   endif
end subroutine lake_width_sill_ptr

end module lake_mod





#include <fms_platform.h>

module lake_tile_mod

use mpp_domains_mod, only : &
     domain2d, mpp_get_compute_domain, mpp_global_field

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : &
     write_version_number, file_exist, check_nml_error, &
     read_data, close_file, stdlog
use constants_mod, only : &
     pi, tfreeze, hlf
use land_constants_mod, only : &
     NBANDS
use land_io_mod, only : &
     init_cover_field
use land_tile_selectors_mod, only : &
     tile_selector_type, SEL_LAKE, register_tile_selector

implicit none
private

! ==== public interfaces =====================================================
public :: lake_pars_type
public :: lake_prog_type
public :: lake_tile_type

public :: new_lake_tile, delete_lake_tile
public :: lake_tiles_can_be_merged, merge_lake_tiles
public :: lake_is_selected
public :: get_lake_tile_tag
public :: lake_tile_stock_pe
public :: lake_tile_heat

public :: read_lake_data_namelist
public :: lake_cover_cold_start

public :: lake_data_radiation
public :: lake_data_diffusion
public :: lake_data_thermodynamics

public :: max_lev
public :: lake_width_inside_lake
public :: large_lake_sill_width
! =====end of public interfaces ==============================================
interface new_lake_tile
   module procedure lake_tile_ctor
   module procedure lake_tile_copy_ctor
end interface


! ==== module constants ======================================================
character(len=*), private, parameter   :: &
     version     = '$Id: lake_tile.F90,v 17.0.2.2.2.1 2010/08/24 12:11:35 pjp Exp $', &
     tagname     = '$Name:  $', &
     module_name = 'lake_tile_mod'

integer, parameter :: max_lev          = 80
integer, parameter :: n_dim_lake_types = 1  ! size of lookup table
real,    parameter :: psi_wilt         = -150.  ! matric head at wilting
real,    parameter :: comp             = 0.001  ! m^-1

! from the modis brdf/albedo product user's guide:
real            :: g_iso  = 1.
real            :: g_vol  = 0.189184
real            :: g_geo  = -1.377622
real            :: g0_iso = 1.0
real            :: g1_iso = 0.0
real            :: g2_iso = 0.0
real            :: g0_vol = -0.007574
real            :: g1_vol = -0.070987
real            :: g2_vol =  0.307588
real            :: g0_geo = -1.284909
real            :: g1_geo = -0.166314
real            :: g2_geo =  0.041840

! ==== types =================================================================
type :: lake_pars_type
  real w_sat
  real awc_lm2
  real k_sat_ref
  real psi_sat_ref
  real chb
  real alpha              ! *** REPLACE LATER BY alpha(layer)
  real heat_capacity_ref
  real thermal_cond_ref
  real refl_dry_dir(NBANDS)
  real refl_dry_dif(NBANDS)
  real refl_sat_dir(NBANDS)
  real refl_sat_dif(NBANDS)
  real emis_dry
  real emis_sat
  real z0_momentum
  real depth_sill
  real width_sill
  real whole_area
  real connected_to_next
  real tau_groundwater
  real rsa_exp         ! riparian source-area exponent
end type lake_pars_type

type :: lake_prog_type
  real dz
  real wl
  real ws
  real T
  real K_z
  real groundwater
  real groundwater_T
end type lake_prog_type

type :: lake_tile_type
   integer :: tag ! kind of the lake
   type(lake_prog_type), pointer :: prog(:)
   type(lake_pars_type)          :: pars
   real,                 pointer :: w_fc(:)
   real,                 pointer :: w_wilt(:)
   real :: Eg_part_ref
   real :: z0_scalar
   real, pointer :: e(:),f(:)
   real, pointer :: heat_capacity_dry(:)
end type lake_tile_type

! ==== module data ===========================================================
real, public :: &
     cpw = 1952.0, & ! specific heat of water vapor at constant pressure
     clw = 4218.0, & ! specific heat of water (liquid)
     csw = 2106.0    ! specific heat of water (ice)

!---- namelist ---------------------------------------------------------------
real    :: lake_width_inside_lake = 1.e5
real    :: large_lake_sill_width = 200.
real    :: min_lake_frac         = 0.
real    :: max_lake_rh           = 1.
real    :: k_over_B              = 0.25      ! reset to 0 for MCM
real    :: rate_fc               = 0.1/86400 ! 0.1 mm/d drainage rate at FC
real    :: sfc_heat_factor       = 1
integer, public :: num_l                 = 18           ! number of lake levels
real    :: dz(max_lev)           = (/ &
    0.02, 0.04, 0.04, 0.05, 0.05, 0.1, 0.1, 0.2, 0.2, &
    0.2,   0.4,  0.4,  0.4,  0.4, 0.4,  1.,  1.,  1., &
    0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., &
    0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., &
    0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., &
    0.,0.,0.,0.,0. /)
                                              ! thickness (m) of model layers,
                                              ! from top down
logical :: use_lm2_awc           = .false.
  integer :: n_map_1st_lake_type = 10

! from analysis of modis data (ignoring temperature dependence):
  real :: f_iso_ice(NBANDS) = (/ 0.056, 0.131 /)
  real :: f_vol_ice(NBANDS) = (/ 0.017, 0.053 /)
  real :: f_geo_ice(NBANDS) = (/ 0.004, 0.010 /)
  real :: f_iso_liq(NBANDS) = (/ 0.056, 0.131 /)
  real :: f_vol_liq(NBANDS) = (/ 0.017, 0.053 /)
  real :: f_geo_liq(NBANDS) = (/ 0.004, 0.010 /)
  real :: refl_ice_dif(NBANDS), refl_liq_dif(NBANDS)

! ---- remainder are used only for cold start ---------
logical :: round_frac_down       = .false.  ! when false, any lake_frac < min_lake_frac
                                            ! is set to min_lake_frac.
                                            ! when true, any lake_frac < min_lake_frac
                                            ! is set to 0.
                                            
character(len=16):: lake_to_use     = 'single-tile'
       ! 'multi-tile' for tiled soil [default]
       ! 'single-tile' for geographically varying soil with single type per
       !     model grid cell
       ! 'uniform' for global constant soil, e.g., to reproduce MCM
       ! 'from-rivers' to get the fraction of lakes from river module
logical :: use_single_lake       = .false.   ! true for single global lake,
                                             ! e.g., to recover MCM
logical :: use_mcm_albedo        = .false.   ! .true. for CLIMAP albedo inputs
logical :: use_single_geo        = .false.   ! .true. for global gw res time,
                                             ! e.g., to recover MCM
integer :: lake_index_constant   = 1         ! index of global constant lake,
                                             ! used when use_single_lake
real    :: gw_res_time           = 60.*86400 ! mean groundwater residence time,
                                             ! used when use_single_geo
real    :: rsa_exp_global        = 1.5
real, dimension(n_dim_lake_types) :: &
  dat_w_sat             =(/ 1.000   /),&
  dat_awc_lm2           =(/ 1.000   /),&
  dat_k_sat_ref         =(/ 0.021   /),&
  dat_psi_sat_ref       =(/ -.059   /),&
  dat_chb               =(/   3.5   /),&
  dat_heat_capacity_ref =(/ 8.4e7   /),&
  dat_thermal_cond_ref  =(/ 8.4e7   /),&
  dat_emis_dry          =(/ 0.950   /),&
  dat_emis_sat          =(/ 0.980   /),&
  dat_z0_momentum       =(/ 1.4e-4  /),&
  dat_tf_depr           =(/  0.00   /)
real, dimension(n_dim_lake_types, NBANDS) :: &
     dat_refl_dry_dif, dat_refl_dry_dir, &
     dat_refl_sat_dif, dat_refl_sat_dir
data &
                   !  VIS    NIR
  dat_refl_dry_dif / 0.060, 0.060 /, &
  dat_refl_dry_dir / 0.060, 0.060 /, &
  dat_refl_sat_dir / 0.060, 0.060 /, &
  dat_refl_sat_dif / 0.060, 0.060 /
integer, dimension(n_dim_lake_types) :: &
  input_cover_types     =(/ 10 /)
character(len=4), dimension(n_dim_lake_types) :: &
  tile_names            =(/ 'lake' /)

namelist /lake_data_nml/ lake_width_inside_lake, &
     large_lake_sill_width, &
     min_lake_frac, round_frac_down, max_lake_rh, &
     lake_to_use,input_cover_types, tile_names, &
     k_over_B,         &
     rate_fc, sfc_heat_factor,        &
     num_l,                   dz,                      &
     use_lm2_awc,    n_map_1st_lake_type, &
     use_single_lake,           use_mcm_albedo,            &
     use_single_geo,            lake_index_constant,         &
     gw_res_time,            rsa_exp_global,      &
     dat_w_sat,               dat_awc_lm2,     &
     dat_k_sat_ref,            &
     dat_psi_sat_ref,               dat_chb,          &
     dat_heat_capacity_ref,         dat_thermal_cond_ref,   &
     dat_refl_dry_dir,            dat_refl_sat_dir,              &
     dat_refl_dry_dif,            dat_refl_sat_dif,              &
     dat_emis_dry,              dat_emis_sat,                &
     dat_z0_momentum,           dat_tf_depr, &
     f_iso_ice, f_vol_ice, f_geo_ice, f_iso_liq, f_vol_liq, f_geo_liq 


!---- end of namelist --------------------------------------------------------

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ============================================================================
subroutine read_lake_data_namelist(lake_n_lev)
  integer, intent(out) :: lake_n_lev
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: i
  real    :: z

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=lake_data_nml, iostat=io)
     ierr = check_nml_error(io, 'lake_data_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=lake_data_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'lake_data_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  unit=stdlog()
  write(unit, nml=lake_data_nml)

  ! initialize global module data here

  refl_ice_dif = g_iso*f_iso_ice + g_vol*f_vol_ice + g_geo*f_geo_ice
  refl_liq_dif = g_iso*f_iso_liq + g_vol*f_vol_liq + g_geo*f_geo_liq

  ! register selectors for tile-specific diagnostics
  do i=1, n_dim_lake_types
     call register_tile_selector(tile_names(i), long_name='',&
          tag = SEL_LAKE, idata1 = i )
  enddo

  ! set up output arguments
  lake_n_lev = num_l
end subroutine 


! ============================================================================
function lake_tile_ctor(tag) result(ptr)
  type(lake_tile_type), pointer :: ptr ! return value
  integer, intent(in)           :: tag ! kind of lake

  allocate(ptr)
  ptr%tag = tag
  ! allocate storage for tile data
  allocate(ptr%prog   (num_l),  &
           ptr%w_fc   (num_l),  &
           ptr%w_wilt (num_l),  &
           ptr%heat_capacity_dry(num_l),  &
           ptr%e      (num_l),  &
           ptr%f      (num_l)   )
  call init_lake_data_0d(ptr)

end function lake_tile_ctor


! ============================================================================
function lake_tile_copy_ctor(lake) result(ptr)
  type(lake_tile_type), pointer    :: ptr  ! return value
  type(lake_tile_type), intent(in) :: lake ! tile to copy
  
  allocate(ptr)
  ptr=lake ! copy all non-pointer data
  ! allocate storage for tile data
  allocate(ptr%prog   (num_l),  &
           ptr%w_fc   (num_l),  &
           ptr%w_wilt (num_l),  &
           ptr%heat_capacity_dry(num_l),  &
           ptr%e      (num_l),  &
           ptr%f      (num_l)   )
  ! copy all allocatable data
  ptr%prog(:)   = lake%prog(:)
  ptr%w_fc(:)   = lake%w_fc(:)
  ptr%w_wilt(:) = lake%w_wilt(:)
  ptr%e(:)      = lake%e(:)
  ptr%f(:)      = lake%f(:)
  ptr%heat_capacity_dry(:) = lake%heat_capacity_dry(:)
end function lake_tile_copy_ctor


! ============================================================================
subroutine delete_lake_tile(ptr)
  type(lake_tile_type), pointer :: ptr

  deallocate(ptr%prog, ptr%w_fc, ptr%w_wilt,ptr%heat_capacity_dry, ptr%e, ptr%f)

  deallocate(ptr)
end subroutine delete_lake_tile


subroutine init_lake_data_0d(lake)
  type(lake_tile_type), intent(inout) :: lake

!  real tau_groundwater
!  real rsa_exp         ! riparian source-area exponent

  integer :: k
  k = lake%tag

  lake%pars%w_sat             = dat_w_sat            (k)
  lake%pars%awc_lm2           = dat_awc_lm2          (k)
  lake%pars%k_sat_ref         = dat_k_sat_ref        (k)
  lake%pars%psi_sat_ref       = dat_psi_sat_ref      (k)
  lake%pars%chb               = dat_chb              (k)
  lake%pars%alpha             = 1
  lake%pars%heat_capacity_ref = dat_heat_capacity_ref(k)
  lake%pars%thermal_cond_ref  = dat_thermal_cond_ref (k)
  lake%pars%refl_dry_dir      = dat_refl_dry_dir     (k,:)
  lake%pars%refl_dry_dif      = dat_refl_dry_dif     (k,:)
  lake%pars%refl_sat_dir      = dat_refl_sat_dir     (k,:)
  lake%pars%refl_sat_dif      = dat_refl_sat_dif     (k,:)
  lake%pars%emis_dry          = dat_emis_dry         (k)
  lake%pars%emis_sat          = dat_emis_sat         (k)
  lake%pars%z0_momentum       = dat_z0_momentum      (k)

  lake%pars%tau_groundwater   = 86400.*30.
  lake%pars%rsa_exp           = rsa_exp_global

  ! -------- derived constant lake parameters --------
  ! w_fc (field capacity) set to w at which hydraulic conductivity equals
  ! a nominal drainage rate "rate_fc"
  ! w_wilt set to w at which psi is psi_wilt
  if (use_lm2_awc) then
     lake%w_wilt(:) = 0.15
     lake%w_fc  (:) = 0.15 + lake%pars%awc_lm2
  else
     lake%w_wilt(:) = lake%pars%w_sat &
          *(lake%pars%psi_sat_ref/(psi_wilt*lake%pars%alpha))**(1/lake%pars%chb)
     lake%w_fc  (:) = lake%pars%w_sat &
          *(rate_fc/(lake%pars%k_sat_ref*lake%pars%alpha**2))**(1/(3+2*lake%pars%chb))
  endif

  ! below made use of phi_e from parlange via entekhabi
  lake%Eg_part_ref = (-4*lake%w_fc(1)**2*lake%pars%k_sat_ref*lake%pars%psi_sat_ref*lake%pars%chb &
       /(pi*lake%pars%w_sat)) * (lake%w_fc(1)/lake%pars%w_sat)**(2+lake%pars%chb)   &
       *(2*pi/(3*lake%pars%chb**2*(1+3/lake%pars%chb)*(1+4/lake%pars%chb)))/2

  lake%z0_scalar = lake%pars%z0_momentum * exp(-k_over_B)

end subroutine 


! ============================================================================
function lake_cover_cold_start(land_mask, lonb, latb, domain) result (lake_frac)
! creates and initializes a field of fractional lake coverage
  logical, intent(in) :: land_mask(:,:)    ! land mask
  real,    intent(in) :: lonb(:,:), latb(:,:)! boundaries of the grid cells
  real,    pointer    :: lake_frac (:,:,:) ! output: map of lake fractional coverage
  type(domain2d), intent(in) :: domain

  allocate( lake_frac(size(land_mask,1),size(land_mask,2),n_dim_lake_types))

  if (trim(lake_to_use)=='from-rivers') then
     lake_frac = 0.0
     call read_data('INPUT/river_data.nc', 'lake_frac', lake_frac(:,:,1), &
          domain=domain)
     ! make sure 'missing values' don't get into the result
     where (lake_frac < 0) lake_frac = 0
     where (lake_frac > 1) lake_frac = 1
  else
     call init_cover_field(lake_to_use, 'INPUT/ground_type.nc', 'cover','frac', &
          lonb, latb, lake_index_constant, input_cover_types, lake_frac)
  endif
  
  if (round_frac_down) then
      where (lake_frac.gt.0. .and. lake_frac.lt.min_lake_frac) lake_frac = 0.
    else
      where (lake_frac.gt.0. .and. lake_frac.lt.min_lake_frac) lake_frac = min_lake_frac
    endif
  
end function 

! =============================================================================
function lake_tiles_can_be_merged(lake1,lake2) result(response)
  logical :: response
  type(lake_tile_type), intent(in) :: lake1,lake2

  response = (lake1%tag==lake2%tag)
end function

! =============================================================================
! combine two lake tiles with specified weights; the results goes into the 
! second one
! THIS NEEDS TO BE REVISED FOR TILE-DEPENDENT DZ
subroutine merge_lake_tiles(t1,w1,t2,w2)
  type(lake_tile_type), intent(in)    :: t1
  type(lake_tile_type), intent(inout) :: t2
  real, intent(in) :: w1, w2 ! relative weights

  ! ---- local vars
  real    :: x1, x2 ! normalized relative weights
  real    :: HEAT1, HEAT2 ! temporaries for heat
  real    :: C1, C2 ! heat capacities
  real    :: gw
  integer :: i

WRITE (*,*) 'SORRY, BUT merge_lake_tiles NEEDS TO BE REVISED TO ALLOW FOR ', &
            'HORIZONTALLY VARYING VERTICAL DISCRETIZATION'

  ! calculate normalized weights
  x1 = w1/(w1+w2)
  x2 = 1.0 - x1

  ! combine state variables
  do i = 1,num_l
    ! calculate "dry" heat capacities:
    C1 = sfc_heat_factor*t1%pars%heat_capacity_ref
    C2 = sfc_heat_factor*t2%pars%heat_capacity_ref
    ! calculate heat content at this level for both source tiles
    HEAT1 = &
    (C1*dz(i)+clw*t1%prog(i)%wl+csw*t1%prog(i)%ws) * (t1%prog(i)%T-tfreeze)
    HEAT2 = &
    (C2*dz(i)+clw*t2%prog(i)%wl+csw*t2%prog(i)%ws) * (t2%prog(i)%T-tfreeze)
    ! calculate (and assign) combined water mass
    t2%prog(i)%wl = t1%prog(i)%wl*x1 + t2%prog(i)%wl*x2
    t2%prog(i)%ws = t1%prog(i)%ws*x1 + t2%prog(i)%ws*x2
    ! if dry heat capacity of combined lake is to be changed, update it here
    ! ...
    ! calculate combined temperature, based on total heat content and combined
    ! heat capacity
    t2%prog(i)%T = (HEAT1*x1+HEAT2*x2) / &
      (C2*dz(i)+clw*t2%prog(i)%wl+csw*t2%prog(i)%ws) + tfreeze

    ! calculate combined groundwater content
    gw = t1%prog(i)%groundwater*x1 + t2%prog(i)%groundwater*x2
    ! calculate combined groundwater temperature
    if(gw/=0) then
       t2%prog(i)%groundwater_T = ( &
            t1%prog(i)%groundwater*x1*(t1%prog(i)%groundwater_T-tfreeze) + &
            t2%prog(i)%groundwater*x2*(t2%prog(i)%groundwater_T-tfreeze)   &
            ) / gw + Tfreeze
    else
       t2%prog(i)%groundwater_T = &
            x1*t1%prog(i)%groundwater_T + x2*t2%prog(i)%groundwater_T
    endif
    t2%prog(i)%groundwater = gw
  enddo

end subroutine

! =============================================================================
! returns true if tile fits the specified selector
function lake_is_selected(lake, sel)
  logical lake_is_selected
  type(tile_selector_type),  intent(in) :: sel
  type(lake_tile_type),      intent(in) :: lake

  lake_is_selected = (sel%idata1 == lake%tag)
end function


! ============================================================================
! returns tag of the tile
function get_lake_tile_tag(lake) result(tag)
  integer :: tag
  type(lake_tile_type), intent(in) :: lake
  
  tag = lake%tag
end function


! ============================================================================
! compute bare-lake albedos and bare-lake emissivity
subroutine lake_data_radiation ( lake, cosz, use_brdf, &
                                  lake_alb_dir, lake_alb_dif, lake_emis )
  type(lake_tile_type), intent(in)  :: lake
  real,                 intent(in)  :: cosz
  logical,              intent(in)  :: use_brdf
  real,                 intent(out) :: lake_alb_dir(:), lake_alb_dif(:), lake_emis

  ! ---- local vars
  real :: lake_sfc_vlc, blend
  real :: liq_value_dir(NBANDS), ice_value_dir(NBANDS)
  real :: liq_value_dif(NBANDS), ice_value_dif(NBANDS)
  real :: zenith_angle, zsq, zcu

  ! ---- radiation properties
  lake_sfc_vlc = lake%prog(1)%wl/lake%prog(1)%dz
  blend        = lake_sfc_vlc/lake%pars%w_sat
  if (use_brdf) then
      zenith_angle = acos(cosz)
      zsq = zenith_angle*zenith_angle
      zcu = zenith_angle*zsq
      liq_value_dir =  f_iso_liq*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                     + f_vol_liq*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                     + f_geo_liq*(g0_geo+g1_geo*zsq+g2_geo*zcu)
      ice_value_dir =  f_iso_ice*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                     + f_vol_ice*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                     + f_geo_ice*(g0_geo+g1_geo*zsq+g2_geo*zcu)
      liq_value_dif = refl_liq_dif
      ice_value_dif = refl_ice_dif
    else
      liq_value_dir = lake%pars%refl_sat_dir
      ice_value_dir = lake%pars%refl_dry_dir
      liq_value_dif = lake%pars%refl_sat_dif
      ice_value_dif = lake%pars%refl_dry_dif
    endif
  lake_alb_dir = ice_value_dir + blend*(liq_value_dir-ice_value_dir)
  lake_alb_dif = ice_value_dif + blend*(liq_value_dif-ice_value_dif)
  lake_emis = lake%pars%emis_dry   + blend*(lake%pars%emis_sat-lake%pars%emis_dry  )
end subroutine

! ============================================================================
! compute bare-lake roughness
subroutine lake_data_diffusion ( lake,lake_z0s, lake_z0m )
  type(lake_tile_type), intent(in)  :: lake
  real,                 intent(out) :: lake_z0s, lake_z0m

  ! ---- surface roughness
  lake_z0s = lake%z0_scalar
  lake_z0m = lake%pars%z0_momentum
end subroutine

! ============================================================================
! compute lake thermodynamic properties.
subroutine lake_data_thermodynamics ( lake_pars, lake_depth, &
     lake_rh, heat_capacity_dry, thermal_cond)
  type(lake_pars_type), intent(in)  :: lake_pars
  real,                 intent(in)  :: lake_depth
  real,                 intent(out) :: lake_rh
  real,                 intent(out) :: heat_capacity_dry(:)
  real,                 intent(out) :: thermal_cond(:)

  ! ---- local vars
  integer l

! ----------------------------------------------------------------------------

  lake_rh = min(max_lake_rh, max(lake_depth/lake_pars%depth_sill,0.))

  do l = 1, num_l
     heat_capacity_dry(l) = lake_pars%heat_capacity_ref
     thermal_cond(l)  = lake_pars%thermal_cond_ref
  enddo

end subroutine

! ============================================================================
subroutine lake_tile_stock_pe (lake, twd_liq, twd_sol  )
  type(lake_tile_type),  intent(in)    :: lake
  real,                  intent(out)   :: twd_liq, twd_sol
  integer n
  
  twd_liq = 0.
  twd_sol = 0.
  do n=1, size(lake%prog)
    twd_liq = twd_liq + lake%prog(n)%wl + lake%prog(n)%groundwater
    twd_sol = twd_sol + lake%prog(n)%ws
    enddo

end subroutine lake_tile_stock_pe


! ============================================================================
! returns lake tile heat content, J/m2
function lake_tile_heat (lake) result(heat) ; real heat
  type(lake_tile_type),  intent(in)  :: lake

  integer :: i

  heat = 0
  do i = 1, num_l
     heat = heat + &
          (lake%heat_capacity_dry(i)*dz(i) + clw*lake%prog(i)%wl + csw*lake%prog(i)%ws)&
                           *(lake%prog(i)%T-tfreeze) + &
          clw*lake%prog(i)%groundwater*(lake%prog(i)%groundwater_T-tfreeze) - &
          hlf*lake%prog(i)%ws
  enddo
end function

end module lake_tile_mod


module river_mod
!-----------------------------------------------------------------------
!                   GNU General Public License                        
!                                                                      
! This program is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
! <CONTACT EMAIL="Kirsten.Findell@@noaa.gov"> Kirsten Findell </CONTACT> 
! <CONTACT EMAIL="Zhi.Liang@@noaa.gov"> Zhi Liang </CONTACT> 
! <NAMELIST NAME="river_nml">
! <DATA NAME="layout" TYPE="integer, dimension(2)">
!  Processor domain layout for river model. If layout(1)*layout(2) is not equal
!  to mpp_npes, the river model layout will be assigned the layout of land model 
!  passed through river_init. 
!  </DATA> 
! <DATA NAME="do_rivers" TYPE="logical">
!   set true to run river model ( default is true). If FALSE, rivers are 
!   essentially turned off to save computing time
!  </DATA> 
! <DATA NAME="dt_slow" TYPE="real">
!   slow time step for river model. dt_slow must be integer multiplier of dt_fast passed 
!   from land model ( land model time step).
!  </DATA> 
! <DATA NAME="diag_freq" TYPE="integer">
!   Number of slow time steps between sending out diagnositics data(default is 1). Please
!   note that diagnostic output frequency ( specified in diag_table ) must be divided by 
!   diag_freq*dt_slow.
!  </DATA> 
! </NAMELIST>

#ifdef INTERNAL_FILE_NML
  use mpp_mod, only: input_nml_file
#else
  use fms_mod, only: open_namelist_file
#endif

  use mpp_mod,             only : CLOCK_SUBCOMPONENT, CLOCK_ROUTINE
  use mpp_mod,             only : mpp_error, mpp_chksum, FATAL, WARNING, stdlog, mpp_npes
  use mpp_mod,             only : mpp_pe, stdout, mpp_chksum, mpp_max
  use mpp_mod,             only : mpp_clock_id, mpp_clock_begin, mpp_clock_end, MPP_CLOCK_DETAILED
  use mpp_domains_mod,     only : domain2d, mpp_get_compute_domain, mpp_get_global_domain 
  use mpp_domains_mod,     only : mpp_get_data_domain, mpp_update_domains, mpp_get_ntile_count
  use fms_mod,             only : write_version_number, check_nml_error
  use fms_mod,             only : close_file, file_exist, field_size, read_data, write_data, lowercase
  use fms_mod,             only : field_exist, CLOCK_FLAG_DEFAULT
  use fms_io_mod,          only : get_mosaic_tile_file
  use diag_manager_mod,    only : diag_axis_init, register_diag_field, register_static_field, send_data
  use time_manager_mod,    only : time_type, increment_time, get_time
  use river_type_mod,      only : river_type, Leo_Mad_trios
  use river_physics_mod,   only : river_physics_step, river_physics_init
  use constants_mod,       only : PI, RADIAN, tfreeze, DENS_H2O, hlf
  use stock_constants_mod, only : ISTOCK_WATER, ISTOCK_HEAT
  use land_tile_mod,       only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, get_elmt_indices, &
     operator(/=)
  use land_data_mod,       only : land_data_type, land_state_type, lnd
  use lake_tile_mod,       only : num_l

  implicit none
  private

!--- version information ---------------------------------------------
  character(len=128) :: version = '$Id: river.F90,v 17.0.2.9.2.1.2.1.2.1 2010/08/24 12:11:35 pjp Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!--- public interface ------------------------------------------------
  public :: river_init, river_end, river_type, update_river, river_stock_pe
  public :: save_river_restart

!--- namelist interface ----------------------------------------------
  logical            :: do_rivers       = .TRUE.  ! if FALSE, rivers are essentially turned off to save computing time
  real               :: dt_slow
  integer            :: diag_freq       = 1       ! Number of slow time steps between sending out diagnositics data.
  logical            :: debug_river     = .FALSE.
  logical            :: do_age          = .false.
  real               :: Somin           = 0.00005 ! There are 7 points with So = -9.999 but basinid > 0....
  real               :: outflowmean_min = 1.      ! temporary fix, should not allow zero in input file
  integer            :: num_c=0, num_species
  logical            :: land_area_called_cellarea = .false.
  logical            :: all_big_outlet_ctn0 = .false.
!Balaji
  public :: num_species !public for test_river_solo
  character(len=6),              dimension(10) :: rt_c_name
  character(len=128),            dimension(10) :: rt_source_conc_file, rt_source_flux_file
  character(len=128),            dimension(10) :: rt_source_conc_name, rt_source_flux_name
  real,                          dimension(10) :: rt_t_ref, rt_vf_ref, rt_q10, rt_kinv
  character(len=128),allocatable, dimension(:) :: source_conc_file, source_flux_file
  character(len=128),allocatable, dimension(:) :: source_conc_name, source_flux_name
  real, dimension(3) :: ave_DHG_exp = (/0.49,0.33,0.18/)  ! (/B, F, M for avg of many rivers, 15Nov05/)
  real, dimension(3) :: ave_AAS_exp = (/0.19,0.39,0.42/)  ! (/b, f, m for avg of many rivers, 15Nov05/)
  real, dimension(3) :: ave_DHG_coef = (/4.62,0.26,0.82/) ! (/A, C, K for avg of many rivers, 15Nov05/)
  real               :: sinuosity = 1.3
  real               :: channel_tau = 86400*365.25*10     ! channel geometry reflects average flow over O(10 y)
  logical :: lake_area_bug = .FALSE. ! if set to true, reverts to buggy (quebec)
      ! behavior, where by mistake cell area was used instead of land area to 
      ! compute the area of lakes. 
  namelist /river_nml/ dt_slow, diag_freq, debug_river, do_age,              &
                       Somin, outflowmean_min, num_c, rt_c_name, rt_t_ref,   &
                       rt_vf_ref, rt_q10, rt_kinv, rt_source_conc_file,      &
                       rt_source_flux_file, rt_source_conc_name,             &
                       rt_source_flux_name, ave_DHG_exp, ave_AAS_exp,        &
                       ave_DHG_coef, do_rivers, sinuosity, channel_tau,      &
                       land_area_called_cellarea, all_big_outlet_ctn0,       &
                       lake_area_bug

  character(len=128) :: river_src_file   = 'INPUT/river_data.nc'
  character(len=128) :: river_Omean_file = 'INPUT/river_Omean.nc'
!---------------------------------------------------------------------
  logical :: module_is_initialized = .FALSE.
  integer :: isc, iec, jsc, jec                         ! compute domain decomposition 
  integer :: isd, ied, jsd, jed                         ! data domain decomposition 
  integer :: nlon, nlat                                 ! size of computational river grid 
  integer :: num_lake_lev
  integer :: id_outflowmean
  integer :: id_dx, id_basin, id_So, id_depth, id_width, id_vel
  integer :: id_LWSr, id_FWSr, id_HSr, id_meltr
  integer :: i_species
  integer :: id_travel, id_elev, id_tocell
  ! ***
  ! the following id_* retained temporarily for compatibility with older diag tables
  integer :: id_storage_old, id_stordis_old, id_infloc_old, id_inflow_old, id_outflow_old
  integer :: id_lake_outflow_old, id_disw2o_old, id_outflowmean_old
  integer :: id_depth_old, id_width_old, id_vel_old
  integer :: id_r_t_rivr, id_i_t_rivr, id_o_t_rivr, id_lot_rivr, id_s_t_rivr, id_dot_rivr
  integer :: id_r_frazil, id_i_frazil, id_o_frazil, id_lofrazil, id_s_frazil, id_dofrazil
  ! ***
  integer :: maxtravel
  real    :: missing = -1.e8

  real,    parameter :: CONST_OMEAN = 80000
  integer, parameter :: num_phys = 2
  real,    parameter :: epsln = 1.e-6
  real,    parameter :: sec_in_day = 86400.

  real,  allocatable, dimension(:,:)   :: discharge2ocean_next   ! store discharge value
  real,  allocatable, dimension(:,:,:) :: discharge2ocean_next_c ! store discharge value
  integer,          allocatable, dimension(:) :: id_infloc,  id_storage, id_stordis, id_inflow
  integer,          allocatable, dimension(:) :: id_run_stor
  integer,          allocatable, dimension(:) :: id_outflow, id_removal, id_dis
  integer,          allocatable, dimension(:) :: id_lake_outflow
  character(len=4), allocatable, dimension(:) :: c_name
  character(len=8), allocatable, dimension(:) :: if_name, of_name, lo_name, do_name
  character(len=8), allocatable, dimension(:) :: st_name, sd_name, rf_name, rm_name, sr_name
  character(len=8), allocatable, dimension(:) :: c_desc
  character(len=24), allocatable, dimension(:) :: if_desc, of_desc, lo_desc, do_desc
  character(len=64), allocatable, dimension(:) :: st_desc, sd_desc, rf_desc, rm_desc, sr_desc
  character(len=7), allocatable, dimension(:) :: flux_units, store_units
  character(len=5), allocatable, dimension(:) :: conc_units
  integer                       :: num_fast_calls 
  integer                       :: slow_step = 0          ! record number of slow time step run.
  real                          :: D2R
  type(domain2d),          save :: domain
  type(river_type) ,       save :: River

!--- these variables are for communication purpose
  integer              :: pe
  integer, allocatable :: ncells(:)            ! number of points with each travel value

!--- clock id variable 
  integer :: slowclock, bndslowclock, physicsclock, diagclock, riverclock

contains


!#####################################################################
  subroutine river_init( land_lon, land_lat, time, dt_fast, land_domain, &
                         land_frac, id_lon, id_lat, river_land_mask )
    real,            intent(in) :: land_lon(:,:)     ! geographical lontitude of cell center
    real,            intent(in) :: land_lat(:,:)     ! geographical lattitude of cell center
    type(time_type), intent(in) :: time              ! current time
    type(time_type), intent(in) :: dt_fast           ! fast time step
    type(domain2d),  intent(in) :: land_domain       ! land domain
    real,            intent(in) :: land_frac(:,:)    ! land area fraction from land model
    integer,         intent(in) :: id_lon, id_lat    ! IDs of diagnostic axes
    logical,         intent(out):: river_land_mask(:,:) ! land mask seen by rivers

    integer              :: unit, outunit, io_status, ierr
    integer              :: sec, day, i, j
    integer              :: nxc, nyc
    character(len=128)   :: filename

    type(Leo_Mad_trios)   :: DHG_exp            ! downstream equation exponents
    type(Leo_Mad_trios)   :: DHG_coef           ! downstream equation coefficients
    type(Leo_Mad_trios)   :: AAS_exp            ! at-a-station equation exponents 

    D2R = PI/180.
    riverclock = mpp_clock_id('update_river'           , CLOCK_FLAG_DEFAULT, CLOCK_SUBCOMPONENT)
    slowclock = mpp_clock_id('update_river_slow'       , CLOCK_FLAG_DEFAULT, CLOCK_ROUTINE)
    bndslowclock = mpp_clock_id('update_river_bnd_slow', CLOCK_FLAG_DEFAULT, CLOCK_ROUTINE)
    physicsclock = mpp_clock_id('river phys'           , CLOCK_FLAG_DEFAULT, CLOCK_ROUTINE)
    diagclock    = mpp_clock_id('river diag'           , CLOCK_FLAG_DEFAULT, CLOCK_ROUTINE)
!--- read namelist -------------------------------------------------
#ifdef INTERNAL_FILE_NML
     read (input_nml_file, nml=river_nml, iostat=io_status)
     ierr = check_nml_error(io_status, 'river_nml')
#else
    if (file_exist('input.nml')) then
      unit = open_namelist_file()
      ierr = 1;
      do while (ierr /= 0)
         read  (unit, nml=river_nml, iostat=io_status, end=10)
         ierr = check_nml_error(io_status,'river_nml')
      enddo
10    continue
      call close_file (unit)
    endif
#endif

!--- write version and namelist info to logfile --------------------
    call write_version_number(version,tagname)
    unit=stdlog()
    write(unit, river_nml)  

    if(.not.do_rivers) return ! do nothing further if the rivers are turned off

!--- check name list variables 

    if(diag_freq .le. 0) call mpp_error(FATAL,'river_mod: diag_freq should be a positive integer')

    pe      = mpp_pe()

! set up time-related values
    River % time = time
    call get_time(dt_fast, sec, day)
    River%dt_fast = day*sec_in_day+sec

    River%dt_slow = dt_slow
    River%channel_tau = channel_tau

    num_fast_calls = River%dt_slow/River%dt_fast
    num_species = num_phys + num_c
    if (do_age) num_species = num_species + 1
    River%num_species = num_species
    River%num_c = num_c
    River%do_age = do_age
    River%num_phys = num_phys

    if(River%dt_slow .lt. River%dt_fast) call mpp_error(FATAL, &
         'river_mod: river slow time step dt_slow should be no less than land model fast time step dt_fast')

    if ( mod(River%dt_slow,River%dt_fast) .ne. 0  ) call mpp_error(FATAL, &
         'river_mod: river slow time step dt_slow should be multiple of land model fast time step dt_fast')

!--- get the domain decompsition, river and land will be on the same grid and have the same domain decomposition.
    domain = land_domain
    call mpp_get_global_domain (domain, xsize=River%nlon, ysize=River%nlat)
    call mpp_get_compute_domain(domain, isc, iec, jsc, jec)
    call mpp_get_data_domain   (domain, isd, ied, jsd, jed)

!---- make sure the halo size is 1
    if( ied-iec .NE. 1 .OR. isc-isd .NE. 1 .OR. jed-jec .NE. 1 .OR. jsc-jsd .NE. 1 ) &
      call mpp_error(FATAL, "river_mod: halo size in four direction should all be 1")

    nxc = iec - isc + 1; nyc = jec - jsc + 1
    !--- make sure land_lon, land_lat, land_frac is on the compute domain
    if(size(land_lon,1) .NE. nxc .OR. size(land_lon,2) .NE. nyc ) call mpp_error(FATAL, &
        "river_mod: land_lon should be on the compute domain")
    if(size(land_lat,1) .NE. nxc .OR. size(land_lat,2) .NE. nyc ) call mpp_error(FATAL, &
        "river_mod: land_lat should be on the compute domain")
    if(size(land_frac,1) .NE. nxc .OR. size(land_frac,2) .NE. nyc ) call mpp_error(FATAL, &
        "river_mod: land_frac should be on the compute domain")

    allocate(discharge2ocean_next  (isc:iec,jsc:jec            ))
    allocate(discharge2ocean_next_c(isc:iec,jsc:jec,num_species))
    allocate(id_infloc (0:num_species), id_storage(0:num_species))
    allocate(id_inflow (0:num_species), id_outflow(0:num_species))
    allocate(id_dis    (0:num_species), id_lake_outflow (0:num_species))
    allocate(id_removal(0:num_species), id_stordis(0:num_species), id_run_stor(0:num_species))
    allocate(c_name       (0:num_species))
    allocate(if_name      (0:num_species), of_name      (0:num_species))
    allocate(rf_name      (0:num_species), rm_name      (0:num_species))
    allocate(st_name      (0:num_species), sd_name      (0:num_species),  sr_name(0:num_species))
    allocate(lo_name      (0:num_species), do_name      (0:num_species))
    allocate(c_desc       (0:num_species))
    allocate(if_desc      (0:num_species), of_desc      (0:num_species))
    allocate(rf_desc      (0:num_species), rm_desc      (0:num_species))
    allocate(st_desc      (0:num_species), sd_desc      (0:num_species),  sr_desc(0:num_species))
    allocate(lo_desc      (0:num_species), do_desc      (0:num_species))
    allocate(store_units (0:num_species), flux_units  (0:num_species))
    allocate(conc_units  (num_species))
    allocate(source_conc_file(num_species-num_c+1:num_species))
    allocate(source_flux_file(num_species-num_c+1:num_species))
    allocate(source_conc_name(num_species-num_c+1:num_species))
    allocate(source_flux_name(num_species-num_c+1:num_species))

!--- read the data from the file river_src_file -- has all static river network data
    call get_river_data(land_lon, land_lat, land_frac)
    river_land_mask = River%mask

    River%t_ref  = rt_t_ref (1:num_c)
    River%vf_ref = rt_vf_ref(1:num_c)
    River%q10    = rt_q10   (1:num_c)
    River%kinv   = rt_kinv  (1:num_c)
    source_conc_file(num_species-num_c+1:num_species) = rt_source_conc_file(1:num_c)
    source_flux_file(num_species-num_c+1:num_species) = rt_source_flux_file(1:num_c)
    source_conc_name(num_species-num_c+1:num_species) = rt_source_conc_name(1:num_c)
    source_flux_name(num_species-num_c+1:num_species) = rt_source_flux_name(1:num_c)

    c_name(0)='_h2o'
    c_desc(0)='h2o mass'
    c_name(1)='_ice'
    c_desc(1)='ice mass'
    c_name(2)='_hEt'
    c_desc(2)='sen.heat'
    if (do_age) c_name(3)='_age'
    if (do_age) c_desc(3)='mass.age'
    do i_species = num_species-num_c+1, num_species
      c_name(i_species)=trim(rt_c_name(i_species-(num_species-num_c)))
      c_desc(i_species)=c_name(i_species)
      enddo

    conc_units(1)                               = 'kg/kg'
    conc_units(2)                               = '  K  '
    if (do_age) conc_units(3)                   = 'days '
    conc_units(num_species-num_c+1:num_species) = 'kg/kg'   ! check this one

    flux_units(0)                               = 'kg/m2/s'
    flux_units(1)                               = 'kg/m2/s'
    flux_units(2)                               = 'W/m2   '
    if (do_age) flux_units(3)                   = 'kg/m2  '
    flux_units(num_species-num_c+1:num_species) = 'kg/m2/s'

    store_units(0)                              = 'kg/m2  '
    store_units(1)                              = 'kg/m2  '
    store_units(2)                              = 'J/m2   '
    if (do_age) store_units(3)                  = 'kg-s/m2'
    store_units(num_species-num_c+1:num_species)= 'kg/m2  '

    do i_species = 0, num_species
      if_name(i_species)='rv_i'//trim(c_name(i_species))
      of_name(i_species)='rv_o'//trim(c_name(i_species))
      do_name(i_species)='rv_d'//trim(c_name(i_species))
      lo_name(i_species)='rv_l'//trim(c_name(i_species))
      rf_name(i_species)='rv_r'//trim(c_name(i_species))
      rm_name(i_species)='rv_m'//trim(c_name(i_species))
      st_name(i_species)='rv_s'//trim(c_name(i_species))
      sd_name(i_species)='rv_n'//trim(c_name(i_species))
      sr_name(i_species)='rv_u'//trim(c_name(i_species))
      enddo

    do i_species = 0, num_species
      if_desc(i_species)='river inflow, '   //trim(c_desc(i_species))
      of_desc(i_species)='river outflow, '  //trim(c_desc(i_species))
      do_desc(i_species)='ocean discharge,' //trim(c_desc(i_species))
      lo_desc(i_species)='lake outflow, '   //trim(c_desc(i_species))
      rf_desc(i_species)='local runoff, '   //trim(c_desc(i_species))
      rm_desc(i_species)='river removal, '  //trim(c_desc(i_species))
      st_desc(i_species)='river storage '   //trim(c_desc(i_species))
      sd_desc(i_species)='river discharge lag (numerical) storage, ' &
                        //trim(c_desc(i_species))
      sr_desc(i_species)='river runoff lag (numerical) storage, ' &
                        //trim(c_desc(i_species))
      enddo

!--- register diag field
    call river_diag_init (id_lon, id_lat)

!--- read restart file 
    call get_mosaic_tile_file('INPUT/river.res.nc', filename, .false., domain)

    outunit=stdout()
    if(file_exist(trim(filename),domain) ) then
        call read_data(filename,'storage',          River%storage,          domain)
        call read_data(filename,'storage_c',        River%storage_c,        domain)
        call read_data(filename,'discharge2ocean',  discharge2ocean_next,   domain)
        call read_data(filename,'discharge2ocean_c',discharge2ocean_next_c, domain)
        call read_data(filename,'Omean',            River%outflowmean,      domain)
        write(outunit,*) 'Read restart files INPUT/river.res.nc'
    else
        River%storage    = 0.0
        River%storage_c  = 0.0
        discharge2ocean_next   = 0.0
        discharge2ocean_next_c = 0.0
        if(file_exist(river_Omean_file)) then
           call read_data(river_Omean_file, 'Omean', River%outflowmean, domain)
        else
           River%outflowmean = CONST_OMEAN
        end if
        write(outunit,*) 'cold restart, set data to 0 '
    endif
    River%stordis_c = River%dt_slow * discharge2ocean_next_c/DENS_H2O
    River%stordis   = River%dt_slow *(discharge2ocean_next + &
                                      discharge2ocean_next_c(:,:,1))/DENS_H2O
    where(River%outflowmean .le. outflowmean_min) River%outflowmean=outflowmean_min

    maxtravel = maxval(River%travel)
    call mpp_max(maxtravel)

    call river_physics_init(River, domain, id_lon, id_lat)
    call get_Leo_Mad_params(DHG_exp, DHG_coef, AAS_exp)
    River%o_exp  = 1./ (AAS_exp%on_w + AAS_exp%on_d)
    do j = jsc, jec
       do i = isc, iec
          if ( River%reach_length(i,j) > 0.0) then
              River%o_coef(i,j) = River%outflowmean(i,j) / &
                   ((sinuosity*River%reach_length(i,j))*DHG_coef%on_w*DHG_coef%on_d &
                   *(River%outflowmean(i,j)**(DHG_exp%on_w+DHG_exp%on_d)))**River%o_exp
          endif
       enddo
    enddo
    River%d_exp  = AAS_exp%on_d
    River%d_coef = DHG_coef%on_d                        &
         *(River%outflowmean**(DHG_exp%on_d-AAS_exp%on_d))
    River%w_exp  = AAS_exp%on_w
    River%w_coef = DHG_coef%on_w                        &
         *(River%outflowmean**(DHG_exp%on_w-AAS_exp%on_w))

    num_lake_lev = num_l
    module_is_initialized = .TRUE.

  end subroutine river_init

!#####################################################################
  subroutine update_river ( runoff, runoff_c, discharge2ocean,  &
                                              discharge2ocean_c )
    real, dimension(:,:),   intent(in)  :: runoff
    real, dimension(:,:,:), intent(in)  :: runoff_c
    real, dimension(:,:),   intent(out) :: discharge2ocean
    real, dimension(:,:,:), intent(out) :: discharge2ocean_c

    integer, save :: n = 0  ! fast time step with each slow time step

    call mpp_clock_begin(riverclock)
    if (.not.do_rivers) then
        discharge2ocean = 0; discharge2ocean_c = 0
        call mpp_clock_end(riverclock)  !needed for early exit when do_rivers=.false.
        return
    endif

    discharge2ocean   = discharge2ocean_next
    discharge2ocean_c = discharge2ocean_next_c
! deplete the discharge storage pools
    River%stordis_c = River%stordis_c &
         - River%dt_fast * discharge2ocean_c/DENS_H2O
    River%stordis   = River%stordis   &
         - River%dt_fast *(discharge2ocean + &
                           discharge2ocean_c(:,:,1))/DENS_H2O

!  increment time
    River%Time = increment_time(River%Time, River%dt_fast, 0)
    n = n + 1
!--- accumulate runoff ---------------------
    River%run_stor   = River%run_stor   + runoff
    River%run_stor_c = River%run_stor_c + runoff_c

    if(n == num_fast_calls) then
        call mpp_clock_begin(slowclock)
        call update_river_slow(River%run_stor(:,:)/real(num_fast_calls), &
             River%run_stor_c(:,:,:)/real(num_fast_calls) )
        call mpp_clock_end(slowclock)       
        call mpp_clock_begin(bndslowclock)
        call update_river_bnd_slow
        call mpp_clock_end(bndslowclock)
        n = 0
        River%run_stor = 0
        River%run_stor_c = 0
    endif

    call mpp_clock_end(riverclock)

  end subroutine update_river

!#####################################################################
  subroutine update_river_slow(runoff, runoff_c)
    real, dimension(:,:),   intent(in)  :: runoff
    real, dimension(:,:,:), intent(in)  :: runoff_c

    real, dimension(isd:ied,jsd:jed) :: &
                             lake_sfc_A, lake_sfc_bot, lake_conn
    real, dimension(isd:ied,jsd:jed,num_lake_lev) :: &
                             lake_wl, lake_ws
    real, dimension(isc:iec,jsc:jec) :: &
                             lake_depth_sill, lake_width_sill, &
                             lake_whole_area, &
                             rivr_LMASS,       & ! mass of liquid water in rivers in cell
                             rivr_FMASS,       & ! mass of ice in rivers in cell
                             rivr_MELT,        & ! net mass melt in rivers in cell
                             rivr_HEAT           ! sensible heat content of rivers in cell
    real, dimension(isc:iec,jsc:jec,num_lake_lev) :: &
                             lake_T
    integer                             :: travelnow, lev
    type(Leo_Mad_trios)   :: DHG_exp
    type(Leo_Mad_trios)   :: DHG_coef
    type(Leo_Mad_trios)   :: AAS_exp
    integer i,j,k, i_next, j_next
    type(land_tile_enum_type)     :: te,ce ! last and current tile list elements
    type(land_tile_type), pointer :: tile  ! pointer to current tile
    logical :: used

    slow_step = slow_step + 1

    River%infloc   = River%land_area*runoff  /DENS_H2O
    River%infloc_c = 0
    do i_species = 1, River%num_phys
       River%infloc_c(:,:,i_species) = &
            River%land_area*runoff_c(:,:,i_species)/DENS_H2O
    enddo
    if (River%do_age) then
        i_species = 3
        River%infloc_c(:,:,i_species) = &
             River%land_area*runoff_c(:,:,i_species)/DENS_H2O
    endif
    do i_species = num_species-River%num_c+1, num_species  ! create mass flux inputs from c data
       where (River%land_area.gt.0.)  &
            River%infloc_c(:,:,i_species) = &
            River%infloc*River%source_conc(:,:,i_species)  &
            + River%source_flux(:,:,i_species)
    enddo
    River%inflow   = 0
    River%inflow_c = 0
    River%lake_outflow   = 0
    River%lake_outflow_c = 0
    River%disw2o = 0.
    River%disc2o = 0.
    River%melt   = 0.
    lake_sfc_A  = 0
    lake_sfc_bot= 0
    lake_T  = 0
    lake_wl = 0
    lake_ws = 0
    lake_depth_sill  = 0
    lake_width_sill  = 0
    lake_whole_area  = 0
    lake_conn   = 0
    ce = first_elmt(lnd%tile_map, is=isc, js=jsc)
    te = tail_elmt (lnd%tile_map)
    do while(ce /= te)
       call get_elmt_indices(ce,i,j,k)
       tile=>current_tile(ce)  ! get pointer to current tile
       ce=next_elmt(ce)        ! advance position to the next tile
       if (.not.associated(tile%lake)) cycle
       if (lake_area_bug) then
          lake_sfc_A (i,j) = tile%frac * lnd%cellarea(i,j)
       else
          lake_sfc_A (i,j) = tile%frac * lnd%area(i,j)
       endif
       do lev = 1, num_lake_lev
         lake_T (i,j,lev)   = tile%lake%prog(lev)%T
         lake_wl(i,j,lev)   = tile%lake%prog(lev)%wl
         lake_ws(i,j,lev)   = tile%lake%prog(lev)%ws
         enddo
       lake_sfc_bot(i,j) = (sum(tile%lake%prog(:)%wl+tile%lake%prog(:)%ws) &
                               -tile%lake%prog(1)%wl-tile%lake%prog(1)%ws ) &
                                    / DENS_H2O
       lake_depth_sill(i,j)  = tile%lake%pars%depth_sill
       lake_width_sill(i,j)  = tile%lake%pars%width_sill
       lake_whole_area(i,j)  = tile%lake%pars%whole_area
       lake_conn (i,j)       = tile%lake%pars%connected_to_next
       enddo

call mpp_update_domains (lake_sfc_A,  domain)
call mpp_update_domains (lake_sfc_bot,domain)
call mpp_update_domains (lake_wl, domain)
call mpp_update_domains (lake_ws, domain)
call mpp_update_domains (lake_conn,   domain)
   do i=isc,iec
     do j=jsc,jec
       i_next = River%i_tocell(i,j)
       j_next = River%j_tocell(i,j)
       if (lake_conn(i,j).gt.0.5 ) then
           if (lake_conn(i_next,j_next).gt.0.5 .or. all_big_outlet_ctn0) then
               lake_depth_sill(i,j) = lake_sfc_bot(i_next,j_next) &
                +(lake_wl(i_next,j_next,1)+lake_ws(i_next,j_next,1))/DENS_H2O
             endif
         endif
       enddo
     enddo

! leftovers from horizontal mixing option, now gone
!call mpp_update_domains (lake_T,  domain)
!call mpp_update_domains (lake_depth_sill, domain)
!call mpp_update_domains (lake_tau, domain)

    travelnow = maxtravel
    do travelnow = maxtravel, 0, -1
       call mpp_clock_begin(physicsclock)
!***************************************************************
       call river_physics_step (River, travelnow, &
         lake_sfc_A, lake_sfc_bot, lake_depth_sill, &
         lake_width_sill, lake_whole_area,         &
         lake_T, lake_wl, lake_ws )
!***************************************************************
       call mpp_clock_end(physicsclock)
    enddo
    ce = first_elmt(lnd%tile_map, is=isc, js=jsc)
    te = tail_elmt (lnd%tile_map)
    do while(ce /= te)
       call get_elmt_indices(ce,i,j,k)
       tile=>current_tile(ce)  ! get pointer to current tile
       ce=next_elmt(ce)        ! advance position to the next tile
       if (.not.associated(tile%lake)) cycle
       do lev = 1, num_lake_lev
         tile%lake%prog(lev)%T  = lake_T (i,j,lev)
         tile%lake%prog(lev)%wl = lake_wl(i,j,lev)
         tile%lake%prog(lev)%ws = lake_ws(i,j,lev)
         enddo
       enddo

    River%outflowmean = River%outflowmean + &
       (River%outflow-River%outflowmean)*River%dt_slow/River%channel_tau
    where(River%outflowmean .le. outflowmean_min) River%outflowmean=outflowmean_min
    call get_Leo_Mad_params(DHG_exp, DHG_coef, AAS_exp)
    do j = jsc, jec
       do i = isc, iec
          if ( River%reach_length(i,j) > 0.0) then
              River%o_coef(i,j) = River%outflowmean(i,j) / &
                   ((sinuosity*River%reach_length(i,j))*DHG_coef%on_w*DHG_coef%on_d &
                   *(River%outflowmean(i,j)**(DHG_exp%on_w+DHG_exp%on_d)))**River%o_exp
          endif
       enddo
    enddo
    River%d_coef = DHG_coef%on_d                        &
         *(River%outflowmean**(DHG_exp%on_d-AAS_exp%on_d))
    River%w_coef = DHG_coef%on_w                        &
         *(River%outflowmean**(DHG_exp%on_w-AAS_exp%on_w))

    River%stordis = River%dt_slow*River%disw2o
    do i_species = 1, num_species
      River%stordis_c(:,:,i_species) = River%dt_slow*River%disc2o(:,:,i_species)
      enddo

    rivr_FMASS = DENS_H2O * (River%storage_c(:,:,1) + River%stordis_c(:,:,1))
    rivr_LMASS = DENS_H2O * (River%storage + River%stordis) - rivr_FMASS
    rivr_MELT  = DENS_H2O *  River%melt / River%dt_slow
    rivr_HEAT  = DENS_H2O * (River%storage_c(:,:,2) + River%stordis_c(:,:,2)) &
                      - hlf*rivr_FMASS

    call mpp_clock_begin(diagclock)
  ! convert area-integrated river outputs to unit-area quantities,
  ! using land area for stores, cell area for fluxes to ocean
    if (id_LWSr > 0) then
       where (lnd%area > 0) &
            rivr_LMASS = rivr_LMASS / lnd%area
       used = send_data (id_LWSr, rivr_LMASS, River%time, mask=lnd%area>0) 
    endif
    if (id_FWSr > 0) then   
       where (lnd%area > 0) &
            rivr_FMASS = rivr_FMASS / lnd%area
       used = send_data (id_FWSr, rivr_FMASS, River%time, mask=lnd%area>0) 
    endif
    if (id_HSr > 0) then
       where (lnd%area > 0) &
            rivr_HEAT = rivr_HEAT / lnd%area
       used = send_data (id_HSr, rivr_HEAT, River%time, mask=lnd%area>0) 
    endif
    if (id_meltr > 0) then
       where (lnd%area > 0) &
            rivr_MELT = rivr_MELT / lnd%area
       used = send_data (id_meltr, rivr_MELT, River%time, mask=lnd%area>0) 
    end if
    if(mod(slow_step, diag_freq) == 0)  call river_diag()
    call mpp_clock_end(diagclock)

  end subroutine update_river_slow

!#####################################################################

  subroutine update_river_bnd_slow

! note that land_area is not the total area of the cell, but just the land area
! within the cell, so it cannot be used to normalize fluxes to all-ocean cells.
! we need a true cell area for normalization, so river will
! just return mass flux per unit time and let land_model divide by area
    discharge2ocean_next = DENS_H2O*(River%disw2o - River%disc2o(:,:,1))

    do i_species = 1, num_species
       discharge2ocean_next_c(:,:,i_species) = DENS_H2O*River%disc2o(:,:,i_species)
    enddo

  end subroutine update_river_bnd_slow

!#####################################################################

  subroutine river_end
    integer :: outunit ! unit number for stdout

    if(.not.do_rivers) return ! do nothing further if rivers are turned off

!--- write out checksum
    outunit=stdout()
    write(outunit,*)"Chksum for storage ==> ", mpp_chksum(River%storage(isc:iec,jsc:jec))
    write(outunit,*)"Chksum for storage_c ==> ", mpp_chksum(River%storage_c(isc:iec,jsc:jec,:))
    write(outunit,*)"Chksum for discharge2ocean_next ==> ", mpp_chksum(discharge2ocean_next(isc:iec,jsc:jec))
    write(outunit,*)"Chksum for discharge2ocean_next_c ==> ", mpp_chksum(discharge2ocean_next_c(isc:iec,jsc:jec,:))

!--- release memory
    deallocate(discharge2ocean_next, discharge2ocean_next_c,&
         River%run_stor, River%run_stor_c)

    deallocate( River%lon, River%lat)
    deallocate(River%land_area ,     River%basinid        )
    deallocate(River%landfrac )
    deallocate(River%tocell )
    deallocate(River%travel )
    deallocate(River%outflow  )
    deallocate(River%inflow  )
    deallocate(River%lake_outflow)
    deallocate(River%lake_outflow_c)
    deallocate(River%storage        )
    deallocate(River%stordis        )
    deallocate(River%melt           )
    deallocate(River%disw2o        )
    deallocate(River%disc2o        )
    deallocate(River%infloc   )
    deallocate(River%reach_length    )
    deallocate(River%mask        )
    deallocate(River%So        )
    deallocate(River%depth     )
    deallocate(River%width     )
    deallocate(River%vel       )
    deallocate(River%infloc_c ,     River%storage_c ,     River%stordis_c    )
    deallocate(River%inflow_c, River%outflow_c )
    deallocate(River%removal_c )
    deallocate(River%vf_ref,River%t_ref,River%q10,River%kinv)
    deallocate(River%d_coef,River%o_coef,River%w_coef)

    module_is_initialized = .FALSE.

  end subroutine river_end


!#####################################################################
  !--- write to restart file
  subroutine save_river_restart(timestamp)
    character(*), intent(in) :: timestamp

    character(len=128) :: filename

    if(.not.do_rivers) return ! do nothing further if rivers are turned off

    filename = 'RESTART/'//trim(timestamp)//'river.res.nc'

    call write_data(filename,'storage', River%storage(isc:iec,jsc:jec), domain)
    call write_data(filename,'storage_c', River%storage_c(isc:iec,jsc:jec,:), domain)

    !--- write out discharge data
    call write_data(filename,'discharge2ocean'  ,discharge2ocean_next  (isc:iec,jsc:jec),   domain)
    call write_data(filename,'discharge2ocean_c',discharge2ocean_next_c(isc:iec,jsc:jec,:), domain)
    call write_data(filename,'Omean',            River%outflowmean,                         domain)
  
  end subroutine save_river_restart


!#####################################################################
  subroutine get_river_data(land_lon, land_lat, land_frac)
    real,            intent(in) :: land_lon(isc:,jsc:)  ! geographical lontitude of cell center
    real,            intent(in) :: land_lat(isc:,jsc:)  ! geographical lattitude of cell center
    real,            intent(in) :: land_frac(isc:,jsc:) ! land area fraction of land grid.

    integer                           :: ni, nj, i, j, siz(4), ntiles
    real, dimension(:,:), allocatable :: xt, yt, frac, lake_frac, tmp
    integer                           :: start(4), nread(4)

    ntiles = mpp_get_ntile_count(domain)

    call field_size(river_src_file, 'basin', siz, domain=domain)
    ni = siz(1)
    nj = siz(2)
    if(ni .NE. River%nlon .OR. nj .NE. River%nlat) call mpp_error(FATAL, &
       "river_mod: size mismatch between river grid and land grid")

    allocate(xt(isc:iec, jsc:jec), yt(isc:iec, jsc:jec), frac(isc:iec, jsc:jec) )
    allocate(lake_frac(isc:iec, jsc:jec))

    call read_data(river_src_file, 'x', xt, domain)
    call read_data(river_src_file, 'y', yt, domain) 
    call read_data(river_src_file, 'land_frac', frac, domain) 
    call read_data(river_src_file, 'lake_frac', lake_frac, domain) 
    !--- the following will be changed when the river data sets is finalized. 
!!$    xt = xt*D2R;
!!$    yt = yt*D2R;   
    xt = land_lon
    yt = land_lat
!--- transform to radians, since land model grid use radians and compare with land grid.


!!$    do j = jsc, jec
!!$       do i = isc, iec
!!$          if(abs(xt(i,j) - land_lon(i,j)) > epsln) call mpp_error(FATAL, &
!!$             "river_mod: longitude mismatch between river grid and land grid")
!!$          if(abs(yt(i,j) - land_lat(i,j)) > epsln) call mpp_error(FATAL, &
!!$             "river_mod: latitude mismatch between river grid and land grid")
!!$          if(abs(frac(i,j) - land_frac(i,j)) > epsln) call mpp_error(FATAL, &
!!$             "river_mod: area fraction mismatch between river grid and land grid")
!!$       end do
!!$    end do

    allocate(River%lon_1d    (1:ni            ) )
    allocate(River%lat_1d    (1:nj            ) )
    allocate(River%lon       (isc:iec, jsc:jec) )
    allocate(River%lat       (isc:iec, jsc:jec) )
    allocate(River%land_area  (isc:iec, jsc:jec) )     
    allocate(River%basinid   (isc:iec, jsc:jec) )
    allocate(River%landfrac  (isc:iec, jsc:jec) )
    allocate(River%mask      (isc:iec, jsc:jec) )
    allocate(River%tocell    (isc:iec, jsc:jec) )
    allocate(River%i_tocell  (isc:iec, jsc:jec) )
    allocate(River%j_tocell  (isc:iec, jsc:jec) )
    allocate(River%travel    (isd:ied, jsd:jed) )
    allocate(River%inflow    (isc:iec, jsc:jec) )
    allocate(River%outflow   (isc:iec, jsc:jec) )
    allocate(River%lake_outflow(isc:iec, jsc:jec) )
    allocate(River%storage   (isc:iec, jsc:jec) )
    allocate(River%stordis   (isc:iec, jsc:jec) )
    allocate(River%run_stor   (isc:iec, jsc:jec) )
    allocate(River%melt      (isc:iec, jsc:jec) )
    allocate(River%disw2o    (isc:iec, jsc:jec) )
    allocate(River%infloc    (isc:iec, jsc:jec))
    allocate(River%reach_length(isc:iec, jsc:jec) )
    allocate(River%So        (isc:iec, jsc:jec) )
    allocate(River%depth     (isc:iec, jsc:jec) )
    allocate(River%width    (isc:iec, jsc:jec) )
    allocate(River%vel      (isc:iec, jsc:jec) )
    allocate(River%infloc_c  (isc:iec, jsc:jec, num_species) )
    allocate(River%storage_c (isc:iec, jsc:jec, num_species) )
    allocate(River%stordis_c (isc:iec, jsc:jec, num_species) )
    allocate(River%run_stor_c (isc:iec, jsc:jec, num_species) )
    allocate(River%outflow_c (isc:iec, jsc:jec, num_species) )
    allocate(River%lake_outflow_c (isc:iec, jsc:jec, num_species) )
    allocate(River%removal_c (isc:iec, jsc:jec, num_species) )
    allocate(River%inflow_c  (isc:iec, jsc:jec, num_species) )
    allocate(River%disc2o    (isc:iec, jsc:jec, num_species))
    allocate(River%d_coef    (isc:iec, jsc:jec) )
    allocate(River%o_coef    (isc:iec, jsc:jec) )
    allocate(River%w_coef    (isc:iec, jsc:jec) )
    allocate(River%outflowmean(isc:iec, jsc:jec) )
    allocate(River%t_ref(4:num_species),River%vf_ref(4:num_species))
    allocate(River%q10  (4:num_species),River%kinv  (4:num_species))
    allocate(River%source_conc(isc:iec, jsc:jec,num_species-num_c+1:num_species))
    allocate(River%source_flux(isc:iec, jsc:jec,num_species-num_c+1:num_species))

    if(ntiles == 1) then   ! lat-lon grid, use actual grid location
       start = 1; nread = 1
       nread(1) = ni
       allocate(tmp(ni,1))
       call read_data(river_src_file, 'x', tmp, start, nread, no_domain=.TRUE.)
       River%lon_1d = tmp(:,1)
       deallocate(tmp)
       start = 1; nread = 1
       nread(2) = nj      
       allocate(tmp(1,nj))            
       call read_data(river_src_file, 'y', tmp, start, nread, no_domain=.TRUE.)
       River%lat_1d = tmp(1,:)
       deallocate(tmp)
    else                   ! cubic grid, use index.
       River%lon_1d(:)      = (/ (i, i=1,River%nlon) /)
       River%lat_1d(:)      = (/ (i, i=1,River%nlat) /)
    end if

    River%lon(:,:)       = land_lon(:,:)
    River%lat(:,:)       = land_lat(:,:)
!!$    River%landfrac(:,:)  = land_frac(:,:)
    River%landfrac(:,:)  = frac(:,:)
    River%infloc    = 0.0
    River%infloc_c  = 0.0
    River%storage   = 0.0
    River%storage_c = 0.0
    River%stordis   = 0.0
    River%run_stor  = 0.0
    River%stordis_c = 0.0
    River%run_stor_c= 0.0
    River%removal_c = 0.0
    River%depth     = 0.
    River%width     = 0.
    River%vel       = 0.
    River%outflow   = 0.
    River%outflow_c = 0.
    River%inflow    = 0.
    River%inflow_c  = 0.
!--- read the data from the source file
    call read_data(river_src_file, 'tocell', River%tocell, domain) 

    where (River%tocell(:,:).eq.  4) River%tocell(:,:)=3
    where (River%tocell(:,:).eq.  8) River%tocell(:,:)=4
    where (River%tocell(:,:).eq. 16) River%tocell(:,:)=5
    where (River%tocell(:,:).eq. 32) River%tocell(:,:)=6
    where (River%tocell(:,:).eq. 64) River%tocell(:,:)=7
    where (River%tocell(:,:).eq.128) River%tocell(:,:)=8

    call read_data(river_src_file, 'basin', River%basinid, domain)
    where (River%basinid >0)
       River%mask = .true.
    elsewhere
       River%mask = .false.
    endwhere

    River%travel = 0
    call read_data(river_src_file, 'travel', River%travel(isc:iec,jsc:jec), domain)
    call mpp_update_domains(River%travel, domain) 
    call read_data(river_src_file, 'celllength', River%reach_length, domain) 
    River%reach_length = River%reach_length * River%landfrac * (1.-lake_frac)
    if (land_area_called_cellarea) then
        call read_data(river_src_file, 'cellarea', River%land_area, domain) 
      else
        call read_data(river_src_file, 'land_area', River%land_area, domain) 
      endif
!    call read_data(river_src_file, 'So', River%So, domain) 
    River%So = 0.0
    where (River%So .LT. 0.0) River%So = Somin

    do i_species = num_species-num_c+1, num_species
       if (trim(source_conc_file(i_species)).eq.'') then
           River%source_conc(:,:,i_species)=0
           if (trim(source_conc_name(i_species)).eq.'one') River%source_conc(:,:,i_species)=1
       else if (trim(source_conc_name(i_species)).ne.'') then
           call read_data(trim(source_conc_file(i_species)), trim(source_conc_name(i_species)), &
                River%source_conc(:,:,i_species), no_domain=.true.)
       else
           River%source_conc(:,:,i_species) = 0
       endif
       if (trim(source_flux_file(i_species)).eq.'') then
           River%source_flux(:,:,i_species)=0
           if (trim(source_flux_name(i_species)).eq.'one') River%source_flux(:,:,i_species)=1
       else if (trim(source_flux_name(i_species)).ne.'') then
           call read_data(trim(source_flux_file(i_species)), &
                trim(source_flux_name(i_species)), &
                River%source_flux(:,:,i_species), no_domain=.true.)
       else
           River%source_flux(:,:,i_species) = 0
       endif
    enddo

    River%source_conc = max(River%source_conc, 0.)
    River%source_flux = max(River%source_flux, 0.)
    
    deallocate(lake_frac)

  end subroutine get_river_data

!#####################################################################

  subroutine river_diag_init(id_lon, id_lat)
    integer, intent(in) :: id_lon  ! ID of land longitude (X) diag axis
    integer, intent(in) :: id_lat  ! ID of land latitude (Y) diag axis

    character(len=11)                :: mod_name = 'river'
    real, dimension(isc:iec,jsc:jec) :: tmp
    logical                          :: sent
    integer                          :: i

! regular diagnostic fields
    do i_species = 0, num_species
      id_inflow(i_species) = register_diag_field ( mod_name, if_name(i_species),       &
           (/id_lon, id_lat/), River%Time, if_desc(i_species), flux_units(i_species),    &
           missing_value=missing )
      id_outflow(i_species) = register_diag_field ( mod_name, of_name(i_species),      &
           (/id_lon, id_lat/), River%Time, of_desc(i_species), flux_units(i_species),    &
           missing_value=missing )
      id_dis(i_species)     = register_diag_field ( mod_name, do_name(i_species),       &
           (/id_lon, id_lat/), River%Time, do_desc(i_species), flux_units(i_species), &
           missing_value=missing )
      id_lake_outflow(i_species) = register_diag_field ( mod_name, lo_name(i_species),     &
           (/id_lon, id_lat/), River%Time, lo_desc(i_species), flux_units(i_species),    &
           missing_value=missing )
      id_infloc(i_species) = register_diag_field ( mod_name, rf_name(i_species),     &
           (/id_lon, id_lat/), River%Time, rf_desc(i_species), flux_units(i_species),    &
           missing_value=missing )
      id_removal(i_species) = register_diag_field ( mod_name, rm_name(i_species),     &
           (/id_lon, id_lat/), River%Time, rm_desc(i_species), flux_units(i_species),    &
           missing_value=missing )
      id_storage(i_species) = register_diag_field ( mod_name, st_name(i_species),     &
           (/id_lon, id_lat/), River%Time, st_desc(i_species), store_units(i_species),    &
           missing_value=missing )
      id_stordis(i_species) = register_diag_field ( mod_name, sd_name(i_species),     &
           (/id_lon, id_lat/), River%Time, sd_desc(i_species), store_units(i_species),    &
           missing_value=missing )
      id_run_stor(i_species) = register_diag_field ( mod_name, sr_name(i_species),     &
           (/id_lon, id_lat/), River%Time, sr_desc(i_species), store_units(i_species),    &
           missing_value=missing )
      enddo

    id_outflowmean   = register_diag_field ( mod_name, 'rv_Qavg', (/id_lon, id_lat/), &
         River%Time, 'long-time average vol. flow', 'm3/s', missing_value=missing )
    id_depth     = register_diag_field ( mod_name, 'rv_depth', (/id_lon, id_lat/), &
         River%Time, 'river flow depth', 'm', missing_value=missing )
    id_width     = register_diag_field ( mod_name, 'rv_width', (/id_lon, id_lat/), &
         River%Time, 'river flow width', 'm', missing_value=missing )
    id_vel       = register_diag_field ( mod_name, 'rv_veloc', (/id_lon, id_lat/), &
         River%Time, 'river flow velocity', 'm/s', missing_value=missing )

  id_storage_old=register_diag_field(mod_name,'storage',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_s_h2o instead', store_units(0),missing_value=missing )
  id_stordis_old=register_diag_field(mod_name,'stordis',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_s_h2o instead', store_units(0),missing_value=missing )
  id_s_frazil=register_diag_field(mod_name,'s_frazil',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_s_ice instead', store_units(1),missing_value=missing )
  id_s_t_rivr=register_diag_field(mod_name,'s_t_rivr',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_s_hEt instead', store_units(2),missing_value=missing )
  id_infloc_old=register_diag_field(mod_name,'infloc',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_r_h2o instead', flux_units(0),missing_value=missing )
  id_r_frazil=register_diag_field(mod_name,'r_frazil',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_r_ice instead', flux_units(1),missing_value=missing )
  id_r_t_rivr=register_diag_field(mod_name,'r_t_rivr',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_r_hEt instead', flux_units(2),missing_value=missing )
  id_inflow_old=register_diag_field(mod_name,'inflow',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_r_h2o instead', flux_units(0),missing_value=missing )
  id_i_frazil=register_diag_field(mod_name,'i_frazil',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_r_ice instead', flux_units(1),missing_value=missing )
  id_i_t_rivr=register_diag_field(mod_name,'i_t_rivr',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_r_hEt instead', flux_units(2),missing_value=missing )
  id_outflow_old=register_diag_field(mod_name,'outflow',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_o_h2o instead', flux_units(0),missing_value=missing )
  id_o_frazil=register_diag_field(mod_name,'o_frazil',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_o_ice instead', flux_units(1),missing_value=missing )
  id_o_t_rivr=register_diag_field(mod_name,'o_t_rivr',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_o_hEt instead', flux_units(2),missing_value=missing )
  id_lake_outflow_old=register_diag_field(mod_name,'lake_outflow',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_l_h2o instead', flux_units(0),missing_value=missing )
  id_lofrazil=register_diag_field(mod_name,'lofrazil',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_l_ice instead', flux_units(1),missing_value=missing )
  id_lot_rivr=register_diag_field(mod_name,'lot_rivr',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_l_hEt instead', flux_units(2),missing_value=missing )
  id_disw2o_old=register_diag_field(mod_name,'disw2o',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_d_h2o instead', flux_units(0),missing_value=missing )
  id_dofrazil=register_diag_field(mod_name,'dofrazil',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_d_ice instead', flux_units(1),missing_value=missing )
  id_dot_rivr=register_diag_field(mod_name,'dot_rivr',(/id_lon, id_lat/), River%Time, &
      'obsolete, pls use rv_d_hEt instead', flux_units(2),missing_value=missing )

  id_outflowmean_old   = register_diag_field ( mod_name, 'flowmean', (/id_lon, id_lat/), &
       River%Time, 'obsolete, pls use rv_Qavg', 'm3/s', missing_value=missing )
  id_depth_old     = register_diag_field ( mod_name, 'depth', (/id_lon, id_lat/), &
       River%Time, 'obsolete, pls use rv_depth', 'm', missing_value=missing )
  id_width_old     = register_diag_field ( mod_name, 'width', (/id_lon, id_lat/), &
       River%Time, 'obsolete, pls use rv_width', 'm', missing_value=missing )
  id_vel_old       = register_diag_field ( mod_name, 'vel', (/id_lon, id_lat/), &
       River%Time, 'obsolete, pls use rv_veloc', 'm/s', missing_value=missing )

  ! fields that historically were in the the land_model.F90. They are registered
  ! for module 'land' to preserve compatibility with older diag tables
  id_LWSr   = register_diag_field ( 'land', 'LWSr', (/id_lon, id_lat/), &
       River%Time, 'river liquid mass storage', 'kg/m2', missing_value=-1.0e+20 )
  id_FWSr   = register_diag_field ( 'land', 'FWSr', (/id_lon, id_lat/), &
       River%Time, 'river ice mass storage', 'kg/m2', missing_value=-1.0e+20 )
  id_HSr   = register_diag_field ( 'land', 'HSr', (/id_lon, id_lat/), &
       River%Time, 'river heat storage', 'J/m2', missing_value=-1.0e+20 )
  id_meltr   = register_diag_field ( 'land', 'meltr', (/id_lon, id_lat/), &
       River%Time, 'melt in river system', 'kg/m2/s', missing_value=-1.0e+20 )

! static fields
    id_dx = register_static_field ( mod_name, 'rv_length', (/id_lon, id_lat/), &
         'river reach length', 'm', missing_value=missing )
    id_basin = register_static_field ( mod_name, 'rv_basin', (/id_lon, id_lat/), &
         'river basin id', 'none', missing_value=missing )
    id_So = register_static_field ( mod_name, 'So', (/id_lon, id_lat/), &
         'Slope', 'none', missing_value=missing )
    id_travel = register_static_field ( mod_name, 'rv_trav', (/id_lon, id_lat/), &
         'cells left to travel before reaching ocean', 'none', missing_value=missing )
    id_tocell = register_static_field ( mod_name, 'rv_dir', (/id_lon, id_lat/), &
         'outflow direction code', 'none', missing_value=missing )

    if (id_dx>0) sent=send_data(id_dx, River%reach_length, River%Time, mask=River%mask )
    if (id_basin>0) then
        tmp = River%basinid(isc:iec,jsc:jec)
        sent=send_data(id_basin, tmp, River%Time, mask=River%mask )
      end if
    if (id_So>0) sent=send_data(id_So, River%So, River%Time, mask=River%mask )
    if (id_travel>0) then
        tmp = River%travel(isc:iec,jsc:jec)
        sent=send_data(id_travel, tmp, River%Time, mask=River%mask )
      end if
    if (id_tocell>0) then
        tmp = River%tocell(isc:iec,jsc:jec)
        sent=send_data(id_tocell, tmp, River%Time, mask=River%mask )
      end if

  end subroutine river_diag_init

!#####################################################################

  subroutine river_diag
    logical :: used   ! logical for send_data
    real diag_factor  (isc:iec,jsc:jec)
    real diag_factor_2(isc:iec,jsc:jec)

    diag_factor = 0.
    diag_factor_2 = 0.
    where (River%land_area(isc:iec,jsc:jec).gt.0.) &
                     diag_factor=DENS_H2O/River%land_area(isc:iec,jsc:jec)
    where (River%land_area(isc:iec,jsc:jec).gt.0.) &
                     diag_factor_2=1./(River%land_area(isc:iec,jsc:jec)*River%dt_slow)

    if (id_inflow(0) > 0) used = send_data (id_inflow(0), &
            diag_factor*River%inflow(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_outflow(0) > 0) used = send_data (id_outflow(0), &
            diag_factor*River%outflow(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_storage(0) > 0) used = send_data (id_storage(0), &
            diag_factor*River%storage(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_stordis(0) > 0) used = send_data (id_stordis(0), &
            diag_factor*River%stordis(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_run_stor(0) > 0) used = send_data (id_run_stor(0), &
            River%dt_fast*River%run_stor(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_infloc(0) > 0) used = send_data (id_infloc(0), &
            diag_factor*River%infloc(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_dis(0) > 0)    used = send_data (id_dis(0), &
            diag_factor*River%disw2o(isc:iec,jsc:jec), River%Time)
    if (id_lake_outflow(0) > 0) used = send_data (id_lake_outflow(0), &
            diag_factor_2*River%lake_outflow(isc:iec,jsc:jec), River%Time, mask=River%mask )

    if (id_storage_old > 0) used = send_data (id_storage_old, &
            diag_factor*River%storage(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_stordis_old > 0) used = send_data (id_stordis_old, &
            diag_factor*River%stordis(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_infloc_old > 0) used = send_data (id_infloc_old, &
            diag_factor*River%infloc(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_inflow_old > 0) used = send_data (id_inflow_old, &
            diag_factor*River%inflow(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_outflow_old > 0) used = send_data (id_outflow_old, &
            diag_factor*River%outflow(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_lake_outflow_old > 0) used = send_data (id_lake_outflow_old, &
            diag_factor_2*River%lake_outflow(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_disw2o_old > 0)    used = send_data (id_disw2o_old, &
            diag_factor*River%disw2o(isc:iec,jsc:jec), River%Time)
    if (id_s_frazil > 0) used = send_data (id_s_frazil, &
            diag_factor*River%storage_c(isc:iec,jsc:jec,1), River%Time, mask=River%mask )
    if (id_r_frazil > 0) used = send_data (id_r_frazil, &
            diag_factor*River%infloc_c(isc:iec,jsc:jec,1), River%Time, mask=River%mask )
    if (id_i_frazil > 0) used = send_data (id_i_frazil, &
            diag_factor*River%inflow_c(isc:iec,jsc:jec,1), River%Time, mask=River%mask )
    if (id_o_frazil > 0) used = send_data (id_o_frazil, &
            diag_factor*River%outflow_c(isc:iec,jsc:jec,1), River%Time, mask=River%mask )
    if (id_lofrazil > 0) used = send_data (id_lofrazil, &
            diag_factor_2*River%lake_outflow_c(isc:iec,jsc:jec,1), River%Time, mask=River%mask )
    if (id_dofrazil > 0)    used = send_data (id_dofrazil, &
            diag_factor*River%disc2o(isc:iec,jsc:jec,1), River%Time)
    if (id_s_t_rivr > 0) used = send_data (id_s_t_rivr, &
            diag_factor*River%storage_c(isc:iec,jsc:jec,2), River%Time, mask=River%mask )
    if (id_r_t_rivr > 0) used = send_data (id_r_t_rivr, &
            diag_factor*River%infloc_c(isc:iec,jsc:jec,2), River%Time, mask=River%mask )
    if (id_i_t_rivr > 0) used = send_data (id_i_t_rivr, &
            diag_factor*River%inflow_c(isc:iec,jsc:jec,2), River%Time, mask=River%mask )
    if (id_o_t_rivr > 0) used = send_data (id_o_t_rivr, &
            diag_factor*River%outflow_c(isc:iec,jsc:jec,2), River%Time, mask=River%mask )
    if (id_lot_rivr > 0) used = send_data (id_lot_rivr, &
            diag_factor_2*River%lake_outflow_c(isc:iec,jsc:jec,2), River%Time, mask=River%mask )
    if (id_dot_rivr > 0)    used = send_data (id_dot_rivr, &
            diag_factor*River%disc2o(isc:iec,jsc:jec,2), River%Time)

    do i_species = 1, num_species
      if (id_outflow(i_species) > 0) used = send_data (id_outflow(i_species), &
        diag_factor*River%outflow_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_lake_outflow(i_species) > 0) used = send_data (id_lake_outflow(i_species), &
        diag_factor_2*River%lake_outflow_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_inflow(i_species) > 0) used = send_data (id_inflow(i_species), &
        diag_factor*River%inflow_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_storage(i_species) > 0) used = send_data (id_storage(i_species), &
        diag_factor*River%storage_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_stordis(i_species) > 0) used = send_data (id_stordis(i_species), &
        diag_factor*River%stordis_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_run_stor(i_species) > 0) used = send_data (id_run_stor(i_species), &
        River%dt_fast*River%run_stor_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_infloc(i_species) > 0) used = send_data (id_infloc(i_species), &
        diag_factor*River%infloc_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_removal(i_species) > 0) used = send_data (id_removal(i_species), &
        diag_factor*River%removal_c(isc:iec,jsc:jec,i_species), River%Time, mask=River%mask )
      if (id_dis(i_species) > 0)    used = send_data (id_dis(i_species), &
        diag_factor*River%disc2o(isc:iec,jsc:jec,i_species), River%Time)
      enddo

    if (id_outflowmean > 0) used = send_data (id_outflowmean, &
            River%outflowmean(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_width > 0) used = send_data (id_width, &
            River%width(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_depth > 0) used = send_data (id_depth, &
            River%depth(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_vel > 0) used = send_data (id_vel, &
            River%vel(isc:iec,jsc:jec), River%Time, mask=River%mask )

    if (id_outflowmean_old > 0) used = send_data (id_outflowmean_old, &
            River%outflowmean(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_width_old > 0) used = send_data (id_width_old, &
            River%width(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_depth_old > 0) used = send_data (id_depth_old, &
            River%depth(isc:iec,jsc:jec), River%Time, mask=River%mask )
    if (id_vel_old > 0) used = send_data (id_vel_old, &
            River%vel(isc:iec,jsc:jec), River%Time, mask=River%mask )

  end subroutine river_diag

!#####################################################################

  subroutine get_Leo_Mad_params(DHG_exp, DHG_coef, AAS_exp)

    type(Leo_Mad_trios), intent(inout) :: DHG_exp  ! Exponents for downstream equations
    type(Leo_Mad_trios), intent(inout) :: DHG_coef ! Coefficients for downstream equations
    type(Leo_Mad_trios), intent(inout) :: AAS_exp  ! Exponents for at-a-station equations

!!! Exponents for the downstream hydraulic geometry equations
    DHG_exp%on_w = ave_DHG_exp(1) 
    DHG_exp%on_d = ave_DHG_exp(2)
    DHG_exp%on_V = ave_DHG_exp(3)

!!! Coefficients for the downstream hydraulic geometry equations
    DHG_coef%on_w = ave_DHG_coef(1)
    DHG_coef%on_d = ave_DHG_coef(2)
    DHG_coef%on_V = ave_DHG_coef(3)

!!! Exponents for the at-a-station hydraulic geometry equations
    AAS_exp%on_w = ave_AAS_exp(1)
    AAS_exp%on_d = ave_AAS_exp(2)
    AAS_exp%on_V = ave_AAS_exp(3)

  end subroutine get_Leo_Mad_params

!#####################################################################

subroutine river_stock_pe(index, value)
integer, intent(in)  :: index
real   , intent(out) :: value ! Domain water (Kg) or heat (Joules)

value = 0.0
if (.not.do_rivers) return

select case(index)
case(ISTOCK_WATER)
  value = DENS_H2O*(sum(River%storage)+sum(River%stordis)) &
        + sum(River%run_stor*River%land_area)*River%dt_fast
case(ISTOCK_HEAT)
! heat stock not yet implemented
  value = 0
case default
! Lnd_stock_pe issues a FATAL error message if index is invalid
end select

end subroutine river_stock_pe

!#####################################################################

end module river_mod


#ifdef test_river_solo

program river_solo
  use mpp_mod,                  only : mpp_error, mpp_pe, mpp_root_pe, mpp_npes, FATAL
  use mpp_mod,                  only : mpp_clock_id, mpp_clock_begin, mpp_clock_end
  use mpp_domains_mod,          only : mpp_define_layout, mpp_define_domains
  use mpp_domains_mod,          only : mpp_get_compute_domain, domain2d, CYCLIC_GLOBAL_DOMAIN
  use mpp_domains_mod,          only : mpp_get_current_ntile, mpp_get_tile_id
  use mpp_io_mod,               only : mpp_open, MPP_RDONLY, MPP_NETCDF, MPP_SINGLE
  use mpp_io_mod,               only : MPP_ASCII, MPP_OVERWR, mpp_close
  use fms_mod,                  only : fms_init, fms_end, stdlog, open_namelist_file
  use fms_mod,                  only : check_nml_error, close_file, file_exist, stdout, read_data
  use fms_io_mod,               only : fms_io_exit
  use time_manager_mod,         only : time_type, increment_time, set_date, increment_date, set_time
  use time_manager_mod,         only : set_calendar_type, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR
  use time_manager_mod,         only : operator(/), operator(-), operator( + ), month_name, get_date
  use diag_manager_mod,         only : diag_manager_init, diag_manager_end
  use river_mod,                only : river_init, river_end, update_river
  use constants_mod,            only : constants_init, PI, radius
  use grid_mod,                 only : get_grid_size, get_grid_cell_vertices
  use grid_mod,                 only : get_grid_cell_centers, get_grid_cell_area, get_grid_comp_area
  use grid_mod,                 only : define_cube_mosaic, get_grid_ntiles
  use river_mod,                only : num_species


  implicit none

  real, parameter       :: CONST_RUNOFF = 200.0

!--- namelist -----------------------------------------

  integer, dimension(6) :: current_date = (/ 0, 0, 0, 0, 0, 0 /)
  character(len=16)     :: calendar = 'julian'
  integer               :: years=0, months=0, days=0, hours=0, minutes=0, seconds=0
  integer               :: dt_fast     = 0
  integer               ::layout(2) = (/1,0/)
  namelist /river_solo_nml/ current_date, dt_fast, years, months, days, &
       hours, minutes, seconds, calendar, layout

!--------------------------------------------------------------------
  type(time_type)      :: Time, Time_start, Time_end, Run_len, Time_step_fast
  integer              :: nf, num_fast_step, unit
  integer              :: yr,mon,day,hr,min,sec, calendar_type=-1
  integer              :: outunit
  real, allocatable    :: runoff(:,:), discharge(:,:)
  integer              :: initClock, mainClock, termClock, updateClock 
!Balaji
  real, allocatable :: runoff_c(:,:,:)
  real, allocatable :: discharge2ocean(:,:)
  real, allocatable :: discharge2ocean_c(:,:,:)
  real, allocatable :: liq(:,:), sol(:,:), mel(:,:), hea(:,:)

  call fms_init

  initClock = mpp_clock_id( 'Initialization' )
  mainClock = mpp_clock_id( 'Main loop' )
  termClock = mpp_clock_id( 'Termination' )
  updateClock = mpp_clock_id( 'update river')

  call mpp_clock_begin(initClock)
  call river_solo_init
  call mpp_clock_end (initClock) !end initialization

  call mpp_clock_begin(mainClock) !begin main loop
  outunit=stdout()
  do nf = 1, num_fast_step
     write(outunit,*)' at river fast time step ', nf
     call mpp_clock_begin(updateClock)
!Balaji
     call update_river( runoff, runoff_c, discharge2ocean, discharge2ocean_c, &
     liq, sol, mel, hea )
!     call update_river ( runoff, discharge )
     call mpp_clock_end (updateClock)
     Time = Time + Time_step_fast
  enddo
  call mpp_clock_end(mainClock)

  call mpp_clock_begin(termClock)
  call river_end
  call diag_manager_end(Time)
  call get_date(Time,yr,mon,day,hr,min,sec)

  if (mpp_pe() == mpp_root_pe()) then
      call mpp_open(unit, 'RESTART/river_solo.res',form=MPP_ASCII,&
           action=MPP_OVERWR,threading=MPP_SINGLE,fileset=MPP_SINGLE,nohdrs=.true.)
      write(unit,*) yr, mon, day, hr, min, sec
      write(unit,*) calendar_type 
      call mpp_close(unit)
  endif

  call fms_io_exit
  call fms_end


contains

!#######################################################################
  subroutine river_solo_init

    integer                     :: unit, ierr, io
    integer                     :: ni, nj, npes, isc, iec, jsc, jec, ntiles, tile
    type(domain2d)              :: Domain
    integer, allocatable        :: tile_ids(:)             ! mosaic tile IDs for the current PE
    real,   allocatable         :: lon(:,:), lat(:,:)
    real,   allocatable         :: area_lnd(:,:), area_lnd_cell(:,:), gfrac(:,:)
    integer                     :: date(6)
    character(len=9)            :: month

    call constants_init

#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=river_solo_nml, iostat=io)
    ierr = check_nml_error(io, 'river_solo_nml')
#else
    if (file_exist('input.nml')) then
      unit = open_namelist_file ()
      ierr=1
      do while (ierr /= 0)
         read  (unit, nml=river_solo_nml, iostat=io, end=10)
         ierr = check_nml_error (io, 'river_solo_nml')
      enddo
10    continue
      call close_file (unit)
    endif
#endif

    unit=stdlog()
    write(unit, nml= river_solo_nml)

! set the calendar 
    if (calendar(1:6) == 'julian') then
        calendar_type = julian
    else if (calendar(1:6) == 'NOLEAP') then
        calendar_type = NOLEAP
    else if (calendar(1:10) == 'thirty_day') then
        calendar_type = THIRTY_DAY_MONTHS
    else if (calendar(1:11) == 'no_calendar') then
        calendar_type = NO_CALENDAR
    else if (calendar(1:1) /= ' ') then
        call mpp_error (FATAL,'==>Error from ocean_solo_mod: invalid namelist value for calendar')
    else
        call mpp_error (FATAL,'==>Error from ocean_solo_mod: no namelist value for calendar')
    endif

! get river_solo restart 
    if (file_exist('INPUT/river_solo.res')) then
        call mpp_open(unit,'INPUT/river_solo.res',form=MPP_ASCII,action=MPP_RDONLY)
        read(unit,*) date
        read(unit,*) calendar_type 
        call close_file(unit)
    endif

    call set_calendar_type (calendar_type)

    call diag_manager_init

    if (sum(current_date) <= 0) then
        call mpp_error(FATAL,'==>Error from river_solo_mod: no namelist value for current date')
    else
        Time_start  = set_date(current_date(1),current_date(2), current_date(3), &
             current_date(4),current_date(5),current_date(6))
    endif

    if (file_exist('INPUT/river_solo.res')) then
        Time_start =  set_date(date(1),date(2),date(3),date(4),date(5),date(6))
    else
        Time_start = Time_start
        date = current_date
    endif

    Time           = Time_start
    Time_end       = increment_date(Time_start, years, months, days, hours, minutes, seconds)
    Run_len        = Time_end - Time_start
    Time_step_fast = set_time(dt_fast, 0)
    num_fast_step  = Run_len/Time_step_fast

    call mpp_open (unit, 'time_stamp.out', form=MPP_ASCII, action=MPP_OVERWR,threading=MPP_SINGLE)

    month = month_name(current_date(2))
    if ( mpp_pe() == mpp_root_pe() ) write (unit,'(6i4,2x,a3)') date, month(1:3)

    call get_date (Time_end, date(1), date(2), date(3), date(4), date(5), date(6))
    month = month_name(date(2))
    if ( mpp_pe() == mpp_root_pe() ) write (unit,'(6i4,2x,a3)') date, month(1:3)

    call close_file (unit)  

!--- get the land grid and set up domain decomposition
    call get_grid_size('LND', 1, ni, nj)

    npes = mpp_npes()
!--- define domain ------------------------------------------------
    call get_grid_ntiles('LND',ntiles)
    if(layout(1)*layout(2)*ntiles .NE. npes) call mpp_define_layout((/1,ni,1,nj/),npes/ntiles,layout)
    if (ntiles==1) then
       call mpp_define_domains ((/1,ni, 1, nj/), layout, domain, &
            xflags = CYCLIC_GLOBAL_DOMAIN, whalo=1, ehalo=1, shalo=1, nhalo=1, name = 'LAND MODEL')
    else
       call define_cube_mosaic ('LND', domain, layout, halo=1 )
    endif
    call mpp_get_compute_domain(Domain, isc, iec, jsc, jec)

    allocate(tile_ids(mpp_get_current_ntile(Domain)))
    tile_ids = mpp_get_tile_id(domain)
    tile = tile_ids(1)
    deallocate(tile_ids)

!--- get grid information
    allocate( lon(isc:iec,jsc:jec), lat(isc:iec,jsc:jec) )
    allocate( area_lnd(ni,nj), area_lnd_cell(ni,nj), gfrac(ni,nj) )
    call get_grid_cell_centers ('LND', tile, lon, lat, domain)
!!$    call get_grid_cell_area    ('LND',tile, area_lnd_cell)
!!$    call get_grid_comp_area    ('LND',tile, area_lnd)

    lon = lon * PI/180.
    lat = lat * PI/180.
!!$    gfrac = area_lnd/area_lnd_cell
    gfrac = 1
    npes = mpp_npes()

    call river_init( lon, lat, Time_start, Time_step_fast, Domain, gfrac(isc:iec,jsc:jec)  )

    allocate(runoff_c(isc:iec,jsc:jec,num_species) )
    allocate(runoff(isc:iec,jsc:jec), discharge(isc:iec,jsc:jec) )
    if(file_exist("INPUT/runoff.nc")) then
       call read_data("INPUT/runoff.nc", "runoff", runoff )
    else
       runoff = CONST_RUNOFF
    end if
    if(file_exist("INPUT/runoff.nc")) then
       call read_data("INPUT/runoff.nc", "runoff_c", runoff_c )
    else
       runoff_c = CONST_RUNOFF
    end if
    allocate( discharge2ocean(isc:iec,jsc:jec) )
    allocate( discharge2ocean_c(isc:iec,jsc:jec,num_species) )

  end subroutine river_solo_init

!#####################################################################

end program river_solo

#endif test_river_solo


module river_physics_mod 

!-----------------------------------------------------------------------
!                   GNU General Public License                        
!                                                                      
! This program is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! For the full text of the GNU General Public License,               
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
! <CONTACT EMAIL="klf@gfdl.noaa.gov"> Kirsten Findell </CONTACT> 
! <CONTACT EMAIL="z1l@gfdl.noaa.gov"> Zhi Liang </CONTACT> 

#ifdef INTERNAL_FILE_NML
  use mpp_mod, only: input_nml_file
#else
  use fms_mod, only: open_namelist_file
#endif

  use mpp_mod,         only : mpp_sync_self, mpp_send, mpp_recv, EVENT_RECV, EVENT_SEND
  use mpp_mod,         only : mpp_npes, mpp_error, FATAL, mpp_get_current_pelist
  use mpp_mod,         only : mpp_root_pe, mpp_pe, mpp_max
  use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, mpp_get_data_domain
  use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY, mpp_update_domains 
  use mpp_domains_mod, only : mpp_get_compute_domains
  use mpp_domains_mod, only : mpp_get_num_overlap, mpp_get_overlap
  use mpp_domains_mod, only : mpp_get_update_size, mpp_get_update_pelist
  use fms_mod,         only : stdlog, write_version_number
  use fms_mod,         only : close_file, check_nml_error, file_exist
  use diag_manager_mod,only : register_diag_field, send_data
  use river_type_mod,  only : river_type, Leo_Mad_trios
  use lake_mod,        only : large_dyn_small_stat
  use lake_tile_mod,   only : num_l
  use constants_mod,   only : tfreeze, hlf, DENS_H2O
  use land_debug_mod,  only : set_current_point, is_watch_point

  implicit none
  private

  real    :: missing = -1.e8

!--- version information ---------------------------------------------
  character(len=128) :: version = '$Id: river_physics.F90,v 18.0.6.1 2010/08/24 12:11:35 pjp Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'


! ---- public interfaces -----------------------------------------------------

  public :: river_physics_init, river_physics_step

!----------------------------------------------------------------------
  real               :: clw = 4218.
  real               :: csw = 2106.
  real,    parameter :: sec_in_day = 86400.
  integer :: num_lake_lev

! ---- namelist interface
  character*6 :: algor = 'linear'
  real :: lake_outflow_frac_ceiling = 1.e20
  real :: lake_sfc_w_min = -1.e20
  real :: storage_threshold_for_melt = 1.
  real :: storage_threshold_for_diag = 1.e6
  logical :: ice_frac_from_sfc = .false.
  logical :: use_lake_area_bug = .false.
  logical :: zero_frac_bug     = .false. ! it TRUE, reverts to quebec (buggy)
      ! behavior, where the discharge points with zero land fraction were
      ! missed, resulting in water non-conservation
  real :: ice_frac_factor = 0.

  namelist /river_physics_nml/ algor, lake_outflow_frac_ceiling, &
                               lake_sfc_w_min, storage_threshold_for_melt, &
                               storage_threshold_for_diag, &
                               ice_frac_from_sfc, ice_frac_factor, &
                               use_lake_area_bug, zero_frac_bug

  integer, parameter, dimension(8) :: di=(/1,1,0,-1,-1,-1,0,1/)
  integer, parameter, dimension(8) :: dj=(/0,-1,-1,-1,0,1,1,1/)
  integer                          :: isc, iec, jsc, jec  ! compute domain
  integer                          :: isd, ied, jsd, jed  ! data domain
  integer                          :: maxtravel
  integer                          :: npes
  integer                          :: num_species
 
  type comm_type
     integer          :: count
     integer          :: pe
     integer, pointer :: i(:) => NULL()
     integer, pointer :: j(:) => NULL()
     integer, pointer :: k(:) => NULL()
  end type comm_type

  type halo_update_type
     type(comm_type), pointer :: send(:) => NULL();
     type(comm_type), pointer :: recv(:) => NULL();
  end type halo_update_type

  type(halo_update_type),  allocatable :: halo_update(:)
  integer                              :: nsend_update, nrecv_update
  real, dimension(:),      allocatable :: send_buffer, recv_buffer
  logical, dimension(:,:), allocatable :: in_domain
  integer, dimension(:,:), allocatable :: nlev

  ! ---- diag field IDs
  integer :: id_temp, id_ice
  integer :: id_temp_old, id_ice_old ! for compatibility with older diagTables

contains

!#######################################################################

  subroutine river_physics_init(River, domain, id_lon, id_lat )
    type(river_type), intent(inout) :: River
    type(domain2d),   intent(inout) :: domain
    integer, intent(in) :: id_lon, id_lat ! diag field IDs

    integer                         :: unit, io_status, ierr
    integer                         :: i, j


!--- read namelist -------------------------------------------------
#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=river_physics_nml, iostat=io_status)
    ierr = check_nml_error(io_status, 'river_physics_nml')
#else
    if (file_exist('input.nml')) then
      unit = open_namelist_file()
      ierr = 1;
      do while ( ierr/=0 )
         read  (unit, river_physics_nml, iostat=io_status, end=10)
         ierr = check_nml_error(io_status,'river_physics_nml')
      enddo
10    continue
      call close_file (unit)
    endif
#endif

!--- write version and namelist info to logfile --------------------
    call write_version_number(version,tagname)
    unit=stdlog()
    write (unit, river_physics_nml)  

    npes     = mpp_npes()

    call mpp_get_compute_domain(domain, isc, iec, jsc, jec)
    call mpp_get_data_domain(domain, isd, ied, jsd, jed)

    num_lake_lev = num_l
    num_species = size(River%outflow_c,3)
    maxtravel = maxval(River%travel)
    call mpp_max(maxtravel)

!--- set up the halo update 
    call setup_halo_update(River, domain)

    do j = jsc, jec
       do i = isc, iec
          if(River%tocell(i,j) > 0) then
             River%i_tocell(i,j) = i + di(River%tocell(i,j))
             River%j_tocell(i,j) = j + dj(River%tocell(i,j))
          end if
       end do
    end do
 
    ! ---- register diagnostic fields
    id_ice  = register_diag_field ( 'river', 'rv_ice', (/id_lon, id_lat/), &
         River%Time, 'river ice mass fraction', '-', missing_value=missing, &
         mask_variant=.TRUE. )
    id_temp = register_diag_field ( 'river', 'rv_T', (/id_lon, id_lat/), &
         River%Time, 'river temperature', 'K', missing_value=missing, &
         mask_variant=.TRUE. )

    id_ice_old = register_diag_field ( 'river', 'ice', (/id_lon, id_lat/), &
         River%Time, 'obsolete, pls use rv_ice', '-', missing_value=missing, &
         mask_variant=.TRUE. )
    id_temp_old = register_diag_field ( 'river', 'temp', (/id_lon, id_lat/), &
         River%Time, 'obsolete, pls use rv_T', 'K', missing_value=missing, &
         mask_variant=.TRUE. )
  end subroutine river_physics_init

!#####################################################################

  subroutine river_physics_step(River, cur_travel, &
         lake_sfc_A, lake_sfc_bot, lake_depth_sill, lake_width_sill, &
         lake_whole_area, lake_T, lake_wl, lake_ws )

    type(river_type),     intent(inout) :: River
    integer,                 intent(in) :: cur_travel

    real, dimension(isd:ied,jsd:jed), intent(in) :: &
                             lake_sfc_A, lake_sfc_bot
    real, dimension(isd:ied,jsd:jed,num_lake_lev), intent(inout) :: &
                             lake_wl, lake_ws
    real, dimension(isc:iec,jsc:jec), intent(in) :: &
                lake_depth_sill, lake_width_sill, lake_whole_area
    real, dimension(isc:iec,jsc:jec,num_lake_lev), intent(inout) :: &
                             lake_T
! ---- local vars ----------------------------------------------------------
    integer   :: i, j, to_i, to_j, i_species, lev
    real      :: Q0, dQ_dV, avail, out_frac, qmelt
    real      :: liq_to_flow, ice_to_flow, liq_this_lev, ice_this_lev
    real      :: lake_area, h, ql, qs, qh, qt, h0, t_scale
    real      :: influx
    real      :: influx_c(River%num_species)
    real      :: v_r_d(River%num_species-River%num_c+1:River%num_species)
    real      :: conc(1:River%num_species)
    logical, dimension(isc:iec,jsc:jec) :: &
         diag_mask ! mask of valid ice and temperature values fo diagnostics
    real, dimension(isc:iec,jsc:jec) :: &
         ice, temperature ! variables for diag output (were in River_type) 
    logical :: used ! flag returned by the send_data

    ! invalidate diag_mask everywhere
    diag_mask = .FALSE.

    ! do for all cells at current number of steps from river mouth
    do j = jsc, jec 
      do i = isc, iec
        call set_current_point(i,j,1) ! for debug output
        if (River%travel(i,j)==cur_travel.and.&
            ((.not.zero_frac_bug).or.(River%landfrac(i,j).gt.0))) then
            ! if zero_frac_bug is FALSE, the second line of condition is
            ! always TRUE, so we revert to bugfix
            ! if zero_frac_bug is TRUE, the second line is simply
            ! River%landfrac(i,j).gt.0, so we get quebec (buggy) condition

            ! FIRST COMPUTE LAKE MASS BALANCE (FROM INFLOC AND INFLOW TO LAKE_OUTFLOW)
          
            lake_area = lake_sfc_A(i,j)
            influx   =(River%inflow  (i,j)  +River%infloc  (i,j))  *DENS_H2O*River%dt_slow
            influx_c =(River%inflow_c(i,j,:)+River%infloc_c(i,j,:))*DENS_H2O*River%dt_slow
            if (River%tocell(i,j).eq.0 .and. River%landfrac(i,j).ge.1.) then
                ! terminal, all-land cell (must have lake)
                h = (clw*lake_wl(i,j,1)+csw*lake_ws(i,j,1))*(lake_T(i,j,1)-tfreeze)
                lake_wl(i,j,1) = lake_wl(i,j,1) + (influx-influx_c(1))/lake_area
                lake_ws(i,j,1) = lake_ws(i,j,1) +         influx_c(1) /lake_area
                lake_T (i,j,1) = tfreeze + &
                   (h+influx_c(2)/lake_area)/(clw*lake_wl(i,j,1)+csw*lake_ws(i,j,1))
                ! LAKE_SFC_C(I,J,:) = LAKE_SFC_C(I,J,:) + INFLUX_C / LAKE_AREA
              else
                ! non-terminal all-land cell (possible lake), or terminal coastal cell (possible lake)
                if (lake_area.gt.0.) then
                     h = (clw*lake_wl(i,j,1)+csw*lake_ws(i,j,1))*(lake_T(i,j,1)-tfreeze)
                     lake_wl(i,j,1) = lake_wl(i,j,1) + (influx-influx_c(1))/lake_area
                     lake_ws(i,j,1) = lake_ws(i,j,1) +         influx_c(1) /lake_area
                     lake_T (i,j,1) = tfreeze + &
                        (h+influx_c(2)/lake_area)/(clw*lake_wl(i,j,1)+csw*lake_ws(i,j,1))
                     ! LAKE_SFC_C(I,J,:) = LAKE_SFC_C(I,J,:) + INFLUX_C / LAKE_AREA
                     h0 = lake_sfc_bot(i,j) + (lake_wl(i,j,1)+lake_ws(i,j,1))/DENS_H2O &
                                           -lake_depth_sill(i,j)
                     qt = lake_area * h0 * DENS_H2O
                     ! qt is mass of water stored transiently above sill
                     ! now reduce it to amount that discharges this time step
                     if (qt.gt.0.) then
                         IF (large_dyn_small_stat) THEN
                             if (lake_width_sill(i,j) .gt. 0.) then
                                 t_scale = lake_whole_area(i,j)/(0.9*lake_width_sill(i,j)*sqrt(h0))
                                 qt = qt * (1. - (1.+River%dt_slow/t_scale)**(-2) )
                                 if (.not.use_lake_area_bug) qt = qt * lake_whole_area(i,j)/lake_area
                               endif
                             qt = min(qt, lake_outflow_frac_ceiling * lake_area &
                                          * max(0.,(lake_wl(i,j,1)+lake_ws(i,j,1))))
                             qt = min(qt, (lake_wl(i,j,1)+lake_ws(i,j,1)-lake_sfc_w_min)*lake_area )
                           ELSE
                             t_scale = lake_whole_area(i,j)/(0.9*lake_width_sill(i,j)*sqrt(h0))
                             qt = qt * (1. - (1.+River%dt_slow/t_scale)**(-2) )
                             if (.not.use_lake_area_bug) qt = qt * lake_whole_area(i,j)/lake_area
                             qt = min(qt, lake_outflow_frac_ceiling * lake_area &
                                          * max(0.,(lake_wl(i,j,1)+lake_ws(i,j,1))))
                             qt = min(qt, (lake_wl(i,j,1)+lake_ws(i,j,1)-lake_sfc_w_min)*lake_area )
                           ENDIF
                         if (ice_frac_from_sfc) then
                             out_frac = lake_wl(i,j,1)/(lake_wl(i,j,1)+lake_ws(i,j,1))
                           else
                             out_frac = max (sum(lake_wl(i,j,:))/sum(lake_wl(i,j,:)+lake_ws(i,j,:)), &
                                           lake_wl(i,j,1)/(lake_wl(i,j,1)+lake_ws(i,j,1)))
                           endif
                         out_frac = min(1., max(0., out_frac))
                         if (ice_frac_factor.lt.1.) then
                             ql = (1.-ice_frac_factor*(1.-out_frac)) * qt
                             ql = min (ql, lake_area*sum(lake_wl(i,j,:)))
                           else
                             ql = out_frac * qt
                           endif
                         qs = qt - ql
                         liq_to_flow = ql
                         ice_to_flow = qs
                         qh = 0.
                         if (is_watch_point()) &
                              write(*,*) 'ql/A,qs/A,A',ql/lake_area,qs/lake_area,lake_area
                         do lev = 1, num_lake_lev
                           if (is_watch_point()) &
                                write(*,*) 'wl(1),ws(1),wl(l),ws(l):',&
                                           lake_wl(i,j,1),lake_ws(i,j,1),&
                                           lake_wl(i,j,lev),lake_ws(i,j,lev)
                           liq_this_lev = max(0.,min(liq_to_flow, lake_area*lake_wl(i,j,lev)))
                           ice_this_lev = max(0.,min(ice_to_flow, lake_area*lake_ws(i,j,lev)))
                           lake_wl(i,j,lev) = lake_wl(i,j,lev) - liq_this_lev/lake_area
                           lake_ws(i,j,lev) = lake_ws(i,j,lev) - ice_this_lev/lake_area
                           liq_to_flow = liq_to_flow - liq_this_lev
                           ice_to_flow = ice_to_flow - ice_this_lev
                           qh = qh + (clw*liq_this_lev+csw*ice_this_lev)*(lake_T(i,j,lev)-tfreeze)
                           if (lev.gt.1) then
                             ! replensih (liquid) water lost from depth, using ice from surface,
                             ! so as to preserve thickness of deeper layer
                             h = (clw*lake_wl(i,j,lev)+csw*lake_ws(i,j,lev)) &
                                                            *(lake_T(i,j,lev)-tfreeze)
                             lake_ws(i,j,lev) = lake_ws(i,j,lev) + liq_this_lev/lake_area
                             lake_ws(i,j,1)   = lake_ws(i,j,1)   - liq_this_lev/lake_area
                             lake_T (i,j,lev) = tfreeze + &
                                (h +(liq_this_lev/lake_area)*csw*(lake_T(i,j,1)-tfreeze))  &
                                            /(clw*lake_wl(i,j,lev)+csw*lake_ws(i,j,lev))
                             endif
                             if (is_watch_point()) &
                                  write(*,*) 'wl(1),ws(1),wl(l),ws(l):',&
                                             lake_wl(i,j,1),lake_ws(i,j,1),&
                                             lake_wl(i,j,lev),lake_ws(i,j,lev)
                           if (liq_to_flow.eq.0..and.ice_to_flow.eq.0.) exit
                           enddo
                         River%lake_outflow  (i,j)   = qt
                         River%lake_outflow_c(i,j,1) = qs
                         River%lake_outflow_c(i,j,2) = qh
                       endif
                   else
                     River%lake_outflow  (i,j  ) = influx
                     River%lake_outflow_c(i,j,1) = influx_c(1)
                     River%lake_outflow_c(i,j,2) = influx_c(2)
                   endif
              endif

            ! NEXT COMPUTE RIVER-REACH MASS BALANCE (FROM LAKE_OUTFLOW TO OUTFLOW)
          
            if (River%tocell(i,j).gt.0 .or. River%landfrac(i,j).lt.1.) then
                ! avail is volume to be split between outflow and new storage
                avail = River%storage(i,j) + River%lake_outflow(i,j) / DENS_H2O
                ! determine total water storage at end of step
                if (River%reach_length(i,j) .gt. 0.) then
                    if (algor.eq.'linear') then   ! assume outflow = Q0+dQ_dV*dS
                        if (River%storage(i,j) .le. 0.) then
                            Q0 = 0.; dQ_dV = 0.
                          else
                            Q0=River%o_coef(i,j)*River%storage(i,j)**River%o_exp
                            dQ_dV=River%o_exp*Q0/River%storage(i,j)
                          endif
                        River%storage(i,j) = River%storage(i,j) + River%dt_slow *   &
                             (River%lake_outflow(i,j)/(DENS_H2O*River%dt_slow)-Q0) &
                             /(1.+River%dt_slow*dQ_dV)
                      else if (algor.eq.'nonlin') then   ! assume all inflow at start of step 
                        if (avail .gt. 0.) then
                            River%storage(i,j) = (avail**(1.-River%o_exp) &
                                 + River%o_coef(i,j)*(River%o_exp-1.)*River%dt_slow) &
                                 **(1./(1.-River%o_exp))
                          else
                            River%storage(i,j) = avail
                          endif
                      endif
                  endif
                ! determine total water outflow during step
                River%outflow(i,j) = (avail - River%storage(i,j)) / River%dt_slow
                ! given outflow, determine flow width, depth, velocity
                if (River%outflow(i,j) .le. 0.) then
                    River%depth(i,j) = 0.
                    River%width(i,j) = 0.
                    River%vel(i,j)   = 0.
                  else
                    River%depth(i,j) = River%d_coef(i,j) &
                         * River%outflow(i,j)**River%d_exp
                    River%width(i,j) = River%w_coef(i,j) &
                         * River%outflow(i,j)**River%w_exp
                    River%vel(i,j) = River%outflow(i,j) /                   &
                                        (River%width(i,j) * River%depth(i,j))
                  endif
                ! given water outflow and storage, split other tracked stuff same way
                out_frac = 0.
                if (avail .gt. 0.) out_frac = River%outflow(i,j)/avail
                River%outflow_c(i,j,:) = out_frac * (River%storage_c(i,j,:) &
                                         +River%lake_outflow_c(i,j,:)/DENS_H2O)
                River%outflow_c(i,j,:) = max(River%outflow_c(i,j,:), 0.)
                River%outflow_c(i,j,1) = min(River%outflow_c(i,j,1), River%outflow(i,j))
                River%storage_c(i,j,:) = River%storage_c(i,j,:)       &
                      + River%lake_outflow_c(i,j,:)/DENS_H2O       &
                      - River%outflow_c(i,j,:)*River%dt_slow
                ! define intensive variables for diagnostics and for use in transformations.
                ! along the way, melt swept snow as necessary. freeze will be a separate
                ! process, added later; it will be different in that frozen river water will
                ! be stationary, thus a different species

                if (River%storage(i,j) .gt. storage_threshold_for_melt) then
                    conc(1) = River%storage_c(i,j,1)/River%storage(i,j)
                    conc(2) = tfreeze + River%storage_c(i,j,2) /  &
                       ( clw*River%storage(i,j) + (csw-clw)*River%storage_c(i,j,1))
                    if (River%storage_c(i,j,1).gt.0. .and. conc(2).gt.tfreeze) then
!                    if (River%storage_c(i,j,1).gt.0. .and. River%storage_c(i,j,2).gt.0.) then
                        qmelt = min(hlf*River%storage_c(i,j,1), River%storage_c(i,j,2))
                        River%melt(i,j) = qmelt
                        River%storage_c(i,j,1) = River%storage_c(i,j,1) - qmelt/hlf
                        River%storage_c(i,j,2) = River%storage_c(i,j,2) - qmelt
!                        conc(2) = tfreeze + River%storage_c(i,j,2) /  &
!                           ( clw*River%storage(i,j) + (csw-clw)*River%storage_c(i,j,1))
                      endif
                  endif

                if (River%storage(i,j) .gt. storage_threshold_for_diag) then
                    conc(1) = River%storage_c(i,j,1)/River%storage(i,j)
                    conc(2) = tfreeze + River%storage_c(i,j,2) /  &
                       ( clw*River%storage(i,j) + (csw-clw)*River%storage_c(i,j,1))
                    diag_mask(i,j) = .TRUE. 
                  else
                    conc(1) = missing
                    conc(2) = missing
                  endif

                ice(i,j)=conc(1)
                temperature(i,j)=conc(2)

                if (River%do_age) then
                    River%removal_c(i,j,River%num_phys+1) = -River%storage(i,j)/sec_in_day
                    River%storage_c(i,j,River%num_phys+1) = River%storage_c(i,j,River%num_phys+1) &
                       - River%removal_c(i,j,River%num_phys+1)*River%dt_slow
                  endif

                if (River%storage(i,j) .gt. 0.) then
                    conc(River%num_phys+1:River%num_species) = &
                       River%storage_c(i,j,River%num_phys+1:River%num_species)/River%storage(i,j)
                  else
                    conc(River%num_phys+1:River%num_species) = 0.
                  endif

                if(River%num_c.gt.0) then
                    if (River%depth(i,j).gt.0. .and. conc(2).gt.100.) then
                        v_r_d = River%vf_ref * River%Q10**((conc(2)-River%t_ref)/10.)&
                           / ((1+River%kinv*conc(River%num_species-River%num_c+1:River%num_species)) &
                           *River%depth(i,j))
                        ! next should not be necessary if storage_c is positive, but maybe it's not.
                        v_r_d = River%vf_ref * River%Q10**((conc(2)-River%t_ref)/10.)&
                           / ((1+River%kinv*max(0.,conc(River%num_species-River%num_c+1:River%num_species)))*River%depth(i,j))
                      else
                        v_r_d = 0.
                      endif
                    River%removal_c(i,j,River%num_species-River%num_c+1:River%num_species) = &
                       River%storage_c(i,j,River%num_species-River%num_c+1:River%num_species) &
                       * (1-exp( -v_r_d * River%dt_slow)) &
                       / River%dt_slow
                    River%storage_c(i,j,River%num_species-River%num_c+1:River%num_species) = &
                       River%storage_c(i,j,River%num_species-River%num_c+1:River%num_species) &
                       - River%removal_c(i,j,River%num_species-River%num_c+1:River%num_species)* River%dt_slow
                  endif
              endif

            ! FINALLY, REDEFINE OUTFLOW AS DISCHARGE IF WE HAVE OCEAN HERE
          
            if (River%landfrac(i,j).lt.1.) then
                River%disw2o(i,j) = River%outflow(i,j)
                River%outflow(i,j) = 0.
                do i_species = 1, num_species
                  River%disc2o(i,j,i_species) = River%outflow_c(i,j,i_species)
                  River%outflow_c(i,j,i_species) = 0.
                  enddo
              endif

          endif
        enddo
      enddo

    

    if (cur_travel .gt. 0) call do_halo_update(River, halo_update(cur_travel))
    
    ! ---- diagnostic section
    if (id_ice > 0) used = send_data (id_ice, &
         ice(isc:iec,jsc:jec), River%Time, mask=diag_mask)
    if (id_temp > 0) used = send_data (id_temp, &
         temperature(isc:iec,jsc:jec), River%Time, mask=diag_mask)
    ! for compatibility with old diag table
    if (id_ice_old > 0) used = send_data (id_ice_old, &
         ice(isc:iec,jsc:jec), River%Time, mask=diag_mask)
    if (id_temp_old > 0) used = send_data (id_temp_old, &
         temperature(isc:iec,jsc:jec), River%Time, mask=diag_mask)

  end subroutine river_physics_step

!#####################################################################
  subroutine setup_halo_update(River, domain)
    type(river_type),      intent(inout) :: River
    type(domain2d),        intent(inout) :: domain

    integer, parameter                   :: MAXCOMM      = 8  ! should be no larger than 8.
    integer                              :: travelnow, nsend2, p, toc
    integer                              :: spos, rpos, n, m, l
    integer                              :: buffer_pos, pos, msgsize
    integer                              :: i, j, i1, j1, i2, j2, i3, j3, i4, j4, k, kk
    integer                              :: send_size, recv_size, siz, i_dest, j_dest
    logical                              :: is_my_recv, is_my_send
    integer                              :: my_recv_index, my_send_index, roff, soff, pe, total_size
    integer                              :: nsend, nrecv, total_send, total_recv, max_send, max_recv
    integer, allocatable, dimension(:,:) :: tocell
    integer, allocatable, dimension(:,:) :: is_recv, ie_recv, js_recv, je_recv
    integer, allocatable, dimension(:,:) :: is1_send, ie1_send, js1_send, je1_send
    integer, allocatable, dimension(:,:) :: is2_send, ie2_send, js2_send, je2_send
    integer, allocatable, dimension(:,:) :: rot_send, rot_recv, dir_send, dir_recv
    integer, allocatable, dimension(:)   :: send_pelist, recv_pelist, pelist_r, pelist_s
    integer, allocatable, dimension(:)   :: send_count, recv_count, recv_size2
    integer, allocatable, dimension(:)   :: isl, iel, jsl, jel  
    integer, allocatable, dimension(:)   :: sbuf, rbuf
    type(comm_type), pointer             :: send => NULL()
    integer, allocatable, dimension(:,:,:) :: i_send, j_send, t_send, p_send, n_send

    call mpp_get_data_domain   (domain, isd, ied, jsd, jed)
    
    !--- first get the travel and tocell information onto data domain
    allocate(tocell(isd:ied,jsd:jed))
    allocate(isl(0:npes-1), iel(0:npes-1), jsl(0:npes-1), jel(0:npes-1) )
    tocell(isc:iec,jsc:jec) = River%tocell(isc:iec,jsc:jec)
    call mpp_update_domains(tocell, domain)
    call mpp_get_compute_domains(domain, xbegin=isl, xend=iel, ybegin=jsl, yend=jel)

    !--- first get the halo update information for send and recv.
    call mpp_get_update_size(domain, nsend, nrecv)

    if(nsend>0) then
       allocate(send_count(nsend))
       do p = 1, nsend
          send_count(p) = mpp_get_num_overlap(domain, EVENT_SEND, p)
       enddo
       if(ANY(send_count .LE. 0)) call mpp_error(FATAL, &
                  "river_mod: send_count should be positive for any entry")
       total_send = sum(send_count)
       allocate(rbuf(4*total_send))
    endif

    if(nrecv>0) then
       allocate(recv_count(nrecv))
       do p = 1, nrecv
          recv_count(p) = mpp_get_num_overlap(domain, EVENT_RECV, p)
       enddo
       if(ANY(recv_count .LE. 0)) call mpp_error(FATAL, &
            "river_mod: recv_count should be positive for any entry")
       total_recv = sum(recv_count)
       allocate(sbuf(4*total_recv))
    endif
 
    !--- pre-post recv
    rpos = 0
    if(nsend > 0) then
       allocate(pelist_s(nsend))
       max_send = maxval(send_count)
       allocate(is1_send(nsend,max_send), ie1_send(nsend,max_send) )
       allocate(js1_send(nsend,max_send), je1_send(nsend,max_send) )
       allocate(is2_send(nsend,max_send), ie2_send(nsend,max_send) )
       allocate(js2_send(nsend,max_send), je2_send(nsend,max_send) )
       allocate(dir_send(nsend,max_send), rot_send(nsend,max_send) )
       call mpp_get_update_pelist(domain, EVENT_SEND, pelist_s)
       do p = 1, nsend    
          call mpp_get_overlap(domain, EVENT_SEND, p, is1_send(p,1:send_count(p)), ie1_send(p,1:send_count(p)), &
               js1_send(p,1:send_count(p)), je1_send(p,1:send_count(p)), dir_send(p,1:send_count(p)), &
               rot_send(p,1:send_count(p)) )
          call mpp_recv(rbuf(rpos+1), glen=4*send_count(p), from_pe=pelist_s(p), block=.FALSE.)
          rpos = rpos + 4*send_count(p)
       enddo
    endif

    spos = 0
    if(nrecv>0) then
       allocate(pelist_r(nrecv))
       max_recv = maxval(recv_count)
       allocate(is_recv (nrecv,max_recv), ie_recv (nrecv,max_recv) )
       allocate(js_recv (nrecv,max_recv), je_recv (nrecv,max_recv) )
       allocate(rot_recv(nrecv,max_recv), dir_recv(nrecv,max_recv) )
       call mpp_get_update_pelist(domain, EVENT_RECV, pelist_r)
       do p = 1, nrecv
          call mpp_get_overlap(domain, EVENT_RECV, p, is_recv(p,1:recv_count(p)), ie_recv(p,1:recv_count(p)), &
               js_recv(p,1:recv_count(p)), je_recv(p,1:recv_count(p)), dir_recv(p,1:recv_count(p)), &
               rot_recv(p,1:recv_count(p)))
          !--- send the information to the process that send data.
          do n = 1, recv_count(p)
             sbuf(spos+(n-1)*4+1) = is_recv(p,n)
             sbuf(spos+(n-1)*4+2) = ie_recv(p,n)
             sbuf(spos+(n-1)*4+3) = js_recv(p,n)
             sbuf(spos+(n-1)*4+4) = je_recv(p,n)
          end do
          call mpp_send(sbuf(spos+1), plen = 4*recv_count(p), to_pe = pelist_r(p) )
          spos = spos + 4*recv_count(p)
       end do
    endif

    call mpp_sync_self(check=EVENT_RECV)
    !--- unpack
    do p = nsend, 1, -1
       rpos = rpos - 4*send_count(p)
       do n = 1, send_count(p)
          is2_send(p,n) = rbuf(rpos+(n-1)*4+1)
          ie2_send(p,n) = rbuf(rpos+(n-1)*4+2)
          js2_send(p,n) = rbuf(rpos+(n-1)*4+3)
          je2_send(p,n) = rbuf(rpos+(n-1)*4+4)
       end do
    end do
        
    call mpp_sync_self()

    is_my_recv = .false.
    do p = 1, nsend
       if(pelist_s(p) == mpp_pe()) then
          is_my_recv = .true.
          my_recv_index = p
       endif
    enddo
    is_my_send = .false.
    do p = 1, nrecv
       if(pelist_r(p) == mpp_pe()) then
          is_my_send = .true.
          my_send_index = p
       endif
    enddo
    roff = 0
    soff = 0
    if( is_my_recv) then
       nrecv_update = nsend
       if(nsend > 0) then
          allocate(recv_pelist(nrecv_update))
          recv_pelist = pelist_s
       endif
    else
       nrecv_update = nsend + 1
       allocate(recv_pelist(nrecv_update))
       my_recv_index = 1
       roff = 1
       recv_pelist(1) = mpp_pe()
       do p = 1, nsend
          recv_pelist(p+1) = pelist_s(p)
       enddo
    endif
    if( is_my_send ) then
       nsend_update = nrecv
       if(nrecv>0) then
          allocate(send_pelist(nsend_update))
          send_pelist = pelist_r
       endif
    else
       nsend_update = nrecv + 1
       allocate(send_pelist(nsend_update))
       my_send_index = 1
       soff = 1
       send_pelist(1) = mpp_pe()
       do p = 1, nrecv
          send_pelist(p+1) = pelist_r(p)
       enddo
    endif

    allocate(halo_update(maxtravel) )
    if(nsend_update>0) then
       do travelnow = 1, maxtravel
          allocate(halo_update(travelnow)%send(nsend_update))
          halo_update(travelnow)%send(:)%count = 0
          do p = 1, nsend_update
             halo_update(travelnow)%send(p)%count = 0
             halo_update(travelnow)%send(p)%pe    = send_pelist(p)
          end do
       end do
    endif

    if(nrecv_update>0) then
       do travelnow = 1, maxtravel
          allocate(halo_update(travelnow)%recv(nrecv_update))
          halo_update(travelnow)%recv(:)%count = 0
          do p = 1, nrecv_update
             halo_update(travelnow)%recv(p)%count = 0
             halo_update(travelnow)%recv(p)%pe    = recv_pelist(p)
          end do
       end do
    endif

    do p = 1, nsend
       pe = pelist_s(p) - mpp_root_pe()
       !--- configure points need to receive from other pe.
       !--- (i,j) --- halo index on the pe sent to, one neighbor pe data domain
       !--- (i1,j1) --- neighbor index of (i,j) on the pe sent to, on neighbor pe compute domain
       !--- (i2,j2) --- my index corresponding to (i,j), on my compute domain
       !--- (i3,j3) --- neighbor index of (i2,j2), on my data domain
       !--- (i4,j4) --- index of (i1,j1) tocell. 
       do n = 1, send_count(p)
          select case ( dir_send(p,n) )
          case(1)  ! east
             i = is2_send(p,n)  ! is2_send(p,n) == ie2_send(p,n)
             i1 = i - 1
             do j = js2_send(p,n), je2_send(p,n)
                do l = -1,1
                   j1 = j + l
                   if(j1<jsl(pe) .OR. j1 > jel(pe) ) cycle
                   select case(rot_send(p,n))
                   case (ZERO) ! w->e
                      i2 = is1_send(p,n)
                      i3 = i2 -1
                      j2 = js1_send(p,n) + j  - js2_send(p,n)
                      j3 = js1_send(p,n) + j1 - js2_send(p,n)
                   case (NINETY) ! s->e
                      i2 = is1_send(p,n) + (je2_send(p,n) - j )
                      i3 = is1_send(p,n) + (je2_send(p,n) - j1)
                      j2 = js1_send(p,n)
                      j3 = j2 - 1
                   end select
                   if(River%travel(i3,j3) >0) then
                      toc = tocell(i3,j3)
                      i4 = i1 + di(toc)
                      j4 = j1 + dj(toc) 
                      if(i4 == i .AND. j4 == j) then
                         call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                      end if
                   end if
                end do
             end do
          case(2)  ! south east
             i = is2_send(p,n)  ! is2_send(p,n) == ie2_send(p,n)
             j = js2_send(p,n)  ! js2_send(p,n) == je2_send(p,n)
             i1 = i - 1
             j1 = j + 1
             i2 = is1_send(p,n)  ! is1_send(p,n) == ie1_send(p,n)
             j2 = js1_send(p,n)  ! js1_send(p,n) == je1_send(p,n)
             select case(rot_send(p,n))
             case (ZERO) ! nw->se 
                i3 = i2 - 1
                j3 = j2 + 1
             case (NINETY)
                i3 = i2 - 1
                j3 = j2 - 1
             case (MINUS_NINETY)
                i3 = i2 + 1
                j3 = j2 + 1
             end select  
             if(River%travel(i3,j3) >0) then
                toc = tocell(i3,j3)
                i4 = i1 + di(toc)
                j4 = j1 + dj(toc) 
                if(i4 == i .AND. j4 == j) then
                   call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                end if
             end if
          case(3)  ! south
             j = js2_send(p,n)  ! js2_send(p,n) == je2_send(p,n)
             j1 = j + 1
             do i = is2_send(p,n), ie2_send(p,n)
                do l = -1,1
                   i1 = i + l
                   if(i1<isl(pe) .OR. i1 > iel(pe) ) cycle
                   select case(rot_send(p,n))
                   case (ZERO) ! n->s
                      i2 = is1_send(p,n) + i  - is2_send(p,n)
                      i3 = is1_send(p,n) + i1 - is2_send(p,n)
                      j2 = js1_send(p,n)
                      j3 = j2 + 1
                   case (MINUS_NINETY) ! e->s
                      i2 = is1_send(p,n)
                      i3 = i2 + 1
                      j2 = js1_send(p,n) + (ie2_send(p,n) - i )
                      j3 = js1_send(p,n) + (ie2_send(p,n) - i1)
                   end select
                   if(River%travel(i3,j3) >0) then
                      toc = tocell(i3,j3)
                      i4 = i1 + di(toc)
                      j4 = j1 + dj(toc) 
                      if(i4 == i .AND. j4 == j) then
                         call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                      end if
                   end if
                end do
             end do
          case(4)  ! south west
             i = is2_send(p,n)  ! is2_send(p,n) == ie2_send(p,n)
             j = js2_send(p,n)  ! js2_send(p,n) == je2_send(p,n)
             i1 = i + 1
             j1 = j + 1
             i2 = is1_send(p,n)  ! is1_send(p,n) == ie1_send(p,n)
             j2 = js1_send(p,n)  ! js1_send(p,n) == je1_send(p,n)
             select case(rot_send(p,n))
             case (ZERO) ! ne->sw 
                i3 = i2 + 1
                j3 = j2 + 1
             case (NINETY) !  
                i3 = i2 - 1
                j3 = j2 + 1
             case (MINUS_NINETY)
                i3 = i2 + 1
                j3 = j2 - 1
             end select  
             if(River%travel(i3,j3) >0) then
                toc = tocell(i3,j3)
                i4 = i1 + di(toc)
                j4 = j1 + dj(toc) 
                if(i4 == i .AND. j4 == j) then
                   call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                end if
             end if
          case(5)  ! west
             i = is2_send(p,n)  ! is2_send(p,n) == ie2_send(p,n)
             i1 = i + 1
             do j = js2_send(p,n), je2_send(p,n)
                do l = -1,1
                   j1 = j + l
                   if(j1<jsl(pe) .OR. j1 > jel(pe) ) cycle
                   select case(rot_send(p,n))
                   case (ZERO) ! e->w
                      i2 = is1_send(p,n)
                      i3 = i2 + 1
                      j2 = js1_send(p,n) + j  - js2_send(p,n)
                      j3 = js1_send(p,n) + j1 - js2_send(p,n)
                   case (NINETY) ! n->w
                      i2 = is1_send(p,n) + (je2_send(p,n) - j )
                      i3 = is1_send(p,n) + (je2_send(p,n) - j1)
                      j2 = js1_send(p,n)
                      j3 = j2 + 1
                   end select
                   if(River%travel(i3,j3) >0) then
                      toc = tocell(i3,j3)
                      i4 = i1 + di(toc)
                      j4 = j1 + dj(toc) 
                      if(i4 == i .AND. j4 == j) then
                         call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                      end if
                   end if
                end do
             end do
          case(6)  ! north west
             i = is2_send(p,n)  ! is2_send(p,n) == ie2_send(p,n)
             j = js2_send(p,n)  ! js2_send(p,n) == je2_send(p,n)
             i1 = i + 1
             j1 = j - 1
             i2 = is1_send(p,n)  ! is1_send(p,n) == ie1_send(p,n)
             j2 = js1_send(p,n)  ! js1_send(p,n) == je1_send(p,n)
             select case(rot_send(p,n))
             case (ZERO) ! se->nw 
                i3 = i2 + 1
                j3 = j2 - 1
             case (NINETY) !  
                i3 = i2 + 1
                j3 = j2 + 1
             case (MINUS_NINETY)
                i3 = i2 - 1
                j3 = j2 - 1
             end select  
             if(River%travel(i3,j3) >0) then
                toc = tocell(i3,j3)
                i4 = i1 + di(toc)
                j4 = j1 + dj(toc) 
                if(i4 == i .AND. j4 == j) then
                   call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                end if
             end if
          case(7)  ! north
             j = js2_send(p,n)  ! js2_send(p,n) == je2_send(p,n)
             j1 = j - 1
             do i = is2_send(p,n), ie2_send(p,n)
                do l = -1,1
                   i1 = i + l
                   if(i1<isl(pe) .OR. i1 > iel(pe)) cycle
                   select case(rot_send(p,n))
                   case (ZERO) ! s->n
                      i2 = is1_send(p,n) + i  - is2_send(p,n)
                      i3 = is1_send(p,n) + i1 - is2_send(p,n)
                      j2 = js1_send(p,n)
                      j3 = j2 - 1
                   case (MINUS_NINETY) ! w->n
                      i2 = is1_send(p,n)
                      i3 = i2 - 1
                      j2 = js1_send(p,n) + (ie2_send(p,n) - i )
                      j3 = js1_send(p,n) + (ie2_send(p,n) - i1)
                   end select
                   if(River%travel(i3,j3) >0) then
                      toc = tocell(i3,j3)
                      i4 = i1 + di(toc)
                      j4 = j1 + dj(toc) 
                      if(i4 == i .AND. j4 == j) then
                         call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                      end if
                   end if
                end do
             end do
          case(8)  ! north east
             i = is2_send(p,n)  ! is2_send(p,n) == ie2_send(p,n)
             j = js2_send(p,n)  ! js2_send(p,n) == je2_send(p,n)
             i1 = i - 1
             j1 = j - 1
             i2 = is1_send(p,n)  ! is1_send(p,n) == ie1_send(p,n)
             j2 = js1_send(p,n)  ! js1_send(p,n) == je1_send(p,n)
             select case(rot_send(p,n))
             case (ZERO) ! sw->ne 
                i3 = i2 - 1
                j3 = j2 - 1
             case (NINETY) !  
                i3 = i2 + 1
                j3 = j2 - 1
             case (MINUS_NINETY)
                i3 = i2 - 1
                j3 = j2 + 1
             end select  
             if(River%travel(i3,j3) >0) then
                toc = tocell(i3,j3)
                i4 = i1 + di(toc)
                j4 = j1 + dj(toc) 
                if(i4 == i .AND. j4 == j) then
                   call add_single_overlap(halo_update(River%travel(i3,j3))%recv(p+roff), i2, j2)
                end if
             end if
          end select
       end do       
    enddo

    do p = 1, nrecv
       !--- configure points need to send to other pe.
       !--- (i,j) ---  index on my data domain
       !--- (i1,j1) --- index on my compute domain corresponding to (i,j)
       !--- (i2,j2) --- index of (i1,j1) tocell
       do n = 1, recv_count(p)
          select case ( dir_recv(p,n) )
          case(1)  ! east
             i = is_recv(p,n)  ! is_recv(p,n) == ie_recv(p,n)
             i1 = i - 1
             do j = js_recv(p,n), je_recv(p,n)
                do l = -1,1
                   j1 = j + l
                   if(j1<jsc .OR. j1 > jec .OR. River%travel(i1,j1) < 1) cycle
                   i2 = i1 + di(tocell(i1,j1))
                   j2 = j1 + dj(tocell(i1,j1)) 
                   if(i2 == i .AND. j2 == j) then
                      call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                   end if
                end do
             end do
          case(2)  ! south east
             i = is_recv(p,n)  ! is_recv(p,n) == ie_recv(p,n)
             j = js_recv(p,n)  ! js_recv(p,n) == je_recv(p,n)
             i1 = i - 1
             j1 = j + 1
             if(River%travel(i1,j1) > 0) then
                i2 = i1 + di(tocell(i1,j1))
                j2 = j1 + dj(tocell(i1,j1)) 
                if(i2 == i .AND. j2 == j) then
                   call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                end if
             end if
          case(3)  ! south
             j = js_recv(p,n)  ! js_recv(p,n) == je_recv(p,n)
             j1 = j + 1
             do i = is_recv(p,n), ie_recv(p,n)
                do l = -1,1
                   i1 = i + l
                   if(i1<isc .OR. i1 > iec .OR. River%travel(i1,j1) < 1) cycle
                   i2 = i1 + di(tocell(i1,j1))
                   j2 = j1 + dj(tocell(i1,j1)) 
                   if(i2 == i .AND. j2 == j) then
                      call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                   end if
                end do
             end do
          case(4)  ! south west
             i = is_recv(p,n)  ! is_recv(p,n) == ie_recv(p,n)
             j = js_recv(p,n)  ! js_recv(p,n) == je_recv(p,n)
             i1 = i + 1
             j1 = j + 1
             if( River%travel(i1,j1) > 0) then
                i2 = i1 + di(tocell(i1,j1))
                j2 = j1 + dj(tocell(i1,j1)) 
                if(i2 == i .AND. j2 == j) then
                   call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                end if
             end if
          case(5)  ! west
             i = is_recv(p,n)  ! is_recv(p,n) == ie_recv(p,n)
             i1 = i + 1
             do j = js_recv(p,n), je_recv(p,n)
                do l = -1,1
                   j1 = j + l
                   if(j1<jsc .OR. j1 > jec .OR. River%travel(i1,j1) < 1) cycle
                   i2 = i1 + di(tocell(i1,j1))
                   j2 = j1 + dj(tocell(i1,j1)) 
                   if(i2 == i .AND. j2 == j) then
                      call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                   end if
                end do
             end do
          case(6)  ! north west
             i = is_recv(p,n)  ! is_recv(p,n) == ie_recv(p,n)
             j = js_recv(p,n)  ! js_recv(p,n) == je_recv(p,n)
             i1 = i + 1
             j1 = j - 1
             if( River%travel(i1,j1) > 0) then
                i2 = i1 + di(tocell(i1,j1))
                j2 = j1 + dj(tocell(i1,j1)) 
                if(i2 == i .AND. j2 == j) then
                   call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                end if
             end if
          case(7)  ! north
             j = js_recv(p,n)  ! js_recv(p,n) == je_recv(p,n)
             j1 = j - 1
             do i = is_recv(p,n), ie_recv(p,n)
                do l = -1,1
                   i1 = i + l
                   if(i1<isc .OR. i1 > iec .OR. River%travel(i1,j1) < 1) cycle
                   i2 = i1 + di(tocell(i1,j1))
                   j2 = j1 + dj(tocell(i1,j1)) 
                   if(i2 == i .AND. j2 == j) then
                      call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                   end if
                end do
             end do
          case(8)  ! north east
             i = is_recv(p,n)  ! is_recv(p,n) == ie_recv(p,n)
             j = js_recv(p,n)  ! js_recv(p,n) == je_recv(p,n)
             i1 = i - 1
             j1 = j - 1
             if( River%travel(i1,j1) > 0) then
                i2 = i1 + di(tocell(i1,j1))
                j2 = j1 + dj(tocell(i1,j1)) 
                if(i2 == i .AND. j2 == j) then
                   call add_single_overlap(halo_update(River%travel(i1,j1))%send(p+soff), i1, j1)
                end if
             end if
          end select
       end do       
    end do

    allocate(in_domain(isc:iec,jsc:jec))
    in_domain = .true.
    do j = jsc, jec
       do i = isc, iec
          if(River%tocell(i,j) > 0) then
             i_dest = i + di(River%tocell(i,j))
             j_dest = j + dj(River%tocell(i,j))
             if(i_dest < isc .OR. i_dest > iec .OR. j_dest < jsc .OR. j_dest > jec) then 
                LOOP_TRAVEL: do travelnow = 1, maxtravel
                   do p = 1, nrecv
                      send => halo_update(travelnow)%send(p+soff)
                      do n = 1, send%count
                         if(send%i(n) == i .AND. send%j(n) == j) then
                            in_domain(i,j) = .false.
                            exit LOOP_TRAVEL 
                         end if
                      end do
                   end do
                end do LOOP_TRAVEL
                if(in_domain(i,j)) then
                   i_dest = i
                   j_dest = j
                end if
             end if
             River%i_tocell(i,j) = i_dest
             River%j_tocell(i,j) = j_dest
          end if
       end do
    end do

    !--- add points that sent to self.
    do j = jsc, jec
       do i = isc, iec
          m = River%travel(i,j)
          if(m >0 .and. in_domain(i,j) ) then
             call add_single_overlap(halo_update(m)%send(my_send_index), i, j)
             call add_single_overlap(halo_update(m)%recv(my_recv_index), River%i_tocell(i, j), River%j_tocell(i, j))
          end if
       end do
    end do

    !--- the following is for the purpose of bitwise reproduce between processor count
    if(nrecv_update>0) allocate(recv_size2(nrecv_update))
    do p=1, nrecv_update
       call mpp_recv(recv_size2(p), glen = 1, from_pe = recv_pelist(p), block=.FALSE. )
    enddo

    do p= 1, nsend_update
       msgsize = 0
       do m = 1, maxtravel
          msgsize = msgsize + 2*halo_update(m)%send(p)%count
       enddo
       call mpp_send(msgsize, plen = 1, to_pe = send_pelist(p))
    enddo

    call mpp_sync_self(check=EVENT_RECV)
    do p=1, nrecv_update 
       recv_size = 0   
       do m = 1, maxtravel
          recv_size = recv_size + halo_update(m)%recv(p)%count
       end do
       recv_size = recv_size*2
       if(recv_size2(p) .NE. recv_size) then
          print*, "At pe = ", mpp_pe()," p = ", p, " from_pe = ", recv_pelist(p), ", send_size = ", recv_size2(p), "recv_size = ", recv_size
          call mpp_error(FATAL, "river_physics_mod: mismatch at send size and recv size")
       endif
    enddo
    call mpp_sync_self()

    total_size = 0
    do p = 1, nrecv_update
       total_size = total_size + recv_size2(p)
    enddo

    if(total_size >0) allocate(recv_buffer(total_size))
    pos = 0
    do p=1, nrecv_update
       if(recv_size2(p) >0) then
          call mpp_recv(recv_buffer(pos+1), glen = recv_size2(p), from_pe = recv_pelist(p), block=.FALSE. )
          pos = pos + recv_size2(p)
       endif
    enddo

    send_size = 0
    do p = 1, nsend_update
       do m = 1, maxtravel
          send_size = send_size + halo_update(m)%send(p)%count
       end do
    end do
    send_size = send_size*2
    if(send_size>0) allocate(send_buffer(send_size))
    pos = 0
    do p= 1, nsend_update
       buffer_pos = pos
       do m = 1, maxtravel
          do n = 1, halo_update(m)%send(p)%count
             send_buffer(pos+1) = halo_update(m)%send(p)%i(n)
             send_buffer(pos+2) = halo_update(m)%send(p)%j(n)
             pos = pos + 2
          end do
       end do
       msgsize = pos - buffer_pos
       if(msgsize >0) then
          call mpp_send(send_buffer(buffer_pos+1), plen = msgsize, to_pe = send_pelist(p))
       end if      
    end do

    call mpp_sync_self(check=EVENT_RECV)

    !--- unpack buffer
    allocate(i_send(isc:iec,jsc:jec,8), j_send(isc:iec,jsc:jec,8) )
    allocate(p_send(isc:iec,jsc:jec,8), t_send(isc:iec,jsc:jec,8) )
    allocate(n_send(isc:iec,jsc:jec,8), nlev(isc:iec,jsc:jec))
    nlev = 0
    pos = 0
    do p=1, nrecv_update
       if(recv_size2(p) >0) then
          do m = 1, maxtravel
             do n = 1, halo_update(m)%recv(p)%count
                i = halo_update(m)%recv(p)%i(n)
                j = halo_update(m)%recv(p)%j(n)
                i1 = recv_buffer(pos+1)
                j1 = recv_buffer(pos+2)
                pos = pos + 2
                do k = 1, nlev(i,j)
                   if( j1 < j_send(i,j,k) .OR. (j1 == j_send(i,j,k) .AND. i1 < i_send(i,j,k) ) ) then
                      do kk = nlev(i,j)+1, k+1, -1
                         i_send(i,j,kk) = i_send(i,j,kk-1)
                         j_send(i,j,kk) = j_send(i,j,kk-1)
                         p_send(i,j,kk) = p_send(i,j,kk-1)
                         t_send(i,j,kk) = t_send(i,j,kk-1)
                         n_send(i,j,kk) = n_send(i,j,kk-1)
                         halo_update(t_send(i,j,kk))%recv(p_send(i,j,kk))%k(n_send(i,j,kk)) = &
                             halo_update(t_send(i,j,kk))%recv(p_send(i,j,kk))%k(n_send(i,j,kk)) + 1
                      end do
                      exit
                   end if
                end do
                nlev(i,j) = nlev(i,j) + 1
                i_send(i,j,k) = i1
                j_send(i,j,k) = j1
                p_send(i,j,k) = p
                t_send(i,j,k) = m
                n_send(i,j,k) = n         
                halo_update(m)%recv(p)%k(n) = k               
             end do
          end do
       end if
    end do

    call mpp_sync_self()    
    if(allocated(send_buffer)) deallocate(send_buffer)
    if(allocated(recv_buffer)) deallocate(recv_buffer)
    if(allocated(recv_size2 )) deallocate(recv_size2 )

    !--- set up buffer for send and recv.
    send_size = 0
    do m = 1, maxtravel
       siz = 0
       do p = 1, nsend_update
          siz = siz + halo_update(m)%send(p)%count
       end do
       send_size = max(send_size, siz)
    end do
    send_size = send_size*(num_species+1)
    if(send_size > 0) allocate(send_buffer(send_size))

    recv_size = 0
    do m = 1, maxtravel
       siz = 0
       do p = 1, nrecv_update
          siz = siz + halo_update(m)%recv(p)%count
       end do
       recv_size = max(recv_size, siz)
    end do
    recv_size = recv_size*(num_species+1)
    if(recv_size > 0) allocate(recv_buffer(recv_size))

    deallocate(tocell)
    deallocate(isl, iel, jsl, jel )
    deallocate(sbuf, rbuf)
    deallocate(is_recv, ie_recv, js_recv, je_recv)
    deallocate(is1_send, ie1_send, js1_send, je1_send)
    deallocate(is2_send, ie2_send, js2_send, je2_send)
    deallocate(rot_send, rot_recv, send_count, recv_count)
    if(ALLOCATED(pelist_r)) deallocate(pelist_r)
    if(ALLOCATED(pelist_s)) deallocate(pelist_s)
    if(ALLOCATED(send_pelist)) deallocate(send_pelist)
    if(ALLOCATED(recv_pelist)) deallocate(recv_pelist)
    return

  end subroutine setup_halo_update

!###############################################################################
  subroutine do_halo_update(River, update)
     type(river_type),    intent(inout) :: River
     type(halo_update_type), intent(in) :: update
     type(comm_type), pointer           :: send=>NULL()
     type(comm_type), pointer           :: recv=>NULL()
     integer                            :: buffer_pos, pos, recv_buffer_pos
     integer                            :: p, n, i, j, count, l, k
     real                               :: wrk_c(isc:iec,jsc:jec,num_species, 8)
     real                               :: wrk  (isc:iec,jsc:jec, 8)

     !--- pre-post recv data
     pos = 0
     do p = 1, nrecv_update
        recv => update%recv(p)
        count = recv%count
        if(count == 0) cycle
        call mpp_recv(recv_buffer(pos+1), glen=count*(num_species+1), from_pe=recv%pe, block=.FALSE. ) 
        pos = pos + count*(num_species+1)
     enddo
     recv_buffer_pos = pos

     !--- send the data
     pos = 0
     do p = 1, nsend_update
        send => update%send(p)
        count = send%count
        if(count == 0) cycle
        buffer_pos = pos
        do n = 1, count
           i = send%i(n)
           j = send%j(n)
           pos = pos + 1
           send_buffer(pos)   = River%outflow(i,j)
           do l = 1, num_species
              pos = pos + 1
              send_buffer(pos) = River%outflow_c(i,j,l)
           end do
        end do
        call mpp_send(send_buffer(buffer_pos+1), plen=count*(num_species+1), to_pe = send%pe ) 
     end do

     call mpp_sync_self(check=EVENT_RECV)

     !--- update the buffer in reverse order
     nlev = 0
     pos = recv_buffer_pos
     do p = nrecv_update, 1, -1
        recv => update%recv(p)
        count = recv%count
        if(count == 0) cycle
        pos = recv_buffer_pos - count*(num_species+1)
        recv_buffer_pos = pos
        do n = 1, count
           i = recv%i(n)
           j = recv%j(n)
           k = recv%k(n)
           pos = pos + 1
           wrk(i,j,k) = recv_buffer(pos)
           nlev(i,j) = nlev(i,j)+1
           do l = 1, num_species
              pos = pos + 1
              wrk_c(i,j,l,k) = recv_buffer(pos)
           end do
        end do
     enddo

     do j = jsc, jec
        do i = isc, iec
           do k = 1, nlev(i,j)
              River%inflow(i,j)   = River%inflow(i,j) + wrk(i,j,k)
              River%inflow_c(i,j,:) = River%inflow_c(i,j,:) + wrk_c(i,j,:,k)
           end do
        end do
     end do

     call mpp_sync_self()


     return

  end subroutine do_halo_update


!###############################################################################
!  This routine will add one point for send/recv into the data type, allocate 
!  memory or expand memory if needed 

  subroutine add_single_overlap(comm, i, j)
    type(comm_type), intent(inout) :: comm
    integer,         intent(in)    :: i, j
    integer, parameter             :: DEFAULT_SIZE = 40 ! too big or too small
    integer                        :: count, maxcount
    integer, allocatable           :: tmp(:)

    count = comm%count 
    count = count + 1
    if(count == 1) then ! assign default space to hold index
       allocate(comm%i(DEFAULT_SIZE))
       allocate(comm%j(DEFAULT_SIZE))
       allocate(comm%k(DEFAULT_SIZE))
    end if
    maxcount = size(comm%i)

    if(count > maxcount) then ! need to expend the size to hold the index
       allocate(tmp(maxcount))
       tmp = comm%i
       deallocate(comm%i)
       allocate(comm%i(2*maxcount))
       comm%i(1:maxcount) = tmp
       tmp = comm%j
       deallocate(comm%j)
       allocate(comm%j(2*maxcount))
       comm%j(1:maxcount) = tmp
       deallocate(tmp)
       deallocate(comm%k)
       allocate(comm%k(2*maxcount))
    end if
    comm%i(count) = i
    comm%j(count) = j    
    comm%k(count) = 0
    comm%count    = count

    return    

  end subroutine add_single_overlap

!#####################################################################

end module river_physics_mod


module river_type_mod
!-----------------------------------------------------------------------
!                   GNU General Public License                        
!                                                                      
! This program is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
! <CONTACT EMAIL="klf@@gfdl.noaa.gov"> Kirsten Findell </CONTACT> 
! <CONTACT EMAIL="z1l@@gfdl.noaa.gov"> Zhi Liang </CONTACT> 

  use time_manager_mod, only : time_type

  implicit none
  private

!--- version information ---------------------------------------------
  character(len=128) :: version = '$Id: river_type.F90,v 18.0 2010/03/02 23:37:04 fms Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!--- public interface ------------------------------------------------
  public :: river_type, Leo_Mad_trios

!--- public data type ------------------------------------------------

  type river_type
     real, dimension(:),        pointer :: lon_1d        => NULL()  ! in degree
     real, dimension(:),        pointer :: lat_1d        => NULL()  ! in degree
     real, dimension(:,:),      pointer :: lon           => NULL()  ! in radians
     real, dimension(:,:),      pointer :: lat           => NULL()  ! in radians
     real, dimension(:,:),      pointer :: reach_length  => NULL()
     real, dimension(:,:),      pointer :: landfrac      => NULL()
     logical, dimension(:,:),   pointer :: mask          => NULL()
     real, dimension(:,:),      pointer :: land_area     => NULL()
     integer, dimension(:,:),   pointer :: basinid       => NULL() 
     integer, dimension(:,:),   pointer :: tocell        => NULL()
     integer, dimension(:,:),   pointer :: travel        => NULL()
     integer, dimension(:,:),   pointer :: i_tocell      => NULL()
     integer, dimension(:,:),   pointer :: j_tocell      => NULL()
     real, dimension(:,:),      pointer :: storage       => NULL()     
     real, dimension(:,:),      pointer :: stordis       => NULL()     
     real, dimension(:,:),      pointer :: run_stor      => NULL()  ! runoff storage
     real, dimension(:,:,:),    pointer :: storage_c     => NULL()     
     real, dimension(:,:,:),    pointer :: stordis_c     => NULL()     
     real, dimension(:,:,:),    pointer :: run_stor_c    => NULL()  ! tracer runoff storage
     real, dimension(:,:),      pointer :: inflow        => NULL()
     real, dimension(:,:,:),    pointer :: inflow_c      => NULL()
     real, dimension(:,:),      pointer :: infloc        => NULL()
     real, dimension(:,:,:),    pointer :: infloc_c      => NULL()
     real, dimension(:,:),      pointer :: outflow       => NULL()
     real, dimension(:,:,:),    pointer :: outflow_c     => NULL()
     real, dimension(:,:),      pointer :: lake_outflow   => NULL()
     real, dimension(:,:,:),    pointer :: lake_outflow_c => NULL()
     real, dimension(:,:),      pointer :: disw2o        => NULL()
     real, dimension(:,:),      pointer :: disw2l        => NULL()
     real, dimension(:,:,:),    pointer :: disc2o        => NULL()
     real, dimension(:,:,:),    pointer :: disc2l        => NULL()
     real, dimension(:,:),      pointer :: melt          => NULL()
     real, dimension(:,:,:),    pointer :: removal_c     => NULL()
     real, dimension(:,:),      pointer :: outflowmean   => NULL()
     real, dimension(:,:),      pointer :: o_coef        => NULL()
     real, dimension(:,:),      pointer :: d_coef        => NULL()
     real, dimension(:,:),      pointer :: w_coef        => NULL()
     real, dimension(:,:,:),    pointer :: source_conc   => NULL()
     real, dimension(:,:,:),    pointer :: source_flux   => NULL()
     real, dimension(:,:),      pointer :: So            => NULL()
     real, dimension(:,:),      pointer :: depth         => NULL()
     real, dimension(:,:),      pointer :: width         => NULL()
     real, dimension(:,:),      pointer :: vel           => NULL()
     real, dimension(:),        pointer :: t_ref         => NULL()
     real, dimension(:),        pointer :: vf_ref        => NULL()
     real, dimension(:),        pointer :: q10           => NULL()
     real, dimension(:),        pointer :: kinv          => NULL()
     real                               :: o_exp
     real                               :: d_exp
     real                               :: w_exp
     real                               :: channel_tau
     type (time_type)                   :: Time
     integer                            :: dt_fast, dt_slow
     integer                            :: nlon, nlat, num_species, num_c
     integer                            :: num_phys
     logical                            :: do_age
  end type river_type

  type Leo_Mad_trios
     real :: on_V, on_d, on_w
  end type Leo_Mad_trios


end module river_type_mod


module land_debug_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only: &
     error_mesg, file_exist, check_nml_error, stdlog, &
     write_version_number, close_file, mpp_pe, mpp_npes, mpp_root_pe, FATAL, NOTE
use time_manager_mod, only : &
     get_date
use grid_mod, only: &
     get_grid_ntiles
use land_data_mod, only : &
     lnd

implicit none
private

! ==== public interfaces =====================================================
public :: land_debug_init
public :: land_debug_end

public :: set_current_point
public :: get_current_point
public :: current_i, current_j, current_k, current_face
public :: is_watch_point
public :: get_watch_point

public :: check_temp_range
! ==== module constants ======================================================
character(len=*), parameter, private   :: &
    module_name = 'land_debug',&
    version     = '$Id: land_debug.F90,v 17.0.6.1 2010/08/24 12:11:35 pjp Exp $',&
    tagname     = '$Name: hiram_20101115_bw $'

! ==== module variables ======================================================
integer :: current_debug_level = 0
integer :: mosaic_tile = 0
integer :: curr_i, curr_j, curr_k

!---- namelist ---------------------------------------------------------------
integer :: watch_point(4)=(/0,0,0,1/) ! coordinates of the point of interest, i,j,tile,mosaic_tile
real    :: temp_lo = 120.0 ! lower limit of "reasonable" temperature range, deg K
real    :: temp_hi = 373.0 ! upper limit of "reasonable" temperature range, deg K
namelist/land_debug_nml/ watch_point, temp_lo, temp_hi


contains

! ============================================================================
subroutine land_debug_init()
  ! ---- local vars
  integer :: unit, ierr, io, ntiles

  call write_version_number(version, tagname)
  
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=land_debug_nml, iostat=io)
  ierr = check_nml_error(io, 'land_debug_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=land_debug_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'land_debug_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=land_debug_nml)
  endif
  ! set number of our mosaic tile 
  call get_grid_ntiles('LND',ntiles)
  mosaic_tile = ntiles*mpp_pe()/mpp_npes() + 1  ! assumption

end subroutine land_debug_init

! ============================================================================
subroutine land_debug_end()
end subroutine

! ============================================================================
subroutine set_current_point(i,j,k)
  integer, intent(in) :: i,j,k

  curr_i = i ; curr_j = j ; curr_k = k

  current_debug_level = 0
  if ( watch_point(1)==i.and. &
       watch_point(2)==j.and. &
       watch_point(3)==k.and. &
       watch_point(4)==mosaic_tile) then
     current_debug_level = 1
  endif
end subroutine set_current_point

! ============================================================================
subroutine get_current_point(i,j,k,face)
  integer, intent(out), optional :: i,j,k,face
  if (present(i)) i = curr_i
  if (present(j)) j = curr_j
  if (present(k)) k = curr_k
  if (present(face)) face = mosaic_tile
end subroutine get_current_point

! ============================================================================
integer function current_i() ; current_i = curr_i ; end function
integer function current_j() ; current_j = curr_j ; end function
integer function current_k() ; current_k = curr_k ; end function
integer function current_face() ; current_face = mosaic_tile ; end function

! ============================================================================
function is_watch_point()
  logical :: is_watch_point
  is_watch_point = (current_debug_level > 0)
end function is_watch_point

! ============================================================================
subroutine get_watch_point(i,j,k,face)
  integer, intent(out), optional :: i,j,k,face
  if (present(i)) i = watch_point(1)
  if (present(j)) j = watch_point(2)
  if (present(k)) k = watch_point(3)
  if (present(face)) face = watch_point(4)
end subroutine get_watch_point

! ============================================================================
! checks if the temperature within reasonable range, and prints a message
! if it isn't
subroutine check_temp_range(temp, tag, varname)
  real, intent(in) :: temp ! temperature to check
  character(*), intent(in) :: tag ! tag to print
  character(*), intent(in) :: varname ! name of the variable for printout

  ! ---- local vars
  integer :: y,mo,d,h,m,s ! components of date

  if(temp_lo<temp.and.temp<temp_hi) then
     return
  else
     call get_date(lnd%time,y,mo,d,h,m,s)
     write(*,'(a," : ",a,g,4(x,a,i4),x,a,i4.4,2("-",i2.2),x,i2.2,2(":",i2.2))')&
          trim(tag), trim(varname)//' out of range: value=', &
         temp,'at i=',curr_i,'j=',curr_j,'tile=',curr_k,'face=',mosaic_tile, &
         'time=',y,mo,d,h,m,s
  endif
end subroutine 


end module land_debug_mod


module land_io_mod

use constants_mod,     only : PI
use fms_mod,           only : file_exist, error_mesg, FATAL, stdlog, mpp_pe, &
     mpp_root_pe, write_version_number, string

use horiz_interp_mod,  only : horiz_interp_type, &
     horiz_interp_new, horiz_interp_del, &
     horiz_interp

use land_numerics_mod, only : nearest, bisect
use nf_utils_mod,      only : nfu_validtype, nfu_get_dim, nfu_get_dim_bounds, &
     nfu_get_valid_range, nfu_is_valid, nfu_inq_var, nfu_get_var

implicit none
private

! ==== public interface ======================================================
public :: init_cover_field
public :: read_field

public :: print_netcdf_error
! ==== end of public interface ===============================================

interface read_field
   module procedure read_field_N_2D, read_field_N_3D
   module procedure read_field_I_2D, read_field_I_3D
end interface

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),__FILE__,__LINE__)

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'land_io_mod', &
     version     = '$Id: land_io.F90,v 17.0.2.5.4.1 2011/12/12 19:30:45 Peter.Phillipps Exp $', &
     tagname     = '$Name:  $'

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ============================================================================
! This procedure creates and initializes a field of fractional coverage.
subroutine init_cover_field( &
     cover_to_use, filename, cover_field_name, frac_field_name, &
     lonb, latb, uniform_cover, input_cover_types, frac)
  character(len=*), intent(in) :: cover_to_use
  character(len=*), intent(in) :: filename
  character(len=*), intent(in) :: cover_field_name, frac_field_name
  real            , intent(in) :: lonb(:,:), latb(:,:) ! boundaries of the grid cells
  integer         , intent(in) :: uniform_cover
  integer         , intent(in) :: input_cover_types(:)
  real            , intent(out):: frac(:,:,:) ! output-global map of soil fractional coverage

  ! ---- local vars ---------------------------------------------------------
  integer :: i,j,k     ! iterators
  integer :: cover_id
  real    :: maxfrac, total

  frac = 0
  
  if (cover_to_use == 'multi-tile') then
     call read_cover_field(filename,cover_field_name,frac_field_name,lonb,latb,input_cover_types,frac)
  else if (cover_to_use=='single-tile') then
     call read_cover_field(filename,cover_field_name,frac_field_name,lonb,latb,input_cover_types,frac)
     do j = 1,size(frac,2)
     do i = 1,size(frac,1)
        total = sum(frac(i,j,:))
        if (total <= 0) cycle ! operate on valid input data points only
        maxfrac=0 ; cover_id=1
        do k = 1,size(frac,3)
           if(frac(i,j,k).gt.maxfrac) then
              maxfrac=frac(i,j,k)
              cover_id=k
           endif
        enddo
        ! set all fractions except dominant fraction to zero
        frac(i,j,:) = 0.0
        frac(i,j,cover_id) = total
     enddo
     enddo
  else if (cover_to_use == 'uniform') then
     call read_cover_field(filename,cover_field_name,frac_field_name,lonb,latb,input_cover_types,frac)
     do j = 1,size(frac,2)
     do i = 1,size(frac,1)
        total = sum(frac(i,j,:))
        if (total <= 0) cycle ! operate on valid input data points only
        ! set all fractions except dominant fraction to zero
        frac(i,j,:) = 0.0
        frac(i,j,uniform_cover) = total
     enddo
     enddo
  else
     call error_mesg ( module_name,'illegal value of cover_to_use '//cover_to_use, FATAL )
  endif

end subroutine init_cover_field


! ============================================================================
subroutine read_cover_field(file, cover_field_name, frac_field_name,&
     lonb, latb, input_cover_types, frac)
  character(len=*)  , intent(in)  :: file            ! file to read from
  character(len=*)  , intent(in)  :: cover_field_name, frac_field_name
  real              , intent(in)  :: lonb(:,:),latb(:,:) ! boundaries of the model grid
  real              , intent(out) :: frac(:,:,:)     ! resulting fractions
  integer, optional , intent(in)  :: input_cover_types(:)

  ! --- local vars
  integer :: ncid, varid

  if (.not.file_exist(file)) &
       call error_mesg(module_name,'input file "'//trim(file)//'" does not exist',FATAL)

  __NF_ASRT__( nf_open(file, NF_NOWRITE, ncid) )
  if(nf_inq_varid(ncid,cover_field_name,varid)==NF_NOERR) then
     call do_read_cover_field(ncid,varid,lonb,latb,input_cover_types,frac)
  else if ( nf_inq_varid(ncid,frac_field_name,varid)==NF_NOERR) then
     call do_read_fraction_field(ncid,varid,lonb,latb,input_cover_types,frac)
  else
     call error_mesg(module_name,&
          'neither "'//trim(cover_field_name)//'" nor "'//&
          frac_field_name//'" is present in input file "'//trim(file)//'"' ,&
          FATAL)
  endif
  __NF_ASRT__( nf_close(ncid) )

end subroutine read_cover_field

! ============================================================================
subroutine do_read_cover_field(ncid,varid,lonb,latb,input_cover_types,frac)
  integer, intent(in)  :: ncid, varid
  real   , intent(in)  :: lonb(:,:),latb(:,:)
  integer, intent(in)  :: input_cover_types(:)
  real   , intent(out) :: frac(:,:,:)

  ! ---- local vars
  integer :: nlon, nlat ! size of input map
  integer :: k
  integer, allocatable :: in_cover(:,:)
  real, allocatable    :: in_lonb(:), in_latb(:), x(:,:)
  type(horiz_interp_type) :: interp
  integer :: vardims(NF_MAX_VAR_DIMS)
  type(nfu_validtype) :: v
  integer :: in_j_start, in_j_count ! limits of the latitude belt we read
  integer :: iret ! result of netcdf calls

  ! find out dimensions, etc
  __NF_ASRT__( nf_inq_vardimid(ncid,varid,vardims) )
  ! get size of the longitude and latitude axes
  __NF_ASRT__( nf_inq_dimlen(ncid, vardims(1), nlon) )
  __NF_ASRT__( nf_inq_dimlen(ncid, vardims(2), nlat) )
  allocate ( in_lonb (nlon+1), in_latb (nlat+1) )
  __NF_ASRT__( nfu_get_dim_bounds(ncid, vardims(1), in_lonb) )
  __NF_ASRT__( nfu_get_dim_bounds(ncid, vardims(2), in_latb) )
  in_lonb = in_lonb*PI/180.0; in_latb = in_latb*PI/180.0

  ! to minimize the i/o and work done by horiz_interp, find the boundaries
  ! of latitude belt in input data that covers the entire latb array
  in_j_start=bisect(in_latb, minval(latb))
  in_j_count=bisect(in_latb, maxval(latb))-in_j_start+1

  ! check for unreasonable values
  if (in_j_start<1) &
     call error_mesg('do_read_cover_field','input latitude start index ('&
                     //string(in_j_start)//') is out of bounds', FATAL)
  if (in_j_start+in_j_count-1>nlat) &
     call error_mesg('do_read_cover_field','input latitude count ('&
                     //string(in_j_count)//') is too large (start index='&
                     //string(in_j_start)//')', FATAL)

  ! allocate input data buffers
  allocate ( x(nlon,in_j_count), in_cover(nlon,in_j_count) )

  ! read input data
  iret = nf_get_vara_int(ncid,varid, &
                    (/1,in_j_start/), (/nlon,in_j_count/), in_cover)
  __NF_ASRT__( iret )
  __NF_ASRT__( nfu_get_valid_range(ncid,varid,v) )

  call horiz_interp_new(interp, in_lonb,in_latb(in_j_start:in_j_start+in_j_count), &
       lonb,latb, interp_method='conservative')
  frac=0
  do k = 1,size(input_cover_types(:))
     x=0
     where(nfu_is_valid(in_cover,v).and.in_cover==input_cover_types(k)) x = 1

     call horiz_interp(interp,x,frac(:,:,k))
  enddo

  call horiz_interp_del(interp)

  ! clean up memory
  deallocate(in_lonb, in_latb, in_cover, x)

end subroutine do_read_cover_field


! ============================================================================
subroutine do_read_fraction_field(ncid,varid,lonb,latb,input_cover_types,frac)
  integer, intent(in)  :: ncid, varid
  real   , intent(in)  :: lonb(:,:),latb(:,:)
  integer, intent(in)  :: input_cover_types(:)
  real   , intent(out) :: frac(:,:,:)

  ! ---- local vars
  integer :: nlon, nlat, ntypes, k, cover
  real, allocatable :: in_frac(:,:,:)
  real, allocatable :: in_lonb(:), in_latb(:)
  real, allocatable :: in_mask(:,:)
  type(horiz_interp_type) :: interp
  type(nfu_validtype) :: v
  integer :: vardims(NF_MAX_VAR_DIMS)
  integer :: in_j_start, in_j_count ! limits of the latitude belt we read
  integer :: iret ! result of netcdf calls

  ! find out dimensions, etc
  __NF_ASRT__( nf_inq_vardimid(ncid,varid,vardims) )
  ! get size of the longitude and latitude axes
  __NF_ASRT__( nf_inq_dimlen(ncid, vardims(1), nlon) )
  __NF_ASRT__( nf_inq_dimlen(ncid, vardims(2), nlat) )
  __NF_ASRT__( nf_inq_dimlen(ncid, vardims(3), ntypes))
  allocate ( in_lonb(nlon+1), in_latb(nlat+1) )
  __NF_ASRT__(nfu_get_dim_bounds(ncid, vardims(1), in_lonb))
  __NF_ASRT__(nfu_get_dim_bounds(ncid, vardims(2), in_latb))
  in_lonb = in_lonb*PI/180.0; in_latb = in_latb*PI/180.0

  ! find the boundaries of latitude belt in input data that covers the 
  ! entire latb array
  in_j_start=bisect(in_latb, minval(latb))
  in_j_count=bisect(in_latb, maxval(latb))-in_j_start+1

  ! check for unreasonable values
  if (in_j_start<1) &
     call error_mesg('do_read_fraction_field','input latitude start index ('&
                     //string(in_j_start)//') is out of bounds', FATAL)
  if (in_j_start+in_j_count-1>nlat) &
     call error_mesg('do_read_fraction_field','input latitude count ('&
                     //string(in_j_count)//') is too large (start index='&
                     //string(in_j_start)//')', FATAL)

  allocate( in_mask(nlon,in_j_count), in_frac(nlon,in_j_count,ntypes) )

  ! read input data
  iret = nf_get_vara_double(ncid, varid, &
          (/1,in_j_start,1/), (/nlon,in_j_count,ntypes/), in_frac)
  __NF_ASRT__( iret ) 
  __NF_ASRT__( nfu_get_valid_range(ncid,varid,v) )

  frac = 0
  do k = 1,size(input_cover_types)
     cover = input_cover_types(k)
     if (cover<1.or.cover>ntypes) then
        cycle ! skip all invalid indices in the array of input cover types
     endif
     in_mask = 0.0
     where(nfu_is_valid(in_frac(:,:,cover),v)) in_mask = 1.0
     call horiz_interp_new(interp, &
          in_lonb,in_latb(in_j_start:in_j_start+in_j_count), lonb,latb,&
          interp_method='conservative',mask_in=in_mask)
     call horiz_interp(interp,in_frac(:,:,cover),frac(:,:,k))
     call horiz_interp_del(interp)
  enddo

  ! clean up memory
  deallocate(in_lonb, in_latb, in_frac, in_mask)

end subroutine do_read_fraction_field


! ============================================================================
subroutine read_field_N_2D(filename, varname, lon, lat, data, interp)
  character(len=*), intent(in) :: filename
  character(len=*), intent(in) :: varname
  real, intent(in)  :: lon(:,:),lat(:,:)
  real, intent(out) :: data(:,:)
  character(len=*), intent(in), optional :: interp

  ! ---- local vars ----------------------------------------------------------
  real    :: data3(size(data,1),size(data,2),1)

  call read_field_N_3D(filename, varname, lon, lat, data3, interp)
  data = data3(:,:,1)

end subroutine read_field_N_2D

! ============================================================================
subroutine read_field_N_3D(filename, varname, lon, lat, data, interp)
  character(len=*), intent(in) :: filename
  character(len=*), intent(in) :: varname
  real, intent(in)  :: lon(:,:),lat(:,:)
  real, intent(out) :: data(:,:,:)
  character(len=*), intent(in), optional :: interp

  ! ---- local vars ----------------------------------------------------------
  integer :: ncid
  integer :: iret

  iret = nf_open(filename,NF_NOWRITE,ncid)
  if(iret/=NF_NOERR) then
     call error_mesg('read_field','Can''t open netcdf file "'//trim(filename)//'"',FATAL)
  endif
  call read_field_I_3D(ncid, varname, lon, lat, data, interp)
  __NF_ASRT__( nf_close(ncid) )

end subroutine read_field_N_3D

! ============================================================================
subroutine read_field_I_2D(ncid, varname, lon, lat, data, interp)
  integer, intent(in) :: ncid
  character(len=*), intent(in) :: varname
  real, intent(in) :: lon(:,:),lat(:,:)
  real, intent(out) :: data(:,:)
  character(len=*), intent(in), optional  :: interp
  ! ---- local vars
  real    :: data3(size(data,1),size(data,2),1)

  call read_field_I_3D(ncid, varname, lon, lat, data3, interp)
  data = data3(:,:,1)

end subroutine read_field_I_2D

! ============================================================================
subroutine read_field_I_3D(ncid, varname, lon, lat, data, interp)
  integer, intent(in) :: ncid
  character(len=*), intent(in) :: varname
  real, intent(in) :: lon(:,:),lat(:,:)
  real, intent(out) :: data(:,:,:)
  character(len=*), intent(in), optional  :: interp

  ! ---- local vars ----------------------------------------------------------
  integer :: nlon, nlat, nlev ! size of input grid
  integer :: varndims ! number of variable dimension
  integer :: vardims(NF_MAX_VAR_DIMS) ! IDs of variable dimension
  integer :: dimlens(NF_MAX_VAR_DIMS) ! sizes of respective dimensions
  real,    allocatable :: in_lonb(:), in_latb(:), in_lon(:), in_lat(:)
  real,    allocatable :: x(:,:,:) ! input buffer
  logical, allocatable :: mask(:,:,:) ! mask of valid values
  real,    allocatable :: rmask(:,:,:) ! real mask for interpolator
  character(len=20) :: interpolation 
  integer :: i,j,k,imap,jmap,data_size
  type(nfu_validtype) :: v

  interpolation = "bilinear"
  if(present(interp)) interpolation = interp
  
  ! get the dimensions of our variable
  __NF_ASRT__( nfu_inq_var(ncid,varname,ndims=varndims,dimids=vardims,dimlens=dimlens) )
  if(varndims<2.or.varndims>3) then
     call error_mesg('read_field','variable "'//trim(varname)//'" is '//string(varndims)//&
          'D, but only reading 2D or 3D variables is supported', FATAL)
  endif
  nlon = dimlens(1) ; nlat = dimlens(2)
  nlev = 1; 
  if (varndims==3) nlev=dimlens(3)
  if(nlev/=size(data,3)) then
     data_size = size(data,3)
     call error_mesg('read_field','3rd dimension length of the variable "'&
          //trim(varname)//'" ('//trim(string(nlev))//') is different from the expected size of data ('// &
          trim(string(data_size))//')', FATAL)
  endif

  allocate (                 &
       in_lon  (nlon),   in_lat  (nlat),   &
       in_lonb (nlon+1), in_latb (nlat+1), &
       x       (nlon, nlat, nlev) ,&
       mask    (nlon, nlat, nlev) , rmask(nlon, nlat, nlev) )

  ! read boundaries of the grid cells in longitudinal direction
  __NF_ASRT__(nfu_get_dim(ncid, vardims(1), in_lon))
  __NF_ASRT__(nfu_get_dim(ncid, vardims(2), in_lat))
  in_lon = in_lon*PI/180.0; in_lat = in_lat*PI/180.0
  __NF_ASRT__(nfu_get_dim_bounds(ncid, vardims(1), in_lonb))
  __NF_ASRT__(nfu_get_dim_bounds(ncid, vardims(2), in_latb))
  in_lonb = in_lonb*PI/180.0; in_latb = in_latb*PI/180.0
  __NF_ASRT__(nfu_get_valid_range(ncid,varname,v))
  ! read input data
  __NF_ASRT__( nfu_get_var(ncid,varname,x) ) ! assuming real is real*8
  mask = nfu_is_valid(x,v)
  rmask = 1.0
  where(.not.mask) rmask = 0.0

  select case(trim(interpolation))
  case ("bilinear")
     do k = 1,size(data,3)
        call horiz_interp(x(:,:,k), in_lonb, in_latb, lon,lat, data(:,:,k), mask_in=rmask(:,:,k), &
             interp_method='bilinear')
     enddo
  case ("nearest")
     do k = 1,size(data,3)
     do j = 1,size(data,2)
     do i = 1,size(data,1)
        call nearest (mask(:,:,k), in_lon, in_lat, lon(i,j), lat(i,j), imap, jmap)
        data(i,j,k) = x(imap,jmap,k)
     enddo
     enddo
     enddo
  case default
     call error_mesg(module_name, interpolation//" is not a valid interpolation method",FATAL)
  end select

  deallocate(in_lonb, in_latb, in_lon, in_lat, x, mask, rmask)

end subroutine read_field_I_3D

! ============================================================================
subroutine print_netcdf_error(ierr, file, line)
  ! prints out NetCDF library error message, including file name and line number
  integer,          intent(in) :: ierr ! error code
  character(len=*), intent(in) :: file ! name of the file
  integer,          intent(in) :: line ! number of line in the file

  ! ---- local vars
  character(len=1024) :: mesg

  if (ierr.ne.NF_NOERR) then
     write(mesg, "('File ',a,' Line ',i4.4,' :: ',a)") &
          trim(file),line,trim(NF_STRERROR(ierr))
     call error_mesg('NetCDF', mesg, FATAL)
  endif
end subroutine print_netcdf_error

end module


! ============================================================================
! module numerics: a collection of useful general-purpose routines
! ============================================================================
#define __ERROR__(message) \
call my_error(mod_name,message,FATAL,thisfile,__LINE__)
#define __NOTE__(message) \
call my_error(mod_name,message,NOTE,thisfile,__LINE__)
#define __ASSERT__(x, message) \
if(.NOT.(x))call my_error(mod_name,message,FATAL,thisfile,__LINE__)

module land_numerics_mod

use fms_mod, only: error_mesg, FATAL, NOTE, write_version_number, mpp_pe, &
     stdout
use mpp_mod, only: mpp_npes, mpp_get_current_pelist, mpp_send, mpp_recv, &
     mpp_sync, mpp_sync_self, mpp_transmit
use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, &
     mpp_get_global_domain

implicit none
private

! ==== public interfaces =====================================================
public :: bisect    ! finds a position of point in array of bounds
public :: lin_int   ! linear interpolation
public :: ludcmp, lubksb ! LU decomposition and back substitution
public :: tridiag   ! tridiagonal system solver
public :: nearest   ! nearest point search

public :: horiz_remap_type
public :: horiz_remap_new, horiz_remap_del
public :: horiz_remap_print
public :: horiz_remap

public :: numerics_init
! ==== end of public interfaces ==============================================


!     Linear interpolation.
interface lin_int
   module procedure lin_int0
   module procedure lin_int1
   module procedure lin_int2
   module procedure lin_int1m
   module procedure lin_int2m
end interface

interface nearest
   module procedure nearest1D, nearest2D
end interface

logical :: module_is_initialized =.FALSE.
! module constants
character(len=*), parameter :: &
     mod_name = 'land_numerics_mod', &
     version  = '$Id: land_numerics.F90,v 17.0.2.6.2.1.4.1 2011/12/12 19:30:45 Peter.Phillipps Exp $', &
     tagname  = '$Name:  $', &
     thisfile = __FILE__
! ==== public type ===========================================================
! this data structure describes the horizontal remapping: that is, the operation 
! of copying the data from the source points to the destination points. The source
! points are not necessarily on the same PE as destination points.
type :: horiz_remap_type
   integer :: n = 0 ! number of points that need remapping on this PE
   integer, pointer :: &
       dst_i(:)=>NULL(), & ! x-indices of destination points
       dst_j(:)=>NULL()    ! y-indices of destination points
   integer, pointer :: &
       src_i(:)=>NULL(), & ! x-indices of source points
       src_j(:)=>NULL(), & ! y-indices of source points
       src_p(:)=>NULL()    ! processor number of source points
   ! data distribution map: for each processor pair that communicate 
   ! (unidirectionally), an entry in the srcPE and dstPE arrays holds their 
   ! numbers. This map is the same on each of the PEs that participate in
   ! remapping.
   integer :: mapSize = 0
   integer, pointer :: &     ! for each index:
       srcPE(:) => NULL(), & ! PE that provides the data
       dstPE(:) => NULL()    ! PE that requests and then uses the data
end type horiz_remap_type

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ============================================================================
! Initializes the numerics module.
subroutine numerics_init()

  module_is_initialized =.TRUE. 
  call write_version_number(version,tagname)

end subroutine numerics_init


! ============================================================================
!  Finds a position of point in array of bounds. Returns i, such that x is
!  between xx(i) and xx(i+1).
!  Usage:
!     value=bisect( xx, x1, periodic )
function bisect(xx, x1, periodic)
  real, intent(in)              :: xx(:)     ! array of boundaries
  real, intent(in)              :: x1        ! point to locate
  logical, intent(in), optional :: periodic  ! if present and true, the data
                                             ! domain is assumed to be periodic
  ! ---- result type ---------------------------------------------------
  integer bisect

  ! ---- local vars ----------------------------------------------------
  real    :: x              ! duplicate of input value
  integer :: low, high, mid
  integer :: n              ! size of the input array
  logical :: ascending      ! if true, the coordinates are in ascending order

  n = size(xx)
  x = x1

  ! bring the point inside bounds of the period
  if (present(periodic)) then
    if (periodic) then
       __ASSERT__(xx(n)-xx(1)/=0,"periodic bisect: period equal to zero")
       x = modulo(x-min(xx(1),xx(n)),abs(xx(n)-xx(1)))+min(xx(1),xx(n))
    endif
  endif

  ! find the coordinates
  if (x >= xx(1).and.x<=xx(n)) then
     low = 1; high = n
     ascending = xx(n) > xx(1)
     do while (high-low > 1)
        mid = (low+high)/2
        if (ascending.eqv.xx(mid) <= x) then
           low = mid
        else
           high = mid
        endif
     enddo
     bisect = low
  else
     bisect = -1
  endif

end function bisect


! ==============================================================================
!     Linearly interpolates 1-D data.
subroutine lin_int0(data, xx, x, res)
  real, intent(in) :: data(:)    ! data to interpolate
  real, intent(in) :: xx(:)      ! coord. corresponding to data
  real, intent(in) :: x          ! coord to interpolate to
  real, intent(inout) :: res     ! result of interpolation

  ! ---- local vars ----------------------------------------------------------
  integer :: i1, i2
  real    :: f1, f2

  ! find where is our time point and calculate weights
  i1 = bisect(xx,x)
  i2 = i1+1
  __ASSERT__(i1>0.AND.i1<size(xx),"Coordinate is out of range")

  f2 = (x-xx(i1))/(xx(i2)-xx(i1))
  f1 = 1.0-f2

  ! update the result
  res = data(i1)*f1+data(i2)*f2

end subroutine lin_int0


! ==============================================================================
!     Linearly interpolates 1-D data.
subroutine lin_int1(data, xx, x, res)

  real, intent(in) :: data(:,:)    ! data to interpolate
  real, intent(in) :: xx(:)        ! coord. corresponding to data
  real, intent(in) :: x            ! coord to interpolate to
  real, intent(inout) :: res(:)    ! result of interpolation

  ! ---- local vars ----------------------------------------------------------
  integer :: i1, i2
  real    :: f1, f2

  ! find where is our time point and calculate weights
  i1 = bisect(xx,x)
  i2 = i1+1

  __ASSERT__(i1>0.AND.i1<size(xx),"Coordinate is out of range")

  f2 = (x-xx(i1))/(xx(i2)-xx(i1))
  f1 = 1.0-f2

  ! update the result
  res = data(:,i1)*f1+data(:,i2)*f2

end subroutine lin_int1


! ==============================================================================
!     Interpolates prescribed over time.
subroutine lin_int2(data, tt, t, res)

  real, intent(in) :: data(:,:,:)  ! data to interpolate
  real, intent(in) :: tt(:)        ! time moments corresponding to data points
  real, intent(in) :: t            ! time to interpolate to
  real, intent(inout) :: res(:,:)  ! result

  ! ---- local vars ----------------------------------------------------------
  integer :: i1, i2
  real    :: f1, f2

  ! find where is our time point and calculate weights
  i1 = bisect(tt,t); i2 = i1+1
  __ASSERT__(i1>0.AND.i1<size(tt),"Coordinate is out of range")

  f2 = (t-tt(i1))/(tt(i2)-tt(i1))
  f1 = 1-f2

  ! update the result
  res = data(:,:,i1)*f1+data(:,:,i2)*f2

end subroutine lin_int2


!     Linearly interpolates 1-D data.
subroutine lin_int1m(data, xx, x, res, mask)
  real, intent(in) :: data(:,:)    ! data to interpolate
  real, intent(in) :: xx(:)        ! coord. corresponding to data
  real, intent(in) :: x            ! coord to interpolate to
  real, intent(inout) :: res(:)    ! result of interpolation
  logical, intent(in) :: mask(:)   ! valid data mask

  ! ---- local vars ----------------------------------------------------------
  integer :: i1, i2
  real    :: f1, f2

  ! find where is our time point and calculate weights
  i1 = bisect(xx,x)
  i2 = i1+1
  __ASSERT__(i1>0.AND.i1<size(xx),"Coordinate is out of range")

  f2 = (x-xx(i1))/(xx(i2)-xx(i1))
  f1 = 1.0-f2

  ! finally, update the result
  where (mask) 
     res = data(:,i1)*f1+data(:,i2)*f2
  endwhere

end subroutine lin_int1m


! ==============================================================================
!     Interpolates prescribed over time.
subroutine lin_int2m(data, tt, t, res, mask)
  real, intent(in) :: data(:,:,:)  ! data to interpolate
  real, intent(in) :: tt(:)        ! time moments corresponding to data points
  real, intent(in) :: t            ! time to interpolate to
  real, intent(inout) :: res(:,:)  ! result
  logical, intent(in) :: mask(:,:) ! interpolation mask

  ! ---- local vars ----------------------------------------------------------
  integer :: i1, i2
  real    :: f1, f2

  ! find where is our time point and calculate weights
  i1 = bisect(tt,t); i2 = i1+1
  __ASSERT__(i1>0.AND.i1<size(tt),"Coordinate is out of range")

  f2 = (t-tt(i1))/(tt(i2)-tt(i1))
  f1 = 1-f2

  ! update the result
  where (mask) 
     res = data(:,:,i1)*f1+data(:,:,i2)*f2
  endwhere
end subroutine lin_int2m


! ==============================================================================
! given a matrix a(n,n) replaces it by LU decomposition of a rowwise permutation
! of itself indx(n) is an output that records the permuatation. This routine is
! used in combination with lubksb to solve linear equations or invert a matrix
! example:
!    call ludcmp(a,indx)
!    call lubksb(a,indx,b1)
!    call lubksb(a,indx,b2)
subroutine ludcmp(a,indx,status)
  real,    intent(inout) :: a(:,:) ! matrix that gets replaced by its LU decomposition
  integer, intent(out)   :: indx(:) ! index of row permutations effecte by partial pivoting
  integer, intent(out), optional :: status

  integer, parameter :: TINY = 1.0e-20
  integer :: n ! size of the matrix 
  integer :: i,j,k,imax
  real    :: aamax,dum,sum
  real    :: vv(size(a,1)) ! implicit scaling for each row

  n = size(a,1)
  if(present(status))status = 0

  ! find largest element in each row and calculate scaling 
  do i = 1,n
     aamax = 0.0
     do j = 1,n
        if(abs(a(i,j)) > aamax)aamax = abs(a(i,j))
     enddo
     if(.not.(aamax /= 0.0)) then 
        if(present(status))then
           status = -1; aamax = TINY
        else
           call error_mesg('ludcmp','Matrix is singular', FATAL)
        endif
     endif
     vv(i) = 1.0/aamax
  enddo

  ! loop over the columns of Crout's method
  do j=1,n
     do i = 1,j-1
        sum = a(i,j)
        do k = 1,i-1
           sum = sum-a(i,k)*a(k,j)
        enddo
        a(i,j) = sum
     enddo
     aamax = 0.0 ! initialize the search for the largest pivot element
     do i = j,n
        sum = a(i,j)
        do k = 1,j-1
           sum = sum-a(i,k)*a(k,j)
        enddo
        a(i,j) = sum
        dum = vv(i)*abs(sum) ! figure of merit for the pivot
        if (dum >= aamax) then ! is it better than the best so far?
           imax = i
           aamax = dum
        endif
     enddo
     if (j /= imax) then ! do we need to interchange rows?
        ! Yes, do so
        do k=1,n
           dum=a(imax,k)
           a(imax,k) = a(j,k)
           a(j,k) = dum
        enddo
        vv(imax) = vv(j)
     endif
     indx(j) = imax
     ! if the pivot element is zero, then the matrix is singular (at least to the
     ! precision of the algorithm). For some applications on singular matrices, it 
     ! is desirable to substitute TINY for zero
     if(a(j,j)==0.0) a(j,j) = TINY

     if (j/=n)then
        ! Finally, divide by the pivot element
        dum = 1.0/a(j,j)
        do i = j+1,n
           a(i,j) = a(i,j)*dum
        enddo
     endif
  enddo ! loop over the columns
end subroutine ludcmp


! ==============================================================================
! given a LU decomposition of matrix a(n,n), permuation vector indx, and right-
! hand side b, solves the set of linear equations A*X = B 
subroutine lubksb(a,indx,b)
  real,    intent(in)    :: a(:,:)  ! LU-decomposed matrix
  integer, intent(in)    :: indx(:) ! permutation vector, as returned by the ludcmp
  real,    intent(inout) :: b(:)    ! right-hand side vector, returns solution

  integer :: i,ii,j,ll,n
  real    :: sum

  n = size(a,1)
  ii = 0
  do i = 1,n
     ll = indx(i)
     sum = b(ll)
     b(ll) = b(i)
     if (ii/=0) then
        do j = ii,i-1
           sum = sum - a(i,j)*b(j)
        enddo
     else if (sum /= 0.0) then
        ii = i
     endif
     b(i) = sum
  enddo
  do i = n, 1, -1
     sum = b(i)
     do j = i+1,n
        sum = sum-a(i,j)*b(j)
     enddo
     b(i) = sum/a(i,i)
  enddo
end subroutine lubksb


! ============================================================================
! given values of the triadiagonal matrix coefficients, computes a solution
subroutine tridiag(a,b,c,r,u)
  real, intent(in)  :: a(:),b(:),c(:),r(:)
  real, intent(out) :: u(:)

  integer :: j
  real :: bet, gam(size(a))
  
  ! check that the sizes are the same
  if(size(a)/=size(b).or.size(a)/=size(c).or.size(a)/=size(r)) &
       call error_mesg('tridiag','sizes of input arrays are not equal',FATAL)
  if(size(u)<size(a)) &
       call error_mesg('tridiag','size of the result is insufficient',FATAL)
  ! check that a(1)==0 and c(N)==0
  if(a(1)/=0.or.c(size(a))/=0) &
       call error_mesg('tridiag','a(1) and c(N) must be equal to 0',FATAL)
  ! decomposition and forward substitution
  bet = b(1)
  u(1) = r(1)/bet
  do j = 2,size(a)
     gam(j) = c(j-1)/bet
     bet = b(j)-a(j)*gam(j)
     if(bet==0) &
          call error_mesg('tridiag','system is ill-defined',FATAL)
     u(j) = (r(j)-a(j)*u(j-1))/bet
  enddo
  ! backward substitution
  do j = size(a)-1,1,-1
     u(j) = u(j)-gam(j+1)*u(j+1)
  enddo
end subroutine tridiag

! ============================================================================
! finds nearest point that is not masked out in input data
! NOTE: implemented in very naive and inefficient way
subroutine nearest1D(mask, lon, lat, plon, plat, iout, jout, dist)
  logical, intent(in) :: mask(:,:)  ! mask of valid input points (.true. if valid point)
  real,    intent(in) :: lon(:)     ! longitudes of input grid central points, radian
  real,    intent(in) :: lat(:)     ! latitudes of input grid central points, radian
  real,    intent(in) :: plon, plat ! coordinates of destination point, radian
  integer, intent(out):: iout, jout ! indices of nearest valid (unmasked) point
  real, optional, intent(out):: dist ! distance to the point 

  ! ---- local constants
  character(*),parameter :: mod_name='nearest1D'
  ! ---- local vars
  integer :: i,j
  real    :: r,r1

  __ASSERT__(size(mask,1)==size(lon),'sizes of "mask" and "lon" are inconsistent')
  __ASSERT__(size(mask,2)==size(lat),'sizes of "mask" and "lat" are inconsistent')
  
  r = HUGE(r)  ! some value larger than any possible distance

  do j = 1, size(mask,2)
  do i = 1, size(mask,1)
     if (.not.mask(i,j)) cycle
     r1 = distance(plon,plat,lon(i),lat(j))
     if ( r1 < r ) then
        iout = i
        jout = j
        r = r1
     endif
  enddo
  enddo
  if (present(dist)) dist = r
end subroutine nearest1D

! ============================================================================
! finds nearest point that is not masked out in input data
! this version works with 2D lon and lat fields
subroutine nearest2D(mask, lon, lat, plon, plat, iout, jout, dist)
  logical, intent(in) :: mask(:,:)  ! mask of valid input points (.true. if valid point)
  real,    intent(in) :: lon(:,:)   ! longitudes of input grid central points, radian
  real,    intent(in) :: lat(:,:)   ! latitudes of input grid central points, radian
  real,    intent(in) :: plon, plat ! coordinates of destination point, radian
  integer, intent(out):: iout, jout ! indices of nearest valid (unmasked) point
  real, optional, intent(out):: dist! distance to the point 

  ! ---- local constants
  character(*),parameter :: mod_name='nearest2D'
  ! ---- local vars 
  integer :: i,j
  real    :: r,r1

  __ASSERT__(ALL(SHAPE(mask)==SHAPE(lon)),'shapes of "mask" and "lon" are different')
  __ASSERT__(ALL(SHAPE(mask)==SHAPE(lat)),'shapes of "mask" and "lat" are different')

  r = HUGE(r)  ! some value larger than any possible distance

  do j = 1, size(mask,2)
  do i = 1, size(mask,1)
     if (.not.mask(i,j)) cycle
     r1 = distance(plon,plat,lon(i,j),lat(i,j))
     if ( r1 < r ) then
        iout = i
        jout = j
        r = r1
     endif
  enddo
  enddo
  if (present(dist)) dist=r
end subroutine nearest2D

! ============================================================================
! private functions that calculates the distance between two points given their 
! coordiantes
function distance(lon1, lat1, lon2, lat2) ; real distance
  ! calculates distance between points on unit square
  real, intent(in) :: lon1,lat1,lon2,lat2
  
  real :: x1,y1,z1, x2,y2,z2
  real :: dlon
  dlon = (lon2-lon1)
  
  z1 = sin(lat1) ;  z2 = sin(lat2)
  y1 = 0.0       ;  y2 = cos(lat2)*sin(dlon)
  x1 = cos(lat1) ;  x2 = cos(lat2)*cos(dlon)
  
  ! distance = acos(x1*x2 + z1*z2)
  distance = (x1-x2)**2+(y1-y2)**2+(z1-z2)**2
end function distance


! ============================================================================
! dealloacate memory associated with the 
subroutine horiz_remap_del(map)
   type(horiz_remap_type), intent(inout) :: map
#define __DEALLOC__(x)\
if (associated(x)) then; deallocate(x); x=>NULL(); endif
   __DEALLOC__(map%dst_i)
   __DEALLOC__(map%dst_j)
   __DEALLOC__(map%src_i)
   __DEALLOC__(map%src_j)
   __DEALLOC__(map%src_p)
   map%n=0
      
   __DEALLOC__(map%srcPE)
   __DEALLOC__(map%dstPE)
   map%mapSize=0   
#undef __DEALLOC__
end subroutine

! ============================================================================
! prints remapping information
subroutine horiz_remap_print(map, prefix)
   type(horiz_remap_type), intent(in) :: map
   character(*), intent(in) :: prefix

   integer :: k

   do k = 1, map%n
      write(*,100) prefix,&
         map%src_i(k),map%src_j(k),map%src_p(k),&
         map%dst_i(k),map%dst_j(k),mpp_pe()
   enddo
100 format(a,'(I:',i4.4,' J:',i4.4,' PE:',i4.4,') -> (I:',i4.4,' J:',i4.4,' PE:',i4.4,')')
end subroutine

! ============================================================================
! given the local mask of the points that need filling, the local mask of 
! the valid points, local arrays of coordinates, and the domain, returns the
! remapping information that can be used later to fill the data
subroutine horiz_remap_new(invalid, valid, lon, lat, domain, pes, map)
  logical, intent(in) :: invalid(:,:) ! mask of points to be filled
  logical, intent(in) :: valid  (:,:) ! mask of valid input points 
  real,    intent(in) :: lon(:,:)   ! longitudes of input grid central points, radian
  real,    intent(in) :: lat(:,:)   ! latitudes of input grid central points, radian
  type(domain2d), intent(in) :: domain ! our domain
  integer, intent(in) :: pes(:)     ! list of PEs
  type(horiz_remap_type), intent(out) :: map ! remapping information


  ! --- local constants  
  character(*), parameter :: mod_name='horiz_remap_new'
  ! --- local vars  
  integer :: ntot ! total number of missing points across all PEs
  integer :: is,ie,js,je ! boundaries of our compute domain
  integer :: npes ! total number of PEs
  integer :: nlon ! longitudinal size of global grid
  integer :: root_pe ! root PE for this operation
  integer, allocatable :: np(:) ! number of missing points per processor
  integer :: p ! processor iterator
  real   , allocatable :: glon(:), glat(:) ! global arrays of missing point coordinates
  integer, allocatable :: from_pe(:) ! number of PE the missing points belong to
  real   , allocatable :: dist(:) ! distance to the missing points
  integer, allocatable :: ii(:),jj(:) ! indices of the nearest points
  integer, allocatable :: ibuf(:),jbuf(:) ! send/receive buffers for indices
  real   , allocatable :: dbuf(:) ! send/receive buffer for distances
  integer :: i,j,k,m,n1
  integer :: k0

  ! get the number of longitudes in global domain (only used to resolve ambiguities
  ! in PE-count independent manner)
  call mpp_get_global_domain(domain, xsize = nlon )  
  ! get the size of our domain
  call mpp_get_compute_domain(domain, is,ie,js,je)
  ! check the input array shapes
  if(size(invalid,1)/=ie-is+1.or.size(invalid,2)/=je-js+1) then
    call my_error(mod_name,'shape of input array "'//'invalid'//'" must be the same as shape of compute domain',FATAL)
  endif
  if(size(valid,1)/=ie-is+1.or.size(valid,2)/=je-js+1) then
    call my_error(mod_name,'shape of input array "'//'valid'//'" must be the same as shape of compute domain',FATAL)
  endif
  if(size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) then
    call my_error(mod_name,'shape of input array "'//'lon'//'" must be the same as shape of compute domain',FATAL)
  endif
  if(size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) then
    call my_error(mod_name,'shape of input array "'//'lat'//'" must be the same as shape of compute domain',FATAL)
  endif
  
  ! get the number of mising points for this PE
  map%n = count(invalid)

  ! get the number of PEs that communicate
  npes = size(pes)
  ! and the number of the root PE
  root_pe = pes(1)

  ! [x] compute the global number of missing points and assemble the 
  ! array of point numbers per PE on root PE
  call mpp_send(map%n,root_pe)
  if (mpp_pe()==root_pe) then
     allocate(np(npes))
     do p = 1,npes
        call mpp_recv(np(p),pes(p))
     enddo
     ntot = sum(np)
     do p = 1, npes
        call mpp_send(ntot,pes(p))
     enddo
  endif
  call mpp_recv(ntot,root_pe)
  
  ! we don't need to do anything if there are no missing points anywhere
  if (ntot==0) return
  
  ! [x] allocate global buffers
  allocate(glon(ntot),glat(ntot),from_pe(ntot),dist(ntot),ii(ntot),jj(ntot))

  ! allocate buffers for missing point indices and processors
  allocate(map%dst_i(map%n), map%dst_j(map%n))
  allocate(map%src_i(map%n), map%src_j(map%n), map%src_p(map%n))
  ! and fill the coordianates of missing points for this PE
  k = 1
  do j=1,size(invalid,2)
  do i=1,size(invalid,1)
     if (invalid(i,j)) then
        glon(k)      = lon(i,j); glat(k)      = lat(i,j)
        map%dst_i(k) = i+is-1  ; map%dst_j(k) = j+js-1
        k = k+1
     endif
  enddo
  enddo
  
  ! [x] send the array of point coordinates to root PE and get the global
  ! arrays of point coordinates in return
  if (mpp_pe()/=root_pe) then
     ! non-root PE sends its data to the root
     call mpp_send(map%n,root_pe)
     if (map%n>0) then
        call mpp_send(glon(1), plen=map%n, to_pe=root_pe)
        call mpp_send(glat(1), plen=map%n, to_pe=root_pe)
     endif
     ! and then receives the global data in response
     call mpp_recv(glon(1),glen=ntot,from_pe=root_pe)
     call mpp_recv(glat(1),glen=ntot,from_pe=root_pe)
  else
     ! root PE receives data from all PEs and assembles global coordinate arrays 
     ! in the order of PEs in the list, except that it puts its own data first.
     from_pe(1:map%n) = root_pe
     k=map%n+1
     do p = 1,npes 
        if (pes(p)==root_pe) cycle
        call mpp_recv(n1,pes(p))
        if (n1>0) then
           call mpp_recv(glon(k),glen=n1,from_pe=pes(p))
           call mpp_recv(glat(k),glen=n1,from_pe=pes(p))
           from_pe(k:k+n1-1)=pes(p)
        endif
        k = k+n1
     enddo
     ! then it distributes the resulting array among PEs
     do p = 1,npes
        if (pes(p)==root_pe) cycle
        call mpp_send(glon(1),plen=ntot,to_pe=pes(p))
        call mpp_send(glat(1),plen=ntot,to_pe=pes(p))
     enddo
  endif

  ! [x] find the nearest points in the domain
  do k = 1, ntot
     call nearest(valid,lon,lat,glon(k),glat(k),ii(k),jj(k),dist=dist(k))     
  enddo
  ! convert local domain indices to global
  ii(:) = ii(:)+is-1; jj(:)=jj(:)+js-1

  ! [5] send the data to root PE and let it calculate the points corresponding to 
  ! the global minimum distance
  if (mpp_pe()/=root_pe) then
     ! non-root PE just sends the data
     call mpp_send(ii(1)  ,plen=ntot,to_pe=root_pe)
     call mpp_send(jj(1)  ,plen=ntot,to_pe=root_pe)
     call mpp_send(dist(1),plen=ntot,to_pe=root_pe)
     ! and receives the updated data in response
     if(map%n>0) then
        ! receive the nearest point locations and PEs
        call mpp_recv(map%src_i(1),glen=map%n,from_pe=root_pe)
        call mpp_recv(map%src_j(1),glen=map%n,from_pe=root_pe)
        call mpp_recv(map%src_p(1),glen=map%n,from_pe=root_pe)
     endif
     ! receive communication map
     call mpp_recv(map%mapSize,glen=1,from_pe=root_pe)
     if (map%mapSize>0) then
        allocate (map%srcPE(map%mapSize),map%dstPE(map%mapSize))
        call mpp_recv(map%srcPE(1),glen=map%mapSize,from_pe=root_pe)
        call mpp_recv(map%dstPE(1),glen=map%mapSize,from_pe=root_pe)
     endif
  else
     ! root PE does the bulk of processing: it assembles all the data
     ! and sends the relevant parts back to the processors that need them
     
     ! receive data about domain-specific nearest points from PEs and select
     ! the globally nearest point among them
     allocate(ibuf(ntot),jbuf(ntot),dbuf(ntot))
     ! note that arrays ii,jj, and dist are initially filled with the
     ! nearest points information for the root PE own domain
     from_pe(:) = root_pe
     do p = 1,npes
        if (pes(p)==root_pe) cycle
        call mpp_recv(ibuf(1),glen=ntot,from_pe=pes(p))
        call mpp_recv(jbuf(1),glen=ntot,from_pe=pes(p))
        call mpp_recv(dbuf(1),glen=ntot,from_pe=pes(p))
        do k = 1,ntot
           ! to avoid dependence on the order of operations, give preference
           ! to the lowest leftmost point among the equidistant points
           if (dbuf(k)<dist(k).or.(&
               dbuf(k)==dist(k).and.jbuf(k)*nlon+ibuf(k)<jj(k)*nlon+ii(k))) then
              ii(k)=ibuf(k); jj(k)=jbuf(k); dist(k)=dbuf(k); from_pe(k)=pes(p)
           endif
        enddo
     enddo
     
     ! release buffers
     deallocate (ibuf,jbuf,dbuf)

     ! create a communication map: arrays srcPE and dstPE listing all pairs that
     ! communicate
     allocate(map%srcPE(ntot),map%dstPE(ntot)) ! allocate max possible number
     k0=1; m=1
     do p = 1, npes
        do k = sum(np(1:p-1))+1, sum(np(1:p))
           if (from_pe(k) == pes(p)) cycle ! skip communications to itself 
           if (ANY(map%srcPE(k0:m-1)==from_pe(k))) cycle ! skip src->dst pair that already exists
           ! add current pair to the communication map
           map%srcPE(m)=from_pe(k); map%dstPE(m)=pes(p); m=m+1
        enddo
        k0=m
     enddo
     
     ! actual number of elements in comm. map is m-1
     map%mapSize=m-1

     ! simply assign the results for the root PE
     if (map%n>0) then
        map%src_i(:) = ii(1:map%n)
        map%src_j(:) = jj(1:map%n)
        map%src_p(:) = from_pe(1:map%n)
     endif
     ! distribute the results among processors
     k = map%n+1
     do p = 1,npes
        if (pes(p)==root_pe) cycle
        if (np(p)>0) then
           ! send nearest point location
           call mpp_send(ii(k),plen=np(p),to_pe=pes(p))
           call mpp_send(jj(k),plen=np(p),to_pe=pes(p))
           call mpp_send(from_pe(k),plen=np(p),to_pe=pes(p))
        endif
        ! broadcast comm. map
        call mpp_send(map%mapSize,plen=1,to_pe=pes(p))
        if (map%mapSize>0) then
           call mpp_send(map%srcPE(1),plen=map%mapSize,to_pe=pes(p))
           call mpp_send(map%dstPE(1),plen=map%mapSize,to_pe=pes(p))
        endif
        k = k+np(p)
     enddo
     
  endif

  call mpp_sync_self()

  deallocate(glon,glat,from_pe,dist,ii,jj)
  
  ! note that many communications in this routine can be sped up if the data 
  ! are combined.
  ! For example instead of sending ii,jj,and from_pe one can encode them
  ! in a single integer array [ a(i*3-2)=ii(i), a(i*3-1)=jj(i), a(i*3)=from_pe(i) ]
  ! and send that array.

end subroutine

! ============================================================================
subroutine horiz_remap(map,domain,d)
  type(horiz_remap_type), intent(in)    :: map
  type(domain2d)        , intent(in)    :: domain
  real                  , intent(inout) :: d(:,:,:) ! field to fill
  
  ! ---- local vars
  integer :: is,ie,js,je ! bounds of out compute domain
  integer :: i,j,k,n
  integer, allocatable :: ii(:),jj(:)
  real   , allocatable :: buf(:,:)
  logical :: ltmp

  ! get the boundaries of the compute domain, for global->local index
  ! conversion
  call mpp_get_compute_domain(domain, is,ie,js,je)

  ltmp = size(d,1)==ie-is+1.or.size(d,2)==je-js+1
  __ASSERT__(ltmp,'shape of data must be the same as shape of compute domain')

  ! handle the local points
  do i = 1, map%n
     if (map%src_p(i)==mpp_pe()) then
       d(map%dst_i(i)-is+1,map%dst_j(i)-js+1,:) = &
       d(map%src_i(i)-is+1,map%src_j(i)-js+1,:)
     endif
  enddo

  ! exchage information with other processors
  do k = 1, map%mapSize
     if (map%srcPE(k)==mpp_pe()) then
        ! get the size of the data from the other PE
        call mpp_recv(n,map%dstPE(k))
        allocate(ii(n),jj(n),buf(n,size(d,3)))
        ! get the indices
        call mpp_recv(ii(1),glen=n,from_pe=map%dstPE(k))
        call mpp_recv(jj(1),glen=n,from_pe=map%dstPE(k))
        ! fill the buffer
        do i = 1,n
           if(ii(i)<is.or.ii(i)>ie) call error_mesg('distr_fill','requested index i outside of domain', FATAL)
           if(jj(i)<js.or.jj(i)>je) call error_mesg('distr_fill','requested index j outside of domain', FATAL)
           buf(i,:) = d(ii(i)-is+1,jj(i)-js+1,:)
        enddo
        ! send the buffer
        call mpp_send(buf(1,1),plen=size(buf),to_pe=map%dstPE(k))
        call mpp_sync_self()
        deallocate (ii,jj,buf)
     else if (map%dstPE(k)==mpp_pe()) then
        ! send data request
        n = count(map%src_p(:)==map%srcPE(k))
        ! alloacate and fill arrays of requested indices ii and jj
        allocate(ii(n),jj(n),buf(n,size(d,3)))
        j = 1
        do i = 1, map%n
           if (map%src_p(i)==map%srcPE(k)) then
              ii(j) = map%src_i(i); jj(j) = map%src_j(i) ; j = j+1
           endif
        enddo
        ! send the data request
        call mpp_send(n,map%srcPE(k))
        call mpp_send(ii(1),plen=n,to_pe=map%srcPE(k))
        call mpp_send(jj(1),plen=n,to_pe=map%srcPE(k))
        ! get the response
        call mpp_recv(buf(1,1),glen=size(buf),from_pe=map%srcPE(k))
        ! fill the data 
        j = 1
        do i = 1,map%n
           if (map%src_p(i)==map%srcPE(k)) then
              d(map%dst_i(i)-is+1,map%dst_j(i)-js+1,:) = buf(j,:) ; j = j+1
           endif
        enddo
        call mpp_sync_self()
        deallocate (ii,jj,buf)
     endif
  enddo

end subroutine

! ==============================================================================
! Reports error, including file name and line.
subroutine my_error(mod_name, message, mode, file, line)

  character(len=*), intent(in) :: mod_name
  character(len=*), intent(in) :: message
  integer,          intent(in) :: mode
  character(len=*), intent(in), optional :: file
  integer,          intent(in), optional :: line

  ! ---- local vars ----------------------------------------------------------
  character(len=512) :: mesg
  if(present(file)) then ! assume that file and line are either both present or not
    write(mesg,'("File ",a," Line ",i4.4," :: ",a)')&
         file, line, trim(message)
  else
    mesg = trim(message)
  endif
  call error_mesg(mod_name, mesg, mode)
end subroutine


end module land_numerics_mod


module land_tile_diag_mod

use mpp_mod,            only : mpp_sum
use time_manager_mod,   only : time_type
use diag_axis_mod,      only : get_axis_length
use diag_manager_mod,   only : register_diag_field, register_static_field, &
     send_data
#ifdef USE_LOG_DIAG_FIELD_INFO
use diag_util_mod,      only : log_diag_field_info
#endif
use fms_mod,            only : write_version_number

use land_tile_selectors_mod, only : tile_selectors_init, tile_selectors_end, &
     tile_selector_type, register_tile_selector, selector_suffix, &
     get_n_selectors, get_selector
use land_tile_mod,      only : land_tile_type, diag_buff_type, &
     land_tile_list_type, first_elmt, tail_elmt, next_elmt, get_elmt_indices, &
     land_tile_enum_type, operator(/=), current_tile, &
     tile_is_selected
use land_data_mod,      only : lnd
use tile_diag_buff_mod, only : diag_buff_type, realloc_diag_buff

implicit none
private


! ==== public interface ======================================================
public :: tile_diag_init
public :: tile_diag_end

public :: diag_buff_type

public :: register_tiled_diag_field
public :: register_tiled_static_field
public :: send_tile_data
public :: send_tile_data_r0d_fptr, send_tile_data_r1d_fptr
public :: send_tile_data_i0d_fptr

public :: dump_tile_diag_fields

! codes of tile aggregaton operations
public :: OP_AVERAGE, OP_SUM

interface send_tile_data
   module procedure send_tile_data_0d
   module procedure send_tile_data_1d
end interface
! ==== end of public interface ===============================================


! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'lan_tile_diag_mod', &
     version     = '$Id: land_tile_diag.F90,v 17.0 2009/07/21 03:02:41 fms Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'

integer, parameter :: INIT_FIELDS_SIZE     = 1     ! initial size of the fields array
integer, parameter :: BASE_TILED_FIELD_ID  = 65536 ! base value for tiled field 
! ids, to distinguish them from regular diagnostic fields. All IDs of tiled
! (that is, registered by register_*tiled_field functions are larger than 
! BASE_TILED_FIELD_ID)
integer, parameter :: MIN_DIAG_BUFFER_SIZE = 1     ! min size of the per-tile diagnostic buffer
! operations used for tile data aggregation
integer, parameter :: OP_AVERAGE = 0 ! weighted average of tile values
integer, parameter :: OP_SUM     = 1 ! sum of all tile values


! ==== derived types =========================================================
type :: tiled_diag_field_type
   integer, pointer :: ids(:) => NULL()
   integer :: offset ! offset of the field data in the buffer
   integer :: size   ! size of the field data in the per-tile buffers
   integer :: op     ! aggregation operation
   logical :: static ! if true, the diag field is static
   integer :: n_sends! number of data points sent to the field since last dump
   character(32) :: name ! for debugging purposes only
end type tiled_diag_field_type


! ==== module data ===========================================================
logical :: module_is_initialized = .false.

! list of registered fields
type(tiled_diag_field_type), pointer :: fields(:) => NULL()
integer :: n_fields       = 0 ! current number of diag fields
integer :: current_offset = 1 ! current total size of the diag fields per tile



contains



! ============================================================================
subroutine tile_diag_init()

  if (module_is_initialized) return

  module_is_initialized = .true.
  call write_version_number(version, tagname)

  ! initialize diag selectors
  call tile_selectors_init()
  call register_tile_selector('')

  ! initailze global data
  allocate(fields(INIT_FIELDS_SIZE))
  n_fields       = 0
  current_offset = 1

end subroutine tile_diag_init



! ============================================================================
subroutine tile_diag_end()

  integer :: i

  ! deallocate global data
  do i = 1, n_fields
     deallocate(fields(i)%ids)
  end do
  deallocate(fields)

  ! destroy selectors
  call tile_selectors_end()

  module_is_initialized = .false.

end subroutine tile_diag_end


! ============================================================================
function register_tiled_diag_field(module_name, field_name, axes, init_time, &
     long_name, units, missing_value, range, op) result (id)

  integer :: id

  character(len=*), intent(in) :: module_name
  character(len=*), intent(in) :: field_name
  integer,          intent(in) :: axes(:)
  type(time_type),  intent(in) :: init_time
  character(len=*), intent(in), optional :: long_name
  character(len=*), intent(in), optional :: units
  real,             intent(in), optional :: missing_value
  real,             intent(in), optional :: range(2)
  integer,          intent(in), optional :: op ! aggregation operation code
  
  id = reg_field(.false., module_name, field_name, init_time, axes, long_name, &
         units, missing_value, range, op=op)

end function

! ============================================================================
function register_tiled_static_field(module_name, field_name, axes, &
     long_name, units, missing_value, range, require, op) result (id)

  integer :: id

  character(len=*), intent(in) :: module_name
  character(len=*), intent(in) :: field_name
  integer,          intent(in) :: axes(:)
  character(len=*), intent(in), optional :: long_name
  character(len=*), intent(in), optional :: units
  real,             intent(in), optional :: missing_value
  real,             intent(in), optional :: range(2)
  logical,          intent(in), optional :: require
  integer,          intent(in), optional :: op ! aggregation operation code
  
  ! --- local vars
  type(time_type) :: init_time

  id = reg_field(.true., module_name, field_name, init_time, axes, long_name, &
         units, missing_value, range, require, op)

end function

! ============================================================================
! provides unified interface for registering a diagnostic field with full set
! of selectors
function reg_field(static, module_name, field_name, init_time, axes, &
     long_name, units, missing_value, range, require, op) result(id)
 
  integer :: id

  logical,          intent(in) :: static
  character(len=*), intent(in) :: module_name
  character(len=*), intent(in) :: field_name
  integer,          intent(in) :: axes(:)
  type(time_type),  intent(in) :: init_time
  character(len=*), intent(in), optional :: long_name
  character(len=*), intent(in), optional :: units
  real,             intent(in), optional :: missing_value
  real,             intent(in), optional :: range(2)
  logical,          intent(in), optional :: require
  integer,          intent(in), optional :: op

  ! ---- local vars
  integer, pointer :: diag_ids(:) ! ids returned by FMS diag manager for each selector
  integer :: i
  integer :: isel    ! selector iterator
  integer :: n_selectors ! number of registered diagnostic tile selectors
  type(tiled_diag_field_type), pointer :: new_fields(:)
  type(tile_selector_type) :: sel
  ! ---- global vars: n_fields, fields, current_offset -- all used and updated

#ifdef USE_LOG_DIAG_FIELD_INFO
  ! log diagnostic field information
  call log_diag_field_info ( module_name, trim(field_name), axes, long_name, units,&
                             missing_value, range, dynamic=.not.static )
#endif
  ! go through all possible selectors and try to register a diagnostic field 
  ! with the name derived from field name and selector; if any of the 
  ! registrations succeeds, return a tiled field id, otherwise return 0.
  ! Note that by design one of the selectors have empty name and selects all
  ! the tiles.
  id = 0
  n_selectors = get_n_selectors()
  allocate(diag_ids(n_selectors))
  
  do isel = 1, n_selectors
     ! try to register field+selector pair with FMS diagnostics manager
     sel = get_selector(isel)
     diag_ids(isel) = reg_field_set(static, sel, module_name, field_name, axes, &
          init_time, long_name, units, missing_value, range, require)

  enddo
  
  if(any(diag_ids>0)) then
     ! if any of the field+selector pairs was found for this field, an entry
     ! must be added to the table of tile diagnostic fields

     ! if there is not enough slots in the field table to add another one,
     ! allocate more space
     if(n_fields>=size(fields)) then
        allocate(new_fields(max(2*n_fields,1)))
        new_fields(1:n_fields) = fields(1:n_fields)
        deallocate(fields)
        fields => new_fields
     endif
     ! add the current field to the field table
     n_fields = n_fields+1
     id       = n_fields
     ! set the array of FMS diagnostic field IDs for each selector
     fields(id)%ids => diag_ids
     ! set the field offset in the diagnostic buffers
     fields(id)%offset = current_offset
     ! calculate field size per tile and increment current offset to
     ! reserve space in per-tile buffers. We assume that the first two axes 
     ! are horizontal coordinates, so their size is not taken into account
     fields(id)%size = 1
     do i = 3, size(axes(:))
        fields(id)%size = fields(id)%size * get_axis_length(axes(i))
     enddo
     current_offset = current_offset + fields(id)%size
     ! store the code of the requested tile aggregation operation
     if(present(op)) then
        fields(id)%op = op
     else
        fields(id)%op = OP_AVERAGE
     endif
     ! store the static field flag
     fields(id)%static = static
     ! zero out the number of data points ent to the field
     fields(id)%n_sends = 0
     ! store the name of the field -- for now, only to be able to see what it is 
     ! in the debugger
     fields(id)%name=field_name
     ! increment the field id by some (large) number to distinguish it from the 
     ! IDs of regular FMS diagnostic fields
     id = id + BASE_TILED_FIELD_ID
  else
     deallocate(diag_ids)
  endif

end function


! ============================================================================
! provides unified interface for registering a diagnostic field with a given
! selector, whether static or time-dependent
function reg_field_set(static, sel, module_name, field_name, axes, init_time, &
     long_name, units, missing_value, range, require) result (id)

  integer :: id 

  logical,          intent(in) :: static
  type(tile_selector_type), intent(in) :: sel
  character(len=*), intent(in) :: module_name
  character(len=*), intent(in) :: field_name
  integer,          intent(in) :: axes(:)
  type(time_type),  intent(in) :: init_time
  character(len=*), intent(in), optional :: long_name
  character(len=*), intent(in), optional :: units
  real,             intent(in), optional :: missing_value
  real,             intent(in), optional :: range(2)
  logical,          intent(in), optional :: require

  character(len=128) :: fname
  character(len=128) :: lname

  ! form field name as concatenation of name of the field and selector suffix
  fname = trim(field_name)//trim(selector_suffix(sel))
  ! form long name as concatenation of specified long name (if present) and
  ! selector long name
  lname = ''
  if(present(long_name)) lname=long_name
  if(trim(sel%long_name)/='') &
     lname = trim(lname)//' ('//trim(sel%long_name)//')'

  ! try registering diagnostic field with FMS diagnostic manager.
  if (static) then
     id = register_static_field ( module_name, fname,   &
#ifdef USE_LOG_DIAG_FIELD_INFO
          axes, lname, units, missing_value, range, require, do_not_log=.TRUE. )
#else
          axes, lname, units, missing_value, range, require )
#endif
  else
     id = register_diag_field ( module_name,  fname,   &
          axes, init_time, lname, units, missing_value, range, &
#ifdef USE_LOG_DIAG_FIELD_INFO
          mask_variant=.true., do_not_log=.TRUE. )
#else
          mask_variant=.true. )
#endif
  endif

end function


! ============================================================================
subroutine send_tile_data_0d(id, x, buffer)
  integer, intent(in) :: id
  real   , intent(in) :: x
  type(diag_buff_type), intent(inout) :: buffer
  
  integer :: idx, i

  if (id <= 0) return

  ! reallocate diagnostic buffer according to the current number and size of 
  ! tiled diag fields
  call realloc_diag_buff(buffer,current_offset)

  ! calculate offset for the current diagnostic field in the buffer
  i = id - BASE_TILED_FIELD_ID 
  idx = fields(i)%offset
  
  ! store the diagnostic data
  buffer%data(idx) = x
  buffer%mask(idx) = .TRUE.

  ! increment sent data counter
  fields(i)%n_sends = fields(i)%n_sends + 1
end subroutine

! ============================================================================
subroutine send_tile_data_1d(id, x, buffer)
  integer, intent(in) :: id
  real   , intent(in) :: x(:)
  type(diag_buff_type), intent(inout) :: buffer

  integer :: is, ie, i
  if (id <= 0) return

  ! reallocate diagnostic buffer according to the current number and size of 
  ! tiled diag fields
  call realloc_diag_buff(buffer, current_offset)
  
  ! calculate offset for the current diagnostic field in the buffer
  i = id - BASE_TILED_FIELD_ID ! index in the array of fields
  is = fields(i)%offset ; ie = is+fields(i)%size-1

  ! store the data
  buffer%data(is:ie) = x(:)
  buffer%mask(is:ie) = .TRUE.

  ! increment sent data counter
  fields(i)%n_sends = fields(i)%n_sends + 1
end subroutine

! NOTE: 2-d fields can be handled similarly to 1-d with reshape

! ============================================================================
subroutine send_tile_data_r0d_fptr(id, tile_map, fptr)
  integer, intent(in) :: id
  type(land_tile_list_type), intent(inout) :: tile_map(:,:)
  ! subroutine returning the pointer to the tile data
  interface
     subroutine fptr(tile, ptr)
       use land_tile_mod, only : land_tile_type
       type(land_tile_type), pointer :: tile ! input
       real                , pointer :: ptr  ! returned pointer to the data
     end subroutine fptr 
  end interface

  type(land_tile_enum_type)     :: te,ce   ! tail and current tile list elements
  type(land_tile_type), pointer :: tileptr ! pointer to tile   
  real                , pointer :: ptr     ! pointer to the data element within a tile

  if(id <= 0) return
  ce = first_elmt( tile_map )
  te = tail_elmt ( tile_map )
  do while(ce /= te)
     tileptr => current_tile(ce)
     call fptr(tileptr,ptr)
     if(associated(ptr)) call send_tile_data(id,ptr,tileptr%diag)
     ce=next_elmt(ce)
  enddo
end subroutine


! ============================================================================
subroutine send_tile_data_r1d_fptr(id, tile_map, fptr)
  integer, intent(in) :: id
  type(land_tile_list_type), intent(inout) :: tile_map(:,:)
  ! subroutine returning the pointer to the tile data
  interface
     subroutine fptr(tile, ptr)
       use land_tile_mod, only : land_tile_type
       type(land_tile_type), pointer :: tile ! input
       real                , pointer :: ptr(:)  ! returned pointer to the data
     end subroutine fptr 
  end interface

  type(land_tile_enum_type)     :: te,ce   ! tail and current tile list elements
  type(land_tile_type), pointer :: tileptr ! pointer to tile   
  real                , pointer :: ptr(:)     ! pointer to the data element within a tile

  if(id <= 0) return
  ce = first_elmt( tile_map )
  te = tail_elmt ( tile_map )
  do while(ce /= te)
     tileptr => current_tile(ce)
     call fptr(tileptr,ptr)
     if(associated(ptr)) call send_tile_data(id,ptr,tileptr%diag)
     ce=next_elmt(ce)
  enddo
end subroutine


! ============================================================================
subroutine send_tile_data_i0d_fptr(id, tile_map, fptr)
  integer, intent(in) :: id
  type(land_tile_list_type), intent(inout) :: tile_map(:,:)
  ! subroutine returning the pointer to the tile data
  interface
     subroutine fptr(tile, ptr)
       use land_tile_mod, only : land_tile_type
       type(land_tile_type), pointer :: tile ! input
       integer             , pointer :: ptr  ! returned pointer to the data
     end subroutine fptr 
  end interface

  type(land_tile_enum_type)     :: te,ce   ! tail and current tile list elements
  type(land_tile_type), pointer :: tileptr ! pointer to tile   
  integer             , pointer :: ptr     ! pointer to the data element within a tile

  if(id <= 0) return
  ce = first_elmt( tile_map )
  te = tail_elmt ( tile_map )
  do while(ce /= te)
     tileptr => current_tile(ce)
     call fptr(tileptr,ptr)
     if(associated(ptr)) call send_tile_data(id,real(ptr),tileptr%diag)
     ce=next_elmt(ce)
  enddo
end subroutine


! ============================================================================
subroutine dump_tile_diag_fields(tiles, time)
  type(land_tile_list_type), intent(in) :: tiles(:,:) ! 
  type(time_type)          , intent(in) :: time       ! current time

  ! ---- local vars
  integer :: ifld ! field number
  integer :: isel ! selector number
  type(land_tile_enum_type)     :: ce, te
  type(land_tile_type), pointer :: tile
  integer :: total_n_sends(n_fields)
  ! ---- local static variables -- saved between calls
  logical :: first_dump = .TRUE.

  total_n_sends(:) = fields(1:n_fields)%n_sends
  call mpp_sum(total_n_sends, n_fields, pelist=lnd%pelist)

  do ifld = 1, n_fields
     if (total_n_sends(ifld) == 0) cycle ! no data to send 
     do isel = 1, get_n_selectors()
        if (fields(ifld)%ids(isel) <= 0) cycle
        call dump_diag_field_with_sel ( fields(ifld)%ids(isel), tiles, &
             fields(ifld), get_selector(isel), time )
     enddo
  enddo
  ! zero out the number of data points sent to the field 
  fields(1:n_fields)%n_sends=0

  ! all the data are sent to the output, so set the data presence tag to FALSE 
  ! in all diag buffers in preparation for the next time step
  ce = first_elmt(tiles)
  te = tail_elmt (tiles)
  do while(ce /= te)
    tile => current_tile(ce)       ! get the pointer to the current tile
    tile%diag%mask(:) = .FALSE.
    ce = next_elmt(ce)            ! move to the next position
  enddo
  ! reset the first_dump flag
  first_dump = .FALSE.

end subroutine

! ============================================================================
subroutine dump_diag_field_with_sel(id, tiles, field, sel, time)
  integer :: id
  type(land_tile_list_type),   intent(in) :: tiles(:,:)
  type(tiled_diag_field_type), intent(in) :: field
  type(tile_selector_type)   , intent(in) :: sel
  type(time_type)            , intent(in) :: time ! current time
   
  ! ---- local vars
  integer :: i,j ! iterators
  integer :: is,ie,js,je,ks,ke ! array boundaries
  logical :: used ! value returned from send_data (ignored)
  real, allocatable :: buffer(:,:,:), weight(:,:,:)
  type(land_tile_enum_type)     :: ce, te
  type(land_tile_type), pointer :: tile
  
  ! calculate array boundaries
  is = lbound(tiles,1); ie = ubound(tiles,1)
  js = lbound(tiles,2); je = ubound(tiles,2)
  ks = field%offset   ; ke = field%offset + field%size - 1
  
  ! allocate and initialize temporary buffers
  allocate(buffer(is:ie,js:je,ks:ke), weight(is:ie,js:je,ks:ke))
  buffer(:,:,:) = 0.0
  weight(:,:,:) = 0.0
  
  ! accumulate data
  ce = first_elmt(tiles, is=is, js=js)
  te = tail_elmt (tiles)
  do while(ce /= te)
    tile => current_tile(ce)      ! get the pointer to current tile
    call get_elmt_indices(ce,i,j) ! get the indices of current tile
    ce = next_elmt(ce)           ! move to the next position
    
    if ( size(tile%diag%data) < ke )       cycle ! do nothing if there is no data in the buffer
    if ( .not.tile_is_selected(tile,sel) ) cycle ! do nothing if tile is not selected
    select case (field%op)
    case (OP_AVERAGE)
       where(tile%diag%mask(ks:ke)) 
          buffer(i,j,:) = buffer(i,j,:) + tile%diag%data(ks:ke)*tile%frac
          weight(i,j,:) = weight(i,j,:) + tile%frac
       end where
    case (OP_SUM)
       where(tile%diag%mask(ks:ke)) 
          buffer(i,j,:) = buffer(i,j,:) + tile%diag%data(ks:ke)
          weight(i,j,:) = 1
       end where
    end select
  enddo

  ! normalize accumulated data
  where (weight>0) buffer=buffer/weight
  
  ! send diag field
  used = send_data ( id, buffer, time, mask=weight>0 )   

  ! clean up temporary data
  deallocate(buffer,weight)

end subroutine


end module land_tile_diag_mod


module tile_diag_buff_mod

implicit none
private

! ==== public interfaces =====================================================
public :: diag_buff_type
public :: new_diag_buff, delete_diag_buff, realloc_diag_buff
! ==== end of public interfaces ==============================================
interface new_diag_buff
   module procedure diag_buff_ctor
   module procedure diag_buff_copy_ctor
end interface

! storage for tile diagnostic data
type :: diag_buff_type
   real   , pointer :: data(:) => NULL()
   logical, pointer :: mask(:) => NULL()
end type diag_buff_type

! ==== module constants =====================================================
integer, parameter :: MIN_DIAG_BUFF_SIZE = 1
character(len=*), parameter :: &
     version = '$Id: land_tile_diag_buff.F90,v 17.0 2009/07/21 03:02:39 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ============================================================================
function diag_buff_ctor() result(buffer)
  type(diag_buff_type), pointer :: buffer
  
  integer :: m ! initial size of the buffer
  
  allocate(buffer)
  m = MIN_DIAG_BUFF_SIZE
  allocate(buffer%mask(m),buffer%data(m))
  ! initialize buffer content
  buffer%mask(:) = .FALSE.
  buffer%data(:) = 0.0
end function


! ============================================================================
function diag_buff_copy_ctor(buffer) result(ptr)
  type(diag_buff_type), pointer :: ptr ! return value
  type(diag_buff_type), intent(in) :: buffer ! buffer to copy
  
  allocate(ptr)
  allocate(ptr%mask(size(buffer%mask)),ptr%data(size(buffer%data)))
  ! initialize buffer content
  ptr%mask(:) = buffer%mask(:)
  ptr%data(:) = buffer%data(:)
end function


! ============================================================================
subroutine delete_diag_buff(buffer)
  type(diag_buff_type), pointer :: buffer
  
  if(.not.associated(buffer)) return
  deallocate(buffer%mask,buffer%data)
  deallocate(buffer)
  
end subroutine


! ============================================================================
! reallocates buffer to have at least m elements
subroutine realloc_diag_buff(buffer, m)
  type(diag_buff_type), intent(inout) :: buffer
  integer             , intent(in)    :: m 

  real    , pointer :: new_data(:)
  logical , pointer :: new_mask(:)
  integer           :: n

  ! n is size of the original buffer; m is the current size of the buffer
  ! for all diagnostic fields
  n = size(buffer%data(:))
  ! do nothing if buffer is big enough
  if(n >= m) return

  allocate(new_data(m), new_mask(m))
  new_data(1:n) = buffer%data(1:n) ; new_data(n+1:m) = 0.0
  new_mask(1:n) = buffer%mask(1:n) ; new_mask(n+1:m) = .FALSE.
  deallocate(buffer%data, buffer%mask)

  buffer%data=>new_data
  buffer%mask=>new_mask

end subroutine


end module tile_diag_buff_mod


module land_tile_selectors_mod

use fms_mod, only : error_mesg, WARNING

implicit none
private

! ==== public interface ======================================================
public :: tile_selector_type      !

! selector tags
public :: SEL_SOIL, SEL_VEGN, SEL_LAKE, SEL_GLAC, SEL_SNOW, SEL_CANA

public :: tile_selectors_init     ! initialize module
public :: tile_selectors_end      ! clean up ufter ourselves

public :: register_tile_selector  ! register selector for diag field
public :: selector_suffix         ! return suffix for the field name

public :: get_selector            ! array of selectors
public :: get_n_selectors         ! number of available selectors
! ==== end of public interface ===============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'land_tile_selectors_mod', &
     version     = '$Id: land_tile_diag_sel.F90,v 18.0 2010/03/02 23:37:10 fms Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'

integer, parameter :: SEL_LEN           = 16  ! max length of the selector name
integer, parameter :: SEL_LONG_NAME_LEN = 128 ! max name of the selector long name
integer, parameter :: INIT_SEL_SIZE     = 1   ! initial size of the array of selectors

! tags for tile-specific diagnostic selectors
integer, parameter :: SEL_SOIL = 1
integer, parameter :: SEL_VEGN = 2
integer, parameter :: SEL_LAKE = 3
integer, parameter :: SEL_GLAC = 4
integer, parameter :: SEL_SNOW = 5
integer, parameter :: SEL_CANA = 6

! ==== derived types =========================================================
type :: tile_selector_type
   character(len=SEL_LEN)           :: name =''          ! name of the selector
   character(len=SEL_LONG_NAME_LEN) :: long_name = ''    ! long name of the selector
   logical, pointer                 :: mask(:) => NULL() ! mask (selector cache)
   integer :: tag = 0 ! tag of the model component
   integer :: idata1=0, idata2=0 ! integer data
   integer :: rdata1=0, rdata2=0 ! real data
end type tile_selector_type

! ==== module private data ===================================================
logical :: module_is_initialized = .false.

! ==== module public data ====================================================
! array of registered selectors
type(tile_selector_type), pointer :: selectors(:) => NULL()
integer :: n_selectors = 0 ! number of registered selectors

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ============================================================================
subroutine tile_selectors_init()

  if (module_is_initialized) return

  module_is_initialized = .true.

  allocate (selectors(INIT_SEL_SIZE))
  n_selectors = 0 ! initialize number of regitered selectors
  ! register couple of default selectors (for all tiles and for each tile)
end subroutine tile_selectors_init


! ============================================================================
subroutine tile_selectors_end()

  integer :: i

  module_is_initialized = .false.
  do i = 1,n_selectors
     if(associated(selectors(i)%mask)) deallocate(selectors(i)%mask)
  enddo
  deallocate(selectors)
  n_selectors = 0
end subroutine tile_selectors_end


! ============================================================================
! registers a selector to be used for diagnostic output 
subroutine register_tile_selector( name, long_name, tag, idata1, idata2, rdata1, rdata2 )
  character(len=*), intent(in) :: name
  character(len=*), intent(in), optional :: long_name
  integer, intent(in), optional :: tag
  integer, intent(in), optional :: idata1, idata2
  real,    intent(in), optional :: rdata1, rdata2

  ! ---- local vars
  type(tile_selector_type), pointer :: new_selectors(:)
  character(len=SEL_LEN) :: name_
  integer :: i

  ! check for conflict of names -- presumably, if the selector was already
  ! registered, then it is an error to register it again
  name_=name
  do i = 1, n_selectors
     if (trim(name_)==trim(selectors(i)%name)) then
        call error_mesg(module_name,'attempt to register selector "'&
             //trim(name)//'" which has already been registered',WARNING)
        return ! just skip it 
     endif
  enddo

  ! allocate additional space for selectors if necessary 
  if(n_selectors >= size(selectors)) then
     allocate(new_selectors(max(n_selectors*2,1)))
     new_selectors(1:n_selectors) = selectors(1:n_selectors)
     deallocate(selectors)
     selectors => new_selectors
  endif

  ! set up the selector values
  n_selectors = n_selectors + 1
  selectors(n_selectors)%name = name
  if (present(long_name)) &
       selectors(n_selectors)%long_name = long_name
  if (present(tag)) selectors(n_selectors)%tag = tag
  if (present(idata1)) selectors(n_selectors)%idata1 = idata1
  if (present(idata2)) selectors(n_selectors)%idata2 = idata2
  if (present(rdata1)) selectors(n_selectors)%rdata1 = rdata1
  if (present(rdata2)) selectors(n_selectors)%rdata2 = rdata2
end subroutine register_tile_selector


! ============================================================================
! returns total number of selectors
function get_n_selectors()
  integer :: get_n_selectors
  get_n_selectors = n_selectors
end function 

! ============================================================================
! retrns n-th selector
function get_selector(n) result (sel)
  type(tile_selector_type) :: sel
  integer, intent(in) :: n

  if (n<1.or.n>get_n_selectors()) return
  sel = selectors(n)

end function 


! ============================================================================
! returns variable suffix for given selector
function selector_suffix(selector)
  character(len=SEL_LEN+1) :: selector_suffix
  type(tile_selector_type), intent(in) :: selector
  
  if(trim(selector%name)=='') then
     selector_suffix = ''
  else
     selector_suffix = '_'//trim(selector%name)
  endif
end function selector_suffix


! ============================================================================
subroutine update_tile_selectors()

  integer :: i
  do i = 1,n_selectors
     if(associated(selectors(i)%mask)) deallocate(selectors(i)%mask)
  enddo
end subroutine update_tile_selectors



end module land_tile_selectors_mod


module land_tile_io_mod

use mpp_mod, only : mpp_send, mpp_recv, mpp_sync
use fms_mod, only : error_mesg, FATAL, mpp_pe, get_mosaic_tile_file
use time_manager_mod, only : time_type
use data_override_mod, only : data_override

use nf_utils_mod, only : nfu_inq_dim, nfu_inq_var, nfu_def_dim, nfu_def_var, &
     nfu_get_var, nfu_put_att
use land_io_mod, only : print_netcdf_error, read_field
use land_tile_mod, only : land_tile_type, land_tile_list_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=), &
     get_elmt_indices
use land_data_mod, only  : lnd
use land_utils_mod, only : put_to_tiles_r0d_fptr

implicit none
private

! ==== public interfaces =====================================================
! restart i/o subroutines: those use CF "compression by gathering" technique
! to pack tile data.
public :: create_tile_out_file
public :: read_tile_data_r0d_fptr,  read_tile_data_r1d_fptr
public :: read_tile_data_i0d_fptr
public :: write_tile_data_r0d_fptr, write_tile_data_r1d_fptr
public :: write_tile_data_i0d_fptr

! data override subroutines
public :: override_tile_data_r0d_fptr

! auxiliary subroutines
public :: get_tile_by_idx
public :: print_netcdf_error

public :: read_field

public :: get_input_restart_name

public :: sync_nc_files ! synchronizes writer and reader processors
! ==== end of public interfaces ==============================================
interface create_tile_out_file
   module procedure create_tile_out_file_idx
   module procedure create_tile_out_file_fptr
end interface

interface read_tile_data_r1d_fptr
   module procedure read_tile_data_r1d_fptr_all
   module procedure read_tile_data_r1d_fptr_idx
end interface

interface write_tile_data_r1d_fptr
   module procedure write_tile_data_r1d_fptr_all
   module procedure write_tile_data_r1d_fptr_idx
end interface

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'land_tile_io_mod', &
     version     = '$Id: land_tile_io.F90,v 17.0.2.3.2.1 2010/06/28 14:44:52 pjp Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'
! name of the "compressed" dimension (and dimension variable) in the output 
! netcdf files -- that is, the dimensions written out using compression by 
! gathering, as described in CF conventions. See subroutines write_tile_data,
! read_tile_data, read_unpack_tile_data, write_cohort_data
character(len=*),   parameter :: tile_index_name   = 'tile_index'
integer, parameter :: INPUT_BUF_SIZE=1024 ! size of the input buffer for tile input 


! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)


contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! =============================================================================
! given a generic name of the restart file, checks if a file with one of the 
! possible restarts file names exists, and if it does returns the tile-qualified 
! (or tile- and processor-qualified) name of the restart.
subroutine get_input_restart_name(name, restart_exists, actual_name)
  character(*), intent(in)  :: name        ! "generic" name of the restart
  logical     , intent(out) :: restart_exists ! TRUE if any file found
  character(*), intent(out) :: actual_name ! name of the found file, if any

  ! ---- local vars
  character(6) :: PE_suffix ! PE number
  
  call get_mosaic_tile_file(trim(name),actual_name,.FALSE.,lnd%domain)
  ! we can't use fms file_exist function here, because it lies: it checks not
  ! just the original name, but the name with PE suffix, and returns true if
  ! either of those exist
  inquire (file=trim(actual_name), exist=restart_exists)
  if (.NOT.restart_exists) then
     ! try the name with current PE number attached
     write(PE_suffix,'(".",I4.4)') lnd%io_id
     actual_name = trim(actual_name)//trim(PE_suffix)
     inquire (file=trim(actual_name), exist=restart_exists)
  endif

end subroutine

! =============================================================================
! this subroutine creates netcdf file for output of tiled data using "compression
! by gathering," as described in CF conventions, and creates coordinate system
! necessary for write_tile_data subroutines.
! In particular:
!  "compressed" dimension and integer variable with appropriate attributes, with 
! variable filled with packing indices
!   horizontal dimensions "lat" and "lon" with associated variable, and boundaries, 
! describing global grid
!   dimension "tile," without any associated variable. length of this dimension is
! equal to current global max of number of tiles per grid cell
!
! The file is actually created only by root processor of our io_domain; the rest 
! of the processors just open the created file in NOWRITE mode. 
subroutine create_tile_out_file_idx(ncid, name, glon, glat, tidx, tile_dim_length, reserve)
  integer          , intent(out) :: ncid      ! resulting NetCDF id
  character(len=*) , intent(in)  :: name      ! name of the file to create
  real             , intent(in)  :: glon(:)   ! longitudes of the grid centers
  real             , intent(in)  :: glat(:)   ! latitudes of the grid centers
  integer          , intent(in)  :: tidx(:)   ! integer compressed index of tiles
  integer          , intent(in)  :: tile_dim_length ! length of tile axis
  integer, optional, intent(in)  :: reserve   ! amount of space to reserve for 
  ! header expansion. This subroutine and following calls to write_tile_data
  ! will work even if this is set to 0, but for efficiency it is useful to
  ! specify some non-zero value, so that netcdf library do not have to rewrite
  ! entire file each time a new variable is added. Default value (8K) should do
  ! fine in most cases.

  ! ---- local vars
  integer        :: reserve_  ! local value of space to reserve at the end of NetCDF header
  character(256) :: full_name ! full name of the file, including the processor number
  character(6)   :: PE_suffix ! PE number
  integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain
  integer, allocatable :: tidx2(:)  ! array of tile indices from all PEs in io_domain
  integer :: p ! io_domain PE iterator 
  integer :: k ! current index in tidx2 array for receive operation

  ! form the full name of the file
  call get_mosaic_tile_file(name,full_name,.FALSE.,lnd%domain)
  write(PE_suffix,'(".",I4.4)') lnd%io_id
  full_name = trim(full_name)//trim(PE_suffix)

  if(tile_dim_length<=0) &
    call error_mesg('create_tile_out_file','tile axis length must be positive', FATAL)

  if (mpp_pe()/=lnd%io_pelist(1)) then
     ! if current PE doesn't do io, we just send the data to the processor that
     ! does
     call mpp_send(size(tidx), plen=1,          to_pe=lnd%io_pelist(1))
     call mpp_send(tidx(1),    plen=size(tidx), to_pe=lnd%io_pelist(1))
  else
     ! gather an array of tile sizes from all processors in our io_domain
     allocate(ntiles(size(lnd%io_pelist)))
     ntiles(1) = size(tidx)
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1)
     enddo
     ! gather tile indices from all processors in our io_domain
     allocate(tidx2(sum(ntiles(:))))
     tidx2(1:ntiles(1))=tidx(:)
     k=ntiles(1)+1
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(tidx2(k), from_pe=lnd%io_pelist(p), glen=ntiles(p))
        k = k+ntiles(p)
     enddo

     ! create netcdf file
#ifdef use_netCDF3
     __NF_ASRT__(nf_create(full_name,NF_CLOBBER,ncid))
#elif use_LARGEFILE
     __NF_ASRT__(nf_create(full_name,IOR(NF_64BIT_OFFSET,NF_CLOBBER),ncid))
#else
     __NF_ASRT__(nf_create(full_name,IOR(NF_NETCDF4,NF_CLASSIC_MODEL),ncid))
#endif

     ! create lon, lat, dimensions and variables
     __NF_ASRT__(nfu_def_dim(ncid,'lon' ,glon(:) ,'longitude','degrees_east'))
     __NF_ASRT__(nfu_def_dim(ncid,'lat' ,glat(:) ,'latitude','degrees_north'))

     __NF_ASRT__(nfu_def_dim(ncid,'tile',tile_dim_length))
     ! the size of tile dimension really does not matter for the output, but it does
     ! matter for uncompressing utility, since it uses it as a size of the array to
     ! unpack to
     ! create tile index dimension and variable
     __NF_ASRT__(nfu_def_dim(ncid,tile_index_name,tidx2,'compressed land point index'))
     __NF_ASRT__(nfu_put_att(ncid,tile_index_name,'compress','tile lat lon'))
     __NF_ASRT__(nfu_put_att(ncid,tile_index_name,'valid_min',0))
     ! release the data we no longer need
     deallocate(ntiles,tidx2)

     ! determine the local value of space reserved in the header; by default 16K
     reserve_ = 1024*16
     if(PRESENT(reserve)) reserve_ = reserve

     ! end definition mode, reserving some space for future additions
     ! this call also commits the changes to the disk
     __NF_ASRT__(nf__enddef(ncid,reserve_,4,0,4))
     ! arguments are ncid,h_minfree,v_align,v_minfree,r_align; default is (ncid,0,4,0,4).
     ! The above call reserves some space at the end of the netcdf header for
     ! future expansion without library's having to rewrite the entire file. See 
     ! manual pages netcdf(3f) or netcdf(3) for more information.
  endif
  ! make sure send-receive operations and file creation have finished
  call mpp_sync(lnd%io_pelist)
  ! open file on non-writing processors to have access to the tile index
  if (mpp_pe()/=lnd%io_pelist(1)) then
     __NF_ASRT__(nf_open(full_name,NF_NOWRITE,ncid))
  endif
end subroutine create_tile_out_file_idx

! =============================================================================
subroutine create_tile_out_file_fptr(ncid, name, glon, glat, tile_exists, &
     tile_dim_length, reserve, created)
  integer          , intent(out) :: ncid      ! resulting NetCDF id
  character(len=*) , intent(in)  :: name      ! name of the file to create
  real             , intent(in)  :: glon(:)   ! longitudes of the grid centers
  real             , intent(in)  :: glat(:)   ! latitudes of the grid centers
  integer          , intent(in)  :: tile_dim_length ! length of tile axis
  integer, optional, intent(in)  :: reserve   ! amount of space to reserve for
  logical, optional, intent(out) :: created   ! indicates wether the file was 
      ! created; it is set to false if no restart needs to be written, in case 
      ! the total number of qualifying tiles in this domain is equal to zero
  ! the following interface describes the "detector function", which is passed 
  ! through the argument list and must return true for any tile to be written 
  ! to the specific restart, false otherwise
  interface
     logical function tile_exists(tile)
        use land_tile_mod, only : land_tile_type
        type(land_tile_type), pointer :: tile
     end function tile_exists
  end interface

  ! ---- local vars
  type(land_tile_enum_type) :: ce, te ! tile list elements
  integer, allocatable :: idx(:)   ! integer compressed index of tiles
  integer :: i,j,k,n

  ! count total number of tiles in this domain
  ce = first_elmt(lnd%tile_map, lnd%is, lnd%js)
  te = tail_elmt (lnd%tile_map)
  n  = 0
  do while (ce/=te)
     if (tile_exists(current_tile(ce))) n = n+1
     ce=next_elmt(ce)
  end do
  
  ! calculate compressed tile index to be written to the restart file;
  allocate(idx(max(n,1))); idx(:) = -1 ! set init value to a known invalid index
  ce = first_elmt(lnd%tile_map, lnd%is, lnd%js)
  n = 1
  do while (ce/=te)
     call get_elmt_indices(ce,i,j,k)
     
     if(tile_exists(current_tile(ce))) then
        idx (n) = (k-1)*lnd%nlon*lnd%nlat + (j-1)*lnd%nlon + (i-1)
        n = n+1
     endif
     ce=next_elmt(ce)
  end do
  ! create tile output file, defining horizontal coordinate and compressed
  ! dimension
  call create_tile_out_file_idx(ncid, name, glon, glat, idx, tile_dim_length, reserve)

  if (present(created)) created = .TRUE.
  
end subroutine

! ============================================================================
! given compressed index, sizes of the global grid, 2D array of tile lists
! and the lower boundaries of this array returns a pointer to the tile
! corresponding to the compressed index, or NULL is the index is outside 
! current domain, or such tile does not exist.
subroutine get_tile_by_idx(idx,nlon,nlat,tiles,is,js,ptr)
   integer, intent(in) :: idx ! index
   integer, intent(in) :: nlon, nlat
   integer, intent(in) :: is, js
   type(land_tile_list_type), intent(in) :: tiles(is:,js:)
   type(land_tile_type), pointer :: ptr

   ! ---- local vars
   integer :: i,j,k
   type(land_tile_enum_type) :: ce,te
   
   ptr=>NULL()

   if(idx<0) return ! negative indices do not correspond to any tile

   ! given tile idx, calculate global lon, lat, and tile indices
   k = idx
   i = modulo(k,nlon)+1 ; k = k/nlon
   j = modulo(k,nlat)+1 ; k = k/nlat
   ! do nothing if the indices is outside of our domain
   if (i<is.or.i>is+size(tiles,1)-1) return ! skip points outside of domain
   if (j<js.or.j>js+size(tiles,2)-1) return ! skip points outside of domain
   ! loop through the list of tiles at the given point to find k+1st tile
   ce = first_elmt (tiles(i,j))
   te = tail_elmt  (tiles(i,j))
   do while(ce/=te.and.k>0)
     ce=next_elmt(ce); k = k-1
   enddo
   ! set the returned pointer   
   ! NOTE that if (ce==te) at the end of the loop (that is, there are less
   ! tiles in the list then requested by the idx), current_tile(ce) returns
   ! NULL
   ptr=>current_tile(ce)
   
end subroutine


! ============================================================================
! given the netcdf file id, name of the variable, and accessor subroutine, this
! subroutine reads integer 2D data (a scalar value per grid cell, that's why 
! there is 0d in the name of this subroutine) and assigns the input values to 
! each tile in respective grid cell.  
subroutine read_tile_data_i0d_fptr(ncid,name,fptr)
   integer     , intent(in) :: ncid ! netcdf file id
   character(*), intent(in) :: name ! name of the variable to read
   ! subroutine returning the pointer to the data to be written
   interface ; subroutine fptr(tile, ptr)
      use land_tile_mod, only : land_tile_type
      type(land_tile_type), pointer :: tile ! input
      integer             , pointer :: ptr  ! returned pointer to the data
    end subroutine fptr 
   end interface
   
   ! ---- local constants
   character(*), parameter :: module_name='read_tile_data_i0d_fptr'
   ! ---- local vars
   integer :: ndims     ! number of the variable dimensions
   integer :: dimids(1) ! IDs of the variable dimensions
   integer :: dimlen(1) ! size of the variable dimensions
   character(NF_MAX_NAME) :: idxname ! name of the index variable
   integer, allocatable :: idx(:) ! storage for compressed index 
   integer, allocatable :: x1d(:) ! storage for the data
   integer :: i,j,bufsize
   integer :: varid, idxid
   type(land_tile_type), pointer :: tileptr ! pointer to tile   
   integer, pointer :: ptr
   
   ! get the number of variable dimensions, and their lengths
   __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen))
   if(ndims/=1) then
      call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL)
   endif
   ! get the name of compressed dimension and ID of corresponding variable
   __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname))
   __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid))
   ! allocate input buffers for compression index and the variable
   bufsize = min(INPUT_BUF_SIZE,dimlen(1))
   allocate(idx(bufsize),x1d(bufsize))
   ! read the input buffer-by-buffer
   do j = 1,dimlen(1),bufsize
      ! read the index variable
      __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx))
      ! read the data
      __NF_ASRT__(nf_get_vara_int(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d))
      ! distribute the data over the tiles
      do i = 1, min(INPUT_BUF_SIZE,dimlen(1)-j+1)
         call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                              lnd%is,lnd%js, tileptr)
         call fptr(tileptr, ptr)
         if(associated(ptr)) ptr = x1d(i)
      enddo
   enddo
   ! release allocated memory
   deallocate(idx,x1d)
end subroutine


! ============================================================================
subroutine read_tile_data_r0d_fptr(ncid,name,fptr)
   integer     , intent(in) :: ncid ! netcdf file id
   character(*), intent(in) :: name ! name of the variable to read
   ! subroutine returning the pointer to the data to be written
   interface ; subroutine fptr(tile, ptr)
      use land_tile_mod, only : land_tile_type
      type(land_tile_type), pointer :: tile ! input
      real                , pointer :: ptr  ! returned pointer to the data
   end subroutine fptr
   end interface
   
   ! ---- local constants
   character(*), parameter :: module_name='read_tile_data_r0d_fptr'
   ! ---- local vars
   integer :: ndims     ! number of the variable dimensions
   integer :: dimids(1) ! IDs of the variable dimensions
   integer :: dimlen(1) ! size of the variable dimensions
   character(NF_MAX_NAME) :: idxname ! name of the index variable
   integer, allocatable :: idx(:) ! storage for compressed index 
   real   , allocatable :: x1d(:) ! storage for the data
   integer :: i, j, bufsize
   integer :: varid, idxid
   type(land_tile_type), pointer :: tileptr ! pointer to tile   
   real, pointer :: ptr
   
   ! get the number of variable dimensions, and their lengths
   __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen))
   if(ndims/=1) then
      call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL)
   endif
   ! get the name of compressed dimension and ID of corresponding variable
   __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname))
   __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid))
   ! allocate input buffers for compression index and the variable
   bufsize=min(INPUT_BUF_SIZE,dimlen(1))
   allocate(idx(bufsize),x1d(bufsize))
   ! read the input buffer-by-buffer
   do j = 1,dimlen(1),bufsize
      ! read the index variable
      __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx))
      ! read the data
      __NF_ASRT__(nf_get_vara_double(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d))
      ! distribute the data over the tiles
      do i = 1, min(bufsize,dimlen(1)-j+1)
         call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                              lnd%is,lnd%js, tileptr)
         call fptr(tileptr, ptr)
         if(associated(ptr)) ptr = x1d(i)
      enddo
   enddo
   ! release allocated memory
   deallocate(idx,x1d)
end subroutine

! ============================================================================
subroutine read_tile_data_r1d_fptr_all(ncid,name,fptr)
   integer     , intent(in) :: ncid ! netcdf file id
   character(*), intent(in) :: name ! name of the variable to read
   ! subroutine returning the pointer to the data to be written
   interface ; subroutine fptr(tile, ptr)
      use land_tile_mod, only : land_tile_type
      type(land_tile_type), pointer :: tile ! input
      real                , pointer :: ptr(:) ! returned pointer to the data
   end subroutine fptr
   end interface
   
   ! ---- local constants
   character(*), parameter :: module_name='read_tile_data_r1d_fptr'
   ! ---- local vars
   integer :: ndims     ! number of the variable dimensions
   integer :: dimids(2) ! IDs of the variable dimensions
   integer :: dimlen(2) ! size of the variable dimensions
   character(NF_MAX_NAME) :: idxname ! name of the index variable
   integer, allocatable :: idx(:)   ! storage for compressed index 
   real   , allocatable :: x1d(:)   ! storage for the data
   integer :: i, j, bufsize
   integer :: varid,idxid
   integer :: start(2), count(2) ! input slab parameters
   type(land_tile_type), pointer :: tileptr ! pointer to tile   
   real, pointer :: ptr(:)
   
   ! get the number of variable dimensions, and their lengths
   __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen))
   if(ndims/=2) then
      call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 2-dimensional', FATAL)
   endif
   ! get the name of compressed dimension and ID of corresponding variable
   __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname))
   __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid))
   ! allocate input buffers for compression index and the variable
   bufsize=min(INPUT_BUF_SIZE,dimlen(1))
   allocate(idx(bufsize),x1d(bufsize*dimlen(2)))
   ! read the input buffer-by-buffer
   do j = 1,dimlen(1),bufsize
      ! set up slab parameters
      start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1)
      start(2) = 1 ; count(2) = dimlen(2)
      ! read the index variable
      __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx))
      ! read the data
      __NF_ASRT__(nf_get_vara_double(ncid,varid,start,count,x1d))
      ! distribute the data over the tiles
      do i = 1, min(bufsize,dimlen(1)-j+1)
         call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                              lnd%is,lnd%js, tileptr)
         call fptr(tileptr, ptr)
         if(associated(ptr)) ptr(:) = x1d(i:count(1)*count(2):count(1))
      enddo
   enddo
   ! release allocated memory
   deallocate(idx,x1d)
end subroutine


! ============================================================================
subroutine read_tile_data_r1d_fptr_idx (ncid,name,fptr,index)
   integer     , intent(in) :: ncid ! netcdf file id
   character(*), intent(in) :: name ! name of the variable to read
   ! subroutine returning the pointer to the data to be written
   interface ; subroutine fptr(tile, ptr)
      use land_tile_mod, only : land_tile_type
      type(land_tile_type), pointer :: tile ! input
      real                , pointer :: ptr(:) ! returned pointer to the data
   end subroutine fptr 
   end interface
   integer    , intent(in) :: index ! index where to read the data
   
   ! ---- local constants
   character(*), parameter :: module_name='read_tile_data_r0d_fptr'
   ! ---- local vars
   integer :: ndims     ! number of the variable dimensions
   integer :: dimids(1) ! IDs of the variable dimensions
   integer :: dimlen(1) ! size of the variable dimensions
   character(NF_MAX_NAME) :: idxname ! name of the index variable
   integer, allocatable :: idx(:) ! storage for compressed index 
   real   , allocatable :: x1d(:) ! storage for the data
   integer :: i,j,bufsize
   integer :: varid, idxid
   type(land_tile_type), pointer :: tileptr ! pointer to tile   
   real, pointer :: ptr(:)
   
   ! get the number of variable dimensions, and their lengths
   __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen))
   if(ndims/=1) then
      call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL)
   endif
   ! get the name of compressed dimension and ID of corresponding variable
   __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname))
   __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid))
   ! allocate input buffers for compression index and the variable
   bufsize=min(INPUT_BUF_SIZE,dimlen(1))
   allocate(idx(bufsize),x1d(bufsize))
   ! read the input buffer-by-buffer
   do j = 1,dimlen(1),bufsize
      ! read the index variable
      __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx))
      ! read the data
      __NF_ASRT__(nf_get_vara_double(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d))
      ! distribute the data over the tiles
      do i = 1, min(bufsize,dimlen(1)-j+1)
         call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                              lnd%is,lnd%js, tileptr)
         call fptr(tileptr, ptr)
         if(associated(ptr)) ptr(index) = x1d(i)
      enddo
   enddo
   ! release allocated memory
   deallocate(idx,x1d)
end subroutine


! ============================================================================
! The subroutines write_tile_data_* below write tiled data (that is, data provided
! in arrays congruous with current tiling) to NetCDF files using "compression
! by gathering" (see CF conventions). They assume that the compressed dimension
! is already created, has certain name (see parameter "tile_index_name" at the beginning
! of this file), and has length equal to the number of actually used tiles in the 
! current domain.

! ============================================================================
! writes out 1-d integer tiled data using "compression by gathering"
subroutine write_tile_data_i1d(ncid,name,data,mask,long_name,units)
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: name
  integer         , intent(inout) :: data(:) ! data to write
  integer         , intent(inout) :: mask(:) ! mask of valid data
  character(len=*), intent(in), optional :: units, long_name
  ! data and mask are "inout" to save the memory on send-receive buffers. On the
  ! root io_domain PE mask is destroyed and data is filled with the information 
  ! from other PEs in our io_domain. On other PEs these arrays reman intact.

  ! local vars
  integer :: varid,iret,p
  integer, allocatable :: buffer(:) ! data buffers

  ! if our PE doesn't do io (that is, it isn't the root io_domain processor),  
  ! simply send the data and mask of valid data to the root IO processor
  if (mpp_pe()/=lnd%io_pelist(1)) then
     call mpp_send(data(1), plen=size(data), to_pe=lnd%io_pelist(1))
     call mpp_send(mask(1), plen=size(data), to_pe=lnd%io_pelist(1))
  else
     ! gather data and masks from all processors in io_domain
     allocate(buffer(size(data)))
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(buffer(1), glen=size(data), from_pe=lnd%io_pelist(p))
        call mpp_recv(mask(1),   glen=size(data), from_pe=lnd%io_pelist(p))
        where (mask>0) data = buffer
     enddo
     ! clean up allocated memory
     deallocate(buffer)
   
     ! create variable, if it does not exist
     if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then
        __NF_ASRT__(nfu_def_var(ncid,name,NF_INT,(/tile_index_name/),long_name,units,varid))
     endif
     ! write data
     iret = nf_enddef(ncid) ! ignore errors (file may be in data mode already)
     __NF_ASRT__(nf_put_var_int(ncid,varid,data))
  endif
  ! wait for all PEs to finish: necessary because mpp_send doesn't seem to 
  ! copy the data, and therefore on non-root io_domain PE there would be a chance
  ! that the data and mask are destroyed before they are actually sent.
  call mpp_sync(lnd%io_pelist)
end subroutine


! ============================================================================
! writes out 1-d real tiled data using "compression by gathering"
subroutine write_tile_data_r1d(ncid,name,data,mask,long_name,units)
  integer         , intent(in) :: ncid    ! netcdf ID
  character(len=*), intent(in) :: name    ! name of the variable
  real            , intent(inout) :: data(:) ! data to write
  integer         , intent(inout) :: mask(:) ! mask of valid data
  character(len=*), intent(in), optional :: units, long_name ! attributes
  ! data and mask are "inout" to save the memory on send-receive buffers. On the
  ! root io_domain PE mask is destroyed and data is filled with the information 
  ! from other PEs in our io_domain. On other PEs these arrays reman intact.

  ! ---- local vars
  integer :: varid,iret,p
  real,    allocatable :: buffer(:) ! data buffer

  ! if our PE doesn't do io (that is, it isn't the root io_domain processor),  
  ! simply send the data and mask of valid data to the root IO processor
  if (mpp_pe()/=lnd%io_pelist(1)) then
     call mpp_send(data(1), plen=size(data), to_pe=lnd%io_pelist(1))
     call mpp_send(mask(1), plen=size(data), to_pe=lnd%io_pelist(1))
  else
     ! gather data and masks from the processors in io_domain
     allocate(buffer(size(data)))
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(buffer(1), glen=size(data), from_pe=lnd%io_pelist(p))
        call mpp_recv(mask(1),   glen=size(data), from_pe=lnd%io_pelist(p))
        where(mask>0) data = buffer
     enddo
     ! clean up allocated memory
     deallocate(buffer)
     
     ! create variable, if it does not exist
     if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then
        __NF_ASRT__(nfu_def_var(ncid,name,NF_DOUBLE,(/tile_index_name/),long_name,units,varid))
     endif
     ! write data
     iret = nf_enddef(ncid) ! ignore errors (file may be in data mode already)
     __NF_ASRT__(nf_put_var_double(ncid,varid,data))
  endif
  ! wait for all PEs to finish: necessary because mpp_send doesn't seem to 
  ! copy the data, and therefore on non-root io_domain PE there would be a chance
  ! that the data and mask are destroyed before they are actually sent.
  call mpp_sync(lnd%io_pelist)
end subroutine


! ============================================================================
! writes out 2-d real tiled data using "compression by gathering". The dimension
! of the data is (tile,z), and both tile and z dimensions are assumed to be 
! already created
subroutine write_tile_data_r2d(ncid,name,data,mask,zdim,long_name,units)
  integer         , intent(in) :: ncid ! netcdf id
  character(len=*), intent(in) :: name ! name of the variable to write
  character(len=*), intent(in) :: zdim ! name of the z-dimension
  real            , intent(inout) :: data(:,:) ! (tile,z)
  integer         , intent(inout) :: mask(:) ! mask of valid data
  character(len=*), intent(in), optional :: units, long_name
  ! data and mask are "inout" to save the memory on send-receive buffers. On the
  ! root io_domain PE mask is destroyed and data is filled with the information 
  ! from other PEs in our io_domain. On other PEs these arrays reman intact.

  ! local vars
  integer :: varid,iret,p,i
  character(NF_MAX_NAME)::dimnames(2)
  real, allocatable :: buffer(:,:) ! send/receive buffer

  ! if our PE doesn't do io (that is, it isn't the root io_domain processor),  
  ! simply send the data and mask of valid data to the root IO processor
  if (mpp_pe()/=lnd%io_pelist(1)) then
     call mpp_send(data(1,1), plen=size(data),   to_pe=lnd%io_pelist(1))
     call mpp_send(mask(1),   plen=size(data,1), to_pe=lnd%io_pelist(1))
  else
     allocate(buffer(size(data,1),size(data,2)))
     ! gather data and masks from the processors in our io_domain
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(buffer(1,1), glen=size(data),   from_pe=lnd%io_pelist(p))
        call mpp_recv(mask(1),     glen=size(data,1), from_pe=lnd%io_pelist(p))
        do i=1,size(data,1)
           if(mask(i)>0) data(i,:) = buffer(i,:)
        enddo
     enddo
     ! clean up allocated memory
     deallocate(buffer)
   
     ! create variable, if it does not exist
     if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then
        dimnames(1) = tile_index_name
        dimnames(2) = zdim
        __NF_ASRT__(nfu_def_var(ncid,name,NF_DOUBLE,dimnames,long_name,units,varid))
     endif
     ! write data
     iret = nf_enddef(ncid) ! ignore errors: its OK if file is in data mode already
     __NF_ASRT__(nf_put_var_double(ncid,varid,data))
  endif
  ! wait for all PEs to finish: necessary because mpp_send doesn't seem to 
  ! copy the data, and therefore on non-root io_domain PE there would be a chance
  ! that the data and mask are destroyed before they are actually sent.
  call mpp_sync(lnd%io_pelist)

end subroutine


! ============================================================================
subroutine write_tile_data_i0d_fptr(ncid,name,fptr,long_name,units)
  integer         , intent(in) :: ncid ! netcdf id
  character(len=*), intent(in) :: name ! name of the variable to write
  character(len=*), intent(in), optional :: units, long_name
  ! subroutine returning the pointer to the data to be written
  interface ; subroutine fptr(tile, ptr)
     use land_tile_mod, only : land_tile_type
     type(land_tile_type), pointer :: tile ! input
     integer             , pointer :: ptr  ! returned pointer to the data
  end subroutine fptr
  end interface
  
  ! ---- local vars
  integer, allocatable :: idx(:)    ! index dimension
  integer, allocatable :: data(:)   ! data to be written
  integer, allocatable :: mask(:)   ! mask of valid data
  type(land_tile_type), pointer :: tileptr ! pointer to tile
  integer, pointer     :: ptr ! pointer to the tile data
  integer :: ntiles  ! total number of tiles (length of compressed dimension)
  integer :: i

  ! get the size of the output array. Note that at this point the variable
  ! might not yet exist, so we can't use nfu_inq_var
  __NF_ASRT__(nfu_inq_dim(ncid,tile_index_name,len=ntiles))

  ! allocate data
  allocate(data(ntiles),idx(ntiles), mask(ntiles))
  ! fill the data with initial values. This is for the case when some of the
  ! compressed tile indices are invalid, so that corresponding indices of the
  ! array are skipped in the loop below. The invalid indices occur when a restart
  ! is written for the domain where no tiles exist, e.g. the ocean-covered 
  ! region
  data = NF_FILL_INT
  mask = 0

  ! read tile index
  i = nf_enddef(ncid) ! ignore errors (file may be in data mode already)
  __NF_ASRT__(nfu_get_var(ncid,tile_index_name,idx))

  ! gather data into an array along the tile dimension. It is assumed that 
  ! the tile dimension spans all the tiles that need to be written.
  do i = 1, size(idx)
     call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                          lnd%is,lnd%js, tileptr)
     call fptr(tileptr, ptr)
     if(associated(ptr)) then
        data(i) = ptr
        mask(i) = 1
     endif
  enddo

  ! write data
  call write_tile_data_i1d(ncid,name,data,mask,long_name,units)
  
  ! release allocated memory
  deallocate(data,idx,mask)
end subroutine


! ============================================================================
subroutine write_tile_data_r0d_fptr(ncid,name,fptr,long_name,units)
  integer         , intent(in) :: ncid ! netcdf id
  character(len=*), intent(in) :: name ! name of the variable to write
  character(len=*), intent(in), optional :: units, long_name
  ! subroutine returning the pointer to the data to be written
  interface ; subroutine fptr(tile, ptr)
     use land_tile_mod, only : land_tile_type
     type(land_tile_type), pointer :: tile ! input
     real                , pointer :: ptr  ! returned pointer to the data
  end subroutine fptr
  end interface
  
  ! ---- local vars
  integer, allocatable :: mask(:)   ! mask of valid data
  integer, allocatable :: idx(:)    ! index dimension
  real   , allocatable :: data(:)   ! data to be written
  type(land_tile_type), pointer :: tileptr ! pointer to tiles
  real   , pointer :: ptr ! pointer to the tile data
  integer :: ntiles  ! total number of tiles (length of compressed dimension)
  integer :: i
  
  ! get the size of the output array. Note that at this point the variable
  ! might not yet exist, so we can't use nfu_inq_var
  __NF_ASRT__(nfu_inq_dim(ncid,tile_index_name,len=ntiles))

  ! allocate data
  allocate(data(ntiles),idx(ntiles),mask(ntiles))
  data = NF_FILL_DOUBLE
  mask = 0

  ! read tile index
  i = nf_enddef(ncid) ! ignore errors (file may be in data mode already)
  __NF_ASRT__(nfu_get_var(ncid,tile_index_name,idx))

  ! gather data into an array along the tile dimension. It is assumed that 
  ! the tile dimension spans all the tiles that need to be written.
  do i = 1, size(idx)
     call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                          lnd%is,lnd%js, tileptr)
     call fptr(tileptr, ptr)
     if(associated(ptr)) then
        data(i) = ptr
        mask(i) = 1
     endif
  enddo

  ! write data
  call write_tile_data_r1d(ncid,name,data,mask,long_name,units)

  ! free allocated memory
  deallocate(data,idx,mask)
end subroutine


! ============================================================================
subroutine write_tile_data_r1d_fptr_all(ncid,name,fptr,zdim,long_name,units)
  integer         , intent(in) :: ncid ! netcdf id
  character(len=*), intent(in) :: name ! name of the variable to write
  character(len=*), intent(in) :: zdim ! name of the z-dimension
  character(len=*), intent(in), optional :: units, long_name
  ! subroutine returning the pointer to the data to be written
  interface ; subroutine fptr(tile, ptr)
     use land_tile_mod, only : land_tile_type
     type(land_tile_type), pointer :: tile ! input
     real                , pointer :: ptr(:) ! returned pointer to the data
  end subroutine fptr
  end interface
  
  ! ---- local vars
  integer, allocatable :: idx(:)    ! index dimension
  real   , allocatable :: data(:,:) ! data to be written
  integer, allocatable :: mask(:)   ! mask of valid data
  type(land_tile_type), pointer :: tileptr ! pointer to tiles
  real   , pointer :: ptr(:) ! pointer to the tile data
  integer :: ntiles  ! total number of tiles (length of compressed dimension)
  integer :: i
  integer :: nlev ! number of levels of the output variable
  
  ! get the size of the output array. Note that at this point the variable
  ! might not yet exist, so we can't use nfu_inq_var
  __NF_ASRT__(nfu_inq_dim(ncid,tile_index_name,len=ntiles))
  __NF_ASRT__(nfu_inq_dim(ncid,zdim,len=nlev))

  ! allocate data
  allocate(data(ntiles,nlev),idx(ntiles),mask(ntiles))
  data = NF_FILL_DOUBLE
  mask = 0

  ! read tile index
  i = nf_enddef(ncid) ! ignore errors (file may be in data mode already)
  __NF_ASRT__(nfu_get_var(ncid,tile_index_name,idx))

  ! gather data into an array along the tile dimension. It is assumed that 
  ! the tile dimension spans all the tiles that need to be written.
  do i = 1, size(idx)
     call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                          lnd%is,lnd%js, tileptr)
     call fptr(tileptr, ptr)
     if(associated(ptr)) then
        data(i,:) = ptr(:)
        mask(i) = 1
     endif
  enddo

  ! write data
  call write_tile_data_r2d(ncid,name,data,mask,zdim,long_name,units)
  
  ! free allocated memory
  deallocate(data,idx)
  
end subroutine


! ============================================================================
subroutine write_tile_data_r1d_fptr_idx(ncid,name,fptr,index,long_name,units)
  integer         , intent(in) :: ncid  ! netcdf id
  character(len=*), intent(in) :: name  ! name of the variable to write
  integer         , intent(in) :: index ! index of the fptr array element to 
                                        ! write out
  character(len=*), intent(in), optional :: units, long_name
  ! subroutine returning the pointer to the data to be written
  interface ; subroutine fptr(tile, ptr)
     use land_tile_mod, only : land_tile_type
     type(land_tile_type), pointer :: tile ! input
     real                , pointer :: ptr(:) ! returned pointer to the data
  end subroutine fptr 
  end interface
  
  ! ---- local vars
  integer, allocatable :: idx(:)    ! index dimension
  real   , allocatable :: data(:)   ! data to be written
  integer, allocatable :: mask(:)   ! mask of valid data
  type(land_tile_type), pointer :: tileptr ! pointer to tiles
  real   , pointer :: ptr(:) ! pointer to the tile data
  integer :: ntiles  ! total number of tiles (length of compressed dimension)
  integer :: i

  ! get the size of the output array. Note that at this point the variable
  ! might not yet exist, so we can't use nfu_inq_var
  __NF_ASRT__(nfu_inq_dim(ncid,tile_index_name,len=ntiles))

  ! allocate data
  allocate(data(ntiles),idx(ntiles),mask(ntiles))
  data = NF_FILL_DOUBLE
  mask = 0

  ! read tile index
  i = nf_enddef(ncid) ! ignore errors (file may be in data mode already)
  __NF_ASRT__(nfu_get_var(ncid,tile_index_name,idx))

  ! gather data into an array along the tile dimension. It is assumed that 
  ! the tile dimension spans all the tiles that need to be written.
  do i = 1, size(idx)
     call get_tile_by_idx(idx(i),lnd%nlon,lnd%nlat,lnd%tile_map,&
                          lnd%is,lnd%js, tileptr)
     call fptr(tileptr, ptr)
     if(associated(ptr)) then
        data(i) = ptr(index)
        mask(i) = 1
     endif
  enddo

  ! write data
  call write_tile_data_r1d(ncid,name,data,mask,long_name,units)

  ! free allocated memory
  deallocate(data,idx)
end subroutine


! ============================================================================
subroutine override_tile_data_r0d_fptr(fieldname,fptr,time,override)
  character(len=*), intent(in)   :: fieldname ! field to override
  type(time_type),  intent(in)   :: time      ! model time
  logical, optional, intent(out) :: override  ! true if the field has been 
                                              ! overridden successfully
  ! subroutine returning the pointer to the data to be overridden
  interface ; subroutine fptr(tile, ptr)
     use land_tile_mod, only : land_tile_type
     type(land_tile_type), pointer :: tile ! input
     real                , pointer :: ptr  ! returned pointer to the data
  end subroutine fptr
  end interface

  ! ---- local vars
  real    :: data2D(lnd%is:lnd%ie,lnd%js:lnd%je) ! storage for the input data
  logical :: override_
  
  call data_override('LND',fieldname,data2D, time, override_ )
  if(present(override)) override=override_
  if(.not.override_) return ! do nothing if the field was not overridden 

  ! distribute the data over the tiles
  call put_to_tiles_r0d_fptr(data2d,lnd%tile_map,fptr)
  
end subroutine

! =============================================================================
! given netcdf ID, synchronizes the definitions between writing and reading 
! processors
subroutine sync_nc_files(ncid)
  integer, intent(in) :: ncid

  integer :: iret

  if(mpp_pe()==lnd%io_pelist(1)) then
     iret = nf_enddef(ncid)
     ! commit possible definition changes and data to the disk
     __NF_ASRT__(nf_sync(ncid))
  endif
  call mpp_sync(lnd%io_pelist)
  if(mpp_pe()/=lnd%io_pelist(1)) then
     ! synchronize in-memory data structures with the changes on the disk
    __NF_ASRT__(nf_sync(ncid))
  endif
end subroutine sync_nc_files

end module


module land_utils_mod

use land_tile_mod, only : land_tile_type, land_tile_enum_type, land_tile_list_type, &
     first_elmt, tail_elmt, next_elmt, operator(/=), get_elmt_indices, current_tile

implicit none
private
! ==== public interfaces =====================================================
public :: put_to_tiles_r0d_fptr
public :: put_to_tiles_r1d_fptr
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: land_utils.F90,v 17.0 2009/07/21 03:02:46 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

contains

! ============================================================================
subroutine put_to_tiles_r0d_fptr(x2d, tile_map, fptr)
  real, intent(in)                         :: x2d     (:,:)
  type(land_tile_list_type), intent(inout) :: tile_map(:,:)
  ! subroutine returning the pointer to the tile data
  interface
     subroutine fptr(tile, ptr)
       use land_tile_mod, only : land_tile_type
       type(land_tile_type), pointer :: tile ! input
       real                , pointer :: ptr  ! returned pointer to the data
     end subroutine fptr 
  end interface

  integer :: i,j
  type(land_tile_enum_type)     :: te,ce   ! tail and current tile list elements
  type(land_tile_type), pointer :: tileptr ! pointer to tile   
  real                , pointer :: ptr     ! pointer to the data element within a tile

  ce = first_elmt( tile_map )
  te = tail_elmt ( tile_map )
  do while(ce /= te)
     call get_elmt_indices(ce,i,j)
     tileptr => current_tile(ce)
     call fptr(tileptr,ptr)
     if (associated(ptr)) ptr=x2d(i,j)
     ce=next_elmt(ce)
  enddo
end subroutine


! ============================================================================
subroutine put_to_tiles_r1d_fptr(x2d, tile_map, fptr)
  real, intent(in)                         :: x2d     (:,:,:)
  type(land_tile_list_type), intent(inout) :: tile_map(:,:)
  ! subroutine returning the pointer to the tile data
  interface
     subroutine fptr(tile, ptr)
       use land_tile_mod, only : land_tile_type
       type(land_tile_type), pointer :: tile ! input
       real                , pointer :: ptr(:) ! returned pointer to the data
     end subroutine fptr 
  end interface

  integer :: i,j
  type(land_tile_enum_type)     :: te,ce   ! tail and current tile list elements
  type(land_tile_type), pointer :: tileptr ! pointer to tile   
  real                , pointer :: ptr(:)  ! pointer to the data element within a tile

  ce = first_elmt( tile_map )
  te = tail_elmt ( tile_map )
  do while(ce /= te)
     call get_elmt_indices(ce,i,j)
     tileptr => current_tile(ce)
     call fptr(tileptr,ptr)
     if (associated(ptr)) ptr(:)=x2d(i,j,:)
     ce=next_elmt(ce)
  enddo
end subroutine

end module land_utils_mod


module sphum_mod

use constants_mod,      only: rdgas, rvgas
use sat_vapor_pres_mod, only: escomp

implicit none 
private

public :: qscomp

! ==== module constants ======================================================
character(len=*), private, parameter :: &
   version = '$Id: sphum.F90,v 15.0 2007/08/14 18:48:28 fms Exp $', &
   tagname = '$Name: hiram_20101115_bw $' ,&
   module_name = 'vegn'
real, parameter :: d622 = rdgas/rvgas
real, parameter :: d378 = 1.0-d622
real, parameter :: del_temp = 0.1 ! temperature increment for q_sat derivative calc.

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

subroutine qscomp(T, p, qsat, DqsatDT )
  real, intent(in) :: T    ! temperature
  real, intent(in) :: p    ! pressure
  real, intent(out):: qsat ! saturated specific humidity
  real, intent(out), optional :: DqsatDT ! deriv of specific humidity w.r.t. T

  real :: esat ! sat. water vapor pressure

  if(120.0<T.and.T<373.0) then
     continue
  else
     write(*,'(a,g)')'temperature out of range',T
  endif
  ! calculate saturated specific humidity
  call escomp(T,esat)
  qsat = d622*esat /(p-d378*esat )

  ! if requested, calculate the derivative of qsat w.r.t. temperature
  if (present(DqsatDT)) then
     call escomp(T+del_temp,esat)
     DqsatDT = (d622*esat/(p-d378*esat)-qsat)/del_temp 
  endif
end subroutine qscomp

end module sphum_mod


module nfc_mod

  use nfu_mod

implicit none
private

! ==== public interface ======================================================
public :: nfu_inq_compressed_dim, nfu_inq_compressed_var
public :: nfu_get_compressed_var
public :: nfu_put_compressed_var
public :: nfu_get_compressed_rec
! ==== end of public interface ===============================================

! ==== interfaces for overloaded functions ===================================
#define __INTERFACE_SECTION__
interface nfu_inq_compressed_dim
   module procedure inq_compressed_dim_n, inq_compressed_dim_i
end interface

interface nfu_inq_compressed_var
   module procedure inq_compressed_var_n, inq_compressed_var_i
end interface

#define F90_TYPE real(8)
#define NF_TYPE  double
#include "getput_compressed.inc"

#define F90_TYPE integer
#define NF_TYPE  int
#include "getput_compressed.inc"

#undef __INTERFACE_SECTION__
! ---- module constants ------------------------------------------------------
character(len=*), parameter :: &
     version = '$Id: nfc.F90,v 17.0 2009/07/21 03:02:50 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

! ---- private type - used to hold dimension/packing information during unpacking
! (see get_compressed_var_i_r8)
type diminfo_type
   integer, pointer :: idx(:)=>NULL() ! packing information
   integer :: length  ! size of the dimension in the input array
   integer :: stride  ! stide along the dimension in the output array
end type 

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_TRY__(err_code,iret,LABEL)iret=err_code;if(iret/=NF_NOERR)goto LABEL
contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ===========================================================================
function inq_compressed_dim_n(ncid,name,ndims,dimids,dimlens,dimid) result (iret)
  integer :: iret
  integer, intent(in)  :: ncid
  character(*), intent(in) :: name
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: dimid

  integer :: dimid_

  __NF_TRY__(nf_inq_dimid(ncid,name,dimid_),iret,7)
  if(present(dimid)) dimid = dimid_
  __NF_TRY__(inq_compressed_dim_i(ncid,dimid_,ndims,dimids,dimlens),iret,7)
7 return
end function

! ===========================================================================
function inq_compressed_dim_i(ncid,dimid,ndims,dimids,dimlens,dimname) result (iret)
  integer :: iret
  integer, intent(in)  :: ncid,dimid
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  character(*), intent(out), optional :: dimname
  
  character(NF_MAX_NAME) :: dimname_
  character(1024) :: compress ! should be more than enough to hold the compression info
  integer :: dimlen,dimid0,varid,n,is,ie

  __NF_TRY__(nfu_inq_dim(ncid,dimid,name=dimname_),iret,7)
  if(present(dimname)) dimname = dimname_
  compress = ''
  __NF_TRY__(nf_inq_varid(ncid,dimname_,varid),iret,7)
  __NF_TRY__(nf_get_att_text(ncid,varid,'compress',compress),iret,7)

  ! parse the description of the compression
  ie = len_trim(compress)
  n = 0
  do while(ie>0)
     is = scan(compress(1:ie),' ',back=.true.)
     if(is==ie) then
        ! skip space runs
     else
        n = n+1
        iret = nfu_inq_dim(ncid,compress(is+1:ie),len=dimlen,dimid=dimid0)
        __NF_TRY__(iret,iret,7)
        if(present(dimids)) dimids(n) = dimid0
        if(present(dimlens)) dimlens(n) = dimlen
     endif
     ie = is-1
  enddo
  if(present(ndims))ndims=n
7 return
end function

! ============================================================================
function inq_compressed_var_n(ncid, name, id, xtype, ndims, dimids, dimlens, natts, &
     is_dim, has_records, varsize, recsize, nrec, is_compressed) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*),intent(in) :: name
  integer, intent(out), optional :: id
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records
  logical, intent(out), optional :: is_compressed ! true if variable is actually compressed

  integer :: vid
  character(len=NF_MAX_NAME) :: vname

  __NF_TRY__(nf_inq_varid(ncid,name,vid),iret,7)
  if(present(id)) id = vid
  iret = inq_compressed_var_i(ncid,vid,vname,xtype,ndims,dimids,dimlens,natts,&
       is_dim,has_records,varsize,recsize,nrec,is_compressed)

7 return  
end function

! ============================================================================
function inq_compressed_var_i(ncid, vid, name, xtype, ndims, dimids, dimlens, &
     natts, is_dim, has_records, varsize, recsize, nrec, is_compressed) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: vid
  character(*),intent(out), optional :: name
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records
  logical, intent(out), optional :: is_compressed ! true if variable is actually compressed

  
  integer :: nd0, dids0(NF_MAX_VAR_DIMS),dlens0(NF_MAX_VAR_DIMS)
  integer :: nd1, dids1(NF_MAX_VAR_DIMS),dlens1(NF_MAX_VAR_DIMS)
  integer :: i,n,unlimdim,vsize,rsize

  iret =  nfu_inq_var(ncid, vid, name, xtype, nd0, dids0, dlens0, natts, &
     is_dim, has_records, varsize, recsize, nrec)

  nd1=1
  if(present(is_compressed)) is_compressed=.false.
  do i = 1, nd0
     if(nfu_inq_compressed_dim(ncid,dids0(i),&
          ndims=n,dimids=dids1(nd1:),dimlens=dlens1(nd1:))==NF_NOERR) then
        nd1 = nd1+n
        if(present(is_compressed)) is_compressed=.true.
     else
        dlens1(nd1) = dlens0(i)
        dids1(nd1) = dids0(i)
        nd1 = nd1+1
     endif
  enddo
  nd1 = nd1-1

  if(present(ndims))   ndims   = nd1
  if(present(dimids))  dimids  = dids1
  if(present(dimlens)) dimlens = dlens1
  if(present(varsize).or.present(recsize)) then
     __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
     vsize = 1; rsize=1
     do i = 1,nd1
        vsize = vsize*dlens1(i)
        if(dids1(i)/=unlimdim)&
             rsize = rsize*dlens1(i)
     enddo
     if (present(varsize)) varsize=vsize
     if (present(recsize)) recsize=rsize
  end if
7 return

end function

#define __BODY_SECTION__
#define F90_TYPE real(8)
#define NF_TYPE  double
#include "getput_compressed.inc"

#define F90_TYPE integer
#define NF_TYPE  int
#include "getput_compressed.inc"

end module nfc_mod


module nfu_mod

implicit none
private

! ==== public interfaces =====================================================
public :: nfu_inq_dim, nfu_inq_var, nfu_inq_att
public :: nfu_def_dim, nfu_def_var
public :: nfu_put_att
public :: nfu_get_dim, nfu_get_dim_bounds
public :: nfu_put_var, nfu_put_rec
public :: nfu_get_var, nfu_get_rec

public :: nfu_get_valid_range, nfu_is_valid, nfu_validtype, nfu_validtype2ascii
! ==== end of public interfaces ==============================================

#define __INTERFACE_SECTION__

interface nfu_inq_dim
   module procedure inq_dim_i
   module procedure inq_dim_n
end interface
interface nfu_inq_att
   module procedure inq_att_i_n
   module procedure inq_att_n_n
   module procedure inq_att_i_i
   module procedure inq_att_n_i
end interface
interface nfu_inq_var
   module procedure inq_var_i
   module procedure inq_var_n
end interface
interface nfu_def_dim
   module procedure def_dim_0
   module procedure def_dim_r
   module procedure def_dim_i
end interface
interface nfu_def_var
   module procedure def_var_i, def_var_n, def_var_scalar
end interface
interface nfu_put_att
   module procedure put_att_text_i
   module procedure put_att_text_n
   module procedure put_att_int_i
   module procedure put_att_int_n
end interface

#define F90_TYPE integer
#define NF_TYPE  int
#include "getput.inc"

#define F90_TYPE real(8)
#define NF_TYPE  double
#include "getput.inc"

interface nfu_get_valid_range
   module procedure get_valid_range_i
   module procedure get_valid_range_n
end interface
interface nfu_is_valid
   module procedure nfu_is_valid_i
   module procedure nfu_is_valid_r
end interface
#undef __INTERFACE_SECTION__
! ---- module constants ------------------------------------------------------
character(len=*), parameter :: &
     module_name = 'nf_utils_mod', &
     version     = '$Id: nfu.F90,v 17.0 2009/07/21 03:02:52 fms Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'

! ---- module types ----------------------------------------------------------
type nfu_validtype
   private
   logical :: hasmax = .false.
   logical :: hasmin = .false.
!   real(kind=8) :: max=HUGE(max),min=-HUGE(min)
   real(kind=8) :: max=0,min=0
end type

! ---- module variables ------------------------------------------------------
logical :: module_is_initialized =.FALSE.

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_TRY__(err_code,iret,LABEL)iret=err_code;if(iret/=NF_NOERR)goto LABEL
contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

#define __BODY_SECTION__
! ============================================================================
function inq_dim_n(ncid, name, len, dimid) result (iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*),intent(in) :: name
  integer, intent(out), optional :: len
  integer, intent(out), optional :: dimid

  integer :: id

  __NF_TRY__(nf_inq_dimid(ncid,name, id),iret,7)
  if(present(dimid))dimid = id
  if(present(len)) &
       iret = nf_inq_dimlen(ncid,id,len)
7 return
end function

! ============================================================================
function inq_dim_i(ncid, id, name, len) result (iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: id
  character(*), intent(out), optional :: name
  integer     , intent(out), optional :: len

  if(present(name)) then
     __NF_TRY__(nf_inq_dimname(ncid,id,name),iret,7)
  endif
  if(present(len)) then
     __NF_TRY__(nf_inq_dimlen(ncid,id,len),iret,7)
  end if
7 return
end function

! ============================================================================
function inq_var_n(ncid, name, id, xtype, ndims, dimids, dimlens, natts, &
     is_dim, has_records, varsize, recsize, nrec) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(*),intent(in) :: name
  integer, intent(out), optional :: id
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records

  integer :: vid
  character(len=NF_MAX_NAME) :: vname

  __NF_TRY__(nf_inq_varid(ncid,name,vid),iret,7)
  if(present(id)) id = vid
  iret = inq_var_i(ncid,vid,vname,xtype,ndims,dimids,dimlens,natts,&
       is_dim,has_records,varsize,recsize,nrec)

7 return  
end function

! ============================================================================
function inq_var_i(ncid, vid, name, xtype, ndims, dimids, dimlens,natts, &
     is_dim, has_records, varsize, recsize, nrec) result(iret)
  integer :: iret
  integer, intent(in) :: ncid
  integer, intent(in) :: vid
  character(*),intent(out), optional :: name
  integer, intent(out), optional :: xtype
  integer, intent(out), optional :: ndims
  integer, intent(out), optional :: dimids(:)
  integer, intent(out), optional :: dimlens(:)
  integer, intent(out), optional :: natts
  logical, intent(out), optional :: is_dim ! true if variable is a dimension variable
  logical, intent(out), optional :: has_records ! true if variable depends on record dimension
  integer, intent(out), optional :: varsize ! total size of the variable
  integer, intent(out), optional :: recsize ! size of a single record
  integer, intent(out), optional :: nrec    ! number of records

  integer :: vxtype, vndims, vdimids(NF_MAX_VAR_DIMS), vnatts
  integer :: vsize, vrecsize
  integer :: unlimdim, did, dlen, i
  character(len=NF_MAX_NAME) :: vname

  __NF_TRY__(nf_inq_var(ncid,vid,vname,vxtype,vndims,vdimids,vnatts),iret,7)
  if (present(name)) name = vname
  if (present(xtype)) xtype = vxtype
  if (present(ndims)) ndims = vndims
  if (present(dimids)) dimids(1:min(vndims,size(dimids))) = &
       vdimids(1:min(vndims,size(dimids)))
  if (present(natts)) natts = vnatts
  if (present(is_dim)) then
     is_dim = (nf_inq_dimid(ncid,vname,did)==NF_NOERR)
  endif
  __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7)
  if (present(has_records)) then
     has_records = ANY(vdimids(1:vndims)==unlimdim)
  endif
  if (present(varsize).or.present(recsize).or.present(dimlens)) then
     vsize = 1; vrecsize=1
     do i = 1,vndims
        __NF_TRY__(nf_inq_dimlen(ncid,vdimids(i),dlen),iret,7)
        vsize = vsize*dlen
        if(vdimids(i)/=unlimdim) vrecsize=vrecsize*dlen
        if(present(dimlens)) dimlens(i)=dlen
     enddo
     if(present(varsize)) varsize=vsize
     if(present(recsize)) recsize=vrecsize 
  endif
  if(present(nrec)) then
     nrec=1
     if(unlimdim/=-1.and.ANY(vdimids(1:vndims)==unlimdim)) then
        __NF_TRY__(nf_inq_dimlen(ncid,unlimdim,nrec),iret,7)
     endif
  endif

7 return  
end function

! ============================================================================
function inq_att_i_n(ncid, varid, att, xtype, len, attid) result (iret)
  integer     , intent(in) :: ncid
  integer     , intent(in) :: varid
  character(*), intent(in) :: att
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  integer, optional, intent(out) :: attid
  integer :: iret

  integer :: xtype_, len_

  __NF_TRY__(nf_inq_att(ncid,varid,att,xtype_,len_),iret,7)
  if(present(attid)) then
     __NF_TRY__(nf_inq_attid(ncid,varid,att,attid),iret,7)
  endif
  if(present(xtype)) xtype = xtype_
  if(present(len))   len   = len_
  
7 return
end function

! ============================================================================
function inq_att_n_n(ncid, var, att, xtype, len, attid) result (iret)
  integer     , intent(in) :: ncid
  character(*), intent(in) :: var
  character(*), intent(in) :: att
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  integer, optional, intent(out) :: attid
  integer :: iret


  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7)
  __NF_TRY__(inq_att_i_n(ncid,varid,att,xtype,len,attid),iret,7)
7 return
end function

! ============================================================================
function inq_att_i_i(ncid, varid, attid, xtype, len, name) result (iret)
  integer, intent(in) :: ncid
  integer, intent(in) :: varid
  integer, intent(in) :: attid
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  character(*), optional, intent(out) :: name
  integer :: iret

  character(NF_MAX_NAME) :: name_

  __NF_TRY__(nf_inq_attname(ncid,varid,attid,name_),iret,7)
  __NF_TRY__(inq_att_i_n(ncid,varid,name_,xtype,len),iret,7)
  if(present(name)) name = name_
7 return
end function

! ============================================================================
function inq_att_n_i(ncid, var, attid, xtype, len, name) result (iret)
  integer, intent(in) :: ncid
  character(*) :: var
  integer, intent(in) :: attid
  integer, optional, intent(out) :: xtype
  integer, optional, intent(out) :: len
  character(*), optional, intent(out) :: name
  integer :: iret

  integer :: varid
  __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7)
  __NF_TRY__(inq_att_i_i(ncid,varid,attid,xtype,len,name),iret,7)
7 return
end function

! ============================================================================
function def_dim_0(ncid,name,size,xtype,long_name,units,edges,dimid,varid) &
     result (iret)
  integer         , intent(in) :: ncid  ! id of NetCDF file to create 
  character(len=*), intent(in) :: name  ! name of the dimension
  integer         , intent(in) :: size  ! size of the dimension
  integer,optional, intent(in) :: xtype ! external type of the associated variable
  character(len=*), intent(in), optional :: &
       long_name, &
       units,     &
       edges
  integer,optional,intent(out) :: dimid,varid
  integer :: iret

  integer :: did,vid

  iret = nf_redef(ncid)

  did = -1; vid = -1
  __NF_TRY__(nf_def_dim(ncid,name,size,did),iret,7)
  if(present(xtype)) then
     __NF_TRY__(nf_def_var(ncid,name,xtype,1,(/did/),vid),iret,7)
     if (present(long_name)) then
        __NF_TRY__(nfu_put_att(ncid,vid,'long_name',long_name),iret,7)
     endif
     if (present(units)) then
        __NF_TRY__(nfu_put_att(ncid,vid,'units',units),iret,7)
     endif
     if (present(edges)) then
        __NF_TRY__(nfu_put_att(ncid,vid,'edges',edges),iret,7)
     endif
  endif
  if(present(dimid))dimid=did
  if(present(varid))varid=vid
7 return
end function

! ============================================================================
function def_dim_r(ncid,name,data,long_name,units,edges,dimid,varid) result (iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(len=*), intent(in) :: name
  real            , intent(in) :: data(:)
  character(len=*), intent(in), optional :: long_name, units, edges
  integer,optional,intent(out) :: dimid,varid
  
  integer :: vid
  iret = nf_redef(ncid)
  
  __NF_TRY__(def_dim_0(ncid,name,size(data),NF_DOUBLE,long_name,units,edges,dimid,varid=vid),iret,7)
  iret = nf_enddef(ncid)
  iret = nf_put_var_double(ncid,vid,data)
  if(present(varid)) varid = vid
7 return
end function

! ============================================================================
function def_dim_i(ncid,name,data,long_name,units,edges,dimid,varid) result (iret)
  integer :: iret
  integer, intent(in) :: ncid
  character(len=*), intent(in) :: name
  integer         , intent(in) :: data(:)
  character(len=*), intent(in), optional :: long_name, units, edges
  integer,optional,intent(out) :: dimid,varid
  
  integer :: vid
  iret = nf_redef(ncid)
  
  __NF_TRY__(def_dim_0(ncid,name,size(data),NF_INT,long_name,units,edges,dimid,varid=vid),iret,7)
  iret = nf_enddef(ncid)
  iret = nf_put_var_int(ncid,vid,data)
  if(present(varid)) varid = vid
7 return
end function

! ============================================================================
function def_var_n(ncid,name,xtype,dims,long_name,units,varid) result(iret)
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: name       ! name of the variable
  integer         , intent(in) :: xtype      ! external type of the var
  character(len=*), intent(in) :: &
       dims(:)       ! vector of dimension names 
  character(len=*), intent(in), optional :: &
       long_name, &  ! name of the variable
       units         ! name of the variable
  integer         , intent(out), optional :: &
       varid   ! ID of the defined variable
  integer :: iret

  ! ---- local vars
  integer :: dimc,dimids(NF_MAX_VAR_DIMS)
  integer :: i

  dimc = size(dims)
  do i = 1,dimc
     __NF_TRY__(nf_inq_dimid(ncid,dims(i),dimids(i)),iret,7)
  enddo
  iret=def_var_i(ncid,name,xtype,dimids(1:dimc),long_name,units,varid)

7 return
end function

! ============================================================================
function def_var_scalar(ncid,name,xtype,long_name,units,varid) result(iret)
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: name       ! name of the variable
  integer         , intent(in) :: xtype      ! external type of the var
  character(len=*), intent(in), optional :: &
       long_name, &  ! name of the variable
       units         ! name of the variable
  integer         , intent(out), optional :: &
       varid   ! ID of the defined variable
  integer :: iret

  ! ---- local vars
  integer :: varid_

  iret = nf_redef(ncid); ! ignore errors here since file can be in define mode already
  __NF_TRY__(nf_def_var(ncid,name,xtype,0,(/1/),varid_),iret,7)
  if(present(varid)) varid = varid_
  if(present(long_name)) then
     __NF_TRY__(nfu_put_att(ncid,varid_,'long_name',long_name),iret,7)
  endif
  if(present(units)) then
     __NF_TRY__(nfu_put_att(ncid,varid_,'units',units),iret,7)
  endif
  
7 return
end function

! ============================================================================
function def_var_i(ncid,name,xtype,dimids,long_name,units,varid) result(iret)
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: name       ! name of the variable
  integer         , intent(in) :: xtype      ! external type of the var
  integer         , intent(in) :: &
       dimids(:)     ! vector of dimension ids
  character(len=*), intent(in), optional :: &
       long_name, &  ! name of the variable
       units         ! name of the variable
  integer         , intent(out), optional :: &
       varid   ! ID of the defined variable
  integer :: iret

  ! ---- local vars
  integer :: dimc,varid_

  dimc = size(dimids)
  iret = nf_redef(ncid); ! ignore errors here since file can be in define mode already
  __NF_TRY__(nf_def_var(ncid,name,xtype,dimc,dimids,varid_),iret,7)
  if(present(varid)) varid = varid_
  if(present(long_name)) then
     __NF_TRY__(nfu_put_att(ncid,varid_,'long_name',long_name),iret,7)
  endif
  if(present(units)) then
     __NF_TRY__(nfu_put_att(ncid,varid_,'units',units),iret,7)
  endif
  
7 return
end function

! ============================================================================
function put_att_text_i(ncid,varid,name,text) result (iret)
  integer :: iret
  integer         , intent(in) :: ncid,varid
  character(len=*), intent(in) :: name,text
  
  iret = nf_redef(ncid)
  iret = nf_put_att_text(ncid,varid,name,len(text),text)
end function

! ============================================================================
function put_att_text_n(ncid,varname,name,text) result (iret)
  integer :: iret
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: varname,name,text
  
  integer :: varid
  
  __NF_TRY__(nf_inq_varid(ncid,varname,varid),iret,7)
  iret = nf_redef(ncid)
  iret = nf_put_att_text(ncid,varid,name,len(text),text)
7 return
end function

! ============================================================================
function put_att_int_i(ncid,varid,name,value) result (iret)
  integer :: iret
  integer         , intent(in) :: ncid,varid
  character(len=*), intent(in) :: name
  integer         , intent(in) :: value
  
  iret = nf_redef(ncid)
  iret = nf_put_att_int(ncid,varid,name,NF_INT,1,value)
end function

! ============================================================================
function put_att_int_n(ncid,varname,name,value) result (iret)
  integer :: iret
  integer         , intent(in) :: ncid
  character(len=*), intent(in) :: varname,name
  integer         , intent(in) :: value
  
  integer :: varid
  
  __NF_TRY__(nf_inq_varid(ncid,varname,varid),iret,7)
  iret = nf_redef(ncid)
  iret = nf_put_att_int(ncid,varid,name,NF_INT,1,value)
7 return
end function

! ============================================================================
function nfu_get_dim(ncid, dimid, x) result(iret)
  integer, intent(in) :: ncid,dimid
  real   , intent(out) :: x(:)
  integer :: iret
  
  integer :: varid
  character(len=NF_MAX_NAME) :: name
  
  __NF_TRY__(nf_inq_dimname(ncid,dimid,name),iret,7)
  __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7)
  __NF_TRY__(nf_get_var_double(ncid,varid,x),iret,7)

7 return
end function

! ============================================================================
function nfu_get_dim_bounds(ncid,dimid,edges)result(iret)
  integer, intent(in) :: ncid,dimid
  real   , intent(out) :: edges(:)
  integer :: iret
    
  ! ---- local vars
  character(len=NF_MAX_NAME) :: name, edges_name
  real    :: x(size(edges)-1)
  integer :: varid, len
  
  __NF_TRY__( nf_inq_dimname(ncid,dimid,name),iret,7 )
  __NF_TRY__( nf_inq_dimlen(ncid,dimid,len),iret,7 )
  __NF_TRY__( nf_inq_varid(ncid,name,varid),iret,7 )
  edges_name = " "
  if (nf_get_att_text(ncid,varid,'edges',edges_name)==NF_NOERR) then
     __NF_TRY__(nf_inq_varid(ncid,edges_name,varid),iret,7)
     __NF_TRY__(nf_get_var_double(ncid,varid,edges),iret,7)
  else
     __NF_TRY__( nf_get_var_double(ncid,varid,x),iret,7 )
     edges(2:len) = (x(1:len-1)+x(2:len))/2
     edges(1) = x(1)-(edges(2)-x(1))
     edges(len+1) = x(len)+(x(len)-edges(len))
  endif
7 return
end function





! ============================================================================
! nfu_get_var interface
! ============================================================================
#define F90_TYPE integer
#define NF_TYPE  int
#include "getput.inc"

#define F90_TYPE real(8)
#define NF_TYPE  double
#include "getput.inc"



function get_valid_range_n(ncid, varname, v) result (iret)
  integer           , intent(in)  :: ncid
  character(*)      , intent(in)  :: varname
  type(nfu_validtype), intent(out) :: v ! validator

  integer :: iret
  integer :: varid

  __NF_TRY__(nfu_inq_var(ncid,varname,id=varid),iret,7)
  iret = get_valid_range_i(ncid, varid, v)

7 return
end function

! ========================================================================
! based on presence/absence of attributes, defines valid range or missing 
! value. For details, see section 8.1 of NetCDF User Guide
function get_valid_range_i(ncid, varid, v) result (iret)
  integer           , intent(in)  :: ncid
  integer           , intent(in)  :: varid
  type(nfu_validtype), intent(out) :: v ! validator

  integer :: iret
  
  integer :: var_T, valid_T, scale_T, T ! types variable and of attributes
  real(kind=8) :: scale, offset, fill, r(2)
  
  ! find the type of the variable
  __NF_TRY__(nfu_inq_var(ncid,varid,xtype=var_T),iret,7)

  ! find the widest type of scale and offset; note that the code
  ! uses assumption that NetCDF types are arranged in th order of rank,
  ! that is NF_BYTE < NF_CHAR < NF_SHORT < NF_INT < NF_FLOAT < NF_DOUBLE
  scale = 1; offset = 0;
  scale_T = 0
  if(nfu_inq_att(ncid,varid,'scale_factor',xtype=T)==NF_NOERR) then
     __NF_TRY__(nf_get_att_double(ncid,varid,'scale_factor',scale),iret,7)
     scale_T = T
  endif
  if(nfu_inq_att(ncid,varid,'add_offset',xtype=T)==NF_NOERR) then
     __NF_TRY__(nf_get_att_double(ncid,varid,'add_offset',offset),iret,7)
     scale_T = max(scale_T,T)
  endif
     
  ! examine possible range attributes
  valid_T = 0; v%hasmax=.false. ; v%hasmin=.false.
  if (nfu_inq_att(ncid,varid,'valid_range',xtype=T)==NF_NOERR) then
     __NF_TRY__(nf_get_att_double(ncid,varid,'valid_range',r),iret,7)
     v%min = r(1)      ; v%max = r(2)
     v%hasmax = .true. ; v%hasmin = .true.
     valid_T = max(valid_T,T)
  else if(nfu_inq_att(ncid,varid,'valid_max',xtype=T)==NF_NOERR) then
     __NF_TRY__(nf_get_att_double(ncid,varid,'valid_max',v%max),iret,7)
     v%hasmax = .true.
     valid_T = max(valid_T,T)
  else if(nfu_inq_att(ncid,varid,'valid_min',xtype=T)==NF_NOERR) then
     __NF_TRY__(nf_get_att_double(ncid,varid,'valid_min',v%min),iret,7)
     v%hasmin = .true.
     valid_T = max(valid_T,T)
  else if(nfu_inq_att(ncid,varid,'missing_value',xtype=T)==NF_NOERR) then
     ! here we always scale, since missing_value is supposed to be in 
     ! external representation
     __NF_TRY__(nf_get_att_double(ncid,varid,'missing_value',v%min),iret,7)
     v%min = v%min*scale + offset
  else
     ! as a last resort, define range based on _FillValue
     ! get fill value and its type: from var, from file, or default
     if(nf_get_att_double(ncid,varid,'_FillValue',fill)/=NF_NOERR) then
        if(nf_get_att_double(ncid,NF_GLOBAL,'_FillValue',fill)/=NF_NOERR) then
           select case(var_T)
           case(NF_CHAR)
              fill = NF_FILL_CHAR
           case(NF_BYTE)
              fill = NF_FILL_BYTE
           case(NF_SHORT)
              fill = NF_FILL_SHORT
           case(NF_INT)
              fill = NF_FILL_INT
           case(NF_REAL)
              fill = NF_FILL_REAL
           case(NF_DOUBLE)
              fill = NF_FILL_DOUBLE
           end select
        endif
     endif
     if(fill>0) then
        ! if _FillValue is positive, then it defines valid maximum
        v%hasmax = .true.
        v%max = fill
        select case(T)
        case (NF_BYTE,NF_CHAR,NF_SHORT,NF_INT)
           v%max = v%max-1
        case (NF_FLOAT)
           v%max = nearest(nearest(real(v%max,4),-1.0),-1.0)
        case (NF_DOUBLE)
           v%max = nearest(nearest(real(v%max,8),-1.0),-1.0)
        end select
     else
        ! if _FillValue is negative or zero, then it defines valid minimum
        v%hasmin = .true.
        v%min = fill
        select case(T)
        case (NF_BYTE,NF_CHAR,NF_SHORT,NF_INT)
           v%min = v%min+1
        case (NF_FLOAT)
           v%min = nearest(nearest(real(v%min,4),+1.0),+1.0)
        case (NF_DOUBLE)
           v%min = nearest(nearest(real(v%min,8),+1.0),+1.0)
        end select
     endif
     ! NOTE: if we go through _FillValue branch, valid_T is 0, so values
     ! are always scaled, as it should be because _FillValue is in external 
     ! representation
  endif
  ! If valid_range is the same type as scale_factor (actually the wider of
  ! scale_factor and add_offset) and this is wider than the external data, then it
  ! will be interpreted as being in the units of the internal (unpacked) data.
  ! Otherwise it is in the units of the external (packed) data.
  if(.not.((valid_T == scale_T).and.(scale_T>var_T))) then
     v%min = v%min*scale + offset
     v%max = v%max*scale + offset
  endif
7 return
end function

! ========================================================================
elemental function nfu_is_valid_r(x, v) result (lret)
  real               , intent(in) :: x ! real value to be examined
  type(nfu_validtype), intent(in) :: v ! validator
  logical :: lret

!  if (x is NaN) then
!     lret = .false.
!  else 
  if (v%hasmin.or.v%hasmax) then
     lret = .not.(((v%hasmin).and.x<v%min).or.((v%hasmax).and.x>v%max))
  else
     lret = (x /= v%min)
  endif
end function

! ========================================================================
elemental function nfu_is_valid_i(x, v) result (lret)
  integer            , intent(in) :: x ! real value to be examined
  type(nfu_validtype), intent(in) :: v ! validator
  logical :: lret
  
  lret = nfu_is_valid_r(real(x),v)
end function

! ========================================================================
function nfu_validtype2ascii(v) result (string)
  character(len=64) :: string
  type(nfu_validtype), intent(in) :: v

  if(v%hasmin.and.v%hasmax) then
     write(string,'("[",g,",",g,"]")') v%min, v%max
  else if (v%hasmin) then
     write(string,'("[",g,")")') v%min
  else if (v%hasmax) then
     write(string,'("(",g,"]")') v%max
  else 
     write(string,'("/=",g)') v%min
  endif
end function

end module nfu_mod


module nf_utils_mod

use nfu_mod ! netcdf utilities
use nfc_mod ! netcdf utilities for compressed files

implicit none
private

! ==== public interfaces =====================================================
! export stuff from nfu_mod
public :: nfu_inq_dim, nfu_inq_var, nfu_inq_att
public :: nfu_def_dim, nfu_def_var
public :: nfu_put_att
public :: nfu_get_dim, nfu_get_dim_bounds
public :: nfu_put_var, nfu_put_rec
public :: nfu_get_var, nfu_get_rec
public :: nfu_get_valid_range, nfu_is_valid, nfu_validtype, nfu_validtype2ascii
! export stuff from nfc_mod
public :: nfu_inq_compressed_dim, nfu_inq_compressed_var
public :: nfu_get_compressed_var
public :: nfu_put_compressed_var
public :: nfu_get_compressed_rec
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: nf_utils.F90,v 17.0 2009/07/21 03:02:54 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

end module nf_utils_mod


! ============================================================================
! snow model module
! ============================================================================
module snow_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : error_mesg, file_exist, check_nml_error, &
     stdlog, write_version_number, close_file, mpp_pe, mpp_root_pe, FATAL, NOTE
use time_manager_mod,   only: time_type, increment_time, time_type_to_real
use constants_mod,      only: tfreeze, hlv, hlf, PI

use land_constants_mod, only : NBANDS
use snow_tile_mod, only : &
     snow_tile_type, snow_prog_type, read_snow_data_namelist, &
     snow_data_thermodynamics, snow_data_area, snow_data_radiation, snow_data_diffusion, &
     snow_data_hydraulics, max_lev, cpw, clw, csw

use land_tile_mod, only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=)
use land_tile_diag_mod, only : &
     register_tiled_diag_field, send_tile_data, diag_buff_type
use land_data_mod,      only : land_state_type, lnd
use land_tile_io_mod, only : create_tile_out_file, read_tile_data_r1d_fptr, &
     write_tile_data_r1d_fptr, print_netcdf_error, get_input_restart_name, &
     sync_nc_files
use nf_utils_mod, only : nfu_def_dim, nfu_put_att
use land_debug_mod, only : is_watch_point

implicit none
private

! ==== public interfaces =====================================================
public :: read_snow_namelist
public :: snow_init
public :: snow_end
public :: save_snow_restart
public :: snow_get_sfc_temp
public :: snow_get_depth_area
public :: snow_radiation
public :: snow_diffusion
public :: snow_step_1
public :: snow_step_2
! =====end of public interfaces ==============================================


! ==== module variables ======================================================
character(len=*), parameter, private   :: &
       module_name = 'snow_mod' ,&
       version     = '$Id: snow.F90,v 17.1.2.1.2.1 2010/08/24 12:11:35 pjp Exp $' ,&
       tagname     = '$Name: hiram_20101115_bw $'

! ==== module variables ======================================================

!---- namelist ---------------------------------------------------------------
logical :: retro_heat_capacity  = .false.
logical :: lm2  = .false.
logical :: steal = .false.
character(len=16):: albedo_to_use = ''  ! or 'brdf-params'
real    :: max_snow             = 1000.
real    :: wet_max              = 0.0  ! TEMP, move to snow_data
real    :: snow_density         = 300. ! TEMP, move to snow_data and generalize
   real :: init_temp = 260.   ! cold-start snow T
   real :: init_pack_ws   =   0.  
   real :: init_pack_wl   =   0.
   real :: min_snow_mass = 0.

namelist /snow_nml/ retro_heat_capacity, lm2, steal, albedo_to_use, &
                    max_snow, wet_max, snow_density, &
                    init_temp, init_pack_ws, init_pack_wl, &
                    min_snow_mass
!---- end of namelist --------------------------------------------------------

logical         :: module_is_initialized =.FALSE.
logical         :: use_brdf
type(time_type) :: time
real            :: delta_time
integer         :: num_l    ! # of snow layers
! next three 'z' variables are all normalized by total snow pack depth
real            :: dz (max_lev) ! relative thicknesses of layers
real            :: z  (max_lev) ! relative depths of layer bounds
real            :: zz (max_lev) ! relative depths of layer centers
real            :: heat_capacity_retro = 1.6e6
real            :: mc_fict

! ==== end of module variables ===============================================

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

contains

! ============================================================================
subroutine read_snow_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: l            ! layer iterator

  call read_snow_data_namelist(num_l,dz,mc_fict)

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=snow_nml, iostat=io)
  ierr = check_nml_error(io, 'snow_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=snow_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'snow_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=snow_nml)
  endif

  ! -------- set up vertical discretization --------
  zz(1) = 0
  do l = 1, num_l
     zz(l+1) = zz(l) + dz(l)
     z(l)    = 0.5*(zz(l+1) + zz(l))
  enddo

end subroutine read_snow_namelist


! ============================================================================
! initialize snow model
subroutine snow_init ( id_lon, id_lat )
  integer, intent(in)               :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in)               :: id_lat  ! ID of land latitude (Y) axis

  ! ---- local vars ----------------------------------------------------------
  integer :: unit         ! unit for various i/o
  type(land_tile_enum_type)     :: te,ce ! tail and current tile list elements
  type(land_tile_type), pointer :: tile  ! pointer to current tile
  character(len=256) :: restart_file_name
  logical :: restart_exists

  module_is_initialized = .TRUE.
  time       = lnd%time
  delta_time = time_type_to_real(lnd%dt_fast)

  ! -------- initialize snow state --------
  call get_input_restart_name('INPUT/snow.res.nc',restart_exists,restart_file_name)
  if (restart_exists) then
     call error_mesg('snow_init',&
          'reading NetCDF restart "'//trim(restart_file_name)//'"',&
          NOTE)
     __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,unit))
     call read_tile_data_r1d_fptr(unit, 'temp', snow_temp_ptr  )
     call read_tile_data_r1d_fptr(unit, 'wl'  , snow_wl_ptr )
     call read_tile_data_r1d_fptr(unit, 'ws'  , snow_ws_ptr )
     __NF_ASRT__(nf_close(unit))     
  else
     call error_mesg('snow_init',&
          'cold-starting snow',&
          NOTE)
     te = tail_elmt (lnd%tile_map)
     ce = first_elmt(lnd%tile_map)
     do while(ce /= te)
        tile=>current_tile(ce)  ! get pointer to current tile
        ce=next_elmt(ce)       ! advance position to the next tile
        
        if (.not.associated(tile%snow)) cycle
     
        tile%snow%prog(1:num_l)%wl = init_pack_wl * dz(1:num_l)
        tile%snow%prog(1:num_l)%ws = init_pack_wl * dz(1:num_l)
        tile%snow%prog(1:num_l)%T  = init_temp
     enddo
  endif

  if (trim(albedo_to_use)=='') then
     use_brdf = .false.
  elseif (trim(albedo_to_use)=='brdf-params') then
     use_brdf = .true.
  else
     call error_mesg('snow_init',&
          'option albedo_to_use="'//&
          trim(albedo_to_use)//'" is invalid, use "" or "brdf-params"',&
          FATAL)
  endif

end subroutine snow_init


! ============================================================================
subroutine snow_end ()

  module_is_initialized =.FALSE.

end subroutine snow_end


! ============================================================================
subroutine save_snow_restart (tile_dim_length, timestamp)
  integer, intent(in) :: tile_dim_length ! length of tile dim. in the output file
  character(*), intent(in) :: timestamp ! timestamp to add to the file name

  ! ---- local vars ----------------------------------------------------------
  integer :: unit            ! restart file i/o unit

  call error_mesg('snow_end','writing NetCDF restart',NOTE)
  ! create output file, including internal structure necessary for tile output
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'snow.res.nc', &
          lnd%coord_glon, lnd%coord_glat, snow_tile_exists, tile_dim_length )

  ! additionally, define vertical coordinate
  if (mpp_pe()==lnd%io_pelist(1)) then
     __NF_ASRT__(nfu_def_dim(unit,'zfull',zz(1:num_l),'depth of level centers'))
     __NF_ASRT__(nfu_put_att(unit,'zfull','positive','down'))
  endif
  call sync_nc_files(unit)

  ! write fields
  call write_tile_data_r1d_fptr(unit,'temp',snow_temp_ptr,'zfull','snow temperature','degrees_K')
  call write_tile_data_r1d_fptr(unit,'wl'  ,snow_wl_ptr,  'zfull','snow liquid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'ws'  ,snow_ws_ptr,  'zfull','snow solid water content','kg/m2')
  ! close output file
  if (mpp_pe()==lnd%io_pelist(1)) &
       __NF_ASRT__(nf_close(unit))

end subroutine save_snow_restart

! ============================================================================
subroutine snow_get_sfc_temp(snow, snow_T)
  type(snow_tile_type), intent(in) :: snow
  real, intent(out) :: snow_T
  
  snow_T = snow%prog(1)%T
end subroutine


! ============================================================================
subroutine snow_get_depth_area(snow, snow_depth, snow_area)
  type(snow_tile_type), intent(in) :: snow
  real, intent(out) :: snow_depth, snow_area

  integer :: l

  snow_depth= 0.0
  do l = 1, num_l
     snow_depth = snow_depth + snow%prog(l)%ws
  enddo
  snow_depth = snow_depth / snow_density
  call snow_data_area (snow_depth, snow_area )
end subroutine


! ============================================================================
! compute snow properties needed to do soil-canopy-atmos energy balance
subroutine snow_radiation ( snow_T, cosz, &
     snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis )
  real, intent(in) :: snow_T  ! snow temperature, deg K
  real, intent(in) :: cosz ! cosine of zenith angle
  real, intent(out) :: snow_refl_dir(NBANDS), snow_refl_dif(NBANDS), snow_refl_lw, snow_emis

  call snow_data_radiation (snow_T, snow_refl_dir, snow_refl_dif, &
                                snow_emis, cosz, use_brdf )
  snow_refl_lw = 1 - snow_emis
end subroutine 


! ============================================================================
! compute snow properties needed to do soil-canopy-atmos energy balance
subroutine snow_diffusion ( snow, snow_z0s, snow_z0m )
  type(snow_tile_type), intent(in) :: snow
  real, intent(out) :: snow_z0s, snow_z0m

  call snow_data_diffusion ( snow_z0s, snow_z0m )
end subroutine


! ============================================================================
! update snow properties explicitly for time step.
! integrate snow-heat conduction equation upward from bottom of snow
! to surface, delivering linearization of surface ground heat flux.
subroutine snow_step_1 ( snow, snow_G_Z, snow_G_TZ, &
                         snow_active, snow_T, snow_rh, snow_liq, snow_ice, &
                         snow_subl, snow_area, snow_G0, snow_DGDT )
  type(snow_tile_type), intent(inout) :: snow
  real,                 intent(in) :: snow_G_Z
  real,                 intent(in) :: snow_G_TZ
  logical,              intent(out):: snow_active
  real,                 intent(out):: &
       snow_T, snow_rh, snow_liq, snow_ice, &
       snow_subl, snow_area, snow_G0, snow_DGDT

  ! ---- local vars
  real :: snow_depth, bbb, denom, dt_e
  real, dimension(num_l):: aaa, ccc, thermal_cond, dz_phys, heat_capacity
  integer :: l

! ----------------------------------------------------------------------------
! in preparation for implicit energy balance, determine various measures
! of water availability, so that vapor fluxes will not exceed mass limits
! ----------------------------------------------------------------------------

  snow_T = tfreeze
  snow_T = snow%prog(1)%T

  call snow_data_thermodynamics ( snow_rh, thermal_cond )
  snow_depth= 0.0
  do l = 1, num_l
     snow_depth = snow_depth + snow%prog(l)%ws
  enddo
  snow_depth = snow_depth / snow_density
  call snow_data_area (snow_depth, snow_area )
  ! ---- only liquid in the top snow layer is available to freeze implicitly
  snow_liq =     snow%prog(1)%wl
  ! ---- snow in any layer can be melted implicitly
  snow_ice = sum(snow%prog(:)%ws)

! ---- fractionate evaporation/sublimation according to sfc phase ratios
!  where (max(snow%prog(1)%ws,0.)+max(snow%prog(1)%wl,0.)>0)
!      snow_subl = max(snow%prog(1)%ws,0.) &
!       /(max(snow%prog(1)%ws,0.)+max(snow%prog(1)%wl,0.))
!    elsewhere
!      snow_subl = 0
!    endwhere
!  snow_active = snow_subl>0.
  if (snow_depth>0) then
     snow_subl = 1.
  else
     snow_subl = 0
  endif
  snow_active = snow_subl>0.

  do l = 1, num_l
     dz_phys(l) = dz(l)*snow_depth
  enddo

  if (retro_heat_capacity) then
     do l = 1, num_l
        heat_capacity(l) = heat_capacity_retro*dz_phys(l)
     enddo
  else
     do l = 1, num_l
        heat_capacity(l) = mc_fict*dz(l) + &
             clw*snow%prog(l)%wl + csw*snow%prog(l)%ws
     enddo
  endif

!  if(num_l > 1) then
  if (snow_depth > 0) then
     do l = 1, num_l-1
        dt_e = 2 / ( dz_phys(l+1)/thermal_cond(l+1) &
                     + dz_phys(l)/thermal_cond(l)   )
        aaa(l+1) = - dt_e * delta_time / heat_capacity(l+1)
        ccc(l)   = - dt_e * delta_time / heat_capacity(l)
     enddo

     bbb = 1.0 - aaa(num_l) + delta_time*snow_G_TZ/heat_capacity(num_l)
     denom = bbb
     dt_e = aaa(num_l)*(snow%prog(num_l)%T - snow%prog(num_l-1)%T) &
          - delta_time*snow_G_Z/heat_capacity(num_l)
     snow%e(num_l-1) = -aaa(num_l)/denom
     snow%f(num_l-1) = dt_e/denom

     do l = num_l-1, 2, -1
        bbb = 1.0 - aaa(l) - ccc(l)
        denom = bbb + ccc(l)*snow%e(l)
        dt_e = - ( ccc(l)*(snow%prog(l+1)%T - snow%prog(l)%T  ) &
                  -aaa(l)*(snow%prog(l)%T   - snow%prog(l-1)%T) )
        snow%e(l-1) = -aaa(l)/denom
        snow%f(l-1) = (dt_e - ccc(l)*snow%f(l))/denom
     enddo

     denom = delta_time/heat_capacity(1)
     snow_G0    = ccc(1)*(snow%prog(2)%T- snow%prog(1)%T &
          + snow%f(1)) / denom
     snow_DGDT  = (1 - ccc(1)*(1-snow%e(1))) / denom    
  endif

!    else  ! one-level case
!      denom = delta_time/heat_capacity(1)
!      snow_G0    = 0.
!      snow_DGDT  = 1. / denom
!    end if

  if (snow_depth <= 0) then
     snow_G0   = snow_G_Z
     snow_DGDT = snow_G_TZ
  endif

  if(is_watch_point()) then
     write(*,*) 'snow_depth', snow_depth 
     write(*,*) '############ snow_step_1 output'
     write(*,*) 'mask      ', .true.
     write(*,*) 'snow_T    ', snow_T     
     write(*,*) 'snow_rh   ', snow_rh    
     write(*,*) 'snow_liq  ', snow_liq   
     write(*,*) 'snow_ice  ', snow_ice   
     write(*,*) 'snow_subl ', snow_subl  
     write(*,*) 'snow_area ', snow_area  
     write(*,*) 'snow_G_Z  ', snow_G_Z   
     write(*,*) 'snow_G_TZ ', snow_G_TZ  
     write(*,*) 'snow_G0   ', snow_G0    
     write(*,*) 'snow_DGDT ', snow_DGDT  
     write(*,*) '############ end of snow_step_1 output'
  endif

end subroutine snow_step_1



! ============================================================================
! apply boundary flows to snow water and move snow water vertically.
  subroutine snow_step_2 ( snow, snow_subl,                     &
                           vegn_lprec, vegn_fprec, vegn_hlprec, vegn_hfprec, &
                           DTg,  Mg_imp,  evapg,  fswg,  flwg,  sensg,  &
                           use_tfreeze_in_grnd_latent, subs_DT, &
                           subs_M_imp, subs_evap, subs_fsw, subs_flw, subs_sens,  &
                           snow_fsw, snow_flw, snow_sens, &
                           snow_levap, snow_fevap, snow_melt, &
                           snow_lprec, snow_hlprec, snow_lrunf, snow_frunf, &
                           snow_hlrunf, snow_hfrunf, snow_Tbot, snow_Cbot, snow_C, &
                           snow_avrg_T )
  type(snow_tile_type), intent(inout) :: snow
  real, intent(in) :: &
     snow_subl, vegn_lprec, vegn_fprec, vegn_hlprec, vegn_hfprec
  real, intent(in) :: &
     DTg, Mg_imp, evapg, fswg, flwg, sensg
  logical, intent(in) :: use_tfreeze_in_grnd_latent
  real, intent(out) :: &
         subs_DT, subs_M_imp, subs_evap, subs_fsw, subs_flw, subs_sens, &
         snow_fsw, snow_flw, snow_sens, &
         snow_levap, snow_fevap, snow_melt, &
         snow_lprec, snow_hlprec, snow_lrunf, snow_frunf, &
         snow_hlrunf, snow_hfrunf, snow_Tbot, snow_Cbot, snow_C, snow_avrg_T

  ! ---- local vars
  real, dimension(num_l) :: del_t, M_layer
  real :: depth, &
         cap0, dW_l, dW_s, dcap, dheat,&
         melt, melt_per_deg, drain,       &
         snow_mass, sum_liq, &
         sum_heat, sum_sno, &
         snow_transfer, frac,&
         liq_rate, hliq_rate,&
         sno_rate, hsno_rate, fict_heat, &
         evapg_lm2, vegn_fprec_lm2, &
         snow_LMASS, snow_FMASS, snow_HEAT
  integer :: l, l_old
  type(snow_prog_type) :: new_prog(num_l)
  ! --------------------------------------------------------------------------

  depth= 0.
  do l = 1, num_l
    depth = depth + snow%prog(l)%ws
  enddo
  depth = depth / snow_density

  if(is_watch_point()) then
     write(*,*) '############ snow_step_2 input'
     write(*,*) 'mask       ', .TRUE.       
     write(*,*) 'snow_subl  ', snow_subl  
     write(*,*) 'vegn_lprec ', vegn_lprec 
     write(*,*) 'vegn_fprec ', vegn_fprec 
     write(*,*) 'vegn_hlprec', vegn_hlprec
     write(*,*) 'vegn_hfprec', vegn_hfprec
     write(*,*) 'DTg        ', DTg        
     write(*,*) 'Mg_imp     ', Mg_imp     
     write(*,*) 'evapg      ', evapg      
     write(*,*) 'fswg       ', fswg       
     write(*,*) 'flwg       ', flwg       
     write(*,*) 'sensg      ', sensg      
     write(*,*) '############ end of snow_step_2 input'

     write(*,*) 'depth   ', depth
     do l = 1, num_l
        write(*,'(i2,3(x,a,g))') l,&
             ' wl=', snow%prog(l)%wl,&
             ' ws=', snow%prog(l)%ws,&
             ' T =', snow%prog(l)%T
     enddo
  endif

  snow_LMASS = 0; snow_FMASS = 0; snow_HEAT = 0
  do l = 1, num_l;
        snow_LMASS = snow_LMASS + snow%prog(l)%wl
        snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                                                * (snow%prog(l)%T-tfreeze)
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 1.01 ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

  ! ---- record fluxes -------------------------------------------------------
  if (lm2.and.steal) then
    if (snow_FMASS-Mg_imp > 0.) then
      if (evapg <= (snow_FMASS-Mg_imp)/delta_time) then
          evapg_lm2 = evapg
          vegn_fprec_lm2 = vegn_fprec
      else if (evapg <= (snow_FMASS-Mg_imp)/delta_time+vegn_fprec) then
          evapg_lm2 = evapg
          vegn_fprec_lm2 = vegn_fprec - evapg + (snow_FMASS-Mg_imp)/delta_time
      else
          evapg_lm2 = (snow_FMASS-Mg_imp)/delta_time+vegn_fprec
          vegn_fprec_lm2 = 0.
      endif
    else
      evapg_lm2 = 0.
      vegn_fprec_lm2 = vegn_fprec
    endif
  else
     evapg_lm2 = evapg
     vegn_fprec_lm2 = vegn_fprec
  endif
  vegn_fprec_lm2 = vegn_fprec
  if (depth>0) then
        snow_fsw   = fswg
        snow_flw   = flwg
        snow_sens  = sensg
        snow_levap = evapg_lm2*(1-snow_subl)
        snow_fevap = evapg_lm2*   snow_subl
  else
        snow_fsw    = 0
        snow_flw    = 0
        snow_sens   = 0
        snow_levap  = 0
        snow_fevap  = 0
  endif
  subs_fsw = fswg - snow_fsw
  subs_flw = flwg - snow_flw
  subs_evap = evapg - snow_levap - snow_fevap
  subs_sens = sensg - snow_sens 

  ! ---- load surface temp change and perform back substitution --------------
  if (depth>0) then
      del_t(1) = DTg
      snow%prog(1)%T  = snow%prog(1)%T + del_t(1)
  endif
  if ( num_l > 1) then
     do l = 1, num_l-1
        if (depth>0) then
            del_t(l+1) = snow%e(l) * del_t(l) + snow%f(l)
            snow%prog(l+1)%T = snow%prog(l+1)%T + del_t(l+1)
        endif
     enddo
  endif
  if (depth>0) then
    subs_DT = del_t(num_l)
  else
    subs_DT = DTg
  endif

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 2 ***** '
     do l = 1, num_l
        write(*,'(i2,a,g)') l,' T =', snow%prog(l)%T
     enddo
  endif

  snow_LMASS = 0; snow_FMASS = 0; snow_HEAT = 0
  do l = 1, num_l
        snow_LMASS = snow_LMASS + snow%prog(l)%wl
        snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                                                * (snow%prog(l)%T-tfreeze)
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 2.01 ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

  ! ---- evaporation and sublimation -----------------------------------------
  if (depth>0) then
      snow%prog(1)%wl = snow%prog(1)%wl - snow_levap*delta_time
      snow%prog(1)%ws = snow%prog(1)%ws - snow_fevap*delta_time
      cap0 = mc_fict*dz(1) + clw*snow%prog(1)%wl + csw*snow%prog(1)%ws
      ! T adjustment for nonlinear terms (del_T)*(del_W)
      dheat = delta_time*(clw*snow_levap+csw*snow_fevap)*del_T(1)
      ! take out extra heat not claimed in advance for evaporation
      if (use_tfreeze_in_grnd_latent) dheat = dheat &
            - delta_time*((cpw-clw)*snow_levap+(cpw-csw)*snow_fevap) &
                               *(snow%prog(1)%T-del_T(1)-tfreeze)
      snow%prog(1)%T  = snow%prog(1)%T  + dheat/cap0
    endif

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 2.5 ***** '
     do l = 1, num_l
        write(*,'(i2,3(a,g))')l,&
             ' wl=', snow%prog(l)%wl,&
             ' ws=', snow%prog(l)%ws,&
             ' T =', snow%prog(l)%T
     enddo
  endif

  snow_LMASS = 0; snow_FMASS = 0; snow_HEAT = 0
  do l = 1, num_l
        snow_LMASS = snow_LMASS + snow%prog(l)%wl
        snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                                                * (snow%prog(l)%T-tfreeze)
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 2.51 ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

  ! ---- distribute implicit phase change downward through snow layers -------
  if (depth>0) then 
      snow_melt = Mg_imp/delta_time
  else
      snow_melt = 0
  endif
  M_layer = 0.
  subs_M_imp = Mg_imp
  do l = 1, num_l
    if (depth>0 .and. subs_M_imp.gt.0) then
        M_layer(l) =  min( subs_M_imp, max(0.,snow%prog(l)%ws) )
        subs_M_imp = subs_M_imp - M_layer(l)
    endif
  enddo
  if (depth>0) then
      M_layer(1) = M_layer(1) + subs_M_imp
      subs_M_imp = 0.
  endif
  do l = 1, num_l
    if (depth>0) then
          cap0 = mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws
          snow%prog(l)%wl = snow%prog(l)%wl + M_layer(l)
          snow%prog(l)%ws = snow%prog(l)%ws - M_layer(l)
          snow%prog(l)%T  = tfreeze + (cap0*(snow%prog(l)%T-tfreeze) ) &
                                                          / ( cap0 + (clw-csw)*M_layer(l) )
    endif
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 3 ***** '
     do l = 1, num_l
        write(*,'(i2,3(a,g))') l,&
             ' wl=', snow%prog(l)%wl,&
             ' ws=', snow%prog(l)%ws,&
             '  T=', snow%prog(l)%T
     enddo
  endif

  snow_LMASS = 0; snow_FMASS = 0; snow_HEAT = 0
  do l = 1, num_l
    snow_LMASS = snow_LMASS + snow%prog(l)%wl
    snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                                                * (snow%prog(l)%T-tfreeze)
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 3.01 ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

! ----------------------------------------------------------------------------
!  call snow_data_hydraulics (pars, snow%prog%wl, psi, hyd_cond )

! ---- remainder of mass fluxes and associated sensible heat fluxes ----------
  liq_rate = vegn_lprec
  sno_rate = vegn_fprec_lm2
  hliq_rate = vegn_hlprec
  if (vegn_fprec.ne.0.) then
          hsno_rate = vegn_hfprec*(vegn_fprec_lm2/vegn_fprec)
  else
          hsno_rate = 0.
  endif

  do l = 1, num_l
    if(depth>0 .or. vegn_fprec_lm2>0) then
    ! ---- mix inflow with existing snow and water ---------------------------
          cap0 = mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws
          dW_l = liq_rate*delta_time
          dW_s = sno_rate*delta_time
          dcap = clw*dW_l + csw*dW_s
          snow%prog(l)%ws = snow%prog(l)%ws + dW_s
          snow%prog(l)%wl = snow%prog(l)%wl + dW_l
          snow%prog(l)%T  = tfreeze &
                                        + (cap0*(snow%prog(l)%T-tfreeze) &
                                        + (hsno_rate+hliq_rate)*delta_time) /(cap0 + dcap)
    endif

    if(is_watch_point()) then
       write(*,*) ' ***** snow_step_2 checkpoint 4a ***** '
       write(*,'(i2,3(a,g))') l,&
            ' wl=', snow%prog(l)%wl,&
            ' ws=', snow%prog(l)%ws,&
            '  T=', snow%prog(l)%T
    endif

    if (depth>0 .or. vegn_fprec_lm2>0) then
    ! ---- compute explicit melt/freeze --------------------------------------
          melt_per_deg = (cap0+dcap)/hlf
          if (snow%prog(l)%ws>0 .and. snow%prog(l)%T>tfreeze) then
                  melt =  min(snow%prog(l)%ws, (snow%prog(l)%T-tfreeze)*melt_per_deg)
      elseif (snow%prog(l)%wl>0 .and. snow%prog(l)%T<tfreeze) then
                  melt = -min(snow%prog(l)%wl, (tfreeze-snow%prog(l)%T)*melt_per_deg)
      else
                  melt = 0
          endif
          snow_melt = snow_melt + melt/delta_time
          snow%prog(l)%wl = snow%prog(l)%wl + melt
          snow%prog(l)%ws = snow%prog(l)%ws - melt
!        where (cap0+dcap.ne.0.) &
!        snow%prog(l)%T  = snow%prog(l)%T  - melt/melt_per_deg
          snow%prog(l)%T = tfreeze &
                 + ((cap0+dcap)*(snow%prog(l)%T-tfreeze) - hlf*melt) &
                                                          / ( cap0+dcap + (clw-csw)*melt )
    endif

   if(is_watch_point()) then
      write(*,*) ' ***** snow_step_2 checkpoint 4b ***** '
      write(*,'(i2,3(a,g))')l,&
            ' wl=', snow%prog(l)%wl,&
            ' ws=', snow%prog(l)%ws,&
            '  T=', snow%prog(l)%T
   endif

   if (depth>0 .or. vegn_fprec_lm2>0) then
    ! ---- compute drainage from this layer to next --------------------------
        drain = max (0., snow%prog(l)%wl - wet_max*snow%prog(l)%ws)
        snow%prog(l)%wl = snow%prog(l)%wl - drain
        liq_rate = drain / delta_time
        hliq_rate = clw*liq_rate*(snow%prog(l)%T-tfreeze)
        sno_rate = 0
        hsno_rate = 0
    endif
  enddo

  snow_lprec  = liq_rate
  snow_hlprec = hliq_rate

  snow_LMASS = 0; snow_FMASS = 0; snow_HEAT = 0
  do l = 1, num_l
        snow_LMASS = snow_LMASS + snow%prog(l)%wl
        snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                                                * (snow%prog(l)%T-tfreeze)
  enddo


  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 4c ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

! ---- conceptually remove fictitious mass/heat for the moment ---------------
  fict_heat = 0.
  do l = 1, num_l
    fict_heat = fict_heat + dz(l)*snow%prog(l)%T     ! (*mc_fict)
  enddo

  snow_mass  = sum(snow%prog%ws)
  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 4d ***** '
     write(*,*) 'max_snow    ', max_snow
     write(*,*) 'snow_mass   ', snow_mass
  endif

! ---- remove any isolated snow molecules (!) or sweep any excess snow from top of pack ----

  snow_lrunf  = 0.
  snow_frunf  = 0.
  snow_hlrunf = 0.
  snow_hfrunf = 0.
  if (0. < snow_mass .and. snow_mass < min_snow_mass ) then
        do l = 1, num_l
          snow_hlrunf = snow_hlrunf  &
            + clw*snow%prog(l)%wl*(snow%prog(l)%T-tfreeze)
          snow_hfrunf = snow_hfrunf  &
            + csw*snow%prog(l)%ws*(snow%prog(l)%T-tfreeze)
          enddo
        snow_lrunf  = sum(snow%prog%wl)
        snow_frunf  = snow_mass
        snow_mass   = 0.
        snow%prog%ws = 0.
        snow%prog%wl = 0.
    else if (max_snow < snow_mass) then
        snow_frunf  = snow_mass - max_snow
        snow_mass  = max_snow
        sum_sno  = 0
        snow_transfer = 0
        do l = 1, num_l
          if (sum_sno + snow%prog(l)%ws > snow_frunf) then
              snow_transfer = snow_frunf - sum_sno
            else
              snow_transfer = snow%prog(l)%ws
            endif
          if (snow%prog(l)%ws > 0) then
              frac = snow_transfer / snow%prog(l)%ws
            else
              frac = 1.
            endif
          sum_sno  = sum_sno  + snow_transfer
          snow_lrunf  = snow_lrunf  +     frac*snow%prog(l)%wl
          snow_hlrunf = snow_hlrunf + clw*frac*snow%prog(l)%wl*(snow%prog(l)%T-tfreeze)
          snow_hfrunf = snow_hfrunf + csw*frac*snow%prog(l)%ws*(snow%prog(l)%T-tfreeze)
          snow%prog(l)%ws = (1-frac)*snow%prog(l)%ws
          snow%prog(l)%wl = (1-frac)*snow%prog(l)%wl
          enddo
    endif
  snow_lrunf  = snow_lrunf  / delta_time
  snow_frunf  = snow_frunf  / delta_time
  snow_hlrunf = snow_hlrunf / delta_time
  snow_hfrunf = snow_hfrunf / delta_time

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 5 ***** '
     write(*,*) 'fict_heat         ', fict_heat
     do l = 1, num_l
        write(*,'(i2,3(a,g))')l,&
             ' wl=', snow%prog(l)%wl,&
             ' ws=', snow%prog(l)%ws,&
             ' T =', snow%prog(l)%T 
     enddo
  endif

  snow_LMASS = 0; snow_FMASS = 0; snow_HEAT = 0
  do l = 1, num_l
        snow_LMASS = snow_LMASS + snow%prog(l)%wl
        snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                                                * (snow%prog(l)%T-tfreeze)
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 5.01 ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

  depth= 0.
  new_prog%ws=0
  new_prog%wl=0
  new_prog%T=0
  do l = 1, num_l
    depth = depth + snow%prog(l)%ws
  enddo
  depth = depth / snow_density

!************************** fudge to avoid T=NaN from too-small mass **
!   if(depth*snow_density < min_snow_mass .and. depth>0.) then
!       depth = 0
!       snow%prog%ws = 0
!       snow%prog%wl = 0
!     endif

! ---- re-layer the snowpack ------------------------------------------------
  do l = 1, num_l
     if (depth > 0) then
        new_prog(l)%ws = snow_mass*dz(l)
        sum_sno = 0
        sum_liq = 0
        sum_heat = 0
     endif
     do l_old = 1, num_l
        if (depth > 0) then
           if (sum_sno + snow%prog(l_old)%ws > new_prog(l)%ws) then
              snow_transfer = new_prog(l)%ws - sum_sno
           else
              snow_transfer = snow%prog(l_old)%ws
           endif
           if (snow%prog(l_old)%ws .ne. 0.) then
              frac = snow_transfer / snow%prog(l_old)%ws
           else
              frac = 1
           endif
           sum_sno  = sum_sno  + snow_transfer
           sum_liq  = sum_liq  + frac*     snow%prog(l_old)%wl
           sum_heat = sum_heat + frac*&
                (clw*snow%prog(l_old)%wl + csw*snow%prog(l_old)%ws)&
                *snow%prog(l_old)%T
           snow%prog(l_old)%ws = (1.-frac)*snow%prog(l_old)%ws
           snow%prog(l_old)%wl = (1.-frac)*snow%prog(l_old)%wl
           if(is_watch_point()) then
              write(*,*) 'l=',l, ' l_old=',l_old,snow_transfer,frac,&
                   sum_sno,sum_liq, sum_heat
           endif
        endif
        
     enddo
     if (depth > 0) then
        new_prog(l)%wl = sum_liq
        new_prog(l)%T  = sum_heat &
             / (clw*new_prog(l)%wl + csw*new_prog(l)%ws)
     endif
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 5.1 ***** '
     write(*,*) 'depth             ', depth
     write(*,*) 'fict_heat         ', fict_heat
     do l = 1, num_l
        write(*,'(i2,3(a,g))')l,&
             ' new_wl=', new_prog(l)%wl,&
             ' new_ws=', new_prog(l)%ws,&
             ' new_T =', new_prog(l)%T 
     enddo
  endif

! add back fictional mass/heat
  do l = 1, num_l
    if (depth > 0) &
    new_prog(l)%T = ( &
    (clw*new_prog(l)%wl + csw*new_prog(l)%ws)*new_prog(l)%T  &
      + mc_fict*dz(l)*fict_heat ) &
      / (clw*new_prog(l)%wl + csw*new_prog(l)%ws + dz(l)*mc_fict)
  enddo
    
  do l = 1, num_l
!!    where (mask .and. snow_mass > 0) snow%prog(l) = new_prog(l)
    if (depth > 0) snow%prog(l) = new_prog(l)
  enddo

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 6 ***** '
     write(*,*) 'evap         ', subs_evap
     write(*,*) 'snow_lprec', snow_lprec
     write(*,*) 'depth        ', depth
     do l = 1, num_l
        write(*,'(i2,3(a,g))')l,&
             ' wl=', snow%prog(l)%wl,&
             ' ws=', snow%prog(l)%ws,&
             ' T =', snow%prog(l)%T 
     enddo
  endif

  snow_LMASS = 0
  snow_FMASS = 0
  snow_HEAT = 0
  do l = 1, num_l
        snow_LMASS = snow_LMASS + snow%prog(l)%wl
        snow_FMASS = snow_FMASS + snow%prog(l)%ws
        snow_HEAT = snow_HEAT + &
          (mc_fict*dz(l) + clw*snow%prog(l)%wl + csw*snow%prog(l)%ws)  &
                            * (snow%prog(l)%T-tfreeze)
  enddo
  snow_Tbot = snow%prog(num_l)%T
  snow_Cbot = mc_fict*dz(num_l) &
        + clw*snow%prog(num_l)%wl + csw*snow%prog(num_l)%ws
  snow_C = sum(mc_fict*dz(1:num_l) &
        + clw*snow%prog(1:num_l)%wl + csw*snow%prog(1:num_l)%ws)
  snow_avrg_T = snow_HEAT/snow_C+tfreeze

  if(is_watch_point()) then
     write(*,*) ' ***** snow_step_2 checkpoint 7 ***** '
     write(*,*) 'LMASS         ', snow_LMASS
     write(*,*) 'FMASS         ', snow_FMASS
     write(*,*) 'HEAT          ', snow_HEAT
  endif

  ! ---- increment time and do diagnostics -----------------------------------
  time = increment_time(time, int(delta_time), 0)

end subroutine snow_step_2

! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function snow_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   snow_tile_exists = associated(tile%snow)
end function snow_tile_exists

! ============================================================================
! accessor functions: given a pointer to a land tile, they return pointer
! to the desired member of the land tile, of NULL if this member does not
! exist.
subroutine snow_temp_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%snow)) ptr=>tile%snow%prog%T
   endif
end subroutine snow_temp_ptr

subroutine snow_wl_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%snow)) ptr=>tile%snow%prog%wl
   endif
end subroutine snow_wl_ptr

subroutine snow_ws_ptr(tile, ptr)
   type(land_tile_type), pointer :: tile
   real                , pointer :: ptr(:)
   ptr=>NULL()
   if(associated(tile)) then
      if(associated(tile%snow)) ptr=>tile%snow%prog%ws
   endif
end subroutine snow_ws_ptr

end module snow_mod





#include <fms_platform.h>

module snow_tile_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : &
     write_version_number, file_exist, check_nml_error, &
     close_file, stdlog
use constants_mod,only: tfreeze, hlf
use land_constants_mod, only : &
     NBANDS
use land_tile_selectors_mod, only : &
     tile_selector_type

implicit none
private

! ==== public interfaces =====================================================
public :: snow_prog_type
public :: snow_tile_type

public :: new_snow_tile, delete_snow_tile
public :: snow_tiles_can_be_merged, merge_snow_tiles
public :: snow_is_selected
public :: get_snow_tile_tag
public :: snow_tile_stock_pe
public :: snow_tile_heat

public :: read_snow_data_namelist

public :: snow_data_thermodynamics
public :: snow_data_hydraulics
public :: snow_data_area
public :: snow_data_radiation
public :: snow_data_diffusion

public :: max_lev
public :: cpw, clw, csw
! ==== end of public interfaces ==============================================
interface new_snow_tile
   module procedure snow_tile_ctor
   module procedure snow_tile_copy_ctor
end interface


! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'snow_tile_mod' ,&
     version     = '$Id: snow_tile.F90,v 17.0.4.1 2010/08/24 12:11:35 pjp Exp $' ,&
     tagname     = '$Name:  $'
integer, parameter :: max_lev = 10
real   , parameter :: t_range = 10.0 ! degK

! from the modis brdf/albedo product user's guide:
real            :: g_iso  = 1.
real            :: g_vol  = 0.189184
real            :: g_geo  = -1.377622
real            :: g0_iso = 1.0
real            :: g1_iso = 0.0
real            :: g2_iso = 0.0
real            :: g0_vol = -0.007574
real            :: g1_vol = -0.070987
real            :: g2_vol =  0.307588
real            :: g0_geo = -1.284909
real            :: g1_geo = -0.166314
real            :: g2_geo =  0.041840

! ==== types =================================================================
type :: snow_prog_type
  real wl
  real ws
  real T
end type snow_prog_type


type :: snow_tile_type
   integer :: tag ! kind of the tile
   type(snow_prog_type), pointer :: prog(:)
   real,                 pointer :: e(:), f(:)
end type snow_tile_type

! ==== module data ===========================================================

!---- namelist ---------------------------------------------------------------
logical :: use_mcm_masking       = .false.   ! MCM snow mask fn
real    :: w_sat                 = 670.
real    :: psi_sat               = -0.06
real    :: k_sat                 = 0.02
real    :: chb                   = 3.5
real    :: thermal_cond_ref      = 0.3
real    :: depth_crit            = 0.0167
real    :: z0_momentum           = 0.001
real    :: refl_snow_max_dir(NBANDS) = (/ 0.8,  0.8  /) ! reset to 0.6 for MCM
real    :: refl_snow_max_dif(NBANDS) = (/ 0.8,  0.8  /) ! reset to 0.6 for MCM
real    :: refl_snow_min_dir(NBANDS) = (/ 0.65, 0.65 /) ! reset to 0.45 for MCM
real    :: refl_snow_min_dif(NBANDS) = (/ 0.65, 0.65 /) ! reset to 0.45 for MCM
real    :: emis_snow_max         = 0.95      ! reset to 1 for MCM
real    :: emis_snow_min         = 0.90      ! reset to 1 for MCM
real    :: k_over_B              = 2         ! reset to 0 for MCM
integer :: num_l                 = 3         ! number of snow levels
real    :: dz(max_lev)           = (/0.1,0.8,0.1,0.,0.,0.,0.,0.,0.,0./)
                                              ! rel. thickness of model layers,
                                              ! from top down
real    :: cpw = 1952.  ! specific heat of water vapor at constant pressure
real    :: clw = 4218.  ! specific heat of water (liquid)
real    :: csw = 2106.  ! specific heat of water (ice)
real    :: mc_fict = 10. * 4218 ! additional (fictitious) soil heat capacity (for numerical stability?).
! from analysis of modis data (ignoring temperature dependence):
  real :: f_iso_cold(NBANDS) = (/ 0.354, 0.530 /)
  real :: f_vol_cold(NBANDS) = (/ 0.200, 0.252 /)
  real :: f_geo_cold(NBANDS) = (/ 0.054, 0.064 /)
  real :: f_iso_warm(NBANDS) = (/ 0.354, 0.530 /)
  real :: f_vol_warm(NBANDS) = (/ 0.200, 0.252 /)
  real :: f_geo_warm(NBANDS) = (/ 0.054, 0.064 /)
  real :: refl_cold_dif(NBANDS), refl_warm_dif(NBANDS)

namelist /snow_data_nml/use_mcm_masking,    w_sat,                 &
                    psi_sat,                k_sat,                 &
                    chb,                                           &
                    thermal_cond_ref,       depth_crit,            &
                    z0_momentum,                                   &
                    refl_snow_max_dir,    refl_snow_min_dir,   &
                    refl_snow_max_dif,    refl_snow_min_dif,   &
                    emis_snow_max,          emis_snow_min,         &
                    k_over_B,             &
                    num_l,                   dz, cpw, clw, csw, mc_fict, &
     f_iso_cold, f_vol_cold, f_geo_cold, f_iso_warm, f_vol_warm, f_geo_warm 
     
!---- end of namelist --------------------------------------------------------

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ============================================================================
subroutine read_snow_data_namelist(snow_num_l, snow_dz, snow_mc_fict)
  integer, intent(out) :: snow_num_l
  real,    intent(out) :: snow_dz(:)
  real,    intent(out) :: snow_mc_fict

  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=snow_data_nml, iostat=io)
  ierr = check_nml_error(io, 'snow_data_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=snow_data_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'snow_data_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  unit=stdlog()
  write(unit, nml=snow_data_nml)

  ! initialize global module data here

  ! set up output arguments
  snow_num_l = num_l
  snow_dz    = dz
  snow_mc_fict = mc_fict

  refl_cold_dif = g_iso*f_iso_cold + g_vol*f_vol_cold + g_geo*f_geo_cold
  refl_warm_dif = g_iso*f_iso_warm + g_vol*f_vol_warm + g_geo*f_geo_warm

end subroutine 

! ============================================================================
function snow_tile_ctor(tag) result(ptr)
  type(snow_tile_type), pointer :: ptr ! return value
  integer, optional, intent(in) :: tag ! kind of tile

  allocate(ptr)
  ptr%tag = 0 ; if(present(tag)) ptr%tag = tag
  ! allocate storage for tile data
  allocate(ptr%prog(num_l))
  allocate(ptr%e(num_l))
  allocate(ptr%f(num_l))

end function snow_tile_ctor

! ============================================================================
function snow_tile_copy_ctor(snow) result(ptr)
  type(snow_tile_type), pointer :: ptr ! return value
  type(snow_tile_type), intent(in) :: snow ! tile to copy

  allocate(ptr)
  ! copy all non-pointer members
  ptr = snow
  ! allocate storage for tile data
  allocate(ptr%prog(num_l))
  allocate(ptr%e(num_l))
  allocate(ptr%f(num_l))
  ! copy all pointer members
  ptr%prog(:) = snow%prog(:)
  ptr%e(:) = snow%e(:)
  ptr%f(:) = snow%f(:)
end function snow_tile_copy_ctor

! ============================================================================
subroutine delete_snow_tile(snow)
  type(snow_tile_type), pointer :: snow

  deallocate(snow%prog)
  deallocate(snow%e)
  deallocate(snow%f)
  deallocate(snow)
end subroutine delete_snow_tile

! =============================================================================
function snow_tiles_can_be_merged(snow1,snow2) result(response)
  logical :: response
  type(snow_tile_type), intent(in) :: snow1,snow2

  response = .TRUE.
end function

! =============================================================================
subroutine merge_snow_tiles(snow1, w1, snow2, w2)
  type(snow_tile_type), intent(in)    :: snow1
  type(snow_tile_type), intent(inout) :: snow2
  real                , intent(in)    :: w1, w2 ! relative weights
  
  ! ---- local vars
  real    :: x1, x2 ! normalized weights
  real    :: HEAT1, HEAT2
  integer :: i
  
  ! calculate normalized weights
  x1 = w1/(w1+w2)
  x2 = 1-x1
  
  do i = 1, num_l
    HEAT1 = (mc_fict*dz(i)+clw*snow1%prog(i)%wl+csw*snow1%prog(i)%ws)*(snow1%prog(i)%T-tfreeze)
    HEAT2 = (mc_fict*dz(i)+clw*snow2%prog(i)%wl+csw*snow2%prog(i)%ws)*(snow2%prog(i)%T-tfreeze)
    snow2%prog(i)%wl = snow1%prog(i)%wl*x1 + snow2%prog(i)%wl*x2
    snow2%prog(i)%ws = snow1%prog(i)%ws*x1 + snow2%prog(i)%ws*x2
    if (snow2%prog(i)%wl/=0.or.snow2%prog(i)%ws/=0) then
       snow2%prog(i)%T  = (HEAT1*x1+HEAT2*x2)/&
            (mc_fict*dz(i)+clw*snow2%prog(i)%wl+csw*snow2%prog(i)%ws)+tfreeze
    else
       snow2%prog(i)%T  = snow1%prog(i)%T*x1 + snow2%prog(i)%T*x2
    endif
  enddo
end subroutine

! =============================================================================
! returns true if tile fits the specified selector
function snow_is_selected(snow, sel)
  logical snow_is_selected
  type(tile_selector_type),  intent(in) :: sel
  type(snow_tile_type),      intent(in) :: snow

  snow_is_selected = .TRUE.
end function

! ============================================================================
! retruns tag of the tile
function get_snow_tile_tag(snow) result(tag)
  integer :: tag
  type(snow_tile_type), intent(in) :: snow
  
  tag = snow%tag
end function

! ============================================================================
! compute snow thermodynmamic properties.
subroutine snow_data_thermodynamics ( snow_rh, thermal_cond)
  real, intent(out) :: snow_rh
  real, intent(out) :: thermal_cond(:)

  ! snow surface assumed to have air at saturation
  snow_rh = 1

  ! these will eventually be functions of water contents and T.
  thermal_cond  = thermal_cond_ref

end subroutine 


! ============================================================================
! compute snow hydraulic properties (assumed dependent only on wl)
subroutine snow_data_hydraulics (wl, ws, psi, hyd_cond )
  real, intent(in),  dimension(:) :: wl, ws
  real, intent(out), dimension(:) :: psi, hyd_cond

  ! ---- local vars 
  integer :: l
  
  do l = 1, num_l
    psi     (l) = psi_sat *(w_sat/(wl(l)+ws(l)))**chb
    hyd_cond(l) = k_sat*(wl(l)/w_sat)**(3+2*chb)
  enddo

end subroutine snow_data_hydraulics


! ============================================================================
! compute snow area
subroutine snow_data_area ( snow_depth, snow_area )
    real, intent(in)  :: snow_depth
    real, intent(out) :: snow_area

  snow_area = 0.
  if (use_mcm_masking) then
     snow_area = min(1., 0.5*sqrt(max(0.,snow_depth)/depth_crit))
  else
     snow_area = max(0.,snow_depth) / (max(0.,snow_depth) + depth_crit)
  endif

end subroutine


! ============================================================================
subroutine snow_data_radiation(snow_T, snow_refl_dir, snow_refl_dif, snow_emis,&
                                  cosz, use_brdf)
  real, intent(in) :: snow_T
  real, intent(out):: snow_refl_dir(NBANDS), snow_refl_dif(NBANDS), snow_emis
  real, optional :: cosz
  logical :: use_brdf

  ! ---- local vars
  real :: blend
  real :: warm_value_dir(NBANDS), cold_value_dir(NBANDS)
  real :: warm_value_dif(NBANDS), cold_value_dif(NBANDS)
  real :: zenith_angle, zsq, zcu

  blend = max(0.,min(1.,1.-(tfreeze-snow_T)/t_range))
  if (use_brdf) then
     zenith_angle = acos(cosz)
     zsq = zenith_angle*zenith_angle
     zcu = zenith_angle*zsq
     warm_value_dir = f_iso_warm*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                    + f_vol_warm*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                    + f_geo_warm*(g0_geo+g1_geo*zsq+g2_geo*zcu)
     cold_value_dir = f_iso_cold*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                    + f_vol_cold*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                    + f_geo_cold*(g0_geo+g1_geo*zsq+g2_geo*zcu)
     warm_value_dif = refl_warm_dif
     cold_value_dif = refl_cold_dif
  else
     warm_value_dir = refl_snow_min_dir
     cold_value_dir = refl_snow_max_dir
     warm_value_dif = refl_snow_min_dif
     cold_value_dif = refl_snow_max_dif
  endif
  snow_refl_dir = cold_value_dir + blend*(warm_value_dir-cold_value_dir)
  snow_refl_dif = cold_value_dif + blend*(warm_value_dif-cold_value_dif)
  snow_emis     = emis_snow_max + blend*(emis_snow_min-emis_snow_max  )
end subroutine


! ============================================================================
subroutine snow_data_diffusion(snow_z0s, snow_z0m)
  real, intent(out):: snow_z0s, snow_z0m

  snow_z0m =  z0_momentum
  snow_z0s =  z0_momentum * exp(-k_over_B)
end subroutine

! ============================================================================
subroutine snow_tile_stock_pe (snow, twd_liq, twd_sol  )
  type(snow_tile_type),  intent(in)    :: snow
  real,                  intent(out)   :: twd_liq, twd_sol
  integer n
  
  twd_liq = 0.
  twd_sol = 0.
  do n=1, size(snow%prog)
    twd_liq = twd_liq + snow%prog(n)%wl
    twd_sol = twd_sol + snow%prog(n)%ws
    enddo

end subroutine snow_tile_stock_pe

! ============================================================================
! returns snow heat content, J/m2
function snow_tile_heat (snow) result(heat) ; real heat
  type(snow_tile_type), intent(in)  :: snow

  integer :: i

  heat = 0
  do i = 1,num_l
     heat = heat - snow%prog(i)%ws*hlf &
        + (mc_fict*dz(i) + clw*snow%prog(i)%wl + csw*snow%prog(i)%ws)  &
                                      * (snow%prog(i)%T-tfreeze) 
  enddo
end function

end module snow_tile_mod


! ============================================================================
! soil model module
! ============================================================================
module soil_mod

#include "../shared/debug.inc"

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only: error_mesg, file_exist, check_nml_error, &
     stdlog, write_version_number, close_file, mpp_pe, mpp_root_pe, FATAL, NOTE
use mpp_io_mod,         only: mpp_open, MPP_RDONLY
use time_manager_mod,   only: time_type, increment_time, time_type_to_real
use diag_manager_mod,   only: diag_axis_init
use constants_mod,      only: tfreeze, hlv, hlf, dens_h2o, PI
use horiz_interp_mod,   only: horiz_interp

use land_constants_mod, only : NBANDS, BAND_VIS, BAND_NIR
use soil_tile_mod, only : &
     soil_tile_type, soil_pars_type, soil_prog_type, read_soil_data_namelist, &
     soil_data_radiation, soil_data_diffusion, soil_data_thermodynamics, &
     soil_data_hydraulics, soil_data_gw_hydraulics, & ! soil_data_gw_tables, &
     soil_data_vwc_sat, &
     max_lev, psi_wilt, cpw, clw, csw, g_iso, g_vol, g_geo, g_RT, &
     num_storage_pts, num_zeta_s_pts, gw_zeta_s, gw_flux_table, gw_area_table, &
     gw_scale_length, gw_scale_relief, gw_scale_soil_depth

use land_tile_mod, only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, get_elmt_indices, &
     operator(/=)
use land_utils_mod, only : put_to_tiles_r0d_fptr, put_to_tiles_r1d_fptr
use land_tile_diag_mod, only : diag_buff_type, &
     register_tiled_static_field, register_tiled_diag_field, &
     send_tile_data, send_tile_data_r0d_fptr, send_tile_data_r1d_fptr, &
     send_tile_data_i0d_fptr
use land_data_mod,      only : land_state_type, lnd
use land_io_mod, only : read_field
use land_tile_io_mod, only : create_tile_out_file, write_tile_data_r0d_fptr,& 
     write_tile_data_r1d_fptr,read_tile_data_r0d_fptr, read_tile_data_r1d_fptr,&
     print_netcdf_error, get_input_restart_name, sync_nc_files
use nf_utils_mod, only : nfu_def_dim, nfu_put_att, nfu_inq_var
use vegn_tile_mod, only : vegn_tile_type, vegn_uptake_profile, vegn_root_properties
use land_debug_mod, only : is_watch_point, get_current_point
use uptake_mod, only : UPTAKE_LINEAR, UPTAKE_DARCY2D, UPTAKE_DARCY2D_LIN, &
     uptake_init, &
     darcy2d_uptake, darcy2d_uptake_solver, &
     darcy2d_uptake_lin, darcy2d_uptake_solver_lin
implicit none
private

! ==== public interfaces =====================================================
public :: read_soil_namelist
public :: soil_init
public :: soil_end
public :: save_soil_restart

public :: soil_get_sfc_temp
public :: soil_radiation
public :: soil_diffusion
public :: soil_step_1
public :: soil_step_2
! =====end of public interfaces ==============================================



! ==== module constants ======================================================
character(len=*), parameter, private   :: &
    module_name = 'soil',&
    version     = '$Id: soil.F90,v 17.0.2.2.2.1 2010/08/24 12:11:36 pjp Exp $',&
    tagname     = '$Name:  $'

! ==== module variables ======================================================

!---- namelist ---------------------------------------------------------------
logical :: lm2                  = .false.
logical :: use_E_min            = .false.     ! prohibit condensation
logical :: use_E_max            = .true.      ! theoretical effiltration capacity flag
real    :: init_temp            = 288.        ! cold-start soil T
real    :: init_w               = 150.        ! cold-start w(l)/dz(l)
real    :: init_groundwater     =   0.        ! cold-start gw storage
real    :: lrunf_ie_min         = -1.0e-4     ! trigger for clip and runoff
real    :: lrunf_ie_tol         =  1.e-12
character(len=16) :: albedo_to_use = ''       ! or 'albedo-map' or 'brdf-maps'
character(len=24) :: uptake_to_use = 'linear' ! or 'darcy2d', or 'darcy2d-linearized'
logical :: uptake_oneway        = .false.     ! if true, roots can't loose water to soil
logical :: uptake_from_sat      = .true.      ! if false, the uptake from saturated soil is prohibited
logical :: unconditional_sweep  = .false.
logical :: allow_negative_rie   = .false.
logical :: baseflow_where_frozen = .false.
logical :: write_when_flagged   = .false.
logical :: bypass_richards_when_stiff = .true.
logical :: corrected_lm2_gw     = .true.
real    :: active_layer_drainage_acceleration = 0.

namelist /soil_nml/ lm2, use_E_min, use_E_max,           &
                    init_temp,      &
                    init_w,       &
                    init_groundwater, lrunf_ie_min, lrunf_ie_tol, &
                    cpw, clw, csw, &
                    albedo_to_use, &
                    uptake_to_use, uptake_oneway, uptake_from_sat, &
                    unconditional_sweep, allow_negative_rie, &
                    baseflow_where_frozen, &
                    write_when_flagged, &
                    bypass_richards_when_stiff, corrected_lm2_gw, &
                    active_layer_drainage_acceleration
!---- end of namelist --------------------------------------------------------

logical         :: module_is_initialized =.FALSE.
logical         :: use_brdf = .false.
type(time_type) :: time
real            :: delta_time
logical         :: use_single_geo, use_geohydrology
integer         :: num_l              ! # of water layers
real            :: dz    (max_lev)    ! thicknesses of layers
real            :: zfull (max_lev)
real            :: zhalf (max_lev+1)
real            :: Eg_min

integer         :: uptake_option = -1 

! ---- diagnostic field IDs
integer :: id_lwc, id_swc, id_psi, id_temp, &
    id_ie, id_sn, id_bf, id_nu, id_hie, id_hsn, id_hbf, id_hnu, &
    id_heat_cap, id_thermal_cond, id_type, id_tau_gw, id_slope_l, &
    id_slope_Z, id_zeta_bar, id_e_depth, id_vwc_sat, id_vwc_fc, &
    id_vwc_wilt, id_K_sat, id_w_fc, &
    id_refl_dry_dif, id_refl_dry_dir, id_refl_sat_dif, id_refl_sat_dir, &
    id_f_iso_dry, id_f_vol_dry, id_f_geo_dry, &
    id_f_iso_sat, id_f_vol_sat, id_f_geo_sat, &
    id_evap, id_uptk_n_iter, id_uptk, id_uptk_residual, id_excess, &
    id_psi_bot, id_sat_frac, id_stor_frac, id_sat_depth, &
    id_uptk_old, id_psi_bot_old, id_sat_frac_old, id_stor_frac_old, &
    id_sat_depth_old, id_slope_Z_old, id_e_depth_old, &
    id_vwc_wilt_old, id_vwc_fc_old, id_vwc_sat_old, id_K_sat_old

! ==== end of module variables ===============================================

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

contains

! ============================================================================
subroutine read_soil_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: l

  call read_soil_data_namelist(num_l,dz,use_single_geo,use_geohydrology)

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=soil_nml, iostat=io)
  ierr = check_nml_error(io, 'soil_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=soil_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'soil_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=soil_nml)
  endif

  ! ---- set up vertical discretization
  zhalf(1) = 0
  do l = 1, num_l;   
     zhalf(l+1) = zhalf(l) + dz(l)
     zfull(l) = 0.5*(zhalf(l+1) + zhalf(l))
  enddo

  ! ---- convert symbolic names of the uptake options into numeric IDs to speed up
  ! the selection during run-time
  if (trim(uptake_to_use)=='linear') then
     uptake_option = UPTAKE_LINEAR
  else if (trim(uptake_to_use)=='darcy2d') then
     uptake_option = UPTAKE_DARCY2D
  else if (trim(uptake_to_use)=='darcy2d-linearized') then
     uptake_option = UPTAKE_DARCY2D_LIN
  else 
     call error_mesg('soil_init',&
          'soil uptake option uptake_to_use="'//&
          trim(uptake_to_use)//'" is invalid, use "linear", "darcy2d" or "darcy2d-linearized"',&
          FATAL)
  endif

  if (use_E_min) then
      Eg_min = 0.
    else
      Eg_min = -HUGE(Eg_min)
    endif

end subroutine read_soil_namelist


! ============================================================================
! initialize soil model
subroutine soil_init ( id_lon, id_lat, id_band )
  integer, intent(in)  :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in)  :: id_lat  ! ID of land latitude (Y) axis
  integer, intent(in)  :: id_band ! ID of spectral band axis

  ! ---- local vars
  integer :: unit         ! unit for various i/o
  type(land_tile_enum_type)     :: te,ce  ! tail and current tile list elements
  type(land_tile_type), pointer :: tile   ! pointer to current tile
  real, allocatable :: gw_param(:,:), gw_param2(:,:), albedo(:,:,:) ! input data buffers for respective variables
  real, allocatable :: f_iso(:,:,:), f_vol(:,:,:), f_geo(:,:,:), refl_dif(:,:,:)

  integer :: i, code, m
  real :: zeta_s, frac
 character(len=256) :: restart_file_name
  logical :: restart_exists

  module_is_initialized = .TRUE.
  time       = lnd%time
  delta_time = time_type_to_real(lnd%dt_fast)

  call uptake_init(num_l,dz,zfull)

  ! -------- initialize soil state --------
  te = tail_elmt (lnd%tile_map)
  ce = first_elmt(lnd%tile_map)
  do while(ce /= te)
     tile=>current_tile(ce)  ! get pointer to current tile
     ce=next_elmt(ce)        ! advance position to the next tile
     
     if (.not.associated(tile%soil)) cycle
     
     if (init_temp.ge.tile%soil%pars%tfreeze) then
        tile%soil%prog(1:num_l)%wl = init_w*dz(1:num_l)
        tile%soil%prog(1:num_l)%ws = 0
     else
        tile%soil%prog(1:num_l)%wl = 0
        tile%soil%prog(1:num_l)%ws = init_w*dz(1:num_l)
     endif
     tile%soil%prog%T             = init_temp
     tile%soil%prog%groundwater   = init_groundwater
     tile%soil%prog%groundwater_T = init_temp
     
     tile%soil%uptake_T           = init_temp
  enddo

  call get_input_restart_name('INPUT/soil.res.nc',restart_exists,restart_file_name)
  if (restart_exists) then
     call error_mesg('soil_init',&
          'reading NetCDF restart "'//trim(restart_file_name)//'"',&
          NOTE)
     __NF_ASRT__(nf_open(restart_file_name,NF_NOWRITE,unit))
     call read_tile_data_r1d_fptr(unit, 'temp'         , soil_T_ptr  )
     call read_tile_data_r1d_fptr(unit, 'wl'           , soil_wl_ptr )
     call read_tile_data_r1d_fptr(unit, 'ws'           , soil_ws_ptr )
     call read_tile_data_r1d_fptr(unit, 'groundwater'  , soil_groundwater_ptr )
     call read_tile_data_r1d_fptr(unit, 'groundwater_T', soil_groundwater_T_ptr)
     if(nfu_inq_var(unit, 'uptake_T')==NF_NOERR) &
          call read_tile_data_r0d_fptr(unit, 'uptake_T', soil_uptake_T_ptr)
          
     __NF_ASRT__(nf_close(unit))     
  else
     call error_mesg('soil_init',&
          'cold-starting soil',&
          NOTE)
  endif
  
  ! initialize soil model diagnostic fields
  call soil_diag_init ( id_lon, id_lat, id_band )
  
  ! read groundwater parameters, if requested
  if (.not.use_single_geo) then
      if (.not.use_geohydrology) then
          allocate(gw_param(lnd%is:lnd%ie,lnd%js:lnd%je))
          call read_field( 'INPUT/groundwater_residence.nc','tau', &
               lnd%lon, lnd%lat, gw_param, interp='bilinear' )
          call put_to_tiles_r0d_fptr( gw_param, lnd%tile_map, soil_tau_groundwater_ptr )
          deallocate(gw_param)
        else
          allocate(gw_param (lnd%is:lnd%ie,lnd%js:lnd%je))
          allocate(gw_param2(lnd%is:lnd%ie,lnd%js:lnd%je))
          call read_field( 'INPUT/geohydrology.nc','hillslope_length', &
               lnd%lon, lnd%lat, gw_param, interp='bilinear' )
          call put_to_tiles_r0d_fptr( gw_param*gw_scale_length, lnd%tile_map, soil_hillslope_length_ptr )
          call read_field( 'INPUT/geohydrology.nc','slope', &
               lnd%lon, lnd%lat, gw_param2, interp='bilinear' )
          gw_param = gw_param*gw_param2
          call put_to_tiles_r0d_fptr( gw_param*gw_scale_relief, lnd%tile_map, soil_hillslope_relief_ptr )
          call read_field( 'INPUT/geohydrology.nc','hillslope_zeta_bar', &
               lnd%lon, lnd%lat, gw_param, interp='bilinear' )
          call put_to_tiles_r0d_fptr( gw_param, lnd%tile_map, soil_hillslope_zeta_bar_ptr )
          call read_field( 'INPUT/geohydrology.nc','soil_e_depth', &
               lnd%lon, lnd%lat, gw_param, interp='bilinear' )
          call put_to_tiles_r0d_fptr( gw_param*gw_scale_soil_depth, lnd%tile_map, soil_soil_e_depth_ptr )
          deallocate(gw_param, gw_param2)
          te = tail_elmt (lnd%tile_map)
          ce = first_elmt(lnd%tile_map)
          do while(ce /= te)
            tile=>current_tile(ce)  ! get pointer to current tile
            ce=next_elmt(ce)        ! advance position to the next tile
            if (.not.associated(tile%soil)) cycle
            if (tile%soil%pars%hillslope_relief.le.0.) &
                tile%soil%pars%hillslope_relief =      &
                   tile%soil%pars%soil_e_depth / gw_zeta_s(num_zeta_s_pts)
            zeta_s = tile%soil%pars%soil_e_depth / tile%soil%pars%hillslope_relief
            zeta_s = max(zeta_s, gw_zeta_s(1))
            zeta_s = min(zeta_s, gw_zeta_s(num_zeta_s_pts))
            m = num_zeta_s_pts / 2
            code = 0
            do while (code.eq.0)
              if (zeta_s .lt. gw_zeta_s(m)) then
                  m = m - 1
                else if (zeta_s .gt. gw_zeta_s(m+1)) then
                  m = m + 1
                else
                 code = 1
                endif
              enddo
            frac = (zeta_s - gw_zeta_s(m)) / (gw_zeta_s(m+1) - gw_zeta_s(m))
            do i = 1, num_storage_pts
              tile%soil%pars%gw_flux_norm(i) = gw_flux_table(i,m) &
                   + frac*(gw_flux_table(i,m+1)-gw_flux_table(i,m))
              tile%soil%pars%gw_area_norm(i) = gw_area_table(i,m) &
                   + frac*(gw_area_table(i,m+1)-gw_area_table(i,m))
               enddo
            enddo
        endif
    endif

  ! set dry soil albedo values, if requested
  if (trim(albedo_to_use)=='albedo-map') then
     allocate(albedo(lnd%is:lnd%ie,lnd%js:lnd%je,NBANDS))
     call read_field( 'INPUT/soil_albedo.nc','SOIL_ALBEDO_VIS',&
          lnd%lon, lnd%lat, albedo(:,:,BAND_VIS),'bilinear')
     call read_field( 'INPUT/soil_albedo.nc','SOIL_ALBEDO_NIR',&
          lnd%lon, lnd%lat, albedo(:,:,BAND_NIR),'bilinear')
     call put_to_tiles_r1d_fptr( albedo, lnd%tile_map, soil_refl_dry_dir_ptr )
     call put_to_tiles_r1d_fptr( albedo, lnd%tile_map, soil_refl_dry_dif_ptr )
     ! for now, put the same value into the saturated soil albedo, so that
     ! the albedo doesn't depend on soil wetness
     call put_to_tiles_r1d_fptr( albedo, lnd%tile_map, soil_refl_sat_dir_ptr )
     call put_to_tiles_r1d_fptr( albedo, lnd%tile_map, soil_refl_sat_dif_ptr )
     deallocate(albedo)
  else if (trim(albedo_to_use)=='brdf-maps') then
     use_brdf = .true.
     allocate(   f_iso(lnd%is:lnd%ie,lnd%js:lnd%je,NBANDS))
     allocate(   f_vol(lnd%is:lnd%ie,lnd%js:lnd%je,NBANDS))
     allocate(   f_geo(lnd%is:lnd%ie,lnd%js:lnd%je,NBANDS))
     allocate(refl_dif(lnd%is:lnd%ie,lnd%js:lnd%je,NBANDS))
! *********************** ????????? *************
! sergey-- these are hig-res maps. is 'bilinear' the best option to use? i simply
! copied it from the albedo-map option.
! *********************** ????????? *************
     call read_field( 'INPUT/soil_brdf.nc','f_iso_vis',&
          lnd%lon, lnd%lat, f_iso(:,:,BAND_VIS),'bilinear')
     call read_field( 'INPUT/soil_brdf.nc','f_vol_vis',&
          lnd%lon, lnd%lat, f_vol(:,:,BAND_VIS),'bilinear')
     call read_field( 'INPUT/soil_brdf.nc','f_geo_vis',&
          lnd%lon, lnd%lat, f_geo(:,:,BAND_VIS),'bilinear')
     call read_field( 'INPUT/soil_brdf.nc','f_iso_nir',&
          lnd%lon, lnd%lat, f_iso(:,:,BAND_NIR),'bilinear')
     call read_field( 'INPUT/soil_brdf.nc','f_vol_nir',&
          lnd%lon, lnd%lat, f_vol(:,:,BAND_NIR),'bilinear')
     call read_field( 'INPUT/soil_brdf.nc','f_geo_nir',&
          lnd%lon, lnd%lat, f_geo(:,:,BAND_NIR),'bilinear')
     refl_dif = g_iso*f_iso + g_vol*f_vol + g_geo*f_geo
     call put_to_tiles_r1d_fptr( f_iso,    lnd%tile_map, soil_f_iso_dry_ptr )
     call put_to_tiles_r1d_fptr( f_vol,    lnd%tile_map, soil_f_vol_dry_ptr )
     call put_to_tiles_r1d_fptr( f_geo,    lnd%tile_map, soil_f_geo_dry_ptr )
     call put_to_tiles_r1d_fptr( refl_dif, lnd%tile_map, soil_refl_dry_dif_ptr )
     ! for now, put the same value into the saturated soil albedo, so that
     ! the albedo doesn't depend on soil wetness
     call put_to_tiles_r1d_fptr( f_iso,    lnd%tile_map, soil_f_iso_sat_ptr )
     call put_to_tiles_r1d_fptr( f_vol,    lnd%tile_map, soil_f_vol_sat_ptr )
     call put_to_tiles_r1d_fptr( f_geo,    lnd%tile_map, soil_f_geo_sat_ptr )
     call put_to_tiles_r1d_fptr( refl_dif, lnd%tile_map, soil_refl_sat_dif_ptr )
     deallocate(f_iso, f_vol, f_geo, refl_dif)
  else if (trim(albedo_to_use)=='') then
     ! do nothing, that is leave soil albedo parameters as defined based on the data table
  else
     call error_mesg('soil_init',&
          'option albedo_to_use="'// trim(albedo_to_use)//&
          '" is invalid, use "albedo-map", "brdf-maps", or nothing ("")',&
          FATAL)
  endif
  
  ! ---- static diagnostic section
  call send_tile_data_r0d_fptr(id_tau_gw,       lnd%tile_map, soil_tau_groundwater_ptr)
  call send_tile_data_r0d_fptr(id_slope_l,      lnd%tile_map, soil_hillslope_length_ptr)
  call send_tile_data_r0d_fptr(id_slope_Z,      lnd%tile_map, soil_hillslope_relief_ptr)
  call send_tile_data_r0d_fptr(id_zeta_bar,     lnd%tile_map, soil_hillslope_zeta_bar_ptr)
  call send_tile_data_r0d_fptr(id_e_depth,      lnd%tile_map, soil_soil_e_depth_ptr)
  call send_tile_data_r0d_fptr(id_vwc_wilt,     lnd%tile_map, soil_vwc_wilt_ptr)
  call send_tile_data_r0d_fptr(id_vwc_fc,       lnd%tile_map, soil_vwc_fc_ptr)
  call send_tile_data_r0d_fptr(id_vwc_sat,      lnd%tile_map, soil_vwc_sat_ptr)
  call send_tile_data_r0d_fptr(id_K_sat,        lnd%tile_map, soil_k_sat_ref_ptr)
  call send_tile_data_r1d_fptr(id_w_fc,         lnd%tile_map, soil_w_fc_ptr)
  call send_tile_data_r1d_fptr(id_refl_dry_dir, lnd%tile_map, soil_refl_dry_dir_ptr)
  call send_tile_data_r1d_fptr(id_refl_dry_dif, lnd%tile_map, soil_refl_dry_dif_ptr)
  call send_tile_data_r1d_fptr(id_refl_sat_dir, lnd%tile_map, soil_refl_sat_dir_ptr)
  call send_tile_data_r1d_fptr(id_refl_sat_dif, lnd%tile_map, soil_refl_sat_dif_ptr)
  call send_tile_data_r1d_fptr(id_f_iso_dry, lnd%tile_map, soil_f_iso_dry_ptr)
  call send_tile_data_r1d_fptr(id_f_vol_dry, lnd%tile_map, soil_f_vol_dry_ptr)
  call send_tile_data_r1d_fptr(id_f_geo_dry, lnd%tile_map, soil_f_geo_dry_ptr)
  call send_tile_data_r1d_fptr(id_f_iso_sat, lnd%tile_map, soil_f_iso_sat_ptr)
  call send_tile_data_r1d_fptr(id_f_vol_sat, lnd%tile_map, soil_f_vol_sat_ptr)
  call send_tile_data_r1d_fptr(id_f_geo_sat, lnd%tile_map, soil_f_geo_sat_ptr)
  call send_tile_data_i0d_fptr(id_type,         lnd%tile_map, soil_tag_ptr)

  call send_tile_data_r0d_fptr(id_slope_Z_old,      lnd%tile_map, soil_hillslope_relief_ptr)
  call send_tile_data_r0d_fptr(id_e_depth_old,      lnd%tile_map, soil_soil_e_depth_ptr)
  call send_tile_data_r0d_fptr(id_vwc_wilt_old,     lnd%tile_map, soil_vwc_wilt_ptr)
  call send_tile_data_r0d_fptr(id_vwc_fc_old,       lnd%tile_map, soil_vwc_fc_ptr)
  call send_tile_data_r0d_fptr(id_vwc_sat_old,      lnd%tile_map, soil_vwc_sat_ptr)
  call send_tile_data_r0d_fptr(id_K_sat_old,        lnd%tile_map, soil_k_sat_ref_ptr)

end subroutine soil_init


! ============================================================================
subroutine soil_diag_init ( id_lon, id_lat, id_band )
  integer, intent(in) :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in) :: id_lat  ! ID of land latitude (Y) axis
  integer, intent(in) :: id_band ! ID of spectral band axis  

  ! ---- local vars
  integer :: axes(3)
  integer :: id_zhalf, id_zfull

  ! define vertical axis and its' edges
  id_zhalf = diag_axis_init ( &
       'zhalf_soil', zhalf(1:num_l+1), 'meters', 'z', 'half level',  -1, set_name='soil' )
  id_zfull = diag_axis_init ( &
       'zfull_soil', zfull(1:num_l),   'meters', 'z', 'full level',  -1, set_name='soil', &
       edges=id_zhalf )

  ! define array of axis indices
  axes = (/ id_lon, id_lat, id_zfull /)

  ! define diagnostic fields
  id_lwc = register_tiled_diag_field ( module_name, 'soil_liq', axes,  &
       Time, 'bulk density of liquid water', 'kg/m3', missing_value=-100.0 )
  id_swc  = register_tiled_diag_field ( module_name, 'soil_ice',  axes,  &
       Time, 'bulk density of solid water', 'kg/m3',  missing_value=-100.0 )
  id_psi = register_tiled_diag_field ( module_name, 'soil_psi', axes,  &
       Time, 'soil-water matric head', 'm', missing_value=-100.0 )
  id_temp  = register_tiled_diag_field ( module_name, 'soil_T',  axes,       &
       Time, 'temperature',            'degK',  missing_value=-100.0 )
  id_ie  = register_tiled_diag_field ( module_name, 'soil_rie',  axes(1:2),  &
       Time, 'inf exc runf',            'kg/(m2 s)',  missing_value=-100.0 )
  id_sn  = register_tiled_diag_field ( module_name, 'soil_rsn',  axes(1:2),  &
       Time, 'satn runf',            'kg/(m2 s)',  missing_value=-100.0 )
  id_bf  = register_tiled_diag_field ( module_name, 'soil_rbf',  axes(1:2),  &
       Time, 'baseflow',            'kg/(m2 s)',  missing_value=-100.0 )
  id_nu  = register_tiled_diag_field ( module_name, 'soil_rnu',  axes(1:2),  &
       Time, 'numerical runoff',    'kg/(m2 s)',  missing_value=-100.0 )
  id_hie  = register_tiled_diag_field ( module_name, 'soil_hie',  axes(1:2), &
       Time, 'heat ie runf',            'W/m2',  missing_value=-100.0 )
  id_hsn  = register_tiled_diag_field ( module_name, 'soil_hsn',  axes(1:2), &
       Time, 'heat sn runf',            'W/m2',  missing_value=-100.0 )
  id_hbf  = register_tiled_diag_field ( module_name, 'soil_hbf',  axes(1:2), &
       Time, 'heat bf runf',            'W/m2',  missing_value=-100.0 )
  id_hnu  = register_tiled_diag_field ( module_name, 'soil_hnu',  axes(1:2), &
       Time, 'heat nu runoff',          'W/m2',  missing_value=-100.0 )
  id_evap  = register_tiled_diag_field ( module_name, 'soil_evap',  axes(1:2), &
       Time, 'soil evap',            'kg/(m2 s)',  missing_value=-100.0 )
  id_excess  = register_tiled_diag_field ( module_name, 'sfc_excess',  axes(1:2),  &
       Time, 'sfc excess pushed down',    'kg/(m2 s)',  missing_value=-100.0 )

  id_uptk_n_iter  = register_tiled_diag_field ( module_name, 'uptake_n_iter',  axes(1:2), &
       Time, 'number of iterations for soil uptake',  missing_value=-100.0 )
  id_uptk = register_tiled_diag_field ( module_name, 'soil_uptk', axes, &
       Time, 'uptake of water by roots', 'kg/(m2 s)',  missing_value=-100.0 )
  id_psi_bot = register_tiled_diag_field ( module_name, 'soil_psi_n', axes(1:2), &
       Time, 'psi at bottom of soil column', 'm',  missing_value=-100.0 )
  id_sat_frac = register_tiled_diag_field ( module_name, 'soil_fsat', axes(1:2), &
       Time, 'fraction of soil area saturated at surface', '-',  missing_value=-100.0 )
  id_stor_frac = register_tiled_diag_field ( module_name, 'soil_fgw', axes(1:2), &
       Time, 'groundwater storage frac above base elev', '-',  missing_value=-100.0 )
  id_sat_depth = register_tiled_diag_field ( module_name, 'soil_wtdep', axes(1:2), &
       Time, 'depth below sfc to saturated soil', 'm',  missing_value=-100.0 )

  ! ---- the following fields are for compatibility with older diag tables
  id_uptk_old = register_tiled_diag_field ( module_name, 'uptake', axes, &
       Time, 'uptake of water by roots (obsolete, use "soil_uptk" instead)', &
       'kg/(m2 s)',  missing_value=-100.0 )
  id_psi_bot_old = register_tiled_diag_field ( module_name, 'psi_bot', axes(1:2), &
       Time, 'psi at bottom of soil column (obsolete, use "soil_psi_n" instead)', &
       'm',  missing_value=-100.0 )
  id_sat_frac_old = register_tiled_diag_field ( module_name, 'sat_frac', axes(1:2), &
       Time, 'fraction of soil area saturated at surface (obsolete, use "soil_fsat" instead)',&
       '-',  missing_value=-100.0 )
  id_stor_frac_old = register_tiled_diag_field ( module_name, 'stor_frac', axes(1:2), &
       Time, 'groundwater storage frac above base elev (obsolete, use "soil_fgw" instead)',&
       '-',  missing_value=-100.0 )
  id_sat_depth_old = register_tiled_diag_field ( module_name, 'sat_depth', axes(1:2), &
       Time, 'depth below sfc to saturated soil (obsolete, use "soil_wtdep" instead)', &
       'm',  missing_value=-100.0 )
  ! ---- end of compatibility section

  id_heat_cap = register_tiled_diag_field ( module_name, 'soil_heat_cap',  &
       axes, Time, 'heat capacity of dry soil','J/(m3 K)', missing_value=-100.0 )
  id_thermal_cond =  register_tiled_diag_field ( module_name, 'soil_tcon', &
       axes, Time, 'soil thermal conductivity', 'W/(m K)',  missing_value=-100.0 )
  
  id_type = register_tiled_static_field ( module_name, 'soil_type',  &
       axes(1:2), 'soil type', missing_value=-1.0 )
  id_tau_gw = register_tiled_static_field ( module_name, 'tau_gw',  &
       axes(1:2), 'groundwater residence time', 's', missing_value=-100.0 )
  id_slope_l = register_tiled_static_field ( module_name, 'slope_l',  &
       axes(1:2), 'hillslope length', 'm', missing_value=-100.0 )
  id_slope_Z = register_tiled_static_field ( module_name, 'soil_rlief',  &
       axes(1:2), 'hillslope relief', 'm', missing_value=-100.0 )
  id_zeta_bar = register_tiled_static_field ( module_name, 'zeta_bar',  &
       axes(1:2), 'hillslope zeta bar', '-', missing_value=-100.0 )
  id_e_depth = register_tiled_static_field ( module_name, 'soil_depth',  &
       axes(1:2), 'soil e-folding depth', 'm', missing_value=-100.0 )
  id_vwc_wilt = register_tiled_static_field ( module_name, 'soil_wilt',  &
       axes(1:2), 'wilting water content', '-', missing_value=-100.0 )
  id_vwc_fc = register_tiled_static_field ( module_name, 'soil_fc',  &
       axes(1:2), 'field capacity', '-', missing_value=-100.0 )
  id_vwc_sat = register_tiled_static_field ( module_name, 'soil_sat',  &
       axes(1:2), 'soil porosity', '-', missing_value=-100.0 )
  id_K_sat = register_tiled_static_field ( module_name, 'soil_Ksat',  &
       axes(1:2), 'soil sat. hydraulic conductivity', 'kg /(m2 s)', missing_value=-100.0 )
  id_w_fc = register_tiled_static_field ( module_name, 'w_fc',  &
       axes, 'soil field capacity', missing_value=-1.0 )
  id_refl_dry_dir = register_tiled_static_field ( module_name, 'refl_dry_dir',  &
       (/id_lon, id_lat, id_band/), 'reflectance of dry soil for direct light', &
       missing_value=-1.0 )
  id_refl_dry_dif = register_tiled_static_field ( module_name, 'refl_dry_dif',  &
       (/id_lon, id_lat, id_band/), 'reflectance of dry soil for diffuse light', &
       missing_value=-1.0 )
  id_refl_sat_dir = register_tiled_static_field ( module_name, 'refl_sat_dir',  &
       (/id_lon, id_lat, id_band/), 'reflectance of saturated soil for direct light', &
       missing_value=-1.0 )
  id_refl_sat_dif = register_tiled_static_field ( module_name, 'refl_sat_dif',  &
       (/id_lon, id_lat, id_band/), 'reflectance of saturated soil for diffuse light', &
       missing_value=-1.0 )
  id_f_iso_dry = register_tiled_static_field ( module_name, 'f_iso_dry',  &
       (/id_lon, id_lat, id_band/), 'isotropic brdf weight, dry soil', &
       missing_value=-1.0 )
  id_f_vol_dry = register_tiled_static_field ( module_name, 'f_vol_dry',  &
       (/id_lon, id_lat, id_band/), 'volumetric brdf weight, dry soil', &
       missing_value=-1.0 )
  id_f_geo_dry = register_tiled_static_field ( module_name, 'f_geo_dry',  &
       (/id_lon, id_lat, id_band/), 'geometric brdf weight, dry soil', &
       missing_value=-1.0 )
  id_f_iso_sat = register_tiled_static_field ( module_name, 'f_iso_sat',  &
       (/id_lon, id_lat, id_band/), 'isotropic brdf weight, saturated soil', &
       missing_value=-1.0 )
  id_f_vol_sat = register_tiled_static_field ( module_name, 'f_vol_sat',  &
       (/id_lon, id_lat, id_band/), 'volumetric brdf weight, saturated soil', &
       missing_value=-1.0 )
  id_f_geo_sat = register_tiled_static_field ( module_name, 'f_geo_sat',  &
       (/id_lon, id_lat, id_band/), 'geometric brdf weight, saturated soil', &
       missing_value=-1.0 )

  ! the following fields are for compatibility with older diag tables only
  id_slope_Z_old = register_tiled_static_field ( module_name, 'slope_Z',  &
       axes(1:2), 'hillslope relief (obsolete, use "soil_rlief" instead)',&
       'm', missing_value=-100.0 )
  id_e_depth_old = register_tiled_static_field ( module_name, 'e_depth',  &
       axes(1:2), 'soil e-folding depth (obsolete, use "soil_depth" instead)', &
       'm', missing_value=-100.0 )
  id_vwc_wilt_old = register_tiled_static_field ( module_name, 'vwc_wilt',  &
       axes(1:2), 'wilting water content (obsolete, use "soil_wilt" instead)', &
       '-', missing_value=-100.0 )
  id_vwc_fc_old = register_tiled_static_field ( module_name, 'vwc_fc',  &
       axes(1:2), 'field capacity (obsolete, use "soil_fc" instead)', &
       '-', missing_value=-100.0 )
  id_vwc_sat_old = register_tiled_static_field ( module_name, 'vwc_sat',  &
       axes(1:2), 'soil porosity (obsolete, use "soil_sat")', &
       '-', missing_value=-100.0 )
  id_K_sat_old = register_tiled_static_field ( module_name, 'K_sat',  &
       axes(1:2), 'soil sat. hydraulic conductivity (obsolte, use "soil_Ksat" instead)', &
       'kg /(m2 s)', missing_value=-100.0 )

end subroutine soil_diag_init


! ============================================================================
subroutine soil_end ()

  module_is_initialized =.FALSE.

end subroutine soil_end


! ============================================================================
subroutine save_soil_restart (tile_dim_length, timestamp)
  integer, intent(in) :: tile_dim_length ! length of tile dim. in the output file
  character(*), intent(in) :: timestamp ! timestamp to add to the file name

  ! ---- local vars ----------------------------------------------------------
  integer :: unit            ! restart file i/o unit

  call error_mesg('soil_end','writing NetCDF restart',NOTE)
  ! create output file, including internal structure necessary for output
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'soil.res.nc', &
          lnd%coord_glon, lnd%coord_glat, soil_tile_exists, tile_dim_length )
  ! in addition, define vertical coordinate
  if (mpp_pe()==lnd%io_pelist(1)) then
     __NF_ASRT__(nfu_def_dim(unit,'zfull',zfull(1:num_l),'full level','m'))
     __NF_ASRT__(nfu_put_att(unit,'zfull','positive','down'))
  endif
  call sync_nc_files(unit)
        
  ! write out fields
  call write_tile_data_r1d_fptr(unit,'temp'         ,soil_T_ptr   ,'zfull','soil temperature','degrees_K')
  call write_tile_data_r1d_fptr(unit,'wl'           ,soil_wl_ptr  ,'zfull','liquid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'ws'           ,soil_ws_ptr  ,'zfull','solid water content','kg/m2')
  call write_tile_data_r1d_fptr(unit,'groundwater'  ,soil_groundwater_ptr  ,'zfull')
  call write_tile_data_r1d_fptr(unit,'groundwater_T',soil_groundwater_T_ptr ,'zfull')
  call write_tile_data_r0d_fptr(unit,'uptake_T',     soil_uptake_T_ptr, 'temperature of transpiring water', 'degrees_K')
  
  ! close file
  __NF_ASRT__(nf_close(unit))

end subroutine save_soil_restart


! ============================================================================
subroutine soil_get_sfc_temp ( soil, soil_T )
  type(soil_tile_type), intent(in) :: soil
  real, intent(out) :: soil_T

  soil_T= soil%prog(1)%T
end subroutine soil_get_sfc_temp


! ============================================================================
! compute soil radiative properties
subroutine soil_radiation ( soil, cosz, &
     soil_refl_dir, soil_refl_dif, soil_refl_lw, soil_emis )
  type(soil_tile_type), intent(in) :: soil
  real, intent(in)  :: cosz
  real, intent(out) :: soil_refl_dir(NBANDS), soil_refl_dif(NBANDS), soil_refl_lw, soil_emis

  call soil_data_radiation ( soil, cosz, use_brdf, soil_refl_dir, soil_refl_dif, soil_emis )
  soil_refl_lw = 1 - soil_emis
  if(any(soil_refl_dif<0).or.any(soil_refl_dif>1).or.&
     any(soil_refl_dir<0).or.any(soil_refl_dir>1)) then
    write(*,*)'soil_refl is out of range'
    write(*,*)'soil_refl_dif=',soil_refl_dif
    write(*,*)'soil_refl_dir=',soil_refl_dir
  endif
end subroutine soil_radiation


! ============================================================================
! compute soil roughness
subroutine soil_diffusion ( soil, soil_z0s, soil_z0m )
  type(soil_tile_type), intent(in) :: soil
  real, intent(out) :: soil_z0s, soil_z0m

  call soil_data_diffusion ( soil, soil_z0s, soil_z0m )
end subroutine soil_diffusion


! ============================================================================
! compute beta function
! after Manabe (1969), but distributed vertically.
subroutine soil_data_beta ( soil, vegn, soil_beta, soil_water_supply, &
                            soil_uptake_T, soil_rh, soil_rh_psi )
  type(soil_tile_type), intent(inout)  :: soil
  type(vegn_tile_type), intent(in)     :: vegn
  real, intent(out) :: soil_beta
  real, intent(out) :: soil_water_supply ! max rate of water supply to roots, kg/(m2 s)
  real, intent(out) :: soil_uptake_T ! an estimate of temperature of the water 
             ! taken up by transpiration. In case of 'linear' uptake it is an exact
             ! value; in case of 'darcy*' treatments the actual uptake profile
             ! is calculated only in step 2, so the value returned is an estimate  
  real, intent(out) :: soil_rh
  real, intent(out) :: soil_rh_psi

  ! ---- local vars
  integer :: l
  real, dimension(num_l) :: &
       uptake_frac_max, & ! root distribution
       vegn_uptake_term, &
       vlc, vsc, & ! volumetric fractions of water and ice in the layer
       DThDP, hyd_cond, DKDP, soil_w_fc, & ! soil hydraulic parameters (not used)
       VRL, & ! vertical distribution of volumetric root length, m/m3
       u, du ! uptake and its derivative (the latter is not used)
  real :: DPsi_min, DPsi_max, tau_gw, psi_for_rh
  real :: gw_length, gw_relief, gw_zeta_bar, gw_e_depth, K_sat ! soil hydraulic parameters (not used)
  real :: K_r, r_r ! root properties
  real :: z  !  soil depth

  call vegn_uptake_profile (vegn, dz(1:num_l), uptake_frac_max, vegn_uptake_term )

  vlc=0;vsc=0
  do l = 1, num_l
    vlc(l) = max(0., soil%prog(l)%wl / (dens_h2o*dz(l)))
    vsc(l) = max(0., soil%prog(l)%ws / (dens_h2o*dz(l)))
    enddo
  
  soil%uptake_frac = 0
  do l = 1, num_l
     soil%uptake_frac(l) = uptake_frac_max(l) &
          * max(0.0, min(1.0,(vlc(l)-soil%w_wilt(l))/&
               (0.75*(soil%w_fc(l)-soil%w_wilt(l)))))
  enddo
  soil_beta = sum(soil%uptake_frac)
  do l = 1, num_l
     if (soil_beta /= 0) then
          soil%uptake_frac(l) = soil%uptake_frac(l) / soil_beta
     else
          soil%uptake_frac(l) = uptake_frac_max(l)
     endif
  enddo
  if (lm2) soil%uptake_frac = uptake_frac_max

  ! calculate soil hydraulic properties, in particular psi_for_rh -- we don't use 
  ! anything else in this subroutine. this moved out of 'case' because
  ! we need psi unconditionally now for soil_rh
  
  call soil_data_hydraulics ( soil, vlc, vsc, &
       soil%psi, DThDP, hyd_cond, DKDP, DPsi_min, DPsi_max, tau_gw, &
       psi_for_rh, soil_w_fc )
  soil_rh = exp(psi_for_rh*g_RT)
  soil_rh_psi = g_RT*soil_rh

  ! calculate total water supply
  select case (uptake_option)
  case(UPTAKE_LINEAR)
     soil_water_supply = 0
     z = 0
     do l = 1, num_l
        soil_water_supply = soil_water_supply + &
          vegn_uptake_term(l)*max(0.0,soil%prog(l)%wl/dz(l)-soil%w_wilt(l)*dens_h2o)
        z = z + dz(l)
     enddo
     soil_water_supply = z * soil_water_supply
     soil_water_supply = soil_water_supply/delta_time
     soil_uptake_T = sum(soil%uptake_frac*soil%prog%T)
  case(UPTAKE_DARCY2D)
     call vegn_root_properties (vegn, dz(1:num_l), VRL, K_r, r_r)
     call darcy2d_uptake ( soil, psi_wilt, VRL, K_r, r_r, uptake_oneway,&
          uptake_from_sat, u, du )
     soil_water_supply = max(0.0,sum(u))
     soil_uptake_T = soil%uptake_T
  case(UPTAKE_DARCY2D_LIN)
     call vegn_root_properties (vegn, dz(1:num_l), VRL, K_r, r_r)
     call darcy2d_uptake_lin ( soil, psi_wilt, VRL, K_r, r_r, uptake_oneway, &
          uptake_from_sat, u, du)
     soil_water_supply = max(0.0,sum(u))
     soil_uptake_T = soil%uptake_T
  end select
end subroutine soil_data_beta


! ============================================================================
! update soil properties explicitly for time step.
! MAY WISH TO INTRODUCE 'UNIVERSAL' SENSITIVITIES FOR SIMPLICITY.
! T-DEPENDENCE OF HYDRAULIC PROPERTIES COULD BE DONE LESS FREQUENTLY.
! integrate soil-heat conduction equation upward from bottom of soil
! to surface, delivering linearization of surface ground heat flux.
subroutine soil_step_1 ( soil, vegn, diag, &
                         soil_T, soil_uptake_T, soil_beta, soil_water_supply, &
                         soil_E_min, soil_E_max, &
                         soil_rh, soil_rh_psi, soil_liq, soil_ice, soil_subl, soil_tf, &
                         soil_G0, soil_DGDT )
  type(soil_tile_type), intent(inout) :: soil
  type(vegn_tile_type), intent(in)    :: vegn
  type(diag_buff_type), intent(inout) :: diag
  real, intent(out) :: &
       soil_T, &    ! temperature of the upper layer of the soil, degK
       soil_uptake_T, & ! estimate of the temperature of the water taken up by transpiration
       soil_beta, &
       soil_water_supply, & ! supply of water to vegetation per unit total active root biomass, kg/m2 
       soil_E_min, &
       soil_E_max, &
       soil_rh,   & ! soil surface relative humidity
       soil_rh_psi,& ! derivative of soil_rh w.r.t. soil surface matric head
       soil_liq,  & ! amount of liquid water available for implicit freeze (=0)
       soil_ice,  & ! amount of ice available for implicit melt (=0)
       soil_subl, & ! part of sublimation in water vapor flux, dimensionless [0,1]
       soil_tf,   & ! soil freezing temperature, degK
       soil_G0, soil_DGDT ! linearization of ground heat flux
  ! ---- local vars
  real :: bbb, denom, dt_e
  real, dimension(num_l) :: aaa, ccc, thermal_cond, heat_capacity, vlc, vsc
  integer :: l

  if(is_watch_point()) then
     write(*,*) 'soil%tag', soil%tag
     write(*,*) 'soil%pars%k_sat_ref', soil%pars%k_sat_ref 
     write(*,*) 'soil%pars%psi_sat_ref', soil%pars%psi_sat_ref
     write(*,*) 'soil%pars%chb', soil%pars%chb
     write(*,*) 'soil%pars%w_sa', soil%pars%vwc_sat
  endif
! ----------------------------------------------------------------------------
! in preparation for implicit energy balance, determine various measures
! of water availability, so that vapor fluxes will not exceed mass limits
! ----------------------------------------------------------------------------

  soil_T = soil%prog(1)%T
  call soil_data_beta ( soil, vegn, soil_beta, soil_water_supply, soil_uptake_T, &
                        soil_rh, soil_rh_psi )

  do l = 1, num_l
    vlc(l) = max(0.0, soil%prog(l)%wl / (dens_h2o * dz(l)))
    vsc(l) = max(0.0, soil%prog(l)%ws / (dens_h2o * dz(l)))
    enddo
  call soil_data_thermodynamics ( soil, vlc, vsc,  &  
                                  soil_E_max, thermal_cond )
  if (.not.use_E_max) soil_E_max =  HUGE(soil_E_max)
  soil_E_min = Eg_min

  do l = 1, num_l
     heat_capacity(l) = soil%heat_capacity_dry(l) *dz(l) &
          + clw*soil%prog(l)%wl + csw*soil%prog(l)%ws
  enddo

  soil_liq  = max(soil%prog(1)%wl, 0.)
  soil_ice  = max(soil%prog(1)%ws, 0.)
  if (soil_liq + soil_ice > 0) then
     soil_subl = soil_ice / (soil_liq + soil_ice)
  else
     soil_subl = 0
  endif
  soil_liq = 0
  soil_ice = 0

  if(num_l > 1) then
     do l = 1, num_l-1
        dt_e = 2 / ( dz(l+1)/thermal_cond(l+1) &
                     + dz(l)/thermal_cond(l)   )
        aaa(l+1) = - dt_e * delta_time / heat_capacity(l+1)
        ccc(l)   = - dt_e * delta_time / heat_capacity(l)
     enddo

     bbb = 1.0 - aaa(num_l)
     denom = bbb
     dt_e = aaa(num_l)*(soil%prog(num_l)%T - soil%prog(num_l-1)%T)
     soil%e(num_l-1) = -aaa(num_l)/denom
     soil%f(num_l-1) = dt_e/denom
     do l = num_l-1, 2, -1
        bbb = 1.0 - aaa(l) - ccc(l)
        denom = bbb + ccc(l)*soil%e(l)
        dt_e = - ( ccc(l)*(soil%prog(l+1)%T - soil%prog(l)%T  ) &
                  -aaa(l)*(soil%prog(l)%T   - soil%prog(l-1)%T) )
        soil%e(l-1) = -aaa(l)/denom
        soil%f(l-1) = (dt_e - ccc(l)*soil%f(l))/denom
     end do
     denom = delta_time/(heat_capacity(1) )
     soil_G0   = ccc(1)*(soil%prog(2)%T- soil%prog(1)%T + soil%f(1)) / denom
     soil_DGDT = (1 - ccc(1)*(1-soil%e(1))) / denom   
  else  ! one-level case
     denom = delta_time/heat_capacity(1)
     soil_G0    = 0.
     soil_DGDT  = 1. / denom
  end if
  
  ! set soil freezing temperature
  soil_tf = soil%pars%tfreeze

  if(is_watch_point()) then
     write(*,*) '#### soil_step_1 checkpoint 1 ####'
     write(*,*) 'mask    ', .true.
     write(*,*) 'T       ', soil_T
     write(*,*) 'uptake_T', soil_uptake_T
     write(*,*) 'beta    ', soil_beta
     write(*,*) 'E_max   ', soil_E_max
     write(*,*) 'rh      ', soil_rh
     write(*,*) 'liq     ', soil_liq
     write(*,*) 'ice     ', soil_ice
     write(*,*) 'subl    ', soil_subl
     write(*,*) 'G0      ', soil_G0
     write(*,*) 'DGDT    ', soil_DGDT
     __DEBUG1__(soil_water_supply)
  endif

  call send_tile_data(id_thermal_cond, thermal_cond, diag)

end subroutine soil_step_1


! ============================================================================
! apply boundary flows to soil water and move soil water vertically.
  subroutine soil_step_2 ( soil, vegn, diag, soil_subl, snow_lprec, snow_hlprec,  &
                           vegn_uptk, &
                           subs_DT, subs_M_imp, subs_evap, &
                           use_tfreeze_in_grnd_latent, &
                           soil_levap, soil_fevap, soil_melt, &
                           soil_lrunf, soil_hlrunf, soil_Ttop, soil_Ctop )
  type(soil_tile_type), intent(inout) :: soil
  type(vegn_tile_type), intent(in)    :: vegn
  type(diag_buff_type), intent(inout) :: diag
  real, intent(in) :: &
     soil_subl     !
  real, intent(in) :: &
     snow_lprec, &
     snow_hlprec, &
     vegn_uptk, &
     subs_DT,       &!
     subs_M_imp,       &! rate of phase change of non-evaporated soil water
     subs_evap
  logical, intent(in) :: use_tfreeze_in_grnd_latent
  real, intent(out) :: &
     soil_levap, soil_fevap, soil_melt, &
     soil_lrunf, soil_hlrunf, soil_Ttop, soil_Ctop

  ! ---- local vars ----------------------------------------------------------
  real, dimension(num_l) :: del_t, eee, fff, &
             psi, DThDP, hyd_cond, DKDP, K, DKDPm, DKDPp, grad, &
             vlc, vsc, dW_l, u_minus, u_plus, DPsi, soil_w_fc, soil_vwc_sat
  real, dimension(num_l+1) :: flow, infilt
  real, dimension(num_l  ) :: div, dq, div_active
  real      :: &
     lprec_eff, hlprec_eff, tflow, hcap,cap_flow, dheat, &
     melt_per_deg, melt, adj, &
     liq_to_extract, ice_to_extract, heat_of_extract, &
     liq_to_extract_here, ice_to_extract_here, &
     lrunf_sn,lrunf_ie,lrunf_bf,lrunf_nu, hlrunf_sn,hlrunf_ie,hlrunf_bf,hlrunf_nu, &
     Qout, DQoutDP, tau_gw, gw_length, gw_relief, gw_zeta_bar, gw_e_depth, K_sat, &
     c0, c1, c2, x, aaa, bbb, ccc, ddd, xxx, sat_frac, z_sat, &
     gw_flux, storage_frac, depth_to_saturation, &
     Dpsi_min, Dpsi_max, psi_for_rh, &
     liq_frac, excess_wat, excess_liq, excess_ice, h1, h2, summax, &
     space_avail, liq_placed, ice_placed, excess_t, dW_l_internal, w_to_move_up
  logical :: stiff, flag
  real, dimension(num_l-1) :: del_z
  integer :: n_iter, l, ipt, jpt, kpt, fpt, l_internal, l_max_active_layer
  real :: jj,dpsi_alt
  real :: &
       VRL(num_l), & ! volumetric root length, m/m3
       K_r, & ! root membrame permeability, kg/(m3 s)
       r_r, & ! root radius, m
       uptake(num_l),   & ! uptake by roots per layer, kg/(m2 s)
       uptake_tot,      & ! total uptake, kg/(m2 s)
       uptake_pos,      & ! sum of the positive uptake, kg/(m2 s) 
       uptake_T_new, & ! updated average temperature of uptaken water, deg K
       uptake_T_corr,& ! correction for uptake temperature, deg K
       Tu ! temperature of water taken up from (or added to) a layer, deg K
  
  jj = 1.
  flag = .false.
  
  if(is_watch_point()) then
     write(*,*) ' ##### soil_step_2 checkpoint 1 #####'
     write(*,*) 'mask    ', .true.
     write(*,*) 'subs_evap    ', subs_evap
     write(*,*) 'snow_lprec   ', snow_lprec
     write(*,*) 'uptake  ', vegn_uptk
     write(*,*) 'subs_M_imp   ', subs_M_imp
     write(*,*) 'theta_s ', soil%pars%vwc_sat
     do l = 1, num_l
        write(*,'(a,i2.2,100(2x,a,g))') 'level=', l,&
             ' T =', soil%prog(l)%T,&
             ' Th=', (soil%prog(l)%ws+soil%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', soil%prog(l)%wl,&
             ' ws=', soil%prog(l)%ws,&
             ' gw=', soil%prog(l)%groundwater
     enddo
  endif

  ! ---- record fluxes ---------
  soil_levap  = subs_evap*(1-soil_subl)
  soil_fevap  = subs_evap*   soil_subl
  soil_melt   = subs_M_imp / delta_time

  ! ---- load surface temp change and perform back substitution --------------
  del_t(1) = subs_DT
  soil%prog(1)%T = soil%prog(1)%T + del_t(1)
  if ( num_l > 1) then
    do l = 1, num_l-1
      del_t(l+1) = soil%e(l) * del_t(l) + soil%f(l)
      soil%prog(l+1)%T = soil%prog(l+1)%T + del_t(l+1)
    end do
  end if

  if(is_watch_point()) then
     write(*,*) ' ##### soil_step_2 checkpoint 2 #####'
     do l = 1, num_l
        write(*,'(a,i2.2,100(2x,a,g))') 'level=',l, 'T=', soil%prog(l)%T, &
             'del_t=', del_t(l), 'e=', soil%e(l), 'f=', soil%f(l)
     enddo
  endif

  ! ---- extract evap from soil and do implicit melt --------------------
  IF(LM2) THEN
    do l = 1, num_l
      soil%prog(l)%wl = soil%prog(l)%wl &
                      - soil%uptake_frac(l)*soil_levap*delta_time
    enddo
  ELSE
    soil%prog(1)%wl = soil%prog(1)%wl - soil_levap*delta_time
    soil%prog(1)%ws = soil%prog(1)%ws - soil_fevap*delta_time
  ENDIF
  hcap = soil%heat_capacity_dry(1)*dz(1) &
                       + clw*soil%prog(1)%wl + csw*soil%prog(1)%ws
  ! T adjustment for nonlinear terms (del_T)*(del_W)
  dheat = delta_time*(clw*soil_levap+csw*soil_fevap)*del_T(1)
  ! take out extra heat not claimed in advance for evaporation
  if (use_tfreeze_in_grnd_latent) dheat = dheat &
          - delta_time*((cpw-clw)*soil_levap+(cpw-csw)*soil_fevap) &
                                 *(soil%prog(1)%T-del_T(1)-tfreeze)
  soil%prog(1)%T  = soil%prog(1)%T  + dheat/hcap
  soil%prog(1)%wl = soil%prog(1)%wl + subs_M_imp
  soil%prog(1)%ws = soil%prog(1)%ws - subs_M_imp
  soil%prog(1)%T  = tfreeze + (hcap*(soil%prog(1)%T-tfreeze) ) &
                              / ( hcap + (clw-csw)*subs_M_imp )

  ! calculate actual vertical distribution of uptake
  select case(uptake_option)
  case ( UPTAKE_LINEAR )
     uptake_T_corr = 0
     n_iter = 0
     uptake = soil%uptake_frac*vegn_uptk
  case ( UPTAKE_DARCY2D, UPTAKE_DARCY2D_LIN )     
     ! for Darcy-flow uptake, find the root water potential to satify actual
     ! transpiration by the vegetation
     call vegn_root_properties (vegn, dz(1:num_l), VRL, K_r, r_r)
     
     if ( uptake_option==UPTAKE_DARCY2D ) then
        call darcy2d_uptake_solver ( soil, vegn_uptk, VRL, K_r, r_r, &
             uptake_oneway, uptake_from_sat, uptake, n_iter)
     else
        call darcy2d_uptake_solver_lin ( soil, vegn_uptk, VRL, K_r, r_r, &
             uptake_oneway, uptake_from_sat, uptake, n_iter )
     endif

     uptake_pos = sum(uptake(:),mask=uptake(:)>0)
     if (uptake_pos > 0) then
        ! calculate actual temperature of uptake
        uptake_T_new  = sum(uptake*soil%prog%T,mask=uptake>0)/uptake_pos
        ! and temperature correction
        uptake_T_corr = soil%uptake_T - uptake_T_new
        if(is_watch_point()) then
           __DEBUG3__(soil%uptake_T, uptake_T_new, uptake_T_corr)
        endif
        ! save new uptake for the next time step to serve as an estimate of uptake 
        ! temperature
        soil%uptake_T    = uptake_T_new
     else
        uptake_T_corr = 0.0
        ! and don't change the soil%uptake_T
     endif
  case default
     call error_mesg('soil_step_2', 'invalid soil uptake option', FATAL)
  end select

  if (is_watch_point())then
     write(*,*) ' ##### soil_step_2 checkpoint 2.1 #####'
     __DEBUG2__(vegn_uptk,sum(uptake))
     do l = 1,num_l
        write(*,'(a,i2.2,100(2x,a,g))')'level=',l, &
             'uptake=',uptake(l),'dwl=',-uptake(l)*delta_time,&
             'wl=',soil%prog(l)%wl,'new wl=',soil%prog(l)%wl - uptake(l)*delta_time
     enddo
  endif

  call send_tile_data(id_uptk_n_iter, real(n_iter), diag)
  call send_tile_data(id_uptk, uptake, diag)
  call send_tile_data(id_uptk_old, uptake, diag)

  ! update temperature and water content of soil due to root uptake processes 
  do l = 1, num_l
     ! calculate the temperature of water that is taken from the layer (or added 
     ! to the layer), including energy balance correction 
     if (uptake(l) > 0) then
        Tu = soil%prog(l)%T + uptake_T_corr
     else
        Tu = soil%uptake_T + uptake_T_corr
     endif
     ! heat capacity of the layer
     hcap = soil%heat_capacity_dry(l)*dz(l) &
          + clw*soil%prog(l)%wl + csw*soil%prog(l)%ws

     soil%prog(l)%T = soil%prog(l)%T - &
          uptake(l)*delta_time*clw*( Tu-soil%prog(l)%T ) / &
          ( hcap - uptake(l)*delta_time*clw )
     soil%prog(l)%wl = soil%prog(l)%wl - uptake(l)*delta_time
  enddo

  if(is_watch_point()) then
     write(*,*) ' ##### soil_step_2 checkpoint 3 #####'
     do l = 1, num_l
        write(*,'(a,i2.2,100(2x,a,g))') ' level=', l,&
             ' T =', soil%prog(l)%T,&
             ' Th=', (soil%prog(l)%ws+soil%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', soil%prog(l)%wl,&
             ' ws=', soil%prog(l)%ws
     enddo
  endif
   lrunf_ie=0; lrunf_sn=0; lrunf_bf=0; lrunf_nu=0
  hlrunf_ie=0;hlrunf_sn=0;hlrunf_bf=0;hlrunf_nu=0
  ! ---- push down any excess surface water, with heat ---------------------
  call soil_data_vwc_sat(soil, soil_vwc_sat)
  liq_frac=0;excess_wat=0;excess_liq=0;excess_ice=0;h1=0;h2=0;liq_frac=0
  l = 1
  summax = max(0.,soil%prog(l)%wl)+max(0.,soil%prog(l)%ws)
  if (summax > 0) then
     liq_frac = max(0.,soil%prog(l)%wl) / summax
  else
     liq_frac = 1
  endif
  excess_wat = max(0., soil%prog(l)%wl + soil%prog(l)%ws &
       - dens_h2o*dz(l)*soil_vwc_sat(l) )
  excess_liq = excess_wat*liq_frac
  excess_ice = excess_wat-excess_liq
  excess_t   = soil%prog(l)%T
  soil%prog(l)%wl = soil%prog(l)%wl - excess_liq
  soil%prog(l)%ws = soil%prog(l)%ws - excess_ice
  call send_tile_data(id_excess, excess_wat/delta_time, diag)

  if(is_watch_point()) then
     write(*,*) ' ##### soil_step_2 checkpoint 3.001 #####'
     write(*,*) ' level=', l,&
          ' summax =', summax,&
          ' liq_frac =', liq_frac,&
          ' soil_vwc_sat =', soil_vwc_sat(l),&
          ' excess_liq =', excess_liq,&
          ' excess_ice =', excess_ice, &
          ' dens_h2o=', dens_h2o, &
          ' dz(l)=',dz(l),&
          'friday am'
  endif

  do l = 2, num_l
     if (excess_liq+excess_ice>0) then
        space_avail = dens_h2o*dz(l)*soil_vwc_sat(l) &
             - (soil%prog(l)%wl + soil%prog(l)%ws)
        liq_placed = max(min(space_avail, excess_liq), 0.)
        ice_placed = max(min(space_avail-liq_placed, excess_ice), 0.)
        h1 = (soil%heat_capacity_dry(l)*dz(l) &
             + csw*soil%prog(l)%ws + clw*soil%prog(l)%wl)
        h2 = liq_placed*clw+ice_placed*csw
        soil%prog(l)%T = (h1 * soil%prog(l)%T &
             + h2 * excess_T )  / (h1+h2)
        soil%prog(l)%wl = soil%prog(l)%wl + liq_placed
        soil%prog(l)%ws = soil%prog(l)%ws + ice_placed
        excess_liq = excess_liq - liq_placed
        excess_ice = excess_ice - ice_placed
     endif
  enddo

! to avoid adding frozen runoff to soil interface, melt all remaining
! excess ice, even if it results in supercooled liquid runoff
   lrunf_nu = (excess_liq+excess_ice) / delta_time
  hlrunf_nu = (  excess_liq*clw*(excess_T-tfreeze)  &
               + excess_ice*csw*(excess_T-tfreeze)  &
               - hlf*excess_ice                   ) / delta_time

  if(is_watch_point()) then
     write(*,*) ' ##### soil_step_2 checkpoint 3.01 #####'
     write(*,*) ' lrunf_nu',lrunf_nu
     write(*,*) 'hlrunf_nu',hlrunf_nu
     do l = 1, num_l
        write(*,'(x,a,x,i2.2,100(x,a,g))') ' level=', l,&
             ' T =', soil%prog(l)%T,&
             ' Th=', (soil%prog(l)%ws +soil%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', soil%prog(l)%wl,&
             ' ws=', soil%prog(l)%ws
     enddo
  endif

  ! ---- fetch soil hydraulic properties -------------------------------------
  vlc=0;vsc=0
  do l = 1, num_l
    vlc(l) = max(0., soil%prog(l)%wl / (dens_h2o*dz(l)))
    vsc(l) = max(0., soil%prog(l)%ws / (dens_h2o*dz(l)))
  enddo
  call soil_data_hydraulics (soil, vlc, vsc, &
                   psi, DThDP, hyd_cond, DKDP, Dpsi_min, Dpsi_max, tau_gw, &
                   psi_for_rh, soil_w_fc )

  IF (lm2) THEN ! ********************************

     if(is_watch_point()) then
        write(*,*) ' ##### soil_step_2 checkpoint 3.1 #####'
        do l = 1, num_l
           write(*,'(x,a,x,i2.2,100(x,a,g))')'level=', l, 'vlc', vlc(l), 'K  ', hyd_cond(l)
        enddo
     endif
  ! ---- remainder of mass fluxes and associated sensible heat fluxes --------
    flow=1
    flow(1)  = 0
    do l = 1, num_l
      infilt(l) = soil%uptake_frac(l)*snow_lprec *delta_time
      flow(l+1) = max(0., soil%prog(l)%wl + flow(l) &
            + infilt(l) - soil_w_fc(l)*dz(l)*dens_h2o)
      dW_l(l) = flow(l) - flow(l+1) + infilt(l)
      soil%prog(l)%wl = soil%prog(l)%wl + dW_l(l)
    enddo
    do l = 1, num_l
      flow(l) = flow(l) + infilt(l)
    enddo
    dW_l=0
    dpsi=0
    lrunf_bf = lrunf_bf + flow(num_l)/delta_time
  ELSE   ! ********************************
    IF (.NOT.USE_GEOHYDROLOGY) THEN
        div = 0.
        IF (CORRECTED_LM2_GW) THEN
            do l = 1, num_l
              if (vlc(l) .ge. soil_vwc_sat(l) .and. vsc(l).le.0.) &
                  div(l) = 0.15*dens_h2o*dz(l)/tau_gw
              enddo
          ELSE
            do l = 1, num_l
              if ((vsc(l)+vlc(l)) .ge. soil_vwc_sat(l)) &
                  div(l) = 0.15*dens_h2o*dz(l)*(vlc(l)/(vsc(l)+vlc(l)))/tau_gw
              enddo
          ENDIF
        z_sat = 0.
        do l=num_l,1,-1
           if(vsc(l)+vlc(l).le.soil_vwc_sat(l)) exit
           z_sat = z_sat + dz(l)
        enddo
        sat_frac = min((z_sat/zhalf(num_l+1))**soil%pars%rsa_exp,1.)
      ELSE
        call soil_data_gw_hydraulics(soil, zfull(num_l), psi(num_l), &
                gw_flux, sat_frac, storage_frac, depth_to_saturation)
        dq = 0.
        z_sat = 0.
        l = num_l
        div_active = 0.
        IF (BASEFLOW_WHERE_FROZEN) THEN
           do l=num_l,1,-1
              if(psi(l).le.0.) exit
              dq(l) = dz(l)*vlc(l)/(vlc(l)+vsc(l))
              z_sat = z_sat + dz(l)
           enddo
          ELSE
             do l=num_l,1,-1
                if(psi(l).le.0.) exit
                if (vsc(l).le.0.) dq(l) = dz(l)
                z_sat = z_sat + dz(l)
             enddo
         !   IF (DRAIN_ACTIVE_LAYER) THEN
                l_max_active_layer = 0
                do l=1,num_l
                   if(vsc(l).gt.0.) exit
                   l_max_active_layer = l
                enddo
                if (l_max_active_layer.lt.num_l .and. l_max_active_layer.gt.0) then
                    do l = 1, l_max_active_layer
                       if(vlc(l).gt.0) &
                           div_active(l) = hyd_cond(l) * soil%pars%hillslope_relief*dz(l) &
                                / (soil%pars%hillslope_length*soil%pars%hillslope_length)
                      enddo
                  endif
         !     ENDIF
          ENDIF
        div = 0.
        if (z_sat.gt.0.) div = (dq / z_sat) * gw_flux
        where (div.eq.0.) div = div_active*active_layer_drainage_acceleration
        call send_tile_data(id_psi_bot, psi(num_l), diag)
        call send_tile_data(id_psi_bot_old, psi(num_l), diag)
        call send_tile_data(id_sat_frac, sat_frac, diag)
        call send_tile_data(id_sat_frac_old, sat_frac, diag)
        call send_tile_data(id_stor_frac, storage_frac, diag)
        call send_tile_data(id_stor_frac_old, storage_frac, diag)
        if (depth_to_saturation .ge. -0.5) call send_tile_data(id_sat_depth, depth_to_saturation, diag)
        if (depth_to_saturation .ge. -0.5) call send_tile_data(id_sat_depth_old, depth_to_saturation, diag)
      ENDIF
    lrunf_bf = lrunf_bf + sum(div)
    if (snow_lprec.ne.0.) then
      lrunf_sn = sat_frac * snow_lprec
      hlrunf_sn = lrunf_sn*snow_hlprec/snow_lprec
    else
      lrunf_sn = 0.
      hlrunf_sn = 0.
    endif


    if(is_watch_point()) then
       do l = 1, num_l
          write(*,'(a,1x,i2.2,100(2x,g))')'div,vsc,psi,dz',l,div(l),vsc(l),psi(l),dz(l)
       enddo
       write(*,*)'lrunf_bf',lrunf_bf
       write(*,*)'tau_gw',tau_gw
       write(*,*)'dens_h2o',dens_h2o
    endif
  ! ---- soil-water flow ----------------------------------------------------
    flow = 0
    stiff = all(DThDP.eq.0)
    lprec_eff = snow_lprec - lrunf_sn
    hlprec_eff = snow_hlprec - hlrunf_sn
IF(stiff .AND. BYPASS_RICHARDS_WHEN_STIFF) THEN   ! BYPASS_RICHARDS_WHEN_STIFF
flow = 0.
div  = 0.
dW_l = 0.
lrunf_ie = lprec_eff
hlrunf_ie = hlprec_eff
lrunf_bf = 0.
hlrunf_bf =0.
psi=-zfull
dpsi=0.
ELSE                                              ! BYPASS_RICHARDS_WHEN_STIFF
    flow(1) = delta_time*lprec_eff
    do l = 1, num_l-1
      del_z(l) = zfull(l+1)-zfull(l)
      K(l) = 0.5*(hyd_cond(l)+hyd_cond(l+1))
      DKDPm(l) = 0. !0.5*DKDP(l)
      DKDPp(l) = 0. ! 0.5*DKDP(l+1)
!        K(l) = hyd_cond(l)
!        DKDPm(l) = DKDP(l)
!        DKDPp(l) = 0
      grad(l)  = jj*(psi(l+1)-psi(l))/del_z(l) - 1
    enddo

    if(is_watch_point()) then
       write(*,*) '##### soil_step_2 checkpoint 3.1 #####'
       do l = 1, num_l
          write(*,'(x,a,x,i2.2,x,a,100(x,g))') 'level=', l, 'DThDP,hyd_cond,psi,DKDP', &
               DThDP(l),&
               hyd_cond(l),&
               psi(l),&
               DKDP(l)
       enddo
       do l = 1, num_l-1
          write(*,'(a,i2.2,1x,a,100(2x,g))') 'interface=', l, 'K,DKDPm,DKDPp,grad,del_z', &
               K(l),&
               DKDPm(l),&
               DKDPp(l),&
               grad(l)
       enddo
    endif


    l = num_l
    xxx = dens_h2o*dz(l)*DThDP(l)/delta_time
    aaa =     - ( jj* K(l-1)/del_z(l-1) - DKDPm(l-1)*grad(l-1))
!      where (stiff)
    bbb = xxx - (- jj*K(l-1)/del_z(l-1) - DKDPp(l-1)*grad(l-1) )
    ddd = - K(l-1) *grad(l-1) - div(l)
!        elsewhere
!          Qout = hyd_cond(l) ! gravity drainage
!          DQoutDP = DKDP(l)  ! gravity drainage
!          Qout = 0.                ! no drainage
!          DQoutDP = 0.             ! no drainage
!          where (psi(l).gt.0.) ! linear baseflow from gw
!              Qout = 0.15*psi(l)/tau_gw
!              DQoutDP = 0.15/tau_gw
!            elsewhere
!              Qout = 0.
!              DQoutDP = 0.
!            endwhere
!          bbb = xxx - (- jj*K(l-1)/del_z(l-1) - DKDPp(l-1)*grad(l-1)&
!                      -DQoutDP )
!          ddd = -Qout - K(l-1) *grad(l-1)
!        endwhere
    eee(l-1) = -aaa/bbb
    fff(l-1) =  ddd/bbb
  
    if(is_watch_point()) then
       write(*,'(a,i2.2,100(2x,g))') 'l,a,b, ,d', l,aaa, bbb,ddd
    endif

    do l = num_l-1, 2, -1
      xxx = dens_h2o*dz(l)*DThDP(l)/delta_time
      aaa = - ( jj*K(l-1)/del_z(l-1) - DKDPm(l-1)*grad(l-1))
      bbb = xxx-( -jj*K(l-1)/del_z(l-1) - DKDPp(l-1)*grad(l-1)&
                  -jj*K(l  )/del_z(l  ) + DKDPm(l  )*grad(l  ))
      ccc =   - (  jj*K(l  )/del_z(l  ) + DKDPp(l  )*grad(l  ))
      ddd =       K(l)*grad(l) - K(l-1)*grad(l-1) &
                            - div(l)
      eee(l-1) =                    -aaa/(bbb+ccc*eee(l))
      fff(l-1) =  (ddd-ccc*fff(l))/(bbb+ccc*eee(l))
      if(is_watch_point()) then
         write(*,'(a,i2.2,100(2x,g))') 'l,a,b,c,d', l,aaa, bbb,ccc,ddd
      endif
    enddo
  
    l = 1
    xxx = dens_h2o*dz(l)*DThDP(l)/delta_time
    bbb = xxx - ( -jj*K(l  )/del_z(l  ) + DKDPm(l  )*grad(l  ))
    ccc =     - (  jj*K(l  )/del_z(l  ) + DKDPp(l  )*grad(l  ))
    ddd =          flow(1)/delta_time +    K(l)     *grad(l) &
                            - div(l)

IF (bbb+ccc*eee(l) .NE. 0.) THEN
    dPsi(l) = (ddd-ccc*fff(l))/(bbb+ccc*eee(l))
    if (.not.stiff .and. dPsi(l).gt.Dpsi_min .and. dPsi(l).lt.Dpsi_max) then
        lrunf_ie = 0.
      else
      	if (stiff) then
            dPsi(l) = - psi(l)
          else
            dPsi(l) = min (dPsi(l), Dpsi_max)
            dPsi(l) = max (dPsi(l), Dpsi_min)
          endif
        flow(l) = (dPsi(l)*(bbb+ccc*eee(l))+ccc*fff(l) &
                      - K(l)*grad(l))*delta_time
        lrunf_ie = lprec_eff - flow(l)/delta_time
        if (.not.allow_negative_rie.and.lrunf_ie.lt.-lrunf_ie_tol) then
            flag = .true.
            call get_current_point(ipt,jpt,kpt,fpt)
            dpsi_alt = (ddd-ccc*fff(l))/(bbb+ccc*eee(l))
            write(*,*) 'note 1: at point ',ipt,jpt,kpt,fpt,'rie= ',lrunf_ie,' reset to 0'
            write(*,*) 'note 1: at point ',ipt,jpt,kpt,fpt,'dPsi=',dPsi(l), ' reset to ',dpsi_alt
            write(*,*) 'note 1: at point ',ipt,jpt,kpt,fpt,'dPsi_min/max=',dPsi_min,dPsi_max
            dPsi(l) = dpsi_alt
            lrunf_ie = 0.
            flow(l) = lprec_eff*delta_time
          endif
      endif
  ELSE
      	if (stiff) then
            dPsi(l) = - psi(l)
          else
            dPsi(l) = Dpsi_max
          endif
        flow(l) = (dPsi(l)*(bbb+ccc*eee(l))+ccc*fff(l) &
                      - K(l)*grad(l))*delta_time
        lrunf_ie = lprec_eff - flow(l)/delta_time
        if (.not.allow_negative_rie.and.lrunf_ie.lt.-lrunf_ie_tol) then
            flag = .true.
            call get_current_point(ipt,jpt,kpt,fpt)
       ! next change will not change answers in previous runs, since old version would crash
       ! the only time this point was reached was when DThDP was zero everywhere.
       !     dpsi_alt = (ddd-ccc*fff(l))/(bbb+ccc*eee(l))
            dpsi_alt = 0.
            write(*,*) 'note 2: at point ',ipt,jpt,kpt,fpt,'rie=',lrunf_ie,' reset to 0'
            write(*,*) 'note 2: at point ',ipt,jpt,kpt,fpt,'dPsi=',dPsi(l),' reset to',dpsi_alt
            write(*,*) 'note 2: at point ',ipt,jpt,kpt,fpt,'dPsi_min/max=',dPsi_min,dPsi_max
            dPsi(l) = dpsi_alt
            lrunf_ie = 0.
            flow(l) = lprec_eff*delta_time
          endif
  ENDIF
      
    if(is_watch_point().or.(flag.and.write_when_flagged)) then
       write(*,'(a,i2.2,100(2x,g))') 'l,  b,c,d', l, bbb,ccc,ddd
       write(*,*) ' ##### soil_step_2 checkpoint 3.2 #####'
       write(*,*) 'ie,sn,bf:', lrunf_ie,lrunf_sn,lrunf_bf
       do l = 1, num_l-1
          write(*,'(a,i2.2,100(2x,g))') 'l,eee(l),fff(l)',l,eee(l),fff(l)
       enddo
       write(*,*) 'DThDP(1)', DThDP(1)
       write(*,*) 'K(1)', K(1)
       write(*,*) 'grad(1)', grad(1)
       write(*,*) 'ddd(1)', ddd
       write(*,*) 'ccc(1)', ccc
       write(*,*) 'bbb(1)', bbb
       write(*,*) 'dPsi(1)', dPsi(1)
       write(*,*) 'Psi(1)', Psi(1)
       write(*,*) 'div(1)', div(1)
    endif

    do l = 2, num_l
      dPsi(l) = eee(l-1)*dPsi(l-1) + fff(l-1)
    enddo
  
    l_internal = 1
    dW_l_internal = -1.e20
    do l = 1, num_l-1
      flow(l+1) = delta_time*( &
           -K(l)*(grad(l)&
           +jj*(DPsi(l+1)-DPsi(l))/ del_z(l)) &
           -grad(l)*(DKDPp(l)*Dpsi(l+1)+ &
                           DKDPm(l)*Dpsi(l) )  )
      dW_l(l) = flow(l) - flow(l+1) - div(l)*delta_time
      if (flag .and. l.gt.1. .and. dW_l(l).gt.dW_l_internal) then
          l_internal = l
          dW_l_internal = dW_l(l)
        endif
      enddo
    flow(num_l+1) = 0.
    dW_l(num_l) = flow(num_l) - flow(num_l+1) &
                            - div(num_l)*delta_time
    if (flag .and. dW_l(num_l).gt.dW_l_internal) then
        l_internal = num_l
        dW_l_internal = dW_l(num_l)
      endif

    if(is_watch_point().or.(flag.and.write_when_flagged)) then
       write(*,*) ' ##### soil_step_2 checkpoint 3.21 #####'
       do l = 1, num_l
          write(*,'(i2.2,100(2x,a,g))') l,&
               ' dW_l=', dW_l(l),&
               ' flow=', flow(l),&
               ' div=', div(l)
       enddo
    endif

    if (flag) then
        w_to_move_up = min(dW_l_internal, -(soil%prog(1)%wl+dW_l(1)))
        w_to_move_up = max(w_to_move_up, 0.)
        write(*,*) 'l_internal=',l_internal
        write(*,*) 'dW_l(l_internal)=',dW_l(l_internal)
        write(*,*) 'soil%prog(1)%wl+dW_l(1)',soil%prog(1)%wl+dW_l(1)
        write(*,*) 'w_to_move_up=',w_to_move_up
        if (l_internal.gt.1) then
            dW_l(1) = dW_l(1) + w_to_move_up
            dW_l(l_internal) = dW_l(l_internal) - w_to_move_up
            do l = 2, l_internal
              flow(l) = flow(l) - w_to_move_up
              enddo
          endif
      endif

    if(is_watch_point().or.(flag.and.write_when_flagged)) then
       write(*,*) ' ##### soil_step_2 checkpoint 3.22 #####'
       do l = 1, num_l
          write(*,'(i2.2,100(2x,a,g))') l,&
               ' dW_l=', dW_l(l),&
               ' flow=', flow(l),&
               ' div=', div(l)
       enddo
    endif

! In rare situations where lrunf_ie is large and negative, clip any liquid supersaturation
! layer by layer and recompute lrunf_ie (this is not good, since it ignores 'comp'):
  IF (lrunf_ie < lrunf_ie_min) THEN
       call get_current_point(ipt,jpt,kpt,fpt)
       write(*,*) 'note: at point ',ipt,jpt,kpt,fpt,' clip triggered by lrunf_ie=',lrunf_ie
       do l = num_l, 1, -1
          adj = max(dW_l(l)+soil%prog(l)%ws+soil%prog(l)%wl &
               - soil_vwc_sat(l)*dz(l)*dens_h2o, 0. )

          if(is_watch_point()) then
             write(*,*) '3.22 l=', l,&
                  ' soil_prog%wl=',soil%prog(l)%wl,  &
                  ' soil_prog%ws=',soil%prog(l)%ws , &
                  ' soil_vwc_sat=', soil_vwc_sat(l), &
                  ' dz=', dz(l), &
                  ' adj=', adj
          endif

          adj = min(adj, max(0.,soil%prog(l)%wl))

          if(is_watch_point()) then
             write(*,*) '3.23 l=', l, ' adj=', adj
          endif

          dW_l(l) = dW_l(l) - adj
          flow(l) = flow(l+1) + dW_l(l) + div(l)*delta_time
       enddo
       lrunf_ie = lprec_eff - flow(1)/delta_time

  ELSE IF (UNCONDITIONAL_SWEEP) THEN
  ! Sweep and fill upward any liquid supersaturation
  ! USE OF THIS EXPERIMENTAL CODE IS NOT RECOMMENDED. 
  ! CONFLICTS WITH COMP.NE.0 !!!
       excess_liq = 0.
       do l = num_l, 1, -1
         adj = dW_l(l)+soil%prog(l)%ws+soil%prog(l)%wl &
                        - soil_vwc_sat(l)*dz(l)*dens_h2o
         if (adj.gt.0.) then  ! collect excess liquid
             adj = min(adj, max(0.,soil%prog(l)%wl))
             dW_l(l) = dW_l(l) - adj
             excess_liq = excess_liq + adj
           else if (adj.lt.0.) then  ! deposit collected liquid
             if (excess_liq.gt.0.) then
                 adj = min(-adj, excess_liq)
                 dW_l(l) = dW_l(l) + adj
                 excess_liq = excess_liq - adj
               endif
           endif
         flow(l) = flow(l+1) + dW_l(l) + div(l)*delta_time
         enddo
       lrunf_ie = lprec_eff - flow(1)/delta_time
  ENDIF
       
       do l = 1, num_l
         soil%prog(l)%wl = soil%prog(l)%wl + dW_l(l)
         enddo

  if(is_watch_point().or.(flag.and.write_when_flagged)) then
     write(*,*) ' ***** soil_step_2 checkpoint 3.3 ***** '
     write(*,*) 'psi_sat',soil%pars%psi_sat_ref
     write(*,*) 'Dpsi_max',Dpsi_max
     do l = 1, num_l
        write(*,'(i2.2,100(2x,a,g))') l, &
             'Th=', (soil%prog(l)%ws +soil%prog(l)%wl)/(dens_h2o*dz(l)), &
             'wl=', soil%prog(l)%wl, &
             'ws=', soil%prog(l)%ws, &
             'dW_l=', dW_l(l), &
             'dPsi=', dPsi(l), &
             'flow=', flow(l)
     enddo
  endif

ENDIF                                              ! BYPASS_RICHARDS_WHEN_STIFF
  ENDIF ! ************************************

  if  (snow_lprec.ne.0.) then
    tflow = tfreeze + snow_hlprec/(clw*snow_lprec)
  else
    tflow = tfreeze
  endif

  if(is_watch_point()) then
     write(*,*) ' ***** soil_step_2 checkpoint 3.4 ***** '
     write(*,*) ' tfreeze', tfreeze
     write(*,*) '  tflow ', tflow
     write(*,*) ' snow_hlprec', snow_hlprec
  endif


! Upstream weighting of advection. Preserving u_plus here for now.
  u_minus = 1.
  where (flow.lt.0.) u_minus = 0.
  do l = 1, num_l-1
    u_plus(l) = 1. - u_minus(l+1)
    enddo
  hcap = (soil%heat_capacity_dry(num_l)*dz(num_l) &
                              + csw*soil%prog(num_l)%ws)/clw
  aaa = -flow(num_l) * u_minus(num_l)
  bbb =  hcap + soil%prog(num_l)%wl - dW_l(num_l) - aaa
  eee(num_l-1) = -aaa/bbb
  fff(num_l-1) = aaa*(soil%prog(num_l)%T-soil%prog(num_l-1)%T) / bbb

  do l = num_l-1, 2, -1
    hcap = (soil%heat_capacity_dry(l)*dz(l) &
                              + csw*soil%prog(l)%ws)/clw
    aaa = -flow(l)   * u_minus(l)
    ccc =  flow(l+1) * u_plus (l)
    bbb =  hcap + soil%prog(l)%wl - dW_l(l) - aaa - ccc
    eee(l-1) = -aaa / ( bbb +ccc*eee(l) )
    fff(l-1) = (   aaa*(soil%prog(l)%T-soil%prog(l-1)%T)    &
                       + ccc*(soil%prog(l)%T-soil%prog(l+1)%T)    &
                       - ccc*fff(l) ) / ( bbb +ccc*eee(l) )
  enddo
    
  hcap = (soil%heat_capacity_dry(1)*dz(1) + csw*soil%prog(1)%ws)/clw
  aaa = -flow(1) * u_minus(1)
  ccc =  flow(2) * u_plus (1)
  bbb =  hcap + soil%prog(1)%wl - dW_l(1) - aaa - ccc

  del_t(1) =  (  aaa*(soil%prog(1)%T-tflow          ) &
                     + ccc*(soil%prog(1)%T-soil%prog(2)%T) &
                     - ccc*fff(1) ) / (bbb+ccc*eee(1))
  soil%prog(1)%T = soil%prog(1)%T + del_t(1)

  if(is_watch_point()) then
     write(*,*) ' ***** soil_step_2 checkpoint 3.4.1 ***** '
     write(*,*) 'hcap', hcap
     write(*,*) 'aaa', aaa
     write(*,*) 'bbb', bbb
     write(*,*) 'ccc', ccc
     write(*,*) 'del_t(1)', del_t(1)
     write(*,*) ' T(1)', soil%prog(1)%T
  endif

  do l = 1, num_l-1
    del_t(l+1) = eee(l)*del_t(l) + fff(l)
    soil%prog(l+1)%T = soil%prog(l+1)%T + del_t(l+1)
  enddo

  tflow = soil%prog(num_l)%T

!  do l = 1, num_l
!    where (mask)
!        hcap = soil%heat_capacity_dry(l)*dz(l) &
!                 + clw*(soil%prog(l)%wl-dW_l(l)) + csw*soil%prog(l)%ws
!        cap_flow = clw*flow(l)
!        soil%prog(l)%T = (hcap*soil%prog(l)%T + cap_flow*tflow) &
!                         /(hcap                 + cap_flow      )
!        tflow  = soil%prog(l)%T
!      endwhere
!    enddo

  if(is_watch_point()) then
     write(*,*) ' ***** soil_step_2 checkpoint 3.5 ***** '
     write(*,*) 'hcap', hcap
     write(*,*) 'cap_flow', cap_flow
     do l = 1, num_l
        write(*,*) 'level=', l, ' T', soil%prog(l)%T
     enddo
  endif

  ! ---- groundwater ---------------------------------------------------------
  ! THIS T AVERAGING IS WRONG, BECAUSE IT NEGLECTS THE MEDIUM  ***
  ! ALSO, FREEZE-THAW IS NEEDED!
  ! PROBABLY THIS SECTION WILL BE DELETED ANYWAY, WITH GW TREATED ABOVE.
  IF (lm2) THEN
    do l = 1, 1      !TEMPORARY LAYER THING !!!!***
      if (soil%prog(l)%groundwater + flow(num_l+1) .ne. 0.) then ! TEMP FIX
          soil%prog(l)%groundwater_T =    &
           + (soil%prog(l)%groundwater*soil%prog(l)%groundwater_T &
              + flow(num_l+1)*tflow) &
            /(soil%prog(l)%groundwater + flow(num_l+1))
      endif
      c0 = delta_time/tau_gw
      c1 = exp(-c0)
      c2 = (1-c1)/c0
      x  = (1-c1)*soil%prog(l)%groundwater/delta_time &
                          + (1-c2)*flow(num_l+1)/delta_time
      soil%prog(l)%groundwater = c1 * soil%prog(l)%groundwater &
                                + c2 * flow(num_l+1)
      soil_lrunf  = x
      soil_hlrunf = x*clw*(soil%prog(l)%groundwater_T-tfreeze)
    enddo
  ELSE
    if (lprec_eff.ne.0. .and. flow(1).ge.0. ) then
      hlrunf_ie = lrunf_ie*hlprec_eff/lprec_eff
    else if (flow(1).lt.0. ) then
      hlrunf_ie = hlprec_eff - (flow(1)/delta_time)*clw &
                         *(soil%prog(1)%T-tfreeze)
    else
      hlrunf_ie = 0.
    endif
    hlrunf_bf = hlrunf_bf + clw*sum(div*(soil%prog%T-tfreeze))


    soil_lrunf  =  lrunf_sn +  lrunf_ie +  lrunf_bf +  lrunf_nu
    soil_hlrunf = hlrunf_sn + hlrunf_ie + hlrunf_bf + hlrunf_nu
  ENDIF

  do l = 1, num_l
    ! ---- compute explicit melt/freeze --------------------------------------
    hcap = soil%heat_capacity_dry(l)*dz(l) &
             + clw*soil%prog(l)%wl + csw*soil%prog(l)%ws
    melt_per_deg = hcap/hlf
    if       (soil%prog(l)%ws>0 .and. soil%prog(l)%T>soil%pars%tfreeze) then
      melt =  min(soil%prog(l)%ws, (soil%prog(l)%T-soil%pars%tfreeze)*melt_per_deg)
    else if (soil%prog(l)%wl>0 .and. soil%prog(l)%T<soil%pars%tfreeze) then
      melt = -min(soil%prog(l)%wl, (soil%pars%tfreeze-soil%prog(l)%T)*melt_per_deg)
    else
      melt = 0
    endif
    soil%prog(l)%wl = soil%prog(l)%wl + melt
    soil%prog(l)%ws = soil%prog(l)%ws - melt
    soil%prog(l)%T = tfreeze &
       + (hcap*(soil%prog(l)%T-tfreeze) - hlf*melt) &
                            / ( hcap + (clw-csw)*melt )
    soil_melt = soil_melt + melt / delta_time
  enddo

  if(is_watch_point()) then
     write(*,*) ' ##### soil_step_2 checkpoint 5 #####'
     do l = 1, num_l
        write(*,'(a,i2.2,100(2x,a,g))') ' level=', l,&
             ' T =', soil%prog(l)%T,&
             ' Th=', (soil%prog(l)%ws +soil%prog(l)%wl)/(dens_h2o*dz(l)),&
             ' wl=', soil%prog(l)%wl,&
             ' ws=', soil%prog(l)%ws,&
             ' gw=', soil%prog(l)%groundwater
     enddo
  endif


  soil_Ttop = soil%prog(1)%T
  soil_Ctop = soil%heat_capacity_dry(1)*dz(1) &
    + clw*soil%prog(1)%wl + csw*soil%prog(1)%ws


! ----------------------------------------------------------------------------
! given solution for surface energy balance, write diagnostic output.
!  

  ! ---- increment time and do diagnostics -----------------------------------
  time = increment_time(time, int(delta_time), 0)
  
  ! ---- diagnostic section
   call send_tile_data(id_temp, soil%prog%T, diag)
   if (id_lwc > 0) call send_tile_data(id_lwc,  soil%prog%wl/dz(1:num_l), diag)
   if (id_swc > 0) call send_tile_data(id_swc,  soil%prog%ws/dz(1:num_l), diag)
   if (id_psi > 0) call send_tile_data(id_psi,  psi+dPsi, diag)
   call send_tile_data(id_ie,   lrunf_ie, diag)
   call send_tile_data(id_sn,   lrunf_sn, diag)
   call send_tile_data(id_bf,   lrunf_bf, diag)
   call send_tile_data(id_nu,   lrunf_nu, diag)
   call send_tile_data(id_hie,  hlrunf_ie, diag)
   call send_tile_data(id_hsn,  hlrunf_sn, diag)
   call send_tile_data(id_hbf,  hlrunf_bf, diag)
   call send_tile_data(id_hnu,  hlrunf_nu, diag)
   if (id_evap > 0) call send_tile_data(id_evap,  soil_levap+soil_fevap, diag)

   call send_tile_data(id_heat_cap, soil%heat_capacity_dry, diag)

end subroutine soil_step_2


! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function soil_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   soil_tile_exists = associated(tile%soil)
end function soil_tile_exists


! ============================================================================
! cohort accessor functions: given a pointer to cohort, return a pointer to a
! specific member of the cohort structure
#define DEFINE_SOIL_ACCESSOR_0D(xtype,x) subroutine soil_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p;p=>NULL();if(associated(t))then;if(associated(t%soil))p=>t%soil%x;endif;end subroutine
#define DEFINE_SOIL_ACCESSOR_1D(xtype,x) subroutine soil_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p(:);p=>NULL();if(associated(t))then;if(associated(t%soil))p=>t%soil%x;endif;end subroutine
#define DEFINE_SOIL_COMPONENT_ACCESSOR_0D(xtype,component,x) subroutine soil_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p;p=>NULL();if(associated(t))then;if(associated(t%soil))p=>t%soil%component%x;endif;end subroutine
#define DEFINE_SOIL_COMPONENT_ACCESSOR_1D(xtype,component,x) subroutine soil_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p(:);p=>NULL();if(associated(t))then;if(associated(t%soil))p=>t%soil%component%x;endif;end subroutine

DEFINE_SOIL_ACCESSOR_1D(real,w_fc)
DEFINE_SOIL_ACCESSOR_0D(real,uptake_T)
DEFINE_SOIL_ACCESSOR_0D(integer,tag)

DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,tau_groundwater)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,hillslope_length)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,hillslope_relief)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,hillslope_zeta_bar)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,soil_e_depth)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,vwc_wilt)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,vwc_fc)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,vwc_sat)
DEFINE_SOIL_COMPONENT_ACCESSOR_0D(real,pars,k_sat_ref)

DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,refl_dry_dir)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,refl_dry_dif)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,refl_sat_dir)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,refl_sat_dif)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,f_iso_dry)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,f_vol_dry)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,f_geo_dry)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,f_iso_sat)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,f_vol_sat)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,pars,f_geo_sat)

DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,prog,T)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,prog,wl)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,prog,ws)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,prog,groundwater)
DEFINE_SOIL_COMPONENT_ACCESSOR_1D(real,prog,groundwater_T)

end module soil_mod





#include <fms_platform.h>

module soil_tile_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : &
     write_version_number, file_exist, check_nml_error, &
     close_file, stdlog, read_data
use constants_mod, only : &
     pi, tfreeze, rvgas, grav, dens_h2o, hlf
use land_constants_mod, only : &
     NBANDS
use land_io_mod, only : &
     init_cover_field
use land_tile_selectors_mod, only : &
     tile_selector_type, SEL_SOIL, register_tile_selector

implicit none
private

! ==== public interfaces =====================================================
public :: soil_pars_type
public :: soil_prog_type
public :: soil_tile_type

public :: new_soil_tile, delete_soil_tile
public :: soil_tiles_can_be_merged, merge_soil_tiles
public :: soil_is_selected
public :: get_soil_tile_tag
public :: soil_tile_stock_pe
public :: soil_tile_heat

public :: read_soil_data_namelist
public :: soil_cover_cold_start

public :: soil_data_radiation
public :: soil_data_diffusion
public :: soil_data_thermodynamics
public :: soil_data_hydraulics
public :: soil_data_gw_hydraulics
public :: soil_data_vwc_sat
public :: soil_ave_temp  ! calculate average soil temperature
public :: soil_ave_theta ! calculate average soil moisture, slm based on available capacity formulation  
public :: soil_ave_theta1! calculate average soil moisture, ens based on all available water
public :: g_iso, g_vol, g_geo, g_RT
public :: num_storage_pts, num_zeta_s_pts
public :: gw_zeta_s, gw_flux_table, gw_area_table
public :: gw_scale_length, gw_scale_relief, gw_scale_soil_depth

public :: max_lev, psi_wilt
! =====end of public interfaces ==============================================
interface new_soil_tile
   module procedure soil_tile_ctor
   module procedure soil_tile_copy_ctor
end interface

! ==== module constants ======================================================
character(len=*), parameter   :: &
     version     = '$Id: soil_tile.F90,v 17.0.2.1.2.1 2010/08/24 12:11:36 pjp Exp $', &
     tagname     = '$Name:  $', &
     module_name = 'soil_tile_mod'

integer, parameter :: max_lev          = 30 
integer, parameter :: n_dim_soil_types = 9       ! size of lookup table
integer, parameter :: num_storage_pts  = 26
integer, parameter :: num_zeta_s_pts   = 31
real,    parameter :: psi_wilt         = -150.0  ! matric head at wilting
real,    parameter :: small            = 1.e-4
real,    parameter :: t_ref            = 293
real,    parameter :: g_RT             = grav / (rvgas*t_ref)
real,    parameter :: sigma_max        = 2.2
real,    parameter :: K_rel_min        = 1.e-12

! from the modis brdf/albedo product user's guide:
real            :: g_iso  = 1.
real            :: g_vol  = 0.189184
real            :: g_geo  = -1.377622
real            :: g0_iso = 1.0
real            :: g1_iso = 0.0
real            :: g2_iso = 0.0
real            :: g0_vol = -0.007574
real            :: g1_vol = -0.070987
real            :: g2_vol =  0.307588
real            :: g0_geo = -1.284909
real            :: g1_geo = -0.166314
real            :: g2_geo =  0.041840

! ==== types =================================================================
type :: soil_pars_type
  real vwc_wilt
  real vwc_fc
  real vwc_sat
  real vlc_min
  real awc_lm2
  real k_sat_ref
  real psi_sat_ref
  real chb
  real alpha              ! *** REPLACE LATER BY alpha(layer)
  real heat_capacity_dry
  real thermal_cond_dry
  real thermal_cond_sat
  real thermal_cond_exp
  real thermal_cond_scale
  real thermal_cond_weight
  real refl_dry_dir(NBANDS)
  real refl_dry_dif(NBANDS)
  real refl_sat_dir(NBANDS)
  real refl_sat_dif(NBANDS)
  real f_iso_dry(NBANDS)
  real f_vol_dry(NBANDS)
  real f_geo_dry(NBANDS)
  real f_iso_sat(NBANDS)
  real f_vol_sat(NBANDS)
  real f_geo_sat(NBANDS)
  real emis_dry
  real emis_sat
  real z0_momentum
  real tau_groundwater
  real rsa_exp         ! riparian source-area exponent
  real hillslope_length
  real hillslope_relief
  real hillslope_zeta_bar
  real soil_e_depth
  real gw_flux_norm(num_storage_pts)
  real gw_area_norm(num_storage_pts)
  integer storage_index
  real tfreeze
end type soil_pars_type


type :: soil_prog_type
  real wl
  real ws
  real T
  real groundwater
  real groundwater_T
end type soil_prog_type


type :: soil_tile_type
   integer :: tag ! kind of the soil
   type(soil_pars_type)               :: pars
   type(soil_prog_type), pointer :: prog(:)
   real,                 pointer :: w_fc(:)
   real,                 pointer :: w_wilt(:)
   real :: Eg_part_ref
   real :: z0_scalar
   ! data that were local to soil.f90
   real,                 pointer :: uptake_frac(:)
   real,                 pointer :: heat_capacity_dry(:)
   real,                 pointer :: e(:),f(:)
   ! added to avoid recalculation of soil hydraulics in case of Darcy uptake
   real          :: uptake_T
   real, pointer :: psi(:) ! soil water potential
end type soil_tile_type

! ==== module data ===========================================================
real, public :: &
     cpw = 1952.0, & ! specific heat of water vapor at constant pressure
     clw = 4218.0, & ! specific heat of water (liquid)
     csw = 2106.0    ! specific heat of water (ice)

!---- namelist ---------------------------------------------------------------
real    :: comp                  = 0.001  ! m^-1, dThdPsi at saturation
real    :: k_over_B              = 2         ! reset to 0 for MCM
real    :: rate_fc               = 0.1/86400 ! 0.1 mm/d drainage rate at FC
real    :: sfc_heat_factor       = 1
real    :: z_sfc_layer           = 0.0
real    :: sub_layer_tc_fac      = 1.0
real    :: z_sub_layer_min       = 0.0
real    :: z_sub_layer_max       = 0.0
real    :: freeze_factor         = 1.0
integer :: num_l                 = 18        ! number of soil levels
real    :: dz(max_lev)           = (/ &
    0.02, 0.04, 0.04, 0.05, 0.05, 0.1, 0.1, 0.2, 0.2, &
    0.2,   0.4,  0.4,  0.4,  0.4, 0.4,  1.,  1.,  1., &
    0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0. /)
                                              ! thickness (m) of model layers,
                                              ! from top down
logical :: use_lm2_awc           = .false.
logical :: lm2                   = .false.
logical :: use_experimental_smc  = .false.
logical :: use_alt_psi_for_rh    = .false.
! ---- remainder are used only for cold start ---------
character(len=16):: soil_to_use     = 'single-tile'
       ! 'multi-tile' for multiple soil types per grid cell, a tile per type
       ! 'single-tile' for geographically varying soil with single type per
       !     model grid cell [default]
       ! 'uniform' for global constant soil, e.g., to reproduce MCM

logical :: use_mcm_albedo        = .false.   ! .true. for CLIMAP albedo inputs
logical :: use_single_geo        = .false.   ! .true. for global gw res time,
                                             ! e.g., to recover MCM
logical :: use_geohydrology      = .false.   ! .true. for analytic hillslope soln
integer :: soil_index_constant   = 9         ! index of global constant soil,
                                             ! used when use_single_soil
real    :: gw_res_time           = 60.*86400 ! mean groundwater residence time,
                                             ! used when use_single_geo
real    :: rsa_exp_global        = 1.5
real    :: gw_scale_length       = 1.0
real    :: gw_scale_relief       = 1.0
real    :: gw_scale_soil_depth   = 1.0

real, dimension(n_dim_soil_types) :: &
  dat_w_sat=&
  (/ 0.380, 0.445, 0.448, 0.412, 0.414, 0.446, 0.424, 0.445, 0.445   /),&
  dat_awc_lm2=&
  (/ 0.063, 0.132, 0.109, 0.098, 0.086, 0.120, 0.101, 0.445, 0.150   /),&
  dat_k_sat_ref=&
  (/ 0.021, .0036, .0018, .0087, .0061, .0026, .0051, .0036, .0036   /),&
  dat_psi_sat_ref=&
  (/ -.059, -0.28, -0.27, -0.13, -0.13, -0.27, -0.16, -0.28, -0.28   /),&
  dat_chb=&
  (/   3.5,   6.4,  11.0,   4.8,   6.3,   8.4,   6.3,   6.4,   6.4   /),&
!  dat_heat_capacity_ref =&
!  (/ 1.8e6, 2.0e6, 2.6e6, 1.9e6, 2.2e6, 2.3e6, 2.1e6, 3.0e6,   1.0   /),&
! previous (ref) values were based on typical water contents
! following dry values are based on w_min=(1-w_sat) w_org=0
! except for peat, where            w_org-(1-w_sat) w_min=0
! microscopic rho*c for w_min is 2650*733 and for w_org is 1300*1926
! (brutsaert 1982 evaporation into the atmosphere p 146)
! ignored air
  dat_heat_capacity_dry =&
  (/ 1.2e6, 1.1e6, 1.1e6, 1.1e6, 1.1e6, 1.1e6, 1.1e6, 1.4e6,   1.0   /),&
!  dat_thermal_cond_ref =&
!  (/   1.5,   0.8,  1.35,  1.15, 1.475, 1.075, 1.217,  0.39, 2.e-7   /),&
! previous (ref) values were based on typical water contents
! following dry and sat values and interpolating exponents are based on
! computations after deVries. i computed C M and F functions for
! unfrozen soil in
! spreadsheet Research\LaD2\soil thermal conductivity. the dry and
! sat values come right out of those computations. the exponent was
! done by eye. curves look like typical literature curves.
! TEMP: still need to treat freezing, maybe import deVries model into code.
  dat_thermal_cond_dry =&
  (/  0.14,  0.21,  0.20,  .175, 0.170, 0.205, 0.183,  0.05, 2.e-7   /),&
  dat_thermal_cond_sat =&
  (/  2.30,  1.50,  1.50,  1.90, 1.900, 1.500, 1.767,  0.50, 2.e-7   /),&
  dat_thermal_cond_scale =&
  (/  15.0,  0.50,   10.,  2.74,  12.2,  2.24,  4.22,   1.0,   1.0   /),&
  dat_thermal_cond_exp =&
  (/   3.0,   5.0,   6.0,   4.0,   4.5,   5.5, 4.667,   1.0,   1.0   /),&
  dat_thermal_cond_weight =&
  (/  0.20,  0.70,   0.7,  0.45, 0.450, 0.700, 0.533,   1.0,   1.0   /),&
  dat_emis_dry=&
  (/ 0.950, 0.950, 0.950, 0.950, 0.950, 0.950, 0.950, 0.950,   1.0   /),&
  dat_emis_sat=&
  (/ 0.980, 0.975, 0.970, .9775, 0.975, .9725, 0.975, 0.975,   1.0   /),&
  dat_z0_momentum=&
  (/  0.01,  0.01,  0.01,  0.01,  0.01,  0.01,  0.01,  0.01, 0.045   /),&
  dat_tf_depr=&
  (/  0.00,  0.00,  0.00,  0.00,  0.00,  0.00,  0.00,  0.00,   0.0   /)
  !Coarse  Medium   Fine    CM     CF     MF    CMF    Peat    MCM
real :: dat_refl_dry_dir(n_dim_soil_types,NBANDS); data dat_refl_dry_dir &
   / 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0,      & ! visible
     0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0   /     ! NIR
real :: dat_refl_dry_dif(n_dim_soil_types,NBANDS); data dat_refl_dry_dif &
   / 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0,      & ! visible
     0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0   /     ! NIR
real :: dat_refl_sat_dir(n_dim_soil_types,NBANDS); data dat_refl_sat_dir &
   / 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0,      & ! visible
     0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0   /     ! NIR
real :: dat_refl_sat_dif(n_dim_soil_types,NBANDS); data dat_refl_sat_dif &
   / 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0,      & ! visible
     0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 999.0   /     ! NIR
  !Coarse  Medium   Fine    CM     CF     MF    CMF    Peat    MCM
integer, dimension(n_dim_soil_types) :: &
  input_cover_types=&
  (/ 1,     2,     3,     4,     5,     6,     7,     8,     100   /)
character(len=4), dimension(n_dim_soil_types) :: &
  tile_names=&
  (/'c   ','m   ','f   ','cm  ','cf  ','mf  ','cmf ','peat','mcm ' /)

namelist /soil_data_nml/ &
     soil_to_use, tile_names, input_cover_types, &
     comp, k_over_B,             &
     rate_fc, sfc_heat_factor, z_sfc_layer, &
     sub_layer_tc_fac, z_sub_layer_min, z_sub_layer_max, freeze_factor, &
     num_l,                   dz,                      &
     use_lm2_awc,    lm2, use_experimental_smc, use_alt_psi_for_rh, &
     use_mcm_albedo,            &
     use_single_geo,         use_geohydrology, &
     soil_index_constant,         &
     gw_res_time,            rsa_exp_global,      &
     gw_scale_length, gw_scale_relief, gw_scale_soil_depth, &
     dat_w_sat,               dat_awc_lm2,     &
     dat_k_sat_ref,            &
     dat_psi_sat_ref,               dat_chb,          &
     dat_heat_capacity_dry,       dat_thermal_cond_dry,   &
     dat_thermal_cond_sat,        dat_thermal_cond_exp,   &
     dat_thermal_cond_scale,        dat_thermal_cond_weight,   &
     dat_refl_dry_dir,            dat_refl_sat_dir,              &
     dat_refl_dry_dif,            dat_refl_sat_dif,              &
     dat_emis_dry,              dat_emis_sat,                &
     dat_z0_momentum,           dat_tf_depr
!---- end of namelist --------------------------------------------------------

real    :: gw_hillslope_length   = 1000.
real    :: gw_hillslope_relief   =  100.
real    :: gw_hillslope_zeta_bar =    0.5
real    :: gw_soil_e_depth       =    4.
real, dimension(num_storage_pts, num_zeta_s_pts) :: &
                                        gw_flux_table, gw_area_table

real, dimension(num_zeta_s_pts ) :: gw_zeta_s       = &
  (/ 1.0000000e-5, 1.5848932e-5, 2.5118864e-5, 3.9810717e-5, 6.3095737e-5, &
     1.0000000e-4, 1.5848932e-4, 2.5118864e-4, 3.9810717e-4, 6.3095737e-4, &
     1.0000000e-3, 1.5848932e-3, 2.5118864e-3, 3.9810717e-3, 6.3095737e-3, &
     1.0000000e-2, 1.5848932e-2, 2.5118864e-2, 3.9810717e-2, 6.3095737e-2, &
     1.0000000e-1, 1.5848932e-1, 2.5118864e-1, 3.9810717e-1, 6.3095737e-1, &
     1.0000000e+0, 1.5848932e+0, 2.5118864e+0, 3.9810717e+0, 6.3095737e+0, &
     1.0000000e+1 /)

real, dimension(num_storage_pts) :: gw_storage_norm = &
  (/ 0.,      0.04000, 0.08000, 0.12000, 0.16000, 0.20000, &
     0.24000, 0.28000, 0.32000, 0.36000, 0.40000, 0.44000, &
     0.48000, 0.52000, 0.56000, 0.60000, 0.64000, 0.68000, &
     0.72000, 0.76000, 0.80000, 0.84000, 0.88000, 0.92000, &
     0.96000, 1.00000   /)
real, dimension(num_storage_pts) :: gw_flux_norm_zeta_s_04 = &
  (/ 0.0e000, 7.04e-6, 1.14e-5, 1.85e-5, 3.01e-5, 4.89e-5, &
     6.95e-5, 8.10e-5, 9.26e-5, 1.42e-4, 2.93e-4, 6.14e-4, &
     1.25e-3, 2.47e-3, 4.76e-3, 8.98e-3, 1.66e-2, 3.02e-2, &
     5.41e-2, 9.56e-2, 1.67e-1, 2.88e-1, 4.92e-1, 8.36e-1, &
     1.53e+0, 1.00e+1   /)
real, dimension(num_storage_pts) :: gw_area_norm_zeta_s_04 = &
  (/ 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, &
     0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, &
     0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, &
     0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, &
     3.48e-1, 1.00000  /)

integer :: num_sfc_layers, sub_layer_min, sub_layer_max

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ============================================================================
subroutine read_soil_data_namelist(soil_num_l, soil_dz, soil_single_geo, &
                                   soil_geohydrology )
  integer, intent(out) :: soil_num_l
  real,    intent(out) :: soil_dz(:)
  logical, intent(out) :: soil_single_geo
  logical, intent(out) :: soil_geohydrology
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: i
  real    :: z

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=soil_data_nml, iostat=io)
  ierr = check_nml_error(io, 'soil_data_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=soil_data_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'soil_data_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  unit=stdlog()
  write(unit, nml=soil_data_nml)
  
  ! register selector for all soil tiles
  call register_tile_selector('soil', long_name='soil',&
       tag = SEL_SOIL, idata1 = 0 )
  ! register selectors for tile-specific diagnostics
  do i=1, n_dim_soil_types
     call register_tile_selector(tile_names(i), long_name='',&
          tag = SEL_SOIL, idata1 = i )
  enddo
  z = 0
  num_sfc_layers = 0
  sub_layer_min = 0
  sub_layer_max = 0

  do i = 1, num_l
    if (z < z_sub_layer_min+1.e-4) sub_layer_min = i
    z = z + dz(i)
    if (z < z_sfc_layer+1.e-4) num_sfc_layers = i
    if (z < z_sub_layer_max+1.e-4) sub_layer_max = i
  enddo

!!$  write (*,*) 'min/max index of layers whose thermal cond is scaled:',sub_layer_min,sub_layer_max

  if (use_geohydrology.and..not.use_single_geo) then
      call read_data('INPUT/geohydrology_table.nc', 'gw_flux_norm', &
                      gw_flux_table, no_domain=.true.)
      call read_data('INPUT/geohydrology_table.nc', 'gw_area_norm', &
                      gw_area_table, no_domain=.true.)
    endif

  ! set up output arguments
  soil_num_l      = num_l
  soil_dz         = dz
  soil_single_geo = use_single_geo
  soil_geohydrology = use_geohydrology

end subroutine 


! ============================================================================
function soil_tile_ctor(tag) result(ptr)
  type(soil_tile_type), pointer :: ptr ! return value
  integer, intent(in)  :: tag ! kind of tile

  allocate(ptr)
  ptr%tag = tag
  ! allocate storage for tile data
  allocate( ptr%prog(num_l))
  allocate( ptr%w_fc              (num_l),  &
            ptr%w_wilt            (num_l),  &
            ptr%uptake_frac       (num_l),  &
            ptr%heat_capacity_dry (num_l),  &
            ptr%e                 (num_l),  &
            ptr%f                 (num_l),  &
            ptr%psi               (num_l)   )
  call soil_data_init_0d(ptr)
end function soil_tile_ctor


! ============================================================================
function soil_tile_copy_ctor(soil) result(ptr)
  type(soil_tile_type), pointer :: ptr ! return value
  type(soil_tile_type), intent(in) :: soil ! tile to copy

  allocate(ptr)
  ptr = soil ! copy all non-pointer members
  ! allocate storage for tile data
  allocate( ptr%prog(num_l))
  allocate( ptr%w_fc              (num_l),  &
            ptr%w_wilt            (num_l),  &
            ptr%uptake_frac       (num_l),  &
            ptr%heat_capacity_dry (num_l),  &
            ptr%e                 (num_l),  &
            ptr%f                 (num_l),  &
            ptr%psi               (num_l)   )
  ! copy all pointer members
  ptr%prog(:) = soil%prog(:)
  ptr%w_fc(:) = soil%w_fc(:)
  ptr%w_wilt(:) = soil%w_wilt(:)
  ptr%uptake_frac(:) = soil%uptake_frac(:)
  ptr%uptake_T = soil%uptake_T
  ptr%heat_capacity_dry(:) = soil%heat_capacity_dry(:)
  ptr%e(:) = soil%e(:)
  ptr%f(:) = soil%f(:)
  ptr%psi(:) = soil%psi(:)
end function soil_tile_copy_ctor


! ============================================================================
subroutine delete_soil_tile(ptr)
  type(soil_tile_type), pointer :: ptr

  deallocate(ptr%prog)
  deallocate(ptr%w_fc, ptr%w_wilt, ptr%uptake_frac,&
             ptr%heat_capacity_dry, ptr%e, ptr%f, ptr%psi)
  deallocate(ptr)
end subroutine delete_soil_tile


! ============================================================================
subroutine soil_data_init_0d(soil)
  type(soil_tile_type), intent(inout) :: soil
  
!  real tau_groundwater
!  real rsa_exp         ! riparian source-area exponent
  integer :: k
  k = soil%tag

  soil%pars%vwc_sat             = dat_w_sat            (k)
  soil%pars%awc_lm2           = dat_awc_lm2          (k)
  soil%pars%k_sat_ref         = dat_k_sat_ref        (k)
  soil%pars%psi_sat_ref       = dat_psi_sat_ref      (k)
  soil%pars%chb               = dat_chb              (k)
  soil%pars%alpha             = 1
  soil%pars%heat_capacity_dry = dat_heat_capacity_dry(k)
  soil%pars%thermal_cond_dry  = dat_thermal_cond_dry (k)
  soil%pars%thermal_cond_sat  = dat_thermal_cond_sat (k)
  soil%pars%thermal_cond_exp  = dat_thermal_cond_exp (k)
  soil%pars%thermal_cond_scale  = dat_thermal_cond_scale (k)
  soil%pars%thermal_cond_weight  = dat_thermal_cond_weight (k)
  soil%pars%refl_dry_dir      = dat_refl_dry_dir     (k,:)
  soil%pars%refl_dry_dif      = dat_refl_dry_dif     (k,:)
  soil%pars%refl_sat_dir      = dat_refl_sat_dir     (k,:)
  soil%pars%refl_sat_dif      = dat_refl_sat_dif     (k,:)
  soil%pars%emis_dry          = dat_emis_dry         (k)
  soil%pars%emis_sat          = dat_emis_sat         (k)
  soil%pars%z0_momentum       = dat_z0_momentum      (k)
  soil%pars%tfreeze           = tfreeze - dat_tf_depr(k)

  soil%pars%rsa_exp           = rsa_exp_global
  soil%pars%tau_groundwater   = gw_res_time
  soil%pars%hillslope_length  = gw_hillslope_length*gw_scale_length
  soil%pars%hillslope_relief  = gw_hillslope_relief*gw_scale_relief
  soil%pars%hillslope_zeta_bar= gw_hillslope_zeta_bar
  soil%pars%soil_e_depth      = gw_soil_e_depth*gw_scale_soil_depth
  soil%pars%storage_index     = 1
  soil%pars%gw_flux_norm      = gw_flux_norm_zeta_s_04
  soil%pars%gw_area_norm      = gw_area_norm_zeta_s_04

  ! ---- derived constant soil parameters
  ! w_fc (field capacity) set to w at which hydraulic conductivity equals
  ! a nominal drainage rate "rate_fc"
  ! w_wilt set to w at which psi is psi_wilt
  if (use_lm2_awc) then
     soil%w_wilt(:) = 0.15
     soil%w_fc  (:) = 0.15 + soil%pars%awc_lm2
  else
     soil%w_wilt(:) = soil%pars%vwc_sat &
          *(soil%pars%psi_sat_ref/(psi_wilt*soil%pars%alpha))**(1/soil%pars%chb)
     soil%w_fc  (:) = soil%pars%vwc_sat &
          *(rate_fc/(soil%pars%k_sat_ref*soil%pars%alpha**2))**(1/(3+2*soil%pars%chb))
  endif

  soil%pars%vwc_wilt = soil%w_wilt(1)
  soil%pars%vwc_fc   = soil%w_fc  (1)

  soil%pars%vlc_min = soil%pars%vwc_sat*K_rel_min**(1/(3+2*soil%pars%chb))

  ! below made use of phi_e from parlange via entekhabi
  soil%Eg_part_ref = (-4*soil%w_fc(1)**2*soil%pars%k_sat_ref*soil%pars%psi_sat_ref*soil%pars%chb &
       /(pi*soil%pars%vwc_sat)) * (soil%w_fc(1)/soil%pars%vwc_sat)**(2+soil%pars%chb)   &
       *(2*pi/(3*soil%pars%chb**2*(1+3/soil%pars%chb)*(1+4/soil%pars%chb)))/2

  soil%z0_scalar = soil%pars%z0_momentum * exp(-k_over_B)

end subroutine 

! ============================================================================
function soil_cover_cold_start(land_mask, lonb, latb) result (soil_frac)
! creates and initializes a field of fractional soil coverage
  logical, intent(in) :: land_mask(:,:)    ! land mask
  real,    intent(in) :: lonb(:,:), latb(:,:) ! boundaries of the grid cells
  real,    pointer    :: soil_frac (:,:,:) ! output: map of soil fractional coverage

  allocate( soil_frac(size(land_mask,1),size(land_mask,2),n_dim_soil_types))

  call init_cover_field(soil_to_use, 'INPUT/ground_type.nc', 'cover','frac', &
       lonb, latb, soil_index_constant, input_cover_types, soil_frac)
  
end function 


! =============================================================================
function soil_tiles_can_be_merged(soil1,soil2) result(response)
  logical :: response
  type(soil_tile_type), intent(in) :: soil1,soil2

  response = (soil1%tag==soil2%tag)
end function


! =============================================================================
subroutine merge_soil_tiles(s1,w1,s2,w2)
  type(soil_tile_type), intent(in) :: s1
  type(soil_tile_type), intent(inout) :: s2
  real                , intent(in) :: w1,w2

  ! ---- local vars
  real    :: x1, x2 ! normalized relative weights
  real    :: gw, HEAT1, HEAT2 ! temporaries for groundwater and heat
  integer :: i
  
  ! calculate normalized weights
  x1 = w1/(w1+w2)
  x2 = 1.0 - x1

  ! combine state variables
  do i = 1,num_l
     ! calculate heat content at this level for both source tiles
     HEAT1 = &
          (s1%heat_capacity_dry(i)*dz(i)+clw*s1%prog(i)%Wl+csw*s1%prog(i)%Ws)* &
          (s1%prog(i)%T-tfreeze)
     HEAT2 = &
          (s2%heat_capacity_dry(i)*dz(i)+clw*s2%prog(i)%Wl+csw*s2%prog(i)%Ws)* &
          (s2%prog(i)%T-tfreeze)
     ! merge the amounts of water
     s2%prog(i)%Wl = x1*s1%prog(i)%Wl + x2*s2%prog(i)%Wl
     s2%prog(i)%Ws = x1*s1%prog(i)%Ws + x2*s2%prog(i)%Ws
     ! if the dry heat capacity of merged soil is to be changed, do it here
     ! ...
     ! calculate the merged temperature based on heat content
     s2%prog(i)%T = tfreeze + (x1*HEAT1+x2*HEAT2)/ &
          (s2%heat_capacity_dry(i)*dz(i)+clw*s2%prog(i)%Wl+csw*s2%prog(i)%Ws)

     ! calculate combined groundwater content
     gw = s1%prog(i)%groundwater*x1 + s2%prog(i)%groundwater*x2
     ! calculate combined groundwater temperature
     if (gw/=0) then
        s2%prog(i)%groundwater_T = ( &
             s1%prog(i)%groundwater*x1*(s1%prog(i)%groundwater_T-tfreeze) + &
             s2%prog(i)%groundwater*x2*(s2%prog(i)%groundwater_T-tfreeze)   &
             ) / gw + tfreeze
     else
        s2%prog(i)%groundwater_T = &
             s1%prog(i)%groundwater_T*x1 + s2%prog(i)%groundwater_T*x2
     endif
     s2%prog(i)%groundwater = gw
  enddo
  s2%uptake_T = s1%uptake_T*x1 + s2%uptake_T*x2
end subroutine

! =============================================================================
! returns true if tile fits the specified selector
function soil_is_selected(soil, sel)
  logical soil_is_selected
  type(tile_selector_type),  intent(in) :: sel
  type(soil_tile_type),      intent(in) :: soil

  soil_is_selected = (sel%idata1==0).or.(sel%idata1==soil%tag)
end function


! ============================================================================
! returns tag of the tile
function get_soil_tile_tag(soil) result(tag)
  integer :: tag
  type(soil_tile_type), intent(in) :: soil
  
  tag = soil%tag
end function



! ============================================================================
! compute average soil temperature with a given depth scale
function soil_ave_temp(soil, depth) result (A) ; real :: A
  type(soil_tile_type), intent(in) :: soil
  real, intent(in)                 :: depth ! averaging depth

  real    :: w ! averaging weight
  real    :: N ! normalizing factor for averaging
  real    :: z ! current depth, m
  integer :: k

  A = 0 ; N = 0 ; z = 0
  do k = 1, num_l
     w = dz(k) * exp(-(z+dz(k)/2)/depth)
     A = A + soil%prog(k)%T * w
     N = N + w
     z = z + dz(k)
     if (z.gt.depth) exit
  enddo
  A = A/N
end function soil_ave_temp


! ============================================================================
! compute average soil moisture with a given depth scale
function soil_ave_theta(soil, depth) result (A) ; real :: A
  type(soil_tile_type), intent(in) :: soil
  real, intent(in)                 :: depth ! averaging depth

  real    :: w ! averaging weight
  real    :: N ! normalizing factor for averaging
  real    :: z ! current depth, m
  integer :: k

  A = 0 ; N = 0 ; z = 0
  do k = 1, num_l
     w = dz(k) * exp(-(z+dz(k)/2)/depth)
     A = A + max(soil%prog(k)%wl/(dens_h2o*dz(k))-soil%w_wilt(k),0.0)/&
          (soil%w_fc(k)-soil%w_wilt(k)) * w
     N = N + w
     z = z + dz(k)
  enddo
  A = A/N
end function soil_ave_theta
function soil_ave_theta1(soil, depth) result (A) ; real :: A
  type(soil_tile_type), intent(in) :: soil
  real, intent(in)                 :: depth ! averaging depth

  real    :: w ! averaging weight
  real    :: N ! normalizing factor for averaging
  real    :: z ! current depth, m
  integer :: k

  A = 0 ; N = 0 ; z = 0
  do k = 1, num_l
     w = dz(k) * exp(-(z+dz(k)/2)/depth)
     A = A +min(max(soil%prog(k)%wl/(dens_h2o*dz(k)),0.0)/&
          (soil%pars%vwc_sat),1.0) * w
     N = N + w
     z = z + dz(k)
     if (z.gt.depth) exit
  enddo
  A = A/N
end function soil_ave_theta1

! ============================================================================
! compute bare-soil albedo, bare-soil emissivity, bare-soil roughness
! for scalar transport, and beta function
subroutine soil_data_radiation ( soil, cosz, use_brdf, soil_alb_dir, soil_alb_dif, soil_emis )
  type(soil_tile_type), intent(in)  :: soil
  real,                 intent(in)  :: cosz
  logical,              intent(in)  :: use_brdf
  real,                 intent(out) :: soil_alb_dir(NBANDS), soil_alb_dif(NBANDS), soil_emis
  ! ---- local vars
  real :: soil_sfc_vlc, blend, dry_value(NBANDS), sat_value(NBANDS)
  real :: zenith_angle, zsq, zcu

  soil_sfc_vlc  = soil%prog(1)%wl/(dens_h2o*dz(1))
  blend         = max(0., min(1., soil_sfc_vlc/soil%pars%vwc_sat))
  if (use_brdf) then
      zenith_angle = acos(cosz)
      zsq = zenith_angle*zenith_angle
      zcu = zenith_angle*zsq
      dry_value =  soil%pars%f_iso_dry*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                 + soil%pars%f_vol_dry*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                 + soil%pars%f_geo_dry*(g0_geo+g1_geo*zsq+g2_geo*zcu)
      sat_value =  soil%pars%f_iso_sat*(g0_iso+g1_iso*zsq+g2_iso*zcu) &
                 + soil%pars%f_vol_sat*(g0_vol+g1_vol*zsq+g2_vol*zcu) &
                 + soil%pars%f_geo_sat*(g0_geo+g1_geo*zsq+g2_geo*zcu)
    else
      dry_value = soil%pars%refl_dry_dir
      sat_value = soil%pars%refl_sat_dir
    endif
  soil_alb_dir  = dry_value              + blend*(sat_value             -dry_value)
  soil_alb_dif  = soil%pars%refl_dry_dif + blend*(soil%pars%refl_sat_dif-soil%pars%refl_dry_dif)
  soil_emis     = soil%pars%emis_dry     + blend*(soil%pars%emis_sat    -soil%pars%emis_dry    )
end subroutine soil_data_radiation


! ============================================================================
! compute bare-soil albedo, bare-soil emissivity, bare-soil roughness
! for scalar transport, and beta function
subroutine soil_data_diffusion ( soil, soil_z0s, soil_z0m )
  type(soil_tile_type), intent(in)  :: soil
  real,                 intent(out) :: soil_z0s, soil_z0m

  soil_z0s = soil%z0_scalar
  soil_z0m = soil%pars%z0_momentum
end subroutine soil_data_diffusion

! ============================================================================
! compute soil thermodynamic properties.
subroutine soil_data_thermodynamics ( soil, vlc, vsc, &
                                      soil_E_max, thermal_cond)
  type(soil_tile_type), intent(inout) :: soil
  real,                 intent(in)  :: vlc(:)
  real,                 intent(in)  :: vsc(:)
  real,                 intent(out) :: soil_E_max
  real,                 intent(out) :: thermal_cond(:)
  real s, w, a, n, f

  integer l

  ! assign some index of water availability for snow-free soil
!  soil_E_max = soil%Eg_part_ref / ( max(small, soil%w_fc(1) - vlc(1)) )  ! NEEDS T adj

  soil_E_max = (soil%pars%k_sat_ref*soil%pars%alpha**2) &
               * (-soil%pars%psi_sat_ref/soil%pars%alpha) &
               * ((4.+soil%pars%chb)*vlc(1)/ &
                ((3.+soil%pars%chb)*soil%pars%vwc_sat))**(3.+soil%pars%chb) &
                / ((1.+3./soil%pars%chb)*dz(1))

     w = soil%pars%thermal_cond_weight
     a = soil%pars%thermal_cond_scale
     n = soil%pars%thermal_cond_exp
  do l = 1, num_sfc_layers
     soil%heat_capacity_dry(l) = sfc_heat_factor*soil%pars%heat_capacity_dry
     s = (vlc(l)+vsc(l))/soil%pars%vwc_sat
     thermal_cond(l)      = sfc_heat_factor * &
          ( soil%pars%thermal_cond_dry+ &
            (soil%pars%thermal_cond_sat-soil%pars%thermal_cond_dry) &
            *(w*s +(1-w)*(1+a**n)*(s**n)/(1+(a*s)**n))    )
     f = 1.
     if (vlc(l)+vsc(l).gt.0.) f = 1.+(freeze_factor-1.)*vsc(l)/(vlc(l)+vsc(l))
     thermal_cond(l) = f * thermal_cond(l)
  enddo
  do l = num_sfc_layers+1, num_l
     soil%heat_capacity_dry(l) = soil%pars%heat_capacity_dry
     s = (vlc(l)+vsc(l))/soil%pars%vwc_sat
     thermal_cond(l)  = &
          ( soil%pars%thermal_cond_dry+ &
            (soil%pars%thermal_cond_sat-soil%pars%thermal_cond_dry) &
            *(w*s +(1-w)*(1+a**n)*(s**n)/(1+(a*s)**n))    )
     f = 1.
     if (vlc(l)+vsc(l).gt.0.) f = 1.+(freeze_factor-1.)*vsc(l)/(vlc(l)+vsc(l))
     thermal_cond(l) = f * thermal_cond(l)
  enddo
  
  ! this is an additional factor intended for tuning annual T range in
  ! high latitudes. presumably other locations are insensitive to this
  ! global parameter, since they don't have freeze/thaw. this really is just a fudge.
  do l = sub_layer_min, sub_layer_max
    thermal_cond(l) = sub_layer_tc_fac * thermal_cond(l)
    enddo
  
end subroutine soil_data_thermodynamics


! ============================================================================
! compute soil hydraulic properties.
subroutine soil_data_hydraulics (soil, vlc, vsc, &
                    psi, DThDP, hyd_cond, DKDP, DPsi_min, DPsi_max, tau_gw, &
                    psi_for_rh, soil_w_fc  )
  type(soil_tile_type),        intent(in) :: soil
  real,                        intent(in),  dimension(:) :: vlc, vsc
  real,                        intent(out), dimension(:) :: &
      psi, DThDP, hyd_cond, DKDP, soil_w_fc
  real,                        intent(out) :: &
      DPsi_min, DPsi_max, tau_gw, psi_for_rh
  ! ---- local vars ----------------------------------------------------------
  integer l
  real :: vlc_loc, vlc_k, psi_k, sigma, B, por, psi_s, k_sat, alt_psi_for_rh
  logical flag
  
  ! ---- T-dependence of hydraulic properties --------------------------------
  ! k_sat   = soil%pars%k_sat0   !  * mu(t0)/mu(t), where mu is dynamic viscosity
  ! psi_sat = soil%pars%psi_sat0 !  * exp(c*(psi-psi0)), where c~+/-(?)0.0068
                     ! better approach would be to adopt air entrapment model
                     ! or at least to scale against surface tension model


  ! ---- water and ice dependence of hydraulic properties --------------------
  ! ---- (T-dependence can be added later)
  hyd_cond=1;DThDP=1;psi=1
  IF (.NOT.USE_EXPERIMENTAL_SMC) THEN
  flag = .false.
  do l = 1, num_l
    hyd_cond(l) = (soil%pars%k_sat_ref*soil%pars%alpha**2)*  &
                ! * mu(T)/mu(t_ref), where mu is dynamic viscosity
               (vlc(l)/soil%pars%vwc_sat)**(3+2*soil%pars%chb)
    if (hyd_cond(l).lt.1.e-12*soil%pars%k_sat_ref) then
      vlc_loc     = soil%pars%vwc_sat*(1.e-12)**(1./(3+2*soil%pars%chb))
      hyd_cond(l) = 1.e-12*soil%pars%k_sat_ref
      if (l.eq.1) flag = .true.
      if (vsc(l).eq.0.) then
        DThDP   (l) = -vlc_loc     &
                         *(vlc_loc   /soil%pars%vwc_sat)**soil%pars%chb &
                 /(soil%pars%psi_sat_ref*soil%pars%chb)
        psi     (l) = (soil%pars%psi_sat_ref/soil%pars%alpha) &
            *(soil%pars%vwc_sat/vlc_loc   )**soil%pars%chb &
            + (vlc(l)-vlc_loc    )/DThDP   (l)
        DKDP    (l) = 0.
        if (l.eq.1.and.vlc(1).gt.0.) then
               alt_psi_for_rh = &
               (soil%pars%psi_sat_ref/soil%pars%alpha) &
               *(soil%pars%vwc_sat/vlc(1)   )**soil%pars%chb
          else if (l.eq.1.and.vlc(1).le.0.) then
               alt_psi_for_rh = -1.e10
          endif
      else
        psi     (l) = ((soil%pars%psi_sat_ref/soil%pars%alpha) / 2.2) &
            *(soil%pars%vwc_sat/vlc_loc   )**soil%pars%chb
        DKDP    (l) = 0.
        DThDP   (l) = 0.
        if (l.eq.1) alt_psi_for_rh = -1.e10
      endif
    else
      if (vsc(l).eq.0.) then
        if (vlc(l).le.soil%pars%vwc_sat) then
          psi     (l) = (soil%pars%psi_sat_ref/soil%pars%alpha) &
             *(soil%pars%vwc_sat/vlc(l))**soil%pars%chb
          DKDP    (l) = -(2+3/soil%pars%chb)*hyd_cond(l) &
                                                 /psi(l)
          DThDP   (l) = -vlc(l)/(psi(l)*soil%pars%chb)
        else
          psi(l) = soil%pars%psi_sat_ref &
             + (vlc(l)-soil%pars%vwc_sat)/comp
          DThDP(l) = comp
          hyd_cond(l) = soil%pars%k_sat_ref
          DKDP(l) = 0.
        endif
      else
        psi     (l) = ((soil%pars%psi_sat_ref/soil%pars%alpha) / 2.2) &
         *(soil%pars%vwc_sat/vlc(l))**soil%pars%chb
        DKDP    (l) = 0.
        DThDP   (l) = 0.
      endif
    endif
  enddo
  if (use_alt_psi_for_rh .and. flag) then
      psi_for_rh = alt_psi_for_rh
    else
      psi_for_rh = psi(1)
    endif

  if (DThDP(1).ne.0.) then
    DPsi_min =            -vlc(1) /DThDP(1)
    DPsi_max = (soil%pars%vwc_sat-vlc(1))/DThDP(1)
  else
    Dpsi_min = -1.e16
    DPsi_max = -psi(1)
  endif
  ELSE
    B     = soil%pars%chb
    por   = soil%pars%vwc_sat
    vlc_k = soil%pars%vlc_min
    psi_s = soil%pars%psi_sat_ref
    psi_k = psi_s*(por/vlc_k)**B
    k_sat = soil%pars%k_sat_ref
    do l = 1, num_l
      vlc_loc = max(vlc(l), vlc_k)
      ! sigma is an adjustment to surface tension for presence of ice
      sigma = 1. + (sigma_max-1.)*min(vsc(l)/vlc(l),1.)
      if (vlc(l).lt.vlc_k) then  ! very dry, no ice, sigma=1 in this case
          DThDP(l) = -vlc_k/(B*psi_k)
          psi  (l) = psi_s*(por/vlc_k)**B + (vlc(l)-vlc_k)/DThDP(l)
        else if (vlc(l).lt.por-vsc(l)) then  ! unsaturated, maybe with ice
          psi  (l) = (psi_s/sigma)*(por/vlc(l))**B
          DThDP(l) = -vlc(l)/(B*psi(l))
        else  ! no air is present in this case
          psi  (l) = (psi_s/sigma)*(por/(por-vsc(l)))**B &
                             + (vlc(l)+vsc(l)-por)/comp
          DThDP(l) = comp
        endif
      hyd_cond(l) = k_sat*(vlc_loc/por)**(3+2*B)
      DKDP(l) = 0
      enddo
    DPsi_min =            -vlc(1) /DThDP(1)
    if (vsc(1).gt.0.) DPsi_min = (vlc_k-vlc(1)) /DThDP(1)
    DPsi_max = (por-vsc(1)-vlc(1))/DThDP(1)
    psi_for_rh = psi(1)
  ENDIF

  soil_w_fc = soil%w_fc
  tau_gw = soil%pars%tau_groundwater
 
end subroutine soil_data_hydraulics


! ============================================================================
subroutine soil_data_gw_hydraulics(soil, z_bot, psi_bot, gw_flux, sat_frac, &
                                    storage_normalized, depth_to_saturation)
  type(soil_tile_type), intent(inout)  :: soil
  real,                 intent(in)  :: z_bot
  real,                 intent(in)  :: psi_bot
  real,                 intent(out) :: gw_flux
  real,                 intent(out) :: sat_frac
  real,                 intent(out) :: storage_normalized
  real,                 intent(out) :: depth_to_saturation

  integer :: code, m
  real :: recharge_normalized, frac

  ! storage_normalized is the fraction of soil above drainage base elevation
  ! that is below the water table
  storage_normalized = 1 - (z_bot-psi_bot)  &
             /(soil%pars%hillslope_zeta_bar*soil%pars%hillslope_relief)
  storage_normalized = min( max( 0., storage_normalized ) , 1.)
  code = 0
  m = soil%pars%storage_index
  do while (code.eq.0)
    if (storage_normalized .lt. gw_storage_norm(m)) then
        m = m - 1
      else if (storage_normalized .gt. gw_storage_norm(m+1)) then
        m = m + 1
      else
        code = 1
      endif
    enddo
  if (m.lt.1.or.m.gt.num_storage_pts-1) then
      write(*,*) '!!! *** m=',m, ' is outside the table in soil_data_gw_hydraulics *** !!!'
      write(*,*) 'num_storage_pts=',num_storage_pts
      write(*,*) 'storage_normalized=',storage_normalized
      write(*,*) 'interval bounds:',gw_storage_norm(m),gw_storage_norm(m+1)
    endif
  frac = (storage_normalized-gw_storage_norm(m)) &
           /(gw_storage_norm(m+1)-gw_storage_norm(m))
  sat_frac = soil%pars%gw_area_norm(m) &
               + frac*(soil%pars%gw_area_norm(m+1)-soil%pars%gw_area_norm(m))
  recharge_normalized = soil%pars%gw_flux_norm(m) &
               + frac*(soil%pars%gw_flux_norm(m+1)-soil%pars%gw_flux_norm(m))
  gw_flux = recharge_normalized * soil%pars%k_sat_ref * soil%pars%soil_e_depth &
                * soil%pars%hillslope_relief &
                   / (soil%pars%hillslope_length * soil%pars%hillslope_length)
  soil%pars%storage_index = m
  
  ! depth_to_saturation, along with sat_frac, is potentially useful for
  ! bgc analysis...
  depth_to_saturation = 0.
  do m=1,num_l
    if (soil%prog(m)%wl+soil%prog(m)%ws .lt. soil%pars%vwc_sat*dens_h2o*dz(m)) then
      depth_to_saturation = depth_to_saturation + dz(m)
      if (m.eq.num_l) depth_to_saturation = -1.
    else
      exit
    endif
  enddo
  
end subroutine soil_data_gw_hydraulics

! ============================================================================
subroutine soil_data_vwc_sat (soil, soil_vwc_sat  )
  type(soil_tile_type),  intent(in)  :: soil
  real,                  intent(out) :: soil_vwc_sat(:)

  soil_vwc_sat(1:num_l) = soil%pars%vwc_sat

end subroutine soil_data_vwc_sat

! ============================================================================
subroutine soil_tile_stock_pe (soil, twd_liq, twd_sol  )
  type(soil_tile_type),  intent(in)    :: soil
  real,                  intent(out)   :: twd_liq, twd_sol
  integer n
  
  twd_liq = 0.
  twd_sol = 0.
  do n=1, size(soil%prog)
    twd_liq = twd_liq + soil%prog(n)%wl + soil%prog(n)%groundwater
    twd_sol = twd_sol + soil%prog(n)%ws
    enddo

end subroutine soil_tile_stock_pe


! ============================================================================
! returns soil tile heat content, J/m2
function soil_tile_heat (soil) result(heat) ; real heat
  type(soil_tile_type),  intent(in)  :: soil

  integer :: i

  heat = 0
  do i = 1, num_l
     heat = heat + &
          (soil%heat_capacity_dry(i)*dz(i)+clw*soil%prog(i)%Wl+csw*soil%prog(i)%Ws)&
                           *(soil%prog(i)%T-tfreeze) + &
          clw*soil%prog(i)%groundwater*(soil%prog(i)%groundwater_T-tfreeze) - &
          hlf*soil%prog(i)%ws
  enddo
end function

end module soil_tile_mod


! ============================================================================
! root uptake module
! ============================================================================
module uptake_mod

#include "../shared/debug.inc"

use constants_mod, only: PI
use fms_mod, only : write_version_number
use soil_tile_mod, only : &
     soil_tile_type, soil_pars_type, max_lev, psi_wilt
use land_debug_mod, only : is_watch_point

implicit none
private

! ==== public interfaces =====================================================
public :: UPTAKE_LINEAR, UPTAKE_DARCY2D, UPTAKE_DARCY2D_LIN

public :: uptake_init

public :: darcy2d_uptake, darcy2d_uptake_solver
public :: darcy2d_uptake_lin, darcy2d_uptake_solver_lin
! =====end of public interfaces ==============================================


! ==== module constants ======================================================
character(len=*), parameter, private   :: &
    module_name = 'uptake',&
    version     = '$Id: uptake.F90,v 17.0 2009/07/21 03:03:04 fms Exp $',&
    tagname     = '$Name:  $'

! values for internal soil uptake option selector
integer, parameter ::   &
     UPTAKE_LINEAR         = 1, &
     UPTAKE_DARCY2D        = 2, &
     UPTAKE_DARCY2D_LIN    = 3

! ==== module variables ======================================================
logical :: module_is_initialized =.FALSE.
integer :: num_l ! # of water layers
real    :: dz    (max_lev)    ! thicknesses of layers
real    :: zfull (max_lev)

contains

! ============================================================================
subroutine uptake_init(num_l_in, dz_in, zfull_in)
  integer, intent(in) :: num_l_in ! # of layers
  real   , intent(in) :: &
       dz_in(:), &  ! layer thickness
       zfull_in(:)  ! layer centers

  call write_version_number(version, tagname)
  module_is_initialized =.TRUE.

  num_l = num_l_in
  dz    = dz_in
  zfull = zfull_in
end subroutine uptake_init


! ============================================================================
! given soil and root parameters, calculate the flux of water toward root
! per unit root length, and its derivative w.r.t. xylem water potential
subroutine darcy2d_flow (psi_x, psi_soil, K_sat, psi_sat, b, K_r, r_r, R, eps, u, du, psi_root)
  real, intent(in) :: &
       psi_x,    & ! xylem water potential, m
       psi_soil, & ! soil water potential, m
       K_sat,    & ! saturated soil hydraulic conductivity, kg/(m2 s)
       psi_sat,  & ! saturates soil water potential, m
       b,        & ! power of soil moisture characteristic function
       K_r,      & ! root membrane permeability per unit area, kg/(m3 s)
       r_r,      & ! radius of root, m
       R,        & ! characteristic radial half-distance between roots, m
       eps         ! requested precision in terms of psi, m

  real, intent(out) :: &
       u,        & ! uptake, kg/(m s)
       du,       & ! derivative of uptake w.r.t psi_x, kg/(m2 s)
       psi_root    ! water potential at the root/soil interface, m

  ! ---- local constants
  integer :: max_iter = 50 ! max number of iterations
  ! ---- local vars
  real :: u_soil, u_root ! water flows through soil and root skin, respectively, kg/(m s)
  real :: f ! u_soil - u_root difference; we look for f(psi_root) = 0
  real :: df ! derivative of w.r.t psi_root
  real :: n
  real :: C_r ! 
  real :: K_s
  real :: K_root ! root membrane prmeability per unit length, kg/(m2 s)
  real :: pl, ph ! brackets of the solution
  real :: psi_root0 ! previous guess for root water potential
  real :: dpsi
  integer :: iter 

  C_r=2*PI/(log(R/r_r))
  n = -(1+3/b)
  K_root = 2*PI*r_r*K_r

  ! set up values bracketing the solution for psi_root, so that
  ! f(pl)<0 and f(ph)>0, where f = u_soil - u_root
  if(psi_soil>psi_x) then
     pl = psi_soil; ph = psi_x
  else
     ph = psi_soil; pl = psi_x
  endif
  ! choose initial values of f and df so that we always do bisection on the
  ! first iteration. 
  ! That means that our first approximation is (psi_soil+psi_x)/2 -- in future,
  ! modify to get something better
  f=1; df=0; psi_root=pl 

  do iter = 1, max_iter
     psi_root0=psi_root
     if (((psi_root-ph)*df-f)*((psi_root-pl)*df-f)>0) then
        ! Newton step would throws us out of range, do bisection
        psi_root = (pl+ph)/2
     else
        ! do Newton step
        psi_root = psi_root - f/df
     endif
     dpsi=psi_root-psi_root0

     ! calculate flux difference and its derivative
     u_soil = C_r*K_sat*&
          (psi_sat/n* &
          (  (min(psi_soil,psi_sat)/psi_sat)**n   &
            -(min(psi_root,psi_sat)/psi_sat)**n ) &
          + max(0.0, psi_soil - psi_sat)          &
          - max(0.0, psi_root - psi_sat)          )
     u_root = K_root*(psi_root-psi_x)
     
     f=u_soil-u_root
     df=-C_r*K_sat*(min(psi_root,psi_sat)/psi_sat)**(n-1)-K_root

     ! update brackets so that they still enclose the root
     if(f>0) then
        ph = psi_root
     else
        pl = psi_root
     endif

     if(abs(dpsi)<eps) exit
  enddo

  u = u_root; 
  ! calcilate derivalive of u w.r.t psi_x
  K_s = C_r*K_sat*(min(psi_root,psi_sat)/psi_sat)**(n-1)
  du = -K_root*K_s/(K_root+K_s)

end subroutine 


! ============================================================================
! given water potential of roots and soil, and array of vegetation factors in
! the uptake formula, calculate the total soil water uptake, its derivative
! w.r.t. root water potential, and optionally the vertical distribution of the
! uptake.
! NOTE that is we use one-way uptake option then U(psi_root) is continuous, but
! DUDpsi_root is not
subroutine darcy2d_uptake ( soil, psi_x0, VRL, K_r, r_r, uptake_oneway, &
     uptake_from_sat, uptake, duptake)
  type(soil_tile_type), intent(in) :: soil
  real, intent(in) :: &
       psi_x0, &   ! water potential inside roots (in xylem) at zero depth, m
       VRL(:), &   ! Volumetric Root Length (root length per unit volume), m/m3
       K_r,    &   ! permeability of the root skin per unit area, kg/(m3 s)
       r_r         ! radius of the roots, m
  logical, intent(in) :: &
       uptake_oneway, & ! if true, then the roots can only take up water, but 
                   ! never loose it to the soil
       uptake_from_sat   ! if false, uptake from saturated soil is prohibited
  real, intent(out) :: &
       uptake(:), & ! water uptake by roots
       duptake(:)   ! derivative of water uptake w.r.t. psi_root
  ! ---- local constants
  real, parameter :: eps = 1e-4 ! tolerance for psi
  ! ---- local vars
  integer :: l
  real :: psi_x     ! water potential inside roots (psi_x0+z), m
  real :: psi_soil  ! water potential of soil, m
  real :: psi_sat   ! saturation soil water potential, m
  real :: k_sat     ! hyraulic conductivity of saturated soil, kg/(m2 s)
  real :: R         ! characteristic half-distance between roots, m
  
  real :: u         ! water uptake by roots at the current layer, kg/(m2 s)
  real :: du        ! derivative of u w.r.t. root water potential
  real :: psi_r


  ! calculate some hydraulic properties common for all soil layers
  psi_sat = soil%pars%psi_sat_ref/soil%pars%alpha
  k_sat   = soil%pars%k_sat_ref*soil%pars%alpha**2

  if(is_watch_point())then
     write(*,*)'##### darcy2d_uptake input #####'
     __DEBUG3__(psi_x0,psi_sat,K_sat)
     __DEBUG2__(K_r,r_r)
  endif
  ! calculate soil water supply and its derivative
  uptake = 0; duptake = 0
  do l = 1, num_l
     psi_x    = psi_x0+zfull(l)
     psi_soil = soil%psi(l)
     if (VRL(l) > 0) then
        R     = 1.0/sqrt(PI*VRL(l)) ! characteristic half-distance between roots, m
     else
        R     = 1.0 ! the value doesn't matter since uptake is 0 anyway 
     endif

     if ( soil%prog(l)%ws > 0 ) &
          cycle ! skip layers with ice
     if ( uptake_oneway.and.psi_x > soil%psi(l) ) &
          cycle ! skip layers where roots would loose water
     if ( .not.(uptake_from_sat).and.psi_soil >= psi_sat ) &
          cycle ! skip layers where the soil is saturated

     ! calculates soil term of uptake expression
     call darcy2d_flow (psi_x, psi_soil, K_sat, psi_sat, soil%pars%chb, K_r, r_r, R, eps, u, du, psi_r)

     ! scale by volumetric root length and thickness of layer to get total uptake 
     ! from the current soil layer
     uptake(l)  = VRL(l)*dz(l)*u ; duptake(l) = VRL(l)*dz(l)*du
     if(is_watch_point()) then
        write(*,'(a,i2.2,100(2x,a,g))')'level=',l, &
             'VRL=', VRL(l), 'R=', R,&
             'psi_x=', psi_x, 'psi_r=', psi_r, 'psi_soil=', psi_soil, &
             'U=',u,&
             'z=', zfull(l)
     endif
  enddo
end subroutine darcy2d_uptake


! =============================================================================
! for Darcy-flow uptake, find the root water potential such to satisfy actual 
! uptake by the vegetation. 
subroutine darcy2d_uptake_solver (soil, vegn_uptk, VRL, K_r, r_r, uptake_oneway, &
     uptake_from_sat, uptake, n_iter)
  type(soil_tile_type), intent(in) :: soil
  real, intent(in)  :: &
       vegn_uptk, & ! uptake requested by vegetation, kg/(m2 s)
       VRL(:),    & ! volumetric root length, m/m3
       K_r,       & ! root membrane permeability per unit area, kg/(m3 s)
       r_r          ! root radius, m
  logical, intent(in) :: &
       uptake_oneway, & ! if true, then the roots can only take up water, but 
                    ! never loose it to the soil
       uptake_from_sat ! if false, uptake from saturated soil is prohibited
  real,    intent(out) :: uptake(:) ! soil water uptake, by layer
  integer, intent(out) :: n_iter ! # of iterations made, for diagnostics only

  real :: uptake_tot

  call uptake_solver_K(soil, vegn_uptk, VRL, K_r, r_r, uptake_oneway, &
     uptake_from_sat, uptake, n_iter, darcy2d_uptake)

  ! since the numerical solution is not exact, adjust the vertical profile 
  ! of uptake to ensure that the sum is equal to transpiration exactly
  uptake_tot = sum(uptake(:))
  uptake(:) = uptake(:)+(vegn_uptk-uptake_tot)/sum(dz(:))*dz(:) 
  
end subroutine darcy2d_uptake_solver

! =============================================================================
! kernel of the uptake solver: given the input and a subroutine that calculates 
! the uptake vertical profile for given water potential at the surface, returns
! a soulution
subroutine uptake_solver_K (soil, vegn_uptk, VRL, K_r, r_r, uptake_oneway, &
     uptake_from_sat, uptake, n_iter, uptake_subr)
  type(soil_tile_type), intent(in) :: soil
  real, intent(in)  :: &
       vegn_uptk, & ! uptake requested by vegetation, kg/(m2 s)
       VRL(:),    & ! volumetric root length, m/m3
       K_r,       & ! root membrane permeability per unit area, kg/(m3 s)
       r_r          ! root radius, m
  logical, intent(in) :: &
       uptake_oneway, & ! if true, then the roots can only take up water, but 
                    ! never loose it to the soil
       uptake_from_sat ! if false, uptake from saturated soil is prohibited
  real,    intent(out) :: uptake(:) ! vertical distribution of soil uptake
  integer, intent(out) :: n_iter ! # of iterations made, for diagnostics only

  interface 
     subroutine uptake_subr ( soil, psi_x0, VRL, K_r, r_r, uptake_oneway, &
          uptake_from_sat, uptake, duptake)
     use soil_tile_mod, only : soil_tile_type
       type(soil_tile_type), intent(in) :: soil
       real, intent(in) :: &
            psi_x0, &   ! water potential inside roots (in xylem) at zero depth, m
            VRL(:), &   ! Volumetric Root Length (root length per unit volume), m/m3
            K_r,    &   ! permeability of the root skin per unit area, kg/(m3 s)
            r_r         ! radius of the roots, m
       logical, intent(in) :: &
            uptake_oneway, & ! if true, then the roots can only take up water, but 
            ! never loose it to the soil
            uptake_from_sat   ! if false, uptake from saturated soil is prohibited
       real, intent(out) :: &
            uptake(:), & ! water uptake by roots
            duptake(:)   ! derivative of water uptake w.r.t. psi_root
     end subroutine uptake_subr
  end interface

  ! ---- local constants
  ! parameters of uptake equation solver:
  integer, parameter :: max_iter = 50    ! max number of iterations
  real   , parameter :: eps      = 1e-10 ! end condition

  ! ---- local vars
  real :: xl,xh,x2,f,DfDx, incr
  real :: duptake(size(uptake))
  integer :: i

  n_iter = 0

  xl = psi_wilt
  xh = maxval(soil%psi(1:num_l)-zfull(1:num_l))

  ! find the lower upper boundary of the interval that contains solution
  incr = 100.0 ! inital psi increment for the lower bracket search
  do i = 1,20
     call uptake_subr ( soil, xl, VRL, K_r, r_r, uptake_oneway, uptake_from_sat, &
          uptake, duptake )
     if (sum(uptake)>=vegn_uptk) exit
     xl = xl-incr; incr=incr*2
  enddo
  if (sum(uptake) <= vegn_uptk) then
     ! Uptake is still smaller than vegn_uptake (that is,
     ! transpiration). We got as close to actual solution as possible.
     if (is_watch_point()) then
        write(*,*)'###### failed to reach lower bracket of uptake #####'
        __DEBUG2__(xl,uptake)
     endif
     return
  endif
  
  ! find upper boundary of the interval that contains solution
  incr = 1.0 ! inital psi increment for the upper bracket search
  do i = 1,20
     call uptake_subr ( soil, xh, VRL, K_r, r_r, uptake_oneway, &
          uptake_from_sat, uptake, duptake)
     if (sum(uptake)<=vegn_uptk) exit
     xh = xh+incr; incr = incr*2
  enddo
  if (sum(uptake)>= vegn_uptk) then
     ! Could not reach the psi_root high enough for uptake from soil to be 
     ! smaller than the transpiration: this can happen when transpiration is 
     ! negative (due to numerics) and uptake is one-way
     return
  endif

  ! the root is bracketed, find it
  x2 = (xl+xh)/2
  call uptake_subr ( soil, x2, VRL, K_r, r_r, uptake_oneway, &
       uptake_from_sat, uptake, duptake )
  f = sum(uptake) - vegn_uptk
  DfDx = sum(duptake)
  do n_iter = 1, max_iter
     ! check if we already reached the desired precision
     if(abs(f)<eps)exit
           
     if (is_watch_point()) then
        write(*,*)'##### solution iteration iter=',n_iter
        __DEBUG5__(f,DfDx,xl,xh,x2)
        __DEBUG2__((x2-xl)*DfDx,(x2-xh)*DfDx)
     endif
           
     if (((x2-xl)*DfDx-f)*((x2-xh)*DfDx-f)>0) then
        ! the Newton-Raphson step would throw us out of the bonds of the interval,
        ! so we do the bisection
        x2 = (xl+xh)/2
        if(is_watch_point()) write(*,*) 'did bisection'
     else
        x2 = x2-f/DfDx
        if(is_watch_point()) write(*,*) 'did Newton-Raphson step'
     endif
           
     call uptake_subr ( soil, x2, VRL, K_r, r_r, uptake_oneway, &
          uptake_from_sat, uptake, duptake)
     f = sum(uptake) - vegn_uptk
     DfDx = sum(duptake)
     
     if (f>0) then
        xl = x2
     else
        xh = x2
     endif
     
     if(is_watch_point()) then
        write(*,*)'#### After iteration',n_iter
        __DEBUG2__(vegn_uptk,sum(uptake))
     endif
  enddo

end subroutine uptake_solver_K

! ============================================================================
! given soil and root parameters, calculate the flux of water toward root
! per unit root length, and its derivative w.r.t. xylem water potential
! this version calculates fluxes linearized around psi_root0
subroutine darcy2d_flow_lin (psi_x, psi_soil, psi_root0, K_sat, psi_sat, b, K_r, &
     r_r, R, u, du, psi_root)
  real, intent(in) :: &
       psi_x,    & ! xylem water potential, m
       psi_soil, & ! soil water potential, m
       psi_root0,& ! value of psi_root we linearize around, m
       K_sat,    & ! saturated soil hydraulic conductivity, kg/(m2 s)
       psi_sat,  & ! saturates soil water potential, m
       b,        & ! power of soil moisture characteristic function
       K_r,      & ! root membrane permeability per unit area, kg/(m3 s)
       r_r,      & ! radius of root, m
       R           ! characteristic radial half-distance between roots, m
  real, intent(out) :: &
       u,        & ! uptake, kg/(m s)
       du,       & ! derivative of uptake w.r.t psi_x, kg/(m2 s)
       psi_root    ! water potential at the root/soil interface, m

  ! ---- local vars
  real :: u_soil0 ! flux through soil for psi_root = psi_root0
  real :: du_soil ! its derivative w.r.t. psi_root
  real :: C_r !
  real :: n
  real :: K_root  ! root membrane prmeability per unit length, kg/(m2 s)

  C_r=2*PI/(log(R/r_r))
  n = -(1+3/b)
  K_root = 2*PI*r_r*K_r

  ! calculate flux through soil for psi_root = psi_root0
  u_soil0 = C_r*K_sat*&
       (psi_sat/n* &
          (  (min(psi_soil ,psi_sat)/psi_sat)**n   &
            -(min(psi_root0,psi_sat)/psi_sat)**n ) &
          + max(0.0, psi_soil  - psi_sat)          &
          - max(0.0, psi_root0 - psi_sat)          )
  ! and its derivative w.r.t. psi_root at psi_root0
  du_soil=-C_r*K_sat*(min(psi_root0,psi_sat)/psi_sat)**(n-1)

  ! flux through soil+membrane
  u  = K_root/(-du_soil+K_root)*(u_soil0+du_soil*(psi_x-psi_root0))
  ! and its derivative w.r.t. psi_x
  du = K_root/(-du_soil+K_root)*du_soil
  ! water potential at the root-soil interface
  psi_root = psi_x + u/K_root
end subroutine 


! ============================================================================
subroutine darcy2d_uptake_lin ( soil, psi_x0, VRL, K_r, r_r,uptake_oneway, &
    uptake_from_sat, u, du )
  type(soil_tile_type), intent(in) :: soil
  real, intent(in) :: &
       psi_x0,    & ! water potential inside roots (in xylem) at zero depth, m
       VRL(:),    & ! Volumetric Root Length (root length per unit volume), m/m3
       K_r,       & ! permeability of the root membrane per unit area, kg/(m3 s)
       r_r          ! radius of fine roots, m
  logical, intent(in) :: &
       uptake_oneway, & ! if true, then the roots can only take up water, but 
                   ! never loose it to the soil
       uptake_from_sat   ! if false, uptake from saturated soil is prohibited
  real, intent(out) :: &
       u(:), &      ! layer-by-layer distribution of uptake, kg/(m2 s)
       du(:)        ! derivative of u w.r.t. root water potential, kg/(m3 s)
  ! ---- local vars
  integer :: k
  real :: psi_x     ! water potential inside roots (psi_x0+z), m
  real :: psi_soil  ! water potential of soil, m
  real :: psi_sat   ! saturation soil water potential, m
  real :: K_sat     ! hyraulic conductivity of saturated soil, kg/(m2 s)
  real :: R         ! characteristic half-distance between roots, m
  
  real :: psi_root  ! water potential at the root/soil interface, m
  real :: psi_root0 ! initial guess of psi_root, m


  ! calculate some hydraulic properties common for all soil layers
  psi_sat = soil%pars%psi_sat_ref/soil%pars%alpha
  K_sat   = soil%pars%k_sat_ref*soil%pars%alpha**2

  u = 0; du = 0
  do k = 1, num_l
     psi_x    = psi_x0 + zfull(k)
     psi_soil = soil%psi(k)
     psi_root0= soil%psi(k) ! change it later to prev. time step value
     if (VRL(k)>0) then
        R     = 1.0/sqrt(PI*VRL(k)) ! characteristic half-distance between roots, m
     else
        R     = 1.0 ! the value doesn't matter since uptake is 0 anyway (no roots) 
     endif
     if ( soil%prog(k)%ws > 0 ) &
          cycle ! skip layers with ice
     if ( uptake_oneway.and.psi_x > soil%psi(k) ) &
          cycle ! skip layers where roots would loose water
     if ( .not.(uptake_from_sat).and.psi_soil >= psi_sat ) &
          cycle ! skip layers where the soil is saturated

     ! calculates soil term of uptake expression
     call darcy2d_flow_lin (psi_x, psi_soil, psi_root0, K_sat, psi_sat, soil%pars%chb, &
          K_r, r_r, R, u(k), du(k), psi_root)

     ! scale by volumetric root length and thickness of layer to get total 
     ! uptake from the current soil layer
     u(k)  = VRL(k)*dz(k)*u(k)
     du(k) = VRL(k)*dz(k)*du(k)
  enddo

end subroutine

! ============================================================================
subroutine darcy2d_uptake_solver_lin ( soil, vegn_uptk, VRL, K_r, r_r, &
     uptake_oneway, uptake_from_sat, uptake, n_iter )
  type(soil_tile_type), intent(in) :: soil
  real, intent(in) :: &
       vegn_uptk, & ! uptake requested by vegetation, kg/(m2 s)
       VRL(:),    & ! Volumetric Root Length (root length per unit volume), m/m3
       K_r,       & ! permeability of the root membrane per unit area, kg/(m3 s)
       r_r          ! radius of fine roots, m
  logical, intent(in) :: &
       uptake_oneway, & ! if true, then the roots can only take up water, but 
                   ! never loose it to the soil
       uptake_from_sat   ! if false, uptake from saturated soil is prohibited
  real, intent(out) :: &
       uptake(:)    ! layer-by-layer distribution of uptake, kg/(m2 s)
  integer, intent(out) :: n_iter ! # of iterations made, for diagnostics only

  ! ---- local vars
  integer :: k
  real :: psi_x0    ! water potential inside roots (in xylem) at zero depth, m
  
  real :: uptake_tot  ! total water uptake by roots, kg/(m2 s)
  real :: Duptake_tot ! derivative of water uptake w.r.t. psi_root, kg/(m3 s)
  real :: du(size(uptake)) ! derivative of u w.r.t. root water potential, kg/(m3 s)
  real :: d_psi_x     ! change of the xylem potential, m

  if (uptake_oneway) then
     call uptake_solver_K(soil, vegn_uptk, VRL, K_r, r_r, uptake_oneway, &
          uptake_from_sat, uptake, n_iter, darcy2d_uptake_lin )
     
     ! since the numerical solution is not exact, adjust the vertical profile 
     ! of uptake to ensure that the sum is equal to transpiration exactly
     uptake_tot = sum(uptake(:))
     uptake(:) = uptake(:)+(vegn_uptk-uptake_tot)/sum(dz(:))*dz(:) 
  else
     psi_x0 = 0.0
     call darcy2d_uptake_lin ( soil, psi_x0, VRL, K_r, r_r, uptake_oneway, &
          uptake_from_sat, uptake, du )
     uptake_tot = sum(uptake)
     Duptake_tot = sum(du) 
     
     if (duptake_tot/=0) then
        d_psi_x = (vegn_uptk - uptake_tot)/duptake_tot
        do k = 1,num_l
           uptake(k) = uptake(k) + d_psi_x*du(k)
        enddo
     else
        uptake(:) = 0
     endif
     n_iter = 0 ! because we didn't do any iterations
  endif

end subroutine


end module uptake_mod


module topo_rough_mod
! <CONTACT EMAIL="slm@gfdl.noaa.gov">
!   Sergey Malyshev
! </CONTACT>

  use time_manager_mod,   only : time_type
  use mpp_domains_mod,    only : domain2d

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

  use fms_mod,            only : write_version_number, error_mesg, FATAL, NOTE, &
       open_restart_file, set_domain, read_data, &
       write_data, close_file, file_exist, check_nml_error, mpp_pe, &
       mpp_root_pe, stdlog
  use diag_manager_mod,   only : register_static_field, send_data
  use topography_mod,     only : get_topog_stdev

implicit none
private
! ==== public interface ======================================================
public :: topo_rough_init
public :: topo_rough_end
public :: update_topo_rough
! ==== end of public interface ===============================================


! <NAMELIST NAME = "topo_rough_nml">
!   <DATA NAME="use_topo_rough" TYPE="logical" DEFAULT="false">
!     If true, the topographic momentum drag scaling scheme is used
!   </DATA>
!   <DATA NAME="max_topo_rough" TYPE="real" DEFAULT="100" UNITS="m">
!     Maximum of topographic "roughness length" used for momentum drag scaling
!   </DATA>
!   <DATA NAME="topo_rough_factor" TYPE="real" DEFAULT="1.0">
!     Scaling factor to convert topography variance to topographic 
!     "roughness length"
!   </DATA>
!   <DATA NAME="topo_rough_source" TYPE="caharacter(len=16)" DEFAULT="'computed'">
!     Source of the sub-grid topography variance data for topographic momentum drag scaling. 
!     'computed' means that the variance is calculated based on high-resolution 
!     topography data. 'input' means that the data will be provided in specified file
!     (NetCDF of IEEE binary)
!   </DATA>
!   <DATA NAME="topo_rough_file" TYPE="character(len=256)" DEFAULT="INPUT/mg_drag.data.nc">
!     Name of the file to be used as an input for sub-grid topography variance data. 
!     The file can be either NetCDF (in this case variable name can also be specified), or
!     IEEE.
!   </DATA>
!   <DATA NAME="topo_rough_var" TYPE="character(len=128)" DEFAULT="ghprime">
!     Name of the NetCDF variable to be used as a topography variance field. Ignored if
!     the file specified in topo_rough_file is not NetCDF file.
!   </DATA>
! </NAMELIST>

logical     :: use_topo_rough    = .false.
real        :: max_topo_rough    = 100 ! m
real        :: topo_rough_factor = 1.0
character(len=16) :: topo_rough_source = 'computed'
character(len=256):: topo_rough_file   = 'INPUT/mg_drag.data.nc'
character(len=128):: topo_rough_var    = 'ghprime'

namelist/topo_rough_nml/ use_topo_rough, topo_rough_factor, max_topo_rough, &
     topo_rough_source, topo_rough_file, topo_rough_var

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name   = 'she_topo_rough', &
     diag_mod_name = 'topo_rough', &
     version       = '$Id: topo_rough.F90,v 17.0.4.1 2010/08/24 12:11:36 pjp Exp $', &
     tagname       = '$Name: hiram_20101115_bw $'

! ==== module private data ===================================================
real, allocatable, save ::topo_stdev(:,:)
logical :: module_is_initialized = .FALSE.

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'

contains ! ###################################################################

subroutine topo_rough_init(time, lonb, latb, domain, id_lon,id_lat)
  type(time_type), intent(in) :: time            ! current time
  type(domain2d) , intent(in) :: domain          ! our domain
  real           , intent(in) :: latb(:,:),lonb(:,:) ! boundaries of the grid cells
  integer        , intent(in) :: id_lon,id_lat   ! IDs of diagnostic axes
!   <ERROR MSG="could not read topography data" STATUS="FATAL">
!     get_topog_stdev failed to provide topography variance data.
!   </ERROR>  
!   <ERROR MSG="input file for for topography standard deviation ... does not exist" STATUS="FATAL">
!     topo_rough_source is set to 'input', but input file name either
!     not specified or specified incorrectly, so the program cannot 
!     find it.
!   </ERROR>
!   <ERROR MSG="... is not a valid value for topo_rough_source" STATUS="FATAL">
!     specified value of namelist parameter topo_rough_source is invalid; 
!     valid values are 'computed' or 'input'.
!   </ERROR>
  ! --- local vars
  integer :: ierr,io,unit
  integer :: id
  logical :: used, got_stdev

  ! write the version and tagname to the logfile
  call write_version_number(version, tagname)

  ! read and write (to logfile) namelist variables
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=topo_rough_nml, iostat=io)
  ierr = check_nml_error(io, 'topo_rough_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file ( )
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=topo_rough_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'topo_rough_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif

  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=topo_rough_nml)
  endif

  ! allocate topo_stdev according to specified domain
  allocate(topo_stdev(size(lonb,1)-1, size(lonb,2)-1))

  if (use_topo_rough) then

     if(trim(topo_rough_source) == 'computed') then
        call error_mesg('topo_rough_init','computing topography standard deviation',NOTE)
        got_stdev = get_topog_stdev(lonb,latb,topo_stdev)
        if (.not.got_stdev) &
             call error_mesg ('topo_rough_init', &
             'could not read topography data', FATAL)
     else if (trim(topo_rough_source)=='input') then
        call error_mesg('topo_rough_init','reading topography standard deviation from "'&
             //trim(topo_rough_file)//'"',NOTE)
        if(.not.file_exist(topo_rough_file,domain))&
             call error_mesg('topo_rough_init',            &
             'input file for topography standard deviation "'// &
             trim(topo_rough_file)//'" does not exist', FATAL)
        
        call set_domain(domain)
        call read_data(topo_rough_file,topo_rough_var,topo_stdev)
     else
        call error_mesg('topo_rough_init','"'//trim(topo_rough_source)//&
             '" is not a valid value for topo_rough_source', FATAL)
     endif
     topo_stdev = min(topo_stdev*topo_rough_factor,max_topo_rough)
  else
     topo_stdev = 0.0
  endif

  ! diag output : send topo_stdev to diagnostics
  id = register_static_field(diag_mod_name,'topo_rough',(/id_lon,id_lat/), &
       'momentum drag coefficient scaling lenght','m',missing_value=-1.0 )
  if(id > 0) &
       used = send_data(id,topo_stdev,time)
  module_is_initialized = .TRUE.
end subroutine topo_rough_init

! ============================================================================
subroutine topo_rough_end()
  deallocate(topo_stdev)
  module_is_initialized = .FALSE.
end subroutine

! ============================================================================
subroutine update_topo_rough(topo_rough)
  real, intent(out) :: topo_rough(:,:,:)

  ! ---- local vars
  integer :: k

  ! just assign standard deviation (scaled and trimmed according to namelist 
  ! parameters) to the output field 
  do k = 1, size(topo_rough,3)
     topo_rough(:,:,k) = topo_stdev(:,:)
  enddo
end subroutine

end module topo_rough_mod


#include <fms_platform.h>

module land_transitions_mod

#include "../shared/debug.inc"

use constants_mod, only : PI

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : write_version_number, string, error_mesg, FATAL, WARNING, NOTE, &
     mpp_pe, write_version_number, file_exist, close_file, &
     check_nml_error, stdlog, mpp_root_pe
use mpp_io_mod, only : mpp_open, mpp_close, MPP_RDONLY, MPP_ASCII
use time_manager_mod, only : time_type, set_date, get_date, set_time, &
     operator(+), operator(-), operator(>), operator(<), operator(<=), operator(/), &
     operator(//), days_in_year, print_date, increment_date, get_time, &
     valid_calendar_types, get_calendar_type
use get_cal_time_mod, only : get_cal_time
use horiz_interp_mod, only : horiz_interp_type, horiz_interp_init, &
     horiz_interp_new, horiz_interp_del, horiz_interp
use time_interp_mod, only : time_interp
use diag_manager_mod, only : register_diag_field, send_data

use nfu_mod, only : nfu_validtype, nfu_inq_var, nfu_get_dim_bounds, nfu_get_rec, &
     nfu_get_dim, nfu_get_valid_range, nfu_is_valid

use vegn_data_mod, only : &
     N_LU_TYPES, LU_NTRL, LU_SCND, landuse_name, landuse_longname

use cana_tile_mod, only : cana_tile_heat
use snow_tile_mod, only : snow_tile_heat
use vegn_tile_mod, only : vegn_tile_heat
use soil_tile_mod, only : soil_tile_heat

use land_tile_mod, only : &
     land_tile_type, land_tile_list_type, land_tile_enum_type, new_land_tile, delete_land_tile, &
     first_elmt, tail_elmt, next_elmt, operator(/=), operator(==), current_tile, &
     land_tile_list_init, land_tile_list_end, &
     empty, erase, remove, insert, land_tiles_can_be_merged, merge_land_tiles, &
     get_tile_water, land_tile_carbon, land_tile_heat
use land_tile_io_mod, only : print_netcdf_error

use land_data_mod, only : &
     land_data_type, lnd
use vegn_tile_mod, only : &
     vegn_tile_type, vegn_tran_priority
use vegn_harvesting_mod, only : &
     vegn_cut_forest

use land_debug_mod, only : set_current_point, is_watch_point, get_current_point
     
implicit none
private

! ==== public interface =====================================================
public :: land_transitions_init
public :: land_transitions_end
public :: save_land_transitions_restart

public :: land_transitions
! ==== end of public interface ==============================================

! ==== module constants =====================================================
character(len=*), parameter   :: &
     version = '$Id: transitions.F90,v 17.0.2.1.2.1.2.1 2010/08/24 12:11:36 pjp Exp $', &
     tagname = '$Name:  $', &
     module_name = 'land_transitions_mod', &
     diag_mod_name = 'landuse'
! selectors for overshoot handling options, for efficiency
integer, parameter :: &
     OPT_IGNORE = 0, &
     OPT_STOP   = 1, &
     OPT_REPORT = 2

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

! ==== data types ===========================================================
type :: tran_type
   integer :: donor    = 0  ! kind of donor tile
   integer :: acceptor = 0  ! kind of acceptor tile
   real    :: frac     = 0  ! area of transition
end type tran_type

! ==== module data ==========================================================
logical :: module_is_initialized = .FALSE.
integer :: ncid ! netcd id of the input file
integer :: input_ids (N_LU_TYPES,N_LU_TYPES) ! id's of input transition rate fields
integer :: diag_ids  (N_LU_TYPES,N_LU_TYPES)
real, allocatable :: buffer_in(:,:) ! buffer for input data
type(horiz_interp_type), save :: interp
type(time_type), allocatable :: time_in(:) ! time axis in input data
type(time_type) :: time0 ! time of previous transition calculations
integer :: overshoot_opt ! selector for overshoot handling options, for efficiency
integer :: conservation_opt ! selector for non-conservation handling options, for efficiency

! ---- namelist variables ---------------------------------------------------
logical :: do_landuse_change = .FALSE. ! if true, then the landuse changes with time
character(len=512) :: input_file = ''
! sets how to handle transition overshoot: that is, the situation when transition 
! is larger than available area of the given land use type.
character(len=16) :: overshoot_handling = 'report' ! or 'stop', or 'ignore'
real :: overshoot_tolerance = 1e-4 ! tolerance interval for overshoots 
! specifies how to handle non-conservation
character(len=16) :: conservation_handling = 'stop' ! or 'report', or 'ignore'

namelist/landuse_nml/input_file, do_landuse_change, &
     overshoot_handling, overshoot_tolerance, &
     conservation_handling
     

contains ! ###################################################################

! ============================================================================
subroutine land_transitions_init(id_lon, id_lat)
  integer, intent(in) :: id_lon, id_lat ! the IDs of land diagnostic axes

  ! ---- local vars
  logical        :: grid_initialized = .false.
  integer        :: len, unit, ierr, io
  integer        :: year,month,day,hour,min,sec
  integer        :: k1,k2,i
  real,allocatable :: lon_in(:,:),lat_in(:,:)
  character(len=12) :: fieldname
  integer :: dimids(NF_MAX_VAR_DIMS), dimlens(NF_MAX_VAR_DIMS)
  integer :: nrec ! number of records in the input file
  real, allocatable :: time(:)  ! real values of time coordinate
  real, allocatable :: mask_in(:,:) ! valid data mask on the input data grid
  type(nfu_validtype) :: v ! valid values range
  integer :: timedim ! id of the record (time) dimension
  integer :: timevar ! id of the time variable
  character(len=NF_MAX_NAME) :: timename  ! name of the time variable
  character(len=256)         :: timeunits ! units ot time in the file
  character(len=24) :: calendar ! model calendar

  if(module_is_initialized) return

  call horiz_interp_init
  call write_version_number(version, tagname)

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=landuse_nml, iostat=io)
  ierr = check_nml_error(io, 'landuse_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file ( )
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=landuse_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'landuse_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=landuse_nml)
  endif

  ! read restart file, if any
  if (file_exist('INPUT/landuse.res')) then
     call error_mesg('land_transitions_init',&
          'reading restart "INPUT/landuse.res"',&
          NOTE)
     call mpp_open(unit,'INPUT/landuse.res', action=MPP_RDONLY, form=MPP_ASCII)
     read(unit,*) year,month,day,hour,min,sec
     time0 = set_date(year,month,day,hour,min,sec)
     call mpp_close(unit)
  else
     call error_mesg('land_transitions_init',&
          'cold-starting land transitions',&
          NOTE)
     time0 = set_date(0001,01,01);
  endif
  
  ! parse the overshoot handling option
  if (trim(overshoot_handling)=='stop') then
     overshoot_opt = OPT_STOP
  else if (trim(overshoot_handling)=='ignore') then
     overshoot_opt = OPT_IGNORE
  else if (trim(overshoot_handling)=='report') then
     overshoot_opt = OPT_REPORT
  else
     call error_mesg('land_transitions_init','overshoot_handling value "'//&
          trim(overshoot_handling)//'" is illegal, use "stop", "report", or "ignore"',&
          FATAL)
  endif

  ! parse the non-conservation handling option
  if (trim(conservation_handling)=='stop') then
     conservation_opt = OPT_STOP
  else if (trim(conservation_handling)=='ignore') then
     conservation_opt = OPT_IGNORE
  else if (trim(conservation_handling)=='report') then
     conservation_opt = OPT_REPORT
  else
     call error_mesg('land_transitions_init','conservation_handling value "'//&
          trim(conservation_handling)//'" is illegal, use "stop", "report", or "ignore"',&
          FATAL)
  endif

  if (do_landuse_change) then
     if (trim(input_file)=='') call error_mesg('landuse_init', &
          'do_landuse_change is requested, but landuse transition file is not specified', &
          FATAL)

     ierr=nf_open(input_file,NF_NOWRITE,ncid)

     if(ierr/=NF_NOERR) call error_mesg('landuse_init', &
          'do_landuse_change is requested, but landuse transition file "'// &
          trim(input_file)//'" could not be opened because '//nf_strerror(ierr), FATAL)
  
     ! initialize array of input field ids
     input_ids(:,:) = 0
     do k1 = 1,size(input_ids,1)
     do k2 = 1,size(input_ids,2)
        ! construct a name of input field and register the field
        fieldname = trim(landuse_name(k1))//'2'//trim(landuse_name(k2))
        if(trim(fieldname)=='2') cycle ! skip unspecified tiles
        
        ierr = nfu_inq_var(ncid,fieldname, id=input_ids(k1,k2))
        if (ierr/=NF_NOERR) then
           if (ierr==NF_ENOTVAR) then
              input_ids(k1,k2)=-1 ! to indicate that input field is not present in the input data
           else
              call error_mesg('landuse_init',&
                   'error initializing field "'//trim(fieldname)//&
                   '" from file "'//trim(input_file)//'" : '//&
                   nf_strerror(ierr), &
                   FATAL)
           endif
        endif
        ! initialize the input data grid and horizontal interpolator
        if ((.not.grid_initialized).and.(input_ids(k1,k2)>0)) then
           ! we assume that all transition rate fields are specified on the same grid, 
           ! in both horizontal and time "directions". Therefore there is a single grid
           ! for all fields, initialized only once.
           
           __NF_ASRT__(nfu_inq_var(ncid,fieldname,dimids=dimids,dimlens=dimlens,nrec=nrec))
           ! allocate temporary variables
           allocate(lon_in(dimlens(1)+1,1), &
                    lat_in(1,dimlens(2)+1), &
                    time(nrec), mask_in(dimlens(1),dimlens(2)) )
           ! allocate module data
           allocate(buffer_in(dimlens(1),dimlens(2)),time_in(nrec))

           ! get the boundaries of the horizontal axes and initialize horizontal
           ! interpolator
           __NF_ASRT__(nfu_get_dim_bounds(ncid, dimids(1), lon_in(:,1)))
           __NF_ASRT__(nfu_get_dim_bounds(ncid, dimids(2), lat_in(1,:)))

           ! get the first record from variable and obtain the mask of valid data
           ! assume that valid mask does not change with time
           __NF_ASRT__(nfu_get_rec(ncid,fieldname,1,buffer_in))
           ! get the valid range for the variable
           __NF_ASRT__(nfu_get_valid_range(ncid,fieldname,v))
           ! get the mask
           where (nfu_is_valid(buffer_in,v))
              mask_in = 1
           elsewhere
              mask_in = 0
           end where

           ! add mask_in and mask_out to this call
           call horiz_interp_new(interp, lon_in*PI/180,lat_in*PI/180, &
                lnd%lonb, lnd%latb, &
                interp_method='conservative',&
                mask_in=mask_in, is_latlon_in=.TRUE. )
           
           ! get the time axis 
           __NF_ASRT__(nf_inq_unlimdim(ncid, timedim))
           __NF_ASRT__(nfu_get_dim(ncid, timedim, time))
           ! get units of time
           __NF_ASRT__(nf_inq_dimname(ncid, timedim, timename))
           __NF_ASRT__(nf_inq_varid(ncid,timename, timevar))
           timeunits = ' '
           __NF_ASRT__(nf_get_att_text(ncid,timevar,'units',timeunits))
           ! get model calendar
           calendar=valid_calendar_types(get_calendar_type())

           ! loop through the time axis and get time_type values in time_in
           do i = 1,size(time)
              time_in(i) = get_cal_time(time(i),timeunits,calendar)
           end do
           
           grid_initialized = .true.
           ! get rid of allocated data
           deallocate(lon_in,lat_in,time,mask_in)
        endif
     enddo
     enddo
  endif ! do_landuse_changes

  ! initialize diagnostics
  diag_ids(:,:) = 0

  do k1 = 1,size(diag_ids,1)
  do k2 = 1,size(diag_ids,2)
     ! skip unnamed tiles
     if(landuse_name(k1)=='')cycle
     if(landuse_name(k2)=='')cycle
     ! construct a name of input field and register the field
     fieldname = trim(landuse_name(k1))//'2'//trim(landuse_name(k2))
     diag_ids(k1,k2) = register_diag_field(diag_mod_name,fieldname,(/id_lon,id_lat/), lnd%time, &
          'rate of transition from '//trim(landuse_longname(k1))//' to '//trim(landuse_longname(k2)),& 
          units='1/year', missing_value=-1.0)
  enddo
  enddo

  module_is_initialized=.TRUE.

end subroutine


! ============================================================================
subroutine land_transitions_end()
  
  if (do_landuse_change) &
       call horiz_interp_del(interp)
  if(allocated(time_in)) &
       deallocate(time_in,buffer_in)
  module_is_initialized=.FALSE.

end subroutine


! ============================================================================
subroutine save_land_transitions_restart(timestamp)
  character(*), intent(in) :: timestamp ! timestamp to add to the file name
  
  integer :: unit,year,month,day,hour,min,sec

  call mpp_open( unit, 'RESTART/'//trim(timestamp)//'landuse.res', nohdrs=.TRUE. )
  if (mpp_pe() == mpp_root_pe()) then
     call get_date(time0, year,month,day,hour,min,sec)
     write(unit,'(6i6,8x,a)') year,month,day,hour,min,sec, &
          'Time of previous landuse transition calculation'
  endif
  call mpp_close(unit)

end subroutine save_land_transitions_restart


! ============================================================================
! performs transitions between tiles, e.g. conversion of forests to crop, etc.
subroutine land_transitions (time)
  type(time_type), intent(in) :: time 

  ! ---- local vars.
  integer :: i,j,k1,k2
  type(tran_type), pointer :: transitions(:,:,:) => NULL()
  integer :: second, minute, hour, day0, day1, month0, month1, year0, year1

  if (.not.do_landuse_change) &
       return ! do nothing if landuse change not requested
  ! NB: in this case file/interp/data are not initialized, so it is
  ! not even possible to use the code below

  call get_date(time,             year0,month0,day0,hour,minute,second)
  call get_date(time-lnd%dt_slow, year1,month1,day1,hour,minute,second)
  if(year0 == year1) &
!!$  if(day0 == day1) &
       return ! do nothing during a year 

  ! get transition rates for current time: read map of transitions, and accumulate
  ! as many layers in array of transitions as necessary. Note that "transitions"
  ! array gets reallocated inside get_transitions as necessary, it has only as many
  ! layers as the max number of transitions occuring at a point at the time.
  do k1 = 1,N_LU_TYPES
  do k2 = 1,N_LU_TYPES
     call get_transitions(time0,time,k1,k2,transitions)
  enddo
  enddo

  ! perform the transitions
  do j = lnd%js,lnd%je
  do i = lnd%is,lnd%ie
     if(empty(lnd%tile_map(i,j))) cycle ! skip cells where there is no land
     ! set current point for debugging
     call set_current_point(i,j,1)
     ! transiton land area between different tile types
     call land_transitions_0d(lnd%tile_map(i,j), &
          transitions(i,j,:)%donor, &
          transitions(i,j,:)%acceptor,&
          transitions(i,j,:)%frac )
  enddo
  enddo
  
  ! deallocate array of transitions
  if (associated(transitions)) deallocate(transitions)
  
  ! store current time for future reference
  time0=time

end subroutine land_transitions


! =============================================================================
! performs tile transitions in a given grid cell
subroutine land_transitions_0d(d_list,d_kinds,a_kinds,area)
  type(land_tile_list_type), intent(inout) :: d_list ! list of tiles
  integer, intent(in) :: d_kinds(:) ! array of donor tile kinds
  integer, intent(in) :: a_kinds(:) ! array of acceptor tile kinds
  real   , intent(in) :: area(:)    ! array of areas changing from donor tiles to acceptor tiles
  
  ! ---- local vars
  integer :: i
  type(land_tile_type), pointer :: ptr
  type(land_tile_list_type) :: a_list
  type(land_tile_enum_type) :: ts, te
  real :: atot ! total fraction of tiles that can be involved in transitions
  ! variable used for conservation check:
  real :: lmass0, fmass0, cmass0, heat0, &
       soil_heat0, vegn_heat0, cana_heat0, snow_heat0 ! pre-transition values 
  real :: lmass1, fmass1, cmass1, heat1, &
       soil_heat1, vegn_heat1, cana_heat1, snow_heat1 ! post-transition values
  real :: lm, fm ! buffers for transition calulations

  ! conservation check code, part 1: calculate the pre-transition grid
  ! cell totals
  lmass0 = 0 ; fmass0 = 0 ; cmass0 = 0 ; heat0 = 0
  soil_heat0 = 0 ;  vegn_heat0 = 0 ; cana_heat0 = 0 ; snow_heat0 = 0
  ts = first_elmt(d_list) ; te=tail_elmt(d_list)
  do while (ts /= te)
     ptr=>current_tile(ts); ts=next_elmt(ts)
     call get_tile_water(ptr,lm,fm)
     lmass0 = lmass0 + lm*ptr%frac ; fmass0 = fmass0 + fm*ptr%frac

     heat0  = heat0  + land_tile_heat  (ptr)*ptr%frac
     cmass0 = cmass0 + land_tile_carbon(ptr)*ptr%frac
     
     if(associated(ptr%soil)) soil_heat0 = soil_heat0 + soil_tile_heat(ptr%soil)*ptr%frac
     if(associated(ptr%vegn)) vegn_heat0 = vegn_heat0 + vegn_tile_heat(ptr%vegn)*ptr%frac
     if(associated(ptr%cana)) cana_heat0 = cana_heat0 + cana_tile_heat(ptr%cana)*ptr%frac
     if(associated(ptr%snow)) snow_heat0 = snow_heat0 + snow_tile_heat(ptr%snow)*ptr%frac
  enddo

  ! calculate the area that can participate in land transitions
  atot = 0 ; ts = first_elmt(d_list) ; te=tail_elmt(d_list)
  do while (ts /= te)
     ptr=>current_tile(ts); ts=next_elmt(ts)
     if (.not.associated(ptr%vegn)) cycle
     atot = atot + ptr%frac
  enddo

  if (is_watch_point()) then
     write(*,*)'### land_transitions_0d: input parameters ###'
     do i = 1, size(d_kinds)
        __DEBUG4__(i,d_kinds(i),a_kinds(i),area(i))
        ! write(*,'(a,i2.2,100(2x,a,g))')'i='i,d_kinds(i)d_kinds(i),a_kinds(i),)
     enddo

     write(*,*)'### land_transitions_0d: land fractions before transitions (initial state) ###'
     ts = first_elmt(d_list) ; te=tail_elmt(d_list)
     do while (ts /= te)
        ptr=>current_tile(ts); ts=next_elmt(ts)
        if (.not.associated(ptr%vegn)) cycle
        write(*,*)'landuse=',ptr%vegn%landuse,' area=',ptr%frac
     enddo
     write(*,'(a,g)')'total area=',atot
  endif

  ! split each donor tile and gather the parts that undergo a 
  ! transition into a separate list. Note that the kind of the landuse is
  ! changed during this transition, including forest harvesting if necessary.
  ! This has to occur at some time before the tiles are merged, and it seems
  ! to be the most convenient place as both original and final landuse kind
  ! is known for each part.
  call land_tile_list_init(a_list)
  do i = 1,size(d_kinds)
     call split_changing_tile_parts(d_list,d_kinds(i),a_kinds(i),area(i)*atot,a_list)
     ! the factor atot normalizes the transitions to the total area in the grid cell
     ! available for the land use, that is, the area of land excluding lakes and glaciers
  enddo
  if (is_watch_point()) then
     write(*,*)'### land_transitions_0d: land fractions after splitting changing parts ###'
     atot = 0 ; ts = first_elmt(d_list) ; te=tail_elmt(d_list)
     do while (ts /= te)
        ptr=>current_tile(ts); ts=next_elmt(ts)
        if (.not.associated(ptr%vegn)) cycle
        write(*,'(2(a,g,2x))')'   donor: landuse=',ptr%vegn%landuse,' area=',ptr%frac
        atot = atot + ptr%frac
     enddo
     ts = first_elmt(a_list); te=tail_elmt(a_list)
     do while (ts /= te)
        ptr=>current_tile(ts); ts=next_elmt(ts)
        if (.not.associated(ptr%vegn)) cycle
        write(*,'(2(a,g,2x))')'acceptor: landuse=',ptr%vegn%landuse,' area=',ptr%frac
        atot = atot + ptr%frac
     enddo
     write(*,'(a,g)')'total area=',atot
  endif

  ! move all tiles from the donor list to the acceptor list -- this will ensure
  ! that all the tiles that can be merged at this time will be
  te = tail_elmt(d_list) 
  do 
     ts=first_elmt(d_list)
     if(ts==te) exit ! reached the end of the list
     ptr=>current_tile(ts)
     if(ptr%frac <= 0.0) then
        call erase(ts) ! if area of the tile is zero, free it
     else
        ! othervise, move it to a_list
        call remove(ts)
        call insert(ptr,a_list)
     endif
  enddo
  ! d_list is empty at this point

  ! merge all generated tiles into the source (donor) list
  te = tail_elmt(a_list) 
  do
     ts=first_elmt(a_list)
     if(ts==te) exit ! break out of loop
     ptr=>current_tile(ts)
     call remove(ts)
     call land_tile_merge(ptr,d_list)
  enddo
  ! a_list is empty at this point
  call land_tile_list_end(a_list)

  if (is_watch_point()) then
     write(*,*)'### land_transitions_0d: land fractions final state ###'
     atot = 0
     ts = first_elmt(d_list); te=tail_elmt(d_list)
     do while (ts /= te)
        ptr=>current_tile(ts); ts=next_elmt(ts)
        if (.not.associated(ptr%vegn)) cycle
        write(*,'(2(a,g,2x))')'landuse=',ptr%vegn%landuse,' area=',ptr%frac
        atot = atot + ptr%frac
     enddo
     write(*,'(a,g)')'total area=',atot
  endif

  ! conservation check part 2: calculate grid cell totals in final state, and 
  ! compare them with pre-transition totals
  lmass1 = 0 ; fmass1 = 0 ; cmass1 = 0 ; heat1 = 0
  soil_heat1 = 0 ;  vegn_heat1 = 0 ; cana_heat1 = 0 ; snow_heat1 = 0
  ts = first_elmt(d_list) ; te=tail_elmt(d_list)
  do while (ts /= te)
     ptr=>current_tile(ts); ts=next_elmt(ts)
     call get_tile_water(ptr,lm,fm)
     lmass1 = lmass1 + lm*ptr%frac ; fmass1 = fmass1 + fm*ptr%frac

     heat1  = heat1  + land_tile_heat  (ptr)*ptr%frac
     cmass1 = cmass1 + land_tile_carbon(ptr)*ptr%frac

     if(associated(ptr%soil)) soil_heat1 = soil_heat1 + soil_tile_heat(ptr%soil)*ptr%frac
     if(associated(ptr%vegn)) vegn_heat1 = vegn_heat1 + vegn_tile_heat(ptr%vegn)*ptr%frac
     if(associated(ptr%cana)) cana_heat1 = cana_heat1 + cana_tile_heat(ptr%cana)*ptr%frac
     if(associated(ptr%snow)) snow_heat1 = snow_heat1 + snow_tile_heat(ptr%snow)*ptr%frac
  enddo
  call check_conservation ('liquid water', lmass0, lmass1, 1e-6)
  call check_conservation ('frozen water', fmass0, fmass1, 1e-6)
  call check_conservation ('carbon'      , cmass0, cmass1, 1e-6)
  call check_conservation ('canopy air heat content', cana_heat0 , cana_heat1 , 1e-6)
  call check_conservation ('vegetation heat content', vegn_heat0 , vegn_heat1 , 1e-6)
  call check_conservation ('snow heat content',       snow_heat0 , snow_heat1 , 1e-6)
  call check_conservation ('soil heat content',       soil_heat0 , soil_heat1 , 1e-6)
  call check_conservation ('heat content', heat0 , heat1 , 1e-6)

end subroutine 


! ==============================================================================
! given a pointer to a tile and a tile list, insert the tile into the list so that
! if tile can be merged with any one already present, it is merged; otherwise 
! the tile is inserted into the list
subroutine land_tile_merge(tile, list)
  type(land_tile_type), pointer :: tile
  type(land_tile_list_type), intent(inout) :: list

  ! ---- local vars
  type(land_tile_type), pointer :: ptr
  type(land_tile_enum_type) :: ct,et
  
  ! try to find a tile that we can merge to
  ct = first_elmt(list) ; et = tail_elmt(list)
  do while(ct/=et)
     ptr=>current_tile(ct) ; ct = next_elmt(ct)
     if (land_tiles_can_be_merged(tile,ptr)) then
        call merge_land_tiles(tile,ptr)
        call delete_land_tile(tile)
        return ! break out of the subroutine
     endif
  enddo
  ! we reach here only if no suitable files was found in the list
  ! if no suitable tile was found, just insert given tile into the list
  call insert(tile,list)
end subroutine land_tile_merge


! =============================================================================
! splits changing parts of donor tiles into a separate tile list, performing
! land use changes in the process
subroutine split_changing_tile_parts(d_list,d_kind,a_kind,dfrac,a_list)
  type(land_tile_list_type), intent(in) :: d_list ! list of donor tiles
  integer, intent(in) :: d_kind ! kind of donor tiles
  integer, intent(in) :: a_kind ! kind of acceptor tiles
  real,    intent(in) :: dfrac  ! fraction of land area that changes kind
  type(land_tile_list_type), intent(inout) :: a_list ! list of acceptors
  
  ! ---- local vars
  type(land_tile_enum_type) :: ct, et
  type(land_tile_type), pointer :: temp
  type(land_tile_type), pointer :: tile
  real :: area, darea, area0, area1
  real :: x0,x1,x2 ! values of transition intensity
  real, parameter :: eps = 1e-6 ! area calculation precision
  integer :: iter
  real :: factor = 1.6
  integer :: severity ! severity of overshoot errors
  integer :: i,j,k,face ! coordinates of current point, for overshoot diagnostics

  ! calculate total area of the tiles that should be transitioned to another kind
  area = 0
  ct = first_elmt(d_list); et=tail_elmt(d_list)
  do while (ct /= et)
     tile=>current_tile(ct); ct=next_elmt(ct)
     if (.not.associated(tile%vegn)) cycle
     if (tile%vegn%landuse == d_kind)  &
          area = area + tile%frac
  enddo

  ! check for overshoot situtaion: that is, a case where the transition area is
  ! larger than the available area
  if(overshoot_opt /= OPT_IGNORE.and.dfrac>area+overshoot_tolerance) then
     severity = WARNING
     if (overshoot_opt==OPT_STOP) severity = FATAL
     call get_current_point(i,j,k,face)
     call error_mesg('she_landuse',&
          'transition at ('//trim(string(i))//','//trim(string(j))//&
          ',face='//trim(string(face))//&
          ') from "'//trim(landuse_name(d_kind))// &
          '" to "'  //trim(landuse_name(a_kind))//&
          '" ('//trim(string(dfrac))//') is larger than area of "'&
          //trim(landuse_name(d_kind))//'" ('//trim(string(area))//')', &
          severity)
  endif

  ! if area of the tiles of requested kind is zero we cannot transition
  ! anything, so just return
  if (area==0) return
       
  ! transition cannot be more than current total area of specified kind
  darea = min(dfrac, area)

  ! solve equation to get transition intensity
  ! (1) bracket transition intensity interval so that requested area is within it
  x0=0.0; area0 = total_transition_area(d_list, d_kind, a_kind, x0)
  x1=1.0; area1 = total_transition_area(d_list, d_kind, a_kind, x1)
  iter = 0
  do
     if ((area0<=darea).and.(area1>=darea)) exit
     if (area0>darea) then
        x0 = x0-(x1-x0)*factor
        area0 = total_transition_area(d_list, d_kind, a_kind, x0)
     else
        x1 = x1+(x1-x0)*factor
        area1 = total_transition_area(d_list, d_kind, a_kind, x1)
     endif
     iter = iter+1
     if (iter>50) then
        call error_mesg('veg_tile_transitions',&
             'cannot braket transition intensity interval after 50 iterations',&
             FATAL) 
     endif
  enddo

  ! find solution for transition intensity by binary search
  do iter = 1,50
     x2 = (x0+x1)/2
     area = total_transition_area(d_list, d_kind, a_kind, x2)
     if (abs(x1-x2)<eps) exit
     if (area>darea) then
        x1=x2
     else
        x0=x2
     endif
  enddo

  ! do tile transitions to destination list
  ct = first_elmt(d_list); et=tail_elmt(d_list)
  do while (ct /= et)
     tile=>current_tile(ct) ; ct=next_elmt(ct)
     if(.not.associated(tile%vegn)) cycle
     if(tile%vegn%landuse == d_kind) then
        darea = vegn_tran_priority(tile%vegn, a_kind, x2)
        if(darea > 0) then
           ! make a copy 
           temp => new_land_tile(tile)
           temp%frac = tile%frac*darea
           tile%frac = tile%frac*(1.0-darea)
           ! convert land use type of the tile:
           ! cut the forest, if necessary
           if(temp%vegn%landuse==LU_NTRL.or.temp%vegn%landuse==LU_SCND) &
                call vegn_cut_forest(temp%vegn, a_kind)
           ! change landuse type of the tile
           temp%vegn%landuse = a_kind
           ! add the new tile to the resulting list 
           call insert(temp, a_list) ! insert tile into output list
        endif
     endif
  enddo

end subroutine split_changing_tile_parts


! ============================================================================
! calculates total area (fraction of grid cell area) participating in 
! vegetation transition from src_kind to dst_kind for given transition
! intensity tau
function total_transition_area(list,src_kind,dst_kind,tau) result (total_area)
  real :: total_area
  type(land_tile_list_type), intent(in) :: list ! list of tiles
  integer , intent(in) :: src_kind, dst_kind ! source and destination kinds
  real    , intent(in) :: tau                ! transition intensity

  ! ---- local vars
  type(land_tile_enum_type) :: ct, et
  type(land_tile_type), pointer :: tile

  total_area = 0
  ct = first_elmt(list) ; et = tail_elmt(list) 
  do while (ct/=et)
     tile=>current_tile(ct);  ct = next_elmt(ct)
     if (.not.associated(tile%vegn)) cycle ! skip non-vegetated tiles
     if(tile%vegn%landuse == src_kind) &
          total_area = total_area + tile%frac*vegn_tran_priority(tile%vegn,dst_kind,tau)
  enddo
  
end function


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

subroutine get_transitions(time0,time1,k1,k2,tran)
  type(time_type), intent(in) :: time0       ! time of previous calculation of 
    ! transitions (the integral transitinos will be calculated between time0 
    ! and time)
  type(time_type), intent(in) :: time1       ! current time
  integer, intent(in) :: k1,k2               ! kinds of tiles
  type(tran_type), pointer :: tran(:,:,:)    ! transition info

  ! ---- local vars
  integer :: i,j,k,sec,days
  type(tran_type), pointer :: ptr(:,:,:) => NULL()
  real    :: frac(lnd%is:lnd%ie,lnd%js:lnd%je)
  real    :: part_of_year
  logical :: used

  ! allocate array of transitions, if necessary
  if (.not.associated(tran)) then
     allocate(tran(lnd%is:lnd%ie,lnd%js:lnd%je,1) )
  end if

  ! get transition rate for this specific transition
  frac(:,:) = 0.0
  if(input_ids(k1,k2)>0) then
     call integral_transition(time0,time1,input_ids(k1,k2),frac)
     
     do j = lnd%js,lnd%je
     do i = lnd%is,lnd%ie
        if(frac(i,j) == 0) cycle ! skip points where transition rate is zero
        ! find the first empty transition element for the current indices
        k = 1
        do while ( k <= size(tran,3) )
           if(tran(i,j,k)%donor == 0) exit
           k = k+1
        enddo

        if (k>size(tran,3)) then
           ! if there is no room, make the array of transitions larger
           allocate(ptr(lnd%is:lnd%ie,lnd%js:lnd%je,size(tran,3)*2))
           ptr(:,:,1:size(tran,3)) = tran
           deallocate(tran)
           tran => ptr
           nullify(ptr)
        end if

        ! store the transition element
        tran(i,j,k) = tran_type(k1,k2,frac(i,j))
     enddo
     enddo
  endif

  ! send transition data to diagnostics
  if(diag_ids(k1,k2)>0) then
     call get_time(time1-time0, sec,days)
     part_of_year = (days+sec/86400.0)/days_in_year(time0)
     used = send_data(diag_ids(k1,k2),frac/part_of_year,time1)
  endif

end subroutine get_transitions


! ===========================================================================
! given beginnig and end of the time period, and the id of the external
! tile transition field, calculates total transition during the specified period.
! The transition rate data are assumed to be in fraction of land area per year,
! timestamped at the beginning of the year
subroutine integral_transition(t1, t2, id, frac)
  type(time_type), intent(in)  :: t1,t2 ! time boundaries
  integer        , intent(in)  :: id    ! id of the field
  real           , intent(out) :: frac(:,:)

  ! ---- local vars
  integer :: n ! size of time axis
  type(time_type) :: ts,te
  integer         :: i1,i2
  real :: w  ! time interpolation weight
  real :: dt ! current time interval, in years
  real :: sum(size(frac,1),size(frac,2))
  integer :: i,j

  ! adjust the integration limits, in case they are out of range   
  n = size(time_in)
  ts = t1; 
  if (ts<time_in(1)) ts = time_in(1)
  if (ts>time_in(n)) ts = time_in(n) 
  te = t2
  if (te<time_in(1)) te = time_in(1)
  if (te>time_in(n)) te = time_in(n) 

  call time_interp(ts, time_in, w, i1,i2)
  __NF_ASRT__(nfu_get_rec(ncid,id,i1,buffer_in))

  frac = 0;
  call horiz_interp(interp,buffer_in,frac)
  dt = (time_in(i2)-time_in(i1))//set_time(0,days_in_year((time_in(i2)+time_in(i1))/2))
  sum = -frac*w*dt
  do while(time_in(i2)<=te)
     __NF_ASRT__(nfu_get_rec(ncid,id,i1,buffer_in))
     call horiz_interp(interp,buffer_in,frac)
     dt = (time_in(i2)-time_in(i1))//set_time(0,days_in_year((time_in(i2)+time_in(i1))/2))
     sum = sum+frac*dt
     i2 = i2+1
     i1 = i2-1
  enddo

  call time_interp(te,time_in,w,i1,i2)
  __NF_ASRT__(nfu_get_rec(ncid,id,i1,buffer_in))
  call horiz_interp(interp,buffer_in,frac)
  dt = (time_in(i2)-time_in(i1))//set_time(0,days_in_year((time_in(i2)+time_in(i1))/2))
  frac = sum+frac*w*dt
  do i = 1,size(frac,1)
  do j = 1,size(frac,2)
     if(frac(i,j)<0) then
        call error_mesg('get','transition rate is below zero',FATAL)
     endif
  enddo
  enddo
end subroutine


! ==============================================================================
! checks conservation and aborts with fatal error if tolerance is exceeded
subroutine check_conservation(name, d1, d2, tolerance)
  character(*), intent(in) :: name ! name of the component
  real, intent(in) :: d1,d2 ! values to check
  real, intent(in) :: tolerance ! tolerance of the test

  integer :: curr_i, curr_j, face
  integer :: severity ! severity of the generated message
  character(256) :: message

  if (conservation_opt == OPT_IGNORE) return ! do nothing

  severity = WARNING
  if (overshoot_opt==OPT_STOP) severity = FATAL
  
  if (abs(d1-d2)>tolerance) then
     call get_current_point(i=curr_i,j=curr_j,face=face)
     write(message,'(a,3(x,a,i4), 2(x,a,g))')&
          'conservation of '//trim(name)//' is violated', &
          'at i=',curr_i,'j=',curr_j,'face=',face, &
          'value before=', d1, 'after=', d2
     call error_mesg('land_transitions',message,severity)
  endif
end subroutine 

end module


module vegetation_mod

#include "../shared/debug.inc"

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only: write_version_number, error_mesg, NOTE,FATAL, file_exist, close_file, &
                   check_nml_error, stdlog 
use mpp_mod, only: mpp_sum, mpp_max, mpp_pe, mpp_root_pe
use time_manager_mod, only: time_type, time_type_to_real, get_date, operator(-)
use constants_mod,    only: tfreeze, rdgas, rvgas, hlv, hlf, cp_air, PI
use sphum_mod, only: qscomp
use nf_utils_mod, only: nfu_def_var, nfu_get_var, nfu_put_var, nfu_inq_var

use vegn_tile_mod, only: vegn_tile_type, &
     vegn_seed_demand, vegn_seed_supply, vegn_add_bliving, &
     cpw, clw, csw
use soil_tile_mod, only: soil_tile_type, soil_ave_temp, soil_ave_theta, &
                         soil_ave_theta1     
use land_constants_mod, only : NBANDS, BAND_VIS, d608, mol_C, mol_CO2, mol_air, &
     seconds_per_year
use land_tile_mod, only : land_tile_type, land_tile_enum_type, &
     first_elmt, tail_elmt, next_elmt, current_tile, operator(/=), &
     get_elmt_indices
use land_tile_diag_mod, only : &
     register_tiled_static_field, register_tiled_diag_field, &
     send_tile_data, diag_buff_type
use land_data_mod,      only : land_state_type, lnd
use land_io_mod, only : read_field
use land_tile_io_mod, only : &
     create_tile_out_file, &
     write_tile_data_r0d_fptr, write_tile_data_i0d_fptr, write_tile_data_r1d_fptr, &
     read_tile_data_r0d_fptr,  read_tile_data_i0d_fptr,  read_tile_data_r1d_fptr, &
     print_netcdf_error, get_input_restart_name
use vegn_data_mod, only : SP_C4GRASS, LEAF_ON, LU_NTRL, read_vegn_data_namelist, &
     tau_drip_l, tau_drip_s, T_transp_min, cold_month_threshold, soil_carbon_depth_scale, &
     fsc_pool_spending_time, ssc_pool_spending_time, harvest_spending_time, &
     N_HARV_POOLS, HARV_POOL_NAMES
use vegn_cohort_mod, only : vegn_cohort_type, vegn_phys_prog_type, &
     update_species,&
     vegn_data_heat_capacity, vegn_data_intrcptn_cap, &
     get_vegn_wet_frac, vegn_data_cover
use canopy_air_mod, only : cana_turbulence
     
use cohort_io_mod, only :  read_create_cohorts, create_cohort_dimension, &
     read_cohort_data_r0d_fptr,  read_cohort_data_i0d_fptr,&
     write_cohort_data_r0d_fptr, write_cohort_data_i0d_fptr
use land_debug_mod, only : is_watch_point, set_current_point, check_temp_range
use vegn_radiation_mod, only : vegn_radiation_init, vegn_radiation
use vegn_photosynthesis_mod, only : vegn_photosynthesis_init, vegn_photosynthesis
use static_vegn_mod, only : read_static_vegn_namelist, static_vegn_init, static_vegn_end, &
     read_static_vegn
use vegn_dynamics_mod, only : vegn_dynamics_init, vegn_carbon_int, vegn_growth, &
     vegn_daily_npp, vegn_phenology, vegn_biogeography
use vegn_disturbance_mod, only : vegn_nat_mortality, vegn_disturbance, update_fuel
use vegn_harvesting_mod, only : &
     vegn_harvesting_init, vegn_harvesting_end, vegn_harvesting

implicit none
private

! ==== public interfaces =====================================================
public :: read_vegn_namelist
public :: vegn_init
public :: vegn_end
public :: save_vegn_restart

public :: vegn_get_cover
public :: vegn_radiation
public :: vegn_diffusion

public :: vegn_step_1
public :: vegn_step_2
public :: vegn_step_3

public :: update_vegn_slow
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), private, parameter :: &
   version = '$Id: vegetation.F90,v 17.0.2.2.2.3.2.1.2.1 2010/08/24 12:11:36 pjp Exp $', &
   tagname = '$Name:  $', &
   module_name = 'vegn'
! values for internal selector of CO2 option used for photosynthesis
integer, parameter :: VEGN_PHOT_CO2_PRESCRIBED  = 1
integer, parameter :: VEGN_PHOT_CO2_INTERACTIVE = 2


! ==== module variables ======================================================

!---- namelist ---------------------------------------------------------------
logical :: lm2               = .false.
real    :: init_Wl           = 0
real    :: init_Ws           = 0
real    :: init_Tv           = 288.
real    :: init_cohort_bl    = 0.05 ! initial biomass of leaves, kg C/m2
real    :: init_cohort_blv   = 0.0  ! initial biomass of labile store, kg C/m2
real    :: init_cohort_br    = 0.05 ! initial biomass of fine roots, kg C/m2
real    :: init_cohort_bsw   = 0.05 ! initial biomass of sapwood, kg C/m2
real    :: init_cohort_bwood = 0.05 ! initial biomass of heartwood, kg C/m2
real    :: init_cohort_cmc   = 0.0  ! initial intercepted water
character(32) :: rad_to_use = 'big-leaf' ! or 'two-stream'
character(32) :: snow_rad_to_use = 'ignore' ! or 'paint-leaves'
character(32) :: photosynthesis_to_use = 'simple' ! or 'leuning'
character(32) :: co2_to_use_for_photosynthesis = 'prescribed' ! or 'interactive'
   ! specifies what co2 concentration to use for photosynthesis calculations: 
   ! 'prescribed'  : a prescribed value is used, equal to co2_for_photosynthesis
   !      specified below.
   ! 'interactive' : concentration of co2 in canopy air is used
real    :: co2_for_photosynthesis = 350.0e-6 ! concentration of co2 for photosynthesis 
   ! calculations, mol/mol. Ignored if co2_to_use_for_photosynthesis is not 'prescribed'
logical :: write_soil_carbon_restart = .FALSE. ! indicates whether to write
                        ! information for soil carbon acceleration
logical :: do_cohort_dynamics   = .TRUE. ! if true, do vegetation growth
logical :: do_patch_disturbance = .TRUE. ! 
logical :: do_phenology         = .TRUE. 
logical :: do_biogeography      = .TRUE.
logical :: do_seed_transport    = .TRUE.
real    :: min_Wl=-1.0, min_Ws=-1.0 ! threshold values for condensation numerics, kg/m2:
   ! if water or snow on canopy fall below these values, the derivatives of
   ! condensation are set to zero, thereby prohibiting switching from condensation to
   ! evaporation in one time step.
real    :: tau_smooth_ncm = 0.0 ! Time scale for ncm smoothing
   ! (low-pass filtering), years. 0.0 retrieves previous behavior (no smoothing)
namelist /vegn_nml/ &
    lm2, init_Wl, init_Ws, init_Tv, cpw, clw, csw, &
    init_cohort_bl, init_cohort_blv, init_cohort_br, init_cohort_bsw, &
    init_cohort_bwood, init_cohort_cmc, &
    rad_to_use, snow_rad_to_use, photosynthesis_to_use, &
    co2_to_use_for_photosynthesis, co2_for_photosynthesis, &
    write_soil_carbon_restart, &
    do_cohort_dynamics, do_patch_disturbance, do_phenology, &
    do_biogeography, do_seed_transport, &
    min_Wl, min_Ws, tau_smooth_ncm
    
!---- end of namelist --------------------------------------------------------

logical         :: module_is_initialized =.FALSE.
type(time_type) :: time ! *** NOT YET USED
real            :: delta_time      ! fast time step
real            :: dt_fast_yr      ! fast time step in years
integer         :: vegn_phot_co2_option = -1 ! internal selector of co2 option 
                                   ! used for photosynthesis
! diagnostic field ids
integer :: id_vegn_type, id_temp, id_wl, id_ws, id_height, id_lai, id_sai, id_leaf_size, &
   id_root_density, id_root_zeta, id_rs_min, id_leaf_refl, id_leaf_tran,&
   id_leaf_emis, id_snow_crit, id_stomatal, id_an_op, id_an_cl, &
   id_bl, id_blv, id_br, id_bsw, id_bwood, id_species, id_status, &
   id_con_v_h, id_con_v_v, id_fuel, id_harv_pool(N_HARV_POOLS), &
   id_harv_rate(N_HARV_POOLS), id_t_harv_pool, id_t_harv_rate, &
   id_csmoke_pool, id_csmoke_rate, id_fsc_in, id_fsc_out, id_ssc_in, &
   id_ssc_out, id_veg_in, id_veg_out, id_fsc_pool, id_fsc_rate, &
   id_ssc_pool, id_ssc_rate, id_t_ann, id_t_cold, id_p_ann, id_ncm, &
   id_lambda, id_afire, id_atfall, id_closs, id_cgain, id_wdgain, id_leaf_age, &
   id_phot_co2
! ==== end of module variables ===============================================

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

contains

! ============================================================================
subroutine read_vegn_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  logical :: use_static_veg ! if true, switch off vegetation dynamics

  call read_vegn_data_namelist()
  call read_static_vegn_namelist(use_static_veg)

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
    read (input_nml_file, nml=vegn_nml, iostat=io)
    ierr = check_nml_error(io, 'vegn_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=vegn_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'vegn_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif

  unit=stdlog()

  ! switch off vegetation dynamics if static vegetation is set
  if (use_static_veg) then
     call error_mesg('vegn_init', &
          'use_static_veg=.TRUE., switching off vegetation dynamics', NOTE)
     write(unit,*)'use_static_veg=.TRUE., switching off vegetation dynamics'
     do_cohort_dynamics   = .FALSE.
     do_patch_disturbance = .FALSE.
     do_phenology         = .FALSE. 
     do_biogeography      = .FALSE.
     do_seed_transport    = .FALSE.
  endif

  if (mpp_pe() == mpp_root_pe()) then
     write(unit, nml=vegn_nml)
  endif

  ! convert symbolic names of photosynthesis CO2 options into numeric IDs to
  ! speed up selection during run-time
  if (trim(co2_to_use_for_photosynthesis)=='prescribed') then
     vegn_phot_co2_option = VEGN_PHOT_CO2_PRESCRIBED
  else if (trim(co2_to_use_for_photosynthesis)=='interactive') then
     vegn_phot_co2_option = VEGN_PHOT_CO2_INTERACTIVE
  else
     call error_mesg('vegn_init',&
          'vegetation photosynthesis option co2_to_use_for_photosynthesis="'//&
          trim(co2_to_use_for_photosynthesis)//'" is invalid, use "prescribed" or "interactive"',&
          FATAL)
  endif

  ! ---- initialize vegetation radiation options
  call vegn_radiation_init(rad_to_use, snow_rad_to_use)

  ! ---- initialize vegetation photosynthesis options
  call vegn_photosynthesis_init(photosynthesis_to_use)

end subroutine read_vegn_namelist


! ============================================================================
! initialize vegetation
subroutine vegn_init ( id_lon, id_lat, id_band )
  integer, intent(in) :: id_lon  ! ID of land longitude (X) axis  
  integer, intent(in) :: id_lat  ! ID of land latitude (Y) axis
  integer, intent(in) :: id_band ! ID of spectral band axis

  ! ---- local vars
  integer :: unit         ! unit for various i/o
  type(land_tile_enum_type)     :: te,ce ! current and tail tile list elements
  type(land_tile_type), pointer :: tile  ! pointer to current tile
  type(vegn_cohort_type), pointer :: cohort! pointer to initial cohort for cold-start
  integer :: n_accum
  integer :: nmn_acm
  character(len=256) :: restart_file_name_1, restart_file_name_2
  logical :: restart_1_exists, restart_2_exists
  real, allocatable :: t_ann(:,:),t_cold(:,:),p_ann(:,:),ncm(:,:) ! buffers for biodata reading 
  logical :: did_read_biodata = .FALSE.
  integer :: i,j ! indices of current tile

  module_is_initialized = .TRUE.

  ! ---- make module copy of time and calculate time step ------------------
  time       = lnd%time
  delta_time = time_type_to_real(lnd%dt_fast)
  dt_fast_yr = delta_time/seconds_per_year


  ! ---- initialize vegn state ---------------------------------------------
  n_accum = 0
  nmn_acm = 0
  call get_input_restart_name('INPUT/vegn1.res.nc',restart_1_exists, restart_file_name_1)
  call get_input_restart_name('INPUT/vegn2.res.nc',restart_2_exists, restart_file_name_2)
  if (restart_1_exists) then
     call error_mesg('vegn_init',&
          'reading NetCDF restarts "'//trim(restart_file_name_1)//&
                            '" and "'//trim(restart_file_name_2)//'"',&
          NOTE)
     __NF_ASRT__(nf_open(restart_file_name_1,NF_NOWRITE,unit))
     ! read the cohort index and generate appropriate number of cohorts
     ! for each vegetation tile
     call read_create_cohorts(unit)
     
     ! read cohort data
     call read_cohort_data_r0d_fptr(unit, 'tv', cohort_tv_ptr )
     call read_cohort_data_r0d_fptr(unit, 'wl', cohort_wl_ptr )
     call read_cohort_data_r0d_fptr(unit, 'ws', cohort_ws_ptr )
     __NF_ASRT__(nf_close(unit))     

     __NF_ASRT__(nf_open(restart_file_name_2,NF_NOWRITE,unit))
     ! read global variables
     __NF_ASRT__(nfu_get_var(unit,'n_accum',n_accum))
     __NF_ASRT__(nfu_get_var(unit,'nmn_acm',nmn_acm))

     call read_cohort_data_i0d_fptr(unit, 'species', cohort_species_ptr )
     call read_cohort_data_r0d_fptr(unit, 'hite', cohort_height_ptr )
     call read_cohort_data_r0d_fptr(unit, 'bl', cohort_bl_ptr )
     call read_cohort_data_r0d_fptr(unit, 'blv', cohort_blv_ptr )
     call read_cohort_data_r0d_fptr(unit, 'br', cohort_br_ptr )
     call read_cohort_data_r0d_fptr(unit, 'bsw', cohort_bsw_ptr )
     call read_cohort_data_r0d_fptr(unit, 'bwood', cohort_bwood_ptr )
     call read_cohort_data_r0d_fptr(unit, 'bliving', cohort_bliving_ptr )
     call read_cohort_data_i0d_fptr(unit, 'status', cohort_status_ptr )
     if(nfu_inq_var(unit,'leaf_age')==NF_NOERR) &
          call read_cohort_data_r0d_fptr(unit,'leaf_age',cohort_leaf_age_ptr)
     call read_cohort_data_r0d_fptr(unit, 'npp_prev_day', cohort_npp_previous_day_ptr )

     if(nfu_inq_var(unit,'landuse')==NF_NOERR) &
          call read_tile_data_i0d_fptr(unit,'landuse',vegn_landuse_ptr)
     call read_tile_data_r0d_fptr(unit,'age',vegn_age_ptr)
     call read_tile_data_r0d_fptr(unit,'fsc',vegn_fast_soil_C_ptr)
     call read_tile_data_r0d_fptr(unit,'ssc',vegn_slow_soil_C_ptr)
     call read_tile_data_r0d_fptr(unit,'fsc_pool',vegn_fsc_pool_ptr)
     call read_tile_data_r0d_fptr(unit,'fsc_rate',vegn_fsc_rate_ptr)
     call read_tile_data_r0d_fptr(unit,'ssc_pool',vegn_ssc_pool_ptr)
     call read_tile_data_r0d_fptr(unit,'ssc_rate',vegn_ssc_rate_ptr)
     ! monthly-mean values
     call read_tile_data_r0d_fptr(unit,'tc_av', vegn_tc_av_ptr)
     call read_tile_data_r0d_fptr(unit,'theta_av', vegn_theta_av_ptr)
     call read_tile_data_r0d_fptr(unit,'tsoil_av', vegn_tsoil_av_ptr)
     call read_tile_data_r0d_fptr(unit,'precip_av', vegn_precip_av_ptr)
     call read_tile_data_r0d_fptr(unit,'lambda', vegn_lambda_ptr)
     call read_tile_data_r0d_fptr(unit,'fuel', vegn_fuel_ptr)
     ! annual-mean values
     call read_tile_data_r0d_fptr(unit,'t_ann', vegn_t_ann_ptr)
     call read_tile_data_r0d_fptr(unit,'t_cold', vegn_t_cold_ptr)
     call read_tile_data_r0d_fptr(unit,'p_ann', vegn_p_ann_ptr)
     call read_tile_data_r0d_fptr(unit,'ncm', vegn_ncm_ptr)
     ! accumulated values for annual averaging
     call read_tile_data_r0d_fptr(unit,'t_ann_acm', vegn_t_ann_acm_ptr)
     call read_tile_data_r0d_fptr(unit,'t_cold_acm', vegn_t_cold_acm_ptr)
     call read_tile_data_r0d_fptr(unit,'p_ann_acm', vegn_p_ann_acm_ptr)
     call read_tile_data_r0d_fptr(unit,'ncm_acm', vegn_ncm_acm_ptr)
     ! burned carbon pool and rate
     if(nfu_inq_var(unit,'csmoke_pool')==NF_NOERR) &
          call read_tile_data_r0d_fptr(unit,'csmoke_pool',vegn_csmoke_pool_ptr)
     if(nfu_inq_var(unit,'csmoke_rate')==NF_NOERR) &
          call read_tile_data_r0d_fptr(unit,'csmoke_rate',vegn_csmoke_rate_ptr)
     ! harvesting pools and rates
     do i = 1, N_HARV_POOLS
        if (nfu_inq_var(unit,trim(HARV_POOL_NAMES(i))//'_harv_pool')==NF_NOERR) &
             call read_tile_data_r1d_fptr(unit,trim(HARV_POOL_NAMES(i))//'_harv_pool',vegn_harv_pool_ptr,i)
        if (nfu_inq_var(unit,trim(HARV_POOL_NAMES(i))//'_harv_rate')==NF_NOERR) &
             call read_tile_data_r1d_fptr(unit,trim(HARV_POOL_NAMES(i))//'_harv_rate',vegn_harv_rate_ptr,i)
     enddo

     __NF_ASRT__(nf_close(unit))
  else
     call error_mesg('vegn_init',&
          'cold-starting vegetation',&
          NOTE)
  endif
  ! read climatological fields for initialization of species distribution
  if (file_exist('INPUT/biodata.nc'))then
     allocate(&
          t_ann (lnd%is:lnd%ie,lnd%js:lnd%je),&
          t_cold(lnd%is:lnd%ie,lnd%js:lnd%je),&
          p_ann (lnd%is:lnd%ie,lnd%js:lnd%je),&
          ncm   (lnd%is:lnd%ie,lnd%js:lnd%je) )
     call read_field( 'INPUT/biodata.nc','T_ANN', &
          lnd%lon, lnd%lat, t_ann, interp='nearest')
     call read_field( 'INPUT/biodata.nc','T_COLD', &
          lnd%lon, lnd%lat, t_cold, interp='nearest')
     call read_field( 'INPUT/biodata.nc','P_ANN', &
          lnd%lon, lnd%lat, p_ann, interp='nearest')
     call read_field( 'INPUT/biodata.nc','NCM', &
          lnd%lon, lnd%lat, ncm, interp='nearest')
     did_read_biodata = .TRUE.
  endif
  ! Go through all tiles and initialize the cohorts that have not been initialized yet --
  ! this allows to read partial restarts. Also initialize accumulation counters to zero
  ! or the values from the restarts.
  te = tail_elmt(lnd%tile_map)
  ce = first_elmt(lnd%tile_map, is=lnd%is, js=lnd%js)
  do while(ce /= te)
     tile=>current_tile(ce)  ! get pointer to current tile
     call get_elmt_indices(ce,i,j)
     ce=next_elmt(ce)       ! advance position to the next tile
     if (.not.associated(tile%vegn)) cycle

     tile%vegn%n_accum = n_accum
     tile%vegn%nmn_acm = nmn_acm

     if (tile%vegn%n_cohorts>0) cycle ! skip initialized tiles
     
     ! create and initialize cohorts for this vegetation tile
     ! for now, just create a new cohort with default values of biomasses
     tile%vegn%n_cohorts = 1
     allocate(tile%vegn%cohorts(tile%vegn%n_cohorts))
     cohort => tile%vegn%cohorts(1)
     cohort%prog%Wl = init_Wl
     cohort%prog%Ws = init_Ws
     cohort%prog%Tv = init_Tv
     
     cohort%bl      = init_cohort_bl
     cohort%blv     = init_cohort_blv
     cohort%br      = init_cohort_br
     cohort%bsw     = init_cohort_bsw
     cohort%bwood   = init_cohort_bwood
     cohort%bliving = cohort%bl+cohort%br+cohort%blv+cohort%bsw
     cohort%npp_previous_day = 0.0
     cohort%status  = LEAF_ON
     cohort%leaf_age = 0.0
     if(did_read_biodata.and.do_biogeography) then
        call update_species(cohort,t_ann(i,j),t_cold(i,j),p_ann(i,j),ncm(i,j),LU_NTRL)
     else
        cohort%species = tile%vegn%tag
     endif
  enddo
  
  call get_input_restart_name('INPUT/soil_carbon.res.nc',restart_1_exists,restart_file_name_1)
  if (restart_1_exists) then
     __NF_ASRT__(nf_open(restart_file_name_1,NF_NOWRITE,unit))
     call error_mesg('veg_data_init','reading soil_carbon restart',NOTE)
     call read_tile_data_r0d_fptr(unit,'asoil_in',vegn_asoil_in_ptr)
     call read_tile_data_r0d_fptr(unit,'fsc_in',vegn_fsc_in_ptr)
     call read_tile_data_r0d_fptr(unit,'ssc_in',vegn_ssc_in_ptr)
     __NF_ASRT__(nf_close(unit))     
  endif
  
  ! initialize carbon integrator
  call vegn_dynamics_init ( id_lon, id_lat, lnd%time, delta_time )

  ! initialize static vegetation
  call static_vegn_init ()
  call read_static_vegn ( lnd%time )

  ! initialize harvesting options
  call vegn_harvesting_init()

  ! initialize vegetation diagnostic fields
  call vegn_diag_init ( id_lon, id_lat, id_band, lnd%time )

  ! ---- diagnostic section
  ce = first_elmt(lnd%tile_map, is=lnd%is, js=lnd%js)
  te  = tail_elmt(lnd%tile_map)
  do while(ce /= te)
     tile => current_tile(ce)
     ce=next_elmt(ce)     
     if (.not.associated(tile%vegn)) cycle ! skip non-vegetation tiles
     ! send the data
     call send_tile_data(id_vegn_type,  real(tile%vegn%tag), tile%diag)
  enddo

  if (allocated(t_ann))  deallocate(t_ann)
  if (allocated(t_cold)) deallocate(t_cold)
  if (allocated(p_ann))  deallocate(p_ann)
  if (allocated(ncm))    deallocate(ncm)

end subroutine vegn_init

! ============================================================================
subroutine vegn_diag_init ( id_lon, id_lat, id_band, time )
  integer        , intent(in) :: id_lon  ! ID of land longitude (X) axis  
  integer        , intent(in) :: id_lat  ! ID of land latitude (Y) axis
  integer        , intent(in) :: id_band ! ID of spectral band axis
  type(time_type), intent(in) :: time    ! initial time for diagnostic fields
  
  ! ---- local vars
  integer :: i

  id_vegn_type = register_tiled_static_field ( module_name, 'vegn_type',  &
       (/id_lon,id_lat/), 'vegetation type', missing_value=-1.0 )

  id_temp = register_tiled_diag_field ( module_name, 'temp',  &
       (/id_lon,id_lat/), time, 'canopy temperature', 'degK', missing_value=-1.0 )
  id_wl = register_tiled_diag_field ( module_name, 'wl',  &
       (/id_lon,id_lat/), time, 'canopy liquid water content', 'kg/m2', missing_value=-1.0 )
  id_ws = register_tiled_diag_field ( module_name, 'ws',  &
       (/id_lon,id_lat/), time, 'canopy solid water content', 'kg/m2', missing_value=-1.0 )

  id_height = register_tiled_diag_field ( module_name, 'height',  &
       (/id_lon,id_lat/), time, 'vegetation height', 'm', missing_value=-1.0 )
  id_lai    = register_tiled_diag_field ( module_name, 'lai',  &
       (/id_lon,id_lat/), time, 'leaf area index', 'm2/m2', missing_value=-1.0 )
  id_sai    = register_tiled_diag_field ( module_name, 'sai',  &
       (/id_lon,id_lat/), time, 'stem area index', 'm2/m2', missing_value=-1.0 )
  id_leaf_size = register_tiled_diag_field ( module_name, 'leaf_size',  &
       (/id_lon,id_lat/), time, missing_value=-1.0 )
  id_root_density = register_tiled_diag_field ( module_name, 'root_density',  &
       (/id_lon,id_lat/), time, 'total biomass below ground', 'kg/m2', missing_value=-1.0 )
  id_root_zeta = register_tiled_diag_field ( module_name, 'root_zeta',  &
       (/id_lon,id_lat/), time, 'e-folding depth of root biomass', 'm',missing_value=-1.0 )
  id_rs_min = register_tiled_diag_field ( module_name, 'rs_min',  &
       (/id_lon,id_lat/), time, missing_value=-1.0 )
  id_leaf_refl = register_tiled_diag_field ( module_name, 'leaf_refl',  &
       (/id_lon,id_lat,id_band/), time, 'reflectivity of leaf', missing_value=-1.0 )
  id_leaf_tran = register_tiled_diag_field ( module_name, 'leaf_tran',  &
       (/id_lon,id_lat,id_band/), time, 'transmittance of leaf', missing_value=-1.0 )
  id_leaf_emis = register_tiled_diag_field ( module_name, 'leaf_emis',  &
       (/id_lon,id_lat/), time, 'leaf emissivity', missing_value=-1.0 )
  id_snow_crit = register_tiled_diag_field ( module_name, 'snow_crit',  &
       (/id_lon,id_lat/), time, missing_value=-1.0 )
  id_stomatal = register_tiled_diag_field ( module_name, 'stomatal_cond',  &
       (/id_lon,id_lat/), time, 'vegetation stomatal conductance', missing_value=-1.0 )
  id_an_op = register_tiled_diag_field ( module_name, 'an_op',  &
       (/id_lon,id_lat/), time, 'net photosynthesis with open stomata', &
       '(mol CO2)(m2 of leaf)^-1 year^-1', missing_value=-1e20 )
  id_an_cl = register_tiled_diag_field ( module_name, 'an_cl',  &
       (/id_lon,id_lat/), time, 'net photosynthesis with closed stomata', &
       '(mol CO2)(m2 of leaf)^-1 year^-1', missing_value=-1e20 )

  id_bl = register_tiled_diag_field ( module_name, 'bl',  &
       (/id_lon,id_lat/), time, 'biomass of leaves', 'kg C/m2', missing_value=-1.0 )
  id_blv = register_tiled_diag_field ( module_name, 'blv',  &
       (/id_lon,id_lat/), time, 'biomass in labile store', 'kg C/m2', missing_value=-1.0 )
  id_br = register_tiled_diag_field ( module_name, 'br',  &
       (/id_lon,id_lat/), time, 'biomass of fine roots', 'kg C/m2', missing_value=-1.0 )
  id_bsw = register_tiled_diag_field ( module_name, 'bsw',  &
       (/id_lon,id_lat/), time, 'biomass of sapwood', 'kg C/m2', missing_value=-1.0 )
  id_bwood = register_tiled_diag_field ( module_name, 'bwood',  &
       (/id_lon,id_lat/), time, 'biomass of heartwood', 'kg C/m2', missing_value=-1.0 )
  id_fuel = register_tiled_diag_field ( module_name, 'fuel',  &
       (/id_lon,id_lat/), time, 'mass of fuel', 'kg C/m2', missing_value=-1.0 )
  id_lambda = register_tiled_diag_field (module_name, 'lambda',(/id_lon,id_lat/), &
       time, 'drought', 'months', missing_value=-100.0)

  id_species = register_tiled_diag_field ( module_name, 'species',  &
       (/id_lon,id_lat/), time, 'vegetation species number', missing_value=-1.0 )
  id_status = register_tiled_diag_field ( module_name, 'status',  &
       (/id_lon,id_lat/), time, 'status of leaves', missing_value=-1.0 )
 id_leaf_age = register_tiled_diag_field ( module_name, 'leaf_age',  &
       (/id_lon,id_lat/), time, 'age of leaves since bud burst', 'days', missing_value=-1.0 )!ens

  id_con_v_h = register_tiled_diag_field ( module_name, 'con_v_h', (/id_lon,id_lat/), &
       time, 'conductance for sensible heat between canopy and canopy air', &
       'm/s', missing_value=-1.0 )
  id_con_v_v = register_tiled_diag_field ( module_name, 'con_v_v', (/id_lon,id_lat/), &
       time, 'conductance for water vapor between canopy and canopy air', &
       'm/s', missing_value=-1.0 )

  id_cgain = register_tiled_diag_field ( module_name, 'cgain', (/id_lon,id_lat/), &
       time, 'carbon gain', 'kg C', missing_value=-100.0 )
  id_closs = register_tiled_diag_field ( module_name, 'closs', (/id_lon,id_lat/), &
       time, 'carbon loss', 'kg C', missing_value=-100.0 )
  id_wdgain = register_tiled_diag_field ( module_name, 'wdgain', (/id_lon,id_lat/), &
       time, 'wood biomass gain', 'kg C', missing_value=-100.0 )

  id_t_ann  = register_tiled_diag_field ( module_name, 't_ann', (/id_lon,id_lat/), &
       time, 'annual mean temperature', 'degK', missing_value=-999.0 )
  id_t_cold  = register_tiled_diag_field ( module_name, 't_cold', (/id_lon,id_lat/), &
       time, 'average temperature of the coldest month', 'degK', missing_value=-999.0 )
  id_p_ann  = register_tiled_diag_field ( module_name, 'p_ann', (/id_lon,id_lat/), &
       time, 'annual mean precipitation', 'kg/(m2 s)', missing_value=-999.0 )
  id_ncm = register_tiled_diag_field ( module_name, 'ncm', (/id_lon,id_lat/), &
       time, 'number of cold months', 'dimensionless', missing_value=-999.0 )

  id_t_harv_pool = register_tiled_diag_field( module_name, 'harv_pool', (/id_lon,id_lat/), &
       time, 'total harvested carbon', 'kg C/m2', missing_value=-999.0)
  id_t_harv_rate = register_tiled_diag_field( module_name, 'harv_rate', (/id_lon,id_lat/), &
       time, 'total rate of release of harvested carbon to the atmosphere', &
       'kg C/(m2 year)', missing_value=-999.0)
  do i = 1,N_HARV_POOLS
     id_harv_pool(i) = register_tiled_diag_field( module_name, &
          trim(HARV_POOL_NAMES(i))//'_harv_pool', (/id_lon,id_lat/), time, &
          'harvested carbon', 'kg C/m2', missing_value=-999.0)
     id_harv_rate(i) = register_tiled_diag_field( module_name, &
          trim(HARV_POOL_NAMES(i))//'_harv_rate', (/id_lon,id_lat/), time, &
          'rate of release of harvested carbon to the atmosphere', 'kg C/(m2 year)', &
          missing_value=-999.0)
  enddo

  id_fsc_pool = register_tiled_diag_field (module_name, 'fsc_pool', (/id_lon, id_lat/), &
       time, 'intermediate pool of fast soil carbon', 'kg C/m2', missing_value=-999.0)
  id_fsc_rate = register_tiled_diag_field (module_name, 'fsc_rate', (/id_lon, id_lat/), &
       time, 'rate of conversion of fsc_pool to the fast soil_carbon', 'kg C/(m2 yr)', &
       missing_value=-999.0)
  id_ssc_pool = register_tiled_diag_field (module_name, 'ssc_pool', (/id_lon, id_lat/), &
       time, 'intermediate pool of slow soil carbon', 'kg C/m2', missing_value=-999.0)
  id_ssc_rate = register_tiled_diag_field (module_name, 'ssc_rate', (/id_lon, id_lat/), &
       time, 'rate of conversion of ssc_pool to the fast soil_carbon', 'kg C/(m2 yr)', &
       missing_value=-999.0)

  id_csmoke_pool = register_tiled_diag_field ( module_name, 'csmoke', (/id_lon, id_lat/), &
       time, 'carbon lost through fire', 'kg C/m2', missing_value=-999.0)
  id_csmoke_rate = register_tiled_diag_field ( module_name, 'csmoke_rate', (/id_lon, id_lat/), &
       time, 'rate of release of carbon lost through fire to the atmosphere', &
       'kg C/(m2 yr)', missing_value=-999.0)

  id_ssc_in = register_tiled_diag_field ( module_name, 'ssc_in',  (/id_lon, id_lat/), &
     time,  'soil slow carbon in', 'kg C/m2', missing_value=-999.0 )
  id_ssc_out = register_tiled_diag_field ( module_name, 'ssc_out',  (/id_lon, id_lat/), &
     time,  'soil slow carbon out', 'kg C/m2', missing_value=-999.0 )
  id_fsc_in = register_tiled_diag_field ( module_name, 'fsc_in',  (/id_lon, id_lat/), &
     time,  'soil fast carbon in', 'kg C/m2', missing_value=-999.0 )
  id_fsc_out = register_tiled_diag_field ( module_name, 'fsc_out',  (/id_lon, id_lat/), &
     time,  'soil fast carbon out', 'kg C/m2', missing_value=-999.0 )
  id_veg_in = register_tiled_diag_field ( module_name, 'veg_in',  (/id_lon, id_lat/), &
     time,  'vegetation carbon in', 'kg C/m2', missing_value=-999.0 )
  id_veg_out = register_tiled_diag_field ( module_name, 'veg_out',  (/id_lon, id_lat/), &
     time,  'vegetation carbon out', 'kg C/m2', missing_value=-999.0 )

  id_afire = register_tiled_diag_field (module_name, 'afire', (/id_lon,id_lat/), &
       time, 'area been fired', missing_value=-100.0)
  id_atfall = register_tiled_diag_field (module_name, 'atfall',(/id_lon,id_lat/), &
       time, 'area been disturbed', missing_value=-100.0)

  id_phot_co2 = register_tiled_diag_field (module_name, 'qco2_phot',(/id_lon,id_lat/), &
       time, 'CO2 mixing ratio for photosynthesis calculations', 'mol CO2/mol dry air', &
       missing_value=-1.0)
end subroutine


! ============================================================================
! write restart file and release memory
subroutine vegn_end ()

  module_is_initialized =.FALSE.

  ! finalize harvesting
  call vegn_harvesting_end ()

  ! finalize static vegetation, if necessary
  call static_vegn_end ()
end subroutine vegn_end


! ============================================================================
subroutine save_vegn_restart(tile_dim_length,timestamp)
  integer, intent(in) :: tile_dim_length ! length of tile dim. in the output file
  character(*), intent(in) :: timestamp ! timestamp to add to the file name

  ! ---- local vars ----------------------------------------------------------
  integer :: unit ! restart file unit 
  integer :: ierr, i
  type(land_tile_enum_type) :: ce, te
  type(land_tile_type), pointer :: tile
  integer :: n_accum, nmn_acm

  call error_mesg('vegn_end','writing NetCDF restart',NOTE)
  ! create output file, including internal structure necessary for tile output
  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'vegn1.res.nc', &
          lnd%coord_glon, lnd%coord_glat, vegn_tile_exists, tile_dim_length)
  ! create compressed dimension for vegetation cohorts -- must be called even
  ! if restart has not been created, because it calls mpp_max and that should 
  ! be called on all PEs to work
  call create_cohort_dimension(unit)

  call write_cohort_data_r0d_fptr(unit,'tv',cohort_tv_ptr,'vegetation temperature','degrees_K')
  call write_cohort_data_r0d_fptr(unit,'wl',cohort_wl_ptr,'vegetation liquid water content','kg/m2')
  call write_cohort_data_r0d_fptr(unit,'ws',cohort_ws_ptr,'vegetation solid water content','kg/m2')
  ! close output file
  __NF_ASRT__(nf_close(unit))


  call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'vegn2.res.nc', &
          lnd%coord_glon, lnd%coord_glat, vegn_tile_exists, tile_dim_length )
  ! create compressed dimension for vegetation cohorts -- see note above
  call create_cohort_dimension(unit)

  ! store global variables
  ! find first tile and get n_accum and nmn_acm from it
  n_accum = 0; nmn_acm = 0
  ce = first_elmt(lnd%tile_map) ; te = tail_elmt(lnd%tile_map)
  do while ( ce /= te )
     tile => current_tile(ce) ; ce=next_elmt(ce)
     if(associated(tile%vegn)) then
        n_accum = tile%vegn%n_accum
        nmn_acm = tile%vegn%nmn_acm
     endif
  enddo
  ! n_accum and nmn_acm are currently the same for all tiles; we only call mpp_max
  ! to handle the situation when there are no tiles in the current domain
  call mpp_max(n_accum); call mpp_max(nmn_acm)
  
  if(mpp_pe()==lnd%io_pelist(1)) then
     ierr = nf_redef(unit)
     __NF_ASRT__(nfu_def_var(unit,'n_accum',NF_INT,long_name='number of accumulated steps'))
     __NF_ASRT__(nfu_def_var(unit,'nmn_acm',NF_INT,long_name='number of accumulated months'))
     ierr = nf_enddef(unit)
     __NF_ASRT__(nfu_put_var(unit,'n_accum',n_accum))
     __NF_ASRT__(nfu_put_var(unit,'nmn_acm',nmn_acm))
  end if
  
  call write_cohort_data_i0d_fptr(unit,'species', cohort_species_ptr, 'vegetation species')
  call write_cohort_data_r0d_fptr(unit,'hite', cohort_height_ptr, 'vegetation height','m')
  call write_cohort_data_r0d_fptr(unit,'bl', cohort_bl_ptr, 'biomass of leaves per individual','kg C/m2')
  call write_cohort_data_r0d_fptr(unit,'blv', cohort_blv_ptr, 'biomass of virtual leaves (labile store) per individual','kg C/m2')
  call write_cohort_data_r0d_fptr(unit,'br', cohort_br_ptr, 'biomass of fine roots per individual','kg C/m2')
  call write_cohort_data_r0d_fptr(unit,'bsw', cohort_bsw_ptr, 'biomass of sapwood per individual','kg C/m2')
  call write_cohort_data_r0d_fptr(unit,'bwood', cohort_bwood_ptr, 'biomass of heartwood per individual','kg C/m2')
  call write_cohort_data_r0d_fptr(unit,'bliving', cohort_bliving_ptr, 'total living biomass per individual','kg C/m2')
!     call write_cohort_data_r0d_fptr(unit,'tleaf', cohort_tleaf_ptr, 'leaf temperature','degK')
  call write_cohort_data_i0d_fptr(unit,'status', cohort_status_ptr, 'leaf status')
  call write_cohort_data_r0d_fptr(unit,'leaf_age',cohort_leaf_age_ptr, 'age of leaves since bud burst', 'days')

!     call write_cohort_data_r0d_fptr(unit,'intercept_l', cohort_cmc_ptr, 'intercepted water per cohort','kg/m2')
  call write_cohort_data_r0d_fptr(unit,'npp_prev_day', cohort_npp_previous_day_ptr, 'previous day NPP','kg C/(m2 year)')

  call write_tile_data_i0d_fptr(unit,'landuse',vegn_landuse_ptr,'vegetation land use type')
  call write_tile_data_r0d_fptr(unit,'age',vegn_age_ptr,'vegetation age', 'yr')
  call write_tile_data_r0d_fptr(unit,'fsc',vegn_fast_soil_C_ptr,'fast soil carbon', 'kg C/m2')
  call write_tile_data_r0d_fptr(unit,'ssc',vegn_slow_soil_C_ptr,'slow soil carbon', 'kg C/m2')
  call write_tile_data_r0d_fptr(unit,'fsc_pool',vegn_fsc_pool_ptr,'intermediate pool for fast soil carbon input', 'kg C/m2')
  call write_tile_data_r0d_fptr(unit,'fsc_rate',vegn_fsc_rate_ptr,'conversion rate of fsc_pool to fast soil carbon', 'kg C/(m2 yr)')
  call write_tile_data_r0d_fptr(unit,'ssc_pool',vegn_ssc_pool_ptr,'intermediate pool for slow soil carbon input', 'kg C/m2')
  call write_tile_data_r0d_fptr(unit,'ssc_rate',vegn_ssc_rate_ptr,'conversion rate of ssc_pool to slow soil carbon', 'kg C/(m2 yr)')

  ! monthly-mean values
  call write_tile_data_r0d_fptr(unit,'tc_av', vegn_tc_av_ptr,'average canopy air temperature','degK')
  call write_tile_data_r0d_fptr(unit,'theta_av', vegn_theta_av_ptr,'average soil moisture')
  call write_tile_data_r0d_fptr(unit,'tsoil_av', vegn_tsoil_av_ptr,'average bulk soil temperature for soil carbon','degK')
  call write_tile_data_r0d_fptr(unit,'precip_av', vegn_precip_av_ptr,'average total precipitation','kg/(m2 s)')
  call write_tile_data_r0d_fptr(unit,'lambda', vegn_lambda_ptr,'dryness parameter')
  call write_tile_data_r0d_fptr(unit,'fuel', vegn_fuel_ptr,'fuel density','kg C/m2')
  ! annual-mean values
  call write_tile_data_r0d_fptr(unit,'t_ann', vegn_t_ann_ptr,'average annual canopy air temperature','degK')
  call write_tile_data_r0d_fptr(unit,'t_cold', vegn_t_cold_ptr,'average canopy air temperature of coldest month','degK')
  call write_tile_data_r0d_fptr(unit,'p_ann', vegn_p_ann_ptr,'average annual precipitation','kg/(m2 s)')
  call write_tile_data_r0d_fptr(unit,'ncm', vegn_ncm_ptr,'number of cold months')
  ! accumulated values for annual averaging
  call write_tile_data_r0d_fptr(unit,'t_ann_acm', vegn_t_ann_acm_ptr,'accumulated annual canopy air temperature','degK')
  call write_tile_data_r0d_fptr(unit,'t_cold_acm', vegn_t_cold_acm_ptr,'accumulated temperature of coldest month','degK')
  call write_tile_data_r0d_fptr(unit,'p_ann_acm', vegn_p_ann_acm_ptr,'accumulated precipitation','kg/(m2 s)')
  call write_tile_data_r0d_fptr(unit,'ncm_acm', vegn_ncm_acm_ptr,'accumulated number of cold months')

  ! burned carbon pool and rate
  call write_tile_data_r0d_fptr(unit,'csmoke_pool',vegn_csmoke_pool_ptr,'carbon lost through fires', 'kg C/m2')
  call write_tile_data_r0d_fptr(unit,'csmoke_rate',vegn_csmoke_rate_ptr,'rate of release of carbon lost through fires to the atmosphere', 'kg C/(m2 yr)')

  ! harvesting pools and rates
  do i = 1, N_HARV_POOLS
     call write_tile_data_r1d_fptr(unit, trim(HARV_POOL_NAMES(i))//'_harv_pool', &
          vegn_harv_pool_ptr, i, 'harvested carbon','kg C/m2')
     call write_tile_data_r1d_fptr(unit, trim(HARV_POOL_NAMES(i))//'_harv_rate', &
          vegn_harv_rate_ptr, i, 'rate of release of harvested carbon to the atmosphere','kg C/(m2 yr)')
  enddo
     

  __NF_ASRT__(nf_close(unit))

  if (write_soil_carbon_restart) then
     call create_tile_out_file(unit,'RESTART/'//trim(timestamp)//'soil_carbon.res.nc', &
          lnd%coord_glon, lnd%coord_glat, vegn_tile_exists, tile_dim_length )

     call write_tile_data_r0d_fptr(unit,'asoil_in',vegn_asoil_in_ptr,'aerobic activity modifier', 'unitless')
     call write_tile_data_r0d_fptr(unit,'fsc_in',vegn_fsc_in_ptr,'fast soil carbon input', 'kg C/m2')
     call write_tile_data_r0d_fptr(unit,'ssc_in',vegn_ssc_in_ptr,'slow soil carbon input', 'kg C/m2')
     __NF_ASRT__(nf_close(unit))
  endif

end subroutine save_vegn_restart


! ============================================================================
subroutine vegn_get_cover(vegn, snow_depth, vegn_cover)
  type(vegn_tile_type), intent(inout)  :: vegn ! it is only inout because vegn%data%cover
                                    ! changes cohort; can it be avoided?
  real,                 intent(in)  :: snow_depth
  real,                 intent(out) :: vegn_cover

  real :: vegn_cover_snow_factor

  call vegn_data_cover(vegn%cohorts(1), snow_depth, vegn_cover, vegn_cover_snow_factor)
  
end subroutine vegn_get_cover


! ============================================================================
subroutine vegn_diffusion ( vegn, vegn_cover, vegn_height, vegn_lai, vegn_sai, vegn_d_leaf)
  type(vegn_tile_type), intent(in) :: vegn
  real,                intent(out) :: &
       vegn_cover, vegn_height, vegn_lai, vegn_sai, vegn_d_leaf
  
  vegn_cover  = vegn%cohorts(1)%cover
  vegn_lai    = vegn%cohorts(1)%lai
  vegn_sai    = vegn%cohorts(1)%sai
  vegn_height = vegn%cohorts(1)%height
  vegn_d_leaf = vegn%cohorts(1)%leaf_size

end subroutine vegn_diffusion


! ============================================================================
subroutine vegn_step_1 ( vegn, diag, &
        p_surf, ustar, drag_q, &
        SWdn, RSv, precip_l, precip_s, &
        land_d, land_z0s, land_z0m, grnd_z0s, &
        soil_beta, soil_water_supply, &
        cana_T, cana_q, cana_co2_mol, &
        ! output
        con_g_h, con_g_v, & ! aerodynamic conductance between canopy air and canopy, for heat and vapor flux
        vegn_T,vegn_Wl,  vegn_Ws,           & ! temperature, water and snow mass of the canopy
        vegn_ifrac,                         & ! intercepted fraction of liquid and frozen precipitation
        vegn_lai,                           & ! leaf area index
        drip_l, drip_s,                     & ! water and snow drip rate from precipitation, kg/(m2 s)
        vegn_hcap,                          & ! vegetation heat capacity
        Hv0,   DHvDTv,   DHvDTc,            & ! sens heat flux
        Et0,   DEtDTv,   DEtDqc,   DEtDwl,   DEtDwf,  & ! transpiration
        Eli0,  DEliDTv,  DEliDqc,  DEliDwl,  DEliDwf, & ! evaporation of intercepted water
        Efi0,  DEfiDTv,  DEfiDqc,  DEfiDwl,  DEfiDwf  ) ! sublimation of intercepted snow
  type(vegn_tile_type), intent(inout) :: vegn ! vegetation data
  type(diag_buff_type), intent(inout) :: diag ! diagnostic buffer
  real, intent(in) :: &
       p_surf,    & ! surface pressure, N/m2
       ustar,     & ! friction velocity, m/s
       drag_q,    & ! bulk drag coefficient for specific humidity
       SWdn(NBANDS), & ! downward SW radiation at the top of the canopy, W/m2
       RSv (NBANDS), & ! net SW radiation balance of the canopy, W/m2
       precip_l, precip_s, & ! liquid and solid precipitation rates, kg/(m2 s)
       land_d, land_z0s, land_z0m, & ! land displacement height and roughness, m
       grnd_z0s, & ! roughness of ground surface (including snow effect)
       soil_beta, & ! relative water availability
       soil_water_supply, & ! max rate of water supply to the roots, kg/(m2 s)
       cana_T,    & ! temperature of canopy air, deg K
       cana_q,    & ! specific humidity of canopy air, kg/kg
       cana_co2_mol ! co2 mixing ratio in the canopy air, mol CO2/mol dry air
  ! output -- coefficients of linearized expressions for fluxes
  real, intent(out) ::   &
       vegn_T,vegn_Wl,  vegn_Ws,& ! temperature, water and snow mass of the canopy
       vegn_ifrac, & ! intercepted fraction of liquid and frozen precipitation
       vegn_lai, & ! vegetation leaf area index
       drip_l, drip_s, & ! water and snow drip rate from precipitation, kg/(m2 s)
       vegn_hcap, & ! total vegetation heat capacity, including intercepted water and snow
       con_g_h, con_g_v, & ! aerodynamic conductance between ground and canopy air
       Hv0,   DHvDTv,   DHvDTc, & ! sens heat flux
       Et0,   DEtDTv,   DEtDqc,   DEtDwl,   DEtDwf,  & ! transpiration
       Eli0,  DEliDTv,  DEliDqc,  DEliDwl,  DEliDwf, & ! evaporation of intercepted water
       Efi0,  DEfiDTv,  DEfiDqc,  DEfiDwl,  DEfiDwf    ! sublimation of intercepted snow
  
  ! ---- local vars 
  real :: &
       ft,DftDwl,DftDwf, & ! fraction of canopy not covered by intercepted water/snow, and its' 
                    ! derivatives w.r.t. intercepted water masses 
       fw,DfwDwl,DfwDwf, & ! fraction of canopy covered by intercepted water, and its' 
                    ! derivatives w.r.t. intercepted water masses 
       fs,DfsDwl,DfsDwf, & ! fraction of canopy covered by intercepted snow, and its' 
                    ! derivatives w.r.t. intercepted water masses
       stomatal_cond, & ! integral stomatal conductance of canopy
       con_v_h, con_v_v, & ! aerodyn. conductance between canopy and CAS, for heat and vapor
       total_cond, &! overall conductance from inside stomata to canopy air 
       qvsat,     & ! sat. specific humidity at the leaf T
       DqvsatDTv, & ! derivative of qvsat w.r.t. leaf T
       rho,       & ! density of canopy air
       phot_co2,  & ! co2 mixing ratio for photosynthesis, mol CO2/mol dry air
       photosynt, & ! photosynthesis
       photoresp    ! photo-respiration
  type(vegn_cohort_type), pointer :: cohort
  
  ! get the pointer to the first (and, currently, the only) cohort
  cohort => vegn%cohorts(1)

  if(is_watch_point()) then
     write(*,*)'#### vegn_step_1 input ####'
     __DEBUG3__(p_surf, ustar, drag_q)
     __DEBUG1__(SWdn)
     __DEBUG1__(RSv) 
     __DEBUG2__(precip_l, precip_s)
     __DEBUG4__(land_d, land_z0s, land_z0m, grnd_z0s)
     __DEBUG2__(soil_beta, soil_water_supply)
     __DEBUG3__(cana_T, cana_q, cana_co2_mol)
     write(*,*)'#### end of vegn_step_1 input ####'
     __DEBUG3__(cohort%height, cohort%lai, cohort%sai)
     __DEBUG2__(cohort%cover,cohort%leaf_size)
     __DEBUG1__(cohort%prog%Tv)
  endif

  ! check the range of input temperature
  call check_temp_range(cohort%prog%Tv,'vegn_step_1','cohort%prog%Tv') 

  ! calculate the fractions of intercepted precipitation
  vegn_ifrac = cohort%cover

  ! get the lai
  vegn_lai = cohort%lai

  ! calculate the aerodynamic conductance coefficients
  call cana_turbulence(ustar, &
     cohort%cover, cohort%height, cohort%lai, cohort%sai, cohort%leaf_size, &
     land_d, land_z0m, land_z0s, grnd_z0s, &
     con_v_h, con_v_v, con_g_h, con_g_v)

  ! calculate the vegetation photosynthesis and associated stomatal conductance
  if (vegn_phot_co2_option == VEGN_PHOT_CO2_INTERACTIVE) then
     phot_co2 = cana_co2_mol
  else 
     phot_co2 = co2_for_photosynthesis
  endif
  call vegn_photosynthesis ( vegn, &
     SWdn(BAND_VIS), RSv(BAND_VIS), cana_q, phot_co2, p_surf, drag_q, &
     soil_beta, soil_water_supply, &
     stomatal_cond, photosynt, photoresp )

  call get_vegn_wet_frac ( cohort, fw, DfwDwl, DfwDwf, fs, DfsDwl, DfsDwf )
  ! transpiring fraction and its derivatives
  ft     = 1 - fw - fs
  DftDwl = - DfwDwl - DfsDwl
  DftDwf = - DfwDwf - DfsDwf
  call qscomp(cohort%prog%Tv, p_surf, qvsat, DqvsatDTv)

  rho = p_surf/(rdgas*cana_T *(1+d608*cana_q))
  
  ! get the vegetation temperature
  vegn_T  =  cohort%prog%Tv
  ! get the amount of intercepted water and snow
  vegn_Wl =  cohort%prog%Wl
  vegn_Ws =  cohort%prog%Ws
  ! calculate the drip rates
  drip_l  = max(vegn_Wl,0.0)/tau_drip_l
  drip_s  = max(vegn_Ws,0.0)/tau_drip_s
  ! correct the drip rates so that the amount of water and snow accumulated over time step 
  ! is no larger then the canopy water-holding capacity
  drip_l = max((vegn_Wl+precip_l*delta_time*vegn_ifrac-cohort%Wl_max)/delta_time,drip_l)
  drip_s = max((vegn_Ws+precip_s*delta_time*vegn_ifrac-cohort%Ws_max)/delta_time,drip_s)

  ! calculate the total heat capacity
  call vegn_data_heat_capacity (cohort, vegn_hcap)
  vegn_hcap = vegn_hcap + clw*cohort%prog%Wl + csw*cohort%prog%Ws
  ! calculate the coefficient of sensible heat flux linearization
  Hv0     =  2*rho*cp_air*con_v_h*(cohort%prog%Tv - cana_T)
  DHvDTv  =  2*rho*cp_air*con_v_h
  DHvDTc  = -2*rho*cp_air*con_v_h
  ! calculate the coefficients of the transpiration linearization
  if(con_v_v==0.and.stomatal_cond==0) then
     total_cond = 0.0
  else
     total_cond = stomatal_cond*con_v_v/(stomatal_cond+con_v_v)
  endif

  if(qvsat>cana_q)then
     ! flux is directed from the surface: transpiration is possible, and the
     ! evaporation of intercepted water depends on the fraction of wet/snow
     ! covered canopy.

     ! prohibit transpiration if leaf temperature below some predefined minimum
     ! typically (268K, but check namelist)
     if(cohort%prog%Tv < T_transp_min) total_cond = 0 
     ! calculate the transpiration linearization coefficients
     Et0     =  rho*total_cond*ft*(qvsat - cana_q)
     DEtDTv  =  rho*total_cond*ft*DqvsatDTv
     DEtDqc  = -rho*total_cond*ft
     DEtDwl  =  rho*total_cond*DftDwl*(qvsat - cana_q)
     DEtDwf  =  rho*total_cond*DftDwf*(qvsat - cana_q)
     ! calculate the coefficients of the intercepted liquid evaporation linearization
     Eli0    =  rho*con_v_v*fw*(qvsat - cana_q)
     DEliDTv =  rho*con_v_v*fw*DqvsatDTv
     DEliDqc = -rho*con_v_v*fw
     DEliDwl =  rho*con_v_v*DfwDwl*(qvsat-cana_q)
     DEliDwf =  rho*con_v_v*DfwDwf*(qvsat-cana_q)
     ! calculate the coefficients of the intercepted snow evaporation linearization
     Efi0    =  rho*con_v_v*fs*(qvsat - cana_q)
     DEfiDTv =  rho*con_v_v*fs*DqvsatDTv
     DEfiDqc = -rho*con_v_v*fs
     DEfiDwl =  rho*con_v_v*DfsDwl*(qvsat-cana_q)
     DEfiDwf =  rho*con_v_v*DfsDwf*(qvsat-cana_q)
  else
     ! Flux is directed TOWARD the surface: no transpiration (assuming plants do not
     ! take water through stomata), and condensation does not depend on the fraction
     ! of wet canopy -- dew formation occurs on the entire surface

     ! prohibit transpiration:
     Et0     = 0
     DEtDTv  = 0; DEtDwl = 0; DEtDwf = 0;
     DEtDqc  = 0
     ! calculate dew or frost formation rates, depending on the temperature
     Eli0    = 0; Efi0    = 0
     DEliDTv = 0; DEfiDTv = 0
     DEliDqc = 0; DEfiDqc = 0
     DEliDwl = 0; DEfiDwl = 0
     DEliDwf = 0; DEfiDwf = 0
     ! calculate the coefficients of the intercepted liquid condensation linearization
     if(vegn_T >= tfreeze) then
        Eli0    =  rho*con_v_v*(qvsat - cana_q)
        DEliDTv =  rho*con_v_v*DqvsatDTv
        DEliDqc = -rho*con_v_v
     else
        ! calculate the coefficients of the intercepted snow condensation linearization
        Efi0    =  rho*con_v_v*(qvsat - cana_q)
        DEfiDTv =  rho*con_v_v*DqvsatDTv
        DEfiDqc = -rho*con_v_v
     endif
     ! prohibit switching from condensation to evaporation if the water content
     ! is below certain threshold
     if (vegn_Wl < min_Wl) then
        Eli0 = 0 ; DEliDTv = 0 ; DEliDqc = 0 ; DEliDwl = 0 ; DEliDwf = 0
     endif
     if (vegn_Ws < min_Ws) then
        Efi0 = 0 ; DEfiDTv = 0 ; DEfiDqc = 0 ; DEfiDwl = 0 ; DEfiDwf = 0
     endif
        
  endif
  ! ---- diagnostic section
  call send_tile_data(id_stomatal, stomatal_cond, diag)
  call send_tile_data(id_an_op, cohort%An_op, diag)
  call send_tile_data(id_an_cl, cohort%An_cl, diag)
  call send_tile_data(id_con_v_h, con_v_h, diag)
  call send_tile_data(id_con_v_v, con_v_v, diag)
  call send_tile_data(id_phot_co2, phot_co2, diag)

end subroutine vegn_step_1


! ============================================================================
! Given the surface solution, substitute it back into the vegetation equations 
! to determine new vegetation state.
subroutine vegn_step_2 ( vegn, diag, &
     delta_Tv, delta_wl, delta_wf, &
     vegn_melt, &
     vegn_ovfl_l,  vegn_ovfl_s,  & ! overflow of liquid and solid water from the canopy, kg/(m2 s)
     vegn_ovfl_Hl, vegn_ovfl_Hs  ) ! heat flux carried from canopy by overflow, W/(m2 s)

  ! ---- arguments 
  type(vegn_tile_type) , intent(inout) :: vegn
  type(diag_buff_type) , intent(inout) :: diag
  real, intent(in) :: &
       delta_Tv, & ! change in vegetation temperature, degK
       delta_wl, & ! change in intercepted liquid water mass, kg/m2
       delta_wf    ! change in intercepted frozen water mass, kg/m2 
  real, intent(out) :: &
       vegn_melt, &
       vegn_ovfl_l,   vegn_ovfl_s,   & ! overflow of liquid and solid water from the canopy
       vegn_ovfl_Hl, vegn_ovfl_Hs      ! heat flux from canopy due to overflow

  ! ---- local variables
  real :: &
     vegn_Wl_max, &  ! max. possible amount of liquid water in the canopy
     vegn_Ws_max, &  ! max. possible amount of solid water in the canopy
     mcv, &
     cap0, melt_per_deg, &
     Wl, Ws  ! positively defined amounts of water and snow on canopy
  type(vegn_cohort_type), pointer :: cohort
  
  ! get the pointer to the first (and, currently, the only) cohort
  cohort => vegn%cohorts(1)

  if (is_watch_point()) then
     write(*,*)'#### vegn_step_2 input ####'
     __DEBUG3__(delta_Tv, delta_wl, delta_wf)
     __DEBUG1__(cohort%prog%Tv)
  endif

  ! update vegetation state
  cohort%prog%Tv = cohort%prog%Tv + delta_Tv
  cohort%prog%Wl = cohort%prog%Wl + delta_wl
  cohort%prog%Ws = cohort%prog%Ws + delta_wf 

  call vegn_data_intrcptn_cap(cohort, vegn_Wl_max, vegn_Ws_max)
  call vegn_data_heat_capacity(cohort, mcv)


  ! ---- update for evaporation and interception -----------------------------
  cap0 = mcv + clw*cohort%prog%Wl + csw*cohort%prog%Ws

  if(is_watch_point()) then
     write (*,*)'#### vegn_step_2 #### 1'
     __DEBUG1__(cap0)
     __DEBUG1__(cohort%prog%Tv)
     __DEBUG2__(cohort%prog%Wl, cohort%prog%Ws)
  endif
  ! melt on the vegetation should probably be prohibited altogether, since
  ! the amount of melt or freeze calculated this way is severely underestimated 
  ! (depending on the overall vegetation heat capacity) which leads to extended 
  ! periods when the canopy temperature is fixed at freezing point.
  if (lm2) then 
     vegn_melt = 0
  else
     ! ---- freeze/melt of intercepted water
     ! heat capacity of leaf + intercepted water/snow _can_ go below zero if the 
     ! total water content goes below zero as a result of implicit time step.
     ! If it does, we just prohibit melt, setting it to zero.
     if(cap0 > 0)then
        melt_per_deg = cap0 / hlf
        if (cohort%prog%Ws>0 .and. cohort%prog%Tv>tfreeze) then
           vegn_melt =  min(cohort%prog%Ws, (cohort%prog%Tv-tfreeze)*melt_per_deg)
        else if (cohort%prog%Wl>0 .and. cohort%prog%Tv<tfreeze) then
           vegn_melt = -min(cohort%prog%Wl, (tfreeze-cohort%prog%Tv)*melt_per_deg)
        else
           vegn_melt = 0
        endif
        cohort%prog%Ws = cohort%prog%Ws - vegn_melt
        cohort%prog%Wl = cohort%prog%Wl + vegn_melt
        if (vegn_melt/=0) &
             cohort%prog%Tv = tfreeze + (cap0*(cohort%prog%Tv-tfreeze) - hlf*vegn_melt) &
             / ( cap0 + (clw-csw)*vegn_melt )
        vegn_melt = vegn_melt / delta_time
     else
        vegn_melt = 0
     endif
  endif

  if(is_watch_point()) then
     write (*,*)'#### vegn_step_2 #### 1'
     __DEBUG1__(cap0)
     __DEBUG1__(cohort%prog%Tv)
     __DEBUG3__(vegn_melt, cohort%prog%Wl, cohort%prog%Ws)
  endif

  ! ---- update for overflow -------------------------------------------------
  Wl = max(cohort%prog%Wl,0.0); Ws = max(cohort%prog%Ws,0.0)
  vegn_ovfl_l = max (0.,Wl-vegn_Wl_max)/delta_time
  vegn_ovfl_s = max (0.,Ws-vegn_Ws_max)/delta_time
  vegn_ovfl_Hl = clw*vegn_ovfl_l*(cohort%prog%Tv-tfreeze)
  vegn_ovfl_Hs = csw*vegn_ovfl_s*(cohort%prog%Tv-tfreeze)

  cohort%prog%Wl = cohort%prog%Wl - vegn_ovfl_l*delta_time
  cohort%prog%Ws = cohort%prog%Ws - vegn_ovfl_s*delta_time

  if(is_watch_point()) then
     write(*,*)'#### vegn_step_2 output #####'
     __DEBUG3__(vegn_melt, vegn_ovfl_l, vegn_ovfl_s)
     __DEBUG2__(vegn_ovfl_Hl,vegn_ovfl_Hs)
  endif

  ! ---- diagnostic section
  call send_tile_data(id_temp,   cohort%prog%Tv, diag)
  call send_tile_data(id_wl,     cohort%prog%Wl, diag)
  call send_tile_data(id_ws,     cohort%prog%Ws, diag)

  call send_tile_data(id_height, cohort%height, diag)
  call send_tile_data(id_lai, cohort%lai, diag)
  call send_tile_data(id_sai, cohort%sai, diag)
  call send_tile_data(id_leaf_size, cohort%leaf_size, diag)
  call send_tile_data(id_root_density, cohort%root_density, diag)
  call send_tile_data(id_root_zeta, cohort%root_zeta, diag)
  call send_tile_data(id_rs_min, cohort%rs_min, diag)
  call send_tile_data(id_leaf_refl, cohort%leaf_refl, diag)
  call send_tile_data(id_leaf_tran, cohort%leaf_tran, diag)
  call send_tile_data(id_leaf_emis, cohort%leaf_emis, diag)
  call send_tile_data(id_snow_crit, cohort%snow_crit, diag)
  
end subroutine vegn_step_2


! ============================================================================
! do the vegetation calculations that require updated (end-of-timestep) values 
! of prognostic land variables
subroutine vegn_step_3(vegn, soil, cana_T, precip, vegn_fco2, diag)
  type(vegn_tile_type), intent(inout) :: vegn
  type(soil_tile_type), intent(in)    :: soil
  real, intent(in) :: cana_T ! canopy temperature, deg K
  real, intent(in) :: precip ! total (rain+snow) precipitation, kg/(m2 s)
  real, intent(out) :: vegn_fco2 ! co2 flux from vegetation, kg CO2/(m2 s)
  type(diag_buff_type), intent(inout) :: diag
  
  ! ---- local vars
  real :: tsoil ! average temperature of soil for soil carbon decomposition, deg K
  real :: theta ! average soil wetness, unitless
  real :: depth_ave! depth for averaging soil moisture based on Jackson function for root distribution  
  real :: percentile = 0.95

  tsoil = soil_ave_temp (soil,soil_carbon_depth_scale)
  ! depth for 95% of root according to Jackson distribution 
  depth_ave = -log(1.-percentile)*vegn%cohorts(1)%root_zeta

  theta = soil_ave_theta1(soil, depth_ave)

  if(is_watch_point()) then
     write(*,*)'#### vegn_step_3 drought input ####'
     __DEBUG3__(depth_ave, tsoil, theta)
  endif

  call vegn_carbon_int(vegn, tsoil, theta, diag)
  ! decrease, if necessary, csmoke spending rate so that csmoke pool
  ! is never depleted below zero
  vegn%csmoke_rate = max( 0.0, &
       min( vegn%csmoke_rate, &
            vegn%csmoke_pool/dt_fast_yr)&
       )
  ! update smoke pool -- stored amount of carbon lost to fire
  vegn%csmoke_pool = vegn%csmoke_pool - &
       vegn%csmoke_rate*dt_fast_yr
  ! decrease harvested rates so that pools are not depleted below zero  
  vegn%harv_rate(:) = max( 0.0, &
                           min(vegn%harv_rate(:), vegn%harv_pool(:)/dt_fast_yr) &
                         )
  ! update harvested pools -- amounts of stored harvested carbon by category
  vegn%harv_pool(:) = vegn%harv_pool(:) - &
       vegn%harv_rate(:)*dt_fast_yr
  ! --- calculate total co2 flux from vegetation
  vegn_fco2 = -vegn%nep + vegn%csmoke_rate + sum(vegn%harv_rate(:))
  ! --- convert it to kg CO2/(m2 s)
  vegn_fco2 = vegn_fco2*mol_CO2/(mol_C*seconds_per_year)

  ! --- accumulate values for climatological averages
  vegn%tc_av     = vegn%tc_av + cana_T
  vegn%tsoil_av  = vegn%tsoil_av + tsoil
  vegn%precip_av = vegn%precip_av + precip
  vegn%theta_av  = vegn%theta_av + soil_ave_theta1(soil,depth_ave)

  vegn%n_accum   = vegn%n_accum+1

end subroutine vegn_step_3


! ============================================================================
! update slow components of the vegetation model
subroutine update_vegn_slow( )

  ! ---- local vars ----------------------------------------------------------
  integer :: second, minute, hour, day0, day1, month0, month1, year0, year1
  type(land_tile_enum_type) :: ce, te
  type(land_tile_type), pointer :: tile
  integer :: i,j,k ! current point indices
  integer :: ii ! pool iterator
  integer :: n ! number of cohorts
  real    :: weight_ncm ! low-pass filter value for the number of cold months

  ! get components of calendar dates for this and previous time step
  call get_date(lnd%time,             year0,month0,day0,hour,minute,second)
  call get_date(lnd%time-lnd%dt_slow, year1,month1,day1,hour,minute,second)

  ce = first_elmt(lnd%tile_map, lnd%is, lnd%js) ; te = tail_elmt(lnd%tile_map)
  do while ( ce /= te )
     call get_elmt_indices(ce,i,j,k) ; call set_current_point(i,j,k) ! this is for debug output only
     tile => current_tile(ce) ; ce=next_elmt(ce)
     if(.not.associated(tile%vegn)) cycle ! skip the rest of the loop body

     if (day1 /= day0) then
        call vegn_daily_npp(tile%vegn)
     endif

     ! monthly averaging
     if (month1 /= month0) then
        ! compute averages from accumulated monthly values 
        tile%vegn%tc_av     = tile%vegn%tc_av     / tile%vegn%n_accum
        tile%vegn%tsoil_av  = tile%vegn%tsoil_av  / tile%vegn%n_accum
        tile%vegn%theta_av  = tile%vegn%theta_av  / tile%vegn%n_accum
        tile%vegn%precip_av = tile%vegn%precip_av / tile%vegn%n_accum
        ! accumulate annual values
        tile%vegn%p_ann_acm = tile%vegn%p_ann_acm+tile%vegn%precip_av
        tile%vegn%t_ann_acm = tile%vegn%t_ann_acm+tile%vegn%tc_av
        if ( tile%vegn%tc_av < cold_month_threshold ) & 
             tile%vegn%ncm_acm = tile%vegn%ncm_acm+1
        tile%vegn%t_cold_acm = min(tile%vegn%t_cold_acm, tile%vegn%tc_av)

        tile%vegn%nmn_acm = tile%vegn%nmn_acm+1 ! increase the number of accumulated months
     endif

     ! annual averaging
     if (year1 /= year0) then
         ! The ncm smoothing is coded as a low-pass exponential filter. See, for example
         ! http://en.wikipedia.org/wiki/Low-pass_filter
         weight_ncm = 1/(1+tau_smooth_ncm)
        if(tile%vegn%nmn_acm /= 0) then
           ! calculate annual averages from accumulated values
           tile%vegn%p_ann  = tile%vegn%p_ann_acm/tile%vegn%nmn_acm
           tile%vegn%t_ann  = tile%vegn%t_ann_acm/tile%vegn%nmn_acm
           tile%vegn%t_cold = tile%vegn%t_cold_acm
           tile%vegn%ncm    = weight_ncm*tile%vegn%ncm_acm + (1-weight_ncm)*tile%vegn%ncm
           ! reset accumulated values
           tile%vegn%ncm_acm    = 0
           tile%vegn%p_ann_acm  = 0
           tile%vegn%t_ann_acm  = 0
           tile%vegn%t_cold_acm = HUGE(tile%vegn%t_cold_acm)
        endif
!!$        call calc_miami_npp(tile%vegn)
        tile%vegn%nmn_acm = 0
     endif

     if (year1 /= year0 .and. do_biogeography) then
        call vegn_biogeography(tile%vegn)
     endif

     if (month1 /= month0.and.do_patch_disturbance) then
        call update_fuel(tile%vegn,tile%soil%w_wilt(1)/tile%soil%pars%vwc_sat)
        ! assume that all layers are the same soil type and wilting is vertically homogeneous
     endif

     if (day1 /= day0 .and. do_cohort_dynamics) then
        n = tile%vegn%n_cohorts
        call send_tile_data(id_cgain,sum(tile%vegn%cohorts(1:n)%carbon_gain),tile%diag)
        call send_tile_data(id_closs,sum(tile%vegn%cohorts(1:n)%carbon_loss),tile%diag)
        call send_tile_data(id_wdgain,sum(tile%vegn%cohorts(1:n)%bwood_gain),tile%diag)
        call vegn_growth(tile%vegn)
        call vegn_nat_mortality(tile%vegn,86400.0)
     endif

     if  (month1 /= month0 .and. do_phenology) then
        call vegn_phenology (tile%vegn,tile%soil%w_wilt(1)/tile%soil%pars%vwc_sat)
        ! assume that all layers are the same soil type and wilting is vertically homogeneous
     endif

     if (year1 /= year0 .and. do_patch_disturbance) then
        call vegn_disturbance(tile%vegn, seconds_per_year)
     endif

     if (year1 /= year0) then
        call vegn_harvesting(tile%vegn)
        tile%vegn%fsc_rate = tile%vegn%fsc_pool/fsc_pool_spending_time
        tile%vegn%ssc_rate = tile%vegn%ssc_pool/ssc_pool_spending_time
        where(harvest_spending_time(:)>0)
           tile%vegn%harv_rate(:) = &
                tile%vegn%harv_pool(:)/harvest_spending_time(:)
        elsewhere
           tile%vegn%harv_rate(:) = 0.0
        end where
     endif

     ! ---- diagnostic section
     call send_tile_data(id_t_ann,   tile%vegn%t_ann,   tile%diag)
     call send_tile_data(id_t_cold,  tile%vegn%t_cold,  tile%diag)
     call send_tile_data(id_lambda,  tile%vegn%lambda,  tile%diag)
     call send_tile_data(id_p_ann,   tile%vegn%p_ann,   tile%diag)
     call send_tile_data(id_ncm,     real(tile%vegn%ncm), tile%diag)
     call send_tile_data(id_afire,   tile%vegn%disturbance_rate(1), tile%diag)
     call send_tile_data(id_atfall,  tile%vegn%disturbance_rate(0), tile%diag)

     do ii = 1,N_HARV_POOLS
        call send_tile_data(id_harv_pool(ii),tile%vegn%harv_pool(ii),tile%diag)
        call send_tile_data(id_harv_rate(ii),tile%vegn%harv_rate(ii),tile%diag)
     enddo
     call send_tile_data(id_t_harv_pool,sum(tile%vegn%harv_pool(:)),tile%diag)
     call send_tile_data(id_t_harv_rate,sum(tile%vegn%harv_rate(:)),tile%diag)
     call send_tile_data(id_csmoke_pool,tile%vegn%csmoke_pool,tile%diag)
     call send_tile_data(id_csmoke_rate,tile%vegn%csmoke_rate,tile%diag)
     call send_tile_data(id_fsc_pool,tile%vegn%fsc_pool,tile%diag)
     call send_tile_data(id_fsc_rate,tile%vegn%fsc_rate,tile%diag)
     call send_tile_data(id_ssc_pool,tile%vegn%ssc_pool,tile%diag)
     call send_tile_data(id_ssc_rate,tile%vegn%ssc_rate,tile%diag)

     n=tile%vegn%n_cohorts
     call send_tile_data(id_bl,      sum(tile%vegn%cohorts(1:n)%bl),     tile%diag)
     call send_tile_data(id_blv,     sum(tile%vegn%cohorts(1:n)%blv),    tile%diag)
     call send_tile_data(id_br,      sum(tile%vegn%cohorts(1:n)%br),     tile%diag)
     call send_tile_data(id_bsw,     sum(tile%vegn%cohorts(1:n)%bsw),    tile%diag)
     call send_tile_data(id_bwood,   sum(tile%vegn%cohorts(1:n)%bwood),  tile%diag)
     call send_tile_data(id_fuel,    tile%vegn%fuel, tile%diag)
     call send_tile_data(id_species, real(tile%vegn%cohorts(1)%species), tile%diag)
     call send_tile_data(id_status,  real(tile%vegn%cohorts(1)%status),  tile%diag)
     call send_tile_data(id_leaf_age,real(tile%vegn%cohorts(1)%leaf_age),  tile%diag)!ens

     ! carbon budget tracking
     call send_tile_data(id_fsc_in,  tile%vegn%fsc_in,  tile%diag)
     call send_tile_data(id_fsc_out, tile%vegn%fsc_out, tile%diag)
     call send_tile_data(id_ssc_in,  tile%vegn%ssc_in,  tile%diag)
     call send_tile_data(id_ssc_out, tile%vegn%ssc_out, tile%diag)
     call send_tile_data(id_veg_in,  tile%vegn%veg_in,  tile%diag)
     call send_tile_data(id_veg_out, tile%vegn%veg_out, tile%diag)
     ! ---- end of diagnostic section

     ! reset averages and number of steps to 0 before the start of new month
     if (month1 /= month0) then
        tile%vegn%n_accum  = 0
        tile%vegn%tc_av    = 0.
        tile%vegn%tsoil_av = 0.
        tile%vegn%theta_av = 0.
        tile%vegn%precip_av= 0.
     endif

     !reset fuel and drought months before the start of new year
     if (year1 /= year0) then
        tile%vegn%lambda     = 0
        tile%vegn%fuel       = 0
     endif

  enddo

  ! seed transport
  if (year1 /= year0 .and. do_seed_transport) then
     call vegn_seed_transport()
  endif

  ! override with static vegetation
  if(day1/=day0) &
       call  read_static_vegn(lnd%time)
end subroutine update_vegn_slow


! ============================================================================
subroutine vegn_seed_transport()

  ! local vars
  type(land_tile_enum_type) :: ce, te
  type(land_tile_type), pointer :: tile
  integer :: i,j ! current point indices
  real :: total_seed_supply
  real :: total_seed_demand
  real :: f_supply ! fraction of the supply that gets spent
  real :: f_demand ! fraction of the demand that gets satisfied

  ce = first_elmt(lnd%tile_map, lnd%is, lnd%js) ; te = tail_elmt(lnd%tile_map)
  total_seed_supply = 0.0; total_seed_demand = 0.0
  do while ( ce /= te )
     call get_elmt_indices(ce,i,j)
     tile => current_tile(ce) ; ce=next_elmt(ce)
     if(.not.associated(tile%vegn)) cycle ! skip the rest of the loop body

     total_seed_supply = total_seed_supply + vegn_seed_supply(tile%vegn)*tile%frac*lnd%area(i,j)
     total_seed_demand = total_seed_demand + vegn_seed_demand(tile%vegn)*tile%frac*lnd%area(i,j)
  enddo
  ! sum totals globally
  call mpp_sum(total_seed_demand, pelist=lnd%pelist)
  call mpp_sum(total_seed_supply, pelist=lnd%pelist)
  ! if either demand or supply are zeros we don't need (or can't) transport anything
  if (total_seed_demand==0.or.total_seed_supply==0)then
     return
  end if

  ! calculate the fraction of the supply that's going to be used
  f_supply = MIN(total_seed_demand/total_seed_supply, 1.0)
  ! calculate the fraction of the demand that's going to be satisfied
  f_demand = MIN(total_seed_supply/total_seed_demand, 1.0)
  ! note that either f_supply or f_demand is 1; the mass conservation law in the
  ! following calculations is satisfied since 
  ! f_demand*total_seed_demand - f_supply*total_seed_supply == 0

  ! redistribute part (or possibly all) of the supply to satisfy part (or possibly all) 
  ! of the demand
  ce = first_elmt(lnd%tile_map) ; te = tail_elmt(lnd%tile_map)
  do while ( ce /= te )
     call get_elmt_indices(ce,i,j)
     tile => current_tile(ce) ; ce=next_elmt(ce)
     if(.not.associated(tile%vegn)) cycle ! skip the rest of the loop body
     
     call vegn_add_bliving(tile%vegn, &
          f_demand*vegn_seed_demand(tile%vegn)-f_supply*vegn_seed_supply(tile%vegn))
  enddo
end subroutine vegn_seed_transport


! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function vegn_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   vegn_tile_exists = associated(tile%vegn)
end function vegn_tile_exists


! ============================================================================
! cohort accessor functions: given a pointer to cohort, return a pointer to a
! specific member of the cohort structure
#define DEFINE_VEGN_ACCESSOR_0D(xtype,x) subroutine vegn_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p;p=>NULL();if(associated(t))then;if(associated(t%vegn))p=>t%vegn%x;endif;end subroutine

#define DEFINE_VEGN_ACCESSOR_1D(xtype,x) subroutine vegn_ ## x ## _ptr(t,p);\
type(land_tile_type),pointer::t;xtype,pointer::p(:);p=>NULL();if(associated(t))then;if(associated(t%vegn))p=>t%vegn%x;endif;end subroutine

#define DEFINE_COHORT_ACCESSOR(xtype,x) subroutine cohort_ ## x ## _ptr(c,p);\
type(vegn_cohort_type),pointer::c;xtype,pointer::p;p=>NULL();if(associated(c))p=>c%x;end subroutine

#define DEFINE_COHORT_COMPONENT_ACCESSOR(xtype,component,x) subroutine cohort_ ## x ## _ptr(c,p);\
type(vegn_cohort_type),pointer::c;xtype,pointer::p;p=>NULL();if(associated(c))p=>c%component%x;end subroutine

DEFINE_VEGN_ACCESSOR_0D(integer,landuse)
DEFINE_VEGN_ACCESSOR_0D(real,age)
DEFINE_VEGN_ACCESSOR_0D(real,fast_soil_C)
DEFINE_VEGN_ACCESSOR_0D(real,slow_soil_C)
DEFINE_VEGN_ACCESSOR_0D(real,fsc_pool)
DEFINE_VEGN_ACCESSOR_0D(real,fsc_rate)
DEFINE_VEGN_ACCESSOR_0D(real,ssc_pool)
DEFINE_VEGN_ACCESSOR_0D(real,ssc_rate)
DEFINE_VEGN_ACCESSOR_0D(real,asoil_in)
DEFINE_VEGN_ACCESSOR_0D(real,fsc_in)
DEFINE_VEGN_ACCESSOR_0D(real,ssc_in)
DEFINE_VEGN_ACCESSOR_0D(real,tc_av)
DEFINE_VEGN_ACCESSOR_0D(real,theta_av)
DEFINE_VEGN_ACCESSOR_0D(real,tsoil_av)
DEFINE_VEGN_ACCESSOR_0D(real,precip_av)
DEFINE_VEGN_ACCESSOR_0D(real,fuel)
DEFINE_VEGN_ACCESSOR_0D(real,lambda)
DEFINE_VEGN_ACCESSOR_0D(real,t_ann)
DEFINE_VEGN_ACCESSOR_0D(real,p_ann)
DEFINE_VEGN_ACCESSOR_0D(real,t_cold)
DEFINE_VEGN_ACCESSOR_0D(real,ncm)
DEFINE_VEGN_ACCESSOR_0D(real,t_ann_acm)
DEFINE_VEGN_ACCESSOR_0D(real,p_ann_acm)
DEFINE_VEGN_ACCESSOR_0D(real,t_cold_acm)
DEFINE_VEGN_ACCESSOR_0D(real,ncm_acm)
DEFINE_VEGN_ACCESSOR_0D(real,csmoke_pool)
DEFINE_VEGN_ACCESSOR_0D(real,csmoke_rate)

DEFINE_VEGN_ACCESSOR_1D(real,harv_pool)
DEFINE_VEGN_ACCESSOR_1D(real,harv_rate)

DEFINE_COHORT_ACCESSOR(integer,species)
DEFINE_COHORT_ACCESSOR(real,bl)
DEFINE_COHORT_ACCESSOR(real,br)
DEFINE_COHORT_ACCESSOR(real,blv)
DEFINE_COHORT_ACCESSOR(real,bsw)
DEFINE_COHORT_ACCESSOR(real,bwood)
DEFINE_COHORT_ACCESSOR(real,bliving)
DEFINE_COHORT_ACCESSOR(integer,status)
DEFINE_COHORT_ACCESSOR(real,leaf_age)
DEFINE_COHORT_ACCESSOR(real,npp_previous_day)

DEFINE_COHORT_COMPONENT_ACCESSOR(real,prog,tv)
DEFINE_COHORT_COMPONENT_ACCESSOR(real,prog,wl)
DEFINE_COHORT_COMPONENT_ACCESSOR(real,prog,ws)

DEFINE_COHORT_ACCESSOR(real,height)

end module vegetation_mod


module vegn_cohort_mod

use constants_mod, only: PI

use land_constants_mod, only: NBANDS, &
     mol_h2o, mol_air
use vegn_data_mod, only : spdata, &
   use_mcm_masking, use_bucket, critical_root_density, &
   tg_c4_thresh, tg_c3_thresh, l_fract, fsc_liv, &
   phen_ev1, phen_ev2, cmc_eps
use vegn_data_mod, only : PT_C3, PT_C4, CMPT_ROOT, CMPT_LEAF, &
   SP_C4GRASS, SP_C3GRASS, SP_TEMPDEC, SP_TROPICAL, SP_EVERGR, &
   LEAF_OFF, LU_CROP, PHEN_EVERGREEN, PHEN_DECIDIOUS
   
implicit none
private
! ==== public interfaces =====================================================
public :: vegn_phys_prog_type
public :: vegn_cohort_type

! operations defined for cohorts
!public :: new_cohort, delete_cohort
public :: vegn_data_heat_capacity
public :: vegn_data_intrcptn_cap
public :: get_vegn_wet_frac
public :: vegn_data_cover
public :: cohort_uptake_profile
public :: cohort_root_properties
 
public :: btotal ! returns cohort total biomass
public :: c3c4   ! returns physiology type for given biomasses and conditions
public :: phenology_type ! returns type of phenology for given conditions
public :: update_species ! updates cohort physiology, phenology type, and species
public :: height_from_biomass
public :: lai_from_biomass
public :: update_bio_living_fraction
public :: update_biomass_pools
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: vegn_cohort.F90,v 17.1.2.1.2.1 2010/02/17 14:47:34 pjp Exp $', &
     tagname = '$Name: hiram_20101115_bw $'

! ==== types =================================================================
type :: vegn_phys_prog_type
  real Wl
  real Ws
  real Tv
end type vegn_phys_prog_type

! vegn_cohort_type describes the data that belong to a vegetation cohort
type :: vegn_cohort_type
  type(vegn_phys_prog_type) :: prog

! ---- biological prognostic variables
! Currently bio prognostic variable is defined as anything that's saved in
! the restart; clearly some vars there are, strictly speaking, diagnostic,
! but saved for reproducibility (to avoid recalculation). exceptions :
! npp_previous_day is left outside, since it's obviously auxiliary; height
! is left outside
  integer :: species = 0   ! vegetation species
  real    :: bl      = 0.0 ! biomass of leaves, kg C/m2
  real    :: blv     = 0.0 ! biomass of virtual leaves (labile store), kg C/m2
  real    :: br      = 0.0 ! biomass of fine roots, kg C/m2
  real    :: bsw     = 0.0 ! biomass of sapwood, kg C/m2
  real    :: bwood   = 0.0 ! biomass of heartwood, kg C/m2

  real    :: bliving = 0.0 ! leaves, fine roots, and sapwood biomass
  integer :: status  = 0   ! growth status of plant
  real    :: leaf_age= 0.0 ! age of leaf in days since budburst

! ---- physical parameters
  real    :: height    = 0.0 ! vegetation height, m
  real    :: lai       = 0.0 ! leaf area index, m2/m2
  real    :: sai       = 0.0 ! stem area index, m2/m2
  real    :: leaf_size = 0.0 ! leaf dimension, m
  real    :: root_density = 0.0
  real    :: root_zeta    = 0.0
  real    :: rs_min       = 0.0
  real    :: leaf_refl(NBANDS) = 0.0 ! reflectance of leaf, per band
  real    :: leaf_tran(NBANDS) = 0.0 ! transmittance of leaf, per band
  real    :: leaf_emis         = 0.0 ! emissivity of leaf
  real    :: snow_crit         = 0.0 ! later parameterize this as snow_mask_fac*height

! ---- auxiliary variables 

  real    :: Wl_max  = 0.0 ! maximum liquid water content of canopy, kg/(m2 of ground)
  real    :: Ws_max  = 0.0 ! maximum soild water content of canopy, kg/(m2 of ground)
  real    :: mcv_dry = 0.0 ! heat capacity of dry canopy
  real    :: cover

  integer :: pt = 0  ! physiology type
  integer :: phent = 0

  real :: b      = 0.0 ! total biomass
  real :: babove = 0.0 ! total above ground biomass
  real :: bs     = 0.0 ! structural biomass: stem + structural roots
  real :: bstem  = 0.0 ! stem biomass

  real :: gpp  = 0.0 ! gross primary productivity kg C/timestep
  real :: npp  = 0.0 ! net primary productivity kg C/timestep
  real :: npp2 = 0.0 ! temporarily stores eddy_npp
  real :: miami_npp = 0.0 ! stores miami-model npp

  real :: resp = 0.0 ! plant respiration
  real :: resl = 0.0 ! leaf respiration
  real :: resr = 0.0 ! root respiration
  real :: resg = 0.0 ! growth respiration
  real :: md   = 0.0 ! plant tissue maintenance kg C/timestep

  real :: An_op = 0.0 ! mol C/(m2 of leaf per year)
  real :: An_cl = 0.0 ! mol C/(m2 of leaf per year)
  
  real :: carbon_gain = 0.0 ! carbon gain during the month
  real :: carbon_loss = 0.0 ! carbon loss during the month
  real :: bwood_gain  = 0.0 !

  ! used in fast time scale calculations
  real :: npp_previous_day     = 0.0
  real :: npp_previous_day_tmp = 0.0

  ! lena added this for storing previous size stomatal opening and lwnet 
  ! for computing canopy air T and q at the next step
  
  real :: gs = 0.0
  real :: gb = 0.0
!moved to prog%Wl  real :: cmc;
!moved to prog%Tv  real :: tleaf ! temperature of leaves, degK

  real :: ds = 0.0

  ! new allocation fractions, Jan2 03
  real :: Pl = 0.0          ! fraction of living biomass in leaves
  real :: Pr = 0.0          ! fraction of living biomass in fine roots
  real :: Psw= 0.0          ! fraction of living biomass in sapwood
  real :: Psw_alphasw = 0.0 ! fraction of sapwood times 
                            ! retirement rate of sapwood into wood
  real :: extinct = 0.0     ! light extinction coefficient in the canopy for photosynthesis calculations
  
! in LM3V the cohort structure has a handy pointer to the tile it belongs to;
! so operations on cohort can update tile-level variables. In this code, it is
! probably impossible to have this pointer here: it needs to be of type
! "type(vegn_tile_type), pointer", which means that the vegn_cohort_mod needs to
! use vegn_tile_mod. But the vegn_tile_mod itself uses vegn_cohort_mod, and 
! this would create a circular dependency of modules, something that's 
! prohibited in FORTRAN.
!  type(vegn_tile_type), pointer :: cp
end type vegn_cohort_type

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ============================================================================
subroutine vegn_data_heat_capacity ( cohort, mcv )
  type(vegn_cohort_type), intent(in)  :: cohort
  real                  , intent(out) :: mcv
  
  mcv = cohort%mcv_dry        ! later add term in vegn_pars%lai
end subroutine


! ============================================================================
subroutine vegn_data_intrcptn_cap ( cohort, vegn_Wl_max, vegn_Ws_max )
  type(vegn_cohort_type), intent(in)  :: cohort
  real                  , intent(out) :: vegn_Wl_max, vegn_Ws_max

  vegn_Wl_max = cohort%Wl_max
  vegn_Ws_max = cohort%Ws_max
end subroutine

! ============================================================================
! calculates functional dependence of wet canopy function f = x**p and its 
! derivative, but approximates it with linear function in the vicinity 
! of zero, to make sure that derivative doesn't become infinite
subroutine wet_frac(w, w_max, p, eps, f, DfDw)
  real, intent(in) :: &
       w, &     ! water content
       w_max, & ! maximum storage capacity
       p, &     ! exponent of the function
       eps      ! neighbourhood of zero where we approximate x**p with linear function
  real, intent(out) :: &
       f, & ! function value
       DfDw ! it's derivative

  if ( w > w_max ) then 
     f = 1; DfDw = 0;
  else if ( w < 0 ) then
     f = 0; DfDw = 0;
  else
     if ( w/w_max <= eps ) then
        f = eps**(p-1)*w/w_max; DfDw = eps**(p-1)/w_max
     else
        f = (w/w_max)**p;   DfDw = p/w_max*(w/w_max)**(p-1)
     endif
  endif
end subroutine wet_frac

! ============================================================================
! given amount of water and snow, returns combined fraction of covered canopy
subroutine get_vegn_wet_frac (cohort, &
     fw, DfwDwl, DfwDws, &
     fs, DfsDwl, DfsDws  )
  type(vegn_cohort_type), intent(in)  :: cohort
  real, intent(out), optional :: &
       fw, DfwDwl, DfwDws, & ! water-covered fraction of canopy and its derivatives
       fs, DfsDwl, DfsDws    ! snow-covered fraction of canopy and its derivatives

  ! ---- local vars
  integer :: sp  ! shorthand for current cohort species
  real    :: fw0 ! total water-covered fraction (without overlap)
  real    :: &   ! local variable for fractions and derivatives
       fwL, DfwDwlL, DfwDwsL, & ! water-covered fraction of canopy and its derivatives
       fsL, DfsDwlL, DfsDwsL    ! snow-covered fraction of canopy and its derivatives

  sp = cohort%species

  ! snow-covered fraction
  if(cohort%Ws_max > 0) then
     call wet_frac(cohort%prog%Ws, cohort%Ws_max, spdata(sp)%csc_pow, cmc_eps, fsL,  DfsDwsL)
  else
     fsL = 0.0; DfsDwsL=0.0
  endif
  DfsDwlL = 0
     
  ! wet fraction
  if(cohort%Wl_max > 0) then
     call wet_frac(cohort%prog%Wl, cohort%Wl_max, spdata(sp)%cmc_pow, cmc_eps, fw0, DfwDwlL)
  else
     fw0 = 0.0; DfwDwlL=0.0
  endif
  ! take into account overlap by snow
  fwL     = fw0*(1-fsL)
  DfwDwlL = DfwDwlL*(1-fsL)
  DfwDwsL = -fw0*DfsDwsL

  ! assign result to output parameters, if present
  if (present(fw))     fw = fwL
  if (present(DfwDwl)) DfwDwl = DfwDwlL
  if (present(DfwDws)) DfwDws = DfwDwsL
  if (present(fs))     fs = fsL
  if (present(DfsDwl)) DfsDwl = DfsDwlL
  if (present(DfsDws)) DfsDws = DfsDwsL
  
end subroutine


! ============================================================================
subroutine vegn_data_cover ( cohort, snow_depth, vegn_cover, &
                                         vegn_cover_snow_factor )
  type(vegn_cohort_type), intent(inout)  :: cohort
  real, intent(in)  :: snow_depth
  real, intent(out) :: vegn_cover
  real, intent(out) :: vegn_cover_snow_factor

  cohort%cover = 1 - exp(-cohort%lai)
  if (use_mcm_masking) then
     vegn_cover_snow_factor =  &
           (1 - min(1., 0.5*sqrt(max(snow_depth,0.)/cohort%snow_crit)))
     cohort%cover = cohort%cover * &
           (1 - min(1., 0.5*sqrt(max(snow_depth,0.)/cohort%snow_crit)))
  else
     vegn_cover_snow_factor =  &
           cohort%snow_crit / &
          (max(snow_depth,0.0) + cohort%snow_crit)
     cohort%cover = cohort%cover * &
           cohort%snow_crit / &
          (max(snow_depth,0.0) + cohort%snow_crit)
  endif
  vegn_cover = cohort%cover
end subroutine vegn_data_cover


! ============================================================================
! returns properties of the fine roots
subroutine cohort_root_properties(cohort, dz, vrl, K_r, r_r)
  type(vegn_cohort_type), intent(in)  :: cohort
  real, intent(in)  :: dz(:)
  real, intent(out) :: &
       vrl(:), & ! volumetric fine root length, m/m3
       K_r,    & ! root membrane permeability per unit area, kg/(m3 s)
       r_r       ! radius of fine roots, m

  integer :: sp, l
  real :: factor, z
  real :: vbr ! volumetric biomass of fine roots, kg C/m3

  sp = cohort%species

  factor = 1.0/(1.0-exp(-sum(dz)/cohort%root_zeta))
  z = 0
  do l = 1, size(dz)
     ! calculate the volumetric fine root biomass density [kgC/m3] for current layer
     ! NOTE: sum(brv*dz) must be equal to cohort%br, which is achieved by nomalizing
     ! factor
     vbr = cohort%br * &
          (exp(-z/cohort%root_zeta) - exp(-(z+dz(l))/cohort%root_zeta))*factor/dz(l)
     ! calculate the volumetric fine root length
     vrl(l) = vbr*spdata(sp)%srl

     z = z + dz(l)
  enddo

  K_r = spdata(sp)%root_perm
  r_r = spdata(sp)%root_r

end subroutine 


! ============================================================================
! calculates vertical distribution of active roots: given layer thicknesses,
! returns fraction of active roots per level
subroutine cohort_uptake_profile(cohort, dz, uptake_frac_max, vegn_uptake_term)
  type(vegn_cohort_type), intent(in)  :: cohort
  real, intent(in)  :: dz(:)
  real, intent(out) :: uptake_frac_max(:)
  real, intent(out) :: vegn_uptake_term(:)

  real, parameter :: res_scaler = mol_air/mol_h2o  ! scaling factor for water supply
  ! NOTE: there is an inconsistency there between the 
  ! units of stomatal conductance [mol/(m2 s)], and the units of humidity deficit [kg/kg],
  ! in the calculations of water demand. Since the uptake options other than LINEAR can't 
  ! use res_scaler, in this code the units of humidity deficit are converted to mol/mol,
  ! and the additional factor is introduced in res_scaler to ensure that the LINEAR uptake 
  ! gives the same results.

  integer :: l
  real    :: z, sum_rf

  if (use_bucket) then
     uptake_frac_max(1) = dz(1)
     z = dz(1)
     do l = 2, size(dz)
        if (cohort%root_density*(exp(-z/cohort%root_zeta)-&
            exp(-(z+dz(l))/cohort%root_zeta))/dz(l) > critical_root_density) &
        then
           uptake_frac_max(l) = dz(l)
        else
           uptake_frac_max(l) = 0
        endif
        z = z + dz(l)
     enddo
  else
     !linear scaling, LM3V
     z = 0
     do l = 1, size(dz)
        uptake_frac_max(l) = (exp(-z/cohort%root_zeta)    &
                - exp(-(z+dz(l))/cohort%root_zeta))
         uptake_frac_max(l) = &
                max( uptake_frac_max(l), 0.0)
        z = z + dz(l)
     enddo

  endif
  
  sum_rf = sum(uptake_frac_max)
  if(sum_rf>0) &
       uptake_frac_max(:) = uptake_frac_max(:)/sum_rf
  
  if (cohort%br <= 0) then
     vegn_uptake_term(:) = 0.0
  else   
     vegn_uptake_term(:) = uptake_frac_max(:) * &
          res_scaler * spdata(cohort%species)%dfr * cohort%br
  endif

end subroutine 


! ============================================================================
function btotal(c)
  real :: btotal ! returned value
  type(vegn_cohort_type), intent(in) :: c
  
  btotal = c%bliving+c%bwood
end function


! ============================================================================
function c3c4(c, temp, precip) result (pt)
  integer :: pt
  type(vegn_cohort_type), intent(in) :: c
  real,              intent(in) :: temp   ! temperatire, degK
  real,              intent(in) :: precip ! precipitation, ???

  real :: pc4
  
  ! Rule based on analysis of ED global output; equations from JPC, 2/02
  if(btotal(c) < tg_c4_thresh) then
    pc4=exp(-0.0421*(273.16+25.56-temp)-(0.000048*(273.16+25.5-temp)*precip));
  else
    pc4=0.0;
  endif
  
  if(pc4>0.5) then 
    pt=PT_C4
  else 
    pt=PT_C3
  endif
  
end function


! ============================================================================
! given current conditions, returns type of phenology.
function phenology_type(c, cm)
  integer :: phenology_type
  type(vegn_cohort_type), intent(in) :: c  ! cohort (not used???)
  real, intent(in) :: cm ! number of cold months
   
  real :: pe  ! prob evergreen
   
  ! GCH, Rule based on analysis of ED global output; equations from JPC, 2/02
  ! GCH, Parameters updated 2/9/02 from JPC
  pe = 1.0/(1.0+((1.0/0.00144)*exp(-0.7491*cm)));
  
  if(pe>phen_ev1 .and. pe<phen_ev2) then
     phenology_type = PHEN_EVERGREEN ! its evergreen
  else
     phenology_type = PHEN_DECIDIOUS ! its deciduous
  endif
end function


! ============================================================================
! given a cohort, climatology, and land use type, determines and updates 
! physiology type, phenology type, and species of the cohort
subroutine update_species(c, t_ann, t_cold, p_ann, cm, landuse)
  type(vegn_cohort_type), intent(inout) :: c    ! cohort to update
  real,              intent(in) :: t_ann   ! annual-mean temperature, degK
  real,              intent(in) :: t_cold  ! average temperature of the coldest month, degK
  real,              intent(in) :: p_ann   ! annual-mean precipitation, mm/yr
  real,              intent(in) :: cm      ! number of cold months
  integer,           intent(in) :: landuse ! land use type

  integer :: spp

  c%pt    = c3c4(c,t_ann,p_ann)
  c%phent = phenology_type(c, cm) 
  
  if(landuse == LU_CROP) c%phent = 0  ! crops can't be evergreen
  
  if(c%pt==PT_C4) then
     spp=SP_C4GRASS;  ! c4 grass
  else if(c%phent==1) then
     spp=SP_EVERGR;   ! evergreen non-grass
  else if(btotal(c) < tg_c3_thresh) then
     spp=SP_C3GRASS;  ! c3 grass
  else if ( t_cold > 278.16 ) then  ! ens,slm Jun 21 2003 to prohibit tropical forest in coastal cells
     spp=SP_TROPICAL; ! tropical deciduous non-grass
  else 
     spp=SP_TEMPDEC;  ! temperate deciduous non-grass
  endif

  ! reset leaf age to zero if species are chnaged
  if (spp/=c%species) c%leaf_age = 0.0

  c%species = spp
end subroutine


! ============================================================================
function height_from_biomass(btotal) result (height)
  real :: height ! returned value
  real, intent(in) :: btotal

  ! GCH, Function from JPC 2/9/02
!  height = 24.19*(1.0-exp(-0.19*(c%bliving+c%bwood)))
  height = 24.19*(1.0-exp(-0.19*btotal))
end function


! ============================================================================
function lai_from_biomass(bl,species) result (lai)
  real :: lai ! returned value
  real,    intent(in) :: bl      ! biomass of leaves, kg C/m2
  integer, intent(in) :: species ! species

  lai = bl*(spdata(species)%specific_leaf_area);   
end function


! ============================================================================
! calculates fractions of living biomass in differerent compartments
subroutine update_bio_living_fraction(c)
  type(vegn_cohort_type), intent(inout) :: c

  real    :: D  ! inverse denominator
  integer :: sp ! species, for convenience

  sp     = c%species
  D      = 1/(1 + spdata(sp)%c1 + c%height*spdata(sp)%c2)

  c%Pl   = D
  c%Pr   = spdata(sp)%c1 * D
  c%Psw  = 1 - c%Pl - c%Pr
  c%Psw_alphasw = spdata(sp)%c3 * spdata(sp)%alpha(CMPT_LEAF) * D
  
end subroutine update_bio_living_fraction


! ============================================================================
! redistribute living biomass pools in a given cohort, and update related 
! properties (height, lai, sai)
subroutine update_biomass_pools(c)
  type(vegn_cohort_type), intent(inout) :: c

  c%b      = c%bliving + c%bwood;
  c%height = height_from_biomass(c%b);
  call update_bio_living_fraction(c);
  c%bsw = c%Psw*c%bliving;
  if(c%status == LEAF_OFF) then
     c%blv = c%Pl*c%bliving + c%Pr*c%bliving;
     c%bl  = 0;
     c%br  = 0;
  else
     c%blv = 0;
     c%bl  = c%Pl*c%bliving;
     c%br  = c%Pr*c%bliving;
  endif
  c%lai = lai_from_biomass(c%bl,c%species)
  c%sai = 0.035*c%height ! Federer and Lash,1978
end subroutine 


end module vegn_cohort_mod


module cohort_io_mod

use fms_mod,          only : error_mesg, FATAL, WARNING
use mpp_mod,          only : mpp_pe, mpp_max, mpp_send, mpp_recv, mpp_sync

use nf_utils_mod,     only : nfu_inq_dim, nfu_get_var, nfu_put_var, &
     nfu_get_rec, nfu_put_rec, nfu_def_dim, nfu_def_var, nfu_put_att, &
     nfu_inq_var
use land_io_mod,      only : print_netcdf_error
use land_tile_mod,    only : land_tile_type, land_tile_list_type, &
     land_tile_enum_type, first_elmt, tail_elmt, next_elmt, get_elmt_indices, &
     current_tile, operator(/=)
use land_tile_io_mod, only : get_tile_by_idx, sync_nc_files

use vegn_cohort_mod, only: vegn_cohort_type
use land_data_mod, only : lnd

implicit none
private

! ==== public interfaces =====================================================
! input
public :: read_create_cohorts
public :: read_cohort_data_r0d_fptr
public :: read_cohort_data_i0d_fptr
! output
public :: create_cohort_dimension
public :: write_cohort_data_r0d_fptr
public :: write_cohort_data_i0d_fptr
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'cohort_io_mod', &
     version     = '$Id: vegn_cohort_io.F90,v 17.0.2.2.6.1 2011/12/12 19:30:45 Peter.Phillipps Exp $', &
     tagname     = '$Name:  $'
! name of the "compressed" dimension (and dimension variable) in the output 
! netcdf files -- that is, the dimensions written out using compression by 
! gathering, as described in CF conventions.
character(len=12),   parameter :: cohort_index_name   = 'cohort_index'
integer, parameter :: INPUT_BUF_SIZE = 1024 ! max size of the input buffer for
                                     ! cohort input

! ==== NetCDF declarations ===================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__)

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

! ============================================================================
! given compressed index, sizes of the global grid, 2D array of tile lists
! and the lower boundaries of this array, returns a pointer to the cohort
! corresponding to the compressed index, or NULL is the index is outside 
! current domain, or such tile does not exist, or such cohort does not exist.
subroutine get_cohort_by_idx(idx,nlon,nlat,ntiles,tiles,is,js,ptr)
   integer, intent(in) :: idx ! index
   integer, intent(in) :: nlon, nlat, ntiles
   integer, intent(in) :: is, js
   type(land_tile_list_type), intent(in) :: tiles(is:,js:)
   type(vegn_cohort_type), pointer :: ptr
   
   ! ---- local vars
   integer :: tile_idx, k
   type(land_tile_type), pointer :: tile
   
   ptr=>NULL()
   
   tile_idx = modulo(idx,nlon*nlat*ntiles)
   call get_tile_by_idx(tile_idx,nlon,nlat,tiles,is,js,tile)
   if(associated(tile)) then
      if (associated(tile%vegn)) then
         k = idx/(nlon*nlat*ntiles) ! calculate cohort index within a tile
         ptr=>tile%vegn%cohorts(k+1)
      endif
   endif

end subroutine

! ============================================================================
subroutine read_create_cohorts(ncid)
  integer, intent(in) :: ncid

  integer :: ncohorts ! total number of cohorts in restart file
  integer :: nlon, nlat, ntiles ! size of respective dimensions
 
  integer, allocatable :: idx(:)
  integer :: i,j,t,k,m, n, nn, idxid
  integer :: bufsize
  type(land_tile_enum_type) :: ce, te
  type(land_tile_type), pointer :: tile
  character(len=64) :: info ! for error message

  ! get the size of dimensions
  nlon = lnd%nlon ; nlat = lnd%nlat
  __NF_ASRT__(nfu_inq_dim(ncid,'tile',len=ntiles))

  ! read the cohort index
  __NF_ASRT__(nfu_inq_dim(ncid,cohort_index_name,len=ncohorts))
  __NF_ASRT__(nfu_inq_var(ncid,cohort_index_name,id=idxid))
  bufsize = min(INPUT_BUF_SIZE,ncohorts)
  allocate(idx(bufsize))
  
  do nn = 1, ncohorts, bufsize
     __NF_ASRT__(nf_get_vara_int(ncid,idxid,nn,min(bufsize,ncohorts-nn+1),idx))
     
     do n = 1,min(bufsize,ncohorts-nn+1)
        if(idx(n)<0) cycle ! skip illegal indices
        k = idx(n)
        i = modulo(k,nlon)+1   ; k = k/nlon
        j = modulo(k,nlat)+1   ; k = k/nlat
        t = modulo(k,ntiles)+1 ; k = k/ntiles
        k = k+1
        
        if (i<lnd%is.or.i>lnd%ie) cycle ! skip points outside of domain
        if (j<lnd%js.or.j>lnd%je) cycle ! skip points outside of domain
        
        ce = first_elmt(lnd%tile_map(i,j))
        do m = 1,t-1
           ce=next_elmt(ce)
        enddo
        tile=>current_tile(ce)
        if(.not.associated(tile%vegn)) then
           info = ''
           write(info,'("(",3i3,")")')i,j,t
           call error_mesg('read_create_cohort',&
                'vegn tile'//trim(info)//' does not exist, but is necessary to create a cohort', &
                WARNING)
        else
           tile%vegn%n_cohorts = tile%vegn%n_cohorts + 1
        endif
     enddo
  enddo

  ! go through all tiles in the domain and allocate requested numner of cohorts
  ce = first_elmt(lnd%tile_map); te = tail_elmt(lnd%tile_map)
  do while (ce/=te)
     tile=>current_tile(ce); ce = next_elmt(ce)
     if(.not.associated(tile%vegn))cycle
     allocate(tile%vegn%cohorts(tile%vegn%n_cohorts))
  enddo

  ! clean up memory
  deallocate(idx)
end subroutine read_create_cohorts


! ============================================================================
! creates cohort dimension, if necessary, in the output restart file. NOTE 
! that this subroutine should be called even if restart has not been created
! (because, for example, there happen to be no vegetation in a certain domain),
! for the reason that it calls mpp_max, and that should be called for each
! processor to work.
subroutine create_cohort_dimension(ncid)
  integer, intent(in) :: ncid


  ! ---- local vars
  type(land_tile_enum_type) :: ce, te ! tile list enumerators
  type(land_tile_type), pointer :: tile
 
  integer, allocatable :: idx(:)   ! integer compressed index of tiles
  integer :: i,j,k,c,n,ntiles,max_cohorts,p
  integer :: iret
  integer, allocatable :: ncohorts(:) ! array of idx sizes from all PEs in io_domain
  integer, allocatable :: idx2(:) ! array of cohort indices from all PEs in io_domain

  ! count total number of cohorts in compute domain and max number of
  ! of cohorts per tile
  ce = first_elmt(lnd%tile_map)
  te = tail_elmt (lnd%tile_map)
  n  = 0
  max_cohorts = 0
  do while (ce/=te)
     tile=>current_tile(ce)
     if(associated(tile%vegn))then
        n = n+tile%vegn%n_cohorts 
        max_cohorts = max(max_cohorts,tile%vegn%n_cohorts)
     endif
     ce=next_elmt(ce)
  enddo

  call mpp_max(max_cohorts)

  ! get the size of the tile dimension from the file
  __NF_ASRT__(nfu_inq_dim(ncid,'tile',len=ntiles))
  
  ! calculate compressed cohort index to be written to the restart file
  allocate(idx(max(n,1))) ; idx(:) = -1
  ce = first_elmt(lnd%tile_map, lnd%is, lnd%js)
  n = 1
  do while (ce/=te)
     tile=>current_tile(ce)
     if(associated(tile%vegn)) then
        call get_elmt_indices(ce,i,j,k)
        do c = 1,tile%vegn%n_cohorts
           idx (n) = &
                (c-1)*lnd%nlon*lnd%nlat*ntiles + &
                (k-1)*lnd%nlon*lnd%nlat + &
                (j-1)*lnd%nlon + &
                (i-1)        
           n = n+1
        enddo
     endif
     ce=next_elmt(ce)
  end do

  if (mpp_pe()/=lnd%io_pelist(1)) then
     ! if this processor is not doing io (that is, it's not root io_domain
     ! processor), simply send the data to the root io_domain PE
     call mpp_send(size(idx), plen=1,         to_pe=lnd%io_pelist(1))
     call mpp_send(idx(1),    plen=size(idx), to_pe=lnd%io_pelist(1))
  else
     ! gather the array of cohort index sizes
     allocate(ncohorts(size(lnd%io_pelist)))
     ncohorts(1) = size(idx)
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(ncohorts(p), from_pe=lnd%io_pelist(p), glen=1)
     enddo
     ! gather cohort index from the processors in our io_domain
     allocate(idx2(sum(ncohorts(:))))
     idx2(1:ncohorts(1))=idx(:)
     k=ncohorts(1)+1
     do p = 2,size(lnd%io_pelist)
        call mpp_recv(idx2(k), from_pe=lnd%io_pelist(p), glen=ncohorts(p))
        k = k+ncohorts(p)
     enddo
     ! create cohort dimension in the output file
     iret = nf_redef(ncid)
     __NF_ASRT__(nfu_def_dim(ncid,'cohort',max_cohorts))
     ! create cohort index
     __NF_ASRT__(nfu_def_dim(ncid,cohort_index_name,idx2,'compressed vegetation cohort index'))
     __NF_ASRT__(nfu_put_att(ncid,cohort_index_name,'compress','cohort tile lat lon'))
     __NF_ASRT__(nfu_put_att(ncid,cohort_index_name,'valid_min',0))
     ! deallocate the data we no longer need
     deallocate(ncohorts,idx2)
     ! leave the define mode to commit the new definitions to the disk
     iret = nf_enddef(ncid)
  endif
  call sync_nc_files(ncid)
end subroutine create_cohort_dimension


#define F90_TYPE real
#define NF_TYPE NF_DOUBLE
#define NF_FILL_VALUE NF_FILL_DOUBLE
#define READ_0D_FPTR read_cohort_data_r0d_fptr
#define WRITE_0D_FPTR write_cohort_data_r0d_fptr
#include "vegn_cohort_io.inc"

#define F90_TYPE integer
#define NF_TYPE NF_INT
#define NF_FILL_VALUE NF_FILL_INT
#define READ_0D_FPTR read_cohort_data_i0d_fptr
#define WRITE_0D_FPTR write_cohort_data_i0d_fptr
#include "vegn_cohort_io.inc"

end module cohort_io_mod


module vegn_data_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : &
     write_version_number, file_exist, check_nml_error, &
     close_file, stdlog

use land_constants_mod, only : NBANDS
use land_tile_selectors_mod, only : &
     tile_selector_type, SEL_VEGN, register_tile_selector

implicit none
private

! ==== public interfaces =====================================================
! ---- public constants
integer, public, parameter :: LU_SEL_TAG = 1 ! tag for the land use selectors
integer, public, parameter :: SP_SEL_TAG = 2 ! tag for the species selectors
integer, public, parameter :: NG_SEL_TAG = 3 ! tag for natural grass selector
  ! by "natural" it means non-human-maintained, so secondary vegetation
  ! grassland will be included. 

integer, public, parameter :: NSPECIES = 5, & ! number of species
 SP_C4GRASS   = 0, & ! c4 grass
 SP_C3GRASS   = 1, & ! c3 grass
 SP_TEMPDEC   = 2, & ! temperate deciduous
 SP_TROPICAL  = 3, & ! non-grass tropical
 SP_EVERGR    = 4    ! non-grass evergreen
character(len=12), parameter :: species_name(0:NSPECIES-1) = &
    (/'c4grass  ',  'c3grass  ' ,  'tempdec  ', 'tropical ','evergreen'/)
character(len=32), parameter :: species_longname(0:NSPECIES-1) = &
    (/'c4 grass                 ', 'c3 grass                 ',  'temperate deciduous trees',&
      'tropical trees           ', 'evergreen trees          '/)

integer, public, parameter :: n_dim_vegn_types = 9
integer, public, parameter :: MSPECIES = NSPECIES+n_dim_vegn_types-1
 
integer, public, parameter :: NCMPT = 6, & ! number of carbon compartments
 CMPT_REPRO   = 1, & ! 
 CMPT_SAPWOOD = 2, & ! sapwood compartment
 CMPT_LEAF    = 3, & ! leaf compartment
 CMPT_ROOT    = 4, & ! fine root compartment
 CMPT_VLEAF   = 5, & ! virtual leaves compartment (labile store)
 CMPT_WOOD    = 6    ! structural wood compartment

integer, public, parameter :: & ! physiology types
 PT_C3        = 0, &
 PT_C4        = 1

integer, public, parameter :: & ! phenology type
 PHEN_DECIDIOUS = 0, &
 PHEN_EVERGREEN = 1

integer, public, parameter :: & ! status of leaves
 LEAF_ON      = 0, &  ! leaves are displayed
 LEAF_OFF     = 5     ! leaves are dropped

integer, public, parameter :: & ! land use types
 N_LU_TYPES = 4, & ! number of different land use types
 LU_PAST    = 1, & ! pasture
 LU_CROP    = 2, & ! crops
 LU_NTRL    = 3, & ! natural vegetation
 LU_SCND    = 4    ! secondary vegetation
character(len=4), public, parameter  :: &
     landuse_name (N_LU_TYPES) = (/ 'past','crop','ntrl','scnd'/)
character(len=32), public, parameter :: &
     landuse_longname (N_LU_TYPES) = (/ 'pasture  ', 'crop     ', 'natural  ', 'secondary' /)

integer, public, parameter :: & ! harvesing pools paraneters
 N_HARV_POOLS        = 6, & ! number of harvesting pools
 HARV_POOL_PAST      = 1, & 
 HARV_POOL_CROP      = 2, &
 HARV_POOL_CLEARED   = 3, &
 HARV_POOL_WOOD_FAST = 4, &
 HARV_POOL_WOOD_MED  = 5, &
 HARV_POOL_WOOD_SLOW = 6
character(len=9), public :: HARV_POOL_NAMES(N_HARV_POOLS)
data HARV_POOL_NAMES &
 / 'past', 'crop', 'cleared', 'wood_fast', 'wood_med', 'wood_slow' /

real, public, parameter :: C2B = 2.0  ! carbon to biomass conversion factor

real, public, parameter :: BSEED = 5e-5 ! seed density for supply/demand calculations, kg C/m2 
! ---- public types
public :: spec_data_type

! ---- public data
public :: &
    vegn_to_use,  input_cover_types, &
    mcv_min, mcv_lai, &
    use_bucket, use_mcm_masking, vegn_index_constant, &
    critical_root_density, &
    ! vegetation data, imported from LM3V
    spdata, &
    min_cosz, &
    agf_bs, K1,K2, fsc_liv, fsc_wood, &
    tau_drip_l, tau_drip_s, & ! canopy water and snow residence times, for drip calculations
    GR_factor, tg_c3_thresh, tg_c4_thresh, &
    fsc_pool_spending_time, ssc_pool_spending_time, harvest_spending_time, &
    l_fract, T_transp_min, soil_carbon_depth_scale, &
    cold_month_threshold, scnd_biomass_bins, &
    phen_ev1, phen_ev2, cmc_eps

! ---- public subroutine
public :: read_vegn_data_namelist
! ==== end of public interfaces ==============================================

! ==== constants =============================================================
character(len=*), parameter   :: &
     version     = '$Id: vegn_data.F90,v 18.0.4.1 2010/08/24 12:11:36 pjp Exp $', &
     tagname     = '$Name: hiram_20101115_bw $', &
     module_name = 'vegn_data_mod'
real, parameter :: TWOTHIRDS  = 2.0/3.0


! ==== types ================================================================
type spec_data_type
  real    :: treefall_disturbance_rate;
  integer :: pt           ! photosynthetic physiology of species

  real    :: c1 ! unitless, coefficient for living biomass allocation
  real    :: c2 ! 1/m, coefficient for living biomass allocation
  real    :: c3 ! unitless, coefficient for calculation of sapwood biomass 
                ! fraction times sapwood retirement rate

  real    :: alpha(NCMPT) ! decay rates of plant carbon pools, 1/yr
  real    :: beta (NCMPT) ! respiration rates of plant carbon pools
  
  real    :: dfr          ! fine root diameter ? or parameter relating diameter of fine roots to resistance
  ! the following two parameters are used in the Darcy-law calculations of water supply
  real    :: srl  ! specific root length, m/(kg C)
  real    :: root_r       ! radius of the fine roots, m
  real    :: root_perm    ! fine root membrane permeability per unit area, kg/(m3 s)
!!$  real    :: ltrans       ! leaf translocation fraction
!!$  real    :: rtrans       ! fine root translocation fraction

  real    :: specific_leaf_area ! cm2/(g biomass)
  real    :: leaf_size    ! characteristic leaf size
  real    :: leaf_life_span ! months
  
  real    :: alpha_phot   ! photosynthesis efficiency
  real    :: m_cond       ! factor of stomatal conductance
  real    :: Vmax         ! max rubisco rate
  real    :: gamma_resp
  real    :: wet_leaf_dreg ! wet leaf photosynthesis down-regulation
  real    :: leaf_age_onset, leaf_age_tau

  ! radiation parameters for 2 bands, VIS and NIR
  real    :: leaf_refl (NBANDS) ! reflectance of leaf
  real    :: leaf_tran (NBANDS) ! transmittance of leaf
  real    :: leaf_emis          ! emissivity of leaf 
  real    :: scatter   (NBANDS) ! scattering coefficient of leaf (calculated as leaf_tran+leaf_refl)
  real    :: upscatter_dif (NBANDS)

  ! parameters of leaf angle distribution; see also Bonan, NCAR/TN-417+STR (LSM
  ! 1.0 technical description), p.18
  real    :: ksi    ! departure of leaf angles from a random distribution
  real    :: phi1   ! leaf distribution parameter
  real    :: phi2   ! leaf distribution parameter
  real    :: mu_bar ! average inverse diffuse optical depth per unit leaf are

  ! canopy intercepted water parameters
  real    :: cmc_lai ! max amount of liquid water on vegetation, kg/(m2 of leaf)
  real    :: cmc_pow ! power of wet fraction dependance on amount of canopy water
  real    :: csc_lai ! max amount of snow on vegetation, kg/(m2 of leaf)
  real    :: csc_pow ! power of snow-covered fraction dependance on amount of canopy snow
  real    :: fuel_intensity

  ! critical temperature for leaf drop, was internal to phenology
  real    :: tc_crit
  real    :: fact_crit_phen, cnst_crit_phen ! wilting factor and offset to 
    ! get critical value for leaf drop -- only one is non-zero at any time
  real    :: fact_crit_fire, cnst_crit_fire ! wilting factor and offset to 
    ! get critical value for fire -- only one is non-zero at the time

  real    :: smoke_fraction ! fraction of carbon lost as smoke during fires

  ! data from LM3W, temporarily here
  real    :: dat_height
  real    :: dat_lai
  real    :: dat_root_density
  real    :: dat_root_zeta
  real    :: dat_rs_min
  real    :: dat_snow_crit
end type

! ==== module data ===========================================================
integer :: idata,jdata ! iterators used in data initialization statements

! ---- namelist --------------------------------------------------------------
type(spec_data_type), save :: spdata(0:MSPECIES)

logical :: use_bucket = .false.
logical :: use_mcm_masking = .false.
real    :: mcv_min = 5.   * 4218.
real    :: mcv_lai = 0.15 * 4218.

! ---- remainder are used only for cold start
character(len=16):: vegn_to_use     = 'single-tile'
       ! 'multi-tile' for tiled vegetation
       ! 'single-tile' for geographically varying vegetation with single type per
       !     model grid cell
       ! 'uniform' for global constant vegetation, e.g., to reproduce MCM
integer :: vegn_index_constant   = 1         ! index of global constant vegn,
                                             ! used when vegn_to_use is 'uniform'
real    :: critical_root_density = 0.125

integer, dimension(1:MSPECIES) :: &
 input_cover_types=(/          -1,   -1,   -1,   -1, &
                          1,    2,    3,    4,    5,    6,    7,    8,    9/)
!character(len=4), dimension(n_dim_vegn_types) :: &
!  tile_names=      (/'be  ','bd  ','bn  ','ne  ','nd  ','g   ','d   ','t   ','a   ' /)

!  BE -- broadleaf evergreen trees
!  BD -- broadleaf deciduous trees
!  BN -- broadleaf/needleleaf trees
!  NE -- needleleaf evergreen trees
!  ND -- needleleaf deciduous trees
!  G  -- grassland
!  D  -- desert
!  T  -- tundra
!  A  -- agriculture


!       c4grass       c3grass    temp-decid      tropical     evergreen      BE     BD     BN     NE     ND      G      D      T      A
real :: dat_height(0:MSPECIES)= &
       (/  0.51,         0.51,          6.6,         19.5,          6.6,   19.5,   6.6,   8.8,   6.6,   5.9,  0.51,   1.0,  0.51,   2.9 /)
real :: dat_lai(0:MSPECIES); data dat_lai(NSPECIES:MSPECIES) &
                                                                        /   5.0,   5.0,   5.0,   5.0,   5.0,  5.0,   .001,   5.0,   5.0 /
! dat_root_density and dat_root_zeta were extended to lm3v species by copying 
! appropriate values from LaD table (e.g., grassland for both C3 and C4 grass)
real :: dat_root_density(0:MSPECIES)= &
!       c4grass       c3grass    temp-decid      tropical     evergreen      BE     BD     BN     NE     ND      G      D      T      A
       (/   1.4,          1.4,          4.2,          4.9,          2.9,    4.9,   4.2,   4.3,   2.9,   2.9,   1.4,   1.0,   1.2,  0.15 /)
real :: dat_root_zeta(0:MSPECIES)= &
       (/  0.26,         0.26,         0.29,         0.26,         0.17,   0.26,  0.29,  0.35,  0.17,  0.17,  0.26,   0.1,  0.11,  0.25 /)
real :: dat_rs_min(0:MSPECIES)= &
       (/ 56.6,          56.6,        131.0,         43.6,         69.7,   43.6, 131.0,  87.1,  69.7, 218.0,  56.6, 100.0, 170.0,  56.6 /)
real :: dat_snow_crit(0:MSPECIES)= &
!       c4grass       c3grass    temp-decid      tropical     evergreen      BE     BD     BN     NE     ND      G      D      T      A
    (/  0.0167,       0.0167,        0.0333,          0.2,       0.1333,    0.2, .0333, .0833, .1333, .1333, .0167, .0167, .0167, .0167 /)

! ==== species data imported from LM3V ======================================

!         c4 grass      c3 grass      c3 temperate  c3 tropical   c3 evergreed
real :: treefall_disturbance_rate(0:MSPECIES); data treefall_disturbance_rate(0:NSPECIES-1) &
        / 0.175,        0.185,        0.015,        0.025,        0.015 /
integer :: pt(0:MSPECIES)= &
!       c4grass       c3grass    temp-decid      tropical     evergreen      BE     BD     BN     NE     ND      G      D      T      A
       (/ PT_C4,        PT_C3,        PT_C3,        PT_C3,        PT_C3,  PT_C3, PT_C3, PT_C3, PT_C3, PT_C3, PT_C4, PT_C4, PT_C3, PT_C3 /)
real :: alpha(0:MSPECIES,NCMPT) ; data ((alpha(idata,jdata), idata=0,MSPECIES),jdata=1,NCMPT) &
        /   0.0,          0.0,          0.0,          0.0,          0.0,     0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,    0., & ! reproduction
            0.0,          0.0,          0.0,          0.0,          0.0,     0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,    0., & ! sapwood
            1.0,          1.0,          1.0,          0.8,         0.12,    0.8,   1.0,   1.0,  0.12,   1.0,   1.0,   1.0,   1.0,   1.0, & ! leaf
            0.9,         0.55,          1.0,          0.8,          0.6,    0.8,   1.0,   1.0,   0.6,   1.0,  0.55,   0.9,  0.55,  0.55, & ! root
            0.0,          0.0,          0.0,          0.0,          0.0,     0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,    0., & ! virtual leaf
            0.0,          0.0,        0.006,        0.012,        0.006,  0.012, 0.006, 0.006, 0.006, 0.006,    0.,    0.,    0.,    0. /  ! structural

! From Foley (Ibis model) 1996 gbc v10 pp. 603-628
real :: beta(0:MSPECIES,NCMPT) ; data ((beta(idata,jdata), idata=0,NSPECIES-1),jdata=1,NCMPT) &
        /   0.0,          0.0,          0.0,          0.0,          0.0,& ! reproduction
            0.0,          0.0,          0.0,          0.0,          0.0,& ! sapwood
            0.0,          0.0,          0.0,          0.0,          0.0,& ! leaf
           1.25,         1.25,         1.25,         1.25,         1.25,& ! root
            0.0,          0.0,          0.0,          0.0,          0.0,& ! virtual leaf
            0.0,          0.0,          0.0,          0.0,          0.0 / ! structural

! root parameters
real :: dfr(0:MSPECIES) ; data dfr &
!       c4grass       c3grass    temp-decid      tropical     evergreen      BE      BD      BN      NE      ND       G       D       T      A
        /   2.2,          2.2,          5.8,          5.8,          5.8,    5.8,    5.8,    5.8,    5.8,    5.8,    2.2,    2.2,    2.2,    2.2 /
real :: srl(0:MSPECIES); data srl & ! specific root length, m/(kg C)
        / 236e3,        236e3,       24.4e3,       24.4e3,       24.4e3, 24.4e3, 24.4e3, 24.4e3, 24.4e3, 24.4e3,  236e3,  236e3,   60e3,   60e3 /
real :: root_r(0:MSPECIES); data root_r & ! radius of fine roots, m
        /1.1e-4,       1.1e-4,       2.9e-4,       2.9e-4,       2.9e-4, 2.9e-4, 2.9e-4, 2.9e-4, 2.9e-4, 2.9e-4, 1.1e-4, 1.1e-4, 2.2e-4, 2.2e-4 /
real :: root_perm(0:MSPECIES); data root_perm & ! fine root membrane permeability per unit membrane area, kg/(m3 s)
        / 1e-5,          1e-5,         1e-5,         1e-5,         1e-5,   1e-5,   1e-5,   1e-5,   1e-5,   1e-5,   1e-5,   1e-5,   1e-5,   1e-5 /
! Specific root length is from Jackson et al., 1997, PNAS  Vol.94, pp.7362--7366, 
! converted to m/(kg C) from m/(g biomass). Biomass/C mass ratio was assumed 
! to be 2. The fine root radius is from the same source.
!
! Root membrane permeability is "high" value from Siqueira et al., 2008, Water 
! Resource Research Vol. 44, W01432, converted to mass units

real :: c1(0:MSPECIES); data c1(0:NSPECIES-1) &
        /   1.358025,     2.222222,     0.4807692,    0.3333333,    0.1948718 /
real :: c2(0:MSPECIES); data c2(0:NSPECIES-1) &
        /   0.4004486,    0.4004486,    0.4004486,    0.3613833,    0.1509976 /
real :: c3(0:MSPECIES); data c3(0:NSPECIES-1) &
        /   0.5555555,    0.5555555,    0.4423077,    1.230769,     0.5897437 /

! leaf radiation parameters
real :: leaf_refl(0:MSPECIES,NBANDS) ; data leaf_refl & ! leaf reflectance
        /   0.11,        0.11,         0.10,         0.10,         0.07,  0.149, 0.130, 0.132, 0.126, 0.143, 0.182, 0.300, 0.139, 0.160, & ! VIS
            0.45,        0.45,         0.45,         0.45,         0.35,  0.149, 0.130, 0.132, 0.126, 0.143, 0.182, 0.300, 0.139, 0.160  / ! NIR
real :: leaf_tran(0:MSPECIES,NBANDS) ; data leaf_tran & ! leaf transmittance
        /   0.07,        0.07,         0.05,         0.05,         0.05,     0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,    0., & ! VIS
            0.25,        0.25,         0.25,         0.25,         0.10,     0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.  / ! NIR
real :: leaf_emis(0:MSPECIES)= & ! leaf emissivity
       (/   1.00,        1.00,         1.00,         1.00,         1.00,   0.98,   0.96,  0.97,  0.98,  0.96, 0.96,   1.0,  0.96,  0.96  /)
real :: ksi(0:MSPECIES)= & ! leaf inclination index
       (/      0.,          0.,           0.,           0.,          0.,     0.,     0.,    0.,    0.,    0.,    0.,    0.,    0.,   0.  /)
real :: min_cosz = 0.01 ! minimum allowed value of cosz for vegetation radiation
   ! properties calculations.
   ! It probably doesn't make sense to set it any less than the default value, because the angular 
   ! diameter of the sun is about 0.01 radian (0.5 degree), so the spread of the direct radiation 
   ! zenith angles is about this. Besides, the sub-grid variations of land surface slope are 
   ! probably even larger that that. 

! canopy interception parameters
real :: cmc_lai(0:MSPECIES)= & ! maximum canopy water conntent per unit LAI
       (/    0.1,         0.1,          0.1,          0.1,          0.1,    0.1,    0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,  0.1  /)
real :: cmc_pow(0:MSPECIES)= & ! power of the wet canopy fraction relation 
  (/   TWOTHIRDS,   TWOTHIRDS,    TWOTHIRDS,    TWOTHIRDS,    TWOTHIRDS,     1.,     1.,    1.,    1.,    1.,    1.,    1.,    1.,   1.  /)
real :: csc_lai(0:MSPECIES)= & ! maximum canopy snow conntent per unit LAI
       (/    0.1,         0.1,          0.1,          0.1,          0.1,    0.1,    0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,  0.1  /)
real :: csc_pow(0:MSPECIES)= & ! power of the snow-covered fraction relation 
  (/   TWOTHIRDS,   TWOTHIRDS,    TWOTHIRDS,    TWOTHIRDS,    TWOTHIRDS,     1.,     1.,    1.,    1.,    1.,    1.,    1.,    1.,   1.  /)
real :: cmc_eps = 0.01 ! value of w/w_max for transition to linear function; 
                       ! the same value is used for liquid and snow

real :: fuel_intensity(0:MSPECIES) ; data fuel_intensity(0:NSPECIES-1) &
        /    1.0,         1.0,        0.002,        0.002,        0.004 /
real :: leaf_size(0:MSPECIES)= & ! characteristic leaf size
       (/   0.04,        0.04,         0.04,          0.04,        0.04,    0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1  /)
! photosynthesis parameters
real :: Vmax(0:MSPECIES)= & ! max rubisco rate
       (/  35e-6,       70e-6,        70e-6,         70e-6,       70e-6,  70e-6, 70e-6, 70e-6, 70e-6, 70e-6, 35e-6, 35e-6, 70e-6, 70e-6  /)
real :: m_cond(0:MSPECIES)= & ! factor of stomatal conductance
       (/    4.0,         9.0,          9.0,           9.0,         9.0,    9.0,   9.0,   9.0,   9.0,   9.0,   4.0,   4.0,   9.0,   9.0  /)
real :: alpha_phot(0:MSPECIES)= & ! photosynthesis efficiency
       (/   0.05,        0.06,         0.06,          0.06,        0.06,   0.06,  0.06,  0.06,  0.06,  0.06,  0.05,  0.05,  0.06,  0.06  /)
real :: gamma_resp(0:MSPECIES)= &
       (/   0.03,        0.02,         0.02,          0.02,        0.03,   0.02,  0.02,  0.02,  0.03,  0.03,  0.03,  0.03,  0.03,  0.02  /)
!       c4grass       c3grass    temp-decid      tropical     evergreen      BE     BD     BN     NE     ND      G      D      T      A
real :: tc_crit(0:MSPECIES)= &
       (/ 283.16,      278.16,       283.16,        283.16,      263.16,      0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,    0. /)
real :: cnst_crit_phen(0:MSPECIES)= & ! constant critical value for leaf drop
       (/    0.1,         0.1,          0.1,           0.1,         0.1,    0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1  /)
real :: fact_crit_phen(0:MSPECIES)= & ! factor for wilting to get critical value for leaf drop
       (/    0.0,         0.0,          0.0,           0.0,         0.0,    0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)
real :: cnst_crit_fire(0:MSPECIES)= & ! constant critical value for leaf drop
       (/    0.1,         0.1,          0.1,           0.1,         0.1,    0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1  /)  
real :: fact_crit_fire(0:MSPECIES)= & ! factor for wilting to get critical value for fire
       (/    0.0,         0.0,          0.0,           0.0,         0.0,    0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)
real :: wet_leaf_dreg(0:MSPECIES) = & ! wet leaf photosynthesis down-regulation: 0.3 means 
        ! photosynthesis of completely wet leaf will be 30% less than that of dry one,
        ! provided everything else is the same 
       (/    0.3,         0.3,          0.3,           0.3,         0.3,    0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3  /)
real :: leaf_age_onset(0:MSPECIES) = & ! onset of Vmax decrease due to leaf aging, days
       (/  100.0,       100.0,        100.0,         100.0,       100.0,  100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0  /)
real :: leaf_age_tau(0:MSPECIES) = &  ! e-folding time of Vmax decrease due to leaf aging, days (0 or less means no aging)
       (/    0.0,         0.0,          0.0,           0.0,         0.0,    0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)

real :: soil_carbon_depth_scale = 0.2   ! depth of active soil for carbon decomposition
real :: cold_month_threshold    = 283.0 ! monthly temperature threshold for calculations of number of cold months
real :: smoke_fraction(0:MSPECIES) = & ! fration of carbon lost as smoke
       (/    0.9,         0.9,          0.9,           0.9,         0.9,    0.9,   0.9,   0.9,   0.9,   0.9,   0.9,   0.9,   0.9,   0.9  /)
real :: agf_bs         = 0.8 ! ratio of above ground stem to total stem
real :: K1 = 10.0, K2 = 0.05 ! soil decomposition parameters
real :: fsc_liv        = 0.8
real :: fsc_wood       = 0.2
real :: tau_drip_l     = 21600.0 ! canopy water residence time, for drip calculations
real :: tau_drip_s     = 86400.0 ! canopy snow residence time, for drip calculations
real :: GR_factor = 0.33 ! growth respiration factor     

real :: tg_c3_thresh = 1.5 ! threshold biomass between tree and grass for C3 plants
real :: tg_c4_thresh = 2.0 ! threshold biomass between tree and grass for C4 plants
real :: fsc_pool_spending_time = 1.0 ! time (yrs) during which intermediate pool of 
                  ! fast soil carbon is entirely converted to the fast soil carbon
real :: ssc_pool_spending_time = 1.0 ! time (yrs) during which intermediate pool of
                  ! slow soil carbon is entirely converted to the slow soil carbon
real :: harvest_spending_time(N_HARV_POOLS) = &
     (/1.0, 1.0, 1.0, 1.0, 10.0, 100.0/)
     ! time (yrs) during which intermediate pool of harvested carbon is completely
     ! released to the atmosphere. 
     ! NOTE: a year in the above *_spending_time definitions is exactly 365*86400 seconds
real :: l_fract      = 0.5 ! fraction of the leaves retained after leaf drop
real :: T_transp_min = 0.0 ! lowest temperature at which transporation is enabled
                           ! 0 means no limit, lm3v value is 268.0
! boundaries of wood biomass bins for secondary veg. (kg C/m2); used to decide 
! whether secondary vegetation tiles can be merged or not. MUST BE IN ASCENDING 
! ORDER.
real  :: scnd_biomass_bins(10) &  
     = (/ 0.5, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 8.0, 10.0, 1000.0 /)
real :: phen_ev1 = 0.5, phen_ev2 = 0.9 ! thresholds for evergreen/decidious 
      ! differentiation (see phenology_type in cohort.F90)

namelist /vegn_data_nml/ &
  vegn_to_use,  input_cover_types, &
  mcv_min, mcv_lai, &
  use_bucket, use_mcm_masking, vegn_index_constant, &
  critical_root_density, &

  dat_height, dat_lai, dat_root_density, dat_root_zeta, dat_rs_min, dat_snow_crit, &
  ! vegetation data, imported from LM3V
  pt, Vmax, m_cond, alpha_phot, gamma_resp, wet_leaf_dreg, &
  leaf_age_onset, leaf_age_tau, &
  treefall_disturbance_rate,fuel_intensity, &
  alpha, beta, c1,c2,c3, &
  dfr, &
  srl, root_r, root_perm, &
  cmc_lai, cmc_pow, csc_lai, csc_pow, cmc_eps, &
  min_cosz, &
  leaf_refl, leaf_tran, leaf_emis, ksi, &
  leaf_size, &
  soil_carbon_depth_scale, cold_month_threshold, &

  smoke_fraction, agf_bs, K1,K2, fsc_liv, fsc_wood, &
  tau_drip_l, tau_drip_s, GR_factor, tg_c3_thresh, tg_c4_thresh, &
  fsc_pool_spending_time, ssc_pool_spending_time, harvest_spending_time, &
  l_fract, T_transp_min, &
  tc_crit, cnst_crit_phen, fact_crit_phen, cnst_crit_fire, fact_crit_fire, &
  scnd_biomass_bins, phen_ev1, phen_ev2


contains ! ###################################################################



! ============================================================================
subroutine read_vegn_data_namelist()
  ! ---- local vars
  integer :: unit         ! unit for namelist i/o
  integer :: io           ! i/o status for the namelist
  integer :: ierr         ! error code, returned by i/o routines
  integer :: i

  call write_version_number(version, tagname)
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=vegn_data_nml, iostat=io)
  ierr = check_nml_error(io, 'vegn_data_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file()
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=vegn_data_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'vegn_data_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif

  unit=stdlog()

  ! reconcile values of fact_crit_phen and cnst_crit_phen
  cnst_crit_phen = max(0.0,min(1.0,cnst_crit_phen))
  fact_crit_phen = max(0.0,fact_crit_phen)
  where (cnst_crit_phen/=0) fact_crit_phen=0.0
  write(unit,*)'reconciled fact_crit_phen and cnst_crit_phen'

  ! do the same for fire
  cnst_crit_fire = max(0.0,min(1.0,cnst_crit_fire))
  fact_crit_fire = max(0.0,fact_crit_fire)
  where (cnst_crit_fire/=0) fact_crit_fire=0.0 
  write(unit,*)'reconciled fact_crit_fire and cnst_crit_fire'

  ! initialize vegetation data structure

  spdata%dat_height = dat_height
  spdata%dat_lai = dat_lai
  spdata%dat_root_density = dat_root_density
  spdata%dat_root_zeta = dat_root_zeta
  spdata%dat_rs_min = dat_rs_min
  spdata%dat_snow_crit = dat_snow_crit

  spdata%treefall_disturbance_rate = treefall_disturbance_rate
  spdata%fuel_intensity            = fuel_intensity
 
  spdata%pt         = pt
  spdata%Vmax       = Vmax
  spdata%m_cond     = m_cond
  spdata%alpha_phot = alpha_phot
  spdata%gamma_resp = gamma_resp
  spdata%wet_leaf_dreg = wet_leaf_dreg
  spdata%leaf_age_onset = leaf_age_onset
  spdata%leaf_age_tau = leaf_age_tau
  spdata%dfr        = dfr

  spdata%srl        = srl
  spdata%root_r     = root_r
  spdata%root_perm  = root_perm
  
  spdata%c1 = c1
  spdata%c2 = c2
  spdata%c3 = c3

  spdata%cmc_lai = cmc_lai
  spdata%cmc_pow = cmc_pow
  spdata%csc_lai = csc_lai
  spdata%csc_pow = csc_pow
  
  spdata%leaf_size = leaf_size

  spdata%tc_crit   = tc_crit
  spdata%cnst_crit_phen = cnst_crit_phen
  spdata%fact_crit_phen = fact_crit_phen
  spdata%cnst_crit_fire = cnst_crit_fire
  spdata%fact_crit_fire = fact_crit_fire

  spdata%smoke_fraction = smoke_fraction

  do i = 0, MSPECIES
     spdata(i)%alpha     = alpha(i,:)
     spdata(i)%beta      = beta(i,:)
     spdata(i)%leaf_refl = leaf_refl(i,:)
     spdata(i)%leaf_tran = leaf_tran(i,:)
     spdata(i)%leaf_emis = leaf_emis(i)
     spdata(i)%ksi       = ksi(i)
     call init_derived_species_data(spdata(i))
  enddo

  ! register selectors for land use type-specific diagnostics
  do i=1, N_LU_TYPES
     call register_tile_selector(landuse_name(i), long_name=landuse_longname(i),&
          tag = SEL_VEGN, idata1 = LU_SEL_TAG, idata2 = i )
  enddo
  
  ! register selectors for species-specific diagnostics
  do i=0,NSPECIES-1
     call register_tile_selector(species_name(i), long_name=species_longname(i),&
          tag = SEL_VEGN, idata1 = SP_SEL_TAG, idata2 = i )
  enddo

  ! register selector for natural grass
  call register_tile_selector('ntrlgrass', long_name='natural (non-human-maintained) grass',&
          tag = SEL_VEGN, idata1 = NG_SEL_TAG)

  write (unit, nml=vegn_data_nml)

end subroutine 


! ============================================================================
subroutine init_derived_species_data(sp)
   type(spec_data_type), intent(inout) :: sp

   integer :: j
   
   sp%leaf_life_span     = 12.0/sp%alpha(CMPT_LEAF) ! in months
   ! calculate specific leaf area (cm2/g(biomass))
   ! Global Raich et al 94 PNAS pp 13730-13734
   sp%specific_leaf_area = 10.0**(2.4 - 0.46*log10(sp%leaf_life_span));       
   ! convert to (m2/kg(carbon)
   sp%specific_leaf_area = C2B*sp%specific_leaf_area*1000.0/10000.0

! rho_wood is not used anywhere?
!     ! the relationship from Moorcroft, based on Reich
!     ! units kg C/m^3, hence the factor of 0.001 to convert from g/cm^3
!      sp%rho_wood = (0.5 + 0.2*(sp%leaf_life_span-1))*0.001;
!     if (sp%rho_wood > 500.) sp%rho_wood = 0.5*0.001;

   sp%phi1=0.5-0.633*sp%ksi-0.33*sp%ksi**2;
   sp%phi2=0.877*(1.0-2.0*sp%phi1);
   if(sp%ksi /= 0) then
      sp%mu_bar = &
           (1-sp%phi1/sp%phi2*log(1+sp%phi2/sp%phi1))&
           / sp%phi2
   else
      ! in degenerate case of spherical leaf angular distribution the above 
      ! formula for mu_bar gives an undefined value, so we handle it separately 
      sp%mu_bar = 1.0
   endif
   do j = 1,NBANDS
      sp%scatter(j)       = sp%leaf_refl(j)+sp%leaf_tran(j);
      sp%upscatter_dif(j) = 0.5*(sp%scatter(j) + & 
           (sp%leaf_refl(j)-sp%leaf_tran(j))*(1+sp%ksi)**2/4);
   enddo
end subroutine


end module


! ============================================================================
! vegetation disturbances
! ============================================================================
module vegn_disturbance_mod

use land_constants_mod, only : seconds_per_year
use vegn_data_mod,   only : spdata, fsc_wood, fsc_liv, agf_bs, LEAF_OFF
use vegn_tile_mod,   only : vegn_tile_type
use vegn_cohort_mod, only : vegn_cohort_type, height_from_biomass, lai_from_biomass, &
     update_biomass_pools

implicit none
private

! ==== public interfaces =====================================================
public :: vegn_nat_mortality
public :: vegn_disturbance
public :: update_fuel
! =====end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), parameter :: &
     version = '$Id: vegn_disturbance.F90,v 17.0 2009/07/21 03:03:20 fms Exp $', &
     tagname = '$Name: hiram_20101115_bw $', &
     module_name = 'vegn_disturbance_mod'

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

subroutine vegn_disturbance(vegn, dt)
  type(vegn_tile_type), intent(inout) :: vegn
  real, intent(in) :: dt ! time since last disturbance calculations, s
  

  real, parameter :: BMIN = 1e-10; ! should be the same as in growth function
  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc    ! current cohort
  real :: precip;
  real :: delta;
  real :: fraction_lost;
  real :: drought_month;
  real :: deltat
  integer :: i
  integer :: sp ! shorhand for cohort species

  deltat = dt/seconds_per_year ! convert time interval to years

  !  Disturbance Rates
  precip=vegn%p_ann*86400*365; 
  drought_month = vegn%lambda;
  vegn%disturbance_rate(0) = 0.0;
  vegn%disturbance_rate(1) = 0.0;
  
  call calculate_patch_disturbance_rates(vegn)
   
  ! Fire disturbance implicitly, i.e.  not patch creating
  vegn%area_disturbed_by_fire = (1.0-exp(-vegn%disturbance_rate(1)*deltat));
  
  do i = 1,vegn%n_cohorts   
     cc => vegn%cohorts(i)
     sp = cc%species

     fraction_lost = 1.0-exp(-vegn%disturbance_rate(1)*deltat);	
      
     ! "dead" biomass : wood + sapwood
     delta = (cc%bwood+cc%bsw)*fraction_lost;
      
     vegn%slow_soil_C = vegn%slow_soil_C + (1.0-spdata(sp)%smoke_fraction)*delta*(1-fsc_wood);
     vegn%fast_soil_C = vegn%fast_soil_C + (1.0-spdata(sp)%smoke_fraction)*delta*   fsc_wood;
     cc%bwood = cc%bwood * (1-fraction_lost);
     cc%bsw   = cc%bsw   * (1-fraction_lost);
      
     vegn%csmoke_pool = vegn%csmoke_pool + spdata(sp)%smoke_fraction*delta;
      
     ! for budget tracking - temporarily not keeping wood and the rest separately,ens
     !      vegn%ssc_in+=delta*(1.0-spdata(sp)%smoke_fraction)*(1-fsc_wood); */
     !      vegn%fsc_in+=delta*(1.0-spdata(sp)%smoke_fraction)*fsc_wood; */
      
     vegn%ssc_in = vegn%ssc_in+(cc%bwood+cc%bsw)*fraction_lost *(1.0-spdata(sp)%smoke_fraction);
     !     vegn%fsc_in+=cc%bsw*fraction_lost *(1.0-spdata(sp)%smoke_fraction);
     vegn%veg_out = vegn%veg_out+delta;
      
     !"alive" biomass: leaves, roots, and virtual pool
     delta = (cc%bl+cc%blv+cc%br)*fraction_lost;
     vegn%fast_soil_C = vegn%fast_soil_C + (1.0-spdata(sp)%smoke_fraction)*delta*    fsc_liv ;
     vegn%slow_soil_C = vegn%slow_soil_C + (1.0-spdata(sp)%smoke_fraction)*delta*(1- fsc_liv);
      
     cc%bl  = cc%bl  * (1-fraction_lost);
     cc%blv = cc%blv * (1-fraction_lost);
     cc%br  = cc%br  * (1-fraction_lost);
      
     vegn%csmoke_pool = vegn%csmoke_pool + spdata(sp)%smoke_fraction*delta;
      
     ! for budget tracking- temporarily keeping alive separate ens
     ! /*      vegn%fsc_in+=delta* fsc_liv; */
     ! /*      vegn%ssc_in+=delta* (1-fsc_liv); */
     vegn%fsc_in = vegn%fsc_in+delta*(1.0-spdata(sp)%smoke_fraction);
     vegn%veg_out = vegn%veg_out+delta;
      
     !"living" biomass:leaves, roots and sapwood
     delta = cc%bliving*fraction_lost;
     cc%bliving = cc%bliving - delta;

     if(cc%bliving < BMIN) then
        ! remove vegetaion competely 	      
        vegn%fast_soil_C = vegn%fast_soil_C + fsc_liv*cc%bliving+ fsc_wood*cc%bwood;
        vegn%slow_soil_C = vegn%slow_soil_C + (1.- fsc_liv)*cc%bliving+ (1-fsc_wood)*cc%bwood;
        
        vegn%fsc_in = vegn%fsc_in + cc%bwood+cc%bliving;
        vegn%veg_out = vegn%veg_out + cc%bwood+cc%bliving;
        
        cc%bliving = 0.;
        cc%bwood   = 0.;
     endif
     call update_biomass_pools(cc)
  enddo

  vegn%csmoke_rate = vegn%csmoke_pool; ! kg C/(m2 yr)
end subroutine vegn_disturbance

! ============================================================================
subroutine calculate_patch_disturbance_rates(vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  ! ---- local vars
  real :: fire_prob;
  real :: fuel;

  fuel = vegn%fuel

#if SIMPLE_FIRE
  ! CALCULATE FIRE DISTURBANCE RATES
  vegn%disturbance_rate(1)=fire(vegn);
#else

  ! lambda is the number of drought months;
  fire_prob = vegn%lambda/(1.+vegn%lambda); 
  ! compute average fuel during fire months
  if (vegn%lambda > 0.00001 ) fuel = fuel/vegn%lambda;
  vegn%disturbance_rate(1) = fuel * fire_prob;

  ! put a threshold for very dry years for warm places
  if (vegn%t_ann > 273.16 .and. vegn%lambda > 3.)  vegn%disturbance_rate(1)=0.33;
#endif  
  
  if(vegn%disturbance_rate(1) > 0.33) vegn%disturbance_rate(1)=0.33;
  
  ! this is only true for the one cohort per patch case
  vegn%disturbance_rate(0) = spdata(vegn%cohorts(1)%species)%treefall_disturbance_rate;
  vegn%total_disturbance_rate = vegn%disturbance_rate(1)+vegn%disturbance_rate(0);
  
  vegn%fuel = fuel;
end subroutine calculate_patch_disturbance_rates


! ============================================================================
function fire(vegn) result(fireterm)
  real :: fireterm; ! return value
  type(vegn_tile_type), intent(inout) :: vegn

  ! ---- local vars
  real :: precip_av ! average precipitation, mm/year

  fireterm = 0
  precip_av = vegn%p_ann * seconds_per_year;
!!$  vegn%ignition_rate = 0.00;             
  vegn%fuel = vegn%total_biomass;

  if(vegn%fuel>0.0) then
     if(precip_av < 400.+40.*(vegn%t_ann-273.16)) then
        fireterm = vegn%fuel*(400. + 40.*(vegn%t_ann-273.16) - precip_av);
     endif
  endif
end function


! ============================================================================
subroutine update_fuel(vegn, wilt)
  type(vegn_tile_type), intent(inout) :: vegn
  real, intent(in) :: wilt ! ratio of wilting to saturated water content

  ! ---- local constants
  !  these three used to be in data 
  real, parameter :: fire_height_threashold = 100;
  real, parameter :: fp1 = 1.; ! disturbance rate per kgC/m2 of fuel
  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc    ! current cohort
  real :: theta_crit; ! critical ratio of average soil water to sat. water
  real :: ignition_rate;
  real ::  babove;
  integer :: i

  do i = 1,vegn%n_cohorts   
     cc => vegn%cohorts(i)
     ! calculate theta_crit: actually either fact_crit_fire or cnst_crit_fire 
     ! is zero, enforced by logic in the vegn_data.F90
     theta_crit = spdata(cc%species)%cnst_crit_fire &
           + wilt*spdata(cc%species)%fact_crit_fire
     theta_crit = max(0.0,min(1.0, theta_crit))
     if((cc%height < fire_height_threashold) &
          .and.(vegn%theta_av < theta_crit)  &
          .and.(vegn%tsoil_av > 278.16)) then
        babove = cc%bl + agf_bs * (cc%bsw + cc%bwood + cc%blv);
        ! this is fuel available durng the drought months only
        vegn%fuel = vegn%fuel + spdata(cc%species)%fuel_intensity*babove;	
     endif
  enddo

  ! note that the ignition rate calculation based on the value of theta_crit for 
  ! the last cohort -- currently it doesn't matter since we have just one cohort, 
  ! but something needs to be done about that in the future
  ignition_rate = 0.;
  if ( (vegn%theta_av < theta_crit) &
       .and. (vegn%tsoil_av>278.16)) ignition_rate = 1.;
  vegn%lambda = vegn%lambda + ignition_rate;

end subroutine update_fuel




! ============================================================================
subroutine vegn_nat_mortality(vegn, deltat)
  type(vegn_tile_type), intent(inout) :: vegn
  real, intent(in) :: deltat ! time since last mortality calculations, s
  
  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc    ! current cohort
  real :: delta;
  real :: fraction_lost;
  real :: bdead, balive; ! combined biomass pools
  integer :: i
  
  vegn%disturbance_rate(0)        = 0.0; 
  vegn%area_disturbed_by_treefall = 0.0;
  
  do i = 1,vegn%n_cohorts
     cc => vegn%cohorts(i)
     ! Treat treefall disturbance implicitly, i.e. not creating a new tile.
     ! note that this disturbance rate calculation only works for the one cohort per 
     ! tile case -- in case of multiple cohort disturbance rate pehaps needs to be 
     ! accumulated (or averaged? or something else?) over the cohorts.
     vegn%disturbance_rate(0) = spdata(cc%species)%treefall_disturbance_rate;
     vegn%area_disturbed_by_treefall = &
          1.0-exp(-vegn%disturbance_rate(0)*deltat/seconds_per_year);

     ! calculate combined biomass pools
     balive = cc%bl + cc%blv + cc%br;
     bdead  = cc%bsw + cc%bwood;
     ! ens need a daily PATCH_FREQ here, for now it is set to 48
     fraction_lost = 1.0-exp(-vegn%disturbance_rate(0)*deltat/seconds_per_year);     
      
     ! "dead" biomass : wood + sapwood
     delta = bdead*fraction_lost;

     vegn%slow_soil_C = vegn%slow_soil_C + (1-fsc_wood)*delta;
     vegn%fast_soil_C = vegn%fast_soil_C +    fsc_wood *delta;

     cc%bwood = cc%bwood * (1-fraction_lost);
     cc%bsw   = cc%bsw   * (1-fraction_lost);

     ! for budget tracking -temporarily
     ! vegn%fsc_in+= cc%bsw*fraction_lost;
     vegn%ssc_in  = vegn%ssc_in  + (cc%bwood+cc%bsw)*fraction_lost;
     vegn%veg_out = vegn%veg_out + delta;
     
     ! note that fast "living" pools are not included into mortality because their 
     ! turnover is calculated separately

     cc%bliving = cc%bsw + cc%bl + cc%br + cc%blv;
     call update_biomass_pools(cc);
  enddo
     
end subroutine vegn_nat_mortality


end module vegn_disturbance_mod


! ============================================================================
! updates carbon pools and rates on the fast time scale
! ============================================================================
module vegn_dynamics_mod

#include "../shared/debug.inc"

use fms_mod, only: write_version_number
use time_manager_mod, only: time_type

use land_constants_mod, only : seconds_per_year, mol_C
use land_tile_diag_mod, only : &
     register_tiled_diag_field, send_tile_data, diag_buff_type
use vegn_data_mod, only : spdata, &
     CMPT_VLEAF, CMPT_SAPWOOD, CMPT_ROOT, CMPT_WOOD, CMPT_LEAF, LEAF_ON, LEAF_OFF, &
     fsc_liv, fsc_wood, K1, K2, soil_carbon_depth_scale, C2B, agf_bs, &
     l_fract
use vegn_tile_mod, only: vegn_tile_type
use soil_tile_mod, only: soil_tile_type, soil_ave_temp, soil_ave_theta
use vegn_cohort_mod, only : vegn_cohort_type, height_from_biomass, lai_from_biomass, &
     update_biomass_pools, update_bio_living_fraction, update_species

use land_debug_mod, only : is_watch_point

implicit none
private

! ==== public interfaces =====================================================
public :: vegn_dynamics_init

public :: vegn_carbon_int   ! fast time-scale integrator of carbon balance
public :: vegn_growth       ! slow time-scale redistributor of accumulated carbon
public :: vegn_daily_npp    ! updates values of daily-average npp
public :: vegn_phenology    !
public :: vegn_biogeography !
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), private, parameter :: &
   version = '$Id: vegn_dynamics.F90,v 17.0 2009/07/21 03:03:22 fms Exp $', &
   tagname = '$Name:  $' ,&
   module_name = 'vegn'
real, parameter :: GROWTH_RESP=0.333  ! fraction of npp lost as growth respiration


! ==== module data ===========================================================
real    :: dt_fast_yr ! fast (physical) time step, yr (year is defined as 365 days)

! diagnostic field IDs
integer :: id_npp, id_nep, id_gpp, id_fast_soil_C, id_slow_soil_C, id_rsoil, id_rsoil_fast
integer :: id_resp, id_resl, id_resr, id_resg, id_asoil
integer :: id_soilt, id_theta, id_litter


contains

! ============================================================================
subroutine vegn_dynamics_init(id_lon, id_lat, time, delta_time)
  integer        , intent(in) :: id_lon ! ID of land longitude (X) axis 
  integer        , intent(in) :: id_lat ! ID of land latitude (Y) axis
  type(time_type), intent(in) :: time       ! initial time for diagnostic fields
  real           , intent(in) :: delta_time ! fast time step, s

  call write_version_number(version, tagname)

  ! set up global variables
  dt_fast_yr = delta_time/seconds_per_year

  ! register diagnostic fields
  id_gpp = register_tiled_diag_field ( module_name, 'gpp',  &
       (/id_lon,id_lat/), time, 'gross primary productivity', 'kg C/(m2 year)', &
       missing_value=-100.0 )
  id_npp = register_tiled_diag_field ( module_name, 'npp',  &
       (/id_lon,id_lat/), time, 'net primary productivity', 'kg C/(m2 year)', &
       missing_value=-100.0 )
  id_nep = register_tiled_diag_field ( module_name, 'nep',  &
       (/id_lon,id_lat/), time, 'net ecosystem productivity', 'kg C/(m2 year)', &
       missing_value=-100.0 )
  id_litter = register_tiled_diag_field (module_name, 'litter', (/id_lon,id_lat/), &
       time, 'litter productivity', 'kg C/(m2 year)', missing_value=-100.0)
  id_fast_soil_C = register_tiled_diag_field ( module_name, 'fsc',  &
       (/id_lon,id_lat/), time, 'fast soil carbon', 'kg C/m2', &
       missing_value=-100.0 )
  id_slow_soil_C = register_tiled_diag_field ( module_name, 'ssc',  &
       (/id_lon,id_lat/), time, 'slow soil carbon', 'kg C/m2', &
       missing_value=-100.0 )
  id_resp = register_tiled_diag_field ( module_name, 'resp', (/id_lon,id_lat/), &
       time, 'respiration', 'kg C/(m2 year)', missing_value=-100.0 )
  id_resl = register_tiled_diag_field ( module_name, 'resl', (/id_lon,id_lat/), &
       time, 'leaf respiration', 'kg C/(m2 year)', missing_value=-100.0 )
  id_resr = register_tiled_diag_field ( module_name, 'resr', (/id_lon,id_lat/), &
       time, 'root respiration', 'kg C/(m2 year)', missing_value=-100.0 )
  id_resg = register_tiled_diag_field ( module_name, 'resg', (/id_lon,id_lat/), &
       time, 'growth respiration', 'kg C/(m2 year)', missing_value=-100.0 )
  id_rsoil = register_tiled_diag_field ( module_name, 'rsoil',  &
       (/id_lon,id_lat/), time, 'soil respiration', 'kg C/(m2 year)', &
       missing_value=-100.0 )
  id_rsoil_fast = register_tiled_diag_field ( module_name, 'rsoil_fast',  &
       (/id_lon,id_lat/), time, 'fast soil carbon respiration', 'kg C/(m2 year)', &
       missing_value=-100.0 )
  id_asoil = register_tiled_diag_field ( module_name, 'asoil',  &
       (/id_lon,id_lat/), time, 'aerobic activity modifier', &
       missing_value=-100.0 )
  id_soilt = register_tiled_diag_field ( module_name, 'tsoil_av',  &
       (/id_lon,id_lat/), time, 'average soil temperature for carbon decomposition', 'degK', &
       missing_value=-100.0 )
  id_theta = register_tiled_diag_field ( module_name, 'theta',  &
       (/id_lon,id_lat/), time, 'average soil wetness for carbon decomposition', 'm3/m3', &
       missing_value=-100.0 )
end subroutine vegn_dynamics_init


! ============================================================================
subroutine vegn_carbon_int(vegn, soilt, theta, diag)
  type(vegn_tile_type), intent(inout) :: vegn
  real, intent(in) :: soilt ! average temperature of soil for soil carbon decomposition, deg K
  real, intent(in) :: theta ! average soil wetness, unitless
  type(diag_buff_type), intent(inout) :: diag

  type(vegn_cohort_type), pointer :: cc
  real :: resp, resl, resr, resg ! respiration terms accumualted for all cohorts 
  real :: cgain, closs ! carbon gain and loss accumulated for entire tile 
  real :: md_alive, md_wood;
  real :: gpp ! gross primary productivity per tile
  integer :: sp ! shorthand for current cohort specie
  integer :: i

  if(is_watch_point()) then
     write(*,*)'#### vegn_carbon_int ####'
     __DEBUG2__(soilt,theta)
  endif

  !  update plant carbon
  vegn%npp = 0
  resp = 0 ; resl = 0 ; resr = 0 ; resg = 0 ; gpp = 0
  cgain = 0 ; closs = 0
  do i = 1, vegn%n_cohorts   
     cc => vegn%cohorts(i)
     sp = cc%species

     call eddy_npp(cc,soilt);
     ! npp2 is for diagnostics and comparison
     cc%npp2 = cc%miami_npp;  ! treat miami npp as above+below npp
     
     cc%carbon_gain = cc%carbon_gain + cc%npp*dt_fast_yr;
     
     ! check if leaves/roots are present and need to be accounted in maintanence
     if(cc%status == LEAF_ON) then
        md_alive = (cc%Pl * spdata(sp)%alpha(CMPT_LEAF) + &
                    cc%Pr * spdata(sp)%alpha(CMPT_ROOT))* &
              cc%bliving*dt_fast_yr;    
     else
        md_alive = 0
     endif
     
     ! compute branch and coarse wood losses for tree types
     md_wood =0;
     if (sp > 1) then
        md_wood = 0.6 *cc%bwood * spdata(sp)%alpha(CMPT_WOOD)*dt_fast_yr;
     endif
        
     cc%md = md_alive + cc%Psw_alphasw * cc%bliving * dt_fast_yr;
     cc%bwood_gain = cc%bwood_gain + cc%Psw_alphasw * cc%bliving * dt_fast_yr;
     cc%bwood_gain = cc%bwood_gain - md_wood;
     if (cc%bwood_gain < 0.0) cc%bwood_gain=0.0; ! potential non-conservation ?
     cc%carbon_gain = cc%carbon_gain - cc%md;
     cc%carbon_loss = cc%carbon_loss + cc%md; ! used in diagnostics only

     ! add md from leaf and root pools to fast soil carbon
     vegn%fast_soil_C = vegn%fast_soil_C +    fsc_liv *md_alive +    fsc_wood *md_wood;
     vegn%slow_soil_C = vegn%slow_soil_C + (1-fsc_liv)*md_alive + (1-fsc_wood)*md_wood;

     ! for budget tracking
!/*     cp->fsc_in+= data->fsc_liv*md_alive+data->fsc_wood*md_wood; */
!/*     cp->ssc_in+= (1.- data->fsc_liv)*md_alive+(1-data->fsc_wood)*md_wood; */
     vegn%fsc_in  = vegn%fsc_in + 1*md_alive+0*md_wood;
     vegn%ssc_in  = vegn%ssc_in + (1.- 1)*md_alive+(1-0)*md_wood;

     vegn%veg_in  = vegn%veg_in  + cc%npp*dt_fast_yr;
     vegn%veg_out = vegn%veg_out + md_alive+md_wood;

     if(is_watch_point()) then
        __DEBUG4__(cc%bl, cc%br, cc%bsw, cc%bwood)
        __DEBUG3__(cc%An_op, cc%An_cl, cc%lai)
        __DEBUG1__(cc%species)
        __DEBUG2__(cc%npp, cc%gpp)
        __DEBUG4__(cc%resp, cc%resl, cc%resr, cc%resg)
        __DEBUG2__(cc%carbon_gain, cc%carbon_loss)
        __DEBUG1__(cc%bwood_gain)
     endif
     ! accumulate tile-level NPP and GPP
     vegn%npp = vegn%npp + cc%npp
     gpp = gpp + cc%gpp 
     ! accumulate respiration terms for tile-level reporting
     resp = resp + cc%resp ; resl = resl + cc%resl
     resr = resr + cc%resr ; resg = resg + cc%resg
     ! accumulate gain/loss terms for tile-level reporting
     cgain = cgain + cc%carbon_gain
     closs = closs + cc%carbon_loss
  enddo

  ! update soil carbon
  call Dsdt(vegn, diag, soilt, theta)

  ! NEP is equal to NNP minus soil respiration
  vegn%nep = vegn%npp - vegn%rh

  call update_soil_pools(vegn)
  vegn%age = vegn%age + dt_fast_yr;


  ! ---- diagnostic section
  call send_tile_data(id_gpp,gpp,diag)
  call send_tile_data(id_npp,vegn%npp,diag)
  call send_tile_data(id_nep,vegn%nep,diag)
  call send_tile_data(id_litter,vegn%litter,diag)
  call send_tile_data(id_resp, resp, diag)
  call send_tile_data(id_resl, resl, diag)
  call send_tile_data(id_resr, resr, diag)
  call send_tile_data(id_resg, resg, diag)
  call send_tile_data(id_soilt,soilt,diag)
  call send_tile_data(id_theta,theta,diag)
  
end subroutine vegn_carbon_int


! ============================================================================
! updates cohort biomass pools, LAI, SAI, and height using accumulated 
! carbon_gain and bwood_gain
subroutine vegn_growth (vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc    ! current cohort
  integer :: i

  do i = 1, vegn%n_cohorts   
     cc => vegn%cohorts(i)

     cc%bwood   = cc%bwood   + cc%bwood_gain
     cc%bliving = cc%bliving + cc%carbon_gain
     
     if(cc%bliving < 0) then
        cc%bwood    = cc%bwood+cc%bliving
        cc%bliving  = 0
        if (cc%bwood < 0) &
             cc%bwood = 0 ! in principle, that's not conserving carbon
     endif
     
     call update_biomass_pools(cc)
     cc%root_density = (cc%br + &
            (cc%bsw+cc%bwood+cc%blv)*(1-agf_bs))*C2B
     cc%Wl_max = spdata(cc%species)%cmc_lai*cc%lai
     cc%Ws_max = spdata(cc%species)%csc_lai*cc%lai
     
     ! reset carbon acculmulation terms
     cc%carbon_gain = 0
     cc%carbon_loss = 0
     cc%bwood_gain  = 0
     if (cc%status == LEAF_ON) then
        cc%leaf_age = cc%leaf_age + 1.0
        ! limit the maximum leaf age by the leaf time span (reciprocal of leaf 
        ! turnover rate alpha) for given species. alpha is in 1/year, factor of
        ! 365 converts the result to days.
        if (spdata(cc%species)%alpha(CMPT_LEAF) > 0) &
             cc%leaf_age = min(cc%leaf_age,365.0/spdata(cc%species)%alpha(CMPT_LEAF))
     endif
  end do

end subroutine vegn_growth


! ============================================================================
subroutine Dsdt(vegn, diag, soilt, theta)
  type(vegn_tile_type), intent(inout) :: vegn
  type(diag_buff_type), intent(inout) :: diag
  real                , intent(in)    :: soilt ! soil temperature, deg K 
  real                , intent(in)    :: theta

  real :: fast_C_loss
  real :: slow_C_loss
  real :: A  ! decomp rate reduction due to moisture and temperature
  
  A=A_function(soilt,theta);
  
  fast_C_loss = vegn%fast_soil_C*A*K1*dt_fast_yr;
  slow_C_loss = vegn%slow_soil_C*A*K2*dt_fast_yr;
  
  vegn%fast_soil_C = vegn%fast_soil_C - fast_C_loss;
  vegn%slow_soil_C = vegn%slow_soil_C - slow_C_loss;

  ! for budget check
  vegn%fsc_out = vegn%fsc_out + fast_C_loss;
  vegn%ssc_out = vegn%ssc_out + slow_C_loss;

  ! loss of C to atmosphere and leaching
  vegn%rh =   (fast_C_loss+slow_C_loss)/dt_fast_yr;
  ! vegn%rh_fast = fast_C_loss/dt_fast_yr;

  ! accumulate decomposition rate reduction for the soil carbon restart output
  vegn%asoil_in = vegn%asoil_in + A

  ! ---- diagnostic section
  call send_tile_data(id_fast_soil_C, vegn%fast_soil_C, diag)
  call send_tile_data(id_slow_soil_C, vegn%slow_soil_C, diag)
  call send_tile_data(id_rsoil_fast, fast_C_loss/dt_fast_yr, diag)
  call send_tile_data(id_rsoil, vegn%rh, diag)
  call send_tile_data(id_asoil, A, diag)

end subroutine Dsdt


! ============================================================================
! The combined reduction in decomposition rate as a funciton of TEMP and MOIST
! Based on CENTURY Parton et al 1993 GBC 7(4):785-809 and Bolker's copy of
! CENTURY code
function A_function(soilt, theta) result(A)
  real :: A                 ! return value, resulting reduction in decomposition rate
  real, intent(in) :: soilt ! effective temperature for soil carbon decomposition
  real, intent(in) :: theta 

  real :: soil_temp; ! temperature of the soil, deg C
  real :: Td; ! rate multiplier due to temp
  real :: Wd; ! rate reduction due to mositure

  ! coefficeints and terms used in temperaturex term
  real :: Topt,Tmax,t1,t2,tshl,tshr;

  soil_temp = soilt-273.16;

  ! EFFECT OF TEMPERATURE
  ! from Bolker's century code
  Tmax=45.0;
  if (soil_temp > Tmax) soil_temp = Tmax;
  Topt=35.0;
  tshr=0.2; tshl=2.63;
  t1=(Tmax-soil_temp)/(Tmax-Topt);
  t2=exp((tshr/tshl)*(1.-t1**tshl));
  Td=t1**tshr*t2;

  if (soil_temp > -10) Td=Td+0.05;
  if (Td > 1.) Td=1.;

  ! EFFECT OF MOISTURE
  ! Linn and Doran, 1984, Soil Sci. Amer. J. 48:1267-1272
  ! This differs from the Century Wd
  ! was modified by slm/ens based on the figures from the above paper 
  !     (not the reported function)

  if(theta <= 0.3) then
     Wd = 0.2;
  else if(theta <= 0.6) then
     Wd = 0.2+0.8*(theta-0.3)/0.3;
  else 
     Wd = exp(2.3*(0.6-theta));
  endif

  A = (Td*Wd); ! the combined (multiplicative) effect of temp and water
               ! on decomposition rates
end function A_function


! ============================================================================
subroutine eddy_npp(cc, tsoil)
  type(vegn_cohort_type), intent(inout) :: cc
  real, intent(in) :: tsoil

  call plant_respiration(cc,tsoil);

  cc%gpp = (cc%An_op - cc%An_cl)*mol_C*cc%lai;
  cc%npp = cc%gpp - cc%resp;

!  if(cc%npp_previous_day > -0.00001/2500.0) then
  if(cc%npp_previous_day > 0) then
     cc%resg = GROWTH_RESP*cc%npp_previous_day;
     cc%npp  = cc%npp  - GROWTH_RESP*cc%npp_previous_day;
     cc%resp = cc%resp + GROWTH_RESP*cc%npp_previous_day;
  else
     cc%resg = 0;
  endif

  ! update, accumulate
  cc%npp_previous_day_tmp = cc%npp_previous_day_tmp + cc%npp; 
end subroutine eddy_npp


! ============================================================================
subroutine plant_respiration(cc, tsoil)
  type(vegn_cohort_type), intent(inout) :: cc
  real, intent(in) :: tsoil
  
  real :: tf,tfs;
  real :: r_leaf, r_vleaf, r_stem, r_root
  
  integer :: sp ! shorthand for cohort species
  sp = cc%species

  tf = exp(3000.0*(1.0/288.16-1.0/cc%prog%Tv));
  tf = tf / ( &
            (1.0+exp(0.4*(5.0-cc%prog%Tv+273.16)))*&
            (1.0+exp(0.4*(cc%prog%Tv - 273.16-45.0)))&
            )

  tfs = exp(3000.0*(1.0/288.16-1.0/tsoil));
  tfs = tfs / ( &
              (1.0+exp(0.4*(5.0-tsoil+273.16)))* &
              (1.0+exp(0.4*(tsoil - 273.16-45.0)))&
              )

  r_leaf = -mol_C*cc%An_cl*cc%lai;
  r_vleaf = spdata(sp)%beta(CMPT_VLEAF)   * cc%blv*tf;
  r_stem  = spdata(sp)%beta(CMPT_SAPWOOD) * cc%bsw*tf;
  r_root  = spdata(sp)%beta(CMPT_ROOT)    * cc%br*tfs;
  
  cc%resp = r_leaf + r_vleaf + r_stem + r_root;
  cc%resl = r_leaf;
  cc%resr = r_root;
end subroutine plant_respiration


! ============================================================================
! calculates prev. day average NPP from accumualted values
subroutine vegn_daily_npp(vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  integer :: n_fast_step;
  integer :: i
  type(vegn_cohort_type), pointer :: cc

  n_fast_step = 1.0/365.0/dt_fast_yr;
  do i = 1, vegn%n_cohorts   
     cc => vegn%cohorts(i)
     vegn%cohorts(i)%npp_previous_day=vegn%cohorts(i)%npp_previous_day_tmp/n_fast_step;
     vegn%cohorts(i)%npp_previous_day_tmp=0.0
  enddo
end subroutine vegn_daily_npp


! =============================================================================
subroutine vegn_phenology(vegn, wilt)
  type(vegn_tile_type), intent(inout) :: vegn
  real, intent(in) :: wilt ! ratio of wilting to saturated water content

  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc
  real :: leaf_litter,root_litter;    
  real :: theta_crit; ! critical ratio of average soil water to sat. water
  integer :: i
  
  vegn%litter = 0

  do i = 1,vegn%n_cohorts   
     cc => vegn%cohorts(i)
     
     if(is_watch_point())then
        write(*,*)'####### vegn_phenology #######'
        __DEBUG4__(vegn%theta_av, wilt, spdata(cc%species)%cnst_crit_phen, spdata(cc%species)%fact_crit_phen)
        __DEBUG1__(cc%species)
        __DEBUG2__(vegn%tc_av,spdata(cc%species)%tc_crit)
     endif
     ! if drought-deciduous or cold-deciduous species
     ! temp=10 degrees C gives good growing season pattern        
     ! spp=0 is c3 grass,1 c3 grass,2 deciduous, 3 evergreen
     ! assumption is that no difference between drought and cold deciduous
     cc%status = LEAF_ON; ! set status to indicate no leaf drop
      
     if(cc%species < 4 )then! deciduous species
        ! actually either fact_crit_phen or cnst_crit_phen is zero, enforced
        ! by logic in the vegn_data.F90
        theta_crit = spdata(cc%species)%cnst_crit_phen &
              + wilt*spdata(cc%species)%fact_crit_phen
        theta_crit = max(0.0,min(1.0, theta_crit))
        if ( (vegn%theta_av < theta_crit) &
             .or.(vegn%tc_av < spdata(cc%species)%tc_crit) ) then
           cc%status = LEAF_OFF; ! set status to indicate leaf drop 
           cc%leaf_age = 0;
           
           leaf_litter = (1.0-l_fract)*cc%bl;
           root_litter = (1.0-l_fract)*cc%br;
           
           ! add to patch litter flux terms
           vegn%litter = vegn%litter + leaf_litter + root_litter;
           
           vegn%fast_soil_C = vegn%fast_soil_C +    fsc_liv *(leaf_litter+root_litter);
           vegn%slow_soil_C = vegn%slow_soil_C + (1-fsc_liv)*(leaf_litter+root_litter);
	     
           ! vegn%fsc_in+=data->fsc_liv*(leaf_litter+root_litter);
           ! vegn%ssc_in+=(1.0-data->fsc_liv)*(leaf_litter+root_litter);
           vegn%fsc_in  = vegn%fsc_in  + leaf_litter+root_litter;
           vegn%veg_out = vegn%veg_out + leaf_litter+root_litter;
           
           cc%blv = cc%blv + l_fract*(cc%bl+cc%br);
           cc%bl  = 0.0;
           cc%br  = 0.0;
           cc%lai = 0.0;
           
           ! update state
           cc%bliving = cc%blv + cc%br + cc%bl + cc%bsw;
           cc%b = cc%bliving + cc%bwood ;
           call update_bio_living_fraction(cc);   
        endif
     endif
  enddo
end subroutine vegn_phenology


! =============================================================================
subroutine vegn_biogeography(vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  ! ---- local vars
  integer :: i

  do i = 1, vegn%n_cohorts   
     call update_species(vegn%cohorts(i), vegn%t_ann, vegn%t_cold, &
          vegn%p_ann*seconds_per_year, vegn%ncm, vegn%landuse)
  enddo
end subroutine

! =============================================================================
! The stuff below comes from she_update.c -- it looks like it belongs here, 
! since it is essentially a part of the carbon integration (update_patch_fast
! is only called immediately after carbon_int in lm3v)
! =============================================================================


! =============================================================================
subroutine update_soil_pools(vegn)
  type(vegn_tile_type), intent(inout) :: vegn
  
  ! ---- local vars
  real :: delta;

  ! update fsc input rate so that intermediate fsc pool is never
  ! depleted below zero; on the other hand the pool can be only 
  ! depleted, never increased
  vegn%fsc_rate = MAX( 0.0, MIN(vegn%fsc_rate, vegn%fsc_pool/dt_fast_yr));
  delta = vegn%fsc_rate*dt_fast_yr;
  vegn%fast_soil_C = vegn%fast_soil_C + delta;
  vegn%fsc_pool    = vegn%fsc_pool    - delta;

  ! update ssc input rate so that intermediate ssc pool is never
  ! depleted below zero; on the other hand the pool can be only 
  ! depleted, never increased
  vegn%ssc_rate = MAX(0.0, MIN(vegn%ssc_rate, vegn%ssc_pool/dt_fast_yr));
  delta = vegn%ssc_rate*dt_fast_yr;
  vegn%slow_soil_C = vegn%slow_soil_C + delta;
  vegn%ssc_pool    = vegn%ssc_pool    - delta;
end subroutine update_soil_pools



end module vegn_dynamics_mod


module vegn_harvesting_mod

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod, only : write_version_number, string, error_mesg, FATAL, NOTE, &
     mpp_pe, write_version_number, file_exist, close_file, &
     check_nml_error, stdlog, mpp_root_pe
use mpp_io_mod, only : axistype, mpp_get_atts, mpp_get_axis_data, &
     mpp_open, mpp_close, MPP_RDONLY, MPP_WRONLY, MPP_ASCII
use vegn_data_mod, only : &
     N_LU_TYPES, LU_PAST, LU_CROP, LU_NTRL, LU_SCND, &
     HARV_POOL_PAST, HARV_POOL_CROP, HARV_POOL_CLEARED, HARV_POOL_WOOD_FAST, &
     HARV_POOL_WOOD_MED, HARV_POOL_WOOD_SLOW, &
     agf_bs, fsc_liv, fsc_wood
use vegn_tile_mod, only : &
     vegn_tile_type
use vegn_cohort_mod, only : &
     vegn_cohort_type, update_biomass_pools

implicit none
private

! ==== public interface ======================================================
public :: vegn_harvesting_init
public :: vegn_harvesting_end

public :: vegn_harvesting

public :: vegn_graze_pasture
public :: vegn_harvest_cropland
public :: vegn_cut_forest
! ==== end of public interface ===============================================

! ==== module constants =====================================================
character(len=*), parameter   :: &
     version = '$Id: vegn_harvesting.F90,v 17.0.4.1 2010/08/24 12:11:36 pjp Exp $', &
     tagname = '$Name: hiram_20101115_bw $', &
     module_name = 'vegn_harvesting_mod'
real, parameter :: ONETHIRD = 1.0/3.0

! ==== module data ==========================================================

! ---- namelist variables ---------------------------------------------------
logical :: do_harvesting       = .TRUE.  ! if true, then harvesting of crops and pastures is done
real :: grazing_intensity      = 0.25    ! fraction of biomass removed each time by grazing
real :: grazing_residue        = 0.1     ! fraction of the grazed biomass transferred into soil pools
real :: frac_wood_wasted_harv  = 0.25    ! fraction of wood wasted while harvesting
real :: frac_wood_wasted_clear = 0.25    ! fraction of wood wasted while clearing land for pastures or crops
real :: frac_wood_fast         = ONETHIRD ! fraction of wood consumed fast
real :: frac_wood_med          = ONETHIRD ! fraction of wood consumed with medium speed
real :: frac_wood_slow         = ONETHIRD ! fraction of wood consumed slowly
real :: crop_seed_density      = 0.1     ! biomass of seeds left after crop harvesting, kg/m2
namelist/harvesting_nml/ do_harvesting, grazing_intensity, grazing_residue, &
     frac_wood_wasted_harv, frac_wood_wasted_clear, &
     frac_wood_fast, frac_wood_med, frac_wood_slow, &
     crop_seed_density

contains ! ###################################################################

! ============================================================================
subroutine vegn_harvesting_init
  integer :: unit, ierr, io

  call write_version_number(version, tagname)

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=harvesting_nml, iostat=io)
  ierr = check_nml_error(io, 'harvesting_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file ( )
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=harvesting_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'harvesting_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=harvesting_nml)
  endif

  if (frac_wood_fast+frac_wood_med+frac_wood_slow/=1.0) then
     call error_mesg('vegn_harvesting_init', &
          'sum of frac_wood_fast, frac_wood_med, and frac_wood_slow must be 1.0',&
          FATAL)
  endif
end subroutine vegn_harvesting_init


! ============================================================================
subroutine vegn_harvesting_end
end subroutine vegn_harvesting_end


! ============================================================================
! harvest vegetation in a tile
subroutine vegn_harvesting(vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  if (.not.do_harvesting) &
       return ! do nothing if no harvesting requested

  select case(vegn%landuse)
  case(LU_PAST)  ! pasture
     call vegn_graze_pasture    (vegn)
  case(LU_CROP)  ! crop
     call vegn_harvest_cropland (vegn)
  end select
end subroutine


! ============================================================================
subroutine vegn_graze_pasture(vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  ! ---- local vars 
  real ::  bdead0, balive0, btotal0; ! initial combined biomass pools
  real ::  bdead1, balive1, btotal1; ! updated combined biomass pools
  type(vegn_cohort_type), pointer :: cc ! shorthand for the current cohort
  integer :: i

  balive0 = 0 ; bdead0 = 0 ;
  balive1 = 0 ; bdead1 = 0 ;

  ! update biomass pools for each cohort according to harvested fraction
  do i = 1,vegn%n_cohorts
     cc=>vegn%cohorts(i)
     ! calculate total biomass pools for the patch
     balive0 = balive0 + cc%bl + cc%blv + cc%br
     bdead0  = bdead0  + cc%bwood + cc%bsw
     ! only potential leaves are consumed
     vegn%harv_pool(HARV_POOL_PAST) = vegn%harv_pool(HARV_POOL_PAST) + &
          cc%bliving*cc%Pl*grazing_intensity*(1-grazing_residue) ;
     cc%bliving = cc%bliving - cc%bliving*cc%Pl*grazing_intensity;

     ! redistribute leftover biomass between biomass pools
     call update_biomass_pools(cc);
 
     ! calculate new combined vegetation biomass pools
     balive1 = balive1 + cc%bl + cc%blv + cc%br
     bdead1  = bdead1  + cc%bwood + cc%bsw
  enddo
  btotal0 = balive0 + bdead0
  btotal1 = balive1 + bdead1

  ! update intermediate soil carbon pools
  vegn%fsc_pool = vegn%fsc_pool + &
       (fsc_liv*(balive0-balive1)+fsc_wood*(bdead0-bdead1))*grazing_residue;
  vegn%ssc_pool = vegn%ssc_pool + &
       ((1-fsc_liv)*(balive0-balive1)+ (1-fsc_wood)*(bdead0-bdead1))*grazing_residue;
end subroutine vegn_graze_pasture


! ================================================================================
subroutine vegn_harvest_cropland(vegn)
  type(vegn_tile_type), intent(inout) :: vegn

  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc ! pointer to the current cohort
  real :: fraction_harvested;    ! fraction of biomass harvested this time
  real :: bdead, balive, btotal; ! combined biomass pools
  integer :: i
  
  balive = 0 ; bdead = 0
  ! calculate initial combined biomass pools for the patch
  do i = 1, vegn%n_cohorts
     cc=>vegn%cohorts(i)
     ! calculate total biomass pools for the patch
     balive = balive + cc%bl + cc%blv + cc%br
     bdead  = bdead  + cc%bwood + cc%bsw
  enddo
  btotal = balive+bdead;

  ! calculate harvested fraction: cut everything down to seed level
  fraction_harvested = MIN(MAX((btotal-crop_seed_density)/btotal,0.0),1.0);

  ! update biomass pools for each cohort according to harvested fraction
  do i = 1, vegn%n_cohorts
     cc=>vegn%cohorts(i)
     ! use for harvest only aboveg round living biomass and waste the correspondent below living and wood
     vegn%harv_pool(HARV_POOL_CROP) = vegn%harv_pool(HARV_POOL_CROP) + &
          cc%bliving*(cc%Pl + cc%Psw*agf_bs)*fraction_harvested;
     vegn%fsc_pool = vegn%fsc_pool + fraction_harvested*(fsc_liv*cc%bliving*cc%Pr + &
          fsc_wood*(cc%bwood + cc%bliving*cc%Psw*(1-agf_bs)));
     vegn%ssc_pool = vegn%ssc_pool + fraction_harvested*((1-fsc_liv)*cc%bliving*cc%Pr + &
          (1-fsc_wood)*(cc%bwood + cc%bliving*cc%Psw*(1-agf_bs)));

     cc%bliving = cc%bliving * (1-fraction_harvested);
     cc%bwood   = cc%bwood   * (1-fraction_harvested);
     ! redistribute leftover biomass between biomass pools
     call update_biomass_pools(cc);
  enddo
end subroutine vegn_harvest_cropland


! ============================================================================
! for now cutting forest is the same as harvesting cropland --
! we basically cut down everything, leaving only seeds
subroutine vegn_cut_forest(vegn, new_landuse)
  type(vegn_tile_type), intent(inout) :: vegn
  integer, intent(in) :: new_landuse ! new land use type that gets assigned to
                                     ! the tile after the wood harvesting

  ! ---- local vars
  type(vegn_cohort_type), pointer :: cc ! pointer to the current cohort
  real :: frac_harvested;        ! fraction of biomass harvested this time
  real :: frac_wood_wasted       ! fraction of wood wasted during transition
  real :: wood_harvested         ! anount of harvested wood, kgC/m2
  real :: bdead, balive, btotal; ! combined biomass pools
  real :: delta
  integer :: i
  
  balive = 0 ; bdead = 0
  ! calculate initial combined biomass pools for the patch
  do i = 1, vegn%n_cohorts
     cc=>vegn%cohorts(i)
     ! calculate total biomass pools for the patch
     balive = balive + cc%bl + cc%blv + cc%br
     bdead  = bdead  + cc%bwood + cc%bsw
  enddo
  btotal = balive+bdead;

  ! calculate harvested fraction: cut everything down to seed level
  frac_harvested = MIN(MAX((btotal-crop_seed_density)/btotal,0.0),1.0);

  ! define fraction of wood wasted, based on the transition type
  if (new_landuse==LU_SCND) then
     frac_wood_wasted = frac_wood_wasted_harv
  else
     frac_wood_wasted = frac_wood_wasted_clear
  endif

  ! update biomass pools for each cohort according to harvested fraction
  do i = 1, vegn%n_cohorts
     cc => vegn%cohorts(i)

     ! calculate total amount of harvested wood, minus the wasted part
     wood_harvested = (cc%bwood+cc%bsw)*frac_harvested*(1-frac_wood_wasted)

     ! distribute harvested wood between pools
     if (new_landuse==LU_SCND) then
        ! this is harvesting, distribute between 3 different wood pools 
        vegn%harv_pool(HARV_POOL_WOOD_FAST) = vegn%harv_pool(HARV_POOL_WOOD_FAST) &
             + wood_harvested*frac_wood_fast
        vegn%harv_pool(HARV_POOL_WOOD_MED) = vegn%harv_pool(HARV_POOL_WOOD_MED) &
             + wood_harvested*frac_wood_med
        vegn%harv_pool(HARV_POOL_WOOD_SLOW) = vegn%harv_pool(HARV_POOL_WOOD_SLOW) &
             + wood_harvested*frac_wood_slow
     else
        ! this is land clearance: everything goes into "cleared" pool
        vegn%harv_pool(HARV_POOL_CLEARED) = vegn%harv_pool(HARV_POOL_CLEARED) &
             + wood_harvested
     endif

     ! distribute wood and living biomass between fast and slow intermediate 
     ! soil carbon pools according to fractions specified thorough the namelists
     delta = (cc%bwood+cc%bsw)*frac_harvested*frac_wood_wasted;
     if(delta<0) call error_mesg('vegn_cut_forest', &
          'harvested amount of dead biomass ('//string(delta)//' kgC/m2) is below zero', &
          FATAL)
     vegn%ssc_pool = vegn%ssc_pool + delta*(1-fsc_wood);
     vegn%fsc_pool = vegn%fsc_pool + delta*   fsc_wood ;

     delta = balive * frac_harvested;
     if(delta<0) call error_mesg('vegn_cut_forest', &
          'harvested amount of live biomass ('//string(delta)//' kgC/m2) is below zero', &
          FATAL)
     vegn%ssc_pool = vegn%ssc_pool + delta*(1-fsc_liv) ;
     vegn%fsc_pool = vegn%fsc_pool + delta*   fsc_liv  ;

     cc%bliving = cc%bliving*(1-frac_harvested);
     cc%bwood   = cc%bwood*(1-frac_harvested);
     ! redistribute leftover biomass between biomass pools
     call update_biomass_pools(cc);
  enddo
end subroutine vegn_cut_forest

end module 


module vegn_photosynthesis_mod

#include "../shared/debug.inc"

use fms_mod,            only : write_version_number, error_mesg, FATAL
use constants_mod,      only : TFREEZE 
use sphum_mod,          only : qscomp

use land_constants_mod, only : BAND_VIS, Rugas,seconds_per_year, mol_h2o, mol_air
use land_debug_mod,     only : is_watch_point
use vegn_data_mod,      only : MSPECIES, PT_C4, spdata
use vegn_tile_mod,      only : vegn_tile_type
use vegn_cohort_mod,    only : vegn_cohort_type, get_vegn_wet_frac

implicit none
private

! ==== public interfaces =====================================================
public :: vegn_photosynthesis_init
public :: vegn_photosynthesis
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), private, parameter :: &
   version = '$Id: vegn_photosynthesis.F90,v 17.0 2009/07/21 03:03:26 fms Exp $', &
   tagname = '$Name:  $', &
   module_name = 'vegn_photosynthesis'
! values for internal vegetation photosynthesis option selector
integer, parameter :: VEGN_PHOT_SIMPLE  = 1 ! zero photosynthesis
integer, parameter :: VEGN_PHOT_LEUNING = 2 ! photosynthesis according to simplified Leuning model

! ==== module variables ======================================================
integer :: vegn_phot_option = -1 ! selector of the photosynthesis option


contains


! ============================================================================
subroutine vegn_photosynthesis_init(photosynthesis_to_use)
  character(*), intent(in) :: photosynthesis_to_use

  call write_version_number(version, tagname)

  ! convert symbolic names of photosynthesis options into numeric IDs to
  ! speed up selection during run-time
  if (trim(photosynthesis_to_use)=='simple') then
     vegn_phot_option = VEGN_PHOT_SIMPLE
  else if (trim(photosynthesis_to_use)=='leuning') then
     vegn_phot_option = VEGN_PHOT_LEUNING
  else
     call error_mesg('vegn_photosynthesis_init',&
          'vegetation photosynthesis option photosynthesis_to_use="'//&
          trim(photosynthesis_to_use)//'" is invalid, use "simple" or "leuning"',&
          FATAL)
  endif

end subroutine vegn_photosynthesis_init


! ============================================================================
! compute stomatal conductance, photosynthesis and respiration
subroutine vegn_photosynthesis ( vegn, &
     PAR_dn, PAR_net, cana_q, cana_co2, p_surf, drag_q, &
     soil_beta, soil_water_supply,&
     stomatal_cond, psyn, resp )
  type(vegn_tile_type), intent(in) :: vegn
  real, intent(in)  :: PAR_dn   ! downward PAR at the top of the canopy, W/m2 
  real, intent(in)  :: PAR_net  ! net PAR absorbed by the canopy, W/m2
  real, intent(in)  :: cana_q   ! specific humidity in canopy air space, kg/kg
  real, intent(in)  :: cana_co2 ! co2 concentration in canopy air space, mol CO2/mol dry air
  real, intent(in)  :: p_surf   ! surface pressure
  real, intent(in)  :: drag_q   ! drag coefficient for specific humidity
  real, intent(in)  :: soil_beta
  real, intent(in)  :: soil_water_supply ! max supply of water to roots per unit
                                ! active root biomass per second, kg/(m2 s)
  real, intent(out) :: stomatal_cond ! stomatal conductance, m/s(?)
  real, intent(out) :: psyn     ! net photosynthesis, mol C/(m2 s)
  real, intent(out) :: resp     ! leaf respiration, mol C/(m2 s)


  ! ---- local constants
  real, parameter :: res_scaler = 20.0    ! scaling factor for water supply

  ! ---- local vars
  type(vegn_cohort_type), pointer :: cohort
  integer :: sp ! shorthand for vegetation species
  real    :: water_supply ! water supply per m2 of leaves
  real    :: fw, fs ! wet and snow-covered fraction of leaves

  ! get the pointer to the first (and, currently, the only) cohort
  cohort => vegn%cohorts(1)

  select case (vegn_phot_option)

  case(VEGN_PHOT_SIMPLE)
     ! beta non-unity only for "beta" models
     stomatal_cond = soil_beta / (cohort%rs_min  + (1-soil_beta)/drag_q)
     cohort%An_op  = 0
     cohort%An_cl  = 0
     psyn = 0
     resp = 0

  case(VEGN_PHOT_LEUNING)
     if(cohort%lai > 0) then
        ! assign species type to local var, purely for convenience 
        sp = cohort%species
        ! recalculate the water supply to mol H20 per m2 of leaf per second
        water_supply = soil_water_supply/(mol_h2o*cohort%lai)
      
        call get_vegn_wet_frac (cohort, fw=fw, fs=fs)
        call gs_Leuning(PAR_dn, PAR_net, cohort%prog%Tv, cana_q, cohort%lai, &
             cohort%leaf_age, p_surf, water_supply, sp, cana_co2, &
             cohort%extinct, fs+fw, stomatal_cond, psyn, resp, cohort%pt)
        ! store the calculated photosythesis and fotorespiration for future use
        ! in carbon_int
        cohort%An_op  = psyn * seconds_per_year
        cohort%An_cl  = resp * seconds_per_year
        ! convert stomatal conductance, photosynthesis and leaf respiration from units
        ! per unit area of leaf to the units per unit area of land
        stomatal_cond = stomatal_cond*cohort%lai
        psyn          = psyn         *cohort%lai
        resp          = resp         *cohort%lai
     else
        ! no leaves means no photosynthesis and no stomatal conductance either
        cohort%An_op  = 0
        cohort%An_cl  = 0
        stomatal_cond = 0
        psyn          = 0
        resp          = 0
     endif

  case default
     call error_mesg('vegn_stomatal_cond', &
          'invalid vegetation photosynthesis option', FATAL)
  end select

end subroutine vegn_photosynthesis


! ============================================================================
subroutine gs_Leuning(rad_top, rad_net, tl, ea, lai, leaf_age, &
                   p_surf, ws, pft, ca, &
                   kappa, leaf_wet,  &
                   gs, apot, acl, pt)
  real,    intent(in)    :: rad_top ! PAR dn on top of the canopy, w/m2
  real,    intent(in)    :: rad_net ! PAR net on top of the canopy, w/m2
  real,    intent(in)    :: tl   ! leaf temperature, degK
  real,    intent(in)    :: ea   ! specific humidity in the canopy air (?), kg/kg
  real,    intent(in)    :: lai  ! leaf area index
  real,    intent(in)    :: leaf_age ! age of leaf since budburst (deciduos), days
  real,    intent(in)    :: p_surf ! surface pressure, Pa
  real,    intent(in)    :: ws   ! water supply, mol H20/(m2 of leaf s)
  integer, intent(in)    :: pft  ! species
  real,    intent(in)    :: ca   ! concentartion of CO2 in the canopy air space, mol CO2/mol dry air
  real,    intent(in)    :: kappa! canopy extinction coefficient (move inside f(pft))
  real,    intent(in)    :: leaf_wet ! fraction of leaf that's wet or snow-covered
  ! note that the output is per area of leaf; to get the quantities per area of
  ! land, multiply them by LAI
  real,    intent(out)   :: gs   ! stomatal conductance, m/s
  real,    intent(out)   :: apot ! net photosynthesis, mol C/(m2 s)
  real,    intent(out)   :: acl  ! leaf respiration, mol C/(m2 s)
  integer, intent(in)    :: pt   ! physiology type (C3 or C4)

  ! ---- local vars     
  ! photosynthesis
  real :: vm;
  real :: kc,ko; ! Michaelis-Menten constants for CO2 and O2, respectively
  real :: ci;
  real :: capgam; ! CO2 compensation point
  real :: f2,f3;
  real :: coef0,coef1;

  real :: Resp;

  ! conductance related
  real :: b;
  real :: ds;  ! humidity deficit, kg/kg
  real :: hl;  ! saturated specific humidity at the leaf temperature, kg/kg
  real :: do1;
  
  ! misceleneous
  real :: dum2;
  real, parameter :: light_crit = 0;
  real, parameter :: gs_lim = 0.25;

  ! new average computations
  real :: lai_eq;
  real, parameter :: rad_phot = 0.0000046 ! PAR conversion factor of J -> mol of quanta 
  real :: light_top;
  real :: par_net;
  real :: Ag;
  real :: An;
  real :: Ag_l;
  real :: Ag_rb;
  real :: anbar;
  real :: gsbar;
  real :: w_scale;
  real, parameter :: p_sea = 1.0e5 ! sea level pressure, Pa
  ! soil water stress
  real :: Ed,an_w,gs_w;

  if (is_watch_point()) then
     write(*,*) '####### gs_leuning input #######'
     __DEBUG2__(rad_top, rad_net)
     __DEBUG1__(tl)
     __DEBUG1__(ea)
     __DEBUG1__(lai)
     __DEBUG1__(leaf_age)
     __DEBUG1__(p_surf)
     __DEBUG1__(ws)
     __DEBUG1__(pft)
     __DEBUG1__(ca)
     __DEBUG1__(kappa)
     __DEBUG1__(leaf_wet)
     __DEBUG1__(pt)
     write(*,*) '####### end of ### gs_leuning input #######'
  endif

  b=0.01;
  do1=0.09 ; ! kg/kg
  if (pft < 2) do1=0.15;


  ! Convert Solar influx from W/(m^2s) to mol_of_quanta/(m^2s) PAR,
  ! empirical relationship from McCree is light=rn*0.0000046
  light_top = rad_top*rad_phot;
  par_net   = rad_net*rad_phot;
  
  ! calculate humidity deficit, kg/kg
  call qscomp(tl, p_surf, hl)
  ds = max(hl-ea,0.0)

  ! capgam=0.209/(9000.0*exp(-5000.0*(1.0/288.2-1.0/tl))); - Foley formulation, 1986

  ko=0.25   *exp(1400.0*(1.0/288.2-1.0/tl))*p_sea/p_surf;
  kc=0.00015*exp(6000.0*(1.0/288.2-1.0/tl))*p_sea/p_surf;
  vm=spdata(pft)%Vmax*exp(3000.0*(1.0/288.2-1.0/tl));
  !decrease Vmax due to aging of temperate deciduous leaves 
  !(based on Wilson, Baldocchi and Hanson (2001)."Plant,Cell, and Environment", vol 24, 571-583)
  if (spdata(pft)%leaf_age_tau>0 .and. leaf_age>spdata(pft)%leaf_age_onset) then
     vm=vm*exp(-(leaf_age-spdata(pft)%leaf_age_onset)/spdata(pft)%leaf_age_tau)
  endif

  capgam=0.5*kc/ko*0.21*0.209; ! Farquhar & Caemmerer 1982

  ! Find respiration for the whole canopy layer
  
  Resp=spdata(pft)%gamma_resp*vm*lai;
  Resp=Resp/((1.0+exp(0.4*(5.0-tl+TFREEZE)))*(1.0+exp(0.4*(tl-45.0-TFREEZE))));
  
  
  ! ignore the difference in concentrations of CO2 near
  !  the leaf and in the canopy air, rb=0.
 
  Ag_l=0.;
  Ag_rb=0.;
  Ag=0.;
  anbar=-Resp/lai;
  gsbar=b;

 
  ! find the LAI level at which gross photosynthesis rates are equal
  ! only if PAR is positive
  if ( light_top > light_crit ) then
     if (pt==PT_C4) then ! C4 species
        coef0=(1+ds/do1)/spdata(pft)%m_cond;
        ci=(ca+1.6*coef0*capgam)/(1+1.6*coef0);
        if (ci>capgam) then
           f2=vm;
           f3=18000.0*vm*ci;       
       
           dum2=min(f2,f3)
           
           ! find LAI level at which rubisco limited rate is equal to light limited rate
           lai_eq = -log(dum2/(kappa*spdata(pft)%alpha_phot*light_top))/kappa;
           lai_eq = min(max(0.0,lai_eq),lai) ! limit lai_eq to physically possible range

           ! gross photosynthesis for light-limited part of the canopy
           Ag_l   = spdata(pft)%alpha_phot * par_net &
                * (exp(-lai_eq*kappa)-exp(-lai*kappa))/(1-exp(-lai*kappa))
           ! gross photosynthesis for rubisco-limited part of the canopy
           Ag_rb  = dum2*lai_eq

           Ag=(Ag_l+Ag_rb)/ &
             ((1.0+exp(0.4*(5.0-tl+TFREEZE)))*(1.0+exp(0.4*(tl-45.0-TFREEZE))));
           An=Ag-Resp;
           anbar=An/lai;
     
           if(anbar>0.0) then
               gsbar=anbar/(ci-capgam)/coef0;
           endif
        endif ! ci>capgam
     else ! C3 species
        coef0=(1+ds/do1)/spdata(pft)%m_cond;
        coef1=kc*(1.0+0.209/ko);
        ci=(ca+1.6*coef0*capgam)/(1+1.6*coef0);
        f2=vm*(ci-capgam)/(ci+coef1);
        f3=vm/2.;
        dum2=min(f2,f3);
        if (ci>capgam) then
           ! find LAI level at which rubisco limited rate is equal to light limited rate
           lai_eq=-log(dum2*(ci+2.*capgam)/(ci-capgam)/ &
                       (spdata(pft)%alpha_phot*light_top*kappa))/kappa;
           lai_eq = min(max(0.0,lai_eq),lai) ! limit lai_eq to physically possible range

           ! gross photosynthesis for light-limited part of the canopy
           Ag_l   = spdata(pft)%alpha_phot * (ci-capgam)/(ci+2.*capgam) * par_net &
                * (exp(-lai_eq*kappa)-exp(-lai*kappa))/(1-exp(-lai*kappa))
           ! gross photosynthesis for rubisco-limited part of the canopy
           Ag_rb  = dum2*lai_eq

           Ag=(Ag_l+Ag_rb)/((1.0+exp(0.4*(5.0-tl+TFREEZE)))*(1.0+exp(0.4*(tl-45.0-TFREEZE))));
           An=Ag-Resp;
           anbar=An/lai;

           if(anbar>0.0) then
               gsbar=anbar/(ci-capgam)/coef0;
           endif
        endif ! ci>capgam
     endif
  endif ! light is available for photosynthesis
  
  an_w=anbar;
  if (an_w > 0.) then
     an_w=an_w*(1-spdata(pft)%wet_leaf_dreg*leaf_wet);
  endif
  
  gs_w=gsbar*(1-spdata(pft)%wet_leaf_dreg*leaf_wet);

  if (gs_w > gs_lim) then
      if(an_w > 0.) an_w = an_w*gs_lim/gs_w;
      gs_w = gs_lim;
  endif

#if 1
  ! find water availability
  ! diagnostic demand

  Ed=gs_w*ds*mol_air/mol_h2o;
  ! the factor mol_air/mol_h2o makes units of gs_w and humidity deficit ds compatible:
  ! ds*mol_air/mol_h2o is the humidity deficit in [mol_h2o/mol_air]

  if (Ed>ws) then
     w_scale=ws/Ed;
     gs_w=w_scale*gs_w;
     if(an_w > 0.0) an_w = an_w*w_scale;
     if(an_w < 0.0.and.gs_w >b) gs_w=b;
     if (is_watch_point()) then
        write(*,*)'#### gs is water-limited'
        __DEBUG1__(w_scale)
        __DEBUG3__(gs_w, an_w, b)
     endif
  endif
  gs=gs_w;
  apot=an_w;
  acl=-Resp/lai;
  

#else
! no water limitation on stomata
   gs=gsbar;  
   apot=anbar; 
   acl=-Resp/lai; 
#endif 

   ! finally, convert units of stomatal conductance to m/s from mol/(m2 s) by
   ! multiplying it by a volume of a mole of gas
   gs = gs * Rugas * Tl / p_surf

   if (is_watch_point()) then
      __DEBUG3__(gs, apot, acl)
   endif
end subroutine gs_Leuning

end module vegn_photosynthesis_mod


module vegn_radiation_mod

use fms_mod,            only : write_version_number, error_mesg, FATAL
use constants_mod,      only : stefan

use land_constants_mod, only : NBANDS
use vegn_data_mod,      only : spdata, min_cosz
use vegn_tile_mod,      only : vegn_tile_type
use vegn_cohort_mod,    only : vegn_cohort_type, vegn_data_cover, get_vegn_wet_frac
use snow_mod,           only : snow_radiation

use land_debug_mod,     only : is_watch_point 

implicit none
private

! ==== public interfaces =====================================================
public :: vegn_radiation_init
public :: vegn_radiation
! ==== end of public interfaces ==============================================

! ==== module constants ======================================================
character(len=*), private, parameter :: &
   version = '$Id: vegn_radiation.F90,v 17.0 2009/07/21 03:03:28 fms Exp $', &
   tagname = '$Name: hiram_20101115_bw $' ,&
   module_name = 'vegn_radiation'
! values for internal vegetation radiation option selector
integer, parameter :: VEGN_RAD_BIGLEAF   = 1 ! "big-leaf" radiation
integer, parameter :: VEGN_RAD_TWOSTREAM = 2 ! two-stream radiation code

! values for internal intercepted snow radiation properties selector -- currently
! works only for VEGN_RAD_TWOSTREAM
integer, parameter :: SNOW_RAD_IGNORE       = 1 ! no influence of intercepted snow
integer, parameter :: SNOW_RAD_PAINT_LEAVES = 2 ! intecepted snow modifies leaf 
   ! reflectance and transmittance

! ==== module variables ======================================================
integer :: vegn_rad_option = -1 ! selector of the current vegetation radiation option
integer :: snow_rad_option = -1 ! selector of the current snow rad properties option


contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


#define __DEBUG__(x) write(*,*) #x , x


! ============================================================================
! initialize vegetation radiation options
subroutine vegn_radiation_init(rad_to_use,snow_rad_to_use)
  character(*), intent(in) :: rad_to_use
  character(*), intent(in) :: snow_rad_to_use

  call write_version_number(version, tagname)

  ! convert symbolic names of radiation options into numeric IDs to
  ! speed up selection during run-time
  if(trim(rad_to_use)=='big-leaf') then
     vegn_rad_option = VEGN_RAD_BIGLEAF
  else if(trim(rad_to_use)=='two-stream') then
     vegn_rad_option = VEGN_RAD_TWOSTREAM
  else
     call error_mesg('vegn_radiation_init',&
          'vegetation radiation option rad_to_use="'//trim(rad_to_use)//'" is invalid, '// &
          'use "big-leaf" or "two-stream"',&
          FATAL)
  endif
  if (trim(snow_rad_to_use)=='ignore') then
     snow_rad_option = SNOW_RAD_IGNORE
  else if (trim(snow_rad_to_use)=='paint-leaves') then
     snow_rad_option = SNOW_RAD_PAINT_LEAVES
  else
     call error_mesg('vegn_radiation_init',&
          'vegetation radiation option snow_rad_to_use="'//trim(snow_rad_to_use)//'" is invalid, '// &
          'use "ignore" or "paint-leaves"',&
          FATAL)
  endif

end subroutine vegn_radiation_init


! ============================================================================
! compute vegetation-only properties needed to do soil-canopy-atmos 
! energy balance. in this version, also derive the aerodynamic soil-canopy
! variables, but probably this should be separated, like radiation is.
subroutine vegn_radiation ( vegn, &
     cosz, snow_depth, snow_refl_dif, snow_emis, &
     vegn_refl_dif, vegn_tran_dif, vegn_refl_dir, vegn_sctr_dir, vegn_tran_dir, &
     vegn_refl_lw, vegn_tran_lw )

  type(vegn_tile_type), intent(inout) :: vegn ! it is only inout because 
                                ! vegn_data_cover modifies cohort; cane we avoid this?
  real, intent(in)  :: cosz     ! cosine of zenith angle of direct (solar) beam
  real, intent(in)  :: snow_depth
  real, intent(in)  :: snow_refl_dif(NBANDS)
  real, intent(in)  :: snow_emis
  real, intent(out) :: &
       vegn_refl_dif(NBANDS), & ! reflectance of canopy for diffuse light
       vegn_tran_dif(NBANDS), & ! transmittance of canopy for diffuse light
       vegn_refl_dir(NBANDS), & ! reflectance of canopy for direct light
       vegn_sctr_dir(NBANDS), & ! part of direct light that is scattered downward
       vegn_tran_dir(NBANDS), & ! part of direct light that passes through the canopy unmolested
       vegn_refl_lw, & ! reflectance of canopy for long-wave (thermal) radiation 
       vegn_tran_lw    ! transmittance of canopy for long-wave (thermal) radiation

  ! ---- local vars 
  real :: vegn_cover, vegn_cover_snow_factor, vegn_lai, &
       vegn_leaf_refl(NBANDS), vegn_leaf_emis, vegn_K

  call vegn_data_cover ( vegn%cohorts(1), snow_depth, vegn_cover, vegn_cover_snow_factor )
  select case(vegn_rad_option)
  case(VEGN_RAD_BIGLEAF)
     call vegn_rad_properties_bigleaf ( vegn%cohorts(1), snow_refl_dif, snow_emis, &
          vegn_leaf_refl, vegn_leaf_emis, vegn_lai, vegn_K )
     vegn_refl_dif = vegn_cover * vegn_leaf_refl
     vegn_refl_dir = vegn_cover * vegn_leaf_refl
     vegn_tran_dif = 1 - vegn_cover 
     vegn_sctr_dir = 0
     vegn_tran_dir = 1 - vegn_cover
  case(VEGN_RAD_TWOSTREAM)
     call vegn_rad_properties_twostream ( vegn%cohorts(1), cosz, &
          vegn_refl_dif, vegn_tran_dif, &
          vegn_refl_dir, vegn_sctr_dir, vegn_tran_dir,&
          vegn_leaf_emis )
!
! ++++ pcm
     vegn_refl_dif = vegn_cover_snow_factor * vegn_refl_dif
     vegn_refl_dir = vegn_cover_snow_factor * vegn_refl_dir
     vegn_sctr_dir = vegn_cover_snow_factor * vegn_sctr_dir
     vegn_tran_dif = vegn_cover_snow_factor * vegn_tran_dif &
                       + (1-vegn_cover_snow_factor)
     vegn_tran_dir = vegn_cover_snow_factor * vegn_tran_dir &
                       + (1-vegn_cover_snow_factor)
! ---- pcm
!
  case default
     call error_mesg('vegn_radiation', &
          'invalid vegetation radiation option', FATAL)
  end select
  vegn_refl_lw       = vegn_cover * (1-vegn_leaf_emis)
  vegn_tran_lw       = 1 - vegn_cover

  ! store the extinction coefficients for use in photosynthesis calculations -- 
  ! currently calculated as if all light were direct
  vegn%cohorts(1)%extinct = &
       (spdata(vegn%cohorts(1)%species)%phi1+spdata(vegn%cohorts(1)%species)%phi2*cosz)&
       / max(cosz,min_cosz)

end subroutine vegn_radiation

! ============================================================================
! compute vegetation-only properties needed to do soil-canopy-atmos 
! energy balance.
subroutine vegn_rad_properties_bigleaf ( cohort, snow_refl, snow_emis, &
     vegn_leaf_refl, vegn_leaf_emis, vegn_lai, vegn_K )
  type(vegn_cohort_type), intent(in) :: cohort
  real, intent(in)  :: snow_refl(NBANDS), snow_emis
  real, intent(out) :: vegn_leaf_refl(NBANDS), vegn_leaf_emis, vegn_lai, vegn_K

  ! ---- local vars 
  real :: a_vs

  if ( cohort%Ws_max > 0 ) then
     a_vs = cohort%prog%Ws / cohort%Ws_max
     ! restrict snow-covered fraction to the interval [0,1]:
     a_vs = min(max(a_vs,0.0), 1.0)
  else
     a_vs = 0
  endif

  ! ---- snow-interception-adjusted radiative properties of vegetation ---------
  vegn_leaf_refl = cohort%leaf_refl + (snow_refl - cohort%leaf_refl)*a_vs
  vegn_leaf_emis = cohort%leaf_emis + (snow_emis - cohort%leaf_emis)*a_vs

  vegn_K = 2.  ! this is a temporary placeholder for now. value does not matter
               ! as long as substrate albedoes for dif/dir are the same.
  vegn_lai      = cohort%lai

end subroutine vegn_rad_properties_bigleaf


! ============================================================================
subroutine vegn_rad_properties_twostream( cohort, cosz, &
          vegn_refl_dif, vegn_tran_dif, &
          vegn_refl_dir, vegn_sctr_dir, vegn_tran_dir, &
          vegn_leaf_emis )
  type(vegn_cohort_type), intent(in) :: cohort
  real, intent(in) :: cosz ! cosine of direct light zenith angle
  real, intent(out), dimension(NBANDS) :: &
       vegn_refl_dif, & ! reflectance for diffuse light
       vegn_tran_dif, & ! transmittance for diffuse light 
       vegn_refl_dir, & ! reflectance for direct light
       vegn_sctr_dir, & ! part of direct light scattered downward (source of 
                        ! diffuse due to direct light scattering)
       vegn_tran_dir    ! transmittance of direct light 
  real, intent(out) :: &
       vegn_leaf_emis   ! emissivity of leaves

  ! ---- local constants
  real, parameter :: albedo_surf = 0.0 ! since we need values for black-background contribution

  ! ---- local vars
  integer :: i
  integer :: sp ! current species, solely to shorten the notation 
  real :: leaf_refl, leaf_tran ! optical properties of partially snow-covered leaves
  real :: snow_refl_dif(NBANDS) ! snow reflectances
  real :: snow_refl_dir(NBANDS), snow_refl_lw, snow_emis ! snow rad. properies (unused)
  real :: fs ! fractional coverage of intercepted snow

  ! get the snow fraction
  select case (snow_rad_option)
  case(SNOW_RAD_PAINT_LEAVES) 
     call get_vegn_wet_frac(cohort, fs=fs)
  case default
     fs = 0
  end select

  ! get the snow radiative properties for current canopy temperature
  call snow_radiation ( cohort%prog%Tv, cosz, snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis )

  sp = cohort%species
  do i = 1, NBANDS
     ! calculate the radiative properties of partially snow-covered leaves, assuming
     ! that the transmittance of snow is zero.
     leaf_refl = (1-fs)*cohort%leaf_refl(i) + fs*snow_refl_dif(i)
     leaf_tran = (1-fs)*cohort%leaf_tran(i)

     call twostream ( max(cosz, min_cosz), &
          spdata(sp)%mu_bar, cohort%lai, albedo_surf, &
          spdata(sp)%phi1, spdata(sp)%phi2, &
          leaf_refl, leaf_tran, &
          vegn_tran_dir(i), vegn_sctr_dir(i), vegn_refl_dir(i), &
          vegn_tran_dif(i), vegn_refl_dif(i)  )
  enddo

  vegn_leaf_emis = cohort%leaf_emis*(1-fs) + snow_emis*fs

end subroutine vegn_rad_properties_twostream


! ============================================================================
subroutine twostream( &
   mu, mu_bar, LAI, albedo_g, phi1, phi2, rl, tl, transm_dir, scatter_dir, albedo_dir, &
   transm_dif, albedo_dif )
   
  real, intent(in)  :: mu         ! cosine of direct light zenith angle
  real, intent(in)  :: mu_bar     ! average inverse diffuse optical depth per unit leaf area
  real, intent(in)  :: LAI        ! leaf area index
  real, intent(in)  :: albedo_g   ! ground surface albedo
  real, intent(in)  :: phi1, phi2 ! coefficients of expression for G_mu
  real, intent(in)  :: rl         ! reflectivity of leaves
  real, intent(in)  :: tl         ! transmittance of leaves
  ! output
  real, intent(out) :: transm_dir ! canopy transmittance for direct beam -- that 
                                  ! is, the part of the beam that passes through 
                                  ! the canopy untouched
  real, intent(out) :: scatter_dir! part of direct beam scattered down, at the 
                                  ! bottom of the canopy 
  real, intent(out) :: albedo_dir ! overall land surface albedo for direct beam 
  real, intent(out) :: transm_dif ! canopy transmittance for diffuse incident light
  real, intent(out) :: albedo_dif ! overall land surface albedo for diffuse incident light

  ! ---- local vars 
  real :: G_mu        ! relative projected leaf area in direction of direct beam
  real :: K           ! optical depth for direct beam per unit LAI
  real :: g1,g2,g3,g4 ! coefficients in the two-stream equation
  real :: kappa       ! eigenvalue of free solution
  real :: a_up, b_up, c_up ! coefficients of upward diffuse light flux
  real :: a_dn, b_dn, c_dn ! coefficients of downward diffuse light flux
  real :: x1,x2       ! intermediate coefficients
  real :: a11,a12,a21,a22, d1,d2 ! coefficients of linear system
  real :: D           ! determinant of the matrix
  real :: A,B         ! coefficients of diffuse light function
  real :: dif_dn_bot, dif_up_bot, dif_up_top
   
  real, parameter :: eta = 6.0; ! this value is suitable only for uniform leaf 
                                ! angular distribution !!!
   
  if(is_watch_point()) then
     write(*,*)'############ twostream input ############'
     __DEBUG__(mu)
     __DEBUG__(mu_bar)
     __DEBUG__(LAI)
     __DEBUG__(albedo_g)
     __DEBUG__(phi1)
     __DEBUG__(phi2)
     __DEBUG__(rl)
     __DEBUG__(tl)
     write(*,*)'############ twostream input ############'
  endif    
  ! calculate coefficients of optical path
  G_mu=phi1+phi2*mu;
  K = G_mu/mu;
 
  ! given optical parameters, calculate coefficients of basic equation
  g1 = (1-(rl+tl)/2+(rl-tl)/eta)/mu_bar;
  g2 = (  (rl+tl)/2+(rl-tl)/eta)/mu_bar;
  g3 = G_mu*((rl+tl)/2+mu*(rl-tl)/eta/G_mu);
  g4 = G_mu*((rl+tl)/2-mu*(rl-tl)/eta/G_mu);
   
  ! calculate eigenvalue of free solution (=exponent coefficient of 
  ! free solution, notes 12)
  kappa = sqrt(g1**2-g2**2);
   
  ! calculate forced term coefficients for diffuse light intensity
  c_up = ( K*g3-g1*g3-g2*g4)/(K*K-g1*g1+g2*g2);
  c_dn = (-K*g4-g1*g4-g2*g3)/(K*K-g1*g1+g2*g2);
  ! calculate intermediate coefficients for solution
  x1 = g1+g2+kappa; x2 = g1+g2-kappa;

  !write(*,*)mu,K,g1,g2,g3,g4,c_up,c_dn
   
  ! calculate coefficients of the matrix
  a11 = x2; 
  a12 = x1; 
  d1  = -c_dn;
  a21 = exp(kappa*LAI)*(x1-albedo_g*x2);
  a22 = exp(-kappa*LAI)*(x2-albedo_g*x1);
  d2  = exp(-K*LAI)*(albedo_g*c_dn + albedo_g*mu - c_up);
  ! solve the equation system 
  D = a11*a22-a12*a21;
  A = (d1*a22-d2*a12)/D;
  B = (a11*d2-a21*d1)/D;
  
  ! calculate coefficients of the diffuse light solution
  a_up = A*x1; b_up=B*x2;
  a_dn = A*x2; b_dn=B*x1;
  
  ! calculate downward diffuse light at the bottom of the canopy
  dif_dn_bot = a_dn*exp(kappa*LAI) + b_dn*exp(-kappa*LAI)+c_dn*exp(-K*LAI);
  dif_up_bot = a_up*exp(kappa*LAI) + b_up*exp(-kappa*LAI)+c_up*exp(-K*LAI);
  
  ! calculate canopy transmittance and scattered part for direct light
  scatter_dir = dif_dn_bot/mu; ! scatter
  transm_dir  = exp(-K*LAI); ! transmittance for unmolested direct light

  ! calculate canopy reflectance for direct light
  dif_up_top = a_up + b_up + c_up;
  albedo_dir = dif_up_top/mu;
     
  ! calculate upward diffuse light at the top of the canopy
  ! no need to recalculate D, since the matrix is the same
  d1 = 1.0;
  d2 = 0.0;
  A = (d1*a22-d2*a12)/D;
  B = (a11*d2-a21*d1)/D;

  ! calculate coefficients of the diffuse light solution
  a_up = A*x1; b_up=B*x2;
  a_dn = A*x2; b_dn=B*x1;
  
  transm_dif = a_dn*exp(kappa*LAI) + b_dn*exp(-kappa*LAI);
  albedo_dif = a_up + b_up;

  if(is_watch_point()) then
     write(*,*)'############ twostream output #############'
     __DEBUG__(transm_dir)
     __DEBUG__(scatter_dir)
     __DEBUG__(albedo_dir)
     __DEBUG__(transm_dif)
     __DEBUG__(albedo_dif)
     write(*,*)'############ end of twostream output #############'
  endif
end subroutine twostream

end module vegn_radiation_mod


module static_vegn_mod

use constants_mod,      only : pi
use mpp_mod,            only : mpp_max, mpp_sum
use time_manager_mod,   only : time_type, set_date, time_type_to_real, &
     get_calendar_type, valid_calendar_types, operator(-), get_date
use get_cal_time_mod,   only : get_cal_time

#ifdef INTERNAL_FILE_NML
use mpp_mod, only: input_nml_file
#else
use fms_mod, only: open_namelist_file
#endif

use fms_mod,            only : write_version_number, error_mesg, FATAL, NOTE, &
     mpp_pe, file_exist, close_file, check_nml_error, stdlog, &
     mpp_root_pe, get_mosaic_tile_file
use time_interp_mod,    only : time_interp
use diag_manager_mod,   only : get_base_date

use nf_utils_mod,       only : nfu_inq_dim, nfu_get_dim, nfu_def_dim, &
     nfu_inq_compressed_var, nfu_get_compressed_rec, nfu_validtype, &
     nfu_get_valid_range, nfu_is_valid, nfu_put_rec, nfu_put_att
use land_data_mod,      only : lnd
use land_io_mod,        only : print_netcdf_error
use land_numerics_mod,  only : nearest
use land_tile_io_mod,   only : create_tile_out_file,sync_nc_files
use land_tile_mod,      only : land_tile_type, land_tile_enum_type, first_elmt, &
     tail_elmt, next_elmt, current_tile, operator(/=), nitems
use vegn_cohort_mod,    only : vegn_cohort_type
use cohort_io_mod,      only : create_cohort_dimension, &
     write_cohort_data_i0d_fptr, write_cohort_data_r0d_fptr


implicit none
private

! ==== public interface =====================================================
public :: read_static_vegn_namelist
public :: static_vegn_init
public :: static_vegn_end

public :: read_static_vegn
public :: write_static_vegn
! ==== end of public interface ==============================================

! ==== module constants =====================================================
character(len=*), parameter :: &
     module_name = 'static_vegn_mod', &
     version     = '$Id: vegn_static_override.F90,v 17.0.2.3.2.1.2.1 2010/08/24 12:11:36 pjp Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'

! ==== module data ==========================================================
logical :: module_is_initialized = .FALSE.
integer :: ncid  ! netcdf id of the input file
integer :: ncid2 ! netcdf id of the output file
type(time_type),allocatable :: time_line(:) ! time line of input data
type(time_type)             :: ts,te        ! beginning and end of time interval
integer, allocatable :: map_i(:,:), map_j(:,:)! remapping arrays: for each of the
     ! land grid cells in current domain they hold indices of corresponding points 
     ! in the input grid.
type(time_type) :: base_time ! model base time for static vegetation output

! ---- namelist variables ---------------------------------------------------
logical :: use_static_veg = .FALSE.
character(len=512) :: input_file = & ! name of input file for static vegetation
     "INPUT/static_veg_data.nc"
character(len=10)  :: timeline   = 'normal' ! type of timeline ('normal' or 'loop')
integer, dimension(6) :: &
     start_loop = (/1,1,1,0,0,0/), & ! beginning of the time loop
     end_loop   = (/1,1,1,0,0,0/)    ! end of the time loop
logical :: fill_land_mask = .FALSE. ! if true, all the vegetation points on the
     ! map are filled with the information from static vegetation data, using
     ! nearest point remap; otherwise only the points that overlap with valid
     ! static vegetation data are overriden.
logical :: write_static_veg = .FALSE. ! if true, the state of vegetation is saved 
     ! periodically for future use as static vegetation input
character(16) :: static_veg_freq = 'daily' ! or 'monthly', or 'annual'
     ! specifies the frequency for writing the static vegetation data file
namelist/static_veg_nml/use_static_veg,input_file,timeline,start_loop,end_loop,&
     fill_land_mask, write_static_veg, static_veg_freq

! ==== NetCDF declarations ==================================================
include 'netcdf.inc'
#define __NF_ASRT__(x) call print_netcdf_error((x),__FILE__,__LINE__)

contains

! ===========================================================================
subroutine read_static_vegn_namelist(static_veg_used)
  logical, intent(out) :: static_veg_used

  ! ---- local vars
  integer :: unit, ierr, io

  call write_version_number(version, tagname)

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, nml=static_veg_nml, iostat=io)
  ierr = check_nml_error(io, 'static_veg_nml')
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file ( )
     ierr = 1;  
     do while (ierr /= 0)
        read (unit, nml=static_veg_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'static_veg_nml')
     enddo
10   continue
     call close_file (unit)
  endif
#endif
  
  if (mpp_pe() == mpp_root_pe()) then
     unit=stdlog()
     write(unit, nml=static_veg_nml)
  endif

  if (    (trim(static_veg_freq)=='daily') &
      .or.(trim(static_veg_freq)=='monthly') &
      .or.(trim(static_veg_freq)=='annual') ) then
     ! static_veg_freq is OK -- do nothing
  else
     call error_mesg('static_vegn_init','option static_veg_freq="'&
          //trim(static_veg_freq)&
          //'" is invalid, use "daily", "monthly", or "annual"', FATAL)
  endif

  static_veg_used = use_static_veg
end subroutine read_static_vegn_namelist


! ===========================================================================
subroutine static_vegn_init()

  ! ---- local vars
  integer :: unlimdim, timelen, timeid
  integer :: i,j,k,iret
  character(len=NF_MAX_NAME) :: dimname  ! name of the dimension variable : time, lon, and lat
  integer                    :: ndims    ! rank of input vars
  integer                    :: dimids (NF_MAX_VAR_DIMS) ! netcdf IDs of input var dimensions
  integer                    :: dimlens(NF_MAX_VAR_DIMS) ! sizes of respective dimensions
  real, allocatable          :: t(:)     ! temporary real timeline
  character(len=256)         :: units    ! units of time in the file
  character(len=256)         :: calendar ! calendar of the data
  real, allocatable          :: in_lon(:)! longitude coordinates in input file
  real, allocatable          :: in_lat(:)! latitude coordinates in input file
  logical, allocatable       :: mask(:,:)! mask of valid points in input data 
  integer, allocatable       :: data(:,:,:,:) ! temprary array used to calculate the mask of
                                         ! valid input data
  logical                    :: has_records ! true if input variable has records
  integer :: tile_dim_length ! length of tile dimension in output files 
                             ! global max of number of tiles per gridcell
  integer :: year, month, day, hour, minute, sec ! components of base date
  character(len=1024) :: actual_input_file
  logical :: input_is_multiface ! TRUE if the input files are face-specific

  if(module_is_initialized) return


  if(use_static_veg) then

     ! SET UP LOOP BOUNDARIES
     ts = set_date(start_loop(1),start_loop(2),start_loop(3), start_loop(4),start_loop(5),start_loop(6))
     te = set_date(end_loop(1)  ,end_loop(2)  ,end_loop(3)  , end_loop(4)  ,end_loop(5)  ,end_loop(6)  )
     
     ! OPEN INPUT FILE
     if (nf_open(input_file,NF_NOWRITE,ncid)/=NF_NOERR) then
        if(lnd%nfaces==1) then
           ! for 1-face grid we can't use multi-face input, even if it exists
           call error_mesg('static_vegn_init','input file "'//trim(input_file)&
                   //'" does not exist', FATAL)
        else
           ! if there's more then one face, try opening face-specific input
           call get_mosaic_tile_file(trim(input_file),actual_input_file,.FALSE.,lnd%domain)
           if (nf_open(actual_input_file,NF_NOWRITE,ncid)/=NF_NOERR) then
              call error_mesg('static_vegn_init','Neither "'//trim(input_file)&
                   //'" nor "'//trim(actual_input_file)//'" files exist', FATAL)
           else
              call error_mesg('static_vegn_init','Reading face-specific vegetation file "'&
                   //trim(actual_input_file)//'"', NOTE)
              input_is_multiface = .TRUE.
           endif
        endif
     else
        call error_mesg('static_vegn_init','Reading global static vegetation file "'&
             //trim(input_file)//'"', NOTE)
        input_is_multiface = .FALSE.
     endif
     
     ! READ TIME AXIS DATA
     __NF_ASRT__(nf_inq_unlimdim( ncid, unlimdim ))
     __NF_ASRT__(nf_inq_dimname ( ncid, unlimdim, dimname ))
     __NF_ASRT__(nf_inq_varid   ( ncid, dimname, timeid ))
     __NF_ASRT__(nf_inq_dimlen( ncid, unlimdim, timelen ))
     allocate (time_line(timelen), t(timelen))
     __NF_ASRT__(nf_get_var_double (ncid, timeid, t ))
     
     ! GET UNITS OF THE TIME
     units = ' '
     __NF_ASRT__(nf_get_att_text(ncid, timeid,'units',units))
     
     ! GET CALENDAR OF THE DATA
     calendar = ' '
     iret = nf_get_att_text(ncid, timeid, 'calendar',calendar)
     if(iret/=NF_NOERR) &
          iret = nf_get_att_text(ncid, timeid,'calendar_type',calendar)
     if(iret/=NF_NOERR) &
          calendar='JULIAN' ! use model calendar? how to get the name of the model calendar?
       
     ! CONVERT TIME TO THE FMS TIME_TYPE AND STORE IT IN THE TIMELINE FOR THE
     ! DATA SET
     do i = 1, size(t)
        ! set the respective value in the timeline
        time_line(i) = get_cal_time(t(i),units,calendar)
     enddo

     ! READ HORIZONTAL COORDINATES
     iret = nfu_inq_compressed_var(ncid,'species',ndims=ndims,dimids=dimids,dimlens=dimlens,&
          has_records=has_records)
     __NF_ASRT__(iret)
     allocate(in_lon(dimlens(1)),in_lat(dimlens(2)))
     __NF_ASRT__(nfu_get_dim(ncid,dimids(1),in_lon)) ! get longitude
     __NF_ASRT__(nfu_get_dim(ncid,dimids(2),in_lat)) ! get latitude
     in_lon = in_lon*PI/180.0 ; in_lat = in_lat*PI/180.0

     ! COMPUTE INDEX REMAPPING ARRAY
     allocate(map_i(lnd%is:lnd%ie,lnd%js:lnd%je))
     allocate(map_j(lnd%is:lnd%ie,lnd%js:lnd%je))
     allocate(mask(size(in_lon),size(in_lat)))

     if(fill_land_mask) then
        ! CALCULATE THE DIMENSIONS OF THE BUFFER FOR THE INPUT DATA
        if (has_records) ndims=ndims-1
        do i = ndims+1,4
           dimlens(i) = 1
        enddo
        ! READ THE FIRST RECORD AND CALCULTE THE MASK OF THE VALID INPUT DATA
        allocate(data(dimlens(1),dimlens(2),dimlens(3),dimlens(4)))
        !             lon        lat        tile       cohort
        data(:,:,:,:) = -1
        __NF_ASRT__(nfu_get_compressed_rec(ncid,'species',1,data))
        do j = 1,size(data,2)
        do i = 1,size(data,1)
           mask(i,j) = any(data(i,j,:,:)>=0)
        enddo
        enddo
        deallocate(data)
     else
        mask(:,:) = .TRUE.
     endif

     if(input_is_multiface) then
        ! check that the sizes of input data and the model data are the same
        if(dimlens(1)/=lnd%nlon.or.dimlens(2)/=lnd%nlat) then
           call error_mesg('static_vegn_init','size of face-specific static vegetation '&
                //'data isn''t the same as the size of the mosaic face', FATAL)
        endif
        ! in case of multi-face input, we don't do any remapping
        do j = lnd%js,lnd%je
        do i = lnd%is,lnd%ie
           map_i(i,j) = i; map_j(i,j) = j
        enddo
        enddo
     else
        ! do the nearest-point remapping
        do j = lnd%js,lnd%je
        do i = lnd%is,lnd%ie
           call nearest(mask,in_lon,in_lat,lnd%lon(i,j),lnd%lat(i,j),map_i(i,j),map_j(i,j))
        enddo
        enddo
     endif

     deallocate (in_lon,in_lat,mask)
     deallocate(t)
  endif

  if(write_static_veg) then
     ! create output file for static vegetation

     ! count all land tiles and determine the lenght of tile dimension
     ! sufficient for the current domain
     tile_dim_length = 0
     do j = lnd%js, lnd%je
     do i = lnd%is, lnd%ie
        k = nitems(lnd%tile_map(i,j))
        tile_dim_length = max(tile_dim_length,k)
     enddo
     enddo
   
     ! [1.1] calculate the tile dimension length by taking the max across all domains
     call mpp_max(tile_dim_length)

     call create_tile_out_file(ncid2,'static_veg_out.nc', &
          lnd%coord_glon, lnd%coord_glat, vegn_tile_exists, tile_dim_length)
     ! create compressed dimension for vegetation cohorts
     call create_cohort_dimension(ncid2)
     ! get the base date of the simulation
     call get_base_date(year,month,day,hour,minute,sec)
     base_time = set_date(year, month, day, hour, minute, sec)
     if(mpp_pe()==lnd%io_pelist(1)) then
        ! create time axis, on root IO processors only
        units = ' '
        write(units, 11) year, month, day, hour, minute, sec
11      format('days since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
        __NF_ASRT__(nfu_def_dim(ncid2,'time',NF_UNLIMITED,NF_DOUBLE,units=trim(units)))
        ! add calendar attribute to the time axis
        iret=nfu_put_att(ncid2,'time','calendar',&
             trim(valid_calendar_types(get_calendar_type())))
        __NF_ASRT__(iret)
     endif
     call sync_nc_files(ncid2)
  endif
  module_is_initialized = .true.

end subroutine static_vegn_init

! ===========================================================================
subroutine static_vegn_end()
  if(use_static_veg) then
     __NF_ASRT__(nf_close(ncid))
     deallocate(time_line,map_i,map_j)
  endif
  if(write_static_veg) then
     __NF_ASRT__(nf_close(ncid2))
  endif
  module_is_initialized = .false.
end subroutine static_vegn_end

! ===========================================================================
subroutine read_static_vegn (time)
  type(time_type), intent(in)    :: time

  ! ---- local vars 
  integer :: index1, index2 ! result of time interpolation (only index1 is used)
  real    :: weight         ! another result of time interp, not used
  character(len=256) :: err_msg

  if(.not.use_static_veg)return;

  !   time_interp to find out the index of the current time interval
  if (timeline == 'loop') then
     err_msg = ''
     call time_interp(time, ts, te, time_line, weight, index1, index2, &
                      correct_leap_year_inconsistency=.true.)
     if(err_msg /= '') then
       call error_mesg('subroutine read_static_vegn',trim(err_msg), FATAL)
     endif
  else if (timeline == 'normal') then
     call time_interp(time, time_line, weight, index1, index2)
  else
     call error_mesg(module_name,'timeline option "'//trim(timeline)// &
          '" is incorrect, use "normal" or "loop"', FATAL)
  endif

  ! read the data into cohort variables
  call read_remap_cohort_data_i0d_fptr(ncid, 'species' , cohort_species_ptr , map_i, map_j, index1)
  call read_remap_cohort_data_r0d_fptr(ncid, 'bl'      , cohort_bl_ptr      , map_i, map_j, index1)
  call read_remap_cohort_data_r0d_fptr(ncid, 'blv'     , cohort_blv_ptr     , map_i, map_j, index1)
  call read_remap_cohort_data_r0d_fptr(ncid, 'br'      , cohort_br_ptr      , map_i, map_j, index1)
  call read_remap_cohort_data_r0d_fptr(ncid, 'bsw'     , cohort_bsw_ptr     , map_i, map_j, index1)
  call read_remap_cohort_data_r0d_fptr(ncid, 'bwood'   , cohort_bwood_ptr   , map_i, map_j, index1)
  call read_remap_cohort_data_r0d_fptr(ncid, 'bliving' , cohort_bliving_ptr , map_i, map_j, index1)
  call read_remap_cohort_data_i0d_fptr(ncid, 'status'  , cohort_status_ptr  , map_i, map_j, index1)

  ! derived variables will be updated in update_land_bc_fast
end subroutine read_static_vegn


! ===========================================================================
subroutine write_static_vegn()

  real :: t ! time in output units
  integer :: rec ! number of record to write
  ! components of the date
  integer :: second, minute, hour, day0, day1, month0, month1, year0, year1

  if(.not.write_static_veg) return;

  ! get components of calendar dates for this and previous time step
  call get_date(lnd%time,             year0,month0,day0,hour,minute,second)
  call get_date(lnd%time-lnd%dt_fast, year1,month1,day1,hour,minute,second)

  if (     (trim(static_veg_freq)=='daily'  .and.  day1/=day0)   &
       .or.(trim(static_veg_freq)=='monthly'.and.month1/=month0) &
       .or.(trim(static_veg_freq)=='annual' .and. year1/=year0) )&
       then
     ! sync output files with the disk so that every processor sees the same 
     ! information, number of records being critical here
     call sync_nc_files(ncid2)
     ! get the current number of records in the output file
     __NF_ASRT__(nfu_inq_dim(ncid2,'time',rec))
     rec = rec+1
     ! create new record in the output file and store current value of time
     if(mpp_pe()==lnd%io_pelist(1)) then
        t = (time_type_to_real(lnd%time)-time_type_to_real(base_time))/86400
        __NF_ASRT__(nfu_put_rec(ncid2,'time',rec,t))
     endif
     ! write static vegetation data
     call write_cohort_data_i0d_fptr(ncid2,'species', cohort_species_ptr, &
          'vegetation species',record=rec)
     call write_cohort_data_r0d_fptr(ncid2,'bl',      cohort_bl_ptr, &
          'biomass of leaves per individual','kg C/m2', record=rec)
     call write_cohort_data_r0d_fptr(ncid2,'blv',     cohort_blv_ptr, &
          'biomass of virtual leaves (labile store) per individual','kg C/m2',record=rec)
     call write_cohort_data_r0d_fptr(ncid2,'br',      cohort_br_ptr, &
          'biomass of fine roots per individual','kg C/m2', record=rec)
     call write_cohort_data_r0d_fptr(ncid2,'bsw',     cohort_bsw_ptr, &
          'biomass of sapwood per individual','kg C/m2', record=rec)
     call write_cohort_data_r0d_fptr(ncid2,'bwood',   cohort_bwood_ptr, &
          'biomass of heartwood per individual','kg C/m2', record=rec)
     call write_cohort_data_r0d_fptr(ncid2,'bliving', cohort_bliving_ptr, &
          'total living biomass per individual','kg C/m2', record=rec)
     call write_cohort_data_i0d_fptr(ncid2,'status',  cohort_status_ptr, &
          'leaf status', record=rec)
  endif
end subroutine write_static_vegn


! ============================================================================
#define F90_TYPE       integer
#define READ_REMAP_SUB read_remap_cohort_data_i0d_fptr
#include "read_remap_cohort_data.inc"

#define F90_TYPE       real
#define READ_REMAP_SUB read_remap_cohort_data_r0d_fptr
#include "read_remap_cohort_data.inc"

! ============================================================================
! tile existence detector: returns a logical value indicating wether component
! model tile exists or not
logical function vegn_tile_exists(tile)
   type(land_tile_type), pointer :: tile
   vegn_tile_exists = associated(tile%vegn)
end function vegn_tile_exists

! ============================================================================
! cohort accessor functions: given a pointer to cohort, return a pointer to a
! specific member of the cohort structure
#define DEFINE_COHORT_ACCESSOR(xtype,x) subroutine cohort_ ## x ## _ptr(c,p);\
type(vegn_cohort_type),pointer::c;xtype,pointer::p;p=>NULL();if(associated(c))p=>c%x;\
end subroutine

DEFINE_COHORT_ACCESSOR(integer,species)
DEFINE_COHORT_ACCESSOR(real,bl)
DEFINE_COHORT_ACCESSOR(real,br)
DEFINE_COHORT_ACCESSOR(real,blv)
DEFINE_COHORT_ACCESSOR(real,bsw)
DEFINE_COHORT_ACCESSOR(real,bwood)
DEFINE_COHORT_ACCESSOR(real,bliving)
DEFINE_COHORT_ACCESSOR(integer,status)

end module static_vegn_mod


module vegn_tile_mod

use fms_mod, only : &
     write_version_number, stdlog, error_mesg, FATAL
use constants_mod, only : &
     tfreeze, hlf

use land_constants_mod, only : NBANDS
use land_io_mod, only : &
     init_cover_field
use land_tile_selectors_mod, only : &
     tile_selector_type, SEL_VEGN

use vegn_data_mod, only : &
     NSPECIES, MSPECIES, NCMPT, C2B, &
     read_vegn_data_namelist, spdata, &
     vegn_to_use,  input_cover_types, &
     mcv_min, mcv_lai, &
     vegn_index_constant, &
     agf_bs, BSEED, LU_NTRL, LU_SCND, N_HARV_POOLS, &
     LU_SEL_TAG, SP_SEL_TAG, NG_SEL_TAG, &
     SP_C3GRASS, SP_C4GRASS, &
     scnd_biomass_bins

use vegn_cohort_mod, only : vegn_cohort_type, vegn_phys_prog_type, &
     height_from_biomass, lai_from_biomass, update_bio_living_fraction, &
     cohort_uptake_profile, cohort_root_properties, update_biomass_pools

implicit none
private

! ==== public interfaces =====================================================
public :: vegn_tile_type

public :: new_vegn_tile, delete_vegn_tile
public :: vegn_tiles_can_be_merged, merge_vegn_tiles
public :: vegn_is_selected
public :: get_vegn_tile_tag
public :: vegn_tile_stock_pe
public :: vegn_tile_carbon ! returns total carbon per tile
public :: vegn_tile_heat ! returns hate content of the vegetation

public :: read_vegn_data_namelist
public :: vegn_cover_cold_start

public :: vegn_uptake_profile
public :: vegn_root_properties
public :: vegn_data_rs_min
public :: vegn_seed_supply
public :: vegn_seed_demand

public :: vegn_tran_priority ! returns transition priority for land use 

public :: vegn_add_bliving
public :: update_derived_vegn_data  ! given state variables, calculate derived values
! =====end of public interfaces ==============================================
interface new_vegn_tile
   module procedure vegn_tile_ctor
   module procedure vegn_tile_copy_ctor
end interface


! ==== module constants ======================================================
character(len=*), parameter   :: &
     version = '$Id: vegn_tile.F90,v 17.0.2.2.2.1.2.1 2010/06/28 14:44:58 pjp Exp $', & 
     tagname = '$Name: hiram_20101115_bw $', &
     module_name = 'vegn_tile_mod'

! ==== types =================================================================
type :: vegn_tile_type
   integer :: tag ! kind of the tile
   integer :: landuse = LU_NTRL

   integer :: n_cohorts = 0
   type(vegn_cohort_type), pointer :: cohorts(:)=>NULL()

   real :: age=0 ! tile age

   real :: fast_soil_C=0  ! fast soil carbon pool, (kg C/m2)
   real :: slow_soil_C=0  ! slow soil carbon pool, (kg C/m2)

   ! fields for smoothing out the contribution of the spike-type processes (e.g. 
   ! harvesting) to the soil carbon pools over some period of time
   real :: fsc_pool=0, fsc_rate=0 ! for fast soil carbon
   real :: ssc_pool=0, ssc_rate=0 ! for slow soil carbon

   real :: csmoke_pool=0 ! carbon lost through fires, kg C/m2 
   real :: csmoke_rate=0 ! rate of release of the above to atmosphere, kg C/(m2 yr)

   real :: harv_pool(N_HARV_POOLS) = 0. ! pools of harvested carbon, kg C/m2
   real :: harv_rate(N_HARV_POOLS) = 0. ! rates of spending (release to the atmosphere), kg C/(m2 yr)

   ! values for the diagnostic of carbon budget and soil carbon acceleration
   real :: asoil_in=0
   real :: ssc_in=0, ssc_out=0
   real :: fsc_in=0, fsc_out=0
   real :: veg_in=0, veg_out=0

   real :: disturbance_rate(0:1) = 0 ! 1/year
   real :: lambda = 0. ! cumulative drought months per year
   real :: fuel   = 0. ! fuel over dry months
   real :: litter = 0. ! litter flux

   ! monthly accumulated/averaged values
   real :: theta_av = 0. ! relative soil_moisture availability not soil moisture
   real :: tsoil_av = 0. ! bulk soil temperature
   real :: tc_av    = 0. ! leaf temperature
   real :: precip_av= 0. ! precipitation

   ! accumulation counters for long-term averages (monthly and annual). Having
   ! these counters in the tile is a bit stupid, since the values are the same for
   ! each tile, but it simplifies the current code, and they are going away when we
   ! switch to exponential averaging in any case.
   integer :: n_accum = 0. ! number of accumulated values for monthly averages
   integer :: nmn_acm = 0. ! number of accumulated values for annual averages
   ! annual-mean values
   real :: t_ann  = 0. ! annual mean T, degK
   real :: t_cold = 0. ! average temperature of the coldest month, degK
   real :: p_ann  = 0. ! annual mean precip
   real :: ncm    = 0. ! number of cold months
   ! annual accumulated values
   real :: t_ann_acm  = 0. ! accumulated annual temperature for t_ann
   real :: t_cold_acm = 0. ! temperature of the coldest month in current year
   real :: p_ann_acm  = 0. ! accumulated annual precipitation for p_ann
   real :: ncm_acm    = 0. ! accumulated number of cold months


   ! it's probably possible to get rid of the fields below
   real :: npp=0 ! net primary productivity
   real :: nep=0 ! net ecosystem productivity
   real :: rh=0 ! soil carbon lost to the atmosphere
   real :: total_biomass !
   real :: area_disturbed_by_treefall
   real :: area_disturbed_by_fire
   real :: total_disturbance_rate
end type vegn_tile_type

! ==== module data ===========================================================
real, public :: &
     cpw = 1952.0, & ! specific heat of water vapor at constant pressure
     clw = 4218.0, & ! specific heat of water (liquid)
     csw = 2106.0    ! specific heat of water (ice)

contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


! ============================================================================
function vegn_tile_ctor(tag) result(ptr)
  type(vegn_tile_type), pointer :: ptr ! return value
  integer, intent(in)  :: tag ! kind of tile

  allocate(ptr)
  ptr%tag = tag
end function vegn_tile_ctor

! ============================================================================
function vegn_tile_copy_ctor(vegn) result(ptr)
  type(vegn_tile_type), pointer :: ptr ! return value
  type(vegn_tile_type), intent(in) :: vegn ! return value

  allocate(ptr)
  ! copy all non-pointer members
  ptr=vegn
  ! copy pointer members (cohorts)
  allocate(ptr%cohorts(ptr%n_cohorts))
  ptr%cohorts(:) = vegn%cohorts(1:ptr%n_cohorts)
end function vegn_tile_copy_ctor

! ============================================================================
subroutine delete_vegn_tile(vegn)
  type(vegn_tile_type), pointer :: vegn

  deallocate(vegn%cohorts)
  deallocate(vegn)
end subroutine delete_vegn_tile

! =============================================================================
function vegn_tiles_can_be_merged(vegn1,vegn2) result(response)
  logical :: response
  type(vegn_tile_type), intent(in) :: vegn1,vegn2

  real    :: b1, b2 
  integer :: i, i1, i2

  if (vegn1%landuse /= vegn2%landuse) then
     response = .false. ! different land use tiles can't be merged
  else if (vegn1%landuse == LU_SCND) then ! secondary vegetation tiles
     ! get tile wood biomasses
     b1 = get_vegn_tile_bwood(vegn1)
     b2 = get_vegn_tile_bwood(vegn2)
     ! find biomass bins where each the tiles belongs to
     i1 = 0 ; i2 = 0
     do i = 1, size(scnd_biomass_bins(:))
        if (b1>scnd_biomass_bins(i)) i1 = i
        if (b2>scnd_biomass_bins(i)) i2 = i
     enddo
     ! tiles can be merged only if biomasses belong to the same bin
     response = (i1 == i2)
  else
     response = .true. ! non-secondary tiles of the same land use type can always be merged
  endif
end function


! ============================================================================
subroutine merge_vegn_tiles(t1,w1,t2,w2)
  type(vegn_tile_type), intent(in) :: t1
  type(vegn_tile_type), intent(inout) :: t2
  real, intent(in) :: w1, w2 ! relative weights
  
  ! ---- local vars
  real :: x1, x2 ! normalized relative weights
  real :: HEAT1, HEAT2 ! heat stored in respective canopies
  type(vegn_cohort_type), pointer :: c1, c2
  
  ! calculate normalized weights
  x1 = w1/(w1+w2)
  x2 = 1.0 - x1

  ! the following assumes that there is one, and only one, cohort per tile 
  c1 => t1%cohorts(1)
  c2 => t2%cohorts(1)
  ! define macro for merging cohort values
#define __MERGE__(field) c2%field = x1*c1%field + x2*c2%field
  HEAT1 = (clw*c1%prog%Wl + csw*c1%prog%Ws + c1%mcv_dry)*(c1%prog%Tv-tfreeze)
  HEAT2 = (clw*c2%prog%Wl + csw*c2%prog%Ws + c2%mcv_dry)*(c2%prog%Tv-tfreeze)
  __MERGE__(prog%Wl)
  __MERGE__(prog%Ws)

  __MERGE__(bl)      ! biomass of leaves, kg C/m2
  __MERGE__(blv)     ! biomass of virtual leaves (labile store), kg C/m2
  __MERGE__(br)      ! biomass of fine roots, kg C/m2
  __MERGE__(bsw)     ! biomass of sapwood, kg C/m2
  __MERGE__(bwood)   ! biomass of heartwood, kg C/m2
  __MERGE__(bliving) ! leaves, fine roots, and sapwood biomass

  ! should we do update_derived_vegn_data here? to get mcv_dry, etc
  call update_biomass_pools(c2)

  ! calculate the resulting dry heat capacity
  c2%mcv_dry = max(mcv_min,mcv_lai*c2%lai)
  ! update canopy temperature -- just merge it based on area weights if the heat 
  ! capacities are zero, or merge it based on the heat content if the heat contents
  ! are non-zero
  if(HEAT1==0.and.HEAT2==0) then
     __MERGE__(prog%Tv)
  else
     c2%prog%Tv = (HEAT1*x1+HEAT2*x2) / &
          (clw*c2%prog%Wl + csw*c2%prog%Ws + c2%mcv_dry) + tfreeze
  endif

#undef  __MERGE__
! re-define macro for tile values
#define __MERGE__(field) t2%field = x1*t1%field + x2*t2%field

  __MERGE__(age);
  
  __MERGE__(fast_soil_C)
  __MERGE__(slow_soil_C)
  
  __MERGE__(fsc_pool); __MERGE__(fsc_rate)
  __MERGE__(ssc_pool); __MERGE__(ssc_rate)

  __MERGE__(csmoke_pool)
  __MERGE__(csmoke_rate)

  __MERGE__(harv_pool)
  __MERGE__(harv_rate)

  ! do we need to merge these?
  __MERGE__(asoil_in)
  __MERGE__(ssc_in); __MERGE__(ssc_out)
  __MERGE__(fsc_in); __MERGE__(fsc_out)
  __MERGE__(veg_in); __MERGE__(veg_out)
  
  ! or these?
  __MERGE__(disturbance_rate)
  __MERGE__(lambda)     ! cumulative drought months per year
  __MERGE__(fuel)       ! fuel over dry months
  __MERGE__(litter)     ! litter flux

  ! monthly accumulated/averaged values
  __MERGE__(theta_av)   ! relative soil_moisture availability not soil moisture
  __MERGE__(tsoil_av)   ! bulk soil temperature
  __MERGE__(tc_av)      ! leaf temperature
  __MERGE__(precip_av)  ! precipitation
  __MERGE__(n_accum)    ! number of accumulated values for monthly averages
  __MERGE__(nmn_acm)    ! number of accumulated values for annual averages

  ! annual-mean values
  __MERGE__(t_ann)      ! annual mean T, degK
  __MERGE__(t_cold)     ! average temperature of the coldest month, degK
  __MERGE__(p_ann)      ! annual mean precip
  __MERGE__(ncm)        ! number of cold months

  ! annual accumulated values
  __MERGE__(t_ann_acm)  ! accumulated annual temperature for t_ann
  __MERGE__(t_cold_acm) ! temperature of the coldest month in current year
  __MERGE__(p_ann_acm)  ! accumulated annual precipitation for p_ann
  __MERGE__(ncm_acm)    ! accumulated number of cold months

#undef __MERGE__

end subroutine merge_vegn_tiles


! ============================================================================
! given a vegetation tile with the state variables set up, calculate derived
! parameters to get a consistent state
! NOTE: this subroutine does not call update_biomass_pools, although some 
! of the calculations are the same. The reason is because this function may 
! be used in the situation when the biomasses are not precisely consistent, for
! example when they come from the data override or from initial conditions.
subroutine update_derived_vegn_data(vegn)
  type(vegn_tile_type), intent(inout) :: vegn
  
  ! ---- local vars 
  type(vegn_cohort_type), pointer :: cc ! pointer to the current cohort
  integer :: i  ! cohort index
  integer :: sp ! shorthand for the vegetation species
  
  ! given that the cohort state variables are initialized, fill in
  ! the intermediate variables
  do i = 1,vegn%n_cohorts
    cc=>vegn%cohorts(i)
    
    sp = cc%species
    ! set the physiology type according to species
    cc%pt     = spdata(sp)%pt
    ! calculate total biomass, calculate height
    cc%b      = cc%bliving + cc%bwood
    cc%height = height_from_biomass(cc%b);
    ! update fractions of the living biomass
    call update_bio_living_fraction(cc)
    cc%bs     = cc%bsw + cc%bwood;   
    cc%bstem  = agf_bs*cc%bs;
    cc%babove = cc%bl + agf_bs*cc%bs; 

    if(sp<NSPECIES) then ! LM3V species
       ! calculate the leaf area index based on the biomass of leaves
       cc%lai = lai_from_biomass(cc%bl, sp)
       ! calculate the root density as the total biomass below ground, in
       ! biomass (not carbon!) units
       cc%root_density = (cc%br + (cc%bsw+cc%bwood+cc%blv)*(1-agf_bs))*C2B
    else
       cc%height        = spdata(sp)%dat_height
       cc%lai           = spdata(sp)%dat_lai
       cc%root_density  = spdata(sp)%dat_root_density
    endif
    cc%sai           = 0.035*cc%height
    cc%leaf_size     = spdata(sp)%leaf_size
    cc%root_zeta     = spdata(sp)%dat_root_zeta
    cc%rs_min        = spdata(sp)%dat_rs_min
    cc%leaf_refl     = spdata(sp)%leaf_refl
    cc%leaf_tran     = spdata(sp)%leaf_tran
    cc%leaf_emis     = spdata(sp)%leaf_emis
    cc%snow_crit     = spdata(sp)%dat_snow_crit
  
    ! putting this initialization within the cohort loop is probably incorrect 
    ! in case of multiple-cohort vegetation, however for a single cohort it works
    cc%Wl_max   = spdata(sp)%cmc_lai*cc%lai
    cc%Ws_max   = spdata(sp)%csc_lai*cc%lai
    cc%mcv_dry = max(mcv_min, mcv_lai*cc%lai)
  enddo
    
end subroutine update_derived_vegn_data

! ============================================================================
! returns the profiles of uptake used in the 'LINEAR' uptake option
subroutine vegn_uptake_profile(vegn, dz, uptake_frac_max, vegn_uptake_term)
  type(vegn_tile_type), intent(in)  :: vegn
  real,                 intent(in)  :: dz(:)
  real,                 intent(out) :: uptake_frac_max(:)
  real,                 intent(out) :: vegn_uptake_term(:)

  call cohort_uptake_profile(vegn%cohorts(1), dz, uptake_frac_max, vegn_uptake_term)
end subroutine


! ============================================================================
subroutine vegn_root_properties (vegn, dz, VRL, K_r, r_r)
  type(vegn_tile_type), intent(in)  :: vegn 
  real,                 intent(in)  :: dz(:)
  real, intent(out) :: &
       vrl(:), & ! volumetric fine root length, m/m3
       K_r,    & ! root membrane permeability per unit area, kg/(m3 s)
       r_r       ! radius of fine roots, m

  call cohort_root_properties(vegn%cohorts(1), dz, VRL, K_r, r_r)
end subroutine 


! ============================================================================
function vegn_data_rs_min ( vegn )
  real :: vegn_data_rs_min
  type(vegn_tile_type), intent(in)  :: vegn
  
  vegn_data_rs_min = vegn%cohorts(1)%rs_min
end function


! ============================================================================
function vegn_seed_supply ( vegn )
  real :: vegn_seed_supply
  type(vegn_tile_type), intent(in) :: vegn

  ! ---- local vars 
  real :: vegn_bliving
  integer :: i
  
  vegn_bliving = 0
  do i = 1,vegn%n_cohorts
     vegn_bliving = vegn_bliving + vegn%cohorts(i)%bliving
  enddo
  vegn_seed_supply = MAX (vegn_bliving-BSEED, 0.0)
  
end function 

! ============================================================================
function vegn_seed_demand ( vegn )
  real :: vegn_seed_demand
  type(vegn_tile_type), intent(in) :: vegn

  integer :: i

  vegn_seed_demand = 0
  do i = 1,vegn%n_cohorts
     if(vegn%cohorts(i)%bliving<BSEED.and.vegn%t_ann>253.16.and.vegn%p_ann>1E-6) then
        vegn_seed_demand = vegn_seed_demand + BSEED
     endif
  enddo
end function 

! ============================================================================
subroutine vegn_add_bliving ( vegn, delta )
  type(vegn_tile_type), intent(inout) :: vegn
  real :: delta ! increment of bliving

  vegn%cohorts(1)%bliving = vegn%cohorts(1)%bliving + delta

  if (vegn%cohorts(1)%bliving < 0)then
     call error_mesg('vegn_add_bliving','resulting bliving is less then 0', FATAL)
  endif
  call update_biomass_pools(vegn%cohorts(1))
end subroutine 





! ============================================================================
! given a vegetation patch, destination kind of transition, and "transition 
! intensity" value, this function returns a fraction of tile that will parti-
! cipate in transition.
!
! this function must be contiguous, monotonic, its value must be within
! interval [0,1]
!
! this function is used to determine what part of each tile is to be converted
! to another land use kind; the equation is solved to get "transition intensity" 
! tau for which total area is equal to requested. Tau is, therefore, a dummy
! parameter, and only relative values of the priority functions for tiles 
! participating in transition have any meaning. For most transitions the priority 
! function is just equal to tau: therefore there is no preference, and all tiles
! contribute equally to converted area. For secondary vegetation harvesting, 
! however, priority also depends on wood biomass, and therefore tiles
! with high wood biomass are harvested first.
function vegn_tran_priority(vegn, dst_kind, tau) result(pri)
  real :: pri
  type(vegn_tile_type), intent(in) :: vegn
  integer             , intent(in) :: dst_kind
  real                , intent(in) :: tau

  real :: vegn_bwood
  integer :: i

  if (vegn%landuse==LU_SCND.and.dst_kind==LU_SCND) then ! secondary biomass harvesting
     vegn_bwood = 0
     do i = 1,vegn%n_cohorts
        vegn_bwood = vegn_bwood + vegn%cohorts(i)%bwood
     enddo
     pri = max(min(tau+vegn_bwood,1.0),0.0)
  else
     pri = max(min(tau,1.0),0.0)
  endif
end function 


! ============================================================================
function vegn_cover_cold_start(land_mask, lonb, latb) result (vegn_frac)
! creates and initializes a field of fractional vegn coverage
  logical, intent(in) :: land_mask(:,:)    ! land mask
  real,    intent(in) :: lonb(:,:), latb(:,:)! boundaries of the grid cells
  real,    pointer    :: vegn_frac (:,:,:) ! output: map of vegn fractional coverage

  allocate( vegn_frac(size(land_mask,1),size(land_mask,2),MSPECIES))

  call init_cover_field(vegn_to_use, 'INPUT/cover_type.nc', 'cover','frac', &
       lonb, latb, vegn_index_constant, input_cover_types, vegn_frac)
  
end function 

! =============================================================================
! returns true if tile fits the specified selector
function vegn_is_selected(vegn, sel)
  logical vegn_is_selected
  type(tile_selector_type),  intent(in) :: sel
  type(vegn_tile_type),      intent(in) :: vegn

  select case (sel%idata1)
  case (LU_SEL_TAG)
     vegn_is_selected = (sel%idata2 == vegn%landuse)
  case (SP_SEL_TAG)
     if (.not.associated(vegn%cohorts)) then
        vegn_is_selected = .FALSE.
     else
        vegn_is_selected = (sel%idata2 == vegn%cohorts(1)%species)
     endif
  case (NG_SEL_TAG)
     if (.not.associated(vegn%cohorts)) then
        vegn_is_selected = .FALSE.
     else
        vegn_is_selected = &
             ((vegn%cohorts(1)%species==SP_C4GRASS) .or.&
              (vegn%cohorts(1)%species==SP_C3GRASS)).and.&
             ((vegn%landuse==LU_NTRL).or. &
              (vegn%landuse==LU_SCND))
     endif
  case default
     vegn_is_selected = .FALSE.
  end select  
     
end function


! ============================================================================
! returns tag of the tile
function get_vegn_tile_tag(vegn) result(tag)
  integer :: tag
  type(vegn_tile_type), intent(in) :: vegn
  
  tag = vegn%tag
end function

! ============================================================================
! returns total wood biomass per tile 
function get_vegn_tile_bwood(vegn) result(bwood)
  real :: bwood
  type(vegn_tile_type), intent(in) :: vegn

  ! ---- local vars
  integer :: i

  bwood = 0
  do i = 1,vegn%n_cohorts
     bwood = bwood + vegn%cohorts(i)%bwood
  enddo
end function

! ============================================================================
subroutine vegn_tile_stock_pe (vegn, twd_liq, twd_sol  )
  type(vegn_tile_type),  intent(in)    :: vegn
  real,                  intent(out)   :: twd_liq, twd_sol
  integer n
  
  twd_liq = 0.
  twd_sol = 0.
  do n=1, vegn%n_cohorts
    twd_liq = twd_liq + vegn%cohorts(n)%prog%wl
    twd_sol = twd_sol + vegn%cohorts(n)%prog%ws
!      vegn_HEAT  = (mcv + clw*cohort%prog%Wl+ csw*cohort%prog%Ws)*(cohort%prog%Tv-tfreeze)

    enddo
end subroutine vegn_tile_stock_pe


! ============================================================================
! returns total carbon in the tile, kg C/m2
function vegn_tile_carbon(vegn) result(carbon) ; real carbon
  type(vegn_tile_type), intent(in)  :: vegn

  integer :: i

  carbon = 0
  do i = 1,vegn%n_cohorts
     carbon = carbon + &
          vegn%cohorts(i)%bl + vegn%cohorts(i)%blv + &
          vegn%cohorts(i)%br + vegn%cohorts(i)%bwood + &
          vegn%cohorts(i)%bsw
  enddo
  carbon = carbon + &
       sum(vegn%harv_pool) + vegn%fsc_pool + vegn%ssc_pool + vegn%csmoke_pool
end function


! ============================================================================
! returns heat content of the vegetation, J/m2
function vegn_tile_heat (vegn) result(heat) ; real heat
  type(vegn_tile_type), intent(in)  :: vegn

  integer :: i

  heat = 0
  do i = 1, vegn%n_cohorts
     heat = heat + &
          (clw*vegn%cohorts(i)%prog%Wl + &
             csw*vegn%cohorts(i)%prog%Ws + &
             vegn%cohorts(i)%mcv_dry)*(vegn%cohorts(i)%prog%Tv-tfreeze) - &
           hlf*vegn%cohorts(i)%prog%Ws
  enddo
end function

end module vegn_tile_mod



module ocean_model_mod

!-----------------------------------------------------------------------

use time_manager_mod, only: time_type, operator(+), operator(>), &
                            get_date, set_time

use          fms_mod, only: file_exist, open_restart_file, &
                            close_file, mpp_pe, mpp_root_pe, mpp_npes,         &
                            write_version_number, stdlog, error_mesg, WARNING, FATAL, &
                            check_nml_error, write_data, set_domain, NOTE, &
                            field_exist, get_mosaic_tile_grid, read_data,  &
                            field_size

#ifdef INTERNAL_FILE_NML
use          mpp_mod, only: input_nml_file
#else
use          fms_mod, only: open_namelist_file
#endif

use  fms_io_mod,      only: get_restart_io_mode

use  amip_interp_mod, only: amip_interp_type, amip_interp_new,  &
                            amip_interp_del, get_amip_sst

use  mpp_domains_mod, only: domain1d, domain2d, mpp_define_domains,  &
                            mpp_get_compute_domain, mpp_get_compute_domains,  &
                            mpp_get_domain_components, mpp_get_pelist,  &
                            CYCLIC_GLOBAL_DOMAIN, mpp_define_layout
use          mpp_mod, only: mpp_npes, mpp_pe, mpp_root_pe, stdout,mpp_error, mpp_chksum

use    constants_mod, only: PI, RADIUS

use mosaic_mod,       only: get_mosaic_ntiles, get_mosaic_grid_sizes, get_mosaic_xgrid
use mosaic_mod,       only: get_mosaic_xgrid_size, calc_mosaic_grid_area

use coupler_types_mod,only: coupler_2d_bc_type

#ifdef SCM
use     scm_forc_mod, only: do_specified_tskin, TSKIN
#endif

implicit none
private

!-----------------------------------------------------------------------
!----------------- public interfaces -----------------------------------

public :: ocean_model_init, ocean_model_end, update_ocean_model, ocean_public_type, &
          ice_ocean_boundary_type, ocean_grids_type, &
          ocean_model_flux_init, ocean_model_init_sfc, ocean_stock_pe, ocean_model_restart
public :: ice_ocn_bnd_type_chksum, ocean_public_type_chksum

public    ocean_model_data_get
interface ocean_model_data_get
   module procedure ocean_model_data1D_get 
   module procedure ocean_model_data2D_get 
end interface

!
! the following type is for data exchange with the new coupler
! it is defined here but declared in coupler_main and allocated in flux_init
!
type ice_ocean_boundary_type
  real, dimension(:,:), pointer :: u_flux =>NULL(), &
                                   v_flux =>NULL(), &
                                   t_flux =>NULL(), &
                                   q_flux =>NULL(), &
                                   salt_flux =>NULL(), &
                                   lw_flux =>NULL(), &
                                   sw_flux_vis_dir =>NULL(), &
                                   sw_flux_vis_dif =>NULL(), &
                                   sw_flux_nir_dir =>NULL(), &
                                   sw_flux_nir_dif =>NULL(), &
                                   lprec =>NULL(), &
                                   fprec  =>NULL()
  real, dimension(:,:), pointer :: runoff =>NULL(), &
                                   calving  =>NULL(), &
                                   runoff_hflx  =>NULL(), &
                                   calving_hflx  =>NULL()
  real, dimension(:,:), pointer :: p  =>NULL()
  ! "data" is collective field for "named" fields above
  real, dimension(:,:,:), pointer :: data  =>NULL()
  integer :: xtype             !REGRID, REDIST or DIRECT used by coupler
  type(coupler_2d_bc_type)      :: fluxes  ! array of fields used for additional tracers
end type ice_ocean_boundary_type

!-----------------------------------------------------------------------

 type ocean_grids_type
    real,    pointer, dimension(:)   :: lon_bnd =>NULL(), lat_bnd =>NULL()
    real,    pointer, dimension(:,:)   :: lon =>NULL(), lat =>NULL()
    logical, pointer, dimension(:,:) :: mask  =>NULL()
 end type

!   lon_bnd    = longitude boundaries for grid boxes
!   lat_bnd    = latitude  boundaries for grid boxes
!   mask       = land-sea mask for grid boxes
!
!    note: longitude/latitude is in radians
!          mask is true for ocean points
!
!-----------------------------------------------------------------------

type ocean_public_type
   type (domain2d)               :: Domain
   type (ocean_grids_type)       :: Global, Data
   real, pointer, dimension(:,:) :: t_surf =>NULL() , &
                                    frazil =>NULL() ,  &
                                    u_surf =>NULL() , &
                                    v_surf =>NULL() , &
                                    s_surf =>NULL() , &
                                    area   =>NULL() , &
                                    sea_lev =>NULL()
   logical, pointer, dimension(:,:) :: maskmap =>NULL()! A pointer to an array indicating which
                                                       ! logical processors are actually used for
                                                       ! the ocean code. The other logical
                                                       ! processors would be all land points and
                                                       ! are not assigned to actual processors.
                                                       ! This need not be assigned if all logical
                                                       ! processors are used. This variable is dummy and need 
                                                       ! not to be set, but it is needed to pass compilation.
   type (time_type)              :: Time, &
                                    Time_step
   logical :: is_ocean_pe
   integer, pointer :: pelist(:) =>NULL()
   integer, dimension(3)            :: axes    
   type(coupler_2d_bc_type)         :: fields  ! array of fields used for additional tracers
end type ocean_public_type

!  Global = grid information for the global data grid
!  Data   = grid information for the local data grid
!
!  t_surf      = surface temperature on the local ocean model grid
!  frazil      = frazil on the local ocean model grid
!  u_surf      = zonal ocean current on the local ocean model grid
!  v_surf      = meridional ocean current on the local ocean model grid
!
!  Time      = current ocean model time
!  Time_step = ocean model time step
!
!    Notes: Global grid information will be the same on all processors
!           The data grid is global, but only the portion local to
!             the current processor is store in Data.
!-----------------------------------------------------------------------

  type, public ::  ocean_state_type; private
     ! This type is private, and can therefore vary between different ocean models.
     ! All information entire ocean state may be contained here, although it is not
     ! necessary that this is implemented with all models.
     logical       :: is_ocean_pe = .false.       ! .true. on processors that run the ocean model.
  end type ocean_state_type

!------- namelist ---------
   logical :: do_netcdf_restart = .true.
   logical :: use_climo_sst  = .false.
   logical :: use_annual_sst = .false.
   integer, dimension(2) :: layout = (/ 0, 0 /)
   character(len=64) :: interp_method  = "conservative" ! default, conservative scheme

!  layout =  domain decomposition (# X-PEs by # Y-PEs)
!             layout = (/0,0/) will use default rules
!
   namelist /ocean_model_nml/ do_netcdf_restart, use_climo_sst, use_annual_sst, layout, interp_method

!-----------------------------------------------------------------------
!--------------------- private below here ------------------------------

!  ---- version number -----

   character(len=128) :: version = '$Id: ocean_model.F90,v 17.0.2.1.4.1 2010/11/15 18:32:26 bw Exp $'
   character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
!------ model resolution parameters ------

   type (amip_interp_type), save :: Amip

   logical :: module_is_initialized=.false.
   logical :: stock_warning_issued =.false.

contains

!#######################################################################

 !#######################################################################
! <SUBROUTINE NAME="update_ocean_model">
!
! <DESCRIPTION>
! Update in time the ocean model fields. 
!   This subroutine uses the forcing in Ice_ocean_boundary to advance the
! ocean model's state from the input value of Ocean_state (which must be for
! time time_start_update) for a time interval of Ocean_coupling_time_step,
! returning the publicly visible ocean surface properties in Ocean_sfc and
! storing the new ocean properties in Ocean_state.
!
! Arguments: 
!  Ice_ocean_boundary - A structure containing the various forcing
!                                 fields coming from the ice. It is intent in.
!  Ocean_state - A structure containing the internal ocean state.
!  Ocean_sfc - A structure containing all the publicly visible ocean
!                        surface fields after a coupling time step.
!  time_start_update - The time at the beginning of the update step.
!  Ocean_coupling_time_step - The amount of time over which to advance
!                                       the ocean.

! Note: although several types are declared intent(inout), this is to allow for
!   the possibility of halo updates and to keep previously allocated memory.
!   In practice, Ice_ocean_boundary is intent in, Ocean_state is private to
!   this module and intent inout, and Ocean_sfc is intent out.
! </DESCRIPTION>
!
  subroutine update_ocean_model(Ice_ocean_boundary, Ocean_state, Ocean_sfc, &
       time_start_update, Ocean_coupling_time_step)
    type(ice_ocean_boundary_type), intent(inout) :: Ice_ocean_boundary
    type(ocean_state_type),        pointer       :: Ocean_state
    type(ocean_public_type),       intent(inout) :: Ocean_sfc
    type(time_type), intent(in)                  :: time_start_update
    type(time_type), intent(in)                  :: Ocean_coupling_time_step
    
    integer :: num_ocean_calls, no

 !check if required boundary fields have been initialized
      if ( .NOT.ASSOCIATED(Ice_ocean_boundary%sw_flux_vis_dir) .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%sw_flux_vis_dif) .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%sw_flux_nir_dir) .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%sw_flux_nir_dif) .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%lw_flux) .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%fprec)   .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%calving) .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%t_flux)  .OR. &
        .NOT.ASSOCIATED(Ice_ocean_boundary%q_flux) ) &
          call error_mesg( 'Update_ocean_model', &
           'Ice_ocean_boundary not correctly initialized.', FATAL )

!-----------------------------------------------------------------------
! ---- update time ----

      Ocean_sfc%Time = Ocean_sfc%Time + Ocean_coupling_time_step
!-----------------------------------------------------------------------
!----- update sst, set currents -----

      call set_ocean_model_state (Ocean_sfc)

!-----------------------------------------------------------------------

 end subroutine update_ocean_model

!#######################################################################

 subroutine set_ocean_model_state (Ocean_sfc)

   type (ocean_public_type), intent(inout) :: Ocean_sfc

!-----------------------------------------------------------------------
!----- get new sea surface temperature ------

       call get_amip_sst ( Ocean_sfc%Time, Amip, Ocean_sfc%t_surf )

#ifdef SCM
!--- for single column model -------------------------------------!
!--- initialize surface temperature to observed value ------------!  
       if (do_specified_tskin) then     
          Ocean_sfc%t_surf = TSKIN
       end if
!-----------------------------------------------------------------!
#endif

!-----------------------------------------------------------------------
!----- currents -----

   Ocean_sfc%u_surf = 0.0
   Ocean_sfc%v_surf = 0.0

!----- dummy out frazil ??? -----

   Ocean_sfc%frazil = 0.0
   Ocean_sfc%area   = 1.0

   Ocean_sfc%s_surf  = 0.0
   Ocean_sfc%sea_lev = 0.0
!-----------------------------------------------------------------------

 end subroutine set_ocean_model_state

!#######################################################################

subroutine ocean_model_init (Ocean, Ocean_state, Time_init, Time)
!
! <DESCRIPTION>
! Initialize the ocean model. 
! Arguments: 
!  Ocean (inout)  - A structure containing various publicly visible ocean
!                    surface properties after initialization.
!  Ocean_state (pointer)- A structure whose internal contents are private
!                    to ocean_model_mod that may be used to contain all
!                    information about the ocean's interior state.
!  Time_init (in) - The start time for the coupled model's calendar.
!  Time_in   (in) - The time at which to initialize the ocean model.
! </DESCRIPTION>

  type (ocean_public_type), intent(inout) :: Ocean
  type (ocean_state_type),  pointer       :: Ocean_state
  type (time_type),         intent(in)    :: Time_init, Time

  integer                              :: siz(4)
  integer                              :: unit, ierr, io, nlon, nlat
  integer                              :: isd, ied, jsd, jed
  integer                              :: i, j, npes
  logical, allocatable, dimension(:,:) :: global_mask
  integer, allocatable, dimension(:)   :: xextent, yextent
  real,    allocatable, dimension(:,:) :: geo_lonv, geo_latv, rmask, netr_mask
  real,    allocatable, dimension(:,:) :: geo_lont, geo_latt
  real,  allocatable, dimension(:,:,:) :: x_vert_T, y_vert_T
  real,    allocatable, dimension(:,:) :: tmpx, tmpy, garea
  real, allocatable, dimension(:)      :: xgrid_area(:)
  integer, allocatable, dimension(:)   :: i1, j1, i2, j2
  character(len=256)                   :: err_mesg
  character(len=80)                    :: domainname
  character(len=256)                   :: grid_file = "INPUT/grid_spec.nc"
  character(len=256)                   :: ocean_mosaic, tile_file
  character(len=256)                   :: axo_file      ! atmosXocean exchange grid file
  integer                              :: nx(1), ny(1)
  integer                              :: ntiles, nfile_axo, nxgrid, n, m
  integer                              :: grid_version
  integer, parameter                   :: VERSION_0 = 0  ! grid file with field geolon_t
  integer, parameter                   :: VERSION_1 = 1  ! grid file with field x_T
  integer, parameter                   :: VERSION_2 = 2  ! mosaic file


   if(module_is_initialized) return

     Ocean%Time      = Time

!   ----- read namelist -----

     if ( file_exist('input.nml')) then
#ifdef INTERNAL_FILE_NML
        read (input_nml_file, nml=ocean_model_nml, iostat=io)
        ierr = check_nml_error(io, 'ocean_model_nml')
#else
        unit = open_namelist_file ( )
        ierr=1
         do while (ierr /= 0)
           read  (unit, nml=ocean_model_nml, iostat=io, end=10)
           ierr = check_nml_error(io,'ocean_model_nml')
        enddo
 10     call close_file (unit)
#endif
     endif
     call get_restart_io_mode(do_netcdf_restart)

!   ----- write version number and namelist -----
     call write_version_number(version, tagname)

     if ( mpp_pe() == mpp_root_pe() ) then
          write (stdlog(),nml=ocean_model_nml)
     endif

    !--- get the grid size 
    if(field_exist(grid_file, 'geolon_t')) then
       grid_version = VERSION_0 
       call field_size( grid_file, 'geolon_t', siz)  
       nlon = siz(1)
       nlat = siz(2)        
    else if(field_exist(grid_file, 'x_T')) then
       grid_version = VERSION_1
       call field_size( grid_file, 'x_T', siz)
       nlon = siz(1)
       nlat = siz(2) 
    else if(field_exist(grid_file, 'ocn_mosaic_file') ) then ! read from mosaic file
       grid_version = VERSION_2
       call read_data(grid_file, "ocn_mosaic_file", ocean_mosaic)
       ocean_mosaic = "INPUT/"//trim(ocean_mosaic)
       ntiles = get_mosaic_ntiles(ocean_mosaic)
       if(ntiles .NE. 1) call error_mesg('ocean_model_init', ' ntiles should be 1 for ocean mosaic, contact developer', FATAL)
       call get_mosaic_grid_sizes( ocean_mosaic, nx, ny)
       nlon = nx(1)
       nlat = ny(1)
    else
       call error_mesg('ocean_model_init','x_T, geolon_t, ocn_mosaic_file does not exist in file '//trim(grid_file), FATAL )
    end if

    if( nlon .LE. 0 .or. nlat .LE. 0 ) call error_mesg('ocean_model_init', 'nlon and nlat should be a positive integer.', FATAL)

!-----------------------------------------------------------------------
!----- set up global storage and local storage -----

   allocate ( Ocean%Global%lon_bnd (nlon+1)  ,  &
              Ocean%Global%lat_bnd (nlat+1)  ,  &
              Ocean%Global%lon     (nlon, nlat),  &
              Ocean%Global%lat     (nlon, nlat),  &    
              Ocean%Global%mask    (nlon, nlat), &
              netr_mask            (nlon, nlat))

   allocate (rmask(nlon,nlat), geo_lont(nlon,nlat), geo_latt(nlon,nlat), &
             geo_lonv(1:nlon+1,1:nlat+1), geo_latv(1:nlon+1,1:nlat+1) )

!--- domain decompsition -----------------------------------------------
   npes = mpp_npes()

!---- domain decomposition ----

    if( layout(1).EQ.0 .AND. layout(2).EQ.0 ) &
         call mpp_define_layout( (/1,nlon,1,nlat/), mpp_npes(), layout )
    if( layout(1).NE.0 .AND. layout(2).EQ.0 )layout(2) = mpp_npes()/layout(1)
    if( layout(1).EQ.0 .AND. layout(2).NE.0 )layout(1) = mpp_npes()/layout(2)

    domainname = 'AMIP Ocean'
    call mpp_define_domains ( (/1,nlon,1,nlat/), layout, Ocean%Domain, name=domainname )
    call set_domain(Ocean%domain)

!----- grid information -----
    select case (grid_version)
    case(VERSION_0)
       call read_data(grid_file, "geolon_t",      geo_lont, no_domain=.TRUE. )
       call read_data(grid_file, "geolat_t",      geo_latt, no_domain=.TRUE. )
       call read_data(grid_file, "geolon_vert_t", geo_lonv, no_domain=.TRUE. )
       call read_data(grid_file, "geolat_vert_t", geo_latv, no_domain=.TRUE. )
       call read_data(grid_file, "wet",      rmask,     no_domain=.TRUE.)
    case(VERSION_1)
       allocate (x_vert_t(nlon,nlat,4), y_vert_t(nlon,nlat,4) ) 
       call read_data(grid_file, "x_T", geo_lont, no_domain=.TRUE. )
       call read_data(grid_file, "y_T", geo_latt, no_domain=.TRUE. )
       call read_data(grid_file, "x_vert_T", x_vert_t, no_domain=.TRUE.)
       call read_data(grid_file, "y_vert_T", y_vert_t, no_domain=.TRUE. )
       geo_lonv(1:nlon,1:nlat) = x_vert_t(1:nlon,1:nlat,1)
       geo_lonv(nlon+1,1:nlat) = x_vert_t(nlon,1:nlat,2)
       geo_lonv(1:nlon,nlat+1) = x_vert_t(1:nlon,nlat,4)
       geo_lonv(nlon+1,nlat+1) = x_vert_t(nlon,nlat,3)
       geo_latv(1:nlon,1:nlat) = y_vert_t(1:nlon,1:nlat,1)
       geo_latv(nlon+1,1:nlat) = y_vert_t(nlon,1:nlat,2)
       geo_latv(1:nlon,nlat+1) = y_vert_t(1:nlon,nlat,4)
       geo_latv(nlon+1,nlat+1) = y_vert_t(nlon,nlat,3)
       deallocate(x_vert_t, y_vert_t)
       call read_data(grid_file, "wet",      rmask,     no_domain=.TRUE.)
    case(VERSION_2)
       call get_mosaic_tile_grid(tile_file, ocean_mosaic, Ocean%Domain )
       allocate(tmpx(2*nlon+1, 2*nlat+1), tmpy(2*nlon+1, 2*nlat+1) )
       allocate(garea(nlon, nlat))
       call read_data(tile_file, "x", tmpx, no_domain=.TRUE.)
       call read_data(tile_file, "y", tmpy, no_domain=.TRUE.)
       do j = 1, nlat
          do i = 1, nlon
             geo_lont(i,j) = tmpx(i*2,j*2)
             geo_latt(i,j) = tmpy(i*2,j*2)
          end do
       end do
       do j = 1, nlat+1
          do i = 1, nlon+1
             geo_lonv(i,j) = tmpx(i*2-1,j*2-1)
             geo_latv(i,j) = tmpy(i*2-1,j*2-1)
          end do
       end do

       call calc_mosaic_grid_area(geo_lonv*pi/180., geo_latv*pi/180., garea )
       garea = garea/(4*PI*RADIUS*RADIUS)  ! scale the earth are to be 1
       call field_size(grid_file, "aXo_file", siz)
       nfile_axo = siz(2)
       rmask = 0.0
       do n = 1, nfile_axo
          call read_data(grid_file, "aXo_file", axo_file, level=n)
          axo_file = 'INPUT/'//trim(axo_file)
          nxgrid = get_mosaic_xgrid_size(axo_file)
          allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area(nxgrid))
          call get_mosaic_xgrid(aXo_file, i1, j1, i2, j2, xgrid_area)
          do m = 1, nxgrid
             i = i2(m); j = j2(m)
             rmask(i,j) = rmask(i,j) + xgrid_area(m)
          end do
          deallocate(i1, j1, i2, j2, xgrid_area)
       end do
       rmask = rmask/garea    

       deallocate(tmpx, tmpy, garea)
    end select

!--- for conservation interpolation, the grid should be rectangular ----
   if(trim(interp_method) == "conservative" ) then
      err_mesg = 'Bilinear interpolation must be used for a tripolar grid'
      do i=1,nlon+1
        if(any(geo_lonv(i,1) /= geo_lonv(i,:)))  &
            call error_mesg ('ocean_model_init',err_mesg,FATAL)
      enddo
      do j=1,nlat+1
         if(any(geo_latv(1,j) /= geo_latv(:,j)))  &
            call error_mesg ('ocean_model_init',err_mesg,FATAL)
      enddo
   endif

!--- define the ice data -----------------------------------------------
   Ocean%Global%mask = .false.
   where (rmask > 0) Ocean%Global%mask = .true.
   Ocean%Global%lon_bnd = geo_lonv(:,1)*pi/180.
   Ocean%Global%lat_bnd = geo_latv(1,:)*pi/180.
   Ocean%Global%lon = geo_lont*pi/180.
   Ocean%Global%lat = geo_latt*pi/180.

!--- release the memory ------------------------------------------------
deallocate(geo_lonv, geo_latv, geo_lont, geo_latt, rmask )

!----- write (to standard output?) domain decomposition -----

     if (allocated(xextent))  deallocate ( xextent, yextent )

     if ( mpp_pe() == mpp_root_pe() ) then
          allocate ( xextent(layout(1)), yextent(layout(2)) )
          call compute_extent ( Ocean%Domain, layout, xextent, yextent )
          write (stdout(),100)
          write (stdout(),110) xextent
          write (stdout(),120) yextent
      100 format ('OCEAN DATA DOMAIN DECOMPOSITION')
      110 format ('  X-AXIS = ',24i4,/,(11x,24i4))
      120 format ('  Y-AXIS = ',24i4,/,(11x,24i4))
          deallocate ( xextent, yextent )
     endif

!----- allocate for local (compute) domain ------

   call mpp_get_compute_domain ( Ocean%Domain, isd, ied, jsd, jed )

   allocate ( Ocean%Data%lon_bnd (isd:ied+1),      &
              Ocean%Data%lat_bnd (jsd:jed+1),      &
              Ocean%Data%lon (isd:ied, jsd:jed),   &
              Ocean%Data%lat (isd:ied, jsd:jed),   &
              Ocean%Data%mask    (isd:ied,jsd:jed) )

!  ---- set up local grid -----
   Ocean%Data%lon_bnd = Ocean%Global%lon_bnd(isd:ied+1)
   Ocean%Data%lat_bnd = Ocean%Global%lat_bnd(jsd:jed+1)
   Ocean%Data%lon = Ocean%Global%lon(isd:ied, jsd:jed)
   Ocean%Data%lat = Ocean%Global%lat(isd:ied, jsd:jed)

!------------ done domain decomposition --------------------------------
!=======================================================================
!-----------------------------------------------------------------------

   allocate ( Ocean%t_surf (isd:ied,jsd:jed), &
              Ocean%u_surf (isd:ied,jsd:jed), &
              Ocean%v_surf (isd:ied,jsd:jed), &
              Ocean%frazil (isd:ied,jsd:jed), &
              Ocean%area   (isd:ied,jsd:jed), &
              Ocean%s_surf (isd:ied,jsd:jed), &
              Ocean%sea_lev(isd:ied,jsd:jed))

     !Ocean%s_surf  = 0.0
     !Ocean%sea_lev = 0.0
!-----------------------------------------------------------------------

!---- maybe this should be on restart? -----
     ! Ocean%frazil = 0.0
     ! Ocean%area   = 1.0
! ---- initialize ocean model ocean/land mask -----


!  ---- read ocean mask from the restart file (must be present) -----
!      if ( file_exist('INPUT/ocean_model.res.nc')) then
!         if (mpp_pe() == mpp_root_pe()) call error_mesg ('ocean_model_mod', &
!           'Reading NetCDF formatted restart file: INPUT/ocean_model.res.nc', NOTE)
!        netr_mask = 0.0
!        call read_data('INPUT/ocean_model.res.nc', 'mask', netr_mask, no_domain=.TRUE.)
!        where(netr_mask .GT. 0.0)
!           Ocean%Global%mask = .true.
!        endwhere
!        deallocate(netr_mask)
!     else
!        if ( file_exist('INPUT/ocean_model.res')) then
!           if (mpp_pe() == mpp_root_pe()) call error_mesg ('ocean_model_mod', &
!                'Reading native formatted restart file.', NOTE)
!
!           unit = open_restart_file ('INPUT/ocean_model.res', 'read')
!
!        ---- read global field ----
!           read ( unit ) Ocean%Global%mask
!
!20         call close_file (unit)
!
!         endif
!      endif

!   ------ define Data masks ------

   !allocate (global_mask (nlon, nlat) )

   !global_mask = Ocean%Global%mask

   !Ocean%Data %mask    = global_mask    (isd:ied,jsd:jed)
    Ocean%Data %mask    = Ocean%Global%mask(isd:ied,jsd:jed)
    
   !deallocate ( global_mask )
!  ---- initialize other modules ----

   if(trim(interp_method) == "conservative") then
      Amip = amip_interp_new ( Ocean%Data%lon_bnd,            &
                               Ocean%Data%lat_bnd,            &
                               Ocean%Data%mask,               &
                               interp_method = interp_method, &
                               use_climo=use_climo_sst,       &
                               use_annual=use_annual_sst )
   else if(trim(interp_method) == "bilinear") then
      Amip = amip_interp_new ( Ocean%Data%lon,                &
                               Ocean%Data%lat,                &
                               Ocean%Data%mask,               &
                               interp_method = interp_method, &
                               use_climo=use_climo_sst,       &
                               use_annual=use_annual_sst )
   else
      call error_mesg('ice_model_init', 'interp_method should be conservative or bilinear', &
                      FATAL)
   endif

   call get_amip_sst ( Ocean%Time, Amip, Ocean%t_surf )

#ifdef SCM
!--- for single column model -------------------------------------!
!--- initialize surface temperature to observed value ------------!  
       if (do_specified_tskin) then     
          Ocean%t_surf = TSKIN
       end if
!-----------------------------------------------------------------!
#endif

!-----------------------------------------------------------------------
!----- set the initial state -------------

   call set_ocean_model_state (Ocean)

!-----------------------------------------------------------------------
   allocate(Ocean_state)
!------------------------------------------

   module_is_initialized = .true.

!-----------------------------------------------------------------------

 end subroutine ocean_model_init

!#######################################################################

 subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time)
  type(ocean_public_type),           intent(inout) :: Ocean_sfc
  type(ocean_state_type),            pointer       :: Ocean_state
  type(time_type),                   intent(in)    :: Time
!   This subroutine terminates the model run, saving the ocean state in a
! restart file and deallocating any data associated with the ocean.

! Arguments: Ocean_sfc - An ocean_public_type structure that is to be
!                        deallocated upon termination.
!  (inout)   Ocean_state - A pointer to the structure containing the internal
!                          ocean state to be deallocated upon termination.
!  (in)      Time - The model time, used for writing restarts.

  !real, dimension(:, :), allocatable :: netr_mask
   integer :: unit

   if(.not.module_is_initialized) return

  !allocate(netr_mask(size(Ocean_sfc%Global%mask, 1), size(Ocean_sfc%Global%mask, 2)))
  !netr_mask = 0.0
  !where ( Ocean_sfc%Global%mask)
  !   netr_mask = 1.0
  !endwhere

  !if( do_netcdf_restart ) then
  !   if (mpp_pe() == mpp_root_pe()) call error_mesg ('ocean_model_mod', &
  !        'Writing NetCDF formatted restart file: RESTART/ocean_model.res.nc', NOTE)
  !   call write_data('RESTART/ocean_model.res.nc', 'mask', netr_mask, no_domain=.true.)
  !else
  !   call set_domain(Ocean_sfc%Domain)
  !   if (mpp_pe() == mpp_root_pe()) call error_mesg ('ocean_model_mod', &
  !        'Writing native formatted restart file.', NOTE)
  !  unit = open_restart_file ('RESTART/ocean_model.res', 'write')
  !  call write_data ( unit, Ocean_sfc%Data%mask )

!    ---- write out model fields ----
!    ---- set domain for global i/o ----

  !  call close_file (unit)
  !endif
  !deallocate(netr_mask)
  call amip_interp_del(Amip)
  module_is_initialized = .false.
     
 end subroutine ocean_model_end

!#######################################################################
! <SUBROUTINE NAME="ocean_model_restart">
!
! <DESCRIPTION>
! dummy interface.
! Arguments: 
!   timestamp (optional, intent(in)) : A character string that represents the model time, 
!                                      used for writing restart. timestamp will append to
!                                      the any restart file name as a prefix. 
! </DESCRIPTION>
!
  subroutine ocean_model_restart(Ocean_state, timestamp)
     type(ocean_state_type),    pointer     :: Ocean_state
     character(len=*), intent(in), optional :: timestamp

    call error_mesg('ocean_model_restart(ocean_model_mod)', &
                     'intermediate restart capability is not implemented for this model', FATAL)

  end subroutine ocean_model_restart
! </SUBROUTINE> NAME="ocean_model_restart"

!#######################################################################
! dummy interface for ESM coupler
subroutine ocean_model_init_sfc(Ocean_state, Ocean)

type(ocean_state_type), pointer          :: Ocean_state
type(ocean_public_type), intent(in)      :: Ocean

return
end subroutine ocean_model_init_sfc

!#######################################################################
subroutine ocean_model_flux_init(Ocean_state)
type(ocean_state_type), pointer       :: Ocean_state

return
end subroutine ocean_model_flux_init
!#######################################################################

 subroutine compute_extent (Domain, layout, xsizelist, ysizelist) 
 type (domain2D), intent(in) :: Domain
 integer, intent(in) :: layout(2)
 integer, intent(out), optional :: xsizelist(:), ysizelist(:)
 integer, dimension(0:layout(1)*layout(2)-1) :: xsize, ysize
 integer :: i, j, xlist(layout(1)), ylist(layout(2))
 type (domain1D) :: Xdom, Ydom

   call mpp_get_compute_domains   ( Domain, xsize=xsize, ysize=ysize )
   call mpp_get_domain_components ( Domain, Xdom, Ydom )
   call mpp_get_pelist ( Xdom, xlist ) 
   call mpp_get_pelist ( Ydom, ylist ) 

     do i = 1, layout(1)
       xsizelist(i) = xsize(xlist(i))
     enddo

     do j = 1, layout(2)
       ysizelist(j) = ysize(ylist(j))
     enddo

 end subroutine compute_extent

!#######################################################################
! dummy routine

!
subroutine ocean_stock_pe(Ocean_state, index, value, time_index)
  type(ocean_state_type),pointer     :: Ocean_state
  integer,               intent(in)  :: index
  real,                  intent(out) :: value
  integer, optional,     intent(in)  :: time_index

  value = 0.0
  if (.not.associated(Ocean_state)) return
  if (.not.Ocean_state%is_ocean_pe) return
  if(.not.stock_warning_issued) then
     call error_mesg('ocean_stock_pe','Stocks not yet implemented. Returning zero.',NOTE)
     stock_warning_issued = .true.
  endif

  end subroutine ocean_stock_pe


subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc)
  type(ocean_state_type),     pointer    :: OS
  type(ocean_public_type),    intent(in) :: Ocean
  character(len=*)          , intent(in) :: name
  real, dimension(isc:,jsc:), intent(out):: array2D
  integer                   , intent(in) :: isc,jsc
  
  array2D(isc:,jsc:) = 0.0
  
end subroutine ocean_model_data2D_get

subroutine ocean_model_data1D_get(OS,Ocean, name, value)
  type(ocean_state_type),     pointer    :: OS
  type(ocean_public_type),    intent(in) :: Ocean
  character(len=*)          , intent(in) :: name
  real                      , intent(out):: value

  value = 0.0

end subroutine ocean_model_data1D_get


!#######################################################################

subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(ice_ocean_boundary_type), intent(in) :: iobt
 integer ::   n,m, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(atmos_land_boundary_type):: ', id, timestep
    write(outunit,100) 'iobt%u_flux         ', mpp_chksum( iobt%u_flux         )
    write(outunit,100) 'iobt%v_flux         ', mpp_chksum( iobt%v_flux         )
    write(outunit,100) 'iobt%t_flux         ', mpp_chksum( iobt%t_flux         )
    write(outunit,100) 'iobt%q_flux         ', mpp_chksum( iobt%q_flux         )
    write(outunit,100) 'iobt%salt_flux      ', mpp_chksum( iobt%salt_flux      )
    write(outunit,100) 'iobt%lw_flux        ', mpp_chksum( iobt%lw_flux        )
    write(outunit,100) 'iobt%sw_flux_vis_dir', mpp_chksum( iobt%sw_flux_vis_dir)
    write(outunit,100) 'iobt%sw_flux_vis_dif', mpp_chksum( iobt%sw_flux_vis_dif)
    write(outunit,100) 'iobt%sw_flux_nir_dir', mpp_chksum( iobt%sw_flux_nir_dir)
    write(outunit,100) 'iobt%sw_flux_nir_dif', mpp_chksum( iobt%sw_flux_nir_dif)
    write(outunit,100) 'iobt%lprec          ', mpp_chksum( iobt%lprec          )
    write(outunit,100) 'iobt%fprec          ', mpp_chksum( iobt%fprec          )
    write(outunit,100) 'iobt%runoff         ', mpp_chksum( iobt%runoff         )
    write(outunit,100) 'iobt%calving        ', mpp_chksum( iobt%calving        )
    write(outunit,100) 'iobt%p              ', mpp_chksum( iobt%p              )

100 FORMAT("CHECKSUM::",A32," = ",Z20)
    do n = 1, iobt%fluxes%num_bcs  !{
       do m = 1, iobt%fluxes%bc(n)%num_fields  !{
          write(outunit,101) 'iobt%',trim(iobt%fluxes%bc(n)%name), &
               trim(iobt%fluxes%bc(n)%field(m)%name), &
               mpp_chksum(iobt%fluxes%bc(n)%field(m)%values)
       enddo  !} m
    enddo  !} n
101 FORMAT("CHECKSUM::",A16,a,'%',a," = ",Z20)

end subroutine ice_ocn_bnd_type_chksum

subroutine ocean_public_type_chksum(id, timestep, ocn)

    character(len=*), intent(in) :: id
    integer         , intent(in) :: timestep
    type(ocean_public_type), intent(in) :: ocn
 integer ::   n,m, outunit
    
    outunit = stdout()

    write(outunit,*) 'BEGIN CHECKSUM(ocean_type):: ', id, timestep
    write(outunit,100) 'ocean%t_surf   ',mpp_chksum(ocn%t_surf )
    write(outunit,100) 'ocean%s_surf   ',mpp_chksum(ocn%s_surf )
    write(outunit,100) 'ocean%u_surf   ',mpp_chksum(ocn%u_surf )
    write(outunit,100) 'ocean%v_surf   ',mpp_chksum(ocn%v_surf )
    write(outunit,100) 'ocean%sea_lev  ',mpp_chksum(ocn%sea_lev)
    write(outunit,100) 'ocean%frazil   ',mpp_chksum(ocn%frazil )

    do n = 1, ocn%fields%num_bcs  !{
       do m = 1, ocn%fields%bc(n)%num_fields  !{
          write(outunit,101) 'ocean%',trim(ocn%fields%bc(n)%name), &
               trim(ocn%fields%bc(n)%field(m)%name), &
               mpp_chksum(ocn%fields%bc(n)%field(m)%values)
       enddo  !} m
    enddo  !} n
101 FORMAT("CHECKSUM::",A16,a,'%',a," = ",Z20)


100 FORMAT("CHECKSUM::",A32," = ",Z20)
end subroutine ocean_public_type_chksum

end module ocean_model_mod


module ocean_tpm_mod  !{
! 
!<CONTACT EMAIL="Richard.Slater@noaa.gov"> Richard D. Slater
!</CONTACT>
!
!<REVIEWER EMAIL="John.Dunne@noaa.gov"> John P. Dunne
!</REVIEWER>
!
!<OVERVIEW>
! Null version of Ocean tracer package module
!</OVERVIEW>
!
!<DESCRIPTION>
! Null version of Ocean tracer package module
!</DESCRIPTION>
!
! <INFO>
! </INFO>
!

!
!       Place tracer modules here
!

!
!       force all variables to be "typed"
!

implicit none

!
!       Set all variables to be private by default

private

!
!       Private routines
!

!
!       Public routines
!

!public ocean_tpm_bbc
!public ocean_tpm_end
!public ocean_tpm_init
public ocean_tpm_flux_init
!public ocean_tpm_sbc
!public ocean_tpm_source
!public ocean_tpm_start
!public ocean_tpm_tracer
public ocean_tpm_init_sfc
!public ocean_tpm_sum_sfc
!public ocean_tpm_avg_sfc
!public ocean_tpm_zero_sfc
!public ocean_tpm_sfc_end

!
!       private parameters
!

character(len=48), parameter                    :: mod_name = 'ocean_tpm_mod'

!
!       Public variables
!
!
!       Private variables
!

character(len=128) :: version = '$Id: ocean_tpm.F90,v 13.0 2006/03/28 21:23:57 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains

!#######################################################################
! <SUBROUTINE NAME="ocean_tpm_init_sfc">
!
! <DESCRIPTION>
!       call subroutines to perform surface coupler initializations
!
!       Note: this subroutine should be merged into ocean_tpm_start
! </DESCRIPTION>
!

subroutine ocean_tpm_init_sfc  !{

return

end subroutine ocean_tpm_init_sfc  !}
! </SUBROUTINE> NAME="ocean_tpm_init_sfc"

!#######################################################################
! <SUBROUTINE NAME="ocean_tpm_flux_init">
!
! <DESCRIPTION>
!       Set up any extra fields needed by the ocean-atmosphere gas fluxes
! </DESCRIPTION>
!

subroutine ocean_tpm_flux_init  !{

return

end subroutine ocean_tpm_flux_init  !}
! </SUBROUTINE> NAME="ocean_tpm_flux_init"

end module ocean_tpm_mod  !}



module amip_interp_mod


! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Provides observed SST and ice mask data sets that have been
!   interpolated onto your model's grid.
! </OVERVIEW>

! <DESCRIPTION>
! Three possible data sets are available:
!
!     1)  <LINK SRC="http://www-pcmdi.llnl.gov/amip">AMIP 1</LINK>        from Jan 1979 to Jan 1989 (2 deg x 2 deg)<BR/>
!     2)  <LINK SRC="amip_interp.rey_oi.txt">Reynolds OI</LINK>   from Nov 1981 to Jan 1999 (1 deg x 1 deg)<BR/>
!     3)  <LINK SRC="ftp://podaac.jpl.nasa.gov/pub/sea_surface_temperature/reynolds/rsst/doc/rsst.html">Reynolds EOF</LINK>  from Jan 1950 to Dec 1998 (2 deg x 2 deg)<BR/><BR/>
!
!     All original data are observed monthly means. This module
!     interpolates linearly in time between pairs of monthly means.
!     Horizontal interpolation is done using the horiz_interp module.
!
!     When a requested date falls outside the range of dates available
!     a namelist option allows for use of the climatological monthly
!     mean values which are computed from all of the data in a particular
!     data set.
! </DESCRIPTION>

! <DATASET NAME="AMIP 1">
!   from Jan 1979 to Jan 1989 (2 deg x 2 deg).
! </DATASET>
! <DATASET NAME="Reynolds OI">
!   from Nov 1981 to Jan 1999 (1 deg x 1 deg)
!             The analysis uses in situ and satellite SST's plus
!             SST's simulated by sea-ice cover.
! </DATASET>
! <DATASET NAME="Reynolds EOF">
!   from Jan 1950 to Dec 1998 (2 deg x 2 deg)
!             NCEP Reynolds Historical Reconstructed Sea Surface Temperature
!             The analysis uses both in-situ SSTs and satellite derived SSTs
!             from the NOAA Advanced Very High Resolution Radiometer.
!             In-situ data is used from 1950 to 1981, while both AVHRR derived
!             satellite SSTs and in-situ data are used from 1981 to the
!             end of 1998.
!
! Note: The data set used by this module have been reformatted as 32-bit IEEE.
!   The data values are packed into 16-bit integers.
!
!   The data sets are read from the following files:
!
!         amip1           INPUT/amip1_sst.data
!         reynolds_io     INPUT/reyoi_sst.data
!         reynolds_eof    INPUT/reynolds_sst.data
! </DATASET>
!-----------------------------------------------------------------------

use  time_interp_mod, only: time_interp, fraction_of_year

use time_manager_mod, only: time_type, operator(+), operator(>), &
                             get_date, set_time, set_date

use  horiz_interp_mod, only: horiz_interp_init, horiz_interp,  &
                             horiz_interp_new, horiz_interp_del, &
                             horiz_interp_type, assignment(=)

use           fms_mod, only: file_exist, error_mesg, write_version_number,  &
                             NOTE, WARNING, FATAL, stdlog, check_nml_error, &
                             open_namelist_file, open_ieee32_file,          &
                             mpp_pe, close_file, lowercase, mpp_root_pe,    &
                             NOTE, mpp_error, fms_error_handler
use        fms_io_mod, only: read_data
use     constants_mod, only: TFREEZE, pi
use      platform_mod, only: R4_KIND, I2_KIND
use mpp_mod,           only: input_nml_file

implicit none
private

!-----------------------------------------------------------------------
!----------------- Public interfaces -----------------------------------

public amip_interp_init, get_amip_sst, get_amip_ice, amip_interp_new, &
       amip_interp_del, amip_interp_type, assignment(=)

!-----------------------------------------------------------------------
!----------------- Public Data -----------------------------------
integer :: i_sst = 1200
integer :: j_sst = 600
logical :: forecast_mode = .false.
real, allocatable, dimension(:,:) ::  sst_ncep, sst_anom

public i_sst, j_sst, sst_ncep, sst_anom, forecast_mode

!-----------------------------------------------------------------------
!--------------------- private below here ------------------------------

!  ---- version number -----

character(len=128) :: version = '$Id: amip_interp.F90,v 18.0.4.1 2010/08/31 14:21:36 z1l Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

   real, allocatable:: temp1(:,:), temp2(:,:)

!-----------------------------------------------------------------------
!------ private defined data type --------

type date_type
   sequence
   integer :: year, month, day
end type

interface assignment(=)
  module procedure  amip_interp_type_eq
end interface

interface operator (==)
   module procedure date_equals
end interface

interface operator (/=)
   module procedure date_not_equals
end interface

interface operator (>)
   module procedure date_gt
end interface

! <INTERFACE NAME="amip_interp_new">
!   <OVERVIEW>
!     Function that initializes data needed for the horizontal
!         interpolation between the sst grid and model grid. The 
!         returned variable of type amip_interp_type is needed when
!         calling get_amip_sst and get_amip_ice.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Function that initializes data needed for the horizontal
!         interpolation between the sst grid and model grid. The 
!         returned variable of type amip_interp_type is needed when
!         calling get_amip_sst and get_amip_ice.
!   </DESCRIPTION>
!   <IN NAME="lon">
!     Longitude in radians of the model's grid box edges (1d lat/lon grid case)
!     or at grid box mid-point (2d case for arbitrary grids).
!   </IN>
!   <IN NAME="lat">
!     Latitude in radians of the model's grid box edges (1d lat/lon grid case)
!     or at grid box mid-point (2d case for arbitrary grids).
!   </IN>
!   <IN NAME="mask">
!     A mask for the model grid.
!   </IN>
!   <IN NAME="use_climo">
!     Flag the specifies that monthly mean climatological values will be used.
!   </IN>
!   <IN NAME="use_annual">
!     Flag the specifies that the annual mean climatological
!              will be used.  If both use_annual = use_climo = true,
!              then use_annual = true will be used.
!   </IN>
!   <IN NAME="interp_method">
!     specify the horiz_interp scheme. = "conservative" means conservative scheme, 
!     = "bilinear" means  bilinear interpolation.
!   </IN>
!   <OUT NAME="Interp">
!     A defined data type variable needed when calling get_amip_sst and get_amip_ice.
!   </OUT>
!   <TEMPLATE>
!     Interp = amip_interp_new ( lon, lat, mask, use_climo, use_annual, interp_method )
!   </TEMPLATE>

!   <NOTE>
!     This function may be called to initialize multiple variables
!     of type amip_interp_type.  However, there currently is no
!     call to release the storage used by this variable.
!   </NOTE>
!   <NOTE>
!     The size of input augment mask must be a function of the size
!     of input augments lon and lat. The first and second dimensions
!     of mask must equal (size(lon,1)-1, size(lat,2)-1).
!   </NOTE>

!   <ERROR MSG="the value of the namelist parameter DATA_SET being used is not allowed" STATUS="FATAL">
!     Check the value of namelist variable DATA_SET.
!   </ERROR>
!   <ERROR MSG="requested input data set does not exist" STATUS="FATAL">
!     The data set requested is valid but the data does not exist in
!      the INPUT subdirectory. You may have requested amip2 data which
!      has not been officially set up.
!      See the section on DATA SETS to properly set the data up.
!   </ERROR>
!   <ERROR MSG="use_climo mismatch" STATUS="FATAL">
!     The namelist variable date_out_of_range = 'fail' and the amip_interp_new
!     argument use_climo = true.  This combination is not allowed.
!   </ERROR>
!   <ERROR MSG="use_annual(climo) mismatch" STATUS="FATAL">
!     The namelist variable date_out_of_range = 'fail' and the amip_interp_new
!     argument use_annual = true.  This combination is not allowed.
!   </ERROR>
interface amip_interp_new
   module procedure amip_interp_new_1d
   module procedure amip_interp_new_2d
end interface
! </INTERFACE>


!-----------------------------------------------------------------------
!----- public data type ------
! <DATA NAME="amip_interp_type"  TYPE="type (horiz_interp_type)"  >
!   All variables in this data type are PRIVATE. It contains information
!   needed by the interpolation module (exchange_mod) and buffers data.
! </DATA>
type amip_interp_type
   private
   type (horiz_interp_type) :: Hintrp
   real, pointer            ::    data1(:,:) =>NULL(), &
                                  data2(:,:) =>NULL()
   type (date_type)         ::    Date1,       Date2
   logical                  :: use_climo, use_annual
   logical                  :: I_am_initialized=.false.
end type

!-----------------------------------------------------------------------
!  ---- resolution/grid variables ----

   integer :: mobs, nobs
   real, allocatable :: lon_bnd(:), lat_bnd(:)

!  ---- global unit & date ----

   integer, parameter :: maxc = 128
   integer :: unit
   character(len=maxc) :: file_name_sst, file_name_ice

   type (date_type) :: Curr_date = date_type( -99, -99, -99 )
   type (date_type) :: Date_end  = date_type( -99, -99, -99 )

   real             :: tice_crit_k
   integer(I2_KIND) ::  ice_crit

   logical :: module_is_initialized = .false.

!-----------------------------------------------------------------------
!---- namelist ----

! <NAMELIST NAME="amip_interp_nml">
!   <DATA NAME="data_set" TYPE="character(len=24)" DEFAULT="data_set = 'amip1'">
!     Name/type of SST data that will be used.
!  <BR/>
!        Possible values (case-insensitive) are: <BR/>
!                          1) amip1<BR/>
!                          2) reynolds_eof<BR/>
!                          3) reynolds_oi<BR/>
!        See the <LINK SRC="amip_interp.html#DATA SETS">data set </LINK>section for more on these data.
!   </DATA>

!   <DATA NAME="date_out_of_range" TYPE="character(len=16)" DEFAULT="date_out_of_range = 'fail'">
!     Controls the use of climatological monthly mean data when
!     the requested date falls outside the range of the data set.<BR/>
!     Possible values are:
!     <PRE>
!   fail      - program will fail if requested date is prior
!               to or after the data set period.
!   initclimo - program uses climatological requested data is
!               prior to data set period and will fail if
!               requested date is after data set period.
!   climo     - program uses climatological data anytime.
!    </PRE>
!   </DATA>

!   <DATA NAME="tice_crit" TYPE="real" DEFAULT="tice_crit = -1.80">
!     Freezing point of sea water in degC or degK.
!   </DATA>
!   <DATA NAME="verbose" TYPE="integer" DEFAULT="verbose = 0">
!     Controls printed output, 0 <= verbose <= 3
!   </DATA>

!---- additional parameters for controlling zonal prescribed sst ----
!---- these parameters only have an effect when use_zonal=.true. ----
!   <DATA NAME="use_zonal" TYPE="logical" DEFAULT=".false.">
!     Flag to selected zonal sst or data set.
!   </DATA>
!   <DATA NAME="teq" TYPE="real" DEFAULT="teq=305.">
!     sst at the equator.
!   </DATA>
!   <DATA NAME="tdif" TYPE="real" DEFAULT="tdif=50.">
!     Equator to pole sst difference.
!   </DATA>
!   <DATA NAME="tann" TYPE="real" DEFAULT="tann=20.">
!     Amplitude of annual cycle.
!   </DATA>
!   <DATA NAME="tlag" TYPE="real" DEFAULT="tlag=0.875">
!     Offset for time of year (for annual cycle).
!   </DATA>

!   <DATA NAME="amip_date" TYPE="integer(3)" DEFAULT="/-1,-1,-1/">
!     Single calendar date in integer "(year,month,day)" format
!     that is used only if set with year>0, month>0, day>0. 
!     If used, model calendar date is replaced by this date, 
!     but model time of day is still used to determine ice/sst.
!     Used for repeating-single-day (rsd) experiments.
!   </DATA>

!   <DATA NAME="sst_pert" TYPE="real" DEFAULT="sst_pert=0.">
!     Temperature perturbation in degrees Kelvin added onto the SST.
!                The perturbation is globally-uniform (even near sea-ice).
!                It is only used when abs(sst_pert) > 1.e-4.  SST perturbation runs
!                may be useful in accessing model sensitivities.
!   </DATA>
 character(len=24) :: data_set = 'amip1'   !  use 'amip1'
                                           !      'amip2'
                                           !      'reynolds_eof'
                                           !      'reynolds_oi'
                                           !      'hurrell'

 character(len=16) :: date_out_of_range = 'fail'  !  use 'fail'
                                                  !      'initclimo'
                                                  !      'climo' 

 real    :: tice_crit    = -1.80       !  in degC or degK
 integer :: verbose      = 0           !  0 <= verbose <= 3

!parameters for prescribed zonal sst option
 logical :: use_zonal    = .false.
 real :: teq  = 305.
 real :: tdif = 50.
 real :: tann = 20.
 real :: tlag = 0.875


!amip date for repeating single day (rsd) option
 integer :: amip_date(3)=(/-1,-1,-1/)

!global temperature perturbation used for sensitivity experiments
 real :: sst_pert = 0.

! SJL: During nudging:   use_ncep_sst = .T.;  no_anom_sst = .T.
!      during forecast:  use_ncep_sst = .T.;  no_anom_sst = .F.
! For seasonal forecast: use_ncep_ice = .F.

 logical :: use_ncep_sst = .false.
 logical ::  no_anom_sst = .true.
 logical :: use_ncep_ice = .true.
 logical :: interp_oi_sst = .true.        ! changed to false for regular runs

 namelist /amip_interp_nml/ use_ncep_sst, no_anom_sst, use_ncep_ice,  tice_crit, &
                            interp_oi_sst, data_set, date_out_of_range,          &
                            use_zonal, teq, tdif, tann, tlag, amip_date,         &
                            sst_pert, verbose, i_sst, j_sst, forecast_mode
! </NAMELIST>


!-----------------------------------------------------------------------

contains

!#######################################################################
! <SUBROUTINE NAME="get_amip_sst" INTERFACE="get_amip_sst">
!   <IN NAME="Time" TYPE="time_type" ></IN>
!   <OUT NAME="sst" TYPE="real" DIM="(:,:)"> </OUT>                  
!   <INOUT NAME="Interp" TYPE="amip_interp_type"> </INOUT>
! </SUBROUTINE>

subroutine get_amip_sst (Time, Interp, sst, err_msg)

   type (time_type),         intent(in)    :: Time
   type (amip_interp_type),  intent(inout) :: Interp
   real,                     intent(out)   ::  sst(:,:)
   character(len=*), optional, intent(out) :: err_msg

   real, dimension(mobs,nobs) :: sice

    integer :: year1, year2, month1, month2
    real    :: fmonth
    type (date_type) :: Date1, Date2, Udate1, Udate2

    type(time_type) :: Amip_Time
    integer :: tod(3),dum

    if(present(err_msg)) err_msg = ''
    if(.not.Interp%I_am_initialized) then
      if(fms_error_handler('get_amip_sst','The amip_interp_type variable is not initialized',err_msg)) return
    endif

!-----------------------------------------------------------------------
!----- compute zonally symetric sst ---------------

    if ( use_ncep_sst .and. forecast_mode ) no_anom_sst = .false.

    if (all(amip_date>0)) then
       call get_date(Time,dum,dum,dum,tod(1),tod(2),tod(3))
       Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3))
    else
       Amip_Time = Time
    endif

 if ( .not. allocated(temp1) ) allocate (temp1(mobs,nobs))
 if ( .not. allocated(temp2) ) allocate (temp2(mobs,nobs))
       
if (use_zonal) then
   call zonal_sst (Amip_Time, sice, temp1)
   call horiz_interp ( Interp%Hintrp, temp1, sst )
else

!-----------------------------------------------------------------------
!---------- get new observed sea surface temperature -------------------

! ---- time interpolation for months -----
   call time_interp (Amip_Time, fmonth, year1, year2, month1, month2)
! ---- force climatology ----
   if (Interp % use_climo) then
       year1=0; year2=0
   endif
   if (Interp % use_annual) then
        year1=0;  year2=0
       month1=0; month2=0
   endif
! ---------------------------

   Date1 = date_type( year1, month1, 0 )
   Date2 = date_type( year2, month2, 0 )

!  -- open/rewind file --
   unit = -1
!-----------------------------------------------------------------------


    if (Date1 /= Interp % Date1) then
!       ---- use Date2 for Date1 ----
        if (Date1 == Interp % Date2) then
            Interp % Date1 = Interp % Date2
            Interp % data1 = Interp % data2
        else
            call read_record ('sst', Date1, Udate1, temp1)
            if ( use_ncep_sst .and. (.not. no_anom_sst) ) then
                 temp1(:,:) = temp1(:,:) + sst_anom(:,:)
            endif
            call horiz_interp ( Interp%Hintrp, temp1, Interp%data1 )
            call clip_data ('sst', Interp%data1)
            Interp % Date1 = Date1
        endif
    endif

!-----------------------------------------------------------------------

    if (Date2 /= Interp % Date2) then
        call read_record ('sst', Date2, Udate2, temp2)
        if ( use_ncep_sst .and. (.not. no_anom_sst) ) then
             temp2(:,:) = temp2(:,:) + sst_anom(:,:)
        endif
        call horiz_interp ( Interp%Hintrp, temp2, Interp%data2 )
        call clip_data ('sst', Interp%data2)
        Interp % Date2 = Date2
    endif

!   ---- if the unit was opened, close it and print dates ----

      if (unit /= -1) then
         call close_file (unit)
         if (verbose > 0 .and. mpp_pe() == 0)         &
                               call print_dates (Amip_Time,   &
                                Interp % Date1, Udate1,  &
                                Interp % Date2, Udate2, fmonth)
      endif

!-----------------------------------------------------------------------
!---------- time interpolation (between months) of sst's ---------------
!-----------------------------------------------------------------------
  sst = Interp % data1 + fmonth * (Interp % data2 - Interp % data1)

!-------------------------------------------------------------------------------
! SJL mods for NWP and TCSF ---
!      Nudging runs: (Note: NCEP SST updated only every 6-hr)
!      Compute SST anomaly from global SST datasets for subsequent forecast runs
!-------------------------------------------------------------------------------
  if ( use_ncep_sst .and. no_anom_sst ) then
       sst_anom(:,:) = sst_ncep(:,:) - (temp1(:,:) + fmonth*(temp2(:,:) - temp1(:,:)) )
       call horiz_interp ( Interp%Hintrp, sst_ncep, sst )
       call clip_data ('sst', sst)
  endif


endif

! add on non-zero sea surface temperature perturbation (namelist option)
! this perturbation may be useful in accessing model sensitivities

   if ( abs(sst_pert) > 0.0001 ) then
      sst = sst + sst_pert
   endif

!-----------------------------------------------------------------------

 end subroutine get_amip_sst



!#######################################################################
! <SUBROUTINE NAME="get_amip_ice" INTERFACE="get_amip_ice">
!   <IN NAME="Time"  TYPE="time_type"  > </IN>
!   <OUT NAME="ice" TYPE="real" DIM="(:,:)"> </OUT>                  
!   <INOUT NAME="Interp" TYPE="amip_interp_type"> </INOUT>
! </SUBROUTINE>

subroutine get_amip_ice (Time, Interp, ice, err_msg)

   type (time_type),         intent(in)    :: Time
   type (amip_interp_type),  intent(inout) :: Interp
   real,                     intent(out)   :: ice(:,:)
   character(len=*), optional, intent(out) :: err_msg

    real, dimension(mobs,nobs) :: sice, temp

    integer :: year1, year2, month1, month2
    real    :: fmonth
    type (date_type) :: Date1, Date2, Udate1, Udate2

    type(time_type) :: Amip_Time
    integer :: tod(3),dum

    if(present(err_msg)) err_msg = ''
    if(.not.Interp%I_am_initialized) then
      if(fms_error_handler('get_amip_ice','The amip_interp_type variable is not initialized',err_msg)) return
    endif

!-----------------------------------------------------------------------
!----- compute zonally symetric sst ---------------


    if (any(amip_date>0)) then

       call get_date(Time,dum,dum,dum,tod(1),tod(2),tod(3))

       Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3))

    else

       Amip_Time = Time
       
    endif
       

if (use_zonal) then
   call zonal_sst (Amip_Time, sice, temp)
   call horiz_interp ( Interp%Hintrp, sice, ice )
else

!-----------------------------------------------------------------------
!---------- get new observed sea surface temperature -------------------

! ---- time interpolation for months -----

   call time_interp (Amip_Time, fmonth, year1, year2, month1, month2)
   
! ---- force climatology ----
   if (Interp % use_climo) then
       year1=0; year2=0
   endif
   if (Interp % use_annual) then
        year1=0;  year2=0
       month1=0; month2=0
   endif
! ---------------------------

   Date1 = date_type( year1, month1, 0 )
   Date2 = date_type( year2, month2, 0 )

   unit = -1
!-----------------------------------------------------------------------

    if (Date1 /= Interp % Date1) then
!       ---- use Date2 for Date1 ----
        if (Date1 == Interp % Date2) then
            Interp % Date1 = Interp % Date2
            Interp % data1 = Interp % data2
        else
!-- SJL -------------------------------------------------------------
! Can NOT use ncep_sst to determine sea_ice For seasonal forecast
! Use climo sea ice for seasonal runs
            if ( use_ncep_sst .and. use_ncep_ice ) then
               where ( sst_ncep <= (TFREEZE+tice_crit) )
                   sice = 1.
               elsewhere
                   sice = 0.
               endwhere
            else
               call read_record ('ice', Date1, Udate1, sice)
            endif
!--------------------------------------------------------------------
            call horiz_interp ( Interp%Hintrp, sice, Interp%data1 )
            call clip_data ('ice', Interp%data1)
            Interp % Date1 = Date1
        endif
    endif

!-----------------------------------------------------------------------

    if (Date2 /= Interp % Date2) then

!-- SJL -------------------------------------------------------------
            if ( use_ncep_sst .and. use_ncep_ice ) then
               where ( sst_ncep <= (TFREEZE+tice_crit) )
                   sice = 1.
               elsewhere
                   sice = 0.
               endwhere
            else
               call read_record ('ice', Date2, Udate2, sice)
            endif
!--------------------------------------------------------------------
        call horiz_interp ( Interp%Hintrp, sice, Interp%data2 )
        call clip_data ('ice', Interp%data2)
        Interp % Date2 = Date2

    endif

!   ---- if the unit was opened, close it and print dates ----

      if (unit /= -1) then
         call close_file (unit)
         if (verbose > 0 .and. mpp_pe() == 0)         &
                               call print_dates (Amip_Time,   &
                                Interp % Date1, Udate1,  &
                                Interp % Date2, Udate2, fmonth)
      endif

!-----------------------------------------------------------------------
!---------- time interpolation (between months) ------------------------
!-----------------------------------------------------------------------

   ice = Interp % data1 + fmonth * (Interp % data2 - Interp % data1)

endif

!-----------------------------------------------------------------------

 end subroutine get_amip_ice



!#######################################################################

! <FUNCTION NAME="amip_interp_new_1d" INTERFACE="amip_interp_new">

!   <IN NAME="lon" TYPE="real" DIM="(:)"> </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:)"> </IN>
!   <IN NAME="mask" TYPE="logical" DIM="(:,:)"> </IN>
!   <IN NAME="use_climo" TYPE="logical" DEFAULT="use_climo = .false."> </IN>
!   <IN NAME="use_annual" TYPE="logical" DEFAULT="use_annual = .false."> </IN>
!   <IN NAME="interp_method" TYPE="character(len=*), optional" DEFAULT="interp_method = conservative"></IN>
!   <OUT NAME="Interp" TYPE="amip_interp_type"> </OUT>

 function amip_interp_new_1d ( lon , lat , mask , use_climo, use_annual, &
                                interp_method ) result (Interp)

 real,    intent(in), dimension(:)   :: lon, lat
 logical, intent(in), dimension(:,:) :: mask
 character(len=*), intent(in), optional       :: interp_method
 logical, intent(in), optional       :: use_climo, use_annual

   type (amip_interp_type) :: Interp

   if(.not.module_is_initialized) call amip_interp_init

   Interp % use_climo  = .false.
   if (present(use_climo)) Interp % use_climo  = use_climo
   Interp % use_annual = .false.
   if (present(use_annual)) Interp % use_annual  = use_annual

   if ( date_out_of_range == 'fail' .and. Interp%use_climo ) &
      call error_mesg ('amip_interp_new_1d', 'use_climo mismatch', FATAL)

   if ( date_out_of_range == 'fail' .and. Interp%use_annual ) &
      call error_mesg ('amip_interp_new_1d', 'use_annual(climo) mismatch', FATAL)

   Interp % Date1 = date_type( -99, -99, -99 )
   Interp % Date2 = date_type( -99, -99, -99 )

!-----------------------------------------------------------------------
!   ---- initialization of horizontal interpolation ----

    call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, &
                             lon, lat, interp_method= interp_method )

    allocate ( Interp % data1 (size(lon(:))-1,size(lat(:))-1), &
               Interp % data2 (size(lon(:))-1,size(lat(:))-1)  )

    Interp%I_am_initialized = .true.

   end function amip_interp_new_1d
! </FUNCTION>

!#######################################################################
! <FUNCTION NAME="amip_interp_new_2d" INTERFACE="amip_interp_new">
!   <IN NAME="lon" TYPE="real" DIM="(:,:)"> </IN>
!   <IN NAME="lat" TYPE="real" DIM="(:,:)"> </IN>
!   <IN NAME="mask" TYPE="logical" DIM="(:,:)"> </IN>
!   <IN NAME="use_climo" TYPE="logical" DEFAULT="use_climo = .false."> </IN>
!   <IN NAME="use_annual" TYPE="logical" DEFAULT="use_annual = .false."> </IN>
!   <IN NAME="interp_method" TYPE="character(len=*), optional" DEFAULT="interp_method = conservative "></IN>
!   <OUT NAME="Interp" TYPE="amip_interp_type"> </OUT>

 function amip_interp_new_2d ( lon , lat , mask , use_climo, use_annual, &
                                interp_method ) result (Interp)

 real,    intent(in), dimension(:,:)   :: lon, lat
 logical, intent(in), dimension(:,:) :: mask
 character(len=*), intent(in), optional :: interp_method
 logical, intent(in), optional       :: use_climo, use_annual

   type (amip_interp_type) :: Interp

   if(.not.module_is_initialized) call amip_interp_init

   Interp % use_climo  = .false.
   if (present(use_climo)) Interp % use_climo  = use_climo
   Interp % use_annual = .false.
   if (present(use_annual)) Interp % use_annual  = use_annual

   if ( date_out_of_range == 'fail' .and. Interp%use_climo ) &
      call error_mesg ('amip_interp_new_2d', 'use_climo mismatch', FATAL)

   if ( date_out_of_range == 'fail' .and. Interp%use_annual ) &
      call error_mesg ('amip_interp_new_2d', 'use_annual(climo) mismatch', FATAL)

   Interp % Date1 = date_type( -99, -99, -99 )
   Interp % Date2 = date_type( -99, -99, -99 )

!-----------------------------------------------------------------------
!   ---- initialization of horizontal interpolation ----

   call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, &
                           lon, lat, interp_method = interp_method)

   allocate ( Interp % data1 (size(lon,1),size(lat,2)), &
              Interp % data2 (size(lon,1),size(lat,2))) 

   Interp%I_am_initialized = .true.

   end function amip_interp_new_2d
! </FUNCTION>

!#######################################################################

 subroutine amip_interp_init()

   integer :: unit,io,ierr

!-----------------------------------------------------------------------

    call horiz_interp_init

!   ---- read namelist ----

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, amip_interp_nml, iostat=io)
#else
    if ( file_exist('input.nml')) then
       unit = open_namelist_file( )
       ierr=1; do while (ierr /= 0)
       read  (unit, nml=amip_interp_nml, iostat=io, end=10)
       ierr = check_nml_error(io,'amip_interp_nml')
       enddo
  10   call close_file (unit)
    endif
#endif

!  ----- write namelist/version info -----
    call write_version_number (version, tagname)

    unit = stdlog ( )
    if (mpp_pe() == 0) then
        write (unit,nml=amip_interp_nml)
    endif
    call close_file (unit)

!   ---- freezing point of sea water in deg K ---

    tice_crit_k = tice_crit
    if ( tice_crit_k < 200. ) tice_crit_k = tice_crit_k + TFREEZE
    ice_crit = nint((tice_crit_k-TFREEZE)*100.)

!   ---- set up file dependent variable ----
!   ----   global file name   ----
!   ----   grid box edges     ----
!   ---- initialize zero size grid if not pe 0 ------

    if (lowercase(trim(data_set)) == 'amip1') then
        file_name_sst = 'INPUT/' // 'amip1_sst.data'
        file_name_ice = 'INPUT/' // 'amip1_sst.data'
        mobs = 180;  nobs = 91
        call set_sst_grid_edges_amip1
        if (mpp_pe() == 0) &
        call error_mesg ('amip_interp_init', 'using AMIP 1 sst', NOTE)
        Date_end = date_type( 1989, 1, 0 )
    else if (lowercase(trim(data_set)) == 'amip2') then
        file_name_sst = 'INPUT/' // 'amip2_sst.data'
        file_name_ice = 'INPUT/' // 'amip2_ice.data'
        mobs = 360;  nobs = 180
        call set_sst_grid_edges_oi
!       --- specfied min for amip2 ---
        tice_crit_k = 271.38
        if (mpp_pe() == 0) &
        call error_mesg ('amip_interp_init', 'using AMIP 2 sst', NOTE)
        Date_end = date_type( 1996, 3, 0 )
    else if (lowercase(trim(data_set)) == 'hurrell') then
        file_name_sst = 'INPUT/' // 'hurrell_sst.data'
        file_name_ice = 'INPUT/' // 'hurrell_ice.data'
        mobs = 360;  nobs = 180
        call set_sst_grid_edges_oi
!       --- specfied min for hurrell ---
        tice_crit_k = 271.38
        if (mpp_pe() == 0) &
        call error_mesg ('amip_interp_init', 'using HURRELL sst', NOTE)
        Date_end = date_type( 2001, 12, 0 )
    else if (lowercase(trim(data_set)) == 'reynolds_eof') then
        file_name_sst = 'INPUT/' // 'reynolds_sst.data'
        file_name_ice = 'INPUT/' // 'reynolds_sst.data'
        mobs = 180;  nobs = 90
        call set_sst_grid_edges_oi
        if (mpp_pe() == 0) &
        call error_mesg ('amip_interp_init',  &
             'using NCEP Reynolds Historical Reconstructed SST', NOTE)
        Date_end = date_type( 1998, 12, 0 )
    else if (lowercase(trim(data_set)) == 'reynolds_oi') then
        file_name_sst = 'INPUT/' // 'reyoi_sst.data'
        file_name_ice = 'INPUT/' // 'reyoi_sst.data'
!--- Added by SJL ---------------------------------------------- 
        if ( use_ncep_sst ) then
             mobs = i_sst;  nobs = j_sst
            if (.not. allocated (sst_ncep)) allocate (sst_ncep(i_sst,j_sst))
            if (.not. allocated (sst_anom)) allocate (sst_anom(i_sst,j_sst))
        else
             mobs = 360;    nobs = 180
        endif
!--- Added by SJL ---------------------------------------------- 
        call set_sst_grid_edges_oi
        if (mpp_pe() == 0) &
        call error_mesg ('amip_interp_init', 'using Reynolds OI SST', &
                                                                NOTE)
        Date_end = date_type( 1999, 1, 0 )
    else
        call error_mesg ('amip_interp_init', 'the value of the &
        &namelist parameter DATA_SET being used is not allowed', FATAL)
    endif

    if (verbose > 1 .and. mpp_pe() == 0) &
              print *, 'ice_crit,tice_crit_k=',ice_crit,tice_crit_k

!  --- check existence of sst data file ??? ---

    if (.not.file_exist(trim(file_name_sst)) .and. .not.file_exist(trim(file_name_sst)//'.nc')) then
      call error_mesg ('amip_interp_init', &
            'Neither '//trim(file_name_sst)//' or '//trim(file_name_sst)//'.nc exists', FATAL)
    endif
    if (.not.file_exist(trim(file_name_ice)) .and. .not.file_exist(trim(file_name_ice)//'.nc')) then
      call error_mesg ('amip_interp_init', &
            'Neither '//trim(file_name_ice)//' or '//trim(file_name_ice)//'.nc exists', FATAL)
    endif

    module_is_initialized = .true.

 end subroutine amip_interp_init

!#######################################################################

! <SUBROUTINE NAME="amip_interp_del">

!   <OVERVIEW>
!     Call this routine for all amip_interp_type variables created by amip_interp_new.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Call this routine for all amip_interp_type variables created by amip_interp_new.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call amip_interp_del (Interp)
!   </TEMPLATE>
!   <INOUT NAME="Interp" TYPE="amip_interp_type">
!     A defined data type variable initialized by amip_interp_new
!            and used when calling get_amip_sst and get_amip_ice.
!   </INOUT>

   subroutine amip_interp_del (Interp)
   type (amip_interp_type), intent(inout) :: Interp

     if(associated(Interp%data1)) deallocate(Interp%data1)
     if(associated(Interp%data2)) deallocate(Interp%data2)
     if(allocated(lon_bnd))       deallocate(lon_bnd)
     if(allocated(lat_bnd))       deallocate(lat_bnd)
     call horiz_interp_del ( Interp%Hintrp )

     Interp%I_am_initialized = .false.

   end subroutine amip_interp_del
!#######################################################################

! </SUBROUTINE>

!#######################################################################

   subroutine set_sst_grid_edges_amip1

   integer :: i, j
   real    :: hpie, dlon, dlat, wb, sb

      allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) )

! ---- compute grid edges (do only once) -----

      hpie = 0.5*pi

      dlon = 4.*hpie/float(mobs);  wb = -0.5*dlon
      do i = 1, mobs+1
          lon_bnd(i) = wb + dlon * float(i-1)
      enddo
          lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie

      dlat = 2.*hpie/float(nobs-1);  sb = -hpie + 0.5*dlat
      lat_bnd(1) = -hpie;  lat_bnd(nobs+1) = hpie
      do j = 2, nobs
          lat_bnd(j) = sb + dlat * float(j-2)
      enddo

   end subroutine set_sst_grid_edges_amip1

!#######################################################################

   subroutine set_sst_grid_edges_oi

   integer :: i, j
   real    :: hpie, dlon, dlat, wb, sb

      allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) )

! ---- compute grid edges (do only once) -----

      hpie = 0.5*pi

      dlon = 4.*hpie/float(mobs);  wb = 0.0
          lon_bnd(1) = wb
      do i = 2, mobs+1
          lon_bnd(i) = wb + dlon * float(i-1)
      enddo
          lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie

      dlat = 2.*hpie/float(nobs);  sb = -hpie
      lat_bnd(1) = sb;  lat_bnd(nobs+1) = hpie
      do j = 2, nobs
          lat_bnd(j) = sb + dlat * float(j-1)
      enddo

   end subroutine set_sst_grid_edges_oi


   subroutine a2a_bilinear(nx, ny, dat1, n1, n2, dat2)
   integer, intent(in):: nx, ny
   integer, intent(in):: n1, n2
   real, intent(in) :: dat1(nx,ny)
   real, intent(out):: dat2(n1,n2)      ! output interpolated data

! local:
  real:: lon1(nx), lat1(ny)
  real:: lon2(n1), lat2(n2)
  real:: dx1, dy1, dx2, dy2
  real:: xc, yc
  real:: a1, b1, c1, c2, c3, c4
  integer i1, i2, jc, i0, j0, it, jt
  integer i,j


!-----------------------------------------------------------
! * Interpolate from "FMS" 1x1 SST data grid to a finer grid
!                     lon: 0.5, 1.5, ..., 359.5
!                     lat: -89.5, -88.5, ... , 88.5, 89.5
!-----------------------------------------------------------

! INput Grid
  dx1 = 360./real(nx)
  dy1 = 180./real(ny)

  do i=1,nx
     lon1(i) = 0.5*dx1 + real(i-1)*dx1
  enddo
  do j=1,ny
     lat1(j) = -90. + 0.5*dy1 + real(j-1)*dy1
  enddo

! OutPut Grid:
  dx2 = 360./real(n1)
  dy2 = 180./real(n2)

  do i=1,n1
     lon2(i) = 0.5*dx2 + real(i-1)*dx2
  enddo
  do j=1,n2
     lat2(j) = -90. + 0.5*dy2 + real(j-1)*dy2
  enddo

  jt = 1
  do 5000 j=1,n2

     yc = lat2(j)
     if ( yc<lat1(1) ) then
            jc = 1
            b1 = 0.
     elseif ( yc>lat1(ny) ) then
            jc = ny-1
            b1 = 1.
     else
          do j0=jt,ny-1
          if ( yc>=lat1(j0) .and. yc<=lat1(j0+1) ) then
               jc = j0
               jt = j0
               b1 = (yc-lat1(jc)) / dy1
               go to 222
          endif
          enddo
     endif
222  continue

     it = 1
     do i=1,n1
        xc = lon2(i)
       if ( xc>lon1(nx) ) then
            i1 = nx;     i2 = 1
            a1 = (xc-lon1(nx)) / dx1
       elseif ( xc<lon1(1) ) then
            i1 = nx;     i2 = 1
            a1 = (xc+360.-lon1(nx)) / dx1
       else
            do i0=it,nx-1
            if ( xc>=lon1(i0) .and. xc<=lon1(i0+1) ) then
               i1 = i0;  i2 = i0+1
               it = i0
               a1 = (xc-lon1(i1)) / dx1
               go to 111
            endif
            enddo
       endif
111    continue

! Debug code:
       if ( a1<-0.001 .or. a1>1.001 .or.  b1<-0.001 .or. b1>1.001 ) then
            write(*,*) i,j,a1, b1
            call mpp_error(FATAL,'a2a bilinear interpolation')
       endif

       c1 = (1.-a1) * (1.-b1)
       c2 =     a1  * (1.-b1)
       c3 =     a1  *     b1
       c4 = (1.-a1) *     b1

! Bilinear interpolation:
       dat2(i,j) = c1*dat1(i1,jc) + c2*dat1(i2,jc) + c3*dat1(i2,jc+1) + c4*dat1(i1,jc+1)

     enddo   !i-loop

5000 continue   ! j-loop

   end subroutine a2a_bilinear

!#######################################################################

! <SUBROUTINE NAME="get_sst_grid_size">

!   <OVERVIEW>
!     Returns the size (i.e., number of longitude and latitude
!         points) of the observed data grid.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns the size (i.e., number of longitude and latitude
!         points) of the observed data grid.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_sst_grid_size (nlon, nlat)
!   </TEMPLATE>
!   <OUT NAME="nlon" TYPE="integer">
!     The number of longitude points (first dimension) in the
!        observed data grid.  For AMIP 1 nlon = 180, and the Reynolds nlon = 360.
!   </OUT>
!   <OUT NAME="nlat" TYPE="integer">
!     The number of latitude points (second dimension) in the
!        observed data grid.  For AMIP 1 nlon = 91, and the Reynolds nlon = 180.
!   </OUT>
!   <ERROR MSG="have not called amip_interp_new" STATUS="FATAL">
!     Must call amip_interp_new before get_sst_grid_size.
!   </ERROR>

   subroutine get_sst_grid_size (nlon, nlat)

   integer, intent(out) :: nlon, nlat

      if ( .not.module_is_initialized ) call amip_interp_init

      nlon = mobs;  nlat = nobs

   end subroutine get_sst_grid_size
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="get_sst_grid_boundary">

!   <OVERVIEW>
!     Returns the grid box boundaries of the observed data grid.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns the grid box boundaries of the observed data grid.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_sst_grid_boundary (blon, blat, mask)
!   </TEMPLATE>
!   <OUT NAME="blon" TYPE="real" DIM="(:)">
!     The grid box edges (in radians) for longitude points of the
!        observed data grid. The size of this argument must be nlon+1.
!   </OUT>
!   <OUT NAME="blat" TYPE="real" DIM="(:)">
!     The grid box edges (in radians) for latitude points of the
!        observed data grid. The size of this argument must be nlat+1.
!   </OUT>
!   <ERROR MSG="have not called amip_interp_new" STATUS="FATAL">
!     Must call amip_interp_new before get_sst_grid_boundary.
!   </ERROR>
!   <ERROR MSG="invalid argument dimensions" STATUS="FATAL">
!     The size of the output argument arrays do not agree with
!      the size of the observed data. See the documentation for
!      interfaces get_sst_grid_size and get_sst_grid_boundary.
!   </ERROR>

   subroutine get_sst_grid_boundary (blon, blat, mask)

   real,    intent(out) :: blon(:), blat(:)
   logical, intent(out) :: mask(:,:)

      if ( .not.module_is_initialized ) call amip_interp_init

! ---- check size of argument(s) ----

      if (size(blon(:)) /= mobs+1 .or. size(blat(:)) /= nobs+1)   &
      call error_mesg ('get_sst_grid_boundary in amip_interp_mod',  &
                       'invalid argument dimensions', FATAL)

! ---- return grid box edges -----

      blon = lon_bnd
      blat = lat_bnd

! ---- masking (data exists at all points) ----

      mask = .true.


   end subroutine get_sst_grid_boundary
! </SUBROUTINE>

!#######################################################################

   subroutine read_record (type, Date, Adate, dat)

     character(len=*), intent(in)  :: type
     type (date_type), intent(in)  :: Date
     type (date_type), intent(inout) :: Adate
     real,             intent(out) :: dat(mobs,nobs)
     real :: tmp_dat(360,180)

     real   (R4_KIND) :: dat4(mobs,nobs)
     integer(I2_KIND) :: idat(mobs,nobs)
     integer :: nrecords, yr, mo, dy, ierr, k
     integer, dimension(:), allocatable :: ryr, rmo, rdy
     character(len=38)   :: mesg
     character(len=maxc) :: ncfilename, ncfieldname

    !---- set file and field name for NETCDF data sets ----

        ncfieldname = 'sst'
     if(type(1:3) == 'sst') then
        ncfilename = trim(file_name_sst)//'.nc'
     else if(type(1:3) == 'ice') then
        ncfilename = trim(file_name_ice)//'.nc'
        if (lowercase(trim(data_set)) == 'amip2' .or. &
            lowercase(trim(data_set)) == 'hurrell') ncfieldname = 'ice'
     endif

    !---- make sure IEEE format file is open ----

     if ( (.NOT. file_exist(ncfilename))  ) then

       ! rewind condition (if unit is open)
        if (unit /= -1 .and. Curr_date % year == 0 .and.   &
             date % month <= Curr_date % month ) then
           if (verbose > 1 .and. mpp_pe() == 0)  &
                print *, ' rewinding unit = ', unit
           rewind unit
        endif

        if (unit == -1) then
           if (type(1:3) == 'sst') then
              unit = open_ieee32_file (file_name_sst, 'read')
           else if (type(1:3) == 'ice') then
              unit = open_ieee32_file (file_name_ice, 'read')
           endif
        endif

     endif

     dy = 0 ! only processing monthly data

     if (verbose > 2 .and. mpp_pe() == 0)  &
          print *, 'looking for date = ', Date

    !---- check dates in NETCDF file -----

     ! This code can handle amip1, reynolds, or reyoi type SST data files in netCDF format
     if (file_exist(ncfilename)) then
        if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', &
             'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE)
        call read_data (ncfilename, 'nrecords', nrecords, no_domain=.true.)
        if (nrecords < 1) call mpp_error('amip_interp_mod', &
                           'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL)
        allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords))
        call read_data(ncfilename, 'yr', ryr, no_domain=.true.)
        call read_data(ncfilename, 'mo', rmo, no_domain=.true.)
        call read_data(ncfilename, 'dy', rdy, no_domain=.true.)
        ierr = 1
        do k = 1, nrecords
          yr = ryr(k);  mo = rmo(k)
          Adate = date_type( yr, mo, 0)
          Curr_date = Adate
          if (verbose > 2 .and. mpp_pe() == 0)  &
                print *, '....... checking   ', Adate
          if (Date == Adate) ierr = 0 
          if (yr == 0 .and. mo == Date%month) ierr = 0
          if (ierr == 0) exit
        enddo
        if (ierr .ne. 0) call mpp_error('amip_interp_mod', &
                         'Model time is out of range not in SST data: '//trim(ncfilename), FATAL)
        deallocate(ryr, rmo, rdy)
       !PRINT *, 'New SST data: ', k, yr, mo, dy, Date%year, Date%month, Date%day, ryr(1), rmo(1)

    !---- check dates in IEEE file -----

     else
        if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', &
             'Reading native formatted input data file: '//trim(data_set), NOTE)
        k = 0
        do
           k = k + 1
           if (lowercase(trim(data_set)) == 'amip2' .or. lowercase(trim(data_set)) == 'hurrell') then
              read (unit, end=10)  yr, mo,     dat4
              dat=dat4
           else
              read (unit, end=10)  yr, mo, dy, idat
           endif
           !new     read (unit, end=10)  yr, mo, dy
           Adate = date_type( yr, mo, dy )
           Curr_date = Adate
           if (verbose > 2 .and. mpp_pe() == 0)  &
                print *, '....... checking   ', Adate
           
           !     --- found date ---
           if (Date == Adate)                    exit
           if (Date%month == mo .and. Date%day == dy .and. Date%year == yr ) exit
           !     --- otherwise use monthly climo ---
           if (yr == 0 .and. Date % month == mo) exit
           
           !     --- skip this data record ---
           !new  if (lowercase(trim(data_set)) /= 'amip2') read (unit)
        enddo
        
        !     --- read data ---
        !new  if (lowercase(trim(data_set)) /= 'amip2') read (unit) idat
        
        !   --- check if climo used when not wanted ---
        
     endif ! if(file_exist(ncfilename))
     
   !---- check if climatological data should be used ----

     if (yr == 0 .or. mo == 0) then
        ierr = 0
        if (date_out_of_range == 'fail' )               ierr = 1
        if (date_out_of_range == 'initclimo' .and.  &
             Date > Date_end )   ierr = 1
        if (ierr /= 0) call error_mesg &
             ('read_record in amip_interp_mod', &
             'climo data read when NO climo data requested', FATAL)
     endif

   !---- read NETCDF data ----

     if (file_exist(ncfilename)) then
         if ( interp_oi_sst ) then
              call read_data(ncfilename, ncfieldname, tmp_dat, timelevel=k, no_domain=.true.)
!     interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation)
              if ( mobs/=360 .or. nobs/=180 ) then
                   call a2a_bilinear(360, 180, tmp_dat, mobs, nobs, dat)
              else
                   dat(:,:) = tmp_dat(:,:)
              endif
         else
              call read_data(ncfilename, ncfieldname, dat, timelevel=k, no_domain=.true.)
         endif
        idat =  nint(dat*100.) ! reconstruct packed data for reproducibity
     endif

   !---- unpacking of data ----

     if (type(1:3) == 'ice') then
        !---- create fractional [0,1] ice mask
        if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then
               where ( idat <= ice_crit )
                   dat = 1.
               elsewhere
                   dat = 0.
               endwhere
        else
           dat = dat*0.01
        endif
     else if (type(1:3) == 'sst') then
        !---- unpack sst ----
        if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then
               dat = real(idat)*0.01 + TFREEZE
        endif
     endif


     return

10   write (mesg, 20) unit
     call error_mesg ('read_record in amip_interp_mod', mesg, FATAL)

20   format ('end of file reading unit ',i2,' (sst data)')

   end subroutine read_record

!#######################################################################

   subroutine clip_data (type, dat)

   character(len=*), intent(in)    :: type
   real,             intent(inout) :: dat(:,:)

   if (type(1:3) == 'ice') then
       dat = min(max(dat,0.0),1.0)
   else if (type(1:3) == 'sst') then
       dat = max(tice_crit_k,dat)
   endif

   end subroutine clip_data

!#######################################################################

function date_equals (Left, Right) result (answer)
type (date_type), intent(in) :: Left, Right
logical :: answer

   if (Left % year  == Right % year  .and.  &
       Left % month == Right % month .and.  &
       Left % day   == Right % day ) then
           answer = .true. 
   else
           answer = .false.
   endif

end function date_equals

!#######################################################################

function date_not_equals (Left, Right) result (answer)
type (date_type), intent(in) :: Left, Right
logical :: answer

   if (Left % year  == Right % year  .and.  &
       Left % month == Right % month .and.  &
       Left % day   == Right % day ) then
           answer = .false.
   else
           answer = .true. 
   endif

end function date_not_equals

!#######################################################################

function date_gt (Left, Right) result (answer)
type (date_type), intent(in) :: Left, Right
logical :: answer
integer :: i, dif(3)

   dif(1) = Left%year  - Right%year
   dif(2) = Left%month - Right%month
   dif(3) = Left%day   - Right%day
   answer = .false.
   do i = 1, 3
     if (dif(i) == 0) cycle
     if (dif(i)  < 0) exit
     if (dif(i)  > 0) then
         answer = .true.
         exit
     endif
   enddo

end function date_gt

!#######################################################################

subroutine print_dates (Time, Date1, Udate1,  &
                              Date2, Udate2, fmonth)

   type (time_type), intent(in) :: Time
   type (date_type), intent(in) :: Date1, Udate1, Date2, Udate2
   real,             intent(in) :: fmonth

   integer :: year, month, day, hour, minute, second

   call get_date (Time, year, month, day, hour, minute, second)

   write (*,10) year,month,day, hour,minute,second
   write (*,20) fmonth
   write (*,30) Date1, Udate1
   write (*,40) Date2, Udate2

10 format (/,' date(y/m/d h:m:s) = ',i4,2('/',i2.2),1x,2(i2.2,':'),i2.2)
20 format (' fmonth = ',f9.7)
30 format (' date1(y/m/d) = ',i4,2('/',i2.2),6x, &
                    'used = ',i4,2('/',i2.2),6x  )
40 format (' date2(y/m/d) = ',i4,2('/',i2.2),6x, &
                    'used = ',i4,2('/',i2.2),6x  )
     
end subroutine print_dates

!#######################################################################

subroutine zonal_sst (Time, ice, sst)

   type (time_type), intent(in)  :: Time
   real,             intent(out) :: ice(mobs,nobs), sst(mobs,nobs)

   real    :: tpi, fdate, eps, ph, sph, sph2, ts
   integer :: j

! namelist needed
!
!  teq  = sst at equator
!  tdif = equator to pole sst difference
!  tann = amplitude of annual cycle
!  tlag = offset for time of year (for annual cycle)
!

    tpi = 2.0*pi

    fdate = fraction_of_year (Time)

    eps = sin( tpi*(fdate-tlag) ) * tann

    do j = 1, nobs

        ph  = 0.5*(lat_bnd(j)+lat_bnd(j+1))
       sph  = sin(ph)
       sph2 = sph*sph

       ts = teq - tdif*sph2 - eps*sph

       sst(:,j) = ts

    enddo

    where ( sst < tice_crit_k )
       ice = 1.0
       sst = tice_crit_k
    elsewhere
       ice  = 0.0
    endwhere


end subroutine zonal_sst

!#######################################################################

subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in)
    type(amip_interp_type), intent(inout) :: amip_interp_out
    type(amip_interp_type), intent(in)    :: amip_interp_in

    if(.not.amip_interp_in%I_am_initialized) then
      call mpp_error(FATAL,'amip_interp_type_eq: amip_interp_type variable on right hand side is unassigned')
    endif

    amip_interp_out%Hintrp     =  amip_interp_in%Hintrp
    amip_interp_out%data1      => amip_interp_in%data1
    amip_interp_out%data2      => amip_interp_in%data2
    amip_interp_out%Date1      =  amip_interp_in%Date1
    amip_interp_out%Date2      =  amip_interp_in%Date2
    amip_interp_out%Date1      =  amip_interp_in%Date1
    amip_interp_out%Date2      =  amip_interp_in%Date2
    amip_interp_out%use_climo  =  amip_interp_in%use_climo
    amip_interp_out%use_annual =  amip_interp_in%use_annual
    amip_interp_out%I_am_initialized = .true.

end subroutine amip_interp_type_eq

!#######################################################################

end module amip_interp_mod
! <INFO>

!   <FUTURE> 
!     Add AMIP 2 data set.
!
!     Other data sets (or extend current data sets).
!   </FUTURE>

! </INFO>


                      module astronomy_mod
! <CONTACT EMAIL="Fei.Liu@noaa.gov">
!  fil
! </CONTACT>
! <REVIEWER EMAIL="">
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!    astronomy_mod provides astronomical variables for use
!    by other modules within fms. the only currently used interface is 
!    for determination of astronomical values needed by the shortwave
!    radiation packages.
! </OVERVIEW>
! <DESCRIPTION>
! </DESCRIPTION>

!  shared modules:

use fms_mod,           only: open_namelist_file, fms_init, &
                             mpp_pe, mpp_root_pe, stdlog, &
                             file_exist, write_version_number, &
                             check_nml_error, error_mesg, &
                             FATAL, NOTE, WARNING, close_file
use time_manager_mod,  only: time_type, set_time, get_time, &
                             get_date_julian, set_date_julian, &
                             set_date, length_of_year, &
                             time_manager_init, &
                             operator(-), operator(+), &
                             operator( // ), operator(<)
use constants_mod,     only: constants_init, PI
use mpp_mod,           only: input_nml_file

!--------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!    astronomy_mod provides astronomical variables for use
!    by other modules within fms. the only currently used interface is 
!    for determination of astronomical values needed by the shortwave
!    radiation packages.
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!----------- version number for this module --------------------------

character(len=128)  :: version =  '$Id: astronomy.F90,v 17.0.10.1 2010/08/31 14:21:37 z1l Exp $'
character(len=128)  :: tagname =  '$Name: hiram_20101115_bw $'


!---------------------------------------------------------------------
!-------  interfaces --------

public       &
              astronomy_init, get_period, set_period, &
              set_orbital_parameters, get_orbital_parameters, &
              set_ref_date_of_ae, get_ref_date_of_ae,  &
              diurnal_solar, daily_mean_solar, annual_mean_solar,  &
              astronomy_end, universal_time, orbital_time

interface diurnal_solar
   module procedure diurnal_solar_2d
   module procedure diurnal_solar_1d
   module procedure diurnal_solar_0d
   module procedure diurnal_solar_cal_2d
   module procedure diurnal_solar_cal_1d
   module procedure diurnal_solar_cal_0d
end interface

interface daily_mean_solar
   module procedure daily_mean_solar_2d
   module procedure daily_mean_solar_1d
   module procedure daily_mean_solar_2level
   module procedure daily_mean_solar_0d
   module procedure daily_mean_solar_cal_2d
   module procedure daily_mean_solar_cal_1d
   module procedure daily_mean_solar_cal_2level
   module procedure daily_mean_solar_cal_0d
end interface

interface annual_mean_solar
   module procedure annual_mean_solar_2d
   module procedure annual_mean_solar_1d
   module procedure annual_mean_solar_2level
end interface

interface get_period
   module procedure get_period_time_type, get_period_integer
end interface

interface set_period
   module procedure set_period_time_type, set_period_integer
end interface


private &

! called from astronomy_init and set_orbital_parameters:
              orbit,  &

! called from diurnal_solar, daily_mean_solar and orbit:
              r_inv_squared,   &

! called from  diurnal_solar and daily_mean_solar:
              angle,  declination,  &
              half_day
!             half_day, orbital_time, &

! called from  diurnal_solar:
!             universal_time


interface half_day
   module procedure half_day_2d, half_day_0d
end interface 


!---------------------------------------------------------------------
!-------- namelist  ---------

real    :: ecc   = 0.01671   ! eccentricity of orbital ellipse 
                             ! [ non-dimensional ]
real    :: obliq = 23.439    ! obliquity [ degrees ]
real    :: per   = 102.932   ! longitude of perihelion with respect 
                             ! to autumnal equinox in NH [ degrees ]
integer :: period = 0        ! specified length of year [ seconds ] ; 
                             ! must be specified to override default 
                             ! value given by length_of_year in 
                             ! time_manager_mod
integer :: day_ae    = 23    ! day of specified autumnal equinox
integer :: month_ae  = 9     ! month of specified autumnal equinox
integer :: year_ae   = 1998  ! year of specified autumnal equinox
integer :: hour_ae   = 5     ! hour of specified autumnal equinox
integer :: minute_ae = 37    ! minute of specified autumnal equinox
integer :: second_ae = 0     ! second of specified autumnal equinox
integer :: num_angles = 3600 ! number of intervals into which the year 
                             ! is divided to compute orbital positions


namelist /astronomy_nml/ ecc, obliq, per, period, &
                         year_ae, month_ae,  day_ae,         & 
                         hour_ae, minute_ae, second_ae, &
                         num_angles

!--------------------------------------------------------------------
!------   public data ----------


!--------------------------------------------------------------------
!------   private data ----------

type(time_type) :: autumnal_eq_ref  ! time_type variable containing
                                    ! specified time of reference 
                                    ! NH autumnal equinox

type(time_type) :: period_time_type ! time_type variable containing
                                    ! period of one orbit

real, dimension(:), allocatable ::      &
                          orb_angle ! table of orbital positions (0 to 
                                    ! 2*pi) as a function of time  used
                                    ! to find actual orbital position
                                    ! via interpolation

real    :: seconds_per_day=86400.   ! seconds in a day
real    :: deg_to_rad               ! conversion from degrees to radians
real    :: twopi                    ! 2 *PI
logical :: module_is_initialized=     &
                          .false.   ! has the module been initialized ?

real, dimension(:), allocatable ::       &
                       cosz_ann, &  ! annual mean cos of zenith angle
                       solar_ann, & ! annual mean solar factor
                       fracday_ann  ! annual mean daylight fraction
real    :: rrsun_ann                ! annual mean earth-sun distance
logical :: annual_mean_calculated =      &
                           .false.  ! have the annual mean values been 
                                    ! calculated ?
integer :: num_pts = 0              ! count of grid_boxes for which
                                    ! annual mean astronomy values have
                                    ! been calculated
integer :: total_pts                ! number of grid boxes owned by the
                                    ! processor


!--------------------------------------------------------------------
!--------------------------------------------------------------------



                           contains



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                     PUBLIC SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!####################################################################
! <SUBROUTINE NAME="astronomy_init">
!  <OVERVIEW>
!    astronomy_init is the constructor for astronomy_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    astronomy_init is the constructor for astronomy_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call astronomy_init (latb, lonb)
!  </TEMPLATE>
!  <IN NAME="latb" TYPE="real">
!   2d array of model latitudes at cell corners [radians]
!  </IN>
!  <IN NAME="lonb" TYPE="real">
!   2d array of model longitudes at cell corners [radians]
!  </IN>
! </SUBROUTINE>
!
subroutine astronomy_init (latb, lonb)
  
!-------------------------------------------------------------------
!    astronomy_init is the constructor for astronomy_mod.
!-------------------------------------------------------------------

real,   dimension(:,:), intent(in), optional   :: latb
real,   dimension(:,:), intent(in), optional   :: lonb

!--------------------------------------------------------------------
!   intent(in) variables:
!
!       latb         2d array of model latitudes at cell corners 
!                    [ radians ]
!       lonb         2d array of model longitudes at cell corners 
!                    [ radians ]
!
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables:

      integer                         :: unit, ierr, io, seconds,  &
                                         days, jd, id

!-------------------------------------------------------------------
!  local variables:
!
!      unit
!      ierr
!      io
!      seconds
!      days
!      jd
!      id
!
!---------------------------------------------------------------------

!-------------------------------------------------------------------
!    if module has already been initialized, exit.
!-------------------------------------------------------------------
      if (module_is_initialized) return

!-------------------------------------------------------------------
!    verify that modules used by this module have been initialized.
!-------------------------------------------------------------------
      call fms_init
      call time_manager_init
      call constants_init

!-----------------------------------------------------------------------
!    read namelist.              
!-----------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, astronomy_nml, iostat=io)
#else
      if ( file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read  (unit, nml=astronomy_nml, iostat=io, end=10) 
        ierr = check_nml_error(io,'astronomy_nml')
        end do                   
10      call close_file (unit)   
      endif                      
#endif                                 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tagname)
      if (mpp_pe() == mpp_root_pe() ) then
        unit = stdlog()
        write (unit, nml=astronomy_nml)
      endif
!--------------------------------------------------------------------
!    be sure input values are within valid ranges.
!    QUESTION : ARE THESE THE RIGHT LIMITS ???
!---------------------------------------------------------------------
      if (ecc < 0.0 .or. ecc > 0.99) &
        call error_mesg ('astronomy_mod', &
                      'ecc must be between 0 and 0.99', FATAL)
      if (obliq < -90. .or. obliq > 90.) &
        call error_mesg ('astronomy_mod', &
                  'obliquity must be between -90 and 90 degrees', FATAL)
      if (per <  0.0 .or. per > 360.0) &
        call error_mesg ('astronomy_mod', &
                 'perihelion must be between 0 and 360 degrees', FATAL)

!----------------------------------------------------------------------
!    set up time-type variable defining specified time of autumnal
!    equinox.
!----------------------------------------------------------------------
      autumnal_eq_ref = set_date (year_ae,month_ae,day_ae, &
                                  hour_ae,minute_ae,second_ae)

!---------------------------------------------------------------------
!    set up time-type variable defining length of year.
!----------------------------------------------------------------------
      if (period == 0) then  
        period_time_type = length_of_year()
        call get_time (period_time_type, seconds, days)
        period = seconds_per_day*days + seconds
      else   
        period_time_type = set_time(period,0)
      endif

!---------------------------------------------------------------------
!    define useful module variables.
!----------------------------------------------------------------------
      twopi = 2.*PI
      deg_to_rad = twopi/360.

!---------------------------------------------------------------------
!    call orbit to define table of orbital angles as function of 
!    orbital time.
!----------------------------------------------------------------------
! wfc moved here from orbit
      allocate ( orb_angle(0:num_angles) )
      call orbit

!--------------------------------------------------------------------
!    if annual mean radiation is desired, then latb will be present.
!    allocate arrays to hold the needed astronomical factors. define 
!    the total number of points that the processor is responsible for.
!--------------------------------------------------------------------
      if (present(latb)) then
        jd = size(latb,2) - 1
        id = size(lonb,1) - 1
        allocate (cosz_ann(jd))
        allocate (solar_ann(jd))
        allocate (fracday_ann(jd))
        total_pts = jd*id
      endif
     
!---------------------------------------------------------------------
!    mark the module as initialized.
!---------------------------------------------------------------------
      module_is_initialized=.true.

!---------------------------------------------------------------------

end subroutine astronomy_init




!###################################################################



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    INTERFACE GET_PERIOD
!
!
! call get_period (period)
!
!  separate routines exist within this interface for integer
!  and time_type output:
!
!  integer, intent(out)         :: period
! OR
!  type(time_type), intent(out) :: period
!
!--------------------------------------------------------------------
!
!   intent(out) variable:
!
!    period_out        length of year for calendar in use
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! <SUBROUTINE NAME="get_period_integer">
!  <OVERVIEW>
!    get_period_integer returns the length of the year as an integer
!    number of seconds.
!  </OVERVIEW>
!  <DESCRIPTION>
!    get_period_integer returns the length of the year as an integer
!    number of seconds.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_period_integer (period_out)
!  </TEMPLATE>
!  <OUT NAME="period_out" TYPE="integer">
!   number of seconds as the length of the year
!  </OUT>
! </SUBROUTINE>
!
subroutine get_period_integer (period_out)

!--------------------------------------------------------------------
!    get_period_integer returns the length of the year as an integer
!    number of seconds.
!--------------------------------------------------------------------

integer, intent(out) :: period_out

!--------------------------------------------------------------------
!   local variables:

      integer :: seconds, days

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!--------------------------------------------------------------------
!    define length of year in seconds.
!--------------------------------------------------------------------
      call get_time (period_time_type, seconds, days)
      period_out = seconds_per_day*days + seconds


end subroutine get_period_integer

!####################################################################
! <SUBROUTINE NAME="get_period_time_type">
!  <OVERVIEW>
!    get_period_time_type returns the length of the year as a time_type
!    variable.
!  </OVERVIEW>
!  <DESCRIPTION>
!    get_period_time_type returns the length of the year as a time_type
!    variable.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_period_time_type (period_out)
!  </TEMPLATE>
!  <OUT NAME="period_out" TYPE="time_type">
!   the length of the year as a time_type
!  </OUT>
! </SUBROUTINE>
!
subroutine get_period_time_type (period_out)

!--------------------------------------------------------------------
!    get_period_time_type returns the length of the year as a time_type
!    variable.
!--------------------------------------------------------------------

type(time_type), intent(inout) :: period_out

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
          call error_mesg ( 'astronomy_mod',  &
              ' module has not been initialized', FATAL)

!--------------------------------------------------------------------
!    define length of year as a time_type variable.
!--------------------------------------------------------------------
      period_out = period_time_type


end subroutine get_period_time_type



!#####################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                END INTERFACE GET_PERIOD
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    INTERFACE SET_PERIOD
!
!
! call set_period (period_in)
!
!  separate routines exist within this interface for integer
!  and time_type output:
!
!  integer, intent(out)         :: period_in
! OR
!  type(time_type), intent(out) :: period_in
!
!--------------------------------------------------------------------
!
!   intent(in) variable:
!
!    period_in        length of year for calendar in use
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! <SUBROUTINE NAME="set_period_integer">
!  <OVERVIEW>
!    set_period_integer saves as the input length of the year (an 
!    integer) in a time_type module variable.
!  </OVERVIEW>
!  <DESCRIPTION>
!    set_period_integer saves as the input length of the year (an 
!    integer) in a time_type module variable.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call set_period_integer (period_in)
!  </TEMPLATE>
!  <IN NAME="period_in" TYPE="time_type">
!   the length of the year as a time_type
!  </IN>
! </SUBROUTINE>
!
subroutine set_period_integer (period_in)

!--------------------------------------------------------------------
!    set_period_integer saves as the input length of the year (an 
!    integer) in a time_type module variable.
!--------------------------------------------------------------------

integer, intent(in) :: period_in

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    define time_type variable defining the length of year from the
!    input value (integer seconds).
!---------------------------------------------------------------------
      period_time_type = set_time(period_in, 0)



end subroutine set_period_integer



!#####################################################################

subroutine set_period_time_type(period_in)

!--------------------------------------------------------------------
!    set_period_time_type saves the length of the year (input as a 
!    time_type variable) into a time_type module variable.
!--------------------------------------------------------------------

type(time_type), intent(in) :: period_in

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    define time_type variable defining the length of year from the
!    input value (time_type).
!---------------------------------------------------------------------
      period_time_type = period_in


end subroutine set_period_time_type



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                END INTERFACE SET_PERIOD
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!#####################################################################
! <SUBROUTINE NAME="set_orbital_parameters">
!  <OVERVIEW>
!    set_orbital_parameters saves the input values of eccentricity,
!    obliquity and perihelion time as module variables for use by
!    astronomy_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    set_orbital_parameters saves the input values of eccentricity,
!    obliquity and perihelion time as module variables for use by
!    astronomy_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call set_orbital_parameters (ecc_in, obliq_in, per_in)
!  </TEMPLATE>
!  <IN NAME="ecc_in" TYPE="real">
!   eccentricity of orbital ellipse
!  </IN>
!  <IN NAME="obliq_in" TYPE="real">
!   obliquity fof orbital ellipse
!  </IN>
!  <IN NAME="per_in" TYPE="real">
!   longitude of perihelion with respect to autumnal
!                      equinox in northern hemisphere
!  </IN>
! </SUBROUTINE>
!
subroutine set_orbital_parameters (ecc_in, obliq_in, per_in)

!--------------------------------------------------------------------
!    set_orbital_parameters saves the input values of eccentricity,
!    obliquity and perihelion time as module variables for use by
!    astronomy_mod.
!--------------------------------------------------------------------

real, intent(in) :: ecc_in
real, intent(in) :: obliq_in
real, intent(in) :: per_in

!--------------------------------------------------------------------  
!
!  intent(in) variables:
!
!     ecc_in           eccentricity of orbital ellipse 
!                      [ non-dimensional ]
!     obliq_in         obliquity
!                      [ degrees ]
!     per_in           longitude of perihelion with respect to autumnal
!                      equinox in northern hemisphere
!                      [ degrees ]
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!--------------------------------------------------------------------
!    be sure input values are within valid ranges.
!    QUESTION : ARE THESE THE RIGHT LIMITS ???
!---------------------------------------------------------------------
      if (ecc_in < 0.0 .or. ecc_in > 0.99) &
        call error_mesg ('astronomy_mod', &
                      'ecc must be between 0 and 0.99', FATAL)
      if (obliq_in < -90.0 .or. obliq > 90.0) &
        call error_mesg ('astronomy_mod', &
                'obliquity must be between -90. and 90. degrees', FATAL)
      if (per_in < 0.0 .or. per_in > 360.0) &
        call error_mesg ('astronomy_mod', &
              'perihelion must be between 0.0 and 360. degrees', FATAL)

!---------------------------------------------------------------------
!    save input values into module variables.
!---------------------------------------------------------------------
      ecc   = ecc_in
      obliq = obliq_in
      per   = per_in

!---------------------------------------------------------------------
!    call orbit to define table of orbital angles as function of 
!    orbital time using the input values of parameters just supplied.
!----------------------------------------------------------------------
      call orbit

!----------------------------------------------------------------------



end subroutine set_orbital_parameters



!####################################################################
! <SUBROUTINE NAME="get_orbital_parameters">
!  <OVERVIEW>
!    get_orbital_parameters retrieves the orbital parameters for use
!    by another module.
!  </OVERVIEW>
!  <DESCRIPTION>
!    get_orbital_parameters retrieves the orbital parameters for use
!    by another module.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_orbital_parameters (ecc_out, obliq_out, per_out)
!  </TEMPLATE>
!  <OUT NAME="ecc_out" TYPE="real">
!   eccentricity of orbital ellipse
!  </OUT>
!  <OUT NAME="obliq_out" TYPE="real">
!   obliquity fof orbital ellipse
!  </OUT>
!  <OUT NAME="per_out" TYPE="real">
!   longitude of perihelion with respect to autumnal
!                      equinox in northern hemisphere
!  </OUT>
! </SUBROUTINE>
!
subroutine get_orbital_parameters (ecc_out, obliq_out, per_out)

!-------------------------------------------------------------------
!    get_orbital_parameters retrieves the orbital parameters for use
!    by another module.
!--------------------------------------------------------------------

real, intent(out) :: ecc_out, obliq_out, per_out

!--------------------------------------------------------------------  
!
!  intent(out) variables:
!
!     ecc_out          eccentricity of orbital ellipse 
!                      [ non-dimensional ]
!     obliq_out        obliquity
!                      [ degrees ]
!     per_out          longitude of perihelion with respect to autumnal
!                      equinox in northern hemisphere
!                      [ degrees ]
!
!-------------------------------------------------------------------

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!--------------------------------------------------------------------
!    fill the output arguments with the eccentricity, obliquity and 
!    perihelion angle.
!--------------------------------------------------------------------
      ecc_out = ecc
      obliq_out = obliq
      per_out = per


end subroutine get_orbital_parameters



!####################################################################
! <SUBROUTINE NAME="set_ref_date_of_ae">
!  <OVERVIEW>
!    set_ref_date_of_ae provides a means of specifying the reference
!    date of the NH autumnal equinox for a particular year. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    set_ref_date_of_ae provides a means of specifying the reference
!    date of the NH autumnal equinox for a particular year.  it is only
!    used if calls are made to the calandar versions of the routines 
!    diurnal_solar and daily_mean_solar. if the NOLEAP calendar is 
!    used, then the date of autumnal equinox will be the same every 
!    year. if JULIAN is used, then the date of autumnal equinox will 
!    return to the same value every 4th year.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call set_ref_date_of_ae (day_in,month_in,year_in, &
!                               second_in,minute_in,hour_in)
!  </TEMPLATE>
!  <IN NAME="day_in" TYPE="integer">
!   day of reference autumnal equinox
!  </IN>
!  <IN NAME="month_in" TYPE="integer">
!   month of reference autumnal equinox
!  </IN>
!  <IN NAME="year_in" TYPE="integer">
!   year of reference autumnal equinox
!  </IN>
!  <IN NAME="second_in" TYPE="real">
!   OPTIONAL: second of reference autumnal equinox
!  </IN>
!  <IN NAME="minute_in" TYPE="real">
!   OPTIONAL: minute of reference autumnal equinox
!  </IN>
!  <IN NAME="hour_in" TYPE="real">
!   OPTIONAL: hour of reference autumnal equinox
!  </IN>
! </SUBROUTINE>
!
subroutine set_ref_date_of_ae (day_in,month_in,year_in, &
                               second_in,minute_in,hour_in)

!---------------------------------------------------------------------
!    set_ref_date_of_ae provides a means of specifying the reference
!    date of the NH autumnal equinox for a particular year.  it is only
!    used if calls are made to the calandar versions of the routines 
!    diurnal_solar and daily_mean_solar. if the NOLEAP calendar is 
!    used, then the date of autumnal equinox will be the same every 
!    year. if JULIAN is used, then the date of autumnal equinox will 
!    return to the same value every 4th year.
!----------------------------------------------------------------------

integer, intent(in)           :: day_in, month_in, year_in
integer, intent(in), optional :: second_in, minute_in, hour_in

!--------------------------------------------------------------------  
!
!  intent(in) variables:
!
!     day_in           day of reference autumnal equinox
!                      [ non-dimensional ]
!     month_in         month of reference autumnal equinox
!                      [ non-dimensional ]
!     year_in          year of reference autumnal equinox
!                      [ non-dimensional ]
!
!  intent(in), optional variables:
!
!     second_in        second of reference autumnal equinox
!                      [ non-dimensional ]
!     minute_in        minute of reference autumnal equinox
!                      [ non-dimensional ]
!     hour_in          hour of reference autumnal equinox
!                      [ non-dimensional ]
! 
!------------------------------------------------------------------- 

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!-------------------------------------------------------------------- 
!    save the input time of ae specification into a time_type module 
!    variable autumnal_eq_ref.
!--------------------------------------------------------------------
      day_ae =    day_in
      month_ae =  month_in
      year_ae =   year_in

      if (present(second_in)) then
        second_ae = second_in
        minute_ae = minute_in
        hour_ae =   hour_in
      else
        second_ae = 0
        minute_ae = 0
        hour_ae   = 0
      endif

      autumnal_eq_ref = set_date (year_ae,month_ae,day_ae, &
                                  hour_ae,minute_ae,second_ae)

!---------------------------------------------------------------------


end subroutine set_ref_date_of_ae



!####################################################################
! <SUBROUTINE NAME="get_ref_date_of_ae">
!  <OVERVIEW>
!     get_ref_date_of_ae retrieves the reference date of the autumnal
!     equinox as integer variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!     get_ref_date_of_ae retrieves the reference date of the autumnal
!     equinox as integer variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call get_ref_date_of_ae (day_out,month_out,year_out, &
!                               second_out, minute_out,hour_out)
!  </TEMPLATE>
!  <OUT NAME="day_out" TYPE="integer">
!   day of reference autumnal equinox
!  </OUT>
!  <OUT NAME="month_out" TYPE="integer">
!   month of reference autumnal equinox
!  </OUT>
!  <OUT NAME="year_out" TYPE="integer">
!   year of reference autumnal equinox
!  </OUT>
!  <OUT NAME="second_out" TYPE="real">
!   second of reference autumnal equinox
!  </OUT>
!  <OUT NAME="minute_out" TYPE="real">
!   minute of reference autumnal equinox
!  </OUT>
!  <OUT NAME="hour_out" TYPE="real">
!   hour of reference autumnal equinox
!  </OUT>
! </SUBROUTINE>
!
subroutine get_ref_date_of_ae (day_out,month_out,year_out,&
                               second_out,minute_out,hour_out)

!---------------------------------------------------------------------
!     get_ref_date_of_ae retrieves the reference date of the autumnal
!     equinox as integer variables.
!---------------------------------------------------------------------

integer, intent(out) :: day_out, month_out, year_out,  &
                        second_out, minute_out, hour_out

!--------------------------------------------------------------------  
!
!  intent(out) variables:
!
!     day_out          day of reference autumnal equinox
!                      [ non-dimensional ]
!     month_out        month of reference autumnal equinox
!                      [ non-dimensional ]
!     year_out         year of reference autumnal equinox
!                      [ non-dimensional ]
!     second_out       second of reference autumnal equinox
!                      [ non-dimensional ]
!     minute_out       minute of reference autumnal equinox
!                      [ non-dimensional ]
!     hour_out         hour of reference autumnal equinox
!                      [ non-dimensional ]
! 
!------------------------------------------------------------------- 

!---------------------------------------------------------------------
!    exit if module has not been initialized.
!---------------------------------------------------------------------
      if (.not. module_is_initialized)   &
        call error_mesg ( 'astronomy_mod',  &
         ' module has not been initialized', FATAL)

!---------------------------------------------------------------------
!    fill the output fields with the proper module data.
!---------------------------------------------------------------------
      day_out    =  day_ae
      month_out  =  month_ae
      year_out   =  year_ae
      second_out =  second_ae
      minute_out =  minute_ae
      hour_out   =  hour_ae


end subroutine get_ref_date_of_ae



!#####################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    INTERFACE DIURNAL_SOLAR
!
! call diurnal_solar (lat, lon, time, cosz, fracday, rrsun, dt_time)
!   or 
! call diurnal_solar (lat, lon, gmt, time_since_ae, cosz, fracday, 
!                     rrsun, dt)
!
!  the first option (used in conjunction with time_manager_mod)      
!  generates the real variables gmt and time_since_ae from the 
!  time_type input, and then calls diurnal_solar with these real
!  inputs. 
!
!  the time of day is set by 
!    real, intent(in) :: gmt
!  the time of year is set by 
!    real, intent(in) :: time_since_ae
!  with time_type input, both of these are extracted from 
!    type(time_type), intent(in) :: time
!
!
!  separate routines exist within this interface for scalar, 
!  1D or 2D input and output fields:
!
!    real, intent(in), dimension(:,:) :: lat, lon
! OR real, intent(in), dimension(:)   :: lat, lon
! OR real, intent(in)                 :: lat, lon
!
!    real, intent(out), dimension(:,:) :: cosz, fracday
! OR real, intent(out), dimension(:)   :: cosz, fracday
! OR real, intent(out)                 :: cosz, fracday
!
!  one may also average the output fields over the time interval 
!  between gmt and gmt + dt by including the optional argument dt (or 
!  dt_time). dt is measured in radians and must be less than pi 
!  (1/2 day). this average is computed analytically, and should be 
!  exact except for the fact that changes in earth-sun distance over 
!  the time interval dt are ignored. in the context of a diurnal GCM, 
!  this option should always be employed to insure that the total flux 
!  at the top of the atmosphere is not modified by time truncation 
!  error.
!
!    real, intent(in), optional :: dt
!    type(time_type), optional :: dt_time
! (see test.90 for examples of the use of these types)
!
!--------------------------------------------------------------------
!
!  intent(in) variables:
!
!     lat            latitudes of model grid points 
!                    [ radians ]
!     lon            longitudes of model grid points
!                    [ radians ]
!     gmt            time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!                    [ radians ]
!     time_since_ae  time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!                    [ radians ]
!     time           time at which astronomical values are desired
!                    time_type variable [ seconds, days]
!     
!
!  intent(out) variables:
!
!     cosz           cosine of zenith angle, set to zero when entire
!                    period is in darkness
!                    [ dimensionless ]
!     fracday        daylight fraction of time interval
!                    [ dimensionless ]
!     rrsun          earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!                    [ dimensionless ]
!
!  intent(in), optional variables:
!
!     dt            time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous. 
!                   [ radians ], (1 day = 2 * pi)
!     dt_time       as in dt, but dt_time is a time_type variable
!                   time_type [ days, seconds ]
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! <SUBROUTINE NAME="diurnal_solar_2d">
!  <OVERVIEW>
!    diurnal_solar_2d returns 2d fields of cosine of zenith angle, 
!    daylight fraction and earth-sun distance at the specified lati-
!    tudes, longitudes and time. these values may be instantaneous
!    or averaged over a specified time interval.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diurnal_solar_2d returns 2d fields of cosine of zenith angle, 
!    daylight fraction and earth-sun distance at the specified lati-
!    tudes, longitudes and time. these values may be instantaneous
!    or averaged over a specified time interval.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diurnal_solar_2d (lat, lon, gmt, time_since_ae, cosz, &
!                             fracday, rrsun, dt_time) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="lon" TYPE="real">
!   longitude of model grid points 
!  </IN>
!  <IN NAME="gmt" TYPE="real">
!   time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!  </IN>
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
!  <IN NAME="dt" TYPE="real">
!   OPTIONAL: time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous.
!  </IN>
! </SUBROUTINE>
!
subroutine diurnal_solar_2d (lat, lon, gmt, time_since_ae, cosz, &
                             fracday, rrsun, dt, allow_negative_cosz, &
                             half_day_out) 

!---------------------------------------------------------------------
!    diurnal_solar_2d returns 2d fields of cosine of zenith angle, 
!    daylight fraction and earth-sun distance at the specified lati-
!    tudes, longitudes and time. these values may be instantaneous
!    or averaged over a specified time interval.
!---------------------------------------------------------------------

real, dimension(:,:), intent(in)           :: lat, lon
real,                 intent(in)           :: gmt, time_since_ae
real, dimension(:,:), intent(out)          :: cosz, fracday
real,                 intent(out)          :: rrsun
real,                 intent(in), optional :: dt
logical,              intent(in), optional :: allow_negative_cosz
real, dimension(:,:), intent(out), optional :: half_day_out


!---------------------------------------------------------------------
!   local variables

      real, dimension(size(lat,1),size(lat,2)) :: t, tt, h, aa, bb,  &
                                                  st, stt, sh
      real                                     :: ang, dec
      logical :: Lallow_negative

!---------------------------------------------------------------------
!   local variables
!
!    t           time of day with respect to local noon (2 pi = 1 day)
!                [ radians ]
!    tt          end of averaging period [ radians ]
!    h           half of the daily period of daylight, centered at noon
!                [ radians, -pi --> pi ]
!    aa          sin(lat) * sin(declination)
!    bb          cos(lat) * cos(declination)
!    st          sine of time of day
!    stt         sine of time of day at end of averaging period
!    sh          sine of half-day period
!    ang         position of earth in its orbit wrt autumnal equinox
!                [ radians ]
!    dec         earth's declination [ radians ]
!    
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    be sure the time in the annual cycle is legitimate.
!---------------------------------------------------------------------
      if (time_since_ae < 0.0 .or. time_since_ae > twopi) &
          call error_mesg('astronomy_mod', &
                    'time_since_ae not between 0 and 2pi', FATAL)

!--------------------------------------------------------------------
!    be sure the time at longitude = 0.0 is legitimate.
!---------------------------------------------------------------------
      if (gmt < 0.0 .or. gmt > twopi) &
         call error_mesg('astronomy_mod', &
                    'gmt not between 0 and 2pi', FATAL)

!---------------------------------------------------------------------
!    define the orbital angle (location in year), solar declination and
!    earth sun distance factor. use functions contained in this module.
!---------------------------------------------------------------------
      ang = angle(time_since_ae)
      dec = declination(ang)
      rrsun  = r_inv_squared(ang)

!---------------------------------------------------------------------
!    define terms needed in the cosine zenith angle equation.
!--------------------------------------------------------------------
      aa = sin(lat)*sin(dec)
      bb = cos(lat)*cos(dec)

!---------------------------------------------------------------------
!    define local time. force it to be between -pi and pi.
!--------------------------------------------------------------------
      t = gmt + lon - PI
      where(t >= PI) t = t - twopi  
      where(t < -PI) t = t + twopi   

      Lallow_negative = .false.
      if (present(allow_negative_cosz)) then
         if (allow_negative_cosz) Lallow_negative = .true.
      end if

!---------------------------------------------------------------------
!    perform a time integration to obtain cosz and fracday if desired.
!    output is valid over the period from t to t + dt.
!--------------------------------------------------------------------
      h   = half_day   (lat,dec)
      
      if ( present(half_day_out) ) then 
         half_day_out = h
      end if

      if ( present(dt) ) then   ! (perform time averaging)
        tt = t + dt
        st  = sin(t)
        stt = sin(tt)
        sh  = sin(h)
        cosz = 0.0

        if (.not. Lallow_negative) then
!-------------------------------------------------------------------
!    case 1: entire averaging period is before sunrise.
!-------------------------------------------------------------------
        where (t < -h .and. tt < -h) cosz = 0.0

!-------------------------------------------------------------------
!    case 2: averaging period begins before sunrise, ends after sunrise
!    but before sunset
!-------------------------------------------------------------------
        where ( (tt+h) /= 0.0 .and.   t < -h .and. abs(tt) <= h)   &
             cosz = aa + bb*(stt + sh)/ (tt + h)

!-------------------------------------------------------------------
!    case 3: averaging period begins before sunrise, ends after sunset,
!    but before the next sunrise. modify if averaging period extends 
!    past the next day's sunrise, but if averaging period is less than 
!    a half- day (pi) that circumstance will never occur.
!-------------------------------------------------------------------
        where (t < -h .and. h /= 0.0 .and. h < tt)    &
              cosz = aa + bb*( sh + sh)/(h+h)

!-------------------------------------------------------------------
!    case 4: averaging period begins after sunrise, ends before sunset.
!-------------------------------------------------------------------
        where ( abs(t) <= h .and. abs(tt) <= h)    &
             cosz = aa + bb*(stt - st)/ (tt - t)

!-------------------------------------------------------------------
!    case 5: averaging period begins after sunrise, ends after sunset. 
!    modify when averaging period extends past the next day's sunrise.  
!------------------------------------------------------------------- 
        where ((h-t) /= 0.0 .and. abs(t) <= h .and.  h < tt)    &
              cosz = aa + bb*(sh - st)/(h-t)

!-------------------------------------------------------------------
!    case 6: averaging period begins after sunrise , ends after the
!    next day's sunrise. note that this includes the case when the
!    day length is one day (h = pi).
!-------------------------------------------------------------------
        where (twopi - h < tt .and. (tt+h-twopi) /= 0.0 .and. t <= h ) &
           cosz = (cosz*(h - t) + (aa*(tt + h - twopi) +     &
            bb*(stt + sh))) / ((h - t) + (tt + h - twopi))

!-------------------------------------------------------------------
!    case 7: averaging period begins after sunset and ends before the
!    next day's sunrise
!-------------------------------------------------------------------
        where(  h <  t .and. twopi - h >= tt  ) cosz = 0.0

!-------------------------------------------------------------------
!    case 8: averaging period begins after sunset and ends after the
!    next day's sunrise but before the next day's sunset. if the
!    averaging period is less than a half-day (pi) the latter
!    circumstance will never occur.
!-----------------------------------------------------------------
        where(  h <  t .and. twopi - h < tt  ) 
          cosz = aa + bb*(stt + sh) / (tt + h - twopi)
        end where

        else
           cosz = aa + bb*(stt - st)/ (tt - t)
        end if



!-------------------------------------------------------------------
!    day fraction is the fraction of the averaging period contained 
!    within the (-h,h) period.
!-------------------------------------------------------------------
        where (t < -h .and.      tt < -h)      fracday = 0.0
        where (t < -h .and. abs(tt) <= h)      fracday = (tt + h )/dt
        where (t < -h .and.       h < tt)      fracday = ( h + h )/dt
        where (abs(t) <= h .and. abs(tt) <= h) fracday = (tt - t )/dt
        where (abs(t) <= h .and.       h < tt) fracday = ( h - t )/dt
        where (      h <  t                 )  fracday = 0.0
        where (twopi - h < tt)                 fracday = fracday +  &
                                                         (tt + h - &
                                                         twopi)/dt      
!----------------------------------------------------------------------
!    if instantaneous values are desired, define cosz at time t.
!----------------------------------------------------------------------
      else  ! (no time averaging)
        if (.not. Lallow_negative) then
           where (abs(t) < h)
             cosz = aa + bb*cos(t)
             fracday = 1.0
           elsewhere
             cosz = 0.0
             fracday = 0.0
           end where
        else
           cosz = aa + bb*cos(t)
           where (abs(t) < h)
             fracday = 1.0
           elsewhere
             fracday = 0.0
           end where
        end if
      end if

!----------------------------------------------------------------------
!    be sure that cosz is not negative.
!----------------------------------------------------------------------
      if (.not. Lallow_negative) then
         cosz = max(0.0, cosz)
      end if

!--------------------------------------------------------------------



end subroutine diurnal_solar_2d


!######################################################################
! <SUBROUTINE NAME="diurnal_solar_1d">
!  <OVERVIEW>
!    diurnal_solar_1d takes 1-d input fields, adds a second dimension
!    and calls diurnal_solar_2d. on return, the 2d fields are returned
!    to the original 1d fields.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diurnal_solar_1d takes 1-d input fields, adds a second dimension
!    and calls diurnal_solar_2d. on return, the 2d fields are returned
!    to the original 1d fields.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diurnal_solar_1d (lat, lon, gmt, time_since_ae, cosz, &
!                             fracday, rrsun, dt) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="lon" TYPE="real">
!   longitude of model grid points 
!  </IN>
!  <IN NAME="gmt" TYPE="real">
!   time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!  </IN>
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
!  <IN NAME="dt" TYPE="real">
!   OPTIONAL: time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous.
!  </IN>
! </SUBROUTINE>
!
subroutine diurnal_solar_1d (lat, lon, gmt, time_since_ae, cosz, &
                             fracday, rrsun, dt, allow_negative_cosz, &
                             half_day_out)

!--------------------------------------------------------------------
!    diurnal_solar_1d takes 1-d input fields, adds a second dimension
!    and calls diurnal_solar_2d. on return, the 2d fields are returned
!    to the original 1d fields.
!----------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:),  intent(in)           :: lat, lon
real,                intent(in)           :: gmt, time_since_ae
real, dimension(:),  intent(out)          :: cosz, fracday
real,                intent(out)          :: rrsun
real,                intent(in), optional :: dt
logical,             intent(in), optional :: allow_negative_cosz
real, dimension(:),  intent(out), optional :: half_day_out

!---------------------------------------------------------------------
!  local variables

      real, dimension(size(lat),1) :: lat_2d, lon_2d, cosz_2d,   &
                                      fracday_2d,halfday_2d

!--------------------------------------------------------------------
!    define 2-d versions of input data arrays.
!--------------------------------------------------------------------
      lat_2d(:,1) = lat
      lon_2d(:,1) = lon

!--------------------------------------------------------------------
!    call diurnal_solar_2d to calculate astronomy fields.
!--------------------------------------------------------------------
!     if (present(dt)) then
        call diurnal_solar_2d (lat_2d, lon_2d, gmt, time_since_ae,&
                               cosz_2d, fracday_2d, rrsun, dt=dt, &
                               allow_negative_cosz=allow_negative_cosz, &
                               half_day_out=halfday_2d)
!     else
!       call diurnal_solar_2d (lat_2d, lon_2d, gmt, time_since_ae, &
!                              cosz_2d, fracday_2d, rrsun)
!     endif

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      fracday = fracday_2d(:,1)
      cosz  = cosz_2d (:,1)
      if (present(half_day_out)) then 
         half_day_out = halfday_2d(:,1)
      end if


end subroutine diurnal_solar_1d


!#####################################################################
! <SUBROUTINE NAME="diurnal_solar_0d">
!  <OVERVIEW>
!    diurnal_solar_0d takes scalar input fields, makes them into 2d
!    arrays dimensioned (1,1), and calls diurnal_solar_2d. on return, 
!    the 2d fields are converted back to the desired scalar output.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diurnal_solar_0d takes scalar input fields, makes them into 2d
!    arrays dimensioned (1,1), and calls diurnal_solar_2d. on return, 
!    the 2d fields are converted back to the desired scalar output.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diurnal_solar_0d (lat, lon, gmt, time_since_ae, cosz, &
!                             fracday, rrsun, dt) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="lon" TYPE="real">
!   longitude of model grid points 
!  </IN>
!  <IN NAME="gmt" TYPE="real">
!   time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!  </IN>
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
!  <IN NAME="dt" TYPE="real">
!   OPTIONAL: time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous.
!  </IN>
! </SUBROUTINE>
!
subroutine diurnal_solar_0d (lat, lon, gmt, time_since_ae, cosz,  &
                             fracday, rrsun, dt, allow_negative_cosz, &
                             half_day_out)

!--------------------------------------------------------------------
!    diurnal_solar_0d takes scalar input fields, makes them into 2d
!    arrays dimensioned (1,1), and calls diurnal_solar_2d. on return, 
!    the 2d fields are converted back to the desired scalar output.
!----------------------------------------------------------------------

real, intent(in)           :: lat, lon, gmt, time_since_ae
real, intent(out)          :: cosz, fracday, rrsun
real, intent(in), optional :: dt
logical,intent(in), optional :: allow_negative_cosz
real, intent(out), optional :: half_day_out

!--------------------------------------------------------------------
!  local variables:
!
      real, dimension(1,1) :: lat_2d, lon_2d, cosz_2d, fracday_2d, halfday_2d

!---------------------------------------------------------------------
!    create 2d arrays from the scalar input fields.
!---------------------------------------------------------------------
      lat_2d = lat
      lon_2d = lon

!--------------------------------------------------------------------
!    call diurnal_solar_2d to calculate astronomy fields.
!--------------------------------------------------------------------
!     if (present(dt)) then
        call diurnal_solar_2d (lat_2d, lon_2d, gmt, time_since_ae,  &
                               cosz_2d, fracday_2d, rrsun, dt=dt, &
                               allow_negative_cosz=allow_negative_cosz, &
                               half_day_out=halfday_2d)
!     else
!       call diurnal_solar_2d (lat_2d, lon_2d, gmt, time_since_ae, &
!                              cosz_2d, fracday_2d, rrsun)
!     end if

!-------------------------------------------------------------------
!    place output fields into scalars for return to calling routine.
!-------------------------------------------------------------------
      fracday = fracday_2d(1,1)
      cosz = cosz_2d(1,1)
      if (present(half_day_out)) then 
         half_day_out = halfday_2d(1,1)
      end if



end subroutine diurnal_solar_0d



!####################################################################
! <SUBROUTINE NAME="diurnal_solar_cal_2d">
!  <OVERVIEW>
!    diurnal_solar_cal_2d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diurnal_solar_cal_2d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diurnal_solar_cal_2d (lat, lon, gmt, time_since_ae, cosz, &
!                             fracday, rrsun, dt) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="lon" TYPE="real">
!   longitude of model grid points 
!  </IN>
!  <IN NAME="gmt" TYPE="real">
!   time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!  </IN>
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
!  <IN NAME="dt_time" TYPE="time_type">
!   OPTIONAL: time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous.
!  </IN>
! </SUBROUTINE>
!
subroutine diurnal_solar_cal_2d (lat, lon, time, cosz, fracday,   &
                                 rrsun, dt_time, allow_negative_cosz, &
                                 half_day_out) 

!-------------------------------------------------------------------
!    diurnal_solar_cal_2d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!-------------------------------------------------------------------

!-------------------------------------------------------------------
real, dimension(:,:), intent(in)            :: lat, lon
type(time_type),      intent(in)            :: time
real, dimension(:,:), intent(out)           :: cosz, fracday
real,                 intent(out)           :: rrsun
type(time_type),      intent(in), optional  :: dt_time
logical,              intent(in), optional  :: allow_negative_cosz
real, dimension(:,:), intent(out), optional  :: half_day_out
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables

      real :: dt
      real :: gmt, time_since_ae

!---------------------------------------------------------------------
!    extract time of day (gmt) from time_type variable time with
!    function universal_time.
!---------------------------------------------------------------------
      gmt = universal_time(time)

!---------------------------------------------------------------------
!    extract the time of year (time_since_ae) from time_type variable 
!    time using the function orbital_time.
!---------------------------------------------------------------------
      time_since_ae = orbital_time(time)

!---------------------------------------------------------------------
!    convert optional time_type variable dt_time (length of averaging 
!    period) to a real variable dt with the function universal_time.
!---------------------------------------------------------------------
      if (present(dt_time))  then
        dt = universal_time(dt_time)
        if (dt > PI) then
          call error_mesg ( 'astronomy_mod', &
             'radiation time step must be no longer than 12 hrs', &
                                                          FATAL)
        endif
        if (dt == 0.0) then
          call error_mesg ( 'astronomy_mod', &
              'radiation time step must not be an integral &
                                     &number of days', FATAL)
        endif

!--------------------------------------------------------------------
!    call diurnal_solar_2d to calculate astronomy fields, with or 
!    without the optional argument dt.
!--------------------------------------------------------------------
        call diurnal_solar_2d (lat, lon, gmt, time_since_ae, cosz, &
               fracday, rrsun, dt=dt, &
               allow_negative_cosz=allow_negative_cosz, & 
               half_day_out=half_day_out)
      else
        call diurnal_solar_2d (lat, lon, gmt, time_since_ae, cosz, &
               fracday, rrsun, &
               allow_negative_cosz=allow_negative_cosz, &
               half_day_out=half_day_out)
      end if


end subroutine diurnal_solar_cal_2d


!#####################################################################
! <SUBROUTINE NAME="diurnal_solar_cal_1d">
!  <OVERVIEW>
!    diurnal_solar_cal_1d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diurnal_solar_cal_1d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diurnal_solar_cal_1d (lat, lon, gmt, time_since_ae, cosz, &
!                             fracday, rrsun, dt) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="lon" TYPE="real">
!   longitude of model grid points 
!  </IN>
!  <IN NAME="gmt" TYPE="real">
!   time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!  </IN>
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
!  <IN NAME="dt_time" TYPE="time_type">
!   OPTIONAL: time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous.
!  </IN>
! </SUBROUTINE>
!
subroutine diurnal_solar_cal_1d (lat, lon, time, cosz, fracday,   &
                                 rrsun, dt_time, allow_negative_cosz, &
                                 half_day_out)

!--------------------------------------------------------------------
real, dimension(:), intent(in)           :: lat, lon
type(time_type),    intent(in)           :: time
real, dimension(:), intent(out)          :: cosz, fracday
real,               intent(out)          :: rrsun
type(time_type),    intent(in), optional :: dt_time
logical,            intent(in), optional :: allow_negative_cosz
real, dimension(:), intent(out), optional :: half_day_out
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!   local variables

      real, dimension(size(lat),1) :: lat_2d, lon_2d, cosz_2d, & 
                                      fracday_2d, halfday_2d

!--------------------------------------------------------------------
!    define 2-d versions of input data arrays.
!--------------------------------------------------------------------
      lat_2d(:,1) = lat
      lon_2d(:,1) = lon

!--------------------------------------------------------------------
!    call diurnal_solar_cal_2d to convert the time_types to reals and
!    then calculate the astronomy fields.
!--------------------------------------------------------------------
      if (present(dt_time)) then
        call diurnal_solar_cal_2d (lat_2d, lon_2d, time, cosz_2d,    &
           fracday_2d, rrsun, dt_time=dt_time, &
           allow_negative_cosz=allow_negative_cosz, &
           half_day_out=halfday_2d)
      else
        call diurnal_solar_cal_2d (lat_2d, lon_2d, time, cosz_2d,    &
           fracday_2d, rrsun, &
           allow_negative_cosz=allow_negative_cosz, &
           half_day_out=halfday_2d)
      end if

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      fracday = fracday_2d(:,1)
      cosz  = cosz_2d (:,1)
      if (present(half_day_out)) then 
         half_day_out = halfday_2d(:,1)
      end if
      

end subroutine diurnal_solar_cal_1d



!#####################################################################
! <SUBROUTINE NAME="diurnal_solar_cal_0d">
!  <OVERVIEW>
!    diurnal_solar_cal_0d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    diurnal_solar_cal_0d receives time_type inputs, converts 
!    them to real variables and then calls diurnal_solar_2d to
!    compute desired astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call diurnal_solar_cal_0d (lat, lon, gmt, time_since_ae, cosz, &
!                             fracday, rrsun, dt_time) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="lon" TYPE="real">
!   longitude of model grid points 
!  </IN>
!  <IN NAME="gmt" TYPE="real">
!   time of day at longitude 0.0; midnight = 0.0, 
!                    one day = 2 * pi
!  </IN>
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
!  <IN NAME="dt_time" TYPE="time_type">
!   OPTIONAL: time interval after gmt over which the astronomical
!                   variables are to be averaged. this produces averaged
!                   output rather than instantaneous.
!  </IN>
! </SUBROUTINE>
!
subroutine diurnal_solar_cal_0d (lat, lon, time, cosz, fracday,   &
                                 rrsun, dt_time, allow_negative_cosz, &
                                 half_day_out)

!---------------------------------------------------------------------
real,            intent(in)           :: lat, lon
type(time_type), intent(in)           :: time
real,            intent(out)          :: cosz, fracday, rrsun
type(time_type), intent(in), optional :: dt_time
logical,         intent(in), optional :: allow_negative_cosz
real,            intent(out), optional :: half_day_out
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables

      real, dimension(1,1) :: lat_2d, lon_2d, cosz_2d, fracday_2d, halfday_2d

!--------------------------------------------------------------------
!    define 2-d versions of input data arrays.
!--------------------------------------------------------------------
      lat_2d = lat
      lon_2d = lon

!--------------------------------------------------------------------
!    call diurnal_solar_cal_2d to convert the time_types to reals and
!    then calculate the astronomy fields.
!--------------------------------------------------------------------
      if (present(dt_time)) then
        call diurnal_solar_cal_2d (lat_2d, lon_2d, time, cosz_2d,   &
           fracday_2d, rrsun, dt_time=dt_time, &
           allow_negative_cosz=allow_negative_cosz, &
           half_day_out=halfday_2d)
      else
        call diurnal_solar_cal_2d (lat_2d, lon_2d, time, cosz_2d,   &
           fracday_2d, rrsun, &
           allow_negative_cosz=allow_negative_cosz, &
           half_day_out=halfday_2d)
      end if

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      fracday= fracday_2d(1,1)
      cosz = cosz_2d(1,1)
      if (present(half_day_out)) then 
         half_day_out = halfday_2d(1,1)
      end if


end subroutine diurnal_solar_cal_0d


!####################################################################

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                END INTERFACE DIURNAL_SOLAR
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                 INTERFACE DAILY_MEAN_SOLAR
!
!
! call daily_mean_solar (lat, time, cosz, fracday, rrsun)
!   or 
! call daily_mean_solar (lat, time_since_ae, cosz, fracday, rrsun)
!   or
! call daily_mean_solar (lat, time, cosz, solar)
!   or 
! call daily_mean_solar (lat, time_since_ae, cosz, solar)
!
!  the first option (used in conjunction with time_manager_mod)
!  generates the real variable time_since_ae from the time_type
!  input time, and then calls daily_mean_solar with this real input 
!  (option 2).  the third and fourth options correspond to the first
!  and second and are used with then spectral 2-layer model, where 
!  only cosz and solar are desired as output. these routines generate
!  dummy arguments and then call option 2, where the calculation is
!  done.
!
!  the time of year is set by 
!    real, intent(in) :: time_since_ae
!  with time_type input, the time of year is extracted from
!    type(time_type), intent(in) :: time
!
!
!  separate routines exist within this interface for scalar, 
!  1D or 2D input and output fields:
!
!    real, intent(in), dimension(:,:) :: lat
! OR real, intent(in), dimension(:)   :: lat
! OR real, intent(in)                 :: lat
!
!    real, intent(out), dimension(:,:) :: cosz, fracday
! OR real, intent(out), dimension(:)   :: cosz, fracday
! OR real, intent(out)                 :: cosz, fracday
!
!--------------------------------------------------------------------
!
!  intent(in) variables:
!
!     lat            latitudes of model grid points 
!                    [ radians ]
!     time_since_ae  time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!                    [ radians ]
!     time           time at which astronomical values are desired
!                    time_type variable [ seconds, days]
!     
!
!  intent(out) variables:
!
!     cosz           cosz is cosine of an effective zenith angle that 
!                    would produce the correct daily solar flux if the 
!                    sun were fixed at that position for the period of 
!                    daylight.  
!                    should one also, or instead, compute cosz weighted
!                    by the instantaneous flux, averaged over the day ??
!                    [ dimensionless ]
!     fracday        daylight fraction of time interval
!                    [ dimensionless ]
!     rrsun          earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!                    [ dimensionless ]
!     solar          shortwave flux factor: cosine of zenith angle *
!                    daylight fraction / (earth-sun distance squared)
!                    [ dimensionless ]
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


! <SUBROUTINE NAME="daily_mean_solar_2d">
!  <OVERVIEW>
!    daily_mean_solar_2d computes the daily mean astronomical 
!    parameters for the input points at latitude lat and time of year 
!    time_since_ae.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_2d computes the daily mean astronomical 
!    parameters for the input points at latitude lat and time of year 
!    time_since_ae.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_2d (lat, time_since_ae, cosz, h_out, rr_out)
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="h_out" TYPE="real">
!   2-d array of half-day lengths at the latitudes
!  </OUT>
!  <OUT NAME="rr_out" TYPE="real">
!   the inverse of the square of the earth-sun
!    distance relative to the mean distance at angle ang in the earth's
!    orbit.
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_2d (lat, time_since_ae, cosz, h_out, rr_out)

!----------------------------------------------------------------------
!    daily_mean_solar_2d computes the daily mean astronomical 
!    parameters for the input points at latitude lat and time of year 
!    time_since_ae.
!    
!----------------------------------------------------------------------

!----------------------------------------------------------------------
real, dimension(:,:), intent(in)   :: lat
real,                 intent(in)   :: time_since_ae
real, dimension(:,:), intent(out)  :: cosz, h_out
real,                 intent(out)  :: rr_out
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables

      real, dimension(size(lat,1),size(lat,2)) :: h
      real :: ang, dec, rr

!--------------------------------------------------------------------
!    be sure the time in the annual cycle is legitimate.
!---------------------------------------------------------------------
      if (time_since_ae < 0.0 .or. time_since_ae > twopi) &
        call error_mesg('astronomy_mod', &
                        'time_since_ae not between 0 and 2pi', FATAL)

!---------------------------------------------------------------------
!    define the orbital angle (location in year), solar declination,
!    half-day length and earth sun distance factor. use functions 
!    contained in this module.
!---------------------------------------------------------------------
      ang = angle (time_since_ae)
      dec = declination(ang)
      h   = half_day    (lat, dec)
      rr  = r_inv_squared (ang)

!---------------------------------------------------------------------
!    where the entire day is dark, define cosz to be zero. otherwise
!    use the standard formula. define the daylight fraction and earth-
!    sun distance.
!---------------------------------------------------------------------
      where (h == 0.0)
        cosz = 0.0
      elsewhere
        cosz = sin(lat)*sin(dec) + cos(lat)*cos(dec)*sin(h)/h
      end where
      h_out = h/PI
      rr_out = rr
!--------------------------------------------------------------------

end subroutine daily_mean_solar_2d



!#####################################################################
! <SUBROUTINE NAME="daily_mean_solar_1d">
!  <OVERVIEW>
!    daily_mean_solar_1d takes 1-d input fields, adds a second dimension
!    and calls daily_mean_solar_2d. on return, the 2d fields are 
!    returned to the original 1d fields.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_1d takes 1-d input fields, adds a second dimension
!    and calls daily_mean_solar_2d. on return, the 2d fields are 
!    returned to the original 1d fields.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_1d (lat, time_since_ae, cosz, h_out, rr_out)
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="h_out" TYPE="real">
!   2-d array of half-day lengths at the latitudes
!  </OUT>
!  <OUT NAME="rr_out" TYPE="real">
!   the inverse of the square of the earth-sun
!    distance relative to the mean distance at angle ang in the earth's
!    orbit.
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_1d (lat, time_since_ae, cosz, h_out, rr_out)

!--------------------------------------------------------------------
!    daily_mean_solar_1d takes 1-d input fields, adds a second dimension
!    and calls daily_mean_solar_2d. on return, the 2d fields are 
!    returned to the original 1d fields.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
real, intent(in), dimension(:) :: lat
real, intent(in) :: time_since_ae
real, intent(out), dimension(size(lat(:))) ::        cosz
real, intent(out), dimension(size(lat(:)))           :: h_out
real, intent(out)           :: rr_out
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables

      real, dimension(size(lat),1) :: lat_2d, cosz_2d, hout_2d

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
      lat_2d(:,1) = lat

!--------------------------------------------------------------------
!    call daily_mean_solar_2d to calculate astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_2d (lat_2d, time_since_ae, cosz_2d,      &
                                hout_2d, rr_out)

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      h_out = hout_2d(:,1)
      cosz  = cosz_2d(:,1)


end subroutine daily_mean_solar_1d


!######################################################################
! <SUBROUTINE NAME="daily_mean_solar_2level">
!  <OVERVIEW>
!    daily_mean_solar_2level takes 1-d input fields, adds a second 
!    dimension and calls daily_mean_solar_2d. on return, the 2d fields 
!    are returned to the original 1d fields.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_2level takes 1-d input fields, adds a second 
!    dimension and calls daily_mean_solar_2d. on return, the 2d fields 
!    are returned to the original 1d fields.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_2level (lat, time_since_ae, cosz, solar)
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="solar" TYPE="real">
!   shortwave flux factor: cosine of zenith angle *
!                    daylight fraction / (earth-sun distance squared)
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_2level (lat, time_since_ae, cosz, solar)

!--------------------------------------------------------------------
!    daily_mean_solar_2level takes 1-d input fields, adds a second 
!    dimension and calls daily_mean_solar_2d. on return, the 2d fields 
!    are returned to the original 1d fields.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
real, intent(in), dimension(:)          :: lat
real, intent(in)                        :: time_since_ae
real, intent(out), dimension(size(lat(:))) :: cosz, solar
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!   local variables

      real, dimension(size(lat),1) :: lat_2d, cosz_2d, hout_2d
      real                         :: rr_out

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
      lat_2d(:,1) = lat

!--------------------------------------------------------------------
!    call daily_mean_solar_2d to calculate astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_2d (lat_2d, time_since_ae, cosz_2d,      &
                                hout_2d, rr_out)

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      solar = cosz_2d(:,1)*hout_2d(:,1)*rr_out
      cosz  = cosz_2d(:,1)


end subroutine daily_mean_solar_2level



!####################################################################
! <SUBROUTINE NAME="daily_mean_solar_0d">
!  <OVERVIEW>
!    daily_mean_solar_1d takes 1-d input fields, adds a second dimension
!    and calls daily_mean_solar_2d. on return, the 2d fields are 
!    returned to the original 1d fields.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_1d takes 1-d input fields, adds a second dimension
!    and calls daily_mean_solar_2d. on return, the 2d fields are 
!    returned to the original 1d fields.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_0d (lat, time_since_ae, cosz, h_out, rr_out)
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN> 
!  <IN NAME="time_since_ae" TYPE="real">
!   time of year; autumnal equinox = 0.0,
!                    one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="h_out" TYPE="real">
!   2-d array of half-day lengths at the latitudes
!  </OUT>
!  <OUT NAME="rr_out" TYPE="real">
!   the inverse of the square of the earth-sun
!    distance relative to the mean distance at angle ang in the earth's
!    orbit.
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_0d (lat, time_since_ae, cosz, h_out, rr_out)

!--------------------------------------------------------------------
!    daily_mean_solar_1d takes 1-d input fields, adds a second dimension
!    and calls daily_mean_solar_2d. on return, the 2d fields are 
!    returned to the original 1d fields.
!----------------------------------------------------------------------

real, intent(in)         :: lat, time_since_ae
real, intent(out)        :: cosz, h_out, rr_out

!--------------------------------------------------------------------
!   local variables

      real, dimension(1,1) :: lat_2d, cosz_2d, hout_2d

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
      lat_2d = lat

!--------------------------------------------------------------------
!    call daily_mean_solar_2d to calculate astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_2d (lat_2d, time_since_ae, cosz_2d,     &
                                hout_2d, rr_out)

!-------------------------------------------------------------------
!    return output fields to scalars for return to calling routine.
!-------------------------------------------------------------------
      h_out = hout_2d(1,1)
      cosz  = cosz_2d(1,1)


end subroutine daily_mean_solar_0d

!####################################################################
! <SUBROUTINE NAME="daily_mean_solar_cal_2d">
!  <OVERVIEW>
!    daily_mean_solar_cal_2d receives time_type inputs, converts 
!    them to real variables and then calls daily_mean_solar_2d to
!    compute desired astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_cal_2d receives time_type inputs, converts 
!    them to real variables and then calls daily_mean_solar_2d to
!    compute desired astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_cal_2d (lat, time, cosz, fracday, rrsun) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   time of year; autumnal equinox = 0.0, one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_cal_2d (lat, time, cosz, fracday, rrsun) 

!-------------------------------------------------------------------
!    daily_mean_solar_cal_2d receives time_type inputs, converts 
!    them to real variables and then calls daily_mean_solar_2d to
!    compute desired astronomical variables.
!-------------------------------------------------------------------
 
!-------------------------------------------------------------------
real, dimension(:,:), intent(in)  :: lat
type(time_type),      intent(in)  :: time
real, dimension(:,:), intent(out) :: cosz, fracday
real,                 intent(out) :: rrsun
!-------------------------------------------------------------------

!-------------------------------------------------------------------
!  local variables

      real :: time_since_ae

!--------------------------------------------------------------------
!    be sure the time in the annual cycle is legitimate.
!---------------------------------------------------------------------
      time_since_ae = orbital_time(time)
      if (time_since_ae < 0.0 .or. time_since_ae > twopi) &
          call error_mesg ('astronomy_mod', &
                         'time_since_ae not between 0 and 2pi', FATAL)

!--------------------------------------------------------------------
!    call daily_mean_solar_2d to calculate astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_2d (lat, time_since_ae, cosz,        &
                                fracday, rrsun)


end subroutine daily_mean_solar_cal_2d



!#####################################################################
! <SUBROUTINE NAME="daily_mean_solar_cal_1d">
!  <OVERVIEW>
!    daily_mean_solar_cal_1d receives time_type inputs, converts 
!    them to real, 2d variables and then calls daily_mean_solar_2d to
!    compute desired astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_cal_1d receives time_type inputs, converts 
!    them to real, 2d variables and then calls daily_mean_solar_2d to
!    compute desired astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_cal_1d (lat, time, cosz, fracday, rrsun) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   time of year; autumnal equinox = 0.0, one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_cal_1d (lat, time, cosz, fracday, rrsun) 

!-------------------------------------------------------------------
!    daily_mean_solar_cal_1d receives time_type inputs, converts 
!    them to real, 2d variables and then calls daily_mean_solar_2d to
!    compute desired astronomical variables.
!-------------------------------------------------------------------

real, dimension(:),  intent(in)   :: lat
type(time_type),     intent(in)   :: time
real, dimension(:),  intent(out)  :: cosz, fracday
real,                intent(out)  :: rrsun

!---------------------------------------------------------------------
!  local variables

      real, dimension(size(lat),1) :: lat_2d, cosz_2d, fracday_2d
       

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
      lat_2d(:,1) = lat

!--------------------------------------------------------------------
!    call daily_mean_solar_cal_2d to convert the time_types to reals and
!    then calculate the astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_cal_2d (lat_2d, time, cosz_2d,   &
                                    fracday_2d, rrsun)

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      fracday = fracday_2d(:,1)
      cosz  = cosz_2d(:,1)


end subroutine daily_mean_solar_cal_1d


!###################################################################
! <SUBROUTINE NAME="daily_mean_solar_cal_2level">
!  <OVERVIEW>
!    daily_mean_solar_cal_2level receives 1d arrays and time_type input,
!    converts them to real, 2d variables and then calls 
!    daily_mean_solar_2d to compute desired astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_cal_2level receives 1d arrays and time_type input,
!    converts them to real, 2d variables and then calls 
!    daily_mean_solar_2d to compute desired astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_cal_2level (lat, time, cosz, solar) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   time of year; autumnal equinox = 0.0, one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="solar" TYPE="real">
!   shortwave flux factor: cosine of zenith angle *
!                    daylight fraction / (earth-sun distance squared)
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_cal_2level (lat, time, cosz, solar) 

!-------------------------------------------------------------------
!    daily_mean_solar_cal_2level receives 1d arrays and time_type input,
!    converts them to real, 2d variables and then calls 
!    daily_mean_solar_2d to compute desired astronomical variables.
!-------------------------------------------------------------------

real, dimension(:),  intent(in)   :: lat
type(time_type),     intent(in)   :: time
real, dimension(:),  intent(out)  :: cosz, solar

!---------------------------------------------------------------------
!  local variables

      real, dimension(size(lat),1) :: lat_2d, cosz_2d, fracday_2d
      real                         :: rrsun
       

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
      lat_2d(:,1) = lat

!--------------------------------------------------------------------
!    call daily_mean_solar_cal_2d to convert the time_types to reals and
!    then calculate the astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_cal_2d (lat_2d, time, cosz_2d,   &
                                    fracday_2d, rrsun)

!-------------------------------------------------------------------
!    place output fields into 1-d arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      solar = cosz_2d(:,1)*fracday_2d(:,1)*rrsun
      cosz  = cosz_2d(:,1)


end subroutine daily_mean_solar_cal_2level




!###################################################################
! <SUBROUTINE NAME="daily_mean_solar_cal_0d">
!  <OVERVIEW>
!    daily_mean_solar_cal_0d converts scalar input fields to real, 
!    2d variables and then calls daily_mean_solar_2d to compute desired
!    astronomical variables.
!  </OVERVIEW>
!  <DESCRIPTION>
!    daily_mean_solar_cal_0d converts scalar input fields to real, 
!    2d variables and then calls daily_mean_solar_2d to compute desired
!    astronomical variables.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call daily_mean_solar_cal_0d (lat, time, cosz, fracday, rrsun) 
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   time of year; autumnal equinox = 0.0, one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
! </SUBROUTINE>
!
subroutine daily_mean_solar_cal_0d (lat, time, cosz, fracday, rrsun) 

!-------------------------------------------------------------------
!    daily_mean_solar_cal_0d converts scalar input fields to real, 
!    2d variables and then calls daily_mean_solar_2d to compute desired
!    astronomical variables.
!-------------------------------------------------------------------

!--------------------------------------------------------------------
real,             intent(in)  :: lat
type(time_type),  intent(in)  :: time
real,             intent(out) :: cosz, fracday, rrsun
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables

      real, dimension(1,1) :: lat_2d, cosz_2d, fracday_2d

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
      lat_2d = lat

!--------------------------------------------------------------------
!    call daily_mean_solar_cal_2d to convert the time_types to reals and
!    then calculate the astronomy fields.
!--------------------------------------------------------------------
      call daily_mean_solar_cal_2d (lat_2d, time, cosz_2d,           &
                                    fracday_2d, rrsun)

!-------------------------------------------------------------------
!    place output fields into scalar arguments for return to 
!    calling routine.
!-------------------------------------------------------------------
      fracday = fracday_2d(1,1)
      cosz  = cosz_2d(1,1)


end subroutine daily_mean_solar_cal_0d



!####################################################################

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                END INTERFACE DAILY_MEAN_SOLAR
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                   INTERFACE ANNUAL_MEAN_SOLAR
!
!  call annual_mean_solar (js, je, lat, cosz, solar, fracday, rrsun)
!     or
!  call annual_mean_solar (lat, cosz, solar)
!
!  the second interface above is used by the spectral 2-layer model,
!  which requires only cosz and solar as output arguments, and which
!  makes this call during the initialization phase of the model.

!  separate routines exist within this interface for 1D or 2D input 
!  and output fields:
!
!    real, intent(in), dimension(:,:) :: lat
! OR real, intent(in), dimension(:)   :: lat
!
!    real, intent(out), dimension(:,:) :: cosz, solar, fracday
! OR real, intent(out), dimension(:)   :: cosz, solar, fracday
!
!---------------------------------------------------------------------
!  intent(in) variables: 
!
!     js, je         starting/ ending subdomain j indices of data in 
!                    the physics wiondow being integrated
!     lat            latitudes of model grid points 
!                    [ radians ]
!     
!
!  intent(out) variables:
!
!     cosz           cosz is the average over the year of the cosine of
!                    an effective zenith angle that would produce the 
!                    correct daily solar flux if the sun were fixed at 
!                    that single position for the period of daylight on
!                    the given day. in this average, the daily mean 
!                    effective cosz is weighted by the daily mean solar 
!                    flux.
!                    [ dimensionless ]
!     solar          normalized solar flux, averaged over the year, 
!                    equal to the product of fracday*cosz*rrsun
!                    [ dimensionless ]
!     fracday        daylight fraction calculated so as to make the 
!                    average flux (solar) equal to the product of the
!                    flux-weighted avg cosz * this fracday * assumed 
!                    annual mean avg earth-sun distance of 1.0.
!                    [ dimensionless ]
!     rrsun          annual mean earth-sun distance (r) relative to 
!                    semi-major axis of orbital ellipse (a); assumed
!                    to be 1.0
!                    [ dimensionless ]
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%





!--------------------------------------------------------------
! <SUBROUTINE NAME="annual_mean_solar_2d">
!  <OVERVIEW>
!    annual_mean_solar_2d returns 2d fields of annual mean values of
!    the cosine of zenith angle, daylight fraction and earth-sun 
!    distance at the specified latitude.
!  </OVERVIEW>
!  <DESCRIPTION>
!    annual_mean_solar_2d returns 2d fields of annual mean values of
!    the cosine of zenith angle, daylight fraction and earth-sun 
!    distance at the specified latitude.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call annual_mean_solar_2d (js, je, lat, cosz, solar, fracday,  &
!                                 rrsun)
!  </TEMPLATE>
!  <IN NAME="js, je" TYPE="real">
!   Starting/ending index of latitude window
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   time of year; autumnal equinox = 0.0, one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="solar" TYPE="real">
!   shortwave flux factor: cosine of zenith angle *
!                    daylight fraction / (earth-sun distance squared)
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
! </SUBROUTINE>
!
subroutine annual_mean_solar_2d (js, je, lat, cosz, solar, fracday,  &
                                 rrsun)

!---------------------------------------------------------------------
!    annual_mean_solar_2d returns 2d fields of annual mean values of
!    the cosine of zenith angle, daylight fraction and earth-sun 
!    distance at the specified latitude. 
!---------------------------------------------------------------------

!--------------------------------------------------------------------
integer,                 intent(in)    :: js, je
real, dimension(:,:),    intent(in)    :: lat
real, dimension(:,:),    intent(out)   :: solar, cosz, fracday
real,                    intent(out)   :: rrsun
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!  local variables

      real, dimension(size(lat,1),size(lat,2)) :: s,z
      real    :: t
      integer :: n, i

!--------------------------------------------------------------------
!    if the calculation has not yet been done, do it here.
!--------------------------------------------------------------------
      if (.not. annual_mean_calculated) then

!----------------------------------------------------------------------
!    determine annual mean values of solar flux and product of cosz 
!    and solar flux by integrating the annual cycle in num_angles 
!    orbital increments.
!----------------------------------------------------------------------
        solar = 0.0
        cosz = 0.0
        do n =1, num_angles
          t = float(n-1)*twopi/float(num_angles)
          call daily_mean_solar(lat,t, z, fracday, rrsun)
          s = z*rrsun*fracday
          solar = solar + s
          cosz  = cosz  + z*s
        end do
        solar = solar/float(num_angles)
        cosz  = cosz/float(num_angles)

!--------------------------------------------------------------------
!   define the flux-weighted annual mean cosine of the zenith angle.
!--------------------------------------------------------------------
        where(solar.eq.0.0) 
          cosz = 0.0
        elsewhere
          cosz = cosz/solar
        end where

!-------------------------------------------------------------------
!    define avg fracday such as to make the avg flux (solar) equal to 
!    the product of the avg cosz * avg fracday * assumed mean avg 
!    radius of 1.0. it is unlikely that these avg fracday and avg rr 
!    will ever be used.
!--------------------------------------------------------------------
        where(solar  .eq.0.0) 
          fracday = 0.0
        elsewhere
          fracday = solar/cosz
        end where
        rrsun = 1.00

!---------------------------------------------------------------------
!    save the values that have been calculated as module variables, if
!    those variables are present; i.e., not the spectral 2-layer model.
!---------------------------------------------------------------------
        if (allocated (cosz_ann)) then
          cosz_ann(js:je) = cosz(1,:)
          solar_ann(js:je)   = solar(1,:)
          fracday_ann(js:je) = fracday(1,:)
          rrsun_ann = rrsun

!--------------------------------------------------------------------
!    increment the points computed counter. set flag to end execution
!    once values have been calculated for all points owned by the 
!    processor.
!--------------------------------------------------------------------
          num_pts = num_pts + size(lat,1)*size(lat,2)
          if ( num_pts == total_pts)  annual_mean_calculated = .true.
        endif

!--------------------------------------------------------------------
!    if the calculation has been done, return the appropriate module 
!    variables.
!--------------------------------------------------------------------
      else
        if (allocated (cosz_ann)) then
          do i=1, size(lat,1)
            cosz(i,:)    = cosz_ann(js:je)
            solar(i,:)   = solar_ann(js:je)
            fracday(i,:) = fracday_ann(js:je)
          end do
          rrsun = rrsun_ann
        endif
      endif

!----------------------------------------------------------------------


end subroutine annual_mean_solar_2d



!#####################################################################
! <SUBROUTINE NAME="annual_mean_solar_1d">
!  <OVERVIEW>
!    annual_mean_solar_1d creates 2-d input fields from 1-d input fields
!    and then calls annual_mean_solar_2d to obtain 2-d output fields 
!    which are then stored into 1-d fields for return to the calling 
!    subroutine.
!  </OVERVIEW>
!  <DESCRIPTION>
!    annual_mean_solar_1d creates 2-d input fields from 1-d input fields
!    and then calls annual_mean_solar_2d to obtain 2-d output fields 
!    which are then stored into 1-d fields for return to the calling 
!    subroutine.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call annual_mean_solar_1d (jst, jnd, lat, cosz, solar,  &
!                                 fracday, rrsun_out)
!  </TEMPLATE>
!  <IN NAME="jst, jnd" TYPE="real">
!   Starting/ending index of latitude window
!  </IN>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   time of year; autumnal equinox = 0.0, one year = 2 * pi
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="solar" TYPE="real">
!   shortwave flux factor: cosine of zenith angle *
!                    daylight fraction / (earth-sun distance squared)
!  </OUT>
!  <OUT NAME="fracday" TYPE="real">
!   daylight fraction of time interval
!  </OUT>
!  <OUT NAME="rrsun_out" TYPE="real">
!   earth-sun distance (r) relative to semi-major axis
!                    of orbital ellipse (a) : (a/r)**2
!  </OUT>
! </SUBROUTINE>
!
subroutine annual_mean_solar_1d (jst, jnd, lat, cosz, solar,  &
                                 fracday, rrsun_out)

!---------------------------------------------------------------------
!    annual_mean_solar_1d creates 2-d input fields from 1-d input fields
!    and then calls annual_mean_solar_2d to obtain 2-d output fields 
!    which are then stored into 1-d fields for return to the calling 
!    subroutine.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
integer,            intent(in)     :: jst, jnd
real, dimension(:), intent(in)     :: lat(:)
real, dimension(:), intent(out)    :: cosz, solar,  fracday
real,               intent(out)    :: rrsun_out
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables

      real, dimension(size(lat),1) :: lat_2d, solar_2d, cosz_2d,   &
                                      fracday_2d
      real :: rrsun

!--------------------------------------------------------------------
!    if the calculation has not been done, do it here.
!--------------------------------------------------------------------
      if ( .not. annual_mean_calculated) then

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
        lat_2d(:,1) = lat

!--------------------------------------------------------------------
!    call annual_mean_solar_2d to calculate the astronomy fields.
!--------------------------------------------------------------------
        call annual_mean_solar_2d (jst, jnd, lat_2d, cosz_2d,   &
                                   solar_2d, fracday_2d, rrsun)

!-------------------------------------------------------------------
!    place output fields into 1-D arrays for return to calling routine.
!-------------------------------------------------------------------
        fracday = fracday_2d(:,1)
        rrsun_out = rrsun
        solar = solar_2d(:,1)
        cosz  =  cosz_2d(:,1)

!--------------------------------------------------------------------
!    if the calculation has been done, simply return the module 
!    variables contain the results at the desired latitudes.
!--------------------------------------------------------------------
      else
        cosz(:)    = cosz_ann(jst:jnd)
        solar(:)   = solar_ann(jst:jnd)
        fracday(:) = fracday_ann(jst:jnd)
        rrsun      = rrsun_ann
      endif

end subroutine annual_mean_solar_1d



!####################################################################
! <SUBROUTINE NAME="annual_mean_solar_2level">
!  <OVERVIEW>
!    annual_mean_solar_2level creates 2-d input fields from 1-d input 
!    fields and then calls annual_mean_solar_2d to obtain 2-d output 
!    fields which are then stored into 1-d fields for return to the 
!    calling subroutine. this subroutine will be called during model
!    initialization.
!  </OVERVIEW>
!  <DESCRIPTION>
!    annual_mean_solar_2level creates 2-d input fields from 1-d input 
!    fields and then calls annual_mean_solar_2d to obtain 2-d output 
!    fields which are then stored into 1-d fields for return to the 
!    calling subroutine. this subroutine will be called during model
!    initialization.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call annual_mean_solar_2level (lat, cosz, solar)
!  </TEMPLATE>
!  <IN NAME="lat" TYPE="real">
!   latitudes of model grid points 
!  </IN>
!  <OUT NAME="cosz" TYPE="real">
!   cosine of solar zenith angle
!  </OUT>
!  <OUT NAME="solar" TYPE="real">
!   shortwave flux factor: cosine of zenith angle *
!                    daylight fraction / (earth-sun distance squared)
!  </OUT>
! </SUBROUTINE>
!
subroutine annual_mean_solar_2level (lat, cosz, solar)

!---------------------------------------------------------------------
!    annual_mean_solar_2level creates 2-d input fields from 1-d input 
!    fields and then calls annual_mean_solar_2d to obtain 2-d output 
!    fields which are then stored into 1-d fields for return to the 
!    calling subroutine. this subroutine will be called during model
!    initialization.
!---------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:), intent(in)     :: lat
real, dimension(:), intent(out)    :: cosz, solar
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables

      real, dimension(size(lat),1) :: lat_2d, solar_2d, cosz_2d,   &
                                      fracday_2d
      integer :: jst, jnd
      real    :: rrsun

!--------------------------------------------------------------------
!    if the calculation has not been done, do it here.
!--------------------------------------------------------------------
      if ( .not. annual_mean_calculated) then

!--------------------------------------------------------------------
!    define 2-d versions of input data array.
!--------------------------------------------------------------------
        lat_2d(:,1) = lat
        jst = 1
        jnd = size(lat(:))

!--------------------------------------------------------------------
!    call annual_mean_solar_2d to calculate the astronomy fields.
!--------------------------------------------------------------------
        call annual_mean_solar_2d (jst, jnd, lat_2d, cosz_2d,   &
                                   solar_2d, fracday_2d, rrsun)

!-------------------------------------------------------------------
!    place output fields into 1-D arrays for return to calling routine.
!-------------------------------------------------------------------
        solar = solar_2d(:,1)
        cosz  =  cosz_2d(:,1)

!--------------------------------------------------------------------
!    if the calculation has been done, print an error message since
!    this subroutine should be called only once.
!--------------------------------------------------------------------
      else
        call error_mesg ('astronomy_mod', &
            'annual_mean_solar_2level should be called only once', &
                                                                 FATAL)
      endif
      annual_mean_calculated = .true.

end subroutine annual_mean_solar_2level


!####################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                END INTERFACE ANNUAL_MEAN_SOLAR
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!###################################################################
! <SUBROUTINE NAME="astronomy_end">
!  <OVERVIEW>
!    astronomy_init is the destructor for astronomy_mod.
!  </OVERVIEW>
!  <DESCRIPTION>
!    astronomy_init is the destructor for astronomy_mod.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call astronomy_end
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine astronomy_end

!----------------------------------------------------------------------
!    astronomy_end is the destructor for astronomy_mod.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!    check if the module has been initialized.
!----------------------------------------------------------------------
      if (.not. module_is_initialized)   &
                call error_mesg ( 'astronomy_mod',  &
                         ' module has not been initialized', FATAL)

!----------------------------------------------------------------------
!    deallocate module variables.
!----------------------------------------------------------------------
      deallocate (orb_angle)
      if (allocated(cosz_ann) ) then
        deallocate (cosz_ann)
        deallocate (fracday_ann)
        deallocate (solar_ann)
      endif

!----------------------------------------------------------------------
!    mark the module as uninitialized.
!----------------------------------------------------------------------
      module_is_initialized = .false.

!---------------------------------------------------------------------


end subroutine astronomy_end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                    PRIVATE SUBROUTINES
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


!####################################################################
! <SUBROUTINE NAME="orbit">
!  <OVERVIEW>
!    orbit computes and stores a table of value of orbital angles as a 
!    function of orbital time (both the angle and time are zero at 
!    autumnal equinox in the NH, and range from 0 to 2*pi).
!  </OVERVIEW>
!  <DESCRIPTION>
!    orbit computes and stores a table of value of orbital angles as a 
!    function of orbital time (both the angle and time are zero at 
!    autumnal equinox in the NH, and range from 0 to 2*pi).
!  </DESCRIPTION>
!  <TEMPLATE>
!   call orbit
!  </TEMPLATE>
! </SUBROUTINE>
!
subroutine orbit

!---------------------------------------------------------------------
!    orbit computes and stores a table of value of orbital angles as a 
!    function of orbital time (both the angle and time are zero at 
!    autumnal equinox in the NH, and range from 0 to 2*pi).
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!   local variables

      integer :: n
      real    :: d1, d2, d3, d4, d5, dt, norm

!--------------------------------------------------------------------
!    allocate the orbital angle array, sized by the namelist parameter
!    num_angles, defining the annual cycle resolution of the earth's
!    orbit. define some constants to be used.
!--------------------------------------------------------------------
! wfc moving to astronomy_init
!     allocate ( orb_angle(0:num_angles) )
      orb_angle(0) = 0.0
      dt = twopi/float(num_angles)
      norm = sqrt(1.0 - ecc**2)
      dt = dt*norm

!---------------------------------------------------------------------
!    define the orbital angle at each of the num_angles locations in 
!    the orbit.
!---------------------------------------------------------------------
      do n = 1, num_angles
        d1 = dt*r_inv_squared(orb_angle(n-1))
        d2 = dt*r_inv_squared(orb_angle(n-1)+0.5*d1)
        d3 = dt*r_inv_squared(orb_angle(n-1)+0.5*d2)
        d4 = dt*r_inv_squared(orb_angle(n-1)+d3)
        d5 = d1/6.0 + d2/3.0 +d3/3.0 +d4/6.0
        orb_angle(n) = orb_angle(n-1) + d5
      end do
  
!-------------------------------------------------------------------



end subroutine orbit



!###################################################################
! <FUNCTION NAME="r_inv_squared">
!  <OVERVIEW>
!    r_inv_squared returns the inverse of the square of the earth-sun
!    distance relative to the mean distance at angle ang in the earth's
!    orbit.
!  </OVERVIEW>
!  <DESCRIPTION>
!    r_inv_squared returns the inverse of the square of the earth-sun
!    distance relative to the mean distance at angle ang in the earth's
!    orbit.
!  </DESCRIPTION>
!  <TEMPLATE>
!    r = r_inv_squared (ang)
!  </TEMPLATE>
!  <IN NAME="ang" TYPE="real">
!    angular position of earth in its orbit, relative to a 
!            value of 0.0 at the NH autumnal equinox, value between
!            0.0 and 2 * pi
!  </IN>
! </FUNCTION>
!
function r_inv_squared (ang)

!--------------------------------------------------------------------
!    r_inv_squared returns the inverse of the square of the earth-sun
!    distance relative to the mean distance at angle ang in the earth's
!    orbit.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
real, intent(in) :: ang
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!
!  intent(in) variables:
!
!      ang   angular position of earth in its orbit, relative to a 
!            value of 0.0 at the NH autumnal equinox, value between
!            0.0 and 2 * pi
!            [ radians ]
!
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!  local variables
 
      real :: r_inv_squared, r, rad_per

!---------------------------------------------------------------------
!  local variables:
!
!      r_inv_squared    the inverse of the square of the earth-sun
!                       distance relative to the mean distance 
!                       [ dimensionless ]
!      r                earth-sun distance relative to mean distance
!                       [ dimensionless ]
!      rad_per          angular position of perihelion 
!                       [ radians ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    define the earth-sun distance (r) and then return the inverse of
!    its square (r_inv_squared) to the calling routine.
!--------------------------------------------------------------------
      rad_per       = per*deg_to_rad
      r             = (1 - ecc**2)/(1. + ecc*cos(ang - rad_per))
      r_inv_squared = r**(-2)


end function r_inv_squared




!####################################################################
! <FUNCTION NAME="angle">
!  <OVERVIEW>
!    angle determines the position within the earth's orbit at time t
!    in the year ( t = 0 at NH autumnal equinox.) by interpolating
!    into the orbital position table. 
!  </OVERVIEW>
!  <DESCRIPTION>
!    angle determines the position within the earth's orbit at time t
!    in the year ( t = 0 at NH autumnal equinox.) by interpolating
!    into the orbital position table. 
!  </DESCRIPTION>
!  <TEMPLATE>
!    r = angle (t)
!  </TEMPLATE>
!  <IN NAME="t" TYPE="real">
!    time of year (between 0 and 2*pi; t=0 at NH autumnal
!                equinox
!  </IN>
! </FUNCTION>
!
function angle (t)

!--------------------------------------------------------------------
!    angle determines the position within the earth's orbit at time t
!    in the year ( t = 0 at NH autumnal equinox.) by interpolating
!    into the orbital position table. 
!--------------------------------------------------------------------

!--------------------------------------------------------------------
real, intent(in) :: t
!--------------------------------------------------------------------

!-------------------------------------------------------------------
!
!  intent(in) variables:
!
!         t      time of year (between 0 and 2*pi; t=0 at NH autumnal
!                equinox
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables

      real :: angle, norm_time, x
      integer :: int, int_1

!--------------------------------------------------------------------
!   local variables:
!
!     angle       orbital position relative to NH autumnal equinox
!                 [ radians ]
!     norm_time   index into orbital table corresponding to input time
!                 [ dimensionless ]
!     x           fractional distance between the orbital table entries
!                 bracketing the input time
!                 [ dimensionless ]
!     int         table index which is lower than actual position, but
!                 closest to it
!                 [ dimensionless ]
!     int_1       next table index just larger than actual orbital 
!                 position
!                 [ dimensionless ]
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    define orbital tables indices bracketing current orbital time
!    (int and int_1). define table index distance between the lower 
!    table value (int) and the actual orbital time (x). define orbital
!    position as being  x of the way between int and int_1. renormalize
!    angle to be within the range 0 to 2*pi.
!--------------------------------------------------------------------
      norm_time = t*float(num_angles)/twopi
      int = floor(norm_time)
      int = modulo(int,num_angles)
      int_1 = int+1
      x = norm_time - floor(norm_time)
      angle = (1.0 -x)*orb_angle(int) + x*orb_angle(int_1)
      angle = modulo(angle, twopi)

end function angle

!####################################################################
! <FUNCTION NAME="declination">
!  <OVERVIEW>
!    declination returns the solar declination angle at orbital
!    position ang in earth's orbit.
!  </OVERVIEW>
!  <DESCRIPTION>
!    declination returns the solar declination angle at orbital
!    position ang in earth's orbit.
!  </DESCRIPTION>
!  <TEMPLATE>
!    r =  declination (ang)
!  </TEMPLATE>
!  <IN NAME="ang" TYPE="real">
!     solar orbital position ang in earth's orbit
!  </IN>
! </FUNCTION>
!
function declination (ang)

!--------------------------------------------------------------------
!    declination returns the solar declination angle at orbital
!    position ang in earth's orbit.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
real, intent(in) :: ang
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!   local variables

      real :: declination
      real :: rad_obliq, sin_dec

!--------------------------------------------------------------------
!   local variables:
!
!    declination         solar declination angle
!                        [ radians ]              
!    rad_obliq           obliquity of the ecliptic
!                        [ radians ]              
!    sin_dec             sine of the solar declination
!                        [ dimensionless ]
!
!--------------------------------------------------------------------

!---------------------------------------------------------------------
!    compute the solar declination.
!---------------------------------------------------------------------
      rad_obliq   =   obliq*deg_to_rad
      sin_dec     = - sin(rad_obliq)*sin(ang)
      declination =   asin(sin_dec)


end function declination


!#####################################################################


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                 INTERFACE HALF_DAY
!
! half_day (latitude, dec) result (h)
!
!
!  separate routines exist within this interface for scalar, 
!  or 2D input and output fields:
!
!    real, intent(in), dimension(:,:) :: latitude
! OR real, intent(in)                 :: latitude
!
!    real, dimension(size(latitude,1),size(latitude,2))  :: h
! OR real                                                :: h
!
!--------------------------------------------------------------------
!
!  intent(in) variables:
!
!     latitude       latitudes of model grid points 
!                    [ radians ]
!     dec            solar declination               
!                    [ radians ]
!
!  intent(out) variables:
!
!     h              half of the length of daylight at the given 
!                    latitude and orbital position (dec); value
!                    ranges between 0 (all darkness) and pi (all
!                    daylight)
!                    [ dimensionless ]
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! <FUNCTION NAME="half_day_2d">
!  <OVERVIEW>
!    half_day_2d returns a 2-d array of half-day lengths at the 
!    latitudes and declination provided.
!  </OVERVIEW>
!  <DESCRIPTION>
!    half_day_2d returns a 2-d array of half-day lengths at the 
!    latitudes and declination provided.
!  </DESCRIPTION>
!  <TEMPLATE>
!    h = half_day_2d (latitude, dec)
!  </TEMPLATE>
!  <IN NAME="latitude" TYPE="real">
!   latitutde of view point
!  </IN>
!  <IN NAME="dec" TYPE="real">
!   solar declination angle at view point
!  </IN>
! </FUNCTION>
!
function half_day_2d (latitude, dec) result(h)

!--------------------------------------------------------------------
!    half_day_2d returns a 2-d array of half-day lengths at the 
!    latitudes and declination provided.
!--------------------------------------------------------------------

!---------------------------------------------------------------------
real, dimension(:,:), intent(in)                     :: latitude
real,                 intent(in)                     :: dec
real, dimension(size(latitude,1),size(latitude,2))   :: h
!---------------------------------------------------------------------


!---------------------------------------------------------------------
!   local variables

      real, dimension (size(latitude,1),size(latitude,2)):: & 
                                                  cos_half_day, lat
      real :: tan_dec 
      real :: eps = 1.0E-05

!---------------------------------------------------------------------
!   local variables
!
!     cos_half_day       cosine of half-day length
!                        [ dimensionless ]
!     lat                model latitude, adjusted so that it is never 
!                        0.5*pi or -0.5*pi
!     tan_dec            tangent of solar declination
!                        [ dimensionless ]
!     eps                small increment
!
!--------------------------------------------------------------------
   
!--------------------------------------------------------------------
!    define tangent of the declination.
!--------------------------------------------------------------------
      tan_dec = tan(dec)

!--------------------------------------------------------------------
!    adjust latitude so that its tangent will be defined.
!--------------------------------------------------------------------
      lat = latitude
      where (latitude ==  0.5*PI) lat= latitude - eps
      where (latitude == -0.5*PI) lat= latitude + eps

!--------------------------------------------------------------------
!    define the cosine of the half-day length. adjust for cases of 
!    all daylight or all night.
!--------------------------------------------------------------------
      cos_half_day = -tan(lat)*tan_dec
      where (cos_half_day <= -1.0)  h = PI
      where (cos_half_day >= +1.0)  h = 0.0
      where(cos_half_day > -1.0 .and. cos_half_day < 1.0) &
                                               h = acos(cos_half_day)


end function half_day_2d

!---------------------------------------------------------------
! <FUNCTION NAME="half_day_0d">
!  <OVERVIEW>
!    half_day_0d takes scalar input fields, makes them into 2-d fields
!    dimensioned (1,1), and calls half_day_2d. on return, the 2-d 
!    fields are converted to the desired scalar output.
!  </OVERVIEW>
!  <DESCRIPTION>
!    half_day_0d takes scalar input fields, makes them into 2-d fields
!    dimensioned (1,1), and calls half_day_2d. on return, the 2-d 
!    fields are converted to the desired scalar output.
!  </DESCRIPTION>
!  <TEMPLATE>
!    h = half_day_2d (latitude, dec)
!  </TEMPLATE>
!  <IN NAME="latitude" TYPE="real">
!   latitutde of view point
!  </IN>
!  <IN NAME="dec" TYPE="real">
!   solar declination angle at view point
!  </IN>
! </FUNCTION>
!
function half_day_0d(latitude, dec) result(h)

!--------------------------------------------------------------------
!    half_day_0d takes scalar input fields, makes them into 2-d fields
!    dimensioned (1,1), and calls half_day_2d. on return, the 2-d 
!    fields are converted to the desired scalar output.
!--------------------------------------------------------------------

real, intent(in) :: latitude, dec
real             :: h

!----------------------------------------------------------------------
!  local variables

      real, dimension(1,1) :: lat_2d, h_2d

!---------------------------------------------------------------------
!    create 2d array from the input latitude field.
!---------------------------------------------------------------------
      lat_2d = latitude

!---------------------------------------------------------------------
!    call half_day with the 2d arguments to calculate half-day length.
!---------------------------------------------------------------------
      h_2d = half_day (lat_2d, dec)

!---------------------------------------------------------------------
!    create scalar from 2d array.
!---------------------------------------------------------------------
      h = h_2d(1,1)



end function half_day_0d


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                
!                 END INTERFACE HALF_DAY
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




!####################################################################
! <FUNCTION NAME="orbital_time">
!  <OVERVIEW>
!    orbital time returns the time (1 year = 2*pi) since autumnal 
!    equinox
!  </OVERVIEW>
!  <DESCRIPTION>
!    orbital time returns the time (1 year = 2*pi) since autumnal 
!    equinox; autumnal_eq_ref is a module variable of time_type and 
!    will have been defined by default or by a call to 
!    set_ref_date_of_ae; length_of_year is available through the time 
!    manager and is set at the value approriate for the calandar being 
!    used
!  </DESCRIPTION>
!  <TEMPLATE>
!    t = orbital_time(time)
!  </TEMPLATE>
!  <IN NAME="time" TYPE="time_type">
!   time (1 year = 2*pi) since autumnal equinox
!  </IN>
! </FUNCTION>
!
function orbital_time(time) result(t)

!---------------------------------------------------------------------
!    orbital time returns the time (1 year = 2*pi) since autumnal 
!    equinox; autumnal_eq_ref is a module variable of time_type and 
!    will have been defined by default or by a call to 
!    set_ref_date_of_ae; length_of_year is available through the time 
!    manager and is set at the value approriate for the calandar being 
!    used
!---------------------------------------------------------------------

type(time_type), intent(in) :: time
real                        :: t

!--------------------------------------------------------------------
      t = real ( (time - autumnal_eq_ref)//period_time_type)
      t = twopi*(t - floor(t))
      if (time < autumnal_eq_ref) t = twopi - t 


end function orbital_time


!#####################################################################
! <FUNCTION NAME="universal_time">
!  <OVERVIEW>
!    universal_time returns the time of day at longitude = 0.0 
!    (1 day = 2*pi)
!  </OVERVIEW>
!  <DESCRIPTION>
!    universal_time returns the time of day at longitude = 0.0 
!    (1 day = 2*pi)
!  </DESCRIPTION>
!  <TEMPLATE>
!    t = universal_time(time)
!  </TEMPLATE>
!  <IN NAME="time" TYPE="time_type">
!   time (1 year = 2*pi) since autumnal equinox
!  </IN>
! </FUNCTION>
!
function universal_time(time) result(t)

!--------------------------------------------------------------------
!    universal_time returns the time of day at longitude = 0.0 
!    (1 day = 2*pi)
!--------------------------------------------------------------------

type(time_type), intent(in) :: time
real                        :: t

!--------------------------------------------------------------------
!   local variables

      integer ::  seconds, days

      call get_time (time, seconds, days)
      t = twopi*real(seconds)/seconds_per_day 

end function universal_time


!#####################################################################





                   end module astronomy_mod


module axis_utils_mod
  !
  !<CONTACT EMAIL="Matthew.Harrison@noaa.gov">M.J. Harrison</CONTACT>
  !
  !<REVIEWER EMAIL="Bruce.Wyman@noaa.gov">Bruce Wyman</REVIEWER>
  !

  !<OVERVIEW>
  ! A set of utilities for manipulating axes and extracting axis
  ! attributes
  !</OVERVIEW>

  !<DESCRIPTION>
  !
  ! subroutine get_axis_cart(axis,cart) : Returns X,Y,Z or T cartesian attribute
  ! subroutine get_axis_bounds(axis,axis_bound,axes) : Return axis_bound either from an array of 
  !                                                    available axes, or defined based on axis mid-points
  ! function get_axis_modulo : Returns true if axis has the modulo attribute
  ! function get_axis_fold   : Returns is axis is folded at a boundary (non-standard meta-data)
  ! function lon_in_range    : Returns lon_strt <= longitude <= lon_strt+360
  ! subroutine tranlon       : Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360.
  ! subroutine nearest_index : Return index of nearest point along axis
  !
  !</DESCRIPTION>
  !

  use mpp_io_mod, only: axistype, atttype, default_axis, default_att,         &
                        mpp_get_atts, mpp_get_axis_data, mpp_modify_meta,     &
                        mpp_get_att_name, mpp_get_att_type, mpp_get_att_char, &
                        mpp_get_att_length
  use mpp_mod,    only: mpp_error, FATAL, stdout
  use fms_mod,    only: lowercase, string_array_index  

  implicit none

# include <netcdf.inc>

  public get_axis_cart, get_axis_bounds, get_axis_modulo, get_axis_fold, lon_in_range, &
         tranlon, frac_index, nearest_index, interp_1d, get_axis_modulo_times

  private

  integer, parameter :: maxatts = 100
  real, parameter    :: epsln= 1.e-10
  real, parameter    :: fp5 = 0.5, f360 = 360.0
  character(len=256) :: version = '$Id: axis_utils.F90,v 16.0.10.1 2010/08/31 14:21:39 z1l Exp $'
  character(len=256) :: tagname = '$Name: hiram_20101115_bw $'   

  interface interp_1d
     module procedure interp_1d_1d
     module procedure interp_1d_2d
     module procedure interp_1d_3d
  end interface

contains


  subroutine get_axis_cart(axis, cart)      

    type(axistype), intent(in) :: axis
    character(len=1), intent(out) :: cart
    character(len=1) :: axis_cart
    character(len=16), dimension(2) :: lon_names, lat_names
    character(len=16), dimension(3) :: z_names
    character(len=16), dimension(2) :: t_names
    character(len=16), dimension(3) :: lon_units, lat_units
    character(len=8) , dimension(4) :: z_units
    character(len=3) , dimension(6) :: t_units
    character(len=32) :: name
    integer :: i,j

    lon_names = (/'lon','x  '/)
    lat_names = (/'lat','y  '/)
    z_names = (/'depth ','height','z     '/)
    t_names = (/'time','t   '/)
    lon_units = (/'degrees_e   ', 'degrees_east', 'degreese    '/)
    lat_units = (/'degrees_n    ', 'degrees_north', 'degreesn     '/)
    z_units = (/'cm ','m  ','pa ','hpa'/)
    t_units = (/'sec', 'min','hou','day','mon','yea'/)

    call mpp_get_atts(axis,cartesian=axis_cart)
    cart = 'N'

    if ( lowercase(axis_cart) == 'x' ) cart = 'X'
    if ( lowercase(axis_cart) == 'y' ) cart = 'Y'
    if ( lowercase(axis_cart) == 'z' ) cart = 'Z'
    if ( lowercase(axis_cart) == 't' ) cart = 'T'

    if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then
       call mpp_get_atts(axis,name=name)
       name = lowercase(name)
       do i=1,size(lon_names(:))
          if (trim(name(1:3)) == trim(lon_names(i))) cart = 'X'
       enddo
       do i=1,size(lat_names(:))
          if (trim(name(1:3)) == trim(lat_names(i))) cart = 'Y'
       enddo
       do i=1,size(z_names(:))
          if (trim(name) == trim(z_names(i))) cart = 'Z'
       enddo
       do i=1,size(t_names(:))
          if (trim(name) == t_names(i)) cart = 'T'
       enddo
    end if

    if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then
       call mpp_get_atts(axis,units=name)
       name = lowercase(name)
       do i=1,size(lon_units(:))
          if (trim(name) == trim(lon_units(i))) cart = 'X'
       enddo
       do i=1,size(lat_units(:))
          if (trim(name) == trim(lat_units(i))) cart = 'Y'
       enddo
       do i=1,size(z_units(:))
          if (trim(name) == trim(z_units(i))) cart = 'Z'
       enddo
       do i=1,size(t_units(:))
          if (name(1:3) == trim(t_units(i))) cart = 'T'
       enddo
    end if

    return

  end subroutine get_axis_cart


  subroutine get_axis_bounds(axis,axis_bound,axes)

    type(axistype), intent(in) :: axis
    type(axistype), intent(inout) :: axis_bound
    type(axistype), intent(in), dimension(:) :: axes

    type(atttype), dimension(:), allocatable :: att
    real, dimension(:), allocatable :: data, tmp

    integer :: i, len
    character(len=128) :: bounds_name = 'none', name, units
    character(len=256) :: longname
    character(len=1) :: cartesian

    axis_bound = default_axis
    allocate(att(maxatts))
    att = default_att
    call mpp_get_atts(axis,atts=att)

    do i=1,maxatts
       if (mpp_get_att_type(att(i)) == NF_CHAR) then
          !            if (str_contains(att(i)%name,'bounds') .or. str_contains(att(i)%name,'edge')) then
          if (string_array_index('bounds',(/mpp_get_att_name(att(i))/)) .or. &
              string_array_index('edge',(/mpp_get_att_name(att(i))/))) then
             bounds_name = mpp_get_att_char(att(i))
          endif
       endif
    enddo

    if (trim(bounds_name) /= 'none') then
       do i=1,size(axes(:))
          call mpp_get_atts(axes(i),name=name)
          if (lowercase(trim(name)) == lowercase(trim(bounds_name))) then
             axis_bound = axes(i)
          endif
       enddo
       call mpp_get_atts(axis_bound,len=len)
       if (len < 1) call mpp_error(FATAL,'error locating boundary axis for '//bounds_name)
    else
       call mpp_get_atts(axis,name=name,units=units,longname=longname,&
            cartesian=cartesian,len=len)
       name = trim(name)//'_bounds'
       longname = trim(longname)//' bounds'
       allocate(tmp(len))
       call mpp_get_axis_data(axis,tmp)
       allocate(data(len+1))
       do i=2,len
          data(i)= tmp(i-1)+fp5*(tmp(i)-tmp(i-1))
       enddo
       data(1)= tmp(1)- fp5*(tmp(2)-tmp(1))
       if (abs(data(1)) < epsln) data(1) = 0.0
       data(len+1)= tmp(len)+ fp5*(tmp(len)-tmp(len-1))         
       if (data(1) == 0.0) then
          if (abs(data(len+1)-360.) > epsln) data(len+1)=360.0
       endif
       call mpp_modify_meta(axis_bound,name=name,units=units,longname=&
            longname,cartesian=cartesian,data=data)
       deallocate(tmp)
       deallocate(data)
    endif

    return
  end subroutine get_axis_bounds

  function get_axis_modulo(axis)

    type(axistype) :: axis
    logical :: get_axis_modulo
    integer :: natt, i
    type(atttype), dimension(:), allocatable :: atts


    call mpp_get_atts(axis,natts=natt)
    allocate(atts(natt))
    call mpp_get_atts(axis,atts=atts)

    get_axis_modulo=.false.
    do i = 1,natt
       if (lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo') get_axis_modulo = .true.
    enddo

    deallocate(atts)

    return
  end function get_axis_modulo

  function get_axis_modulo_times(axis, tbeg, tend)

    logical :: get_axis_modulo_times
    type(axistype), intent(in) :: axis
    character(len=*), intent(out) :: tbeg, tend
    integer :: natt, i
    type(atttype), dimension(:), allocatable :: atts
    logical :: found_tbeg, found_tend
    
    call mpp_get_atts(axis,natts=natt)
    allocate(atts(natt))
    call mpp_get_atts(axis,atts=atts)
  
    found_tbeg = .false.
    found_tend = .false.

    do i = 1,natt
      if(lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo_beg') then
        if(mpp_get_att_length(atts(i)) > len(tbeg)) then
          call mpp_error(FATAL,'error in get: len(tbeg) too small to hold attribute')
        endif
        tbeg = trim(mpp_get_att_char(atts(i)))
        found_tbeg = .true.
      endif
      if(lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo_end') then
        if(mpp_get_att_length(atts(i)) > len(tend)) then
          call mpp_error(FATAL,'error in get: len(tend) too small to hold attribute')
        endif
        tend = trim(mpp_get_att_char(atts(i)))
        found_tend = .true.
      endif
    enddo

    if(found_tbeg .and. .not.found_tend) then
      call mpp_error(FATAL,'error in get: Found modulo_beg but not modulo_end')
    endif
    if(.not.found_tbeg .and. found_tend) then
      call mpp_error(FATAL,'error in get: Found modulo_end but not modulo_beg')
    endif

    get_axis_modulo_times = found_tbeg 

  end function get_axis_modulo_times

  function get_axis_fold(axis)

    type(axistype) :: axis
    logical :: get_axis_fold
    integer :: natt, i
    type(atttype), dimension(:), allocatable :: atts


    call mpp_get_atts(axis,natts=natt)
    allocate(atts(natt))
    call mpp_get_atts(axis,atts=atts)

    get_axis_fold=.false.
    do i = 1,natt
       if (mpp_get_att_char(atts(i)) == 'fold_top') get_axis_fold = .true.
    enddo

    deallocate(atts)

    return
  end function get_axis_fold

  function lon_in_range(lon, l_strt)
    real :: lon, l_strt, lon_in_range, l_end

    lon_in_range = lon
    l_end = l_strt+360.

    if (abs(lon_in_range - l_strt) < 1.e-4) then
       lon_in_range = l_strt
       return
    endif

    if (abs(lon_in_range - l_end) < 1.e-4) then
       lon_in_range = l_strt
       return
    endif

    do
       if (lon_in_range < l_strt) then          
          lon_in_range = lon_in_range +  f360;
       else if (lon_in_range  >  l_end) then
          lon_in_range  = lon_in_range - f360;
       else
          exit
       end if
    end do

  end function lon_in_range

  subroutine tranlon(lon, lon_start, istrt)

    ! returns array of longitudes s.t.  lon_strt <= lon < lon_strt+360.
    ! also, the first istrt-1 entries are moved to the end of the array
    !
    ! e.g.
    !        lon =      0 1 2 3 4 5  ...  358 359; lon_strt = 3 ==>
    !        tranlon =  3 4 5 6 7 8  ...  359 360 361 362; istrt = 4

    real, intent(inout), dimension(:) :: lon
    real, intent(in) :: lon_start
    integer, intent(out) :: istrt


    integer :: len, i
    real :: lon_strt, tmp(size(lon(:))-1)

    len = size(lon(:))

    do i=1,len
       lon(i) = lon_in_range(lon(i),lon_start)
    enddo

    istrt=0
    do i=1,len-1
       if (lon(i+1) < lon(i)) then
          istrt=i+1 
          exit
       endif
    enddo

    if (istrt>1) then ! grid is not monotonic
       if (abs(lon(len)-lon(1)) < epsln) then 
          tmp = cshift(lon(1:len-1),istrt-1)
          lon(1:len-1) = tmp
          lon(len) = lon(1)
       else
          lon = cshift(lon,istrt-1)
       endif
       lon_strt = lon(1)
       do i=2,len+1
          lon(i) = lon_in_range(lon(i),lon_strt)
          lon_strt = lon(i)
       enddo
    endif

    return
  end subroutine tranlon

  function frac_index (value, array)
    !=======================================================================
    !
    !     nearest_index = index of nearest data point within "array" corresponding to
    !            "value".
    !
    !     inputs:
    !
    !     value  = arbitrary data...same units as elements in "array"
    !     array  = array of data points  (must be monotonically increasing)
    !
    !     output:
    !
    !     nearest_index =  index of nearest data point to "value"
    !             if "value" is outside the domain of "array" then nearest_index = 1
    !             or "ia" depending on whether array(1) or array(ia) is
    !             closest to "value"
    !
    !             note: if "array" is dimensioned array(0:ia) in the calling
    !                   program, then the returned index should be reduced
    !                   by one to account for the zero base.
    !
    !     example:
    !
    !     let model depths be defined by the following:
    !     parameter (km=5)
    !     dimension z(km)
    !     data z /5.0, 10.0, 50.0, 100.0, 250.0/
    !
    !     k1 = nearest_index (12.5, z, km)
    !     k2 = nearest_index (0.0, z, km)
    !
    !     k1 would be set to 2, and k2 would be set to 1 so that
    !     z(k1) would be the nearest data point to 12.5 and z(k2) would
    !     be the nearest data point to 0.0
    !
    !=======================================================================

    integer :: ia, i, ii, unit
    real :: value, frac_index
    real, dimension(:) :: array
    logical keep_going
    
    ia = size(array(:))

    do i=2,ia
       if (array(i) < array(i-1)) then
          unit = stdout() 
          write (unit,*) '=> Error: "frac_index" array must be monotonically increasing when searching for nearest value to ',&
                              value
          write (unit,*) '          array(i) < array(i-1) for i=',i 
          write (unit,*) '          array(i) for i=1..ia follows:'
          do ii=1,ia
             write (unit,*) 'i=',ii, ' array(i)=',array(ii)
          enddo
          call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.')
       endif
    enddo
    if (value < array(1) .or. value > array(ia)) then
!       if (value < array(1))  frac_index = 1.
!       if (value > array(ia)) frac_index = float(ia)
        frac_index = -1.0
    else
       i=1
       keep_going = .true.
       do while (i <= ia .and. keep_going)
          i = i+1
          if (value <= array(i)) then
             frac_index = float(i-1) + (value-array(i-1))/(array(i)-array(i-1)) 
             keep_going = .false.
          endif
       enddo
    endif
  end function frac_index

  function nearest_index (value, array)
    !=======================================================================
    !
    !     nearest_index = index of nearest data point within "array" corresponding to
    !            "value".
    !
    !     inputs:
    !
    !     value  = arbitrary data...same units as elements in "array"
    !     array  = array of data points  (must be monotonically increasing)
    !     ia     = dimension of "array"
    !
    !     output:
    !
    !     nearest_index =  index of nearest data point to "value"
    !             if "value" is outside the domain of "array" then nearest_index = 1
    !             or "ia" depending on whether array(1) or array(ia) is
    !             closest to "value"
    !
    !             note: if "array" is dimensioned array(0:ia) in the calling
    !                   program, then the returned index should be reduced
    !                   by one to account for the zero base.
    !
    !     example:
    !
    !     let model depths be defined by the following:
    !     parameter (km=5)
    !     dimension z(km)
    !     data z /5.0, 10.0, 50.0, 100.0, 250.0/
    !
    !     k1 = nearest_index (12.5, z, km)
    !     k2 = nearest_index (0.0, z, km)
    !
    !     k1 would be set to 2, and k2 would be set to 1 so that
    !     z(k1) would be the nearest data point to 12.5 and z(k2) would
    !     be the nearest data point to 0.0
    !
    !=======================================================================

    integer :: nearest_index, ia, i, ii, unit
    real :: value
    real, dimension(:) :: array
    logical keep_going

    ia = size(array(:))

    do i=2,ia
       if (array(i) < array(i-1)) then
          unit = stdout()
          write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing &
                         &when searching for nearest value to ',value
          write (unit,*) '          array(i) < array(i-1) for i=',i 
          write (unit,*) '          array(i) for i=1..ia follows:'
          do ii=1,ia
             write (unit,*) 'i=',ii, ' array(i)=',array(ii)
          enddo
          call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.')
       endif
    enddo
    if (value < array(1) .or. value > array(ia)) then
       if (value < array(1))  nearest_index = 1
       if (value > array(ia)) nearest_index = ia
    else
       i=1
       keep_going = .true.
       do while (i <= ia .and. keep_going)
          i = i+1
          if (value <= array(i)) then
             nearest_index = i
             if (array(i)-value > value-array(i-1)) nearest_index = i-1
             keep_going = .false.
          endif
       enddo
    endif
  end function nearest_index

  !#############################################################################

  subroutine interp_1d_linear(grid1,grid2,data1,data2)  

    real, dimension(:),    intent(in) :: grid1, data1, grid2
    real, dimension(:), intent(inout) :: data2

    integer :: n1, n2, i, n, ext
    real :: w

    n1 = size(grid1(:))
    n2 = size(grid2(:))


    do i=2,n1
       if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic')
    enddo

    do i=2,n2
       if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic')
    enddo

    if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1')
    if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1')

    do i=1,n2
       n = nearest_index(grid2(i),grid1)

       if (grid1(n) < grid2(i)) then
          w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n))
          data2(i) = (1.-w)*data1(n) + w*data1(n+1)
       else
          if(n==1) then
             data2(i) = data1(n)
          else
             w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1))
             data2(i) = (1.-w)*data1(n-1) + w*data1(n)   
          endif     
       endif
    enddo


    return

  end subroutine interp_1d_linear

  !###################################################################
  subroutine interp_1d_cubic_spline(grid1, grid2, data1, data2, yp1, ypn)  

    real, dimension(:),    intent(in) :: grid1, grid2, data1
    real, dimension(:), intent(inout) :: data2
    real,                  intent(in) :: yp1, ypn

    real, dimension(size(grid1))      :: y2, u
    real                              :: sig, p, qn, un, h, a ,b
    integer                           :: n, m, i, k, klo, khi

    n = size(grid1(:))
    m = size(grid2(:))    

    do i=2,n
       if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic')
    enddo

    do i=2,m
       if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic')
    enddo

    if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1')
    if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1')

    if (yp1 >.99e30) then
       y2(1)=0.
       u(1)=0.
    else
       y2(1)=-0.5
       u(1)=(3./(grid1(2)-grid1(1)))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1)
    endif

    do i=2,n-1
       sig=(grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1))
       p=sig*y2(i-1)+2.
       y2(i)=(sig-1.)/p
       u(i)=(6.*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) &
             /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p
    enddo

    if (ypn > .99e30) then
       qn=0.
       un=0.
    else
       qn=0.5
       un=(3./(grid1(n)-grid1(n-1)))*(ypn-(data1(n)-data1(n-1))/(grid1(n)-grid1(n-1)))
    endif

    y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)

    do  k=n-1,1,-1
       y2(k)=y2(k)*y2(k+1)+u(k)
    enddo

    do k = 1, m
       n = nearest_index(grid2(k),grid1)
       if (grid1(n) < grid2(k)) then
          klo = n
       else
          if(n==1) then
            klo = n
          else 
            klo = n -1
          endif
       endif
       khi = klo+1
       h   = grid1(khi)-grid1(klo)
       a   = (grid1(khi) - grid2(k))/h
       b   = (grid2(k) - grid1(klo))/h
       data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2)/6
    enddo

  end subroutine interp_1d_cubic_spline

  !###################################################################

  subroutine interp_1d_1d(grid1,grid2,data1,data2, method, yp1, yp2)  

    real, dimension(:),      intent(in)    :: grid1, data1, grid2
    real, dimension(:),      intent(inout) :: data2
    character(len=*), optional, intent(in) :: method
    real,             optional, intent(in) :: yp1, yp2

    real              :: y1, y2
    character(len=32) :: interp_method    
    integer           :: k2, ks, ke

    k2 = size(grid2(:))

    interp_method = "linear"
    if(present(method)) interp_method = method
    y1 = 1.0e30
    if(present(yp1)) y1 = yp1
    y2 = 1.0e30
    if(present(yp2)) y2 = yp2
    call find_index(grid1, grid2(1), grid2(k2), ks, ke)
    select case(trim(interp_method))
    case("linear")
       call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2)
    case("cubic_spline")
       call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2)
    case default
       call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline")
    end select

    return

  end subroutine interp_1d_1d

  !###################################################################


  subroutine interp_1d_2d(grid1,grid2,data1,data2)  

    real, dimension(:,:),    intent(in) :: grid1, data1, grid2
    real, dimension(:,:), intent(inout) :: data2

    integer :: n1, n2, i, n, k2, ks, ke
    real :: w

    n1 = size(grid1,1)
    n2 = size(grid2,1)
    k2 = size(grid2,2)

    if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch')

    do n=1,n1
       call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke)
       call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:))
    enddo

    return

  end subroutine interp_1d_2d

  !###################################################################

  subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2)  

    real, dimension(:,:,:),  intent(in)    :: grid1, data1, grid2
    real, dimension(:,:,:),  intent(inout) :: data2
    character(len=*), optional, intent(in) :: method
    real,             optional, intent(in) :: yp1, yp2

    integer           :: n1, n2, m1, m2, k2, i, n, m
    real              :: w, y1, y2
    character(len=32) :: interp_method
    integer           :: ks, ke
    n1 = size(grid1,1)
    n2 = size(grid2,1)
    m1 = size(grid1,2)
    m2 = size(grid2,2)
    k2 = size(grid2,3)

    interp_method = "linear"
    if(present(method)) interp_method = method
    y1 = 1.0e30
    if(present(yp1)) y1 = yp1
    y2 = 1.0e30
    if(present(yp2)) y2 = yp2

    if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch')

    select case(trim(interp_method))
    case("linear")
       do m=1,m1
          do n=1,n1
            call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke)
             call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:))
          enddo
       enddo
    case("cubic_spline")
       do m=1,m1
          do n=1,n1
            call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke)
            call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2)
          enddo
       enddo
    case default
       call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline")
    end select

    return

  end subroutine interp_1d_3d


  !#####################################################################
  subroutine find_index(grid1, xs, xe, ks, ke)
    real, dimension(:), intent(in) :: grid1
    real,               intent(in) :: xs, xe
    integer,           intent(out) :: ks, ke

    integer :: k, nk

    nk = size(grid1(:))

    ks = 0; ke = 0
    do k = 1, nk-1
       if(grid1(k) <= xs .and. grid1(k+1) > xs ) then
          ks = k
          exit
       endif
    enddo
    do k = nk, 2, -1
       if(grid1(k) >= xe .and. grid1(k-1) < xe ) then
          ke = k
          exit
       endif
    enddo

    if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1')
    if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1')

  end subroutine find_index

end module axis_utils_mod

#ifdef test_axis_utils

program test

use fms_mod,       only : fms_init, file_exist, open_namelist_file, check_nml_error
use fms_mod,       only : close_file
use mpp_mod,       only : mpp_error, FATAL, stdout
use mpp_mod,       only : input_nml_file
use axis_utils_mod, only: interp_1d

implicit none



integer, parameter :: maxsize = 100

integer :: n_src = 0
integer :: n_dst = 0
real, dimension(MAXSIZE) :: grid_src = 0 
real, dimension(MAXSIZE) :: grid_dst = 0
real, dimension(MAXSIZE) :: data_src = 0

namelist / test_axis_utils_nml / n_src, n_dst, grid_src, grid_dst, data_src

real, allocatable :: data_dst(:)
integer           :: unit, ierr, io

  call fms_init()

  !--- default option of data
  n_src = 31
  n_dst = 40
  grid_src(1:n_src) = (/ -63.6711465476916, -63.6711455476916, 166.564180735096, 401.25299580552, &
                         641.056493022762, 886.219516665347, 1137.35352761133, 1394.4936854079,   &
                         1657.17893448689, 1925.64572676068, 2200.13183483549, 2480.9124139255,   &
                         2768.35396680912, 3062.86513953019, 3675.47369643284, 4325.10564183322,  &
                         5020.19039479527, 5769.85432323481, 6584.25101514851, 7475.94655633703,  &
                         8462.01951335773, 9568.28246037887, 10178.3869413515, 10834.1425668942,  &
                         11543.5265942777, 12317.3907407535, 13170.4562394288, 14125.6466646843,  &
                         15225.8720618086, 16554.7859690842, 19697.1334102613   /)
  grid_dst(1:n_dst) = (/ 1002.9522552602, 1077.51144617887, 1163.37842788755, 1264.19848463606,  &
                         1382.57557953916, 1521.56713587855, 1684.76300370633, 1876.37817787584, &
                         2101.36166220498, 2365.52429149707, 2675.68881278444, 3039.86610206727, &
                         3467.4620678435, 3969.52058529847, 4553.81573511231, 5159.54844211827,  &
                         5765.28114912423, 6371.01385613019, 6976.74656313614, 7582.4792701421,  &
                         8188.21197714806, 8793.94468415402, 9399.67739115997, 10005.4100981659, &
                         10611.1428051719, 11216.8755121778, 11822.6082191838, 12428.3409261898, &
                         13034.0736331957, 13639.8063402017, 14245.5390472076, 14851.2717542136, &
                         15457.0044612196, 16062.7371682255, 16668.4698752315, 17274.2025822374, &
                         17879.9352892434, 18485.6679962493, 19091.4007032553, 19697.1334102613 /)
  data_src(1:n_src) = (/ 309.895999643929, 309.991081541887, 309.971074746584, 310.873654697145, &
                         311.946530606618, 312.862249229647, 314.821236806913, 315.001269608758, &
                         315.092410930288, 315.19010999336,  315.122964496815, 315.057882573487, &
                         314.998796850493, 314.984586411292, 315.782246062002, 318.142544345795, &
                         321.553905292867, 325.247730854554, 329.151282227113, 332.835673638378, &
                         336.810414210932, 341.64530983048,  344.155248759994, 346.650476976385, &
                         349.106430095269, 351.915323032738, 354.709396583792, 359.68904432446,  &
                         371.054289820675, 395.098187506342, 446.150726850039 /)


  !---reading namelist 
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, test_axis_utils_nml, iostat=io)
#else
  if(file_exist('input.nml')) then
    unit =  open_namelist_file()
       ierr=1
    do while (ierr /= 0)
          read  (unit, nml=test_axis_utils_nml, iostat=io, end=10)
          ierr = check_nml_error(io,'test_axis_utils_nml')  ! also initializes nml error codes
    enddo
 10    call close_file(unit)
  endif
#endif

  if(n_src >MAXSIZE) call mpp_error(FATAL, 'test_axis_utils: nml n_src is greater than MAXSIZE')
  if(n_dst >MAXSIZE) call mpp_error(FATAL, 'test_axis_utils: nml n_dst is greater than MAXSIZE')

  allocate(data_dst(n_dst) )



  !--- write out data
  unit = stdout()
  write(unit,*)' the source grid is ', grid_src(1:n_src)
  write(unit,*)' the destination grid is ', grid_dst(1:n_dst)
  write(unit,*)' the source data is ', data_src(1:n_src)
  call interp_1d(grid_src(1:n_src), grid_dst(1:n_dst), data_src(1:n_src), data_dst, "linear")
  write(unit,*)' the destination data using linear interpolation is ', data_dst(1:n_dst)
  call interp_1d(grid_src(1:n_src), grid_dst(1:n_dst), data_src(1:n_src), data_dst, "cubic_spline")
  write(unit,*)' the destination data using cublic spline interpolation is ', data_dst(1:n_dst)

end program test


#endif /* test_axis_utils */







               module column_diagnostics_mod



use mpp_io_mod,             only:  mpp_io_init, mpp_open, MPP_ASCII, &
                                   MPP_OVERWR, MPP_SEQUENTIAL,   &
                                   MPP_MULTI, mpp_close
use fms_mod,                only:  fms_init, mpp_pe, mpp_root_pe, &
                                   file_exist, check_nml_error, &
                                   error_mesg, FATAL, NOTE, WARNING, &
                                   close_file, open_namelist_file, &
                                   stdlog, write_version_number
use time_manager_mod,       only:  time_manager_init, month_name, &
                                   get_date, time_type
use constants_mod,          only:  constants_init, PI, RADIAN
use mpp_mod,                only:  input_nml_file

!-------------------------------------------------------------------

implicit none
private

!---------------------------------------------------------------------
!       module to locate and mark desired diagnostic columns         
!
!
!--------------------------------------------------------------------
  



!---------------------------------------------------------------------
!----------- ****** VERSION NUMBER ******* ---------------------------


character(len=128)  :: version =  '$Id: column_diagnostics.F90,v 17.0.4.1 2010/08/31 14:21:41 z1l Exp $'
character(len=128)  :: tag     =  '$Name: hiram_20101115_bw $'



!---------------------------------------------------------------------
!-------  interfaces --------

public    column_diagnostics_init,  &
          initialize_diagnostic_columns,  &
          column_diagnostics_header,   &
          close_column_diagnostics_units


!private 


!--------------------------------------------------------------------
!----    namelist -----

real          :: crit_xdistance = 4.0   
                 ! model grid points must be within crit_xdistance in 
                 ! longitude of the requested diagnostics point 
                 ! coordinates in order to be flagged as the desired
                 ! point 
                 ! [ degrees ]
real          :: crit_ydistance = 4.0   
                 ! model grid points must be within crit_ydistance in 
                 ! latitude of the requested diagnostics point 
                 ! coordinates in order to be flagged as the desired
                 ! point 
                 ! [ degrees ]

namelist / column_diagnostics_nml /              &
                                      crit_xdistance, &
                                      crit_ydistance

!--------------------------------------------------------------------
!-------- public data  -----


!--------------------------------------------------------------------
!------ private data ------


logical    :: module_is_initialized = .false.

!-------------------------------------------------------------------
!-------------------------------------------------------------------



                        contains



!####################################################################

subroutine column_diagnostics_init 

!--------------------------------------------------------------------
!    column_diagnostics_init is the constructor for 
!    column_diagnostics_mod.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    local variables:
!
      integer    :: unit, ierr, io

!--------------------------------------------------------------------
!   local variables:
!
!       unit       unit number for nml file
!       ierr       error return flag
!       io         error return code
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    if routine has already been executed, return.
!--------------------------------------------------------------------
      if (module_is_initialized) return

!---------------------------------------------------------------------
!    verify that all modules used by this module have been initialized.
!----------------------------------------------------------------------
      call mpp_io_init
      call fms_init
      call time_manager_init
      call constants_init
 
!---------------------------------------------------------------------
!    read namelist.
!---------------------------------------------------------------------
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, column_diagnostics_nml, iostat=io)
#else
      if (file_exist('input.nml')) then
        unit =  open_namelist_file ( )
        ierr=1; do while (ierr /= 0)
        read (unit, nml=column_diagnostics_nml, iostat=io, end=10)
        ierr = check_nml_error (io, 'column_diagnostics_nml')
        enddo
10      call close_file (unit)
      endif
#endif 
!---------------------------------------------------------------------
!    write version number and namelist to logfile.
!---------------------------------------------------------------------
      call write_version_number (version, tag)
      if (mpp_pe() == mpp_root_pe())    then
                    unit = stdlog()
                    write (unit, nml=column_diagnostics_nml)
      endif
!--------------------------------------------------------------------
      module_is_initialized = .true.


end subroutine column_diagnostics_init 



!####################################################################


subroutine initialize_diagnostic_columns     &
                   (module, num_diag_pts_latlon, num_diag_pts_ij,  &
                    global_i , global_j , global_lat_latlon,   &
                    global_lon_latlon, lonb_in, latb_in,  &
                    do_column_diagnostics,  &
                    diag_lon, diag_lat, diag_i, diag_j, diag_units)

!---------------------------------------------------------------------
!    initialize_diagnostic_columns returns the (i, j, lat, lon) coord-
!    inates of any diagnostic columns that are located on the current
!    processor.
!----------------------------------------------------------------------

!---------------------------------------------------------------------
character(len=*),      intent(in)    :: module
integer,               intent(in)    :: num_diag_pts_latlon,  &
                                        num_diag_pts_ij
integer, dimension(:), intent(in)    :: global_i, global_j   
real   , dimension(:), intent(in)    :: global_lat_latlon,    &
                                        global_lon_latlon 
real,    dimension(:,:), intent(in)  :: lonb_in, latb_in
logical, dimension(:,:), intent(out) :: do_column_diagnostics
integer, dimension(:), intent(inout) :: diag_i, diag_j        
real   , dimension(:), intent(out)   :: diag_lat, diag_lon
integer, dimension(:), intent(out)   :: diag_units
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!    intent(in) variables:
!
!       module                module calling this subroutine
!       num_diag_pts_latlon   number of diagnostic columns specified
!                             by lat-lon  coordinates
!       num_diag_pts_ij       number of diagnostic columns specified
!                             by global (i,j) coordinates
!       global_i              specified global i coordinates
!       global_j              specified global j coordinates
!       global_lat_latlon     specified global lat coordinates
!       global_lon_latlon     specified global lon coordinates
!
!    intent(out) variables:
!
!       do_column_diagnostics is a diagnostic column in this jrow ?
!       diag_i                processor i indices of diagnstic columns
!       diag_j                processor j indices of diagnstic columns
!       diag_lat              latitudes of diagnostic columns 
!                             [ degrees ]
!       diag_lon              longitudes of diagnostic columns 
!                             [ degrees ]
!       diag_units            unit number for each diagnostic column
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!    local variables:

      real, dimension(size(diag_i,1))     :: global_lat, global_lon
      real, dimension(size(latb_in,1)-1, size(latb_in,2)-1) ::  &
                                  distance, distance_x, distance_y, &
                                   distance_x2, distance2
      real, dimension(size(latb_in,1), size(latb_in,2)) :: latb_deg
      real, dimension(size(lonb_in,1), size(lonb_in,2)) :: lonb_deg
      real       :: dellat, dellon
      real       :: latb_max, latb_min, lonb_max, lonb_min

      integer            ::  num_diag_pts
      integer            ::  i, j, nn
      real               ::  ref_lat
      real               ::  current_distance
      character(len=8)   ::  char
      character(len=32)  ::  filename
      logical            ::  allow_ij_input
      logical            ::  open_file        

!--------------------------------------------------------------------
!    local variables:
!
!       global_lat      latitudes for all diagnostic columns [ degrees ]
!       global_lon      longitudes for all diagnostic columns 
!                       [ degrees ]
!       num_diag_pts    total number of diagnostic columns
!       i, j, nn        do loop indices
!       char            character string for diaganostic column index
!       filename        filename for output file for diagnostic column 
!
!---------------------------------------------------------------------

      if (.not. module_is_initialized) call column_diagnostics_init

!--------------------------------------------------------------------
!    save the input lat and lon fields. define the delta of latitude
!    and longitude.
!--------------------------------------------------------------------
      latb_deg = latb_in*RADIAN
      lonb_deg = lonb_in*RADIAN
      dellat = latb_in(1,2) - latb_in(1,1)
      dellon = lonb_in(2,1) - lonb_in(1,1)
      latb_max = MAXVAL (latb_deg(:,:))
      latb_min = MINVAL (latb_deg(:,:))
      lonb_max = MAXVAL (lonb_deg(:,:))
      lonb_min = MINVAL (lonb_deg(:,:))
      if (lonb_min < 10.0 .or. lonb_max > 350.) then
        lonb_min = 0.
        lonb_max = 360.0
      endif

      allow_ij_input = .true.
      ref_lat = latb_in(1,1)
      do i =2,size(latb_in,1)
        if (latb_in(i,1) /= ref_lat) then
          allow_ij_input = .false.
          exit
        endif
      end do

      if ( .not. allow_ij_input .and. num_diag_pts_ij /= 0) then
        call error_mesg ('column_diagnostics_mod', &
        'cannot specify column diagnostics column with (i,j) &
           &coordinates when using cubed sphere -- must specify &
                                    & lat/lon coordinates', FATAL)
      endif

!----------------------------------------------------------------------
!    initialize column_diagnostics flag and diag unit numbers. define 
!    total number of diagnostic columns.
!----------------------------------------------------------------------
      do_column_diagnostics = .false.
      diag_units(:) = -1
      diag_i(:) = -99
      diag_j(:) = -99
      diag_lat(:) = -999.
      diag_lon(:) = -999.
      num_diag_pts = size(diag_i(:))

!--------------------------------------------------------------------
!    define an array of lat-lon values for all diagnostic columns.
!--------------------------------------------------------------------
      do nn = 1, num_diag_pts_latlon
        global_lat(nn) = global_lat_latlon(nn)
        global_lon(nn) = global_lon_latlon(nn)
      end do

      do nn = 1, num_diag_pts_ij
        global_lat(nn+num_diag_pts_latlon) =    &
                         ((-0.5*acos(-1.0) + 0.5*dellat) + &
                         (global_j (nn)-1) *dellat)*RADIAN
        global_lon(nn+num_diag_pts_latlon) = (0.5*dellon +     &
                          (global_i (nn)-1)*dellon)*RADIAN
      end do   

!----------------------------------------------------------------------
!    loop over all diagnostic points to check for their presence on 
!    this processor.
!----------------------------------------------------------------------
      do nn=1,num_diag_pts
        open_file = .false.

!----------------------------------------------------------------------
!    verify that the values of lat and lon are valid.
!----------------------------------------------------------------------
        if (global_lon(nn) >= 0. .and. global_lon(nn) <= 360.0) then
        else
          call error_mesg ('column_diagnostics_mod', &
               ' invalid longitude', FATAL)
        endif
        if (global_lat(nn) >= -90.0 .and. global_lat(nn) <= 90.0) then 
        else
          call error_mesg ('column_diagnostics_mod', &
               ' invalid latitude', FATAL)
        endif

!--------------------------------------------------------------------
!    if the desired diagnostics column is within the current 
!    processor's domain, define the total and coordinate distances from
!    each of the processor's grid points to the diagnostics point. 
!--------------------------------------------------------------------

        if (global_lat(nn) .ge. latb_min .and.  &
            global_lat(nn) .le. latb_max) then
          if (global_lon(nn) .ge. lonb_min     .and.&
              global_lon(nn) .le. lonb_max)  then
            do j=1,size(latb_deg,2) - 1
              do i=1,size(lonb_deg,1) - 1
                distance_y(i,j) = ABS(global_lat(nn) - latb_deg(i,j))
                distance_x(i,j) = ABS(global_lon(nn) - lonb_deg(i,j))
                distance_x2(i,j) = ABS((global_lon(nn)-360.) -  &
                                                       lonb_deg(i,j))
                distance(i,j) = (global_lat(nn) - latb_deg(i,j))**2 + &
                                (global_lon(nn) - lonb_deg(i,j))**2
                distance2(i,j) = (global_lat(nn) - latb_deg(i,j))**2 + &
                                 ((global_lon(nn)-360.) -    &
                                                   lonb_deg(i,j))**2
              end do
            end do

!--------------------------------------------------------------------
!    find the grid point on the processor that is within the specified
!    critical distance and also closest to the requested diagnostics 
!    column. save the (i,j) coordinates and (lon,lat) of this model
!    grid point. set a flag indicating that a disgnostics file should
!    be opened on this processor for this diagnostic point.
!--------------------------------------------------------------------
            current_distance = distance(1,1)
            do j=1,size(latb_deg,2) - 1
              do i=1,size(lonb_deg,1) - 1
                if (distance_x(i,j) <= crit_xdistance .and. &
                    distance_y(i,j) <= crit_ydistance ) then  
                  if (distance(i,j) < current_distance) then
                    current_distance = distance(i,j)
                    do_column_diagnostics(i,j) = .true.
                    diag_j(nn) = j
                    diag_i(nn) = i
                    diag_lon(nn) = lonb_deg(i,j)
                    diag_lat(nn) = latb_deg(i,j)
                    open_file = .true.
                  endif
                endif

!---------------------------------------------------------------------
!    check needed because of the 0.0 / 360.0 longitude periodicity.
!---------------------------------------------------------------------
                if (distance_x2(i,j) <= crit_xdistance .and. &
                    distance_y(i,j) <= crit_ydistance ) then  
                  if (distance2(i,j) < current_distance) then
                    current_distance = distance2(i,j)
                    do_column_diagnostics(i,j) = .true.
                    diag_j(nn) = j
                    diag_i(nn) = i
                    diag_lon(nn) = lonb_deg(i,j)
                    diag_lat(nn) = latb_deg(i,j)
                    open_file = .true.
                  endif
                endif
              end do
            end do

!--------------------------------------------------------------------
!    if the point has been found on this processor, open a diagnostics
!    file. 
!--------------------------------------------------------------------
            if (open_file) then
              write (char, '(i2)') nn
              filename = trim(module) // '_point' //    &
                         trim(adjustl(char)) // '.out'
              call mpp_open (diag_units(nn), filename, &
                             form=MPP_ASCII, &
                             action=MPP_OVERWR,  &
                             access=MPP_SEQUENTIAL,  &
                             threading=MPP_MULTI, nohdrs=.true.)
            endif  ! (open_file)
          endif
        endif
      end do

!---------------------------------------------------------------------


end subroutine initialize_diagnostic_columns




!####################################################################

subroutine column_diagnostics_header     &
                              (module, diag_unit, Time, nn, diag_lon, &
                               diag_lat, diag_i, diag_j)

!--------------------------------------------------------------------
!    column_diagnostics_header writes out information concerning
!    time and location of following data into the column_diagnostics
!    output file.
!--------------------------------------------------------------------

!--------------------------------------------------------------------
character(len=*),      intent(in)  :: module
type(time_type),       intent(in)  :: Time 
integer,               intent(in)  :: diag_unit
integer,               intent(in)  :: nn
real,    dimension(:), intent(in)  :: diag_lon, diag_lat
integer, dimension(:), intent(in)  :: diag_i, diag_j         

!--------------------------------------------------------------------
!    intent(in) variables
!
!       module     module name calling this subroutine
!       Time       current model time [ time_type ]
!       diag_unit  unit number for column_diagnostics output
!       nn         index of diagnostic column currently active
!       diag_lon   longitude of current diagnostic column [ degrees ]
!       diag_lat   latitude of current diagnostic column [ degrees ]
!       diag_i     i coordinate of current diagnostic column
!       diag_j     j coordinate of current diagnostic column
!
!---------------------------------------------------------------------

!--------------------------------------------------------------------
!     local variables:

      integer           :: year, month, day, hour, minute, second 
      character(len=8)  :: mon
      character(len=64) :: header

!--------------------------------------------------------------------
!     local variables:
!    
!       year, month, day, hour, minute, seconds   
!                      integers defining the current time
!       mon            character string for the current month
!       header         title for the output 
!        
!--------------------------------------------------------------------

      if (.not. module_is_initialized) call column_diagnostics_init

!--------------------------------------------------------------------
!    convert the time type to a date and time for printing. convert 
!    month to a character string.
!--------------------------------------------------------------------
      call get_date (Time, year, month, day, hour, minute, second)
      mon = month_name(month)

!---------------------------------------------------------------------
!    write timestamp and column location information to the diagnostic
!    columns output unit.
!---------------------------------------------------------------------
      write (diag_unit,'(a)')  ' '
      write (diag_unit,'(a)')  ' '
      write (diag_unit,'(a)')   &
              '======================================================'
      write (diag_unit,'(a)')  ' '
      header = '               PRINTING ' // module // '  DIAGNOSTICS' 
      write (diag_unit,'(a)')  header                          
      write (diag_unit,'(a)')  ' '
      write (diag_unit,'(a, i6,2x, a,i4,i4,i4,i4)')  ' time stamp:',  &
                                           year, trim(mon), day, &
                                           hour, minute, second
      write (diag_unit,'(a, i4)')      &
            ' DIAGNOSTIC POINT COORDINATES, point #', nn
      write (diag_unit,'(a)')  ' '
      write (diag_unit,'(a,f8.3,a,f8.3)') ' longitude = ',    &
                   diag_lon(nn), ' latitude  = ', diag_lat(nn)
      write (diag_unit,'(a, i6, a,i6,a,i6)')    &
                               ' on processor # ', mpp_pe(),   &
                               ' :   processor i =', diag_i(nn),     &
                               ' ,   processor j =', diag_j(nn)
      write (diag_unit,'(a)')  ' '

!---------------------------------------------------------------------



end subroutine column_diagnostics_header



!######################################################################

subroutine close_column_diagnostics_units (diag_units)

!---------------------------------------------------------------------
!    close_column_diagnostics_units closes any open column_diagnostics
!    files associated with the calling module.
!----------------------------------------------------------------------

!----------------------------------------------------------------------
integer, dimension(:), intent(in)  :: diag_units
!----------------------------------------------------------------------

!--------------------------------------------------------------------
!    intent(in) variable:
!
!      diag_units    array of column diagnostic unit numbers
!
!--------------------------------------------------------------------

!--------------------------------------------------------------------
!    local variable

      integer   :: nn    ! do loop index

!--------------------------------------------------------------------
!    close the unit associated with each diagnostic column.
!--------------------------------------------------------------------
      do nn=1, size(diag_units(:))
        if (diag_units(nn) /= -1) then
          call mpp_close (diag_units(nn))
        endif
      end do

!---------------------------------------------------------------------


end subroutine close_column_diagnostics_units


!#####################################################################




               end module column_diagnostics_mod



module constants_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!    Defines useful constants for Earth.
! </OVERVIEW>

! <DESCRIPTION>
!   Constants are defined as real parameters.
!   Constants are accessed through the "use" statement.
! </DESCRIPTION>

implicit none
private

character(len=128) :: version='$Id: constants.F90,v 17.0 2009/07/21 03:18:26 fms Exp $'
character(len=128) :: tagname='$Name: hiram_20101115_bw $'
!dummy variable to use in HUGE initializations
real :: realnumber

!------------ physical constants ---------------
! <DATA NAME="RADIUS" UNITS="m" TYPE="real" DEFAULT="6371.e3">
!   radius of the earth
! </DATA>
! <DATA NAME="OMEGA" UNITS="1/s" TYPE="real" DEFAULT="7.292e-5">
!   rotation rate of the planet (earth)
! </DATA>
! <DATA NAME="GRAV" UNITS="m/s^2" TYPE="real" DEFAULT="9.80">
!   acceleration due to gravity
! </DATA>
! <DATA NAME="RDGAS" UNITS="J/kg/deg" TYPE="real" DEFAULT="287.04">
!   gas constant for dry air
! </DATA>
! <DATA NAME="KAPPA" TYPE="real" DEFAULT="2./7.">
!   RDGAS / CP_AIR
! </DATA>
! <DATA NAME="CP_AIR" UNITS="J/kg/deg" TYPE="real" DEFAULT="RDGAS/KAPPA">
!   specific heat capacity of dry air at constant pressure
! </DATA>
! <DATA NAME="CP_OCEAN" UNITS="J/kg/deg" TYPE="real" DEFAULT="3989.24495292815">
!   specific heat capacity taken from McDougall (2002) "Potential Enthalpy ..."
! </DATA>
! <DATA NAME="RHO0" UNITS="kg/m^3" TYPE="real" DEFAULT="1.035e3">
!   average density of sea water
! </DATA>
! <DATA NAME="RHO0R" UNITS="m^3/kg" TYPE="real" DEFAULT="1.0/RHO0">
!   reciprocal of average density of sea water
! </DATA>
! <DATA NAME="RHO_CP" UNITS="J/m^3/deg" TYPE="real" DEFAULT="RHO0*CP_OCEAN">
!   (kg/m^3)*(cal/kg/deg C)(joules/cal) = (joules/m^3/deg C)
! </DATA>

real, public, parameter :: RADIUS = 6371.0e3   
real, public, parameter :: OMEGA  = 7.292e-5 
real, public, parameter :: GRAV   = 9.80    
real, public, parameter :: RDGAS  = 287.04 
real, public, parameter :: KAPPA  = 2./7.  
real, public, parameter :: CP_AIR = RDGAS/KAPPA 
real, public, parameter :: CP_OCEAN = 3989.24495292815
real, public, parameter :: RHO0    = 1.035e3
real, public, parameter :: RHO0R   = 1.0/RHO0
real, public, parameter :: RHO_CP  = RHO0*CP_OCEAN

!------------ water vapor constants ---------------
! <DATA NAME="ES0" TYPE="real" DEFAULT="1.0">
!   Humidity factor. Controls the humidity content of the atmosphere through 
!   the Saturation Vapour Pressure expression when using DO_SIMPLE.
! </DATA>
! <DATA NAME="RVGAS" UNITS="J/kg/deg" TYPE="real" DEFAULT="461.50">
!   gas constant for water vapor
! </DATA>
! <DATA NAME="CP_VAPOR" UNITS="J/kg/deg" TYPE="real" DEFAULT="4.0*RVGAS">
!   specific heat capacity of water vapor at constant pressure
! </DATA>
! <DATA NAME="DENS_H2O" UNITS="kg/m^3" TYPE="real" DEFAULT="1000.">
!   density of liquid water
! </DATA>
! <DATA NAME="HLV" UNITS="J/kg" TYPE="real" DEFAULT="2.500e6">
!   latent heat of evaporation
! </DATA>
! <DATA NAME="HLF" UNITS="J/kg" TYPE="real" DEFAULT="3.34e5">
!   latent heat of fusion
! </DATA>
! <DATA NAME="HLS" UNITS="J/kg" TYPE="real" DEFAULT="2.834e6">
!   latent heat of sublimation
! </DATA>
! <DATA NAME="TFREEZE" UNITS="degK" TYPE="real" DEFAULT="273.16">
!   temp where fresh water freezes
! </DATA>

real, public, parameter :: ES0 = 1.0 
real, public, parameter :: RVGAS = 461.50 
real, public, parameter :: CP_VAPOR = 4.0*RVGAS
real, public, parameter :: DENS_H2O = 1000. 
real, public, parameter :: HLV = 2.500e6   
real, public, parameter :: HLF = 3.34e5   
real, public, parameter :: HLS = HLV + HLF
real, public, parameter :: TFREEZE = 273.16    

!-------------- radiation constants -----------------

! <DATA NAME="WTMAIR" UNITS="AMU" TYPE="real" DEFAULT="2.896440E+01">
!  molecular weight of air 
! </DATA>
! <DATA NAME="WTMH2O" UNITS="AMU" TYPE="real" DEFAULT="1.801534E+01">
!  molecular weight of water
! </DATA>
! <DATA NAME="WTMOZONE" UNITS="AMU" TYPE="real" DEFAULT="4.799820E+01">
!   molecular weight of ozone
! </DATA>
! <DATA NAME="WTMC" UNITS="AMU" TYPE="real" DEFAULT="1.200000+01">
!   molecular weight of carbon 
! <DATA NAME="WTMCO2" UNITS="AMU" TYPE="real" DEFAULT="4.400995+01">
!   molecular weight of carbon dioxide
! <DATA NAME="WTMO2" UNITS="AMU" TYPE="real" DEFAULT="3.19988+01">
!   molecular weight of molecular oxygen
! <DATA NAME="WTMCFC11" UNITS="AMU" TYPE="real" DEFAULT="1.373681+02">
!   molecular weight of CFC-11 (CCl3F)
! <DATA NAME="WTMCFC12" UNITS="AMU" TYPE="real" DEFAULT="1.209135+02">
!   molecular weight of CFC-21 (CCl2F2)
! </DATA>
! <DATA NAME="DIFFAC" TYPE="real" DEFAULT="1.660000E+00">
! diffusivity factor
! </DATA>
! <DATA NAME="SECONDS_PER_DAY" UNITS="seconds" TYPE="real" DEFAULT="8.640000E+04">
! seconds in a day
! </DATA>
! <DATA NAME="AVOGNO" UNITS="atoms/mole" TYPE="real" DEFAULT="6.023000E+23">
!  Avogadro's number 
! </DATA>
! <DATA NAME="PSTD" UNITS="dynes/cm^2" TYPE="real" DEFAULT="1.013250E+06">
!  mean sea level pressure
! </DATA>
! <DATA NAME="PSTD_MKS" UNITS="Newtons/m^2" TYPE="real" DEFAULT="101325.0">
!  mean sea level pressure
! </DATA>

real, public, parameter :: WTMAIR = 2.896440E+01
real, public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !pjp OK to change value because not used yet.
!real, public, parameter :: WTMO3  = 47.99820E+01
real, public, parameter :: WTMOZONE =  47.99820
real, public, parameter :: WTMC     =  12.00000
real, public, parameter :: WTMCO2   =  44.00995
real, public, parameter :: WTMO2    =  31.9988
real, public, parameter :: WTMCFC11 = 137.3681
real, public, parameter :: WTMCFC12 = 120.9135
real, public, parameter :: DIFFAC = 1.660000E+00
real, public, parameter :: SECONDS_PER_DAY  = 8.640000E+04, SECONDS_PER_HOUR = 3600., SECONDS_PER_MINUTE=60.
real, public, parameter :: AVOGNO = 6.023000E+23
real, public, parameter :: PSTD   = 1.013250E+06
real, public, parameter :: PSTD_MKS    = 101325.0
!real, public, parameter :: REARTH  = 6.356766E+08 !pjp Not used anywhere. 

! <DATA NAME="RADCON" UNITS="deg sec/(cm day)" TYPE="real" DEFAULT="((1.0E+02*GRAV)/(1.0E+04*CP_AIR))*SECONDS_PER_DAY">
!  factor used to convert flux divergence to heating rate in degrees per day
! </DATA>
! <DATA NAME="RADCON_MKS" UNITS="deg sec/(m day)" TYPE="real" DEFAULT="(GRAV/CP_AIR)*SECONDS_PER_DAY">
!  factor used to convert flux divergence to heating rate in degrees per day
! </DATA>
! <DATA NAME="O2MIXRAT" TYPE="real" DEFAULT="2.0953E-01">
! mixing ratio of molecular oxygen in air
! </DATA>
! <DATA NAME="RHOAIR" UNITS="kg/m^3" TYPE="real" DEFAULT="1.292269">
!  reference atmospheric density
! </DATA>
! <DATA NAME="ALOGMIN" TYPE="real" DEFAULT="-50.0">
!  minimum value allowed as argument to log function
! </DATA>

real, public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0E+04*CP_AIR))*SECONDS_PER_DAY
real, public, parameter :: RADCON_MKS  = (GRAV/CP_AIR)*SECONDS_PER_DAY
real, public, parameter :: O2MIXRAT    = 2.0953E-01
real, public, parameter :: RHOAIR      = 1.292269
real, public, parameter :: ALOGMIN     = -50.0

!------------ miscellaneous constants ---------------
! <DATA NAME="STEFAN" UNITS="W/m^2/deg^4" TYPE="real" DEFAULT="5.6734e-8">
!   Stefan-Boltzmann constant
! </DATA>
! <DATA NAME="VONKARM"  TYPE="real" DEFAULT="0.40">
!   Von Karman constant
! </DATA>
! <DATA NAME="PI" TYPE="real" DEFAULT="3.14159265358979323846">
!    ratio of circle circumference to diameter
! </DATA>
! <DATA NAME="RAD_TO_DEG"  TYPE="real" DEFAULT="180.0/PI">
!   degrees per radian
! </DATA>
! <DATA NAME="DEG_TO_RAD"  TYPE="real" DEFAULT="PI/180.0">
!   radians per degree
! </DATA>
! <DATA NAME="RADIAN"  TYPE="real" DEFAULT="180.0/PI">
!   equal to RAD_TO_DEG. Named RADIAN for backward compatability.
! </DATA>
! <DATA NAME="C2DBARS" UNITS="dbars" TYPE="real" DEFAULT="1.e-4">
!   converts rho*g*z (in mks) to dbars: 1dbar = 10^4 (kg/m^3)(m/s^2)m
! </DATA>
! <DATA NAME="KELVIN" TYPE="real" DEFAULT="273.15">
!   degrees Kelvin at zero Celsius
! </DATA>
! <DATA NAME="EPSLN" TYPE="real" DEFAULT="1.0e-40">
!   a small number to prevent divide by zero exceptions
! </DATA>

real, public, parameter :: STEFAN  = 5.6734e-8 
real, public, parameter :: VONKARM = 0.40     
real, public, parameter :: PI      = 3.14159265358979323846
real, public, parameter :: RAD_TO_DEG=180./PI
real, public, parameter :: DEG_TO_RAD=PI/180.
real, public, parameter :: RADIAN  = RAD_TO_DEG
real, public, parameter :: C2DBARS = 1.e-4
real, public, parameter :: KELVIN  = 273.15
real, public, parameter :: EPSLN   = 1.0e-40
!-----------------------------------------------------------------------
! version and tagname published
! so that write_version_number can be called for constants_mod by fms_init
public :: version, tagname
!-----------------------------------------------------------------------
public :: constants_init

contains

subroutine constants_init

! dummy routine.

end subroutine constants_init

end module constants_mod

! <INFO>

!   <FUTURE>               
!   1.  Renaming of constants.
!   </FUTURE>               
!   <FUTURE>               
!   2.  Additional constants.
!   </FUTURE>
!   <NOTE>
!    Constants have been declared as type REAL, PARAMETER.
!
!    The value a constant can not be changed in a users program.
!    New constants can be defined in terms of values from the
!    constants module using a parameter statement.<br><br>
!
!    The name given to a particular constant may be changed.<br><br>
!
!    Constants can be used on the right side on an assignment statement
!    (their value can not be reassigned). 
!
!
!<TESTPROGRAM NAME="EXAMPLE">
!<PRE>
!    use constants_mod, only:  TFREEZE, grav_new => GRAV
!    real, parameter :: grav_inv = 1.0 / grav_new
!    tempc(:,:,:) = tempk(:,:,:) - TFREEZE
!    geopotential(:,:) = height(:,:) * grav_new
!</PRE>
!</TESTPROGRAM>
!   </NOTE>

! </INFO>



! ----------------------------------------------------------------
!                   GNU General Public License                        
! This file is a part of MOM.                                                                 
!                                                                      
! MOM is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
!
! 
!<CONTACT EMAIL="Richard.Slater@noaa.gov"> Richard D. Slater
!</CONTACT>
!
!<REVIEWER EMAIL="John.Dunne@noaa.gov"> John P. Dunne
!</REVIEWER>
!
!<OVERVIEW>
! Ocean Carbon Model Intercomparison Study II: Gas exchange coupler
!</OVERVIEW>
!
!<DESCRIPTION>
!       Implementation of routines to solve the gas fluxes at the
!       ocean surface for a coupled model
!       as outlined in the Biotic-HOWTO documentation,
!       revision 1.7, 1999/10/05.
!</DESCRIPTION>
!
! <REFERENCE>
! http://www.ipsl.jussieu.fr/OCMIP/phase2/simulations/Biotic/HOWTO-Biotic.html
! </REFERENCE>
!

!
!------------------------------------------------------------------
!
!       Module atmos_ocean_fluxes_mod
!
!       This module will take fields from an atmospheric and an
!       oceanic model and calculate ocean surface fluxes for
!       CO2, O2, CFC-11 or CFC-12 as outlined in the various
!       HOWTO documents at the OCMIP2 website. Multiple instances
!       of a given tracer may be given, resulting in multiple
!       surface fluxes. Additionally, data may be overridden at
!       the individual fields, or fluxes. This could be used in
!       the absence of an atmospheric or oceanic model.
!
!------------------------------------------------------------------
!

module  atmos_ocean_fluxes_mod  !{

!
!------------------------------------------------------------------
!
!       Global definitions
!
!------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Modules
!
!----------------------------------------------------------------------
!

use mpp_mod,           only: stdout, stdlog, mpp_error, FATAL, mpp_sum, mpp_npes

use coupler_types_mod, only: coupler_1d_bc_type
use coupler_types_mod, only: ind_alpha, ind_csurf, ind_sc_no
use coupler_types_mod, only: ind_pcair, ind_u10, ind_psurf
use coupler_types_mod, only: ind_deposition
use coupler_types_mod, only: ind_runoff
use coupler_types_mod, only: ind_flux, ind_deltap, ind_kw

use field_manager_mod, only: fm_path_name_len, fm_string_len, fm_exists, fm_get_index
use field_manager_mod, only: fm_new_list, fm_get_current_list, fm_change_list
use field_manager_mod, only: fm_field_name_len, fm_type_name_len, fm_dump_list
use field_manager_mod, only: fm_loop_over_list

use fm_util_mod,       only: fm_util_default_caller
use fm_util_mod,       only: fm_util_get_length
use fm_util_mod,       only: fm_util_set_value, fm_util_set_good_name_list, fm_util_set_no_overwrite
use fm_util_mod,       only: fm_util_set_caller, fm_util_reset_good_name_list, fm_util_reset_no_overwrite
use fm_util_mod,       only: fm_util_reset_caller, fm_util_get_string_array, fm_util_check_for_bad_fields
use fm_util_mod,       only: fm_util_get_string, fm_util_get_real_array, fm_util_get_real, fm_util_get_integer
use fm_util_mod,       only: fm_util_get_logical, fm_util_get_logical_array

!
!----------------------------------------------------------------------
!
!       force all variables to be "typed"
!
!----------------------------------------------------------------------
!

implicit none

!
!----------------------------------------------------------------------
!
!       Make all routines and variables private by default
!
!----------------------------------------------------------------------
!

private

!
!----------------------------------------------------------------------
!
!       Public routines
!
!----------------------------------------------------------------------
!

public  :: atmos_ocean_fluxes_calc
public  :: atmos_ocean_fluxes_init
public  :: aof_set_coupler_flux

!
!----------------------------------------------------------------------
!
!       Public parameters
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Public types
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Public variables
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Private routines
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Private parameters
!
!----------------------------------------------------------------------
!

character(len=48), parameter    :: mod_name = 'atmos_ocean_fluxes_mod'

!
!----------------------------------------------------------------------
!
!       Private types
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Private variables
!
!----------------------------------------------------------------------
!

character(len=128) :: version = '$Id: atmos_ocean_fluxes.F90,v 18.0 2010/03/02 23:55:03 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!
!-----------------------------------------------------------------------
!
!       Subroutine and function definitions
!
!-----------------------------------------------------------------------
!

contains


!#######################################################################
! <FUNCTION NAME="aof_set_coupler_flux">
!
! <DESCRIPTION>
! Set the values for a coupler flux and return its index (0 on error)
! </DESCRIPTION>
!
function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, param, flag,       &
     mol_wt, ice_restart_file, ocean_restart_file, units, caller)           &
         result (coupler_index)  !{

implicit none

!
!       Return type
!

integer :: coupler_index

!
!       arguments
!

character(len=*), intent(in)                            :: name
character(len=*), intent(in)                            :: flux_type
character(len=*), intent(in)                            :: implementation
integer, intent(in), optional                           :: atm_tr_index
real, intent(in), dimension(:), optional                :: param
logical, intent(in), dimension(:), optional             :: flag
real, intent(in), optional                              :: mol_wt
character(len=*), intent(in), optional                  :: ice_restart_file
character(len=*), intent(in), optional                  :: ocean_restart_file
character(len=*), intent(in), optional                  :: units
character(len=*), intent(in), optional                  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'aof_set_coupler_flux'

!
!       Local variables
!

integer                                                 :: n
integer                                                 :: length
integer                                                 :: num_parameters
integer                                                 :: outunit
character(len=fm_path_name_len)                         :: coupler_list
character(len=fm_path_name_len)                         :: current_list
character(len=fm_string_len)                            :: flux_type_test
character(len=fm_string_len)                            :: implementation_test
character(len=256)                                      :: error_header
character(len=256)                                      :: warn_header
character(len=256)                                      :: note_header
character(len=128)                                      :: flux_list
character(len=128)                                      :: caller_str
character(len=fm_string_len), pointer, dimension(:)     :: good_list => NULL()
character(len=256)                                      :: long_err_msg

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}
outunit = stdout()
write (outunit,*)
write (outunit,*) trim(note_header), ' Processing coupler fluxes ', trim(name)

!
!       define the coupler list name
!

coupler_list = '/coupler_mod/fluxes/' // trim(name)

!
!       Check whether a flux has already been set for this name, and if so, return
!       the index for it (this is because the fluxes may be defined in both the atmosphere
!       and ocean models) (check whether the good_list list exists, since this will
!       indicate that this routine has already been called, and not just that
!       the field table input has this list defined)
!

if (fm_exists('/coupler_mod/GOOD/fluxes/' // trim(name) // '/good_list')) then  !{
  write (outunit,*)
  write (outunit,*) trim(note_header), ' Using previously defined coupler flux'
  coupler_index = fm_get_index(coupler_list)
  if (coupler_index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Could not get coupler flux ')
  endif  !}

!
!       allow atm_tr_index to be set here, since it will only be set from atmospheric
!       PEs, and the atmospheric routines call this routine last, thus overwriting the
!       current value is safe (furthermore, this is not a value which could have any meaningful
!       value set from the run script.
!

  if (present(atm_tr_index)) then  !{
    write (outunit,*) trim(note_header), ' Redefining atm_tr_index to ', atm_tr_index
    call fm_util_set_value(trim(coupler_list) // '/atm_tr_index', atm_tr_index, no_create = .true.,        &
         no_overwrite = .false., caller = caller_str)
  endif  !}
  return
endif  !}

!
!       Set a new coupler flux and get its index
!

coupler_index = fm_new_list(coupler_list)
if (coupler_index .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set coupler flux ')
endif  !}

!
!       Change to the new list, first saving the current list
!

current_list = fm_get_current_list()
if (current_list .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not get the current list')
endif  !}

if (.not. fm_change_list(coupler_list)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not change to the new list')
endif  !}

!
!       Set the array in which to save the valid names for this list,
!       used later for a consistency check. This is used in the fm_util_set_value
!       routines to make the list of valid values
!

call fm_util_set_good_name_list('/coupler_mod/GOOD/fluxes/' // trim(name) // '/good_list')

!
!       Set other defaults for the fm_util_set_value routines
!

call fm_util_set_no_overwrite(.true.)
call fm_util_set_caller(caller_str)

!
!       Set various values to given values, or to defaults if not given
!

if (flux_type .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Blank flux_type given')
else  !}{
  if (fm_exists('/coupler_mod/types/' // trim(flux_type))) then  !{
    call fm_util_set_value('flux_type', flux_type)
!
!       check that the flux_type that we will use (possibly given from the field_table)
!       is defined
!
    flux_type_test = fm_util_get_string('flux_type', scalar = .true.)
    if (.not. fm_exists('/coupler_mod/types/' // trim(flux_type_test))) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Undefined flux_type given from field_table: ' // trim(flux_type_test))
    endif  !}
  else  !}{
    call mpp_error(FATAL, trim(error_header) // ' Undefined flux_type given as argument to the subroutine: ' // trim(flux_type))
  endif  !}
endif  !}

if (implementation .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Blank flux_type given')
else  !}{
  if (fm_exists('/coupler_mod/types/' // trim(flux_type) // '/implementation/' // trim(implementation))) then  !{
    call fm_util_set_value('implementation', implementation)
!
!       check that the flux_type/implementation that we will use
!       (both possibly given from the field_table) is defined
!
    implementation_test = fm_util_get_string('implementation', scalar = .true.)
    if (.not. fm_exists('/coupler_mod/types/' // trim(flux_type_test) //  '/implementation/' // trim(implementation_test))) then  !{
      if (flux_type .eq. flux_type_test) then
        if (implementation .eq. implementation_test) then
          call mpp_error(FATAL, trim(error_header) // ' Should not get here, as it is tested for above')
        else
          call mpp_error(FATAL, trim(error_header) //                                                   &
               ' Undefined flux_type/implementation (implementation given from field_table): ' //       &
               trim(flux_type_test) // '/implementation/' // trim(implementation_test))
        endif
      else
        if (implementation .eq. implementation_test) then
	  long_err_msg = 'Undefined flux_type/implementation (flux_type given from field_table): '
	  long_err_msg = long_err_msg // trim(flux_type_test) // '/implementation/' // trim(implementation_test)
          call mpp_error(FATAL, trim(error_header) // long_err_msg)
        else
	  long_err_msg = ' Undefined flux_type/implementation (both given from field_table): '
	  long_err_msg = long_err_msg //  trim(flux_type_test) // '/implementation/' // trim(implementation_test)
          call mpp_error(FATAL, trim(error_header) // long_err_msg)
        endif
      endif
    endif  !}
  else  !}{
    call mpp_error(FATAL, trim(error_header) // ' Undefined flux_type/implementation given as argument to the subroutine: ' //  &
         trim(flux_type) // '/implementation/' // trim(implementation))
  endif  !}
endif  !}

if (present(atm_tr_index)) then  !{
  call fm_util_set_value('atm_tr_index', atm_tr_index)
else  !}{
  call fm_util_set_value('atm_tr_index', 0)
endif  !}

if (present(mol_wt)) then  !{
  call fm_util_set_value('mol_wt', mol_wt)
else  !}{
  call fm_util_set_value('mol_wt', 0.0)
endif  !}

if (present(ice_restart_file)) then  !{
  call fm_util_set_value('ice_restart_file', ice_restart_file)
else  !}{
  call fm_util_set_value('ice_restart_file', 'ice_coupler_fluxes.res.nc')
endif  !}

if (present(ocean_restart_file)) then  !{
  call fm_util_set_value('ocean_restart_file', ocean_restart_file)
else  !}{
  call fm_util_set_value('ocean_restart_file', 'ocean_coupler_fluxes.res.nc')
endif  !}

if (present(param)) then  !{
  num_parameters = fm_util_get_integer('/coupler_mod/types/' //                                 &
       trim(fm_util_get_string('flux_type', scalar = .true.)) // '/implementation/' //          &
       trim(fm_util_get_string('implementation', scalar = .true.)) // '/num_parameters', scalar = .true.)
  length = min(size(param(:)),num_parameters)
  if (length .ne. num_parameters) then  !{
    write (outunit,*) trim(note_header), ' Number of parameters provided for ', trim(name), ' does not match the'
    write (outunit,*) 'number of parameters required (', size(param(:)), ' != ', num_parameters, ').'
    write (outunit,*) 'This could be an error, or more likely is just a result of the implementation being'
    write (outunit,*) 'overridden by the field table input'
  endif  !}
  if (length .gt. 0) then  !{
    call fm_util_set_value('param', param(1:length), length)
  else  !}{
    call fm_util_set_value('param', 'null', index = 0)
  endif  !}
else  !}{
  call fm_util_set_value('param', 'null', index = 0)
endif  !}

if (present(flag)) then  !{
  call fm_util_set_value('flag', flag, size(flag(:)))
else  !}{
  call fm_util_set_value('flag', .false., index = 0)
endif  !}

flux_list = '/coupler_mod/types/' // trim(flux_type) // '/'

if (present(units)) then  !{
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = ind_flux)) // '-units', units)
else  !}{
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = ind_flux)) // '-units',      &
                         fm_util_get_string(trim(flux_list) // 'flux/units', index = ind_flux))
endif  !}

do n = 1, fm_util_get_length(trim(flux_list) // 'flux/name')  !{
  if (n .ne. ind_flux) then  !{
    call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = n)) // '-units',   &
                           fm_util_get_string(trim(flux_list) // 'flux/units', index = n))
  endif  !}
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = n)) // '-long_name', &
                         fm_util_get_string(trim(flux_list) // 'flux/long_name', index = n))
enddo  !} n

do n = 1, fm_util_get_length(trim(flux_list) // 'atm/name')  !{
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = n)) // '-units',      &
                         fm_util_get_string(trim(flux_list) // 'atm/units', index = n))
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = n)) // '-long_name',  &
                         fm_util_get_string(trim(flux_list) // 'atm/long_name', index = n))
enddo  !} n

do n = 1, fm_util_get_length(trim(flux_list) // 'ice/name')  !{
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = n)) // '-units',      &
                         fm_util_get_string(trim(flux_list) // 'ice/units', index = n))
  call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = n)) // '-long_name',  &
                         fm_util_get_string(trim(flux_list) // 'ice/long_name', index = n))
enddo  !} n

!
!       Reset the defaults for the fm_util_set_value calls
!

call fm_util_reset_good_name_list
call fm_util_reset_no_overwrite
call fm_util_reset_caller

!
!       Change back to the saved current list
!

if (.not. fm_change_list(current_list)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not change back to ' // trim(current_list))
endif  !}

!
!       Check for any errors in the number of fields in this list
!

if (caller_str .eq. ' ') then  !{
  caller_str = trim(mod_name) // '(' // trim(sub_name) // ')'
endif  !}
good_list => fm_util_get_string_array('/coupler_mod/GOOD/fluxes/' // trim(name) // '/good_list', &
     caller = caller_str)
if (associated(good_list)) then  !{
  call fm_util_check_for_bad_fields(trim(coupler_list), good_list, caller = caller_str)
  deallocate(good_list)
else  !}{
  call mpp_error(FATAL, trim(error_header) // ' Empty "' // trim(name) // '" list')
endif  !}

return

end function aof_set_coupler_flux  !}
! </FUNCTION> NAME="aof_set_coupler_flux"


!#######################################################################
! <SUBROUTINE NAME="atmos_ocean_fluxes_init">
!
! <DESCRIPTION>
!     Initialize gas flux structures
! </DESCRIPTION>
!

subroutine atmos_ocean_fluxes_init(gas_fluxes, gas_fields_atm, gas_fields_ice)  !{

implicit none

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

type(coupler_1d_bc_type), intent(inout) :: gas_fluxes
type(coupler_1d_bc_type), intent(inout) :: gas_fields_atm
type(coupler_1d_bc_type), intent(inout) :: gas_fields_ice

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_ocean_fluxes_init'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

integer                                 :: num_parameters
integer                                 :: num_flags
integer                                 :: n
integer                                 :: m
character(len=128)                      :: caller_str
character(len=fm_type_name_len)         :: typ
character(len=fm_field_name_len)        :: name
integer                                 :: ind
integer                                 :: outunit
integer                                 :: total_fluxes
character(len=8)                        :: string
character(len=128)                      :: error_string
character(len=128)                      :: flux_list
logical, save                           :: initialized = .false.

!
! =====================================================================
!     begin executable code
! =====================================================================
!

!
!       don't execute if already called
!

if (initialized) then  !{

  return

endif  !}

initialized = .true.
outunit = stdout()
!write (outunit,*)
!write (outunit,*) 'Dumping field manager tree'
!if (.not. fm_dump_list('/', recursive = .true.)) then  !{
  !call mpp_error(FATAL, trim(error_header) // ' Problem dumping field manager tree')
!endif  !}

caller_str = trim(mod_name) // '(' // trim(sub_name) // ')'

!
!       Set other defaults for the fm_util_set_value routines
!

call fm_util_set_no_overwrite(.true.)
call fm_util_set_caller(caller_str)

!
!       determine the number of flux fields
!

gas_fluxes%num_bcs = fm_util_get_length('/coupler_mod/fluxes/')
gas_fields_atm%num_bcs = gas_fluxes%num_bcs
gas_fields_ice%num_bcs = gas_fluxes%num_bcs
if (gas_fluxes%num_bcs .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not get number of fluxes')
elseif (gas_fluxes%num_bcs .eq. 0) then  !}{
  write (outunit,*) trim(note_header), ' No gas fluxes'
  return
else  !}{
  write (outunit,*) trim(note_header), ' Processing ', gas_fluxes%num_bcs, ' gas fluxes'
endif  !}

!
!       allocate the arrays
!

allocate (gas_fluxes%bc(gas_fluxes%num_bcs))

allocate (gas_fields_atm%bc(gas_fields_atm%num_bcs))

allocate (gas_fields_ice%bc(gas_fields_ice%num_bcs))

!
!       loop over the input fields, setting the values in the flux_type
!

n = 0
do while (fm_loop_over_list('/coupler_mod/fluxes', name, typ, ind))  !{
   
  if (typ .ne. 'list') then  !{
       
    call mpp_error(FATAL, trim(error_header) // ' ' // trim(name) // ' is not a list')
       
  else  !}{

    n = n + 1  ! increment the array index

    if (n .ne. ind) then  !{
      write (outunit,*) trim(warn_header), ' Flux index, ', ind,       &
           ' does not match array index, ', n, ' for ', trim(name)
    endif  !}

!
!       Change list to the new flux
!

    if (.not. fm_change_list('/coupler_mod/fluxes/' // trim(name))) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem changing to ' // trim(name))
    endif  !}

!
!       save and check the flux_type
!

    gas_fluxes%bc(n)%flux_type = fm_util_get_string('flux_type', scalar = .true.)
    if (.not. fm_exists('/coupler_mod/types/' // trim(gas_fluxes%bc(n)%flux_type))) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Undefined flux_type given for ' //          &
           trim(name) // ': ' // trim(gas_fluxes%bc(n)%flux_type))
    endif  !}
    gas_fields_atm%bc(n)%flux_type = gas_fluxes%bc(n)%flux_type
    gas_fields_ice%bc(n)%flux_type = gas_fluxes%bc(n)%flux_type

!
!       save and check the implementation
!

    gas_fluxes%bc(n)%implementation = fm_util_get_string('implementation', scalar = .true.)
    if (.not. fm_exists('/coupler_mod/types/' // trim(gas_fluxes%bc(n)%flux_type) //            &
         '/implementation/' // trim(gas_fluxes%bc(n)%implementation))) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Undefined implementation given for ' //     &
           trim(name) // ': ' // trim(gas_fluxes%bc(n)%flux_type) // '/implementation/' //      &
           trim(gas_fluxes%bc(n)%implementation))
    endif  !}
    gas_fields_atm%bc(n)%implementation = gas_fluxes%bc(n)%implementation
    gas_fields_ice%bc(n)%implementation = gas_fluxes%bc(n)%implementation

!
!       set the flux list name
!

    flux_list = '/coupler_mod/types/' // trim(gas_fluxes%bc(n)%flux_type) // '/'

!
!       allocate the arrays
!

    gas_fluxes%bc(n)%num_fields = fm_util_get_length(trim(flux_list) // 'flux/name')
    allocate (gas_fluxes%bc(n)%field(gas_fluxes%bc(n)%num_fields))
    gas_fields_atm%bc(n)%num_fields = fm_util_get_length(trim(flux_list) // 'atm/name')
    allocate (gas_fields_atm%bc(n)%field(gas_fields_atm%bc(n)%num_fields))
    gas_fields_ice%bc(n)%num_fields = fm_util_get_length(trim(flux_list) // 'ice/name')
    allocate (gas_fields_ice%bc(n)%field(gas_fields_ice%bc(n)%num_fields))

!
!       save the name and generate unique field names for Flux, Ice and Atm
!

    gas_fluxes%bc(n)%name = name
    do m = 1, fm_util_get_length(trim(flux_list) // 'flux/name')  !{
      gas_fluxes%bc(n)%field(m)%name = trim(name) // "_" // fm_util_get_string(trim(flux_list) // 'flux/name', index = m)
      gas_fluxes%bc(n)%field(m)%override = .false.
      gas_fluxes%bc(n)%field(m)%mean     = .false.
    enddo  !} m

    gas_fields_atm%bc(n)%name = name
    do m = 1, fm_util_get_length(trim(flux_list) // 'atm/name')  !{
      gas_fields_atm%bc(n)%field(m)%name = trim(name) // "_" // fm_util_get_string(trim(flux_list) // 'atm/name', index = m)
      gas_fields_atm%bc(n)%field(m)%override = .false.
      gas_fields_atm%bc(n)%field(m)%mean     = .false.
    enddo  !} m

    gas_fields_ice%bc(n)%name = name
    do m = 1, fm_util_get_length(trim(flux_list) // 'ice/name')  !{
      gas_fields_ice%bc(n)%field(m)%name = trim(name) // "_" // fm_util_get_string(trim(flux_list) // 'ice/name', index = m)
      gas_fields_ice%bc(n)%field(m)%override = .false.
      gas_fields_ice%bc(n)%field(m)%mean     = .false.
    enddo  !} m

!
!       save the units
!

    do m = 1, fm_util_get_length(trim(flux_list) // 'flux/name')  !{
      gas_fluxes%bc(n)%field(m)%units =         &
           fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = m)) // '-units', scalar = .true.)
    enddo  !} m
    do m = 1, fm_util_get_length(trim(flux_list) // 'atm/name')  !{
      gas_fields_atm%bc(n)%field(m)%units =             &
           fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = m)) // '-units')
    enddo  !} m
    do m = 1, fm_util_get_length(trim(flux_list) // 'ice/name')  !{
      gas_fields_ice%bc(n)%field(m)%units =             &
           fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = m)) // '-units')
    enddo  !} m

!
!       save the long names
!

    do m = 1, fm_util_get_length(trim(flux_list) // 'flux/name')  !{
      gas_fluxes%bc(n)%field(m)%long_name =      &
           fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = m)) // '-long_name', scalar = .true.)
      gas_fluxes%bc(n)%field(m)%long_name = trim(gas_fluxes%bc(n)%field(m)%long_name) // ' for ' // name
    enddo  !} m
    do m = 1, fm_util_get_length(trim(flux_list) // 'atm/name')  !{
      gas_fields_atm%bc(n)%field(m)%long_name =      &
           fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = m)) // '-long_name')
      gas_fields_atm%bc(n)%field(m)%long_name = trim(gas_fields_atm%bc(n)%field(m)%long_name) // ' for ' // name
    enddo  !} m
    do m = 1, fm_util_get_length(trim(flux_list) // 'ice/name')  !{
      gas_fields_ice%bc(n)%field(m)%long_name =      &
           fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = m)) // '-long_name')
      gas_fields_ice%bc(n)%field(m)%long_name = trim(gas_fields_ice%bc(n)%field(m)%long_name) // ' for ' // name
    enddo  !} m

!
!       save the atm_tr_index
!

    gas_fluxes%bc(n)%atm_tr_index = fm_util_get_integer('atm_tr_index', scalar = .true.)

!
!       save the molecular weight
!

    gas_fluxes%bc(n)%mol_wt = fm_util_get_real('mol_wt', scalar = .true.)
    gas_fields_atm%bc(n)%mol_wt = gas_fluxes%bc(n)%mol_wt
    gas_fields_ice%bc(n)%mol_wt = gas_fluxes%bc(n)%mol_wt

!
!       save the ice_restart_file
!

    gas_fluxes%bc(n)%ice_restart_file = fm_util_get_string('ice_restart_file', scalar = .true.)
    gas_fields_atm%bc(n)%ice_restart_file = gas_fluxes%bc(n)%ice_restart_file
    gas_fields_ice%bc(n)%ice_restart_file = gas_fluxes%bc(n)%ice_restart_file

!
!       save the ocean_restart_file
!

    gas_fluxes%bc(n)%ocean_restart_file = fm_util_get_string('ocean_restart_file', scalar = .true.)
    gas_fields_atm%bc(n)%ocean_restart_file = gas_fluxes%bc(n)%ocean_restart_file
    gas_fields_ice%bc(n)%ocean_restart_file = gas_fluxes%bc(n)%ocean_restart_file

!
!       save the params
!

    gas_fluxes%bc(n)%param => fm_util_get_real_array('param')

!
!       save the flags
!

    gas_fluxes%bc(n)%flag => fm_util_get_logical_array('flag')

!
!       Perform some integrity checks
!

    num_parameters = fm_util_get_integer(trim(flux_list) // 'implementation/' //        &
         trim(gas_fluxes%bc(n)%implementation) // '/num_parameters', scalar = .true.)
    if (num_parameters .gt. 0) then  !{
      if (.not. associated(gas_fluxes%bc(n)%param)) then  !{
        write (error_string,'(a,i2)') ': need ', num_parameters
        call mpp_error(FATAL, trim(error_header) // ' No param for ' // trim(name) // trim(error_string))
      elseif (size(gas_fluxes%bc(n)%param(:)) .ne. num_parameters) then  !}{
        write (error_string,'(a,i2,a,i2)') ': ', size(gas_fluxes%bc(n)%param(:)), ' given, need ', num_parameters
        call mpp_error(FATAL, trim(error_header) // ' Wrong number of param for ' // trim(name) // trim(error_string))
      endif  !}
    elseif (num_parameters .eq. 0) then  !}{
      if (associated(gas_fluxes%bc(n)%param)) then  !{
        write (error_string,'(a,i3)') ' but has size of ', size(gas_fluxes%bc(n)%param(:))
        call mpp_error(FATAL, trim(error_header) // ' No params needed for ' // trim(name) // trim(error_string))
      endif  !}
    else  !}{
      write (error_string,'(a,i2)') ': ', num_parameters
      call mpp_error(FATAL, trim(error_header) // 'Num_parameters is negative for ' // trim(name) // trim(error_string))
    endif  !}
    num_flags = fm_util_get_integer(trim(flux_list) // '/num_flags', scalar = .true.)
    if (num_flags .gt. 0) then  !{
      if (.not. associated(gas_fluxes%bc(n)%flag)) then  !{
        write (error_string,'(a,i2)') ': need ', num_flags
        call mpp_error(FATAL, trim(error_header) // ' No flag for ' // trim(name) // trim(error_string))
      elseif (size(gas_fluxes%bc(n)%flag(:)) .ne. num_flags) then  !}{
        write (error_string,'(a,i2,a,i2)') ': ', size(gas_fluxes%bc(n)%flag(:)), ' given, need ', num_flags
        call mpp_error(FATAL, trim(error_header) // ' Wrong number of flag for ' // trim(name) // trim(error_string))
      endif  !}
    elseif (num_flags .eq. 0) then  !}{
      if (associated(gas_fluxes%bc(n)%flag)) then  !{
        write (error_string,'(a,i3)') ' but has size of ', size(gas_fluxes%bc(n)%flag(:))
        call mpp_error(FATAL, trim(error_header) // ' No flags needed for ' // trim(name) // trim(error_string))
      endif  !}
    else  !}{
      write (error_string,'(a,i2)') ': ', num_flags
      call mpp_error(FATAL, trim(error_header) // 'Num_flags is negative for ' // trim(name) // trim(error_string))
    endif  !}

!
!       set some flags for this flux_type
!

    gas_fluxes%bc(n)%use_atm_pressure = fm_util_get_logical(trim(flux_list) // '/use_atm_pressure')
    gas_fields_atm%bc(n)%use_atm_pressure = gas_fluxes%bc(n)%use_atm_pressure
    gas_fields_ice%bc(n)%use_atm_pressure = gas_fluxes%bc(n)%use_atm_pressure

    gas_fluxes%bc(n)%use_10m_wind_speed = fm_util_get_logical(trim(flux_list) // '/use_10m_wind_speed')
    gas_fields_atm%bc(n)%use_10m_wind_speed = gas_fluxes%bc(n)%use_10m_wind_speed
    gas_fields_ice%bc(n)%use_10m_wind_speed = gas_fluxes%bc(n)%use_10m_wind_speed

    gas_fluxes%bc(n)%pass_through_ice = fm_util_get_logical(trim(flux_list) // '/pass_through_ice')
    gas_fields_atm%bc(n)%pass_through_ice = gas_fluxes%bc(n)%pass_through_ice
    gas_fields_ice%bc(n)%pass_through_ice = gas_fluxes%bc(n)%pass_through_ice

  endif  !}

enddo  !}

write (outunit,*)
write (outunit,*) 'Dumping fluxes tracer tree'
if (.not. fm_dump_list('/coupler_mod/fluxes', recursive = .true.)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Problem dumping fluxes tracer tree')
endif  !}

!
!       Check that the number of fluxes is the same on all processors
!       If they are, then the sum of the number of fluxes across all processors
!       should equal to the number of fluxes on each processor times the number of processors
!

total_fluxes = gas_fluxes%num_bcs
call mpp_sum(total_fluxes)
if (total_fluxes .ne. mpp_npes() * gas_fluxes%num_bcs) then  !{
  write (string, '(i4)') gas_fluxes%num_bcs
  call mpp_error(FATAL, trim(error_header) //           &
       ' Number of fluxes does not match across the processors: ' // trim(string) // ' fluxes')
endif  !}

!
!       Reset the defaults for the fm_util_set_value calls
!

call fm_util_reset_no_overwrite
call fm_util_reset_caller

return
end subroutine  atmos_ocean_fluxes_init  !}
! </SUBROUTINE> NAME="atmos_ocean_fluxes_init"


!#######################################################################
! <SUBROUTINE NAME="atmos_ocean_fluxes_calc">
!
! <DESCRIPTION>
!     Calculate the ocean gas fluxes. Units should be mol/m^2/s, upward flux is positive.
! </DESCRIPTION>
!

subroutine atmos_ocean_fluxes_calc(gas_fields_atm, gas_fields_ice,      &
     gas_fluxes, seawater)  !{

!
!-----------------------------------------------------------------------
!     modules (have to come first)
!-----------------------------------------------------------------------
!

implicit none

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

type(coupler_1d_bc_type), intent(in)            :: gas_fields_atm
type(coupler_1d_bc_type), intent(in)            :: gas_fields_ice
type(coupler_1d_bc_type), intent(inout)         :: gas_fluxes
real, intent(in), dimension(:)                  :: seawater

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'atmos_ocean_fluxes_calc'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

integer                                 :: n
integer                                 :: i
integer                                 :: length
real, dimension(:), allocatable         :: kw
real, dimension(:), allocatable         :: cair
character(len=128)                      :: error_string

real, parameter :: epsln=1.0e-30
real, parameter :: permeg=1.0e-6

!
!       Return if no fluxes to be calculated
!

if (gas_fluxes%num_bcs .le. 0) then
  return
endif

!
!       check some things
!

if (.not. associated(gas_fluxes%bc)) then  !{
  if (gas_fluxes%num_bcs .ne. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Number of gas fluxes not zero')
  else  !}{
    return
  endif  !}
endif  !}

!
! =====================================================================
!     begin executable code
! =====================================================================
!

do n = 1, gas_fluxes%num_bcs  !{

!
!       only do calculations if the flux has not been overridden
!

  if ( .not. gas_fluxes%bc(n)%field(ind_flux)%override) then  !{

    if (gas_fluxes%bc(n)%flux_type .eq. 'air_sea_gas_flux_generic') then  !{

      length = size(gas_fluxes%bc(n)%field(1)%values(:))

      if (.not. allocated(kw)) then
        allocate( kw(length) )
        allocate ( cair(length) )
      elseif (size(kw(:)) .ne. length) then
        call mpp_error(FATAL, trim(error_header) // ' Lengths of flux fields do not match')
      endif

      if (gas_fluxes%bc(n)%implementation .eq. 'ocmip2') then  !}{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            gas_fluxes%bc(n)%field(ind_kw)%values(i) = gas_fluxes%bc(n)%param(1) * gas_fields_atm%bc(n)%field(ind_u10)%values(i)**2
            cair(i) =                                                           &
                 gas_fields_ice%bc(n)%field(ind_alpha)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_pCair)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_psurf)%values(i) * gas_fluxes%bc(n)%param(2)
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = gas_fluxes%bc(n)%field(ind_kw)%values(i) *                &
                 sqrt(660 / (gas_fields_ice%bc(n)%field(ind_sc_no)%values(i) + epsln)) *                           &
                 (gas_fields_ice%bc(n)%field(ind_csurf)%values(i) - cair(i))
            gas_fluxes%bc(n)%field(ind_deltap)%values(i) = (gas_fields_ice%bc(n)%field(ind_csurf)%values(i) - cair(i)) / &
                 (gas_fields_ice%bc(n)%field(ind_alpha)%values(i) * permeg + epsln)
          else  !}{
            gas_fluxes%bc(n)%field(ind_kw)%values(i) = 0.0
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
            gas_fluxes%bc(n)%field(ind_deltap)%values(i) = 0.0
            cair(i) = 0.0
          endif  !}
        enddo  !} i

      else  !}{

        call mpp_error(FATAL, ' Unknown implementation (' // trim(gas_fluxes%bc(n)%implementation) //    &
             ') for ' // trim(gas_fluxes%bc(n)%name))

      endif  !}

    elseif (gas_fluxes%bc(n)%flux_type .eq. 'air_sea_gas_flux') then  !{

      length = size(gas_fluxes%bc(n)%field(1)%values(:))

      if (.not. allocated(kw)) then
        allocate( kw(length) )
        allocate ( cair(length) )
      elseif (size(kw(:)) .ne. length) then
        call mpp_error(FATAL, trim(error_header) // ' Lengths of flux fields do not match')
      endif

      if (gas_fluxes%bc(n)%implementation .eq. 'ocmip2_data') then  !{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            kw(i) = gas_fluxes%bc(n)%param(1) * gas_fields_atm%bc(n)%field(ind_u10)%values(i)
            cair(i) =                                                           &
                 gas_fields_ice%bc(n)%field(ind_alpha)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_pCair)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_psurf)%values(i) * gas_fluxes%bc(n)%param(2)
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = kw(i) *                &
                 (gas_fields_ice%bc(n)%field(ind_csurf)%values(i) - cair(i))
          else  !}{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
            cair(i) = 0.0
            kw(i) = 0.0
          endif  !}
        enddo  !} i

      elseif (gas_fluxes%bc(n)%implementation .eq. 'ocmip2') then  !}{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            kw(i) = gas_fluxes%bc(n)%param(1) * gas_fields_atm%bc(n)%field(ind_u10)%values(i)**2
            cair(i) =                                                           &
                 gas_fields_ice%bc(n)%field(ind_alpha)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_pCair)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_psurf)%values(i) * gas_fluxes%bc(n)%param(2)
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = kw(i) *                &
                 (gas_fields_ice%bc(n)%field(ind_csurf)%values(i) - cair(i))
          else  !}{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
            cair(i) = 0.0
            kw(i) = 0.0
          endif  !}
        enddo  !} i

      elseif (gas_fluxes%bc(n)%implementation .eq. 'linear') then  !}{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            kw(i) = gas_fluxes%bc(n)%param(1) * max(0.0, gas_fields_atm%bc(n)%field(ind_u10)%values(i) - gas_fluxes%bc(n)%param(2))
            cair(i) =                                                           &
                 gas_fields_ice%bc(n)%field(ind_alpha)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_pCair)%values(i) *              &
                 gas_fields_atm%bc(n)%field(ind_psurf)%values(i) * gas_fluxes%bc(n)%param(3)
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = kw(i) *                &
                 (gas_fields_ice%bc(n)%field(ind_csurf)%values(i) - cair(i))
          else  !}{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
            cair(i) = 0.0
            kw(i) = 0.0
          endif  !}
        enddo  !} i
    
      else  !}{

        call mpp_error(FATAL, ' Unknown implementation (' // trim(gas_fluxes%bc(n)%implementation) //    &
             ') for ' // trim(gas_fluxes%bc(n)%name))

      endif  !}
    elseif (gas_fluxes%bc(n)%flux_type .eq. 'air_sea_deposition') then  !}{

      if (gas_fluxes%bc(n)%param(1) .le. 0.0) then
        write (error_string, '(1pe10.3)') gas_fluxes%bc(n)%param(1)
        call mpp_error(FATAL, ' Bad parameter (' // trim(error_string) //       &
             ') for air_sea_deposition for ' // trim(gas_fluxes%bc(n)%name))
      endif

      length = size(gas_fluxes%bc(n)%field(1)%values(:))

      if (gas_fluxes%bc(n)%implementation .eq. 'dry') then  !{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) =        &
                 gas_fields_atm%bc(n)%field(ind_deposition)%values(i) / gas_fluxes%bc(n)%param(1)
          else  !}{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
          endif  !}
        enddo  !} i

      elseif (gas_fluxes%bc(n)%implementation .eq. 'wet') then  !}{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) =        &
                 gas_fields_atm%bc(n)%field(ind_deposition)%values(i) / gas_fluxes%bc(n)%param(1)
          else  !}{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
          endif  !}
        enddo  !} i
    
      else  !}{

        call mpp_error(FATAL, ' Unknown implementation (' // trim(gas_fluxes%bc(n)%implementation) //    &
             ') for ' // trim(gas_fluxes%bc(n)%name))

      endif  !}

    elseif (gas_fluxes%bc(n)%flux_type .eq. 'land_sea_runoff') then  !}{

      if (gas_fluxes%bc(n)%param(1) .le. 0.0) then
        write (error_string, '(1pe10.3)') gas_fluxes%bc(n)%param(1)
        call mpp_error(FATAL, ' Bad parameter (' // trim(error_string) //       &
             ') for land_sea_runoff for ' // trim(gas_fluxes%bc(n)%name))
      endif

      length = size(gas_fluxes%bc(n)%field(1)%values(:))

      if (gas_fluxes%bc(n)%implementation .eq. 'river') then  !{

        do i = 1, length  !{
          if (seawater(i) == 1) then  !{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) =        &
                 gas_fields_atm%bc(n)%field(ind_deposition)%values(i) / gas_fluxes%bc(n)%param(1)
          else  !}{
            gas_fluxes%bc(n)%field(ind_flux)%values(i) = 0.0
          endif  !}
        enddo  !} i

      else  !}{

        call mpp_error(FATAL, ' Unknown implementation (' // trim(gas_fluxes%bc(n)%implementation) //    &
             ') for ' // trim(gas_fluxes%bc(n)%name))

      endif  !}

    else  !}{

      call mpp_error(FATAL, ' Unknown flux_type (' // trim(gas_fluxes%bc(n)%flux_type) //    &
           ') for ' // trim(gas_fluxes%bc(n)%name))

    endif  !}
      
  endif  !}

enddo  !} n

if (allocated(kw)) then
  deallocate(kw)
  deallocate(cair)
endif

return
end subroutine  atmos_ocean_fluxes_calc  !}
! </SUBROUTINE> NAME="atmos_ocean_fluxes_calc"

end module  atmos_ocean_fluxes_mod  !}


module coupler_types_mod  !{
!-----------------------------------------------------------------------
!                   GNU General Public License                        
! This file is a part of MOM.                                                                 
!                                                                      
! MOM is free software; you can redistribute it and/or modify it and  
! are expected to follow the terms of the GNU General Public License  
! as published by the Free Software Foundation; either version 2 of   
! the License, or (at your option) any later version.                 
!                                                                      
! MOM 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.                                           
!                                                                      
! For the full text of the GNU General Public License,                
! write to: Free Software Foundation, Inc.,                           
!           675 Mass Ave, Cambridge, MA 02139, USA.                   
! or see:   http://www.gnu.org/licenses/gpl.html                      
!-----------------------------------------------------------------------
!
!<CONTACT EMAIL="Richard.Slater@noaa.gov">
! Richard D. Slater 
!</CONTACT>
!
! <REVIEWER EMAIL="John.Dunne@noaa.gov">
! John Dunne
! </REVIEWER>
!
!<OVERVIEW>
! This module contains type declarations for the coupler.
!</OVERVIEW>
!
!<DESCRIPTION>
! This module contains type declarations for the coupler.
!</DESCRIPTION>
!

!
! /coupler_mod/
!              types/
!                    air_sea_gas_flux_generic/
!                         implementation/
!                                        ocmip2/
!                                                    num_parameters = 2
!                         num_flags = 0
!                         use_atm_pressure = t
!                         use_10m_wind_speed = t
!                         pass_through_ice = f
!                         atm/
!                             name/
!                                  pcair, u10, psurf
!                             long_name/
!                                       'Atmospheric concentration'
!                                       'Wind speed at 10 m'
!                                       'Surface atmospheric pressure'
!                             units/
!                                   'mol/mol', 'm/s', 'Pa'
!                         ice/
!                             name/
!                                  alpha, csurf, sc_no
!                             long_name/
!                                       'Solubility from atmosphere'
!                                       'Surface concentration from ocean'
!                                       'Schmidt number'
!                             units/
!                                   'mol/m^3/atm', 'mol/m^3', 'dimensionless'
!                         flux/
!                              name/
!                                   flux, deltap, kw
!                              long_name/
!                                        'Surface gas flux'
!                                        'ocean-air delta pressure'
!                                        'piston velocity'
!                              units/
!                                    'mol/m^2/s', 'uatm', 'm/s'
!                    air_sea_gas_flux/
!                         implementation/
!                                        ocmip2/
!                                                    num_parameters = 2
!                                        ocmip2_data/
!                                                    num_parameters = 2
!                                        linear/
!                                                    num_parameters = 3
!                         num_flags = 0
!                         use_atm_pressure = t
!                         use_10m_wind_speed = t
!                         pass_through_ice = f
!                         atm/
!                             name/
!                                  pcair, u10, psurf
!                             long_name/
!                                       'Atmospheric concentration'
!                                       'Wind speed at 10 m'
!                                       'Surface atmospheric pressure'
!                             units/
!                                   'mol/mol', 'm/s', 'Pa'
!                         ice/
!                             name/
!                                  alpha, csurf
!                             long_name/
!                                       'Solubility from atmosphere'
!                                       'Surface concentration from ocean'
!                             units/
!                                   'mol/m^3/atm', 'mol/m^3'
!                         flux/
!                              name/
!                                   flux
!                              long_name/
!                                        'Surface gas flux'
!                              units/
!                                    'mol/m^2/s'
!                    air_sea_deposition/
!                         implementation/
!                                        dry/
!                                            num_parameters = 1
!                                        wet/
!                                            num_parameters = 1
!                         num_flags = 0
!                         use_atm_pressure = f
!                         use_10m_wind_speed = f
!                         pass_through_ice = t
!                         atm/
!                             name/
!                                  depostion
!                             long_name/
!                                       'Atmospheric deposition'
!                             units/
!                                   'kg/m^2/s'
!                         ice/
!                             name/
!                             long_name/
!                             units/
!                         flux/
!                              name/
!                                   flux
!                              long_name/
!                                        'Surface deposition'
!                              units/
!                                    'mol/m^2/s'
!                    land_sea_runoff/
!                         implementation/
!                                        river/
!                                              num_parameters = 1
!                         num_flags = 0
!                         use_atm_pressure = f
!                         use_10m_wind_speed = f
!                         pass_through_ice = t
!                         atm/                  ! really land (perhaps should change this?)
!                             name/
!                                  runoff
!                             long_name/
!                                       'Concentration in land runoff'
!                             units/
!                                   'kg/m^3'
!                         ice/
!                             name/
!                             long_name/
!                             units/
!                         flux/
!                              name/
!                                   flux
!                              long_name/
!                                        'Concentration in land runoff'
!                              units/
!                                    'mol/m^3'
!

use field_manager_mod, only: fm_field_name_len, fm_string_len, fm_dump_list

implicit none
!
!-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: coupler_types.F90,v 18.0 2010/03/02 23:55:06 fms Exp $'
  character(len=128) :: tag = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------
real, parameter :: bound_tol = 1e-7

private

!
!----------------------------------------------------------------------
!
!       Public routines
!
!----------------------------------------------------------------------
!

public  coupler_types_init
public  coupler_type_copy
public  coupler_type_copy_1d_2d
public  coupler_type_copy_1d_3d

!
!----------------------------------------------------------------------
!
!       Private routines
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Public parameters
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Private parameters
!
!----------------------------------------------------------------------
!

character(len=48), parameter                    :: mod_name = 'coupler_types_mod'

!
!----------------------------------------------------------------------
!
!       Public types
!
!----------------------------------------------------------------------
!

!
!       3-d fields
!

type, public    :: coupler_3d_values_type
  character(len=fm_field_name_len)                      :: name = ' '
  real, pointer, dimension(:,:,:)                       :: values => NULL()
  logical                                               :: mean = .true.
  logical                                               :: override = .false.
  integer                                               :: id_diag = 0
  character(len=fm_string_len)                          :: long_name = ' '
  character(len=fm_string_len)                          :: units = ' '
end type coupler_3d_values_type

type, public    :: coupler_3d_field_type  !{
  character(len=fm_field_name_len)                      :: name = ' '
  integer                                               :: num_fields = 0
  type(coupler_3d_values_type), pointer, dimension(:)   :: field => NULL()
  character(len=fm_string_len)                          :: flux_type = ' '
  character(len=fm_string_len)                          :: implementation = ' '
  real, pointer, dimension(:)                           :: param => NULL()
  logical, pointer, dimension(:)                        :: flag => NULL()
  integer                                               :: atm_tr_index = 0
  character(len=fm_string_len)                          :: ice_restart_file = ' '
  character(len=fm_string_len)                          :: ocean_restart_file = ' '
  logical                                               :: use_atm_pressure
  logical                                               :: use_10m_wind_speed
  logical                                               :: pass_through_ice
  real							:: mol_wt = 0.0
end type coupler_3d_field_type

type, public    :: coupler_3d_bc_type  !{
  integer                                               :: num_bcs = 0
  type(coupler_3d_field_type), pointer, dimension(:)    :: bc => NULL()
end type coupler_3d_bc_type

!
!       2-d fields
!

type, public    :: coupler_2d_values_type
  character(len=fm_field_name_len)                      :: name = ' '
  real, pointer, dimension(:,:)                         :: values => NULL()
  logical                                               :: mean = .true.
  logical                                               :: override = .false.
  integer                                               :: id_diag = 0
  character(len=fm_string_len)                          :: long_name = ' '
  character(len=fm_string_len)                          :: units = ' '
end type coupler_2d_values_type

type, public    :: coupler_2d_field_type  !{
  character(len=fm_field_name_len)                      :: name = ' '
  integer                                               :: num_fields = 0
  type(coupler_2d_values_type), pointer, dimension(:)   :: field => NULL()
  character(len=fm_string_len)                          :: flux_type = ' '
  character(len=fm_string_len)                          :: implementation = ' '
  real, pointer, dimension(:)                           :: param => NULL()
  logical, pointer, dimension(:)                        :: flag => NULL()
  integer                                               :: atm_tr_index = 0
  character(len=fm_string_len)                          :: ice_restart_file = ' '
  character(len=fm_string_len)                          :: ocean_restart_file = ' '
  logical                                               :: use_atm_pressure
  logical                                               :: use_10m_wind_speed
  logical                                               :: pass_through_ice
  real							:: mol_wt = 0.0
end type coupler_2d_field_type

type, public    :: coupler_2d_bc_type  !{
  integer                                               :: num_bcs = 0
  type(coupler_2d_field_type), pointer, dimension(:)    :: bc => NULL()
end type coupler_2d_bc_type

!
!       1-d fields
!

type, public    :: coupler_1d_values_type
  character(len=fm_field_name_len)                      :: name = ' '
  real, pointer, dimension(:)                           :: values => NULL()
  logical                                               :: mean = .true.
  logical                                               :: override = .false.
  integer                                               :: id_diag = 0
  character(len=fm_string_len)                          :: long_name = ' '
  character(len=fm_string_len)                          :: units = ' '
end type coupler_1d_values_type

type, public    :: coupler_1d_field_type  !{
  character(len=fm_field_name_len)                      :: name = ' '
  integer                                               :: num_fields = 0
  type(coupler_1d_values_type), pointer, dimension(:)   :: field => NULL()
  character(len=fm_string_len)                          :: flux_type = ' '
  character(len=fm_string_len)                          :: implementation = ' '
  real, pointer, dimension(:)                           :: param => NULL()
  logical, pointer, dimension(:)                        :: flag => NULL()
  integer                                               :: atm_tr_index = 0
  character(len=fm_string_len)                          :: ice_restart_file = ' '
  character(len=fm_string_len)                          :: ocean_restart_file = ' '
  logical                                               :: use_atm_pressure
  logical                                               :: use_10m_wind_speed
  logical                                               :: pass_through_ice
  real							:: mol_wt = 0.0
end type coupler_1d_field_type

type, public    :: coupler_1d_bc_type  !{
  integer                                               :: num_bcs = 0
  type(coupler_1d_field_type), pointer, dimension(:)    :: bc => NULL()
end type coupler_1d_bc_type

!
!----------------------------------------------------------------------
!
!       Private types
!
!----------------------------------------------------------------------
!

!
!----------------------------------------------------------------------
!
!       Public variables
!
!----------------------------------------------------------------------
!

integer, public :: ind_u10
integer, public :: ind_psurf
integer, public :: ind_pcair
integer, public :: ind_csurf
integer, public :: ind_alpha
integer, public :: ind_sc_no
integer, public :: ind_flux
integer, public :: ind_deltap
integer, public :: ind_kw
integer, public :: ind_deposition
integer, public :: ind_runoff

!
!----------------------------------------------------------------------
!
!       Private variables
!
!----------------------------------------------------------------------
!

logical, save   :: module_is_initialized = .false.

!
!----------------------------------------------------------------------
!
!        Interface definitions for overloaded routines
!
!----------------------------------------------------------------------
!

interface  coupler_type_copy  !{
  module procedure  coupler_type_copy_1d_2d
  module procedure  coupler_type_copy_1d_3d
end interface  coupler_type_copy  !}

!
!-----------------------------------------------------------------------
!
!       Subroutine and function definitions
!
!-----------------------------------------------------------------------
!

contains


!#######################################################################
! <SUBROUTINE NAME="coupler_types_init">
!  <OVERVIEW>
!   Initialize the coupler types
!  </OVERVIEW>
!  <DESCRIPTION>
!   Initialize the coupler types
!  </DESCRIPTION>
!  <TEMPLATE>
!   call coupler_tpyes_init
!  </TEMPLATE>
!

subroutine coupler_types_init

!
!-----------------------------------------------------------------------
!     modules
!-----------------------------------------------------------------------
!

use mpp_mod,           only: stdout, mpp_error, FATAL
use fm_util_mod,       only: fm_util_set_value, fm_util_set_no_overwrite
use fm_util_mod,       only: fm_util_set_caller, fm_util_reset_no_overwrite
use fm_util_mod,       only: fm_util_reset_caller
use field_manager_mod, only: fm_new_list, fm_change_list

implicit none

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'coupler_types_init'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

integer                 :: field_index, outunit
character(len=128)      :: error_msg

!
! =====================================================================
!     begin executable code
! =====================================================================
!

!
!       Return if already intialized
!

if (module_is_initialized) then  !{
  return
endif  !}

!
!       Set other defaults for the fm_util_set_value routines
!

call fm_util_set_no_overwrite(.true.)
call fm_util_set_caller(sub_name)

!
!       Be sure that the various lists and fields are defined in the field manager tree
!

if (fm_new_list('/coupler_mod') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "coupler_mod" list')
endif  !}

if (fm_new_list('/coupler_mod/GOOD') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "GOOD" list')
endif  !}
call fm_util_set_value('/coupler_mod/GOOD/good_coupler_mod_list', 'GOOD', append = .true.)

if (fm_new_list('/coupler_mod/fluxes') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "/coupler_mod/fluxes" list')
endif  !}
call fm_util_set_value('/coupler_mod/GOOD/good_coupler_mod_list', 'fluxes', append = .true.)

if (fm_new_list('/coupler_mod/types') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "/coupler_mod/types" list')
endif  !}
call fm_util_set_value('/coupler_mod/GOOD/good_coupler_mod_list', 'types', append = .true.)

!
!       change to the "/coupler_mod/types" list
!

if (.not. fm_change_list('/coupler_mod/types')) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not change to "/coupler_mod/types"')
endif  !}

!
!       Define the air_sea_gas_flux_generic type
!

!       add the new type

if (fm_new_list('air_sea_gas_flux_generic') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic" list')
endif  !}

!       add the implementation list

if (fm_new_list('air_sea_gas_flux_generic/implementation') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/implementation" list')
endif  !}

!       add the names of the different implementations

if (fm_new_list('air_sea_gas_flux_generic/implementation/ocmip2') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/implementation/ocmip2" list')
endif  !}
call fm_util_set_value('air_sea_gas_flux_generic/implementation/ocmip2/num_parameters', 2)

!       add some scalar quantaties

call fm_util_set_value('air_sea_gas_flux_generic/num_flags', 0)
call fm_util_set_value('air_sea_gas_flux_generic/use_atm_pressure', .true.)
call fm_util_set_value('air_sea_gas_flux_generic/use_10m_wind_speed', .true.)
call fm_util_set_value('air_sea_gas_flux_generic/pass_through_ice', .false.)

!       add required fields that will come from the atmosphere model

if (fm_new_list('air_sea_gas_flux_generic/atm') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/atm" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_pcair = field_index
call fm_util_set_value('air_sea_gas_flux_generic/atm/name',      'pcair',                     index = ind_pcair)
call fm_util_set_value('air_sea_gas_flux_generic/atm/long_name', 'Atmospheric concentration', index = ind_pcair)
call fm_util_set_value('air_sea_gas_flux_generic/atm/units',     'mol/mol',                   index = ind_pcair)

field_index = field_index + 1
ind_u10 = field_index
call fm_util_set_value('air_sea_gas_flux_generic/atm/name',      'u10',                index = ind_u10)
call fm_util_set_value('air_sea_gas_flux_generic/atm/long_name', 'Wind speed at 10 m', index = ind_u10)
call fm_util_set_value('air_sea_gas_flux_generic/atm/units',     'm/s',                index = ind_u10)

field_index = field_index + 1
ind_psurf = field_index
call fm_util_set_value('air_sea_gas_flux_generic/atm/name',      'psurf',                        index = ind_psurf)
call fm_util_set_value('air_sea_gas_flux_generic/atm/long_name', 'Surface atmospheric pressure', index = ind_psurf)
call fm_util_set_value('air_sea_gas_flux_generic/atm/units',     'Pa',                           index = ind_psurf)

!       add required fields that will come from the ice model

if (fm_new_list('air_sea_gas_flux_generic/ice') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/ice" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_alpha = field_index
call fm_util_set_value('air_sea_gas_flux_generic/ice/name',      'alpha',                                                index = ind_alpha)
call fm_util_set_value('air_sea_gas_flux_generic/ice/long_name', 'Solubility w.r.t. atmosphere', index = ind_alpha)
call fm_util_set_value('air_sea_gas_flux_generic/ice/units',     'mol/m^3/atm',                                          index = ind_alpha)

field_index = field_index + 1
ind_csurf = field_index
call fm_util_set_value('air_sea_gas_flux_generic/ice/name',      'csurf',                                         index = ind_csurf)
call fm_util_set_value('air_sea_gas_flux_generic/ice/long_name', 'Ocean concentration', index = ind_csurf)
call fm_util_set_value('air_sea_gas_flux_generic/ice/units',     'mol/m^3',                                       index = ind_csurf)

field_index = field_index + 1
ind_sc_no = field_index
call fm_util_set_value('air_sea_gas_flux_generic/ice/name',      'sc_no',                                         index = ind_sc_no)
call fm_util_set_value('air_sea_gas_flux_generic/ice/long_name', 'Schmidt number', index = ind_sc_no)
call fm_util_set_value('air_sea_gas_flux_generic/ice/units',     'dimensionless',                                       index = ind_sc_no)

!       add the flux output field(s)

if (fm_new_list('air_sea_gas_flux_generic/flux') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/flux" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_flux = field_index
call fm_util_set_value('air_sea_gas_flux_generic/flux/name',      'flux',         index = ind_flux)
call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Surface flux', index = ind_flux)
call fm_util_set_value('air_sea_gas_flux_generic/flux/units',     'mol/m^2/s',    index = ind_flux)

field_index = field_index + 1
ind_deltap = field_index
call fm_util_set_value('air_sea_gas_flux_generic/flux/name',      'deltap',         index = ind_deltap)
call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Ocean-air delta pressure', index = ind_deltap)
call fm_util_set_value('air_sea_gas_flux_generic/flux/units',     'uatm',    index = ind_deltap)

field_index = field_index + 1
ind_kw = field_index
call fm_util_set_value('air_sea_gas_flux_generic/flux/name',      'kw',         index = ind_kw)
call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Piston velocity', index = ind_kw)
call fm_util_set_value('air_sea_gas_flux_generic/flux/units',     'm/s',    index = ind_kw)

!
!       Define the air_sea_gas_flux type
!

!       add the new type

if (fm_new_list('air_sea_gas_flux') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux" list')
endif  !}

!       add the implementation list

if (fm_new_list('air_sea_gas_flux/implementation') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation" list')
endif  !}

!       add the names of the different implementations

if (fm_new_list('air_sea_gas_flux/implementation/ocmip2') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation/ocmip2" list')
endif  !}
call fm_util_set_value('air_sea_gas_flux/implementation/ocmip2/num_parameters', 2)
if (fm_new_list('air_sea_gas_flux/implementation/ocmip2_data') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation/ocmip2_data" list')
endif  !}
call fm_util_set_value('air_sea_gas_flux/implementation/ocmip2_data/num_parameters', 2)
if (fm_new_list('air_sea_gas_flux/implementation/linear') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation/linear" list')
endif  !}
call fm_util_set_value('air_sea_gas_flux/implementation/linear/num_parameters', 3)

!       add some scalar quantaties

call fm_util_set_value('air_sea_gas_flux/num_flags', 0)
call fm_util_set_value('air_sea_gas_flux/use_atm_pressure', .true.)
call fm_util_set_value('air_sea_gas_flux/use_10m_wind_speed', .true.)
call fm_util_set_value('air_sea_gas_flux/pass_through_ice', .false.)

!       add required fields that will come from the atmosphere model

if (fm_new_list('air_sea_gas_flux/atm') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/atm" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_pcair = field_index
call fm_util_set_value('air_sea_gas_flux/atm/name',      'pcair',                     index = ind_pcair)
call fm_util_set_value('air_sea_gas_flux/atm/long_name', 'Atmospheric concentration', index = ind_pcair)
call fm_util_set_value('air_sea_gas_flux/atm/units',     'mol/mol',                   index = ind_pcair)

field_index = field_index + 1
ind_u10 = field_index
call fm_util_set_value('air_sea_gas_flux/atm/name',      'u10',                index = ind_u10)
call fm_util_set_value('air_sea_gas_flux/atm/long_name', 'Wind speed at 10 m', index = ind_u10)
call fm_util_set_value('air_sea_gas_flux/atm/units',     'm/s',                index = ind_u10)

field_index = field_index + 1
ind_psurf = field_index
call fm_util_set_value('air_sea_gas_flux/atm/name',      'psurf',                        index = ind_psurf)
call fm_util_set_value('air_sea_gas_flux/atm/long_name', 'Surface atmospheric pressure', index = ind_psurf)
call fm_util_set_value('air_sea_gas_flux/atm/units',     'Pa',                           index = ind_psurf)

!       add required fields that will come from the ice model

if (fm_new_list('air_sea_gas_flux/ice') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/ice" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_alpha = field_index
call fm_util_set_value('air_sea_gas_flux/ice/name',      'alpha',                                                index = ind_alpha)
call fm_util_set_value('air_sea_gas_flux/ice/long_name', 'Solubility from atmosphere times Schmidt number term', index = ind_alpha)
call fm_util_set_value('air_sea_gas_flux/ice/units',     'mol/m^3/atm',                                          index = ind_alpha)

field_index = field_index + 1
ind_csurf = field_index
call fm_util_set_value('air_sea_gas_flux/ice/name',      'csurf',                                         index = ind_csurf)
call fm_util_set_value('air_sea_gas_flux/ice/long_name', 'Ocean concentration times Schmidt number term', index = ind_csurf)
call fm_util_set_value('air_sea_gas_flux/ice/units',     'mol/m^3',                                       index = ind_csurf)

!       add the flux output field(s)

if (fm_new_list('air_sea_gas_flux/flux') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/flux" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_flux = field_index
call fm_util_set_value('air_sea_gas_flux/flux/name',      'flux',         index = ind_flux)
call fm_util_set_value('air_sea_gas_flux/flux/long_name', 'Surface flux', index = ind_flux)
call fm_util_set_value('air_sea_gas_flux/flux/units',     'mol/m^2/s',    index = ind_flux)

!
!       Define the air_sea_deposition type
!

!       add the new type

if (fm_new_list('air_sea_deposition') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition" list')
endif  !}

!       add the implementation list

if (fm_new_list('air_sea_deposition/implementation') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/implementation" list')
endif  !}

!       add the names of the different implementations

if (fm_new_list('air_sea_deposition/implementation/dry') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/implementation/dry" list')
endif  !}
call fm_util_set_value('air_sea_deposition/implementation/dry/num_parameters', 1)
if (fm_new_list('air_sea_deposition/implementation/wet') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/implementation/wet" list')
endif  !}
call fm_util_set_value('air_sea_deposition/implementation/wet/num_parameters', 1)

!       add some scalar quantaties

call fm_util_set_value('air_sea_deposition/num_flags', 0)
call fm_util_set_value('air_sea_deposition/use_atm_pressure', .false.)
call fm_util_set_value('air_sea_deposition/use_10m_wind_speed', .false.)
call fm_util_set_value('air_sea_deposition/pass_through_ice', .true.)

!       add required fields that will come from the atmosphere model

if (fm_new_list('air_sea_deposition/atm') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/atm" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_deposition = field_index
call fm_util_set_value('air_sea_deposition/atm/name',      'deposition',             index = ind_deposition)
call fm_util_set_value('air_sea_deposition/atm/long_name', 'Atmospheric deposition', index = ind_deposition)
call fm_util_set_value('air_sea_deposition/atm/units',     'kg/m^2/s',               index = ind_deposition)

!       add required fields that will come from the ice model

if (fm_new_list('air_sea_deposition/ice') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/ice" list')
endif  !}

field_index = 0

call fm_util_set_value('air_sea_deposition/ice/name',      ' ', index = 0)
call fm_util_set_value('air_sea_deposition/ice/long_name', ' ', index = 0)
call fm_util_set_value('air_sea_deposition/ice/units',     ' ', index = 0)

!       add the flux output field(s)

if (fm_new_list('air_sea_deposition/flux') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/flux" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_flux = field_index
call fm_util_set_value('air_sea_deposition/flux/name',      'flux',               index = ind_flux)
call fm_util_set_value('air_sea_deposition/flux/long_name', 'Surface deposition', index = ind_flux)
call fm_util_set_value('air_sea_deposition/flux/units',     'mol/m^2/s',          index = ind_flux)

!
!       Define the land_sea_runoff type
!

!       add the new type

if (fm_new_list('land_sea_runoff') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff" list')
endif  !}

!       add the implementation list

if (fm_new_list('land_sea_runoff/implementation') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/implementation" list')
endif  !}

!       add the names of the different implementations

if (fm_new_list('land_sea_runoff/implementation/river') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/implementation/river" list')
endif  !}
call fm_util_set_value('land_sea_runoff/implementation/river/num_parameters', 1)

!       add some scalar quantaties

call fm_util_set_value('land_sea_runoff/num_flags', 0)
call fm_util_set_value('land_sea_runoff/use_atm_pressure', .false.)
call fm_util_set_value('land_sea_runoff/use_10m_wind_speed', .false.)
call fm_util_set_value('land_sea_runoff/pass_through_ice', .true.)

!       add required fields that will come from the land model (the array name is still called "atm")

if (fm_new_list('land_sea_runoff/atm') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/atm" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_runoff = field_index
call fm_util_set_value('land_sea_runoff/atm/name',      'runoff',                       index = ind_runoff)
call fm_util_set_value('land_sea_runoff/atm/long_name', 'Concentration in land runoff', index = ind_runoff)
call fm_util_set_value('land_sea_runoff/atm/units',     'mol/m^3',                      index = ind_runoff)

!       add required fields that will come from the ice model

if (fm_new_list('land_sea_runoff/ice') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/ice" list')
endif  !}

field_index = 0

call fm_util_set_value('land_sea_runoff/ice/name',      ' ', index = 0)
call fm_util_set_value('land_sea_runoff/ice/long_name', ' ', index = 0)
call fm_util_set_value('land_sea_runoff/ice/units',     ' ', index = 0)

!       add the flux output field(s)

if (fm_new_list('land_sea_runoff/flux') .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/flux" list')
endif  !}

field_index = 0

field_index = field_index + 1
ind_flux = field_index
call fm_util_set_value('land_sea_runoff/flux/name',      'flux',                         index = ind_flux)
call fm_util_set_value('land_sea_runoff/flux/long_name', 'Concentration in land runoff', index = ind_flux)
call fm_util_set_value('land_sea_runoff/flux/units',     'mol/m^3',                      index = ind_flux)

!
!       change back to root list
!

if (.not. fm_change_list('/')) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not change to "/"')
endif  !}

!
!       Reset the defaults for the fm_util_set_value calls
!

call fm_util_reset_no_overwrite
call fm_util_reset_caller

module_is_initialized = .true.

!
!       Dump the coupler_mod types list
!
outunit = stdout()
write (outunit,*)
write (outunit,*) 'Dumping coupler_mod/types tree'
if (.not. fm_dump_list('/coupler_mod/types', recursive = .true.)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Problem dumping /coupler_mod/types tree')
endif  !}

return

end subroutine  coupler_types_init  !}
! </SUBROUTINE> NAME="coupler_types_init"



!#######################################################################
! <SUBROUTINE NAME="coupler_type_copy_1d_2d">
!  <OVERVIEW>
!   Copy fields from one coupler type to another.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Copy fields from one coupler type to another.
!   Specific version for generic coupler_type_copy.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call coupler_type_copy(var_in, var_out, is, ie, js, je,     &
!        diag_name, axes, time, suffix = 'something')
!		
!  </TEMPLATE>
!  <IN NAME="var_in" TYPE="coupler_1d_bc_type">
!   variable to copy information from
!  </IN>
!  <IN NAME="var_out" TYPE="coupler_2d_bc_type">
!   variable to copy information to
!  </IN>
!  <IN NAME="is" TYPE="integer">
!   lower bound of first dimension
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   upper bound of first dimension
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   lower bound of second dimension
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   upper bound of second dimension
!  </IN>
!  <IN NAME="diag_name" TYPE="character">
!   name for diagnostic file--if blank, then don't register the fields
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!   array of axes identifiers for diagnostic variable registration
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   model time variable for registering diagnostic field
!  </IN>
!  <IN NAME="suffix" TYPE="character">
!   optional suffix to make the name identifier unique
!  </IN>
!

subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je,     &
     diag_name, axes, time, suffix)  !{

!
!-----------------------------------------------------------------------
!     modules
!-----------------------------------------------------------------------
!

use time_manager_mod, only: time_type
use diag_manager_mod, only: register_diag_field
use mpp_mod,          only: mpp_error, FATAL

implicit none

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

type(coupler_1d_bc_type), intent(in)    :: var_in
type(coupler_2d_bc_type), intent(inout) :: var_out
integer, intent(in)                     :: is
integer, intent(in)                     :: ie
integer, intent(in)                     :: js
integer, intent(in)                     :: je
character(len=*), intent(in)            :: diag_name
integer, dimension(:), intent(in)       :: axes
type(time_type), intent(in)             :: time
character(len=*), intent(in), optional  :: suffix
 
!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'coupler_type_copy_1d_2d'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

character(len=128)      :: error_msg
integer                 :: m
integer                 :: n

!
! =====================================================================
!     begin executable code
! =====================================================================
!

!
!       Error if output fields is not zero
!

if (var_out%num_bcs .ne. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Number of output fields is non-zero')
endif  !}
  
var_out%num_bcs = var_in%num_bcs

!
!       Return if no input fields
!

if (var_in%num_bcs .ne. 0) then  !{
  if (associated(var_out%bc)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' var_out%bc already associated')
  endif  !}
  allocate ( var_out%bc(var_out%num_bcs) )
  do n = 1, var_out%num_bcs  !{
    var_out%bc(n)%name = var_in%bc(n)%name
    var_out%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index
    var_out%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file
    var_out%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file
    var_out%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure
    var_out%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed
    var_out%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice
    var_out%bc(n)%mol_wt = var_in%bc(n)%mol_wt
    var_out%bc(n)%num_fields = var_in%bc(n)%num_fields
    if (associated(var_out%bc(n)%field)) then  !{
      write (error_msg, *) trim(error_header), ' var_out%bc(', n, ')%field already associated'
      call mpp_error(FATAL, trim(error_msg))
    endif  !}
    allocate ( var_out%bc(n)%field(var_out%bc(n)%num_fields) )
    do m = 1, var_out%bc(n)%num_fields  !{
      if (present(suffix)) then  !{
        var_out%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix)
      else  !}{
        var_out%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name
      endif  !}
      var_out%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name
      var_out%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units
      var_out%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean
      if (associated(var_out%bc(n)%field(m)%values)) then  !{
        write (error_msg, *) trim(error_header), ' var_out%bc(', n, ')%field(', m, ')%values already associated'
        call mpp_error(FATAL, trim(error_msg))
      endif  !}
      allocate ( var_out%bc(n)%field(m)%values(is:ie,js:je) )
      var_out%bc(n)%field(m)%values = 0.0
      if (diag_name .ne. ' ') then  !{
        if (size(axes) .lt. 2) then  !{
          call mpp_error(FATAL, trim(error_header) // ' axes less than 2 elements')
        endif  !}
        var_out%bc(n)%field(m)%id_diag = register_diag_field(diag_name,                &
             var_out%bc(n)%field(m)%name, axes(1:2), Time,                             &
             var_out%bc(n)%field(m)%long_name, var_out%bc(n)%field(m)%units )
      endif  !}
    enddo  !} m
  enddo  !} n

endif  !}

return

end subroutine  coupler_type_copy_1d_2d  !}
! </SUBROUTINE> NAME="coupler_type_copy_1d_2d


!#######################################################################
! <SUBROUTINE NAME="coupler_type_copy_1d_3d">
!  <OVERVIEW>
!   Copy fields from one coupler type to another.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Copy fields from one coupler type to another.
!   Specific version for generic coupler_type_copy.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, &
!        diag_name, axes, time, suffix = 'something')
!		
!  </TEMPLATE>
!  <IN NAME="var_in" TYPE="coupler_1d_bc_type">
!   variable to copy information from
!  </IN>
!  <IN NAME="var_out" TYPE="coupler_3d_bc_type">
!   variable to copy information to
!  </IN>
!  <IN NAME="is" TYPE="integer">
!   lower bound of first dimension
!  </IN>
!  <IN NAME="ie" TYPE="integer">
!   upper bound of first dimension
!  </IN>
!  <IN NAME="js" TYPE="integer">
!   lower bound of second dimension
!  </IN>
!  <IN NAME="je" TYPE="integer">
!   upper bound of second dimension
!  </IN>
!  <IN NAME="kd" TYPE="integer">
!   third dimension
!  </IN>
!  <IN NAME="diag_name" TYPE="character">
!   name for diagnostic file--if blank, then don't register the fields
!  </IN>
!  <IN NAME="axes" TYPE="integer">
!   array of axes identifiers for diagnostic variable registration
!  </IN>
!  <IN NAME="time" TYPE="time_type">
!   model time variable for registering diagnostic field
!  </IN>
!  <IN NAME="suffix" TYPE="character">
!   optional suffix to make the name identifier unique
!  </IN>
!

subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, &
     diag_name, axes, time, suffix)  !{

!
!-----------------------------------------------------------------------
!     modules
!-----------------------------------------------------------------------
!

use time_manager_mod, only: time_type
use diag_manager_mod, only: register_diag_field
use mpp_mod,          only: mpp_error, FATAL

implicit none

!
!-----------------------------------------------------------------------
!     arguments
!-----------------------------------------------------------------------
!

type(coupler_1d_bc_type), intent(in)    :: var_in
type(coupler_3d_bc_type), intent(inout) :: var_out
integer, intent(in)                     :: is
integer, intent(in)                     :: ie
integer, intent(in)                     :: js
integer, intent(in)                     :: je
integer, intent(in)                     :: kd
character(len=*), intent(in)            :: diag_name
integer, dimension(:), intent(in)       :: axes
type(time_type), intent(in)             :: time
character(len=*), intent(in), optional  :: suffix
 
!
!-----------------------------------------------------------------------
!     local parameters
!-----------------------------------------------------------------------
!

character(len=64), parameter    :: sub_name = 'coupler_type_copy_1d_3d'
character(len=256), parameter   :: error_header =                               &
     '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: warn_header =                                &
     '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):'
character(len=256), parameter   :: note_header =                                &
     '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):'

!
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
!

character(len=128)      :: error_msg
integer                 :: m
integer                 :: n

!
! =====================================================================
!     begin executable code
! =====================================================================
!

!
!       Error if output fields is not zero
!

if (var_out%num_bcs .ne. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Number of output fields is non-zero')
endif  !}
  
var_out%num_bcs = var_in%num_bcs

!
!       Return if no input fields
!

if (var_in%num_bcs .ne. 0) then  !{
  if (associated(var_out%bc)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' var_out%bc already associated')
  endif  !}
  allocate ( var_out%bc(var_out%num_bcs) )
  do n = 1, var_out%num_bcs  !{
    var_out%bc(n)%name = var_in%bc(n)%name
    var_out%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index
    var_out%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file
    var_out%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file
    var_out%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure
    var_out%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed
    var_out%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice
    var_out%bc(n)%mol_wt = var_in%bc(n)%mol_wt
    var_out%bc(n)%num_fields = var_in%bc(n)%num_fields
    if (associated(var_out%bc(n)%field)) then  !{
      write (error_msg, *) trim(error_header), ' var_out%bc(', n, ')%field already associated'
      call mpp_error(FATAL, trim(error_msg))
    endif  !}
    allocate ( var_out%bc(n)%field(var_out%bc(n)%num_fields) )
    do m = 1, var_out%bc(n)%num_fields  !{
      if (present(suffix)) then  !{
        var_out%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // suffix
      else  !}{
        var_out%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name
      endif  !}
      var_out%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name
      var_out%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units
      var_out%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean
      if (associated(var_out%bc(n)%field(m)%values)) then  !{
        write (error_msg, *) trim(error_header), ' var_out%bc(', n, ')%field(', m, ')%values already associated'
        call mpp_error(FATAL, trim(error_msg))
      endif  !}
      allocate ( var_out%bc(n)%field(m)%values(is:ie,js:je,kd) )
      var_out%bc(n)%field(m)%values = 0.0
      if (diag_name .ne. ' ') then  !{
        if (size(axes) .lt. 3) then  !{
          call mpp_error(FATAL, trim(error_header) // ' axes less than 3 elements')
        endif  !}
        var_out%bc(n)%field(m)%id_diag = register_diag_field(diag_name,                &
             var_out%bc(n)%field(m)%name, axes(1:3), Time,                             &
             var_out%bc(n)%field(m)%long_name, var_out%bc(n)%field(m)%units )
      endif  !}
    enddo  !} m
  enddo  !} n

endif  !}

return

end subroutine  coupler_type_copy_1d_3d  !}
! </SUBROUTINE> NAME="coupler_type_copy_1d_3d

end module coupler_types_mod  !}


module ensemble_manager_mod


  use fms_mod, only : open_namelist_file,close_file,check_nml_error
  use mpp_mod, only : mpp_npes, stdout, stdlog, mpp_error, FATAL
  use mpp_mod, only : mpp_pe, mpp_declare_pelist
  use mpp_mod, only : input_nml_file
  use fms_io_mod, only       : set_filename_appendix 
  use diag_manager_mod, only : set_diag_filename_appendix

  IMPLICIT NONE

  private

  integer, parameter :: MAX_ENSEMBLE_SIZE = 100


  integer, allocatable, dimension(:,:) :: ensemble_pelist
  integer, allocatable, dimension(:,:) :: ensemble_pelist_ocean
  integer, allocatable, dimension(:,:) :: ensemble_pelist_atmos
  integer, allocatable, dimension(:)   :: ensemble_pelist_ocean_filter
  integer, allocatable, dimension(:)   :: ensemble_pelist_atmos_filter

  integer :: ensemble_size = 1
  integer :: ensemble_id = 1
  integer :: pe, total_npes_pm=0,ocean_npes_pm=0,atmos_npes_pm=0

  public :: ensemble_manager_init, get_ensemble_id, get_ensemble_size, get_ensemble_pelist
  public :: ensemble_pelist_setup
  public :: get_ensemble_filter_pelist
contains  

  subroutine ensemble_manager_init()


    integer :: i, io_status, ioun, npes

    namelist /ensemble_nml/ ensemble_size

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, ensemble_nml, iostat=io_status)
#else
    ioun = open_namelist_file()
    read(ioun,nml=ensemble_nml,iostat = io_status)
    call close_file(ioun)
#endif

    if(ensemble_size < 1) call mpp_error(FATAL, &
       'ensemble_manager_mod: ensemble_nml variable ensemble_size must be a positive integer')
    if(ensemble_size > max_ensemble_size)  call mpp_error(FATAL, &
       'ensemble_manager_mod: ensemble_nml variable ensemble_size should be no larger than MAX_ENSEMBLE_SIZE, '// &
       'change ensemble_size or increase MAX_ENSEMBLE_SIZE')

    pe = mpp_pe()
    npes = mpp_npes()
    total_npes_pm = npes/ensemble_size
    if (mod(npes, total_npes_pm) /= 0) call mpp_error(FATAL,'ensemble_size must be divis by npes')

    call mpp_declare_pelist((/(i,i=0,npes-1)/),'_ens0') ! for ensemble driver

  end subroutine ensemble_manager_init

  function get_ensemble_id()
    integer :: get_ensemble_id
    get_ensemble_id = ensemble_id
  end function get_ensemble_id

  function get_ensemble_size()

    integer, dimension(4) :: get_ensemble_size

    get_ensemble_size(1) = ensemble_size
    get_ensemble_size(2) = total_npes_pm
    get_ensemble_size(3) = ocean_npes_pm
    get_ensemble_size(4) = atmos_npes_pm

  end function get_ensemble_size


  subroutine get_ensemble_pelist(pelist, name)

    integer, intent(inout) :: pelist(:,:)
    character(len=*), intent(in), optional  :: name

    if (size(pelist,1) < ensemble_size) &
         call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 1st index < ensemble_size')

    if(present(name)) then
       select case(name)
       case('ocean')
          if (size(pelist,2) < ocean_npes_pm)&
               call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < ocean_npes_pm') 
          pelist = 0       
          pelist(1:ensemble_size,1:ocean_npes_pm) = &
               ensemble_pelist_ocean(1:ensemble_size,1:ocean_npes_pm)

       case('atmos')
          if (size(pelist,2) < atmos_npes_pm)&
               call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < atmos_npes_pm') 
          pelist = 0       
          pelist(1:ensemble_size,1:atmos_npes_pm) = &
               ensemble_pelist_atmos(1:ensemble_size,1:atmos_npes_pm)

       case default
          call mpp_error(FATAL,'get_ensemble_pelist: unknown argument name='//name)
       end select
    else
       if (size(pelist,2) < total_npes_pm)&
            call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < total_npes_pm') 
       pelist = 0       
       pelist(1:ensemble_size,1:total_npes_pm) = &
            ensemble_pelist(1:ensemble_size,1:total_npes_pm)
    endif

    return
  end subroutine get_ensemble_pelist

  subroutine get_ensemble_filter_pelist(pelist, name)

    integer, intent(inout) :: pelist(:)
    character(len=*), intent(in)  :: name

    select case(name)
    case('ocean')
       if (size(pelist) < ensemble_size * ocean_npes_pm)&
            call mpp_error(FATAL,'get_ensemble_filter_pelist: size of pelist argument < ensemble_size * ocean_npes_pm') 
       pelist = 0       
       pelist(1:ensemble_size*ocean_npes_pm) = &
            ensemble_pelist_ocean_filter(1:ensemble_size*ocean_npes_pm)

    case('atmos')
       if (size(pelist) < ensemble_size * atmos_npes_pm)&
            call mpp_error(FATAL,'get_ensemble_filter_pelist: size of pelist argument < ensemble_size * atmos_npes_pm') 
       pelist = 0       
       pelist(1:ensemble_size*atmos_npes_pm) = &
            ensemble_pelist_atmos_filter(1:ensemble_size*atmos_npes_pm)

    case default
       call mpp_error(FATAL,'get_ensemble_filter_pelist: unknown argument name='//name)
    end select


    return
  end subroutine get_ensemble_filter_pelist

!nnz: I think the following block of code should be contained in a subroutine
!     to consolidate and ensure the consistency of declaring the various pelists.

  subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, Atm_pelist, Ocean_pelist)    
    logical, intent(in)                  :: concurrent
    integer, intent(in)                  :: atmos_npes, ocean_npes
    integer, dimension(:), intent(inout) :: Atm_pelist, Ocean_pelist
    integer           :: atmos_pe_start, atmos_pe_end, ocean_pe_start, ocean_pe_end
    character(len=10) :: pelist_name, text
    integer           :: npes, n, m ,i

    npes = total_npes_pm

    allocate(ensemble_pelist(ensemble_size,total_npes_pm))
    allocate(ensemble_pelist_ocean(1:ensemble_size, 1:ocean_npes) )
    allocate(ensemble_pelist_atmos(1:ensemble_size, 1:atmos_npes) )
    atmos_pe_start = 0
    ocean_pe_start = 0
    if( concurrent .OR. atmos_npes+ocean_npes == npes )then
       ocean_pe_start = ensemble_size*atmos_npes
    endif
    do n=1,ensemble_size
       atmos_pe_end = atmos_pe_start + atmos_npes - 1
       ocean_pe_end = ocean_pe_start + ocean_npes - 1
       ensemble_pelist_atmos(n, 1:atmos_npes) = (/(i,i=atmos_pe_start,atmos_pe_end)/)
       ensemble_pelist_ocean(n, 1:ocean_npes) = (/(i,i=ocean_pe_start,ocean_pe_end)/)
       ensemble_pelist(n, 1:atmos_npes)       = ensemble_pelist_atmos(n, 1:atmos_npes)
       ensemble_pelist(n, atmos_npes+1:npes)  = ensemble_pelist_ocean(n, 1:ocean_npes)
       if(ANY(ensemble_pelist(n,:) == pe)) ensemble_id = n
       write(pelist_name,'(a,i2.2)')  '_ens',n
       call mpp_declare_pelist(ensemble_pelist(n,:), trim(pelist_name))
       atmos_pe_start = atmos_pe_end + 1
       ocean_pe_start = ocean_pe_end + 1
    enddo

    Atm_pelist(:)   = ensemble_pelist_atmos(ensemble_id,:)
    Ocean_pelist(:) = ensemble_pelist_ocean(ensemble_id,:)

    !    write(pelist_name,'(a,i2.2)')  '_ocn_ens',ensemble_id
    !    call mpp_declare_pelist(Ocean%pelist , trim(pelist_name) )

    !    write(pelist_name,'(a,i2.2)')  '_atm_ens',ensemble_id
    !    call mpp_declare_pelist(Atm%pelist , trim(pelist_name) )
    !
    !nnz: The above is sufficient for non-concurrent mode.
    !     BUT
    !     For atmosphere_init to work in ensemble, concurrent mode 
    !     the following Atm_pelist should be declared (per ensemble member)
    !     instead of the above Atm%pelist!
    !     
    !   allocate( Atm_pelist(1:ensemble_size, 1:atmos_npes) )
    !   do n=1,ensemble_size
    !       do i=1, atmos_npes
    !          Atm_pelist(n, i) = ensemble_pelist(n, i)
    !       enddo
    !       write(pelist_name,'(a,i2.2)')  '_atm_ens',n
    !       call mpp_declare_pelist(Atm_pelist(n,:) , trim(pelist_name) )
    !    enddo
    !
    !     The way I understand this with the help of Totalview is:
    !     With mpp_declare_pelist(Atm%pelist)
    !     When we are in fv_arrays_init when mp_init(comID) is called
    !     comID is the same for the atmospheric PE's for both ensemble members
    !     since peset(5)%id is the same (7) for those PE's, so the PE count is double what it should be inside
    !     mp_init().
    !     It is also true that for Ocean PE's, peset(4)%id is the same (6) for Ocean PE's in both ensemble members
    !     but for Ocean it is not a problem because Ocean is not trying to create new communicators
    !     from this peset whereas ATM does (vis mp_init).
    !
    !     Who sets peset(i)%id ? Can it be modified to assign different %id for the two subsets.
    !     peset(i)%id = 0 for Ocean PE's on ATM pesets and for ATM PE's on Ocean pesets.  
    !
    !     With mpp_declare_pelist(Atm_pelist(n,:)) n=1,...,ensemble_size
    !     we get separate pesets for each ATM ensemble member and each with a different %id and mp_init is cured. 
    !
    !     There is also a matter of precedence. If we have both calls
    !     call mpp_declare_pelist(Atm%pelist , trim(pelist_name) )
    !     and
    !     call mpp_declare_pelist(Atm_pelist(n,:) , trim(pelist_name) )
    !     then concurrent run fails because with call mpp_set_current_pelist( Atm%pelist   )
    !     peset(i) is searched for i=1,2,... and the first pelist that matches argument, its peset is set as current. 
    !
    !     To be consistent with ATM and OCEAN we can do the following 
    !     (eventhough mpp_declare_pelist(Ocean%pelist) is adequate right now.) 


    if( concurrent )then
       do n=1,ensemble_size
          write(pelist_name,'(a,i2.2)')  'atm_ens',n
          call mpp_declare_pelist(ensemble_pelist_atmos(n,:) , trim(pelist_name) )
          write(pelist_name,'(a,i2.2)')  'ocn_ens',n
          call mpp_declare_pelist(ensemble_pelist_ocean(n,:) , trim(pelist_name) )
       enddo
    else
       write(pelist_name,'(a,i2.2)')  'atm_ens',ensemble_id
       call mpp_declare_pelist(Atm_pelist , trim(pelist_name) )
       write(pelist_name,'(a,i2.2)')  'ocn_ens',ensemble_id
       call mpp_declare_pelist(Ocean_pelist , trim(pelist_name) )
    endif


    ocean_npes_pm = ocean_npes
    atmos_npes_pm = atmos_npes  

    !Declare pelist of all Ocean and Atmos pes across all ensembles ( filters )
    allocate(ensemble_pelist_ocean_filter(ensemble_size * ocean_npes_pm))
    allocate(ensemble_pelist_atmos_filter(ensemble_size * atmos_npes_pm))
    do n=1,ensemble_size
       do m=1,ocean_npes_pm
          i=(n-1)*ocean_npes_pm + m
          ensemble_pelist_ocean_filter(i) = ensemble_pelist_ocean(n,m)
       enddo
       do m=1,atmos_npes_pm
          i=(n-1)*atmos_npes_pm + m
          ensemble_pelist_atmos_filter(i) = ensemble_pelist_atmos(n,m)
       enddo
    enddo
    
    write(pelist_name,'(a)')  'ocn_filter'
    call mpp_declare_pelist(ensemble_pelist_ocean_filter, trim(pelist_name) )

    write(pelist_name,'(a)')  'atm_filter'
    call mpp_declare_pelist(ensemble_pelist_atmos_filter, trim(pelist_name) )

    !
    !Rename output files to identify the ensemble
    !If ensemble_size=1 do not rename files so that the same coupler
    !can be used for non-ensemble experiments
    !
    if (ensemble_size > 1) then       
       write( text,'(a,i2.2)' ) 'ens_', ensemble_id    
       !Append ensemble_id to the restart filenames
       call set_filename_appendix(trim(text)) 
       !Append ensemble_id to the diag_out filenames
       write( text,'(a,i2.2)' ) '.ens_', ensemble_id    
       call set_diag_filename_appendix(trim(text)) 
    endif   
    
  end subroutine ensemble_pelist_setup


end module ensemble_manager_mod


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                   !!
!!                   GNU General Public License                      !!
!!                                                                   !!
!! This file is part of the Flexible Modeling System (FMS).          !!
!!                                                                   !!
!! FMS is free software; you can redistribute it and/or modify       !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation.             !!
!!                                                                   !!
!! FMS 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 FMS; if not, write to:                                 !!
!!          Free Software Foundation, Inc.                           !!
!!          59 Temple Place, Suite 330                               !!
!!          Boston, MA  02111-1307  USA                              !!
!! or see:                                                           !!
!!          http://www.gnu.org/licenses/gpl.txt                      !!
!!                                                                   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module data_override_mod
!
! <CONTACT EMAIL="Giang.Nong@noaa.gov">
! G.T. Nong
! </CONTACT>
!
! <CONTACT EMAIL="Matthew.Harrison@noaa.gov">
!  M.J. Harrison 
! </CONTACT>
!
! <CONTACT EMAIL="Michael.Winton@noaa.gov">
! M. Winton
! </CONTACT>

!<OVERVIEW>
! Given a gridname, fieldname and model time this routine will get data in a file whose
! path is described in a user-provided data_table, do spatial and temporal interpolation if 
! necessary to convert data to model's grid and time.
!
! Before using data_override a data_table must be created with the following entries:
! gridname, fieldname_code, fieldname_file, file_name, ongrid, factor.
!
! More explainations about data_table entries can be found in the source code (defining data_type)
!
! If user wants to override fieldname_code with a const, set fieldname_file in data_table = ""
! and factor = const
!
! If user wants to override fieldname_code with data from a file, set fieldname_file = name in
! the netCDF data file, factor then will be for unit conversion (=1 if no conversion required)
!
! A field can be overriden globally (by default) or users can specify one or two regions in which
! data_override will take place, field values outside the region will not be affected. 
!</OVERVIEW>
#include <fms_platform.h>
use platform_mod, only: r8_kind
use constants_mod, only: PI
use mpp_io_mod, only: axistype,mpp_close,mpp_open,mpp_get_axis_data,MPP_RDONLY,MPP_ASCII
use mpp_mod, only : mpp_error,FATAL,WARNING,mpp_pe,stdout,stdlog,mpp_root_pe, NOTE, mpp_min, mpp_max, mpp_chksum
use mpp_mod, only : input_nml_file
use horiz_interp_mod, only : horiz_interp_init, horiz_interp_new, horiz_interp_type, &
     assignment(=), horiz_interp_del
use time_interp_external_mod, only:time_interp_external_init, time_interp_external, &
     init_external_field, get_external_field_size
use fms_io_mod, only: field_size, read_data, fms_io_init,get_mosaic_tile_grid
use fms_mod, only: write_version_number, field_exist, lowercase, file_exist, open_namelist_file, check_nml_error, close_file
use axis_utils_mod, only: get_axis_bounds
use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.)
use mpp_domains_mod, only : mpp_copy_domain, mpp_get_global_domain
use mpp_domains_mod, only : mpp_get_data_domain, mpp_set_compute_domain, mpp_set_data_domain
use mpp_domains_mod, only : mpp_set_global_domain, mpp_deallocate_domain

use time_manager_mod, only: time_type

implicit none
private

character(len=128) :: version = '$Id: data_override.F90,v 18.0.4.1.2.1.2.2 2010/09/08 21:00:23 wfc Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

type data_type_lima
   character(len=3)   :: gridname
   character(len=128) :: fieldname_code !fieldname used in user's code (model)
   character(len=128) :: fieldname_file ! fieldname used in the netcdf data file
   character(len=512) :: file_name   ! name of netCDF data file
   logical            :: ongrid   ! true if data is on model's grid, false otherwise
   real               :: factor ! For unit conversion, default=1, see OVERVIEW above
end type data_type_lima

type data_type
   character(len=3)   :: gridname
   character(len=128) :: fieldname_code !fieldname used in user's code (model)
   character(len=128) :: fieldname_file ! fieldname used in the netcdf data file
   character(len=512) :: file_name   ! name of netCDF data file
   character(len=128) :: interpol_method   ! interpolation method (default "bilinear")
   real               :: factor ! For unit conversion, default=1, see OVERVIEW above
end type data_type

type override_type
   character(len=3)        :: gridname  
   character(len=128)      :: fieldname
   integer                 :: t_index !index for time interp
   type(horiz_interp_type) :: horz_interp ! index for horizontal spatial interp
   integer                 :: dims(4) ! dimensions(x,y,z,t) of the field in filename
   integer                 :: comp_domain(4) ! istart,iend,jstart,jend for compute domain
   logical, dimension(:,:), _ALLOCATABLE :: region1 ! mask for regional override
   logical, dimension(:,:), _ALLOCATABLE :: region2 ! mask for regional override
end type override_type

 integer, parameter :: max_table=100, max_array=100
 integer            :: table_size ! actual size of data table
 integer, parameter :: ANNUAL=1, MONTHLY=2, DAILY=3, HOURLY=4, UNDEF=-1
 real, parameter    :: tpi=2*PI
 real               :: deg_to_radian, radian_to_deg 
 logical            :: module_is_initialized = .FALSE.

type(domain2D),save :: ocn_domain,atm_domain,lnd_domain, ice_domain 
real, dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn
real, dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm
real, dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice
real, dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd
real                                      :: min_glo_lon_ocn, max_glo_lon_ocn
real                                      :: min_glo_lon_atm, max_glo_lon_atm
real                                      :: min_glo_lon_lnd, max_glo_lon_lnd
real                                      :: min_glo_lon_ice, max_glo_lon_ice
integer:: num_fields = 0 ! number of fields in override_array already processed
type(data_type), dimension(max_table)           :: data_table ! user-provided data table
type(data_type)                                 :: default_table
type(override_type), dimension(max_array), save :: override_array ! to store processed fields
type(override_type), save                       :: default_array
logical                                         :: atm_on, ocn_on, lnd_on, ice_on
logical                                         :: debug_data_override
logical                                         :: grid_center_bug = .false.

namelist /data_override_nml/ debug_data_override, grid_center_bug

interface data_override
     module procedure data_override_0d
     module procedure data_override_2d
     module procedure data_override_3d
end interface

public :: data_override_init, data_override

contains
!===============================================================================================
! <SUBROUTINE NAME="data_override_init">
!   <DESCRIPTION>
! Assign default values for default_table, get domain of component models,
! get global grids of component models.
! Users should call data_override_init before calling data_override
!   </DESCRIPTION>
!   <TEMPLATE>
! call data_override_init
!   </TEMPLATE>
subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in)
  type (domain2d), intent(in), optional :: Atm_domain_in
  type (domain2d), intent(in), optional :: Ocean_domain_in, Ice_domain_in 
  type (domain2d), intent(in), optional :: Land_domain_in

! <NOTE>
! This subroutine should be called in coupler_init after
! (ocean/atmos/land/ice)_model_init have been called.
!
! data_override_init can be called more than once, in one call the user can pass 
! up to 4 domains of component models, at least one domain must be present in
! any call
!
! Data_table is initialized here with default values. Users should provide "real" values
! that will override the default values. Real values can be given using data_table, each
! line of data_table contains one data_entry. Items of data_entry are comma separated.
!
! </NOTE>
  character(len=128)    :: grid_file = 'INPUT/grid_spec.nc'
  integer               :: is,ie,js,je,count
  integer               :: i, iunit, ntable, ntable_lima, ntable_new, unit,io_status, ierr
  character(len=256)    :: record
  type(data_type_lima)  :: data_entry_lima
  type(data_type)       :: data_entry
  logical               :: file_open

  debug_data_override = .false.

#ifdef INTERNAL_FILE_NML
  read (input_nml_file, data_override_nml, iostat=io_status)
  ierr = check_nml_error(io_status, 'data_override_nml')
#else
  iunit = open_namelist_file ()
  ierr=1; do while (ierr /= 0)
  read  (iunit, nml=data_override_nml, iostat=io_status, end=10)
  ierr = check_nml_error(io_status, 'data_override_nml')
  enddo
10 call close_file (iunit)
#endif
  unit = stdlog()
  write(unit, data_override_nml)

!  if(module_is_initialized) return

  atm_on = PRESENT(Atm_domain_in)
  ocn_on = PRESENT(Ocean_domain_in)
  lnd_on = PRESENT(Land_domain_in)
  ice_on = PRESENT(Ice_domain_in)
  if(.not. module_is_initialized) then
    atm_domain = NULL_DOMAIN2D
    ocn_domain = NULL_DOMAIN2D
    lnd_domain = NULL_DOMAIN2D
    ice_domain = NULL_DOMAIN2D 
  end if   
  if (atm_on) atm_domain = Atm_domain_in
  if (ocn_on) ocn_domain = Ocean_domain_in
  if (lnd_on) lnd_domain = Land_domain_in
  if (ice_on) ice_domain = Ice_domain_in 

  if(.not. module_is_initialized) then
    call horiz_interp_init
    radian_to_deg = 180./PI
    deg_to_radian = PI/180.

    call write_version_number (version, tagname)

!  Initialize user-provided data table  
    default_table%gridname = 'none'
    default_table%fieldname_code = 'none'
    default_table%fieldname_file = 'none'
    default_table%file_name = 'none'
    default_table%factor = 1.
    default_table%interpol_method = 'bilinear'
    do i = 1,max_table
       data_table(i) = default_table
    enddo

!  Read coupler_table 
    call mpp_open(iunit, 'data_table', action=MPP_RDONLY)
    ntable = 0
    ntable_lima = 0
    ntable_new = 0
    do while (ntable <= max_table)
       read(iunit,'(a)',end=100) record
       if (record(1:1) == '#') cycle
       if (record(1:10) == '          ') cycle
       ntable=ntable+1 
       if (index(lowercase(record), ".false.") .ne. 0 .or. index(lowercase(record), ".true.") .ne. 0 ) then   ! old format
          ntable_lima = ntable_lima + 1
          read(record,*,err=99) data_entry_lima
          data_entry%gridname       = data_entry_lima%gridname
          data_entry%fieldname_code = data_entry_lima%fieldname_code
          data_entry%fieldname_file = data_entry_lima%fieldname_file
          data_entry%file_name      = data_entry_lima%file_name
          data_entry%factor         = data_entry_lima%factor 
          if(data_entry_lima%ongrid) then
             data_entry%interpol_method = 'none'
          else
             data_entry%interpol_method = 'bilinear'
          endif
       else                                      ! new format
          ntable_new=ntable_new+1
          read(record,*,err=99) data_entry
          data_entry%interpol_method = lowercase(data_entry%interpol_method) 
          if (data_entry%interpol_method == 'default') then
            data_entry%interpol_method = default_table%interpol_method
          endif
          if (.not.(data_entry%interpol_method == 'default'  .or. &
                    data_entry%interpol_method == 'bicubic'  .or. &
                    data_entry%interpol_method == 'bilinear' .or. &
                    data_entry%interpol_method == 'none')) then
             unit = stdout()
             write(unit,*)" gridname is ", trim(data_entry%gridname)
             write(unit,*)" fieldname_code is ", trim(data_entry%fieldname_code)
             write(unit,*)" fieldname_file is ", trim(data_entry%fieldname_file)
             write(unit,*)" file_name is ", trim(data_entry%file_name)
             write(unit,*)" factor is ", data_entry%factor 
             write(unit,*)" interpol_method is ", trim(data_entry%interpol_method)
             call mpp_error(FATAL, 'data_override_mod: invalid last entry in data_override_table, ' &
                               //'its value should be "default", "bicubic", "bilinear" or "none" ') 
          endif
       endif
       data_table(ntable) = data_entry
    enddo
    call mpp_error(FATAL,'too many enries in data_table')
99  call mpp_error(FATAL,'error in data_table format')
100 continue
    table_size = ntable
    if(ntable_new*ntable_lima /= 0) call mpp_error(FATAL, &
       'data_override_mod: New and old formats together in same data_table not supported')
    call mpp_close(iunit)
!  Initialize override array
    default_array%gridname = 'NONE'
    default_array%fieldname = 'NONE'
    default_array%t_index = -1
    default_array%dims = -1
    default_array%comp_domain = -1
    do i = 1, max_array
       override_array(i) = default_array
    enddo
    call time_interp_external_init
 endif

 module_is_initialized = .TRUE.

 if ( .NOT. (atm_on .or. ocn_on .or. lnd_on .or. ice_on)) return 
 call fms_io_init

! Test if grid_file is already opened
 inquire (file=trim(grid_file), opened=file_open)
 if(file_open) call mpp_error(FATAL, trim(grid_file)//' already opened')

 if(field_exist(grid_file, "x_T" ) .OR. field_exist(grid_file, "geolon_t" ) ) then
    if (atm_on) then
       call mpp_get_compute_domain( atm_domain,is,ie,js,je) 
       allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je))
       call get_grid_version_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
            min_glo_lon_atm, max_glo_lon_atm )
    endif
    if (ocn_on) then
       call mpp_get_compute_domain( ocn_domain,is,ie,js,je) 
       allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je))
       call get_grid_version_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
            min_glo_lon_ocn, max_glo_lon_ocn )
    endif

    if (lnd_on) then
       call mpp_get_compute_domain( lnd_domain,is,ie,js,je) 
       allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je))
       call get_grid_version_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
            min_glo_lon_lnd, max_glo_lon_lnd )
    endif

    if (ice_on) then
       call mpp_get_compute_domain( ice_domain,is,ie,js,je) 
       allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je))
       call get_grid_version_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
            min_glo_lon_ice, max_glo_lon_ice )
    endif
 else if(field_exist(grid_file, "ocn_mosaic_file" ) .OR. field_exist(grid_file, "gridfiles" ) ) then
    if(field_exist(grid_file, "gridfiles" ) ) then
       count = 0
       if (atm_on) count = count + 1 
       if (lnd_on) count = count + 1 
       if ( ocn_on .OR. ice_on ) count = count + 1 
       if(count .NE. 1) call mpp_error(FATAL, 'data_override_mod: the grid file is a solo mosaic, ' // &
            'one and only one of atm_on, lnd_on or ice_on/ocn_on should be true')
    endif
   if (atm_on) then
       call mpp_get_compute_domain(atm_domain,is,ie,js,je) 
       allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je))
       call get_grid_version_2(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
            min_glo_lon_atm, max_glo_lon_atm )
    endif

    if (ocn_on) then
       call mpp_get_compute_domain( ocn_domain,is,ie,js,je) 
       allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je))
       call get_grid_version_2(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
            min_glo_lon_ocn, max_glo_lon_ocn )
    endif

    if (lnd_on) then
       call mpp_get_compute_domain( lnd_domain,is,ie,js,je) 
       allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je))
       call get_grid_version_2(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
            min_glo_lon_lnd, max_glo_lon_lnd )
    endif

    if (ice_on) then
       call mpp_get_compute_domain( ice_domain,is,ie,js,je) 
       allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je))
       call get_grid_version_2(grid_file, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
            min_glo_lon_ice, max_glo_lon_ice )
    endif
 else
    call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '//trim(grid_file))
 end if

end subroutine data_override_init
! </SUBROUTINE>
!===============================================================================================
subroutine check_grid_sizes(domain_name, Domain, nlon, nlat)
character(len=12), intent(in) :: domain_name
type (domain2d),   intent(in) :: Domain
integer,           intent(in) :: nlon, nlat

character(len=184) :: error_message
integer            :: xsize, ysize

call mpp_get_global_domain(Domain, xsize=xsize, ysize=ysize)
if(nlon .NE. xsize .OR. nlat .NE. ysize) then
  error_message = 'Error in data_override_init. Size of grid as specified by '// &
                  '             does not conform to that specified by grid_spec.nc.'// &
                  '  From             :     by      From grid_spec.nc:     by    '
  error_message( 59: 70) = domain_name
  error_message(130:141) = domain_name
  write(error_message(143:146),'(i4)') xsize
  write(error_message(150:153),'(i4)') ysize
  write(error_message(174:177),'(i4)') nlon
  write(error_message(181:184),'(i4)') nlat
  call mpp_error(FATAL,error_message)
endif

end subroutine check_grid_sizes
!===============================================================================================
subroutine get_domain(gridname, domain, comp_domain)
! Given a gridname, this routine returns the working domain associated with this gridname
  character(len=3), intent(in) :: gridname
  type(domain2D), intent(inout) :: domain
  integer, intent(out), optional :: comp_domain(4) ! istart,iend,jstart,jend for compute domain

  domain = NULL_DOMAIN2D
  select case (gridname)
     case('OCN')
        domain = ocn_domain
     case('ATM')       
        domain = atm_domain
     case('LND')       
        domain = lnd_domain
     case('ICE')        
        domain = ice_domain
     case default
        call mpp_error(FATAL,'error in data_override get_domain')
  end select
  if(domain .EQ. NULL_DOMAIN2D) call mpp_error(FATAL,'data_override: failure in get_domain')
  if(present(comp_domain)) &
     call mpp_get_compute_domain(domain,comp_domain(1),comp_domain(2),comp_domain(3),comp_domain(4)) 
end subroutine get_domain
!===============================================================================================

! <SUBROUTINE NAME="data_override_2d">
!   <DESCRIPTION>
! This routine performs data override for 2D fields; for usage, see data_override_3d.
!   </DESCRIPTION>
subroutine data_override_2d(gridname,fieldname,data_2D,time,override,region1,region2)
  character(len=3), intent(in) :: gridname ! model grid ID
  character(len=*), intent(in) :: fieldname ! field to override
  logical, intent(out), optional :: override ! true if the field has been overriden succesfully
  real, intent(in), optional :: region1(4),region2(4) !lat and lon of region where override is done
  type(time_type), intent(in) :: time !  model time
  real, dimension(:,:), intent(inout) :: data_2D !data returned by this call
!  real, dimension(size(data_2D,1),size(data_2D,2),1) :: data_3D
  real, dimension(:,:,:), allocatable ::  data_3D
  integer       :: index1
  integer       :: i

!1  Look  for the data file in data_table 
  if(PRESENT(override)) override = .false.
  index1 = -1
  do i = 1, table_size
     if( trim(gridname) /= trim(data_table(i)%gridname)) cycle
     if( trim(fieldname) /= trim(data_table(i)%fieldname_code)) cycle
     index1 = i                               ! field found        
     exit
  enddo
  if(index1 .eq. -1) return  ! NO override was performed

  allocate(data_3D(size(data_2D,1),size(data_2D,2),1))
  data_3D(:,:,1) = data_2D
  call data_override_3d(gridname,fieldname,data_3D,time,override,region1,region2,data_index=index1)
     
  data_2D(:,:) = data_3D(:,:,1)
  deallocate(data_3D)
end subroutine data_override_2d
! </SUBROUTINE>
!===============================================================================================

! <SUBROUTINE NAME="data_override_3d">
!   <DESCRIPTION>
! This routine performs data override for 3D fields
!   <TEMPLATE>
! call data_override(gridname,fieldname,data,time,override)
!   </TEMPLATE>
!   </DESCRIPTION>

!   <IN NAME="gridname"  TYPE="character" DIM="(*)">
! Grid name (Ocean, Ice, Atmosphere, Land)
!   </IN>
!   <IN NAME="fieldname_code" TYPE="character" DIM="(*)">
!    Field name as used in the code (may be different from the name in NetCDF data file)
!   </IN>
!   <OUT NAME="data" TYPE="real" DIM="(:,:,:)">
!    array containing output data
!   </OUT>
!   <IN NAME="time" TYPE="time_type">
!    model time
!   </IN>
!   <OUT NAME="override" TYPE="logical">
!    TRUE if the field is overriden, FALSE otherwise
!   </OUT>
!   <IN NAME="region1" TYPE="real" DIM="(4)">
!    Restricts override to a rectangular region in lat,lon space.
!    This may not be a rectangular region in i,j space when the model grid is tripolar.
!    region1=(/lat_start, lat_end, lon_start, lon_end/)
!    Clarification regarding longitude: lon_start may be greater than lon_end.
!    The region overriden will be from lat_start eastward to lat_end.
!    e.g. if lat_start,lat_end = 180.,0.0 then the western hemisphere will be overriden.
!   </IN>
!   <IN NAME="region2" TYPE="real" DIM="(4)">
!    A second region to override. May be present only if region1 is also present.
!   </IN>
!   <IN NAME="data_index" TYPE="integer">
!   </IN>
subroutine data_override_3d(gridname,fieldname_code,data1,time,override,region1,region2,data_index)
  character(len=3), intent(in) :: gridname ! model grid ID
  character(len=*), intent(in) :: fieldname_code ! field name as used in the model
  logical, intent(out), optional :: override ! true if the field has been overriden succesfully
  type(time_type), intent(in) :: time !(target) model time
  real, intent(in), optional :: region1(4),region2(4) !lat and lon of regions where override is done
!Note: region2 can not exist without region1. In other words, if only one region is specified, it
! should be region1
  integer, intent(in), optional :: data_index
  real, dimension(:,:,:), intent(out) :: data1 !data returned by this call
  real, dimension(:,:,:), allocatable :: data !temporary array for data
  character(len=512) :: filename !file containing source data
  character(len=128) :: fieldname ! fieldname used in the data file
  integer :: i,j
  integer :: dims(4)
  integer :: index1 ! field index in data_table
  integer :: id_time !index for time interp in override array
  integer :: axis_sizes(4)
  real, dimension(:),allocatable :: lon_in, lat_in !of the input (source) grid
  real, dimension(:,:), pointer :: lon_local =>NULL(), &
                                   lat_local =>NULL() !of output (target) grid cells

  type(axistype) :: axis_centers(4), axis_bounds(4)
  logical :: data_file_is_2D = .false.  !data in netCDF file is 2D
  logical :: ongrid, use_comp_domain
  type(domain2D) :: domain
  integer :: curr_position ! position of the field currently processed in override_array
  real :: factor
  integer, dimension(4) :: comp_domain = 0  ! istart,iend,jstart,jend for compute domain
  integer :: ilocal, jlocal, dxsize, dysize

  use_comp_domain = .false.
  if(.not.module_is_initialized) &
       call mpp_error(FATAL,'Error: need to call data_override_init first')

!1  Look  for the data file in data_table 
  if(PRESENT(override)) override = .false.
  if (present(data_index)) then
    index1 = data_index
  else
    index1 = -1
    do i = 1, table_size
       if( trim(gridname) /= trim(data_table(i)%gridname)) cycle
       if( trim(fieldname_code) /= trim(data_table(i)%fieldname_code)) cycle
       index1 = i                               ! field found        
       exit
    enddo
    if(index1 .eq. -1) then
       if(mpp_pe() == mpp_root_pe() .and. debug_data_override) &
            call mpp_error(WARNING,'this field is NOT found in data_table: '//trim(fieldname_code))
       return  ! NO override was performed
    endif
  endif
 
  if(present(region2) .and. .not. present(region1)) &
       call mpp_error(FATAL,'data_override: region2 is specified without region1')

  fieldname = data_table(index1)%fieldname_file ! fieldname in netCDF data file
  factor = data_table(index1)%factor

  if(fieldname == "") then
     data1 = factor
     if(PRESENT(override)) override = .true.
     return
  else
     filename = data_table(index1)%file_name
     if (filename == "") call mpp_error(FATAL,'data_override: filename not given in data_table')
  endif  
  ongrid = (data_table(index1)%interpol_method == 'none')

!3 Check if fieldname has been previously processed
  curr_position = -1
  if(num_fields > 0 ) then
     do i = 1, num_fields
        if(trim(override_array(i)%gridname) /= trim(gridname))   cycle 
        if(trim(override_array(i)%fieldname) /= trim(fieldname_code)) cycle
        curr_position = i
        exit        
     enddo
  endif

  if(curr_position < 0) then ! the field has not been processed previously
     num_fields = num_fields + 1
     curr_position = num_fields     
! Get working domain from model's gridname
     call get_domain(gridname,domain,comp_domain)                          
     dxsize = comp_domain(2)-comp_domain(1) + 1
     dysize = comp_domain(4)-comp_domain(3) + 1
     if(dxsize==size(data1,1) .and. dysize==size(data1,2)) use_comp_domain = .true.
     if(present(region1)) then
       allocate(override_array(curr_position)%region1(comp_domain(1):comp_domain(2), comp_domain(3):comp_domain(4)))
       call get_region_bounds( &
         gridname,comp_domain(1),comp_domain(2),comp_domain(3),comp_domain(4),region1,override_array(curr_position)%region1)
       if(present(region2)) then
         allocate(override_array(curr_position)%region2(comp_domain(1):comp_domain(2), comp_domain(3):comp_domain(4)))
         call get_region_bounds( &
           gridname,comp_domain(1),comp_domain(2),comp_domain(3),comp_domain(4),region2,override_array(curr_position)%region2)
       endif
     endif
! record fieldname, gridname in override_array    
     override_array(curr_position)%fieldname = fieldname_code
     override_array(curr_position)%gridname = gridname
     override_array(curr_position)%comp_domain = comp_domain
!4 get index for time interp   
     if(ongrid) then
        id_time = init_external_field(filename,fieldname,domain=domain,verbose=.false.,use_comp_domain=use_comp_domain)
        dims = get_external_field_size(id_time)
        override_array(curr_position)%dims = dims
        if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1') 
        override_array(curr_position)%t_index = id_time     
     else !ongrid=false
        id_time = init_external_field(filename,fieldname,domain=domain, axis_centers=axis_centers,&
             axis_sizes=axis_sizes, verbose=.false.,override=.true.,use_comp_domain=use_comp_domain)  
        dims = get_external_field_size(id_time)
        override_array(curr_position)%dims = dims
        if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 2')
        override_array(curr_position)%t_index = id_time
        
!5 Get local lon and lat of model grid
        select case(gridname)
        case('OCN')          
           lon_local => lon_local_ocn; lat_local => lat_local_ocn
        case('ICE')
           lon_local => lon_local_ice; lat_local => lat_local_ice
        case('ATM')
           lon_local => lon_local_atm; lat_local => lat_local_atm
        case('LND')
           lon_local => lon_local_lnd; lat_local => lat_local_lnd
        case default
           call mpp_error(FATAL,'error: gridname not recognized in data_override')
        end select

!7 get lon and lat of the input (source) grid, assuming that axis%data contains
!  lat and lon of the input grid (in degrees)
        call get_axis_bounds(axis_centers(1),axis_bounds(1), axis_centers)
        call get_axis_bounds(axis_centers(2),axis_bounds(2), axis_centers)
        allocate(lon_in(axis_sizes(1)+1), lat_in(axis_sizes(2)+1))
        call mpp_get_axis_data(axis_bounds(1),lon_in)
        call mpp_get_axis_data(axis_bounds(2),lat_in)
! convert lon_in and lat_in from deg to radian
        lon_in = lon_in * deg_to_radian
        lat_in = lat_in * deg_to_radian

        select case (data_table(index1)%interpol_method)
        case ('bilinear')
          call horiz_interp_new (override_array(curr_position)%horz_interp,lon_in, lat_in, lon_local, lat_local,&
               interp_method="bilinear")
        case ('bicubic')
          call horiz_interp_new (override_array(curr_position)%horz_interp,lon_in, lat_in, lon_local, lat_local,&
               interp_method="bicubic")
        end select
        deallocate(lon_in)
        deallocate(lat_in)
     endif !(ongrid)
  else !curr_position >0
     dims = override_array(curr_position)%dims
     comp_domain = override_array(curr_position)%comp_domain
!9 Get id_time  previously stored in override_array
     id_time = override_array(curr_position)%t_index
  endif !if curr_position < 0

  allocate(data(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4),size(data1,3)))
  data = HUGE(1.0)
  ! Determine if  data in netCDF file is 2D or not  
  data_file_is_2D = .false.
  if((dims(3) == 1) .and. (size(data1,3)>1)) data_file_is_2D = .true. 

  if(ongrid) then
!10 do time interp to get data in compute_domain
     if(data_file_is_2D) then        
        call time_interp_external(id_time,time,data(:,:,1),verbose=.false.)
        data(:,:,1) = data(:,:,1)*factor
        do i = 2, size(data,3)
           data(:,:,i) = data(:,:,1)
        enddo
     else
        call time_interp_external(id_time,time,data,verbose=.false.)
        data = data*factor
     endif    
  else  ! off grid case
! do time interp to get global data
     if(data_file_is_2D) then
        call time_interp_external(id_time,time,data(:,:,1),verbose=.false.,horz_interp=override_array(curr_position)%horz_interp) 
        data(:,:,1) = data(:,:,1)*factor
        do i = 2, size(data,3)
           data(:,:,i) = data(:,:,1)
        enddo
     else
        call time_interp_external(id_time,time,data,verbose=.false.,horz_interp=override_array(curr_position)%horz_interp)
        data = data*factor
     endif

  endif

  if(present(region1)) then
    do j = comp_domain(3), comp_domain(4)
      jlocal = j - comp_domain(3) + 1
      do i = comp_domain(1), comp_domain(2)
        if(override_array(curr_position)%region1(i,j)) then
          ilocal = i - comp_domain(1) + 1
          data1(ilocal,jlocal,:) = data(i,j,:)
        endif
      enddo
    enddo   
    if(present(region2)) then
      do j = comp_domain(3), comp_domain(4)
        jlocal = j - comp_domain(3) + 1
        do i = comp_domain(1), comp_domain(2)
          if(override_array(curr_position)%region2(i,j)) then
            ilocal = i - comp_domain(1) + 1
            data1(ilocal,jlocal,:) = data(i,j,:)
          endif
        enddo
      enddo   
    endif
  else
     data1 = data
  endif

  if(PRESENT(override)) override = .true.
  deallocate(data)

end subroutine data_override_3d
! </SUBROUTINE>

! <SUBROUTINE NAME="data_override_0d">
!   <DESCRIPTION>
! This routine performs data override for scalar fields
!   <TEMPLATE>
! call data_override(fieldname,data,time,override)
!   </TEMPLATE>
!   </DESCRIPTION>
!   <IN NAME="gridname"  TYPE="character" DIM="(*)">
! Grid name (Ocean, Ice, Atmosphere, Land)
!   </IN>
!   <IN NAME="fieldname_code" TYPE="character" DIM="(*)">
!    Field name as used in the code (may be different from the name in NetCDF data file)
!   </IN>
!   <OUT NAME="data" TYPE="real" DIM="(:,:,:)">
!    array containing output data
!   </OUT>
!   <IN NAME="time" TYPE="time_type">
!    model time
!   </IN>
!   <OUT NAME="override" TYPE="logical">
!    TRUE if the field is overriden, FALSE otherwise
!   </OUT>
!   <IN NAME="data_index" TYPE="integer">
!   </IN>
subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_index)
  character(len=3), intent(in) :: gridname ! model grid ID
  character(len=*), intent(in) :: fieldname_code ! field name as used in the model
  logical, intent(out), optional :: override ! true if the field has been overriden succesfully
  type(time_type), intent(in) :: time !(target) model time
  real,             intent(out) :: data !data returned by this call
  integer, intent(in), optional :: data_index

  character(len=512) :: filename !file containing source data
  character(len=128) :: fieldname ! fieldname used in the data file
  integer :: index1 ! field index in data_table
  integer :: id_time !index for time interp in override array
  integer :: curr_position ! position of the field currently processed in override_array
  integer :: i
  real :: factor

  if(.not.module_is_initialized) &
       call mpp_error(FATAL,'Error: need to call data_override_init first')

!1  Look  for the data file in data_table 
  if(PRESENT(override)) override = .false.
  if (present(data_index)) then
    index1 = data_index
  else
    index1 = -1
    do i = 1, table_size
       if( trim(gridname) /= trim(data_table(i)%gridname)) cycle
       if( trim(fieldname_code) /= trim(data_table(i)%fieldname_code)) cycle
       index1 = i                               ! field found        
       exit
    enddo
    if(index1 .eq. -1) then
       if(mpp_pe() == mpp_root_pe() .and. debug_data_override) &
            call mpp_error(WARNING,'this field is NOT found in data_table: '//trim(fieldname_code))
       return  ! NO override was performed
    endif
  endif
 
  fieldname = data_table(index1)%fieldname_file ! fieldname in netCDF data file
  factor = data_table(index1)%factor

  if(fieldname == "") then
     data = factor
     if(PRESENT(override)) override = .true.
     return
  else
     filename = data_table(index1)%file_name
     if (filename == "") call mpp_error(FATAL,'data_override: filename not given in data_table')
  endif  

!3 Check if fieldname has been previously processed
  curr_position = -1
  if(num_fields > 0 ) then
     do i = 1, num_fields
        if(trim(override_array(i)%gridname) /= trim(gridname))   cycle 
        if(trim(override_array(i)%fieldname) /= trim(fieldname_code)) cycle
        curr_position = i
        exit        
     enddo
  endif

  if(curr_position < 0) then ! the field has not been processed previously
     num_fields = num_fields + 1
     curr_position = num_fields     
     ! record fieldname, gridname in override_array    
     override_array(curr_position)%fieldname = fieldname_code
     override_array(curr_position)%gridname = gridname
     id_time = init_external_field(filename,fieldname,verbose=.false.)
     if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1') 
     override_array(curr_position)%t_index = id_time     
  else !curr_position >0
     !9 Get id_time  previously stored in override_array
     id_time = override_array(curr_position)%t_index
  endif !if curr_position < 0

  !10 do time interp to get data in compute_domain
  call time_interp_external(id_time, time, data, verbose=.false.)
  data = data*factor

  if(PRESENT(override)) override = .true.

end subroutine data_override_0d
! </SUBROUTINE>

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

! Get lon and lat of three model (target) grids from grid_spec.nc
subroutine get_grid_version_1(grid_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon)
  character(len=*),            intent(in) :: grid_file
  character(len=*),            intent(in) :: mod_name
  type(domain2d),              intent(in) :: domain
  integer,                     intent(in) :: isc, iec, jsc, jec
  real, dimension(isc:,jsc:), intent(out) :: lon, lat
  real,                       intent(out) :: min_lon, max_lon

  integer                                      :: i, j, siz(4)
  integer                                      :: nlon, nlat         ! size of global lon and lat
  real(r8_kind), dimension(:,:,:), allocatable :: lon_vert, lat_vert !of OCN grid vertices
  real(r8_kind), dimension(:),     allocatable :: glon, glat         ! lon and lat of 1-D grid of atm/lnd
  logical                                      :: is_new_grid
  integer                                      :: is, ie, js, je
  integer                                      :: isd, ied, jsd, jed
  integer                                      :: isg, ieg, jsg, jeg
  type(domain2d)                               :: domain2
  character(len=3)                             :: xname, yname

  call mpp_get_data_domain(domain, isd, ied, jsd, jed)
  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)

  select case(mod_name)
  case('ocn', 'ice')
    is_new_grid = .FALSE.
    if(field_exist(grid_file, 'x_T')) then
       is_new_grid = .true.
    else if(field_exist(grid_file, 'geolon_t')) then
       is_new_grid = .FALSE.
    else
       call mpp_error(FATAL,'data_override: both x_T and geolon_t is not in the grid file '//trim(grid_file) )
    endif

    if(is_new_grid) then
      call field_size(grid_file, 'x_T', siz)
      nlon = siz(1); nlat = siz(2)
      call check_grid_sizes(trim(mod_name)//'_domain  ', domain, nlon, nlat)
      allocate(lon_vert(isc:iec,jsc:jec,4), lat_vert(isc:iec,jsc:jec,4) )
      call read_data(trim(grid_file), 'x_vert_T', lon_vert, domain)
      call read_data(trim(grid_file), 'y_vert_T', lat_vert, domain)
      
!2 Global lon and lat of ocean grid cell centers are determined from adjacent vertices
      lon(:,:) = (lon_vert(:,:,1) + lon_vert(:,:,2) + lon_vert(:,:,3) + lon_vert(:,:,4))*0.25
      lat(:,:) = (lat_vert(:,:,1) + lat_vert(:,:,2) + lat_vert(:,:,3) + lat_vert(:,:,4))*0.25
    else      
      if(grid_center_bug) call mpp_error(NOTE, &
           'data_override: grid_center_bug is set to true, the grid center location may be incorrect')
      call field_size(grid_file, 'geolon_vert_t', siz)
      nlon = siz(1) - 1; nlat = siz(2) - 1;
      call check_grid_sizes(trim(mod_name)//'_domain  ', domain, nlon, nlat)
      call mpp_copy_domain(domain, domain2)
      call mpp_set_compute_domain(domain2, isc, iec+1, jsc, jec+1, iec-isc+2, jec-jsc+2 )
      call mpp_set_data_domain   (domain2, isd, ied+1, jsd, jed+1, ied-isd+2, jed-jsd+2 )   
      call mpp_set_global_domain (domain2, isg, ieg+1, jsg, jeg+1, ieg-isg+2, jeg-jsg+2 )    
      allocate(lon_vert(isc:iec+1,jsc:jec+1,1))
      allocate(lat_vert(isc:iec+1,jsc:jec+1,1))
      call read_data(trim(grid_file), 'geolon_vert_t', lon_vert, domain2)
      call read_data(trim(grid_file), 'geolat_vert_t', lat_vert, domain2)

      if(grid_center_bug) then
         do j = jsc, jec
            do i = isc, iec
               lon(i,j) = (lon_vert(i,j,1) + lon_vert(i+1,j,1))/2.
               lat(i,j) = (lat_vert(i,j,1) + lat_vert(i,j+1,1))/2.
            enddo
         enddo
      else
         do j = jsc, jec
            do i = isc, iec
               lon(i,j) = (lon_vert(i,j,1) + lon_vert(i+1,j,1) + &
                    lon_vert(i+1,j+1,1) + lon_vert(i,j+1,1))*0.25
               lat(i,j) = (lat_vert(i,j,1) + lat_vert(i+1,j,1) + &
                    lat_vert(i+1,j+1,1) + lat_vert(i,j+1,1))*0.25
            enddo
         enddo
      end if
      call mpp_deallocate_domain(domain2)
    endif
    deallocate(lon_vert)
    deallocate(lat_vert)
  case('atm', 'lnd')
     if(trim(mod_name) == 'atm') then
        xname = 'xta'; yname = 'yta'
     else
        xname = 'xtl'; yname = 'ytl'
     endif
     call field_size(grid_file, xname, siz)
     nlon = siz(1); allocate(glon(nlon))
     call read_data(grid_file, xname, glon, no_domain = .true.)

     call field_size(grid_file, yname, siz)
     nlat = siz(1); allocate(glat(nlat))
     call read_data(grid_file, yname, glat, no_domain = .true.)
     call check_grid_sizes(trim(mod_name)//'_domain  ', domain, nlon, nlat)

     is = isc - isg + 1; ie = iec - isg + 1
     js = jsc - jsg + 1; je = jec - jsg + 1
     do j = js, jec
        do i = is, ie
           lon(i,j) = glon(i)
           lat(i,j) = glat(j)
        enddo
     enddo
     deallocate(glon)
     deallocate(glat)
  case default
     call mpp_error(FATAL, "data_override_mod: mod_name should be 'atm', 'ocn', 'ice' or 'lnd' ")
  end select
 
  ! convert from degree to radian
  lon = lon * deg_to_radian
  lat = lat* deg_to_radian
  min_lon = minval(lon)
  max_lon = maxval(lon)
  call mpp_min(min_lon)
  call mpp_max(max_lon)


end subroutine get_grid_version_1

! Get global lon and lat of three model (target) grids from mosaic.nc
! z1l: currently we assume the refinement ratio is 2 and there is one tile on each pe.
subroutine get_grid_version_2(mosaic_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon)
  character(len=*),            intent(in) :: mosaic_file
  character(len=*),            intent(in) :: mod_name
  type(domain2d),              intent(in) :: domain
  integer,                     intent(in) :: isc, iec, jsc, jec
  real, dimension(isc:,jsc:), intent(out) :: lon, lat
  real,                       intent(out) :: min_lon, max_lon

  integer            :: i, j, siz(4)
  integer            :: nlon, nlat             ! size of global grid
  integer            :: nlon_super, nlat_super ! size of global supergrid.
  integer            :: isd, ied, jsd, jed
  integer            :: isg, ieg, jsg, jeg
  integer            :: isc2, iec2, jsc2, jec2
  character(len=256) :: solo_mosaic_file, grid_file
  real, allocatable  :: tmpx(:,:), tmpy(:,:)
  type(domain2d)     :: domain2

  if(trim(mod_name) .NE. 'atm' .AND. trim(mod_name) .NE. 'ocn' .AND. &
     trim(mod_name) .NE. 'ice' .AND. trim(mod_name) .NE. 'lnd' ) call mpp_error(FATAL, &
        "data_override_mod: mod_name should be 'atm', 'ocn', 'ice' or 'lnd' ")

  call mpp_get_data_domain(domain, isd, ied, jsd, jed)
  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)

  ! get the grid file to read
  if(field_exist(mosaic_file, trim(mod_name)//'_mosaic_file' )) then
     call read_data(mosaic_file, trim(mod_name)//'_mosaic_file', solo_mosaic_file) 
     solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file)
  else
     solo_mosaic_file = mosaic_file
  end if
  call get_mosaic_tile_grid(grid_file, solo_mosaic_file, domain)

  call field_size(grid_file, 'area', siz)
  nlon_super = siz(1); nlat_super = siz(2)
  if( mod(nlon_super,2) .NE. 0) call mpp_error(FATAL,  &
       'data_override_mod: '//trim(mod_name)//' supergrid longitude size can not be divided by 2')
  if( mod(nlat_super,2) .NE. 0) call mpp_error(FATAL,  &
       'data_override_mod: '//trim(mod_name)//' supergrid latitude size can not be divided by 2')
  nlon = nlon_super/2;
  nlat = nlat_super/2;     
  call check_grid_sizes(trim(mod_name)//'_domain  ', domain, nlon, nlat)

  !--- setup the domain for super grid.
  call mpp_copy_domain(domain, domain2)
  call mpp_set_compute_domain(domain2, 2*isc-1, 2*iec+1, 2*jsc-1, 2*jec+1, 2*iec-2*isc+3, 2*jec-2*jsc+3 )
  call mpp_set_data_domain   (domain2, 2*isd-1, 2*ied+1, 2*jsd-1, 2*jed+1, 2*ied-2*isd+3, 2*jed-2*jsd+3 )   
  call mpp_set_global_domain (domain2, 2*isg-1, 2*ieg+1, 2*jsg-1, 2*jeg+1, 2*ieg-2*isg+3, 2*jeg-2*jsg+3 )

  call mpp_get_compute_domain(domain2, isc2, iec2, jsc2, jec2)
  if(isc2 .NE. 2*isc-1 .OR. iec2 .NE. 2*iec+1 .OR. jsc2 .NE. 2*jsc-1 .OR. jec2 .NE. 2*jec+1) then
     call mpp_error(FATAL, 'data_override_mod: '//trim(mod_name)//' supergrid domain is not set properly')
  endif

  allocate(tmpx(isc2:iec2, jsc2:jec2), tmpy(isc2:iec2, jsc2:jec2) )
  call read_data( grid_file, 'x', tmpx, domain2)
  call read_data( grid_file, 'y', tmpy, domain2)     
  ! copy data onto model grid
  if(trim(mod_name) == 'ocn' .OR. trim(mod_name) == 'ice') then
     do j = jsc, jec
        do i = isc, iec
           lon(i,j) = (tmpx(i*2-1,j*2-1)+tmpx(i*2+1,j*2-1)+tmpx(i*2+1,j*2+1)+tmpx(i*2-1,j*2+1))*0.25
           lat(i,j) = (tmpy(i*2-1,j*2-1)+tmpy(i*2+1,j*2-1)+tmpy(i*2+1,j*2+1)+tmpy(i*2-1,j*2+1))*0.25
        end do
     end do
  else
     do j = jsc, jec
        do i = isc, iec
           lon(i,j) = tmpx(i*2,j*2)
           lat(i,j) = tmpy(i*2,j*2)
        end do
     end do
  endif

  ! convert to radian
  lon = lon * deg_to_radian
  lat = lat * deg_to_radian

  deallocate(tmpx, tmpy)
  min_lon = minval(lon)
  max_lon = maxval(lon)
  call mpp_min(min_lon)
  call mpp_max(max_lon)

  call mpp_deallocate_domain(domain2)

end subroutine get_grid_version_2

!===============================================================================================
subroutine get_region_bounds(gridname, is,ie,js,je, region_in, region_out)
! Given gridname and region limits (in lat and lon), this routine returns
! the region's indices (in i and j) determined on global array
! lat values are between (-90, +90), lon values:(0,360)     
! Do not give negative lon
  character(len=3), intent(in) :: gridname ! model grid ID
  integer, intent(in)  :: is,ie,js,je ! comp domain index limits in global space
  real,    intent(in)  :: region_in(4) !(lat_start, lat_end, lon_start, lon_end)
  logical, intent(out), dimension(is:ie,js:je) :: region_out
  real, dimension(:,:), pointer :: lon_local, lat_local
  integer :: i,j
  real :: lat_start, lat_end, lon_start, lon_end
  real :: max_glo_lon, min_glo_lon
  character(len=256) :: error_message

  lat_start = region_in(1)
  lat_end   = region_in(2)
  lon_start = region_in(3)
  lon_end   = region_in(4)

  if(lat_start < -90. .or. lat_end > 90.) then
    error_message = 'data_override: latitude out of range -90 to +90  lat_start=          lat_end=        '
    write(error_message(60:67), '(f8.2)') lat_start
    write(error_message(78:85), '(f8.2)') lat_end
    call mpp_error(FATAL,trim(error_message))
  endif

  if(lat_start > lat_end) then
    error_message = 'data_override: lat_start greater than lat_end. lon_start=          lon_end=        '
    write(error_message(58:65), '(f8.2)') lat_start
    write(error_message(76:83), '(f8.2)') lat_end
    call mpp_error(FATAL,trim(error_message))
  endif

  lat_start = lat_start * deg_to_radian
  lat_end   = lat_end   * deg_to_radian
  lon_start = lon_start * deg_to_radian
  lon_end   = lon_end   * deg_to_radian

  select case(gridname)
  case('OCN')    
     lon_local => lon_local_ocn
     lat_local => lat_local_ocn
     max_glo_lon = max_glo_lon_ocn
     min_glo_lon = min_glo_lon_ocn
  case('ICE')          
     lon_local => lon_local_ocn
     lat_local => lat_local_ocn
     max_glo_lon = max_glo_lon_ice
     min_glo_lon = min_glo_lon_ice
  case('ATM')       
     lon_local => lon_local_atm
     lat_local => lat_local_atm
     max_glo_lon = max_glo_lon_atm
     min_glo_lon = min_glo_lon_atm
  case('LND')          
     lon_local => lon_local_lnd
     lat_local => lat_local_lnd
     max_glo_lon = max_glo_lon_lnd
     min_glo_lon = min_glo_lon_lnd
  case default
     call mpp_error(FATAL,'data_override: grid not recognized.  Grid name='//gridname)
  end select

! Adjust lon_start and lon_end.
! Because longitude is cyclic, the longitude of the grid points could be anything,
! except for the constraint that maxval(lon_global) - minval(lon_global) < 2*PI
! We want to be able to be specify lon_start and lon_end independently of the grid values.
! e.g. If lon_end=270 deg but the grid goes from -180 to +180 then we want to adjust lon_end to -90
! To accomplish this:
! lon_start is adjusted such that lon_start > maxval(lon_global) - 2*PI
! lon_end   is adjusted such that lon_end   < minval(lon_global) + 2*PI

  lon_start = lon_start + (ceiling((max_glo_lon-lon_start)/tpi) - 1)*tpi
  lon_end   = lon_end   + (floor  ((min_glo_lon-lon_end  )/tpi) + 1)*tpi

  do j=js,je
    do i=is,ie
      region_out(i,j) = (lat_local(i,j) > lat_start .and. lat_local(i,j) < lat_end)
      if(lon_end >= lon_start) then
        region_out(i,j) = region_out(i,j) .and. (lon_local(i,j) < lon_end .and. lon_local(i,j) > lon_start)
      else
        region_out(i,j) = region_out(i,j) .and. (lon_local(i,j) < lon_end .or.  lon_local(i,j) > lon_start)
      endif
    enddo
  enddo

end subroutine get_region_bounds
!===============================================================================================
end module data_override_mod

#ifdef test_data_override

 program test

 ! Input data and path_names file for this program is in:
 ! /archive/pjp/unit_tests/test_data_override/lima/exp1

 use           mpp_mod, only: input_nml_file
 use   mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_get_compute_domain, mpp_define_layout
 use           fms_mod, only: fms_init, fms_end, mpp_npes, file_exist, open_namelist_file, check_nml_error, close_file
 use           fms_mod, only: error_mesg, FATAL, file_exist, field_exist, field_size
 use        fms_io_mod, only: read_data, fms_io_exit
 use     constants_mod, only: constants_init, pi
 use  time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), set_time, print_time
 use  diag_manager_mod, only: diag_manager_init, diag_manager_end, register_static_field, register_diag_field
 use  diag_manager_mod, only: send_data, diag_axis_init
 use data_override_mod, only: data_override_init, data_override

 implicit none

 type(domain2d)                    :: Domain
 integer                           :: nlon, nlat, siz(4)
 real, allocatable, dimension(:)   :: x, y
 real, allocatable, dimension(:,:) :: lon, lat
 real, allocatable, dimension(:,:) :: sst, ice
 integer                           :: id_x, id_y, id_lon, id_lat, id_sst, id_ice
 integer                           :: i, j, is, ie, js, je, unit, io, ierr
 real                              :: rad_to_deg
 character(len=36)                 :: message
 type(time_type)                   :: Time
 logical                           :: used, ov_sst, ov_ice
 integer, dimension(2)             :: layout = (/0,0/)
 character(len=256)                :: solo_mosaic_file, tile_file
 character(len=128)                :: grid_file   = "INPUT/grid_spec.nc"

 namelist / test_data_override_nml / layout

 call fms_init
 call constants_init
 call set_calendar_type(NOLEAP)
 call diag_manager_init

 rad_to_deg = 180./pi

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, test_data_override_nml, iostat=io)
#else
 if (file_exist('input.nml')) then
   unit = open_namelist_file ( )
   ierr=1
   do while (ierr /= 0)
     read(unit, nml=test_data_override_nml, iostat=io, end=10)
          ierr = check_nml_error(io, 'test_data_override_nml')
   enddo
10 call close_file (unit)
 endif
#endif

 if(field_exist(grid_file, "x_T" ) ) then
    call field_size(grid_file, 'x_T', siz)
    nlon = siz(1)
    nlat = siz(2)
 else if(field_exist(grid_file, "geolon_t" ) ) then
    call field_size(grid_file, 'geolon_t', siz)
    nlon = siz(1)
    nlat = siz(2)
 else if (field_exist(grid_file, "ocn_mosaic_file" )) then
    call read_data(grid_file, 'ocn_mosaic_file', solo_mosaic_file) 
    solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file)
    call field_size(solo_mosaic_file, 'gridfiles', siz)
    if( siz(2) .NE. 1) call error_mesg('test_data_override', 'only support single tile mosaic, contact developer', FATAL)
    call read_data(solo_mosaic_file, 'gridfiles', tile_file)
    tile_file = 'INPUT/'//trim(tile_file)
    call field_size(tile_file, 'area', siz)
    if(mod(siz(1),2) .NE. 0 .OR. mod(siz(2),2) .NE. 0 ) call error_mesg('test_data_override', &
        "test_data_override: supergrid size can not be divided by 2", FATAL)
    nlon = siz(1)/2
    nlat = siz(2)/2
 else
    call error_mesg('test_data_override', 'x_T, geolon_t and ocn_mosaic_file does not exist', FATAL)
 end if

 if(layout(1)*layout(2) .NE. mpp_npes() ) then
    call mpp_define_layout( (/1,nlon,1,nlat/), mpp_npes(), layout )
 end if


 call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, name='test_data_override')
 call data_override_init(Ice_domain_in=Domain, Ocean_domain_in=Domain)
 call mpp_get_compute_domain(Domain, is, ie, js, je)
 call get_grid

 allocate(x(nlon), y(nlat))

 do i=1,nlon
   x(i) = i
 enddo
 do j=1,nlat
   y(j) = j
 enddo

 Time = set_date(2,1,1,0,0,0)

 allocate(sst(is:ie,js:je), ice(is:ie,js:je))

 id_x  = diag_axis_init('x',  x,  'point_E', 'x', long_name='point_E', Domain2=Domain)
 id_y  = diag_axis_init('y',  y,  'point_N', 'y', long_name='point_N', Domain2=Domain)

 Time = Time + set_time(0,1)

 id_lon = register_static_field('test_data_override_mod', 'lon', (/id_x,id_y/), 'longitude', 'Degrees')
 id_lat = register_static_field('test_data_override_mod', 'lat', (/id_x,id_y/), 'longitude', 'Degrees')
 id_sst = register_diag_field  ('test_data_override_mod', 'sst', (/id_x,id_y/), Time, 'SST', 'K')
 id_ice = register_diag_field  ('test_data_override_mod', 'ice', (/id_x,id_y/), Time, 'ICE', ' ')
 used = send_data(id_lon, lon, Time)
 used = send_data(id_lat, lat, Time)

 sst = 0.
 ice = 0.

!call data_override('OCN','sst_obs',sst,Time,override=ov_sst, region1=(/-45., 45.,-190., -10./)) ! lima crashes.                    lima_pjp works
!call data_override('OCN','sst_obs',sst,Time,override=ov_sst, region1=(/-45., 45.,  90., 270./)) ! lima crashes with error message. lima_pjp works
!call data_override('OCN','sst_obs',sst,Time,override=ov_sst, region1=(/-45., 45., -10.,-190./)) ! lima does no override.           lima_pjp works
!call data_override('OCN','sst_obs',sst,Time,override=ov_sst, region1=(/ 65., 90.,-190., -10./)) ! lima crashes with error message. lima_pjp works
 call data_override('OCN','sst_obs',sst,Time,override=ov_sst, region1=(/ 72., 90.,-230.,  30./)) ! lima not tested.                 lima_pjp works
!call data_override('OCN','sst_obs',sst,Time,override=ov_sst, region1=(/-45., 45.,-190., -10./))
!call data_override('OCN','sst_obs',sst,Time,override=ov_sst)
 call data_override('ICE', 'sic_obs', ice, Time, override=ov_ice)

 if(.not.ov_sst .or. .not.ov_ice) then
   if(ov_sst) then
     message = 'override failed for ice'
   else if(ov_ice) then
     message = 'override failed for sst'
   else
     message = 'override failed for both sst and ice'
   endif
   call error_mesg('test_data_override', trim(message), FATAL)
 endif

 if(id_sst > 0) used = send_data(id_sst, sst, Time)
 if(id_ice > 0) used = send_data(id_ice, ice, Time)

!-------------------------------------------------------------------------------------------------------
! All the tests above are tests of regional override.
! What follows is a test of calendar conversion
 
!Time = set_date(1980,2,27,0,0,0)
!call print_time(Time)
!call data_override('OCN','sst_obs',sst,Time)
!if(id_sst > 0) used = send_data(id_sst, sst, Time)
 
!Time = set_date(1980,2,28,0,0,0)
!call print_time(Time)
!call data_override('OCN','sst_obs',sst,Time)
!if(id_sst > 0) used = send_data(id_sst, sst, Time)
 
!Time = set_date(1980,2,29,0,0,0)
!call print_time(Time)
!call data_override('OCN','sst_obs',sst,Time)
!if(id_sst > 0) used = send_data(id_sst, sst, Time)
 
!Time = set_date(1980,3,1,0,0,0)
!call print_time(Time)
!call data_override('OCN','sst_obs',sst,Time)
!if(id_sst > 0) used = send_data(id_sst, sst, Time)
 
!Time = set_date(1980,3,2,0,0,0)
!call print_time(Time)
!call data_override('OCN','sst_obs',sst,Time)
!if(id_sst > 0) used = send_data(id_sst, sst, Time)
!-------------------------------------------------------------------------------------------------------

 call diag_manager_end(Time)
 call fms_io_exit
 call fms_end

 contains
!=================================================================================================================================
 subroutine get_grid
   real, allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo
   real, allocatable, dimension(:,:)   :: lon_global, lat_global
   integer, dimension(4)  :: siz
   character(len=128) :: message


   if(field_exist(grid_file, 'x_T')) then
      call field_size(grid_file, 'x_T', siz)
      if(siz(1) /= nlon .or. siz(2) /= nlat) then
         write(message,'(a,2i4)') 'x_T is wrong shape. shape(x_T)=',siz(1:2)
         call error_mesg('test_data_override', trim(message), FATAL)
      endif
      allocate(lon_vert_glo(nlon,nlat,4), lat_vert_glo(nlon,nlat,4) )
      allocate(lon_global  (nlon,nlat  ), lat_global  (nlon,nlat  ) )
      call read_data(trim(grid_file), 'x_vert_T', lon_vert_glo, no_domain=.true.)
      call read_data(trim(grid_file), 'y_vert_T', lat_vert_glo, no_domain=.true.)
      lon_global(:,:)  = (lon_vert_glo(:,:,1) + lon_vert_glo(:,:,2) + lon_vert_glo(:,:,3) + lon_vert_glo(:,:,4))*0.25
      lat_global(:,:) =  (lat_vert_glo(:,:,1) + lat_vert_glo(:,:,2) + lat_vert_glo(:,:,3) + lat_vert_glo(:,:,4))*0.25
   else  if(field_exist(grid_file, "geolon_t" ) ) then
      call field_size(grid_file, 'geolon_vert_t', siz)
      if(siz(1) /= nlon+1 .or. siz(2) /= nlat+1) then
         write(message,'(a,2i4)') 'geolon_vert_t is wrong shape. shape(geolon_vert_t)=',siz(1:2)
         call error_mesg('test_data_override', trim(message), FATAL)
      endif
      allocate(lon_vert_glo(nlon+1,nlat+1,1), lat_vert_glo(nlon+1,nlat+1,1))
      allocate(lon_global  (nlon,  nlat    ), lat_global  (nlon,  nlat    ))
      call read_data(trim(grid_file), 'geolon_vert_t', lon_vert_glo, no_domain=.true.)
      call read_data(trim(grid_file), 'geolat_vert_t', lat_vert_glo, no_domain=.true.)

      do i = 1, nlon
         do j = 1, nlat
            lon_global(i,j) = (lon_vert_glo(i,j,1) + lon_vert_glo(i+1,j,1) + &
                 lon_vert_glo(i+1,j+1,1) + lon_vert_glo(i,j+1,1))*0.25
            lat_global(i,j) = (lat_vert_glo(i,j,1) + lat_vert_glo(i+1,j,1) + &
                 lat_vert_glo(i+1,j+1,1) + lat_vert_glo(i,j+1,1))*0.25
         enddo
      enddo
   else if( field_exist(grid_file, "ocn_mosaic_file") ) then ! reading from mosaic file
      call field_size(tile_file, 'area', siz)
      if(siz(1) /= nlon*2 .or. siz(2) /= nlat*2) then
         write(message,'(a,2i4)') 'area is wrong shape. shape(area)=',siz(1:2)
         call error_mesg('test_data_override', trim(message), FATAL)
      endif
      allocate(lon_vert_glo(siz(1)+1,siz(2)+1,1), lat_vert_glo(siz(1)+1,siz(2)+1,1))
      allocate(lon_global  (nlon,  nlat    ), lat_global  (nlon,  nlat    ))
      call read_data( tile_file, 'x', lon_vert_glo, no_domain=.true.)
      call read_data( tile_file, 'y', lat_vert_glo, no_domain=.true.)  
      do j = 1, nlat
         do i = 1, nlon
            lon_global(i,j) = lon_vert_glo(i*2,j*2,1)
            lat_global(i,j) = lat_vert_glo(i*2,j*2,1)
         end do
      end do
   end if

  allocate(lon(is:ie,js:je), lat(is:ie,js:je))
  lon = lon_global(is:ie,js:je)
  lat = lat_global(is:ie,js:je)

  deallocate(lon_vert_glo)
  deallocate(lat_vert_glo)
  deallocate(lon_global)
  deallocate(lat_global)

 end subroutine get_grid
!=================================================================================================================================
 end program test
#endif


MODULE diag_axis_mod
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>

  ! <OVERVIEW> <TT>diag_axis_mod</TT> is an integral part 
  !   of diag_manager_mod. It helps to create axis IDs 
  !   that are used in register_diag_field.  
  ! </OVERVIEW>

  ! <DESCRIPTION> Users first create axis ID by calling
  !   diag_axis_init, then use this axis ID in 
  !   register_diag_field.
  ! </DESCRIPTION>

  USE mpp_domains_mod, ONLY: domain1d, domain2d, mpp_get_compute_domain&
       &, mpp_get_domain_components, null_domain1d, null_domain2d,&
       & OPERATOR(.NE.), mpp_get_global_domain, mpp_get_domain_name
  USE fms_mod, ONLY: error_mesg, write_version_number, lowercase, uppercase, FATAL
  USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,&
       & max_num_axis_sets

  IMPLICIT NONE

  PRIVATE
  PUBLIC  diag_axis_init, get_diag_axis, get_domain1d, get_domain2d,&
       & get_axis_length, get_axis_global_length, diag_subaxes_init,&
       & get_diag_axis_cart, get_diag_axis_data, max_axes, get_axis_aux,&
       & get_tile_count, get_axes_shift, get_diag_axis_name,&
       & get_axis_num, get_diag_axis_domain_name


  ! Module variables

  ! counter of number of axes defined
  INTEGER, DIMENSION(:), ALLOCATABLE :: num_subaxes
  INTEGER :: num_def_axes = 0

  ! storage for axis set names
  CHARACTER(len=128), DIMENSION(:), ALLOCATABLE, SAVE :: Axis_sets
  INTEGER :: num_axis_sets = 0

  ! ---- global storage for all defined axes ----
  TYPE(diag_axis_type), ALLOCATABLE, SAVE :: Axes(:)
  LOGICAL :: module_is_initialized = .FALSE.
  CHARACTER(len=128) :: version =&
       & '$Id: diag_axis.F90,v 18.0.2.1 2010/03/03 14:05:46 sdu Exp $'
  CHARACTER(len=128) :: tagname =&
       & '$Name: hiram_20101115_bw $'

CONTAINS

  ! <FUNCTION NAME="diag_axis_init">
  !   <OVERVIEW>
  !     Initialize the axis, and return the axis ID.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION diag_axis_init(name, data, units, cart_name, long_name,
  !           direction, set_name, edges, Domain, Domain2, aux, tile_count)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>diag_axis_init</TT> initializes an axis and returns the axis ID that
  !     is to be used with <TT>register_diag_field</TT>.  This function also
  !     increments the axis counter and fills in the axes
  !   </DESCRIPTION>
  !   <IN NAME="name" TYPE="CHARACTER(len=*)">Short name for axis</IN>
  !   <IN NAME="data" TYPE="REAL, DIMENSION(:)">Array of coordinate values</IN>
  !   <IN NAME="units" TYPE="CHARACTER(len=*)">Units for the axis</IN>
  !   <IN NAME="cart_name" TYPE="CHARACTER(len=*)">
  !     Cartesian axis ("X", "Y", "Z", "T")
  !   </IN>
  !   <IN NAME="direction" TYPE="INTEGER, OPTIONAL" DEFAULT="0">
  !     Indicates the direction of the axis:
  !     <UL>
  !       <LI>Up if +1</LI>
  !       <LI>Down if -1</LI>
  !       <LI>Neither up or down if 0</LI>
  !     </UL>
  !   </IN>
  !   <IN NAME="long_name" TYPE="CHARACTER(len=*), OPTIONAL" DEFAULT="name">
  !     Long name for the axis.
  !   </IN>
  !   <IN NAME="edges" TYPE="INTEGER, OPTIONAL">
  !     Axis ID for the previously defined "edges axis"
  !   </IN>
  !   <IN NAME="Domain" TYPE="TYPE(domain1d), OPTIONAL" />
  !   <IN NAME="Domain2" TYPE="TYPE(domain2d), OPTIONAL" />
  !   <IN NAME="aux" TYPE="CHARACTER(len=*), OPTIONAL">
  !     Auxiliary name, can only be <TT>geolon_t</TT> or <TT>geolat_t</TT>
  !   </IN>
  !   <IN NAME="tile_count" TYPE="INTEGER, OPTIONAL" />
  FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, direction,&
       & set_name, edges, Domain, Domain2, aux, tile_count) RESULT (indexx)
    CHARACTER(len=*), INTENT(in) :: name
    REAL, DIMENSION(:), INTENT(in) :: DATA
    CHARACTER(len=*), INTENT(in) :: units
    CHARACTER(len=*), INTENT(in) :: cart_name  
    CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name, set_name
    INTEGER, INTENT(in), OPTIONAL :: direction, edges
    TYPE(domain1d), INTENT(in), OPTIONAL :: Domain
    TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2
    CHARACTER(len=*), INTENT(in), OPTIONAL :: aux
    INTEGER, INTENT(in), OPTIONAL :: tile_count

    TYPE(domain1d) :: domain_x, domain_y
    INTEGER :: indexx, ierr, axlen
    INTEGER :: i, set, tile
    INTEGER :: isc, iec, isg, ieg
    CHARACTER(len=128) :: errmsg

    IF ( .NOT.module_is_initialized ) THEN
       CALL write_version_number( version, tagname )
    ENDIF

    IF ( PRESENT(tile_count)) THEN
       tile = tile_count
    ELSE
       tile = 1
    END IF
    
    ! Allocate the axes
    IF (.NOT. ALLOCATED(Axis_sets)) ALLOCATE(Axis_sets(max_num_axis_sets))
    IF (.NOT. ALLOCATED(Axes)) ALLOCATE(Axes(max_axes))
    IF (.NOT. ALLOCATED(num_subaxes)) THEN
       ALLOCATE(num_subaxes(max_axes))
       num_subaxes = 0
    END IF

    !---- is there an axis set? ----
    IF ( PRESENT(set_name) ) THEN
       set = get_axis_set_num (set_name)
       !---- add new set name ----
       IF (set == 0) THEN
          num_axis_sets = num_axis_sets + 1
          IF ( num_axis_sets > max_num_axis_sets ) THEN
             WRITE (errmsg, FMT='("num_axis_sets (",I2,") exceeds max_num_axis_sets (",I2,"). ")') num_axis_sets, max_num_axis_sets
             ! <ERROR STATUS="FATAL">
             !   num_axis_sets (<num_axis_sets>) exceeds max_num_axis_sets(<num_axis_sets>).
             !   Increase max_num_axis_sets via diag_manager_nml.
             ! </ERROR>
             CALL error_mesg('diag_axis_mod :: diag_axis_init',  &
                  TRIM(errmsg)//'  Increase max_num_axis_sets via diag_manager_nml.', FATAL)
          END IF
          set = num_axis_sets
          Axis_sets(set) = set_name
       END IF
    ELSE
       set = 0
    END IF

    !---- see if axis already exists --
    ! if this is time axis, return the ID of a previously defined
    ! if this is spatial axis, FATAL error
    DO i = 1, num_def_axes
       IF ( TRIM(name) == Axes(i)%name ) THEN
          IF ( TRIM(name) == 'Stations' .OR. TRIM(name) == 'Levels') THEN
             indexx = i
             RETURN
          ELSE IF ( set == Axes(i)%set ) THEN
             IF ( TRIM(lowercase(name)) == 'time' .OR.&
                  & TRIM(lowercase(cart_name)) == 't' .OR.&
                  & TRIM(lowercase(name)) == 'nv' .OR.&
                  & TRIM(lowercase(cart_name)) == 'n' ) THEN
                indexx = i
                RETURN
             ELSE IF ( (lowercase(cart_name) /= 'x' .AND. lowercase(cart_name) /= 'y')&
                  & .OR. tile /= Axes(i)%tile_count) THEN
                ! <ERROR STATUS="FATAL">axis_name <NAME> and axis_set already exist.</ERROR>
                CALL error_mesg('diag_axis_mod :: diag_axis_init',&
                     & 'axis_name '//TRIM(name)//' and axis_set already exist.', FATAL)
             END IF
          END IF
       END IF
    END DO
    
    !---- register axis ----
    num_def_axes = num_def_axes + 1
    ! <ERROR STATUS="FATAL">max_axes exceeded, increase it via diag_manager_nml</ERROR>
    IF (num_def_axes > max_axes) CALL error_mesg ('diag_axis_init in&
         & diag_axis_mod', 'max_axes exceeded, increase it via&
         & diag_manager_nml', FATAL)
    indexx = num_def_axes

    !---- check and then save cart_name name ----
    IF ( TRIM(uppercase(cart_name)) == 'X' .OR.&
         & TRIM(uppercase(cart_name)) == 'Y' .OR.&
         & TRIM(uppercase(cart_name)) == 'Z' .OR.&
         & TRIM(uppercase(cart_name)) == 'T' .OR.&
         & TRIM(uppercase(cart_name)) == 'N' ) THEN
       Axes(indexx)%cart_name = TRIM(uppercase(cart_name))
    ELSE     
       ! <ERROR STATUS="FATAL">Invalid cart_name name.</ERROR>
       CALL error_mesg('diag_axis_mod :: diag_axis_init', 'Invalid cart_name name.', FATAL)
    END IF

    !---- allocate storage for coordinate values of axis ----
    IF ( Axes(indexx)%cart_name == 'T' ) THEN 
       axlen = 0
    ELSE
       axlen = SIZE(data(:))
    END IF
    ALLOCATE ( Axes(indexx)%data(1:axlen) )

    ! Initialize Axes(indexx)
    Axes(indexx)%name   = TRIM(name)
    Axes(indexx)%data   = data(1:axlen)
    Axes(indexx)%units  = units  
    Axes(indexx)%length = axlen
    Axes(indexx)%set    = set
    ! start and end are used in subaxes information only
    Axes(indexx)%start = -1
    Axes(indexx)%end = -1
    Axes(indexx)%subaxis_name = ""
    Axes(indexx)%shift = 0

    IF ( PRESENT(long_name) ) THEN
       Axes(indexx)%long_name = long_name
    ELSE
       Axes(indexx)%long_name = name
    END IF

    IF ( PRESENT(aux) ) THEN
       Axes(indexx)%aux = TRIM(aux)
    ELSE
       Axes(indexx)%aux = 'none'
    END IF
 
    !---- axis direction (-1, 0, or +1) ----
    IF ( PRESENT(direction) )THEN
       IF ( ABS(direction) /= 1 .AND. direction /= 0 )&
            ! <ERROR STATUS="FATAL">direction must be 0, +1, or -1</ERROR>
            & CALL error_mesg('diag_axis_mod :: diag_axis_init',&
            & 'direction must be 0, +1 or -1',FATAL)
       Axes(indexx)%direction = direction
    ELSE
       Axes(indexx)%direction = 0
    END IF

    !---- domain2d type ----
    IF ( PRESENT(Domain2) .AND. PRESENT(Domain)) THEN
       ! <ERROR STATUS="FATAL">Presence of both Domain and Domain2 at the same time is prohibited</ERROR>
       CALL error_mesg('diag_axis_mod :: diag_axis_init', &
            'Presence of both Domain and Domain2 at the same time is prohibited', &
            FATAL)
    ELSE IF ( PRESENT(Domain2) .OR. PRESENT(Domain)) THEN
       IF ( Axes(indexx)%cart_name /= 'X' .AND. Axes(indexx)%cart_name /= 'Y') THEN
          ! <ERROR STATUS="FATAL">Domain must not be present for an axis which is not in the X or Y direction.</ERROR>
          CALL error_mesg('diag_axis_mod :: diag_axis_init', &
               'Domain must not be present for an axis which is not in the X or Y direction', &
               FATAL)
       END IF
    END IF

    Axes(indexx)%tile_count = tile

    IF ( PRESENT(Domain2) ) THEN
       Axes(indexx)%Domain2 = Domain2
       CALL mpp_get_domain_components(Domain2, domain_x, domain_y, tile_count=tile_count)
       IF ( Axes(indexx)%cart_name == 'X' ) Axes(indexx)%Domain = domain_x
       IF ( Axes(indexx)%cart_name == 'Y' ) Axes(indexx)%Domain = domain_y
    ELSE IF ( PRESENT(Domain)) THEN
       !---- domain1d type ----     
       Axes(indexx)%Domain2 = null_domain2d ! needed since not 2-D domain
       Axes(indexx)%Domain = Domain
    ELSE
       Axes(indexx)%Domain2 = null_domain2d 
       Axes(indexx)%Domain = null_domain1d
    END IF


    !--- set up the shift value for x-y axis
    IF ( Axes(indexx)%Domain .NE. null_domain1d ) THEN
       CALL mpp_get_compute_domain(Axes(indexx)%Domain, isc, iec)
       CALL mpp_get_global_domain(Axes(indexx)%Domain, isg, ieg)
       IF ( Axes(indexx)%length == ieg - isg + 2 ) THEN
          Axes(indexx)%shift = 1 
       END IF
    END IF

    !---- have axis edges been defined ? ----
    Axes(indexx)%edges = 0
    IF (PRESENT(edges) ) THEN
       IF ( edges > 0 .AND. edges < num_def_axes ) THEN
          ierr=0
          IF ( Axes(edges)%cart_name /= Axes(indexx)%cart_name) ierr=1
          IF ( Axes(edges)%length    /= Axes(indexx)%length+1 ) ierr=ierr+2
          IF ( Axes(edges)%set       /= Axes(indexx)%set      ) ierr=ierr+4
          IF ( ierr > 0 )   THEN 
             ! <ERROR STATUS="FATAL">Edges axis does not match axis (code <CODE>).</ERROR>
             WRITE (errmsg,'("Edges axis does not match axis (code ",I1,").")') ierr
             CALL error_mesg ('diag_axis_mod :: diag_axis_init', errmsg, FATAL)
          END IF
          Axes(indexx)%edges = edges
       ELSE
          ! <ERROR STATUS="FATAL">Edges axis is not defined.</ERROR>
          CALL error_mesg ('diag_axis_mod :: diag_axis_init', &
               'Edges axis is not defined', FATAL)
       END IF
    END IF

    ! Module is now initialized
    module_is_initialized = .TRUE.

  END FUNCTION diag_axis_init
  ! </FUNCTION>

  ! <FUNCTION NAME="diag_subaxes_init">
  !   <OVERVIEW>
  !     Create a subaxis on a parent axis.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION diag_subaxes_init(axis, subdata, start_indx, end_indx,
  !           domain_1d, domain_2d)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given the ID of a parent axis, create a subaxis and fill it with data,
  !     and return the ID of the corresponding subaxis.
  !     
  !     The subaxis is defined on the parent axis from <TT>start_indx</TT>
  !     to <TT>end_indx</TT>.
  !   </DESCRIPTION>
  !   <IN NAME="axis" TYPE="INTEGER">ID of the parent axis</IN>
  !   <IN NAME="subdata" TYPE="REAL, DIMENSION(:)">Data of the subaxis</IN>
  !   <IN NAME="start_indx" TYPE="INTEGER">Start index of the subaxis</IN>
  !   <IN NAME="end_indx" TYPE="INTEGER">End index of the subaxis</IN>
  !   <IN NAME="domain_1d" TYPE="TYPE(domain1d), OPTIONAL" />
  !   <IN NAME="domain_2d" TYPE="TYPE(domain2d), OPTIONAL" />
  FUNCTION diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2d)  RESULT(index)
    INTEGER, INTENT(in) :: axis
    REAL, DIMENSION(:), INTENT(in) :: subdata
    INTEGER, INTENT(in) :: start_indx
    INTEGER, INTENT(in) :: end_indx 
    TYPE(domain2d), INTENT(in), OPTIONAL  :: domain_2d

    INTEGER :: index
    INTEGER :: i, nsub_axis, direction
    CHARACTER(len=128) :: name, nsub_name   
    CHARACTER(len=128) :: units
    CHARACTER(len=128) :: cart_name
    CHARACTER(len=128) :: long_name
    CHARACTER(len=128) :: errmsg
    LOGICAL :: subaxis_set 

! there may be more than 1 subaxis on a parent axis, check for redundancy
    nsub_axis = 0
    subaxis_set = .FALSE.
    sa_search: DO i = 1, num_subaxes(axis)
       IF ( start_indx == Axes(axis)%start(i) .AND. end_indx == Axes(axis)%end(i) ) THEN
          nsub_axis = i
          subaxis_set = .TRUE.    !subaxis already exists
          name = TRIM(Axes(axis)%subaxis_name(nsub_axis))
          EXIT sa_search
       END IF
    END DO sa_search

    IF ( nsub_axis == 0 ) THEN  ! create new subaxis
       num_subaxes(axis) = num_subaxes(axis) + 1
       IF (num_subaxes(axis) > max_subaxes) THEN
          ! <ERROR STATUS="FATAL">max_subaxes (value <VALUE>) is too small.  Consider increasing max_subaxes.</ERROR>
          WRITE (errmsg,'("max_subaxes (value ",I4,") is too small.  Consider increasing max_subaxes.")') max_subaxes
          CALL error_mesg ('diag_subaxes_init in diag_axis_mod',errmsg, FATAL)
       END IF
       nsub_axis = num_subaxes(axis)
       Axes(axis)%start(nsub_axis) = start_indx
       Axes(axis)%end(nsub_axis)   = end_indx
    END IF
  
    ! Create new name for the subaxis from name of parent axis
    ! If subaxis already exists, get the index and return       
    IF(subaxis_set) THEN
       IF ( Axes(axis)%set > 0 ) THEN
          index = get_axis_num(name, set_name=TRIM(Axis_sets(Axes(axis)%set)))     
       ELSE
          index = get_axis_num(name)    
       END IF
    ELSE
       ! get a new index for subaxis
       !::sdu:: Need a check to allow larger numbers in the index number.
       WRITE (nsub_name,'(I2.2)') nsub_axis
       name = TRIM(Axes(axis)%name)//'_sub'//TRIM(nsub_name)
       Axes(axis)%subaxis_name(nsub_axis) = name
       long_name = TRIM(Axes(axis)%long_name)
       units = TRIM(Axes(axis)%units)
       cart_name = TRIM(Axes(axis)%cart_name)
       direction = Axes(axis)%direction
       IF (Axes(axis)%set > 0) THEN
          index =  diag_axis_init (TRIM(name), subdata, TRIM(units), TRIM(cart_name), TRIM(long_name), &
               set_name=TRIM(Axis_sets(Axes(axis)%set)), direction=direction, Domain2=domain_2d)
       ELSE
          index =  diag_axis_init (TRIM(name), subdata, TRIM(units), TRIM(cart_name), TRIM(long_name), &
               direction=direction, Domain2=domain_2d)
       END IF
    END IF
  END FUNCTION diag_subaxes_init
  ! </FUNCTION>
         
  ! <SUBROUTINE NAME="get_diag_axis">
  !   <OVERVIEW>
  !     Return information about the axis with index ID
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,
  !          direction, edges, Domain, data)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return information about the axis with index ID
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  !   <OUT NAME="name" TYPE="CHARACTER(len=*)">Short name for axis</OUT>
  !   <OUT NAME="units" TYPE="CHARACTER(len=*)">Units for axis</OUT>
  !   <OUT NAME="long_name" TYPE="CHARACTER(len=*)">Long name for axis</OUT>
  !   <OUT NAME="cart_name" TYPE="CHARACTER(len=*)">
  !     Cartesian axis ("x", "y", "z", "t").
  !   </OUT>
  !   <OUT NAME="direction" TYPE="INTEGER">
  !     Direction of data. (See <TT>diag_axis_init</TT> for a description of
  !     allowed values)
  !   </OUT>
  !   <OUT NAME="edges" TYPE="INTEGER">
  !     Axis ID for the previously defined "edges axis".
  !   </OUT>
  !   <OUT NAME="Domain" TYPE="TYPE(domain1d)" />
  !   <OUT NAME="data" TYPE="REAL, DIMENSION(:)">
  !     Array of coordinate values for this axis.
  !   </OUT>
  SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,&
       & direction, edges, Domain, data)
    CHARACTER(len=*), INTENT(out) :: name, units, long_name, cart_name
    INTEGER, INTENT(in) :: id
    TYPE(domain1d), INTENT(out) :: Domain
    INTEGER, INTENT(out) :: direction, edges
    REAL, DIMENSION(:), INTENT(out) :: DATA
    CHARACTER(len=128) :: error_msg

    IF ( id < 1 .OR. id > num_def_axes ) THEN
       ! <ERROR STATUS="FATAL">Illegal value for axis_id used (value <VALUE>).</ERROR>
       WRITE(error_msg,'(i2)')id
       CALL error_mesg('get_diag_axis in diag_axis_mod', &
            'Illegal value for axis_id used (value '//TRIM(error_msg)//').', FATAL)
    END IF
    name      = Axes(id)%name
    units     = Axes(id)%units
    long_name = Axes(id)%long_name
    cart_name = Axes(id)%cart_name
    direction = Axes(id)%direction
    edges     = Axes(id)%edges
    Domain    = Axes(id)%Domain
    IF ( Axes(id)%length > SIZE(data(:)) ) THEN 
       ! <ERROR STATUS="FATAL">array data is too small.</ERROR>
       CALL error_mesg ('get_diag_axis in diag_axis_mod', 'array data is too small', FATAL)
    ELSE
       data(1:Axes(id)%length) = Axes(id)%data
    END IF
  END SUBROUTINE get_diag_axis
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="get_diag_axis_cart">
  !   <OVERVIEW>
  !     Return the axis cartesian.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_diag_axis_cart(id, cart_name)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the axis cartesian ('X', 'Y', 'Z' or 'T') for the axis ID given.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  !   <OUT NAME="cart_name" TYPE="CHARACTER(len=*)">Cartesian axis</OUT>
  SUBROUTINE get_diag_axis_cart(id, cart_name)
    CHARACTER(len=*), INTENT(out) :: cart_name
    INTEGER, INTENT(in)           :: id

    cart_name = Axes(id)%cart_name
  END SUBROUTINE get_diag_axis_cart
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="get_diag_axis_data">
  !   <OVERVIEW>
  !     Return the axis data.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_diag_axis_data(id, data)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the axis data for the axis ID given.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  !   <OUT NAME="data" TYPE="REAL, DIMENSION(:)">Axis data</OUT>
  SUBROUTINE get_diag_axis_data(id, DATA)
    INTEGER, INTENT(in) :: id
    REAL, DIMENSION(:), INTENT(out) :: DATA

    IF (Axes(id)%length > SIZE(data(:))) THEN 
       ! <ERROR STATUS="FATAL">array data is too small</ERROR>
       CALL error_mesg ('get_diag_axis_data in diag_axis_mod', 'array data is too small', FATAL)
    ELSE
       data(1:Axes(id)%length) = Axes(id)%data
    END IF
  END SUBROUTINE get_diag_axis_data
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="get_diag_axis_name">
  !   <OVERVIEW>
  !     Return the short name of the axis.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_diag_axis_name (id, name)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the short name for the axis ID given.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  !   <OUT NAME="name" TYPE="CHARACTER(len=*)">Axis short name</OUT>
  SUBROUTINE get_diag_axis_name (id, name)
    INTEGER         , INTENT(in)  :: id
    CHARACTER(len=*), INTENT(out) :: name

    CHARACTER(len=128) :: error_msg

    IF (id < 1 .OR. id > num_def_axes) THEN
       ! <ERROR STATUS="FATAL">Illegal value for axis used (value <VALUE>).</ERROR>
       WRITE(error_msg,'(i2)')id
       CALL error_mesg('get_diag_axis_name in diag_axis_mod', &
            'Illegal value for axis_id used (value '//TRIM(error_msg)//').', FATAL)
    ELSE
       name = Axes(id)%name
    END IF
  END SUBROUTINE get_diag_axis_name
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="get_diag_axis_domain_name">
  !   <OVERVIEW>
  !     Return the name of the axis' domain
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_diag_axis_domain_name(id, name)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Retruns the name of the axis' domain.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  !   <OUT NAME="name" TYPE="CHARACTER(len=*)">Axis' domain name</OUT>
  SUBROUTINE get_diag_axis_domain_name(id, name)
    INTEGER, INTENT(in) :: id
    CHARACTER(len=*), INTENT(out) :: name

    CHARACTER(len=128) :: error_msg

    IF (id <1 .OR. id > num_def_axes) THEN
       ! <ERROR STATUS="FATAL">
       !   Illegal value for axis used (value <VALUE>).
       ! </ERROR>
       WRITE (error_msg, '(I2)') id
       CALL error_mesg('get_diag_axis_domain_name::diag_axis_mod',&
            & 'Illegal value for axis_id used (value '&
            &//TRIM(error_msg)//').', FATAL)
    END IF
    name = mpp_get_domain_name(Axes(id)%domain2)
  END SUBROUTINE get_diag_axis_domain_name
  ! </SUBROUTINE>

  ! <FUNCTION NAME="get_axis_length">
  !   <OVERVIEW>
  !     Return the length of the axis.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_axis_length(id)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the length of the axis ID given.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  INTEGER FUNCTION get_axis_length(id)
    INTEGER, INTENT(in) :: id

    INTEGER :: length   

    IF ( Axes(id)%Domain .NE. null_domain1d ) THEN
       CALL mpp_get_compute_domain(Axes(id)%Domain,size=length)
       !---one extra point is needed for some case. ( like symmetry domain )
       get_axis_length = length + Axes(id)%shift
    ELSE
       get_axis_length = Axes(id)%length
    END IF
  END FUNCTION get_axis_length
  ! </FUNCTION>

  ! <FUNCTION NAME="get_axis_aux">
  !   <OVERVIEW>
  !     Return the auxiliary name for the axis.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     CHARACTER(LEN=128) FUNCTION get_axis_aux(id)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Returns the auxiliary name for the axis.  The only possible values for
  !     the auxiliary names is <TT>geolon_t</TT> or <TT>geolat_t</TT>.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  FUNCTION get_axis_aux (id) RESULT (aux)
    INTEGER, INTENT(in) :: id
    CHARACTER(len=128) :: aux

    aux =  Axes(id)%aux
  END FUNCTION get_axis_aux
  ! </FUNCTION>

  ! <FUNCTION NAME="get_axis_global_length">
  !   <OVERVIEW>
  !     Return the global length of the axis.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_axis_global_length (id)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Returns the global length of the axis ID given.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  FUNCTION get_axis_global_length(id) RESULT (length)
    INTEGER, INTENT(in) :: id
    INTEGER :: length

    length = Axes(id)%length
  END FUNCTION get_axis_global_length
  ! </FUNCTION>

  ! <FUNCTION NAME="get_tile_count">
  !   <OVERVIEW>
  !     Return the tile count for the axis.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_tile_count (ids)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the tile count for the axis IDs given.
  !   </DESCRIPTION>
  !   <IN NAME="ids" TYPE="INTEGER, DIMENSION(:)">
  !     Axis IDs.  Possible dimensions: 1 <= <TT>size(ids(:))</TT> <= 4.
  !   </IN>
  FUNCTION get_tile_count(ids) RESULT (tile_count)
    INTEGER, DIMENSION(:), INTENT(in) :: ids

    INTEGER :: tile_count
    INTEGER :: i, id, flag

    IF ( SIZE(ids(:)) < 1 ) THEN 
       ! <ERROR STATUS="FATAL">input argument has incorrect size.</ERROR>
       CALL error_mesg ('get_tile_count in diag_axis_mod', 'input argument has incorrect size', FATAL)
    END IF
    tile_count = 1
    flag = 0
    DO i = 1, SIZE(ids(:))
       id = ids(i)
       IF ( Axes(id)%cart_name == 'X' .OR.  &
            Axes(id)%cart_name == 'Y' ) flag = flag + 1
       !     --- both x/y axes found ---
       IF ( flag == 2 ) THEN
          tile_count = Axes(id)%tile_count
          EXIT
       END IF
    END DO
  END FUNCTION get_tile_count
  ! </FUNCTION>

  ! <FUNCTION NAME="get_domain1d">
  !   <OVERVIEW>
  !     Return the 1D domain.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(domain1d) FUNCTION get_domain1d (id)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Retrun the 1D domain for the axis ID given.
  !   </DESCRIPTION>
  !   <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
  FUNCTION get_domain1d(id) RESULT (Domain1)
    INTEGER, INTENT(in) :: id

    TYPE(domain1d) :: Domain1   
    IF (Axes(id)%Domain .NE. NULL_DOMAIN1D) THEN
       Domain1 = Axes(id)%Domain
    ELSE
       Domain1 = NULL_DOMAIN1D
    ENDIF
  END FUNCTION get_domain1d
  ! </FUNCTION>

  ! <FUNCTION NAME="get_domain2d">
  !   <OVERVIEW>
  !     Return the 2D domain.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(domain2d) FUNCTION get_domain2d (ids)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the 2D domain for the axis IDs given.
  !   </DESCRIPTION>
  !   <IN NAME="ids" TYPE="INTEGER, DIMENSION(:)">
  !     Axis IDs.  Possible dimensions: 1 <= <TT>size(ids(:))</TT> <= 4.
  !   </IN>
  FUNCTION get_domain2d(ids) RESULT (Domain2)
    INTEGER, DIMENSION(:), INTENT(in) :: ids

    TYPE(domain2d) :: Domain2
    INTEGER :: i, id, flag

    IF ( SIZE(ids(:)) < 1 ) THEN 
       ! <ERROR STATUS="FATAL">input argument has incorrect size.</ERROR>
       CALL error_mesg ('get_domain2d in diag_axis_mod', 'input argument has incorrect size', FATAL)
    END IF
    Domain2 = null_domain2d
    flag = 0
    DO i = 1, SIZE(ids(:))
       id = ids(i)
       IF ( Axes(id)%cart_name == 'X' .OR. Axes(id)%cart_name == 'Y' ) flag = flag + 1
       !     --- both x/y axes found ---
       IF ( flag == 2 ) THEN
          IF (Axes(id)%Domain2 .NE. NULL_DOMAIN2D) Domain2 = Axes(id)%Domain2
          EXIT
       END IF
    END DO
  END FUNCTION get_domain2d
  ! </FUNCTION>

  ! <SUBROUTINE NAME="get_axes_shift">
  !   <OVERVIEW>
  !     Return the value of the shift.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_axes_shift(ids, ishift, jshift)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the value of the shift for the axis IDs given.
  !   </DESCRIPTION>
  !   <IN NAME="ids" TYPE="INTEGER, DIMENSION(:)">
  !     Axis IDs.  Possible dimensions: 1 <= <TT>size(ids(:))</TT> <= 4
  !   </IN>
  !   <OUT NAME="ishift" TYPE="INTEGER">X shift value.</OUT>
  !   <OUT NAME="jshift" TYPE="INTEGER">Y shift value.</OUT>
  SUBROUTINE get_axes_shift(ids, ishift, jshift) 
    INTEGER, DIMENSION(:), INTENT(in) :: ids
    INTEGER, INTENT(out) :: ishift, jshift

    INTEGER :: i, id

    !-- get the value of the shift.
    ishift = 0 
    jshift = 0
    DO i = 1, SIZE(ids(:))
       id = ids(i)
       SELECT CASE (Axes(id)%cart_name)
       CASE ( 'X' )
          ishift = Axes(id)%shift
       CASE ( 'Y' )
          jshift = Axes(id)%shift
       END SELECT
    END DO
  END SUBROUTINE get_axes_shift
  ! </SUBROUTINE>

  ! <PRIVATE>
  ! <FUNCTION NAME="get_axis_num">
  !   <OVERVIEW>
  !     Returns index into axis table corresponding to a given axis name.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_axis_num(axis_name, set_name)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Returns index into axis table corresponding to a given axis name.
  !   </DESCRIPTION>
  !   <IN NAME="axis_name" TYPE="CHARACTER(len=*)">Axis name.</IN>
  !   <IN NAME="set_name" TYPE="CHARACTER(len=*), OPTIONAL">Set name.</IN>
  FUNCTION get_axis_num(axis_name, set_name) RESULT (num)
    CHARACTER(len=*), INTENT(in) :: axis_name
    CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name

    INTEGER :: num, set, n

    IF ( PRESENT(set_name) ) THEN
       set = get_axis_set_num (TRIM(set_name))
    ELSE
       set = 0
    END IF
    num = 0
    DO n = 1, num_def_axes
       IF ( TRIM(axis_name) == TRIM(Axes(n)%name) .AND. Axes(n)%set == set ) THEN
          num = n
          RETURN
       END IF
    END DO
  END FUNCTION get_axis_num
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="get_axis_set_num">
  !   <OVERVIEW>
  !     Returns index in axis set table corresponding to a given axis set name.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_axis_set_num(set_name)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Returns index in axis set table corresponding to a given axis set name.
  !   </DESCRIPTION>
  !   <IN NAME="set_name" TYPE="CHARACTER(len=*)">Set name.</IN>
  FUNCTION get_axis_set_num (set_name) RESULT (num)
    CHARACTER(len=*), INTENT(in) :: set_name

    INTEGER :: num, iset

    num = 0
    DO iset = 1, num_axis_sets
       IF (set_name == Axis_sets(iset))THEN
          num = iset
          RETURN
       END IF
    END DO
  END FUNCTION get_axis_set_num
  ! </FUNCTION>
  ! </PRIVATE>
END MODULE diag_axis_mod


#include <fms_platform.h>

MODULE diag_data_mod
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>
  
  ! <OVERVIEW>
  !   Type descriptions and global variables for the diag_manager modules.
  ! </OVERVIEW>

  ! <DESCRIPTION>
  !   Notation: 
  !   <DL>
  !     <DT>input field</DT>
  !     <DD>The data structure describing the field as
  !       registered by the model code.</DD>
  !
  !     <DT>output field</DT>
  !     <DD>The data structure describing the actual
  !       diagnostic output with requested frequency and
  !       other options.</DD>
  !   </DL>
  !
  !   Input fields, output fields, and output files are gathered in arrays called
  !   "input_fields", "output_fields", and "files", respectively. Indices in these
  !   arrays are used as pointers to create associations between various data
  !   structures.
  !
  !   Each input field associated with one or several output fields via array of
  !   indices output_fields; each output field points to the single "parent" input
  !   field with the input_field index, and to the output file with the output_file 
  !   index
  ! </DESCRIPTION>

  USE time_manager_mod, ONLY: time_type
  USE mpp_domains_mod,  ONLY: domain1d, domain2d
  USE mpp_io_mod,       ONLY: fieldtype
  USE fms_mod, ONLY: WARNING
#ifdef use_netCDF
  ! NF90_FILL_REAL has value of 9.9692099683868690e+36.
  USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL
#endif

  IMPLICIT NONE

  PUBLIC


  ! <!-- PARAMETERS for diag_data.F90 -->
  ! <DATA NAME="MAX_FIELDS_PER_FILE" TYPE="INTEGER, PARAMETER" DEFAULT="300">
  !   Maximum number of fields per file.
  ! </DATA>
  ! <DATA NAME="MAX_OUT_PER_IN_FIELD" TYPE="INTEGER, PARAMETER" DEFAULT="150">
  !   Maximum number of output_fields per input_field.
  ! </DATA>
  ! <DATA NAME="DIAG_OTHER" TYPE="INTEGER, PARAMETER" DEFAULT="0" />
  ! <DATA NAME="DIAG_OCEAN" TYPE="INTEGER, PARAMETER" DEFAULT="1" />
  ! <DATA NAME="DIAG_ALL" TYPE="INTEGER, PARAMETER" DEFAULT="2" />
  ! <DATA NAME="VERY_LARGE_FILE_FREQ" TYPE="INTEGER, PARAMETER" DEFAULT="100000" />
  ! <DATA NAME="VERY_LARGE_AXIS_LENGTH" TYPE="INTEGER, PARAMETER" DEFAUTL="10000" />
  ! <DATA NAME="EVERY_TIME" TYPE="INTEGER, PARAMETER" DEFAULT="0" />
  ! <DATA NAME="END_OF_RUN" TYPE="INTEGER, PARAMETER" DEFAULT="-1" />
  ! <DATA NAME="DIAG_SECONDS" TYPE="INTEGER, PARAMETER" DEFAULT="1" />
  ! <DATA NAME="DIAG_MINUTES" TYPE="INTEGER, PARAMETER" DEFAULT="2" />
  ! <DATA NAME="DIAG_HOURS" TYPE="INTEGER, PARAMETER" DEFAULT="3" />
  ! <DATA NAME="DIAG_DAYS" TYPE="INTEGER, PARAMETER" DEFAULT="4" />
  ! <DATA NAME="DIAG_MONTHS" TYPE="INTEGER, PARAMETER" DEFAULT="5" />
  ! <DATA NAME="DIAG_YEARS" TYPE="INTEGER, PARAMETER" DEFAULT="6" />
  ! <DATA NAME="MAX_SUBAXES" TYPE="INTEGER, PARAMETER" DEFAULT="10" />
  ! <DATA NAME="CMOR_MISSING_VALUE" TYPE="REAL, PARAMETER" DEFAULT="1.0e20" />

  ! Specify storage limits for fixed size tables used for pointers, etc.
  INTEGER, PARAMETER :: MAX_FIELDS_PER_FILE = 300 !< Maximum number of fields per file.
  INTEGER, PARAMETER :: MAX_OUT_PER_IN_FIELD = 150 !< Maximum number of output_fields per input_field
  INTEGER, PARAMETER :: DIAG_OTHER = 0
  INTEGER, PARAMETER :: DIAG_OCEAN = 1
  INTEGER, PARAMETER :: DIAG_ALL   = 2
  INTEGER, PARAMETER :: VERY_LARGE_FILE_FREQ = 100000
  INTEGER, PARAMETER :: VERY_LARGE_AXIS_LENGTH = 10000
  INTEGER, PARAMETER :: EVERY_TIME =  0
  INTEGER, PARAMETER :: END_OF_RUN = -1
  INTEGER, PARAMETER :: DIAG_SECONDS = 1, DIAG_MINUTES = 2, DIAG_HOURS = 3
  INTEGER, PARAMETER :: DIAG_DAYS = 4, DIAG_MONTHS = 5, DIAG_YEARS = 6
  INTEGER, PARAMETER :: MAX_SUBAXES = 10
  REAL, PARAMETER :: CMOR_MISSING_VALUE = 1.0e20 !< CMOR standard missing value

  ! <TYPE NAME="diag_grid">
  !   <DESCRIPTION>
  !     Contains the coordinates of the local domain to output.
  !   </DESCRIPTION>
  !   <DATA NAME="start" TYPE="REAL, DIMENSION(3)">
  !     Start coordinates (Lat, Lon, Depth) of the local domain to output.
  !   </DATA>
  !   <DATA NAME="end" TYPE="REAL, DIMENSION(3)">
  !     End coordinates (Lat, Lon, Depth) of the local domain to output.
  !   </DATA>
  !   <DATA NAME="l_start_indx" TYPE="INTEGER, DIMENSION(3)">
  !     Start indices at each local PE.
  !   </DATA>
  !   <DATA NAME="l_end_indx" TYPE="INTEGER, DIMENSION(3)">
  !     End indices at each local PE.
  !   </DATA>
  !   <DATA NAME="subaxes" TYPE="INTEGER, DIMENSION(3)">
  !     ID returned from diag_subaxes_init of 3 subaces.
  !   </DATA>
  TYPE diag_grid
     REAL, DIMENSION(3) :: start, END ! start and end coordinates (lat,lon,depth) of local domain to output   
     INTEGER, DIMENSION(3) :: l_start_indx, l_end_indx ! start and end indices at each LOCAL PE
     INTEGER, DIMENSION(3) :: subaxes ! id returned from diag_subaxes_init of 3 subaxes
  END TYPE diag_grid
  ! </TYPE>
  
  ! <TYPE NAME="diag_fieldtype">
  !   <DESCRIPTION>
  !     Diagnostic field type
  !   </DESCRIPTION>
  !   <DATA NAME="Field" TYPE="TYPE(fieldtype)">
  !   </DATA>
  !   <DATA NAME="Domain" TYPE="TYPE(domain2d)">
  !   </DATA>
  !   <DATA NAME="miss" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="miss_pack" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="miss_present" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="miss_pack_present" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="tile_count" TYPE="INTEGER">
  !   </DATA>
  TYPE diag_fieldtype
     TYPE(fieldtype) :: Field
     TYPE(domain2d) :: Domain
     REAL :: miss, miss_pack
     LOGICAL :: miss_present, miss_pack_present
     INTEGER :: tile_count
  END TYPE diag_fieldtype
  ! </TYPE>

  ! <TYPE NAME="coord_type">
  !   <DESCRIPTION>
  !     Define the region for field output.
  !   </DESCRIPTION>
  !   <DATA NAME="xbegin" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="xend" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="ybegin" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="yend" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="zbegin" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="zend" TYPE="REAL">
  !   </DATA>
  TYPE coord_type
     REAL :: xbegin
     REAL :: xend
     REAL :: ybegin
     REAL :: yend
     REAL :: zbegin
     REAL :: zend
  END TYPE coord_type
  ! </TYPE>
  
  ! <TYPE NAME="file_type">
  !   <DESCRIPTION>
  !     Type to define the diagnostic files that will be written as defined by the diagnostic table.
  !   </DESCRIPTION>
  !   <DATA NAME="name" TYPE="CHARACTER(len=128)">
  !     Name of the output file.
  !   </DATA>
  !   <DATA NAME="long_name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="fields" TYPE="INTEGER, dimension(max_fields_per_file)">
  !   </DATA>
  !   <DATA NAME="num_fields" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="output_freq" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="output_units" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="format" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="time_units" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="file_unit" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="bytes_written" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="time_axis_id" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="time_bounds_id" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="new_file_freq" TYPE="INTEGER">
  !     Frequency to create a new file.
  !   </DATA>
  !   <DATA NAME="new_file_freq_units" TYPE="INTEGER">
  !     Time units of new_file_freq ( days, hours, years, ...)
  !   </DATA>
  !   <DATA NAME="duration" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="duration_units" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="tile_count" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="local" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="last_flush" TYPE="TYPE(time_type)">
  !   </DATA>
  !   <DATA NAME="next_open" TYPE="TYPE(time_type)">
  !     Time to open next file.
  !   </DATA>
  !   <DATA NAME="start_time" TYPE="TYPE(time_type)">
  !     Time file opened
  !   </DATA>
  !   <DATA NAME="close_time" TYPE="TYPE(time_type)">
  !     Time file closed.  File does not allow data after close time
  !   </DATA>
  !   <DATA NAME="f_avg_start" TYPE="TYPE(diag_fieldtype)">
  !   </DATA>
  !   <DATA NAME="f_avg_end" TYPE="TYPE(diag_fieldtype)">
  !   </DATA>
  !   <DATA NAME="f_avg_nitems" TYPE="TYPE(diag_fieldtype)">
  !   </DATA>
  !   <DATA NAME="f_bounds" TYPE="TYPE(diag_fieldtype)">
  !   </DATA>
  TYPE file_type
     CHARACTER(len=128) :: name !< Name of the output file.
     CHARACTER(len=128) :: long_name
     INTEGER, DIMENSION(max_fields_per_file) :: fields
     INTEGER :: num_fields
     INTEGER :: output_freq
     INTEGER :: output_units
     INTEGER :: FORMAT
     INTEGER :: time_units
     INTEGER :: file_unit
     INTEGER :: bytes_written
     INTEGER :: time_axis_id, time_bounds_id
     INTEGER :: new_file_freq !< frequency to create new file
     INTEGER :: new_file_freq_units !< time units of new_file_freq (days, hours, years, ...)
     INTEGER :: duration
     INTEGER :: duration_units
     INTEGER :: tile_count
     LOGICAL :: local !< .TRUE. if fields are output in a region instead of global.
     TYPE(time_type) :: last_flush
     TYPE(time_type) :: next_open !< Time to open a new file.
     TYPE(time_type) :: start_time !< Time file opened.
     TYPE(time_type) :: close_time !< Time file closed.  File does not allow data after close time
     TYPE(diag_fieldtype):: f_avg_start, f_avg_end, f_avg_nitems, f_bounds
  END TYPE file_type
  ! </TYPE>  
  
  ! <TYPE NAME="input_field_type">
  !   <DESCRIPTION>
  !     Type to hold the input field description
  !   </DESCRIPTION>
  !   <DATA NAME="module_name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="field_name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="long_name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="units" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="standard_name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="interp_method" TYPE="CHARACTER(len=64)">
  !   </DATA>
  !   <DATA NAME="axes" TYPE="INTEGER, DIMENSION(3)">
  !   </DATA>
  !   <DATA NAME="num_axes" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="missing_value_present" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="range_present" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="missing_value" TYPE="REAL">
  !   </DATA>
  !   <DATA NAME="range" TYPE="REAL, DIMENSION(2)">
  !   </DATA>
  !   <DATA NAME="output_fields" TYPE="INTEGER, DIMENSION(max_out_per_in_field)">
  !   </DATA>
  !   <DATA NAME="num_output_fields" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="size" TYPE="INTEGER, DIMENSION(3)">
  !   </DATA>
  !   <DATA NAME="static" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="register" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="mask_variant" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="local" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="tile_count" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="local_coord" TYPE="TYPE(coord_type)">
  !   </DATA>
  TYPE input_field_type
     CHARACTER(len=128) :: module_name, field_name, long_name, units, standard_name
     CHARACTER(len=64) :: interp_method
     INTEGER, DIMENSION(3) :: axes
     INTEGER :: num_axes 
     LOGICAL :: missing_value_present, range_present
     REAL :: missing_value
     REAL, DIMENSION(2) :: range
     INTEGER, DIMENSION(max_out_per_in_field) :: output_fields
     INTEGER :: num_output_fields
     INTEGER, DIMENSION(3) :: size
     LOGICAL :: static, register, mask_variant, local
     INTEGER :: numthreads
     INTEGER :: tile_count
     TYPE(coord_type) :: local_coord
     TYPE(time_type)  :: time
  END TYPE input_field_type
  ! </TYPE>

  ! <TYPE NAME="output_field_type">
  !   <DESCRIPTION>
  !     Type to hold the output field description.
  !   </DESCRIPTION>
  !   <DATA NAME="input_field" TYPE="INTEGER">
  !     Index of the corresponding input field in the table
  !   </DATA>
  !   <DATA NAME="output_file" TYPE="INTEGER">
  !     Index of the output file in the table
  !   </DATA>
  !   <DATA NAME="output_name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="static" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="time_max" TYPE="LOGICAL">
  !     .TRUE. if the output field is maximum over time interval
  !   </DATA>
  !   <DATA NAME="time_min" TYPE="LOGICAL">
  !     .TRUE. if the output field is minimum over time interval
  !   </DATA>
  !   <DATA NAME="time_average" TYPE="LOGICAL">
  !     .TRUE. if the output field is averaged over time interval.
  !   </DATA>
  !   <DATA NAME="time_ops" TYPE="LOGICAL">
  !     .TRUE. if any of time_min, time_max, or time_average is true
  !   </DATA>
  !   <DATA NAME="pack" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="time_method" TYPE="CHARACTER(len=50)">
  !     Time method field from the input file
  !   </DATA>
  !   <DATA NAME="buffer" TYPE="REAL, _ALLOCATABLE, DIMENSION(:,:,:,:)" DEFAULT="_NULL">
  !     Coordinates of buffer are (x, y, z, time-of-day)
  !   </DATA>
  !   <DATA NAME="counter" TYPE="REAL, _ALLOCATABLE, DIMENSION(:,:,:,:)" DEFAULT="_NULL">
  !     Coordinates of buffer are (x, y, z, time-of-day)
  !   </DATA>
  !   <DATA NAME="count_0d" TYPE="REAL, _ALLOCATABLE, DIMENSION(:)">
  !   </DATA>
  !   <DATA NAME="num_elements" TYPE="REAL, _ALLOCATABLE, DIMENSION(:)">
  !   </DATA>
  !   <DATA NAME="last_output" TYPE="TYPE(time_type)">
  !   </DATA>
  !   <DATA NAME="next_output" TYPE="TYPE(time_type)">
  !   </DATA>
  !   <DATA NAME="next_next_output" TYPE="TYPE(time_type)">
  !   </DATA>
  !   <DATA NAME="f_type" TYPE="TYPE(diag_fieldtype)">
  !   </DATA>
  !   <DATA NAME="axes" TYPE="INTEGER, DIMENSION(4)">
  !   </DATA>
  !   <DATA NAME="num_axes" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="total_elements" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="region_elements" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="n_diurnal_samples" TYPE="INTEGER">
  !     Number of diurnal sample intervals, 1 or more
  !   </DATA>
  !   <DATA NAME="output_grid" TYPE="TYPE(diag_grid)">
  !   </DATA>
  !   <DATA NAME="local_output" TYPE="LOGICAL">
  !     .TRUE. if this field is written out on a region and not globally.
  !   </DATA>
  !   <DATA NAME="need_compute" TYPE="LOGICAL">
  !     .TRUE. if this field is written out on a region, not global.
  !   </DATA>
  !   <DATA NAME="phys_window" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="written_once" TYPE="LOGICAL">
  !   </DATA>
  !   <DATA NAME="reduced_k_range" TYPE="LOGICAL">
  !     .TRUE. if dealing with vertical sub-level output.
  !   </DATA>
  !   <DATA NAME="imin" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="imax" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="jmin" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="jmax" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="kmin" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="kmax" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="Time_of_prev_field_data" TYPE="TYPE(time_type)">
  !   </DATA>
  TYPE output_field_type
     INTEGER :: input_field ! index of the corresponding input field in the table
     INTEGER :: output_file ! index of the output file in the table
     CHARACTER(len=128) :: output_name
     LOGICAL :: time_average ! true if the output field is averaged over time interval
     LOGICAL :: static
     LOGICAL :: time_max ! true if the output field is maximum over time interval
     LOGICAL :: time_min ! true if the output field is minimum over time interval
     LOGICAL :: time_ops ! true if any of time_min, time_max, or time_average is true
     INTEGER  :: pack
     CHARACTER(len=50) :: time_method ! time method field from the input file 
     ! coordianes of the buffer and counter are (x, y, z, time-of-day)
     REAL, _ALLOCATABLE, DIMENSION(:,:,:,:) :: buffer _NULL
     REAL, _ALLOCATABLE, DIMENSION(:,:,:,:) :: counter _NULL
     ! the following two counters are used in time-averaging for some 
     ! combination of the field options. Their size is the length of the 
     ! diurnal axis; the counters must be tracked separately for each of
     ! the diurnal interval, becaus the number of time slices accumulated
     ! in each can be different, depending on time step and the number of
     ! diurnal samples.
     REAL, _ALLOCATABLE, DIMENSION(:)  :: count_0d
     INTEGER, _ALLOCATABLE, dimension(:) :: num_elements
     
     TYPE(time_type) :: last_output, next_output, next_next_output
     TYPE(diag_fieldtype) :: f_type
     INTEGER, DIMENSION(4) :: axes
     INTEGER :: num_axes, total_elements, region_elements
     INTEGER :: n_diurnal_samples ! number of diurnal sample intervals, 1 or more
     TYPE(diag_grid) :: output_grid
     LOGICAL :: local_output, need_compute, phys_window, written_once
     LOGICAL :: reduced_k_range
     INTEGER :: imin, imax, jmin, jmax, kmin, kmax
     TYPE(time_type) :: Time_of_prev_field_data
  END TYPE output_field_type
  ! </TYPE>

  ! <TYPE NAME="diag_axis_type">
  !   <DESCRIPTION>
  !     Type to hold the diagnostic axis description.
  !   </DESCRIPTION>
  !   <DATA NAME="name" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="units" TYPE="CHARACTER(len=256)">
  !   </DATA>
  !   <DATA NAME="long_name" TYPE="CHARACTER(len=256)">
  !   </DATA>
  !   <DATA NAME="cart_name" TYPE="CHARACTER(len=1)">
  !   </DATA>
  !   <DATA NAME="data" TYPE="REAL, DIMENSION(:), POINTER">
  !   </DATA>
  !   <DATA NAME="start" TYPE="INTEGER, DIMENSION(max_subaxes)">
  !   </DATA>
  !   <DATA NAME="end" TYPE="INTEGER, DIMENSION(max_subaxes)">
  !   </DATA>
  !   <DATA NAME="subaxis_name" TYPE="CHARACTER(len=128), DIMENSION(max_subaxes)">
  !   </DATA>
  !   <DATA NAME="length" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="direction" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="edges" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="set" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="shift" TYPE="INTEGER">
  !   </DATA>
  !   <DATA NAME="Domain" TYPE="TYPE(domain1d)">
  !   </DATA>
  !   <DATA NAME="Domain2" TYPE="TYPE(domain2d)">
  !   </DATA>
  !   <DATA NAME="aux" TYPE="CHARACTER(len=128)">
  !   </DATA>
  !   <DATA NAME="tile_count" TYPE="INTEGER">
  !   </DATA>
  TYPE diag_axis_type
     CHARACTER(len=128) :: name
     CHARACTER(len=256) :: units, long_name
     CHARACTER(len=1) :: cart_name
     REAL, DIMENSION(:), POINTER :: data
     INTEGER, DIMENSION(max_subaxes) :: start
     INTEGER, DIMENSION(max_subaxes) :: end
     CHARACTER(len=128), DIMENSION(max_subaxes) :: subaxis_name
     INTEGER :: length, direction, edges, set, shift
     TYPE(domain1d) :: Domain
     TYPE(domain2d) :: Domain2
     CHARACTER(len=128) :: aux
     INTEGER :: tile_count
  END TYPE diag_axis_type
  ! </TYPE>

  ! <TYPE NAME="diag_global_att_type">
  !   <DESCRIPTION>
  !   </DESCRIPTION>
  !   <DATA NAME="grid_type" TYPE="CHARACTER(len=128)" DEFAULT="regular">
  !   </DATA>
  !   <DATA NAME="tile_name" TYPE="CHARACTER(len=128)" DEFAULT="N/A">
  !   </DATA>
  TYPE diag_global_att_type
     CHARACTER(len=128)   :: grid_type='regular'
     CHARACTER(len=128)   :: tile_name='N/A'
  END TYPE diag_global_att_type
  ! </TYPE>
  
  ! Private CHARACTER Arrays for the CVS version and tagname.
  CHARACTER(len=128),PRIVATE  :: version =&
       & '$Id: diag_data.F90,v 18.0.2.8 2010/04/06 16:51:06 sdu Exp $'
  CHARACTER(len=128),PRIVATE  :: tagname =&
       & '$Name: hiram_20101115_bw $'

  ! <!-- Other public variables -->
  ! <DATA NAME="num_files" TYPE="INTEGER" DEFAULT="0">
  !   Number of output files currenly in use by the diag_manager.
  ! </DATA>
  ! <DATA NAME="num_input_fields" TYPE="INTEGER" DEFAULT="0">
  !   Number of input fields in use.
  ! </DATA>
  ! <DATA NAME="num_output_fields" TYPE="INTEGER" DEFAULT="0">
  !   Number of output fields in use.
  ! </DATA>
  ! <DATA NAME="null_axis_id" TYPE="INTEGER" />
  INTEGER :: num_files = 0
  INTEGER :: num_input_fields = 0
  INTEGER :: num_output_fields = 0
  INTEGER :: null_axis_id

  ! <!-- Namelist variables -->
  ! <DATA NAME="append_pelist_name" TYPE="LOGICAL" DEFAULT=".FALSE." />
  ! <DATA NAME="mix_snapshot_average_fields" TYPE="LOGICAL" DEFAULT=".FALSE." />
  ! <DATA NAME="max_files" TYPE="INTEGER" DEFAULT="31">
  !   Maximum number of output files allowed.  Increase via the diag_manager_nml namelist.
  ! </DATA>
  ! <DATA NAME="max_output_fields" TYPE="INTEGER" DEFAULT="300">
  !   Maximum number of output fields.  Increase via the diag_manager_nml namelist.
  ! </DATA>
  ! <DATA NAME="max_input_fields" TYPE="INTEGER" DEFAULT="300">
  !   Maximum number of input fields.  Increase via the diag_manager_nml namelist.
  ! </DATA>
  ! <DATA NAME="max_axes" TYPE="INTEGER" DEFAULT="60">
  !   Maximum number of independent axes.
  ! </DATA>
  ! <DATA NAME="do_diag_field_log" TYPE="LOGICAL" DEFAULT=".FALSE." />
  ! <DATA NAME="write_bytes_in_file" TYPE="LOGICAL" DEFAULT=".FALSE." />
  ! <DATA NAME="debug_diag_manager" TYPE="LOGICAL" DEFAULT=".FALSE." />
  ! <DATA NAME="max_num_axis_sets" TYPE="INTEGER" DEFAULT="25" />
  ! <DATA NAME="use_cmor" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   Indicates if we should overwrite the MISSING_VALUE to use the CMOR missing value.
  ! </DATA>
  ! <DATA NAME="ISSUE_OOR_WARNINGS" TYPE="LOGICAL" DEFAULT=".TRUE.">
  !   Issue warnings if the output field has values outside the given
  !   range for a variable.
  ! </DATA>
  ! <DATA NAME="OOR_WARNINGS_FATAL" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   Cause a fatal error if the output field has a value outside the
  !   given range for a variable.
  ! </DATA>
  LOGICAL :: append_pelist_name = .FALSE.
  LOGICAL :: mix_snapshot_average_fields =.FALSE.
  INTEGER :: max_files = 31 !< Maximum number of output files allowed.  Increase via diag_manager_nml.
  INTEGER :: max_output_fields = 300 !< Maximum number of output fields.  Increase via diag_manager_nml.
  INTEGER :: max_input_fields = 300 !< Maximum number of input fields.  Increase via diag_manager_nml.
  INTEGER :: max_axes = 60 !< Maximum number of independent axes.
  LOGICAL :: do_diag_field_log = .FALSE.
  LOGICAL :: write_bytes_in_file = .FALSE.
  LOGICAL :: debug_diag_manager = .FALSE.
  INTEGER :: max_num_axis_sets = 25
  LOGICAL :: use_cmor = .FALSE.
  LOGICAL :: issue_oor_warnings = .TRUE.
  LOGICAL :: oor_warnings_fatal = .FALSE.

  ! <!-- netCDF variable -->
  ! <DATA NAME="FILL_VALUE" TYPE="REAL" DEFAULT="NF90_FILL_REAL">
  !   Fill value used.  Value will be <TT>NF90_FILL_REAL</TT> if using the
  !   netCDF module, otherwise will be 9.9692099683868690e+36.
  ! </DATA>
#ifdef use_netCDF
  REAL :: FILL_VALUE = NF_FILL_REAL  ! from file /usr/local/include/netcdf.inc
#else
  REAL :: FILL_VALUE = 9.9692099683868690e+36 
#endif

  ! <!-- REAL public variables -->
  ! <DATA NAME="EMPTY" TYPE="REAL" DEFAULT="0.0" />
  ! <DATA NAME="MAX_VALUE" TYPE="REAL" />
  ! <DATA NAME="MIN_VALUE" TYPE="REAL" />
  REAL :: EMPTY = 0.0
  REAL :: MAX_VALUE, MIN_VALUE

  ! <!-- Global data for all files -->
  ! <DATA NAME="base_time" TYPE="TYPE(time_type)" />
  ! <DATA NAME="base_year" TYPE="INTEGER" />
  ! <DATA NAME="base_month" TYPE="INTEGER" />
  ! <DATA NAME="base_day" TYPE="INTEGER" />
  ! <DATA NAME="base_hour" TYPE="INTEGER" />
  ! <DATA NAME="base_minute" TYPE="INTEGER" />
  ! <DATA NAME="base_second" TYPE="INTEGER" />
  ! <DATA NAME="global_descriptor" TYPE="CHARACTER(len=256)" />
  TYPE(time_type) :: base_time
  INTEGER :: base_year, base_month, base_day, base_hour, base_minute, base_second
  CHARACTER(len = 256):: global_descriptor

  ! <!-- ALLOCATABLE variables -->
  ! <DATA NAME="files" TYPE="TYPE(file_type), DIMENSION(:), SAVE, ALLOCATABLE" />
  ! <DATA NAME="input_fields" TYPE="TYPE(input_field_type), DIMENSION(:), ALLOCATABLE" />
  ! <DATA NAME="output_fields" TYPE="TYPE(output_field_type), DIMENSION(:), ALLOCATABLE" />
  TYPE(file_type), SAVE, ALLOCATABLE :: files(:)
  TYPE(input_field_type), ALLOCATABLE :: input_fields(:)
  TYPE(output_field_type), ALLOCATABLE :: output_fields(:)

  ! <!-- Even More Variables -->
  ! <DATA NAME="time_zero" TYPE="TYPE(time_type)" />
  ! <DATA NAME="first_send_data_call" TYPE="LOGICAL" DEFAULT=".TRUE." />
  ! <DATA NAME="module_is_initialized" TYPE="LOGICAL" DEFAULT=".FALSE." />
  ! <DATA NAME="diag_log_unit" TYPE="INTEGER" />
  ! <DATA NAME="time_unit_list" TYPE="CHARACTER(len=10), DIMENSION(6)"
  !       DEFAULT="(/'seconds   ', 'minutes   ', 'hours     ', 'days      ', 'months    ', 'years     '/)" />
  ! <DATA NAME="filename_appendix" TYPE="CHARACTER(len=32)" DEFAULT="" />
  ! <DATA NAME="pelist_name" TYPE="CHARACTER(len=32)" />
  TYPE(time_type) :: time_zero
  LOGICAL :: first_send_data_call = .TRUE.
  LOGICAL :: module_is_initialized = .FALSE.
  INTEGER :: diag_log_unit
  CHARACTER(len=10), DIMENSION(6) :: time_unit_list = (/'seconds   ', 'minutes   ',&
       & 'hours     ', 'days      ', 'months    ', 'years     '/)
  CHARACTER(len=32), SAVE :: filename_appendix = ''
  CHARACTER(len=32) :: pelist_name
  INTEGER :: oor_warning = WARNING
  
END MODULE diag_data_mod


#include <fms_platform.h>

MODULE diag_grid_mod
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>
  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/" />
  ! <OVERVIEW>
  !   <TT>diag_grid_mod</TT> is a set of procedures to work with the
  !   model's global grid to allow regional output.
  ! </OVERVIEW>
  ! <DESCRIPTION>
  !   <TT>diag_grid_mod</TT> contains useful utilities for dealing
  !   with, mostly, regional output for grids other than the standard
  !   lat/lon grid.  This module contains three public procedures <TT>
  !   diag_grid_init</TT>, which is shared globably in the <TT>
  !   diag_manager_mod</TT>, <TT>diag_grid_end</TT> which will free
  !   up memory used during the register field calls, and
  !   <TT>get_local_indexes</TT>.  The <TT>send_global_grid</TT>
  !   procedure is called by the model that creates the global grid.
  !   <TT>send_global_grid</TT> needs to be called before any fields
  !   are registered that will output only regions.  <TT>get_local_indexes</TT>
  !   is to be called by the <TT>diag_manager_mod</TT> to discover the
  !   global indexes defining a subregion on the tile.
  !
  !   <B>Change Log</B>
  !   <DL>
  !     <DT>September 2009</DT>
  !     <DD>
  !       <UL>
  !         <LI>Single point region in Cubed Sphere</LI>
  !         <LI>Single tile regions in the cubed sphere</LI>
  !       </UL>
  !     </DD> 
  !   </DL>
  ! </DESCRIPTION>

  ! <INFO>
  !   <FUTURE>
  !     Multi-tile regional output in the cubed sphere.
  !   </FUTURE>
  !   <FUTURE>
  !     Single grid in the tri-polar grid.
  !   </FUTURE>
  !   <FUTURE>
  !     Multi-tile regional output in the tri-polar grid.
  !   </FUTURE>
  !   <FUTURE>
  !     Regional output using array masking.  This should allow
  !     regional output to work on any current or future grid.
  !   </FUTURE>
  ! </INFO>
  USE constants_mod, ONLY: DEG_TO_RAD, RAD_TO_DEG, RADIUS
  USE fms_mod, ONLY: write_version_number, error_mesg, WARNING, FATAL,&
       & mpp_pe
  USE mpp_mod, ONLY: mpp_root_pe, mpp_npes, mpp_max
  Use mpp_domains_mod, ONLY: domain2d, mpp_get_tile_id,&
       & mpp_get_ntile_count, mpp_get_compute_domains

  IMPLICIT NONE

  ! Parameters
  CHARACTER(len=128), PARAMETER :: version =&
       & '$Id: diag_grid.F90,v 18.0.2.6 2010/04/12 21:25:34 sdu Exp $'
  CHARACTER(len=128), PARAMETER :: tagname =&
       & '$Name: hiram_20101115_bw $'

  ! Derived data types
  ! <PRIVATE>
  ! <TYPE NAME="diag_global_grid_type">
  !   <DESCRIPTION>
  !     Contains the model's global grid data, and other grid information.
  !   </DESCRIPTION>
  !   <DATA NAME="glo_lat" TYPE="REAL, _ALLOCATABLE, DIMENSION(:,:)">
  !     The latitude values on the global grid.
  !   </DATA>
  !   <DATA NAME="glo_lon" TYPE="REAL, _ALLOCATABLE, DIMENSION(:,:)">
  !     The longitude values on the global grid.
  !   </DATA>
  !   <DATA NAME="aglo_lat" TYPE="REAL, _ALLOCATABLE, DIMENSION(:,:)">
  !     The latitude values on the global a-grid.  Here we expect isc-1:iec+1 and
  !     jsc=1:jec+1 to be passed in.
  !   </DATA>
  !   <DATA NAME="aglo_lon" TYPE="REAL, _ALLOCATABLE, DIMENSION(:,:)">
  !     The longitude values on the global a-grid.  Here we expec isc-1:iec+j and
  !     jsc-1:jec+1 to be passed in.
  !   </DATA>
  !   <DATA NAME="myXbegin" TYPE="INTEGER">
  !     The starting index of the compute domain on the current PE.
  !   </DATA>
  !   <DATA NAME="myYbegin" TYPE="INTEGER">
  !     The starting index of the compute domain on the cureent PE.
  !   </DATA>
  !   <DATA NAME="dimI" TYPE="INTEGER">
  !     The dimension of the global grid in the 'i' / longitudal direction.
  !   </DATA>
  !   <DATA NAME="dimJ" TYPE="INTEGER">
  !     The dimension of the global grid in the 'j' / latitudal direction.
  !   </DATA>
  !   <DATA NAME="adimI" TYPE="INTEGER">
  !     The dimension of the global a-grid in the 'i' / longitudal direction.  Again,
  !     the expected dimension for diag_grid_mod is isc-1:iec+1.
  !   </DATA>
  !   <DATA NAME="adimJ" TYPE="INTEGER">
  !     The dimension of the global a-grid in the 'j' / latitudal direction.  Again,
  !     the expected dimension for diag_grid_mod is jsc-1:jec+1.
  !   </DATA>
  !   <DATA NAME="tile_number" TYPE="INTEGER">
  !     The tile the <TT>glo_lat</TT> and <TT>glo_lon</TT> define.
  !   </DATA>
  !   <DATA NAME="ntimes" TYPE="INTEGER">
  !     The number of tiles.
  !   </DATA>
  !   <DATA NAME="peStart" TYPE="INTEGER">
  !     The starting PE number for the current tile.
  !   </DATA>
  !   <DATA NAME="peEnd" TYPE="INTEGER">
  !     The ending PE number for the current tile.
  !   </DATA>
  !   <DATA NAME="grid_type" TYPE="CHARACTER(len=128)">
  !     The global grid type.
  !   </DATA>
  TYPE :: diag_global_grid_type
     REAL, _ALLOCATABLE, DIMENSION(:,:) :: glo_lat, glo_lon
     REAL, _ALLOCATABLE, DIMENSION(:,:) :: aglo_lat, aglo_lon
     INTEGER :: myXbegin, myYbegin
     INTEGER :: dimI, dimJ
     INTEGER :: adimI, adimJ
     INTEGER :: tile_number
     INTEGER :: ntiles
     INTEGER :: peStart, peEnd
     CHARACTER(len=128) :: grid_type
  END TYPE diag_global_grid_type
  ! </TYPE>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <TYPE NAME="point">
  !   <DESCRIPTION>
  !      Private point type to hold the (x,y,z) location for a (lat,lon)
  !      location.
  !   </DESCRIPTION>
  !   <DATA NAME="x" TYPE="REAL">
  !     The x value of the (x,y,z) coordinates.
  !   </DATA>
  !   <DATA NAME="y" TYPE="REAL">
  !     The y value of the (x,y,z) coordinates.
  !   </DATA>
  !   <DATA NAME="z" TYPE="REAL">
  !     The z value of the (x,y,z) coordinates.
  !   </DATA>
  TYPE :: point
     REAL :: x,y,z
  END TYPE point
  ! </TYPE>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <DATA NAME="diag_global_grid" TYPE="TYPE(diag_global_grid_type)">
  !   Variable to hold the global grid data
  ! </DATA>
  ! </PRIVATE>
  TYPE(diag_global_grid_type) :: diag_global_grid

  ! <PRIVATE>
  ! <DATA NAME="diag_grid_initialized" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   Indicates if the diag_grid_mod has been initialized.
  ! </DATA>
  ! </PRIVATE>
  LOGICAL :: diag_grid_initialized = .FALSE.

  PRIVATE
  PUBLIC :: diag_grid_init, diag_grid_end, get_local_indexes,  &
            get_local_indexes2

CONTAINS

  ! <SUBROUTINE NAME="diag_grid_init">
  !   <OVERVIEW>
  !     Send the global grid to the <TT>diag_manager_mod</TT> for
  !     regional output. 
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     In order for the diag_manager to do regional output for grids
  !     other than the standard lat/lon grid, the <TT>
  !     diag_manager_mod</TT> needs to know the the latitude and
  !     longitude values for the entire global grid.  This procedure
  !     is the mechanism the models will use to share their grid with
  !     the diagnostic manager.
  !     
  !     This procedure needs to be called after the grid is created,
  !     and before the first call to register the fields.
  !   </DESCRIPTION>
  !   <IN NAME="domain" TYPE="INTEGER">
  !     The domain to which the grid data corresponds.
  !   </IN>
  !   <IN NAME="glo_lat" TYPE="REAL, DIMENSION(:,:)">
  !     The latitude information for the grid tile.
  !   </IN>
  !   <IN NAME="glo_lon" TYPE="REAL, DIMENSION(:,:)">
  !     The longitude information for the grid tile.
  !   </IN>
  !   <IN NAME="aglo_lat" TYPE="REAL, DIMENSION(:,:)">
  !     The latitude information for the a-grid tile.
  !   </IN>
  !   <IN NAME="aglo_lon" TYPE="REAL, DIMENSION(:,:)">
  !     The longitude information for the a-grid tile.
  !   </IN>
  SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
    TYPE(domain2d), INTENT(in) :: domain
    REAL, INTENT(in), DIMENSION(:,:) :: glo_lat, glo_lon
    REAL, INTENT(in), DIMENSION(:,:) :: aglo_lat, aglo_lon

    INTEGER, DIMENSION(1) :: tile
    INTEGER :: ntiles
    INTEGER :: stat
    INTEGER :: i_dim, j_dim
    INTEGER :: ai_dim, aj_dim
    INTEGER, DIMENSION(2) :: latDim, lonDim
    INTEGER, DIMENSION(2) :: alatDim, alonDim
    INTEGER :: myPe, npes, npesPerTile
    INTEGER, ALLOCATABLE, DIMENSION(:) :: xbegin, xend, ybegin, yend

    ! Write the version and tagname to the logfile
    CALL write_version_number(version, tagname)

    ! Verify all allocatable / pointers for diag_global_grid hare not
    ! allocated / associated.
    IF ( ALLOCATED(xbegin) ) DEALLOCATE(xbegin)
    IF ( ALLOCATED(ybegin) ) DEALLOCATE(ybegin)
    IF ( ALLOCATED(xend) ) DEALLOCATE(xend)
    IF ( ALLOCATED(yend) ) DEALLOCATE(yend)

    ! What is my PE
    myPe = mpp_pe() + 1
    
    ! Get the domain/pe layout, and allocate the [xy]begin|end arrays/pointers
    npes = mpp_npes()
    ALLOCATE(xbegin(npes), &
         &   ybegin(npes), &
         &   xend(npes), &
         &   yend(npes), STAT=stat)
    IF ( stat .NE. 0 ) THEN
       CALL error_mesg('diag_grid_mod::diag_grid_init',&
            &'Could not allocate memory for the compute grid indices&
            &.', FATAL)
    END IF
    
    ! Get tile information
    ntiles = mpp_get_ntile_count(domain)
    tile = mpp_get_tile_id(domain)
    
    ! Number of PEs per tile
    npesPerTile = npes / ntiles
    diag_global_grid%peEnd = npesPerTile * tile(1)
    diag_global_grid%peStart = diag_global_grid%peEnd - npesPerTile + 1

    ! Get the compute domains
    CALL mpp_get_compute_domains(domain,&
         & XBEGIN=xbegin, XEND=xend,&
         & YBEGIN=ybegin, YEND=yend)

    ! Module initialized
    diag_grid_initialized = .TRUE.

    ! Get the size of the grids
    latDim = SHAPE(glo_lat)
    lonDim = SHAPE(glo_lon)
    IF (  (latDim(1) == lonDim(1)) .AND.&
         &(latDim(2) == lonDim(2)) ) THEN
       IF ( tile(1) == 4 .OR. tile(1) == 5 ) THEN
          ! These tiles need to be transposed.
          i_dim = latDim(2)
          j_dim = latDim(1)
       ELSE 
          i_dim = latDim(1)
          j_dim = latDim(2)
       END IF
    ELSE
       CALL error_mesg('diag_grid_mod::diag_grid_init',&
            &'glo_lat and glo_lon must be the same shape.', FATAL)
    END IF

    ! Same thing for the a-grid
    alatDim = SHAPE(aglo_lat)
    alonDim = SHAPE(aglo_lon)
    IF (  (alatDim(1) == alonDim(1)) .AND. &
         &(alatDim(2) == alonDim(2)) ) THEN
       IF ( tile(1) == 4 .OR. tile(1) == 5 ) THEN
          ! These tiles need to be transposed.
          ai_dim = alatDim(2)
          aj_dim = alatDim(1)
       ELSE
          ai_dim = alatDim(1)
          aj_dim = alatDim(2)
       END IF
    ELSE
       CALL error_mesg('diag_grid_mod::diag_grid_init',&
            & "a-grid's glo_lat and glo_lon must be the same shape.", FATAL)
    END IF
    
    ! Allocate the grid arrays
    IF (   _ALLOCATED(diag_global_grid%glo_lat) .OR.&
         & _ALLOCATED(diag_global_grid%glo_lon) ) THEN
       IF ( mpp_pe() == mpp_root_pe() ) &
            & CALL error_mesg('diag_grid_mod::diag_grid_init',&
            &'The global grid has already been initialized', WARNING)
    ELSE
       ALLOCATE(diag_global_grid%glo_lat(i_dim,j_dim),&
            &   diag_global_grid%glo_lon(i_dim,j_dim), STAT=stat)
       IF ( stat .NE. 0 ) THEN
          CALL error_mesg('diag_grid_mod::diag_grid_init',&
               &'Could not allocate memory for the global grid.', FATAL)
       END IF
    END IF

    ! Same thing for the a-grid
    IF (   _ALLOCATED(diag_global_grid%aglo_lat) .OR.&
         & _ALLOCATED(diag_global_grid%aglo_lon) ) THEN
       IF ( mpp_pe() == mpp_root_pe() ) &
            & CALL error_mesg('diag_grid_mod::diag_grid_init',&
            &'The global a-grid has already been initialized', WARNING)
    ELSE
       ALLOCATE(diag_global_grid%aglo_lat(0:ai_dim-1,0:aj_dim-1),&
            &   diag_global_grid%aglo_lon(0:ai_dim-1,0:aj_dim-1), STAT=stat)
       IF ( stat .NE. 0 ) THEN
          CALL error_mesg('diag_global_mod::diag_grid_init',&
               &'Could not allocate memory for the global a-grid', FATAL)
       END IF
    END IF
    
    ! Set the values for diag_global_grid

    ! If we are on tile 4 or 5, we need to transpose the grid to get
    ! this to work.
    IF ( tile(1) == 4 .OR. tile(1) == 5 ) THEN
       diag_global_grid%glo_lat = TRANSPOSE(glo_lat)
       diag_global_grid%glo_lon = TRANSPOSE(glo_lon)
       diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat)
       diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon)
    ELSE
       diag_global_grid%glo_lat = glo_lat
       diag_global_grid%glo_lon = glo_lon
       diag_global_grid%aglo_lat = aglo_lat
       diag_global_grid%aglo_lon = aglo_lon
    END IF
    diag_global_grid%dimI = i_dim
    diag_global_grid%dimJ = j_dim
    diag_global_grid%adimI = ai_dim
    diag_global_grid%adimJ = aj_dim
    diag_global_grid%tile_number = tile(1)
    diag_global_grid%ntiles = ntiles
    diag_global_grid%myXbegin = xbegin(myPe)
    diag_global_grid%myYbegin = ybegin(myPe)

    ! Unallocate arrays used here
    DEALLOCATE(xbegin)
    DEALLOCATE(ybegin)
    DEALLOCATE(xend)
    DEALLOCATE(yend)
  END SUBROUTINE diag_grid_init
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="diag_grid_end">
  !   <OVERVIEW>
  !     Unallocate the diag_global_grid variable.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE diag_grid_end()
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     The <TT>diag_global_grid</TT> variable is only needed during
  !     the register field calls, and then only if there are fields
  !     requestion regional output.  Once all the register fields
  !     calls are complete (before the first <TT>send_data</TT> call
  !     this procedure can be called to free up memory.
  !   </DESCRIPTION>
  SUBROUTINE diag_grid_end()
    
    IF ( diag_grid_initialized ) THEN
       ! De-allocate grid
       IF ( _ALLOCATED(diag_global_grid%glo_lat) ) THEN
          DEALLOCATE(diag_global_grid%glo_lat)
       ELSE IF ( mpp_pe() == mpp_root_pe() ) THEN
          CALL error_mesg('diag_grid_mod::diag_grid_end',&
               &'diag_global_grid%glo_lat was not allocated.', WARNING)
       END IF
       
       IF ( _ALLOCATED(diag_global_grid%glo_lon) ) THEN
          DEALLOCATE(diag_global_grid%glo_lon)
       ELSE IF ( mpp_pe() == mpp_root_pe() ) THEN
          CALL error_mesg('diag_grid_mod::diag_grid_end',&
               &'diag_global_grid%glo_lon was not allocated.', WARNING)
       END IF
       ! De-allocate a-grid
       IF ( _ALLOCATED(diag_global_grid%aglo_lat) ) THEN
          DEALLOCATE(diag_global_grid%aglo_lat)
       ELSE IF ( mpp_pe() == mpp_root_pe() ) THEN
          CALL error_mesg('diag_grid_mod::diag_grid_end',&
               &'diag_global_grid%aglo_lat was not allocated.', WARNING)
       END IF
       
       IF ( _ALLOCATED(diag_global_grid%aglo_lon) ) THEN
          DEALLOCATE(diag_global_grid%aglo_lon)
       ELSE IF ( mpp_pe() == mpp_root_pe() ) THEN
          CALL error_mesg('diag_grid_mod::diag_grid_end',&
               &'diag_global_grid%aglo_lon was not allocated.', WARNING)
       END IF
       
       diag_grid_initialized = .FALSE.
    END IF
  END SUBROUTINE diag_grid_end
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="get_local_indexes">
  !   <OVERVIEW>
  !     Find the local start and local end indexes on the local PE
  !     for regional output.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_local_indexes(latStart, latEnd, lonStart,
  !     lonEnd, istart, iend, jstart, jend)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given a defined region, find the local indexes on the local
  !     PE surrounding the region.
  !   </DESCRIPTION>
  !   <IN NAME="latStart" TYPE="REAL">
  !     The minimum latitude value defining the region.  This value
  !     must be less than latEnd, and be in the range [-90,90]
  !   </IN>
  !   <IN NAME="latEnd" TYPE="REAL">
  !     The maximum latitude value defining the region.  This value
  !     must be greater than latStart, and be in the range [-90,90]
  !   </IN>
  !   <IN NAME="lonStart" TYPE="REAL">
  !     The western most longitude value defining the region.
  !     Possible ranges are either [-180,180] or [0,360].
  !   </IN>
  !   <IN NAME="lonEnd" TYPE="REAL">
  !     The eastern most longitude value defining the region.
  !     Possible ranges are either [-180,180] or [0,360].
  !   </IN>
  !   <OUT NAME="istart" TYPE="INTEGER">
  !     The local start index on the local PE in the 'i' direction.
  !   </OUT>
  !   <OUT NAME="iend" TYPE="INTEGER">
  !     The local end index on the local PE in the 'i' direction.
  !   </OUT>
  !   <OUT NAME="jstart" TYPE="INTEGER">
  !     The local start index on the local PE in the 'j' direction.
  !   </OUT>
  !   <OUT NAME="jend" TYPE="INTEGER">
  !     The local end index on the local PE in the 'j' direction.
  !   </OUT>
  SUBROUTINE get_local_indexes(latStart, latEnd, lonStart, lonEnd,&
       & istart, iend, jstart, jend)
    REAL, INTENT(in) :: latStart, lonStart !< lat/lon start angles
    REAL, INTENT(in) :: latEnd, lonEnd !< lat/lon end angles
    INTEGER, INTENT(out) :: istart, jstart !< i/j start indexes
    INTEGER, INTENT(out) :: iend, jend !< i/j end indexes

    INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: indexes
    INTEGER :: myTile, ntiles, i, j

    IF ( .NOT. diag_grid_initialized )&
         & CALL error_mesg('diag_grid_mod::get_local_indexes',&
         &'Module not initialized, first initialze module with a call &
         &to diag_grid_init', FATAL)
    
    myTile = diag_global_grid%tile_number
    ntiles = diag_global_grid%ntiles

    ! Allocate the indexes array, and initialize to zero.  (Useful for
    ! reduction later on.)
    IF ( ALLOCATED(indexes) ) DEALLOCATE(indexes)
    ALLOCATE(indexes(ntiles,4,2))
    indexes = 0 

    ! There will be four points to define a region, find all four.
    ! Need to call the correct function depending on if the tile is a
    ! pole tile or not.
    !
    ! Also, if looking for a single point, then use the a-grid
    IF ( latStart == latEnd .AND. lonStart == lonEnd ) THEN
       ! single point
       IF ( MOD(diag_global_grid%tile_number,3) == 0 ) THEN
          indexes(myTile,1,:) = find_pole_index_agrid(latStart,lonStart)
          indexes(myTile,2,:) = indexes(myTile,1,:)
          indexes(myTile,3,:) = indexes(myTile,1,:)
          indexes(myTile,4,:) = indexes(myTile,1,:)
       ELSE
          indexes(myTile,1,:) = find_equator_index_agrid(latStart,lonStart)
          indexes(myTile,2,:) = indexes(myTile,1,:)
          indexes(myTile,3,:) = indexes(myTile,1,:)
          indexes(myTile,4,:) = indexes(myTile,1,:)
       END IF
    ELSE
       ! multi-point
       IF ( MOD(diag_global_grid%tile_number,3) == 0 ) THEN
          ! Pole tile
          indexes(myTile,1,:) = find_pole_index(latStart, lonStart)
          indexes(myTile,2,:) = find_pole_index(latStart, lonEnd)
          indexes(myTile,3,:) = find_pole_index(latEnd, lonStart)
          indexes(myTile,4,:) = find_pole_index(latEnd, lonEnd)
       ELSE
          indexes(myTile,1,:) = find_equator_index(latStart, lonStart)
          indexes(myTile,2,:) = find_equator_index(latStart, lonEnd)
          indexes(myTile,3,:) = find_equator_index(latEnd, lonStart)
          indexes(myTile,4,:) = find_equator_index(latEnd, lonEnd)
       END IF
    END IF
    
    WHERE ( indexes(:,:,1) .NE. 0 )
       indexes(:,:,1) = indexes(:,:,1) + diag_global_grid%myXbegin - 1
    END WHERE
    WHERE ( indexes(:,:,2) .NE. 0 )
       indexes(:,:,2) = indexes(:,:,2) + diag_global_grid%myYbegin - 1
    END WHERE
    
    DO j = 1, 6 ! Each tile.
       DO i = 1, 4
          CALL mpp_max(indexes(j,i,1))
          CALL mpp_max(indexes(j,i,2))
       END DO
    END DO
    
    ! Are there any indexes found on this tile?
    ! Check if all points are on this tile
    ! Works since the find index functions return 0 if not found.
    IF (   PRODUCT(indexes(myTile,:,1)) /= 0 .OR.&
         & PRODUCT(indexes(myTile,:,2)) /= 0  ) THEN
       istart = MINVAL(indexes(myTile,:,1))
       jstart = MINVAL(indexes(myTile,:,2))
       iend = MAXVAL(indexes(myTile,:,1))
       jend = MAXVAL(indexes(myTile,:,2))
    ELSE
       istart = 0
       jstart = 0
       iend = 0
       jend = 0
    END IF

    DEALLOCATE(indexes)
  END SUBROUTINE get_local_indexes
  ! </SUBROUTINE>
  
  ! <SUBROUTINE NAME="get_local_indexes2">
  !   <OVERVIEW>
  !     Find the indices of the nearest grid point of the a-grid to the 
  !     specified (lon,lat) location on the local PE. if desired point not 
  !     within domain of local PE, return (0,0) as the indices. 
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_local_indexes2 (lat, lon, iindex, jindex)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given a specified location, find the nearest a-grid indices on 
  !     the local PE.
  !   </DESCRIPTION>
  !   <IN NAME="lat" TYPE="REAL">
  !     The requested latitude.  This value must be in the range [-90,90]
  !   </IN>
  !   <IN NAME="lon" TYPE="REAL">
  !     The requested longitude.
  !     Possible ranges are either [-180,180] or [0,360].
  !   </IN>
  !   <OUT NAME="iindex" TYPE="INTEGER">
  !     The local index on the local PE in the 'i' direction.
  !   </OUT>
  !   <OUT NAME="jindex" TYPE="INTEGER">
  !     The local index on the local PE in the 'j' direction.
  !   </OUT>
  SUBROUTINE get_local_indexes2(lat, lon, iindex, jindex)
    REAL, INTENT(in) :: lat, lon !< lat/lon location    
    INTEGER, INTENT(out) :: iindex, jindex !< i/j indexes

    INTEGER  :: indexes(2)
    INTEGER :: i, j

    IF ( .NOT. diag_grid_initialized )&
         & CALL error_mesg('diag_grid_mod::get_local_indexes2',&
         &'Module not initialized, first initialze module with a call &
         &to diag_grid_init', FATAL)
    
    indexes = 0 

    IF ( MOD(diag_global_grid%tile_number,3) == 0 ) THEN
       IF ( lat > 30.0 .AND. diag_global_grid%tile_number == 3 ) THEN
          indexes(:) = find_pole_index_agrid(lat,lon)
       ELSE IF ( lat < -30.0 .AND. diag_global_grid%tile_number == 6 ) THEN
          indexes(:) = find_pole_index_agrid(lat,lon)
       ENDIF
    ELSE
       indexes(:) = find_equator_index_agrid(lat,lon)
    END IF

    iindex = indexes(1)
    jindex = indexes(2)
    if (iindex ==  diag_global_grid%adimI -1 .or.&
        jindex ==  diag_global_grid%adimJ -1 ) then
      iindex = 0
      jindex = 0
    endif
           
  END SUBROUTINE get_local_indexes2
  ! </SUBROUTINE>

  ! <PRIVATE>
  ! <FUNCTION NAME="rad2deg">
  !   <OVERVIEW>
  !     Convert and angle in radian to degrees.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE ELEMENTAL REAL FUNCTION rad2deg(angle)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given a scalar, or an array of angles in radians this
  !     function will return a scalar or array (of the same
  !     dimension) of angles in degrees.
  !   </DESCRIPTION>
  !   <IN NAME="angle" TYPE="REAL">
  !     Scalar or array of angles in radians.
  !   </IN>
  !   <OUT NAME="rad2deg" TYPE="REAL">
  !     Scalar or array (depending on the size of angle) of angles in
  !     degrees.
  !   </OUT>
  PURE ELEMENTAL REAL FUNCTION rad2deg(angle)
    REAL, INTENT(in) :: angle

    rad2deg = RAD_TO_DEG * angle
  END FUNCTION rad2deg
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="deg2rad">
  !   <OVERVIEW>
  !     Convert an angle in degrees to radians.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE ELEMENTAL REAL FUNCTION deg2rad(angle)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given a scalar, or an array of angles in degrees this
  !     function will return a scalar or array (of the same
  !     dimension) of angles in radians.
  !   </DESCRIPTION>
  !   <IN NAME="angle" TYPE="REAL">
  !     Scalar or array of angles in degrees.
  !   </IN>
  PURE ELEMENTAL REAL FUNCTION deg2rad(angle)
    REAL, INTENT(in) :: angle

    deg2rad = DEG_TO_RAD * angle
  END FUNCTION deg2rad
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="find_pole_index">
  !   <OVERVIEW>
  !     Return the closest index (i,j) to the given (lat,lon) point.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE FUNCTION find_pole_index(lat, lon)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     This function searches a pole grid tile looking for the grid point
  !     closest to the give (lat, lon) location, and returns the i
  !     and j indexes of the point.
  !   </DESCRIPTION>
  !   <IN NAME="lat" TYPE="REAL">
  !     Latitude location
  !   </IN>
  !   <IN NAME="lon" TYPE="REAL">
  !     Longitude location
  !   </IN>
  !   <OUT NAME="find_pole_index" TYPE="INTEGER, DIMENSION(2)">
  !     The (i, j) location of the closest grid to the given (lat,
  !     lon) location.
  !   </OUT>
  PURE FUNCTION find_pole_index(lat, lon)
    INTEGER, DIMENSION(2) :: find_pole_index
    REAL, INTENT(in) :: lat, lon
    
    INTEGER :: indxI, indxJ !< Indexes to be returned.
    INTEGER :: dimI, dimJ !< Size of the grid dimensions
    INTEGER :: i,j !< Count indexes
    INTEGER :: nearestCorner !< index of the nearest corner
    INTEGER , DIMENSION(4,2) :: ijArray !< indexes of the cornerPts and pntDistances arrays
    REAL :: llat, llon !< Corrected lat and lon location (if looking for pole point.)
    REAL :: maxCtrDist !< maximum distance to the origPt to corner
    REAL, DIMENSION(4) :: pntDistances !< distance from origPt to corner
    REAL, DIMENSION(4,2) :: cornerPts !< Corner points using (lat,lon)
    TYPE(point) :: origPt !< Original point
    TYPE(point), DIMENSION(9) :: points !< xyz of 8 nearest neighbors
    REAL, DIMENSION(9) :: distSqrd !< distance between origPt and points(:)

    ! Set the inital fail values for indxI and indxJ
    indxI = 0
    indxJ = 0
    
    dimI = diag_global_grid%dimI
    dimJ = diag_global_grid%dimJ

    ! Since the poles have an non-unique longitude value, make a small correction if looking for one of the poles.
    IF ( lat == 90.0 ) THEN
       llat = lat - .1
    ELSE IF ( lat == -90.0 ) THEN
       llat = lat + .1
    ELSE
       llat = lat
    END IF
    llon = lon

    iLoop: DO i=1, dimI-1
       jLoop: DO j = 1, dimJ-1
          ! Get the lat,lon for the four corner points.
          cornerPts = RESHAPE( (/ diag_global_grid%glo_lat(i,  j),  diag_global_grid%glo_lon(i,  j),&
               &                  diag_global_grid%glo_lat(i+1,j+1),diag_global_grid%glo_lon(i+1,j+1),&
               &                  diag_global_grid%glo_lat(i+1,j),  diag_global_grid%glo_lon(i+1,j),&
               &                  diag_global_grid%glo_lat(i,  j+1),diag_global_grid%glo_lon(i,  j+1) /),&
               &               (/ 4, 2 /), ORDER=(/2,1/) )

          ! Find the maximum half distance of the corner points
          maxCtrDist = MAX(gCirDistance(cornerPts(1,1),cornerPts(1,2), cornerPts(2,1),cornerPts(2,2)),&
               &           gCirDistance(cornerPts(3,1),cornerPts(3,2), cornerPts(4,1),cornerPts(4,2)))/2
          ! Find the distance of the four corner points to the point of interest.
          pntDistances = gCirDistance(cornerPts(:,1),cornerPts(:,2), llat,llon)

          IF ( (MINVAL(pntDistances) <= maxCtrDist) .AND. (i*j.NE.0) ) THEN
             ! Set up the i,j index array
             ijArray = RESHAPE( (/ i, j, i+1, j+1, i+1, j, i, j+1 /), (/ 4, 2 /), ORDER=(/2,1/) )

             ! the nearest point index
             nearestCorner = MINLOC(pntDistances,1)

             indxI = ijArray(nearestCorner,1)
             indxJ = ijArray(nearestCorner,2)
             
             EXIT iLoop
          END IF
       END DO jLoop
    END DO iLoop
    
          
    ! Make sure we have indexes in the correct range
    valid: IF (  (indxI <= 0 .OR. dimI < indxI) .OR. &
         &       (indxJ <= 0 .OR. dimJ < indxJ) ) THEN
       indxI = 0
       indxJ = 0
    ELSE ! indxI and indxJ are valid.
       ! Since we are looking for the closest grid point to the
       ! (lat,lon) point, we need to check the surrounding
       ! points.  The indexes for the variable points are as follows
       ! 
       ! 1---4---7
       ! |   |   |
       ! 2---5---8
       ! |   |   |
       ! 3---6---9

       ! The original point
       origPt = latlon2xyz(lat,lon)

       ! Set the 'default' values for points(:) x,y,z to some large
       ! value.
       DO i=1, 9
          points(i)%x = 1.0e20
          points(i)%y = 1.0e20
          points(i)%z = 1.0e20
       END DO

       ! All the points around the i,j indexes
       IF ( indxI > 1 ) THEN
          points(1) = latlon2xyz(diag_global_grid%glo_lat(indxI-1,indxJ+1),&
               &                 diag_global_grid%glo_lon(indxI-1,indxJ+1))
          points(2) = latlon2xyz(diag_global_grid%glo_lat(indxI-1,indxJ),&
               &                 diag_global_grid%glo_lon(indxI-1,indxJ))
          IF ( indxJ > 1 ) THEN
             points(3) = latlon2xyz(diag_global_grid%glo_lat(indxI-1,indxJ-1),&
                  &                 diag_global_grid%glo_lon(indxI-1,indxJ-1))
          END IF
       END IF
       points(4) = latlon2xyz(diag_global_grid%glo_lat(indxI,  indxJ+1),&
            &                 diag_global_grid%glo_lon(indxI,  indxJ+1))
       points(5) = latlon2xyz(diag_global_grid%glo_lat(indxI,  indxJ),&
            &                 diag_global_grid%glo_lon(indxI,  indxJ))
       IF ( indxJ > 1 ) THEN
          points(6) = latlon2xyz(diag_global_grid%glo_lat(indxI,  indxJ-1),&
               &                 diag_global_grid%glo_lon(indxI,  indxJ-1))
       END IF
       points(7) = latlon2xyz(diag_global_grid%glo_lat(indxI+1,indxJ+1),&
            &                 diag_global_grid%glo_lon(indxI+1,indxJ+1))
       points(8) = latlon2xyz(diag_global_grid%glo_lat(indxI+1,indxJ),&
            &                 diag_global_grid%glo_lon(indxI+1,indxJ))
       IF ( indxJ > 1 ) THEN
          points(9) = latlon2xyz(diag_global_grid%glo_lat(indxI+1,indxJ-1),&
               &                 diag_global_grid%glo_lon(indxI+1,indxJ-1))
       END IF
          
       ! Calculate the distance squared between the points(:) and the origPt
       distSqrd = distanceSqrd(origPt, points)

       SELECT CASE (MINLOC(distSqrd,1))
       CASE ( 1 )
          indxI = indxI-1
          indxJ = indxJ+1
       CASE ( 2 )
          indxI = indxI-1
          indxJ = indxJ
       CASE ( 3 )
          indxI = indxI-1
          indxJ = indxJ-1
       CASE ( 4 )
          indxI = indxI
          indxJ = indxJ+1
       CASE ( 5 )
          indxI = indxI
          indxJ = indxJ
       CASE ( 6 )
          indxI = indxI
          indxJ = indxJ-1
       CASE ( 7 )
          indxI = indxI+1
          indxJ = indxJ+1
       CASE ( 8 )
          indxI = indxI+1
          indxJ = indxJ
       CASE ( 9 )
          indxI = indxI+1
          indxJ = indxJ-1
       CASE DEFAULT
          indxI = 0
          indxJ = 0
       END SELECT
    END IF valid
    
    ! Set the return value for the funtion
    find_pole_index = (/indxI, indxJ/)
  END FUNCTION find_pole_index
  ! </FUNCTION>
  ! </PRIVATE>
  
  ! <PRIVATE>
  ! <FUNCTION NAME="find_equator_index">
  !   <OVERVIEW>
  !     Return the closest index (i,j) to the given (lat,lon) point.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE FUNCTION find_equator_index(lat, lon)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     This function searches a equator grid tile looking for the grid point
  !     closest to the give (lat, lon) location, and returns the i
  !     and j indexes of the point.
  !   </DESCRIPTION>
  !   <IN NAME="lat" TYPE="REAL">
  !     Latitude location
  !   </IN>
  !   <IN NAME="lon" TYPE="REAL">
  !     Longitude location
  !   </IN>
  !   <OUT NAME="find_equator_index" TYPE="INTEGER, DIMENSION(2)">
  !     The (i, j) location of the closest grid to the given (lat,
  !     lon) location.
  !   </OUT>
  PURE FUNCTION find_equator_index(lat, lon)
    INTEGER, DIMENSION(2) :: find_equator_index
    REAL, INTENT(in) :: lat, lon
    
    INTEGER :: indxI, indxJ !< Indexes to be returned.
    INTEGER :: indxI_tmp !< Hold the indxI value if on tile 3 or 4
    INTEGER :: dimI, dimJ !< Size of the grid dimensions
    INTEGER :: i,j !< Count indexes
    INTEGER :: jstart, jend, nextj !< j counting variables
    TYPE(point) :: origPt !< Original point
    TYPE(point), DIMENSION(4) :: points !< xyz of 8 nearest neighbors
    REAL, DIMENSION(4) :: distSqrd !< distance between origPt and points(:)

    ! Set the inital fail values for indxI and indxJ
    indxI = 0
    indxJ = 0
    
    dimI = diag_global_grid%dimI
    dimJ = diag_global_grid%dimJ

    ! check to see if the 'fix' for the latitude index is needed
    IF ( diag_global_grid%glo_lat(1,1) > &
         &diag_global_grid%glo_lat(1,2) ) THEN
       ! reverse the j search
       jstart = dimJ
       jend = 2
       nextj = -1
    ELSE
       jstart = 1
       jend = dimJ-1
       nextJ = 1
    END IF

    ! find the I index
    iLoop: DO i=1, dimI-1
       IF (   diag_global_grid%glo_lon(i,1) >&
            & diag_global_grid%glo_lon(i+1,1) ) THEN
          ! We are at the 0 longitudal line
          IF (   (diag_global_grid%glo_lon(i,1) <= lon .AND. lon <= 360) .OR.&
               & (0 <= lon .AND. lon < diag_global_grid%glo_lon(i+1, 1)) ) THEN
             indxI = i
             EXIT iLoop
          END IF
       ELSEIF ( diag_global_grid%glo_lon(i,1) <= lon .AND.&
            &   lon <= diag_global_grid%glo_lon(i+1,1) ) THEN
          indxI = i
          EXIT iLoop
       END IF
    END DO iLoop
    
    ! Find the J index
    IF ( indxI > 0 ) THEN
       jLoop: DO j=jstart, jend, nextj
          IF (   diag_global_grid%glo_lat(indxI,j) <= lat .AND.&
               & lat <= diag_global_grid%glo_lat(indxI,j+nextj) ) THEN
             indxJ = j
             EXIT jLoop
          END IF
       END DO jLoop
    END IF

    ! Make sure we have indexes in the correct range
    valid: IF ( (indxI <= 0 .OR. dimI < indxI) .OR. &
         &      (indxJ <= 0 .OR. dimJ < indxJ) ) THEN
       indxI = 0
       indxJ = 0
    ELSE ! indxI and indxJ are valid.    
       ! Since we are looking for the closest grid point to the
       ! (lat,lon) point, we need to check the surrounding
       ! points.  The indexes for the variable points are as follows
       ! 
       ! 1---3
       ! |   |
       ! 2---4

       ! The original point
       origPt = latlon2xyz(lat,lon)

       ! Set the 'default' values for points(:) x,y,z to some large
       ! value.
       DO i=1, 4
          points(i)%x = 1.0e20
          points(i)%y = 1.0e20
          points(i)%z = 1.0e20
       END DO
       
       ! The original point
       origPt = latlon2xyz(lat,lon)

       points(1) = latlon2xyz(diag_global_grid%glo_lat(indxI,indxJ),&
            &                 diag_global_grid%glo_lon(indxI,indxJ))
       points(2) = latlon2xyz(diag_global_grid%glo_lat(indxI,indxJ+nextj),&
            &                 diag_global_grid%glo_lon(indxI,indxJ+nextj))
       points(3) = latlon2xyz(diag_global_grid%glo_lat(indxI+1,indxJ+nextj),&
            &                 diag_global_grid%glo_lon(indxI+1,indxJ+nextj))
       points(4) = latlon2xyz(diag_global_grid%glo_lat(indxI+1,indxJ),&
            &                 diag_global_grid%glo_lon(indxI+1,indxJ))
  
       ! Find the distance between the original point and the four
       ! grid points
       distSqrd = distanceSqrd(origPt, points)  
  
       SELECT CASE (MINLOC(distSqrd,1))
       CASE ( 1 )
          indxI = indxI;
          indxJ = indxJ;
       CASE ( 2 )
          indxI = indxI;
          indxJ = indxJ+nextj;
       CASE ( 3 )
          indxI = indxI+1;
          indxJ = indxJ+nextj;
       CASE ( 4 )
          indxI = indxI+1;
          indxJ = indxJ;
       CASE DEFAULT
          indxI = 0;
          indxJ = 0;
       END SELECT

       ! If we are on tile 3 or 4, then the indxI and indxJ are
       ! reversed due to the transposed grids.
       IF (   diag_global_grid%tile_number == 4 .OR.&
            & diag_global_grid%tile_number == 5 ) THEN
          indxI_tmp = indxI
          indxI = indxJ
          indxJ = indxI_tmp
       END IF
    END IF valid

    ! Set the return value for the function
    find_equator_index = (/indxI, indxJ/)
  END FUNCTION find_equator_index
  ! </FUNCTION>
  ! </PRIVATE>
  
  ! <PRIVATE>
  ! <FUNCTION NAME="find_pole_index_agrid">
  !   <OVERVIEW>
  !     Return the closest index (i,j) to the given (lat,lon) point.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE FUNCTION find_pole_index_agrid(lat, lon)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     This function searches a pole a-grid tile looking for the grid point
  !     closest to the give (lat, lon) location, and returns the i
  !     and j indexes of the point.
  !   </DESCRIPTION>
  !   <IN NAME="lat" TYPE="REAL">
  !     Latitude location
  !   </IN>
  !   <IN NAME="lon" TYPE="REAL">
  !     Longitude location
  !   </IN>
  !   <OUT NAME="find_pole_index" TYPE="INTEGER, DIMENSION(2)">
  !     The (i, j) location of the closest grid to the given (lat,
  !     lon) location.
  !   </OUT>
  PURE FUNCTION find_pole_index_agrid(lat, lon)
    INTEGER, DIMENSION(2) :: find_pole_index_agrid
    REAL, INTENT(in) :: lat, lon
    
    INTEGER :: indxI, indxJ !< Indexes to be returned.
    INTEGER :: dimI, dimJ !< Size of the grid dimensions
    INTEGER :: i,j !< Count indexes
    INTEGER :: nearestCorner !< index of the nearest corner.
    INTEGER, DIMENSION(4,2) :: ijArray !< indexes of the cornerPts and pntDistances arrays
    REAL :: llat, llon
    REAL :: maxCtrDist !< maximum distance to center of grid
    REAL, DIMENSION(4) :: pntDistances !< distance from origPt to corner
    TYPE(point) :: origPt !< Original point
    REAL, DIMENSION(4,2) :: cornerPts !< Corner points using (lat,lon)
    TYPE(point), DIMENSION(9) :: points !< xyz of 8 nearest neighbors
    REAL, DIMENSION(9) :: distSqrd !< distance between origPt and points(:)

    ! Set the inital fail values for indxI and indxJ
    indxI = 0
    indxJ = 0
    
    dimI = diag_global_grid%adimI
    dimJ = diag_global_grid%adimJ

    ! Since the poles have an non-unique longitude value, make a small correction if looking for one of the poles.
    IF ( lat == 90.0 ) THEN
       llat = lat - .1
    ELSE IF ( lat == -90.0 ) THEN
       llat = lat + .1
    ELSE
       llat = lat
    END IF
    llon = lon

    origPt = latlon2xyz(llat,llon)

    iLoop: DO i=0, dimI-2
       jLoop: DO j = 0, dimJ-2
          cornerPts = RESHAPE( (/ diag_global_grid%aglo_lat(i,  j),  diag_global_grid%aglo_lon(i,  j),&
               &                  diag_global_grid%aglo_lat(i+1,j+1),diag_global_grid%aglo_lon(i+1,j+1),&
               &                  diag_global_grid%aglo_lat(i+1,j),  diag_global_grid%aglo_lon(i+1,j),&
               &                  diag_global_grid%aglo_lat(i,  j+1),diag_global_grid%aglo_lon(i,  j+1) /),&
               &               (/ 4, 2 /), ORDER=(/2,1/) )
          ! Find the maximum half distance of the corner points
          maxCtrDist = MAX(gCirDistance(cornerPts(1,1),cornerPts(1,2), cornerPts(2,1),cornerPts(2,2)),&
               &           gCirDistance(cornerPts(3,1),cornerPts(3,2), cornerPts(4,1),cornerPts(4,2)))

          ! Find the distance of the four corner points to the point of interest.
          pntDistances = gCirDistance(cornerPts(:,1),cornerPts(:,2), llat,llon)

          IF ( (MINVAL(pntDistances) <= maxCtrDist) .AND. (i*j.NE.0) ) THEN
             ! Set up the i,j index array
             ijArray = RESHAPE( (/ i, j, i+1, j+1, i+1, j, i, j+1 /), (/ 4, 2 /), ORDER=(/2,1/) )

             ! the nearest point index
             nearestCorner = MINLOC(pntDistances,1)

             indxI = ijArray(nearestCorner,1)
             indxJ = ijArray(nearestCorner,2)
             
             EXIT iLoop
          END IF
       END DO jLoop
    END DO iLoop
    
          
    ! Make sure we have indexes in the correct range
    valid: IF (  (indxI <= 0 .OR. dimI-1 <= indxI) .OR. &
         &       (indxJ <= 0 .OR. dimJ-1 <= indxJ) ) THEN
       indxI = 0
       indxJ = 0
    ELSE ! indxI and indxJ are valid.
       ! Since we are looking for the closest grid point to the
       ! (lat,lon) point, we need to check the surrounding
       ! points.  The indexes for the variable points are as follows
       ! 
       ! 1---4---7
       ! |   |   |
       ! 2---5---8
       ! |   |   |
       ! 3---6---9

       ! Set the 'default' values for points(:) x,y,z to some large
       ! value.
       DO i=1, 9
          points(i)%x = 1.0e20
          points(i)%y = 1.0e20
          points(i)%z = 1.0e20
       END DO

       ! All the points around the i,j indexes
       points(1) = latlon2xyz(diag_global_grid%aglo_lat(indxI-1,indxJ+1),&
            &                 diag_global_grid%aglo_lon(indxI-1,indxJ+1))
       points(2) = latlon2xyz(diag_global_grid%aglo_lat(indxI-1,indxJ),&
            &                 diag_global_grid%aglo_lon(indxI-1,indxJ))
       points(3) = latlon2xyz(diag_global_grid%aglo_lat(indxI-1,indxJ-1),&
            &                 diag_global_grid%aglo_lon(indxI-1,indxJ-1))
       points(4) = latlon2xyz(diag_global_grid%aglo_lat(indxI,  indxJ+1),&
            &                 diag_global_grid%aglo_lon(indxI,  indxJ+1))
       points(5) = latlon2xyz(diag_global_grid%aglo_lat(indxI,  indxJ),&
            &                 diag_global_grid%aglo_lon(indxI,  indxJ))
       points(6) = latlon2xyz(diag_global_grid%aglo_lat(indxI,  indxJ-1),&
            &                 diag_global_grid%aglo_lon(indxI,  indxJ-1))
       points(7) = latlon2xyz(diag_global_grid%aglo_lat(indxI+1,indxJ+1),&
            &                 diag_global_grid%aglo_lon(indxI+1,indxJ+1))
       points(8) = latlon2xyz(diag_global_grid%aglo_lat(indxI+1,indxJ),&
            &                 diag_global_grid%aglo_lon(indxI+1,indxJ))
       points(9) = latlon2xyz(diag_global_grid%aglo_lat(indxI+1,indxJ-1),&
            &                 diag_global_grid%aglo_lon(indxI+1,indxJ-1))

          
       ! Calculate the distance squared between the points(:) and the origPt
       distSqrd = distanceSqrd(origPt, points)

       SELECT CASE (MINLOC(distSqrd,1))
       CASE ( 1 )
          indxI = indxI-1
          indxJ = indxJ+1
       CASE ( 2 )
          indxI = indxI-1
          indxJ = indxJ
       CASE ( 3 )
          indxI = indxI-1
          indxJ = indxJ-1
       CASE ( 4 )
          indxI = indxI
          indxJ = indxJ+1
       CASE ( 5 )
          indxI = indxI
          indxJ = indxJ
       CASE ( 6 )
          indxI = indxI
          indxJ = indxJ-1
       CASE ( 7 )
          indxI = indxI+1
          indxJ = indxJ+1
       CASE ( 8 )
          indxI = indxI+1
          indxJ = indxJ
       CASE ( 9 )
          indxI = indxI+1
          indxJ = indxJ-1
       CASE DEFAULT
          indxI = 0
          indxJ = 0
       END SELECT
    END IF valid
    
    ! Set the return value for the funtion
    find_pole_index_agrid = (/indxI, indxJ/)
  END FUNCTION find_pole_index_agrid
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="find_equator_index_agrid">
  !   <OVERVIEW>
  !     Return the closest index (i,j) to the given (lat,lon) point.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE FUNCTION find_equator_index_agrid(lat, lon)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     This function searches a equator grid tile looking for the grid point
  !     closest to the give (lat, lon) location, and returns the i
  !     and j indexes of the point.
  !   </DESCRIPTION>
  !   <IN NAME="lat" TYPE="REAL">
  !     Latitude location
  !   </IN>
  !   <IN NAME="lon" TYPE="REAL">
  !     Longitude location
  !   </IN>
  !   <OUT NAME="find_equator_index" TYPE="INTEGER, DIMENSION(2)">
  !     The (i, j) location of the closest grid to the given (lat,
  !     lon) location.
  !   </OUT>
  PURE FUNCTION find_equator_index_agrid(lat, lon)
    INTEGER, DIMENSION(2) :: find_equator_index_agrid
    REAL, INTENT(in) :: lat, lon
    
    INTEGER :: indxI, indxJ !< Indexes to be returned.
    INTEGER :: indxI_tmp !< Hold the indxI value if on tile 3 or 4
    INTEGER :: dimI, dimJ !< Size of the grid dimensions
    INTEGER :: i,j !< Count indexes
    INTEGER :: jstart, jend, nextj !< j counting variables
    TYPE(point) :: origPt !< Original point
    TYPE(point), DIMENSION(4) :: points !< xyz of 8 nearest neighbors
    REAL, DIMENSION(4) :: distSqrd !< distance between origPt and points(:)

    ! Set the inital fail values for indxI and indxJ
    indxI = 0
    indxJ = 0
    
    dimI = diag_global_grid%adimI
    dimJ = diag_global_grid%adimJ

    ! check to see if the 'fix' for the latitude index is needed
    IF ( diag_global_grid%aglo_lat(1,1) > &
         &diag_global_grid%aglo_lat(1,2) ) THEN
       ! reverse the j search
       jstart = dimJ-1
       jend = 1
       nextj = -1
    ELSE
       jstart = 0
       jend = dimJ-2
       nextJ = 1
    END IF

    ! find the I index
    iLoop: DO i=0, dimI-2
       IF (   diag_global_grid%aglo_lon(i,0) >&
            & diag_global_grid%aglo_lon(i+1,0) ) THEN
          ! We are at the 0 longitudal line
          IF (   (diag_global_grid%aglo_lon(i,0) <= lon .AND. lon <= 360) .OR.&
               & (0 <= lon .AND. lon < diag_global_grid%aglo_lon(i+1, 0)) ) THEN
             indxI = i
             EXIT iLoop
          END IF
       ELSEIF ( diag_global_grid%aglo_lon(i,0) <= lon .AND.&
            &   lon <= diag_global_grid%aglo_lon(i+1,0) ) THEN
          indxI = i
          EXIT iLoop
       END IF
    END DO iLoop
    
    ! Find the J index
    IF ( indxI > 0 ) THEN
       jLoop: DO j=jstart, jend, nextj
          IF (   diag_global_grid%aglo_lat(indxI,j) <= lat .AND.&
               & lat <= diag_global_grid%aglo_lat(indxI,j+nextj) ) THEN
             indxJ = j
             EXIT jLoop
          END IF
       END DO jLoop
    END IF

    ! Make sure we have indexes in the correct range
    valid: IF ( (indxI <= 0 .OR. dimI-1 < indxI) .OR. &
         &      (indxJ <= 0 .OR. dimJ-1 < indxJ) ) THEN
       indxI = 0
       indxJ = 0
    ELSE ! indxI and indxJ are valid.    
       ! Since we are looking for the closest grid point to the
       ! (lat,lon) point, we need to check the surrounding
       ! points.  The indexes for the variable points are as follows
       ! 
       ! 1---3
       ! |   |
       ! 2---4

       ! The original point
       origPt = latlon2xyz(lat,lon)

       ! Set the 'default' values for points(:) x,y,z to some large
       ! value.
       DO i=1, 4
          points(i)%x = 1.0e20
          points(i)%y = 1.0e20
          points(i)%z = 1.0e20
       END DO
       
       ! The original point
       origPt = latlon2xyz(lat,lon)

       points(1) = latlon2xyz(diag_global_grid%aglo_lat(indxI,indxJ),&
            &                 diag_global_grid%aglo_lon(indxI,indxJ))
       points(2) = latlon2xyz(diag_global_grid%aglo_lat(indxI,indxJ+nextj),&
            &                 diag_global_grid%aglo_lon(indxI,indxJ+nextj))
       points(3) = latlon2xyz(diag_global_grid%aglo_lat(indxI+1,indxJ+nextj),&
            &                 diag_global_grid%aglo_lon(indxI+1,indxJ+nextj))
       points(4) = latlon2xyz(diag_global_grid%aglo_lat(indxI+1,indxJ),&
            &                 diag_global_grid%aglo_lon(indxI+1,indxJ))
  
       ! Find the distance between the original point and the four
       ! grid points
       distSqrd = distanceSqrd(origPt, points)  
  
       SELECT CASE (MINLOC(distSqrd,1))
       CASE ( 1 )
          indxI = indxI;
          indxJ = indxJ;
       CASE ( 2 )
          indxI = indxI;
          indxJ = indxJ+nextj;
       CASE ( 3 )
          indxI = indxI+1;
          indxJ = indxJ+nextj;
       CASE ( 4 )
          indxI = indxI+1;
          indxJ = indxJ;
       CASE DEFAULT
          indxI = 0;
          indxJ = 0;
       END SELECT

       ! If we are on tile 3 or 4, then the indxI and indxJ are
       ! reversed due to the transposed grids.
       IF (   diag_global_grid%tile_number == 4 .OR.&
            & diag_global_grid%tile_number == 5 ) THEN
          indxI_tmp = indxI
          indxI = indxJ
          indxJ = indxI_tmp
       END IF
    END IF valid

    ! Set the return value for the function
    find_equator_index_agrid = (/indxI, indxJ/)
  END FUNCTION find_equator_index_agrid
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="latlon2xyz">
  !   <OVERVIEW>
  !     Return the (x,y,z) position of a given (lat,lon) point.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE ELEMENTAL TYPE(point) FUNCTION latlon2xyz(lat, lon)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given a specific (lat, lon) point on the Earth, return the
  !     corresponding (x,y,z) location.  The return of latlon2xyz
  !     will be either a scalar or an array of the same size as lat
  !     and lon.
  !   </DESCRIPTION>
  !   <IN NAME="lat" TYPE="REAL">
  !     The latitude of the (x,y,z) location to find.  <TT>lat</TT>
  !     can be either a scalar or array.  <TT>lat</TT> must be of the
  !     same rank / size as <TT>lon</TT>.  This function assumes
  !     <TT>lat</TT> is in the range [-90,90].
  !   </IN>
  !   <IN NAME="lon" TYPE="REAL">
  !     The longitude of the (x,y,z) location to find.  <TT>lon</TT>
  !     can be either a scalar or array.  <TT>lon</TT> must be of the
  !     same rank / size as <TT>lat</TT>.  This function assumes
  !     <TT>lon</TT> is in the range [0,360].
  !   </IN>
  PURE ELEMENTAL TYPE(point) FUNCTION latlon2xyz(lat, lon)
    REAL, INTENT(in) :: lat, lon

    ! lat/lon angles in radians
    REAL :: theta, phi

    ! Convert the lat lon values to radians The lat values passed in
    ! are in the range [-90,90], but we need to have a radian range
    ! [0,pi], where 0 is at the north pole.  This is the reason for
    ! the subtraction from 90
    theta = deg2rad(90-lat)
    phi = deg2rad(lon)

    ! Calculate the x,y,z point
    latlon2xyz%x = RADIUS * SIN(theta) * COS(phi)
    latlon2xyz%y = RADIUS * SIN(theta) * SIN(phi)
    latlon2xyz%z = RADIUS * COS(theta)
  END FUNCTION latlon2xyz
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="distanceSqrd">
  !   <OVERVIEW>
  !     Find the distance between two points in the Cartesian
  !     coordinate space.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE ELEMENTAL REAL FUNCTION distanceSqrd(pt1, pt2)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>distanceSqrd</TT> will find the distance squared between
  !     two points in the xyz coordinate space.  <TT>pt1</TT> and <TT>
  !     pt2</TT> can either be both scalars, both arrays of the same
  !     size, or one a scalar and one an array.  The return value
  !     will be a scalar or array of the same size as the input array.
  !   </DESCRIPTION>
  !   <IN NAME="pt1" TYPE="TYPE(POINT)" />
  !   <IN NAME="pt2" TYPE="TYPE(POINT)" />
  PURE ELEMENTAL REAL FUNCTION distanceSqrd(pt1, pt2)
    TYPE(point), INTENT(in) :: pt1, pt2

    distanceSqrd = (pt1%x-pt2%x)**2 +&
         &         (pt1%y-pt2%y)**2 +&
         &         (pt1%z-pt2%z)**2
  END FUNCTION distanceSqrd
  ! </FUNCTION>
  ! </PRIVATE>

  ! <FUNCTION NAME="gCirDistance">
  !   <OVERVIEW>
  !     Find the distance, along the geodesic, between two points.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE ELEMENTAL REAL FUNCTION gCirDistance(lat1, lon1, lat2, lon2)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>aCirDistance</TT> will find the distance, along the geodesic, between two points defined by the (lat,lon) position of
  !     each point.
  !   </DESCRIPTION>
  !   <IN NAME="lat1" TYPE="REAL">Latitude of the first point</IN>
  !   <IN NAME="lon1" TYPE="REAL">Longitude of the first point</IN>
  !   <IN NAME="lat2" TYPE="REAL">Latitude of the second point</IN>
  !   <IN NAME="lon2" TYPE="REAL">Longitude of the second point</IN>
  PURE ELEMENTAL REAL FUNCTION gCirDistance(lat1, lon1, lat2, lon2)
    REAL, INTENT(in) :: lat1, lat2, lon1, lon2

    REAL :: theta1, theta2
    REAL :: deltaLambda !< Difference in longitude angles, in radians.
    REAL :: deltaTheta !< Difference in latitude angels, in radians.

    theta1 = deg2rad(lat1)
    theta2 = deg2rad(lat2)
    deltaLambda = deg2rad(lon2-lon1)
    deltaTheta = deg2rad(lat2-lat1)

    gCirDistance = RADIUS * 2 * ASIN(SQRT((SIN(deltaTheta/2))**2 + COS(theta1)*COS(theta2)*(SIN(deltaLambda/2))**2))
  END FUNCTION gCirDistance
  ! </FUNCTION>
END MODULE diag_grid_mod


#include <fms_platform.h>

MODULE diag_manager_mod
  ! <CONTACT EMAIL="Matthew.Harrison@gfdl.noaa.gov">
  !   Matt Harrison
  ! </CONTACT>
  ! <CONTACT EMAIL="Giang.Nong@noaa.gov">
  !   Giang Nong
  ! </CONTACT>
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>
  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/" />
  ! <OVERVIEW>
  !   <TT>diag_manager_mod</TT> is a set of simple calls for parallel diagnostics
  !   on distributed systems. It is geared toward the writing of data in netCDF
  !   format.
  ! </OVERVIEW>
  ! <DESCRIPTION>
  !   <TT>diag_manager_mod</TT> provides a convenient set of interfaces for
  !   writing data to disk.  It is built upon the parallel I/O interface of FMS
  !   code <TT>/shared/mpp/mpp_io.F90</TT>.
  !
  !   A single group of calls to the <TT>diag_manager_mod</TT> interfaces
  !   provides data to disk at any number of sampling and/or averaging intervals
  !   specified at run-time. Run-time specification of diagnostics are input
  !   through the diagnostics table.
  !
  !   <H4>Usage</H4>
  !   Use of <TT>diag_manager</TT> includes the following steps:
  !   <OL>
  !     <LI> Create diag_table as described in the
  !          <LINK SRC="diag_table.html">diag_table.F90</LINK>
  !          documentation.</LI>
  !     <LI> Call <LINK SRC="#diag_manager_init"><TT>diag_manager_init</TT></LINK> to initialize
  !          diag_manager_mod.</LI>
  !     <LI> Call <LINK SRC="#register_diag_field"><TT>register_diag_field</TT></LINK> to register the field to be
  !          output.
  !          <B>NOTE:</B> ALL fields in diag_table should be registered <I>BEFORE</I>
  !          the first send_data call</LI>
  !     <LI> Call <LINK SRC="#send_data"><TT>send_data</TT></LINK> to send data to output fields </LI>
  !     <LI> Call <LINK SRC="#diag_manager_end"><TT>diag_manager_end</TT></LINK> to exit diag_manager </LI>
  !   </OL>
  !
  !   <H4>Features</H4>
  !   Features of <TT>diag_manager_mod</TT>:
  !   <OL>
  !     <LI> Ability to output from 0D arrays (scalars) to 3D arrays.</LI>
  !     <LI> Ability to output time average of fields that have time dependent
  !          mask.</LI>
  !     <LI> Give optional warning if <TT>register_diag_field</TT> fails due to
  !          misspelled module name or field name.</LI>
  !     <LI> Check if a field is registered twice.</LI>
  !     <LI> Check for duplicate lines in diag_table. </LI>
  !     <LI> <LINK SRC="diag_table.html">diag_table</LINK> can contain fields
  !          that are NOT written to any files. The file name in diag_table of
  !          these fields is <TT>null</TT>.</LI>
  !     <LI> By default, a field is output in its global grid.  The user can now 
  !          output a field in a specified region.  See
  !          <LINK SRC="#send_data"><TT>send_data</TT></LINK> for more details.</LI>
  !     <LI> To check if the diag table is set up correctly, user should set
  !          <TT>debug_diag_manager=.true.</TT> in diag_manager namelist, then
  !          the the content of diag_table is printed in stdout.</LI>
  !     <LI> New optional format of file information in <LINK SRC="diag_table.html">diag_table</LINK>.It is possible to have just
  !          one file name and reuse it many times. A time string will be appended to the base file name each time a new file is
  !          opened. The time string can be any combination from year to second of current model time.
  !
  !          Here is an example file line: <BR />
  !          <PRE>"file2_yr_dy%1yr%3dy",2,"hours",1,"hours","Time", 10, "days", "1 1 7 0 0 0", 6, "hours"</PRE>
  !          <BR />
  !
  !          From left to right we have: 
  !          <UL>
  !            <LI>file name</LI> 
  !            <LI>output frequency</LI>
  !            <LI>output frequency unit</LI>
  !            <LI>Format (should always be 1)</LI>
  !            <LI>time axis unit</LI>
  !            <LI>time axis name</LI>
  !            <LI>frequency for creating new file</LI>
  !            <LI>unit for creating new file</LI>
  !            <LI>start time of the new file</LI>
  !            <LI>file duration</LI>
  !            <LI>file duration unit.</LI>
  !          </UL>
  !          The 'file duration', if absent, will be equal to frequency for creating a new file.
  !
  !          Thus, the above means: create a new file every 10 days, each file will last 6 hours from creation time, no files will
  !          be created before time "1 1 7 0 0 0".
  !
  !          In this example the string
  !          <TT>10, "days", "1 1 7 0 0 0", 6, "hours"</TT> is optional.
  !
  !          Keywords for the time string suffix is
  !          <TT>%xyr,%xmo,%xdy,%xhr,%xmi,%xsc</TT> where <TT>x</TT> is a
  !          mandatory 1 digit number specifying the width of field used in
  !          writing the string</LI>
  !     <LI> New time axis for time averaged fields.  Users can use a namelist option to handle the time value written
  !          to time axis for time averaged fields.
  !
  !          If <TT>mix_snapshot_average_fields=.true.</TT> then a time averaged file will have time values corresponding to
  !          ending time_bound e.g. January monthly average is labeled Feb01. Users can have both snapshot and averaged fields in
  !          one file.
  !
  !          If <TT>mix_snapshot_average_fields=.false.</TT> The time value written to time axis for time averaged fields is the
  !          middle on the averaging time. For example, January monthly mean will be written at Jan 16 not Feb 01 as
  !          before. However, to use this new feature users should <B>separate</B> snapshot fields and time averaged fields in
  !          <B>different</B> files or a fatal error will occur.
  !
  !          The namelist <B>default</B> value is <TT>mix_snapshot_average_fields=.false.</TT></LI>
  !     <LI> Time average, Max and Min, and diurnal. In addition to time average users can also get then Max or Min value
  !          during the same interval of time as time average. For this purpose, in the diag table users must replace
  !          <TT>.true.</TT> or <TT>.false.</TT> by "<TT>max</TT>" or "<TT>min</TT>".  <B><I>Note:</I></B> Currently, max
  !          and min are not available for regional output.
  !
  !          A diurnal average can also be requested using <TT>diurnal##</TT> where <TT>##</TT> are the number of diurnal
  !          sections to average.</LI>
  !     <LI> <TT>standard_name</TT> is added as optional argument in <LINK SRC="#register_diag_field"><TT>register_diag_field</TT>
  !          </LINK>.</LI>
  !     <LI>When namelist variable <TT>debug_diag_manager = .true.</TT> array
  !         bounds are checked in <LINK SRC="#send_data"><TT>send_data</TT></LINK>.</LI>
  !     <LI>Coordinate attributes can be written in the output file if the
  !         argument "<TT>aux</TT>" is given in <LINK SRC="diag_axis.html#diag_axis_init"><TT>diag_axis_init</TT></LINK>. The
  !         corresponding fields (geolat/geolon) should also be written to the
  !         same file.</LI>
  !   </OL>
  !
  ! </DESCRIPTION>

  ! <NAMELIST NAME="diag_manager_nml">
  !   <DATA NAME="append_pelist_name" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   </DATA>
  !   <DATA NAME="mix_snapshot_average_fields" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !     Set to .TRUE. to allow both time average and instantaneous fields in the same output file.
  !   </DATA>
  !   <DATA NAME="max_files" TYPE="INTEGER" DEFULT="31">
  !   </DATA>
  !   <DATA NAME="max_output_fields" TYPE="INTEGER" DEFAULT="300">
  !   </DATA>
  !   <DATA NAME="max_input_fields" TYPE="INTEGER" DEFAULT="300">
  !   </DATA>
  !   <DATA NAME="max_axes" TYPE="INTEGER" DEFAULT="60">
  !   </DATA>
  !   <DATA NAME="do_diag_field_log" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   </DATA>
  !   <DATA NAME="write_bytes_in_files" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   </DATA>
  !   <DATA NAME="debug_diag_manager" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !   </DATA>
  !   <DATA NAME="max_num_axis_sets" TYPE="INTEGER" DEFAULT="25">
  !   </DATA>
  !   <DATA NAME="use_cmor" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !     Let the <TT>diag_manager</TT> know if the missing value (if supplied) should be overridden to be the
  !     CMOR standard value of -1.0e20.
  !   </DATA>
  !   <DATA NAME="issue_oor_warnings" TYPE="LOGICAL" DEFAULT=".TRUE.">
  !     If <TT>.TRUE.</TT>, then the <TT>diag_manager</TT> will check for values outside the valid range.  This range is defined in
  !     the model, and passed to the <TT>diag_manager_mod</TT> via the OPTIONAL variable range in the <TT>register_diag_field</TT>
  !     function.
  !   </DATA>
  !   <DATA NAME="oor_warnings_fatal" TYPE="LOGICAL" DEFAULT=".FALSE.">
  !     If <TT>.TRUE.</TT> then <TT>diag_manager_mod</TT> will issue a <TT>FATAL</TT> error if any values for the output field are
  !     outside the given range.
  !   </DATA>
  ! </NAMELIST>

  USE time_manager_mod, ONLY: set_time, set_date, OPERATOR(>=), OPERATOR(>), OPERATOR(<),&
       & OPERATOR(==), OPERATOR(/=), time_type, month_name, get_calendar_type, NO_CALENDAR,&
       & OPERATOR(/), OPERATOR(+), get_time
  USE mpp_io_mod, ONLY: mpp_open, MPP_RDONLY, MPP_ASCII, mpp_close, mpp_get_field_name
  USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdlog, write_version_number,&
       & file_exist, mpp_pe, check_nml_error, lowercase, stdout, mpp_error,&
       & fms_error_handler
#ifdef INTERNAL_FILE_NML
  USE mpp_mod, ONLY: input_nml_file
#else
  USE fms_mod, ONLY: open_namelist_file, close_file
#endif

  USE mpp_mod, ONLY: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_sum, mpp_chksum, stdout
  USE diag_axis_mod, ONLY: diag_axis_init, get_axis_length, max_axes, get_axis_num
  USE diag_util_mod, ONLY: get_subfield_size, log_diag_field_info, update_bounds,&
       & check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,&
       & init_file, diag_time_inc, find_input_field, init_input_field, init_output_field,&
       & diag_data_out, write_static, check_duplicate_output_fields, get_date_dif,&
       & get_subfield_vert_size, sync_file_times
  USE diag_data_mod, ONLY: max_files, CMOR_MISSING_VALUE, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, EVERY_TIME,&
       & END_OF_RUN, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, num_files,&
       & max_input_fields, max_output_fields, num_output_fields, EMPTY, FILL_VALUE, null_axis_id,&
       & MAX_VALUE, MIN_VALUE, base_time, base_year, base_month, base_day,&
       & base_hour, base_minute, base_second, global_descriptor, coord_type, files, input_fields,&
       & output_fields, Time_zero, append_pelist_name, mix_snapshot_average_fields,&
       & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
       & diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,&
       & use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, filename_appendix
  USE diag_table_mod, ONLY: parse_diag_table
  USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
  USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
  USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: diag_manager_init, send_data, send_tile_averaged_data, diag_manager_end,&
       & register_diag_field, register_static_field, diag_axis_init, get_base_time, get_base_date,&
       & need_data, average_tiles, DIAG_ALL, DIAG_OCEAN, DIAG_OTHER, get_date_dif, DIAG_SECONDS,&
       & DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, get_diag_global_att,&
       & set_diag_global_att
  ! Public interfaces from diag_grid_mod
  PUBLIC :: diag_grid_init, diag_grid_end
  PUBLIC :: set_diag_filename_appendix
  PUBLIC :: diag_manager_set_time_end, diag_send_complete

  ! version number of this module
  CHARACTER(len=128), PARAMETER :: version =&
       & '$Id: diag_manager.F90,v 18.0.2.17.2.1.4.1 2011/12/12 19:30:45 Peter.Phillipps Exp $'
  CHARACTER(len=128), PARAMETER :: tagname =&
       & '$Name:  $'  

  type(time_type) :: Time_end

  ! <INTERFACE NAME="send_data">
  !   <TEMPLATE>
  !     send_data(diag_field_id, field, time, is_in, js_in, ks_in,
  !             mask, rmask, ie_in, je_in, ke_in, weight)
  !   </TEMPLATE>
  !   <OVERVIEW>
  !     Send data over to output fields. 
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     <TT>send_data</TT> is overloaded for fields having zero dimension
  !     (scalars) to 3 dimension.  <TT>diag_field_id</TT> corresponds to the id
  !     returned from a previous call to <TT>register_diag_field</TT>. The field
  !     array is restricted to the computational range of the array. Optional
  !     argument <TT>is_in</TT> can be used to update sub-arrays of the entire
  !     field. Additionally, an optional logical or real mask can be used to
  !     apply missing values to the array.
  !
  !     If a field is declared to be <TT>mask_variant</TT> in
  !     <TT>register_diag_field</TT> logical mask should be mandatory.
  !
  !     For the real  mask, the mask is applied if the mask value is less than
  !     0.5.
  !
  !     By default, a field will be written out entirely in its global grid.
  !     Users can also specify regions in which the field will be output. The
  !     region is specified in diag-table just before the end of output_field
  !     replacing "none". 
  !
  !     For example, by default:
  !
  !     "ocean_mod","Vorticity","vorticity","file1","all",.false.,"none",2 
  !
  !     for regional output:
  !
  !     "ocean_mod","Vorticity","vorticity_local","file2","all",.false.,"0.5 53.5 -89.5 -28.5 -1 -1",2
  !
  !     The format of region is "<TT>xbegin xend ybegin yend zbegin zend</TT>".
  !     If it is a 2D field use (-1 -1) for (zbegin zend) as in the example
  !     above. For a 3D field use (-1 -1) for (zbegin zend) when you want to
  !     write the entire vertical extent, otherwise specify real coordinates.
  !     The units used for region are the actual units used in grid_spec.nc
  !     (for example degrees for lat, lon). a FATAL error will occur if the
  !     region's boundaries are not found in grid_spec.nc.
  !
  !     Regional output on the cubed sphere is also supported.  To use regional output on the cubed sphere, first the grid
  !     information needs to be sent to <TT>diag_manager_mod</TT> using the <LINK SRC="diag_grid.html#diag_grid_init"><TT>
  !     diag_grid_init</TT></LINK> subroutine.  <B><I>NOTE:</I></B> Regions must be confined to a single tile.  Regions spanning
  !     tiles will be ignored.  A future release will allow multi-tile regions.
  ! 
  !     <B><I>NOTE:</I></B> When using regional output the files containing regional 
  !     outputs should be different from files containing global (default) output. 
  !     It is a FATAL error to have one file containing both regional and global 
  !     results. For maximum flexibility and independence from PE counts one file 
  !     should contain just one region.
  ! 
  !     Time averaging is supported in regional output.
  ! 
  !     Physical fields (written in "physics windows" of atmospheric code) are 
  !     currently fully supported for regional outputs.
  !
  !     Note of dimension of field in send_data
  !
  !     Most fields are defined in data_domain but used in compute domain. In 
  !     <TT>send_data</TT> users can pass EITHER field in data domain OR field in 
  !     compute domain. If data domain is used, users should also pass the starting and 
  !     ending indices of compute domain (isc, iec ...). If compute domain is used no 
  !     indices are needed. These indices are for determining halo exclusively. If 
  !     users want to ouput the field partially they should use regional output as 
  !     mentioned above.
  !
  !     Weight in Time averaging is now supported, each time level may have a
  !     different weight. The default of weight is 1.
  !   </DESCRIPTION>
  !   <IN NAME="diag_field_id" TYPE="INTEGER"> </IN>
  !   <IN NAME="field" TYPE="REAL, DIMENSION(:,:,:)"> </IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)"> </IN>
  !   <IN NAME="is_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="js_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="ks_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:,:,:), OPTIONAL"></IN>
  !   <IN NAME="rmask" TYPE="REAL, DIMENSION(:,:,:), OPTIONAL"></IN>
  !   <IN NAME="ie_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="je_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="ke_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="weight" TYPE="REAL, OPTIONAL"></IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL"></OUT>
  INTERFACE send_data
     MODULE PROCEDURE send_data_0d
     MODULE PROCEDURE send_data_1d
     MODULE PROCEDURE send_data_2d
     MODULE PROCEDURE send_data_3d
  END INTERFACE
  ! </INTERFACE>

  ! <INTERFACE NAME="register_diag_field">
  !   <OVERVIEW>
  !      Register Diagnostic Field.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION register_diag_field (module_name, field_name, axes, init_time,
  !           long_name, units, missing_value, range, mask_variant, standard_name,
  !           verbose)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !      Return field index for subsequent calls to
  !      <LINK SRC="#send_data">send_data</LINK>.
  !
  !      <TT>axes</TT> are the axis ID returned from <TT>diag_axis_init</TT>,
  !      <TT>axes</TT> are required for fields of 1-3 dimension and NOT required
  !      for scalars.
  !
  !      For a static scalar (constant) <TT>init_time</TT> is not needed.
  !
  !      Optional <TT>mask_variant</TT> is for fields that have a time-dependent
  !      mask. If <TT>mask_variant</TT> is true then <TT>mask</TT> must be
  !      present in argument list of <TT>send_data</TT>.
  !
  !      The pair (<TT>module_name</TT>, <TT>fieldname</TT>) should be registered
  !      only once or a FATAL error will occur.
  !    </DESCRIPTION>
  !    <IN NAME="module_name" TYPE="CHARACTER(len=*)" />
  !    <IN NAME="field_name" TYPE="CHARACTER(len=*)" />
  !    <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)" />
  !    <IN NAME="init_time" TYPE="TYPE(time_type)" />
  !    <IN NAME="long_name" TYPE="CHARACTER(len=*)" />
  !    <IN NAME="units" TYPE="CHARACTER(len=*)" />
  !    <IN NAME="missing_value" TYPE="REAL" />
  !    <IN NAME="range" TYPE="REAL, DIMENSION(2)" />
  !    <IN NAME="mask_variant" TYPE="LOGICAL" /> 
  !    <IN NAME="standard_name" TYPE="CHARACTER(len=*)" />
  INTERFACE register_diag_field
     MODULE PROCEDURE register_diag_field_scalar
     MODULE PROCEDURE register_diag_field_array
  END INTERFACE
  ! </INTERFACE>

  !  <INTERFACE NAME="send_tile_averaged_data">
  !    <OVERVIEW>
  !      Send tile-averaged data over to output fields. 
  !    </OVERVIEW>
  !    <TEMPLATE>
  !      LOGICAL send_tile_averaged_data(diag_field_id, field, area, time, mask)
  !    </TEMPLATE>
  !    <DESCRIPTION>
  !      <TT>send_tile_averaged_data</TT> is overloaded for 3D and 4D arrays. 
  !      <TT>diag_field_id</TT> corresponds to the ID returned by previous call
  !      to <TT>register_diag_field</TT>. Logical masks can be used to mask out
  !      undefined and/or unused values.  Note that the dimension of output field
  !      is smaller by one than the dimension of the data, since averaging over
  !      tiles (3D dimension) is performed.
  !    </DESCRIPTION>
  !    <IN NAME="diag_field_id" TYPE="INTEGER" />
  !    <IN NAME="field" TYPE="REAL" DIM="(:,:,:)" />
  !    <IN NAME="area" TYPE="REAL" DIM="(:,:,:)" />
  !    <IN NAME="time" TYPE="TYPE(time_type)" DIM="(:,:,:)" />
  !    <IN NAME="mask" TYPE="LOGICAL" DIM="(:,:,:)" />
  INTERFACE send_tile_averaged_data
     MODULE PROCEDURE send_tile_averaged_data2d
     MODULE PROCEDURE send_tile_averaged_data3d
  END INTERFACE
  ! </INTERFACE>

CONTAINS

  ! <FUNCTION NAME="register_diag_field_scalar" INTERFACE="register_diag_field">
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)" />
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)" />
  !   <IN NAME="axes" TYPE="Not Applicable" />
  !   <IN NAME="init_time" TYPE="TYPE(time_type), OPTIONAL" />
  !   <IN NAME="long_name" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="units" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="missing_value" TYPE="REAL, OPTIONAL" />
  !   <IN NAME="range" TYPE="REAL, DIMENSION(2), OPTIONAL" />
  !   <IN NAME="mask_variant" TYPE="Not Applicable" />
  !   <IN NAME="standard_name" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="do_not_log" TYPE="LOGICAL, OPTIONAL" />
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL" />
  INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, &
       & long_name, units, missing_value, range, standard_name, do_not_log, err_msg)
    CHARACTER(len=*), INTENT(in) :: module_name, field_name
    TYPE(time_type), OPTIONAL, INTENT(in) :: init_time
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
    REAL, OPTIONAL, INTENT(in) :: missing_value
    REAL,  DIMENSION(2), OPTIONAL, INTENT(in) :: RANGE
    LOGICAL, OPTIONAL, INTENT(in) :: do_not_log ! if TRUE, field information is not logged
    CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg
 
    IF ( PRESENT(init_time) ) THEN
       register_diag_field_scalar = register_diag_field_array(module_name, field_name,&
            & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
            & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg)
    ELSE
       IF ( PRESENT(err_msg) ) err_msg = ''
       register_diag_field_scalar = register_static_field(module_name, field_name,&
            & (/null_axis_id/),long_name, units, missing_value, range,&
            & standard_name=standard_name, do_not_log=do_not_log)
    END IF
  END FUNCTION register_diag_field_scalar
  ! </FUNCTION>

  ! <FUNCTION NAME="register_diag_field_array" INTERFACE="register_diag_field">
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)" />
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)" />
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)" />
  !   <IN NAME="init_time" TYPE="TYPE(time_type)" />
  !   <IN NAME="long_name" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="units" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="missing_value" TYPE="REAL, OPTIONAL" />
  !   <IN NAME="range" TYPE="REAL, DIMENSION(2), OPTIONAL" />
  !   <IN NAME="mask_variant" TYPE="LOGICAL, OPTIONAL" />
  !   <IN NAME="standard_name" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="do_not_log" TYPE="LOGICAL, OPTIONAL" />
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="interp_method" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="tile_count" TYPE="INTEGER, OPTIONAL" />
  INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, &
       & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
       & do_not_log, err_msg, interp_method, tile_count)
    CHARACTER(len=*), INTENT(in) :: module_name, field_name
    INTEGER, INTENT(in) :: axes(:)
    TYPE(time_type), INTENT(in) :: init_time
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
    REAL, OPTIONAL, INTENT(in) :: missing_value, RANGE(2)
    LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose
    LOGICAL, OPTIONAL, INTENT(in) :: do_not_log ! if TRUE, field info is not logged
    CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method
    INTEGER, OPTIONAL, INTENT(in) :: tile_count

    INTEGER :: field, j, ind, file_num, freq
    INTEGER :: output_units
    INTEGER :: stdout_unit
    LOGICAL :: mask_variant1, verbose1
    CHARACTER(len=128) :: msg

    ! get stdout unit number
    stdout_unit = stdout()

    IF ( PRESENT(mask_variant) ) THEN
       mask_variant1 = mask_variant
    ELSE
       mask_variant1 = .FALSE.
    END IF

    IF ( PRESENT(verbose) ) THEN 
       verbose1 = verbose
    ELSE 
       verbose1 = .FALSE.
    END IF

    IF ( PRESENT(err_msg) ) err_msg = ''
    
    ! Call register static, then set static back to false
    register_diag_field_array = register_static_field(module_name, field_name, axes,&
         & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
         & DYNAMIC=.TRUE., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count)

    IF ( .NOT.first_send_data_call ) THEN 
       ! <ERROR STATUS="WARNING">
       !   module/output_field <module_name>/<field_name> registered AFTER first
       !   send_data call, TOO LATE
       ! </ERROR>
       IF ( mpp_pe() == mpp_root_pe() ) &
            & CALL  error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
            &//TRIM(module_name)//'/'// TRIM(field_name)//&
            &' registered AFTER first send_data call, TOO LATE', WARNING)  
    END IF

    IF ( register_diag_field_array < 0 ) THEN
       ! <ERROR STATUS="WARNING">
       !   module/output_field <modul_name>/<field_name> NOT found in diag_table
       ! </ERROR>
       IF ( debug_diag_manager .OR. verbose1 ) THEN 
          IF ( mpp_pe() == mpp_root_pe() ) &
               & CALL error_mesg ('register_diag_field', 'module/output_field '&
               &//TRIM(module_name)//'/'// TRIM(field_name)//' NOT found in diag_table',&
               & WARNING) 
       END IF
    ELSE 
       input_fields(register_diag_field_array)%static = .FALSE.
       field = register_diag_field_array
       IF ( PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name  

       DO j = 1, input_fields(field)%num_output_fields
          ind = input_fields(field)%output_fields(j)
          output_fields(ind)%static = .FALSE.
          ! Set up times in output_fields
          output_fields(ind)%last_output = init_time
          ! Get output frequency from for the appropriate output file
          file_num = output_fields(ind)%output_file
          IF ( file_num == max_files ) CYCLE
          IF ( output_fields(ind)%local_output ) THEN
             IF ( output_fields(ind)%need_compute) THEN         
                files(file_num)%local = .TRUE.
             END IF
          END IF

          ! Need to sync start_time of file with init time of model
          ! and close_time calculated with the duration of the file.
          ! Also, increase next_open until it is greater than init_time.
          CALL sync_file_times(file_num, init_time, err_msg=msg)
          IF ( msg /= '' ) THEN
             IF ( fms_error_handler('diag_manager_mod::register_diag_field', TRIM(msg), err_msg) ) RETURN
          END IF

          freq = files(file_num)%output_freq
          output_units = files(file_num)%output_units
          output_fields(ind)%next_output = diag_time_inc(init_time, freq, output_units, err_msg=msg)
          IF ( msg /= '' ) THEN
             IF ( fms_error_handler('register_diag_field',&
                  & ' file='//TRIM(files(file_num)%name)//': '//TRIM(msg),err_msg)) RETURN
          END IF
          output_fields(ind)%next_next_output = &
               & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
          IF ( msg /= '' ) THEN
             IF ( fms_error_handler('register_diag_field',&
                  &' file='//TRIM(files(file_num)%name)//': '//TRIM(msg),err_msg) ) RETURN
          END IF
          IF ( debug_diag_manager .AND. mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output ) THEN
             WRITE (msg,'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
                  & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
                  & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
                  & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
             WRITE(stdout_unit,* ) 'module/output_field '//TRIM(module_name)//'/'//TRIM(field_name)// &
                  & ' will be output in region:'//TRIM(msg)
          END IF
       END DO
    END IF
  END FUNCTION register_diag_field_array
  ! </FUNCTION>

  ! <FUNCTION NAME="register_static_field">
  !   <OVERVIEW>
  !     Register Static Field.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION register_static_field(module_name, field_name, axes,
  !       long_name, units, missing_value, range, mask_variant, standard_name,
  !       dynamic, do_not_log, interp_method, tile_count)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return field index for subsequent call to send_data.
  !   </DESCRIPTION>
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)" />
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)" />
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)" />
  !   <IN NAME="long_name" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="units" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="missing_value" TYPE="REAL, OPTIONAL" />
  !   <IN NAME="range" TYPE="REAL, DIMENSION(2), OPTIONAL" />
  !   <IN NAME="mask_variang" TYPE="LOGICAL, OPTIONAL" DEFAULT=".FALSE."/>
  !   <IN NAME="standard_name" TYPE="CHARACTER(len=*), OPTIONAL" />
  !   <IN NAME="dynamic" TYPE="LOGICAL, OPTIONAL" DEFAULT=".FALSE."/>
  !   <IN NAME="do_not_log" TYPE="LOGICAL, OPTIONAL" DEFAULT=".TRUE."/>
  !   <IN NAME="interp_method" TYPE="CHARACTER(len=*), OPTIOANL" />
  !   <IN NAME="tile_count" TYPE="INTEGER, OPTIONAL" />
  INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, units,&
       & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
       & tile_count)
    CHARACTER(len=*), INTENT(in) :: module_name, field_name
    INTEGER, DIMENSION(:), INTENT(in) :: axes
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
    REAL, OPTIONAL, INTENT(in) :: missing_value
    REAL, DIMENSION(2), OPTIONAL, INTENT(in) :: range
    LOGICAL, OPTIONAL, INTENT(in) :: mask_variant
    LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC
    LOGICAL, OPTIONAL, INTENT(in) :: do_not_log ! if TRUE, field information is not logged
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method
    INTEGER,          OPTIONAL, INTENT(in) :: tile_count

    REAL :: missing_value_use
    INTEGER :: field, num_axes, j, out_num, k
    INTEGER, DIMENSION(3) :: siz, local_siz, local_start, local_end ! indices of local domain of global axes
    INTEGER :: tile, file_num
    LOGICAL :: mask_variant1, dynamic1, allow_log
    CHARACTER(len=128) :: msg

    ! Fatal error if the module has not been initialized.
    IF ( .NOT.module_is_initialized ) THEN 
       ! <ERROR STATUS="FATAL">diag_manager has NOT been initialized</ERROR>
       CALL error_mesg ('register_static_field', 'diag_manager has NOT been initialized', FATAL)
    END IF

    ! Check if OPTIONAL parameters were passed in.
    IF ( PRESENT(missing_value) ) THEN
       IF ( use_cmor ) THEN 
          missing_value_use = CMOR_MISSING_VALUE
       ELSE
          missing_value_use = missing_value
       END IF
    END IF
    
    IF ( PRESENT(mask_variant) ) THEN 
       mask_variant1 = mask_variant
    ELSE 
       mask_variant1 = .FALSE.
    END IF
    
    IF ( PRESENT(DYNAMIC) ) THEN
       dynamic1 = DYNAMIC
    ELSE
       dynamic1 = .FALSE.
    END IF

    IF ( PRESENT(tile_count) ) THEN 
       tile = tile_count
    ELSE
       tile = 1
    END IF

    IF ( PRESENT(do_not_log) ) THEN
       allow_log = .NOT.do_not_log
    ELSE
       allow_log = .TRUE. 
    END IF

    ! Namelist do_diag_field_log is by default false.  Thus to log the
    ! registration of the data field, but the OPTIONAL parameter
    ! do_not_log == .FALSE. and the namelist variable
    ! do_diag_field_log == .TRUE..
    IF ( do_diag_field_log.AND.allow_log ) THEN
       CALL log_diag_field_info (module_name, field_name, axes, &
            & long_name, units, missing_value=missing_value, range=range, &
            & DYNAMIC=dynamic1)
    END IF

    register_static_field = find_input_field(module_name, field_name, 1)
    field = register_static_field
    ! Negative index returned if this field was not found in the diag_table.
    IF ( register_static_field < 0 ) RETURN

    IF ( tile > 1 ) THEN
       IF ( .NOT.input_fields(field)%register ) THEN
          ! <ERROR STATUS="FATAL">
          !   module/output_field <module_name>/<field_name> is not registered for tile_count = 1,
          !   should not register for tile_count > 1
          ! </ERROR>
          CALL error_mesg ('register_diag_field', 'module/output_field '//trim(module_name)//'/'//&
           & TRIM(field_name)//' is not registered for tile_count = 1, should not register for tile_count > 1',&
           & FATAL)    
       END IF

       CALL init_input_field(module_name, field_name, tile)
       register_static_field = find_input_field(module_name, field_name, tile)
       DO j = 1, input_fields(field)%num_output_fields
          out_num = input_fields(field)%output_fields(j)
          file_num = output_fields(out_num)%output_file
          IF(input_fields(field)%local) THEN
             CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
                  & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
                  & tile, input_fields(field)%local_coord)
          ELSE
             CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
                  & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
          END IF
       END DO
       field = register_static_field       
    END IF

    ! Store information for this input field into input field table

    ! Set static to true, if called by register_diag_field this is
    ! flipped back to false
    input_fields(field)%static = .TRUE.
    ! check if the field is registered twice
    IF ( input_fields(field)%register .AND. mpp_pe() == mpp_root_pe() ) THEN
       ! <ERROR STATUS="FATAL">
       !   module/output_field <module_name>/<field_name> ALREADY Registered, should
       !   not register twice
       ! </ERROR>
       CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '//trim(module_name)//'/'//&
            & TRIM(field_name)//' ALREADY registered, should not register twice', FATAL) 
    END IF

    ! Set flag that this field was registered
    input_fields(field)%register = .TRUE.
    ! set flag for mask: does it change with time?
    input_fields(field)%mask_variant = mask_variant1

    ! Check for more OPTIONAL parameters.
    IF ( PRESENT(long_name) ) THEN
       input_fields(field)%long_name = TRIM(long_name)
    ELSE
       input_fields(field)%long_name = input_fields(field)%field_name
    END IF
    
    IF ( PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name 
    
    IF ( PRESENT(units) ) THEN
       input_fields(field)%units = TRIM(units)
    ELSE
       input_fields(field)%units = 'none'
    END IF
    
    IF ( PRESENT(missing_value) ) THEN
       input_fields(field)%missing_value = missing_value_use
       input_fields(field)%missing_value_present = .TRUE.
    ELSE
       input_fields(field)%missing_value_present = .FALSE.
    END IF
    
    IF ( PRESENT(range) ) THEN
       input_fields(field)%range = range
       input_fields(field)%range_present = .TRUE.
    ELSE
       input_fields(field)%range = (/ 1., 0. /)
       input_fields(field)%range_present = .FALSE.
    END IF

    IF ( PRESENT(interp_method) ) THEN
       IF ( TRIM(interp_method) .NE. 'conserve_order1' ) THEN 
          ! <ERROR STATUS="FATAL">
          !   when registering module/output_field <module_name>/<field_name> then optional
          !   argument interp_method = <interp_method>, but it should be "conserve_order1"
          ! </ERROR>
          CALL error_mesg ('diag_manager_mod::register_diag_field',&
               & 'when registering module/output_field '//TRIM(module_name)//'/'//&
               & TRIM(field_name)//', the optional argument interp_method = '//TRIM(interp_method)//&
               & ', but it should be "conserve_order1"', FATAL)
       END IF
       input_fields(field)%interp_method = TRIM(interp_method)
    ELSE 
       input_fields(field)%interp_method = ''
    END IF

    ! Store the axis info
    num_axes = SIZE(axes(:)) ! num_axes should be <= 3.
    input_fields(field)%axes(1:num_axes) = axes
    input_fields(field)%num_axes = num_axes
    
    siz = 1
    DO j = 1, num_axes
       IF ( axes(j) .LE. 0 ) THEN
          ! <ERROR STATUS="FATAL">
          !   module/output_field <module_name>/<field_name> has non-positive axis_id
          ! </ERROR>
          CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '//trim(module_name)//'/'//&
               & TRIM(field_name)//' has non-positive axis_id', FATAL) 
       END IF
       siz(j) = get_axis_length(axes(j))
    END DO

    ! Default length for axes is 1
    DO j = 1, 3
       input_fields(field)%size(j) = siz(j)
    END DO

    local_siz = 1
    local_start = 1
    local_end= 1
    ! Need to loop through all output_fields associated and allocate their buffers
    DO j = 1, input_fields(field)%num_output_fields
       out_num = input_fields(field)%output_fields(j)
       ! Range is required when pack >= 4 
       IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present ) THEN
          IF(mpp_pe() .EQ. mpp_root_pe()) THEN
             ! <ERROR STATUS="FATAL">
             !   output_field <field_name> has pack >= 4, range is REQUIRED in register_diag_field
             ! </ERROR>
             CALL error_mesg ('diag_manager_mod::register_diag_field ', 'output_field '//TRIM(field_name)// &
                  ' has pack >=4, range is REQUIRED in register_diag_field', FATAL)
          END IF
       END IF
       ! reset the number of diurnal samples to 1 if the field is static (and, therefore,
       ! doesn't vary diurnally)
       IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
       !  if local_output (size of output_fields does NOT equal size of input_fields)
       IF ( output_fields(out_num)%reduced_k_range ) THEN
          CALL get_subfield_vert_size(axes, out_num)
   
          local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
          local_end(3)   = output_fields(out_num)%output_grid%l_end_indx(3)
          local_siz(3)   = local_end(3) - local_start(3) +1                         

          ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), local_siz(3),&
               & output_fields(out_num)%n_diurnal_samples))

          IF ( output_fields(out_num)%time_max ) THEN
             output_fields(out_num)%buffer = MAX_VALUE
          ELSE IF ( output_fields(out_num)%time_min ) THEN
             output_fields(out_num)%buffer = MIN_VALUE
          ELSE
             output_fields(out_num)%buffer = EMPTY
          END IF
          output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
          output_fields(out_num)%total_elements  = siz(1)*siz(2)*siz(3)
       ELSE IF ( output_fields(out_num)%local_output ) THEN
          IF ( SIZE(axes(:)) .LE. 1 ) THEN
             ! <ERROR STATUS="FATAL">axes of <field_name> must >= 2 for local output</ERROR>
             CALL error_mesg ('diag_manager_mod::register_diag_field', 'axes of '//TRIM(field_name)//&
                  & ' must >= 2 for local output', FATAL)
          END IF
          CALL get_subfield_size(axes, out_num)
          IF ( output_fields(out_num)%need_compute ) THEN
             DO k = 1, num_axes
                local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
                local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
                local_siz(k) = local_end(k) - local_start(k) +1                         
             END DO
             ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
                  & output_fields(out_num)%n_diurnal_samples))
             IF(output_fields(out_num)%time_max) THEN
                output_fields(out_num)%buffer = MAX_VALUE
             ELSE IF(output_fields(out_num)%time_min) THEN
                output_fields(out_num)%buffer = MIN_VALUE
             ELSE
                output_fields(out_num)%buffer = EMPTY
             END IF
             output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
             output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
          END IF
       ELSE ! the field is output globally
          ! size of output_fields equal size of input_fields 
          ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
               & output_fields(out_num)%n_diurnal_samples))
          IF(output_fields(out_num)%time_max) THEN
             output_fields(out_num)%buffer = MAX_VALUE
          ELSE IF(output_fields(out_num)%time_min) THEN
             output_fields(out_num)%buffer = MIN_VALUE
          ELSE
             output_fields(out_num)%buffer = EMPTY
          END IF
          output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
       END IF
  
       ! Reset to false in register_field if this is not static
       output_fields(out_num)%static = .TRUE.
       ! check if time average is true for static field
       IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops ) THEN
          WRITE (msg,'(a,"/",a)') TRIM(module_name), TRIM(field_name)
          IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
             ! <ERROR STATUS="WARNING">
             !   module/field <module_name>/<field_name> is STATIC.
             !   Cannot perform time operations average, maximum or
             !   minimum on static fields.  Setting the time operation to 'NONE'
             !   for this field.
             ! </ERROR>
             CALL error_mesg ('diag_manager_mod::register_static_field',&
                  & 'module/field '//TRIM(msg)//' is STATIC.  Cannot perform time operations&
                  & average, maximum, or minimum on static fields.  Setting the time operation&
                  & to "NONE" for this field.', WARNING)
          END IF
          output_fields(out_num)%time_ops = .FALSE.
          output_fields(out_num)%time_average = .FALSE.
          output_fields(out_num)%time_method = 'point'
       END IF

       ! assume that the number of axes of output_fields = that of input_fields
       ! this should be changed later to take into account time-of-day axis
       output_fields(out_num)%num_axes = input_fields(field)%num_axes
       ! Axes are copied from input_fields if output globally or from subaxes if output locally
       IF ( .NOT.output_fields(out_num)%local_output ) THEN 
          output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
               & input_fields(field)%axes(1:input_fields(field)%num_axes)
       ELSE
          output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
               & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
       END IF

       ! if necessary, initialize the diurnal time axis and append its index in the 
       ! output field axes array
       IF ( output_fields(out_num)%n_diurnal_samples > 1 ) THEN
          output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
               & init_diurnal_axis(output_fields(out_num)%n_diurnal_samples)
          output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
       END IF

       IF ( output_fields(out_num)%reduced_k_range ) THEN 
          output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
       END IF

       ! Initialize a time variable used in an error check
       output_fields(out_num)%Time_of_prev_field_data = Time_zero
    END DO

    IF ( input_fields(field)%mask_variant ) THEN
       DO j = 1, input_fields(field)%num_output_fields
          out_num = input_fields(field)%output_fields(j)
          IF(output_fields(out_num)%time_average) THEN
             ALLOCATE(output_fields(out_num)%counter(siz(1), siz(2), siz(3),&
                  & output_fields(out_num)%n_diurnal_samples))
             output_fields(out_num)%counter = 0.0
          END IF
       END DO
    END IF
  END FUNCTION register_static_field
  ! </FUNCTION>

  ! <FUNCTION NAME="send_data_0d" INTERFACE="send_data">
  !   <IN NAME="diag_field_id" TYPE="INTEGER"> </IN>
  !   <IN NAME="field" TYPE="REAL"> </IN>
  !   <IN NAME="time" TYPE="TYPE(time_type), OPTIONAL"> </IN>
  !   <IN NAME="is_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="js_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="ks_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="mask" TYPE="Not Applicable"></IN>
  !   <IN NAME="rmask" TYPE="Not Applicable"></IN>
  !   <IN NAME="ie_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="je_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="ke_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="weight" TYPE="Not Applicable"></IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL"></OUT>
  LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg)
    INTEGER, INTENT(in) :: diag_field_id
    REAL, INTENT(in) :: field
    TYPE(time_type), INTENT(in), OPTIONAL :: time
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    REAL :: field_out(1, 1, 1)

    ! If diag_field_id is < 0 it means that this field is not registered, simply return
    IF ( diag_field_id <= 0 ) THEN
       send_data_0d = .FALSE.
       RETURN
    END IF
    ! First copy the data to a three d array with last element 1
    field_out(1, 1, 1) = field
    send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg)
  END FUNCTION send_data_0d
  ! </FUNCTION>

  ! <FUNCTION NAME="send_data_1d" INTERFACE="send_data">
  !   <IN NAME="diag_field_id" TYPE="INTEGER"> </IN>
  !   <IN NAME="field" TYPE="REAL, DIMENSION(:)"> </IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)"> </IN>
  !   <IN NAME="is_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="js_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="ks_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:), OPTIONAL"></IN>
  !   <IN NAME="rmask" TYPE="REAL, DIMENSION(:), OPTIONAL"></IN>
  !   <IN NAME="ie_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="je_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="ke_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="weight" TYPE="REAL, OPTIONAL"></IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL"></OUT>
  LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
    INTEGER, INTENT(in) :: diag_field_id
    REAL, DIMENSION(:), INTENT(in) :: field
    REAL, INTENT(in), OPTIONAL :: weight
    REAL, INTENT(in), DIMENSION(:), OPTIONAL :: rmask
    TYPE (time_type), INTENT(in), OPTIONAL :: time
    INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in
    LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out
    LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) ::  mask_out

    ! If diag_field_id is < 0 it means that this field is not registered, simply return
    IF ( diag_field_id <= 0 ) THEN
       send_data_1d = .FALSE.
       RETURN
    END IF

    ! First copy the data to a three d array with last element 1
    field_out(:, 1, 1) = field

    ! Default values for mask
    IF ( PRESENT(mask) ) THEN 
       mask_out(:, 1, 1) = mask
    ELSE
       mask_out = .TRUE.
    END IF

    IF ( PRESENT(rmask) ) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE.
    IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
       send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in, 1, 1, mask_out,&
            & ie_in=ie_in,weight=weight, err_msg=err_msg)
    ELSE
       send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in, 1, 1,&
            & ie_in=ie_in, weight=weight, err_msg=err_msg)
    END IF
  END FUNCTION send_data_1d
  ! </FUNCTION>

  ! <FUNCTION NAME="send_data_2d" INTERFACE="send_data">
  !   <IN NAME="diag_field_id" TYPE="INTEGER"> </IN>
  !   <IN NAME="field" TYPE="REAL, DIMENSION(:,:)"> </IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)"> </IN>
  !   <IN NAME="is_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="js_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="ks_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:,:), OPTIONAL"></IN>
  !   <IN NAME="rmask" TYPE="REAL, DIMENSION(:,:), OPTIONAL"></IN>
  !   <IN NAME="ie_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="je_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="ke_in" TYPE="Not Applicable"></IN>
  !   <IN NAME="weight" TYPE="REAL, OPTIONAL"></IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL"></OUT>
  LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
       & mask, rmask, ie_in, je_in, weight, err_msg)
    INTEGER, INTENT(in) :: diag_field_id
    REAL, INTENT(in), DIMENSION(:,:) :: field
    REAL, INTENT(in), OPTIONAL :: weight
    TYPE (time_type), INTENT(in), OPTIONAL :: time
    INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in
    LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask
    REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out
    LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) ::  mask_out

    ! If diag_field_id is < 0 it means that this field is not registered, simply return
    IF ( diag_field_id <= 0 ) THEN
       send_data_2d = .FALSE.
       RETURN
    END IF

    ! First copy the data to a three d array with last element 1
    field_out(:, :, 1) = field

    ! Default values for mask
    IF ( PRESENT(mask) ) THEN 
       mask_out(:, :, 1) = mask
    ELSE 
       mask_out = .TRUE.
    END IF
    
    IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE.
    IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
       send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in, js_in, 1, mask_out,&
            & ie_in=ie_in, je_in=je_in,weight=weight, err_msg=err_msg)
    ELSE
       send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in, js_in, 1, ie_in=ie_in,&
            & je_in=je_in, weight=weight, err_msg=err_msg)
    END IF
  END FUNCTION send_data_2d
  ! </FUNCTION>

  ! <FUNCTION NAME="send_data_3d" INTERFACE="send_data">
  !   <IN NAME="diag_field_id" TYPE="INTEGER"> </IN>
  !   <IN NAME="field" TYPE="REAL, DIMENSION(:,:,:)"> </IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)"> </IN>
  !   <IN NAME="is_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="js_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="ks_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:,:,:), OPTIONAL"></IN>
  !   <IN NAME="rmask" TYPE="REAL, DIMENSION(:,:,:), OPTIONAL"></IN>
  !   <IN NAME="ie_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="je_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="ke_in" TYPE="INTEGER, OPTIONAL"></IN>
  !   <IN NAME="weight" TYPE="REAL, OPTIONAL"></IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL"></OUT>
  LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
             & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
    INTEGER, INTENT(in) :: diag_field_id
    REAL, DIMENSION(:,:,:), INTENT(in) :: field
    REAL, INTENT(in), OPTIONAL :: weight
    TYPE (time_type), INTENT(in), OPTIONAL :: time
    INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in 
    LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask
    REAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    REAL :: weight1
    REAL :: missvalue
    INTEGER :: ksr, ker
    INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
    INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
    INTEGER, DIMENSION(3) :: l_start, l_end ! local start and end indices on 3 axes for regional output
    INTEGER   :: hi, hj, twohi, twohj  ! halo size in x and y direction
    INTEGER :: sample ! index along the diurnal time axis
    INTEGER :: day,second,tick ! components of the current date
    INTEGER :: status
    INTEGER :: numthreads
#if defined(_OPENMP)
    INTEGER :: omp_get_num_threads !< OMP function
#endif
    LOGICAL :: average, phys_window, need_compute
    LOGICAL :: reduced_k_range, local_output
    LOGICAL :: time_max, time_min
    LOGICAL :: missvalue_present
    LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: oor_mask
    CHARACTER(len=256) :: err_msg_local
    CHARACTER(len=128) :: error_string, error_string1
    TYPE(time_type) :: dt ! time interval for diurnal output

    ! If diag_field_id is < 0 it means that this field is not registered, simply return
    IF ( diag_field_id <= 0 ) THEN
       send_data_3d = .FALSE.
       RETURN
    ELSE
       send_data_3d = .TRUE.
    END IF

    IF ( PRESENT(err_msg) ) err_msg = ''
    IF ( .NOT.module_is_initialized ) THEN
       IF ( fms_error_handler('send_data_3d', 'diag_manager NOT initialized', err_msg) ) RETURN
    END IF
    err_msg_local = ''

    ! oor_mask is only used for checking out of range values.
     ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
     IF ( status .NE. 0 ) THEN
        WRITE (err_msg_local, FMT='("Unable to allocate oor_mask(",I5,",",I5,",",I5"). (STAT: ",I5,")")')&
             & SIZE(field,1), SIZE(field,2), SIZE(field,3), status
        IF ( fms_error_handler('send_data_3d', err_msg_local, err_msg) ) RETURN
     END IF

    IF ( PRESENT(mask) ) THEN 
       oor_mask = mask
    ELSE 
       oor_mask = .TRUE.
    END IF
    IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) oor_mask = .FALSE.

    ! send_data works in either one or another of two modes.
    ! 1. Input field is a window (e.g. FMS physics)
    ! 2. Input field includes halo data
    ! It cannot handle a window of data that has halos.
    ! (A field with no windows or halos can be thought of as a special case of either mode.)
    ! The logic for indexing is quite different for these two modes, but is not clearly separated.
    ! If both the beggining and ending indices are present, then field is assumed to have halos.
    ! If only beggining indices are present, then field is assumed to be a window.

    ! There are a number of ways a user could mess up this logic, depending on the combination
    ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations.
    IF ( PRESENT(ie_in) ) THEN
       IF ( .NOT.PRESENT(is_in) ) THEN
          IF ( fms_error_handler('send_data_3d', 'ie_in present without is_in', err_msg) ) RETURN
       END IF
       IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN
          IF ( fms_error_handler('send_data_3d', 'is_in and ie_in present, but js_in present without je_in', err_msg) ) RETURN
       END IF
    END IF
    IF ( PRESENT(je_in) ) THEN
       IF ( .NOT.PRESENT(js_in) ) THEN
          IF ( fms_error_handler('send_data_3d', 'je_in present without js_in', err_msg) ) RETURN
       END IF
       IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN
          IF ( fms_error_handler('send_data_3d', 'js_in and je_in present, but is_in present without ie_in', err_msg)) RETURN
       END IF
    END IF

    ! If is, js, or ks not present default them to 1
    is = 1
    js = 1
    ks = 1
    IF ( PRESENT(is_in) ) is = is_in
    IF ( PRESENT(js_in) ) js = js_in
    IF ( PRESENT(ks_in) ) ks = ks_in
    n1 = SIZE(field, 1)
    n2 = SIZE(field, 2)
    n3 = SIZE(field, 3)
    ie = is+n1-1
    je = js+n2-1
    ke = ks+n3-1
    IF ( PRESENT(ie_in) ) ie = ie_in
    IF ( PRESENT(je_in) ) je = je_in
    IF ( PRESENT(ke_in) ) ke = ke_in
    twohi = n1-(ie-is+1)
    IF ( MOD(twohi,2) /= 0 ) THEN
       IF ( fms_error_handler('send_data_3d', 'non-symmetric halos in first dimension', err_msg) ) RETURN
    END IF
    twohj = n2-(je-js+1)
    IF ( MOD(twohj,2) /= 0 ) THEN
       IF ( fms_error_handler('send_data_3d', 'non-symmetric halos in second dimension', err_msg) ) RETURN
    END IF
    hi = twohi/2
    hj = twohj/2

    ! The next line is necessary to ensure that is,ie,js,ie are relative to field(1:,1:)
    ! But this works only when there is no windowing.
    IF ( PRESENT(ie_in) .AND. PRESENT(je_in) ) THEN
       is=1+hi
       ie=n1-hi
       js=1+hj
       je=n2-hj
    END IF

    ! used for field, mask and rmask bounds
    f1=1+hi
    f2=n1-hi
    f3=1+hj
    f4=n2-hj

    ! weight is for time averaging where each time level may has a different weight
    IF ( PRESENT(weight) ) THEN 
       weight1 = weight
    ELSE
       weight1 = 1.
    END IF
    
    ! Is there a missing_value?
    missvalue_present = input_fields(diag_field_id)%missing_value_present
    IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value

    number_of_outputs = input_fields(diag_field_id)%num_output_fields
#if defined(_OPENMP)
    input_fields(diag_field_id)%numthreads = omp_get_num_threads()
#endif
    numthreads = input_fields(diag_field_id)%numthreads
    if(present(time)) input_fields(diag_field_id)%time = time

    ! Issue a warning if any value in field is outside the valid range
    IF ( input_fields(diag_field_id)%range_present ) THEN
       IF ( ISSUE_OOR_WARNINGS .OR. OOR_WARNINGS_FATAL ) THEN
          WRITE (error_string, '("[",ES14.5E3,",",ES14.5E3,"]")')&
               & input_fields(diag_field_id)%range(1:2)
          WRITE (error_string1, '("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
                  & MINVAL(field(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),&
                  & MAXVAL(field(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke))
          IF ( missvalue_present ) THEN
             IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
                  &   ((field(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
                  &     field(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
                  &     field(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN
                ! <ERROR STATUS="WARNING/FATAL">
                !   A value for <module_name> in field <field_name> (Min: <min_val>, Max: <max_val>)
                !   is outside the range [<lower_val>,<upper_val>] and not equal to the missing
                !   value.
                ! </ERROR>
                CALL error_mesg('diag_manager_mod::send_data_3d',&
                     & 'A value for '//&
                     &TRIM(input_fields(diag_field_id)%module_name)//' in field '//&
                     &TRIM(input_fields(diag_field_id)%field_name)//' '&
                     &//TRIM(error_string1)//&
                     &' is outside the range '//TRIM(error_string)//',&
                     & and not equal to the missing value.',&
                     &OOR_WARNING)
             END IF
          ELSE
             IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
                  &   (field(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
                  &    field(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN
                ! <ERROR STATUS="WARNING/FATAL">
                !   A value for <module_name> in field <field_name> (Min: <min_val>, Max: <max_val>)
                !   is outside the range [<lower_val>,<upper_val>].
                ! </ERROR>
                CALL error_mesg('diag_manager_mod::send_data_3d',&
                     & 'A value for '//&
                     &TRIM(input_fields(diag_field_id)%module_name)//' in field '//&
                     &TRIM(input_fields(diag_field_id)%field_name)//' '&
                     &//TRIM(error_string1)//&
                     &' is outside the range '//TRIM(error_string)//'.',&
                     &OOR_WARNING)
             END IF
          END IF
       END IF
    END IF

    ! Loop through each output field that depends on this input field
    num_out_fields: DO ii = 1, number_of_outputs
       ! Get index to an output field
       out_num = input_fields(diag_field_id)%output_fields(ii)

      ! is this field output on a local domain only?
       local_output = output_fields(out_num)%local_output
       ! if local_output, does the current PE take part in send_data?
       need_compute = output_fields(out_num)%need_compute

       reduced_k_range = output_fields(out_num)%reduced_k_range

      ! skip all PEs not participating in outputting this field
       IF ( local_output .AND. (.NOT.need_compute) ) CYCLE

       ! Get index to output file for this field
       file_num = output_fields(out_num)%output_file
       IF(file_num == max_files) CYCLE
       ! Output frequency and units for this file is
       freq = files(file_num)%output_freq
       units = files(file_num)%output_units
       ! Is this output field being time averaged?
       average = output_fields(out_num)%time_average
       ! Looking for max and min value of this field over the sampling interval?
       time_max = output_fields(out_num)%time_max
       time_min = output_fields(out_num)%time_min   
       IF ( output_fields(out_num)%total_elements > SIZE(field(f1:f2,f3:f4,ks:ke)) ) THEN
          output_fields(out_num)%phys_window = .TRUE.
       ELSE
          output_fields(out_num)%phys_window = .FALSE.
       END IF
       phys_window = output_fields(out_num)%phys_window
       IF ( need_compute ) THEN        
          l_start = output_fields(out_num)%output_grid%l_start_indx
          l_end = output_fields(out_num)%output_grid%l_end_indx
       END IF

       ! compute the diurnal index
       sample = 1
       IF ( PRESENT(time) ) THEN
          dt = set_time(0,1)/output_fields(out_num)%n_diurnal_samples ! our time interval
          CALL get_time(time,second,day,tick) ! current date
          sample = set_time(second,0,tick)/dt + 1
       END IF
   
       ! Get the vertical layer start and end index.
       IF ( reduced_k_range ) THEN
          l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
          l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
       END IF
       ksr= l_start(3)
       ker= l_end(3)

       ! Initialize output time for fields output every time step
       IF ( freq == EVERY_TIME .AND. .NOT.output_fields(out_num)%static ) THEN
          IF (output_fields(out_num)%next_output == output_fields(out_num)%last_output) THEN
             IF(PRESENT(time)) THEN
                output_fields(out_num)%next_output = time
             ELSE
                WRITE (error_string,'(a,"/",a)')&
                     & TRIM(input_fields(diag_field_id)%module_name),&
                     & TRIM(output_fields(out_num)%output_name)
                IF ( fms_error_handler('send_data_3d', 'module/output_field '//TRIM(error_string)//&
                     & ', time must be present when output frequency = EVERY_TIME', err_msg)) RETURN
             END IF
          END IF
       END IF 
       IF ( .NOT.output_fields(out_num)%static .AND. .NOT.PRESENT(time) ) THEN
          WRITE (error_string,'(a,"/",a)')&
               & TRIM(input_fields(diag_field_id)%module_name), &
               & TRIM(output_fields(out_num)%output_name)
          IF ( fms_error_handler('send_data_3d', 'module/output_field '//TRIM(error_string)//&
               & ', time must be present for nonstatic field', err_msg)) RETURN
       END IF

       ! Is it time to output for this field; CAREFUL ABOUT > vs >= HERE
       !--- The fields send out within openmp parallel region will be written out in
       !--- diag_send_complete. 
       IF ( numthreads == 1) then
          IF ( .NOT.output_fields(out_num)%static .AND. freq /= END_OF_RUN ) THEN
             IF ( time > output_fields(out_num)%next_output ) THEN
                ! A non-static field that has skipped a time level is an error
                IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 ) THEN
                   IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN 
                      WRITE (error_string,'(a,"/",a)')&
                           & TRIM(input_fields(diag_field_id)%module_name), &
                           & TRIM(output_fields(out_num)%output_name)
                      IF ( fms_error_handler('send_data_3d', 'module/output_field '//TRIM(error_string)//&
                           & ' is skipped one time level in output data', err_msg)) RETURN
                   END IF
                END IF

                status = writing_field(out_num, .FALSE., error_string, time)
                IF(status == -1) THEN
                   IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
                      IF(fms_error_handler('send_data_3d','module/output_field '//TRIM(error_string)//&
                           & ', write EMPTY buffer', err_msg)) RETURN
                   END IF
                END IF
             END IF  !time > output_fields(out_num)%next_output
          END IF  !.not.output_fields(out_num)%static .and. freq /= END_OF_RUN
          ! Finished output of previously buffered data, now deal with buffering new data   
       END IF

       IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN
          CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg=err_msg_local)
          IF ( err_msg_local /= '' ) THEN
             IF ( fms_error_handler('send_data', err_msg_local, err_msg) ) RETURN
          END IF
       END IF
 
       ! Take care of submitted field data
       IF ( average ) THEN
          IF ( input_fields(diag_field_id)%mask_variant ) THEN
             IF ( need_compute ) THEN
                WRITE (error_string,'(a,"/",a)')  &
                     & TRIM(input_fields(diag_field_id)%module_name), &
                     & TRIM(output_fields(out_num)%output_name)   
                IF ( fms_error_handler('send_data_3d', 'module/output_field '//TRIM(error_string)//&
                     & ', regional output NOT supported with mask_variant', err_msg)) RETURN
             END IF

             ! Should reduced_k_range data be supported with the mask_variant option   ?????
             ! If not, error message should be produced and the reduced_k_range loop below eliminated 
             IF ( PRESENT(mask) ) THEN
                IF ( missvalue_present ) THEN              
                   IF ( debug_diag_manager ) THEN
                      CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                      CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                      IF ( err_msg_local /= '' ) THEN
                         IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                      END IF
                   END IF

                   IF ( reduced_k_range ) THEN 
                      DO k= ksr, ker
                         k1= k - ksr + 1 
                         DO j=js, je
                            DO i=is, ie
                               IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
                                  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
                                       & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
                                       & field(i-is+1+hi, j-js+1+hj, k) * weight1  
                                  output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
                                       & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
                               END IF
                            END DO
                         END DO
                      END DO
                   ELSE
                      DO k=ks, ke 
                         DO j=js, je
                            DO i=is, ie
                               IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
                                  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
                                       & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
                                       & field(i-is+1+hi,j-js+1+hj,k)*weight1
                                  output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
                                       &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
                               END IF
                            END DO
                         END DO
                      END DO
                   END IF
                ELSE
                   WRITE (error_string,'(a,"/",a)')&
                        & TRIM(input_fields(diag_field_id)%module_name), &
                        & TRIM(output_fields(out_num)%output_name)
                   IF ( fms_error_handler('send_data_3d', 'module/output_field '//TRIM(error_string)//&
                        & ', variable mask but no missing value defined', err_msg)) RETURN
                END IF
             ELSE  ! no mask present
                WRITE (error_string,'(a,"/",a)')&
                     & TRIM(input_fields(diag_field_id)%module_name), &
                     & TRIM(output_fields(out_num)%output_name)
                IF(fms_error_handler('send_data_3d','module/output_field '//TRIM(error_string)//&
                     & ', variable mask but no mask given', err_msg)) RETURN
             END IF
          ELSE ! mask_variant=false
             IF ( PRESENT(mask) ) THEN
                IF ( missvalue_present ) THEN
                   IF ( need_compute ) THEN

                      DO k = l_start(3), l_end(3)
                         k1 = k-l_start(3)+1
                         DO j = js, je 
                            DO i = is, ie
                               IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                                  i1 = i-l_start(1)-hi+1 
                                  j1=  j-l_start(2)-hj+1
                                  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
                                     output_fields(out_num)%buffer(i1,j1,k1,sample) =&
                                          & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
                                          & field(i-is+1+hi,j-js+1+hj,k) * weight1                              
                                  ELSE
                                     output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue   
                                  END IF
                               END IF
                            END DO
                         END DO
                      END DO
!$OMP CRITICAL
                      DO j = js, je 
                         DO i = is, ie
                            IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                               output_fields(out_num)%num_elements(sample) = &
                                     output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
                            END IF
                         END DO
                      END DO
!$OMP END CRITICAL
                   ELSE IF ( reduced_k_range ) THEN 
                      DO k=ksr, ker
                         k1 = k - ksr + 1 
                         DO j=js, je
                            DO i=is, ie
                               IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
                                  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
                                       & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
                                       & field(i-is+1+hi,j-js+1+hj,k) * weight1  
                               ELSE
                                  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
                               END IF
                            END DO
                         END DO
                      END DO
                   ELSE
                      IF ( debug_diag_manager ) THEN
                         CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                         CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                         IF ( err_msg_local /= '' ) THEN
                            IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                         END IF
                      END IF
                      DO k=ks, ke
                         DO j=js, je
                            DO i=is, ie
                               IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
                                  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
                                       & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
                                       & field(i-is+1+hi,j-js+1+hj,k) * weight1  
                               ELSE
                                  output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
                               END IF
                            END DO
                         END DO
                      END DO
                   END IF
!$OMP CRITICAL
                   IF ( need_compute .AND. .NOT.phys_window ) THEN
                      IF ( ANY(mask(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3))) ) &
                           & output_fields(out_num)%count_0d(sample) =&
                           & output_fields(out_num)%count_0d(sample) + weight1
                   ELSE
                      IF ( ANY(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
                           & output_fields(out_num)%count_0d(sample)+weight1
                   END IF
!$OMP END CRITICAL
                ELSE ! missing value NOT present
                   IF ( .NOT.ALL(mask(f1:f2,f3:f4,ks:ke)) .AND. mpp_pe() .EQ. mpp_root_pe() ) THEN
                      ! <ERROR STATUS="WARNING">
                      !   Mask will be ignored since missing values were not specified
                      ! </ERROR>
                      CALL error_mesg('warning2 send_data_3d',&
                           & 'Mask will be ignored since missing values were not specified',WARNING)
                   END IF
                   IF ( need_compute ) THEN                 
                      DO j = js, je 
                         DO i = is, ie
                            IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                               i1 = i-l_start(1)-hi+1 
                               j1 =  j-l_start(2)-hj+1
                               output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ &
                                    & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
                            END IF
                         END DO
                      END DO
!$OMP CRITICAL
                      DO j = js, je 
                         DO i = is, ie
                            IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                               output_fields(out_num)%num_elements(sample)=&
                                    & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1

                            END IF
                         END DO
                      END DO
!$OMP END CRITICAL
                   ELSE IF ( reduced_k_range ) THEN 
                      ksr= l_start(3)
                      ker= l_end(3)
                      output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
                           & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)&
                           & + field(f1:f2,f3:f4,ksr:ker)*weight1   
                   ELSE
                      IF ( debug_diag_manager ) THEN
                         CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                         CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                         IF ( err_msg_local /= '') THEN
                            IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                         END IF
                      END IF
                      output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
                           & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample)&
                           & + field(f1:f2,f3:f4,ks:ke)*weight1   
                   END IF
                   IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
                        & output_fields(out_num)%count_0d(sample) + weight1
                END IF
             ELSE ! mask NOT present
                IF ( missvalue_present ) THEN
                   IF ( need_compute ) THEN 
                      DO k = l_start(3), l_end(3)
                         k1 = k - l_start(3) + 1                    
                         DO j = js, je 
                            DO i = is, ie
                               IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN
                                  i1 = i-l_start(1)-hi+1 
                                  j1=  j-l_start(2)-hj+1 
                                  IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
                                     output_fields(out_num)%buffer(i1,j1,k1,sample) =&
                                          & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
                                          & field(i-is+1+hi,j-js+1+hj,k) * weight1
                                  ELSE
                                     output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
                                  END IF
                               END IF
                            END DO
                         END DO
                      END DO
!$OMP CRITICAL
                      DO j = js, je 
                         DO i = is, ie
                            IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN
                               output_fields(out_num)%num_elements(sample) =&
                                    & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
                            END IF
                         END DO
                      END DO
!$OMP END CRITICAL

                      IF ( .NOT.phys_window ) THEN
                         !rab if(any(field(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3)) /= &
                         !rab        & missvalue)) &
                         !rab        & output_fields(out_num)%count_0d = output_fields(out_num)%count_0d + weight1 
                         outer0: DO k = l_start(3), l_end(3)
                            DO j=l_start(2)+hj, l_end(2)+hj
                               DO i=l_start(1)+hi, l_end(1)+hi
                                  IF ( field(i,j,k) /= missvalue ) THEN
                                     output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1    
                                     EXIT outer0
                                  END IF
                               END DO
                            END DO
                         END DO outer0
                      END IF
                   ELSE IF ( reduced_k_range ) THEN 
                      ksr= l_start(3)
                      ker= l_end(3)
                      DO k = ksr, ker
                         k1 = k - ksr + 1
                         DO j=js, je
                            DO i=is, ie
                               IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
                                  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
                                       & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
                                       & field(i-is+1+hi,j-js+1+hj,k) * weight1  
                               ELSE
                                  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
                               END IF
                            END DO
                         END DO
                      END DO
                      !rab
                      !rab if(any(field(f1:f2,f3:f4,ks:ke) /= missvalue)) &
                      !rab       & output_fields(out_num)%count_0d = output_fields(out_num)%count_0d + weight1    
!$OMP CRITICAL
                      outer3: DO k = ksr, ker
                         k1=k-ksr+1
                         DO j=f3, f4 
                            DO i=f1, f2 
                               IF ( field(i,j,k) /= missvalue ) THEN
                                  output_fields(out_num)%count_0d = output_fields(out_num)%count_0d + weight1    
                                  EXIT outer3
                               END IF
                            END DO
                         END DO
                      END DO outer3
!$OMP END CRITICAL
                   ELSE
                      IF ( debug_diag_manager ) THEN
                         CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                         CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                         IF ( err_msg_local /= '' ) THEN
                            IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                         END IF
                      END IF
                      DO k=ks, ke
                         DO j=js, je
                            DO i=is, ie
                               IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue )  THEN
                                  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
                                       & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
                                       & field(i-is+1+hi,j-js+1+hj,k) * weight1  
                               ELSE
                                  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
                               END IF
                            END DO 
                         END DO
                      END DO
                      !rab
                      !rab if(any(field(f1:f2,f3:f4,ks:ke) /= missvalue)) &
                      !rab        & output_fields(out_num)%count_0d = output_fields(out_num)%count_0d + weight1    
!$OMP CRITICAL
                      outer1: DO k=ks, ke 
                         DO j=f3, f4 
                            DO i=f1, f2 
                               IF ( field(i,j,k) /= missvalue ) THEN
                                  output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1    
                                  EXIT outer1
                               END IF
                            END DO
                         END DO
                      END DO outer1
!$OMP END CRITICAL
                   END IF
                ELSE ! no missing value defined, No mask
                   IF ( need_compute ) THEN
                      DO j = js, je  
                         DO i = is, ie                                         
                            IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                               i1 = i-l_start(1)-hi+1 
                               j1=  j-l_start(2)-hj+1
                               output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +&
                                    & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
                            END IF
                         END DO
                      END DO
!$OMP CRITICAL
                      DO j = js, je  
                         DO i = is, ie                                         
                            IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                               output_fields(out_num)%num_elements(sample) =&
                                    & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
                            END IF
                         END DO
                      END DO
!$OMP END CRITICAL
                      ! Accumulate time average 
                   ELSE IF ( reduced_k_range ) THEN 
                      ksr= l_start(3)
                      ker= l_end(3)
                      output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
                           & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + field(f1:f2,f3:f4,ksr:ker)*weight1
                   ELSE 
                      IF ( debug_diag_manager ) THEN
                         CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                         CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                         IF ( err_msg_local /= '' ) THEN
                            IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                         END IF
                      END IF
                      output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
                           & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
                           & field(f1:f2,f3:f4,ks:ke)*weight1
                   END IF
                   IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
                        & output_fields(out_num)%count_0d(sample) + weight1
                END IF
             END IF ! if mask present
          END IF  !if mask_variant
!$OMP CRITICAL
          IF ( .NOT.need_compute )&
               & output_fields(out_num)%num_elements(sample) =&
               & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
          IF ( reduced_k_range ) &
               & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
               & (ie-is+1)*(je-js+1)*(ker-ksr+1)
          ! Add processing for Max and Min
!$OMP END CRITICAL
       ELSE IF ( time_max ) THEN
          IF ( PRESENT(mask) ) THEN
             IF ( need_compute ) THEN
                DO k = l_start(3), l_end(3)
                   k1 = k - l_start(3) + 1
                   DO j = js, je
                      DO i = is, ie
                         IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                            i1 = i-l_start(1)-hi+1 
                            j1=  j-l_start(2)-hj+1
                            IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.&
                                 & field(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample)) THEN
                               output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
                            END IF
                         END IF
                      END DO
                   END DO
                END DO
                ! Maximum time value with masking 
             ELSE IF ( reduced_k_range ) THEN 
                ksr = l_start(3)
                ker = l_end(3)
                WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. &
                     & field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample))&
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
             ELSE
                IF ( debug_diag_manager ) THEN
                   CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                   CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                   IF ( err_msg_local /= '' ) THEN
                      IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                   END IF
                END IF
                WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.&
                     & field(f1:f2,f3:f4,ks:ke)>output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))&
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
             END IF
          ELSE
             IF ( need_compute ) THEN
                DO k = l_start(3), l_end(3)
                   k1 = k - l_start(3) + 1
                   DO j = js, je
                      DO i = is, ie
                         IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                            i1 = i-l_start(1)-hi+1 
                            j1 =  j-l_start(2)-hj+1
                            IF ( field(i-is+1+hi,j-js+1+hj,k) > output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
                               output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
                            END IF
                         END IF
                      END DO
                   END DO
                END DO
                ! Maximum time value 
             ELSE IF ( reduced_k_range ) THEN 
                ksr = l_start(3)
                ker = l_end(3)
                WHERE ( field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
             ELSE
                IF ( debug_diag_manager ) THEN
                   CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                   CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                   IF ( err_msg_local /= '' ) THEN
                      IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                   END IF
                END IF
                WHERE ( field(f1:f2,f3:f4,ks:ke) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
             END IF
          END IF
          output_fields(out_num)%count_0d(sample) = 1
       ELSE IF ( time_min ) THEN
          IF ( PRESENT(mask) ) THEN
             IF ( need_compute ) THEN
                DO k = l_start(3), l_end(3)
                   k1 = k - l_start(3) + 1
                   DO j = js, je
                      DO i = is, ie
                         IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                            i1 = i-l_start(1)-hi+1 
                            j1 =  j-l_start(2)-hj+1
                            IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.&
                                 & field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
                               output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
                            END IF
                         END IF
                      END DO
                   END DO
                END DO
                ! Minimum time value with masking 
             ELSE IF ( reduced_k_range ) THEN 
                ksr= l_start(3)
                ker= l_end(3)
                WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND.&
                     & field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)) &
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
             ELSE
                IF ( debug_diag_manager ) THEN
                   CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                   CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                   IF ( err_msg_local /= '' ) THEN
                      IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                   END IF
                END IF
                WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.&
                     & field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) 
             END IF
          ELSE
             IF ( need_compute ) THEN
                DO k = l_start(3), l_end(3)
                   k1 = k - l_start(3) + 1
                   DO j = js, je
                      DO i = is, ie
                         IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN
                            i1 = i-l_start(1)-hi+1 
                            j1=  j-l_start(2)-hj+1
                            IF ( field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
                               output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
                            END IF
                         END IF
                      END DO
                   END DO
                END DO
                ! Minimum time value 
             ELSE IF ( reduced_k_range ) THEN 
                ksr= l_start(3)
                ker= l_end(3)
                WHERE ( field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
                     output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
             ELSE
                IF ( debug_diag_manager ) THEN
                   CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                   CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                   IF ( err_msg_local /= '' ) THEN
                      IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                   END IF
                END IF
                WHERE ( field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
                     & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
             END IF
          END IF
          output_fields(out_num)%count_0d(sample) = 1
       ELSE  ! ( not average, not min, max)
          output_fields(out_num)%count_0d(sample) = 1
          IF ( need_compute ) THEN
             DO j = js, je 
                DO i = is, ie           
                   IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                      i1 = i-l_start(1)-hi+1 
                      j1 = j-l_start(2)-hj+1
                      output_fields(out_num)%buffer(i1,j1,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
                   END IF
                END DO
             END DO
             ! instantaneous output
          ELSE IF ( reduced_k_range ) THEN 
             ksr = l_start(3)
             ker = l_end(3)
             output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
          ELSE
             IF ( debug_diag_manager ) THEN
                CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
                CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
                IF ( err_msg_local /= '' ) THEN
                   IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg) ) RETURN
                END IF
             END IF
             output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
          END IF
               
          IF ( PRESENT(mask) .AND. missvalue_present ) THEN
             IF ( need_compute ) THEN
                DO k = l_start(3), l_end(3)
                   k1 = k - l_start(3) + 1
                   DO j = js, je
                      DO i = is, ie                                                       
                         IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                            i1 = i-l_start(1)-hi+1 
                            j1 =  j-l_start(2)-hj+1                    
                            IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
                                 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue                     
                         END IF
                      END DO
                   END DO
                END DO
             ELSE IF ( reduced_k_range ) THEN 
                ksr= l_start(3)
                ker= l_end(3)
                DO k=ksr, ker 
                   k1= k - ksr + 1
                   DO j=js, je
                      DO i=is, ie
                         IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
                              & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
                      END DO
                   END DO
                END DO
             ELSE
                DO k=ks, ke
                   DO j=js, je
                      DO i=is, ie
                         IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
                              & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
                      END DO
                   END DO
                END DO
             END IF
          END IF
       END IF !average

       IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN
          CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local)
          IF ( err_msg_local /= '' ) THEN
             IF ( fms_error_handler('send_data in diag_manager_mod', err_msg_local, err_msg)) RETURN
          END IF
       END IF
 
       ! If rmask and missing value present, then insert missing value     
       IF ( PRESENT(rmask) .AND. missvalue_present ) THEN
          IF ( need_compute ) THEN
             DO k = l_start(3), l_end(3)
                k1 = k - l_start(3) + 1
                DO j = js, je 
                   DO i = is, ie                                               
                      IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
                         i1 = i-l_start(1)-hi+1 
                         j1 =  j-l_start(2)-hj+1
                         IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) &
                              & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue                                   
                      END IF
                   END DO
                END DO
             END DO
          ELSE IF ( reduced_k_range ) THEN 
             ksr= l_start(3)
             ker= l_end(3)
             DO k= ksr, ker 
                k1 = k - ksr + 1
                DO j=js, je
                   DO i=is, ie
                      IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) &
                           & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
                   END DO
                END DO
             END DO
          ELSE
             DO k=ks, ke
                DO j=js, je
                   DO i=is, ie
                      IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) &
                           & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
                   END DO
                END DO
             END DO
          END IF
       END IF

    END DO num_out_fields
  END FUNCTION send_data_3d
  ! </FUNCTION>

  ! <FUNCTION NAME="send_tile_averaged_data2d" INTERFACE="send_tile_averaged_data">
  !   <IN NAME="diag_field_id" TYPE="INTEGER"></IN>
  !   <IN NAME="field" TYPE="REAL, DIMENSION(:,:,:)"></IN>
  !   <IN NAME="area" TYPE="REAL, DIMENSION(:,:,:)">  </IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)">  </IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:,:,:), OPTIONAL"></IN>
  LOGICAL FUNCTION send_tile_averaged_data2d ( id, field, area, time, mask )
    INTEGER, INTENT(in) :: id  ! id od the diagnostic field 
    REAL, INTENT(in) :: field(:,:,:) ! field to average and send
    REAL, INTENT(in) :: area (:,:,:) ! area of tiles (== averaging weights), arbitrary units
    TYPE(time_type), INTENT(in)  :: time ! current time
    LOGICAL, INTENT(in),OPTIONAL :: mask (:,:,:) ! land mask

    REAL, DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(SIZE(field,1), SIZE(field,2))

    CALL average_tiles(id, field, area, mask, out)
    send_tile_averaged_data2d = send_data(id, out, time, mask=ANY(mask,DIM=3))
  END FUNCTION send_tile_averaged_data2d
  ! </FUNCTION>

  ! <FUNCTION NAME="send_tile_averaged_data3d" INTERFACE="send_tile_averaged_data">
  !   <IN NAME="diag_field_id" TYPE="INTEGER"></IN>
  !   <IN NAME="field" TYPE="REAL, DIMENSION(:,:,:,:)"></IN>
  !   <IN NAME="area" TYPE="REAL, DIMENSION(:,:,:)"></IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)"></IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:,:,:), OPTIONAL">  </IN>
  LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask )
    INTEGER, INTENT(in) :: id ! id of the diagnostic field
    REAL, DIMENSION(:,:,:,:), INTENT(in) :: field ! (lon, lat, tile, lev) field to average and send
    REAL, DIMENSION(:,:,:), INTENT(in) :: area (:,:,:) ! (lon, lat, tile) tile areas ( == averaging weights), arbitrary units
    TYPE(time_type), INTENT(in)  :: time ! current time
    LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask ! (lon, lat, tile) land mask

    REAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
    LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
    INTEGER :: it

    DO it=1, SIZE(field,4)
       CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
    END DO

    mask3(:,:,1) = ANY(mask,DIM=3)
    DO it = 2, SIZE(field,4)
       mask3(:,:,it) = mask3(:,:,1)
    END DO

    send_tile_averaged_data3d = send_data( id, out, time, mask=mask3 )
  END FUNCTION send_tile_averaged_data3d
  ! </FUNCTION>

  ! <SUBROUTINE NAME="average_tiles">
  !   <OVERVIEW>
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE average_tiles(diag_field_id, x, area, mask, out)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !   </DESCRIPTION>
  !   <IN NAME="diag_field_id" TYPE="INTEGER"></IN>
  !   <IN NAME="x" TYPE="REAL, DIMENSION(:,:,:)">(lon, lat, tile) field to average</IN>
  !   <IN NAME="area" TYPE="REAL, DIMENSION(:,:,:)">(lon, lat, tile) fractional area</IN>
  !   <IN NAME="mask" TYPE="LOGICAL, DIMENSION(:,:,:)">(lon, lat, tile) land mask</IN>
  !   <OUT NAME="out" TYPE="REAL, DIMENSION(:,:)">(lon, lat) result of averaging</OUT>
  SUBROUTINE average_tiles(diag_field_id, x, area, mask, out)
    INTEGER, INTENT(in) :: diag_field_id
    REAL, DIMENSION(:,:,:), INTENT(in) :: x 
    REAL, DIMENSION(:,:,:), INTENT(in) :: area
    LOGICAL, DIMENSION(:,:,:), INTENT(in) :: mask
    REAL, DIMENSION(:,:), INTENT(out) :: out 

    INTEGER  :: it ! iterator over tile number
    REAL, DIMENSION(SIZE(x,1),SIZE(x,2)) :: s ! area accumulator
    REAL :: local_missing_value

    ! Initialize local_missing_value
    IF ( input_fields(diag_field_id)%missing_value_present ) THEN
       local_missing_value = input_fields(diag_field_id)%missing_value
    ELSE 
       local_missing_value = 0.0
    END IF
    
    ! Initialize s and out to zero.
    s(:,:) = 0.0
    out(:,:) = 0.0
    
    DO it = 1, SIZE(area,3)
       WHERE ( mask(:,:,it) ) 
          out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
          s(:,:) = s(:,:) + area(:,:,it)
       END WHERE
    END DO

    WHERE ( s(:,:) > 0 ) 
       out(:,:) = out(:,:)/s(:,:)
    ELSEWHERE
       out(:,:) = local_missing_value
    END WHERE
  END SUBROUTINE average_tiles
  ! </SUBROUTINE>

  INTEGER FUNCTION writing_field(out_num, at_diag_end, error_string, time)
    INTEGER, INTENT(in) :: out_num
    LOGICAL, INTENT(in) :: at_diag_end
    CHARACTER(len=*), INTENT(out) :: error_string
    TYPE(time_type), INTENT(in) :: time

    TYPE(time_type) :: middle_time
    LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
    LOGICAL :: average, need_compute, phys_window
    INTEGER :: in_num, file_num, freq, units
    INTEGER :: b1,b2,b3,b4 ! size of buffer along x,y,z,and diurnal axes
    INTEGER :: i, j, k, m
    REAL    :: missvalue, num

    writing_field = 0
    
    need_compute = output_fields(out_num)%need_compute

    in_num = output_fields(out_num)%input_field
    IF ( input_fields(in_num)%static ) RETURN

    missvalue = input_fields(in_num)%missing_value
    missvalue_present = input_fields(in_num)%missing_value_present
    reduced_k_range = output_fields(out_num)%reduced_k_range
    phys_window = output_fields(out_num)%phys_window
    ! Is this output field being time averaged?
    average = output_fields(out_num)%time_average
    ! Looking for max and min value of this field over the sampling interval?
    time_max = output_fields(out_num)%time_max
    time_min = output_fields(out_num)%time_min   
    file_num = output_fields(out_num)%output_file
    freq = files(file_num)%output_freq
    units = files(file_num)%output_units

    ! If average get size: Average intervals are last_output, next_output
    IF ( average ) THEN
       b1=SIZE(output_fields(out_num)%buffer,1)
       b2=SIZE(output_fields(out_num)%buffer,2) 
       b3=SIZE(output_fields(out_num)%buffer,3)
       b4=SIZE(output_fields(out_num)%buffer,4)
       IF ( input_fields(in_num)%mask_variant ) THEN           
          DO m=1, b4 
             DO k=1, b3
                DO j=1, b2
                   DO i=1, b1 
                      IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )THEN
                         output_fields(out_num)%buffer(i,j,k,m) = &
                              & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
                      ELSE
                         output_fields(out_num)%buffer(i,j,k,m) =  missvalue
                      END IF
                   END DO
                END DO
             END DO
          END DO
       ELSE  !not mask variant
          DO m = 1, b4
             IF ( phys_window ) THEN
                IF ( need_compute .OR. reduced_k_range ) THEN
                   num = REAL(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
                ELSE
                   num = REAL(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
                END IF
             ELSE
                num = output_fields(out_num)%count_0d(m)
             END IF
             IF ( num > 0. ) THEN
                IF ( missvalue_present ) THEN
                   DO k=1, b3
                      DO j=1, b2
                         DO i=1, b1
                            IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue ) &
                                 & output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num  
                         END DO
                      END DO
                   END DO
                ELSE
                   output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
                END IF
             ELSE IF ( .NOT. at_diag_end ) THEN
                IF ( missvalue_present ) THEN
                   IF(ANY(output_fields(out_num)%buffer /= missvalue)) THEN
                      WRITE (error_string,'(a,"/",a)')&
                           & TRIM(input_fields(in_num)%module_name), &
                           & TRIM(output_fields(out_num)%output_name)
                      writing_field = -1
                      RETURN
                   END IF
                END IF
             END IF
          END DO
       END IF ! mask_variant
    ELSE IF ( time_min .OR. time_max ) THEN
       IF ( missvalue_present ) THEN
          WHERE ( ABS(output_fields(out_num)%buffer) == MIN_VALUE ) 
             output_fields(out_num)%buffer = missvalue
          END WHERE
       END IF ! if missvalue is NOT present buffer retains max_value or min_value
    END IF !average

    ! Output field
    IF ( at_diag_end .AND. freq == END_OF_RUN ) output_fields(out_num)%next_output = time
    IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) ) THEN
       middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
       CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time)
    ELSE
       CALL diag_data_out(file_num, out_num, &
            & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
    END IF

    IF ( at_diag_end ) RETURN

    ! Take care of cleaning up the time counters and the storeage size
    output_fields(out_num)%last_output = output_fields(out_num)%next_output
    IF ( freq == END_OF_RUN ) THEN
       output_fields(out_num)%next_output = time
    ELSE
       IF ( freq == EVERY_TIME ) THEN
          output_fields(out_num)%next_output = time
       ELSE
          output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
          output_fields(out_num)%next_next_output = &
               & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
       END IF
       output_fields(out_num)%count_0d(:) = 0.0
       output_fields(out_num)%num_elements(:) = 0
       IF ( time_max ) THEN 
          output_fields(out_num)%buffer = MAX_VALUE
       ELSE IF ( time_min ) THEN
          output_fields(out_num)%buffer = MIN_VALUE
       ELSE
          output_fields(out_num)%buffer = EMPTY
       END IF
       IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
    END IF

  END FUNCTION writing_field

  SUBROUTINE diag_manager_set_time_end(Time_end_in)
    TYPE (time_type), INTENT(in) :: Time_end_in

    Time_end = Time_end_in

  END SUBROUTINE diag_manager_set_time_end

  !-----------------------------------------------------------------------
  SUBROUTINE diag_send_complete(time_step, err_msg)
    TYPE (time_type), INTENT(in)           :: time_step
    character(len=*), INTENT(out), optional :: err_msg
     
    type(time_type)    :: next_time, time
    integer            :: file, j, out_num, in_num, freq, status
    logical            :: local_output, need_compute
    CHARACTER(len=128) :: error_string

    IF(Time_end == Time_zero) CALL mpp_error(FATAL, "diag_manager_mod(diag_send_complete): "//&
              & "diag_manager_set_time_end must be called before calling diag_send_complete")

    DO file = 1, num_files
       freq = files(file)%output_freq
       DO j = 1, files(file)%num_fields
          out_num = files(file)%fields(j) !this is position of output_field in array output_fields
          in_num = output_fields(out_num)%input_field

          IF ( input_fields(in_num)%numthreads == 1 ) CYCLE
          IF ( output_fields(out_num)%static .OR. freq == END_OF_RUN ) CYCLE
          time = input_fields(in_num)%time
          IF ( time >= time_end ) CYCLE

          ! is this field output on a local domain only?
          local_output = output_fields(out_num)%local_output
          ! if local_output, does the current PE take part in send_data?
          need_compute = output_fields(out_num)%need_compute
          ! skip all PEs not participating in outputting this field
          IF ( local_output .AND. (.NOT.need_compute) ) CYCLE
          next_time = time + time_step

          IF ( next_time > output_fields(out_num)%next_output ) THEN
             ! A non-static field that has skipped a time level is an error
             IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 ) THEN
                IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN 
                   WRITE (error_string,'(a,"/",a)')&
                        & TRIM(input_fields(in_num)%module_name), &
                        & TRIM(output_fields(out_num)%output_name)
                   IF ( fms_error_handler('diag_send_complete', 'module/output_field '//TRIM(error_string)//&
                        & ' is skipped one time level in output data', err_msg)) RETURN
                END IF
             END IF

             status = writing_field(out_num, .FALSE., error_string, next_time)
             IF ( status == -1 ) THEN
                IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
                   IF(fms_error_handler('diag_send_complete','module/output_field '//TRIM(error_string)//&
                        & ', write EMPTY buffer', err_msg)) RETURN
                END IF
             END IF
          END IF  !time > output_fields(out_num)%next_output
       END DO
    END DO

  END SUBROUTINE diag_send_complete

  ! <SUBROUTINE NAME="diag_manager_end">
  !   <OVERVIEW>
  !     Exit Diagnostics Manager.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Flushes diagnostic buffers where necessary. Close diagnostics files.
  !
  !     A warning will be issued here if a field in diag_table is not registered
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     SUBROUTINE diag_manager_end(time)
  !   </TEMPLATE>
  !   <IN NAME="TIME" TYPE="time_type"></IN>
  SUBROUTINE diag_manager_end(time)
    TYPE(time_type), INTENT(in) :: time

    INTEGER :: file

    IF ( do_diag_field_log ) THEN
       CALL mpp_close (diag_log_unit)
    END IF
    DO file = 1, num_files
       CALL closing_file(file, time)   
    END DO
  END SUBROUTINE diag_manager_end
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="closing_file">
  !   <OVERVIEW>
  !     Replaces diag_manager_end; close just one file: files(file)
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE closing_file(file, time)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !   </DESCRIPTION>
  !   <IN NAME="file" TYPE="INTEGER"></IN>
  !   <IN NAME="tile" TYPE="TYPE(time_type)"></IN>
  SUBROUTINE closing_file(file, time)
    INTEGER, INTENT(in) :: file
    TYPE(time_type), INTENT(in) :: time

    INTEGER :: j, i, input_num, freq, status
    INTEGER :: stdout_unit
    LOGICAL :: reduced_k_range, need_compute, local_output
    CHARACTER(len=128) :: message

    stdout_unit = stdout()

    ! Output all registered, non_static output_fields
    DO j = 1, files(file)%num_fields
       i = files(file)%fields(j) !this is position of output_field in array output_fields

       ! is this field output on a local domain only?
       local_output = output_fields(i)%local_output
       ! if local_output, does the current PE take part in send_data?
       need_compute = output_fields(i)%need_compute

       reduced_k_range = output_fields(i)%reduced_k_range

       ! skip all PEs not participating in outputting this field
       IF ( local_output .AND. (.NOT. need_compute) ) CYCLE
       ! skip fields that were not registered or non-static   
       input_num = output_fields(i)%input_field
       IF ( input_fields(input_num)%static ) CYCLE
       IF ( .NOT.input_fields(input_num)%register ) CYCLE 
       freq = files(file)%output_freq
       IF ( freq /= END_OF_RUN .AND. files(file)%file_unit < 0 &
            & .AND. ALL(output_fields(i)%num_elements(:) == 0) .AND. ALL(output_fields(i)%count_0d(:) == 0) ) CYCLE
       ! Is it time to output for this field; CAREFUL ABOUT >= vs > HERE
       ! For end should be >= because no more data is coming 
       IF ( time >= output_fields(i)%next_output .OR. freq == END_OF_RUN ) THEN
          IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 ) THEN
             WRITE (message,'(a,"/",a)') TRIM(input_fields(input_num)%module_name), &
                  & TRIM(output_fields(i)%output_name)
             ! <ERROR STATUS="WARNING">
             !   <input_fields(input_num)%module_name>/<output_fields(i)%output_name> skip one time
             !   level, maybe send_data never called
             ! </ERROR>
             IF ( mpp_pe() .EQ. mpp_root_pe() ) & 
                  & CALL error_mesg('diag_manager_end, closing_file', 'module/output_field ' //&
                  & TRIM(message)//', skip one time level, maybe send_data never called', WARNING)
          END IF
          
          status = writing_field(i, .TRUE., message, time)

       ELSEIF ( .NOT.output_fields(i)%written_once ) THEN
          ! <ERROR STATUS="NOTE">
          !   <output_fields(i)%output_name) NOT available, check if output interval > runlength.
          !   NetCDF fill_values are written
          ! </ERROR>
          CALL error_mesg('Potential error in diag_manager_end ',TRIM(output_fields(i)%output_name)//' NOT available,'//&
               & ' check if output interval > runlength. Netcdf fill_values are written', NOTE)
          output_fields(i)%buffer = FILL_VALUE
          CALL diag_data_out(file, i, output_fields(i)%buffer, time, .TRUE.)   
       END IF
    END DO
    ! Now it's time to output static fields
    CALL write_static(file)

    ! Write out the number of bytes of data saved to this file
    IF ( write_bytes_in_file ) THEN
       CALL mpp_sum (files(file)%bytes_written)
       IF ( mpp_pe() == mpp_root_pe() ) WRITE (stdout_unit,'(a,i12,a,a)') 'Diag_Manager: ',files(file)%bytes_written, &
            & ' bytes of data written to file ',TRIM(files(file)%name)
    END IF
  END SUBROUTINE closing_file
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="diag_manager_init">
  !   <OVERVIEW>
  !     Initialize Diagnostics Manager.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE diag_manager_init(diag_model_subset, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Open and read diag_table. Select fields and files for diagnostic output.
  !   </DESCRIPTION>
  !   <IN NAME="diag_model_subset" TYPE="INTEGER, OPTIONAL"></IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL"></OUT>
  SUBROUTINE diag_manager_init(diag_model_subset, err_msg)
    INTEGER, OPTIONAL, INTENT(IN) :: diag_model_subset
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    REAL(kind=FLOAT_KIND) :: foo
    INTEGER :: diag_subset_output
    INTEGER :: mystat, iunit
    INTEGER, ALLOCATABLE, DIMENSION(:) :: pelist
    INTEGER :: stdlog_unit, stdout_unit
    CHARACTER(len=256) :: err_msg_local

    NAMELIST /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
         & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
         & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
         & oor_warnings_fatal

    ! If the module was already initialized do nothing
    IF ( module_is_initialized ) RETURN

    ! Clear the err_msg variable if contains any residual information
    IF ( PRESENT(err_msg) ) err_msg = ''

    min_value = HUGE(foo)
    max_value = -min_value

    ! get stdlog and stdout unit number
    stdlog_unit = stdlog()
    stdout_unit = stdout()

    ! version number to logfile
    CALL write_version_number(version, tagname)

    Time_zero = set_time(0,0)
    !--- initialize time_end to time_zero
    Time_end  = Time_zero
    diag_subset_output = DIAG_ALL
    IF ( PRESENT(diag_model_subset) ) THEN
       IF ( diag_model_subset >= DIAG_OTHER .AND. diag_model_subset <= DIAG_ALL ) THEN
          diag_subset_output = diag_model_subset
       ELSE
          IF ( fms_error_handler('diag_manager_init', 'invalid value of diag_model_subset',err_msg) ) RETURN
       END IF
    END IF

#ifdef INTERNAL_FILE_NML
    READ (input_nml_file, NML=diag_manager_nml, IOSTAT=mystat)
#else
    IF ( file_exist('input.nml') ) THEN
       iunit = open_namelist_file()
       READ (iunit, diag_manager_nml, iostat=mystat)
       CALL close_file(iunit)
    END IF
#endif
    IF ( mystat > 0 ) THEN
       IF ( fms_error_handler('diag_manager_init', 'Error reading diag_manager_nml', err_msg) ) RETURN
    END IF
    IF ( mpp_pe() == mpp_root_pe() ) THEN 
       WRITE (stdlog_unit, diag_manager_nml)
    END IF

    ! Issue note about using the CMOR missing value.
    IF ( use_cmor ) THEN 
       err_msg_local = ''
       WRITE (err_msg_local,'(ES8.1E2)') CMOR_MISSING_VALUE
       CALL error_mesg('diag_manager_mod::diag_manager_init', 'Using CMOR missing value ('//TRIM(err_msg_local)//').', NOTE)
    END IF

    ! How to handle Out of Range Warnings.
    IF ( oor_warnings_fatal ) THEN
       oor_warning = FATAL
       CALL error_mesg('diag_manager_mod::diag_manager_init', 'Out &
            &of Range warnings are fatal.', NOTE)
    ELSEIF ( .NOT.issue_oor_warnings ) THEN
       CALL error_mesg('diag_manager_mod::diag_manager_init', 'Out &
            &of Range warnings will be ignored.', NOTE)
    END IF

    IF ( mix_snapshot_average_fields ) THEN
       IF ( mpp_pe() == mpp_root_pe() ) CALL mpp_error(WARNING,'Namelist '//&
            & 'mix_snapshot_average_fields = .TRUE. will cause ERROR in time coordinates '//&
            & 'of all time_averaged fields. Strongly recommend mix_snapshot_average_fields = .FALSE.')
    END IF
    ALLOCATE(output_fields(max_output_fields))
    ALLOCATE(input_fields(max_input_fields))
    ALLOCATE(files(max_files))
    ALLOCATE(pelist(mpp_npes()))
    CALL mpp_get_current_pelist(pelist, pelist_name)

    CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
    IF ( mystat /= 0 ) THEN
       IF ( fms_error_handler('diag_manager_mod::diag_manager_init',&
            & 'Error parsing diag_table. '//TRIM(err_msg_local), err_msg) ) RETURN
    END IF
    
    !initialize files%bytes_written to zero
    files(:)%bytes_written = 0

    ! open diag field log file
    IF ( do_diag_field_log ) THEN
       CALL mpp_open(diag_log_unit, 'diag_field_log.out', nohdrs=.TRUE.)
    END IF

    module_is_initialized = .TRUE.
    ! create axis_id for scalars here
    null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'X', 'none')
    RETURN
  END SUBROUTINE diag_manager_init
  ! </SUBROUTINE>


  ! <FUNCTION NAME="get_base_time">
  !   <OVERVIEW>
  !     Return base time for diagnostics. 
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(time_type) FUNCTION get_base_time()
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return base time for diagnostics (note: base time must be >= model time).
  !   </DESCRIPTION>
  TYPE(time_type) FUNCTION get_base_time ()
    ! <ERROR STATUS="FATAL">
    !   MODULE has not been initialized
    ! </ERROR>
    IF ( .NOT.module_is_initialized ) CALL error_mesg('get_base_time in diag_manager_mod', &
         & 'module has not been initialized', FATAL)
    get_base_time = base_time
  END FUNCTION get_base_time
  ! </FUNCTION>

  ! <SUBROUTINE NAME="get_base_date">
  !   <OVERVIEW>
  !     Return base date for diagnostics.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_base_date(year, month, day, hour, minute, second)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return date information for diagnostic reference time.
  !   </DESCRIPTION>
  !   <OUT NAME="year" TYPE="INTEGER"></OUT>
  !   <OUT NAME="month" TYPE="INTEGER"></OUT>
  !   <OUT NAME="day" TYPE="INTEGER"></OUT>
  !   <OUT NAME="hour" TYPE="INTEGER"></OUT>
  !   <OUT NAME="minute" TYPE="INTEGER"></OUT>
  !   <OUT NAME="second" TYPE="INTEGER"></OUT>
  SUBROUTINE get_base_date(year, month, day, hour, minute, second)
    INTEGER, INTENT(out) :: year, month, day, hour, minute, second

    ! <ERROR STATUS="FATAL">module has not been initialized</ERROR>
    IF (.NOT.module_is_initialized) CALL error_mesg ('get_base_date in diag_manager_mod', &
         & 'module has not been initialized', FATAL)
    year   = base_year
    month  = base_month
    day    = base_day
    hour   = base_hour
    minute = base_minute
    second = base_second
  END SUBROUTINE get_base_date
  ! </SUBROUTINE>

  ! <FUNCTION NAME="need_data">
  !   <OVERVIEW>
  !     Determine whether data is needed for the current model time step.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     LOGICAL need_data(diag_field_id, next_model_time)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Determine whether data is needed for the current model time step.
  !     Since diagnostic data are buffered, the "next" model time is passed
  !     instead of the current model time. This call can be used to minimize
  !     overhead for complicated diagnostics.
  !   </DESCRIPTION>
  !   <IN NAME="next_model_time" TYPE="TYPE(time_type)">
  !     next_model_time = current model time + model time_step
  !   </IN>
  !   <IN NAME="diag_field_id" TYPE="INTEGER"></IN>
  LOGICAL FUNCTION need_data(diag_field_id, next_model_time)
    TYPE(time_type), INTENT(in) :: next_model_time
    INTEGER, INTENT(in) :: diag_field_id

    INTEGER :: i, out_num 

    need_data = .FALSE.
    IF ( diag_field_id < 0 ) RETURN ! this field is unused
    DO i = 1, input_fields(diag_field_id)%num_output_fields
       ! Get index to an output field
       out_num = input_fields(diag_field_id)%output_fields(i)
       IF ( .NOT.output_fields(out_num)%static ) THEN
          IF ( next_model_time > output_fields(out_num)%next_output ) need_data=.TRUE.
          ! Is this output field being time averaged?
          ! assume average data based on every timestep
          ! needs to be changed when different forms of averaging are implemented 
          IF ( output_fields(out_num)%time_average) need_data = .TRUE. 
       END IF
    END DO
    RETURN
  END FUNCTION need_data
  ! </FUNCTION>

  ! <SUBROUTINE NAME="set_diag_filename_appendix">
  !   <OVERVIEW>
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE set_diag_filename_appendix(string_in)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !   </DESCRIPTION>
  !   <IN NAME="string_in" TYPE="CHARACTER(len=*)"></IN>
  SUBROUTINE set_diag_filename_appendix(string_in)
    CHARACTER(len=*) , INTENT(in) :: string_in
    
    filename_appendix = TRIM(string_in)
  END SUBROUTINE set_diag_filename_appendix
  ! </SUBROUTINE>

  ! <FUNCTION NAME="init_diurnal_axis">
  !   <OVERVIEW>
  !     Finds or initializes a diurnal time axis and returns its' ID.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION init_diurnal_axis(n_samples)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Given number of time intervals in the day, finds or initializes a diurnal time axis
  !     and returns its ID. It uses get_base_date, so should be in the file where it's accessible.
  !     The units are 'days since BASE_DATE', all diurnal axes belong to the set 'diurnal'
  !   </DESCRIPTION>
  !   <IN NAME="n_samples" TYPE="INTEGER">Number of intervals during the day</IN>
  INTEGER FUNCTION init_diurnal_axis(n_samples)
    INTEGER, INTENT(in) :: n_samples ! number of intervals during the day

    REAL :: DATA  (n_samples)   ! central points of time intervals
    REAL :: edges (n_samples+1) ! boundaries of time intervals
    INTEGER :: edges_id ! id of the corresponding edges
    INTEGER :: i
    INTEGER :: year, month, day, hour, minute, second ! components of the base date
    CHARACTER(32)  :: name  ! name of the axis
    CHARACTER(128) :: units ! units of time

    CALL get_base_date(year, month, day, hour, minute, second)
    WRITE (units,11) 'hours', year, month, day, hour, minute, second
11  FORMAT(a,' since ',i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':',i2.2)
    ! compute central points and units
    edges(1) = 0.0
    DO i = 1, n_samples
       DATA (i) = 24.0*(REAL(i)-0.5)/n_samples
       edges(i+1) = 24.0* REAL(i)/n_samples
    END DO

    ! define edges
    name = ''
    WRITE (name,'(a,i2.2)') 'time_of_day_edges_', n_samples
    edges_id = get_axis_num(name, 'diurnal')
    IF ( edges_id <= 0 ) THEN
       edges_id =  diag_axis_init(name,edges,units,'N','time of day edges', set_name='diurnal')
    END IF
  
    ! define axis itself
    name = ''
    WRITE (name,'(a,i2.2)') 'time_of_day_', n_samples
    init_diurnal_axis = get_axis_num(name, 'diurnal')
    IF ( init_diurnal_axis <= 0 ) THEN
       init_diurnal_axis = diag_axis_init(name, DATA, units, 'N', 'time of day', set_name='diurnal', edges=edges_id)
    END IF
  END FUNCTION init_diurnal_axis
  ! </FUNCTION>
END MODULE diag_manager_mod

! <INFO>
!   <COMPILER NAME="PORTABILITY">
!     <TT>diag_manager_mod</TT> uses standard Fortran 90.
!   </COMPILER>
!   <COMPILER NAME="ACQUIRING SOURCE">
!     Use the following commands to check out the source at GFDL.
!     <PRE>
!       setenv CVSROOT '/home/fms/cvs'
!       cvs co diag_manager
!     </PRE>
!   </COMPILER>
!   <COMPILER NAME="COMPILING AND LINKING SOURCE">
!     Any module or program unit using <TT>diag_manager_mod</TT> must contain the line
!     <PRE>
!     use diag_manager_mod
!     </PRE>
!     If netCDF output is desired, the cpp flag <TT>-Duse_netCDF</TT>
!     must be turned on. 
!   </COMPILER>
!   <PRECOMP FLAG="-Duse_netCDF"> 
!     Used to write out <LINK SRC="http://www.unidata.ucar.edu/software/netcdf">NetCDF</LINK> files.
!   </PRECOMP>
!   <PRECOMP FLAG="-Dtest_diag_manager">
!     Used to build the unit test suite for the <TT>diag_manager_mod</TT>.
!   </PRECOMP>
!   <LOADER FLAG="-lnetcdf">
!     Link in the NetCDF libraries.
!   </LOADER>
!   <TESTPROGRAM NAME="test">
!     Unit test for the <TT>diag_manager_mod</TT>.  Each test must be run separately, and ends with an intentional fatal error.
!     Each test has its own <TT>diag_table</TT>, see the source of <TT>diag_manager.F90</TT> for the list of <TT>diag_tables</TT>
!     for the unit tests.
!   </TESTPROGRAM>
!   <FUTURE>
!     Regional output for the cubed-sphere grid.
!   </FUTURE>
! </INFO>

! ********** Test Program **********
#ifdef test_diag_manager
! This program runs only one of many possible tests with each execution.
! Each test ends with an intentional fatal error.
! diag_manager_mod is not a stateless module, and there are situations
! where a fatal error leaves the module in a state that does not allow
! it to function properly if used again. Therefore, the program must
! be terminated after each intentional fatal error.

! Each test is dependent on the diag_table, and different diag_tables
! exist for each test. Depending on the test, an intentional fatal error
! may be triggered upon the call to diag_manager_init, register_diag_field or send_data.
! Because of this, the calls to all of those routines differ depending on the test.

! The diag_table for each test is included below.

!--------------------------------------------------------------------------------------------------
! diag_table for test 1

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat1", "dat1", "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 2

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat1", "dat1", "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 3

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat1", "dat1", "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 4

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
!  "diag_test2", 1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
!  "test_mod",              "dat2", "dat2", "diag_test2", "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 5

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
!  "diag_test2", 1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
!  "test_mod",              "dat2", "dat2", "diag_test2", "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 6

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
!  "diag_test2", 1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
!  "test_mod",              "dat2", "dat2", "diag_test2", "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 7

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat1", "dat1", "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 8

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
!  "diag_test2", 1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
!  "test_mod",              "dat2", "dat2", "diag_test2", "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 9

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "bk",   "bk",   "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 10

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "bk",   "bk",   "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 11

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 12

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
! # Test of the error check that duplicate field names do not appear in same file,
!  "test_mod",              "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 13

! test_diag_manager
! 1 3 1 0 0 0
! #output files
!  "diag_test",  1, "days", 1, "days", "time",
!  "diag_test2", 1, "months", 1, "days", "time",
! #output variables
!  "test_diag_manager_mod", "dat2", "dat2", "diag_test",  "all", .false., "none", 2,
! # Test of WARNING message that no data is written when run length is less than output interval  
!  "test_mod",              "dat2", "dat2", "diag_test2", "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------
! diag_table for test 14

! test_diag_manager
! 1990 1 29 0 0 0
! #output files
!  "diag_test2", 1, "months", 1, "days", "time",
! #output variables
! # Test of check for invalid date. (Jan 29 1990 + one month = Feb 29 1990)
!  "test_mod",              "dat2", "dat2", "diag_test2", "all", .false., "none", 2,
!--------------------------------------------------------------------------------------------------

PROGRAM test
  ! This program runs only one of many possible tests with each execution.
  ! Each test ends with an intentional fatal error.
  ! diag_manager_mod is not a stateless module, and there are situations
  ! where a fatal error leaves the module in a state that does not allow
  ! it to function properly if used again. Therefore, the program must
  ! be terminated after each intentional fatal error.

  ! Each test is dependent on the diag_table, and different diag_tables
  ! exist for each test. Depending on the test, an intentional fatal error
  ! may be triggered upon the call to diag_manager_init, register_diag_field or send_data.
  ! Because of this, the calls to all of those routines differ depending on the test.

  USE mpp_mod, ONLY: mpp_pe, mpp_error, FATAL
  USE mpp_domains_mod, ONLY: domain2d, mpp_define_domains, mpp_get_compute_domain
  USE mpp_domains_mod, ONLY: mpp_define_io_domain, mpp_define_layout
  USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, file_exist, check_nml_error, open_file
  USE fms_mod, ONLY: error_mesg, FATAL, stdlog
#ifdef INTERNAL_FILE_NML
  USE mpp_mod, ONLY: input_nml_file
#else
  USE fms_mod, ONLY:  open_namelist_file, close_file
#endif
  USE fms_io_mod, ONLY: fms_io_exit
  USE constants_mod, ONLY: constants_init, PI, RAD_TO_DEG

  USE time_manager_mod, ONLY: time_type, set_calendar_type, set_date, decrement_date, OPERATOR(+), set_time
  USE time_manager_mod, ONLY: NOLEAP, JULIAN, GREGORIAN, THIRTY_DAY_MONTHS, OPERATOR(*), assignment(=)

  USE diag_manager_mod, ONLY: diag_manager_init, send_data, diag_axis_init, diag_manager_end
  USE diag_manager_mod, ONLY: register_static_field, register_diag_field, diag_send_complete
  USE diag_manager_mod, ONLY: diag_manager_set_time_end

  IMPLICIT NONE

  TYPE(domain2d) :: Domain1
  TYPE(domain2d) :: Domain2

  REAL, ALLOCATABLE, DIMENSION(:) :: lon_global1, lonb_global1
  REAL, ALLOCATABLE, DIMENSION(:) :: lat_global1, latb_global1
  REAL, ALLOCATABLE, DIMENSION(:) :: lon_global2, lonb_global2
  REAL, ALLOCATABLE, DIMENSION(:) :: lat_global2, latb_global2
  REAL, ALLOCATABLE, DIMENSION(:) :: pfull, bk, phalf
  REAL, ALLOCATABLE, DIMENSION(:) :: lon1, lat1, lonb1, latb1
  REAL, ALLOCATABLE, DIMENSION(:) :: lon2, lat2, lonb2, latb2
  REAL, ALLOCATABLE, DIMENSION(:,:,:) :: dat1, dat1h
  REAL, ALLOCATABLE, DIMENSION(:,:,:) :: dat2, dat2h
  REAL, ALLOCATABLE, DIMENSION(:,:) :: dat2_2d
  REAL :: dp, surf_press=1.e5
  INTEGER :: id_phalf, id_pfull, id_bk
  INTEGER :: id_lon1, id_lonb1, id_latb1, id_lat1, id_dat1
  INTEGER :: id_lon2, id_lat2, id_dat2, id_dat2_2d
  INTEGER :: i, j, k, is1, ie1, js1, je1, nml_unit, io, ierr, log_unit, out_unit
  INTEGER :: is_in, ie_in, js_in, je_in
  INTEGER :: is2, ie2, js2, je2, hi=1, hj=1
  INTEGER :: nlon1, nlat1, nlon2, nlat2
  INTEGER, DIMENSION(2) :: layout = (/0,0/)
  INTEGER :: test_number=1
  INTEGER :: nlon=18, nlat=18, nlev=2
  INTEGER :: io_layout(2) = (/0,0/) 
  INTEGER :: nstep = 2
  TYPE(time_type) :: Time, Time_step, Time_end
  LOGICAL :: used, test_successful
  CHARACTER(len=256) :: err_msg
  integer :: omp_get_num_threads

  integer :: nyc1, n, jsw, jew, isw, iew
  integer :: numthreads, ny_per_thread, idthread

  NAMELIST /test_diag_manager_nml/ layout, test_number, nlon, nlat, nlev, io_layout, nstep

  CALL fms_init
  nml_unit = open_namelist_file()
  log_unit = stdlog()
  out_unit = open_file(file='test_diag_manager.out', form='formatted', threading='multi', action='write')
  CALL constants_init
  CALL set_calendar_type(JULIAN)

#ifdef INTERNAL_FILE_NML
  READ (input_nml_file, NML=test_diag_manager_nml, IOSTAT=io)
  ierr = check_nml_error(io, 'test_diag_manager_nml')
#else
  IF ( file_exist('input.nml') ) THEN
     ierr=1
     DO WHILE (ierr /= 0)
        READ(nml_unit, nml=test_diag_manager_nml, iostat=io, END=10)
        ierr = check_nml_error(io, 'test_diag_manager_nml')
     END DO
10   CALL close_file(nml_unit)
  END IF
#endif
  WRITE (log_unit,test_diag_manager_nml)

  IF ( test_number == 12 ) THEN
     CALL diag_manager_init(err_msg=err_msg)
     IF ( err_msg /= '' ) THEN
        WRITE (out_unit,'(a)') 'test12 successful: err_msg='//TRIM(err_msg)
        CALL error_mesg('test_diag_manager','test12 successful.',FATAL)
     ELSE
        WRITE (out_unit,'(a)') 'test12 fails'
        CALL error_mesg('test_diag_manager','test12 fails',FATAL)
     END IF
  ELSE
     CALL diag_manager_init
  END IF

  IF ( layout(1)*layout(2) .NE. mpp_npes() ) THEN
     CALL mpp_define_layout((/1,nlon,1,nlat/), mpp_npes(), layout )
  END IF

  nlon1 = nlon
  nlat1 = nlat
  nlon2 = nlon * 2
  nlat2 = nlat * 2

  CALL mpp_define_domains((/1,nlon1,1,nlat1/), layout, Domain1, name='test_diag_manager')
  CALL mpp_get_compute_domain(Domain1, is1, ie1, js1, je1)
  ALLOCATE(lon_global1(nlon1), lonb_global1(nlon1+1))
  ALLOCATE(lat_global1(nlat1), latb_global1(nlat1+1))
  ALLOCATE(lon_global2(nlon2), lonb_global2(nlon2+1))
  ALLOCATE(lat_global2(nlat2), latb_global2(nlat2+1))
  ALLOCATE(pfull(nlev), bk(nlev), phalf(nlev+1))

  ALLOCATE(lon1(is1:ie1), lat1(js1:je1), lonb1(is1:ie1+1), latb1(js1:je1+1))
  CALL compute_grid(nlon1, nlat1, is1, ie1, js1, je1, lon_global1, lat_global1, lonb_global1, latb_global1, lon1, lat1, lonb1, latb1)
  CALL mpp_define_domains((/1,nlon2,1,nlat2/), layout, Domain2, name='test_diag_manager')
  CALL mpp_get_compute_domain(Domain2, is2, ie2, js2, je2)
  CALL mpp_define_io_domain(Domain1, io_layout)
  CALL mpp_define_io_domain(Domain2, io_layout)    

  ALLOCATE(lon2(is2:ie2), lat2(js2:je2), lonb2(is2:ie2+1), latb2(js2:je2+1))
  CALL compute_grid(nlon2, nlat2, is2, ie2, js2, je2, lon_global2, lat_global2, lonb_global2, latb_global2, lon2, lat2, lonb2, latb2)
  dp = surf_press/nlev
  DO k=1, nlev+1
     phalf(k) = dp*(k-1)
  END DO
  DO k=1, nlev
     pfull(k) = .5*(phalf(k) + phalf(k+1))
     bk(k) = pfull(k)/surf_press
  END DO

  ALLOCATE(dat1(is1:ie1,js1:je1,nlev))
  ALLOCATE(dat1h(is1-hi:ie1+hi,js1-hj:je1+hj,nlev))
  dat1h = 0.
  DO j=js1, je1
     DO i=is1, ie1
        dat1(i,j,1) = SIN(lon1(i))*COS(lat1(j))
     END DO
  END DO
  dat1h(is1:ie1,js1:je1,1) = dat1(:,:,1)
  dat1(:,:,2) = -dat1(:,:,1)
  dat1h(:,:,2) = -dat1h(:,:,1)

  ALLOCATE(dat2(is2:ie2,js2:je2,nlev))
  ALLOCATE(dat2_2d(is2:ie2,js2:je2))
  ALLOCATE(dat2h(is2-hi:ie2+hi,js2-hj:je2+hj,nlev))
  dat2h = 0.
  DO j=js2, je2
     DO i=is2, ie2
        dat2(i,j,1) = SIN(lon2(i))*COS(lat2(j))
     END DO
  END DO
  dat2h(is2:ie2,js2:je2,1) = dat2(:,:,1)
  dat2(:,:,2) = -dat2(:,:,1)
  dat2h(:,:,2) = -dat2h(:,:,1)
  dat2_2d = dat2(:,:,1)

  id_lonb1 = diag_axis_init('lonb1', RAD_TO_DEG*lonb_global1, 'degrees_E', 'x', long_name='longitude edges', Domain2=Domain1)
  id_latb1 = diag_axis_init('latb1', RAD_TO_DEG*latb_global1, 'degrees_N', 'y', long_name='latitude edges',  Domain2=Domain1)

  id_lon1  = diag_axis_init('lon1',  RAD_TO_DEG*lon_global1, 'degrees_E','x',long_name='longitude',Domain2=Domain1,edges=id_lonb1)
  id_lat1  = diag_axis_init('lat1',  RAD_TO_DEG*lat_global1, 'degrees_N','y',long_name='latitude', Domain2=Domain1,edges=id_latb1)

  id_phalf= diag_axis_init('phalf', phalf, 'Pa', 'z', long_name='half pressure level', direction=-1)
  id_pfull= diag_axis_init('pfull', pfull, 'Pa', 'z', long_name='full pressure level', direction=-1, edges=id_phalf)

  id_lon2 = diag_axis_init('lon2',  RAD_TO_DEG*lon_global2,  'degrees_E', 'x', long_name='longitude', Domain2=Domain2)
  id_lat2 = diag_axis_init('lat2',  RAD_TO_DEG*lat_global2,  'degrees_N', 'y', long_name='latitude',  Domain2=Domain2)

  IF ( test_number == 14 ) THEN
     Time = set_date(1990,1,29,0,0,0)
  ELSE
     Time = set_date(1990,1,1,0,0,0)
  END IF

  id_dat1 = register_diag_field('test_diag_manager_mod', 'dat1', (/id_lon1,id_lat1,id_pfull/), Time, 'sample data', 'K')
  id_dat2 = register_diag_field('test_diag_manager_mod', 'dat2', (/id_lon2,id_lat2,id_pfull/), Time, 'sample data', 'K')


  !-- The following is used to test openMP
  IF ( test_number == 15 ) THEN
     numthreads = 1
#if defined(_OPENMP)
!$OMP PARALLEL default(shared) private(idthread)
     numthreads = omp_get_num_threads()
!$OMP END PARALLEL
#endif
      nyc1 = je1 - js1 + 1
      IF (MOD(nyc1, numthreads ) /= 0) THEN
         CALL error_mesg ('test_diag_manager',&
              & 'The number of OpenMP threads must be an integral multiple &
              &of the number of rows in the compute domain', FATAL)
     END IF
     ny_per_thread = nyc1/numthreads

     dat1 = 1
     IF ( MOD(86400,nstep) .NE. 0 ) CALL error_mesg ('test_diag_manager', '86400 must be divided by nstep', FATAL)
     Time_step = set_time(86400/nstep,0)
     Time_end  = Time + nstep*Time_step
     CALL diag_manager_set_time_end(Time_end)
     DO n = 1, nstep

        Time = Time + Time_step
        !$OMP parallel do default(shared) private(isw, iew, jsw, jew )
        
        DO jsw = js1, je1, ny_per_thread
           jew = jsw + ny_per_thread -1
           isw = is1 
           iew = ie1
           if(id_dat1>0) used = send_data(id_dat1, dat1(isw:iew, jsw:jew,:), Time, &
                                is_in=isw-is1+1, js_in=jsw-js1+1,err_msg=err_msg)
        END DO
        !$OMP END parallel do
        CALL diag_send_complete(Time_step) 
     END DO
  END IF


  IF ( test_number == 14 ) THEN
     id_dat2_2d = register_diag_field('test_mod', 'dat2', (/id_lon2,id_lat2/), Time, 'sample data', 'K', err_msg=err_msg)
     IF ( err_msg /= '' ) THEN
        WRITE (out_unit,'(a)') 'test14 successful. err_msg='//TRIM(err_msg)
     ELSE
        WRITE (out_unit,'(a)') 'test14 fails.'
     END IF
  ELSE
     id_dat2_2d = register_diag_field('test_mod', 'dat2', (/id_lon2,id_lat2/), Time, 'sample data', 'K')
  END IF

  id_bk = register_static_field('test_diag_manager_mod', 'bk', (/id_pfull/), 'half level sigma', 'none')

  IF ( test_number == 13 ) THEN
     IF ( id_dat2_2d > 0 ) used=send_data(id_dat2_2d, dat2(:,:,1), Time, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test13: successful if a WARNING message appears that refers to output interval greater than runlength'
     ELSE
        WRITE (out_unit,'(a)') 'test13 fails: err_msg='//TRIM(err_msg)
     END IF
  END IF

  ! Note: test12 involves diag_manager_init, it does not require a call to send_data.
  !       See call to diag_manager_init above.

  IF ( test_number == 11 ) THEN
     is_in = 1+hi
     js_in = 1+hj
     ie_in = ie2-is2+1+hi
     je_in = je2-js2+1+hj

     IF ( id_dat2 > 0 ) used=send_data(id_dat2, dat2h, Time, is_in=is_in, js_in=js_in, ie_in=ie_in, je_in=je_in, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test11.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test11.1 fails. err_msg='//TRIM(err_msg)
     END IF

     ! intentional_error: je_in is missing
     IF ( id_dat2 > 0 ) used=send_data(id_dat2, dat2h, Time, is_in=is_in, js_in=js_in, ie_in=ie_in, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test11.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test11.2 successful. err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 10 ) THEN
     !  1 window, no halos, static, 1 dimension, global data.

     IF ( id_bk > 0 ) used = send_data(id_bk, bk, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test10.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test10.1 fails: err_msg='//TRIM(err_msg)
     END IF

     !  intentional_error: data array too large.
     IF ( id_bk > 0 ) used = send_data(id_bk, phalf, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE(out_unit,'(a)') 'test10.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test10.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 9 ) THEN
     !  1 window, no halos, static, 1 dimension, global data
     IF ( id_bk > 0 ) used = send_data(id_bk, bk, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test9.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test9.1 fails: err_msg='//TRIM(err_msg)
     END IF

     !  intentional_error: data array too small
     IF ( id_bk > 0 ) used = send_data(id_bk, bk(1:nlev-1), err_msg=err_msg) ! intentional_error
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test9.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test9.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 8 ) THEN
     !  1 window with halos
     is_in = 1+hi
     js_in = 1+hj

     ie_in = ie2-is2+1+hi
     je_in = je2-js2+1+hj
     IF ( id_dat2 > 0 ) used=send_data(id_dat2, dat2h, Time, is_in=is_in, js_in=js_in,&
          & ks_in=1, ie_in=ie_in, je_in=je_in, ke_in=nlev, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test8.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test8.1 fails: err_msg='//TRIM(err_msg)
     END IF

     !  intentional_error: data array too small in both x and y directions
     !  Error check is done on second call to send_data. Change in value of Time triggers the check.
     Time = Time + set_time(0,1)
     ie_in = ie1-is1+1+hi
     je_in = je1-js1+1+hj
     IF ( id_dat2 > 0 ) used=send_data(id_dat2, dat1h, Time, is_in=is_in, js_in=js_in,&
          & ks_in=1, ie_in=ie_in, je_in=je_in, ke_in=nlev, err_msg=err_msg)
     Time = Time + set_time(0,1)
     IF ( id_dat2 > 0 ) used=send_data(id_dat2, dat1h, Time, is_in=is_in, js_in=js_in, &
          & ks_in=1, ie_in=ie_in, je_in=je_in, ke_in=nlev, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test8.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test8.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 7 ) THEN
     !  1 window with halos
     is_in = 1+hi
     js_in = 1+hj

     ie_in = ie1-is1+1+hi
     je_in = je1-js1+1+hj
     IF ( id_dat1 > 0 ) used=send_data(id_dat1, dat1h, Time, is_in=is_in, js_in=js_in,&
          & ks_in=1, ie_in=ie_in, je_in=je_in, ke_in=nlev, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test7.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test7.1 fails: err_msg='//TRIM(err_msg)
     END IF

     !  intentional_error: data array too large in both x and y directions
     ie_in = ie2-is2+1+hi
     je_in = je2-js2+1+hj
     IF ( id_dat1 > 0 ) used=send_data(id_dat1, dat2h, Time, is_in=is_in, js_in=js_in,&
          & ks_in=1, ie_in=ie_in, je_in=je_in, ke_in=nlev, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test7.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test7.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 6 ) THEN
     !  multiple windows, no halos
     !  No error messages should appear at any point within either do loop for test6.1
     test_successful = .TRUE.
     DO i=is2, ie2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(i:i,:,:), Time, i-is2+1, 1, err_msg=err_msg)
        IF ( err_msg /= '' ) THEN
           WRITE (out_unit,'(a)') 'test6.1 fails: err_msg='//TRIM(err_msg)
           test_successful = .FALSE.
        END IF
     END DO
     Time = Time + set_time(0,1)
     DO i=is2, ie2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(i:i,:,:), Time, i-is2+1, 1, err_msg=err_msg)
        IF ( err_msg /= '' ) THEN
           WRITE (out_unit,'(a)') 'test6.1 fails: err_msg='//TRIM(err_msg)
           test_successful = .FALSE.
        END IF
     END DO
     IF ( test_successful ) THEN
        WRITE (out_unit,'(a)') 'test6.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test6.1 fails.'
     END IF

     !  intentional_error: data array too small in y direction
     !  Error check is done on second call to send_data. Change in value of Time triggers the check.
     Time = Time + set_time(0,1)
     DO i=is2, ie2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(i:i,js2:je2-1,:), Time, i-is2+1, 1)
     END DO
     Time = Time + set_time(0,1)
     DO i=is2, ie2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(i:i,js2:je2-1,:), Time, i-is2+1, 1, err_msg=err_msg)
        IF ( err_msg /= '' ) EXIT ! exit immediately after error is detected. No need to continue.
     END DO
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test6.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test6.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 5 ) THEN
     !  multiple windows, no halos
     !  No error messages should appear at any point within either do loop for test5.1
     test_successful = .TRUE.
     DO j=js2, je2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(:,j:j,:), Time, 1, j-js2+1, err_msg=err_msg)
        IF ( err_msg /= '' ) THEN
           WRITE (out_unit,'(a)') 'test5.1 fails: err_msg='//TRIM(err_msg)
           test_successful = .FALSE.
        END IF
     END DO
     Time = Time + set_time(0,1)
     DO j=js2, je2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(:,j:j,:), Time, 1, j-js2+1, err_msg=err_msg)
        IF ( err_msg /= '' ) THEN
           WRITE (out_unit,'(a)') 'test5.1 fails: err_msg='//TRIM(err_msg)
           test_successful = .FALSE.
        END IF
     END DO
     IF ( test_successful ) THEN
        WRITE (out_unit,'(a)') 'test5.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test5.1 fails.'
     END IF

     !  intentional_error: data array too small in x direction.
     !  Error check is done on second call to send_data. Change in value of Time triggers the check.
     Time = Time + set_time(0,1)
     DO j=js2, je2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(is2:ie2-1,j:j,:), Time, 1, j-js2+1)
     END DO
     Time = Time + set_time(0,1)
     DO j=js2, je2
        IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2(is2:ie2-1,j:j,:), Time, 1, j-js2+1, err_msg=err_msg)
        IF ( err_msg /= '' ) EXIT ! exit immediately after error is detected. No need to continue.
     END DO
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test5.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test5.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 4 ) THEN
     !  1 window, no halos
     IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2, Time, err_msg=err_msg)
     Time = Time + set_time(0,1)
     IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat2, Time, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test4.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test4.1 fails: err_msg='//TRIM(err_msg)
     END IF

     !  intentional_error: data array too small in both x and y directions
     !  Error check is done on second call to send_data. Change in value of Time triggers the check.
     Time = Time + set_time(0,1)
     IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat1, Time, err_msg=err_msg)
     Time = Time + set_time(0,1)
     IF ( id_dat2 > 0 ) used = send_data(id_dat2, dat1, Time, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test4.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test4.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 3 ) THEN
     !  multiple windows, no halos
     !  No error messages should appear at any point within do loop for test3.1
     test_successful = .TRUE.
     DO i=is1, ie1
        IF ( id_dat1 > 0 ) used = send_data(id_dat1, dat1(i:i,:,:), Time, i-is1+1, 1, err_msg=err_msg)
        IF ( err_msg /= '' ) THEN
           WRITE (out_unit,'(a)') 'test3.1 fails: err_msg='//TRIM(err_msg)
           test_successful = .FALSE.
        END IF
     END DO
     IF ( test_successful ) THEN
        WRITE (out_unit,'(a)') 'test3.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test3.1 fails.'
     END IF

     !  intentional_error: data array too large in y direction
     DO i=is1, ie1
        IF ( id_dat1 > 0 ) used = send_data(id_dat1, dat2(i:i,:,:), Time, i-is1+1, 1, err_msg=err_msg)
        IF ( err_msg /= '' ) EXIT ! exit immediately after error is detected. No need to continue.
     END DO
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test3.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test3.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 2 ) THEN
     !  multiple windows, no halos
     !  No error messages should appear at any point within do loop for test2.1
     test_successful = .TRUE.
     DO j=js1, je1
        IF ( id_dat1 > 0 ) used = send_data(id_dat1, dat1(:,j:j,:), Time, 1, j-js1+1, err_msg=err_msg)
        IF ( err_msg /= '' ) THEN
           WRITE (out_unit,'(a)') 'test2.1 fails: err_msg='//TRIM(err_msg)
           test_successful = .FALSE.
        END IF
     END DO
     IF ( test_successful ) THEN
        WRITE (out_unit,'(a)') 'test2.1 successful.'
     ELSE
        WRITE (out_unit,'(a)') 'test2.1 fails.'
     END IF

     !  intentional_error: data array too large in x direction
     DO j=js1, je1
        IF ( id_dat1 > 0 ) used = send_data(id_dat1, dat2(:,j:j,:), Time, 1, j-js1+1, err_msg=err_msg)
        IF ( err_msg /= '' ) EXIT ! exit immediately after error is detected. No need to continue.
     END DO
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test2.2 fails.'
     ELSE
        WRITE (out_unit,'(a)') 'test2.2 successful: err_msg='//TRIM(err_msg)
     END IF
  END IF

  IF ( test_number == 1 ) THEN
     !  1 window, no halos
     IF ( id_dat1 > 0 ) used = send_data(id_dat1, dat2, Time, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test1.1 fails: Intentional error not detected'
     ELSE
        WRITE (out_unit,'(a)') 'test1.1 successful: '//TRIM(err_msg)
     END IF

     !  intentional_error: data array too large in both x and y directions
     IF ( id_dat1 > 0 ) used = send_data(id_dat1, dat1, Time, err_msg=err_msg)
     IF ( err_msg == '' ) THEN
        WRITE (out_unit,'(a)') 'test1.2 successful'
     ELSE
        WRITE (out_unit,'(a)') 'test1.2 fails: '//TRIM(err_msg)
     END IF
  END IF

  CALL diag_manager_end(Time)
  CALL fms_io_exit
  CALL fms_end

CONTAINS

  SUBROUTINE compute_grid(nlon, nlat, is, ie, js, je, lon_global, lat_global, lonb_global, latb_global, lon, lat, lonb, latb)
    INTEGER, INTENT(in) :: nlon, nlat, is, ie, js, je
    REAL, INTENT(out), DIMENSION(:) :: lon_global, lat_global, lonb_global, latb_global, lon, lat, lonb, latb

    REAL :: dlon, dlat
    INTEGER :: i, j

    dlon = 2*PI/nlon
    dlat = PI/nlat

    DO i=1, nlon+1
       lonb_global(i) = dlon*(i-1)
    END DO
    DO j=1,nlat+1
       latb_global(j) = dlat*(j-1) - .5*PI
    END DO
    DO i=1,nlon
       lon_global(i) = .5*(lonb_global(i) + lonb_global(i+1))
    END DO
    DO j=1,nlat
       lat_global(j) = .5*(latb_global(j) + latb_global(j+1))
    END DO
    lon  = lon_global(is:ie)
    lat  = lat_global(js:je)
    lonb = lonb_global(is:ie+1)
    latb = latb_global(js:je+1)
  END SUBROUTINE compute_grid
END PROGRAM test
#endif


MODULE diag_output_mod
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>

  ! <OVERVIEW> <TT>diag_output_mod</TT> is an integral part of 
  !   <TT>diag_manager_mod</TT>. Its function is to write axis-meta-data, 
  !   field-meta-data and field data
  ! </OVERVIEW>

  USE mpp_io_mod, ONLY: axistype, fieldtype, mpp_io_init, mpp_open,  mpp_write_meta,&
       & mpp_write, mpp_flush, mpp_close, mpp_get_id, MPP_WRONLY, MPP_OVERWR,&
       & MPP_NETCDF, MPP_MULTI, MPP_SINGLE
  USE mpp_domains_mod, ONLY: domain1d, domain2d, mpp_define_domains, mpp_get_pelist,&
       &  mpp_get_global_domain, mpp_get_compute_domains, null_domain1d, null_domain2d,&
       & OPERATOR(.NE.), mpp_get_layout, OPERATOR(.EQ.)
  USE mpp_mod, ONLY: mpp_npes, mpp_pe
  USE diag_axis_mod, ONLY: diag_axis_init, get_diag_axis, get_axis_length,&
       & get_axis_global_length, get_domain1d, get_domain2d, get_axis_aux, get_tile_count
  USE diag_data_mod, ONLY: diag_fieldtype, diag_global_att_type 
  USE time_manager_mod, ONLY: get_calendar_type, valid_calendar_types
  USE fms_mod, ONLY: error_mesg, mpp_pe, write_version_number, FATAL
  USE platform_mod, ONLY: r8_kind

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: diag_output_init, write_axis_meta_data, write_field_meta_data, done_meta_data,&
       & diag_field_out, diag_flush, diag_fieldtype, get_diag_global_att, set_diag_global_att

  TYPE(diag_global_att_type), SAVE :: diag_global_att

  INTEGER, PARAMETER      :: NETCDF1 = 1
  INTEGER, PARAMETER      :: mxch  = 128
  INTEGER, PARAMETER      :: mxchl = 256
  INTEGER                 :: current_file_unit = -1
  INTEGER, DIMENSION(2,2) :: max_range = RESHAPE((/ -32767, 32767, -127,   127 /),(/2,2/))
!  DATA max_range / -32767, 32767, -127,   127 /
  INTEGER, DIMENSION(2)   :: missval = (/ -32768, -128 /)
  
  INTEGER, PARAMETER      :: max_axis_num = 20
  INTEGER                 :: num_axis_in_file = 0
  INTEGER, DIMENSION(max_axis_num) :: axis_in_file   
  LOGICAL, DIMENSION(max_axis_num) :: time_axis_flag, edge_axis_flag
  TYPE(axistype), DIMENSION(max_axis_num), SAVE :: Axis_types

  LOGICAL :: module_is_initialized = .FALSE.

  CHARACTER(len=128), PRIVATE :: version= &
       '$Id: diag_output.F90,v 17.0.8.2 2010/08/03 18:00:39 sdu Exp $'
  CHARACTER(len=128), PRIVATE :: tagname= &
       '$Name: hiram_20101115_bw $'

CONTAINS

  ! <SUBROUTINE NAME="diag_output_init">
  !   <OVERVIEW>
  !     Registers the time axis and opens the output file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE diag_output_init (file_name, format, file_title, file_unit,
  !      all_scalar_or_1d, domain)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Registers the time axis, and opens the file for output.
  !   </DESCRIPTION>
  !   <IN NAME="file_name" TYPE="CHARACTER(len=*)">Output file name</IN>
  !   <IN NAME="format" TYPE="INTEGER">File format (Currently only 'NETCDF' is valid)</IN>
  !   <IN NAME="file_title" TYPE="CHARACTER(len=*)">Descriptive title for the file</IN>
  !   <OUT NAME="file_unit" TYPE="INTEGER">
  !     File unit number assigned to the output file.  Needed for subsuquent calls to
  !     <TT>diag_output_mod</TT>
  !   </OUT>
  !   <IN NAME="all_scalar_or_1d" TYPE="LOGICAL" />
  !   <IN NAME="domain" TYPE="TYPE(domain2d)" />
  SUBROUTINE diag_output_init(file_name, FORMAT, file_title, file_unit,&
       & all_scalar_or_1d, domain)
    CHARACTER(len=*), INTENT(in)  :: file_name, file_title
    INTEGER         , INTENT(in)  :: FORMAT
    INTEGER         , INTENT(out) :: file_unit
    LOGICAL         , INTENT(in)  :: all_scalar_or_1d
    TYPE(domain2d)  , INTENT(in)  :: domain

    ! real(KIND=r8_kind), dimension(1) :: tdata
    INTEGER :: form, threading, fileset
    TYPE(diag_global_att_type) :: gAtt

    !---- initialize mpp_io ----
    IF ( .NOT.module_is_initialized ) THEN
       CALL mpp_io_init ()
       module_is_initialized = .TRUE.
    END IF
    CALL write_version_number( version, tagname )
   
    !---- set up output file ----
    SELECT CASE (FORMAT)
    CASE (NETCDF1)
       form      = MPP_NETCDF
       threading = MPP_MULTI
       fileset   = MPP_MULTI
    CASE default
       ! <ERROR STATUS="FATAL">invalid format</ERROR>
       CALL error_mesg('diag_output_init', 'invalid format', FATAL)
    END SELECT

    IF(all_scalar_or_1d) THEN
       threading = MPP_SINGLE
       fileset   = MPP_SINGLE
    END IF

    !---- open output file (return file_unit id) -----
    IF ( domain .EQ. NULL_DOMAIN2D ) THEN
       CALL mpp_open(file_unit, file_name, action=MPP_OVERWR, form=form,&
            & threading=threading, fileset=fileset)
    ELSE
       CALL mpp_open(file_unit, file_name, action=MPP_OVERWR, form=form,&
            & threading=threading, fileset=fileset, domain=domain) 
    END IF

    !---- write global attributes ----
    IF ( file_title(1:1) /= ' ' ) THEN
       CALL mpp_write_meta(file_unit, 'title', cval=TRIM(file_title))
    END IF

    !---- write grid type (mosaic or regular)
    CALL get_diag_global_att(gAtt)
    CALL mpp_write_meta(file_unit, 'grid_type', cval=TRIM(gAtt%grid_type))
    CALL mpp_write_meta(file_unit, 'grid_tile', cval=TRIM(gAtt%tile_name))

  END SUBROUTINE diag_output_init
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="write_axis_meta_data">
  !   <OVERVIEW>
  !     Write the axes meta data to file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE write_axis_meta_data(file_unit, axes, time_ops)
  !   </TEMPLATE>
  !   <IN NAME="file_unit" TYPE="INTEGER">File unit number</IN>
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)">Array of axis ID's, including the time axis</IN>
  !   <IN NAME="time_ops" TYPE="LOGICAL, OPTIONAL">
  !     .TRUE. if this file contains any min, max, or time_average
  !   </IN>
  SUBROUTINE write_axis_meta_data(file_unit, axes, time_ops)
    INTEGER, INTENT(in) :: file_unit, axes(:)
    LOGICAL, INTENT(in), OPTIONAL :: time_ops

    TYPE(domain1d)       :: Domain
    TYPE(domain1d)       :: Edge_Domain

    CHARACTER(len=mxch)  :: axis_name, axis_units
    CHARACTER(len=mxchl) :: axis_long_name
    CHARACTER(len=1)     :: axis_cart_name
    INTEGER              :: axis_direction, axis_edges
    REAL, ALLOCATABLE    :: axis_data(:)
    INTEGER, ALLOCATABLE :: axis_extent(:), pelist(:)

    INTEGER              :: calendar, id_axis, id_time_axis
    INTEGER              :: i, index, num, length, edges_index
    INTEGER              :: gbegin, gend, gsize, ndivs
    LOGICAL              :: time_ops1

    IF ( PRESENT(time_ops) ) THEN 
       time_ops1 = time_ops
    ELSE
       time_ops1 = .FALSE.
    END IF

    !---- save the current file_unit ----
    IF ( num_axis_in_file == 0 ) current_file_unit = file_unit

    !---- dummy checks ----
    num = SIZE(axes(:))
    ! <ERROR STATUS="FATAL">number of axes < 1 </ERROR>
    IF ( num < 1 ) CALL error_mesg('write_axis_meta_data', 'number of axes < 1.', FATAL)

    ! <ERROR STATUS="FATAL">writing meta data out-of-order to different files.</ERROR>
    IF ( file_unit /= current_file_unit ) CALL error_mesg('write_axis_meta_data',&
         & 'writing meta data out-of-order to different files.', FATAL)

    !---- check all axes ----
    !---- write axis meta data for new axes ----
    DO i = 1, num
       id_axis = axes(i)
       index = get_axis_index ( id_axis )

       !---- skip axes already written -----
       IF ( index > 0 ) CYCLE

       !---- create new axistype (then point to) -----
       num_axis_in_file = num_axis_in_file + 1
       axis_in_file(num_axis_in_file) = id_axis
       edge_axis_flag(num_axis_in_file) = .FALSE.
       length = get_axis_global_length(id_axis)
       ALLOCATE(axis_data(length))

       CALL get_diag_axis(id_axis, axis_name, axis_units, axis_long_name,&
            & axis_cart_name, axis_direction, axis_edges, Domain, axis_data)

       IF ( Domain .NE. null_domain1d ) THEN
          IF ( length > 0 ) THEN
             CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file),&
                  & axis_name, axis_units, axis_long_name, axis_cart_name,&
                  & axis_direction, Domain, axis_data )
          ELSE
             CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
                  & axis_units, axis_long_name, axis_cart_name, axis_direction, Domain)
          END IF
       ELSE
          IF ( length > 0 ) THEN
             CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
                  & axis_units, axis_long_name, axis_cart_name, axis_direction, DATA=axis_data)
          ELSE
             CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
                  & axis_units, axis_long_name, axis_cart_name, axis_direction)
          END IF
       END IF

       !---- write additional attribute (calendar_type) for time axis ----
       !---- NOTE: calendar attribute is compliant with CF convention 
       !---- http://www.cgd.ucar.edu/cms/eaton/netcdf/CF-current.htm#cal
       IF ( axis_cart_name == 'T' ) THEN
          time_axis_flag(num_axis_in_file) = .TRUE.
          id_time_axis = mpp_get_id(Axis_types(num_axis_in_file))
          calendar = get_calendar_type()
          CALL mpp_write_meta(file_unit, id_time_axis, 'calendar_type', cval=TRIM(valid_calendar_types(calendar)))
          CALL mpp_write_meta(file_unit, id_time_axis, 'calendar', cval=TRIM(valid_calendar_types(calendar)))
          IF ( time_ops1 ) THEN 
             CALL mpp_write_meta( file_unit, id_time_axis, 'bounds', cval = TRIM(axis_name)//'_bounds')        
          END IF
       ELSE
          time_axis_flag(num_axis_in_file) = .FALSE.
       END IF
    
       DEALLOCATE(axis_data)

       !------------- write axis containing edge information ---------------

       !  --- this axis has no edges -----
       IF ( axis_edges <= 0 ) CYCLE

       !  --- was this axis edge previously defined? ---
       id_axis = axis_edges
       edges_index = get_axis_index(id_axis)
       IF ( edges_index > 0 ) CYCLE
    
       !  ---- get data for axis edges ----
       length = get_axis_global_length ( id_axis )
       ALLOCATE(axis_data(length))
       CALL get_diag_axis(id_axis, axis_name, axis_units, axis_long_name, axis_cart_name,&
            & axis_direction, axis_edges, Domain, axis_data )

       !  ---- write edges attribute to original axis ----
       CALL mpp_write_meta(file_unit, mpp_get_id(Axis_types(num_axis_in_file)),&
            & 'edges', cval=axis_name )

       !  ---- add edges index to axis list ----
       !  ---- assume this is not a time axis ----
       num_axis_in_file = num_axis_in_file + 1
       axis_in_file(num_axis_in_file) = id_axis
       edge_axis_flag(num_axis_in_file) = .TRUE.
       time_axis_flag (num_axis_in_file) = .FALSE.

       !  ---- write edges axis to file ----
       IF ( Domain .NE. null_domain1d ) THEN
          ! assume domain decomposition is irregular and loop through all prev and next
          ! domain pointers extracting domain extents.  Assume all pes are used in
          ! decomposition
          CALL mpp_get_global_domain(Domain, begin=gbegin, END=gend, size=gsize)
          CALL mpp_get_layout(Domain, ndivs)
          IF ( ndivs .EQ. 1 ) THEN
             CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
                  & axis_units, axis_long_name, axis_cart_name, axis_direction, DATA=axis_data )
          ELSE
             IF ( ALLOCATED(axis_extent) ) DEALLOCATE(axis_extent)
             ALLOCATE(axis_extent(0:ndivs-1))
             CALL mpp_get_compute_domains(Domain,size=axis_extent(0:ndivs-1))
             gend=gend+1
             axis_extent(ndivs-1)= axis_extent(ndivs-1)+1
             IF ( ALLOCATED(pelist) ) DEALLOCATE(pelist)      
             ALLOCATE(pelist(0:ndivs-1))
             CALL mpp_get_pelist(Domain,pelist)
             CALL mpp_define_domains((/gbegin,gend/),ndivs,Edge_Domain,&
                  & pelist=pelist(0:ndivs-1), extent=axis_extent(0:ndivs-1))
             CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file),&
                  & axis_name, axis_units, axis_long_name, axis_cart_name,&
                  & axis_direction, Edge_Domain,  DATA=axis_data)
          END IF
       ELSE
          CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name, axis_units,&
               & axis_long_name, axis_cart_name, axis_direction, DATA=axis_data)
       END IF
       DEALLOCATE (axis_data)
    END DO
  END SUBROUTINE write_axis_meta_data
  ! </SUBROUTINE>

  ! <FUNCTION NAME="write_field_meta_data">
  !   <OVERVIEW>
  !     Write the field meta data to file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(diag_fieldtype) FUNCTION write_field_meta_data(file_unit, name, axes, units,
  !     long_name, rnage, pack, mval, avg_name, time_method, standard_name, interp_method)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     The meta data for the field is written to the file indicated by file_unit
  !   </DESCRIPTION>
  !   <IN NAME="file_unit" TYPE="INTEGER">Output file unit number</IN>
  !   <IN NAME="name" TYPE="CHARACTER(len=*)">Field name</IN>
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)">Array of axis IDs</IN>
  !   <IN NAME="units" TYPE="CHARACTER(len=*)">Field units</IN>
  !   <IN NAME="long_name" TYPE="CHARACTER(len=*)">Field's long name</IN>
  !   <IN NAME="range" TYPE="REAL, DIMENSION(2), OPTIONAL">
  !     Valid range (min, max).  If min > max, the range will be ignored
  !   </IN>
  !   <IN NAME="pack" TYPE="INTEGER, OPTIONAL" DEFAULT="2">
  !     Packing flag.  Only valid when range specified.  Valid values:
  !     <UL>
  !       <LI> 1 = 64bit </LI>
  !       <LI> 2 = 32bit </LI>
  !       <LI> 4 = 16bit </LI>
  !       <LI> 8 =  8bit </LI>
  !     </UL>
  !   </IN>
  !   <IN NAME="mval" TYPE="REAL, OPTIONAL">Missing value, must be within valid range</IN>
  !   <IN NAME="avg_name" TYPE="CHARACTER(len=*), OPTIONAL">
  !     Name of variable containing time averaging info
  !   </IN>
  !   <IN NAME="time_method" TYPE="CHARACTER(len=*), OPTIONAL">
  !     Name of transformation applied to the time-varying data, i.e. "avg", "min", "max"
  !   </IN>
  !   <IN NAME="standard_name" TYPE="CHARACTER(len=*), OPTIONAL">Standard name of field</IN>
  !   <IN NAME="interp_method" TYPE="CHARACTER(len=*), OPTIONAL" />
  FUNCTION write_field_meta_data ( file_unit, name, axes, units, long_name, range, pack,&
       & mval, avg_name, time_method,standard_name,interp_method) result ( Field )
    INTEGER, INTENT(in) :: file_unit, axes(:)
    CHARACTER(len=*), INTENT(in) :: name, units, long_name
    REAL, OPTIONAL, INTENT(in) :: RANGE(2), mval
    INTEGER, OPTIONAL, INTENT(in) :: pack
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: avg_name, time_method,standard_name
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method

    CHARACTER(len=128) :: standard_name2
    TYPE(diag_fieldtype) :: Field
    LOGICAL :: coord_present
    CHARACTER(len=40) :: aux_axes(SIZE(axes))
    CHARACTER(len=160) :: coord_att

    REAL :: scale, add
    INTEGER :: i, indexx, num, ipack, np
    LOGICAL :: use_range
    INTEGER :: axis_indices(SIZE(axes))

    !---- dummy checks ----
    coord_present = .FALSE.
    IF( PRESENT(standard_name) ) THEN 
       standard_name2 = standard_name
    ELSE
       standard_name2 = 'none'
    END IF
    
    num = SIZE(axes(:))
    ! <ERROR STATUS="FATAL">number of axes < 1</ERROR>
    IF ( num < 1 ) CALL error_mesg ( 'write_meta_data', 'number of axes < 1', FATAL)
    ! <ERROR STATUS="FATAL">writing meta data out-of-order to different files</ERROR>
    IF ( file_unit /= current_file_unit ) CALL error_mesg ( 'write_meta_data',  &
         & 'writing meta data out-of-order to different files', FATAL)


    !---- check all axes for this field ----
    !---- set up indexing to axistypes ----
    DO i = 1, num
       indexx = get_axis_index(axes(i))
       !---- point to existing axistype -----
       IF ( indexx > 0 ) THEN
          axis_indices(i) = indexx
       ELSE
          ! <ERROR STATUS="FATAL">axis data not written for field</ERROR>
          CALL error_mesg ('write_field_meta_data',&
               & 'axis data not written for field '//TRIM(name), FATAL)
       END IF
    END DO

    !  Create coordinate attribute
    IF ( num >= 2 ) THEN     
       coord_att = ' '
       DO i = 1, num
          aux_axes(i) = get_axis_aux(axes(i))
          IF( TRIM(aux_axes(i)) /= 'none' ) THEN
             IF(LEN_TRIM(coord_att) == 0) THEN
                coord_att = TRIM(aux_axes(i))
             ELSE
                coord_att = TRIM(coord_att)// ' '//TRIM(aux_axes(i))
             ENDIF
             coord_present = .TRUE.
          END IF
       END DO
    END IF

    !--------------------- write field meta data ---------------------------

    !---- select packing? ----
    !(packing option only valid with range option)
    IF ( PRESENT(pack) ) THEN
       ipack = pack
    ELSE
       ipack = 2
    END IF
    
    !---- check range ----
    use_range = .FALSE.
    add = 0.0
    scale = 1.0
    IF ( PRESENT(range) ) THEN
       IF ( RANGE(2) > RANGE(1) ) THEN
          use_range = .TRUE.
          !---- set packing parameters ----
          IF ( ipack > 2 ) THEN
             np = ipack/4
             add = 0.5*(RANGE(1)+RANGE(2))
             scale = (RANGE(2)-RANGE(1)) / real(max_range(2,np)-max_range(1,np))
          END IF
       END IF
    END IF

    !---- select packing? ----
    IF ( PRESENT(mval) ) THEN
       Field%miss = mval
       Field%miss_present = .TRUE.
       IF ( ipack > 2 ) THEN
          np = ipack/4
          Field%miss_pack = REAL(missval(np))*scale+add
          Field%miss_pack_present = .TRUE.
       ELSE
          Field%miss_pack = mval
          Field%miss_pack_present = .FALSE.
       END IF
    ELSE
       Field%miss_present = .FALSE.
       Field%miss_pack_present = .FALSE.
    END IF

    !------ write meta data and return fieldtype -------
    IF ( use_range ) THEN
       IF ( Field%miss_present ) THEN
          CALL mpp_write_meta(file_unit, Field%Field,&
               & Axis_types(axis_indices(1:num)),&
               & name, units, long_name,&
               & RANGE(1), RANGE(2),&
               & missing=Field%miss_pack,&
               & scale=scale, add=add, pack=ipack,&
               & time_method=time_method)
       ELSE
          CALL mpp_write_meta(file_unit, Field%Field,&
               & Axis_types(axis_indices(1:num)),&
               & name, units,  long_name,&
               & RANGE(1), RANGE(2),&
               & scale=scale, add=add, pack=ipack,&
               & time_method=time_method)
       END IF
    ELSE
       IF ( Field%miss_present ) THEN
          CALL mpp_write_meta(file_unit, Field%Field,&
               & Axis_types(axis_indices(1:num)),&
               & name, units, long_name,&
               & missing=Field%miss_pack,&
               & pack=ipack, time_method=time_method)
       ELSE
          CALL mpp_write_meta(file_unit, Field%Field,&
               & Axis_types(axis_indices(1:num)),&
               & name, units, long_name,&
               & pack=ipack, time_method=time_method)
       END IF
    END IF

    !---- write additional attribute for time averaging -----
    IF ( PRESENT(avg_name) ) THEN
       IF ( avg_name(1:1) /= ' ' ) THEN
          CALL mpp_write_meta(file_unit, mpp_get_id(Field%Field),&
             & 'time_avg_info',&
             & cval=trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT')
       END IF
    END IF

    ! write coordinates attribute for CF compliance
    IF ( coord_present ) &
         CALL mpp_write_meta(file_unit, mpp_get_id(Field%Field),&
         & 'coordinates', cval=TRIM(coord_att))
    IF ( TRIM(standard_name2) /= 'none' ) CALL mpp_write_meta(file_unit, mpp_get_id(Field%Field),&
         & 'standard_name', cval=TRIM(standard_name2))

    !---- write attribute for interp_method ----
    IF( PRESENT(interp_method) ) THEN
       CALL mpp_write_meta ( file_unit, mpp_get_id(Field%Field),&
            & 'interp_method', cval=TRIM(interp_method)) 
    END IF

    !---- get axis domain ----
    Field%Domain = get_domain2d ( axes )
    Field%tile_count = get_tile_count ( axes )

  END FUNCTION write_field_meta_data
  ! </FUNCTION>

  ! <SUBROUTINE NAME="done_meta_data">
  !   <OVERVIEW>
  !     Writes axis data to file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE done_meta_data(file_unit)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Writes axis data to file.  This subroutine is to be called once per file
  !     after all <TT>write_meta_data</TT> calls, and before the first 
  !     <TT>diag_field_out</TT> call.
  !   </DESCRIPTION>
  !   <IN NAME="file_unit" TYPE="INTEGER">Output file unit number</IN>
  SUBROUTINE done_meta_data(file_unit)
    INTEGER,  INTENT(in)  :: file_unit  

    INTEGER               :: i

    !---- write data for all non-time axes ----
    DO i = 1, num_axis_in_file
       IF ( time_axis_flag(i) ) CYCLE
       CALL mpp_write(file_unit, Axis_types(i))
    END DO

    num_axis_in_file = 0
  END SUBROUTINE done_meta_data
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="diag_field_out">
  !   <OVERVIEW>
  !     Writes field data to an output file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE diag_field_out(file_unit, field, data, time)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Writes field data to an output file.
  !   </DESCRIPTION>
  !   <IN NAME="file_unit" TYPE="INTEGER">Output file unit number</IN>
  !   <INOUT NAME="field" TYPE="TYPE(diag_fieldtype)"></INOUT>
  !   <INOUT NAME="data" TYPE="REAL, DIMENSIONS(:,:,:,:)"></INOUT>
  !   <IN NAME="time" TYPE="REAL(KIND=r8_kind), OPTIONAL"></IN>
  SUBROUTINE diag_field_out(file_unit, Field, DATA, time)
    INTEGER, INTENT(in) :: file_unit
    TYPE(diag_fieldtype), INTENT(inout) :: Field
    REAL , INTENT(inout) :: data(:,:,:,:)
    REAL(KIND=r8_kind), OPTIONAL, INTENT(in) :: time

    !---- replace original missing value with (un)packed missing value ----
    !print *, 'PE,name,miss_pack_present=',mpp_pe(), &
    !  trim(Field%Field%name),Field%miss_pack_present
    IF ( Field%miss_pack_present ) THEN
       WHERE ( DATA == Field%miss ) DATA = Field%miss_pack
    END IF

    !---- output data ----
    IF ( Field%Domain .NE. null_domain2d ) THEN
       CALL mpp_write(file_unit, Field%Field, Field%Domain, DATA, time, tile_count=Field%tile_count)
    ELSE
       CALL mpp_write(file_unit, Field%Field, DATA, time)
    END IF
  END SUBROUTINE diag_field_out
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="diag_flush">
  !   <OVERVIEW>
  !     Flush buffer and insure data is not lost.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     CALL diag_flush(file_unit)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     This subroutine can be called periodically to flush the buffer, and
  !     insure that data is not lost if the execution fails.
  !   </DESCRIPTION>
  !   <IN NAME="file_unit" TYPE="INTEGER">Output file unit number to flush</IN>
  SUBROUTINE diag_flush(file_unit)
    INTEGER, INTENT(in) :: file_unit

    CALL mpp_flush (file_unit)
  END SUBROUTINE diag_flush
  ! </SUBROUTINE>


  ! <FUNCTION NAME="get_axis_index">
  !   <OVERVIEW>
  !     Return the axis index number.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_axis_index(num)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the axis index number.
  !   </DESCRIPTION>
  !   <IN NAME="num" TYPE="INTEGER"></IN>
  FUNCTION get_axis_index(num) RESULT ( index )
    INTEGER, INTENT(in) :: num

    INTEGER :: index
    INTEGER :: i

    !---- get the array index for this axis type ----
    !---- set up pointers to axistypes ----
    !---- write axis meta data for new axes ----
    index = 0
    DO i = 1, num_axis_in_file
       IF ( num == axis_in_file(i) ) THEN
          index = i
          EXIT
       END IF
    END DO
  END FUNCTION get_axis_index
  ! </FUNCTION>

  ! <SUBROUTINE NAME="get_diag_global_att">
  !   <OVERVIEW>
  !     Return the global attribute type.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     CALL get_diag_global_att(gAtt)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the global attribute type.
  !   </DESCRIPTION>
  !   <OUT NAME="gAtt" TYPE="TYPE(diag_global_att_type"></OUT>
  SUBROUTINE get_diag_global_att(gAtt)
    TYPE(diag_global_att_type), INTENT(out) :: gAtt

    gAtt=diag_global_att
  END SUBROUTINE get_diag_global_att
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="set_diag_global_att">
  !   <OVERVIEW>
  !     Set the global attribute type.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     CALL set_diag_global_att(component, gridType, timeName)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Set the global attribute type.
  !   </DESCRIPTION>
  !   <IN NAME="component" TYPE="CHARACTER(len=*)"></IN>
  !   <IN NAME="gridType" TYPE="CHARACTER(len=*)"></IN>
  !   <IN NAME="tileName" TYPE="CHARACTER(len=*)"></IN>
  SUBROUTINE set_diag_global_att(component, gridType, tileName)
    CHARACTER(len=*),INTENT(in) :: component, gridType, tileName 

    ! The following two lines are set to remove compile time warnings
    ! about 'only used once'.
    CHARACTER(len=64) :: component_tmp
    component_tmp = component
    ! Don't know how to set these for specific component
    ! Want to be able to say 
    ! if(output_file has component) then
    diag_global_att%grid_type = gridType
    diag_global_att%tile_name = tileName
    ! endif
  END SUBROUTINE set_diag_global_att
  ! </SUBROUTINE>

END MODULE diag_output_mod



MODULE diag_table_mod
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>
  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/" />
  ! <OVERVIEW>
  !   <TT>diag_table_mod</TT> is a set of subroutines use to parse out the data from a <TT>diag_table</TT>.  This module
  !   will also setup the arrays required to store the information by counting the number of input fields, output files, and
  !   files.
  ! </OVERVIEW>
  ! <DESCRIPTION>
  !   <TT>diag_table_mod</TT> parses the <TT>diag_table</TT> file, and sets up the required arrays to hold the information
  !   needed for the <TT>diag_manager_mod</TT> to correctly write out the model history files.
  !
  !   The <I>diagnostics table</I> allows users to specify sampling rates and the choice of fields at run time.  The
  !   <TT>diag_table</TT> file consists of comma-separated ASCII values.  The <TT>diag_table</TT> essentially has three sections:
  !   <B>Global</B>, <B>File</B>, and <B>Field</B> sections.  The <B>Global</B> section must be the first two lines of the file,
  !   whereas the <B>File</B> and <B>Field</B> sections can be inter mixed to allow the file to be organized as desired.
  !   Comments can be added to the <TT>diag_table</TT> file by using the hash symbol (#) as the first character in the line.
  !
  !   All errors in the <TT>diag_table</TT> will throw a <TT>FATAL</TT> error.  A simple utility <TT>diag_table_chk</TT>has been
  !   added to the FRE tools suite to check a <TT>diag_table</TT> for errors.  A brief usage statement can be obtained by running
  !   <TT>diag_table_chk --help</TT>, and a man page like description can views by running <TT>perldoc diag_table_chk</TT>.
  !
  !   Below is a description of the three sections.
  !   <OL>
  !     <LI>
  !       <B>Global Section:</B>  The first two lines of the <TT>diag_table</TT> must contain the <I>title</I> and the <I>base
  !       date</I> of the experiment respectively.  The <I>title</I> must be a Fortran CHARACTER string.  The <I>base date</I>
  !       is the reference time used for the time units, and must be greater than or equal to the model start time.
  !       The <I>base date</I> consists of six space-separated integer in the following format.<BR />
  !       <TT><NOBR>year month day hour minute second</NOBR></TT><BR />
  !     </LI>
  !     <LI>
  !       <B>File Section:</B> File lines contain 6 required and 5 optional fields (optional fields are surrounded with
  !       square brackets ([]).  File lines can be intermixed with the field lines, but the file must be defined before any
  !       fields that are to be written to the file.  File lines have the following format:<BR />
  !       <PRELN>
  !         "file_name", output_freq, "output_freq_units", file_format, "time_axis_units", "time_axis_name"
  !         [, new_file_freq, "new_file_freq_units"[, "start_time"[, file_duration, "file_duration_units"]]]
  !       </PRELN>
  !       <BR />
  !       with the following descriptions.
  !       <DL>
  !         <DT><TT>CHARACTER(len=128) :: file_name</TT></DT>
  !         <DD>
  !           Output file name without the trailing "<TT>.nc</TT>".
  !
  !           A single file description can produce multiple files using special time string suffix keywords.  This time string
  !           will append the time strings to the base file name each time a new file is opened.  They syntax for the time string
  !           suffix keywords are <TT>%#tt</TT> Where <TT>#</TT> is a mandatory single digit number specifying the width of the
  !           field, and <TT>tt</TT> can be as follows:
  !           <NL>
  !             <LI><TT>yr</TT> <EN /> Years</LI>
  !             <LI><TT>mo</TT> <EN /> Months</LI>
  !             <LI><TT>dy</TT> <EN /> Days</LI>
  !             <LI><TT>hr</TT> <EN /> Hours</LI>
  !             <LI><TT>mi</TT> <EN /> Minutes</LI>
  !             <LI><TT>sc</TT> <EN /> Seconds</LI>
  !           </NL>
  !           Thus, a file name of <TT>file2_yr_dy%1yr%3dy</TT> will have a base file name of <TT>file2_yr_dy_1_001</TT> if the
  !           file is created on year 1 day 1 of the model run.  <B><I>NOTE:</I></B> The time suffix keywords must be used if the
  !           optional fields <TT>new_file_freq</TT> and <TT>new_file_freq_units</TT> are used, otherwise a <TT>FATAL</TT> error
  !           will occur.
  !         </DD>
  !
  !         <DT><TT>INTEGER :: output_freq</TT></DT>
  !         <DD>How often to write fields to file.
  !           <NL>
  !             <LI><TT>> 0</TT> <EN /> Output frequency in <TT>output_freq_units</TT>.</LI>
  !             <LI><TT>= 0</TT> <EN /> Output frequency every time set. (<TT>output_freq_units</TT> is ignored.)</LI>
  !             <LI><TT>=-1</TT> <EN /> Output at end of run only. (<TT>output_freq_units</TT> is ignored.)</LI>
  !           </NL>
  !         </DD>
  !         <DT><TT>CHARACTER(len=10) :: output_freq_units</TT></DT>
  !         <DD>
  !           Time units for output.  Can be either <TT>years</TT>, <TT>months</TT>, <TT>days</TT>, <TT>minutes</TT>,
  !           <TT>hours</TT>, or <TT>seconds</TT>.
  !         </DD>
  !         <DT><TT>INTEGER :: file_format</TT></DT>
  !         <DD>
  !           Output file format.  Currently only the <I>netCDF</I> file format is supported.
  !           <NL>
  !             <LI><TT>= 1</TT> <EN /> netCDF</LI>
  !           </NL>
  !         </DD>
  !         <DT><TT>CHARACTER(len=10) :: time_axis_units</TT></DT>
  !         <DD>
  !           Time units for the output file time axis.  Can be either <TT>years</TT>, <TT>months</TT>, <TT>days</TT>,
  !           <TT>minutes</TT>, <TT>hours</TT>, or <TT>seconds</TT>.
  !         </DD>
  !         <DT><TT>CHARACTER(len=128) :: time_axis_name</TT></DT>
  !         <DD>
  !           Axis name for the output file time axis.  The character sting must contain the string 'time'. (mixed upper and
  !           lowercase allowed.)
  !         </DD>
  !         <DT><TT>INTEGER, OPTIONAL :: new_file_freq</TT></DT>
  !         <DD>
  !           Frequency for closing the existing file, and creating a new file in <TT>new_file_freq_units</TT>.
  !         </DD>
  !         <DT><TT>CHARACTER(len=10), OPTIONAL :: new_file_freq_units</TT></DT>
  !         <DD>
  !           Time units for creating a new file.  Can be either <TT>years</TT>, <TT>months</TT>, <TT>days</TT>,
  !           <TT>minutes</TT>, <TT>hours</TT>, or <TT>seconds</TT>.  <B><I>NOTE:</I></B> If the <TT>new_file_freq</TT> field is
  !           present, then this field must also be present.
  !         </DD>
  !         <DT><TT>CHARACTER(len=25), OPTIONAL :: start_time</TT></DT>
  !         <DD>
  !           Time to start the file for the first time.  The format of this string is the same as the <I>global date</I>.  <B><I>
  !           NOTE:</I></B> The <TT>new_file_freq</TT> and the <TT>new_file_freq_units</TT> fields must be present to use this field.
  !         </DD>
  !         <DT><TT>INTEGER, OPTIONAL :: file_duration</TT></DT>
  !         <DD>
  !           How long file should receive data after start time in <TT>file_duration_units</TT>.  This optional field can only
  !           be used if the <TT>start_time</TT> field is present.  If this field is absent, then the file duration will be equal
  !           to the frequency for creating new files.  <B><I>NOTE:</I></B> The <TT>file_duration_units</TT> field must also be
  !           present if this field is present.
  !         </DD>
  !         <DT><TT>CHARACTER(len=10), OPTIONAL :: file_duration_units</TT></DT>
  !         <DD>
  !           File duration units. Can be either <TT>years</TT>, <TT>months</TT>, <TT>days</TT>,
  !           <TT>minutes</TT>, <TT>hours</TT>, or <TT>seconds</TT>.  <B><I>NOTE:</I></B> If the <TT>file_duration</TT> field is
  !           present, then this field must also be present.
  !         </DD>
  !       </DL>
  !     </LI>
  !     <LI>
  !       <B>Field Section:</B> Field lines contain 8 fields.  Field lines can be intermixed with file lines, but the file must
  !       be defined before any fields that are to be written to the file.  Fields line can contain fields that are not written
  !       to any files.  The file name for these fields is <TT>null</TT>.
  !
  !       Field lines have the following format:<BR />
  !       <PRE>
  ! "module_name", "field_name", "output_name", "file_name", "time_sampling", "reduction_method", "regional_section", packing
  !       </PRE>
  !       with the following descriptions.
  !       <DL>
  !         <DT><TT>CHARACTER(len=128) :: module_name</TT></DT>
  !         <DD>Module that contains the <TT>field_name</TT> variable.  (e.g. <TT>atmos_mod</TT>, <TT>land_mod</TT>)</DD>
  !         <DT><TT>CHARACTER(len=128) :: field_name</TT></DT>
  !         <DD>Module variable name that has data to be written to file.</DD>
  !         <DT><TT>CHARACTER(len=128) :: output_name</TT></DT>
  !         <DD>Name of the field as written in <TT>file_name</TT>.</DD>
  !         <DT><TT>CHARACTER(len=128) :: file_name</TT></DT>
  !         <DD>
  !           Name of the file where the field is to be written. <B><I>NOTE:</I></B> The file <TT>file_name</TT> must be
  !           defined first.
  !         </DD>
  !         <DT><TT>CHARACTER(len=50) :: time_sampling</TT></DT>
  !         <DD>Currently not used.  Please use the string "all".</DD>
  !         <DT><TT>CHARACTER(len=50) :: reduction_method</TT></DT>
  !         <DD>
  !           The data reduction method to perform prior to writing data to disk.  Valid options are (redundant names are
  !           separated with commas):
  !           <DL>
  !             <DT><TT>.TRUE.</TT>, average</DT>
  !             <DD>Average from the last time written to the current time.</DD>
  !             <DT><TT>.FALSE.</TT>, none</DT>
  !             <DD>No reduction performed.  Write current time step value only.</DD>
  !             <DT>min</DT> <DD>Minimum value from last write to current time.</DD>
  !             <DT>max</DT> <DD>Maximum value from last write to current time.</DD>
  !             <DT>diurnal##</DT> <DD>## diurnal averages</DD>
  !           </DL>
  !         </DD>
  !         <DT><TT>CHARACTER(len=50) :: regional_section</TT></DT>
  !         <DD>
  !           Bounds of the regional section to capture.  A value of <TT>none</TT> indicates a global region.  The regional
  !           section has the following format:<BR />
  !           <TT>lat_min, lat_max, lon_min, lon_max, vert_min, vert_max</TT><BR />
  !           Use <TT>vert_min = -1</TT> and <TT>vert_max = -1</TT> to get the entire vertical axis.  <B><I>NOTE:</I></B>
  !           Currently, the defined region <I>MUST</I> be confined to a single tile.
  !         </DD>
  !         <DT><TT>INTEGER :: packing</TT></DT>
  !         <DD>
  !           Fortran number <TT>KIND</TT> of the data written.  Valid values:
  !           <NL>
  !             <LI><TT>= 1</TT> <EN /> double precision</LI>
  !             <LI><TT>= 2</TT> <EN /> float</LI>
  !             <LI><TT>= 4</TT> <EN /> packed 16-bit integers</LI>
  !             <LI><TT>= 8</TT> <EN /> packed 1-byte (not tested).</LI>
  !           </NL>
  !         </DD>
  !       </DL>
  !     </LI>
  !   </OL>
  !
  !   <H4><B>Sample <TT>diag_table</TT></B></H4>
  !   <NL>
  !     <LI>
  !       <PRE>
  ! "diag manager test"
  ! 1999 1 1 0 0 0
  !
  ! #output files
  ! 10_days,               10, "days", 1, "hours", "Time"
  ! "file1_hr%hr3",         5, "days", 1, "hours", "Time", 15, "days"
  ! "file2_yr_dy%yr1%dy3",  5, "days", 1, "hours", "Time", 10, "days", "1 1 7 0 0 0"
  ! "file3_yr_dy%yr1%dy3",  5, "days", 1, "hours", "Time", 20, "days", "1 1 7 0 0 0", 5, "years"
  !
  ! #output variables
  ! "ice_mod", "ice", "ice", "10_days", "all", .false., "none", 2
  !
  ! # temp_local file and fields.
  ! temp_local, 1, "days", 1, "hours", "Time"
  ! "ocean_mod", "temp", "temp", "temp_local", "all", .FALSE., "5 259.5 -59.5 59.5 1 1", 2
  !       </PRE>
  !     </LI>
  !   </NL>
  !
  !   <H4>Useful Additional Utility</H4>
  !   A simple utility has been created to help discover
  ! </DESCRIPTION>
  USE mpp_io_mod, ONLY: mpp_open, MPP_RDONLY
  USE fms_mod, ONLY: fms_error_handler, error_mesg, file_exist, stdlog, mpp_pe, mpp_root_pe, FATAL, WARNING, lowercase, close_file
  USE time_manager_mod, ONLY: get_calendar_type, NO_CALENDAR, set_date, set_time, month_name, time_type
  USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE
  
  USE diag_data_mod, ONLY: global_descriptor, base_time, base_year, base_month, base_day, base_hour, base_minute, base_second,&
       & DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, coord_type, append_pelist_name, pelist_name, filename_appendix
  USE diag_util_mod, ONLY: init_file, check_duplicate_output_fields, init_input_field, init_output_field

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: parse_diag_table
  
  TYPE field_description_type
     CHARACTER(len=128) :: module_name, field_name, output_name, file_name
     CHARACTER(len=50) :: time_sampling
     CHARACTER(len=50) :: time_method   
     CHARACTER(len=50) :: spatial_ops
     TYPE(coord_type) :: regional_coords
     INTEGER :: pack
  END TYPE field_description_type

  TYPE file_description_type
     INTEGER :: output_freq 
     INTEGER :: file_format
     INTEGER :: new_file_freq
     INTEGER :: file_duration
     INTEGER :: iTime_units
     INTEGER :: iOutput_freq_units
     INTEGER :: iNew_file_freq_units
     INTEGER :: iFile_duration_units
     CHARACTER(len=128) :: file_name
     CHARACTER(len=10) :: output_freq_units
     CHARACTER(len=10) :: time_units
     CHARACTER(len=128) :: long_name
     CHARACTER(len=10) :: new_file_freq_units
     CHARACTER(len=25) :: start_time_s
     CHARACTER(len=10) :: file_duration_units
     TYPE(time_type) :: start_time
  END TYPE file_description_type

CONTAINS
  
  ! <SUBROUTINE NAME="parse_diag_table">
  !   <OVERVIEW>
  !     Parse the <TT>diag_table</TT> in preparation for diagnostic output.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE parse_diag_table(diag_subset, istat, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>parse_diag_table</TT> is the public interface to parse the diag_table, and setup the arrays needed to store the
  !     requested diagnostics from the <TT>diag_table</TT>.  <TT>parse_diag_table</TT> will return a non-zero <TT>istat</TT> if
  !     a problem parsing the <TT>diag_table</TT>.
  !
  !     NOT YET IMPLEMENTED: <TT>parse_diag_table</TT> will parse through the <TT>diag_table</TT> twice.  The first pass, will be
  !     to get a good "guess" of array sizes.  These arrays, that will hold the requested diagnostic fields and files, will then be
  !     allocated to the size of the "guess" plus a slight increase.
  !   </DESCRIPTION>
  !   <IN NAME="diag_subset" TYPE="INTEGER, OPTIONAL">
  !     Diagnostic sampling subset.
  !   </IN>
  !   <OUT NAME="iunit" TYPE="INTEGER, OPTIONAL">
  !     Status of parsing the <TT>diag_table</TT>.  A non-zero status indicates a problem parsing the table.
  !   </OUT>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">
  !     Error message corresponding to the <TT>istat</TT> return value.
  !   </OUT>
  !   <ERROR STATUS="FATAL">
  !     diag_table file does not exist.
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Error reading the global descriptor from the diagnostic table.
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Error reading the base date from the diagnostic table.
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     The base_year/month/day can not equal zero
  !   </ERROR>
  !   <ERROR STATUS="WARNING">
  !     Problem reading diag_table, line numbers in errors may be incorrect.
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Problem reading the diag_table (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Incorrect file description FORMAT in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Invalid file FORMAT for file description in the diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Invalid time axis units in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Invalid output frequency units in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Invalid NEW file frequency units in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Invalid file duration units in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Invalid start time in the file description in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Field description FORMAT is incorrect in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Packing is out of range for the field description in diag_table. (line: <line_number>)
  !   </ERROR>
  !   <ERROR STATUS="FATAL">
  !     Error in regional output description for field description in diag_table. (line: <line_number>)
  !   </ERROR>
  SUBROUTINE parse_diag_table(diag_subset, istat, err_msg)
    INTEGER, INTENT(in), OPTIONAL :: diag_subset
    INTEGER, INTENT(out), OPTIONAL, TARGET :: istat
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    INTEGER :: iunit !< The Fortran file unit number of the diag_table.
    INTEGER :: stdlog_unit !< Fortran file unit number for the stdlog file.
    INTEGER :: record_len !< String length of the diag_table line read in.
    INTEGER :: line_num !< Integer representation of the line number.
    INTEGER :: commentStart !< Index location of first '#' on line
    INTEGER :: diag_subset_output !< local value of diag_subset
    INTEGER :: nfields, nfiles !< Number of fields and files.  Not used yet.
    INTEGER, TARGET :: mystat !< variable to hold return status of function/subroutine calls.
    INTEGER, POINTER :: pstat !< pointer that points to istat if preset, otherwise, points to mystat.

    CHARACTER(len=5) :: line_number !< String representation of the line number.
    CHARACTER(len=9) :: amonth !< Month name
    CHARACTER(len=256) :: record_line !< Current line from the diag_table.
    CHARACTER(len=256) :: record_first !< Holds the first non-blank line after the global descriptor and the base date.
    CHARACTER(len=256) :: local_err_msg !< Sting to hold local error messages.

    TYPE(file_description_type) :: temp_file
    TYPE(field_description_type) :: temp_field

    ! set up the pstat pointer
    IF ( PRESENT(istat) ) THEN
       pstat => istat
    ELSE
       pstat => mystat
    END IF
    ! Default return value (success)
    pstat = 0

    IF ( PRESENT(diag_subset) ) THEN
       diag_subset_output = diag_subset
    ELSE 
       diag_subset_output = DIAG_ALL
    END IF
    
    ! get the stdlog unit number
    stdlog_unit = stdlog()

    CALL open_diag_table(iunit, IOSTAT=mystat, ERR_MSG=local_err_msg)
    IF ( mystat /= 0 ) THEN
       pstat = mystat
       IF ( fms_error_handler('diag_table_mod::parse_diag_table', TRIM(local_err_msg), err_msg) ) RETURN
    END IF
    
    ! Read in the global file labeling string
    READ (UNIT=iunit, FMT=*, IOSTAT=mystat) global_descriptor
    IF ( mystat /= 0 ) THEN
       pstat = mystat
       IF ( fms_error_handler('diag_table_mod::parse_diag_table', 'Error reading the global descriptor from the diagnostic table.',&
            & err_msg) ) RETURN
    END IF
    
    ! Read in the base date
    READ (UNIT=iunit, FMT=*, IOSTAT=mystat) base_year, base_month, base_day, base_hour, base_minute, base_second
    IF ( mystat /= 0 ) THEN
       pstat = mystat
       IF ( fms_error_handler('diag_manager_init', 'Error reading the base date from the diagnostic table.', err_msg) ) RETURN
    END IF
    
    ! Set up the time type for base time
    IF ( get_calendar_type() /= NO_CALENDAR ) THEN
       IF ( base_year==0 .OR. base_month==0 .OR. base_day==0 ) THEN
          pstat = 101
          IF ( fms_error_handler('diag_table_mod::parse_diag_table', 'The base_year/month/day can not equal zero', err_msg) ) RETURN
       END IF
       base_time = set_date(base_year, base_month, base_day, base_hour, base_minute, base_second)
       amonth = month_name(base_month)
    ELSE
       ! No calendar - ignore year and month
       base_time = set_time(NINT(base_hour*SECONDS_PER_HOUR)+NINT(base_minute*SECONDS_PER_MINUTE)+base_second, base_day)
       base_year = 0
       base_month = 0
       amonth = 'day'
    END IF

    IF ( mpp_pe() == mpp_root_pe() ) THEN
       WRITE (stdlog_unit,'("base date used = ",I4,1X,A,2I3,2(":",I2.2)," gmt")') base_year, TRIM(amonth), base_day, &
            & base_hour, base_minute, base_second
    END IF


    ! Begin the line counter.
    ! Since Fortran doesn't have a simple way to keep track of line numbers, we need to
    !   1) find the next non-blank line.
    !   2) rewind the file.
    !   3) search, while counting lines, for the same line found in (1), and
    !   4) backspace one line (since it may be a file description line) and then continue the file parsing.
    record_len = 0
    DO WHILE ( record_len == 0 )
       ! Find the next non-blank line.
       ! Ignoring IOSTAT.  Using it only to keep program from terminating.
       READ (UNIT=iunit, FMT='(A)', IOSTAT=mystat) record_first
       IF ( mystat == 0 ) THEN 
          record_len = LEN_TRIM(record_first)
       ELSE 
          IF ( mpp_pe() == mpp_root_pe() ) THEN
             CALL error_mesg("diag_table_mod::parse_diag_table",&
                  & "Problem reading diag_table, line numbers in errors may be incorrect.", WARNING)
          END IF
          EXIT
       END IF
    END DO
    
    REWIND(iunit)

    ! Start line counter and look for matching line.
    line_num = 0
    record_line = ''
    DO WHILE ( record_line /= record_first )
       READ (UNIT=iunit, FMT='(A)', IOSTAT=mystat) record_line
       IF ( mystat == 0 ) THEN 
          line_num = line_num + 1
       ELSE 
          IF ( mpp_pe() == mpp_root_pe() ) THEN
             CALL error_mesg("diag_table_mod::parse_diag_table",&
                  & "Problem reading diag_table, line numbers in errors may be incorrect.", WARNING)
          END IF
          EXIT
       END IF
    END DO

    ! Found matching line.  Backspace since this may actually be a file
    ! description line.  Also, count back one.
    BACKSPACE(iunit)
    line_num = line_num - 1

    nfiles=0
    nfields=0
    parser: DO WHILE ( mystat >= 0 )
       ! Read in the entire line from the file.
       ! If there is a read error, give a warning, and
       ! cycle the parser loop.
       READ (iunit, FMT='(A)', IOSTAT=mystat) record_line
       ! Increase line counter, and put in string for use in warning/error messages.
       line_num = line_num + 1
       WRITE (line_number, '(I5)') line_num

       IF ( mystat > 0 ) THEN
          IF ( mpp_pe() == mpp_root_pe() ) &
               & CALL error_mesg("diag_table_mod::parse_diag_table",&
               & "Problem reading the diag_table (line:" //line_number//").", FATAL)
          CYCLE parser
       ELSE IF ( mystat < 0 ) THEN
          EXIT parser
       END IF
       
       ! How long is the read in string?
       record_len = LEN_TRIM(record_line)

       ! ignore blank lines and  lines with comments only (comment marker '#')
       commentStart = INDEX(record_line,'#')
       IF ( commentStart .NE. 0 ) record_line = record_line(1:commentStart-1)
       IF ( LEN_TRIM(record_line) == 0 .OR. record_len == 0 ) CYCLE parser

       init: IF ( is_a_file(TRIM(record_line)) ) THEN
          temp_file = parse_file_line(LINE=record_line, ISTAT=mystat, ERR_MSG=local_err_msg)
          
          IF ( mystat > 0 ) THEN 
             CALL error_mesg("diag_table_mod::parse_diag_table",&
                  & TRIM(local_err_msg)//" (line:" //TRIM(line_number)//").", FATAL)
          ELSE IF ( mystat < 0 ) THEN
             IF ( mpp_pe() == mpp_root_pe() )&
                  & CALL error_mesg("diag_table_mod::parse_diag_table",&
                  & TRIM(local_err_msg)//" (line: "//TRIM(line_number)//").", WARNING)
             CYCLE parser
          ELSE IF ( (diag_subset_output == DIAG_OTHER .AND. VERIFY('ocean', lowercase(temp_file%file_name)) == 0).OR.&
               &    (diag_subset_output == DIAG_OCEAN .AND. VERIFY('ocean', lowercase(temp_file%file_name)) /= 0) ) THEN
             CYCLE parser
          ELSE IF ( temp_file%new_file_freq > 0 ) THEN ! Call the init_file subroutine.  The '1' is for the tile_count
             CALL init_file(temp_file%file_name, temp_file%output_freq, temp_file%iOutput_freq_units, temp_file%file_format,&
                  & temp_file%iTime_units, temp_file%long_name, 1, temp_file%new_file_freq, temp_file%iNew_file_freq_units,&
                  & temp_file%start_time, temp_file%file_duration, temp_file%iFile_duration_units)
          ELSE
             CALL init_file(temp_file%file_name, temp_file%output_freq, temp_file%iOutput_freq_units, temp_file%file_format,&
                  & temp_file%iTime_units, temp_file%long_name, 1)
          END IF
          
          ! Increment number of files
          nfiles = nfiles + 1
       ELSE ! We have a field.
          temp_field = parse_field_line(LINE=record_line, ISTAT=mystat, ERR_MSG=local_err_msg)

          ! Check for errors, then initialize the input and output field
          IF (  mystat > 0 ) THEN
             CALL error_mesg("diag_table_mod::parse_diag_table",&
                  & TRIM(local_err_msg)//" (line: "//TRIM(line_number)//").",FATAL)
          ELSE IF ( mystat < 0 ) THEN
             IF ( mpp_pe() == mpp_root_pe() )&
                  & CALL error_mesg("diag_table_mod::Parse_diag_table",&
                  & TRIM(local_err_msg)//" (line: "//TRIM(line_number)//").",WARNING)
             CYCLE parser
          ELSE IF ( (diag_subset_output == DIAG_OTHER .AND. VERIFY('ocean', lowercase(temp_field%file_name)) == 0).OR.&
               &    (diag_subset_output == DIAG_OCEAN .AND. VERIFY('ocean', lowercase(temp_field%file_name)) /= 0) ) THEN 
             CYCLE parser
          ELSE IF ( lowercase(TRIM(temp_field%spatial_ops)) == 'none' ) THEN
             CALL init_input_field(temp_field%module_name, temp_field%field_name, 1)
             CALL init_output_field(temp_field%module_name, temp_field%field_name, temp_field%output_name, temp_field%file_name,&
                  & temp_field%time_method, temp_field%pack, 1)
          ELSE 
             CALL init_input_field(temp_field%module_name, temp_field%field_name, 1)
             CALL init_output_field(temp_field%module_name, temp_field%field_name, temp_field%output_name, temp_field%file_name,&
                  & temp_field%time_method, temp_field%pack, 1, temp_field%regional_coords)
          END IF

          ! Increment number of fields
          nfields = nfields + 1
       END IF init
    END DO parser

    ! Close the diag_table file.
    CALL close_diag_table(iunit)

    ! check duplicate output_fields in the diag_table
    CALL check_duplicate_output_fields(ERR_MSG=local_err_msg)
    IF ( local_err_msg /= '' ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_diag_table', TRIM(local_err_msg), err_msg) ) RETURN
    END IF

  END SUBROUTINE parse_diag_table
  ! </SUBROUTINE>

  ! <PRIVATE>
  ! <SUBROUTINE NAME="open_diag_table">
  !   <OVERVIEW>
  !     Open the diag_table file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE open_diag_table(iunit, iostat)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Open the <TT>diag_table</TT> file, and return the Fortran file unit number.
  !   </DESCRIPTION>
  !   <OUT NAME="iunit" TYPE="INTEGER">Fortran file unit number of the <TT>diag_table</TT>.</OUT>
  !   <IN NAME="iostat" TYPE="INTEGER, OPTIONAL">
  !     Status of opening file.  If iostat == 0, file exists.  If iostat > 0, the diag_table file does not exist.
  !   </IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">
  !     String to hold the return error message.
  !   </OUT>
  SUBROUTINE open_diag_table(iunit, iostat, err_msg)
    INTEGER, INTENT(out) :: iunit
    INTEGER, INTENT(out), OPTIONAL, TARGET :: iostat
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    INTEGER, TARGET :: mystat
    INTEGER, POINTER :: pstat

    IF ( PRESENT(iostat) ) THEN
       pstat => iostat
    ELSE 
       pstat => mystat
    END IF
    
    IF ( .NOT.file_exist('diag_table') ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::open_diag_table',&
            & 'diag_table file does not exist.', err_msg) ) RETURN
    ELSE 
       pstat = 0
    END IF

    CALL mpp_open(iunit, 'diag_table', action=MPP_RDONLY)
  END SUBROUTINE open_diag_table
  ! </SUBROUTINE>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <SUBROUTINE NAME="close_diag_table">
  !   <OVERVIEW>
  !     Close the diag_table file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE close_diag_table(iunit)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Closes the diag_table file.
  !   </DESCRIPTION>
  !   <IN NAME="iunit" TYPE="INTEGER">Fortran file unit number of the <TT>diag_table</TT>.</IN>
  SUBROUTINE close_diag_table(iunit)
    INTEGER, INTENT(in) :: iunit

    CALL close_file(iunit)
  END SUBROUTINE close_diag_table
  ! </SUBROUTINE>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="parse_file_line">
  !   <OVERVIEW>
  !     Parse a file description line from the <TT>diag_table</TT> file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(file_description_type) FUNCTION parse_file_line(line, istat, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>parse_file_line</TT> parses a file description line from the <TT>diag_table</TT> file, and returns a
  !     <TT>TYPE(file_description_type)</TT>.  The calling function, would then need to call the <TT>init_file</TT> to initialize
  !     the diagnostic output file.
  !   </DESCRIPTION>
  !   <IN NAME="line" TYPE="CHARACTER(len=*)">Line to parse from the <TT>diag_table</TT> file.</IN>
  !   <OUT NAME="istat" TYPE="INTEGER, OPTIONAL">
  !     Return state of the function.  A value of 0 indicates success.  A positive value indicates a <TT>FATAL</TT> error occurred,
  !     and a negative value indicates a <TT>WARNING</TT> should be issued.
  !   </OUT>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">
  !     Error string to include in the <TT>FATAL</TT> or <TT>WARNING</TT> message.
  !   </OUT>
  TYPE(file_description_type) FUNCTION parse_file_line(line, istat, err_msg)
    CHARACTER(len=*), INTENT(in) :: line
    INTEGER, INTENT(out), OPTIONAL, TARGET :: istat
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    INTEGER, TARGET :: mystat
    INTEGER, POINTER :: pstat
    INTEGER :: year, month, day, hour, minute, second
    CHARACTER(len=256) :: local_err_msg !< Hold the return error message from routine calls.

    IF ( PRESENT(istat) ) THEN
       pstat => istat
    ELSE
       pstat => mystat
    END IF
    pstat = 0 ! default success return value

    ! Initialize the optional file description fields.
    parse_file_line%new_file_freq = 0
    parse_file_line%new_file_freq_units = ''
    parse_file_line%start_time_s = ''
    parse_file_line%file_duration = 0
    parse_file_line%file_duration_units = ''

    ! Read in the file description line..
    READ (line, FMT=*, IOSTAT=mystat) parse_file_line%file_name, parse_file_line%output_freq, parse_file_line%output_freq_units,&
         & parse_file_line%file_format, parse_file_line%time_units, parse_file_line%long_name,&
         & parse_file_line%new_file_freq, parse_file_line%new_file_freq_units, parse_file_line%start_time_s,&
         & parse_file_line%file_duration, parse_file_line%file_duration_units
    IF ( mystat > 0 ) THEN
       pstat = mystat
       IF ( fms_error_handler('diag_table_mod::parse_file_line', 'Incorrect file description format in diag_table.', err_msg) )&
            & RETURN
    END IF
          
    ! Fix the file name
    parse_file_line%file_name = fix_file_name(TRIM(parse_file_line%file_name))

    ! Verify values / formats are correct
    IF ( parse_file_line%file_format > 2 .OR. parse_file_line%file_format < 1 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_file_line', 'Invalid file format for file description in the diag_table.',&
            & err_msg) ) RETURN
    END IF
    
    ! check for known units
    parse_file_line%iTime_units = find_unit_ivalue(parse_file_line%time_units)
    parse_file_line%iOutput_freq_units = find_unit_ivalue(parse_file_line%output_freq_units)
    parse_file_line%iNew_file_freq_units = find_unit_ivalue(parse_file_line%new_file_freq_units)
    parse_file_line%iFile_duration_units = find_unit_ivalue(parse_file_line%file_duration_units)
    ! Verify the units are valid
    IF ( parse_file_line%iTime_units < 0 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_file_line', 'Invalid time axis units in diag_table.', err_msg) )&
            & RETURN
    END IF
    IF ( parse_file_line%iOutput_freq_units < 0 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_file_line', 'Invalid output frequency units in diag_table.', err_msg) )&
            & RETURN
    END IF
    IF ( parse_file_line%iNew_file_freq_units < 0 .AND. parse_file_line%new_file_freq > 0 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_file_line', 'Invalid new file frequency units in diag_table.', err_msg) )&
            & RETURN
    END IF
    IF ( parse_file_line%iFile_duration_units < 0 .AND. parse_file_line%file_duration > 0 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_file_line', 'Invalid file duration units in diag_table.', err_msg) )&
            & RETURN
    END IF

    !::sdu::
    !::sdu:: Here is where we would want to parse the regional/global string
    !::sdu::

    ! Check for file frequency, start time and duration presence.
    ! This will determine how the init subroutine is called.
    new_file_freq_present: IF ( parse_file_line%new_file_freq > 0 ) THEN ! New file frequency present.
       IF ( LEN_TRIM(parse_file_line%start_time_s) > 0 ) THEN ! start time present
          READ (parse_file_line%start_time_s, FMT=*, IOSTAT=mystat) year, month, day, hour, minute, second
          IF ( mystat /= 0 ) THEN 
             pstat = 1
             IF ( fms_error_handler('diag_table_mod::parse_file_line',&
                  & 'Invalid start time in the file description in diag_table.', err_msg) ) RETURN
          END IF
          parse_file_line%start_time = set_date(year, month, day, hour, minute, second, err_msg=local_err_msg)
          IF ( local_err_msg /= '' ) THEN
             pstat = 1
             IF ( fms_error_handler('diag_table_mod::parse_file_line', local_err_msg, err_msg) ) RETURN
          END IF
          IF ( parse_file_line%file_duration <= 0 ) THEN ! file_duration not present
             parse_file_line%file_duration = parse_file_line%new_file_freq
             parse_file_line%iFile_duration_units = parse_file_line%iNew_file_freq_units
          END IF
       ELSE
          parse_file_line%start_time = base_time
          parse_file_line%file_duration = parse_file_line%new_file_freq
          parse_file_line%iFile_duration_units = parse_file_line%iNew_file_freq_units
       END IF
    END IF new_file_freq_present

  END FUNCTION parse_file_line
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="parse_field_line">
  !   <OVERVIEW>
  !     Parse a field description line from the <TT>diag_table</TT> file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(field_description_type) FUNCTION parse_field_line(line, istat, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>parse_field_line</TT> parses a field description line from the <TT>diag_table</TT> file, and returns a
  !     <TT>TYPE(field_description_type)</TT>.  The calling function, would then need to call the <TT>init_input_field</TT> and
  !     <TT>init_output_field</TT> to initialize the diagnostic output field.
  !   </DESCRIPTION>
  !   <IN NAME="line" TYPE="CHARACTER(len=*)">Line to parse from the <TT>diag_table</TT> file.</IN>
  !   <OUT NAME="istat" TYPE="INTEGER, OPTIONAL">
  !     Return state of the function.  A value of 0 indicates success.  A positive value indicates a <TT>FATAL</TT> error occurred,
  !     and a negative value indicates a <TT>WARNING</TT> should be issued.
  !   </OUT>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">
  !     Error string to include in the <TT>FATAL</TT> or <TT>WARNING</TT> message.
  !   </OUT>
  TYPE(field_description_type) FUNCTION parse_field_line(line, istat, err_msg)
    CHARACTER(len=*), INTENT(in) :: line
    INTEGER, INTENT(out), OPTIONAL, TARGET :: istat
    CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg

    INTEGER, TARGET :: mystat
    INTEGER, POINTER :: pstat

    IF ( PRESENT(istat) ) THEN
       pstat => istat
    ELSE
       pstat => mystat
    END IF
    pstat = 0 ! default success return value

    READ (line, FMT=*, IOSTAT=mystat) parse_field_line%module_name, parse_field_line%field_name, parse_field_line%output_name,&
         & parse_field_line%file_name, parse_field_line%time_sampling, parse_field_line%time_method, parse_field_line%spatial_ops,&
         & parse_field_line%pack
    IF ( mystat /= 0 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_field_line',&
            & 'Field description format is incorrect in diag_table.', err_msg) ) RETURN
    END IF
              
    ! Fix the file name
    ! Removes any added '.nc' and appends additional information.
    parse_field_line%file_name = fix_file_name(TRIM(parse_field_line%file_name))

    IF ( parse_field_line%pack > 8 .OR. parse_field_line%pack < 1 ) THEN
       pstat = 1
       IF ( fms_error_handler('diag_table_mod::parse_field_line',&
            & 'Packing is out of range for the field description in diag_table.', err_msg) ) RETURN
    END IF
    
    IF ( lowercase(TRIM(parse_field_line%spatial_ops)) /= 'none' ) THEN
       READ (parse_field_line%spatial_ops, FMT=*, IOSTAT=mystat) parse_field_line%regional_coords
       IF ( mystat /= 0 ) THEN
          IF ( fms_error_handler('diag_table_mod::parse_field_line',&
               & 'Error in regional output description for field description in diag_table.', err_msg) ) RETURN
       END IF
    END IF
  END FUNCTION parse_field_line
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="is_a_file">
  !   <OVERVIEW>
  !     Determines if a line from the diag_table file is a file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE LOGICAL FUNCTION is_a_file(line)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>is_a_file</TT> checks a diag_table line to determine if the line describes a file.  If the line describes a file, the
  !     <TT>is_a_file</TT> will return <TT>.TRUE.</TT>.  Otherwise, it will return <TT>.FALSE.</TT>
  !   </DESCRIPTION>
  !   <IN NAME="line" TYPE="CARACTER(len=*)">String containing the <TT>diag_table</TT> line.</IN>
  PURE LOGICAL FUNCTION is_a_file(line)
    CHARACTER(len=*), INTENT(in) :: line

    CHARACTER(len=5) :: first
    INTEGER :: second 
    INTEGER :: mystat !< IO status from read

#if defined __PATHSCALE__ || defined _CRAYFTN
    ! This portion is to 'fix' pathscale's and Cray's Fortran compilers inability to handle the FMT=* correctly in the read
    ! statement.
    CHARACTER(len=10) :: secondString
    INTEGER :: comma1, comma2, linelen

    linelen = LEN(line)
    comma1 = INDEX(line,',') + 1 ! +1 to go past the comma
    comma2 = INDEX(line(comma1:linelen),',') + comma1 - 2 ! -2 to get rid of +1 in comma1 and to get 1 character before the comma

    secondString = ADJUSTL(line(comma1:comma2))
    READ (UNIT=secondString, FMT='(I)', IOSTAT=mystat) second
#else
    READ (UNIT=line, FMT=*, IOSTAT=mystat) first, second
#endif

    ! The line is a file if my status is zero after the read.
    is_a_file = mystat == 0
  END FUNCTION is_a_file
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="fix_file_name(file_name_string)">
  !   <OVERVIEW>
  !     Fixes the file name for use with diagnostic file and field initializations.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE CHARACTER(len=128) FUNCTION fix_file_name(file_name_string)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Removes any trailing '.nc' and appends to the file name additional information
  !     depending on if we are running an ensemble, or requesting append_pelist_name.
  !     
  !     Presently, the ensemble appendix will override the append_pelist_name variable.
  !   </DESCRIPTION>
  !   <IN NAME="file_name_string" TYPE="CHARACTER(len=*)">String containing the file name from the <TT>diag_table</TT>.</IN>
  PURE CHARACTER(len=128) FUNCTION fix_file_name(file_name_string)
    CHARACTER(len=*), INTENT(IN) :: file_name_string

    INTEGER :: file_name_len

    fix_file_name = file_name_string ! Default return value

    file_name_len = LEN_TRIM(file_name_string)

    ! Remove trailing '.nc' from the file_name, and append suffixes
    IF ( file_name_len > 2 ) THEN 
       IF ( file_name_string(file_name_len-2:file_name_len) == '.nc' ) THEN
          fix_file_name = file_name_string(1:file_name_len-3)
          file_name_len = file_name_len - 3
       END IF
    END IF
       
    ! If using ensembles, then append the ensemble information
    ! Or add the optional suffix based on the pe list name if the
    ! append_pelist_name == .TRUE.
    IF ( LEN_TRIM(filename_appendix) > 0 ) THEN 
       fix_file_name(file_name_len+1:) = TRIM(filename_appendix)    
    ELSE IF ( append_pelist_name ) THEN
       fix_file_name(file_name_len+1:) = TRIM(pelist_name)
    END IF
  END FUNCTION fix_file_name
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <FUNCTION NAME="find_unit_ivalue">
  !   <OVERVIEW>
  !     Return the integer value for the given time unit.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     PURE INTEGER FUNCTION find_unit_ivalue(unit_string)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Returns the corresponding integer value for the given time unit.
  !     <UL>
  !       <LI> seconds = 1 </LI>
  !       <LI> minutes = 2 </LI>
  !       <LI> hours = 3 </LI>
  !       <LI> days = 4 </LI>
  !       <LI> months = 5 </LI>
  !       <LI> years = 6 </LI>
  !       <LI> unknown = -1 </LI>
  !     </UL>
  !   </DESCRIPTION>
  !   <IN NAME="unit_string" TYPE="CHARACTER(len=*)">String containing the unit.</IN>
  PURE INTEGER FUNCTION find_unit_ivalue(unit_string)
       CHARACTER(len=*), INTENT(IN) :: unit_string !< Input string, containing the unit.

    SELECT CASE (TRIM(unit_string))
    CASE ('seconds')
       find_unit_ivalue = 1
    CASE ('minutes')
       find_unit_ivalue = 2
    CASE ('hours')
       find_unit_ivalue = 3
    CASE ('days')
       find_unit_ivalue = 4
    CASE ('months') 
       find_unit_ivalue = 5
    CASE ('years')
       find_unit_ivalue = 6
    CASE DEFAULT
       find_unit_ivalue = -1 ! Return statement if an incorrect / unknown unit used.
    END SELECT
  END FUNCTION find_unit_ivalue
  ! </FUNCTION>
  ! </PRIVATE>

  ! <PRIVATE>
  ! <SUBROUTINE NAME="initialize_output_arrays">
  !   <OVERVIEW>
  !     Allocate the file, in and out field arrays after reading the <TT>diag_table</TT> file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE initialize_output_arrays()
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     After reading in the <TT>diag_table</TT> file, the arrays that will hold the file, in, and out field data need to be
  !     allocated.  This routine will determine the size of the arrays, and then allocate the arrays.
  !   </DESCRIPTION>
  SUBROUTINE initialize_output_arrays()
    ! Place Holder
  END SUBROUTINE initialize_output_arrays
  ! </SUBROUTINE>
  ! </PRIVATE>
END MODULE diag_table_mod



MODULE diag_util_mod
  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
  !   Seth Underwood
  ! </CONTACT>
  ! <HISTORY SRC="http://cobweb.gfdl.noaa.gov/fms-cgi-bin/viewcvs/FMS/shared/diag_manager/"/>

  ! <OVERVIEW>
  !   Functions and subroutines necessary for the <TT>diag_manager_mod</TT>.
  ! </OVERVIEW>

  ! <DESCRIPTION>
  !   <TT>diag_util_mod</TT> is a set of Fortran functions and subroutines used by the <TT>diag_manager_mod</TT>.
  ! </DESCRIPTION>

  ! <INFO>
  !   <FUTURE>
  !     Make an interface <TT>check_bounds_are_exact</TT> for the subroutines <TT>check_bounds_are_exact_static</TT> and
  !     <TT>check_bounds_are_exact_dynamic</TT>. 
  !     <PRE>
  !       INTERFACE check_bounds_are_exact
  !         MODULE PROCEDURE check_bounds_are_exact_static
  !         MODULE PROCEDURE check_bounds_are_exact_dynamic
  !       END INTERFACE check_bounds_are_exact
  !     </PRE>
  !   </FUTURE>
  ! </INFO>
  USE diag_data_mod, ONLY  : output_fields, input_fields, files, do_diag_field_log, diag_log_unit,&
       & VERY_LARGE_AXIS_LENGTH, time_zero, VERY_LARGE_FILE_FREQ, END_OF_RUN, EVERY_TIME,&
       & DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, base_time,&
       & time_unit_list, max_files, base_year, base_month, base_day, base_hour, base_minute,&
       & base_second, num_files, max_files, max_fields_per_file, max_out_per_in_field,&
       & max_input_fields,num_input_fields, max_output_fields, num_output_fields, coord_type,&
       & mix_snapshot_average_fields, global_descriptor, CMOR_MISSING_VALUE, use_cmor
  USE diag_axis_mod, ONLY  : get_diag_axis_data, get_axis_global_length, get_diag_axis_cart,&
       & get_domain1d, get_domain2d, diag_subaxes_init, diag_axis_init, get_diag_axis, get_axis_aux,&
       & get_axes_shift, get_diag_axis_name, get_diag_axis_domain_name
  USE diag_output_mod, ONLY: diag_flush, diag_field_out, diag_output_init, write_axis_meta_data,&
       & write_field_meta_data, done_meta_data
  USE diag_grid_mod, ONLY: get_local_indexes
  USE fms_mod, ONLY        : error_mesg, FATAL, WARNING, mpp_pe, mpp_root_pe, lowercase, fms_error_handler
  USE fms_io_mod, ONLY     : get_tile_string, return_domain, string
  USE mpp_domains_mod,ONLY : domain1d, domain2d, mpp_get_compute_domain, null_domain1d, null_domain2d,&
       & OPERATOR(.NE.), OPERATOR(.EQ.), mpp_modify_domain, mpp_get_domain_components,&
       & mpp_get_ntile_count, mpp_get_current_ntile, mpp_get_tile_id, mpp_mosaic_defined, mpp_get_tile_npes
  USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), NO_CALENDAR, increment_date,&
       & increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),&
       & OPERATOR(<), OPERATOR(>=), OPERATOR(<=)
  USE mpp_io_mod, ONLY : mpp_close
  USE mpp_mod, ONLY : mpp_npes
  USE constants_mod, ONLY : SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE

  IMPLICIT NONE
  PRIVATE
  PUBLIC get_subfield_size, log_diag_field_info, update_bounds, check_out_of_bounds,&
       & check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,&
       & find_input_field, init_input_field, init_output_field, diag_data_out, write_static,&
       & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times

  CHARACTER(len=128),PRIVATE  :: version =&
       & '$Id: diag_util.F90,v 18.0.2.5 2010/05/10 16:31:52 sdu Exp $'
  CHARACTER(len=128),PRIVATE  :: tagname =&
       & '$Name: hiram_20101115_bw $'

CONTAINS

  ! <SUBROUTINE NAME="get_subfield_size">
  !   <OVERVIEW>
  !     Get the size, start, and end indices for output fields.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_subfield_size(axes, outnum)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Get the size, start and end indices for <TT>output_fields(outnum)</TT>, then  
  !     fill in <TT>output_fields(outnum)%output_grid%(start_indx, end_indx)</TT>
  !   </DESCRIPTION>
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)">Axes of the <TT>input_field</TT>.</IN>
  !   <IN NAME="outnum" TYPE="INTEGER">Position in array <TT>output_fields</TT>.</IN>
  SUBROUTINE get_subfield_size(axes, outnum)
    INTEGER, INTENT(in) :: axes(:) ! axes of the input_field
    INTEGER, INTENT(in) :: outnum  ! position in array output_fields

    REAL, ALLOCATABLE   :: global_lat(:), global_lon(:), global_depth(:)
    INTEGER :: global_axis_size
    INTEGER :: i,xbegin,xend,ybegin,yend,xbegin_l,xend_l,ybegin_l,yend_l 
    CHARACTER(len=1) :: cart
    TYPE(domain2d) :: Domain2, Domain2_new
    TYPE(domain1d) :: Domain1,Domain1x,Domain1y,Domain1x_new,Domain1y_new
    REAL :: start(3), end(3) ! start and end coordinates in 3 axes
    INTEGER :: gstart_indx(3), gend_indx(3) ! global start and end indices of output domain in 3 axes 
    REAL, ALLOCATABLE :: subaxis_x(:), subaxis_y(:), subaxis_z(:) !containing local coordinates in x,y,z axes
    CHARACTER(len=128) :: msg
    INTEGER :: ishift, jshift
    CHARACTER(len=128), DIMENSION(2) :: axis_domain_name

    !initilization for local output
    ! initially out of (lat/lon/depth) range
    start = -1.e10
    end = -1.e10 
    gstart_indx = -1
    gend_indx=-1

    ! get axis data (lat, lon, depth) and indices
    start = output_fields(outnum)%output_grid%start
    end = output_fields(outnum)%output_grid%end

    CALL get_diag_axis_domain_name(axes(1), axis_domain_name(1))
    CALL get_diag_axis_domain_name(axes(2), axis_domain_name(2))

    IF (   INDEX(lowercase(axis_domain_name(1)), 'cubed') == 0 .AND. &
         & INDEX(lowercase(axis_domain_name(2)), 'cubed') == 0 ) THEN
       DO i = 1, SIZE(axes(:))
          global_axis_size = get_axis_global_length(axes(i))
          output_fields(outnum)%output_grid%subaxes(i) = -1
          CALL get_diag_axis_cart(axes(i), cart)
          SELECT CASE(cart)
          CASE ('X')
             ! <ERROR STATUS="FATAL">wrong order of axes.  X should come first.</ERROR>
             IF( i.NE.1 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
                  & 'wrong order of axes, X should come first',FATAL)
             ALLOCATE(global_lon(global_axis_size))
             CALL get_diag_axis_data(axes(i),global_lon)
             IF( INT( start(i)*END(i) ) == 1 ) THEN 
                gstart_indx(i) = 1
                gend_indx(i) = global_axis_size
                output_fields(outnum)%output_grid%subaxes(i) = axes(i)
             ELSE 
                gstart_indx(i) = get_index(start(i),global_lon)
                gend_indx(i) = get_index(END(i),global_lon)
             END IF
             ALLOCATE(subaxis_x(gstart_indx(i):gend_indx(i)))
             subaxis_x=global_lon(gstart_indx(i):gend_indx(i))   
          CASE ('Y')
             ! <ERROR STATUS="FATAL">wrong order of axes, Y should come second.</ERROR>
             IF( i.NE.2 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
                  & 'wrong order of axes, Y should come second',FATAL)
             ALLOCATE(global_lat(global_axis_size))
             CALL get_diag_axis_data(axes(i),global_lat)
             IF( INT( start(i)*END(i) ) == 1 ) THEN 
                gstart_indx(i) = 1
                gend_indx(i) = global_axis_size
                output_fields(outnum)%output_grid%subaxes(i) = axes(i)
             ELSE
                gstart_indx(i) = get_index(start(i),global_lat)
                gend_indx(i) = get_index(END(i),global_lat)
             END IF
             ALLOCATE(subaxis_y(gstart_indx(i):gend_indx(i)))
             subaxis_y=global_lat(gstart_indx(i):gend_indx(i))
          CASE ('Z')
             ! <ERROR STATUS="FATAL">wrong values in vertical axis of region</ERROR>
             IF ( start(i)*END(i)<0 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
                  & 'wrong values in vertical axis of region',FATAL)
             IF ( start(i)>=0 .AND. END(i)>0 ) THEN 
                ALLOCATE(global_depth(global_axis_size))
                CALL get_diag_axis_data(axes(i),global_depth)
                gstart_indx(i) = get_index(start(i),global_depth)
                gend_indx(i) = get_index(END(i),global_depth)
                ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
                subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
                output_fields(outnum)%output_grid%subaxes(i) =&
                     & diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
                DEALLOCATE(subaxis_z,global_depth)
             ELSE ! regional vertical axis is the same as global vertical axis
                gstart_indx(i) = 1
                gend_indx(i) = global_axis_size
                output_fields(outnum)%output_grid%subaxes(i) = axes(i)
                ! <ERROR STATUS="FATAL">i should equal 3 for z axis</ERROR>
                IF( i /= 3 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
                     & 'i should equal 3 for z axis', FATAL)
             END IF
          CASE default
             ! <ERROR STATUS="FATAL">Wrong axis_cart</ERROR>
             CALL error_mesg('diag_util_mod::get_subfield_size', 'Wrong axis_cart', FATAL)
          END SELECT
       END DO

       DO i = 1, SIZE(axes(:))
          IF( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 ) THEN
             ! <ERROR STATUS="FATAL">
             !   can not find gstart_indx/gend_indx for <output_fields(outnum)%output_name>,
             !   check region bounds for axis <i>.
             ! </ERROR>
             WRITE(msg,'(A,I2)') ' check region bounds for axis ', i
             CALL error_mesg('diag_util_mod::get_subfield_size', 'can not find gstart_indx/gend_indx for '&
                  & //TRIM(output_fields(outnum)%output_name)//','//TRIM(msg), FATAL)
          END IF
       END DO
    ELSE ! cubed sphere
       ! get the i and j start and end indexes
       CALL get_local_indexes(LONSTART=start(1), LONEND=END(1), &
            &                 LATSTART=start(2), LATEND=END(2), &
            &                 ISTART=gstart_indx(1), IEND=gend_indx(1), &
            &                 JSTART=gstart_indx(2), JEND=gend_indx(2))
       global_axis_size =  get_axis_global_length(axes(1))
       ALLOCATE(global_lon(global_axis_size))
       global_axis_size = get_axis_global_length(axes(2))
       ALLOCATE(global_lat(global_axis_size))
       CALL get_diag_axis_data(axes(1),global_lon)
       CALL get_diag_axis_data(axes(2),global_lat)
       IF (   (gstart_indx(1) > 0 .AND. gstart_indx(2) > 0) .AND. &
            & (gend_indx(1) > 0 .AND. gend_indx(2) > 0) ) THEN
          ALLOCATE(subaxis_x(gstart_indx(1):gend_indx(1)))
          ALLOCATE(subaxis_y(gstart_indx(2):gend_indx(2)))
          subaxis_x=global_lon(gstart_indx(1):gend_indx(1))
          subaxis_y=global_lat(gstart_indx(2):gend_indx(2))
       END IF

       ! Now deal with the Z component
       IF ( SIZE(axes(:)) > 2 ) THEN
          global_axis_size = get_axis_global_length(axes(3))
          output_fields(outnum)%output_grid%subaxes(3) = -1
          CALL get_diag_axis_cart(axes(3), cart)
          ! <ERROR STATUS="FATAL">
          !   axis(3) should be Z-axis
          ! </ERROR>
          IF ( lowercase(cart) /= 'z' ) CALL error_mesg('diag_util_mod::get_subfield_size', &
               &'axis(3) should be Z-axis', FATAL)
          ! <ERROR STATUS="FATAL">
          !   wrong values in vertical axis of region
          ! </ERROR>
          IF ( start(3)*END(3)<0 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
               & 'wrong values in vertical axis of region',FATAL)
          IF ( start(3)>=0 .AND. END(3)>0 ) THEN 
             ALLOCATE(global_depth(global_axis_size))
             CALL get_diag_axis_data(axes(3),global_depth)
             gstart_indx(3) = get_index(start(3),global_depth)
             IF( start(3) == 0.0 )  gstart_indx(3) = 1
             gend_indx(3) = get_index(END(3),global_depth)
             IF( start(3) >= MAXVAL(global_depth) ) gstart_indx(3)= global_axis_size
             IF( END(3)   >= MAXVAL(global_depth) ) gend_indx(3)  = global_axis_size
             
             ALLOCATE(subaxis_z(gstart_indx(3):gend_indx(3)))
             subaxis_z=global_depth(gstart_indx(3):gend_indx(3))
             output_fields(outnum)%output_grid%subaxes(3) =&
                  & diag_subaxes_init(axes(3),subaxis_z, gstart_indx(3),gend_indx(3))
             DEALLOCATE(subaxis_z,global_depth)
          ELSE ! regional vertical axis is the same as global vertical axis
             gstart_indx(3) = 1
             gend_indx(3) = global_axis_size
             output_fields(outnum)%output_grid%subaxes(3) = axes(3)
          END IF
       END IF
    END IF
    
    ! get domain and compute_domain(xbegin,xend,ybegin,yend)
    xbegin=-1
    xend=-1
    ybegin=-1
    yend=-1

    Domain2 = get_domain2d(axes)
    IF ( Domain2 .NE. NULL_DOMAIN2D ) THEN
       CALL mpp_get_compute_domain(Domain2,xbegin,xend,ybegin,yend)
       CALL mpp_get_domain_components(Domain2, Domain1x, Domain1y)
    ELSE
       DO i = 1, MIN(SIZE(axes(:)),2)    
          Domain1 = get_domain1d(axes(i))
          IF ( Domain1 .NE. NULL_DOMAIN1D ) THEN
             CALL get_diag_axis_cart(axes(i),cart)
             SELECT CASE(cart)
             CASE ('X')
                Domain1x = get_domain1d(axes(i))
                CALL mpp_get_compute_domain(Domain1x,xbegin,xend)   
             CASE ('Y')
                Domain1y = get_domain1d(axes(i))
                CALL mpp_get_compute_domain(Domain1y,ybegin,yend)
             CASE default ! do nothing here
             END SELECT
          ELSE
             ! <ERROR STATUS="FATAL">No domain available</ERROR>
             CALL error_mesg('diag_util_mod::get_subfield_size', 'NO domain available', FATAL)
          END IF
       END DO
    END IF

    CALL get_axes_shift(axes, ishift, jshift)
    xend = xend+ishift
    yend = yend+jshift

    IF ( xbegin== -1 .OR. xend==-1 .OR. ybegin==-1 .OR. yend==-1 ) THEN
       ! <ERROR STATUS="FATAL">wrong compute domain indices</ERROR>
       CALL error_mesg('diag_util_mod::get_subfield_size', 'wrong compute domain indices',FATAL)  
    END IF
      
    ! get the area containing BOTH compute domain AND local output area
    IF(gstart_indx(1)> xend .OR. xbegin > gend_indx(1)) THEN
       output_fields(outnum)%output_grid%l_start_indx(1) = -1
       output_fields(outnum)%output_grid%l_end_indx(1) = -1
       output_fields(outnum)%need_compute = .FALSE. ! not involved
    ELSEIF (gstart_indx(2)> yend .OR. ybegin > gend_indx(2)) THEN
       output_fields(outnum)%output_grid%l_start_indx(2) = -1
       output_fields(outnum)%output_grid%l_end_indx(2) = -1
       output_fields(outnum)%need_compute = .FALSE. ! not involved
    ELSE
       output_fields(outnum)%output_grid%l_start_indx(1) = MAX(xbegin, gstart_indx(1))
       output_fields(outnum)%output_grid%l_start_indx(2) = MAX(ybegin, gstart_indx(2))
       output_fields(outnum)%output_grid%l_end_indx(1) = MIN(xend, gend_indx(1))
       output_fields(outnum)%output_grid%l_end_indx(2) = MIN(yend, gend_indx(2))
       output_fields(outnum)%need_compute = .TRUE.  ! involved in local output
    END IF

    IF ( output_fields(outnum)%need_compute ) THEN
       ! need to modify domain1d and domain2d for subaxes
       xbegin_l = output_fields(outnum)%output_grid%l_start_indx(1)
       xend_l = output_fields(outnum)%output_grid%l_end_indx(1)
       ybegin_l = output_fields(outnum)%output_grid%l_start_indx(2)
       yend_l = output_fields(outnum)%output_grid%l_end_indx(2)
       CALL mpp_modify_domain(Domain2, Domain2_new, xbegin_l,xend_l, ybegin_l,yend_l,&
            & gstart_indx(1),gend_indx(1), gstart_indx(2),gend_indx(2))
       CALL mpp_get_domain_components(Domain2_new, Domain1x_new, Domain1y_new)

       output_fields(outnum)%output_grid%subaxes(1) =&
            & diag_subaxes_init(axes(1),subaxis_x, gstart_indx(1),gend_indx(1),Domain2_new)
       output_fields(outnum)%output_grid%subaxes(2) =&
            & diag_subaxes_init(axes(2),subaxis_y, gstart_indx(2),gend_indx(2),Domain2_new)
       DO i = 1, SIZE(axes(:))
          IF(output_fields(outnum)%output_grid%subaxes(i) == -1) THEN  
             ! <ERROR STATUS="FATAL">
             !   <output_fields(outnum)%output_name> error at i = <i>
             ! </ERROR>
             WRITE(msg,'(a,"/",I4)') 'at i = ',i
             CALL error_mesg('diag_util_mod::get_subfield_size '//TRIM(output_fields(outnum)%output_name),&
                  'error '//TRIM(msg), FATAL)   
          END IF
       END DO

       ! local start index should start from 1
       output_fields(outnum)%output_grid%l_start_indx(1) = MAX(xbegin, gstart_indx(1)) - xbegin + 1   
       output_fields(outnum)%output_grid%l_start_indx(2) = MAX(ybegin, gstart_indx(2)) - ybegin + 1
       output_fields(outnum)%output_grid%l_end_indx(1) = MIN(xend, gend_indx(1)) - xbegin + 1 
       output_fields(outnum)%output_grid%l_end_indx(2) = MIN(yend, gend_indx(2)) - ybegin + 1
       IF ( SIZE(axes(:))>2 ) THEN
          output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
          output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
       ELSE
          output_fields(outnum)%output_grid%l_start_indx(3) = 1
          output_fields(outnum)%output_grid%l_end_indx(3) = 1
       END IF
    END IF
    IF ( ALLOCATED(subaxis_x) ) DEALLOCATE(subaxis_x, global_lon)
    IF ( ALLOCATED(subaxis_y) ) DEALLOCATE(subaxis_y, global_lat)

  END SUBROUTINE get_subfield_size
  ! </SUBROUTINE>
  
  ! <SUBROUTINE NAME="get_subfield_vert_size">
  !   <OVERVIEW>
  !     Get size, start and end indices for output fields.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE get_subfield_vert_size(axes, outnum)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Get size, start and end indices for <TT>output_fields(outnum)</TT>, fill in
  !     <TT>output_fields(outnum)%output_grid%(start_indx, end_indx)</TT>.
  !   </DESCRIPTION>
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)">Axes of the <TT>input_field</TT></IN>
  !   <IN NAME="outnum" TYPE="INTEGER">Position in array <TT>output_fields</TT>.</IN>
  SUBROUTINE get_subfield_vert_size(axes, outnum)
    INTEGER, DIMENSION(:), INTENT(in) :: axes ! axes of the input_field
    INTEGER, INTENT(in) :: outnum  ! position in array output_fields

    REAL, DIMENSION(3) :: start, end ! start and end coordinates in 3 axes
    REAL, ALLOCATABLE, DIMENSION(:) :: global_depth
    REAL, ALLOCATABLE, DIMENSION(:) :: subaxis_z !containing local coordinates in x,y,z axes
    INTEGER :: i, global_axis_size
    INTEGER, DIMENSION(3) :: gstart_indx, gend_indx ! global start and end indices of output domain in 3 axes 
    CHARACTER(len=1) :: cart
    CHARACTER(len=128) :: msg

    !initilization for local output
    start = -1.e10
    end = -1.e10 ! initially out of (lat/lon/depth) range
    gstart_indx = -1 
    gend_indx=-1

    ! get axis data (lat, lon, depth) and indices
    start= output_fields(outnum)%output_grid%start
    end = output_fields(outnum)%output_grid%end

    DO i = 1, SIZE(axes(:))   
       global_axis_size = get_axis_global_length(axes(i))
       output_fields(outnum)%output_grid%subaxes(i) = -1
       CALL get_diag_axis_cart(axes(i), cart)
       SELECT CASE(cart)
       CASE ('X')
          ! <ERROR STATUS="FATAL">wrong order of axes, X should come first</ERROR>
          IF ( i.NE.1 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
               & 'wrong order of axes, X should come first',FATAL)
          gstart_indx(i) = 1
          gend_indx(i) = global_axis_size
          output_fields(outnum)%output_grid%subaxes(i) = axes(i)
       CASE ('Y')
          ! <ERROR STATUS="FATAL">wrong order of axes, Y should come second</ERROR>
          IF( i.NE.2 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
               & 'wrong order of axes, Y should come second',FATAL)
          gstart_indx(i) = 1
          gend_indx(i) = global_axis_size
          output_fields(outnum)%output_grid%subaxes(i) = axes(i)
       CASE ('Z')
          ! <ERROR STATUS="FATAL">wrong values in vertical axis of region</ERROR>
          IF( start(i)*END(i) < 0 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
               & 'wrong values in vertical axis of region',FATAL)
          IF( start(i) >= 0 .AND. END(i) > 0 ) THEN 
             ALLOCATE(global_depth(global_axis_size))
             CALL get_diag_axis_data(axes(i),global_depth)
             gstart_indx(i) = get_index(start(i),global_depth)
             IF( start(i) == 0.0 )  gstart_indx(i) = 1

             gend_indx(i) = get_index(END(i),global_depth)
             IF( start(i) >= MAXVAL(global_depth) ) gstart_indx(i)= global_axis_size
             IF( END(i)   >= MAXVAL(global_depth) ) gend_indx(i)  = global_axis_size

             ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
             subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
             output_fields(outnum)%output_grid%subaxes(i) =&
                  & diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
             DEALLOCATE(subaxis_z,global_depth)
          ELSE !   vertical axis is the same as global vertical axis
             gstart_indx(i) = 1
             gend_indx(i) = global_axis_size
             output_fields(outnum)%output_grid%subaxes(i) = axes(i)
             ! <ERROR STATUS="FATAL">i should equal 3 for z axis</ERROR>
             IF( i /= 3 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
                  & 'i should equal 3 for z axis', FATAL)
          END IF
       CASE default
          ! <ERROR STATUS="FATAL">Wrong axis_cart</ERROR>
          CALL error_mesg('diag_util_mod::get_subfield_vert_size', 'Wrong axis_cart', FATAL)
       END SELECT
    END DO

    DO i = 1,SIZE(axes(:))
       IF ( gstart_indx(i)== -1 .OR. gend_indx(i)== -1 ) THEN
          ! <ERROR STATUS="FATAL">
          !   can not find gstart_indx/gend_indx for <output_fields(outnum)%output_name>
          !   check region bounds for axis
          ! </ERROR>
          WRITE(msg,'(A,I2)') ' check region bounds for axis ', i
          CALL error_mesg('diag_util_mod::get_subfield_vert_size', 'can not find gstart_indx/gend_indx for '&
               & //TRIM(output_fields(outnum)%output_name)//','//TRIM(msg), FATAL)
       END IF
    END DO

    DO i= 1, 2
       output_fields(outnum)%output_grid%l_start_indx(i) = gstart_indx(i)
       output_fields(outnum)%output_grid%l_end_indx(i)   = gend_indx(i)
    END DO

    IF( SIZE(axes(:)) > 2 ) THEN
       output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
       output_fields(outnum)%output_grid%l_end_indx(3)   = gend_indx(3)
    ELSE
       output_fields(outnum)%output_grid%l_start_indx(3) = 1
       output_fields(outnum)%output_grid%l_end_indx(3)   = 1
    END IF
  END SUBROUTINE get_subfield_vert_size
  ! </SUBROUTINE>
  
  ! <PRIVATE>
  ! <FUNCTION NAME="get_index">
  !   <OVERVIEW>
  !     Find index <TT>i</TT> of array such that <TT>array(i)</TT> is closest to number.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION get_index(number, array)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Find index <TT>i</TT> of array such that <TT>array(i)</TT> is closest to number.
  !     Array must be  monotonouslly ordered.
  !   </DESCRIPTION>
  !   <IN NAME="number" TYPE="REAL"></IN>
  !   <IN NAME="array" TYPE="REAL, DIMENSION(:)"></IN>
  INTEGER FUNCTION get_index(number, array)
    REAL, INTENT(in) :: number
    REAL, INTENT(in), DIMENSION(:) :: array

    INTEGER :: i, n
    LOGICAL :: found

    n = SIZE(array(:))
    ! check if array is monotonous
    DO i = 2, n-1
       IF( (array(i-1)<array(i).AND.array(i)>array(i+1)) .OR. (array(i-1)>array(i).AND.array(i)<array(i+1))) THEN
          ! <ERROR STATUS="FATAL">array NOT monotonously ordered</ERROR>
          CALL error_mesg('diag_util_mod::get_index', 'array NOT monotonously ordered',FATAL) 
       END IF
    END DO
    get_index = -1
    found = .FALSE.
    ! search in increasing array 
    DO i = 1, n-1                
       IF ( (array(i)<=number).AND.(array(i+1)>= number) ) THEN
          IF( number - array(i) <= array(i+1) - number ) THEN
             get_index = i
             found=.TRUE.
          ELSE
             get_index = i+1
             found=.TRUE.
          ENDIF
          EXIT
       END IF
    END DO
    ! if not found, search in decreasing array
    IF( .NOT.found ) THEN
       DO i = 1, n-1
          IF ( (array(i)>=number).AND.(array(i+1)<= number) ) THEN
             IF ( array(i)-number <= number-array(i+1) ) THEN
                get_index = i 
                found = .TRUE.
             ELSE
                get_index = i+1
                found = .TRUE.
             END IF
             EXIT
          END IF
       END DO
    END IF
    ! if still not found, is it less than the first element
    ! or greater than last element? (Increasing Array)
    IF ( .NOT. found ) THEN
       IF ( array(1).GT.number ) THEN
          get_index = 1
          found = .TRUE.
       ELSE IF ( array(n).LT.number ) THEN
          get_index = n
          found = .TRUE.
       ELSE
          found = .FALSE.
       END IF
    END IF
   
   ! if still not found, is it greater than the first element
   ! or less than the last element? (Decreasing Array)
    IF ( .NOT. found ) THEN
       IF ( array(1).LT.number ) THEN
          get_index = 1
          found = .TRUE.
       ELSE IF ( array(n).GT.number ) THEN
          get_index = n
          found = .TRUE.
       ELSE
          found = .FALSE.
       END IF
    END IF
  END FUNCTION get_index
  ! </FUNCTION>
  ! </PRIVATE>

  ! <SUBROUTINE NAME="log_diag_field_info">
  !   <OVERVIEW>
  !     Writes brief diagnostic field info to the log file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,
  !     missing_value, range, dynamic)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     If the <TT>do_diag_field_log</TT> namelist parameter is .TRUE.,
  !     then a line briefly describing diagnostic field is added to
  !     the log file.  Normally users should not call this subroutine
  !     directly, since it is called by register_static_field and
  !     register_diag_field if do_not_log is not set to .TRUE..  It is
  !     used, however, in LM3 to avoid excessive logs due to the
  !     number of fields registered for each of the tile types.  LM3
  !     code uses a do_not_log parameter in the registration calls,
  !     and subsequently calls this subroutine to log field information
  !     under a generic name.
  !   </DESCRIPTION>
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)">Module name.</IN>
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)">Field name.</IN>
  !   <IN NAME="axes" TYPE="INTEGER, DIMENSION(:)">Axis IDs.</IN>
  !   <IN NAME="long_name" TYPE="CHARACTER(len=*), OPTIONAL">Long name for field.</IN>
  !   <IN NAME="units" TYPE="CHARACTER(len=*), OPTIONAL">Unit of field.</IN>
  !   <IN NAME="missing_value" TYPE="REAL, OPTIONAL">Missing value value.</IN>
  !   <IN NAME="range" TYPE="REAL, DIMENSION(2), OPTIONAL">Valid range of values for field.</IN>
  !   <IN NAME="dynamic" TYPE="LOGICAL, OPTIONAL"><TT>.TRUE.</TT> if field is not static.</IN>
  SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
       & missing_value, range, dynamic)
    CHARACTER(len=*), INTENT(in) :: module_name, field_name
    INTEGER, DIMENSION(:), INTENT(in) :: axes
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units
    REAL, OPTIONAL, INTENT(in) :: missing_value
    REAL, DIMENSION(2), OPTIONAL, INTENT(IN) :: range
    LOGICAL, OPTIONAL, INTENT(in) :: dynamic

    ! ---- local vars
    CHARACTER(len=256) :: lmodule, lfield, lname, lunits
    CHARACTER(len=64)  :: lmissval, lmin, lmax
    CHARACTER(len=8)   :: numaxis, timeaxis
    CHARACTER(len=1)   :: sep = '|'
    CHARACTER(len=256) :: axis_name, axes_list
    INTEGER :: i

    IF ( .NOT.do_diag_field_log ) RETURN
    IF ( mpp_pe().NE.mpp_root_pe() ) RETURN

    lmodule = TRIM(module_name)
    lfield = TRIM(field_name)

    IF ( PRESENT(long_name) ) THEN
       lname  = TRIM(long_name)
    ELSE 
       lname  = ''
    END IF
    
    IF ( PRESENT(units) ) THEN
       lunits = TRIM(units)
    ELSE
       lunits = ''
    END IF
 
    WRITE (numaxis,'(i1)') SIZE(axes)

    IF (PRESENT(missing_value)) THEN
       IF ( use_cmor ) THEN
          WRITE (lmissval,*) CMOR_MISSING_VALUE
       ELSE
          WRITE (lmissval,*) missing_value
       END IF
    ELSE
       lmissval = ''
    ENDIF

    IF ( PRESENT(range) ) THEN
       WRITE (lmin,*) range(1)
       WRITE (lmax,*) range(2)
    ELSE
       lmin = ''
       lmax = ''
    END IF

    IF ( PRESENT(dynamic) ) THEN
       IF (dynamic) THEN
          timeaxis = 'T'
       ELSE
          timeaxis = 'F'
       END IF
    ELSE
       timeaxis = ''
    END IF

    axes_list=''
    DO i = 1, SIZE(axes)
       CALL get_diag_axis_name(axes(i),axis_name)
       IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//','
       axes_list = TRIM(axes_list)//TRIM(axis_name)
    END DO

    !write (diag_log_unit,'(8(a,a),a)') &
    WRITE (diag_log_unit,'(777a)') &
         & TRIM(lmodule),  sep, TRIM(lfield),  sep, TRIM(lname),    sep,&
         & TRIM(lunits),   sep, TRIM(numaxis), sep, TRIM(timeaxis), sep,&
         & TRIM(lmissval), sep, TRIM(lmin),    sep, TRIM(lmax),     sep,&
         & TRIM(axes_list)
  END SUBROUTINE log_diag_field_info
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="update_bounds">
  !   <OVERVIEW>
  !     Update the <TT>output_fields</TT> min and max boundaries.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Update the <TT>output_fields</TT> x, y, and z min and max boundaries (array indices).
  !   </DESCRIPTION>
  !   <IN NAME="out_num" TYPE="INTEGER"><TT>output_field</TT> ID.</IN>
  !   <IN NAME="lower_i" TYPE="INTEGER">Lower <TT>i</TT> bound.</IN>
  !   <IN NAME="upper_i" TYPE="INTEGER">Upper <TT>i</TT> bound.</IN>
  !   <IN NAME="lower_j" TYPE="INTEGER">Lower <TT>j</TT> bound.</IN>
  !   <IN NAME="upper_j" TYPE="INTEGER">Upper <TT>j</TT> bound.</IN>
  !   <IN NAME="lower_k" TYPE="INTEGER">Lower <TT>k</TT> bound.</IN>
  !   <IN NAME="upper_k" TYPE="INTEGER">Upper <TT>k</TT> bound.</IN>
  SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
    INTEGER, INTENT(in) :: out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k
    
    output_fields(out_num)%imin = MIN(output_fields(out_num)%imin, lower_i)
    output_fields(out_num)%imax = MAX(output_fields(out_num)%imax, upper_i)
    output_fields(out_num)%jmin = MIN(output_fields(out_num)%jmin, lower_j)
    output_fields(out_num)%jmax = MAX(output_fields(out_num)%jmax, upper_j)
    output_fields(out_num)%kmin = MIN(output_fields(out_num)%kmin, lower_k)
    output_fields(out_num)%kmax = MAX(output_fields(out_num)%kmax, upper_k)
  END SUBROUTINE update_bounds
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="check_out_of_bounds">
  !   <OVERVIEW>
  !     Checks if the array indices for <TT>output_fields(out_num)</TT> are outside the <TT>output_fields(out_num)%buffer</TT> upper
  !     and lower bounds.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>check_out_of_bounds</TT> verifies the array min and max indices in the x, y, and z directions of <TT>
  !     output_fields(out_num)</TT> are not outside the upper and lower array boundaries of
  !     <TT>output_fields(out_num)%buffer</TT>.  If the min and max indices are outside the upper and lower bounds of the buffer
  !     array, then <TT>check_out_of_bounds</TT> returns an error string.
  !   </DESCRIPTION>
  !   <IN NAME="out_num" TYPE="INTEGER">
  !     Output field ID number.
  !   </IN>
  !   <IN NAME="diag_field_id" TYPE="INTEGER">
  !     Input field ID number.
  !   </IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*)">
  !     Return status of <TT>check_out_of_bounds</TT>.  An empty error string indicates the x, y, and z indices are not outside the
  !     buffer array boundaries.
  !   </OUT>
  SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg)
    INTEGER, INTENT(in) :: out_num, diag_field_id
    CHARACTER(len=*), INTENT(out) :: err_msg

    CHARACTER(len=128) :: error_string1, error_string2

    IF (   output_fields(out_num)%imin < LBOUND(output_fields(out_num)%buffer,1) .OR.&
         & output_fields(out_num)%imax > UBOUND(output_fields(out_num)%buffer,1) .OR.&
         & output_fields(out_num)%jmin < LBOUND(output_fields(out_num)%buffer,2) .OR.&
         & output_fields(out_num)%jmax > UBOUND(output_fields(out_num)%buffer,2) .OR.&
         & output_fields(out_num)%kmin < LBOUND(output_fields(out_num)%buffer,3) .OR.&
         & output_fields(out_num)%kmax > UBOUND(output_fields(out_num)%buffer,3) ) THEN
       WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),&
            & TRIM(output_fields(out_num)%output_name)
       error_string2 ='Buffer bounds=   :   ,   :   ,   :     Actual bounds=   :   ,   :   ,   :   '
       WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1)
       WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1)
       WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2)
       WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2)
       WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3)
       WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3)
       WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin
       WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax
       WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin
       WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax
       WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin
       WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax
       err_msg = 'module/output_field='//TRIM(error_string1)//&
            & '  Bounds of buffer exceeded.  '//TRIM(error_string2)
       !   imax, imin, etc need to be reset in case the program is not terminated.
       output_fields(out_num)%imax = 0
       output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
       output_fields(out_num)%jmax = 0
       output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
       output_fields(out_num)%kmax = 0
       output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
    ELSE
       err_msg = ''
    END IF

  END SUBROUTINE check_out_of_bounds
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="check_bounds_are_exact_dynamic">
  !   <OVERVIEW>
  !     Check if the array indices for <TT>output_fields(out_num)</TT> are equal to the <TT>output_fields(out_num)%buffer</TT>
  !     upper and lower bounds.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>check_bounds_are_exact_dynamic</TT> checks if the min and max array indices for <TT>output_fields(out_num)</TT> are
  !     equal to the upper and lower bounds of <TT>output_fields(out_num)%buffer</TT>.  This check is only performed if
  !     <TT>output_fields(out_num)%Time_of_prev_field_data</TT> doesn't equal <TT>Time</TT> or <TT>Time_zero</TT>.
  !     <TT>check_bounds_are_exact_dynamic</TT> returns an error string if the array indices do not match the buffer bounds.
  !   </DESCRIPTION>
  !   <IN NAME="out_num" TYPE="INTEGER">
  !     Output field ID number.
  !   </IN>
  !   <IN NAME="diag_field_id" TYPE="INTEGER">
  !     Input field ID number.
  !   </IN>
  !   <IN NAME="Time" TYPE="TYPE(time_type)">
  !     Time to use in check.  The check is only performed if <TT>output_fields(out_num)%Time_of_prev_field_data</TT> is not
  !     equal to <TT>Time</TT> or <TT>Time_zero</TT>.
  !   </IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*)">
  !     Return status of <TT>check_bounds_are_exact_dynamic</TT>.  An empty error string indicates the x, y, and z indices are
  !     equal to the buffer array boundaries.
  !   </OUT>
  SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
    INTEGER, INTENT(in) :: out_num, diag_field_id
    TYPE(time_type), INTENT(in) :: Time
    CHARACTER(len=*), INTENT(out) :: err_msg

    CHARACTER(len=128) :: error_string1, error_string2
    LOGICAL :: do_check

    err_msg = ''

    ! Check bounds only when the value of Time changes. When windows are used,
    ! a change in Time indicates that a new loop through the windows has begun,
    !  so a check of the previous loop can be done.
    IF ( Time == output_fields(out_num)%Time_of_prev_field_data ) THEN
       do_check = .FALSE.
    ELSE
       IF ( output_fields(out_num)%Time_of_prev_field_data == Time_zero ) THEN
          ! It may or may not be OK to check, I don't know how to tell.
          ! Check will be done on subsequent calls anyway.
          do_check = .FALSE.
       ELSE
          do_check = .TRUE.
       END IF
       output_fields(out_num)%Time_of_prev_field_data = Time
    END IF

    IF ( do_check ) THEN
       IF (   output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.&
            & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.&
            & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.&
            & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.&
            & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.&
            & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN
          WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),&
               & TRIM(output_fields(out_num)%output_name)
          error_string2 ='Buffer bounds=   :   ,   :   ,   :     Actual bounds=   :   ,   :   ,   :   '
          WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1)
          WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1)
          WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2)
          WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2)
          WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3)
          WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3)
          WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin
          WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax
          WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin
          WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax
          WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin
          WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax
          err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2)
       END IF
       output_fields(out_num)%imax = 0
       output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
       output_fields(out_num)%jmax = 0
       output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
       output_fields(out_num)%kmax = 0
       output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
    END IF
  END SUBROUTINE check_bounds_are_exact_dynamic
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="check_bounds_are_exact_static">
  !   <OVERVIEW>
  !     Check if the array indices for <TT>output_fields(out_num)</TT> are equal to the <TT>output_fields(out_num)%buffer</TT>
  !     upper and lower bounds.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !   </DESCRIPTION>
  !   <IN NAME="out_num" TYPE="INTEGER">Output field ID</IN>
  !   <IN NAME="diag_field_id" TYPE="INTEGER">Input field ID.</IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*)"></OUT>
  SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
    INTEGER, INTENT(in) :: out_num, diag_field_id
    CHARACTER(len=*), INTENT(out) :: err_msg

    CHARACTER(len=128)  :: error_string1, error_string2

    err_msg = ''

    IF (   output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.&
         & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.&
         & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.&
         & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.&
         & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.&
         & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN
       WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),&
            & TRIM(output_fields(out_num)%output_name)
       error_string2 ='Buffer bounds=   :   ,   :   ,   :     Actual bounds=   :   ,   :   ,   :   '
       WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1)
       WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1)
       WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2)
       WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2)
       WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3)
       WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3)
       WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin
       WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax
       WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin
       WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax
       WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin
       WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax
       err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2)
    END IF
    output_fields(out_num)%imax = 0
    output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
    output_fields(out_num)%jmax = 0
    output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
    output_fields(out_num)%kmax = 0
    output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
    
  END SUBROUTINE check_bounds_are_exact_static
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="init_file">
  !   <OVERVIEW>
  !     Initialize the output file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE init_file(name, output_freq, output_units, format, time_units
  !     long_name, tile_count, new_file_freq, new_file_freq_units, start_time,
  !     file_duration, file_duration_units)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Initialize the output file.
  !   </DESCRIPTION>
  !   <IN NAME="name" TYPE="CHARACTER(len=*)">File name.</IN>
  !   <IN NAME="output_freq" TYPE="INTEGER">How often data is to be written to the file.</IN>
  !   <IN NAME="output_units" TYPE="INTEGER">The output frequency unit.  (MIN, HOURS, DAYS, etc.)</IN>
  !   <IN NAME="format" TYPE="INTEGER">Number type/kind the data is to be written out to the file.</IN>
  !   <IN NAME="time_units" TYPE="INTEGER">Time axis units.</IN>
  !   <IN NAME="log_name" TYPE="CHARACTER(len=*)">Long name for time axis.</IN>
  !   <IN NAME="tile_count" TYPE="INTEGER">Tile number.</IN>
  !   <IN NAME="new_file_freq" TYPE="INTEGER, OPTIONAL">How often a new file is to be created.</IN>
  !   <IN NAME="new_file_freq_units" TYPE="INTEGER, OPTIONAL">The new file frequency unit.  (MIN, HOURS, DAYS, etc.)</IN>
  !   <IN NAME="start_time" TYPE="TYPE(time_type), OPTIONAL">Time when the file is to start </IN>
  !   <IN NAME="file_duration" TYPE="INTEGER, OPTIONAL">How long file is to be used.</IN>
  !   <IN NAME="file_duration_units" TYPE="INTEGER, OPTIONAL">File duration unit.  (MIN, HOURS, DAYS, etc.)</IN>
  SUBROUTINE init_file(name, output_freq, output_units, FORMAT, time_units, long_name, tile_count,&
       & new_file_freq, new_file_freq_units, start_time, file_duration, file_duration_units)
    CHARACTER(len=*), INTENT(in) :: name, long_name
    INTEGER, INTENT(in) :: output_freq, output_units, FORMAT, time_units
    INTEGER, INTENT(in) :: tile_count
    INTEGER, INTENT(in), OPTIONAL :: new_file_freq, new_file_freq_units
    INTEGER, INTENT(in), OPTIONAL :: file_duration, file_duration_units
    TYPE(time_type), INTENT(in), OPTIONAL :: start_time

    INTEGER :: new_file_freq1, new_file_freq_units1
    INTEGER :: file_duration1, file_duration_units1
    REAL, DIMENSION(1) :: tdata
    CHARACTER(len=128) :: time_units_str

    ! Get a number for this file
    num_files = num_files + 1
    IF ( num_files >= max_files ) THEN
       ! <ERROR STATUS="FATAL">
       !   max_files exceeded, increase max_files via the max_files variable
       !   in the namelist diag_manager_nml.
       ! </ERROR>
       CALL error_mesg('diag_util_mod::init_file',&
            & ' max_files exceeded, increase max_files via the max_files variable&
            & in the namelist diag_manager_nml.', FATAL)
    END IF

    IF ( PRESENT(new_file_freq) ) THEN 
       new_file_freq1 = new_file_freq
    ELSE 
       new_file_freq1 = VERY_LARGE_FILE_FREQ
    END IF
    
    IF ( PRESENT(new_file_freq_units) ) THEN 
       new_file_freq_units1 = new_file_freq_units 
    ELSE IF ( get_calendar_type() == NO_CALENDAR ) THEN
       new_file_freq_units1 = DIAG_DAYS
    ELSE 
       new_file_freq_units1 = DIAG_YEARS
    END IF
    
    IF ( PRESENT(file_duration) ) THEN
       file_duration1 = file_duration 
    ELSE
       file_duration1 = new_file_freq1
    END IF
    
    IF ( PRESENT(file_duration_units) ) THEN 
       file_duration_units1 = file_duration_units
    ELSE 
       file_duration_units1 = new_file_freq_units1
    END IF
    
    files(num_files)%tile_count = tile_count
    files(num_files)%name = TRIM(name)
    files(num_files)%output_freq = output_freq
    files(num_files)%output_units = output_units
    files(num_files)%format = FORMAT
    files(num_files)%time_units = time_units
    files(num_files)%long_name = TRIM(long_name)
    files(num_files)%num_fields = 0
    files(num_files)%local = .FALSE.
    files(num_files)%last_flush = base_time
    files(num_files)%file_unit = -1
    files(num_files)%new_file_freq = new_file_freq1
    files(num_files)%new_file_freq_units = new_file_freq_units1
    files(num_files)%duration = file_duration1
    files(num_files)%duration_units = file_duration_units1
    IF ( PRESENT(start_time) ) THEN 
       files(num_files)%start_time = start_time
    ELSE
       files(num_files)%start_time = base_time
    END IF
    files(num_files)%next_open=diag_time_inc(files(num_files)%start_time,new_file_freq1,new_file_freq_units1)
    files(num_files)%close_time = diag_time_inc(files(num_files)%start_time,file_duration1, file_duration_units1)
    IF ( files(num_files)%close_time>files(num_files)%next_open ) THEN
       ! <ERROR STATUS="FATAL">
       !   close time GREATER than next_open time, check file duration,
       !   file frequency in <files(num_files)%name>
       ! </ERROR>
       CALL error_mesg('diag_util_mod::init_file', 'close time GREATER than next_open time, check file duration,&
            & file frequency in '//files(num_files)%name, FATAL)
    END IF
    
    ! add time_axis_id and time_bounds_id here
    WRITE(time_units_str, 11) TRIM(time_unit_list(files(num_files)%time_units)), base_year,&
         & base_month, base_day, base_hour, base_minute, base_second
11  FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
    files(num_files)%time_axis_id = diag_axis_init (TRIM(long_name), tdata, time_units_str, 'T',&
         & TRIM(long_name) , set_name=TRIM(name) )
    !---- register axis for storing time boundaries
    files(num_files)%time_bounds_id = diag_axis_init( 'nv',(/1.,2./),'none','N','vertex number',&
         & set_name=TRIM(name))
  END SUBROUTINE init_file
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="sync_file_times">
  !   <OVERVIEW>
  !     Synchronize the file's start and close times with the model start and end times.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE sync_file_times(init_time)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     <TT>sync_file_times</TT> checks to see if the file start time is less than the
  !     model's init time (passed in as the only argument).  If it is less, then the
  !     both the file start time and end time are synchronized using the passed in initial time
  !     and the duration as calculated by the <TT>diag_time_inc</TT> function.  <TT>sync_file_times</TT>
  !     will also increase the <TT>next_open</TT> until it is greater than the init_time.
  !   </DESCRIPTION>
  !   <IN NAME="file_id" TYPE="INTEGER">The file ID</IN>
  !   <IN NAME="init_time" TYPE="TYPE(time_type)">Initial time use for the synchronization.</IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">Return error message</OUT>
  SUBROUTINE sync_file_times(file_id, init_time, err_msg)
    INTEGER, INTENT(in) :: file_id
    TYPE(time_type), INTENT(in) :: init_time
    CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg

    CHARACTER(len=128) :: msg

    IF ( PRESENT(err_msg) ) err_msg = ''

    IF ( files(file_id)%start_time < init_time ) THEN
       ! Sync the start_time of the file with the initial time of the model
       files(file_id)%start_time = init_time
       ! Sync the file's close time also
       files(file_id)%close_time = diag_time_inc(files(file_id)%start_time,&
            & files(file_id)%duration, files(file_id)%duration_units)
    END IF

    ! Need to increase next_open until it is greate than init_time
    DO WHILE ( files(file_id)%next_open <= init_time )
       files(file_id)%next_open = diag_time_inc(files(file_id)%next_open,&
            & files(file_id)%new_file_freq, files(file_id)%new_file_freq_units, err_msg=msg)
       IF ( msg /= '' ) THEN
          IF ( fms_error_handler('diag_util_mod::sync_file_times',&
               & ' file='//TRIM(files(file_id)%name)//': '//TRIM(msg), err_msg) ) RETURN
       END IF
    END DO
  END SUBROUTINE sync_file_times
  ! </SUBROUTINE>

  ! <FUNCTION NAME="diag_time_inc">
  !   <OVERVIEW>
  !     Return the next time data/file is to be written based on the frequency and units.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the next time data/file is to be written.  This value is based on the current time and the frequency and units.
  !     Function completed successful if the optional <TT>err_msg</TT> is empty.
  !   </DESCRIPTION>
  !   <IN NAME="time" TYPE="TYPE(time_type)">Current model time.</IN>
  !   <IN NAME="output_freq" TYPE="INTEGER">Output frequency number value.</IN>
  !   <IN NAME="output_units" TYPE="INTEGER">Output frequency unit.</IN>
  !   <OUT NAME="err_msg" TYPE="CHARACTER, OPTIONAL">
  !     Function error message.  An empty string indicates the next output time was found successfully.
  !   </OUT>
  TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg)
    TYPE(time_type), INTENT(in) :: time
    INTEGER, INTENT(in):: output_freq, output_units
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    CHARACTER(len=128) :: error_message_local

    IF ( PRESENT(err_msg) ) err_msg = ''
    error_message_local = ''

    ! special values for output frequency are -1 for output at end of run
    ! and 0 for every timestep.  Need to check for these here?
    ! Return zero time increment, hopefully this value is never used
    IF ( output_freq == END_OF_RUN .OR. output_freq == EVERY_TIME ) THEN
       diag_time_inc = time
       RETURN
    END IF

    ! Make sure calendar was not set after initialization
    IF ( output_units == DIAG_SECONDS ) THEN
       IF ( get_calendar_type() == NO_CALENDAR ) THEN
          diag_time_inc = increment_time(time, output_freq, 0, err_msg=error_message_local)
       ELSE
          diag_time_inc = increment_date(time, 0, 0, 0, 0, 0, output_freq, err_msg=error_message_local)
       END IF
    ELSE IF ( output_units == DIAG_MINUTES ) THEN
       IF ( get_calendar_type() == NO_CALENDAR ) THEN
          diag_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_MINUTE), 0, &
               &err_msg=error_message_local)
       ELSE
          diag_time_inc = increment_date(time, 0, 0, 0, 0, output_freq, 0, err_msg=error_message_local)
       END IF
    ELSE IF ( output_units == DIAG_HOURS ) THEN
       IF ( get_calendar_type() == NO_CALENDAR ) THEN
          diag_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_HOUR), 0, err_msg=error_message_local)
       ELSE
          diag_time_inc = increment_date(time, 0, 0, 0, output_freq, 0, 0, err_msg=error_message_local)
       END IF
    ELSE IF ( output_units == DIAG_DAYS ) THEN
       IF (get_calendar_type() == NO_CALENDAR) THEN
          diag_time_inc = increment_time(time, 0, output_freq, err_msg=error_message_local)
       ELSE
          diag_time_inc = increment_date(time, 0, 0, output_freq, 0, 0, 0, err_msg=error_message_local)
       END IF
    ELSE IF ( output_units == DIAG_MONTHS ) THEN
       IF (get_calendar_type() == NO_CALENDAR) THEN
          error_message_local = 'output units of months NOT allowed with no calendar'
       ELSE
          diag_time_inc = increment_date(time, 0, output_freq, 0, 0, 0, 0, err_msg=error_message_local)
       END IF
    ELSE IF ( output_units == DIAG_YEARS ) THEN
       IF ( get_calendar_type() == NO_CALENDAR ) THEN
          error_message_local = 'output units of years NOT allowed with no calendar'
       ELSE
          diag_time_inc = increment_date(time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local)
       END IF
    ELSE 
       error_message_local = 'illegal output units'
    END IF

    IF ( error_message_local /= '' ) THEN
       IF ( fms_error_handler('diag_time_inc',error_message_local,err_msg) ) RETURN
    END IF
  END FUNCTION diag_time_inc
  ! </FUNCTION>

  ! <PRIVATE>
  ! <FUNCTION NAME="find_file">
  !   <OVERVIEW>
  !     Return the file number for file name and tile.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION fild_file(name, time_count)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Find the file number for the file name and tile number given.  A return value of <TT>-1</TT> indicates the file was not found.
  !   </DESCRIPTION>
  !   <IN NAME="name=" TYPE="CHARACTER(len=*)">File name.</IN>
  !   <IN NAME="tile_count" TYPE="INTEGER">Tile number.</IN>
  INTEGER FUNCTION find_file(name, tile_count)
    INTEGER, INTENT(in) :: tile_count
    CHARACTER(len=*), INTENT(in) :: name

    INTEGER :: i

    find_file = -1
    DO i = 1, num_files
       IF( TRIM(files(i)%name) == TRIM(name) .AND. tile_count == files(i)%tile_count ) THEN
          find_file = i
          RETURN
       END IF
    END DO
  END FUNCTION find_file
  ! </FUNCTION>
  ! </PRIVATE>

  ! <FUNCTION NAME="find_input_field">
  !   <OVERVIEW>
  !     Return the field number for the given module name, field name, and tile number.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     INTEGER FUNCTION find_input_field(module_name, field_name, tile_count)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Return the field number for the given module name, field name and tile number.  A return value of <TT>-1</TT> indicates
  !     the field was not found.
  !   </DESCRIPTION>
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)">Module name.</IN>
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)">field name.</IN>
  !   <IN NAME="tile_count" TYPE="INTEGER">Tile number.</IN>
  INTEGER FUNCTION find_input_field(module_name, field_name, tile_count)
    CHARACTER(len=*), INTENT(in) :: module_name, field_name
    INTEGER, INTENT(in) :: tile_count

    INTEGER :: i

    find_input_field = -1 ! Default return value if not found.
    DO i = 1, num_input_fields
       IF(tile_count == input_fields(i)%tile_count .AND.&
            & TRIM(input_fields(i)%module_name) == TRIM(module_name) .AND.&
            & lowercase(TRIM(input_fields(i)%field_name)) == lowercase(TRIM(field_name))) THEN 
          find_input_field = i
          RETURN
       END IF
    END DO
  END FUNCTION find_input_field
  ! </FUNCTION>

  ! <SUBROUTINE NAME="init_input_field">
  !   <OVERVIEW>
  !     Initialize the input field.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE init_input_field(module_name, field_name, tile_count)
  !   </TEMPLATE>
  !     Initialize the input field.
  !   <DESCRIPTION>
  !   </DESCRIPTION>
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)">Module name.</IN>
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)">Input field name.</IN>
  !   <IN NAME="tile_count" TYPE="INTEGER">Tile number.</IN>
  SUBROUTINE init_input_field(module_name, field_name, tile_count)
    CHARACTER(len=*),  INTENT(in) :: module_name, field_name
    INTEGER, INTENT(in) :: tile_count

    ! Get a number for this input_field if not already set up
    IF ( find_input_field(module_name, field_name, tile_count) < 0 ) THEN
       num_input_fields = num_input_fields + 1
       IF ( num_input_fields > max_input_fields ) THEN
          ! <ERROR STATUS="FATAL">max_input_fields exceeded, increase it via diag_manager_nml</ERROR>
          CALL error_mesg('diag_util_mod::init_input_field',&
               & 'max_input_fields exceeded, increase it via diag_manager_nml', FATAL)
       END IF
    ELSE
       ! If this is already initialized do not need to do anything
       RETURN
    END IF

    input_fields(num_input_fields)%module_name = TRIM(module_name)
    input_fields(num_input_fields)%field_name = TRIM(field_name)
    input_fields(num_input_fields)%num_output_fields = 0
    ! Set flag that this field has not been registered
    input_fields(num_input_fields)%register = .FALSE.
    input_fields(num_input_fields)%local = .FALSE.
    input_fields(num_input_fields)%standard_name = 'none'
    input_fields(num_input_fields)%tile_count = tile_count
    input_fields(num_input_fields)%numthreads = 1
    input_fields(num_input_fields)%time = time_zero
  END SUBROUTINE init_input_field
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="init_output_field">
  !   <OVERVIEW>
  !     Initialize the output field.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE init_output_field(module_name, field_name, output_name, output_file
  !     time_method, pack, tile_count, local_coord)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Initialize the output field.
  !   </DESCRIPTION>
  !   <IN NAME="module_name" TYPE="CHARACTER(len=*)">Module name.</IN>
  !   <IN NAME="field_name" TYPE="CHARACTER(len=*)">Output field name.</IN>
  !   <IN NAME="output_name" TYPE="CHARACTER(len=*)">Output name written to file.</IN>
  !   <IN NAME="output_file" TYPE="CHARACTER(len=*)">File where field should be written.</IN>
  !   <IN NAME="time_method" TYPE="CHARACTER(len=*)">
  !     Data reduction method.  See <LINK SRC="diag_manager.html">diag_manager_mod</LINK> for valid methods.</IN>
  !   <IN NAME="pack" TYPE="INTEGER">Packing method.</IN>
  !   <IN NAME="tile_count" TYPE="INTEGER">Tile number.</IN>
  !   <IN NAME="local_coord" TYPE="INTEGER, OPTIONAL">Region to be written.  If missing, then all data to be written.</IN>
  SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,&
       & time_method, pack, tile_count, local_coord)
    CHARACTER(len=*), INTENT(in) :: module_name, field_name, output_name, output_file
    CHARACTER(len=*), INTENT(in) :: time_method
    INTEGER, INTENT(in) :: pack
    INTEGER, INTENT(in) :: tile_count
    TYPE(coord_type), INTENT(in), OPTIONAL :: local_coord
    INTEGER :: out_num, in_num, file_num, file_num_tile1
    INTEGER :: num_fields, i, method_selected, l1
    INTEGER :: ioerror
    CHARACTER(len=128) :: error_msg
    CHARACTER(len=50) :: t_method

    ! Get a number for this output field
    num_output_fields = num_output_fields + 1
    IF ( num_output_fields > max_output_fields ) THEN
       ! <ERROR STATUS="FATAL">max_output_fields = <max_output_fields> exceeded.  Increase via diag_manager_nml</ERROR>
       WRITE (UNIT=error_msg,FMT=*) max_output_fields
       CALL error_mesg('diag_util_mod::init_output_field', 'max_output_fields = '//TRIM(error_msg)//' exceeded.&
            &  Increase via diag_manager_nml', FATAL)
    END IF
    out_num = num_output_fields

    ! First, find the index to the associated input field
    in_num = find_input_field(module_name, field_name, tile_count)
    IF ( in_num < 0 ) THEN
       IF ( tile_count > 1 ) THEN
          WRITE (error_msg,'(A,"/",A,"/",A)') TRIM(module_name),TRIM(field_name),&
               & "tile_count="//TRIM(string(tile_count))
       ELSE
          WRITE (error_msg,'(A,"/",A)') TRIM(module_name),TRIM(field_name)
       END IF
       ! <ERROR STATUS="FATAL">module_name/field_name <module_name>/<field_name>[/tile_count=<tile_count>] NOT registered</ERROR>
       CALL error_mesg('diag_util_mod::init_output_field',&
            & 'module_name/field_name '//TRIM(error_msg)//' NOT registered', FATAL)
    END IF

    ! Add this output field into the list for this input field
    input_fields(in_num)%num_output_fields =&
         & input_fields(in_num)%num_output_fields + 1
    IF ( input_fields(in_num)%num_output_fields > max_out_per_in_field ) THEN
       ! <ERROR STATUS="FATAL">
       !   MAX_OUT_PER_IN_FIELD = <MAX_OUT_PER_IN_FIELD> exceeded for <module_name>/<field_name>, increase MAX_OUT_PER_IN_FIELD
       !   in diag_data.F90.
       ! </ERROR>
       WRITE (UNIT=error_msg,FMT=*) MAX_OUT_PER_IN_FIELD
       CALL error_mesg('diag_util_mod::init_output_field',&
        & 'MAX_OUT_PER_IN_FIELD exceeded for '//TRIM(module_name)//"/"//TRIM(field_name)//&
        &', increase MAX_OUT_PER_IN_FIELD in diag_data.F90', FATAL)
    END IF
    input_fields(in_num)%output_fields(input_fields(in_num)%num_output_fields) = out_num

    ! Also put pointer to input field in this output field
    output_fields(out_num)%input_field = in_num

    ! Next, find the number for the corresponding file
    IF ( TRIM(output_file).EQ.'null' ) THEN
       file_num = max_files
    ELSE
       file_num = find_file(output_file, 1)
       IF ( file_num < 0 ) THEN
          ! <ERROR STATUS="FATAL">
          !   file <file_name> is NOT found in the diag_table.
          ! </ERROR>
          CALL error_mesg('diag_util_mod::init_output_field', 'file '&
               & //TRIM(output_file)//' is NOT found in the diag_table', FATAL)
       END IF
       IF ( tile_count > 1 ) THEN
          file_num_tile1 = file_num
          file_num = find_file(output_file, tile_count)
          IF(file_num < 0) THEN
             CALL init_file(files(file_num_tile1)%name, files(file_num_tile1)%output_freq,&
                  & files(file_num_tile1)%output_units, files(file_num_tile1)%format,&
                  & files(file_num_tile1)%time_units, files(file_num_tile1)%long_name,&
                  & tile_count, files(file_num_tile1)%new_file_freq,&
                  & files(file_num_tile1)%new_file_freq_units, files(file_num_tile1)%start_time,&
                  & files(file_num_tile1)%duration, files(file_num_tile1)%duration_units  )
             file_num = find_file(output_file, tile_count)
             IF ( file_num < 0 ) THEN
                ! <ERROR STATUS="FATAL">
                !   file <output_file> is not initialized for tile_count = <tile_count>
                ! </ERROR>
                CALL error_mesg('diag_util_mod::init_output_field', 'file '//TRIM(output_file)//&
                     & ' is not initialized for tile_count = '//TRIM(string(tile_count)), FATAL)
             END IF
          END IF
       END IF
    END IF

    ! Insert this field into list for this file
    files(file_num)%num_fields = files(file_num)%num_fields + 1
    IF ( files(file_num)%num_fields > MAX_FIELDS_PER_FILE ) THEN
       WRITE (UNIT=error_msg, FMT=*) MAX_FIELDS_PER_FILE
       ! <ERROR STATUS="FATAL">
       !   MAX_FIELDS_PER_FILE = <MAX_FIELDS_PER_FILE> exceeded.  Increase MAX_FIELDS_PER_FILE in diag_data.F90.
       ! </ERROR>
       CALL error_mesg('diag_util_mod::init_output_field',&
            & 'MAX_FIELDS_PER_FILE = '//TRIM(error_msg)//' exceeded.  Increase MAX_FIELDS_PER_FILE in diag_data.F90.', FATAL)
    END IF
    num_fields = files(file_num)%num_fields
    files(file_num)%fields(num_fields) = out_num

    ! Set the file for this output field
    output_fields(out_num)%output_file = file_num

    ! Enter the other data for this output field
    output_fields(out_num)%output_name = TRIM(output_name)
    output_fields(out_num)%pack = pack
    output_fields(out_num)%num_axes = 0
    output_fields(out_num)%total_elements = 0
    output_fields(out_num)%region_elements = 0
    output_fields(out_num)%imax = 0
    output_fields(out_num)%jmax = 0
    output_fields(out_num)%kmax = 0
    output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
    output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
    output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH

    ! initialize the size of the diurnal axis to 1
    output_fields(out_num)%n_diurnal_samples = 1

    ! Initialize all time method to false
    method_selected = 0
    output_fields(out_num)%time_average = .FALSE.
    output_fields(out_num)%time_min = .FALSE.
    output_fields(out_num)%time_max = .FALSE. 
    output_fields(out_num)%time_ops = .FALSE.
    output_fields(out_num)%written_once = .FALSE.

    t_method = lowercase(time_method)
    ! cannot time average fields output every time
    IF ( files(file_num)%output_freq == EVERY_TIME ) THEN
       output_fields(out_num)%time_average = .FALSE.
       method_selected = method_selected+1
       t_method = 'point'
    ELSEIF ( INDEX(t_method,'diurnal') == 1 ) THEN
       ! get the integer number from the t_method
       READ (UNIT=t_method(8:LEN_TRIM(t_method)), FMT=*, IOSTAT=ioerror) output_fields(out_num)%n_diurnal_samples
       IF ( ioerror /= 0 ) THEN
          ! <ERROR STATUS="FATAL">
          !   could not find integer number of diurnal samples in string "<t_method>"
          ! </ERROR>
          CALL error_mesg('diag_util_mod::init_output_field',&
               & 'could not find integer number of diurnal samples in string "' //TRIM(t_method)//'"', FATAL)
       ELSE IF ( output_fields(out_num)%n_diurnal_samples <= 0 ) THEN
          ! <ERROR STATUS="FATAL">
          !   The integer value of diurnal samples must be greater than zero.
          ! </ERROR>
          CALL error_mesg('diag_util_mod::init_output_field',&
               & 'The integer value of diurnal samples must be greater than zero.', FATAL)
       END IF
       output_fields(out_num)%time_average = .TRUE.
       method_selected = method_selected+1
       t_method='mean'
    ELSE
       SELECT CASE(TRIM(t_method))
       CASE ( '.true.', 'mean', 'average', 'avg' )
          output_fields(out_num)%time_average = .TRUE.
          method_selected = method_selected+1
          t_method = 'mean'
       CASE ( '.false.', 'none', 'point' )
          output_fields(out_num)%time_average = .FALSE.
          method_selected = method_selected+1
          t_method = 'point'
       CASE ( 'maximum', 'max' )
          output_fields(out_num)%time_max = .TRUE.
          l1 = LEN_TRIM(output_fields(out_num)%output_name)
          IF ( output_fields(out_num)%output_name(l1-2:l1) /= 'max' ) &
               output_fields(out_num)%output_name = TRIM(output_name)//'_max'
          method_selected = method_selected+1
          t_method = 'max'        
       CASE ( 'minimum', 'min' )
          output_fields(out_num)%time_min = .TRUE.
          l1 = LEN_TRIM(output_fields(out_num)%output_name)
          IF ( output_fields(out_num)%output_name(l1-2:l1) /= 'min' )&
               & output_fields(out_num)%output_name = TRIM(output_name)//'_min'
          method_selected = method_selected+1
          t_method = 'min'        
       END SELECT
    END IF
    
    ! reconcile logical flags
    output_fields(out_num)%time_ops = output_fields(out_num)%time_min.OR.output_fields(out_num)%time_max&
         & .OR.output_fields(out_num)%time_average

    output_fields(out_num)%phys_window = .FALSE.
    ! need to initialize grid_type = -1(start, end, l_start_indx,l_end_indx etc...)
    IF ( PRESENT(local_coord) ) THEN
       input_fields(in_num)%local = .TRUE.
       input_fields(in_num)%local_coord = local_coord
       IF ( INT(local_coord%xbegin * local_coord%xbegin) == 1 .AND.&
            & INT(local_coord%ybegin * local_coord%ybegin) ==1 ) THEN
          output_fields(out_num)%local_output = .FALSE.
          output_fields(out_num)%need_compute = .FALSE.
          output_fields(out_num)%reduced_k_range = .TRUE.
       ELSE
          output_fields(out_num)%local_output = .TRUE.
          output_fields(out_num)%need_compute = .FALSE.
          output_fields(out_num)%reduced_k_range = .FALSE.
       END IF

       output_fields(out_num)%output_grid%start(1) = local_coord%xbegin
       output_fields(out_num)%output_grid%start(2) = local_coord%ybegin
       output_fields(out_num)%output_grid%start(3) = local_coord%zbegin
       output_fields(out_num)%output_grid%end(1) = local_coord%xend
       output_fields(out_num)%output_grid%end(2) = local_coord%yend
       output_fields(out_num)%output_grid%end(3) = local_coord%zend
       DO i = 1, 3
          output_fields(out_num)%output_grid%l_start_indx(i) = -1
          output_fields(out_num)%output_grid%l_end_indx(i) = -1
          output_fields(out_num)%output_grid%subaxes(i) = -1
       END DO
    ELSE
       output_fields(out_num)%local_output = .FALSE.
       output_fields(out_num)%need_compute = .FALSE.
       output_fields(out_num)%reduced_k_range = .FALSE.
    END IF

    ! <ERROR STATUS="FATAL">
    !   improper time method in diag_table for output field <output_name>
    ! </ERROR>
    IF ( method_selected /= 1 ) CALL error_mesg('diag_util_mod::init_output_field',&
         &'improper time method in diag_table for output field:'//TRIM(output_name),FATAL)

    output_fields(out_num)%time_method = TRIM(t_method)

    ! allocate counters: NOTE that for simplicity we always allocate them, even 
    ! if they are superceeded by 4D "counter" array. This isn't most memory 
    ! efficient, approach, but probably tolerable since they are so small anyway
    ALLOCATE(output_fields(out_num)%count_0d(output_fields(out_num)%n_diurnal_samples))
    ALLOCATE(output_fields(out_num)%num_elements(output_fields(out_num)%n_diurnal_samples))
    output_fields(out_num)%count_0d(:) = 0
    output_fields(out_num)%num_elements(:) = 0
  END SUBROUTINE init_output_field
  ! </SUBROUTINE>
  
  ! <PRIVATE>
  ! <SUBROUTINE NAME="opening_file">
  !   <OVERVIEW>
  !     Open file for output.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE opening_file(file, time)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Open file for output, and write the meta data.  <BB>Warning:</BB> Assumes all data structures have been fully initialized.
  !   </DESCRIPTION>
  !   <IN NAME="file" TYPE="INTEGER">File ID.</IN>
  !   <IN NAME="tile" TYPE="TYPE(time_type)">Tile number.</IN>
  SUBROUTINE opening_file(file, time)
    ! WARNING: Assumes that all data structures are fully initialized
    INTEGER, INTENT(in) :: file
    TYPE(time_type), INTENT(in) :: time  

    REAL, DIMENSION(2) :: DATA
    INTEGER :: j, field_num, input_field_num, num_axes, k 
    INTEGER :: field_num1
    INTEGER :: position
    INTEGER :: dir, edges
    INTEGER :: ntileMe
    INTEGER, ALLOCATABLE :: tile_id(:)
    INTEGER, DIMENSION(1) :: time_axis_id, time_bounds_id
    ! size of this axes array must be at least max num. of
    ! axes per field + 2; the last two elements are for time
    ! and time bounds dimensions
    INTEGER, DIMENSION(6) :: axes 
    LOGICAL :: time_ops, aux_present, match_aux_name
    LOGICAL :: all_scalar_or_1d
    CHARACTER(len=7) :: prefix
    CHARACTER (len = 7) :: avg_name = 'average'
    CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, filename, aux_name,fieldname
    CHARACTER(len=128) :: suffix, base_name
    CHARACTER(len=32) :: time_name, timeb_name,time_longname, timeb_longname, cart_name
    CHARACTER(len=256) :: fname
    TYPE(domain1d) :: domain
    TYPE(domain2d) :: domain2

    aux_present = .FALSE.
    match_aux_name = .FALSE.
    ! it's unlikely that a file starts with word "rregion", need to check anyway.
    IF ( LEN(files(file)%name) >=7 .AND. .NOT.files(file)%local ) THEN
       prefix = files(file)%name(1:7)
       IF ( lowercase(prefix) == 'rregion' ) THEN 
          ! <ERROR STATUS="WARNING">
          !   file name should not start with word "rregion"
          ! </ERROR>
          IF ( mpp_pe() == mpp_root_pe() ) CALL error_mesg('diag_util_mod::opening_file',&
               & 'file name should not start with word "rregion"', WARNING)
       END IF
    END IF
    
    ! Here is where time_units string must be set up; time since base date
    WRITE (time_units, 11) TRIM(time_unit_list(files(file)%time_units)), base_year,&
         & base_month, base_day, base_hour, base_minute, base_second
11  FORMAT(A, ' since ', I4.4, '-', I2.2, '-', I2.2, ' ', I2.2, ':', I2.2, ':', I2.2)
    base_name = files(file)%name
    IF ( files(file)%new_file_freq < VERY_LARGE_FILE_FREQ ) THEN
       position = INDEX(files(file)%name, '%')
       IF ( position > 0 )  THEN
          base_name = base_name(1:position-1)
       ELSE
          ! <ERROR STATUS="FATAL">
          !   filename <files(file)%name> does not contain % for time stamp string
          ! </ERROR>
          CALL error_mesg('diag_util_mod::opening_file',&
               & 'file name '//TRIM(files(file)%name)//' does not contain % for time stamp string', FATAL) 
       END IF
       suffix = get_time_string(files(file)%name, time)
    ELSE
       suffix = ' '
    END IF
    ! Add CVS tag as prefix of filename  (currently not implemented)
    !  i1 = INDEX(tagname,':') + 2
    !  i2 = len_trim(tagname) - 2
    !  if(i2 <=i1)  call error_mesg('diag_util opening_file','error in CVS tagname index',FATAL)
    !  prefix2 = tagname(i1:i2)//'_'
    IF ( files(file)%local ) THEN      
       ! prepend "rregion" to all local files for post processing, the prefix will be removed in postprocessing
       filename = 'rregion'//TRIM(base_name)//TRIM(suffix)
    ELSE
       ! filename = trim(prefix2)//trim(base_name)//trim(suffix)
       filename = TRIM(base_name)//TRIM(suffix)
    END IF

    ! Loop through all fields with this file to output axes
    ! JWD: This is a klooge; need something more robust
    domain2 = NULL_DOMAIN2D
    all_scalar_or_1d = .TRUE.
    DO j = 1, files(file)%num_fields
       field_num = files(file)%fields(j)
       if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE
       num_axes = output_fields(field_num)%num_axes
       IF ( num_axes > 1 ) THEN
          all_scalar_or_1d = .FALSE.
          domain2 = get_domain2d ( output_fields(field_num)%axes(1:num_axes) )
          IF ( domain2 .NE. NULL_DOMAIN2D ) EXIT
       END IF
    END DO
    IF( .NOT.all_scalar_or_1d ) THEN
       IF ( domain2 .EQ. NULL_DOMAIN2D ) CALL return_domain(domain2)
       IF ( domain2 .EQ. NULL_DOMAIN2D ) THEN
          ! <ERROR STATUS="FATAL">
          !   Domain not defined through set_domain interface; cannot retrieve tile info
          ! </ERROR>
          CALL error_mesg('diag_util_mod::opening_file',&
               & 'Domain not defined through set_domain interface; cannot retrieve tile info', FATAL)
       END IF
       IF ( mpp_get_ntile_count(domain2) > 1 ) THEN
          ntileMe = mpp_get_current_ntile(domain2)
          ALLOCATE(tile_id(ntileMe))
          tile_id = mpp_get_tile_id(domain2)
          fname = TRIM(filename)
          CALL get_tile_string(filename, TRIM(fname)//'.tile' , tile_id(files(file)%tile_count))
          DEALLOCATE(tile_id)
       END IF
    END IF

    CALL diag_output_init(filename, files(file)%format, global_descriptor,&
         & files(file)%file_unit, all_scalar_or_1d, domain2) 
    files(file)%bytes_written = 0 
    ! Does this file contain time_average fields?
    time_ops = .FALSE.
    DO j = 1, files(file)%num_fields
       field_num = files(file)%fields(j)
       IF ( output_fields(field_num)%time_ops ) THEN
          time_ops = .TRUE.
          EXIT
       END IF
    END DO
    ! Loop through all fields with this file to output axes
    DO j = 1, files(file)%num_fields
       field_num = files(file)%fields(j)
       input_field_num = output_fields(field_num)%input_field
       IF (.NOT.input_fields(input_field_num)%register) THEN
          WRITE (error_string,'(A,"/",A)') TRIM(input_fields(input_field_num)%module_name),&
               & TRIM(input_fields(input_field_num)%field_name)
          IF(mpp_pe() .EQ. mpp_root_pe()) THEN
             ! <ERROR STATUS="WARNING">
             !   module/field_name (<input_fields(input_field_num)%module_name>/<input_fields(input_field_num)%field_name>)
             !   NOT registered
             ! </ERROR>
             CALL error_mesg('diag_util_mod::opening_file',&
                  & 'module/field_name ('//TRIM(error_string)//') NOT registered', WARNING)  
          END IF
          CYCLE
       END IF
       if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE

       ! Put the time axis in the axis field
       num_axes = output_fields(field_num)%num_axes
       axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
       ! make sure that axis_id are not -1
       DO k = 1, num_axes
          IF ( axes(k) < 0 ) THEN
             WRITE(error_string,'(a)') output_fields(field_num)%output_name
             ! <ERROR STATUS="FATAL">
             !   ouptut_name <output_fields(field_num)%output_name> has axis_id = -1
             ! </ERROR>
             CALL error_mesg('diag_util_mod::opening_file','output_name '//TRIM(error_string)//&
                  & ' has axis_id = -1', FATAL)
          END IF
       END DO
       ! check if aux is present in any axes
       IF ( .NOT.aux_present ) THEN
          DO k = 1, num_axes
             aux_name = get_axis_aux(axes(k))
             IF ( TRIM(aux_name) /= 'none' ) THEN
                aux_present = .TRUE.
                EXIT
             END IF
          END DO
       END IF

       axes(num_axes + 1) = files(file)%time_axis_id
       CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 1), time_ops)
       IF ( time_ops ) THEN
          axes(num_axes + 2) = files(file)%time_bounds_id
          CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 2))     
       END IF
    END DO

    ! Looking for the first NON-static field in a file
    field_num1 = files(file)%fields(1)
    DO j = 1, files(file)%num_fields
       field_num = files(file)%fields(j)
       IF ( output_fields(field_num)%time_ops ) THEN
          field_num1 = field_num
          EXIT
       END IF
    END DO
    DO j = 1, files(file)%num_fields
       field_num = files(file)%fields(j)
       input_field_num = output_fields(field_num)%input_field
       IF (.NOT.input_fields(input_field_num)%register) CYCLE
       IF (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE
       ! Make sure that 1 file contains either time_average or instantaneous fields
       ! cannot have both time_average and instantaneous in 1 file
       IF ( .NOT.mix_snapshot_average_fields ) THEN
          IF ( (output_fields(field_num)%time_ops.NEQV.output_fields(field_num1)%time_ops) .AND.&
               & .NOT.output_fields(field_num1)%static .AND. .NOT.output_fields(field_num)%static) THEN
             IF ( mpp_pe() == mpp_root_pe() ) THEN
                ! <ERROR STATUS="FATAL">
                !   <files(file)%name> can NOT have BOTH time average AND instantaneous fields.
                !   Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.
                ! </ERROR>
                CALL error_mesg('diag_util_mod::opening_file','file '//&
                     & TRIM(files(file)%name)//' can NOT have BOTH time average AND instantaneous fields.'//&
                     & ' Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.' , FATAL)
             END IF
          END IF
       END IF
       ! check if any field has the same name as aux_name
       IF ( aux_present .AND. .NOT.match_aux_name ) THEN
          fieldname = output_fields(field_num)%output_name
          IF ( INDEX(aux_name, TRIM(fieldname)) > 0 ) match_aux_name = .TRUE.   
       END IF

       ! Put the time axis in the axis field
       num_axes = output_fields(field_num)%num_axes
       axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
       IF ( .NOT.output_fields(field_num)%static ) THEN
          num_axes=num_axes+1
          axes(num_axes) = files(file)%time_axis_id
       END IF
       IF(output_fields(field_num)%time_average) THEN
          avg = avg_name
       ELSE IF(output_fields(field_num)%time_max) THEN
          avg = avg_name
       ELSE IF(output_fields(field_num)%time_min) THEN
          avg = avg_name
       ELSE
          avg = " "
       END IF
       IF ( input_fields(input_field_num)%missing_value_present ) THEN
          IF ( LEN_TRIM(input_fields(input_field_num)%interp_method) > 0 ) THEN
             output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
                  & output_fields(field_num)%output_name, axes(1:num_axes),&
                  & input_fields(input_field_num)%units,&
                  & input_fields(input_field_num)%long_name,&
                  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
                  & input_fields(input_field_num)%missing_value, avg_name = avg,&
                  & time_method=output_fields(field_num)%time_method,&
                  & standard_name = input_fields(input_field_num)%standard_name,&
                  & interp_method = input_fields(input_field_num)%interp_method)
          ELSE
             output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
                  & output_fields(field_num)%output_name, axes(1:num_axes),&
                  & input_fields(input_field_num)%units,&
                  & input_fields(input_field_num)%long_name,&
                  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
                  & input_fields(input_field_num)%missing_value, avg_name = avg,&
                  & time_method=output_fields(field_num)%time_method,&
                  & standard_name = input_fields(input_field_num)%standard_name)
          END IF
          ! NEED TO TAKE CARE OF TIME AVERAGING INFO TOO BOTH CASES
       ELSE
          IF ( LEN_TRIM(input_fields(input_field_num)%interp_method) > 0 ) THEN
             output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
                  & output_fields(field_num)%output_name, axes(1:num_axes),&
                  & input_fields(input_field_num)%units,&
                  & input_fields(input_field_num)%long_name,&
                  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
                  & avg_name = avg,&
                  & time_method=output_fields(field_num)%time_method,&
                  & standard_name = input_fields(input_field_num)%standard_name,&
                  & interp_method = input_fields(input_field_num)%interp_method)
          ELSE
             output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
                  & output_fields(field_num)%output_name, axes(1:num_axes),&
                  & input_fields(input_field_num)%units,&
                  & input_fields(input_field_num)%long_name,&
                  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
                  & avg_name = avg,&
                  & time_method=output_fields(field_num)%time_method,&
                  & standard_name = input_fields(input_field_num)%standard_name)
          END IF
       END IF
    END DO

    ! If any of the fields in the file are time averaged, need to output the axes
    ! Use double precision since time axis is double precision
    IF ( time_ops ) THEN
       time_axis_id(1) = files(file)%time_axis_id
       files(file)%f_avg_start = write_field_meta_data(files(file)%file_unit,&
            & avg_name // '_T1', time_axis_id, time_units,&
            & "Start time for average period", pack=1)
       files(file)%f_avg_end = write_field_meta_data(files(file)%file_unit,&
            & avg_name // '_T2', time_axis_id, time_units,&
            & "End time for average period", pack=1)
       files(file)%f_avg_nitems = write_field_meta_data(files(file)%file_unit,&
            & avg_name // '_DT', time_axis_id,&
            & TRIM(time_unit_list(files(file)%time_units)),& 
            & "Length of average period", pack=1)
    END IF

    IF ( time_ops ) THEN
       time_axis_id(1) = files(file)%time_axis_id
       time_bounds_id(1) = files(file)%time_bounds_id
       CALL get_diag_axis( time_axis_id(1), time_name, time_units, time_longname,&
            & cart_name, dir, edges, Domain, DATA)
       CALL get_diag_axis( time_bounds_id(1), timeb_name, timeb_units, timeb_longname,&
            & cart_name, dir, edges, Domain, DATA)     
       files(file)%f_bounds =  write_field_meta_data(files(file)%file_unit,&
            & TRIM(time_name)//'_bounds', (/time_bounds_id,time_axis_id/),&
            & TRIM(time_unit_list(files(file)%time_units)),&
            & TRIM(time_name)//' axis boundaries', pack=1)      
    END IF
    ! Let lower levels know that all meta data has been sent
    CALL done_meta_data(files(file)%file_unit)
    IF( aux_present .AND. .NOT.match_aux_name ) THEN
       ! <ERROR STATUS="WARNING">
       !   one axis has auxiliary but the corresponding field is NOT
       !   found in file <file_name>
       ! </ERROR>
       IF ( mpp_pe() == mpp_root_pe() ) CALL error_mesg('diag_util_mod::opening_file',&
            &'one axis has auxiliary but the corresponding field is NOT found in file '//TRIM(files(file)%name), WARNING)
    END IF
  END SUBROUTINE opening_file
  ! </SUBROUTINE>
  ! </PRIVATE>
  
  ! <PRIVATE>
  ! <FUNCTION NAME="get_time_string">
  !   <OVERVIEW>
  !     This function determines a string based on current time.
  !     This string is used as suffix in output file name
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     This function determines a string based on current time.
  !     This string is used as suffix in output file name
  !   </DESCRIPTION>
  !   <IN NAME="filename" TYPE="CHARACTER(len=128)">File name.</IN>
  !   <IN NAME="current_time" TYPE="TYPE(time_type)">Current model time.</IN>
  CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
    CHARACTER(len=128), INTENT(in) :: filename
    TYPE(time_type), INTENT(in) :: current_time

    INTEGER :: yr1, mo1, dy1, hr1, mi1, sc1  ! get from current time
    INTEGER :: yr2, dy2, hr2, mi2            ! for computing next_level time unit
    INTEGER :: yr1_s, mo1_s, dy1_s, hr1_s, mi1_s, sc1_s ! actual values to write string
    INTEGER :: abs_sec, abs_day              ! component of current_time
    INTEGER :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
    INTEGER :: julian_day, i, position, len, first_percent
    CHARACTER(len=1) :: width  ! width of the field in format write
    CHARACTER(len=10) :: format
    CHARACTER(len=20) :: yr, mo, dy, hr, mi, sc        ! string of current time (output)
    CHARACTER(len=128) :: filetail

    format = '("_",i*.*)'
    CALL get_date(current_time, yr1, mo1, dy1, hr1, mi1, sc1)
    len = LEN_TRIM(filename)
    first_percent = INDEX(filename, '%')
    filetail = filename(first_percent:len)
    ! compute year string 
    position = INDEX(filetail, 'yr')
    IF ( position > 0 ) THEN
       width = filetail(position-1:position-1)
       yr1_s = yr1
       format(7:9) = width//'.'//width
       WRITE(yr, format) yr1_s   
       yr2 = 0
    ELSE  
       yr = ' '
       yr2 = yr1 - 1
    END IF
    ! compute month string 
    position = INDEX(filetail, 'mo')
    IF ( position > 0 ) THEN   
       width = filetail(position-1:position-1)
       mo1_s = yr2*12 + mo1  
       format(7:9) = width//'.'//width
       WRITE(mo, format) mo1_s
    ELSE
       mo = ' '
    END IF
    ! compute day string        
    IF ( LEN_TRIM(mo) > 0 ) THEN ! month present
       dy1_s = dy1 
       dy2 = dy1_s - 1
    ELSE IF ( LEN_TRIM(yr) >0 )  THEN ! no month, year present
       ! compute julian day
       IF ( mo1 == 1 ) THEN
          dy1_s = dy1
       ELSE
          julian_day = 0
          DO i = 1, mo1-1
             julian_day = julian_day + days_per_month(i)
          END DO
          IF ( leap_year(current_time) .AND. mo1 > 2 ) julian_day = julian_day + 1
          julian_day = julian_day + dy1
          dy1_s = julian_day
       END IF
       dy2 = dy1_s - 1
    ELSE ! no month, no year
       CALL get_time(current_time, abs_sec, abs_day)
       dy1_s = abs_day  
       dy2 = dy1_s 
    END IF
    position = INDEX(filetail, 'dy')
    IF ( position > 0 ) THEN 
       width = filetail(position-1:position-1)
       FORMAT(7:9) = width//'.'//width
       WRITE(dy, FORMAT) dy1_s
    ELSE
       dy = ' '
    END IF
    ! compute hour string
    IF ( LEN_TRIM(dy) > 0 ) THEN
       hr1_s = hr1
    ELSE
       hr1_s = dy2*24 + hr1
    END IF
    hr2 = hr1_s
    position = INDEX(filetail, 'hr')
    IF ( position > 0 ) THEN
       width = filetail(position-1:position-1)
       format(7:9) = width//'.'//width
       WRITE(hr, format) hr1_s
    ELSE
       hr = ' '
    END IF
    ! compute minute string
    IF ( LEN_TRIM(hr) > 0 ) THEN
       mi1_s = mi1
    ELSE
       mi1_s = hr2*60 + mi1
    END IF
    mi2 = mi1_s
    position = INDEX(filetail, 'mi')
    IF(position>0) THEN
       width = filetail(position-1:position-1)
       format(7:9) = width//'.'//width
       WRITE(mi, format) mi1_s
    ELSE
       mi = ' '
    END IF
    ! compute second string
    IF ( LEN_TRIM(mi) > 0 ) THEN
       sc1_s = sc1
    ELSE
       sc1_s = NINT(mi2*SECONDS_PER_MINUTE) + sc1
    END IF
    position = INDEX(filetail, 'sc')
    IF ( position > 0 ) THEN
       width = filetail(position-1:position-1)
       format(7:9) = width//'.'//width
       WRITE(sc, format) sc1_s
    ELSE
       sc = ' '
    ENDIF
    get_time_string = TRIM(yr)//TRIM(mo)//TRIM(dy)//TRIM(hr)//TRIM(mi)//TRIM(sc)
  END FUNCTION get_time_string
  ! </FUNCTION>
  ! </PRIVATE>

  ! <FUNCTION NAME="get_date_dif">
  !   <OVERVIEW>
  !     Return the difference between two times in units.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     REAL FUNCTION get_date_dif(t2, t1, units)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Calculate and return the difference between the two times given in the unit given using the function <TT>t2 - t1</TT>.
  !   </DESCRIPTION>
  !   <IN NAME="t2" TYPE="TYPE(time_type)">Most recent time.</IN>
  !   <IN NAME="t1" TYPE="TYPE(time_type)">Most distant time.</IN>
  !   <IN NAME="units" TYPE="INTEGER">Unit of return value.</IN>
  REAL FUNCTION get_date_dif(t2, t1, units)
    TYPE(time_type), INTENT(in) :: t2, t1
    INTEGER, INTENT(in) :: units

    INTEGER :: dif_seconds, dif_days
    TYPE(time_type) :: dif_time

    ! Compute time axis label value
    ! <ERROR STATUS="FATAL">
    !   variable t2 is less than in variable t1
    ! </ERROR>
    IF ( t2 < t1 ) CALL error_mesg('diag_util_mod::get_date_dif', &
         & 'in variable t2 is less than in variable t1', FATAL)

    dif_time = t2 - t1

    CALL get_time(dif_time, dif_seconds, dif_days)

    IF ( units == DIAG_SECONDS ) THEN
       get_date_dif = dif_seconds + SECONDS_PER_DAY * dif_days
    ELSE IF ( units == DIAG_MINUTES ) THEN
       get_date_dif = 1440 * dif_days + dif_seconds / SECONDS_PER_MINUTE
    ELSE IF ( units == DIAG_HOURS ) THEN
       get_date_dif = 24 * dif_days + dif_seconds / SECONDS_PER_HOUR
    ELSE IF ( units == DIAG_DAYS ) THEN
       get_date_dif = dif_days + dif_seconds / SECONDS_PER_DAY
    ELSE IF ( units == DIAG_MONTHS ) THEN
       ! <ERROR STATUS="FATAL">
       !   months not supported as output units
       ! </ERROR>
       CALL error_mesg('diag_util_mod::get_date_dif', 'months not supported as output units', FATAL)
    ELSE IF ( units == DIAG_YEARS ) THEN
       ! <ERROR STATUS="FATAL">
       !   years not suppored as output units
       ! </ERROR>
       CALL error_mesg('diag_util_mod::get_date_dif', 'years not supported as output units', FATAL)
    ELSE
       ! <ERROR STATUS="FATAL">
       !   illegal time units
       ! </ERROR>
       CALL error_mesg('diag_util_mod::diag_date_dif', 'illegal time units', FATAL)
    END IF
  END FUNCTION get_date_dif
  ! </FUNCTION>

  ! <SUBROUTINE NAME="diag_data_out">
  !   <OVERVIEW>
  !     Write data out to file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE diag_data_out(file, field, dat, time, fianl_call_in, static_write_in)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Write data out to file, and if necessary flush the buffers.
  !   </DESCRIPTION>
  !   <IN NAME="file" TYPE="INTEGER">File ID.</IN>
  !   <IN NAME="field" TYPE="INTEGER">Field ID.</IN>
  !   <INOUT NAME="dat" TYPE="REAL, DIMENSION(:,:,:,:)">Data to write out.</INOUT>
  !   <IN NAME="time" TYPE="TYPE(time_type)">Current model time.</IN>
  !   <IN NAME="final_call_in" TYPE="LOGICAL, OPTIONAL"><TT>.TRUE.</TT> if this is the last write for file.</IN>
  !   <IN NAME="static_write_in" TYPE="LOGICAL, OPTIONAL"><TT>.TRUE.</TT> if static fields are to be written to file.</IN>
  SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in)
    INTEGER, INTENT(in) :: file, field
    REAL, DIMENSION(:,:,:,:), INTENT(inout) :: dat
    TYPE(time_type), INTENT(in) :: time
    LOGICAL, OPTIONAL, INTENT(in):: final_call_in, static_write_in

    LOGICAL :: final_call, do_write, static_write
    INTEGER :: i, num
    REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif

    do_write = .TRUE.
    final_call = .FALSE.
    IF ( PRESENT(final_call_in) ) final_call = final_call_in
    static_write = .FALSE.
    IF ( PRESENT(static_write_in) ) static_write = static_write_in
    dif = get_date_dif(time, base_time, files(file)%time_units)
    ! get file_unit, open new file and close curent file if necessary
    IF ( .NOT.static_write .OR. files(file)%file_unit < 0 ) CALL check_and_open(file, time, do_write)
    IF ( .NOT.do_write ) RETURN  ! no need to write data
    CALL diag_field_out(files(file)%file_unit,output_fields(field)%f_type, dat, dif)
    ! record number of bytes written to this file
    files(file)%bytes_written = files(file)%bytes_written +&
         & (SIZE(dat,1)*SIZE(dat,2)*SIZE(dat,3))*(8/output_fields(field)%pack)
    IF ( .NOT.output_fields(field)%written_once ) output_fields(field)%written_once = .TRUE.
    ! *** inserted this line because start_dif < 0 for static fields ***
    IF ( .NOT.output_fields(field)%static ) THEN 
       start_dif = get_date_dif(output_fields(field)%last_output, base_time,files(file)%time_units)
       IF ( .NOT.mix_snapshot_average_fields ) THEN
          end_dif = get_date_dif(output_fields(field)%next_output, base_time, files(file)%time_units)
       ELSE
          end_dif = dif
       END IF
    END IF

    ! Need to write average axes out;
    DO i = 1, files(file)%num_fields
       num = files(file)%fields(i)
       IF ( output_fields(num)%time_ops .AND. &
            input_fields(output_fields(num)%input_field)%register) THEN
          IF ( num == field ) THEN
             ! Output the axes if this is first time-averaged field
             time_data(1, 1, 1, 1) = start_dif
             CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_start, time_data(1:1,:,:,:), dif)
             time_data(2, 1, 1, 1) = end_dif
             CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_end, time_data(2:2,:,:,:), dif)
             ! Compute the length of the average
             dt_time(1, 1, 1, 1) = end_dif - start_dif
             CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_nitems, dt_time(1:1,:,:,:), dif)

             ! Include boundary variable for CF compliance
             CALL diag_field_out(files(file)%file_unit, files(file)%f_bounds, time_data(1:2,:,:,:), dif)         
             EXIT
          END IF
       END IF
    END DO

    ! If write time is greater (equal for the last call) than last_flush for this file, flush it
    IF ( final_call ) THEN
       IF ( time >= files(file)%last_flush ) THEN
          CALL diag_flush(files(file)%file_unit)
          files(file)%last_flush = time
       END IF
    ELSE
       IF ( time > files(file)%last_flush ) THEN
          CALL diag_flush(files(file)%file_unit)
          files(file)%last_flush = time
       END IF
    END IF
  END SUBROUTINE diag_data_out
  ! </SUBROUTINE>

  ! <PRIVATE>
  ! <SUBROUTINE NAME="check_and_open">
  !   <OVERVIEW>
  !     Checks if it is time to open a new file.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE check_and_open(file, time, do_write)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Checks if it is time to open a new file. If yes, it first closes the
  !     current file, opens a new file and returns file_unit
  !     previous diag_manager_end is replaced by closing_file and output_setup by opening_file.
  !   </DESCRIPTION>
  !   <IN NAME="file" TYPE="INTEGER">File ID.</IN>
  !   <IN NAME="time" TYPE="TYPE(time_type)">Current model time.</IN>
  !   <OUT NAME="do_write" TYPE="LOGICAL"><TT>.TRUE.</TT> if file is expecting more data to write, <TT>.FALSE.</TT> otherwise.</OUT>
  SUBROUTINE check_and_open(file, time, do_write)
    INTEGER, INTENT(in) :: file
    TYPE(time_type), INTENT(in) :: time
    LOGICAL, INTENT(out) :: do_write

    IF ( time >= files(file)%start_time ) THEN 
       IF ( files(file)%file_unit < 0 ) THEN ! need to open a new file
          CALL opening_file(file, time)
          do_write = .TRUE.
       ELSE
          do_write = .TRUE.
          IF ( time > files(file)%close_time .AND. time < files(file)%next_open ) THEN
             do_write = .FALSE. ! file still open but receives NO MORE data
          ELSE IF ( time > files(file)%next_open ) THEN ! need to close current file and open a new one 
             CALL write_static(file)  ! write all static fields and close this file
             CALL opening_file(file, time)        
             files(file)%start_time = files(file)%next_open
             files(file)%close_time =&
                  & diag_time_inc(files(file)%start_time,files(file)%duration, files(file)%duration_units)  
             files(file)%next_open =&
                  & diag_time_inc(files(file)%next_open, files(file)%new_file_freq,&
                  & files(file)%new_file_freq_units)
             IF ( files(file)%close_time > files(file)%next_open ) THEN 
                ! <ERROR STATUS="FATAL">
                !   <file_name> has close time GREATER than next_open time,
                !   check file duration and frequency
                ! </ERROR>
                CALL error_mesg('diag_util_mod::check_and_open',&
                     & files(file)%name//' has close time GREATER than next_open time, check file duration and frequency',FATAL)
             END IF
          END IF ! no need to open new file, simply return file_unit
       END IF
    ELSE
       do_write = .FALSE.
    END IF
  END SUBROUTINE check_and_open
  ! </SUBROUTINE>
  ! </PRIVATE>

  ! <SUBROUTINE NAME="write_static">
  !   <OVERVIEW>
  !     Output all static fields in this file
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE write_static(file)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Write the static data to the file.
  !   </DESCRIPTION>
  !   <IN NAME="file" TYPE="INTEGER">File ID.</IN>
  SUBROUTINE write_static(file)
    INTEGER, INTENT(in) :: file

    INTEGER :: j, i, input_num

    DO j = 1, files(file)%num_fields
       i = files(file)%fields(j)
       input_num = output_fields(i)%input_field
       ! skip fields that were not registered
       IF ( .NOT.input_fields(input_num)%register ) CYCLE
       if( output_fields(i)%local_output .AND. .NOT. output_fields(i)%need_compute) CYCLE
       ! only output static fields here
       IF ( .NOT.output_fields(i)%static ) CYCLE
       CALL diag_data_out(file, i, output_fields(i)%buffer, files(file)%last_flush, .TRUE., .TRUE.)
    END DO
    ! Close up this file   
    CALL mpp_close(files(file)%file_unit)
    files(file)%file_unit = -1
  END SUBROUTINE write_static
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="check_duplicate_output_fields">
  !   <OVERVIEW>
  !     Checks to see if <TT>output_name</TT> and <TT>output_file</TT> are unique in <TT>output_fields</TT>.
  !   </OVERVIEW>
  !   <TEMPLATE>
  !     SUBROUTINE check_duplicate_output_fields(err_msg)
  !   </TEMPLATE>
  !   <DESCRIPTION>
  !     Check to see if <TT>output_name</TT> and <TT>output_file</TT> are unique in <TT>output_fields</TT>.  An empty
  !     <TT>err_msg</TT> indicates no duplicates found.
  !   </DESCRIPTION>
  !   <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">Error message.  If empty, then no duplicates found.</OUT>
  SUBROUTINE check_duplicate_output_fields(err_msg)
    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg

    INTEGER :: i, j, tmp_file
    CHARACTER(len=128) :: tmp_name
    CHARACTER(len=256) :: err_msg_local

    IF ( PRESENT(err_msg) ) err_msg=''
    ! Do the checking when more than 1 output_fileds present
    IF ( num_output_fields <= 1 ) RETURN 
    err_msg_local = ''

    i_loop: DO i = 1, num_output_fields-1
       tmp_name = TRIM(output_fields(i)%output_name)
       tmp_file =  output_fields(i)%output_file
       DO j = i+1, num_output_fields
          IF ( (tmp_name == TRIM(output_fields(j)%output_name)) .AND. &
               &(tmp_file == output_fields(j)%output_file)) THEN
             err_msg_local = ' output_field "'//TRIM(tmp_name)//&
                  &'" duplicated in file "'//TRIM(files(tmp_file)%name)//'"'
             EXIT i_loop
          END IF
       END DO
    END DO i_loop
    IF ( err_msg_local /= '' ) THEN
       IF ( fms_error_handler(' ERROR in diag_table',err_msg_local,err_msg) ) RETURN
    END IF
  END SUBROUTINE check_duplicate_output_fields
  ! </SUBROUTINE>
END MODULE diag_util_mod


! nf95 -r8 -g -I ~/regression/ia64/23-Jun-2005/CM2.1U_Control-1990_E1.k32pe/include/ -D_TEST_CLOUD_INTERPOLATOR -D_F95 cloud_interpolator.F90

#include <fms_platform.h>

#define _FLATTEN(A) reshape((A), (/size((A))/) )

MODULE cloud_interpolator_mod
  implicit none
  private

  public :: cld_ntrp_linear_cell_interp, cld_ntrp_locate_cell, cld_ntrp_get_cell_values
#ifdef _TEST_CLOUD_INTERPOLATOR
  public :: cld_ntrp_expand_index, cld_ntrp_contract_indices
#endif

character(128), parameter :: version = '$Id: cloud_interpolator.F90,v 14.0 2007/03/15 22:38:35 fms Exp $'
real, parameter           :: tol = 10*epsilon(1.)

CONTAINS

!...............................................................................
  _PURE subroutine cld_ntrp_expand_index(Ic, ie, ier)
    integer, intent(in)  ::  Ic    ! contacted index
    integer, intent(out) ::  ie(:) ! expanded list of indices
    integer, intent(out) ::  ier   ! error flag (0=ok)

    integer j, nd

    ier =  0
    nd  = size(ie) ! dimension

    if(Ic >= 2**nd) then
       ie  = -1
       ier = 1 ! error
       return
    endif

    do j = 1, nd
       ie(j) = mod(Ic/2**(j-1), 2)
    end do
    
  end subroutine cld_ntrp_expand_index

!...............................................................................
!...............................................................................
  _PURE subroutine cld_ntrp_contract_indices(ie, Ic, ier)
    integer, intent(in) ::  ie(:)  ! expanded list of indices
    integer, intent(out)  ::  Ic   ! contacted index
    integer, intent(out) ::  ier   ! error flag (0=ok)

    integer j, nd    

    ier = 0
    nd  = size(ie) ! dimension

    Ic = ie(nd)
    do j = nd-1, 1, -1
       Ic = Ic * 2
       Ic = Ic + ie(j)
    end do

    if(Ic >= 2**nd) ier = 1

  end subroutine cld_ntrp_contract_indices

  
!...............................................................................
!...............................................................................
  _PURE subroutine cld_ntrp_linear_cell_interp(fvals, ts, f, ier)
    real, intent(in) :: fvals(0:)  ! values at the cell nodes
    real, intent(in) :: ts(:)      ! normalized [0,1]^nd cell coordinates
    real, intent(out):: f          ! interpolated value
    integer, intent(out) ::  ier   ! error flag (0=ok)
    
    integer j, nd, Ic, iflag
    integer ie(size(fvals))
    real    basis

    ier = 0
    f   = 0
    nd   = size(ts)
    if(size(fvals) /= 2**nd) then
       ier = 1
       return
    endif
    
    do Ic = 0, 2**nd - 1
       basis = 1
       call cld_ntrp_expand_index(Ic, ie, iflag)
       do j = 1, nd
          basis = basis * (  (1-ie(j))*(1.0-ts(j)) + ie(j)*ts(j) )
       end do
       f = f + fvals(Ic)*basis
    end do
    
  end subroutine cld_ntrp_linear_cell_interp

!...............................................................................
!...............................................................................
  _PURE subroutine cld_ntrp_locate_cell(axis, x, index, ier)
    real, intent(in)     :: axis(:) ! axis 
    real, intent(in)     :: x       ! abscissae
    integer, intent(out) :: index   ! lower-left corner index
    integer, intent(out) ::  ier    ! error flag (0=ok)

    logical down
    integer n, index1, is
    real axis_1, axis_n, axis_min, axis_max
    ier   = 0
    index = -1
    down = .FALSE.
    n = size(axis)
    if(n < 2) then
       ier = 3
       return
    endif
    axis_1 = axis(1)
    axis_n = axis(n)
    axis_min = axis_1
    axis_max = axis_n
    if(axis_1 > axis_n) then
       down = .TRUE.
       axis_min = axis_n
       axis_max = axis_1
    endif

    if(x < axis_min-tol) then
       ier = 1
       return
    endif
    if(x > axis_max+tol) then
       ier = 2
       return
    endif

    index = floor((n-1)*(x - axis_1)/(axis_n-axis_1)) + 1
    index  = min(n-1, index)
    index1 = index+1

    if(.NOT. down) then
       if(axis(index) <= x+tol) then
          if(x <= axis(index1)+tol) then
             ! axis is uniform, or nearly so. Done!
             return
          else
             ! increase index
             is = index+1
             do index = is, n-1
                index1 = index+1
                if(axis(index1) >= x-tol) return
             enddo
          endif
       else
          ! decrease index
          is = index - 1
          do index = is, 1, -1
             if(axis(index) <= x+tol) return
          enddo
       endif
    else
       ! axis is pointing down
       if(axis(index) >= x-tol) then
          if(x >= axis(index1)-tol) then
             ! axis is uniform, or nearly so. Done!
             return
          else
             ! increase index
             is = index + 1
             do index = is, n-1
                index1 = index+1
                if(axis(index1) <= x+tol) return
             enddo
          endif
       else
          ! decrease index
          is = index - 1
          do index = is, 1, -1
             if(axis(index) >= x-tol) return
          enddo
       endif
    endif    
    
  end subroutine cld_ntrp_locate_cell

!...............................................................................
!...............................................................................
  _PURE subroutine cld_ntrp_get_flat_index(nsizes, indices, flat_index, ier)
    integer, intent(in)  :: nsizes(:)  ! size of array along each axis
    integer, intent(in)  :: indices(:) ! cell indices
    integer, intent(out) :: flat_index ! index into flattened array
    integer, intent(out) ::  ier       ! error flag (0=ok)

    integer nd, id

    ier = 0
    flat_index = -1
    nd = size(nsizes)
    if(nd /= size(indices)) then
       ! size mismatch
       ier = 1
       return
    endif
    
    flat_index = indices(nd)-1
    do id = nd-1, 1, -1
       flat_index = flat_index*nsizes(id) + indices(id)-1
    enddo
    flat_index = flat_index + 1    
    
  end subroutine cld_ntrp_get_flat_index

!...............................................................................
!...............................................................................
  _PURE subroutine cld_ntrp_get_cell_values(nsizes, fnodes, indices, fvals, ier)
    integer, intent(in)  :: nsizes(:)  ! size of fnodes along each axis
    real, intent(in)     :: fnodes(:)  ! flattened array of node values
    integer, intent(in)  :: indices(:) ! cell indices
    real, intent(out)    :: fvals(0:)  ! returned array values in the cell
    integer, intent(out) ::  ier       ! error flag (0=ok)

    integer id, nt, nd, flat_index, Ic, iflag
    integer, dimension(size(nsizes)) :: cell_indices, node_indices
    ier = 0
    fvals = 0

    nd = size(nsizes)
    if(nd /= size(indices)) then
       ! size mismatch
       ier = 1
       return
    endif
    if(2**nd > size(fvals)) then
       ! not enough elements to hold result
       ier = 2
       return
    endif
    nt = 1
    do id = 1, nd
       nt = nt * nsizes(id)
    enddo
    if(nt /= size(fnodes)) then
       ! not enough node values
       ier = 3
       return
    endif

    do Ic = 0, 2**nd-1
       call cld_ntrp_expand_index(Ic, cell_indices, iflag)
       node_indices = indices + cell_indices
       call cld_ntrp_get_flat_index(nsizes, node_indices, flat_index, iflag)
       fvals(Ic) = fnodes(flat_index)
    enddo
    
  end subroutine cld_ntrp_get_cell_values

end MODULE cloud_interpolator_mod
!===============================================================================

#ifdef _TEST_CLOUD_INTERPOLATOR
program test
  use cloud_interpolator_mod
  implicit none

  call test_expansion_contraction
  call test_linear_cell_interpolation
  call test_cell_search
  call test_get_node_values

  contains
    subroutine test_expansion_contraction
      integer ie1(4), ie2(4), Ic, ier, idiff, j
      ie1 = (/1,0,1,1/)
      call cld_ntrp_contract_indices(ie1, Ic, ier)
      if(ier/=0) print *,'ERROR flag ier=', ier
      call cld_ntrp_expand_index(Ic, ie2, ier)
      if(ier/=0) print *,'ERROR flag ier=', ier
      idiff = 0
      do j = 1, size(ie1)
         idiff = idiff + abs(ie1(j)-ie2(j))
      end do
      if(idiff/=0) then
         print *,'ERROR: contraction/expansion test failed (ie1/=ie2)'
      endif
      print *,'ie1 = ', ie1
      print *,'ie2 = ', ie2
      print *,'Ic  = ', Ic
      
    end subroutine test_expansion_contraction

    subroutine test_linear_cell_interpolation
      integer, parameter :: nd = 3 
      real :: fvals(2**nd), ts(nd)
      real :: fi, fx
      integer ier
      ! f  = 1 + x + 2*y + 3*z
      fvals = (/ 1., 2., 3., 4., 4., 5., 6., 7. /)
      ts    = (/ 0.1, 0.2, 0.3 /)
      fx    = 1. + ts(1) + 2*ts(2) + 3*ts(3)
      call cld_ntrp_linear_cell_interp(fvals, ts, fi, ier)
      if(ier/=0) print *,'ERROR flag ier=', ier
      print *,'fi, fx = ', fi, fx
    end subroutine test_linear_cell_interpolation

    subroutine test_cell_search
      integer index, ier
      integer, parameter :: n = 5
      real :: axis1(n) = (/0., 0.1, 0.2, 0.3, 0.4/)
      real :: axis2(n) = (/0., 0.01, 0.02, 0.03, 0.4/)
      real :: axis3(n) = (/0.4, 0.3, 0.2, 0.1, 0./)
      real :: axis4(n) = (/0.4, 0.03, 0.02, 0.01, 0./)
      real x
      integer :: ier_tot = 0
      
      print *,'axis1=', axis1
      x = -0.0001
      call cld_ntrp_locate_cell(axis1, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))
      x = 0.
      call cld_ntrp_locate_cell(axis1, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 1
      ier_tot = ier_tot + abs(index - (1))
      x = 0.1
      call cld_ntrp_locate_cell(axis1, x, index, ier)
      print *, ' x=',x, ' index=', index, ' ==? ', 2
      ier_tot = ier_tot + abs(index - (2))
      x = 0.4
      call cld_ntrp_locate_cell(axis1, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 4
      ier_tot = ier_tot + abs(index - (4))
      x = 0.40001
      call cld_ntrp_locate_cell(axis1, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))

      print *,'axis2=', axis1
      x = -0.0001
      call cld_ntrp_locate_cell(axis2, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))
      x = 0.
      call cld_ntrp_locate_cell(axis2, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 1
      ier_tot = ier_tot + abs(index - (1))
      x = 0.1
      call cld_ntrp_locate_cell(axis2, x, index, ier)
      print *, ' x=',x, ' index=', index, ' ==? ', 4
      ier_tot = ier_tot + abs(index - (4))
      x = 0.4
      call cld_ntrp_locate_cell(axis2, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 4
      ier_tot = ier_tot + abs(index - (4))
      x = 0.40001
      call cld_ntrp_locate_cell(axis2, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))

      print *,'axis3=', axis1
      x = -0.0001
      call cld_ntrp_locate_cell(axis3, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))
      x = 0.
      call cld_ntrp_locate_cell(axis3, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 4
      ier_tot = ier_tot + abs(index - (4))
      x = 0.1
      call cld_ntrp_locate_cell(axis3, x, index, ier)
      print *, ' x=',x, ' index=', index, ' ==? ', 4
      ier_tot = ier_tot + abs(index - (4))
      x = 0.4
      call cld_ntrp_locate_cell(axis3, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 1
      ier_tot = ier_tot + abs(index - (1))
      x = 0.40001
      call cld_ntrp_locate_cell(axis3, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))

      print *,'axis4=', axis1
      x = -0.0001
      call cld_ntrp_locate_cell(axis4, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))
      x = 0.
      call cld_ntrp_locate_cell(axis4, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 4
      ier_tot = ier_tot + abs(index - (4))
      x = 0.1
      call cld_ntrp_locate_cell(axis4, x, index, ier)
      print *, ' x=',x, ' index=', index, ' ==? ', 1
      ier_tot = ier_tot + abs(index - (1))
      x = 0.4
      call cld_ntrp_locate_cell(axis4, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', 1
      ier_tot = ier_tot + abs(index - (1))
      x = 0.40001
      call cld_ntrp_locate_cell(axis4, x, index, ier)
      print *,' x=',x, ' index=', index, ' ==? ', -1
      ier_tot = ier_tot + abs(index - (-1))

      print *,'Total error in test_cell_search: ', ier_tot

    end subroutine test_cell_search

    subroutine test_get_node_values
      integer, parameter :: nd = 3, n1=6, n2=5, n3=4
      real, dimension(n1, n2, n3) :: fnodes
      real :: fvals(2**nd), fexact(2**nd)
      real x, y, z
      integer i, j, k, ier, indices(nd)
      real :: error_tot = 0.
      do k = 1, n3
         do j = 1, n2
            do i = 1, n1
               x = 1* real(i-1)/real(n1-1)
               y = 2* real(j-1)/real(n2-1)
               z = 3* real(k-1)/real(n3-1)
               fnodes(i,j,k) = x + y*z**2
            enddo
         enddo
      enddo

      indices = (/1,1,1/)
      call cld_ntrp_get_cell_values((/n1,n2,n3/), _FLATTEN(fnodes), indices, fvals, ier)
      fexact = (/0.0, 0.2, 0.0, 0.2, 0.0, 0.2, 0.5, 0.7/)
      if(ier/=0) print *,'ERROR flag ier=', ier
      print *,'indices ', indices
      print *,'fvals=', fvals, ' ==? ', fexact
      error_tot = error_tot + abs(sum(fvals - fexact))

      indices = (/5,4,2/)
      call cld_ntrp_get_cell_values((/n1,n2,n3/), _FLATTEN(fnodes), indices, fvals, ier)
      fexact = (/2.3, 2.5, 2.8, 3.0, 6.8, 7.0, 8.8, 9.0/)
      if(ier/=0) print *,'ERROR flag ier=', ier
      print *,'indices ', indices
      print *,'fvals=', fvals, ' ==? ', fexact
      error_tot = error_tot + abs(sum(fvals - fexact))

      print *,'Total error in test_get_node_values: ', error_tot


    end subroutine test_get_node_values

  end program test

#endif


!FDOC_TAG_GFDL fdoc.pl generated xml skeleton
! $Id: drifters.F90,v 17.0 2009/07/21 03:19:00 fms Exp $

#include <fms_platform.h>
#include "fms_switches.h"
#define _FLATTEN(A) reshape((A), (/size((A))/) )

module drifters_mod
! <CONTACT EMAIL="Alexander.Pletzer@noaa.gov">
!   Alexander Pletzer
! </CONTACT>
! <REVIEWER EMAIL="">
!   
! </REVIEWER>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
!   
! </OVERVIEW>
! <TT>Drifters_mod</TT>is a module designed to advect a set of particles, in parallel or 
! sequentially, given an prescribed velocity field. 
! 
! <DESCRIPTION>
! Drifters are idealized point particles with positions that evolve in time according
! to a prescribed velocity field, starting from some initial conditions. Drifters have
! no mass, no energy, no size, and no friction and therefore have no impact on the 
! dynamics of the underlying system. The only feature that distinguishes a drifter
! from another is its trajectory. This makes drifters ideal for tracking pollution
! clouds and probing fields (e.g. temperature, salinity) along ocean currents, to name 
! a few applications.
! Drifters can mimic real experiments such as the Argo floats 
! http://www.metoffice.com/research/ocean/argo/ukfloats.html.
!
! When run in parallel, on a 2d decomposed domain, <TT>drifters_mod</TT> will handle all the
! bookkeeping and communication transparently for the user. This involves adding/removing 
! drifters as they enter/leave a processor element (PE) domain. Note that the number of drifters 
! can vary greatly both between PE domains and within a PE domain in the course of a simulation; the drifters' 
! module will also manage dynamically the memory for the user.
! 
! There are a number of basic assumptions which could make the drifters' module 
! ill-suited for some tasks. First and foremost, it is assumed that the motion of 
! drifters is not erratic but follows deterministic trajectories. Furthermore, 
! drifters should not cross both compute and data domain boundaries within less 
! than a time step. This limitation is imposed by the Runge-Kutta integration 
! scheme, which must be able to complete, within a time step, a trajectory 
! calculation that starts inside the compute domain and ends inside the data domain. Therefore, the drifters, 
! as they are presently modelled, are unlikely to work for very fast objects. 
! This constraint also puts a upper limit to the domain decomposition, although
! it can often be remedied by increasing the number of ghost nodes.
! 
! Another fundamental assumption is that the (e.g. velocity) fields are structured, 
! on a per PE domain basis. There is no support for locally nested or unstrucured 
! meshes. Meshes need not be smooth and continuous across PE domains, however.    
! </DESCRIPTION>
!

! <INFO>

!   <REFERENCE>            </REFERENCE>
!   <COMPILER NAME="">     </COMPILER>
!   <PRECOMP FLAG="">      </PRECOMP>
!   <LOADER FLAG="">       </LOADER>
!   <TESTPROGRAM NAME="">  </TESTPROGRAM>
!   <BUG>                  </BUG>
!   <NOTE> 
!     See NOTE above.
!   </NOTE>
!   <FUTURE>               </FUTURE>

! </INFO>

#ifdef _SERIAL

! serial code
#define _MPP_PE 0
#define _MPP_ROOT 0
#define _MPP_NPES 1
#define _TYPE_DOMAIN2D integer

#else

! parallel code
  use mpp_mod        , only : mpp_pe, mpp_npes
  use mpp_domains_mod, only : domain2d
#define _MPP_PE mpp_pe()
#define _MPP_ROOT mpp_root_pe()
#define _MPP_NPES mpp_npes()
#define _TYPE_DOMAIN2D type(domain2d)

#endif

  use drifters_core_mod,  only: drifters_core_type, drifters_core_new, drifters_core_del, assignment(=)

  use drifters_input_mod, only: drifters_input_type, drifters_input_new, drifters_input_del, assignment(=)

  use drifters_io_mod,    only: drifters_io_type, drifters_io_new, drifters_io_del, drifters_io_set_time_units, &
                                drifters_io_set_position_names, drifters_io_set_position_units, &
                                drifters_io_set_field_names, drifters_io_set_field_units, drifters_io_write

  use drifters_comm_mod,  only: drifters_comm_type, drifters_comm_new, drifters_comm_del, drifters_comm_set_pe_neighbors, &
                                drifters_comm_set_domain, drifters_comm_gather, drifters_comm_update

  use cloud_interpolator_mod, only: cld_ntrp_linear_cell_interp, cld_ntrp_locate_cell, cld_ntrp_get_cell_values

  implicit none
  private  

  public :: drifters_type, assignment(=), drifters_push, drifters_compute_k, drifters_set_field
  public :: drifters_new, drifters_del, drifters_set_domain, drifters_set_pe_neighbors
  public :: drifters_set_v_axes, drifters_set_domain_bounds, drifters_positions2lonlat
  public :: drifters_print_checksums, drifters_save, drifters_write_restart, drifters_distribute

  integer, parameter, private :: MAX_STR_LEN = 128
  character(len=MAX_STR_LEN), parameter, private :: version = '$Id: drifters.F90,v 17.0 2009/07/21 03:19:00 fms Exp $'
  real :: DRFT_EMPTY_ARRAY(0)

  type drifters_type
     ! Be sure to update drifters_new, drifters_del and drifters_copy_new
     ! when adding members
     type(drifters_core_type)  :: core
     type(drifters_input_type) :: input
     type(drifters_io_type)    :: io
     type(drifters_comm_type)  :: comm
     real    :: dt             ! total dt, over a complete step
     real    :: time
     ! fields
     real, _ALLOCATABLE :: fields(:,:) _NULL
     ! velocity field axes
     real, _ALLOCATABLE :: xu(:) _NULL
     real, _ALLOCATABLE :: yu(:) _NULL
     real, _ALLOCATABLE :: zu(:) _NULL
     real, _ALLOCATABLE :: xv(:) _NULL
     real, _ALLOCATABLE :: yv(:) _NULL
     real, _ALLOCATABLE :: zv(:) _NULL
     real, _ALLOCATABLE :: xw(:) _NULL
     real, _ALLOCATABLE :: yw(:) _NULL
     real, _ALLOCATABLE :: zw(:) _NULL
     ! Runge Kutta coefficients holding intermediate results (positions)
     real, _ALLOCATABLE :: temp_pos(:,:) _NULL
     real, _ALLOCATABLE :: rk4_k1(:,:) _NULL
     real, _ALLOCATABLE :: rk4_k2(:,:) _NULL
     real, _ALLOCATABLE :: rk4_k3(:,:) _NULL
     real, _ALLOCATABLE :: rk4_k4(:,:) _NULL
     ! store filenames for convenience
     character(len=MAX_STR_LEN) :: input_file, output_file
     ! Runge Kutta stuff
     integer :: rk4_step
     logical :: rk4_completed
     integer :: nx, ny
     logical, _ALLOCATABLE   :: remove(:) _NULL
  end type drifters_type

  interface assignment(=)
     module procedure drifters_copy_new
  end interface

  interface drifters_push
    module procedure drifters_push_2
    module procedure drifters_push_3
  end interface

  interface drifters_compute_k
     module procedure drifters_computek2d
     module procedure drifters_computek3d
  end interface

  interface drifters_set_field
    module procedure drifters_set_field_2d
    module procedure drifters_set_field_3d
  end interface

  

contains

  !============================================================================
! <SUBROUTINE NAME="drifters_new">
!  <OVERVIEW>
!  Constructor. 
!  </OVERVIEW>
!  <DESCRIPTION>
! Will read positions stored in the netCDF file <TT>input_file</TT>.
! The trajectories will be saved in files <TT>output_file.PE</TT>, 
! one file per PE domain.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_new(self, input_file, output_file, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   Opaque data structure.
!  </INOUT>
!  <IN NAME="input_file" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!     NetCDF input file name containing initial positions.
!  </IN>
!  <IN NAME="output_file" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!     NetCDF output file. Will contain trajectory positions and interpolated fields.
!  </IN>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!     Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_new(self, input_file, output_file, ermesg)

    type(drifters_type) :: self
    character(len=*), intent(in)  :: input_file
    character(len=*), intent(in)  :: output_file
    character(len=*), intent(out) :: ermesg
    
    integer nd, nf, npdim, i
    character(len=6) :: pe_str

    ermesg = ''

    self%input_file  = input_file
    self%output_file = output_file

    call drifters_input_new(self%input, input_file, ermesg)
    if(ermesg/='') return

    ! number of dimensions
    nd = size(self%input%velocity_names)
    ! estimate for the max number of particles (will resize if exceeded)
    npdim = int(1.3*size(self%input%positions, 2))
    call drifters_core_new(self%core, nd=nd, npdim=npdim, ermesg=ermesg)
    if(ermesg/='') return

    ! number of fields
    nf = size(self%input%field_names)

    ! one output file per PE
    pe_str = '    '
    write(pe_str, '(i6)') _MPP_PE
    pe_str = adjustr(pe_str)
    do i = 1, 4
       if(pe_str(i:i)==' ') pe_str(i:i)='0'
    enddo
    call drifters_io_new(self%io, output_file//'.'//pe_str, nd, nf, ermesg)
    if(ermesg/='') return

    call drifters_comm_new(self%comm)
    if(ermesg/='') return

    ! Set meta data
    call drifters_io_set_time_units(self%io, name=self%input%time_units, &
         & ermesg=ermesg)

    call drifters_io_set_position_names(self%io, names=self%input%position_names, &
         & ermesg=ermesg)
    if(ermesg/='') return
    call drifters_io_set_position_units(self%io, names=self%input%position_units, &
         & ermesg=ermesg)
    if(ermesg/='') return

    call drifters_io_set_field_names(self%io, names=self%input%field_names, &
         & ermesg=ermesg)
    if(ermesg/='') return
    call drifters_io_set_field_units(self%io, names=self%input%field_units, &
         & ermesg=ermesg)
    if(ermesg/='') return    

    self%dt   = -1
    self%time = -1
    self%rk4_step = 0
    self%nx       = 0
    self%ny       = 0
    self%rk4_completed = .FALSE.

    allocate(self%rk4_k1(self%core%nd, self%core%npdim))
    self%rk4_k1 = -huge(1.)
    allocate(self%rk4_k2(self%core%nd, self%core%npdim))
    self%rk4_k2 = -huge(1.)
    allocate(self%rk4_k3(self%core%nd, self%core%npdim))
    self%rk4_k3 = -huge(1.)
    allocate(self%rk4_k4(self%core%nd, self%core%npdim))
    self%rk4_k4 = -huge(1.)
    allocate(self%remove(self%core%npdim))
    self%remove = .FALSE.
    allocate(self%temp_pos(nd, self%core%npdim))
    self%temp_pos = -huge(1.)

    allocate(self%fields(nf, self%core%npdim))
    self%fields = -huge(1.)

  end subroutine drifters_new

  !============================================================================
! <SUBROUTINE NAME="drifters_del">
!  <OVERVIEW>
!   Destructor.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Call this to reclaim memory.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_del(self, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   Opaque data structure.
!  </INOUT>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!   Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_del(self, ermesg)
    type(drifters_type) :: self
    character(len=*), intent(out) :: ermesg
    
    integer flag
    ermesg = ''
    deallocate(self%fields, stat=flag)
    deallocate(self%xu, stat=flag)
    deallocate(self%yu, stat=flag)
    deallocate(self%zu, stat=flag)
    deallocate(self%xv, stat=flag)
    deallocate(self%yv, stat=flag)
    deallocate(self%zv, stat=flag)
    deallocate(self%xw, stat=flag)
    deallocate(self%yw, stat=flag)
    deallocate(self%zw, stat=flag)
    deallocate(self%temp_pos, stat=flag)
    deallocate(self%rk4_k1, stat=flag)
    deallocate(self%rk4_k2, stat=flag)
    deallocate(self%rk4_k3, stat=flag)
    deallocate(self%rk4_k4, stat=flag)
    deallocate(self%remove, stat=flag)
    
    call drifters_core_del(self%core, ermesg)
    if(ermesg/='') return
    call drifters_input_del(self%input, ermesg)
    if(ermesg/='') return
    call drifters_io_del(self%io, ermesg)
    if(ermesg/='') return
    call drifters_comm_del(self%comm)
    if(ermesg/='') return

  end subroutine drifters_del

  !============================================================================
! <SUBROUTINE NAME="drifters_copy_new">
!  <OVERVIEW>
!   Copy constructor.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Copy a drifter state into a new state. Note: this will not open new files; this will
!   copy all members into a new container.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_copy_new(new_instance, old_instance)
!		
!  </TEMPLATE>
!  <INOUT NAME="new_instance" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   New data structure.
!  </INOUT>
!  <IN NAME="old_instance" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   Old data structure.
!  </IN>
! </SUBROUTINE>
!
  !============================================================================
  subroutine drifters_copy_new(new_instance, old_instance)

    type(drifters_type), intent(in)    :: old_instance
    type(drifters_type), intent(inout) :: new_instance

    character(len=MAX_STR_LEN) :: ermesg

    ermesg = ''

    ! make sure new_instance is empty
    call drifters_del(new_instance, ermesg)
    if(ermesg/='') return

    new_instance%core  = old_instance%core
    new_instance%input = old_instance%input
    new_instance%io    = old_instance%io
    new_instance%comm  = old_instance%comm

     new_instance%dt     = old_instance%dt
     new_instance%time   = old_instance%time

     allocate(new_instance%fields( size(old_instance%fields, 1), &
          &                        size(old_instance%fields, 2) ))
     new_instance%fields = old_instance%fields

     allocate(new_instance%xu( size(old_instance%xu) ))
     allocate(new_instance%yu( size(old_instance%yu) ))
     allocate(new_instance%zu( size(old_instance%zu) ))
     new_instance%xu = old_instance%xu
     new_instance%yu = old_instance%yu
     new_instance%zu = old_instance%zu
     allocate(new_instance%xv( size(old_instance%xv) ))
     allocate(new_instance%yv( size(old_instance%yv) ))
     allocate(new_instance%zv( size(old_instance%zv) ))
     new_instance%xv = old_instance%xv
     new_instance%yv = old_instance%yv
     new_instance%zv = old_instance%zv
     allocate(new_instance%xw( size(old_instance%xw) ))
     allocate(new_instance%yw( size(old_instance%yw) ))
     allocate(new_instance%zw( size(old_instance%zw) ))
     new_instance%xw = old_instance%xw
     new_instance%yw = old_instance%yw
     new_instance%zw = old_instance%zw

     allocate(new_instance%temp_pos( size(old_instance%temp_pos,1), &
          &                          size(old_instance%temp_pos,2) ))
     new_instance%temp_pos = old_instance%temp_pos
     allocate(new_instance%rk4_k1( size(old_instance%rk4_k1,1), &
          &                        size(old_instance%rk4_k1,2) ))
     allocate(new_instance%rk4_k2( size(old_instance%rk4_k2,1), &
          &                        size(old_instance%rk4_k2,2) ))
     allocate(new_instance%rk4_k3( size(old_instance%rk4_k3,1), &
          &                        size(old_instance%rk4_k3,2) ))
     allocate(new_instance%rk4_k4( size(old_instance%rk4_k4,1), &
          &                        size(old_instance%rk4_k4,2) ))
     new_instance%rk4_k1 = old_instance%rk4_k1
     new_instance%rk4_k2 = old_instance%rk4_k2 
     new_instance%rk4_k3 = old_instance%rk4_k3
     new_instance%rk4_k4 = old_instance%rk4_k4

     new_instance%rk4_step = old_instance%rk4_step
     new_instance%rk4_completed = old_instance%rk4_completed
     new_instance%nx = old_instance%nx
     new_instance%ny = old_instance%ny

     allocate(new_instance%remove(size(old_instance%remove)))
     new_instance%remove = old_instance%remove


  end subroutine drifters_copy_new

  !============================================================================
! <SUBROUTINE NAME="drifters_set_domain">
!  <OVERVIEW>
!   Set the compute, data, and global domain boundaries. 
!  </OVERVIEW>
!  <DESCRIPTION>
!   The data domain extends beyond the compute domain and is shared between 
!   two or more PE domains. A particle crossing the compute domain boundary 
!   will trigger a communication with one or more neighboring domains. A particle 
!   leaving the data domain will be removed from the list of particles.   
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_set_domain(self, &
!		& xmin_comp, xmax_comp, ymin_comp, ymax_comp, &
!		& xmin_data, xmax_data, ymin_data, ymax_data, &
!		& xmin_glob, xmax_glob, ymin_glob, ymax_glob, &
!		& ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   Opaque data structure.
!  </INOUT>
!  <IN NAME="xmin_comp" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Min of longitude-like axis on compute domain.
!  </IN>
!  <IN NAME="xmax_comp" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Max of longitude-like axis on compute domain.
!  </IN>
!  <IN NAME="ymin_comp" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Min of latitude-like axis on compute domain.
!  </IN>
!  <IN NAME="ymax_comp" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Max of latitude-like axis on compute domain.
!  </IN>
!  <IN NAME="xmin_data" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Min of longitude-like axis on data domain.
!  </IN>
!  <IN NAME="xmax_data" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Max of longitude-like axis on data domain.
!  </IN>
!  <IN NAME="ymin_data" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Min of latitude-like axis on data domain.
!  </IN>
!  <IN NAME="ymax_data" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Max of latitude-like axis on data domain.
!  </IN>
!  <IN NAME="xmin_glob" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Min of longitude-like axis on global domain.
!  </IN>
!  <IN NAME="xmax_glob" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Max of longitude-like axis on global domain.
!  </IN>
!  <IN NAME="ymin_glob" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Min of latitude-like axis on global domain.
!  </IN>
!  <IN NAME="ymax_glob" TYPE="real" DIM="SCALAR" UNITS="" DEFAULT="">
!   Max of latitude-like axis on global domain.
!  </IN>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!   Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_set_domain(self, &
       & xmin_comp, xmax_comp, ymin_comp, ymax_comp, &
       & xmin_data, xmax_data, ymin_data, ymax_data, &
       & xmin_glob, xmax_glob, ymin_glob, ymax_glob, &
       & ermesg)
    type(drifters_type) :: self
    ! compute domain boundaries
    real, optional, intent(in) :: xmin_comp, xmax_comp, ymin_comp, ymax_comp
    ! data domain boundaries
    real, optional, intent(in) :: xmin_data, xmax_data, ymin_data, ymax_data
    ! global boundaries (only specify those if domain is periodic)
    real, optional, intent(in) :: xmin_glob, xmax_glob, ymin_glob, ymax_glob    
    character(len=*), intent(out) :: ermesg

    ermesg = ''
    if(present(xmin_comp)) self%comm%xcmin = xmin_comp
    if(present(xmax_comp)) self%comm%xcmax = xmax_comp
    if(present(ymin_comp)) self%comm%ycmin = ymin_comp
    if(present(ymax_comp)) self%comm%ycmax = ymax_comp

    if(present(xmin_data)) self%comm%xdmin = xmin_data
    if(present(xmax_data)) self%comm%xdmax = xmax_data
    if(present(ymin_data)) self%comm%ydmin = ymin_data
    if(present(ymax_data)) self%comm%ydmax = ymax_data

    if(present(xmin_glob)) self%comm%xgmin = xmin_glob
    if(present(xmax_glob)) self%comm%xgmax = xmax_glob
    if(present(ymin_glob)) self%comm%ygmin = ymin_glob
    if(present(ymax_glob)) self%comm%ygmax = ymax_glob

    ! Note: the presence of both xgmin/xgmax will automatically set the 
    ! periodicity flag
    if(present(xmin_glob) .and. present(xmax_glob)) self%comm%xperiodic = .TRUE.
    if(present(ymin_glob) .and. present(ymax_glob)) self%comm%yperiodic = .TRUE.    

  end subroutine drifters_set_domain

  !============================================================================
! <SUBROUTINE NAME="drifters_set_pe_neighbors">
!  <OVERVIEW>
!   Given an MPP based deomposition, set the PE numbers that are adjacent to this
!   processor.
!  </OVERVIEW>
!  <DESCRIPTION>
!   This will allow several PEs to track the trajectories of particles in the 
!   buffer regions. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_set_pe_neighbors(self, domain, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   Opaque data structure.
!  </INOUT>
!  <INOUT NAME="domain" TYPE="" DIM="SCALAR" UNITS="" DEFAULT="">
!   MPP domain.
!  </INOUT>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!   Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_set_pe_neighbors(self, domain, ermesg)

    type(drifters_type) :: self
    _TYPE_DOMAIN2D      :: domain
    character(len=*), intent(out) :: ermesg

    ermesg = ''
    
    call drifters_comm_set_pe_neighbors(self%comm, domain)

  end subroutine drifters_set_pe_neighbors

  !============================================================================
#define _DIMS 2
#define drifters_push_XXX drifters_push_2
#include "drifters_push.h"
#undef _DIMS
#undef drifters_push_XXX

  !============================================================================
#define _DIMS 3
#define drifters_push_XXX drifters_push_3
#include "drifters_push.h"
#undef _DIMS
#undef drifters_push_XXX

  !============================================================================
  subroutine drifters_modulo(self, positions, ermesg)
    type(drifters_type) :: self
    real, intent(inout) :: positions(:,:)
    character(len=*), intent(out) :: ermesg

    integer ip, np
    real x, y

    ermesg = ''
    np = self%core%np

    if(self%comm%xperiodic) then
       do ip = 1, np
          x = positions(1, ip)
          positions(1, ip) = self%comm%xgmin + &
               & modulo(x - self%comm%xgmin, self%comm%xgmax-self%comm%xgmin)
       enddo
    endif

    if(self%comm%yperiodic) then
       do ip = 1, np
          y = positions(2, ip)
          positions(2, ip) = self%comm%ygmin + &
               & modulo(y - self%comm%ygmin, self%comm%ygmax-self%comm%ygmin)
       enddo
    endif

  end subroutine drifters_modulo
    
  !============================================================================
#define _DIMS 2
#define drifters_set_field_XXX drifters_set_field_2d
#include "drifters_set_field.h"
#undef _DIMS
#undef drifters_set_field_XXX

  !============================================================================
#define _DIMS 3
#define drifters_set_field_XXX drifters_set_field_3d
#include "drifters_set_field.h"
#undef _DIMS
#undef drifters_set_field_XXX
  !============================================================================
! <SUBROUTINE NAME="drifters_save">
!  <OVERVIEW>
!   Append new positions to NetCDF file.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Use this method to append the new trajectory positions and the interpolated
!   probe fields to a netCDF file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_save(self, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!   Opaque daata structure.
!  </INOUT>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!   Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_save(self, ermesg)
    type(drifters_type) :: self
    character(len=*), intent(out) :: ermesg

    integer nf, np

    ermesg = ''
    nf = size(self%input%field_names)
    np = self%core%np

    ! save to disk
    call drifters_io_write(self%io, self%time, np, self%core%nd, nf, &
         & self%core%ids, self%core%positions, &
         & fields=self%fields(:,1:np), ermesg=ermesg)

  end subroutine drifters_save
  !============================================================================
! <SUBROUTINE NAME="drifters_distribute">
!  <OVERVIEW>
!   Distribute particles across PEs.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Use this method after setting the domain boundaries 
!   (<TT>drifters_set_domain</TT>) to spread the particles across PE
!   domains.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_distribute(self, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!    Opaque handle.
!  </INOUT>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!    Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_distribute(self, ermesg)
    type(drifters_type) :: self
    character(len=*), intent(out) :: ermesg

    real x, y
    integer i, nptot, nd

    ermesg = ''
    nd = self%core%nd
    if(nd < 2) then
       ermesg = 'drifters_distribute: dimension must be >=2'
       return
    endif

    nptot = size(self%input%positions, 2)
    do i = 1, nptot
       x = self%input%positions(1,i)
       y = self%input%positions(2,i)
       if(x >= self%comm%xdmin .and. x <= self%comm%xdmax .and. &
        & y >= self%comm%ydmin .and. y <= self%comm%ydmax) then

          self%core%np = self%core%np + 1
          self%core%positions(1:nd, self%core%np) = self%input%positions(1:nd, i)
          self%core%ids(self%core%np)             = i

       endif
    enddo

  end subroutine drifters_distribute

  !============================================================================
! <SUBROUTINE NAME="drifters_write_restart">
!  <OVERVIEW>
!   Write restart file.
!  </OVERVIEW>
!  <DESCRIPTION>
!   Gather all the particle positions distributed across PE domains on root PE 
!   and save the data in netCDF file.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_write_restart(self, filename, &
!		& x1, y1, geolon1, &
!		& x2, y2, geolat2, &
!		& root, mycomm, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!    Opaque data structure.
!  </INOUT>
!  <IN NAME="filename" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!    Restart file name.
!  </IN>
!  <IN NAME="x1" TYPE="real" DIM="" UNITS="" DEFAULT="">
!    Pseudo-longitude axis supporting longitudes.
!  </IN>
!  <INOUT NAME="y1" TYPE="" DIM="" UNITS="" DEFAULT="">
!    Pseudo-latitude axis supporting longitudes.
!  </INOUT>
!  <INOUT NAME="geolon1" TYPE="" DIM="" UNITS="" DEFAULT="">
!    Longitude array (x1, y1).
!  </INOUT>
!  <IN NAME="x2" TYPE="real" DIM="" UNITS="" DEFAULT="">
!    Pseudo-longitude axis supporting latitudes.
!  </IN>
!  <INOUT NAME="y2" TYPE="" DIM="" UNITS="" DEFAULT="">
!   Pseudo-latitude axis supporting latitudes.
!  </INOUT>
!  <INOUT NAME="geolat2" TYPE="" DIM="" UNITS="" DEFAULT="">
!   Latitudes array (x2, y2)
!  </INOUT>
!  <IN NAME="root" TYPE="integer" DIM="SCALAR" UNITS="" DEFAULT="">
!   Root PE.
!  </IN>
!  <IN NAME="mycomm" TYPE="integer" DIM="SCALAR" UNITS="" DEFAULT="">
!   MPI communicator.
!  </IN>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!   Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_write_restart(self, filename, &
       & x1, y1, geolon1, &
       & x2, y2, geolat2, &
       & root, mycomm, ermesg)
    ! gather all positions and ids and save the result in 
    ! self%input data structure on PE "root", then write restart file

    type(drifters_type) :: self
    character(len=*), intent(in)  :: filename

    ! if these optional arguments are passed, the positions will 
    ! mapped to lon/lat degrees and saved in the file.
    real, intent(in), optional    :: x1(:), y1(:), geolon1(:,:)
    real, intent(in), optional    :: x2(:), y2(:), geolat2(:,:) 
  
    integer, intent(in), optional :: root    ! root pe
    integer, intent(in), optional :: mycomm  ! MPI communicator
    character(len=*), intent(out) :: ermesg

    integer :: np
    logical :: do_save_lonlat
    real, allocatable    ::  lons(:), lats(:)

    ermesg = ''

    np = self%core%np
    
    allocate(lons(np), lats(np))
    lons = -huge(1.)
    lats = -huge(1.)

    ! get lon/lat if asking for
    if(present(x1) .and. present(y1) .and. present(geolon1) .and. &
         & present(x2) .and. present(y2) .and. present(geolat2)) then
       do_save_lonlat = .TRUE.
    else
       do_save_lonlat = .FALSE.
    endif

    if(do_save_lonlat) then

       ! Interpolate positions onto geo longitudes/latitudes
       call drifters_positions2lonlat(self,   &
            & positions=self%core%positions(:,1:np), &
            & x1=x1, y1=y1, geolon1=geolon1,         &
            & x2=x2, y2=y2, geolat2=geolat2,         &
            & lons=lons, lats=lats, ermesg=ermesg)
       if(ermesg/='') return ! problems, bail off

    endif

    call drifters_comm_gather(self%comm, self%core, self%input, &
         & lons, lats, do_save_lonlat, &
         & filename, &
         & root, mycomm)
     
  end subroutine drifters_write_restart

  !============================================================================
#define _DIMS 2
#define drifters_compute_k_XXX drifters_computek2d
#include "drifters_compute_k.h"
#undef _DIMS
#undef drifters_compute_k_XXX

   !============================================================================
#define _DIMS 3
#define drifters_compute_k_XXX drifters_computek3d
#include "drifters_compute_k.h"
#undef _DIMS
#undef drifters_compute_k_XXX


 !============================================================================
! <SUBROUTINE NAME="drifters_set_v_axes">
!  <OVERVIEW>
!   Set velocity field axes.
!  </OVERVIEW>
!  <DESCRIPTION>
!  Velocity axis components may be located on different grids or cell faces. For instance, zonal (u)
!  and meridional (v) velcity components are staggered by half a cell size in Arakawa's C and D grids.
!  This call will set individual axes for each components do as to allow interpolation of the velocity
!  field on arbitrary positions.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_set_v_axes(self, component, x, y, z, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!  Opaque data structure.
!  </INOUT>
!  <IN NAME="component" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!  Velocity component: either 'u', 'v', or 'w'.
!  </IN>
!  <IN NAME="x" TYPE="real" DIM="" UNITS="" DEFAULT="">
!  X-axis.
!  </IN>
!  <INOUT NAME="y" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Y-axis.
!  </INOUT>
!  <INOUT NAME="z" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Z-axis.
!  </INOUT>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!  Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_set_v_axes(self, component, x, y, z, ermesg)
    type(drifters_type) :: self
    character(len=*), intent(in)  :: component
    real, intent(in)              :: x(:), y(:), z(:)
    character(len=*), intent(out) :: ermesg

    integer ier, nx, ny, nz
    
    ermesg = ''
    nx = size(x)
    ny = size(y)
    nz = size(z)
    select case (component(1:1))
       case ('u', 'U')
          if(nx > 0) then
             deallocate(self%xu, stat=ier)
             allocate(self%xu(nx))
             self%xu = x
             self%nx = max(self%nx, size(x))
          endif
          if(ny > 0) then
             deallocate(self%yu, stat=ier)
             allocate(self%yu(ny))
             self%yu = y
             self%ny = max(self%ny, size(y))
          endif
          if(nz > 0) then
             deallocate(self%zu, stat=ier)
             allocate(self%zu(nz))
             self%zu = z
          endif
      case ('v', 'V')
          if(nx > 0) then
             deallocate(self%xv, stat=ier)
             allocate(self%xv(nx))
             self%xv = x
             self%nx = max(self%nx, size(x))
          endif
          if(ny > 0) then
             deallocate(self%yv, stat=ier)
             allocate(self%yv(ny))
             self%yv = y
             self%ny = max(self%ny, size(y))
          endif
          if(nz > 0) then
             deallocate(self%zv, stat=ier)
             allocate(self%zv(nz))
             self%zv = z
          endif
      case ('w', 'W')
          if(nx > 0) then
             deallocate(self%xw, stat=ier)
             allocate(self%xw(nx))
             self%xw = x
             self%nx = max(self%nx, size(x))
          endif
          if(ny > 0) then
             deallocate(self%yw, stat=ier)
             allocate(self%yw(ny))
             self%yw = y
             self%ny = max(self%ny, size(y))
          endif
          if(nz > 0) then
             deallocate(self%zw, stat=ier)
             allocate(self%zw(nz))
             self%zw = z
          endif
      case default
         ermesg = 'drifters_set_v_axes: ERROR component must be "u", "v" or "w"'        
    end select
  end subroutine drifters_set_v_axes

  !============================================================================
! <SUBROUTINE NAME="drifters_set_domain_bounds">
!  <OVERVIEW>
!  Set boundaries of "data" and "compute" domains
!  </OVERVIEW>
!  <DESCRIPTION>
!  Each particle will be tracked sol long is it is located in the data domain. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_set_domain_bounds(self, domain, backoff_x, backoff_y, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!  Opaque data structure.
!  </INOUT>
!  <INOUT NAME="domain" TYPE="" DIM="SCALAR" UNITS="" DEFAULT="">
!  Instance of Domain2D (see mpp_domain)
!  </INOUT>
!  <IN NAME="backoff_x" TYPE="integer" DIM="SCALAR" UNITS="" DEFAULT="">
!  Data domain is reduced (if backoff_x > 0) by backoff_x nodes at east and west boundaries.
!  </IN>
!  <IN NAME="backoff_y" TYPE="integer" DIM="SCALAR" UNITS="" DEFAULT="">
!  Data domain is reduced (if backoff_y > 0) by backoff_y nodes at north and south boundaries.
!  </IN>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!  Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_set_domain_bounds(self, domain, backoff_x, backoff_y, ermesg)
    type(drifters_type) :: self
    _TYPE_DOMAIN2D      :: domain
    integer, intent(in) ::  backoff_x ! particles leaves domain when crossing ied-backoff_x
    integer, intent(in) ::  backoff_y ! particles leaves domain when crossing jed-backoff_y
    character(len=*), intent(out) :: ermesg
    
    ermesg = ''

    if(.not._ALLOCATED(self%xu) .or. .not._ALLOCATED(self%yu)) then
       ermesg = 'drifters_set_domain_bounds: ERROR "u"-component axes not set'
       return
    endif
    call drifters_comm_set_domain(self%comm, domain, self%xu, self%yu, backoff_x, backoff_y)
    if(.not._ALLOCATED(self%xv) .or. .not._ALLOCATED(self%yv)) then
       ermesg = 'drifters_set_domain_bounds: ERROR "v"-component axes not set'
       return
    endif
    if(_ALLOCATED(self%xw) .and. _ALLOCATED(self%yw)) then
       call drifters_comm_set_domain(self%comm, domain, self%xv, self%yv, backoff_x, backoff_y)
    endif

    
  end subroutine drifters_set_domain_bounds

  !============================================================================
! <SUBROUTINE NAME="drifters_positions2lonlat">
!  <OVERVIEW>
!  Interpolates positions onto longitude/latitude grid.
!  </OVERVIEW>
!  <DESCRIPTION>
!  In many cases, the integrated positions will not be longitudes  or latitudes. This call
!  can be ionvoked to recover the longitude/latitude positions from the "logical" positions.
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_positions2lonlat(self, positions, &
!		&                                        x1, y1, geolon1, &
!		&                                        x2, y2, geolat2, &
!		&                                        lons, lats, &
!		&                                        ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!  Opaque data structure.
!  </INOUT>
!  <IN NAME="positions" TYPE="real" DIM="" UNITS="" DEFAULT="">
!  Logical positions.
!  </IN>
!  <IN NAME="x1" TYPE="real" DIM="" UNITS="" DEFAULT="">
!  X-axis of "geolon1" field.
!  </IN>
!  <INOUT NAME="y1" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Y-axis of "geolon1" field.
!  </INOUT>
!  <INOUT NAME="geolon1" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Longitude field as an array of (x1, y1).
!  </INOUT>
!  <IN NAME="x2" TYPE="real" DIM="" UNITS="" DEFAULT="">
!  X-axis of "geolat2" field.
!  </IN>
!  <INOUT NAME="y2" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Y-axis of "geolat2" field.
!  </INOUT>
!  <INOUT NAME="geolat2" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Latitude field as an array of (x2, y2)
!  </INOUT>
!  <OUT NAME="lons" TYPE="real" DIM="" UNITS="" DEFAULT="">
!  Returned longitudes.
!  </OUT>
!  <INOUT NAME="lats" TYPE="" DIM="" UNITS="" DEFAULT="">
!  Returned latitudes.
!  </INOUT>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!  Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_positions2lonlat(self, positions, &
       &                                        x1, y1, geolon1, &
       &                                        x2, y2, geolat2, &
       &                                        lons, lats, &
       &                                        ermesg)

    type(drifters_type) :: self
    ! Input positions
    real, intent(in)    :: positions(:,:)
    ! Input mesh
    real, intent(in)    :: x1(:), y1(:), geolon1(:,:) ! geolon1(x1, y1)
    real, intent(in)    :: x2(:), y2(:), geolat2(:,:) ! geolat2(x2, y2)
    ! Output lon/lat 
    real, intent(out)   :: lons(:), lats(:)
    character(len=*), intent(out) :: ermesg

    real    fvals(2**self%core%nd), ts(self%core%nd)
    integer np, ij(2), ip, ier, n1s(2), n2s(2), i, j, iertot
    character(len=10) :: n1_str, n2_str, np_str, iertot_str

    ermesg = ''
    lons = -huge(1.)
    lats = -huge(1.)

    ! check dimensions
    n1s = (/size(x1), size(y1)/)
    n2s = (/size(x2), size(y2)/)
    if(n1s(1) /= size(geolon1, 1) .or. n1s(2) /= size(geolon1, 2)) then
       ermesg = 'drifters_positions2geolonlat: ERROR incompatibles dims between (x1, y1, geolon1)'
       return
    endif
    if(n2s(1) /= size(geolat2, 1) .or. n2s(2) /= size(geolat2, 2)) then
       ermesg = 'drifters_positions2geolonlat: ERROR incompatibles dims between (x2, y2, geolat2)'
       return
    endif

    np = size(positions, 2)
    if(size(lons) < np .or. size(lats) < np) then
       write(np_str, '(i10)') np
       write(n1_str, '(i10)') size(lons)
       write(n2_str, '(i10)') size(lats)
       ermesg = 'drifters_positions2geolonlat: ERROR size of "lons" ('//trim(n1_str)// &
            & ') or "lats" ('//trim(n2_str)//') < '//trim(np_str)
       return
    endif

    ! Interpolate
    iertot = 0
    do ip = 1, np

       ! get longitude
       call cld_ntrp_locate_cell(x1, positions(1,ip), i, ier)
       iertot = iertot + ier
       call cld_ntrp_locate_cell(y1, positions(2,ip), j, ier)
       iertot = iertot + ier
       ij(1) = i; ij(2) = j;
       call cld_ntrp_get_cell_values(n1s, _FLATTEN(geolon1), ij, fvals, ier)
       iertot = iertot + ier
       ts(1) = (positions(1,ip) - x1(i))/(x1(i+1) - x1(i))
       ts(2) = (positions(2,ip) - y1(j))/(y1(j+1) - y1(j))
       call cld_ntrp_linear_cell_interp(fvals, ts, lons(ip), ier)
       iertot = iertot + ier

       ! get latitude
       call cld_ntrp_locate_cell(x2, positions(1,ip), i, ier)
       iertot = iertot + ier
       call cld_ntrp_locate_cell(y2, positions(2,ip), j, ier)
       iertot = iertot + ier
       ij(1) = i; ij(2) = j;
       call cld_ntrp_get_cell_values(n2s, _FLATTEN(geolat2), ij, fvals, ier)
       iertot = iertot + ier
       ts(1) = (positions(1,ip) - x2(i))/(x2(i+1) - x2(i))
       ts(2) = (positions(2,ip) - y2(j))/(y2(j+1) - y2(j))
       call cld_ntrp_linear_cell_interp(fvals, ts, lats(ip), ier)
       iertot = iertot + ier

    enddo

  if(iertot /= 0) then
     write(iertot_str, '(i10)') iertot
     ermesg = 'drifters_positions2geolonlat: ERROR '//trim(iertot_str)// &
          & ' interpolation errors (domain out of bounds?)'
  endif

  end subroutine drifters_positions2lonlat

  !============================================================================
! <SUBROUTINE NAME="drifters_print_checksums">
!  <OVERVIEW>
!  Print Runge-Kutta check sums.
!  </OVERVIEW>
!  <DESCRIPTION>
!  Useful for debugging only. 
!  </DESCRIPTION>
!  <TEMPLATE>
!   call   drifters_print_checksums(self, pe, ermesg)
!		
!  </TEMPLATE>
!  <INOUT NAME="self" TYPE="drifters_type" DIM="SCALAR" UNITS="" DEFAULT="">
!  Opaque handle.
!  </INOUT>
!  <IN NAME="pe" TYPE="integer" DIM="SCALAR" UNITS="" DEFAULT="">
!  Processor element.
!  </IN>
!  <OUT NAME="ermesg" TYPE="character" DIM="SCALAR" UNITS="" DEFAULT="">
!  Error message (if any).
!  </OUT>
! </SUBROUTINE>
!
  subroutine drifters_print_checksums(self, pe, ermesg)

    type(drifters_type) :: self
    integer, intent(in), optional :: pe
    character(len=*), intent(out) :: ermesg

    integer, parameter :: i8 = selected_int_kind(13)
    integer(i8) :: mold, chksum_pos, chksum_k1, chksum_k2, chksum_k3, chksum_k4
    integer(i8) :: chksum_tot
    integer nd, np, me

    ermesg = ''

    if(.not. present(pe)) then
       me = _MPP_PE
    else
       me = pe
    endif

    if(me == _MPP_PE) then

       nd = self%core%nd
       np = self%core%np
       chksum_pos = transfer(sum(sum(self%core%positions(1:nd,1:np),1)), mold)
       chksum_k1  = transfer(sum(sum(self%rk4_k1(1:nd,1:np),1)), mold)
       chksum_k2  = transfer(sum(sum(self%rk4_k2(1:nd,1:np),1)), mold)
       chksum_k3  = transfer(sum(sum(self%rk4_k3(1:nd,1:np),1)), mold)
       chksum_k4  = transfer(sum(sum(self%rk4_k4(1:nd,1:np),1)), mold)
       chksum_tot = chksum_pos + chksum_k1 + chksum_k2 + chksum_k3 +chksum_k4

       print *,'==============drifters checksums=========================='
       print '(a,i25,a,i6,a,e15.7)','==positions: ', chksum_pos,  ' PE=', me, ' time = ', self%time
       print '(a,i25,a,i6,a,e15.7)','==k1       : ', chksum_k1,   ' PE=', me, ' time = ', self%time
       print '(a,i25,a,i6,a,e15.7)','==k2       : ', chksum_k2,   ' PE=', me, ' time = ', self%time
       print '(a,i25,a,i6,a,e15.7)','==k3       : ', chksum_k3,   ' PE=', me, ' time = ', self%time
       print '(a,i25,a,i6,a,e15.7)','==k4       : ', chksum_k4,   ' PE=', me, ' time = ', self%time
       print '(a,i25,a,i6,a,e15.7)','==total    : ', chksum_tot,  ' PE=', me, ' time = ', self%time

    endif

  end subroutine drifters_print_checksums

  subroutine drifters_reset_rk4(self, ermesg)
    type(drifters_type) :: self
    character(len=*), intent(out) :: ermesg
    
    integer ier, nd
    
    ermesg = ''

    if(size(self%rk4_k1, 2) < self%core%np) then
       deallocate(self%rk4_k1, stat=ier)
       allocate(self%rk4_k1(self%core%nd, self%core%npdim))
       self%rk4_k1 = 0
    endif
    if(size(self%rk4_k2, 2) < self%core%np) then
       deallocate(self%rk4_k2, stat=ier)
       allocate(self%rk4_k2(self%core%nd, self%core%npdim))
       self%rk4_k2 = 0
    endif
    if(size(self%rk4_k3, 2) < self%core%np) then
       deallocate(self%rk4_k3, stat=ier)
       allocate(self%rk4_k3(self%core%nd, self%core%npdim))
       self%rk4_k3 = 0
    endif
    if(size(self%rk4_k4, 2) < self%core%np) then
       deallocate(self%rk4_k4, stat=ier)
       allocate(self%rk4_k4(self%core%nd, self%core%npdim))
       self%rk4_k4 = 0
    endif

    if(size(self%remove) < self%core%np) then
       deallocate(self%remove, stat=ier)
       allocate(self%remove(self%core%npdim))
       self%remove = .FALSE.
    endif
          
    if(size(self%temp_pos, 2) < self%core%np) then
       deallocate(self%temp_pos, stat=ier)
       nd = size(self%input%velocity_names)
       allocate(self%temp_pos(nd, self%core%npdim))
       self%temp_pos = -huge(1.)
    endif

  end subroutine drifters_reset_rk4

end module drifters_mod

!##############################################################################
! Unit test
! =========
!
! Compilation instructions:
!
!
! Example 1: Altix with MPP
! set FMS="/net2/ap/regression/ia64/25-May-2006/SM2.1U_Control-1990_D1_lm2/"
! set NETCDF="-lnetcdf"
! set MPI="-lmpi"
! set MPP="-I $FMS/exec $FMS//exec/mpp*.o $FMS/exec/threadloc.o"
! set INC="-I/usr/include -I/usr/local/include -I $FMS/src/shared/include -I./"
! set F90="ifort -Duse_libMPI -r8 -g -check bounds"
!
! Example 2: IRIX with MPP
! set FMS="/net2/ap/regression/sgi/25-May-2006/SM2.1U_Control-1990_D1_lm2/"
! set NETCDF="-lnetcdf"
! set MPI="-lmpi -lexc"
! set MPP="-I $FMS/exec/ $FMS/exec/mpp*.o $FMS/exec/threadloc.o $FMS/exec/nsclock.o"
! set INC="-I/usr/include -I/usr/local/include -I $FMS/src/shared/include -I./"
! set F90="f90 -Duse_libMPI -r8 -g -64 -macro_expand -DEBUG:conform_check=YES:subscript_check=ON:trap_uninitialized=ON:verbose_runtime=ON"
!
! Example 3: ia32 without MPP/MPI
! set MPI=""
! set MPP=""
! set NETCDF="-L/net/ap/Linux.i686/pgf95/lib -lnetcdf"
! set INC="-I/net/ap/Linux.i686/pgf95/include -I /home/ap/HIM/him_global/include -I./"
! set 
! set F90="/usr/local/nf95/bin/nf95 -g -r8 -C=all -colour"
! or  
! set F90="pgf95 -g -r8 -Mbounds -Mchkfpstk -Mchkptr -Mstabs"
! or
! set F90="lf95 --dbl"
!
! All platforms:
!
! set SRCS="cloud_interpolator.F90 quicksort.F90 drifters_core.F90 drifters_io.F90 drifters_input.F90 drifters_comm.F90 drifters.F90"
! $F90 -D_DEBUG -D_TEST_DRIFTERS $INC $MPP $SRCS $NETCDF $MPI
! 
! 
! Run the test unit:
! =================
! rm -f drifters_out_test_3d.nc.*
! mpirun -np # a.out
! drifters_combine -f drifters_out_test_3d.nc
! md5sum drifters_out_test_3d.nc
! 548603caca8db971f2e833b9ce8b85f0  drifters_out_test_3d.nc
! md5sum drifters_res.nc 
! 6b697d25ff9ee719b5cedbdc6ccb702a  drifters_res.nc
!
! NOTE: checksums on drifters_res.nc may vary according to PE layouts. The
! differences should only affect the (arbitrary) order in which drifters
! are saved onto file.

! On IRIX64:
! set F90="f90 -r8 -g -64 -macro_expand -DEBUG:conform_check=YES:subscript_check=ON:trap_uninitialized=ON:verbose_runtime=ON" 
! $F90 -D_DEBUG -D_TEST_DRIFTERS $INC -I $MPPLIB_DIR $SRCS $MPPLIB_DIR/mpp*.o $MPPLIB_DIR/nsclock.o $MPPLIB_DIR/threadloc.o -L/usr/local/lib -lnetcdf -lmpi -lexc
! 
! input file: drifters_inp_test_3d.nc
!!$netcdf drifters_inp_test_3d {
!!$dimensions:
!!$	nd = 3 ; // number of dimensions (2 or 3)
!!$	np = 4 ; // number of particles
!!$variables:
!!$	double positions(np, nd) ;
!!$		positions:names = "x y z" ;
!!$		positions:units = "- - -" ;
!!$	int ids(np) ;
!!$
!!$// global attributes:
!!$		:velocity_names = "u v w" ;
!!$		:field_names = "temp" ;
!!$		:field_units = "C" ;
!!$		:time_units = "seconds" ;
!!$		:title = "example of input data for drifters" ;
!!$data:
!!$
!!$ positions =
!!$  -0.8, 0., 0.,
!!$  -0.2, 0., 0., 
!!$   0.2, 0., 0.,
!!$   0.8, 0., 0.;
!!$
!!$ ids = 1, 2, 3, 4 ; // must range from 1 to np, in any order
!!$}


#ifdef _TEST_DRIFTERS

! number of dimensions (2 or 3)
#define _DIMS 3

subroutine my_error_handler(mesg)
#ifndef _SERIAL
  use mpp_mod, only : FATAL, mpp_error
#endif
  implicit none
  character(len=*), intent(in) :: mesg
#ifndef _SERIAL
  call mpp_error(FATAL, mesg)
#else
  print *, mesg
  stop 
#endif
end subroutine my_error_handler

program test

  ! Example showing how to use drifters_mod.
  
  use drifters_mod
#ifndef _SERIAL
  use mpp_mod
  use mpp_domains_mod
#endif
  implicit none
  
  ! declare drifters object
  type(drifters_type) :: drfts  ! drifters' object
  type(drifters_type) :: drfts2 ! to test copy
  character(len=128)  :: ermesg

  real    :: t0, dt, t, tend, rho
  real    :: xmin, xmax, ymin, ymax, zmin, zmax, theta
  real, parameter :: pi = 3.1415926535897931159980
  real, allocatable :: x(:), y(:)
#if _DIMS == 2
  real, allocatable :: u(:,:), v(:,:), w(:,:), temp(:,:)
#endif
#if _DIMS == 3
  real, allocatable :: z(:), u(:,:,:), v(:,:,:), w(:,:,:), temp(:,:,:)
#endif
  integer :: layout(2), nx, ny, nz, halox, haloy, i, j, k, npes, pe, root
  integer :: isd,  ied,  jsd,  jed, isc,  iec,  jsc,  jec
  integer :: pe_beg, pe_end
  integer :: ibnds(1) ! only used in _SERIAL mode

  _TYPE_DOMAIN2D :: domain

#ifndef _SERIAL
  call mpp_init
#endif
  npes   = _MPP_NPES
  pe     = _MPP_PE
  root   = _MPP_ROOT
  pe_beg = npes/2
  pe_end = npes-1


  ! input parameters
  t0 = 0.0 ! initial time
  tend = 2.0*pi ! max time
  dt =  tend/20.0 ! time step
  ! domain boundaries
  xmin = -1. ; xmax = 1.
  ymin = -1. ; ymax = 1.
  zmin = -1. ; zmax = 1.
  nx = 41; ny = 41; nz = 21;
  halox = 2; haloy = 2;

  allocate( x(1-halox:nx+halox), y(1-haloy:ny+haloy))
  x = xmin + (xmax-xmin)*(/ (real(i-1)/real(nx-1), i = 1-halox, nx+halox) /)
  y = ymin + (ymax-ymin)*(/ (real(j-1)/real(ny-1), j = 1-haloy, ny+haloy) /)

#if _DIMS == 2
  allocate( u(1-halox:nx+halox, 1-haloy:ny+haloy), &
       &    v(1-halox:nx+halox, 1-haloy:ny+haloy), &
       &    w(1-halox:nx+halox, 1-haloy:ny+haloy), &
       & temp(1-halox:nx+halox, 1-haloy:ny+haloy))
#endif
#if _DIMS == 3
  allocate( z(nz) )
  z = zmin + (zmax-zmin)*(/ (real(k-1)/real(nz-1), k = 1, nz) /)
  allocate( u(1-halox:nx+halox, 1-haloy:ny+haloy, nz), &
       &    v(1-halox:nx+halox, 1-haloy:ny+haloy, nz), &
       &    w(1-halox:nx+halox, 1-haloy:ny+haloy, nz), &
       & temp(1-halox:nx+halox, 1-haloy:ny+haloy, nz))
#endif


#ifndef _SERIAL
  ! decompose domain
  call mpp_domains_init ! (MPP_DEBUG)
!!$  call mpp_domains_set_stack_size(stackmax)

  call mpp_declare_pelist( (/ (i, i=pe_beg, pe_end) /), '_drifters')
#endif

  ! this sumulates a run on a subset of PEs
  if(pe >= pe_beg .and. pe <= pe_end) then 
     
#ifndef _SERIAL
     call mpp_set_current_pelist( (/ (i, i=pe_beg, pe_end) /) )

     call mpp_define_layout( (/1,nx, 1,ny/), pe_end-pe_beg+1, layout )
     if(pe==root) print *,'LAYOUT: ', layout
     call mpp_define_domains((/1,nx, 1,ny/), layout, domain, &
          & xhalo=halox, yhalo=haloy) !,&
     !& xflags=CYCLIC_GLOBAL_DOMAIN, yflags=CYCLIC_GLOBAL_DOMAIN)
#endif

     ! constructor
#if _DIMS == 2
     call drifters_new(drfts, &
          & input_file ='drifters_inp_test_2d.nc'  , &
          & output_file='drifters_out_test_2d.nc', &
          & ermesg=ermesg)
#endif
#if _DIMS == 3
     call drifters_new(drfts, &
          & input_file ='drifters_inp_test_3d.nc'  , &
          & output_file='drifters_out_test_3d.nc', &
          & ermesg=ermesg)
#endif
     if(ermesg/='') call my_error_handler(ermesg)

     ! set start/end pe
     drfts%comm%pe_beg = pe_beg
     drfts%comm%pe_end = pe_end

     ! set the initial time and dt
     drfts%time = t0
     drfts%dt   = dt

#ifndef _SERIAL
     call mpp_get_data_domain   ( domain, isd,  ied,  jsd,  jed  )
     call mpp_get_compute_domain( domain, isc,  iec,  jsc,  jec  )
#else
     ibnds = lbound(x); isd = ibnds(1)
     ibnds = ubound(x); ied = ibnds(1)
     ibnds = lbound(y); jsd = ibnds(1)
     ibnds = ubound(y); jed = ibnds(1)
     isc = isd; iec = ied - 1
     jsc = jsd; jec = jed - 1
#endif


     ! set the PE domain boundaries. Xmin_comp/ymin_comp, xmax_comp/ymax_comp
     ! refer to the "compute" domain, which should cover densily the domain: ie
     ! xcmax[pe] = xcmin[pe_east]
     ! ycmax[pe] = ycmin[pe_north]
     ! Xmin_data/ymin_data, xmax_data/ymax_data refer to the "data" domain, which
     ! should be larger than the compute domain and therefore overlap: ie
     ! xdmax[pe] > xdmin[pe_east]
     ! ydmax[pe] > ydmin[pe_north]
     ! Particles in the overlap regions are tracked by several PEs. 

     call drifters_set_domain(drfts, &
          & xmin_comp=x(isc  ), xmax_comp=x(iec+1), &
          & ymin_comp=y(jsc  ), ymax_comp=y(jec+1), &
          & xmin_data=x(isd  ), xmax_data=x(ied  ), &
          & ymin_data=y(jsd  ), ymax_data=y(jed  ), &
          !!$       & xmin_glob=xmin    , xmax_glob=xmax    , & ! periodicity in x
!!$       & ymin_glob=ymin    , ymax_glob=ymax    , & ! periodicity in y
     & ermesg=ermesg)
     if(ermesg/='') call my_error_handler(ermesg)

     ! set neighboring PEs [domain2d is of type(domain2d)]

     call drifters_set_pe_neighbors(drfts, domain=domain, ermesg=ermesg)
     if(ermesg/='') call my_error_handler(ermesg)

     ! set the velocities axes. Each velocity can have different axes.

     call drifters_set_v_axes(drfts, component='u', &
          & x=x, y=y, &
#if _DIMS == 2
          & z=DRFT_EMPTY_ARRAY, &
#endif
#if _DIMS >= 3
          & z=z, &
#endif
          & ermesg=ermesg)
     if(ermesg/='') call my_error_handler(ermesg)

     call drifters_set_v_axes(drfts, component='v', &
          & x=x, y=y, &
#if _DIMS == 2
          & z=DRFT_EMPTY_ARRAY, &
#endif
#if _DIMS >= 3
          & z=z, &
#endif
          & ermesg=ermesg)
     if(ermesg/='') call my_error_handler(ermesg)

#if _DIMS == 3
     call drifters_set_v_axes(drfts, component='w', &
          & x=x, y=y, &
#if _DIMS == 2
          & z=DRFT_EMPTY_ARRAY, &
#endif
#if _DIMS >= 3
          & z=z, &
#endif
          & ermesg=ermesg)
     if(ermesg/='') call my_error_handler(ermesg)
#endif

     ! Distribute the drifters across PEs
     call drifters_distribute(drfts, ermesg)
     if(ermesg/='') call my_error_handler(ermesg)

     t = t0

     do while (t <= tend+epsilon(1.))

        ! Update time

        t = t + dt/2.0

        ! Set velocity and field
#if _DIMS == 2
        do j = 1-haloy, ny+haloy
           do i = 1-halox, nx+halox
              theta = atan2(y(j), x(i))
              rho   = sqrt(x(i)**2 + y(j)**2)
              u(i,j) = - rho * sin(theta)
              v(i,j) = + rho * cos(theta)
              temp(i,j) = (x(i)**2 + y(j)**2)
           enddo
        enddo
        ! Push the drifters
        call drifters_push(drfts, u=u, v=v, ermesg=ermesg)
        if(ermesg/='') call my_error_handler(ermesg)
#endif
#if _DIMS == 3
        do k = 1, nz
           do j = 1-haloy, ny+haloy
              do i = 1-halox, nx+halox
                 theta = atan2(y(j), x(i))
                 rho   = sqrt(x(i)**2 + y(j)**2)
                 u(i,j,k) = - rho * sin(theta)
                 v(i,j,k) = + rho * cos(theta)
                 w(i,j,k) = + 0.01 * cos(t)
                 temp(i,j,k) = (x(i)**2 + y(j)**2) * (1.0 - z(k)**2)
              enddo
           enddo
        enddo
        ! Push the drifters
        call drifters_push(drfts, u=u, v=v, w=w, ermesg=ermesg)
        if(ermesg/='') call my_error_handler(ermesg)
#endif


        ! Check if RK4 integration is complete

        if(drfts%rk4_completed) then

           ! Interpolate fields

           call drifters_set_field(drfts, index_field=1, x=x, y=y, &
#if _DIMS >= 3
                & z=z, &
#endif
                &    data=temp, ermesg=ermesg)
           if(ermesg/='') call my_error_handler(ermesg)

           ! Save data 

           call drifters_save(drfts, ermesg=ermesg)
           if(ermesg/='') call my_error_handler(ermesg)

        endif

     enddo

     ! Write restart file

     call drifters_write_restart(drfts, filename='drifters_res.nc', &
          & ermesg=ermesg)  
     if(ermesg/='') call my_error_handler(ermesg)

     ! test copy
     drfts2 = drfts

     ! destroy

     call drifters_del(drfts, ermesg=ermesg)
     if(ermesg/='') call my_error_handler(ermesg)

     deallocate(x, y)
     deallocate(u, v, temp)
#if _DIMS == 3
     deallocate(z, w)
#endif

  endif

#ifndef _SERIAL
  call mpp_exit
#endif

end program test
#endif 


#include <fms_platform.h>
#include "fms_switches.h"

! $Id: drifters_comm.F90,v 14.0.14.1 2010/08/31 14:28:49 z1l Exp $

module drifters_comm_mod

#ifdef _SERIAL

#define _TYPE_DOMAIN2D integer
#define _NULL_PE 0

#else

  use mpp_mod,         only        : NULL_PE, FATAL, NOTE, mpp_error, mpp_pe, mpp_npes
  use mpp_mod,         only        : mpp_root_pe
  use mpp_mod,         only        : mpp_send, mpp_recv, mpp_sync_self
  use mpp_domains_mod, only        : domain2D
  use mpp_domains_mod, only        : mpp_get_neighbor_pe, mpp_define_domains, mpp_get_layout
  use mpp_domains_mod, only        : mpp_get_compute_domain, mpp_get_data_domain
  use mpp_domains_mod, only        : NORTH, SOUTH, EAST, WEST, CYCLIC_GLOBAL_DOMAIN
  use mpp_domains_mod, only        : NORTH_EAST, SOUTH_EAST, SOUTH_WEST, NORTH_WEST

#define _TYPE_DOMAIN2D type(domain2d)
#define _NULL_PE NULL_PE

#endif

  use drifters_core_mod, only: drifters_core_type, drifters_core_remove_and_add,  drifters_core_set_positions

  implicit none
  private

  public :: drifters_comm_type, drifters_comm_new, drifters_comm_del, drifters_comm_set_pe_neighbors
  public :: drifters_comm_set_domain, drifters_comm_update, drifters_comm_gather

  type drifters_comm_type
     ! compute domain
     real           :: xcmin, xcmax
     real           :: ycmin, ycmax
     ! data domain
     real           :: xdmin, xdmax
     real           :: ydmin, ydmax
     ! global valid min/max
     real           :: xgmin, xgmax
     real           :: ygmin, ygmax
     ! x/y period (can be be nearly infinite)
     logical        :: xperiodic, yperiodic
     ! neighbor domains
     integer        :: pe_N, pe_S, pe_E, pe_W, pe_NE, pe_SE, pe_SW, pe_NW
     ! starting/ending pe, set this to a value /= 0 if running concurrently
     integer        :: pe_beg, pe_end
  end type drifters_comm_type


contains

!===============================================================================
  subroutine drifters_comm_new(self)
    type(drifters_comm_type)   :: self
    
    self%xcmin = -huge(1.); self%xcmax = +huge(1.)
    self%ycmin = -huge(1.); self%ycmax = +huge(1.)

    self%xdmin = -huge(1.); self%xdmax = +huge(1.)
    self%ydmin = -huge(1.); self%ydmax = +huge(1.)

    self%xgmin = -huge(1.); self%xgmax = +huge(1.)
    self%ygmin = -huge(1.); self%ygmax = +huge(1.)

    self%xperiodic = .FALSE.; self%yperiodic = .FALSE.

    self%pe_N  = _NULL_PE
    self%pe_S  = _NULL_PE
    self%pe_E  = _NULL_PE
    self%pe_W  = _NULL_PE
    self%pe_NE = _NULL_PE
    self%pe_SE = _NULL_PE
    self%pe_SW = _NULL_PE
    self%pe_NW = _NULL_PE

    self%pe_beg =  0
    self%pe_end = -1
    
    
  end subroutine drifters_comm_new

!===============================================================================
  subroutine drifters_comm_del(self)
    type(drifters_comm_type)   :: self
    
    ! nothing to deallocate
    call drifters_comm_new(self)

  end subroutine drifters_comm_del

!===============================================================================
  subroutine drifters_comm_set_data_bounds(self, xmin, ymin, xmax, ymax)
    ! Set data domain bounds.
    type(drifters_comm_type)   :: self
    real, intent(in)           :: xmin, ymin, xmax, ymax
    
    self%xdmin = max(xmin, self%xdmin)
    self%xdmax = min(xmax, self%xdmax)
    self%ydmin = max(ymin, self%ydmin)
    self%ydmax = min(ymax, self%ydmax)

  end subroutine drifters_comm_set_data_bounds

!===============================================================================
  subroutine drifters_comm_set_comp_bounds(self, xmin, ymin, xmax, ymax)
    ! Set compute domain bounds.
    type(drifters_comm_type)   :: self
    real, intent(in)           :: xmin, ymin, xmax, ymax
    
    self%xcmin = max(xmin, self%xcmin)
    self%xcmax = min(xmax, self%xcmax)
    self%ycmin = max(ymin, self%ycmin)
    self%ycmax = min(ymax, self%ycmax)

  end subroutine drifters_comm_set_comp_bounds

!===============================================================================
  subroutine drifters_comm_set_pe_neighbors(self, domain)
    ! Set neighboring pe numbers.
    type(drifters_comm_type)   :: self
    _TYPE_DOMAIN2D, intent(inout) :: domain

#ifndef _SERIAL
! parallel code

    integer        :: pe_N, pe_S, pe_E, pe_W, pe_NE, pe_SE, pe_SW, pe_NW

    call mpp_get_neighbor_pe(domain, NORTH     , pe_N )
    call mpp_get_neighbor_pe(domain, NORTH_EAST, pe_NE)
    call mpp_get_neighbor_pe(domain, EAST      , pe_E )
    call mpp_get_neighbor_pe(domain, SOUTH_EAST, pe_SE)
    call mpp_get_neighbor_pe(domain, SOUTH     , pe_S )
    call mpp_get_neighbor_pe(domain, SOUTH_WEST, pe_SW)
    call mpp_get_neighbor_pe(domain, WEST      , pe_W )
    call mpp_get_neighbor_pe(domain, NORTH_WEST, pe_NW)

    if(pe_N  /= self%pe_N  .and. self%pe_N  == _NULL_PE) then
       self%pe_N  = pe_N 
    else if(pe_N  /= self%pe_N ) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: NORTH PE changed!.')
    endif 
    if(pe_NE /= self%pe_NE .and. self%pe_NE == _NULL_PE) then
       self%pe_NE = pe_NE
    else if(pe_NE /= self%pe_NE) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: NORTH-EAST PE changed!.')
    endif 
    if(pe_E  /= self%pe_E  .and. self%pe_E  == _NULL_PE) then
       self%pe_E  = pe_E 
    else if(pe_E  /= self%pe_E ) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: EAST PE changed!.')
    endif 
    if(pe_SE /= self%pe_SE .and. self%pe_SE == _NULL_PE) then
       self%pe_SE = pe_SE
    else if(pe_SE /= self%pe_SE) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: SOUTH-EAST PE changed!.')
    endif 
    if(pe_S  /= self%pe_S  .and. self%pe_S  == _NULL_PE) then
       self%pe_S  = pe_S 
    else if(pe_S  /= self%pe_S ) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: SOUTH PE changed!.')
    endif 
    if(pe_SW /= self%pe_SW .and. self%pe_SW == _NULL_PE) then
       self%pe_SW = pe_SW
    else if(pe_SW /= self%pe_SW) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: SOUTH-WEST PE changed!.')
    endif 
    if(pe_W  /= self%pe_W  .and. self%pe_W  == _NULL_PE) then
       self%pe_W  = pe_W 
    else if(pe_W  /= self%pe_W ) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: WEST PE changed!.')
    endif 
    if(pe_NW /= self%pe_NW .and. self%pe_NW == _NULL_PE) then
       self%pe_NW = pe_NW
    else if(pe_NW /= self%pe_NW) then
       call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: NORTH-WEST PE changed!.')
    endif 

#endif
! end of parallel code

  end subroutine drifters_comm_set_pe_neighbors

!===============================================================================
  subroutine drifters_comm_set_domain(self, domain, x, y, backoff_x, backoff_y)
    ! Set boundaries of domain and compute neighbors. This method can be called
    ! multiple times; the data domain will just be the intersection (overlap) of
    ! all domains (e.g domain_u, domain_v, etc). 
    type(drifters_comm_type)   :: self
    _TYPE_DOMAIN2D, intent(inout) :: domain
    real, intent(in)           :: x(:), y(:)           ! global axes
    integer, intent(in)        :: backoff_x, backoff_y ! >=0, data domain is reduced by "backoff_x,y" indices in x, resp. y
    
    ! compute/data domain start/end indices
    integer isc, iec, jsc, jec
    integer isd, ied, jsd, jed
    integer nx, ny, hx, hy, bckf_x, bckf_y, halox, haloy
    real dx, dy, xdmin, xdmax, ydmin, ydmax

#ifdef _SERIAL
    integer :: ibnds(1)

    ibnds = lbound(x); isc = ibnds(1)
    ibnds = ubound(x); iec = ibnds(1) - 1
    ibnds = lbound(y); jsc = ibnds(1)
    ibnds = ubound(y); jec = ibnds(1) - 1
#else
    call mpp_get_compute_domain( domain, isc, iec, jsc, jec )
#endif

    self%xcmin = max(x(isc), self%xcmin)
    self%xcmax = min(x(iec), self%xcmax)
    self%ycmin = max(y(jsc), self%ycmin)
    self%ycmax = min(y(jec), self%ycmax)

    nx = iec - isc + 1
    ny = jec - jsc + 1

#ifdef _SERIAL
    isd = 1; ied = size(x); jsd = 1; jed = size(y)
#else
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
#endif

    hx = max(ied-iec, isc-isd)
    hy = max(jed-jec, jsc-jsd)
    bckf_x = min(backoff_x, hx)
    bckf_y = min(backoff_y, hy)

    halox = max(0, hx - bckf_x)
    haloy = max(0, hy - bckf_y)

    if(isd < 1) then
       dx = x(2) - x(1)
       xdmin = self%xcmin - dx*halox
    else
       xdmin = x(isd+bckf_x)
    endif

    if(ied > nx) then
       dx = x(nx) - x(nx-1)
       xdmax = self%xcmax + dx*halox
    else
       xdmax = x(ied-bckf_x)
    endif

    if(jsd < 1) then
       dy = y(2) - y(1)
       ydmin = self%ycmin - dy*haloy
    else
       ydmin = y(jsd+bckf_y)
    endif

    if(jed > ny) then
       dy = y(ny) - y(ny-1)
       ydmax = self%ycmax + dy*haloy
    else
       ydmax = y(jed-bckf_y)
    endif
    
    self%xdmin = max(xdmin, self%xdmin)
    self%ydmin = max(ydmin, self%ydmin)
    self%xdmax = min(xdmax, self%xdmax)
    self%ydmax = min(ydmax, self%ydmax)

    call drifters_comm_set_pe_neighbors(self, domain)

  end subroutine drifters_comm_set_domain

!===============================================================================
  subroutine drifters_comm_update(self, drfts, new_positions, &
       & comm, remove, max_add_remove)

    type(drifters_comm_type)   :: self
    type(drifters_core_type)   :: drfts
    real, intent(inout)           :: new_positions(:,:)
    integer, intent(in), optional :: comm ! MPI communicator
    logical, intent(in), optional :: remove(:) ! Set to True for particles that should be removed
    integer, intent(in), optional :: max_add_remove ! max no of particles to add/remove

#ifdef _SERIAL
! serial code
    
    drfts%positions(:, 1:drfts%np) = new_positions(:, 1:drfts%np)
    return

#else
! parallel code

    include 'mpif.h'


    integer nd, np, nar_est, ip, neigh_pe, irem, pe, npes, ntuples
    integer ntuples_tot, ndata, mycomm
#ifdef _USE_MPI
    integer ier 
#endif
    integer, allocatable :: iadd(:)
    integer, allocatable :: table_recv(:), table_send(:)
    real   , allocatable :: data_recv(:,:), data_send(:,:)
    integer, allocatable :: indices_to_remove(:)
    integer, allocatable :: ids_to_add(:)
    real   , allocatable :: positions_to_add(:,:)
    real                 :: x, y, xold, yold
    character(len=128) :: ermsg, notemsg
    logical            :: is_present
    integer            :: id, j, k, m, n, el
    logical            :: crossed_W, crossed_E, crossed_S, crossed_N
    logical            :: was_in_compute_domain, left_domain

    mycomm = MPI_COMM_WORLD
    if( present(comm) ) mycomm = comm

    nd = drfts%nd
    np = size(new_positions,2)
    if(np > 0 .and. nd < 2) call mpp_error( FATAL, &
         & 'drifters_comm_update: number of dimensions must be 2 or higher.' )

    nar_est = 100 
    if(present(max_add_remove)) nar_est = max(1, max_add_remove)

    pe   = mpp_pe()
    npes = mpp_npes()

    ! assume pe list is contiguous, self%pe_beg...self%pe_end
    allocate(iadd(self%pe_beg:self%pe_end))
    allocate(table_recv(self%pe_beg:self%pe_end))
    allocate(table_send(self%pe_beg:self%pe_end))
    allocate(data_recv(nar_est*(1+nd), self%pe_beg:self%pe_end))
    allocate(data_send(nar_est*(1+nd), self%pe_beg:self%pe_end))
    allocate(indices_to_remove(nar_est))

    table_send = 0
    table_recv = 0
    data_send  = 0
    data_recv  = 0

    iadd = 0
    irem = 0
    do ip = 1, np
       x = new_positions(1, ip)
       y = new_positions(2, ip)
       xold = drfts%positions(1, ip)
       yold = drfts%positions(2, ip)

       if(    xold<self%xcmin .or. xold>self%xcmax .or. &
            & yold<self%ycmin .or. yold>self%ycmax      ) then
          was_in_compute_domain = .FALSE.
       else
          was_in_compute_domain = .TRUE.
       endif

       ! check if drifters crossed compute domain boundary 
       
       crossed_W = .FALSE.
       crossed_E = .FALSE.
       crossed_S = .FALSE.
       crossed_N = .FALSE.
       if( was_in_compute_domain .and. &
            & (x<self%xcmin) .and. (xold>self%xcmin) ) crossed_W = .TRUE.
       if( was_in_compute_domain .and. &
            & (x>self%xcmax) .and. (xold<self%xcmax) ) crossed_E = .TRUE.
       if( was_in_compute_domain .and. &
            & (y<self%ycmin) .and. (yold>self%ycmin) ) crossed_S = .TRUE.
       if( was_in_compute_domain .and. &
            & (y>self%ycmax) .and. (yold<self%ycmax) ) crossed_N = .TRUE.

       neigh_pe = _NULL_PE
       if(crossed_N .and. .not. crossed_E .and. .not. crossed_W) neigh_pe = self%pe_N
       if(crossed_N .and.       crossed_E                      ) neigh_pe = self%pe_NE
       if(crossed_E .and. .not. crossed_N .and. .not. crossed_S) neigh_pe = self%pe_E
       if(crossed_S .and.       crossed_E                      ) neigh_pe = self%pe_SE
       if(crossed_S .and. .not. crossed_E .and. .not. crossed_W) neigh_pe = self%pe_S
       if(crossed_S .and.       crossed_W                      ) neigh_pe = self%pe_SW
       if(crossed_W .and. .not. crossed_S .and. .not. crossed_N) neigh_pe = self%pe_W
       if(crossed_N .and.       crossed_W                      ) neigh_pe = self%pe_NW

       if(neigh_pe /= _NULL_PE) then
          iadd(neigh_pe) = iadd(neigh_pe) + 1
          if(iadd(neigh_pe) > nar_est) then
             write(notemsg, '(a,i4,a,i4,a)') 'drifters_comm_update: exceeded nar_est (', &
                  & iadd(neigh_pe),'>',nar_est,').'
             call mpp_error( FATAL, notemsg)
          endif
          table_send(neigh_pe)  = table_send(neigh_pe) + 1
          k = ( iadd(neigh_pe)-1 )*(1+nd) + 1
          data_send(k       , neigh_pe) = drfts%ids(ip)
          data_send(k+1:k+nd, neigh_pe) = new_positions(:,ip)
       endif

       ! check if drifters left data domain

       left_domain = .FALSE.
       if(       (x<self%xdmin .and. (self%pe_W/=pe)) .or. &
            &    (x>self%xdmax .and. (self%pe_E/=pe)) .or. &
            &    (y<self%ydmin .and. (self%pe_S/=pe)) .or. &
            &    (y>self%ydmax .and. (self%pe_N/=pe)) ) then
          left_domain = .TRUE.
       endif

       ! remove if particle was tagged as such

       if(present(remove)) then
          if(remove(ip)) left_domain = .TRUE.
       endif

       if(left_domain) then
          irem = irem + 1
          if(irem > nar_est) then
             write(notemsg, '(a,i4,a,i4,a)') 'drifters_comm_update: exceeded nar_est (',&
                  & irem,'>',nar_est,').'
             call mpp_error( FATAL, notemsg)
          endif
          indices_to_remove(irem) = ip
       endif

    enddo


    ! update drifters' positions (remove whatever needs to be removed later)
    call drifters_core_set_positions(drfts, new_positions, ermsg)
    if(ermsg/='') call mpp_error( FATAL, ermsg)

    ! fill in table_recv from table_send. table_send contains the
    ! number of tuples that will be sent to another pe. table_recv
    ! will contain the number of tuples to be received. The indices 
    ! of table_send refer to the pe where the tuples should be sent to;
    ! the indices of table_recv refer to the pe number 
    ! (self%pe_beg..self%pe_end) from
    ! which the tuple should be received from.
    !
    ! table_send(to_pe) = ntuples; table_recv(from_pe) = ntuples

    ! the following is a transpose operation
    ! table_send(m)[pe] -> table_recv(pe)[m]
    do m = self%pe_beg, self%pe_end
#ifdef _USE_MPI
       call MPI_Scatter (table_send   , 1, MPI_INTEGER,  &
            &            table_recv(m), 1, MPI_INTEGER,  &
            &            m, mycomm, ier )
#else
       if(pe==m) then
          do k = self%pe_beg, self%pe_end
             call mpp_send(table_send(k), plen=1, to_pe=k)
          enddo
       endif
       call mpp_recv(table_recv(m), glen=1, from_pe=m)    
#endif
    enddo

    ! communicate new positions. data_send is an array of size n*(nd+1) times npes.
    ! Each column j of data_send contains the tuple (id, x, y, ..) to be sent to pe=j.
    ! Inversely, data_recv's column j contains tuples (id, x, y,..) received from pe=j.
    do m = self%pe_beg, self%pe_end
       ntuples = table_send(m)
       ndata   = ntuples*(nd+1)
       ! should be able to send ndata?
#ifdef _USE_MPI
       call MPI_Scatter (data_send     , nar_est*(1+nd), MPI_REAL8, &
            &            data_recv(1,m), nar_est*(1+nd), MPI_REAL8, &
            &            m, mycomm, ier )
#else
       if(pe==m) then
          do k = self%pe_beg, self%pe_end
             call mpp_send(data_send(1,k), plen=nar_est*(1+nd), to_pe=k)
          enddo
       endif
       call mpp_recv(data_recv(1,m), glen=nar_est*(1+nd), from_pe=m)           
#endif
    enddo

    ! total number of tuples will determine size of ids_to_add/positions_to_add
    ntuples_tot = 0
    do m = self%pe_beg, self%pe_end
       ntuples_tot = ntuples_tot + table_recv(m)
    enddo

    allocate(positions_to_add(nd, ntuples_tot))
    allocate(      ids_to_add(    ntuples_tot))

    ! fill positions_to_add and ids_to_add.
    k = 0
    do m = self%pe_beg, self%pe_end
       ! get ids/positions coming from all pes
       do n = 1, table_recv(m)
          ! iterate over all ids/positions coming from pe=m
          el = (n-1)*(nd+1) + 1
          id = int(data_recv(el, m))
          ! only add if id not already present in drfts
          ! this can happen if a drifter meanders about 
          ! the compute domain boundary
          is_present = .false.
          do j = 1, drfts%np
             if(id == drfts%ids(j)) then
                is_present = .true.
                write(notemsg, '(a,i4,a)') 'Drifter ', id, ' already advected (will not be added).'
                call mpp_error(NOTE, notemsg)
                exit
             endif
          enddo
          if(.not. is_present) then
             k = k + 1
             ids_to_add(k)         = id

             positions_to_add(1:nd, k) = data_recv(el+1:el+nd, m)

          endif
       enddo
    enddo
    
    ! remove and add
    if(irem > 0 .or. k > 0) then
       write(notemsg, '(i4,a,i4,a)') irem, ' drifter(s) will be removed, ', k,' will be added'
       call mpp_error(NOTE, notemsg)
!!$       if(k>0) print *,'positions to add ', positions_to_add(:,1:k)
!!$       if(irem>0) print *,'ids to remove: ', indices_to_remove(1:irem)
    endif
    call drifters_core_remove_and_add(drfts, indices_to_remove(1:irem), &
         & ids_to_add(1:k), positions_to_add(:,1:k), ermsg)
    if(ermsg/='') call mpp_error( FATAL, ermsg)

#ifndef _USE_MPI
    ! make sure unbuffered mpp_isend call returned before deallocating
    call mpp_sync_self
#endif

    deallocate(ids_to_add)
    deallocate(positions_to_add)

    deallocate(iadd)
    deallocate(table_recv)
    deallocate(table_send)
    deallocate(data_recv)
    deallocate(data_send)
    deallocate(indices_to_remove)

#endif
! end of parallel code

  end subroutine drifters_comm_update

!===============================================================================
  subroutine drifters_comm_gather(self, drfts, dinp, &
       & lons, lats, do_save_lonlat, &
       & filename, &
       & root, mycomm)

    use drifters_input_mod, only : drifters_input_type, drifters_input_save

    type(drifters_comm_type)   :: self
    type(drifters_core_type)   :: drfts
    type(drifters_input_type)  :: dinp
    real, intent(in)           :: lons(:), lats(:)
    logical, intent(in)        :: do_save_lonlat
    character(len=*), intent(in)  :: filename
    integer, intent(in), optional :: root    ! root pe
    integer, intent(in), optional :: mycomm  ! MPI communicator

    character(len=128) :: ermesg

#ifdef _SERIAL
! serial code

       dinp%ids(1:drfts%np)          = drfts%ids(1:drfts%np)
       dinp%positions(:, 1:drfts%np) = drfts%positions(:, 1:drfts%np)

       if(do_save_lonlat) then

          call drifters_input_save(dinp, filename=filename, &
               & geolon=lons, geolat=lats, ermesg=ermesg)

       else

          call drifters_input_save(dinp, filename=filename, ermesg=ermesg)

       endif

#else
! parallel code


    integer :: npf, ip, comm, root_pe, pe, npes, nd, np, npdim, npmax, ier, nptot
    integer :: i, j, k, kk
    integer, allocatable ::  nps(:)
    real    :: x, y
    real, allocatable :: lons0(:), lats0(:), recvbuf(:,:)
    real    :: data(drfts%nd+3, drfts%np)
    include 'mpif.h'

    comm    = MPI_COMM_WORLD
    if(present(mycomm)) comm = mycomm

    root_pe = mpp_root_pe()
    if(present(root)) root_pe = root

    pe   = mpp_pe()
    npes = mpp_npes()

    nd = drfts%nd
    np = drfts%np
    npdim = drfts%npdim
    
    allocate(nps(self%pe_beg:self%pe_end))
    nps = 0
    
    ! npf= number of drifters in compute domain

    npf = 0
    do ip = 1, np
       x = drfts%positions(1, ip)
       y = drfts%positions(2, ip)
       if( x <= self%xcmax .and. x >= self%xcmin .and. &
        &  y <= self%ycmax .and. y >= self%ycmin) then
          npf = npf + 1
          data(1       , npf)   = real(drfts%ids(ip))
          data(1+1:1+nd, npf)   =      drfts%positions(:, ip)
          data(    2+nd, npf)   = lons(ip)
          data(    3+nd, npf)   = lats(ip)
       endif
    enddo

    ! gather number of drifters
#ifdef _USE_MPI
    call mpi_gather(npf, 1, MPI_INT, &
         &          nps, 1, MPI_INT, &
         &          root_pe, comm, ier)
    !!if(ier/=0) ermesg = 'drifters_write_restart: ERROR while gathering "npf"'
#else
    call mpp_send(npf, plen=1, to_pe=root_pe)
    if(pe==root_pe) then
       do i = self%pe_beg, self%pe_end
          call mpp_recv(nps(i), glen=1, from_pe=i)
       enddo
    endif
#endif
    
    ! Now we know the max number of drifters to expect from each PE, so allocate 
    ! recvbuf (first dim will be zero on all PEs except root).

    ! allocate recvbuf to receive all the data on root PE, strided by npmax*(nd+3)
    npmax = maxval(nps)
    allocate(recvbuf(npmax*(nd+3), self%pe_beg:self%pe_end))
    recvbuf = -1

    ! Each PE sends data to recvbuf on root_pe.
#ifdef _USE_MPI
    call mpi_gather(         data  ,     npf*(nd+3), MPI_REAL8, &
         &                  recvbuf,   npmax*(nd+3), MPI_REAL8, &
         &          root_pe, comm, ier)
    !!if(ier/=0) ermesg = 'drifters_write_restart: ERROR while gathering "data"'
#else
    if(npf > 0) call mpp_send(data(1,1), plen=npf*(nd+3), to_pe=root_pe)
    if(pe==root_pe) then
       do i = self%pe_beg, self%pe_end
          if(nps(i) > 0) call mpp_recv(recvbuf(1, i), glen=nps(i)*(nd+3), from_pe=i)
       enddo
    endif
#endif
    
    ! Set positions and ids
    if(pe == root_pe) then
       ! check dims 
       nptot = sum(nps) ! total number of drifters, across al PEs
       if(nptot /= size(dinp%ids)) then
          deallocate(dinp%ids      , stat=ier)
          deallocate(dinp%positions, stat=ier)
          allocate(dinp%ids(nptot))
          allocate(dinp%positions(nd, nptot))
          dinp%ids       = -1
          dinp%positions = -huge(1.)
       endif

       allocate(lons0(nptot), lats0(nptot))

       ! Set the new positions/ids in dinp, on PE=root. Also set 
       ! lons/lats, these arrays will hold garbage if x1, y1, etc. were 
       ! not passed as subroutine arguments, that's ok 'cause we won't
       ! save them.
       j = 1
       do i = self%pe_beg, self%pe_end
          do k = 1, nps(i)
             kk = (nd+3)*(k-1)
             dinp%ids(j)             = int(recvbuf(kk+1          , i))
             dinp%positions(1:nd, j) =     recvbuf(kk+1+1:kk+1+nd, i)
             lons0(j)                =     recvbuf(kk+2+nd, i)
             lats0(j)                =     recvbuf(kk+3+nd, i)
             j = j + 1
          enddo
       enddo

       if(do_save_lonlat) then

          call drifters_input_save(dinp, filename=filename, &
               & geolon=lons0, geolat=lats0, ermesg=ermesg)

       else

          call drifters_input_save(dinp, filename=filename, ermesg=ermesg)

       endif

       deallocate(lons0, lats0)

    endif

#ifndef _USE_MPI
    call mpp_sync_self
#endif
    deallocate(nps    , stat=ier)
    deallocate(recvbuf, stat=ier)

#endif
! _end of parallel code

  end subroutine drifters_comm_gather


end module drifters_comm_mod

!===============================================================================
!===============================================================================
#ifdef _TEST_DRIFTERS_COMM
! set FMS=/home/ap/ia64/mpp/mpp_test/exec/
! set OPTS="-r8 -g"
! set OBJS="$FMS/mpp*.o $FMS/threadloc.o"
! set INCS="-I/usr/include -I/usr/local/include -I${FMS}"
! set LIBS="-L/usr/local/lib -lnetcdf -L/usr/lib -lmpi -lcprts"
! ifort $OPTS $INCS -D_TEST_DRIFTERS_COMM drifters_comm.F90 quicksort.F90 drifters_core.F90 $OBJS $LIBS
program main

  use drifters_core_mod
  use drifters_comm_mod
  use mpp_mod
  use mpp_domains_mod

  implicit none

  integer, parameter :: nd=2, npmax = 4
  integer :: nx, ny, halox, haloy, layout(2), i, j, npes, pe, it, nt
  _TYPE_DOMAIN2D      :: domain
  type(drifters_core_type)      :: drfts
  type(drifters_comm_type) :: drfts_com
  real, parameter                     :: xmin=0., xmax=1., ymin=0., ymax=1.
  real                                :: dx, dy, u0, v0, dt, Lx, Ly
  real, allocatable                   :: x(:), y(:)
  character(len=128)  :: ermsg = ''
  integer :: ids(npmax)
  real    :: positions(nd, npmax), velocity(nd, npmax)
  integer :: io_status
!!$  integer :: stackmax=4000000

  namelist /drifters_comm_nml/ nx, ny, halox, haloy, u0, v0, dt, nt 
  

  call mpp_init !(MPP_DEBUG)
  !call mpp_set_stack_size(3145746)

  ! default input values
  nx = 11
  ny = 21
  halox = 2
  haloy = 2
  u0    = 1.0
  v0    = 0.0
  dt    = 0.1
  nt    = 10

  ! read input
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, drifters_comm_nml, iostat=io_status)
#else
  open(unit=1, file='input.nml', form='formatted')
  read(1, drifters_comm_nml)
  close(unit=1)
  if(mpp_pe()==0) write(*,drifters_comm_nml)
#endif

  ! create global domain
  Lx = xmax - xmin
  Ly = ymax - ymin
  dx = Lx/real(nx-1)
  dy = Ly/real(ny-1)
  allocate(x(nx), y(ny))
  x = xmin + (/ ( i*dx, i=0, nx-1) /)
  y = ymin + (/ ( j*dy, j=0, ny-1) /)

  ! decompose domain
  call mpp_domains_init ! (MPP_DEBUG)
!!$  call mpp_domains_set_stack_size(stackmax)

  npes = mpp_npes()
  call mpp_define_layout( (/1,nx, 1,ny/), npes, layout )
  if(mpp_pe()==0) print *,'LAYOUT: ', layout
  call mpp_define_domains((/1,nx, 1,ny/), layout, domain, xhalo=halox, yhalo=haloy,&
       & xflags=CYCLIC_GLOBAL_DOMAIN, yflags=CYCLIC_GLOBAL_DOMAIN)

  ! set up drifters' communicator
  call drifters_comm_new(drfts_com)
  call drifters_comm_set_domain(drfts_com, domain, x, y, 0,0)
  ! repeated calls just for the fun of it
  call drifters_comm_set_domain(drfts_com, domain, x, y, 0,0)
  call drifters_comm_set_domain(drfts_com, domain, x, y, 0,0)
  
  ! create drifters
  call drifters_core_new(drfts, nd, npmax, ermsg)
  if(ermsg /= '') print *,ermsg

  pe = mpp_pe()
  ids = (/ (i+100*pe, i=1,npmax) /)
  call drifters_core_set_ids(drfts, ids, ermsg)
  if(ermsg /= '') print *,ermsg

  ! position particles
  if(pe == 0) then
     positions(:, 1) = (/ (drfts_com%xcmin + drfts_com%xcmax)/2., &
          &               (drfts_com%ycmin + drfts_com%ycmax)/2. /)
     !positions(:, 2) = (/0.,0.01/)
     call drifters_core_set_positions(drfts, positions(:, 1:1), ermsg)
     if(ermsg /= '') print *,ermsg
  endif

  ! push drifters
  velocity(:,1) = (/u0, v0/)
  do it = 1, nt
     positions(:,1:drfts%np) = xmin + &
          & modulo(drfts%positions(:,1:drfts%np) + dt*velocity(:,1:drfts%np)-xmin, xmax-xmin)
     ! this will redistribute the drifters and update the positions
     call drifters_comm_update(drfts_com, drfts, positions(:,1:drfts%np))
     
     if(drfts%np > 0) then 
        do i=1,drfts%np
           print '(a,i2,a,i3,a,i3,a, i3, a,2f10.6)', 'PE: ',pe, ' it=', it, ' np=', drfts%np, ' ip=', i, &
                & ' x,y=', drfts%positions(1,i), drfts%positions(2,i)
        enddo
     endif
!!$     call drifters_print(drfts, ermsg)
!!$     if(ermsg /= '') print *,ermsg
  enddo

  ! clean up
  call drifters_core_del(drfts, ermsg)
  if(ermsg /= '') print *,ermsg
  call drifters_comm_del(drfts_com)
  call mpp_domains_exit
  call mpp_exit

end program main
#endif
! _TEST_DRIFTERS_COMM


! $Id: drifters_core.F90,v 14.0 2007/03/15 22:38:50 fms Exp $
!
! nf95 -r8 -g -I ~/regression/ia64/23-Jun-2005/CM2.1U_Control-1990_E1.k32pe/include/ -D_TEST_DRIFTERS -D_F95 quicksort.F90 drifters_core.F90

#include <fms_platform.h>

module drifters_core_mod
  implicit none
  private

  public :: drifters_core_type, drifters_core_new, drifters_core_del
  public :: drifters_core_remove_and_add, drifters_core_set_positions, assignment(=)
#ifdef _TEST_DRIFTERS_CORE
  public :: drifters_core_print, drifters_core_resize
#endif

  ! Globals
  integer, parameter, private   :: MAX_STR_LEN = 128
  character(MAX_STR_LEN), parameter, private :: version = '$Id: drifters_core.F90,v 14.0 2007/03/15 22:38:50 fms Exp $'

  type drifters_core_type
     ! Be sure to update drifters_core_new, drifters_core_del and drifters_core_copy_new
     ! when adding members
     integer*8 :: it   ! time index
     integer :: nd     ! number of dimensions
     integer :: np     ! number of particles (drifters)
     integer :: npdim  ! max number of particles (drifters)
     integer, _ALLOCATABLE :: ids(:)_NULL  ! particle id number
     real   , _ALLOCATABLE :: positions(:,:)   _NULL
  end type drifters_core_type

  interface assignment(=)
     module procedure drifters_core_copy_new
  end interface

contains

!###############################################################################
  subroutine drifters_core_new(self, nd, npdim, ermesg)
    type(drifters_core_type)        :: self
    integer, intent(in)       :: nd
    integer, intent(in)       :: npdim
    character(*), intent(out) :: ermesg
    integer ier, iflag, i
    ermesg = ''
    ier    = 0

    call drifters_core_del(self, ermesg)

    allocate(self%positions(nd, npdim), stat=iflag)
    if(iflag/=0) ier = ier + 1
    self%positions   = 0

    allocate(self%ids(npdim), stat=iflag)
    if(iflag/=0) ier = ier + 1
    self%ids         = (/(i, i=1,npdim)/)

    self%nd    = nd
    self%npdim = npdim

    if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_new'
  end subroutine drifters_core_new

 !###############################################################################
 subroutine drifters_core_del(self, ermesg)
    type(drifters_core_type)        :: self
    character(*), intent(out) :: ermesg
    integer ier, iflag
    ermesg = ''
    ier    = 0
    self%it  = 0
    self%nd  = 0
    self%np  = 0
    iflag = 0
    if(_ALLOCATED(self%positions)) deallocate(self%positions, stat=iflag)
    if(iflag/=0) ier = ier + 1
    if(_ALLOCATED(self%ids)) deallocate(self%ids, stat=iflag)
    if(iflag/=0) ier = ier + 1
    
    if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_del'
  end subroutine drifters_core_del

 !###############################################################################
 subroutine drifters_core_copy_new(new_instance, old_instance)

    type(drifters_core_type), intent(inout)   :: new_instance
    type(drifters_core_type), intent(in)      :: old_instance

    character(len=MAX_STR_LEN) :: ermesg

    ermesg = ''
    call drifters_core_del(new_instance, ermesg)
    if(ermesg/='') return
    ! this should provide the right behavior for both pointers and allocatables
    new_instance%it         = old_instance%it
    new_instance%nd         = old_instance%nd
    new_instance%np         = old_instance%np
    new_instance%npdim      = old_instance%npdim
    allocate(new_instance%ids( size(old_instance%ids) ))
    new_instance%ids        = old_instance%ids
    allocate(new_instance%positions( size(old_instance%positions,1), &
         &                           size(old_instance%positions,2) ))
    new_instance%positions  = old_instance%positions
   
 end subroutine drifters_core_copy_new
 !###############################################################################
  subroutine drifters_core_resize(self, npdim, ermesg)
    type(drifters_core_type)        :: self
    integer, intent(in)        :: npdim ! new max value
    character(*), intent(out) :: ermesg
    integer ier, iflag, i

    real   , allocatable :: positions(:,:)
    integer, allocatable :: ids(:)

    ermesg = ''
    ier    = 0
    if(npdim <= self%npdim) return

    ! temps
    allocate(positions(self%nd, self%np), stat=iflag)
    allocate(               ids(self%np), stat=iflag)
    
    positions    = self%positions(:, 1:self%np)
    ids          = self%ids(1:self%np)

    deallocate(self%positions, stat=iflag)
    deallocate(self%ids      , stat=iflag)

    allocate(self%positions(self%nd, npdim), stat=iflag)
    allocate(self%ids(npdim), stat=iflag)
    self%positions = 0
    ! default id numbers
    self%ids       = (/ (i, i=1,npdim) /)
    self%positions(:, 1:self%np) = positions
    self%npdim = npdim
    
    if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_resize'
  end subroutine drifters_core_resize

!###############################################################################
  subroutine drifters_core_set_positions(self, positions, ermesg)
    type(drifters_core_type)        :: self
    real, intent(in)           :: positions(:,:)
    character(*), intent(out)  :: ermesg
    integer ier !, iflag
    ermesg = ''
    ier = 0
    self%np = min(self%npdim, size(positions, 2))
    self%positions(:,1:self%np) = positions(:,1:self%np)
    self%it                = self%it + 1
    if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_set_positions'
  end subroutine drifters_core_set_positions

!###############################################################################
  subroutine drifters_core_set_ids(self, ids, ermesg)
    type(drifters_core_type)        :: self
    integer, intent(in)        :: ids(:)
    character(*), intent(out)  :: ermesg
    integer ier, np !, iflag
    ermesg = ''
    ier = 0
    np = min(self%npdim, size(ids))
    self%ids(1:np) = ids(1:np)
    if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_set_ids'
  end subroutine drifters_core_set_ids

!###############################################################################
subroutine drifters_core_remove_and_add(self, indices_to_remove_in, &
     & ids_to_add, positions_to_add, &
     & ermesg)
    type(drifters_core_type)        :: self
    integer, intent(in   )     :: indices_to_remove_in(:)
    integer, intent(in   )     :: ids_to_add(:)
    real   , intent(in   )     :: positions_to_add(:,:)
    character(*), intent(out)  :: ermesg
    integer ier, np_add, np_remove, i, j, n_diff !, iflag
    integer indices_to_remove(size(indices_to_remove_in))
    external qksrt_quicksort
    ermesg = ''
    ier = 0

    ! copy, required so we can have indices_to_remove_in intent(in)    
    indices_to_remove = indices_to_remove_in
    np_remove = size(indices_to_remove)
    np_add    = size(ids_to_add, 1)
    n_diff = np_add - np_remove

    ! cannot remove more than there are elements
    if(self%np + n_diff < 0) then
       ermesg = 'drifters::ERROR attempting to remove more elements than there are elements in drifters_core_remove_and_add'
       return
    endif
    
    ! check for overflow, and resize if necessary
    if(self%np + n_diff > self%npdim)  &
         & call drifters_core_resize(self, int(1.2*(self%np + n_diff))+1, ermesg)

    do i = 1, min(np_add, np_remove)
       j = indices_to_remove(i)
       self%ids(j)            = ids_to_add(i)
       self%positions(:,j)    = positions_to_add(:,i)
    enddo
    
    if(n_diff > 0) then
       ! all the particles to remove were removed and replaced. Just need to append
       ! remaining particles to end of list
       self%ids(         self%np+1:self%np+n_diff)   = ids_to_add(        np_remove+1:np_add)
       self%positions(:, self%np+1:self%np+n_diff)   = positions_to_add(:,np_remove+1:np_add)

       self%np = self%np + n_diff

    else if(n_diff < 0) then
       ! all the particles were added by filling in holes left by particles that 
       ! were previously removed. Now remove remaining particles, starting from the end,  
       ! by replacing the missing particle with a copy from the end.
       
       ! sort remaining indices in ascending order
       call qksrt_quicksort(size(indices_to_remove), indices_to_remove, np_add+1, np_remove)

       do i = np_remove, np_add+1, -1
          if(self%np <= 0) exit
          j = indices_to_remove(i)
          self%ids      (  j)    = self%ids      (  self%np)
          self%positions(:,j)    = self%positions(:,self%np)
          self%np = self%np - 1
       enddo
    endif
       
    if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_remove_and_add'
  end subroutine drifters_core_remove_and_add
  
!###############################################################################
  subroutine drifters_core_print(self, ermesg)
    type(drifters_core_type)        :: self
    character(*), intent(out) :: ermesg
    integer j
    ermesg = ''

    print '(a,i10,a,i6,a,i6,a,i4,a,i4,a,i4)','it=',self%it,  &
         & ' np=', self%np, ' npdim=', self%npdim
        
    print *,'ids and positions:'
    do j = 1, self%np
       print *,self%ids(j), self%positions(:,j)
    enddo    
       
  end subroutine drifters_core_print


end module drifters_core_mod
!###############################################################################
!###############################################################################

#ifdef _TEST_DRIFTERS_CORE
program test
  use drifters_core_mod
  implicit none
  type(drifters_core_type) :: drf
  integer :: ier, nd, npdim, i, j, np
  character(128) :: ermesg
  integer :: npa
  real   , allocatable :: positions(:,:), positions_to_add(:,:)

  ! c-tor/d-tor tests
  nd    = 3
  npdim = 2
  call drifters_core_new(drf, nd, npdim, ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_del(drf, ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_new(drf, nd, npdim, ermesg)
  if(ermesg/='') print *,ermesg

  call drifters_core_print(drf, ermesg)

  npdim = 10
  call drifters_core_resize(drf, npdim, ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_print(drf, ermesg)

  np = 7
  allocate(positions(nd,np))
  positions(1,:) = (/0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0/) ! x
  positions(2,:) = (/0.1, 1.1, 2.1, 3.1, 4.1, 5.1, 6.1/) ! y
  positions(3,:) = (/0.2, 1.2, 2.2, 3.2, 4.2, 5.2, 6.2/) ! z
  call drifters_core_set_positions(drf, positions, ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_print(drf, ermesg)

  ! remove more particles than are added
  npa = 2
  allocate(positions_to_add(nd,npa))
  positions_to_add(1,:) = (/100.0, 200.0/)
  positions_to_add(2,:) = (/100.1, 200.1/)
  positions_to_add(3,:) = (/100.2, 200.2/)
  call drifters_core_remove_and_add(drf, (/2, 6, 1/), &
     & (/ 1001, 1002 /), &
     & positions_to_add, &
     & ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_print(drf, ermesg)
  deallocate(positions_to_add)

  ! add more particles than are removed
  npa = 3
  allocate(positions_to_add(nd,npa))
  positions_to_add(1,:) = (/1000.0, 2000.0, 3000.0/)
  positions_to_add(2,:) = (/1000.1, 2000.1, 3000.1/)
  positions_to_add(3,:) = (/1000.2, 2000.2, 3000.2/)
  call drifters_core_remove_and_add(drf, (/3,1/), &
     & (/ 1003, 1004, 1005 /), &
     & positions_to_add,  &
     & ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_print(drf, ermesg)
  deallocate(positions_to_add)
  
  ! add particles requiring resizing
  npa = 10
  allocate(positions_to_add(nd,npa))
  positions_to_add(1,:) = (/100.0, 200.0, 300.0, 400.0, 500.0, 600.0, 700.0, 800.0, 900.0, 10000.0/)
  positions_to_add(2,:) = (/100.1, 200.1, 300.1, 400.1, 500.1, 600.1, 700.1, 800.1, 900.1, 10000.1/)
  positions_to_add(3,:) = (/100.2, 200.2, 300.2, 400.2, 500.2, 600.2, 700.2, 800.2, 900.2, 10000.2/)
  call drifters_core_remove_and_add(drf, (/3,1,5,2/), &
     & (/ (1010+i, i=1,npa) /), &
     & positions_to_add,  &
     & ermesg)
  if(ermesg/='') print *,ermesg
  call drifters_core_print(drf, ermesg)
  deallocate(positions_to_add)

!!$  call test_circle(ier)
!!$  !call test_3d(ier)
!!$
!!$  if(ier/=0) then
!!$     print *,'Test unit failed ier=', ier
!!$  else
!!$     print *,'Sucessful test ier=', ier
!!$  end if

end program test


#endif


! $Id: drifters_input.F90,v 14.0 2007/03/15 22:38:53 fms Exp $

#include <fms_platform.h>


module drifters_input_mod
  implicit none
  private

  public :: drifters_input_type, drifters_input_new, drifters_input_del, drifters_input_save, assignment(=)

  ! Globals
  integer, parameter, private   :: MAX_STR_LEN = 128
  character(MAX_STR_LEN), parameter, private :: version = '$Id: drifters_input.F90,v 14.0 2007/03/15 22:38:53 fms Exp $'
  character, parameter, private :: SEPARATOR = ' '

  type drifters_input_type
     ! Be sure to update drifters_input_new, drifters_input_del and drifters_input_copy_new
     ! when adding members
     character(len=MAX_STR_LEN), _ALLOCATABLE :: position_names(:) _NULL
     character(len=MAX_STR_LEN), _ALLOCATABLE :: position_units(:) _NULL
     character(len=MAX_STR_LEN), _ALLOCATABLE :: field_names(:)    _NULL
     character(len=MAX_STR_LEN), _ALLOCATABLE :: field_units(:)    _NULL
     character(len=MAX_STR_LEN), _ALLOCATABLE :: velocity_names(:) _NULL
     real                      , _ALLOCATABLE :: positions(:,:) _NULL
     integer                   , _ALLOCATABLE :: ids(:)         _NULL
     character(len=MAX_STR_LEN)               :: time_units
     character(len=MAX_STR_LEN)               :: title
     character(len=MAX_STR_LEN)               :: version
  end type drifters_input_type

  interface assignment(=)
     module procedure drifters_input_copy_new
  end interface
 

  contains

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

  subroutine drifters_input_new(self, filename, ermesg)
    type(drifters_input_type)    :: self
    character(len=*), intent(in) :: filename
    character(len=*), intent(out):: ermesg

    ! Local 
    integer :: ier, ncid, nd, nf, np, ipos, j, id, i, isz
    character(len=MAX_STR_LEN) :: attribute
    include 'netcdf.inc'
    
    ermesg = ''

    ier = nf_open(filename, NF_NOWRITE, ncid)
    if(ier/=NF_NOERR) then
       ermesg = 'drifters_input: ERROR could not open netcdf file '//filename
       return
    endif

    ! version
    ier = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'version', len(version), version)

    ier = NF_INQ_DIMID(NCID, 'nd', id)
    if(ier/=NF_NOERR) then
       ermesg = 'drifters_input: ERROR could not find "nd" (number of dimensions)'
       ier = nf_close(ncid)
       return
    endif
    ier = NF_INQ_DIMLEN(NCID, id, nd)

    ! determine number of fields (nf)
    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'field_names', attribute)
    isz = min(len(attribute), len(trim(attribute))+1)
    attribute(isz:isz) = ' '
    ipos = 1
    nf = 0
    do i = 1, isz
       if(attribute(i:i)==SEPARATOR) then
          nf = nf + 1
       endif
    enddo
      
    ier = NF_INQ_DIMID(NCID, 'np', id)
    if(ier/=NF_NOERR) then
       ermesg = 'drifters_input: ERROR could not find "np" (number of particles)'
       ier = nf_close(ncid)
       return
    endif
    ier = NF_INQ_DIMLEN(NCID, id, np)

    allocate(self%position_names(nd))
    allocate(self%position_units(nd))
    allocate(self%field_names(nf))
    allocate(self%field_units(nf))
    allocate(self%velocity_names(nd))
    allocate(self%ids(np))
    allocate(self%positions(nd, np))

    ier = NF_INQ_VARID(NCID, 'ids', id)
    if(ier/=NF_NOERR) then
       ermesg = 'drifters_input: ERROR could not find "ids"'
       ier = nf_close(ncid)
       return
    endif
    ier = NF_GET_VAR_INT(NCID, id, self%ids)

    ier = NF_INQ_VARID(NCID, 'positions', id)
    if(ier/=NF_NOERR) then
       ermesg = 'drifters_input: ERROR could not find "positions"'
       ier = nf_close(ncid)
       return
    endif
    ier = NF_GET_VAR_DOUBLE(NCID, id, self%positions)

    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'version', attribute)
    self%version = trim(attribute)
   
    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'time_units', attribute)
    self%time_units = trim(attribute)

    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'title', attribute)
    self%title = trim(attribute)

    attribute = ''
    ier = nf_get_att_text(ncid, id, 'names', attribute)
    isz = min(len(attribute), len(trim(attribute))+1)
    attribute(isz:isz) = ' '
    ipos = 1
    j = 1
    do i = 1, isz
       if(attribute(i:i)==SEPARATOR) then
          self%position_names(j)  = trim(adjustl(attribute(ipos:i-1)))
          ipos = i+1
          j = j + 1
          if(j > nd) exit
       endif
    enddo

    attribute = ''
    ier = nf_get_att_text(ncid, id, 'units', attribute)
    isz = min(len(attribute), len(trim(attribute))+1)
    attribute(isz:isz) = ' '
    ipos = 1
    j = 1
    do i = 1, isz
       if(attribute(i:i)==SEPARATOR) then
          self%position_units(j)  = trim(adjustl(attribute(ipos:i-1)))
          ipos = i+1
          j = j + 1
          if(j > nd) exit
       endif
    enddo

    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'field_names', attribute)
    isz = min(len(attribute), len(trim(attribute))+1)
    attribute(isz:isz) = ' '
    ipos = 1
    j = 1
    do i = 1, isz
       if(attribute(i:i)==SEPARATOR) then
          self%field_names(j)  = trim(adjustl(attribute(ipos:i-1)))
          ipos = i+1
          j = j + 1
          if(j > nf) exit
       endif
    enddo

    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'field_units', attribute)
    isz = min(len(attribute), len(trim(attribute))+1)
    attribute(isz:isz) = ' '
    ipos = 1
    j = 1
    do i = 1, isz
       if(attribute(i:i)==SEPARATOR) then
          self%field_units(j)  = trim(adjustl(attribute(ipos:i-1)))
          ipos = i+1
          j = j + 1
          if(j > nf) exit
       endif
    enddo

    attribute = ''
    ier = nf_get_att_text(ncid, NF_GLOBAL, 'velocity_names', attribute)
    isz = min(len(attribute), len(trim(attribute))+1)
    attribute(isz:isz) = ' '
    ipos = 1
    j = 1
    do i = 1, isz
       if(attribute(i:i)==SEPARATOR) then
          self%velocity_names(j)  = trim(adjustl(attribute(ipos:i-1)))
          ipos = i+1
          j = j + 1
          if(j > nd) exit
       endif
    enddo

  end subroutine drifters_input_new

!===============================================================================
  subroutine drifters_input_del(self, ermesg)
    type(drifters_input_type)    :: self
    character(len=*), intent(out):: ermesg

    integer :: iflag

    ermesg = ''

    deallocate(self%position_names, stat=iflag)
    deallocate(self%position_units, stat=iflag)
    deallocate(self%field_names, stat=iflag)
    deallocate(self%field_units, stat=iflag)
    deallocate(self%velocity_names, stat=iflag)
    deallocate(self%ids, stat=iflag)
    deallocate(self%positions, stat=iflag)
    
  end subroutine drifters_input_del

!===============================================================================
  subroutine drifters_input_copy_new(new_instance, old_instance)

    type(drifters_input_type), intent(inout) :: new_instance
    type(drifters_input_type), intent(in)    :: old_instance

    allocate(new_instance%position_names( size(old_instance%position_names) ))
    allocate(new_instance%position_units( size(old_instance%position_units) ))
    allocate(new_instance%field_names( size(old_instance%field_names) ))
    allocate(new_instance%field_units( size(old_instance%field_units) ))
    allocate(new_instance%velocity_names( size(old_instance%velocity_names) ))
    new_instance%position_names = old_instance%position_names
    new_instance%position_units = old_instance%position_units 
    new_instance%field_names    = old_instance%field_names
    new_instance%field_units    = old_instance%field_units
    new_instance%velocity_names = old_instance%velocity_names
    new_instance%time_units     = old_instance%time_units
    new_instance%title          = old_instance%title
    new_instance%version        = old_instance%version
    allocate(new_instance%positions( size(old_instance%positions,1),size(old_instance%positions,2) ))
    new_instance%positions      = old_instance%positions
    allocate(new_instance%ids(size(old_instance%ids)))
    new_instance%ids            = old_instance%ids

  end subroutine drifters_input_copy_new

!===============================================================================
  subroutine drifters_input_save(self, filename, geolon, geolat, ermesg)
    ! save state in netcdf file. can be used as restart file.
    type(drifters_input_type)    :: self
    character(len=*), intent(in ):: filename
    real, intent(in), optional   :: geolon(:), geolat(:)
    character(len=*), intent(out):: ermesg

    integer ncid, nc_nd, nc_np, ier, nd, np, nf, nc_pos, nc_ids, i, j, n
    integer nc_lon, nc_lat
    character(len=MAX_STR_LEN) :: att

    include 'netcdf.inc'

    ermesg = ''
    
    ier = nf_create(filename, NF_CLOBBER, ncid)
    if(ier/=NF_NOERR) then 
       ermesg = 'drifters_input: ERROR cannot create '//filename
       return
    endif

    nd = size(self%positions, 1)
    np = size(self%positions, 2)
    nf = size(self%field_names)

    ! dimensions
    ier = nf_def_dim(ncid, 'nd', nd, nc_nd)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating dim "nd" '//nf_strerror(ier)

    ier = nf_def_dim(ncid, 'np', np, nc_np)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating dim "np" '//nf_strerror(ier)

    ! global attributes
    ier = nf_put_att_text(ncid, NF_GLOBAL, 'title', len_trim(self%title), self%title)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "title" ' &
         & //nf_strerror(ier)
    
    ier = nf_put_att_text(ncid, NF_GLOBAL, 'time_units', len_trim(self%time_units), self%time_units)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "time_units" ' &
         & //nf_strerror(ier)

    att = ''
    j = 1
    do i = 1, nf
       n = len_trim(self%field_units(i))
       att(j:j+n+1) = trim(self%field_units(i)) // ' '
       j = j + n + 1
    enddo
    ier = nf_put_att_text(ncid, NF_GLOBAL, 'field_units',   len_trim(att), &
         & att)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "field_units" ' &
         & //nf_strerror(ier)

    att = ''
    j = 1
    do i = 1, nf
       n = len_trim(self%field_names(i))
       att(j:j+n+1) = trim(self%field_names(i)) // ' '
       j = j + n + 1
    enddo
    ier = nf_put_att_text(ncid, NF_GLOBAL, 'field_names',   len_trim(att), &
         & att)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "field_names" ' &
         & //nf_strerror(ier)

    att = ''
    j = 1
    do i = 1, nd
       n = len_trim(self%velocity_names(i))
       att(j:j+n+1) = trim(self%velocity_names(i)) // ' '
       j = j + n + 1
    enddo
    ier = nf_put_att_text(ncid, NF_GLOBAL, 'velocity_names',   len_trim(att), &
         & att)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "velocity_names" ' &
         & //nf_strerror(ier)

    ! variables
    ier = nf_def_var(ncid, 'positions', NF_DOUBLE, 2, (/nc_nd, nc_np/), nc_pos)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "positions" '//nf_strerror(ier)

    ier = nf_def_var(ncid, 'ids', NF_INT, 1, (/nc_np/), nc_ids)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "ids" '//nf_strerror(ier)

    ! optional: longitudes/latitudes in deg
    if(present(geolon)) then
       ier = nf_def_var(ncid, 'longitude', NF_DOUBLE, 1, (/nc_np/), nc_lon)
       if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "longitude" ' &
            & //nf_strerror(ier)
       att = 'degrees_east'
       ier = nf_put_att_text(ncid, nc_lon, 'units', len(trim(att)), trim(att))
       if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "units" to "longitude" ' &
         & //nf_strerror(ier)
    endif
    if(present(geolat)) then
       ier = nf_def_var(ncid, 'latitude', NF_DOUBLE, 1, (/nc_np/), nc_lat)
       if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "latitude" ' &
            & //nf_strerror(ier)
       att = 'degrees_north'
       ier = nf_put_att_text(ncid, nc_lat, 'units', len(trim(att)), trim(att))
       if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "units" to "latitude" ' &
         & //nf_strerror(ier)
    endif
    
    ! variable attributes
    
    att = ''
    j = 1
    do i = 1, nd
       n = len_trim(self%position_units(i))
       att(j:j+n+1) = trim(self%position_units(i)) // ' '
       j = j + n + 1
    enddo
    ier = nf_put_att_text(ncid, nc_pos, 'units',   len_trim(att), &
         & att)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "units" to "positions" ' &
         & //nf_strerror(ier)
    
    att = ''
    j = 1
    do i = 1, nd
       n = len_trim(self%position_names(i))
       att(j:j+n+1) = trim(self%position_names(i)) // ' '
       j = j + n + 1
    enddo
    ier = nf_put_att_text(ncid, nc_pos, 'names',   len_trim(att), &
         & att)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "names" to "positions" ' &
         & //nf_strerror(ier)

    ! end of define mode
    ier = nf_enddef(ncid)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not end define mode ' &
         & //nf_strerror(ier)

    ! data
    ier = nf_put_var_double(ncid, nc_pos, self%positions)    
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "positions" ' &
         & //nf_strerror(ier)
    
    ier = nf_put_var_int(ncid, nc_ids, self%ids)    
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "ids" ' &
         & //nf_strerror(ier)

    if(present(geolon)) then
       ier = nf_put_var_double(ncid, nc_lon, geolon)    
       if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "geolon" ' &
            & //nf_strerror(ier)       
    endif
    if(present(geolat)) then
       ier = nf_put_var_double(ncid, nc_lat, geolat)    
       if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "geolat" ' &
            & //nf_strerror(ier)       
    endif
    
    
    ier = nf_close(ncid)
    if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not close file ' &
         & //nf_strerror(ier)
    
  end subroutine drifters_input_save

end module drifters_input_mod

!===============================================================================
!===============================================================================
#ifdef _TEST_DRIFTERS_INPUT
program test
  use drifters_input_mod
  implicit none
  character(len=128) :: ermesg
  integer :: i
  
  type(drifters_input_type) :: obj
  
  call drifters_input_new(obj, 'input.nc', ermesg)
  if(ermesg/='') print *,'ERROR: ', ermesg

  print *,'field_names:'
  do i = 1, size(obj%field_names)
     print *,trim(obj%field_names(i))
  enddo

  print *,'velocity_names:'
  do i = 1, size(obj%velocity_names)
     print *,trim(obj%velocity_names(i))
  enddo

  print *,'ids = ', obj%ids

  print *,'positions: '
  do i = 1, size(obj%positions, 2)
     print *,obj%positions(:,i)
  enddo

  call drifters_input_del(obj, ermesg)
end program test

#endif


! $Id: drifters_io.F90,v 14.0 2007/03/15 22:38:56 fms Exp $

!!#include <fms_platform.h>

module drifters_io_mod
  implicit none  
  private

  public :: drifters_io_type, drifters_io_new, drifters_io_del, drifters_io_set_time_units
  public :: drifters_io_set_position_names, drifters_io_set_position_units, drifters_io_set_field_names
  public :: drifters_io_set_field_units, drifters_io_write

  ! Globals
  integer, parameter, private   :: MAX_STR_LEN = 128
  character(MAX_STR_LEN), parameter, private :: &
       & version = '$Id: drifters_io.F90,v 14.0 2007/03/15 22:38:56 fms Exp $'

  real :: drfts_eps_t = 10*epsilon(1.)
  

  type drifters_io_type
     real                 :: time
     integer              :: it ! time index
     integer              :: it_id  ! infinite axis index
     integer              :: ncid
     integer              :: nc_positions, nc_fields, nc_ids, nc_time, nc_index_time    
     logical              :: enddef
  end type drifters_io_type

contains

!###############################################################################
  subroutine drifters_io_new(self, filename, nd, nf, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(in)  :: filename
    integer, intent(in)           :: nd  ! number of dims
    integer, intent(in)           :: nf  ! number of fields
    character(len=*), intent(out) :: ermesg

    integer ier, nc_it_id, nc_nd, nc_nf
    integer :: size1(1), size2(2)
    include 'netcdf.inc'

    ermesg=''
    self%enddef = .FALSE.

    ier = nf_create(filename, NF_CLOBBER, self%ncid)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_create ('//filename//') '//nf_strerror(ier)

    ! global attributes
    ier = nf_put_att_text(self%ncid, NF_GLOBAL, 'version', len_trim(version), trim(version))
    

    ! dimensions
    ier = nf_def_dim(self%ncid, 'it_id', NF_UNLIMITED, nc_it_id)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_dim (it_id) '//nf_strerror(ier)

    ier = nf_def_dim(self%ncid, 'nf', nf, nc_nf)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_dim (nf) '//nf_strerror(ier)

    ier = nf_def_dim(self%ncid, 'nd', nd, nc_nd)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_dim (nd) '//nf_strerror(ier)

    ! variables
    size1 = (/nc_it_id/)
    ier = nf_def_var(self%ncid, 'index_time', NF_INT, 1, size1, self%nc_index_time)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (index_time)'//nf_strerror(ier)

    ier = nf_def_var(self%ncid, 'time', NF_DOUBLE, 1, size1, self%nc_time)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (time)'//nf_strerror(ier)

    ier = nf_def_var(self%ncid, 'ids', NF_INT, 1, size1, self%nc_ids)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (ids)'//nf_strerror(ier)

    size2 = (/nc_nd, nc_it_id/)
    ier = nf_def_var(self%ncid, 'positions', NF_DOUBLE, 2, size2, self%nc_positions)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (positions)'//nf_strerror(ier)

    size2 = (/nc_nf, nc_it_id/)
    ier = nf_def_var(self%ncid, 'fields', NF_DOUBLE, 2, size2, self%nc_fields)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (fields)'//nf_strerror(ier)
    
    self%time  = -huge(1.)
    self%it    = -1
    self%it_id = 1

  end subroutine drifters_io_new

!###############################################################################
  subroutine drifters_io_del(self, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(out) :: ermesg

    integer ier
    include 'netcdf.inc'

    ermesg = ''
    
    ier = nf_close(self%ncid)
    if(ier/=NF_NOERR) ermesg = 'drifters_io_del::nf_close '//nf_strerror(ier)
    
  end subroutine drifters_io_del

!###############################################################################
  subroutine drifters_io_set_time_units(self, name, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(in)  :: name
    character(len=*), intent(out) :: ermesg

    integer ier
    include 'netcdf.inc'

    ermesg = ''
    ier = nf_put_att_text(self%ncid, NF_GLOBAL, &
         & 'time_units', len_trim(name), trim(name))
    if(ier/=NF_NOERR) &
         & ermesg = 'drifters_io_set_time_units::failed to add time_units attribute ' &
         & //nf_strerror(ier)

  end subroutine drifters_io_set_time_units

!###############################################################################
  subroutine drifters_io_set_position_names(self, names, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(in)  :: names(:)
    character(len=*), intent(out) :: ermesg

    integer n, ier, i
    character(len=128) :: attname
    include 'netcdf.inc'

    n = size(names)
    ermesg = ''

    do i = 1, n
       write(attname, '(i6)' ) i
       attname = 'name_'//adjustl(attname)
       ier = nf_put_att_text(self%ncid, self%nc_positions, &
            & trim(attname), len_trim(names(i)), trim(names(i)))
       if(ier/=NF_NOERR) &
            & ermesg = 'drifters_io_set_position_names::failed to add name attribute to positions '//nf_strerror(ier)
    enddo

  end subroutine drifters_io_set_position_names

!###############################################################################
  subroutine drifters_io_set_position_units(self, names, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(in)  :: names(:)
    character(len=*), intent(out) :: ermesg

    integer n, ier, i
    character(len=128) :: attname
    include 'netcdf.inc'

    n = size(names)
    ermesg = ''

    do i = 1, n
       write(attname, '(i6)' ) i
       attname = 'unit_'//adjustl(attname)
       ier = nf_put_att_text(self%ncid, self%nc_positions, &
            & trim(attname), len_trim(names(i)), trim(names(i)))
       if(ier/=NF_NOERR) &
            & ermesg = 'drifters_io_set_position_names::failed to add unit attribute to positions '//nf_strerror(ier)
    enddo
        
  end subroutine drifters_io_set_position_units

!###############################################################################
  subroutine drifters_io_set_field_names(self, names, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(in)  :: names(:)
    character(len=*), intent(out) :: ermesg

    integer n, ier, i
    character(len=128) :: attname
    include 'netcdf.inc'

    n = size(names)
    ermesg = ''

    do i = 1, n
       write(attname, '(i6)' ) i
       attname = 'name_'//adjustl(attname)
       ier = nf_put_att_text(self%ncid, self%nc_fields, &
            & trim(attname), len_trim(names(i)), trim(names(i)))
       if(ier/=NF_NOERR) &
            & ermesg = 'drifters_io_set_field_names::failed to add name attribute to fields '//nf_strerror(ier)
    enddo

  end subroutine drifters_io_set_field_names

!###############################################################################
  subroutine drifters_io_set_field_units(self, names, ermesg)
    type(drifters_io_type)        :: self
    character(len=*), intent(in)  :: names(:)
    character(len=*), intent(out) :: ermesg

    integer n, ier, i
    character(len=128) :: attname
    include 'netcdf.inc'

    n = size(names)
    ermesg = ''

    do i = 1, n
       write(attname, '(i6)' ) i
       attname = 'unit_'//adjustl(attname)
       ier = nf_put_att_text(self%ncid, self%nc_fields, &
            & trim(attname), len_trim(names(i)), trim(names(i)))
       if(ier/=NF_NOERR) &
            & ermesg = 'drifters_io_set_field_units::failed to add unit attribute to fields '//nf_strerror(ier)
    enddo
    
  end subroutine drifters_io_set_field_units
!###############################################################################

  subroutine drifters_io_write(self, time, np, nd, nf, ids, positions, fields, ermesg)
    type(drifters_io_type)        :: self
    real, intent(in)              :: time
    integer, intent(in)           :: np    ! number of dirfters
    integer, intent(in)           :: nd    ! number of dimensions
    integer, intent(in)           :: nf    ! number of fields
    integer, intent(in)           :: ids(np)          ! of size np
    real, intent(in)              :: positions(nd,np) ! nd times np
    real, intent(in)              :: fields(nf,np)    ! nf times np
    character(len=*), intent(out) :: ermesg

    integer ier, i
    integer :: start1(1), len1(1), start2(2), len2(2)
    integer :: it_indices(np)
    real    :: time_array(np)
    include 'netcdf.inc'

    ermesg = ''
    
    if(.not. self%enddef) then
       ier = nf_enddef(self%ncid)
       if(ier/=NF_NOERR) then 
            ermesg = 'drifters_io_write::nf_enddef failure. No data will be written. '//nf_strerror(ier)
            return
       endif
       self%enddef = .TRUE.
    endif

    if(abs(time - self%time) > drfts_eps_t) then
       self%it = self%it + 1
       self%time = time
    endif

    start1(1) = self%it_id
    len1(1)   = np

    it_indices = (/(self%it,i=1,np)/)
    ier = nf_put_vara_int( self%ncid, self%nc_index_time, start1, len1, it_indices )
    if(ier/=NF_NOERR) &
         & ermesg = 'drifters_io_write::failed to write index_time: ' //nf_strerror(ier)

    time_array = (/(time,i=1,np)/)
    ier = nf_put_vara_double( self%ncid, self%nc_time, start1, len1, time_array )
    if(ier/=NF_NOERR) &
         & ermesg = 'drifters_io_write::failed to write time: ' //nf_strerror(ier)

    ier = nf_put_vara_int(self%ncid, self%nc_ids, start1, len1, ids)
    if(ier/=NF_NOERR) &
         & ermesg = 'drifters_io_write::failed to write ids: '//nf_strerror(ier)

    start2(1) = 1
    start2(2) = self%it_id

    len2(1)   = nd
    len2(2)   = np

    ier = nf_put_vara_double(self%ncid, self%nc_positions, start2, len2, positions)
    if(ier/=NF_NOERR) &
         & ermesg = 'drifters_io_write::failed to write positions: '//nf_strerror(ier)

    len2(1)   = nf
    len2(2)   = np    
    
    ier = nf_put_vara_double(self%ncid, self%nc_fields, start2, len2, fields)
    if(ier/=NF_NOERR) &
         & ermesg = 'drifters_io_write::failed to write fields: '//nf_strerror(ier)

    self%it_id = self%it_id + np
    
  end subroutine drifters_io_write

end module drifters_io_mod
 !###############################################################################
 !###############################################################################
#ifdef _TEST_DRIFTERS_IO
! set FC=pgf95
! set FOPTS='-r8 -g -Mdclchk -Minform=warn'
! set INCS='-I/usr/local/include'
! set LIBS='-L/usr/local/lib -lnetcdf'
! $FC $INCS $FOPTS -D_TEST_DRIFTERS_IO drifters_io.F90 $LIBS
program test
  use drifters_io_mod
  implicit none
  type(drifters_io_type) :: drfts_io
  character(len=128) :: ermesg
  character(len=31) :: filename
  integer :: np, nd, nf, nt, i, j, k, npmax
  real :: dt, time, xmin, xmax, ymin, ymax, u, v, dr, x, y
  integer, allocatable :: ids(:)
  real, allocatable :: positions(:,:), fields(:,:)

  ! number of dimensions
  nd = 3
  ! number of fields 
  nf = 2
  ! max number of dirfters 
  npmax = 20
  ! number of time steps
  nt = 50
  ! starting time
  time = 0.

  ! domain boundary. (drifters outside domain will not be written to file.)
  xmin = 0.
  ymin = 0.
  xmax = 1.
  ymax = 1.

  ! constant velocity
  u = (xmax-xmin)*sqrt(2.)
  v = (ymax-ymin)*sqrt(2.)
  dt = 1/real(nt)

  ! open file
  
  filename = 'test.nc'
  call drifters_io_new(drfts_io, filename, nd, nf, ermesg)
  if(ermesg/='') print *,'ERROR after drifters_io_new: ', ermesg

  ! set attributes

  call drifters_io_set_position_names(drfts_io, (/'x','y','z'/), ermesg)
  if(ermesg/='') print *,'ERROR after drifters_io_position_names: ', ermesg

  ! note the trailing blanks in the first field, which are added here to 
  ! ensure that "salinity" will not be truncated (all names must have the 
  ! same length)
  call drifters_io_set_field_names(drfts_io, (/'temp    ','salinity'/), ermesg)
  if(ermesg/='') print *,'ERROR after drifters_io_field_names: ', ermesg

  call drifters_io_set_position_units(drfts_io, (/'deg east ','deg north','meters'/), ermesg)
  if(ermesg/='') print *,'ERROR after drifters_io_position_units: ', ermesg
  
  call drifters_io_set_field_units(drfts_io, (/'deg K ','ppm'/), ermesg)
  if(ermesg/='') print *,'ERROR after drifters_io_field_units: ', ermesg

  allocate(positions(nd, npmax), ids(npmax), fields(nf, npmax))
  dr = sqrt( (xmax-xmin)**2 + (ymax-ymin)**2 )/real(npmax)


  ! x
  positions(1, :) = +(/ (i*dr,i=0,npmax-1) /)/sqrt(2.)
  ! y
  positions(2, :) = -(/ (i*dr,i=0,npmax-1) /)/sqrt(2.)
  ! z
  positions(3, :) = 0.

  ! drifters' identity array (can be any integer number)
  ids = (/ (i, i=1, npmax) /)
  
  ! set fields as a function of space time
  fields(1, :) = sqrt( (positions(1,:)-xmin)**2 + (positions(2,:)-ymin)**2 )
  fields(2, :) = positions(1,:)-u*time + positions(2,:)-v*time ! invariant

  ! write to disk only drifters inside domain
  do i = 1, npmax
     x = positions(1,i)
     y = positions(2,i)
     if(x>=xmin .and. x<=xmax .and. y>=ymin .and. y<=ymax) then
        call drifters_io_write(drfts_io, time, np=1, nd=nd, nf=nf, &
             & ids=ids(i), positions=positions(:,i), fields=fields(:,i), ermesg=ermesg)
        if(ermesg/='') print *,'ERROR after drifters_io_write: ', ermesg
     endif
  enddo

  ! advect
  
  do j = 1, nt
     time = time + dt
     positions(1, :) = positions(1, :) + u*dt
     positions(2, :) = positions(2, :) + v*dt
     fields(1, :) = sqrt( (positions(1,:)-xmin)**2 + (positions(2,:)-ymin)**2 )
     fields(2, :) = positions(1,:)-u*time + positions(2,:)-v*time ! invariant

     do i = 1, npmax
        x = positions(1,i)
        y = positions(2,i)
        if(x>=xmin .and. x<=xmax .and. y>=ymin .and. y<=ymax) then
           call drifters_io_write(drfts_io, time, np=1, nd=nd, nf=nf, &
                & ids=ids(i), positions=positions(:,i), fields=fields(:,i), ermesg=ermesg)
           if(ermesg/='') print *,'ERROR after drifters_io_write: ', ermesg
        endif
     enddo
     
  enddo

  deallocate(positions, ids, fields)

  call drifters_io_del(drfts_io, ermesg)
  if(ermesg/='') print *,'ERROR after drifters_io_del: ', ermesg

end program test
#endif 
! _TEST_DRIFTERS_IO


#undef _TYP
#define _TYP integer

! Written by Magnus Lie Hetland 

function qksrt_partition(n, list, start, end) result(top)
  implicit none
  integer, intent(in) :: n
  _TYP, intent(inout) :: list(n)
     integer, intent(in) :: start, end

     integer pivot, bottom, top
     logical done

     pivot = list(end)                          ! Partition around the last value
     bottom = start-1                           ! Start outside the area to be partitioned
     top = end                                  ! Ditto

     done = .false.
     do while (.not. done)                      ! Until all elements are partitioned...

        do while (.not. done)                  ! Until we find an out of place element...
           bottom = bottom+1                  ! ... move the bottom up.

           if(bottom == top) then             ! If we hit the top...
              done = .true.                  ! ... we are done.
              exit
           endif

           if(list(bottom) > pivot) then           ! Is the bottom out of place?
              list(top) = list(bottom)       ! Then put it at the top...
              exit                          ! ... and start searching from the top.
           endif
        enddo

        do while (.not. done)                        ! Until we find an out of place element...
           top = top-1                        ! ... move the top down.

           if(top == bottom) then                  ! If we hit the bottom...
              done = .true.                      ! ... we are done.
              exit
           endif

           if(list(top) < pivot) then              ! Is the top out of place?
              list(bottom) = list(top)       ! Then put it at the bottom...
              exit                          ! ...and start searching from the bottom.
           endif
        enddo
     enddo

     list(top) = pivot                          ! Put the pivot in its place.
     ! Return the split point

end function qksrt_partition

recursive subroutine qksrt_quicksort(n, list, start, end)
     implicit none
     integer, intent(in) :: n
     _TYP, intent(inout) :: list(n)
     integer, intent(in) :: start, end
     integer :: split, qksrt_partition
     external :: qksrt_partition
     if(start < end) then                            ! If there are two or more elements...
        split = qksrt_partition(n, list, start, end)    ! ... partition the sublist...
        call qksrt_quicksort(n, list,  start, split-1)        ! ... and sort both halves.
        call qksrt_quicksort(n, list, split+1, end)
     endif
end subroutine qksrt_quicksort


#ifdef _TEST_SORT
      program test
        implicit none
        integer :: list(16) = (/6, 2, 3, 4, 1, 45, 3432, 3245, 32545, 66555, 32, 1,3, -43254, 324, 54/)
        print *,'before list=', list
        call qksrt_quicksort(size(list), list, 1, size(list))
        print *,'after  list=', list
      end program test
#endif


module stock_constants_mod

  use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_sum
  use time_manager_mod, only : time_type, get_time
  use time_manager_mod, only : operator(+), operator(-)
  use diag_manager_mod, only : register_diag_field,send_data

  implicit none

  character(len=128), parameter :: version = '$Id: stock_constants.F90,v 17.0 2009/07/21 03:19:07 fms Exp $'


  integer,public,    parameter                :: NELEMS=3
  integer,           parameter                :: NELEMS_report=3
  integer,public,    parameter                :: ISTOCK_WATER=1, ISTOCK_HEAT=2, ISTOCK_SALT=3
  integer,public,    parameter                :: ISTOCK_TOP=1, ISTOCK_BOTTOM=2, ISTOCK_SIDE=3
  integer,public                              :: stocks_file
  ! Stock related stuff
  ! Shallow (no constructor) data structures holding the starting stock values (per PE) and
  ! flux integrated increments at present time.

  integer, parameter :: NSIDES  = 3         ! top, bottom, side
 
  type stock_type ! per PE values
     real  :: q_start = 0.0    ! total stocks at start time
     real  :: q_now   = 0.0    ! total stocks at time t    
     
     ! The dq's below are the stocks increments at the present time
     ! delta_t * surf integr of flux
     ! one for each side (ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE)
     real  :: dq(NSIDES)    = 0.0    ! stock increments at present time on the Ice   grid     
     real  :: dq_IN(NSIDES) = 0.0    ! stock increments at present time on the Ocean grid       
  end type stock_type

  type(stock_type), save, dimension(NELEMS) :: Atm_stock, Ocn_stock, Lnd_stock, Ice_stock
  type(time_type), save :: init_time

  public stocks_report
  public stocks_report_init
  public stocks_set_init_time

  integer,private,   parameter                :: NCOMPS=4
  integer,private,   parameter                :: ISTOCK_ATM=1,ISTOCK_LND=2,ISTOCK_ICE=3,ISTOCK_OCN=4
  character(len=3) , parameter, dimension(NCOMPS)  :: COMP_NAMES=(/'ATM', 'LND', 'ICE', 'OCN'/)


  character(len=5) , parameter, dimension(NELEMS)  :: STOCK_NAMES=(/'water', 'heat ', 'salt '/)
  character(len=12), parameter, dimension(NELEMS)  :: STOCK_UNITS=(/'[Kg]    ','[Joules]','[Kg]    '/)


contains


    subroutine stocks_report_init(Time)
    type(time_type)               , intent(in) :: Time

    character(len=80) :: formatString,space
    integer :: i,s
    real, dimension(NELEMS) :: val_atm, val_lnd, val_ice, val_ocn

    do i = 1, NELEMS_report
       val_atm(i) = Atm_stock(i)%q_start
       val_lnd(i) = Lnd_stock(i)%q_start
       val_ice(i) = Ice_stock(i)%q_start
       val_ocn(i) = Ocn_stock(i)%q_start
       call mpp_sum(val_atm(i))
       call mpp_sum(val_lnd(i))
       call mpp_sum(val_ice(i))
       call mpp_sum(val_ocn(i))
    enddo



    if(mpp_pe() == mpp_root_pe()) then
!       earth_area = 4.*PI*Radius**2

       write(stocks_file,*) '================Stocks Report Guide====================================='
       write(stocks_file,*) ' '
       write(stocks_file,*) 'S(t) = Total amount     of a tracer in the component model at time t.'
       write(stocks_file,*) '       Calculated via the component model itself.'
       write(stocks_file,*) ' '
       write(stocks_file,*) 'F(t) = Cumulative input of a tracer to the component model at time t.'
       write(stocks_file,*) '       Calculated via interchange of fluxes with other component models.'
       write(stocks_file,*) ' '
       write(stocks_file,*) 'S(t) - S(0) = Cumulative increase of the component stocks at time t'
       write(stocks_file,*) '              Calculated by the component itself.'
       write(stocks_file,*) ' '
       write(stocks_file,*) 'In a conserving component F(t)=S(t)-S(0) to within numerical accuracy.'
       write(stocks_file,*) ' '
       write(stocks_file,*) 'Component Model refers to one of OCN, ATM, LND or ICE'
       write(stocks_file,*) ''
       write(stocks_file,*) 'NOTE: When use_lag_fluxes=.true. is used in coupler, the ocean stocks '
       write(stocks_file,*) '      calculations are in error by an order which scales as the inverse'
       write(stocks_file,*) '      of the number of time steps.'
       write(stocks_file,*) ' '
       write(stocks_file,*) '======================================================================='       


       write(stocks_file,*) '======================Initial Stock S(0)==============================='       
!The following produces  formatString='(5x,a,a,12x,a,a, 9x)' but is general to handle more elements         
       formatString= '(5x'
       do i=1,NELEMS_report
          s = 25-len_trim(STOCK_NAMES(i))-len_trim(STOCK_UNITS(i))
          write(space,'(i2)') s 
          formatString= trim(formatString)//',a,a,'//trim(space)
          formatString= trim(formatString)//trim('x') 
       enddo
       formatString= trim(formatString)//')'
       
       write(stocks_file,formatString) (trim(STOCK_NAMES(i)),trim(STOCK_UNITS(i)), i=1,NELEMS_report)

!The following produces  formatString=' (a,x,es22.15,3x,es22.15,3x)' but is general to handle more elements
       formatString= '(a,x'
       do i=1,NELEMS_report
          write(space,'(i2)') s 
          formatString= trim(formatString)//',es22.15,3x'
       enddo
       formatString= trim(formatString)//')'
       
      
       write(stocks_file,formatString) 'ATM', (val_atm(i), i=1,NELEMS_report) 
       write(stocks_file,formatString) 'LND', (val_lnd(i), i=1,NELEMS_report)
       write(stocks_file,formatString) 'ICE', (val_ice(i), i=1,NELEMS_report)
       write(stocks_file,formatString) 'OCN', (val_ocn(i), i=1,NELEMS_report)

       write(stocks_file,*) '========================================================================'       
       write(stocks_file,'(a)'  ) ' '!blank line

    end if
    
    call stocks_set_init_time(Time)

  end subroutine stocks_report_init


  subroutine stocks_report(Time)
    type(time_type)               , intent(in) :: Time

    type(time_type) :: timeSinceStart
    type(stock_type) :: stck
    real, dimension(NCOMPS) :: f_value, f_ice_grid, f_ocn_grid, f_ocn_btf, q_start, q_now,c_value
    character(len=80) :: formatString
    integer :: iday0, isec0, iday, isec, hours
    real    :: days
    integer :: diagID , comp,elem,i
    integer, parameter :: initID = -2 ! initial value for diag IDs. Must not be equal to the value 
    ! that register_diag_field returns when it can't register the filed -- otherwise the registration 
    ! is attempted every time this subroutine is called

    integer, dimension(NCOMPS,NELEMS), save :: f_valueDiagID = initID
    integer, dimension(NCOMPS,NELEMS), save :: c_valueDiagID = initID
    integer, dimension(NCOMPS,NELEMS), save :: fmc_valueDiagID = initID
    integer, dimension(NCOMPS,NELEMS), save :: f_lostDiagID = initID

    real :: diagField
    logical :: used
    character(len=30) :: field_name, units

    if(mpp_pe()==mpp_root_pe()) then
       call get_time(init_time, isec0, iday0)
       call get_time(Time, isec, iday)
       
       hours = iday*24 + isec/3600 - iday0*24 - isec0/3600
       days  = hours/24.  
       write(stocks_file,*) '==============================================='
       write(stocks_file,'(a,f12.3)') 't = TimeSinceStart[days]= ',days 
       write(stocks_file,*) '==============================================='
    endif

    do elem = 1,NELEMS_report

       do comp = 1,NCOMPS

          if(comp == ISTOCK_ATM) stck = Atm_stock(elem)
          if(comp == ISTOCK_LND) stck = Lnd_stock(elem)
          if(comp == ISTOCK_ICE) stck = Ice_stock(elem)
          if(comp == ISTOCK_OCN) stck = Ocn_stock(elem)


          f_ice_grid(comp) = sum(stck%dq)
          f_ocn_grid(comp) = sum(stck%dq_IN)
          f_ocn_btf(comp)  = stck%dq_IN( ISTOCK_BOTTOM )

          q_start(comp) = stck%q_start
          q_now(comp)   = stck%q_now 

          call mpp_sum(f_ice_grid(comp))
          call mpp_sum(f_ocn_grid(comp))
          call mpp_sum(f_ocn_btf(comp))
          call mpp_sum(q_start(comp))
          call mpp_sum(q_now(comp))

          c_value(comp) = q_now(comp) - q_start(comp)

          if(mpp_pe() == mpp_root_pe()) then

             if(f_valueDiagID(comp,elem) == initID) then
                field_name = trim(COMP_NAMES(comp)) // trim(STOCK_NAMES(elem))
                field_name  = trim(field_name) // 'StocksChange_Flux'
                units = trim(STOCK_UNITS(elem))
                f_valueDiagID(comp,elem) = register_diag_field('stock_print', field_name, Time, &
                     units=units)
             endif

             if(c_valueDiagID(comp,elem) == initID) then
                field_name = trim(COMP_NAMES(comp)) // trim(STOCK_NAMES(elem))
                field_name = trim(field_name) // 'StocksChange_Comp'
                units = trim(STOCK_UNITS(elem))
                c_valueDiagID(comp,elem) = register_diag_field('stock_print', field_name, Time, &
                     units=units)
             endif

             if(fmc_valueDiagID(comp,elem) == initID) then
                field_name = trim(COMP_NAMES(comp)) // trim(STOCK_NAMES(elem))
                field_name = trim(field_name) // 'StocksChange_Diff'
                units = trim(STOCK_UNITS(elem))
                fmc_valueDiagID(comp,elem) = register_diag_field('stock_print', field_name, Time, &
                     units=units)
             endif

             f_value(comp) = f_ice_grid(comp)

             if(comp == ISTOCK_OCN) then

                f_value(comp) = f_ocn_grid(comp)

                if(f_lostDiagID(comp,elem) == initID) then
                   field_name = trim(COMP_NAMES(comp)) // trim(STOCK_NAMES(elem))
                   field_name = trim(field_name) // 'StocksExchangeLost'
                   units = trim(STOCK_UNITS(elem))
                   f_lostDiagID(comp,elem) = register_diag_field('stock_print', field_name, Time, &
                        units=units)
                endif

                DiagID=f_lostDiagID(comp,elem)
                diagField = f_ice_grid(comp) - f_ocn_grid(comp)
                if (DiagID > 0)  used = send_data(DiagID, diagField, Time)

             endif


             DiagID=f_valueDiagID(comp,elem)
             diagField = f_value(comp)
             if (DiagID > 0)  used = send_data(DiagID, diagField, Time)
             DiagID=c_valueDiagID(comp,elem)
             diagField = c_value(comp)
             if (DiagID > 0)  used = send_data(DiagID, diagField, Time)
             DiagID=fmc_valueDiagID(comp,elem)
             diagField = f_value(comp)-c_value(comp)
             if (DiagID > 0)  used = send_data(DiagID, diagField, Time)


             !             formatString = '(a,a,a,i16,2x,es22.15,2x,es22.15,2x,es22.15,2x,es22.15,2x,es22.15,2x,es22.15)'
             !
             !             write(stocks_file,formatString) trim(COMP_NAMES(comp)),STOCK_NAMES(elem),STOCK_UNITS(elem) &
             !                  ,hours, q_now, q_now-q_start, f_value, f_value - (q_now - q_start), (f_value - (q_now - q_start))/q_start


          endif
       enddo


       if(mpp_pe()==mpp_root_pe()) then
!          write(stocks_file,'(a)'  ) ' '!blank line
!          write(stocks_file,'(a,f12.3)') 't = TimeSinceStart[days]= ',days 
!          write(stocks_file,'(a)'  )   ' '!blank line
!          write(stocks_file,'(a,30x,a,20x,a,20x,a,20x,a)') 'Component ','ATM','LND','ICE','OCN'
!          write(stocks_file,'(55x,a,20x,a,20x,a,20x,a)')  'ATM','LND','ICE','OCN'
!          write(stocks_file,'(a,f12.3,12x,a,20x,a,20x,a,20x,a)') 't = TimeSinceStart[days]= ',days,'ATM','LND','ICE','OCN'

          write(stocks_file,'(a,a,40x,a,20x,a,20x,a,20x,a)') 'Stocks of ',trim(STOCK_NAMES(elem)),'ATM','LND','ICE','OCN'
          formatString = '(a,a,2x,es22.15,2x,es22.15,2x,es22.15,2x,es22.15)'

          write(stocks_file,formatString) 'Total =S(t)               ',STOCK_UNITS(elem),&
               ( q_now(i), i=1,NCOMPS)
          write(stocks_file,formatString) 'Change=S(t)-S(0)          ',STOCK_UNITS(elem),&
               ( q_now(i)-q_start(i), i=1,NCOMPS)
          write(stocks_file,formatString) 'Input =F(t)               ',STOCK_UNITS(elem),&
               ( f_value(i), i=1,NCOMPS)
          write(stocks_file,formatString) 'Diff  =F(t) - (S(t)-S(0)) ',STOCK_UNITS(elem),&
               ( f_value(i) - c_value(i), i=1,NCOMPS)                           
          write(stocks_file,formatString) 'Error =Diff/S(0)          ','[NonDim]    ', &
               ((f_value(i) - c_value(i))/(1+q_start(i)), i=1,NCOMPS)  !added 1 to avoid div by zero. Assuming q_start large          

          write(stocks_file,'(a)'  ) ' '!blank line
          formatString = '(a,a,a,6x,es22.15)'
          write(stocks_file,formatString) 'Lost Stocks in the exchange between Ice and Ocean ',trim(STOCK_NAMES(elem)),trim(STOCK_UNITS(elem)),  &
               f_ice_grid(ISTOCK_OCN) - f_ocn_grid(ISTOCK_OCN) + f_ocn_btf(ISTOCK_OCN)

          write(stocks_file,'(a)') ' ' !blank line  
          write(stocks_file,'(a)') ' ' !blank line

       endif
    enddo

  end subroutine stocks_report

  subroutine stocks_set_init_time(Time)
    type(time_type)     , intent(in) :: Time
    init_time = Time
    
  end subroutine stocks_set_init_time

end module stock_constants_mod


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! xgrid_mod - implements exchange grids.  An exchange grid is the grid whose
!             boundary set is the union of the boundaries of the participating
!             grids.  The exchange grid is the coarsest grid that is a 
!             refinement of each of the participating grids.  Every exchange
!             grid cell is a subarea of one and only one cell in each of the
!             participating grids.  The exchange grid has two purposes:
!
!               (1) The exchange cell areas are used as weights for
!                   conservative interpolation between model grids.
!
!               (2) Computation of surface fluxes takes place on it,
!                   thereby using the finest scale data obtainable.
!
!             The exchange cells are the 2D intersections between cells of the
!             participating grids.  They are computed elsewhere and are
!             read here from a NetCDF grid file as a sequence of quintuples
!             (i and j on each of two grids and the cell area).
!
!             Each processing element (PE) computes a subdomain of each of the
!             participating grids as well as a subset of the exchange cells.
!             The geographic regions corresponding to these subdomains will,
!             in general, not be the same so communication must occur between
!             the PEs.  The scheme for doing this is as follows.  A distinction
!             is drawn between the participating grids.  There is a single
!             "side 1" grid and it does not have partitions (sub-grid surface
!             types).  There are one or more "side 2" grids and they may have
!             more than 1 partition.  In standard usage, the atmosphere grid is
!             on side 1 and the land and sea ice grids are on side 2.  The set
!             of exchange cells computed on a PE corresponds to its side 2
!             geographic region(s).  Communication between the PEs takes place
!             on the side 1 grid.  Note:  this scheme does not generally allow
!             reproduction of answers across varying PE counts.  This is
!             because, in the side 1 "get", exchange cells are first summed
!             locally onto a side 1 grid, then these side 1 contributions are
!             further summed after they have been communicated to their target
!             PE.  For the make_exchange_reproduce option, a special side 1 get
!             is used.  This get communicates individual exchange cells.  The
!             cells are summed in the order they appear in the grid spec. file.
!                                    Michael Winton (Michael.Winton@noaa.gov) Oct 2001
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
module xgrid_mod

! <CONTACT EMAIL="Michael.Winton@noaa.gov">
!   Michael Winton
! </CONTACT>
! <CONTACT EMAIL="Zhi.Liang@noaa.gov">
!   Zhi Liang
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!    <TT>xgrid_mod</TT> implements exchange grids for coupled models running on
!     multiple processors.  An exchange grid is formed from the union of
!     the bounding lines of the two (logically rectangular) participating
!     grids.  The exchange grid is therefore the coarsest grid that is a
!     refinement of both participating grids.  Exchange grids are used for
!     two purposes by coupled models:  (1) conservative interpolation of fields
!     between models uses the exchange grid cell areas as weights and
!     (2) the surface flux calculation takes place on the exchange grid thereby
!     using the finest scale data available.  <TT>xgrid_mod</TT> uses a NetCDF grid
!     specification file containing the grid cell overlaps in combination with
!     the <LINK SRC="ftp://ftp.gfdl.gov/pub/vb/mpp/mpp_domains.F90">
!     <TT>mpp_domains</TT></LINK> domain decomposition information to determine 
!     the grid and processor connectivities.
! </OVERVIEW>

! <DESCRIPTION>
!     <TT>xgrid_mod</TT> is initialized with a list of model identifiers (three characters
!     each), a list of <TT>mpp_domains</TT> domain data structures, and a grid specification
!     file name.  The first element in the lists refers to the "side one" grid.
!     The remaining elements are on "side two".  Thus, there may only be a single
!     side one grid and it is further restricted to have no partitions (sub-grid
!     areal divisions).  In standard usage, the atmosphere model is on side one
!     and the land and sea ice models are on side two.  <TT>xgrid_mod</TT> performs
!     interprocessor communication on the side one grid.  Exchange grid variables
!     contain no data for zero sized partitions.  The size and format of exchange
!     grid variables change every time the partition sizes or number of partitions
!     are modified with a <TT>set_frac_area</TT> call on a participating side two grid.
!     Existing exchange grid variables cannot be properly interpreted after
!     that time; new ones must be allocated and assigned with the <TT>put_to_xgrid</TT>
!     call.
! </DESCRIPTION>

! <DATA NAME="xmap_type"  TYPE=""  >
!   The fields of xmap_type are all private.
! </DATA>

! <DATASET NAME="">
!     <TT>xgrid_mod</TT> reads a NetCDF grid specification file to determine the
!     grid and processor connectivities.  The exchange grids are defined
!     by a sequence of quintuples:  the <TT>i/j</TT> indices of the intersecting
!     cells of the two participating grids and their areal overlap.
!     The names of the five fields are generated automatically from the
!     three character ids of the participating grids.  For example, if
!     the side one grid id is "ATM" and the side two grid id is "OCN",
!     <TT>xgrid_mod</TT> expects to find the following five fields in the grid
!     specification file:  <TT>I_ATM_ATMxOCN, J_ATM_ATMxOCN, I_OCN_ATMxOCN,
!     J_OCN_ATMxOCN, and AREA_ATMxOCN</TT>.  These fields may be generated
!     by the <TT>make_xgrids</TT> utility.
! </DATASET>
use       fms_mod,   only: file_exist, open_namelist_file, check_nml_error,  &
                           error_mesg, close_file, FATAL, NOTE, stdlog,      &
                           write_version_number, read_data, field_exist,     &
                           field_size, lowercase, string,                    &
                           get_mosaic_tile_grid
use mpp_mod,         only: mpp_npes, mpp_pe, mpp_root_pe, mpp_send, mpp_recv, &
                           mpp_sync_self, stdout, mpp_max
use mpp_mod,         only: input_nml_file
use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_compute_domains, &
                           Domain2d, mpp_global_sum, mpp_update_domains,    &
                           mpp_modify_domain, mpp_get_data_domain, XUPDATE, &
                           YUPDATE, mpp_get_current_ntile, mpp_get_tile_id, &
                           mpp_get_ntile_count, mpp_get_tile_list,          &
                           mpp_get_global_domain
use mpp_io_mod,      only: mpp_open, MPP_MULTI, MPP_SINGLE, MPP_OVERWR
use constants_mod,   only: PI
use mosaic_mod,          only: get_mosaic_xgrid, get_mosaic_xgrid_size
use stock_constants_mod, only: ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, STOCK_NAMES, STOCK_UNITS, NELEMS, stocks_file, stock_type
use gradient_mod,        only: gradient_cubic

implicit none
private

public xmap_type, setup_xmap, set_frac_area, put_to_xgrid, get_from_xgrid, &
       xgrid_count, some, conservation_check, xgrid_init, &
       AREA_ATM_SPHERE, AREA_LND_SPHERE, AREA_OCN_SPHERE, &
       AREA_ATM_MODEL, AREA_LND_MODEL, AREA_OCN_MODEL, &
       get_ocean_model_area_elements, grid_box_type,   &
       get_xmap_grid_area

!--- paramters that determine the remapping method
integer, parameter :: FIRST_ORDER        = 1
integer, parameter :: SECOND_ORDER       = 2
integer, parameter :: VERSION1           = 1 ! grid spec file
integer, parameter :: VERSION2           = 2 ! mosaic grid file

! <NAMELIST NAME="xgrid_nml">
!   <DATA NAME="make_exchange_reproduce" TYPE="logical"  DEFAULT=".false.">
!     Set to .true. to make <TT>xgrid_mod</TT> reproduce answers on different
!     numbers of PEs.  This option has a considerable performance impact.
!   </DATA>
!   <DATA NAME="interp_method" TYPE="character(len=64)"  DEFAULT=" 'first_order' ">
!     exchange grid interpolation method. It has two options: 
!     "first_order", "second_order".
!   </DATA>
!   <DATA NAME="xgrid_log" TYPE="logical"  DEFAULT=" .false. ">
!     Outputs exchange grid information to xgrid.out.<pe> for debug/diag purposes.
!   </DATA>
logical :: make_exchange_reproduce = .false. ! exactly same on different # PEs
logical :: xgrid_log = .false. 
character(len=64) :: interp_method = 'first_order'
logical :: debug_stocks = .false. 
namelist /xgrid_nml/ make_exchange_reproduce, interp_method, debug_stocks, xgrid_log
! </NAMELIST>
logical :: init = .true.
integer :: remapping_method

! Area elements used inside each model
real, allocatable, dimension(:,:) :: AREA_ATM_MODEL, AREA_LND_MODEL, AREA_OCN_MODEL
! Area elements based on a the spherical model used by the ICE layer
real, allocatable, dimension(:,:) :: AREA_ATM_SPHERE, AREA_LND_SPHERE, AREA_OCN_SPHERE

! <INTERFACE NAME="put_to_xgrid">

!   <OVERVIEW>
!     Scatters data from model grid onto exchange grid.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Scatters data from model grid onto exchange grid.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call put_to_xgrid(d, grid_id, x, xmap, remap_order)
!   </TEMPLATE>
!   <IN NAME="d"  TYPE="real"  > </IN>
!   <IN NAME="grid_id"  TYPE=" character(len=3)"  > </IN>
!   <INOUT NAME="x"  TYPE="real"  > </INOUT>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>
!   <IN NAME="remap_method" TYPE="integer,optional">
!     exchange grid interpolation method. It has four possible values: 
!     FIRST_ORDER (=1), SECOND_ORDER(=2). Default value is FIRST_ORDER.
!   </IN>
interface put_to_xgrid
  module procedure put_side1_to_xgrid
  module procedure put_side2_to_xgrid
end interface
! </INTERFACE>

! <INTERFACE NAME="get_from_xgrid">

!   <OVERVIEW>
!     Sums data from exchange grid to model grid.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Sums data from exchange grid to model grid.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_from_xgrid(d, grid_id, x, xmap)
!   </TEMPLATE>
!   <IN NAME="x"  TYPE="real"  > </IN>
!   <IN NAME="grid_id"  TYPE=" character(len=3)"  > </IN>
!   <OUT NAME="d"  TYPE="real"  > </OUT>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>
interface get_from_xgrid
  module procedure get_side1_from_xgrid
  module procedure get_side2_from_xgrid
end interface
! </INTERFACE>

! <INTERFACE NAME="conservation_check">

!   <OVERVIEW>
!     Returns three numbers which are the global sum of a variable.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns three numbers which are the global sum of a
!     variable (1) on its home model grid, (2) after interpolation to the other
!     side grid(s), and (3) after re_interpolation back onto its home side grid(s).
!     Conservation_check must be called by all PEs to work properly.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call conservation_check(d, grid_id, xmap,remap_order)
!   </TEMPLATE>
!   <IN NAME="d"  TYPE="real" DIM="(:,:)" > </IN>
!   <IN NAME="grid_id"  TYPE="character(len=3)"  > </IN>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>
!   <OUT NAME="" TYPE="real" DIM="3">The global sum of a variable.</OUT>
!   <IN NAME="remap_method" TYPE="integer,optional">
!   </IN>
interface conservation_check
  module procedure conservation_check_side1
  module procedure conservation_check_side2
end interface
! </INTERFACE>

type xcell_type
  integer :: i1, j1, i2, j2 ! indices of cell in model arrays on both sides
  integer :: pe             ! other side pe that has this cell
  integer :: tile           ! tile index of side 1 mosaic.
  real    :: area           ! geographic area of exchange cell
!  real    :: area1_ratio     !(= x_area/grid1_area), will be added in the future to improve efficiency
!  real    :: area2_ratio     !(= x_area/grid2_area), will be added in the future to improve efficiency
  real    :: di, dj         ! Weight for the gradient of flux
  real    :: scale
end type xcell_type

type grid_box_type
   real, dimension(:,:),   pointer :: dx     => NULL()
   real, dimension(:,:),   pointer :: dy     => NULL()
   real, dimension(:,:),   pointer :: area   => NULL()
   real, dimension(:),     pointer :: edge_w => NULL()
   real, dimension(:),     pointer :: edge_e => NULL()
   real, dimension(:),     pointer :: edge_s => NULL()
   real, dimension(:),     pointer :: edge_n => NULL()
   real, dimension(:,:,:), pointer :: en1    => NULL()
   real, dimension(:,:,:), pointer :: en2    => NULL()
   real, dimension(:,:,:), pointer :: vlon   => NULL()
   real, dimension(:,:,:), pointer :: vlat   => NULL()
end type grid_box_type

type grid_type
  character(len=3)                :: id                               ! grid identifier
  integer                         :: ntile                            ! number of tiles in mosaic
  integer                         :: ni, nj                           ! max of global size of all the tiles
  integer, pointer, dimension(:)  :: tile =>NULL()                    ! tile id ( pe index )
  integer, pointer, dimension(:)  :: is =>NULL(), ie =>NULL()         ! domain - i-range (pe index)
  integer, pointer, dimension(:)  :: js =>NULL(), je =>NULL()         ! domain - j-range (pe index)
  integer, pointer                :: is_me =>NULL(),  ie_me =>NULL()  ! my domain - i-range
  integer, pointer                :: js_me =>NULL(),  je_me =>NULL()  ! my domain - j-range
  integer                         :: isd_me, ied_me                   ! my data domain - i-range
  integer                         :: jsd_me, jed_me                   ! my data domain - j-range
  integer, pointer                :: tile_me                          ! my tile id
  integer                         :: im , jm , km                     ! global domain range
  real, pointer, dimension(:)     :: lon =>NULL(), lat =>NULL()       ! center of global grids
  real, pointer, dimension(:,:)   :: geolon=>NULL(), geolat=>NULL()   ! geographical grid center
  real, pointer, dimension(:,:,:) :: frac_area =>NULL()               ! partition fractions
  real, pointer, dimension(:,:)   :: area =>NULL()                    ! cell area
  real, pointer, dimension(:,:)   :: area_inv =>NULL()                ! 1 / area for normalization
  integer                         :: first, last                      ! xgrid index range
  integer                         :: size                             ! # xcell patterns
  type(xcell_type), pointer       :: x(:) =>NULL()                    ! xcell patterns
  integer                         :: size_repro                       ! # side 1 patterns for repro
  type(xcell_type), pointer       :: x_repro(:) =>NULL()              ! side 1 patterns for repro
  type(Domain2d)                  :: domain                           ! used for conservation checks
  type(Domain2d)                  :: domain_with_halo                 ! used for second order remapping
  logical                         :: is_latlon                        ! indicate if the grid is lat-lon grid or not.
  type(grid_box_type)             :: box                              ! used for second order remapping.
end type grid_type

type x1_type
  integer :: i, j
  real    :: area   ! (= geographic area * frac_area)
!  real    :: area_ratio !(= x1_area/grid1_area) ! will be added in the future to improve efficiency
  real    :: di, dj ! weight for the gradient of flux
  integer :: tile           ! tile index of side 1 mosaic.
end type x1_type

type x2_type
  integer :: i, j, k
  real    :: area   ! geographic area of exchange cell
!  real    :: area_ratio !(=x2_area/grid2_area )  ! will be added in the future to improve efficiency
end type x2_type

type xmap_type
  private
  integer :: size            ! # of exchange grid cells with area > 0 on this pe

  integer :: me, npes, root_pe
  logical, pointer, dimension(:) :: your1my2  =>NULL()! true if side 1 domain on
                                                      ! indexed pe overlaps side 2
                                                      ! domain on this pe
  logical, pointer, dimension(:) :: your2my1 =>NULL() ! true if a side 2 domain on
                                                      ! indexed pe overlaps side 1
                                                      ! domain on this pe

  type (grid_type), pointer, dimension(:) :: grids =>NULL() ! 1st grid is side 1;
                                                            ! rest on side 2
  !
  ! Description of the individual exchange grid cells (index is cell #)
  !
  type(x1_type), pointer, dimension(:) :: x1 =>NULL() ! side 1 info
  type(x2_type), pointer, dimension(:) :: x2 =>NULL() ! side 2 info

  real, pointer,    dimension(:) :: send_buffer =>NULL() ! for non-blocking sends
  real, pointer,    dimension(:) :: recv_buffer =>NULL() ! for non-blocking recv
  integer, pointer, dimension(:) :: send_count_repro =>NULL()
  integer, pointer, dimension(:) :: recv_count_repro  =>NULL()
  integer :: version                                  ! version of xgrids. version=VERSION! is for grid_spec file 
                                                      ! and version=VERSION2 is for mosaic grid.
end type xmap_type

!-----------------------------------------------------------------------
 character(len=128) :: version = '$Id: xgrid.F90,v 18.0.10.1 2010/08/31 14:28:51 z1l Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

 real, parameter                              :: EPS = 1.0e-10
 logical :: module_is_initialized = .FALSE.

 ! The following is required to compute stocks of water, heat, ...

  interface stock_move
     module procedure stock_move_3d, stock_move_2d
  end interface

  public stock_move, stock_type, stock_print, get_index_range, stock_integrate_2d
  public FIRST_ORDER, SECOND_ORDER

contains

!#######################################################################

logical function in_box(i, j, is, ie, js, je)
integer :: i, j, is, ie, js, je

  in_box = (i>=is) .and. (i<=ie) .and. (j>=js) .and. (j<=je)
end function in_box

!#######################################################################

! <SUBROUTINE NAME="xgrid_init">

!   <OVERVIEW>
!     Initialize the xgrid_mod. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     Initialization routine for the xgrid module. It reads the xgrid_nml,  
!     writes the version information and xgrid_nml to the log file.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call xgrid_init ( )
!   </TEMPLATE>
!   <OUT NAME="remap_method" TYPE="integer">
!     exchange grid interpolation method. It has four possible values: 
!     FIRST_ORDER (=1), SECOND_ORDER(=2).
!   </OUT>
subroutine xgrid_init(remap_method) 
  integer, intent(out) :: remap_method

  integer :: unit, ierr, io

  if (module_is_initialized) return
  module_is_initialized = .TRUE.

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, xgrid_nml, iostat=io)
#else
  if ( file_exist( 'input.nml' ) ) then
      unit = open_namelist_file ( )
      ierr = 1
      do while ( ierr /= 0 )
        read ( unit,  nml = xgrid_nml, iostat = io, end = 10 )
        ierr = check_nml_error ( io, 'xgrid_nml' )
      enddo
  10 continue
      call close_file ( unit )
  endif
#endif

!--------- write version number and namelist ------------------
  call write_version_number (version, tagname)

  unit = stdlog ( )
  if ( mpp_pe() == mpp_root_pe() ) write (unit,nml=xgrid_nml)
  call close_file (unit)

!--------- check interp_method has suitable value

  select case(trim(interp_method))
  case('first_order')
     remap_method = FIRST_ORDER
  case('second_order')
     remap_method = SECOND_ORDER
  case default
     call error_mesg('xgrid_mod', ' nml interp_method = ' //trim(interp_method)// &
      ' is not a valid namelist option', FATAL)
  end select
  
  remapping_method = remap_method

end subroutine xgrid_init
! </SUBROUTINE>

!#######################################################################

subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, use_higher_order)
type(xmap_type), intent(inout)         :: xmap
type(grid_type), intent(inout)         :: grid
character(len=*), intent(in)           :: grid_file
character(len=3), intent(in)           :: grid1_id, grid_id
integer,          intent(in)           :: tile1, tile2
logical,        intent(in)             :: use_higher_order

  integer, allocatable, dimension(:) :: i1, j1, i2, j2            ! xgrid quintuples
  real,    allocatable, dimension(:) :: area, di, dj              ! from grid file
  type (grid_type), pointer, save    :: grid1 =>NULL()
  integer                            :: l, ll, ll_repro, p, siz(4), nxgrid, size_prev
  type(xcell_type), allocatable      :: x_local(:)
  integer                            :: size_repro, out_unit
  logical                            :: scale_exist = .false.
  real,    allocatable, dimension(:) :: scale


  scale_exist = .false.
  grid1 => xmap%grids(1)
  out_unit = stdout()
  select case(xmap%version)
  case(VERSION1)
     call field_size(grid_file, 'AREA_'//grid1_id//'x'//grid_id, siz)
     nxgrid = siz(1);
     if(nxgrid .LE. 0) return
     allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), area(nxgrid))
     call read_data(grid_file, 'I_'//grid1_id//'_'//grid1_id//'x'//grid_id, i1)
     call read_data(grid_file, 'J_'//grid1_id//'_'//grid1_id//'x'//grid_id, j1)
     call read_data(grid_file, 'I_'//grid_id//'_'//grid1_id//'x'//grid_id, i2)
     call read_data(grid_file, 'J_'//grid_id//'_'//grid1_id//'x'//grid_id, j2)
     call read_data(grid_file, 'AREA_'//grid1_id//'x'//grid_id, area)
     if(use_higher_order) then
        allocate(di(nxgrid), dj(nxgrid))
        call read_data(grid_file, 'DI_'//grid1_id//'x'//grid_id, di)
        call read_data(grid_file, 'DJ_'//grid1_id//'x'//grid_id, dj)
     end if
  case(VERSION2)
     !--- max_size is the exchange grid size between super grid.
     nxgrid = get_mosaic_xgrid_size(grid_file)
     allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), area(nxgrid) )
     if(use_higher_order) then
        allocate(di(nxgrid), dj(nxgrid))
        call get_mosaic_xgrid(grid_file, i1, j1, i2, j2, area, di, dj)
     else
        call get_mosaic_xgrid(grid_file, i1, j1, i2, j2, area)
     end if
     !--- if field "scale" exist, read this field. Normally this 
     !--- field only exist in landXocean exchange grid cell.
     if(grid1_id == 'LND' .AND. grid_id == 'OCN') then
        if(field_exist(grid_file, "scale")) then
           allocate(scale(nxgrid))
           write(out_unit, *)"NOTE from load_xgrid(xgrid_mod): field 'scale' exist in the file "// &
               trim(grid_file)//", this field will be read and the exchange grid cell area will be multiplied by scale"
           call read_data(grid_file, "scale", scale)
           scale_exist = .true.
        endif
     endif
  end select

  size_repro = 0
  if(grid1%tile_me == tile1) then
     do l=1,nxgrid
        if (in_box(i1(l), j1(l), grid1%is_me, grid1%ie_me, grid1%js_me, grid1%je_me) ) then
           grid1%area(i1(l),j1(l)) = grid1%area(i1(l),j1(l))+area(l)
           do p=0,xmap%npes-1
              if (grid%tile(p) == tile2) then
                 if (in_box(i2(l), j2(l), grid%is(p), grid%ie(p), grid%js(p), grid%je(p)))  then
                    xmap%your2my1(p) = .true.
                 end if
              end if
           end do
           size_repro = size_repro + 1
        end if
     end do
  end if

  size_prev = grid%size

  if(grid%tile_me == tile2) then
     do l=1,nxgrid
        if (in_box(i2(l), j2(l), grid%is_me, grid%ie_me, grid%js_me, grid%je_me) ) then
           grid%size = grid%size + 1
           grid%area(i2(l),j2(l)) = grid%area(i2(l),j2(l))+area(l)
           do p=0,xmap%npes-1
              if(grid1%tile(p) == tile1) then
                 if (in_box(i1(l), j1(l), grid1%is(p), grid1%ie(p), &
                      grid1%js(p), grid1%je(p))) then
                    xmap%your1my2(p) = .true.
                 end if
              end if
           end do
        end if
     end do
  end if

  if(grid%size > size_prev) then
     if(size_prev > 0) then ! need to extend data
        allocate(x_local(size_prev))
        x_local = grid%x
        if(ASSOCIATED(grid%x)) deallocate(grid%x)
        allocate( grid%x( grid%size ) )
        grid%x(1:size_prev) = x_local
        deallocate(x_local)
     else
        allocate( grid%x( grid%size ) )
        grid%x%di = 0; grid%x%dj = 0
     end if
  end if

  ll = size_prev
  if( grid%tile_me == tile2 ) then ! me is tile2
     do l=1,nxgrid
        if (in_box(i2(l), j2(l), grid%is_me, grid%ie_me, grid%js_me, grid%je_me)) then
           ! insert in this grids cell pattern list and add area to side 2 area
           ll = ll + 1
           grid%x(ll)%i1   = i1(l); grid%x(ll)%i2   = i2(l)
           grid%x(ll)%j1   = j1(l); grid%x(ll)%j2   = j2(l)
           grid%x(ll)%tile = tile1
           grid%x(ll)%area = area(l)
           if(scale_exist) then
              grid%x(ll)%scale = scale(l)
           else
              grid%x(ll)%scale = 1
           endif
           if(use_higher_order) then
              grid%x(ll)%di  = di(l)
              grid%x(ll)%dj  = dj(l)
           end if

           if (make_exchange_reproduce) then
              do p=0,xmap%npes-1
                 if(grid1%tile(p) == tile1) then
                    if (in_box(i1(l), j1(l), grid1%is(p), grid1%ie(p), &
                         grid1%js(p), grid1%je(p))) then
                       grid%x(ll)%pe = p + xmap%root_pe
                    end if
                 end if
              end do
           end if ! make_exchange reproduce
        end if
     end do
  end if

  if (make_exchange_reproduce .and. grid1%tile_me == tile1 .and. size_repro > 0) then
     ll_repro = grid%size_repro
     grid%size_repro = ll_repro + size_repro
     if(ll_repro > 0) then  ! extend data
        allocate(x_local(ll_repro))
        x_local = grid%x_repro
        if(ASSOCIATED(grid%x_repro)) deallocate(grid%x_repro)
        allocate( grid%x_repro(grid%size_repro ) )
        grid%x_repro(1:ll_repro) = x_local
        deallocate(x_local)
     else
        allocate( grid%x_repro( grid%size_repro ) )
        grid%x_repro%di = 0; grid%x_repro%dj = 0
     end if
     do l=1,nxgrid
        if (in_box(i1(l),j1(l), grid1%is_me,grid1%ie_me, grid1%js_me,grid1%je_me) ) then
           ll_repro = ll_repro + 1
           grid%x_repro(ll_repro)%i1   = i1(l); grid%x_repro(ll_repro)%i2   = i2(l)
           grid%x_repro(ll_repro)%j1   = j1(l); grid%x_repro(ll_repro)%j2   = j2(l)
           grid%x_repro(ll_repro)%tile = tile1
           grid%x_repro(ll_repro)%area = area(l)
           if(use_higher_order) then
              grid%x_repro(ll_repro)%di  = di(l)
              grid%x_repro(ll_repro)%dj  = dj(l)
           end if

           do p=0,xmap%npes-1
              if(grid%tile(p) == tile2) then
                 if (in_box(i2(l), j2(l), grid%is(p), grid%ie(p), &
                      grid%js(p), grid%je(p))) then
                    grid%x_repro(ll_repro)%pe = p + xmap%root_pe
                 end if
              end if
           end do
        end if ! make_exchange_reproduce
     end do
  end if

  deallocate(i1, j1, i2, j2, area)
  if(use_higher_order) deallocate(di, dj)
  if(scale_exist) deallocate(scale)

end subroutine load_xgrid

!#######################################################################
!
! get_grid - read the center point of the grid from grid_spec.nc.
!          - only the grid at the side 1 is needed, so we only read 
!          - atm and land grid
!
!

subroutine get_grid(grid, grid_id, grid_file, grid_version)
  type(grid_type), intent(inout) :: grid
  character(len=3), intent(in)   :: grid_id
  character(len=*), intent(in)   :: grid_file
  integer,          intent(in)   :: grid_version

  real, dimension(grid%im) :: lonb
  real, dimension(grid%jm) :: latb
  real, allocatable        :: tmpx(:,:), tmpy(:,:)
  real                     :: d2r
  integer                  :: is, ie, js, je, nlon, nlat, siz(4), i, j

  d2r = PI/180.0

  call mpp_get_compute_domain(grid%domain, is, ie, js, je)

  select case(grid_version)
  case(VERSION1)
     allocate(grid%lon(grid%im), grid%lat(grid%jm))
     if(grid_id == 'ATM') then
        call read_data(grid_file, 'xta', lonb)
        call read_data(grid_file, 'yta', latb)

        if(.not. allocated(AREA_ATM_MODEL)) then
           allocate(AREA_ATM_MODEL(is:ie, js:je))
           call get_area_elements(grid_file, 'AREA_ATM_MODEL', grid%domain, AREA_ATM_MODEL)
        endif
        if(.not. allocated(AREA_ATM_SPHERE)) then
           allocate(AREA_ATM_SPHERE(is:ie, js:je))
           call get_area_elements(grid_file, 'AREA_ATM', grid%domain, AREA_ATM_SPHERE)
        endif
     else if(grid_id == 'LND') then
        call read_data(grid_file, 'xtl', lonb)
        call read_data(grid_file, 'ytl', latb)
        if(.not. allocated(AREA_LND_MODEL)) then
           allocate(AREA_LND_MODEL(is:ie, js:je))
           call get_area_elements(grid_file, 'AREA_LND_MODEL', grid%domain, AREA_LND_MODEL)
        endif
        if(.not. allocated(AREA_LND_SPHERE)) then
           allocate(AREA_LND_SPHERE(is:ie, js:je))
           call get_area_elements(grid_file, 'AREA_LND', grid%domain, AREA_LND_SPHERE)
        endif
     else if(grid_id == 'OCN' ) then
        if(.not. allocated(AREA_OCN_SPHERE)) then
           allocate(AREA_OCN_SPHERE(is:ie, js:je))
           call get_area_elements(grid_file, 'AREA_OCN', grid%domain, AREA_OCN_SPHERE)
        endif
     endif
     !--- second order remapping suppose second order
     if(grid_id == 'LND' .or. grid_id == 'ATM') then
        grid%lon   = lonb * d2r
        grid%lat   = latb * d2r
     endif
     grid%is_latlon = .true.
  case(VERSION2)
     call field_size(grid_file, 'area', siz)
     nlon = siz(1); nlat = siz(2)
     if( mod(nlon,2) .NE. 0) call error_mesg('xgrid_mod',  &
          'flux_exchange_mod: atmos supergrid longitude size can not be divided by 2', FATAL)
     if( mod(nlat,2) .NE. 0) call error_mesg('xgrid_mod',  &
          'flux_exchange_mod: atmos supergrid latitude size can not be divided by 2', FATAL)
     nlon = nlon/2
     nlat = nlat/2
     if(nlon .NE. grid%im .OR. nlat .NE. grid%jm) call error_mesg('xgrid_mod', &
         'grid size in tile_file does not match the global grid size', FATAL)
     allocate(tmpx(nlon*2+1, nlat*2+1), tmpy(nlon*2+1, nlat*2+1))
     call read_data( grid_file, 'x', tmpx, no_domain=.true.)
     call read_data( grid_file, 'y', tmpy, no_domain=.true.) 
     if( grid_id == 'LND' .or. grid_id == 'ATM') then
        if(is_lat_lon(tmpx, tmpy) ) then
           allocate(grid%lon(grid%im), grid%lat(grid%jm))
           do i = 1, grid%im
              grid%lon(i) = tmpx(2*i,2) * d2r
           end do
           do j = 1, grid%jm
              grid%lat(j) = tmpy(2, 2*j) * d2r
           end do
           grid%is_latlon = .true.
        else
           allocate(grid%geolon(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me))
           allocate(grid%geolat(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me))
           grid%geolon = 1e10
           grid%geolat = 1e10
           !--- area_ocn_sphere, area_lnd_sphere, area_atm_sphere is not been defined.
           do j = grid%js_me,grid%je_me
              do i = grid%is_me,grid%ie_me
                 grid%geolon(i, j) = tmpx(i*2,j*2)*d2r
                 grid%geolat(i, j) = tmpy(i*2,j*2)*d2r
              end do
           end do
           call mpp_update_domains(grid%geolon, grid%domain)
           call mpp_update_domains(grid%geolat, grid%domain)
           grid%is_latlon = .false.
        end if
     end if
     deallocate(tmpx, tmpy)
  end select

  return

end subroutine get_grid
  
!#######################################################################
! Read the area elements from NetCDF file
subroutine get_area_elements(file, name, domain, data)
  character(len=*), intent(in) :: file
  character(len=*), intent(in) :: name
  type(domain2d),   intent(in) :: domain
  real, intent(out)            :: data(:,:)

  if(field_exist(file, name)) then
     call read_data(file, name, data, domain)
  else
     call error_mesg('xgrid_mod', 'no field named '//trim(name)//' in grid file '//trim(file)// &
                     ' Will set data to negative values...', NOTE)
     ! area elements no present in grid_spec file, set to negative values....
     data = -1
  endif    

end subroutine get_area_elements

!#######################################################################
! Read the OCN model area elements from NetCDF file
! <SUBROUTINE NAME="get_ocean_model_area_elements">

!   <OVERVIEW>
!      Read Ocean area element data.
!   </OVERVIEW>
!   <DESCRIPTION>
!      If available in the NetCDF file, this routine will read the 
!      AREA_OCN_MODEL field and load the data into global AREA_OCN_MODEL.
!      If not available, then the array AREA_OCN_MODEL will be left
!      unallocated. Must be called by all PEs.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_ocean_model_area_elements(ocean_domain, grid_file)
!   </TEMPLATE>

!   <IN NAME="ocean_domain" TYPE="type(Domain2d)"> </IN>
!   <IN NAME="grid_file" TYPE="character(len=*)" > </IN>
subroutine get_ocean_model_area_elements(domain, grid_file)

  type(Domain2d), intent(in) :: domain
  character(len=*), intent(in) :: grid_file
  integer :: is, ie, js, je

  if(allocated(AREA_OCN_MODEL)) return

  call mpp_get_compute_domain(domain, is, ie, js, je)
  ! allocate even if ie<is, ... in which case the array will have zero size
  ! but will still return .T. for allocated(...)
  allocate(AREA_OCN_MODEL(is:ie, js:je))
  if(ie < is .or. je < js ) return


  if(field_exist(grid_file, 'AREA_OCN_MODEL') )then
     call read_data(grid_file, 'AREA_OCN_MODEL', AREA_OCN_MODEL, domain)
  else
     deallocate(AREA_OCN_MODEL)
  endif


end subroutine get_ocean_model_area_elements
! </SUBROUTINE>
!#######################################################################

! <SUBROUTINE NAME="setup_xmap">

!   <OVERVIEW>
!      Sets up exchange grid connectivity using grid specification file and
!      processor domain decomposition. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Sets up exchange grid connectivity using grid specification file and
!      processor domain decomposition. Initializes xmap.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid)
!   </TEMPLATE>

!   <IN NAME="grid_ids" TYPE="character(len=3)" DIM="(:)"> </IN>
!   <IN NAME="grid_domains" TYPE="type(Domain2d)" DIM="(:)"> </IN>
!   <IN NAME="grid_file" TYPE="character(len=*)" > </IN>
!   <IN NAME="atmos_grid" TYPE="type(grid_box_type),optional" > </IN>
!   <OUT NAME="xmap" TYPE="xmap_type"  > </OUT>

subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid)
  type (xmap_type),                        intent(inout) :: xmap
  character(len=3), dimension(:),            intent(in ) :: grid_ids
  type(Domain2d), dimension(:),              intent(in ) :: grid_domains
  character(len=*),                          intent(in ) :: grid_file
  type(grid_box_type), optional,             intent(in ) :: atm_grid

  integer :: g,     p, send_size, recv_size, i, siz(4)
  integer :: unit, nxgrid_file, i1, i2, i3, tile1, tile2, j
  integer :: nxc, nyc, out_unit
  type (grid_type), pointer, save :: grid =>NULL(), grid1 =>NULL()
  real, dimension(3) :: xxx
  real, dimension(:,:), allocatable   :: check_data
  real, dimension(:,:,:), allocatable :: check_data_3D
  character(len=256)                  :: xgrid_file, xgrid_name
  character(len=256)                  :: tile_file, mosaic_file
  character(len=256)                  :: mosaic1, mosaic2, contact
  character(len=256)                  :: tile1_name, tile2_name
  character(len=256),     allocatable :: tile1_list(:), tile2_list(:)
  logical :: use_higher_order = .false.

  if(interp_method .ne. 'first_order')  use_higher_order = .true.

  out_unit = stdout()
  xmap%me   = mpp_pe  ()
  xmap%npes = mpp_npes()
  xmap%root_pe = mpp_root_pe()

  allocate( xmap%grids(1:size(grid_ids(:))) )

  allocate ( xmap%your1my2(0:xmap%npes-1), xmap%your2my1(0:xmap%npes-1) )

  xmap%your1my2 = .false.; xmap%your2my1 = .false.;

!  check the exchange grid file version to be used by checking the field in the file
  if(field_exist(grid_file, "AREA_ATMxOCN" ) ) then
     xmap%version = VERSION1
  else if(field_exist(grid_file, "ocn_mosaic_file" ) ) then
     xmap%version = VERSION2
  else
     call error_mesg('xgrid_mod', 'both AREA_ATMxOCN and ocn_mosaic_file does not exist in '//trim(grid_file), FATAL)
  end if

  if(xmap%version==VERSION1) then
     call error_mesg('xgrid_mod', 'reading exchange grid information from grid spec file', NOTE)
  else
     call error_mesg('xgrid_mod', 'reading exchange grid information from mosaic grid file', NOTE)
  end if

  do g=1,size(grid_ids(:))
     grid => xmap%grids(g)
     if (g==1) grid1 => xmap%grids(g)
     grid%id     = grid_ids    (g)
     grid%domain = grid_domains(g)

     allocate ( grid%is(0:xmap%npes-1), grid%ie(0:xmap%npes-1) )
     allocate ( grid%js(0:xmap%npes-1), grid%je(0:xmap%npes-1) )
     allocate ( grid%tile(0:xmap%npes-1) )
     call mpp_get_compute_domains(grid%domain, xbegin=grid%is, xend=grid%ie, &
          ybegin=grid%js, yend=grid%je  )
     call mpp_get_global_domain(grid%domain, xsize=grid%ni, ysize=grid%nj)
     call mpp_max(grid%ni)
     call mpp_max(grid%nj)
     
     call mpp_get_tile_list(grid%domain, grid%tile)
     grid%ntile = mpp_get_ntile_count(grid%domain)
     ! make sure the grid%tile are between 1 and ntile 
     do p = 0, xmap%npes-1
        if(grid%tile(p) > grid%ntile .or. grid%tile(p) < 1) call error_mesg('xgrid_mod', &
                 'tile id should between 1 and ntile', FATAL)
     end do 

     grid%is_me => grid%is(xmap%me-xmap%root_pe); grid%ie_me => grid%ie(xmap%me-xmap%root_pe)
     grid%js_me => grid%js(xmap%me-xmap%root_pe); grid%je_me => grid%je(xmap%me-xmap%root_pe)
     grid%tile_me => grid%tile(xmap%me-xmap%root_pe)

     !--- The starting index of compute domain may not start at 1.
     grid%im = maxval(grid%ie) - minval(grid%is) + 1
     grid%jm = maxval(grid%je) - minval(grid%js) + 1
     grid%km = 1

     allocate( grid%area    (grid%is_me:grid%ie_me, grid%js_me:grid%je_me) )
     allocate( grid%area_inv(grid%is_me:grid%ie_me, grid%js_me:grid%je_me) )
     grid%area       = 0.0
     grid%size       = 0
     grid%size_repro = 0

     call mpp_get_data_domain(grid%domain, grid%isd_me, grid%ied_me, grid%jsd_me, grid%jed_me)

     ! get the center point of the grid box
     select case(xmap%version)
     case(VERSION1)
        call get_grid(grid, grid_ids(g), grid_file, xmap%version)
     case(VERSION2)
        call read_data(grid_file, lowercase(grid_ids(g))//'_mosaic_file', mosaic_file)      
        call get_mosaic_tile_grid(tile_file, 'INPUT/'//trim(mosaic_file), grid%domain)
        call get_grid(grid, grid_ids(g), tile_file, xmap%version)
     end select

     if( use_higher_order .AND. grid%id == 'ATM') then
        if( grid%is_latlon ) then
           call mpp_modify_domain(grid%domain, grid%domain_with_halo, whalo=1, ehalo=1, shalo=1, nhalo=1)
           call mpp_get_data_domain(grid%domain_with_halo, grid%isd_me, grid%ied_me, grid%jsd_me, grid%jed_me) 
        else
           if(.NOT. present(atm_grid)) call error_mesg('xgrid_mod', 'when first grid is "ATM", atm_grid should be present', FATAL)
           if(grid%is_me-grid%isd_me .NE. 1 .or. grid%ied_me-grid%ie_me .NE. 1 .or.               &
              grid%js_me-grid%jsd_me .NE. 1 .or. grid%jed_me-grid%je_me .NE. 1 ) call error_mesg( &
              'xgrid_mod', 'for non-latlon grid (cubic grid), the halo size should be 1 in all four direction', FATAL)
           if(.NOT.( ASSOCIATED(atm_grid%dx) .AND. ASSOCIATED(atm_grid%dy) .AND. ASSOCIATED(atm_grid%edge_w) .AND.    &
                ASSOCIATED(atm_grid%edge_e) .AND. ASSOCIATED(atm_grid%edge_s) .AND. ASSOCIATED(atm_grid%edge_n) .AND. &
                ASSOCIATED(atm_grid%en1) .AND. ASSOCIATED(atm_grid%en2) .AND. ASSOCIATED(atm_grid%vlon) .AND.         &
                ASSOCIATED(atm_grid%vlat) ) )  call error_mesg( &
            'xgrid_mod', 'for non-latlon grid (cubic grid), all the fields in atm_grid data type should be allocated', FATAL)
           nxc = grid%ie_me  - grid%is_me  + 1
           nyc = grid%je_me  - grid%js_me  + 1
           if(size(atm_grid%dx,1) .NE. nxc .OR. size(atm_grid%dx,2) .NE. nyc+1)               &
                call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%dx', FATAL)
           if(size(atm_grid%dy,1) .NE. nxc+1 .OR. size(atm_grid%dy,2) .NE. nyc)               &
                call error_mesg('xgrid_mod', 'incorrect dimension sizeof atm_grid%dy', FATAL)
           if(size(atm_grid%area,1) .NE. nxc .OR. size(atm_grid%area,2) .NE. nyc)             &
                call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%area', FATAL)
           if(size(atm_grid%edge_w(:)) .NE. nyc+1 .OR. size(atm_grid%edge_e(:)) .NE. nyc+1)    &
                call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%edge_w/edge_e', FATAL)
           if(size(atm_grid%edge_s(:)) .NE. nxc+1 .OR. size(atm_grid%edge_n(:)) .NE. nxc+1)    &
                call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%edge_s/edge_n', FATAL)
           if(size(atm_grid%en1,1) .NE. 3 .OR. size(atm_grid%en1,2) .NE. nxc .OR. size(atm_grid%en1,3) .NE. nyc+1) & 
                call error_mesg( 'xgrid_mod', 'incorrect dimension size of atm_grid%en1', FATAL)
           if(size(atm_grid%en2,1) .NE. 3 .OR. size(atm_grid%en2,2) .NE. nxc+1 .OR. size(atm_grid%en2,3) .NE. nyc) &
                call error_mesg( 'xgrid_mod', 'incorrect dimension size of atm_grid%en2', FATAL)
           if(size(atm_grid%vlon,1) .NE. 3 .OR. size(atm_grid%vlon,2) .NE. nxc .OR. size(atm_grid%vlon,3) .NE. nyc)   &
                call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlon', FATAL)
           if(size(atm_grid%vlat,1) .NE. 3 .OR. size(atm_grid%vlat,2) .NE. nxc .OR. size(atm_grid%vlat,3) .NE. nyc)   &
                call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlat', FATAL)
           allocate(grid%box%dx    (grid%is_me:grid%ie_me,   grid%js_me:grid%je_me+1 ))
           allocate(grid%box%dy    (grid%is_me:grid%ie_me+1, grid%js_me:grid%je_me   ))
           allocate(grid%box%area  (grid%is_me:grid%ie_me,   grid%js_me:grid%je_me   ))
           allocate(grid%box%edge_w(grid%js_me:grid%je_me+1))
           allocate(grid%box%edge_e(grid%js_me:grid%je_me+1))
           allocate(grid%box%edge_s(grid%is_me:grid%ie_me+1))
           allocate(grid%box%edge_n(grid%is_me:grid%ie_me+1))
           allocate(grid%box%en1   (3, grid%is_me:grid%ie_me,   grid%js_me:grid%je_me+1 ))
           allocate(grid%box%en2   (3, grid%is_me:grid%ie_me+1, grid%js_me:grid%je_me   ))
           allocate(grid%box%vlon  (3, grid%is_me:grid%ie_me,   grid%js_me:grid%je_me   ))
           allocate(grid%box%vlat  (3, grid%is_me:grid%ie_me,   grid%js_me:grid%je_me   ))
           grid%box%dx     = atm_grid%dx
           grid%box%dy     = atm_grid%dy
           grid%box%area   = atm_grid%area
           grid%box%edge_w = atm_grid%edge_w
           grid%box%edge_e = atm_grid%edge_e
           grid%box%edge_s = atm_grid%edge_s
           grid%box%edge_n = atm_grid%edge_n
           grid%box%en1    = atm_grid%en1
           grid%box%en2    = atm_grid%en2
           grid%box%vlon   = atm_grid%vlon
           grid%box%vlat   = atm_grid%vlat
        end if
     end if

     if (g>1) then
        allocate( grid%frac_area(grid%is_me:grid%ie_me, grid%js_me:grid%je_me, grid%km) )
        grid%frac_area = 1.0

        ! load exchange cells, sum grid cell areas, set your1my2/your2my1
        select case(xmap%version)
        case(VERSION1)
           call load_xgrid (xmap, grid, grid_file, grid_ids(1), grid_ids(g), 1, 1, use_higher_order)
        case(VERSION2)
           select case(grid_ids(1))
           case( 'ATM' )
              xgrid_name = 'a'
           case( 'LND' )
              xgrid_name = 'l'
           case default 
              call error_mesg('xgrid_mod', 'grid_ids(1) should be ATM or LND', FATAL)
           end select
           select case(grid_ids(g))
           case( 'LND' )
              xgrid_name = trim(xgrid_name)//'Xl_file'
           case( 'OCN' )
              xgrid_name = trim(xgrid_name)//'Xo_file'
           case default 
              call error_mesg('xgrid_mod', 'grid_ids(g) should be LND or OCN', FATAL)
           end select       
           ! get the tile list for each mosaic
           call read_data(grid_file, lowercase(grid_ids(1))//'_mosaic_file', mosaic1) 
           call read_data(grid_file, lowercase(grid_ids(g))//'_mosaic_file', mosaic2) 
           mosaic1 = 'INPUT/'//trim(mosaic1)
           mosaic2 = 'INPUT/'//trim(mosaic2)
           allocate(tile1_list(grid1%ntile), tile2_list(grid%ntile) )
           do j = 1, grid1%ntile
              call read_data(mosaic1, 'gridtiles', tile1_list(j), level=j)
           end do
           do j = 1, grid%ntile
              call read_data(mosaic2, 'gridtiles', tile2_list(j), level=j)
           end do
           if(field_exist(grid_file, xgrid_name)) then
              call field_size(grid_file, xgrid_name, siz)
              nxgrid_file = siz(2)
              ! loop through all the exchange grid file
              do i = 1, nxgrid_file
                 call read_data(grid_file, xgrid_name, xgrid_file, level = i)
                 xgrid_file = 'INPUT/'//trim(xgrid_file) 
                 if( .NOT. file_exist(xgrid_file) )call error_mesg('xgrid_mod', &
                      'file '//trim(xgrid_file)//' does not exist, check your xgrid file.', FATAL)

                 ! find the tile number of side 1 and side 2 mosaic, which is contained in field contact
                 call read_data(xgrid_file, "contact", contact)
                 i1 = index(contact, ":")
                 i2 = index(contact, "::")
                 i3 = index(contact, ":", back=.true. )
                 if(i1 == 0 .OR. i2 == 0) call error_mesg('xgrid_mod', &
                      'field contact in file '//trim(xgrid_file)//' should contains ":" and "::" ', FATAL)
                 if(i1 == i3) call error_mesg('xgrid_mod', &
                      'field contact in file '//trim(xgrid_file)//' should contains two ":"', FATAL)
                 tile1_name = contact(i1+1:i2-1)
                 tile2_name = contact(i3+1:len_trim(contact))
                 tile1 = 0; tile2 = 0
                 do j = 1, grid1%ntile
                    if( tile1_name == tile1_list(j) ) then
                       tile1 = j
                       exit
                    end if
                 end do
                 do j = 1, grid%ntile
                    if( tile2_name == tile2_list(j) ) then
                       tile2 = j
                       exit
                    end if
                 end do
                 if(tile1 == 0) call error_mesg('xgrid_mod', &
                      trim(tile1_name)//' is not a tile of mosaic '//trim(mosaic1), FATAL)
                 if(tile2 == 0) call error_mesg('xgrid_mod', &
                      trim(tile2_name)//' is not a tile of mosaic '//trim(mosaic2), FATAL)
                 call load_xgrid (xmap, grid, xgrid_file, grid_ids(1), grid_ids(g), tile1, tile2, &
                                  use_higher_order)
              end do
           endif
           deallocate(tile1_list, tile2_list)
        end select
        grid%area_inv = 0.0;
        where (grid%area>0.0) grid%area_inv = 1.0/grid%area
     end if
  end do

  grid1%area_inv = 0.0;
  where (grid1%area>0.0)
     grid1%area_inv = 1.0/grid1%area
  end where

  xmap%your1my2(xmap%me-xmap%root_pe) = .false. ! this is not necessarily true but keeps
  xmap%your2my1(xmap%me-xmap%root_pe) = .false. ! a PE from communicating with itself

  send_size = sum((grid1%ie-grid1%is+1)*(grid1%je-grid1%js+1))
  send_size = max(send_size, grid1%im*grid1%jm)
  recv_size = maxval((grid1%ie-grid1%is+1)*(grid1%je-grid1%js+1) )
  if (make_exchange_reproduce) then
     allocate( xmap%send_count_repro(0:xmap%npes-1) )
     allocate( xmap%recv_count_repro(0:xmap%npes-1) )
     xmap%send_count_repro = 0
     xmap%recv_count_repro = 0
     do g=2,size(xmap%grids(:))
        do p=0,xmap%npes-1
           if(xmap%grids(g)%size >0) &
                xmap%send_count_repro(p) = xmap%send_count_repro(p) &
                +count(xmap%grids(g)%x      (:)%pe==p+xmap%root_pe)
           if(xmap%grids(g)%size_repro >0) &
                xmap%recv_count_repro(p) = xmap%recv_count_repro(p) &
                +count(xmap%grids(g)%x_repro(:)%pe==p+xmap%root_pe)
        end do
     end do
     send_size = max(send_size, sum(xmap%send_count_repro))
  end if
  allocate (xmap%send_buffer(send_size))
  allocate (xmap%recv_buffer(recv_size))

  if (xgrid_log) then
    call mpp_open( unit, 'xgrid.out', action=MPP_OVERWR, threading=MPP_MULTI, &
         fileset=MPP_MULTI, nohdrs=.TRUE. )  

    write( unit,* )xmap%grids(:)%id, ' GRID: PE ', xmap%me, ' #XCELLS=', &
       xmap%grids(2:size(xmap%grids(:)))%size, ' #COMM. PARTNERS=', &
       count(xmap%your1my2), '/', count(xmap%your2my1), &
       pack((/(p+xmap%root_pe,p=0,xmap%npes-1)/), xmap%your1my2),  &
       '/', pack((/(p+xmap%root_pe,p=0,xmap%npes-1)/), xmap%your2my1)
    call close_file (unit)
  endif

  allocate( xmap%x1(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) )
  allocate( xmap%x2(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) )

  call regen(xmap)

  xxx = conservation_check(grid1%area*0+1.0, grid1%id, xmap)
  write(out_unit,* )"Checked data is array of constant 1"
  write(out_unit,* )grid1%id,'(',xmap%grids(:)%id,')=', xxx 

  do g=2,size(xmap%grids(:))
     xxx = conservation_check(xmap%grids(g)%frac_area*0+1.0, xmap%grids(g)%id, xmap )
     write( out_unit,* )xmap%grids(g)%id,'(',xmap%grids(:)%id,')=', xxx 
  enddo
  ! create an random number 2d array
  if(grid1%id == "ATM") then
     allocate(check_data(size(grid1%area,1), size(grid1%area,2)))
     call random_number(check_data)

     !--- second order along both zonal and meridinal direction
     xxx = conservation_check(check_data, grid1%id, xmap,  remap_method = remapping_method )
     write( out_unit,* ) &
          "Checked data is array of random number between 0 and 1 using "//trim(interp_method)
     write( out_unit,* )grid1%id,'(',xmap%grids(:)%id,')=', xxx 

     deallocate(check_data)
     do g=2,size(xmap%grids(:))
        allocate(check_data_3d(size(xmap%grids(g)%frac_area,1),size(xmap%grids(g)%frac_area,2), &
             size(xmap%grids(g)%frac_area,3) )) 
        call random_number(check_data_3d)
        xxx = conservation_check(check_data_3d, xmap%grids(g)%id, xmap,  remap_method = remapping_method )
        write( out_unit,* )xmap%grids(g)%id,'(',xmap%grids(:)%id,')=', xxx
        deallocate( check_data_3d)
     end do
  endif

end subroutine setup_xmap
! </SUBROUTINE>

!#######################################################################


subroutine regen(xmap)
type (xmap_type), intent(inout) :: xmap

  integer :: g, l, i, j, k, max_size

  max_size = 0;
  do g=2,size(xmap%grids(:))
    max_size = max_size + xmap%grids(g)%size * xmap%grids(g)%km
  end do
  if (max_size>size(xmap%x1(:))) then
    deallocate(xmap%x1)
    deallocate(xmap%x2)
    allocate( xmap%x1(1:max_size) )
    allocate( xmap%x2(1:max_size) )
  end if

  xmap%size = 0
  do g=2,size(xmap%grids(:))
    xmap%grids(g)%first = xmap%size + 1;
    do l=1,xmap%grids(g)%size
      i = xmap%grids(g)%x(l)%i2
      j = xmap%grids(g)%x(l)%j2
      do k=1,xmap%grids(g)%km
        if (xmap%grids(g)%frac_area(i,j,k)/=0.0) then
          xmap%size = xmap%size+1
          xmap%x1(xmap%size)%i    = xmap%grids(g)%x(l)%i1
          xmap%x1(xmap%size)%j    = xmap%grids(g)%x(l)%j1
          xmap%x1(xmap%size)%tile = xmap%grids(g)%x(l)%tile
          xmap%x1(xmap%size)%area = xmap%grids(g)%x(l)%area &
                                   *xmap%grids(g)%frac_area(i,j,k)
          xmap%x1(xmap%size)%di   = xmap%grids(g)%x(l)%di 
          xmap%x1(xmap%size)%dj   = xmap%grids(g)%x(l)%dj 
          xmap%x2(xmap%size)%i    = xmap%grids(g)%x(l)%i2
          xmap%x2(xmap%size)%j    = xmap%grids(g)%x(l)%j2
          xmap%x2(xmap%size)%k    = k
          xmap%x2(xmap%size)%area = xmap%grids(g)%x(l)%area * xmap%grids(g)%x(l)%scale 
        end if
      end do
    end do
    xmap%grids(g)%last = xmap%size
  end do
end subroutine regen

!#######################################################################

! <SUBROUTINE NAME="set_frac_area">

!   <OVERVIEW>
!     Changes sub-grid portion areas and/or number.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Changes sub-grid portion areas and/or number.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call set_frac_area(f, grid_id, xmap)
!   </TEMPLATE>

!   <IN NAME="f" TYPE="real" DIM="(:,:,:)"> </IN>
!   <IN NAME="grid_id" TYPE="character(len=3)" > </IN>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>

subroutine set_frac_area(f, grid_id, xmap)
real, dimension(:,:,:), intent(in   ) :: f
character(len=3),       intent(in   ) :: grid_id
type (xmap_type),       intent(inout) :: xmap

  integer :: g
  type(grid_type), pointer, save :: grid =>NULL()

  if (grid_id==xmap%grids(1)%id) call error_mesg ('xgrid_mod',  &
                                   'set_frac_area called on side 1 grid', FATAL)
  do g=2,size(xmap%grids(:))
    grid => xmap%grids(g)
    if (grid_id==grid%id) then
      if (size(f,3)/=size(grid%frac_area,3)) then
        deallocate (grid%frac_area)
        grid%km = size(f,3);
        allocate( grid%frac_area(grid%is_me:grid%ie_me, grid%js_me:grid%je_me, &
                                                                      grid%km) )
      end if
      grid%frac_area = f;
      call regen(xmap)
      return;
    end if
  end do

  call error_mesg ('xgrid_mod', 'set_frac_area: could not find grid id', FATAL)

end subroutine  set_frac_area
! </SUBROUTINE>



!#######################################################################

! <FUNCTION NAME="xgrid_count">

!   <OVERVIEW>
!     Returns current size of exchange grid variables.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns current size of exchange grid variables.
!   </DESCRIPTION>
!   <TEMPLATE>
!     xgrid_count(xmap)
!   </TEMPLATE>

!   <IN NAME="xmap" TYPE="xmap_type" > </IN>
!   <OUT NAME="xgrid_count"  TYPE="integer"  > </OUT>

integer function xgrid_count(xmap)
type (xmap_type), intent(inout) :: xmap

  xgrid_count = xmap%size
end function xgrid_count
! </FUNCTION>

!#######################################################################

! <SUBROUTINE NAME="put_side1_to_xgrid" INTERFACE="put_to_xgrid">
!   <IN NAME="d"  TYPE="real" DIM="(:,:)" > </IN>
!   <IN NAME="grid_id"  TYPE=" character(len=3)"  > </IN>
!   <INOUT NAME="x"  TYPE="real" DIM="(:)" > </INOUT>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>
!   <IN NAME="remap_method" TYPE="integer,optional"></IN>

subroutine put_side1_to_xgrid(d, grid_id, x, xmap, remap_method)
real, dimension(:,:), intent(in   )    :: d
character(len=3),     intent(in   )    :: grid_id
real, dimension(:),   intent(inout)    :: x
type (xmap_type),     intent(inout)    :: xmap
integer, intent(in), optional          :: remap_method

  integer :: g, method

  method = FIRST_ORDER      ! default
  if(present(remap_method)) method = remap_method

  if (grid_id==xmap%grids(1)%id) then
       if(method == FIRST_ORDER) then
          call put_1_to_xgrid_order_1(d, x, xmap)
       else 
          if(grid_id .NE. 'ATM') call error_mesg ('xgrid_mod',  &
                       "second order put_to_xgrid should only be applied to 'ATM' model, "//&
                       "contact developer", FATAL)
          call put_1_to_xgrid_order_2(d, x, xmap)
       endif
    return;
  end if

  do g=2,size(xmap%grids(:))
    if (grid_id==xmap%grids(g)%id)    &
      call error_mesg ('xgrid_mod',  &
                       'put_to_xgrid expects a 3D side 2 grid', FATAL)
  end do

  call error_mesg ('xgrid_mod', 'put_to_xgrid: could not find grid id', FATAL)

end subroutine put_side1_to_xgrid
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="put_side2_to_xgrid" INTERFACE="put_to_xgrid">
!   <IN NAME="d"  TYPE="real" DIM="(:,:,:)" > </IN>
!   <IN NAME="grid_id"  TYPE=" character(len=3)"  > </IN>
!   <INOUT NAME="x"  TYPE="real" DIM="(:)" > </INOUT>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>

subroutine put_side2_to_xgrid(d, grid_id, x, xmap)
real, dimension(:,:,:), intent(in   ) :: d
character(len=3),       intent(in   ) :: grid_id
real, dimension(:),     intent(inout) :: x
type (xmap_type),       intent(inout) :: xmap

  integer :: g

  if (grid_id==xmap%grids(1)%id) &
    call error_mesg ('xgrid_mod',  &
                     'put_to_xgrid expects a 2D side 1 grid', FATAL)

  do g=2,size(xmap%grids(:))
    if (grid_id==xmap%grids(g)%id) then
         call put_2_to_xgrid(d, xmap%grids(g), x, xmap)
      return;
    end if
  end do

  call error_mesg ('xgrid_mod', 'put_to_xgrid: could not find grid id', FATAL)

end subroutine put_side2_to_xgrid
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="get_side1_from_xgrid" INTERFACE="get_from_xgrid">
!   <IN NAME="x"  TYPE="real" DIM="(:)" > </IN>
!   <IN NAME="grid_id"  TYPE=" character(len=3)"  > </IN>
!   <OUT NAME="d"  TYPE="real" DIM="(:,:)" > </OUT>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>

subroutine get_side1_from_xgrid(d, grid_id, x, xmap)
real, dimension(:,:), intent(  out) :: d
character(len=3),     intent(in   ) :: grid_id
real, dimension(:),   intent(in   ) :: x
type (xmap_type),     intent(inout) :: xmap

  integer :: g

  if (grid_id==xmap%grids(1)%id) then
    if (make_exchange_reproduce) then
      call get_1_from_xgrid_repro(d, x, xmap)
    else
      call get_1_from_xgrid(d, x, xmap)
    end if
    return;
  end if
  
  do g=2,size(xmap%grids(:))
    if (grid_id==xmap%grids(g)%id) &
      call error_mesg ('xgrid_mod',  & 
                       'get_from_xgrid expects a 3D side 2 grid', FATAL)
  end do
  
  call error_mesg ('xgrid_mod', 'get_from_xgrid: could not find grid id', FATAL)

end subroutine get_side1_from_xgrid
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="get_side2_from_xgrid" INTERFACE="get_from_xgrid">
!   <IN NAME="x"  TYPE="real" DIM="(:)" > </IN>
!   <IN NAME="grid_id"  TYPE=" character(len=3)"  > </IN>
!   <OUT NAME="d"  TYPE="real" DIM="(:,:,:)" > </OUT>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>

subroutine get_side2_from_xgrid(d, grid_id, x, xmap)
real, dimension(:,:,:), intent(  out) :: d
character(len=3),       intent(in   ) :: grid_id
real, dimension(:),     intent(in   ) :: x
type (xmap_type),       intent(in   ) :: xmap

  integer :: g

  if (grid_id==xmap%grids(1)%id) &
    call error_mesg ('xgrid_mod',  &
                     'get_from_xgrid expects a 2D side 1 grid', FATAL)
  
  do g=2,size(xmap%grids(:))
    if (grid_id==xmap%grids(g)%id) then
      call get_2_from_xgrid(d, xmap%grids(g), x, xmap)
      return;
    end if
  end do
  
  call error_mesg ('xgrid_mod', 'get_from_xgrid: could not find grid id', FATAL)

end subroutine get_side2_from_xgrid
! </SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="some">

!   <OVERVIEW>
!     Returns logical associating exchange grid cells with given side two grid.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns logical associating exchange grid cells with given side two grid.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call some(xmap, some_arr, grid_id)
!   </TEMPLATE>

!   <IN NAME="xmap"  TYPE="xmap_type"  ></IN>
!   <IN NAME="grid_id"  TYPE="character(len=3)"  ></IN>
!   <OUT NAME="some_arr"  TYPE="logical" DIM="(xmap%size)" >
!     logical associating exchange grid cells with given side 2 grid.
!   </OUT>

subroutine some(xmap, some_arr, grid_id)
type (xmap_type),           intent(in) :: xmap
character(len=3), optional, intent(in) :: grid_id
logical, dimension(:), intent(out) :: some_arr

  integer :: g

  if (.not.present(grid_id)) then

    if(xmap%size > 0) then
       some_arr = .true.
    else 
       some_arr = .false.
    end if
    return;
  end if

  if (grid_id==xmap%grids(1)%id) &
    call error_mesg ('xgrid_mod', 'some expects a side 2 grid id', FATAL)
  
  do g=2,size(xmap%grids(:))
    if (grid_id==xmap%grids(g)%id) then
      some_arr = .false.
      some_arr(xmap%grids(g)%first:xmap%grids(g)%last) = .true.;
      return;
    end if
  end do
  
  call error_mesg ('xgrid_mod', 'some could not find grid id', FATAL)

end subroutine some
! </SUBROUTINE>

!#######################################################################

subroutine put_2_to_xgrid(d, grid, x, xmap)
type (grid_type),                                intent(in) :: grid
real, dimension(grid%is_me:grid%ie_me, &
                grid%js_me:grid%je_me, grid%km), intent(in) :: d
real, dimension(:    ), intent(inout) :: x
type (xmap_type),       intent(in   ) :: xmap

  integer                 ::   l

  do l=grid%first,grid%last
    x(l) = d(xmap%x2(l)%i,xmap%x2(l)%j,xmap%x2(l)%k)
  end do
end subroutine put_2_to_xgrid

!#######################################################################

subroutine get_2_from_xgrid(d, grid, x, xmap)
type (grid_type),                                intent(in ) :: grid
real, dimension(grid%is_me:grid%ie_me, &
                grid%js_me:grid%je_me, grid%km), intent(out) :: d
real, dimension(:),     intent(in   ) :: x
type (xmap_type),       intent(in   ) :: xmap

  integer                 :: l, k

  d = 0.0
  do l=grid%first,grid%last
    d(xmap%x2(l)%i,xmap%x2(l)%j,xmap%x2(l)%k) = &
            d(xmap%x2(l)%i,xmap%x2(l)%j,xmap%x2(l)%k) + xmap%x2(l)%area*x(l)
  end do
  !
  !  normalize with side 2 grid cell areas
  !
  do k=1,size(d,3)
    d(:,:,k) = d(:,:,k) * grid%area_inv
  end do
end subroutine get_2_from_xgrid

!#######################################################################

function get_side_1(pe, im, jm)
integer, intent(in)    :: pe, im, jm
real, dimension(im,jm) :: get_side_1

!  call mpp_recv(buf, im*jm, pe)
!  l = 0
!  do j=1,jm; do i=1,im;
!    l = l + 1
!    get_side_1(i,j) = buf(l)
!  end do; end do
  ! Force use of "scalar", integer pointer mpp interface.
  call mpp_recv( get_side_1(1,1), glen=im*jm, from_pe=pe )
end function get_side_1

!#######################################################################

subroutine put_1_to_xgrid_order_1(d, x, xmap)
real, dimension(:,:), intent(in   ) :: d
real, dimension(:  ), intent(inout) :: x
type (xmap_type),     intent(inout) :: xmap

  integer :: i, is, ie, im, j, js, je, jm, p, l, tile
  real, dimension(xmap%grids(1)%ni,xmap%grids(1)%nj,xmap%grids(1)%ntile) :: dg
  type (grid_type), pointer, save :: grid1 =>NULL()

  grid1 => xmap%grids(1)
  is = grid1%is_me; ie = grid1%ie_me;
  js = grid1%js_me; je = grid1%je_me;
  tile = grid1%tile_me
  dg(is:ie,js:je,tile) = d;

  im = ie-is+1; jm = je-js+1;
  l = 0
  call mpp_sync_self()          !Balaji
  do j=1,jm; do i=1,im;
    l = l + 1;
    xmap%send_buffer(l) =  d(i,j)
  end do; end do;
  do p=0,xmap%npes-1
    if (xmap%your2my1(p)) then
      ! Force use of "scalar", integer pointer mpp interface.
      call mpp_send(xmap%send_buffer(1), plen=im*jm, to_pe=p+xmap%root_pe);
    end if
  end do
  do p=0,xmap%npes-1
    if (xmap%your1my2(p)) then
      is = grid1%is(p); ie = grid1%ie(p);
      js = grid1%js(p); je = grid1%je(p);
      tile = grid1%tile(p)
      dg(is:ie,js:je,tile) = get_side_1(p+xmap%root_pe,ie-is+1,je-js+1);
    end if
  end do
  do l=1,xmap%size
    x(l) =  dg(xmap%x1(l)%i,xmap%x1(l)%j,xmap%x1(l)%tile)
  end do

!  call mpp_sync_self
end subroutine put_1_to_xgrid_order_1

!#######################################################################


subroutine put_1_to_xgrid_order_2(d, x, xmap)
  real, dimension(:,:), intent(in   ) :: d
  real, dimension(:  ), intent(inout) :: x
  type (xmap_type),     intent(inout) :: xmap

  integer :: i, is, ie, im, j, js, je, jm, p, l, isd, jsd, tile
  real, dimension(xmap%grids(1)%im,xmap%grids(1)%jm,xmap%grids(1)%ntile) :: dg
  real, dimension(xmap%grids(1)%im,xmap%grids(1)%jm,xmap%grids(1)%ntile) :: grad_x, grad_y
  real, dimension(xmap%grids(1)%isd_me:xmap%grids(1)%ied_me,xmap%grids(1)%jsd_me:xmap%grids(1)%jed_me) :: tmp
  real, dimension(xmap%grids(1)%is_me:xmap%grids(1)%ie_me,xmap%grids(1)%js_me:xmap%grids(1)%je_me) :: tmpx, tmpy
  type (grid_type), pointer, save :: grid1 =>NULL()
  integer                         :: send_size, recv_size

  grid1 => xmap%grids(1)
  is = grid1%is_me;   ie = grid1%ie_me
  js = grid1%js_me;   je = grid1%je_me
  isd = grid1%isd_me
  jsd = grid1%jsd_me
  im = ie-is+1;       jm = je-js+1
  tile = grid1%tile_me
  dg(is:ie,js:je,tile) = d

  ! first get the halo of data
  tmp = 0
  tmp(is:ie,js:je) = d(:,:)

  if(grid1%is_latlon) then
     call mpp_update_domains(tmp,grid1%domain_with_halo)
     grad_y(is:ie,js:je,tile) = grad_merid_latlon(tmp, grid1%lat, is, ie, js, je, isd, jsd)
     grad_x(is:ie,js:je,tile) = grad_zonal_latlon(tmp, grid1%lon, grid1%lat, is, ie, js, je, isd, jsd)
  else
     call mpp_update_domains(tmp,grid1%domain)
     call gradient_cubic(tmp, xmap%grids(1)%box%dx, xmap%grids(1)%box%dy, xmap%grids(1)%box%area,      &
                         xmap%grids(1)%box%edge_w, xmap%grids(1)%box%edge_e, xmap%grids(1)%box%edge_s, &
                         xmap%grids(1)%box%edge_n, xmap%grids(1)%box%en1, xmap%grids(1)%box%en2,       &
                         xmap%grids(1)%box%vlon, xmap%grids(1)%box%vlat, tmpx, tmpy,                   &
                         is==1, ie==grid1%im, js==1, je==grid1%jm)
     grad_x(is:ie,js:je,tile) = tmpx
     grad_y(is:ie,js:je,tile) = tmpy    
  end if     

  send_size = 3*im*jm
  ! if size of send_buffer is not enough, need to reallocate send_buffer
  if(size(xmap%send_buffer(:)) .lt. send_size) then
     deallocate(xmap%send_buffer)
     allocate(xmap%send_buffer(send_size))
  endif

  l = 0
  do j=js,je; do i=is,ie
     l = l + 1
     xmap%send_buffer(l) =  tmp(i,j)
  end do; end do

  do j=js,je; do i=is,ie
     l = l + 1
     xmap%send_buffer(l) = grad_y(i,j,tile)
  end do; end do

  do j=js,je; do i=is,ie
     l = l + 1
     xmap%send_buffer(l) = grad_x(i,j,tile)
  end do; end do

  do p=0,xmap%npes-1
     if (xmap%your2my1(p)) then
        ! Force use of "scalar", integer pointer mpp interface.
        call mpp_send(xmap%send_buffer(1), plen=send_size, to_pe=p+xmap%root_pe);
     end if
  end do

  do p=0,xmap%npes-1
     if (xmap%your1my2(p)) then
        is = grid1%is(p);  ie = grid1%ie(p)
        js = grid1%js(p);  je = grid1%je(p)
        tile = grid1%tile(p)
        recv_size = 3*(ie-is+1)*(je-js+1)
        if(size(xmap%recv_buffer(:)) .lt. recv_size) then
           deallocate(xmap%recv_buffer)
           allocate(xmap%recv_buffer(recv_size))
        endif
        call mpp_recv(xmap%recv_buffer(1), glen = recv_size, from_pe = p+xmap%root_pe)
        l = 0
        do j = js,je; do i=is,ie
           l = l + 1
           dg(i,j,tile) = xmap%recv_buffer(l)
        enddo; enddo
        do j = js,je; do i=is,ie
           l = l + 1
           grad_y(i,j,tile) = xmap%recv_buffer(l)
        enddo; enddo

        do j = js,je; do i=is,ie
           l = l + 1
           grad_x(i,j,tile) = xmap%recv_buffer(l)
        enddo; enddo
     end if
  end do

  do l=1,xmap%size
     tile = xmap%x1(l)%tile
     x(l) =  dg(xmap%x1(l)%i,xmap%x1(l)%j,tile)
     x(l) = x(l) + grad_y(xmap%x1(l)%i,xmap%x1(l)%j,tile ) *xmap%x1(l)%dj
     x(l) = x(l) + grad_x(xmap%x1(l)%i,xmap%x1(l)%j,tile ) *xmap%x1(l)%di
  end do

  call mpp_sync_self() ! originally called before calling mpp_send

end subroutine put_1_to_xgrid_order_2

!#######################################################################

subroutine get_1_from_xgrid(d, x, xmap)
real, dimension(:,:), intent(out)   :: d
real, dimension(:  ), intent(in )   :: x
type (xmap_type),     intent(inout) :: xmap

  real, dimension(xmap%grids(1)%ni,xmap%grids(1)%nj,xmap%grids(1)%ntile), target :: dg
  integer :: i, is, ie, im, j, js, je, jm, l, le, p, tile
  real             , pointer, save :: dgp =>NULL()
  type (grid_type) , pointer, save :: grid1 =>NULL()

  grid1 => xmap%grids(1)

  dg = 0.0;
  do l=1,xmap%size
    dgp => dg(xmap%x1(l)%i,xmap%x1(l)%j,xmap%x1(l)%tile)
    dgp =  dgp + xmap%x1(l)%area*x(l)
  end do

  le = 0;
  call mpp_sync_self()          !Balaji
  do p=0,xmap%npes-1
    if (xmap%your1my2(p)) then
      l = le + 1;
      is = grid1%is(p); ie = grid1%ie(p);
      js = grid1%js(p); je = grid1%je(p);
      tile = grid1%tile(p)
      do j=js,je; do i=is,ie;
        le = le + 1
        xmap%send_buffer(le) = dg(i,j,tile)
      end do; end do;
      ! Force use of "scalar", integer pointer mpp interface.
      call mpp_send(xmap%send_buffer(l), plen=le-l+1, to_pe=p+xmap%root_pe);
    end if
  end do
  d = dg(grid1%is_me:grid1%ie_me,grid1%js_me:grid1%je_me,grid1%tile_me);
  im = grid1%ie_me-grid1%is_me+1;
  jm = grid1%je_me-grid1%js_me+1;
  do p=0,xmap%npes-1
    if (xmap%your2my1(p)) d = d + get_side_1(p+xmap%root_pe,im,jm)
  end do
  !
  ! normalize with side 1 grid cell areas
  !
  d = d * grid1%area_inv

!  call mpp_sync_self
end subroutine get_1_from_xgrid

!#######################################################################

subroutine get_1_from_xgrid_repro(d, x, xmap)
type (xmap_type), intent(inout)                  :: xmap
real, dimension(xmap%grids(1)%is_me:xmap%grids(1)%ie_me, &
                xmap%grids(1)%js_me:xmap%grids(1)%je_me), intent(out) :: d
real, dimension(:  ), intent(in ) :: x

  real,    dimension(:), allocatable :: x_psum
  integer, dimension(:), allocatable :: pe_psum
  integer :: l1, l2, l3, g, i, j, k, p
  integer, dimension(0:xmap%npes-1) :: pl
  type (grid_type), pointer, save :: grid =>NULL()

  allocate ( x_psum  (sum(xmap%send_count_repro)) )
  allocate ( pe_psum (sum(xmap%send_count_repro)) )
  x_psum = 0.0
  l1 = 0 ! index into partition summed exchange grid variable
  l2 = 0 ! index into exchange grid variable
  do g=2,size(xmap%grids(:))
    do l3=1,xmap%grids(g)%size ! index into this side 2 grid's patterns
      l1 = l1 + 1
      do k=1,xmap%grids(g)%km
        i = xmap%grids(g)%x(l3)%i2
        j = xmap%grids(g)%x(l3)%j2
        if (xmap%grids(g)%frac_area(i,j,k)/=0.0) then
          l2 = l2 + 1
          x_psum (l1) = x_psum(l1) + xmap%x1(l2)%area * x(l2)
          pe_psum(l1) = xmap%grids(g)%x(l3)%pe
        end if
      end do
    end do
  end do
  l2 = 0;
  call mpp_sync_self()          !Balaji
  do p=0,xmap%npes-1
    l1 = l2 + 1
    l2 = l2 + xmap%send_count_repro(p)
    if (xmap%send_count_repro(p)>0) then ! can send to myself
      xmap%send_buffer(l1:l2) = pack(x_psum, pe_psum==p+xmap%root_pe)
      ! Force use of "scalar", integer pointer mpp interface.
      call mpp_send(xmap%send_buffer(l1), plen=l2-l1+1, to_pe=p+xmap%root_pe);
    end if
  end do
  deallocate ( x_psum, pe_psum)
  allocate ( x_psum (sum(xmap%recv_count_repro)) )
  l2 = 0;
  do p=0,xmap%npes-1
    l1 = l2 + 1
    l2 = l2 + xmap%recv_count_repro(p)
    if (xmap%recv_count_repro(p)>0) then ! can receive from myself
      ! Force use of "scalar", integer pointer mpp interface.
      call mpp_recv(x_psum(l1), glen=l2-l1+1, from_pe=p+xmap%root_pe);
      pl(p) = l1
    end if
  end do
  d = 0.0
  do g=2,size(xmap%grids(:))
    grid => xmap%grids(g)
    do l3=1,grid%size_repro ! index into side1 grid's patterns
      i = grid%x_repro(l3)%i1
      j = grid%x_repro(l3)%j1
      d(i,j) = d(i,j) + x_psum(pl(grid%x_repro(l3)%pe-xmap%root_pe))
      pl(grid%x_repro(l3)%pe-xmap%root_pe) = pl(grid%x_repro(l3)%pe-xmap%root_pe) + 1
    end do
  end do
  deallocate ( x_psum )
  !
  ! normalize with side 1 grid cell areas
  !
  d = d * xmap%grids(1)%area_inv

!  call mpp_sync_self
end subroutine get_1_from_xgrid_repro

!#######################################################################

! <FUNCTION NAME="conservation_check_side1" INTERFACE="conservation_check">
!   <IN NAME="d"  TYPE="real" DIM="(:,:)" > </IN>
!   <IN NAME="grid_id"  TYPE="character(len=3)"  > </IN>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>
!   <OUT NAME="conservation_check_side1" TYPE="real" DIM="dimension(3)" > </OUT>
!   <IN NAME="remap_method" TYPE="integer,optional"></IN>
! conservation_check - returns three numbers which are the global sum of a
! variable (1) on its home model grid, (2) after interpolation to the other
! side grid(s), and (3) after re_interpolation back onto its home side grid(s).
!
function conservation_check_side1(d, grid_id, xmap,remap_method) ! this one for 1->2->1
real, dimension(:,:),    intent(in   ) :: d
character(len=3),        intent(in   ) :: grid_id
type (xmap_type),        intent(inout) :: xmap
real, dimension(3)                     :: conservation_check_side1
integer, intent(in), optional :: remap_method


  real, dimension(xmap%size) :: x_over, x_back
  real, dimension(size(d,1),size(d,2)) :: d1
  real, dimension(:,:,:), allocatable  :: d2
  integer                              :: g
  type (grid_type), pointer, save      :: grid1 =>NULL(), grid2 =>NULL()

  grid1 => xmap%grids(1)
  conservation_check_side1(1) = mpp_global_sum(grid1%domain, grid1%area*d)
  conservation_check_side1(2) = 0.0
  call put_to_xgrid (d, grid1%id, x_over, xmap, remap_method)    ! put from side 1
  do g=2,size(xmap%grids(:))
    grid2 => xmap%grids(g)
    allocate (d2 (grid2%is_me:grid2%ie_me, grid2%js_me:grid2%je_me,  grid2%km) )
    call get_from_xgrid (d2, grid2%id, x_over, xmap) ! get onto side 2's
    conservation_check_side1(2) = conservation_check_side1(2) + &
      mpp_global_sum( grid2%domain, grid2%area * sum(grid2%frac_area*d2,DIM=3) )
    call put_to_xgrid (d2, grid2%id, x_back, xmap) ! put from side 2's
    deallocate (d2)
  end do
  call get_from_xgrid(d1, grid1%id, x_back, xmap)  ! get onto side 1
  conservation_check_side1(3) = mpp_global_sum(grid1%domain, grid1%area*d1)
end function conservation_check_side1
! </FUNCTION>

!#######################################################################
!
! conservation_check - returns three numbers which are the global sum of a
! variable (1) on its home model grid, (2) after interpolation to the other
! side grid(s), and (3) after re_interpolation back onto its home side grid(s).
!
! <FUNCTION NAME="conservation_check_side2" INTERFACE="conservation_check">
!   <IN NAME="d"  TYPE="real" DIM="(:,:,:)" > </IN>
!   <IN NAME="grid_id"  TYPE="character(len=3)"  > </IN>
!   <INOUT NAME="xmap"  TYPE="xmap_type"  > </INOUT>
!   <OUT NAME="conservation_check_side2" TYPE="real" DIM="dimension(3)" > </OUT>

function conservation_check_side2(d, grid_id, xmap,remap_method) ! this one for 2->1->2
real, dimension(:,:,:), intent(in   )  :: d
character(len=3),       intent(in   )  :: grid_id
type (xmap_type),       intent(inout)  :: xmap
real, dimension(3)                     :: conservation_check_side2
integer, intent(in), optional :: remap_method


  real, dimension(xmap%size) :: x_over, x_back
  real, dimension(:,:  ), allocatable :: d1
  real, dimension(:,:,:), allocatable :: d2
  integer                             :: g
  type (grid_type), pointer, save     :: grid1 =>NULL(), grid2 =>NULL()

  grid1 => xmap%grids(1)
  do g = 2,size(xmap%grids(:))
    grid2 => xmap%grids(g)
    if (grid_id==grid2%id) then
      conservation_check_side2(1) = mpp_global_sum( grid2%domain, &
                                     grid2%area * sum(grid2%frac_area*d,DIM=3) )
      call put_to_xgrid(d, grid_id, x_over, xmap)  ! put from this side 2
    else
      call put_to_xgrid(0 * grid2%frac_area, grid2%id, x_over, xmap) ! zero rest
    end if
  end do

  allocate ( d1(size(grid1%area,1),size(grid1%area,2)) )
  call get_from_xgrid(d1, grid1%id, x_over, xmap)  ! get onto side 1
  conservation_check_side2(2) = mpp_global_sum(grid1%domain, grid1%area*d1)
  call put_to_xgrid(d1,  grid1%id, x_back, xmap,remap_method)   ! put from side 1
  deallocate ( d1 )

  conservation_check_side2(3) = 0.0;
  do g = 2,size(xmap%grids(:))
    grid2 => xmap%grids(g)
    allocate ( d2 ( size(grid2%frac_area, 1), size(grid2%frac_area, 2),  &
                                              size(grid2%frac_area, 3) ) )
    call get_from_xgrid(d2,  grid2%id, x_back, xmap) ! get onto side 2's
    conservation_check_side2(3) = conservation_check_side2(3)                  &
                                 +mpp_global_sum( grid2%domain,                &
                                    grid2%area * sum(grid2%frac_area*d2,DIM=3) )
    deallocate ( d2 )
  end do
  
end function conservation_check_side2
! </FUNCTION>

!******************************************************************************
! This routine is used to get the grid area of component model with id.
subroutine get_xmap_grid_area(id, xmap, area)
  character(len=3),     intent(in   ) :: id
  type (xmap_type),     intent(inout) :: xmap
  real, dimension(:,:), intent(out  ) :: area
  integer                             :: g
  logical                             :: found

   found = .false.
   do g = 1, size(xmap%grids(:))
      if (id==xmap%grids(g)%id ) then
         if(size(area,1) .NE. size(xmap%grids(g)%area,1) .OR. size(area,2) .NE. size(xmap%grids(g)%area,2) ) &
           call error_mesg("xgrid_mod", "size mismatch between area and xmap%grids(g)%area", FATAL)
         area = xmap%grids(g)%area
         found = .true.
         exit
      end if
   end do

   if(.not. found) call error_mesg("xgrid_mod", id//" is not found in xmap%grids id", FATAL)

end subroutine get_xmap_grid_area

!#######################################################################

! This function is used to calculate the gradient along zonal direction.
! Maybe need to setup a limit for the gradient. The grid is assumeed 
! to be regular lat-lon grid

function grad_zonal_latlon(d, lon, lat, is, ie, js, je, isd, jsd) 

  integer,                    intent(in) :: isd, jsd
  real, dimension(isd:,jsd:), intent(in) :: d
  real, dimension(:),         intent(in) :: lon
  real, dimension(:),         intent(in) :: lat
  integer,                    intent(in) :: is, ie, js, je 
  real, dimension(is:ie,js:je)           :: grad_zonal_latlon
  real                                   :: dx, costheta
  integer                                :: i, j, ip1, im1

  !  calculate the gradient of the data on each grid
  do i = is, ie
     if(i == 1) then
        ip1 = i+1; im1 = i
     else if(i==size(lon(:)) ) then
        ip1 = i; im1 = i-1
     else
        ip1 = i+1; im1 = i-1
     endif
     dx = lon(ip1) - lon(im1)
     if(abs(dx).lt.EPS )  call error_mesg('xgrids_mod(grad_zonal_latlon)', 'Improper grid size in lontitude', FATAL)
     if(dx .gt. PI)  dx = dx - 2.0* PI
     if(dx .lt. -PI) dx = dx + 2.0* PI
     do j = js, je
        costheta = cos(lat(j))
        if(abs(costheta) .lt. EPS) call error_mesg('xgrids_mod(grad_zonal_latlon)', 'Improper latitude grid', FATAL)
        grad_zonal_latlon(i,j) = (d(ip1,j)-d(im1,j))/(dx*costheta)
     enddo
  enddo

  return

end function grad_zonal_latlon

!#######################################################################

! This function is used to calculate the gradient along meridinal direction.
! Maybe need to setup a limit for the gradient. regular lat-lon grid are assumed

function grad_merid_latlon(d, lat, is, ie, js, je, isd, jsd) 
  integer,                    intent(in) :: isd, jsd
  real, dimension(isd:,jsd:), intent(in) :: d
  real, dimension(:),         intent(in) :: lat
  integer,                    intent(in) :: is, ie, js, je 
  real, dimension(is:ie,js:je)           :: grad_merid_latlon
  real                                   :: dy
  integer                                :: i, j, jp1, jm1

  !  calculate the gradient of the data on each grid
  do j = js, je
     if(j == 1) then
        jp1 = j+1; jm1 = j
     else if(j == size(lat(:)) ) then
        jp1 = j;   jm1 = j-1
     else
        jp1 = j+1; jm1 = j-1
     endif
     dy = lat(jp1) - lat(jm1)
     if(abs(dy).lt.EPS) call error_mesg('xgrids_mod(grad_merid_latlon)', 'Improper grid size in latitude', FATAL)

     do i = is, ie
        grad_merid_latlon(i,j) = (d(i,jp1) - d(i,jm1))/dy
     enddo
  enddo

  return
end function grad_merid_latlon

!#######################################################################
subroutine get_index_range(xmap, grid_index, is, ie, js, je, km)

  type(xmap_type), intent(in)     :: xmap
  integer, intent(in)             :: grid_index
  integer, intent(out)            :: is, ie, js, je, km

  is = xmap % grids(grid_index) % is_me
  ie = xmap % grids(grid_index) % ie_me
  js = xmap % grids(grid_index) % js_me
  je = xmap % grids(grid_index) % je_me
  km = xmap % grids(grid_index) % km
  
end subroutine get_index_range
!#######################################################################

subroutine stock_move_3d(from, to, grid_index, data, xmap, &
     & delta_t, from_side, to_side, radius, verbose, ier)

  ! this version takes rank 3 data, it can be used to compute the flux on anything but the 
  ! first grid, which typically is on the atmos side.
  ! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only
  ! if these are present.

  use mpp_mod, only : mpp_sum
  use mpp_domains_mod, only : domain2D, mpp_redistribute, mpp_get_compute_domain

  type(stock_type), intent(inout), optional :: from, to
  integer, intent(in)             :: grid_index        ! grid index
  real, intent(in)                :: data(:,:,:)  ! data array is 3d
  type(xmap_type), intent(in)     :: xmap
  real, intent(in)                :: delta_t
  integer, intent(in)             :: from_side, to_side ! ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE
  real, intent(in)                :: radius       ! earth radius
  character(len=*), intent(in), optional      :: verbose
  integer, intent(out)            :: ier

  real    :: from_dq, to_dq

  ier = 0
  if(grid_index == 1) then
     ! data has rank 3 so grid index must be > 1
     ier = 1
     return
  endif

  if(.not. associated(xmap%grids) ) then
     ier = 2
     return
  endif

     from_dq = delta_t * 4*PI*radius**2 * sum( sum(xmap%grids(grid_index)%area * &
          & sum(xmap%grids(grid_index)%frac_area * data, DIM=3), DIM=1))
     to_dq = from_dq

  ! update only if argument is present.
  if(present(to  )) to   % dq(  to_side) = to   % dq(  to_side) + to_dq
  if(present(from)) from % dq(from_side) = from % dq(from_side) - from_dq

  if(present(verbose).and.debug_stocks) then
     call mpp_sum(from_dq)
     call mpp_sum(to_dq)
     from_dq = from_dq/(4*PI*radius**2)
     to_dq   = to_dq  /(4*PI*radius**2)
     if(mpp_pe()==mpp_root_pe()) then
        write(stocks_file,'(a,es19.12,a,es19.12,a)') verbose, from_dq,' [*/m^2]'
     endif
  endif

end subroutine stock_move_3d

!...................................................................

subroutine stock_move_2d(from, to, grid_index, data, xmap, &
     & delta_t, from_side, to_side, radius, verbose, ier)

  ! this version takes rank 2 data, it can be used to compute the flux on the atmos side
  ! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only
  ! if these are present.

  use mpp_mod, only : mpp_sum
  use mpp_domains_mod, only : domain2D, mpp_redistribute, mpp_get_compute_domain

  type(stock_type), intent(inout), optional :: from, to
  integer, optional, intent(in)   :: grid_index
  real, intent(in)                :: data(:,:)    ! data array is 2d
  type(xmap_type), intent(in)     :: xmap
  real, intent(in)                :: delta_t
  integer, intent(in)             :: from_side, to_side ! ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE
  real, intent(in)                :: radius       ! earth radius
  character(len=*), intent(in)    :: verbose
  integer, intent(out)            :: ier

  real    :: to_dq, from_dq

  ier = 0

  if(.not. associated(xmap%grids) ) then
     ier = 3
     return
  endif

  if( .not. present(grid_index) .or. grid_index==1 ) then

     ! only makes sense if grid_index == 1
     from_dq = delta_t * 4*PI*radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1))
     to_dq = from_dq

  else

     ier = 4
     return

  endif

  ! update only if argument is present.
  if(present(to  )) to   % dq(  to_side) = to   % dq(  to_side) + to_dq
  if(present(from)) from % dq(from_side) = from % dq(from_side) - from_dq

  if(debug_stocks) then
     call mpp_sum(from_dq)
     call mpp_sum(to_dq)
     from_dq = from_dq/(4*PI*radius**2)
     to_dq   = to_dq  /(4*PI*radius**2)
     if(mpp_pe()==mpp_root_pe()) then
        write(stocks_file,'(a,es19.12,a,es19.12,a)') verbose, from_dq,' [*/m^2]'
     endif
  endif

end subroutine stock_move_2d

!#######################################################################
subroutine stock_integrate_2d(data, xmap, delta_t, radius, res, ier)

  ! surface/time integral of a 2d array

  use mpp_mod, only : mpp_sum

  real, intent(in)                :: data(:,:)    ! data array is 2d
  type(xmap_type), intent(in)     :: xmap
  real, intent(in)                :: delta_t
  real, intent(in)                :: radius       ! earth radius
  real, intent(out)               :: res
  integer, intent(out)            :: ier

  ier = 0
  res = 0

  if(.not. associated(xmap%grids) ) then
     ier = 6
     return
  endif

  res = delta_t * 4*PI*radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1))

end subroutine stock_integrate_2d
!#######################################################################

!#######################################################################



subroutine stock_print(stck, Time, comp_name, index, ref_value, radius, pelist)

  use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_sum
  use time_manager_mod, only : time_type, get_time
  use diag_manager_mod, only : register_diag_field,send_data

  type(stock_type), intent(in)  :: stck
  type(time_type), intent(in)   :: Time
  character(len=*)              :: comp_name
  integer, intent(in)           :: index     ! to map stock element (water, heat, ..) to a name
  real, intent(in)              :: ref_value ! the stock value returned by the component per PE
  real, intent(in)              :: radius
  integer, intent(in), optional :: pelist(:)

  integer, parameter :: initID = -2 ! initial value for diag IDs. Must not be equal to the value 
  ! that register_diag_field returns when it can't register the filed -- otherwise the registration 
  ! is attempted every time this subroutine is called

  real :: f_value, c_value, planet_area
  character(len=80) :: formatString
  integer :: iday, isec, hours
  integer :: diagID, compInd
  integer, dimension(NELEMS,4), save :: f_valueDiagID = initID
  integer, dimension(NELEMS,4), save :: c_valueDiagID = initID
  integer, dimension(NELEMS,4), save :: fmc_valueDiagID = initID

  real :: diagField
  logical :: used
  character(len=30) :: field_name, units

  f_value = sum(stck % dq)
  c_value = ref_value      - stck % q_start
  if(present(pelist)) then
     call mpp_sum(f_value, pelist=pelist)
     call mpp_sum(c_value, pelist=pelist)
  else
     call mpp_sum(f_value)
     call mpp_sum(c_value)
  endif

  if(mpp_pe() == mpp_root_pe()) then
     ! normalize to 1 earth m^2
     planet_area = 4*PI*radius**2
     f_value       = f_value     / planet_area
     c_value       = c_value     / planet_area

     if(comp_name == 'ATM') compInd = 1
     if(comp_name == 'LND') compInd = 2
     if(comp_name == 'ICE') compInd = 3
     if(comp_name == 'OCN') compInd = 4


     if(f_valueDiagID(index,compInd) == initID) then
        field_name = trim(comp_name) // trim(STOCK_NAMES(index))
        field_name  = trim(field_name) // 'StocksChange_Flux'
        units = trim(STOCK_UNITS(index))
        f_valueDiagID(index,compInd) = register_diag_field('stock_print', field_name, Time, &
             units=units)
     endif

     if(c_valueDiagID(index,compInd) == initID) then
        field_name = trim(comp_name) // trim(STOCK_NAMES(index))
        field_name = trim(field_name) // 'StocksChange_Comp'
        units = trim(STOCK_UNITS(index))
        c_valueDiagID(index,compInd) = register_diag_field('stock_print', field_name, Time, &
             units=units)
     endif

     if(fmc_valueDiagID(index,compInd) == initID) then
        field_name = trim(comp_name) // trim(STOCK_NAMES(index))
        field_name = trim(field_name) // 'StocksChange_Diff'
        units = trim(STOCK_UNITS(index))
        fmc_valueDiagID(index,compInd) = register_diag_field('stock_print', field_name, Time, &
             units=units)
     endif

     DiagID=f_valueDiagID(index,compInd)
     diagField = f_value
     if (DiagID > 0)  used = send_data(DiagID, diagField, Time)
     DiagID=c_valueDiagID(index,compInd)
     diagField = c_value
     if (DiagID > 0)  used = send_data(DiagID, diagField, Time)
     DiagID=fmc_valueDiagID(index,compInd)
     diagField = f_value-c_value
     if (DiagID > 0)  used = send_data(DiagID, diagField, Time)


     call get_time(Time, isec, iday)
     hours = iday*24 + isec/3600
     formatString = '(a,a,a,i16,2x,es22.15,2x,es22.15,2x,es22.15)'
     write(stocks_file,formatString) trim(comp_name),STOCK_NAMES(index),STOCK_UNITS(index) &
          ,hours,f_value,c_value,f_value-c_value

  endif


end subroutine stock_print


!###############################################################################
function is_lat_lon(lon, lat)
  real, dimension(:,:), intent(in) :: lon, lat
  logical                          :: is_lat_lon
  integer                          :: i, j, nlon, nlat

  is_lat_lon = .true.
  nlon = size(lon,1)
  nlat = size(lon,2)
  do j = 1, nlat
     do i = 2, nlon
        if(lat(i,j) .NE. lat(1,j)) then
           is_lat_lon = .false.
           return
        end if
     end do
  end do

  do i = 1, nlon
     do j = 2, nlat
        if(lon(i,j) .NE. lon(i,1)) then
           is_lat_lon = .false.
           return
        end if
     end do
  end do

  return
end function is_lat_lon

end module xgrid_mod


! <INFO>

!   <REFERENCE>   
!      A <LINK SRC="http://www.gfdl.noaa.gov/~mw/docs/grid_coupling.html"> guide </LINK>to grid coupling in FMS.
!   </REFERENCE>
!   <REFERENCE>
!      A simple xgrid <LINK SRC="http://www.gfdl.gov/~mw/docs/xgrid_example.f90.txt"> example. </LINK>
!   </REFERENCE>

! </INFO>


!======================================================================================
! standalone unit test

#ifdef TEST_XGRID
! Now only test some simple test, will test cubic grid mosaic in the future.

program xgrid_test

  use mpp_mod,         only : mpp_pe, mpp_npes, mpp_error, FATAL
  use mpp_mod,         only : input_nml_file
  use mpp_domains_mod, only : mpp_define_domains, mpp_define_layout, mpp_domains_exit
  use mpp_domains_mod, only : mpp_get_compute_domain, domain2d, mpp_domains_init
  use mpp_domains_mod, only : mpp_define_mosaic_pelist, mpp_define_mosaic, mpp_global_sum
  use mpp_domains_mod, only : mpp_get_data_domain, mpp_get_global_domain, mpp_update_domains
  use mpp_io_mod,      only : mpp_open, MPP_RDONLY,MPP_NETCDF, MPP_MULTI, MPP_SINGLE, mpp_close
  use mpp_io_mod,      only : mpp_get_att_value
  use fms_mod,         only : fms_init, file_exist, field_exist, field_size, open_namelist_file
  use fms_mod,         only : check_nml_error, close_file, read_data, stdout, fms_end
  use fms_mod,         only : get_mosaic_tile_grid, write_data, set_domain
  use fms_io_mod,      only : fms_io_exit
  use constants_mod,   only : DEG_TO_RAD
  use xgrid_mod,       only : xgrid_init, setup_xmap, put_to_xgrid, get_from_xgrid
  use xgrid_mod,       only : xmap_type, xgrid_count, grid_box_type, SECOND_ORDER
  use xgrid_mod,       only : get_xmap_grid_area
  use mosaic_mod,      only : get_mosaic_ntiles, get_mosaic_grid_sizes
  use mosaic_mod,      only : get_mosaic_ncontacts, get_mosaic_contact
  use gradient_mod,    only : calc_cubic_grid_info

implicit none

  real, parameter :: EPSLN = 1.0e-10
  character(len=256) :: atm_input_file  = "INPUT/atmos_input.nc"
  character(len=256) :: atm_output_file = "atmos_output.nc"
  character(len=256) :: lnd_output_file = "land_output.nc"
  character(len=256) :: ocn_output_file = "ocean_output.nc"
  character(len=256) :: atm_field_name  = "none"

  character(len=256) :: runoff_input_file  = "INPUT/land_runoff.nc"
  character(len=256) :: runoff_output_file  = "land_runoff.nc"
  character(len=256) :: runoff_field_name  = "none"


  namelist /xgrid_test_nml/ atm_input_file, atm_field_name, runoff_input_file, runoff_field_name

  integer              :: remap_method
  integer              :: pe, npes, ierr, nml_unit, io, n
  integer              :: siz(4), ntile_lnd, ntile_atm, ntile_ocn, ncontact
  integer, allocatable :: layout(:,:), global_indices(:,:)
  integer, allocatable :: atm_nx(:), atm_ny(:), ocn_nx(:), ocn_ny(:), lnd_nx(:), lnd_ny(:)
  integer, allocatable :: pe_start(:), pe_end(:), dummy(:)
  integer, allocatable :: istart1(:), iend1(:), jstart1(:), jend1(:), tile1(:)
  integer, allocatable :: istart2(:), iend2(:), jstart2(:), jend2(:), tile2(:)
  character(len=256)   :: grid_file = "INPUT/grid_spec.nc"
  character(len=256)   :: atm_mosaic, ocn_mosaic, lnd_mosaic
  character(len=256)   :: atm_mosaic_file, ocn_mosaic_file, lnd_mosaic_file
  character(len=256)   :: grid_descriptor, tile_file
  integer              :: isc_atm, iec_atm, jsc_atm, jec_atm, nxc_atm, nyc_atm
  integer              :: isc_lnd, iec_lnd, jsc_lnd, jec_lnd
  integer              :: isc_ocn, iec_ocn, jsc_ocn, jec_ocn
  integer              :: isd_atm, ied_atm, jsd_atm, jed_atm
  integer              :: unit, i, j, nxa, nya, nxgrid, nxl, nyl, out_unit
  type(domain2d)       :: Atm_domain, Ocn_domain, Lnd_domain
  type(xmap_type)      :: Xmap, Xmap_runoff
  type(grid_box_type)  :: atm_grid
  real, allocatable    :: xt(:,:), yt(:,:)  ! on T-cell data domain
  real, allocatable    :: xc(:,:), yc(:,:)  ! on C-cell compute domain
  real, allocatable    :: tmpx(:,:), tmpy(:,:)
  real, allocatable    :: atm_data_in(:,:), atm_data_out(:,:)
  real, allocatable    :: lnd_data_out(:,:,:), ocn_data_out(:,:,:)
  real, allocatable    :: runoff_data_in(:,:), runoff_data_out(:,:,:)
  real, allocatable    :: atm_area(:,:), lnd_area(:,:), ocn_area(:,:)
  real, allocatable    :: x_1(:), x_2(:)
  real                 :: sum_atm_in, sum_ocn_out, sum_lnd_out, sum_atm_out
  real                 :: sum_runoff_in, sum_runoff_out
  logical              :: atm_input_file_exist, runoff_input_file_exist


  call fms_init
  call mpp_domains_init
  call xgrid_init(remap_method)

  npes     = mpp_npes()
  pe       = mpp_pe()
  out_unit = stdout()

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, xgrid_test_nml, iostat=io)
#else
 if (file_exist('input.nml')) then
   ierr=1
   nml_unit = open_namelist_file()
   do while (ierr /= 0)
     read(nml_unit, nml=xgrid_test_nml, iostat=io, end=10)
          ierr = check_nml_error(io, 'xgrid_test_nml')
   enddo
10 call close_file(nml_unit)
 endif
#endif

  if(field_exist(grid_file, "AREA_ATM" ) ) then
     allocate(atm_nx(1), atm_ny(1))
     allocate(lnd_nx(1), lnd_ny(1))
     allocate(ocn_nx(1), ocn_ny(1))
     allocate(layout(1,2))
     call field_size(grid_file, "AREA_ATM", siz )
     atm_nx = siz(1); atm_ny = siz(2)
     call field_size(grid_file, "AREA_OCN", siz )
     ocn_nx = siz(1); ocn_ny = siz(2)
     call field_size(grid_file, "AREA_LND", siz )
     lnd_nx = siz(1); lnd_ny = siz(2)
     call mpp_define_layout( (/1,atm_nx,1,atm_ny/), npes, layout(1,:)) 
     call mpp_define_domains( (/1,atm_nx,1,atm_ny/), layout(1,:), Atm_domain)
     call mpp_define_layout( (/1,lnd_nx,1,lnd_ny/), npes, layout(1,:)) 
     call mpp_define_domains( (/1,lnd_nx,1,lnd_ny/), layout(1,:), Lnd_domain) 
     call mpp_define_layout( (/1,ocn_nx,1,ocn_ny/), npes, layout(1,:))
     call mpp_define_domains( (/1,ocn_nx,1,ocn_ny/), layout(1,:), Ocn_domain)
     deallocate(layout)
  else if (field_exist(grid_file, "atm_mosaic" ) ) then
     !--- Get the mosaic data of each component model 
     call read_data(grid_file, 'atm_mosaic', atm_mosaic)
     call read_data(grid_file, 'lnd_mosaic', lnd_mosaic)
     call read_data(grid_file, 'ocn_mosaic', ocn_mosaic)
     atm_mosaic_file = 'INPUT/'//trim(atm_mosaic)//'.nc'
     lnd_mosaic_file = 'INPUT/'//trim(lnd_mosaic)//'.nc'
     ocn_mosaic_file = 'INPUT/'//trim(ocn_mosaic)//'.nc'

     ntile_lnd = get_mosaic_ntiles(lnd_mosaic_file);
     ntile_ocn = get_mosaic_ntiles(ocn_mosaic_file);
     ntile_atm = get_mosaic_ntiles(atm_mosaic_file);
     if(ntile_lnd > 1) call mpp_error(FATAL,  &
         'xgrid_test: there is more than one tile in lnd_mosaic, which is not implemented yet')
     if(ntile_ocn > 1) call mpp_error(FATAL,  &
           'xgrid_test: there is more than one tile in ocn_mosaic, which is not implemented yet')

     write(out_unit,*)" There is ", ntile_atm, " tiles in atmos mosaic"
     write(out_unit,*)" There is ", ntile_lnd, " tiles in land  mosaic"
     write(out_unit,*)" There is ", ntile_ocn, " tiles in ocean mosaic"
     allocate(atm_nx(ntile_atm), atm_ny(ntile_atm))
     allocate(lnd_nx(ntile_ocn), lnd_ny(ntile_lnd))
     allocate(ocn_nx(ntile_ocn), ocn_ny(ntile_ocn))

     call get_mosaic_grid_sizes(atm_mosaic_file, atm_nx, atm_ny)
     call get_mosaic_grid_sizes(lnd_mosaic_file, lnd_nx, lnd_ny)
     call get_mosaic_grid_sizes(ocn_mosaic_file, ocn_nx, ocn_ny)

     ncontact = get_mosaic_ncontacts(atm_mosaic_file)
     if(ncontact > 0) then
        allocate(tile1(ncontact),   tile2(ncontact) )
        allocate(istart1(ncontact), iend1(ncontact) )
        allocate(jstart1(ncontact), jend1(ncontact) )
        allocate(istart2(ncontact), iend2(ncontact) )
        allocate(jstart2(ncontact), jend2(ncontact) )
        call get_mosaic_contact( atm_mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1, &
                                 istart2, iend2, jstart2, jend2)
     endif

     if(mod(npes, ntile_atm) .NE. 0 ) call mpp_error(FATAL,"npes should be divided by ntile_atm")

     allocate(pe_start(ntile_atm), pe_end(ntile_atm) )
     allocate(global_indices(4, ntile_atm), layout(2,ntile_atm))
     call mpp_define_mosaic_pelist( atm_nx*atm_ny, pe_start, pe_end)
     do n = 1, ntile_atm
        global_indices(:,n) = (/1, atm_nx(n), 1, atm_ny(n)/)
        call mpp_define_layout( global_indices(:,n), pe_end(n)-pe_start(n)+1, layout(:,n))
     end do
 
     call mpp_define_mosaic(global_indices, layout, Atm_domain, ntile_atm, ncontact, tile1, tile2, &
                            istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,        &
                            pe_start, pe_end, whalo=1, ehalo=1, shalo=1, nhalo=1)
     deallocate( pe_start, pe_end, global_indices, layout )

     allocate(pe_start(ntile_lnd), pe_end(ntile_lnd) )
     allocate(global_indices(4,ntile_lnd), layout(2,ntile_lnd))
     call mpp_define_mosaic_pelist( lnd_nx*lnd_ny, pe_start, pe_end)
     do n = 1, ntile_lnd
        global_indices(:,n) = (/1, lnd_nx(n), 1, lnd_ny(n)/)
        call mpp_define_layout( global_indices(:,n), pe_end(n)-pe_start(n)+1, layout(:,n))
     end do

     ncontact = 0 ! no update is needed for land and ocean model.
 
     call mpp_define_mosaic(global_indices, layout, Lnd_domain, ntile_lnd, ncontact, dummy, dummy, &
                            dummy, dummy, dummy, dummy, dummy, dummy, dummy, dummy, pe_start, pe_end)
     deallocate( pe_start, pe_end, global_indices, layout )

     allocate(pe_start(ntile_ocn), pe_end(ntile_ocn) )
     allocate(global_indices(4, ntile_ocn), layout(2, ntile_ocn))
     call mpp_define_mosaic_pelist( ocn_nx*ocn_ny, pe_start, pe_end)
     do n = 1, ntile_ocn
        global_indices(:,n) = (/1, ocn_nx(n), 1, ocn_ny(n)/)
        call mpp_define_layout( global_indices(:,n), pe_end(n)-pe_start(n)+1, layout(:,n))
     end do
 
     call mpp_define_mosaic(global_indices, layout, Ocn_domain, ntile_ocn, ncontact, dummy, dummy, &
                            dummy, dummy, dummy, dummy, dummy, dummy, dummy, dummy, pe_start, pe_end)
     deallocate( pe_start, pe_end, global_indices, layout )
  else
     call mpp_error(FATAL, 'test_xgrid:both AREA_ATM and atm_mosaic does not exist in '//trim(grid_file))
  end if

  deallocate(atm_nx, atm_ny, lnd_nx, lnd_ny, ocn_nx, ocn_ny)

  call mpp_get_compute_domain(atm_domain, isc_atm, iec_atm, jsc_atm, jec_atm)
  call mpp_get_compute_domain(lnd_domain, isc_lnd, iec_lnd, jsc_lnd, jec_lnd)
  call mpp_get_compute_domain(ocn_domain, isc_ocn, iec_ocn, jsc_ocn, jec_ocn)
  call mpp_get_data_domain(atm_domain, isd_atm, ied_atm, jsd_atm, jed_atm)
  call mpp_get_global_domain(atm_domain, xsize = nxa, ysize = nya)
  call mpp_get_global_domain(lnd_domain, xsize = nxl, ysize = nyl)
  nxc_atm = iec_atm - isc_atm + 1
  nyc_atm = jec_atm - jsc_atm + 1

  ! set up atm_grid for second order conservative interpolation and atm grid is cubic grid.
  if(remap_method == SECOND_ORDER ) then  
     ! check if atmos mosaic is cubic grid or not */
     call mpp_open(unit,trim(atm_mosaic_file),MPP_RDONLY,MPP_NETCDF,threading=MPP_MULTI,fileset=MPP_SINGLE)
     call mpp_get_att_value(unit, "mosaic", "grid_descriptor", grid_descriptor)
     call mpp_close(unit)

     if(trim(grid_descriptor) == "cubic_grid") then
        allocate(xt         (isd_atm:ied_atm,jsd_atm:jed_atm),     yt         (isd_atm:ied_atm,jsd_atm:jed_atm)   )
        allocate(xc         (isc_atm:ied_atm,jsc_atm:jed_atm),     yc         (isc_atm:ied_atm,jsc_atm:jed_atm)   )
        allocate(atm_grid%dx(isc_atm:iec_atm,jsc_atm:jed_atm),     atm_grid%dy(isc_atm:iec_atm+1,jsc_atm:jec_atm) )
        allocate(atm_grid%edge_w(jsc_atm:jed_atm),               atm_grid%edge_e(jsc_atm:jed_atm))
        allocate(atm_grid%edge_s(isc_atm:ied_atm),               atm_grid%edge_n(isc_atm:ied_atm))
        allocate(atm_grid%en1 (3,isc_atm:iec_atm,jsc_atm:jed_atm), atm_grid%en2 (3,isc_atm:ied_atm,jsc_atm:jec_atm) )
        allocate(atm_grid%vlon(3,isc_atm:iec_atm,jsc_atm:jec_atm), atm_grid%vlat(3,isc_atm:iec_atm,jsc_atm:jec_atm) )
        allocate(atm_grid%area(isc_atm:iec_atm,jsc_atm:jec_atm) )

        ! first get grid from grid file 
        call get_mosaic_tile_grid(tile_file, atm_mosaic_file, atm_domain)
        allocate(tmpx(nxa*2+1, nya*2+1), tmpy(nxa*2+1, nya*2+1))
        call read_data( tile_file, 'x', tmpx, no_domain=.true.)
        call read_data( tile_file, 'y', tmpy, no_domain=.true.) 
        xt = 0; yt = 0;
        do j = jsc_atm, jec_atm
           do i = isc_atm, iec_atm
              xt(i,j) = tmpx(2*i, 2*j)*DEG_TO_RAD
              yt(i,j) = tmpy(2*i, 2*j)*DEG_TO_RAD
           end do
        end do
        do j = jsc_atm, jed_atm
           do i = isc_atm, ied_atm
              xc(i,j) = tmpx(2*i-1, 2*j-1)*DEG_TO_RAD
              yc(i,j) = tmpy(2*i-1, 2*j-1)*DEG_TO_RAD
           end do
        end do        
        call mpp_update_domains(xt, atm_domain)
        call mpp_update_domains(yt, atm_domain)

        call calc_cubic_grid_info(xt, yt, xc, yc, atm_grid%dx, atm_grid%dy, atm_grid%area, atm_grid%edge_w, &
                                  atm_grid%edge_e, atm_grid%edge_s, atm_grid%edge_n, atm_grid%en1,          &
                                  atm_grid%en2, atm_grid%vlon, atm_grid%vlat, isc_atm==1, iec_atm==nxa,     &
                                  jsc_atm==1, jec_atm==nya                               )
     end if
  end if
  !--- conservation check is done in setup_xmap. 
  call setup_xmap(Xmap, (/ 'ATM', 'OCN', 'LND' /), (/ Atm_domain, Ocn_domain, Lnd_domain /), grid_file, atm_grid)
  call setup_xmap(Xmap_runoff, (/ 'LND', 'OCN'/), (/ Lnd_domain, Ocn_domain/), grid_file )
  call set_domain(atm_domain)
  !--- remap realistic data and write the output file when atmos_input_file does exist
  atm_input_file_exist = file_exist(atm_input_file)
  if( atm_input_file_exist ) then
     if(trim(atm_input_file) == trim(atm_output_file) ) call mpp_error(FATAL, &
          "test_xgrid: atm_input_file should have a different name from atm_output_file")
     call field_size(atm_input_file, atm_field_name, siz )
     if(siz(1) .NE. nxa .OR. siz(2) .NE. nya ) call mpp_error(FATAL,"test_xgrid: x- and y-size of field "//trim(atm_field_name) &
            //" in file "//trim(atm_input_file) //" does not compabile with the grid size" )
     if(siz(3) > 1) call mpp_error(FATAL,"test_xgrid: number of vertical level of field "//trim(atm_field_name) &
            //" in file "//trim(atm_input_file) //" should be no larger than 1")

     allocate(atm_data_in (isc_atm:iec_atm, jsc_atm:jec_atm   ) )
     allocate(atm_data_out(isc_atm:iec_atm, jsc_atm:jec_atm   ) )
     allocate(lnd_data_out(isc_lnd:iec_lnd, jsc_lnd:jec_lnd, 1) )
     allocate(ocn_data_out(isc_ocn:iec_ocn, jsc_ocn:jec_ocn, 1) )
     nxgrid = max(xgrid_count(Xmap), 1)
     allocate(x_1(nxgrid), x_2(nxgrid))

     atm_data_in  = 0
     atm_data_out = 0
     lnd_data_out = 0
     ocn_data_out = 0
     ! test one time level should be sufficient
     call read_data(atm_input_file, atm_field_name, atm_data_in, atm_domain)
     call put_to_xgrid(atm_data_in, 'ATM', x_1, Xmap, remap_method=remap_method)
     call get_from_xgrid(lnd_data_out, 'LND', x_1, xmap)
     call get_from_xgrid(ocn_data_out, 'OCN', x_1, xmap)
     call put_to_xgrid(lnd_data_out, 'LND', x_2, xmap)
     call put_to_xgrid(ocn_data_out, 'OCN', x_2, xmap)
     call get_from_xgrid(atm_data_out, 'ATM', x_2, xmap)
     call write_data( atm_output_file, atm_field_name, atm_data_out, atm_domain)
     call write_data( lnd_output_file, atm_field_name, lnd_data_out, lnd_domain)
     call write_data( ocn_output_file, atm_field_name, ocn_data_out, ocn_domain)
     ! conservation check 
     allocate(atm_area(isc_atm:iec_atm, jsc_atm:jec_atm ) )
     allocate(lnd_area(isc_lnd:iec_lnd, jsc_lnd:jec_lnd ) )
     allocate(ocn_area(isc_ocn:iec_ocn, jsc_ocn:jec_ocn ) )
     call get_xmap_grid_area("ATM", Xmap, atm_area)
     call get_xmap_grid_area("LND", Xmap, lnd_area)
     call get_xmap_grid_area("OCN", Xmap, ocn_area)


     sum_atm_in  = mpp_global_sum(atm_domain, atm_area * atm_data_in)
     sum_lnd_out = mpp_global_sum(lnd_domain, lnd_area * lnd_data_out(:,:,1))
     sum_ocn_out = mpp_global_sum(ocn_domain, ocn_area * ocn_data_out(:,:,1))
     sum_atm_out = mpp_global_sum(atm_domain, atm_area * atm_data_out)
     write(out_unit,*) "********************** check conservation *********************** "
     write(out_unit,*) "the global area sum of atmos input data is                    : ", sum_atm_in 
     write(out_unit,*) "the global area sum of atmos output data is                   : ", sum_atm_out
     write(out_unit,*) "the global area sum of land output data + ocean output data is: ", sum_lnd_out+sum_ocn_out
     deallocate(atm_area, lnd_area, ocn_area, atm_data_in, atm_data_out, lnd_data_out, ocn_data_out)
     deallocate(x_1, x_2)
  else
     write(out_unit,*) "NOTE from test_xgrid ==> file "//trim(atm_input_file)//" does not exist, no check is done for real data sets."
  end if           

  runoff_input_file_exist = file_exist(runoff_input_file)     
  if( runoff_input_file_exist ) then
     if(trim(runoff_input_file) == trim(runoff_output_file) ) call mpp_error(FATAL, &
          "test_xgrid: runoff_input_file should have a different name from runoff_output_file")
     call field_size(runoff_input_file, runoff_field_name, siz )
     if(siz(1) .NE. nxl .OR. siz(2) .NE. nyl ) call mpp_error(FATAL,"test_xgrid: x- and y-size of field "//trim(runoff_field_name) &
            //" in file "//trim(runoff_input_file) //" does not compabile with the grid size" )
     if(siz(3) > 1) call mpp_error(FATAL,"test_xgrid: number of vertical level of field "//trim(runoff_field_name) &
            //" in file "//trim(runoff_input_file) //" should be no larger than 1")

     allocate(runoff_data_in (isc_lnd:iec_lnd, jsc_lnd:jec_lnd   ) ) 
     allocate(runoff_data_out(isc_ocn:iec_ocn, jsc_ocn:jec_ocn, 1) )
     nxgrid = max(xgrid_count(Xmap_runoff), 1)
     allocate(x_1(nxgrid), x_2(nxgrid))

     runoff_data_in  = 0
     runoff_data_out = 0
     ! test one time level should be sufficient
     call read_data(runoff_input_file, runoff_field_name, runoff_data_in, lnd_domain)
     call put_to_xgrid(runoff_data_in, 'LND', x_1, Xmap_runoff)
     call get_from_xgrid(runoff_data_out, 'OCN', x_1, xmap_runoff)
     call write_data( runoff_output_file, runoff_field_name, runoff_data_out, ocn_domain)
     ! conservation check 
     allocate(lnd_area(isc_lnd:iec_lnd, jsc_lnd:jec_lnd ) )
     allocate(ocn_area(isc_ocn:iec_ocn, jsc_ocn:jec_ocn ) )
     call get_xmap_grid_area("LND", Xmap_runoff, lnd_area)
     call get_xmap_grid_area("OCN", Xmap_runoff, ocn_area)

     sum_runoff_in  = mpp_global_sum(lnd_domain, lnd_area * runoff_data_in)
     sum_runoff_out = mpp_global_sum(ocn_domain, ocn_area * runoff_data_out(:,:,1))
     write(out_unit,*) "********************** check conservation *********************** "
     write(out_unit,*) "the global area sum of runoff input data is                    : ", sum_runoff_in 
     write(out_unit,*) "the global area sum of runoff output data is                   : ", sum_runoff_out
  else
     write(out_unit,*) "NOTE from test_xgrid ==> file "//trim(runoff_input_file)//" does not exist, no check is done for real data sets."
  end if           

  write(out_unit,*) "************************************************************************"
  write(out_unit,*) "***********      Finish running program test_xgrid         *************"
  write(out_unit,*) "************************************************************************"

  call mpp_domains_exit
  call fms_io_exit
  call fms_end

end program xgrid_test

! end of TEST_XGRID
#endif


#ifdef _XGRID_MAIN
! to compile on Altix:
! setenv FMS /net2/ap/regression/ia64/10-Aug-2006/CM2.1U_Control-1990_E1.k_dyn30pe/exec
! ifort -fpp -r8 -i4 -g -check all -D_XGRID_MAIN -I $FMS xgrid.f90 $FMS/stock_constants.o $FMS/fms*.o $FMS/mpp*.o $FMS/constants.o $FMS/time_manager.o $FMS/memutils.o $FMS/threadloc.o -L/usr/local/lib -lnetcdf -L/usr/lib -lmpi -lsma
! mpirun -np 30 a.out
program main
  use mpp_mod
  use fms_mod
  use mpp_domains_mod
  use xgrid_mod, only : xmap_type, setup_xmap, stock_move, stock_type, get_index_range
  use stock_constants_mod, only : ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, ISTOCK_WATER, ISTOCK_HEAT, NELEMS
  use constants_mod, only       : PI
  implicit none

  type(xmap_type)  :: xmap_sfc, xmap_runoff
  integer          :: npes, pe, root, i, nx, ny, ier
  integer          :: patm_beg, patm_end, pocn_beg, pocn_end
  integer          :: is, ie, js, je, km, index_ice, index_lnd
  integer          :: layout(2)
  type(stock_type), save :: Atm_stock(NELEMS), Ice_stock(NELEMS), &
       &                    Lnd_stock(NELEMS), Ocn_stock(NELEMS)
  type(domain2D)   :: Atm_domain, Ice_domain, Lnd_domain, Ocn_domain
  logical, pointer :: maskmap(:,:)
  real, allocatable :: data2d(:,:), data3d(:,:,:)
  real              :: dt, dq_tot_atm, dq_tot_ice, dq_tot_lnd, dq_tot_ocn



  call fms_init

  npes   = mpp_npes()
  pe     = mpp_pe()
  root   = mpp_root_pe()
  patm_beg = 0
  patm_end = npes/2 - 1
  pocn_beg = patm_end + 1
  pocn_end = npes - 1

  if(npes /= 30) call mpp_error(FATAL,'must run unit test on 30 pes')

  call mpp_domains_init ! (MPP_DEBUG)

  call mpp_declare_pelist( (/ (i, i=patm_beg, patm_end) /), 'atm_lnd_ice pes' ) 
  call mpp_declare_pelist( (/ (i, i=pocn_beg, pocn_end) /), 'ocn pes' ) 

  index_ice = 2 ! 2nd exchange grid
  index_lnd = 3 ! 3rd exchange grid

  dt = 1.0

  if(pe < 15) then

     call mpp_set_current_pelist( (/ (i, i=patm_beg, patm_end) /) )

     ! Lnd
     nx = 144
     ny = 90
     layout = (/ 5, 3 /)
     call mpp_define_domains( (/1,nx, 1,ny/), layout, Lnd_domain, &
          & xflags = CYCLIC_GLOBAL_DOMAIN, name = 'LAND MODEL' )

     ! Atm
     nx = 144
     ny = 90
     layout = (/1, 15/)
     call mpp_define_domains( (/1,nx, 1,ny/), layout, Atm_domain)

     ! Ice
     nx = 360
     ny = 200
     layout = (/15, 1/)
     call mpp_define_domains( (/1,nx, 1,ny/), layout, Ice_domain, name='ice_nohalo' )

     ! Build exchange grid
     call setup_xmap(xmap_sfc, (/ 'ATM', 'OCN', 'LND' /), &
          &                    (/ Atm_domain, Ice_domain, Lnd_domain /), &
          &                    "INPUT/grid_spec.nc")

!  call setup_xmap(xmap_sfc, (/ 'LND', 'OCN' /), &
!       &                    (/  Lnd_domain, Ice_domain /), &
!       &                    "INPUT/grid_spec.nc")


     ! Atm -> Ice

     i = index_ice

     call get_index_range(xmap=xmap_sfc, grid_index=i, is=is, ie=ie, js=js, je=je, km=km)

     allocate(data3d(is:ie, js:je, km))
     data3d(:,:,1   ) = 1.0/(4.0*PI)
     data3d(:,:,2:km) = 0.0
     call stock_move(from=Atm_stock(ISTOCK_WATER), to=Ice_stock(ISTOCK_WATER), &
          & grid_index=i, data=data3d, xmap=xmap_sfc, &
          & delta_t=dt, from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, radius=1.0, ier=ier)
     deallocate(data3d)

     ! Atm -> Lnd

     i = index_lnd

     call get_index_range(xmap=xmap_sfc, grid_index=i, is=is, ie=ie, js=js, je=je, km=km)
     
     allocate(data3d(is:ie, js:je, km))
     data3d(:,:,1   ) = 1.0/(4.0*PI)
     data3d(:,:,2:km) = 0.0
     call stock_move(from=Atm_stock(ISTOCK_WATER), to=Lnd_stock(ISTOCK_WATER), &
          & grid_index=i, data=data3d, xmap=xmap_sfc, &
          & delta_t=dt, from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, radius=1.0, ier=ier)
     deallocate(data3d)

  else ! pes: 15...29

     call mpp_set_current_pelist( (/ (i, i=pocn_beg, pocn_end) /) )

     ! Ocn
     nx = 360
     ny = 200
     layout = (/ 5, 3 /)
     call mpp_define_domains( (/1,nx,1,ny/), layout, Ocn_domain, name='ocean model')

  endif

  ! Ice -> Ocn (same grid different layout)

  i = index_ice

  if( pe < pocn_beg ) then 

     call get_index_range(xmap=xmap_sfc, grid_index=i, is=is, ie=ie, js=js, je=je, km=km)

     allocate(data3d(is:ie, js:je, km))
     data3d(:,:,1   ) = 1.0/(4.0*PI)
     data3d(:,:,2:km) = 0.0
  else
     is = 0
     ie = 0
     js = 0
     je = 0
     km = 0
     allocate(data3d(is:ie, js:je, km))
  endif

  call stock_move(from=Ice_stock(ISTOCK_WATER), to=Ocn_stock(ISTOCK_WATER), &
       & grid_index=i, data=data3d(:,:,1), xmap=xmap_sfc, &
       & delta_t=dt, from_side=ISTOCK_BOTTOM, to_side=ISTOCK_TOP, radius=1.0, ier=ier)
  deallocate(data3d)

  ! Sum across sides and PEs

  dq_tot_atm = sum(Atm_stock(ISTOCK_WATER)%dq)
  call mpp_sum(dq_tot_atm)

  dq_tot_lnd = sum(Lnd_stock(ISTOCK_WATER)%dq)
  call mpp_sum(dq_tot_lnd)

  dq_tot_ice = sum(Ice_stock(ISTOCK_WATER)%dq)
  call mpp_sum(dq_tot_ice)

  dq_tot_ocn = sum(Ocn_stock(ISTOCK_WATER)%dq)
  call mpp_sum(dq_tot_ocn)

  if(pe==root) then
     write(*,'(a,4f10.7,a,e10.2)') ' Total delta_q(water) Atm/Lnd/Ice/Ocn: ', &
          & dq_tot_atm, dq_tot_lnd, dq_tot_ice, dq_tot_ocn, &
          & ' residue: ', dq_tot_atm + dq_tot_lnd + dq_tot_ice + dq_tot_ocn
  endif

 
end program main
! end of _XGRID_MAIN
#endif



module fft_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     Performs simultaneous fast Fourier transforms (FFTs) between
!     real grid space and complex Fourier space.
! </OVERVIEW>

! <DESCRIPTION>
!     This routine computes multiple 1-dimensional FFTs and inverse FFTs.
!     There are 2d and 3d versions between type real grid point space
!     and type complex Fourier space. There are single (32-bit) and
!     full (64-bit) versions.
!
!     On Cray and SGI systems, vendor-specific scientific library
!     routines are used, otherwise a user may choose a NAG library version
!     or stand-alone version using Temperton's FFT.
! </DESCRIPTION>

!-----------------------------------------------------------------------
!these are used to determine hardware/OS/compiler

#ifdef __sgi
#  ifdef _COMPILER_VERSION
!the MIPSPro compiler defines _COMPILER_VERSION
#    define sgi_mipspro
#  else
#    define sgi_generic
#  endif
#endif

!fft uses the SCILIB on SGICRAY, and the NAG library otherwise
#if defined(_CRAY) || defined(sgi_mipspro)
#  define SGICRAY
#endif

use platform_mod, only: R8_KIND, R4_KIND
use      fms_mod, only: write_version_number,  &
                        error_mesg, FATAL
#ifndef SGICRAY
#ifndef NAGFFT
use    fft99_mod, only: fft991, set99
#endif
#endif

implicit none
private

!----------------- interfaces --------------------

public :: fft_init, fft_end, fft_grid_to_fourier, fft_fourier_to_grid

! <INTERFACE NAME="fft_grid_to_fourier">

!   <OVERVIEW>
!     Given multiple sequences of real data values, this routine
!     computes the complex Fourier transform for all sequences.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Given multiple sequences of real data values, this routine
!     computes the complex Fourier transform for all sequences.
!   </DESCRIPTION>
!   <TEMPLATE>
!     fourier = fft_grid_to_fourier ( grid )
!   </TEMPLATE>
!   <IN NAME="grid">
!     Multiple sequence of real data values. The first dimension
!     must be n+1 (where n is the size of a single sequence).
!   </IN>
!   <OUT NAME="fourier">
!     Multiple sequences of transformed data in complex Fourier space.
!     The first dimension must equal n/2+1 (where n is the size
!     of a single sequence). The remaining dimensions must be the
!     same size as the input argument "grid".
!   </OUT>
!   <NOTE>
!     The complex Fourier components are passed in the following format.
!     <PRE>
!        fourier (1)     = cmplx ( a(0), b(0) )
!        fourier (2)     = cmplx ( a(1), b(1) )
!            :              :
!            :              :
!        fourier (n/2+1) = cmplx ( a(n/2), b(n/2) )
!     </PRE>
!   where n = length of each real transform
!   </NOTE>
!   <ERROR MSG="fft_init must be called" STATUS="Error">
!     The initialization routine fft_init must be called before routines
!     fft_grid_to_fourier. 
!   </ERROR>
!   <ERROR MSG="size of first dimension of input data is wrong" STATUS="Error">
!     The real grid point field must have a first dimension equal to n+1
!      (where n is the size of each real transform). This message occurs
!      when using the SGI/Cray fft.
!   </ERROR>
!   <ERROR MSG="length of input data too small" STATUS="Error">
!      The real grid point field must have a first dimension equal to n
!      (where n is the size of each real transform). This message occurs
!      when using the NAG or Temperton fft.
!   </ERROR>
!   <ERROR MSG="float kind not supported for nag fft" STATUS="Error">
!      32-bit real data is not supported when using the NAG fft. You
!      may try modifying this part of the code by uncommenting the
!      calls to the NAG library or less consider using the Temperton fft.
!   </ERROR>
interface fft_grid_to_fourier
  module procedure fft_grid_to_fourier_float_2d, fft_grid_to_fourier_double_2d, &
                   fft_grid_to_fourier_float_3d, fft_grid_to_fourier_double_3d
end interface
! </INTERFACE>

! <INTERFACE NAME="fft_fourier_to_grid">

!   <OVERVIEW>
!     Given multiple sequences of Fourier space transforms,
!     this routine computes the inverse transform and returns
!     the real data values for all sequences.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Given multiple sequences of Fourier space transforms,
!     this routine computes the inverse transform and returns
!     the real data values for all sequences.
!   </DESCRIPTION>
!   <TEMPLATE>
!     grid = fft_fourier_to_grid ( fourier )
!   </TEMPLATE>
!   <IN NAME="fourier">
!     Multiple sequence complex Fourier space transforms.
!     The first dimension must equal n/2+1 (where n is the
!     size of a single real data sequence).
!   </IN>
!   <OUT NAME="grid">
!     Multiple sequence of real data values. The first dimension
!     must be n+1 (where n is the size of a single sequence).
!     The remaining dimensions must be the same size as the input
!     argument "fourier".
!   </OUT>
!   <ERROR MSG="fft_init must be called" STATUS="Error">
!     The initialization routine fft_init must be called before routines fft_fourier_to_grid.
!   </ERROR>
!   <ERROR MSG="size of first dimension of input data is wrong" STATUS="Error">
!      The complex Fourier field must have a first dimension equal to
!      n/2+1 (where n is the size of each real transform). This message
!      occurs when using the SGI/Cray fft. 
!   </ERROR>
!   <ERROR MSG="length of input data too small" STATUS="Error">
!      The complex Fourier field must have a first dimension greater
!      than or equal to n/2+1 (where n is the size of each real
!      transform). This message occurs when using the NAG or Temperton fft. 
!   </ERROR>
!   <ERROR MSG="float kind not supported for nag fft" STATUS="Error">
!      float kind not supported for nag fft 
!      32-bit real data is not supported when using the NAG fft. You
!      may try modifying this part of the code by uncommenting the
!      calls to the NAG library or less consider using the Temperton fft.
!   </ERROR>
interface fft_fourier_to_grid
  module procedure fft_fourier_to_grid_float_2d, fft_fourier_to_grid_double_2d, &
                   fft_fourier_to_grid_float_3d, fft_fourier_to_grid_double_3d
end interface
! </INTERFACE>

!---------------------- private data -----------------------------------

! tables for trigonometric constants and factors
! (not all will be used)
real(R8_KIND), allocatable, dimension(:) :: table8
real(R4_KIND), allocatable, dimension(:) :: table4
real         , allocatable, dimension(:) :: table99
integer      , allocatable, dimension(:) :: ifax

logical :: do_log =.true.
integer :: leng, leng1, leng2, lenc    ! related to transform size

logical :: module_is_initialized=.false.

!  cvs version and tag name
character(len=128) :: version = '$Id: fft.F90,v 13.0 2006/03/28 21:38:54 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!-----------------------------------------------------------------------
!
!                    WRAPPER FOR FFT
!
!   Provides fast fourier transtorm (FFT) between real grid
!   space and complex fourier space.
!
!   The complex fourier components are passed in the following format.
!
!        fourier (1)     = cmplx ( a(0), b(0) )
!        fourier (2)     = cmplx ( a(1), b(1) )
!            :              :
!            :              :
!        fourier (n/2+1) = cmplx ( a(n/2), b(n/2) )
!
!   where n = length of each real transform
!
!   fft uses the SCILIB on SGICRAY, otherwise the NAG library or
!   a standalone version of Temperton's fft is used
!     SCFFTM and CSFFTM are used on Crays
!     DZFFTM and ZDFFTM are used on SGIs
!   The following NAG routines are used: c06fpf, c06gqf, c06fqf.
!   These routine names may be slightly different on different 
!   platforms.
!
!-----------------------------------------------------------------------

contains

!#######################################################################

! <FUNCTION NAME="fft_grid_to_fourier_float_2d" INTERFACE="fft_grid_to_fourier">
!   <IN NAME="grid" TYPE="real(R4_KIND)" DIM="(:,:)"></IN>
!   <OUT NAME="fourier" TYPE="complex(R4_KIND)" DIM="(lenc,size(grid,2))"> </OUT>

! </FUNCTION>
 function fft_grid_to_fourier_float_2d (grid) result (fourier)

!-----------------------------------------------------------------------

   real   (R4_KIND), intent(in),  dimension(:,:)  :: grid
   complex(R4_KIND), dimension(lenc,size(grid,2)) :: fourier

!-----------------------------------------------------------------------
!
!  input
!  -----
!   grid = Multiple transforms in grid point space, the first dimension
!          must be n+1 (where n is the size of each real transform).
!
!  returns
!  -------
!    Multiple transforms in complex fourier space, the first dimension
!    must equal n/2+1 (where n is the size of each real transform).
!    The remaining dimensions must be the same size as the input
!    argument "grid".
!
!-----------------------------------------------------------------------
#ifdef SGICRAY
#  ifdef _CRAY
!  local storage for cray fft
   real(R4_KIND), dimension((2*leng+4)*size(grid,2)) :: work
#  else
!  local storage for sgi fft
   real(R4_KIND), dimension(leng2) :: work
#  endif
#else
#  ifdef NAGFFT
!  local storage for nag fft
   real(R4_KIND), dimension(size(grid,2),leng) :: data, work
#  else
!  local storage for temperton fft
   real, dimension(leng2,size(grid,2)) :: data
   real, dimension(leng1,size(grid,2)) :: work
#  endif   
#endif   

#if defined(SGICRAY) || defined(NAGFFT)
   real(R4_KIND) :: scale
#endif
   integer :: j, k, num, len_grid

!-----------------------------------------------------------------------

      if (.not.module_is_initialized) &
        call error_handler ('fft_grid_to_fourier',  &
                            'fft_init must be called.')

!-----------------------------------------------------------------------

      len_grid = size(grid,1)
#ifdef SGICRAY
      if (len_grid /= leng1) call error_handler ('fft_grid_to_fourier',  &
                        'size of first dimension of input data is wrong')
#else
      if (len_grid < leng) call error_handler ('fft_grid_to_fourier',  &
                                   'length of input data too small.')
#endif
!-----------------------------------------------------------------------
!----------------transform to fourier coefficients (+1)-----------------

      num   = size(grid,2)    ! number of transforms

#ifdef SGICRAY
!  Cray/SGI fft
      scale = 1./real(leng)
#  ifdef _CRAY
      call scfftm (-1,leng,num,scale, grid,leng1, fourier,lenc,  &
                   table4, work, 0)
#  else
      call scfftm (-1,leng,num,scale, grid,leng1, fourier,lenc,  &
                   table4, work, 0)
#  endif
#else
#  ifdef NAGFFT
!  NAG fft
!  will not allow float kind for NAG
      call error_handler ('fft_grid_to_fourier',  &
                          'float kind not supported for nag fft')
      do j=1,size(grid,2)
         data(j,1:leng) = grid(1:leng,j)
      enddo
      scale = 1./sqrt(float(leng))
      data = data * scale
      fourier(1,:) = cmplx( data(:,1), 0. )
      do k=2,lenc-1
         fourier(k,:) = cmplx( data(:,k), data(:,leng-k+2) )
      enddo
      fourier(lenc,:) = cmplx( data(:,lenc), 0. )
#  else
!  Temperton fft
      do j=1,num
        data(1:leng,j) = grid(1:leng,j)
      enddo
      call fft991 (data,work,table99,ifax,1,leng2,leng,num,-1)
      do j=1,size(grid,2)
      do k=1,lenc
        fourier(k,j) = cmplx( data(2*k-1,j), data(2*k,j) )
      enddo
      enddo
#  endif
#endif
!-----------------------------------------------------------------------

 end function fft_grid_to_fourier_float_2d

!#######################################################################

! <FUNCTION NAME="fft_fourier_to_grid_float_2d" INTERFACE="fft_fourier_to_grid">
!   <IN NAME="fourier" TYPE="real(R4_KIND)" DIM="(:,:)"></IN>
!   <OUT NAME="grid" TYPE="complex(R4_KIND)" DIM="(leng1,size(fourier,2))"> </OUT>

! </FUNCTION>
 function fft_fourier_to_grid_float_2d (fourier) result (grid)

!-----------------------------------------------------------------------

   complex(R4_KIND),  intent(in),  dimension(:,:)     :: fourier
   real   (R4_KIND), dimension(leng1,size(fourier,2)) :: grid

!-----------------------------------------------------------------------
!
!  input
!  -----
!  fourier = Multiple transforms in complex fourier space, the first 
!            dimension must equal n/2+1 (where n is the size of each
!            real transform).
!
!  returns
!  -------
!    Multiple transforms in grid point space, the first dimension
!    must be n+1 (where n is the size of each real transform).
!    The remaining dimensions must be the same size as the input
!    argument "fourier".
!
!-----------------------------------------------------------------------
#ifdef SGICRAY
#  ifdef _CRAY
!  local storage for cray fft
   real(R4_KIND), dimension((2*leng+4)*size(fourier,2)) :: work
#  else
!  local storage for sgi fft
   real(R4_KIND), dimension(leng2) :: work
#  endif
#else
#  ifdef NAGFFT
!  local storage for nag fft
   real(R4_KIND), dimension(size(fourier,2),leng) :: data, work
#  else
!  local storage for temperton fft
   real, dimension(leng2,size(fourier,2)) :: data
   real, dimension(leng1,size(fourier,2)) :: work
#  endif   
#endif   

#if defined(SGICRAY) || defined(NAGFFT)
   real(R4_KIND) :: scale
#endif
   integer :: j, k, num, len_fourier

!-----------------------------------------------------------------------

   if (.not.module_is_initialized) &
      call error_handler ('fft_grid_to_fourier',  &
                          'fft_init must be called.')

!-----------------------------------------------------------------------

      len_fourier = size(fourier,1)
      num         = size(fourier,2)    ! number of transforms

#ifdef SGICRAY
      if (len_fourier /= lenc) call error_handler ('fft_fourier_to_grid', &
               'size of first dimension of input data is wrong')
#else
      if (len_fourier < lenc) call error_handler ('fft_fourier_to_grid',  &
                               'length of input data too small.')
#endif
!-----------------------------------------------------------------------
!----------------inverse transform to real space (-1)-------------------

#ifdef SGICRAY
!  Cray/SGI fft
      scale = 1.0
#  ifdef _CRAY
      call csfftm (+1,leng,num,scale, fourier,len_fourier,  &
                     grid,leng1, table4, work, 0)
#  else
      call csfftm (+1,leng,num,scale, fourier,len_fourier,  &
                     grid,leng1, table4, work, 0)
#  endif
#else
#  ifdef NAGFFT
!  NAG fft
!  will not allow float kind for nag
      call error_handler ('fft_fourier_to_grid',  &
                          'float kind not supported for nag fft')

  ! save input complex array in real format (herm.)
      do k=1,lenc
         data(:,k) = real(fourier(k,:))
      enddo
      do k=2,lenc-1
         data(:,leng-k+2) = aimag(fourier(k,:))
      enddo

  ! scale and transpose data
      scale = sqrt(real(leng))
      do j=1,num
         grid(1:leng,j) = data(j,1:leng)*scale
      enddo
#  else
!  Temperton fft
      do j=1,num
      do k=1,lenc
         data(2*k-1,j) = real (fourier(k,j))
         data(2*k  ,j) = aimag(fourier(k,j))
      enddo
      enddo
      call fft991 (data,work,table99,ifax,1,leng2,leng,num,+1)
      do j=1,num
         grid(1:leng,j) = data(1:leng,j)
      enddo
#  endif
#endif

!-----------------------------------------------------------------------

 end function fft_fourier_to_grid_float_2d

!#######################################################################
! <FUNCTION NAME="fft_grid_to_fourier_double_2d" INTERFACE="fft_grid_to_fourier">
!   <IN NAME="grid" TYPE="real(R8_KIND)" DIM="(:,:)"></IN>
!   <OUT NAME="fourier" TYPE="complex(R8_KIND)" DIM="(lenc,size(grid,2))"> </OUT>

! </FUNCTION>
 function fft_grid_to_fourier_double_2d (grid) result (fourier)

!-----------------------------------------------------------------------

   real   (R8_KIND), intent(in),  dimension(:,:)  :: grid
   complex(R8_KIND), dimension(lenc,size(grid,2)) :: fourier

!-----------------------------------------------------------------------
!
!  input
!  -----
!   grid = Multiple transforms in grid point space, the first dimension
!          must be n+1 (where n is the size of each real transform).
!
!  returns
!  -------
!    Multiple transforms in complex fourier space, the first dimension
!    must equal n/2+1 (where n is the size of each real transform).
!    The remaining dimensions must be the same size as the input
!    argument "grid".
!
!-----------------------------------------------------------------------
#ifdef SGICRAY
#  ifdef _CRAY
!  local storage for cray fft
   real(R8_KIND), dimension((2*leng+4)*size(grid,2)) :: work
#  else
!  local storage for sgi fft
   real(R8_KIND), dimension(leng2) :: work
#  endif
#else
#  ifdef NAGFFT
!  local storage for nag fft
   real(R8_KIND), dimension(size(grid,2),leng) :: data, work
#  else
!  local storage for temperton fft
   real, dimension(leng2,size(grid,2)) :: data
   real, dimension(leng1,size(grid,2)) :: work
#  endif   
#endif   

#if defined(SGICRAY) || defined(NAGFFT)
   real(R8_KIND) :: scale
#endif
   integer :: j, k, num, len_grid
#ifdef NAGFFT
   integer :: ifail
#endif

!-----------------------------------------------------------------------

      if (.not.module_is_initialized) &
        call error_handler ('fft_grid_to_fourier',  &
                            'fft_init must be called.')

!-----------------------------------------------------------------------

      len_grid = size(grid,1)
#ifdef SGICRAY
      if (len_grid /= leng1) call error_handler ('fft_grid_to_fourier',  &
                        'size of first dimension of input data is wrong')
#else
      if (len_grid < leng) call error_handler ('fft_grid_to_fourier',  &
                                   'length of input data too small.')
#endif
!-----------------------------------------------------------------------
!----------------transform to fourier coefficients (+1)-----------------

      num   = size(grid,2)    ! number of transforms
#ifdef SGICRAY
!  Cray/SGI fft
      scale = 1./float(leng)
#  ifdef _CRAY
      call scfftm (-1,leng,num,scale, grid,leng1, fourier,lenc,  &
                   table8, work, 0)
#  else
      call dzfftm (-1,leng,num,scale, grid,leng1, fourier,lenc,  &
                   table8, work, 0)
#  endif
#else
#  ifdef NAGFFT
!  NAG fft
      do j=1,size(grid,2)
         data(j,1:leng) = grid(1:leng,j)
      enddo
      call c06fpf ( num, leng, data, 's', table8, work, ifail )
      scale = 1./sqrt(float(leng))
      data = data * scale
      fourier(1,:) = cmplx( data(:,1), 0. )
      do k=2,lenc-1
         fourier(k,:) = cmplx( data(:,k), data(:,leng-k+2) )
      enddo
      fourier(lenc,:) = cmplx( data(:,lenc), 0. )
#  else
!  Temperton fft
      do j=1,num
        data(1:leng,j) = grid(1:leng,j)
      enddo
      call fft991 (data,work,table99,ifax,1,leng2,leng,num,-1)
      do j=1,size(grid,2)
      do k=1,lenc
        fourier(k,j) = cmplx( data(2*k-1,j), data(2*k,j) )
      enddo
      enddo
#  endif
#endif
!-----------------------------------------------------------------------

 end function fft_grid_to_fourier_double_2d

!#######################################################################

! <FUNCTION NAME="fft_fourier_to_grid_double_2d" INTERFACE="fft_fourier_to_grid">
!   <IN NAME="fourier" TYPE="real(R8_KIND)" DIM="(:,:)"></IN>
!   <OUT NAME="grid" TYPE="complex(R8_KIND)" DIM="(leng1,size(fourier,2))"> </OUT>

! </FUNCTION>
 function fft_fourier_to_grid_double_2d (fourier) result (grid)

!-----------------------------------------------------------------------

   complex(R8_KIND),  intent(in),  dimension(:,:)     :: fourier
   real   (R8_KIND), dimension(leng1,size(fourier,2)) :: grid

!-----------------------------------------------------------------------
!
!  input
!  -----
!  fourier = Multiple transforms in complex fourier space, the first 
!            dimension must equal n/2+1 (where n is the size of each
!            real transform).
!
!  returns
!  -------
!    Multiple transforms in grid point space, the first dimension
!    must be n+1 (where n is the size of each real transform).
!    The remaining dimensions must be the same size as the input
!    argument "fourier".
!
!-----------------------------------------------------------------------
#ifdef SGICRAY
#  ifdef _CRAY
!  local storage for cray fft
   real(R8_KIND), dimension((2*leng+4)*size(fourier,2)) :: work
#  else
!  local storage for sgi fft
   real(R8_KIND), dimension(leng2) :: work
#  endif
#else
#  ifdef NAGFFT
!  local storage for nag fft
   real(R8_KIND), dimension(size(fourier,2),leng) :: data, work
#  else
!  local storage for temperton fft
   real, dimension(leng2,size(fourier,2)) :: data
   real, dimension(leng1,size(fourier,2)) :: work
#  endif   
#endif   

#if defined(SGICRAY) || defined(NAGFFT)
   real(R8_KIND) :: scale
#endif
   integer :: j, k, num, len_fourier
#ifdef NAGFFT
   integer :: ifail
#endif

!-----------------------------------------------------------------------

      if (.not.module_is_initialized) &
        call error_handler ('fft_grid_to_fourier',  &
                            'fft_init must be called.')

!-----------------------------------------------------------------------

      len_fourier = size(fourier,1)
      num         = size(fourier,2)    ! number of transforms

#ifdef SGICRAY
      if (len_fourier /= lenc) call error_handler ('fft_fourier_to_grid', &
               'size of first dimension of input data is wrong')
#else
      if (len_fourier < lenc) call error_handler ('fft_fourier_to_grid',  &
                               'length of input data too small.')
#endif
!-----------------------------------------------------------------------
!----------------inverse transform to real space (-1)-------------------

#ifdef SGICRAY
!  Cray/SGI fft
      scale = 1.0
#  ifdef _CRAY
      call csfftm (+1,leng,num,scale, fourier,len_fourier,  &
                     grid,leng1, table8, work, 0)
#  else
      call zdfftm (+1,leng,num,scale, fourier,len_fourier,  &
                     grid,leng1, table8, work, 0)
#  endif
#else
#  ifdef NAGFFT
!  NAG fft

    ! save input complex array in real format (herm.)
      do k=1,lenc
         data(:,k) = real(fourier(k,:))
      enddo
      do k=2,lenc-1
         data(:,leng-k+2) = aimag(fourier(k,:))
      enddo

      call c06gqf ( num, leng, data, ifail )
      call c06fqf ( num, leng, data, 's', table8, work, ifail )

    ! scale and transpose data
      scale = sqrt(real(leng))
      do j=1,num
         grid(1:leng,j) = data(j,1:leng)*scale
      enddo
#  else
!  Temperton fft
      do j=1,num
      do k=1,lenc
         data(2*k-1,j) = real (fourier(k,j))
         data(2*k  ,j) = aimag(fourier(k,j))
      enddo
      enddo
      call fft991 (data,work,table99,ifax,1,leng2,leng,num,+1)
      do j=1,num
         grid(1:leng,j) = data(1:leng,j)
      enddo
#  endif
#endif

!-----------------------------------------------------------------------

 end function fft_fourier_to_grid_double_2d

!#######################################################################
!                   interface overloads
!#######################################################################
! <FUNCTION NAME="fft_grid_to_fourier_float_3d" INTERFACE="fft_grid_to_fourier">
!   <IN NAME="grid" TYPE="real(R4_KIND)" DIM="(:,:,:)"></IN>
!   <OUT NAME="fourier" TYPE="complex(R4_KIND)" DIM="(lenc,size(grid,2),size(grid,3))"> </OUT>

! </FUNCTION>

 function fft_grid_to_fourier_float_3d (grid) result (fourier)

!-----------------------------------------------------------------------
   real   (R4_KIND),    intent(in),  dimension(:,:,:) :: grid
   complex(R4_KIND), dimension(lenc,size(grid,2),size(grid,3)) :: fourier
   integer :: n
!-----------------------------------------------------------------------

    do n = 1, size(grid,3)
      fourier(:,:,n) = fft_grid_to_fourier_float_2d (grid(:,:,n))
    enddo

!-----------------------------------------------------------------------

 end function fft_grid_to_fourier_float_3d

!#######################################################################

! <FUNCTION NAME="fft_fourier_to_grid_float_3d" INTERFACE="fft_fourier_to_grid">
!   <IN NAME="fourier" TYPE="real(R4_KIND)" DIM="(:,:,:)"></IN>
!   <OUT NAME="grid" TYPE="complex(R4_KIND)" DIM="(leng1,size(fourier,2),size(fourier,3))"> </OUT>

! </FUNCTION>
 function fft_fourier_to_grid_float_3d (fourier) result (grid)

!-----------------------------------------------------------------------
   complex(R4_KIND),  intent(in),  dimension(:,:,:) :: fourier
   real   (R4_KIND), dimension(leng1,size(fourier,2),size(fourier,3)) :: grid
   integer :: n
!-----------------------------------------------------------------------

    do n = 1, size(fourier,3)
      grid(:,:,n) = fft_fourier_to_grid_float_2d (fourier(:,:,n))
    enddo

!-----------------------------------------------------------------------

 end function fft_fourier_to_grid_float_3d

!#######################################################################

! <FUNCTION NAME="fft_grid_to_fourier_double_3d" INTERFACE="fft_grid_to_fourier">
!   <IN NAME="grid" TYPE="real(R8_KIND)" DIM="(:,:,:)"></IN>
!   <OUT NAME="fourier" TYPE="complex(R8_KIND)" DIM="(lenc,size(grid,2),size(grid,3))"> </OUT>

! </FUNCTION>
 function fft_grid_to_fourier_double_3d (grid) result (fourier)

!-----------------------------------------------------------------------
   real   (R8_KIND),    intent(in),  dimension(:,:,:) :: grid
   complex(R8_KIND), dimension(lenc,size(grid,2),size(grid,3)) :: fourier
   integer :: n
!-----------------------------------------------------------------------

    do n = 1, size(grid,3)
      fourier(:,:,n) = fft_grid_to_fourier_double_2d (grid(:,:,n))
    enddo

!-----------------------------------------------------------------------

 end function fft_grid_to_fourier_double_3d

!#######################################################################

! <FUNCTION NAME="fft_fourier_to_grid_double_3d" INTERFACE="fft_fourier_to_grid">
!   <IN NAME="fourier" TYPE="real(R8_KIND)" DIM="(:,:,:)"></IN>
!   <OUT NAME="grid" TYPE="complex(R8_KIND)" DIM="(leng1,size(fourier,2),size(fourier,3))"> </OUT>

! </FUNCTION>
 function fft_fourier_to_grid_double_3d (fourier) result (grid)

!-----------------------------------------------------------------------
   complex(R8_KIND),  intent(in),  dimension(:,:,:) :: fourier
   real   (R8_KIND), dimension(leng1,size(fourier,2),size(fourier,3)) :: grid
   integer :: n
!-----------------------------------------------------------------------

    do n = 1, size(fourier,3)
      grid(:,:,n) = fft_fourier_to_grid_double_2d (fourier(:,:,n))
    enddo

!-----------------------------------------------------------------------

 end function fft_fourier_to_grid_double_3d

!#######################################################################

! <SUBROUTINE NAME="fft_init">

!   <OVERVIEW>
!     This routine must be called to initialize the size of a
!        single transform and setup trigonometric constants.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine must be called once to initialize the size of a
!   single transform. To change the size of the transform the
!   routine fft_exit must be called before re-initialing with fft_init.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call fft_init ( n )
!   </TEMPLATE>
!   <IN NAME="n" TYPE="integer" >
!     The number of real values in a single sequence of data.
!        The resulting transformed data will have n/2+1 pairs of
!        complex values.
!   </IN>
 subroutine fft_init (n)

!-----------------------------------------------------------------------
   integer, intent(in) :: n
!-----------------------------------------------------------------------
!
!   n = size (length) of each transform
!
!-----------------------------------------------------------------------
#ifdef SGICRAY
   real   (R4_KIND) ::  dummy4(1)
   complex(R4_KIND) :: cdummy4(1)
   real   (R8_KIND) ::  dummy8(1)
   complex(R8_KIND) :: cdummy8(1)
   integer :: isys(0:1)
#else
#  ifdef NAGFFT
   real(R8_KIND) :: data8(n), work8(n)
   real(R4_KIND) :: data4(n), work4(n)
   integer       :: ifail4, ifail8
#  endif
#endif
!-----------------------------------------------------------------------
!   --- fourier transform initialization ----

!   <ERROR MSG="attempted to reinitialize fft"
!          STATUS="FATAL">
!     You must call fft_exit before calling fft_init for a second time.
!   </ERROR>

      if (module_is_initialized) &
      call error_handler ('fft_init', 'attempted to reinitialize fft')

!  write version and tag name to log file
   if (do_log) then
      call write_version_number (version, tagname)
      do_log = .false.
   endif

!  variables that save length of transform
      leng = n; leng1 = n+1; leng2 = n+2; lenc = n/2+1

#ifdef SGICRAY
#  ifdef _CRAY
!  initialization for cray
!  float kind may not apply for cray
      allocate (table4(100+2*leng), table8(100+2*leng))   ! size may be too large?
      call scfftm (0,leng,1,0.0, dummy4, 1, cdummy4, 1, table4, dummy4, 0)
      call scfftm (0,leng,1,0.0, dummy8, 1, cdummy8, 1, table8, dummy8, 0)
#  else
!  initialization for sgi
      allocate (table4(leng+256), table8(leng+256))
      isys(0) = 1
      call scfftm (0,leng,1,0.0, dummy4, 1, cdummy4, 1, table4, dummy8, isys)
      call dzfftm (0,leng,1,0.0, dummy8, 1, cdummy8, 1, table8, dummy8, isys)
#  endif
#else
#  ifdef NAGFFT
!  initialization for nag fft
      ifail8 = 0
      allocate (table8(100+2*leng))   ! size may be too large?
      call c06fpf ( 1, leng, data8, 'i', table8, work8, ifail8 )

!  will not allow float kind for nag
      ifail4 = 0
!!!!! allocate (table4(100+2*leng))
!!!!! call c06fpe ( 1, leng, data4, 'i', table4, work4, ifail4 )

      if (ifail4 /= 0 .or. ifail8 /= 0) then
          call error_handler ('fft_init', 'nag fft initialization error')
      endif
#  else
!  initialization for Temperton fft
      allocate (table99(3*leng/2+1))
      allocate (ifax(10))
      call set99 ( table99, ifax, leng )
#  endif
#endif

      module_is_initialized = .true.

!-----------------------------------------------------------------------

 end subroutine fft_init
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="fft_end">

!   <OVERVIEW>
!     This routine is called to unset the transform size and deallocate memory.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine is called to unset the transform size and
!   deallocate memory. It can not be called unless fft_init
!   has already been called. There are no arguments.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call fft_end
!   </TEMPLATE>
!   <ERROR MSG="attempt to un-initialize fft that has not been initialized" STATUS="Error">
!     You can not call fft_end unless fft_init has been called.
!   </ERROR>
 subroutine fft_end

!-----------------------------------------------------------------------
!
!   unsets transform size and deallocates memory
!
!-----------------------------------------------------------------------
!   --- fourier transform un-initialization ----

      if (.not.module_is_initialized) &
        call error_handler ('fft_end', &
          'attempt to un-initialize fft that has not been initialized')

      leng = 0; leng1 = 0; leng2 = 0; lenc = 0

      if (allocated(table4))  deallocate (table4)
      if (allocated(table8))  deallocate (table8)
      if (allocated(table99)) deallocate (table99)

      module_is_initialized = .false.

!-----------------------------------------------------------------------

 end subroutine fft_end
! </SUBROUTINE>

!#######################################################################
! wrapper for handling errors

 subroutine error_handler ( routine, message )
 character(len=*), intent(in) :: routine, message

   call error_mesg ( routine, message, FATAL )

!  print *, 'ERROR: ',trim(routine)
!  print *, 'ERROR: ',trim(message)
!  stop 111

 end subroutine error_handler

!#######################################################################

end module fft_mod

#ifdef test_fft
program test
use fft_mod
integer, parameter :: lot = 2
real   , allocatable :: ain(:,:), aout(:,:)
complex, allocatable :: four(:,:)
integer :: i, j, m, n
integer :: ntrans(2) = (/ 60, 90 /)

! test multiple transform lengths
  do m = 1,2

  ! set up input data
    n = ntrans(m)
    allocate (ain(n+1,lot),aout(n+1,lot),four(n/2+1,lot))
    call random_number (ain(1:n,:))
    aout(1:n,:) = ain(1:n,:)

    call fft_init (n)
  ! transform grid to fourier and back
    four = fft_grid_to_fourier (aout)
    aout = fft_fourier_to_grid (four)

  ! print original and transformed
    do j=1,lot
    do i=1,n
      write (*,'(2i4,3(2x,f15.9))') j, i, ain(i,j), aout(i,j), aout(i,j)-ain(i,j)
    enddo
    enddo

    call fft_end
    deallocate (ain,aout,four)
  enddo

end program test
#endif

! <INFO>
!   <REFERENCE>        
!     For the SGI/Cray version refer to the manual pages for
!     DZFFTM, ZDFFTM, SCFFTM, and CSFFTM. 
!   </REFERENCE>
!   <REFERENCE>
!     For the NAG version refer to the NAG documentation for
!     routines C06FPF, C06FQF, and C06GQF. 
!   </REFERENCE>
!   <PRECOMP FLAG="-D NAGFFT">  
!      -D NAGFFT
!      On non-Cray/SGI machines, set to use the NAG library FFT routines.
!      Otherwise the Temperton FFT is used by default.
!   </PRECOMP> 
!   <PRECOMP FLAG="-D test_fft">
!      Provides source code for a simple test program.
!   The program generates several sequences of real data.
!   This data is transformed to Fourier space and back to real data,
!   then compared to the original real data.
!   </PRECOMP>
!   <LOADER FLAG="-lscs">   
!     On SGI machines the scientific library needs to be loaded by
!     linking with:
!   </LOADER>
!   <LOADER FLAG="-L/usr/local/lib -lnag">    
!     If using the NAG library, the following loader options (or
!     something similar) may be necessary:
!   </LOADER>
!   <NOTE>             
!     The routines are overloaded for 2d and 3d versions.
!     The 2d versions copy data into 3d arrays then calls the 3d interface.
!
!     On SGI/Cray machines:
!
!     There are single (32-bit) and full (64-bit) versions.
!     For Cray machines the single precision version does not apply.
!
!     On non-SGI/CRAY machines:
!
!     The NAG library option uses the "full" precision NAG
!     routines (C06FPF,C06FQF,C06GQF). Users may have to specify
!     a 64-bit real compiler option (e.g., -r8).
!
!     The stand-alone Temperton FFT option works for the
!     real precision specified at compile time.
!     If you compiled with single (32-bit) real precision
!     then FFT's cannot be computed at full (64-bit) precision.
!   </NOTE>
! </INFO>



module fft99_mod

use constants_mod, only: pi
use mpp_mod,       only: mpp_error, FATAL

implicit none
private

public :: fft99, fft991, set99

contains

!##########################################################################

    subroutine fft99 (a,work,trigs,ifax,inc,jump,n,lot,isign) 

! purpose      performs multiple fast fourier transforms.  this package
!              will perform a number of simultaneous real/half-complex
!              periodic fourier transforms or corresponding inverse
!              transforms, i.e.  given a set of real data vectors, the
!              package returns a set of 'half-complex' fourier
!              coefficient vectors, or vice versa.  the length of the
!              transforms must be an even number greater than 4 that has
!              no other factors except possibly powers of 2, 3, and 5.
!              this is an all-fortran version of a optimized routine
!              fft99 written for xmp/ymps by dr. clive temperton of
!              ecmwf.
!
!              the package fft99f contains several user-level routines:
!
!            subroutine set99
!                an initialization routine that must be called once
!                before a sequence of calls to the fft routines
!                (provided that n is not changed).
!
!            subroutines fft99 and fft991
!                two fft routines that return slightly different
!                arrangements of the data in gridpoint space.
!
! usage        let n be of the form 2**p * 3**q * 5**r, where p .ge. 1,
!              q .ge. 0, and r .ge. 0.  then a typical sequence of
!              calls to transform a given set of real vectors of length
!              n to a set of 'half-complex' fourier coefficient vectors
!              of length n is
!
!                   dimension ifax(13),trigs(3*n/2+1),a(m*(n+2)),
!                  +          work(m*(n+1))
!
!                   call set99 (trigs, ifax, n)
!                   call fft99 (a,work,trigs,ifax,inc,jump,n,m,isign)
!
!              see the individual write-ups for set99, fft99, and
!              fft991 below, for a detailed description of the
!              arguments.
!
! history      the package was written by clive temperton at ecmwf in
!              november, 1978.  it was modified, documented, and tested
!              for ncar by russ rew in september, 1980.
!
!-----------------------------------------------------------------------
!
! subroutine set99 (trigs, ifax, n)
!
! purpose      a set-up routine for fft99 and fft991.  it need only be
!              called once before a sequence of calls to the fft
!              routines (provided that n is not changed).
!
! argument     ifax(13),trigs(3*n/2+1)
! dimensions
!
! arguments
!
! on input     trigs
!               a floating point array of dimension 3*n/2 if n/2 is
!               even, or 3*n/2+1 if n/2 is odd.
!
!              ifax
!               an integer array.  the number of elements actually used
!               will depend on the factorization of n.  dimensioning
!               ifax for 13 suffices for all n less than a million.
!
!              n
!               an even number greater than 4 that has no prime factor
!               greater than 5.  n is the length of the transforms (see
!               the documentation for fft99 and fft991 for the
!               definitions of the transforms).
!
! on output    ifax
!               contains the factorization of n/2.  ifax(1) is the
!               number of factors, and the factors themselves are stored
!               in ifax(2),ifax(3),...  if set99 is called with n odd,
!               or if n has any prime factors greater than 5, ifax(1)
!               is set to -99.
!
!              trigs
!               an array of trigonometric function values subsequently
!               used by the fft routines.
!
!-----------------------------------------------------------------------
!
! subroutine fft991 (a,work,trigs,ifax,inc,jump,n,m,isign)
!                       and
! subroutine fft99 (a,work,trigs,ifax,inc,jump,n,m,isign)
!
! purpose      perform a number of simultaneous real/half-complex
!              periodic fourier transforms or corresponding inverse
!              transforms, using ordinary spatial order of gridpoint
!              values (fft991) or explicit cyclic continuity in the
!              gridpoint values (fft99).  given a set
!              of real data vectors, the package returns a set of
!              'half-complex' fourier coefficient vectors, or vice
!              versa.  the length of the transforms must be an even
!              number that has no other factors except possibly powers
!              of 2, 3, and 5.  this is an all-fortran version of 
!              optimized routine fft991 written for xmp/ymps by
!              dr. clive temperton of ecmwf.
!
! argument     a(m*(n+2)), work(m*(n+1)), trigs(3*n/2+1), ifax(13)
! dimensions
!
! arguments
!
! on input     a
!               an array of length m*(n+2) containing the input data
!               or coefficient vectors.  this array is overwritten by
!               the results.
!
!              work
!               a work array of dimension m*(n+1)
!
!              trigs
!               an array set up by set99, which must be called first.
!
!              ifax
!               an array set up by set99, which must be called first.
!
!              inc
!               the increment (in words) between successive elements of
!               each data or coefficient vector (e.g.  inc=1 for
!               consecutively stored data).
!
!              jump
!               the increment (in words) between the first elements of
!               successive data or coefficient vectors.  on crays, 
!               try to arrange data so that jump is not a multiple of 8
!               (to avoid memory bank conflicts).  for clarification of
!               inc and jump, see the examples below.
!
!              n
!               the length of each transform (see definition of
!               transforms, below).
!
!              m
!               the number of transforms to be done simultaneously.
!
!              isign
!               = +1 for a transform from fourier coefficients to
!                    gridpoint values.
!               = -1 for a transform from gridpoint values to fourier
!                    coefficients.
!
! on output    a
!               if isign = +1, and m coefficient vectors are supplied
!               each containing the sequence:
!
!               a(0),b(0),a(1),b(1),...,a(n/2),b(n/2)  (n+2 values)
!
!               then the result consists of m data vectors each
!               containing the corresponding n+2 gridpoint values:
!
!               for fft991, x(0), x(1), x(2),...,x(n-1),0,0.
!               for fft99, x(n-1),x(0),x(1),x(2),...,x(n-1),x(0).
!                   (explicit cyclic continuity)
!
!               when isign = +1, the transform is defined by:
!                 x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
!                 where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
!                 and i=sqrt (-1)
!
!               if isign = -1, and m data vectors are supplied each
!               containing a sequence of gridpoint values x(j) as
!               defined above, then the result consists of m vectors
!               each containing the corresponding fourier cofficients
!               a(k), b(k), 0 .le. k .le n/2.
!
!               when isign = -1, the inverse transform is defined by:
!                 c(k)=(1/n)*sum(j=0,...,n-1)(x(j)*exp(-2*i*j*k*pi/n))
!                 where c(k)=a(k)+i*b(k) and i=sqrt(-1)
!
!               a call with isign=+1 followed by a call with isign=-1
!               (or vice versa) returns the original data.
!
!               note: the fact that the gridpoint values x(j) are real
!               implies that b(0)=b(n/2)=0.  for a call with isign=+1,
!               it is not actually necessary to supply these zeros.
!
! examples      given 19 data vectors each of length 64 (+2 for explicit
!               cyclic continuity), compute the corresponding vectors of
!               fourier coefficients.  the data may, for example, be
!               arranged like this:
!
! first data   a(1)=    . . .                a(66)=             a(70)
! vector       x(63) x(0) x(1) x(2) ... x(63) x(0)  (4 empty locations)
!
! second data  a(71)=   . . .                                  a(140)
! vector       x(63) x(0) x(1) x(2) ... x(63) x(0)  (4 empty locations)
!
!               and so on.  here inc=1, jump=70, n=64, m=19, isign=-1,
!               and fft99 should be used (because of the explicit cyclic
!               continuity).
!
!               alternatively the data may be arranged like this:
!
!                first         second                          last
!                data          data                            data
!                vector        vector                          vector
!
!                 a(1)=         a(2)=                           a(19)=
!
!                 x(63)         x(63)       . . .               x(63)
!        a(20)=   x(0)          x(0)        . . .               x(0)
!        a(39)=   x(1)          x(1)        . . .               x(1)
!                  .             .                               .
!                  .             .                               .
!                  .             .                               .
!
!               in which case we have inc=19, jump=1, and the remaining
!               parameters are the same as before.  in either case, each
!               coefficient vector overwrites the corresponding input
!               data vector.
!
!-----------------------------------------------------------------------
    integer, intent(in)    :: inc,jump,n,lot,isign
    integer, intent(inout) :: ifax(:)
    real,    intent(in)    :: trigs(:)
    real,    intent(inout) :: a(*),work(*)

!     dimension a(n),work(n),trigs(n),ifax(1)
!
!     subroutine "fft99" - multiple fast real periodic transform
!     corresponding to old scalar routine fft9
!     procedure used to convert to half-length complex transform
!     is given by cooley, lewis and welch (j. sound vib., vol. 12
!     (1970), 315-337)
!
!     a is the array containing input and output data
!     work is an area of size (n+1)*lot
!     trigs is a previously prepared list of trig function values
!     ifax is a previously prepared list of factors of n/2
!     inc is the increment within each data 'vector'
!         (e.g. inc=1 for consecutively stored data)
!     jump is the increment between the start of each data vector
!     n is the length of the data vectors
!     lot is the number of data vectors
!     isign = +1 for transform from spectral to gridpoint
!           = -1 for transform from gridpoint to spectral
!
!     ordering of coefficients:
!         a(0),b(0),a(1),b(1),a(2),b(2),...,a(n/2),b(n/2)
!         where b(0)=b(n/2)=0; (n+2) locations required
!
!     ordering of data:
!         x(n-1),x(0),x(1),x(2),...,x(n),x(0)
!         i.e. explicit cyclic continuity; (n+2) locations required
!
!     vectorization is achieved on cray by doing the transforms in
!     parallel
!
!     *** n.b. n is assumed to be an even number
!
!     definition of transforms:
!     -------------------------
!
!     isign=+1: x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
!         where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
!
!     isign=-1: a(k)=(1/n)*sum(j=0,...,n-1)(x(j)*cos(2*j*k*pi/n))
!               b(k)=-(1/n)*sum(j=0,...,n-1)(x(j)*sin(2*j*k*pi/n))
!

    integer :: nfax, nx, nh, ink, igo, ibase, jbase
    integer :: i, j, k, L, m, ia, la, ib

      nfax=ifax(1)
      nx=n+1
      nh=n/2
      ink=inc+inc
      if (isign.eq.+1) go to 30

!   if necessary, transfer data to work area
      igo=50
      if (mod(nfax,2).eq.1) goto 40
      ibase=inc+1
      jbase=1
    do L=1,lot
      i=ibase
      j=jbase
!dir$ ivdep
      do m=1,n
        work(j)=a(i)
        i=i+inc
        j=j+1
      enddo
      ibase=ibase+jump
      jbase=jbase+nx
    enddo

      igo=60
      go to 40

!   preprocessing (isign=+1)
!   ------------------------

   30 continue
      call fft99a(a,work,trigs,inc,jump,n,lot)
      igo=60

!   complex transform
!   -----------------

   40 continue
      ia=inc+1
      la=1
      do 80 k=1,nfax
      if (igo.eq.60) go to 60
   50 continue
      call vpassm (a(ia),a(ia+inc),work(1),work(2),trigs, &
                   ink,2,jump,nx,lot,nh,ifax(k+1),la)
      igo=60
      go to 70
   60 continue
      call vpassm (work(1),work(2),a(ia),a(ia+inc),trigs, &
                   2,ink,nx,jump,lot,nh,ifax(k+1),la)
      igo=50
   70 continue
      la=la*ifax(k+1)
   80 continue

    if (isign.eq.-1) go to 130

! if necessary, transfer data from work area

    if (mod(nfax,2).ne.1) then
      ibase=1
      jbase=ia
      do L=1,lot
        i=ibase
        j=jbase
!dir$ ivdep
        do m=1,n
          a(j)=work(i)
          i=i+1
          j=j+inc
        enddo
        ibase=ibase+nx
        jbase=jbase+jump
      enddo
    endif

!   fill in cyclic boundary points
      ia=1
      ib=n*inc+1
!dir$ ivdep
      do L=1,lot
        a(ia)=a(ib)
        a(ib+inc)=a(ia+inc)
        ia=ia+jump
        ib=ib+jump
      enddo
      go to 140

!   postprocessing (isign=-1):
!   --------------------------

  130 continue
      call fft99b(work,a,trigs,inc,jump,n,lot)

  140 continue

    end subroutine fft99

!##########################################################################

    subroutine fft99a (a,work,trigs,inc,jump,n,lot)
    integer, intent(in)    :: inc,jump,n,lot
    real,    intent(in)    :: trigs(:)
    real,    intent(inout) :: a(*),work(*)

!     dimension a(n),work(n),trigs(n)
!
!     subroutine fft99a - preprocessing step for fft99, isign=+1
!     (spectral to gridpoint transform)

    integer :: nh, nx, ink, k, L
    integer :: ia, ib, ja, jb, iabase, ibbase, jabase, jbbase
    real    :: c, s

      nh=n/2
      nx=n+1
      ink=inc+inc

!   a(0) and a(n/2)
      ia=1
      ib=n*inc+1
      ja=1
      jb=2
!dir$ ivdep
    do L=1,lot
      work(ja)=a(ia)+a(ib)
      work(jb)=a(ia)-a(ib)
      ia=ia+jump
      ib=ib+jump
      ja=ja+nx
      jb=jb+nx
    enddo
 
!   remaining wavenumbers
      iabase=2*inc+1
      ibbase=(n-2)*inc+1
      jabase=3
      jbbase=n-1

    do k=3,nh,2
      ia=iabase
      ib=ibbase
      ja=jabase
      jb=jbbase
      c=trigs(n+k)
      s=trigs(n+k+1)
!dir$ ivdep
      do L=1,lot
        work(ja)=(a(ia)+a(ib))- &
            (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
        work(jb)=(a(ia)+a(ib))+ &
            (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
        work(ja+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))+ &
            (a(ia+inc)-a(ib+inc))
        work(jb+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))- &
            (a(ia+inc)-a(ib+inc))
        ia=ia+jump
        ib=ib+jump
        ja=ja+nx
        jb=jb+nx
      enddo
      iabase=iabase+ink
      ibbase=ibbase-ink
      jabase=jabase+2
      jbbase=jbbase-2
    enddo

!   wavenumber n/4 (if it exists)
    if (iabase.eq.ibbase) then
      ia=iabase
      ja=jabase
!dir$ ivdep
      do L=1,lot
        work(ja)=2.0*a(ia)
        work(ja+1)=-2.0*a(ia+inc)
        ia=ia+jump
        ja=ja+nx
      enddo
    endif

    end subroutine fft99a

!##########################################################################

    subroutine fft99b (work,a,trigs,inc,jump,n,lot)
    integer, intent(in)    :: inc,jump,n,lot
    real,    intent(in)    :: trigs(:)
    real,    intent(inout) :: a(*),work(*)

!     dimension work(n),a(n),trigs(n)
!
!     subroutine fft99b - postprocessing step for fft99, isign=-1
!     (gridpoint to spectral transform)

    integer :: nh, nx, ink, k, L
    integer :: ia, ib, ja, jb, iabase, ibbase, jabase, jbbase
    real    :: scale, c, s

      nh=n/2
      nx=n+1
      ink=inc+inc

!   a(0) and a(n/2)
      scale=1.0/real(n)
      ia=1
      ib=2
      ja=1
      jb=n*inc+1
!dir$ ivdep
    do L=1,lot
      a(ja)=scale*(work(ia)+work(ib))
      a(jb)=scale*(work(ia)-work(ib))
      a(ja+inc)=0.0
      a(jb+inc)=0.0
      ia=ia+nx
      ib=ib+nx
      ja=ja+jump
      jb=jb+jump
    enddo

!   remaining wavenumbers
      scale=0.5*scale
      iabase=3
      ibbase=n-1
      jabase=2*inc+1
      jbbase=(n-2)*inc+1

    do k=3,nh,2
      ia=iabase
      ib=ibbase
      ja=jabase
      jb=jbbase
      c=trigs(n+k)
      s=trigs(n+k+1)
!dir$ ivdep
      do L=1,lot
        a(ja)=scale*((work(ia)+work(ib)) &
           +(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
        a(jb)=scale*((work(ia)+work(ib)) &
           -(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
        a(ja+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1))) &
            +(work(ib+1)-work(ia+1)))
        a(jb+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1))) &
            -(work(ib+1)-work(ia+1)))
        ia=ia+nx
        ib=ib+nx
        ja=ja+jump
        jb=jb+jump
      enddo
      iabase=iabase+2
      ibbase=ibbase-2
      jabase=jabase+ink
      jbbase=jbbase-ink
    enddo

!   wavenumber n/4 (if it exists)
    if (iabase.eq.ibbase) then
      ia=iabase
      ja=jabase
      scale=2.0*scale
!dir$ ivdep
      do L=1,lot
        a(ja)=scale*work(ia)
        a(ja+inc)=-scale*work(ia+1)
        ia=ia+nx
        ja=ja+jump
      enddo
    endif

    end subroutine fft99b

!##########################################################################

    subroutine fft991(a,work,trigs,ifax,inc,jump,n,lot,isign)
    integer, intent(in)    :: inc,jump,n,lot,isign
    integer, intent(inout) :: ifax(:)
    real,    intent(in)    :: trigs(:)
    real,    intent(inout) :: a(*),work((n+1)*lot)

!     dimension a(n),work(n),trigs(n),ifax(1)
!
!     subroutine "fft991" - multiple real/half-complex periodic
!     fast fourier transform
!
!     same as fft99 except that ordering of data corresponds to
!     that in mrfft2
!
!     procedure used to convert to half-length complex transform
!     is given by cooley, lewis and welch (j. sound vib., vol. 12
!     (1970), 315-337)
!
!     a is the array containing input and output data
!     work is an area of size (n+1)*lot
!     trigs is a previously prepared list of trig function values
!     ifax is a previously prepared list of factors of n/2
!     inc is the increment within each data 'vector'
!         (e.g. inc=1 for consecutively stored data)
!     jump is the increment between the start of each data vector
!     n is the length of the data vectors
!     lot is the number of data vectors
!     isign = +1 for transform from spectral to gridpoint
!           = -1 for transform from gridpoint to spectral
!
!     ordering of coefficients:
!         a(0),b(0),a(1),b(1),a(2),b(2),...,a(n/2),b(n/2)
!         where b(0)=b(n/2)=0; (n+2) locations required
!
!     ordering of data:
!         x(0),x(1),x(2),...,x(n-1)
!
!     vectorization is achieved on cray by doing the transforms in
!     parallel
!
!     *** n.b. n is assumed to be an even number
!
!     definition of transforms:
!     -------------------------
!
!     isign=+1: x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
!         where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
!
!     isign=-1: a(k)=(1/n)*sum(j=0,...,n-1)(x(j)*cos(2*j*k*pi/n))
!               b(k)=-(1/n)*sum(j=0,...,n-1)(x(j)*sin(2*j*k*pi/n))
!

    integer :: nfax, nx, nh, ink, igo, ibase, jbase
    integer :: i, j, k, L, m, ia, la, ib


      nfax=ifax(1)
      nx=n+1
      nh=n/2
      ink=inc+inc
      if (isign.eq.+1) go to 30

!     if necessary, transfer data to work area
      igo=50
      if (mod(nfax,2).eq.1) goto 40
      ibase=1
      jbase=1
    do L=1,lot
      i=ibase
      j=jbase
!dir$ ivdep
      do m=1,n
        work(j)=a(i)
        i=i+inc
        j=j+1
      enddo
      ibase=ibase+jump
      jbase=jbase+nx
    enddo
!
      igo=60
      go to 40
!
!   preprocessing (isign=+1)
!   ------------------------
!
   30 continue
      call fft99a(a,work,trigs,inc,jump,n,lot)
      igo=60
!
!   complex transform
!   -----------------
!
   40 continue
      ia=1
      la=1
    do k=1,nfax
      if (igo.eq.60) go to 60
   50 continue
        call vpassm (a(ia),a(ia+inc),work(1),work(2),trigs, &
                     ink,2,jump,nx,lot,nh,ifax(k+1),la)
      igo=60
      go to 70
   60 continue
        call vpassm (work(1),work(2),a(ia),a(ia+inc),trigs, &
                     2,ink,nx,jump,lot,nh,ifax(k+1),la)
      igo=50
   70 continue
      la=la*ifax(k+1)
    enddo

    if (isign.eq.-1) go to 130

! if necessary, transfer data from work area
    if (mod(nfax,2).ne.1) then
      ibase=1
      jbase=1
      do L=1,lot
        i=ibase
        j=jbase
!dir$ ivdep
        do m=1,n
          a(j)=work(i)
          i=i+1
          j=j+inc
        enddo
        ibase=ibase+nx
        jbase=jbase+jump
      enddo
    endif

!   fill in zeros at end
      ib=n*inc+1
!dir$ ivdep
      do L=1,lot
        a(ib)=0.0
        a(ib+inc)=0.0
        ib=ib+jump
      enddo
      go to 140

!     postprocessing (isign=-1):
!     --------------------------

  130 continue
      call fft99b (work,a,trigs,inc,jump,n,lot)

  140 continue

    end subroutine fft991

!##########################################################################

    subroutine set99 (trigs, ifax, n)
    integer, intent(in)  :: n
    integer, intent(out) :: ifax(:)
    real,    intent(out) :: trigs(:)

!     dimension ifax(13),trigs(1)
!
! mode 3 is used for real/half-complex transforms.  it is possible
! to do complex/complex transforms with other values of mode, but
! documentation of the details were not available when this routine
! was written.
!
    integer :: mode = 3
    integer :: i

      call fax (ifax, n, mode)
      i = ifax(1)
      if (ifax(i+1) .gt. 5 .or. n .le. 4) ifax(1) = -99
      if (ifax(1) .le. 0 ) then 
        call mpp_error(FATAL,'fft99_mod: in routine set99 -- invalid n')
      endif
      call fftrig (trigs, n, mode)

    end subroutine set99

!##########################################################################

    subroutine fax (ifax,n,mode)
    integer, intent(out) :: ifax(:)
    integer, intent(in)  :: n, mode

    integer :: nn, k, L, inc, nfax, ii, istop, i, item

      nn=n
      if (iabs(mode).eq.1) go to 10
      if (iabs(mode).eq.8) go to 10
      nn=n/2
      if ((nn+nn).eq.n) go to 10
      ifax(1)=-99
      return
   10 k=1
!     test for factors of 4
   20 if (mod(nn,4).ne.0) go to 30
      k=k+1
      ifax(k)=4
      nn=nn/4
      if (nn.eq.1) go to 80
      go to 20
!     test for extra factor of 2
   30 if (mod(nn,2).ne.0) go to 40
      k=k+1
      ifax(k)=2
      nn=nn/2
      if (nn.eq.1) go to 80
!     test for factors of 3
   40 if (mod(nn,3).ne.0) go to 50
      k=k+1
      ifax(k)=3
      nn=nn/3
      if (nn.eq.1) go to 80
      go to 40
!     now find remaining factors
   50 L=5
      inc=2
!     inc alternately takes on values 2 and 4
   60 if (mod(nn,L).ne.0) go to 70
      k=k+1
      ifax(k)=L
      nn=nn/L
      if (nn.eq.1) go to 80
      go to 60
   70 L=L+inc
      inc=6-inc
      go to 60
   80 ifax(1)=k-1
!     ifax(1) contains number of factors
      nfax=ifax(1)
!     sort factors into ascending order
      if (nfax.eq.1) go to 110
      do 100 ii=2,nfax
      istop=nfax+2-ii
      do 90 i=2,istop
      if (ifax(i+1).ge.ifax(i)) go to 90
      item=ifax(i)
      ifax(i)=ifax(i+1)
      ifax(i+1)=item
   90 continue
  100 continue
  110 continue

    end subroutine fax

!##########################################################################

    subroutine fftrig (trigs,n,mode)
    real,    intent(out) :: trigs(:)
    integer, intent(in)  :: n, mode

    real    :: del, angle
    integer :: imode, nn, nh, i, L, la

      imode=iabs(mode)
      nn=n
      if (imode.gt.1.and.imode.lt.6) nn=n/2
      del=(pi+pi)/real(nn)
      L=nn+nn
      do i=1,L,2
        angle=0.5*real(i-1)*del
        trigs(i)=cos(angle)
        trigs(i+1)=sin(angle)
      enddo
      if (imode.eq.1) return
      if (imode.eq.8) return

      del=0.5*del
      nh=(nn+1)/2
      L=nh+nh
      la=nn+nn
      do i=1,L,2
        angle=0.5*real(i-1)*del
        trigs(la+i)=cos(angle)
        trigs(la+i+1)=sin(angle)
      enddo
      if (imode.le.3) return

      del=0.5*del
      la=la+nn
    if (mode.ne.5) then
      do i=2,nn
        angle=real(i-1)*del
        trigs(la+i)=2.0*sin(angle)
      enddo
      return
    endif

      del=0.5*del
      do i=2,n
        angle=real(i-1)*del
        trigs(la+i)=sin(angle)
      enddo

    end subroutine fftrig

!##########################################################################

    subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la)
    integer, intent(in)  :: inc1, inc2, inc3, inc4, lot, n, ifac, la
    real,    intent(in)  :: a(*),b(*),trigs(*)
    real,    intent(out) :: c(*),d(*)
!
!     subroutine "vpassm" - multiple version of "vpassa"
!     performs one pass through data
!     as part of multiple complex fft routine
!     a is first real input vector
!     b is first imaginary input vector
!     c is first real output vector
!     d is first imaginary output vector
!     trigs is precalculated table of sines " cosines
!     inc1 is addressing increment for a and b
!     inc2 is addressing increment for c and d
!     inc3 is addressing increment between a"s & b"s
!     inc4 is addressing increment between c"s & d"s
!     lot is the number of vectors
!     n is length of vectors
!     ifac is current factor of n
!     la is product of previous factors
!

    real :: sin36=0.587785252292473
    real :: cos36=0.809016994374947
    real :: sin72=0.951056516295154
    real :: cos72=0.309016994374947
    real :: sin60=0.866025403784437

    integer :: i, j, k, L, m, iink, jink, jump, ibase, jbase, igo, ijk, la1
    integer :: ia, ja, ib, jb, kb, ic, jc, kc, id, jd, kd, ie, je, ke
    real    :: c1, s1, c2, s2, c3, s3, c4, s4

      m=n/ifac
      iink=m*inc1
      jink=la*inc2
      jump=(ifac-1)*jink
      ibase=0
      jbase=0
      igo=ifac-1
      if (igo.gt.4) return
!del  go to (10,50,90,130),igo

  select case (igo)

!   coding for factor 2

    case (1)
   10 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      do 20 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 15 ijk=1,lot
      c(ja+j)=a(ia+i)+a(ib+i)
      d(ja+j)=b(ia+i)+b(ib+i)
      c(jb+j)=a(ia+i)-a(ib+i)
      d(jb+j)=b(ia+i)-b(ib+i)
      i=i+inc3
      j=j+inc4
   15 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   20 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 40 k=la1,m,la
      kb=k+k-2
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      do 30 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 25 ijk=1,lot
      c(ja+j)=a(ia+i)+a(ib+i)
      d(ja+j)=b(ia+i)+b(ib+i)
      c(jb+j)=c1*(a(ia+i)-a(ib+i))-s1*(b(ia+i)-b(ib+i))
      d(jb+j)=s1*(a(ia+i)-a(ib+i))+c1*(b(ia+i)-b(ib+i))
      i=i+inc3
      j=j+inc4
   25 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   30 continue
      jbase=jbase+jump
   40 continue
!     return

!   coding for factor 3

    case (2)
   50 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      do 60 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 55 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
      c(jb+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))
      c(jc+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))
      d(jb+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))
      d(jc+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))
      i=i+inc3
      j=j+inc4
   55 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   60 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 80 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      do 70 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 65 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
      c(jb+j)=                                                           &
          c1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))) &
         -s1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
      d(jb+j)=                                                           &
          s1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))) &
         +c1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
      c(jc+j)=                                                           &
          c2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))) &
         -s2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
      d(jc+j)=                                                           &
          s2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))) &
         +c2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
      i=i+inc3
      j=j+inc4
   65 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   70 continue
      jbase=jbase+jump
   80 continue
!     return

!   coding for factor 4

    case (3)
   90 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      id=ic+iink
      jd=jc+jink
      do 100 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 95 ijk=1,lot
      c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
      c(jc+j)=(a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))
      d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
      d(jc+j)=(b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))
      c(jb+j)=(a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))
      c(jd+j)=(a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))
      d(jb+j)=(b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))
      d(jd+j)=(b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))
      i=i+inc3
      j=j+inc4
   95 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  100 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 120 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      kd=kc+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      c3=trigs(kd+1)
      s3=trigs(kd+2)
      do 110 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 105 ijk=1,lot
      c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
      d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
      c(jc+j)=                                     &
          c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) &
         -s2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
      d(jc+j)=                                     &
          s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) &
         +c2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
      c(jb+j)=                                     &
          c1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))) &
         -s1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
      d(jb+j)=                                     &
          s1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))) &
         +c1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
      c(jd+j)=                                     &
          c3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))) &
         -s3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
      d(jd+j)=                                     &
          s3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))) &
         +c3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
      i=i+inc3
      j=j+inc4
  105 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  110 continue
      jbase=jbase+jump
  120 continue
!     return

!   coding for factor 5

    case (4)
  130 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      id=ic+iink
      jd=jc+jink
      ie=id+iink
      je=jd+jink
      do 140 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 135 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
      c(jb+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
        -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
      c(je+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
        +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
      d(jb+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
        +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
      d(je+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
        -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
      c(jc+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
        -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
      c(jd+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
        +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
      d(jc+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
        +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
      d(jd+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
        -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
      i=i+inc3
      j=j+inc4
  135 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  140 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 160 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      kd=kc+kb
      ke=kd+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      c3=trigs(kd+1)
      s3=trigs(kd+2)
      c4=trigs(ke+1)
      s4=trigs(ke+2)
      do 150 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 145 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
      c(jb+j)=                                                          &
          c1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         -s1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      d(jb+j)=                                                          &
          s1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         +c1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      c(je+j)=                                                          &
          c4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         -s4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      d(je+j)=                                                          &
          s4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         +c4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      c(jc+j)=                                                          &
          c2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         -s2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      d(jc+j)=                                                          &
          s2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         +c2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      c(jd+j)=                                                          &
          c3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         -s3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      d(jd+j)=                                                          &
          s3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         +c3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      i=i+inc3
      j=j+inc4
  145 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  150 continue
      jbase=jbase+jump
  160 continue

  end select

    end subroutine vpassm

!##########################################################################

end module fft99_mod



module field_manager_mod
!
! <CONTACT EMAIL="William.Cooke@noaa.gov"> William Cooke
! </CONTACT>
! 
! <REVIEWER EMAIL="Richard.Slater@noaa.gov"> Richard D. Slater
! </REVIEWER>
!
! <REVIEWER EMAIL="Matthew.Harrison@noaa.gov"> Matthew Harrison
! </REVIEWER>
!
! <REVIEWER EMAIL="John.Dunne@noaa.gov"> John P. Dunne
! </REVIEWER>
!
! <HISTORY
!  SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/field_manager/field_manager.F90"/>

! <OVERVIEW>

! The field manager reads entries from a field table and stores this
! information along with the type  of field it belongs to. This allows
! the component models to query the field manager to see if  non-default
! methods of operation are desired. In essence the field table is a
! powerful type of namelist. Default values can be provided for all the
! fields through a namelist, individual fields can be modified  through
! the field table however.

!</OVERVIEW>

! <DESCRIPTION>
!
! An example of field table entries could be
! <PRE>
!"tracer","atmos_mod","sphum"/
!
!"tracer","atmos_mod","sf6"
!"longname","sulf_hex"
!"advection_scheme_horiz","2nd_order"
!"Profile_type","Fixed","surface_value = 0.0E+00"/
!
!"prog_tracers","ocean_mod","age_global"
!horizontal-advection-scheme = mdfl_sweby
!vertical-advection-scheme = mdfl_sweby
!restart_file = ocean_age.res.nc
! </PRE>
! 
! The field table consists of entries in the following format.
!
! The first line of an entry should consist of three quoted strings.
!
! The first quoted string will tell the field manager what type of 
! field it is.
! 
! The second quoted string will tell the field manager which model the 
! field is being applied to.
! The supported types at present are
!<PRE>
!      "coupler_mod" for the coupler,
!      "atmos_mod" for the atmosphere model,
!      "ocean_mod" for the ocean model,
!      "land_mod" for the land model, and,
!      "ice_mod" for the ice model.
!</PRE>
! The third quoted string should be a unique name that can be used as a
! query.
!
! The second and following lines of each entry are called methods in
! this context. Methods can be developed within any module and these
! modules can query the field manager to find any methods that are
! supplied in the field table.
!
! These lines can be coded quite flexibly.
!
! The line can consist of two or three quoted strings or a simple unquoted 
! string.
!
! If the line consists two or three quoted strings, then the first string will 
! be an identifier that the querying module will ask for.
!
! The second string will be a name that the querying module can use to
! set up values for the module. 
!
! The third string, if present, can supply parameters to the calling module that can be
! parsed and used to further modify values.
!
! If the line consists of a simple unquoted string then quotes are not allowed 
! in any part of the line.
!
! An entry is ended with a backslash (/) as the final character in a
! row.
! 
! Comments can be inserted in the field table by having a # as the
! first character in the line.
! 
! In the example above we have three field entries. 
! 
! The first is a simple declaration of a tracer called "sphum". 
!
! The second is for a tracer called "sf6". In this case a field named
! "longname" will be given the value "sulf_hex". A field named 
! "advection_scheme_horiz" will be given the value "2nd_order". Finally a field
! name "Profile_type" will be given a child field called "Fixed", and that field
! will be given a field called "surface_value" with a real value of 0.0E+00.
!
! The third entry is an example of a oceanic age tracer. Note that the 
! method lines are formatted differently here. This is the flexibility mentioned 
! above.
! 
! With these formats, a number of restrictions are required. 
!
! The following formats are equally valid.
!<PRE>
!      "longname","sulf_hex"
!      "longname = sulf_hex"
!      longname = sulf_hex
!</PRE>
! However the following is not valid.
!<PRE>
!      longname = "sulf_hex"
!</PRE>
!
! In the SF6 example above the last line of the entry could be written in the 
! following ways.
!<PRE>
!      "Profile_type","Fixed","surface_value = 0.0E+00"/
!      Profile_type/Fixed/surface_value = 0.0E+00/
!</PRE>
!
! Values supplied with fields are converted to the various types with the
! following assumptions.
!<PRE>
! Real values : These values contain a decimal point or are in exponential format.
!    These values only support e or E format for exponentials.
!    e.g. 10.0, 1e10 and 1E10 are considered to be real numbers.
!
! Integer values : These values only contain numbers. 
!    e.g 10 is an integer. 10.0 and 1e10 are not.
!
! Logical values : These values are supplied as one of the following formats.
!    T, .T., TRUE, .TRUE.
!    t, .t., true, .true.
!    F, .F., FALSE, .FALSE.
!    f, .f., false, .false.
!    These will be converted to T or F in a dump of the field.
!
! Character strings : These values are assumed to be strings if a character 
!    other than an e (or E) is in the value. Numbers can be suppled in the value.
!    If the value does not meet the criteria for a real, integer or logical type,
!    it is assumed to be a character type.
!</PRE>
! The entries within the field table can be designed by the individual
! authors of code to allow modification of their routines.
!
! </DESCRIPTION>

use    mpp_mod, only : mpp_error,   &
                       FATAL,       &
                       NOTE,        &
                       WARNING,     &
                       mpp_pe,      &
                       mpp_root_pe, &
                       stdlog,      &
                       stdout
use mpp_io_mod, only : mpp_io_init, &
                       mpp_open,    &
                       mpp_close,   &
                       MPP_ASCII,   &
                       MPP_RDONLY
use    fms_mod, only : lowercase,   &
                       file_exist,  &
                       write_version_number

implicit none
private


character(len=128) :: version = '$Id: field_manager.F90,v 17.0 2009/07/21 03:19:13 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized  = .false.

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Public routines
!        Interface definitions (optional arguments are in [brackets]):
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
public :: field_manager_init   ! (nfields, [table_name]) returns number of fields
public :: field_manager_end    ! ()
public :: find_field_index     ! (model, field_name) or (list_path)
public :: find_field_index_old ! (model, field_name) returns index of field_name in 
public :: find_field_index_new ! (list_path) returns index of field_name in 
                               ! component model model
public :: get_field_info       ! (n,fld_type,fld_name,model,num_methods)
                               ! Returns parameters relating to field n.
public :: get_field_method     ! (n, m, method) Returns the m-th method of field n
public :: get_field_methods    ! (n, methods) Returns the methods related to field n
public :: parse                ! (text, label, values) Overloaded function to parse integer,
                               ! real or character. Parse returns the number of values 
                               ! decoded (> 1 => an array of values)
public :: fm_change_list       ! (list) return success
public :: fm_change_root       ! (list) return success
public :: fm_dump_list         ! (list [, recursive]) return success
public :: fm_exists            ! (field) return success
public :: fm_get_index         ! (field) return index
public :: fm_get_current_list  ! () return path
public :: fm_get_length        ! (list) return length
public :: fm_get_type          ! (field) return string
public :: fm_get_value         ! (entry, value [, index]) return success !! generic
public :: fm_get_value_integer !   as above (overloaded function)
public :: fm_get_value_logical !   as above (overloaded function)
public :: fm_get_value_real    !   as above (overloaded function)
public :: fm_get_value_string  !   as above (overloaded function)
public :: fm_intersection      ! (lists, num_lists) return fm_array_list pointer
public :: fm_loop_over_list    ! (list, name, type, index) return success
public :: fm_new_list          ! (list [, create] [, keep]) return index
public :: fm_new_value         ! (entry, value [, create] [, index]) return index !! generic
public :: fm_new_value_integer !   as above (overloaded function)
public :: fm_new_value_logical !   as above (overloaded function)
public :: fm_new_value_real    !   as above (overloaded function)
public :: fm_new_value_string  !   as above (overloaded function)
public :: fm_reset_loop        ! ()
public :: fm_return_root       ! () return success
public :: fm_modify_name       ! (oldname, newname) return success
public :: fm_query_method      ! (name, method_name, method_control) return success and 
                               ! name and control strings
public :: fm_find_methods      ! (list, methods, control) return success and name and 
                               ! control strings.
public :: fm_copy_list         ! (list, suffix, [create]) return index
public :: fm_set_verbosity     ! ([verbosity])

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!   Private routines
!   Interface definitions (optional arguments are in [brackets]):
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

private :: create_field        ! (list_p, name) return field pointer
private :: dump_list           ! (list_p, recursive, depth) return success
private :: find_base           ! (field, path, base)
private :: find_field          ! (field, list_p) return field pointer
private :: find_head           ! (field, head, rest)
private :: find_list           ! (list, list_p, create) return field pointer
private :: get_field           ! (field, list_p) return field pointer
private :: initialize          ! ()
private :: make_list           ! (list_p, name) return field pointer

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Public parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer, parameter, public :: fm_field_name_len = 48
! <DATA NAME="fm_field_name_len" TYPE="integer, parameter" DEFAULT="48">
!   The length of a character string representing the field name.
! </DATA>
integer, parameter, public :: fm_path_name_len  = 512
! <DATA NAME="fm_path_name_len" TYPE="integer, parameter" DEFAULT="512">
!   The length of a character string representing the field path.
! </DATA>
integer, parameter, public :: fm_string_len     = 128
! <DATA NAME="fm_string_len" TYPE="integer, parameter" DEFAULT="128">
!   The length of a character string representing character values for the field.
! </DATA>
integer, parameter, public :: fm_type_name_len  = 8
! <DATA NAME="fm_type_name_len" TYPE="integer, parameter" DEFAULT="8">
!   The length of a character string representing the various types that the values of the field can take.
! </DATA>
integer, parameter, public :: NUM_MODELS        = 5
! <DATA NAME="NUM_MODELS" TYPE="integer, parameter" DEFAULT="5">
!   Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER).
! </DATA>
integer, parameter, public :: NO_FIELD          = -1
! <DATA NAME="NO_FIELD" TYPE="integer, parameter" DEFAULT="-1">
!   The value returned if a field is not defined.
! </DATA>! 
integer, parameter, public :: MODEL_ATMOS       = 1
! <DATA NAME="MODEL_ATMOS" TYPE="integer, parameter" DEFAULT="1">
!   Atmospheric model.
! </DATA>! 
integer, parameter, public :: MODEL_OCEAN       = 2
! <DATA NAME="MODEL_OCEAN" TYPE="integer, parameter" DEFAULT="2">
!   Ocean model.
! </DATA>
integer, parameter, public :: MODEL_LAND        = 3
! <DATA NAME="MODEL_LAND" TYPE="integer, parameter" DEFAULT="3">
!   Land model.
! </DATA>
integer, parameter, public :: MODEL_ICE         = 4
! <DATA NAME="MODEL_ICE" TYPE="integer, parameter" DEFAULT="4">
!   Ice model.
! </DATA>
integer, parameter, public :: MODEL_COUPLER     = 5
! <DATA NAME="MODEL_COUPLER" TYPE="integer, parameter" DEFAULT="5">
!   Ice model.
! </DATA>
character(len=11), parameter, public, dimension(NUM_MODELS) :: &
   MODEL_NAMES=(/'atmospheric','oceanic    ','land       ','ice        ','coupler    '/)
! <DATA NAME="MODEL_NAMES" TYPE="character(len=11), parameter">
!   Model names, e.g. MODEL_NAMES(MODEL_OCEAN) is 'oceanic'
! </DATA>

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Public type definitions
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

type, public :: fm_array_list_def  !{
  character (len=fm_field_name_len), dimension(:), pointer :: names => NULL()
  integer                                                  :: length
end type  fm_array_list_def  !}

!
! <TYPE NAME="method_type">
! <DESCRIPTION>

! This method_type is a way to allow a component module to alter the parameters it needs
! for various tracers. In essence this is a way to modify a namelist. A namelist can supply
! default parameters for all tracers. This  method will allow the user to modify these
! default parameters for an individual tracer. An example could be that  the user wishes to
! use second order advection on a tracer and also use fourth order advection on a second
! tracer  within the same model run. The default advection could be second order and the
! field table would then indicate  that the second tracer requires fourth order advection.
! This would be parsed by the advection routine.

!
! </DESCRIPTION>
type, public :: method_type

  ! <DATA NAME="method_type :: method_type" TYPE="character" DIM="(128)">
  !
  !   This string represents a tag that a module using this method can
  !   key on. Typically this should contain some reference to the module
  !   that is calling it.
  ! </DATA>
  !
  ! <DATA NAME="method_type :: method_name" TYPE="character" DIM="(128)">
  !   This is the name of a method which the module can parse and use
  !   to assign different default values to a field method.
  ! </DATA> 
  !
  ! <DATA NAME="method_type :: method_control" TYPE="character" DIM="(256)">
  !   This is the string containing parameters that the module can use
  !   as values  for a field method. These should override default
  !   values within the module.
  ! </DATA>
  character(len=fm_string_len) :: method_type
  character(len=fm_string_len) :: method_name
  character(len=fm_string_len) :: method_control
end type
! </TYPE> NAME="method_type"

! <TYPE NAME="method_type_short">
! <DESCRIPTION>
!   This method_type is the same as method_type except that the
!   method_control string is not present. This is used when you wish to
!   change to a scheme within a module but do not need to pass 
!   parameters.
! </DESCRIPTION>
type, public :: method_type_short
  ! <DATA NAME="method_type_short :: method_type" TYPE="character" DIM="(128)">
  !   see method_type :: method_type above.
  ! </DATA>
  !
  ! <DATA NAME="method_type_short :: method_name" TYPE="character" DIM="(128)">
  !   see method_type :: method_name above.
  ! </DATA> 
  character(len=fm_string_len) :: method_type
  character(len=fm_string_len) :: method_name
end type
! </TYPE> NAME="method_type_short"

! <TYPE NAME="method_type_very_short">
! <DESCRIPTION>
!   This method_type is the same as method_type except that the
!   method_control and method_name strings are not present. This is used
!   when you wish to change to a scheme within a module but do not need
!   to pass  parameters.
! </DESCRIPTION>
type, public :: method_type_very_short
  ! <DATA NAME="method_type_short :: method_type" TYPE="character" DIM="(128)">
  !   see method_type :: method_type above.
  ! </DATA>
  character(len=fm_string_len) :: method_type
end type
! </TYPE> NAME="method_type_very_short"


!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Public types
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

type(method_type), public :: default_method


!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Public variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Interface definitions for overloaded routines
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

interface find_field_index
  module procedure  find_field_index_old
  module procedure  find_field_index_new
end interface

interface parse
  module procedure  parse_real
  module procedure  parse_reals
  module procedure  parse_integer
  module procedure  parse_integers
  module procedure  parse_string
  module procedure  parse_strings
end interface

interface  fm_new_value  !{
  module procedure  fm_new_value_integer
  module procedure  fm_new_value_logical
  module procedure  fm_new_value_real
  module procedure  fm_new_value_string
end interface  !}

interface  fm_get_value  !{
  module procedure  fm_get_value_integer
  module procedure  fm_get_value_logical
  module procedure  fm_get_value_real
  module procedure  fm_get_value_string
end interface  !}

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Private parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=17), parameter :: module_name       = 'field_manager_mod'
character(len=1),  parameter :: bracket_left      = '['
character(len=1),  parameter :: bracket_right     = ']'
character(len=1),  parameter :: comma             = ","
character(len=1),  parameter :: comment           = '#'
character(len=1),  parameter :: dquote            = '"'
character(len=1),  parameter :: equal             = '='
character(len=1),  parameter :: list_sep          = '/'
character(len=1),  parameter :: space             = ' '
character(len=1),  parameter :: squote            = "'"
character(len=1),  parameter :: tab               = char(9) ! ASCII

integer,           parameter :: null_type         = 0
integer,           parameter :: integer_type      = 1
integer,           parameter :: list_type         = 2
integer,           parameter :: logical_type      = 3
integer,           parameter :: real_type         = 4
integer,           parameter :: string_type       = 5
integer,           parameter :: num_types         = 5
integer,           parameter :: line_len          = 256
integer,           parameter :: array_increment   = 10
integer,           parameter :: MAX_FIELDS        = 150
integer,           parameter :: MAX_FIELD_METHODS = 150


!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Private type definitions
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

type, private :: field_type !{
  character(len=fm_field_name_len)                    :: field_type
  character(len=fm_string_len)                    :: field_name
  integer                                             :: model, num_methods
  type(method_type)                                   :: methods(MAX_FIELD_METHODS)
end type field_type !}

type, private :: field_names_type !{
  character(len=fm_field_name_len)                    :: fld_type
  character(len=fm_field_name_len)                    :: mod_name
  character(len=fm_string_len)                    :: fld_name
end  type field_names_type !}

type, private :: field_names_type_short !{
  character(len=fm_field_name_len)                    :: fld_type
  character(len=fm_field_name_len)                    :: mod_name
end type field_names_type_short !}

type, private :: field_def  !{
  character (len=fm_field_name_len)                   :: name
  integer                                             :: index
  type (field_def), pointer                           :: parent => NULL()
  integer                                             :: field_type
  integer                                             :: length
  integer                                             :: array_dim
  integer                                             :: max_index
  type (field_def), pointer                           :: first_field => NULL()
  type (field_def), pointer                           :: last_field => NULL()
  integer, pointer, dimension(:)                      :: i_value => NULL()
  logical, pointer, dimension(:)                      :: l_value => NULL()
  real, pointer, dimension(:)                         :: r_value => NULL()
  character(len=fm_string_len), pointer, dimension(:) :: s_value => NULL()
  type (field_def), pointer                           :: next => NULL()
  type (field_def), pointer                           :: prev => NULL()
end type field_def  !}

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Private types
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

type(field_type), private :: fields(MAX_FIELDS)


!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        Private variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=fm_path_name_len)  :: loop_list
character(len=fm_type_name_len)  :: field_type_name(num_types)
character(len=fm_field_name_len) :: save_root_name
! The string set is the set of characters. 
character(len=52)                :: set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
! If a character in the string being parsed matches a character within
! the string set_nonexp then the string being parsed cannot be a number.
character(len=50)                :: set_nonexp = "ABCDFGHIJKLMNOPQRSTUVWXYZabcdfghijklmnopqrstuvwxyz"
! If a character in the string being parsed matches a character within
! the string setnum then the string may be a number.
character(len=13)                :: setnum     = "0123456789+-."
integer                          :: num_fields         = 0
integer                          :: verb               = 0
integer                          :: verb_level_warn    = 0
integer                          :: verb_level_note    = 0
integer                          :: default_verbosity  = 0
integer                          :: max_verbosity      = 1
type (field_def), pointer        :: loop_list_p        => NULL()
type (field_def), pointer        :: current_list_p     => NULL()
type (field_def), pointer        :: root_p             => NULL()
type (field_def), pointer        :: save_root_parent_p => NULL()
type (field_def), target, save   :: root 


contains

! <SUBROUTINE NAME="field_manager_init">
!   <OVERVIEW>
!     Routine to initialize the field manager.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine reads from a file containing formatted strings. 
!     These formatted strings contain information on which schemes are
!     needed within various modules. The field manager does not
!     initialize any of those schemes however. It simply holds the
!     information and is queried by the appropriate  module.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call field_manager_init(nfields, table_name)
!   </TEMPLATE>

subroutine field_manager_init(nfields, table_name)

! <OUT NAME="nfields" TYPE="integer">
!   The number of fields.
! </OUT>

integer,                      intent(out), optional :: nfields

! <IN NAME="table_name" TYPE="character, optional"
!     DIM="(len=128)" DEFAULT="field_table">
!   The name of the field table. The default name is field_table.
! </IN>

character(len=fm_string_len), intent(in), optional :: table_name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=18), parameter :: sub_name     = 'field_manager_init'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=1024)              :: record
character(len=fm_path_name_len)  :: control_str
character(len=fm_path_name_len)  :: list_name
character(len=fm_path_name_len)  :: method_name
character(len=fm_path_name_len)  :: name_str
character(len=fm_path_name_len)  :: type_str
character(len=fm_path_name_len)  :: val_name
character(len=fm_string_len)     :: tbl_name
integer                          :: control_array(MAX_FIELDS,3)
integer                          :: endcont
integer                          :: icount
integer                          :: index_list_name
integer                          :: iunit
integer                          :: l
integer                          :: log_unit
integer                          :: ltrec
integer                          :: m
integer                          :: midcont
integer                          :: model
integer                          :: startcont
logical                          :: flag_method
logical                          :: fm_success
type(field_names_type_short)     :: text_names_short
type(field_names_type)           :: text_names
type(method_type_short)          :: text_method_short
type(method_type)                :: text_method
type(method_type_very_short)     :: text_method_very_short



if (module_is_initialized) then
   if(present(nfields)) nfields = num_fields
   return
endif
num_fields = 0
call initialize

call mpp_io_init()

if (.not.PRESENT(table_name)) then
   tbl_name = 'field_table'
else
   tbl_name = trim(table_name)
endif

if (.not. file_exist(trim(tbl_name))) then
!   <ERROR MSG="No field table available, so no fields are being registered." STATUS="NOTE">
!      The field table does not exist.
!   </ERROR>
if (mpp_pe() == mpp_root_pe()) then
  if (verb .gt. verb_level_warn) then
    call mpp_error(NOTE, trim(warn_header)//                       &
         'No field table ('//trim(tbl_name)//') available, so no fields are being registered.')
  endif
endif
if(present(nfields)) nfields = 0
return
endif


call mpp_open(iunit,file=trim(tbl_name), form=MPP_ASCII, action=MPP_RDONLY)
!write_version_number should precede all writes to stdlog from field_manager
call write_version_number (version, tagname)
log_unit = stdlog()
do while (.TRUE.)
   read(iunit,'(a)',end=89,err=99) record
   write( log_unit,'(a)' )record
   if (record(1:1) == "#" ) cycle
   ltrec =  LEN_TRIM(record)
   if (ltrec .le. 0 ) cycle ! Blank line


         icount = 0
         do l= 1, ltrec
            if (record(l:l) == '"' ) then
               icount = icount + 1
            endif
         enddo
!     <ERROR MSG="Too many fields in field table header entry." STATUS="FATAL">
!       There are more that 3 fields in the field table header entry. 
!       The entry should look like <BR/>
!       "Field_Type","Model_Type","Field_Name" <BR/>
!        or<BR/>
!       "Field_Type","Model_Type"
!     </ERROR>
      if (icount > 6 ) then
        call mpp_error(FATAL,trim(error_header)//'Too many fields in field table header entry.'//trim(record))
      endif

         select case (icount)
           case (6)
             read(record,*,end=79,err=79) text_names
             text_names%fld_type = lowercase(trim(text_names%fld_type))
             text_names%mod_name = lowercase(trim(text_names%mod_name))
             text_names%fld_name = lowercase(trim(text_names%fld_name))
           case(4)
! If there is no control string then the last string can be omitted and there are only 4 '"' in the record.
             read(record,*,end=79,err=79) text_names_short
             text_names%fld_type = lowercase(trim(text_names_short%fld_type))
             text_names%mod_name = lowercase(trim(text_names_short%mod_name))
             text_names%fld_name = lowercase(trim(text_names_short%mod_name))
           case(2)
! If there is only the method_type string then the last 2 strings need to be blank and there are only 2 '"' in the record.
             read(record,*,end=79,err=79) text_names_short
             text_names%fld_type = lowercase(trim(text_names_short%fld_type))
             text_names%mod_name = lowercase(trim(text_names_short%mod_name))
             text_names%fld_name = lowercase(trim(text_names_short%mod_name))
           case default
!     <ERROR MSG="Unterminated field in field table header entry." STATUS="FATAL">
!       There is an unterminated or unquoted string in the field table entry.
             text_names%fld_type = " "
             text_names%mod_name = lowercase(trim(record))
             text_names%fld_name = " "
!             call mpp_error(FATAL,trim(error_header)//'Unterminated field in field_table header entry.'//trim(record))
!     </ERROR>
         end select    

! Create a list with Rick Slaters field manager code

   list_name = list_sep//trim(text_names%mod_name)//list_sep//trim(text_names%fld_type)//&
               list_sep//trim(text_names%fld_name)
   if (mpp_pe() == mpp_root_pe() ) then
     if (verb .gt. verb_level_note) then
!   <ERROR MSG="Creating list name = list_name." STATUS="NOTE">
!      A field is being created called list_name.
!   </ERROR>
       call mpp_error(NOTE, trim(note_header)//'Creating list name = '//trim(list_name))
     endif
   endif

   index_list_name = fm_new_list(list_name, create = .true.)
!   <ERROR MSG="Could not set field list for list_name." STATUS="FATAL">
!      A field called list_name could not be created.
!   </ERROR>
   if ( index_list_name == NO_FIELD ) &
     call mpp_error(FATAL, trim(error_header)//'Could not set field list for '//trim(list_name))

   fm_success = fm_change_list(list_name)  
   select case (text_names%mod_name)
   case ('coupler_mod')
      model = MODEL_COUPLER
   case ('atmos_mod')
      model = MODEL_ATMOS
   case ('ocean_mod')
      model = MODEL_OCEAN
   case ('land_mod')
      model = MODEL_LAND
   case ('ice_mod')
      model = MODEL_ICE
   case default
!   <ERROR MSG="The model name is unrecognised : model_name" STATUS="FATAL">
!      The model name being supplied in the field entry is unrecognised.
!      This should be the second string in the first line of the field entry.
!      Recognised names are atmos_mod, ice_mod, land_mod and ocean_mod.
!   </ERROR>
     call mpp_error(FATAL, trim(error_header)//'The model name is unrecognised : '//trim(text_names%mod_name))
   end select
   if (find_field_index(list_name) > 0) then
      num_fields = num_fields + 1


!     <ERROR MSG="max fields exceeded" STATUS="FATAL">
!       Maximum number of fields for this module has been exceeded.
!     </ERROR>
      if (num_fields > MAX_FIELDS) call mpp_error(FATAL,trim(error_header)//'max fields exceeded')
      fields(num_fields)%model       = model
      fields(num_fields)%field_name  = lowercase(trim(text_names%fld_name))
      fields(num_fields)%field_type  = lowercase(trim(text_names%fld_type))
      fields(num_fields)%num_methods = 0
      call check_for_name_duplication

! Check to see that the first line is not the only line
      if ( record(LEN_TRIM(record):LEN_TRIM(record)) == list_sep) cycle

      flag_method = .TRUE.
      m = 1
      do while (flag_method)
         read(iunit,'(a)',end=99,err=99) record
! If the line is blank then fetch the next line.
         if (LEN_TRIM(record) .le. 0) cycle
! If the last character in the line is / then this is the end of the field methods
         if ( record(LEN_TRIM(record):LEN_TRIM(record)) == list_sep) then
            flag_method = .FALSE.
            if (LEN_TRIM(record) == 1) cycle
            record = record(:LEN_TRIM(record)-1) ! Remove the end of field method marker
         endif
! If the line is now blank, after removing the field separator marker, then fetch the next line.
         if (LEN_TRIM(record) .le. 0) cycle
! If the first character in the line is # then it is treated as a comment
         if (record(1:1) == comment ) cycle

         icount = 0
         do l= 1, LEN_TRIM(record)
            if (record(l:l) == dquote ) then
               icount = icount + 1
            endif
         enddo     
!     <ERROR MSG="Too many fields in field entry." STATUS="FATAL">
!       There are more that 3 fields in the tracer entry. This is probably due
!       to separating the parameters entry into multiple strings. 
!       The entry should look like <BR/>       
!       "Type","Name","Control1=XXX,Control2=YYY" <BR/>
!        and not like<BR/>
!       "Type","Name","Control1=XXX","Control2=YYY"
!     </ERROR>
      if (icount > 6 ) call mpp_error(FATAL,trim(error_header)//'Too many fields in field entry.'//trim(record))

      if (.not. fm_change_list ( list_name)) &
         call mpp_error(FATAL, trim(error_header)//'Could not change to '//trim(list_name)//' list')

      select case (icount)
        case (6)
          read(record,*,end=99,err=99) text_method
          fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method%method_type))
          fields(num_fields)%methods(m)%method_name = lowercase(trim(text_method%method_name))
          fields(num_fields)%methods(m)%method_control = lowercase(trim(text_method%method_control))

          type_str    = text_method%method_type
          name_str    = text_method%method_name
          control_str = text_method%method_control

        case(4)
! If there is no control string then the last string can be omitted and there are only 4 '"' in the record.
          read(record,*,end=99,err=99) text_method_short
          fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method_short%method_type))
          fields(num_fields)%methods(m)%method_name = lowercase(trim(text_method_short%method_name))
          fields(num_fields)%methods(m)%method_control = " "

          type_str    = text_method_short%method_type
          name_str    = ""
          control_str = text_method_short%method_name

        case(2)
! If there is only the method_type string then the last 2 strings need to be blank and there are only 2 '"' in the record.
          read(record,*,end=99,err=99) text_method_very_short
          fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method_very_short%method_type))
          fields(num_fields)%methods(m)%method_name = " "
          fields(num_fields)%methods(m)%method_control = " "

          type_str    = ""
          name_str    = ""
          control_str = text_method_very_short%method_type

        case(0)
          read(record,'(A)',end=99,err=99) control_str
          type_str = ""
          name_str = ""

        case default
!     <ERROR MSG="Unterminated field in field entry." STATUS="FATAL">
!       There is an unterminated or unquoted string in the field table entry.
          call mpp_error(FATAL,trim(error_header)//'Unterminated field in field entry.'//trim(record))
!     </ERROR>
      end select

! This section of code breaks the control string into separate strings. 
! The array control_array contains the following parameters.
! control_array(:,1) = index within control_str of the first character of the name.
! control_array(:,2) = index within control_str of the equal sign
! control_array(:,3) = index within control_str of the last character of the value.
! 
! control_array(:,1)   -> control_array(:,2) -1 = name of the parameter.
! control_array(:,2)+1 -> control_array(:,3)    = value of the parameter.

      ltrec= len_trim(control_str)
      control_array(:,1) = 1
      control_array(:,2:3) = ltrec
      icount = 0
      do l= 1, ltrec
         if (control_str(l:l) == equal ) then
            icount = icount + 1
            control_array(icount,2) = l ! Middle of string
         elseif (control_str(l:l) == comma ) then
            if (icount .eq. 0) then

!     <ERROR MSG="Unterminated field in field entry." STATUS="FATAL">
!       Bad format for field entry (comma without equals sign)
              call mpp_error(FATAL,trim(error_header) //                                &
                   ' Bad format for field entry (comma without equals sign): ''' //     &
                   trim(control_str) // '''')
!     </ERROR>

            elseif (icount .gt. MAX_FIELDS) then

!     <ERROR MSG="Unterminated field in field entry." STATUS="FATAL">
!       Too many fields in field entry
              call mpp_error(FATAL,trim(error_header) //        &
                   ' Too many fields in field entry: ''' //     &
                   trim(control_str) // '''')
!     </ERROR>

            else

              control_array(icount,3) = l-1   !End of previous string
              control_array(min(MAX_FIELDS,icount+1),1) = l+1 !Start of next string

            endif
         endif
      enddo     

      ! Make sure that we point to the end of the string (minus any trailing comma)
      ! for the last set of values. This fixes the case where the last set of values
      ! is a comma separated list

      if (control_str(ltrec:ltrec) .ne. comma) then
        control_array(max(1,icount),3) = ltrec
      endif


      if ( icount == 0 ) then
        method_name = type_str
        if (len_trim(method_name) > 0 ) then
          method_name = trim(method_name)//list_sep// trim(name_str)
        else
          method_name = trim(name_str)
        endif
        val_name = control_str
        
        call new_name(list_name, method_name, val_name )
      
      else
      
        do l = 1,icount
          startcont = control_array(l,1)
          midcont   = control_array(l,2)
          endcont   = control_array(l,3)
          
          method_name = trim(type_str)
          if (len_trim(method_name) > 0 ) then
            method_name = trim(method_name)//list_sep// trim(name_str)
          else
            method_name = trim(name_str)
          endif
          
          if (len_trim(method_name) > 0 ) then
            method_name = trim(method_name)//list_sep//&
                          trim(control_str(startcont:midcont-1))
          else
            method_name = trim(control_str(startcont:midcont-1))
          endif
          val_name =    trim(control_str(midcont+1:endcont))
        
          call new_name(list_name, method_name, val_name )
        enddo

      endif

      fields(num_fields)%num_methods = fields(num_fields)%num_methods + 1
!     <ERROR MSG="Maximum number of methods for field exceeded" STATUS="FATAL">
!       Maximum number of methods allowed for entries in the field table has been exceeded.
!     </ERROR>
      if (fields(num_fields)%num_methods > MAX_FIELD_METHODS) &
         call mpp_error(FATAL,trim(error_header)//'Maximum number of methods for field exceeded')
         m = m + 1
      enddo
   else

!     <ERROR MSG="Field with identical name and model name duplicate found, skipping" STATUS="NOTE">
!       The name of the field and the model name are identical. Skipping that field.
!     </ERROR>
      if (mpp_pe() == 0) then
         if (verb .gt. verb_level_warn) then
           call mpp_error(WARNING, trim(warn_header)//                              &
                'Field with identical name and model name duplicate found, skipping')
          endif
      endif
      flag_method = .TRUE.
      do while (flag_method)
         read(iunit,'(A)',end=99,err=99) record
         if ( record(LEN_TRIM(record):LEN_TRIM(record)) == list_sep) then
            flag_method = .FALSE.
         endif
      enddo
   endif
79 continue
enddo
         
89 continue
close(iunit)

if(present(nfields)) nfields = num_fields
if (verb .gt. verb_level_warn) &
  fm_success= fm_dump_list("/", .true.)
  
default_method%method_type = 'none'
default_method%method_name = 'none'
default_method%method_control = 'none'
return

99 continue

!     <ERROR MSG="error reading field table" STATUS="FATAL">
!       There is an error in reading the field table.
!     </ERROR>
call mpp_error(FATAL,trim(error_header)//' Error reading field table. Record = '//trim(record))

end subroutine field_manager_init
! </SUBROUTINE>

subroutine check_for_name_duplication
integer :: i

! Check that name is unique amoung fields of the same field_type and model.
do i=1,num_fields-1
  if ( fields(i)%field_type == fields(num_fields)%field_type .and. &
       fields(i)%model      == fields(num_fields)%model      .and. &
       fields(i)%field_name == fields(num_fields)%field_name ) then
    if (mpp_pe() .eq. mpp_root_pe()) then
      call mpp_error(WARNING,'Error in field_manager_mod. Duplicate field name: Field type='//trim(fields(i)%field_type)// &
         ',  Model='//trim(MODEL_NAMES(fields(i)%model))// &
         ',  Duplicated name='//trim(fields(i)%field_name))
    endif
  endif
enddo

end subroutine check_for_name_duplication

!#######################################################################
!#######################################################################

! <PRIVATE><SUBROUTINE NAME="new_name">
!   <OVERVIEW>
!     Subroutine to add new values to list parameters.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine uses input strings list_name, method_name
!     and val_name_in to add new values to the list. Given
!     list_name a new list item is created that is named
!     method_name and is given the value or values in
!     val_name_in. If there is more than 1 value in
!     val_name_in, these values should be  comma-separated.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call new_name ( list_name, method_name , val_name_in)
!   </TEMPLATE>
subroutine new_name ( list_name, method_name_in , val_name_in)
!   <IN NAME="list_name" TYPE="character(len=*)">
!     The name of the field that is of interest here.
!   </IN>
!   <IN NAME="method_name" TYPE="character(len=*)">
!     The name of the method that values are being supplied for.
!   </IN>
character(len=*), intent(in)    :: list_name
character(len=*), intent(in)    :: method_name_in
!   <INOUT NAME="val_name_in" TYPE="character(len=*)">
!     The value or values that will be parsed and used as the value when 
!     creating a new field or fields.
!   </INOUT>
character(len=*), intent(inout) :: val_name_in

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=8),  parameter :: sub_name     = 'new_name'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_string_len)   :: method_name
character(len=fm_string_len)   :: val_list
character(len=fm_string_len)   :: val_name
integer, dimension(MAX_FIELDS) :: end_val
integer, dimension(MAX_FIELDS) :: start_val
integer                        :: i
integer                        :: index_t
integer                        :: left_br
integer                        :: num_elem
integer                        :: out_unit
integer                        :: right_br
integer                        :: val_int
integer                        :: val_type
logical                        :: append_new
logical                        :: val_logic
real                           :: val_real
integer                        :: length

call strip_front_blanks(val_name_in)
method_name = trim (method_name_in)
call strip_front_blanks(method_name)

index_t  = 1
num_elem = 1
append_new = .false.
start_val(1) = 1
end_val(:) = len_trim(val_name_in)

! If the array of values being passed in is a comma delimited list then count 
! the number of elements.

do i = 1, len_trim(val_name_in)
  if ( val_name_in(i:i) == comma ) then
    end_val(num_elem) = i-1
    start_val(num_elem+1) = i+1
    num_elem = num_elem + 1
  endif
enddo

! Check to see if this is an array element of form array[x] = value
left_br  = scan(method_name,'[')
right_br = scan(method_name,']')
if ( num_elem .eq. 1 ) then 
!     <ERROR MSG="Left bracket present without right bracket in method_name" STATUS="FATAL">
!       When using an array element an unpaired bracket was found.
!     </ERROR>
  if ( left_br > 0 .and. right_br == 0 ) &
    call mpp_error(FATAL, trim(error_header)//"Left bracket present without right bracket in "//trim(method_name))
!     <ERROR MSG="Right bracket present without left bracket in method_name" STATUS="FATAL">
!       When using an array element an unpaired bracket was found.
!     </ERROR>
  if ( left_br== 0 .and. right_br > 0 ) &
    call mpp_error(FATAL, trim(error_header)//"Right bracket present without left bracket in "//trim(method_name))
  

  if ( left_br > 0 .and. right_br > 0 ) then 
!     <ERROR MSG="Using a non-numeric value for index in method_name" STATUS="FATAL">
!       An array assignment was requested but a non-numeric value was found. i.e. array[a] = 1
!     </ERROR>
    if ( scan( method_name(left_br+1:right_br -1), set ) > 0 ) &
       call mpp_error(FATAL, trim(error_header)//"Using a non-numeric value for index in "//trim(method_name))
    read(method_name(left_br+1:right_br -1), *) index_t
    method_name = method_name(:left_br -1)
  endif
else
! If there are multiple values then there cannot be a bracket in method_name.
!     <ERROR MSG="Using a comma delimited list with an indexed array element in method_name" STATUS="FATAL">
!       When supplying multiple values an index was found. i.e array[3] = 4,5,6 is invalid.
!     </ERROR>
  if ( left_br > 0 .or. right_br > 0 ) &
    call mpp_error(FATAL, &
      trim(error_header)//"Using a comma delimited list with an indexed array element in "//trim(method_name))

endif

do i = 1, num_elem

  if ( i .gt. 1 .or. index_t .eq. 0 ) then
    append_new = .true.
    index_t = 0 ! If append is true then index must be <= 0
  endif  
  val_type = string_type  ! Assume it is a string
  val_name = val_name_in(start_val(i):end_val(i))
  call strip_front_blanks(val_name)


!
!       if the string starts and ends with matching single quotes, then this is a string
!       if there are quotes which do not match, then this is an error
!

  length = len_trim(val_name)
  if (val_name(1:1) .eq. squote) then  !{

    if (val_name(length:length) .eq. squote) then
      val_name = val_name(2:length-1)
      val_type = string_type
    elseif (val_name(length:length) .eq. dquote) then
      call mpp_error(FATAL, trim(error_header) // ' Quotes do not match in ' // trim(val_name) //       &
           ' for ' // trim(method_name) // ' of ' // trim(list_name))
    else
      call mpp_error(FATAL, trim(error_header) // ' No trailing quote in ' // trim(val_name) //         &
           ' for ' // trim(method_name) // ' of ' // trim(list_name))
    endif

  elseif (val_name(1:1) .eq. dquote .or. val_name(length:length) .eq. dquote) then  !}{

    call mpp_error(FATAL, trim(error_header) // ' Double quotes not allowed in ' // trim(val_name) //   &
         ' for ' // trim(method_name) // ' of ' // trim(list_name))

  elseif (val_name(length:length) .eq. squote) then  !}{

    call mpp_error(FATAL, trim(error_header) // ' No leading quote in ' // trim(val_name) //            &
         ' for ' // trim(method_name) // ' of ' // trim(list_name))

  else  !}{
! If the string to be parsed is a real then all the characters must be numeric, 
! be a plus/minus, be a decimal point or, for exponentials, be e or E.

! If a string is an integer, then all the characters must be numeric.

  if ( scan(val_name(1:1), setnum ) > 0 ) then  

! If there is a letter in the name it may only be e or E

      if ( scan(val_name, set_nonexp ) > 0 ) then
        if (verb .gt. verb_level_warn) then
!     <ERROR MSG="First character of value is numerical but the value does not appear to be numerical." STATUS="WARNING">
!       The value may not be numerical. This is a warning as the user may wish to use a value of 2nd_order.
!     </ERROR>
          call mpp_error(WARNING, trim(warn_header)//                                  &
               'First character of value is numerical but the value does not appear to be numerical.')
          call mpp_error(WARNING, 'Name = '// trim(list_name)// list_sep//                &
               trim(method_name)// ' Value = '// trim(val_name))
        endif

      else
! It is real if there is a . in the name or the value appears exponential
        if ( scan(val_name, '.') > 0 .or. scan(val_name, 'e') > 0 .or. scan(val_name, 'E') > 0) then 
          read(val_name, *) val_real
          val_type = real_type
        else
          read(val_name, *) val_int
          val_type = integer_type
        endif   
      endif

    endif

! If val_name is t/T or f/F then this is a logical flag.
    if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3) then
       if ( val_name == 't' .or. val_name == 'T' .or. val_name == '.t.' .or. val_name == '.T.' ) then
         val_logic = .TRUE.
         val_type = logical_type
       endif
       if ( val_name == 'f' .or. val_name == 'F' .or. val_name == '.f.' .or. val_name == '.F.' ) then
         val_logic = .FALSE.
         val_type = logical_type
       endif
    endif
    if ( trim(lowercase(val_name)) == 'true' .or. trim(lowercase(val_name)) == '.true.' ) then
      val_logic = .TRUE.
      val_type = logical_type
    endif
    if ( trim(lowercase(val_name)) == 'false' .or. trim(lowercase(val_name)) == '.false.' ) then
      val_logic = .FALSE.
      val_type = logical_type
    endif
  endif  !}

  select case(val_type) 

    case (integer_type)
      if ( fm_new_value( method_name, val_int, create = .true., index = index_t, append = append_new ) < 0 ) &
        call mpp_error(FATAL, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
                              ' (I) for '//trim(list_name))

    case (logical_type)
      if ( fm_new_value( method_name, val_logic, create = .true., index = index_t, append = append_new) < 0 ) &
        call mpp_error(FATAL, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
                              ' (L) for '//trim(list_name))

    case (real_type)
      if ( fm_new_value( method_name, val_real, create = .true., index = index_t, append = append_new) < 0 ) &
        call mpp_error(FATAL, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
                              ' (R) for '//trim(list_name))

    case (string_type)
      if ( fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
        call mpp_error(FATAL, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
                              ' (S) for '//trim(list_name))
    case default
      call mpp_error(FATAL, trim(error_header)//'Could not find a valid type to set the '//trim(method_name)//&
                            ' for '//trim(list_name))
    
  end select

  if (mpp_pe() == mpp_root_pe() ) then
    if (verb .gt. verb_level_note) then
      out_unit = stdout()
      write (out_unit,*) trim(note_header), 'Creating new value = ', trim(method_name), ' ', trim(val_name)
    endif
  endif

enddo

end subroutine new_name 
!</SUBROUTINE>
!</PRIVATE>
!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="field_manager_end">
!   <OVERVIEW>
!     Destructor for field manager.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine writes to the logfile that the user is exiting field_manager and 
!     changes the initialized flag to false.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call field_manager_end
!   </TEMPLATE>
subroutine field_manager_end

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=17), parameter :: sub_name     = 'field_manager_end'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

integer :: unit 

call write_version_number (version, tagname)
if ( mpp_pe() == mpp_root_pe() ) then
   unit = stdlog()
   write (unit,'(/,(a))') trim(note_header), 'Exiting field_manager, have a nice day ...'
   unit = stdout()
   write (unit,'(/,(a))') trim(note_header), 'Exiting field_manager, have a nice day ...'
endif

module_is_initialized = .false.

end subroutine field_manager_end
! </SUBROUTINE>

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="strip_front_blanks">
!   <OVERVIEW>
!     A routine to strip whitespace from the start of character strings.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This subroutine removes spaces and tabs from the start of a character string.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call strip_front_blanks(name)
!   </TEMPLATE>
subroutine strip_front_blanks(name)

character(len=*), intent(inout) :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=18), parameter :: sub_name     = 'strip_front_blanks'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

integer :: i, j

j = 1
do i = 1,len_trim(name) !{
   if ( .not. (name(i:i) .eq. space .or.                        &
               name(i:i) .eq. tab)) then  !{
    j = i
    exit
  endif !}
enddo !}
name = name(j:)
end subroutine strip_front_blanks
!</SUBROUTINE>

!#######################################################################
!#######################################################################

! <FUNCTION NAME="find_field_index">
!   <OVERVIEW>
!     Function to return the index of the field.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This function when passed a model number and a field name will 
!     return the index of the field within the field manager. This index 
!     can be used to access other information from the field manager.
!   </DESCRIPTION>
!   <TEMPLATE>
!     value=find_field_index( model, field_name )
!     value=find_field_index( field_name )
!   </TEMPLATE>

function find_field_index_old(model, field_name)
! 
!   <IN NAME="model" TYPE="integer">
!     The number indicating which model is used.
!   </IN>
!   <IN NAME="field_name" TYPE="character">
!     The name of the field that an index is being requested for.
!   </IN>
!   <OUT NAME="find_field_index" TYPE="integer">
!     The index of the field corresponding to field_name.
!   </OUT>

integer                      :: find_field_index_old
integer,          intent(in) :: model
character(len=*), intent(in) :: field_name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=16), parameter :: sub_name     = 'find_field_index'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
integer :: i

find_field_index_old = NO_FIELD

do i=1,num_fields
   if (fields(i)%model == model .and. fields(i)%field_name == lowercase(field_name)) then
      find_field_index_old = i
      return
   endif
enddo

end function find_field_index_old

function find_field_index_new(field_name)
! 
!   <IN NAME="field_name" TYPE="character">
!     The path to the name of the field that an index is being requested for.
!   </IN>
!   <OUT NAME="find_field_index" TYPE="integer">
!     The index of the field corresponding to field_name.
!   </OUT>

integer                      :: find_field_index_new
character(len=*), intent(in) :: field_name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=16), parameter :: sub_name     = 'find_field_index'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
integer :: i

find_field_index_new = NO_FIELD

find_field_index_new = fm_get_index(field_name)

end function find_field_index_new
! </FUNCTION>

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="get_field_info">
!   <OVERVIEW>
!     This routine allows access to field information given an index.
!   </OVERVIEW>
!   <DESCRIPTION>
!     When passed an index, this routine will return the type of field, 
!     the name of the field, the model which the field is associated and 
!     the number of methods associated with the field.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_field_info( n,fld_type,fld_name,model,num_methods )
!   </TEMPLATE>
subroutine get_field_info(n,fld_type,fld_name,model,num_methods)
!
!   <IN NAME="n" TYPE="integer">
!     The field index.
!   </IN>
integer,          intent(in)  :: n

!   <OUT NAME="fld_type" TYPE="character" DIM="(*)">
!     The field type.
!   </OUT>

!   <OUT NAME="fld_name" TYPE="character" DIM="(*)">
!     The name of the field.
!   </OUT>

!   <OUT NAME="model" TYPE="integer">
!     The number indicating which model is used.
!   </OUT>

!   <OUT NAME="num_methods" TYPE="integer">
!     The number of methods.
!   </OUT>
character (len=*),intent(out) :: fld_type, fld_name
integer, intent(out) :: model, num_methods

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=14), parameter :: sub_name     = 'get_field_info'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

!   <ERROR MSG="invalid field index" STATUS="FATAL">
!     The field index is invalid because it is less than 1 or greater than the 
!     number of fields.
!   </ERROR>
if (n < 1 .or. n > num_fields) call mpp_error(FATAL,trim(error_header)//'Invalid field index')

fld_type    = fields(n)%field_type
fld_name    = fields(n)%field_name
model       = fields(n)%model
num_methods = fields(n)%num_methods

end subroutine get_field_info
! </SUBROUTINE>

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="get_field_method">
!   <OVERVIEW>
!     A routine to get a specified method.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine, when passed a field index and a method index will 
!     return the method text associated with the field(n) method(m).
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_field_method( n,m,method )
!   </TEMPLATE>
subroutine get_field_method(n,m,method)
!
!   <IN NAME="n" TYPE="integer">
!     The field index.
!   </IN>
!   <IN NAME="m" TYPE="integer">
!     The method index.
!   </IN>
!   <OUT NAME="method" TYPE="type(method_type)">
!     The m-th method of field with index n.
!   </OUT>
integer,           intent(in)    :: n
integer,           intent(in)    :: m
type(method_type) ,intent(inout) :: method

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=16), parameter :: sub_name     = 'get_field_method'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

!   <ERROR MSG="invalid field index" STATUS="FATAL">
!     The field index is invalid because it is less than 1 or greater than the 
!     number of fields.
!   </ERROR>
if (n < 1 .or. n > num_fields) call mpp_error(FATAL,trim(error_header)//'Invalid field index')

!   <ERROR MSG="invalid method index" STATUS="FATAL">
!     The method index is invalid because it is less than 1 or greater than 
!     the number of methods.
!   </ERROR>
if (m < 1 .or. m > fields(n)%num_methods) call mpp_error(FATAL,trim(error_header)//'Invalid method index')

  method = fields(n)%methods(m)

end subroutine get_field_method
! </SUBROUTINE>

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="get_field_methods">
!   <OVERVIEW>
!     A routine to obtain all the methods associated with a field.
!   </OVERVIEW>
!   <DESCRIPTION>
!     When passed a field index, this routine will return the text 
!     associated with all the methods attached to the field.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_field_methods( n,methods )
!   </TEMPLATE>
subroutine get_field_methods(n,methods)
!
!   <IN NAME="n" TYPE="integer">
!     The field index.
!   </IN>
!   <OUT NAME="method" TYPE="type(method_type)" DIM="(:)">
!     An array of methods for field with index n.
!   </OUT>
integer,          intent(in)  :: n

type(method_type),intent(inout) :: methods(:)

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=17), parameter :: sub_name     = 'get_field_methods'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len), dimension(size(methods(:))) :: control
character(len=fm_path_name_len), dimension(size(methods(:))) :: method
logical                                                   :: found_methods
!   <ERROR MSG="invalid field index" STATUS="FATAL">
!     The field index is invalid because it is less than 1 or greater than the 
!     number of fields.
!   </ERROR>
  if (n < 1 .or. n > num_fields) &
    call mpp_error(FATAL,trim(error_header)//'Invalid field index')

!   <ERROR MSG="method array too small" STATUS="FATAL">
!     The method array is smaller than the number of methods.
!   </ERROR>
  if (size(methods(:)) <  fields(n)%num_methods) &
    call mpp_error(FATAL,trim(error_header)//'Method array too small')

  methods = default_method
  methods(1:fields(n)%num_methods) = fields(n)%methods(1:fields(n)%num_methods)

end subroutine get_field_methods
! </SUBROUTINE>

!#######################################################################
!#######################################################################
  
! <FUNCTION NAME="parse">
!   <OVERVIEW>
!     A function to parse an integer or an array of integers, 
!     a real or an array of reals, a string or an array of strings.
!   </OVERVIEW>
!   <DESCRIPTION>
!  Parse is an integer function that decodes values from a text string.
!  The text string has the form: "label=list" where "label" is an
!  arbitrary user defined label describing the values being decoded,
!  and "list" is a list of one or more values separated by commas.
!  The values may be integer, real, or character.
!  Parse returns the number of values decoded.
!   </DESCRIPTION>
!   <TEMPLATE>
!     number = parse(text, label, value)
!   </TEMPLATE>


function parse_reals ( text, label, values ) result (parse)
!
!   <IN NAME="text" TYPE="character(len=*)">
!     The text string from which the values will be parsed.
!   </IN>
!   <IN NAME="label" TYPE="character(len=*)">
!     A label which describes the values being decoded. 
!   </IN>
!   <OUT NAME="value" TYPE="integer, real, character(len=*)">
!     The value or values that have been decoded.
!   </OUT>
!   <OUT NAME="parse" TYPE="integer">
!     The number of values that have been decoded. This allows 
!     a user to define a large array and fill it partially with 
!     values from a list. This should be the size of the value array.
!   </OUT>
character(len=*), intent(in)  :: text, label
real,             intent(out) :: values(:)

include 'parse.inc'
end function parse_reals
! </FUNCTION>

!#######################################################################
!#######################################################################

function parse_integers ( text, label, values ) result (parse)
character(len=*), intent(in)  :: text, label
integer,          intent(out) :: values(:)

include 'parse.inc'
end function parse_integers

!#######################################################################
!#######################################################################

function parse_strings ( text, label, values ) result (parse)
character(len=*), intent(in)  :: text, label
character(len=*), intent(out) :: values(:)

include 'parse.inc'
end function parse_strings

!#######################################################################
!#######################################################################

!---- scalar overloads -----

function parse_real ( text, label, value ) result (parse)
character(len=*), intent(in)  :: text, label
real,             intent(out) :: value
integer :: parse

real :: values(1)

   parse = parse_reals ( text, label, values )
   if (parse > 0) value = values(1)
end function parse_real

!#######################################################################
!#######################################################################

function parse_integer ( text, label, value ) result (parse)
character(len=*), intent(in)  :: text, label
integer,          intent(out) :: value
integer :: parse

integer :: values(1)

   parse = parse_integers ( text, label, values )
   if (parse > 0) value = values(1)
end function parse_integer

!#######################################################################
!#######################################################################

function parse_string ( text, label, value ) result (parse)
character(len=*), intent(in)  :: text, label
character(len=*), intent(out) :: value
integer :: parse

character(len=len(value)) :: values(1)

   parse = parse_strings ( text, label, values )
   if (parse > 0) value = values(1)
end function parse_string

!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="create_field">
!
! <OVERVIEW>
!    A function to create a field as a child of parent_p. This will return
!    a pointer to a field_def type.
! </OVERVIEW>
! <DESCRIPTION>
!    Allocate and initialize a new field in parent_p list.
!    Return a pointer to the field on success, or a null pointer
!    on failure.
! </DESCRIPTION>
!   <TEMPLATE>
!     list_p => create_field(parent_p, name)
!   </TEMPLATE>
!
!
function  create_field(parent_p, name)                        &
          result (list_p)  !{
!
!   <IN NAME="parent_p" TYPE="type(field_def), pointer">
!     A pointer to the parent of the field that is to be created.
!   </IN>
!   <IN NAME="name" TYPE="character">
!     The name of the field that is to be created.
!   </IN>
!   <OUT NAME="list_p" TYPE="type(field_def), pointer">
!     A pointer to the field that has been created.
!   </OUT>
!
!        Function definition
!
type (field_def), pointer    :: list_p
!
!        arguments
!
type (field_def), pointer    :: parent_p
character(len=*), intent(in) :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=12), parameter :: sub_name     = 'create_field'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
integer                      :: ier
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                      :: error, out_unit
!
!        Check for fatal errors which should never arise
!
out_unit = stdout()
if (.not. associated(parent_p)) then  !{

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Unnassociated pointer'  &
                   , ' for ', trim(name)
  endif  !}
  nullify(list_p)
  return
endif  !}

if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Empty name for '        &
                   , trim(name)
  endif  !}
  nullify(list_p)
  return
endif  !}
!
!        Allocate space for the new list
!
allocate(list_p, stat = error)
if (error .ne. 0) then !{
  write (out_unit,*) trim(error_header), 'Error ', error,       &
       ' allocating memory for list ', trim(name)
  nullify(list_p)
  return
endif  !}
!
!        Initialize the new field
!
list_p%name = name

nullify(list_p%next)
list_p%prev => parent_p%last_field
nullify(list_p%first_field)
nullify(list_p%last_field)
list_p%length = 0
list_p%field_type = null_type
list_p%max_index = 0
list_p%array_dim = 0
if (associated(list_p%i_value)) deallocate(list_p%i_value)
if (associated(list_p%l_value)) deallocate(list_p%l_value)
if (associated(list_p%r_value)) deallocate(list_p%r_value)
if (associated(list_p%s_value)) deallocate(list_p%s_value)
!
!        If this is the first field in the parent, then set the pointer
!        to it, otherwise, update the "next" pointer for the last list
!
if (parent_p%length .le. 0) then  !{
  parent_p%first_field => list_p
else  !}{
  parent_p%last_field%next => list_p
endif  !}
!
!        Update the pointer for the last list in the parent
!
parent_p%last_field => list_p
!
!        Update the length for the parent
!
parent_p%length = parent_p%length + 1
!
!        Set the new index as the return value
!
list_p%index = parent_p%length
!
!        set the pointer to the parent list
!
list_p%parent => parent_p

end function  create_field  !}
! </FUNCTION> NAME="create_field"
!</PRIVATE>
!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="dump_list">
!
! <OVERVIEW>
!    This is a function that lists the parameters of a field.
! </OVERVIEW>
! <DESCRIPTION>
!    Given a pointer to a list, this function prints out the fields, and 
!    subfields, if recursive is true, associated with the list.
!
!    This is most likely to be used through fm_dump_list.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = dump_list(list_p, recursive= .true., depth=0)
!   </TEMPLATE>
!
recursive function dump_list(list_p, recursive, depth)                &
          result (success)  !{
!
!   <IN NAME="list_p" TYPE="type(field_def), pointer">
!     A pointer to the field, the contents of which will be printed out.
!   </IN>
!   <IN NAME="recursive" TYPE="logical">
!     A flag to make the function recursively print all the sub-fields 
!     of the field pointed to by list_p.
!   </IN>
!   <IN NAME="depth" TYPE="integer">
!     The listing will be padded so that 'depth' spaces appear before 
!     the field being printed.
!   </IN>
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!
!        Function definition
!
logical                             :: success
!
!        arguments
!
type (field_def), pointer           :: list_p
logical, intent(in)                 :: recursive
integer, intent(in)                 :: depth

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer,                  parameter :: max_depth    = 128
character(len=max_depth), parameter :: blank        = '    '
character(len=9),  parameter :: sub_name     = 'dump_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                             :: depthp1
integer                             :: first
integer                             :: i
integer                             :: j
integer                             :: last
integer                             :: nf
integer                             :: nl
integer                             :: out_unit
character(len=fm_field_name_len)    :: num
character(len=fm_field_name_len)    :: scratch
type (field_def), pointer           :: this_field_p
!
!        Check for a valid list
!

out_unit = stdout()
this_field_p => NULL()

if (.not. associated(list_p)) then  !{

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Invalid list pointer'
  endif  !}
  success = .false.
elseif (list_p%field_type .ne. list_type) then  !}{

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),               &
                       trim(list_p%name), ' is not a list'
  endif  !}
  success = .false.
else  !}{
!
!        set the default return value
!
  success = .true.
!
!        Print the name of this list
!
  write (out_unit,'(a,a,a)') blank(1:depth), trim(list_p%name), list_sep
!
!        Increment the indentation depth
!
  if (depth .eq. max_depth) then  !{
    if (verb .gt. verb_level_note) then  !{
      write (out_unit,*) trim(note_header),                        &
          'Indentation depth exceeded'
    endif  !}
  else  !}{
    ! The following max function is to work around an error in the IBM compiler for len_trim
    depthp1 = depth + max(len_trim(list_p%name),0) + len_trim(list_sep)
  endif  !}

  this_field_p => list_p%first_field

  do while (associated(this_field_p))  !{

    select case(this_field_p%field_type)
    case(list_type)
!
!        If this is a list, then call dump_list
!
      if (recursive) then  !{
! If recursive is true, then this routine will find and dump sub-fields.
        if (.not. dump_list(this_field_p, .true., depthp1)) then  !{
          success = .false.
          exit
        endif  !}
      else  !}{ ! Otherwise it will print out the name of this field.
        write (out_unit,'(a,a,a)') blank(1:depthp1),               &
                trim(this_field_p%name), list_sep
      endif  !}

    case(integer_type)

         if (this_field_p%max_index .eq. 0) then  !{
         ! Write out the solitary value for this field.
          write (out_unit,'(a,a,a)') blank(1:depthp1),             &
               trim(this_field_p%name), ' = NULL'
        elseif (this_field_p%max_index .eq. 1) then  !}{
          write (scratch,*) this_field_p%i_value(1)
          call strip_front_blanks(scratch)
          write (out_unit,'(a,a,a,a)') blank(1:depthp1),           &
                trim(this_field_p%name), ' = ', trim(scratch)

        else  !}{ Write out the array of values for this field.
          do j = 1, this_field_p%max_index - 1  !{
            write (scratch,*) this_field_p%i_value(j)
            call strip_front_blanks(scratch)
            write (num,*) j
            call strip_front_blanks(num)
            write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1),     &
                 trim(this_field_p%name), '[', trim(num),          &
                 '] = ', trim(scratch)
          enddo  !} j
          write (scratch,*) this_field_p%i_value(this_field_p%max_index)
          call strip_front_blanks(scratch)
          write (num,*) this_field_p%max_index
          call strip_front_blanks(num)
          write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1),       &
               trim(this_field_p%name), '[', trim(num),            &
               '] = ', trim(scratch)
        endif  !}



    case(logical_type)

        if (this_field_p%max_index .eq. 0) then  !{
         ! Write out the solitary value for this field.
          write (out_unit,'(a,a,a)') blank(1:depthp1),             &
               trim(this_field_p%name), ' = NULL'
        elseif (this_field_p%max_index .eq. 1) then  !}{
          write (out_unit,'(a,a,a,l1)') blank(1:depthp1),          &
               trim(this_field_p%name), ' = ',                     &
               this_field_p%l_value(1)
        else  !}{ Write out the array of values for this field.
          do j = 1, this_field_p%max_index - 1  !{
            write (num,*) j
            call strip_front_blanks(num)
            write (out_unit,'(a,a,a,a,a,l1)') blank(1:depthp1),    &
                 trim(this_field_p%name), '[', trim(num),          &
                 '] = ', this_field_p%l_value(j)
          enddo  !} j
          write (num,*) this_field_p%max_index
          call strip_front_blanks(num)

       write (out_unit,'(a,a,a,a,a,l1)') blank(1:depthp1),         &
               trim(this_field_p%name), '[', trim(num),            &
               '] = ', this_field_p%l_value(this_field_p%max_index)
        endif  !}


    case(real_type)

        if (this_field_p%max_index .eq. 0) then  !{
         ! Write out the solitary value for this field.
          write (out_unit,'(a,a,a)') blank(1:depthp1),             &
               trim(this_field_p%name), ' = NULL'
        elseif (this_field_p%max_index .eq. 1) then  !}{
          write (scratch,*) this_field_p%r_value(1)
          call strip_front_blanks(scratch)
          write (out_unit,'(a,a,a,a)') blank(1:depthp1),           &
                  trim(this_field_p%name), ' = ', trim(scratch)
        else  !}{ Write out the array of values for this field.
          do j = 1, this_field_p%max_index - 1  !{
            write (scratch,*) this_field_p%r_value(j)
            call strip_front_blanks(scratch)
            write (num,*) j
            call strip_front_blanks(num)
            write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1),     &
                 trim(this_field_p%name), '[', trim(num),          &
                 '] = ', trim(scratch)
          enddo  !} j
          write (scratch,*) this_field_p%r_value(this_field_p%max_index)
          call strip_front_blanks(scratch)
          write (num,*) this_field_p%max_index
          call strip_front_blanks(num)
          write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1),       &
               trim(this_field_p%name), '[', trim(num),            &
               '] = ', trim(scratch)
        endif  !}

    case(string_type)
        if (this_field_p%max_index .eq. 0) then  !{
         ! Write out the solitary value for this field.
          write (out_unit,'(a,a,a)') blank(1:depthp1),             &
               trim(this_field_p%name), ' = NULL'
        elseif (this_field_p%max_index .eq. 1) then  !}{
        write (out_unit,'(a,a,a,a,a)') blank(1:depthp1),           &
                trim(this_field_p%name), ' = ''',                  &
               trim(this_field_p%s_value(1)), ''''
        else  !}{ Write out the array of values for this field.
          do j = 1, this_field_p%max_index - 1  !{
            write (num,*) j
            call strip_front_blanks(num)
            write (out_unit,'(a,a,a,a,a,a,a)') blank(1:depthp1),   &
                 trim(this_field_p%name), '[', trim(num),          &
                 '] = ''', trim(this_field_p%s_value(j)), ''''
          enddo  !} j
          write (num,*) this_field_p%max_index
          call strip_front_blanks(num)
          write (out_unit,'(a,a,a,a,a,a,a)') blank(1:depthp1),     &
               trim(this_field_p%name), '[', trim(num),            &
               '] = ''',                                           &
               trim(this_field_p%s_value(this_field_p%max_index)), &
               ''''
        endif  !}

    case default

        if (verb .gt. verb_level_warn) then  !{
          write (out_unit,*) trim(warn_header),                    &
                  'Undefined type for ',                           &
                  trim(this_field_p%name)
        endif  !}
        success = .false.
        exit

    end select

    this_field_p => this_field_p%next
  enddo  !}
endif  !}

end function dump_list  !}
! </FUNCTION> NAME="dump_list"
!</PRIVATE>
!#######################################################################
!#######################################################################

! <PRIVATE><SUBROUTINE NAME="find_base">
!
! <OVERVIEW>
!    A subroutine that splits a listname into a path and a base.
! </OVERVIEW>
! <DESCRIPTION>
!    Find the base name for a list by splitting the list name into
!    a path and base. The base is the last field within name, while the
!    path is the preceding section of name. The base string can then be 
!    used to query for values associated with name.
! </DESCRIPTION>
!   <TEMPLATE>
!     call find_base(name, path, base)
!   </TEMPLATE>
!
subroutine find_base(name, path, base)  !{
!
!   <IN NAME="name" TYPE="character(len=*)">
!   </IN>
!   <OUT NAME="path" TYPE="character(len=*)">
!      A string containing the path of the base field.
!   </OUT>
!   <OUT NAME="base" TYPE="character(len=*)">
!      A string which can be used to query for values associated with name.
!   </OUT>
!
!        arguments
!
character(len=*), intent(in)  :: name
character(len=*), intent(out) :: path
character(len=*), intent(out) :: base

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=9),  parameter :: sub_name     = 'find_base'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

integer :: i
integer :: length

!
!        Check for the last occurrence of the list separator in name
!
! The following max function is to work around an error in the IBM compiler for len_trim
length = max(len_trim(name),0)

if (length .eq. 0) then  !{

   !
   !       Empty name, so return empty path and base
   !
   path = ' '
   base = ' '
else  !}{
   !
   !       Remove trailing list separators
   !
   do while (name(length:length) .eq. list_sep)  !{
      length = length - 1
      if (length .eq. 0) then  !{
         exit
      endif  !}
   enddo  !}
   if (length .eq. 0) then  !{

      !
      !       Name only list separators, so return empty path and base
      !
      path = ' '
      base = ' '
   else  !}{
      !
      !       Check for the last occurrence of the list separator in name
      !
      i = index(name(1:length), list_sep, back = .true.)
      if (i .eq. 0) then  !{
         !
         !       no list separators in the path, so return an empty path
         !       and name as the base
         !
         path = ' '
         base = name(1:length)
      else  !}{
         !
         !       Found a list separator, so return the part up to the last
         !       list separator in path, and the remainder in base
         !
         path = name(1:i)
         base = name(i+1:length)
      endif  !}
   endif  !}
endif  !}

end subroutine find_base  !}
! </SUBROUTINE> NAME="find_base"
!</PRIVATE>
!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="find_field">
!
! <OVERVIEW>
!    Find and return a pointer to the field in the specified
!    list. Return a null pointer on error.
! </OVERVIEW>
! <DESCRIPTION>
!    Find and return a pointer to the field in the specified
!    list. Return a null pointer on error. Given a pointer to a field, 
!    this function searchs for "name" as a sub field.
! </DESCRIPTION>
!   <TEMPLATE>
!     field_p => find_field(name, this_list_p)
!   </TEMPLATE>
!
function find_field(name, this_list_p)                                &
        result (field_p)  !{
!  <OUT NAME="field_p" TYPE="type(field_def), pointer">
!    A pointer to the field corresponding to "name" or an unassociated 
!    pointer if the field name does not exist.
!  </OUT>
!  <IN NAME="name" TYPE="character(len=*)">
!    The name of a field that the user wishes to find.
!  </IN>
!  <IN NAME="this_list_p" TYPE="type(field_def), pointer">
!    A pointer to a list which the user wishes to search for a field "name".
!  </IN>
!
!        Function definition
!
type (field_def), pointer    :: field_p
!
!        arguments
!
character(len=*), intent(in) :: name
type (field_def), pointer    :: this_list_p

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=10), parameter :: sub_name     = 'find_field'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save    :: temp_p 


nullify (field_p)

if (name .eq. '.') then  !{

!
!        If the field is '.' then return this list
!
  field_p => this_list_p
elseif (name .eq. '..') then  !}{
!
!        If the field is '..' then return the parent list
!
  field_p => this_list_p%parent
else  !}{
!
!        Loop over each field in this list
!
  temp_p => this_list_p%first_field

  do while (associated(temp_p))  !{
!
!        If the name matches, then set the return pointer and exit
!        the loop
!
    if (temp_p%name .eq. name) then  !{
      field_p => temp_p
      exit
    endif  !}

    temp_p => temp_p%next

  enddo  !}
endif  !}

end function find_field  !}
! </FUNCTION> NAME="find_field"
!</PRIVATE>

!#######################################################################
!#######################################################################

! <PRIVATE><SUBROUTINE NAME="find_head">
!
! <OVERVIEW>
!    Find the first list for a name by splitting the name into
!    a head and the rest.
! </OVERVIEW>
! <DESCRIPTION>
!   Find the first list for a name by splitting the name into a head and the
! rest. The head is the first field within name, while rest is the remaining
! section of name. The head string can then be used to find other fields that
! may be associated with name.
! </DESCRIPTION>
!   <TEMPLATE>
!     call find_head(name, head, rest)
!   </TEMPLATE>
!
subroutine find_head(name, head, rest)  !{
!
!   <IN NAME="name" TYPE="character(len=*)">
!      The name of a field of interest.
!   </IN>
!   <OUT NAME="head" TYPE="character(len=*)">
!      head is the first field within name.
!   </OUT>
!   <OUT NAME="rest" TYPE="character(len=*)">
!      rest is the remaining section of name.
!   </OUT>
!
!        arguments
!
character(len=*), intent(in)  :: name
character(len=*), intent(out) :: head
character(len=*), intent(out) :: rest

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=9),  parameter :: sub_name     = 'find_head'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer        :: i
!
!        Check for the first occurrence of the list separator in name
!
i = index(name, list_sep)
!
!        Check for additional consecutive list separators and return
!        those also
!
do while (i .le. len(name))  !{
  if (name(i+1:i+1) .eq. list_sep) then  !{
    i = i + 1
  else  !}{
    exit
  endif  !}
enddo  !}

if (i .eq. 0) then  !{
!
!        no list separators in the path, so return an empty head and
!        name as the rest
!
  head = ' '
  rest = name
elseif (i .eq. len(name)) then  !}{
!
!        The last character in name is a list separator, so return name
!        as head and an empty rest
!
  head = name
  rest = ' '
else  !}{
!
!        Found a list separator, so return the part up to the list
!        separator in head, and the remainder in rest
!
  head = name(1:i)
  rest = name(i+1:)
endif  !}

end subroutine find_head  !}
! </SUBROUTINE> NAME="find_head"
!</PRIVATE>

!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="find_list">
!
! <OVERVIEW>
!    Find and return a pointer to the specified list, relative to
!    relative_p. Return a null pointer on error.
! </OVERVIEW>
! <DESCRIPTION>
!    This function, when supplied a pointer to a field and a name of a second
!    field relative to that pointer, will find a list and return the pointer to 
!    the second field. If create is .true. and the second field does not exist,
!    it will be created.
! </DESCRIPTION>
!   <TEMPLATE>
!     list_p => find_list(path, relative_p, create)
!   </TEMPLATE>
!
function find_list(path, relative_p, create)                    &
        result (list_p)  !{
!
!   <OUT NAME="list_p" TYPE="type(field_def), pointer">
!     A pointer to the list to be returned.
!   </OUT>
!   <IN NAME="path" TYPE="character(len=*)">
!     A path to the list of interest.
!   </IN>
!   <IN NAME="list_p" TYPE="type(field_def), pointer">
!     A pointer to the list to which "path" is relative to.
!   </IN>
!   <IN NAME="create" TYPE="logical">
!     If the list does not exist, having create = .true. will create it.
!   </IN>
!
!        Function definition
!
type (field_def), pointer        :: list_p
!
!        arguments
!
character(len=*), intent(in)     :: path
type (field_def), pointer        :: relative_p
logical,          intent(in)     :: create

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=9),  parameter :: sub_name     = 'find_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len)  :: working_path
character(len=fm_path_name_len)  :: rest
character(len=fm_field_name_len) :: this_list
integer                          :: i, out_unit
type (field_def), pointer, save  :: working_path_p 
type (field_def), pointer, save  :: this_list_p 


out_unit = stdout()
nullify(list_p)
!
!        If the path is empty, then return the relative list
!
if (path .eq. ' ') then  !{

  list_p => relative_p

else  !}{
!
!        If a fully qualified path is given (i.e., starts with the
!        list separator) then do everything relative to root,
!        otherwise, do everything relative to relative list.
!
  if (path(1:1) .eq. list_sep) then  !{
    working_path_p => root_p
    working_path = path(2:)
  else  !}{
    working_path_p => relative_p
    working_path = path
  endif  !}
!
!        Loop over each field in the path
!
  do while (working_path .ne. ' ')  !{
!
!        Get the first list in the working path
!
    call find_head(working_path, this_list, rest)
!
!        If the first list is empty, then the 'rest' should hold the
!        final field in the path
!
    if (this_list .eq. ' ') then  !{
      this_list = rest
      rest = ' '
    endif  !}
!
!        Strip off trailing list separators
!
    i = len_trim(this_list)
    do while (i .gt. 0 .and. this_list(i:i) .eq. list_sep)  !{
      this_list(i:i) = ' '
      i = i - 1
    enddo  !}
!
!        Find a pointer to this field in the working list
!
    this_list_p => find_field(this_list, working_path_p)

    if (.not. associated(this_list_p)) then  !{
      if (create) then  !{
!
!        Create the list if so requested
!
        this_list_p => make_list(working_path_p, this_list)
        if (.not. associated(this_list_p)) then  !{
          if (verb .gt. verb_level_warn) then  !{
            write (out_unit,*) trim(warn_header), 'List "',       &
                 trim(this_list), '" could not be created in ',   &
                 trim(path)
          endif  !}
          nullify(list_p)
          return
        endif  !}
      else  !}{
!
!        Otherwise, return an error
!

        if (verb .gt. verb_level_note) then  !{
          write (out_unit,*) trim(note_header), 'List "',         &
               trim(this_list), '" does not exist in ', trim(path)
        endif  !}
        nullify(list_p)
        return
      endif  !}
    endif  !}
!
!        Make sure that the field found is a list, and if so, proceed to
!        the next field in the path, otherwise, return an error
!
    if (this_list_p%field_type .eq. list_type) then  !{
      working_path_p => this_list_p
      working_path = rest
    else  !}{
      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header), '"',                &
             trim(this_list), '" is not a list in ', trim(path)
      endif  !}
      nullify(list_p)
      return
    endif  !}
  enddo  !}
  list_p => working_path_p
endif  !}

end function find_list  !}
! </FUNCTION> NAME="find_list"
!</PRIVATE>

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_change_list">
!
! <OVERVIEW>
!    Change the current list. Return true on success,
!    false otherwise
! </OVERVIEW>
! <DESCRIPTION>
!    This function changes the currect list to correspond to the list named name.
!    If the first character of name is the list separator (/) then the list will 
!    search for "name" starting from the root of the field tree. Otherwise it 
!    will search for name starting from the current list.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_change_list(name)
!   </TEMPLATE>
!
function fm_change_list(name)                                        &
        result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list that the user wishes to change to.
!   </IN>
!
!        Function definition
!
logical        :: success
!
!        arguments
!
character(len=*), intent(in)  :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=14), parameter :: sub_name     = 'fm_change_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_p 
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Find the list if path is not empty
!
temp_p => find_list(name, current_list_p, .false.)

if (associated(temp_p)) then  !{
  current_list_p => temp_p
  success = .true.
else  !}{
  success = .false.
endif  !}

end function fm_change_list  !}
! </FUNCTION> NAME="fm_change_list"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_change_root">
!
! <OVERVIEW>
!    Change the root list
! </OVERVIEW>
! <DESCRIPTION>
!    This function changes the root of the field tree to correspond to the 
!    field named name. An example of a use of this would be if code is 
!    interested in a subset of fields with a common base. This common base 
!    could be set using fm_change_root and fields could be referenced using 
!    this root. 
!    
!    This function should be used in conjunction with fm_return_root.
!    
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_change_root(name)
!   </TEMPLATE>
!
function  fm_change_root(name)                                        &
          result (success)  !{
!
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of the field which the user wishes to become the root.
!   </IN>
!
!        Function definition
!
logical        :: success
!
!        arguments
!
character(len=*), intent(in)  :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=14), parameter :: sub_name     = 'fm_change_root'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_list_p 
integer :: out_unit
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
out_unit = stdout()
!
!        Must supply a field field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  success = .false.
  return
endif  !}
!
!        Get a pointer to the list
!
temp_list_p => find_list(name, current_list_p, .false.)

if (associated(temp_list_p)) then  !{
!
!        restore the saved root values if we've already changed root
!
  if (save_root_name .ne. ' ') then  !{
    root_p%name = save_root_name
    root_p%parent => save_root_parent_p
  endif  !}
!
!        set the pointer for the new root field
!
  root_p => temp_list_p
!
!        save the new root field's name and parent
!
  save_root_name = root_p%name
  save_root_parent_p => root_p%parent
!
!        set the new root name and parent fields to appropriate values
!
  root_p%name = ' '
  nullify(root_p%parent)
!
!        set the current list to the new root as it likely is not
!        going to be meaningful anymore
!
  current_list_p => root_p
  success = .true.
else  !}{
!
!        Couldn't find the list
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                      &
         'Could not find list ', trim(name)
  endif  !}
  success = .false.
endif  !}

end function  fm_change_root  !}
! </FUNCTION> NAME="fm_change_root"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_dump_list">
!
! <OVERVIEW>
!    A function to list properties associated with a field.
! </OVERVIEW>
! <DESCRIPTION>
!    This function writes the contents of the field named "name" to stdout.
!    If recursive is present and .true., then this function writes out the 
!    contents of any subfields associated with the field named "name".
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_dump_list(name, recursive = .true.) 
!   </TEMPLATE>
!
function  fm_dump_list(name, recursive)                        &
          result (success)  !{
!
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of the field for which output is requested.
!   </IN>
!   <IN NAME="recursive" TYPE="logical, optional">
!     If present and .true., then a recursive listing of fields will be
!     performed.
!   </IN>
!
!        Function definition
!
logical        :: success
!
!        arguments
!
character(len=*), intent(in)           :: name
logical,          intent(in), optional :: recursive

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=12), parameter :: sub_name     = 'fm_dump_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
logical                         :: recursive_t
type (field_def), pointer, save :: temp_list_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Check whether to do things recursively
!
if (present(recursive)) then  !{
  recursive_t = recursive
else  !}{
  recursive_t = .false.
endif  !}
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}

if (name .eq. ' ') then  !{
!
!        If list is empty, then dump the current list
!
  temp_list_p => current_list_p
  success = .true.
else  !}{
!
!        Get a pointer to the list
!
  temp_list_p => find_list(name, current_list_p, .false.)
  if (associated(temp_list_p)) then  !{
    success = .true.
  else  !}{
!
!        Error following the path
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                        &
           'Could not follow path for ', trim(name)
    endif  !}
    success = .false.
  endif  !}
endif  !}
!
!        Dump the list
!
if (success) then  !{
  success = dump_list(temp_list_p, recursive_t, 0)
endif  !}

end function  fm_dump_list  !}
! </FUNCTION> NAME="fm_dump_list"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_exists">
!
! <OVERVIEW>
!   A function to test whether a named field exists.
! </OVERVIEW>
! <DESCRIPTION>
!   This function determines is a field exists, relative to the current list,
!   and returns true if the list exists, false otherwise.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_exists(name)
!   </TEMPLATE>
!
function fm_exists(name)                                                &
        result (success)  !{
!
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of the field that is being queried.
!   </IN>
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!
!        Function definition
!
logical        :: success
!
!        arguments
!
character(len=*), intent(in) :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=9),  parameter :: sub_name     = 'fm_exists'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: dummy_p 
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Determine whether the field exists
!
dummy_p => get_field(name, current_list_p)
success = associated(dummy_p)

end function fm_exists  !}
! </FUNCTION> NAME="fm_exists"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_get_index">
!
! <OVERVIEW>
!    A function to return the index of a named field.
! </OVERVIEW>
! <DESCRIPTION>
!    Returns the index for name, returns the parameter NO_FIELD if it does not
!    exist. If the first character of the named field is the list peparator, 
!    then the named field will be relative to the root of the field tree. 
!    Otherwise the named field will be relative to the current list. 
! </DESCRIPTION>
!   <TEMPLATE>
!     index = fm_get_index(name)
!   </TEMPLATE>
!
function  fm_get_index(name)                        &
          result (index)  !{
!   <OUT NAME="index" TYPE="index">
!     The index of the named field if it exists. 
!     Otherwise the parameter NO_FIELD.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a field that the user wishes to get an index for.
!   </IN>
!
!        Function definition
!
integer        :: index
!
!        arguments
!
character(len=*), intent(in) :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=12), parameter :: sub_name     = 'fm_get_index'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  index = NO_FIELD
  return
endif  !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)
if (associated(temp_field_p)) then  !{
!
!        Set the index
!
  index = temp_field_p%index
else  !}{
!
!        Error following the path
!
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Could not follow path for ', trim(name)
  endif  !}
  index = NO_FIELD
endif  !}

end function  fm_get_index  !}
! </FUNCTION> NAME="fm_get_index"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_get_current_list">
!
! <OVERVIEW>
!    A function to return the full path of the current list.
! </OVERVIEW>
! <DESCRIPTION>
!    This function returns the full path for the current list. A blank 
!    path indicates an error condition has occurred.
! </DESCRIPTION>
!   <TEMPLATE>
!     path = fm_get_current_list()
!   </TEMPLATE>
!
function  fm_get_current_list()                                        &
          result (path)  !{
!
!   <OUT NAME="path" TYPE="character(len=fm_path_name_len)">
!     The path corresponding to the current list.
!   </OUT>
!
!        Function definition
!
character(len=fm_path_name_len) :: path
!
!        arguments
!

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=19), parameter :: sub_name     = 'fm_get_current_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_list_p 
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Set a pointer to the current list and proceed
!        up the tree, filling in the name as we go
!
temp_list_p => current_list_p
path = ' '

do while (associated(temp_list_p))  !{
!
!        Check whether we are at the root field--it is the
!        only field with a blank name
!
  if (temp_list_p%name .eq. ' ') then  !{
    exit
  endif  !}
!
!        Append the name to the path
!
  path = list_sep // trim(temp_list_p%name) // path
!
!        Point to the next field
!
  temp_list_p => temp_list_p%parent
enddo  !}

if (.not. associated(temp_list_p)) then  !{
!
!        The pointer is not associated, indicating an error has
!        occurred, so set the path accordingly
!
  path = ' '
elseif (path .eq. ' ') then  !}{
!
!        If path is empty, then the current list must be root,
!        so set path accordingly
!
  path = list_sep
endif  !}

end function  fm_get_current_list  !}
! </FUNCTION> NAME="fm_get_current_list"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_get_length">
!
! <OVERVIEW>
!    A function to return how many elements are contained within the named 
!    list or entry.
! </OVERVIEW>
! <DESCRIPTION>
!    This function returns the list or entry length for the named list or entry.
!    If the named field or entry does not exist, a value of 0 is returned.
! </DESCRIPTION>
!   <TEMPLATE>
!     length = fm_get_length(name)
!   </TEMPLATE>
!
function  fm_get_length(name)                        &
          result (length)  !{
!
!   <OUT NAME="length" TYPE="integer">
!     The number of elements that the field name has.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list or entry that the user wishes to get the length of.
!   </IN>
!
!        Function definition
!
integer                      :: length
!
!        arguments
!
character(len=*), intent(in) :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=13), parameter :: sub_name     = 'fm_get_length'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  length = 0
  return
endif  !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)

if (associated(temp_field_p)) then  !{
!
!        Set the field length
!
  if (temp_field_p%field_type .eq. list_type) then !{
    length = temp_field_p%length
  else !}{
    length = temp_field_p%max_index
  endif !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                            &
         'Could not follow path for ', trim(name)
  endif  !}
  length = 0
endif  !}

end function  fm_get_length  !}
! </FUNCTION> NAME="fm_get_length"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_get_type">
!
! <OVERVIEW>
!    A function to return the type of the named field.
! </OVERVIEW>
! <DESCRIPTION>
!    This function returns the type of the field for name.
!    This indicates whether the named field is a "list" (has children fields),
!    or has values of type "integer", "real", "logical" or "string".
!    If it does not exist it returns a blank string. 
! </DESCRIPTION>
!   <TEMPLATE>
!     name_field_type = fm_get_type(name)
!   </TEMPLATE>
!
function  fm_get_type(name)                        &
          result (name_field_type)  !{
!   <OUT NAME="name_field_type" TYPE="character(len=8)">
!     A string containing the type of the named field.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a field that the user wishes to find the type of.
!   </IN>
!
!        Function definition
!
character(len=8)             :: name_field_type
!
!        arguments
!
character(len=*), intent(in) :: name

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=11), parameter :: sub_name     = 'fm_get_type'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  name_field_type = ' '
  return
endif  !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)

if (associated(temp_field_p)) then  !{
!
!        Set the field type
!
  name_field_type = field_type_name(temp_field_p%field_type)
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                            &
         'Could not follow path for ', trim(name)
  endif  !}
  name_field_type = ' '
endif  !}

end function  fm_get_type  !}
! </FUNCTION> NAME="fm_get_type"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_get_value">
!
! <OVERVIEW>
!    An overloaded function to find and extract a value for a named field.
! </OVERVIEW>
! <DESCRIPTION>
!    Find and extract the value for name. The value may be of type real, 
!    integer, logical or character. If a single value from an array  of values 
!    is required, an optional index can be supplied.
!    Return true for success and false for failure
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_get_value(name, value, index)
!   </TEMPLATE>
!
function  fm_get_value_integer(name, value, index)                 &
          result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a field that the user wishes to get a value for.
!   </IN>
!   <OUT NAME="value" TYPE="integer, real, logical or character">
!     The value associated with the named field.
!   </OUT>
!   <IN NAME="index" TYPE="integer, optional">
!     An optional index to retrieve a single value from an array.
!   </IN>
!
!        Function definition
!
logical                                :: success
!
!        arguments
!
character(len=*), intent(in)           :: name
integer,          intent(out)          :: value
integer,          intent(in), optional :: index

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=20), parameter :: sub_name     = 'fm_get_value_integer'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: index_t
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  value = 0
  success = .false.
  return
endif  !}
!
!        Set index to retrieve
!
if (present(index)) then  !{
  index_t = index
else !}{
  index_t = 1
endif !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)

if (associated(temp_field_p)) then  !{
!
!        check that the field is the correct type
!
  if (temp_field_p%field_type .eq. integer_type) then  !{
    if (index_t .lt. 1) then  !{
!
!        Index is not positive
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Optional index for ', trim(name),                 &
             ' not positive: ', index_t
      endif  !}
      value = 0
      success = .false.
    elseif (index_t .gt. temp_field_p%max_index) then  !}{
!
!        Index is too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                        &
             'Optional index for ', trim(name),                      &
             ' too large: ', index_t, ' > ', temp_field_p%max_index
      endif  !}
      value = 0
      success = .false.
    else  !}{
!
!        extract the value
!
      value = temp_field_p%i_value(index_t)
      success = .true.
    endif !}
  else  !}{
!
!        Field not corrcet type
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Field not type integer ', trim(name)
    endif  !}
    value = 0
    success = .false.
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                            &
         'Could not follow path for ', trim(name)
  endif  !}
  value = 0
  success = .false.
endif  !}

end function  fm_get_value_integer  !}

!#######################################################################
!#######################################################################

function  fm_get_value_logical(name, value, index)                 &
          result (success)  !{
!
!        Function definition
!
logical                                :: success
!
!        arguments
!
character(len=*), intent(in)           :: name
logical,          intent(out)          :: value
integer,          intent(in), optional :: index

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=20), parameter :: sub_name     = 'fm_get_value_logical'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: index_t
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  value = .false.
  success = .false.
  return
endif  !}
!
!        Set index to retrieve
!
if (present(index)) then  !{
  index_t = index
else  !}{
  index_t = 1
endif  !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)

if (associated(temp_field_p)) then  !{
!
!        check that the field is the correct type
!
  if (temp_field_p%field_type .eq. logical_type) then  !{

    if (index_t .lt. 1) then  !{
!
!        Index is not positive
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Optional index for ', trim(name),                 &
             ' not positive: ', index_t
      endif  !}
      value = .false.
      success = .false.

    elseif (index_t .gt. temp_field_p%max_index) then  !}{
!
!        Index is too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                        &
             'Optional index for ', trim(name),                      &
             ' too large: ', index_t, ' > ', temp_field_p%max_index
      endif  !}
      value = .false.
      success = .false.

    else  !}{
!
!        extract the value
!
      value = temp_field_p%l_value(index_t)
      success = .true.
    endif !}
  else  !}{
!
!        Field not correct type
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Field not type logical ', trim(name)
    endif  !}
    value = .false.
    success = .false.
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                            &
         'Could not follow path for ', trim(name)
  endif  !}
  value = .false.
  success = .false.
endif  !}

end function  fm_get_value_logical  !}

!#######################################################################
!#######################################################################

function  fm_get_value_real(name, value, index)                 &
          result (success)  !{
!
!        Function definition
!
logical                                :: success
!
!        arguments
!
character(len=*), intent(in)           :: name
real,             intent(out)          :: value
integer,          intent(in), optional :: index

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=17), parameter :: sub_name     = 'fm_get_value_real'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: index_t
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  value = 0.0
  success = .false.
  return
endif  !}
!
!        Set index to retrieve
!
if (present(index)) then  !{
  index_t = index
else  !}{
  index_t = 1
endif  !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)

if (associated(temp_field_p)) then  !{
!
!        check that the field is the correct type
!
  if (temp_field_p%field_type .eq. real_type) then  !{

    if (index_t .lt. 1) then  !{

!
!        Index is not positive
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                        &
             'Optional index for ', trim(name),                      &
             ' not positive: ', index_t
      endif  !}
      value = 0.0
      success = .false.

    elseif (index_t .gt. temp_field_p%max_index) then  !}{

!
!        Index is too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                        &
             'Optional index for ', trim(name),                      &
             ' too large: ', index_t, ' > ', temp_field_p%max_index
      endif  !}
      value = 0.0
      success = .false.

    else  !}{

!
!        extract the value
!
      value = temp_field_p%r_value(index_t)
      success = .true.
    endif !}
  else  !}{
!
!        Field not correct type
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Field not type real ', trim(name)
    endif  !}
    value = 0.0
    success = .false.
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                            &
         'Could not follow path for ', trim(name)
  endif  !}
  value = 0.0
  success = .false.
endif  !}

end function  fm_get_value_real  !}

!#######################################################################
!#######################################################################

function  fm_get_value_string(name, value, index)                 &
          result (success)  !{
!
!        Function definition
!
logical                                :: success
!
!        arguments
!
character(len=*), intent(in)           :: name
character(len=*), intent(out)          :: value
integer,          intent(in), optional :: index

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=19), parameter :: sub_name     = 'fm_get_value_string'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: index_t
type (field_def), pointer, save :: temp_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  value = ''
  success = .false.
  return
endif  !}
!
!        Set index to retrieve
!
if (present(index)) then  !{
  index_t = index
else  !}{
  index_t = 1
endif  !}
!
!        Get a pointer to the field
!
temp_field_p => get_field(name, current_list_p)

if (associated(temp_field_p)) then  !{
!
!        check that the field is the correct type
!
  if (temp_field_p%field_type .eq. string_type) then  !{
    if (index_t .lt. 1) then  !{
!
!        Index is not positive
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                        &
             'Optional index for ', trim(name),                      &
             ' not positive: ', index_t
      endif  !}
      value = ''
      success = .false.

    elseif (index_t .gt. temp_field_p%max_index) then  !}{
!
!        Index is too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                        &
             'Optional index for ', trim(name),                      &
             ' too large: ', index_t, ' > ', temp_field_p%max_index
      endif  !}
      value = ''
      success = .false.
    else  !}{
!
!        extract the value
!
      value = temp_field_p%s_value(index_t)
      !if (trim(value) == '') then
        !success = .false.
      !else
        success = .true.
      !endif
    endif !}
  else  !}{
!
!        Field not correct type
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Field not type string ', trim(name)
    endif  !}
    value = ''
    success = .false.
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                            &
         'Could not follow path for ', trim(name)
  endif  !}
  value = ''
  success = .false.
endif  !}

end function  fm_get_value_string  !}
! </FUNCTION> NAME="fm_get_value"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_intersection">
!
! <OVERVIEW>
!    A function to find the common names of the sub-fields in a list 
!    of fields.
! </OVERVIEW>
! <DESCRIPTION>
!    Return a pointer to an fm_array_list of the intersection
!    of an array of lists, ignoring the contents of the values,
!    but just returning the names.
!    Return false on the end of the intersection.
! </DESCRIPTION>
!   <TEMPLATE>
!     return_p => fm_intersection(lists,dim)
!   </TEMPLATE>
!
function fm_intersection(lists, dim)                        &
        result (return_p)  !{
!   <OUT NAME="return_p" TYPE="type (fm_array_list_def), pointer">
!     A pointer to a list of names that are common to the fields provided in 
!     lists.
!   </OUT>
!   <IN NAME="dim" TYPE="dim">
!     The dimension of lists.
!   </IN>
!   <IN NAME="lists" TYPE="character(len=*)" DIM="(dim)">
!     A list of fields that the user wishes to find the common fields of.
!   </IN>
!
!        Function definition
!
type (fm_array_list_def), pointer  :: return_p
!
!        arguments
!
integer,          intent(in)       :: dim
character(len=*), intent(in)       :: lists(dim)

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=15), parameter :: sub_name     = 'fm_intersection'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character (len=fm_field_name_len)  :: name
character (len=fm_field_name_len),                          &
        dimension(:), allocatable  :: names
character (len=fm_type_name_len)   :: field_type
integer                            :: count
integer                            :: error
integer                            :: index
integer                            :: n, ier
integer                            :: shortest
logical                            :: found
type (field_def), pointer, save    :: temp_p 
integer                            :: out_unit

out_unit = stdout()

nullify(return_p)
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        return error if dimension if bad
!
if (dim .le. 0) then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Non-positive dimension: ', dim
  endif  !}
  nullify(return_p)
  return
endif  !}
!
!        make sure that the lists exist, and find the shortest list
!        and its length
!
count = -1
shortest = 0
do n = 1, dim  !{
  temp_p => find_list(lists(n), current_list_p, .false.)
  if (associated(temp_p)) then  !{
    if (count .eq. -1) then  !{
      count = temp_p%length
      shortest = n
    else  !}{
      if (count .gt. temp_p%length) then  !{
        count = temp_p%length
        shortest = n
      endif  !}
    endif  !}
  else  !}{
    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
                         'List does not exist: "', trim(lists(n)), '"'
    endif  !}
    nullify(return_p)
    return
  endif  !}
enddo  !} n
!
!        allocate return pointer
!
allocate( return_p, stat = error)
if (error .ne. 0) then !{
  write (out_unit,*) trim(error_header), 'Error ', error          &
                 , ' allocating memory for return_p '
  nullify(return_p)
  return
endif  !}
if ( associated(return_p%names)) deallocate(return_p%names)
!
!        return if any list is empty
!
if (count .eq. 0) then  !{
  return_p%length = 0
  return
endif  !}
!
!        If there is only one list, then return its names
!
if (dim .eq. 1) then  !{
!
!        allocate space for names in return pointer
!
  allocate( return_p%names(count), stat = error)
  if (error .ne. 0) then !{
    write (out_unit,*) trim(error_header), 'Error ', error        &
                   , ' allocating memory for names in return_p '
    nullify(return_p)
    return
  endif  !}
  count = 0
  do while (fm_loop_over_list(lists(1), name, field_type, index))  !{
    count = count + 1
    return_p%names(count) = name
  enddo  !}
  return
endif  !}
!
!        allocate space for names
!
allocate( names(count), stat = error)
if (error .ne. 0) then !{
  write (out_unit,*) trim(error_header), 'Error ', error          &
                 , ' allocating memory for names '
  nullify(return_p)
  return
endif  !}
!
!        Loop over the shortest list, checking whether its names
!        occur in all of the other lists. If so, then save the name
!
count = 0
do while (fm_loop_over_list(lists(shortest), name, field_type, index))  !{
  found = .true.
  do n = 1, dim  !{
    if (n .ne. shortest) then   !{
      temp_p => find_list(trim(lists(n)) // list_sep // name,        &
                          current_list_p, .false.)
      if (.not. associated(temp_p)) then  !{
        found = .false.
        exit
      endif  !}
    endif  !}
  enddo  !}
  if (found) then  !{
    count = count + 1
    names(count) = name
  endif  !}
enddo  !}
!
!        allocate space for names in return pointer
!
allocate( return_p%names(count), stat = error)
if (error .ne. 0) then !{
  write (out_unit,*) trim(error_header), 'Error ', error  &
                 , ' allocating memory for names in return_p '
  deallocate(names)
  nullify(return_p)
  return
endif  !}
!
!        copy the names to the return pointer and clean up
!
do n = 1, count  !{
  return_p%names(n) = names(n)
enddo  !} n
return_p%length = count
deallocate(names)

end function fm_intersection  !}
! </FUNCTION> NAME="fm_intersection"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_loop_over_list">
!
! <OVERVIEW>
!    A function for looping over a list.
! </OVERVIEW>
! <DESCRIPTION>
!    Loop over the list, setting the name, type and index
!    of the next field. Return false at the end of the loop.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_loop_over_list(list, name, field_type, index)
!   </TEMPLATE>
!
function  fm_loop_over_list(list, name, field_type, index)        &
          result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="list" TYPE="character(len=*)">
!     The name of a list to loop over.
!   </IN>
!   <OUT NAME="name" TYPE="character(len=*)">
!     The name of a field from list.
!   </OUT>
!   <OUT NAME="field_type" TYPE="character(len=fm_type_name_len)">
!     The type of a list entry.
!   </OUT>
!   <OUT NAME="index" TYPE="integer">
!     The index of tje field within the list.
!   </OUT>
!
!        Function definition
!
logical                                      :: success
!
!        arguments
!
character(len=*),                intent(in)  :: list
character(len=*),                intent(out) :: name
character(len=fm_type_name_len), intent(out) :: field_type
integer,                         intent(out) :: index

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=17), parameter :: sub_name     = 'fm_loop_over_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
type (field_def), pointer, save :: temp_list_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}

if (list .eq. loop_list .and. associated(loop_list_p)) then  !{
!
!        We've already started this loop, so continue on
!
  loop_list_p => loop_list_p%next
  success = set_list_stuff()
elseif (list .eq. ' ') then  !{
!
!        If list is empty, then loop over the current list
!
  loop_list = ' '
  loop_list_p => current_list_p%first_field
  success = set_list_stuff()
else  !}{
!
!        Get a pointer to the list
!
  loop_list = list
  loop_list_p => find_list(loop_list, current_list_p, .false.)
  if (associated(loop_list_p)) then  !{
    loop_list_p => loop_list_p%first_field
    success = set_list_stuff()
  else  !}{
!
!        Error following the path
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                        &
           'Could not follow path for ', trim(list)
    endif  !}
    success = .false.
  endif  !}
endif  !}

return

contains

!#######################################################################
!#######################################################################

! <FUNCTION NAME="set_list_stuff">
!
! <DESCRIPTION>
! If the the pointer matches to the right list,
! extract the field information.  Used in fm_loop_over_list
! </DESCRIPTION>
function  set_list_stuff()                                                &
          result (success)  !{
!
!        Function definition
!
  logical        :: success
!
!        arguments
!
  if (associated(loop_list_p)) then  !{
    name = loop_list_p%name
    field_type = field_type_name(loop_list_p%field_type)
    index = loop_list_p%index
    success = .true.
  else  !}{
    name = ' '
    field_type = ' '
    index = 0
    success = .false.
    loop_list = ' '
  endif  !}

end function  set_list_stuff  !}
! </FUNCTION> NAME="set_list_stuff"

end function  fm_loop_over_list  !}
! </FUNCTION> NAME="fm_loop_over_list"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_new_list">
!
! <OVERVIEW>
!    A function to create a new list.
! </OVERVIEW>
! <DESCRIPTION>
!    Allocate and initialize a new list and return the index of the list. 
!    If an error occurs return the parameter NO_FIELD.
! </DESCRIPTION>
!   <TEMPLATE>
!     index = fm_new_list(name, create, keep)
!   </TEMPLATE>
!
function  fm_new_list(name, create, keep)                        &
          result (index)  !{
!   <OUT NAME="index" TYPE="integer">
!     The index of the newly created list.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list that the user wishes to create.
!   </IN>
!   <IN NAME="create" TYPE="logical, optional">
!     If present and .true., create the list if it does not exist.
!   </IN>
!   <IN NAME="keep" TYPE="logical, optional">
!     If present and .true., make this list the current list.
!   </IN>
!
!        Function definition
!
integer                                :: index
!
!        arguments
!
character(len=*), intent(in)           :: name
logical,          intent(in), optional :: create
logical,          intent(in), optional :: keep

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=11), parameter :: sub_name     = 'fm_new_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
logical                          :: create_t
logical                          :: keep_t
character(len=fm_path_name_len)  :: path
character(len=fm_field_name_len) :: base
type (field_def), pointer, save  :: temp_list_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field list name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a list name'
  endif  !}
  index = NO_FIELD
  return
endif  !}
!
!        Check for optional arguments
!
if (present(create)) then  !{
  create_t = create
else  !}{
  create_t = .false.
endif  !}

if (present(keep)) then  !{
  keep_t = keep
else  !}{
  keep_t = .false.
endif  !}
!
!        Get a pointer to the parent list
!
call find_base(name, path, base)

temp_list_p => find_list(path, current_list_p, create_t)

if (associated(temp_list_p)) then  !{
!
!        Create the list
!
  temp_list_p => make_list(temp_list_p, base)
  if (associated(temp_list_p)) then  !{
!
!        Make this list the current list, if requested
!
    if (keep_t) then  !{
      current_list_p => temp_list_p
    endif  !}
    index = temp_list_p%index
  else  !}{
!
!        Error in making the list
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                        &
           'Could not create list ', trim(name)
    endif  !}
    index = NO_FIELD

  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                  &
         'Could not follow path for ', trim(name)
  endif  !}
  index = NO_FIELD

endif  !}

end function  fm_new_list  !}
! </FUNCTION> NAME="fm_new_list"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_new_value">
!
! <OVERVIEW>
!    An overloaded function to assign a value to a field.
! </OVERVIEW>
! <DESCRIPTION>
!    Allocate and initialize a new value and return the index.
!    If an error condition occurs the parameter NO_FIELD is returned.
!
!    If the type of the field is changing (e.g. real values being transformed to
!    integers), then any previous values for the field are removed and replaced 
!    by the value passed in the present call to this function.
!     
!    If append is present and .true., then index cannot be greater than 0 if 
!    it is present.
! </DESCRIPTION>
!   <TEMPLATE>
!     field_index = fm_new_value(name, value, [create], [index], [append])
!   </TEMPLATE>
!
function  fm_new_value_integer(name, value, create, index, append)     &
          result (field_index)  !{
!   <OUT NAME="field_index" TYPE="integer">
!     An index for the named field.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a field that the user wishes to create a value for.
!   </IN>
!   <IN NAME="value" TYPE="integer, real, logical, or character(len=*)">
!     The value that the user wishes to apply to the named field.
!   </IN>
!   <IN NAME="create" TYPE="logical, optional">
!     If present and .true., then a value for this field will be created.
!   </IN>
!   <IN NAME="index" TYPE="integer, optional">
!     The index to an array of values that the user wishes to apply a new value.
!   </IN>
!   <IN NAME="append" TYPE="logical, optional">
!     If present and .true., then append the value to an array of the present 
!     values. If present and .true., then index cannot be greater than 0.
!   </IN>
!
!        Function definition
!
integer                                :: field_index
!
!        arguments
!
character(len=*), intent(in)           :: name
integer,          intent(in)           :: value
logical,          intent(in), optional :: create
integer,          intent(in), optional :: index
logical,          intent(in), optional :: append

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=20), parameter :: sub_name     = 'fm_new_value_integer'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
logical                          :: create_t
integer                          :: i, ier
integer                          :: index_t
integer, pointer, dimension(:)   :: temp_i_value
character(len=fm_path_name_len)  :: path
character(len=fm_field_name_len) :: base
type (field_def), pointer, save  :: temp_list_p 
type (field_def), pointer, save  :: temp_field_p 
integer                          :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  field_index = NO_FIELD
  return
endif  !}
!
!        Check for optional arguments
!
if (present(create)) then  !{
  create_t = create
else  !}{
  create_t = .false.
endif  !}
!
!        Check that append is not true and index non-positive
!

if (present(index) .and. present(append)) then  !{
  if (append .and. index .gt. 0) then  !{
    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Index and Append both set for ', trim(name)
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
endif  !}
!
!        Set index to define
!
if (present(index)) then  !{
  index_t = index
  if (index_t .lt. 0) then  !{
!
!        Index is negative
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Optional index for ', trim(name),                   &
           ' negative: ', index_t
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
else  !}{
  index_t = 1
endif  !}
!
!        Get a pointer to the parent list
!
call find_base(name, path, base)
temp_list_p => find_list(path, current_list_p, create_t)

if (associated(temp_list_p)) then  !{
  temp_field_p => find_field(base, temp_list_p)
  if (.not. associated(temp_field_p)) then  !{
!
!        Create the field if it doesn't exist
!
    temp_field_p => create_field(temp_list_p, base)
  endif  !}
  if (associated(temp_field_p)) then  !{
!
!        Check if the field_type is the same as previously
!        If not then reset max_index to 0
!
    if (temp_field_p%field_type /= integer_type ) then
        temp_field_p%max_index = 0
      if (temp_field_p%field_type /= null_type ) then  !{
        if (verb .gt. verb_level_warn) then  !{
          write (out_unit,*) trim(warn_header),                   &
               'Changing type of ', trim(name), ' from ',         &
               trim(field_type_name(temp_field_p%field_type)),    &
               ' to ', trim(field_type_name(integer_type))
        endif  !}
      endif  !}
    endif
!
!        Assign the type
!
    temp_field_p%field_type = integer_type
!
!        Set the index if appending
!

    if (present(append)) then  !{
      if (append) then  !{
        index_t = temp_field_p%max_index + 1
      endif  !}
    endif  !}

    if (index_t .gt. temp_field_p%max_index + 1) then  !{

!
!        Index too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Index too large for ', trim(name), ': ', index_t
      endif  !}
      field_index = NO_FIELD
      return

    elseif (index_t .eq. 0 .and.                                &
            temp_field_p%max_index .gt. 0) then  !}{
!
!        Can't set non-null field to null
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Trying to nullify a non-null field: ',            &
             trim(name)
      endif  !}
      field_index = NO_FIELD
      return

    elseif (.not. associated(temp_field_p%i_value) .and.        &
            index_t .gt. 0) then  !}{
!
!        Array undefined, so allocate the array
!
      allocate(temp_field_p%i_value(1))
      temp_field_p%max_index = 1
      temp_field_p%array_dim = 1
    elseif (index_t .gt. temp_field_p%array_dim) then  !}{
!
!        Array is too small, so allocate new array and copy over
!        old values
!
      temp_field_p%array_dim = temp_field_p%array_dim + array_increment
      allocate (temp_i_value(temp_field_p%array_dim))
      do i = 1, temp_field_p%max_index  !{
        temp_i_value(i) = temp_field_p%i_value(i)
      enddo  !} i
      if (associated (temp_field_p%i_value)) deallocate(temp_field_p%i_value)
      temp_field_p%i_value => temp_i_value
      temp_field_p%max_index = index_t
    endif  !}
!
!        Assign the value and set the field_index for return
!        for non-null fields (index_t > 0)
!
    if (index_t .gt. 0) then  !{
      temp_field_p%i_value(index_t) = value
      if (index_t .gt. temp_field_p%max_index) then  !{
        temp_field_p%max_index = index_t
      endif  !}
    endif  !}
    field_index = temp_field_p%index

  else  !}{
!
!        Error in making the field
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Could not create integer value field ',             &
           trim(name)
    endif  !}
    field_index = NO_FIELD
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                       &
         'Could not follow path for ',                          &
         trim(name)
  endif  !}
  field_index = NO_FIELD
endif  !}

end function  fm_new_value_integer  !}

!#######################################################################
!#######################################################################

function  fm_new_value_logical(name, value, create, index, append) &
          result (field_index)  !{
!
!        Function definition
!
integer                                :: field_index
!
!        arguments
!
character(len=*), intent(in)           :: name
logical,          intent(in)           :: value
logical,          intent(in), optional :: create
integer,          intent(in), optional :: index 
logical,          intent(in), optional :: append

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=20), parameter :: sub_name     = 'fm_new_value_logical'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len)      :: path
character(len=fm_field_name_len)     :: base
integer                              :: i, ier
integer                              :: index_t
logical                              :: create_t
logical, dimension(:), pointer       :: temp_l_value 
type (field_def),      pointer, save :: temp_list_p 
type (field_def),      pointer, save :: temp_field_p 
integer                              :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  field_index = NO_FIELD
  return
endif  !}
!
!        Check for optional arguments
!
if (present(create)) then  !{
  create_t = create
else  !}{
  create_t = .false.
endif  !}
!
!        Check that append is not true and index greater than 0
!
if (present(index) .and. present(append)) then  !{
  if (append .and. index .gt. 0) then  !{
    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Index and Append both set for ', trim(name)
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
endif  !}
!
!        Set index to define
!

if (present(index)) then  !{
  index_t = index
  if (index_t .lt. 0) then  !{
!
!        Index is negative
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Optional index for ', trim(name),                   &
           ' negative: ', index_t
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
else  !}{
  index_t = 1
endif !}
!
!        Get a pointer to the parent list
!
call find_base(name, path, base)
temp_list_p => find_list(path, current_list_p, create_t)

if (associated(temp_list_p)) then  !{
  temp_field_p => find_field(base, temp_list_p)
  if (.not. associated(temp_field_p)) then  !{
!
!        Create the field if it doesn't exist
!
    temp_field_p => create_field(temp_list_p, base)
  endif  !}
  if (associated(temp_field_p)) then  !{
!
!        Check if the field_type is the same as previously
!        If not then reset max_index to 0
!
    if (temp_field_p%field_type /= logical_type ) then
        temp_field_p%max_index = 0
      if (temp_field_p%field_type /= null_type ) then  !{
        if (verb .gt. verb_level_warn) then  !{
          write (out_unit,*) trim(warn_header),                   &
               'Changing type of ', trim(name), ' from ',         &
               trim(field_type_name(temp_field_p%field_type)),    &
               ' to ', trim(field_type_name(logical_type))
        endif  !}
      endif  !}
    endif
!
!        Assign the type
!
    temp_field_p%field_type = logical_type
!
!        Set the index if appending
!

    if (present(append)) then  !{
      if (append) then  !{
        index_t = temp_field_p%max_index + 1
      endif  !}
    endif  !}

    if (index_t .gt. temp_field_p%max_index + 1) then  !{

!
!        Index too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Index too large for ', trim(name), ': ', index_t
      endif  !}
      field_index = NO_FIELD
      return

    elseif (index_t .eq. 0 .and.                                &
            temp_field_p%max_index .gt. 0) then  !}{

!
!        Can't set non-null field to null
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Trying to nullify a non-null field: ', trim(name)
      endif  !}
      field_index = NO_FIELD
      return

    elseif (.not. associated(temp_field_p%l_value) .and.        &
            index_t .gt. 0) then  !}{

!
!        Array undefined, so allocate the array
!

      allocate(temp_field_p%l_value(1))
      temp_field_p%max_index = 1
      temp_field_p%array_dim = 1

    elseif (index_t .gt. temp_field_p%array_dim) then  !}{

!
!        Array is too small, so allocate new array and copy over
!        old values
!
      temp_field_p%array_dim = temp_field_p%array_dim + array_increment
      allocate (temp_l_value(temp_field_p%array_dim))
      do i = 1, temp_field_p%max_index  !{
        temp_l_value(i) = temp_field_p%l_value(i)
      enddo  !} i
      if (associated(temp_field_p%l_value)) deallocate(temp_field_p%l_value)
      temp_field_p%l_value => temp_l_value
      temp_field_p%max_index = index_t

    endif  !}

!
!        Assign the value and set the field_index for return
!        for non-null fields (index_t > 0)
!

    if (index_t .gt. 0) then  !{
      temp_field_p%l_value(index_t) = value
      if (index_t .gt. temp_field_p%max_index) then  !{
        temp_field_p%max_index = index_t
      endif  !}
    endif  !}
    field_index = temp_field_p%index
  else  !}{
!
!        Error in making the field
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Could not create logical value field ',             &
           trim(name)
    endif  !}
    field_index = NO_FIELD
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                       &
         'Could not follow path for ',                          &
         trim(name)
  endif  !}
  field_index = NO_FIELD
endif  !}

end function  fm_new_value_logical  !}

!#######################################################################
!#######################################################################

function  fm_new_value_real(name, value, create, index, append) &
          result (field_index)  !{
!
!        Function definition
!
integer                                :: field_index
!
!        arguments
!
character(len=*), intent(in)           :: name
real,             intent(in)           :: value
logical,          intent(in), optional :: create
integer,          intent(in), optional :: index
logical,          intent(in), optional :: append
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=17), parameter :: sub_name     = 'fm_new_value_real'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

logical                          :: create_t
integer                          :: i, ier
integer                          :: index_t
real, pointer, dimension(:)      :: temp_r_value
character(len=fm_path_name_len)  :: path
character(len=fm_field_name_len) :: base
type (field_def), pointer, save  :: temp_list_p 
type (field_def), pointer, save  :: temp_field_p 
integer                          :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  field_index = NO_FIELD
  return
endif  !}
!
!        Check for optional arguments
!
if (present(create)) then  !{
  create_t = create
else  !}{
  create_t = .false.
endif  !}
!
!        Check that append is not true and index greater than 0
!
if (present(index) .and. present(append)) then  !{
  if (append .and. index .gt. 0) then  !{
    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                          &
           'Index and Append both set for ', trim(name)
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
endif  !}
!
!        Set index to define
!

if (present(index)) then  !{
  index_t = index
  if (index_t .lt. 0) then  !{
!
!        Index is negative
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Optional index for ', trim(name),                   &
           ' negative: ', index_t
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
else  !}{
  index_t = 1
endif !}

!
!        Get a pointer to the parent list
!
call find_base(name, path, base)
temp_list_p => find_list(path, current_list_p, create_t)

if (associated(temp_list_p)) then  !{
  temp_field_p => find_field(base, temp_list_p)
  if (.not. associated(temp_field_p)) then  !{
!
!        Create the field if it doesn't exist
!
    temp_field_p => create_field(temp_list_p, base)
  endif  !}
  if (associated(temp_field_p)) then  !{
!
!        Check if the field_type is the same as previously
!        If not then reset max_index to 0
!
    if (temp_field_p%field_type /= real_type ) then
        temp_field_p%max_index = 0
      if (temp_field_p%field_type /= null_type ) then  !{
        if (verb .gt. verb_level_warn) then  !{
          write (out_unit,*) trim(warn_header),                   &
               'Changing type of ', trim(name), ' from ',         &
               trim(field_type_name(temp_field_p%field_type)),    &
               ' to ', trim(field_type_name(real_type))
        endif  !}
      endif  !}
    endif
!
!        Assign the type
!
    temp_field_p%field_type = real_type
!
!        Set the index if appending
!
    if (present(append)) then  !{
      if (append) then  !{
        index_t = temp_field_p%max_index + 1
      endif  !}
    endif  !}
    if (index_t .gt. temp_field_p%max_index + 1) then  !{
!
!        Index too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Index too large for ', trim(name), ': ', index_t
      endif  !}
      field_index = NO_FIELD
      return
    elseif (index_t .eq. 0 .and.                                &
            temp_field_p%max_index .gt. 0) then  !}{
!
!        Can't set non-null field to null
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Trying to nullify a non-null field: ',            &
             trim(name)
      endif  !}
      field_index = NO_FIELD
      return
    elseif (.not. associated(temp_field_p%r_value) .and.        &
            index_t .gt. 0) then  !}{
!
!        Array undefined, so allocate the array
!
      allocate(temp_field_p%r_value(1))
      temp_field_p%max_index = 1
      temp_field_p%array_dim = 1
    elseif (index_t .gt. temp_field_p%array_dim) then  !}{
!
!        Array is too small, so allocate new array and copy over
!        old values
!
      temp_field_p%array_dim = temp_field_p%array_dim + array_increment
      allocate (temp_r_value(temp_field_p%array_dim))
      do i = 1, temp_field_p%max_index  !{
        temp_r_value(i) = temp_field_p%r_value(i)
      enddo  !} i
      if (associated(temp_field_p%r_value)) deallocate(temp_field_p%r_value)
      temp_field_p%r_value => temp_r_value
      temp_field_p%max_index = index_t
    endif  !}
!
!        Assign the value and set the field_index for return
!        for non-null fields (index_t > 0)
!
    if (index_t .gt. 0) then  !{
      temp_field_p%r_value(index_t) = value
      if (index_t .gt. temp_field_p%max_index) then  !{
        temp_field_p%max_index = index_t
      endif  !}
    endif  !}
    field_index = temp_field_p%index
  else  !}{
!
!        Error in making the field
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                        &
           'Could not create real value field ', trim(name)
    endif  !}
    field_index = NO_FIELD
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                          &
         'Could not follow path for ', trim(name)
  endif  !}
  field_index = NO_FIELD
endif  !}

end function  fm_new_value_real  !}

!#######################################################################
!#######################################################################

function  fm_new_value_string(name, value, create, index, append) &
          result (field_index)  !{
!
!        Function definition
!
integer                                :: field_index
!
!        arguments
!
character(len=*), intent(in)           :: name
character(len=*), intent(in)           :: value
logical,          intent(in), optional :: create
integer,          intent(in), optional :: index
logical,          intent(in), optional :: append
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=19), parameter :: sub_name     = 'fm_new_value_string'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=fm_string_len), dimension(:), pointer :: temp_s_value
character(len=fm_path_name_len)                     :: path
character(len=fm_field_name_len)                    :: base
integer                                             :: i, ier
integer                                             :: index_t
logical                                             :: create_t
type (field_def),                     save, pointer :: temp_list_p
type (field_def),                     save, pointer :: temp_field_p
integer                         :: out_unit

out_unit = stdout()
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Must supply a field name
!
if (name .eq. ' ') then  !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'Must supply a field name'
  endif  !}
  field_index = NO_FIELD
  return
endif  !}
!
!        Check for optional arguments
!
if (present(create)) then  !{
  create_t = create
else  !}{
  create_t = .false.
endif  !}
!
!        Check that append is not true and index greater than 0
!

if (present(index) .and. present(append)) then  !{
  if (append .and. index .gt. 0) then  !{
    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Index and Append both set for ', trim(name)
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
endif  !}
!
!        Set index to define
!
if (present(index)) then  !{
  index_t = index
  if (index_t .lt. 0) then  !{
!
!        Index is negative
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Optional index for ', trim(name),                   &
           ' negative: ', index_t
    endif  !}
    field_index = NO_FIELD
    return
  endif  !}
else  !}{
  index_t = 1
endif  !}

!
!        Get a pointer to the parent list
!
call find_base(name, path, base)
temp_list_p => find_list(path, current_list_p, create_t)

if (associated(temp_list_p)) then  !{
  temp_field_p => find_field(base, temp_list_p)
  if (.not. associated(temp_field_p)) then  !{
!
!        Create the field if it doesn't exist
!
    temp_field_p => create_field(temp_list_p, base)
  endif  !}
  if (associated(temp_field_p)) then  !{
!
!        Check if the field_type is the same as previously
!        If not then reset max_index to 0
!
    if (temp_field_p%field_type /= string_type ) then
        temp_field_p%max_index = 0
      if (temp_field_p%field_type /= null_type ) then  !{
        if (verb .gt. verb_level_warn) then  !{
          write (out_unit,*) trim(warn_header),                   &
               'Changing type of ', trim(name), ' from ',         &
               trim(field_type_name(temp_field_p%field_type)),    &
               ' to ', trim(field_type_name(string_type))
        endif  !}
      endif  !}
    endif
!
!        Assign the type
!
    temp_field_p%field_type = string_type
!
!        Set the index if appending
!

    if (present(append)) then  !{
      if (append) then  !{
        index_t = temp_field_p%max_index + 1
      endif  !}
    endif  !}

    if (index_t .gt. temp_field_p%max_index + 1) then  !{

!
!        Index too large
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Index too large for ', trim(name), ': ', index_t
      endif  !}
      field_index = NO_FIELD
      return

    elseif (index_t .eq. 0 .and.                                &
            temp_field_p%max_index .gt. 0) then  !}{

!
!        Can't set non-null field to null
!

      if (verb .gt. verb_level_warn) then  !{
        write (out_unit,*) trim(warn_header),                   &
             'Trying to nullify a non-null field: ',            &
             trim(name)
      endif  !}
      field_index = NO_FIELD
      return

    elseif (.not. associated(temp_field_p%s_value) .and.        &
            index_t .gt. 0) then  !}{

!
!        Array undefined, so allocate the array
!

      allocate(temp_field_p%s_value(1))
      temp_field_p%max_index = 1
      temp_field_p%array_dim = 1

    elseif (index_t .gt. temp_field_p%array_dim) then  !}{

!
!        Array is too small, so allocate new array and copy over
!        old values
!
      temp_field_p%array_dim = temp_field_p%array_dim + array_increment
      allocate (temp_s_value(temp_field_p%array_dim))
      do i = 1, temp_field_p%max_index  !{
        temp_s_value(i) = temp_field_p%s_value(i)
      enddo  !} i
      if (associated(temp_field_p%s_value)) deallocate(temp_field_p%s_value)
      temp_field_p%s_value => temp_s_value
      temp_field_p%max_index = index_t

    endif  !}

!
!        Assign the value and set the field_index for return
!        for non-null fields (index_t > 0)
!

    if (index_t .gt. 0) then  !{
      temp_field_p%s_value(index_t) = value
      if (index_t .gt. temp_field_p%max_index) then  !{
        temp_field_p%max_index = index_t
      endif  !}
    endif  !}
    field_index = temp_field_p%index
  else  !}{
!
!        Error in making the field
!

    if (verb .gt. verb_level_warn) then  !{
      write (out_unit,*) trim(warn_header),                     &
           'Could not create string value field ',              &
           trim(name)
    endif  !}
    field_index = NO_FIELD
  endif  !}
else  !}{
!
!        Error following the path
!

  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                       &
         'Could not follow path for ', trim(name)
  endif  !}
  field_index = NO_FIELD
endif  !}

end function  fm_new_value_string  !}
! </FUNCTION> NAME="fm_new_value"


!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_reset_loop">
!
! <OVERVIEW>
!    Resets the loop variable. For use in conjunction with fm_loop_over_list.
! </OVERVIEW>
! <DESCRIPTION>
!    Resets the loop variable. For use in conjunction with fm_loop_over_list.
! </DESCRIPTION>
!   <TEMPLATE>
!     call fm_reset_loop 
!   </TEMPLATE>
!
subroutine  fm_reset_loop
!
!        arguments
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=13), parameter :: sub_name     = 'fm_reset_loop'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        Reset the variables
!
loop_list = ' '
nullify(loop_list_p)

end subroutine  fm_reset_loop  !}
! </FUNCTION> NAME="fm_reset_loop"

!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_return_root">
!
! <OVERVIEW>
!    Return the root list to the value at initialization
! </OVERVIEW>
! <DESCRIPTION>
!    Return the root list to the value at initialization. 
!    For use in conjunction with fm_change_root. 
!
!    Users should use this routine before leaving their routine if they 
!    previously used fm_change_root.
! </DESCRIPTION>
!   <TEMPLATE>
!     call fm_return_root
!   </TEMPLATE>
!
subroutine  fm_return_root  !{
!
!        arguments
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=14), parameter :: sub_name     = 'fm_return_root'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
!
!        restore the saved values to the current root
!
root_p%name = save_root_name
root_p%parent => save_root_parent_p
!
!        set the pointer to the original root field
!
root_p => root
!
!        reset the save root name and parent variables
!
save_root_name = ' '
nullify(save_root_parent_p)

end subroutine  fm_return_root  !}
! </FUNCTION> NAME="fm_return_root"

!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="get_field">
!
! <OVERVIEW>
!    Return a pointer to the field if it exists relative to this_list_p,
!    null otherwise
! </OVERVIEW>
! <DESCRIPTION>
!    Return a pointer to the field if it exists relative to this_list_p,
!    null otherwise
! </DESCRIPTION>
!   <TEMPLATE>
!     list_p => get_field(name, this_list_p)
!   </TEMPLATE>
!
function get_field(name, this_list_p)                                        &
        result (list_p)  !{
!   <OUT NAME="list_p" TYPE="type (field_def)">
!     A pointer to the field name.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list that the user wishes to get information for.
!   </IN>
!   <IN NAME="this_list_p" TYPE="type (field_def)">
!     A pointer to a list that serves as the base point for searching for name.
!   </IN>
!
!        Function definition
!
type (field_def), pointer        :: list_p
!
!        arguments
!
character(len=*), intent(in)     :: name
type (field_def), pointer        :: this_list_p
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=9),  parameter :: sub_name     = 'get_field'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len)  :: path
character(len=fm_field_name_len) :: base
type (field_def), pointer, save  :: temp_p 

nullify(list_p)
!
!        Get the path and base for name
!
call find_base(name, path, base)
!
!        Find the list if path is not empty
!
if (path .ne. ' ') then  !{
  temp_p => find_list(path, this_list_p, .false.)
  if (associated(temp_p)) then  !{
    list_p => find_field(base, temp_p)
  else  !}{
    nullify(list_p)
  endif  !}
else  !}{
  list_p => find_field(base, this_list_p)
endif  !}

end function get_field  !}
! </FUNCTION> NAME="get_field"
!</PRIVATE>


!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_modify_name">
!
! <OVERVIEW>
!    This function allows a user to rename a field without modifying the 
!    contents of the field.
! </OVERVIEW>
! <DESCRIPTION>
!    Function to modify the name of a field. 
!    Should be used with caution.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_modify_name(oldname, newname)
!   </TEMPLATE>
!
function fm_modify_name(oldname, newname)                                        &
        result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="oldname" TYPE="character(len=*)">
!     The name of a field that the user wishes to change the name of.
!   </IN>
!   <IN NAME="newname" TYPE="character(len=*)">
!     The name that the user wishes to change the name of the field to.
!   </IN>
!
!        Function definition
!
logical                          :: success
!
!        arguments
!
character(len=*), intent(in)     :: oldname
character(len=*), intent(in)     :: newname
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=14), parameter :: sub_name     = 'fm_modify_name'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len)  :: path
character(len=fm_field_name_len) :: base
type (field_def), pointer, save  :: list_p 
type (field_def), pointer, save  :: temp_p 
!
!        Get the path and base for name
!
call find_base(oldname, path, base)
!
!        Find the list if path is not empty
!
success = .false.
if (path .ne. ' ') then  !{
  temp_p => find_list(path, current_list_p, .false.)
  if (associated(temp_p)) then  !{
    list_p => find_field(base, temp_p)
    if (associated(list_p)) then !{
      list_p%name = newname
      success = .true.
    endif!}
  else  !}{
    nullify(list_p)
  endif  !}
else  !}{
  list_p => find_field(base, current_list_p)
  if (associated(list_p)) then !{
    list_p%name = newname
    success = .true.
  endif !} 
endif  !}

end function fm_modify_name  !}
! </FUNCTION> NAME="fm_modify_name"


!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="initialize">
!
! <OVERVIEW>
!    A function to initialize the values of the pointers. This will remove
!    all fields and reset the field tree to only the root field.
! </OVERVIEW>
! <DESCRIPTION>
!    A function to initialize the values of the pointers. This will remove
!    all fields and reset the field tree to only the root field.
! </DESCRIPTION>
!   <TEMPLATE>
!     call initialize
!   </TEMPLATE>
!
subroutine initialize  !{
!
!        arguments
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=10), parameter :: sub_name     = 'initialize'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer :: ier
!
!        Initialize the root field
!
if (.not. module_is_initialized) then  !{
  root_p => root

  field_type_name(integer_type) = 'integer'
  field_type_name(list_type) = 'list'
  field_type_name(logical_type) = 'logical'
  field_type_name(real_type) = 'real'
  field_type_name(string_type) = 'string'

  root%name = ' '
  root%index = 1
  root%parent => root_p

  root%field_type = list_type

  root%length = 0
  nullify(root%first_field)
  nullify(root%last_field)
  root%max_index = 0
  root%array_dim = 0
  if (associated(root%i_value)) deallocate(root%i_value)
  if (associated(root%l_value)) deallocate(root%l_value)
  if (associated(root%r_value)) deallocate(root%r_value)
  if (associated(root%s_value)) deallocate(root%s_value)

  nullify(root%next)
  nullify(root%prev)

  current_list_p => root

  nullify(loop_list_p)
  loop_list = ' '

  nullify(save_root_parent_p)
  save_root_name = ' '

  module_is_initialized = .true.

endif  !}

end subroutine initialize  !}
! </FUNCTION> NAME="initialize"
!</PRIVATE>

!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="make_list">
!
! <OVERVIEW>
!    This function creates a new field and returns a pointer to that field.
! </OVERVIEW>
! <DESCRIPTION>
!    Allocate and initialize a new list in this_list_p list.
!    Return a pointer to the list on success, or a null pointer
!    on failure
! </DESCRIPTION>
!   <TEMPLATE>
!     list_p => make_list(this_list_p, name)
!   </TEMPLATE>
!
function  make_list(this_list_p, name)                        &
          result (list_p)  !{
!   <OUT NAME="list_p" TYPE="type (field_def), pointer">
!     A pointer to the list that has been created. 
!   </OUT>
!   <IN NAME="this_list_p" TYPE="type (field_def), pointer">
!     The base of a list that the user wishes to add a list to.
!   </IN>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list that the user wishes to create.
!   </IN>
!
!        Function definition
!
type (field_def), pointer    :: list_p
!
!        arguments
!
type (field_def), pointer    :: this_list_p
character(len=*), intent(in) :: name
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=9),  parameter :: sub_name     = 'make_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer :: ier
type (field_def), pointer, save :: dummy_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Check to see whether there is already a list with
!        this name, and if so, return an error as list names
!        must be unique
!
dummy_p => find_field(name, this_list_p )
if (associated(dummy_p)) then  !{
!
!        This list is already specified, return an error
!
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header), 'List ',                 &
         trim(name), ' already exists'
  endif  !}
!  nullify(list_p)
  list_p => dummy_p
  return
endif  !}
!
!        Create a field for the new list
!
nullify(list_p)
list_p => create_field(this_list_p, name)
if (.not. associated(list_p)) then !{
  if (verb .gt. verb_level_warn) then  !{
    write (out_unit,*) trim(warn_header),                          &
         'Could not create field ', trim(name)
  endif  !}
  nullify(list_p)
  return
endif  !}
!
!        Initialize the new list
!
list_p%length = 0
list_p%field_type = list_type
if (associated(list_p%i_value)) deallocate(list_p%i_value)
if (associated(list_p%l_value)) deallocate(list_p%l_value)
if (associated(list_p%r_value)) deallocate(list_p%r_value)
if (associated(list_p%s_value)) deallocate(list_p%s_value)

end function  make_list  !}
! </FUNCTION> NAME="make_list"
!</PRIVATE>


!#######################################################################
!#######################################################################

! <FUNCTION NAME="fm_query_method">
!
! <OVERVIEW>
!    This is a function that provides the capability to return parameters 
!    associated with a field in a pair of strings.
! </OVERVIEW>
! <DESCRIPTION>
!    Given a name return a list of method names and control strings.
!    This function should return strings similar to those in the field
!    table if a comma delimited format is being used.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_query_method(name, method_name, method_control)
!   </TEMPLATE>
!
function fm_query_method(name, method_name, method_control)                &
          result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list that the user wishes to change to.
!   </IN>
!   <OUT NAME="method_name" TYPE="character(len=*)">
!     The name of a parameter associated with the named field.
!   </OUT>
!   <OUT NAME="method_control" TYPE="character(len=*)">
!     The value of parameters associated with the named field.
!   </OUT>
!
!        Function definition
!
logical                       :: success
!
!        arguments
!
character(len=*), intent(in)  :: name
character(len=*), intent(out) :: method_name
character(len=*), intent(out) :: method_control
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=15), parameter :: sub_name     = 'fm_query_method'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len) :: path
character(len=fm_path_name_len) :: base
character(len=fm_path_name_len) :: name_loc
logical                         :: recursive_t
type (field_def), pointer, save :: temp_list_p 
type (field_def), pointer, save :: temp_value_p 
type (field_def), pointer, save :: this_field_p 
integer                         :: out_unit

  out_unit = stdout()
  success     = .false.
  recursive_t = .true.
  method_name = " "
  method_control = " "
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}
name_loc = lowercase(name)
call find_base(name_loc, path, base)

  temp_list_p => find_list(name_loc, current_list_p, .false.)

if (associated(temp_list_p)) then
! Find the entry values for the list.
  success = query_method(temp_list_p, recursive_t, base, method_name, method_control)
else  !}{
! This is not a list but it may be a parameter with a value
! If so put the parameter value in method_name.

  temp_value_p => find_list(path, current_list_p, .false.)
  if (associated(temp_value_p)) then  !{
! Find the entry values for this item.
  this_field_p => temp_value_p%first_field

  do while (associated(this_field_p))  !{
    if ( this_field_p%name == base ) then !{
      method_name = this_field_p%s_value(1)
      method_control = ""
      success = .true.
      exit
    else !}{
      success = .false.
    endif !}
    this_field_p => this_field_p%next
  enddo

  else  !}{
!
!        Error following the path
!
    if (verb .gt. verb_level_warn) then
      write (out_unit,*) trim(warn_header), 'Could not follow path for ', trim(path)
    endif
    success = .false.
  endif  !}
endif  !}

end function  fm_query_method  !}
! </FUNCTION> NAME="fm_query_method"

!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME="query_method">
!
! <OVERVIEW>
!    A private function that can recursively recover values for parameters 
!    associated with a field.
! </OVERVIEW>
! <DESCRIPTION>
!    A private function that can recursively recover values for parameters 
!    associated with a field.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = query_method(list_p, recursive, name, method_name, method_control)
!   </TEMPLATE>
!
recursive function query_method(list_p, recursive, name, method_name, method_control) &
          result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="list_p" TYPE="type (field_def), pointer">
!     A pointer to the field that is of interest.
!   </IN>
!   <IN NAME="name" TYPE="character(len=*)">
!     The name of a list that the user wishes to change to.
!   </IN>
!   <OUT NAME="method_name" TYPE="character(len=*)">
!     The name of a parameter associated with the named field.
!   </OUT>
!   <OUT NAME="method_control" TYPE="character(len=*)">
!     The value of parameters associated with the named field.
!   </OUT>
!
!        Function definition
!
logical                       :: success
!
!        arguments
!
type (field_def), pointer     :: list_p
logical,          intent(in)  :: recursive
character(len=*), intent(in)  :: name
character(len=*), intent(out) :: method_name, method_control
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=12), parameter :: sub_name     = 'query_method'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
integer,                  parameter :: max_depth = 64
character(len=max_depth), parameter :: blank = '    '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: depthp1
integer                         :: first
integer                         :: i
integer                         :: last
character(len=64)               :: scratch
type (field_def), pointer :: this_field_p 
integer                         :: out_unit

out_unit = stdout()

!
!        Check for a valid list
!
if (.not. associated(list_p)) then  !{
  if (verb .gt. verb_level_warn) then
    write (out_unit,*) trim(warn_header), 'Invalid list pointer'
  endif
  success = .false.
elseif (list_p%field_type .ne. list_type) then  !}{
  if (verb .gt. verb_level_warn) then
    write (out_unit,*) trim(warn_header), trim(list_p%name)//' is not a list'
  endif
  success = .false.
else  !}{
!
!        set the default return value
!
  success = .true.

  this_field_p => list_p%first_field

  do while (associated(this_field_p))  !{
    select case(this_field_p%field_type)
    case(list_type)
!
!        If this is a list, then this is the method name
!
      if (recursive) then  !{
        if (.not. query_method(this_field_p, .true., this_field_p%name, method_name, method_control)) then  !{
          success = .false.
          exit
        else  !}{
          !write (method_name,'(a,a)') method_name(1:LEN_TRIM(method_name)), &
          i = LEN_TRIM(method_name)
          if ( i .gt. 0 ) then
            write (method_name,'(a,a)') method_name(1:i), &
                    trim(this_field_p%name)
          else
            write (method_name,'(a)') trim(this_field_p%name)
          endif        
        endif  !}
      endif  !}

    case(integer_type)
        write (scratch,*) this_field_p%i_value
        call strip_front_blanks(scratch)
        write (method_control,'(a,a,a,a,a)') trim(method_control),comma, &
                trim(this_field_p%name), ' = ', trim(scratch)


    case(logical_type)

        write (method_control,'(a,a,a,a,l1)') trim(method_control),comma, &
                trim(this_field_p%name), ' = ', this_field_p%l_value

    case(real_type)

        write (scratch,*) this_field_p%r_value
        call strip_front_blanks(scratch)
        write (method_control,'(a,a,a,a,a)') trim(method_control),comma, &
                trim(this_field_p%name), ' = ', trim(scratch)


    case(string_type)
        write (method_control,'(a,a,a,a,a,$)') trim(method_control),comma, &
                trim(this_field_p%name), ' = ',trim(this_field_p%s_value(1))
        do i = 2, this_field_p%max_index
          write (method_control,'(a,a,$)') comma//trim(this_field_p%s_value(i))
        enddo


    case default
        if (verb .gt. verb_level_warn) then
          write (out_unit,*) trim(warn_header), 'Undefined type for ', trim(this_field_p%name)
        endif
        success = .false.
        exit

    end select 
    this_field_p => this_field_p%next
  enddo  !}
endif  !}

end function query_method  !}
! </FUNCTION> NAME="query_method"
!</PRIVATE>

!#######################################################################
!#######################################################################

! <FUNCTION NAME = "fm_copy_list" >
! <OVERVIEW>
!    A function that allows the user to copy a field and add a suffix to 
!    the name of the new field.
! </OVERVIEW>
! <DESCRIPTION>
!    Given the name of a pre-existing field and a suffix, this function
!    will create a new field. The name of the new field will be that of 
!    the old field with a suffix supplied by the user.
! </DESCRIPTION>
!   <TEMPLATE>
!     index = fm_copy_list(list_name, suffix, create)
!   </TEMPLATE>
!
function fm_copy_list(list_name, suffix, create ) &
         result(index)   !{
!   <OUT NAME="index" TYPE="integer">
!     The index of the field that has been created by the copy.
!   </OUT>
!   <IN NAME="list_name" TYPE="character(len=*)">
!     The name of a field that the user wishes to copy..
!   </IN>
!   <IN NAME="suffix" TYPE="character(len=*)">
!     The suffix that will be added to list_name when the field is copied.
!   </IN>
!
!        Function definition
!
integer        :: index
!
!        arguments
!
character(len=*), intent(in)           :: list_name
character(len=*), intent(in)           :: suffix
logical,          intent(in), optional :: create

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=12), parameter :: sub_name     = 'fm_copy_list'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_string_len), dimension(MAX_FIELD_METHODS) :: control
character(len=fm_string_len), dimension(MAX_FIELD_METHODS) :: method
character(len=fm_string_len)                               :: head
character(len=fm_string_len)                               :: list_name_new
character(len=fm_string_len)                               :: tail
character(len=fm_string_len)                               :: val_str
integer                                                    :: n
integer                                                    :: num_meth
integer                                                    :: val_int
logical                                                    :: found_methods
logical                                                    :: got_value
logical                                                    :: recursive_t
logical                                                    :: success
logical                                                    :: val_logical
real                                                       :: val_real
type (field_def), pointer, save                            :: temp_field_p 
type (field_def), pointer, save                            :: temp_list_p 
integer                                                    :: out_unit

out_unit = stdout()


num_meth= 1
list_name_new = trim(list_name)//trim(suffix)
!
  recursive_t = .true.
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}

if (list_name .eq. ' ') then  !{
!
!        If list is empty, then dump the current list
!
  temp_list_p => current_list_p
  success = .true.
else  !}{
!
!        Get a pointer to the list
!
  temp_list_p => find_list(list_name, current_list_p, .false.)
  if (associated(temp_list_p)) then  !{
    success = .true.
  else  !}{
!
!        Error following the path
!
    if (verb .gt. verb_level_warn) then
      write (out_unit,*) trim(warn_header), 'Could not follow path for ', trim(list_name)
    endif
    success = .false.
  endif  !}
endif  !}

!
!        Find the list
!
if (success) then  !{
  method(:) = ' '
  control(:) = ' '
  found_methods = fm_find_methods(trim(list_name), method, control)
  do n = 1, MAX_FIELD_METHODS
    if (LEN_TRIM(method(n)) > 0 ) then
      index = fm_new_list(trim(list_name_new)//list_sep//method(n), create = create)
      call find_base(method(n), head, tail)
      temp_field_p => find_list(trim(list_name)//list_sep//head,temp_list_p, .false.)
      temp_field_p => find_field(tail,temp_field_p)
      select case (temp_field_p%field_type)
        case (integer_type)
          got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_int)
          if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_int, &
                             create = create, append = .true.) < 0 ) &
            call mpp_error(FATAL, trim(error_header)//'Could not set the '//trim(method(n))//&
                                  ' for '//trim(list_name)//trim(suffix))
  
        case (logical_type)
          got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_logical)
          if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_logical, &
                             create = create, append = .true.) < 0 ) &
            call mpp_error(FATAL, trim(error_header)//'Could not set the '//trim(method(n))//&
                                  ' for '//trim(list_name)//trim(suffix))
  
        case (real_type)
          got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_real)
          if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_real, &
                             create = create, append = .true.) < 0 ) &
            call mpp_error(FATAL, trim(error_header)//'Could not set the '//trim(method(n))//&
                                  ' for '//trim(list_name)//trim(suffix))
  
        case (string_type)
          got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_str)
          if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_str, &
                             create = create, append = .true.) < 0 ) &
            call mpp_error(FATAL, trim(error_header)//'Could not set the '//trim(method(n))//&
                                  ' for '//trim(list_name)//trim(suffix))
        case default
      end select
  
    endif
  enddo
endif  !}

end function fm_copy_list !}         
! </FUNCTION > NAME = "fm_copy_list"

!#######################################################################
!#######################################################################

! <FUNCTION NAME = "fm_find_methods" >
! <OVERVIEW>
!    This function retrieves all the methods associated with a field.
! </OVERVIEW>
! <DESCRIPTION>
!    This function retrieves all the methods associated with a field.
!    This is different from fm_query_method in that this function gets all
!    the methods associated as opposed to 1 method.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = fm_find_methods(list_name, methods, control )
!   </TEMPLATE>
!
function fm_find_methods(list_name, methods, control ) &
         result(success)   !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="list_name" TYPE="character(len=*)">
!     The name of a list that the user wishes to find methods for.
!   </IN>
!   <OUT NAME="methods" TYPE="character(len=*)">
!     An array of the methods associated with list_name.
!   </OUT>
!   <OUT NAME="control" TYPE="character(len=*)">
!     An array of the parameters associated with methods.
!   </OUT>
!
!        Function definition
!
logical                                     :: success
!
!        arguments
!
character(len=*), intent(in)                :: list_name
character(len=*), intent(out), dimension(:) :: methods
character(len=*), intent(out), dimension(:) :: control

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=15), parameter :: sub_name     = 'fm_find_methods'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: num_meth
logical                         :: recursive_t
type (field_def), pointer, save :: temp_list_p 
integer                         :: out_unit

out_unit = stdout()
num_meth= 1
!
!        Check whether to do things recursively
!
  recursive_t = .true.
!  recursive_t = .false.
!
!        Initialize the field manager if needed
!
if (.not. module_is_initialized) then  !{
  call initialize
endif  !}

if (list_name .eq. ' ') then  !{
!
!        If list is empty, then dump the current list
!
  temp_list_p => current_list_p
  success = .true.
else  !}{
!
!        Get a pointer to the list
!
  temp_list_p => find_list(list_name, current_list_p, .false.)
  if (associated(temp_list_p)) then  !{
    success = .true.
  else  !}{
!
!        Error following the path
!
    if (verb .gt. verb_level_warn) then
      write (out_unit,*) trim(warn_header), 'Could not follow path for ', trim(list_name)
    endif
    success = .false.
  endif  !}
endif  !}

!
!        Find the list
!
if (success) then  !{
  success = find_method(temp_list_p, recursive_t, num_meth, methods, control)
endif  !}

end function fm_find_methods !}         
! </FUNCTION > NAME = "fm_find_methods"

!#######################################################################
!#######################################################################

! <PRIVATE><FUNCTION NAME = "find_method">
!
! <OVERVIEW>
!    Given a field list pointer this function retrieves methods and 
!    associated parameters for the field list.
! </OVERVIEW>
! <DESCRIPTION>
!    Given a field list pointer this function retrieves methods and 
!    associated parameters for the field list.
! </DESCRIPTION>
!   <TEMPLATE>
!     success = find_method(list_p, recursive, num_meth, method, control)
!   </TEMPLATE>
!
recursive function find_method(list_p, recursive, num_meth, method, control)   &
          result (success)  !{
!   <OUT NAME="success" TYPE="logical">
!     A flag to indicate whether the function operated with (FALSE) or 
!     without (TRUE) errors.
!   </OUT>
!   <IN NAME="list_p" TYPE="type (field_def), pointer">
!     A pointer to the field of interest
!   </IN>
!   <IN NAME="recursive" TYPE="logical">
!     If true, then recursively search for methods.
!   </IN>
!   <INOUT NAME="num_meth" TYPE="integer">
!     The number of methods found.
!   </INOUT>
!   <OUT NAME="method" TYPE="character(len=*)" DIM="(:)">
!     The methods associated with the field pointed to by list_p
!   </OUT>
!   <OUT NAME="control" TYPE="character(len=*)" DIM="(:)">
!     The control parameters for the methods found.
!   </OUT>
!
!        Function definition
!
logical                                     :: success
!
!        arguments
!
type (field_def), pointer                   :: list_p
logical,          intent(in)                :: recursive
integer,          intent(inout)             :: num_meth
character(len=*), intent(out), dimension(:) :: method
character(len=*), intent(out), dimension(:) :: control
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=11), parameter :: sub_name     = 'find_method'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer, parameter                          :: max_depth = 64
character(len=max_depth), parameter         :: blank = '    '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
character(len=fm_path_name_len) :: scratch
integer                         :: depthp1
integer                         :: first
integer                         :: i
integer                         :: last
integer                         :: n
type (field_def), pointer, save :: this_field_p 
integer                         :: out_unit

out_unit = stdout()
!
!        Check for a valid list
!
if (.not. associated(list_p)) then  !{
  if (verb .gt. verb_level_warn) then
    write (out_unit,*) trim(warn_header), 'Invalid list pointer'
  endif
  success = .false.
elseif (list_p%field_type .ne. list_type) then  !}{
  if (verb .gt. verb_level_warn) then
    write (out_unit,*) trim(warn_header), trim(list_p%name), ' is not a list'
  endif
  success = .false.
else  !}{
!
!        set the default return value
!
  success = .true.

  this_field_p => list_p%first_field

  do while (associated(this_field_p))  !{
    select case(this_field_p%field_type)
    case(list_type)
!
!        If this is a list, then this is the method name
!
        if ( this_field_p%length > 1) then
           do n = num_meth+1, num_meth + this_field_p%length - 1
              write (method(n),'(a,a,a,$)') trim(method(num_meth)), &
                                            trim(this_field_p%name), list_sep
           enddo
           write (method(num_meth),'(a,a,a,$)') trim(method(num_meth)), &
                                                trim(this_field_p%name), list_sep
        else
           write (method(num_meth),'(a,a,a,$)') trim(method(num_meth)), &
                                                trim(this_field_p%name), list_sep
        endif
        success = find_method(this_field_p, .true., num_meth, method, control)

    case(integer_type)
        write (scratch,*) this_field_p%i_value
        call strip_front_blanks(scratch)
        write (method(num_meth),'(a,a)') trim(method(num_meth)), &
                trim(this_field_p%name)
        write (control(num_meth),'(a)') &
                trim(scratch)
        num_meth = num_meth + 1


    case(logical_type)

        write (method(num_meth),'(a,a)') trim(method(num_meth)), &
                trim(this_field_p%name)
        write (control(num_meth),'(l1)') &
                this_field_p%l_value
        num_meth = num_meth + 1

    case(real_type)

        write (scratch,*) this_field_p%r_value
        call strip_front_blanks(scratch)
        write (method(num_meth),'(a,a)') trim(method(num_meth)), &
                trim(this_field_p%name)
        write (control(num_meth),'(a)') &
                trim(scratch)
        num_meth = num_meth + 1


    case(string_type)
        write (method(num_meth),'(a,a)') trim(method(num_meth)), &
                trim(this_field_p%name)
        write (control(num_meth),'(a)') &
                 trim(this_field_p%s_value(1))
        do i = 2, this_field_p%max_index
          write (control(num_meth),'(a,a,$)') comma//trim(this_field_p%s_value(i))
        enddo
        num_meth = num_meth + 1


    case default
        if (verb .gt. verb_level_warn) then
          write (out_unit,*) trim(warn_header), 'Undefined type for ', trim(this_field_p%name)
        endif
        success = .false.
        exit

    end select 

    this_field_p => this_field_p%next
  enddo  !}
endif  !}

end function find_method !}
! </FUNCTION > NAME = "find_method"
!</PRIVATE>

!#######################################################################
! <SUBROUTINE NAME="fm_set_verbosity">
!
! <OVERVIEW>
!   A subroutine to set the verbosity of the field manager output.
! </OVERVIEW>
! <DESCRIPTION>
!   This subroutine will set the level of verbosity in the module.
!   Currently, verbosity is either on (1) or off (0). However,
!   in the future, "on" may have more granularity. If no argument
!   is given, then, if verbosity is on it will be turned off, and
!   is off, will be turned to the default on level.
!   If verbosity is negative then it is turned off.
!   Values greater than the maximum will be set to the maximum.
! </DESCRIPTION>
!   <TEMPLATE>
!     call fm_set_verbosity(verbosity)
!   </TEMPLATE>
!
subroutine  fm_set_verbosity(verbosity)  !{
!   <IN NAME="verbosity" TYPE="integer, optional">
!     The level of verbosity required by the user.
!   </IN>
!
!       arguments
!

integer, intent(in), optional :: verbosity

!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!       local parameters
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

character(len=16), parameter :: sub_name     = 'fm_set_verbosity'
character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name)   //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: warn_header  = '==>Warning from ' // trim(module_name) //  &
                                               '(' // trim(sub_name) // '): '
character(len=64), parameter :: note_header  = '==>Note from ' // trim(module_name)    //  &
                                               '(' // trim(sub_name) // '): '
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!        local variables
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
integer                         :: out_unit

out_unit = stdout()

!
!       Check whether an argument has been given
!

if (present(verbosity)) then  !{

  if (verbosity .le. 0) then  !{
    verb = 0
  elseif (verbosity .ge. max_verbosity) then  !}{
    verb = max_verbosity
  else  !}{
    verb = verbosity
  endif  !}

else  !}{

  if (verb .eq. 0) then  !{
    verb = default_verbosity
  else  !}{
    verb = 0
  endif  !}

endif  !}

write (out_unit,*) 
write (out_unit,*) trim(note_header),                          &
     'Verbosity now at level ', verb
write (out_unit,*) 

end subroutine  fm_set_verbosity  !}
! </SUBROUTINE> NAME="fm_set_verbosity"

end module field_manager_mod

#ifdef test_field_manager

program test

use field_manager_mod
use mpp_mod, only : mpp_exit, mpp_pe, mpp_root_pe, mpp_error, NOTE

implicit none
!#include "mpif.h"


integer :: i, j, nfields, num_methods, model
character(len=fm_string_len) :: field_type, field_name, str, name_field_type, path
character(len=512) :: method_name, method_control
real :: param
integer :: flag, index
logical :: success
type(method_type), dimension(20) :: methods

call field_manager_init(nfields)

! Dump the list of fields produced from reading the field_table

! Here are the lists that propagate off the root "/"
! By calling fm_dump_list with a single argument you only get the 
! lists branching off this argument in the list.
write(*,*) "Here's a baseline listing"
success = fm_dump_list("/")
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

! By adding the optional .true. argument you get a recursive listing of the fields.
write(*,*) "Here's a recursive listing"
success = fm_dump_list("/", .true.)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

! Using fm_dump_list with a blank first argument returns the last field accessed by field manager.
write(*,*) 'Dumping last field changed to by field_manager using fm_change_list'
success = fm_dump_list("", .true.)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

! Change list to look at the land model fields
write(*,*) 'Changing list to land_mod'
success = fm_change_list("/land_mod")
write(*,*) 'Dumping last list changed to by field_manager using fm_change_list i.e list of land model fields'
success = fm_dump_list("", .true.)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

! Now let's modify some of the field entries.
! 
!In this example we add a field ( convection = 'off' ) to the radon list
write(*,*) "ADDING convection = off TO RADON LIST"
!if ( fm_change_list('/atmos_mod/tracer/radon')) then
if ( fm_exists('/atmos_mod/tracer/radon')) then
   write(*,*) "'/atmos_mod/tracer/radon' exists "
   success = fm_change_list('/atmos_mod/tracer/radon')
! The next line creates a new field branching off radon.
   index = fm_new_value('convection','off')
endif

success = fm_query_method('radon',method_name,method_control)
if (success ) then
call mpp_error(NOTE, "Method names for radon is/are "//trim(method_name))
call mpp_error(NOTE, "Method controls for radon is/are "//trim(method_control))
else
call mpp_error(NOTE, "There is no atmos model radon field defined in the field_table")
endif
! Dump the listing of the modified tracer
success = fm_dump_list("/atmos_mod/tracer/radon", .true.)
if (.not. success ) call mpp_error(NOTE, "There is no atmos model radon field defined in the field_table")
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'


! Find out what the current path is. Should be '/atmos_mod/tracer/radon' as set in fm_change_list above.
path = fm_get_current_list()
write(*,*) 'Current path is ',trim(path)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

! Now let's modify the value of the field we just added.
write(*,*) "MODIFYING RADON FIELD CONVECTION ATTRIBUTE TO convection = RAS_off "
index = fm_new_value('convection','RAS_off')

! Dump the listing of the modified tracer
success = fm_dump_list("/atmos_mod/tracer/radon", .true.)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'





write(*,*) "ORIGINAL OCEAN MODEL TRACER FIELDS"

! Dump the listing of the original ocean model tracers
success = fm_dump_list("/ocean_mod/tracer", .true.)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'


index = fm_get_length("/ocean_mod/tracer") 
write(*,*) "The length of the current list '/ocean_mod/tracer' is ",index," i.e."
success = fm_dump_list("/ocean_mod/tracer")
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

! Find out what type of field this is. Possibilities are real, integer, string, logical, and list
name_field_type = fm_get_type('/ocean_mod/tracer/biotic1/diff_horiz/linear/slope')
write(*,*) 'The type for /ocean_mod/tracer/biotic1/diff_horiz/linear/slope is ',name_field_type

success = fm_get_value('/ocean_mod/tracer/biotic1/diff_horiz/linear/slope',str)
write(*,*) 'The value for /ocean_mod/tracer/biotic1/diff_horiz/linear/slope is (character) ',str


write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

write(*,*) "MODIFYING BIOTIC1 FIELD slope ATTRIBUTE TO slope = 0.95 "
if ( fm_change_list('/ocean_mod/tracer/biotic1/diff_horiz/linear')) &
   index = fm_new_value('slope',0.95, index = 1)

! Dump the listing of the modified ocean model tracer attribute
success = fm_dump_list("/ocean_mod/tracer/biotic1", .true.)
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

name_field_type = fm_get_type('/ocean_mod/tracer/biotic1/diff_horiz/linear/slope')
write(*,*) 'Now the type for /ocean_mod/tracer/biotic1/diff_horiz/linear/slope is ',name_field_type
success =  fm_get_value('/ocean_mod/tracer/biotic1/diff_horiz/linear/slope',param)
write(*,*) 'The value for /ocean_mod/tracer/biotic1/diff_horiz/linear/slope is (real) ',param
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'

write(*,*) 'Changing the name of biotic1 to biotic_control'
success = fm_modify_name('/ocean_mod/tracer/biotic1', 'biotic_control')

! Dump the listing of the modified tracer
success = fm_dump_list("/ocean_mod/tracer/biotic_control", .true.)

! Double check to show that the tracer has been renamed and the original doesn't exist anymore. 
success = fm_dump_list("/ocean_mod/tracer/biotic1", .true.)
if (.not. success ) call mpp_error(NOTE, "Ocean model tracer biotic1 does not exist anymore.")
write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'


if ( fm_change_list("/ocean_mod/tracer/age_ctl") ) then
success = fm_dump_list("", .true.)
write(*,*) "Now we'll add a new list to this list"
index = fm_new_list("units",create = .true.)

success = fm_dump_list("", .true.)

write(*,*) "Now we'll give it a value"
if (success) index = fm_new_value('units','days')

success = fm_dump_list("", .true.)


write(*,*) '+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+'
endif
!errorcode = 121
!CALL MPI_ERROR_STRING(errorcode, string, resultlen, ierror)
!write(*,*) string
call field_manager_end

call mpp_exit

end program test

#endif


module fm_util_mod  !{
! 
!<CONTACT EMAIL="Richard.Slater@noaa.gov"> Richard D. Slater
!</CONTACT>
!
!<REVIEWER EMAIL="John.Dunne@noaa.gov"> John P. Dunne
!</REVIEWER>
!
!<OVERVIEW>
! Utility routines for the field manager
!</OVERVIEW>
!
!<DESCRIPTION>
! This module provides utility routines for the field manager.
! Basically, it provides for error catching, reporting and
! termination while interfacing with the field manager.
!</DESCRIPTION>
!
! <INFO>
! </INFO>
!

use field_manager_mod, only: fm_string_len, fm_path_name_len, fm_field_name_len, fm_type_name_len
use field_manager_mod, only: fm_get_type, fm_get_index, fm_get_length
use field_manager_mod, only: fm_get_current_list, fm_new_list, fm_change_list, fm_loop_over_list
use field_manager_mod, only: fm_new_value, fm_get_value
use field_manager_mod, only: fm_exists, fm_dump_list
use fms_mod,           only: FATAL, stdout
use mpp_mod,           only: mpp_error

implicit none

private

public  fm_util_start_namelist
public  fm_util_end_namelist
public  fm_util_check_for_bad_fields
public  fm_util_set_caller
public  fm_util_reset_caller
public  fm_util_set_no_overwrite
public  fm_util_reset_no_overwrite
public  fm_util_set_good_name_list
public  fm_util_reset_good_name_list
public  fm_util_get_length
public  fm_util_get_integer
public  fm_util_get_logical
public  fm_util_get_real
public  fm_util_get_string
public  fm_util_get_integer_array
public  fm_util_get_logical_array
public  fm_util_get_real_array
public  fm_util_get_string_array
public  fm_util_set_value
public  fm_util_set_value_integer_array
public  fm_util_set_value_logical_array
public  fm_util_set_value_real_array
public  fm_util_set_value_string_array
public  fm_util_set_value_integer
public  fm_util_set_value_logical
public  fm_util_set_value_real
public  fm_util_set_value_string
!public  fm_util_get_index
public  fm_util_get_index_list
public  fm_util_get_index_string

!
!       Public variables
!

character(len=128), public      :: fm_util_default_caller = ' '

!
!       private parameters
!

character(len=48), parameter    :: mod_name = 'fm_util_mod'

!
!       Private variables
!

character(len=128)              :: save_default_caller = ' '
character(len=128)              :: default_good_name_list = ' '
character(len=128)              :: save_default_good_name_list = ' '
logical                         :: default_no_overwrite = .false.
logical                         :: save_default_no_overwrite = .false.
character(len=fm_path_name_len) :: save_current_list
character(len=fm_path_name_len) :: save_path
character(len=fm_path_name_len) :: save_name
character(len=128) :: version = '$Id: fm_util.F90,v 17.0 2009/07/21 03:19:16 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

!
!        Interface definitions for overloaded routines
!

!interface  fm_util_get_value  !{
  !module procedure  fm_util_get_value_integer
  !module procedure  fm_util_get_value_logical
  !module procedure  fm_util_get_value_real
  !module procedure  fm_util_get_value_string
  !module procedure  fm_util_get_value_integer_array
  !module procedure  fm_util_get_value_logical_array
  !module procedure  fm_util_get_value_real_array
  !module procedure  fm_util_get_value_string_array
!end interface  !}

interface  fm_util_set_value  !{
  module procedure  fm_util_set_value_integer_array
  module procedure  fm_util_set_value_logical_array
  module procedure  fm_util_set_value_real_array
  module procedure  fm_util_set_value_string_array
  module procedure  fm_util_set_value_integer
  module procedure  fm_util_set_value_logical
  module procedure  fm_util_set_value_real
  module procedure  fm_util_set_value_string
end interface  !}

!interface  fm_util_get_index  !{
  !module procedure  fm_util_get_index_list
  !module procedure  fm_util_get_index_string
!end interface  !}


contains


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_caller">
!
! <DESCRIPTION>
! Set the default value for the optional "caller" variable used in many of these
! subroutines. If the argument is blank, then set the default to blank, otherwise
! the deault will have brackets placed around the argument.
!
! </DESCRIPTION>
!

subroutine fm_util_set_caller(caller)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)          :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_set_caller'

!
!       Local variables
!

!
!       save the default caller string
!

save_default_caller = fm_util_default_caller

!
!       set the default caller string
!

if (caller .eq. ' ') then  !{
  fm_util_default_caller = ' '
else  !}{
  fm_util_default_caller = '[' // trim(caller) // ']'
endif  !}

return

end subroutine fm_util_set_caller  !}
! </SUBROUTINE> NAME="fm_util_set_caller"


!#######################################################################
! <SUBROUTINE NAME="fm_util_reset_caller">
!
! <DESCRIPTION>
! Reset the default value for the optional "caller" variable used in many of these
! subroutines to blank.
!
! </DESCRIPTION>
!

subroutine fm_util_reset_caller  !{

implicit none

!
!       arguments
!

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_reset_caller'

!
!       Local variables
!

!
!       reset the default caller string
!

fm_util_default_caller = save_default_caller
save_default_caller = ' '

return

end subroutine fm_util_reset_caller  !}
! </SUBROUTINE> NAME="fm_util_reset_caller"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_good_name_list">
!
! <DESCRIPTION>
! Set the default value for the optional "good_name_list" variable used in many of these
! subroutines.
!
! </DESCRIPTION>
!

subroutine fm_util_set_good_name_list(good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)          :: good_name_list

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_set_good_name_list'

!
!       Local variables
!

!
!       save the default good_name_list string
!

save_default_good_name_list = default_good_name_list

!
!       set the default good_name_list string
!

default_good_name_list = good_name_list

return

end subroutine fm_util_set_good_name_list  !}
! </SUBROUTINE> NAME="fm_util_set_good_name_list"


!#######################################################################
! <SUBROUTINE NAME="fm_util_reset_good_name_list">
!
! <DESCRIPTION>
! Reset the default value for the optional "good_name_list" variable used in many of these
! subroutines to the saved value.
!
! </DESCRIPTION>
!

subroutine fm_util_reset_good_name_list  !{

implicit none

!
!       arguments
!

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_reset_good_name_list'

!
!       Local variables
!

!
!       reset the default good_name_list string
!

default_good_name_list = save_default_good_name_list
save_default_good_name_list = ' '

return

end subroutine fm_util_reset_good_name_list  !}
! </SUBROUTINE> NAME="fm_util_reset_good_name_list"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_no_overwrite">
!
! <DESCRIPTION>
! Set the default value for the optional "no_overwrite" variable used in some of these
! subroutines.
!
! </DESCRIPTION>
!

subroutine fm_util_set_no_overwrite(no_overwrite)  !{

implicit none

!
!       arguments
!

logical, intent(in)          :: no_overwrite

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_set_no_overwrite'

!
!       Local variables
!

!
!       save the default no_overwrite string
!

save_default_no_overwrite = default_no_overwrite

!
!       set the default no_overwrite value
!

default_no_overwrite = no_overwrite

return

end subroutine fm_util_set_no_overwrite  !}
! </SUBROUTINE> NAME="fm_util_set_no_overwrite"


!#######################################################################
! <SUBROUTINE NAME="fm_util_reset_no_overwrite">
!
! <DESCRIPTION>
! Reset the default value for the optional "no_overwrite" variable used in some of these
! subroutines to false.
!
! </DESCRIPTION>
!

subroutine fm_util_reset_no_overwrite  !{

implicit none

!
!       arguments
!

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_reset_no_overwrite'

!
!       Local variables
!

!
!       reset the default no_overwrite value
!

default_no_overwrite = save_default_no_overwrite
save_default_no_overwrite = .false.

return

end subroutine fm_util_reset_no_overwrite  !}
! </SUBROUTINE> NAME="fm_util_reset_no_overwrite"


!#######################################################################
! <SUBROUTINE NAME="fm_util_check_for_bad_fields">
!
! <DESCRIPTION>
! Check for unrecognized fields in a list
!
! </DESCRIPTION>
!

subroutine fm_util_check_for_bad_fields(list, good_fields, caller)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)                    :: list
character(len=*), intent(in), dimension(:)      :: good_fields
character(len=*), intent(in), optional          :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_check_for_bad_fields'

!
!       Local variables
!

logical                                 :: fm_success
integer                                 :: i
integer                                 :: ind
integer                                 :: list_length
integer                                 :: good_length
character(len=fm_type_name_len)         :: typ
character(len=fm_field_name_len)        :: name
logical                                 :: found
character(len=256)                      :: error_header
character(len=256)                      :: warn_header
character(len=256)                      :: note_header
character(len=128)                      :: caller_str
integer                         :: out_unit

out_unit = stdout()

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a list is given (fatal if not)
!

if (list .eq. ' ') then  !{
  write (out_unit,*) trim(error_header) // ' Empty list given'
  call mpp_error(FATAL, trim(error_header) // ' Empty list given')
endif  !}

!
!       Check that we have been given a list
!

if (fm_get_type(list) .ne. 'list') then  !{
  write (out_unit,*) trim(error_header) // ' Not given a list: ' // trim(list)
  call mpp_error(FATAL, trim(error_header) // ' Not given a list: ' // trim(list))
endif  !}

!
!       Get the list length
!

list_length = fm_get_length(list)
if (list_length .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(list))
endif  !}

!
!       Get the number of good fields
!

good_length = size(good_fields)

if (list_length .lt. good_length) then  !{

!
!       If the list length is less than the number of good fields this is an error 
!       as the list should be fully populated and we'll check which extra fields
!       are given in good_fields
!

  write (out_unit,*) trim(error_header), ' List length < number of good fields (',       &
       list_length, ' < ', good_length, ') in list ', trim(list)

  write (out_unit,*)
  write (out_unit,*) 'The list contains the following fields:'
  fm_success= fm_dump_list(list, .false.)
  write (out_unit,*)
  write (out_unit,*) 'The supposed list of good fields is:'
  do i = 1, good_length  !{
    if (fm_exists(trim(list) // '/' // good_fields(i))) then  !{
      write (out_unit,*) 'List field: "', trim(good_fields(i)), '"'
    else  !}{
      write (out_unit,*) 'EXTRA good field: "', trim(good_fields(i)), '"'
    endif  !}
  enddo  !} i
  write (out_unit,*)

  call mpp_error(FATAL, trim(error_header) //                                           &
       ' List length < number of good fields for list: ' // trim(list))

elseif (list_length .gt. good_length) then  !}{

!
!       If the list length is greater than the number of good fields this is an error
!       as the there should not be any more fields than those given in the good fields list
!       and we'll check which extra fields are given in the list
!

  write (out_unit,*) trim(warn_header), 'List length > number of good fields (',        &
       list_length, ' > ', good_length, ') in list ', trim(list)

  write (out_unit,*) trim(error_header), ' Start of list of fields'
  do while (fm_loop_over_list(list, name, typ, ind))  !{
    found = .false.
    do i = 1, good_length  !{
      found = found .or. (name .eq. good_fields(i))
    enddo  !} i
    if (found) then  !{
      write (out_unit,*) 'Good list field: "', trim(name), '"'
    else  !}{
      write (out_unit,*) 'EXTRA list field: "', trim(name), '"'
    endif  !}
  enddo  !}
  write (out_unit,*) trim(error_header), ' End of list of fields'

  call mpp_error(FATAL, trim(error_header) //                                           &
       ' List length > number of good fields for list: ' // trim(list))

endif  !}

!
!       If the list length equals the number of good fields then all is good
!

return

end subroutine fm_util_check_for_bad_fields  !}
! </SUBROUTINE> NAME="fm_util_check_for_bad_fields"


!#######################################################################
! <FUNCTION NAME="fm_util_get_length">
!
! <DESCRIPTION>
! Get the length of an element of the Field Manager tree
! </DESCRIPTION>
!
function fm_util_get_length(name, caller)       &
         result (field_length)  !{

implicit none

!
!       Return type
!

integer :: field_length

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_length'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Get the field's length
!

field_length = fm_get_length(name)
if (field_length .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
endif  !}

return

end function fm_util_get_length  !}
! </FUNCTION> NAME="fm_util_get_length"


!#######################################################################
! <FUNCTION NAME="fm_util_get_index_string">
!
! <DESCRIPTION>
! Get the index of an element of a string in the Field Manager tree
! </DESCRIPTION>
!
function fm_util_get_index_string(name, string, caller)       &
         result (fm_index)  !{

implicit none

!
!       Return type
!

integer :: fm_index

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in)            :: string
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_index_string'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: index_str
character(len=fm_type_name_len) :: fm_type
character(len=fm_string_len)    :: fm_string
integer                         :: i
integer                         :: length

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check the field's type and get the index
!

fm_index = 0
fm_type = fm_get_type(name)
if (fm_type .eq. 'string') then  !{
  length = fm_get_length(name)
  if (length .lt. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
  endif  !}
  if (length .gt. 0) then  !{
    do i = 1, length  !{
      if (.not. fm_get_value(name, fm_string, index = i)) then  !{
        write (index_str,*) '(', i, ')'
        call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
      endif  !}
      if (fm_string .eq. string) then  !{
        fm_index = i
        exit
      endif  !}
    enddo  !} i
  endif  !}
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

!if (fm_index .eq. 0) then  !{
  !call mpp_error(FATAL, trim(error_header) // ' "' // trim(string) // '" does not exist in ' // trim(name))
!endif  !}

return

end function fm_util_get_index_string  !}
! </FUNCTION> NAME="fm_util_get_index_string"


!#######################################################################
! <FUNCTION NAME="fm_util_get_index_list">
!
! <DESCRIPTION>
! Get the length of an element of the Field Manager tree
! </DESCRIPTION>
!
function fm_util_get_index_list(name, caller)       &
         result (fm_index)  !{

implicit none

!
!       Return type
!

integer :: fm_index

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_index_list'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=fm_type_name_len) :: fm_type

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check the field's type and get the index
!

fm_index = 0
fm_type = fm_get_type(name)
if (fm_type .eq. 'list') then  !{
  fm_index = fm_get_index(name)
  if (fm_index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' List does not exist: ' // trim(name))
  endif  !}
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' List does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}


return

end function fm_util_get_index_list  !}
! </FUNCTION> NAME="fm_util_get_index_list"


!#######################################################################
! <FUNCTION NAME="fm_util_get_integer_array">
!
! <DESCRIPTION>
! Get an integer value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_integer_array(name, caller)            &
         result (array)  !{

implicit none

!
!       Return type
!

integer, pointer, dimension(:) :: array

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_integer_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: index_str
character(len=fm_type_name_len) :: fm_type
integer                         :: i
integer                         :: length

nullify(array)

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'integer') then  !{
  length = fm_get_length(name)
  if (length .lt. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
  endif  !}
  if (length .gt. 0) then  !{
    allocate(array(length))
    do i = 1, length  !{
      if (.not. fm_get_value(name, array(i), index = i)) then  !{
        write (index_str,*) '(', i, ')'
        call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
      endif  !}
    enddo  !} i
  endif  !}
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_integer_array  !}
! </FUNCTION> NAME="fm_util_get_integer_array"


!#######################################################################
! <FUNCTION NAME="fm_util_get_logical_array">
!
! <DESCRIPTION>
! Get a logical value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_logical_array(name, caller)            &
         result (array)  !{

implicit none

!
!       Return type
!

logical, pointer, dimension(:) :: array

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_logical_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: index_str
character(len=fm_type_name_len) :: fm_type
integer                         :: i
integer                         :: length

nullify(array)

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'logical') then  !{
  length = fm_get_length(name)
  if (length .lt. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
  endif  !}
  if (length .gt. 0) then  !{
    allocate(array(length))
    do i = 1, length  !{
      if (.not. fm_get_value(name, array(i), index = i)) then  !{
        write (index_str,*) '(', i, ')'
        call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
      endif  !}
    enddo  !} i
  endif  !}
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_logical_array  !}
! </FUNCTION> NAME="fm_util_get_logical_array"


!#######################################################################
! <FUNCTION NAME="fm_util_get_real_array">
!
! <DESCRIPTION>
! Get a real value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_real_array(name, caller)            &
         result (array)  !{

implicit none

!
!       Return type
!

real, pointer, dimension(:) :: array

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_real_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: index_str
character(len=fm_type_name_len) :: fm_type
integer                         :: i
integer                         :: length

nullify(array)

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'real') then  !{
  length = fm_get_length(name)
  if (length .lt. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
  endif  !}
  if (length .gt. 0) then  !{
    allocate(array(length))
    do i = 1, length  !{
      if (.not. fm_get_value(name, array(i), index = i)) then  !{
        write (index_str,*) '(', i, ')'
        call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
      endif  !}
    enddo  !} i
  endif  !}
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_real_array  !}
! </FUNCTION> NAME="fm_util_get_real_array"


!#######################################################################
! <FUNCTION NAME="fm_util_get_string_array">
!
! <DESCRIPTION>
! Get a string value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_string_array(name, caller)            &
         result (array)  !{

implicit none

!
!       Return type
!

character(len=fm_string_len), pointer, dimension(:) :: array

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_string_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: index_str
character(len=fm_type_name_len) :: fm_type
integer                         :: i
integer                         :: length

nullify(array)

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'string') then  !{
  length = fm_get_length(name)
  if (length .lt. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
  endif  !}
  if (length .gt. 0) then  !{
    allocate(array(length))
    do i = 1, length  !{
      if (.not. fm_get_value(name, array(i), index = i)) then  !{
        write (index_str,*) '(', i, ')'
        call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
      endif  !}
    enddo  !} i
  endif  !}
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_string_array  !}
! </FUNCTION> NAME="fm_util_get_string_array"


!#######################################################################
! <FUNCTION NAME="fm_util_get_integer">
!
! <DESCRIPTION>
! Get an integer value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_integer(name, caller, index, default_value, scalar)            &
         result (value)  !{

implicit none

!
!       Return type
!

integer :: value

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
integer, intent(in), optional           :: default_value
logical, intent(in), optional           :: scalar

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_integer'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
integer                         :: index_t
character(len=fm_type_name_len) :: fm_type
integer                         :: field_length

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check whether we require a scalar (length=1) and return
!       an error if we do, and it isn't
!

if (present(scalar)) then  !{
  if (scalar) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    elseif (field_length .gt. 1) then  !}{
      call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
    endif  !}
  endif  !}
endif  !}

!
!       set the index
!

if (present(index)) then  !{
  index_t = index
  if (index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Index not positive')
  endif  !}
else  !}{
  index_t = 1
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'integer') then  !{
  if (.not. fm_get_value(name, value, index = index_t)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
  endif  !}
elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
  value = default_value
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_integer  !}
! </FUNCTION> NAME="fm_util_get_integer"


!#######################################################################
! <FUNCTION NAME="fm_util_get_logical">
!
! <DESCRIPTION>
! Get a logical value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_logical(name, caller, index, default_value, scalar)            &
         result (value)  !{

implicit none

!
!       Return type
!

logical :: value

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
logical, intent(in), optional           :: default_value
logical, intent(in), optional           :: scalar

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_logical'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
integer                         :: index_t
character(len=fm_type_name_len) :: fm_type
integer                         :: field_length

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check whether we require a scalar (length=1) and return
!       an error if we do, and it isn't
!

if (present(scalar)) then  !{
  if (scalar) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    elseif (field_length .gt. 1) then  !}{
      call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
    endif  !}
  endif  !}
endif  !}

!
!       set the index
!

if (present(index)) then  !{
  index_t = index
  if (index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Index not positive')
  endif  !}
else  !}{
  index_t = 1
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'logical') then  !{
  if (.not. fm_get_value(name, value, index = index_t)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
  endif  !}
elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
  value = default_value
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_logical  !}
! </FUNCTION> NAME="fm_util_get_logical"


!#######################################################################
! <FUNCTION NAME="fm_util_get_real">
!
! <DESCRIPTION>
! Get a real value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_real(name, caller, index, default_value, scalar)            &
         result (value)  !{

implicit none

!
!       Return type
!

real :: value

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
real, intent(in), optional              :: default_value
logical, intent(in), optional           :: scalar

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_real'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
integer                         :: index_t
character(len=fm_type_name_len) :: fm_type
integer                         :: field_length

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check whether we require a scalar (length=1) and return
!       an error if we do, and it isn't
!

if (present(scalar)) then  !{
  if (scalar) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    elseif (field_length .gt. 1) then  !}{
      call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
    endif  !}
  endif  !}
endif  !}

!
!       set the index
!

if (present(index)) then  !{
  index_t = index
  if (index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Index not positive')
  endif  !}
else  !}{
  index_t = 1
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'real') then  !{
  if (.not. fm_get_value(name, value, index = index_t)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
  endif  !}
elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
  value = default_value
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_real  !}
! </FUNCTION> NAME="fm_util_get_real"


!#######################################################################
! <FUNCTION NAME="fm_util_get_string">
!
! <DESCRIPTION>
! Get a string value from the Field Manager tree.
! </DESCRIPTION>
!
function fm_util_get_string(name, caller, index, default_value, scalar)            &
         result (value)  !{

implicit none

!
!       Return type
!

character(len=fm_string_len) :: value

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
character(len=*), intent(in), optional  :: default_value
logical, intent(in), optional           :: scalar

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_get_string'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
integer                         :: index_t
character(len=fm_type_name_len) :: fm_type
integer                         :: field_length

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check whether we require a scalar (length=1) and return
!       an error if we do, and it isn't
!

if (present(scalar)) then  !{
  if (scalar) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    elseif (field_length .gt. 1) then  !}{
      call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
    endif  !}
  endif  !}
endif  !}

!
!       set the index
!

if (present(index)) then  !{
  index_t = index
  if (index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Index not positive')
  endif  !}
else  !}{
  index_t = 1
endif  !}

fm_type = fm_get_type(name)
if (fm_type .eq. 'string') then  !{
  if (.not. fm_get_value(name, value, index = index_t)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
  endif  !}
elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
  value = default_value
elseif (fm_type .eq. ' ') then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
else  !}{
 call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
endif  !}

return

end function fm_util_get_string  !}
! </FUNCTION> NAME="fm_util_get_string"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_integer_array">
!
! <DESCRIPTION>
! Set an integer array in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_integer_array(name, value, length, caller, no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)                            :: name
integer, intent(in)                                     :: length
integer, intent(in)                                     :: value(length)
character(len=*), intent(in), optional                  :: caller
logical, intent(in), optional                           :: no_overwrite
character(len=fm_path_name_len), intent(in), optional   :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_integer_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
integer                         :: field_length
integer                         :: n
logical                         :: no_overwrite_use
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that the length is non-negative
!

if (length .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Negative array length')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

!
!       write the data array
!

if (length .eq. 0) then  !{
  if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
    field_index = fm_new_value(name, 0, index = 0)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with length = ', length
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
else  !}{
  if (no_overwrite_use .and. fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    do n = field_length + 1, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  else  !}{
    field_index = fm_new_value(name, value(1))
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
    endif  !}
    do n = 2, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_integer_array  !}
! </SUBROUTINE> NAME="fm_util_set_value_integer_array"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_logical_array">
!
! <DESCRIPTION>
! Set a logical array in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_logical_array(name, value, length, caller, no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)                            :: name
integer, intent(in)                                     :: length
logical, intent(in)                                     :: value(length)
character(len=*), intent(in), optional                  :: caller
logical, intent(in), optional                           :: no_overwrite
character(len=fm_path_name_len), intent(in), optional   :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_logical_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
integer                         :: field_length
integer                         :: n
logical                         :: no_overwrite_use
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that the length is non-negative
!

if (length .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Negative array length')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

!
!       write the data array
!

if (length .eq. 0) then  !{
  if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
    field_index = fm_new_value(name, .false., index = 0)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with length = ', length
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
else  !}{
  if (no_overwrite_use .and. fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    do n = field_length + 1, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  else  !}{
    field_index = fm_new_value(name, value(1))
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
    endif  !}
    do n = 2, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_logical_array  !}
! </SUBROUTINE> NAME="fm_util_set_value_logical_array"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_real_array">
!
! <DESCRIPTION>
! Set a real array in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_real_array(name, value, length, caller, no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)                            :: name
integer, intent(in)                                     :: length
real, intent(in)                                        :: value(length)
character(len=*), intent(in), optional                  :: caller
logical, intent(in), optional                           :: no_overwrite
character(len=fm_path_name_len), intent(in), optional   :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_real_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
integer                         :: field_length
integer                         :: n
logical                         :: no_overwrite_use
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that the length is non-negative
!

if (length .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Negative array length')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

!
!       write the data array
!

if (length .eq. 0) then  !{
  if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
    field_index = fm_new_value(name, 0.0, index = 0)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with length = ', length
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
else  !}{
  if (no_overwrite_use .and. fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    do n = field_length + 1, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  else  !}{
    field_index = fm_new_value(name, value(1))
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
    endif  !}
    do n = 2, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_real_array  !}
! </SUBROUTINE> NAME="fm_util_set_value_real_array"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_string_array">
!
! <DESCRIPTION>
! Set a string array in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_string_array(name, value, length, caller, no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)                            :: name
integer, intent(in)                                     :: length
character(len=*), intent(in)                            :: value(length)
character(len=*), intent(in), optional                  :: caller
logical, intent(in), optional                           :: no_overwrite
character(len=fm_path_name_len), intent(in), optional   :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_string_array'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
integer                         :: field_length
integer                         :: n
logical                         :: no_overwrite_use
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that the length is non-negative
!

if (length .lt. 0) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Negative array length')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

!
!       write the data array
!

if (length .eq. 0) then  !{
  if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
    field_index = fm_new_value(name, ' ', index = 0)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with length = ', length
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
else  !}{
  if (no_overwrite_use .and. fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    do n = field_length + 1, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  else  !}{
    field_index = fm_new_value(name, value(1))
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
    endif  !}
    do n = 2, length  !{
      field_index = fm_new_value(name, value(n), index = n)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', n
        call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
      endif  !}
    enddo  !} n
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_string_array  !}
! </SUBROUTINE> NAME="fm_util_set_value_string_array"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_integer">
!
! <DESCRIPTION>
! Set an integer value in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_integer(name, value, caller, index, append, no_create,        &
     no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)            :: name
integer, intent(in)                     :: value
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
logical, intent(in), optional           :: append
logical, intent(in), optional           :: no_create
logical, intent(in), optional           :: no_overwrite
character(len=*), intent(in), optional  :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_integer'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
logical                         :: no_overwrite_use
integer                         :: field_length
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: create
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that append and index are not both given
!

if (present(index) .and. present(append)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

if (present(no_create)) then  !{
  create = .not. no_create
  if (no_create .and. (present(append) .or. present(index))) then  !{
    call mpp_error(FATAL, trim(error_header) // ' append or index are present when no_create is true for ' // trim(name))
  endif  !}
else  !}{
  create = .true.
endif  !}

if (present(index)) then  !{
  if (fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
      field_index = fm_new_value(name, value, index = index)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', index
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
      endif  !}
    endif  !}
  else  !}{
    field_index = fm_new_value(name, value, index = index)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with index = ', index
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
elseif (present(append)) then  !}{
  field_index = fm_new_value(name, value, append = append)
  if (field_index .le. 0) then  !{
    write (str_error,*) ' with append = ', append
    call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
  endif  !}
else  !}{
  if (fm_exists(name)) then  !{
    if (.not. no_overwrite_use) then  !{
      field_index = fm_new_value(name, value)
      if (field_index .le. 0) then  !{
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
      endif  !}
    endif  !}
  elseif (create) then  !}{
    field_index = fm_new_value(name, value)
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
    endif  !}
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check, unless the field did not exist and we did not create it
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_integer  !}
! </SUBROUTINE> NAME="fm_util_set_value_integer"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_logical">
!
! <DESCRIPTION>
! Set a logical value in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_logical(name, value, caller, index, append, no_create,        &
     no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)            :: name
logical, intent(in)                     :: value
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
logical, intent(in), optional           :: append
logical, intent(in), optional           :: no_create
logical, intent(in), optional           :: no_overwrite
character(len=*), intent(in), optional  :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_logical'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
logical                         :: no_overwrite_use
integer                         :: field_length
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: create
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that append and index are not both given
!

if (present(index) .and. present(append)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

if (present(no_create)) then  !{
  create = .not. no_create
  if (no_create .and. (present(append) .or. present(index))) then  !{
    call mpp_error(FATAL, trim(error_header) // ' append or index are present when no_create is true for ' // trim(name))
  endif  !}
else  !}{
  create = .true.
endif  !}

if (present(index)) then  !{
  if (fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
      field_index = fm_new_value(name, value, index = index)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', index
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
      endif  !}
    endif  !}
  else  !}{
    field_index = fm_new_value(name, value, index = index)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with index = ', index
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
elseif (present(append)) then  !}{
  field_index = fm_new_value(name, value, append = append)
  if (field_index .le. 0) then  !{
    write (str_error,*) ' with append = ', append
    call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
  endif  !}
else  !}{
  if (fm_exists(name)) then  !{
    if (.not. no_overwrite_use) then  !{
      field_index = fm_new_value(name, value)
      if (field_index .le. 0) then  !{
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
      endif  !}
    endif  !}
  elseif (create) then  !}{
    field_index = fm_new_value(name, value)
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
    endif  !}
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check, unless the field did not exist and we did not create it
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_logical  !}
! </SUBROUTINE> NAME="fm_util_set_value_logical"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_real">
!
! <DESCRIPTION>
! Set a real value in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_real(name, value, caller, index, append, no_create,        &
     no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)            :: name
real, intent(in)                        :: value
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
logical, intent(in), optional           :: append
logical, intent(in), optional           :: no_create
logical, intent(in), optional           :: no_overwrite
character(len=*), intent(in), optional  :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_real'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
logical                         :: no_overwrite_use
integer                         :: field_length
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: create
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that append and index are not both given
!

if (present(index) .and. present(append)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

if (present(no_create)) then  !{
  create = .not. no_create
  if (no_create .and. (present(append) .or. present(index))) then  !{
    call mpp_error(FATAL, trim(error_header) // ' append or index are present when no_create is true for ' // trim(name))
  endif  !}
else  !}{
  create = .true.
endif  !}

if (present(index)) then  !{
  if (fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
      field_index = fm_new_value(name, value, index = index)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', index
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
      endif  !}
    endif  !}
  else  !}{
    field_index = fm_new_value(name, value, index = index)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with index = ', index
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
elseif (present(append)) then  !}{
  field_index = fm_new_value(name, value, append = append)
  if (field_index .le. 0) then  !{
    write (str_error,*) ' with append = ', append
    call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
  endif  !}
else  !}{
  if (fm_exists(name)) then  !{
    if (.not. no_overwrite_use) then  !{
      field_index = fm_new_value(name, value)
      if (field_index .le. 0) then  !{
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
      endif  !}
    endif  !}
  elseif (create) then  !}{
    field_index = fm_new_value(name, value)
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
    endif  !}
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check, unless the field did not exist and we did not create it
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_real  !}
! </SUBROUTINE> NAME="fm_util_set_value_real"


!#######################################################################
! <SUBROUTINE NAME="fm_util_set_value_string">
!
! <DESCRIPTION>
! Set a string value in the Field Manager tree.
! </DESCRIPTION>
!

subroutine fm_util_set_value_string(name, value, caller, index, append, no_create,        &
     no_overwrite, good_name_list)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)            :: name
character(len=*), intent(in)            :: value
character(len=*), intent(in), optional  :: caller
integer, intent(in), optional           :: index
logical, intent(in), optional           :: append
logical, intent(in), optional           :: no_create
logical, intent(in), optional           :: no_overwrite
character(len=*), intent(in), optional  :: good_name_list

!
!       Local parameters
!

character(len=48), parameter    :: sub_name = 'fm_util_set_value_string'

!
!       Local variables
!

character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
character(len=32)               :: str_error
integer                         :: field_index
logical                         :: no_overwrite_use
integer                         :: field_length
character(len=fm_path_name_len) :: good_name_list_use
logical                         :: create
logical                         :: add_name

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       check that append and index are not both given
!

if (present(index) .and. present(append)) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
endif  !}

!
!       check for whether to overwrite existing values
!

if (present(no_overwrite)) then  !{
  no_overwrite_use = no_overwrite
else  !}{
  no_overwrite_use = default_no_overwrite
endif  !}

!
!       check for whether to save the name in a list
!

if (present(good_name_list)) then  !{
  good_name_list_use = good_name_list
else  !}{
  good_name_list_use = default_good_name_list
endif  !}

if (present(no_create)) then  !{
  create = .not. no_create
  if (no_create .and. (present(append) .or. present(index))) then  !{
    call mpp_error(FATAL, trim(error_header) // ' append or index are present when no_create is true for ' // trim(name))
  endif  !}
else  !}{
  create = .true.
endif  !}

if (present(index)) then  !{
  if (fm_exists(name)) then  !{
    field_length = fm_get_length(name)
    if (field_length .lt. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
    endif  !}
    if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
      field_index = fm_new_value(name, value, index = index)
      if (field_index .le. 0) then  !{
        write (str_error,*) ' with index = ', index
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
      endif  !}
    endif  !}
  else  !}{
    field_index = fm_new_value(name, value, index = index)
    if (field_index .le. 0) then  !{
      write (str_error,*) ' with index = ', index
      call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
    endif  !}
  endif  !}
elseif (present(append)) then  !}{
  field_index = fm_new_value(name, value, append = append)
  if (field_index .le. 0) then  !{
    write (str_error,*) ' with append = ', append
    call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
  endif  !}
else  !}{
  if (fm_exists(name)) then  !{
    if (.not. no_overwrite_use) then  !{
      field_index = fm_new_value(name, value)
      if (field_index .le. 0) then  !{
        call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
      endif  !}
    endif  !}
  elseif (create) then  !}{
    field_index = fm_new_value(name, value)
    if (field_index .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
    endif  !}
  endif  !}
endif  !}

!
!       Add the variable name to the list of good names, to be used
!       later for a consistency check, unless the field did not exist and we did not create it
!

if (good_name_list_use .ne. ' ') then  !{
  if (fm_exists(good_name_list_use)) then  !{
    add_name = fm_util_get_index_string(good_name_list_use, name,               &
       caller = caller_str) .le. 0              ! true if name does not exist in string array
  else  !}{
    add_name = .true.                           ! always add to new list
  endif  !}
  if (add_name .and. fm_exists(name)) then  !{
    if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
      call mpp_error(FATAL, trim(error_header) //                               &
           ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
    endif  !}
  endif  !}
endif  !}

return

end subroutine fm_util_set_value_string  !}
! </SUBROUTINE> NAME="fm_util_set_value_string"


!#######################################################################
! <SUBROUTINE NAME="fm_util_start_namelist">
!
! <DESCRIPTION>
! Start processing a namelist
! </DESCRIPTION>
!
subroutine fm_util_start_namelist(path, name, caller, no_overwrite, check)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)            :: path
character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller
logical,          intent(in), optional  :: no_overwrite
logical,          intent(in), optional  :: check

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_start_namelist'

!
!       Local variables
!

integer                         :: namelist_index
character(len=fm_path_name_len) :: path_name
character(len=256)              :: error_header
character(len=256)              :: warn_header
character(len=256)              :: note_header
character(len=128)              :: caller_str
integer                         :: out_unit

out_unit = stdout()

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a name is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Concatenate the path and name
!

if (path .eq. ' ') then  !{
  path_name = name
else  !}{
  path_name = trim(path) // '/' // name
endif  !}
save_path = path
save_name = name

!
!       set the default caller string, if desired
!

if (present(caller)) then  !{
  call fm_util_set_caller(caller)
else  !}{
  call fm_util_reset_caller
endif  !}

!
!       set the default no_overwrite flag, if desired
!

if (present(no_overwrite)) then  !{
  call fm_util_set_no_overwrite(no_overwrite)
else  !}{
  call fm_util_reset_no_overwrite
endif  !}

!
!       set the default good_name_list string, if desired
!

if (present(check)) then  !{
  if (check) then  !{
    call fm_util_set_good_name_list('/ocean_mod/GOOD/namelists/' // trim(path_name) // '/good_list')
  else  !}{
    call fm_util_reset_good_name_list
  endif  !}
else  !}{
  call fm_util_reset_good_name_list
endif  !}

!
!       Process the namelist
!

write (out_unit,*)
write (out_unit,*) trim(note_header), ' Processing namelist ', trim(path_name)

!
!       Check whether the namelist already exists. If so, then use that one
!

namelist_index = fm_get_index('/ocean_mod/namelists/' // trim(path_name))
if (namelist_index .gt. 0) then  !{

  !write (out_unit,*) trim(note_header), ' Namelist already set with index ', namelist_index

else  !}{

!
!       Set a new namelist and get its index
!

  namelist_index = fm_new_list('/ocean_mod/namelists/' // trim(path_name), create = .true.)
  if (namelist_index .le. 0) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Could not set namelist ' // trim(path_name))
  endif  !}

endif  !}

!
!       Add the namelist name to the list of good namelists, to be used
!       later for a consistency check
!

if (fm_new_value('/ocean_mod/GOOD/namelists/' // trim(path) // '/good_values',    &
                 name, append = .true., create = .true.) .le. 0) then  !{
  call mpp_error(FATAL, trim(error_header) //                           &
       ' Could not add ' // trim(name) // ' to "' // trim(path) // '/good_values" list')
endif  !}

!
!       Change to the new namelist, first saving the current list
!

save_current_list = fm_get_current_list()
if (save_current_list .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not get the current list')
endif  !}

if (.not. fm_change_list('/ocean_mod/namelists/' // trim(path_name))) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Could not change to the namelist ' // trim(path_name))
endif  !}

return

end subroutine fm_util_start_namelist  !}
! </SUBROUTINE> NAME="fm_util_start_namelist"


!#######################################################################
! <SUBROUTINE NAME="fm_util_end_namelist">
!
! <DESCRIPTION>
! Finish up processing a namelist
! </DESCRIPTION>
!
subroutine fm_util_end_namelist(path, name, caller, check)  !{

implicit none

!
!       arguments
!

character(len=*), intent(in)            :: path
character(len=*), intent(in)            :: name
character(len=*), intent(in), optional  :: caller
logical,          intent(in), optional  :: check

!
!       Local parameters
!

character(len=48), parameter  :: sub_name = 'fm_util_end_namelist'

!
!       Local variables
!

character(len=fm_string_len), pointer, dimension(:)     :: good_list => NULL()
character(len=fm_path_name_len)                         :: path_name
character(len=256)                                      :: error_header
character(len=256)                                      :: warn_header
character(len=256)                                      :: note_header
character(len=128)                                      :: caller_str

!
!       set the caller string and headers
!

if (present(caller)) then  !{
  caller_str = '[' // trim(caller) // ']'
else  !}{
  caller_str = fm_util_default_caller
endif  !}

error_header = '==>Error from ' // trim(mod_name) //   &
               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
warn_header = '==>Warning from ' // trim(mod_name) //  &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
note_header = '==>Note from ' // trim(mod_name) //     &
              '(' // trim(sub_name) // ')' // trim(caller_str) // ':'

!
!       check that a path is given (fatal if not)
!

if (name .eq. ' ') then  !{
  call mpp_error(FATAL, trim(error_header) // ' Empty name given')
endif  !}

!
!       Check that the path ane name match the preceding call to
!       fm_util_start_namelist
!

if (path .ne. save_path) then  !{
  call mpp_error(FATAL, trim(error_header) // ' Path "' // trim(path) // '" does not match saved path "' // trim(save_path) // '"')
elseif (name .ne. save_name) then  !}{
  call mpp_error(FATAL, trim(error_header) // ' Name "' // trim(name) // '" does not match saved name "' // trim(save_name) // '"')
endif  !}

!
!       Concatenate the path and name
!

if (path .eq. ' ') then  !{
  path_name = name
else  !}{
  path_name = trim(path) // '/' // name
endif  !}
save_path = ' '
save_name = ' '

!
!       Check for any errors in the number of fields in this list
!

if (present(check)) then  !{
  if (check) then  !{
    if (caller_str .eq. ' ') then  !{
      caller_str = trim(mod_name) // '(' // trim(sub_name) // ')'
    endif  !}
    good_list => fm_util_get_string_array('/ocean_mod/GOOD/namelists/' // trim(path_name) // '/good_list',            &
         caller = trim(mod_name) // '(' // trim(sub_name) // ')')
    if (associated(good_list)) then  !{
      call fm_util_check_for_bad_fields('/ocean_mod/namelists/' // trim(path_name), good_list, caller = caller_str)
      deallocate(good_list)
    else  !}{
      call mpp_error(FATAL, trim(error_header) // ' Empty "' // trim(path_name) // '" list')
    endif  !}
  endif  !}
endif  !}

!
!       Change back to the saved list
!

if (save_current_list .ne. ' ') then  !{
  if (.not. fm_change_list(save_current_list)) then  !{
    call mpp_error(FATAL, trim(error_header) // ' Could not change to the saved list: ' // trim(save_current_list))
  endif  !}
endif  !}
save_current_list = ' '

!
!       reset the default caller string
!

call fm_util_reset_caller

!
!       reset the default no_overwrite string
!

call fm_util_reset_no_overwrite

!
!       reset the default good_name_list string
!

call fm_util_reset_good_name_list

return

end subroutine fm_util_end_namelist  !}
! </SUBROUTINE> NAME="fm_util_end_namelist"


end module fm_util_mod  !}



module fms_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   The fms module provides routines that are commonly used
!   by most FMS modules.
! </OVERVIEW>

! <DESCRIPTION>
!   Here is a summary of the functions performed by routines
!     in the fms module.
!
!   1. Output module version numbers to a common (<TT>log</TT>) file
!     using a common format.<BR/>
!   2. Open specific types of files common to many FMS modules.
!     These include namelist files, restart files, and 32-bit IEEE
!     data files. There also is a matching interface to close the files.
!     If other file types are needed the <TT>mpp_open</TT> and <TT>mpp_close</TT>
!     interfaces in module <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp_io.html">mpp_io</LINK> must be used.<BR/>
!    3. Read and write distributed data to simple native unformatted files.
!     This type of file (called a restart file) is used to checkpoint
!     model integrations for a subsequent restart of the run.<BR/>
!    4. For convenience there are several routines published from
!     the <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp.html">mpp</LINK> module. These are routines for getting processor
!     numbers, commonly used I/O unit numbers, error handling, and timing sections of code.
! </DESCRIPTION>

!-----------------------------------------------------------------------
!
!         A collection of commonly used routines.
!
!  The routines are primarily I/O related, however, there also
!  exists several simple miscellaneous utility routines.
!
!-----------------------------------------------------------------------
!
!  file_exist         Checks the existence of the given file name.
!
!  check_nml_error    Checks the iostat argument that is returned after
!                     reading a namelist and determines if the error
!                     code is valid.
!
!  write_version_number  Prints to the log file (or a specified unit)
!                        the (cvs) version id string and (cvs) tag name.
!
!  error_mesg          Print notes, warnings and error messages, 
!                      terminates program for error messages.
!                      (use error levels NOTE,WARNING,FATAL)
!
!  open_namelist_file  Opens namelist file for reading only.
!
!  open_restart_file   Opens a file that will be used for reading or writing
!                      restart files with native unformatted data.
!
!  open_ieee32_file    Opens a file that will be used for reading or writing
!                      unformatted 32-bit ieee data.
!
!  close_file          Closes a file that was opened using 
!                      open_namelist_file, open_restart_file, or
!                      open_ieee32_file.
!
!  set_domain          Call this routine to internally store in fms_mod the
!                      domain2d data type prior to calling the distributed
!                      data I/O routines read_data and write_data.
!
!  read_data           Reads distributed data from a single threaded file.
!
!  write_data          Writes distributed data to a single threaded file.
!
!  fms_init            Initializes the fms module and also the
!                      mpp_io module (which initializes all mpp mods).
!                      Will be called automatically if the user does
!                      not call it.
!
!  fms_end             Calls mpp exit routines.
!
!  lowercase           Convert character strings to all lower case
!
!  uppercase           Convert character strings to all upper case
!
!  monotonic_array     Determines if the real input array has
!                      monotonically increasing or decreasing values.
!
!  string_array_index  Match the input character string to a string
!                      in an array/list of character strings.
!
!-----------------------------------------------------------------------
!---- published routines from mpp_mod ----
!
!   mpp_error, NOTE, WARNING, FATAL
!   mpp_error_state
!   mpp_pe, mpp_npes, mpp_root_pe
!   stdin, stdout, stderr, stdlog
!   mpp_chksum
!
!   mpp_clock_id, mpp_clock_begin , mpp_clock_end
!   MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
!   CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, 
!   CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
!
!-----------------------------------------------------------------------

use          mpp_mod, only:  mpp_error, NOTE, WARNING, FATAL,    &
                             mpp_set_warn_level,                 &
                             mpp_transmit, ALL_PES,              &
                             mpp_pe, mpp_npes, mpp_root_pe,      &
                             mpp_sync, mpp_chksum,               &
                             mpp_clock_begin, mpp_clock_end,     &
                             mpp_clock_id, mpp_init, mpp_exit,   &
                             MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, &
                             CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,&
                             CLOCK_MODULE_DRIVER, CLOCK_MODULE,  &
                             CLOCK_ROUTINE, CLOCK_LOOP,          &
                             CLOCK_INFRA, mpp_clock_set_grain,   &
                             mpp_set_stack_size,                 &
                             stdin, stdout, stderr, stdlog,      &
                             mpp_error_state, lowercase,         &
                             uppercase, mpp_broadcast, input_nml_file

use  mpp_domains_mod, only:  domain2D, mpp_define_domains, &
                             mpp_update_domains, GLOBAL_DATA_DOMAIN, &
                             mpp_domains_init, mpp_domains_exit,     &
                             mpp_global_field, mpp_domains_set_stack_size,  &
                             mpp_get_compute_domain, mpp_get_global_domain, &
                             mpp_get_data_domain

use       mpp_io_mod, only:  mpp_io_init, mpp_open, mpp_close,         &
                       MPP_ASCII, MPP_NATIVE, MPP_IEEE32, MPP_NETCDF,  &
                       MPP_RDONLY, MPP_WRONLY, MPP_APPEND, MPP_OVERWR, &
                       MPP_SEQUENTIAL, MPP_DIRECT,                     &
                       MPP_SINGLE, MPP_MULTI, MPP_DELETE, mpp_io_exit, &
                       fieldtype, mpp_get_atts, mpp_get_info, mpp_get_fields

use fms_io_mod, only : read_data, write_data, fms_io_init, fms_io_exit, field_size, &
                       open_namelist_file, open_restart_file, open_ieee32_file, close_file, &
                       set_domain, get_domain_decomp, nullify_domain, &
                       open_file, open_direct_file, string, get_mosaic_tile_grid, &
                       get_mosaic_tile_file, get_global_att_value, file_exist, field_exist

use memutils_mod, only: print_memuse_stats, memutils_init
use constants_mod, only: constants_version=>version, constants_tagname=>tagname !pjp: PI not computed


implicit none
private

! routines for initialization and termination of module
public :: fms_init, fms_end

! routines for opening/closing specific types of file
public :: open_namelist_file, open_restart_file, &
          open_ieee32_file, close_file, &
          open_file, open_direct_file

! routines for reading/writing distributed data
public :: set_domain, read_data, write_data
public :: get_domain_decomp, field_size, nullify_domain
public :: get_global_att_value

! routines for get mosaic information
public :: get_mosaic_tile_grid, get_mosaic_tile_file

! miscellaneous i/o routines
public :: file_exist, check_nml_error, field_exist,     &
          write_version_number, error_mesg, fms_error_handler

! miscellaneous utilities (non i/o)
public :: lowercase, uppercase, string,        &
          string_array_index, monotonic_array

! public mpp interfaces
public :: mpp_error, NOTE, WARNING, FATAL, &
          mpp_error_state,                 &
          mpp_pe, mpp_npes, mpp_root_pe,   &
          stdin, stdout, stderr, stdlog,   &
          mpp_chksum
public :: mpp_clock_id, mpp_clock_begin, mpp_clock_end
public :: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, &
          CLOCK_MODULE_DRIVER, CLOCK_MODULE,   &
          CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA

!Balaji
!this is published by fms and applied to any initialized clocks
!of course you can go and set the flag to SYNC or DETAILED by hand
integer, public :: clock_flag_default

!------ namelist interface -------
!------ adjustable severity level for warnings ------

  logical           :: read_all_pe   = .true.
  character(len=16) :: clock_grain = 'NONE', clock_flags='NONE'
  character(len=8)  :: warning_level = 'warning'
  character(len=64) :: iospec_ieee32 = '-N ieee_32'
  integer           :: stack_size = 0
  integer           :: domains_stack_size = 0
  logical, public   :: print_memory_usage = .FALSE.

!------ namelist interface -------

! <NAMELIST NAME="fms_nml">
!   <DATA NAME="clock_grain"  TYPE="character"  DEFAULT="'NONE'">
!     The level of clock granularity used for performance timing sections
!     of code. Possible values in order of increasing detail are:
!     'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
!     'LOOP', and 'INFRA'.  Code sections are defined using routines in MPP 
!     module: mpp_clock_id, mpp_clock_begin, and mpp_clock_end.
!     The fms module makes these routines public.
!     A list of timed code sections will be printed to STDOUT.
!     See the <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp.html">MPP</LINK>
!     module for more details.
!   </DATA>
!   <DATA NAME="clock_flags"  TYPE="character"  DEFAULT="'NONE'">
!     Possible values are 'NONE', 'SYNC', or 'DETAILED'.
!     SYNC will give accurate information on load balance of the clocked
!     portion of code.
!     DETAILED also turns on detailed message-passing performance diagnosis.
!     Both SYNC and DETAILED will  work correctly on innermost clock nest
!     and distort outer clocks, and possibly the overall code time.
!     See the <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp.html">MPP</LINK>
!     module for more details.
!   </DATA>
!   <DATA NAME="read_all_pe"  TYPE="logical"  DEFAULT="true">
!     Read global data on all processors extracting local part needed (TRUE) or
!     read global data on PE0 and broadcast to all PEs (FALSE).
!   </DATA>
!   <DATA NAME="warning_level"  TYPE="character"  DEFAULT="'warning'">
!     Sets the termination condition for the WARNING flag to interfaces
!     error_mesg/mpp_error. set warning_level = 'fatal' (program crashes for
!     warning messages) or 'warning' (prints warning message and continues).
!   </DATA>
!   <DATA NAME="iospec_ieee32"  TYPE="character"  DEFAULT="'-N ieee_32'">
!     iospec flag used with the open_ieee32_file interface.
!   </DATA>
!   <DATA NAME="stack_size"  TYPE="integer"  DEFAULT="0">
!     The size in words of the MPP user stack. If stack_size > 0, the following
!     MPP routine is called: call mpp_set_stack_size (stack_size). If stack_size
!     = 0 (default) then the default size set by mpp_mod is used.
!   </DATA>
!   <DATA NAME="domains_stack_size" TYPE="integer"  DEFAULT="0">
!     The size in words of the MPP_DOMAINS user stack. If
!     domains_stack_size > 0, the following MPP_DOMAINS routine is called:
!     call mpp_domains_set_stack_size (domains_stack_size). If
!     domains_stack_size = 0 (default) then the default size set by
!     mpp_domains_mod is used. 
!   </DATA>
!   <DATA NAME="print_memory_usage"  TYPE="logical"  DEFAULT=".FALSE.">
!     If set to .TRUE., memory usage statistics will be printed at various
!     points in the code. It is used to study memory usage, e.g to detect
!     memory leaks.
!   </DATA>
! </NAMELIST>

  namelist /fms_nml/  read_all_pe, clock_grain, clock_flags,    &
                      warning_level, iospec_ieee32, &
                      stack_size, domains_stack_size, &
                      print_memory_usage

!   ---- private data for check_nml_error ----

   integer, private :: num_nml_error_codes, nml_error_codes(20)
   logical, private :: do_nml_error_init = .true.
   private  nml_error_init


!  ---- version number -----

  character(len=128) :: version = '$Id: fms.F90,v 17.0.8.1.2.1.2.1 2010/08/31 14:28:53 z1l Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

  logical :: module_is_initialized = .FALSE.


contains

!#######################################################################

! <SUBROUTINE NAME="fms_init">

!   <OVERVIEW>
!     Initializes the FMS module and also calls the initialization routines for all
!     modules in the MPP package. Will be called automatically if the user does
!     not call it. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Initialization routine for the fms module. It also calls initialization routines
!      for the mpp, mpp_domains, and mpp_io modules. Although this routine
!      will be called automatically by other fms_mod routines, users should
!      explicitly call fms_init. If this routine is called more than once it will
!      return silently. There are no arguments.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call fms_init ( )
!   </TEMPLATE>


!   <ERROR MSG="invalid entry for namelist variable warning_level" STATUS="FATAL">
!     The namelist variable warning_level must be either 'fatal' or 'warning'
!     (case-insensitive). 
!   </ERROR>
!   <ERROR MSG="invalid entry for namelist variable clock_grain" STATUS="FATAL">
!     The namelist variable clock_grain must be one of the following values:
!     'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
!     'LOOP', or 'INFRA' (case-insensitive). 
!   </ERROR>

! initializes the fms module/package
! also calls mpp initialization routines and reads fms namelist

subroutine fms_init (localcomm )
 integer, intent(in), optional :: localcomm
 integer :: unit, ierr, io

    if (module_is_initialized) return    ! return silently if already called
    module_is_initialized = .true.
!---- initialize mpp routines ----
    if(present(localcomm)) then
       call mpp_init(localcomm=localcomm)
    else
       call mpp_init()
    endif
    call mpp_domains_init
    call fms_io_init

!---- read namelist input ----

    call nml_error_init  ! first initialize namelist iostat error codes

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, fms_nml, iostat=io)
#else
    if (file_exist('input.nml')) then
       unit = open_namelist_file ( )
       ierr=1; do while (ierr /= 0)
          read  (unit, nml=fms_nml, iostat=io, end=10)
          ierr = check_nml_error(io,'fms_nml')  ! also initializes nml error codes
       enddo
 10    call mpp_close (unit)
    endif
#endif

!---- define mpp stack sizes if non-zero -----

    if (        stack_size > 0) call         mpp_set_stack_size (        stack_size)
    if (domains_stack_size > 0) call mpp_domains_set_stack_size (domains_stack_size)

!---- set severity level for warnings ----

    select case( trim(lowercase(warning_level)) )
    case( 'fatal' )  
        call mpp_set_warn_level ( FATAL )
    case( 'warning' )
        call mpp_set_warn_level ( WARNING )
    case default
        call error_mesg ( 'fms_init',  &
             'invalid entry for namelist variable warning_level', FATAL )
    end select

!--- set granularity for timing code sections ---

    select case( trim(uppercase(clock_grain)) )
    case( 'NONE' )
        call mpp_clock_set_grain (0)
    case( 'COMPONENT' )
        call mpp_clock_set_grain (CLOCK_COMPONENT)
    case( 'SUBCOMPONENT' )
        call mpp_clock_set_grain (CLOCK_SUBCOMPONENT)
    case( 'MODULE_DRIVER' )
        call mpp_clock_set_grain (CLOCK_MODULE_DRIVER)
    case( 'MODULE' )
        call mpp_clock_set_grain (CLOCK_MODULE)
    case( 'ROUTINE' )
        call mpp_clock_set_grain (CLOCK_ROUTINE)
    case( 'LOOP' )
        call mpp_clock_set_grain (CLOCK_LOOP)
    case( 'INFRA' )
        call mpp_clock_set_grain (CLOCK_INFRA)
    case default
        call error_mesg ( 'fms_init',  &
             'invalid entry for namelist variable clock_grain', FATAL )
    end select
!Balaji
    select case( trim(uppercase(clock_flags)) )
    case( 'NONE' )
       clock_flag_default = 0
    case( 'SYNC' )
       clock_flag_default = MPP_CLOCK_SYNC
    case( 'DETAILED' )
       clock_flag_default = MPP_CLOCK_DETAILED
    case default
       call error_mesg ( 'fms_init',  &
            'invalid entry for namelist variable clock_flags', FATAL )
   end select

!--- write version info and namelist to logfile ---

    call write_version_number (version, tagname)
    if (mpp_pe() == mpp_root_pe()) then
      unit = stdlog()
      write (unit, nml=fms_nml)
      write (unit,*) 'nml_error_codes=', nml_error_codes(1:num_nml_error_codes)
    endif

    call memutils_init( print_memory_usage )
    call print_memuse_stats('fms_init')

    call write_version_number (constants_version,constants_tagname)

end subroutine fms_init
! </SUBROUTINE>

!#######################################################################


! <SUBROUTINE NAME="fms_end">

!   <OVERVIEW>
!     Calls the termination routines for all modules in the MPP package.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Termination routine for the fms module. It also calls destructor routines
!      for the mpp, mpp_domains, and mpp_io modules. If this routine is called
!      more than once it will return silently. There are no arguments. 
!   </DESCRIPTION>
!   <TEMPLATE>
!     call fms_end ( )
!   </TEMPLATE>

! terminates the fms module/package
! also calls mpp destructor routines

subroutine fms_end ( )

    if (.not.module_is_initialized) return  ! return silently
!    call fms_io_exit  ! now called from coupler_end
    call mpp_io_exit
    call mpp_domains_exit
    call mpp_exit
    module_is_initialized =.FALSE.

end subroutine fms_end
! </SUBROUTINE>


!#######################################################################
! <SUBROUTINE NAME="error_mesg">

!   <OVERVIEW>
!     Print notes, warnings and error messages; terminates program for warning 
!     and error messages. (use error levels NOTE,WARNING,FATAL, see example below)
!   </OVERVIEW>
!   <DESCRIPTION>
!     Print notes, warnings and error messages; and terminates the program for 
!     error messages. This routine is a wrapper around mpp_error, and is provided 
!     for backward compatibility. This module also publishes mpp_error,
!      <B>users should try to use the mpp_error interface</B>. 
!   </DESCRIPTION>
!   <TEMPLATE>
!     call error_mesg ( routine, message, level )
!   </TEMPLATE>

!   <IN NAME="routine"  TYPE="character" >
!     Routine name where the warning or error has occurred.
!   </IN>
!   <IN NAME="message"  TYPE="character" >
!     Warning or error message to be printed.
!   </IN>
!   <IN NAME="level"  TYPE="integer" >
!     Level of severity; set to NOTE, WARNING, or FATAL Termination always occurs 
!     for FATAL, never for NOTE, and is settable for WARNING (see namelist).
!   </IN>
!   <NOTE>
!
!     Examples:
!     <PRE>
!        use fms_mod, only: error_mesg, FATAL, NOTE

!        call error_mesg ('fms_mod', 'initialization not called', FATAL)
!        call error_mesg ('fms_mod', 'fms_mod message', NOTE)
!     </PRE>
!   </NOTE>
! wrapper for the mpp error handler
! users should try to use the mpp_error interface

 subroutine error_mesg (routine, message, level)
  character(len=*), intent(in) :: routine, message
  integer,          intent(in) :: level

!  input:
!      routine   name of the calling routine (character string)
!      message   message written to output   (character string)
!      level     set to NOTE, MESSAGE, or FATAL (integer)

    if (.not.module_is_initialized) call fms_init ( )
    call mpp_error ( routine, message, level )

 end subroutine error_mesg
! </SUBROUTINE>

!#######################################################################
! <FUNCTION NAME="fms_error_handler">

!   <OVERVIEW>
!     Facilitates the control of fatal error conditions
!   </OVERVIEW>
!   <DESCRIPTION>
!     When err_msg is present, message is copied into err_msg
!     and the function returns a value of .true.
!     Otherwise calls mpp_error to terminate execution.
!     The intended use is as shown below.
!   </DESCRIPTION>
!   <TEMPLATE>
!     if(fms_error_handler(routine, message, err_msg)) return
!   </TEMPLATE>
!   <IN NAME="routine"  TYPE="character">
!     Routine name where the fatal error has occurred.
!   </IN>
!   <IN NAME="message"  TYPE="character">
!     fatal error message to be printed.
!   </IN>
!   <OUT NAME="fms_error_handler"  TYPE="logical">
!     .true.  when err_msg is present
!     .false. when err_msg is not present
!   </OUT>
!   <OUT NAME="err_msg"  TYPE="character">
!     When err_msg is present: err_msg = message
!   </OUT>

 function fms_error_handler(routine, message, err_msg)

 logical :: fms_error_handler
 character(len=*), intent(in) :: routine, message
 character(len=*), intent(out), optional :: err_msg

 fms_error_handler = .false.
 if(present(err_msg)) then
   err_msg = message
   fms_error_handler = .true.
 else
   call mpp_error(trim(routine),trim(message),FATAL)
 endif

 end function fms_error_handler
! </FUNCTION>

!#######################################################################
! <FUNCTION NAME="check_nml_error">

!   <OVERVIEW>
!     Checks the iostat argument that is returned after reading a namelist 
!     and determines if the error code is valid. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     The FMS allows multiple namelist records to reside in the same file. 
!     Use this interface to check the iostat argument that is returned after 
!     reading a record from the namelist file. If an invalid iostat value 
!     is detected this routine will produce a fatal error. See the NOTE below.
!   </DESCRIPTION>
!   <TEMPLATE>
!     check_nml_error ( iostat, nml_name )
!   </TEMPLATE>

!   <IN NAME="iostat"  TYPE="integer" >
!     The iostat value returned when reading a namelist record.
!   </IN>
!   <IN NAME="nml_name"  TYPE="character" >
!     The name of the namelist. This name will be printed if an error is 
!     encountered, otherwise the name is not used.
!   </IN>
!   <OUT NAME=""  TYPE="integer" >
!     This function returns the input iostat value (integer) if it is an 
!     allowable error code. If the iostat error code is not
!     allowable, an error message is printed and the program terminated.
!   </OUT>
!   <NOTE>
!     Some compilers will return non-zero iostat values when reading through 
!     files with multiple namelist. This routine
!     will try skip these errors and only terminate for true namelist errors.
!
!     Examples
!
!       The following example checks if a file exists, reads a namelist input 
!       from that file, and checks for errors in that
!       namelist. When the correct namelist is read and it has no errors the 
!       routine check_nml_error will return zero and the while loop will exit. 
!       This code segment should be used to read namelist files. 
!       <PRE>
!          integer :: unit, ierr, io
!
!          if ( file_exist('input.nml') ) then
!              unit = open_namelist_file ( )
!              ierr=1
!              do while (ierr /= 0)
!                read  (unit, nml=moist_processes_nml, iostat=io, end=10)
!                ierr = check_nml_error(io,'moist_processes_nml')
!              enddo
!        10    call close_file (unit)
!          endif
!       </PRE>
!   </NOTE>

!   <ERROR MSG="while reading namelist ...., iostat = ####" STATUS="FATAL">
!     There was an error message reading the namelist specified. Carefully 
!     examine all namelist variables for
!     misspellings of type mismatches (e.g., integer vs. real).
!   </ERROR>

! used to check the iostat argument that is
! returned after reading a namelist
! see the online documentation for how this routine might be used

 function check_nml_error (iostat, nml_name) result (error_code)

  integer,          intent(in) :: iostat
  character(len=*), intent(in) :: nml_name
  integer   error_code, i
  character(len=128) :: err_str

   if (.not.module_is_initialized) call fms_init ( )

   error_code = iostat

   do i = 1, num_nml_error_codes
        if (error_code == nml_error_codes(i)) return
   enddo

!  ------ fatal namelist error -------
!  ------ only on root pe ----------------
   if (mpp_pe() == mpp_root_pe()) then
       write (err_str,*) 'while reading namelist ',  &
                         trim(nml_name), ', iostat = ',error_code
       call error_mesg ('check_nml_error in fms_mod', err_str, FATAL)
       call error_mesg ('check_nml_error in fms_mod', err_str, FATAL)
       call mpp_sync() ! In principal, this sync should not be necessary
                       ! as mpp_error's call to MPI_ABORT and ABORT should
                       ! kill all associated processes. Still...
   else
       call mpp_sync()
   endif

end function check_nml_error
! </FUNCTION>

!-----------------------------------------------------------------------
!   private routine for initializing allowable error codes

subroutine nml_error_init

! some compilers return non-zero iostat values while
! reading through files with multiple namelist records
! this routines "attempts" to identify the iostat values associated
! with records not belonging to the requested namelist

   integer  unit, io, ir
   real    ::  a=1.
   integer ::  b=1
   logical ::  c=.true.
   integer ::  tmp(1)
   character(len=8) ::  d='testing'
   namelist /b_nml/  a,b,c,d

      nml_error_codes(1) = -1
      nml_error_codes(2) = 0

!     ---- create dummy namelist file that resembles actual ----
!     ---- (each pe has own copy) ----
      if(mpp_pe() == mpp_root_pe() ) then
         call mpp_open (unit, '_read_error.nml', form=MPP_ASCII,  &
              action=MPP_OVERWR, access=MPP_SEQUENTIAL, &
              threading=MPP_SINGLE)
         !     ---- due to namelist bug this will not always work ---
         write (unit, 10)
10       format ('    ', &
              /' &a_nml  a=1.  /',    &
              /'#------------------', &
              /' &b_nml  a=5., b=0, c=.false., d=''test'',  &end')
         call mpp_close (unit)

         !     ---- read namelist files and save error codes ----
         call mpp_open (unit, '_read_error.nml', form=MPP_ASCII,  &
              action=MPP_RDONLY, access=MPP_SEQUENTIAL, &
              threading=MPP_SINGLE)
         ir=2; io=1; do
            read  (unit, nml=b_nml, iostat=io, end=20)
            if (io == 0) exit
            ir=ir+1; nml_error_codes(ir)=io
         enddo
20       call mpp_close (unit, action=MPP_DELETE)
         num_nml_error_codes = ir
         tmp(1) = num_nml_error_codes
      endif

   
      call mpp_broadcast(tmp,1,mpp_root_pe())
      num_nml_error_codes = tmp(1)
      call mpp_broadcast(nml_error_codes, num_nml_error_codes, mpp_root_pe())

!del  if (mpp_pe() == mpp_root_pe()) &
!del  print *, 'PE,nml_error_codes=',mpp_pe(), nml_error_codes(1:ir)
      do_nml_error_init = .false.

end subroutine nml_error_init

!#######################################################################
! <SUBROUTINE NAME="write_version_number">

!   <OVERVIEW>
!     Prints to the log file (or a specified unit) the (cvs) version id string and
!     (cvs) tag name.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Prints to the log file (stdlog) or a specified unit the (cvs) version id string
!      and (cvs) tag name.
!   </DESCRIPTION>
!   <TEMPLATE>
!    call write_version_number ( version [, tag, unit] )
!   </TEMPLATE>

!   <IN NAME="version" TYPE="character(len=*)">
!    string that contains routine name and version number.
!   </IN>
!   <IN NAME="tag" TYPE="character(len=*)">
!    The tag/name string, this is usually the Name string
!    returned by CVS when checking out the code.
!   </IN>
!   <IN NAME="unit" TYPE="integer">
!    The Fortran unit number of an open formatted file. If this unit number 
!    is not supplied the log file unit number is used (stdlog). 
!   </IN>
! prints module version number to the log file of specified unit number

 subroutine write_version_number (version, tag, unit)

!   in:  version = string that contains routine name and version number
!
!   optional in:
!        tag = cvs tag name that code was checked out with
!        unit    = alternate unit number to direct output  
!                  (default: unit=stdlog)

   character(len=*), intent(in) :: version
   character(len=*), intent(in), optional :: tag 
   integer,          intent(in), optional :: unit 

   integer :: logunit 

   if (.not.module_is_initialized) call fms_init ( )

     logunit = stdlog()
     if (present(unit)) then
         logunit = unit
     else    
       ! only allow stdlog messages on root pe
         if ( mpp_pe() /= mpp_root_pe() ) return
     endif   

     if (present(tag)) then
         write (logunit,'(/,80("="),/(a))') trim(version), trim(tag)
     else    
         write (logunit,'(/,80("="),/(a))') trim(version)
     endif   

 end subroutine write_version_number
! </SUBROUTINE>

!#######################################################################


! <FUNCTION NAME="string_array_index">

!   <OVERVIEW>
!     match the input character string to a string
!     in an array/list of character strings
!   </OVERVIEW>
!   <DESCRIPTION>
!      Tries to find a match for a character string in a list of character strings.
!      The match is case sensitive and disregards blank characters to the right of
!      the string. 
!   </DESCRIPTION>
!   <TEMPLATE>
!      string_array_index ( string, string_array [, index] )
!   </TEMPLATE>

!   <IN NAME="string"  TYPE="character(len=*), scalar" >
!     Character string of arbitrary length.
!   </IN>
!   <IN NAME="string_array"  TYPE="character(len=*)" DIM="(:)">
!     Array/list of character strings.
!   </IN>
!   <OUT NAME="index"  TYPE="integer" >
!     The index of string_array where the first match was found. If
!            no match was found then index = 0.
!   </OUT>
!   <OUT NAME="string_array_index"  TYPE="logical" >
!     If an exact match was found then TRUE is returned, otherwise FALSE is returned.
!   </OUT>
!   <NOTE>
!     Examples
!      <PRE>
!       string = "def"
!       string_array = (/ "abcd", "def ", "fghi" /)

!       string_array_index ( string, string_array, index )

!       Returns: TRUE, index = 2
!      </PRE>
!   </NOTE>
! match the input character string to a string
! in an array/list of character strings

function string_array_index ( string, string_array, index ) result (found)
character(len=*),  intent(in)  :: string, string_array(:)
integer, optional, intent(out) :: index
logical :: found
integer :: i

! initialize this function to false
! loop thru string_array and exit when a match is found

  found = .false.
  if (present(index)) index = 0

  do i = 1, size(string_array(:))
    ! found a string match ?
    if ( trim(string) == trim(string_array(i)) ) then
         found = .true.
         if (present(index)) index = i
         exit
    endif
  enddo

end function string_array_index
! </FUNCTION>

!#######################################################################

! <FUNCTION NAME="monotonic_array">

!   <OVERVIEW>
!     Determines if a real input array has monotonically increasing or
!     decreasing values.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Determines if the real input array has monotonically increasing or
!     decreasing values.
!   </DESCRIPTION>
!   <TEMPLATE>
!     monotonic_array ( array [, direction] )
!   </TEMPLATE>

!   <IN NAME="array"  TYPE="real" DIM="(:)">
!     An array of real values. If the size(array) < 2 this function
!     assumes the array is not monotonic, no fatal error will occur.
!   </IN>
!   <OUT NAME="direction"  TYPE="integer" >
!     If the input array is:
!                >> monotonic (small to large) then direction = +1.
!                >> monotonic (large to small) then direction = -1.
!                >> not monotonic then direction = 0. 
!   </OUT>
!   <OUT NAME="monotonic_array"  TYPE="logical" >
!     If the input array of real values either increases or decreases monotonically
!      then TRUE is returned, otherwise FALSE is returned. 
!   </OUT>
! determines if the real input array has
! monotonically increasing or decreasing values

function monotonic_array ( array, direction )
real,    intent(in)            :: array(:)
integer, intent(out), optional :: direction
logical :: monotonic_array
integer :: i

! initialize
  monotonic_array = .false.
  if (present(direction)) direction = 0

! array too short
  if ( size(array(:)) < 2 ) return

! ascending
  if ( array(1) < array(size(array(:))) ) then
     do i = 2, size(array(:))
       if (array(i-1) < array(i)) cycle
       return
     enddo
     monotonic_array = .true.
     if (present(direction)) direction = +1

! descending
  else
     do i = 2, size(array(:))
       if (array(i-1) > array(i)) cycle
       return
     enddo
     monotonic_array = .true.
     if (present(direction)) direction = -1
  endif

end function monotonic_array
! </FUNCTION>

end module fms_mod
! <INFO>
!   <BUG>              
!     Namelist error checking may not work correctly with some compilers.
!
!     Users should beware when mixing Fortran reads and read_data calls. If a
!     Fortran read follows read_data and namelist variable read_all_pe = FALSE
!     (not the default), then the code will fail. It is safest if Fortran reads 
!     precede calls to read_data.
!   </BUG>
!   <ERROR MSG="unexpected EOF" STATUS="FATAL">
!     An unexpected end-of-file was encountered in a read_data call.
!     You may want to use the optional end argument to detect the EOF. 
!   </ERROR>
!   <NOTE>
!     1) If the <B>MPP</B> or <B>MPP_DOMAINS</B> stack size is exceeded the
!     program will terminate after printing the required size. 
!   
!     2) When running on a very small number of processors or for high
!     resolution models the default domains_stack_size will
!     probably be insufficient. 
!
!     3) The following performance routines in the <B>MPP</B> module are published by this module.
!<PRE>
!        mpp_clock_id, mpp_clock_begin, mpp_clock_end
!</PRE>
!        and associated parameters that are published:
!<PRE>
!        MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,
!        CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
!</PRE>
!
!     4) Here is an example of how to time a section of code.<BR/>
!<PRE>
!          use fms_mod, only: mpp_clock_id, mpp_clock_begin, &
!                             mpp_clock_end. MPP_CLOCK_SYNC, &
!                             CLOCK_MODULE_DRIVER
!          integer :: id_mycode
!
!          id_mycode = mpp_clock_id ('mycode loop', flags=MPP_CLOCK_SYNC, grain=CLOCK_MODULE_DRIVER)
!          call mpp_clock_begin (id_mycode)
!                        :
!                        :
!           ~~ this code will be timed ~~ 
!                        :
!                        :
!          call mpp_clock_end (id_mycode)
! </PRE>
!        Note: <TT>CLOCK_MODULE_DRIVER</TT> can be replaced with
!        CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE,
!        CLOCK_LOOP, or CLOCK_INFRA.
!        
!   </NOTE>
!   <FUTURE>           
!     NetCDF facilities for reading and writing restart files and (IEEE32) 
!       data files.
!    </FUTURE>
!    <FUTURE>
!     May possible split the FMS module into two modules. 
!
!      i.general utilities (FMS_MOD) <BR/>
!     ii.I/O utilities (FMS_IO_MOD) 
!    </FUTURE>
! </INFO>



#include <fms_platform.h>

module fms_io_mod

!
!
! <CONTACT EMAIL="Zhi.Liang@noaa.gov">
! Zhi Liang
! </CONTACT>

! <CONTACT EMAIL="Matthew.Harrison@noaa.gov">
! M.J. Harrison 
! </CONTACT>
!
! <REVIEWER EMAIL="Matthew.Harrison@noaa.gov">
! M.J. Harrison 
! </REVIEWER>

! <REVIEWER EMAIL="Bruce.Wyman@noaa.gov">
! B. Wyman
! </REVIEWER>

!<DESCRIPTION>
! This module is for writing and reading restart data in NetCDF format.
! fms_io_init must be called before the first write_data/read_data call
! For writing, fms_io_exit must be called after ALL write calls have
! been made. Typically, fms_io_init and fms_io_exit are placed in the
! main (driver) program while read_data and write_data can be called where needed.
! Presently, two combinations of threading and fileset are supported, users can choose
! one line of the following by setting namelist:
!
! With the introduction of netCDF restart files, there is a need for a global
! switch to turn on/off netCDF restart options in all of the modules that deal with
! restart files. Here two more namelist variables (logical type) are introduced to fms_io
!
! fms_netcdf_override
! fms_netcdf_restart
!
! because default values of both flags are .true., the default behavior of the entire model is 
! to use netCDF IO mode. To turn off netCDF restart, simply set fms_netcdf_restart to .false.
!
! Fei.Liu@noaa.gov
! 05222006
! Read distributed files in NetCDF is available. Details can be found in read_data_3d_new
! <PRE>
!threading_read='multi', threading_write='multi', fileset_write='multi' (default)
!threading_read='multi', threading_write='single', fileset_write='single'
! </PRE>
!</DESCRIPTION>
! <NAMELIST NAME="fms_io_nml">  
! <DATA NAME="threading_read" TYPE="character">
! threading_read can be 'single' or 'multi'
! </DATA>
! <DATA NAME="threading_write" TYPE="character">
! threading_write can be 'single' or 'multi'
! </DATA>
! <DATA NAME="fileset_write" TYPE="character">
! fileset_write can be 'single' or 'multi'
! </DATA>
! <DATA NAME="fms_netcdf_override" TYPE="logical">
!   .true. : fms_netcdf_restart overrides individual do_netcdf_restart value (default behavior)
!   .false.: individual module settings has a precedence over the global setting, therefore fms_netcdf_restart is ignored
! </DATA>
! <DATA NAME="fms_netcdf_restart" TYPE="logical">
!   .true. : all modules deal with restart files will operate under netCDF mode (default behavior)
!   .false.: all modules deal with restart files will operate under binary mode
!   This flag is effective only when fms_netcdf_override is .true. When fms_netcdf_override is .false., individual
!   module setting takes over.
! </DATA>
! <DATA NAME="time_stamped_restart" TYPE="logical">
!   .true. : time_stamp will be added to the restart file name as a prefix when 
!            optional argument time_stamp is passed into routine save_restart. 
!   .false.: time_stmp will not be added to the restart file name even though
!            time_stamp is passed into save_restart.
!    default is true.
! </DATA>
! <DATA NAME="print_chksum" TYPE="logical">
!    set print_chksum (default is false) to true to print out chksum of fields that are
!    read and written through save_restart/restore_state. The chksum is accross all the 
!    processors, so there will be only one chksum even there are multiple-tiles in the 
!    grid. For the multiple case, the filename appeared in the message will contain
!    tile1 because the message is print out from root pe and on root pe the tile id is tile1. 
! </DATA>
!</NAMELIST>

use mpp_io_mod,      only: mpp_open, mpp_close, mpp_io_init, mpp_io_exit, mpp_read, mpp_write
use mpp_io_mod,      only: mpp_write_meta, mpp_get_info, mpp_get_atts, mpp_get_fields
use mpp_io_mod,      only: mpp_get_axes, mpp_get_axis_data, mpp_get_att_char, mpp_get_att_name
use mpp_io_mod,      only: mpp_get_att_real_scalar
use mpp_io_mod,      only: fieldtype, axistype, atttype, default_field, default_axis, default_att
use mpp_io_mod,      only: MPP_NETCDF, MPP_ASCII, MPP_MULTI, MPP_SINGLE, MPP_OVERWR, MPP_RDONLY
use mpp_io_mod,      only: MPP_IEEE32, MPP_NATIVE, MPP_DELETE, MPP_APPEND, MPP_SEQUENTIAL, MPP_DIRECT
use mpp_io_mod,      only: MAX_FILE_SIZE, mpp_get_att_value
use mpp_domains_mod, only: domain2d, domain1d, NULL_DOMAIN1D, NULL_DOMAIN2D, operator( .EQ. ), CENTER
use mpp_domains_mod, only: mpp_get_domain_components, mpp_get_compute_domain, mpp_get_data_domain
use mpp_domains_mod, only: mpp_get_domain_shift, mpp_get_global_domain, mpp_global_field, mpp_domain_is_tile_root_pe
use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_current_ntile, mpp_get_tile_id, mpp_mosaic_defined
use mpp_domains_mod, only: mpp_get_io_domain
use mpp_mod,         only: mpp_error, FATAL, NOTE, WARNING, mpp_pe, mpp_root_pe, mpp_npes, stdlog, stdout
use mpp_mod,         only: mpp_broadcast, ALL_PES, mpp_chksum, mpp_get_current_pelist, mpp_npes, lowercase
use mpp_mod,         only: input_nml_file

use platform_mod, only: r8_kind

implicit none
private


integer, parameter, private :: max_split_file = 50
integer, parameter, private :: max_fields=400
integer, parameter, private :: max_axes=40
integer, parameter, private :: max_atts=20
integer, parameter, private :: max_domains = 10
integer, parameter, private :: MAX_TIME_LEVEL_REGISTER = 2
integer, parameter, private :: MAX_TIME_LEVEL_WRITE = 20
integer, parameter          :: max_axis_size=10000

type var_type
   private
   character(len=128)                     :: name
   character(len=128)                     :: longname
   character(len=128)                     :: units
   real, dimension(:,:,:,:), _ALLOCATABLE :: buffer _NULL 
   logical                                :: domain_present
   logical                                :: write_on_this_pe
   integer                                :: domain_idx
   logical                                :: is_dimvar
   type(fieldtype)                        :: field
   type(axistype)                         :: axis
   integer                                :: position
   integer                                :: ndim
   integer                                :: siz(4)      ! X/Y/Z/T extent of fields (data domain 
                                                         ! size for distributed writes;global size for reads)
   integer                                :: gsiz(4)     ! global X/Y/Z/T extent of fields 
   integer                                :: csiz(4)     ! actual data size in the file
   integer                                :: id_axes(3)  ! store index for x/y/z axistype.
   logical                                :: initialized ! indicate if the field is read or not in routine save_state.
   logical                                :: mandatory   ! indicate if the field is mandatory to be when restart.
   integer                                :: is, ie, js, je  ! index of the data in compute domain
   real                                   :: default_data 
end type var_type

type Ptr0Dr
   real,                   pointer :: p => NULL()
end type Ptr0Dr

type Ptr1Dr
   real, dimension(:),     pointer :: p => NULL()
end type Ptr1Dr

type Ptr2Dr
   real, dimension(:,:),   pointer :: p => NULL()
end type Ptr2Dr

type Ptr3Dr
   real, dimension(:,:,:), pointer :: p => NULL()
end type Ptr3Dr

type Ptr0Di
   integer,                   pointer :: p => NULL()
end type Ptr0Di

type Ptr1Di
   integer, dimension(:),     pointer :: p => NULL()
end type Ptr1Di

type Ptr2Di
   integer, dimension(:,:),   pointer :: p => NULL()
end type Ptr2Di

type Ptr3Di
   integer, dimension(:,:,:), pointer :: p => NULL()
end type Ptr3Di

type restart_file_type
   private
   integer                                  :: unit ! mpp_io unit for netcdf file
   character(len=128)                       :: name
   integer                                  :: nvar, natt, max_ntime
   logical                                  :: is_root_pe
   integer                                  :: tile_count
   type(var_type), dimension(:),   pointer  :: var  => NULL()
   type(Ptr0Dr),   dimension(:,:), pointer  :: p0dr => NULL()
   type(Ptr1Dr),   dimension(:,:), pointer  :: p1dr => NULL()
   type(Ptr2Dr),   dimension(:,:), pointer  :: p2dr => NULL()
   type(Ptr3Dr),   dimension(:,:), pointer  :: p3dr => NULL()
   type(Ptr0Di),   dimension(:,:), pointer  :: p0di => NULL()
   type(Ptr1Di),   dimension(:,:), pointer  :: p1di => NULL()
   type(Ptr2Di),   dimension(:,:), pointer  :: p2di => NULL()
   type(Ptr3Di),   dimension(:,:), pointer  :: p3di => NULL()
end type restart_file_type

interface read_data
   module procedure read_data_3d_new
   module procedure read_data_2d_new
   module procedure read_data_1d_new
   module procedure read_data_scalar_new
   module procedure read_data_i3d_new
   module procedure read_data_i2d_new
   module procedure read_data_i1d_new
   module procedure read_data_iscalar_new
   module procedure read_data_2d, read_ldata_2d, read_idata_2d
   module procedure read_data_3d, read_data_4d
#ifdef OVERLOAD_C8
   module procedure read_cdata_2d,read_cdata_3d,read_cdata_4d
#endif
   module procedure read_data_text
   module procedure read_data_2d_region
end interface

interface write_data
   module procedure write_data_3d_new
   module procedure write_data_2d_new
   module procedure write_data_1d_new
   module procedure write_data_scalar_new
   module procedure write_data_i3d_new
   module procedure write_data_i2d_new
   module procedure write_data_i1d_new
   module procedure write_data_iscalar_new
   module procedure write_data_2d, write_ldata_2d, write_idata_2d
   module procedure write_data_3d, write_data_4d
#ifdef OVERLOAD_C8
   module procedure write_cdata_2d,write_cdata_3d,write_cdata_4d
#endif
end interface

interface register_restart_field
   module procedure register_restart_field_r0d
   module procedure register_restart_field_r1d
   module procedure register_restart_field_r2d
   module procedure register_restart_field_r3d
   module procedure register_restart_field_i0d
   module procedure register_restart_field_i1d
   module procedure register_restart_field_i2d
   module procedure register_restart_field_i3d
   module procedure register_restart_field_r0d_2level
   module procedure register_restart_field_r1d_2level
   module procedure register_restart_field_r2d_2level
   module procedure register_restart_field_r3d_2level
   module procedure register_restart_field_i0d_2level
   module procedure register_restart_field_i1d_2level
   module procedure register_restart_field_i2d_2level
   module procedure register_restart_field_i3d_2level
end interface

interface reset_field_pointer
   module procedure reset_field_pointer_r0d
   module procedure reset_field_pointer_r1d
   module procedure reset_field_pointer_r2d
   module procedure reset_field_pointer_r3d
   module procedure reset_field_pointer_i0d
   module procedure reset_field_pointer_i1d
   module procedure reset_field_pointer_i2d
   module procedure reset_field_pointer_i3d
   module procedure reset_field_pointer_r0d_2level
   module procedure reset_field_pointer_r1d_2level
   module procedure reset_field_pointer_r2d_2level
   module procedure reset_field_pointer_r3d_2level
   module procedure reset_field_pointer_i0d_2level
   module procedure reset_field_pointer_i1d_2level
   module procedure reset_field_pointer_i2d_2level
   module procedure reset_field_pointer_i3d_2level
end interface

interface restore_state
   module procedure restore_state_all
   module procedure restore_state_one_field
end interface

interface query_initialized
   module procedure query_initialized_id
   module procedure query_initialized_name
   module procedure query_initialized_r2d
end interface

interface get_global_att_value
  module procedure get_global_att_value_text
  module procedure get_global_att_value_real
end interface

interface get_var_att_value
  module procedure get_var_att_value_text
end interface

integer :: num_files_r = 0 ! number of currently opened files for reading
integer :: num_files_w = 0 ! number of currently opened files for writing
integer :: num_domains = 0 ! number of domains in array_domain
integer :: num_registered_files ! mumber of files registered by calling register_restart_file


integer :: thread_r, thread_w, fset_w, form
logical :: module_is_initialized = .FALSE.

character(len=32) :: pelist_name
character(len=7)  :: pe_name
character(len=128):: error_msg  

  
!------ private data, pointer to current 2d domain ------
! entrained from fms_mod.  This will be deprecated in the future.
type(domain2D), pointer, private :: Current_domain =>NULL()

integer, private :: is,ie,js,je      ! compute domain
integer, private :: isd,ied,jsd,jed  ! data domain
integer, private :: isg,ieg,jsg,jeg  ! global domain
character(len=128),      dimension(:), allocatable         :: registered_file ! file names registered through register_restart_file 
type(restart_file_type), dimension(:), allocatable         :: files_read  ! store files that are read through read_data
type(restart_file_type), dimension(:), allocatable, target :: files_write ! store files that are written through write_data
type(domain2d), dimension(max_domains), save       :: array_domain
type(domain1d), dimension(max_domains), save       :: domain_x, domain_y
public  :: read_data, write_data, fms_io_init, fms_io_exit, field_size
public  :: open_namelist_file, open_restart_file, open_ieee32_file, close_file 
public  :: set_domain, nullify_domain, get_domain_decomp, return_domain
public  :: open_file, open_direct_file
public  :: get_restart_io_mode, get_tile_string, string
public  :: get_mosaic_tile_grid, get_mosaic_tile_file
public  :: get_global_att_value, get_var_att_value
public  :: file_exist, field_exist
public  :: register_restart_field, save_restart, restore_state
public  :: restart_file_type, query_initialized
public  :: reset_field_name, reset_field_pointer
private :: lookup_field_r, lookup_axis, unique_axes

public  :: set_filename_appendix, get_instance_filename
character(len=32), save :: filename_appendix = ''

!--- public interface ---
interface string
   module procedure string_from_integer
   module procedure string_from_real
end interface

!--- namelist interface
logical           :: fms_netcdf_override = .true.
logical           :: fms_netcdf_restart  = .true.
character(len=32) :: threading_read      = 'multi'
character(len=32) :: threading_write     = 'multi'
character(len=32) :: fileset_write       = 'multi'
character(len=32) :: format              = 'netcdf' 
logical           :: read_all_pe         = .TRUE.
character(len=64) :: iospec_ieee32       = '-N ieee_32'
integer           :: max_files_w         = 40
integer           :: max_files_r         = 40
logical           :: read_data_bug       = .false.
logical           :: time_stamp_restart  = .true.
logical           :: print_chksum        = .false.
  namelist /fms_io_nml/ fms_netcdf_override, fms_netcdf_restart, &
       threading_read, threading_write, &
       fileset_write, format, read_all_pe, iospec_ieee32,max_files_w,max_files_r, &
       read_data_bug, time_stamp_restart, print_chksum


character(len=128) :: version = '$Id: fms_io.F90,v 17.0.2.2.4.1.2.1.2.1.2.1 2010/08/31 14:28:53 z1l Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains

! <SUBROUTINE NAME="get_restart_io_mode">
! <DESCRIPTION>
! With the introduction of netCDF restart files, there is a need for a global
! switch to turn on/off netCDF restart options in all of the modules that deal with
! restart files. Here two more namelist variables (logical type) are introduced to fms_io
!
! fms_netcdf_override
! fms_netcdf_restart
!
! because default values of both flags are .true., the default behavior of the entire model is 
! to use netCDF IO mode. To turn off netCDF restart, simply set fms_netcdf_restart to .false.
! 
! </DESCRIPTION>
! <TEMPLATE>
!  call get_fms_io_mode(do_netcdf_restart)
! </TEMPLATE>
! <INOUT NAME="do_netcdf_restart" TYPE="logical">
!  This the input argument that contains the individual module setting of restart IO mode.
!  Upon return from this subroutine, this output argument contains the actual setting of restart IO mode
!  the calling module will be using
! </INOUT>
! </SUBROUTINE>
subroutine get_restart_io_mode(do_netcdf_restart)

  logical, intent(inout)  :: do_netcdf_restart

  if(fms_netcdf_override) do_netcdf_restart = fms_netcdf_restart
  
end subroutine get_restart_io_mode
!.....................................................................
! <SUBROUTINE NAME="fms_io_init">
!   <DESCRIPTION>
! Initialize fms_io module
!   </DESCRIPTION>
!   <TEMPLATE>
! call fms_io_init()
!   </TEMPLATE>
subroutine fms_io_init()
    
  integer                            :: i, unit, io_status, logunit
  integer, allocatable, dimension(:) :: pelist


  if (module_is_initialized) return
  call mpp_io_init()

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, fms_io_nml, iostat=io_status)
#else
  call mpp_open(unit, 'input.nml',form=MPP_ASCII,action=MPP_RDONLY)
  read(unit,fms_io_nml,iostat=io_status)
  if (io_status > 0) then
     call mpp_error(FATAL,'=>fms_io_init: Error reading input.nml')
  endif
  call mpp_close (unit)
#endif

  if (mpp_pe() == mpp_root_pe()) then
    logunit = stdlog() ; write(logunit, fms_io_nml)
    write (logunit,'(/,80("="),/(a))') trim(version), trim(tagname)
  end if
! take namelist options if present

  select case (threading_read) 
  case ('multi')
     thread_r = MPP_MULTI
  case ('single')
     thread_r = MPP_SINGLE
  case default
     call mpp_error(FATAL,'fms_io_init: threading_read should be multi/single but you chose'//trim(threading_read))
  end select
! take namelist options if present

  select case (fileset_write) 
  case ('multi')
     fset_w = MPP_MULTI
  case ('single')
     fset_w = MPP_SINGLE
  case default
     call mpp_error(FATAL,'fms_io_init: fileset_write should be multi/single but you chose'//trim(fileset_write))
  end select

  select case (threading_write) 
  case ('multi')
     thread_w = MPP_MULTI
  case ('single')
     thread_w = MPP_SINGLE
  case default
     call mpp_error(FATAL,'fms_io_init: threading_write should be multi/single but you chose'//trim(threading_write))
  end select

  select case(format)
  case ('netcdf')
     form=MPP_NETCDF
  case default
     call mpp_error(FATAL,'fms_io_init: only NetCDF format currently supported in fms_io')
  end select

! Initially allocate  files_write and files_read
  allocate(files_write(max_files_w),files_read(max_files_r))
  allocate(registered_file(max_files_w))

  allocate(pelist(mpp_npes()))        
  call mpp_get_current_pelist(pelist,pelist_name)
  if(mpp_npes()>10000) then
     write(pe_name,'(a,i6.6)' )'.', mpp_pe()    
  else
     write(pe_name,'(a,i4.4)' )'.', mpp_pe()    
  endif
  deallocate(pelist)

  do i = 1, max_domains
     array_domain(i) = NULL_DOMAIN2D
  enddo
  !---- initialize module domain2d pointer ----
  nullify (Current_domain)
  module_is_initialized = .TRUE.
  
end subroutine fms_io_init

! </SUBROUTINE>
! <SUBROUTINE NAME="fms_io_exit">
!   <DESCRIPTION>
! This routine is called after ALL fields have been written to temporary files
! The result NETCDF files are created here.
!   </DESCRIPTION>
!   <TEMPLATE>
! call fms_io_exit
!   </TEMPLATE>

subroutine fms_io_exit()
    integer                             :: num_x_axes, num_y_axes, num_z_axes
    integer                             :: unit
    real, dimension(max_axis_size)      :: axisdata
    real(r8_kind)                       :: tlev  
    integer,        dimension(max_axes) :: id_x_axes, siz_x_axes
    integer,        dimension(max_axes) :: id_y_axes, siz_y_axes
    integer,        dimension(max_axes) :: id_z_axes, siz_z_axes
    type(axistype), dimension(max_axes) :: x_axes, y_axes, z_axes
    type(axistype)                      :: t_axes
    type(var_type), pointer, save       :: cur_var=>NULL()
    integer                             :: i, j, k, kk
    character(len=256)                  :: filename
    character(len=10)                   :: axisname
    logical                             :: domain_present

    if( .NOT.module_is_initialized )return !make sure it's only called once per PE

    do i=1,max_axis_size
       axisdata(i) = i
    enddo

    ! each field has an associated domain type (may be undefined).
    ! each file only needs to write unique axes (i.e. if 2 fields share an identical axis, then only write the axis once)
    ! unique axes are defined by the global size and domain decomposition (i.e. can support identical axis sizes with
    ! different domain decomposition)

    do i = 1, num_files_w
       filename = files_write(i)%name

       !--- check if any field in this file present domain.
       domain_present = .false.
       do j = 1, files_write(i)%nvar
          if (files_write(i)%var(j)%domain_present) then
              domain_present = .true.
              exit
          end if
       end do

       !--- get the unique axes for all the fields.
       num_x_axes = unique_axes(files_write(i), 1, id_x_axes, siz_x_axes, domain_x)
       num_y_axes = unique_axes(files_write(i), 2, id_y_axes, siz_y_axes, domain_y)
       num_z_axes = unique_axes(files_write(i), 3, id_z_axes, siz_z_axes          )

       if( domain_present ) then
          call mpp_open(unit,trim(filename),action=MPP_OVERWR,form=form,threading=thread_w,&
               fileset=fset_w, is_root_pe=files_write(i)%is_root_pe, domain=array_domain(files_write(i)%var(j)%domain_idx))
       else  ! global data
          call mpp_open(unit,trim(filename),action=MPP_OVERWR,form=form,threading=MPP_SINGLE,&
               fileset=MPP_SINGLE, is_root_pe=files_write(i)%is_root_pe)
       end if

       do j = 1, num_x_axes
         if (j < 10) then
             write(axisname,'(a,i1)') 'xaxis_',j
          else
             write(axisname,'(a,i2)') 'xaxis_',j
          endif          
          if(id_x_axes(j) > 0) then
             call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
                  data=axisdata(1:siz_x_axes(j)),domain=domain_x(id_x_axes(j)),cartesian='X')
          else
             call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
                  data=axisdata(1:siz_x_axes(j)),cartesian='X')
          endif             
       end do

       do j = 1, num_y_axes
         if (j < 10) then
             write(axisname,'(a,i1)') 'yaxis_',j
          else
             write(axisname,'(a,i2)') 'yaxis_',j
          endif          
          if(id_y_axes(j) > 0) then
             call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
                  data=axisdata(1:siz_y_axes(j)),domain=domain_y(id_y_axes(j)),cartesian='Y')
          else
             call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
                  data=axisdata(1:siz_y_axes(j)),cartesian='Y')
          endif             
       end do

       do j = 1, num_z_axes
          if (j < 10) then
             write(axisname,'(a,i1)') 'zaxis_',j
          else
             write(axisname,'(a,i2)') 'zaxis_',j
          endif          
          call mpp_write_meta(unit,z_axes(j),axisname,'none',axisname, &
               data=axisdata(1:siz_z_axes(j)),cartesian='Z')
       end do


       ! write time axis  (comment out if no time axis)
       call mpp_write_meta(unit,t_axes,&
            'Time','time level','Time',cartesian='T')

       ! write metadata for fields
       do j = 1, files_write(i)%nvar
          cur_var => files_write(i)%var(j)
          call mpp_write_meta(unit,cur_var%field, (/x_axes(cur_var%id_axes(1)), &
               y_axes(cur_var%id_axes(2)), z_axes(cur_var%id_axes(3)), t_axes/), cur_var%name, &
               'none',cur_var%name,pack=1)
       enddo

       ! write values for ndim of spatial axes
       do j = 1, num_x_axes
          call mpp_write(unit,x_axes(j))
       enddo
       do j = 1, num_y_axes
          call mpp_write(unit,y_axes(j))
       enddo
       do j = 1, num_z_axes
          call mpp_write(unit,z_axes(j))
       enddo

       ! write data of each field
       do k = 1, files_write(i)%max_ntime
          do j = 1, files_write(i)%nvar
             cur_var => files_write(i)%var(j)
             tlev=k
             ! If some fields only have one time level, we do not need to write the second level, just keep
             ! the data missing.
             ! If some fields only have one time level, we just write out 0 to the other level
             if(k > cur_var%siz(4)) then
                cur_var%buffer(:,:,:,1) = 0.0
                kk = 1
             else
                kk = k
             end if
             if(cur_var%domain_present) then
                call mpp_write(unit, cur_var%field,array_domain(cur_var%domain_idx), cur_var%buffer(:,:,:,kk), tlev, &
                               default_data=cur_var%default_data)
             else if (thread_w == MPP_MULTI .or. cur_var%write_on_this_pe .OR. &
                      (files_write(i)%is_root_pe.and.thread_w == MPP_SINGLE)) then
                call mpp_write(unit, cur_var%field, cur_var%buffer(:,:,:,kk), tlev)
             end if
          enddo ! end j loop
       enddo ! end k loop
       call mpp_close(unit)
    enddo ! end i loop

    !--- release the memory 

    do i = 1,  num_files_w
       do j = 1, files_write(i)%nvar
          deallocate(files_write(i)%var(j)%buffer)
       end do
    end do

  cur_var=>NULL()
  module_is_initialized = .false.
  num_files_w = 0
  num_files_r = 0    

end subroutine fms_io_exit
!.....................................................................
! </SUBROUTINE>

! <SUBROUTINE NAME="write_data">
    !<DESCRIPTION>
    ! This subroutine performs writing "fieldname" to file "filename". All values of "fieldname" 
    ! will be written to a temporary file. The final NETCDF file will be created only at a later step
    ! when the user calls fms_io_exit. Therefore, make sure that fms_io_exit is called after all
    ! fields have been written by this subroutine.
    !</DESCRIPTION>
!   <TEMPLATE>
! call write_data(filename, fieldname, data, domain)
!   </TEMPLATE>
!   <IN NAME="filename" TYPE="character" DIM="(*)">
!    File name
!   </IN>
!   <IN NAME="fieldname" TYPE="character" DIM="(*)">
!    Field  name
!   </IN>
!   <IN NAME="data"  TYPE="real">
!   array containing data of fieldname
!   </IN>
!   <IN NAME="domain"  TYPE="domain, optional">
!   domain of fieldname
!   </IN>
!=================================================================================
subroutine write_data_i3d_new(filename, fieldname, data, domain,                  &
                              no_domain, position, tile_count, data_default)

  character(len=*), intent(in) :: filename, fieldname 
  integer, dimension(:,:,:), intent(in) :: data
  type(domain2d), intent(in), optional :: domain
  logical, intent(in), optional :: no_domain
  integer, intent(in), optional :: position, tile_count, data_default
  real :: default_data

  default_data = 0
  if(present(data_default)) default_data = real(data_default)

  call write_data_3d_new(filename, fieldname, real(data), domain,  &
                         no_domain, .false., position, tile_count, data_default=default_data)
end subroutine write_data_i3d_new
!.....................................................................
subroutine write_data_i2d_new(filename, fieldname, data, domain, &
                              no_domain, position, tile_count, data_default)

  character(len=*), intent(in) :: filename, fieldname 
  integer, dimension(:,:), intent(in) :: data
  type(domain2d), intent(in), optional :: domain
  logical, intent(in), optional :: no_domain
  integer, intent(in), optional :: position, tile_count, data_default
  real :: default_data

  default_data = 0
  if(present(data_default)) default_data = real(data_default)
  call write_data_2d_new(filename, fieldname, real(data), domain, &
                         no_domain, position, tile_count, data_default=default_data)

end subroutine write_data_i2d_new
!.....................................................................
subroutine write_data_i1d_new(filename, fieldname, data, domain, &
                              no_domain, tile_count, data_default)
  type(domain2d), intent(in), optional :: domain
  character(len=*), intent(in) :: filename, fieldname 
  integer, dimension(:), intent(in) :: data
  logical, intent(in), optional :: no_domain
  integer, intent(in), optional :: tile_count, data_default
  real :: default_data

  default_data = 0
  if(present(data_default)) default_data = real(data_default)
  call write_data_1d_new(filename, fieldname, real(data), domain, &
                         no_domain, tile_count, data_default=default_data)
end subroutine write_data_i1d_new
!.....................................................................
subroutine write_data_iscalar_new(filename, fieldname, data, domain, &
                                  no_domain, tile_count, data_default)
  type(domain2d), intent(in), optional :: domain
  character(len=*), intent(in) :: filename, fieldname 
  integer, intent(in) :: data
  logical, intent(in), optional :: no_domain
  integer, intent(in), optional :: tile_count, data_default
  real :: default_data

  default_data = 0
  if(present(data_default)) default_data = real(data_default)
  call write_data_scalar_new(filename, fieldname, real(data), domain, &
                             no_domain, tile_count, data_default=default_data)

end subroutine write_data_iscalar_new
!.....................................................................
subroutine write_data_3d_new(filename, fieldname, data, domain, no_domain, scalar_or_1d, &
                             position, tile_count, data_default)

  character(len=*),         intent(in)         :: filename, fieldname 
  real, dimension(:,:,:),   intent(in)         :: data
  type(domain2d), optional, intent(in), target :: domain
  real,           optional, intent(in)         :: data_default
  logical,        optional, intent(in)         :: no_domain   
  logical,        optional, intent(in)         :: scalar_or_1d
  integer,        optional, intent(in)         :: position, tile_count

  !--- local variables
  real,               allocatable :: tmp_buffer(:,:,:,:)
  integer                         :: index_field ! position of the fieldname in the list of fields
  integer                         :: index_file  ! position of the filename in the list of files_write
  logical                         :: append_pelist, is_no_domain, is_scalar_or_1d
  character(len=256)              :: fname, filename2,append_string
  real                            :: default_data
  integer                         :: length, i, domain_idx
  integer                         :: ishift, jshift
  integer                         :: gxsize, gysize
  integer                         :: cxsize, cysize
  integer                         :: dxsize, dysize
  type(domain2d), pointer, save   :: d_ptr   =>NULL()
  type(var_type), pointer, save   :: cur_var =>NULL()
  type(restart_file_type), pointer, save :: cur_file =>NULL()
  type(domain2d), pointer,save            :: io_domain=>NULL()

! Initialize files to default values
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(write_data_3d_new): need to call fms_io_init')  


  if(PRESENT(data_default))then
     default_data=data_default
  else
     default_data=0.
  endif

  if(present(tile_count) .AND. .not. present(domain)) call mpp_error(FATAL, &
         'fms_io write_data: when tile_count is present, domain must be present')

  is_scalar_or_1d = .false.
  if(PRESENT(scalar_or_1d)) is_scalar_or_1d = scalar_or_1d

  is_no_domain = .false.
  if (PRESENT(no_domain)) THEN
     is_no_domain = no_domain
  end if

  if(is_no_domain) then
     if(PRESENT(domain)) &
       call mpp_error(FATAL, 'fms_io(write_data_3d_new): no_domain cannot be .true. when optional argument domain is present.')  
  else if(PRESENT(domain))then
     d_ptr => domain
  else if (ASSOCIATED(Current_domain)) then
     d_ptr => Current_domain
  endif

  !--- remove .nc from file name
  length = len_trim(filename)
  if(filename(length-2:length) == '.nc') then
     filename2 = filename(1:length-3)
  else
     filename2 = filename(1:length)
  end if

  !Logical append_pelist decides whether to append the pelist_name to file name
  append_pelist = .false.
  !Append a string to the file name
  append_string=''

  !If the filename_appendix  is set override the passed argument. 
  if(len_trim(filename_appendix) > 0)  then
     append_pelist = .true.
     append_string = filename_appendix
  endif

  if(append_pelist) filename2 = trim(filename2)//'.'//trim(append_string)

  !JWD:  This is likely a temporary fix. Since fms_io needs to know tile_count,
  !JWD:  I just don't see how the physics can remain "tile neutral"
  !z1l:  one solution is add one more public interface called set_tile_count
  call get_mosaic_tile_file(filename2, fname, is_no_domain, domain, tile_count)

  ! Check if filename has been open  or not
  index_file = -1
  do i=1,num_files_w
     if (trim(files_write(i)%name) == trim(fname)) then
        index_file = i
        cur_file => files_write(index_file)
        exit
     endif
  enddo

  if (index_file < 0) then 
     if(num_files_w == max_files_w) &  ! need to have bigger max_files_w
          call mpp_error(FATAL,'fms_io(write_data_3d_new): max_files_w exceeded, increase it via fms_io_nml')    
     ! record the file name in array files_write
     num_files_w=num_files_w + 1
     index_file = num_files_w
     cur_file => files_write(index_file)
     cur_file%name = trim(fname)         
     cur_file%tile_count=1
     if(present(tile_count)) cur_file%tile_count = tile_count
     if(ASSOCIATED(d_ptr))then
        cur_file%is_root_pe = mpp_domain_is_tile_root_pe(d_ptr)
     else
        cur_file%is_root_pe = mpp_pe() == mpp_root_pe()
     endif
     cur_file%max_ntime = 1
     !-- allocate memory
     allocate(cur_file%var(max_fields) )
     cur_file%nvar = 0
     do i = 1, max_fields
        cur_file%var(i)%name           = 'none'
        cur_file%var(i)%domain_present = .false.
        cur_file%var(i)%write_on_this_pe = .false.
        cur_file%var(i)%domain_idx     = -1
        cur_file%var(i)%is_dimvar      = .false.
        cur_file%var(i)%position       = CENTER
        cur_file%var(i)%siz(:)         = 0
        cur_file%var(i)%gsiz(:)        = 0
        cur_file%var(i)%id_axes(:)     = -1
     end do
  endif

  ! check if the field is new or not and get position and dimension of the field
  index_field = -1
  do i = 1, cur_file%nvar
     if(trim(cur_file%var(i)%name) == trim(fieldname)) then
        index_field = i
        exit
     end if 
  end do

  if(index_field > 0) then
     cur_var   => cur_file%var(index_field)
     cur_var%siz(4) =  cur_var%siz(4) + 1
     if(cur_file%max_ntime < cur_var%siz(4) ) cur_file%max_ntime = cur_var%siz(4)
     ! the time level should be no larger than MAX_TIME_LEVEL_WRITE ( =20) for write_data.
     if( cur_var%siz(4) > MAX_TIME_LEVEL_WRITE ) call mpp_error(FATAL, 'fms_io(write_data_3d_new): ' // &
          'the time level of field '//trim(cur_var%name)//' in file '//trim(cur_file%name)// &
          ' is greater than MAX_TIME_LEVEL_WRITE(=20), increase MAX_TIME_LEVEL_WRITE or check your code')
  else 
     cur_file%nvar = cur_file%nvar +1
     if(cur_file%nvar>max_fields) then
        write(error_msg,'(I3,"/",I3)') cur_file%nvar, max_fields 
        call  mpp_error(FATAL,'fms_io(write_data_3d_new): max_fields exceeded, needs increasing, nvar/max_fields=' &
             //trim(error_msg))
     endif
     index_field =  cur_file%nvar
     cur_var   => cur_file%var(index_field)
     cur_var%siz(1)  = size(data,1)
     cur_var%siz(2)  = size(data,2)
     cur_var%siz(3)  = size(data,3)
     cur_var%siz(4)  = 1
     cur_var%gsiz(3) = cur_var%siz(3)
     cur_var%name = fieldname
     cur_var%default_data = default_data
     cur_var%ndim = 3
     if(present(position)) cur_var%position = position
     
     if(ASSOCIATED(d_ptr)) then
        io_domain => mpp_get_io_domain(d_ptr)
        if(associated(io_domain)) then
           if(mpp_domain_is_tile_root_pe(io_domain)) cur_var%write_on_this_pe = .true.
        endif
     endif
     
     if(ASSOCIATED(d_ptr) .AND. .NOT. is_scalar_or_1d)then
        cur_var%domain_present = .true.
        domain_idx = lookup_domain(d_ptr)
        if(domain_idx == -1) then
           num_domains = num_domains + 1
           if(num_domains > max_domains) call  mpp_error(FATAL,'fms_io(write_data_3d_new), 1: max_domains exceeded,' &
                //' needs increasing')
           domain_idx = num_domains
           array_domain(domain_idx) = d_ptr
           call mpp_get_domain_components(array_domain(domain_idx), domain_x(domain_idx), domain_y(domain_idx), &
                tile_count=tile_count)
        endif
        cur_var%domain_idx = domain_idx
        call mpp_get_domain_shift ( array_domain(domain_idx), ishift, jshift, position)
        call mpp_get_global_domain(array_domain(domain_idx), xsize=gxsize,ysize=gysize,tile_count=tile_count)
        call mpp_get_compute_domain(array_domain(domain_idx), xsize = cxsize, ysize = cysize, tile_count=tile_count)
        call mpp_get_data_domain   (array_domain(domain_idx), xsize = dxsize, ysize = dysize, tile_count=tile_count)
        if (ishift .NE. 0) then
           cxsize = cxsize+ishift; dxsize = dxsize+ishift; gxsize = gxsize + ishift
        end if
        if (jshift .NE. 0) then
           cysize = cysize+jshift; dysize = dysize+jshift; gysize = gysize + jshift
        endif
        if( (cur_var%siz(1) .NE. cxsize .AND. cur_var%siz(1) .NE. dxsize ) .OR. &
            (cur_var%siz(2) .NE. cysize .AND. cur_var%siz(2) .NE. dysize ) ) then
            call mpp_error(FATAL, 'fms_io(write_data_3d_new): data should be on either computer domain '//&
              'or data domain when domain is present for field '//trim(fieldname)//' of file '//trim(filename) )
        end if
        cur_var%gsiz(1)   = gxsize
        cur_var%gsiz(2)   = gysize
     else
        cur_var%domain_present=.false.
        cur_var%gsiz(1) = size(data,1)
        cur_var%gsiz(2) = size(data,2)
     endif
  end if

  ! copy the data to the buffer 
  ! if the time level is greater than the size(cur_var%buffer,4), 
  ! need to increase the buffer size 

  if(cur_var%siz(4) == 1) then
     allocate(cur_var%buffer(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3), cur_var%siz(4)) )
  else
     allocate(tmp_buffer(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3), size(cur_var%buffer,4)) )
     tmp_buffer = cur_var%buffer
     deallocate(cur_var%buffer)
     allocate(cur_var%buffer(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3), cur_var%siz(4)) )
     cur_var%buffer(:,:,:,1:size(tmp_buffer,4)) = tmp_buffer 
     deallocate(tmp_buffer)
  endif

  cur_var%buffer(:,:,:,cur_var%siz(4)) = data ! copy current data to buffer for future write out 

  d_ptr =>NULL()
  cur_var =>NULL()
  cur_file =>NULL()

end subroutine write_data_3d_new
! </SUBROUTINE>  

!-------------------------------------------------------------------------------
!
!   The routine will register a scalar real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r0d(fileObj, filename, fieldname, data, domain, mandatory, &
                                    no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type),    intent(inout)      :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,                       intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  logical,          optional, intent(in)         :: no_domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: mandatory
  integer,          optional, intent(in)         :: position, tile_count
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r0d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r0d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 1/), index_field, domain, mandatory, &
                       no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p0dr(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 0
  register_restart_field_r0d = index_field  

  return    

end function register_restart_field_r0d

!-------------------------------------------------------------------------------
!
!   The routine will register a 1-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r1d(fileObj, filename, fieldname, data, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real, dimension(:),         intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  logical,          optional, intent(in)         :: no_domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r1d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r1d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data,1), 1, 1, 1/), index_field, domain, mandatory, &
                       no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units )

  fileObj%p1dr(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 1
  register_restart_field_r1d = index_field  

  return    
  
end function register_restart_field_r1d

!-------------------------------------------------------------------------------
!
!   The routine will register a 2-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r2d(fileObj, filename, fieldname, data, domain, mandatory, &
                                    no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,     dimension(:,:),   intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r2d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r2d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p2dr(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 2
  register_restart_field_r2d = index_field    

  return    

end function register_restart_field_r2d


!-------------------------------------------------------------------------------
!
!   The routine will register a 3-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r3d(fileObj, filename, fieldname, data, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,     dimension(:,:,:), intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r3d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r3d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p3dr(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 3
  register_restart_field_r3d = index_field   

  return    

end function register_restart_field_r3d

!-------------------------------------------------------------------------------
!
!   The routine will register a scalar integer restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i0d(fileObj, filename, fieldname, data, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,                    intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  logical,          optional, intent(in)         :: no_domain  
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i0d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i0d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 1/), index_field, domain, &
                       mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p0di(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 0
  register_restart_field_i0d = index_field
  
  return
   
end function register_restart_field_i0d

!-------------------------------------------------------------------------------
!
!   The routine will register a 1-D integer restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i1d(fileObj, filename, fieldname, data, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer, dimension(:),      intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  logical,          optional, intent(in)         :: no_domain
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i1d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i1d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data,1), 1, 1, 1/), index_field, domain, &
                       mandatory, no_domain=.true., scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p1di(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 1
  register_restart_field_i1d = index_field
  
  return
  
end function register_restart_field_i1d


!-------------------------------------------------------------------------------
!
!   The routine will register a 2-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i2d(fileObj, filename, fieldname, data, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,  dimension(:,:),   intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i2d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i2d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p2di(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 2
  register_restart_field_i2d = index_field
  
  return 

end function register_restart_field_i2d

!-------------------------------------------------------------------------------
!
!   The routine will register a 3-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i3d(fileObj, filename, fieldname, data, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,  dimension(:,:,:), intent(in), target :: data 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i3d

  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i3d): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p3di(fileObj%var(index_field)%siz(4), index_field)%p => data
  fileObj%var(index_field)%ndim = 3
  register_restart_field_i3d = index_field
  
  return  

end function register_restart_field_i3d

!-------------------------------------------------------------------------------
!
!   The routine will register a scalar real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r0d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,                       intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  logical,          optional, intent(in)         :: no_domain
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r0d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_r0d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 2/), index_field, domain, &
                       mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p0dr(1, index_field)%p => data1
  fileObj%p0dr(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 0
  register_restart_field_r0d_2level = index_field
  
  return  

end function register_restart_field_r0d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a 1-D real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r1d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,     dimension(:),     intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  logical,          optional, intent(in)         :: no_domain
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r1d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_r1d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), 1, 1, 2/), index_field, domain, &
                       mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p1dr(1, index_field)%p => data1
  fileObj%p1dr(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 1
  register_restart_field_r1d_2level = index_field
  
  return    

end function register_restart_field_r1d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a 3-D real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r2d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,     dimension(:,:),   intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r2d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_r2d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), 1, 2/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p2dr(1, index_field)%p => data1
  fileObj%p2dr(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 2
  register_restart_field_r2d_2level = index_field
  
  return    

end function register_restart_field_r2d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a 3-D real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r3d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  real,     dimension(:,:,:), intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_r3d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_r3d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), size(data1,3), 2/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p3dr(1, index_field)%p => data1
  fileObj%p3dr(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 3
  register_restart_field_r3d_2level = index_field
  
  return    

end function register_restart_field_r3d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a scalar integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i0d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,                    intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  logical,          optional, intent(in)         :: no_domain
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i0d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_i0d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 2/), index_field, domain, &
                       mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p0di(1, index_field)%p => data1
  fileObj%p0di(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 0
  register_restart_field_i0d_2level = index_field
  
  return   
 
end function register_restart_field_i0d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a 1-D integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i1d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,  dimension(:),     intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  logical,          optional, intent(in)         :: no_domain
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i1d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_i1d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), 1, 1, 2/), index_field, domain, &
                       mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
                       data_default=data_default, longname=longname, units=units)
  fileObj%p1di(1, index_field)%p => data1
  fileObj%p1di(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 1
  register_restart_field_i1d_2level = index_field
  
  return  
  
end function register_restart_field_i1d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a 3-D integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i2d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,  dimension(:,:),   intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i2d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_i2d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), 1, 2/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p2di(1, index_field)%p => data1
  fileObj%p2di(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 2
  register_restart_field_i2d_2level = index_field
  
  return    

end function register_restart_field_i2d_2level

!-------------------------------------------------------------------------------
!
!   The routine will register a 3-D integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i3d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
                             no_domain, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),           intent(in)         :: filename, fieldname
  integer,  dimension(:,:,:), intent(in), target :: data1, data2 
  type(domain2d),   optional, intent(in), target :: domain
  real,             optional, intent(in)         :: data_default
  logical,          optional, intent(in)         :: no_domain   
  integer,          optional, intent(in)         :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units
  integer                                        :: index_field
  integer                                        :: register_restart_field_i3d_2level

  if(.not.module_is_initialized) call mpp_error(FATAL, &
      'fms_io(register_restart_field_i3d_2level): need to call fms_io_init')  
  call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), size(data1,3), 2/), &
                       index_field, domain, mandatory, no_domain, .false., &
                       position, tile_count, data_default, longname, units)
  fileObj%p3di(1, index_field)%p => data1
  fileObj%p3di(2, index_field)%p => data2
  fileObj%var(index_field)%ndim = 3
  register_restart_field_i3d_2level = index_field
  
  return    

end function register_restart_field_i3d_2level

!-------------------------------------------------------------------------------
!
!  saves all registered variables to restart files. Those variables are set 
!  through register_restart_field
!
!-------------------------------------------------------------------------------

subroutine save_restart(fileObj, time_stamp, directory )
  type(restart_file_type), intent(inout) :: fileObj
  character(len=*), intent(in), optional :: directory
  character(len=*), intent(in), optional :: time_stamp
  ! Arguments: 
  !  (in)      directory  - The directory where the restart file goes.
  !  (in)      time_stamp - character format of the time of this restart file.
  character(len=256) :: dir
  character(len=256) :: restartpath          ! The restart file path (dir/file).
  character(len=80)  :: restartname          ! The restart file name (no dir).
  character(len=8)   :: suffix               ! A suffix (like _2) that is appended to the name of files after the first.
  integer            :: var_sz, size_in_file ! The size in bytes of each variable and of the variables already in a file.
  integer            :: start_var, next_var  ! The starting variables of the current and next files.
  integer            :: unit                 ! The mpp unit of the open file.
  real, dimension(max_axis_size)      :: axisdata
  integer,        dimension(max_axes) :: id_x_axes, siz_x_axes
  integer,        dimension(max_axes) :: id_y_axes, siz_y_axes
  integer,        dimension(max_axes) :: id_z_axes, siz_z_axes
  type(axistype), dimension(max_axes) :: x_axes, y_axes, z_axes
  type(axistype)                      :: t_axes            
  integer                             :: num_var_axes
  type(axistype), dimension(4)        :: var_axes
  type(var_type), pointer, save       :: cur_var=>NULL()
  integer                             :: num_x_axes, num_y_axes, num_z_axes
  integer                             :: naxes_x, naxes_y, naxes_z
  integer                             :: nfiles, i, j, k, l, siz, ind_dom
  logical                             :: domain_present
  real(r8_kind)                       :: tlev  
  character(len=10)                   :: axisname  

  real, allocatable, dimension(:,:,:) :: r3d
  real, allocatable, dimension(:,:)   :: r2d, global_r2d
  real, allocatable, dimension(:)     :: r1d  
  real                                :: r0d

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(save_restart): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  do i=1,max_axis_size
     axisdata(i) = i
  enddo

  dir = "RESTART"
  if(present(directory)) dir = directory

  restartname = fileObj%name
  nfiles = 0
  if(time_stamp_restart) then
     if (PRESENT(time_stamp)) then
        restartname = trim(time_stamp)//"."//trim(restartname)
     endif
  end if
  if(len_trim(dir) > 0) then
     restartpath = trim(dir)//"/"// trim(restartname)
  else
     restartpath = trim(restartname)
  end if
  !--- check if any field in this file present domain.
  domain_present = .false.
  do j = 1, fileObj%nvar
     if (fileObj%var(j)%domain_present) then
        domain_present = .true.
        ind_dom = j
        exit
     end if
  end do
  num_x_axes = unique_axes(fileObj, 1, id_x_axes, siz_x_axes, domain_x)
  num_y_axes = unique_axes(fileObj, 2, id_y_axes, siz_y_axes, domain_y)
  num_z_axes = unique_axes(fileObj, 3, id_z_axes, siz_z_axes          )
  next_var = 1
  size_in_file = 0
  do j = 1, num_x_axes
     size_in_file = size_in_file + siz_x_axes(j)
  end do
  do j = 1, num_y_axes
     size_in_file = size_in_file + siz_y_axes(j)
  end do
  do j = 1, num_z_axes
     size_in_file = size_in_file + siz_z_axes(j)
  end do
  size_in_file = 8*(size_in_file*2+1000)

  do while (next_var <= fileObj%nvar )
     start_var = next_var

     do j=start_var,fileObj%nvar
        cur_var => fileObj%var(j)
        var_sz = 8*cur_var%csiz(1)*cur_var%csiz(2)*cur_var%csiz(3)
        if ((j==start_var) .OR. (size_in_file < MAX_FILE_SIZE-var_sz)) then
           size_in_file = size_in_file + var_sz
        else 
           exit
        endif
     enddo
     next_var = j
     ! For distribute write, normally will not over the limit. 
     if( nfiles > 0 ) then
        if(fset_w == MPP_MULTI .AND. domain_present) call mpp_error(FATAL, "fms_io_mod(save_restart): "// &
             "For distribute write(fileset_write='multi'), the file size should not be very large and need to be split")
        if (nfiles < 10) then
           write(suffix,'("_",I1)') nfiles
        else if(nfiles < 100) then
           write(suffix,'("_",I2)') nfiles
        else
           call mpp_error(FATAL, "fms_io(save_restart): num_files should be less than 100")
        endif
        !--- remove .nc from restartpath and attach suffix.
        siz = len_trim(restartpath)
        if(restartpath(siz-2:siz) == ".nc") then
           restartpath = restartpath(1:siz-3)//trim(suffix)
        else      
           restartpath = trim(restartpath) // trim(suffix)
        end if
     end if
     if( domain_present ) then
        call mpp_open(unit,trim(restartpath),action=MPP_OVERWR,form=form,threading=thread_w,&
             fileset=fset_w, is_root_pe=fileObj%is_root_pe, domain=array_domain(fileObj%var(ind_dom)%domain_idx) )
     else  ! global data
        call mpp_open(unit,trim(restartpath),action=MPP_OVERWR,form=form,threading=MPP_SINGLE,&
             fileset=MPP_SINGLE, is_root_pe=fileObj%is_root_pe)
     end if

     ! write_out x_axes
     naxes_x = 0
     do j = 1, num_x_axes
        ! make sure this axis is used by some variable 
        do l=start_var,next_var-1
           if( fileObj%var(l)%id_axes(1) == j ) exit
        end do
        if(l == next_var) cycle  
        naxes_x = naxes_x + 1
        if (naxes_x < 10) then
           write(axisname,'(a,i1)') 'xaxis_',naxes_x
        else
           write(axisname,'(a,i2)') 'xaxis_',naxes_x
        endif
        if(id_x_axes(j) > 0) then
           call mpp_write_meta(unit,x_axes(naxes_x),axisname,'none',axisname, &
                data=axisdata(1:siz_x_axes(j)),domain=domain_x(id_x_axes(j)),cartesian='X')
        else
           call mpp_write_meta(unit,x_axes(naxes_x),axisname,'none',axisname, &
                data=axisdata(1:siz_x_axes(j)),cartesian='X')
        endif
     end do

     ! write out y_axes
     naxes_y = 0
     do j = 1, num_y_axes
        ! make sure this axis is used by some variable 
        do l=start_var,next_var-1
           if( fileObj%var(l)%id_axes(2) == j ) exit
        end do
        if(l == next_var) cycle  
        naxes_y = naxes_y + 1
        if (naxes_y < 10) then
           write(axisname,'(a,i1)') 'yaxis_',naxes_y
        else
           write(axisname,'(a,i2)') 'yaxis_',naxes_y
        endif
        if(id_y_axes(j) > 0) then
           call mpp_write_meta(unit,y_axes(naxes_y),axisname,'none',axisname, &
                data=axisdata(1:siz_y_axes(j)),domain=domain_y(id_y_axes(j)),cartesian='Y')
        else
           call mpp_write_meta(unit,y_axes(naxes_y),axisname,'none',axisname, &
                data=axisdata(1:siz_y_axes(j)),cartesian='Y')
        endif
     end do

     ! write out z_axes
     naxes_z = 0
     do j = 1, num_z_axes
        ! make sure this axis is used by some variable 
        do l=start_var,next_var-1
           if( fileObj%var(l)%id_axes(3) == j ) exit
        end do
        if(l == next_var) cycle  
        naxes_z = naxes_z + 1
        if (naxes_z < 10) then
           write(axisname,'(a,i1)') 'zaxis_',naxes_z
        else
           write(axisname,'(a,i2)') 'zaxis_',naxes_z
        endif
        call mpp_write_meta(unit,z_axes(naxes_z),axisname,'none',axisname, &
             data=axisdata(1:siz_z_axes(j)),cartesian='Z')
     end do

     ! write out time axis  
     call mpp_write_meta(unit,t_axes,&
          'Time','time level','Time',cartesian='T')
     ! write metadata for fields
     do j = start_var,next_var-1
        cur_var => fileObj%var(j)
        if(cur_var%siz(4) > 1 .AND. cur_var%siz(4) .NE. fileObj%max_ntime ) call mpp_error(FATAL, &
         "fms_io(save_restart): "//trim(cur_var%name)//" in file "//trim(fileObj%name)// &
         " has more than one time level, but number of time level is not equal to max_ntime")

        if(cur_var%ndim == 0) then
           num_var_axes = 1
           var_axes(1) = t_axes
        else if(cur_var%ndim == 1) then
           num_var_axes = 1
           var_axes(1) = x_axes(cur_var%id_axes(1))
           if(cur_var%siz(4) == fileObj%max_ntime) then
              num_var_axes = 2
              var_axes(2) = t_axes
           end if
        else if(cur_var%ndim == 2) then
           num_var_axes = 2
           var_axes(1) = x_axes(cur_var%id_axes(1))
           var_axes(2) = y_axes(cur_var%id_axes(2))
           if(cur_var%siz(4) == fileObj%max_ntime) then
              num_var_axes = 3
              var_axes(3) = t_axes
           end if
        else if(cur_var%ndim == 3) then
           num_var_axes = 3
           var_axes(1) = x_axes(cur_var%id_axes(1))
           var_axes(2) = y_axes(cur_var%id_axes(2))
           var_axes(3) = z_axes(cur_var%id_axes(3))
           if(cur_var%siz(4) == fileObj%max_ntime) then
              num_var_axes = 4
              var_axes(4) = t_axes
           end if
        end if
        call mpp_write_meta(unit,cur_var%field, var_axes(1:num_var_axes), cur_var%name, &
                 cur_var%units,cur_var%longname,pack=1)
     enddo

     ! write values for ndim of spatial axes
     do j = 1, naxes_x
        call mpp_write(unit,x_axes(j))
     enddo
     do j = 1, naxes_y
        call mpp_write(unit,y_axes(j))
     enddo
     do j = 1, naxes_z
        call mpp_write(unit,z_axes(j))
     enddo

     ! write data of each field
     do k = 1, fileObj%max_ntime
        do j=start_var,next_var-1
           cur_var => fileObj%var(j)
           tlev=k
           ! If some fields only have one time level, we do not need to write the second level, just keep
           ! the data missing.
           if(k <= cur_var%siz(4)) then
              if(cur_var%domain_present) then  ! one 2-D or 3-D case possible present domain
                 if( Associated(fileObj%p2dr(k,j)%p) ) then
                    call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p2dr(k,j)%p, tlev, &
                                   default_data=cur_var%default_data)
                 else if( Associated(fileObj%p3dr(k,j)%p) ) then
                    call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p3dr(k,j)%p, tlev, &
                                   default_data=cur_var%default_data)
                 else if( Associated(fileObj%p2di(k,j)%p) ) then
                    allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
                    r2d = fileObj%p2di(k,j)%p
                    call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), r2d, tlev, &
                                   default_data=cur_var%default_data)
                    deallocate(r2d)
                 else if( Associated(fileObj%p3di(k,j)%p) ) then
                    allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
                    r3d = fileObj%p3di(k,j)%p
                    call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), r3d, tlev, &
                                   default_data=cur_var%default_data)
                    deallocate(r3d)
                 else
                    call mpp_error(FATAL, "fms_io(save_restart): domain is present and thread_w  "// &
                         "is MPP_MULTI, field "//trim(cur_var%name)//" of file "//trim(fileObj%name)// &
                         ", but none of p2dr, p3dr, p2di and p3di is associated") 
                 end if
              else if (thread_w == MPP_MULTI .or. cur_var%write_on_this_pe .or. &
                       (fileObj%is_root_pe.and.thread_w == MPP_SINGLE)) then     
                 if ( Associated(fileObj%p0dr(k,j)%p) ) then
                    call mpp_write(unit, cur_var%field, fileObj%p0dr(k,j)%p, tlev)
                 else if ( Associated(fileObj%p1dr(k,j)%p) ) then
                    call mpp_write(unit, cur_var%field, fileObj%p1dr(k,j)%p, tlev)
                 else if ( Associated(fileObj%p2dr(k,j)%p) ) then
                    call mpp_write(unit, cur_var%field, fileObj%p2dr(k,j)%p, tlev)
                 else if ( Associated(fileObj%p3dr(k,j)%p) ) then
                    call mpp_write(unit, cur_var%field, fileObj%p3dr(k,j)%p, tlev)
                 else if ( Associated(fileObj%p0di(k,j)%p) ) then
                    r0d =  fileObj%p0di(k,j)%p
                    call mpp_write(unit, cur_var%field, r0d,                  tlev)
                 else if ( Associated(fileObj%p1di(k,j)%p) ) then
                    allocate(r1d(cur_var%siz(1)) )
                    r1d = fileObj%p1di(k,j)%p
                    call mpp_write(unit, cur_var%field, r1d,                  tlev)
                    deallocate(r1d)
                 else if ( Associated(fileObj%p2di(k,j)%p) ) then
                    allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
                    r2d = fileObj%p2di(k,j)%p
                    call mpp_write(unit, cur_var%field, r2d,                  tlev)
                    deallocate(global_r2d, r2d)
                 else if ( Associated(fileObj%p3di(k,j)%p) ) then
                    allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
                    r3d = fileObj%p3di(k,j)%p
                    call mpp_write(unit, cur_var%field, r3d,                  tlev)
                    deallocate(r3d)
                 else
                    call mpp_error(FATAL, "fms_io(save_restart): There is no pointer associated with the data of  field "// &
                         trim(cur_var%name)//" of file "//trim(fileObj%name) )
                 end if
              end if
           end if
        enddo ! end j loop
     enddo ! end k loop
     call mpp_close(unit)
     nfiles = nfiles+1
  enddo

  cur_var =>NULL()

  if(print_chksum) call write_chksum(fileObj, MPP_OVERWR)

end subroutine save_restart

!-------------------------------------------------------------------------------
!    This subroutine will calculate chksum and print out chksum information.
!
subroutine write_chksum(fileObj, action)
  type(restart_file_type), intent(inout) :: fileObj
  integer,                 intent(in)    :: action
  integer(LONG_KIND)                     :: data_chksum
  integer                                :: j, k, outunit
  type(var_type), pointer, save          :: cur_var=>NULL()
  character(len=32)                      :: routine_name

  if(action == MPP_OVERWR) then
     routine_name = "save_restart"
  else if(action == MPP_RDONLY) then
     routine_name = "restore_state"
  else
     call mpp_error(FATAL, "fms_io_mod(write_chksum): action should be MPP_OVERWR or MPP_RDONLY")
  endif

  do j=1,fileObj%nvar
     cur_var => fileObj%var(j)
     if(action == MPP_OVERWR .OR. (action == MPP_RDONLY .AND. cur_var%initialized) ) then 
        do k = 1, cur_var%siz(4)
           if ( Associated(fileObj%p0dr(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p0dr(k,j)%p, (/mpp_pe()/) )
           else if ( Associated(fileObj%p1dr(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p1dr(k,j)%p, (/mpp_pe()/) )
           else if ( Associated(fileObj%p2dr(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p2dr(k,j)%p(cur_var%is:cur_var%ie,cur_var%js:cur_var%je) )
           else if ( Associated(fileObj%p3dr(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p3dr(k,j)%p(cur_var%is:cur_var%ie,cur_var%js:cur_var%je, :) )
           else if ( Associated(fileObj%p0di(k,j)%p) ) then
              data_chksum = fileObj%p0di(k,j)%p
           else if ( Associated(fileObj%p1di(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p1di(k,j)%p, (/mpp_pe()/) )
           else if ( Associated(fileObj%p2di(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p2di(k,j)%p(cur_var%is:cur_var%ie,cur_var%js:cur_var%je) )
           else if ( Associated(fileObj%p3di(k,j)%p) ) then
              data_chksum = mpp_chksum(fileObj%p3di(k,j)%p(cur_var%is:cur_var%ie,cur_var%js:cur_var%je, :))
           else
              call mpp_error(FATAL, "fms_io(write_chksum): There is no pointer associated with the data of  field "// &
                   trim(cur_var%name)//" of file "//trim(fileObj%name) )
           end if
           outunit = stdout()
           write(outunit,'(a, I1, a, I16)')'fms_io('//trim(routine_name)//'): At time level = ', k, ', chksum for "'// &
                trim(cur_var%name)// '" of "'// trim(fileObj%name)// '" = ', data_chksum    

        enddo
     endif
  enddo
  cur_var =>NULL()

end subroutine write_chksum

!-------------------------------------------------------------------------------
!
!    This subroutine reads the model state from previously
!    generated files.  All restart variables are read from the first
!    file in the input filename list in which they are found.

subroutine restore_state_all(fileObj, directory)
  type(restart_file_type), intent(inout)       :: fileObj
  character(len=*),      intent(in), optional  :: directory

! Arguments: 
!  (in)      directory - The directory where the restart or save
!                        files should be found. The default is 'INPUT'

  character(len=128) :: dir    
  character(len=256) :: restartpath ! The restart file path (dir/file). 
  character(len=200) :: filepath    ! The path (dir/file) to the file being opened.
  character(len=8)   :: suffix      ! A suffix (like "_2") that is added to any
                                    ! additional restart files.
  character(len=80)  :: varname     ! A variable's name.
  character(len=256) :: filename
  integer            :: num_restart ! The number of restart files that have already
                                    ! been opened.
  integer            :: nfile       ! The number of files (restart files and others
                                    ! explicitly in filename) that are open.
  integer   :: unit(max_split_file) ! The mpp unit of all open files.
  type(var_type), pointer, save       :: cur_var=>NULL()
  integer                             :: ndim, nvar, natt, ntime, tlev, siz
  type(fieldtype), allocatable        :: fields(:)
  logical                             :: fexist, domain_present
  integer                             :: j, n, l, k, missing_fields, domain_idx
  integer                             :: tile_id(1)
  real, allocatable, dimension(:,:,:) :: r3d
  real, allocatable, dimension(:,:)   :: r2d
  real, allocatable, dimension(:)     :: r1d  
  real                                :: r0d
  type(domain2d), pointer, save       :: io_domain=>NULL()

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(restore_state_all): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  dir = 'INPUT'
  if(present(directory)) dir = directory

  num_restart = 0
  nfile = 0
  if(len_trim(dir) > 0) then
     restartpath = trim(dir)//"/"// trim(fileObj%name)
  else
     restartpath = trim(fileObj%name)
  end if

  domain_present = .false.
  do j = 1, fileObj%nvar
     if (fileObj%var(j)%domain_present) then
        domain_present = .true.
        domain_idx = fileObj%var(j)%domain_idx
        exit
     end if
  end do

  !--- first open all the restart files
  !--- NOTE: For distributed restart file, we are assuming there is only one file exist.

  inquire (file=trim(restartpath)//trim(pe_name), exist=fexist)
  if(.NOT. fexist .and. domain_present) then
     io_domain => mpp_get_io_domain(array_domain(domain_idx))
     if(associated(io_domain)) then
        tile_id = mpp_get_tile_id(io_domain)
        if(mpp_npes() > 10000) then
           write(filename, '(a,i6.6)' ) trim(restartpath)//'.', tile_id(1)
        else
           write(filename, '(a,i4.4)' ) trim(restartpath)//'.', tile_id(1)
        endif
        inquire (file=trim(filename), exist = fexist)
     endif
     io_domain => NULL()
  endif
  if(fexist) then
     nfile = 1
     if(domain_present) then
        call mpp_open(unit(nfile), trim(restartpath), form=form,action=MPP_RDONLY,threading=thread_r, &
             fileset=MPP_MULTI, domain=array_domain(domain_idx) )
     else
        call mpp_open(unit(nfile), trim(restartpath), form=form,action=MPP_RDONLY,threading=thread_r, &
             fileset=MPP_MULTI)
     endif
  else
     do while(.true.)
        if (num_restart < 10) then
           write(suffix,'("_",I1)') num_restart
        else
           write(suffix,'("_",I2)') num_restart
        endif
        if (num_restart > 0) then
           siz = len_trim(restartpath)
           if(restartpath(siz-2:siz) == ".nc") then
              filepath = restartpath(1:siz-3)//trim(suffix)
           else      
              filepath = trim(restartpath) // trim(suffix)
           end if
        else
           filepath = trim(restartpath)
        end if
        inquire (file=trim(filepath), exist=fexist) 
        if(.not. fexist) inquire(file=trim(filepath)//".nc", exist=fexist)
        if(fexist) then
           nfile = nfile + 1
           if(nfile > max_split_file) call mpp_error(FATAL, &
                "fms_io(restore_state_all): nfile is larger than max_split_file, increase max_split_file")
           call mpp_open(unit(nfile), trim(filepath), form=form,action=MPP_RDONLY,threading=thread_r, &
                fileset=MPP_SINGLE)
        else
           exit
        end if
        num_restart = num_restart + 1
     end do
  end if
  if(nfile == 0) call mpp_error(FATAL, "fms_io(restore_state_all): unable to find any restart files "// &
       "specified by "//trim(restartpath))


  ! Read each variable from the first file in which it is found.
  do n=1,nfile
     call mpp_get_info(unit(n), ndim, nvar, natt, ntime)

     allocate(fields(nvar))
     call mpp_get_fields(unit(n),fields(1:nvar))

     missing_fields = 0

     do j=1,fileObj%nvar
        cur_var => fileObj%var(j)
        domain_present = cur_var%domain_present
        domain_idx = cur_var%domain_idx
        do l=1, nvar
           call mpp_get_atts(fields(l),name=varname)
           if (lowercase(trim(varname)) == lowercase(trim(cur_var%name))) then
              cur_var%initialized = .true.
              do k = 1, cur_var%siz(4)
                 tlev = k
                 if(domain_present) then 
                    if( Associated(fileObj%p0dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), fileObj%p0dr(k,j)%p, tlev)
                    else if( Associated(fileObj%p1dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), fileObj%p1dr(k,j)%p, tlev)       
                    else if( Associated(fileObj%p2dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), array_domain(domain_idx), fileObj%p2dr(k,j)%p, tlev)
                    else if( Associated(fileObj%p3dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), array_domain(domain_idx), fileObj%p3dr(k,j)%p, tlev)
                    else if( Associated(fileObj%p0di(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), r0d, tlev)
                       fileObj%p0di(k,j)%p = r0d
                    else if( Associated(fileObj%p1di(k,j)%p) ) then
                       allocate(r1d(cur_var%siz(1)))
                       call mpp_read(unit(n), fields(l), r1d, tlev)
                       fileObj%p1di(k,j)%p = r1d
                       deallocate(r1d)
                    else if( Associated(fileObj%p2di(k,j)%p) ) then
                       allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
                       r2d = 0
                       call mpp_read(unit(n), fields(l), array_domain(domain_idx), r2d, tlev)
                       fileObj%p2di(k,j)%p = r2d
                       deallocate(r2d)
                    else if( Associated(fileObj%p3di(k,j)%p) ) then
                       allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
                       r3d = 0
                       call mpp_read(unit(n), fields(l), array_domain(domain_idx), r3d, tlev)
                       fileObj%p3di(k,j)%p = r3d
                       deallocate(r3d)
                    else
                       call mpp_error(FATAL, "fms_io(restore_state_all): domain is present for the field "//trim(varname)// &
                            " of file "//trim(fileObj%name)//", but none of p2dr, p3dr, p2di and p3di is associated") 
                    end if
                 else
                    if( Associated(fileObj%p0dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), fileObj%p0dr(k,j)%p, tlev)
                    else if( Associated(fileObj%p1dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), fileObj%p1dr(k,j)%p, tlev)
                    else if( Associated(fileObj%p2dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), fileObj%p2dr(k,j)%p, tlev)
                    else if( Associated(fileObj%p3dr(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), fileObj%p3dr(k,j)%p, tlev) 
                    else if( Associated(fileObj%p0di(k,j)%p) ) then
                       call mpp_read(unit(n), fields(l), r0d, tlev)
                       fileObj%p0di(k,j)%p = r0d
                    else if( Associated(fileObj%p1di(k,j)%p) ) then
                       allocate(r1d(cur_var%siz(1)) )
                       call mpp_read(unit(n), fields(l), r1d, tlev)                
                       fileObj%p1di(k,j)%p = r1d
                       deallocate(r1d)
                    else if( Associated(fileObj%p2di(k,j)%p) ) then
                       allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
                       r2d = 0
                       call mpp_read(unit(n), fields(l), r2d, tlev)                
                       fileObj%p2di(k,j)%p = r2d
                       deallocate(r2d)
                    else if( Associated(fileObj%p3di(k,j)%p) ) then
                       allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
                       r3d = 0
                       call mpp_read(unit(n), fields(l), r3d, tlev)                
                       fileObj%p3di(k,j)%p = r3d
                       deallocate(r3d)
                    else
                       call mpp_error(FATAL, "fms_io(restore_state_all): There is no pointer "//&
                            "associated with the data of  field "// trim(varname)//" of file "//trim(fileObj%name) )
                    end if
                 end if
              end do
              exit ! Start search for next restart variable.
           endif
        enddo
        if (l>nvar) missing_fields = missing_fields+1
     enddo

     deallocate(fields)
     if (missing_fields == 0) exit
  enddo

  do n=1,nfile
     call close_file(unit(n))
  enddo

  ! check whether all fields have been found
  do j = 1, fileObj%nvar
     if( .NOT. fileObj%var(j)%initialized ) then
        if( fileObj%var(j)%mandatory ) then
           call mpp_error(FATAL, "fms_io(restore_state_all): unable to find mandatory variable "// &
                trim(fileObj%var(j)%name)//" in restart file "//trim(fileObj%name) )
        end if
     end if
  end do
  cur_var =>NULL()

  if(print_chksum) call write_chksum(fileObj, MPP_RDONLY )

end subroutine restore_state_all

!-------------------------------------------------------------------------------
!
!    This subroutine reads the model state from previously
!    generated files.  All restart variables are read from the first
!    file in the input filename list in which they are found.

subroutine restore_state_one_field(fileObj, id_field, directory)
  type(restart_file_type), intent(inout)       :: fileObj
  integer,                 intent(in)          :: id_field
  character(len=*),      intent(in), optional  :: directory

! Arguments: 
!  (in)      directory - The directory where the restart or save
!                        files should be found. The default is 'INPUT'

  character(len=128) :: dir    
  character(len=256) :: restartpath ! The restart file path (dir/file). 
  character(len=200) :: filepath    ! The path (dir/file) to the file being opened.
  character(len=8)   :: suffix      ! A suffix (like "_2") that is added to any
                                    ! additional restart files.
  character(len=80)  :: varname     ! A variable's name.
  character(len=256) :: filename
  integer            :: num_restart ! The number of restart files that have already
                                    ! been opened.
  integer            :: nfile       ! The number of files (restart files and others
                                    ! explicitly in filename) that are open.
  integer   :: unit(max_split_file) ! The mpp unit of all open files.
  type(var_type), pointer, save       :: cur_var=>NULL()
  integer                             :: ndim, nvar, natt, ntime, tlev, siz
  integer                             :: tile_id(1)
  type(fieldtype), allocatable        :: fields(:)
  logical                             :: fexist, domain_present
  integer                             :: j, n, l, k, missing_fields, domain_idx
  real, allocatable, dimension(:,:,:) :: r3d
  real, allocatable, dimension(:,:)   :: r2d
  real, allocatable, dimension(:)     :: r1d  
  real                                :: r0d
  type(domain2d), pointer, save       :: io_domain=>NULL()

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(restore_state_one_field): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  dir = 'INPUT'
  if(present(directory)) dir = directory

  cur_var => fileObj%var(id_field)
  domain_present = cur_var%domain_present
  domain_idx = cur_var%domain_idx

  num_restart = 0
  nfile = 0
  if(len_trim(dir) > 0) then
     restartpath = trim(dir)//"/"// trim(fileObj%name)
  else
     restartpath = trim(fileObj%name)
  end if
  !--- first open all the restart files
  !--- NOTE: For distributed restart file, we are assuming there is only one file exist.
  inquire (file=trim(restartpath)//trim(pe_name), exist=fexist)     
  if(.NOT. fexist .and. domain_present) then
     io_domain => mpp_get_io_domain(array_domain(domain_idx))
     if(associated(io_domain)) then
        tile_id = mpp_get_tile_id(io_domain)
        if(mpp_npes()>10000) then
           write(filename, '(a,i6.6)' ) trim(restartpath)//'.', tile_id(1)
        else
           write(filename, '(a,i4.4)' ) trim(restartpath)//'.', tile_id(1)
        endif
        inquire (file=trim(filename), exist = fexist)
     endif
     io_domain=>NULL()
  endif

  if(fexist) then
     nfile = 1
     if(domain_present) then
        call mpp_open(unit(nfile), trim(restartpath), form=form,action=MPP_RDONLY,threading=thread_r, &
             fileset=MPP_MULTI, domain=array_domain(domain_idx) )
     else
        call mpp_open(unit(nfile), trim(restartpath), form=form,action=MPP_RDONLY,threading=thread_r, &
             fileset=MPP_MULTI)
     endif
  else
     do while(.true.)
        if (num_restart < 10) then
           write(suffix,'("_",I1)') num_restart
        else
           write(suffix,'("_",I2)') num_restart
        endif
        if (num_restart > 0) then
           siz = len_trim(restartpath)
           if(restartpath(siz-2:siz) == ".nc") then
              filepath = restartpath(1:siz-3)//trim(suffix)
           else      
              filepath = trim(restartpath) // trim(suffix)
           end if
        else
           filepath = trim(restartpath)
        end if
        inquire (file=trim(filepath), exist=fexist) 
        if(.not. fexist) inquire(file=trim(filepath)//".nc", exist=fexist)
        if(fexist) then
           nfile = nfile + 1
           if(nfile > max_split_file) call mpp_error(FATAL, &
                "fms_io(restore_state_one_field): nfile is larger than max_split_file, increase max_split_file")
           call mpp_open(unit(nfile), trim(filepath), form=form,action=MPP_RDONLY,threading=thread_r, &
                fileset=MPP_SINGLE)
        else
           exit
        end if
        num_restart = num_restart + 1
     end do
  end if
  if(nfile == 0) call mpp_error(FATAL, "fms_io(restore_state_one_field): unable to find any restart files "// &
       "specified by "//trim(restartpath))


  ! Read each variable from the first file in which it is found.
  do n=1,nfile
     call mpp_get_info(unit(n), ndim, nvar, natt, ntime)

     allocate(fields(nvar))
     call mpp_get_fields(unit(n),fields(1:nvar))

     missing_fields = 0
     j = id_field
     do l=1, nvar
        call mpp_get_atts(fields(l),name=varname)
        if (lowercase(trim(varname)) == lowercase(trim(cur_var%name))) then
           cur_var%initialized = .true.
           do k = 1, cur_var%siz(4)
              tlev = k
              if(domain_present) then        
                 if( Associated(fileObj%p0dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), fileObj%p0dr(k,j)%p, tlev)
                 else if( Associated(fileObj%p1dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), fileObj%p1dr(k,j)%p, tlev)       
                 else if( Associated(fileObj%p2dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), array_domain(domain_idx), fileObj%p2dr(k,j)%p, tlev)
                 else if( Associated(fileObj%p3dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), array_domain(domain_idx), fileObj%p3dr(k,j)%p, tlev)
                 else if( Associated(fileObj%p0di(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), r0d, tlev)
                    fileObj%p0di(k,j)%p = r0d
                 else if( Associated(fileObj%p1di(k,j)%p) ) then
                    allocate(r1d(cur_var%siz(1)))
                    call mpp_read(unit(n), fields(l), r1d, tlev)
                    fileObj%p1di(k,j)%p = r1d
                    deallocate(r1d)
                 else if( Associated(fileObj%p2di(k,j)%p) ) then
                    allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
                    r2d = 0
                    call mpp_read(unit(n), fields(l), array_domain(domain_idx), r2d, tlev)
                    fileObj%p2di(k,j)%p = r2d
                    deallocate(r2d)
                 else if( Associated(fileObj%p3di(k,j)%p) ) then
                    allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
                    r3d = 0
                    call mpp_read(unit(n), fields(l), array_domain(domain_idx), r3d, tlev)
                    fileObj%p3di(k,j)%p = r3d
                    deallocate(r3d)
                 else
                    call mpp_error(FATAL, "fms_io(restore_state_one_field): domain is present for the field "//trim(varname)// &
                         " of file "//trim(fileObj%name)//", but none of p2dr, p3dr, p2di and p3di is associated") 
                 end if
              else
                 if( Associated(fileObj%p0dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), fileObj%p0dr(k,j)%p, tlev)
                 else if( Associated(fileObj%p1dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), fileObj%p1dr(k,j)%p, tlev)
                 else if( Associated(fileObj%p2dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), fileObj%p2dr(k,j)%p, tlev)
                 else if( Associated(fileObj%p3dr(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), fileObj%p3dr(k,j)%p, tlev) 
                 else if( Associated(fileObj%p0di(k,j)%p) ) then
                    call mpp_read(unit(n), fields(l), r0d, tlev)
                    fileObj%p0di(k,j)%p = r0d
                 else if( Associated(fileObj%p1di(k,j)%p) ) then
                    allocate(r1d(cur_var%siz(1)) )
                    call mpp_read(unit(n), fields(l), r1d, tlev)                
                    fileObj%p1di(k,j)%p = r1d
                    deallocate(r1d)
                 else if( Associated(fileObj%p2di(k,j)%p) ) then
                    allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
                    r2d = 0
                    call mpp_read(unit(n), fields(l), r2d, tlev)                
                    fileObj%p2di(k,j)%p = r2d
                    deallocate(r2d)
                 else if( Associated(fileObj%p3di(k,j)%p) ) then
                    allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
                    r3d = 0
                    call mpp_read(unit(n), fields(l), r3d, tlev)                
                    fileObj%p3di(k,j)%p = r3d
                    deallocate(r3d)
                 else
                    call mpp_error(FATAL, "fms_io(restore_state_one_field): There is no pointer "// &
                         "associated with the data of  field "//trim(varname)//" of file "//trim(fileObj%name) )
                 end if
              end if
           end do
           exit ! Start search for next restart variable.
        endif
     enddo
     if (l>nvar) missing_fields = missing_fields+1
     deallocate(fields)
     if (missing_fields == 0) exit
  enddo

  do n=1,nfile
     call close_file(unit(n))
  enddo

  ! check whether the field have been found
  if( .NOT. fileObj%var(id_field)%initialized ) then
     if( fileObj%var(id_field)%mandatory ) then
        call mpp_error(FATAL, "fms_io(restore_state_one_field): unable to find mandatory variable "// &
             trim(fileObj%var(id_field)%name)//" in restart file "//trim(fileObj%name) )
     end if
  end if
  cur_var =>NULL()

end subroutine restore_state_one_field

!-------------------------------------------------------------------------------
!
!     This routine will setup one entry to be written out 
!
!-------------------------------------------------------------------------------
subroutine setup_one_field(fileObj, filename, fieldname, field_siz, index_field,  domain, mandatory, &
                           no_domain, scalar_or_1d, position, tile_count, data_default, longname, units)
  type(restart_file_type), intent(inout)         :: fileObj
  character(len=*),         intent(in)           :: filename, fieldname 
  integer, dimension(:),    intent(in)           :: field_siz
  integer,                  intent(out)          :: index_field
  type(domain2d), optional, intent(in), target   :: domain
  real,           optional, intent(in)           :: data_default
  logical,        optional, intent(in)           :: no_domain
  logical,        optional, intent(in)           :: scalar_or_1d   
  integer,        optional, intent(in)           :: position, tile_count
  logical,          optional, intent(in)         :: mandatory
  character(len=*), optional, intent(in)         :: longname, units

  !--- local variables
  integer                         :: i, domain_idx
  integer                         :: ishift, jshift
  integer                         :: gxsize, gysize
  integer                         :: cxsize, cysize
  integer                         :: dxsize, dysize
  real                            :: default_data
  logical                         :: is_no_domain = .false.
  logical                         :: is_scalar_or_1d = .false.
  character(len=256)              :: fname, filename2, append_string
  type(domain2d), pointer, save   :: d_ptr   =>NULL()
  type(var_type), pointer, save   :: cur_var =>NULL()
  type(domain2d), pointer, save   :: io_domain =>NULL()
  integer                         :: length

  if(ANY(field_siz < 1)) then
     call mpp_error(FATAL, "fms_io(setup_one_field): each entry of field_size should be a positive integer")
  end if

  if(PRESENT(data_default))then
     default_data=data_default
  else
     default_data=0.
  endif

  if(present(tile_count) .AND. .not. present(domain)) call mpp_error(FATAL, &
         'fms_io(setup_one_field): when tile_count is present, domain must be present')

  is_scalar_or_1d = .false.
  if(PRESENT(scalar_or_1d)) is_scalar_or_1d = scalar_or_1d

  is_no_domain = .false.
  if (PRESENT(no_domain)) THEN
     is_no_domain = no_domain
  end if

  if(is_no_domain) then
     if(PRESENT(domain)) &
       call mpp_error(FATAL, 'fms_io(setup_one_field): no_domain cannot be .true. when optional argument domain is present.')
  else if(PRESENT(domain))then
     d_ptr => domain
  else if (ASSOCIATED(Current_domain)) then
     d_ptr => Current_domain
  endif

  !--- remove .nc from file name
  length = len_trim(filename)
  if(filename(length-2:length) == '.nc') then
     filename2 = filename(1:length-3)
  else
     filename2 = filename(1:length)
  end if

  !Append a string to the file name
  append_string=''
  !If the filename_appendix  is set override the passed argument. 
  if(len_trim(filename_appendix) > 0)   append_string = filename_appendix

  if(len_trim(append_string) > 0) filename2 = trim(filename2)//'.'//trim(append_string)

  !JWD:  This is likely a temporary fix. Since fms_io needs to know tile_count,
  !JWD:  I just don't see how the physics can remain "tile neutral"
  !z1l:  one solution is add one more public interface called set_tile_count
  call get_mosaic_tile_file(filename2, fname, is_no_domain, domain, tile_count)

  if(Associated(fileObj%var) ) then
     ! make sure the consistency of file name
     if(trim(fileObj%name) .NE. trim(fname)) call mpp_error(FATAL, 'fms_io(setup_one_field): filename = '// &
         trim(fname)//' is not consistent with the filename of the restart object = '//trim(fileObj%name) )
  else
     allocate(fileObj%var(max_fields) )
     allocate(fileObj%p0dr(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p1dr(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p2dr(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p3dr(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p0di(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p1di(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p2di(MAX_TIME_LEVEL_REGISTER, max_fields))
     allocate(fileObj%p3di(MAX_TIME_LEVEL_REGISTER, max_fields))
     !--- make sure fname is not used in other restart_file_type object.
     do i = 1, num_registered_files
        if(trim(fname) == trim(registered_file(i)) ) call mpp_error(FATAL, &
          'fms_io(setup_one_field): '//trim(fname)//' is already registered with other restart_file_type data')
     end do
     num_registered_files = num_registered_files + 1
     registered_file(num_registered_files) = trim(fname)
     fileObj%name = trim(fname)         
     fileObj%tile_count=1
     if(present(tile_count)) fileObj%tile_count = tile_count
     if(ASSOCIATED(d_ptr))then
        fileObj%is_root_pe = mpp_domain_is_tile_root_pe(d_ptr)
     else
        fileObj%is_root_pe = mpp_pe() == mpp_root_pe()
     endif
     fileObj%max_ntime = field_siz(4)
     fileObj%nvar      = 0
     !-- allocate memory
     do i = 1, max_fields
        fileObj%var(i)%name           = 'none'
        fileObj%var(i)%domain_present = .false.
        fileObj%var(i)%write_on_this_pe = .false.
        fileObj%var(i)%domain_idx     = -1
        fileObj%var(i)%is_dimvar      = .false.
        fileObj%var(i)%position       = CENTER
        fileObj%var(i)%siz(:)         = 0
        fileObj%var(i)%gsiz(:)        = 0
        fileObj%var(i)%id_axes(:)     = -1
        fileObj%var(i)%longname       = "";
        fileObj%var(i)%units          = "none";
        fileObj%var(i)%mandatory      = .true.
        fileObj%var(i)%initialized    = .false.
     end do
  endif

  ! check if the field is new or not and get position and dimension of the field
  index_field = -1
  do i = 1, fileObj%nvar
     if(trim(fileObj%var(i)%name) == trim(fieldname)) then
        index_field = i
        exit
     end if 
  end do

  if(index_field > 0) then
     cur_var   => fileObj%var(index_field)
     if(cur_var%siz(1) .NE. field_siz(1) .OR. cur_var%siz(2) .NE. field_siz(2) .OR. cur_var%siz(3) .NE. field_siz(3) ) &
        call mpp_error(FATAL, 'fms_io(setup_one_field): field size mismatch for field '// &
                       trim(fieldname)//' of file '//trim(filename) )

     cur_var%siz(4) =  cur_var%siz(4) + field_siz(4)
     if(fileObj%max_ntime < cur_var%siz(4) ) fileObj%max_ntime = cur_var%siz(4)
     ! the time level should be no larger than MAX_TIME_LEVEL_REGISTER ( = 2) 
     if( cur_var%siz(4) > MAX_TIME_LEVEL_REGISTER ) call mpp_error(FATAL, 'fms_io(setup_one_field): ' // &
          'the time level of field '//trim(cur_var%name)//' in file '//trim(fileObj%name)// &
          ' is greater than MAX_TIME_LEVEL_REGISTER(=2), increase MAX_TIME_LEVEL_REGISTER or check your code')
  else 
     fileObj%nvar = fileObj%nvar +1
     if(fileObj%nvar>max_fields) then
        write(error_msg,'(I3,"/",I3)') fileObj%nvar, max_fields 
        call  mpp_error(FATAL,'fms_io(setup_one_field): max_fields exceeded, needs increasing, nvar/max_fields=' &
             //trim(error_msg))
     endif
     index_field =  fileObj%nvar
     cur_var   => fileObj%var(index_field)
     cur_var%siz(:)  = field_siz(:)
     cur_var%gsiz(3) = field_siz(3)
     cur_var%csiz(3) = field_siz(3)
     cur_var%name = fieldname
     cur_var%default_data = default_data
     if(present(mandatory)) cur_var%mandatory = mandatory
     if(present(longname)) then
        cur_var%longname = longname
     else
        cur_var%longname = fieldname
     end if
     if(present(units))    cur_var%units    = units
     if(present(position)) cur_var%position = position
     cur_var%is = 1; cur_var%ie =  cur_var%siz(1) 
     cur_var%js = 1; cur_var%je =  cur_var%siz(2)
     if(ASSOCIATED(d_ptr)) then
        io_domain => mpp_get_io_domain(d_ptr)
        if(associated(io_domain)) then
           if(mpp_domain_is_tile_root_pe(io_domain)) cur_var%write_on_this_pe = .true.
        endif
     endif
     
     if(ASSOCIATED(d_ptr) .AND. .NOT. is_scalar_or_1d ) then
        cur_var%domain_present = .true.
        domain_idx = lookup_domain(d_ptr)
        if(domain_idx == -1) then
           num_domains = num_domains + 1
           if(num_domains > max_domains) call  mpp_error(FATAL,'fms_io(setup_one_field), 1: max_domains exceeded,' &
                //' needs increasing')
           domain_idx = num_domains
           array_domain(domain_idx) = d_ptr
           call mpp_get_domain_components(array_domain(domain_idx), domain_x(domain_idx), domain_y(domain_idx), &
                tile_count=tile_count)
        endif
        cur_var%domain_idx = domain_idx
        call mpp_get_domain_shift ( array_domain(domain_idx), ishift, jshift, position)
        call mpp_get_global_domain(array_domain(domain_idx), xsize=gxsize,ysize=gysize,tile_count=tile_count)
        call mpp_get_compute_domain(array_domain(domain_idx), xsize = cxsize, ysize = cysize, tile_count=tile_count)
        call mpp_get_data_domain   (array_domain(domain_idx), xsize = dxsize, ysize = dysize, tile_count=tile_count)
        if (ishift .NE. 0) then
           cxsize = cxsize+ishift; dxsize = dxsize+ishift; gxsize = gxsize + ishift
        end if
        if (jshift .NE. 0) then
           cysize = cysize+jshift; dysize = dysize+jshift; gysize = gysize + jshift
        endif
        if( (cur_var%siz(1) .NE. cxsize .AND. cur_var%siz(1) .NE. dxsize ) .OR. &
            (cur_var%siz(2) .NE. cysize .AND. cur_var%siz(2) .NE. dysize ) ) then
            call mpp_error(FATAL, 'fms_io(setup_one_field): data should be on either computer domain '//&
              'or data domain when domain is present for field '//trim(fieldname)//' of file '//trim(filename) )
        end if
        cur_var%is   = 1 + (cur_var%siz(1) - cxsize)/2
        cur_var%ie   = cur_var%is + cxsize - 1;
        cur_var%js   = 1 + (cur_var%siz(2) - cysize)/2
        cur_var%je   = cur_var%js + cysize - 1;
        cur_var%gsiz(1)   = gxsize
        cur_var%gsiz(2)   = gysize
        if(thread_w == MPP_MULTI) then
           call mpp_get_compute_domain(array_domain(domain_idx), xsize=cxsize,ysize=cysize,tile_count=tile_count)
           cur_var%csiz(1)   = cxsize
           cur_var%csiz(2)   = cysize
        else
           cur_var%csiz(1)   = cur_var%gsiz(1)
           cur_var%csiz(2)   = cur_var%gsiz(2)
        end if
     else
        cur_var%domain_present=.false.
        cur_var%gsiz(1:2) = field_siz(1:2)
        cur_var%csiz(1:2) = field_siz(1:2)
     endif
  end if

  d_ptr =>NULL()
  cur_var =>NULL()

end subroutine setup_one_field


!.....................................................................
subroutine write_data_2d_new(filename, fieldname, data, domain,    &
                             no_domain, position,tile_count, data_default)

  character(len=*), intent(in)                 :: filename, fieldname 
  real, dimension(:,:), intent(in)             :: data
  real, dimension(size(data,1),size(data,2),1) :: data_3d
  real, intent(in), optional                   :: data_default
  type(domain2d), intent(in), optional         :: domain
  logical, intent(in), optional                :: no_domain
  integer, intent(in), optional                :: position, tile_count
 
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(write_data_2d_new):need to call fms_io_init first')
  data_3d(:,:,1) = data(:,:)

  call write_data_3d_new(filename, fieldname, data_3d, domain, &
                         no_domain, .false., position, tile_count, data_default)

end subroutine write_data_2d_new

! ........................................................
subroutine write_data_1d_new(filename, fieldname, data,domain, &
                             no_domain, tile_count, data_default)
  
  type(domain2d), intent(in), optional   :: domain
  character(len=*), intent(in)           :: filename, fieldname 
  real, dimension(:), intent(in)         :: data
  real, dimension(size(data(:)),1,1)     :: data_3d
  real, intent(in), optional             :: data_default
  logical, intent(in), optional          :: no_domain
  integer, intent(in), optional          :: tile_count
  
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(write_data_1d_new): module not initialized')  
  data_3d(:,1,1) = data(:)  
  call write_data_3d_new(filename, fieldname, data_3d,domain,   &
                         no_domain=no_domain, scalar_or_1d=.true., tile_count=tile_count, data_default=data_default)  
end subroutine write_data_1d_new

! ..........................................................
subroutine write_data_scalar_new(filename, fieldname, data, domain, &
                                 no_domain, tile_count, data_default)

  type(domain2d), intent(in), optional   :: domain
  character(len=*), intent(in)           :: filename, fieldname 
  real, intent(in)                       :: data
  real, dimension(1,1,1)                 :: data_3d
  real, intent(in), optional             :: data_default
  logical, intent(in), optional          :: no_domain
  integer, intent(in), optional          :: tile_count
    
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(write_data_scalar_new):  module not initialized: '//fieldname)  

  data_3d(1,1,1) = data
  call write_data_3d_new(filename, fieldname, data_3d,domain, &
                         no_domain=no_domain, scalar_or_1d=.true., tile_count=tile_count, data_default=data_default)
end subroutine write_data_scalar_new

! ..........................................................

function lookup_field_r(nfile,fieldname)
! Given fieldname, this function returns the field position in the model's fields list

  integer, intent(in)          :: nfile
  character(len=*), intent(in) :: fieldname
  integer                      :: lookup_field_r
  integer                      :: j

  lookup_field_r=-1
  do j = 1, files_read(nfile)%nvar
     if (trim(files_read(nfile)%var(j)%name) == trim(fieldname)) then
        lookup_field_r = j
        exit 
     endif
  enddo
  return
end function lookup_field_r


!..........................................................

function lookup_domain(domain)
! given domain, this function returns the position of domain in array_domain or -1 if not found

  type(domain2d), intent(in) :: domain
  integer                    :: i, lookup_domain
  lookup_domain = -1
  do i =1, num_domains
     if(domain .EQ. array_domain(i)) then
        lookup_domain = i
        exit
     endif
  enddo
end function lookup_domain
!.........................................................
function lookup_axis(axis_sizes,siz,domains,dom)

! Given axis size (global), this function returns the axis id  

  integer, intent(in)      :: axis_sizes(:), siz
  type(domain1d), optional :: domains(:)
  type(domain1d), optional :: dom
  integer :: lookup_axis
  integer :: j


  lookup_axis=-1
  do j=1,size(axis_sizes(:))
     if (siz == axis_sizes(j)) then
        if (PRESENT(domains)) then
           if (dom .EQ. domains(j)) then 
              lookup_axis = j
              exit
           endif
        else
           lookup_axis = j
           exit
        endif
     endif
  enddo
  if (lookup_axis == -1) call mpp_error(FATAL,'fms_io(lookup_axis): could not find axis in set of axes')
end function lookup_axis
!.....................................................................
! <SUBROUTINE NAME="field_size">
!<DESCRIPTION>
! Given filename and fieldname, this subroutine returns the size of field
!</DESCRIPTION>
!   <TEMPLATE>
! call field_size(filename, fieldname, siz) 
!   </TEMPLATE>
!   <IN NAME="filename" TYPE="character" DIM="(*)">
!    File name
!   </IN>
!   <IN NAME="fieldname" TYPE="character" DIM="(*)">
!    Field  name
!   </IN>
!   <OUT NAME="siz" TYPE="integer" DIM="(*)">
!    siz must be a dimension(4) array to retrieve the size of the field
!   </OUT>
!   <OUT NAME="field_found" TYPE="logical, optional">
!    if this flag is present, field_size will not abort if
!    called for a non-existent field.
!    Instead it will return T or F depending on
!    whether or not the field was found.
!   </OUT>
subroutine field_size(filename, fieldname, siz, field_found, domain, no_domain )

  character(len=*), intent(in)                 :: filename, fieldname
  integer,       intent(inout)                 :: siz(:)
  logical,       intent(out), optional         :: field_found  
  type(domain2d), intent(in), optional, target :: domain
  logical,       intent(in),  optional         :: no_domain

  integer                              :: nfile, unit
  logical                              :: found, found_file
  character(len=256)                   :: actual_file
  logical                              :: read_dist, io_domain_exist, is_no_domain

  if (size(siz(:)) < 4) call mpp_error(FATAL,'fms_io(field_size): size array must be >=4 to receive field size of ' &
       //trim(fieldname)//' in file '// trim(filename))

  is_no_domain = .false.
  if(present(no_domain)) is_no_domain = no_domain

!--- first need to get the filename, when is_no_domain is true, only check file without tile
!--- if is_no_domain is false, first check no_domain=.false., then check no_domain = .true.
  found_file = get_file_name(filename, actual_file, read_dist, io_domain_exist, no_domain=is_no_domain, &
                             domain=domain)
  !--- when is_no_domain is true and file is not found, send out error message.
  if(is_no_domain .AND. .NOT. found_file) call mpp_error(FATAL, &
         'fms_io_mod(field_size): file '//trim(filename)//' and corresponding distributed file are not found')
  found = .false.
  if(found_file) then
     call get_file_unit(actual_file, unit, nfile, read_dist, io_domain_exist, domain=domain)
     call get_size(unit,fieldname,siz,found)    
  endif

  if(.not.found .AND. .not. is_no_domain) then
     found_file =  get_file_name(filename, actual_file, read_dist, io_domain_exist, no_domain=.true.)
     !--- when is_no_domain is true and file is not found, send out error message.
     if(.NOT. found_file) call mpp_error(FATAL, 'fms_io_mod(field_size): file ' //trim(filename)// &
          '(with the consideration of tile number) and corresponding distributed file are not found')  
     call get_file_unit(actual_file, unit, nfile, read_dist, io_domain_exist, domain=domain)
     call get_size(unit,fieldname,siz,found)
  endif

  if( PRESENT(field_found) )then
     field_found = found
  else if (.not. found )then
     call mpp_error(FATAL, 'fms_io(field_size): field '//trim(fieldname)//' NOT found in file '//trim(actual_file))
  end if

  return
end subroutine field_size
! </SUBROUTINE>

subroutine get_size(unit, fieldname, siz, found)
integer,          intent(in)    :: unit
character(len=*), intent(in)    :: fieldname
integer,          intent(inout) :: siz(:)
logical,          intent(out)   :: found

  character(len=128)             :: name
  character(len=1)               :: cart
  integer                        :: i, ndim, nvar, natt, ntime, siz_in(4), j, len
  type(fieldtype)                :: fields(max_fields)
  type(axistype)                 :: axes(max_fields)
     found = .false.
     call mpp_get_info(unit,ndim,nvar,natt,ntime)
     if (nvar > max_fields) then
        write(error_msg,'(I3,"/",I3)') nvar,max_fields 
        call  mpp_error(FATAL,'fms_io(field_size): max_fields too small, needs increasing, nvar/max_fields=' &
             //trim(error_msg))!//' in file '//trim(filename))
     endif
     call mpp_get_fields(unit,fields(1:nvar))
     do i=1, nvar
        call mpp_get_atts(fields(i),name=name)
        if (lowercase(trim(name)) == lowercase(trim(fieldname))) then
           call mpp_get_atts(fields(i),ndim=ndim)
           call mpp_get_atts(fields(i),axes=axes(1:ndim))
           call mpp_get_atts(fields(i),siz=siz_in)
           siz = siz_in
           siz(4) = ntime
           if(ndim == 1) then
              call mpp_get_atts(axes(1), len=siz(1))
           end if
           do j = 1, ndim
              call mpp_get_atts(axes(j),len=len)
              call get_axis_cart(axes(j),cart)
              select case (cart)
              case ('X')
                 siz(1) = len
              case('Y')
                 siz(2) = len
              case('Z')
                 siz(3) = len
              case('T')
                 siz(4) = len
              end select
           enddo
           found = .true.
           exit
        endif
     enddo

     if(.not. found) then
        call mpp_get_axes(unit,axes(1:ndim))
        do i=1, ndim
           call mpp_get_atts(axes(i),name=name, len= siz_in(1))
           if (lowercase(trim(name)) == lowercase(trim(fieldname))) then
              siz(1)= siz_in(1)
              found = .true.
              exit
           endif
        enddo
     endif
end subroutine get_size

! <SUBROUTINE NAME="read_data">
!<DESCRIPTION>
! This routine performs reading "fieldname" stored in "filename". The data values of fieldname
! will be stored in "data" at the end of this routine. For fieldname with multiple timelevel
! just repeat the routine with explicit timelevel in each call.
!</DESCRIPTION>
!   <TEMPLATE>
! call read_data(filename,fieldname,data,domain,timelevel)
!   </TEMPLATE>
!   <IN NAME="filename" TYPE="character" DIM="(*)">
!    File name
!   </IN>
!   <IN NAME="fieldname" TYPE="character" DIM="(*)">
!    Field  name
!   </IN>
!   <IN NAME="domain"  TYPE="domain, optional">
!   domain of fieldname
!   </IN>
!   <IN NAME="timelevel" TYPE="integer, optional">
!     time level of fieldname
!   </IN>
!   <OUT NAME="data"  TYPE="real">
!   array containing data of fieldname
!   </OUT>
!=====================================================================================
subroutine read_data_i3d_new(filename,fieldname,data,domain,timelevel, &
                             no_domain,position, tile_count)
  character(len=*),           intent(in)   :: filename, fieldname
  integer, dimension(:,:,:), intent(inout) :: data ! 3 dimensional data    
  type(domain2d), intent(in),   optional   :: domain
  integer, intent(in),          optional   :: timelevel
  logical, intent(in),          optional   :: no_domain 
  integer, intent(in) ,         optional   :: position, tile_count

  real, dimension(size(data,1),size(data,2),size(data,3)) :: r_data
  r_data = 0
  call read_data_3d_new(filename,fieldname,r_data,domain,timelevel, &
                        no_domain, .false., position, tile_count)
  data = CEILING(r_data)
end subroutine read_data_i3d_new

subroutine read_data_i2d_new(filename,fieldname,data,domain,timelevel, &
                             no_domain,position, tile_count)
  character(len=*),         intent(in)   :: filename, fieldname
  integer, dimension(:,:), intent(inout) :: data ! 2 dimensional data    
  type(domain2d), intent(in), optional   :: domain
  integer, intent(in),        optional   :: timelevel
  logical, intent(in),        optional   :: no_domain
  integer, intent(in) ,       optional   :: position, tile_count
  real, dimension(size(data,1),size(data,2)) :: r_data

  r_data = 0
  call read_data_2d_new(filename,fieldname,r_data,domain,timelevel, &
                        no_domain, position, tile_count)
  data = CEILING(r_data)
end subroutine read_data_i2d_new
!.....................................................................
subroutine read_data_i1d_new(filename,fieldname,data,domain,timelevel, &
                             no_domain, tile_count)
  character(len=*), intent(in)           :: filename, fieldname
  integer, dimension(:), intent(inout)   :: data ! 1 dimensional data    
  type(domain2d), intent(in), optional   :: domain
  integer, intent(in) , optional         :: timelevel
  logical, intent(in), optional          :: no_domain 
  integer, intent(in), optional          :: tile_count

  real, dimension(size(data,1))        :: r_data

  call read_data_1d_new(filename,fieldname,r_data,domain,timelevel, &
                        no_domain, tile_count)
  data = CEILING(r_data)
end subroutine read_data_i1d_new
!.....................................................................
subroutine read_data_iscalar_new(filename,fieldname,data,domain,timelevel, &
                                 no_domain, tile_count)
  character(len=*), intent(in)           :: filename, fieldname
  integer, intent(inout)                 :: data     
  type(domain2d), intent(in), optional   :: domain
  integer, intent(in) , optional         :: timelevel
  logical, intent(in), optional          :: no_domain 
  integer, intent(in), optional          :: tile_count

  real                                 :: r_data
  call read_data_scalar_new(filename,fieldname,r_data,domain,timelevel, &
                            no_domain, tile_count)
  data = CEILING(r_data)
end subroutine read_data_iscalar_new
!=====================================================================================
subroutine read_data_3d_new(filename,fieldname,data,domain,timelevel, &
      no_domain, scalar_or_1d, position, tile_count, is_2d)
  character(len=*),                  intent(in) :: filename, fieldname
  real, dimension(:,:,:),         intent(inout) :: data ! 3 dimensional data    
  type(domain2d), target, optional,  intent(in) :: domain
  integer,                optional,  intent(in) :: timelevel
  logical,                optional,  intent(in) :: no_domain 
  logical,                optional,  intent(in) :: scalar_or_1d
  integer,                optional,  intent(in) :: position, tile_count
  logical,                optional,  intent(in) :: is_2d

  character(len=256)            :: fname
  integer                       :: unit, siz_in(4)
  integer                       :: file_index  ! index of the opened file in array files
  integer                       :: tlev=1
  integer                       :: index_field ! position of the fieldname in the list of variables
  integer                       :: cxsize, cysize
  integer                       :: dxsize, dysize
  integer                       :: gxsize, gysize
  integer                       :: ishift, jshift
  logical                       :: is_scalar_or_1d = .false.
  logical                       :: is_no_domain = .false.
  logical                       :: read_dist, io_domain_exist, found_file
  type(domain2d), pointer, save :: d_ptr =>NULL()
  type(domain2d), pointer, save :: io_domain =>NULL()


! read disttributed files is used when reading restart files that are NOT mppnccombined. In this
! case PE 0 will read file_res.nc.0000, PE 1 will read file_res.nc.0001 and so forth.
! 
! namelist to be used with read_dist_files: threading_read=multi,
! threading_write=multi, fileset_write=multi.

! Initialize files to default values
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(read_data_3d_new):  module not initialized')  
  is_no_domain = .false.
  if (PRESENT(no_domain)) THEN
     if(PRESENT(domain) .AND. no_domain) &
       call mpp_error(FATAL, 'fms_io(read_data_3d_new): no_domain cannot be .true. when optional argument domain is present.')
     is_no_domain = no_domain
  endif  
 
  if(PRESENT(domain))then
     d_ptr => domain
  elseif (ASSOCIATED(Current_domain) .AND. .NOT. is_no_domain ) then
     d_ptr => Current_domain
  endif

  is_scalar_or_1d = .false.
  if(present(scalar_or_1d)) is_scalar_or_1d = scalar_or_1d

  if(.not. PRESENT(domain) .and. .not. ASSOCIATED(Current_domain) ) is_no_domain = .true.

  found_file = get_file_name(filename, fname, read_dist, io_domain_exist, is_no_domain, domain,  tile_count)
  if(.not.found_file) call mpp_error(FATAL, 'fms_io_mod(read_data_3d_new): file ' //trim(filename)// &
          '(with the consideration of tile number) and corresponding distributed file are not found')  
  call get_file_unit(fname, unit, file_index, read_dist, io_domain_exist, domain=domain)

  siz_in(3) = size(data,3)
  if(is_no_domain .or. .NOT. associated(d_ptr) .or. is_scalar_or_1d) then
     gxsize = size(data,1)
     gysize = size(data,2)
  else if(read_dist) then
     if(io_domain_exist) then
        io_domain=>mpp_get_io_domain(d_ptr)
        call mpp_get_global_domain(io_domain, xsize = gxsize, ysize = gysize, tile_count=tile_count, position=position)
        io_domain=>NULL()
     else
        call mpp_get_compute_domain(d_ptr, xsize = gxsize, ysize = gysize, tile_count=tile_count, position=position)
     endif
  else
     call mpp_get_compute_domain(d_ptr, xsize = cxsize, ysize = cysize, tile_count=tile_count, position=position)
     call mpp_get_data_domain   (d_ptr, xsize = dxsize, ysize = dysize, tile_count=tile_count, position=position)
     call mpp_get_global_domain (d_ptr, xsize = gxsize, ysize = gysize, tile_count=tile_count, position=position)
     call mpp_get_domain_shift  (d_ptr, ishift, jshift, position)
     if( (size(data,1) .NE. cxsize .AND. size(data,1) .NE. dxsize) .OR. &
         (size(data,2) .NE. cysize .AND. size(data,2) .NE. dysize) )then
       call mpp_error(FATAL,'fms_io(read_data_3d_new): data should be on either computer domain '//&
                            'or data domain when domain is present. '//&
                            'shape(data)=',shape(data),'  cxsize,cysize,dxsize,dysize=',(/cxsize,cysize,dxsize,dysize/))
     end if 
  endif

  if (PRESENT(timelevel)) then
     tlev = timelevel
  else
     tlev = 1
  endif  

  if ((thread_r == MPP_MULTI).or.(mpp_pe()==mpp_root_pe())) then
     call get_field_id(unit, file_index, fieldname, index_field, is_no_domain, .false. )
     siz_in = files_read(file_index)%var(index_field)%siz
     if(files_read(file_index)%var(index_field)%is_dimvar ) then
        if (.not. read_dist) then
           if (siz_in(1) /= gxsize) &
                call mpp_error(FATAL,'fms_io(read_data_3d_new), field '//trim(fieldname)// &
                ' in file '//trim(filename)//' field size mismatch 2')
        endif
     else
        if (siz_in(1) /= gxsize .or. siz_in(2) /= gysize .or. siz_in(3) /= size(data,3)) then
           PRINT *, gxsize, gysize, size(data, 3), siz_in(1), siz_in(2), siz_in(3)
           call mpp_error(FATAL,'fms_io(read_data_3d_new), field '//trim(fieldname)// &
                ' in file '//trim(filename)//': field size mismatch 1')
        endif
     end if
     if ( tlev < 1 .or. files_read(file_index)%max_ntime < tlev)  then
        write(error_msg,'(I5,"/",I5)') tlev, files_read(file_index)%max_ntime
        call mpp_error(FATAL,'fms_io(read_data_3d_new): time level out of range, time level/max_time_level=' &
             //trim(error_msg)//' in field/file: '//trim(fieldname)//'/'//trim(filename))
     endif

     
     if(is_no_domain .OR. is_scalar_or_1d) then
        if (files_read(file_index)%var(index_field)%is_dimvar) then
           call mpp_get_axis_data(files_read(file_index)%var(index_field)%axis,data(:,1,1))
        else
           call mpp_read(unit,files_read(file_index)%var(index_field)%field,data(:,:,:),tlev)
        endif
     else 
        call mpp_read(unit,files_read(file_index)%var(index_field)%field,d_ptr,data,tlev,tile_count)
     endif
  endif  

  d_ptr =>NULL()

  return
end subroutine read_data_3d_new


!=====================================================================================
subroutine read_data_2d_region(filename,fieldname,data,start,nread,domain, &
                                 no_domain, tile_count)
  character(len=*),                  intent(in) :: filename, fieldname
  real, dimension(:,:),           intent(inout) :: data ! 3 dimensional data    
  integer, dimension(:),             intent(in) :: start, nread
  type(domain2d), target,  optional, intent(in) :: domain
  logical,                 optional, intent(in) :: no_domain 
  integer,                 optional, intent(in) :: tile_count
  character(len=256)            :: fname
  integer                       :: unit, siz_in(4)
  integer                       :: file_index  ! index of the opened file in array files
  integer                       :: index_field ! position of the fieldname in the list of variables
  logical                       :: is_no_domain = .false.
  logical                       :: read_dist, io_domain_exist, found_file
  type(domain2d), pointer, save :: d_ptr =>NULL()


! Initialize files to default values
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(read_data_2d_region):  module not initialized')  
  is_no_domain = .false.
  if (PRESENT(no_domain)) is_no_domain = no_domain
 
  if(PRESENT(domain))then
     d_ptr => domain
  elseif (ASSOCIATED(Current_domain) .AND. .NOT. is_no_domain ) then
     d_ptr => Current_domain
  endif

  if(.not. PRESENT(domain) .and. .not. ASSOCIATED(Current_domain) ) is_no_domain = .true.

  found_file = get_file_name(filename, fname, read_dist, io_domain_exist, is_no_domain, domain,  tile_count)
  if(.not.found_file) call mpp_error(FATAL, 'fms_io_mod(read_data_2d_region): file ' //trim(filename)// &
          '(with the consideration of tile number) and corresponding distributed file are not found')  
  call get_file_unit(fname, unit, file_index, read_dist, io_domain_exist, domain=domain)


  if ((thread_r == MPP_MULTI).or.(mpp_pe()==mpp_root_pe())) then
     call get_field_id(unit, file_index, fieldname, index_field, is_no_domain, .false. )
     siz_in = files_read(file_index)%var(index_field)%siz
     if(files_read(file_index)%var(index_field)%is_dimvar) then
        call mpp_error(FATAL, 'fms_io_mod(read_data_2d_region): the field should not be a dimension variable')
     endif
     call mpp_read(unit,files_read(file_index)%var(index_field)%field,data,start, nread)
  endif  

  d_ptr =>NULL()

  return
end subroutine read_data_2d_region

!=====================================================================================
!--- we assume any text data are at most 2-dimensional and level is for first dimension
subroutine read_data_text(filename,fieldname,data,level)
  character(len=*), intent(in)   :: filename, fieldname
  character(len=*), intent(out)  :: data
  integer, intent(in) , optional :: level
  logical                        :: file_opened, found_file, read_dist, io_domain_exist
  integer                        :: lev, unit, index_field
  integer                        :: file_index
  character(len=256)             :: fname

! Initialize files to default values
  if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(read_data_text):  module not initialized')  

  file_opened=.false.
  if (PRESENT(level)) then
     lev = level
  else
     lev = 1
  endif  

  found_file = get_file_name(filename, fname, read_dist, io_domain_exist, no_domain=.true. )
 if(.not.found_file) call mpp_error(FATAL, 'fms_io_mod(read_data_text): file ' //trim(filename)// &
          '(with the consideration of tile number) and corresponding distributed file are not found')  
  call get_file_unit(fname, unit, file_index, read_dist, io_domain_exist )

! Get info of this file and field   
  if ((thread_r == MPP_MULTI).or.(mpp_pe()==mpp_root_pe())) then
     call get_field_id(unit, file_index, fieldname, index_field, .true., .true. )     

     if ( lev < 1 .or. lev > files_read(file_index)%var(index_field)%siz(1) )  then
        write(error_msg,'(I5,"/",I5)') lev, files_read(file_index)%var(index_field)%siz(1)
        call mpp_error(FATAL,'fms_io(read_data_text): text level out of range, level/max_level=' &
             //trim(error_msg)//' in field/file: '//trim(fieldname)//'/'//trim(filename))
     endif

     call mpp_read(unit,files_read(file_index)%var(index_field)%field,data, level=level)
  endif  
  return
end subroutine read_data_text
!.............................................................. 
! </SUBROUTINE>
subroutine read_data_2d_new(filename,fieldname,data,domain,timelevel,&
      no_domain,position,tile_count)
  character(len=*), intent(in)                 :: filename, fieldname
  real, dimension(:,:), intent(inout)          :: data     !2 dimensional data 
  real, dimension(size(data,1),size(data,2),1) :: data_3d
  type(domain2d), intent(in), optional         :: domain
  integer, intent(in) , optional               :: timelevel
  logical, intent(in), optional                ::  no_domain
  integer, intent(in) , optional               :: position, tile_count
  integer                                      :: isc,iec,jsc,jec,isd,ied,jsd,jed
  integer :: isg,ieg,jsg,jeg
  integer                                      :: xsize_c,ysize_c,xsize_d,ysize_d
  integer                                      :: xsize_g,ysize_g, ishift, jshift

!#ifdef use_CRI_pointers
!  pointer( p, data_3d )
!  p = LOC(data)
!#endif
  call read_data_3d_new(filename,fieldname,data_3d,domain,timelevel,&
        no_domain,.false., position,tile_count)

  if(PRESENT(domain)) then
     call mpp_get_global_domain( domain,isg,ieg,jsg,jeg,xsize=xsize_g,ysize=ysize_g, tile_count=tile_count, position=position)
     call mpp_get_compute_domain( domain,isc,iec,jsc,jec,xsize=xsize_c,ysize=ysize_c, tile_count=tile_count, position=position)
     call mpp_get_data_domain( domain,isd,ied,jsd,jed,xsize=xsize_d,ysize=ysize_d, tile_count=tile_count, position=position)
     call mpp_get_domain_shift  (domain, ishift, jshift, position)
     if((size(data,1)==xsize_c) .and. (size(data,2)==ysize_c)) then !on_comp_domain
        data(:,:) = data_3d(:,:,1)
     else if((size(data,1)==xsize_d) .and. (size(data,2)==ysize_d)) then !on_data_domain
        data(isc-isd+1:iec-isd+1,jsc-jsd+1:jec-jsd+1) = data_3d(isc-isd+1:iec-isd+1,jsc-jsd+1:jec-jsd+1,1)
     else if((size(data,1)==xsize_g) .and. (size(data,2)==ysize_g)) then !on_global_domain
        data(:,:) = data_3d(:,:,1)
     else 
        call mpp_error(FATAL,'error in read_data_2d_new, field '//trim(fieldname)// &
                      ' in file '//trim(filename)//' data must be in compute or data domain')
     endif
  else     
     data(:,:) = data_3d(:,:,1)
  endif

end subroutine read_data_2d_new
!.....................................................................
subroutine read_data_1d_new(filename,fieldname,data,domain,timelevel,&
      no_domain, tile_count)
  character(len=*), intent(in)           :: filename, fieldname
  real, dimension(:), intent(inout)      :: data     !1 dimensional data 
  real, dimension(size(data,1),1,1)      :: data_3d
  type(domain2d), intent(in), optional   :: domain
  integer, intent(in) , optional         :: timelevel
  logical, intent(in), optional          ::  no_domain
  integer, intent(in), optional          :: tile_count
#ifdef use_CRI_pointers
  pointer( p, data_3d )
  p = LOC(data)
#endif

  call read_data_3d_new(filename,fieldname,data_3d,domain,timelevel,&
        no_domain=no_domain, scalar_or_1d=.true., tile_count=tile_count)

end subroutine read_data_1d_new
!.....................................................................

subroutine read_data_scalar_new(filename,fieldname,data,domain,timelevel,&
      no_domain, tile_count)

! this subroutine is for reading a single number
  character(len=*), intent(in)           :: filename, fieldname
  real, intent(inout)                    :: data     !zero dimension data 
  real, dimension(1,1,1)                 :: data_3d
  type(domain2d), intent(in), optional   :: domain
  integer, intent(in) , optional         :: timelevel
  logical, intent(in), optional          ::  no_domain
  integer, intent(in), optional          :: tile_count

  if(present(no_domain)) then
     if(.NOT. no_domain) call mpp_error(FATAL, 'fms_io(read_data_scalar_new): no_domain should be true for field ' &
                                 //trim(fieldname)//' of file '//trim(filename) )
  end if

  call read_data_3d_new(filename,fieldname,data_3d,domain,timelevel,&
        no_domain=no_domain, scalar_or_1d=.true., tile_count=tile_count)

  data = data_3d(1,1,1)

end subroutine read_data_scalar_new
!.....................................................................

function unique_axes(file, index, id_axes, siz_axes, dom)
  type(restart_file_type),   intent(inout)           :: file
  integer,                      intent(in)           :: index
  integer, dimension(:),       intent(out)           :: id_axes
  integer, dimension(:),       intent(out)           :: siz_axes
  type(domain1d), dimension(:), intent(in), optional :: dom
  integer                                            :: unique_axes
  type(var_type), pointer, save :: cur_var => NULL()
  integer :: i,j
  logical :: found
  
  unique_axes=0

  if(index <0 .OR. index > 3) call mpp_error(FATAL,"unique_axes(fms_io_mod): index should be 1, 2 or 3")

  do i = 1, file%nvar
     cur_var => file%var(i)
     if(cur_var%ndim < index) cycle
     found = .false.
     do j = 1, unique_axes
        if(siz_axes(j) == cur_var%gsiz(index) ) then
           if(PRESENT(dom)) then
              if(cur_var%domain_idx == id_axes(j) ) then
                 found = .true.
                 exit
              else if(cur_var%domain_idx >0 .AND. id_axes(j) >0) then
                 if(dom(cur_var%domain_idx) .EQ. dom(id_axes(j)) ) then
                    found = .true.
                    exit
                 end if
              end if
           else
              found = .true.
              exit
           end if
        end if  
     end do
     if(found) then
        cur_var%id_axes(index) = j
     else
        unique_axes = unique_axes+1
        if(unique_axes > max_axes) then
           write(error_msg,'(I3,"/",I3)') unique_axes, max_axes
           if(index == 1 ) then
              call mpp_error(FATAL,'# x axes exceeded max_axes in fms_io,num_axes/max_axes= '//trim(error_msg))
           else if(index == 2 ) then
              call mpp_error(FATAL,'# y axes exceeded max_axes in fms_io,num_axes/max_axes= '//trim(error_msg))
           else
              call mpp_error(FATAL,'# z axes exceeded max_axes in fms_io,num_axes/max_axes= '//trim(error_msg))
           end if
        endif
        id_axes(unique_axes)   = cur_var%domain_idx
        siz_axes(unique_axes) = cur_var%gsiz(index)
        if(siz_axes(unique_axes) > max_axis_size) then
           call mpp_error(FATAL, 'fms_io_mod(unique_axes): size_axes is greater than max_axis_size, '//&
              'increase fms_io_nml variable max_axis_size to at least ', siz_axes(unique_axes))
        endif
        cur_var%id_axes(index) = unique_axes
     end if
  end do       

  cur_var => NULL()
  
  return

end function unique_axes

  !#######################################################################
  !#######################################################################
  !   --------- routines for reading distributed data ---------
  ! before calling these routines the domain decompostion must be set
  ! by calling "set_domain" with the appropriate domain2d data type
  !
  ! reading can be done either by all PEs (default) or by only the root PE
  ! this is controlled by namelist variable "read_all_pe".
  
  ! By default, array data is expected to be declared in data domain and no_halo
  !is NOT needed, however IF data is decalared in COMPUTE domain then optional NO_HALO should be .true.

  !#######################################################################

subroutine read_data_2d ( unit, data, end)

  integer, intent(in)                        :: unit
  real,    intent(out), dimension(isd:,jsd:) :: data
  logical, intent(out), optional             :: end  
  real, dimension(isg:ieg,jsg:jeg)           :: gdata
  integer                                    :: len
  logical                                    :: no_halo

  include "read_data_2d.inc"  
end subroutine read_data_2d

!#######################################################################

subroutine read_ldata_2d ( unit, data, end)

  integer, intent(in)                        :: unit
  logical, intent(out), dimension(isd:,jsd:) :: data
  logical, intent(out), optional             :: end  
  logical, dimension(isg:ieg,jsg:jeg)        :: gdata
  integer                                    :: len
  logical                                    :: no_halo

  include "read_data_2d.inc"
end subroutine read_ldata_2d
!#######################################################################

subroutine read_idata_2d ( unit, data, end)

  integer, intent(in)                        :: unit
  integer, intent(out), dimension(isd:,jsd:) :: data
  logical, intent(out), optional             :: end
  integer, dimension(isg:ieg,jsg:jeg)        :: gdata
  integer                                    :: len
  logical                                    :: no_halo

  include "read_data_2d.inc"
end subroutine read_idata_2d

!#######################################################################

#ifdef OVERLOAD_C8
subroutine read_cdata_2d ( unit, data, end)
  
  integer, intent(in)                           :: unit
  complex,    intent(out), dimension(isd:,jsd:) :: data
  logical, intent(out), optional                :: end
  complex, dimension(isg:ieg,jsg:jeg)           :: gdata
  integer                                       :: len
  logical                                       :: no_halo

  include "read_data_2d.inc"
end subroutine read_cdata_2d
#endif

!#######################################################################

subroutine read_data_3d ( unit, data, end)

  integer, intent(in)                           :: unit
  real,    intent(out), dimension(isd:,jsd:,:)  :: data
  logical, intent(out), optional                :: end  
  real, dimension(isg:ieg,jsg:jeg,size(data,3)) :: gdata
  integer                                       :: len
  logical                                       :: no_halo

  include "read_data_3d.inc"
end subroutine read_data_3d

!#######################################################################

#ifdef OVERLOAD_C8
subroutine read_cdata_3d ( unit, data, end)

  integer, intent(in)                              :: unit
  complex, intent(out), dimension(isd:,jsd:,:)     :: data
  logical, intent(out), optional                   :: end
  complex, dimension(isg:ieg,jsg:jeg,size(data,3)) :: gdata
  integer                                          :: len
  logical                                          :: no_halo

  include "read_data_3d.inc"  
end subroutine read_cdata_3d
#endif

!#######################################################################

subroutine read_data_4d ( unit, data, end)

  integer, intent(in)                                        :: unit
  real,    intent(out), dimension(isd:,jsd:,:,:)             :: data
  logical, intent(out), optional                             :: end
  real, dimension(isg:ieg,jsg:jeg,size(data,3),size(data,4)) :: gdata
  integer                                                    :: len
  logical                                                    :: no_halo
! WARNING: memory usage with this routine could be costly
   
  include "read_data_4d.inc"  
end subroutine read_data_4d

!#######################################################################

#ifdef OVERLOAD_C8
subroutine read_cdata_4d ( unit, data, end)

  integer, intent(in)                                           :: unit
  complex, intent(out), dimension(isd:,jsd:,:,:)                :: data
  logical, intent(out), optional                                :: end
  complex, dimension(isg:ieg,jsg:jeg,size(data,3),size(data,4)) :: gdata
  integer                                                       :: len
  logical                                                       :: no_halo
! WARNING: memory usage with this routine could be costly
 
  include "read_data_4d.inc"
end subroutine read_cdata_4d
#endif

!#######################################################################
!     -------- routines for writing distributed data --------
! before calling these routines the domain decompostion must be set
! by calling "set_domain" with the appropriate domain2d data type
!#######################################################################
subroutine write_data_2d ( unit, data )
  integer, intent(in)                       :: unit
  real,    intent(in), dimension(isd:,jsd:) :: data  
  real, dimension(isg:ieg,jsg:jeg) :: gdata

  include "write_data.inc"
end subroutine write_data_2d

!#######################################################################

subroutine write_ldata_2d ( unit, data )

  integer, intent(in)                       :: unit
  logical, intent(in), dimension(isd:,jsd:) :: data
  logical, dimension(isg:ieg,jsg:jeg) :: gdata

  include "write_data.inc"
end subroutine write_ldata_2d

!#######################################################################
subroutine write_idata_2d ( unit, data )

  integer, intent(in)                       :: unit
  integer, intent(in), dimension(isd:,jsd:) :: data
  integer, dimension(isg:ieg,jsg:jeg) :: gdata

  include "write_data.inc"
end subroutine write_idata_2d

!#######################################################################

#ifdef OVERLOAD_C8
subroutine write_cdata_2d ( unit, data )

  integer, intent(in)                       :: unit
  complex, intent(in), dimension(isd:,jsd:) :: data
  complex, dimension(isg:ieg,jsg:jeg) :: gdata

  include "write_data.inc"
end subroutine write_cdata_2d
#endif

!#######################################################################

subroutine write_data_3d ( unit, data )

  integer, intent(in) :: unit
  real,    intent(in), dimension(isd:,jsd:,:) :: data
  real, dimension(isg:ieg,jsg:jeg,size(data,3)) :: gdata
    
  include "write_data.inc"
end subroutine write_data_3d

!#######################################################################

#ifdef OVERLOAD_C8
subroutine write_cdata_3d ( unit, data )

  integer, intent(in) :: unit
  complex, intent(in), dimension(isd:,jsd:,:) :: data
  complex, dimension(isg:ieg,jsg:jeg,size(data,3)) :: gdata

  include "write_data.inc"
end subroutine write_cdata_3d
#endif

!#######################################################################
subroutine write_data_4d ( unit, data )

  integer, intent(in) :: unit
  real,    intent(in), dimension(isd:,jsd:,:,:) :: data
  real, dimension(isg:ieg,jsg:jeg,size(data,3),size(data,4)) :: gdata
  integer :: n

  if (.not.associated(Current_domain))  &
       call mpp_error(FATAL,'fms_io(write_data_4d): need to call set_domain ')

! get the global data and write only on root pe
! do this one field at a time to save memory
  do n = 1, size(data,4)
     call mpp_global_field ( Current_domain, data(:,:,:,n), gdata(:,:,:,n) )
  enddo
  if ( mpp_pe() == mpp_root_pe() ) write (unit) gdata
end subroutine write_data_4d

!#######################################################################

#ifdef OVERLOAD_C8
subroutine write_cdata_4d ( unit, data )

  integer, intent(in) :: unit
  complex,    intent(in), dimension(isd:,jsd:,:,:) :: data
  complex, dimension(isg:ieg,jsg:jeg,size(data,3),size(data,4)) :: gdata
  integer :: n

  if (.not.associated(Current_domain)) call mpp_error(FATAL, 'fms_io(write_cdata_4d): need to call set_domain')

! get the global data and write only on root pe
! do this one field at a time to save memory
  do n = 1, size(data,4)
     call mpp_global_field ( Current_domain, data(:,:,:,n), gdata(:,:,:,n) )
  enddo
  if ( mpp_pe() == mpp_root_pe() ) write (unit) gdata
end subroutine write_cdata_4d
#endif

!#######################################################################
! private routines (read_eof,do_read)
! this routine is called when an EOF is found while
! reading a distributed data file using read_data

subroutine read_eof (end_found)
  logical, intent(out), optional :: end_found
  
  if (present(end_found))then
     end_found = .true.
  else
     call mpp_error(FATAL,'fms_io(read_eof): unexpected EOF')
  endif
end subroutine read_eof

!#######################################################################
! determines if current pe should read data
! checks namelist variable read_all_pe

function do_read ( )
  logical :: do_read
  do_read = mpp_pe() == mpp_root_pe() .or. read_all_pe
end function do_read

!!#######################################################################

subroutine reset_field_name(fileObj, id_field, name)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  character(len=*),        intent(in)         :: name

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_name): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_name): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )

  fileObj%var(id_field)%name = trim(name)

end subroutine reset_field_name 

!#######################################################################

subroutine reset_field_pointer_r0d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real,                    intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r0d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r0d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r0d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p0dr(1, id_field)%p => data

end subroutine reset_field_pointer_r0d

!#######################################################################

subroutine reset_field_pointer_r1d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real, dimension(:),      intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r1d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r1d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r1d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p1dr(1, id_field)%p => data

end subroutine reset_field_pointer_r1d


!#######################################################################
subroutine reset_field_pointer_r2d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real, dimension(:,:),    intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r2d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r2d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r2d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p2dr(1, id_field)%p => data

end subroutine reset_field_pointer_r2d

!#######################################################################

subroutine reset_field_pointer_r3d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real, dimension(:,:,:),  intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r3d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r3d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r3d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p3dr(1, id_field)%p => data

end subroutine reset_field_pointer_r3d

!#######################################################################

subroutine reset_field_pointer_i0d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  integer,                 intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i0d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i0d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i0d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p0di(1, id_field)%p => data

end subroutine reset_field_pointer_i0d

!#######################################################################

subroutine reset_field_pointer_i1d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  integer, dimension(:),   intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i1d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i1d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i1d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p1di(1, id_field)%p => data

end subroutine reset_field_pointer_i1d


!#######################################################################
subroutine reset_field_pointer_i2d(fileObj, id_field, data)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  integer, dimension(:,:), intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i2d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i2d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i2d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p2di(1, id_field)%p => data

end subroutine reset_field_pointer_i2d

!#######################################################################

subroutine reset_field_pointer_i3d(fileObj, id_field, data)
  type(restart_file_type),   intent(inout)      :: fileObj
  integer,                   intent(in)         :: id_field
  integer, dimension(:,:,:), intent(in), target :: data   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i3d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i3d): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 1) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i3d): one-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not one level" )

  fileObj%p3di(1, id_field)%p => data

end subroutine reset_field_pointer_i3d

!#######################################################################

subroutine reset_field_pointer_r0d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real,                    intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r0d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r0d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r0d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p0dr(1, id_field)%p => data1
  fileObj%p0dr(2, id_field)%p => data2

end subroutine reset_field_pointer_r0d_2level

!#######################################################################

subroutine reset_field_pointer_r1d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real, dimension(:),      intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r1d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r1d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r1d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p1dr(1, id_field)%p => data1
  fileObj%p1dr(2, id_field)%p => data2

end subroutine reset_field_pointer_r1d_2level

!#######################################################################

subroutine reset_field_pointer_r2d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real, dimension(:,:),    intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r2d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r2d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r2d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p2dr(1, id_field)%p => data1
  fileObj%p2dr(2, id_field)%p => data2

end subroutine reset_field_pointer_r2d_2level

!#######################################################################

subroutine reset_field_pointer_r3d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  real, dimension(:,:,:),  intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_r3d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r3d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_r3d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p3dr(1, id_field)%p => data1
  fileObj%p3dr(2, id_field)%p => data2

end subroutine reset_field_pointer_r3d_2level

!#######################################################################

subroutine reset_field_pointer_i0d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  integer,                 intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i0d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i0d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i0d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p0di(1, id_field)%p => data1
  fileObj%p0di(2, id_field)%p => data2

end subroutine reset_field_pointer_i0d_2level

!#######################################################################

subroutine reset_field_pointer_i1d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  integer, dimension(:),   intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i1d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i1d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i1d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p1di(1, id_field)%p => data1
  fileObj%p1di(2, id_field)%p => data2

end subroutine reset_field_pointer_i1d_2level

!#######################################################################

subroutine reset_field_pointer_i2d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type), intent(inout)      :: fileObj
  integer,                 intent(in)         :: id_field
  integer, dimension(:,:), intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i2d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i2d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i2d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p2di(1, id_field)%p => data1
  fileObj%p2di(2, id_field)%p => data2

end subroutine reset_field_pointer_i2d_2level

!#######################################################################

subroutine reset_field_pointer_i3d_2level(fileObj, id_field, data1, data2)
  type(restart_file_type),   intent(inout)      :: fileObj
  integer,                   intent(in)         :: id_field
  integer, dimension(:,:,:), intent(in), target :: data1, data2   

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(reset_field_pointer_i3d_2level): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id_field < 0 .OR. id_field > fileObj%nvar) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i3d_2level): id_field should be positive integer and "// &
         "no larger than number of fields in the file "//trim(fileObj%name) )
  if(fileObj%var(id_field)%siz(4) .NE. 2) call mpp_error(FATAL, &
         "fms_io(reset_field_pointer_i3d_2level): two-level reset_field_pointer is called, but "//&
         "field "//trim(fileObj%var(id_field)%name)//" of file "//trim(fileObj%name)//" is not two level" )

  fileObj%p3di(1, id_field)%p => data1
  fileObj%p3di(2, id_field)%p => data2

end subroutine reset_field_pointer_i3d_2level

!#########################################################################
!   This function returns .true. if the field referred to by id has
! initialized from a restart file, and .false. otherwise. 
!
! Arguments: id - A integer that is the index of the field in fileObj.
!  (in)  fileObj - The control structure returned by a previous call to
!                  register_restart_field
function query_initialized_id(fileObj, id)
  type(restart_file_type), intent(in) :: fileObj
  integer,                 intent(in) :: id

  logical :: query_initialized_id

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(query_initialized_id): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  if(id < 1 .OR. id > fileObj%nvar) call mpp_error(FATAL, "fms_io(query_initialized_id): " // &
      "argument id must be between 1 and nvar in the restart_file_type object")

  query_initialized_id = fileObj%var(id)%initialized

  return

end function query_initialized_id

!#########################################################################
!   This function returns .true. if the field referred to by name has
! initialized from a restart file, and .false. otherwise. 
!
! Arguments: name - A pointer to the field that is being queried.
!  (in)  fileObj - The control structure returned by a previous call to
!                  register_restart_field
function query_initialized_name(fileObj, name)
  type(restart_file_type), intent(inout) :: fileObj
  character(len=*),           intent(in) :: name

  logical :: query_initialized_name

  integer :: m

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(query_initialized_name): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  query_initialized_name = .false.
  do m=1,fileObj%nvar
    if (trim(name) == fileObj%var(m)%name) then
      if (fileObj%var(m)%initialized) query_initialized_name = .true.
      exit
    endif
  enddo
! Assume that you are going to initialize it now, so set flag to initialized if
! queried again.
  if (m<=fileObj%nvar) then
     fileObj%var(m)%initialized = .true.
  else if(mpp_pe() == mpp_root_pe()) then
    call mpp_error(NOTE,"fms_io(query_initialized_name): Unknown restart variable "//name// &
                        " queried for initialization.")
  end if

end function query_initialized_name


!   This function returns 1 if the field pointed to by f_ptr has
! initialized from a restart file, and 0 otherwise.  If f_ptr is
! NULL, it tests whether the entire restart file has been success-
! fully read.
!
! Arguments: f_ptr - A pointer to the field that is being queried.
!  (in)      name - The name of the field that is being queried.
!  (in)      CS - The control structure returned by a previous call to
!                 restart_init.
function query_initialized_r2d(fileObj, f_ptr, name)
  type(restart_file_type),   intent(inout) :: fileObj 
  real, dimension(:,:), target, intent(in) :: f_ptr
  character(len=*),             intent(in) :: name

  logical :: query_initialized_r2d
  integer :: m

  if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(query_initialized_r2d): " // &
      "restart_file_type data must be initialized by calling register_restart_field before using it")

  query_initialized_r2d = .false.
  do m=1, fileObj%nvar
     if (ASSOCIATED(fileObj%p2dr(1,m)%p,f_ptr)) then
        if (fileObj%var(m)%initialized) query_initialized_r2d = .true.
        exit
     endif
  enddo
  ! Assume that you are going to initialize it now, so set flag to initialized if
  ! queried again.
  if (m<=fileObj%nvar) then
     fileObj%var(m)%initialized = .true.
  else
     query_initialized_r2d = query_initialized_name(fileObj, name)
     if (mpp_pe() == mpp_root_pe() ) call mpp_error(NOTE, "fms_io(query_initialized_r2d): Unable to find "// &
          trim(name)//" queried by pointer, "//"probably because of the suspect comparison of pointers by ASSOCIATED.")
     query_initialized_r2d = query_initialized_name(fileObj, name)
     if (mpp_pe() == mpp_root_pe() .AND. query_initialized_r2d) call mpp_error(NOTE, &
          "fms_io(query_initialized_r2d): "//trim(name)// " initialization confirmed by name.")
  endif

  return

end function query_initialized_r2d


!#######################################################################
!#######################################################################
!
! routines for opening specific types of files:
!
!                       form        action 
! open_namelist_file  MPP_ASCII   MPP_RDONLY  
! open restart_file   MPP_NATIVE
! open_ieee32_file    MPP_IEEE32
!
! all have: access=MPP_SEQUENTIAL, threading=MPP_SINGLE, nohdrs=.true.
! use the close_file interface to close these files
!
! if other types of files need to be opened the mpp_open and
! mpp_close routines in the mpp_io_mod should be used
!
!#######################################################################


! <FUNCTION NAME="open_namelist_file">
!   <DESCRIPTION>
! Opens single namelist file for reading only by all PEs
! the default file opened is called "input.nml".
!   </DESCRIPTION>
! <IN NAME="file" TYPE="character">
! name of the file to be opened
! </IN>
! <OUT NAME="unit" TYPE="integer">
! unit number returned by this function
! </OUT>
function open_namelist_file (file) result (unit)
  character(len=*), intent(in), optional :: file
  integer :: unit

#ifdef INTERNAL_FILE_NML
  call mpp_error(WARNING, "fms_io_mod: open_namelist_file should not be called when INTERNAL_FILE_NML is defined")
#endif

  if (.not.module_is_initialized) call fms_io_init ( )    
  if (present(file)) then
     call mpp_open ( unit, file, form=MPP_ASCII, action=MPP_RDONLY, &
          access=MPP_SEQUENTIAL, threading=MPP_SINGLE )
  else
     call mpp_open ( unit, 'input.nml', form=MPP_ASCII, action=MPP_RDONLY, &
          access=MPP_SEQUENTIAL, threading=MPP_SINGLE )
  endif
end function open_namelist_file
! </FUNCTION>

! <FUNCTION NAME="open_restart_file">
!   <DESCRIPTION> 
! Opens single restart file for reading by all PEs or
! writing by root PE only
! the file has native format and no mpp header records.
!   </DESCRIPTION>
!<IN NAME="file" TYPE="character">
! name of the file to be opened
! </IN>
!<IN NAME="action" TYPE="character">
! action to be performed: can be 'read' or 'write'
! </IN>
! <OUT NAME="unit" TYPE="integer">
! unit number returned by this function
! </OUT>
function open_restart_file (file, action) result (unit)
  character(len=*), intent(in) :: file, action
  integer :: unit  
  integer :: mpp_action

  if (.not.module_is_initialized) call fms_io_init ( )

!   --- action (read,write) ---

  select case (lowercase(trim(action)))
  case ('read')
     mpp_action = MPP_RDONLY
  case ('write')
     mpp_action = MPP_OVERWR
  case default
     call mpp_error(FATAL,'fms_io(open_restart_file): action should be either read or write in file'//trim(file))
  end select
  
  call mpp_open ( unit, file, form=MPP_NATIVE, action=mpp_action, &
       access=MPP_SEQUENTIAL, threading=MPP_SINGLE, nohdrs=.true. )

end function open_restart_file
! </FUNCTION>


! <FUNCTION NAME="open_direct_file">
!   <DESCRIPTION> 
! Opens single direct access file for reading by all PEs or
! writing by root PE only
! the file has native format and no mpp header records.
!   </DESCRIPTION>

  function open_direct_file (file, action, recl) result (unit)
    character(len=*), intent(in) :: file, action
    integer,          intent(in) :: recl
    integer :: unit

    integer :: mpp_action

    if (.not.module_is_initialized) call fms_io_init ( )

    !   --- action (read,write) ---

    select case (lowercase(trim(action)))
    case ('read')
       mpp_action = MPP_RDONLY
    case ('write')
       mpp_action = MPP_OVERWR
    case default
       call mpp_error(FATAL,'invalid option for argument action')
    end select

    call mpp_open ( unit, file, form=MPP_NATIVE, action=mpp_action, &
         access=MPP_DIRECT, threading=MPP_SINGLE, nohdrs=.true., recl=recl )

  end function open_direct_file
! </FUNCTION>

! <FUNCTION NAME=" open_ieee32_file">
!   <DESCRIPTION>  
! Opens single 32-bit ieee file for reading by all PEs or 
! writing by root PE only (writing is not recommended)
! the file has no mpp header records.
!   </DESCRIPTION>
!<IN NAME="file" TYPE="character">
! name of the file to be opened
! </IN>
!<IN NAME="action" TYPE="character">
! action to be performed: can be 'read' or 'write'
! </IN>
! <OUT NAME="unit" TYPE="integer">
! unit number returned by this function
! </OUT>
function open_ieee32_file (file, action) result (unit)
  character(len=*), intent(in) :: file, action
  integer :: unit  
  integer :: mpp_action

  if (.not.module_is_initialized) call fms_io_init ( )

!   --- action (read,write) ---
  select case (lowercase(trim(action)))
  case ('read')
     mpp_action = MPP_RDONLY
  case ('write')
     mpp_action = MPP_OVERWR
  case default
     call mpp_error (FATAL,'fms_io(open_ieee32_file): action should be either read or write in file'//trim(file))
  end select
  
  if (iospec_ieee32(1:1) == ' ') then
     call mpp_open ( unit, file, form=MPP_IEEE32, action=mpp_action, &
          access=MPP_SEQUENTIAL, threading=MPP_SINGLE,    &
          nohdrs=.true. )
  else
     call mpp_open ( unit, file, form=MPP_IEEE32, action=mpp_action, &
          access=MPP_SEQUENTIAL, threading=MPP_SINGLE,    &
          nohdrs=.true., iospec=iospec_ieee32 )
  endif
end function open_ieee32_file
! </FUNCTION>

!#######################################################################
! <FUNCTION NAME=" close_file">
!   <DESCRIPTION>
!  Closes files that are opened by: open_namelist_file, open restart_file,
! and open_ieee32_file. Users should use mpp_close for other cases.
!   </DESCRIPTION>
!<IN NAME="unit" TYPE="integer">
! unit number of the file to be closed
! </IN>
!<IN NAME="status" TYPE="character, optional">
! action to be performed: can be 'delete'
! </IN>

subroutine close_file (unit, status)
  integer,          intent(in)           :: unit
  character(len=*), intent(in), optional :: status
  
  if (.not.module_is_initialized) call fms_io_init ( )
  if (unit == stdlog()) return    
  if (present(status)) then
     if (lowercase(trim(status)) == 'delete') then
        call mpp_close (unit, action=MPP_DELETE)
     else
        call mpp_error(FATAL,'fms_io(close_file): status should be DELETE')
     endif
  else
     call mpp_close (unit)
  endif
end subroutine close_file
! </FUNCTION>

!#######################################################################
  

! <SUBROUTINE NAME="set_domain">
!   <DESCRIPTION>
! set_domain is called to save the domain2d data type prior to
! calling the distributed data I/O routines, read_data and write_data.
!   </DESCRIPTION>
! <IN NAME="Domain2" TYPE="domain2D">
! domain to be passed to routines in fms_io_mod, Current_domain will point to
! this Domain2
! </IN>
subroutine set_domain (Domain2)
    
  type(domain2D), intent(in), target :: Domain2

  if (.NOT.module_is_initialized) call fms_io_init ( )

!  --- set_domain must be called before a read_data or write_data ---
  if (associated(Current_domain)) nullify (Current_domain)
  Current_domain => Domain2
  
  !  --- module indexing to shorten read/write routines ---
  
  call mpp_get_compute_domain (Current_domain,is ,ie ,js ,je )
  call mpp_get_data_domain    (Current_domain,isd,ied,jsd,jed)
  call mpp_get_global_domain  (Current_domain,isg,ieg,jsg,jeg)
end subroutine set_domain
!#######################################################################
! </SUBROUTINE>

! <SUBROUTINE NAME="nullify_domain">
subroutine nullify_domain ()
!   <DESCRIPTION>
! Use to nulify domain that has been assigned by set_domain.
!   </DESCRIPTION>
  if (.NOT.module_is_initialized) call fms_io_init ( )

!  --- set_domain must be called before a read_data or write_data ---

  if (associated(Current_domain)) nullify (Current_domain)
  is=0;ie=0;js=0;je=0
  isd=0;ied=0;jsd=0;jed=0
  isg=0;ieg=0;jsg=0;jeg=0
end subroutine nullify_domain
! </SUBROUTINE>

! <SUBROUTINE NAME="return_domain">
!   <DESCRIPTION>
! This routine is the reverse of set_domain above. This routine is called when 
! users want to retrieve the domain2d that is used in fms_io_mod
!   </DESCRIPTION>
! <OUT NAME="domain2" TYPE="domain2D">
! domain returned from  fms_io_mod.
! </OUT>
subroutine return_domain(domain2)
  type(domain2D), intent(inout) :: domain2

  if (associated(Current_domain)) then
     domain2 = Current_domain
  else
     domain2 = NULL_DOMAIN2D       
  endif
end subroutine return_domain
! </SUBROUTINE>

!#######################################################################
! this will be a private routine with the next release
! users should get the domain decomposition from the domain2d data type

!#######################################################################
! <SUBROUTINE NAME="get_domain_decomp">
!   <DESCRIPTION>
! This will be a private routine with the next release.
! Users should get the domain decomposition from the domain2d data type.
!   </DESCRIPTION>
! <OUT NAME="x" TYPE="integer">
! array containing beginning and ending indices of global and compute domain in x direction
! </OUT>
! <OUT NAME="y" TYPE="integer">
! array containing beginning and ending indices of global and compute domain in y direction
! </OUT>
subroutine get_domain_decomp ( x, y )

  integer, intent(out), dimension(4) :: x, y
  
  if (mpp_pe() == mpp_root_pe())  call mpp_error(NOTE, &
       'subroutine get_domain_decomp will be removed with the next release')
  x = (/ isg, ieg, is, ie /)
  y = (/ jsg, jeg, js, je /)

end subroutine get_domain_decomp
! </SUBROUTINE>

subroutine get_axis_cart(axis, cart)      

  type(axistype), intent(in) :: axis
  character(len=1), intent(out) :: cart
  character(len=1) :: axis_cart
  character(len=16), dimension(2) :: lon_names, lat_names
  character(len=16), dimension(3) :: z_names
  character(len=16), dimension(2) :: t_names
  character(len=16), dimension(2) :: lon_units, lat_units
  character(len=8) , dimension(4) :: z_units
  character(len=3) , dimension(4) :: t_units
  character(len=32) :: name
  integer :: i

  lon_names = (/'lon','x  '/)
  lat_names = (/'lat','y  '/)
  z_names = (/'depth ','height','z     '/)
  t_names = (/'time','t   '/)
  lon_units = (/'degrees_e   ', 'degrees_east'/)
  lat_units = (/'degrees_n    ', 'degrees_north'/)
  z_units = (/'cm ','m  ','pa ','hpa'/)
  t_units = (/'sec', 'min','hou','day'/)  
  call mpp_get_atts(axis,cartesian=axis_cart)
  cart = 'N'  
  if (axis_cart == 'x' ) cart = 'X'
  if (axis_cart == 'y' ) cart = 'Y'
  if (axis_cart == 'z' ) cart = 'Z'
  if (axis_cart == 't' ) cart = 'T'
  if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then
     call mpp_get_atts(axis,name=name)
     name = lowercase(name)
     do i=1,size(lon_names(:))
        if (lowercase(name(1:3)) == trim(lon_names(i))) cart = 'X'
     enddo
     do i=1,size(lat_names(:))
        if (name(1:3) == trim(lat_names(i))) cart = 'Y'
     enddo
     do i=1,size(z_names(:))
        if (name == trim(z_names(i))) cart = 'Z'
     enddo
     do i=1,size(t_names(:))
        if (name(1:3) == t_names(i)) cart = 'T'
     enddo
  end if

  if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then
     call mpp_get_atts(axis,units=name)
     name = lowercase(name)
     do i=1,size(lon_units(:))
        if (trim(name) == trim(lon_units(i))) cart = 'X'
     enddo
     do i=1,size(lat_units(:))
        if (trim(name) == trim(lat_units(i))) cart = 'Y'
     enddo
     do i=1,size(z_units(:))
        if (trim(name) == trim(z_units(i))) cart = 'Z'
     enddo
     do i=1,size(t_units(:))
        if (name(1:3) == trim(t_units(i))) cart = 'T'
     enddo
  end if
  
  return
end subroutine get_axis_cart


! The following function is here as a last resort.
! This is copied from what was utilities_mod in order that redundant code 
! could be deleted.

 function open_file ( file, form, action, access, threading, recl ) &
             result ( unit )

 character(len=*), intent(in) :: file 
 character(len=*), intent(in), optional :: form, action, access, threading
 integer         , intent(in), optional :: recl 
 integer  :: unit 

 character(len=32) :: form_local, action_local, access_local, thread_local
 character(len=32) :: action_ieee32
 logical :: open, no_headers, do_ieee32
 integer :: mpp_format, mpp_action, mpp_access, mpp_thread
!-----------------------------------------------------------------------

   if ( .not. module_is_initialized ) then
        call fms_io_init ( )
!        do_init = .false.
   endif

!   ---- return stdlog if this is the logfile ----

    if (trim(file) == 'logfile.out') then
       unit = stdlog()
       return
    endif

!   ---- is this file open and connected to a unit ?? ---- 

   inquire (file=trim(file), opened=open, number=unit)

!  cannot open a file that is already open
!  except for the log file

   if ( open .and. unit >= 0 ) then
      call mpp_error (FATAL, 'open_file in fms_mod : '// &
                       'file '//trim(file)//' is already open')
   endif   

!  --- defaults ---

   form_local   = 'formatted';  if (present(form))      form_local   = form
   access_local = 'sequential'; if (present(access))    access_local = access
   thread_local = 'single';     if (present(threading)) thread_local = threading
   no_headers   = .true.
   do_ieee32    = .false.

   if (present(action)) then    ! must be present
      action_local = action
   else
      call mpp_error (FATAL, 'open_file in fms_mod : argument action not present')
   endif


!   --- file format ---

    select case (lowercase(trim(form_local)))
       case ('formatted')
           mpp_format = MPP_ASCII
       case ('ascii')
           mpp_format = MPP_ASCII
       case ('unformatted')
           mpp_format = MPP_NATIVE
       case ('native')
           mpp_format = MPP_NATIVE
       case ('ieee32')
           do_ieee32 = .true.
       case ('netcdf')
           mpp_format = MPP_NETCDF
       case default
           call mpp_error (FATAL, 'open_file in fms_mod : '// &
                            'invalid option for argument form')
    end select

!   --- action (read,write,append) ---

    select case (lowercase(trim(action_local)))
       case ('read')
           mpp_action = MPP_RDONLY
       case ('write')
           mpp_action = MPP_OVERWR
       case ('append')
           mpp_action = MPP_APPEND
       case default
           call mpp_error (FATAL, 'open_file in fms_mod : '// &
                            'invalid option for argument action')
    end select

!   --- file access (sequential,direct) ---

    select case (lowercase(trim(access_local)))
       case ('sequential')
           mpp_access = MPP_SEQUENTIAL
       case ('direct')
           mpp_access = MPP_DIRECT
       case default
           call mpp_error (FATAL, 'open_file in fms_mod : '// &
                            'invalid option for argument access')
    end select

!   --- threading (single,multi) ---

    select case (lowercase(trim(thread_local)))
       case ('single')
           mpp_thread = MPP_SINGLE
       case ('multi')
           mpp_thread = MPP_MULTI
       case default
           call mpp_error (FATAL, 'open_file in fms_mod : '// &
                            'invalid option for argument thread')
           if (trim(file) /= '_read_error.nml') no_headers = .false.
    end select

!   ---------------- open file -----------------------

    if ( .not.do_ieee32 ) then
       call mpp_open ( unit, file, form=mpp_format, action=mpp_action, &
                       access=mpp_access, threading=mpp_thread,        &
                       nohdrs=no_headers, recl=recl )
    else
     ! special open for ieee32 file
     ! fms_mod has iospec value
     ! pass local action flag to open changing append to write
       action_ieee32 = action_local
       if (lowercase(trim(action_ieee32)) == 'append') action_ieee32 = 'write'
       unit = open_ieee32_file ( file, action_ieee32 )
    endif

!-----------------------------------------------------------------------

 end function open_file

  !#######################################################################

  function string_from_integer(n)
    integer, intent(in) :: n
    character(len=16) :: string_from_integer

    if(n<0) then
       call mpp_error(FATAL, 'fms_io_mod: n should be non-negative integer, contact developer')
    else if( n<10 ) then
       write(string_from_integer,'(i1)') n
    else if( n<100 ) then
       write(string_from_integer,'(i2)') n
    else if( n<1000 ) then
       write(string_from_integer,'(i3)') n
    else if( n<10000 ) then
       write(string_from_integer,'(i4)') n
    else if( n<100000 ) then
       write(string_from_integer,'(i5)') n
    else if( n<1000000 ) then
       write(string_from_integer,'(i6)') n
    else if( n<10000000 ) then
       write(string_from_integer,'(i7)') n
    else if( n<100000000 ) then
       write(string_from_integer,'(i8)') n
    else
       call mpp_error(FATAL, 'fms_io_mod: n is too big, contact developer')
    end if

    return

  end function string_from_integer

  !#######################################################################
  function string_from_real(a)
    real, intent(in) :: a
    character(len=32) :: string_from_real

    write(string_from_real,*) a

    return

  end function string_from_real

  !#######################################################################

 subroutine get_tile_string(str_out, str_in, tile, str2_in)
    character(len=*), intent(inout)        :: str_out
    character(len=*), intent(in)           :: str_in
    integer,          intent(in)           :: tile
    character(len=*), intent(in), optional :: str2_in

    if(tile > 0 .AND. tile < 9) then
       write(str_out,'(a,i1)') trim(str_in), tile
    else if(tile >= 10 .AND. tile < 99) then
       write(str_out,'(a,i2)') trim(str_in), tile
    else
       call mpp_error(FATAL, "FMS_IO: get_tile_string: tile must be a positive number less than 100")
    end if

    if(present(str2_in)) str_out=trim(str_out)//trim(str2_in)

 end subroutine get_tile_string


  !#####################################################################
  subroutine get_mosaic_tile_file(file_in, file_out, is_no_domain, domain, tile_count)
    character(len=*), intent(in)                   :: file_in
    character(len=*), intent(out)                  :: file_out
    logical,          intent(in)                   :: is_no_domain
    type(domain2D),   intent(in), optional, target :: domain
    integer,          intent(in), optional         :: tile_count 
    character(len=256)                             :: basefile, tilename
    integer                                        :: lens, ntiles, ntileMe, tile
    integer, dimension(:), allocatable             :: tile_id
    type(domain2d), pointer, save                  :: d_ptr =>NULL()

    !--- deal with the situation that the file is alreday in the full name.
    lens = len_trim(file_in)
    if(lens > 8) then
       if(file_in(lens-7:lens) == '.nc'//trim(pe_name) ) then
         file_out = file_in
         return
        endif
    endif

    if(index(file_in, '.nc', back=.true.)==0) then
       basefile = trim(file_in)
    else
       lens = len_trim(file_in)
       if(file_in(lens-2:lens) .NE. '.nc') call mpp_error(FATAL, &
            'fms_io_mod: .nc should be at the end of file '//trim(file_in))
       basefile = file_in(1:lens-3)
    end if

    if(mpp_mosaic_defined())then
       !--- get the tile name
       ntiles = 1
       if(PRESENT(domain))then
          ntiles = mpp_get_ntile_count(domain)
          d_ptr => domain
       elseif (ASSOCIATED(Current_domain) .AND. .NOT. is_no_domain ) then
          ntiles = mpp_get_ntile_count(Current_domain)
          d_ptr => Current_domain
       endif
       if(ntiles > 1 )then
          ntileMe = mpp_get_current_ntile(d_ptr)
          allocate(tile_id(ntileMe))
          tile_id = mpp_get_tile_id(d_ptr)
          tile = 1
          if(present(tile_count)) tile = tile_count
          tilename = 'tile'//string(tile_id(tile))
          deallocate(tile_id)
          if(index(basefile,'.'//trim(tilename),back=.true.) == 0)then
             basefile = trim(basefile)//'.'//trim(tilename);
          end if
       end if
    endif

    file_out = trim(basefile)//'.nc'

    d_ptr =>NULL()

  end subroutine get_mosaic_tile_file

  !#############################################################################
  subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count) 
    character(len=*), intent(out)          :: grid_file
    character(len=*), intent(in)           :: mosaic_file
    type(domain2D),   intent(in)           :: domain
    integer,          intent(in), optional :: tile_count 
    integer                                :: tile, ntileMe
    integer, dimension(:), allocatable     :: tile_id

    tile = 1
    if(present(tile_count)) tile = tile_count
    ntileMe = mpp_get_current_ntile(domain)
    allocate(tile_id(ntileMe))
    tile_id = mpp_get_tile_id(domain)     
    call read_data(mosaic_file, "gridfiles", grid_file, level=tile_id(tile) )
    grid_file = 'INPUT/'//trim(grid_file)
    deallocate(tile_id)

  end subroutine get_mosaic_tile_grid

  subroutine get_var_att_value_text(file, varname, attname, attvalue)
    character(len=*), intent(in)    :: file
    character(len=*), intent(in)    :: varname
    character(len=*), intent(in)    :: attname
    character(len=*), intent(inout) :: attvalue
    integer                         :: unit

    call mpp_open(unit,trim(file),MPP_RDONLY,MPP_NETCDF,threading=MPP_MULTI,fileset=MPP_SINGLE)
    call mpp_get_att_value(unit, varname, attname, attvalue)
    call mpp_close(unit)
 
    return

  end subroutine get_var_att_value_text

  !#############################################################################
  ! return false if the attribute is not find in the file.
  function get_global_att_value_text(file, att, attvalue)
    character(len=*), intent(in)    :: file
    character(len=*), intent(in)    :: att
    character(len=*), intent(inout) :: attvalue
    logical                         :: get_global_att_value_text
    integer                         :: unit, ndim, nvar, natt, ntime, i
    type(atttype), allocatable      :: global_atts(:)

    get_global_att_value_text = .false.
    call mpp_open(unit,trim(file),MPP_RDONLY,MPP_NETCDF,threading=MPP_MULTI,fileset=MPP_SINGLE)
    call mpp_get_info(unit, ndim, nvar, natt, ntime)
    allocate(global_atts(natt))
    call mpp_get_atts(unit,global_atts)
    do i=1,natt
       if( trim(mpp_get_att_name(global_atts(i))) == trim(att) ) then
          attvalue = trim(mpp_get_att_char(global_atts(i)))
          get_global_att_value_text = .true.
          exit
       end if
    end do
    deallocate(global_atts)

    return

  end function get_global_att_value_text

  !#############################################################################
  ! return false if the attribute is not find in the file.
  function get_global_att_value_real(file, att, attvalue)
    character(len=*), intent(in)    :: file
    character(len=*), intent(in)    :: att
    real,             intent(inout) :: attvalue
    logical                         :: get_global_att_value_real
    integer                         :: unit, ndim, nvar, natt, ntime, i
    type(atttype), allocatable      :: global_atts(:)

    get_global_att_value_real = .false.
    call mpp_open(unit,trim(file),MPP_RDONLY,MPP_NETCDF,threading=MPP_MULTI,fileset=MPP_SINGLE)
    call mpp_get_info(unit, ndim, nvar, natt, ntime)
    allocate(global_atts(natt))
    call mpp_get_atts(unit,global_atts)
    do i=1,natt
       if( trim(mpp_get_att_name(global_atts(i))) == trim(att) ) then
          attvalue = mpp_get_att_real_scalar(global_atts(i))
          get_global_att_value_real = .true.
          exit
       end if
    end do
    deallocate(global_atts)

    return

  end function get_global_att_value_real

  !#############################################################################
  ! This routine will get the actual file name, as well as if read_dist is true or false.
  ! return true if such file exist and return false if not.
  function get_file_name(orig_file, actual_file, read_dist, io_domain_exist, no_domain, domain, &
                           tile_count)
    character(len=*),                 intent(in) :: orig_file
    character(len=*),                intent(out) :: actual_file
    logical,                         intent(out) :: read_dist
    logical,                         intent(out) :: io_domain_exist
    logical,                optional, intent(in) :: no_domain
    type(domain2D), target, optional, intent(in) :: domain
    integer,                optional, intent(in) :: tile_count  
    logical                                      :: get_file_name

    type(domain2d), pointer, save :: d_ptr, io_domain
    logical                       :: fexist, is_no_domain
    integer                       :: tile_id(1)
    character(len=256)            :: fname

    is_no_domain=.false.
    if(PRESENT(no_domain)) is_no_domain = no_domain

    if(present(domain)) then
       d_ptr => domain
    elseif (ASSOCIATED(Current_domain) .AND. .NOT. is_no_domain ) then
       d_ptr => Current_domain
    endif

    fexist          = .false.
    read_dist       = .false.
    get_file_name   = .false.
    io_domain_exist = .false.

  !--- The file maybe not netcdf file, we just check the original file.
    if(index(orig_file, '.nc', back=.true.) == 0) then
       inquire (file=trim(orig_file), exist=fexist)
       if(fexist) then
          actual_file = orig_file
          get_file_name = .true.
          return
       endif
    endif 
    
    !JWD:  This is likely a temporary fix. Since fms_io needs to know tile_count, 
    !JWD:  I just don't see how the physics can remain "tile neutral"
    call get_mosaic_tile_file(orig_file, actual_file, is_no_domain, domain, tile_count)

    !--- check if the file is group redistribution.
    if(ASSOCIATED(d_ptr)) then
       io_domain => mpp_get_io_domain(d_ptr)
       if(associated(io_domain)) then
          tile_id = mpp_get_tile_id(io_domain)       
          if(mpp_npes()>10000) then
             write(fname, '(a,i6.6)' ) trim(actual_file)//'.', tile_id(1)
          else
             write(fname, '(a,i4.4)' ) trim(actual_file)//'.', tile_id(1)
          endif
          inquire (file=trim(fname), exist=fexist)
          if(fexist) io_domain_exist = .true.
       endif   
       io_domain=>NULL()
    endif 

    if(.not. fexist) inquire (file=trim(actual_file)//trim(pe_name), exist=fexist)

    if(fexist) then
       read_dist = .true.
       d_ptr => NULL()
       get_file_name = .true.
       return
    endif

    inquire (file=trim(actual_file), exist=fexist)
    if(fexist) then
       d_ptr => NULL()
       get_file_name = .true.
       return
    endif    

    !Perhaps the file has an ensemble instance appendix
    call get_instance_filename(actual_file, actual_file)
    inquire (file=trim(actual_file)//trim(pe_name), exist=fexist)  
    if(.not. fexist) inquire (file=trim(actual_file)//'.nc'//trim(pe_name), exist=fexist)     
    if(fexist) then
       read_dist = .true. 
       d_ptr => NULL()
       get_file_name = .true.
       return
    endif    
    inquire (file=trim(actual_file), exist=fexist)
          if(.not. fexist) inquire (file=trim(actual_file)//'.nc', exist=fexist)
    
    if(fexist) then
       d_ptr => NULL()
       get_file_name = .true.
       return
    endif

  end function get_file_name
  

  !#############################################################################
  subroutine get_file_unit(filename, unit, index_file, read_dist, io_domain_exist, domain )
    character(len=*),         intent(in) :: filename
    integer,                 intent(out) :: unit, index_file 
    logical,                  intent(in) :: read_dist, io_domain_exist
    type(domain2d), optional, intent(in) :: domain    

    logical  :: file_opened
    integer  :: i

    ! Need to check if filename has been opened or not
    file_opened=.false.
    do i=1,num_files_r
       if (files_read(i)%name == trim(filename))  then
          index_file = i
          unit = files_read(index_file)%unit
          return 
       endif
    enddo

    ! need to open the file now
    ! Increase num_files_r and set file_type 
    if(num_files_r == max_files_r) &  ! need to have bigger max_files_r
         call mpp_error(FATAL,'fms_io(get_file_unit): max_files_r exceeded, increase it via fms_io_nml')
    num_files_r=num_files_r + 1 
    if (read_dist .and. thread_r == MPP_SINGLE) then
       call mpp_error(FATAL,'fms_io(get_file_unit): single-threaded read from distributed fileset not allowed' &
            //'change threading_read to MULTI')
    endif
    if(read_dist) then
       if(io_domain_exist) then
          if(present(domain)) then
             call mpp_open(unit,filename,form=form,action=MPP_RDONLY,threading=MPP_MULTI, &
                fileset=MPP_MULTI, domain=domain)
          else if(ASSOCIATED(current_domain) ) then
             call mpp_open(unit,filename,form=form,action=MPP_RDONLY,threading=MPP_MULTI, &
                fileset=MPP_MULTI, domain=current_domain)
          else
             call mpp_error(FATAL,'fms_io(get_file_unit): when io_domain_exsit = .true., '// &
                   'either domain is present or current_domain is associated')
          endif
       else
          call mpp_open(unit,trim(filename),form=form,action=MPP_RDONLY,threading=thread_r, &
            fileset=MPP_MULTI)
       endif
    else
       call mpp_open(unit,trim(filename),form=form,action=MPP_RDONLY,threading=thread_r, &
            fileset=MPP_SINGLE)
    end if
    files_read(num_files_r)%name = trim(filename)
    allocate(files_read(num_files_r)%var (max_fields) )
    files_read(num_files_r)%nvar = 0
    index_file = num_files_r
    files_read(index_file)%unit = unit   

  end subroutine get_file_unit

  !#############################################################################
  subroutine get_field_id(unit, index_file, fieldname, index_field, is_no_domain, is_not_dim)
    integer,          intent(in) :: unit
    integer,          intent(in) :: index_file
    character(len=*), intent(in) :: fieldname
    integer,         intent(out) :: index_field
    logical,          intent(in) :: is_no_domain
    logical,          intent(in) :: is_not_dim

    character(len=128)                     :: name
    type(axistype),  dimension(max_axes)   :: axes
    type(fieldtype), dimension(max_fields) :: fields
    integer                                :: i, j, ndim, nvar, natt, var_dim
    integer                                :: siz_in(4)

    index_field = -1
    do j = 1, files_read(index_file)%nvar
       if (trim(files_read(index_file)%var(j)%name) == trim(fieldname)) then
          index_field = j
          return
       endif
    enddo

    !--- fieldname is not read, so need to get fieldname from file 
    files_read(index_file)%nvar = files_read(index_file)%nvar + 1
    if(files_read(index_file)%nvar > max_fields) then
       write(error_msg,'(I3,"/",I3)') files_read(index_file)%nvar, max_fields 
       call  mpp_error(FATAL,'fms_io(get_field_id): max_fields exceeded, needs increasing, nvar/max_fields=' &
            //trim(error_msg))
    endif
    call mpp_get_info(unit, ndim, nvar, natt, files_read(index_file)%max_ntime)
    if(files_read(index_file)%max_ntime < 1)  files_read(index_file)%max_ntime = 1
    if(nvar > max_fields) then
       write(error_msg,'(I3,"/",I3)') files_read(index_file)%nvar,max_fields
       call mpp_error(FATAL,'fms_io(get_field_id): max_fields too small needs increasing,nvar/max_fields=' &
            //trim(error_msg)//'in file'//trim(files_read(index_file)%name))
    endif
    call mpp_get_fields(unit, fields(1:nvar))     
    siz_in = 1
    index_field = files_read(index_file)%nvar
    files_read(index_file)%var(index_field)%is_dimvar = .false.

    do i=1, nvar
       call mpp_get_atts(fields(i),name=name,ndim=var_dim,siz=siz_in)
       if (lowercase(trim(name)) == lowercase(trim(fieldname))) then ! found the variable
          if(var_dim .lt.3) then
             do j=var_dim+1,3
                siz_in(j)=1
             enddo
          endif
          files_read(index_file)%var(index_field)%name    = fieldname
          files_read(index_file)%var(index_field)%field   = fields(i)
          files_read(index_file)%var(index_field)%siz(:)  = siz_in
          files_read(index_file)%var(index_field)%gsiz(:) = siz_in
          return
       endif
    enddo

    !--- the fieldname may be a dimension variable.
    if( .not. is_not_dim) then
       if (ndim > max_axes) then
          write(error_msg,'(I3,"/",I3)') ndim, max_axes 
          call  mpp_error(FATAL,'fms_io(get_field_id): max_axes exceeded, needs increasing, ndim/max_fields=' &
               //trim(error_msg)//' in file '//trim(files_read(index_file)%name))             
       endif
       call mpp_get_axes(unit, axes(1:ndim))
       do i=1,ndim
          call mpp_get_atts(axes(i), name=name, len = siz_in(1)) 
          if (lowercase(trim(name)) == lowercase(trim(fieldname))) then
             if(.not. is_no_domain) call mpp_error(FATAL, &
                  'fms_io(get_field_id): the field is a dimension variable, no_domain should be true.')
             files_read(index_file)%var(index_field)%is_dimvar = .true.
             files_read(index_file)%var(index_field)%name      = fieldname
             files_read(index_file)%var(index_field)%axis      = axes(i)
             files_read(index_file)%var(index_field)%siz(:)    = siz_in
             files_read(index_file)%var(index_field)%gsiz(:)   = siz_in
             return
          endif
       enddo
    end if
    !--- the field is not in the file when reaching here.
    call mpp_error(FATAL, 'fms_io(get_field_id): field '//trim(fieldname)// &
                   ' NOT found in file '//trim(files_read(index_file)%name))

  end subroutine get_field_id

!#######################################################################
! check the existence of the given file name
! if the file_name string has zero length or the
! first character is blank return a false result
! <FUNCTION NAME="file_exist">

!   <OVERVIEW>
!     Checks the existence of a given file name.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Checks the existence of the given file name.
!     If the file_name string has zero length or the
!     first character is blank return a false result.
!   </DESCRIPTION>
!   <TEMPLATE>
!     file_exist ( file_name )
!   </TEMPLATE>

!   <IN NAME="file_name"  TYPE="character" >
!     A file name (or path name) that is checked for existence.
!   </IN>
!   <OUT NAME=""  TYPE="logical" >
!     This function returns a logical result.  If file_name exists the result 
!     is true, otherwise false is returned.
!     If the length of character string "file_name" is zero or the first
!     character is blank, then the returned value will be false.
!     When reading a file, this function is often used in conjunction with
!     routine open_file.
!   </OUT>
!   <ERROR MSG="set_domain not called" STATUS="FATAL">
!     Before calling write_data you must first call set_domain with domain2d data 
!     type associated with the distributed data you are writing.
!   </ERROR>

 function file_exist (file_name, domain, no_domain)
  character(len=*), intent(in)         :: file_name
  type(domain2d), intent(in), optional :: domain
  logical,        intent(iN), optional :: no_domain  

  logical                              :: file_exist, is_no_domain
  character(len=256)                   :: fname
  logical                              :: read_dist, io_domain_exist

  is_no_domain = .false.
  if(present(no_domain)) is_no_domain = no_domain
   !--- to deal with mosaic file, in this case, the file is assumed to be in netcdf format
   file_exist = get_file_name(file_name, fname, read_dist, io_domain_exist, no_domain=is_no_domain, domain=domain)
   if(is_no_domain) return
   if(.not.file_exist) file_exist=get_file_name(file_name, fname, read_dist, io_domain_exist, no_domain=.true.)   

   return
 
 end function file_exist
! </FUNCTION>


!#######################################################################
! <FUNCTION NAME="field_exist">

!   <OVERVIEW>
!     check if a given field name exists in a given file name. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     check if a given field name exists in a given file name. 
!     If the field_name string has zero length or the
!     first character is blank return a false result.
!     if the file file_name don't exist, return a false result.
!   </DESCRIPTION>
!   <TEMPLATE>
!     field_exist ( file_name, field_name )
!   </TEMPLATE>

!   <IN NAME="file_name"  TYPE="character" >
!     A file name (or path name) that is checked for existence.
!   </IN>
!   <IN NAME="field_name"  TYPE="character" >
!     A field name that is checked for existence.
!   </IN>
!   <OUT NAME=""  TYPE="logical" >
!     This function returns a logical result.  If field exists in the 
!     file file_name, the result is true, otherwise false is returned.
!     If the length of character string "field_name" is zero or the first
!     character is blank, then the returned value will be false.
!     if the file file_name don't exist, return a false result.
!   </OUT>

 function field_exist (file_name, field_name, domain, no_domain)
  character(len=*),                 intent(in) :: file_name
  character(len=*),                 intent(in) :: field_name
  type(domain2d), intent(in), optional, target :: domain
  logical,       intent(in),  optional         :: no_domain
  logical                      :: field_exist, is_no_domain
  integer                      :: unit, ndim, nvar, natt, ntime, i, nfile
  character(len=64)            :: name
  type(fieldtype), allocatable :: fields(:)
  logical                      :: file_exist, read_dist, io_domain_exist
  character(len=256)           :: fname

   field_exist = .false.
   if (len_trim(field_name) == 0) return
   if (field_name(1:1) == ' ')    return

   is_no_domain = .false.
   if(present(no_domain)) is_no_domain = no_domain   

   file_exist=get_file_name(file_name, fname, read_dist, io_domain_exist, no_domain=is_no_domain, domain=domain)
   if(file_exist) then
      call get_file_unit(fname, unit, nfile, read_dist, io_domain_exist, domain=domain)
      call mpp_get_info(unit, ndim, nvar, natt, ntime)
      allocate(fields(nvar))
      call mpp_get_fields(unit,fields)

      do i=1, nvar
         call mpp_get_atts(fields(i),name=name)
         if(lowercase(trim(name)) == lowercase(trim(field_name))) field_exist = .true.
      enddo
      deallocate(fields)
    endif
    if(field_exist .or. is_no_domain) return
    file_exist =  get_file_name(file_name, fname, read_dist, io_domain_exist, no_domain=.true.)
    if(file_exist) then
       call get_file_unit(fname, unit, nfile, read_dist, io_domain_exist)
       call mpp_get_info(unit, ndim, nvar, natt, ntime)
       allocate(fields(nvar))
       call mpp_get_fields(unit,fields)
       do i=1, nvar
          call mpp_get_atts(fields(i),name=name)
          if(lowercase(trim(name)) == lowercase(trim(field_name))) field_exist = .true.
       enddo
       deallocate(fields)
    endif

    return

 end function field_exist
! </FUNCTION>

subroutine set_filename_appendix(string_in)
  character(len=*) , intent(in) :: string_in
  filename_appendix = trim(string_in)
end subroutine set_filename_appendix

subroutine get_instance_filename(name_in,name_out)
  character(len=*)  , intent(in)  :: name_in
  character(len=*), intent(inout) :: name_out
  integer :: length
  
  length = len_trim(name_in)
  name_out = name_in(1:length)
  
  if(len_trim(filename_appendix) > 0) then
     if(name_in(length-2:length) == '.nc') then
        name_out = name_in(1:length-3)//'.'//trim(filename_appendix)//'.nc'
     else
        name_out = name_in(1:length)  //'.'//trim(filename_appendix)
     end if
  end if
  
end subroutine get_instance_filename

end module fms_io_mod




#ifdef test_fms_io

 program fms_io_test
#include <fms_platform.h>

 use mpp_mod,         only: mpp_pe, mpp_npes, mpp_root_pe, mpp_init, mpp_exit
 use mpp_mod,         only: stdout, mpp_error, FATAL, NOTE, mpp_chksum
 use mpp_mod,         only: input_nml_file
 use mpp_domains_mod, only: domain2D, mpp_define_layout, mpp_define_mosaic
 use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain
 use mpp_domains_mod, only: mpp_domains_init, mpp_domains_exit
 use mpp_domains_mod, only: mpp_domains_set_stack_size, mpp_define_io_domain
 use mpp_io_mod,      only: mpp_open, mpp_close, MPP_ASCII, MPP_RDONLY
 use fms_io_mod,      only: read_data, write_data, fms_io_init, fms_io_exit
 use fms_io_mod,      only: file_exist, register_restart_field, save_restart, restore_state
 use fms_io_mod,      only: restart_file_type
 use mpp_io_mod,      only: MAX_FILE_SIZE

 implicit none

 integer :: sizex_latlon_grid = 144
 integer :: sizey_latlon_grid = 90
 integer :: size_cubic_grid = 48
 integer :: nz = 10, nt = 2, halo = 1
 integer :: stackmax =4000000
 integer :: num_step = 4 ! number of time steps to run, this is used for intermediate run.
                         ! set num_step = 0 for no intermediate run.
 logical :: do_write=.true. ! set this to false for high resolution and single file,
                            ! split file capability is not implemented for write_data
 integer :: layout_cubic (2) = (/0,0/)
 integer :: layout_latlon(2) = (/0,0/)  
 integer :: io_layout(2) = (/0,0/) ! set ndivs_x and ndivs_y to divide each tile into io_layout(1)*io_layout(2)
                                   ! group and write out data from the root pe of each group.

 namelist /test_fms_io_nml/ sizex_latlon_grid, sizey_latlon_grid, size_cubic_grid, &
                            nz, nt, halo, num_step, stackmax, do_write, layout_cubic, layout_latlon, io_layout

 integer           :: unit, io_status, step
 character(len=20) :: time_stamp

 type data_storage_type
    real,    allocatable, dimension(:,:,:,:) :: data1_r3d, data2_r3d, data1_r3d_read, data2_r3d_read
    real,    allocatable, dimension(:,:,:)   :: data1_r2d, data2_r2d, data1_r2d_read, data2_r2d_read
    real,    allocatable, dimension(:,:)     :: data1_r1d, data2_r1d, data1_r1d_read, data2_r1d_read
    real,    allocatable, dimension(:)       :: data1_r0d, data2_r0d, data1_r0d_read, data2_r0d_read
    integer, allocatable, dimension(:,:,:,:) :: data1_i3d, data2_i3d, data1_i3d_read, data2_i3d_read
    integer, allocatable, dimension(:,:,:)   :: data1_i2d, data2_i2d, data1_i2d_read, data2_i2d_read
    integer, allocatable, dimension(:,:)     :: data1_i1d, data2_i1d, data1_i1d_read, data2_i1d_read
    integer, allocatable, dimension(:)       :: data1_i0d, data2_i0d, data1_i0d_read, data2_i0d_read
 end type data_storage_type
 
 type(data_storage_type), save :: latlon_data
 type(data_storage_type), save :: cubic_data
 type(domain2d),          save :: domain_latlon
 type(domain2d),          save :: domain_cubic
 type(restart_file_type), save :: restart_latlon
 type(restart_file_type), save :: restart_cubic
 integer                       :: ntile_latlon = 1
 integer                       :: ntile_cubic = 6
 integer                       :: npes

 character(len=128) :: file_latlon, file_cubic

 call mpp_init
 npes = mpp_npes()

 call mpp_domains_init  

 call fms_io_init

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, test_fms_io_nml, iostat=io_status)
#else
 if (file_exist('input.nml') )then
    call mpp_open(unit, 'input.nml',form=MPP_ASCII,action=MPP_RDONLY)
    read(unit,test_fms_io_nml,iostat=io_status)

    if (io_status > 0) then
     call mpp_error(FATAL,'=>test_fms_io: Error reading test_fms_io_nml')
  endif
    call mpp_close (unit)
 end if
#endif

 write(stdout(), test_fms_io_nml )
  call mpp_domains_set_stack_size(stackmax)
 !--- currently we assume at most two time level will be written to restart file.
 if(nt > 2) call mpp_error(FATAL, "test_fms_io: test_fms_io_nml variable nt should be no larger than 2")

 file_latlon   = "test.res.latlon_grid.save_restore.nc"
 file_cubic    = "test.res.cubic_grid.save_restore.nc"

 call setup_test_restart(restart_latlon, "latlon_grid", ntile_latlon, latlon_data, file_latlon, layout_latlon, domain_latlon)
 call setup_test_restart(restart_cubic,  "cubic_grid", ntile_cubic, cubic_data, file_cubic, layout_cubic, domain_cubic )

 if(file_exist('INPUT/'//trim(file_latlon), domain_latlon)) then
    call restore_state(restart_latlon)
    call compare_restart("latlon_grid save_restore", latlon_data)
 end if
 if(file_exist('INPUT/'//trim(file_cubic), domain_cubic) ) then
    call restore_state(restart_cubic)
    call compare_restart("cubic_grid save_restore", cubic_data)
 end if
 
 !---copy data
 if(mod(npes,ntile_latlon) == 0) call copy_restart_data(latlon_data)
 if(mod(npes,ntile_cubic) == 0 ) call copy_restart_data(cubic_data)

 do step = 1, num_step
    write(time_stamp, '(a,I4.4)') "step", step
    if(mod(npes,ntile_latlon) == 0) call save_restart(restart_latlon, time_stamp)
    if(mod(npes,ntile_cubic) == 0 ) call save_restart(restart_cubic, time_stamp)
 end do
 if(mod(npes,ntile_latlon) == 0) call save_restart(restart_latlon)
 if(mod(npes,ntile_cubic)  == 0) call save_restart(restart_cubic)

 if(mod(npes,ntile_latlon) == 0) call release_storage_memory(latlon_data)
 if(mod(npes,ntile_cubic) == 0 ) call release_storage_memory(cubic_data)

 if(mod(npes,ntile_cubic) == 0 ) call mpp_error(NOTE, "test_fms_io: restart test is done for latlon_grid")
 if(mod(npes,ntile_cubic) == 0 ) call mpp_error(NOTE, "test_fms_io: restart test is done for cubic_grid")

 call fms_io_exit
 call mpp_domains_exit
 call mpp_exit

contains

  !******************************************************************************
  subroutine setup_test_restart(restart_data, type, ntiles, storage, file, layout_in, domain)
    type(restart_file_type),   intent(inout) :: restart_data
    character(len=*), intent(in)             :: type
    integer,          intent(in)             :: ntiles
    type(data_storage_type), intent(inout)   :: storage
    character(len=*), intent(in)             :: file  
    integer,          intent(in)             :: layout_in(:)
    type(domain2d),   intent(inout)          :: domain
    character(len=128)                       :: file_r
    character(len=128)                       :: file_w
    integer                                  :: pe, npes_per_tile, tile
    integer                                  :: num_contact
    integer                                  :: n, layout(2)
    integer, allocatable, dimension(:,:)     :: global_indices, layout2D
    integer, allocatable, dimension(:)       :: pe_start, pe_end
    integer, dimension(1)                    :: tile1, tile2
    integer, dimension(1)                    :: istart1, iend1, jstart1, jend1
    integer, dimension(1)                    :: istart2, iend2, jstart2, jend2
    integer                                  :: i, j, k, nx, ny
    integer                                  :: isc, iec, jsc, jec
    integer                                  :: isd, ied, jsd, jed
    integer                                  :: id_restart

    file_r = "INPUT/test.res."//trim(type)//".read_write.nc"
    file_w = "RESTART/test.res."//trim(type)//".read_write.nc"

    select case(type)
    case("latlon_grid")
       nx = sizex_latlon_grid
       ny = sizey_latlon_grid
    case("cubic_grid")
       nx = size_cubic_grid
       ny = size_cubic_grid
    case default
       call mpp_error(FATAL, "test_fms_io: "//type//" is not a valid option")
    end select

    pe   = mpp_pe()
    if(mod(npes,ntiles) .NE. 0) then
       call mpp_error(NOTE, "test_fms_io: npes can not be divided by ntiles, no test will be done for "//trim(type))
       return
    end if
    npes_per_tile = npes/ntiles
    tile = pe/npes_per_tile + 1

    if(layout_in(1)*layout_in(2) == npes_per_tile) then
       layout = layout_in
    else
       call mpp_define_layout( (/1,nx,1,ny/), npes_per_tile, layout )
    endif
    if(io_layout(1) <1 .OR. io_layout(2) <1) call mpp_error(FATAL, &
            "program test_fms_io: both elements of test_fms_io_nml variable io_layout must be positive integer")
    if(mod(layout(1), io_layout(1)) .NE. 0 ) call mpp_error(FATAL, &
         "program test_fms_io: layout(1) must be divided by io_layout(1)")
    if(mod(layout(2), io_layout(2)) .NE. 0 ) call mpp_error(FATAL, &
         "program test_fms_io: layout(2) must be divided by io_layout(2)")    
    allocate(global_indices(4,ntiles), layout2D(2,ntiles), pe_start(ntiles), pe_end(ntiles) )
    do n = 1, ntiles
       global_indices(:,n) = (/1,nx,1,ny/)
       layout2D(:,n)       = layout
       pe_start(n)         = (n-1)*npes_per_tile
       pe_end(n)           = n*npes_per_tile-1
    end do
    num_contact = 0
    call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                           istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                           pe_start, pe_end, whalo=halo, ehalo=halo, shalo=halo, nhalo=halo, name = type  )
    if(io_layout(1) .NE. 1 .OR. io_layout(2) .NE. 1) call mpp_define_io_domain(domain, io_layout)

    call mpp_get_compute_domain(domain, isc, iec, jsc, jec)
    call mpp_get_data_domain(domain, isd, ied, jsd, jed)

    allocate(storage%data1_r3d(isd:ied, jsd:jed, nz, nt), storage%data1_r3d_read(isd:ied, jsd:jed, nz, nt) )
    allocate(storage%data2_r3d(isd:ied, jsd:jed, nz, nt), storage%data2_r3d_read(isd:ied, jsd:jed, nz, nt) )
    allocate(storage%data1_i3d(isd:ied, jsd:jed, nz, nt), storage%data1_i3d_read(isd:ied, jsd:jed, nz, nt) )
    allocate(storage%data2_i3d(isd:ied, jsd:jed, nz, nt), storage%data2_i3d_read(isd:ied, jsd:jed, nz, nt) )
    allocate(storage%data1_r2d(isd:ied, jsd:jed,     nt), storage%data1_r2d_read(isd:ied, jsd:jed,     nt) )
    allocate(storage%data2_r2d(isd:ied, jsd:jed,     nt), storage%data2_r2d_read(isd:ied, jsd:jed,     nt) )
    allocate(storage%data1_i2d(isd:ied, jsd:jed,     nt), storage%data1_i2d_read(isd:ied, jsd:jed,     nt) )
    allocate(storage%data2_i2d(isd:ied, jsd:jed,     nt), storage%data2_i2d_read(isd:ied, jsd:jed,     nt) )
    allocate(storage%data1_r1d(                  nz, nt), storage%data1_r1d_read(                  nz, nt) )
    allocate(storage%data2_r1d(                  nz, nt), storage%data2_r1d_read(                  nz, nt) )
    allocate(storage%data1_i1d(                  nz, nt), storage%data1_i1d_read(                  nz, nt) )
    allocate(storage%data2_i1d(                  nz, nt), storage%data2_i1d_read(                  nz, nt) )
    allocate(storage%data1_r0d(                      nt), storage%data1_r0d_read(                      nt) )
    allocate(storage%data2_r0d(                      nt), storage%data2_r0d_read(                      nt) )
    allocate(storage%data1_i0d(                      nt), storage%data1_i0d_read(                      nt) )
    allocate(storage%data2_i0d(                      nt), storage%data2_i0d_read(                      nt) )

    storage%data1_r3d = 0; storage%data1_r3d_read = 0; storage%data2_r3d = 0; storage%data2_r3d_read = 0
    storage%data1_i3d = 0; storage%data1_i3d_read = 0; storage%data2_i3d = 0; storage%data2_i3d_read = 0
    storage%data1_r2d = 0; storage%data1_r2d_read = 0; storage%data2_r2d = 0; storage%data2_r2d_read = 0
    storage%data1_i2d = 0; storage%data1_i2d_read = 0; storage%data2_i2d = 0; storage%data2_i2d_read = 0
    storage%data1_r1d = 0; storage%data1_r1d_read = 0; storage%data2_r1d = 0; storage%data2_r1d_read = 0
    storage%data1_i1d = 0; storage%data1_i1d_read = 0; storage%data2_i1d = 0; storage%data2_i1d_read = 0
    storage%data1_r0d = 0; storage%data1_r0d_read = 0; storage%data2_r0d = 0; storage%data2_r0d_read = 0
    storage%data1_i0d = 0; storage%data1_i0d_read = 0; storage%data2_i0d = 0; storage%data2_i0d_read = 0
    do n = 1, nt
       storage%data1_r0d(n) =  tile + n*1e-3
       storage%data2_r0d(n) = -tile - n*1e-3
       storage%data1_i0d(n) =  tile*1e3 + n
       storage%data2_i0d(n) = -tile*1e3 - n
       do k = 1, nz
          storage%data1_r1d(k,n) =   tile*1e3 + n + k*1e-3
          storage%data2_r1d(k,n) =  -tile*1e3 - n - k*1e-3
          storage%data1_i1d(k,n) =   tile*1e6 + n*1e3 + k
          storage%data2_i1d(k,n) =  -tile*1e6 - n*1e3 - k
          do j = jsc, jec
             do i = isc, iec
                storage%data1_r3d(i,j,k,n) =  tile*1e6 + n*1e3 + k + i*1e-3 + j*1e-6; 
                storage%data2_r3d(i,j,k,n) = -tile*1e6 - n*1e3 - k - i*1e-3 - j*1e-6; 
                storage%data1_i3d(i,j,k,n) =  tile*1e9 + n*1e8 + k*1e6 + i*1e3 + j; 
                storage%data2_i3d(i,j,k,n) = -tile*1e9 - n*1e8 - k*1e6 - i*1e3 - j; 
             end do
          end do
       end do

       do j = jsc, jec
          do i = isc, iec
             storage%data1_r2d(i,j,n) =  tile*1e1 + n + i*1e-3 + j*1e-6; 
             storage%data2_r2d(i,j,n) = -tile*1e1 - n - i*1e-3 - j*1e-6; 
             storage%data1_i2d(i,j,n) =  tile*1e7 + n*1e6 + i*1e3 + j; 
             storage%data2_i2d(i,j,n) = -tile*1e7 - n*1e6 - i*1e3 - j; 
          end do
       end do
    end do
    if(file_exist(file_r, domain)) then
       do n = 1, nt
          call read_data(file_r, "data1_r3d", storage%data1_r3d_read(:,:,:,n), domain, timelevel = n )
          call read_data(file_r, "data2_r3d", storage%data2_r3d_read(:,:,:,n), domain, timelevel = n )
          call read_data(file_r, "data1_i3d", storage%data1_i3d_read(:,:,:,n), domain, timelevel = n )
          call read_data(file_r, "data2_i3d", storage%data2_i3d_read(:,:,:,n), domain, timelevel = n )
          call read_data(file_r, "data1_r2d", storage%data1_r2d_read(:,:,  n), domain, timelevel = n )
          call read_data(file_r, "data2_r2d", storage%data2_r2d_read(:,:,  n), domain, timelevel = n )
          call read_data(file_r, "data1_i2d", storage%data1_i2d_read(:,:,  n), domain, timelevel = n )
          call read_data(file_r, "data2_i2d", storage%data2_i2d_read(:,:,  n), domain, timelevel = n )
          call read_data(file_r, "data1_r1d", storage%data1_r1d_read(:,    n), domain, timelevel = n )
          call read_data(file_r, "data2_r1d", storage%data2_r1d_read(:,    n), domain, timelevel = n )
          call read_data(file_r, "data1_i1d", storage%data1_i1d_read(:,    n), domain, timelevel = n )
          call read_data(file_r, "data2_i1d", storage%data2_i1d_read(:,    n), domain, timelevel = n )
          call read_data(file_r, "data1_r0d", storage%data1_r0d_read(      n), domain, timelevel = n )
          call read_data(file_r, "data2_r0d", storage%data2_r0d_read(      n), domain, timelevel = n )
          call read_data(file_r, "data1_i0d", storage%data1_i0d_read(      n), domain, timelevel = n )
          call read_data(file_r, "data2_i0d", storage%data2_i0d_read(      n), domain, timelevel = n )
       end do
       call compare_restart(type//" read_write", storage)
    end if


    !--- high resolution restart is not implemented for write data
    if(do_write ) then 
       do n = 1, nt
          call write_data(file_w, "data1_r3d", storage%data1_r3d(:,:,:,n), domain )
          call write_data(file_w, "data2_r3d", storage%data2_r3d(:,:,:,n), domain )
          call write_data(file_w, "data1_i3d", storage%data1_i3d(:,:,:,n), domain )
          call write_data(file_w, "data2_i3d", storage%data2_i3d(:,:,:,n), domain )
          call write_data(file_w, "data1_r2d", storage%data1_r2d(:,:,  n), domain )
          call write_data(file_w, "data2_r2d", storage%data2_r2d(:,:,  n), domain )
          call write_data(file_w, "data1_i2d", storage%data1_i2d(:,:,  n), domain )
          call write_data(file_w, "data2_i2d", storage%data2_i2d(:,:,  n), domain )
          call write_data(file_w, "data1_r1d", storage%data1_r1d(:,    n), domain )
          call write_data(file_w, "data2_r1d", storage%data2_r1d(:,    n), domain )
          call write_data(file_w, "data1_i1d", storage%data1_i1d(:,    n), domain )
          call write_data(file_w, "data2_i1d", storage%data2_i1d(:,    n), domain )
          call write_data(file_w, "data1_r0d", storage%data1_r0d(      n), domain )
          call write_data(file_w, "data2_r0d", storage%data2_r0d(      n), domain )
          call write_data(file_w, "data1_i0d", storage%data1_i0d(      n), domain )
          call write_data(file_w, "data2_i0d", storage%data2_i0d(      n), domain )
       end do
    end if

    !--- test register_restart_field, save_restart, restore_state

    id_restart = register_restart_field(restart_data, file, "data1_r3d", storage%data1_r3d_read(:,:,:,1), &
                                domain, longname="first data_r3d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_r3d", storage%data1_r3d_read(:,:,:,2), &
                                domain, longname="first data_r3d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_r3d", storage%data2_r3d_read(:,:,:,1), &
                                storage%data2_r3d_read(:,:,:,2), &
                                domain, longname="second data_i3d", units="none")

    id_restart = register_restart_field(restart_data, file, "data1_i3d", storage%data1_i3d_read(:,:,:,1), &
                                domain, longname="first data_i3d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_i3d", storage%data1_i3d_read(:,:,:,2), &
                                domain, longname="first data_i3d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_i3d", storage%data2_i3d_read(:,:,:,1), &
                                storage%data2_i3d_read(:,:,:,2), &
                                domain, longname="second data_i3d", units="none")

    id_restart = register_restart_field(restart_data, file, "data1_r2d", storage%data1_r2d_read(:,:,  1), &
                                domain, longname="first data_r2d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_r2d", storage%data1_r2d_read(:,:,  2), &
                                domain, longname="first data_r2d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_r2d", storage%data2_r2d_read(:,:,  1), &
                                storage%data2_r2d_read(:,:,2), &
                                domain, longname="second data_i2d", units="none")

    id_restart = register_restart_field(restart_data, file, "data1_i2d", storage%data1_i2d_read(:,:,  1), &
                                domain, longname="first data_i2d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_i2d", storage%data1_i2d_read(:,:,  2), &
                                domain, longname="first data_i2d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_i2d", storage%data2_i2d_read(:,:,  1), &
                                storage%data2_i2d_read(:,:,2), &
                                domain, longname="second data_i2d", units="none")

    id_restart = register_restart_field(restart_data, file, "data1_r1d", storage%data1_r1d_read(:,    1), &
                                domain, longname="first data_r1d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_r1d", storage%data1_r1d_read(:,    2), &
                                domain, longname="first data_r1d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_r1d", storage%data2_r1d_read(:,    1), &
                                storage%data2_r1d_read(:,  2), &
                                domain, longname="second data_i1d", units="none")

    id_restart = register_restart_field(restart_data, file, "data1_i1d", storage%data1_i1d_read(:,    1), &
                                domain, longname="first data_i1d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_i1d", storage%data1_i1d_read(:,    2), &
                                domain, longname="first data_i1d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_i1d", storage%data2_i1d_read(:,    1), &
                                storage%data2_i1d_read(:,  2), &
                                domain, longname="second data_i1d", units="none")


    id_restart = register_restart_field(restart_data, file, "data1_r0d", storage%data1_r0d_read(      1), &
                                domain, longname="first data_r0d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_r0d", storage%data1_r0d_read(      2), &
                                domain, longname="first data_r0d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_r0d", storage%data2_r0d_read(      1), &
                                storage%data2_r0d_read(    2), &
                                domain, longname="second data_i0d", units="none")

    id_restart = register_restart_field(restart_data, file, "data1_i0d", storage%data1_i0d_read(      1), &
                                domain, longname="first data_i0d",units="none")
    id_restart = register_restart_field(restart_data, file, "data1_i0d", storage%data1_i0d_read(      2), &
                                domain, longname="first data_i0d",units="none")
    id_restart = register_restart_field(restart_data, file, "data2_i0d", storage%data2_i0d_read(      1), &
                                storage%data2_i0d_read(    2), &
                                domain, longname="second data_i0d", units="none")

  end subroutine setup_test_restart

  subroutine compare_restart(type, storage)
    character(len=*), intent(in)             :: type
    type(data_storage_type), intent(inout)   :: storage

       call compare_data_r4d(storage%data1_r3d, storage%data1_r3d_read, type//" data1_r3d")
       call compare_data_r4d(storage%data2_r3d, storage%data2_r3d_read, type//" data2_r3d")
       call compare_data_i4d(storage%data1_i3d, storage%data1_i3d_read, type//" data1_i3d")
       call compare_data_i4d(storage%data2_i3d, storage%data2_i3d_read, type//" data2_i3d")
       call compare_data_r3d(storage%data1_r2d, storage%data1_r2d_read, type//" data1_r2d")
       call compare_data_r3d(storage%data2_r2d, storage%data2_r2d_read, type//" data2_r2d")
       call compare_data_i3d(storage%data1_i2d, storage%data1_i2d_read, type//" data1_i2d")
       call compare_data_i3d(storage%data2_i2d, storage%data2_i2d_read, type//" data2_i2d")
       call compare_data_r2d(storage%data1_r1d, storage%data1_r1d_read, type//" data1_r1d")
       call compare_data_r2d(storage%data2_r1d, storage%data2_r1d_read, type//" data2_r1d")
       call compare_data_i2d(storage%data1_i1d, storage%data1_i1d_read, type//" data1_i1d")
       call compare_data_i2d(storage%data2_i1d, storage%data2_i1d_read, type//" data2_i1d")
       call compare_data_r1d(storage%data1_r0d, storage%data1_r0d_read, type//" data1_r0d")
       call compare_data_r1d(storage%data2_r0d, storage%data2_r0d_read, type//" data2_r0d")
       call compare_data_i1d(storage%data1_i0d, storage%data1_i0d_read, type//" data1_i0d")
       call compare_data_i1d(storage%data2_i0d, storage%data2_i0d_read, type//" data2_i0d")

  end subroutine compare_restart

  subroutine release_storage_memory(storage)
    type(data_storage_type), intent(inout)   :: storage

    deallocate(storage%data1_r3d, storage%data2_r3d, storage%data1_r3d_read, storage%data2_r3d_read)
    deallocate(storage%data1_i3d, storage%data2_i3d, storage%data1_i3d_read, storage%data2_i3d_read)
    deallocate(storage%data1_r2d, storage%data2_r2d, storage%data1_r2d_read, storage%data2_r2d_read)
    deallocate(storage%data1_i2d, storage%data2_i2d, storage%data1_i2d_read, storage%data2_i2d_read)
    deallocate(storage%data1_r1d, storage%data2_r1d, storage%data1_r1d_read, storage%data2_r1d_read)
    deallocate(storage%data1_i1d, storage%data2_i1d, storage%data1_i1d_read, storage%data2_i1d_read)
    deallocate(storage%data1_r0d, storage%data2_r0d, storage%data1_r0d_read, storage%data2_r0d_read)
    deallocate(storage%data1_i0d, storage%data2_i0d, storage%data1_i0d_read, storage%data2_i0d_read)

  end subroutine release_storage_memory

  subroutine copy_restart_data(storage)
    type(data_storage_type), intent(inout)   :: storage

    storage%data1_r3d_read = storage%data1_r3d; storage%data2_r3d_read = storage%data2_r3d
    storage%data1_i3d_read = storage%data1_i3d; storage%data2_i3d_read = storage%data2_i3d
    storage%data1_r2d_read = storage%data1_r2d; storage%data2_r2d_read = storage%data2_r2d
    storage%data1_i2d_read = storage%data1_i2d; storage%data2_i2d_read = storage%data2_i2d
    storage%data1_r1d_read = storage%data1_r1d; storage%data2_r1d_read = storage%data2_r1d
    storage%data1_i1d_read = storage%data1_i1d; storage%data2_i1d_read = storage%data2_i1d
    storage%data1_r0d_read = storage%data1_r0d; storage%data2_r0d_read = storage%data2_r0d
    storage%data1_i0d_read = storage%data1_i0d; storage%data2_i0d_read = storage%data2_i0d

    return

  end subroutine copy_restart_data

  subroutine compare_data_r4d( a, b, string )
    real, intent(in), dimension(:,:,:,:) :: a, b
    character(len=*), intent(in)         :: string
    integer(LONG_KIND)                   :: sum1, sum2
    integer                              :: i, j, k, l
    integer, parameter                   :: stdunit = 6

    if(size(a,1) .ne. size(b,1) .or. size(a,2) .ne. size(b,2) .or. size(a,3) .ne. size(b,3) .or. size(a,4) .ne. size(b,4) ) &
         call mpp_error(FATAL,'compare_data_r4d: size of a and b does not match')

    do l = 1, size(a,4)
       do k = 1, size(a,3)
          do j = 1, size(a,2)
             do i = 1, size(a,1)
                if(a(i,j,k,l) .ne. b(i,j,k,l)) then
                   write(stdunit,'(a,i3,a,i3,a,i3,a,i3,a,i3,a,f18.9,a,f18.9)')" at pe ", mpp_pe(), &
                        ", at point (",i,", ", j, ", ", k, ", ", l, "), a = ", a(i,j,k,l), ", b = ", b(i,j,k,l)
                   call mpp_error(FATAL, trim(string)//': point by point comparison are not OK.')
                endif
             enddo
          enddo
       enddo
    enddo
    sum1 = mpp_chksum( a, (/mpp_pe()/) )
    sum2 = mpp_chksum( b, (/mpp_pe()/) )

    if( sum1.EQ.sum2 )then
       if( mpp_pe() .EQ. mpp_root_pe() )call mpp_error( NOTE, trim(string)//': OK.' )
       !--- in some case, even though checksum agree, the two arrays 
       !    actually are different, like comparing (1.1,-1.2) with (-1.1,1.2)
       !--- hence we need to check the value point by point.
    else
       call mpp_error( FATAL, trim(string)//': chksums are not OK.' )
    end if
  end subroutine compare_data_r4d

  subroutine compare_data_i4d( a, b, string )
    integer, intent(in), dimension(:,:,:,:) :: a, b
    character(len=*), intent(in)            :: string
    real                                    :: real_a(size(a,1),size(a,2),size(a,3),size(a,4))
    real                                    :: real_b(size(b,1),size(b,2),size(b,3),size(b,4))

    real_a = a 
    real_b = b
    call compare_data_r4d(real_a, real_b, string)

  end subroutine compare_data_i4d


  subroutine compare_data_r3d( a, b, string )
    real, intent(in), dimension(:,:,:) :: a, b
    character(len=*), intent(in)       :: string
    integer(LONG_KIND)                 :: sum1, sum2
    integer                            :: i, j, l
    integer, parameter                 :: stdunit = 6

    if(size(a,1) .ne. size(b,1) .or. size(a,2) .ne. size(b,2) .or. size(a,3) .ne. size(b,3) ) &
         call mpp_error(FATAL,'compare_data_r3d: size of a and b does not match')

    do l = 1, size(a,3)
       do j = 1, size(a,2)
          do i = 1, size(a,1)
             if(a(i,j,l) .ne. b(i,j,l)) then
                write(stdunit,'(a,i3,a,i3,a,i3,a,i3,a,f16.9,a,f16.9)')" at pe ", mpp_pe(), &
                     ", at point (",i,", ", j, ", ", l, "), a = ", a(i,j,l), ", b = ", b(i,j,l)
                call mpp_error(FATAL, trim(string)//': point by point comparison are not OK.')
             endif
          enddo
       enddo
    enddo
    sum1 = mpp_chksum( a, (/mpp_pe()/) )
    sum2 = mpp_chksum( b, (/mpp_pe()/) )

    if( sum1.EQ.sum2 )then
       if( mpp_pe() .EQ. mpp_root_pe() )call mpp_error( NOTE, trim(string)//': OK.' )
       !--- in some case, even though checksum agree, the two arrays 
       !    actually are different, like comparing (1.1,-1.2) with (-1.1,1.2)
       !--- hence we need to check the value point by point.
    else
       call mpp_error( FATAL, trim(string)//': chksums are not OK.' )
    end if
  end subroutine compare_data_r3d

  subroutine compare_data_i3d( a, b, string )
    integer, intent(in), dimension(:,:,:) :: a, b
    character(len=*), intent(in)          :: string
    real                                  :: real_a(size(a,1),size(a,2),size(a,3))
    real                                  :: real_b(size(b,1),size(b,2),size(b,3))

    real_a = a 
    real_b = b
    call compare_data_r3d(real_a, real_b, string)

  end subroutine compare_data_i3d


  subroutine compare_data_r2d( a, b, string )
    real, intent(in), dimension(:,:) :: a, b
    character(len=*), intent(in)     :: string
    integer(LONG_KIND)               :: sum1, sum2
    integer                          :: i, l
    integer, parameter               :: stdunit = 6

    if(size(a,1) .ne. size(b,1) .or. size(a,2) .ne. size(b,2) ) &
         call mpp_error(FATAL,'compare_data_r2d: size of a and b does not match')

    do l = 1, size(a,2)
       do i = 1, size(a,1)
          if(a(i,l) .ne. b(i,l)) then
             write(stdunit,'(a,i3,a,i3,a,i3,a,f16.9,a,f16.9)')" at pe ", mpp_pe(), &
                  ", at point (",i, ", ", l, "), a = ", a(i,l), ", b = ", b(i,l)
             call mpp_error(FATAL, trim(string)//': point by point comparison are not OK.')
          endif
       enddo
    end do
    sum1 = mpp_chksum( a, (/mpp_pe()/) )
    sum2 = mpp_chksum( b, (/mpp_pe()/) )

    if( sum1.EQ.sum2 )then
       if( mpp_pe() .EQ. mpp_root_pe() )call mpp_error( NOTE, trim(string)//': OK.' )
       !--- in some case, even though checksum agree, the two arrays 
       !    actually are different, like comparing (1.1,-1.2) with (-1.1,1.2)
       !--- hence we need to check the value point by point.
    else
       call mpp_error( FATAL, trim(string)//': chksums are not OK.' )
    end if
  end subroutine compare_data_r2d

  subroutine compare_data_i2d( a, b, string )
    integer, intent(in), dimension(:,:) :: a, b
    character(len=*), intent(in)        :: string
    real                                :: real_a(size(a,1),size(a,2))
    real                                :: real_b(size(b,1),size(b,2))

    real_a = a 
    real_b = b
    call compare_data_r2d(real_a, real_b, string)

  end subroutine compare_data_i2d

  subroutine compare_data_r1d( a, b, string )
    real, intent(in), dimension(:) :: a, b
    character(len=*), intent(in)   :: string
    integer(LONG_KIND)             :: sum1, sum2
    integer                        :: l
    integer, parameter             :: stdunit = 6

    if(size(a,1) .ne. size(b,1) ) &
         call mpp_error(FATAL,'compare_data_r1d: size of a and b does not match')

    do l = 1, size(a(:))
       if(a(l) .ne. b(l)) then
          write(stdunit,'(a,i3,a,i3,a,f16.9,a,f16.9)')" at pe ", mpp_pe(), &
               ", at point (",l, "), a = ", a(l), ", b = ", b(l)
          call mpp_error(FATAL, trim(string)//': point by point comparison are not OK.')
       endif
    enddo
    sum1 = mpp_chksum( a, (/mpp_pe()/) )
    sum2 = mpp_chksum( b, (/mpp_pe()/) )

    if( sum1.EQ.sum2 )then
       if( mpp_pe() .EQ. mpp_root_pe() )call mpp_error( NOTE, trim(string)//': OK.' )
       !--- in some case, even though checksum agree, the two arrays 
       !    actually are different, like comparing (1.1,-1.2) with (-1.1,1.2)
       !--- hence we need to check the value point by point.
    else
       call mpp_error( FATAL, trim(string)//': chksums are not OK.' )
    end if
  end subroutine compare_data_r1d

  subroutine compare_data_i1d( a, b, string )
    integer, intent(in), dimension(:) :: a, b
    character(len=*), intent(in)      :: string
    real                              :: real_a(size(a(:)))
    real                              :: real_b(size(b(:)))

    real_a = a 
    real_b = b
    call compare_data_r1d(real_a, real_b, string)

  end subroutine compare_data_i1d

end program fms_io_test

#else
module null_fms_io_test
end module  

#endif  /* test_fms_io */


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                   !!
!!                   GNU General Public License                      !!
!!                                                                   !!
!! This file is part of the Flexible Modeling System (FMS).          !!
!!                                                                   !!
!! FMS is free software; you can redistribute it and/or modify       !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation.             !!
!!                                                                   !!
!! FMS 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 FMS; if not, write to:                                 !!
!!          Free Software Foundation, Inc.                           !!
!!          59 Temple Place, Suite 330                               !!
!!          Boston, MA  02111-1307  USA                              !!
!! or see:                                                           !!
!!          http://www.gnu.org/licenses/gpl.txt                      !!
!!                                                                   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module horiz_interp_mod

! <CONTACT EMAIL="Zhi.Liang@noaa.gov"> Zhi Liang </CONTACT>
! <CONTACT EMAIL="Bruce.Wyman@noaa.gov"> Bruce Wyman </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Performs spatial interpolation between grids.
! </OVERVIEW>

! <DESCRIPTION>
!     This module can interpolate data from any logically rectangular grid
!     to any logically rectangular grid. Four interpolation schems are used here:
!     conservative, bilinear, bicubic and inverse of square distance weighted. 
!     The four interpolation schemes are implemented seperately in 
!     horiz_interp_conserver_mod, horiz_interp_blinear_mod, horiz_interp_bicubic_mod
!     and horiz_interp_spherical_mod. bicubic interpolation requires the source grid
!     is regular lon/lat grid. User can choose the interpolation method in the 
!     public interface horiz_interp_new through optional argument interp_method,
!     with acceptable value "conservative", "bilinear", "bicubic" and "spherical".
!     The default value is "conservative". There is an optional mask field for 
!     missing input data. An optional output mask field may be used in conjunction with
!     the input mask to show where output data exists.
! </DESCRIPTION>

!-----------------------------------------------------------------------
!
!        Performs spatial interpolation between grids.
!
!-----------------------------------------------------------------------

use fms_mod,                    only: write_version_number, fms_error_handler
use mpp_mod,                    only: mpp_error, FATAL, stdout, mpp_min
use constants_mod,              only: pi
use horiz_interp_type_mod,      only: horiz_interp_type, assignment(=)
use horiz_interp_type_mod,      only: CONSERVE, BILINEAR, SPHERICA, BICUBIC
use horiz_interp_conserve_mod,  only: horiz_interp_conserve_init, horiz_interp_conserve
use horiz_interp_conserve_mod,  only: horiz_interp_conserve_new, horiz_interp_conserve_del
use horiz_interp_bilinear_mod,  only: horiz_interp_bilinear_init, horiz_interp_bilinear
use horiz_interp_bilinear_mod,  only: horiz_interp_bilinear_new, horiz_interp_bilinear_del
use horiz_interp_bicubic_mod,   only: horiz_interp_bicubic_init, horiz_interp_bicubic
use horiz_interp_bicubic_mod,   only: horiz_interp_bicubic_new, horiz_interp_bicubic_del
use horiz_interp_spherical_mod, only: horiz_interp_spherical_init, horiz_interp_spherical
use horiz_interp_spherical_mod, only: horiz_interp_spherical_new, horiz_interp_spherical_del

 implicit none
 private

!---- interfaces ----

 public   horiz_interp_type, horiz_interp, horiz_interp_new, horiz_interp_del, &
          horiz_interp_init, horiz_interp_end, assignment(=)

! <INTERFACE NAME="horiz_interp_new">
!   <OVERVIEW>
!      Allocates space and initializes a derived-type variable
!      that contains pre-computed interpolation indices and weights.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Allocates space and initializes a derived-type variable
!      that contains pre-computed interpolation indices and weights
!      for improved performance of multiple interpolations between
!      the same grids. This routine does not need to be called if you
!      are doing a single grid-to-grid interpolation.
!   </DESCRIPTION>
!   <IN NAME="lon_in" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians">
!      Longitude (in radians) for source data grid. You can pass 1-D lon_in to 
!      represent the geographical longitude of regular lon/lat grid, or just 
!      pass geographical longitude(lon_in is 2-D). The grid location may be 
!      located at grid cell edge or center, decided by optional argument "grid_at_center".
!   </IN>
!   <IN NAME="lat_in" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians">
!      Latitude (in radians) for source data grid. You can pass 1-D lat_in to 
!      represent the geographical latitude of regular lon/lat grid, or just 
!      pass geographical latitude(lat_in is 2-D). The grid location may be 
!      located at grid cell edge or center, decided by optional argument "grid_at_center".
!   </IN>
!   <IN NAME="lon_out" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians" >
!      Longitude (in radians) for destination data grid. You can pass 1-D lon_out to 
!      represent the geographical longitude of regular lon/lat grid, or just 
!      pass geographical longitude(lon_out is 2-D). The grid location may be 
!      located at grid cell edge or center, decided by optional argument "grid_at_center".
!   </IN>
!   <IN NAME="lat_out" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians" >
!      Latitude (in radians) for destination data grid. You can pass 1-D lat_out to 
!      represent the geographical latitude of regular lon/lat grid, or just 
!      pass geographical latitude(lat_out is 2-D). The grid location may be 
!      located at grid cell edge or center, decided by optional argument "grid_at_center".
!   </IN>
!   <IN NAME="verbose" TYPE="integer">
!      Integer flag that controls the amount of printed output.
!      verbose = 0, no output; = 1, min,max,means; = 2, still more
!   </IN>
!   <IN NAME="interp_method" TYPE="character(len=*)" > 
!      interpolation method, = "conservative", using conservation scheme,
!      = "bilinear", using bilinear interpolation, = "spherical",using spherical regrid.
!      = "bicubic", using bicubic interpolation. The default value is "convervative".
!   </IN>
!   <IN NAME = "src_modulo" >
!      Indicate the source data grid is cyclic or not.
!   </IN>
!   <IN NAME = "grid_at_center" >
!      Indicate the data is on the center of grid box or the edge of grid box. 
!      When true, the data is on the center of grid box. default vaule is false.
!      This option is only available when interp_method = "bilinear" or "bicubic".
!   </IN>
!   <OUT NAME="Interp" >
!      A derived-type variable containing indices and weights used for subsequent 
!      interpolations. To reinitialize this variable for a different grid-to-grid 
!      interpolation you must first use the "horiz_interp_del" interface.
!   </OUT>

 interface horiz_interp_new
    module procedure horiz_interp_new_1d     ! Source grid is 1d, destination grid is 1d
    module procedure horiz_interp_new_1d_src ! Source grid is 1d, destination grid is 2d
    module procedure horiz_interp_new_2d     ! Source grid is 2d, destination grid is 2d
    module procedure horiz_interp_new_1d_dst ! Source grid is 2d, destination grid is 1d
 end interface
! </INTERFACE>

! <INTERFACE NAME="horiz_interp">
!
!   <OVERVIEW>
!     Subroutine for performing the horizontal interpolation between two grids.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Subroutine for performing the horizontal interpolation between
!     two grids. There are two forms of this interface.
!     Form A requires first calling horiz_interp_new, while Form B
!     requires no initialization.
!   </DESCRIPTION>

!   <IN NAME="Interp" >
!     Derived-type variable containing interpolation indices and weights.
!     Returned by a previous call to horiz_interp_new.
!   </IN>
!   <IN NAME="data_in">
!      Input data on source grid.
!   </IN>
!   <IN NAME="verbose">
!      flag for the amount of print output.
!               verbose = 0, no output; = 1, min,max,means; = 2, still more
!   </IN>
!   <IN NAME="mask_in">
!      Input mask, must be the same size as the input data. The real value of
!      mask_in must be in the range (0.,1.). Set mask_in=0.0 for data points 
!      that should not be used or have missing data. It is Not needed for 
!      spherical regrid.
!   </IN>
!   <IN NAME="missing_value" >
!      Use the missing_value to indicate missing data.
!   </IN>
!   <IN NAME="missing_permit">
!      numbers of points allowed to miss for the bilinear interpolation. The value
!      should be between 0 and 3.
!   </IN>
!   <IN NAME="lon_in, lat_in" >
!      longitude and latitude (in radians) of source grid. More explanation can 
!      be found in the documentation of horiz_interp_new.
!   </IN>
!   <IN NAME="lon_out, lat_out" >
!      longitude and latitude (in radians) of destination grid. More explanation can 
!      be found in the documentation of horiz_interp_new.
!   </IN>
!   <OUT NAME="data_out">
!      Output data on destination grid.
!   </OUT>
!   <OUT NAME="mask_out">
!      Output mask that specifies whether data was computed.
!   </OUT>

!   <ERROR MSG="size of input array incorrect" STATUS="FATAL">
!      The input data array does not match the size of the input grid edges
!      specified. If you are using the initialization interface make sure you
!      have the correct grid size.
!   </ERROR>
!   <ERROR MSG="size of output array incorrect" STATUS="FATAL">
!      The output data array does not match the size of the input grid
!      edges specified. If you are using the initialization interface make
!      sure you have the correct grid size.
!   </ERROR>

 interface horiz_interp
    module procedure horiz_interp_base_2d
    module procedure horiz_interp_base_3d
    module procedure horiz_interp_solo_1d
    module procedure horiz_interp_solo_1d_src
    module procedure horiz_interp_solo_2d
    module procedure horiz_interp_solo_1d_dst
    module procedure horiz_interp_solo_old
 end interface
! </INTERFACE>

!-----------------------------------------------------------------------
 character(len=128) :: version = '$Id: horiz_interp.F90,v 16.0.8.1 2010/08/31 14:28:55 z1l Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
 logical            :: module_is_initialized = .FALSE.
!-----------------------------------------------------------------------

contains

!#######################################################################
!  <SUBROUTINE NAME="horiz_interp_init">
!  <OVERVIEW>
!     writes version number and tag name to logfile.out
!  </OVERVIEW>
!  <DESCRIPTION>       
!     writes version number and tag name to logfile.out
!  </DESCRIPTION>

  subroutine horiz_interp_init

  if(module_is_initialized) return
  call write_version_number (version, tagname)
  call horiz_interp_conserve_init
  call horiz_interp_bilinear_init
  call horiz_interp_bicubic_init
  call horiz_interp_spherical_init

  module_is_initialized = .true.

  end subroutine horiz_interp_init

!  </SUBROUTINE>

!#######################################################################
!  <SUBROUTINE NAME="horiz_interp_new_1d" INTERFACE="horiz_interp_new">
!  <IN NAME="lon_in" TYPE="real" DIM="(:),(:,:)" UNITS="radians"></IN>
!  <IN NAME="lat_in" TYPE="real" DIM="(:),(:,:)"></IN>
!  <IN NAME="lon_out" TYPE="real" DIM="(:),(:,:)"></IN>
!  <IN NAME="lat_out" TYPE="real" DIM="(:),(:,:)"></IN>
!  <IN NAME="verbose" TYPE="integer, optional"></IN>
!  <IN NAME="interp_method" TYPE="character(len=*),optional"></IN>
!  <IN NAME="src_modulo" TYPE="logical, optional" > </IN>
!  <OUT NAME="Interp" TYPE="type(horiz_interp_type)"></OUT>

!<PUBLICROUTINE INTERFACE="horiz_interp_new">
  subroutine horiz_interp_new_1d (Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                                  interp_method, num_nbrs, max_dist, src_modulo,     &
                                  grid_at_center, mask_in, mask_out)
!</PUBLICROUTINE>

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout)        :: Interp
    real, intent(in),  dimension(:)               :: lon_in , lat_in
    real, intent(in),  dimension(:)               :: lon_out, lat_out
    integer, intent(in),                 optional :: verbose
    character(len=*), intent(in),        optional :: interp_method
    integer, intent(in),                 optional :: num_nbrs
    real,    intent(in),                 optional :: max_dist
    logical, intent(in),                 optional :: src_modulo
    logical, intent(in),                 optional :: grid_at_center
    real, intent(in), dimension(:,:),    optional :: mask_in  ! dummy
    real, intent(out),dimension(:,:),    optional :: mask_out ! dummy
    !-----------------------------------------------------------------------
    real, dimension(:,:), allocatable :: lon_src, lat_src, lon_dst, lat_dst
    real, dimension(:),   allocatable :: lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d
    integer                           :: i, j, nlon_in, nlat_in, nlon_out, nlat_out
    logical                           :: center
    character(len=40)                 :: method
    !-----------------------------------------------------------------------
    call horiz_interp_init

    method = 'conservative'
    if(present(interp_method)) method = interp_method

    select case (trim(method))
    case ("conservative")
       Interp%interp_method = CONSERVE
       call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose)
    case ("bilinear")
       Interp%interp_method = BILINEAR
       center = .false.
       if(present(grid_at_center) ) center = grid_at_center
       if(center) then
          nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:))
          allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out))
          do i = 1, nlon_out
             lon_dst(i,:) = lon_out(i)
          enddo
          do j = 1, nlat_out
             lat_dst(:,j) = lat_out(j)
          enddo

          call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, &
               verbose, src_modulo)
          deallocate(lon_dst, lat_dst)
       else
          nlon_in  = size(lon_in(:))-1;  nlat_in  = size(lat_in(:))-1
          nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1
          allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in))
          allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out))
          do i = 1, nlon_in
             lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5
          enddo
          do j = 1, nlat_in
             lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5
          enddo
          do i = 1, nlon_out
             lon_dst(i,:) = (lon_out(i) + lon_out(i+1)) * 0.5
          enddo
          do j = 1, nlat_out
             lat_dst(:,j) = (lat_out(j) + lat_out(j+1)) * 0.5
          enddo
          call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_dst, lat_dst, &
               verbose, src_modulo)
          deallocate(lon_src_1d, lat_src_1d, lon_dst, lat_dst)
       endif
    case ("bicubic")
       Interp%interp_method = BICUBIC
       center = .false.
       if(present(grid_at_center) ) center = grid_at_center
       !No need to expand to 2d, horiz_interp_bicubic_new does 1d-1d
       if(center) then 
          call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
            verbose, src_modulo)
       else
          nlon_in  = size(lon_in(:))-1;  nlat_in  = size(lat_in(:))-1
          nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1
          allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in))
          allocate(lon_dst_1d(nlon_out), lat_dst_1d(nlat_out))
          do i = 1, nlon_in
             lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5
          enddo
          do j = 1, nlat_in
             lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5
          enddo
          do i = 1, nlon_out
             lon_dst_1d(i) = (lon_out(i) + lon_out(i+1)) * 0.5
          enddo
          do j = 1, nlat_out
             lat_dst_1d(j) = (lat_out(j) + lat_out(j+1)) * 0.5
          enddo
          call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d, &
               verbose, src_modulo)
          deallocate(lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d)
       endif
    case ("spherical")
       Interp%interp_method = SPHERICA
       nlon_in  = size(lon_in(:));   nlat_in  = size(lat_in(:))
       nlon_out  = size(lon_out(:)); nlat_out = size(lat_out(:))
       allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in))
       allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out))
       do i = 1, nlon_in
          lon_src(i,:) = lon_in(i)
       enddo
       do j = 1, nlat_in
          lat_src(:,j) = lat_in(j)
       enddo
       do i = 1, nlon_out
          lon_dst(i,:) = lon_out(i)
       enddo
       do j = 1, nlat_out
          lat_dst(:,j) = lat_out(j)
       enddo
       call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_dst, lat_dst, &
            num_nbrs, max_dist, src_modulo)
       deallocate(lon_src, lat_src, lon_dst, lat_dst)
    case default
       call mpp_error(FATAL,'horiz_interp_mod: interp_method should be conservative, bilinear, bicubic, spherical')
    end select

    !-----------------------------------------------------------------------
    Interp%I_am_initialized = .true.

  end subroutine horiz_interp_new_1d
!  </SUBROUTINE>

!#######################################################################

 subroutine horiz_interp_new_1d_src (Interp, lon_in, lat_in, lon_out, lat_out,   &
                                     verbose, interp_method, num_nbrs, max_dist, &
                                     src_modulo, grid_at_center, mask_in, mask_out, is_latlon_out )

   type(horiz_interp_type), intent(inout)        :: Interp
   real, intent(in),  dimension(:)               :: lon_in , lat_in
   real, intent(in),  dimension(:,:)             :: lon_out, lat_out
   integer, intent(in),                 optional :: verbose
   character(len=*), intent(in),        optional :: interp_method
   integer, intent(in),                 optional :: num_nbrs  ! minimum number of neighbors
   real,    intent(in),                 optional :: max_dist
   logical, intent(in),                 optional :: src_modulo
   logical, intent(in),                 optional :: grid_at_center
   real, intent(in), dimension(:,:),    optional :: mask_in
   real, intent(out),dimension(:,:),    optional :: mask_out
   logical, intent(in),                 optional :: is_latlon_out

   real, dimension(:,:), allocatable :: lon_src, lat_src
   real, dimension(:),   allocatable :: lon_src_1d, lat_src_1d
   integer                           :: i, j, nlon_in, nlat_in
   character(len=40)                 :: method
   logical                           :: center
   logical                           :: dst_is_latlon
   !-----------------------------------------------------------------------
   call horiz_interp_init

   method = 'conservative'
   if(present(interp_method)) method = interp_method

   select case (trim(method))
   case ("conservative")
      Interp%interp_method = CONSERVE
      !--- check to see if the source grid is regular lat-lon grid or not.
      if(PRESENT(is_latlon_out)) then
         dst_is_latlon = is_latlon_out
      else
         dst_is_latlon = is_lat_lon(lon_out, lat_out) 
      end if
      if(dst_is_latlon ) then
         if(present(mask_in)) then
            if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001)  ) call mpp_error(FATAL, &
                  'horiz_interp_conserve_new_1d_src(horiz_interp_conserve_mod): input mask not between 0,1')
            allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) )
            Interp%mask_in = mask_in
         end if
         call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), &
              verbose=verbose )
      else
         call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
              verbose=verbose, mask_in=mask_in, mask_out=mask_out )
      end if
   case ("bilinear")
      Interp%interp_method = BILINEAR
      center = .false.
      if(present(grid_at_center) ) center = grid_at_center
      if(center) then
         call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
              verbose, src_modulo )
      else
         nlon_in  = size(lon_in(:))-1;  nlat_in  = size(lat_in(:))-1
         allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in))
         do i = 1, nlon_in
            lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5
         enddo
         do j = 1, nlat_in
            lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5
         enddo
         call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, &
              verbose, src_modulo )
         deallocate(lon_src_1d,lat_src_1d)
      endif
   case ("bicubic")
      Interp%interp_method = BICUBIC
      center = .false.
      if(present(grid_at_center) ) center = grid_at_center
      if(center) then
        call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
              verbose, src_modulo )
      else
         nlon_in  = size(lon_in(:))-1;  nlat_in  = size(lat_in(:))-1
         allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in))
         do i = 1, nlon_in
            lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5
         enddo
         do j = 1, nlat_in
            lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5
         enddo
           call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, &
              verbose, src_modulo )
         deallocate(lon_src_1d,lat_src_1d)
      endif
   case ("spherical")
      Interp%interp_method = SPHERICA
      nlon_in  = size(lon_in(:));  nlat_in  = size(lat_in(:))
      allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in))
      do i = 1, nlon_in
         lon_src(i,:) = lon_in(i)
      enddo
      do j = 1, nlat_in
         lat_src(:,j) = lat_in(j)
      enddo
      call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_out, lat_out, &
           num_nbrs, max_dist, src_modulo)
      deallocate(lon_src, lat_src)
   case default
      call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical')
   end select

   !-----------------------------------------------------------------------
   Interp%I_am_initialized = .true.

 end subroutine horiz_interp_new_1d_src

!#######################################################################

 subroutine horiz_interp_new_2d (Interp, lon_in, lat_in, lon_out, lat_out,   &
                                 verbose, interp_method, num_nbrs, max_dist, &
                                 src_modulo, mask_in, mask_out, is_latlon_in, is_latlon_out  )
 type(horiz_interp_type), intent(inout)     :: Interp
 real, intent(in),  dimension(:,:)          :: lon_in , lat_in
 real, intent(in),  dimension(:,:)          :: lon_out, lat_out
 integer, intent(in),              optional :: verbose
 character(len=*), intent(in),     optional :: interp_method
 integer, intent(in),              optional :: num_nbrs
 real,    intent(in),              optional :: max_dist
 logical, intent(in),              optional :: src_modulo
 real, intent(in), dimension(:,:), optional :: mask_in
 real, intent(out),dimension(:,:), optional :: mask_out
 logical, intent(in),              optional :: is_latlon_in, is_latlon_out
 logical           :: src_is_latlon, dst_is_latlon
 character(len=40) :: method
!-----------------------------------------------------------------------
   call horiz_interp_init

   method = 'bilinear'
   if(present(interp_method)) method = interp_method

   select case (trim(method))
   case ("conservative")
      Interp%interp_method = CONSERVE
      if(PRESENT(is_latlon_in)) then
         src_is_latlon = is_latlon_in
      else
         src_is_latlon = is_lat_lon(lon_in, lat_in)
      end if
      if(PRESENT(is_latlon_out)) then
         dst_is_latlon = is_latlon_out
      else
         dst_is_latlon = is_lat_lon(lon_out, lat_out)
      end if
      if(src_is_latlon .AND. dst_is_latlon) then
         if(present(mask_in)) then
            if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001)  ) call mpp_error(FATAL, &
              'horiz_interp_conserve_new_2d(horiz_interp_conserve_mod): input mask not between 0,1')
            allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) )
            Interp%mask_in = mask_in
         end if
         call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out(:,1), lat_out(1,:), &
              verbose=verbose )
      else if(src_is_latlon) then
         call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, &
              verbose=verbose, mask_in=mask_in, mask_out=mask_out )
      else if(dst_is_latlon) then
         call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), &
              verbose=verbose, mask_in=mask_in, mask_out=mask_out )
      else 
         call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
              verbose=verbose, mask_in=mask_in, mask_out=mask_out )
      end if

   case ("spherical") 
      Interp%interp_method = SPHERICA
      call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
                                    num_nbrs, max_dist, src_modulo )
   case ("bilinear")
      Interp%interp_method = BILINEAR
      call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
                                        verbose, src_modulo )
   case default
      call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear')
   end select     

!-----------------------------------------------------------------------
   Interp%I_am_initialized = .true.

 end subroutine horiz_interp_new_2d

!#######################################################################
 subroutine horiz_interp_new_1d_dst (Interp, lon_in, lat_in, lon_out, lat_out,   &
      verbose, interp_method, num_nbrs, max_dist, src_modulo, mask_in, mask_out, is_latlon_in )
   type(horiz_interp_type), intent(inout)     :: Interp
   real, intent(in),  dimension(:,:)          :: lon_in , lat_in
   real, intent(in),  dimension(:)            :: lon_out, lat_out
   integer, intent(in),              optional :: verbose
   character(len=*), intent(in),     optional :: interp_method
   integer, intent(in),              optional :: num_nbrs
   real,    intent(in),              optional :: max_dist
   logical, intent(in),              optional :: src_modulo
   real, intent(in), dimension(:,:), optional :: mask_in
   real, intent(out),dimension(:,:), optional :: mask_out
   logical, intent(in),              optional :: is_latlon_in

   character(len=40) :: method
   !-------------some local variables-----------------------------------------------
   integer                           :: i, j, nlon_out, nlat_out
   real, dimension(:,:), allocatable :: lon_dst, lat_dst
   logical                           :: src_is_latlon
   !-----------------------------------------------------------------------
   call horiz_interp_init

   method = 'bilinear'
   if(present(interp_method)) method = interp_method

   nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:))
   allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out))
   do i = 1, nlon_out
      lon_dst(i,:) = lon_out(i)
   enddo
   do j = 1, nlat_out
      lat_dst(:,j) = lat_out(j)
   enddo

   select case (trim(method))
   case ("conservative")
      Interp%interp_method = CONSERVE
      if(PRESENT(is_latlon_in)) then
         src_is_latlon = is_latlon_in
      else
         src_is_latlon = is_lat_lon(lon_in, lat_in)
      end if      

      if(src_is_latlon) then
         if(present(mask_in)) then
            if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001)  ) call mpp_error(FATAL, &
              'horiz_interp_conserve_new_1d_dst(horiz_interp_conserve_mod): input mask not between 0,1')
            allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) )
            Interp%mask_in = mask_in
         end if
         call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, &
              verbose=verbose)
      else
         call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, &
              verbose=verbose, mask_in=mask_in, mask_out=mask_out )
      end if
   case ("bilinear")
      Interp%interp_method = BILINEAR
      call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, &
           verbose, src_modulo )
   case ("spherical")
      Interp%interp_method = SPHERICA
      call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, &
           num_nbrs, max_dist, src_modulo)
   case default
      call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear')
   end select

   deallocate(lon_dst,lat_dst)

   !-----------------------------------------------------------------------
   Interp%I_am_initialized = .true.

 end subroutine horiz_interp_new_1d_dst

!#######################################################################
! <SUBROUTINE NAME="horiz_interp_base_2d" INTERFACE="horiz_interp">
!   <IN NAME="Interp" TYPE="type(horiz_interp_type)"> </IN>
!   <IN NAME="data_in" TYPE="real" DIM="(:,:),(:,:,:)"> </IN>
!   <IN NAME="lon_in, lat_in" TYPE="real" DIM="(:),(:,:)"> </IN>
!   <IN NAME="lon_out, lat_out" TYPE="real" DIM="(:),(:,:)"> </IN>
!   <IN NAME="missing_value" TYPE="integer, optional" > </IN>
!   <IN NAME="missing_permit" TYPE="integer,optional" > </IN>
!   <IN NAME="verbose" TYPE="integer,optional"> </IN>
!   <IN NAME="mask_in" TYPE="real,optional" DIM="(:,:),(:,:,:)"> </IN>
!   <OUT NAME="data_out" TYPE="real" DIM="(:,:),(:,:,:)"> </OUT>
!   <OUT NAME="mask_out" TYPE="real,optional" DIM="(:,:),(:,:,:)"> </OUT>

!<PUBLICROUTINE INTERFACE="horiz_interp"> 
 subroutine horiz_interp_base_2d ( Interp, data_in, data_out, verbose, &
                                   mask_in, mask_out, missing_value, missing_permit, err_msg )
!</PUBLICROUTINE>
!-----------------------------------------------------------------------
   type (horiz_interp_type), intent(in) :: Interp
      real, intent(in),  dimension(:,:) :: data_in
      real, intent(out), dimension(:,:) :: data_out
   integer, intent(in),                   optional :: verbose
      real, intent(in),   dimension(:,:), optional :: mask_in
      real, intent(out),  dimension(:,:), optional :: mask_out
      real, intent(in),                   optional :: missing_value
      integer, intent(in),                optional :: missing_permit
   character(len=*), intent(out),         optional :: err_msg
!-----------------------------------------------------------------------
   if(present(err_msg)) err_msg = ''
   if(.not.Interp%I_am_initialized) then
     if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return
   endif

   select case(Interp%interp_method)
   case(CONSERVE)
      call horiz_interp_conserve(Interp,data_in, data_out, verbose, mask_in, mask_out)
   case(BILINEAR)
      call horiz_interp_bilinear(Interp,data_in, data_out, verbose, mask_in, mask_out, &
                             missing_value, missing_permit )
   case(BICUBIC)
      call horiz_interp_bicubic(Interp,data_in, data_out, verbose, mask_in, mask_out, &
                             missing_value, missing_permit )
   case(SPHERICA)
      call horiz_interp_spherical(Interp,data_in, data_out, verbose, mask_in, mask_out, &
                             missing_value )
   case default
      call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical')
   end select

   return

 end subroutine horiz_interp_base_2d
! </SUBROUTINE>

!#######################################################################

 subroutine horiz_interp_base_3d ( Interp, data_in, data_out, verbose, mask_in, mask_out, &
      missing_value, missing_permit, err_msg  )
   !-----------------------------------------------------------------------
   !   overload of interface horiz_interp_base_2d
   !   uses 3d arrays for data and mask
   !   this allows for multiple interpolations with one call
   !-----------------------------------------------------------------------
   type (horiz_interp_type), intent(in)           :: Interp
   real, intent(in),  dimension(:,:,:)            :: data_in
   real, intent(out), dimension(:,:,:)            :: data_out
   integer, intent(in),                  optional :: verbose
   real, intent(in),   dimension(:,:,:), optional :: mask_in
   real, intent(out),  dimension(:,:,:), optional :: mask_out
   real, intent(in),                     optional :: missing_value
   integer, intent(in),                  optional :: missing_permit
   character(len=*), intent(out),        optional :: err_msg
   !-----------------------------------------------------------------------
   integer :: n

   if(present(err_msg)) err_msg = ''
   if(.not.Interp%I_am_initialized) then          
     if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return
   endif

   do n = 1, size(data_in,3)
      if (present(mask_in))then
         if(present(mask_out)) then
            call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), &
                 verbose, mask_in(:,:,n), mask_out(:,:,n), &
                 missing_value, missing_permit )
         else
            call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), &
                 verbose, mask_in(:,:,n), missing_value = missing_value,  &
                 missing_permit = missing_permit )
         endif
      else
         if(present(mask_out)) then
            call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), &
                 verbose, mask_out=mask_out(:,:,n), missing_value = missing_value,  &
                 missing_permit = missing_permit )
         else
            call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), &
                 verbose, missing_value = missing_value,  &
                 missing_permit = missing_permit )
         endif
     endif
   enddo
  
   return
!-----------------------------------------------------------------------
 end subroutine horiz_interp_base_3d

!#######################################################################
!<PUBLICROUTINE INTERFACE="horiz_interp"> 
 subroutine horiz_interp_solo_1d ( data_in, lon_in, lat_in, lon_out, lat_out,    &
                                   data_out, verbose, mask_in, mask_out,         &
                                   interp_method, missing_value, missing_permit, &
                                   num_nbrs, max_dist,src_modulo, grid_at_center  )              
!</PUBLICROUTINE>
!-----------------------------------------------------------------------
!   interpolates from a rectangular grid to rectangular grid.
!   interp_method can be the value conservative, bilinear or spherical.
!   horiz_interp_new don't need to be called before calling this routine.

!-----------------------------------------------------------------------
      real, intent(in),  dimension(:,:) :: data_in
      real, intent(in),  dimension(:)   :: lon_in , lat_in
      real, intent(in),  dimension(:)   :: lon_out, lat_out
      real, intent(out), dimension(:,:) :: data_out
   integer, intent(in),                   optional :: verbose
      real, intent(in),   dimension(:,:), optional :: mask_in
      real, intent(out),  dimension(:,:), optional :: mask_out
   character(len=*), intent(in),          optional :: interp_method
      real, intent(in),                   optional :: missing_value
   integer, intent(in),                   optional :: missing_permit
   integer, intent(in),                   optional :: num_nbrs
      real, intent(in),                   optional :: max_dist
   logical, intent(in),                   optional :: src_modulo
   logical, intent(in),                   optional :: grid_at_center
!-----------------------------------------------------------------------
    type (horiz_interp_type) :: Interp
!-----------------------------------------------------------------------
    call horiz_interp_init

    call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                             interp_method, num_nbrs, max_dist, src_modulo, grid_at_center )

    call horiz_interp ( Interp, data_in, data_out, verbose,   &
                        mask_in, mask_out, missing_value, missing_permit )

    call horiz_interp_del ( Interp )
!-----------------------------------------------------------------------

 end subroutine horiz_interp_solo_1d

!#######################################################################

 subroutine horiz_interp_solo_1d_src ( data_in, lon_in, lat_in, lon_out, lat_out,    &
                                       data_out, verbose, mask_in, mask_out,         &
                                       interp_method, missing_value, missing_permit, &
                                       num_nbrs, max_dist, src_modulo, grid_at_center )
!-----------------------------------------------------------------------
!
!   interpolates from a uniformly spaced grid to any output grid.
!   interp_method can be the value "onservative","bilinear" or "spherical".
!   horiz_interp_new don't need to be called before calling this routine.
!
!-----------------------------------------------------------------------
      real, intent(in),  dimension(:,:) :: data_in
      real, intent(in),  dimension(:)   :: lon_in , lat_in
      real, intent(in),  dimension(:,:) :: lon_out, lat_out
      real, intent(out), dimension(:,:) :: data_out
   integer, intent(in),                   optional :: verbose
      real, intent(in),   dimension(:,:), optional :: mask_in
      real, intent(out),  dimension(:,:), optional :: mask_out
   character(len=*), intent(in),          optional :: interp_method
      real, intent(in),                   optional :: missing_value
   integer, intent(in),                   optional :: missing_permit
   integer, intent(in),                   optional :: num_nbrs
      real, intent(in),                   optional :: max_dist
   logical, intent(in),                   optional :: src_modulo
   logical, intent(in),                   optional :: grid_at_center

!-----------------------------------------------------------------------
   type (horiz_interp_type) :: Interp
   logical                  :: dst_is_latlon
   character(len=128)       :: method
!-----------------------------------------------------------------------
    call horiz_interp_init
    method = 'conservative'
    if(present(interp_method)) method = interp_method
    dst_is_latlon = .true.
    if(trim(method) == 'conservative') dst_is_latlon = is_lat_lon(lon_out, lat_out)

    if(dst_is_latlon) then
       call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                               interp_method, num_nbrs, max_dist, src_modulo,    &
                               grid_at_center, is_latlon_out = dst_is_latlon )
       call horiz_interp ( Interp, data_in, data_out, verbose,   &
                           mask_in, mask_out, missing_value, missing_permit )
    else
       call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                               interp_method, num_nbrs, max_dist, src_modulo,    &
                               grid_at_center, mask_in, mask_out, is_latlon_out = dst_is_latlon)

       call horiz_interp ( Interp, data_in, data_out, verbose,   &
                           missing_value=missing_value, missing_permit=missing_permit )
    end if

    call horiz_interp_del ( Interp )

!-----------------------------------------------------------------------

 end subroutine horiz_interp_solo_1d_src


!#######################################################################

 subroutine horiz_interp_solo_2d ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, &
                                   verbose, mask_in, mask_out, interp_method, missing_value,&
                                   missing_permit, num_nbrs, max_dist, src_modulo  )
!-----------------------------------------------------------------------
!
!   interpolates from any grid to any grid. interp_method should be "spherical"
!   horiz_interp_new don't need to be called before calling this routine.
!
!-----------------------------------------------------------------------
      real, intent(in),  dimension(:,:) :: data_in
      real, intent(in),  dimension(:,:) :: lon_in , lat_in
      real, intent(in),  dimension(:,:) :: lon_out, lat_out
      real, intent(out), dimension(:,:) :: data_out
   integer, intent(in),                   optional :: verbose
      real, intent(in),   dimension(:,:), optional :: mask_in
      real, intent(out),  dimension(:,:), optional :: mask_out
   character(len=*), intent(in),          optional :: interp_method
      real, intent(in),                   optional :: missing_value
   integer, intent(in),                   optional :: missing_permit
   integer, intent(in),                   optional :: num_nbrs
      real, intent(in),                   optional :: max_dist
   logical, intent(in),                   optional :: src_modulo
!-----------------------------------------------------------------------
   type (horiz_interp_type) :: Interp
   logical                  :: dst_is_latlon, src_is_latlon
   character(len=128)       :: method
!-----------------------------------------------------------------------
    call horiz_interp_init

    method = 'conservative'
    if(present(interp_method)) method = interp_method
    dst_is_latlon = .true.
    src_is_latlon = .true.
    if(trim(method) == 'conservative') then
       dst_is_latlon = is_lat_lon(lon_out, lat_out)
       src_is_latlon = is_lat_lon(lon_in, lat_in)
    end if

    if(dst_is_latlon .and. src_is_latlon) then
       call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                               interp_method, num_nbrs, max_dist, src_modulo,    &
                               is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon )
       call horiz_interp ( Interp, data_in, data_out, verbose,   &
                           mask_in, mask_out, missing_value, missing_permit )
    else
       call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                               interp_method, num_nbrs, max_dist, src_modulo,    &
                               mask_in, mask_out, &
                               is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon)
       call horiz_interp ( Interp, data_in, data_out, verbose,   &
                           missing_value=missing_value, missing_permit=missing_permit )
    end if

    call horiz_interp_del ( Interp )

!-----------------------------------------------------------------------

 end subroutine horiz_interp_solo_2d

!#######################################################################

 subroutine horiz_interp_solo_1d_dst ( data_in, lon_in, lat_in, lon_out, lat_out, data_out,    &
                                       verbose, mask_in, mask_out,interp_method,missing_value, &
                                       missing_permit,  num_nbrs, max_dist, src_modulo)
!-----------------------------------------------------------------------
!
!   interpolates from any grid to rectangular longitude/latitude grid. 
!   interp_method should be "spherical".
!   horiz_interp_new don't need to be called before calling this routine.
!
!-----------------------------------------------------------------------
      real, intent(in),  dimension(:,:) :: data_in
      real, intent(in),  dimension(:,:) :: lon_in , lat_in
      real, intent(in),  dimension(:)   :: lon_out, lat_out
      real, intent(out), dimension(:,:) :: data_out
   integer, intent(in),                   optional :: verbose  
      real, intent(in),   dimension(:,:), optional :: mask_in
      real, intent(out),  dimension(:,:), optional :: mask_out
   character(len=*), intent(in),          optional :: interp_method
      real, intent(in),                   optional :: missing_value
   integer, intent(in),                   optional :: missing_permit
   integer, intent(in),                   optional :: num_nbrs
      real, intent(in),                   optional :: max_dist
   logical, intent(in),                   optional :: src_modulo
!-----------------------------------------------------------------------
   type (horiz_interp_type) :: Interp
   logical                  :: src_is_latlon
   character(len=128)       :: method
!-----------------------------------------------------------------------
    call horiz_interp_init

    method = 'conservative'
    if(present(interp_method)) method = interp_method
    src_is_latlon = .true.
    if(trim(method) == 'conservative') src_is_latlon = is_lat_lon(lon_in, lat_in)

    if(src_is_latlon) then
       call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                               interp_method, num_nbrs, max_dist, src_modulo,    &
                               is_latlon_in = src_is_latlon )
       call horiz_interp ( Interp, data_in, data_out, verbose,   &
                           mask_in, mask_out, missing_value, missing_permit )
    else
       call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, &
                               interp_method, num_nbrs, max_dist, src_modulo,    &
                               mask_in, mask_out, is_latlon_in = src_is_latlon)

       call horiz_interp ( Interp, data_in, data_out, verbose,   &
                           missing_value=missing_value, missing_permit=missing_permit )
    end if

    call horiz_interp_del ( Interp )

!-----------------------------------------------------------------------

 end subroutine horiz_interp_solo_1d_dst

!#######################################################################

 subroutine horiz_interp_solo_old (data_in, wb, sb, dx, dy,  &
                                   lon_out, lat_out, data_out,  &
                                   verbose, mask_in, mask_out)

!-----------------------------------------------------------------------
!       Overloaded version of interface horiz_interp_solo_2
!
! input
!
!   data_in     Global input data stored from west to east (first dimension),
!               south to north (second dimension).  [real, dimension(:,:)]
!
!   wb          Longitude (in radians) that corresponds to western-most
!               boundary of grid box i=1 in array data_in.  [real]
!
!   sb          Latitude (in radians) that corresponds to southern-most
!               boundary of grid box j=1 in array data_in.  [real]
!
!   dx          Grid spacing (in radians) for the longitude axis (first
!               dimension) for the input data.  [real]
!
!   dy          Grid spacing (in radians) for the latitude axis (second
!               dimension) for the input data.  [real]
!
!   lon_out    The longitude edges (in radians) for output data grid boxes.
!               The values are for adjacent grid boxes and must increase in
!               value. If there are MLON grid boxes there must be MLON+1
!               edge values.  [real, dimension(:)]
!
!   lat_out    The latitude edges (in radians) for output data grid boxes.
!               The values are for adjacent grid boxes and may increase or
!               decrease in value. If there are NLAT grid boxes there must
!               be NLAT+1 edge values.  [real, dimension(:)]
!
! OUTPUT
!   data_out    Output data on the output grid defined by grid box
!               edges: blon_out and blat_out.  [real, dimension(:,:)]
!
!-----------------------------------------------------------------------
      real, intent(in),  dimension(:,:) :: data_in
      real, intent(in)                  :: wb, sb, dx, dy
      real, intent(in),  dimension(:)   :: lon_out, lat_out
      real, intent(out), dimension(:,:) :: data_out
   integer, intent(in),                   optional :: verbose
      real, intent(in),   dimension(:,:), optional :: mask_in
      real, intent(out),  dimension(:,:), optional :: mask_out
!-----------------------------------------------------------------------
     real, dimension(size(data_in,1)+1)  :: blon_in
     real, dimension(size(data_in,2)+1)  :: blat_in
     integer :: i, j, nlon_in, nlat_in
     real    :: tpi
!-----------------------------------------------------------------------
   call horiz_interp_init
 
   tpi = 2.*pi
   nlon_in = size(data_in,1)
   nlat_in = size(data_in,2)

   do i = 1, nlon_in+1
      blon_in(i) = wb + float(i-1)*dx
   enddo
      if (abs(blon_in(nlon_in+1)-blon_in(1)-tpi) < epsilon(blon_in)) &
              blon_in(nlon_in+1)=blon_in(1)+tpi

   do j = 2, nlat_in
      blat_in(j) = sb + float(j-1)*dy
   enddo
      blat_in(1)         = -0.5*pi
      blat_in(nlat_in+1) =  0.5*pi


   call horiz_interp_solo_1d (data_in, blon_in, blat_in,    &
                              lon_out, lat_out, data_out,   &
                              verbose, mask_in, mask_out    )

!-----------------------------------------------------------------------

 end subroutine horiz_interp_solo_old

!#######################################################################
! <SUBROUTINE NAME="horiz_interp_del">

!   <OVERVIEW>
!     Deallocates memory used by "horiz_interp_type" variables.
!       Must be called before reinitializing with horiz_interp_new.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Deallocates memory used by "horiz_interp_type" variables.
!     Must be called before reinitializing with horiz_interp_new.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call horiz_interp_del ( Interp )
!   </TEMPLATE>

!   <INOUT NAME="Interp" TYPE="horiz_interp_type">
!     A derived-type variable returned by previous call
!              to horiz_interp_new. The input variable must have
!              allocated arrays. The returned variable will contain
!              deallocated arrays.
!   </INOUT>

! </SUBROUTINE>

 subroutine horiz_interp_del ( Interp )

   type (horiz_interp_type), intent(inout) :: Interp

!-----------------------------------------------------------------------
!  releases space used by horiz_interp_type variables
!  must be called before re-initializing the same variable
!-----------------------------------------------------------------------
   select case(Interp % interp_method) 
   case (CONSERVE)
      call horiz_interp_conserve_del(Interp )
   case (BILINEAR)
      call horiz_interp_bilinear_del(Interp )
   case (BICUBIC)
      call horiz_interp_bicubic_del(Interp )
   case (SPHERICA)
      call horiz_interp_spherical_del(Interp )
   end select

   Interp%I_am_initialized = .false.
!-----------------------------------------------------------------------

 end subroutine horiz_interp_del

 !#####################################################################

! <SUBROUTINE NAME="horiz_interp_end">

!   <OVERVIEW>
!     Dummy routine.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Dummy routine.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call horiz_interp_end
!   </TEMPLATE>

! </SUBROUTINE>

 subroutine horiz_interp_end
 return
 end subroutine horiz_interp_end

 !####################################################################
 function is_lat_lon(lon, lat)
    real, dimension(:,:), intent(in) :: lon, lat
    logical                          :: is_lat_lon
    integer                          :: i, j, nlon, nlat, num

    is_lat_lon = .true.
    nlon = size(lon,1)
    nlat = size(lon,2)
    LOOP_LAT: do j = 1, nlat
       do i = 2, nlon
          if(lat(i,j) .NE. lat(1,j)) then
             is_lat_lon = .false.
             exit LOOP_LAT
          end if
       end do
    end do LOOP_LAT

    if(is_lat_lon) then
       LOOP_LON: do i = 1, nlon
          do j = 2, nlat
             if(lon(i,j) .NE. lon(i,1)) then
                is_lat_lon = .false.
                exit LOOP_LON
             end if
          end do
       end do LOOP_LON
    end if

    num = 0
    if(is_lat_lon) num = 1
    call mpp_min(num)
    if(num == 1) then
       is_lat_lon = .true.
    else
       is_lat_lon = .false.
    end if

    return
 end function is_lat_lon

!#####################################################################

end module horiz_interp_mod

! <INFO>
!   <NOTE>             
!       Has not been checked with grids that do not cover the sphere.
!
!       Has not been checked with the optional mask arguments.
!
!       If a latitude or longitude index cannot be found the tolerance
!       used for making this determination may need to be increased.
!       This can be done by increasing the value of module variable
!       num_iters (default 4).
!   </NOTE>
!   <TESTPROGRAM>  
!     <PRE>
!       program test
!       use horiz_interp_mod
!       implicit none
!       integer, parameter :: nxi=177, nyi=91, nxo=133, nyo=77 ! resolution
!       real :: zi(nxi,nyi), zo(nxo,nyo)                       ! data
!       real :: xi(nxi+1), yi(nyi+1), xo(nxo+1), yo(nyo+1)     ! grid edges
!       real :: pi, tpi, hpi, dx, dy
!     
!       ! constants
!         hpi = acos(0.0)
!          pi = hpi*2.0
!         tpi = hpi*4.0
!     
!       ! grid setup: west to east, south to north
!         dx = tpi/real(nxi); call setaxis (0.,dx,xi);   xi(nxi+1) = xi(1)+tpi
!         dx = tpi/real(nxo); call setaxis (0.,dx,xo);   xo(nxo+1) = xo(1)+tpi
!         dy =  pi/real(nyi); call setaxis (-hpi,dy,yi); yi(nyi+1) = hpi
!         dy =  pi/real(nyo); call setaxis (-hpi,dy,yo); yo(nyo+1) = hpi
!     
!       ! random data on the input grid
!         call random_number (zi)
!     
!       ! interpolate (flipping y-axis)
!         call horiz_interp (zi(:,1:nyi:+1), xi, yi(1:nyi+1:+1), xo, yo(1:nyo+1:+1), zo, verbose=2)
!         call horiz_interp (zi(:,nyi:1:-1), xi, yi(nyi+1:1:-1), xo, yo(1:nyo+1:+1), zo, verbose=2)
!         call horiz_interp (zi(:,nyi:1:-1), xi, yi(nyi+1:1:-1), xo, yo(nyo+1:1:-1), zo, verbose=2)
!         call horiz_interp (zi(:,1:nyi:+1), xi, yi(1:nyi+1:+1), xo, yo(nyo+1:1:-1), zo, verbose=2)
!     
!       contains
!     ! set up a sequence of numbers
!         subroutine setaxis (xo,dx,x)
!         real, intent(in)  :: xo, dx
!         real, intent(out) :: x(:)
!         integer :: i
!           x(1) = xo
!           do i=2,size(x(:))
!             x(i) = x(i-1)+dx
!           enddo
!         end subroutine setaxis
!     
!       end program test
!     </PRE>
!   </TESTPROGRAM>
! </INFO>

#ifdef test_horiz_interp
! T More tests will be added in the future.
program horiz_interp_test

use mpp_mod,          only : mpp_init, mpp_exit, mpp_error, FATAL, stdout, mpp_npes
use mpp_mod,          only : mpp_clock_id, mpp_clock_begin, mpp_clock_end
use mpp_mod,          only : mpp_pe, mpp_root_pe, NOTE, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
use mpp_mod,          only : input_nml_file
use mpp_io_mod,       only : mpp_io_init, mpp_io_exit
use mpp_domains_mod,  only : mpp_define_layout, mpp_define_domains, mpp_get_compute_domain
use mpp_domains_mod,  only : mpp_domains_init, domain2d
use fms_mod,          only : file_exist, open_namelist_file, close_file, check_nml_error
use horiz_interp_mod, only : horiz_interp_init, horiz_interp_new, horiz_interp_del
use horiz_interp_mod, only : horiz_interp, horiz_interp_type
use constants_mod,    only : constants_init, PI

implicit none

  integer :: ni_src = 360, nj_src = 180
  integer :: ni_dst = 144, nj_dst = 72

  namelist /test_horiz_interp_nml/ ni_src, nj_src, ni_dst, nj_dst

  real :: lon_src_beg = 0,    lon_src_end = 360
  real :: lat_src_beg = -90,  lat_src_end = 90
  real :: lon_dst_beg = -280, lon_dst_end = 80
  real :: lat_dst_beg = -90,  lat_dst_end = 90
  real :: D2R = PI/180.
  real, parameter :: SMALL = 1.0e-10

  type(domain2d)                    :: domain
  type(horiz_interp_type)           :: Interp
  integer                           :: id1, id2, id3, id4
  integer                           :: isc, iec, jsc, jec, i, j
  integer                           :: nml_unit, io, ierr, layout(2)
  real                              :: dlon_src, dlat_src, dlon_dst, dlat_dst
  real, allocatable, dimension(:)   :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst
  real, allocatable, dimension(:,:) :: lon2D_src, lat2D_src, lon2D_dst, lat2D_dst
  real, allocatable, dimension(:,:) :: data_src, data1_dst, data2_dst, data3_dst, data4_dst

  call constants_init
  call mpp_init
  call mpp_domains_init
  call mpp_io_init
  call horiz_interp_init

  !--- read namelist
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, test_horiz_interp_nml, iostat=io)
#else
  if (file_exist('input.nml')) then
     ierr=1
     nml_unit = open_namelist_file()
     do while (ierr /= 0)
        read(nml_unit, nml=test_horiz_interp_nml, iostat=io, end=10)
        ierr = check_nml_error(io, 'test_horiz_interp_nml')
     enddo
10   call close_file(nml_unit)
  endif
#endif

  !--- define domains
  call mpp_define_layout( (/1, ni_dst, 1, nj_dst/), mpp_npes(), layout)
  call mpp_define_domains((/1, ni_dst, 1, nj_dst/), layout, domain)
  call mpp_get_compute_domain(domain,isc,iec,jsc,jec)

  !--- test conservative horiz_interp with a simple test. the source grid is the region
  !    (0:360,-90:90) with grid size ni_src, nj_src ( default 360X180). and the destination 
  !    is the region (-280:80, -90:90) with grid size ni_dstXnj_dst( default 144X72). 
  !    integer checksum and global sum will be printed out for both the 1D and 2D version. 

  allocate(lon2D_src(ni_src+1, nj_src+1), lat2D_src(ni_src+1, nj_src+1) )
  allocate(lon1D_src(ni_src+1), lat1D_src(nj_src+1), data_src(ni_src, nj_src) )

  allocate(lon2D_dst(isc:iec+1, jsc:jec+1), lat2D_dst(isc:iec+1, jsc:jec+1) )
  allocate(lon1D_dst(isc:iec+1), lat1D_dst(jsc:jec+1) )
  allocate(data1_dst(isc:iec, jsc:jec), data2_dst(isc:iec, jsc:jec) )
  allocate(data3_dst(isc:iec, jsc:jec), data4_dst(isc:iec, jsc:jec) )

  ! set up longitude and latitude of source/destination grid.   
  dlon_src = (lon_src_end-lon_src_beg)/ni_src 
  dlat_src = (lat_src_end-lat_src_beg)/nj_src
  dlon_dst = (lon_dst_end-lon_dst_beg)/ni_dst 
  dlat_dst = (lat_dst_end-lat_dst_beg)/nj_dst

  do i = 1, ni_src+1
     lon1D_src(i) = lon_src_beg + (i-1)*dlon_src
  end do

  do j = 1, nj_src+1
     lat1D_src(j) = lat_src_beg + (j-1)*dlat_src
  end do

  do i = isc, iec+1
     lon1D_dst(i) = lon_dst_beg + (i-1)*dlon_dst
  end do

  do j = jsc, jec+1
     lat1D_dst(j) = lat_dst_beg + (j-1)*dlat_dst
  end do

  ! scale grid to radians.
  lon1D_src = lon1D_src * D2R
  lat1D_src = lat1D_src * D2R
  lon1D_dst = lon1D_dst * D2R
  lat1D_dst = lat1D_dst * D2R

  do i = 1, ni_src+1
     lon2D_src(i,:) = lon1D_src(i)
  end do

  do j = 1, nj_src+1
     lat2D_src(:,j) = lat1D_src(j)
  end do

  do i = isc, iec+1
     lon2D_dst(i,:) = lon1D_dst(i)
  end do

  do j = jsc, jec+1
     lat2D_dst(:,j) = lat1D_dst(j)
  end do

  !--- set up the source data
  do j = 1, nj_src
     do i = 1, ni_src
        data_src(i,j) = i + j*0.001
     end do
  end do

  id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
  id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
  id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
  id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )

  ! --- 1dx1d version conservative interpolation
  call mpp_clock_begin(id1)
  call horiz_interp_new(Interp, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, interp_method = "conservative")
  call horiz_interp(Interp, data_src, data1_dst)
  call horiz_interp_del(Interp)
  call mpp_clock_end(id1)

  ! --- 1dx2d version conservative interpolation
  call mpp_clock_begin(id2)
  call horiz_interp_new(Interp, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, interp_method = "conservative")
  call horiz_interp(Interp, data_src, data2_dst)
  call horiz_interp_del(Interp)
  call mpp_clock_end(id2)

  ! --- 2dx1d version conservative interpolation
  call mpp_clock_begin(id3)
  call horiz_interp_new(Interp, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, interp_method = "conservative")
  call horiz_interp(Interp, data_src, data3_dst)
  call horiz_interp_del(Interp)
  call mpp_clock_end(id3)

  ! --- 2dx2d version conservative interpolation
  call mpp_clock_begin(id4)
  call horiz_interp_new(Interp, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, interp_method = "conservative")
  call horiz_interp(Interp, data_src, data4_dst)
  call horiz_interp_del(Interp)
  call mpp_clock_end(id4)

  !--- compare the data after interpolation between 1-D and 2-D version interpolation
  do j = jsc, jsc
     do i = isc, iec

        if( abs(data1_dst(i,j)-data2_dst(i,j)) > SMALL ) then
           print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), &
           ", data2 = ", data2_dst(i,j), ", data1-data2 = ",  data1_dst(i,j) - data2_dst(i,j)
           call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data2_dst")
        end if
     end do
  end do

  if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE,   &
       "The test that verify 1dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") 

  do j = jsc, jsc
     do i = isc, iec

        if( abs(data1_dst(i,j)-data3_dst(i,j)) > SMALL ) then
           print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), &
           ", data2 = ", data3_dst(i,j), ", data1-data2 = ",  data1_dst(i,j) - data3_dst(i,j)
           call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data3_dst")
        end if
     end do
  end do

  if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE,   &
       "The test that verify 2dx1d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") 

  do j = jsc, jsc
     do i = isc, iec

        if( abs(data1_dst(i,j)-data4_dst(i,j)) > SMALL ) then
           print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), &
           ", data2 = ", data4_dst(i,j), ", data1-data2 = ",  data1_dst(i,j) - data4_dst(i,j)
           call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data4_dst")
        end if
     end do
  end do

  if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE,   &
       "The test that verify 2dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") 

  call mpp_io_exit
  call mpp_exit

end program horiz_interp_test
#endif


module horiz_interp_bicubic_mod

  use mpp_mod,               only: mpp_error, FATAL, stdout, mpp_pe, mpp_root_pe
  use fms_mod,               only: write_version_number
  use horiz_interp_type_mod, only: horiz_interp_type
  
 implicit none

! This module delivers methods for bicubic interpolation from a
! coarse regular grid on a fine regular grid.
! Subroutines
!
!       bcuint
!       bcucof
! 
! are methods taken from
!
!       W. H. Press, S. A. Teukolski, W. T. Vetterling and B. P. Flannery,
!       Numerical Recipies in FORTRAN, The Art of Scientific Computing.
!       Cambridge University Press, 1992
!       
! written by
!       martin.schmidt@io-warnemuende.de (2004)
! revied by
!       martin.schmidt@io-warnemuende.de (2004)
!
! Version 1.0.0.2005-07-06
! The module is thought to interact with MOM-4. 
! Alle benotigten Felder werden extern von MOM verwaltet, da sie
! nicht fur alle interpolierten Daten die gleiche Dimension haben mussen.

   private
   
   public  :: horiz_interp_bicubic, horiz_interp_bicubic_new, horiz_interp_bicubic_del, fill_xy
   public  :: horiz_interp_bicubic_init   

  interface horiz_interp_bicubic_new
    module procedure horiz_interp_bicubic_new_1d
    module procedure horiz_interp_bicubic_new_1d_s
  end interface

   character(len=128) :: version="$Id: horiz_interp_bicubic.F90,v 14.0 2007/03/15 22:39:52 fms Exp $"
   character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
   logical            :: module_is_initialized = .FALSE.
   integer            :: verbose_bicubic = 0
   
!     Grid variables
!     xc, yc : co-ordinates of the coarse grid
!     xf, yf : co-ordinates of the fine grid
!     fc     : variable to be interpolated at the coarse grid
!     dfc_x  : x-derivative of fc at the coarse grid 
!     dfc_y  : y-derivative of fc at the coarse grid 
!     dfc_xy : x-y-derivative of fc at the coarse grid 
!     ff     : variable to be interpolated at the fine grid
!     dff_x  : x-derivative of fc at the fine grid 
!     dff_y  : y-derivative of fc at the fine grid 
!     dff_xy : x-y-derivative of fc at the fine grid 
      

   logical            :: initialized_bicubic = .false.
   
   
   real, save         :: missing = -1e33 
   
   interface fill_xy
      module procedure fill_xy
   end interface

   
   contains

  !#######################################################################
  !  <SUBROUTINE NAME="horiz_interp_bicubic_init">
  !  <OVERVIEW>
  !     writes version number and tag name to logfile.out
  !  </OVERVIEW>
  !  <DESCRIPTION>       
  !     writes version number and tag name to logfile.out
  !  </DESCRIPTION>

  subroutine horiz_interp_bicubic_init

     if(module_is_initialized) return
     call write_version_number (version, tagname)
     module_is_initialized = .true.

  end subroutine horiz_interp_bicubic_init

  !  </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_bicubic_new">

  !   <OVERVIEW>
  !      Initialization routine.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose_bicubic, src_modulo )

  !   </TEMPLATE>
  !   
  !   <IN NAME="lon_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Longitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="lat_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lon_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Longitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="lat_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Latitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="src_modulo" TYPE="logical, optional">
  !      logical variable to indicate if the boundary condition along zonal boundary
  !      is cyclic or not. When true, the zonal boundary condition is cyclic.
  !   </IN>

  !   <IN NAME="verbose_bicubic" TYPE="integer, optional" >
  !      flag for the amount of print output.
  !   </IN>

  !   <INOUT NAME="Interp" TYPE="type(horiz_interp_type)" >
  !      A derived-type variable containing indices and weights used for subsequent 
  !      interpolations. To reinitialize this variable for a different grid-to-grid 
  !      interpolation you must first use the "horiz_interp_bicubic_del" interface.
  !   </INOUT>

  subroutine horiz_interp_bicubic_new_1d_s ( Interp, lon_in, lat_in, lon_out, lat_out, &
       verbose, src_modulo )

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),  dimension(:)        :: lon_in , lat_in
    real, intent(in),  dimension(:,:)      :: lon_out, lat_out
    integer, intent(in),          optional :: verbose
    logical, intent(in),          optional :: src_modulo
    integer                                :: i, j, ip1, im1, jp1, jm1 
    logical                                :: src_is_modulo
    integer                                :: nlon_in, nlat_in, nlon_out, nlat_out
    integer                                :: jcl, jcu, icl, icu, jj
    real                                   :: xz, yz
    integer                                :: unit
  
    if(present(verbose)) verbose_bicubic = verbose
    src_is_modulo = .false. 
    if (present(src_modulo)) src_is_modulo = src_modulo

    if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) &
         call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // &
         'interplation, the output grids should be geographical grids')    

    !--- get the grid size 
    nlon_in  = size(lon_in)   ; nlat_in  = size(lat_in)
    nlon_out = size(lon_out,1); nlat_out = size(lat_out,2)
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
!   use wti(:,:,1) for x-derivative, wti(:,:,2) for y-derivative, wti(:,:,3) for xy-derivative  
    allocate ( Interp%wti    (nlon_in, nlat_in, 3) )
    allocate ( Interp%lon_in (nlon_in) )
    allocate ( Interp%lat_in (nlat_in) )
    allocate ( Interp%rat_x  (nlon_out, nlat_out) )
    allocate ( Interp%rat_y  (nlon_out, nlat_out) )
    allocate ( Interp%i_lon  (nlon_out, nlat_out, 2) )
    allocate ( Interp%j_lat  (nlon_out, nlat_out, 2) )
    
    Interp%lon_in = lon_in
    Interp%lat_in = lat_in

    if ( verbose_bicubic > 0 ) then
       unit = stdout()
       write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")')
       write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src
       write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src)
       write (unit,'(/," Latitude of coarse grid points (radian):  yc(j) j=1, ",i4)') Interp%nlat_src
       write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src)
       do i=1, Interp%nlat_dst
         write (unit,*)
         write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst
         write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst)
       enddo
       do i=1, Interp%nlon_dst 
         write (unit,*)
         write (unit,'(/," Latitude of fine grid points (radian):  yf(j) j=1, ",i4)') Interp%nlon_dst
         write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst)
       enddo
    endif  
      

!---------------------------------------------------------------------------
!     Find the x-derivative. Use central differences and forward or
!     backward steps at the boundaries
    
    do j=1,nlat_in
      do i=1,nlon_in
        ip1=min(i+1,nlon_in)
        im1=max(i-1,1)
        Interp%wti(i,j,1) = 1./(Interp%lon_in(ip1)-Interp%lon_in(im1))
      enddo
    enddo
      
      
!---------------------------------------------------------------------------
     
!     Find the y-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          Interp%wti(i,j,2) = 1./(Interp%lat_in(jp1)-Interp%lat_in(jm1))
        enddo
      enddo
   
!---------------------------------------------------------------------------
     
!     Find the xy-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          ip1=min(i+1,nlon_in)
          im1=max(i-1,1)
          Interp%wti(i,j,3) = 1./((Interp%lon_in(ip1)-Interp%lon_in(im1))*(Interp%lat_in(jp1)-Interp%lat_in(jm1)))
        enddo
      enddo
!---------------------------------------------------------------------------
!     Now for each point at the dest-grid find the boundary points of 
!     the source grid
      do j=1, nlat_out
        do i=1,nlon_out
          yz  = lat_out(i,j)
          xz  = lon_out(i,j)
          jcl = 0
          jcu = 0
          jcl = indl(Interp%lat_in, yz) 
          jcu = indu(Interp%lat_in, yz)
          icl = 0
          icu = 0
          icl = indl(Interp%lon_in, xz) 
          icu = indu(Interp%lon_in, xz) 
          Interp%j_lat(i,j,1) = jcl
          Interp%j_lat(i,j,2) = jcu
          Interp%i_lon(i,j,1) = icl 
          Interp%i_lon(i,j,2) = icu 
          Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl))
          Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl))
          if(yz.gt.Interp%lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: yf < ycl, no valid boundary point')
          if(yz.lt.Interp%lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: yf > ycu, no valid boundary point')
          if(xz.gt.Interp%lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: xf < xcl, no valid boundary point')
          if(xz.lt.Interp%lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: xf > xcu, no valid boundary point')
        enddo
      enddo
  end subroutine horiz_interp_bicubic_new_1d_s
  ! </SUBROUTINE>
  subroutine horiz_interp_bicubic_new_1d ( Interp, lon_in, lat_in, lon_out, lat_out, &
       verbose, src_modulo )

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),  dimension(:)        :: lon_in , lat_in
    real, intent(in),  dimension(:)        :: lon_out, lat_out
    integer, intent(in),          optional :: verbose
    logical, intent(in),          optional :: src_modulo
    integer                                :: i, j, ip1, im1, jp1, jm1 
    logical                                :: src_is_modulo
    integer                                :: nlon_in, nlat_in, nlon_out, nlat_out
    integer                                :: jcl, jcu, icl, icu, jj
    real                                   :: xz, yz
    integer                                :: unit

    if(present(verbose)) verbose_bicubic = verbose
    src_is_modulo = .false. 
    if (present(src_modulo)) src_is_modulo = src_modulo

    !--- get the grid size 
    nlon_in  = size(lon_in) ; nlat_in  = size(lat_in)
    nlon_out = size(lon_out); nlat_out = size(lat_out)
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
    allocate ( Interp%wti     (nlon_in, nlat_in, 3) )
    allocate ( Interp%lon_in  (nlon_in) )
    allocate ( Interp%lat_in  (nlat_in) )
    allocate ( Interp%rat_x   (nlon_out, nlat_out) )
    allocate ( Interp%rat_y   (nlon_out, nlat_out) )
    allocate ( Interp%i_lon   (nlon_out, nlat_out, 2) )
    allocate ( Interp%j_lat   (nlon_out, nlat_out, 2) )
    
    Interp%lon_in = lon_in
    Interp%lat_in = lat_in

    if ( verbose_bicubic > 0 ) then
       unit = stdout()
       write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d")')
       write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src
       write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src)
       write (unit,'(/," Latitude of coarse grid points (radian):  yc(j) j=1, ",i4)') Interp%nlat_src
       write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src)
       write (unit,*)
       write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst
       write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst)
       write (unit,'(/," Latitude of fine grid points (radian):  yf(j) j=1, ",i4)') Interp%nlon_dst
       write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst)
    endif  
      

!---------------------------------------------------------------------------
!     Find the x-derivative. Use central differences and forward or
!     backward steps at the boundaries
    
    do j=1,nlat_in
      do i=1,nlon_in
        ip1=min(i+1,nlon_in)
        im1=max(i-1,1)
        Interp%wti(i,j,1) = 1./(lon_in(ip1)-lon_in(im1))
      enddo
    enddo
      
      
!---------------------------------------------------------------------------
     
!     Find the y-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          Interp%wti(i,j,2) = 1./(lat_in(jp1)-lat_in(jm1))
        enddo
      enddo
   
!---------------------------------------------------------------------------
     
!     Find the xy-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          ip1=min(i+1,nlon_in)
          im1=max(i-1,1)
          Interp%wti(i,j,3) = 1./((lon_in(ip1)-lon_in(im1))*(lat_in(jp1)-lat_in(jm1)))
        enddo
      enddo
!---------------------------------------------------------------------------
!     Now for each point at the dest-grid find the boundary points of 
!     the source grid
      do j=1, nlat_out
        yz  = lat_out(j)
        jcl = 0
        jcu = 0
        jcl = indl(lat_in, yz) 
        jcu = indu(lat_in, yz)
        do i=1,nlon_out
          xz = lon_out(i)
          icl = 0
          icu = 0
          icl = indl(lon_in, xz) 
          icu = indu(lon_in, xz) 
          Interp%j_lat(i,j,1) = jcl
          Interp%j_lat(i,j,2) = jcu
          Interp%i_lon(i,j,1) = icl 
          Interp%i_lon(i,j,2) = icu 
          if(yz.gt.lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: yf < ycl, no valid boundary point')
          if(yz.lt.lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: yf > ycu, no valid boundary point')
          if(xz.gt.lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: xf < xcl, no valid boundary point')
          if(xz.lt.lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: xf > xcu, no valid boundary point')
          Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl))
          Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl))
        enddo
      enddo

  end subroutine horiz_interp_bicubic_new_1d
   
  subroutine horiz_interp_bicubic( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value, missing_permit)
    type (horiz_interp_type), intent(in)        :: Interp
    real, intent(in),  dimension(:,:)           :: data_in
    real, intent(out), dimension(:,:)           :: data_out
    integer, intent(in),               optional :: verbose
    real, intent(in),  dimension(:,:), optional :: mask_in
    real, intent(out), dimension(:,:), optional :: mask_out
    real, intent(in),                  optional :: missing_value
    integer, intent(in),               optional :: missing_permit
    real :: yz, ycu, ycl
    real :: xz, xcu, xcl
    real :: val, val1, val2
    real, dimension(4) :: y, y1, y2, y12
    integer :: icl, icu, jcl, jcu
    integer :: iclp1, icup1, jclp1, jcup1
    integer :: iclm1, icum1, jclm1, jcum1
    integer :: i,j
         
    if ( present(verbose) ) verbose_bicubic = verbose
!    fill_in = .false.
!    if ( present(fill) ) fill_in = fill
!   use dfc_x and dfc_y as workspace      
!    if ( fill_in ) call fill_xy(fc(ics:ice,jcs:jce), ics, ice, jcs, jce, maxpass=2)
!    where ( data_in .le. missing ) data_in(:,:) = 0.
!!  
    do j=1, Interp%nlat_dst
      do i=1, Interp%nlon_dst
        yz  = Interp%rat_y(i,j)
        xz  = Interp%rat_x(i,j)
        jcl = Interp%j_lat(i,j,1)
        jcu = Interp%j_lat(i,j,2)
        icl = Interp%i_lon(i,j,1)
        icu = Interp%i_lon(i,j,2)
        iclp1 = min(icl+1,Interp%nlon_src)
        iclm1 = max(icl-1,1)
        icup1 = min(icu+1,Interp%nlon_src)
        icum1 = max(icu-1,1)
        jclp1 = min(jcl+1,Interp%nlat_src)
        jclm1 = max(jcl-1,1)
        jcup1 = min(jcu+1,Interp%nlat_src)
        jcum1 = max(jcu-1,1)
        ycl = Interp%lat_in(jcl)
        ycu = Interp%lat_in(jcu)
        xcl = Interp%lon_in(icl)
        xcu = Interp%lon_in(icu)
        y(1)  =  data_in(icl,jcl)
        y(2)  =  data_in(icu,jcl)
        y(3)  =  data_in(icu,jcu)
        y(4)  =  data_in(icl,jcu)
        y1(1) = ( data_in(iclp1,jcl) - data_in(iclm1,jcl) ) * Interp%wti(icl,jcl,1)
        y1(2) = ( data_in(icup1,jcl) - data_in(icum1,jcl) ) * Interp%wti(icu,jcl,1)
        y1(3) = ( data_in(icup1,jcu) - data_in(icum1,jcu) ) * Interp%wti(icu,jcu,1)
        y1(4) = ( data_in(iclp1,jcu) - data_in(iclm1,jcu) ) * Interp%wti(icl,jcu,1)
        y2(1) = ( data_in(icl,jclp1) - data_in(icl,jclm1) ) * Interp%wti(icl,jcl,2)
        y2(2) = ( data_in(icu,jclp1) - data_in(icu,jclm1) ) * Interp%wti(icu,jcl,2)
        y2(3) = ( data_in(icu,jcup1) - data_in(icu,jcum1) ) * Interp%wti(icu,jcu,2)
        y2(4) = ( data_in(icl,jcup1) - data_in(icl,jcum1) ) * Interp%wti(icl,jcu,2)
        y12(1)= ( data_in(iclp1,jclp1) + data_in(iclm1,jclm1) - data_in(iclm1,jclp1) &
                - data_in(iclp1,jclm1) ) * Interp%wti(icl,jcl,3)
        y12(2)= ( data_in(icup1,jclp1) + data_in(icum1,jclm1) - data_in(icum1,jclp1) &
                - data_in(icup1,jclm1) ) * Interp%wti(icu,jcl,3)
        y12(3)= ( data_in(icup1,jcup1) + data_in(icum1,jcum1) - data_in(icum1,jcup1) &
                - data_in(icup1,jcum1) ) * Interp%wti(icu,jcu,3)
        y12(4)= ( data_in(iclp1,jcup1) + data_in(iclm1,jcum1) - data_in(iclm1,jcup1) &
                - data_in(iclp1,jcum1) ) * Interp%wti(icl,jcu,3)
        
        call bcuint(y,y1,y2,y12,xcl,xcu,ycl,ycu,xz,yz,val,val1,val2) 
        data_out   (i,j) = val
        if(present(mask_out)) mask_out(i,j) = 1.
!!        dff_x(i,j) = val1
!!        dff_y(i,j) = val2
      enddo
    enddo
  return
  end subroutine horiz_interp_bicubic
     
   
!---------------------------------------------------------------------------
     
   subroutine bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,t,u,ansy,ansy1,ansy2)
      real ansy,ansy1,ansy2,x1l,x1u,x2l,x2u,y(4),y1(4),y12(4),y2(4)
!     uses bcucof
      integer i
      real t,u,c(4,4)
      call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
      ansy=0.
      ansy2=0.
      ansy1=0.
      do i=4,1,-1
        ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1)
        ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2)
        ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i)
      enddo
!      ansy1=ansy1/(x1u-x1l) ! could be used for accuracy checks
!      ansy2=ansy2/(x2u-x2l) ! could be used for accuracy checks
      return
!  (c) copr. 1986-92 numerical recipes software -3#(-)f.
   end subroutine bcuint
!---------------------------------------------------------------------------
     
   subroutine bcucof(y,y1,y2,y12,d1,d2,c)
      real d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4)
      integer i,j,k,l
      real d1d2,xx,cl(16),wt(16,16),x(16)
      save wt
      data wt/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,10* &
       0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,4*0,1,0,-3,2,-2,0,6,-4, &
       1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0,   &
      -6,4,2*0,3,-2,0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2,  &
       10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,5*0,1,-2,1,0,-2,4,   &
      -2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0,  &
       2,-2,2*0,-1,1/
      d1d2=d1*d2
      do i=1,4
        x(i)=y(i)
        x(i+4)=y1(i)*d1
        x(i+8)=y2(i)*d2
        x(i+12)=y12(i)*d1d2
      enddo
      do i=1,16
        xx=0.
        do k=1,16
          xx=xx+wt(i,k)*x(k)
        enddo
        cl(i)=xx
      enddo
      l=0
      do i=1,4
        do j=1,4
          l=l+1
          c(i,j)=cl(l)
        enddo
      enddo
      return
!  (c) copr. 1986-92 numerical recipes software -3#(-)f.
   end subroutine bcucof

!-----------------------------------------------------------------------

    function indl(xc, xf) 
! find the lower neighbour of xf in field xc, return is the index      
    real, intent(in) :: xc(1:)
    real, intent(in) :: xf
    integer             :: indl
    integer             :: ii
       indl = 1
       do ii=1, size(xc)
         if(xc(ii).gt.xf) return
         indl = ii
       enddo
       call mpp_error(FATAL,'Error in indl')
    return
    end function indl

!-----------------------------------------------------------------------
      
    function indu(xc, xf) 
! find the upper neighbour of xf in field xc, return is the index      
    real, intent(in) :: xc(1:)
    real, intent(in) :: xf
    integer             :: indu
    integer             :: ii
       do ii=1, size(xc)
         indu = ii
         if(xc(ii).gt.xf) return
       enddo
       call mpp_error(FATAL,'Error in indu')
    return
    end function indu
    
!-----------------------------------------------------------------------

    subroutine fill_xy(fi, ics, ice, jcs, jce, mask, maxpass)
      integer, intent(in)        :: ics,ice,jcs,jce
      real, intent(inout)        :: fi(ics:ice,jcs:jce)
      real, intent(in), optional :: mask(ics:ice,jcs:jce)
      integer, intent(in)        :: maxpass
      real                       :: work_old(ics:ice,jcs:jce)
      real                       :: work_new(ics:ice,jcs:jce)
      logical :: ready
      real    :: blank = -1.e30
      real    :: tavr
      integer :: ipass = 0
      integer :: inl, inr, jnl, jnu, i, j, is, js,  iavr
      
      
      ready = .false.

      work_new(:,:) = fi(:,:)
      work_old(:,:) = work_new(:,:)
      ipass = 0
      if ( present(mask) ) then
         do while (.not.ready)
           ipass = ipass+1
           ready = .true.
           do j=jcs, jce
             do i=ics, ice
               if (work_old(i,j).le.blank) then
                 tavr=0.
                 iavr=0
                 inl = max(i-1,ics)
                 inr = min(i+1,ice)
                 jnl = max(j-1,jcs)
                 jnu = min(j+1,jce)
                 do js=jnl,jnu
                   do is=inl,inr
                     if (work_old(is,js) .ne. blank .and. mask(is,js).ne.0) then
                       tavr = tavr + work_old(is,js)
                       iavr = iavr+1
                     endif
                   enddo
                 enddo
                 if (iavr.gt.0) then
                   if (iavr.eq.1) then
! spreading is not allowed if the only valid neighbor is a corner point
! otherwise an ill posed cellular automaton is established leading to
! a spreading of constant values in diagonal direction
! if all corner points are blanked the valid neighbor must be a direct one
! and spreading is allowed
                     if (work_old(inl,jnu).eq.blank.and.&
                         work_old(inr,jnu).eq.blank.and.&
                         work_old(inr,jnl).eq.blank.and.&
                         work_old(inl,jnl).eq.blank) then
                           work_new(i,j)=tavr/iavr
                           ready = .false.
                     endif
                  else
                    work_new(i,j)=tavr/iavr
                    ready = .false.
                  endif
                endif
              endif
            enddo ! j
          enddo   ! i
! save changes made during this pass to work_old
          work_old(:,:)=work_new(:,:)
          if(ipass.eq.maxpass) ready=.true.
        enddo !while (.not.ready)
        fi(:,:) = work_new(:,:)
      else
         do while (.not.ready)
           ipass = ipass+1
           ready = .true.
           do j=jcs, jce
             do i=ics, ice
               if (work_old(i,j).le.blank) then
                 tavr=0.
                 iavr=0
                 inl = max(i-1,ics)
                 inr = min(i+1,ice)
                 jnl = max(j-1,jcs)
                 jnu = min(j+1,jce)
                 do is=inl,inr
                   do js=jnl,jnu
                     if (work_old(is,js).gt.blank) then
                       tavr = tavr + work_old(is,js)
                       iavr = iavr+1
                     endif
                   enddo
                 enddo
                 if (iavr.gt.0) then
                   if (iavr.eq.1) then
! spreading is not allowed if the only valid neighbor is a corner point
! otherwise an ill posed cellular automaton is established leading to
! a spreading of constant values in diagonal direction
! if all corner points are blanked the valid neighbor must be a direct one
! and spreading is allowed
                     if (work_old(inl,jnu).le.blank.and. &
                         work_old(inr,jnu).le.blank.and. &
                         work_old(inr,jnl).le.blank.and. &
                         work_old(inl,jnl).le.blank) then
                           work_new(i,j)=tavr/iavr
                           ready = .false.
                     endif
                  else
                    work_new(i,j)=tavr/iavr
                    ready = .false.
                  endif
                endif
              endif
            enddo ! j
          enddo   ! i
! save changes made during this pass to work_old
          work_old(:,:)=work_new(:,:)
          if(ipass.eq.maxpass) ready=.true.
        enddo !while (.not.ready)
        fi(:,:) = work_new(:,:)
      endif
      return
    end subroutine fill_xy      

  subroutine horiz_interp_bicubic_del( Interp )

    type (horiz_interp_type), intent(inout) :: Interp

    if(associated(Interp%rat_x))  deallocate ( Interp%rat_x )
    if(associated(Interp%rat_y))  deallocate ( Interp%rat_y )
    if(associated(Interp%lon_in)) deallocate ( Interp%lon_in )
    if(associated(Interp%lat_in)) deallocate ( Interp%lat_in )
    if(associated(Interp%i_lon))  deallocate ( Interp%i_lon )
    if(associated(Interp%j_lat))  deallocate ( Interp%j_lat )
    if(associated(Interp%wti))    deallocate ( Interp%wti )

  end subroutine horiz_interp_bicubic_del

end module horiz_interp_bicubic_mod

       


module horiz_interp_bilinear_mod

  ! <CONTACT EMAIL="Zhi.Liang@noaa.gov"> Zhi Liang </CONTACT>

  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

  ! <OVERVIEW>
  !   Performs spatial interpolation between grids using bilinear interpolation
  ! </OVERVIEW>

  ! <DESCRIPTION>
  !     This module can interpolate data from regular rectangular grid
  !     to rectangular/tripolar grid. The interpolation scheme is bilinear interpolation.
  !     There is an optional mask field for missing input data.
  !     An optional output mask field may be used in conjunction with
  !     the input mask to show where output data exists.
  ! </DESCRIPTION>

  use mpp_mod,               only: mpp_error, FATAL, stdout, mpp_pe, mpp_root_pe
  use fms_mod,               only: write_version_number
  use constants_mod,         only: PI
  use horiz_interp_type_mod, only: horiz_interp_type, stats

  implicit none
  private


  public :: horiz_interp_bilinear_new, horiz_interp_bilinear, horiz_interp_bilinear_del
  public :: horiz_interp_bilinear_init

  !--- public interface
  interface horiz_interp_bilinear_new
    module procedure horiz_interp_bilinear_new_1d
    module procedure horiz_interp_bilinear_new_2d
  end interface


  real, parameter :: epsln=1.e-10

  !-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: horiz_interp_bilinear.F90,v 14.0 2007/03/15 22:39:57 fms Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
  logical            :: module_is_initialized = .FALSE.

contains

  !#######################################################################
  !  <SUBROUTINE NAME="horiz_interp_bilinear_init">
  !  <OVERVIEW>
  !     writes version number and tag name to logfile.out
  !  </OVERVIEW>
  !  <DESCRIPTION>       
  !     writes version number and tag name to logfile.out
  !  </DESCRIPTION>

  subroutine horiz_interp_bilinear_init

    if(module_is_initialized) return
    call write_version_number (version, tagname)
    module_is_initialized = .true.

  end subroutine horiz_interp_bilinear_init

  !  </SUBROUTINE>

  !########################################################################

  subroutine horiz_interp_bilinear_new_1d ( Interp, lon_in, lat_in, lon_out, lat_out, &
       verbose, src_modulo )

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),  dimension(:)        :: lon_in , lat_in
    real, intent(in),  dimension(:,:)      :: lon_out, lat_out
    integer, intent(in),          optional :: verbose
    logical, intent(in),          optional :: src_modulo

    logical :: src_is_modulo
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m
    integer :: ie, is, je, js, ln_err, lt_err, warns, unit
    real    :: wtw, wte, wts, wtn, lon, lat, tpi, hpi
    real    :: glt_min, glt_max, gln_min, gln_max, min_lon, max_lon

    warns = 0
    if(present(verbose)) warns = verbose
    src_is_modulo = .true. 
    if (present(src_modulo)) src_is_modulo = src_modulo

    hpi = 0.5*pi
    tpi = 4.0*hpi
    glt_min = hpi
    glt_max = -hpi
    gln_min = tpi
    gln_max = -tpi
    min_lon = 0.0
    max_lon = tpi
    ln_err = 0
    lt_err = 0
    !-----------------------------------------------------------------------

    allocate ( Interp % wti (size(lon_out,1),size(lon_out,2),2),   &
               Interp % wtj (size(lon_out,1),size(lon_out,2),2),   &
               Interp % i_lon (size(lon_out,1),size(lon_out,2),2), &
               Interp % j_lat (size(lon_out,1),size(lon_out,2),2))
    !-----------------------------------------------------------------------

    nlon_in = size(lon_in(:))  ; nlat_in = size(lat_in(:))
    nlon_out = size(lon_out, 1); nlat_out = size(lon_out, 2)
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out

    if(src_is_modulo) then
       if(lon_in(nlon_in) - lon_in(1) .gt. tpi + epsln) &
            call mpp_error(FATAL,'horiz_interp_bilinear_mod: '// & 
            'The range of source grid longitude should be no larger than tpi')

       if(lon_in(1) .lt. 0.0 .OR. lon_in(nlon_in) > tpi ) then
          min_lon = lon_in(1)
          max_lon = lon_in(nlon_in)
       endif
    endif

    do n = 1, nlat_out
       do m = 1, nlon_out
          lon = lon_out(m,n)
          lat = lat_out(m,n)

          if(src_is_modulo) then
             if(lon .lt. min_lon) then
                lon = lon + tpi
             else if(lon .gt. max_lon) then
                lon = lon - tpi
             endif
          else  ! when the input grid is in not cyclic, the output grid should located inside
             ! the input grid
             if((lon .lt. lon_in(1)) .or. (lon .gt. lon_in(nlon_in))) &
                  call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //&
                  'when input grid is not modulo, output grid should locate inside input grid')
          endif

          glt_min = min(lat,glt_min);  glt_max = max(lat,glt_max)
          gln_min = min(lon,gln_min);  gln_max = max(lon,gln_max)

          is = indp(lon, lon_in ) 
          if( lon_in(is) .gt. lon ) is = max(is-1,1)
          if( lon_in(is) .eq. lon .and. is .eq. nlon_in) is = max(is - 1,1)
          ie = min(is+1,nlon_in)
          if(lon_in(is) .ne. lon_in(ie) .and. lon_in(is) .le. lon) then
             wtw = ( lon_in(ie) - lon) / (lon_in(ie) - lon_in(is) )
          else
             !     east or west of the last data value. this could be because a
             !     cyclic condition is needed or the dataset is too small. 
             ln_err = 1
             ie = 1
             is = nlon_in
             if (lon_in(ie) .ge. lon ) then
                wtw = (lon_in(ie) -lon)/(lon_in(ie)-lon_in(is)+tpi+epsln)
             else
                wtw = (lon_in(ie) -lon+tpi+epsln)/(lon_in(ie)-lon_in(is)+tpi+epsln)
             endif
          endif
          wte = 1. - wtw

          js = indp(lat, lat_in ) 

          if( lat_in(js) .gt. lat ) js = max(js - 1, 1)
          if( lat_in(js) .eq. lat .and. js .eq. nlat_in) js = max(js - 1, 1)
          je = min(js + 1, nlat_in)

          if ( lat_in(js) .ne. lat_in(je) .and. lat_in(js) .le. lat) then
             wts = ( lat_in(je) - lat )/(lat_in(je)-lat_in(js))
          else
             !     north or south of the last data value. this could be because a
             !     pole is not included in the data set or the dataset is too small.
             !     in either case extrapolate north or south
             lt_err = 1
             wts = 1.
          endif

          wtn = 1. - wts

          Interp % i_lon (m,n,1) = is; Interp % i_lon (m,n,2) = ie
          Interp % j_lat (m,n,1) = js; Interp % j_lat (m,n,2) = je
          Interp % wti   (m,n,1) = wtw
          Interp % wti   (m,n,2) = wte
          Interp % wtj   (m,n,1) = wts
          Interp % wtj   (m,n,2) = wtn

       enddo
    enddo

    unit = stdout()

    if (ln_err .eq. 1 .and. warns > 0) then
       write (unit,'(/,(1x,a))')                                      &
            '==> Warning: the geographic data set does not extend far   ', &
            '             enough east or west - a cyclic boundary       ', &
            '             condition was applied. check if appropriate   '
       write (unit,'(/,(1x,a,2f8.4))')                                &
            '    data required between longitudes:', gln_min, gln_max,     &
            '      data set is between longitudes:', lon_in(1), lon_in(nlon_in)
       warns = warns - 1
    endif

    if (lt_err .eq. 1 .and. warns > 0) then
       write (unit,'(/,(1x,a))')                                     &
            '==> Warning: the geographic data set does not extend far   ',&
            '             enough north or south - extrapolation from    ',&
            '             the nearest data was applied. this may create ',&
            '             artificial gradients near a geographic pole   ' 
       write (unit,'(/,(1x,a,2f8.4))')                             &
            '    data required between latitudes:', glt_min, glt_max,   &
            '      data set is between latitudes:', lat_in(1), lat_in(nlat_in)
    endif

    return

  end subroutine horiz_interp_bilinear_new_1d

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_bilinear_new">

  !   <OVERVIEW>
  !      Initialization routine.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, src_modulo )

  !   </TEMPLATE>
  !   
  !   <IN NAME="lon_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Longitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="lat_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lon_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Longitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="lat_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Latitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="src_modulo" TYPE="logical, optional">
  !      logical variable to indicate if the boundary condition along zonal boundary
  !      is cyclic or not. When true, the zonal boundary condition is cyclic.
  !   </IN>

  !   <IN NAME="verbose" TYPE="integer, optional" >
  !      flag for the amount of print output.
  !   </IN>

  !   <INOUT NAME="Interp" TYPE="type(horiz_interp_type)" >
  !      A derived-type variable containing indices and weights used for subsequent 
  !      interpolations. To reinitialize this variable for a different grid-to-grid 
  !      interpolation you must first use the "horiz_interp_del" interface.
  !   </INOUT>

  subroutine horiz_interp_bilinear_new_2d ( Interp, lon_in, lat_in, lon_out, lat_out, &
       verbose, src_modulo )

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),  dimension(:,:)      :: lon_in , lat_in
    real, intent(in),  dimension(:,:)      :: lon_out, lat_out
    integer, intent(in),          optional :: verbose
    logical, intent(in),          optional :: src_modulo
    integer                                :: warns 
    logical                                :: src_is_modulo
    integer                                :: nlon_in, nlat_in, nlon_out, nlat_out
    integer                                :: m, n, is, ie, js, je, num_solution
    real                                   :: lon, lat, quadra, x, y, y1, y2
    real                                   :: a1, b1, c1, d1, a2, b2, c2, d2, a, b, c
    real                                   :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4
    real                                   :: tpi, lon_min, lon_max

    tpi = 2.0*pi

    warns = 0
    if(present(verbose)) warns = verbose
    src_is_modulo = .true. 
    if (present(src_modulo)) src_is_modulo = src_modulo

    ! make sure lon and lat has the same dimension
    if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) &
         call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // &
         'interplation, the output grids should be geographical grids')    

    if(size(lon_in,1) /= size(lat_in,1) .or. size(lon_in,2) /= size(lat_in,2) ) &
         call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear '// &
         'interplation, the input grids should be geographical grids')  

    !--- get the grid size 
    nlon_in  = size(lon_in,1) ; nlat_in  = size(lat_in,2)
    nlon_out = size(lon_out,1); nlat_out = size(lon_out,2)
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out

    allocate ( Interp % wti (size(lon_out,1),size(lon_out,2),2),   &
               Interp % wtj (size(lon_out,1),size(lon_out,2),2),   &
               Interp % i_lon (size(lon_out,1),size(lon_out,2),2), &
               Interp % j_lat (size(lon_out,1),size(lon_out,2),2))

    !--- first fine the neighbor points for the destination points.
    call find_neighbor(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo)

    !***************************************************************************
    !         Algorithm explanation (from disscussion with Steve Garner )      *
    !                                                                          *
    !    lon(x,y) = a1*x + b1*y + c1*x*y + d1         (1)                      *
    !    lat(x,y) = a2*x + b2*y + c2*x*y + d2         (2)                      *
    !    f (x,y) = a3*x + b3*y + c3*x*y + d3          (3)                      *
    !    with x and y is between 0 and 1.                                      *
    !    lon1 = lon(0,0) = d1,          lat1 = lat(0,0) = d2                   *
    !    lon2 = lon(1,0) = a1+d1,       lat2 = lat(1,0) = a2+d2                *
    !    lon3 = lon(1,1) = a1+b1+c1+d1, lat3 = lat(1,1) = a2+b2+c2+d2          *
    !    lon4 = lon(0,1) = b1+d1,       lat4 = lat(0,1) = b2+d2                *
    !    where (lon1,lat1),(lon2,lat2),(lon3,lat3),(lon4,lat4) represents      *
    !    the four corners starting from the left lower corner of grid box      *
    !    that encloses a destination grid ( the rotation direction is          *
    !    counterclockwise ). With these conditions, we get                     *
    !    a1 = lon2-lon1,           a2 = lat2-lat1                              *
    !    b1 = lon4-lon1,           b2 = lat4-lat1                              *
    !    c1 = lon3-lon2-lon4+lon1, c2 = lat3-lat2-lat4+lat1                    *
    !    d1 = lon1                 d2 = lat1                                   *
    !    So given any point (lon,lat), from equation (1) and (2) we can        *
    !    solve (x,y).                                                          *
    !    From equation (3)                                                     *
    !    f1 = f(0,0) = d3,          f2 = f(1,0) = a3+d3                        *
    !    f3 = f(1,1) = a3+b3+c3+d3, f4 = f(0,1) = b3+d3                        *
    !    we obtain                                                             *
    !    a3 = f2-f1,       b3 = f4-f1                                          *
    !    c3 = f3-f2-f4+f1, d3 = f1                                             *
    !    at point (lon,lat) ---> (x,y)                                         *
    !    f(x,y) = (f2-f1)x + (f4-f1)y + (f3-f2-f4+f1)xy + f1                   *
    !           = f1*(1-x)*(1-y) + f2*x*(1-y) + f3*x*y + f4*y*(1-x)            *
    !    wtw=1-x; wte=x; wts=1-y; xtn=y                                        *
    !                                                                          *
    !***************************************************************************

    lon_min = minval(lon_in);
    lon_max = maxval(lon_in);
    !--- calculate the weight
    do n = 1, nlat_out
       do m = 1, nlon_out
          lon = lon_out(m,n)
          lat = lat_out(m,n)
          if(lon .lt. lon_min) then
             lon = lon + tpi
          else if(lon .gt. lon_max) then
             lon = lon - tpi
          endif
          is = Interp%i_lon(m,n,1); ie = Interp%i_lon(m,n,2)
          js = Interp%j_lat(m,n,1); je = Interp%j_lat(m,n,2)
          lon1 = lon_in(is,js); lat1 = lat_in(is,js);
          lon2 = lon_in(ie,js); lat2 = lat_in(ie,js);
          lon3 = lon_in(ie,je); lat3 = lat_in(ie,je);
          lon4 = lon_in(is,je); lat4 = lat_in(is,je); 
          if(lon .lt. lon_min) then
             lon1 = lon1 -tpi; lon4 = lon4 - tpi
          else if(lon .gt. lon_max) then
             lon2 = lon2 +tpi; lon3 = lon3 + tpi
          endif                      
          a1 = lon2-lon1
          b1 = lon4-lon1
          c1 = lon1+lon3-lon4-lon2
          d1 = lon1
          a2 = lat2-lat1
          b2 = lat4-lat1
          c2 = lat1+lat3-lat4-lat2
          d2 = lat1
          !--- the coefficient of the quadratic equation
          a  = b2*c1-b1*c2
          b  = a1*b2-a2*b1+c1*d2-c2*d1+c2*lon-c1*lat
          c  = a2*lon-a1*lat+a1*d2-a2*d1
          quadra = b*b-4*a*c
          if(abs(quadra) < epsln) quadra = 0.0
          if(quadra < 0.0) call mpp_error(FATAL, &
               "horiz_interp_bilinear_mod: No solution existed for this quadratic equation")
          if ( abs(a) .lt. epsln) then  ! a = 0 is a linear equation
             if( abs(b) .lt. epsln) call mpp_error(FATAL, &
                  "horiz_interp_bilinear_mod: no unique solution existed for this linear equation")
             y = -c/b
          else
             y1 = 0.5*(-b+sqrt(quadra))/a
             y2 = 0.5*(-b-sqrt(quadra))/a
             if(abs(y1) < epsln) y1 = 0.0
             if(abs(y2) < epsln) y2 = 0.0
             if(abs(1-y1) < epsln) y1 = 1.0
             if(abs(1-y2) < epsln) y2 = 1.0
             num_solution = 0
             if(y1 .le. 1 .and. y1 .ge. 0) then
                y = y1
                num_solution = num_solution +1
             endif
             if(y2 .le. 1 .and. y2 .ge. 0) then
                y = y2
                num_solution = num_solution + 1
             endif
             if(num_solution == 0) then
                call mpp_error(FATAL, "horiz_interp_bilinear_mod: No solution found")
             else if(num_solution == 2) then
                call mpp_error(FATAL, "horiz_interp_bilinear_mod: Two solutions found")
             endif
           endif
           if(abs(a1+c1*y) < epsln) call mpp_error(FATAL, &
               "horiz_interp_bilinear_mod: the denomenator is 0")
           if(abs(y) < epsln) y = 0.0
           if(abs(1-y) < epsln) y = 1.0
           x = (lon-b1*y-d1)/(a1+c1*y)
           if(abs(x) < epsln) x = 0.0
           if(abs(1-x) < epsln) x = 1.0
           ! x and y should be between 0 and 1.
           if( x>1 .or. x<0 .or. y>1 .or. y < 0) call mpp_error(FATAL, &
               "horiz_interp_bilinear_mod: weight should be between 0 and 1")
           Interp % wti(m,n,1)=1-x; Interp % wti(m,n,2)=x   
           Interp % wtj(m,n,1)=1-y; Interp % wtj(m,n,2)=y          
       enddo
    enddo

  end subroutine horiz_interp_bilinear_new_2d
  ! </SUBROUTINE>

  !#######################################################################
  ! this routine will search the source grid to fine the grid box that encloses 
  ! each destination grid.
  subroutine find_neighbor( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo )
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),       dimension(:,:) :: lon_in , lat_in
    real, intent(in),       dimension(:,:) :: lon_out, lat_out
    logical,                 intent(in)    :: src_modulo
    integer                                :: nlon_in, nlat_in, nlon_out, nlat_out
    integer                                :: max_step, n, m, l, i, j, ip1, jp1, step
    integer                                :: is, js, jstart, jend, istart, iend, npts
    integer, allocatable, dimension(:)     :: ilon, jlat
    real                                   :: lon_min, lon_max, lon, lat, tpi
    logical                                :: found
    real                                   :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4

    tpi = 2.0*pi
    nlon_in  = size(lon_in,1) ; nlat_in  = size(lat_in,2)
    nlon_out = size(lon_out,1); nlat_out = size(lon_out,2)

    lon_min = minval(lon_in);
    lon_max = maxval(lon_in);

    max_step = min(nlon_in,nlat_in)/2 ! can be adjusted if needed
    allocate(ilon(8*max_step), jlat(8*max_step) )

    do n = 1, nlat_out
       do m = 1, nlon_out
          found = .false.
          lon = lon_out(m,n)
          lat = lat_out(m,n)

          if(src_modulo) then
             if(lon .lt. lon_min) then
                lon = lon + tpi
             else if(lon .gt. lon_max) then
                lon = lon - tpi
             endif
          else
             if(lon .lt. lon_min .or. lon .gt. lon_max ) &
             call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //&
                  'when input grid is not modulo, output grid should locate inside input grid')
          endif
          !--- search for the surrounding four points locatioon.
          if(m==1 .and. n==1) then
             J_LOOP: do j = 1, nlat_in-1
                do i = 1, nlon_in
                   ip1 = i+1
                   jp1 = j+1
                   if(i==nlon_in) then
                      if(src_modulo)then
                         ip1 = 1
                      else
                         cycle
                      endif
                   endif
                   lon1 = lon_in(i,  j);   lat1 = lat_in(i,j)
                   lon2 = lon_in(ip1,j);   lat2 = lat_in(ip1,j)
                   lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1)
                   lon4 = lon_in(i,  jp1); lat4 = lat_in(i,  jp1)  

                   if(lon .lt. lon_min .or. lon .gt. lon_max) then
                      if(i .ne. nlon_in) then
                         cycle
                      else
                         if(lon .lt. lon_min) then
                             lon1 = lon1 -tpi; lon4 = lon4 - tpi
                         else if(lon .gt. lon_max) then
                             lon2 = lon2 +tpi; lon3 = lon3 + tpi
                         endif
                      endif
                   endif

                   if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south
                      if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east
                         if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then ! north
                            if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then  ! west
                               found = .true.
                               Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1
                               Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1
                               exit J_LOOP
                            endif
                         endif
                      endif
                   endif
                enddo
             enddo J_LOOP
          else
             step = 0
             do while ( .not. found .and. step .lt. max_step )
                !--- take the adajcent point as the starting point
                if(m == 1) then
                   is = Interp % i_lon (m,n-1,1)
                   js = Interp % j_lat (m,n-1,1)
                else
                   is = Interp % i_lon (m-1,n,1)
                   js = Interp % j_lat (m-1,n,1)
                endif
                if(step==0) then
                   npts = 1
                   ilon(1) = is
                   jlat(1) = js
                else
                   npts = 0
                   !--- bottom and top boundary
                   jstart = max(js-step,1)
                   jend   = min(js+step,nlat_in)

                   do l = -step, step
                      i = is+l
                      if(src_modulo)then
                         if( i < 1) then
                            i = i + nlon_in
                         else if (i > nlon_in) then
                            i = i - nlon_in
                         endif
                         if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, &
                              'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' )
                      else
                         if( i < 1 .or. i > nlon_in) cycle
                      endif

                      npts       = npts + 1
                      ilon(npts) = i
                      jlat(npts) = jstart
                      npts       = npts + 1
                      ilon(npts) = i
                      jlat(npts) = jend                         
                   enddo

                   !--- right and left boundary -----------------------------------------------
                   istart = is - step
                   iend   = is + step
                   if(src_modulo) then
                      if( istart < 1)       istart = istart + nlon_in
                      if( iend   > nlon_in) iend   = iend   - nlon_in
                   else 
                      istart = max(istart,1)
                      iend   = min(iend, nlon_in)
                   endif
                   do l = -step, step
                      j = js+l
                         if( j < 1 .or. j > nlat_in) cycle
                         npts = npts+1
                         ilon(npts) = istart
                         jlat(npts) = j
                         npts = npts+1
                         ilon(npts) = iend
                         jlat(npts) = j
                  end do
                end if

                !--- find the surrouding points             
                do l = 1, npts
                   i = ilon(l)
                   j = jlat(l)
                   ip1 = i+1
                   if(ip1>nlon_in) then
                      if(src_modulo) then
                         ip1 = 1
                      else
                         cycle
                      endif
                   endif
                   jp1 = j+1
                   if(jp1>nlat_in) cycle
                   lon1 = lon_in(i,  j);   lat1 = lat_in(i,j)
                   lon2 = lon_in(ip1,j);   lat2 = lat_in(ip1,j)
                   lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1)
                   lon4 = lon_in(i,  jp1); lat4 = lat_in(i,  jp1)  

                   if(lon .lt. lon_min .or. lon .gt. lon_max) then
                      if(i .ne. nlon_in) then
                         cycle
                      else
                         if(lon .lt. lon_min) then
                             lon1 = lon1 -tpi; lon4 = lon4 - tpi
                         else if(lon .gt. lon_max) then
                             lon2 = lon2 +tpi; lon3 = lon3 + tpi
                         endif
                      endif
                   endif

                   if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south
                      if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east
                         if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then !north
                            if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west
                               found = .true.
                               is=i; js=j  
                               Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1
                               Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1
                               exit
                            endif
                         endif
                      endif
                   endif
                enddo
                step = step + 1
             enddo
          endif
          if(.not.found) then
             call mpp_error(FATAL, &
                  'horiz_interp_bilinear_mod: the destination point is not inside the source grid' )
          endif
       enddo
    enddo

  end subroutine find_neighbor

  !#######################################################################
  function intersect(x1, y1, x2, y2, x)
     real, intent(in) :: x1, y1, x2, y2, x
     real             :: intersect

     intersect = (y2-y1)*(x-x1)/(x2-x1) + y1

  return

  end function intersect

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_bilinear">

  !   <OVERVIEW>
  !      Subroutine for performing the horizontal interpolation between two grids.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Subroutine for performing the horizontal interpolation between two grids. 
  !     horiz_interp_bilinear_new must be called before calling this routine.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_bilinear ( Interp, data_in, data_out, verbose, mask_in,mask_out, missing_value, missing_permit)
  !   </TEMPLATE>
  !   
  !   <IN NAME="Interp" TYPE="type(horiz_interp_type)">
  !     Derived-type variable containing interpolation indices and weights.
  !     Returned by a previous call to horiz_interp_bilinear_new.
  !   </IN>
  !   <IN NAME="data_in" TYPE="real, dimension(:,:)">
  !      Input data on source grid.
  !   </IN>
  !   <IN NAME="verbose" TYPE="integer, optional">
  !      flag for the amount of print output.
  !               verbose = 0, no output; = 1, min,max,means; = 2, still more
  !   </IN>
  !   <IN NAME="mask_in" TYPE="real, dimension(:,:),optional">
  !      Input mask, must be the same size as the input data. The real value of
  !      mask_in must be in the range (0.,1.). Set mask_in=0.0 for data points 
  !      that should not be used or have missing data. 
  !   </IN>
  !   <IN NAME="missing_value" TYPE="real, optional">
  !      Use the missing_value to indicate missing data.
  !   </IN>

  !   <IN NAME="missing_permit" TUPE="integer, optional">
  !      numbers of points allowed to miss for the bilinear interpolation. The value
  !      should be between 0 and 3.
  !   </IN>

  !   <OUT NAME="data_out" TYPE="real, dimension(:,:)">
  !      Output data on destination grid.
  !   </OUT>
  !   <OUT NAME="mask_out" TYPE="real, dimension(:,:),optional">
  !      Output mask that specifies whether data was computed.
  !   </OUT>

  subroutine horiz_interp_bilinear ( Interp, data_in, data_out, verbose, mask_in,mask_out, &
       missing_value, missing_permit)
    !-----------------------------------------------------------------------
    type (horiz_interp_type), intent(in)        :: Interp
    real, intent(in),  dimension(:,:)           :: data_in
    real, intent(out), dimension(:,:)           :: data_out
    integer, intent(in),               optional :: verbose
    real, intent(in), dimension(:,:),  optional :: mask_in
    real, intent(out), dimension(:,:), optional :: mask_out
    real, intent(in),                  optional :: missing_value
    integer, intent(in),               optional :: missing_permit
    !-----------------------------------------------------------------------
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m,         &
         is, ie, js, je, iverbose, max_missing, num_missing, &
         miss_in, miss_out, unit
    real    :: dwtsum, wtsum, min_in, max_in, avg_in, &
         min_out, max_out, avg_out, wtw, wte, wts, wtn
    real    :: mask(size(data_in,1), size(data_in,2) )

    num_missing = 0

    nlon_in  = Interp%nlon_src;  nlat_in  = Interp%nlat_src
    nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst

    if(present(mask_in)) then
       mask = mask_in
    else
       mask = 1.0
    endif

    if (present(verbose)) then
       iverbose = verbose
    else
       iverbose = 0
    endif

    if(present(missing_permit)) then
       max_missing = missing_permit
    else
       max_missing = 0
    endif

    if(max_missing .gt. 3 .or. max_missing .lt. 0) call mpp_error(FATAL, &
         'horiz_interp_bilinear_mod: missing_permit should be between 0 and 3')

    if (size(data_in,1) /= nlon_in .or. size(data_in,2) /= nlat_in) &
         call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of input array incorrect')

    if (size(data_out,1) /= nlon_out .or. size(data_out,2) /= nlat_out) &
         call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of output array incorrect')

    do n = 1, nlat_out
       do m = 1, nlon_out
          is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2)
          js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2)
          wtw = Interp % wti   (m,n,1)
          wte = Interp % wti   (m,n,2)
          wts = Interp % wtj   (m,n,1)
          wtn = Interp % wtj   (m,n,2)

          if(present(missing_value) ) then
             num_missing = 0
             if(data_in(is,js) == missing_value) then
                num_missing = num_missing+1
                mask(is,js) = 0.0
             endif
             if(data_in(ie,js) == missing_value) then
                num_missing = num_missing+1
                mask(ie,js) = 0.0
             endif
             if(data_in(ie,je) == missing_value) then
                num_missing = num_missing+1
                mask(ie,je) = 0.0
             endif
             if(data_in(is,je) == missing_value) then
                num_missing = num_missing+1
                mask(is,je) = 0.0
             endif
          endif

          dwtsum = data_in(is,js)*mask(is,js)*wtw*wts &
               + data_in(ie,js)*mask(ie,js)*wte*wts &
               + data_in(ie,je)*mask(ie,je)*wte*wtn &
               + data_in(is,je)*mask(is,je)*wtw*wtn 
          wtsum  = mask(is,js)*wtw*wts + mask(ie,js)*wte*wts  &
               + mask(ie,je)*wte*wtn + mask(is,je)*wtw*wtn

          if(.not. present(mask_in) .and. .not. present(missing_value)) wtsum = 1.0

          if(num_missing .gt. max_missing ) then
             data_out(m,n) = missing_value
             if(present(mask_out)) mask_out(m,n) = 0.0
          else if(wtsum .lt. epsln) then 
             if(present(missing_value)) then
                data_out(m,n) = missing_value
             else
                data_out(m,n) = 0.0
             endif
             if(present(mask_out)) mask_out(m,n) = 0.0      
          else
             data_out(m,n) = dwtsum/wtsum
             if(present(mask_out)) mask_out(m,n) = wtsum
          endif
       enddo
    enddo
    !***********************************************************************
    ! compute statistics: minimum, maximum, and mean
    !-----------------------------------------------------------------------
    if (iverbose > 0) then

       ! compute statistics of input data

       call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask_in)

       ! compute statistics of output data
       call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask_out)

       !---- output statistics ----
       unit = stdout()
       write (unit,900)
       write (unit,901)  min_in ,max_in, avg_in
       if (present(mask_in))  write (unit,903)  miss_in
       write (unit,902)  min_out,max_out,avg_out
       if (present(mask_out)) write (unit,903)  miss_out

900    format (/,1x,10('-'),' output from horiz_interp ',10('-'))
901    format ('  input:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
902    format (' output:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
903    format ('          number of missing points = ',i6)

    endif

    return

  end subroutine horiz_interp_bilinear
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_bilinear_del">

  !   <OVERVIEW>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_bilinear_new.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_bilinear_new.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_bilinear_del ( Interp )
  !   </TEMPLATE>

  !   <INOUT NAME="Interp" TYPE="horiz_interp_type">
  !     A derived-type variable returned by previous call
  !     to horiz_interp_bilinear_new. The input variable must have
  !     allocated arrays. The returned variable will contain
  !     deallocated arrays.
  !   </INOUT>

  subroutine horiz_interp_bilinear_del( Interp )

    type (horiz_interp_type), intent(inout) :: Interp

    if(associated(Interp%wti))   deallocate(Interp%wti)
    if(associated(Interp%wtj))   deallocate(Interp%wtj)
    if(associated(Interp%i_lon)) deallocate(Interp%i_lon)
    if(associated(Interp%j_lat)) deallocate(Interp%j_lat)

  end subroutine horiz_interp_bilinear_del
  ! </SUBROUTINE>

  !#######################################################################

  function indp (value, array)
    integer                        :: indp
    real, dimension(:), intent(in) :: array
    real, intent(in)               :: value
    !
    !=======================================================================
    !
    !     indp = index of nearest data point within "array" corresponding to
    !            "value".

    !     inputs:
    !     value  = arbitrary data...same units as elements in "array"
    !     array  = array of data points  (must be monotonically increasing)

    !     output:
    !     indp =  index of nearest data point to "value"
    !             if "value" is outside the domain of "array" then indp = 1
    !             or "ia" depending on whether array(1) or array(ia) is
    !             closest to "value"
    !=======================================================================
    !
    integer i, ia, unit
    logical keep_going
    !
    ia = size(array(:))
    do i=2,ia
       if (array(i) .lt. array(i-1)) then
          unit = stdout()
          write (unit,*) &
               ' => Error: array must be monotonically increasing in "indp"' , &
               '           when searching for nearest element to value=',value
          write (unit,*) '           array(i) < array(i-1) for i=',i 
          write (unit,*) '           array(i) for i=1..ia follows:'
          call abort()
       endif
    enddo
    if (value .lt. array(1) .or. value .gt. array(ia)) then
       if (value .lt. array(1))  indp = 1
       if (value .gt. array(ia)) indp = ia
    else
       i=1
       keep_going = .true.
       do while (i .le. ia .and. keep_going)
          i = i+1
          if (value .le. array(i)) then
             indp = i
             if (array(i)-value .gt. value-array(i-1)) indp = i-1
             keep_going = .false.
          endif
       enddo
    endif
    return
  end function indp

  !######################################################################

end module horiz_interp_bilinear_mod


module horiz_interp_conserve_mod

  ! <CONTACT EMAIL="Bruce.Wyman@noaa.gov"> Bruce Wyman </CONTACT>
  ! <CONTACT EMAIL="Zhi.Liang@noaa.gov"> Zhi Liang </CONTACT>

  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

  ! <OVERVIEW>
  !   Performs spatial interpolation between grids using conservative interpolation
  ! </OVERVIEW>

  ! <DESCRIPTION>
  !     This module can conservatively interpolate data from any logically rectangular grid
  !     to any rectangular grid. The interpolation scheme is area-averaging 
  !     conservative scheme. There is an optional mask field for missing input data in both
  !     horiz_interp__conserveinit and horiz_interp_conserve. For efficiency purpose, mask should only be 
  !     kept in horiz_interp_init (will remove the mask in horiz_interp in the future). 
  !     There are 1-D and 2-D version of horiz_interp_conserve_init for 1-D and 2-D grid.
  !     There is a optional argument mask in horiz_interp_conserve_init_2d and no mask should 
  !     to passed into horiz_interp_conserv. optional argument mask will not be passed into
  !     horiz_interp_conserve_init_1d and optional argument mask may be passed into 
  !     horiz_interp_conserve (For the purpose of reproduce Memphis??? results).   
  !     An optional output mask field may be used in conjunction with the input mask to show 
  !     where output data exists.
  ! </DESCRIPTION>

  use mpp_mod,               only: mpp_send, mpp_recv, mpp_pe, mpp_root_pe, mpp_npes
  use mpp_mod,               only: mpp_error, FATAL,  mpp_sync_self 
  use fms_mod,               only: write_version_number
  use constants_mod,         only: PI
  use horiz_interp_type_mod, only: horiz_interp_type


  implicit none
  private

  ! public interface


  ! <INTERFACE NAME="horiz_interp_conserve_new">
  !   <OVERVIEW>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights
  !      for improved performance of multiple interpolations between
  !      the same grids. 

  !   </DESCRIPTION>
  !   <IN NAME="lon_in" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians">
  !      Longitude (in radians) for source data grid. 
  !   </IN>
  !   <IN NAME="lat_in" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians">
  !      Latitude (in radians) for source data grid.
  !   </IN>
  !   <IN NAME="lon_out" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians" >
  !      Longitude (in radians) for destination data grid. 
  !   </IN>
  !   <IN NAME="lat_out" TYPE="real" DIM="dimension(:), dimension(:,:)" UNITS="radians" >
  !      Latitude (in radians) for destination data grid. 
  !   </IN>
  !   <IN NAME="verbose" TYPE="integer, optional" >
  !      flag for the amount of print output.
  !   </IN>
  !   <IN NAME="mask_in" TYPE="real, dimension(:,:),optional">
  !      Input mask.  must be the size (size(lon_in)-1, size(lon. The real value of
  !      mask_in must be in the range (0.,1.). Set mask_in=0.0 for data points 
  !      that should not be used or have missing data.
  !   </IN>
  !   <OUT NAME="mask_out" TYPE="real, dimension(:,:),optional">
  !      Output mask that specifies whether data was computed.
  !   </OUT>
  !   <INOUT NAME="Interp" TYPE="type(horiz_interp_type)" >
  !      A derived-type variable containing indices and weights used for subsequent 
  !      interpolations. To reinitialize this variable for a different grid-to-grid 
  !      interpolation you must first use the "horiz_interp_del" interface.
  !   </INOUT>
  interface horiz_interp_conserve_new
     module procedure horiz_interp_conserve_new_1dx1d
     module procedure horiz_interp_conserve_new_1dx2d
     module procedure horiz_interp_conserve_new_2dx1d
     module procedure horiz_interp_conserve_new_2dx2d
  end interface
  ! </INTERFACE>
  public :: horiz_interp_conserve_init 
  public :: horiz_interp_conserve_new, horiz_interp_conserve, horiz_interp_conserve_del

  integer :: pe, root_pe
  !-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: horiz_interp_conserve.F90,v 16.0.6.1 2010/05/19 14:04:54 rab Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
  logical            :: module_is_initialized = .FALSE.

contains

  !#######################################################################
  !  <SUBROUTINE NAME="horiz_interp_conserve_init">
  !  <OVERVIEW>
  !     writes version number and tag name to logfile.out
  !  </OVERVIEW>
  !  <DESCRIPTION>       
  !     writes version number and tag name to logfile.out
  !  </DESCRIPTION>

  subroutine horiz_interp_conserve_init

    if(module_is_initialized) return
    call write_version_number (version, tagname)
    module_is_initialized = .true.

  end subroutine horiz_interp_conserve_init

  !  </SUBROUTINE>

  !#######################################################################
  !<PUBLICROUTINE INTERFACE="horiz_interp_conserve_new">
  subroutine horiz_interp_conserve_new_1dx1d ( Interp, lon_in, lat_in, lon_out, lat_out, verbose)
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),       dimension(:)   :: lon_in , lat_in
    real, intent(in),       dimension(:)   :: lon_out, lat_out
    integer, intent(in),       optional    :: verbose
  !</PUBLICROUTINE>
    !-----------------------------------------------------------------------
    real, dimension(size(lat_out(:))-1,2) :: sph
    real, dimension(size(lon_out(:))-1,2) :: theta
    real, dimension(size(lat_in(:)))      :: slat_in
    real, dimension(size(lon_in(:))-1)    :: dlon_in
    real, dimension(size(lat_in(:))-1)    :: dsph_in
    real, dimension(size(lon_out(:))-1)   :: dlon_out
    real, dimension(size(lat_out(:))-1)   :: dsph_out
    real    :: blon, fac, hpi, tpi, eps
    integer :: num_iters = 4
    integer :: i, j, m, n, nlon_in, nlat_in, nlon_out, nlat_out,   &
         iverbose, m2, n2, iter
    logical :: s2n
    character(len=64) :: mesg
    !-----------------------------------------------------------------------
    iverbose = 0;  if (present(verbose)) iverbose = verbose

    pe      = mpp_pe()
    root_pe = mpp_root_pe()
    !-----------------------------------------------------------------------
    hpi = 0.5*pi
    tpi = 4.*hpi
    Interp%version = 1
    nlon_in = size(lon_in(:))-1;  nlat_in = size(lat_in(:))-1
    nlon_out = size(lon_out(:))-1;  nlat_out = size(lat_out(:))-1

    allocate ( Interp % facj (nlat_out,2), Interp % jlat (nlat_out,2),      &
               Interp % faci (nlon_out,2), Interp % ilon (nlon_out,2),      &
               Interp % area_src (nlon_in, nlat_in),   &
               Interp % area_dst (nlon_out, nlat_out) )

    !-----------------------------------------------------------------------
    !  --- set-up for input grid boxes ---

    do j = 1, nlat_in+1
       slat_in(j) = sin(lat_in(j))
    enddo

    do j = 1, nlat_in
       dsph_in(j) = abs(slat_in(j+1)-slat_in(j))
    enddo

    do i = 1,nlon_in
       dlon_in(i) = abs(lon_in(i+1)-lon_in(i))
    enddo

    !  set south to north flag
    s2n = .true.
    if (lat_in(1) > lat_in(nlat_in+1)) s2n = .false.

    !-----------------------------------------------------------------------
    !  --- set-up for output grid boxes ---

    do n = 1, nlat_out
       dsph_out(n) = abs(sin(lat_out(n+1))-sin(lat_out(n)))
    enddo

    do m = 1,nlon_out
       theta(m,1)  = lon_out(m)
       theta(m,2)  = lon_out(m+1)
       dlon_out(m) = abs(lon_out(m+1)-lon_out(m))
    enddo

    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
    !***********************************************************************

    !------ set up latitudinal indexing ------
    !------ make sure output grid goes south to north ------

    do n = 1, nlat_out
       if (lat_out(n) < lat_out(n+1)) then
          sph(n,1) = sin(lat_out(n))
          sph(n,2) = sin(lat_out(n+1))
       else
          sph(n,1) = sin(lat_out(n+1))
          sph(n,2) = sin(lat_out(n))
       endif
    enddo

    Interp%jlat = 0
    do n2 = 1, 2         ! looping on grid box edges
       do n = 1, nlat_out   ! looping on output latitudes
          eps = 0.0
          do iter=1,num_iters
             ! find indices from input latitudes
             do j = 1, nlat_in
                if ( (s2n .and. (slat_in(j)-sph(n,n2)) <= eps .and.   &
                     (sph(n,n2)-slat_in(j+1)) <= eps) .or. &
                     (.not.s2n .and. (slat_in(j+1)-sph(n,n2)) <= eps .and.  &
                     (sph(n,n2)-slat_in(j)) <= eps) ) then
                   Interp%jlat(n,n2) = j
                   ! weight with sin(lat) to exactly conserve area-integral
                   fac = (sph(n,n2)-slat_in(j))/(slat_in(j+1)-slat_in(j))
                   if (s2n) then
                      if (n2 == 1) Interp%facj(n,n2) = 1.0 - fac
                      if (n2 == 2) Interp%facj(n,n2) = fac
                   else
                      if (n2 == 1) Interp%facj(n,n2) = fac
                      if (n2 == 2) Interp%facj(n,n2) = 1.0 - fac
                   endif
                   exit
                endif
             enddo
             if ( Interp%jlat(n,n2) /= 0 ) exit
             ! did not find this output grid edge in the input grid
             ! increase tolerance for multiple passes
             eps  = epsilon(sph)*real(10**iter)
          enddo
          ! no match
          if ( Interp%jlat(n,n2) == 0 ) then
             write (mesg,710) n,sph(n,n2)
710          format (': n,sph=',i3,f14.7,40x)
             call mpp_error(FATAL, 'horiz_interp_conserve_mod:no latitude index found'//trim(mesg))
          endif
       enddo
    enddo

    !------ set up longitudinal indexing ------

    Interp%ilon = 0
    do m2 = 1, 2         ! looping on grid box edges
       do m = 1, nlon_out   ! looping on output longitudes
          blon = theta(m,m2)
          if ( blon < lon_in(1)         ) blon = blon + tpi
          if ( blon > lon_in(nlon_in+1) ) blon = blon - tpi
          eps = 0.0
          do iter=1,num_iters
             ! find indices from input longitudes
             do i = 1, nlon_in
                if ( (lon_in(i)-blon) <= eps .and. &
                     (blon-lon_in(i+1)) <= eps ) then
                   Interp%ilon(m,m2) = i
                   fac = (blon-lon_in(i))/(lon_in(i+1)-lon_in(i))
                   if (m2 == 1) Interp%faci(m,m2) = 1.0 - fac
                   if (m2 == 2) Interp%faci(m,m2) = fac
                   exit
                endif
             enddo
             if ( Interp%ilon(m,m2) /= 0 ) exit
             ! did not find this output grid edge in the input grid
             ! increase tolerance for multiple passes
             eps  = epsilon(blon)*real(10**iter)
          enddo
          ! no match
          if ( Interp%ilon(m,m2) == 0 ) then
             print *, 'lon_out,blon,blon_in,eps=',  &
                  theta(m,m2),blon,lon_in(1),lon_in(nlon_in+1),eps
             call mpp_error(FATAL, 'horiz_interp_conserve_mod: no longitude index found')
          endif
       enddo
    enddo

    !  --- area of input grid boxes ---

    do j = 1,nlat_in
       do i = 1,nlon_in
          Interp%area_src(i,j) = dlon_in(i) * dsph_in(j)
       enddo
    enddo

    !  --- area of output grid boxes ---

    do n = 1, nlat_out
       do m = 1, nlon_out
          Interp%area_dst(m,n) = dlon_out(m) * dsph_out(n)
       enddo
    enddo

    !-----------------------------------------------------------------------
    ! this output may be quite lengthy and is not recommended
    ! when using more than one processor
    if (iverbose > 2) then
       write (*,801) (i,Interp%ilon(i,1),Interp%ilon(i,2),  &
            Interp%faci(i,1),Interp%faci(i,2),i=1,nlon_out)
       write (*,802) (j,Interp%jlat(j,1),Interp%jlat(j,2),  &
            Interp%facj(j,1),Interp%facj(j,2),j=1,nlat_out)
801    format (/,2x,'i',4x,'is',5x,'ie',4x,'facis',4x,'facie',  &
            /,(i4,2i7,2f10.5))
802    format (/,2x,'j',4x,'js',5x,'je',4x,'facjs',4x,'facje',  &
            /,(i4,2i7,2f10.5))
    endif
    !-----------------------------------------------------------------------

  end subroutine horiz_interp_conserve_new_1dx1d

  !#######################################################################
  !<PUBLICROUTINE INTERFACE="horiz_interp_conserve_new">
  subroutine horiz_interp_conserve_new_1dx2d ( Interp, lon_in, lat_in, lon_out, lat_out, mask_in, mask_out, verbose)
    type(horiz_interp_type),        intent(inout) :: Interp
    real, intent(in),              dimension(:)   :: lon_in , lat_in
    real, intent(in),              dimension(:,:) :: lon_out, lat_out
    real, intent(in),    optional, dimension(:,:) :: mask_in
    real, intent(inout), optional, dimension(:,:) :: mask_out
    integer, intent(in), optional                 :: verbose
  !</PUBLICROUTINE>

    integer :: create_xgrid_1DX2D_order1, get_maxxgrid, maxxgrid
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i
    real, dimension(size(lon_in(:))-1, size(lat_in(:))-1) :: mask_src
    integer, allocatable, dimension(:)   :: i_src, j_src, i_dst, j_dst
    real,    allocatable, dimension(:)   :: xgrid_area
    real,    allocatable, dimension(:,:) :: dst_area

    if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) )  &
        call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out')
    nlon_in  = size(lon_in(:)) - 1;  nlat_in  = size(lat_in(:)) - 1
    nlon_out = size(lon_out,1) - 1;  nlat_out = size(lon_out,2) - 1

    mask_src = 1
    if(present(mask_in)) then
       if( (size(mask_in,1) .NE. nlon_in) .OR.  (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, &
         'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in')
       mask_src = mask_in
    end if

    maxxgrid = get_maxxgrid()
    allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) )
    allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) )
    nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, &
                                       mask_src, i_src, j_src, i_dst, j_dst, xgrid_area)
    allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) )
    allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) )
    allocate(Interp%area_frac_dst(nxgrid) )
    Interp%version = 2
    Interp%nxgrid   = nxgrid
    Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0
    Interp%j_src = j_src(1:nxgrid)+1
    Interp%i_dst = i_dst(1:nxgrid)+1
    Interp%j_dst = j_dst(1:nxgrid)+1

    ! sum over exchange grid area to get destination grid area
    dst_area = 0
    do i = 1, nxgrid
       dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i)       
    end do    

    do i = 1, nxgrid
       Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) )
    end do
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
    if(present(mask_out)) then
       if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, &
         'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out')
       mask_out = 0.0
       do i = 1, nxgrid
          mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i),Interp%j_dst(i)) + Interp%area_frac_dst(i)
       end do
    end if

    deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area )

  end subroutine horiz_interp_conserve_new_1dx2d

  !#######################################################################
  !<PUBLICROUTINE INTERFACE="horiz_interp_conserve_new">
  subroutine horiz_interp_conserve_new_2dx1d ( Interp, lon_in, lat_in, lon_out, lat_out, mask_in, mask_out, verbose)
    type(horiz_interp_type),        intent(inout) :: Interp
    real, intent(in),              dimension(:,:) :: lon_in , lat_in
    real, intent(in),              dimension(:)   :: lon_out, lat_out
    real, intent(in),    optional, dimension(:,:) :: mask_in
    real, intent(inout), optional, dimension(:,:) :: mask_out
    integer, intent(in), optional                 :: verbose
  !</PUBLICROUTINE>

    integer :: create_xgrid_2DX1D_order1, get_maxxgrid, maxxgrid
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i
    real, dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src
    integer, allocatable, dimension(:)   :: i_src, j_src, i_dst, j_dst
    real,    allocatable, dimension(:)   :: xgrid_area
    real,    allocatable, dimension(:,:) :: dst_area

    if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) )  &
        call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in')
    nlon_in  = size(lon_in,1)   - 1;  nlat_in  = size(lon_in,2)   - 1
    nlon_out = size(lon_out(:)) - 1;  nlat_out = size(lat_out(:)) - 1

    mask_src = 1
    if(present(mask_in)) then
       if( (size(mask_in,1) .NE. nlon_in) .OR.  (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, &
         'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in')
       mask_src = mask_in
    end if

    maxxgrid = get_maxxgrid()
    allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) )
    allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) )

    nxgrid = create_xgrid_2DX1D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, &
                                       mask_src, i_src, j_src, i_dst, j_dst, xgrid_area)
    allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) )
    allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) )
    allocate(Interp%area_frac_dst(nxgrid) )
    Interp%version = 2
    Interp%nxgrid   = nxgrid
    Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0
    Interp%j_src = j_src(1:nxgrid)+1
    Interp%i_dst = i_dst(1:nxgrid)+1
    Interp%j_dst = j_dst(1:nxgrid)+1

    ! sum over exchange grid area to get destination grid area
    dst_area = 0
    do i = 1, nxgrid
       dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i)       
    end do    

    do i = 1, nxgrid
       Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) )
    end do
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
    if(present(mask_out)) then
       if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, &
         'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out')
       mask_out = 0.0
       do i = 1, nxgrid
          mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i),Interp%j_dst(i)) + Interp%area_frac_dst(i)
       end do
    end if

    deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area)

  end subroutine horiz_interp_conserve_new_2dx1d

  !#######################################################################
  !<PUBLICROUTINE INTERFACE="horiz_interp_conserve_new">
  subroutine horiz_interp_conserve_new_2dx2d ( Interp, lon_in, lat_in, lon_out, lat_out, mask_in, mask_out, verbose)
    type(horiz_interp_type),        intent(inout) :: Interp
    real, intent(in),              dimension(:,:) :: lon_in , lat_in
    real, intent(in),              dimension(:,:) :: lon_out, lat_out
    real, intent(in),    optional, dimension(:,:) :: mask_in
    real, intent(inout), optional, dimension(:,:) :: mask_out
    integer, intent(in), optional                 :: verbose
  !</PUBLICROUTINE>

    integer :: create_xgrid_2DX2D_order1, get_maxxgrid, maxxgrid
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i
    real, dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src
    integer, allocatable, dimension(:)   :: i_src, j_src, i_dst, j_dst
    real,    allocatable, dimension(:)   :: xgrid_area
    real,    allocatable, dimension(:,:) :: dst_area

    if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) )  &
        call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in')
    if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) )  &
        call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out')
    nlon_in  = size(lon_in,1)  - 1;  nlat_in  = size(lon_in,2)  - 1
    nlon_out = size(lon_out,1) - 1;  nlat_out = size(lon_out,2) - 1

    mask_src = 1
    if(present(mask_in)) then
       if( (size(mask_in,1) .NE. nlon_in) .OR.  (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, &
         'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in')
       mask_src = mask_in
    end if

    maxxgrid = get_maxxgrid()
    allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) )
    allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) )
    nxgrid = create_xgrid_2DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, &
                                       mask_src, i_src, j_src, i_dst, j_dst, xgrid_area)
    allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) )
    allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) )
    allocate(Interp%area_frac_dst(nxgrid) )
    Interp%version = 2
    Interp%nxgrid   = nxgrid
    Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0
    Interp%j_src = j_src(1:nxgrid)+1
    Interp%i_dst = i_dst(1:nxgrid)+1
    Interp%j_dst = j_dst(1:nxgrid)+1

    ! sum over exchange grid area to get destination grid area
    dst_area = 0
    do i = 1, nxgrid
       dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i)       
    end do    

    do i = 1, nxgrid
       Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) )
    end do

    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
    if(present(mask_out)) then
       if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, &
         'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out')
       mask_out = 0.0
       do i = 1, nxgrid
          mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i),Interp%j_dst(i)) + Interp%area_frac_dst(i)
       end do
    end if

    deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area )

  end subroutine horiz_interp_conserve_new_2dx2d

  !########################################################################
  ! <SUBROUTINE NAME="horiz_interp_conserve">

  !   <OVERVIEW>
  !      Subroutine for performing the horizontal interpolation between two grids.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Subroutine for performing the horizontal interpolation between two grids. 
  !     horiz_interp_conserve_new must be called before calling this routine.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_conserve ( Interp, data_in, data_out, verbose, mask_in, mask_out)
  !   </TEMPLATE>
  !   
  !   <IN NAME="Interp" TYPE="type(horiz_interp_type)">
  !     Derived-type variable containing interpolation indices and weights.
  !     Returned by a previous call to horiz_interp_new.
  !   </IN>
  !   <IN NAME="data_in" TYPE="real, dimension(:,:)">
  !      Input data on source grid.
  !   </IN>

  !   <IN NAME="verbose" TYPE="integer, optional">
  !      flag for the amount of print output.
  !               verbose = 0, no output; = 1, min,max,means; = 2, still more
  !   </IN>
  !   <IN NAME="mask_in" TYPE="real, dimension(:,:),optional">
  !      Input mask, must be the same size as the input data. The real value of
  !      mask_in must be in the range (0.,1.). Set mask_in=0.0 for data points 
  !      that should not be used or have missing data. mask_in will be applied only
  !      when horiz_interp_conserve_new_1d is called. mask_in will be passed into
  !      horiz_interp_conserve_new_2d.
  !   </IN>

  !   <OUT NAME="data_out" TYPE="real, dimension(:,:)">
  !      Output data on destination grid.
  !   </OUT>
  !   <OUT NAME="mask_out" TYPE="real, dimension(:,:),optional">
  !      Output mask that specifies whether data was computed. mask_out will be computed only
  !      when horiz_interp_conserve_new_1d is called. mask_out will be computed in
  !      horiz_interp_conserve_new_2d.
  !   </OUT>

  subroutine horiz_interp_conserve ( Interp, data_in, data_out, verbose, &
       mask_in, mask_out)
    !-----------------------------------------------------------------------
    type (horiz_interp_type), intent(in) :: Interp
    real, intent(in),  dimension(:,:) :: data_in
    real, intent(out), dimension(:,:) :: data_out
    integer, intent(in),                   optional :: verbose
    real, intent(in),   dimension(:,:), optional :: mask_in
    real, intent(out),  dimension(:,:), optional :: mask_out

    !  --- error checking ---
    if (size(data_in,1) /= Interp%nlon_src .or. size(data_in,2) /= Interp%nlat_src) &
         call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of input array incorrect')

    if (size(data_out,1) /= Interp%nlon_dst .or. size(data_out,2) /= Interp%nlat_dst) &
         call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of output array incorrect')

    select case ( Interp%version)
    case (1)
       call horiz_interp_conserve_version1(Interp, data_in, data_out, verbose, mask_in, mask_out)
    case (2)
       if(present(mask_in) .OR. present(mask_out) ) call mpp_error(FATAL,  &
            'horiz_interp_conserve: for version 2, mask_in and mask_out must be passed in horiz_interp_new, not in horiz_interp')
       call horiz_interp_conserve_version2(Interp, data_in, data_out, verbose)     
    end select

  end subroutine horiz_interp_conserve
  ! </SUBROUTINE>

  !##############################################################################
  subroutine horiz_interp_conserve_version1 ( Interp, data_in, data_out, verbose, &
       mask_in, mask_out)
    !-----------------------------------------------------------------------
    type (horiz_interp_type), intent(in) :: Interp
    real, intent(in),  dimension(:,:) :: data_in
    real, intent(out), dimension(:,:) :: data_out
    integer, intent(in),                   optional :: verbose
    real, intent(in),   dimension(:,:), optional :: mask_in
    real, intent(out),  dimension(:,:), optional :: mask_out
    !----------local variables----------------------------------------------------
    integer :: m, n, nlon_in, nlat_in, nlon_out, nlat_out,   &
         miss_in, miss_out, is, ie, js, je,   &
         np, npass, iverbose
    real    :: dsum, wsum, avg_in, min_in, max_in,   &
         avg_out, min_out, max_out, eps, asum,   &
         dwtsum, wtsum, arsum, fis, fie, fjs, fje
    !-----------------------------------------------------------------------
    iverbose = 0;  if (present(verbose)) iverbose = verbose

    eps = epsilon(wtsum)

    nlon_in  = Interp%nlon_src;  nlat_in  = Interp%nlat_src
    nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst

    if (present(mask_in)) then
       if ( count(mask_in < -.0001 .or. mask_in > 1.0001) > 0 ) &
            call mpp_error(FATAL, 'horiz_interp_conserve_mod: input mask not between 0,1')
    endif

    !-----------------------------------------------------------------------
    !---- loop through output grid boxes ----

    data_out = 0.0
    do n = 1, nlat_out
       ! latitude window
       ! setup ascending latitude indices and weights
       if (Interp%jlat(n,1) <= Interp%jlat(n,2)) then
          js = Interp%jlat(n,1); je = Interp%jlat(n,2)
          fjs = Interp%facj(n,1); fje = Interp%facj(n,2)
       else
          js = Interp%jlat(n,2); je = Interp%jlat(n,1)
          fjs = Interp%facj(n,2); fje = Interp%facj(n,1)
       endif

       do m = 1, nlon_out
          ! longitude window
          is = Interp%ilon(m,1); ie = Interp%ilon(m,2)
          fis = Interp%faci(m,1); fie = Interp%faci(m,2)
          npass = 1
          dwtsum = 0.
          wtsum = 0.
          arsum = 0.

          ! wrap-around on input grid
          ! sum using 2 passes (pass 1: end of input grid)
          if ( ie < is ) then
             ie = nlon_in
             fie = 1.0
             npass = 2
          endif

          do np = 1, npass
             ! pass 2: beginning of input grid
             if ( np == 2 ) then
                is = 1
                fis = 1.0
                ie = Interp%ilon(m,2)
                fie = Interp%faci(m,2)
             endif

             ! summing data*weight and weight for single grid point
             if (present(mask_in)) then
                call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), &
                     fis, fie, fjs,fje, dwtsum, wtsum, arsum, mask_in(is:ie,js:je)  )
             else if( ASSOCIATED(Interp%mask_in) ) then
                call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), &
                     fis, fie, fjs,fje, dwtsum, wtsum, arsum, Interp%mask_in(is:ie,js:je)  )
             else
                call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), &
                     fis, fie, fjs,fje,  dwtsum, wtsum, arsum    )
             endif
          enddo

          if (wtsum > eps) then
             data_out(m,n) = dwtsum/wtsum
             if (present(mask_out)) mask_out(m,n) = wtsum/arsum
          else
             data_out(m,n) = 0.
             if (present(mask_out)) mask_out(m,n) = 0.0
          endif

       enddo
    enddo

    !***********************************************************************
    ! compute statistics: minimum, maximum, and mean
    !-----------------------------------------------------------------------

    if (iverbose > 0) then

       ! compute statistics of input data

       call stats(data_in, Interp%area_src, asum, dsum, wsum, min_in, max_in, miss_in, mask_in)
       ! diagnostic messages
       ! on the root_pe, we can calculate the global mean, minimum and maximum.
       if(pe == root_pe) then
          if (wsum > 0.0) then
             avg_in=dsum/wsum
          else
             print *, 'horiz_interp stats: input area equals zero '
             avg_in=0.0
          endif
          if (iverbose > 1) print '(2f16.11)', 'global sum area_in  = ',  asum, wsum
       endif

       ! compute statistics of output data
       call stats(data_out, Interp%area_dst, asum, dsum, wsum, min_out, max_out, miss_out, mask_out)
       ! diagnostic messages
       if(pe == root_pe) then
          if (wsum > 0.0) then
             avg_out=dsum/wsum
          else
             print *, 'horiz_interp stats: output area equals zero '
             avg_out=0.0
          endif
          if (iverbose > 1) print '(2f16.11)', 'global sum area_out = ',  asum, wsum
       endif
       !---- output statistics ----
       ! the global mean, min and max are calculated on the root pe.
       if(pe == root_pe) then
          write (*,900)
          write (*,901)  min_in ,max_in ,avg_in
          if (present(mask_in))  write (*,903)  miss_in
          write (*,902)  min_out,max_out,avg_out
          if (present(mask_out)) write (*,903)  miss_out
       endif

900    format (/,1x,10('-'),' output from horiz_interp ',10('-'))
901    format ('  input:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
902    format (' output:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
903    format ('          number of missing points = ',i6)

    endif

    !-----------------------------------------------------------------------
  end subroutine horiz_interp_conserve_version1

  !#############################################################################
  subroutine horiz_interp_conserve_version2 ( Interp, data_in, data_out, verbose )
    !-----------------------------------------------------------------------
    type (horiz_interp_type), intent(in) :: Interp
    real,    intent(in),  dimension(:,:) :: data_in
    real,    intent(out), dimension(:,:) :: data_out
    integer, intent(in),        optional :: verbose  
    integer :: i, i_src, j_src, i_dst, j_dst

    data_out = 0.0
    do i = 1, Interp%nxgrid
       i_src = Interp%i_src(i); j_src = Interp%j_src(i)
       i_dst = Interp%i_dst(i); j_dst = Interp%j_dst(i)
       data_out(i_dst, j_dst) = data_out(i_dst, j_dst) + data_in(i_src,j_src)*Interp%area_frac_dst(i)
    end do
    
  end subroutine horiz_interp_conserve_version2

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_conserve_del">

  !   <OVERVIEW>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_new.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_new.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_conserve_del ( Interp )
  !   </TEMPLATE>

  !   <INOUT NAME="Interp" TYPE="horiz_interp_type">
  !     A derived-type variable returned by previous call
  !     to horiz_interp_new. The input variable must have
  !     allocated arrays. The returned variable will contain
  !     deallocated arrays.
  !   </INOUT>

  subroutine horiz_interp_conserve_del ( Interp )

    type (horiz_interp_type), intent(inout) :: Interp

    select case(Interp%version)  
    case (1)
       if(associated(Interp%area_src)) deallocate(Interp%area_src)
       if(associated(Interp%area_dst)) deallocate(Interp%area_dst)
       if(associated(Interp%facj))     deallocate(Interp%facj)
       if(associated(Interp%jlat))     deallocate(Interp%jlat)
       if(associated(Interp%faci))     deallocate(Interp%faci)
       if(associated(Interp%ilon))     deallocate(Interp%ilon)
    case (2)
       if(associated(Interp%i_src)) deallocate(Interp%i_src)
       if(associated(Interp%j_src)) deallocate(Interp%j_src)
       if(associated(Interp%i_dst)) deallocate(Interp%i_dst)
       if(associated(Interp%j_dst)) deallocate(Interp%j_dst)
       if(associated(Interp%area_frac_dst)) deallocate(Interp%area_frac_dst)
    end select

  end subroutine horiz_interp_conserve_del
  ! </SUBROUTINE>

  !#######################################################################
  !---This statistics is for conservative scheme
  subroutine stats ( dat, area, asum, dsum, wsum, low, high, miss, mask )
    real,    intent(in)  :: dat(:,:), area(:,:)
    real,    intent(out) :: asum, dsum, wsum, low, high
    integer, intent(out) :: miss
    real,    intent(in), optional :: mask(:,:)

    integer :: pe, root_pe, npes, p, buffer_int(1)
    real    :: buffer_real(5)

    pe = mpp_pe()
    root_pe = mpp_root_pe()
    npes = mpp_npes()

    ! sum data, data*area; and find min,max on each pe.

    if (present(mask)) then
       asum = sum(area(:,:))
       dsum = sum(area(:,:)*dat(:,:)*mask(:,:))
       wsum = sum(area(:,:)*mask(:,:))
       miss = count(mask(:,:) <= 0.5)
       low  = minval(dat(:,:),mask=mask(:,:) > 0.5)
       high = maxval(dat(:,:),mask=mask(:,:) > 0.5)
    else
       asum = sum(area(:,:))
       dsum = sum(area(:,:)*dat(:,:))
       wsum = sum(area(:,:))
       miss = 0
       low  = minval(dat(:,:))
       high = maxval(dat(:,:))
    endif

    ! other pe send local min, max, avg to the root pe and 
    ! root pe receive these information

    if(pe == root_pe) then
       do p = 1, npes - 1
          ! Force use of "scalar", integer pointer mpp interface
          call mpp_recv(buffer_real(1),glen=5,from_pe=root_pe+p)
          asum = asum + buffer_real(1)
          dsum = dsum + buffer_real(2)
          wsum = wsum + buffer_real(3)
          low  = min(low, buffer_real(4))
          high = max(high, buffer_real(5))
          call mpp_recv(buffer_int(1),glen=1,from_pe=root_pe+p)
          miss = miss + buffer_int(1)
       enddo
    else
       buffer_real(1) = asum
       buffer_real(2) = dsum
       buffer_real(3) = wsum
       buffer_real(4) = low
       buffer_real(5) = high
       ! Force use of "scalar", integer pointer mpp interface
       call mpp_send(buffer_real(1),plen=5,to_pe=root_pe)
       buffer_int(1) = miss
       call mpp_send(buffer_int(1),plen=1,to_pe=root_pe)
    endif

    call mpp_sync_self()   

  end subroutine stats

  !#######################################################################

  subroutine data_sum( data, area, facis, facie, facjs, facje,  &
       dwtsum, wtsum, arsum, mask )

    !  sums up the data and weights for a single output grid box
    !-----------------------------------------------------------------------
    real, intent(in), dimension(:,:) :: data, area
    real, intent(in)                 :: facis, facie, facjs, facje
    real, intent(inout)              :: dwtsum, wtsum, arsum
    real, intent(in), optional       :: mask(:,:)

    !  fac__ = fractional portion of each boundary grid box included
    !          in the integral
    !  dwtsum = sum(data*area*mask)
    !  wtsum  = sum(area*mask)
    !  arsum  = sum(area)
    !-----------------------------------------------------------------------
    real, dimension(size(area,1),size(area,2)) :: wt
    real    :: asum
    integer :: id, jd
    !-----------------------------------------------------------------------

    id=size(area,1); jd=size(area,2) 

    wt=area
    wt( 1,:)=wt( 1,:)*facis
    wt(id,:)=wt(id,:)*facie
    wt(:, 1)=wt(:, 1)*facjs
    wt(:,jd)=wt(:,jd)*facje

    asum = sum(wt)
    arsum = arsum + asum

    if (present(mask)) then
       wt = wt * mask
       dwtsum = dwtsum + sum(wt*data)
       wtsum =  wtsum + sum(wt)
    else
       dwtsum = dwtsum + sum(wt*data)
       wtsum =  wtsum + asum
    endif
    !-----------------------------------------------------------------------

  end subroutine data_sum


  !#######################################################################

end module horiz_interp_conserve_mod




module horiz_interp_spherical_mod

  ! <CONTACT EMAIL="Matthew.Harrison@noaa.gov"> Matthew Harrison </CONTACT>
  ! <CONTACT EMAIL="Zhi.Liang@noaa.gov"> Zhi Liang </CONTACT>

  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

  ! <OVERVIEW>
  !   Performs spatial interpolation between grids using inverse-distance-weighted scheme.
  ! </OVERVIEW>

  ! <DESCRIPTION>
  !     This module can interpolate data from rectangular/tripolar grid
  !     to rectangular/tripolar grid. The interpolation scheme is inverse-distance-weighted 
  !     scheme.    There is an optional mask field for missing input data.
  !     An optional output mask field may be used in conjunction with
  !     the input mask to show where output data exists.
  ! </DESCRIPTION>

  use mpp_mod,               only : mpp_error, FATAL, WARNING, stdout
  use mpp_mod,               only : mpp_root_pe, mpp_pe
  use mpp_mod,               only : input_nml_file
  use fms_mod,               only : write_version_number, file_exist, close_file
  use fms_mod,               only : check_nml_error, open_namelist_file
  use constants_mod,         only : pi
  use horiz_interp_type_mod, only : horiz_interp_type, stats

  implicit none
  private


  public :: horiz_interp_spherical_new, horiz_interp_spherical, horiz_interp_spherical_del
  public :: horiz_interp_spherical_init

  integer, parameter :: max_neighbors = 400 
  real,    parameter :: max_dist_default = 0.1  ! radians
  integer, parameter :: num_nbrs_default = 4
  real,    parameter :: large=1.e20
  real,    parameter :: epsln=1.e-10

  integer            :: pe, root_pe


  !--- namelist interface
  !<NAMELIST NAME="horiz_interp_spherical_nml">
  ! <DATA NAME="search_method" TYPE="character(len=32)">
  !  indicate the searching method to find the nearest neighbor points. Its value
  !  can be "radial_search" and "full_search", with default value "radial_search".
  !  when search_method is "radial_search", the search may be not quite accurate for some cases.
  !  Normally the search will be ok if you chose suitable max_dist.  
  !  When search_method is "full_search", it will be always accurate, but will be slower
  !  comparing to "radial_search". Normally these two search algorithm will produce same 
  !  results other than order of operation. "radial_search" are recommended to use. 
  !  The purpose to add "full_search" is in case you think you interpolation results is 
  !  not right, you have other option to verify.
  ! </DATA>
  !</NAMELIST>

  character(len=32) :: search_method = "radial_search" ! or "full_search"
  namelist /horiz_interp_spherical_nml/ search_method

  !-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: horiz_interp_spherical.F90,v 14.0.16.1 2010/08/31 14:28:55 z1l Exp $'
  character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
  logical            :: module_is_initialized = .FALSE.

contains

  !#######################################################################
  !  <SUBROUTINE NAME="horiz_interp_spherical_init">
  !  <OVERVIEW>
  !     writes version number and tag name to logfile.out
  !  </OVERVIEW>
  !  <DESCRIPTION>       
  !     writes version number and tag name to logfile.out
  !  </DESCRIPTION>

  subroutine horiz_interp_spherical_init
    integer :: unit, ierr, io


    if(module_is_initialized) return
    call write_version_number (version, tagname)
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, horiz_interp_spherical_nml, iostat=io)
#else
    if (file_exist('input.nml')) then
       unit = open_namelist_file ( )
       ierr=1; do while (ierr /= 0)
       read  (unit, nml=horiz_interp_spherical_nml, iostat=io, end=10)
       ierr = check_nml_error(io,'horiz_interp_spherical_nml')  ! also initializes nml error codes
    enddo
10  call close_file (unit)
    endif
#endif

 module_is_initialized = .true.



end subroutine horiz_interp_spherical_init

  !  </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_spherical_new">

  !   <OVERVIEW>
  !      Initialization routine.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_spherical_new(Interp, lon_in,lat_in,lon_out,lat_out, num_nbrs, max_dist, src_modulo)
  !   </TEMPLATE>
  !   
  !   <IN NAME="lon_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Longitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="lat_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lon_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Longitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="lat_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Latitude (in radians) for source data grid. 
  !   </IN>

  !   <IN NAME="num_nbrs" TYPE="integer, optional">
  !     Number of nearest neighbors for regridding. When number of neighbors within
  !     the radius max_dist ( namelist variable) is less than num_nbrs, All the neighbors 
  !     will be used to interpolate onto destination grid. when number of neighbors within
  !     the radius max_dist ( namelist variable) is greater than num_nbrs, at least "num_nbrs"
  !     neighbors will be used to remap onto destination grid. 
  !   </IN>

  !   <IN NAME="max_dist" TYPE="real, optional" UNITS="radians">
  !      Maximum region of influence around destination grid points.
  !   </IN>

  !   <IN NAME="src_modulo" TYPE="logical, optional">
  !      logical variable to indicate if the boundary condition along zonal boundary
  !      is cyclic or not. When true, the zonal boundary condition is cyclic.
  !   </IN>

  !   <INOUT NAME="Interp" TYPE="type(horiz_interp_type)">
  !      A derived-type variable containing indices and weights used for subsequent 
  !      interpolations. To reinitialize this variable for a different grid-to-grid 
  !      interpolation you must first use the "horiz_interp_del" interface.
  !   </INOUT>

  subroutine horiz_interp_spherical_new(Interp, lon_in,lat_in,lon_out,lat_out, &
       num_nbrs, max_dist, src_modulo)
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),       dimension(:,:) :: lon_in, lat_in, lon_out, lat_out
    integer, intent(in),        optional   :: num_nbrs
    real, optional,             intent(in) :: max_dist
    logical,          intent(in), optional :: src_modulo

    !------local variables ---------------------------------------
    integer :: i, j, n
    integer :: map_dst_xsize, map_dst_ysize, map_src_xsize, map_src_ysize
    integer :: map_src_size, num_neighbors
    real    :: max_src_dist, tpi, hpi 
    logical :: src_is_modulo
    real    :: min_theta_dst, max_theta_dst, min_phi_dst, max_phi_dst
    real    :: min_theta_src, max_theta_src, min_phi_src, max_phi_src 
    integer, dimension(:),        allocatable        :: ilon, jlat
    integer, dimension(:,:,:),    allocatable        :: map_src_add
    integer, dimension(:,:),      allocatable        :: num_found
    real, dimension(:,:,:),       allocatable        :: map_src_dist
    real, dimension(size(lon_out,1),size(lon_out,2)) :: theta_dst, phi_dst
    real, dimension(size(lon_in,1)*size(lon_in,2))   :: theta_src, phi_src

    !--------------------------------------------------------------

    pe      = mpp_pe()
    root_pe = mpp_root_pe()

    tpi = 2.0*PI; hpi = 0.5*PI

    num_neighbors = num_nbrs_default
    if(present(num_nbrs)) num_neighbors = num_nbrs
    if (num_neighbors <= 0) call mpp_error(FATAL,'horiz_interp_spherical_mod: num_neighbors must be > 0') 

    max_src_dist = max_dist_default
    if (PRESENT(max_dist)) max_src_dist = max_dist
    Interp%max_src_dist = max_src_dist

    src_is_modulo = .true.
    if (PRESENT(src_modulo)) src_is_modulo = src_modulo

    !--- check the grid size comformable
    map_dst_xsize=size(lon_out,1);map_dst_ysize=size(lon_out,2)
    map_src_xsize=size(lon_in,1); map_src_ysize=size(lon_in,2)
    map_src_size = map_src_xsize*map_src_ysize

    if (map_dst_xsize /= size(lat_out,1) .or. map_dst_ysize /= size(lat_out,2)) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: destination grids not conformable')
    if (map_src_xsize /= size(lat_in,1) .or. map_src_ysize /= size(lat_in,2)) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: source grids not conformable')

    theta_src      = reshape(lon_in,(/map_src_size/))
    phi_src        = reshape(lat_in,(/map_src_size/))
    theta_dst(:,:) = lon_out(:,:)
    phi_dst(:,:)   = lat_out(:,:)

    min_theta_dst=tpi;max_theta_dst=0.0;min_phi_dst=pi;max_phi_dst=-pi
    min_theta_src=tpi;max_theta_src=0.0;min_phi_src=pi;max_phi_src=-pi

    where(theta_dst<0.0)  theta_dst = theta_dst+tpi
    where(theta_dst>tpi)  theta_dst = theta_dst-tpi
    where(theta_src<0.0)  theta_src = theta_src+tpi
    where(theta_src>tpi)  theta_src = theta_src-tpi

    where(phi_dst < -hpi) phi_dst = -hpi
    where(phi_dst > hpi)  phi_dst =  hpi
    where(phi_src < -hpi) phi_src = -hpi
    where(phi_src > hpi)  phi_src =  hpi    

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          min_theta_dst = min(min_theta_dst,theta_dst(i,j))
          max_theta_dst = max(max_theta_dst,theta_dst(i,j))
          min_phi_dst = min(min_phi_dst,phi_dst(i,j))
          max_phi_dst = max(max_phi_dst,phi_dst(i,j))
       enddo
    enddo

    do i=1,map_src_size
       min_theta_src = min(min_theta_src,theta_src(i))
       max_theta_src = max(max_theta_src,theta_src(i))
       min_phi_src = min(min_phi_src,phi_src(i))
       max_phi_src = max(max_phi_src,phi_src(i))
    enddo

    if (min_phi_dst < min_phi_src) print *, '=> WARNING:  latitute of dest grid exceeds src'
    if (max_phi_dst > max_phi_src) print *, '=> WARNING:  latitute of dest grid exceeds src'
    ! when src is cyclic, no need to print out the following warning.
    if(.not. src_is_modulo) then    
       if (min_theta_dst < min_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src'
       if (max_theta_dst > max_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src'
    endif
    allocate(map_src_add(map_dst_xsize,map_dst_ysize,max_neighbors),    &
         map_src_dist(map_dst_xsize,map_dst_ysize,max_neighbors),   &
         num_found(map_dst_xsize,map_dst_ysize),                    &
         ilon(max_neighbors),jlat(max_neighbors)  )

    ! allocate memory to data type
    allocate(Interp%i_lon(map_dst_xsize,map_dst_ysize,max_neighbors), &
         Interp%j_lat(map_dst_xsize,map_dst_ysize,max_neighbors),     &
         Interp%src_dist(map_dst_xsize,map_dst_ysize,max_neighbors),  &
         Interp%num_found(map_dst_xsize,map_dst_ysize)       )

    map_src_add         = 0
    map_src_dist        = large
    num_found           = 0

    !using radial_search to find the nearest points and corresponding distance.

    select case(trim(search_method))
    case ("radial_search") ! will be efficient, but may be not so accurate for some cases
       call radial_search(theta_src, phi_src, theta_dst, phi_dst, map_src_xsize, map_src_ysize, &
            map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo)    
    case ("full_search")   ! always accurate, but less efficient.
       call full_search(theta_src, phi_src, theta_dst, phi_dst, map_src_add, map_src_dist, &
            num_found, num_neighbors,max_src_dist )
    case default
       call mpp_error(FATAL,"horiz_interp_spherical_new: nml search_method = "// &
                  trim(search_method)//" is not a valid namelist option")
    end select    

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          do n=1,num_found(i,j)
             if(map_src_add(i,j,n) == 0) then
                jlat(n) = 0; ilon(n) = 0
             else
                jlat(n) = map_src_add(i,j,n)/map_src_xsize + 1
                ilon(n) = map_src_add(i,j,n) - (jlat(n)-1)*map_src_xsize
                if(ilon(n) == 0) then
                   jlat(n) = jlat(n) - 1
                   ilon(n) = map_src_xsize
                endif
             endif
          enddo
          Interp%i_lon(i,j,:)         = ilon(:)
          Interp%j_lat(i,j,:)         = jlat(:)
          Interp%num_found(i,j)       = num_found(i,j)
          Interp%src_dist(i,j,:)      = map_src_dist(i,j,:)
       enddo
    enddo

    Interp%nlon_src = map_src_xsize; Interp%nlat_src = map_src_ysize
    Interp%nlon_dst = map_dst_xsize; Interp%nlat_dst = map_dst_ysize

    deallocate(map_src_add, map_src_dist, ilon, jlat)
    return

  end subroutine horiz_interp_spherical_new
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_spherical">

  !   <OVERVIEW>
  !      Subroutine for performing the horizontal interpolation between two grids.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Subroutine for performing the horizontal interpolation between two grids. 
  !     horiz_interp_spherical_new must be called before calling this routine.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_spherical( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value)
  !   </TEMPLATE>
  !   
  !   <IN NAME="Interp" TYPE="type(horiz_interp_type)">
  !     Derived-type variable containing interpolation indices and weights.
  !     Returned by a previous call to horiz_interp_spherical_new.
  !   </IN>
  !   <IN NAME="data_in" TYPE="real, dimension(:,:)">
  !      Input data on source grid.
  !   </IN>
  !   <IN NAME="verbose" TYPE="integer, optional">
  !      flag for the amount of print output.
  !               verbose = 0, no output; = 1, min,max,means; = 2, still more
  !   </IN>
  !   <IN NAME="mask_in" TYPE="real, dimension(:,:),optional">
  !      Input mask, must be the same size as the input data. The real value of
  !      mask_in must be in the range (0.,1.). Set mask_in=0.0 for data points 
  !      that should not be used or have missing data. 
  !   </IN>
  !   <IN NAME="missing_value" TYPE="real, optional">
  !      Use the missing_value to indicate missing data.
  !   </IN>
  !   <OUT NAME="data_out" TYPE="real, dimension(:,:)">
  !      Output data on destination grid.
  !   </OUT>
  !   <OUT NAME="mask_out" TYPE="real, dimension(:,:),optional">
  !      Output mask that specifies whether data was computed.
  !   </OUT>

  subroutine horiz_interp_spherical( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value)
    type (horiz_interp_type), intent(in)        :: Interp
    real, intent(in),  dimension(:,:)           :: data_in
    real, intent(out), dimension(:,:)           :: data_out
    integer, intent(in),               optional :: verbose
    real, intent(in), dimension(:,:),  optional :: mask_in
    real, intent(out), dimension(:,:), optional :: mask_out
    real, intent(in),                  optional :: missing_value

    !--- some local variables ----------------------------------------
    real, dimension(Interp%nlon_dst, Interp%nlat_dst,size(Interp%src_dist,3)) :: wt
    real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src
    real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found
    integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose
    real    :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum
    !-----------------------------------------------------------------

    iverbose = 0;  if (present(verbose)) iverbose = verbose

    nlon_in  = Interp%nlon_src; nlat_in  = Interp%nlat_src
    nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst   

    if(size(data_in,1) .ne. nlon_in .or. size(data_in,2) .ne. nlat_in ) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: size of input array incorrect')

    if(size(data_out,1) .ne. nlon_out .or. size(data_out,2) .ne. nlat_out ) & 
         call mpp_error(FATAL,'horiz_interp_spherical_mod: size of output array incorrect')

    mask_src = 1.0; mask_dst = 1.0
    if(present(mask_in)) mask_src = mask_in

    do n=1,nlat_out
       do m=1,nlon_out
          ! neighbors are sorted nearest to farthest
          ! check nearest to see if it is a land point
          num_found = Interp%num_found(m,n) 
          if(num_found == 0 ) then
             mask_dst(m,n) = 0.0
          else          
             i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) 
             if (mask_src(i1,j1) .lt. 0.5) then
                mask_dst(m,n) = 0.0
             endif

             if(num_found .gt. 1 ) then
                i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2)
                ! compare first 2 nearest neighbors -- if they are nearly
                ! equidistant then use this mask for robustness
                if(abs(Interp%src_dist(m,n,2)-Interp%src_dist(m,n,1)) .lt. epsln) then
                   if((mask_src(i1,j1) .lt. 0.5))  mask_dst(m,n) = 0.0
                endif
             endif

             sum=0.0
             do k=1, num_found
                if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5 ) then
                   wt(m,n,k) = 0.0
                else
                   if (Interp%src_dist(m,n,k) <= epsln) then
                      wt(m,n,k) = large
                      sum = sum + large
                   else if(Interp%src_dist(m,n,k) <= Interp%max_src_dist ) then
                      wt(m,n,k) = 1.0/Interp%src_dist(m,n,k)
                      sum = sum+wt(m,n,k)
                   else
                      wt(m,n,k) = 0.0
                   endif
                endif
             enddo
             if (sum > epsln) then
                do k = 1, num_found
                   wt(m,n,k) = wt(m,n,k)/sum
                enddo
             else
                mask_dst(m,n) = 0.0
             endif
          endif
       enddo
    enddo

    data_out = 0.0
    do n=1,nlat_out
       do m=1,nlon_out
          if(mask_dst(m,n) .gt. 0.5) then
             do k=1, Interp%num_found(m,n)
                i = Interp%i_lon(m,n,k)
                j = Interp%j_lat(m,n,k)
                data_out(m,n) = data_out(m,n)+data_in(i,j)*wt(m,n,k)
             enddo
          else
             if(present(missing_value)) then
                data_out(m,n) = missing_value
             else
                data_out(m,n) = 0.0
             endif
          endif
       enddo
    enddo

    if(present(mask_out)) mask_out = mask_dst

    !***********************************************************************
    ! compute statistics: minimum, maximum, and mean
    !-----------------------------------------------------------------------

    if (iverbose > 0) then

       ! compute statistics of input data

       call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask=mask_src)

       ! compute statistics of output data
       call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask=mask_dst)

       !---- output statistics ----
       ! root_pe have the information of global mean, min and max
       if(pe == root_pe) then
          write (*,900)
          write (*,901)  min_in ,max_in, avg_in
          if (present(mask_in))  write (*,903)  miss_in
          write (*,902)  min_out,max_out,avg_out
          if (present(mask_out)) write (*,903)  miss_out
       endif
900    format (/,1x,10('-'),' output from horiz_interp ',10('-'))
901    format ('  input:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
902    format (' output:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
903    format ('          number of missing points = ',i6)

    endif

    return
  end subroutine horiz_interp_spherical
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_spherical_del">

  !   <OVERVIEW>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_spherical_new.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_spherical_new.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_spherical_del ( Interp )
  !   </TEMPLATE>

  !   <INOUT NAME="Interp" TYPE="horiz_interp_type">
  !     A derived-type variable returned by previous call
  !     to horiz_interp_spherical_new. The input variable must have
  !     allocated arrays. The returned variable will contain
  !     deallocated arrays.
  !   </INOUT>


  subroutine horiz_interp_spherical_del( Interp )

    type (horiz_interp_type), intent(inout) :: Interp

    if(associated(Interp%src_dist))  deallocate(Interp%src_dist)
    if(associated(Interp%num_found)) deallocate(Interp%num_found)
    if(associated(Interp%i_lon))     deallocate(Interp%i_lon)
    if(associated(Interp%j_lat))     deallocate(Interp%j_lat)

  end subroutine horiz_interp_spherical_del
  ! </SUBROUTINE>

  !#######################################################################


  subroutine radial_search(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map_src_ysize, &
       map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo)
    real,    intent(in),    dimension(:)   :: theta_src, phi_src
    real,    intent(in),    dimension(:,:) :: theta_dst, phi_dst
    integer, intent(in)                    :: map_src_xsize, map_src_ysize
    integer, intent(out), dimension(:,:,:) :: map_src_add
    real,    intent(out), dimension(:,:,:) :: map_src_dist
    integer, intent(inout), dimension(:,:) :: num_found
    integer, intent(in)                    :: num_neighbors
    real,    intent(in)                    :: max_src_dist
    logical, intent(in)                    :: src_is_modulo

    !---------- local variables ----------------------------------------
    integer, parameter :: max_nbrs = 50
    integer :: i, j, jj, i0, j0, n, l,i_left, i_right
    integer :: map_dst_xsize, map_dst_ysize
    integer :: i_left1, i_left2, i_right1, i_right2
    integer :: map_src_size, step, step_size, bound, bound_start, bound_end
    logical :: continue_search, result, continue_radial_search
    real    :: d, res
    !------------------------------------------------------------------
    map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2)
    map_src_size = map_src_xsize*map_src_ysize

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          continue_search=.true.
          step = 1
          step_size = sqrt(real(map_src_size) )
          do while (continue_search .and. step_size > 0)
             do while (step <= map_src_size .and. continue_search)
                ! count land points as nearest neighbors
                d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step))
                if (d <= max_src_dist) then
                   result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                        step,d, num_found(i,j), num_neighbors )
                   if (result) then
                      n = 0
                      i0 = mod(step,map_src_xsize)

                      if (i0 == 0) i0 = map_src_xsize
                      res = float(step)/float(map_src_xsize)
                      j0 = ceiling(res)
                      continue_radial_search = .true.
                      do while (continue_radial_search)
                         continue_radial_search = .false.
                         n = n+1 ! radial counter
                         if(n > max_nbrs) exit
                         ! ************** left boundary *******************************
                         i_left = i0-n
                         if (i_left <= 0) then
                            if (src_is_modulo) then
                               i_left = map_src_xsize + i_left
                            else
                               i_left = 1
                            endif
                         endif

                         do l = 0, 2*n
                            jj = j0 - n - 1 + l
                            if( jj < 0) then
                               bound = ( 1 - jj )*map_src_xsize - i_left
                            else if ( jj >= map_src_ysize ) then
                               bound = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left
                            else
                               bound = jj * map_src_xsize + i_left
                            endif

                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                         enddo

                         ! ***************************right boundary ******************************* 
                         i_right = i0+n
                         if (i_right > map_src_xsize) then
                            if (src_is_modulo) then
                               i_right = i_right - map_src_xsize
                            else
                               i_right = map_src_xsize
                            endif
                         endif

                         do l = 0, 2*n
                            jj = j0 - n - 1 + l
                            if( jj < 0) then
                               bound = ( 1 - jj )*map_src_xsize - i_right
                            else if ( jj >= map_src_ysize ) then
                               bound = ( 2*map_src_ysize - jj) * map_src_xsize - i_right

                            else
                               bound = jj * map_src_xsize + i_right
                            endif

                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                         enddo

                         ! ************************* bottom boundary **********************************
                         i_left2 = 0
                         if( i_left > i_right) then
                            i_left1 = 1
                            i_right1 = i_right
                            i_left2 = i_left
                            i_right2 = map_src_xsize
                         else
                            i_left1 = i_left
                            i_right1 = i_right                            
                         endif

                         jj = j0 - n - 1
                         if( jj < 0 ) then
                            bound_start = ( 1 - jj)*map_src_xsize - i_right1
                            bound_end   = ( 1 - jj)*map_src_xsize - i_left1
                         else
                            bound_start = jj * map_src_xsize + i_left1
                            bound_end = jj * map_src_xsize + i_right1
                         endif

                         bound = bound_start
                         do while (bound <= bound_end)
                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                            bound = bound + 1

                         enddo

                         if(i_left2 > 0 ) then
                            if( jj < 0 ) then
                               bound_start = ( 1 - jj)*map_src_xsize - i_right2
                               bound_end   = ( 1 - jj)*map_src_xsize - i_left2
                            else
                               bound_start = jj * map_src_xsize + i_left2
                               bound_end = jj * map_src_xsize + i_right2
                            endif

                            bound = bound_start
                            do while (bound <= bound_end)
                               d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                               if(d<=max_src_dist) then
                                  result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                       bound,d, num_found(i,j), num_neighbors)
                                  if (result) continue_radial_search = .true.
                               endif
                               bound = bound + 1
                            enddo
                         endif

                         ! ************************** top boundary ************************************
                         jj = j0 + n - 1
                         if( jj >= map_src_ysize) then
                            bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right1
                            bound_end   = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left1
                         else
                            bound_start = jj * map_src_xsize + i_left1
                            bound_end = jj * map_src_xsize + i_right1
                         endif

                         bound = bound_start
                         do while (bound <= bound_end)
                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                            bound = bound + 1
                         enddo

                         if(i_left2 > 0) then
                            if( jj >= map_src_ysize) then
                               bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right2
                               bound_end   = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left2
                            else
                               bound_start = jj * map_src_xsize + i_left2
                               bound_end = jj * map_src_xsize + i_right2
                            endif

                            bound = bound_start
                            do while (bound <= bound_end)
                               d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                               if(d<=max_src_dist) then
                                  result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                       bound,d, num_found(i,j), num_neighbors)
                                  if (result) continue_radial_search = .true.
                               endif
                               bound = bound + 1
                            enddo
                         endif

                      enddo
                      continue_search = .false. ! stop looking
                   endif
                endif
                step=step+step_size
             enddo ! search loop
             step = 1
             step_size = step_size/2
          enddo
       enddo
    enddo

    return

  end subroutine radial_search


  !#####################################################################

  function update_dest_neighbors(map_src_add, map_src_dist, src_add,d, num_found, min_nbrs)

    integer, intent(inout), dimension(:) :: map_src_add
    real, intent(inout),    dimension(:) :: map_src_dist
    integer, intent(in)                  :: src_add
    real, intent(in)                     :: d
    integer, intent(inout)               :: num_found
    integer, intent(in)                  :: min_nbrs

    logical :: update_dest_neighbors, already_exist = .false.

    integer :: n,m

    update_dest_neighbors = .false.

    n = 0
    NLOOP : do while ( n .le. num_found )
       n = n + 1
       DIST_CHK : if (d .le. map_src_dist(n)) then
          do m=n,num_found
             if (src_add == map_src_add(m)) then
                already_exist = .true.
                exit NLOOP
             endif
          enddo
          if(num_found < max_neighbors) then
             num_found = num_found + 1
          else
             call mpp_error(FATAL,'update_dest_neighbors: '// &
                  'number of neighbor points found is greated than maxium neighbor points' )
          endif
          do m=num_found,n+1,-1
             map_src_add(m) = map_src_add(m-1)
             map_src_dist(m) = map_src_dist(m-1)
          enddo
          map_src_add(n) = src_add
          map_src_dist(n) = d
          update_dest_neighbors = .true.
          if( num_found > min_nbrs ) then
             if( map_src_dist(num_found) > map_src_dist(num_found-1) ) then
                num_found = num_found - 1
             endif
             if( map_src_dist(min_nbrs+1) > map_src_dist(min_nbrs) ) then
                num_found = min_nbrs
             endif
          endif
          exit NLOOP ! n loop
       endif DIST_CHK
    end do NLOOP
    if(already_exist) return

    if( .not. update_dest_neighbors ) then
       if( num_found < min_nbrs ) then
          num_found               = num_found + 1
          update_dest_neighbors   = .true.
          map_src_add(num_found)  = src_add
          map_src_dist(num_found) = d
       endif
    endif


    return

  end function update_dest_neighbors

  !########################################################################
!  function spherical_distance(theta1,phi1,theta2,phi2)

!    real, intent(in) :: theta1, phi1, theta2, phi2
!    real :: spherical_distance

!    real :: r1(3), r2(3), cross(3), s, dot, ang

    ! this is a simple, enough way to calculate distance on the sphere
    ! first, construct cartesian vectors r1 and r2
    ! then calculate the cross-product which is proportional to the area
    ! between the 2 vectors.  The angular distance is arcsin of the 
    ! distancealong the sphere
    !
    ! theta is longitude and phi is latitude
    !


!    r1(1) = cos(theta1)*cos(phi1);r1(2)=sin(theta1)*cos(phi1);r1(3)=sin(phi1)
!    r2(1) = cos(theta2)*cos(phi2);r2(2)=sin(theta2)*cos(phi2);r2(3)=sin(phi2)

!    cross(1) = r1(2)*r2(3)-r1(3)*r2(2)
!    cross(2) = r1(3)*r2(1)-r1(1)*r2(3)
!    cross(3) = r1(1)*r2(2)-r1(2)*r2(1)

!    s = sqrt(cross(1)**2.+cross(2)**2.+cross(3)**2.)

!    s = min(s,1.0-epsln)

!    dot = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3)

!    if (dot > 0) then
!       ang = asin(s)
!    else if (dot < 0) then
!       ang = pi + asin(s)  !?  original is pi - asin(s)
!    else
!       ang = pi/2.
!    endif

!    spherical_distance = abs(ang) ! in radians

!    return

!  end function spherical_distance
  ! The great cycle distance
  function spherical_distance(theta1,phi1,theta2,phi2)

    real, intent(in) :: theta1, phi1, theta2, phi2
    real :: spherical_distance, dot

    if(theta1 == theta2 .and. phi1 == phi2) then
        spherical_distance = 0.0
        return
    endif
  
    dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2)
    if(dot > 1 ) dot = 1.
    if(dot < -1) dot = -1
    spherical_distance = acos(dot)

    return

  end function spherical_distance


  !#######################################################################

  subroutine full_search(theta_src,phi_src,theta_dst,phi_dst,map_src_add, map_src_dist,num_found, &
                         num_neighbors,max_src_dist)
    real,    intent(in),    dimension(:)   :: theta_src, phi_src
    real,    intent(in),    dimension(:,:) :: theta_dst, phi_dst
    integer, intent(out), dimension(:,:,:) :: map_src_add
    real,    intent(out), dimension(:,:,:) :: map_src_dist
    integer, intent(out), dimension(:,:)   :: num_found
    integer, intent(in)                    :: num_neighbors
    real, intent(in)                       :: max_src_dist

    integer :: i,j,map_src_size, step
    integer :: map_dst_xsize,map_dst_ysize
    real    :: d
    logical :: found

    map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2)
    map_src_size =size(theta_src(:))

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          do step = 1, map_src_size
             d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step))
             if( d <= max_src_dist) then
                found = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                     step,d,num_found(i,j), num_neighbors )
             endif
          enddo
       enddo
    enddo

  end subroutine full_search

  !#######################################################################


end module horiz_interp_spherical_mod


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                   !!
!!                   GNU General Public License                      !!
!!                                                                   !!
!! This file is part of the Flexible Modeling System (FMS).          !!
!!                                                                   !!
!! FMS is free software; you can redistribute it and/or modify       !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation.             !!
!!                                                                   !!
!! FMS 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 FMS; if not, write to:                                 !!
!!          Free Software Foundation, Inc.                           !!
!!          59 Temple Place, Suite 330                               !!
!!          Boston, MA  02111-1307  USA                              !!
!! or see:                                                           !!
!!          http://www.gnu.org/licenses/gpl.txt                      !!
!!                                                                   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module horiz_interp_type_mod
! <CONTACT EMAIL="Zhi.Liang@noaa.gov"> Zhi Liang </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     define derived data type that contains indices and weights used for subsequent 
!      interpolations.
! </OVERVIEW>

! <DESCRIPTION>
!     define derived data type that contains indices and weights used for subsequent 
!      interpolations.
! </DESCRIPTION>


use mpp_mod, only : mpp_send, mpp_recv, mpp_sync_self, mpp_error, FATAL
use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes

implicit none
private


! parameter to determine interpolation method
 integer, parameter :: CONSERVE = 1
 integer, parameter :: BILINEAR = 2
 integer, parameter :: SPHERICA = 3
 integer, parameter :: BICUBIC  = 4

public :: CONSERVE, BILINEAR, SPHERICA, BICUBIC
public :: horiz_interp_type, stats, assignment(=)

interface assignment(=)
  module procedure horiz_interp_type_eq
end interface

!<PUBLICTYPE >
 type horiz_interp_type
   real,    dimension(:,:), pointer   :: faci =>NULL(), facj =>NULL()   !weights for conservative scheme
   integer, dimension(:,:), pointer   :: ilon =>NULL(), jlat =>NULL()   !indices for conservative scheme
   real,    dimension(:,:), pointer   :: area_src =>NULL()              !area of the source grid
   real,    dimension(:,:), pointer   :: area_dst =>NULL()              !area of the destination grid
   real,    dimension(:,:,:), pointer :: wti =>NULL(),wtj =>NULL()      !weights for bilinear interpolation
                                                                        !wti ist used for derivative "weights" in bicubic 
   integer, dimension(:,:,:), pointer :: i_lon =>NULL(), j_lat =>NULL() !indices for bilinear interpolation 
                                                                        !and spherical regrid
   real,    dimension(:,:,:), pointer :: src_dist =>NULL()              !distance between destination grid and 
                                                                        !neighbor source grid.
   logical, dimension(:,:), pointer   :: found_neighbors =>NULL()       !indicate whether destination grid 
                                                                        !has some source grid around it.
   real                               :: max_src_dist
   integer, dimension(:,:), pointer   :: num_found => NULL()
   integer                            :: nlon_src, nlat_src !size of source grid
   integer                            :: nlon_dst, nlat_dst !size of destination grid
   integer                            :: interp_method      !interpolation method.
                                                            !=1, conservative scheme
                                                            !=2, bilinear interpolation
                                                            !=3, spherical regrid
                                                            !=4, bicubic regrid
   real,    dimension(:,:), pointer   :: rat_x =>NULL(), rat_y =>NULL() !the ratio of coordinates of the dest grid
                                                                        ! (x_dest -x_src_r)/(x_src_l -x_src_r) and (y_dest -y_src_r)/(y_src_l -y_src_r)
   real,    dimension(:), pointer     :: lon_in =>NULL(),  lat_in =>NULL()  !the coordinates of the source grid
   logical                            :: I_am_initialized=.false.
   integer                            :: version                            !indicate conservative interpolation version with value 1 or 2
   !--- The following are for conservative interpolation scheme version 2 ( through xgrid)
   integer                            :: nxgrid                             !number of exchange grid between src and dst grid.
   integer, dimension(:), pointer     :: i_src=>NULL(), j_src=>NULL()       !indices in source grid.
   integer, dimension(:), pointer     :: i_dst=>NULL(), j_dst=>NULL()       !indices in destination grid.
   real,    dimension(:), pointer     :: area_frac_dst=>NULL()              !area fraction in destination grid.
   real,    dimension(:,:), pointer   :: mask_in=>NULL() 
 end type
!</PUBLICTYPE>

contains

!#######################################################################
!---This statistics is for bilinear interpolation and spherical regrid.
 subroutine stats ( dat, low, high, avg, miss, missing_value, mask )
 real,    intent(in)  :: dat(:,:)
 real,    intent(out) :: low, high, avg
 integer, intent(out) :: miss
 real, intent(in), optional :: missing_value
 real,    intent(in), optional :: mask(:,:)

 real :: dsum, npts, buffer_real(3)
 integer :: pe, root_pe, npes, p, buffer_int(2)

   pe = mpp_pe()
   root_pe = mpp_root_pe()
   npes = mpp_npes()

   dsum = 0.0
   miss = 0

   if (present(missing_value)) then
      miss = count(dat(:,:) == missing_value)
      low  = minval(dat(:,:), dat(:,:) /= missing_value)
      high = maxval(dat(:,:), dat(:,:) /= missing_value)
      dsum = sum(dat(:,:), dat(:,:) /= missing_value)
   else if(present(mask)) then
      miss = count(mask(:,:) <= 0.5)
      low  = minval(dat(:,:),mask=mask(:,:) > 0.5)
      high = maxval(dat(:,:),mask=mask(:,:) > 0.5)
      dsum = sum(dat(:,:), mask=mask(:,:) > 0.5)
   else
      miss = 0
      low  = minval(dat(:,:))
      high = maxval(dat(:,:))
      dsum = sum(dat(:,:))
   endif
   avg = 0.0
   
   npts = size(dat(:,:)) - miss
   if(pe == root_pe) then
      do p = 1, npes - 1  ! root_pe receive data from other pe
      ! Force use of "scalar", integer pointer mpp interface
         call mpp_recv(buffer_real(1),glen=3, from_pe=p+root_pe)
         dsum = dsum + buffer_real(1)
         low  = min(low, buffer_real(2))
         high = max(high, buffer_real(3))
         call mpp_recv(buffer_int(1), glen=2, from_pe=p+root_pe)
         miss = miss + buffer_int(1)
         npts = npts + buffer_int(2)
      enddo         
      if(npts == 0) then
         print*, 'Warning: no points is valid'
      else
         avg = dsum/real(npts)
      endif
    else   ! other pe send data to the root_pe.
      buffer_real(1) = dsum
      buffer_real(2) = low
      buffer_real(3) = high
      ! Force use of "scalar", integer pointer mpp interface
      call mpp_send(buffer_real(1),plen=3,to_pe=root_pe)
      buffer_int(1) = miss
      buffer_int(2) = npts
      call mpp_send(buffer_int(1), plen=2, to_pe=root_pe)
    endif

    call mpp_sync_self()

    return

 end subroutine stats

!#################################################################################################################################
 subroutine horiz_interp_type_eq(horiz_interp_out, horiz_interp_in)
    type(horiz_interp_type), intent(inout) :: horiz_interp_out
    type(horiz_interp_type), intent(in)    :: horiz_interp_in

    if(.not.horiz_interp_in%I_am_initialized) then
      call mpp_error(FATAL,'horiz_interp_type_eq: horiz_interp_type variable on right hand side is unassigned')
    endif

    horiz_interp_out%faci            => horiz_interp_in%faci
    horiz_interp_out%facj            => horiz_interp_in%facj
    horiz_interp_out%ilon            => horiz_interp_in%ilon
    horiz_interp_out%jlat            => horiz_interp_in%jlat
    horiz_interp_out%area_src        => horiz_interp_in%area_src
    horiz_interp_out%area_dst        => horiz_interp_in%area_dst
    horiz_interp_out%wti             => horiz_interp_in%wti
    horiz_interp_out%wtj             => horiz_interp_in%wtj
    horiz_interp_out%i_lon           => horiz_interp_in%i_lon
    horiz_interp_out%j_lat           => horiz_interp_in%j_lat
    horiz_interp_out%src_dist        => horiz_interp_in%src_dist
    horiz_interp_out%found_neighbors => horiz_interp_in%found_neighbors
    horiz_interp_out%max_src_dist    =  horiz_interp_in%max_src_dist
    horiz_interp_out%num_found       => horiz_interp_in%num_found
    horiz_interp_out%nlon_src        =  horiz_interp_in%nlon_src
    horiz_interp_out%nlat_src        =  horiz_interp_in%nlat_src
    horiz_interp_out%nlon_dst        =  horiz_interp_in%nlon_dst
    horiz_interp_out%nlat_dst        =  horiz_interp_in%nlat_dst
    horiz_interp_out%interp_method   =  horiz_interp_in%interp_method
    horiz_interp_out%rat_x           => horiz_interp_in%rat_x
    horiz_interp_out%rat_y           => horiz_interp_in%rat_y
    horiz_interp_out%lon_in          => horiz_interp_in%lon_in
    horiz_interp_out%lat_in          => horiz_interp_in%lat_in
    horiz_interp_out%I_am_initialized = .true.
    horiz_interp_out%i_src           => horiz_interp_in%i_src
    horiz_interp_out%j_src           => horiz_interp_in%j_src
    horiz_interp_out%i_dst           => horiz_interp_in%i_dst
    horiz_interp_out%j_dst           => horiz_interp_in%j_dst
    horiz_interp_out%area_frac_dst   => horiz_interp_in%area_frac_dst
    if(horiz_interp_in%interp_method == CONSERVE) then
       horiz_interp_out%version =  horiz_interp_in%version
       if(horiz_interp_in%version==2) horiz_interp_out%nxgrid = horiz_interp_in%nxgrid
    end if

 end subroutine horiz_interp_type_eq
!#################################################################################################################################

end module horiz_interp_type_mod


module memutils_mod
!Author: Balaji (V.Balaji@noaa.gov)
!Various operations for memory management
!these currently include efficient methods for memory-to-memory copy
!including strided data and arbitrary gather-scatter vectors
!also various memory and cache inquiry operators
  implicit none
  private
#ifdef _CRAYT3E
  integer :: pe, shmem_my_pe
#endif

  integer(kind=8) :: l1_cache_line_size, l1_cache_size, l1_associativity
  integer(kind=8) :: l2_cache_line_size, l2_cache_size, l2_associativity

  logical :: memutils_initialized=.FALSE.

  interface memcpy
     module procedure memcpy_r8
     module procedure memcpy_r8_gather
     module procedure memcpy_r8_scatter
     module procedure memcpy_r8_gather_scatter
  end interface

  public :: get_l1_cache_line, get_l2_cache_line, memcpy, memutils_init
  public :: print_memuse_stats
#ifdef _CRAY
  public :: hplen
#endif
#ifdef _CRAYT90
  public :: stklen
#endif
  logical, private :: print_memory_usage=.FALSE.
  contains

    subroutine memutils_init(print_flag)
!initialize memutils module
!currently sets default cache characteristics
!(will provide overrides later)
!also sets pe to my_pe on t3e
      logical, optional :: print_flag
#ifdef _CRAYT3E
!all sizes in bytes
      l1_cache_line_size = 32
      l1_cache_size = 8192
      l1_associativity = 1
      l2_cache_line_size = 64
      l2_cache_size = 98304
      l2_associativity = 3
#else
!defaults
      l1_cache_line_size = 1
      l1_cache_size = 1
      l1_associativity = 1
      l2_cache_line_size = 1
      l2_cache_size = 1
      l2_associativity = 1
#endif
#ifdef _CRAYT3E
      pe = SHMEM_MY_PE()
#endif
      if( PRESENT(print_flag) )print_memory_usage = print_flag
      memutils_initialized = .TRUE.
      return
    end subroutine memutils_init

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
!MEMCPY routines: <nelems> real*8 words are copied from RHS to LHS     !
!  Either side can have constant stride (lhs_stride, rhs_stride)       !
!      or indexed by a gather/scatter array (lhs_indx, rhs_indx)       !
! index arrays are 0-based (i.e C-like not fortran-like: this is       !
! for compatibility with the SHMEM_IXGET/PUT routines)                 !
!                                                                      !
! EXAMPLES:                                                            !
!                                                                      !
!Replace                                                               !
!  a(0:n-1) = b(0:n-1)                                                 !
!with                                                                  !
!  call memcpy(a,b,n)                                                  !
!                                                                      !
!Replace                                                               !
!  a(0:2*n-1:2) = b(0:3*n-1:3)                                         !
!with                                                                  !
!  call memcpy(a,b,dim,n,2,3)    !dim.GE.3*n                           !
!                                                                      !
!Replace                                                               !
!  a(0:n-1) = b(indx(1:n))                                             !
!with                                                                  !
!  call memcpy(a,b,dim,n,1,indx) !dim.GE.max(indx)                     !
!                                                                      !
!Replace                                                               !
!  a(indx(1:n)) = b(0:n-1)                                             !
!with                                                                  !
!  call memcpy(a,b,dim,n,indx,1) !dim.GE.max(indx)                     !
!                                                                      !
!Replace                                                               !
!  a(indxa(1:n)) = b(indxb(1:n))                                       !
!with                                                                  !
!  call memcpy(a,b,dim,n,indx,indxb) !dim.GE.max(indxa,indxb)          !
!                                                                      !
!  There are no error checks!!! (routines are built for speed)         !
!  Specifically there is no bounds-checking: if the stride or          !
!  indexing causes you to exceed <dim> you will have done a            !
!  potentially unsafe memory load                                      !
!                                                                      !
!T3E: we use the shmem routines on-processor to effect the transfer    !
!     via the (faster) E-registers                                     !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    subroutine memcpy_r8( lhs, rhs, dim, nelems, lhs_stride, rhs_stride )
!base routine: handles constant stride memcpy
!default strides are of course 1
      integer, intent(in) :: dim
      real(kind=8), dimension(0:dim-1), intent(in)  :: rhs
      real(kind=8), dimension(0:dim-1), intent(out) :: lhs
      integer, intent(in), optional :: nelems, lhs_stride, rhs_stride
      integer :: n, rs, ls

!defaults
      n = dim
      ls = 1
      rs = 1
      if( PRESENT(nelems) )then
          n = nelems
!only check for stride if nelems is present
          if( PRESENT(lhs_stride) )ls = lhs_stride
          if( PRESENT(rhs_stride) )rs = rhs_stride
      endif
      if( ls.EQ.1 .AND. rs.EQ.1 )then
#ifdef _CRAYT3E
          call SHMEM_GET( lhs(0), rhs(0), n, pe )
#else
          lhs(0:n-1) = rhs(0:n-1)
#endif
      else
#ifdef _CRAYT3E
          call SHMEM_IGET( lhs(0), rhs(0), ls, rs, n, pe )
#else
          lhs(0:n*ls-1:ls) = rhs(0:n*rs-1:rs)
#endif
      endif
      return
    end subroutine memcpy_r8

    subroutine memcpy_r8_gather( lhs, rhs, dim, nelems, lhs_stride, rhs_indx )
!memcpy routine with gather: copies nelems words from rhs(indx(:)) to lhs(:)
      integer, intent(in) :: dim, nelems, lhs_stride
      real(kind=8), dimension(0:dim-1), intent(in)  :: rhs
      real(kind=8), dimension(0:dim-1), intent(out) :: lhs
      integer, intent(in), dimension(nelems) :: rhs_indx
#ifdef _CRAYT3E
!dir$ CACHE_BYPASS lhs, rhs, rhs_indx
      real(kind=8), dimension(nelems) :: tmp

      if( lhs_stride.EQ.1 )then
          call SHMEM_IXGET( lhs(0), rhs(0), rhs_indx, nelems, pe )
      else
          call SHMEM_IXGET( tmp, rhs(0), rhs_indx, nelems, pe )
          call SHMEM_IGET( lhs(0), tmp, lhs_stride, 1, nelems, pe )
      endif
#else
      lhs(0:nelems*lhs_stride-1:lhs_stride) = rhs(rhs_indx(1:nelems))
#endif
      return
    end subroutine memcpy_r8_gather

    subroutine memcpy_r8_scatter( lhs, rhs, dim, nelems, lhs_indx, rhs_stride )
!memcpy routine with scatter: copies nelems words from rhs(:) to lhs(indx(:))
      integer, intent(in) :: dim, nelems, rhs_stride
      real(kind=8), dimension(0:dim-1), intent(in)  :: rhs
      real(kind=8), dimension(0:dim-1), intent(out) :: lhs
      integer, intent(in), dimension(nelems) :: lhs_indx
#ifdef _CRAYT3E
!dir$ CACHE_BYPASS lhs, rhs, lhs_indx
      real(kind=8), dimension(nelems) :: tmp

      if( rhs_stride.EQ.1 )then
          call SHMEM_IXPUT( lhs(0), rhs(0), lhs_indx, nelems, pe )
      else
          call SHMEM_IGET( tmp, rhs(0), rhs_stride, 1, nelems, pe )
          call SHMEM_IXPUT( lhs(0), tmp, lhs_indx, nelems, pe )
      endif
      call SHMEM_QUIET          !required to ensure completion of put
#else
      lhs(lhs_indx(1:nelems)) = rhs(0:nelems*rhs_stride-1:rhs_stride)
#endif
      return
    end subroutine memcpy_r8_scatter

    subroutine memcpy_r8_gather_scatter( lhs, rhs, dim, nelems, lhs_indx, rhs_indx )
!memcpy routine with gather/scatter: copies nelems words from rhs(indx(:)) to lhs(indx(:))
      integer, intent(in) :: dim, nelems
      real(kind=8), dimension(0:dim-1), intent(in)  :: rhs
      real(kind=8), dimension(0:dim-1), intent(out) :: lhs
      integer, intent(in), dimension(nelems) :: lhs_indx, rhs_indx
#ifdef _CRAYT3E
!dir$ CACHE_BYPASS lhs, rhs, lhs_indx, rhs_indx
      real(kind=8), dimension(nelems) :: tmp

      call SHMEM_IXGET( tmp, rhs(0), rhs_indx, nelems, pe )
      call SHMEM_IXPUT( lhs(0), tmp, lhs_indx, nelems, pe )
      call SHMEM_QUIET          !required to ensure completion of put
#else
      lhs(lhs_indx(1:nelems)) = rhs(rhs_indx(1:nelems))
#endif
      return
    end subroutine memcpy_r8_gather_scatter

#ifdef _CRAY
  integer function hplen(             hpalloc, hplargest, hpshrink, hpgrow, hpfirst, hplast )
!using IHPSTAT calls from SR-2165 v2.0 p535
!with no arguments returns heap length (in words on PVP, bytes on t3e)
    integer, intent(out), optional :: hpalloc, hplargest, hpshrink, hpgrow, hpfirst, hplast
    integer :: IHPSTAT

    hplen = IHPSTAT(1)	                      !Heap length
    if( present(hpalloc  ) )hpalloc   = IHPSTAT( 4) !Blocks allocated
    if( present(hplargest) )hplargest = IHPSTAT(10) !Largest free block size
    if( present(hpshrink ) )hpshrink  = IHPSTAT(11) !Amount heap can shrink
    if( present(hpgrow   ) )hpgrow    = IHPSTAT(12) !Amount heap can grow
    if( present(hpfirst  ) )hpfirst   = IHPSTAT(13) !First word address
    if( present(hplast   ) )hplast    = IHPSTAT(14) !Last word address
    return
  end function hplen
#endif /* _CRAY */

#ifdef _CRAYT90
  integer function stklen(            stkhiwm, stknumber, stktotal, stkmost, stkgrew, stkgtimes )
!using STKSTAT(3C) struct
    integer, optional, intent(out) :: stkhiwm, stknumber, stktotal, stkmost, stkgrew, stkgtimes
    integer :: istat(20)

    call STKSTAT(istat)
    stklen = istat(1)	!Stack length
    if( present(stkhiwm  ) )stkhiwm   = istat(2) !stack hiwatermark
    if( present(stknumber) )stknumber = istat(3) !current #stacks
    if( present(stktotal ) )stktotal  = istat(4) !total #stacks
    if( present(stkmost  ) )stkmost   = istat(5) !most #stacks at one time
    if( present(stkgrew  ) )stkgrew   = istat(6) !#stacks that grew
    if( present(stkgtimes) )stkgtimes = istat(7) !#times stack grew
    return
  end function stklen
#endif /* _CRAYT90 */

!cache utilities: need to write version for other argument types
  function get_l1_cache_line(a)
    integer(kind=8) :: get_l1_cache_line
    real, intent(in) :: a
    integer(kind=8) :: i
    i = LOC(a)
    get_l1_cache_line = mod(i,l1_cache_size/l1_associativity)/l1_cache_line_size
  end function get_l1_cache_line

  function get_l2_cache_line(a)
    integer(kind=8) :: get_l2_cache_line
    real, intent(in) :: a
    integer(kind=8) :: i
    i = LOC(a)
    get_l2_cache_line = mod(i,l2_cache_size/l2_associativity)/l2_cache_line_size
  end function get_l2_cache_line

  subroutine print_memuse_stats( text, unit, always )
    use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_npes, mpp_min, mpp_max, mpp_sum, stderr
    character(len=*), intent(in) :: text
    integer, intent(in), optional :: unit
    logical, intent(in), optional :: always
    real :: m, mmin, mmax, mavg, mstd
    integer :: mu
!memuse is an external function: works on SGI
!use #ifdef to generate equivalent on other platforms.
    integer :: memuse !default integer OK?

    if( PRESENT(always) )then
        if( .NOT.always )return
    else
        if( .NOT.print_memory_usage )return
    end if
    mu = stderr(); if( PRESENT(unit) )mu = unit
#if defined(__sgi) || defined(__aix) || defined(__SX)
    m = memuse()*1e-3
#else
    call mem_dump(m)
#endif 
    mmin = m; call mpp_min(mmin)
    mmax = m; call mpp_max(mmax)
    mavg = m; call mpp_sum(mavg); mavg = mavg/mpp_npes()
    mstd = (m-mavg)**2; call mpp_sum(mstd); mstd = sqrt( mstd/mpp_npes() )
    if( mpp_pe().EQ.mpp_root_pe() )write( mu,'(a64,4es11.3)' ) &
         'Memuse(MB) at '//trim(text)//'=', mmin, mmax, mstd, mavg

    return
  end subroutine print_memuse_stats

!#######################################################################

subroutine mem_dump ( memuse )
use mpp_mod,    only : stdout
use mpp_io_mod, only : mpp_open, mpp_close, mpp_ascii, mpp_rdonly,     &
                       mpp_sequential, mpp_single

real, intent(out) :: memuse

! This routine returns the memory usage on Linux systems.
! It does this by querying a system file (file_name below).
! It is intended for use by print_memuse_stats above.

character(len=32) :: file_name = '/proc/self/status'
character(len=32) :: string
integer :: mem_unit
real    :: multiplier

  memuse = 0.0
  multiplier = 1.0

  call mpp_open ( mem_unit, file_name,                                 &
                      form=MPP_ASCII,        action=MPP_RDONLY,        &
                      access=MPP_SEQUENTIAL, threading=MPP_SINGLE )
  
  do; read (mem_unit,'(a)', end=10) string
    if ( INDEX ( string, 'VmHWM:' ) == 1 ) then
      read (string(7:LEN_TRIM(string)-2),*) memuse
      exit
    endif
  enddo
  
  if (TRIM(string(LEN_TRIM(string)-1:)) == "kB" ) &
    multiplier = 1.0/1024. ! Convert from kB to MB

10 call mpp_close ( mem_unit )
   memuse = memuse * multiplier

  return
end subroutine mem_dump

end module memutils_mod


module gradient_mod
! <CONTACT EMAIL="Zhi.Liang@noaa.gov">
!   Zhi Liang
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!    <TT>gradient_mod</TT> implements some utility routines to calculate gradient.
! </OVERVIEW>

! <DESCRIPTION>
!    <TT>gradient_mod</TT> implements some utility routines to calculate gradient.
!    Currently only gradient on cubic grid is implemented. Also a public interface 
!    is provided to calculate grid information needed to calculate gradient.

use mpp_mod,       only : mpp_error, FATAL
use constants_mod, only : RADIUS

implicit none
private


public :: gradient_cubic
public :: calc_cubic_grid_info

character(len=128) :: version = '$Id: gradient.F90,v 16.0 2008/07/30 22:46:00 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains


!#####################################################################
!  NOTe: pin has halo size = 1.
!  the size of pin    will be (nx+2,ny+2), T-cell center, with halo = 1
!  the size of dx     will be (nx, ny+1),  N-cell center
!  the size of dy     will be (nx+1, ny),  E-cell center
!  the size of area   will be (nx, ny),    T-cell center.
!  The size of edge_w will be (ny+1),      C-cell center
!  The size of edge_e will be (ny+1),      C-cell center
!  The size of edge_s will be (nx+1),      C-cell center
!  The size of edge_n will be (nx+1),      C-cell center
!  The size of en_n   will be (3,nx,ny+1), N-cell center
!  The size of en_e   will be (3,nx+1,ny), E-cell center
!  The size of vlon   will be (3,nx, ny)   T-cell center
!  The size of vlat   will be (3,nx, ny),  T-cell center

subroutine gradient_cubic(pin, dx, dy, area, edge_w, edge_e, edge_s, edge_n,    &
                          en_n, en_e, vlon, vlat, grad_x, grad_y, on_west_edge, &
                          on_east_edge, on_south_edge, on_north_edge)

  real,    dimension(:,:  ), intent(in ) :: pin, dx, dy, area
  real,    dimension(:    ), intent(in ) :: edge_w, edge_e, edge_s, edge_n
  real,    dimension(:,:,:), intent(in ) :: en_n, en_e
  real,    dimension(:,:,:), intent(in ) :: vlon, vlat
  real,    dimension(:,:  ), intent(out) :: grad_x, grad_y
  logical,                   intent(in ) :: on_west_edge, on_east_edge, on_south_edge, on_north_edge
  integer :: nx, ny


  nx = size(grad_x,1)
  ny = size(grad_x,2)

  if(size(pin,1) .NE. nx+2 .OR. size(pin,2) .NE. ny+2)call mpp_error(FATAL, "gradient_mod:size of pin should be (nx+2, ny+2)")
  if(size(dx,1) .NE. nx .OR. size(dx,2) .NE. ny+1 ) call mpp_error(FATAL, "gradient_mod: size of dx should be (nx,ny+1)")
  if(size(dy,1) .NE. nx+1 .OR. size(dy,2) .NE. ny ) call mpp_error(FATAL, "gradient_mod: size of dy should be (nx+1,ny)")
  if(size(area,1) .NE. nx .OR. size(area,2) .NE. ny ) call mpp_error(FATAL, "gradient_mod: size of area should be (nx,ny)")
  if(size(vlon,1) .NE. 3 .OR. size(vlon,2) .NE. nx .OR. size(vlon,3) .NE. ny) &
          call mpp_error(FATAL, "gradient_mod: size of vlon should be (3,nx,ny)")
  if(size(vlat,1) .NE. 3 .OR. size(vlat,2) .NE. nx .OR. size(vlat,3) .NE. ny) &
          call mpp_error(FATAL, "gradient_mod: size of vlat should be (3,nx,ny)")
  if(size(edge_w) .NE. ny+1) call mpp_error(FATAL, "gradient_mod: size of edge_w should be (ny+1)")
  if(size(edge_e) .NE. ny+1) call mpp_error(FATAL, "gradient_mod: size of edge_e should be (ny+1)")
  if(size(edge_s) .NE. nx+1) call mpp_error(FATAL, "gradient_mod: size of edge_s should be (nx+1)")
  if(size(edge_n) .NE. nx+1) call mpp_error(FATAL, "gradient_mod: size of edge_n should be (nx+1)")
  if(size(en_n,1) .NE. 3 .OR. size(en_n,2) .NE. nx .OR.  size(en_n,3) .NE. ny+1 ) &
       call mpp_error(FATAL, "gradient_mod:size of en_n should be (3, nx, ny+1)")
  if(size(en_e,1) .NE. 3 .OR. size(en_e,2) .NE. nx+1 .OR.  size(en_e,3) .NE. ny ) &
       call mpp_error(FATAL, "gradient_mod:size of en_e should be (3, nx+1, ny)")

  call grad_c2l(nx, ny, pin, dx, dy, area, edge_w, edge_e, edge_s, edge_n, en_n, en_e, vlon, vlat, &
                grad_x, grad_y, on_west_edge, on_east_edge, on_south_edge, on_north_edge)

  return

end subroutine gradient_cubic


subroutine calc_cubic_grid_info(xt, yt, xc, yc, dx, dy, area, edge_w, edge_e, edge_s, edge_n, &
                           en_n, en_e, vlon, vlat, on_west_edge, on_east_edge, on_south_edge, on_north_edge )
  real,    dimension(:,:  ), intent(in ) :: xt, yt, xc, yc
  real,    dimension(:,:  ), intent(out) :: dx, dy, area
  real,    dimension(:    ), intent(out) :: edge_w, edge_e, edge_s, edge_n
  real,    dimension(:,:,:), intent(out) :: en_n, en_e
  real,    dimension(:,:,:), intent(out) :: vlon, vlat
  logical,                   intent(in ) :: on_west_edge, on_east_edge, on_south_edge, on_north_edge
  integer :: nx, ny, nxp, nyp


  nx  = size(area,1)
  ny  = size(area,2)
  nxp = nx+1
  nyp = ny+1

  if(size(xt,1) .NE. nx+2 .OR. size(xt,2) .NE. ny+2 ) call mpp_error(FATAL, "gradient_mod: size of xt should be (nx+2,ny+2)")
  if(size(yt,1) .NE. nx+2 .OR. size(yt,2) .NE. ny+2 ) call mpp_error(FATAL, "gradient_mod: size of yt should be (nx+2,ny+2)")
  if(size(xc,1) .NE. nxp .OR. size(xc,2) .NE. nyp ) call mpp_error(FATAL, "gradient_mod: size of xc should be (nx+1,ny+1)")
  if(size(yc,1) .NE. nxp .OR. size(yc,2) .NE. nyp ) call mpp_error(FATAL, "gradient_mod: size of yc should be (nx+1,ny+1)")
  if(size(dx,1) .NE. nx .OR. size(dx,2) .NE. nyp ) call mpp_error(FATAL, "gradient_mod: size of dx should be (nx,ny+1)")
  if(size(dy,1) .NE. nxp .OR. size(dy,2) .NE. ny ) call mpp_error(FATAL, "gradient_mod: size of dy should be (nx+1,ny)")
  if(size(area,1) .NE. nx .OR. size(area,2) .NE. ny ) call mpp_error(FATAL, "gradient_mod: size of area should be (nx,ny)")
  if(size(vlon,1) .NE. 3 .OR. size(vlon,2) .NE. nx .OR. size(vlon,3) .NE. ny) &
          call mpp_error(FATAL, "gradient_mod: size of vlon should be (3,nx,ny)")
  if(size(vlat,1) .NE. 3 .OR. size(vlat,2) .NE. nx .OR. size(vlat,3) .NE. ny) &
          call mpp_error(FATAL, "gradient_mod: size of vlat should be (3,nx,ny)")
  if(size(edge_w) .NE. ny+1) call mpp_error(FATAL, "gradient_mod: size of edge_w should be (ny-1)")
  if(size(edge_e) .NE. ny+1) call mpp_error(FATAL, "gradient_mod: size of edge_e should be (ny-1)")
  if(size(edge_s) .NE. nx+1) call mpp_error(FATAL, "gradient_mod: size of edge_s should be (nx-1)")
  if(size(edge_n) .NE. nx+1) call mpp_error(FATAL, "gradient_mod: size of edge_n should be (nx-1)")
  if(size(en_n,1) .NE. 3 .OR. size(en_n,2) .NE. nx .OR.  size(en_n,3) .NE. nyp ) &
       call mpp_error(FATAL, "gradient_mod:size of en_n should be (3, nx, ny+1)")
  if(size(en_e,1) .NE. 3 .OR. size(en_e,2) .NE. nxp .OR.  size(en_e,3) .NE. ny ) &
       call mpp_error(FATAL, "gradient_mod:size of en_e should be (3, nx+1, ny)")


  call calc_c2l_grid_info(nx, ny, xt, yt, xc, yc, dx, dy, area, edge_w, edge_e, edge_s, edge_n, &
                          en_n, en_e, vlon, vlat, on_west_edge, on_east_edge, on_south_edge, on_north_edge )


  return

end subroutine calc_cubic_grid_info

end module gradient_mod


module grid_mod

use mpp_mod, only : mpp_root_pe
use constants_mod, only : PI, radius
use fms_mod, only : uppercase, lowercase, field_exist, field_size, read_data, &
     error_mesg, string, FATAL, NOTE
use mosaic_mod, only : get_mosaic_ntiles, get_mosaic_xgrid_size, get_mosaic_grid_sizes, &
     get_mosaic_xgrid, calc_mosaic_grid_area

! the following two use statement are only needed for define_cube_mosaic
use mpp_domains_mod, only : domain2d, mpp_define_mosaic, mpp_get_compute_domain, &
                            mpp_get_global_domain
use mosaic_mod, only : get_mosaic_ncontacts, get_mosaic_contact

implicit none;private

! ==== public interfaces =====================================================
! grid dimension inquiry subroutines
public :: get_grid_ntiles ! returns number of tiles
public :: get_grid_size   ! returns horizontal sizes of the grid
! grid geometry inquiry subroutines
public :: get_grid_cell_centers 
public :: get_grid_cell_vertices
! grid area inquiry subroutines
public :: get_grid_cell_area
public :: get_grid_comp_area
! decompose cubed sphere domains -- probably does not belong here, but it should 
! be in some place available for component models
public :: define_cube_mosaic
! ==== end of public interfaces ==============================================

interface get_grid_size
   module procedure get_grid_size_for_all_tiles
   module procedure get_grid_size_for_one_tile
end interface

interface get_grid_cell_vertices
   module procedure get_grid_cell_vertices_1D
   module procedure get_grid_cell_vertices_2D
end interface

interface get_grid_cell_centers
   module procedure get_grid_cell_centers_1D
   module procedure get_grid_cell_centers_2D
end interface

! ==== module constants ======================================================
character(len=*), parameter :: &
     module_name = 'grid_mod', &
     version     = '$Id: grid.F90,v 17.0.4.1.2.1.2.3 2010/08/19 14:19:39 z1l Exp $', &
     tagname     = '$Name: hiram_20101115_bw $'

character(len=*), parameter :: &
     grid_dir  = 'INPUT/',     &      ! root directory for all grid files
     grid_file = 'INPUT/grid_spec.nc' ! name of the grid spec file

integer, parameter :: &
     MAX_NAME = 256,  & ! max length of the variable names
     MAX_FILE = 1024, & ! max length of the file names
     VERSION_0 = 0,   &
     VERSION_1 = 1,   &
     VERSION_2 = 2

! ==== module variables ======================================================
integer :: grid_version = -1

contains 

function get_grid_version()
  integer :: get_grid_version
  if(grid_version<0) then
    if(field_exist(grid_file, 'geolon_t')) then
       grid_version = VERSION_0 
    else if(field_exist(grid_file, 'x_T')) then
       grid_version = VERSION_1
    else if(field_exist(grid_file, 'ocn_mosaic_file') ) then
       grid_version = VERSION_2
    else
       call error_mesg(module_name//'/get_grid_version',&
            'Can''t determine the version of the grid spec: none of "x_T", "geolon_t", or "ocn_mosaic_file" exist in file "'//trim(grid_file)//'"', &
            FATAL )
    endif
  endif
  get_grid_version = grid_version
end function get_grid_version


! ============================================================================
! returns number of tiles for a given component
! ============================================================================
subroutine get_grid_ntiles(component,ntiles)
  character(len=*)     :: component
  integer, intent(out) :: ntiles

  ! local vars
  character(len=MAX_FILE) :: component_mosaic

  select case (get_grid_version())
  case(VERSION_0,VERSION_1)
     ntiles = 1
  case(VERSION_2)
     call read_data(grid_file,trim(lowercase(component))//'_mosaic_file',component_mosaic)
     ntiles = get_mosaic_ntiles(grid_dir//trim(component_mosaic))
  end select
end subroutine get_grid_ntiles


! ============================================================================
! returns size of the grid for each of the tiles
! ============================================================================
subroutine get_grid_size_for_all_tiles(component,nx,ny)
  character(len=*)     :: component
  integer, intent(inout) :: nx(:),ny(:)

  ! local vars
  integer :: siz(4) ! for the size of external fields
  character(len=MAX_NAME) :: varname1, varname2
  character(len=MAX_FILE) :: component_mosaic
  
  varname1 = 'AREA_'//trim(uppercase(component))
  varname2 = trim(lowercase(component))//'_mosaic_file'

  select case (get_grid_version())
  case(VERSION_0,VERSION_1)
     call field_size(grid_file, varname1, siz)
     nx(1) = siz(1); ny(1)=siz(2)
  case(VERSION_2) ! mosaic file
     call read_data(grid_file,varname2, component_mosaic)
     call get_mosaic_grid_sizes(grid_dir//trim(component_mosaic),nx,ny)
  end select
end subroutine get_grid_size_for_all_tiles


! ============================================================================
! returns size of the grid for one of the tiles
! ============================================================================
subroutine get_grid_size_for_one_tile(component,tile,nx,ny)
  character(len=*)       :: component
  integer, intent(in)    :: tile
  integer, intent(inout) :: nx,ny
  
  ! local vars
  integer, allocatable :: nnx(:), nny(:)
  integer :: ntiles

  call get_grid_ntiles(component, ntiles)
  if(tile>0.and.tile<=ntiles) then
     allocate(nnx(ntiles),nny(ntiles))
     call get_grid_size_for_all_tiles(component,nnx,nny)
     nx = nnx(tile); ny = nny(tile)
     deallocate(nnx,nny)
  else
     call error_mesg('get_grid_size',&
          'requested tile index '//trim(string(tile))//' is out of bounds (1:'//trim(string(ntiles))//')',&
          FATAL)
  endif
end subroutine get_grid_size_for_one_tile

! ============================================================================
! return grid cell area for the specified model component and tile
! ============================================================================
subroutine get_grid_cell_area(component, tile, cellarea, domain)
  character(len=*), intent(in)    :: component
  integer         , intent(in)    :: tile
  real            , intent(inout) :: cellarea(:,:)
  type(domain2d)  , intent(in), optional :: domain

  ! local vars
  integer :: nlon, nlat
  real, allocatable :: glonb(:,:), glatb(:,:)

  select case(get_grid_version())
  case(VERSION_0,VERSION_1)
     select case(trim(component))
     case('LND')
        call read_data(grid_file, 'AREA_LND_CELL', cellarea, &
            no_domain=.not.present(domain), domain=domain)
     case('ATM','OCN')
        call read_data(grid_file, 'AREA_'//trim(uppercase(component)),cellarea,&
            no_domain=.not.present(domain),domain=domain)
     case default
        call error_mesg(module_name//'/get_grid_cell_area',&
             'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
             FATAL)
     end select
     ! convert area to m2
     cellarea = cellarea*4*PI*radius**2
  case(VERSION_2)
     if (present(domain)) then
        call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat)
     else
        call get_grid_size(component,tile,nlon,nlat)
     endif
     allocate(glonb(nlon+1,nlat+1),glatb(nlon+1,nlat+1))
     call get_grid_cell_vertices(component, tile, glonb, glatb, domain)
     call calc_mosaic_grid_area(glonb*pi/180.0, glatb*pi/180.0, cellarea)
     deallocate(glonb,glatb)
  end select

end subroutine get_grid_cell_area


! ============================================================================
! get the area of the component per grid cell
! ============================================================================
subroutine get_grid_comp_area(component,tile,area,domain)
  character(len=*) :: component
  integer, intent(in) :: tile
  real, intent(inout) :: area(:,:)
  type(domain2d), intent(in), optional :: domain
  ! local vars
  integer :: n_xgrid_files ! number of exchange grid files in the mosaic
  integer :: siz(4), nxgrid
  integer :: i,j,m,n
  integer, allocatable :: i1(:), j1(:), i2(:), j2(:)
  real, allocatable :: xgrid_area(:)
  real, allocatable :: rmask(:,:)
  character(len=MAX_NAME) :: &
     xgrid_name, & ! name of the variable holding xgrid names
     tile_name,  & ! name of the tile
     xgrid_file, & ! name of the current xgrid file
     mosaic_name   ! name of the mosaic
  character(len=MAX_NAME) :: varname1, varname2
  integer :: is,ie,js,je ! boundaries of our domain
  integer :: i0, j0 ! offsets for x and y, respectively

  select case (get_grid_version())
  case(VERSION_0,VERSION_1)
     select case(component)
     case('ATM')
        call read_data(grid_file,'AREA_ATM',area, no_domain=.not.present(domain),domain=domain)
     case('OCN')
        allocate(rmask(size(area,1),size(area,2)))
        call read_data(grid_file,'AREA_OCN',area, no_domain=.not.present(domain),domain=domain)
        call read_data(grid_file,'wet',     rmask,no_domain=.not.present(domain),domain=domain)
        area = area*rmask
        deallocate(rmask)
     case('LND')
        call read_data(grid_file,'AREA_LND',area,no_domain=.not.present(domain),domain=domain)
     case default
        call error_mesg(module_name//'/get_grid_comp_area',&
             'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
             FATAL)
     end select
  case(VERSION_2) ! mosaic gridspec
     select case (component)
     case ('ATM')
        ! just read the grid cell area and return
        call get_grid_cell_area(component,tile,area)
        return
     case ('LND')
        xgrid_name = 'aXl_file'
        call read_data(grid_file, 'lnd_mosaic', mosaic_name)
        tile_name  = trim(mosaic_name)//'_tile'//char(tile+ichar('0'))
     case ('OCN')
        xgrid_name = 'aXo_file'
        call read_data(grid_file, 'ocn_mosaic', mosaic_name)
        tile_name  = trim(mosaic_name)//'_tile'//char(tile+ichar('0'))
     case default
        call error_mesg(module_name//'/get_grid_comp_area',&
             'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
             FATAL)
     end select
     ! get the boundaries of the requested domain
     if(present(domain)) then
        call mpp_get_compute_domain(domain,is,ie,js,je)
        i0 = 1-is ; j0=1-js
     else
        call get_grid_size(component,tile,ie,je)
        is = 1 ; i0 = 0
        js = 1 ; j0 = 0
     endif
     if (size(area,1)/=ie-is+1.or.size(area,2)/=je-js+1) &
        call error_mesg(module_name//'/get_grid_comp_area',&
        'size of the output argument "area" is not consistent with the domain',FATAL) 

     area(:,:) = 0
     if(field_exist(grid_file,xgrid_name)) then
        ! get the number of the exchange-grid files
        call field_size(grid_file,xgrid_name,siz)
        n_xgrid_files = siz(2)
        ! loop through all exchange grid files
        do n = 1, n_xgrid_files
           ! get the name of the current exchange grid file
           call read_data(grid_file,xgrid_name,xgrid_file,level=n)
           ! skip the rest of the loop if the name of the current tile isn't found 
           ! in the file name, but check this only if there is more than 1 tile
           if(n_xgrid_files>1) then
              if(index(xgrid_file,trim(tile_name))==0) cycle
           endif
           ! finally read the exchange grid
           nxgrid = get_mosaic_xgrid_size(grid_dir//xgrid_file)
           allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area(nxgrid))
           call get_mosaic_xgrid(grid_dir//xgrid_file, i1, j1, i2, j2, xgrid_area)
           ! and sum the exchange grid areas
           do m = 1, nxgrid
              i = i2(m); j = j2(m)
              if (i<is.or.i>ie) cycle
              if (j<js.or.j>je) cycle
              area(i+i0,j+j0) = area(i+i0,j+j0) + xgrid_area(m)
           end do
           deallocate(i1, j1, i2, j2, xgrid_area)
        enddo
     endif
  end select ! version
  ! convert area to m2
  area = area*4*PI*radius**2
end subroutine

! ============================================================================
! returns arrays of global grid cell boundaries for given model component and 
! mosaic tile number.
! NOTE that in case of non-lat-lon grid the returned coordinates may have be not so 
! meaningful, by the very nature of such grids. But presumably these 1D coordinate 
! arrays are good enough for diag axis and such.
! ============================================================================
subroutine get_grid_cell_vertices_1D(component, tile, glonb, glatb)
  character(len=*), intent(in) :: component
  integer,          intent(in) :: tile
  real,          intent(inout) :: glonb(:),glatb(:)

  integer                      :: nlon, nlat
  integer                      :: start(4), nread(4)
  real, allocatable            :: tmp(:,:)
  character(len=MAX_FILE)      :: filename1, filename2

  call get_grid_size_for_one_tile(component, tile, nlon, nlat)
  if (size(glonb(:))/=nlon+1) &
       call error_mesg ( module_name//'/get_grid_cell_vertices_1D',&
       'Size of argument "glonb" is not consistent with the grid size',FATAL)
  if (size(glatb(:))/=nlat+1) &
       call error_mesg ( module_name//'/get_grid_cell_vertices_1D',&
       'Size of argument "glatb" is not consistent with the grid size',FATAL)
  if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then
     call error_mesg(module_name//'/get_grid_cell_vertices_1D',&
          'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
          FATAL)     
  endif

  select case(get_grid_version())
  case(VERSION_0)
     select case(trim(component))
     case('ATM','LND')
        call read_data(grid_file, 'xb'//lowercase(component(1:1)), glonb, no_domain=.true.)
        call read_data(grid_file, 'yb'//lowercase(component(1:1)), glatb, no_domain=.true.)
     case('OCN')
        call read_data(grid_file, "gridlon_vert_t", glonb, no_domain=.true.) 
        call read_data(grid_file, "gridlat_vert_t", glatb, no_domain=.true.) 
     end select
  case(VERSION_1)
     select case(trim(component))
     case('ATM','LND')
        call read_data(grid_file, 'xb'//lowercase(component(1:1)), glonb, no_domain=.true.)
        call read_data(grid_file, 'yb'//lowercase(component(1:1)), glatb, no_domain=.true.)
     case('OCN')
        call error_mesg(module_name//'/get_grid_cell_vertices_1D',&
           'reading of OCN grid vertices from VERSION_1 grid specs is not implemented', FATAL)
     end select
  case(VERSION_2)
     ! get the name of the mosaic file for the component
     call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1)
     filename1=grid_dir//trim(filename1)
     ! get the name of the grid file for the component and tile
     call read_data(filename1, 'gridfiles', filename2, level=tile)
     filename2 = grid_dir//trim(filename2)

     start = 1; nread = 1
     nread(1) = 2*nlon+1
     allocate( tmp(2*nlon+1,1) )
     call read_data(filename2, "x", tmp, start, nread, no_domain=.TRUE.)
     glonb(1:nlon+1) = tmp(1:2*nlon+1:2,1)
     deallocate(tmp)
     allocate(tmp(1,2*nlat+1))

     start = 1; nread = 1
     nread(2) = 2*nlat+1
     call read_data(filename2, "x", tmp, start, nread, no_domain=.TRUE.)
     glatb(1:nlat+1) = tmp(1,1:2*nlat+1:2)
     deallocate(tmp)
  end select

end subroutine get_grid_cell_vertices_1D

! ============================================================================
! returns cell vertices for the specified model component and mosaic tile number
! ============================================================================
subroutine get_grid_cell_vertices_2D(component, tile, lonb, latb, domain)
  character(len=*),         intent(in) :: component
  integer,                  intent(in) :: tile
  real,                  intent(inout) :: lonb(:,:),latb(:,:)
  type(domain2d), optional, intent(in) :: domain

  ! local vars
  character(len=MAX_FILE) :: filename1, filename2
  integer :: nlon, nlat
  integer :: i,j
  real, allocatable :: buffer(:), tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:)
  integer :: is,ie,js,je ! boundaries of our domain
  integer :: i0,j0 ! offsets for coordinates
  integer :: isg, jsg
  integer :: start(4), nread(4)

  call get_grid_size_for_one_tile(component, tile, nlon, nlat)
  if (present(domain)) then
    call mpp_get_compute_domain(domain,is,ie,js,je)
  else
    is = 1 ; ie = nlon
    js = 1 ; je = nlat
    !--- domain normally should be present
    call error_mesg ( module_name//'/get_grid_cell_vertices',&
       'domain is not present, global data will be read', NOTE)
  endif
  i0 = -is+1; j0 = -js+1
  
  ! verify that lonb and latb sizes are consistent with the size of domain
  if (size(lonb,1)/=ie-is+2.or.size(lonb,2)/=je-js+2) &
       call error_mesg ( module_name//'/get_grid_cell_vertices',&
       'Size of argument "lonb" is not consistent with the domain size',FATAL)
  if (size(latb,1)/=ie-is+2.or.size(latb,2)/=je-js+2) &
       call error_mesg ( module_name//'/get_grid_cell_vertices',&
       'Size of argument "latb" is not consistent with the domain size',FATAL)
  if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then
     call error_mesg(module_name//'/get_grid_cell_vertices',&
          'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
          FATAL)  
  endif

  select case(get_grid_version())
  case(VERSION_0)
     select case(component)
     case('ATM','LND')
        allocate(buffer(max(nlon,nlat)+1))
        ! read coordinates of grid cell vertices
        call read_data(grid_file, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1), no_domain=.true.)
        do j = js, je+1
           do i = is, ie+1
              lonb(i+i0,j+j0) = buffer(i)
           enddo
        enddo
        call read_data(grid_file, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1), no_domain=.true.)
        do j = js, je+1
           do i = is, ie+1
              latb(i+i0,j+j0) = buffer(j)
           enddo
        enddo
        deallocate(buffer)
     case('OCN')
        !!!!!! ERROR: this is not going to work when domain is present, because the size of the
        ! domain is smaller by 1 then the size of the vertices array
        if (present(domain)) &
           call error_mesg(module_name//'/get_grid_cell_vertices',&
           'reading of OCN grid vertices from VERSION_0 grid specs for non-global domain is not implemented', FATAL)
        call read_data(grid_file, 'geolon_vert_t', lonb, no_domain=.not.present(domain), domain=domain )
        call read_data(grid_file, 'geolat_vert_t', latb, no_domain=.not.present(domain), domain=domain )
     end select
  case(VERSION_1)
     select case(component)
     case('ATM','LND')
        allocate(buffer(max(nlon,nlat)+1))
        ! read coordinates of grid cell vertices
        call read_data(grid_file, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1), no_domain=.true.)
        do j = js, je+1
           do i = is, ie+1
              lonb(i+i0,j+j0) = buffer(i)
           enddo
        enddo
        call read_data(grid_file, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1), no_domain=.true.)
        do j = js, je+1
           do i = is, ie+1
              latb(i+i0,j+j0) = buffer(j)
           enddo
        enddo
        deallocate(buffer)
     case('OCN')
        nlon=ie-is+1; nlat=je-js+1
        allocate (x_vert_t(nlon,nlat,4), y_vert_t(nlon,nlat,4) ) 
        call read_data(grid_file, 'x_vert_T', x_vert_t, no_domain=.not.present(domain), domain=domain )
        call read_data(grid_file, 'y_vert_T', y_vert_t, no_domain=.not.present(domain), domain=domain )
        lonb(1:nlon,1:nlat) = x_vert_t(1:nlon,1:nlat,1)
        lonb(nlon+1,1:nlat) = x_vert_t(nlon,1:nlat,2)
        lonb(1:nlon,nlat+1) = x_vert_t(1:nlon,nlat,4)
        lonb(nlon+1,nlat+1) = x_vert_t(nlon,nlat,3)
        latb(1:nlon,1:nlat) = y_vert_t(1:nlon,1:nlat,1)
        latb(nlon+1,1:nlat) = y_vert_t(nlon,1:nlat,2)
        latb(1:nlon,nlat+1) = y_vert_t(1:nlon,nlat,4)
        latb(nlon+1,nlat+1) = y_vert_t(nlon,nlat,3)
        deallocate(x_vert_t, y_vert_t)
     end select
  case(VERSION_2)
     ! get the name of the mosaic file for the component
     call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1)
     filename1=grid_dir//trim(filename1)
     ! get the name of the grid file for the component and tile
     call read_data(filename1, 'gridfiles', filename2, level=tile)
     filename2 = grid_dir//trim(filename2)
     if(PRESENT(domain)) then
        call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg)
        start = 1; nread = 1
        start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3
        start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3
        allocate(tmp(nread(1), nread(2)) )
        call read_data(filename2, 'x', tmp, start, nread, no_domain=.TRUE.)
        do j = 1, je-js+2
           do i = 1, ie-is+2
              lonb(i,j) = tmp(2*i-1,2*j-1)
           enddo
        enddo
        call read_data(filename2, 'y', tmp, start, nread, no_domain=.TRUE.)
        do j = 1, je-js+2
           do i = 1, ie-is+2
              latb(i,j) = tmp(2*i-1,2*j-1)
           enddo
        enddo        
     else
        allocate(tmp(2*nlon+1,2*nlat+1))
        call read_data(filename2, 'x', tmp, no_domain=.TRUE.)
        do j = js, je+1
           do i = is, ie+1
              lonb(i+i0,j+j0) = tmp(2*i-1,2*j-1)
           end do
        end do
        call read_data(filename2, 'y', tmp, no_domain=.TRUE.)
        do j = js, je+1
           do i = is, ie+1
              latb(i+i0,j+j0) = tmp(2*i-1,2*j-1)
           end do
        end do
     endif
     deallocate(tmp)
  end select

end subroutine get_grid_cell_vertices_2D

! ============================================================================
! returns global coordinate arrays fro given model component and mosaic tile number
! NOTE that in case of non-lat-lon grid those coordinates may have be not so 
! meaningful, by the very nature of such grids. But presumably these 1D coordinate 
! arrays are good enough for diag axis and such.
! ============================================================================
subroutine get_grid_cell_centers_1D(component, tile, glon, glat)
  character(len=*), intent(in) :: component
  integer, intent(in) :: tile
  real, intent(inout) :: glon(:),glat(:)
  integer                      :: nlon, nlat
  integer                      :: start(4), nread(4)
  real, allocatable            :: tmp(:,:)
  character(len=MAX_FILE)      :: filename1, filename2

  call get_grid_size_for_one_tile(component, tile, nlon, nlat)
  if (size(glon(:))/=nlon) &
       call error_mesg ( module_name//'/get_grid_cell_centers_1D',&
       'Size of argument "glon" is not consistent with the grid size',FATAL)
  if (size(glat(:))/=nlat) &
       call error_mesg ( module_name//'/get_grid_cell_centers_1D',&
       'Size of argument "glat" is not consistent with the grid size',FATAL)
  if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then
     call error_mesg(module_name//'/get_grid_cell_centers_1D',&
          'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
          FATAL)     
  endif

  select case(get_grid_version())
  case(VERSION_0)
     select case(trim(component))
     case('ATM','LND')
        call read_data(grid_file, 'xt'//lowercase(component(1:1)), glon, no_domain=.true.)
        call read_data(grid_file, 'yt'//lowercase(component(1:1)), glat, no_domain=.true.)
     case('OCN')
        call read_data(grid_file, "gridlon_t", glon, no_domain=.true.) 
        call read_data(grid_file, "gridlat_t", glat, no_domain=.true.)
     end select 
  case(VERSION_1)
     select case(trim(component))
     case('ATM','LND')
        call read_data(grid_file, 'xt'//lowercase(component(1:1)), glon, no_domain=.true.)
        call read_data(grid_file, 'yt'//lowercase(component(1:1)), glat, no_domain=.true.)
     case('OCN')
        call read_data(grid_file, "grid_x_T", glon, no_domain=.true.) 
        call read_data(grid_file, "grid_y_T", glat, no_domain=.true.) 
     end select
  case(VERSION_2)
     ! get the name of the mosaic file for the component
     call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1)
     filename1=grid_dir//trim(filename1)
     ! get the name of the grid file for the component and tile
     call read_data(filename1, 'gridfiles', filename2, level=tile)
     filename2 = grid_dir//trim(filename2)

     start = 1; nread = 1
     nread(1) = 2*nlon+1; start(2) = 2
     allocate( tmp(2*nlon+1,1) )
     call read_data(filename2, "x", tmp, start, nread, no_domain=.TRUE.)
     glon(1:nlon) = tmp(2:2*nlon:2,1)
     deallocate(tmp)
     allocate(tmp(1, 2*nlat+1))

     start = 1; nread = 1
     nread(2) = 2*nlat+1; start(1) = 2
     call read_data(filename2, "y", tmp, start, nread, no_domain=.TRUE.)
     glat(1:nlat) = tmp(1,2:2*nlat:2)
     deallocate(tmp)
  end select

  
end subroutine get_grid_cell_centers_1D

! ============================================================================
! returns grid cell centers for specified model component and mosaic tile number
! ============================================================================
subroutine get_grid_cell_centers_2D(component, tile, lon, lat, domain)
  character(len=*), intent(in) :: component
  integer, intent(in) :: tile
  real, intent(inout) :: lon(:,:),lat(:,:)
  type(domain2d), intent(in), optional :: domain
  ! local vars
  character(len=MAX_NAME) :: varname
  character(len=MAX_FILE) :: filename1, filename2
  integer :: nlon, nlat
  integer :: i,j
  real, allocatable :: buffer(:),tmp(:,:)
  integer :: is,ie,js,je ! boundaries of our domain
  integer :: i0,j0 ! offsets for coordinates
  integer :: isg, jsg
  integer :: start(4), nread(4) 

  call get_grid_size_for_one_tile(component, tile, nlon, nlat)
  if (present(domain)) then
    call mpp_get_compute_domain(domain,is,ie,js,je)
  else
    is = 1 ; ie = nlon
    js = 1 ; je = nlat
    !--- domain normally should be present
    call error_mesg ( module_name//'/get_grid_cell_centers',&
       'domain is not present, global data will be read', NOTE)
  endif
  i0 = -is+1; j0 = -js+1

  ! verify that lon and lat sizes are consistent with the size of domain
  if (size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) &
       call error_mesg ( module_name//'/get_grid_cell_centers',&
       'Size of array "lon" is not consistent with the domain size',&
       FATAL )
  if (size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) &
       call error_mesg ( module_name//'/get_grid_cell_centers',&
       'Size of array "lat" is not consistent with the domain size',&
       FATAL )
  if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then
     call error_mesg(module_name//'/get_grid_cell_vertices',&
          'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN',&
          FATAL)  
  endif

  select case(get_grid_version())
  case(VERSION_0)
     select case (trim(component))
     case('ATM','LND')
        allocate(buffer(max(nlon,nlat)))
        ! read coordinates of grid cell vertices
        call read_data(grid_file, 'xt'//lowercase(component(1:1)), buffer(1:nlon), no_domain=.true.)
        do j = js,je
        do i = is,ie
           lon(i+i0,j+j0) = buffer(i)
        enddo
        enddo
        call read_data(grid_file, 'yt'//lowercase(component(1:1)), buffer(1:nlat), no_domain=.true.)
        do j = js,je
        do i = is,ie
           lat(i+i0,j+j0) = buffer(j)
        enddo
        enddo
        deallocate(buffer)
     case('OCN')
        call read_data(grid_file, 'geolon_t', lon, no_domain=.not.present(domain), domain=domain )
        call read_data(grid_file, 'geolat_t', lat, no_domain=.not.present(domain), domain=domain )
     end select
  case(VERSION_1)
     select case(trim(component))
     case('ATM','LND')
        allocate(buffer(max(nlon,nlat)))
        ! read coordinates of grid cell vertices
        call read_data(grid_file, 'xt'//lowercase(component(1:1)), buffer(1:nlon), no_domain=.true.)
        do j = js,je
        do i = is,ie
           lon(i+i0,j+j0) = buffer(i)
        enddo
        enddo
        call read_data(grid_file, 'yt'//lowercase(component(1:1)), buffer(1:nlat), no_domain=.true.)
        do j = js,je
        do i = is,ie
           lat(i+i0,j+j0) = buffer(j)
        enddo
        enddo
        deallocate(buffer)
     case('OCN')
        call read_data(grid_file, 'x_T', lon, no_domain=.not.present(domain), domain=domain )
        call read_data(grid_file, 'y_T', lat, no_domain=.not.present(domain), domain=domain )
     end select
  case(VERSION_2) ! mosaic grid file
     ! get the name of the mosaic file for the component
     call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1)
     filename1=grid_dir//trim(filename1)
     ! get the name of the grid file for the component and tile
     call read_data(filename1, 'gridfiles', filename2, level=tile)
     filename2 = grid_dir//trim(filename2)
     if(PRESENT(domain)) then
        call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg)
        start = 1; nread = 1
        start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3
        start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3
        allocate(tmp(nread(1), nread(2)))
        call read_data(filename2, 'x', tmp, start, nread, no_domain=.TRUE.)
        do j = 1, je-js+1
           do i = 1, ie-is+1
              lon(i,j) = tmp(2*i,2*j)
           enddo
        enddo
        call read_data(filename2, 'y', tmp, start, nread, no_domain=.TRUE.)
        do j = 1, je-js+1
           do i = 1, ie-is+1
              lat(i,j) = tmp(2*i,2*j)
           enddo
        enddo        
     else
        allocate(tmp(2*nlon+1,2*nlat+1))
        call read_data(filename2, 'x', tmp, no_domain=.TRUE.)
        do j = js,je
           do i = is,ie
              lon(i+i0,j+j0) = tmp(2*i,2*j)
           end do
        end do
        call read_data(filename2, 'y', tmp, no_domain=.TRUE.)
        do j = js,je
           do i = is,ie
              lat(i+i0,j+j0) = tmp(2*i,2*j)
           end do
        end do
        deallocate(tmp)
     endif
  end select

end subroutine get_grid_cell_centers_2D


! ============================================================================
! given a model component, a layout, and (optionally) a halo size, returns a 
! domain for current processor
! ============================================================================
! this subroutine probably does not belong in the grid_mod 
subroutine define_cube_mosaic ( component, domain, layout, halo )
  character(len=*) , intent(in)    :: component
  type(domain2d)   , intent(inout) :: domain
  integer          , intent(in)    :: layout(2)
  integer, optional, intent(in)    :: halo 

  ! ---- local constants
  
  ! ---- local vars
  character(len=MAX_NAME) :: varname
  character(len=MAX_FILE) :: mosaic_file
  integer :: ntiles     ! number of tiles
  integer :: ncontacts  ! number of contacts between mosaic tiles
  integer :: n
  integer :: ng         ! halo size
  integer, allocatable :: nlon(:), nlat(:), global_indices(:,:)
  integer, allocatable :: pe_start(:), pe_end(:), layout_2d(:,:)
  integer, allocatable :: tile1(:),tile2(:)
  integer, allocatable :: is1(:),ie1(:),js1(:),je1(:)
  integer, allocatable :: is2(:),ie2(:),js2(:),je2(:)

  call get_grid_ntiles(component,ntiles)
  allocate(nlon(ntiles), nlat(ntiles))
  allocate(global_indices(4,ntiles))
  allocate(pe_start(ntiles),pe_end(ntiles))
  allocate(layout_2d(2,ntiles))
  call get_grid_size(component,nlon,nlat)

  do n = 1, ntiles
     global_indices(:,n) = (/ 1, nlon(n), 1, nlat(n) /)
     layout_2d     (:,n) = layout
     pe_start        (n) = mpp_root_pe() + (n-1)*layout(1)*layout(2)
     pe_end          (n) = mpp_root_pe() +     n*layout(1)*layout(2) - 1
  enddo

  varname=trim(lowercase(component))//'_mosaic_file'
  call read_data(grid_file,varname,mosaic_file)
  mosaic_file = grid_dir//mosaic_file

  ! get the contact information from mosaic file
  ncontacts = get_mosaic_ncontacts(mosaic_file)
  allocate(tile1(ncontacts),tile2(ncontacts))
  allocate(is1(ncontacts),ie1(ncontacts),js1(ncontacts),je1(ncontacts))
  allocate(is2(ncontacts),ie2(ncontacts),js2(ncontacts),je2(ncontacts))
  call get_mosaic_contact(mosaic_file, tile1, tile2, &
       is1, ie1, js1, je1, is2, ie2, js2, je2)

  ng = 0
  if(present(halo)) ng = halo
  ! create the domain2d variable
  call mpp_define_mosaic ( global_indices, layout_2d, domain, &
       ntiles, ncontacts, tile1, tile2,                  &
       is1, ie1, js1, je1, &
       is2, ie2, js2, je2, &
       pe_start=pe_start, pe_end=pe_end, symmetry=.true.,  &
       shalo = ng, nhalo = ng, whalo = ng, ehalo = ng,     &
       name = trim(component)//'Cubic-Sphere Grid' )

  deallocate(nlon,nlat,global_indices,pe_start,pe_end,layout_2d)
  deallocate(tile1,tile2)
  deallocate(is1,ie1,js1,je1)
  deallocate(is2,ie2,js2,je2)

end subroutine define_cube_mosaic

end module grid_mod


module mosaic_mod

! <CONTACT EMAIL="Zhi.Liang@noaa.gov">
!   Zhi Liang
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!    <TT>mosaic_mod</TT> implements some utility routines to read mosaic information.
! </OVERVIEW>

! <DESCRIPTION>
!    <TT>mosaic_mod</TT> implements some utility routines to read mosaic information.
!    The information includes number of tiles and contacts in the mosaic, 
!    mosaic grid resolution of each tile, mosaic contact information, mosaic exchange
!    grid information. Each routine will call a C-version routine to get these information.
! </DESCRIPTION>

use mpp_mod, only : mpp_error, FATAL

implicit none
private


! --- public interface


public :: get_mosaic_ntiles
public :: get_mosaic_ncontacts
public :: get_mosaic_grid_sizes
public :: get_mosaic_contact
public :: get_mosaic_xgrid_size
public :: get_mosaic_xgrid
public :: calc_mosaic_grid_area

logical :: module_is_initialized = .true.
! version information varaible
 character(len=128) :: version = '$Id: mosaic.F90,v 15.0 2007/08/14 04:14:22 fms Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

contains

!#######################################################################

! <SUBROUTINE NAME="mosaic_init">
!   <OVERVIEW>
!     Initialize the mosaic_mod. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     Initialization routine for the mosaic module. It writes the 
!     version information to the log file.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call mosaic_init ( )
!   </TEMPLATE>
subroutine mosaic_init() 

  if (module_is_initialized) return
  module_is_initialized = .TRUE.

!--------- write version number and namelist ------------------
!  call write_version_number (version, tagname)

end subroutine mosaic_init
! </SUBROUTINE>

!#######################################################################
! <FUNCTION NAME="get_mosaic_xgrid_size">
!   <OVERVIEW>
!     return exchange grid size of mosaic xgrid file.
!   </OVERVIEW>
!   <DESCRIPTION>
!     return exchange grid size of mosaic xgrid file.
!   </DESCRIPTION>
!   <TEMPLATE>
!    nxgrid = get_mosaic_xgrid_size(xgrid_file)
!   </TEMPLATE>
!   <IN NAME="xgrid_file" TYPE="character(len=*)">
!     The file that contains exchange grid information.
!   </IN>
  function get_mosaic_xgrid_size(xgrid_file)
    character(len=*), intent(in)          :: xgrid_file
    integer                               :: get_mosaic_xgrid_size
    character(len=len_trim(xgrid_file)+1) :: xfile    
    integer                               :: read_mosaic_xgrid_size
    integer                               :: strlen

    !---- transfer to C-stype string
    strlen = len_trim(xgrid_file)
    xfile(1:strlen) = xgrid_file(1:strlen)
    strlen = strlen+1
    xfile(strlen:strlen) = CHAR(0)

    get_mosaic_xgrid_size = read_mosaic_xgrid_size(xfile)

    return   

  end function get_mosaic_xgrid_size
! </FUNCTION>
!#######################################################################
! <SUBROUTINE NAME="get_mosaic_xgrid">
!   <OVERVIEW>
!     get exchange grid information from mosaic xgrid file.
!   </OVERVIEW>
!   <DESCRIPTION>
!     get exchange grid information from mosaic xgrid file.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_mosaic_xgrid(xgrid_file, nxgrid, i1, j1, i2, j2, area)
!   </TEMPLATE>
!   <IN NAME="xgrid_file" TYPE="character(len=*)">
!     The file that contains exchange grid information.
!   </IN>
!   <INOUT NAME="nxgrid" TYPE="integer">
!     number of exchange grid in xgrid_file
!   </INOUT>
!   <INOUT NAME="i1, j1" TYPE="integer, dimension(:)">
!     i and j-index in grid 1 of exchange grid.
!   </INOUT>
!   <INOUT NAME="i2, j2" TYPE="integer, dimension(:)">
!     i and j-index in grid 2 of exchange grid.
!   </INOUT>
!   <INOUT NAME="area" TYPE="real, dimension(:)">
!     area of the exchange grid. The area is scaled to represent unit earth area.
!   </INOUT>
  subroutine get_mosaic_xgrid(xgrid_file, i1, j1, i2, j2, area, di, dj)
    character(len=*), intent(in) :: xgrid_file
    integer,       intent(inout) :: i1(:), j1(:), i2(:), j2(:)
    real,          intent(inout) :: area(:)
    real, optional,intent(inout) :: di(:), dj(:)

    character(len=len_trim(xgrid_file)+1) :: xfile
    integer :: n, strlen, nxgrid

    !---- transfer to C-stype string
    strlen = len_trim(xgrid_file)
    xfile(1:strlen) = xgrid_file(1:strlen)
    strlen = strlen+1
    xfile(strlen:strlen) = CHAR(0)

    !--- order 2 xgrid will be implemented later 
    nxgrid = size(i1(:))

    if(PRESENT(di)) then
       if(.NOT. PRESENT(dj) ) call mpp_error(FATAL, "mosaic_mod: when di is present, dj should be present")
       call read_mosaic_xgrid_order2(xfile, i1, j1, i2, j2, area, di, dj)
    else
       call read_mosaic_xgrid_order1(xfile, i1, j1, i2, j2, area)
    end if

    ! in C, programming, the starting index is 0, so need add 1 to the index.
    do n = 1, nxgrid
       i1(n) = i1(n) + 1
       j1(n) = j1(n) + 1
       i2(n) = i2(n) + 1
       j2(n) = j2(n) + 1
    end do
  end subroutine get_mosaic_xgrid
! </SUBROUTINE>

  !###############################################################################
  ! <SUBROUTINE NAME="get_mosaic_ntiles">
  !   <OVERVIEW>
  !     get number of tiles in the mosaic_file.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     get number of tiles in the mosaic_file.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     ntiles = get_mosaic_ntiles( mosaic_file)
  !   </TEMPLATE>
  !   <IN NAME="mosaic_file" TYPE="character(len=*)">
  !     The file that contains mosaic information.
  !   </IN>
  function get_mosaic_ntiles(mosaic_file)
    character(len=*), intent(in) :: mosaic_file
    integer                      :: get_mosaic_ntiles 

    character(len=len_trim(mosaic_file)+1) :: mfile    
    integer                                :: strlen
    integer                                :: read_mosaic_ntiles

    !---- transfer to C-stype string
    strlen = len_trim(mosaic_file)
    mfile(1:strlen) = mosaic_file(1:strlen)
    strlen = strlen+1
    mfile(strlen:strlen) = CHAR(0)

    get_mosaic_ntiles = read_mosaic_ntiles(mfile)

  end function get_mosaic_ntiles
! </SUBROUTINE>

  !###############################################################################
  ! <SUBROUTINE NAME="get_mosaic_ncontacts">
  !   <OVERVIEW>
  !     get number of contacts in the mosaic_file.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     get number of contacts in the mosaic_file.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     ntiles = get_mosaic_ncontacts( mosaic_file)
  !   </TEMPLATE>
  !   <IN NAME="mosaic_file" TYPE="character(len=*)">
  !     The file that contains mosaic information.
  !   </IN>
  function get_mosaic_ncontacts( mosaic_file)
    character(len=*), intent(in) :: mosaic_file
    integer                      :: get_mosaic_ncontacts 

    character(len=len_trim(mosaic_file)+1) :: mfile    
    integer                                :: strlen
    integer                                :: read_mosaic_ncontacts

    !---- transfer to C-stype string
    strlen = len_trim(mosaic_file)
    mfile(1:strlen) = mosaic_file(1:strlen)
    strlen = strlen+1
    mfile(strlen:strlen) = CHAR(0)

    get_mosaic_ncontacts = read_mosaic_ncontacts(mfile)

  end function get_mosaic_ncontacts
! </SUBROUTINE>


  !###############################################################################
  ! <SUBROUTINE NAME="get_mosaic_grid_sizes">
  !   <OVERVIEW>
  !     get grid size of each tile from mosaic_file
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     get grid size of each tile from mosaic_file
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call get_mosaic_grid_sizes(mosaic_file, nx, ny)
  !   </TEMPLATE>
  !   <IN NAME="mosaic_file" TYPE="character(len=*)">
  !     The file that contains mosaic information.
  !   </IN>
  !   <INOUT NAME="nx" TYPE="integer, dimension(:)">
  !     List of grid size in x-direction of each tile.
  !   </INOUT>
  !   <INOUT NAME="ny" TYPE="integer, dimension(:)">
  !     List of grid size in y-direction of each tile.
  !   </INOUT>
  subroutine get_mosaic_grid_sizes( mosaic_file, nx, ny)
    character(len=*),         intent(in) :: mosaic_file
    integer, dimension(:), intent(inout) :: nx, ny

    character(len=len_trim(mosaic_file)+1) :: mfile    
    integer                                :: strlen

    !---- transfer to C-stype string
    strlen = len_trim(mosaic_file)
    mfile(1:strlen) = mosaic_file(1:strlen)
    strlen = strlen+1
    mfile(strlen:strlen) = CHAR(0)

    call read_mosaic_grid_sizes(mfile, nx, ny)

  end subroutine get_mosaic_grid_sizes
! </SUBROUTINE>

  !###############################################################################
  ! <SUBROUTINE NAME="get_mosaic_contact">
  !   <OVERVIEW>
  !     get contact information from mosaic_file
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     get contact information from mosaic_file
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call get_mosaic_contact(mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1,
  !                             istart2, iend2, jstart2, jend2)
  !   </TEMPLATE>
  !   <IN NAME="mosaic_file" TYPE="character(len=*)">
  !     The file that contains mosaic information.
  !   </IN>
  !   <INOUT NAME="tile1" TYPE="integer, dimension(:)">
  !     list tile number in tile 1 of each contact.
  !   </INOUT>
  !   <INOUT NAME="tile1" TYPE="integer, dimension(:)">
  !     list tile number in tile 2 of each contact.
  !   </INOUT>
  !   <INOUT NAME="istart1" TYPE="integer, dimension(:)">
  !     list starting i-index in tile 1 of each contact.
  !   </INOUT>
  !   <INOUT NAME="iend1" TYPE="integer, dimension(:)">
  !     list ending i-index in tile 1 of each contact.
  !   </INOUT>
  !   <INOUT NAME="jstart1" TYPE="integer, dimension(:)">
  !     list starting j-index in tile 1 of each contact.
  !   </INOUT>
  !   <INOUT NAME="jend1" TYPE="integer, dimension(:)">
  !     list ending j-index in tile 1 of each contact.
  !   </INOUT>
  !   <INOUT NAME="istart2" TYPE="integer, dimension(:)">
  !     list starting i-index in tile 2 of each contact.
  !   </INOUT>
  !   <INOUT NAME="iend2" TYPE="integer, dimension(:)">
  !     list ending i-index in tile 2 of each contact.
  !   </INOUT>
  !   <INOUT NAME="jstart2" TYPE="integer, dimension(:)">
  !     list starting j-index in tile 2 of each contact.
  !   </INOUT>
  !   <INOUT NAME="jend2" TYPE="integer, dimension(:)">
  !     list ending j-index in tile 2 of each contact.
  !   </INOUT>
  subroutine get_mosaic_contact( mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1, &
                                   istart2, iend2, jstart2, jend2)
    character(len=*),         intent(in) :: mosaic_file
    integer, dimension(:), intent(inout) :: tile1, tile2
    integer, dimension(:), intent(inout) :: istart1, iend1, jstart1, jend1
    integer, dimension(:), intent(inout) :: istart2, iend2, jstart2, jend2
    character(len=len_trim(mosaic_file)+1) :: mfile    
    integer                                :: strlen

    !---- transfer to C-stype string
    strlen = len_trim(mosaic_file)
    mfile(1:strlen) = mosaic_file(1:strlen)
    strlen = strlen+1
    mfile(strlen:strlen) = CHAR(0)

    call read_mosaic_contact(mfile, tile1, tile2, istart1, iend1, jstart1, jend1, &
                            istart2, iend2, jstart2, jend2)
    !--- transfer C-index to Fortran-index.
    istart1 = istart1 + 1
    iend1   = iend1   + 1
    jstart1 = jstart1 + 1
    jend1   = jend1   + 1
    istart2 = istart2 + 1
    iend2   = iend2   + 1
    jstart2 = jstart2 + 1
    jend2   = jend2   + 1

  end subroutine get_mosaic_contact
! </SUBROUTINE>

  !###############################################################################
  ! <SUBROUTINE NAME="calc_mosaic_grid_area">
  !   <OVERVIEW>
  !     calculate grid cell area.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     calculate the grid cell area. The purpose of this routine is to make 
  !     sure the consistency between model grid area and exchange grid area.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call calc_mosaic_grid_area(lon, lat, area)
  !   </TEMPLATE>
  !   <IN NAME="lon" TYPE="real, dimension(:,:)">
  !     geographical longitude of grid cell vertices.
  !   </IN>
  !   <IN NAME="lat" TYPE="real, dimension(:,:)">
  !     geographical latitude of grid cell vertices.
  !   </IN>
  !   <INOUT NAME="area" TYPE="real, dimension(:,:)">
  !     grid cell area.
  !   </INOUT>
  subroutine calc_mosaic_grid_area(lon, lat, area)
     real, dimension(:,:), intent(in)    :: lon
     real, dimension(:,:), intent(in)    :: lat
     real, dimension(:,:), intent(inout) :: area
     integer                             :: nlon, nlat

     nlon = size(area,1)
     nlat = size(area,2)
     ! make sure size of lon, lat and area are consitency
     if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) &
        call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1")
     if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) &
        call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1")

     call get_grid_area( nlon, nlat, lon, lat, area)

  end subroutine calc_mosaic_grid_area
  ! </SUBROUTINE>

end module mosaic_mod


#ifdef TEST_MOSAIC
program test_mosaic

use mosaic_mod, only : get_mosaic_ntiles, get_mosaic_ncontacts
use mosaic_mod, only : get_mosaic_grid_sizes, get_mosaic_contact

implicit none

integer              :: ntiles, ncontacts, n
integer, allocatable :: tile1(:), tile2(:), nx(:), ny(:)
integer, allocatable :: istart1(:), iend1(:), jstart1(:), jend1(:)
integer, allocatable :: istart2(:), iend2(:), jstart2(:), jend2(:)
character(len=128)   :: mosaic_file = "INPUT/mosaic.nc"

ntiles = get_mosaic_ntiles(mosaic_file)
ncontacts = get_mosaic_ncontacts(mosaic_file)
allocate(nx(ntiles), ny(ntiles))
allocate(tile1(ncontacts), tile2(ncontacts) )
allocate(istart1(ncontacts), iend1(ncontacts), jstart1(ncontacts), jend1(ncontacts) )
allocate(istart2(ncontacts), iend2(ncontacts), jstart2(ncontacts), jend2(ncontacts) )

call get_mosaic_grid_sizes(mosaic_file, nx, ny )
call get_mosaic_contact(mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2)

! print out information

print '(a,i3,a,a)', "****** There is ", ntiles, " tiles in ", trim(mosaic_file)
do n = 1, ntiles
   print '(a,i3,a,i3,a,i3)', " tile = ", n, ", nx = ", nx(n), ", ny = ", ny(n)
end do

print '(a,i3,a,a)', "****** There is ", ncontacts, " contacts in ", trim(mosaic_file)
do n = 1, ncontacts
   print '(a,i3,a,i3,a,i3,a,i4,a,i4,a,i4,a,i4,a,i4,a,i4,a,i4,a,i4)', &
           "contact=", n, ": tile1=", tile1(n), " tile2=", tile2(n),   &
           " is1=", istart1(n), " ie1=", iend1(n),                   &
           " js1=", jstart1(n), " je1=", jend1(n),                   &
           " is2=", istart2(n), " ie2=", iend2(n),                   &
           " js2=", jstart2(n), " je2=", jend2(n)
end do

deallocate(tile1, tile2, nx, ny)
deallocate(istart1, iend1, jstart1, jend1)
deallocate(istart2, iend2, jstart2, jend2)


end program test_mosaic
#endif


!-----------------------------------------------------------------------
!                 Communication for message-passing codes
!
! AUTHOR: V. Balaji (V.Balaji@noaa.gov)
!         SGI/GFDL Princeton University
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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.
!
! For the full text of the GNU General Public License,
! write to: Free Software Foundation, Inc.,
!           675 Mass Ave, Cambridge, MA 02139, USA.  
!-----------------------------------------------------------------------
module mpp_mod
!a generalized communication package for use with shmem and MPI
!will add: co_array_fortran, MPI2
!Balaji (V.Balaji@noaa.gov) 11 May 1998

! <CONTACT EMAIL="V.Balaji@noaa.gov">
!   V. Balaji
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <RCSLOG SRC="http://www.gfdl.noaa.gov/~vb/changes_mpp.html"/>

! <OVERVIEW>
!   <TT>mpp_mod</TT>, is a set of simple calls to provide a uniform interface
!   to different message-passing libraries. It currently can be
!   implemented either in the SGI/Cray native SHMEM library or in the MPI
!   standard. Other libraries (e.g MPI-2, Co-Array Fortran) can be
!   incorporated as the need arises.
! </OVERVIEW>

! <DESCRIPTION>
!   The data transfer between a processor and its own memory is based
!   on <TT>load</TT> and <TT>store</TT> operations upon
!   memory. Shared-memory systems (including distributed shared memory
!   systems) have a single address space and any processor can acquire any
!   data within the memory by <TT>load</TT> and
!   <TT>store</TT>. The situation is different for distributed
!   parallel systems. Specialized MPP systems such as the T3E can simulate
!   shared-memory by direct data acquisition from remote memory. But if
!   the parallel code is distributed across a cluster, or across the Net,
!   messages must be sent and received using the protocols for
!   long-distance communication, such as TCP/IP. This requires a
!   ``handshaking'' between nodes of the distributed system. One can think
!   of the two different methods as involving <TT>put</TT>s or
!   <TT>get</TT>s (e.g the SHMEM library), or in the case of
!   negotiated communication (e.g MPI), <TT>send</TT>s and
!   <TT>recv</TT>s.
!   
!   The difference between SHMEM and MPI is that SHMEM uses one-sided
!   communication, which can have very low-latency high-bandwidth
!   implementations on tightly coupled systems. MPI is a standard
!   developed for distributed computing across loosely-coupled systems,
!   and therefore incurs a software penalty for negotiating the
!   communication. It is however an open industry standard whereas SHMEM
!   is a proprietary interface. Besides, the <TT>put</TT>s or
!   <TT>get</TT>s on which it is based cannot currently be implemented in
!   a cluster environment (there are recent announcements from Compaq that
!   occasion hope).
!   
!   The message-passing requirements of climate and weather codes can be
!   reduced to a fairly simple minimal set, which is easily implemented in
!   any message-passing API. <TT>mpp_mod</TT> provides this API.
!
!    Features of <TT>mpp_mod</TT> include:
!   
!    1) Simple, minimal API, with free access to underlying API for
!       more complicated stuff.<BR/>
!    2) Design toward typical use in climate/weather CFD codes.<BR/>
!    3) Performance to be not significantly lower than any native API.
!   
!   This module is used to develop higher-level calls for <LINK 
!   SRC="mpp_domains.html">domain decomposition</LINK> and <LINK
!   SRC="mpp_io.html">parallel I/O</LINK>.
!   
!   Parallel computing is initially daunting, but it soon becomes
!   second nature, much the way many of us can now write vector code
!   without much effort. The key insight required while reading and
!   writing parallel code is in arriving at a mental grasp of several
!   independent parallel execution streams through the same code (the SPMD
!   model). Each variable you examine may have different values for each
!   stream, the processor ID being an obvious example. Subroutines and
!   function calls are particularly subtle, since it is not always obvious
!   from looking at a call what synchronization between execution streams
!   it implies. An example of erroneous code would be a global barrier
!   call (see <LINK SRC="#mpp_sync">mpp_sync</LINK> below) placed
!   within a code block that not all PEs will execute, e.g:
!   
!   <PRE>
!   if( pe.EQ.0 )call mpp_sync()
!   </PRE>
!   
!   Here only PE 0 reaches the barrier, where it will wait
!   indefinitely. While this is a particularly egregious example to
!   illustrate the coding flaw, more subtle versions of the same are
!   among the most common errors in parallel code.
!   
!   It is therefore important to be conscious of the context of a
!   subroutine or function call, and the implied synchronization. There
!   are certain calls here (e.g <TT>mpp_declare_pelist, mpp_init,
!   mpp_malloc, mpp_set_stack_size</TT>) which must be called by all
!   PEs. There are others which must be called by a subset of PEs (here
!   called a <TT>pelist</TT>) which must be called by all the PEs in the
!   <TT>pelist</TT> (e.g <TT>mpp_max, mpp_sum, mpp_sync</TT>). Still
!   others imply no synchronization at all. I will make every effort to
!   highlight the context of each call in the MPP modules, so that the
!   implicit synchronization is spelt out.  
!   
!   For performance it is necessary to keep synchronization as limited
!   as the algorithm being implemented will allow. For instance, a single
!   message between two PEs should only imply synchronization across the
!   PEs in question. A <I>global</I> synchronization (or <I>barrier</I>)
!   is likely to be slow, and is best avoided. But codes first
!   parallelized on a Cray T3E tend to have many global syncs, as very
!   fast barriers were implemented there in hardware.
!   
!   Another reason to use pelists is to run a single program in MPMD
!   mode, where different PE subsets work on different portions of the
!   code. A typical example is to assign an ocean model and atmosphere
!   model to different PE subsets, and couple them concurrently instead of
!   running them serially. The MPP module provides the notion of a
!   <I>current pelist</I>, which is set when a group of PEs branch off
!   into a subset. Subsequent calls that omit the <TT>pelist</TT> optional
!   argument (seen below in many of the individual calls) assume that the
!   implied synchronization is across the current pelist. The calls
!   <TT>mpp_root_pe</TT> and <TT>mpp_npes</TT> also return the values
!   appropriate to the current pelist. The <TT>mpp_set_current_pelist</TT>
!   call is provided to set the current pelist.

! </DESCRIPTION>
! <PUBLIC>
!  F90 is a strictly-typed language, and the syntax pass of the
!  compiler requires matching of type, kind and rank (TKR). Most calls
!  listed here use a generic type, shown here as <TT>MPP_TYPE_</TT>. This
!  is resolved in the pre-processor stage to any of a variety of
!  types. In general the MPP operations work on 4-byte and 8-byte
!  variants of <TT>integer, real, complex, logical</TT> variables, of
!  rank 0 to 5, leading to 48 specific module procedures under the same
!  generic interface. Any of the variables below shown as
!  <TT>MPP_TYPE_</TT> is treated in this way.
! </PUBLIC>

#include <fms_platform.h>

#if defined(use_libSMA) && defined(sgi_mipspro)
  use shmem_interface
#endif

#if defined(use_libMPI) && defined(sgi_mipspro)
  use mpi
#endif

  use mpp_parameter_mod, only : MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE
  use mpp_parameter_mod, only : NOTE, WARNING, FATAL, MPP_CLOCK_DETAILED,MPP_CLOCK_SYNC
  use mpp_parameter_mod, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER
  use mpp_parameter_mod, only : CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
  use mpp_parameter_mod, only : MAX_EVENTS, MAX_BINS, MAX_EVENT_TYPES, PESET_MAX, MAX_CLOCKS
  use mpp_parameter_mod, only : MAXPES, EVENT_WAIT, EVENT_ALLREDUCE, EVENT_BROADCAST
  use mpp_parameter_mod, only : EVENT_RECV, EVENT_SEND, MPP_READY, MPP_WAIT
  use mpp_parameter_mod, only : mpp_parameter_version=>version, mpp_parameter_tagname=>tagname
  use mpp_data_mod,      only : stat, mpp_stack, ptr_stack, status, ptr_status, sync, ptr_sync  
  use mpp_data_mod,      only : mpp_from_pe, ptr_from, remote_data_loc, ptr_remote
  use mpp_data_mod,      only : mpp_data_version=>version, mpp_data_tagname=>tagname

implicit none
private

#if defined(use_libSMA) 
#include <mpp/shmem.fh>
#endif

#if defined(use_libMPI) && !defined(sgi_mipspro)
#include <mpif.h>   
!sgi_mipspro gets this from 'use mpi'
#endif

  !--- public paramters  -----------------------------------------------
  public :: MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, NOTE, WARNING, FATAL
  public :: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT
  public :: CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
  public :: MAXPES, EVENT_RECV, EVENT_SEND

  !--- public data from mpp_data_mod ------------------------------
  public :: request

  !--- public interface from mpp_util.h ------------------------------
  public :: stdin, stdout, stderr, stdlog, lowercase, uppercase, mpp_error, mpp_error_state
  public :: mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_set_stack_size, mpp_pe
  public :: mpp_node, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_declare_pelist
  public :: mpp_get_current_pelist, mpp_set_current_pelist, mpp_clock_begin, mpp_clock_end
  public :: mpp_clock_id, mpp_clock_set_grain, mpp_record_timing_data, get_unit

  !--- public interface from mpp_comm.h ------------------------------
  public :: mpp_chksum, mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv
  public :: mpp_broadcast, mpp_malloc, mpp_init, mpp_exit
  public :: mpp_gather
#ifdef use_MPI_GSM
  public :: mpp_gsm_malloc, mpp_gsm_free
#endif

  !*********************************************************************
  !
  !    public data type
  !
  !*********************************************************************
  !peset hold communicators as SHMEM-compatible triads (start, log2(stride), num)
  type :: communicator
     private
     character(len=32) :: name
     integer, pointer  :: list(:) =>NULL()
     integer           :: count
     integer           :: start, log2stride ! dummy variables when libMPI is defined.
     integer           :: id, group         ! MPI communicator and group id for this PE set.
                                            ! dummy variables when libSMA is defined.
  end type communicator

  type :: event
     private
     character(len=16)                         :: name
     integer(LONG_KIND), dimension(MAX_EVENTS) :: ticks, bytes
     integer                                   :: calls
  end type event

  !a clock contains an array of event profiles for a region
  type :: clock
     private
     character(len=32)    :: name
     integer(LONG_KIND)   :: tick
     integer(LONG_KIND)   :: total_ticks
     integer              :: peset_num
     logical              :: sync_on_begin, detailed
     integer              :: grain
     type(event), pointer :: events(:) =>NULL() !if needed, allocate to MAX_EVENT_TYPES
     logical              :: is_on              !initialize to false. set true when calling mpp_clock_begin
                                                ! set false when calling mpp_clock_end
  end type clock

  type :: Clock_Data_Summary
     private
     character(len=16)  :: name
     real(DOUBLE_KIND)  :: msg_size_sums(MAX_BINS)
     real(DOUBLE_KIND)  :: msg_time_sums(MAX_BINS)
     real(DOUBLE_KIND)  :: total_data
     real(DOUBLE_KIND)  :: total_time
     integer(LONG_KIND) :: msg_size_cnts(MAX_BINS)
     integer(LONG_KIND) :: total_cnts
  end type Clock_Data_Summary

  type :: Summary_Struct
     private
     character(len=16)         :: name
     type (Clock_Data_Summary) :: event(MAX_EVENT_TYPES)
  end type Summary_Struct

!***********************************************************************
!
!     public interface from mpp_util.h
!
!***********************************************************************
  ! <INTERFACE NAME="mpp_error">
  !  <OVERVIEW>
  !    Error handler.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    It is strongly recommended that all error exits pass through
  !    <TT>mpp_error</TT> to assure the program fails cleanly. An individual
  !    PE encountering a <TT>STOP</TT> statement, for instance, can cause the
  !    program to hang. The use of the <TT>STOP</TT> statement is strongly
  !    discouraged.
  !    
  !    Calling mpp_error with no arguments produces an immediate error
  !    exit, i.e:
  !    <PRE>
  !    call mpp_error
  !    call mpp_error(FATAL)
  !    </PRE>
  !    are equivalent.
  !    
  !    The argument order
  !    <PRE>
  !    call mpp_error( routine, errormsg, errortype )
  !    </PRE>
  !    is also provided to support legacy code. In this version of the
  !    call, none of the arguments may be omitted.
  !    
  !    The behaviour of <TT>mpp_error</TT> for a <TT>WARNING</TT> can be
  !    controlled with an additional call <TT>mpp_set_warn_level</TT>.
  !    <PRE>
  !    call mpp_set_warn_level(ERROR)
  !    </PRE>
  !    causes <TT>mpp_error</TT> to treat <TT>WARNING</TT>
  !    exactly like <TT>FATAL</TT>.
  !    <PRE>
  !    call mpp_set_warn_level(WARNING)
  !    </PRE>
  !    resets to the default behaviour described above.
  !    
  !    <TT>mpp_error</TT> also has an internal error state which
  !    maintains knowledge of whether a warning has been issued. This can be
  !    used at startup in a subroutine that checks if the model has been
  !    properly configured. You can generate a series of warnings using
  !    <TT>mpp_error</TT>, and then check at the end if any warnings has been
  !    issued using the function <TT>mpp_error_state()</TT>. If the value of
  !    this is <TT>WARNING</TT>, at least one warning has been issued, and
  !    the user can take appropriate action:
  !    
  !    <PRE>
  !    if( ... )call mpp_error( WARNING, '...' )
  !    if( ... )call mpp_error( WARNING, '...' )
  !    if( ... )call mpp_error( WARNING, '...' )
  !    ...
  !    if( mpp_error_state().EQ.WARNING )call mpp_error( FATAL, '...' )
  !    </PRE>
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_error( errortype, routine, errormsg )
  !  </TEMPLATE>
  !  <IN NAME="errortype">
  !    One of <TT>NOTE</TT>, <TT>WARNING</TT> or <TT>FATAL</TT> 
  !    (these definitions are acquired by use association).
  !    <TT>NOTE</TT> writes <TT>errormsg</TT> to <TT>STDOUT</TT>. 
  !    <TT>WARNING</TT> writes <TT>errormsg</TT> to <TT>STDERR</TT>.
  !    <TT>FATAL</TT> writes <TT>errormsg</TT> to <TT>STDERR</TT>,
  !    and induces a clean error exit with a call stack traceback.
  !  </IN>
  ! </INTERFACE>
  interface mpp_error
     module procedure mpp_error_basic
     module procedure mpp_error_mesg
     module procedure mpp_error_noargs
     module procedure mpp_error_is
     module procedure mpp_error_rs
     module procedure mpp_error_ia
     module procedure mpp_error_ra
     module procedure mpp_error_ia_ia
     module procedure mpp_error_ia_ra
     module procedure mpp_error_ra_ia
     module procedure mpp_error_ra_ra
     module procedure mpp_error_ia_is
     module procedure mpp_error_ia_rs
     module procedure mpp_error_ra_is
     module procedure mpp_error_ra_rs
     module procedure mpp_error_is_ia
     module procedure mpp_error_is_ra
     module procedure mpp_error_rs_ia
     module procedure mpp_error_rs_ra
     module procedure mpp_error_is_is
     module procedure mpp_error_is_rs
     module procedure mpp_error_rs_is
     module procedure mpp_error_rs_rs
  end interface

  interface array_to_char
     module procedure iarray_to_char
     module procedure rarray_to_char
  end interface

!***********************************************************************
!
!    public interface from mpp_comm.h
!
!***********************************************************************
#ifdef use_libSMA
  !currently SMA contains no generic shmem_wait for different integer kinds:
  !I have inserted one here
  interface shmem_integer_wait
     module procedure shmem_int4_wait_local
     module procedure shmem_int8_wait_local
  end interface
#endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !                                                                             !
  !       ROUTINES TO INITIALIZE/FINALIZE MPP MODULE: mpp_init, mpp_exit        !
  !                                                                             !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  ! <SUBROUTINE NAME="mpp_init">
  !  <OVERVIEW>
  !   Initialize <TT>mpp_mod</TT>.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !   Called to initialize the <TT>mpp_mod</TT> package. It is recommended
  !   that this call be the first executed line in your program. It sets the
  !   number of PEs assigned to this run (acquired from the command line, or
  !   through the environment variable <TT>NPES</TT>), and associates an ID
  !   number to each PE. These can be accessed by calling <LINK
  !   SRC="#mpp_npes"><TT>mpp_npes</TT></LINK> and <LINK
  !   SRC="#mpp_pe"><TT>mpp_pe</TT></LINK>.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !   call mpp_init( flags )
  !  </TEMPLATE>
  !  <IN NAME="flags" TYPE="integer">
  !   <TT>flags</TT> can be set to <TT>MPP_VERBOSE</TT> to
  !   have <TT>mpp_mod</TT> keep you informed of what it's up to.
  !  </IN>
  ! </SUBROUTINE>

  ! <SUBROUTINE NAME="mpp_exit">
  !  <OVERVIEW>
  !   Exit <TT>mpp_mod</TT>.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !   Called at the end of the run, or to re-initialize <TT>mpp_mod</TT>,
  !   should you require that for some odd reason.
  !
  !   This call implies synchronization across all PEs.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !   call mpp_exit()
  !  </TEMPLATE>
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="mpp_malloc">
  !  <OVERVIEW>
  !    Symmetric memory allocation.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    This routine is used on SGI systems when <TT>mpp_mod</TT> is
  !    invoked in the SHMEM library. It ensures that dynamically allocated
  !    memory can be used with <TT>shmem_get</TT> and
  !    <TT>shmem_put</TT>. This is called <I>symmetric
  !    allocation</I> and is described in the
  !    <TT>intro_shmem</TT> man page. <TT>ptr</TT> is a <I>Cray
  !    pointer</I> (see the section on <LINK
  !    SRC="#PORTABILITY">portability</LINK>).  The operation can be expensive
  !    (since it requires a global barrier). We therefore attempt to re-use
  !    existing allocation whenever possible. Therefore <TT>len</TT>
  !    and <TT>ptr</TT> must have the <TT>SAVE</TT> attribute
  !    in the calling routine, and retain the information about the last call
  !    to <TT>mpp_malloc</TT>. Additional memory is symmetrically
  !    allocated if and only if <TT>newlen</TT> exceeds
  !    <TT>len</TT>.
  !
  !    This is never required on Cray PVP or MPP systems. While the T3E
  !    manpages do talk about symmetric allocation, <TT>mpp_mod</TT>
  !    is coded to remove this restriction.
  !
  !    It is never required if <TT>mpp_mod</TT> is invoked in MPI.
  !
  !   This call implies synchronization across all PEs.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !   call mpp_malloc( ptr, newlen, len )
  !  </TEMPLATE>
  !  <IN NAME="ptr">
  !     a cray pointer, points to a dummy argument in this routine.
  !  </IN>
  !  <IN NAME="newlen" TYPE="integer">
  !     the required allocation length for the pointer ptr
  !  </IN>
  !  <IN NAME="len" TYPE="integer">
  !     the current allocation (0 if unallocated).
  !  </IN>
  ! </SUBROUTINE>

  !#####################################################################

  ! <SUBROUTINE NAME="mpp_set_stack_size">
  !  <OVERVIEW>
  !    Allocate module internal workspace.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    <TT>mpp_mod</TT> maintains a private internal array called
  !    <TT>mpp_stack</TT> for private workspace. This call sets the length,
  !    in words, of this array. 
  !
  !    The <TT>mpp_init</TT> call sets this
  !    workspace length to a default of 32768, and this call may be used if a
  !    longer workspace is needed.
  !    
  !    This call implies synchronization across all PEs.
  !    
  !    This workspace is symmetrically allocated, as required for
  !    efficient communication on SGI and Cray MPP systems. Since symmetric
  !    allocation must be performed by <I>all</I> PEs in a job, this call
  !    must also be called by all PEs, using the same value of
  !    <TT>n</TT>. Calling <TT>mpp_set_stack_size</TT> from a subset of PEs,
  !    or with unequal argument <TT>n</TT>, may cause the program to hang.
  !    
  !    If any MPP call using <TT>mpp_stack</TT> overflows the declared
  !    stack array, the program will abort with a message specifying the
  !    stack length that is required. Many users wonder why, if the required
  !    stack length can be computed, it cannot also be specified at that
  !    point. This cannot be automated because there is no way for the
  !    program to know if all PEs are present at that call, and with equal
  !    values of <TT>n</TT>. The program must be rerun by the user with the
  !    correct argument to <TT>mpp_set_stack_size</TT>, called at an
  !    appropriate point in the code where all PEs are known to be present.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_set_stack_size(n)
  !  </TEMPLATE>
  !  <IN NAME="n" TYPE="integer"></IN>
  ! </SUBROUTINE>

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !                                                                             !
  !            GLOBAL REDUCTION ROUTINES: mpp_max, mpp_sum, mpp_min             !
  !                                                                             !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  ! <INTERFACE NAME="mpp_max">
  !  <OVERVIEW>
  !    Reduction operations.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    Find the max of scalar a the PEs in pelist
  !    result is also automatically broadcast to all PEs
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call  mpp_max( a, pelist )
  !  </TEMPLATE>
  !  <IN NAME="a">
  !    <TT>real</TT> or <TT>integer</TT>, of 4-byte of 8-byte kind.
  !  </IN>
  !  <IN NAME="pelist">
  !    If <TT>pelist</TT> is omitted, the context is assumed to be the
  !    current pelist. This call implies synchronization across the PEs in
  !    <TT>pelist</TT>, or the current pelist if <TT>pelist</TT> is absent.
  !  </IN>
  ! </INTERFACE>

  interface mpp_max
     module procedure mpp_max_real8
#ifndef no_8byte_integers
     module procedure mpp_max_int8
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_max_real4
#endif
     module procedure mpp_max_int4
  end interface

  interface mpp_min
     module procedure mpp_min_real8
#ifndef no_8byte_integers
     module procedure mpp_min_int8
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_min_real4
#endif
     module procedure mpp_min_int4
  end interface


  ! <INTERFACE NAME="mpp_sum">
  !  <OVERVIEW>
  !    Reduction operation.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    <TT>MPP_TYPE_</TT> corresponds to any 4-byte and 8-byte variant of
  !    <TT>integer, real, complex</TT> variables, of rank 0 or 1. A
  !    contiguous block from a multi-dimensional array may be passed by its
  !    starting address and its length, as in <TT>f77</TT>.
  !
  !    Library reduction operators are not required or guaranteed to be
  !    bit-reproducible. In any case, changing the processor count changes
  !    the data layout, and thus very likely the order of operations. For
  !    bit-reproducible sums of distributed arrays, consider using the
  !    <TT>mpp_global_sum</TT> routine provided by the <LINK
  !    SRC="mpp_domains.html"><TT>mpp_domains</TT></LINK> module.
  !
  !    The <TT>bit_reproducible</TT> flag provided in earlier versions of
  !    this routine has been removed.
  !
  !
  !    If <TT>pelist</TT> is omitted, the context is assumed to be the
  !    current pelist. This call implies synchronization across the PEs in
  !    <TT>pelist</TT>, or the current pelist if <TT>pelist</TT> is absent.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_sum( a, length, pelist )
  !  </TEMPLATE>
  !  <IN NAME="length"></IN>
  !  <IN NAME="pelist"></IN>
  !  <INOUT NAME="a"></INOUT>
  ! </INTERFACE>

  interface mpp_sum
#ifndef no_8byte_integers
     module procedure mpp_sum_int8
     module procedure mpp_sum_int8_scalar
     module procedure mpp_sum_int8_2d
     module procedure mpp_sum_int8_3d
     module procedure mpp_sum_int8_4d
     module procedure mpp_sum_int8_5d
#endif
     module procedure mpp_sum_real8
     module procedure mpp_sum_real8_scalar
     module procedure mpp_sum_real8_2d
     module procedure mpp_sum_real8_3d
     module procedure mpp_sum_real8_4d
     module procedure mpp_sum_real8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_sum_cmplx8
     module procedure mpp_sum_cmplx8_scalar
     module procedure mpp_sum_cmplx8_2d
     module procedure mpp_sum_cmplx8_3d
     module procedure mpp_sum_cmplx8_4d
     module procedure mpp_sum_cmplx8_5d
#endif
     module procedure mpp_sum_int4
     module procedure mpp_sum_int4_scalar
     module procedure mpp_sum_int4_2d
     module procedure mpp_sum_int4_3d
     module procedure mpp_sum_int4_4d
     module procedure mpp_sum_int4_5d
#ifdef OVERLOAD_R4
     module procedure mpp_sum_real4
     module procedure mpp_sum_real4_scalar
     module procedure mpp_sum_real4_2d
     module procedure mpp_sum_real4_3d
     module procedure mpp_sum_real4_4d
     module procedure mpp_sum_real4_5d
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_sum_cmplx4
     module procedure mpp_sum_cmplx4_scalar
     module procedure mpp_sum_cmplx4_2d
     module procedure mpp_sum_cmplx4_3d
     module procedure mpp_sum_cmplx4_4d
     module procedure mpp_sum_cmplx4_5d
#endif
  end interface

  !#####################################################################
  ! <INTERFACE NAME="mpp_gather">
  !  <OVERVIEW>
  !    gather information onto root pe.
  !  </OVERVIEW>
  ! </INTERFACE>
  interface mpp_gather
     module procedure mpp_gather_int4_1d
     module procedure mpp_gather_real4_1d
     module procedure mpp_gather_real8_1d
  end interface


  !#####################################################################

  ! <INTERFACE NAME="mpp_transmit">
  !  <OVERVIEW>
  !    Basic message-passing call.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    <TT>MPP_TYPE_</TT> corresponds to any 4-byte and 8-byte variant of
  !    <TT>integer, real, complex, logical</TT> variables, of rank 0 or 1. A
  !    contiguous block from a multi-dimensional array may be passed by its
  !    starting address and its length, as in <TT>f77</TT>.
  !    
  !    <TT>mpp_transmit</TT> is currently implemented as asynchronous
  !    outward transmission and synchronous inward transmission. This follows
  !    the behaviour of <TT>shmem_put</TT> and <TT>shmem_get</TT>. In MPI, it
  !    is implemented as <TT>mpi_isend</TT> and <TT>mpi_recv</TT>. For most
  !    applications, transmissions occur in pairs, and are here accomplished
  !    in a single call.
  !    
  !    The special PE designations <TT>NULL_PE</TT>,
  !    <TT>ANY_PE</TT> and <TT>ALL_PES</TT> are provided by use
  !    association.
  !    
  !    <TT>NULL_PE</TT>: is used to disable one of the pair of
  !    transmissions.<BR/>
  !    <TT>ANY_PE</TT>: is used for unspecific remote
  !    destination. (Please note that <TT>put_pe=ANY_PE</TT> has no meaning
  !    in the MPI context, though it is available in the SHMEM invocation. If
  !    portability is a concern, it is best avoided).<BR/>
  !    <TT>ALL_PES</TT>: is used for broadcast operations.
  !    
  !    It is recommended that <LINK
  !    SRC="#mpp_broadcast"><TT>mpp_broadcast</TT></LINK> be used for
  !    broadcasts.
  !    
  !    The following example illustrates the use of
  !    <TT>NULL_PE</TT> and <TT>ALL_PES</TT>:
  !    
  !    <PRE>
  !    real, dimension(n) :: a
  !    if( pe.EQ.0 )then
  !        do p = 1,npes-1
  !           call mpp_transmit( a, n, p, a, n, NULL_PE )
  !        end do
  !    else
  !        call mpp_transmit( a, n, NULL_PE, a, n, 0 )
  !    end if
  !    
  !    call mpp_transmit( a, n, ALL_PES, a, n, 0 )
  !    </PRE>
  !    
  !    The do loop and the broadcast operation above are equivalent.
  !    
  !    Two overloaded calls <TT>mpp_send</TT> and
  !     <TT>mpp_recv</TT> have also been
  !    provided. <TT>mpp_send</TT> calls <TT>mpp_transmit</TT>
  !    with <TT>get_pe=NULL_PE</TT>. <TT>mpp_recv</TT> calls
  !    <TT>mpp_transmit</TT> with <TT>put_pe=NULL_PE</TT>. Thus
  !    the do loop above could be written more succinctly:
  !    
  !    <PRE>
  !    if( pe.EQ.0 )then
  !        do p = 1,npes-1
  !           call mpp_send( a, n, p )
  !        end do
  !    else
  !        call mpp_recv( a, n, 0 )
  !    end if
  !    </PRE>
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_transmit( put_data, put_len, put_pe, get_data, get_len, get_pe )
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_transmit
     module procedure mpp_transmit_real8
     module procedure mpp_transmit_real8_scalar
     module procedure mpp_transmit_real8_2d
     module procedure mpp_transmit_real8_3d
     module procedure mpp_transmit_real8_4d
     module procedure mpp_transmit_real8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_transmit_cmplx8
     module procedure mpp_transmit_cmplx8_scalar
     module procedure mpp_transmit_cmplx8_2d
     module procedure mpp_transmit_cmplx8_3d
     module procedure mpp_transmit_cmplx8_4d
     module procedure mpp_transmit_cmplx8_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_transmit_int8
     module procedure mpp_transmit_int8_scalar
     module procedure mpp_transmit_int8_2d
     module procedure mpp_transmit_int8_3d
     module procedure mpp_transmit_int8_4d
     module procedure mpp_transmit_int8_5d
     module procedure mpp_transmit_logical8
     module procedure mpp_transmit_logical8_scalar
     module procedure mpp_transmit_logical8_2d
     module procedure mpp_transmit_logical8_3d
     module procedure mpp_transmit_logical8_4d
     module procedure mpp_transmit_logical8_5d
#endif

     module procedure mpp_transmit_real4
     module procedure mpp_transmit_real4_scalar
     module procedure mpp_transmit_real4_2d
     module procedure mpp_transmit_real4_3d
     module procedure mpp_transmit_real4_4d
     module procedure mpp_transmit_real4_5d

#ifdef OVERLOAD_C4
     module procedure mpp_transmit_cmplx4
     module procedure mpp_transmit_cmplx4_scalar
     module procedure mpp_transmit_cmplx4_2d
     module procedure mpp_transmit_cmplx4_3d
     module procedure mpp_transmit_cmplx4_4d
     module procedure mpp_transmit_cmplx4_5d
#endif
     module procedure mpp_transmit_int4
     module procedure mpp_transmit_int4_scalar
     module procedure mpp_transmit_int4_2d
     module procedure mpp_transmit_int4_3d
     module procedure mpp_transmit_int4_4d
     module procedure mpp_transmit_int4_5d
     module procedure mpp_transmit_logical4
     module procedure mpp_transmit_logical4_scalar
     module procedure mpp_transmit_logical4_2d
     module procedure mpp_transmit_logical4_3d
     module procedure mpp_transmit_logical4_4d
     module procedure mpp_transmit_logical4_5d
  end interface
  interface mpp_recv
     module procedure mpp_recv_real8
     module procedure mpp_recv_real8_scalar
     module procedure mpp_recv_real8_2d
     module procedure mpp_recv_real8_3d
     module procedure mpp_recv_real8_4d
     module procedure mpp_recv_real8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_recv_cmplx8
     module procedure mpp_recv_cmplx8_scalar
     module procedure mpp_recv_cmplx8_2d
     module procedure mpp_recv_cmplx8_3d
     module procedure mpp_recv_cmplx8_4d
     module procedure mpp_recv_cmplx8_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_recv_int8
     module procedure mpp_recv_int8_scalar
     module procedure mpp_recv_int8_2d
     module procedure mpp_recv_int8_3d
     module procedure mpp_recv_int8_4d
     module procedure mpp_recv_int8_5d
     module procedure mpp_recv_logical8
     module procedure mpp_recv_logical8_scalar
     module procedure mpp_recv_logical8_2d
     module procedure mpp_recv_logical8_3d
     module procedure mpp_recv_logical8_4d
     module procedure mpp_recv_logical8_5d
#endif

     module procedure mpp_recv_real4
     module procedure mpp_recv_real4_scalar
     module procedure mpp_recv_real4_2d
     module procedure mpp_recv_real4_3d
     module procedure mpp_recv_real4_4d
     module procedure mpp_recv_real4_5d

#ifdef OVERLOAD_C4
     module procedure mpp_recv_cmplx4
     module procedure mpp_recv_cmplx4_scalar
     module procedure mpp_recv_cmplx4_2d
     module procedure mpp_recv_cmplx4_3d
     module procedure mpp_recv_cmplx4_4d
     module procedure mpp_recv_cmplx4_5d
#endif
     module procedure mpp_recv_int4
     module procedure mpp_recv_int4_scalar
     module procedure mpp_recv_int4_2d
     module procedure mpp_recv_int4_3d
     module procedure mpp_recv_int4_4d
     module procedure mpp_recv_int4_5d
     module procedure mpp_recv_logical4
     module procedure mpp_recv_logical4_scalar
     module procedure mpp_recv_logical4_2d
     module procedure mpp_recv_logical4_3d
     module procedure mpp_recv_logical4_4d
     module procedure mpp_recv_logical4_5d
  end interface
  interface mpp_send
     module procedure mpp_send_real8
     module procedure mpp_send_real8_scalar
     module procedure mpp_send_real8_2d
     module procedure mpp_send_real8_3d
     module procedure mpp_send_real8_4d
     module procedure mpp_send_real8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_send_cmplx8
     module procedure mpp_send_cmplx8_scalar
     module procedure mpp_send_cmplx8_2d
     module procedure mpp_send_cmplx8_3d
     module procedure mpp_send_cmplx8_4d
     module procedure mpp_send_cmplx8_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_send_int8
     module procedure mpp_send_int8_scalar
     module procedure mpp_send_int8_2d
     module procedure mpp_send_int8_3d
     module procedure mpp_send_int8_4d
     module procedure mpp_send_int8_5d
     module procedure mpp_send_logical8
     module procedure mpp_send_logical8_scalar
     module procedure mpp_send_logical8_2d
     module procedure mpp_send_logical8_3d
     module procedure mpp_send_logical8_4d
     module procedure mpp_send_logical8_5d
#endif

     module procedure mpp_send_real4
     module procedure mpp_send_real4_scalar
     module procedure mpp_send_real4_2d
     module procedure mpp_send_real4_3d
     module procedure mpp_send_real4_4d
     module procedure mpp_send_real4_5d

#ifdef OVERLOAD_C4
     module procedure mpp_send_cmplx4
     module procedure mpp_send_cmplx4_scalar
     module procedure mpp_send_cmplx4_2d
     module procedure mpp_send_cmplx4_3d
     module procedure mpp_send_cmplx4_4d
     module procedure mpp_send_cmplx4_5d
#endif
     module procedure mpp_send_int4
     module procedure mpp_send_int4_scalar
     module procedure mpp_send_int4_2d
     module procedure mpp_send_int4_3d
     module procedure mpp_send_int4_4d
     module procedure mpp_send_int4_5d
     module procedure mpp_send_logical4
     module procedure mpp_send_logical4_scalar
     module procedure mpp_send_logical4_2d
     module procedure mpp_send_logical4_3d
     module procedure mpp_send_logical4_4d
     module procedure mpp_send_logical4_5d
  end interface

  ! <INTERFACE NAME="mpp_broadcast">

  !   <OVERVIEW>
  !     Parallel broadcasts.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     The <TT>mpp_broadcast</TT> call has been added because the original
  !     syntax (using <TT>ALL_PES</TT> in <TT>mpp_transmit</TT>) did not
  !     support a broadcast across a pelist.
  !
  !     <TT>MPP_TYPE_</TT> corresponds to any 4-byte and 8-byte variant of
  !     <TT>integer, real, complex, logical</TT> variables, of rank 0 or 1. A
  !     contiguous block from a multi-dimensional array may be passed by its
  !     starting address and its length, as in <TT>f77</TT>.
  !
  !     Global broadcasts through the <TT>ALL_PES</TT> argument to <LINK
  !     SRC="#mpp_transmit"><TT>mpp_transmit</TT></LINK> are still provided for
  !     backward-compatibility.
  !
  !     If <TT>pelist</TT> is omitted, the context is assumed to be the
  !     current pelist. <TT>from_pe</TT> must belong to the current
  !     pelist. This call implies synchronization across the PEs in
  !     <TT>pelist</TT>, or the current pelist if <TT>pelist</TT> is absent.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call mpp_broadcast( data, length, from_pe, pelist )
  !   </TEMPLATE>
  !   <IN NAME="length"> </IN>
  !   <IN NAME="from_pe"> </IN>
  !   <IN NAME="pelist"> </IN>
  !   <INOUT NAME="data(*)"> </INOUT>
  ! </INTERFACE>
  interface mpp_broadcast
     module procedure mpp_broadcast_char
     module procedure mpp_broadcast_real8
     module procedure mpp_broadcast_real8_scalar
     module procedure mpp_broadcast_real8_2d
     module procedure mpp_broadcast_real8_3d
     module procedure mpp_broadcast_real8_4d
     module procedure mpp_broadcast_real8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_broadcast_cmplx8
     module procedure mpp_broadcast_cmplx8_scalar
     module procedure mpp_broadcast_cmplx8_2d
     module procedure mpp_broadcast_cmplx8_3d
     module procedure mpp_broadcast_cmplx8_4d
     module procedure mpp_broadcast_cmplx8_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_broadcast_int8
     module procedure mpp_broadcast_int8_scalar
     module procedure mpp_broadcast_int8_2d
     module procedure mpp_broadcast_int8_3d
     module procedure mpp_broadcast_int8_4d
     module procedure mpp_broadcast_int8_5d
     module procedure mpp_broadcast_logical8
     module procedure mpp_broadcast_logical8_scalar
     module procedure mpp_broadcast_logical8_2d
     module procedure mpp_broadcast_logical8_3d
     module procedure mpp_broadcast_logical8_4d
     module procedure mpp_broadcast_logical8_5d
#endif

     module procedure mpp_broadcast_real4
     module procedure mpp_broadcast_real4_scalar
     module procedure mpp_broadcast_real4_2d
     module procedure mpp_broadcast_real4_3d
     module procedure mpp_broadcast_real4_4d
     module procedure mpp_broadcast_real4_5d

#ifdef OVERLOAD_C4
     module procedure mpp_broadcast_cmplx4
     module procedure mpp_broadcast_cmplx4_scalar
     module procedure mpp_broadcast_cmplx4_2d
     module procedure mpp_broadcast_cmplx4_3d
     module procedure mpp_broadcast_cmplx4_4d
     module procedure mpp_broadcast_cmplx4_5d
#endif
     module procedure mpp_broadcast_int4
     module procedure mpp_broadcast_int4_scalar
     module procedure mpp_broadcast_int4_2d
     module procedure mpp_broadcast_int4_3d
     module procedure mpp_broadcast_int4_4d
     module procedure mpp_broadcast_int4_5d
     module procedure mpp_broadcast_logical4
     module procedure mpp_broadcast_logical4_scalar
     module procedure mpp_broadcast_logical4_2d
     module procedure mpp_broadcast_logical4_3d
     module procedure mpp_broadcast_logical4_4d
     module procedure mpp_broadcast_logical4_5d
  end interface

  !#####################################################################
  ! <INTERFACE NAME="mpp_chksum">

  !   <OVERVIEW>
  !     Parallel checksums.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     <TT>mpp_chksum</TT> is a parallel checksum routine that returns an
  !     identical answer for the same array irrespective of how it has been
  !     partitioned across processors. <TT>LONG_KIND</TT>is the <TT>KIND</TT>
  !     parameter corresponding to long integers (see discussion on
  !     OS-dependent preprocessor directives) defined in
  !     the header file <TT>fms_platform.h</TT>. <TT>MPP_TYPE_</TT> corresponds to any
  !     4-byte and 8-byte variant of <TT>integer, real, complex, logical</TT>
  !     variables, of rank 0 to 5.
  !
  !     Integer checksums on FP data use the F90 <TT>TRANSFER()</TT>
  !     intrinsic.
  !
  !     The <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/chksum/chksum.html">serial checksum module</LINK> is superseded
  !     by this function, and is no longer being actively maintained. This
  !     provides identical results on a single-processor job, and to perform
  !     serial checksums on a single processor of a parallel job, you only
  !     need to use the optional <TT>pelist</TT> argument.
  !     <PRE>
  !     use mpp_mod
  !     integer :: pe, chksum
  !     real :: a(:)
  !     pe = mpp_pe()
  !     chksum = mpp_chksum( a, (/pe/) )
  !     </PRE>
  !
  !     The additional functionality of <TT>mpp_chksum</TT> over
  !     serial checksums is to compute the checksum across the PEs in
  !     <TT>pelist</TT>. The answer is guaranteed to be the same for
  !     the same distributed array irrespective of how it has been
  !     partitioned.
  !
  !     If <TT>pelist</TT> is omitted, the context is assumed to be the
  !     current pelist. This call implies synchronization across the PEs in
  !     <TT>pelist</TT>, or the current pelist if <TT>pelist</TT> is absent.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     mpp_chksum( var, pelist )
  !   </TEMPLATE>
  !   <IN NAME="pelist" TYPE="integer" DIM="(:)"> </IN>
  !   <IN NAME="var" TYPE="MPP_TYPE_"> </IN>
  ! </INTERFACE>
  interface mpp_chksum
#ifndef no_8byte_integers
     module procedure mpp_chksum_i8_1d
     module procedure mpp_chksum_i8_2d
     module procedure mpp_chksum_i8_3d
     module procedure mpp_chksum_i8_4d
#endif
     module procedure mpp_chksum_i4_1d
     module procedure mpp_chksum_i4_2d
     module procedure mpp_chksum_i4_3d
     module procedure mpp_chksum_i4_4d
     module procedure mpp_chksum_r8_0d
     module procedure mpp_chksum_r8_1d
     module procedure mpp_chksum_r8_2d
     module procedure mpp_chksum_r8_3d
     module procedure mpp_chksum_r8_4d
     module procedure mpp_chksum_r8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_chksum_c8_0d
     module procedure mpp_chksum_c8_1d
     module procedure mpp_chksum_c8_2d
     module procedure mpp_chksum_c8_3d
     module procedure mpp_chksum_c8_4d
     module procedure mpp_chksum_c8_5d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_chksum_r4_0d
     module procedure mpp_chksum_r4_1d
     module procedure mpp_chksum_r4_2d
     module procedure mpp_chksum_r4_3d
     module procedure mpp_chksum_r4_4d
     module procedure mpp_chksum_r4_5d
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_chksum_c4_0d
     module procedure mpp_chksum_c4_1d
     module procedure mpp_chksum_c4_2d
     module procedure mpp_chksum_c4_3d
     module procedure mpp_chksum_c4_4d
     module procedure mpp_chksum_c4_5d
#endif
  end interface

!***********************************************************************
!
!            module variables 
!
!***********************************************************************
  type(communicator),save :: peset(0:PESET_MAX) !0 is a dummy used to hold single-PE "self" communicator
  logical              :: module_is_initialized = .false.
  logical              :: debug = .false.
  integer              :: npes=1, root_pe=0, pe=0
  integer(LONG_KIND)   :: tick, ticks_per_sec, max_ticks, start_tick, end_tick, tick0=0
  integer              :: mpp_comm_private
  logical              :: first_call_system_clock_mpi=.TRUE.
  real(DOUBLE_KIND)    :: mpi_count0=0  ! use to prevent integer overflow
  real(DOUBLE_KIND)    :: mpi_tick_rate=0.d0  ! clock rate for mpi_wtick()
  logical              :: mpp_record_timing_data=.TRUE.
  type(clock),save     :: clocks(MAX_CLOCKS)
  integer              :: log_unit, etc_unit
  character(len=32)    :: configfile='logfile'
  integer              :: peset_num=0, current_peset_num=0
  integer              :: world_peset_num                  !the world communicator
  integer              :: error
  integer              :: clock_num=0, num_clock_ids=0,current_clock=0, previous_clock(MAX_CLOCKS)=0
  real                 :: tick_rate
  integer, allocatable :: request(:)
  integer, allocatable :: request_recv(:)
! if you want to save the non-root PE information uncomment out the following line
! and comment out the assigment of etcfile to '/dev/null'
#ifdef NO_DEV_NULL
  character(len=32)    :: etcfile='._mpp.nonrootpe.msgs'
#else
  character(len=32)    :: etcfile='/dev/null'
#endif

#ifdef SGICRAY
  integer :: in_unit=100, out_unit=101, err_unit=102 !see intro_io(3F): to see why these values are used rather than 5,6,0
#else
  integer :: in_unit=5, out_unit=6, err_unit=0
#endif

  !--- variables used in mpp_util.h
  type(Summary_Struct) :: clock_summary(MAX_CLOCKS)
  logical              :: warnings_are_fatal = .FALSE.
  integer              :: error_state=0
  integer              :: clock_grain=CLOCK_LOOP-1

  !--- variables used in mpp_comm.h
#ifdef use_libMPI
#ifdef _CRAYT3E
  !BWA: mpif.h on t3e currently does not contain MPI_INTEGER8 datatype
  !(O2k and t90 do)
  !(t3e: fixed on 3.3 I believe)
  integer, parameter :: MPI_INTEGER8=MPI_INTEGER
#endif
#endif /* use_libMPI */
#ifdef use_MPI_SMA
#include <mpp/shmem.fh>
  integer :: pSync(SHMEM_BARRIER_SYNC_SIZE)
  pointer( p_pSync, pSync ) !used by SHPALLOC
#endif

  integer            :: clock0    !measures total runtime from mpp_init to mpp_exit
  integer            :: mpp_stack_size=0, mpp_stack_hwm=0
  integer            :: tag=1
  logical            :: verbose=.FALSE.
#ifdef _CRAY
  integer(LONG_KIND) :: word(1)
#endif
#if defined(sgi_mipspro) || defined(__ia64)
  integer(INT_KIND)  :: word(1)
#endif

!***********************************************************************
!            variables needed for include/read_input_nml.inc
!
! parameter defining length of character variables 
  integer, parameter :: INPUT_STR_LENGTH = 256
! public variable needed for reading input.nml from an internal file
  character(len=INPUT_STR_LENGTH), dimension(:), allocatable, public :: input_nml_file
!***********************************************************************

  character(len=128), public :: version= &
       '$Id mpp.F90 $'
  character(len=128), public :: tagname= &
       '$Name: hiram_20101115_bw $'

  logical :: etc_unit_is_stderr = .false.
  namelist /mpp_nml/ etc_unit_is_stderr

  contains
#include <system_clock.h>
#include <mpp_util.inc>
#include <mpp_comm.inc>

  end module mpp_mod






module mpp_data_mod
#include <fms_platform.h>

#if defined(use_libMPI) && defined(sgi_mipspro)
  use mpi
#endif

  use mpp_parameter_mod, only : MAXPES

  implicit none
  private

  character(len=128), public :: version= &
       '$Id mpp_data.F90 $'
  character(len=128), public :: tagname= &
       '$Name: hiram_20101115_bw $'

#if defined(use_libSMA) || defined(use_MPI_SMA)
#include <mpp/shmem.fh>
#endif

#if defined(use_libMPI) && !defined(sgi_mipspro)
#include <mpif.h>  
!sgi_mipspro gets this from 'use mpi'
#endif

  !--- public data is used by mpp_mod
  public :: stat, mpp_stack, ptr_stack, status, ptr_status, sync, ptr_sync  
  public :: mpp_from_pe, ptr_from, remote_data_loc, ptr_remote

  !--- public data which is used by mpp_domains_mod. 
  !--- All othere modules should import these parameters from mpp_domains_mod. 
  public :: mpp_domains_stack, ptr_domains_stack

  !-------------------------------------------------------------------------------!
  ! The following data included in the .inc file are diffrent for sma or mpi case !
  !-------------------------------------------------------------------------------!

#ifdef use_libSMA
#include <mpp_data_sma.inc>
#else
#ifdef use_libMPI
#include <mpp_data_mpi.inc>
#else
#include <mpp_data_nocomm.inc>
#endif
#endif

end module mpp_data_mod


!-----------------------------------------------------------------------
!   Domain decomposition and domain update for message-passing codes
!
! AUTHOR: V. Balaji (vb@gfdl.gov)
!         SGI/GFDL Princeton University
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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.
!
! For the full text of the GNU General Public License,
! write to: Free Software Foundation, Inc.,
!           675 Mass Ave, Cambridge, MA 02139, USA.  
!-----------------------------------------------------------------------

! <CONTACT EMAIL="V.Balaji@noaa.gov">
!   V. Balaji
! </CONTACT>
! <CONTACT EMAIL="Zhi.Liang@noaa.gov">
!   Zhi Liang
! </CONTACT>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <RCSLOG SRC="http://www.gfdl.noaa.gov/~vb/changes_mpp_domains.html"/>

! <OVERVIEW>
!   <TT>mpp_domains_mod</TT> is a set of simple calls for domain
!   decomposition and domain updates on rectilinear grids. It requires the
!   module <LINK SRC="mpp.html">mpp_mod</LINK>, upon which it is built.
! </OVERVIEW>

! <DESCRIPTION>
!   Scalable implementations of finite-difference codes are generally
!   based on decomposing the model domain into subdomains that are
!   distributed among processors. These domains will then be obliged to
!   exchange data at their boundaries if data dependencies are merely
!   nearest-neighbour, or may need to acquire information from the global
!   domain if there are extended data dependencies, as in the spectral
!   transform. The domain decomposition is a key operation in the
!   development of parallel codes.
!   
!   <TT>mpp_domains_mod</TT> provides a domain decomposition and domain
!   update API for <I>rectilinear</I> grids, built on top of the <LINK
!   SRC="mpp.html">mpp_mod</LINK> API for message passing. Features
!   of <TT>mpp_domains_mod</TT> include:
! 
!   Simple, minimal API, with free access to underlying API for more complicated stuff.
!
!   Design toward typical use in climate/weather CFD codes.
!  
!   <H4>Domains</H4>
! 
!   I have assumed that domain decomposition will mainly be in 2
!   horizontal dimensions, which will in general be the two
!   fastest-varying indices. There is a separate implementation of 1D
!   decomposition on the fastest-varying index, and 1D decomposition on
!   the second index, treated as a special case of 2D decomposition, is
!   also possible. We define <I>domain</I> as the grid associated with a <I>task</I>.
!   We define the <I>compute domain</I> as the set of gridpoints that are
!   computed by a task, and the <I>data domain</I> as the set of points
!   that are required by the task for the calculation. There can in
!   general be more than 1 task per PE, though often
!   the number of domains is the same as the processor count. We define
!   the <I>global domain</I> as the global computational domain of the
!   entire model (i.e, the same as the computational domain if run on a
!   single processor). 2D domains are defined using a derived type <TT>domain2D</TT>,
!   constructed as follows (see comments in code for more details):
!   
!   <PRE>
!     type, public :: domain_axis_spec
!        private
!        integer :: begin, end, size, max_size
!        logical :: is_global
!     end type domain_axis_spec
!     type, public :: domain1D
!        private
!        type(domain_axis_spec) :: compute, data, global, active
!        logical :: mustputb, mustgetb, mustputf, mustgetf, folded
!        type(domain1D), pointer, dimension(:) :: list
!        integer :: pe              !PE to which this domain is assigned
!        integer :: pos
!     end type domain1D
!domaintypes of higher rank can be constructed from type domain1D
!typically we only need 1 and 2D, but could need higher (e.g 3D LES)
!some elements are repeated below if they are needed once per domain
!     type, public :: domain2D
!        private
!        type(domain1D) :: x
!        type(domain1D) :: y
!        type(domain2D), pointer, dimension(:) :: list
!        integer :: pe              !PE to which this domain is assigned
!        integer :: pos
!     end type domain2D
!     type(domain1D), public :: NULL_DOMAIN1D
!     type(domain2D), public :: NULL_DOMAIN2D
!   </PRE>

!   The <TT>domain2D</TT> type contains all the necessary information to
!   define the global, compute and data domains of each task, as well as the PE
!   associated with the task. The PEs from which remote data may be
!   acquired to update the data domain are also contained in a linked list
!   of neighbours.
! </DESCRIPTION>

module mpp_domains_mod
!a generalized domain decomposition package for use with mpp_mod
!Balaji (vb@gfdl.gov) 15 March 1999
  use mpp_parameter_mod,      only : MPP_DEBUG, MPP_VERBOSE, MPP_DOMAIN_TIME
  use mpp_parameter_mod,      only : GLOBAL_DATA_DOMAIN, CYCLIC_GLOBAL_DOMAIN, GLOBAL,CYCLIC 
  use mpp_parameter_mod,      only : AGRID, BGRID_SW, BGRID_NE, CGRID_NE, CGRID_SW, DGRID_NE, DGRID_SW
  use mpp_parameter_mod,      only : FOLD_WEST_EDGE, FOLD_EAST_EDGE, FOLD_SOUTH_EDGE, FOLD_NORTH_EDGE
  use mpp_parameter_mod,      only : WUPDATE, EUPDATE, SUPDATE, NUPDATE, XUPDATE, YUPDATE
  use mpp_parameter_mod,      only : NON_BITWISE_EXACT_SUM, BITWISE_EXACT_SUM, MPP_DOMAIN_TIME
  use mpp_parameter_mod,      only : CENTER, CORNER, SCALAR_PAIR, SCALAR_BIT
  use mpp_parameter_mod,      only : NORTH, NORTH_EAST, EAST, SOUTH_EAST
  use mpp_parameter_mod,      only : SOUTH, SOUTH_WEST, WEST, NORTH_WEST
  use mpp_parameter_mod,      only : MAX_DOMAIN_FIELDS, NULL_PE, DOMAIN_ID_BASE
  use mpp_parameter_mod,      only : ZERO, NINETY, MINUS_NINETY, ONE_HUNDRED_EIGHTY, MAX_TILES
  use mpp_parameter_mod,      only : EVENT_SEND, EVENT_RECV, ROOT_GLOBAL
  use mpp_data_mod,           only : mpp_domains_stack, ptr_domains_stack
  use mpp_mod,                only : mpp_pe, mpp_root_pe, mpp_npes, mpp_error, FATAL, WARNING, NOTE
  use mpp_mod,                only : stdout, stderr, stdlog, mpp_send, mpp_recv, mpp_transmit, mpp_sync_self
  use mpp_mod,                only : mpp_clock_id, mpp_clock_begin, mpp_clock_end
  use mpp_mod,                only : mpp_max, mpp_min, mpp_sum, mpp_get_current_pelist, mpp_broadcast
  use mpp_mod,                only : mpp_sync, mpp_init, mpp_malloc, lowercase
  use mpp_mod,                only : input_nml_file
  use mpp_memutils_mod,       only : mpp_memuse_begin, mpp_memuse_end
  use mpp_pset_mod, only: mpp_pset_init
  implicit none
  private

#include <fms_platform.h>

  !--- public paramters imported from mpp_domains_parameter_mod
  public :: GLOBAL_DATA_DOMAIN, CYCLIC_GLOBAL_DOMAIN, BGRID_NE, BGRID_SW, CGRID_NE, CGRID_SW
  public :: DGRID_NE, DGRID_SW, FOLD_WEST_EDGE, FOLD_EAST_EDGE, FOLD_SOUTH_EDGE, FOLD_NORTH_EDGE
  public :: WUPDATE, EUPDATE, SUPDATE, NUPDATE, XUPDATE, YUPDATE
  public :: NON_BITWISE_EXACT_SUM, BITWISE_EXACT_SUM, MPP_DOMAIN_TIME
  public :: CENTER, CORNER, SCALAR_PAIR
  public :: NORTH, NORTH_EAST, EAST, SOUTH_EAST
  public :: SOUTH, SOUTH_WEST, WEST, NORTH_WEST
  public :: ZERO, NINETY, MINUS_NINETY, ONE_HUNDRED_EIGHTY 

  !--- public data imported from mpp_data_mod
  public :: NULL_DOMAIN1D, NULL_DOMAIN2D

  public :: domain_axis_spec, domain1D, domain2D, DomainCommunicator2D

  !--- public interface from mpp_domains_util.h
  public :: mpp_domains_set_stack_size, mpp_get_compute_domain, mpp_get_compute_domains
  public :: mpp_get_data_domain, mpp_get_global_domain, mpp_get_domain_components
  public :: mpp_get_layout, mpp_get_pelist, operator(.EQ.), operator(.NE.) 
  public :: mpp_domain_is_symmetry
  public :: mpp_get_neighbor_pe, mpp_nullify_domain_list
  public :: mpp_set_compute_domain, mpp_set_data_domain, mpp_set_global_domain
  public :: mpp_get_memory_domain, mpp_get_domain_shift, mpp_domain_is_tile_root_pe
  public :: mpp_get_tile_id, mpp_get_domain_extents, mpp_get_current_ntile, mpp_get_ntile_count
  public :: mpp_get_refine_overlap_number, mpp_get_mosaic_refine_overlap
  public :: mpp_get_tile_list
  public :: mpp_get_tile_npes
  public :: mpp_get_num_overlap, mpp_get_overlap
  public :: mpp_get_io_domain, mpp_get_domain_pe, mpp_get_domain_tile_root_pe
  public :: mpp_get_domain_name, mpp_get_io_domain_layout
  public :: mpp_copy_domain, mpp_set_domain_symmetry
  public :: mpp_get_update_pelist, mpp_get_update_size
  public :: mpp_get_domain_npes

  !--- public interface from mpp_domains_reduce.h
  public :: mpp_global_field, mpp_global_max, mpp_global_min, mpp_global_sum
!  public :: mpp_global_sum_tl, mpp_global_sum_ad
  !--- public interface from mpp_domains_misc.h
  public :: mpp_broadcast_domain, mpp_domains_init, mpp_domains_exit, mpp_redistribute
  public :: mpp_update_domains, mpp_check_field
!  public :: mpp_update_domains_ad   ! bnc
  public :: mpp_get_boundary
  !--- public interface from mpp_domains_define.h
  public :: mpp_define_layout, mpp_define_domains, mpp_modify_domain, mpp_define_mosaic
  public :: mpp_define_mosaic_pelist, mpp_define_null_domain, mpp_mosaic_defined
  public :: mpp_define_io_domain, mpp_deallocate_domain
  public :: mpp_compute_extent

  integer, parameter :: NAME_LENGTH = 64
  integer, parameter :: MAXLIST = 8
 
  !--- data types used mpp_domains_mod.
  type domain_axis_spec        !type used to specify index limits along an axis of a domain
     private
     integer :: begin, end, size, max_size      !start, end of domain axis, size, max size in set
     logical :: is_global       !TRUE if domain axis extent covers global domain
  end type domain_axis_spec

  type domain1D
     private
     type(domain_axis_spec) :: compute, data, global, memory
     logical :: cyclic
     type(domain1D), pointer :: list(:) =>NULL()
     integer :: pe               !PE to which this domain is assigned
     integer :: pos              !position of this PE within link list, i.e domain%list(pos)%pe = pe
     integer :: goffset, loffset !needed for global sum
  end type domain1D

  type domain1D_spec
     private
     type(domain_axis_spec) :: compute
     integer                :: pos
  end type domain1D_spec
       
  type domain2D_spec
     private
     type(domain1D_spec), pointer :: x(:)       => NULL() ! x-direction domain decomposition
     type(domain1D_spec), pointer :: y(:)       => NULL() ! x-direction domain decomposition
     integer,        pointer :: tile_id(:) => NULL() ! tile id of each tile
     integer                 :: pe                   ! PE to which this domain is assigned
     integer                 :: pos                  ! position of this PE within link list
     integer                 :: tile_root_pe         ! root pe of tile.
  end type domain2D_spec

  type overlap_type
     private
     integer                  :: count = 0                 ! number of ovrelapping
     integer                  :: pe
     integer,         pointer :: tileMe(:)       => NULL() ! my tile id for this overlap
     integer,         pointer :: tileNbr(:)      => NULL() ! neighbor tile id for this overlap
     integer,         pointer :: is(:)           => NULL() ! starting i-index 
     integer,         pointer :: ie(:)           => NULL() ! ending   i-index 
     integer,         pointer :: js(:)           => NULL() ! starting j-index 
     integer,         pointer :: je(:)           => NULL() ! ending   j-index 
     integer,         pointer :: isMe(:)         => NULL() ! starting i-index of my tile on current pe
     integer,         pointer :: ieMe(:)         => NULL() ! ending   i-index of my tile on current pe
     integer,         pointer :: jsMe(:)         => NULL() ! starting j-index of my tile on current pe
     integer,         pointer :: jeMe(:)         => NULL() ! ending   j-index of my tile on current pe
     integer,         pointer :: dir(:)          => NULL() ! direction ( value 1,2,3,4 = E,S,W,N)
     integer,         pointer :: rotation(:)     => NULL() ! rotation angle.
     logical,         pointer :: is_refined(:)   => NULL() ! indicate if the overlap is refined or not.
     integer,         pointer :: index(:)        => NULL() ! for refinement
     logical,         pointer :: from_contact(:) => NULL() ! indicate if the overlap is computed from define_contact_overlap
  end type overlap_type

  type overlapSpec
     private
     integer                     :: whalo, ehalo, shalo, nhalo ! halo size
     integer                     :: xbegin, xend, ybegin, yend
     integer                     :: nsend, nrecv
     type(overlap_type), pointer :: send(:) => NULL()
     type(overlap_type), pointer :: recv(:) => NULL()
     type(refineSpec),   pointer :: rSpec(:)=> NULL()
     type(overlapSpec),  pointer :: next
  end type overlapSpec

  type tile_type
     integer :: xbegin, xend, ybegin, yend
  end type tile_type

  type refineSpec
     private
     integer          :: count                 ! number of ovrelapping
     integer          :: total                 ! total number of points to be saved in buffer.
     integer, pointer :: isMe(:)     => NULL() ! starting i-index on current pe and tile.
     integer, pointer :: ieMe(:)     => NULL() ! ending i-index on current pe and tile.
     integer, pointer :: jsMe(:)     => NULL() ! starting j-index on current pe and tile.
     integer, pointer :: jeMe(:)     => NULL() ! ending j-index on current pe and tile.
     integer, pointer :: isNbr(:)    => NULL() ! starting i-index on neighbor pe or tile
     integer, pointer :: ieNbr(:)    => NULL() ! ending i-index on neighbor pe or tile
     integer, pointer :: jsNbr(:)    => NULL() ! starting j-index on neighbor pe or tile
     integer, pointer :: jeNbr(:)    => NULL() ! ending j-index on neighbor pe or tile
     integer, pointer :: start(:)    => NULL() ! starting index in the buffer
     integer, pointer :: end(:)      => NULL() ! ending index in the buffer
     integer, pointer :: dir(:)      => NULL() ! direction 
     integer, pointer :: rotation(:) => NULL() ! rotation angle.
  end type refineSpec

!domaintypes of higher rank can be constructed from type domain1D
!typically we only need 1 and 2D, but could need higher (e.g 3D LES)
!some elements are repeated below if they are needed once per domain, not once per axis

  type domain2D
     private
     character(len=NAME_LENGTH)  :: name='unnamed'          ! name of the domain, default is "unspecified"
     integer(LONG_KIND)          :: id 
     integer                     :: pe                      ! PE to which this domain is assigned
     integer                     :: fold          
     integer                     :: pos                     ! position of this PE within link list
     logical                     :: symmetry                ! indicate the domain is symmetric or non-symmetric.
     integer                     :: whalo, ehalo            ! halo size in x-direction
     integer                     :: shalo, nhalo            ! halo size in y-direction
     integer                     :: ntiles                  ! number of tiles within mosaic
     integer                     :: max_ntile_pe            ! maximum value in the pelist of number of tiles on each pe.
     integer                     :: ncontacts               ! number of contact region within mosaic.
     logical                     :: rotated_ninety          ! indicate if any contact rotate NINETY or MINUS_NINETY
     logical                     :: initialized=.FALSE.     ! indicate if the overlapping is computed or not.
     integer                     :: tile_root_pe            ! root pe of current tile.
     integer                     :: io_layout(2)            ! io_layout, will be set through mpp_define_io_domain
                                                            ! default = domain layout
     integer,            pointer :: pearray(:,:)  => NULL() ! pe of each layout position 
     integer,            pointer :: tile_id(:)    => NULL() ! tile id of each tile
     type(domain1D),     pointer :: x(:)          => NULL() ! x-direction domain decomposition
     type(domain1D),     pointer :: y(:)          => NULL() ! y-direction domain decomposition
     type(domain2D_spec),pointer :: list(:)       => NULL() ! domain decomposition on pe list
     type(tile_type),    pointer :: tileList(:)   => NULL() ! store tile information
     type(overlapSpec),  pointer :: check_C       => NULL() ! send and recv information for boundary consistency check of C-cell
     type(overlapSpec),  pointer :: check_E       => NULL() ! send and recv information for boundary consistency check of E-cell
     type(overlapSpec),  pointer :: check_N       => NULL() ! send and recv information for boundary consistency check of N-cell
     type(overlapSpec),  pointer :: bound_C       => NULL() ! send information for getting boundary value for symmetry domain.
     type(overlapSpec),  pointer :: bound_E       => NULL() ! send information for getting boundary value for symmetry domain.
     type(overlapSpec),  pointer :: bound_N       => NULL() ! send information for getting boundary value for symmetry domain.
     type(overlapSpec),  pointer :: update_T      => NULL() ! send and recv information for halo update of T-cell.
     type(overlapSpec),  pointer :: update_E      => NULL() ! send and recv information for halo update of E-cell.
     type(overlapSpec),  pointer :: update_C      => NULL() ! send and recv information for halo update of C-cell.
     type(overlapSpec),  pointer :: update_N      => NULL() ! send and recv information for halo update of N-cell.
     type(domain2d),     pointer :: io_domain     => NULL() ! domain for IO, will be set through calling mpp_set_io_domain ( this will be changed).
  end type domain2D     

  !--- the following type is used to reprsent the contact between tiles.
  !--- this type will only be used in mpp_domains_define.inc
  type contact_type
     private
     integer          :: ncontact                               ! number of neighbor tile.
     integer, pointer :: tile(:) =>NULL()                      ! neighbor tile 
     integer, pointer :: align1(:)=>NULL(), align2(:)=>NULL()   ! alignment of me and neighbor
     real,    pointer :: refine1(:)=>NULL(), refine2(:)=>NULL() !
     integer, pointer :: is1(:)=>NULL(), ie1(:)=>NULL()         ! i-index of current tile repsenting contact
     integer, pointer :: js1(:)=>NULL(), je1(:)=>NULL()         ! j-index of current tile repsenting contact
     integer, pointer :: is2(:)=>NULL(), ie2(:)=>NULL()         ! i-index of neighbor tile repsenting contact
     integer, pointer :: js2(:)=>NULL(), je2(:)=>NULL()         ! j-index of neighbor tile repsenting contact
  end type contact_type


  type DomainCommunicator2D
     private
     logical            :: initialized=.false.
     integer(LONG_KIND) :: id=-9999
     integer(LONG_KIND) :: l_addr  =-9999
     integer(LONG_KIND) :: l_addrx =-9999
     integer(LONG_KIND) :: l_addry =-9999
     type(domain2D), pointer :: domain     =>NULL()
     type(domain2D), pointer :: domain_in  =>NULL()
     type(domain2D), pointer :: domain_out =>NULL()
     type(overlapSpec), pointer :: send(:,:,:,:) => NULL()
     type(overlapSpec), pointer :: recv(:,:,:,:) => NULL()
     integer, dimension(:,:),       _ALLOCATABLE :: sendis _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: sendie _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: sendjs _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: sendje _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: recvis _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: recvie _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: recvjs _NULL
     integer, dimension(:,:),       _ALLOCATABLE :: recvje _NULL
     logical, dimension(:),         _ALLOCATABLE :: S_do_buf _NULL
     logical, dimension(:),         _ALLOCATABLE :: R_do_buf _NULL
     integer, dimension(:),         _ALLOCATABLE :: cto_pe  _NULL
     integer, dimension(:),         _ALLOCATABLE :: cfrom_pe  _NULL
     integer, dimension(:),         _ALLOCATABLE :: S_msize _NULL
     integer, dimension(:),         _ALLOCATABLE :: R_msize _NULL
     integer :: Slist_size=0, Rlist_size=0
     integer :: isize=0, jsize=0, ke=0
     integer :: isize_in=0, jsize_in=0
     integer :: isize_out=0, jsize_out=0
     integer :: isize_max=0, jsize_max=0
     integer :: gf_ioff=0, gf_joff=0
  ! Remote data
     integer, dimension(:)  , _ALLOCATABLE :: isizeR _NULL
     integer, dimension(:)  , _ALLOCATABLE :: jsizeR _NULL
     integer, dimension(:,:), _ALLOCATABLE :: sendisR _NULL
     integer, dimension(:,:), _ALLOCATABLE :: sendjsR _NULL
     integer(LONG_KIND), dimension(:), _ALLOCATABLE :: rem_addr  _NULL
     integer(LONG_KIND), dimension(:), _ALLOCATABLE :: rem_addrx _NULL
     integer(LONG_KIND), dimension(:), _ALLOCATABLE :: rem_addry _NULL
     integer(LONG_KIND), dimension(:,:), _ALLOCATABLE :: rem_addrl  _NULL
     integer(LONG_KIND), dimension(:,:), _ALLOCATABLE :: rem_addrlx  _NULL
     integer(LONG_KIND), dimension(:,:), _ALLOCATABLE :: rem_addrly  _NULL
     integer                             :: position        ! data location. T, E, C, or N.
  end type DomainCommunicator2D

!#######################################################################

!***********************************************************************
!
!     module variables 
!
!***********************************************************************
  integer             :: pe
  logical             :: module_is_initialized = .false.
  logical             :: debug                 = .FALSE.
  logical             :: verbose=.FALSE.
  logical             :: mosaic_defined = .false.
  integer             :: mpp_domains_stack_size=0
  integer             :: mpp_domains_stack_hwm=0
  type(domain1D),save :: NULL_DOMAIN1D
  type(domain2D),save :: NULL_DOMAIN2D

  !-------- The following variables are used in mpp_domains_comm.h
  
  integer, parameter :: MAX_ADDRS=512
  integer(LONG_KIND),dimension(MAX_ADDRS),save :: addrs_sorted=-9999  ! list of sorted local addrs
  integer,           dimension(-1:MAX_ADDRS),save :: addrs_idx=-9999  ! idx of addr assoicated w/ d_comm
  integer,           dimension(MAX_ADDRS),save :: a_salvage=-9999     ! freed idx list of addr
  integer,                                save :: a_sort_len=0        ! len sorted memory list
  integer,                                save :: n_addrs=0           ! num memory addresses used

  integer(LONG_KIND), parameter :: ADDR2_BASE=Z'0000000000010000'
  integer, parameter :: MAX_ADDRS2=128
  integer(LONG_KIND),dimension(MAX_ADDRS2),save :: addrs2_sorted=-9999  ! list of sorted local addrs
  integer,           dimension(-1:MAX_ADDRS2),save :: addrs2_idx=-9999  ! idx of addr2 assoicated w/ d_comm
  integer,           dimension(MAX_ADDRS2),save :: a2_salvage=-9999     ! freed indices of addr2
  integer,                                 save :: a2_sort_len=0        ! len sorted memory list
  integer,                                 save :: n_addrs2=0           ! num memory addresses used

  integer, parameter :: MAX_DOM_IDS=128
  integer(LONG_KIND),dimension(MAX_DOM_IDS),save :: ids_sorted=-9999 ! list of sorted domain identifiers
  integer,           dimension(-1:MAX_DOM_IDS),save :: ids_idx=-9999 ! idx of d_comm associated w/ sorted addr
  integer,                                  save :: i_sort_len=0     ! len sorted domain ids list
  integer,                                  save :: n_ids=0          ! num domain ids used (=i_sort_len; dom ids never removed)

  integer, parameter :: MAX_FIELDS=1024
  integer(LONG_KIND),        dimension(MAX_FIELDS),save           :: dcKey_sorted=-9999  ! list of sorted local addrs
  !     Not sure why static d_comm fails during deallocation of derived type members; allocatable works
  !     type(DomainCommunicator2D),dimension(MAX_FIELDS),save,target    :: d_comm              ! domain communicators
  type(DomainCommunicator2D),dimension(:),allocatable,save,target :: d_comm              ! domain communicators
  integer,                   dimension(-1:MAX_FIELDS),save           :: d_comm_idx=-9999 ! idx of d_comm associated w/ sorted addr
  integer,                   dimension(MAX_FIELDS),save           :: dc_salvage=-9999    ! freed indices of d_comm
  integer,                                         save           :: dc_sort_len=0       ! len sorted comm keys (=num active communicators)
  integer,                                         save           :: n_comm=0            ! num communicators used

  !     integer(LONG_KIND), parameter :: GT_BASE=2**8
  integer(LONG_KIND), parameter :: GT_BASE=Z'0000000000000100'  ! Workaround for 64bit int init problem

  !     integer(LONG_KIND), parameter :: KE_BASE=2**48
  integer(LONG_KIND), parameter :: KE_BASE=Z'0001000000000000'  ! Workaround for 64bit int init problem

  integer, parameter :: MAXOVERLAP = 100 

  integer(LONG_KIND) :: domain_cnt=0

  !--- the following variables are used in mpp_domains_misc.h
  logical :: domain_clocks_on=.FALSE.
  integer :: send_clock=0, recv_clock=0, unpk_clock=0
  integer :: wait_clock=0, pack_clock=0, pack_loop_clock=0

  !--- namelist interface
! <NAMELIST NAME="mpp_domains_nml">
!   <DATA NAME="debug_update_domain" TYPE="character(len=32)"  DEFAULT="none">
!     when debug_update_domain = none, no debug will be done. When debug_update_domain is set to fatal, 
!     the run will be exited with fatal error message. When debug_update_domain is set to 
!     warning, the run will output warning message. when debug update_domain is set to 
!     note, the run will output some note message. Will check the consistency on the boundary between
!     processor/tile when updating doamin for symmetric domain and check the consistency on the north
!     folded edge. 
!   </DATA>
! </NAMELIST>
  character(len=32) :: debug_update_domain = "none"
  logical           :: debug_message_passing = .false.
  namelist /mpp_domains_nml/ debug_update_domain, domain_clocks_on, debug_message_passing

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

  integer, parameter :: NO_CHECK = -1
  integer            :: debug_update_level = NO_CHECK
!***********************************************************************
!
!         public interface from mpp_domains_define.h
!
!***********************************************************************

  ! <INTERFACE NAME="mpp_define_layout">
  !  <OVERVIEW>
  !    Retrieve layout associated with a domain decomposition.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    Given a global 2D domain and the number of divisions in the
  !    decomposition (<TT>ndivs</TT>: usually the PE count unless some
  !    domains are masked) this calls returns a 2D domain layout.
  !    
  !    By default, <TT>mpp_define_layout</TT> will attempt to divide the
  !    2D index space into domains that maintain the aspect ratio of the
  !    global domain. If this cannot be done, the algorithm favours domains
  !    that are longer in <TT>x</TT> than <TT>y</TT>, a preference that could
  !    improve vector performance.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_define_layout( global_indices, ndivs, layout )
  !  </TEMPLATE>
  !  <IN NAME="global_indices"></IN>
  !  <IN NAME="ndivs"></IN>
  !  <OUT NAME="layout"></OUT>
  ! </INTERFACE>

  interface mpp_define_layout
     module procedure mpp_define_layout2D
  end interface


  ! <INTERFACE NAME="mpp_define_domains">

  !   <OVERVIEW>
  !     Set up a domain decomposition.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     There are two forms for the <TT>mpp_define_domains</TT> call. The 2D
  !     version is generally to be used but is built by repeated calls to the
  !     1D version, also provided.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call mpp_define_domains( global_indices, ndivs, domain, &
  !                                   pelist, flags, halo, extent, maskmap )
  !   </TEMPLATE>
  !  <TEMPLATE>
  !    call mpp_define_domains( global_indices, layout, domain, pelist, &
  !                                   xflags, yflags, xhalo, yhalo,           &
  !                                   xextent, yextent, maskmap, name )
  !  </TEMPLATE>
  !   <IN NAME="global_indices" >
  !     Defines the global domain.
  !   </IN>
  !   <IN NAME="ndivs">
  !     Is the number of domain divisions required.
  !   </IN>
  !   <INOUT NAME="domain">
  !     Holds the resulting domain decomposition.
  !   </INOUT>
  !   <IN NAME="pelist">
  !     List of PEs to which the domains are to be assigned.
  !   </IN>
  !   <IN NAME="flags">
  !      An optional flag to pass additional information
  !      about the desired domain topology. Useful flags in a 1D decomposition
  !      include <TT>GLOBAL_DATA_DOMAIN</TT> and
  !      <TT>CYCLIC_GLOBAL_DOMAIN</TT>. Flags are integers: multiple flags may
  !      be added together. The flag values are public parameters available by
  !      use association.
  !   </IN>
  !   <IN NAME="halo">
  !     Width of the halo.
  !   </IN>
  !   <IN NAME="extent">
  !      Normally <TT>mpp_define_domains</TT> attempts
  !      an even division of the global domain across <TT>ndivs</TT>
  !      domains. The <TT>extent</TT> array can be used by the user to pass a
  !      custom domain division. The <TT>extent</TT> array has <TT>ndivs</TT>
  !      elements and holds the compute domain widths, which should add up to
  !      cover the global domain exactly.
  !   </IN>
  !   <IN NAME="maskmap">
  !     Some divisions may be masked
  !     (<TT>maskmap=.FALSE.</TT>) to exclude them from the computation (e.g
  !     for ocean model domains that are all land). The <TT>maskmap</TT> array
  !     is dimensioned <TT>ndivs</TT> and contains <TT>.TRUE.</TT> values for
  !     any domain that must be <I>included</I> in the computation (default
  !     all). The <TT>pelist</TT> array length should match the number of
  !     domains included in the computation.
  !    </IN>   

  !  <IN NAME="layout"></IN>
  !  <IN NAME="xflags, yflags"></IN>
  !  <IN NAME="xhalo, yhalo"></IN>
  !  <IN NAME="xextent, yextent"></IN>
  !  <IN NAME="name" ></IN>

  !  <NOTE>    
  !    For example:
  !    
  !    <PRE>
  !    call mpp_define_domains( (/1,100/), 10, domain, &
  !         flags=GLOBAL_DATA_DOMAIN+CYCLIC_GLOBAL_DOMAIN, halo=2 )
  !    </PRE>
  !    
  !    defines 10 compute domains spanning the range [1,100] of the global
  !    domain. The compute domains are non-overlapping blocks of 10. All the data
  !    domains are global, and with a halo of 2 span the range [-1:102]. And
  !    since the global domain has been declared to be cyclic,
  !    <TT>domain(9)%next => domain(0)</TT> and <TT>domain(0)%prev =>
  !    domain(9)</TT>. A field is allocated on the data domain, and computations proceed on
  !    the compute domain. A call to <LINK
  !    SRC="#mpp_update_domains"><TT>mpp_update_domains</TT></LINK> would fill in
  !    the values in the halo region:

  !    <PRE>
  !    call mpp_get_data_domain( domain, isd, ied ) !returns -1 and 102
  !    call mpp_get_compute_domain( domain, is, ie ) !returns (1,10) on PE 0 ...
  !    allocate( a(isd:ied) )
  !    do i = is,ie
  !       a(i) = &lt;perform computations&gt;
  !    end do
  !    call mpp_update_domains( a, domain )
  !    </PRE>

  !    The call to <TT>mpp_update_domains</TT> fills in the regions outside
  !    the compute domain. Since the global domain is cyclic, the values at
  !    <TT>i=(-1,0)</TT> are the same as at <TT>i=(99,100)</TT>; and
  !    <TT>i=(101,102)</TT> are the same as <TT>i=(1,2)</TT>.
  !    
  !    The 2D version is just an extension of this syntax to two
  !    dimensions.
  !
  !    The 2D version of the above should generally be used in
  !    codes, including 1D-decomposed ones, if there is a possibility of
  !    future evolution toward 2D decomposition. The arguments are similar to
  !    the 1D case, except that now we have optional arguments
  !    <TT>flags</TT>, <TT>halo</TT>, <TT>extent</TT> and <TT>maskmap</TT>
  !    along two axes.
  !    
  !    <TT>flags</TT> can now take an additional possible value to fold
  !    one or more edges. This is done by using flags
  !    <TT>FOLD_WEST_EDGE</TT>, <TT>FOLD_EAST_EDGE</TT>,
  !    <TT>FOLD_SOUTH_EDGE</TT> or <TT>FOLD_NORTH_EDGE</TT>. When a fold
  !    exists (e.g cylindrical domain), vector fields reverse sign upon
  !    crossing the fold. This parity reversal is performed only in the
  !    vector version of <LINK
  !    SRC="#mpp_update_domains"><TT>mpp_update_domains</TT></LINK>. In
  !    addition, shift operations may need to be applied to vector fields on
  !    staggered grids, also described in the vector interface to
  !    <TT>mpp_update_domains</TT>.
  !    
  !    <TT>name</TT> is the name associated with the decomposition,
  !    e.g <TT>'Ocean model'</TT>. If this argument is present,
  !    <TT>mpp_define_domains</TT> will print the domain decomposition
  !    generated to <TT>stdlog</TT>.
  !    
  !    Examples:
  !    
  !    <PRE>
  !    call mpp_define_domains( (/1,100,1,100/), (/2,2/), domain, xhalo=1 )
  !    </PRE>
  !    
  !    will create the following domain layout:
  !    <PRE>
  !                   |---------|-----------|-----------|-------------|
  !                   |domain(1)|domain(2)  |domain(3)  |domain(4)    |
  !    |--------------|---------|-----------|-----------|-------------|
  !    |Compute domain|1,50,1,50|51,100,1,50|1,50,51,100|51,100,51,100|
  !    |--------------|---------|-----------|-----------|-------------|
  !    |Data domain   |0,51,1,50|50,101,1,50|0,51,51,100|50,101,51,100|
  !    |--------------|---------|-----------|-----------|-------------|
  !    </PRE>
  !    
  !    Again, we allocate arrays on the data domain, perform computations
  !    on the compute domain, and call <TT>mpp_update_domains</TT> to update
  !    the halo region.
  !    
  !    If we wished to perfom a 1D decomposition along <TT>Y</TT>
  !    on the same global domain, we could use:

  !    <PRE>
  !    call mpp_define_domains( (/1,100,1,100/), layout=(/4,1/), domain, xhalo=1 )
  !    </PRE>

  !    This will create the following domain layout:
  !    <PRE>
  !                   |----------|-----------|-----------|------------|
  !                   |domain(1) |domain(2)  |domain(3)  |domain(4)   |
  !    |--------------|----------|-----------|-----------|------------|
  !    |Compute domain|1,100,1,25|1,100,26,50|1,100,51,75|1,100,76,100|
  !    |--------------|----------|-----------|-----------|------------|
  !    |Data domain   |0,101,1,25|0,101,26,50|0,101,51,75|1,101,76,100|
  !    |--------------|----------|-----------|-----------|------------|
  !    </PRE>
  !   </NOTE>
  ! </INTERFACE>
  interface mpp_define_domains
     module procedure mpp_define_domains1D
     module procedure mpp_define_domains2D
  end interface

  interface mpp_define_null_domain
     module procedure mpp_define_null_domain1D
     module procedure mpp_define_null_domain2D
  end interface

  interface mpp_copy_domain
     module procedure mpp_copy_domain1D
     module procedure mpp_copy_domain2D
  end interface mpp_copy_domain

  interface mpp_deallocate_domain 
     module procedure mpp_deallocate_domain1D
     module procedure mpp_deallocate_domain2D
  end interface

! <INTERFACE NAME="mpp_modify_domain">
!   <OVERVIEW>
!     modifies the extents (compute, data and global) of domain
!   </OVERVIEW>
!   <IN NAME="domain_in">
!     The source domain.
!   </IN>
!   <IN NAME="halo">
!     Halo size of the returned 1D doamin. Default value is 0.
!   </IN>
!   <IN NAME="cbegin,cend">
!    Axis specifications associated with the compute domain of the returned 1D domain.
!   </IN>
!   <IN NAME="gbegin,gend">
!    Axis specifications associated with the global domain of the returned 1D domain.
!   </IN>
!   <IN NAME="isc,iec">
!    Zonal axis specifications associated with the compute domain of the returned 2D domain.
!   </IN>
!   <IN NAME="jsc,jec">
!    Meridinal axis specifications associated with the compute domain of the returned 2D domain.
!   </IN>
!   <IN NAME="isg,ieg">
!    Zonal axis specifications associated with the global domain of the returned 2D domain.
!   </IN>
!   <IN NAME="jsg,jeg">
!    Meridinal axis specifications associated with the global domain of the returned 2D domain.
!   </IN>
!   <IN NAME="xhalo,yhalo">
!     Halo size of the returned 2D doamin. Default value is 0.
!   </IN>
!   <INOUT NAME="domain_out">
!     The returned domain.
!   </INOUT>

! </INTERFACE>

  interface mpp_modify_domain
     module procedure mpp_modify_domain1D
     module procedure mpp_modify_domain2D
  end interface


!***********************************************************************
!
!        public interface from mpp_domains_misc.h
!
!***********************************************************************

! <INTERFACE NAME="mpp_update_domains">
!  <OVERVIEW>
!     Halo updates.
!  </OVERVIEW>
!  <DESCRIPTION>
!    <TT>mpp_update_domains</TT> is used to perform a halo update of a
!    domain-decomposed array on each PE. <TT>MPP_TYPE_</TT> can be of type
!    <TT>complex</TT>, <TT>integer</TT>, <TT>logical</TT> or <TT>real</TT>;
!    of 4-byte or 8-byte kind; of rank up to 5. The vector version (with
!    two input data fields) is only present for <TT>real</TT> types.
!    
!    For 2D domain updates, if there are halos present along both
!    <TT>x</TT> and <TT>y</TT>, we can choose to update one only, by
!    specifying <TT>flags=XUPDATE</TT> or <TT>flags=YUPDATE</TT>. In
!    addition, one-sided updates can be performed by setting <TT>flags</TT>
!    to any combination of <TT>WUPDATE</TT>, <TT>EUPDATE</TT>,
!    <TT>SUPDATE</TT> and <TT>NUPDATE</TT>, to update the west, east, north
!    and south halos respectively. Any combination of halos may be used by
!    adding the requisite flags, e.g: <TT>flags=XUPDATE+SUPDATE</TT> or
!    <TT>flags=EUPDATE+WUPDATE+SUPDATE</TT> will update the east, west and
!    south halos.
!    
!    If a call to <TT>mpp_update_domains</TT> involves at least one E-W
!    halo and one N-S halo, the corners involved will also be updated, i.e,
!    in the example above, the SE and SW corners will be updated.
!    
!    If <TT>flags</TT> is not supplied, that is
!    equivalent to <TT>flags=XUPDATE+YUPDATE</TT>.
!    
!    The vector version is passed the <TT>x</TT> and <TT>y</TT>
!    components of a vector field in tandem, and both are updated upon
!    return. They are passed together to treat parity issues on various
!    grids. For example, on a cubic sphere projection, the <TT>x</TT> and
!    <TT>y</TT> components may be interchanged when passing from an
!    equatorial cube face to a polar face. For grids with folds, vector
!    components change sign on crossing the fold.  Paired scalar quantities
!    can also be passed with the vector version if flags=SCALAR_PAIR, in which
!    case components are appropriately interchanged, but signs are not.
!    
!    Special treatment at boundaries such as folds is also required for
!    staggered grids. The following types of staggered grids are
!    recognized:
!    
!    1) <TT>AGRID</TT>: values are at grid centers.<BR/>
!    2) <TT>BGRID_NE</TT>: vector fields are at the NE vertex of a grid
!    cell, i.e: the array elements <TT>u(i,j)</TT> and <TT>v(i,j)</TT> are
!    actually at (i+&#189;,j+&#189;) with respect to the grid centers.<BR/>
!    3) <TT>BGRID_SW</TT>: vector fields are at the SW vertex of a grid
!    cell, i.e: the array elements <TT>u(i,j)</TT> and <TT>v(i,j)</TT> are
!    actually at (i-&#189;,j-&#189;) with respect to the grid centers.<BR/>
!    4) <TT>CGRID_NE</TT>: vector fields are at the N and E faces of a
!    grid cell, i.e: the array elements <TT>u(i,j)</TT> and <TT>v(i,j)</TT>
!    are actually at (i+&#189;,j) and (i,j+&#189;) with respect to the
!    grid centers.<BR/>
!    5) <TT>CGRID_SW</TT>: vector fields are at the S and W faces of a
!    grid cell, i.e: the array elements <TT>u(i,j)</TT> and <TT>v(i,j)</TT>
!    are actually at (i-&#189;,j) and (i,j-&#189;) with respect to the
!    grid centers.
!
!    The gridtypes listed above are all available by use association as
!    integer parameters. The scalar version of <TT>mpp_update_domains</TT>
!    assumes that the values of a scalar field are always at <TT>AGRID</TT>
!    locations, and no special boundary treatment is required. If vector
!    fields are at staggered locations, the optional argument
!    <TT>gridtype</TT> must be appropriately set for correct treatment at
!    boundaries.
!    
!    It is safe to apply vector field updates to the appropriate arrays
!    irrespective of the domain topology: if the topology requires no
!    special treatment of vector fields, specifying <TT>gridtype</TT> will
!    do no harm.
!
!    <TT>mpp_update_domains</TT> internally buffers the date being sent
!    and received into single messages for efficiency. A turnable internal
!    buffer area in memory is provided for this purpose by
!    <TT>mpp_domains_mod</TT>. The size of this buffer area can be set by
!    the user by calling <LINK SRC="mpp_domains.html#mpp_domains_set_stack_size">
!    <TT>mpp_domains_set_stack_size</TT></LINK>.
!  </DESCRIPTION>
!  <TEMPLATE>
!    call mpp_update_domains( field, domain, flags )
!  </TEMPLATE>
!  <TEMPLATE>
!    call mpp_update_domains( fieldx, fieldy, domain, flags, gridtype )
!  </TEMPLATE>
! </INTERFACE>
  interface mpp_update_domains
     module procedure mpp_update_domain2D_r8_2d
     module procedure mpp_update_domain2D_r8_3d
     module procedure mpp_update_domain2D_r8_4d
     module procedure mpp_update_domain2D_r8_5d
     module procedure mpp_update_domain2D_r8_2dv
     module procedure mpp_update_domain2D_r8_3dv
     module procedure mpp_update_domain2D_r8_4dv
     module procedure mpp_update_domain2D_r8_5dv
#ifdef OVERLOAD_C8
     module procedure mpp_update_domain2D_c8_2d
     module procedure mpp_update_domain2D_c8_3d
     module procedure mpp_update_domain2D_c8_4d
     module procedure mpp_update_domain2D_c8_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_update_domain2D_i8_2d
     module procedure mpp_update_domain2D_i8_3d
     module procedure mpp_update_domain2D_i8_4d
     module procedure mpp_update_domain2D_i8_5d
!!$     module procedure mpp_update_domain2D_l8_2d
!!$     module procedure mpp_update_domain2D_l8_3d
!!$     module procedure mpp_update_domain2D_l8_4d
!!$     module procedure mpp_update_domain2D_l8_5d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_update_domain2D_r4_2d
     module procedure mpp_update_domain2D_r4_3d
     module procedure mpp_update_domain2D_r4_4d
     module procedure mpp_update_domain2D_r4_5d
     module procedure mpp_update_domain2D_r4_2dv
     module procedure mpp_update_domain2D_r4_3dv
     module procedure mpp_update_domain2D_r4_4dv
     module procedure mpp_update_domain2D_r4_5dv
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_update_domain2D_c4_2d
     module procedure mpp_update_domain2D_c4_3d
     module procedure mpp_update_domain2D_c4_4d
     module procedure mpp_update_domain2D_c4_5d
#endif
     module procedure mpp_update_domain2D_i4_2d
     module procedure mpp_update_domain2D_i4_3d
     module procedure mpp_update_domain2D_i4_4d
     module procedure mpp_update_domain2D_i4_5d
!!$     module procedure mpp_update_domain2D_l4_2d
!!$     module procedure mpp_update_domain2D_l4_3d
!!$     module procedure mpp_update_domain2D_l4_4d
!!$     module procedure mpp_update_domain2D_l4_5d
  end interface

!--------------------------------------------------------------
!bnc: for adjoint update
!--------------------------------------------------------------
!!$  interface mpp_update_domains_ad
!!$     module procedure mpp_update_domain2D_ad_r8_2d
!!$     module procedure mpp_update_domain2D_ad_r8_3d
!!$     module procedure mpp_update_domain2D_ad_r8_4d
!!$     module procedure mpp_update_domain2D_ad_r8_5d
!!$     module procedure mpp_update_domain2D_ad_r8_2dv
!!$     module procedure mpp_update_domain2D_ad_r8_3dv
!!$     module procedure mpp_update_domain2D_ad_r8_4dv
!!$     module procedure mpp_update_domain2D_ad_r8_5dv
!!$#ifdef OVERLOAD_C8
!!$     module procedure mpp_update_domain2D_ad_c8_2d
!!$     module procedure mpp_update_domain2D_ad_c8_3d
!!$     module procedure mpp_update_domain2D_ad_c8_4d
!!$     module procedure mpp_update_domain2D_ad_c8_5d
!!$#endif
!!$#ifndef no_8byte_integers
!!$     module procedure mpp_update_domain2D_ad_i8_2d
!!$     module procedure mpp_update_domain2D_ad_i8_3d
!!$     module procedure mpp_update_domain2D_ad_i8_4d
!!$     module procedure mpp_update_domain2D_ad_i8_5d
!!$     module procedure mpp_update_domain2D_ad_l8_2d
!!$     module procedure mpp_update_domain2D_ad_l8_3d
!!$     module procedure mpp_update_domain2D_ad_l8_4d
!!$     module procedure mpp_update_domain2D_ad_l8_5d
!!$#endif
!!$#ifdef OVERLOAD_R4
!!$     module procedure mpp_update_domain2D_ad_r4_2d
!!$     module procedure mpp_update_domain2D_ad_r4_3d
!!$     module procedure mpp_update_domain2D_ad_r4_4d
!!$     module procedure mpp_update_domain2D_ad_r4_5d
!!$     module procedure mpp_update_domain2D_ad_r4_2dv
!!$     module procedure mpp_update_domain2D_ad_r4_3dv
!!$     module procedure mpp_update_domain2D_ad_r4_4dv
!!$     module procedure mpp_update_domain2D_ad_r4_5dv
!!$#endif
!!$#ifdef OVERLOAD_C4
!!$     module procedure mpp_update_domain2D_ad_c4_2d
!!$     module procedure mpp_update_domain2D_ad_c4_3d
!!$     module procedure mpp_update_domain2D_ad_c4_4d
!!$     module procedure mpp_update_domain2D_ad_c4_5d
!!$#endif
!!$     module procedure mpp_update_domain2D_ad_i4_2d
!!$     module procedure mpp_update_domain2D_ad_i4_3d
!!$     module procedure mpp_update_domain2D_ad_i4_4d
!!$     module procedure mpp_update_domain2D_ad_i4_5d
!!$  end interface
!bnc


  interface mpp_do_update
     module procedure mpp_do_update_r8_3d
     module procedure mpp_do_update_r8_3dv
#ifdef OVERLOAD_C8
     module procedure mpp_do_update_c8_3d
#endif
#ifndef no_8byte_integers
     module procedure mpp_do_update_i8_3d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_do_update_r4_3d
     module procedure mpp_do_update_r4_3dv
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_do_update_c4_3d
#endif
     module procedure mpp_do_update_i4_3d
  end interface

  interface mpp_do_check
     module procedure mpp_do_check_r8_3d
     module procedure mpp_do_check_r8_3dv
#ifdef OVERLOAD_C8
     module procedure mpp_do_check_c8_3d
#endif
#ifndef no_8byte_integers
     module procedure mpp_do_check_i8_3d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_do_check_r4_3d
     module procedure mpp_do_check_r4_3dv
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_do_check_c4_3d
#endif
     module procedure mpp_do_check_i4_3d
  end interface


!-------------------------------------------------------
!bnc  for adjoint do_update
!-------------------------------------------------------
!!$  interface mpp_do_update_ad
!!$     module procedure mpp_do_update_ad_r8_3d
!!$     module procedure mpp_do_update_ad_r8_3dv
!!$#ifdef OVERLOAD_C8
!!$     module procedure mpp_do_update_ad_c8_3d
!!$#endif
!!$#ifndef no_8byte_integers
!!$     module procedure mpp_do_update_ad_i8_3d
!!$#endif
!!$#ifdef OVERLOAD_R4
!!$     module procedure mpp_do_update_ad_r4_3d
!!$     module procedure mpp_do_update_ad_r4_3dv
!!$#endif
!!$#ifdef OVERLOAD_C4
!!$     module procedure mpp_do_update_ad_c4_3d
!!$#endif
!!$     module procedure mpp_do_update_ad_i4_3d
!!$  end interface
!bnc

! <INTERFACE NAME="mpp_get_boundary">
! <OVERVIEW>
!    Get the boundary data for symmetric domain when the data is at C, E, or N-cell center
! </OVERVIEW>
!  <DESCRIPTION>
!    <TT>mpp_get_boundary</TT> is used to get the boundary data for symmetric domain 
!        when the data is at C, E, or N-cell center. For cubic grid, the data should 
!        always at C-cell center. 
!  </DESCRIPTION>
!  <TEMPLATE>
!    call mpp_get_boundary
!  </TEMPLATE>
!  <TEMPLATE>
!    call mpp_get_boundary
!  </TEMPLATE>
! </INTERFACE>
  interface mpp_get_boundary
     module procedure mpp_get_boundary_r8_2d
     module procedure mpp_get_boundary_r8_3d
     module procedure mpp_get_boundary_r8_4d
     module procedure mpp_get_boundary_r8_5d
     module procedure mpp_get_boundary_r8_2dv
     module procedure mpp_get_boundary_r8_3dv
     module procedure mpp_get_boundary_r8_4dv
     module procedure mpp_get_boundary_r8_5dv
#ifdef OVERLOAD_R4
     module procedure mpp_get_boundary_r4_2d
     module procedure mpp_get_boundary_r4_3d
     module procedure mpp_get_boundary_r4_4d
     module procedure mpp_get_boundary_r4_5d
     module procedure mpp_get_boundary_r4_2dv
     module procedure mpp_get_boundary_r4_3dv
     module procedure mpp_get_boundary_r4_4dv
     module procedure mpp_get_boundary_r4_5dv
#endif
  end interface

  interface mpp_do_get_boundary
     module procedure mpp_do_get_boundary_r8_3d
     module procedure mpp_do_get_boundary_r8_3dv
#ifdef OVERLOAD_R4
     module procedure mpp_do_get_boundary_r4_3d
     module procedure mpp_do_get_boundary_r4_3dv
#endif
  end interface

! <INTERFACE NAME="mpp_redistribute">
!  <OVERVIEW>
!    Reorganization of distributed global arrays.
!  </OVERVIEW>
!  <DESCRIPTION>
!    <TT>mpp_redistribute</TT> is used to reorganize a distributed
!    array.  <TT>MPP_TYPE_</TT> can be of type <TT>integer</TT>,
!    <TT>complex</TT>, or <TT>real</TT>; of 4-byte or 8-byte kind; of rank
!    up to 5.
!  </DESCRIPTION>
!  <TEMPLATE>
!    call mpp_redistribute( domain_in, field_in, domain_out, field_out )
!  </TEMPLATE>
!  <IN NAME="field_in" TYPE="MPP_TYPE_">
!    <TT>field_in</TT> is dimensioned on the data domain of <TT>domain_in</TT>.
!  </IN>
!  <OUT NAME="field_out" TYPE="MPP_TYPE_">
!    <TT>field_out</TT> on the data domain of <TT>domain_out</TT>.
!  </OUT>
! </INTERFACE>
  interface mpp_redistribute
     module procedure mpp_redistribute_r8_2D
     module procedure mpp_redistribute_r8_3D
     module procedure mpp_redistribute_r8_4D
     module procedure mpp_redistribute_r8_5D
#ifdef OVERLOAD_C8
     module procedure mpp_redistribute_c8_2D
     module procedure mpp_redistribute_c8_3D
     module procedure mpp_redistribute_c8_4D
     module procedure mpp_redistribute_c8_5D
#endif
#ifndef no_8byte_integers
     module procedure mpp_redistribute_i8_2D
     module procedure mpp_redistribute_i8_3D
     module procedure mpp_redistribute_i8_4D
     module procedure mpp_redistribute_i8_5D
!!$     module procedure mpp_redistribute_l8_2D
!!$     module procedure mpp_redistribute_l8_3D
!!$     module procedure mpp_redistribute_l8_4D
!!$     module procedure mpp_redistribute_l8_5D
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_redistribute_r4_2D
     module procedure mpp_redistribute_r4_3D
     module procedure mpp_redistribute_r4_4D
     module procedure mpp_redistribute_r4_5D
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_redistribute_c4_2D
     module procedure mpp_redistribute_c4_3D
     module procedure mpp_redistribute_c4_4D
     module procedure mpp_redistribute_c4_5D
#endif
     module procedure mpp_redistribute_i4_2D
     module procedure mpp_redistribute_i4_3D
     module procedure mpp_redistribute_i4_4D
     module procedure mpp_redistribute_i4_5D
!!$     module procedure mpp_redistribute_l4_2D
!!$     module procedure mpp_redistribute_l4_3D
!!$     module procedure mpp_redistribute_l4_4D
!!$     module procedure mpp_redistribute_l4_5D
  end interface

  interface mpp_do_redistribute
     module procedure mpp_do_redistribute_r8_3D
#ifdef OVERLOAD_C8
     module procedure mpp_do_redistribute_c8_3D
#endif
#ifndef no_8byte_integers
     module procedure mpp_do_redistribute_i8_3D
     module procedure mpp_do_redistribute_l8_3D
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_do_redistribute_r4_3D
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_do_redistribute_c4_3D
#endif
     module procedure mpp_do_redistribute_i4_3D
     module procedure mpp_do_redistribute_l4_3D
  end interface


! <INTERFACE NAME="mpp_check_field">
!   <OVERVIEW>
!     Parallel checking between two ensembles which run
!     on different set pes at the same time.
!   </OVERVIEW>
!   <DESCRIPTION>
!     There are two forms for the <TT>mpp_check_field</TT> call. The 2D
!     version is generally to be used and 3D version is  built by repeated calls to the
!     2D version.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call mpp_check_field(field_in, pelist1, pelist2, domain, mesg, &
!                                w_halo, s_halo, e_halo, n_halo, force_abort  )
!   </TEMPLATE>
!   <IN NAME="field_in" >
!     Field to be checked
!   </IN>
!   <IN NAME="pelist1, pelist2">
!     Pelist of the two ensembles to be compared
!   </IN>
!   <IN NAME="domain">
!     Domain of current pe
!   </IN>
!   <IN NAME="mesg" >
!     Message to be printed out
!   </IN>
!   <IN NAME="w_halo, s_halo, e_halo, n_halo">
!     Halo size to be checked. Default value is 0.
!   </IN>
!   <IN NAME="force_abort">
!     When true, abort program when any difference found. Default value is false.
!   </IN>
! </INTERFACE>

  interface mpp_check_field
     module procedure mpp_check_field_2D
     module procedure mpp_check_field_3D
  end interface

!***********************************************************************
!
!         public interface from mpp_domains_reduce.h
!
!***********************************************************************

! <INTERFACE NAME="mpp_global_field">
!  <OVERVIEW>
!    Fill in a global array from domain-decomposed arrays.
!  </OVERVIEW>
!  <DESCRIPTION>
!    <TT>mpp_global_field</TT> is used to get an entire
!    domain-decomposed array on each PE. <TT>MPP_TYPE_</TT> can be of type
!    <TT>complex</TT>, <TT>integer</TT>, <TT>logical</TT> or <TT>real</TT>;
!    of 4-byte or 8-byte kind; of rank up to 5.
!    
!    All PEs in a domain decomposition must call
!    <TT>mpp_global_field</TT>, and each will have a complete global field
!    at the end. Please note that a global array of rank 3 or higher could
!    occupy a lot of memory.
!  </DESCRIPTION>
!  <TEMPLATE>
!    call mpp_global_field( domain, local, global, flags )
!  </TEMPLATE>
!  <IN NAME="domain" TYPE="type(domain2D)"></IN>
!  <IN NAME="local" TYPE="MPP_TYPE_">
!    <TT>local</TT> is dimensioned on either the compute domain or the
!    data domain of <TT>domain</TT>.
!  </IN>
!  <OUT NAME="global" TYPE="MPP_TYPE_">
!    <TT>global</TT> is dimensioned on the corresponding global domain.
!  </OUT>
!  <IN NAME="flags" TYPE="integer">
!    <TT>flags</TT> can be given the value <TT>XONLY</TT> or
!    <TT>YONLY</TT>, to specify a globalization on one axis only.
!  </IN>
! </INTERFACE>
  interface mpp_global_field
     module procedure mpp_global_field2D_r8_2d
     module procedure mpp_global_field2D_r8_3d
     module procedure mpp_global_field2D_r8_4d
     module procedure mpp_global_field2D_r8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_global_field2D_c8_2d
     module procedure mpp_global_field2D_c8_3d
     module procedure mpp_global_field2D_c8_4d
     module procedure mpp_global_field2D_c8_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_global_field2D_i8_2d
     module procedure mpp_global_field2D_i8_3d
     module procedure mpp_global_field2D_i8_4d
     module procedure mpp_global_field2D_i8_5d
     module procedure mpp_global_field2D_l8_2d
     module procedure mpp_global_field2D_l8_3d
     module procedure mpp_global_field2D_l8_4d
     module procedure mpp_global_field2D_l8_5d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_global_field2D_r4_2d
     module procedure mpp_global_field2D_r4_3d
     module procedure mpp_global_field2D_r4_4d
     module procedure mpp_global_field2D_r4_5d
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_global_field2D_c4_2d
     module procedure mpp_global_field2D_c4_3d
     module procedure mpp_global_field2D_c4_4d
     module procedure mpp_global_field2D_c4_5d
#endif
     module procedure mpp_global_field2D_i4_2d
     module procedure mpp_global_field2D_i4_3d
     module procedure mpp_global_field2D_i4_4d
     module procedure mpp_global_field2D_i4_5d
     module procedure mpp_global_field2D_l4_2d
     module procedure mpp_global_field2D_l4_3d
     module procedure mpp_global_field2D_l4_4d
     module procedure mpp_global_field2D_l4_5d
  end interface

  interface mpp_do_global_field
     module procedure mpp_do_global_field2D_r8_3d
#ifdef OVERLOAD_C8
     module procedure mpp_do_global_field2D_c8_3d
#endif
#ifndef no_8byte_integers
     module procedure mpp_do_global_field2D_i8_3d
     module procedure mpp_do_global_field2D_l8_3d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_do_global_field2D_r4_3d
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_do_global_field2D_c4_3d
#endif
     module procedure mpp_do_global_field2D_i4_3d
     module procedure mpp_do_global_field2D_l4_3d
  end interface

! <INTERFACE NAME="mpp_global_max">
!  <OVERVIEW>
!    Global max/min of domain-decomposed arrays.
!  </OVERVIEW>
!  <DESCRIPTION>
!    <TT>mpp_global_max</TT> is used to get the maximum value of a
!    domain-decomposed array on each PE. <TT>MPP_TYPE_</TT> can be of type
!    <TT>integer</TT> or <TT>real</TT>; of 4-byte or 8-byte kind; of rank
!    up to 5. The dimension of <TT>locus</TT> must equal the rank of
!    <TT>field</TT>.
!    
!    All PEs in a domain decomposition must call
!    <TT>mpp_global_max</TT>, and each will have the result upon exit.
!    
!    The function <TT>mpp_global_min</TT>, with an identical syntax. is
!    also available.
!  </DESCRIPTION>
!  <TEMPLATE>
!    mpp_global_max( domain, field, locus )
!  </TEMPLATE>
!  <IN NAME="domain" TYPE="type(domain2D)"></IN>
!  <IN NAME="field" TYPE="MPP_TYPE_">  
!    <TT>field</TT> is dimensioned on either the compute domain or the
!    data domain of <TT>domain</TT>.
!  </IN>
!  <OUT NAME="locus" TYPE="integer" DIM="(:)">
!    <TT>locus</TT>, if present, can be used to retrieve the location of
!    the maximum (as in the <TT>MAXLOC</TT> intrinsic of f90).
!  </OUT>
! </INTERFACE>

  interface mpp_global_max
     module procedure mpp_global_max_r8_2d
     module procedure mpp_global_max_r8_3d
     module procedure mpp_global_max_r8_4d
     module procedure mpp_global_max_r8_5d
#ifdef OVERLOAD_R4
     module procedure mpp_global_max_r4_2d
     module procedure mpp_global_max_r4_3d
     module procedure mpp_global_max_r4_4d
     module procedure mpp_global_max_r4_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_global_max_i8_2d
     module procedure mpp_global_max_i8_3d
     module procedure mpp_global_max_i8_4d
     module procedure mpp_global_max_i8_5d
#endif
     module procedure mpp_global_max_i4_2d
     module procedure mpp_global_max_i4_3d
     module procedure mpp_global_max_i4_4d
     module procedure mpp_global_max_i4_5d
  end interface

  interface mpp_global_min
     module procedure mpp_global_min_r8_2d
     module procedure mpp_global_min_r8_3d
     module procedure mpp_global_min_r8_4d
     module procedure mpp_global_min_r8_5d
#ifdef OVERLOAD_R4
     module procedure mpp_global_min_r4_2d
     module procedure mpp_global_min_r4_3d
     module procedure mpp_global_min_r4_4d
     module procedure mpp_global_min_r4_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_global_min_i8_2d
     module procedure mpp_global_min_i8_3d
     module procedure mpp_global_min_i8_4d
     module procedure mpp_global_min_i8_5d
#endif
     module procedure mpp_global_min_i4_2d
     module procedure mpp_global_min_i4_3d
     module procedure mpp_global_min_i4_4d
     module procedure mpp_global_min_i4_5d
  end interface

! <INTERFACE NAME="mpp_global_sum">
!  <OVERVIEW>
!    Global sum of domain-decomposed arrays.
!  </OVERVIEW>
!  <DESCRIPTION>
!    <TT>mpp_global_sum</TT> is used to get the sum of a
!    domain-decomposed array on each PE. <TT>MPP_TYPE_</TT> can be of type
!    <TT>integer</TT>, <TT>complex</TT>, or <TT>real</TT>; of 4-byte or
!    8-byte kind; of rank up to 5.
!  </DESCRIPTION>
!  <TEMPLATE>
!    call mpp_global_sum( domain, field, flags )
!  </TEMPLATE>
!  <IN NAME="domain" TYPE="type(domain2D)"></IN>
!  <IN NAME="field" TYPE="MPP_TYPE_">
!    <TT>field</TT> is dimensioned on either the compute domain or the
!    data domain of <TT>domain</TT>.
!  </IN>
!  <IN NAME="flags" TYPE="integer">
!    <TT>flags</TT>, if present, must have the value
!    <TT>BITWISE_EXACT_SUM</TT>. This produces a sum that is guaranteed to
!    produce the identical result irrespective of how the domain is
!    decomposed. This method does the sum first along the ranks beyond 2,
!    and then calls <LINK
!    SRC="#mpp_global_field"><TT>mpp_global_field</TT></LINK> to produce a
!    global 2D array which is then summed. The default method, which is
!    considerably faster, does a local sum followed by <LINK
!    SRC="mpp.html#mpp_sum"><TT>mpp_sum</TT></LINK> across the domain
!    decomposition.
!  </IN>
!  <NOTE>
!    All PEs in a domain decomposition must call
!    <TT>mpp_global_sum</TT>, and each will have the result upon exit.
!  </NOTE>
! </INTERFACE>

  interface mpp_global_sum
     module procedure mpp_global_sum_r8_2d
     module procedure mpp_global_sum_r8_3d
     module procedure mpp_global_sum_r8_4d
     module procedure mpp_global_sum_r8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_global_sum_c8_2d
     module procedure mpp_global_sum_c8_3d
     module procedure mpp_global_sum_c8_4d
     module procedure mpp_global_sum_c8_5d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_global_sum_r4_2d
     module procedure mpp_global_sum_r4_3d
     module procedure mpp_global_sum_r4_4d
     module procedure mpp_global_sum_r4_5d
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_global_sum_c4_2d
     module procedure mpp_global_sum_c4_3d
     module procedure mpp_global_sum_c4_4d
     module procedure mpp_global_sum_c4_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_global_sum_i8_2d
     module procedure mpp_global_sum_i8_3d
     module procedure mpp_global_sum_i8_4d
     module procedure mpp_global_sum_i8_5d
#endif
     module procedure mpp_global_sum_i4_2d
     module procedure mpp_global_sum_i4_3d
     module procedure mpp_global_sum_i4_4d
     module procedure mpp_global_sum_i4_5d
  end interface

!gag
  interface mpp_global_sum_tl
     module procedure mpp_global_sum_tl_r8_2d
     module procedure mpp_global_sum_tl_r8_3d
     module procedure mpp_global_sum_tl_r8_4d
     module procedure mpp_global_sum_tl_r8_5d
#ifdef OVERLOAD_C8
     module procedure mpp_global_sum_tl_c8_2d
     module procedure mpp_global_sum_tl_c8_3d
     module procedure mpp_global_sum_tl_c8_4d
     module procedure mpp_global_sum_tl_c8_5d
#endif
#ifdef OVERLOAD_R4
     module procedure mpp_global_sum_tl_r4_2d
     module procedure mpp_global_sum_tl_r4_3d
     module procedure mpp_global_sum_tl_r4_4d
     module procedure mpp_global_sum_tl_r4_5d
#endif
#ifdef OVERLOAD_C4
     module procedure mpp_global_sum_tl_c4_2d
     module procedure mpp_global_sum_tl_c4_3d
     module procedure mpp_global_sum_tl_c4_4d
     module procedure mpp_global_sum_tl_c4_5d
#endif
#ifndef no_8byte_integers
     module procedure mpp_global_sum_tl_i8_2d
     module procedure mpp_global_sum_tl_i8_3d
     module procedure mpp_global_sum_tl_i8_4d
     module procedure mpp_global_sum_tl_i8_5d
#endif
     module procedure mpp_global_sum_tl_i4_2d
     module procedure mpp_global_sum_tl_i4_3d
     module procedure mpp_global_sum_tl_i4_4d
     module procedure mpp_global_sum_tl_i4_5d
  end interface
!gag

!bnc
!!$  interface mpp_global_sum_ad
!!$     module procedure mpp_global_sum_ad_r8_2d
!!$     module procedure mpp_global_sum_ad_r8_3d
!!$     module procedure mpp_global_sum_ad_r8_4d
!!$     module procedure mpp_global_sum_ad_r8_5d
!!$#ifdef OVERLOAD_C8
!!$     module procedure mpp_global_sum_ad_c8_2d
!!$     module procedure mpp_global_sum_ad_c8_3d
!!$     module procedure mpp_global_sum_ad_c8_4d
!!$     module procedure mpp_global_sum_ad_c8_5d
!!$#endif
!!$#ifdef OVERLOAD_R4
!!$     module procedure mpp_global_sum_ad_r4_2d
!!$     module procedure mpp_global_sum_ad_r4_3d
!!$     module procedure mpp_global_sum_ad_r4_4d
!!$     module procedure mpp_global_sum_ad_r4_5d
!!$#endif
!!$#ifdef OVERLOAD_C4
!!$     module procedure mpp_global_sum_ad_c4_2d
!!$     module procedure mpp_global_sum_ad_c4_3d
!!$     module procedure mpp_global_sum_ad_c4_4d
!!$     module procedure mpp_global_sum_ad_c4_5d
!!$#endif
!!$#ifndef no_8byte_integers
!!$     module procedure mpp_global_sum_ad_i8_2d
!!$     module procedure mpp_global_sum_ad_i8_3d
!!$     module procedure mpp_global_sum_ad_i8_4d
!!$     module procedure mpp_global_sum_ad_i8_5d
!!$#endif
!!$     module procedure mpp_global_sum_ad_i4_2d
!!$     module procedure mpp_global_sum_ad_i4_3d
!!$     module procedure mpp_global_sum_ad_i4_4d
!!$     module procedure mpp_global_sum_ad_i4_5d
!!$  end interface
!bnc

!***********************************************************************
!
!            public interface from mpp_domain_util.h
!
!***********************************************************************

  ! <INTERFACE NAME="mpp_get_neighbor_pe">
  !  <OVERVIEW>
  !    Retrieve PE number of a neighboring domain.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    Given a 1-D or 2-D domain decomposition, this call allows users to retrieve 
  !    the PE number of an adjacent PE-domain while taking into account that the 
  !    domain may have holes (masked) and/or have cyclic boundary conditions and/or a 
  !    folded edge. Which PE-domain will be retrived will depend on "direction": 
  !    +1 (right) or -1 (left) for a 1-D domain decomposition and either NORTH, SOUTH, 
  !    EAST, WEST, NORTH_EAST, SOUTH_EAST, SOUTH_WEST, or NORTH_WEST for a 2-D 
  !    decomposition. If no neighboring domain exists (masked domain), then the 
  !    returned "pe" value will be set to NULL_PE.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_neighbor_pe( domain1d, direction=+1   , pe)
  !    call mpp_get_neighbor_pe( domain2d, direction=NORTH, pe)
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_get_neighbor_pe
     module procedure mpp_get_neighbor_pe_1d
     module procedure mpp_get_neighbor_pe_2d
  end interface 
  ! <INTERFACE NAME="operator">
  !  <OVERVIEW>
  !    Equality/inequality operators for domaintypes.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The module provides public operators to check for
  !    equality/inequality of domaintypes, e.g:
  !    
  !    <PRE>
  !    type(domain1D) :: a, b
  !    type(domain2D) :: c, d
  !    ...
  !    if( a.NE.b )then
  !        ...
  !    end if
  !    if( c==d )then
  !        ...
  !    end if
  !    </PRE>
  !    
  !    Domains are considered equal if and only if the start and end
  !    indices of each of their component global, data and compute domains
  !    are equal.
  !  </DESCRIPTION>
  ! </INTERFACE>
  interface operator(.EQ.)
     module procedure mpp_domain1D_eq
     module procedure mpp_domain2D_eq
  end interface

  interface operator(.NE.)
     module procedure mpp_domain1D_ne
     module procedure mpp_domain2D_ne
  end interface

  ! <INTERFACE NAME="mpp_get_compute_domain">
  !  <OVERVIEW>
  !    These routines retrieve the axis specifications associated with the compute domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    retrieve the axis specifications associated with the compute domains
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_compute_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_get_compute_domain
     module procedure mpp_get_compute_domain1D
     module procedure mpp_get_compute_domain2D
  end interface

  ! <INTERFACE NAME="mpp_get_compute_domains">
  !  <OVERVIEW>
  !    Retrieve the entire array of compute domain extents associated with a decomposition.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    Retrieve the entire array of compute domain extents associated with a decomposition.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_compute_domains( domain, xbegin, xend, xsize, &
  !                                                ybegin, yend, ysize )
  !  </TEMPLATE>
  !  <IN NAME="domain" TYPE="type(domain2D)"></IN>
  !  <OUT NAME="xbegin,ybegin" TYPE="integer" DIM="(:)"></OUT>
  !  <OUT NAME="xend,yend" TYPE="integer" DIM="(:)"></OUT>
  !  <OUT NAME="xsize,ysize" TYPE="integer" DIM="(:)"></OUT>
  ! </INTERFACE>
  interface mpp_get_compute_domains
     module procedure mpp_get_compute_domains1D
     module procedure mpp_get_compute_domains2D
  end interface

  ! <INTERFACE NAME="mpp_get_data_domain">
  !  <OVERVIEW>
  !    These routines retrieve the axis specifications associated with the data domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    retrieve the axis specifications associated with the data domains.
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_data_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_get_data_domain
     module procedure mpp_get_data_domain1D
     module procedure mpp_get_data_domain2D
  end interface

  ! <INTERFACE NAME="mpp_get_global_domain">
  !  <OVERVIEW>
  !    These routines retrieve the axis specifications associated with the global domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    retrieve the axis specifications associated with the global domains.
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_global_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_get_global_domain
     module procedure mpp_get_global_domain1D
     module procedure mpp_get_global_domain2D
  end interface

  ! <INTERFACE NAME="mpp_get_memory_domain">
  !  <OVERVIEW>
  !    These routines retrieve the axis specifications associated with the memory domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    retrieve the axis specifications associated with the memory domains.
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_memory_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_get_memory_domain
     module procedure mpp_get_memory_domain1D
     module procedure mpp_get_memory_domain2D
  end interface

  interface mpp_get_domain_extents
     module procedure mpp_get_domain_extents1D
     module procedure mpp_get_domain_extents2D
  end interface

  ! <INTERFACE NAME="mpp_set_compute_domain">
  !  <OVERVIEW>
  !    These routines set the axis specifications associated with the compute domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    set the axis specifications associated with the compute domains
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_set_compute_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_set_compute_domain
     module procedure mpp_set_compute_domain1D
     module procedure mpp_set_compute_domain2D
  end interface

  ! <INTERFACE NAME="mpp_set_data_domain">
  !  <OVERVIEW>
  !    These routines set the axis specifications associated with the data domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    set the axis specifications associated with the data domains.
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_set_data_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_set_data_domain
     module procedure mpp_set_data_domain1D
     module procedure mpp_set_data_domain2D
  end interface

  ! <INTERFACE NAME="mpp_set_global_domain">
  !  <OVERVIEW>
  !    These routines set the axis specifications associated with the global domains.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The domain is a derived type with private elements. These routines 
  !    set the axis specifications associated with the global domains.
  !    The 2D version of these is a simple extension of 1D.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_set_global_domain
  !  </TEMPLATE>
  ! </INTERFACE>
  interface mpp_set_global_domain
     module procedure mpp_set_global_domain1D
     module procedure mpp_set_global_domain2D
  end interface


  ! <INTERFACE NAME="mpp_get_pelist">
  !  <OVERVIEW>
  !    Retrieve list of PEs associated with a domain decomposition.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The 1D version of this call returns an array of the PEs assigned to this 1D domain
  !    decomposition. In addition the optional argument <TT>pos</TT> may be
  !    used to retrieve the 0-based position of the domain local to the
  !    calling PE, i.e <TT>domain%list(pos)%pe</TT> is the local PE,
  !    as returned by <LINK SRC="mpp.html#mpp_pe"><TT>mpp_pe()</TT></LINK>.
  !    The 2D version of this call is identical to 1D version.
  !  </DESCRIPTION>
  !  <IN NAME="domain"></IN>
  !  <OUT NAME="pelist"></OUT>
  !  <OUT NAME="pos"></OUT>
  ! </INTERFACE>
  interface mpp_get_pelist
     module procedure mpp_get_pelist1D
     module procedure mpp_get_pelist2D
  end interface

  ! <INTERFACE NAME="mpp_get_layout">
  !  <OVERVIEW>
  !    Retrieve layout associated with a domain decomposition.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    The 1D version of this call returns the number of divisions that was assigned to this
  !    decomposition axis. The 2D version of this call returns an array of
  !    dimension 2 holding the results on two axes.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_get_layout( domain, layout )
  !  </TEMPLATE>
  !  <IN NAME="domain"></IN>
  !  <OUT NAME="layout"></OUT>
  ! </INTERFACE>
  interface mpp_get_layout
     module procedure mpp_get_layout1D
     module procedure mpp_get_layout2D
  end interface

  ! <INTERFACE NAME="mpp_nullify_domain_list">
  !  <OVERVIEW>
  !    nullify domain list.
  !  </OVERVIEW>
  !  <DESCRIPTION>
  !    Nullify domain list. This interface is needed in mpp_domains_test.
  !    1-D case can be added in if needed.
  !  </DESCRIPTION>
  !  <TEMPLATE>
  !    call mpp_nullify_domain_list( domain)
  !  </TEMPLATE>
  !  <INOUT NAME="domain"></INOUT>
  ! </INTERFACE>
  interface mpp_nullify_domain_list
     module procedure nullify_domain2d_list
  end interface  

  !--- version information variables
  character(len=128), public :: version= &
       '$Id: mpp_domains.F90,v 16.0.6.2.2.1.2.1.2.2.4.4.2.1.4.1.2.1.6.1 2011/12/12 20:26:08 Peter.Phillipps Exp $'
  character(len=128), public :: tagname= &
       '$Name:  $'


contains

#include <mpp_domains_util.inc>
#include <mpp_domains_comm.inc>
#include <mpp_domains_define.inc>
#include <mpp_domains_misc.inc>
#include <mpp_domains_reduce.inc>


end module mpp_domains_mod

! <INFO>

!   <COMPILER NAME="">     
!     Any module or program unit using <TT>mpp_domains_mod</TT>
!     must contain the line

!     <PRE>
!     use mpp_domains_mod
!     </PRE>

!     <TT>mpp_domains_mod</TT> <TT>use</TT>s <LINK
!     SRC="mpp.html">mpp_mod</LINK>, and therefore is subject to the <LINK
!     SRC="mpp.html#COMPILING AND LINKING SOURCE">compiling and linking requirements of that module.</LINK>
!   </COMPILER>
!   <PRECOMP FLAG="">      
!     <TT>mpp_domains_mod</TT> uses standard f90, and has no special
!     requirements. There are some OS-dependent
!     pre-processor directives that you might need to modify on
!     non-SGI/Cray systems and compilers. The <LINK
!     SRC="mpp.html#PORTABILITY">portability of mpp_mod</LINK>
!     obviously is a constraint, since this module is built on top of
!     it. Contact me, Balaji, SGI/GFDL, with questions.
!   </PRECOMP> 
!   <LOADER FLAG="">       
!     The <TT>mpp_domains</TT> source consists of the main source file
!     <TT>mpp_domains.F90</TT> and also requires the following include files:
!    <PRE>
!     <TT>fms_platform.h</TT>
!     <TT>mpp_update_domains2D.h</TT>
!     <TT>mpp_global_reduce.h</TT>
!     <TT>mpp_global_sum.h</TT>
!     <TT>mpp_global_field.h</TT>
!    </PRE>
!    GFDL users can check it out of the main CVS repository as part of
!    the <TT>mpp</TT> CVS module. The current public tag is <TT>galway</TT>.
!    External users can download the latest <TT>mpp</TT> package <LINK SRC=
!    "ftp://ftp.gfdl.gov/pub/vb/mpp/mpp.tar.Z">here</LINK>. Public access
!    to the GFDL CVS repository will soon be made available.

!   </LOADER>

! </INFO>


!-----------------------------------------------------------------------
!                 Parallel I/O for message-passing codes
!
! AUTHOR: V. Balaji (vb@gfdl.gov)
!         SGI/GFDL Princeton University
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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.
!
! For the full text of the GNU General Public License,
! write to: Free Software Foundation, Inc.,
!           675 Mass Ave, Cambridge, MA 02139, USA.  
!-----------------------------------------------------------------------

! <CONTACT EMAIL="vb@gfdl.noaa.gov">
!   V. Balaji
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <RCSLOG SRC="http://www.gfdl.noaa.gov/~vb/changes_mpp_io.html"/>

! <OVERVIEW>
!   <TT>mpp_io_mod</TT>, is a set of simple calls for parallel I/O on
!   distributed systems. It is geared toward the writing of data in netCDF
!   format. It requires the modules <LINK
!   SRC="mpp_domains.html">mpp_domains_mod</LINK> and <LINK
!   SRC="mpp.html">mpp_mod</LINK>, upon which it is built.
! </OVERVIEW>

! <DESCRIPTION>
!   In massively parallel environments, an often difficult problem is
!   the reading and writing of data to files on disk. MPI-IO and MPI-2 IO
!   are moving toward providing this capability, but are currently not
!   widely implemented. Further, it is a rather abstruse
!   API. <TT>mpp_io_mod</TT> is an attempt at a simple API encompassing a
!   certain variety of the I/O tasks that will be required. It does not
!   attempt to be an all-encompassing standard such as MPI, however, it
!   can be implemented in MPI if so desired. It is equally simple to add
!   parallel I/O capability to <TT>mpp_io_mod</TT> based on vendor-specific
!   APIs while providing a layer of insulation for user codes.
!   
!   The <TT>mpp_io_mod</TT> parallel I/O API built on top of the <LINK
!   SRC="mpp_domains.html">mpp_domains_mod</LINK> and <LINK
!   SRC="mpp.html">mpp_mod</LINK> API for domain decomposition and
!   message passing. Features of <TT>mpp_io_mod</TT> include:
!   
!    1) Simple, minimal API, with free access to underlying API for more
!   complicated stuff.<BR/>
!    2) Self-describing files: comprehensive header information
!   (metadata) in the file itself.<BR/>
!    3) Strong focus on performance of parallel write: the climate models
!   for which it is designed typically read a minimal amount of data
!   (typically at the beginning of the run); but on the other hand, tend
!   to write copious amounts of data during the run. An interface for
!   reading is also supplied, but its performance has not yet been optimized.<BR/>
!    4) Integrated netCDF capability: <LINK SRC
!   ="http://www.unidata.ucar.edu/packages/netcdf/">netCDF</LINK> is a
!   data format widely used in the climate/weather modeling
!   community. netCDF is considered the principal medium of data storage
!   for <TT>mpp_io_mod</TT>. But I provide a raw unformatted
!   fortran I/O capability in case netCDF is not an option, either due to
!   unavailability, inappropriateness, or poor performance.<BR/>
!    5) May require off-line post-processing: a tool for this purpose,
!   <TT>mppnccombine</TT>, is available. GFDL users may use
!   <TT>~hnv/pub/mppnccombine</TT>. Outside users may obtain the
!   source <LINK SRC
!   ="ftp://ftp.gfdl.gov/perm/hnv/mpp/mppnccombine.c">here</LINK>.  It
!   can be compiled on any C compiler and linked with the netCDF
!   library. The program is free and is covered by the <LINK SRC
!   ="ftp://ftp.gfdl.gov/perm/hnv/mpp/LICENSE">GPL license</LINK>.
!   
!   The internal representation of the data being written out is
!   assumed be the default real type, which can be 4 or 8-byte. Time data
!   is always written as 8-bytes to avoid overflow on climatic time scales
!   in units of seconds.
!   
!   <LINK SRC="modes"></LINK><H4>I/O modes in <TT>mpp_io_mod</TT></H4>
!   
!   The I/O activity critical to performance in the models for which
!   <TT>mpp_io_mod</TT> is designed is typically the writing of large
!   datasets on a model grid volume produced at intervals during
!   a run. Consider a 3D grid volume, where model arrays are stored as
!   <TT>(i,j,k)</TT>. The domain decomposition is typically along
!   <TT>i</TT> or <TT>j</TT>: thus to store data to disk as a global
!   volume, the distributed chunks of data have to be seen as
!   non-contiguous. If we attempt to have all PEs write this data into a
!   single file, performance can be seriously compromised because of the
!   data reordering that will be required. Possible options are to have
!   one PE acquire all the data and write it out, or to have all the PEs
!   write independent files, which are recombined offline. These three
!   modes of operation are described in the <TT>mpp_io_mod</TT> terminology
!   in terms of two parameters, <I>threading</I> and <I>fileset</I>,
!   as follows:
!   
!   <I>Single-threaded I/O:</I> a single PE acquires all the data
!   and writes it out.<BR/>
!   <I>Multi-threaded, single-fileset I/O:</I> many PEs write to a
!   single file.<BR/>
!    <I>Multi-threaded, multi-fileset I/O:</I> many PEs write to
!   independent files. This is also called <I>distributed I/O</I>.
!   
!   The middle option is the most difficult to achieve performance. The
!   choice of one of these modes is made when a file is opened for I/O, in
!   <LINK SRC="#mpp_open">mpp_open</LINK>.
!   
!   <LINK name="metadata"></LINK><H4>Metadata in <TT>mpp_io_mod</TT></H4>
!   
!   A requirement of the design of <TT>mpp_io_mod</TT> is that the file must
!   be entirely self-describing: comprehensive header information
!   describing its contents is present in the header of every file. The
!   header information follows the model of netCDF. Variables in the file
!   are divided into <I>axes</I> and <I>fields</I>. An axis describes a
!   co-ordinate variable, e.g <TT>x,y,z,t</TT>. A field consists of data in
!   the space described by the axes. An axis is described in
!   <TT>mpp_io_mod</TT> using the defined type <TT>axistype</TT>:
!   
!   <PRE>
!   type, public :: axistype
!      sequence
!      character(len=128) :: name
!      character(len=128) :: units
!      character(len=256) :: longname
!      character(len=8) :: cartesian
!      integer :: len
!      integer :: sense           !+/-1, depth or height?
!      type(domain1D), pointer :: domain
!      real, dimension(:), pointer :: data
!      integer :: id, did
!      integer :: type  ! external NetCDF type format for axis data
!      integer :: natt
!      type(atttype), pointer :: Att(:) ! axis attributes
!   end type axistype
!   </PRE>
!   
!   A field is described using the type <TT>fieldtype</TT>:
!   
!   <PRE>
!   type, public :: fieldtype
!      sequence
!      character(len=128) :: name
!      character(len=128) :: units
!      character(len=256) :: longname
!      real :: min, max, missing, fill, scale, add
!      integer :: pack
!      type(axistype), dimension(:), pointer :: axes
!      integer, dimension(:), pointer :: size
!      integer :: time_axis_index
!      integer :: id
!      integer :: type ! external NetCDF format for field data
!      integer :: natt, ndim
!      type(atttype), pointer :: Att(:) ! field metadata
!   end type fieldtype
!   </PRE>
!   
!   An attribute (global, field or axis) is described using the <TT>atttype</TT>:
!   
!   <PRE>
!   type, public :: atttype
!      sequence
!      integer :: type, len
!      character(len=128) :: name
!      character(len=256)  :: catt
!      real(FLOAT_KIND), pointer :: fatt(:)
!   end type atttype
!   </PRE>
!   
!   <LINK name="packing"></LINK>This default set of field attributes corresponds
!   closely to various conventions established for netCDF files. The
!   <TT>pack</TT> attribute of a field defines whether or not a
!   field is to be packed on output. Allowed values of
!   <TT>pack</TT> are 1,2,4 and 8. The value of
!   <TT>pack</TT> is the number of variables written into 8
!   bytes. In typical use, we write 4-byte reals to netCDF output; thus
!   the default value of <TT>pack</TT> is 2. For
!   <TT>pack</TT> = 4 or 8, packing uses a simple-minded linear
!   scaling scheme using the <TT>scale</TT> and <TT>add</TT>
!   attributes. There is thus likely to be a significant loss of dynamic
!   range with packing. When a field is declared to be packed, the
!   <TT>missing</TT> and <TT>fill</TT> attributes, if
!   supplied, are packed also.
!   
!   Please note that the pack values are the same even if the default
!   real is 4 bytes, i.e <TT>PACK=1</TT> still follows the definition
!   above and writes out 8 bytes.
!   
!   A set of <I>attributes</I> for each variable is also available. The
!   variable definitions and attribute information is written/read by calling
!   <LINK SRC="#mpp_write_meta">mpp_write_meta</LINK> or <LINK SRC="#mpp_read_meta">mpp_read_meta</LINK>. A typical calling
!   sequence for writing data might be:
!   
!   <PRE>
!   ...
!     type(domain2D), dimension(:), allocatable, target :: domain
!     type(fieldtype) :: field
!     type(axistype) :: x, y, z, t
!   ...
!     call mpp_define_domains( (/1,nx,1,ny/), domain )
!     allocate( a(domain(pe)%x%data%start_index:domain(pe)%x%data%end_index, &
!                 domain(pe)%y%data%start_index:domain(pe)%y%data%end_index,nz) )
!   ...
!     call mpp_write_meta( unit, x, 'X', 'km', 'X distance', &
!          domain=domain(pe)%x, data=(/(float(i),i=1,nx)/) )
!     call mpp_write_meta( unit, y, 'Y', 'km', 'Y distance', &
!          domain=domain(pe)%y, data=(/(float(i),i=1,ny)/) )
!     call mpp_write_meta( unit, z, 'Z', 'km', 'Z distance', &
!          data=(/(float(i),i=1,nz)/) )
!     call mpp_write_meta( unit, t, 'Time', 'second', 'Time' )
!   
!     call mpp_write_meta( unit, field, (/x,y,z,t/), 'a', '(m/s)', AAA', &
!          missing=-1e36 )
!   ...
!     call mpp_write( unit, x )
!     call mpp_write( unit, y )
!     call mpp_write( unit, z )
!   ...
!   </PRE>
!   
!   In this example, <TT>x</TT> and <TT>y</TT> have been
!   declared as distributed axes, since a domain decomposition has been
!   associated. <TT>z</TT> and <TT>t</TT> are undistributed
!   axes. <TT>t</TT> is known to be a <I>record</I> axis (netCDF
!   terminology) since we do not allocate the <TT>data</TT> element
!   of the <TT>axistype</TT>. <I>Only one record axis may be
!   associated with a file.</I> The call to <LINK
!   SRC="#mpp_write_meta">mpp_write_meta</LINK> initializes
!   the axes, and associates a unique variable ID with each axis. The call
!   to <TT>mpp_write_meta</TT> with argument <TT>field</TT>
!   declared <TT>field</TT> to be a 4D variable that is a function
!   of <TT>(x,y,z,t)</TT>, and a unique variable ID is associated
!   with it. A 3D field will be written at each call to
!   <TT>mpp_write(field)</TT>.
!   
!   The data to any variable, including axes, is written by
!   <TT>mpp_write</TT>.
!   
!   Any additional attributes of variables can be added through
!   subsequent <TT>mpp_write_meta</TT> calls, using the variable ID as a
!   handle. <I>Global</I> attributes, associated with the dataset as a
!   whole, can also be written thus. See the <LINK
!   SRC="#mpp_write_meta">mpp_write_meta</LINK> call syntax below
!   for further details.
!   
!   You cannot interleave calls to <TT>mpp_write</TT> and
!   <TT>mpp_write_meta</TT>: the first call to
!   <TT>mpp_write</TT> implies that metadata specification is
!   complete.
!   
!   A typical calling sequence for reading data might be:
!   
!   <PRE>
!   ...
!     integer :: unit, natt, nvar, ntime
!     type(domain2D), dimension(:), allocatable, target :: domain
!     type(fieldtype), allocatable, dimension(:) :: fields
!     type(atttype), allocatable, dimension(:) :: global_atts
!     real, allocatable, dimension(:) :: times
!   ...
!     call mpp_define_domains( (/1,nx,1,ny/), domain )
!   
!     call mpp_read_meta(unit)
!     call mpp_get_info(unit,natt,nvar,ntime)
!     allocate(global_atts(natt))
!     call mpp_get_atts(unit,global_atts)
!     allocate(fields(nvar))
!     call mpp_get_vars(unit, fields)
!     allocate(times(ntime))
!     call mpp_get_times(unit, times)
!   
!     allocate( a(domain(pe)%x%data%start_index:domain(pe)%x%data%end_index, &
!                 domain(pe)%y%data%start_index:domain(pe)%y%data%end_index,nz) )
!   ...
!     do i=1, nvar
!       if (fields(i)%name == 'a')  call mpp_read(unit,fields(i),domain(pe), a,
!                                                 tindex)
!     enddo
!   ...
!   </PRE>
!   
!   In this example, the data are distributed as in the previous
!   example. The call to <LINK
!   SRC="#mpp_read_meta">mpp_read_meta</LINK> initializes
!   all of the metadata associated with the file, including global
!   attributes, variable attributes and non-record dimension data. The
!   call to <TT>mpp_get_info</TT> returns the number of global
!   attributes (<TT>natt</TT>), variables (<TT>nvar</TT>) and
!   time levels (<TT>ntime</TT>) associated with the file
!   identified by a unique ID (<TT>unit</TT>).
!   <TT>mpp_get_atts</TT> returns all global attributes for
!   the file in the derived type <TT>atttype(natt)</TT>.
!   <TT>mpp_get_vars</TT> returns variable types
!   (<TT>fieldtype(nvar)</TT>).  Since the record dimension data are not allocated for calls to <LINK SRC="#mpp_write">mpp_write</LINK>, a separate call to  <TT>mpp_get_times</TT> is required to access record dimension data.  Subsequent calls to
!   <TT>mpp_read</TT> return the field data arrays corresponding to
!   the fieldtype.  The <TT>domain</TT> type is an optional
!   argument.  If <TT>domain</TT> is omitted, the incoming field
!   array should be dimensioned for the global domain, otherwise, the
!   field data is assigned to the computational domain of a local array.
!   
!   <I>Multi-fileset</I> reads are not supported with <TT>mpp_read</TT>.

! </DESCRIPTION>

module mpp_io_mod
#include <fms_platform.h>

use mpp_parameter_mod,  only : MPP_WRONLY, MPP_RDONLY, MPP_APPEND, MPP_OVERWR, MPP_ASCII
use mpp_parameter_mod,  only : MPP_IEEE32, MPP_NATIVE, MPP_NETCDF, MPP_SEQUENTIAL
use mpp_parameter_mod,  only : MPP_DIRECT, MPP_SINGLE, MPP_MULTI, MPP_DELETE, MPP_COLLECT
use mpp_parameter_mod,  only : MPP_DEBUG, MPP_VERBOSE, NULLUNIT, NULLTIME, ALL_PES
use mpp_parameter_mod,  only : CENTER, EAST, NORTH, CORNER
use mpp_parameter_mod,  only : MAX_FILE_SIZE, GLOBAL_ROOT_ONLY, XUPDATE, YUPDATE
use mpp_mod,            only : mpp_error, FATAL, WARNING, NOTE, stdin, stdout, stderr, stdlog
use mpp_mod,            only : mpp_pe, mpp_root_pe, mpp_npes, lowercase, mpp_transmit
use mpp_mod,            only : mpp_init, mpp_sync, mpp_clock_id, mpp_clock_begin, mpp_clock_end
use mpp_mod,            only : MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_ROUTINE
use mpp_mod,            only : input_nml_file
use mpp_domains_mod,    only : domain1d, domain2d, NULL_DOMAIN1D, mpp_domains_init
use mpp_domains_mod,    only : mpp_get_global_domain, mpp_get_compute_domain
use mpp_domains_mod,    only :  mpp_get_data_domain, mpp_get_memory_domain
use mpp_domains_mod,    only : mpp_update_domains, mpp_global_field, mpp_domain_is_symmetry
use mpp_domains_mod,    only : operator( .NE. ), mpp_get_domain_shift
use mpp_domains_mod,    only : mpp_get_io_domain, mpp_domain_is_tile_root_pe, mpp_get_domain_tile_root_pe
use mpp_domains_mod,    only : mpp_get_tile_id, mpp_get_tile_npes, mpp_get_io_domain_layout
use mpp_domains_mod,    only : mpp_get_domain_name, mpp_get_domain_npes

implicit none
private

#ifdef use_netCDF
#include <netcdf.inc>
#endif

  !--- public parameters  -----------------------------------------------
  public :: MPP_WRONLY, MPP_RDONLY, MPP_APPEND, MPP_OVERWR, MPP_ASCII, MPP_IEEE32
  public :: MPP_NATIVE, MPP_NETCDF, MPP_SEQUENTIAL, MPP_DIRECT, MPP_SINGLE
  public :: MPP_MULTI, MPP_DELETE, MPP_COLLECT
  public :: FILE_TYPE_USED
  public :: MAX_FILE_SIZE
  !--- public data type ------------------------------------------------
  public :: axistype, atttype, fieldtype, validtype, filetype

  !--- public data -----------------------------------------------------
  public :: default_field, default_axis, default_att
    
  !--- public interface from mpp_io_util.h ----------------------
  public :: mpp_get_iospec, mpp_get_id, mpp_get_ncid, mpp_get_unit_range, mpp_is_valid
  public :: mpp_set_unit_range, mpp_get_info, mpp_get_atts, mpp_get_fields
  public :: mpp_get_times, mpp_get_axes, mpp_get_recdimid, mpp_get_axis_data
  public :: mpp_io_set_stack_size, mpp_get_field_index, mpp_get_axis_index
  public :: mpp_get_field_name, mpp_get_att_value, mpp_get_att_length
  public :: mpp_get_att_type, mpp_get_att_name, mpp_get_att_real, mpp_get_att_char
  public :: mpp_get_att_real_scalar
  public :: mpp_get_file_name, mpp_file_is_opened 
  public :: mpp_io_clock_on

  !--- public interface from mpp_io_misc.h ----------------------
  public :: mpp_io_init, mpp_io_exit, netcdf_err, mpp_flush

  !--- public interface from mpp_io_write.h ---------------------
  public :: mpp_write, mpp_write_meta, mpp_copy_meta, mpp_modify_meta

  !--- public interface from mpp_io_read.h ---------------------
  public :: mpp_read, mpp_read_meta, mpp_get_tavg_info

  !--- public interface from mpp_io_switch.h ---------------------
  public :: mpp_open, mpp_close

  !-----------------------------------------------------------------------------
  !--- mpp_io data types
  !-----------------------------------------------------------------------------
integer FILE_TYPE_USED  
type :: atttype
     private
     integer             :: type, len
     character(len=128)  :: name
     character(len=1280) :: catt
     real, pointer       :: fatt(:) =>NULL() ! just use type conversion for integers
  end type atttype

  type :: axistype
     private
     character(len=128) :: name
     character(len=128) :: units
     character(len=256) :: longname
     character(len=8)   :: cartesian
     character(len=24)  :: calendar
     integer            :: sense, len          !+/-1, depth or height?
     type(domain1D)     :: domain              !if pointer is associated, it is a distributed data axis
     real, pointer      :: data(:) =>NULL()    !axis values (not used if time axis)
     integer            :: id, did, type, natt !id is the "variable ID", did is the "dimension ID": 
                                               !netCDF requires 2 IDs for axes
     integer            :: shift               !normally is 0. when domain is symmetry, its value maybe 1.
     type(atttype), pointer :: Att(:) =>NULL()
  end type axistype

  type :: validtype
     private
     logical :: is_range ! if true, then the data represent the valid range
     real    :: min,max  ! boundaries of the valid range or missing value
  end type validtype

  type :: fieldtype
     private
     character(len=128)      :: name
     character(len=128)      :: units
     character(len=256)      :: longname
     character(len=128)      :: standard_name   ! CF standard name
     real                    :: min, max, missing, fill, scale, add
     integer                 :: pack
     type(axistype), pointer :: axes(:) =>NULL() !axes associated with field size, time_axis_index redundantly 
                                        !hold info already contained in axes. it's clunky and inelegant, 
                                        !but required so that axes can be shared among multiple files
     integer, pointer        :: size(:) =>NULL()
     integer                 :: time_axis_index
     integer                 :: id, type, natt, ndim
     type(atttype), pointer  :: Att(:) =>NULL()
     integer                 :: position ! indicate the location of the data ( CENTER, NORTH, EAST, CORNER )
  end type fieldtype

  type :: filetype
     private
     character(len=256) :: name
     integer            :: action, format, access, threading, fileset, record, ncid
     logical            :: opened, initialized, nohdrs
     integer            :: time_level
     real(DOUBLE_KIND)  :: time
     logical            :: valid
     logical            :: write_on_this_pe   ! indicate if will write out from this pe
     logical            :: io_domain_exist    ! indicate if io_domain exist or not.
     integer            :: id       !variable ID of time axis associated with file (only one time axis per file)
     integer            :: recdimid !dim ID of time axis associated with file (only one time axis per file)
     real(DOUBLE_KIND), pointer :: time_values(:) =>NULL() ! time axis values are stored here instead of axis%data 
                                                  ! since mpp_write assumes these values are not time values. 
                                                  ! Not used in mpp_write
     ! additional elements of filetype for mpp_read (ignored for mpp_write)
     integer :: ndim, nvar, natt  ! number of dimensions, non-dimension variables and global attributes
                                  ! redundant axis types stored here and in associated fieldtype
                                  ! some axes are not used by any fields, i.e. "edges"
     type(axistype), pointer  :: axis(:) =>NULL()
     type(fieldtype), pointer :: var(:) =>NULL()
     type(atttype), pointer   :: att(:) =>NULL()
     type(domain2d), pointer  :: domain =>NULL()
  end type filetype

!***********************************************************************
!
!     public interface from mpp_io_util.h
!
!***********************************************************************
  interface mpp_get_id
     module procedure mpp_get_axis_id
     module procedure mpp_get_field_id
  end interface

! <INTERFACE NAME="mpp_get_atts">
!   <OVERVIEW>
!     Get file global metdata.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Get file global metdata.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call mpp_get_atts( unit, global_atts)
!   </TEMPLATE>
!  <IN NAME="unit"></IN>
!  <IN NAME="global_atts"></IN>
! </INTERFACE>
  interface mpp_get_atts
     module procedure mpp_get_global_atts
     module procedure mpp_get_field_atts
     module procedure mpp_get_axis_atts
  end interface

  interface mpp_get_att_value
     module procedure mpp_get_field_att_text 
  end interface


!***********************************************************************
!
!      public interface from mpp_io_read.h
!
!***********************************************************************
! <INTERFACE NAME="mpp_read">
!   <OVERVIEW>
!     Read from an open file.
!   </OVERVIEW>
!   <DESCRIPTION>
!      <TT>mpp_read</TT> is used to read data to the file on an I/O unit
!      using the file parameters supplied by <LINK
!      SRC="#mpp_open"><TT>mpp_open</TT></LINK>. There are two
!      forms of <TT>mpp_read</TT>, one to read
!      distributed field data, and one to read non-distributed field
!      data. <I>Distributed</I> data refer to arrays whose two
!      fastest-varying indices are domain-decomposed. Distributed data must
!      be 2D or 3D (in space). Non-distributed data can be 0-3D.
!
!      The <TT>data</TT> argument for distributed data is expected by
!      <TT>mpp_read</TT> to contain data specified on the <I>data</I> domain,
!      and will read the data belonging to the <I>compute</I> domain,
!      fetching data as required by the parallel I/O <LINK
!      SRC="#modes">mode</LINK> specified in the <TT>mpp_open</TT> call. This
!      is consistent with our definition of <LINK
!      SRC="http:mpp_domains.html#domains">domains</LINK>, where all arrays are
!      expected to be dimensioned on the data domain, and all operations
!      performed on the compute domain.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call mpp_read( unit, field, data, time_index )
!   </TEMPLATE>
!   <TEMPLATE>
!     call mpp_read( unit, field, domain, data, time_index )
!   </TEMPLATE>
!  <IN NAME="unit"></IN>
!  <IN NAME="field"></IN>
!  <INOUT NAME="data"></INOUT>
!  <IN NAME="domain"></IN>
!  <IN NAME="time_index">
!     time_index is an optional argument. It is to be omitted if the
!     field was defined not to be a function of time. Results are
!     unpredictable if the argument is supplied for a time- independent
!     field, or omitted for a time-dependent field.
!  </IN>
!  <NOTE>
!     The type of read performed by <TT>mpp_read</TT> depends on
!     the file characteristics on the I/O unit specified at the <LINK
!     SRC="#mpp_open"><TT>mpp_open</TT></LINK> call. Specifically, the
!     format of the input data (e.g netCDF or IEEE) and the
!     <TT>threading</TT> flags, etc., can be changed there, and
!     require no changes to the <TT>mpp_read</TT>
!     calls. (<TT>fileset</TT> = MPP_MULTI is not supported by
!     <TT>mpp_read</TT>; IEEE is currently not supported).
!
!     Packed variables are unpacked using the <TT>scale</TT> and
!     <TT>add</TT> attributes.
!
!     <TT>mpp_read_meta</TT> must be called prior to calling <TT>mpp_read.</TT>
!  </NOTE>
! </INTERFACE>
  interface mpp_read
     module procedure mpp_read_2ddecomp_r2d
     module procedure mpp_read_2ddecomp_r3d
     module procedure mpp_read_r0D
     module procedure mpp_read_r1D
     module procedure mpp_read_r2D
     module procedure mpp_read_r3D
     module procedure mpp_read_text
     module procedure mpp_read_region_r2D
  end interface

!***********************************************************************
!
!    public interface from mpp_io_write.h
!
!***********************************************************************

! <INTERFACE NAME="mpp_write_meta">
!   <OVERVIEW>
!     Write metadata.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine is used to write the <LINK SRC="#metadata">metadata</LINK>
!     describing the contents of a file being written. Each file can contain
!     any number of fields, which are functions of 0-3 space axes and 0-1
!     time axes. (Only one time axis can be defined per file). The basic
!     metadata defined <LINK SRC="#metadata">above</LINK> for <TT>axistype</TT>
!     and <TT>fieldtype</TT> are written in the first two forms of the call
!     shown below. These calls will associate a unique variable ID with each
!     variable (axis or field). These can be used to attach any other real,
!     integer or character attribute to a variable. The last form is used to
!     define a <I>global</I> real, integer or character attribute that
!     applies to the dataset as a whole.
!   </DESCRIPTION>
!  <TEMPLATE>
!    call mpp_write_meta( unit, axis, name, units, longname,
!      cartesian, sense, domain, data )
!  </TEMPLATE>
!  <NOTE>
!    The first form defines a time or space axis. Metadata corresponding to the type
!    above are written to the file on &lt;unit&gt;. A unique ID for subsequen
!    references to this axis is returned in axis%id. If the &lt;domain&gt;
!    element is present, this is recognized as a distributed data axis
!    and domain decomposition information is also written if required (the
!    domain decomposition info is required for multi-fileset multi-threaded
!    I/O). If the &lt;data&gt; element is allocated, it is considered to be a
!    space axis, otherwise it is a time axis with an unlimited dimension. Only
!    one time axis is allowed per file.
!  </NOTE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, field, axes, name, units, longname,
!                              min, max, missing, fill, scale, add, pack )
!  </TEMPLATE>
!  <NOTE>
!    The second form defines a field. Metadata corresponding to the type
!    above are written to the file on &lt;unit&gt;. A unique ID for subsequen
!    references to this field is returned in field%id. At least one axis
!    must be associated, 0D variables are not considered. mpp_write_meta
!    must previously have been called on all axes associated with this
!    field.
!  </NOTE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, id, name, rval=rval, pack=pack )
!  </TEMPLATE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, id, name, ival=ival )
!  </TEMPLATE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, id, name, cval=cval )
!  </TEMPLATE>
!  <NOTE>
!    The third form (3 - 5) defines metadata associated with a previously defined
!    axis or field, identified to mpp_write_meta by its unique ID &lt;id&gt;.
!    The attribute is named &lt;name&gt; and can take on a real, integer
!    or character value. &lt;rval&gt; and &lt;ival&gt; can be scalar or 1D arrays.
!    This need not be called for attributes already contained in
!    the type.
!  </NOTE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, name, rval=rval, pack=pack )
!  </TEMPLATE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, name, ival=ival )
!  </TEMPLATE>
!  <TEMPLATE>
!    call mpp_write_meta( unit, name, cval=cval )
!  </TEMPLATE>
!  <NOTE>
!    The last form (6 - 8) defines global metadata associated with the file as a
!    whole. The attribute is named &lt;name&gt; and can take on a real, integer
!    or character value. &lt;rval&gt; and &lt;ival&gt; can be scalar or 1D arrays.
!  </NOTE>
!  <IN NAME="unit"></IN>
!  <OUT NAME="axis"></OUT>
!  <IN NAME="name"></IN>
!  <IN NAME="units"></IN>
!  <IN NAME="longname"></IN>
!  <IN NAME="cartesian"></IN>
!  <IN NAME="sense"></IN>
!  <IN NAME="domain"></IN>
!  <IN NAME="data"></IN>
!  <OUT NAME="field"></OUT>
!  <IN NAME="min, max"></IN>
!  <IN NAME="missing"></IN>
!  <IN NAME="fill"></IN>
!  <IN NAME="scale"></IN>
!  <IN NAME="add"></IN>
!  <IN NAME="pack"></IN>
!  <IN NAME="id"></IN>
!  <IN NAME="cval"></IN>
!  <IN NAME="ival"></IN>
!  <IN NAME="rval"></IN>
! <NOTE>
!    Note that <TT>mpp_write_meta</TT> is expecting axis data on the
!    <I>global</I> domain even if it is a domain-decomposed axis.
!
!    You cannot interleave calls to <TT>mpp_write</TT> and
!    <TT>mpp_write_meta</TT>: the first call to
!    <TT>mpp_write</TT> implies that metadata specification is complete.
! </NOTE>
! </INTERFACE>
  interface mpp_write_meta
     module procedure mpp_write_meta_var
     module procedure mpp_write_meta_scalar_r
     module procedure mpp_write_meta_scalar_i
     module procedure mpp_write_meta_axis
     module procedure mpp_write_meta_field
     module procedure mpp_write_meta_global
     module procedure mpp_write_meta_global_scalar_r
     module procedure mpp_write_meta_global_scalar_i
  end interface
     
  interface mpp_copy_meta
     module procedure mpp_copy_meta_axis
     module procedure mpp_copy_meta_field
     module procedure mpp_copy_meta_global
  end interface

  interface mpp_modify_meta
!     module procedure mpp_modify_att_meta
     module procedure mpp_modify_field_meta
     module procedure mpp_modify_axis_meta
  end interface

! <INTERFACE NAME="mpp_write">
!   <OVERVIEW>
!     Write to an open file.
!   </OVERVIEW>
!   <DESCRIPTION>
!    <TT>mpp_write</TT> is used to write data to the file on an I/O unit
!    using the file parameters supplied by <LINK
!    SRC="#mpp_open"><TT>mpp_open</TT></LINK>. Axis and field definitions must
!    have previously been written to the file using <LINK
!    SRC="#mpp_write_meta"><TT>mpp_write_meta</TT></LINK>.  There are three
!    forms of <TT>mpp_write</TT>, one to write axis data, one to write
!    distributed field data, and one to write non-distributed field
!    data. <I>Distributed</I> data refer to arrays whose two
!    fastest-varying indices are domain-decomposed. Distributed data must
!    be 2D or 3D (in space). Non-distributed data can be 0-3D.
!
!    The <TT>data</TT> argument for distributed data is expected by
!    <TT>mpp_write</TT> to contain data specified on the <I>data</I> domain,
!    and will write the data belonging to the <I>compute</I> domain,
!    fetching or sending data as required by the parallel I/O <LINK
!    SRC="#modes">mode</LINK> specified in the <TT>mpp_open</TT> call. This
!    is consistent with our definition of <LINK
!    SRC="http:mpp_domains.html#domains">domains</LINK>, where all arrays are
!    expected to be dimensioned on the data domain, and all operations
!    performed on the compute domain.
!
!     The type of the <TT>data</TT> argument must be a <I>default
!     real</I>, which can be 4 or 8 byte.
!   </DESCRIPTION>
!  <TEMPLATE>
!    mpp_write( unit, axis )
!  </TEMPLATE>
!  <TEMPLATE>
!    mpp_write( unit, field, data, tstamp )
!  </TEMPLATE>
!  <TEMPLATE>
!    mpp_write( unit, field, domain, data, tstamp )
!  </TEMPLATE>
!  <IN NAME="tstamp">
!    <TT>tstamp</TT> is an optional argument. It is to
!    be omitted if the field was defined not to be a function of time.
!    Results are unpredictable if the argument is supplied for a time-
!    independent field, or omitted for a time-dependent field. Repeated
!    writes of a time-independent field are also not recommended. One
!    time level of one field is written per call. tstamp must be an 8-byte
!    real, even if the default real type is 4-byte.
!  </IN>
!  <NOTE>
!    The type of write performed by <TT>mpp_write</TT> depends on the file
!    characteristics on the I/O unit specified at the <LINK
!    SRC="#mpp_open"><TT>mpp_open</TT></LINK> call. Specifically, the format of
!    the output data (e.g netCDF or IEEE), the <TT>threading</TT> and
!    <TT>fileset</TT> flags, etc., can be changed there, and require no
!    changes to the <TT>mpp_write</TT> calls.
!
!    Packing is currently not implemented for non-netCDF files, and the
!    <TT>pack</TT> attribute is ignored. On netCDF files,
!    <TT>NF_DOUBLE</TT>s (8-byte IEEE floating point numbers) are
!    written for <TT>pack</TT>=1 and <TT>NF_FLOAT</TT>s for
!    <TT>pack</TT>=2. (<TT>pack</TT>=2 gives the customary
!    and default behaviour). We write <TT>NF_SHORT</TT>s (2-byte
!    integers) for <TT>pack=4</TT>, or <TT>NF_BYTE</TT>s
!    (1-byte integers) for <TT>pack=8</TT>. Integer scaling is done
!    using the <TT>scale</TT> and <TT>add</TT> attributes at
!    <TT>pack</TT>=4 or 8, satisfying the relation
!
!    <PRE>
!    data = packed_data*scale + add
!    </PRE>
!
!    <TT>NOTE: mpp_write</TT> does not check to see if the scaled
!    data in fact fits into the dynamic range implied by the specified
!    packing. It is incumbent on the user to supply correct scaling
!    attributes.
!
!    You cannot interleave calls to <TT>mpp_write</TT> and
!    <TT>mpp_write_meta</TT>: the first call to
!    <TT>mpp_write</TT> implies that metadata specification is
!    complete.
! </NOTE>
! </INTERFACE>
  interface mpp_write
     module procedure mpp_write_2ddecomp_r2d
     module procedure mpp_write_2ddecomp_r3d
     module procedure mpp_write_2ddecomp_r4d
     module procedure mpp_write_r0D
     module procedure mpp_write_r1D
     module procedure mpp_write_r2D
     module procedure mpp_write_r3D
     module procedure mpp_write_r4D
     module procedure mpp_write_axis
  end interface

!***********************************************************************
!
!            module variables
!
!***********************************************************************
  logical            :: module_is_initialized = .FALSE.
  logical            :: verbose =.FALSE.
  logical            :: debug = .FALSE.
  integer            :: maxunits, unit_begin, unit_end
  integer            :: mpp_io_stack_size=0, mpp_io_stack_hwm=0
  integer            :: varnum=0
  integer            :: pe, npes
  character(len=256) :: text
  integer            :: error
  integer            :: records_per_pe
  integer            :: mpp_read_clock=0, mpp_write_clock=0
  integer            :: mpp_open_clock=0, mpp_close_clock=0


!initial value of buffer between meta_data and data in .nc file
  integer            :: header_buffer_val = 16384  ! value used in NF__ENDDEF
  logical            :: global_field_on_root_pe = .true.
  logical            :: io_clocks_on = .false.
  integer            :: shuffle = 0
  integer            :: deflate = 0
  integer            :: deflate_level = -1
  
  namelist /mpp_io_nml/header_buffer_val, global_field_on_root_pe, io_clocks_on, &
                       shuffle, deflate_level

  real(DOUBLE_KIND), allocatable :: mpp_io_stack(:)
  type(axistype),save            :: default_axis      !provided to users with default components
  type(fieldtype),save           :: default_field     !provided to users with default components
  type(atttype),save             :: default_att       !provided to users with default components
  type(filetype), allocatable    :: mpp_file(:)


  character(len=128) :: version= &
       '$Id: mpp_io.F90,v 16.0.8.2.2.2.4.1.6.1.2.1.6.2.2.1 2010/08/04 13:10:12 z1l Exp $'
  character(len=128) :: tagname= &
       '$Name: hiram_20101115_bw $'

contains

#include <mpp_io_util.inc>
#include <mpp_io_misc.inc>
#include <mpp_io_connect.inc>
#include <mpp_io_read.inc>
#include <mpp_io_write.inc>

end module mpp_io_mod




module mpp_memutils_mod

  use mpp_mod, only: mpp_min, mpp_max, mpp_sum, mpp_pe, mpp_root_pe
  use mpp_mod, only: mpp_error, FATAL, stderr, mpp_npes, get_unit

  implicit none
  private

  public :: mpp_print_memuse_stats, mpp_mem_dump
  public :: mpp_memuse_begin, mpp_memuse_end

  real    :: begin_memuse
  logical :: memuse_started = .false.

contains

  !#######################################################################
  subroutine mpp_memuse_begin
#if defined(__sgi) || defined(__aix) || defined(__SX)
    integer :: memuse
#endif

    if(memuse_started) then
       call mpp_error(FATAL, "mpp_memutils_mod: mpp_memuse_begin was already called")
    endif
    memuse_started = .true.

#if defined(__sgi) || defined(__aix) || defined(__SX)
    begin_memuse = memuse()*1e-3
#else
    call mpp_mem_dump(begin_memuse)
#endif 

  end subroutine mpp_memuse_begin

  !#######################################################################
  subroutine mpp_memuse_end( text, unit )

    character(len=*), intent(in) :: text
    integer, intent(in), optional :: unit
    real    :: m, mmin, mmax, mavg, mstd, end_memuse
    integer :: mu
#if defined(__sgi) || defined(__aix) || defined(__SX)
    integer :: memuse
#endif

    if(.NOT.memuse_started) then
       call mpp_error(FATAL, "mpp_memutils_mod: mpp_memuse_begin must be called before calling mpp_memuse_being")
    endif
    memuse_started = .false.

#if defined(__sgi) || defined(__aix) || defined(__SX)
    end_memuse = memuse()*1e-3
#else
    call mpp_mem_dump(end_memuse)
#endif 

    mu = stderr(); if( PRESENT(unit) )mu = unit
    m = end_memuse - begin_memuse
    mmin = m; call mpp_min(mmin)
    mmax = m; call mpp_max(mmax)
    mavg = m; call mpp_sum(mavg); mavg = mavg/mpp_npes()
    mstd = (m-mavg)**2; call mpp_sum(mstd); mstd = sqrt( mstd/mpp_npes() )
    if( mpp_pe().EQ.mpp_root_pe() )write( mu,'(a64,4es11.3)' ) &
         'Memory(MB) used in '//trim(text)//'=', mmin, mmax, mstd, mavg

    return    

  end subroutine mpp_memuse_end

  !#######################################################################

  subroutine mpp_print_memuse_stats( text, unit )

    character(len=*), intent(in) :: text
    integer, intent(in), optional :: unit
    real :: m, mmin, mmax, mavg, mstd
    integer :: mu
!memuse is an external function: works on SGI
!use #ifdef to generate equivalent on other platforms.
#if defined(__sgi) || defined(__aix) || defined(__SX)
    integer :: memuse !default integer OK?
#endif 

    mu = stderr(); if( PRESENT(unit) )mu = unit
#if defined(__sgi) || defined(__aix) || defined(__SX)
    m = memuse()*1e-3
#else
    call mpp_mem_dump(m)
#endif 
    mmin = m; call mpp_min(mmin)
    mmax = m; call mpp_max(mmax)
    mavg = m; call mpp_sum(mavg); mavg = mavg/mpp_npes()
    mstd = (m-mavg)**2; call mpp_sum(mstd); mstd = sqrt( mstd/mpp_npes() )
    if( mpp_pe().EQ.mpp_root_pe() )write( mu,'(a64,4es11.3)' ) &
         'Memuse(MB) at '//trim(text)//'=', mmin, mmax, mstd, mavg

    return
  end subroutine mpp_print_memuse_stats

!#######################################################################

subroutine mpp_mem_dump ( memuse )

real, intent(out) :: memuse

! This routine returns the memory usage on Linux systems.
! It does this by querying a system file (file_name below).
! It is intended for use by print_memuse_stats above.

character(len=32) :: file_name = '/proc/self/status'
character(len=32) :: string
integer :: mem_unit
real    :: multiplier

  memuse = 0.0
  multiplier = 1.0

  mem_unit = get_unit()
  open(mem_unit, file=file_name, form='FORMATTED', action='READ', access='SEQUENTIAL')
  
  do; read (mem_unit,'(a)', end=10) string
    if ( INDEX ( string, 'VmHWM:' ) == 1 ) then
      read (string(7:LEN_TRIM(string)-2),*) memuse
      exit
    endif
  enddo
  
  if (TRIM(string(LEN_TRIM(string)-1:)) == "kB" ) &
    multiplier = 1.0/1024. ! Convert from kB to MB

10 close (mem_unit)
   memuse = memuse * multiplier

  return
end subroutine mpp_mem_dump


end module mpp_memutils_mod


module mpp_parameter_mod
#include <fms_platform.h>

  implicit none
  private

  character(len=128), public :: version= &
       '$Id mpp_parameter.F90 $'
  character(len=128), public :: tagname= &
       '$Name: hiram_20101115_bw $'

  !--- public paramters which is used by mpp_mod and its components. 
  !--- All othere modules should import these parameters from mpp_mod. 
  public :: MAXPES, MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, NOTE, WARNING, FATAL
  public :: MPP_WAIT, MPP_READY, MAX_CLOCKS, MAX_EVENT_TYPES, MAX_EVENTS, MPP_CLOCK_SYNC
  public :: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER
  public :: CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA, MAX_BINS, PESET_MAX
  public :: EVENT_ALLREDUCE, EVENT_BROADCAST, EVENT_RECV, EVENT_SEND, EVENT_WAIT

  !--- public paramters which is used by mpp_domains_mod and its components. 
  !--- All othere modules should import these parameters from mpp_domains_mod. 
  public :: GLOBAL_DATA_DOMAIN, CYCLIC_GLOBAL_DOMAIN, BGRID_NE, BGRID_SW, CGRID_NE, CGRID_SW
  public :: DGRID_NE, DGRID_SW, FOLD_WEST_EDGE, FOLD_EAST_EDGE, FOLD_SOUTH_EDGE, FOLD_NORTH_EDGE
  public :: WUPDATE, EUPDATE, SUPDATE, NUPDATE, XUPDATE, YUPDATE, BITWISE_EXACT_SUM, NON_BITWISE_EXACT_SUM
  public :: MPP_DOMAIN_TIME, WEST, EAST, SOUTH, NORTH, SCALAR_BIT, SCALAR_PAIR
  public :: NORTH_EAST, SOUTH_EAST, SOUTH_WEST, NORTH_WEST
  public :: AGRID, GLOBAL, CYCLIC, DOMAIN_ID_BASE, CENTER, CORNER
  public :: MAX_DOMAIN_FIELDS, MAX_TILES
  public :: ZERO, NINETY, MINUS_NINETY, ONE_HUNDRED_EIGHTY

  !--- public paramters which is used by mpp_domains_mod and its components. 
  !--- All othere modules should import these parameters from mpp_io_mod. 
  public :: MPP_WRONLY, MPP_RDONLY, MPP_APPEND, MPP_OVERWR, MPP_ASCII, MPP_IEEE32
  public :: MPP_NATIVE, MPP_NETCDF, MPP_SEQUENTIAL, MPP_DIRECT, MPP_SINGLE, MPP_MULTI
  public :: MPP_DELETE, MPP_COLLECT, NULLUNIT, NULLTIME
  public :: MAX_FILE_SIZE, ROOT_GLOBAL, GLOBAL_ROOT_ONLY

  !--- The following paramters are used by mpp_mod and its components.
  integer, parameter :: MAXPES=2048            !used for dimensioning stuff that might be indexed by pe
  integer, parameter :: MPP_VERBOSE=1, MPP_DEBUG=2
  integer, parameter :: ALL_PES=-1, ANY_PE=-2, NULL_PE=-3
  integer, parameter :: NOTE=0, WARNING=1, FATAL=2
  integer, parameter :: MAX_CLOCKS=400, MAX_EVENT_TYPES=5, MAX_EVENTS=40000
  integer, parameter :: EVENT_ALLREDUCE=1, EVENT_BROADCAST=2, EVENT_RECV=3, EVENT_SEND=4, EVENT_WAIT=5
  integer, parameter :: MPP_CLOCK_SYNC=1, MPP_CLOCK_DETAILED=2
  !--- predefined clock granularities, but you can use any integer
  !--- using CLOCK_LOOP and above may distort coarser-grain measurements
  integer, parameter :: CLOCK_COMPONENT=1      !component level, e.g model, exchange
  integer, parameter :: CLOCK_SUBCOMPONENT=11  !top level within a model component, e.g dynamics, physics
  integer, parameter :: CLOCK_MODULE_DRIVER=21 !module driver level, e.g adriver that calls multiple 
                                               !related physics routines
  integer, parameter :: CLOCK_MODULE=31        !module level, e.g main subroutine of a physics module
  integer, parameter :: CLOCK_ROUTINE=41       !level of individual subroutine or function
  integer, parameter :: CLOCK_LOOP=51          !loops or blocks within a routine
  integer, parameter :: CLOCK_INFRA=61         !infrastructure level, e.g halo update
  integer, parameter :: MAX_BINS=20
  integer, parameter :: PESET_MAX=32           !should be .LE. max num of MPI communicators
  integer(LONG_KIND), parameter :: MPP_WAIT=-1, MPP_READY=-2

  !--- The following paramters are used by mpp_domains_mod and its components.
  integer, parameter :: GLOBAL=0, CYCLIC=1
  integer, parameter :: WEST=2, EAST=3, SOUTH=4, NORTH=5, SCALAR_BIT=6, CENTER=7, CORNER=8
  integer, parameter :: SOUTH_WEST=7, SOUTH_EAST=8, NORTH_WEST=9, NORTH_EAST=10
  integer, parameter :: SEND=1, RECV=2
  integer, parameter :: GLOBAL_DATA_DOMAIN=2**GLOBAL, CYCLIC_GLOBAL_DOMAIN=2**CYCLIC
  integer, parameter :: AGRID=0, BGRID=1, CGRID=2, DGRID=3
  integer, parameter :: BGRID_NE=BGRID+2**NORTH+2**EAST
  integer, parameter :: BGRID_SW=BGRID+2**SOUTH+2**WEST
  integer, parameter :: CGRID_NE=CGRID+2**NORTH+2**EAST
  integer, parameter :: CGRID_SW=CGRID+2**SOUTH+2**WEST
  integer, parameter :: DGRID_NE=DGRID+2**NORTH+2**EAST
  integer, parameter :: DGRID_SW=DGRID+2**SOUTH+2**WEST
  integer, parameter :: FOLD_WEST_EDGE = 2**WEST, FOLD_EAST_EDGE = 2**EAST
  integer, parameter :: FOLD_SOUTH_EDGE=2**SOUTH, FOLD_NORTH_EDGE=2**NORTH
  integer, parameter :: WUPDATE=2**WEST, EUPDATE=2**EAST, SUPDATE=2**SOUTH, NUPDATE=2**NORTH
  integer, parameter :: XUPDATE=WUPDATE+EUPDATE, YUPDATE=SUPDATE+NUPDATE, SCALAR_PAIR=2**SCALAR_BIT
  integer, parameter :: ZERO=0, NINETY=90, MINUS_NINETY=-90, ONE_HUNDRED_EIGHTY=180

! DOMAIN_ID_BASE acts as a counter increment for domains as they are defined. It's used in
! combination with the flag parameter defined above to create a unique identifier for
! each Domain+flags combination. Therefore, the value of any flag must not exceed DOMAIN_ID_BASE.
! integer(LONG_KIND), parameter :: DOMAIN_ID_BASE=INT( 2**(4*LONG_KIND),KIND=LONG_KIND )
  integer(LONG_KIND), parameter :: DOMAIN_ID_BASE=Z'0000000100000000' ! Workaround for 64bit init problem
  integer, parameter :: NON_BITWISE_EXACT_SUM=0
  integer, parameter :: BITWISE_EXACT_SUM=1
  integer, parameter :: MPP_DOMAIN_TIME=MPP_DEBUG+1
  integer, parameter :: MAX_DOMAIN_FIELDS=100
  integer, parameter :: MAX_TILES=100

  !--- The following paramters are used by mpp_io_mod and its components.
  integer, parameter :: MPP_WRONLY=100, MPP_RDONLY=101, MPP_APPEND=102, MPP_OVERWR=103 !action on open
  integer, parameter :: MPP_ASCII=200,  MPP_IEEE32=201, MPP_NATIVE=202, MPP_NETCDF=203 !format
  integer, parameter :: MPP_SEQUENTIAL=300, MPP_DIRECT=301 !access
  integer, parameter :: MPP_SINGLE=400, MPP_MULTI=401      !threading, fileset
  integer, parameter :: MPP_DELETE=501, MPP_COLLECT=502    !action on close
  integer, parameter :: NULLUNIT=-1                        !returned by PEs not participating in 
                                                           !IO after a collective call with threading
                                                           !equal to MPP_SINGLE
  integer, parameter :: ROOT_GLOBAL = 9
  integer, parameter :: GLOBAL_ROOT_ONLY = 2**ROOT_GLOBAL 
  real(DOUBLE_KIND), parameter :: NULLTIME=-1.
#ifdef LARGE_FILE
  integer(LONG_KIND), parameter :: MAX_FILE_SIZE = 4294967295
#else
  integer(LONG_KIND), parameter :: MAX_FILE_SIZE = 2147483647
#endif

  !#####################################################################

end module mpp_parameter_mod


! module within MPP for handling PSETs:
! PSET: Persistent Shared-memory Execution Thread
!
! AUTHOR: V. Balaji (v.balaji@noaa.gov)
! DATE: 2006-01-15
#include <fms_platform.h>
#ifdef test_mpp_pset
!PSET_DEBUG is always turned on in the test program
#define PSET_DEBUG
#endif

module mpp_pset_mod
  use mpp_mod, only: mpp_pe, mpp_npes, mpp_root_pe, mpp_send, mpp_recv, &
       mpp_sync, mpp_error, FATAL, WARNING, stdout, stderr, mpp_chksum, &
       mpp_declare_pelist, mpp_get_current_pelist, mpp_set_current_pelist, &
       mpp_init
  implicit none
  private

!private variables
  integer :: pe
  integer :: commID !MPI communicator, copy here from pset
  logical :: verbose=.FALSE.
  logical :: module_is_initialized=.FALSE.
  character(len=256) :: text
#ifdef use_SGI_GSM
#include <mpp/shmem.fh>
  integer :: pSync(SHMEM_BARRIER_SYNC_SIZE)
  pointer( p_pSync, pSync ) !used by SHPALLOC
#endif
!generic interfaces
  interface mpp_pset_broadcast_ptr
     module procedure mpp_pset_broadcast_ptr_scalar
     module procedure mpp_pset_broadcast_ptr_array
  end interface
  interface mpp_send_ptr
     module procedure mpp_send_ptr_scalar
     module procedure mpp_send_ptr_array
  end interface
  interface mpp_recv_ptr
     module procedure mpp_recv_ptr_scalar
     module procedure mpp_recv_ptr_array
  end interface
  interface mpp_pset_print_chksum
     module procedure mpp_pset_print_chksum_1D
     module procedure mpp_pset_print_chksum_2D
     module procedure mpp_pset_print_chksum_3D
     module procedure mpp_pset_print_chksum_4D
  end interface
!public type
  type :: mpp_pset_type
     private
     sequence
     integer :: npset !number of PSETs
     integer :: next_in_pset, prev_in_pset !next and prev PE in PSET (cyclic)
     integer :: root_in_pset !PE designated to be the root within PSET
     logical :: root !true if you are the root PSET
     integer :: pos !position of current PE within pset
!stack is allocated by root
!it is then mapped to mpp_pset_stack by mpp_pset_broadcast_ptr
     real, _ALLOCATABLE :: stack(:) _NULL
     integer, _ALLOCATABLE :: pelist(:) _NULL !base PElist
     integer, _ALLOCATABLE :: root_pelist(:) _NULL !a PElist of all the roots
     integer, _ALLOCATABLE :: pset(:) _NULL !PSET IDs
     integer(POINTER_KIND) :: p_stack
     integer :: lstack, maxstack, hiWM !current stack length, max, hiWM
     integer :: commID
     character(len=32) :: name
     logical :: initialized=.FALSE.
  end type mpp_pset_type
!public types
  public :: mpp_pset_type
!public variables
!public member functions
  public :: mpp_pset_create, mpp_pset_sync, mpp_pset_broadcast, &
       mpp_pset_broadcast_ptr, mpp_pset_check_ptr, mpp_pset_segment_array, &
       mpp_pset_stack_push, mpp_pset_stack_reset, mpp_pset_print_chksum, &
       mpp_pset_delete, mpp_pset_root, mpp_pset_numroots, mpp_pset_init, &
       mpp_pset_get_root_pelist, mpp_pset_print_stack_chksum

contains
  subroutine mpp_pset_init
#ifdef use_SGI_GSM
    integer :: err
#ifdef sgi_mipspro
    character(len=8) :: value !won't be read
    integer :: lenname, lenval!won't be read
#endif
    if( module_is_initialized )return
!this part needs to be called _all_ PEs
    call SHMEM_BARRIER_ALL()
    call SHPALLOC( p_pSync, SHMEM_BARRIER_SYNC_SIZE, err, -1 )
    call SHMEM_BARRIER_ALL()
#ifdef sgi_mipspro
    call PXFGETENV( 'SMA_GLOBAL_ALLOC', 0, value, lenval, err )
    if( err.NE.0 )call mpp_error( FATAL, &
         'The environment variable SMA_GLOBAL_ALLOC must be set on Irix.' )
#endif
#endif
    module_is_initialized = .TRUE.
  end subroutine mpp_pset_init
  
  subroutine mpp_pset_create(npset,pset,stacksize,pelist, commID)
!create PSETs
!  called by all PEs in parent pelist
!  mpset must be exact divisor of npes
    integer, intent(in) :: npset !number of PSETs per set
    type(mpp_pset_type), intent(inout) :: pset
    integer, intent(in), optional :: stacksize
    integer, intent(in), optional :: pelist(:)
    integer, intent(in), optional :: commID

    integer :: npes, my_commID
    integer :: i, j, k, out_unit
    integer, allocatable :: my_pelist(:), root_pelist(:)

    call mpp_init()
    call mpp_pset_init()

#ifdef PSET_DEBUG
    verbose=.TRUE.
#endif
    out_unit = stdout()
    pe = mpp_pe()
    if(present(pelist)) then
       npes = size(pelist(:))
    else
       npes = mpp_npes()
    endif
    if( mod(npes,npset).NE.0 )then
        write( text,'(a,2i6)' ) &
             'MPP_PSET_CREATE: PSET size (npset) must divide npes exactly:'// &
             ' npset, npes=', npset, npes
        call mpp_error( FATAL, text )
    end if

    !configure out root_pelist
    allocate(my_pelist(0:npes-1) )
    allocate(root_pelist(0:npes/npset-1) )
    if(present(pelist)) then
       if(.not. present(commID)) call mpp_error(FATAL, &
         'MPP_PSET_CREATE: when pelist is present, commID should also be present')
       my_pelist = pelist
       my_commID = commID
    else
       call mpp_get_current_pelist(my_pelist, commID = my_commID)
    endif
    do i = 0,npes/npset-1
       root_pelist(i) = my_pelist(npset*i)
    enddo
    write( out_unit,'(a,i6)' )'MPP_PSET_CREATE creating PSETs... npset=', npset
    if(ANY(my_pelist == pe) ) then
    if( pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_CREATE: PSET already initialized!' )     
    pset%npset = npset
    allocate( pset%pelist(0:npes-1) )
    allocate( pset%root_pelist(0:npes/npset-1) )
    pset%commID = my_commID
    pset%pelist = my_pelist
!create the root PElist
    pset%root_pelist = root_pelist
    allocate( pset%pset(0:npset-1) )
    do i = 0,npes/npset-1
       k = npset*i
!designate the root PE, next PE, prev PE
       do j = 0,npset-1
          if( pe.EQ.pset%pelist(k+j) )then
              pset%pset(:) =  pset%pelist(k:k+npset-1)
              pset%pos = j
              pset%root_in_pset = pset%root_pelist(i)
              if( j.EQ.0 )then
                  pset%prev_in_pset = pset%pelist(k+npset-1)
              else
                  pset%prev_in_pset = pset%pelist(k+j-1)
              end if
              if( j.EQ.npset-1 )then
                  pset%next_in_pset = pset%pelist(k)
              else
                  pset%next_in_pset = pset%pelist(k+j+1)
              end if
          end if
       end do
    end do

    pset%root = pe.EQ.pset%root_in_pset

!stack
    pset%hiWM = 0 !initialize hi-water-mark
    pset%maxstack = 1000000 !default
    if( PRESENT(stacksize) )pset%maxstack = stacksize
    write( out_unit,'(a,i8)' ) &
         'MPP_PSET_CREATE: setting stacksize=', pset%maxstack
    if( pset%root )then
        allocate( pset%stack(pset%maxstack) )
#ifdef use_CRI_pointers
        pset%p_stack = LOC(pset%stack)
#endif
    end if
    pset%initialized = .TRUE. !must be called before using pset
    call mpp_pset_broadcast_ptr(pset,pset%p_stack)
    endif

    call mpp_declare_pelist(root_pelist)

    if( verbose )then
        write( stderr(),'(a,4i6)' )'MPP_PSET_CREATE: pe, root, next, prev=', &
             pe, pset%root_in_pset, pset%next_in_pset, pset%prev_in_pset
        write( stderr(),* )'PE ', pe, ' pset=', pset%pset(:)
        write( out_unit,* )'root pelist=', pset%root_pelist(:)
    end if
  end subroutine mpp_pset_create

  subroutine mpp_pset_delete(pset)
    type(mpp_pset_type), intent(inout) :: pset
    integer :: out_unit

    out_unit = stdout()
    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_DELETE: called with uninitialized PSET.' )
!deallocate arrays...
    deallocate( pset%pelist )
    deallocate( pset%root_pelist )
    deallocate( pset%pset )
    if( pset%root )deallocate( pset%stack )
    write( out_unit, '(a,i10)' ) &
         'Deleting PSETs... stack high-water-mark=', pset%hiWM
!... and set status flag
    pset%initialized = .FALSE.
  end subroutine mpp_pset_delete

  subroutine mpp_send_ptr_scalar( ptr, pe )
    integer(POINTER_KIND), intent(in) :: ptr
    integer, intent(in) :: pe

!currently only wraps mpp_send
!on some architectures, mangling might occur
    call mpp_send( ptr, pe )
  end subroutine mpp_send_ptr_scalar

  subroutine mpp_send_ptr_array( ptr, pe )
    integer(POINTER_KIND), intent(in) :: ptr(:)
    integer, intent(in) :: pe

!currently only wraps mpp_send
!on some architectures, mangling might occur
    call mpp_send( ptr, size(ptr), pe )
  end subroutine mpp_send_ptr_array

  subroutine mpp_recv_ptr_scalar( ptr, pe )
    integer(POINTER_KIND), intent(inout) :: ptr
    integer, intent(in) :: pe

    call mpp_recv( ptr, pe )
    call mpp_translate_remote_ptr( ptr, pe )
    return
  end subroutine mpp_recv_ptr_scalar

  subroutine mpp_recv_ptr_array( ptr, pe )
    integer(POINTER_KIND), intent(inout) :: ptr(:)
    integer, intent(in) :: pe
    integer :: i

    call mpp_recv( ptr, size(ptr), pe )
    do i = 1, size(ptr)
       call mpp_translate_remote_ptr( ptr(i), pe )
    end do
    return
  end subroutine mpp_recv_ptr_array

  subroutine mpp_translate_remote_ptr( ptr, pe )
!modifies the received pointer to correct numerical address
    integer(POINTER_KIND), intent(inout) :: ptr
    integer, intent(in) :: pe
#ifdef use_SGI_GSM
!from the MPI_SGI_GLOBALPTR manpage
!            POINTER(global_ptr, global_addr)
!            INTEGER rem_rank, comm, ierror
!            INTEGER(KIND=MPI_ADDRESS_KIND) rem_addr, size, global_addr
!
!            CALL MPI_SGI_GLOBALPTR(rem_addr, size, rem_rank, comm, global_ptr, ierror)
    real :: dummy
    pointer( p, dummy )
    integer :: ierror
!length goes in the second argument to MPI_SGI_GLOBALPTR
!    according to Kim Mcmahon, this is only used to ensure the requested array
!    length is within the valid memory-mapped region. We do not have access to
!    the actual array length, so we are only going to set it to 1. This might
!    unexpectedly fail on some large model.
    integer(POINTER_KIND) :: length=1
#ifdef sgi_mipspro
    return !no translation needed on sgi_mipspro if SMA_GLOBAL_ALLOC is set
#endif
#ifdef use_libMPI
!the MPI communicator was stored in pset%commID
!since this routine doesn't take a pset argument, we let the caller store
!it in the module global variable commID (see broadcast_ptr and check_ptr)
    p = ptr
    call MPI_SGI_GLOBALPTR( dummy, length, pe, commID, ptr, ierror )
    if( ierror.EQ.-1 )call mpp_error( FATAL, &
         'MPP_TRANSLATE_REMOTE_PTR: unknown MPI_SGI_GLOBALPTR error.' )
#else
    call mpp_error( FATAL, &
         'MPP_TRANSLATE_REMOTE_PTR now only works under -Duse_libMPI' )
#endif
#endif
    return
  end subroutine mpp_translate_remote_ptr

  subroutine mpp_pset_sync(pset)
!this is a replacement for mpp_sync, doing syncs across
!shared arrays without calling mpp_sync
    type(mpp_pset_type), intent(in) :: pset

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_SYNC: called with uninitialized PSET.' )
#ifdef use_SGI_GSM
!assumes npset contiguous PEs starting with root_in_pset
    call SHMEM_BARRIER( pset%root_in_pset, 0, pset%npset, pSync )
#else
!currently does mpp_sync!!! slow!!!
!try and make a lightweight pset sync
    call mpp_sync
#endif
  end subroutine mpp_pset_sync

  subroutine mpp_pset_broadcast(pset,a)
!broadcast value on the root to its sub-threads
    type(mpp_pset_type), intent(in) :: pset
    real, intent(inout) :: a
    integer :: i

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_BROADCAST: called with uninitialized PSET.' )
    if( pset%root )then
        do i = 1,pset%npset-1
           call mpp_send( a, pset%pset(i) )
        end do
    else
        call mpp_recv( a, pset%root_in_pset )
    end if
    call mpp_pset_sync(pset)
  end subroutine mpp_pset_broadcast

  subroutine mpp_pset_broadcast_ptr_scalar(pset,ptr)
!create a shared array by broadcasting pointer
!root allocates memory and passes pointer in
!on return all other PSETs will have the pointer to a shared object
    type(mpp_pset_type), intent(in) :: pset
    integer(POINTER_KIND), intent(inout) :: ptr
    integer :: i

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_BROADCAST_PTR: called with uninitialized PSET.' )
    commID = pset%commID !pass to mpp_translate_remote_ptr
    if( pset%root )then
        do i = 1,pset%npset-1
           call mpp_send_ptr( ptr, pset%pset(i) )
        end do
    else
        call mpp_recv_ptr( ptr, pset%root_in_pset )
    end if
  end subroutine mpp_pset_broadcast_ptr_scalar

  subroutine mpp_pset_broadcast_ptr_array(pset,ptr)
!create a shared array by broadcasting pointer
!root allocates memory and passes pointer in
!on return all other PSETs will have the pointer to a shared object
    type(mpp_pset_type), intent(in) :: pset
    integer(POINTER_KIND), intent(inout) :: ptr(:)
    integer :: i

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_BROADCAST_PTR: called with uninitialized PSET.' )
    commID = pset%commID !pass to mpp_translate_remote_ptr
    if( pset%root )then
        do i = 1,pset%npset-1
           call mpp_send_ptr( ptr, pset%pset(i) )
        end do
    else
        call mpp_recv_ptr( ptr, pset%root_in_pset )
    end if
  end subroutine mpp_pset_broadcast_ptr_array

  subroutine mpp_pset_check_ptr(pset,ptr)
!checks if the supplied pointer is indeed shared
    type(mpp_pset_type), intent(in) :: pset
#ifdef use_CRI_pointers
    real :: dummy
    pointer( ptr, dummy )
#else
    integer(POINTER_KIND), intent(in) :: ptr
#endif
#ifdef PSET_DEBUG
    integer(POINTER_KIND) :: p
    integer :: i
    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_CHECK_PTR: called with uninitialized PSET.' )
    commID = pset%commID !pass to mpp_translate_remote_ptr
!check if this is a shared pointer
    p = ptr
    if( pset%root )then
        do i = 1,pset%npset-1
           call mpp_send_ptr( p, pset%pset(i) )
        end do
    else
        call mpp_recv_ptr( p, pset%root_in_pset )
    end if
    call mpp_pset_sync(pset)
    if( p.NE.ptr )call mpp_error( FATAL, &
         'MPP_PSET_CHECK_PTR: pointers do not match!' )
#else
!do nothing if the debug CPP flag isn't on
#endif
  end subroutine mpp_pset_check_ptr

  subroutine mpp_pset_segment_array( pset, ls, le, lsp, lep )
!given input indices ls, le, returns indices lsp, lep
!so that segments span the range ls:le with no overlaps.
!attempts load balance: also some PSETs might get lsp>lep
!so that do-loops will be null
    type(mpp_pset_type), intent(in) :: pset
    integer, intent(in) :: ls, le
    integer, intent(out) :: lsp, lep
    integer :: i

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_SEGMENT_ARRAY: called with uninitialized PSET.' )
#ifdef PSET_DEBUG
    if( le-ls+1.LT.pset%npset )then
        write( text,'(3(a,i6))' ) &
             'MPP_PSET_ARRAY_SEGMENT: parallel range (', ls, ',', le, &
             ') is smaller than the number of threads:', pset%npset
        call mpp_error( WARNING, text )
    end if
#endif
    lep = ls-1 !initialize so that lsp is correct on first pass
    do i = 0,pset%pos
       lsp = lep + 1
       lep = lsp + CEILING( REAL(le-lsp+1)/(pset%npset-i) ) - 1
    end do
  end subroutine mpp_pset_segment_array

  subroutine mpp_pset_stack_push( pset, ptr, len )
!mpp_malloc specialized for shared arrays
!len is the length of the required array
!lstack is the stack already in play
!user should zero lstack (call mpp_pset_stack_reset) when the stack is to be cleared
    type(mpp_pset_type), intent(inout) :: pset
    integer, intent(in) :: len
#ifdef use_CRI_pointers
    real :: dummy
    pointer( ptr, dummy )
    real :: stack(pset%maxstack)
    pointer( p, stack )

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_STACK_PUSH: called with uninitialized PSET.' )
    if( pset%lstack+len.GT.pset%maxstack )then
        write( text, '(a,3i12)' ) &
             'MPP_PSET_STACK_PUSH: mpp_pset_stack overflow: '// &
             'len+lstack.GT.maxstack.  len, lstack, maxstack=', &
             len, pset%lstack, pset%maxstack
        call mpp_error( FATAL, text )
    end if
    p = pset%p_stack !point stack to shared stack pointer
    ptr = LOC( stack(pset%lstack+1) )
    call mpp_pset_check_ptr(pset,ptr) !make sure ptr is the same across PSETs
    pset%lstack = pset%lstack + len
    pset%hiWM = max( pset%hiWM, pset%lstack )
#else
    integer(POINTER_KIND), intent(out) :: ptr
    call mpp_error( FATAL, &
         'MPP_PSET_STACK_PUSH only works with Cray pointers.' )
#endif
  end subroutine mpp_pset_stack_push

  subroutine mpp_pset_stack_reset(pset)
    type(mpp_pset_type), intent(inout) :: pset
!reset stack... will reuse any temporary arrays! USE WITH CARE
!next few lines are to zero stack contents...
!but it's better noone tries to use uninitialized stack variables!
!    integer :: l1, l2
!    real :: mpp_pset_stack(maxstack)
!    pointer( p_mpp_pset_stack, mpp_pset_stack )
!    p_mpp_pset_stack = ptr_mpp_pset_stack
!    call mpp_pset_array_segment( 1, lstack, l1, l2 )
!    mpp_pset_stack(l1:l2) = 0.
    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_STACK_RESET: called with uninitialized PSET.' )
    pset%lstack = 0
  end subroutine mpp_pset_stack_reset

  subroutine mpp_pset_print_chksum_1D(pset, caller, array)
!print a checksum of an array
!pass the whole domain seen by root PSET
!add lines to check on shared array?
    type(mpp_pset_type), intent(in) :: pset
    character(len=*), intent(in) :: caller
    real, intent(in) :: array(:)

#ifdef PSET_DEBUG
    logical :: do_print
    integer(LONG_KIND) :: chksum

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_PRINT_CHKSUM: called with uninitialized PSET.' )

    if( pset%root )then
        do_print = pe.EQ.mpp_root_pe() !set to T to print from all PEs
        call mpp_set_current_pelist(pset%root_pelist)
        chksum = mpp_chksum( array )
        if( do_print ) &
             write( stderr(), '(a,z18)' )trim(caller)//' chksum=', chksum
    end if
    call mpp_set_current_pelist(pset%pelist)
#endif
    return
  end subroutine mpp_pset_print_chksum_1D

  subroutine mpp_pset_print_chksum_2D(pset, caller, array)
    type(mpp_pset_type), intent(in) :: pset
    character(len=*), intent(in) :: caller
    real, intent(in) :: array(:,:)
    real :: array1D( size(array) )
#ifdef use_CRI_pointers
    pointer( p, array1D )
    p = LOC(array)
#else
    array1D = TRANSFER( array, array1D )
#endif
    call mpp_pset_print_chksum(pset, caller, array1D)
  end subroutine mpp_pset_print_chksum_2D

  subroutine mpp_pset_print_chksum_3D(pset, caller, array)
    type(mpp_pset_type), intent(in) :: pset
    character(len=*), intent(in) :: caller
    real, intent(in) :: array(:,:,:) !overload for other ranks
    real :: array1D( size(array) )
#ifdef use_CRI_pointers
    pointer( p, array1D )
    p = LOC(array)
#else
    array1D = TRANSFER( array, array1D )
#endif
    call mpp_pset_print_chksum(pset, caller, array1D)
  end subroutine mpp_pset_print_chksum_3D

  subroutine mpp_pset_print_chksum_4D(pset, caller, array)
    type(mpp_pset_type), intent(in) :: pset
    character(len=*), intent(in) :: caller
    real, intent(in) :: array(:,:,:,:)
    real :: array1D( size(array) )
#ifdef use_CRI_pointers
    pointer( p, array1D )
    p = LOC(array)
#else
    array1D = TRANSFER( array, array1D )
#endif
    call mpp_pset_print_chksum(pset, caller, array1D)
  end subroutine mpp_pset_print_chksum_4D

  subroutine mpp_pset_print_stack_chksum( pset, caller )
    type(mpp_pset_type), intent(in) :: pset
    character(len=*), intent(in) :: caller

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_PRINT_STACK_CHKSUM: called with uninitialized PSET.' )
    call mpp_pset_print_chksum( pset, trim(caller)//' stack', &
         pset%stack(1:pset%lstack) )
  end subroutine mpp_pset_print_stack_chksum

!accessor functions
  function mpp_pset_root(pset)
    logical :: mpp_pset_root
    type(mpp_pset_type), intent(in) :: pset

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_ROOT: called with uninitialized PSET.' )
    mpp_pset_root = pset%root
  end function mpp_pset_root
  
  function mpp_pset_numroots(pset)
!necessary to export root_pelist: caller needs to pre-allocate
    integer :: mpp_pset_numroots
    type(mpp_pset_type), intent(in) :: pset

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_NUMROOTS: called with uninitialized PSET.' )
    mpp_pset_numroots = size(pset%root_pelist)
  end function mpp_pset_numroots

  subroutine mpp_pset_get_root_pelist(pset,pelist,commID)
    type(mpp_pset_type), intent(in) :: pset
    integer, intent(out) :: pelist(:)
    integer, intent(out), optional :: commID

    if( .NOT.pset%initialized )call mpp_error( FATAL, &
         'MPP_PSET_GET_ROOT_PELIST: called with uninitialized PSET.' )
    if( size(pelist).NE.size(pset%root_pelist) )then
        write( text,'(a,2i6)' ) &
             'pelist argument has wrong size: requested, actual=', &
             size(pelist), size(pset%root_pelist)
        call mpp_error( FATAL, 'MPP_PSET_GET_ROOT_PELIST: '//text )
    end if
    pelist(:) = pset%root_pelist(:)
    if( PRESENT(commID) )then
#ifdef use_libMPI
        commID = pset%commID
#else
        call mpp_error( WARNING, &
             'MPP_PSET_GET_ROOT_PELIST: commID is only defined under -Duse_libMPI.' )
#endif
    end if
  end subroutine mpp_pset_get_root_pelist
  
end module mpp_pset_mod



module mpp_utilities_mod

!-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: mpp_utilities.F90,v 17.0 2009/07/21 03:21:23 fms Exp $'
  character(len=128) :: tag = '$Name: hiram_20101115_bw $'
!-----------------------------------------------------------------------

  public :: mpp_array_global_min_max

contains

!#######################################################################
! <SUBROUTINE NAME="mpp_array_global_min_max">
!
! <DESCRIPTION>
! Compute and return the global min and max of an array
! and the corresponding lat-lon-depth locations .   
!
! NOTES:
! This algorithm works only for an input array that has a unique global 
! max and min location. This is assured by introducing a factor that distinguishes
! the values of extrema at each processor.
!
! Vectorized using maxloc() and minloc() intrinsic functions by 
! Russell.Fiedler@csiro.au (May 2005).
!
! Modified by Zhi.Liang@noaa.gov (July 2005)
!          
! Modified by Niki.Zadeh@noaa.gov (Feb. 2009)
!
! </DESCRIPTION>
!
subroutine mpp_array_global_min_max(in_array, tmask,isd,jsd,isc,iec,jsc,jec,nk, g_min, g_max, &
                                    geo_x,geo_y,geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax)

  use mpp_mod,           only: mpp_min, mpp_max, mpp_pe, mpp_sum

  real, dimension(isd:,jsd:,:), intent(in) :: in_array
  real, dimension(isd:,jsd:,:), intent(in) :: tmask
  integer,                      intent(in) :: isd,jsd,isc,iec,jsc,jec,nk
  real,                         intent(out):: g_min, g_max
  real, dimension(isd:,jsd:),   intent(in) :: geo_x,geo_y
  real, dimension(:),           intent(in) :: geo_z
  real,                         intent(out):: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax 



  real    :: tmax, tmin, tmax0, tmin0
  integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin
  integer :: igmax, jgmax, kgmax, igmin, jgmin, kgmin
  real    :: fudge

  ! arrays to enable vectorization
  integer :: iminarr(3),imaxarr(3)

  g_min=-88888888888.0 ; g_max=-999999999.0

  tmax=-1.e10;tmin=1.e10
  itmax=0;jtmax=0;ktmax=0
  itmin=0;jtmin=0;ktmin=0
  
  if(ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then
     iminarr=minloc(in_array(isc:iec,jsc:jec,:),tmask(isc:iec,jsc:jec,:) > 0.)
     imaxarr=maxloc(in_array(isc:iec,jsc:jec,:),tmask(isc:iec,jsc:jec,:) > 0.)
     itmin=iminarr(1)+isc-1
     jtmin=iminarr(2)+jsc-1
     ktmin=iminarr(3)
     itmax=imaxarr(1)+isc-1
     jtmax=imaxarr(2)+jsc-1 
     ktmax=imaxarr(3)
     tmin=in_array(itmin,jtmin,ktmin)
     tmax=in_array(itmax,jtmax,ktmax)
  end if

  ! use "fudge" to distinguish processors when tracer extreme is independent of processor
  fudge = 1.0 + 1.e-12*mpp_pe() 
  tmax = tmax*fudge
  tmin = tmin*fudge
  if(tmax == 0.0) then 
    tmax = tmax + 1.e-12*mpp_pe() 
  endif 
  if(tmin == 0.0) then 
    tmin = tmin + 1.e-12*mpp_pe() 
  endif 
  

  tmax0=tmax;tmin0=tmin

  call mpp_max(tmax)
  call mpp_min(tmin)

  g_max = tmax
  g_min = tmin

  !Now find the location of the global extrema.
  !
  !Note that the fudge factor above guarantees that the location of max (min) is uinque,
  ! since tmax0 (tmin0) has slightly different values on each processor.
  !Otherwise, the function in_array(i,j,k) could be equal to global max (min) at more 
  ! than one point in space and this would be a much more difficult problem to solve.
  !
  !mpp_max trick
  !-999 on all current PE's
  xgmax=-999; ygmax=-999; zgmax=-999
  xgmin=-999; ygmin=-999; zgmin=-999


  !except when
  if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above.
     xgmax=geo_x(itmax,jtmax) 
     ygmax=geo_y(itmax,jtmax) 
     zgmax=geo_z(ktmax)    
  endif

  call mpp_max(xgmax) 
  call mpp_max(ygmax) 
  call mpp_max(zgmax)     
  
  if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above.
     xgmin=geo_x(itmin,jtmin) 
     ygmin=geo_y(itmin,jtmin) 
     zgmin=geo_z(ktmin)    
  endif

  call mpp_max(xgmin) 
  call mpp_max(ygmin) 
  call mpp_max(zgmin)     
  
  return


end subroutine mpp_array_global_min_max
! </SUBROUTINE>  NAME="mpp_array_global_min_max"



end module mpp_utilities_mod


#ifdef test_mpp
#ifdef SYSTEM_CLOCK
#undef SYSTEM_CLOCK
#endif

program test   !test various aspects of mpp_mod
#include <fms_platform.h>

#ifdef sgi_mipspro
  use shmem_interface
#endif

  use mpp_mod, only : mpp_init, mpp_exit, mpp_pe, mpp_npes, mpp_root_pe, stdout
  use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sync, mpp_malloc
  use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size
  use mpp_mod, only : mpp_broadcast, mpp_transmit, mpp_sum, mpp_max, mpp_chksum, ALL_PES
  use mpp_mod, only : mpp_error, FATAL
#ifdef use_MPI_GSM
  use mpp_mod, only : mpp_gsm_malloc, mpp_gsm_free
#endif

  implicit none

  integer, parameter              :: n=1048576
  real, allocatable, dimension(:) :: a, b, c
#ifdef use_MPI_GSM
  real                            :: d(n)
  pointer (locd, d)
#else
  real, allocatable, dimension(:) :: d
  integer(LONG_KIND) :: locd
#endif
  integer                         :: tick, tick0, ticks_per_sec, id
  integer                         :: pe, npes, root, i, j, k, l, m, n2, istat
  real                            :: dt

  call mpp_init()
  call mpp_set_stack_size(3145746)
  pe = mpp_pe()
  npes = mpp_npes()
  root = mpp_root_pe()

  ! first test broadcast
  call test_broadcast()

  call SYSTEM_CLOCK( count_rate=ticks_per_sec )
  allocate( a(n), b(n) )
  id = mpp_clock_id( 'Random number' )
  call mpp_clock_begin(id)
  call random_number(a)
  call mpp_clock_end  (id)
  !---------------------------------------------------------------------!
  !   time transmit, compare against shmem_put and get                  !
  !---------------------------------------------------------------------!
  if( pe.EQ.root )then
     print *, 'Time mpp_transmit for various lengths...'
#ifdef SGICRAY
     print *, 'For comparison, times for shmem_get and shmem_put are also provided.'
#endif
     print *
  end if
  id = mpp_clock_id( 'mpp_transmit' )
  call mpp_clock_begin(id)
  !timing is done for cyclical pass (more useful than ping-pong etc)
  l = n
  do while( l.GT.0 )
     !--- mpp_transmit -------------------------------------------------
     call mpp_sync()
     call SYSTEM_CLOCK(tick0)
     do i = 1,npes
        call mpp_transmit( put_data=a(1), plen=l, to_pe=modulo(pe+npes-i,npes), &
                           get_data=b(1), glen=l, from_pe=modulo(pe+i,npes) )
        !          call mpp_sync_self( (/modulo(pe+npes-i,npes)/) )
     end do
     call mpp_sync()
     call SYSTEM_CLOCK(tick)
     dt = real(tick-tick0)/(npes*ticks_per_sec)
     dt = max( dt, epsilon(dt) )
     if( pe.EQ.root )write( stdout(),'(/a,i8,f13.6,f8.2)' )'MPP_TRANSMIT length, time, bw(Mb/s)=', l, dt, l*8e-6/dt
!#ifdef SGICRAY
!     !--- shmem_put ----------------------------------------------------
!     call mpp_sync()
!     call SYSTEM_CLOCK(tick0)
!     do i = 1,npes
!       call shmem_real_put( b, a, l, modulo(pe+1,npes) )
!     end do
!     call mpp_sync()
!     call SYSTEM_CLOCK(tick)
!     dt = real(tick-tick0)/(npes*ticks_per_sec)
!     dt = max( dt, epsilon(dt) )
!     if( pe.EQ.root )write( stdout(),'( a,i8,f13.6,f8.2)' )'SHMEM_PUT    length, time, bw(Mb/s)=', l, dt, l*8e-6/dt
!     !--- shmem_get ----------------------------------------------------
!     call mpp_sync()
!     call SYSTEM_CLOCK(tick0)
!     do i = 1,npes
!        call shmem_real_get( b, a, l, modulo(pe+1,npes) )
!     end do
!     call SYSTEM_CLOCK(tick)
!     dt = real(tick-tick0)/(npes*ticks_per_sec)
!     dt = max( dt, epsilon(dt) )
!     if( pe.EQ.root )write( stdout(),'( a,i8,f13.6,f8.2)' )'SHMEM_GET    length, time, bw(Mb/s)=', l, dt, l*8e-6/dt
!#endif
     l = l/2
  end do
  !---------------------------------------------------------------------!
  !                   test mpp_sum                                      !
  !---------------------------------------------------------------------!
  if( pe.EQ.root )then
     print '(/a)', 'Time mpp_sum...'
  end if
  a = real(pe+1)
  call mpp_sync()
  call SYSTEM_CLOCK(tick0)
  call mpp_sum(a(1:1000),1000)
  call SYSTEM_CLOCK(tick)
  dt = real(tick-tick0)/ticks_per_sec
  dt = max( dt, epsilon(dt) )
  if( pe.EQ.root )write( stdout(),'(a,2i6,f9.1,i8,f13.6,f8.2/)' ) &
       'mpp_sum: pe, npes, sum(pe+1), length, time, bw(Mb/s)=', pe, npes, a(1), n, dt, n*8e-6/dt
  call mpp_clock_end(id)
  !---------------------------------------------------------------------!
  !                   test mpp_max                                      !
  !---------------------------------------------------------------------!
  if( pe.EQ.root )then
     print *
     print *, 'Test mpp_max...'
  end if
  a = real(pe+1)
  print *, 'pe,     pe+1 =', pe, a(1)
  call mpp_max( a(1) )
  print *, 'pe, max(pe+1)=', pe, a(1)
  !pelist check
  call mpp_sync()
  call flush(stdout(),istat)
  if( npes.GE.2 )then
     if( pe.EQ.root )print *, 'Test of pelists: bcast, sum and max using PEs 0...npes-2 (excluding last PE)'
     call mpp_declare_pelist( (/(i,i=0,npes-2)/) )
     a = real(pe+1)
     if( pe.NE.npes-1 )call mpp_broadcast( a, n, npes-2, (/(i,i=0,npes-2)/) )
     print *, 'bcast(npes-1) from 0 to npes-2=', pe, a(1)
     a = real(pe+1)
     if( pe.NE.npes-1 )then
        call mpp_set_current_pelist( (/(i,i=0,npes-2)/) )
        id = mpp_clock_id( 'Partial mpp_sum' )
        call mpp_clock_begin(id)
        call mpp_sum( a(1:1000), 1000, (/(i,i=0,npes-2)/) )
        call mpp_clock_end  (id)
     end if
     if( pe.EQ.root )print *, 'sum(pe+1) from 0 to npes-2=', a(1)
     a = real(pe+1)
     if( pe.NE.npes-1 )call mpp_max( a(1), (/(i,i=0,npes-2)/) )
     if( pe.EQ.root )print *, 'max(pe+1) from 0 to npes-2=', a(1)
  end if
  call mpp_set_current_pelist()
  
#ifdef use_CRI_pointers
  !---------------------------------------------------------------------!
  !                   test mpp_chksum                                   !
  !---------------------------------------------------------------------!
  if( modulo(n,npes).EQ.0 )then  !only set up for even division
     n2 = 1024
     a = 0.d0
     if( pe.EQ.root )call random_number(a(1:n2))
!    if( pe.EQ.root )call random_number(a)
     call mpp_sync()
     call mpp_transmit( put_data=a(1), plen=n2, to_pe=ALL_PES, &
                        get_data=a(1), glen=n2, from_pe=root )
!    call mpp_transmit( put_data=a(1), plen=n, to_pe=ALL_PES, &
!                       get_data=a(1), glen=n, from_pe=root )
     m= n2/npes
!    m= n/npes
     allocate( c(m) )
     c = a(pe*m+1:pe*m+m)
     
     if( pe.EQ.root )then
        print *
        print *, 'Test mpp_chksum...'
        print *, 'This test shows that a whole array and a distributed array give identical checksums.'
     end if
     print *, 'chksum(a(1:1024))=', mpp_chksum(a(1:n2),(/pe/))
     print *, 'chksum(c(1:1024))=', mpp_chksum(c)
!    print *, 'chksum(a)=', mpp_chksum(a,(/pe/))
!    print *, 'chksum(c)=', mpp_chksum(c)
  end if
!test of pointer sharing
#ifdef use_MPI_GSM
      call mpp_gsm_malloc( locd, sizeof(d) )
#else
  if( pe.EQ.root )then
      allocate( d(n) )
      locd = LOC(d)
  end if
  call mpp_broadcast(locd,root)
#endif
  if( pe.EQ.root )then
      call random_number(d)
  end if
  call mpp_sync()
!  call test_shared_pointers(locd,n)

#ifdef use_MPI_GSM
  call mpp_gsm_free( locd )
#else
  if( pe.EQ.root )then
      deallocate( d )
  end if
#endif
#endif
  call mpp_exit()

contains

  !***********************************************
  !currently only test the mpp_broadcast_char
  subroutine test_broadcast()
     integer, parameter :: ARRAYSIZE = 3
     integer, parameter :: STRINGSIZE = 256
     character(len=STRINGSIZE), dimension(ARRAYSIZE) :: textA, textB
     integer :: n

     textA(1) = "This is line 1 "
     textA(2) = "Here comes the line 2 "
     textA(3) = "Finally is line 3 "  
     do n = 1, ARRAYSIZE  
        textB(n) = TextA(n)
     enddo

     if(mpp_pe() .NE. mpp_root_pe()) then
        do n =1, ARRAYSIZE
           textA(n) = ""
        enddo
     endif

     !--- comparing textA and textB. textA and textB are supposed to be different on pe other than root_pe
     if(mpp_pe() == mpp_root_pe()) then
        do n = 1, ARRAYSIZE         
           if(textA(n) .NE. textB(n)) call mpp_error(FATAL, "test_broadcast: on root_pe, textA should equal textB")
        enddo
     else
        do n = 1, ARRAYSIZE         
           if(textA(n) == textB(n)) call mpp_error(FATAL, "test_broadcast: on root_pe, textA should not equal textB")
        enddo 
     endif
     call mpp_broadcast(textA, STRINGSIZE, mpp_root_pe())
     !--- after broadcast, textA and textB should be the same
     do n = 1, ARRAYSIZE         
        if(textA(n) .NE. textB(n)) call mpp_error(FATAL, "test_broadcast: after broadcast, textA should equal textB")
     enddo

     write(stdout(),*) "==> NOTE from test_broadcast: The test is succesful"

  end subroutine test_broadcast

  subroutine test_shared_pointers(locd,n)
    integer(LONG_KIND), intent(in) :: locd
    integer :: n
    real :: dd(n)
    pointer( p, dd )

    p = locd
    print *, 'TEST_SHARED_POINTERS: pe, locd=', pe, locd
!    print *, 'TEST_SHARED_POINTERS: pe, chksum(d)=', pe, mpp_chksum(dd,(/pe/))
    print *, 'TEST_SHARED_POINTERS: pe, sum(d)=', pe, sum(dd)
    return
  end subroutine test_shared_pointers
end program test

#else
module null_mpp_test
end module  

#endif /* test_mpp */


#ifdef test_mpp_domains
program test
  use mpp_mod,         only : FATAL, WARNING, MPP_DEBUG, NOTE, MPP_CLOCK_SYNC,MPP_CLOCK_DETAILED
  use mpp_mod,         only : mpp_pe, mpp_npes, mpp_node, mpp_root_pe, mpp_error, mpp_set_warn_level
  use mpp_mod,         only : mpp_declare_pelist, mpp_set_current_pelist, mpp_sync, mpp_sync_self
  use mpp_mod,         only : mpp_clock_begin, mpp_clock_end, mpp_clock_id
  use mpp_mod,         only : mpp_init, mpp_exit, mpp_chksum, stdout, stderr
  use mpp_mod,         only : input_nml_file
  use mpp_domains_mod, only : GLOBAL_DATA_DOMAIN, BITWISE_EXACT_SUM, BGRID_NE, CGRID_NE
  use mpp_domains_mod, only : FOLD_SOUTH_EDGE, FOLD_NORTH_EDGE, FOLD_WEST_EDGE, FOLD_EAST_EDGE
  use mpp_domains_mod, only : MPP_DOMAIN_TIME, CYCLIC_GLOBAL_DOMAIN, NUPDATE,EUPDATE, XUPDATE, YUPDATE, SCALAR_PAIR
  use mpp_domains_mod, only : domain1D, domain2D, DomainCommunicator2D
  use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_domains_set_stack_size
  use mpp_domains_mod, only : mpp_global_field, mpp_global_sum, mpp_global_max, mpp_global_min
  use mpp_domains_mod, only : mpp_domains_init, mpp_domains_exit, mpp_broadcast_domain
  use mpp_domains_mod, only : mpp_update_domains, mpp_check_field, mpp_redistribute, mpp_get_memory_domain
  use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains, mpp_modify_domain
  use mpp_domains_mod, only : mpp_get_neighbor_pe, mpp_define_mosaic, mpp_nullify_domain_list
  use mpp_domains_mod, only : NORTH, NORTH_EAST, EAST, SOUTH_EAST, CORNER, CENTER
  use mpp_domains_mod, only : SOUTH, SOUTH_WEST, WEST, NORTH_WEST, mpp_define_mosaic_pelist
  use mpp_domains_mod, only : mpp_get_refine_overlap_number, mpp_get_mosaic_refine_overlap
  use mpp_domains_mod, only : mpp_get_global_domain, ZERO, NINETY, MINUS_NINETY
  use mpp_domains_mod, only : mpp_get_boundary
  use mpp_memutils_mod, only : mpp_memuse_begin, mpp_memuse_end

  implicit none
#include <fms_platform.h>
  integer :: pe, npes
  integer :: nx=128, ny=128, nz=40, stackmax=4000000
  integer :: unit=7
  integer :: stdunit = 6
  logical :: debug=.FALSE., opened
  logical :: check_parallel = .FALSE.  ! when check_parallel set to false,
                                       ! mpes should be equal to npes     
  integer :: mpes = 0
  integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2
  integer :: x_cyclic_offset = 3   ! to be used in test_cyclic_offset
  integer :: y_cyclic_offset = -4  ! to be used in test_cyclic_offset
  character(len=32) :: warn_level = "fatal"
  integer :: wide_halo_x = 0, wide_halo_y = 0
  integer :: nx_cubic = 0, ny_cubic = 0
  namelist / test_mpp_domains_nml / nx, ny, nz, stackmax, debug, mpes, check_parallel, &
                               whalo, ehalo, shalo, nhalo, x_cyclic_offset, y_cyclic_offset, &
                               warn_level, wide_halo_x, wide_halo_y, nx_cubic, ny_cubic
  integer :: i, j, k
  integer :: layout(2)
  integer :: id

  call mpp_memuse_begin()
  call mpp_init()
 
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, test_mpp_domains_nml) 
#else
  do
     inquire( unit=unit, opened=opened )
     if( .NOT.opened )exit
     unit = unit + 1
     if( unit.EQ.100 )call mpp_error( FATAL, 'Unable to locate unit number.' )
  end do
  open( unit=unit, status='OLD', file='input.nml', err=10 )
  read( unit,test_mpp_domains_nml )
  close(unit)
10 continue
#endif

  select case(trim(warn_level))
  case("fatal")
     call mpp_set_warn_level(FATAL)
  case("warning")
     call mpp_set_warn_level(WARNING)
  case default
     call mpp_error(FATAL, "test_mpp_domains: warn_level should be fatal or warning")
  end select
  
  pe = mpp_pe()
  npes = mpp_npes()
  
  if( debug )then
      call mpp_domains_init(MPP_DEBUG)
  else
      call mpp_domains_init(MPP_DOMAIN_TIME)
  end if
  call mpp_domains_set_stack_size(stackmax)
  
  if( pe.EQ.mpp_root_pe() )print '(a,9i6)', 'npes, mpes, nx, ny, nz, whalo, ehalo, shalo, nhalo =', &
                           npes, mpes, nx, ny, nz, whalo, ehalo, shalo, nhalo
  call mpp_memuse_end("in the begining", stdout())  

  !--- wide_halo_x and wide_halo_y must be either both 0 or both positive.
  if( wide_halo_x < 0 .OR. wide_halo_y < 0) call mpp_error(FATAL, &
     "test_mpp_domain: both wide_halo_x and wide_halo_y should be non-negative")
  if( wide_halo_x == 0 .NEQV. wide_halo_y == 0) call mpp_error(FATAL, &
     "test_mpp_domain: wide_halo_x and wide_halo_y should be both zero or both positive")

  !--- nx_cubic and ny_cubic must be either both 0 or both positive.
  if( nx_cubic < 0 .OR. ny_cubic < 0) call mpp_error(FATAL, &
     "test_mpp_domain: both nx_cubic and ny_cubic should be non-negative")
  if( nx_cubic == 0 .NEQV. ny_cubic == 0) call mpp_error(FATAL, &
     "test_mpp_domain: nx_cubic and ny_cubic should be both zero or both positive")

  if( .not. check_parallel) then
      call test_modify_domain()
!!$      call test_cyclic_offset('x_cyclic_offset')
!!$      call test_cyclic_offset('y_cyclic_offset')
!!$      call test_cyclic_offset('torus_x_offset')
!!$      call test_cyclic_offset('torus_y_offset')

      call test_get_boundary('Four-Tile')
      call test_get_boundary('Cubic-Grid')
      call test_uniform_mosaic('Single-Tile')
      call test_uniform_mosaic('Folded-north mosaic') ! one-tile tripolar grid
      call test_uniform_mosaic('Folded-north symmetry mosaic') ! one-tile tripolar grid
      call test_uniform_mosaic('Folded-south symmetry mosaic') ! one-tile tripolar grid
      call test_uniform_mosaic('Folded-west symmetry mosaic') ! one-tile tripolar grid
      call test_uniform_mosaic('Folded-east symmetry mosaic') ! one-tile tripolar grid
      call test_uniform_mosaic('Four-Tile')
      call test_uniform_mosaic('Cubic-Grid') ! 6 tiles.
      call test_nonuniform_mosaic('Five-Tile')
      call test_refined_mosaic('Refined-Four-Tile')
      call test_refined_mosaic('Refined-Symmetric-Four-Tile')
      call test_refined_mosaic('Refined-Cubic-Grid')

      call test_halo_update( 'Simple' ) !includes global field, global sum tests
      call test_halo_update( 'Cyclic' )
      call test_halo_update( 'Folded-north' ) !includes vector field test
      call test_halo_update( 'Masked' ) !includes vector field test
      call test_halo_update( 'Folded xy_halo' ) ! 

      call test_halo_update( 'Simple symmetry' ) !includes global field, global sum tests
      call test_halo_update( 'Cyclic symmetry' )
      call test_halo_update( 'Folded-north symmetry' ) !includes vector field test
      call test_halo_update( 'Folded-south symmetry' ) !includes vector field test
      call test_halo_update( 'Folded-west symmetry' ) !includes vector field test
      call test_halo_update( 'Folded-east symmetry' ) !includes vector field test

      !--- z1l: The following will not work due to symmetry and domain%x is cyclic.
      !--- Will solve this problem in the future if needed.
      ! call test_halo_update( 'Masked symmetry' ) !includes vector field test

      call test_global_field( 'Non-symmetry' )
      call test_global_field( 'Symmetry center' )
      call test_global_field( 'Symmetry corner' )
      call test_global_field( 'Symmetry east' )
      call test_global_field( 'Symmetry north' )

      call test_global_reduce( 'Simple')
      call test_global_reduce( 'Simple symmetry center')
      call test_global_reduce( 'Simple symmetry corner')
      call test_global_reduce( 'Simple symmetry east')
      call test_global_reduce( 'Simple symmetry north')
      call test_global_reduce( 'Cyclic symmetry center')
      call test_global_reduce( 'Cyclic symmetry corner')
      call test_global_reduce( 'Cyclic symmetry east')
      call test_global_reduce( 'Cyclic symmetry north')

      call test_redistribute( 'Complete pelist' )
!      call test_redistribute( 'Overlap  pelist' )
!      call test_redistribute( 'Disjoint pelist' )

      call test_define_mosaic_pelist('One tile', 1)
      call test_define_mosaic_pelist('Two uniform tile', 2)
      call test_define_mosaic_pelist('Two nonuniform tile', 2)
      call test_define_mosaic_pelist('Ten tile', 10)
      call test_define_mosaic_pelist('Ten tile with nonuniform cost', 10)
  else
      call test_parallel( )
  endif

!!$!Balaji adding openMP tests
!!$  call test_openmp()
!!$ 
!!$! Alewxander.Pletzer get_neighbor tests
!!$  call test_get_neighbor_1d
!!$  call test_get_neighbor_non_cyclic
!!$  call test_get_neighbor_cyclic
!!$  call test_get_neighbor_folded_north
!!$  call test_get_neighbor_mask

  call mpp_domains_exit()
  call mpp_exit()
  
contains
  subroutine test_openmp()
#ifdef _OPENMP
    integer :: omp_get_num_thread, omp_get_max_threads, omp_get_thread_num
    real, allocatable :: a(:,:,:)
    type(domain2D) :: domain
    integer :: layout(2)
    integer :: i,j,k, jthr
    integer :: thrnum, maxthr
    integer(LONG_KIND) :: sum1, sum2
    
    call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
    call mpp_define_domains( (/1,nx,1,ny/), layout, domain )
    call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
    allocate( a(isd:ied,jsd:jed,nz) )
    maxthr = omp_get_max_threads()
    write( stdout(),'(a,4i6)' )'pe,js,je,maxthr=', pe, js, je, maxthr
    if( mod(je-js+1,maxthr).NE.0 ) &
         call mpp_error( FATAL, 'maxthr must divide domain (TEMPORARY).' )
    jthr = (je-js+1)/maxthr
!$OMP PARALLEL PRIVATE(i,j,k,thrnum)
    thrnum = omp_get_thread_num()
    write( stdout(),'(a,4i6)' )'pe,thrnum,js,je=', &
         pe, thrnum, js+thrnum*jthr,js+(thrnum+1)*jthr-1
    write( stdout(),'(a,3i6)' )'pe,thrnum,node=', pe, thrnum, mpp_node()
!!$OMP DO
    do k = 1,nz
!when omp DO is commented out, user must compute j loop limits
!with omp DO, let OMP figure it out
       do j = js+thrnum*jthr,js+(thrnum+1)*jthr-1
!       do j = js,je
          do i = is,ie
             a(i,j,k) = global(i,j,k)
          end do
       end do
    end do
!!$OMP END DO
!$OMP END PARALLEL
    sum1 = mpp_chksum( a(is:ie,js:je,:) )
    sum2 = mpp_chksum( global(is:ie,js:je,:) )
    if( sum1.EQ.sum2 )then
        call mpp_error( NOTE, 'OMP parallel test OK.' )
    else
        if( mpp_pe().EQ.mpp_root_pe() )write( stderr(),'(a,2z18)' )'OMP checksums: ', sum1, sum2
        call mpp_error( FATAL, 'OMP parallel test failed.' )
    end if
#endif
    return
  end subroutine test_openmp

  subroutine test_redistribute( type )
!test redistribute between two domains
    character(len=*), intent(in) :: type
    type(domain2D) :: domainx, domainy
    type(DomainCommunicator2D), pointer, save :: dch =>NULL()
    real, allocatable, dimension(:,:,:)       :: gcheck, global
    real, allocatable, dimension(:,:,:), save :: x, y
    real, allocatable, dimension(:,:,:), save :: x2, y2
    real, allocatable, dimension(:,:,:), save :: x3, y3
    real, allocatable, dimension(:,:,:), save :: x4, y4
    real, allocatable, dimension(:,:,:), save :: x5, y5
    real, allocatable, dimension(:,:,:), save :: x6, y6
    integer, allocatable :: pelist(:)
    integer :: pemax
    integer :: is, ie, js, je, isd, ied, jsd, jed
    
    pemax = npes/2              !the partial pelist will run from 0...pemax
    !--- nullify domain list otherwise it retains memory between calls.
    call mpp_nullify_domain_list(domainx)
    call mpp_nullify_domain_list(domainy)

    allocate( gcheck(nx,ny,nz), global(nx,ny,nz) )
    !fill in global array: with k.iiijjj
    do k = 1,nz
       do j = 1,ny
          do i = 1,nx
             global(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
    end do

!select pelists
    select case(type)
    case( 'Complete pelist' )
!both pelists run from 0...npes-1
        if(nx < npes) then
           call mpp_error(NOTE, &
              "test_mpp_domains(test_redistribute): nx is less than npes, no test will be done for complete pelist")
           return
        endif
        allocate( pelist(0:npes-1) )
        pelist = (/ (i,i=0,npes-1) /)
        call mpp_declare_pelist( pelist )
    case( 'Overlap  pelist' )
!one pelist from 0...pemax, other from 0...npes-1
        allocate( pelist(0:pemax) )
        pelist = (/ (i,i=0,pemax) /)
        call mpp_declare_pelist( pelist )
    case( 'Disjoint pelist' )
!one pelist from 0...pemax, other from pemax+1...npes-1
        if( pemax+1.GE.npes )return
        allocate( pelist(0:pemax) )
        pelist = (/ (i,i=0,pemax) /)

        call mpp_declare_pelist( pelist )
        ! z1l: the follwing will cause deadlock will happen
        ! for npes = 6, x- mpp_global_field will call mpp_sync
        call mpp_declare_pelist( (/ (i,i=pemax+1,npes-1) /))
    case default
        call mpp_error( FATAL, 'TEST_REDISTRIBUTE: no such test: '//type )
    end select
        
!set up x and y arrays
    select case(type)
    case( 'Complete pelist' )
!set up x array
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domainx, name=type )
        call mpp_get_compute_domain( domainx, is,  ie,  js,  je  )
        call mpp_get_data_domain   ( domainx, isd, ied, jsd, jed )
        allocate( x(isd:ied,jsd:jed,nz) )
        allocate( x2(isd:ied,jsd:jed,nz) )
        allocate( x3(isd:ied,jsd:jed,nz) )
        allocate( x4(isd:ied,jsd:jed,nz) )
        allocate( x5(isd:ied,jsd:jed,nz) )
        allocate( x6(isd:ied,jsd:jed,nz) )
        x = 0.
        x(is:ie,js:je,:) = global(is:ie,js:je,:)
        x2 = x;  x3 = x; x4 = x; x5 = x; x6 = x
!set up y array
        call mpp_define_domains( (/1,nx,1,ny/), (/npes,1/), domainy, name=type )
        call mpp_get_compute_domain( domainy, is,  ie,  js,  je  )
        call mpp_get_data_domain   ( domainy, isd, ied, jsd, jed )
        allocate( y(isd:ied,jsd:jed,nz) )
        allocate( y2(isd:ied,jsd:jed,nz) )
        allocate( y3(isd:ied,jsd:jed,nz) )
        allocate( y4(isd:ied,jsd:jed,nz) )
        allocate( y5(isd:ied,jsd:jed,nz) )
        allocate( y6(isd:ied,jsd:jed,nz) )
        y = 0.
        y2 = 0.;y3 = 0.;y4 = 0.;y5 = 0.;y6 = 0.
    case( 'Overlap  pelist' )
!one pelist from 0...pemax, other from 0...npes-1
!set up x array
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domainx, name=type )
        call mpp_get_compute_domain( domainx, is,  ie,  js,  je  )
        call mpp_get_data_domain   ( domainx, isd, ied, jsd, jed )
        allocate( x(isd:ied,jsd:jed,nz) )
        allocate( x2(isd:ied,jsd:jed,nz) )
        allocate( x3(isd:ied,jsd:jed,nz) )
        allocate( x4(isd:ied,jsd:jed,nz) )
        allocate( x5(isd:ied,jsd:jed,nz) )
        allocate( x6(isd:ied,jsd:jed,nz) )
        x = 0.
        x(is:ie,js:je,:) = global(is:ie,js:je,:)
        x2 = x;  x3 = x; x4 = x; x5 = x; x6 = x
!set up y array
        if( ANY(pelist.EQ.pe) )then
            call mpp_set_current_pelist(pelist)
            call mpp_define_layout( (/1,nx,1,ny/), mpp_npes(), layout )
            call mpp_define_domains( (/1,nx,1,ny/), layout, domainy, name=type )
            call mpp_get_compute_domain( domainy, is,  ie,  js,  je  )
            call mpp_get_data_domain   ( domainy, isd, ied, jsd, jed )
            allocate( y(isd:ied,jsd:jed,nz) )
            allocate( y2(isd:ied,jsd:jed,nz) )
            allocate( y3(isd:ied,jsd:jed,nz) )
            allocate( y4(isd:ied,jsd:jed,nz) )
            allocate( y5(isd:ied,jsd:jed,nz) )
            allocate( y6(isd:ied,jsd:jed,nz) )
            y = 0.
            y2 = 0.;y3 = 0.;y4 = 0.;y5 = 0.;y6 = 0.
        end if
    case( 'Disjoint pelist' )
!one pelist from 0...pemax, other from pemax+1...npes-1
    
!set up y array
        if( ANY(pelist.EQ.pe) )then
            call mpp_set_current_pelist(pelist)
            call mpp_define_layout( (/1,nx,1,ny/), mpp_npes(), layout )
            call mpp_define_domains( (/1,nx,1,ny/), layout, domainy, name=type )
            call mpp_get_compute_domain( domainy, is,  ie,  js,  je  )
            call mpp_get_data_domain   ( domainy, isd, ied, jsd, jed )
            allocate( y(isd:ied,jsd:jed,nz) )
            allocate( y2(isd:ied,jsd:jed,nz) )
            allocate( y3(isd:ied,jsd:jed,nz) )
            allocate( y4(isd:ied,jsd:jed,nz) )
            allocate( y5(isd:ied,jsd:jed,nz) )
            allocate( y6(isd:ied,jsd:jed,nz) )
            y = 0.
            y2 = 0.;y3 = 0.;y4 = 0.;y5 = 0.;y6 = 0.
        else
!set up x array
            call mpp_set_current_pelist( (/ (i,i=pemax+1,npes-1) /) )
            call mpp_define_layout( (/1,nx,1,ny/), mpp_npes(), layout )
            call mpp_define_domains( (/1,nx,1,ny/), layout, domainx, name=type )
            call mpp_get_compute_domain( domainx, is,  ie,  js,  je  )
            call mpp_get_data_domain   ( domainx, isd, ied, jsd, jed )
            allocate( x(isd:ied,jsd:jed,nz) )
            allocate( x2(isd:ied,jsd:jed,nz) )
            allocate( x3(isd:ied,jsd:jed,nz) )
            allocate( x4(isd:ied,jsd:jed,nz) )
            allocate( x5(isd:ied,jsd:jed,nz) )
            allocate( x6(isd:ied,jsd:jed,nz) )
            x = 0.
            x(is:ie,js:je,:) = global(is:ie,js:je,:)
            x2 = x;  x3 = x; x4 = x; x5 = x; x6 = x
         end if
    end select
         
!go global and redistribute
    call mpp_set_current_pelist()
    call mpp_broadcast_domain(domainx)
    call mpp_broadcast_domain(domainy)
    
    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_redistribute( domainx, x, domainy, y )
    call mpp_clock_end  (id)
    
!check answers on pelist
    if( ANY(pelist.EQ.pe) )then
        call mpp_set_current_pelist(pelist)
        call mpp_global_field( domainy, y, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
    end if
        
    call mpp_set_current_pelist()

    call mpp_clock_begin(id)
    if(ALLOCATED(y))y=0.
    call mpp_redistribute( domainx, x,  domainy, y,  complete=.false. )
    call mpp_redistribute( domainx, x2, domainy, y2, complete=.false. )
    call mpp_redistribute( domainx, x3, domainy, y3, complete=.false. )
    call mpp_redistribute( domainx, x4, domainy, y4, complete=.false. )
    call mpp_redistribute( domainx, x5, domainy, y5, complete=.false. )
    call mpp_redistribute( domainx, x6, domainy, y6, complete=.true., dc_handle=dch )
    call mpp_clock_end  (id)
    
!check answers on pelist
    if( ANY(pelist.EQ.pe) )then
        call mpp_set_current_pelist(pelist)
        call mpp_global_field( domainy, y, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y2, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y3, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y4, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y5, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y6, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
    end if

    call mpp_set_current_pelist()

    if(type == 'Complete pelist')then
      write(stdout(),*) 'Use domain communicator handle'
      call mpp_clock_begin(id)
      if(ALLOCATED(y))then
         y=0.; y2=0.; y3=0.; y4=0.; y5=0.; y6=0.
      endif
      call mpp_redistribute( domainx, x, domainy, y, complete=.false. )
      call mpp_redistribute( domainx, x2, domainy, y2, complete=.false. )
      call mpp_redistribute( domainx, x3, domainy, y3, complete=.false. )
      call mpp_redistribute( domainx, x4, domainy, y4, complete=.false. )
      call mpp_redistribute( domainx, x5, domainy, y5, complete=.false. )
      call mpp_redistribute( domainx, x6, domainy, y6, complete=.true., dc_handle=dch )
      call mpp_clock_end  (id)
    
!check answers on pelist
    if( ANY(pelist.EQ.pe) )then
        call mpp_set_current_pelist(pelist)
        call mpp_global_field( domainy, y, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y2, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y3, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y4, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y5, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
        call mpp_global_field( domainy, y6, gcheck )
        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
    end if
    endif
    dch =>NULL()
        
    call mpp_set_current_pelist()

    call mpp_sync()
    
    deallocate(gcheck, global)
    if(ALLOCATED(pelist)) deallocate(pelist)

    if(ALLOCATED(x))then
      call mpp_redistribute( domainx, x, domainy, y, free=.true.,list_size=6 )
      deallocate(x,x2,x3,x4,x5,x6)
    endif
    if(ALLOCATED(y))deallocate(y,y2,y3,y4,y5,y6)
  end subroutine test_redistribute


  subroutine test_uniform_mosaic( type )
    character(len=*), intent(in) :: type

    type(domain2D) :: domain
    integer        :: num_contact, ntiles, npes_per_tile, ntile_per_pe, update_flags
    integer        :: i, j, k, l, n, shift, tw, te, ts, tn, tsw, tnw, tse, tne
    integer        :: ism, iem, jsm, jem, wh, eh, sh, nh
    integer        :: isc, iec, jsc, jec, isd, ied, jsd, jed
    real           :: gsum, lsum  

    integer, allocatable, dimension(:)       :: tile
    integer, allocatable, dimension(:)       :: pe_start, pe_end, tile1, tile2
    integer, allocatable, dimension(:)       :: istart1, iend1, jstart1, jend1
    integer, allocatable, dimension(:)       :: istart2, iend2, jstart2, jend2
    integer, allocatable, dimension(:,:)     :: layout2D, global_indices
    real,    allocatable, dimension(:,:)     :: global2D
    real,    allocatable, dimension(:,:,:)   :: local1, local2
    real,    allocatable, dimension(:,:,:,:) :: x, y, x1, x2, x3, x4, y1, y2, y3, y4
    real,    allocatable, dimension(:,:,:,:) :: global1, global2, gcheck  
    real,    allocatable, dimension(:,:,:,:) :: global1_all, global2_all, global_all
    character(len=128) :: type2, type3
    logical            :: folded_north, folded_north_sym, folded_north_nonsym
    logical            :: folded_south_sym, folded_west_sym, folded_east_sym
    logical            :: cubic_grid, single_tile, four_tile
    integer            :: whalo_save, ehalo_save, nhalo_save, shalo_save
    integer            :: nx_save, ny_save

    if(wide_halo_x > 0) then
       whalo_save = whalo
       ehalo_save = ehalo
       shalo_save = shalo
       nhalo_save = nhalo
       nx_save    = nx
       ny_save    = ny
       if(type == 'Single-Tile' .OR. type == 'Folded-north mosaic' .OR. type == 'Cubic-Grid') then
          whalo = wide_halo_x
          ehalo = wide_halo_x
          shalo = wide_halo_y
          nhalo = wide_halo_y
       endif
       if(type == 'Cubic-Grid') then
          if(nx_cubic >0) then
             nx = nx_cubic
             ny = ny_cubic
          endif          
       endif

    endif

    folded_north_nonsym = .false.
    folded_north_sym    = .false.
    folded_north        = .false.
    folded_south_sym    = .false.
    folded_west_sym     = .false.
    folded_east_sym     = .false.
    cubic_grid        = .false.
    single_tile        = .false.
    four_tile          = .false.
    !--- check the type
    select case(type)
    case ( 'Single-Tile' )   !--- single with cyclic along x- and y-direction
       single_tile = .true.
       ntiles = 1
       num_contact = 2
    case ( 'Folded-north mosaic' )
       ntiles = 1
       num_contact = 2
       folded_north_nonsym = .true.
    case ( 'Folded-north symmetry mosaic' )
       ntiles = 1
       num_contact = 2
       folded_north_sym = .true.
    case ( 'Folded-south symmetry mosaic' )
       ntiles = 1
       num_contact = 2
       folded_south_sym = .true.
    case ( 'Folded-west symmetry mosaic' )
       ntiles = 1
       num_contact = 2
       folded_west_sym = .true.
    case ( 'Folded-east symmetry mosaic' )
       ntiles = 1
       num_contact = 2
       folded_east_sym = .true.
    case ( 'Four-Tile' ) !--- cyclic along both x- and y-direction. 
       ntiles = 4
       num_contact = 8
       four_tile = .true.
    case ( 'Cubic-Grid' )
       ntiles = 6
       num_contact = 12
       cubic_grid = .true.
       if( nx .NE. ny) then
          call mpp_error(NOTE,'TEST_MPP_DOMAINS: for Cubic_grid mosaic, nx should equal ny, '//&
                   'No test is done for Cubic-Grid mosaic. ' )
          if(wide_halo_x > 0) then
             whalo = whalo_save
             ehalo = ehalo_save
             shalo = shalo_save
             nhalo = nhalo_save
             nx    = nx_save
             ny    = ny_save
          endif
          return
       end if
    case default
       call mpp_error(FATAL, 'TEST_MPP_DOMAINS: no such test: '//type)
    end select

    folded_north = folded_north_nonsym .OR. folded_north_sym
      
    allocate(layout2D(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
    if( mod(npes, ntiles) == 0 ) then
       npes_per_tile = npes/ntiles
       write(stdout(),*)'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
                       '", each tile will be distributed over ', npes_per_tile, ' processors.'
       ntile_per_pe = 1
       allocate(tile(ntile_per_pe))
       tile = pe/npes_per_tile+1
       call mpp_define_layout( (/1,nx,1,ny/), npes_per_tile, layout )
       do n = 1, ntiles
          pe_start(n) = (n-1)*npes_per_tile
          pe_end(n)   = n*npes_per_tile-1
       end do
    else if ( mod(ntiles, npes) == 0 ) then
       ntile_per_pe = ntiles/npes 
       write(stdout(),*)'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
                        '", there will be ', ntile_per_pe, ' tiles on each processor.'
       allocate(tile(ntile_per_pe))
       do n = 1, ntile_per_pe
          tile(n) = pe*ntile_per_pe + n
       end do
       do n = 1, ntiles
          pe_start(n) = (n-1)/ntile_per_pe
          pe_end(n)   = pe_start(n)
       end do
       layout = 1
    else
       call mpp_error(NOTE,'TEST_MPP_DOMAINS: npes should be multiple of ntiles or ' // &
            'ntiles should be multiple of npes. No test is done for '//trim(type) )  
       if(wide_halo_x > 0) then
          whalo = whalo_save
          ehalo = ehalo_save
          shalo = shalo_save
          nhalo = nhalo_save
          nx    = nx_save
          ny    = ny_save
       endif
       return
    end if
 
    do n = 1, ntiles
       global_indices(:,n) = (/1,nx,1,ny/)
       layout2D(:,n)         = layout
    end do

    allocate(tile1(num_contact), tile2(num_contact) )
    allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) ) 
    allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) ) 

    call mpp_memuse_begin()
    !--- define domain
    if(single_tile) then
       !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST)
       tile1(1) = 1; tile2(1) = 1
       istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
       istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
       !--- Contact line 2, between tile 1 (SOUTH) and tile 1 (NORTH)  --- cyclic
       tile1(2) = 1; tile2(2) = 1
       istart1(2) = 1;  iend1(2) = nx; jstart1(2) = 1;   jend1(2) = 1
       istart2(2) = 1;  iend2(2) = nx; jstart2(2) = ny;  jend2(2) = ny
       call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
            istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
            pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
            name = type, symmetry = .false. )
    else if(folded_north) then
       !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST)  --- cyclic
       tile1(1) = 1; tile2(1) = 1
       istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
       istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
       !--- Contact line 2, between tile 1 (NORTH) and tile 1 (NORTH)  --- folded-north-edge
       tile1(2) = 1; tile2(2) = 1
       istart1(2) = 1;  iend1(2) = nx/2;   jstart1(2) = ny;  jend1(2) = ny
       istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = ny;  jend2(2) = ny
       if(folded_north_nonsym) then
          call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                                 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                                 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
                                 name = type, symmetry = .false.  )
       else
          call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                                 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                                 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
                                 name = type, symmetry = .true.  )
       endif
    else if(folded_south_sym) then
       !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST)  --- cyclic
       tile1(1) = 1; tile2(1) = 1
       istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1;  jend1(1) = ny
       istart2(1) = 1;  iend2(1) = 1;  jstart2(1) = 1;  jend2(1) = ny
       !--- Contact line 2, between tile 1 (SOUTH) and tile 1 (SOUTH)  --- folded-south-edge
       tile1(2) = 1; tile2(2) = 1
       istart1(2) = 1;  iend1(2) = nx/2;   jstart1(2) = 1;  jend1(2) = 1
       istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = 1;  jend2(2) = 1
       call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                              istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                              pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
                              name = type, symmetry = .true.  )
    else if(folded_west_sym) then
       !--- Contact line 1, between tile 1 (NORTH) and tile 1 (SOUTH)  --- cyclic
       tile1(1) = 1; tile2(1) = 1
       istart1(1) = 1; iend1(1) = nx; jstart1(1) = ny;  jend1(1) = ny
       istart2(1) = 1; iend2(1) = nx; jstart2(1) = 1;   jend2(1) = 1
       !--- Contact line 2, between tile 1 (WEST) and tile 1 (WEST)  --- folded-west-edge
       tile1(2) = 1; tile2(2) = 1
       istart1(2) = 1;  iend1(2) = 1; jstart1(2) = 1;  jend1(2) = ny/2
       istart2(2) = 1;  iend2(2) = 1; jstart2(2) = ny; jend2(2) = ny/2+1
       call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                              istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                              pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
                              name = type, symmetry = .true.  )
    else if(folded_east_sym) then
       !--- Contact line 1, between tile 1 (NORTH) and tile 1 (SOUTH)  --- cyclic
       tile1(1) = 1; tile2(1) = 1
       istart1(1) = 1; iend1(1) = nx; jstart1(1) = ny;  jend1(1) = ny
       istart2(1) = 1; iend2(1) = nx; jstart2(1) = 1;   jend2(1) = 1
       !--- Contact line 2, between tile 1 (EAST) and tile 1 (EAST)  --- folded-west-edge
       tile1(2) = 1; tile2(2) = 1
       istart1(2) = nx;  iend1(2) = nx; jstart1(2) = 1;  jend1(2) = ny/2
       istart2(2) = nx;  iend2(2) = nx; jstart2(2) = ny; jend2(2) = ny/2+1
       call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
                              istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
                              pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
                              name = type, symmetry = .true.  )
    else if( four_tile ) then
       call define_fourtile_mosaic(type, domain, (/nx,nx,nx,nx/), (/ny,ny,ny,ny/), global_indices, &
                                   layout2D, pe_start, pe_end, symmetry = .false. )
    else if( cubic_grid ) then
       call define_cubic_mosaic(type, domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
                                global_indices, layout2D, pe_start, pe_end )
    endif
    call mpp_memuse_end(trim(type)//" mpp_define_mosaic", stdout() )

    !--- setup data
    allocate(global2(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz, ntile_per_pe) ) 
    allocate(global_all(1:nx,1:ny,nz, ntiles) )    
    global2 = 0
    do l = 1, ntiles
       do k = 1, nz
          do j = 1, ny
             do i = 1, nx
                global_all(i,j,k,l) = l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    do n = 1, ntile_per_pe
       global2(1:nx,1:ny,:,n) = global_all(:,:,:,tile(n))
    end do

    call mpp_get_compute_domain( domain, isc, iec, jsc, jec )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
    call mpp_get_memory_domain   ( domain, ism, iem, jsm, jem )
    allocate( gcheck(nx, ny, nz, ntile_per_pe) )
    allocate( x (ism:iem,jsm:jem,nz, ntile_per_pe) )
    allocate( x1(ism:iem,jsm:jem,nz, ntile_per_pe) )
    allocate( x2(ism:iem,jsm:jem,nz, ntile_per_pe) )
    allocate( x3(ism:iem,jsm:jem,nz, ntile_per_pe) )
    allocate( x4(ism:iem,jsm:jem,nz, ntile_per_pe) )
    x = 0.
    x(isc:iec,jsc:jec,:,:) = global2(isc:iec,jsc:jec,:,:)
    x1 = x; x2 = x; x3 = x; x4 = x;

    !--- test mpp_global_sum
    gsum = 0
    allocate(global2D(nx,ny))
    do n = 1, ntiles
       do j = 1, ny
          do i = 1, nx
             global2D(i,j) = sum(global_all(i,j,:,n))
          end do
       end do
       gsum = gsum + sum(global2D)
    end do

    do n = 1, ntile_per_pe  
       lsum = mpp_global_sum( domain, x(:,:,:,n), tile_count=n )
    end do  
    if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum

    !test exact mpp_global_sum
    do n = 1, ntile_per_pe  
       lsum = mpp_global_sum( domain, x(:,:,:,n), BITWISE_EXACT_SUM, tile_count=n)
    end do 
    call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum')

    !--- test mpp_global_field
    gcheck = 0.    
    id = mpp_clock_id( type//' global field ', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    do n = 1, ntile_per_pe
       call mpp_global_field( domain, x(:,:,:,n), gcheck(:,:,:,n), tile_count=n)
    end do
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    do n = 1, ntile_per_pe
       call compare_checksums( global2(1:nx,1:ny,:,n), gcheck(:,:,:,n), type//' mpp_global_field ' )
    end do

    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    do n = 1, ntile_per_pe
       !--- fill up the value at halo points.
       if(single_tile) then
          call fill_regular_mosaic_halo(global2(:,:,:,n), global_all, 1, 1, 1, 1, 1, 1, 1, 1)
       else if(folded_north) then
          call fill_folded_north_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
       else if(folded_south_sym) then
          call fill_folded_south_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
       else if(folded_west_sym) then
          call fill_folded_west_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
       else if(folded_east_sym) then
          call fill_folded_east_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
       else if(four_tile) then
          select case ( tile(n) )
          case (1)
             tw = 2; ts = 3; tsw = 4
          case (2)
             tw = 1; ts = 4; tsw = 3
          case (3)
             tw = 4; ts = 1; tsw = 2
          case (4)
             tw = 3; ts = 2; tsw = 1
          end select
          te = tw; tn = ts; tse = tsw; tnw = tsw; tne = tsw
          call fill_regular_mosaic_halo(global2(:,:,:,n), global_all, te, tse, ts, tsw, tw, tnw, tn, tne )
       else if(cubic_grid) then
          call fill_cubic_grid_halo(global2(:,:,:,n), global_all, global_all, tile(n), 0, 0, 1, 1 )
       endif

       !full update
       call mpp_clock_begin(id)
       if(ntile_per_pe == 1) then
          call mpp_update_domains( x(:,:,:,n), domain )
       else
          call mpp_update_domains( x(:,:,:,n), domain, tile_count = n )
       end if
       call mpp_clock_end  (id)
    end do
    type2 = type
    do n = 1, ntile_per_pe  
       if(ntile_per_pe>1)   write(type2, *)type, " at tile_count = ",n
       call compare_checksums( x(ism:ism+ied-isd,jsm:jsm+jed-jsd,:,n), global2(isd:ied,jsd:jed,:,n), trim(type2) )
    end do

    !partial update only be done when there is at most one tile on each pe
    if(ntile_per_pe == 1 ) then
       id = mpp_clock_id( type//' partial', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
       call mpp_clock_begin(id)
       call mpp_update_domains( x1, domain, NUPDATE+EUPDATE, complete=.false. )
       call mpp_update_domains( x2, domain, NUPDATE+EUPDATE, complete=.false. )
       call mpp_update_domains( x3, domain, NUPDATE+EUPDATE, complete=.false. )
       call mpp_update_domains( x4, domain, NUPDATE+EUPDATE, complete=.true. )
       call mpp_clock_end  (id)
       call compare_checksums( x1(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//' partial x1' )
       call compare_checksums( x2(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//' partial x2' )
       call compare_checksums( x3(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//' partial x3' )
       call compare_checksums( x4(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//' partial x4' )

       !arbitrary halo update. not for tripolar grid
       if(wide_halo_x == 0) then
          if(single_tile .or. four_tile .or. cubic_grid ) then
             allocate(local2(isd:ied,jsd:jed,nz) )
             do wh = 1-whalo, whalo
                do eh = 1-ehalo, ehalo
                   do sh = 1-shalo, shalo
                      do nh = 1-nhalo, nhalo
                         if( wh*eh <= 0 ) cycle
                         if( sh*nh <= 0 ) cycle
                         if( wh*sh <= 0 ) cycle
                         local2(isd:ied,jsd:jed,:) = global2(isd:ied,jsd:jed,:,1)
                         x = 0.
                         x(isc:iec,jsc:jec,:,1) = local2(isc:iec,jsc:jec,:)       
                         call fill_halo_zero(local2, wh, eh, sh, nh, 0, 0, isc, iec, jsc, jec, isd, ied, jsd, jed) 

                         write(type2,'(a,a,i2,a,i2,a,i2,a,i2)') trim(type), ' with whalo = ', wh, &
                              ', ehalo = ',eh, ', shalo = ', sh, ', nhalo = ', nh
                         call mpp_update_domains( x, domain, whalo=wh, ehalo=eh, shalo=sh, nhalo=nh, name = type2  )
                         call compare_checksums( x(isd:ied,jsd:jed,:,1), local2, trim(type2) )
                      end do
                   end do
                end do
             end do
             deallocate(local2)
          end if
       endif
    end if

    deallocate(global2, global_all, x, x1, x2, x3, x4)
    !------------------------------------------------------------------
    !              vector update : BGRID_NE, one extra point in each direction for cubic-grid
    !------------------------------------------------------------------
    !--- setup data
    shift = 0
    if(single_tile .or. four_tile .or. folded_north_nonsym) then
       shift = 0
    else
       shift = 1
    endif

    allocate(global1(1-whalo:nx+shift+ehalo,1-shalo:ny+shift+nhalo,nz,ntile_per_pe) ) 
    allocate(global2(1-whalo:nx+shift+ehalo,1-shalo:ny+shift+nhalo,nz,ntile_per_pe) ) 
    allocate(global1_all(nx+shift,ny+shift,nz, ntiles),  global2_all(nx+shift,ny+shift,nz, ntiles))    
    global1 = 0; global2 = 0
    do l = 1, ntiles
       do k = 1, nz
          do j = 1, ny+shift
             do i = 1, nx+shift
                global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
                global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    !-----------------------------------------------------------------------
    !--- make sure consistency on the boundary for cubic grid
    !--- east boundary will take the value of neighbor tile ( west/south),
    !--- north boundary will take the value of neighbor tile ( south/west).
    !--- for the point on the corner, the 12 corner take the following value
    !--- corner between 1, 2, 3 takes the value at 3, 
    !--- corner between 1, 3, 5 takes the value at 3
    !-----------------------------------------------------------------------
    if( cubic_grid ) then
       do l = 1, ntiles
          if(mod(l,2) == 0) then ! tile 2, 4, 6
             te = l + 2
             tn = l + 1
             if(te>6) te = te - 6
             if(tn > 6) tn = tn - 6
             global1_all(nx+shift,1:ny+1,:,l) = global2_all(nx+shift:1:-1,1,:,te)  ! east 
             global2_all(nx+shift,1:ny+1,:,l) = global1_all(nx+shift:1:-1,1,:,te)  ! east 
             global1_all(1:nx,ny+shift,:,l)    = global1_all(1:nx,1,:,tn) ! north
             global2_all(1:nx,ny+shift,:,l)    = global2_all(1:nx,1,:,tn) ! north
          else                   ! tile 1, 3, 5
             te = l + 1
             tn = l + 2
             if(tn > 6) tn = tn - 6
             global1_all(nx+shift,:,:,l)    = global1_all(1,:,:,te)  ! east
             global2_all(nx+shift,:,:,l)    = global2_all(1,:,:,te)  ! east
             global1_all(1:nx+1,ny+shift,:,l) = global2_all(1,ny+shift:1:-1,:,tn) ! north
             global2_all(1:nx+1,ny+shift,:,l) = global1_all(1,ny+shift:1:-1,:,tn) ! north
          end if
       end do
       ! set the corner value to 0 
       global1_all(1,ny+1,:,:) = 0; global1_all(nx+1,1,:,:) = 0; global1_all(1,1,:,:) = 0; global1_all(nx+1,ny+1,:,:) = 0
       global2_all(1,ny+1,:,:) = 0; global2_all(nx+1,1,:,:) = 0; global2_all(1,1,:,:) = 0; global2_all(nx+1,ny+1,:,:) = 0
    end if

    do n = 1, ntile_per_pe
       global1(1:nx+shift,1:ny+shift,:,n) = global1_all(:,:,:,tile(n))
       global2(1:nx+shift,1:ny+shift,:,n) = global2_all(:,:,:,tile(n))
    end do

    if(folded_north) then
       call fill_folded_north_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)    
       call fill_folded_north_halo(global2(:,:,:,1), 1, 1, shift, shift, -1)   
    else if(folded_south_sym) then
       call fill_folded_south_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)    
       call fill_folded_south_halo(global2(:,:,:,1), 1, 1, shift, shift, -1)  
    else if(folded_west_sym) then
       call fill_folded_west_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)    
       call fill_folded_west_halo(global2(:,:,:,1), 1, 1, shift, shift, -1) 
    else if(folded_east_sym) then
       call fill_folded_east_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)    
       call fill_folded_east_halo(global2(:,:,:,1), 1, 1, shift, shift, -1) 
    endif

    allocate( x (ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( y (ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( x1(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( x2(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( x3(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( x4(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( y1(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( y2(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( y3(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( y4(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )

    x = 0.; y = 0
    x (isc:iec+shift,jsc:jec+shift,:,:) = global1(isc:iec+shift,jsc:jec+shift,:,:)
    y (isc:iec+shift,jsc:jec+shift,:,:) = global2(isc:iec+shift,jsc:jec+shift,:,:)
    x1 = x; x2 = x; x3 = x; x4 = x
    y1 = y; y2 = y; y3 = y; y4 = y

    !-----------------------------------------------------------------------
    !                   fill up the value at halo points.     
    !-----------------------------------------------------------------------
    if(cubic_grid) then
       type2 = type//' paired-scalar BGRID_NE'
       update_flags = SCALAR_PAIR
    else
       type2 = type//' vector BGRID_NE'
       update_flags = XUPDATE + YUPDATE
    endif

    id = mpp_clock_id( trim(type2), flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    type3 = type2

    do n = 1, ntile_per_pe
       if(single_tile) then
          call fill_regular_mosaic_halo(global1(:,:,:,n), global1_all, 1, 1, 1, 1, 1, 1, 1, 1)       
          call fill_regular_mosaic_halo(global2(:,:,:,n), global2_all, 1, 1, 1, 1, 1, 1, 1, 1)     
       else if(folded_north) then
          !redundant points must be equal and opposite for tripolar grid
          global1(nx/2+shift,                ny+shift,:,:) = 0.  !pole points must have 0 velocity
          global1(nx+shift  ,                ny+shift,:,:) = 0.  !pole points must have 0 velocity
          global1(nx/2+1+shift:nx-1+shift,   ny+shift,:,:) = -global1(nx/2-1+shift:1+shift:-1, ny+shift,:,:)
          global1(1-whalo:shift,             ny+shift,:,:) = -global1(nx-whalo+1:nx+shift,     ny+shift,:,:)
          global1(nx+1+shift:nx+ehalo+shift, ny+shift,:,:) = -global1(1+shift:ehalo+shift,     ny+shift,:,:)
          global2(nx/2+shift,                ny+shift,:,:) = 0.  !pole points must have 0 velocity
          global2(nx+shift  ,                ny+shift,:,:) = 0.  !pole points must have 0 velocity
          global2(nx/2+1+shift:nx-1+shift,   ny+shift,:,:) = -global2(nx/2-1+shift:1+shift:-1, ny+shift,:,:)
          global2(1-whalo:shift,             ny+shift,:,:) = -global2(nx-whalo+1:nx+shift,     ny+shift,:,:)
          global2(nx+1+shift:nx+ehalo+shift, ny+shift,:,:) = -global2(1+shift:ehalo+shift,     ny+shift,:,:)
          !--- the following will fix the +0/-0 problem on altix
          if(nhalo >0) then
             global1(shift,ny+shift,:,:) = 0.  !pole points must have 0 velocity
             global2(shift,ny+shift,:,:) = 0.  !pole points must have 0 velocity
          end if
       else if(folded_south_sym) then
          global1(nx/2+shift,                1,:,:) = 0.  !pole points must have 0 velocity
          global1(nx+shift  ,                1,:,:) = 0.  !pole points must have 0 velocity
          global1(nx/2+1+shift:nx-1+shift,   1,:,:) = -global1(nx/2-1+shift:1+shift:-1, 1,:,:)
          global1(1-whalo:shift,             1,:,:) = -global1(nx-whalo+1:nx+shift,     1,:,:)
          global1(nx+1+shift:nx+ehalo+shift, 1,:,:) = -global1(1+shift:ehalo+shift,     1,:,:)
          global2(nx/2+shift,                1,:,:) = 0.  !pole points must have 0 velocity
          global2(nx+shift  ,                1,:,:) = 0.  !pole points must have 0 velocity
          global2(nx/2+1+shift:nx-1+shift,   1,:,:) = -global2(nx/2-1+shift:1+shift:-1, 1,:,:)
          global2(1-whalo:shift,             1,:,:) = -global2(nx-whalo+1:nx+shift,     1,:,:)
          global2(nx+1+shift:nx+ehalo+shift, 1,:,:) = -global2(1+shift:ehalo+shift,     1,:,:)
          !--- the following will fix the +0/-0 problem on altix
          if(shalo >0) then
             global1(shift,1,:,:) = 0.  !pole points must have 0 velocity
             global2(shift,1,:,:) = 0.  !pole points must have 0 velocity
          endif
       else if(folded_west_sym) then
          global1(1, ny/2+shift, :,:) = 0. !pole points must have 0 velocity
          global1(1, ny+shift,   :,:) = 0. !pole points must have 0 velocity
          global1(1, ny/2+1+shift:ny-1+shift,   :,:) = -global1(1, ny/2-1+shift:1+shift:-1, :,:)
          global1(1, 1-shalo:shift,             :,:) = -global1(1, ny-shalo+1:ny+shift,     :,:)
          global1(1, ny+1+shift:ny+nhalo+shift, :,:) = -global1(1, 1+shift:nhalo+shift,     :,:)
          global2(1, ny/2+shift, :,:) = 0. !pole points must have 0 velocity
          global2(1, ny+shift,   :,:) = 0. !pole points must have 0 velocity
          global2(1, ny/2+1+shift:ny-1+shift,   :,:) = -global2(1, ny/2-1+shift:1+shift:-1, :,:)
          global2(1, 1-shalo:shift,             :,:) = -global2(1, ny-shalo+1:ny+shift,     :,:)
          global2(1, ny+1+shift:ny+nhalo+shift, :,:) = -global2(1, 1+shift:nhalo+shift,     :,:)
          !--- the following will fix the +0/-0 problem on altix
          if(whalo>0) then
             global1(1, shift, :, :) = 0.  !pole points must have 0 velocity
             global2(1, shift, :, :) = 0.  !pole points must have 0 velocity
          endif
       else if(folded_east_sym) then
          global1(nx+shift, ny/2+shift, :,:) = 0. !pole points must have 0 velocity
          global1(nx+shift, ny+shift,   :,:) = 0. !pole points must have 0 velocity
          global1(nx+shift, ny/2+1+shift:ny-1+shift,   :,:) = -global1(nx+shift, ny/2-1+shift:1+shift:-1, :,:)
          global1(nx+shift, 1-shalo:shift,             :,:) = -global1(nx+shift, ny-shalo+1:ny+shift,     :,:)
          global1(nx+shift, ny+1+shift:ny+nhalo+shift, :,:) = -global1(nx+shift, 1+shift:nhalo+shift,     :,:)
          global2(nx+shift, ny/2+shift, :,:) = 0. !pole points must have 0 velocity
          global2(nx+shift, ny+shift,   :,:) = 0. !pole points must have 0 velocity
          global2(nx+shift, ny/2+1+shift:ny-1+shift,   :,:) = -global2(nx+shift, ny/2-1+shift:1+shift:-1, :,:)
          global2(nx+shift, 1-shalo:shift,             :,:) = -global2(nx+shift, ny-shalo+1:ny+shift,     :,:)
          global2(nx+shift, ny+1+shift:ny+nhalo+shift, :,:) = -global2(nx+shift, 1+shift:nhalo+shift,     :,:)
          !--- the following will fix the +0/-0 problem on altix
          if(ehalo >0) then
             global1(nx+shift, shift, :,:) = 0.  !pole points must have 0 velocity
             global2(nx+shift, shift, :,:) = 0.  !pole points must have 0 velocity
          end if          
       else if(four_tile) then
          select case ( tile(n) )
          case (1)
             tw = 2; ts = 3; tsw = 4
          case (2)
             tw = 1; ts = 4; tsw = 3
          case (3)
             tw = 4; ts = 1; tsw = 2
          case (4)
             tw = 3; ts = 2; tsw = 1
          end select
          te = tw; tn = ts; tse = tsw; tnw = tsw; tne = tsw
          call fill_regular_mosaic_halo(global1(:,:,:,n), global1_all, te, tse, ts, tsw, tw, tnw, tn, tne )
          call fill_regular_mosaic_halo(global2(:,:,:,n), global2_all, te, tse, ts, tsw, tw, tnw, tn, tne )
       else if(cubic_grid) then
          call fill_cubic_grid_halo(global1(:,:,:,n), global1_all, global2_all, tile(n), 1, 1, 1, 1 )
          call fill_cubic_grid_halo(global2(:,:,:,n), global2_all, global1_all, tile(n), 1, 1, 1, 1 )
       endif

       if(ntile_per_pe > 1) write(type3, *)trim(type2), " at tile_count = ",n
       call mpp_clock_begin(id)
       if(ntile_per_pe == 1) then
          call mpp_update_domains( x(:,:,:,n),  y(:,:,:,n),  domain, flags=update_flags, gridtype=BGRID_NE, name=type3)
       else
          call mpp_update_domains( x(:,:,:,n),  y(:,:,:,n),  domain, flags=update_flags, gridtype=BGRID_NE, &
               name=type3, tile_count = n)
       end if
       call mpp_clock_end  (id)
    end do

    do n = 1, ntile_per_pe
       if(ntile_per_pe > 1) write(type3, *)trim(type2), " at tile_count = ", n
       call compare_checksums( x (isd:ied+shift,jsd:jed+shift,:,n),  global1(isd:ied+shift,jsd:jed+shift,:,n), trim(type3)//' X' )
       call compare_checksums( y (isd:ied+shift,jsd:jed+shift,:,n),  global2(isd:ied+shift,jsd:jed+shift,:,n), trim(type3)//' Y' )
    end do

    if(ntile_per_pe == 1) then
       call mpp_clock_begin(id)
       call mpp_update_domains( x1, y1, domain, flags=update_flags, gridtype=BGRID_NE, complete=.false., name=type2)
       call mpp_update_domains( x2, y2, domain, flags=update_flags, gridtype=BGRID_NE, complete=.false.,  name=type2)
       call mpp_update_domains( x3, y3, domain, flags=update_flags, gridtype=BGRID_NE, complete=.false., name=type2)
       call mpp_update_domains( x4, y4, domain, flags=update_flags, gridtype=BGRID_NE, complete=.true.,  name=type2)
       call mpp_clock_end  (id)

       call compare_checksums( x1(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' X1')
       call compare_checksums( x2(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' X2')
       call compare_checksums( x3(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' X3')
       call compare_checksums( x4(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' X4')
       call compare_checksums( y1(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' Y1')
       call compare_checksums( y2(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' Y2')
       call compare_checksums( y3(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' Y3')
       call compare_checksums( y4(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//' Y4')

       !--- arbitrary halo updates ---------------------------------------
       if(wide_halo_x == 0) then
          if(single_tile .or. four_tile .or. cubic_grid ) then
             allocate(local1(isd:ied+shift,jsd:jed+shift,nz) )     
             allocate(local2(isd:ied+shift,jsd:jed+shift,nz) )    
             do wh = 1-whalo, whalo
                do eh = 1-ehalo, ehalo
                   do sh = 1-shalo, shalo
                      do nh = 1-nhalo, nhalo
                         if( wh*eh <= 0 ) cycle
                         if( sh*nh <= 0 ) cycle
                         if( wh*sh <= 0 ) cycle

                         local1(isd:ied+shift,jsd:jed+shift,:) = global1(isd:ied+shift,jsd:jed+shift,:,1)
                         local2(isd:ied+shift,jsd:jed+shift,:) = global2(isd:ied+shift,jsd:jed+shift,:,1)
                         x = 0.; y = 0.
                         x(isc:iec+shift,jsc:jec+shift,:,1) = global1_all(isc:iec+shift,jsc:jec+shift,:,tile(1))       
                         y(isc:iec+shift,jsc:jec+shift,:,1) = global2_all(isc:iec+shift,jsc:jec+shift,:,tile(1))    
                         call fill_halo_zero(local1, wh, eh, sh, nh, shift, shift, isc, iec, jsc, jec, isd, ied, jsd, jed)
                         call fill_halo_zero(local2, wh, eh, sh, nh, shift, shift, isc, iec, jsc, jec, isd, ied, jsd, jed)

                         write(type3,'(a,a,i2,a,i2,a,i2,a,i2)') trim(type2), ' with whalo = ', wh, &
                              ', ehalo = ',eh, ', shalo = ', sh, ', nhalo = ', nh
                         call mpp_update_domains( x,  y,  domain, flags=update_flags, gridtype=BGRID_NE, &
                              whalo=wh, ehalo=eh, shalo=sh, nhalo=nh, name=type3)
                         call compare_checksums( x(isd:ied+shift,jsd:jed+shift,:,1),  local1, trim(type3)//' X' )
                         call compare_checksums( y(isd:ied+shift,jsd:jed+shift,:,1),  local2, trim(type3)//' Y' )
                      end do
                   end do
                end do
             end do
             deallocate(local1, local2)
          end if
       endif
    end if
    !------------------------------------------------------------------
    !              vector update : CGRID_NE
    !------------------------------------------------------------------
    !--- setup data
    if(cubic_grid .or. folded_north .or. folded_south_sym .or. folded_west_sym .or. folded_east_sym ) then
       deallocate(global1_all, global2_all)
       allocate(global1_all(nx+shift,ny,nz, ntiles),  global2_all(nx,ny+shift,nz, ntiles))   
       deallocate(global1, global2, x, y, x1, x2, x3, x4, y1, y2, y3, y4)
       allocate(global1(1-whalo:nx+shift+ehalo,1-shalo:ny  +nhalo,nz,ntile_per_pe) ) 
       allocate( x (ism:iem+shift,jsm:jem  ,nz,ntile_per_pe) )
       allocate( y (ism:iem  ,jsm:jem+shift,nz,ntile_per_pe) )
       allocate( x1(ism:iem+shift,jsm:jem  ,nz,ntile_per_pe) )
       allocate( x2(ism:iem+shift,jsm:jem  ,nz,ntile_per_pe) )
       allocate( x3(ism:iem+shift,jsm:jem  ,nz,ntile_per_pe) )
       allocate( x4(ism:iem+shift,jsm:jem  ,nz,ntile_per_pe) )
       allocate( y1(ism:iem  ,jsm:jem+shift,nz,ntile_per_pe) )
       allocate( y2(ism:iem  ,jsm:jem+shift,nz,ntile_per_pe) )
       allocate( y3(ism:iem  ,jsm:jem+shift,nz,ntile_per_pe) )
       allocate( y4(ism:iem  ,jsm:jem+shift,nz,ntile_per_pe) )
       allocate(global2(1-whalo:nx  +ehalo,1-shalo:ny+shift+nhalo,nz,ntile_per_pe) ) 
       global1 = 0; global2 = 0
       do l = 1, ntiles
          do k = 1, nz
             do j = 1, ny
                do i = 1, nx+shift
                   global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
                end do
             end do
             do j = 1, ny+shift
                do i = 1, nx
                   global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
                end do
             end do
          end do
       end do
    endif
    if( folded_north .or. folded_south_sym .or. folded_west_sym .or. folded_east_sym ) then
       do n = 1, ntile_per_pe
          global1(1:nx+shift,1:ny  ,:,n) = global1_all(1:nx+shift,1:ny,  :,tile(n))
          global2(1:nx  ,1:ny+shift,:,n) = global2_all(1:nx  ,1:ny+shift,:,tile(n))
       end do
    endif

    if( cubic_grid ) then
       !-----------------------------------------------------------------------
       !--- make sure consistency on the boundary for cubic grid
       !--- east boundary will take the value of neighbor tile ( west/south),
       !--- north boundary will take the value of neighbor tile ( south/west).
       !-----------------------------------------------------------------------
       do l = 1, ntiles
          if(mod(l,2) == 0) then ! tile 2, 4, 6
             te = l + 2
             tn = l + 1
             if(te>6) te = te - 6
             if(tn > 6) tn = tn - 6
             global1_all(nx+shift,1:ny,:,l) = global2_all(nx:1:-1,1,:,te)  ! east 
             global2_all(1:nx,ny+shift,:,l) = global2_all(1:nx,1,:,tn) ! north
          else                   ! tile 1, 3, 5
             te = l + 1
             tn = l + 2
             if(tn > 6) tn = tn - 6
             global1_all(nx+shift,:,:,l)    = global1_all(1,:,:,te)  ! east
             global2_all(1:nx,ny+shift,:,l) = global1_all(1,ny:1:-1,:,tn) ! north
          end if
       end do
       do n = 1, ntile_per_pe
          global1(1:nx+shift,1:ny  ,:,n) = global1_all(1:nx+shift,1:ny,  :,tile(n))
          global2(1:nx  ,1:ny+shift,:,n) = global2_all(1:nx  ,1:ny+shift,:,tile(n))
       end do
    else if( folded_north ) then
       call fill_folded_north_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
       call fill_folded_north_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
    else if(folded_south_sym ) then
       call fill_folded_south_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
       call fill_folded_south_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
    else if(folded_west_sym ) then
       call fill_folded_west_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
       call fill_folded_west_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
    else if(folded_east_sym ) then
       call fill_folded_east_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
       call fill_folded_east_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
    endif
    x = 0.; y = 0.
    x (isc:iec+shift,jsc:jec  ,:,:) = global1(isc:iec+shift,jsc:jec  ,:,:)
    y (isc:iec  ,jsc:jec+shift,:,:) = global2(isc:iec  ,jsc:jec+shift,:,:)
    x1 = x; x2 = x; x3 = x; x4 = x
    y1 = y; y2 = y; y3 = y; y4 = y

    !-----------------------------------------------------------------------
    !                   fill up the value at halo points for cubic-grid.
    !   On the contact line, the following relation will be used to 
    !   --- fill the value on contact line ( balance send and recv).
    !       2W --> 1E, 1S --> 6N, 3W --> 1N, 4S --> 2E
    !       4W --> 3E, 3S --> 2N, 1W --> 5N, 2S --> 6E
    !       6W --> 5E, 5S --> 4N, 5W --> 3N, 6S --> 4E
    !---------------------------------------------------------------------------
    id = mpp_clock_id( type//' vector CGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    type2 = type
    do n = 1, ntile_per_pe
       if( cubic_grid ) then    
          call fill_cubic_grid_halo(global1(:,:,:,n), global1_all, global2_all, tile(n), 1, 0, 1, -1 )
          call fill_cubic_grid_halo(global2(:,:,:,n), global2_all, global1_all, tile(n), 0, 1, -1, 1 )
       else if( folded_north ) then
          !redundant points must be equal and opposite
          global2(nx/2+1:nx,     ny+shift,:,:) = -global2(nx/2:1:-1, ny+shift,:,:)
          global2(1-whalo:0,     ny+shift,:,:) = -global2(nx-whalo+1:nx, ny+shift,:,:)
          global2(nx+1:nx+ehalo, ny+shift,:,:) = -global2(1:ehalo,       ny+shift,:,:)
       else if( folded_south_sym ) then
          global2(nx/2+1:nx,     1,:,:) = -global2(nx/2:1:-1, 1,:,:)
          global2(1-whalo:0,     1,:,:) = -global2(nx-whalo+1:nx, 1, :,:)
          global2(nx+1:nx+ehalo, 1,:,:) = -global2(1:ehalo,       1, :,:)
       else if( folded_west_sym ) then
          global1(1, ny/2+1:ny,     :,:) = -global1(1, ny/2:1:-1,     :,:)
          global1(1, 1-shalo:0,     :,:) = -global1(1, ny-shalo+1:ny, :,:)
          global1(1, ny+1:ny+nhalo, :,:) = -global1(1, 1:nhalo,       :,:)
       else if( folded_east_sym ) then
          global1(nx+shift, ny/2+1:ny,     :,:) = -global1(nx+shift, ny/2:1:-1,     :,:)
          global1(nx+shift, 1-shalo:0,     :,:) = -global1(nx+shift, ny-shalo+1:ny, :,:)
          global1(nx+shift, ny+1:ny+nhalo, :,:) = -global1(nx+shift, 1:nhalo,       :,:)
       end if

       if(ntile_per_pe > 1) write(type2, *)type, " at tile_count = ",n
       call mpp_clock_begin(id)
       if(ntile_per_pe == 1) then
          call mpp_update_domains( x(:,:,:,n),  y(:,:,:,n),  domain, gridtype=CGRID_NE, name=type2//' vector CGRID_NE')
       else
          call mpp_update_domains( x(:,:,:,n),  y(:,:,:,n),  domain, gridtype=CGRID_NE, &
               name=type2//' vector CGRID_NE', tile_count = n)
       end if
       call mpp_clock_end  (id)
    end do



    do n = 1, ntile_per_pe
       if(ntile_per_pe > 1) write(type2, *)type, " at tile_count = ",n
       call compare_checksums( x(isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed,  :,n), &
                               trim(type2)//' CGRID_NE X')
       call compare_checksums( y(isd:ied,jsd:jed+shift,:,n), global2(isd:ied,  jsd:jed+shift,:,n), &
                               trim(type2)//' CGRID_NE Y')       
    end do

    if(ntile_per_pe == 1) then
       call mpp_clock_begin(id)
       call mpp_update_domains( x1, y1, domain, gridtype=CGRID_NE, complete=.false., name=type//' vector CGRID_NE' )
       call mpp_update_domains( x2, y2, domain, gridtype=CGRID_NE, complete=.false., name=type//' vector CGRID_NE')
       call mpp_update_domains( x3, y3, domain, gridtype=CGRID_NE, complete=.false., name=type//' vector CGRID_NE' )
       call mpp_update_domains( x4, y4, domain, gridtype=CGRID_NE, complete=.true. , name=type//' vector CGRID_NE')
       call mpp_clock_end  (id)

       call compare_checksums( x1(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//' CGRID_NE X1')
       call compare_checksums( x2(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//' CGRID_NE X2')
       call compare_checksums( x3(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//' CGRID_NE X3')
       call compare_checksums( x4(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//' CGRID_NE X4')
       call compare_checksums( y1(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//' CGRID_NE Y1')
       call compare_checksums( y2(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//' CGRID_NE Y2')
       call compare_checksums( y3(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//' CGRID_NE Y3')
       call compare_checksums( y4(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//' CGRID_NE Y4')

       !--- arbitrary halo updates ---------------------------------------
       if(wide_halo_x ==0) then
          if(single_tile .or. four_tile .or. cubic_grid ) then
             allocate(local1(isd:ied+shift,jsd:jed,      nz) )     
             allocate(local2(isd:ied,      jsd:jed+shift,nz) )    

             do wh = 1-whalo, whalo
                do eh = 1-ehalo, ehalo
                   do sh = 1-shalo, shalo
                      do nh = 1-nhalo, nhalo
                         if( wh*eh <= 0 ) cycle
                         if( sh*nh <= 0 ) cycle
                         if( wh*sh <= 0 ) cycle
                         local1(isd:ied+shift,jsd:jed,      :) = global1(isd:ied+shift,jsd:jed,      :,1)
                         local2(isd:ied,      jsd:jed+shift,:) = global2(isd:ied,      jsd:jed+shift,:,1)
                         x = 0.; y = 0.
                         x(isc:iec+shift,jsc:jec,      :,1) = global1_all(isc:iec+shift,jsc:jec,      :,tile(1))       
                         y(isc:iec,      jsc:jec+shift,:,1) = global2_all(isc:iec,      jsc:jec+shift,:,tile(1))    
                         call fill_halo_zero(local1, wh, eh, sh, nh, shift, 0, isc, iec, jsc, jec, isd, ied, jsd, jed)  
                         call fill_halo_zero(local2, wh, eh, sh, nh, 0, shift, isc, iec, jsc, jec, isd, ied, jsd, jed) 

                         write(type3,'(a,a,i2,a,i2,a,i2,a,i2)') trim(type), ' vector CGRID_NE with whalo = ', &
                              wh, ', ehalo = ',eh, ', shalo = ', sh, ', nhalo = ', nh
                         !          id = mpp_clock_id( trim(type3), flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
                         !          call mpp_clock_begin(id)
                         call mpp_update_domains( x,  y,  domain, gridtype=CGRID_NE, whalo=wh, ehalo=eh, &
                              shalo=sh, nhalo=nh, name=type3)
                         !          call mpp_clock_end  (id)
                         call compare_checksums( x(isd:ied+shift,jsd:jed, :,1),  local1, trim(type3)//' X' )
                         call compare_checksums( y(isd:ied,jsd:jed+shift, :,1),  local2, trim(type3)//' Y' )
                      end do
                   end do
                end do
             end do
             deallocate(local1, local2)
          end if
       endif
    end if

    deallocate(global1, global2, x, y, x1, x2, x3, x4, y1, y2, y3, y4, global1_all, global2_all)
    deallocate(layout2D, global_indices, pe_start, pe_end, tile1, tile2)
    deallocate(istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2 ) 

    if(wide_halo_x > 0) then
       whalo = whalo_save
       ehalo = ehalo_save
       shalo = shalo_save
       nhalo = nhalo_save
       nx    = nx_save
       ny    = ny_save
    endif

  end subroutine test_uniform_mosaic

  !#################################################################################

  subroutine fill_halo_zero(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, jsd, jed)
    integer,                         intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed
    integer,                         intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift
    real, dimension(isd:,jsd:,:), intent(inout) :: data

    if(whalo >=0) then
       data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0
       data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0
    else
       data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0
       data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0
    end if

    if(shalo>=0) then
       data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0
       data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0
    else
       data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0
       data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0
    end if

  end subroutine fill_halo_zero

  !##############################################################################
  ! this routine fill the halo points for the regular mosaic. 
  subroutine fill_regular_mosaic_halo(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    real, dimension(:,:,:,:),             intent(in)    :: data_all
    integer,                              intent(in)    :: te, tse, ts, tsw, tw, tnw, tn, tne

       data(nx+1:nx+ehalo, 1:ny,          :) = data_all(1:ehalo,       1:ny,          :, te) ! east
       data(1:nx,          1-shalo:0,     :) = data_all(1:nx,          ny-shalo+1:ny, :, ts) ! south 
       data(1-whalo:0,     1:ny,          :) = data_all(nx-whalo+1:nx, 1:ny,          :, tw) ! west
       data(1:nx,          ny+1:ny+nhalo, :) = data_all(1:nx,          1:nhalo,       :, tn) ! north  
       data(nx+1:nx+ehalo, 1-shalo:0,     :) = data_all(1:ehalo,       ny-shalo+1:ny, :,tse) ! southeast
       data(1-whalo:0,     1-shalo:0,     :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest
       data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo,       1:nhalo,       :,tnw) ! northeast
       data(1-whalo:0,     ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo,       :,tne) ! northwest    



  end subroutine fill_regular_mosaic_halo

  !################################################################################
  subroutine fill_folded_north_halo(data, ioff, joff, ishift, jshift, sign)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    integer,                              intent(in   ) :: ioff, joff, ishift, jshift, sign    
    integer  :: nxp, nyp, m1, m2

    nxp = nx+ishift
    nyp = ny+jshift
    m1 = ishift - ioff
    m2 = 2*ishift - ioff

    data(1-whalo:0,                  1:nyp,:) =      data(nx-whalo+1:nx,        1:ny+jshift,:) ! west
    data(nx+1:nx+ehalo+ishift,       1:nyp,:) =      data(1:ehalo+ishift,       1:ny+jshift,:) ! east
    if(m1 .GE. 1-whalo) data(1-whalo:m1,  nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1, nyp-joff:nyp-nhalo-joff+1:-1,:)
    data(m1+1:nx+m2,       nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,       nyp-joff:nyp-nhalo-joff+1:-1,:)
    data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,  nyp-joff:nyp-nhalo-joff+1:-1,:)

  end subroutine fill_folded_north_halo

  !################################################################################
  subroutine fill_folded_south_halo(data, ioff, joff, ishift, jshift, sign)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    integer,                              intent(in   ) :: ioff, joff, ishift, jshift, sign    
    integer  :: nxp, nyp, m1, m2

    nxp = nx+ishift
    nyp = ny+jshift
    m1 = ishift - ioff
    m2 = 2*ishift - ioff


    data(1-whalo:0,                  1:nyp,:) =      data(nx-whalo+1:nx,        1:nyp,:) ! west
    data(nx+1:nx+ehalo+ishift,       1:nyp,:) =      data(1:ehalo+ishift,       1:nyp,:) ! east
    if(m1 .GE. 1-whalo)data(1-whalo:m1, 1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:)
    data(m1+1:nx+m2,       1-shalo:0,:) = sign*data(nxp:1:-1,             shalo+jshift:1+jshift:-1,:)
    data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,  shalo+jshift:1+jshift:-1,:)

  end subroutine fill_folded_south_halo

  !################################################################################
  subroutine fill_folded_west_halo(data, ioff, joff, ishift, jshift, sign)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    integer,                              intent(in   ) :: ioff, joff, ishift, jshift, sign    
    integer  :: nxp, nyp, m1, m2

    nxp = nx+ishift
    nyp = ny+jshift
    m1 = jshift - joff
    m2 = 2*jshift - joff

    data(1:nxp, 1-shalo:0, :)      = data(1:nxp, ny-shalo+1:ny, :) ! south
    data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north
    if(m1 .GE. 1-shalo) data(1-whalo:0, 1-shalo:m1, :) = sign*data(whalo+ishift:1+ishift:-1, shalo+m2:1+jshift:-1,:)
    data(1-whalo:0, m1+1:ny+m2, :) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :)
    data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:)

  end subroutine fill_folded_west_halo

  !################################################################################
  subroutine fill_folded_east_halo(data, ioff, joff, ishift, jshift, sign)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    integer,                              intent(in   ) :: ioff, joff, ishift, jshift, sign    
    integer  :: nxp, nyp, m1, m2

    nxp = nx+ishift
    nyp = ny+jshift
    m1 = jshift - joff
    m2 = 2*jshift - joff

    data(1:nxp, 1-shalo:0, :)      = data(1:nxp, ny-shalo+1:ny, :) ! south
    data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north
    if(m1 .GE. 1-shalo) data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:)
    data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :)
    data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:)

  end subroutine fill_folded_east_halo

  !################################################################################
  subroutine fill_four_tile_bound(data_all, is, ie, js, je, ioff, joff, tile, &
                                   ebound, sbound, wbound, nbound )
    real, dimension(:,:,:,:),       intent(in)    :: data_all
    integer,                        intent(in)    :: is, ie, js, je
    integer,                        intent(in)    :: tile, ioff, joff
    real, dimension(:,:), optional, intent(inout) :: ebound, sbound, wbound, nbound
    integer                                       :: tw, te, ts, tn

    if(tile == 1 .OR. tile == 3) te = tile + 1
    if(tile == 2 .OR. tile == 4) te = tile - 1
    if(tile == 1 .OR. tile == 2) ts = tile + 2
    if(tile == 3 .OR. tile == 4) ts = tile - 2
    tw = te;   tn = ts
    if(present(ebound)) then
       if( ie == nx ) then
          ebound(:,:) = data_all(1, js:je+joff, :, te)
       else
          ebound(:,:) = data_all(ie+ioff, js:je+joff, :, tile)
       end if
    end if

    if(present(wbound)) then
       if( is == 1 ) then
          wbound(:,:) = data_all(nx+ioff, js:je+joff, :, tw)
       else
          wbound(:,:) = data_all(is, js:je+joff, :, tile)
       end if
    end if

    if(present(sbound)) then
       if( js == 1 ) then
          sbound(:,:) = data_all(is:ie+ioff, ny+joff, :, ts)
       else
          sbound(:,:) = data_all(is:ie+ioff, js, :, tile)
       end if
    end if

    if(present(nbound)) then
       if( je == ny ) then
          nbound(:,:) = data_all(is:ie+ioff, 1, :, tn)
       else
          nbound(:,:) = data_all(is:ie+ioff, je+joff, :, tile)
       end if
    end if

    return

  end subroutine fill_four_tile_bound

  !################################################################################
  subroutine fill_cubic_grid_bound(data1_all, data2_all, is, ie, js, je, ioff, joff, tile, sign1, sign2, &
                                   ebound, sbound, wbound, nbound )
    real, dimension(:,:,:,:),       intent(in)    :: data1_all, data2_all
    integer,                        intent(in)    :: is, ie, js, je
    integer,                        intent(in)    :: tile, ioff, joff, sign1, sign2
    real, dimension(:,:), optional, intent(inout) :: ebound, sbound, wbound, nbound
    integer                                       :: tw, te, ts, tn

    if(mod(tile,2) == 0) then ! tile 2, 4, 6
       tw = tile - 1; te = tile + 2; ts = tile - 2; tn = tile + 1
       if(te > 6 ) te = te - 6
       if(ts < 1 ) ts = ts + 6
       if(tn > 6 ) tn = tn - 6
       !--- East bound
       if(present(ebound)) then
          if(ie == nx) then                
             ebound(:,:) = sign1*data2_all(nx+joff-js+1:nx-je+1:-1,1,:,te)
          else
             ebound(:,:) = data1_all(ie+ioff, js:je+joff, :,tile)
          end if
       end if
       !--- South bound
       if(present(sbound)) then
          if(js == 1) then                
             sbound(:,:) = sign2*data2_all(nx+joff, ny+ioff-is+1:ny-ie+1:-1,:,ts)
          else
             sbound(:,:) = data1_all(is:ie+ioff, js, :,tile)
          end if
       end if

       !--- West bound
       if(present(wbound)) then
          if(is == 1) then
             wbound(:,:) = data1_all(nx+ioff, js:je+joff,:,tw)
          else
             wbound(:,:) = data1_all(is, js:je+joff,:,tile)
          end if
       end if

       !--- north bound
       if(present(nbound)) then
          if(je == ny) then                
             nbound(:,:) = data1_all(is:ie+ioff, 1,:,tn)
          else
             nbound(:,:) = data1_all(is:ie+ioff, je+joff, :,tile)
          end if
       end if
    else ! tile 1, 3, 5
       tw = tile - 2; te = tile + 1; ts = tile - 1; tn = tile + 2
       if(tw < 1 ) tw = tw + 6
       if(ts < 1 ) ts = ts + 6
       if(tn > 6 ) tn = tn - 6
       !--- East bound
       if(present(ebound)) then
          if(ie == nx) then                
             ebound(:,:) = data1_all(1, js:je+joff, :,te) 
          else
             ebound(:,:) = data1_all(ie+ioff, js:je+joff, :,tile)
          end if
       end if
       !--- South bound
       if(present(sbound)) then
          if(js == 1) then                
             sbound(:,:) = data1_all(is:ie+ioff,ny+joff,:,ts)
          else
             sbound(:,:) = data1_all(is:ie+ioff, js, :,tile)
          end if
       end if

       !--- West bound
       if(present(wbound)) then
          if(is == 1) then
             wbound(:,:) = sign1*data2_all(nx+joff-js+1:nx-je+1:-1,ny+ioff,:,tw)
          else
             wbound(:,:) = data1_all(is, js:je+joff,:,tile)
          end if
       end if

       !--- north bound
       if(present(nbound)) then
          if(je == ny) then                
             nbound(:,:) = sign2*data2_all(1, ny+ioff-is+1:ny-ie+1:-1,:,tn)
          else
             nbound(:,:) = data1_all(is:ie+ioff, je+joff, :,tile)
          end if
       end if

    end if

  end subroutine fill_cubic_grid_bound

  !##############################################################################
  ! this routine fill the halo points for the cubic grid. ioff and joff is used to distinguish
  ! T, C, E, or N-cell
  subroutine fill_cubic_grid_halo(data, data1_all, data2_all, tile, ioff, joff, sign1, sign2)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    real, dimension(:,:,:,:),             intent(in)    :: data1_all, data2_all
    integer,                              intent(in)    :: tile, ioff, joff, sign1, sign2 
    integer                                             :: lw, le, ls, ln

    if(mod(tile,2) == 0) then ! tile 2, 4, 6
       lw = tile - 1; le = tile + 2; ls = tile - 2; ln = tile + 1
       if(le > 6 ) le = le - 6
       if(ls < 1 ) ls = ls + 6
       if(ln > 6 ) ln = ln - 6
       data(1-whalo:0, 1:ny+joff, :) = data1_all(nx-whalo+1:nx, 1:ny+joff, :, lw) ! west 
       do i = 1, ehalo 
          data(nx+i+ioff, 1:ny+joff, :)    = sign1*data2_all(nx+joff:1:-1, i+ioff, :, le) ! east 
       end do
       do i = 1, shalo 
          data(1:nx+ioff, 1-i, :)     = sign2*data2_all(nx-i+1, ny+ioff:1:-1, :, ls) ! south 
       end do
       data(1:nx+ioff, ny+1+joff:ny+nhalo+joff, :) = data1_all(1:nx+ioff, 1+joff:nhalo+joff, :, ln) ! north
    else ! tile 1, 3, 5
       lw = tile - 2; le = tile + 1; ls = tile - 1; ln = tile + 2
       if(lw < 1 ) lw = lw + 6
       if(ls < 1 ) ls = ls + 6
       if(ln > 6 ) ln = ln - 6
       do i = 1, whalo 
          data(1-i, 1:ny+joff, :)     = sign1*data2_all(nx+joff:1:-1, ny-i+1, :, lw) ! west 
       end do
       data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:ny+joff, :, le) ! east 
       data(1:nx+ioff, 1-shalo:0, :)     = data1_all(1:nx+ioff, ny-shalo+1:ny, :, ls) ! south 
       do i = 1, nhalo 
          data(1:nx+ioff, ny+i+joff, :)    = sign2*data2_all(i+joff, ny+ioff:1:-1, :, ln) ! north 
       end do
    end if

  end subroutine fill_cubic_grid_halo
    
   !#####################################################################
  subroutine test_nonuniform_mosaic( type )
    character(len=*), intent(in) :: type

    type(domain2D)               :: domain
    integer                      :: num_contact, ntiles, ntile_per_pe
    integer                      :: i, j, k, n, nxm, nym, ni, nj, shift
    integer                      :: ism, iem, jsm, jem, isc, iec, jsc, jec
    integer                      :: isd, ied, jsd, jed
    integer                      :: indices(4), msize(2)
    character(len=128)           :: type2

    integer, allocatable, dimension(:)       :: tile
    integer, allocatable, dimension(:)       :: pe_start, pe_end, tile1, tile2
    integer, allocatable, dimension(:)       :: istart1, iend1, jstart1, jend1
    integer, allocatable, dimension(:)       :: istart2, iend2, jstart2, jend2
    integer, allocatable, dimension(:,:)     :: layout2D, global_indices
    real,    allocatable, dimension(:,:,:,:) :: global1_all, global2_all
    real,    allocatable, dimension(:,:,:,:) :: global1, global2, x, y  

    shift = 0
    select case(type)
    case('Five-Tile') ! one tile will run on pe 0 and other four tiles will run on pe 1
       shift = 1      ! one extra point for symmetry domain
       ntiles = 5     ! tile 1 with resolution 2*nx and 2*ny and the tiles are nx and ny.
       num_contact = 11
       if(npes .NE. 2) then
          call mpp_error(NOTE,'TEST_MPP_DOMAINS: Five-Tile mosaic will not be tested because npes is not 2')
          return
       end if 
       nxm = 2*nx; nym = 2*ny
       layout = 1
       if( pe == 0) then
          ntile_per_pe = 1
          allocate(tile(ntile_per_pe))
          tile = 1
          indices = (/1,2*nx,1,2*ny/)
          ni = 2*nx; nj = 2*ny
       else
          ntile_per_pe = 4
          allocate(tile(ntile_per_pe))
          do n = 1, ntile_per_pe
             tile(n) = n + 1
          end do
          indices = (/1,nx,1,ny/)
          ni = nx; nj = ny
       end if
       allocate(pe_start(ntiles), pe_end(ntiles) )
       pe_start(1) = 0; pe_start(2:) = 1
       pe_end = pe_start
    case default
       call mpp_error(FATAL, 'TEST_MPP_DOMAINS: no such test: '//type)
    end select

    allocate(layout2D(2,ntiles), global_indices(4,ntiles) )

    do n = 1, ntiles
       if(n==1) then
          global_indices(:,n) = (/1,2*nx,1,2*ny/)
       else
          global_indices(:,n) = (/1,nx,1,ny/)
       endif  
!       global_indices(:,n) = indices
       layout2D(:,n)       = layout
    end do

    allocate(tile1(num_contact), tile2(num_contact) )
    allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) ) 
    allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) ) 

    !--- define domain
    select case(type)
    case( 'Five-Tile' )
       !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST)
       tile1(1) = 1; tile2(1) = 2
       istart1(1) = 2*nx; iend1(1) = 2*nx; jstart1(1) = 1;  jend1(1) = ny
       istart2(1) = 1;    iend2(1) = 1;    jstart2(1) = 1;  jend2(1) = ny
       !--- Contact line 2, between tile 1 (EAST) and tile 4 (WEST)
       tile1(2) = 1; tile2(2) = 4
       istart1(2) = 2*nx; iend1(2) = 2*nx; jstart1(2) = ny+1; jend1(2) = 2*ny
       istart2(2) = 1;    iend2(2) = 1;    jstart2(2) = 1;    jend2(2) = ny
       !--- Contact line 3, between tile 1 (SOUTH) and tile 1 (NORTH)
       tile1(3) = 1; tile2(3) = 1
       istart1(3) = 1; iend1(3) = 2*nx; jstart1(3) = 1;    jend1(3) = 1
       istart2(3) = 1; iend2(3) = 2*nx; jstart2(3) = 2*ny; jend2(3) = 2*ny
       !--- Contact line 4, between tile 1 (WEST) and tile 3 (EAST)
       tile1(4) = 1; tile2(4) = 3
       istart1(4) = 1;  iend1(4) = 1;  jstart1(4) = 1;  jend1(4) = ny
       istart2(4) = nx; iend2(4) = nx; jstart2(4) = 1;  jend2(4) = ny
       !--- Contact line 5, between tile 1 (WEST) and tile 5 (EAST)
       tile1(5) = 1; tile2(5) = 5
       istart1(5) = 1;  iend1(5) = 1;  jstart1(5) = ny+1;  jend1(5) = 2*ny
       istart2(5) = nx; iend2(5) = nx; jstart2(5) = 1;     jend2(5) = ny
       !--- Contact line 6, between tile 2 (EAST) and tile 3 (WEST)
       tile1(6) = 2; tile2(6) = 3
       istart1(6) = nx; iend1(6) = nx; jstart1(6) = 1;  jend1(6) = ny
       istart2(6) = 1;  iend2(6) = 1;  jstart2(6) = 1;  jend2(6) = ny       
       !--- Contact line 7, between tile 2 (SOUTH) and tile 4 (NORTH)  --- cyclic
       tile1(7) = 2; tile2(7) = 4
       istart1(7) = 1;  iend1(7) = nx; jstart1(7) = 1;   jend1(7) = 1
       istart2(7) = 1;  iend2(7) = nx; jstart2(7) = ny;  jend2(7) = ny
       !--- Contact line 8, between tile 2 (NORTH) and tile 4 (SOUTH) 
       tile1(8) = 2; tile2(8) = 4
       istart1(8) = 1;  iend1(8) = nx; jstart1(8) = ny;  jend1(8) = ny
       istart2(8) = 1;  iend2(8) = nx; jstart2(8) = 1;   jend2(8) = 1
       !--- Contact line 9, between tile 3 (SOUTH) and tile 5 (NORTH)  --- cyclic
       tile1(9) = 3; tile2(9) = 5
       istart1(9) = 1;  iend1(9) = nx; jstart1(9) = 1;   jend1(9) = 1
       istart2(9) = 1;  iend2(9) = nx; jstart2(9) = ny;  jend2(9) = ny
       !--- Contact line 10, between tile 3 (NORTH) and tile 5 (SOUTH) 
       tile1(10) = 3; tile2(10) = 5
       istart1(10) = 1;  iend1(10) = nx; jstart1(10) = ny;  jend1(10) = ny
       istart2(10) = 1;  iend2(10) = nx; jstart2(10) = 1;   jend2(10) = 1
       !--- Contact line 11, between tile 4 (EAST) and tile 5 (WEST)
       tile1(11) = 4; tile2(11) = 5
       istart1(11) = nx; iend1(11) = nx; jstart1(11) = 1;  jend1(11) = ny
       istart2(11) = 1;  iend2(11) = 1;  jstart2(11) = 1;  jend2(11) = ny  
       msize(1) = 2*nx + whalo + ehalo
       msize(2) = 2*ny + shalo + nhalo
       call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, num_contact, tile1, tile2, &
            istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
            pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,       &
            name = type, memory_size = msize, symmetry = .true.  )
    end select
    
    !--- setup data
    allocate(global1_all(1:nxm,1:nym,nz, ntiles) )  
    allocate(global1(1-whalo:ni+ehalo,1-shalo:nj+nhalo,nz, ntile_per_pe) )   
    do n = 1, ntiles
       do k = 1, nz
          do j = 1, nym
             do i = 1, nxm
                global1_all(i,j,k,n) = n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    do n = 1, ntile_per_pe
       global1(1:ni,1:nj,:,n) = global1_all(1:ni,1:nj,:,tile(n))
    end do

    call mpp_get_compute_domain( domain, isc, iec, jsc, jec )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
    call mpp_get_memory_domain   ( domain, ism, iem, jsm, jem )

    allocate( x (ism:iem,jsm:jem,nz, ntile_per_pe) )
    x = 0.
    x(isc:iec,jsc:jec,:,:) = global1(isc:iec,jsc:jec,:,:)

    !--- fill up the value at halo points
    do n = 1, ntile_per_pe
       call fill_five_tile_halo(global1(:,:,:,n), global1_all, tile(n), 0, 0 )
    end do

    ! full update
    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    do n = 1, ntile_per_pe
       call mpp_update_domains( x(:,:,:,n), domain, tile_count = n )
    end do
    call mpp_clock_end(id)

   do n = 1, ntile_per_pe
      write(type2, *)type, " at tile_count = ",n
      call compare_checksums( x(isd:ied,jsd:jed,:,n), global1(isd:ied,jsd:jed,:,n), trim(type2) )
   end do

   deallocate(global1_all, global1, x)

    !------------------------------------------------------------------
    !  vector update : BGRID_NE, one extra point in each direction for Five-Tile
    !------------------------------------------------------------------
    !--- setup data
    allocate(global1_all(nxm+shift,nym+shift,nz, ntiles), global2_all(nxm+shift,nym+shift,nz, ntiles) )  
    allocate(global1(1-whalo:ni+ehalo+shift,1-shalo:nj+nhalo+shift,nz, ntile_per_pe) )  
    allocate(global2(1-whalo:ni+ehalo+shift,1-shalo:nj+nhalo+shift,nz, ntile_per_pe) )   
    do n = 1, ntiles
       do k = 1, nz
          do j = 1, nym+shift
             do i = 1, nxm+shift
                global1_all(i,j,k,n) = 1.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
                global2_all(i,j,k,n) = 2.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    !------------------------------------------------------------------------
    ! --- make sure consisency on the boundary for Five-Tile mosaic
    ! --- east boundary will take the value of neighbor tile west,
    ! --- north boundary will take the value of neighbor tile south.
    !------------------------------------------------------------------------
    if(type == 'Five-Tile') then
       global1_all(nxm+1,    1:ny,:,1) = global1_all(1,    1:ny,:,2)  ! east
       global1_all(nxm+1,ny+1:nym,:,1) = global1_all(1,    1:ny,:,4)  ! east
       global1_all(1:nxm+1, nym+1,:,1) = global1_all(1:nxm+1, 1,:,1)  ! north
       global1_all(nx+1,     1:ny,:,2) = global1_all(1,    1:ny,:,3)  ! east
       global1_all(1:nx+1,   ny+1,:,2) = global1_all(1:nx+1,  1,:,4)  ! north
       global1_all(nx+1,     1:ny,:,3) = global1_all(1,    1:ny,:,1)  ! east
       global1_all(1:nx+1,   ny+1,:,3) = global1_all(1:nx+1,  1,:,5)  ! north
       global1_all(nx+1,     1:ny,:,4) = global1_all(1,    1:ny,:,5)  ! east
       global1_all(1:nx+1,   ny+1,:,4) = global1_all(1:nx+1,  1,:,2)  ! north
       global1_all(nx+1,     1:ny,:,5) = global1_all(1,ny+1:nym,:,1)  ! east
       global1_all(1:nx+1,   ny+1,:,5) = global1_all(1:nx+1,  1,:,3)  ! north
       global1_all(nx+1,     ny+1,:,2) = global1_all(1,       1,:,5)  ! northeast 
       global1_all(nx+1,     ny+1,:,3) = global1_all(1,    ny+1,:,1)  ! northeast 
       global2_all(nxm+1,    1:ny,:,1) = global2_all(1,    1:ny,:,2)  ! east
       global2_all(nxm+1,ny+1:nym,:,1) = global2_all(1,    1:ny,:,4)  ! east
       global2_all(1:nxm+1, nym+1,:,1) = global2_all(1:nxm+1, 1,:,1)  ! north
       global2_all(nx+1,     1:ny,:,2) = global2_all(1,    1:ny,:,3)  ! east
       global2_all(1:nx+1,   ny+1,:,2) = global2_all(1:nx+1,  1,:,4)  ! north
       global2_all(nx+1,     1:ny,:,3) = global2_all(1,    1:ny,:,1)  ! east
       global2_all(1:nx+1,   ny+1,:,3) = global2_all(1:nx+1,  1,:,5)  ! north
       global2_all(nx+1,     1:ny,:,4) = global2_all(1,    1:ny,:,5)  ! east
       global2_all(1:nx+1,   ny+1,:,4) = global2_all(1:nx+1,  1,:,2)  ! north
       global2_all(nx+1,     1:ny,:,5) = global2_all(1,ny+1:nym,:,1)  ! east
       global2_all(1:nx+1,   ny+1,:,5) = global2_all(1:nx+1,  1,:,3)  ! north
       global2_all(nx+1,     ny+1,:,2) = global2_all(1,       1,:,5)  ! northeast 
       global2_all(nx+1,     ny+1,:,3) = global2_all(1,    ny+1,:,1)  ! northeast 
    end if

    do n = 1, ntile_per_pe
       global1(1:ni+shift,1:nj+shift,:,n) = global1_all(1:ni+shift,1:nj+shift,:,tile(n))
       global2(1:ni+shift,1:nj+shift,:,n) = global2_all(1:ni+shift,1:nj+shift,:,tile(n))
    end do

    allocate( x (ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
    allocate( y (ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )

    x = 0.; y = 0
    x (isc:iec+shift,jsc:jec+shift,:,:) = global1(isc:iec+shift,jsc:jec+shift,:,:)
    y (isc:iec+shift,jsc:jec+shift,:,:) = global2(isc:iec+shift,jsc:jec+shift,:,:)

    !-----------------------------------------------------------------------
    !                   fill up the value at halo points.     
    !-----------------------------------------------------------------------
    do n = 1, ntile_per_pe
       call fill_five_tile_halo(global1(:,:,:,n), global1_all, tile(n), shift, shift)
       call fill_five_tile_halo(global2(:,:,:,n), global2_all, tile(n), shift, shift)
    end do

    id = mpp_clock_id( type//' BGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    do n = 1, ntile_per_pe
       call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=BGRID_NE, tile_count = n )
    end do
    call mpp_clock_end(id)

   do n = 1, ntile_per_pe
      write(type2, *)type, " at tile_count = ",n
      call compare_checksums( x(isd:ied+shift,jsd:jed+shift,:,n), global1(isd:ied+shift,jsd:jed+shift,:,n), &
                              trim(type2)//' BGRID_NE X')
      call compare_checksums( y(isd:ied+shift,jsd:jed+shift,:,n), global2(isd:ied+shift,jsd:jed+shift,:,n), &
                              trim(type2)//' BGRID_NE Y')
   end do

   deallocate(global1_all, global2_all, global1, global2, x, y)

    !------------------------------------------------------------------
    !  vector update : CGRID_NE
    !------------------------------------------------------------------
    !--- setup data
    allocate(global1_all(nxm+shift,nym,nz, ntiles), global2_all(nxm,nym+shift,nz, ntiles) )  
    allocate(global1(1-whalo:ni+ehalo+shift, 1-shalo:nj+nhalo,       nz, ntile_per_pe) )  
    allocate(global2(1-whalo:ni+ehalo,       1-shalo:nj+nhalo+shift, nz, ntile_per_pe) )   
    do n = 1, ntiles
       do k = 1, nz
          do j = 1, nym
             do i = 1, nxm+shift
                global1_all(i,j,k,n) = 1.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
          do j = 1, nym+shift
             do i = 1, nxm
                global2_all(i,j,k,n) = 2.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    !------------------------------------------------------------------------
    ! --- make sure consisency on the boundary for Five-Tile mosaic
    ! --- east boundary will take the value of neighbor tile west,
    ! --- north boundary will take the value of neighbor tile south.
    !------------------------------------------------------------------------
    if(type == 'Five-Tile') then
       global1_all(nxm+1,    1:ny,:,1) = global1_all(1,    1:ny,:,2)  ! east
       global1_all(nxm+1,ny+1:nym,:,1) = global1_all(1,    1:ny,:,4)  ! east
       global1_all(nx+1,     1:ny,:,2) = global1_all(1,    1:ny,:,3)  ! east
       global1_all(nx+1,     1:ny,:,3) = global1_all(1,    1:ny,:,1)  ! east
       global1_all(nx+1,     1:ny,:,4) = global1_all(1,    1:ny,:,5)  ! east
       global1_all(nx+1,     1:ny,:,5) = global1_all(1,ny+1:nym,:,1)  ! east
       global2_all(1:nxm,   nym+1,:,1) = global2_all(1:nxm,   1,:,1)  ! north
       global2_all(1:nx,     ny+1,:,2) = global2_all(1:nx,    1,:,4)  ! north
       global2_all(1:nx,     ny+1,:,3) = global2_all(1:nx,    1,:,5)  ! north
       global2_all(1:nx,     ny+1,:,4) = global2_all(1:nx,    1,:,2)  ! north
       global2_all(1:nx,     ny+1,:,5) = global2_all(1:nx,    1,:,3)  ! north
    end if

    do n = 1, ntile_per_pe
       global1(1:ni+shift,      1:nj,:,n) = global1_all(1:ni+shift,      1:nj,:,tile(n))
       global2(1:ni,      1:nj+shift,:,n) = global2_all(1:ni,      1:nj+shift,:,tile(n))
    end do

    allocate( x (ism:iem+shift,      jsm:jem,nz,ntile_per_pe) )
    allocate( y (ism:iem,      jsm:jem+shift,nz,ntile_per_pe) )

    x = 0.; y = 0
    x (isc:iec+shift,      jsc:jec,:,:) = global1(isc:iec+shift,      jsc:jec,:,:)
    y (isc:iec,      jsc:jec+shift,:,:) = global2(isc:iec,      jsc:jec+shift,:,:)

    !-----------------------------------------------------------------------
    !                   fill up the value at halo points.     
    !-----------------------------------------------------------------------
    do n = 1, ntile_per_pe
       call fill_five_tile_halo(global1(:,:,:,n), global1_all, tile(n), shift, 0)
       call fill_five_tile_halo(global2(:,:,:,n), global2_all, tile(n), 0, shift)
    end do

    id = mpp_clock_id( type//' CGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    do n = 1, ntile_per_pe
       call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=CGRID_NE, tile_count = n )
    end do
    call mpp_clock_end(id)

   do n = 1, ntile_per_pe
      write(type2, *)type, " at tile_count = ",n
      call compare_checksums( x(isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed,:,n), &
                              trim(type2)//' CGRID_NE X')
      call compare_checksums( y(isd:ied,jsd:jed+shift,:,n), global2(isd:ied,jsd:jed+shift,:,n), &
                              trim(type2)//' CGRID_NE Y')
   end do

   deallocate(global1_all, global2_all, global1, global2, x, y)

  end subroutine test_nonuniform_mosaic

  subroutine fill_five_tile_halo(data, data_all, tile, ioff, joff)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    real, dimension(:,:,:,:),             intent(in)    :: data_all
    integer,                              intent(in)    :: tile, ioff, joff
    integer                                             :: nxm, nym

    nxm = 2*nx; nym = 2*ny

    select case(tile)
    case(1)
       data(nxm+1+ioff:nxm+ehalo+ioff,                     1:ny,:) = data_all(1+ioff:ehalo+ioff,              1:ny,:,2) ! east
       data(nxm+1+ioff:nxm+ehalo+ioff,            ny+1:nym+joff,:) = data_all(1+ioff:ehalo+ioff,         1:ny+joff,:,4) ! east
       data(1-whalo:0,                                     1:ny,:) = data_all(nx-whalo+1:nx,                  1:ny,:,3) ! west
       data(1-whalo:0,                            ny+1:nym+joff,:) = data_all(nx-whalo+1:nx,             1:ny+joff,:,5) ! west
       data(1:nxm+ioff,                               1-shalo:0,:) = data_all(1:nxm+ioff,          nym-shalo+1:nym,:,1) ! south
       data(1:nxm+ioff,               nym+1+joff:nym+nhalo+joff,:) = data_all(1:nxm+ioff,        1+joff:nhalo+joff,:,1) ! north
       data(nxm+1+ioff:nxm+ehalo+ioff,                1-shalo:0,:) = data_all(1+ioff:ehalo+ioff,     ny-shalo+1:ny,:,4) ! southeast
       data(1-whalo:0,                                1-shalo:0,:) = data_all(nx-whalo+1:nx,         ny-shalo+1:ny,:,5) ! southwest
       data(nxm+1+ioff:nxm+ehalo+ioff,nym+1+joff:nym+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,2) ! northeast
       data(1-whalo:0,                nym+1+joff:nym+nhalo+joff,:) = data_all(nx-whalo+1:nx,     1+joff:nhalo+joff,:,3) ! northwest
    case(2)
       data(nx+1+ioff:nx+ehalo+ioff,              1:ny+joff,:) = data_all(1+ioff:ehalo+ioff,              1:ny+joff,:,3) ! east
       data(1-whalo:0,                            1:ny+joff,:) = data_all(nxm-whalo+1:nxm,                1:ny+joff,:,1) ! west
       data(1:nx+ioff,                            1-shalo:0,:) = data_all(1:nx+ioff,                  ny-shalo+1:ny,:,4) ! south 
       data(1:nx+ioff,              ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff,              1+joff:nhalo+joff,:,4) ! north
       data(nx+1+ioff:nx+ehalo+ioff,              1-shalo:0,:) = data_all(1+ioff:ehalo+ioff,          ny-shalo+1:ny,:,5) ! southeast
       data(1-whalo:0,                            1-shalo:0,:) = data_all(nxm-whalo+1:nxm,          nym-shalo+1:nym,:,1) ! southwest
       data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,      1+joff:nhalo+joff,:,5) ! northeast
       data(1-whalo:0,              ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm,  ny+1+joff:ny+nhalo+joff,:,1) ! northwest
    case(3)
       data(nx+1+ioff:nx+ehalo+ioff,              1:ny+joff,:) = data_all(1+ioff:ehalo+ioff,              1:ny+joff,:,1) ! east
       data(1-whalo:0,                            1:ny+joff,:) = data_all(nx-whalo+1:nx,                  1:ny+joff,:,2) ! west
       data(1:nx+ioff,                            1-shalo:0,:) = data_all(1:nx+ioff,                  ny-shalo+1:ny,:,5) ! south 
       data(1:nx+ioff,              ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff,              1+joff:nhalo+joff,:,5) ! north
       data(nx+1+ioff:nx+ehalo+ioff,              1-shalo:0,:) = data_all(1+ioff:ehalo+ioff,        nym-shalo+1:nym,:,1) ! southeast
       data(1-whalo:0,                            1-shalo:0,:) = data_all(nx-whalo+1:nx,              ny-shalo+1:ny,:,4) ! southwest
       data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,ny+1+joff:ny+nhalo+joff,:,1) ! northeast
       data(1-whalo:0,              ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx,          1+joff:nhalo+joff,:,4) ! northwest
    case(4)
       data(nx+1+ioff:nx+ehalo+ioff,              1:ny+joff,:) = data_all(1+ioff:ehalo+ioff,        1:ny+joff,:,5) ! east
       data(1-whalo:0,                            1:ny+joff,:) = data_all(nxm-whalo+1:nxm,     ny+1:2*ny+joff,:,1) ! west
       data(1:nx+ioff,                            1-shalo:0,:) = data_all(1:nx+ioff,            ny-shalo+1:ny,:,2) ! south 
       data(1:nx+ioff,              ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff,        1+joff:nhalo+joff,:,2) ! north
       data(nx+1+ioff:nx+ehalo+ioff,              1-shalo:0,:) = data_all(1+ioff:ehalo+ioff,    ny-shalo+1:ny,:,3) ! southeast
       data(1-whalo:0,                            1-shalo:0,:) = data_all(nxm-whalo+1:nxm,      ny-shalo+1:ny,:,1) ! southwest
       data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,3) ! northeast
       data(1-whalo:0,              ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm,  1+joff:nhalo+joff,:,1) ! northwest
    case(5)
       data(nx+1+ioff:nx+ehalo+ioff,            1:  ny+joff,:) = data_all(1+ioff:ehalo+ioff,   ny+1:2*ny+joff,:,1) ! east
       data(1-whalo:0,                            1:ny+joff,:) = data_all(nx-whalo+1:nx,            1:ny+joff,:,4) ! west
       data(1:nx+ioff,                            1-shalo:0,:) = data_all(1:nx+ioff,            ny-shalo+1:ny,:,3) ! south 
       data(1:nx+ioff,              ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff,        1+joff:nhalo+joff,:,3) ! north
       data(nx+1+ioff:nx+ehalo+ioff,              1-shalo:0,:) = data_all(1+ioff:ehalo+ioff,    ny-shalo+1:ny,:,1) ! southeast
       data(1-whalo:0,                            1-shalo:0,:) = data_all(nx-whalo+1:nx,        ny-shalo+1:ny,:,2) ! southwest
       data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,1) ! northeast
       data(1-whalo:0,              ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx,    1+joff:nhalo+joff,:,2) ! northwest
    end select

  end subroutine fill_five_tile_halo

  !##############################################################################
  !--- The following is used to test the refined mosaic. Three cases will be tested, 
  !--- non-symmetric regular mosaic, symmetric regular mosaic cubic grid. The regular mosaic 
  !--- contains 4 tiles. East of tile 1 connected with West of tile 2 (refine = 3)
  !--- and vice verse; East of tile 3 connected with West of tile 4 (refine = 2)
  !--- and vice verse; North of tile 1 connected with South of tile 3 (refine = 2)
  !--- and vice verse; North of tile 2 connected with South of tile 4 (refine = 1)
  !--- and vice verse; So there ar total 8 contacts. 
  subroutine test_refined_mosaic(type)
    character(len=*), intent(in) :: type

    type(domain2D)                           :: domain
    integer,              dimension(4)       :: isMe1, ieMe1, jsMe1, jeMe1
    integer,              dimension(4)       :: isNb1, ieNb1, jsNb1, jeNb1
    integer,              dimension(4)       :: isMe2, ieMe2, jsMe2, jeMe2
    integer,              dimension(4)       :: isNb2, ieNb2, jsNb2, jeNb2
    integer,              dimension(4)       :: rotation1, rotation2, dirMe1, dirMe2
    integer, allocatable, dimension(:,:)     :: from_tile1, from_tile2
    integer                                  :: ntiles, num_contact, npes_on_tile
    integer                                  :: totpoints, maxtotal, pos, ntiles_on_pe
    integer                                  :: tNb, nimax, njmax, avgpoints
    integer                                  :: n, m, l, te, tse, ts, tsw, tw, tnw, tn, tne, nn
    integer                                  :: noverlap1, noverlap2, total1, total2
    integer                                  :: isc, iec, jsc, jec, isg, ieg, jsg, jeg
    integer                                  :: ism, iem, jsm, jem, isd, ied, jsd, jed
    integer, allocatable, dimension(:)       :: tiles, ni, nj
    integer, allocatable, dimension(:)       :: pe_start, pe_end, tile1, tile2
    integer, allocatable, dimension(:)       :: istart1, iend1, jstart1, jend1
    integer, allocatable, dimension(:)       :: istart2, iend2, jstart2, jend2
    integer, allocatable, dimension(:,:)     :: layout, global_indices
    real,    allocatable, dimension(:,:,:,:) :: global_all, global1, global2
    real,    allocatable, dimension(:,:,:,:) :: x, y, x1, y1, x2, y2
    real,    allocatable, dimension(:,:,:,:) :: global1_all, global2_all
    real,    allocatable, dimension(:,:)     :: buffer, buffer1, buffer2, bufferx, buffery
    real,    allocatable, dimension(:,:)     :: bufferx1, buffery1, bufferx2, buffery2
    integer                                  :: shift
    character(len=128)                       :: type2
    logical                                  :: found

    !--- check the type
    select case(type)
    case ("Refined-Four-Tile", "Refined-Symmetric-Four-Tile" )
       ntiles = 4
       allocate(ni(ntiles), nj(ntiles))
       ! "Four-Tile" test case will only run on one pe or multiple 0f 8 ( balanced).
       if( npes .NE. 1 .AND. npes .NE. 8 .AND. npes .NE. 16 .AND. npes .NE. 32) then
          call mpp_error(NOTE,'TEST_MPP_DOMAINS(test_refined_mosaic: ' // &
                  type// ' mosaic will not be tested because npes is not 1, 8, 16 or 32')
          return
       end if            
       ni(1) =   nx; nj(1) =   ny
       ni(2) =   nx; nj(2) = 3*ny
       ni(3) = 2*nx; nj(3) =   ny
       ni(4) =   nx; nj(4) = 2*ny
       num_contact = 8   
    case ("Refined-Cubic-Grid")
       ntiles = 6; num_contact = 12
       allocate(ni(ntiles), nj(ntiles))
       ! "Cubic-Grid" will be tested only when nx = ny
       if( nx /= ny ) then
           call mpp_error(NOTE,'TEST_MPP_DOMAINS(test_refined_mosaic: ' // &
           type//' will not be tested because nx is not equal to ny' )
           return
       end if
       ! "Cubic-Grid" test case will only run on one pe or multiple 0f 16 pes ( balanced).
       if( npes .NE. 1 .AND. mod(npes,16) .NE. 0) then
          call mpp_error(NOTE,'TEST_MPP_DOMAINS(test_refined_mosaic: ' // &
                  type//' will not be tested because npes is not 1 and can not be divided by 16')
          return
       end if
       ni(1) =   nx; nj(1) =   ny
       ni(2) = 2*nx; nj(2) = 3*ny
       ni(3) = 2*nx; nj(3) =   ny
       ni(4) =   nx; nj(4) = 3*ny
       ni(5) = 2*nx; nj(5) =   ny
       ni(6) =   nx; nj(6) = 2*ny
    case default
       call mpp_error(FATAL, 'TEST_MPP_DOMAINS(test_refined_mosaic): no such test: '//type)
    end select

    allocate(layout(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
    totpoints = sum(ni*nj)
    if(mod(totpoints, npes) .NE. 0) call mpp_error(FATAL,    &
        "TEST_MPP_DOMAINS(test_refined_mosaic): totpoints can not be divided by npes")
    avgpoints = totpoints/npes
    layout = 1
    pe_start = 0; pe_end = 0; pos = 0

    do n = 1, ntiles
       global_indices(:,n) = (/1, ni(n), 1, nj(n)/)
       if(npes > 1) then  ! no sharing processor between tiles
          if( mod(ni(n)*nj(n), avgpoints) .NE. 0) call mpp_error(FATAL, &
               'TEST_MPP_DOMAINS(test_refined_mosaic): number of points should be divided by average of points in each pe')
          npes_on_tile = ni(n)*nj(n)/avgpoints
          call mpp_define_layout( (/1,ni(n),1,nj(n)/), npes_on_tile, layout(:,n) )
          pe_start(n) = pos
          pe_end(n)   = pos + npes_on_tile - 1       
          pos         = pos + npes_on_tile
       end if
    end do

    ntiles_on_pe = 1
    if(npes == 1) then
       ntiles_on_pe = ntiles
       allocate(tiles(ntiles_on_pe))
       tiles = (/ (i, i=1,ntiles) /)
    else
       ntiles_on_pe = 1
       allocate(tiles(ntiles_on_pe))
       do n = 1, ntiles
          if( pe .GE. pe_start(n) .AND. pe .LE. pe_end(n) ) tiles = n
       end do
    end if

    allocate(tile1(num_contact), tile2(num_contact) )
    allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) ) 
    allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) ) 

    !--- define domain
    select case(type)
    case( 'Refined-Four-Tile', 'Refined-Symmetric-Four-Tile' )
       call define_fourtile_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end, &
                                   type == 'Refined-Symmetric-Four-Tile'   )
    case( 'Refined-Cubic-Grid' )
       call define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end )
    end select

    !--- first test mpp_get_mosaic_refine_overlap
    maxtotal = 0
    allocate(from_tile1(4, ntiles_on_pe), from_tile2(4, ntiles_on_pe))
    do n = 1, ntiles_on_pe
       rotation2 = ZERO
       noverlap1 = mpp_get_refine_overlap_number(domain, tile_count=n)
       call mpp_get_mosaic_refine_overlap(domain, isMe1, ieMe1, jsMe1, jeMe1, isNb1, ieNb1, jsNb1, jeNb1, &
                                          dirMe1, rotation1, tile_count = n)
       total1 = sum( (ieNb1(1:noverlap1)-isNb1(1:noverlap1)+1) * (jeNb1(1:noverlap1)-jsNb1(1:noverlap1)+1)  )

       !--- the following will figure out the overlapping
       call mpp_get_compute_domain(domain, isc, iec, jsc, jec, tile_count=n)
       call mpp_get_global_domain(domain, isg, ieg, jsg, jeg, tile_count=n)
       noverlap2 = 0; total2 = 0
       select case ( type )
       case ( 'Refined-Four-Tile', 'Refined-Symmetric-Four-Tile' )
          if( iec == ieg ) then   ! --- EAST
             noverlap2 = noverlap2 + 1
             if( mod(tiles(n),2) == 1) then ! tile 1, 3    
                tNb = tiles(n) + 1
             else                           ! tile 2, 4
                tNb = tiles(n) - 1
             endif
             from_tile2(noverlap2,n) = tNb
             dirMe2(noverlap2) = 1
             isMe2(noverlap2) = iec + 1;    ieMe2(noverlap2) = iec + ehalo
             jsMe2(noverlap2) = max(jsg,jsc - shalo); jeMe2(noverlap2) = min(jeg, jec+nhalo)
             isNb2(noverlap2) = 1;          ieNb2(noverlap2) = ehalo
             select case(tiles(n))
             case(1)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*3+1;  jeNb2(noverlap2) = jeMe2(noverlap2)*3
             case(2)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/3+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/3.)
             case(3)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*2+1;  jeNb2(noverlap2) = jeMe2(noverlap2)*2
             case(4)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/2+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/2.)
             end select
             total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
          end if

          if( jsc == jsg .AND. mod(tiles(n),2) == 1 ) then   ! --- SOUTH (only tile 1 and 3)
             noverlap2 = noverlap2 + 1
             tNb = mod(tiles(n)+2, ntiles)
             from_tile2(noverlap2,n) = tNb
             dirMe2(noverlap2) = 3
             isMe2(noverlap2) = max(isg,isc-whalo); ieMe2(noverlap2) = min(ieg, iec+ehalo)
             jsMe2(noverlap2) = jsc - shalo;        jeMe2(noverlap2) = jsc - 1
             if(tiles(n) == 1) then  ! refinement is 2
                isNb2(noverlap2) = (isMe2(noverlap2)-1)*2+1;    ieNb2(noverlap2) = ieMe2(noverlap2)*2
             else                   ! refinement is 2
                isNb2(noverlap2) = (isMe2(noverlap2)-1)/2+1;    ieNb2(noverlap2) = ceiling(ieMe2(noverlap2)/2.)
             end if
             jsNb2(noverlap2) = nj(tNb) - shalo + 1; jeNb2(noverlap2) = nj(tNb)
             total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
          end if

          if( isc == isg ) then   ! --- WEST
             noverlap2 = noverlap2 + 1
             if( mod(tiles(n),2) == 1) then ! tile 1, 3    
                tNb = tiles(n) + 1
             else                           ! tile 2, 4
                tNb = tiles(n) - 1
             endif
             from_tile2(noverlap2,n) = tNb
             dirMe2(noverlap2) = 5
             isMe2(noverlap2) = isc - whalo;          ieMe2(noverlap2) = isc - 1
             jsMe2(noverlap2) = max(jsg,jsc - shalo); jeMe2(noverlap2) = min(jeg, jec+nhalo)
             isNb2(noverlap2) = ni(tNb) - whalo + 1; ieNb2(noverlap2) = ni(tNb)
             select case(tiles(n))
             case(1)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*3+1;  jeNb2(noverlap2) = jeMe2(noverlap2)*3
             case(2)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/3+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/3.)
             case(3)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*2+1;  jeNb2(noverlap2) = jeMe2(noverlap2)*2
             case(4)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/2+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/2.)
             end select
             total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
          end if

          if( jec == jeg .AND. mod(tiles(n),2) == 1 ) then   ! --- NORTH (only tile 1 and 3)
             noverlap2 = noverlap2 + 1
             tNb = mod(tiles(n)+2, ntiles)
             from_tile2(noverlap2,n) = tNb
             dirMe2(noverlap2) = 7
             isMe2(noverlap2) = max(isg,isc-whalo); ieMe2(noverlap2) = min(ieg, iec+ehalo)
             jsMe2(noverlap2) = jec + 1;        jeMe2(noverlap2) = jec + nhalo
             if(tiles(n) == 1) then  ! refinement is 2
                isNb2(noverlap2) = (isMe2(noverlap2)-1)*2+1;    ieNb2(noverlap2) = ieMe2(noverlap2)*2
             else                   ! refinement is 2
                isNb2(noverlap2) = (isMe2(noverlap2)-1)/2+1;    ieNb2(noverlap2) = ceiling(ieMe2(noverlap2)/2.)
             end if
             jsNb2(noverlap2) = 1;          jeNb2(noverlap2) = nhalo
             total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
          end if

       case ( 'Refined-Cubic-Grid' )
          select case( tiles(n) )
          case ( 1 )  ! possible refined overlap will be at EAST, WEST
             if( iec == ieg ) then   ! --- EAST
                noverlap2 = noverlap2 + 1
                tNb = 2
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 1
                isMe2(noverlap2) = iec + 1;                  ieMe2(noverlap2) = iec + ehalo
                jsMe2(noverlap2) = max(jsg,jsc - shalo);     jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = 1;                        ieNb2(noverlap2) = ehalo
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*3+1; jeNb2(noverlap2) = jeMe2(noverlap2)*3
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
             end if
             if( isc == isg ) then   ! --- WEST
                noverlap2 = noverlap2 + 1
                tNb = 5
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 5
                isMe2(noverlap2) = isc - whalo;                  ieMe2(noverlap2) = isc - 1
                jsMe2(noverlap2) = max(jsg,jsc - shalo);         jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = (nj(1)-jeMe2(noverlap2))*2+1; ieNb2(noverlap2) = (nj(1)-jsMe2(noverlap2)+1)*2
                jsNb2(noverlap2) = nj(tNb) - whalo + 1;          jeNb2(noverlap2) = nj(tNb)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
                rotation2(noverlap2) = NINETY
             end if
          case ( 2 )  ! possible refined overlap will be at EAST, WEST
             if( iec == ieg ) then   ! --- EAST
                noverlap2 = noverlap2 + 1
                tNb = 4
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 1
                isMe2(noverlap2) = iec + 1;                      ieMe2(noverlap2) = iec + ehalo
                jsMe2(noverlap2) = max(jsg,jsc - shalo);         jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = (nj(2)-jeMe2(noverlap2))/3+1; ieNb2(noverlap2) = ceiling((nj(2)-jsMe2(noverlap2)+1)/3.)
                jsNb2(noverlap2) = 1;                            jeNb2(noverlap2) = ehalo
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
                rotation2(noverlap2) = NINETY       
             end if
             if( isc == isg ) then   ! --- WEST
                noverlap2 = noverlap2 + 1
                tNb = 1
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 5
                isMe2(noverlap2) = isc - whalo;              ieMe2(noverlap2) = isc - 1
                jsMe2(noverlap2) = max(jsg,jsc - shalo);     jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = ni(tNb) - whalo + 1;      ieNb2(noverlap2) = ni(tNb)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/3+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/3.)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
             end if
          case ( 3 )  ! possible refined overlap will be at EAST, NORTH          
             if( iec == ieg ) then   ! --- EAST
                noverlap2 = noverlap2 + 1
                tNb = 4
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 1
                isMe2(noverlap2) = iec + 1;                  ieMe2(noverlap2) = iec + ehalo
                jsMe2(noverlap2) = max(jsg,jsc - shalo);     jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = 1;                        ieNb2(noverlap2) = ehalo
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*3+1; jeNb2(noverlap2) = jeMe2(noverlap2)*3
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
             end if
             if( jec == jeg ) then   ! --- NORTH
                noverlap2 = noverlap2 + 1
                tNb = 5
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 7
                isMe2(noverlap2) = max(isg,isc - whalo);        ieMe2(noverlap2) = min(ieg, iec+ehalo)
                jsMe2(noverlap2) = jec + 1;                     jeMe2(noverlap2) = jec + nhalo
                isNb2(noverlap2) = 1;                           ieNb2(noverlap2) = nhalo
                jsNb2(noverlap2) = (ni(3)-ieMe2(noverlap2))/2+1; jeNb2(noverlap2) = ceiling((ni(3)-isMe2(noverlap2)+1)/2.)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
                rotation2(noverlap2) = MINUS_NINETY
             end if
          case ( 4 )  ! possible refined overlap will be at NORTH, EAST, SOUTH, WEST
             if( jec == jeg ) then   ! --- NORTH
                noverlap2 = noverlap2 + 1
                tNb = 5
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 7
                isMe2(noverlap2) = max(isg,isc - whalo);        ieMe2(noverlap2) = min(ieg, iec+ehalo)
                jsMe2(noverlap2) = jec + 1;                     jeMe2(noverlap2) = jec + nhalo
                isNb2(noverlap2) = (isMe2(noverlap2)-1)*2+1;    ieNb2(noverlap2) = ieMe2(noverlap2)*2
                jsNb2(noverlap2) = 1;                           jeNb2(noverlap2) = nhalo
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
             end if
             if( iec == ieg ) then   ! --- EAST
                noverlap2 = noverlap2 + 1
                tNb = 6
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 1
                isMe2(noverlap2) = iec + 1;                        ieMe2(noverlap2) = iec + ehalo
                jsMe2(noverlap2) = max(jsg,jsc - shalo);           jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = (nj(4)-jeMe2(noverlap2)-1)/3+1; ieNb2(noverlap2) = ceiling((nj(4)-jsMe2(noverlap2)+1)/3.)
                jsNb2(noverlap2) = 1;                              jeNb2(noverlap2) = ehalo
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
                rotation2(noverlap2) = NINETY
             end if
             if( jsc == jsg ) then   ! --- SOUTH
                noverlap2 = noverlap2 + 1
                tNb = 2
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 3
                isMe2(noverlap2) = max(isg,isc - whalo);        ieMe2(noverlap2) = min(ieg, iec+ehalo)
                jsMe2(noverlap2) = jsc - shalo;                 jeMe2(noverlap2) = jsc  - 1
                isNb2(noverlap2) = ni(tNb) - shalo + 1;         ieNb2(noverlap2) = ni(tNb)
                jsNb2(noverlap2) = (ni(4)-ieMe2(noverlap2))*3+1; jeNb2(noverlap2) = (ni(4)-isMe2(noverlap2)+1)*3
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
                rotation2(noverlap2) = MINUS_NINETY
             end if
             if( isc == isg ) then   ! --- WEST
                noverlap2 = noverlap2 + 1
                tNb = 3
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 5
                isMe2(noverlap2) = isc - whalo;              ieMe2(noverlap2) = isc - 1
                jsMe2(noverlap2) = max(jsg,jsc - shalo);     jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = ni(tNb) - whalo + 1;      ieNb2(noverlap2) = ni(tNb)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/3+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/3.)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
             end if

         case ( 5 )  ! possible refined overlap will be at EAST, NORTH, WEST, SOUTH       
             if( iec == ieg ) then   ! --- EAST
                noverlap2 = noverlap2 + 1
                tNb = 6
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 1
                isMe2(noverlap2) = iec + 1;                  ieMe2(noverlap2) = iec + ehalo
                jsMe2(noverlap2) = max(jsg,jsc - shalo);     jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = 1;                        ieNb2(noverlap2) = ehalo
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)*2+1; jeNb2(noverlap2) = jeMe2(noverlap2)*2
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
             end if
             if( jec == jeg ) then   ! --- NORTH
                noverlap2 = noverlap2 + 1
                tNb = 1
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 7
                isMe2(noverlap2) = max(isg,isc - whalo);         ieMe2(noverlap2) = min(ieg, iec+ehalo)
                jsMe2(noverlap2) = jec + 1;                      jeMe2(noverlap2) = jec + nhalo
                isNb2(noverlap2) = 1;                            ieNb2(noverlap2) = nhalo
                jsNb2(noverlap2) = (ni(5)-ieMe2(noverlap2))/2+1; jeNb2(noverlap2) = ceiling((ni(5)-isMe2(noverlap2)+1)/2.)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
                rotation2(noverlap2) = MINUS_NINETY 
             end if
             if( isc == isg ) then   ! --- WEST
                noverlap2 = noverlap2 + 1
                tNb = 3
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 5
                isMe2(noverlap2) = isc - whalo;                  ieMe2(noverlap2) = isc - 1
                jsMe2(noverlap2) = max(jsg,jsc - shalo);         jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = (nj(5)-jeMe2(noverlap2))*2+1; ieNb2(noverlap2) = (nj(5)-jsMe2(noverlap2)+1)*2
                jsNb2(noverlap2) = nj(tNb) - whalo + 1;          jeNb2(noverlap2) = nj(tNb)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
                rotation2(noverlap2) = NINETY
             end if
             if( jsc == jsg ) then   ! --- SOUTH
                noverlap2 = noverlap2 + 1
                tNb = 4
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 3
                isMe2(noverlap2) = max(isg,isc - whalo);        ieMe2(noverlap2) = min(ieg, iec+ehalo)
                jsMe2(noverlap2) = jsc - shalo;                 jeMe2(noverlap2) = jsc  - 1
                isNb2(noverlap2) = (isMe2(noverlap2)-1)/2+1;    ieNb2(noverlap2) = ceiling(ieMe2(noverlap2)/2.)
                jsNb2(noverlap2) = nj(tNb) - shalo + 1;         jeNb2(noverlap2) = nj(tNb)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
             end if


          case ( 6 )  ! possible refined overlap will be at SOUTH, WEST
             if( jsc == jsg ) then   ! --- SOUTH
                noverlap2 = noverlap2 + 1
                tNb = 4
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 3
                isMe2(noverlap2) = max(isg,isc - whalo);        ieMe2(noverlap2) = min(ieg, iec+ehalo)
                jsMe2(noverlap2) = jsc - shalo;                 jeMe2(noverlap2) = jsc  - 1
                isNb2(noverlap2) = ni(tNb) - shalo + 1;         ieNb2(noverlap2) = ni(tNb)
                jsNb2(noverlap2) = (ni(6)-ieMe2(noverlap2))*3+1; jeNb2(noverlap2) = (ni(6)-isMe2(noverlap2)+1)*3
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1) 
                rotation2(noverlap2) = MINUS_NINETY
             end if
             if( isc == isg ) then   ! --- WEST
                noverlap2 = noverlap2 + 1
                tNb = 5
                from_tile2(noverlap2,n) = tNb
                dirMe2(noverlap2) = 5
                isMe2(noverlap2) = isc - whalo;              ieMe2(noverlap2) = isc - 1
                jsMe2(noverlap2) = max(jsg,jsc - shalo);     jeMe2(noverlap2) = min(jeg, jec+nhalo)
                isNb2(noverlap2) = ni(tNb) - whalo + 1;      ieNb2(noverlap2) = ni(tNb)
                jsNb2(noverlap2) = (jsMe2(noverlap2)-1)/2+1; jeNb2(noverlap2) = ceiling(jeMe2(noverlap2)/2.)
                total2 = total2 + (ieNb2(noverlap2) - isNb2(noverlap2) + 1) * (jeNb2(noverlap2) - jsNb2(noverlap2) + 1)
             end if
          end select
       end select

       if(total1 .NE. total2) call mpp_error(FATAL, "test_mpp_domains: mismatch on total number of points")
       !--- we add one extra point in each direction for the consideration of symmetric domain.
       total2 = sum( (ieNb2(1:noverlap2) - isNb2(1:noverlap2) + 2) * (jeNb2(1:noverlap2) - jsNb2(1:noverlap2) + 2) )
       maxtotal = max(maxtotal, total2)
       !--- comparing
       if( noverlap1 .NE. noverlap2 ) call mpp_error(FATAL, "test_mpp_domains: mismatch on number of overlapping region")
       do m = 1, noverlap1
          found = .false.
          do l = 1, noverlap2
             if(dirMe1(m) == dirMe2(l)) then
                found = .true.
                exit
             endif
          enddo
          from_tile1(m,n) = from_tile2(l,n)
          if(.not. found) call mpp_error(FATAL, "test_mpp_domains: mismatch on direction")
          if( (isMe1(m) .NE. isMe2(l)) .OR. (ieMe1(m) .NE. ieMe2(l))        &
              .OR. (jsMe1(m) .NE. jsMe2(l)) .OR. (jeMe1(m) .NE. jeMe2(l)) ) &
              call mpp_error(FATAL, "test_mpp_domains: mismatch on myself overlapping index")
          if( (isNb1(m) .NE. isNb2(l)) .OR. (ieNb1(m) .NE. ieNb2(l))        &
              .OR. (jsNb1(m) .NE. jsNb2(l)) .OR. (jeNb1(m) .NE. jeNb2(l)) ) &
              call mpp_error(FATAL, "test_mpp_domains: mismatch on neighbor overlapping index") 
          if(rotation1(m) .NE. rotation2(l)) call mpp_error(FATAL, "test_mpp_domains: mismatch on rotation angle");
       end do
    end do

    !--- setup data
    nimax = maxval(ni); njmax = maxval(nj)
    allocate(global_all(1:nimax,1:njmax,nz,ntiles) )
    allocate(global2(1-whalo:nimax+ehalo,1-shalo:njmax+nhalo,nz, ntiles_on_pe) ) 
    global2 = 0
    do n = 1, ntiles
       do k = 1, nz
          do j = 1, njmax
             do i = 1, nimax
                global_all(i,j,k,n) = n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    do n = 1, ntiles_on_pe
       nn = tiles(n)
       global2(1:ni(nn),1:nj(nn),:,n) = global_all(1:ni(nn),1:nj(nn),:,nn)
    end do

    call mpp_get_memory_domain   ( domain, ism, iem, jsm, jem )
    allocate( x (ism:iem,jsm:jem,nz, ntiles_on_pe) )
    allocate( x1(ism:iem,jsm:jem,nz, ntiles_on_pe) )
    allocate( x2(ism:iem,jsm:jem,nz, ntiles_on_pe) )
    x = 0

    do n = 1, ntiles_on_pe
       call mpp_get_compute_domain( domain, isc, iec, jsc, jec, tile_count=n  )
       call mpp_get_data_domain   ( domain, isd, ied, jsd, jed, tile_count=n )
       x(isc:iec,jsc:jec,:,:) = global2(isc:iec,jsc:jec,:,:)
    end do
    x1 = x; x2 = x

    allocate(buffer (maxtotal*nz, ntiles_on_pe))
    allocate(buffer1(maxtotal*nz, ntiles_on_pe))
    allocate(buffer2(maxtotal*nz, ntiles_on_pe))

    !--- call mpp_update_domains to update domain 
    do n = 1, ntiles_on_pe
       call mpp_update_domains( x(:,:,:,n), domain, buffer=buffer(:,n), tile_count=n )
    end do

    !--- multiple varaibles update
    do n = 1, ntiles_on_pe
       call mpp_update_domains( x1(:,:,:,n), domain, buffer=buffer1(:,n), complete=.false., tile_count=n )
       call mpp_update_domains( x2(:,:,:,n), domain, buffer=buffer2(:,n), complete=.true., tile_count=n )
    end do

    !--- fill up the value at halo points and compare the value at buffer.
    do n = 1, ntiles_on_pe  

       !--- comparing the buffer.
       noverlap1 = mpp_get_refine_overlap_number(domain, tile_count=n)
       call mpp_get_mosaic_refine_overlap(domain, isMe1, ieMe1, jsMe1, jeMe1, isNb1, ieNb1, jsNb1, jeNb1, &
                                          dirMe1, rotation1, tile_count = n)             
       pos = 0
       do m = 1, noverlap1       
          do k = 1, nz
             do j = jsNb1(m), jeNb1(m)
                do i = isNb1(m), ieNb1(m)
                   pos = pos + 1
                   if(global_all(i,j,k,from_tile1(m,n)) .NE. buffer(pos,n) ) then
                      write(stdunit, 111) 'x', type, mpp_pe(), i, j, k, buffer(pos,n), global_all(i,j,k,from_tile1(m,n)) 
                      call mpp_error(FATAL, "test_refined_mosaic: mismatch between buffer data and actual data for "//type )
                   end if
                   if(global_all(i,j,k,from_tile1(m,n)) .NE. buffer1(pos,n) ) then
                      write(stdunit, 111) 'x1', type, mpp_pe(), i, j, k, buffer1(pos,n), global_all(i,j,k,from_tile1(m,n)) 
                      call mpp_error(FATAL, "test_refined_mosaic: mismatch between buffer data and actual data for "//type )
                   end if
                   if(global_all(i,j,k,from_tile1(m,n)) .NE. buffer2(pos,n) ) then
                      write(stdunit, 111) 'x2', type, mpp_pe(), i, j, k, buffer2(pos,n), global_all(i,j,k,from_tile1(m,n)) 
                      call mpp_error(FATAL, "test_refined_mosaic: mismatch between buffer data and actual data for "//type )
                   end if
                end do
             end do
          end do
       end do

       !--- fill the halo and compare
       select case(type)
       case('Refined-Four-Tile', 'Refined-Symmetric-Four-Tile')
          te = 0; ts = 0; tn = 0; tw = 0
          select case(tiles(n))       
          case(1)
             tsw = 4 
          case(2)
             tsw = 3; tn = 4; ts = 4
          case(3)
             tsw = 2
          case(4)
             tsw = 1; ts = 2; tn = 2
          end select
          tse = tsw; tnw = tsw; tne = tsw
          call fill_regular_refinement_halo( global2(:,:,:,n), global_all, ni, nj, tiles(n), &
                                             te, tse, ts, tsw, tw, tnw, tn, tne, 0, 0)
       case('Refined-Cubic-Grid')       
          call fill_cubicgrid_refined_halo(global2(:,:,:,n), global_all, global_all, ni, nj, tiles(n), 0, 0, 1, 1 )
       end select
       call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
       type2 = type
       if(ntiles_on_pe>1) write(type2, *)trim(type2), " at tile_count = ", tiles(n)
       call compare_checksums( x (isd:ied,jsd:jed,:,n), global2(isd:ied,jsd:jed,:,n), trim(type2)//' X' )
       call compare_checksums( x1(isd:ied,jsd:jed,:,n), global2(isd:ied,jsd:jed,:,n), trim(type2)//' X1' )
       call compare_checksums( x2(isd:ied,jsd:jed,:,n), global2(isd:ied,jsd:jed,:,n), trim(type2)//' X2' )
    end do  

    deallocate(global2, global_all, x, x1, x2)
    !------------------------------------------------------------------
    !              vector update : BGRID_NE, one extra point in each direction for cubic-grid
    !------------------------------------------------------------------
    !--- setup data
    shift = 0
    if( type == 'Refined-Symmetric-Four-Tile' .OR. type == 'Refined-Cubic-Grid' ) shift = 1

    nimax = maxval(ni) + shift; njmax = maxval(nj) + shift
    allocate(global1_all(1:nimax,1:njmax,nz,ntiles) )
    allocate(global2_all(1:nimax,1:njmax,nz,ntiles) )
    allocate(global1(1-whalo:nimax+ehalo,1-shalo:njmax+nhalo,nz, ntiles_on_pe) ) 
    allocate(global2(1-whalo:nimax+ehalo,1-shalo:njmax+nhalo,nz, ntiles_on_pe) ) 
    global1 = 0; global2 = 0
    do n = 1, ntiles
       do k = 1, nz
          do j = 1, njmax
             do i = 1, nimax
                global1_all(i,j,k,n) = 1.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
                global2_all(i,j,k,n) = 2.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    !--- make sure consistency on the no-refinement boundary  for symmetric domain.
    !--- For "Symmetric four tile" mosaic, north of tile 2 and 4 need to be filled.
    !--- For "Cubic-Grid", The following need to be filled: north of tile 1,
    !--- north of tile 2, east and north of tile 6. The velocity at the corner point will be 0.
    select case( type ) 
    case ( 'Refined-Symmetric-Four-Tile' ) 
       global1_all(1:ni(2)+1,nj(2)+1,:,2) = global1_all(1:ni(2)+1,1,:,4)
       global2_all(1:ni(2)+1,nj(2)+1,:,2) = global2_all(1:ni(2)+1,1,:,4)
       global1_all(1:ni(4)+1,nj(4)+1,:,4) = global1_all(1:ni(4)+1,1,:,2)
       global2_all(1:ni(4)+1,nj(4)+1,:,4) = global2_all(1:ni(4)+1,1,:,2)
    case ( 'Refined-Cubic-Grid' )
       global1_all(1:ni(1)+1,nj(1)+1,:,1) = -global2_all(1,nj(3)+1:1:-1,:,3) ! north
       global2_all(1:ni(1)+1,nj(1)+1,:,1) =  global1_all(1,nj(3)+1:1:-1,:,3) ! north
       global1_all(1:ni(2)+1,nj(2)+1,:,2) =  global1_all(1:ni(3)+1,1,   :,3) ! north
       global2_all(1:ni(2)+1,nj(2)+1,:,2) =  global2_all(1:ni(3)+1,1,   :,3) ! north
       global1_all(1:ni(6)+1,nj(6)+1,:,6) =  global1_all(1:ni(1)+1,1,   :,1) ! north
       global2_all(1:ni(6)+1,nj(6)+1,:,6) =  global2_all(1:ni(1)+1,1,   :,1) ! north
       global1_all(ni(6)+1,1:nj(6)+1,:,6) =  global2_all(ni(2)+1:1:-1,1,:,2)  ! east 
       global2_all(ni(6)+1,1:nj(6)+1,:,6) = -global1_all(ni(2)+1:1:-1,1,:,2)  ! east 
       do n = 1, ntiles
          global1_all(1,      1,:,n) = 0;  global1_all(1,      nj(n)+1,:,n) = 0;
          global1_all(ni(n)+1,1,:,n) = 0;  global1_all(ni(n)+1,nj(n)+1,:,n) = 0;
          global2_all(1,      1,:,n) = 0;  global2_all(1,      nj(n)+1,:,n) = 0;
          global2_all(ni(n)+1,1,:,n) = 0;  global2_all(ni(n)+1,nj(n)+1,:,n) = 0;
       end do
    end select

    do n = 1, ntiles_on_pe
       nn = tiles(n)
       global1(1:ni(nn)+shift,1:nj(nn)+shift,:,n) = global1_all(1:ni(nn)+shift,1:nj(nn)+shift,:,nn)
       global2(1:ni(nn)+shift,1:nj(nn)+shift,:,n) = global2_all(1:ni(nn)+shift,1:nj(nn)+shift,:,nn)
    end do

    call mpp_get_memory_domain   ( domain, ism, iem, jsm, jem )
    allocate( x  (ism:iem+shift,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( y  (ism:iem+shift,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( x1 (ism:iem+shift,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( y1 (ism:iem+shift,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( x2 (ism:iem+shift,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( y2 (ism:iem+shift,jsm:jem+shift,nz, ntiles_on_pe) )
    x = 0; y = 0

    do n = 1, ntiles_on_pe
       call mpp_get_compute_domain( domain, isc, iec, jsc, jec, tile_count=n )
       call mpp_get_data_domain   ( domain, isd, ied, jsd, jed, tile_count=n )
       x(isc:iec+shift,jsc:jec+shift,:,:) = global1(isc:iec+shift,jsc:jec+shift,:,:)
       y(isc:iec+shift,jsc:jec+shift,:,:) = global2(isc:iec+shift,jsc:jec+shift,:,:)
    end do
    x1 = x; x2 =x; y1 = y; y2 = y

    allocate(bufferx(maxtotal*nz, ntiles_on_pe),  buffery(maxtotal*nz, ntiles_on_pe) )
    allocate(bufferx1(maxtotal*nz, ntiles_on_pe), buffery1(maxtotal*nz, ntiles_on_pe) )
    allocate(bufferx2(maxtotal*nz, ntiles_on_pe), buffery2(maxtotal*nz, ntiles_on_pe) )

    !--- call mpp_update_domains to update domain 
    do n = 1, ntiles_on_pe
       call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=BGRID_NE, &
                                bufferx=bufferx(:,n), buffery=buffery(:,n), tile_count=n )
    end do

    !--- multiple update
    do n = 1, ntiles_on_pe
       call mpp_update_domains( x1(:,:,:,n), y1(:,:,:,n), domain, gridtype=BGRID_NE, &
                                bufferx=bufferx1(:,n), buffery=buffery1(:,n), complete=.false., tile_count=n )
       call mpp_update_domains( x2(:,:,:,n), y2(:,:,:,n), domain, gridtype=BGRID_NE, &
                                bufferx=bufferx2(:,n), buffery=buffery2(:,n), complete=.true., tile_count=n )
    end do

    !--- fill up the value at halo points and compare the value at buffer.
    do n = 1, ntiles_on_pe  
       !--- comparing the buffer.
       noverlap1 = mpp_get_refine_overlap_number(domain, tile_count=n, position = CORNER)
       call mpp_get_mosaic_refine_overlap(domain, isMe1, ieMe1, jsMe1, jeMe1, isNb1, ieNb1, jsNb1, jeNb1, &
               dirMe1, rotation1, tile_count = n, position = CORNER)             
       pos = 0

       do m = 1, noverlap1  
          select case( rotation1(m) )
          case (ZERO)     
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. bufferx(pos,n) ) then
                         write(stdunit,111)'x','BGRID '//type,mpp_pe(),i,j,k,bufferx(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. buffery(pos,n) ) then
                         write(stdunit,111)'y','BGRID '//type,mpp_pe(),i,j,k,buffery(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. bufferx1(pos,n) ) then
                         write(stdunit,111)'x1','BGRID '//type,mpp_pe(),i,j,k,bufferx1(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X1")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. buffery1(pos,n) ) then
                         write(stdunit,111)'y1','BGRID '//type,mpp_pe(),i,j,k,buffery1(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y1")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. bufferx2(pos,n) ) then
                         write(stdunit,111)'x2','BGRID '//type,mpp_pe(),i,j,k,bufferx2(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X2")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. buffery2(pos,n) ) then
                         write(stdunit,111)'y2','BGRID '//type,mpp_pe(),i,j,k,buffery2(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y2")
                      end if
                   end do
                end do
             end do
          case (NINETY) ! S->E, N->W, u->-v, v->u    
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx(pos,n) ) then
                         write(stdunit,111)'x','BGRID '//type,mpp_pe(),i,j,k,bufferx(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X")
                      end if
                      if(-global1_all(i,j,k,from_tile1(m,n)) .NE. buffery(pos,n) ) then
                         write(stdunit,111)'y','BGRID '//type,mpp_pe(),i,j,k,buffery(pos,n),-global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx1(pos,n) ) then
                         write(stdunit,111)'x1','BGRID '//type,mpp_pe(),i,j,k,bufferx1(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X1")
                      end if
                      if(-global1_all(i,j,k,from_tile1(m,n)) .NE. buffery1(pos,n) ) then
                         write(stdunit,111)'y1','BGRID '//type,mpp_pe(),i,j,k,buffery1(pos,n),-global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y1")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx2(pos,n) ) then
                         write(stdunit,111)'x2','BGRID '//type,mpp_pe(),i,j,k,bufferx2(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X2")
                      end if
                      if(-global1_all(i,j,k,from_tile1(m,n)) .NE. buffery2(pos,n) ) then
                         write(stdunit,111)'y2','BGRID '//type,mpp_pe(),i,j,k,buffery2(pos,n),-global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y2")
                      end if
                   end do
                end do
             end do
          case (MINUS_NINETY) ! S->E, N->W, u->-v, v->u    
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(-global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx(pos,n) ) then
                         write(stdunit,111)'x','BGRID '//type,mpp_pe(),i,j,k,bufferx(pos,n),-global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. buffery(pos,n) ) then
                         write(stdunit,111)'y','BGRID '//type,mpp_pe(),i,j,k,buffery(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y")
                      end if
                      if(-global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx1(pos,n) ) then
                         write(stdunit,111)'x1','BGRID '//type,mpp_pe(),i,j,k,bufferx1(pos,n),-global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X1")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. buffery1(pos,n) ) then
                         write(stdunit,111)'y1','BGRID '//type,mpp_pe(),i,j,k,buffery1(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y1")
                      end if
                      if(-global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx2(pos,n) ) then
                         write(stdunit,111)'x2','BGRID '//type,mpp_pe(),i,j,k,bufferx2(pos,n),-global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" X2")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. buffery2(pos,n) ) then
                         write(stdunit,111)'y2','BGRID '//type,mpp_pe(),i,j,k,buffery2(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: BGRID "//type//" Y2")
                      end if
                   end do
                end do
             end do
          end select
       end do

       !--- fill the halo data and compare
       select case(type)
       case('Refined-Four-Tile', 'Refined-Symmetric-Four-Tile')
          te = 0; ts = 0; tn = 0; tw = 0
          select case(tiles(n))       
          case(1)
             tsw = 4 
          case(2)
             tsw = 3; tn = 4; ts = 4
          case(3)
             tsw = 2
          case(4)
             tsw = 1; ts = 2; tn = 2
          end select
          tse = tsw; tnw = tsw; tne = tsw
          call fill_regular_refinement_halo( global1(:,:,:,n), global1_all, ni, nj, tiles(n), &
               te, tse, ts, tsw, tw, tnw, tn, tne, shift, shift )
          call fill_regular_refinement_halo( global2(:,:,:,n), global2_all, ni, nj, tiles(n), &
               te, tse, ts, tsw, tw, tnw, tn, tne, shift, shift )
       case('Refined-Cubic-Grid')       
          call fill_cubicgrid_refined_halo(global1(:,:,:,n), global1_all, global2_all, ni, nj, tiles(n), 1, 1, 1, -1 )
          call fill_cubicgrid_refined_halo(global2(:,:,:,n), global2_all, global1_all, ni, nj, tiles(n), 1, 1, -1, 1 )
       end select

       call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
       write(type2, *)"BGRID ", type
       if(ntiles_on_pe>1) write(type2, *)trim(type2), " at tile_count = ", tiles(n)
       call compare_checksums( x (isd:ied+shift,jsd:jed+shift,:,n), global1(isd:ied+shift,jsd:jed+shift,:,n), trim(type2)//' X' )
       call compare_checksums( x1(isd:ied+shift,jsd:jed+shift,:,n), global1(isd:ied+shift,jsd:jed+shift,:,n), trim(type2)//' X1')
       call compare_checksums( x2(isd:ied+shift,jsd:jed+shift,:,n), global1(isd:ied+shift,jsd:jed+shift,:,n), trim(type2)//' X2')
       write(type2, *)"BGRID ", type
       if(ntiles_on_pe>1) write(type2, *)trim(type2), " at tile_count = ", tiles(n)
       call compare_checksums( y (isd:ied+shift,jsd:jed+shift,:,n), global2(isd:ied+shift,jsd:jed+shift,:,n), trim(type2)//' Y' )
       call compare_checksums( y1(isd:ied+shift,jsd:jed+shift,:,n), global2(isd:ied+shift,jsd:jed+shift,:,n), trim(type2)//' Y1')
       call compare_checksums( y2(isd:ied+shift,jsd:jed+shift,:,n), global2(isd:ied+shift,jsd:jed+shift,:,n), trim(type2)//' Y2')
    end do  

    deallocate(global1_all, global2_all, global1, global2, x, y, x1, x2, y1, y2 )
    !------------------------------------------------------------------
    !              vector update : CGRID_NE, one extra point may needed to symmetric domain
    !------------------------------------------------------------------
    !--- setup data

    nimax = maxval(ni); njmax = maxval(nj)
    allocate(global1_all(1:nimax+shift,1:njmax,nz,ntiles) )
    allocate(global2_all(1:nimax,1:njmax+shift,nz,ntiles) )
    allocate(global1(1-whalo:nimax+ehalo+shift,1-shalo:njmax+nhalo,nz, ntiles_on_pe) ) 
    allocate(global2(1-whalo:nimax+ehalo,1-shalo:njmax+nhalo+shift,nz, ntiles_on_pe) ) 
    global1 = 0; global2 = 0
    do n = 1, ntiles
       do k = 1, nz
          do j = 1, njmax
             do i = 1, nimax + shift
                global1_all(i,j,k,n) = 1.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
          do j = 1, njmax + shift
             do i = 1, nimax
                global2_all(i,j,k,n) = 2.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    !--- make sure consistency on the no-refinement boundary  for symmetric domain.
    !--- For "Symmetric four tile" mosaic, north of tile 2 and 4 need to be filled.
    !--- For "Cubic-Grid", The following need to be filled: north of tile 1,
    !--- north of tile 2, east and north of tile 6. The velocity at the corner point will be 0.
    select case( type ) 
    case ('Refined-Symmetric-Four-Tile' ) 
       global2_all(1:ni(2),nj(2)+1,:,2) = global2_all(1:ni(2),1,:,4)
       global2_all(1:ni(4),nj(4)+1,:,4) = global2_all(1:ni(4),1,:,2)
    case ('Refined-Cubic-Grid' )
       global2_all(1:ni(1),nj(1)+1,:,1) =  global1_all(1,nj(3):1:-1,:,3) ! north
       global2_all(1:ni(2),nj(2)+1,:,2) =  global2_all(1:ni(3),1,   :,3) ! north
       global2_all(1:ni(6),nj(6)+1,:,6) =  global2_all(1:ni(1),1,   :,1) ! north
       global1_all(ni(6)+1,1:nj(6),:,6) =  global2_all(ni(2):1:-1,1,:,2)  ! east 
    end select

    do n = 1, ntiles_on_pe
       nn = tiles(n)
       global1(1:ni(nn)+shift,1:nj(nn),:,n) = global1_all(1:ni(nn)+shift,1:nj(nn),:,nn)
       global2(1:ni(nn),1:nj(nn)+shift,:,n) = global2_all(1:ni(nn),1:nj(nn)+shift,:,nn)
    end do

    call mpp_get_memory_domain   ( domain, ism, iem, jsm, jem )
    allocate( x  (ism:iem+shift,jsm:jem,nz, ntiles_on_pe) )
    allocate( y  (ism:iem,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( x1 (ism:iem+shift,jsm:jem,nz, ntiles_on_pe) )
    allocate( y1 (ism:iem,jsm:jem+shift,nz, ntiles_on_pe) )
    allocate( x2 (ism:iem+shift,jsm:jem,nz, ntiles_on_pe) )
    allocate( y2 (ism:iem,jsm:jem+shift,nz, ntiles_on_pe) )
    x = 0; y = 0
    bufferx  = 0; buffery = 0 
    bufferx1 = 0; buffery1 = 0
    bufferx2 = 0; buffery2 = 0
    do n = 1, ntiles_on_pe
       call mpp_get_compute_domain( domain, isc, iec, jsc, jec, tile_count=n )
       call mpp_get_data_domain   ( domain, isd, ied, jsd, jed, tile_count=n )
       x(isc:iec+shift,jsc:jec,:,:) = global1(isc:iec+shift,jsc:jec,:,:)
       y(isc:iec,jsc:jec+shift,:,:) = global2(isc:iec,jsc:jec+shift,:,:)
    end do
    x1 = x; x2 =x; y1 = y; y2 = y   

    !--- call mpp_update_domains to update domain 
    do n = 1, ntiles_on_pe
       call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=CGRID_NE, &
                                bufferx=bufferx(:,n), buffery=buffery(:,n), tile_count=n )
    end do

    !--- multiple update
    do n = 1, ntiles_on_pe
       call mpp_update_domains( x1(:,:,:,n), y1(:,:,:,n), domain, gridtype=CGRID_NE, &
                                bufferx=bufferx1(:,n), buffery=buffery1(:,n), complete=.false., tile_count=n )
       call mpp_update_domains( x2(:,:,:,n), y2(:,:,:,n), domain, gridtype=CGRID_NE, &
                                bufferx=bufferx2(:,n), buffery=buffery2(:,n), complete=.true., tile_count=n )
    end do

    !--- fill up the value at halo points and compare the value at buffer.
    do n = 1, ntiles_on_pe  

       !--- comparing the buffer.
       noverlap1 = mpp_get_refine_overlap_number(domain, tile_count=n)
       call mpp_get_mosaic_refine_overlap(domain, isMe1, ieMe1, jsMe1, jeMe1, isNb1, ieNb1, jsNb1, jeNb1, &
                                          dirMe1, rotation1, tile_count = n, position = EAST)             
       pos = 0
       do m = 1, noverlap1 
          select case( rotation1(m) )
          case (ZERO)     
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. bufferx(pos,n) ) then
                         write(stdunit,111)'x','CGRID '//type,mpp_pe(),i,j,k,bufferx(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. bufferx1(pos,n) ) then
                         write(stdunit,111)'x1','CGRID '//type,mpp_pe(),i,j,k,bufferx1(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X1")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. bufferx2(pos,n) ) then
                         write(stdunit,111)'x2','CGRID '//type,mpp_pe(),i,j,k,bufferx2(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X2")
                      end if
                   end do
                end do
             end do
          case (NINETY) ! S->E, N->W, u->-v, v->u    
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx(pos,n) ) then
                         write(stdunit,111)'x','CGRID '//type,mpp_pe(),i,j,k,bufferx(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx1(pos,n) ) then
                         write(stdunit,111)'x1','CGRID '//type,mpp_pe(),i,j,k,bufferx1(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X1")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx2(pos,n) ) then
                         write(stdunit,111)'x2','CGRID '//type,mpp_pe(),i,j,k,bufferx2(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X2")
                      end if
                   end do
                end do
             end do
          case (MINUS_NINETY) ! S->E, N->W, u->-v, v->u    
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(-global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx(pos,n) ) then
                         write(stdunit,111)'x','CGRID '//type,mpp_pe(),i,j,k,bufferx(pos,n),-global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X")
                      end if
                      if(-global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx1(pos,n) ) then
                         write(stdunit,111)'x1','CGRID '//type,mpp_pe(),i,j,k,bufferx1(pos,n),-global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X1")
                      end if
                      if(-global2_all(i,j,k,from_tile1(m,n)) .NE. bufferx2(pos,n) ) then
                         write(stdunit,111)'x2','CGRID '//type,mpp_pe(),i,j,k,bufferx2(pos,n),-global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" X2")
                      end if
                   end do
                end do
             end do
          end select
       end do

       call mpp_get_mosaic_refine_overlap(domain, isMe1, ieMe1, jsMe1, jeMe1, isNb1, ieNb1, jsNb1, jeNb1, &
            dirMe1, rotation1, tile_count = n, position = NORTH) 
       pos = 0
       do m = 1, noverlap1
          select case( rotation1(m) )
          case (ZERO)               
             do k = 1, nz  
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. buffery(pos,n) ) then
                         write(stdunit,111)'y','CGRID '//type,mpp_pe(),i,j,k,buffery(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. buffery1(pos,n) ) then
                         write(stdunit,111)'y1','CGRID '//type,mpp_pe(),i,j,k,buffery1(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y1")
                      end if
                      if(global2_all(i,j,k,from_tile1(m,n)) .NE. buffery2(pos,n) ) then
                         write(stdunit,111)'y2','CGRID '//type,mpp_pe(),i,j,k,buffery2(pos,n),global2_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y2")
                      end if
                   end do
                end do
             end do
          case (NINETY) ! S->E, N->W, u->-v, v->u    
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(-global1_all(i,j,k,from_tile1(m,n)) .NE. buffery(pos,n) ) then
                         write(stdunit,111)'y','CGRID '//type,mpp_pe(),i,j,k,buffery(pos,n),-global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y")
                      end if
                      if(-global1_all(i,j,k,from_tile1(m,n)) .NE. buffery1(pos,n) ) then
                         write(stdunit,111)'y1','CGRID '//type,mpp_pe(),i,j,k,buffery1(pos,n),-global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y1")
                      end if
                      if(-global1_all(i,j,k,from_tile1(m,n)) .NE. buffery2(pos,n) ) then
                         write(stdunit,111)'y2','CGRID '//type,mpp_pe(),i,j,k,buffery2(pos,n),-global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y2")
                      end if
                   end do
                end do
             end do
          case (MINUS_NINETY) ! S->E, N->W, u->-v, v->u    
             do k = 1, nz
                do j = jsNb1(m), jeNb1(m)
                   do i = isNb1(m), ieNb1(m)
                      pos = pos + 1
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. buffery(pos,n) ) then
                         write(stdunit,111)'y','CGRID '//type,mpp_pe(),i,j,k,buffery(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. buffery1(pos,n) ) then
                         write(stdunit,111)'y1','CGRID '//type,mpp_pe(),i,j,k,buffery1(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y1")
                      end if
                      if(global1_all(i,j,k,from_tile1(m,n)) .NE. buffery2(pos,n) ) then
                         write(stdunit,111)'y2','CGRID '//type,mpp_pe(),i,j,k,buffery2(pos,n),global1_all(i,j,k,from_tile1(m,n))
                         call mpp_error(FATAL,"test_refined_mosaic: mismatch between buffer and actual data: CGRID "//type//" Y2")
                      end if
                   end do
                end do
             end do
          end select
       end do
       !--- fill the halo data and compare
       select case(type)
       case('Refined-Four-Tile', 'Refined-Symmetric-Four-Tile')
          te = 0; ts = 0; tn = 0; tw = 0
          select case(tiles(n))       
          case(1)
             tsw = 4 
          case(2)
             tsw = 3; tn = 4; ts = 4
          case(3)
             tsw = 2
          case(4)
             tsw = 1; ts = 2; tn = 2
          end select
          tse = tsw; tnw = tsw; tne = tsw
          call fill_regular_refinement_halo( global1(:,:,:,n), global1_all, ni, nj, tiles(n), &
               te, tse, ts, tsw, tw, tnw, tn, tne, shift, 0 )
          call fill_regular_refinement_halo( global2(:,:,:,n), global2_all, ni, nj, tiles(n), &
               te, tse, ts, tsw, tw, tnw, tn, tne, 0, shift )
       case('Refined-Cubic-Grid')       
          call fill_cubicgrid_refined_halo(global1(:,:,:,n), global1_all, global2_all, ni, nj, tiles(n), 1, 0, 1, -1 )
          call fill_cubicgrid_refined_halo(global2(:,:,:,n), global2_all, global1_all, ni, nj, tiles(n), 0, 1, -1, 1 )
       end select

       call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
       write(type2, *)"CGRID ", type
       if(ntiles_on_pe>1) write(type2, *)trim(type2), " at tile_count = ", tiles(n)
       call compare_checksums( x (isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed,:,n), trim(type2)//' X' )
       call compare_checksums( x1(isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed,:,n), trim(type2)//' X1')
       call compare_checksums( x2(isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed,:,n), trim(type2)//' X2')
       write(type2, *)"CGRID ", type
       if(ntiles_on_pe>1) write(type2, *)trim(type2), " at tile_count = ", tiles(n)
       call compare_checksums( y (isd:ied,jsd:jed+shift,:,n), global2(isd:ied,jsd:jed+shift,:,n), trim(type2)//' Y' )
       call compare_checksums( y1(isd:ied,jsd:jed+shift,:,n), global2(isd:ied,jsd:jed+shift,:,n), trim(type2)//' Y1' )
       call compare_checksums( y2(isd:ied,jsd:jed+shift,:,n), global2(isd:ied,jsd:jed+shift,:,n), trim(type2)//' Y2' )
    end do  

  111 format('For variable ', a, ', type = ', a, ', at pe = ', i3, ', at neighbor point (',i3,',',i3,',',i3, &
             '), failed value = ', f14.9, ', but the value should be ', f14.9 )


  end subroutine test_refined_mosaic

  !#######################################################################################
  subroutine test_get_boundary(type)
     character(len=*), intent(in)  :: type

     type(domain2D)       :: domain
     integer              :: ntiles, num_contact, npes_per_tile, ntile_per_pe, layout(2)
     integer              :: n, l, isc, iec, jsc, jec, ism, iem, jsm, jem
     integer, allocatable, dimension(:)       :: tile, ni, nj, pe_start, pe_end
     integer, allocatable, dimension(:,:)     :: layout2D, global_indices
     real,    allocatable, dimension(:,:,:)   :: ebuffer,   sbuffer,   wbuffer,   nbuffer
     real,    allocatable, dimension(:,:,:)   :: ebuffer1,  sbuffer1,  wbuffer1,  nbuffer1
     real,    allocatable, dimension(:,:,:)   :: ebuffer2,  sbuffer2,  wbuffer2,  nbuffer2
     real,    allocatable, dimension(:,:,:)   :: ebound,    sbound,    wbound,    nbound
     real,    allocatable, dimension(:,:,:)   :: ebufferx,  sbufferx,  wbufferx,  nbufferx
     real,    allocatable, dimension(:,:,:)   :: ebufferx1, sbufferx1, wbufferx1, nbufferx1
     real,    allocatable, dimension(:,:,:)   :: ebufferx2, sbufferx2, wbufferx2, nbufferx2
     real,    allocatable, dimension(:,:,:)   :: eboundx,   sboundx,   wboundx,   nboundx
     real,    allocatable, dimension(:,:,:)   :: ebuffery,  sbuffery,  wbuffery,  nbuffery
     real,    allocatable, dimension(:,:,:)   :: ebuffery1, sbuffery1, wbuffery1, nbuffery1
     real,    allocatable, dimension(:,:,:)   :: ebuffery2, sbuffery2, wbuffery2, nbuffery2
     real,    allocatable, dimension(:,:,:)   :: eboundy,   sboundy,   wboundy,   nboundy
     real,    allocatable, dimension(:,:,:,:) :: global_all, global1_all, global2_all
     real,    allocatable, dimension(:,:,:,:) :: global, global1, global2
     real,    allocatable, dimension(:,:,:,:) :: x, x1, x2, y, y1, y2

     !--- check the type
    select case(type)     
    case ( 'Four-Tile' ) !--- cyclic along both x- and y-direction. 
       ntiles = 4
       num_contact = 8
    case ( 'Cubic-Grid' )
       ntiles = 6
       num_contact = 12
       if( nx .NE. ny) then
          call mpp_error(NOTE,'TEST_MPP_DOMAINS: for Cubic_grid mosaic, nx should equal ny, '//&
                   'No test is done for Cubic-Grid mosaic. ' )
          return
       end if
    case default
       call mpp_error(FATAL, 'TEST_MPP_DOMAINS: no such test: '//type)
    end select

    allocate(layout2D(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
    allocate(ni(ntiles), nj(ntiles))
    ni(:) = nx; nj(:) = ny
    if( mod(npes, ntiles) == 0 ) then
       npes_per_tile = npes/ntiles
       write(stdout(),*)'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
                       '", each tile will be distributed over ', npes_per_tile, ' processors.'
       ntile_per_pe = 1
       allocate(tile(ntile_per_pe))
       tile = pe/npes_per_tile+1
       call mpp_define_layout( (/1,nx,1,ny/), npes_per_tile, layout )
       do n = 1, ntiles
          pe_start(n) = (n-1)*npes_per_tile
          pe_end(n)   = n*npes_per_tile-1
       end do
    else if ( mod(ntiles, npes) == 0 ) then
       ntile_per_pe = ntiles/npes 
       write(stdout(),*)'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
                        '", there will be ', ntile_per_pe, ' tiles on each processor.'
       allocate(tile(ntile_per_pe))
       do n = 1, ntile_per_pe
          tile(n) = pe*ntile_per_pe + n
       end do
       do n = 1, ntiles
          pe_start(n) = (n-1)/ntile_per_pe
          pe_end(n)   = pe_start(n)
       end do
       layout = 1
    else
       call mpp_error(NOTE,'TEST_MPP_DOMAINS: npes should be multiple of ntiles or ' // &
            'ntiles should be multiple of npes. No test is done for '//trim(type) )       
       return
    end if
 
    do n = 1, ntiles
       global_indices(:,n) = (/1,nx,1,ny/)
       layout2D(:,n)         = layout
    end do

     select case(type)
     case("Four-Tile")
        call define_fourtile_mosaic(type, domain, (/nx,nx,nx,nx/), (/ny,ny,ny,ny/), global_indices, &
                                    layout2D, pe_start, pe_end, .true. )  
     case("Cubic-Grid")
        call define_cubic_mosaic(type, domain, ni, nj, global_indices, layout2D, pe_start, pe_end )
     end select

    !--- Test the get_boundary of the data at C-cell center. 
    allocate(global_all(1:nx+1,1:ny+1,nz, ntiles) ) 
    allocate(global(1:nx+1,1:ny+1,nz, ntile_per_pe) )      
    global = 0
    do l = 1, ntiles
       do k = 1, nz
          do j = 1, ny+1
             do i = 1, nx+1
                global_all(i,j,k,l) = l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    do n = 1, ntile_per_pe
       global(:,:,:,n) = global_all(:,:,:,tile(n))
    end do

    call mpp_get_compute_domain( domain, isc, iec, jsc, jec )
    call mpp_get_memory_domain   ( domain, ism, iem, jsm, jem )
    allocate( x (ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( x1(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( x2(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    x = 0.
    x(isc:iec+1,jsc:jec+1,:,:) = global(isc:iec+1,jsc:jec+1,:,:)
    x1 = x; x2 = x*10

    !--- buffer allocation
    allocate(ebuffer(jec-jsc+2, nz, ntile_per_pe), wbuffer(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffer(iec-isc+2, nz, ntile_per_pe), nbuffer(iec-isc+2, nz, ntile_per_pe))
    allocate(ebuffer1(jec-jsc+2, nz, ntile_per_pe), wbuffer1(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffer1(iec-isc+2, nz, ntile_per_pe), nbuffer1(iec-isc+2, nz, ntile_per_pe))
    allocate(ebuffer2(jec-jsc+2, nz, ntile_per_pe), wbuffer2(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffer2(iec-isc+2, nz, ntile_per_pe), nbuffer2(iec-isc+2, nz, ntile_per_pe))
    allocate(ebound(jec-jsc+2, nz, ntile_per_pe), wbound(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbound(iec-isc+2, nz, ntile_per_pe), nbound(iec-isc+2, nz, ntile_per_pe))
    do n = 1, ntile_per_pe 
       call mpp_get_boundary(x(:,:,:,n), domain, ebuffer=ebuffer(:,:,n), sbuffer=sbuffer(:,:,n), wbuffer=wbuffer(:,:,n), &
                             nbuffer=nbuffer(:,:,n), position=CORNER, tile_count=n  )
    end do

    !--- multiple variable 
    do n = 1, ntile_per_pe 
       call mpp_get_boundary(x1(:,:,:,n), domain, ebuffer=ebuffer1(:,:,n), sbuffer=sbuffer1(:,:,n), wbuffer=wbuffer1(:,:,n), &
                             nbuffer=nbuffer1(:,:,n), position=CORNER, tile_count=n, complete = .false.  )
       call mpp_get_boundary(x2(:,:,:,n), domain, ebuffer=ebuffer2(:,:,n), sbuffer=sbuffer2(:,:,n), wbuffer=wbuffer2(:,:,n), &
                             nbuffer=nbuffer2(:,:,n), position=CORNER, tile_count=n, complete = .true.  )
    end do    

    !--- compare the buffer.
    select case(type)
    case("Four-Tile")
       do n = 1, ntile_per_pe
          call fill_four_tile_bound(global_all, isc, iec, jsc, jec, 1, 1, &
               tile(n), ebound(:,:,n), sbound(:,:,n), wbound(:,:,n), nbound(:,:,n) )  
       end do
    case("Cubic-Grid")
       do n = 1, ntile_per_pe
          call fill_cubic_grid_bound(global_all, global_all, isc, iec, jsc, jec, 1, 1, &
               tile(n), 1, 1, ebound(:,:,n), sbound(:,:,n), wbound(:,:,n), nbound(:,:,n) )  
       end do
    end select

    call compare_checksums( ebound, ebuffer(:,:,:),  "east bound of "//trim(type) )
    call compare_checksums( sbound, sbuffer(:,:,:),  "south bound of "//trim(type) )
    call compare_checksums( wbound, wbuffer(:,:,:),  "west bound of "//trim(type) )
    call compare_checksums( nbound, nbuffer(:,:,:),  "north bound of "//trim(type) )
    call compare_checksums( ebound, ebuffer1(:,:,:),  "east bound of "//trim(type)//" X1" )
    call compare_checksums( sbound, sbuffer1(:,:,:),  "south bound of "//trim(type)//" X1" )
    call compare_checksums( wbound, wbuffer1(:,:,:),  "west bound of "//trim(type)//" X1" )
    call compare_checksums( nbound, nbuffer1(:,:,:),  "north bound of "//trim(type)//" X1" )
    call compare_checksums( ebound*10, ebuffer2(:,:,:),  "east bound of "//trim(type)//" X2" )
    call compare_checksums( sbound*10, sbuffer2(:,:,:),  "south bound of "//trim(type)//" X2" )
    call compare_checksums( wbound*10, wbuffer2(:,:,:),  "west bound of "//trim(type)//" X2" )
    call compare_checksums( nbound*10, nbuffer2(:,:,:),  "north bound of "//trim(type)//" X2" )

    !--- release memory
    deallocate(global, global_all, x, x1, x2)
    deallocate(ebuffer, sbuffer, wbuffer, nbuffer)
    deallocate(ebuffer1, sbuffer1, wbuffer1, nbuffer1)
    deallocate(ebuffer2, sbuffer2, wbuffer2, nbuffer2)
    deallocate(ebound, sbound, wbound, nbound )

    !-------------------------------------------------------------------------------------------
    !
    !             Test SCALAR_PAIR BGRID
    !
    !-------------------------------------------------------------------------------------------
    allocate(global1_all(1:nx+1,1:ny+1,nz, ntiles) ) 
    allocate(global2_all(1:nx+1,1:ny+1,nz, ntiles) ) 
    allocate(global1(1:nx+1,1:ny+1,nz, ntile_per_pe) )   
    allocate(global2(1:nx+1,1:ny+1,nz, ntile_per_pe) )      
    do l = 1, ntiles
       do k = 1, nz
          do j = 1, ny+1
             do i = 1, nx+1
                global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
                global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    do n = 1, ntile_per_pe
       global1(:,:,:,n) = global1_all(:,:,:,tile(n))
       global2(:,:,:,n) = global2_all(:,:,:,tile(n))
    end do
    allocate( x (ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( x1(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( x2(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( y (ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( y1(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    allocate( y2(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
    x = 0.; y = 0
    x(isc:iec+1,jsc:jec+1,:,:) = global1(isc:iec+1,jsc:jec+1,:,:)
    y(isc:iec+1,jsc:jec+1,:,:) = global2(isc:iec+1,jsc:jec+1,:,:)
    x1 = x; x2 = x*10
    y1 = y; y2 = y*10

    !--- buffer allocation
    allocate(ebufferx(jec-jsc+2, nz, ntile_per_pe), wbufferx(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbufferx(iec-isc+2, nz, ntile_per_pe), nbufferx(iec-isc+2, nz, ntile_per_pe))
    allocate(ebufferx1(jec-jsc+2, nz, ntile_per_pe), wbufferx1(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbufferx1(iec-isc+2, nz, ntile_per_pe), nbufferx1(iec-isc+2, nz, ntile_per_pe))
    allocate(ebufferx2(jec-jsc+2, nz, ntile_per_pe), wbufferx2(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbufferx2(iec-isc+2, nz, ntile_per_pe), nbufferx2(iec-isc+2, nz, ntile_per_pe))
    allocate(eboundx(jec-jsc+2, nz, ntile_per_pe), wboundx(jec-jsc+2, nz, ntile_per_pe))
    allocate(sboundx(iec-isc+2, nz, ntile_per_pe), nboundx(iec-isc+2, nz, ntile_per_pe))
    allocate(ebuffery(jec-jsc+2, nz, ntile_per_pe), wbuffery(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffery(iec-isc+2, nz, ntile_per_pe), nbuffery(iec-isc+2, nz, ntile_per_pe))
    allocate(ebuffery1(jec-jsc+2, nz, ntile_per_pe), wbuffery1(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffery1(iec-isc+2, nz, ntile_per_pe), nbuffery1(iec-isc+2, nz, ntile_per_pe))
    allocate(ebuffery2(jec-jsc+2, nz, ntile_per_pe), wbuffery2(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffery2(iec-isc+2, nz, ntile_per_pe), nbuffery2(iec-isc+2, nz, ntile_per_pe))
    allocate(eboundy(jec-jsc+2, nz, ntile_per_pe), wboundy(jec-jsc+2, nz, ntile_per_pe))
    allocate(sboundy(iec-isc+2, nz, ntile_per_pe), nboundy(iec-isc+2, nz, ntile_per_pe))

    do n = 1, ntile_per_pe 
       call mpp_get_boundary(x(:,:,:,n), y(:,:,:,n), domain, ebufferx=ebufferx(:,:,n), sbufferx=sbufferx(:,:,n), &
                             wbufferx=wbufferx(:,:,n), nbufferx=nbufferx(:,:,n), ebuffery=ebuffery(:,:,n),       &
                             sbuffery=sbuffery(:,:,n), wbuffery=wbuffery(:,:,n), nbuffery=nbuffery(:,:,n),       &
                             gridtype=BGRID_NE, tile_count=n, flags = SCALAR_PAIR  )
    end do

    do n = 1, ntile_per_pe 
       call mpp_get_boundary(x1(:,:,:,n), y1(:,:,:,n), domain, ebufferx=ebufferx1(:,:,n), sbufferx=sbufferx1(:,:,n), &
                             wbufferx=wbufferx1(:,:,n), nbufferx=nbufferx1(:,:,n), ebuffery=ebuffery1(:,:,n),       &
                             sbuffery=sbuffery1(:,:,n), wbuffery=wbuffery1(:,:,n), nbuffery=nbuffery1(:,:,n),       &
                             gridtype=BGRID_NE, tile_count=n, flags = SCALAR_PAIR, complete = .false.  )
       call mpp_get_boundary(x2(:,:,:,n), y2(:,:,:,n), domain, ebufferx=ebufferx2(:,:,n), sbufferx=sbufferx2(:,:,n), &
                             wbufferx=wbufferx2(:,:,n), nbufferx=nbufferx2(:,:,n), ebuffery=ebuffery2(:,:,n),       &
                             sbuffery=sbuffery2(:,:,n), wbuffery=wbuffery2(:,:,n), nbuffery=nbuffery2(:,:,n),       &
                             gridtype=BGRID_NE, tile_count=n, flags = SCALAR_PAIR, complete = .true.  )
    end do

    !--- compare the buffer.
    select case(type)
    case("Four-Tile")
       do n = 1, ntile_per_pe
          call fill_four_tile_bound(global1_all, isc, iec, jsc, jec, 1, 1, &
               tile(n), eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )  
          call fill_four_tile_bound(global2_all, isc, iec, jsc, jec, 1, 1, &
               tile(n), eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )  
       end do
    case("Cubic-Grid")
       do n = 1, ntile_per_pe
          call fill_cubic_grid_bound(global1_all, global2_all, isc, iec, jsc, jec, 1, 1, &
               tile(n), 1, 1, eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )  
          call fill_cubic_grid_bound(global2_all, global1_all, isc, iec, jsc, jec, 1, 1, &
               tile(n), 1, 1, eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )  
       end do
    end select

    call compare_checksums( eboundx, ebufferx(:,:,:),   "east bound of SCALAR_PAIR BGRID " //trim(type)//" X" )
    call compare_checksums( sboundx, sbufferx(:,:,:),   "south bound of SCALAR_PAIR BGRID "//trim(type)//" X" )
    call compare_checksums( wboundx, wbufferx(:,:,:),   "west bound of SCALAR_PAIR BGRID " //trim(type)//" X" )
    call compare_checksums( nboundx, nbufferx(:,:,:),   "north bound of SCALAR_PAIR BGRID "//trim(type)//" X" )
    call compare_checksums( eboundy, ebuffery(:,:,:),   "east bound of SCALAR_PAIR BGRID " //trim(type)//" Y" )
    call compare_checksums( sboundy, sbuffery(:,:,:),   "south bound of SCALAR_PAIR BGRID "//trim(type)//" Y" )
    call compare_checksums( wboundy, wbuffery(:,:,:),   "west bound of SCALAR_PAIR BGRID " //trim(type)//" Y" )
    call compare_checksums( nboundy, nbuffery(:,:,:),   "north bound of SCALAR_PAIR BGRID "//trim(type)//" Y" )
    call compare_checksums( eboundx, ebufferx1(:,:,:),  "east bound of SCALAR_PAIR BGRID " //trim(type)//" X1" )
    call compare_checksums( sboundx, sbufferx1(:,:,:),  "south bound of SCALAR_PAIR BGRID "//trim(type)//" X1" )
    call compare_checksums( wboundx, wbufferx1(:,:,:),  "west bound of SCALAR_PAIR BGRID " //trim(type)//" X1" )
    call compare_checksums( nboundx, nbufferx1(:,:,:),  "north bound of SCALAR_PAIR BGRID "//trim(type)//" X1" )
    call compare_checksums( eboundy, ebuffery1(:,:,:),  "east bound of SCALAR_PAIR BGRID " //trim(type)//" Y1" )
    call compare_checksums( sboundy, sbuffery1(:,:,:),  "south bound of SCALAR_PAIR BGRID "//trim(type)//" Y1" )
    call compare_checksums( wboundy, wbuffery1(:,:,:),  "west bound of SCALAR_PAIR BGRID " //trim(type)//" Y1" )
    call compare_checksums( nboundy, nbuffery1(:,:,:),  "north bound of SCALAR_PAIR BGRID "//trim(type)//" Y1" )

    select case(type)
    case("Four-Tile")
       do n = 1, ntile_per_pe
          call fill_four_tile_bound(global1_all*10, isc, iec, jsc, jec, 1, 1, &
               tile(n), eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )  
          call fill_four_tile_bound(global2_all*10, isc, iec, jsc, jec, 1, 1, &
               tile(n), eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )  
       end do
    case("Cubic-Grid")
       do n = 1, ntile_per_pe
          call fill_cubic_grid_bound(global1_all*10, global2_all*10, isc, iec, jsc, jec, 1, 1, &
               tile(n), 1, 1, eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )  
          call fill_cubic_grid_bound(global2_all*10, global1_all*10, isc, iec, jsc, jec, 1, 1, &
               tile(n), 1, 1, eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )  
       end do
    end select

    call compare_checksums( eboundx, ebufferx2(:,:,:),  "east bound of SCALAR_PAIR BGRID " //trim(type)//" X2" )
    call compare_checksums( sboundx, sbufferx2(:,:,:),  "south bound of SCALAR_PAIR BGRID "//trim(type)//" X2" )
    call compare_checksums( wboundx, wbufferx2(:,:,:),  "west bound of SCALAR_PAIR BGRID " //trim(type)//" X2" )
    call compare_checksums( nboundx, nbufferx2(:,:,:),  "north bound of SCALAR_PAIR BGRID "//trim(type)//" X2" )
    call compare_checksums( eboundy, ebuffery2(:,:,:),  "east bound of SCALAR_PAIR BGRID " //trim(type)//" Y2" )
    call compare_checksums( sboundy, sbuffery2(:,:,:),  "south bound of SCALAR_PAIR BGRID "//trim(type)//" Y2" )
    call compare_checksums( wboundy, wbuffery2(:,:,:),  "west bound of SCALAR_PAIR BGRID " //trim(type)//" Y2" )
    call compare_checksums( nboundy, nbuffery2(:,:,:),  "north bound of SCALAR_PAIR BGRID "//trim(type)//" Y2" )

    !--- release memory
    deallocate(global1, global1_all, global2, global2_all)
    deallocate(x, y, x1, y1, x2, y2)
    deallocate(ebufferx, sbufferx, wbufferx, nbufferx)
    deallocate(ebufferx1, sbufferx1, wbufferx1, nbufferx1)
    deallocate(ebufferx2, sbufferx2, wbufferx2, nbufferx2)
    deallocate(ebuffery, sbuffery, wbuffery, nbuffery)
    deallocate(ebuffery1, sbuffery1, wbuffery1, nbuffery1)
    deallocate(ebuffery2, sbuffery2, wbuffery2, nbuffery2)
    deallocate(eboundx, sboundx, wboundx, nboundx )    
    deallocate(eboundy, sboundy, wboundy, nboundy )  

    !-------------------------------------------------------------------------------------------
    !
    !             Test VECTOR CGRID
    !
    !-------------------------------------------------------------------------------------------
    allocate(global1_all(1:nx+1,1:ny,  nz, ntiles) ) 
    allocate(global2_all(1:nx,  1:ny+1,nz, ntiles) ) 
    allocate(global1(1:nx+1,1:ny,  nz, ntile_per_pe) )   
    allocate(global2(1:nx,  1:ny+1,nz, ntile_per_pe) )      
    do l = 1, ntiles
       do k = 1, nz
          do j = 1, ny
             do i = 1, nx+1
                global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
          do j = 1, ny+1
             do i = 1, nx
                global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
             end do
          end do
       end do
    end do

    do n = 1, ntile_per_pe
       global1(:,:,:,n) = global1_all(:,:,:,tile(n))
       global2(:,:,:,n) = global2_all(:,:,:,tile(n))
    end do
    allocate( x (ism:iem+1,jsm:jem,  nz, ntile_per_pe) )
    allocate( x1(ism:iem+1,jsm:jem,  nz, ntile_per_pe) )
    allocate( x2(ism:iem+1,jsm:jem,  nz, ntile_per_pe) )
    allocate( y (ism:iem,  jsm:jem+1,nz, ntile_per_pe) )
    allocate( y1(ism:iem,  jsm:jem+1,nz, ntile_per_pe) )
    allocate( y2(ism:iem,  jsm:jem+1,nz, ntile_per_pe) )
    x = 0.; y = 0
    x(isc:iec+1,jsc:jec,  :,:) = global1(isc:iec+1,jsc:jec,  :,:)
    y(isc:iec,  jsc:jec+1,:,:) = global2(isc:iec,  jsc:jec+1,:,:)
    x1 = x; x2 = x*10
    y1 = y; y2 = y*10

    !--- buffer allocation
    allocate(ebufferx(jec-jsc+1, nz, ntile_per_pe), wbufferx(jec-jsc+1, nz, ntile_per_pe))
    allocate(sbufferx(iec-isc+2, nz, ntile_per_pe), nbufferx(iec-isc+2, nz, ntile_per_pe))
    allocate(ebufferx1(jec-jsc+1, nz, ntile_per_pe), wbufferx1(jec-jsc+1, nz, ntile_per_pe))
    allocate(sbufferx1(iec-isc+2, nz, ntile_per_pe), nbufferx1(iec-isc+2, nz, ntile_per_pe))
    allocate(ebufferx2(jec-jsc+1, nz, ntile_per_pe), wbufferx2(jec-jsc+1, nz, ntile_per_pe))
    allocate(sbufferx2(iec-isc+2, nz, ntile_per_pe), nbufferx2(iec-isc+2, nz, ntile_per_pe))
    allocate(ebuffery(jec-jsc+2, nz, ntile_per_pe), wbuffery(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffery(iec-isc+1, nz, ntile_per_pe), nbuffery(iec-isc+1, nz, ntile_per_pe))
    allocate(ebuffery1(jec-jsc+2, nz, ntile_per_pe), wbuffery1(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffery1(iec-isc+1, nz, ntile_per_pe), nbuffery1(iec-isc+1, nz, ntile_per_pe))
    allocate(ebuffery2(jec-jsc+2, nz, ntile_per_pe), wbuffery2(jec-jsc+2, nz, ntile_per_pe))
    allocate(sbuffery2(iec-isc+1, nz, ntile_per_pe), nbuffery2(iec-isc+1, nz, ntile_per_pe))
    allocate(eboundx(jec-jsc+1, nz, ntile_per_pe), wboundx(jec-jsc+1, nz, ntile_per_pe))
    allocate(sboundy(iec-isc+1, nz, ntile_per_pe), nboundy(iec-isc+1, nz, ntile_per_pe))

    do n = 1, ntile_per_pe 
       call mpp_get_boundary(x(:,:,:,n), y(:,:,:,n), domain, ebufferx=ebufferx(:,:,n), wbufferx=wbufferx(:,:,n), &
                             sbuffery=sbuffery(:,:,n), nbuffery=nbuffery(:,:,n), gridtype=CGRID_NE, tile_count=n  )
    end do

    do n = 1, ntile_per_pe 
       call mpp_get_boundary(x1(:,:,:,n), y1(:,:,:,n), domain, ebufferx=ebufferx1(:,:,n), wbufferx=wbufferx1(:,:,n), &
                             sbuffery=sbuffery1(:,:,n), nbuffery=nbuffery1(:,:,n), gridtype=CGRID_NE, tile_count=n,  &
                             complete = .false.  )
       call mpp_get_boundary(x2(:,:,:,n), y2(:,:,:,n), domain, ebufferx=ebufferx2(:,:,n), wbufferx=wbufferx2(:,:,n), &
                             sbuffery=sbuffery2(:,:,n), nbuffery=nbuffery2(:,:,n), gridtype=CGRID_NE, tile_count=n,  &
                             complete = .true.  )
    end do

    !--- compare the buffer.
    select case(type)
    case("Four-Tile")
       do n = 1, ntile_per_pe
          call fill_four_tile_bound(global1_all, isc, iec, jsc, jec, 1, 0, &
               tile(n), ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )  
          call fill_four_tile_bound(global2_all, isc, iec, jsc, jec, 0, 1, &
               tile(n), sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )  
       end do
    case("Cubic-Grid")
       do n = 1, ntile_per_pe
          call fill_cubic_grid_bound(global1_all, global2_all, isc, iec, jsc, jec, 1, 0, &
               tile(n), 1, -1, ebound=eboundx(:,:,n), wbound=wboundx(:,:,n)  )  
          call fill_cubic_grid_bound(global2_all, global1_all, isc, iec, jsc, jec, 0, 1, &
               tile(n), -1, 1, sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )  
       end do
    end select

    call compare_checksums( eboundx, ebufferx(:,:,:),   "east bound of CGRID " //trim(type)//" X" )
    call compare_checksums( wboundx, wbufferx(:,:,:),   "west bound of CGRID " //trim(type)//" X" )
    call compare_checksums( sboundy, sbuffery(:,:,:),   "south bound of CGRID "//trim(type)//" Y" )
    call compare_checksums( nboundy, nbuffery(:,:,:),   "north bound of CGRID "//trim(type)//" Y" )
    call compare_checksums( eboundx, ebufferx1(:,:,:),  "east bound of CGRID " //trim(type)//" X1" )
    call compare_checksums( wboundx, wbufferx1(:,:,:),  "west bound of CGRID " //trim(type)//" X1" )
    call compare_checksums( sboundy, sbuffery1(:,:,:),  "south bound of CGRID "//trim(type)//" Y1" )
    call compare_checksums( nboundy, nbuffery1(:,:,:),  "north bound of CGRID "//trim(type)//" Y1" )

    select case(type)
    case("Four-Tile")
       do n = 1, ntile_per_pe
          call fill_four_tile_bound(global1_all*10, isc, iec, jsc, jec, 1, 0, &
               tile(n), ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )  
          call fill_four_tile_bound(global2_all*10, isc, iec, jsc, jec, 0, 1, &
               tile(n), sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )  
       end do
    case("Cubic-Grid")
       do n = 1, ntile_per_pe
          call fill_cubic_grid_bound(global1_all*10, global2_all*10, isc, iec, jsc, jec, 1, 0, &
               tile(n), 1, -1, ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )  
          call fill_cubic_grid_bound(global2_all*10, global1_all*10, isc, iec, jsc, jec, 0, 1, &
               tile(n), -1, 1, sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )  
       end do
    end select

    call compare_checksums( eboundx, ebufferx2(:,:,:),  "east bound of CGRID " //trim(type)//" X2" )
    call compare_checksums( wboundx, wbufferx2(:,:,:),  "west bound of CGRID " //trim(type)//" X2" )
    call compare_checksums( sboundy, sbuffery2(:,:,:),  "south bound of CGRID "//trim(type)//" Y2" )
    call compare_checksums( nboundy, nbuffery2(:,:,:),  "north bound of CGRID "//trim(type)//" Y2" )

    !--- release memory
    deallocate(global1, global1_all, global2, global2_all)
    deallocate(x, y, x1, y1, x2, y2)
    deallocate(ebufferx, sbufferx, wbufferx, nbufferx)
    deallocate(ebufferx1, sbufferx1, wbufferx1, nbufferx1)
    deallocate(ebufferx2, sbufferx2, wbufferx2, nbufferx2)
    deallocate(ebuffery, sbuffery, wbuffery, nbuffery)
    deallocate(ebuffery1, sbuffery1, wbuffery1, nbuffery1)
    deallocate(ebuffery2, sbuffery2, wbuffery2, nbuffery2)
    deallocate(eboundx, sboundy, wboundx, nboundy )    

  end subroutine test_get_boundary

  !######################################################################################
  subroutine define_fourtile_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end, symmetry )
    character(len=*), intent(in)  :: type
    type(domain2d), intent(inout) :: domain
    integer,        intent(in)    :: global_indices(:,:), layout(:,:)
    integer,        intent(in)    :: ni(:), nj(:)
    integer,        intent(in)    :: pe_start(:), pe_end(:)
    logical,        intent(in)    :: symmetry
    integer, dimension(8)         :: istart1, iend1, jstart1, jend1, tile1
    integer, dimension(8)         :: istart2, iend2, jstart2, jend2, tile2
    integer                       :: ntiles, num_contact, msize(2)

    ntiles = 4
    num_contact = 8
    if(size(pe_start(:)) .NE. 4 .OR. size(pe_end(:)) .NE. 4 ) call mpp_error(FATAL, &
         "define_fourtile_mosaic: size of pe_start and pe_end should be 4")
    if(size(global_indices,1) .NE. 4) call mpp_error(FATAL, &
         "define_fourtile_mosaic: size of first dimension of global_indices should be 4")
    if(size(global_indices,2) .NE. 4) call mpp_error(FATAL, &
         "define_fourtile_mosaic: size of second dimension of global_indices should be 4")
    if(size(layout,1) .NE. 2) call mpp_error(FATAL, &
         "define_fourtile_mosaic: size of first dimension of layout should be 2")
    if(size(layout,2) .NE. 4) call mpp_error(FATAL, &
         "define_fourtile_mosaic: size of second dimension of layout should be 4")
    if(size(ni(:)) .NE. 4 .OR. size(nj(:)) .NE. 4) call mpp_error(FATAL, &
         "define_fourtile_mosaic: size of ni and nj should be 4")

    !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST)
    tile1(1) = 1; tile2(1) = 2
    istart1(1) = ni(1); iend1(1) = ni(1); jstart1(1) = 1;     jend1(1) = nj(1)
    istart2(1) = 1;     iend2(1) = 1;     jstart2(1) = 1;     jend2(1) = nj(2)
    !--- Contact line 2, between tile 1 (SOUTH) and tile 3 (NORTH)  --- cyclic
    tile1(2) = 1; tile2(2) = 3
    istart1(2) = 1;     iend1(2) = ni(1); jstart1(2) = 1;     jend1(2) = 1    
    istart2(2) = 1;     iend2(2) = ni(3); jstart2(2) = nj(3); jend2(2) = nj(3)
    !--- Contact line 3, between tile 1 (WEST) and tile 2 (EAST) --- cyclic
    tile1(3) = 1; tile2(3) = 2
    istart1(3) = 1;     iend1(3) = 1;     jstart1(3) = 1;     jend1(3) = nj(1)
    istart2(3) = ni(2); iend2(3) = ni(2); jstart2(3) = 1;     jend2(3) = nj(2)
    !--- Contact line 4, between tile 1 (NORTH) and tile 3 (SOUTH) 
    tile1(4) = 1; tile2(4) = 3
    istart1(4) = 1;     iend1(4) = ni(1); jstart1(4) = nj(1); jend1(4) = nj(1)
    istart2(4) = 1;     iend2(4) = ni(3); jstart2(4) = 1;     jend2(4) = 1    
    !--- Contact line 5, between tile 2 (SOUTH) and tile 4 (NORTH) --- cyclic
    tile1(5) = 2; tile2(5) = 4
    istart1(5) = 1;     iend1(5) = ni(2); jstart1(5) = 1;     jend1(5) = 1    
    istart2(5) = 1;     iend2(5) = ni(4); jstart2(5) = nj(4); jend2(5) = nj(4)
    !--- Contact line 6, between tile 2 (NORTH) and tile 4 (SOUTH)
    tile1(6) = 2; tile2(6) = 4
    istart1(6) = 1;     iend1(6) = ni(2); jstart1(6) = nj(2); jend1(6) = nj(2)
    istart2(6) = 1;     iend2(6) = ni(4); jstart2(6) = 1;     jend2(6) = 1    
    !--- Contact line 7, between tile 3 (EAST) and tile 4 (WEST) 
    tile1(7) = 3; tile2(7) = 4
    istart1(7) = ni(3); iend1(7) = ni(3); jstart1(7) = 1;     jend1(7) = nj(3)
    istart2(7) = 1;     iend2(7) = 1;     jstart2(7) = 1;     jend2(7) = nj(4)
    !--- Contact line 8, between tile 3 (WEST) and tile 4 (EAST) --- cyclic
    tile1(8) = 3; tile2(8) = 4
    istart1(8) = 1;     iend1(8) = 1;     jstart1(8) = 1;     jend1(8) = nj(3)
    istart2(8) = ni(4); iend2(8) = ni(4); jstart2(8) = 1;     jend2(8) = nj(4)
    msize(1) = maxval(ni(:)/layout(1,:)) + whalo + ehalo + 1 ! make sure memory domain size is no smaller than
    msize(2) = maxval(nj(:)/layout(2,:)) + shalo + nhalo + 1 ! data domain size       
    call mpp_define_mosaic(global_indices, layout, domain, ntiles, num_contact, tile1, tile2,       &
         istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,          &
         pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,    &
         name = type, memory_size = msize, symmetry = symmetry )
 
    return

  end subroutine define_fourtile_mosaic

  !#######################################################################################
  !--- define mosaic domain for cubic grid
  subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end )
    character(len=*), intent(in)  :: type
    type(domain2d), intent(inout) :: domain
    integer,        intent(in)    :: global_indices(:,:), layout(:,:)
    integer,        intent(in)    :: ni(:), nj(:)
    integer,        intent(in)    :: pe_start(:), pe_end(:)
    integer, dimension(12)        :: istart1, iend1, jstart1, jend1, tile1
    integer, dimension(12)        :: istart2, iend2, jstart2, jend2, tile2
    integer                       :: ntiles, num_contact, msize(2)


    ntiles = 6
    num_contact = 12
    if(size(pe_start(:)) .NE. 6 .OR. size(pe_end(:)) .NE. 6 ) call mpp_error(FATAL, &
         "define_cubic_mosaic: size of pe_start and pe_end should be 6")
    if(size(global_indices,1) .NE. 4) call mpp_error(FATAL, &
         "define_cubic_mosaic: size of first dimension of global_indices should be 4")
    if(size(global_indices,2) .NE. 6) call mpp_error(FATAL, &
         "define_cubic_mosaic: size of second dimension of global_indices should be 6")
    if(size(layout,1) .NE. 2) call mpp_error(FATAL, &
         "define_cubic_mosaic: size of first dimension of layout should be 2")
    if(size(layout,2) .NE. 6) call mpp_error(FATAL, &
         "define_cubic_mosaic: size of second dimension of layout should be 6")
    if(size(ni(:)) .NE. 6 .OR. size(nj(:)) .NE. 6) call mpp_error(FATAL, &
         "define_cubic_mosaic: size of ni and nj should be 6")

    !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST)
    tile1(1) = 1; tile2(1) = 2
    istart1(1) = ni(1);  iend1(1) = ni(1);  jstart1(1) = 1;      jend1(1) = nj(1)
    istart2(1) = 1;      iend2(1) = 1;      jstart2(1) = 1;      jend2(1) = nj(2)
    !--- Contact line 2, between tile 1 (NORTH) and tile 3 (WEST)
    tile1(2) = 1; tile2(2) = 3
    istart1(2) = 1;      iend1(2) = ni(1);  jstart1(2) = nj(1);  jend1(2) = nj(1)
    istart2(2) = 1;      iend2(2) = 1;      jstart2(2) = nj(3);  jend2(2) = 1
    !--- Contact line 3, between tile 1 (WEST) and tile 5 (NORTH)
    tile1(3) = 1; tile2(3) = 5
    istart1(3) = 1;      iend1(3) = 1;      jstart1(3) = 1;      jend1(3) = nj(1)
    istart2(3) = ni(5);  iend2(3) = 1;      jstart2(3) = nj(5);  jend2(3) = nj(5)
    !--- Contact line 4, between tile 1 (SOUTH) and tile 6 (NORTH)
    tile1(4) = 1; tile2(4) = 6
    istart1(4) = 1;      iend1(4) = ni(1);  jstart1(4) = 1;      jend1(4) = 1
    istart2(4) = 1;      iend2(4) = ni(6);  jstart2(4) = nj(6);  jend2(4) = nj(6)       
    !--- Contact line 5, between tile 2 (NORTH) and tile 3 (SOUTH)
    tile1(5) = 2; tile2(5) = 3
    istart1(5) = 1;      iend1(5) = ni(2);  jstart1(5) = nj(2);  jend1(5) = nj(2)
    istart2(5) = 1;      iend2(5) = ni(3);  jstart2(5) = 1;      jend2(5) = 1
    !--- Contact line 6, between tile 2 (EAST) and tile 4 (SOUTH)
    tile1(6) = 2; tile2(6) = 4
    istart1(6) = ni(2);  iend1(6) = ni(2);  jstart1(6) = 1;      jend1(6) = nj(2)
    istart2(6) = ni(4);  iend2(6) = 1;      jstart2(6) = 1;      jend2(6) = 1
    !--- Contact line 7, between tile 2 (SOUTH) and tile 6 (EAST)
    tile1(7) = 2; tile2(7) = 6
    istart1(7) = 1;      iend1(7) = ni(2);  jstart1(7) = 1;      jend1(7) = 1
    istart2(7) = ni(6);  iend2(7) = ni(6);  jstart2(7) = nj(6);  jend2(7) = 1
    !--- Contact line 8, between tile 3 (EAST) and tile 4 (WEST)
    tile1(8) = 3; tile2(8) = 4
    istart1(8) = ni(3);  iend1(8) = ni(3);  jstart1(8) = 1;      jend1(8) = nj(3)
    istart2(8) = 1;      iend2(8) = 1;      jstart2(8) = 1;      jend2(8) = nj(4)
    !--- Contact line 9, between tile 3 (NORTH) and tile 5 (WEST)
    tile1(9) = 3; tile2(9) = 5
    istart1(9) = 1;      iend1(9) = ni(3);  jstart1(9) = nj(3);  jend1(9) = nj(3)
    istart2(9) = 1;      iend2(9) = 1;      jstart2(9) = nj(5);  jend2(9) = 1
    !--- Contact line 10, between tile 4 (NORTH) and tile 5 (SOUTH)
    tile1(10) = 4; tile2(10) = 5
    istart1(10) = 1;     iend1(10) = ni(4); jstart1(10) = nj(4); jend1(10) = nj(4)
    istart2(10) = 1;     iend2(10) = ni(5); jstart2(10) = 1;     jend2(10) = 1
    !--- Contact line 11, between tile 4 (EAST) and tile 6 (SOUTH)
    tile1(11) = 4; tile2(11) = 6
    istart1(11) = ni(4); iend1(11) = ni(4); jstart1(11) = 1;     jend1(11) = nj(4)
    istart2(11) = ni(6); iend2(11) = 1;     jstart2(11) = 1;     jend2(11) = 1
    !--- Contact line 12, between tile 5 (EAST) and tile 6 (WEST)
    tile1(12) = 5; tile2(12) = 6
    istart1(12) = ni(5); iend1(12) = ni(5); jstart1(12) = 1;     jend1(12) = nj(5)
    istart2(12) = 1;     iend2(12) = 1;     jstart2(12) = 1;     jend2(12) = nj(6)
    msize(1) = maxval(ni(:)/layout(1,:)) + whalo + ehalo + 1 ! make sure memory domain size is no smaller than
    msize(2) = maxval(nj(:)/layout(2,:)) + shalo + nhalo + 1 ! data domain size       
    call mpp_define_mosaic(global_indices, layout, domain, ntiles, num_contact, tile1, tile2, &
         istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,      &
         pe_start, pe_end, symmetry = .true., whalo=whalo, ehalo=ehalo,   &
         shalo=shalo, nhalo=nhalo, name = trim(type), memory_size = msize  )  

    return 

  end subroutine define_cubic_mosaic

  !#######################################################################################
  subroutine fill_regular_refinement_halo( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, ioff, joff )
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    real, dimension(:,:,:,:),             intent(in)    :: data_all
    integer, dimension(:),                intent(in)    :: ni, nj
    integer,                              intent(in)    :: tm, te, tse, ts, tsw, tw, tnw, tn, tne
    integer,                              intent(in)    :: ioff, joff


    if(te>0) data    (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff,                   :) = &
             data_all(1+ioff:ehalo+ioff,               1:nj(te)+joff,                   :,te)  ! east
    if(ts>0) data    (1:ni(tm)+ioff,                   1-shalo:0,                       :) = &
             data_all(1:ni(ts)+ioff,                   nj(ts)-shalo+1:nj(ts),           :,ts)  ! south 
    if(tw>0) data    (1-whalo:0,                       1:nj(tm)+joff,                   :) = &
             data_all(ni(tw)-whalo+1:ni(tw),           1:nj(tw)+joff,                   :,tw)  ! west
    if(tn>0) data    (1:ni(tm)+ioff,                   nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = &
             data_all(1:ni(tn)+ioff,                   1+joff:nhalo+joff,               :,tn)  ! north  
    if(tse>0)data    (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0,                       :) = &
             data_all(1+ioff:ehalo+ioff,               nj(tse)-shalo+1:nj(tse),         :,tse) ! southeast
    if(tsw>0)data    (1-whalo:0,                       1-shalo:0,                       :) = &
             data_all(ni(tsw)-whalo+1:ni(tsw),         nj(tsw)-shalo+1:nj(tsw),         :,tsw) ! southwest
    if(tne>0)data    (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = &
             data_all(1+ioff:ehalo+ioff,               1+joff:nhalo+joff,               :,tnw) ! northeast
    if(tnw>0)data    (1-whalo:0,                       nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = &
             data_all(ni(tnw)-whalo+1:ni(tnw),         1+joff:nhalo+joff,               :,tne) ! northwest      

  end subroutine fill_regular_refinement_halo

  !##############################################################################
  ! this routine fill the halo points for the refined cubic grid. ioff and joff is used to distinguish
  ! T, C, E, or N-cell
  subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, ioff, joff, sign1, sign2)
    real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data
    real, dimension(:,:,:,:),             intent(in)    :: data1_all, data2_all
    integer, dimension(:),                intent(in)    :: ni, nj
    integer,                              intent(in)    :: tile, ioff, joff, sign1, sign2 
    integer                                             :: lw, le, ls, ln

    if(mod(tile,2) == 0) then ! tile 2, 4, 6
       lw = tile - 1; le = tile + 2; ls = tile - 2; ln = tile + 1
       if(le > 6 ) le = le - 6
       if(ls < 1 ) ls = ls + 6
       if(ln > 6 ) ln = ln - 6
       if( nj(tile) == nj(lw) ) then
          data(1-whalo:0, 1:nj(tile)+joff, :) = data1_all(ni(lw)-whalo+1:ni(lw), 1:nj(lw)+joff, :, lw) ! west 
       end if
       if( nj(tile) == ni(le) ) then
          do i = 1, ehalo 
             data(ni(tile)+i+ioff, 1:nj(tile)+joff, :)    = sign1*data2_all(ni(le)+joff:1:-1, i+ioff, :, le) ! east 
          end do
       end if
       if(ni(tile) == nj(ls) ) then
          do i = 1, shalo 
             data(1:ni(tile)+ioff, 1-i, :)     = sign2*data2_all(ni(ls)-i+1, nj(ls)+ioff:1:-1, :, ls) ! south 
          end do
       end if
       if(ni(tile) == ni(ln) ) then
          data(1:ni(tile)+ioff, nj(tile)+1+joff:nj(tile)+nhalo+joff, :) = data1_all(1:ni(ln)+ioff, 1+joff:nhalo+joff, :, ln) ! north
       end if
    else ! tile 1, 3, 5
       lw = tile - 2; le = tile + 1; ls = tile - 1; ln = tile + 2
       if(lw < 1 ) lw = lw + 6
       if(ls < 1 ) ls = ls + 6
       if(ln > 6 ) ln = ln - 6
       if(nj(tile) == ni(lw) ) then
          do i = 1, whalo 
             data(1-i, 1:nj(tile)+joff, :)     = sign1*data2_all(ni(lw)+joff:1:-1, nj(lw)-i+1, :, lw) ! west 
          end do
       end if
       if(nj(tile) == nj(le) ) then
          data(ni(tile)+1+ioff:ni(tile)+ehalo+ioff, 1:nj(tile)+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:nj(le)+joff, :, le) ! east 
       end if
       if(ni(tile) == ni(ls) ) then
          data(1:ni(tile)+ioff, 1-shalo:0, :)     = data1_all(1:ni(ls)+ioff, nj(ls)-shalo+1:nj(ls), :, ls) ! south 
       end if
       if(ni(tile) == nj(ln) ) then
          do i = 1, nhalo 
             data(1:ni(tile)+ioff, nj(tile)+i+joff, :)    = sign2*data2_all(i+joff, nj(ln)+ioff:1:-1, :, ln) ! north 
          end do
       end if
    end if

  end subroutine fill_cubicgrid_refined_halo
    

  !##################################################################################
  subroutine test_halo_update( type )
    character(len=*), intent(in) :: type
    real, allocatable, dimension(:,:,:) :: x, x1, x2, x3, x4
    real, allocatable, dimension(:,:,:) :: y, y1, y2, y3, y4
    type(domain2D) :: domain
    real,    allocatable :: global1(:,:,:), global2(:,:,:), global(:,:,:)
    logical, allocatable :: maskmap(:,:)
    integer              :: shift, i, xhalo, yhalo
    logical              :: is_symmetry, folded_south, folded_west, folded_east
    integer              :: is, ie, js, je, isd, ied, jsd, jed

    ! when testing maskmap option, nx*ny should be able to be divided by both npes and npes+1
    if(type == 'Masked' .or. type == 'Masked symmetry') then
       if(mod(nx*ny, npes) .NE. 0 .OR. mod(nx*ny, npes+1) .NE. 0 ) then
          call mpp_error(NOTE,'TEST_MPP_DOMAINS: nx*ny can not be divided by both npes and npes+1, '//&
               'Masked test_halo_update will not be tested')
          return
       end if
    end if

    if(type == 'Folded xy_halo' ) then
       xhalo = max(whalo, ehalo); yhalo = max(shalo, nhalo)
       allocate(global(1-xhalo:nx+xhalo,1-yhalo:ny+yhalo,nz) )
    else
       allocate(global(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz) )
    end if

    global = 0
    do k = 1,nz
       do j = 1,ny
          do i = 1,nx
             global(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
    end do

    if(index(type, 'symmetry') == 0) then
       is_symmetry = .false.
    else
       is_symmetry = .true.
    end if
    select case(type)
    case( 'Simple', 'Simple symmetry' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                 shalo=shalo, nhalo=nhalo, name=type, symmetry = is_symmetry )
    case( 'Cyclic', 'Cyclic symmetry' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo,        &
             shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN, yflags=CYCLIC_GLOBAL_DOMAIN, &
             name=type, symmetry = is_symmetry )
        global(1-whalo:0,                 1:ny,:) = global(nx-whalo+1:nx,             1:ny,:)
        global(nx+1:nx+ehalo,             1:ny,:) = global(1:ehalo,                   1:ny,:)
        global(1-whalo:nx+ehalo,     1-shalo:0,:) = global(1-whalo:nx+ehalo, ny-shalo+1:ny,:)
        global(1-whalo:nx+ehalo, ny+1:ny+nhalo,:) = global(1-whalo:nx+ehalo,       1:nhalo,:)
    case( 'Folded-north', 'Folded-north symmetry' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo,   &
             shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN, yflags=FOLD_NORTH_EDGE, &
             name=type, symmetry = is_symmetry  )
        call fill_folded_north_halo(global, 0, 0, 0, 0, 1)
    case( 'Folded-south symmetry' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo,   &
             shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN, yflags=FOLD_SOUTH_EDGE, &
             name=type, symmetry = is_symmetry  )
        call fill_folded_south_halo(global, 0, 0, 0, 0, 1)
    case( 'Folded-west symmetry' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo,   &
             shalo=shalo, nhalo=nhalo, xflags=FOLD_WEST_EDGE, yflags=CYCLIC_GLOBAL_DOMAIN, &
             name=type, symmetry = is_symmetry  )
        call fill_folded_west_halo(global, 0, 0, 0, 0, 1)
    case( 'Folded-east symmetry' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo,   &
             shalo=shalo, nhalo=nhalo, xflags=FOLD_EAST_EDGE, yflags=CYCLIC_GLOBAL_DOMAIN, &
             name=type, symmetry = is_symmetry  )
        call fill_folded_east_halo(global, 0, 0, 0, 0, 1)
    case( 'Folded xy_halo' )
        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=xhalo, yhalo=yhalo,   &
             xflags=CYCLIC_GLOBAL_DOMAIN, yflags=FOLD_NORTH_EDGE, name=type, symmetry = is_symmetry  )
        global(1-xhalo:0,                1:ny,:) = global(nx-xhalo+1:nx,                   1:ny,:)
        global(nx+1:nx+xhalo,            1:ny,:) = global(1:xhalo,                         1:ny,:)
        global(1-xhalo:nx+xhalo,ny+1:ny+yhalo,:) = global(nx+xhalo:1-xhalo:-1, ny:ny-yhalo+1:-1,:)
    case( 'Masked', 'Masked symmetry' )
!with fold and cyclic, assign to npes+1 and mask out the top-rightdomain
        call mpp_define_layout( (/1,nx,1,ny/), npes+1, layout )
        allocate( maskmap(layout(1),layout(2)) )
        maskmap(:,:) = .TRUE.; maskmap(layout(1),layout(2)) = .FALSE.
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo,   &
             shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN, yflags=FOLD_NORTH_EDGE, &
             maskmap=maskmap, name=type, symmetry = is_symmetry  )
        deallocate(maskmap)
       !we need to zero out the global data on the missing domain.
       !this logic assumes top-right, in an even division
        if( mod(nx,layout(1)).NE.0 .OR. mod(ny,layout(2)).NE.0 )call mpp_error( FATAL, &
             'TEST_MPP_DOMAINS: test for masked domains needs (nx,ny) to divide evenly on npes+1 PEs.' )
        global(nx-nx/layout(1)+1:nx,ny-ny/layout(2)+1:ny,:) = 0
        call fill_folded_north_halo(global, 0, 0, 0, 0, 1)        
    case default
        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type )
    end select
        
!set up x array
    call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
    allocate( x (isd:ied,jsd:jed,nz) )
    allocate( x1(isd:ied,jsd:jed,nz) )
    allocate( x2(isd:ied,jsd:jed,nz) )
    allocate( x3(isd:ied,jsd:jed,nz) )
    allocate( x4(isd:ied,jsd:jed,nz) )
    x = 0.
    x (is:ie,js:je,:) = global(is:ie,js:je,:)
    x1 = x; x2 = x; x3 = x; x4 = x

!full update
    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x, domain )
    call mpp_clock_end  (id)
    call compare_checksums( x, global(isd:ied,jsd:jed,:), type )

!partial update
    id = mpp_clock_id( type//' partial', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x1, domain, NUPDATE+EUPDATE, complete=.false. )
    call mpp_update_domains( x2, domain, NUPDATE+EUPDATE, complete=.false. )
    call mpp_update_domains( x3, domain, NUPDATE+EUPDATE, complete=.false. )
    call mpp_update_domains( x4, domain, NUPDATE+EUPDATE, complete=.true. )
    call mpp_clock_end  (id)
    call compare_checksums( x1(is:ied,js:jed,:), global(is:ied,js:jed,:), type//' partial x1' )
    call compare_checksums( x2(is:ied,js:jed,:), global(is:ied,js:jed,:), type//' partial x2' )
    call compare_checksums( x3(is:ied,js:jed,:), global(is:ied,js:jed,:), type//' partial x3' )
    call compare_checksums( x4(is:ied,js:jed,:), global(is:ied,js:jed,:), type//' partial x4' )
    
    !--- test vector update for FOLDED and MASKED case.
    if(type == 'Simple' .or. type == 'Simple symmetry' .or. type == 'Cyclic' .or. type == 'Cyclic symmetry') then
       deallocate(x,x1,x2,x3,x4)
       return       
    end if

    !------------------------------------------------------------------
    !              vector update : BGRID_NE
    !------------------------------------------------------------------
    shift = 0
    if(is_symmetry) then
       shift = 1
       deallocate(global)
       allocate(global(1-whalo:nx+ehalo+shift,1-shalo:ny+nhalo+shift,nz) )
       global = 0.0
       do k = 1,nz
          do j = 1,ny+1
             do i = 1,nx+1
                global(i,j,k) = k + i*1e-3 + j*1e-6
             end do
          end do
       end do
       if(type == 'Masked symmetry') then
           global(nx-nx/layout(1)+1:nx+1,ny-ny/layout(2)+1:ny+1,:) = 0
       endif
       deallocate(x, x1, x2, x3, x4)
       allocate( x (isd:ied+1,jsd:jed+1,nz) )
       allocate( x1(isd:ied+1,jsd:jed+1,nz) )
       allocate( x2(isd:ied+1,jsd:jed+1,nz) )
       allocate( x3(isd:ied+1,jsd:jed+1,nz) )
       allocate( x4(isd:ied+1,jsd:jed+1,nz) )
    endif

    folded_south = .false.
    folded_west  = .false.
    folded_east  = .false.
    select case (type)
    case ('Folded-north', 'Masked')
       !fill in folded north edge, cyclic east and west edge
       call fill_folded_north_halo(global, 1, 1, 0, 0, -1)     
    case ('Folded xy_halo')
       !fill in folded north edge, cyclic east and west edge
       global(1-xhalo:0,                  1:ny,:) =  global(nx-xhalo+1:nx,                     1:ny,:)
       global(nx+1:nx+xhalo,              1:ny,:) =  global(1:xhalo,                           1:ny,:)
       global(1-xhalo:nx+xhalo-1,ny+1:ny+yhalo,:) = -global(nx+xhalo-1:1-xhalo:-1,ny-1:ny-yhalo:-1,:)
       global(nx+xhalo,          ny+1:ny+yhalo,:) = -global(nx-xhalo,             ny-1:ny-yhalo:-1,:)
    case ('Folded-north symmetry', 'Masked symmetry' )
       call fill_folded_north_halo(global, 1, 1, 1, 1, -1)
    case ('Folded-south symmetry' )
       folded_south = .true.
       call fill_folded_south_halo(global, 1, 1, 1, 1, -1)
    case ('Folded-west symmetry' )
       folded_west = .true.
       call fill_folded_west_halo(global, 1, 1, 1, 1, -1)
    case ('Folded-east symmetry' )
       folded_east = .true.
       call fill_folded_east_halo(global, 1, 1, 1, 1, -1)
    case default
        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type )
    end select

    x = 0.
    x(is:ie+shift,js:je+shift,:) = global(is:ie+shift,js:je+shift,:)
    !set up y array
    allocate( y (isd:ied+shift,jsd:jed+shift,nz) )
    allocate( y1(isd:ied+shift,jsd:jed+shift,nz) )
    allocate( y2(isd:ied+shift,jsd:jed+shift,nz) )
    allocate( y3(isd:ied+shift,jsd:jed+shift,nz) )
    allocate( y4(isd:ied+shift,jsd:jed+shift,nz) )
    y = x; x1 = x; x2 = x; x3 = x; x4 = x
    y = x; y1 = x; y2 = x; y3 = x; y4 = x

    id = mpp_clock_id( type//' vector BGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x,  y,  domain, gridtype=BGRID_NE)
    call mpp_update_domains( x1, y1, domain, gridtype=BGRID_NE, complete=.false. )
    call mpp_update_domains( x2, y2, domain, gridtype=BGRID_NE, complete=.false. )
    call mpp_update_domains( x3, y3, domain, gridtype=BGRID_NE, complete=.false. )
    call mpp_update_domains( x4, y4, domain, gridtype=BGRID_NE, complete=.true.  )
    call mpp_clock_end  (id)

    !redundant points must be equal and opposite

    if(folded_south) then
       global(nx/2+shift,                1,:) = 0.  !pole points must have 0 velocity
       global(nx+shift  ,                1,:) = 0.  !pole points must have 0 velocity
       global(nx/2+1+shift:nx-1+shift,   1,:) = -global(nx/2-1+shift:1+shift:-1, 1,:)
       global(1-whalo:shift,             1,:) = -global(nx-whalo+1:nx+shift,     1,:)
       global(nx+1+shift:nx+ehalo+shift, 1,:) = -global(1+shift:ehalo+shift,     1,:)
       !--- the following will fix the +0/-0 problem on altix
       if(shalo >0) global(shift,1,:) = 0.  !pole points must have 0 velocity
    else if(folded_west) then
       global(1, ny/2+shift, :) = 0. !pole points must have 0 velocity
       global(1, ny+shift,   :) = 0. !pole points must have 0 velocity
       global(1, ny/2+1+shift:ny-1+shift,   :) = -global(1, ny/2-1+shift:1+shift:-1, :)
       global(1, 1-shalo:shift,             :) = -global(1, ny-shalo+1:ny+shift,     :)
       global(1, ny+1+shift:ny+nhalo+shift, :) = -global(1, 1+shift:nhalo+shift,     :)
       !--- the following will fix the +0/-0 problem on altix
       if(whalo>0) global(1, shift, :) = 0.  !pole points must have 0 velocity
    else if(folded_east) then
       global(nx+shift, ny/2+shift, :) = 0. !pole points must have 0 velocity
       global(nx+shift, ny+shift,   :) = 0. !pole points must have 0 velocity
       global(nx+shift, ny/2+1+shift:ny-1+shift,   :) = -global(nx+shift, ny/2-1+shift:1+shift:-1, :)
       global(nx+shift, 1-shalo:shift,             :) = -global(nx+shift, ny-shalo+1:ny+shift,     :)
       global(nx+shift, ny+1+shift:ny+nhalo+shift, :) = -global(nx+shift, 1+shift:nhalo+shift,     :)
       if(ehalo >0) global(nx+shift, shift, :) = 0.  !pole points must have 0 velocity       
    else
       global(nx/2+shift,                ny+shift,:) = 0.  !pole points must have 0 velocity
       global(nx+shift  ,                ny+shift,:) = 0.  !pole points must have 0 velocity
       global(nx/2+1+shift:nx-1+shift,   ny+shift,:) = -global(nx/2-1+shift:1+shift:-1, ny+shift,:)
       if(type == 'Folded xy_halo') then
          global(1-xhalo:shift,             ny+shift,:) = -global(nx-xhalo+1:nx+shift,     ny+shift,:)
          global(nx+1+shift:nx+xhalo+shift, ny+shift,:) = -global(1+shift:xhalo+shift,     ny+shift,:)
       else
          global(1-whalo:shift,             ny+shift,:) = -global(nx-whalo+1:nx+shift,     ny+shift,:)
          global(nx+1+shift:nx+ehalo+shift, ny+shift,:) = -global(1+shift:ehalo+shift,     ny+shift,:)
       end if
       !--- the following will fix the +0/-0 problem on altix
       if(nhalo >0) global(shift,ny+shift,:) = 0.  !pole points must have 0 velocity
    endif

    call compare_checksums( x,  global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE X' )
    call compare_checksums( y,  global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE Y' )
    call compare_checksums( x1, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE X1' )
    call compare_checksums( x2, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE X2' )
    call compare_checksums( x3, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE X3' )
    call compare_checksums( x4, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE X4' )
    call compare_checksums( y1, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE Y1' )
    call compare_checksums( y2, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE Y2' )
    call compare_checksums( y3, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE Y3' )
    call compare_checksums( y4, global(isd:ied+shift,jsd:jed+shift,:), type//' BGRID_NE Y4' )

    deallocate(global, x, x1, x2, x3, x4, y, y1, y2, y3, y4)

    !------------------------------------------------------------------
    !              vector update : CGRID_NE
    !------------------------------------------------------------------
    !--- global1 is x-component and global2 is y-component
    if(type == 'Folded xy_halo') then
       allocate(global1(1-xhalo:nx+xhalo, 1-yhalo:ny+yhalo, nz))
       allocate(global2(1-xhalo:nx+xhalo, 1-yhalo:ny+yhalo, nz))
    else
       allocate(global1(1-whalo:nx+ehalo+shift, 1-shalo:ny+nhalo, nz))
       allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo+shift, nz))
    end if
    allocate(x (isd:ied+shift,jsd:jed,nz), y (isd:ied,jsd:jed+shift,nz) )
    allocate(x1(isd:ied+shift,jsd:jed,nz), y1(isd:ied,jsd:jed+shift,nz) )
    allocate(x2(isd:ied+shift,jsd:jed,nz), y2(isd:ied,jsd:jed+shift,nz) )
    allocate(x3(isd:ied+shift,jsd:jed,nz), y3(isd:ied,jsd:jed+shift,nz) )
    allocate(x4(isd:ied+shift,jsd:jed,nz), y4(isd:ied,jsd:jed+shift,nz) )
    
    global1 = 0.0
    global2 = 0.0
    do k = 1,nz
       do j = 1,ny
          do i = 1,nx+shift
             global1(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
       do j = 1,ny+shift
          do i = 1,nx
             global2(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
    end do

    if(type == 'Masked' .or. type == 'Masked symmetry') then
       global1(nx-nx/layout(1)+1:nx+shift,ny-ny/layout(2)+1:ny,:) = 0
       global2(nx-nx/layout(1)+1:nx,ny-ny/layout(2)+1:ny+shift,:) = 0
    end if

    select case (type)
    case ('Folded-north', 'Masked')
       !fill in folded north edge, cyclic east and west edge
       call fill_folded_north_halo(global1, 1, 0, 0, 0, -1)
       call fill_folded_north_halo(global2, 0, 1, 0, 0, -1)
    case ('Folded xy_halo')
       global1(1-xhalo:0,                   1:ny,:) =  global1(nx-xhalo+1:nx,                     1:ny,:)
       global1(nx+1:nx+xhalo,               1:ny,:) =  global1(1:xhalo,                           1:ny,:)
       global2(1-xhalo:0,                   1:ny,:) =  global2(nx-xhalo+1:nx,                     1:ny,:)
       global2(nx+1:nx+xhalo,               1:ny,:) =  global2(1:xhalo,                           1:ny,:)
       global1(1-xhalo:nx+xhalo-1, ny+1:ny+yhalo,:) = -global1(nx+xhalo-1:1-xhalo:-1, ny:ny-yhalo+1:-1,:)
       global1(nx+xhalo,           ny+1:ny+yhalo,:) = -global1(nx-xhalo,              ny:ny-yhalo+1:-1,:)
       global2(1-xhalo:nx+xhalo,   ny+1:ny+yhalo,:) = -global2(nx+xhalo:1-xhalo:-1,   ny-1:ny-yhalo:-1,:)
    case ('Folded-north symmetry')
       call fill_folded_north_halo(global1, 1, 0, 1, 0, -1)
       call fill_folded_north_halo(global2, 0, 1, 0, 1, -1)
    case ('Folded-south symmetry')
       call fill_folded_south_halo(global1, 1, 0, 1, 0, -1)
       call fill_folded_south_halo(global2, 0, 1, 0, 1, -1)
    case ('Folded-west symmetry')
       call fill_folded_west_halo(global1, 1, 0, 1, 0, -1)
       call fill_folded_west_halo(global2, 0, 1, 0, 1, -1)
    case ('Folded-east symmetry')
       call fill_folded_east_halo(global1, 1, 0, 1, 0, -1)
       call fill_folded_east_halo(global2, 0, 1, 0, 1, -1)
    case default
        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type )
    end select

    x = 0.; y = 0.
    x(is:ie+shift,js:je,      :) = global1(is:ie+shift,js:je,      :)
    y(is:ie      ,js:je+shift,:) = global2(is:ie,      js:je+shift,:)
    x1 = x; x2 = x; x3 = x; x4 = x
    y1 = y; y2 = y; y3 = y; y4 = y

    id = mpp_clock_id( type//' vector CGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x,  y,  domain, gridtype=CGRID_NE)
    call mpp_update_domains( x1, y1, domain, gridtype=CGRID_NE, complete=.false. )
    call mpp_update_domains( x2, y2, domain, gridtype=CGRID_NE, complete=.false. )
    call mpp_update_domains( x3, y3, domain, gridtype=CGRID_NE, complete=.false. )
    call mpp_update_domains( x4, y4, domain, gridtype=CGRID_NE, complete=.true.  )
    call mpp_clock_end  (id)

    !redundant points must be equal and opposite
    if(folded_south) then
       global2(nx/2+1:nx,     1,:) = -global2(nx/2:1:-1, 1,:)
       global2(1-whalo:0,     1,:) = -global2(nx-whalo+1:nx, 1, :)
       global2(nx+1:nx+ehalo, 1,:) = -global2(1:ehalo,       1, :)
    else if(folded_west) then
       global1(1, ny/2+1:ny,     :) = -global1(1, ny/2:1:-1,     :)
       global1(1, 1-shalo:0,     :) = -global1(1, ny-shalo+1:ny, :)
       global1(1, ny+1:ny+nhalo, :) = -global1(1, 1:nhalo,       :)
    else if(folded_east) then
       global1(nx+shift, ny/2+1:ny,     :) = -global1(nx+shift, ny/2:1:-1,     :)
       global1(nx+shift, 1-shalo:0,     :) = -global1(nx+shift, ny-shalo+1:ny, :)
       global1(nx+shift, ny+1:ny+nhalo, :) = -global1(nx+shift, 1:nhalo,       :)
    else
       global2(nx/2+1:nx,     ny+shift,:) = -global2(nx/2:1:-1, ny+shift,:)
       if(type == 'Folded xy_halo') then
          global2(1-xhalo:0,     ny+shift,:) = -global2(nx-xhalo+1:nx, ny+shift,:)
          global2(nx+1:nx+xhalo, ny+shift,:) = -global2(1:xhalo,       ny+shift,:)
       else
          global2(1-whalo:0,     ny+shift,:) = -global2(nx-whalo+1:nx, ny+shift,:)
          global2(nx+1:nx+ehalo, ny+shift,:) = -global2(1:ehalo,       ny+shift,:)
       end if
    endif

    call compare_checksums( x,  global1(isd:ied+shift,jsd:jed,      :), type//' CGRID_NE X' )
    call compare_checksums( y,  global2(isd:ied,      jsd:jed+shift,:), type//' CGRID_NE Y' )
    call compare_checksums( x1, global1(isd:ied+shift,jsd:jed,      :), type//' CGRID_NE X1' )
    call compare_checksums( x2, global1(isd:ied+shift,jsd:jed,      :), type//' CGRID_NE X2' )
    call compare_checksums( x3, global1(isd:ied+shift,jsd:jed,      :), type//' CGRID_NE X3' )
    call compare_checksums( x4, global1(isd:ied+shift,jsd:jed,      :), type//' CGRID_NE X4' )
    call compare_checksums( y1, global2(isd:ied,      jsd:jed+shift,:), type//' CGRID_NE Y1' )
    call compare_checksums( y2, global2(isd:ied,      jsd:jed+shift,:), type//' CGRID_NE Y2' )
    call compare_checksums( y3, global2(isd:ied,      jsd:jed+shift,:), type//' CGRID_NE Y3' )
    call compare_checksums( y4, global2(isd:ied,      jsd:jed+shift,:), type//' CGRID_NE Y4' )

    deallocate(global1, global2, x, x1, x2, x3, x4, y, y1, y2, y3, y4)


  end subroutine test_halo_update

  !##################################################################################
  subroutine test_cyclic_offset( type )
    character(len=*), intent(in) :: type
    real, allocatable, dimension(:,:,:) :: x, x1, x2, x3, x4
    real, allocatable, dimension(:,:,:) :: y, y1, y2, y3, y4
    type(domain2D) :: domain
    real,    allocatable :: global1(:,:,:), global2(:,:,:), global(:,:,:)
    integer              :: i, j, k, jj, ii
    integer              :: is, ie, js, je, isd, ied, jsd, jed
    character(len=128)   :: type2

    allocate(global(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz))

    global = 0
    do k = 1,nz
       do j = 1,ny
          do i = 1,nx
             global(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
    end do

    call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
    select case(type)
    case( 'x_cyclic_offset' )
        write(type2, *)type, ' x_cyclic=', x_cyclic_offset
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                 shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN,   &
                                 name=type, x_cyclic_offset = x_cyclic_offset)
        do j = 1, ny
           jj = mod(j + x_cyclic_offset + ny, ny)
           if(jj==0) jj = ny
           global(1-whalo:0,j,:) = global(nx-whalo+1:nx, jj,:) ! West
           jj = mod(j - x_cyclic_offset + ny, ny)
           if(jj==0) jj = ny
           global(nx+1:nx+ehalo,j,:) = global(1:ehalo,jj,:)    ! East
        end do
    case( 'y_cyclic_offset' )
        write(type2, *)type, ' y_cyclic = ', y_cyclic_offset
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                 shalo=shalo, nhalo=nhalo, yflags=CYCLIC_GLOBAL_DOMAIN,   &
                                 name=type, y_cyclic_offset = y_cyclic_offset)
        do i = 1, nx
           ii = mod(i + y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:) ! South
           ii = mod(i - y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)    ! NORTH
        end do
    case( 'torus_x_offset' )
        write(type2, *)type, ' x_cyclic = ', x_cyclic_offset
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                 shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN,   &
                                 yflags=CYCLIC_GLOBAL_DOMAIN, name=type,                  &
                                 x_cyclic_offset = x_cyclic_offset)
        do j = 1, ny
           jj = mod(j + x_cyclic_offset + ny, ny)
           if(jj==0) jj = ny
           global(1-whalo:0,j,:) = global(nx-whalo+1:nx, jj,:) ! West
           jj = mod(j - x_cyclic_offset + ny, ny)
           if(jj==0) jj = ny
           global(nx+1:nx+ehalo,j,:) = global(1:ehalo,jj,:)    ! East
        end do
        global(1:nx,1-shalo:0,:)     = global(1:nx, ny-shalo+1:ny,:) ! South
        global(1:nx,ny+1:ny+nhalo,:) = global(1:nx, 1:nhalo, :)    ! NORTH
        
        do j = 1, shalo
           jj = mod(ny-j+1 + x_cyclic_offset + ny, ny)
           if(jj==0) jj = ny
           global(1-whalo:0, 1-j,:) = global(nx-whalo+1:nx, jj, :)  ! Southwest
           jj = mod(ny-j+1-x_cyclic_offset+ny,ny)
           if(jj==0) jj = ny
           global(nx+1:nx+ehalo, 1-j,:) = global(1:ehalo, jj, :)    ! Southeast
        end do
        do j = 1, nhalo
           jj = mod(j + x_cyclic_offset + ny, ny)
           if(jj==0) jj = ny
           global(1-whalo:0, ny+j,:) = global(nx-whalo+1:nx, jj, :)  ! northwest
           jj = mod(j - x_cyclic_offset+ny,ny)
           if(jj==0) jj = ny
           global(nx+1:nx+ehalo, ny+j,:) = global(1:ehalo, jj, :)    ! northeast
        end do

    case( 'torus_y_offset' )
        write(type2, *)type, ' y_cyclic = ', y_cyclic_offset
        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                 shalo=shalo, nhalo=nhalo, xflags=CYCLIC_GLOBAL_DOMAIN,   &
                                 yflags=CYCLIC_GLOBAL_DOMAIN, name=type,                  &
                                 y_cyclic_offset = y_cyclic_offset)
        do i = 1, nx
           ii = mod(i + y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:) ! South
           ii = mod(i - y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)    ! NORTH
        end do
        global(1-whalo:0,1:ny,:)     = global(nx-whalo+1:nx, 1:ny,:) ! West
        global(nx+1:nx+ehalo,1:ny,:) = global(1:ehalo, 1:ny, :)      ! East
        do i = 1, whalo
           ii = mod(nx-i+1 + y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(1-i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:) ! southwest
           ii = mod(nx-i+1 - y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(1-i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)    ! northwest
        end do
        do i = 1, ehalo
           ii = mod(i + y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(nx+i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:) ! southeast
           ii = mod(i - y_cyclic_offset + nx, nx)
           if(ii==0) ii = nx
           global(nx+i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)    ! northeast
        end do
    case default
        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type )
    end select
        
!set up x array
    call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
    allocate( x (isd:ied,jsd:jed,nz) )
    allocate( x1(isd:ied,jsd:jed,nz) )
    allocate( x2(isd:ied,jsd:jed,nz) )
    allocate( x3(isd:ied,jsd:jed,nz) )
    allocate( x4(isd:ied,jsd:jed,nz) )
    x = 0.
    x (is:ie,js:je,:) = global(is:ie,js:je,:)
    x1 = x; x2 = x; x3 = x; x4 = x

!full update
    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x, domain )
    call mpp_clock_end  (id)
    call compare_checksums( x, global(isd:ied,jsd:jed,:), trim(type2) )

!partial update
    id = mpp_clock_id( type//' partial', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x1, domain, NUPDATE+EUPDATE, complete=.false. )
    call mpp_update_domains( x2, domain, NUPDATE+EUPDATE, complete=.false. )
    call mpp_update_domains( x3, domain, NUPDATE+EUPDATE, complete=.false. )
    call mpp_update_domains( x4, domain, NUPDATE+EUPDATE, complete=.true. )
    call mpp_clock_end  (id)
    call compare_checksums( x1(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//' partial x1' )
    call compare_checksums( x2(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//' partial x2' )
    call compare_checksums( x3(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//' partial x3' )
    call compare_checksums( x4(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//' partial x4' )
    
    !--- test vector update for FOLDED and MASKED case.
    deallocate(x,x1,x2,x3,x4)


    !------------------------------------------------------------------
    !              vector update : BGRID_NE
    !------------------------------------------------------------------
    !--- global1 is x-component and global2 is y-component
    allocate(global1(1-whalo:nx+ehalo, 1-shalo:ny+nhalo, nz))
    allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo, nz))
    allocate(x (isd:ied,jsd:jed,nz), y (isd:ied,jsd:jed,nz) )
    allocate(x1(isd:ied,jsd:jed,nz), y1(isd:ied,jsd:jed,nz) )
    allocate(x2(isd:ied,jsd:jed,nz), y2(isd:ied,jsd:jed,nz) )
    allocate(x3(isd:ied,jsd:jed,nz), y3(isd:ied,jsd:jed,nz) )
    allocate(x4(isd:ied,jsd:jed,nz), y4(isd:ied,jsd:jed,nz) )
    where (global >0)
       global1 = 1000 + global
       global2 = 2000 + global
    elsewhere
       global1 = 0
       global2 = 0
    end where
    x = 0.; y = 0
    x(is:ie,js:je,:) = global1(is:ie,js:je,:)
    y(is:ie,js:je,:) = global2(is:ie,js:je,:)
    x1 = x; x2 = x; x3 = x; x4 = x
    y1 = y; y2 = y; y3 = y; y4 = y

    id = mpp_clock_id( type//' vector BGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x,  y,  domain, gridtype=BGRID_NE)
    call mpp_update_domains( x1, y1, domain, gridtype=BGRID_NE, complete=.false. )
    call mpp_update_domains( x2, y2, domain, gridtype=BGRID_NE, complete=.false. )
    call mpp_update_domains( x3, y3, domain, gridtype=BGRID_NE, complete=.false. )
    call mpp_update_domains( x4, y4, domain, gridtype=BGRID_NE, complete=.true.  )
    call mpp_clock_end  (id)

    !redundant points must be equal and opposite

    call compare_checksums( x,  global1(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE X' )
    call compare_checksums( y,  global2(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE Y' )
    call compare_checksums( x1, global1(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE X1' )
    call compare_checksums( x2, global1(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE X2' )
    call compare_checksums( x3, global1(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE X3' )
    call compare_checksums( x4, global1(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE X4' )
    call compare_checksums( y1, global2(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE Y1' )
    call compare_checksums( y2, global2(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE Y2' )
    call compare_checksums( y3, global2(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE Y3' )
    call compare_checksums( y4, global2(isd:ied,jsd:jed,:), trim(type2)//' BGRID_NE Y4' )

    !------------------------------------------------------------------
    !              vector update : CGRID_NE
    !------------------------------------------------------------------

    x = 0.; y = 0.
    x(is:ie,js:je,:) = global1(is:ie,js:je,:)
    y(is:ie,js:je,:) = global2(is:ie,js:je,:)
    x1 = x; x2 = x; x3 = x; x4 = x
    y1 = y; y2 = y; y3 = y; y4 = y

    id = mpp_clock_id( type//' vector CGRID_NE', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_update_domains( x,  y,  domain, gridtype=CGRID_NE)
    call mpp_update_domains( x1, y1, domain, gridtype=CGRID_NE, complete=.false. )
    call mpp_update_domains( x2, y2, domain, gridtype=CGRID_NE, complete=.false. )
    call mpp_update_domains( x3, y3, domain, gridtype=CGRID_NE, complete=.false. )
    call mpp_update_domains( x4, y4, domain, gridtype=CGRID_NE, complete=.true.  )
    call mpp_clock_end  (id)

    call compare_checksums( x,  global1(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE X' )
    call compare_checksums( y,  global2(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE Y' )
    call compare_checksums( x1, global1(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE X1' )
    call compare_checksums( x2, global1(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE X2' )
    call compare_checksums( x3, global1(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE X3' )
    call compare_checksums( x4, global1(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE X4' )
    call compare_checksums( y1, global2(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE Y1' )
    call compare_checksums( y2, global2(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE Y2' )
    call compare_checksums( y3, global2(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE Y3' )
    call compare_checksums( y4, global2(isd:ied,jsd:jed,:), trim(type2)//' CGRID_NE Y4' )

    deallocate(global1, global2, x, x1, x2, x3, x4, y, y1, y2, y3, y4)


  end subroutine test_cyclic_offset


  subroutine test_global_field( type )
    character(len=*), intent(in) :: type
    real, allocatable, dimension(:,:,:) :: x, gcheck
    type(domain2D) :: domain
    real, allocatable    :: global1(:,:,:)
    integer              :: ishift, jshift, ni, nj, i, j, position
    integer, allocatable :: pelist(:)
    integer              :: is, ie, js, je, isd, ied, jsd, jed

    !--- set up domain    
    call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
    select case(type)
    case( 'Non-symmetry' )
           call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                    shalo=shalo, nhalo=nhalo, name=type )
    case( 'Symmetry center', 'Symmetry corner', 'Symmetry east', 'Symmetry north' )
           call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                    shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. )
    case default
        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' )
    end select
    call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
        
    !--- determine if an extra point is needed
    ishift = 0; jshift = 0
    position = CENTER
    select case(type)
    case ('Symmetry corner')
       ishift = 1; jshift = 1; position=CORNER
    case ('Symmetry east')
       ishift = 1; jshift = 0; position=EAST
    case ('Symmetry north')
       ishift = 0; jshift = 1; position=NORTH
    end select

    ie  = ie+ishift;  je  = je+jshift
    ied = ied+ishift; jed = jed+jshift
    ni  = nx+ishift;  nj  = ny+jshift
    allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz))
    global1 = 0.0
    do k = 1,nz
       do j = 1,nj
          do i = 1,ni
             global1(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
    enddo

    allocate( gcheck(ni, nj, nz) )
    allocate( x (isd:ied,jsd:jed,nz) )

    x(:,:,:) = global1(isd:ied,jsd:jed,:)

    !--- test the data on data domain
    gcheck = 0.    
    id = mpp_clock_id( type//' global field on data domain', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_global_field( domain, x, gcheck, position=position )
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    call compare_checksums( global1(1:ni,1:nj,:), gcheck, type//' mpp_global_field on data domain' )

    !--- Since in the disjoint redistribute mpp test, pelist1 = (npes/2+1 .. npes-1)
    !--- will be declared. But for the x-direction global field, mpp_sync_self will
    !--- be called. For some pe count, pelist1 will be set ( only on pe of pelist1 )
    !--- in the mpp_sync_self call, later when calling mpp_declare_pelist(pelist1),
    !--- deadlock will happen. For example npes = 6 and layout = (2,3), pelist = (4,5)
    !--- will be set in mpp_sync_self. To solve the problem, some explicit mpp_declare_pelist
    !--- on all pe is needed for those partial pelist. But for y-update, it is ok. 
    !--- because the pelist in y-update is not continous.
    allocate(pelist(0:layout(1)-1))    
    do j = 0, layout(2)-1
       do i = 0, layout(1)-1
          pelist(i) = j*layout(1) + i
       end do
       call mpp_declare_pelist(pelist)
    end do
    deallocate(pelist)

    !xupdate
    gcheck = 0.
    call mpp_clock_begin(id)
    call mpp_global_field( domain, x, gcheck, flags = XUPDATE, position=position )
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    call compare_checksums( global1(1:ni,js:je,:), gcheck(1:ni,js:je,:), &
                            type//' mpp_global_field xupdate only on data domain' )

    !yupdate
    gcheck = 0.
    call mpp_clock_begin(id)
    call mpp_global_field( domain, x, gcheck, flags = YUPDATE, position=position )
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    call compare_checksums( global1(is:ie,1:nj,:), gcheck(is:ie,1:nj,:), &
                            type//' mpp_global_field yupdate only on data domain' )

    call mpp_clock_begin(id)
    call mpp_global_field( domain, x, gcheck, position=position )

    call mpp_clock_end  (id)                                          
    !compare checksums between global and x arrays  
    call compare_checksums( global1(1:ni,1:nj,:), gcheck, &
                            type//' mpp_global_field on data domain' )

    !--- test the data on compute domain
    gcheck = 0.    
    id = mpp_clock_id( type//' global field on compute domain', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    call mpp_global_field( domain, x(is:ie, js:je, :), gcheck, position=position )
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    call compare_checksums( global1(1:ni,1:nj,:), gcheck, type//' mpp_global_field on compute domain' )

    !xupdate
    gcheck = 0.
    call mpp_clock_begin(id)
    call mpp_global_field( domain, x(is:ie, js:je,:), gcheck, flags = XUPDATE, position=position )
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    call compare_checksums( global1(1:ni,js:je,:), gcheck(1:ni,js:je,:), &
                            type//' mpp_global_field xupdate only on compute domain' )

    !yupdate
    gcheck = 0.
    call mpp_clock_begin(id)
    call mpp_global_field( domain, x(is:ie, js:je,:), gcheck, flags = YUPDATE, position=position )
    call mpp_clock_end  (id)
    !compare checksums between global and x arrays
    call compare_checksums( global1(is:ie,1:nj,:), gcheck(is:ie,1:nj,:), &
                            type//' mpp_global_field yupdate only on compute domain' )


    deallocate(global1, gcheck, x)

  end subroutine test_global_field

    !--- test mpp_global_sum, mpp_global_min and mpp_global_max
  subroutine test_global_reduce (type)
    character(len=*), intent(in) :: type
    real    :: lsum, gsum, lmax, gmax, lmin, gmin
    integer :: ni, nj, ishift, jshift, position
    integer              :: is, ie, js, je, isd, ied, jsd, jed

    type(domain2D) :: domain
    real, allocatable, dimension(:,:,:) :: global1, x
    real, allocatable, dimension(:,:)   :: global2D
    !--- set up domain    
    call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
    select case(type)
    case( 'Simple' )
           call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                    shalo=shalo, nhalo=nhalo, name=type )
    case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' )
           call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, &
                                    shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. )
    case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' )
           call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
                                    name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, yflags=CYCLIC_GLOBAL_DOMAIN )
    case default
        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' )
    end select
    call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
        
    !--- determine if an extra point is needed
    ishift = 0; jshift = 0; position = CENTER
    select case(type)
    case ('Simple symmetry corner', 'Cyclic symmetry corner')
       ishift = 1; jshift = 1; position = CORNER
    case ('Simple symmetry east', 'Cyclic symmetry east' )
       ishift = 1; jshift = 0; position = EAST
    case ('Simple symmetry north', 'Cyclic symmetry north')
       ishift = 0; jshift = 1; position = NORTH
    end select

    ie  = ie+ishift;  je  = je+jshift
    ied = ied+ishift; jed = jed+jshift
    ni  = nx+ishift;  nj  = ny+jshift
    allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz))
    global1 = 0.0
    do k = 1,nz
       do j = 1,nj
          do i = 1,ni
             global1(i,j,k) = k + i*1e-3 + j*1e-6
          end do
       end do
    enddo

    !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data

    allocate( x (isd:ied,jsd:jed,nz) )
    allocate( global2D(ni,nj))

    x(:,:,:) = global1(isd:ied,jsd:jed,:)
    do j = 1, nj
       do i = 1, ni
          global2D(i,j) = sum(global1(i,j,:))
       enddo 
    enddo
    !test mpp_global_sum
   
    if(type(1:6) == 'Simple') then
       gsum = sum( global2D(1:ni,1:nj) )
    else
       gsum = sum( global2D(1:nx, 1:ny) )
    endif
    id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    lsum = mpp_global_sum( domain, x, position = position  )
    call mpp_clock_end  (id)
    if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum

    !test exact mpp_global_sum
    id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position )
    call mpp_clock_end  (id)
    !--- The following check will fail on altix in normal mode, but it is ok
    !--- in debugging mode. It is ok on irix.
    call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum')

    !test mpp_global_min
    gmin = minval(global1(1:ni, 1:nj, :))
    id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    lmin = mpp_global_min( domain, x, position = position )
    call mpp_clock_end  (id)
    call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min')

    !test mpp_global_max
    gmax = maxval(global1(1:ni, 1:nj, :))
    id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
    call mpp_clock_begin(id)
    lmax = mpp_global_max( domain, x, position = position )
    call mpp_clock_end  (id)
    call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' )

    deallocate(global1, x)

  end subroutine test_global_reduce


  subroutine test_parallel ( )
  
    integer :: npes, layout(2), i, j, k,is, ie, js, je, isd, ied, jsd, jed
    real, dimension(:,:), allocatable :: field, lfield
    real, dimension(:,:,:), allocatable :: field3d, lfield3d
    type(domain2d) :: domain
    integer, dimension(:), allocatable :: pelist1 , pelist2
    logical :: group1, group2
    character(len=128)  :: mesg
    
    npes = mpp_npes()
    allocate(pelist1(npes-mpes), pelist2(mpes))
    pelist1 = (/(i, i = 0, npes-mpes -1)/)
    pelist2 = (/(i, i = npes-mpes, npes - 1)/)
    call mpp_declare_pelist(pelist1)
    call mpp_declare_pelist(pelist2)
    group1 = .FALSE. ; group2 = .FALSE.
    if(any(pelist1==pe)) group1 = .TRUE.
    if(any(pelist2==pe)) group2 = .TRUE.
    mesg = 'parallel checking'
    
    if(group1) then
       call mpp_set_current_pelist(pelist1)
       call mpp_define_layout( (/1,nx,1,ny/), npes-mpes, layout )
    else if(group2) then
       call mpp_set_current_pelist(pelist2)
       call mpp_define_layout( (/1,nx,1,ny/), mpes, layout )
    endif
    call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)

    call mpp_set_current_pelist() 
     
     call mpp_get_compute_domain(domain, is, ie, js, je)
     call mpp_get_data_domain(domain, isd, ied, jsd, jed)
     allocate(lfield(is:ie,js:je),field(isd:ied,jsd:jed))
     allocate(lfield3d(is:ie,js:je,nz),field3d(isd:ied,jsd:jed,nz))
     
     do i = is, ie
     do j = js, je
        lfield(i,j) = real(i)+real(j)*0.001
     enddo
     enddo
     do i = is, ie
     do j = js, je
     do k = 1, nz
        lfield3d(i,j,k) = real(i)+real(j)*0.001+real(k)*0.00001
     enddo
     enddo
     enddo
     field = 0.0
     field3d = 0.0
     field(is:ie,js:je)= lfield(is:ie,js:je)
     field3d(is:ie,js:je,:) = lfield3d(is:ie,js:je,:)
     call mpp_update_domains(field,domain)
     call mpp_update_domains(field3d,domain)
     
    call mpp_check_field(field, pelist1, pelist2,domain, '2D '//mesg, w_halo = whalo, &
                            s_halo = shalo, e_halo = ehalo, n_halo = nhalo)
    call mpp_check_field(field3d, pelist1, pelist2,domain, '3D '//mesg, w_halo = whalo, &
                            s_halo = shalo, e_halo = ehalo, n_halo = nhalo)
                            
  end subroutine test_parallel
  
  subroutine test_modify_domain( )
  
    type(domain2D) :: domain2d_no_halo, domain2d_with_halo
    integer :: is1, ie1, js1, je1, isd1, ied1, jsd1, jed1
    integer :: is2, ie2, js2, je2, isd2, ied2, jsd2, jed2
    
    call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
    call mpp_define_domains( (/1,nx,1,ny/), layout, domain2d_no_halo,   &
                            yflags=CYCLIC_GLOBAL_DOMAIN, xhalo=0, yhalo=0)

    call mpp_get_compute_domain(domain2d_no_halo, is1, ie1, js1, je1)
    call mpp_get_data_domain(domain2d_no_halo, isd1, ied1, jsd1, jed1)
    call mpp_modify_domain(domain2d_no_halo, domain2d_with_halo, whalo=whalo,ehalo=ehalo,shalo=shalo,nhalo=nhalo)
    call mpp_get_compute_domain(domain2d_with_halo, is2, ie2, js2, je2)
    call mpp_get_data_domain(domain2d_with_halo, isd2, ied2, jsd2, jed2)
    if( is1 .NE. is2 .OR. ie1 .NE. ie2 .OR. js1 .NE. js2 .OR. je1 .NE. je2 ) then
        print*, "at pe ", pe, " compute domain without halo: ", is1, ie1, js1, je1, &
                " is not equal to the domain with halo ", is2, ie2, js2, je2        
        call mpp_error(FATAL, "compute domain mismatch between domain without halo and domain with halo")
    end if

    if( isd1-whalo .NE. isd2 .OR. ied1+ehalo .NE. ied2 .OR. jsd1-shalo .NE. jsd2 .OR. jed1+nhalo .NE. jed2 ) then
        print*, "at pe ", pe, "halo is w=",whalo,",e=",ehalo,",s=",shalo,"n=",nhalo, &
               ",data domain without halo is ",isd1, ied1, jsd1, jed1,                     &
               ", data domain with halo is ", isd2, ied2, jsd2, jed2 
    else
        if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, 'test_modify_domain: OK.' )
    end if

    return
    
end subroutine test_modify_domain

  subroutine compare_checksums( a, b, string )
    real, intent(in), dimension(:,:,:) :: a, b
    character(len=*), intent(in) :: string
    integer(LONG_KIND) :: sum1, sum2
    integer :: i, j, k

    ! z1l can not call mpp_sync here since there might be different number of tiles on each pe.
    ! mpp_sync()
    call mpp_sync_self()

    if(size(a,1) .ne. size(b,1) .or. size(a,2) .ne. size(b,2) .or. size(a,3) .ne. size(b,3) ) &
         call mpp_error(FATAL,'compare_chksum: size of a and b does not match')

    do k = 1, size(a,3)
       do j = 1, size(a,2)
          do i = 1, size(a,1)
             if(a(i,j,k) .ne. b(i,j,k)) then
                write(stdunit,'(a,i3,a,i3,a,i3,a,i3,a,f16.9,a,f16.9)')" at pe ", mpp_pe(), &
                     ", at point (",i,", ", j, ", ", k, "), a = ", a(i,j,k), ", b = ", b(i,j,k)
                call mpp_error(FATAL, trim(string)//': point by point comparison are not OK.')
             endif
          enddo
       enddo
    enddo

    sum1 = mpp_chksum( a, (/pe/) )
    sum2 = mpp_chksum( b, (/pe/) )

    if( sum1.EQ.sum2 )then
        if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': OK.' )
        !--- in some case, even though checksum agree, the two arrays 
        !    actually are different, like comparing (1.1,-1.2) with (-1.1,1.2)
        !--- hence we need to check the value point by point.
    else
        call mpp_error( FATAL, trim(string)//': chksums are not OK.' )
    end if
  end subroutine compare_checksums

  !###########################################################################

  subroutine compare_data_scalar( a, b, action, string )
    real,             intent(in) :: a, b
    integer,          intent(in) :: action
    character(len=*), intent(in) :: string
    if( a .EQ. b)then
        if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': data comparison are OK.' )
    else
        write(stdunit,'(a,i3,a,es12.4,a,es12.4,a,es12.4)')' on pe ', mpp_pe(),' a = ', a, ', b = ', b, ', a - b =', a-b
        call mpp_error( action, trim(string)//': data comparison are not OK.' )
    end if

  end subroutine compare_data_scalar

  subroutine test_get_neighbor_1d
    type(domain1d) :: dmn1d
    integer npes, peN, peS
    npes = mpp_npes()
    call mpp_define_domains((/1,npes/), npes, dmn1d)
    call mpp_get_neighbor_pe(dmn1d, direction=+1, pe=peN)
    call mpp_get_neighbor_pe(dmn1d, direction=-1, pe=peS)
    print '(a,i2,a,2i3)', 'PE: ', mpp_pe(), ' R/L pes: ', peN, peS
  end subroutine test_get_neighbor_1d

  subroutine test_get_neighbor_non_cyclic
    type(domain2d) :: domain
    integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
    nx = 10
    ny = 20
    halo = 2
    npes = mpp_npes()
    if( npes .NE. 8 ) then 
       call mpp_error(NOTE, 'test_mpp_domains: test_get_neighbor_non_cyclic '// &
                            ' will be performed only when npes = 8')
      return
    end if
    call mpp_define_layout( (/1,nx, 1,ny/), npes, layout )
    call mpp_define_domains((/1,nx, 1,ny/), layout, domain, xhalo=halo, yhalo=halo)
    call mpp_get_neighbor_pe(domain, direction=NORTH, pe=peN)
    call mpp_get_neighbor_pe(domain, direction=SOUTH, pe=peS)
    call mpp_get_neighbor_pe(domain, direction=EAST, pe=peE)
    call mpp_get_neighbor_pe(domain, direction=WEST, pe=peW)
    call mpp_get_neighbor_pe(domain, direction=NORTH_EAST, pe=peNE)
    call mpp_get_neighbor_pe(domain, direction=NORTH_WEST, pe=peNW)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_EAST, pe=peSE)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_WEST, pe=peSW)
    print '(a,i2,a,2i2,a,8i3)','PE: ', mpp_pe(), ' layout (non-cyclic): ', layout,  &
         & ' N/S/E/W/NE/SE/SW/NW pes: ', peN, peS, peE, peW, peNE, peSE, peSW, peNW
  end subroutine test_get_neighbor_non_cyclic

  subroutine test_get_neighbor_cyclic
    type(domain2d) :: domain
    integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
    nx = 10
    ny = 20
    halo = 2
    npes = mpp_npes()
    if( npes .NE. 8 ) then 
       call mpp_error(NOTE, 'test_mpp_domains: test_get_neighbor_cyclic '// &
                            ' will be performed only when npes = 8')
      return
    end if
    call mpp_define_layout( (/1,nx, 1,ny/), npes, layout )
    call mpp_define_domains((/1,nx, 1,ny/), layout, domain, xhalo=halo, yhalo=halo, &
         xflags=CYCLIC_GLOBAL_DOMAIN, yflags=CYCLIC_GLOBAL_DOMAIN)
    call mpp_get_neighbor_pe(domain, direction=NORTH, pe=peN)
    call mpp_get_neighbor_pe(domain, direction=SOUTH, pe=peS)
    call mpp_get_neighbor_pe(domain, direction=EAST, pe=peE)
    call mpp_get_neighbor_pe(domain, direction=WEST, pe=peW)
    call mpp_get_neighbor_pe(domain, direction=NORTH_EAST, pe=peNE)
    call mpp_get_neighbor_pe(domain, direction=NORTH_WEST, pe=peNW)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_EAST, pe=peSE)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_WEST, pe=peSW)
    print '(a,i2,a,2i2,a,8i3)','PE: ', mpp_pe(), ' layout (cyclic)    : ', layout, & 
         & ' N/S/E/W/NE/SE/SW/NW pes: ', peN, peS, peE, peW, peNE, peSE, peSW, peNW
  end subroutine test_get_neighbor_cyclic

  subroutine test_get_neighbor_folded_north
    type(domain2d) :: domain
    integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
    nx = 10
    ny = 20
    halo = 2
    npes = mpp_npes()
    if( npes .NE. 8 ) then 
       call mpp_error(NOTE, 'test_mpp_domains: test_get_neighbor_folded_north '// &
                            ' will be performed only when npes = 8')
      return
    end if
    call mpp_define_layout( (/1,nx, 1,ny/), npes, layout )
    call mpp_define_domains((/1,nx, 1,ny/), layout, domain, xhalo=halo, yhalo=halo, &
         xflags=CYCLIC_GLOBAL_DOMAIN, yflags=FOLD_NORTH_EDGE)
    call mpp_get_neighbor_pe(domain, direction=NORTH, pe=peN)
    call mpp_get_neighbor_pe(domain, direction=SOUTH, pe=peS)
    call mpp_get_neighbor_pe(domain, direction=EAST, pe=peE)
    call mpp_get_neighbor_pe(domain, direction=WEST, pe=peW)
    call mpp_get_neighbor_pe(domain, direction=NORTH_EAST, pe=peNE)
    call mpp_get_neighbor_pe(domain, direction=NORTH_WEST, pe=peNW)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_EAST, pe=peSE)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_WEST, pe=peSW)
    print '(a,i2,a,2i2,a,8i3)','PE: ', mpp_pe(), ' layout (folded N)  : ', layout, & 
         & ' N/S/E/W/NE/SE/SW/NW pes: ', peN, peS, peE, peW, peNE, peSE, peSW, peNW
  end subroutine test_get_neighbor_folded_north

  subroutine test_get_neighbor_mask
    logical, allocatable ::  mask(:,:)
    integer :: im, jm, n_remove
    type(domain2d) :: domain
    integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
    nx = 10
    ny = 20
    halo = 2
    npes = mpp_npes()
    
    n_remove = 2
    if( npes .NE. 8 ) then 
       call mpp_error(NOTE, 'test_mpp_domains: test_get_neighbor_mask '// &
                            ' will be performed only when npes = 8')
      return
    end if
    call mpp_define_layout( (/1,nx, 1,ny/), npes+n_remove, layout )
    allocate(mask(layout(1), layout(2)))
    mask = .TRUE.  ! activate domains
    im = min(layout(1), ceiling(layout(1)/2.0))
    jm = min(layout(2), ceiling(layout(2)/2.0))
    mask(im  ,jm  ) = .FALSE. ! deactivate domain
    mask(im  ,jm-1) = .FALSE. ! deactivate domain
    print '(a,2i3,a,2i3)', 'Masked out domains ', im, jm, ' and ', im,jm-1
    call mpp_define_domains((/1,nx, 1,ny/), layout, domain, xhalo=halo, yhalo=halo, &
         maskmap=mask)
    call mpp_get_neighbor_pe(domain, direction=NORTH, pe=peN)
    call mpp_get_neighbor_pe(domain, direction=SOUTH, pe=peS)
    call mpp_get_neighbor_pe(domain, direction=EAST, pe=peE)
    call mpp_get_neighbor_pe(domain, direction=WEST, pe=peW)
    call mpp_get_neighbor_pe(domain, direction=NORTH_EAST, pe=peNE)
    call mpp_get_neighbor_pe(domain, direction=NORTH_WEST, pe=peNW)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_EAST, pe=peSE)
    call mpp_get_neighbor_pe(domain, direction=SOUTH_WEST, pe=peSW)
    print '(a,i3,a,2i3,a,8i3)','PE: ', mpp_pe(), ' layout (mask   )  : ', layout, & 
         & ' N/S/E/W/NE/SE/SW/NW pes: ', peN, peS, peE, peW, peNE, peSE, peSW, peNW
  end subroutine test_get_neighbor_mask

  subroutine test_define_mosaic_pelist(type, ntile)
    character(len=*),       intent(in) :: type
    integer,                intent(in) :: ntile
    integer                            :: npes, root_pe, start_pe, n, ntile_per_pe
    integer, dimension(:), allocatable :: pe1_start, pe1_end, pe2_start, pe2_end
    integer, dimension(:), allocatable :: sizes, costpertile

    root_pe = mpp_root_pe()
    npes = mpp_npes()

    allocate(sizes(ntile), pe1_start(ntile), pe1_end(ntile), pe2_start(ntile), pe2_end(ntile),costpertile(ntile) )
    costpertile = 1
    sizes = nx*ny
    if(npes ==1) then
       pe1_start = root_pe; pe1_end = root_pe
    end if
    select case(type)
    case('One tile')
       pe1_start = root_pe; pe1_end = npes+root_pe-1
    case('Two uniform tile')
       if(mod(npes,2) .NE. 0 .AND. npes .NE. 1) then
          call mpp_error(NOTE, 'test_define_mosaic_pelist: npes can not be divided by 2, no test for '//type )
          return
       end if
       if(npes .NE. 1) then
          pe1_start(1) = root_pe;        pe1_end(1) = npes/2+root_pe-1
          pe1_start(2) = npes/2+root_pe; pe1_end(2) = npes+root_pe-1       
       end if
    case('Two nonuniform tile')
       if(mod(npes,3) .NE. 0 .AND. npes .NE. 1) then
          call mpp_error(NOTE, 'test_define_mosaic_pelist: npes can not be divided by 3, no test for '//type )
          return
       end if
       sizes(1) = 2*nx*ny
       if(npes .NE. 1) then
          pe1_start(1) = root_pe;          pe1_end(1) = npes/3*2+root_pe-1
          pe1_start(2) = npes/3*2+root_pe; pe1_end(2) = npes+root_pe-1
       end if
    case('Ten tile')
       if(mod(npes,10) .NE. 0 .AND. npes .NE. 1 .AND. mod(10,npes) .NE. 0) then
          call mpp_error(NOTE, 'test_define_mosaic_pelist: npes can not be divided by 10(or reverse), no test for '//type )
          return
       end if
       if(mod(10, npes)==0) then
          ntile_per_pe = ntile/npes          
          do n = 1, ntile
             pe1_start(n) = root_pe+(n-1)/ntile_per_pe; pe1_end(n) = pe1_start(n)
          end do
       else if(mod(npes,10) == 0) then
          do n = 1, ntile
             pe1_start(n) = npes/10*(n-1)+root_pe; pe1_end(n) = npes/10*n+root_pe-1
          end do
       end if
    case('Ten tile with nonuniform cost')
       if(mod(npes,15) .NE. 0 .AND. npes .NE. 1) then
          call mpp_error(NOTE, 'test_define_mosaic_pelist: npes can not be divided by 15, no test for '//type )
          return
       end if
       costpertile(1:5) = 2; costpertile(6:ntile) = 1
       if(npes .NE. 1) then
          start_pe = root_pe
          do n = 1, ntile
             pe1_start(n) = start_pe
             pe1_end(n)   = start_pe + npes/15*costpertile(n)-1
             start_pe = pe1_end(n) + 1
          end do
       end if
    case default
       call mpp_error(FATAL,"test_define_mosaic_pelist: "//type//" is an invalid type")
    end select

    call mpp_define_mosaic_pelist( sizes, pe2_start, pe2_end, costpertile=costpertile)
    if( ANY(pe1_start .NE. pe2_start) .OR. ANY(pe1_end .NE. pe2_end) ) then
       call mpp_error(FATAL,"test_define_mosaic_pelist: test failed for "//trim(type) )
    else
       call mpp_error(NOTE,"test_define_mosaic_pelist: test successful for "//trim(type) )
    end if

  end subroutine test_define_mosaic_pelist

end program test
#else
module null_mpp_domains_test
end module
#endif


#ifdef test_mpp_io
program test
#include <fms_platform.h>

  use mpp_mod,         only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self
  use mpp_mod,         only : FATAL, NOTE, mpp_chksum, MPP_DEBUG, mpp_set_stack_size, MPP_CLOCK_SYNC
  use mpp_mod,         only : mpp_sync, mpp_exit, mpp_clock_begin, mpp_clock_end, mpp_clock_id
  use mpp_domains_mod, only : mpp_define_domains, mpp_domains_set_stack_size, domain1D, mpp_get_global_domain
  use mpp_domains_mod, only : domain2D, mpp_define_layout, mpp_get_domain_components, mpp_define_mosaic
  use mpp_domains_mod, only : mpp_get_memory_domain, mpp_get_compute_domain, mpp_domains_exit
  use mpp_domains_mod, only : CENTER, EAST, NORTH, CORNER, mpp_get_data_domain
  use mpp_domains_mod, only : mpp_define_io_domain, mpp_deallocate_domain
  use mpp_io_mod,      only : mpp_io_init, mpp_write_meta, axistype, fieldtype, atttype
  use mpp_io_mod,      only : MPP_RDONLY, mpp_open, MPP_OVERWR, MPP_ASCII, MPP_SINGLE
  use mpp_io_mod,      only : MPP_NETCDF, MPP_MULTI, mpp_get_atts, mpp_write, mpp_close
  use mpp_io_mod,      only : mpp_get_info, mpp_get_axes, mpp_get_fields, mpp_get_times
  use mpp_io_mod,      only : mpp_read, mpp_io_exit

  implicit none

#ifdef use_netCDF
#include <netcdf.inc>
#endif

  !--- namelist definition
  integer           :: nx=128, ny=128, nz=40, nt=2
  integer           :: halo=2, stackmax=1500000, stackmaxd=500000
  logical           :: debug=.FALSE.  
  character(len=64) :: file='test', iospec='-F cachea'
  integer           :: layout(2) = (/0,0/)
  integer           :: ntiles_x=1, ntiles_y=1  ! total number of tiles will be ntiles_x*ntiles_y,
                                               ! the grid size for each tile will be (nx/ntiles_x, ny/ntiles_y) 
                                               ! set ntiles > 1 to test the efficiency of mpp_io.
  integer           :: io_layout(2) = (/0,0/)  ! set io_layout to divide each tile into io_layout(1)*io_layout(2)
                                               ! group and write out data from the root pe of each group.

  namelist / test_mpp_io_nml / nx, ny, nz, nt, halo, stackmax, stackmaxd, debug, file, iospec, &
                               ntiles_x, ntiles_y, layout, io_layout

  integer        :: pe, npes
  type(domain2D) :: domain

  integer            :: tks_per_sec
  integer            :: i,j,k, unit=7
  integer            :: id_single_tile_mult_file
  integer            :: id_mult_tile, id_single_tile_with_group, id_mult_tile_with_group
  logical            :: opened
  character(len=64)  :: varname

  real(DOUBLE_KIND)  :: time
  type(axistype)     :: x, y, z, t
  type(fieldtype)    :: f
  type(domain1D)     :: xdom, ydom
  integer(LONG_KIND) :: rchk, chk

  call mpp_init() 
  pe = mpp_pe()
  npes = mpp_npes()

  do
     inquire( unit=unit, opened=opened )
     if( .NOT.opened )exit
     unit = unit + 1
     if( unit.EQ.100 )call mpp_error( FATAL, 'Unable to locate unit number.' )
  end do
  open( unit=unit, status='OLD', file='input.nml', err=10 )
  read( unit,test_mpp_io_nml )
  close(unit)
10 continue

  call SYSTEM_CLOCK( count_rate=tks_per_sec )
  if( debug )then
      call mpp_io_init(MPP_DEBUG)
  else
      call mpp_io_init()
  end if
  call mpp_set_stack_size(stackmax)
  call mpp_domains_set_stack_size(stackmaxd)

  if( pe.EQ.mpp_root_pe() )then
      print '(a,6i6)', 'npes, nx, ny, nz, nt, halo=', npes, nx, ny, nz, nt, halo
      print *, 'Using NEW domaintypes and calls...'
  end if

  write( file,'(a,i3.3)' )trim(file), npes

  if(ntiles_x == 1 .and. ntiles_y == 1 .and. io_layout(1) == 1 .and. io_layout(2) == 1) then
     call test_netcdf_io('Simple')
     call test_netcdf_io('Symmetry_T_cell')
     call test_netcdf_io('Symmetry_E_cell')
     call test_netcdf_io('Symmetry_N_cell')
     call test_netcdf_io('Symmetry_C_cell')
     call test_netcdf_io('Symmetry_T_cell_memory')
     call test_netcdf_io('Symmetry_E_cell_memory')
     call test_netcdf_io('Symmetry_N_cell_memory')
     call test_netcdf_io('Symmetry_C_cell_memory')
  else
     if(io_layout(1) <1 .OR. io_layout(2) <1) call mpp_error(FATAL, &
            "program test_mpp_io: both elements of test_mpp_io_nml variable io_layout must be positive integer")
     if(ntiles_x <1 .OR. ntiles_y <1) call mpp_error(FATAL, &
            "program test_mpp_io: mpp_io_nml variable ntiles_x and ntiles_y must be positive integer")
     if(mod(nx, ntiles_x) .NE. 0) call mpp_error(FATAL, &
            "program test_mpp_io: nx must be divided by ntiles_x")
     if(mod(ny, ntiles_y) .NE. 0) call mpp_error(FATAL, &
            "program test_mpp_io: ny must be divided by ntiles_y")
     if(mod(npes, ntiles_x*ntiles_y) .NE. 0) call mpp_error(FATAL, &
            "program test_mpp_io: npes should be divided by ntiles = ntiles_x*ntiles_y ")
     if(layout(1) * layout(2) .NE. npes) call mpp_error(FATAL, &
            "program test_mpp_io: npes should equal to layout(1)*layout(2)" )
     if(mod(layout(1), io_layout(1)) .NE. 0 ) call mpp_error(FATAL, &
            "program test_mpp_io: layout(1) must be divided by io_layout(1)")
     if(mod(layout(2), io_layout(2)) .NE. 0 )call mpp_error(FATAL, &
            "program test_mpp_io: layout(2) must be divided by io_layout(2)")

     id_single_tile_mult_file = mpp_clock_id('Single Tile Multiple File', flags=MPP_CLOCK_SYNC)
     call mpp_clock_begin(id_single_tile_mult_file)
     call test_netcdf_io_mosaic('Single_tile_mult_file', layout, 1, 1, (/1,1/) )
     call mpp_clock_end(id_single_tile_mult_file)

     if(io_layout(1) >1 .OR. io_layout(2) > 1) then
        id_single_tile_with_group = mpp_clock_id('Single Tile With Group', flags=MPP_CLOCK_SYNC)
        call mpp_clock_begin(id_single_tile_with_group)
        call test_netcdf_io_mosaic('Single_tile_with_group', layout, 1, 1, io_layout)
        call mpp_clock_end(id_single_tile_with_group)
     endif

     id_mult_tile  = mpp_clock_id('Multiple Tile', flags=MPP_CLOCK_SYNC)
     call mpp_clock_begin(id_mult_tile)
     if(ntiles_x > 1 .OR. ntiles_y > 1) then
        call test_netcdf_io_mosaic('Mult_tile', layout, ntiles_x, ntiles_y, (/1,1/))
     else
        call test_netcdf_io_mosaic('Mult_tile', layout, io_layout(1), io_layout(2), (/1,1/) )
     endif
     call mpp_clock_end(id_mult_tile)

     if( (io_layout(1) >1 .OR. io_layout(2) > 1) .AND. (ntiles_x >1 .OR. ntiles_y > 1) ) then
        id_mult_tile_with_group = mpp_clock_id('Multiple Tile With Group', flags=MPP_CLOCK_SYNC)
        call mpp_clock_begin(id_mult_tile_with_group)
        call test_netcdf_io_mosaic('Mult_tile_with_group', layout, ntiles_x, ntiles_y, io_layout)
        call mpp_clock_end(id_mult_tile_with_group)
     endif
  endif

  call mpp_io_exit()
  call mpp_domains_exit()
  call mpp_exit()

  contains

  !------------------------------------------------------------------

  subroutine test_netcdf_io(type)
  character(len=*), intent(in) :: type
  integer :: ndim, nvar, natt, ntime
  integer :: is, ie, js, je, isd, ied, jsd, jed, ism, iem, jsm, jem
  integer :: position, msize(2), ioff, joff, nxg, nyg
  logical :: symmetry
  type(atttype),          allocatable :: atts(:)
  type(fieldtype),        allocatable :: vars(:)
  type(axistype),         allocatable :: axes(:)
  real(DOUBLE_KIND),      allocatable :: tstamp(:)
  real, dimension(:,:,:), allocatable :: data, gdata, rdata

  !--- determine the shift and symmetry according to type, 
  select case(type)
  case('Simple')
     position = CENTER; symmetry = .false.
  case('Symmetry_T_cell', 'Symmetry_T_cell_memory')
     position = CENTER; symmetry = .true.
  case('Symmetry_E_cell', 'Symmetry_E_cell_memory')
     position = EAST;   symmetry = .true.
  case('Symmetry_N_cell', 'Symmetry_N_cell_memory')
     position = NORTH;  symmetry = .true.
  case('Symmetry_C_cell', 'Symmetry_C_cell_memory')
     position = CORNER; symmetry = .true.
  case default
     call mpp_error(FATAL, "type = "//type//" is not a valid test type")
  end select

!define domain decomposition
  call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
  if(index(type,"memory") == 0) then  
     call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=halo, yhalo=halo, symmetry = symmetry )
  else  ! on memory domain
     msize(1) = nx/layout(1) + 2*halo + 2
     msize(2) = ny/layout(2) + 2*halo + 2
     call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=halo, yhalo=halo, symmetry = symmetry, &
                              memory_size = msize )
  end if

  call mpp_get_compute_domain( domain, is,  ie,  js,  je, position=position  )
  call mpp_get_data_domain   ( domain, isd, ied, jsd, jed, position=position )
  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
  call mpp_get_global_domain ( domain, xsize=nxg, ysize=nyg, position=position )
  call mpp_get_domain_components( domain, xdom, ydom )

!define global data array
  allocate( gdata(nxg,nyg,nz) )
  gdata = 0.
  do k = 1,nz
     do j = 1,nyg
        do i = 1,nxg
           gdata(i,j,k) = k + i*1e-3 + j*1e-6
        end do
     end do
  end do

  ioff = ism - isd; joff = jsm - jsd
  allocate( data(ism:iem,jsm:jem,nz) )
  data = 0
  data(is+ioff:ie+ioff,js+joff:je+joff,:) = gdata(is:ie,js:je,:)

!tests

!sequential write: single-threaded formatted: only if small
  if( nx*ny*nz*nt.LT.1000 .AND. index(type,"memory") .NE. 0 )then
      if( pe.EQ.mpp_root_pe() )print *, 'sequential write: single-threaded formatted'
!here the only test is a successful write: please look at test.txt for verification.
      call mpp_open( unit, trim(file)//'s.txt', action=MPP_OVERWR, form=MPP_ASCII, threading=MPP_SINGLE )
      call mpp_write_meta( unit, x, 'X', 'km', 'X distance', domain=xdom, data=(/(i-1.,i=1,nxg)/) )
      call mpp_write_meta( unit, y, 'Y', 'km', 'Y distance', domain=ydom, data=(/(i-1.,i=1,nyg)/) )
      call mpp_write_meta( unit, z, 'Z', 'km', 'Z distance',              data=(/(i-1.,i=1,nz)/) )
      call mpp_write_meta( unit, t, 'T', 'sec', 'Time' )
      call mpp_write_meta( unit, f, (/x,y,z,t/), 'Data', 'metres', 'Random data' )
      call mpp_write( unit, x )
      call mpp_write( unit, y )
      call mpp_write( unit, z )
      do i = 0,nt-1
         time = i*10.
         call mpp_write( unit, f, domain, data, time )
      end do
      call mpp_close(unit)
  end if

!netCDF distributed write
  if( pe.EQ.mpp_root_pe() )print *, 'netCDF distributed write'
  call mpp_open( unit, trim(type)//"_"//trim(file)//'d', action=MPP_OVERWR, &
                 form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI )
  call mpp_write_meta( unit, x, 'X', 'km', 'X distance', 'X', domain=xdom, data=(/(i-1.,i=1,nxg)/) )
  call mpp_write_meta( unit, y, 'Y', 'km', 'Y distance', 'Y', domain=ydom, data=(/(i-1.,i=1,nyg)/) )
  call mpp_write_meta( unit, z, 'Z', 'km', 'Z distance', 'Z', data=(/(i-1.,i=1,nz)/) )
  call mpp_write_meta( unit, t, 'T', 'sec', 'Time', 'T' )
  call mpp_write_meta( unit, f, (/x,y,z,t/), 'Data', 'metres', 'Random data', pack=1 )
  call mpp_write( unit, x )
  call mpp_write( unit, y )
  call mpp_write( unit, z )
  do i = 0,nt-1
     time = i*10.
     call mpp_write( unit, f, domain, data, time )
  end do
  call mpp_close(unit)
  
!netCDF single-threaded write
  if( pe.EQ.mpp_root_pe() )print *, 'netCDF single-threaded write'
  call mpp_open( unit, trim(type)//"_"//trim(file)//'s', action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_SINGLE )

  call mpp_write_meta( unit, x, 'X', 'km', 'X distance', 'X', domain=xdom, data=(/(i-1.,i=1,nxg)/) )

  call mpp_write_meta( unit, y, 'Y', 'km', 'Y distance', 'Y', domain=ydom, data=(/(i-1.,i=1,nyg)/) )
  call mpp_write_meta( unit, z, 'Z', 'km', 'Z distance', 'Z',              data=(/(i-1.,i=1,nz)/) )
  call mpp_write_meta( unit, t, 'T', 'sec', 'Time', 'T' )
  call mpp_write_meta( unit, f, (/x,y,z,t/), 'Data', 'metres', 'Random data', pack=1 )

  call mpp_write( unit, x )
  call mpp_write( unit, y )
  call mpp_write( unit, z )

  do i = 0,nt-1
     time = i*10.
     call mpp_write( unit, f, domain, data, time)
  end do
  call mpp_close(unit)
  allocate( rdata(is:ie,js:je,nz) )

!netCDF multi-threaded read
  if( pe.EQ.mpp_root_pe() )print *, 'netCDF multi-threaded read'
  call mpp_sync()
  call mpp_open( unit, trim(type)//"_"//trim(file)//'s', action=MPP_RDONLY,  &
                 form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_SINGLE )
  call mpp_get_info( unit, ndim, nvar, natt, ntime )
  allocate( atts(natt) )
  allocate( axes(ndim) )
  allocate( vars(nvar) )
  allocate( tstamp(ntime) )
  call mpp_get_atts ( unit, atts(:) )
  call mpp_get_axes ( unit, axes(:) )
  call mpp_get_fields ( unit, vars(:) )
  call mpp_get_times( unit, tstamp(:) )

  call mpp_get_atts(vars(1),name=varname)

  if( varname.NE.'Data' )call mpp_error( FATAL, 'File being read is not the expected one.' )
  call mpp_read( unit, vars(1), domain, rdata, 1 )
  rchk = mpp_chksum(rdata(is:ie,js:je,:))
  chk  = mpp_chksum( data(is+ioff:ie+ioff,js+joff:je+joff,:))
  if( pe.EQ.mpp_root_pe() )print '(a,2z18)', trim(type)//' checksum=', rchk, chk
  if( rchk == chk ) then
      if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(type)//': single-fileset: data comparison are OK.' )
  else
      call mpp_error( FATAL, 'Checksum error on multi-threaded/single-fileset netCDF read for type ' &
               //trim(type) )
  end if

  deallocate( atts, axes, vars, tstamp )

!netCDF distributed read
  if( pe.EQ.mpp_root_pe() )print *, 'netCDF multi-threaded read'
  call mpp_sync()               !wait for previous write to complete
  call mpp_open( unit, trim(type)//"_"//trim(file)//'d', action=MPP_RDONLY,  &
                 form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI )
  call mpp_get_info( unit, ndim, nvar, natt, ntime )
  allocate( atts(natt) )
  allocate( axes(ndim) )
  allocate( vars(nvar) )
  allocate( tstamp(ntime) )
  call mpp_get_atts ( unit, atts(:) )
  call mpp_get_axes ( unit, axes(:) )
  call mpp_get_fields ( unit, vars(:) )
  call mpp_get_times( unit, tstamp(:) )

  call mpp_get_atts(vars(1),name=varname)
  rdata = 0

  if( varname.NE.'Data' )call mpp_error( FATAL, 'File being read is not the expected one.' )

  call mpp_read( unit, vars(1), domain, rdata, 1 )

  rchk = mpp_chksum(rdata(is:ie,js:je,:))
  chk  = mpp_chksum( data(is+ioff:ie+ioff,js+joff:je+joff,:))
  if( pe.EQ.mpp_root_pe() )print '(a,2z18)', trim(type)//' checksum=', rchk, chk
  if( rchk == chk ) then
      if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(type)//': multi-fileset: data comparison are OK.' )
  else
      call mpp_error( FATAL, 'Checksum error on multi-threaded/multi-fileset netCDF read for type ' &
           //trim(type) )
  end if

  deallocate( atts, axes, vars, tstamp )

  deallocate( rdata, gdata, data)

  end subroutine test_netcdf_io


  subroutine test_netcdf_io_mosaic(type, layout, ntiles_x, ntiles_y, io_layout)
  character(len=*), intent(in) :: type
  integer,          intent(in) :: layout(:)
  integer,          intent(in) :: io_layout(:)
  integer,          intent(in) :: ntiles_x, ntiles_y

  integer                              :: ndim, nvar, natt, ntime
  integer                              :: isc, iec, jsc, jec, nlon, nlat, n, i, j
  integer                              :: my_tile, ncontacts, npes_per_tile, ntiles
  integer, dimension(:),   allocatable :: tile1, istart1, iend1, jstart1, jend1
  integer, dimension(:),   allocatable :: tile2, istart2, iend2, jstart2, jend2
  integer, dimension(:),   allocatable :: pe_start, pe_end
  integer, dimension(:,:), allocatable :: layout2D, global_indices
  character(len=64)                    :: output_file
  logical                              :: is_root_pe
  real, dimension(:,:,:), allocatable  :: data, rdata
  type(fieldtype), save                :: vars(1)
  integer                              :: id_clock_read, id_clock_write

  ! first get number of tiles of this mosaic. when there is one tile,
  ! the file will be read/write using distributed file.
  ! when there is more than one tile, single fileset will be used
  npes = mpp_npes()
  
  id_clock_read  = mpp_clock_id(trim(type)//" read", flags=MPP_CLOCK_SYNC)
  id_clock_write = mpp_clock_id(trim(type)//" write", flags=MPP_CLOCK_SYNC)

  ncontacts = 0
  ntiles = ntiles_x*ntiles_y

  npes_per_tile = npes/ntiles
  my_tile       = mpp_pe()/npes_per_tile + 1
  is_root_pe = .false.
  if(mpp_pe() == (my_tile-1)*npes_per_tile ) is_root_pe = .true.

  allocate(layout2D(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
  !--- for simplify purpose, we assume all the tiles have the same size.
  do n = 1, ntiles
     pe_start(n) = (n-1)*npes_per_tile
     pe_end(n)   = n*npes_per_tile-1
  end do
  if(ntiles>1) then
     nlon = nx/ntiles_x
     nlat = ny/ntiles_y
  else
     nlon = nx
     nlat = ny
  endif
  
  do n = 1, ntiles
     global_indices(:,n) = (/1,nlon,1,nlat/)
     layout2D(1,n)         = layout(1)/ntiles_x
     layout2D(2,n)         = layout(2)/ntiles_y
  end do

  call mpp_define_mosaic(global_indices, layout2D, domain, ntiles, ncontacts, tile1, tile2, &
                         istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, pe_end, &
                         name = type)
  call mpp_get_compute_domain( domain, isc,  iec,  jsc,  jec  )
  call mpp_get_domain_components(domain, xdom, ydom)
  allocate( data (isc:iec,jsc:jec,nz) )
  allocate( rdata(isc:iec,jsc:jec,nz) )
  do k = 1,nz
     do j = jsc, jec
        do i = isc, iec
           data(i,j,k)  = k + i*1e-3 + j*1e-6
        enddo
     enddo
  enddo

  !--- netcdf distribute write if ntiles = 1, otherwise single-thread write
  output_file = type
  select case(type)
  case("Single_tile_single_file")
     call mpp_open( unit, output_file, action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_SINGLE, fileset=MPP_SINGLE )
  case("Single_tile_mult_file")
     call mpp_open( unit, output_file, action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI )
  case("Mult_tile")
     write(output_file, '(a,I4.4)') type//'.tile', my_tile
     call mpp_open( unit, output_file, action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_SINGLE, is_root_pe=is_root_pe )
  case("Single_tile_with_group")
     call mpp_define_io_domain(domain, io_layout)
     call mpp_open( unit, output_file, action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI, domain=domain)
  case("Mult_tile_with_group")
     write(output_file, '(a,I4.4)') type//'.tile', my_tile
     call mpp_define_io_domain(domain, io_layout)
     call mpp_open( unit, output_file, action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI, domain=domain)

  case default
     call mpp_error(FATAL, "program test_mpp_io: invaid value of type="//type)
  end select  

  call mpp_write_meta( unit, x, 'X', 'km', 'X distance', 'X', domain=xdom, data=(/(i-1.,i=1,nlon)/) )
  call mpp_write_meta( unit, y, 'Y', 'km', 'Y distance', 'Y', domain=ydom, data=(/(i-1.,i=1,nlat)/) )
  call mpp_write_meta( unit, z, 'Z', 'km', 'Z distance', 'Z', data=(/(i-1.,i=1,nz)/) )
  call mpp_write_meta( unit, t, 'T', 'sec', 'Time', 'T' )
  call mpp_write_meta( unit, f, (/x,y,z,t/), 'Data', 'metres', 'Random data', pack=1 )
  call mpp_write( unit, x )
  call mpp_write( unit, y )
  call mpp_write( unit, z )
  call mpp_clock_begin(id_clock_write)
  do i = 0,nt-1
     time = i*10.
     call mpp_write( unit, f, domain, data, time )
  end do
  call mpp_clock_end(id_clock_write)
  call mpp_close(unit)
  
  call mpp_sync()               !wait for previous write to complete

  select case(type)
  case("Single_tile_single_file")
     call mpp_open( unit, output_file, action=MPP_RDONLY, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_SINGLE )
  case("Single_tile_mult_file")
     call mpp_open( unit, output_file, action=MPP_RDONLY, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI )
  case("Mult_tile")
     call mpp_open( unit, output_file, action=MPP_RDONLY, form=MPP_NETCDF, threading=MPP_MULTI, &
         fileset=MPP_SINGLE, is_root_pe=is_root_pe )
  case("Single_tile_with_group", "Mult_tile_with_group")
     call mpp_open( unit, output_file, action=MPP_RDONLY, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI, domain=domain)
  case default
     call mpp_error(FATAL, "program test_mpp_io: invaid value of type="//type)
  end select  

  call mpp_get_info( unit, ndim, nvar, natt, ntime )
  call mpp_get_fields ( unit, vars(:) )
  call mpp_get_atts(vars(1),name=varname)

  if( varname.NE.'Data' )call mpp_error( FATAL, 'File being read is not the expected one.' )
  call mpp_clock_begin(id_clock_read)
  do i = 0,nt-1
     call mpp_read( unit, vars(1), domain, rdata, 1 )
  enddo
  call mpp_clock_end(id_clock_read)
  rchk = mpp_chksum(rdata)
  chk  = mpp_chksum( data)
  if( pe.EQ.mpp_root_pe() )print '(a,2z18)', trim(type)//' checksum=', rchk, chk
  if( rchk == chk ) then
      if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(type)//': data comparison are OK.' )
  else
      call mpp_error( FATAL, 'Checksum error on netCDF read for type ' &
               //trim(type) )
  end if

!  deallocate( vars)

  deallocate( rdata, data)
  call mpp_deallocate_domain(domain)

  end subroutine test_netcdf_io_mosaic

end program test

#else
module null_mpp_io_test
end module
#endif


#ifdef test_mpp_pset
#include <fms_platform.h>
program test
  use mpp_mod, only: mpp_init, mpp_exit, mpp_pe, mpp_npes, stderr, stdout, &
       mpp_clock_id, mpp_clock_begin, mpp_clock_end
  use mpp_pset_mod, only: mpp_pset_type, mpp_pset_create, mpp_pset_root, &
       mpp_pset_broadcast_ptr, mpp_pset_segment_array, mpp_pset_sync, &
       mpp_pset_stack_push, mpp_pset_print_chksum, mpp_pset_delete
  implicit none
!test program demonstrates how to create PSETs
!  how to distribute allocatable arrays
!  how to distribute automatic arrays
  integer, parameter :: n=96 !divisible by lots of numbers
  real, allocatable, dimension(:,:,:) :: a, b, cc
  real :: c(n,n,n)
#ifdef use_CRI_pointers
  pointer( ptr_c, c )
#endif
  integer(POINTER_KIND) :: ptr !useless declaration, but it will compile
  integer :: i, j, k, ks, ke
!MPP
  integer :: pe, npes
!MPP_PSET
  type(mpp_pset_type) :: pset
  logical :: root
!clocks
  integer :: id_full, id_alloc, id_auto

  call mpp_init()
  pe = mpp_pe()
  npes = mpp_npes()
  write( stdout(),'(a,i6)' )'Starting MPP_PSET unit test, npes=', npes
  call mpp_pset_create( npes, pset )
  root = mpp_pset_root(pset)
  id_full = mpp_clock_id( 'Full array' )
  id_alloc = mpp_clock_id( 'Allocatable array, PSETs' )
  id_auto = mpp_clock_id( 'Automatic array, PSETs' )
!allocate a and b
  allocate( a(n,n,n) )
  allocate( b(n,n,n) )
!allocate shared array c
  if( root )then
      allocate( cc(n,n,n) )
#ifdef use_CRI_pointers
      ptr = LOC(cc)
#endif
  end if
  call mpp_pset_broadcast_ptr( pset, ptr )
#ifdef use_CRI_pointers
  ptr_c = ptr
#endif
!initialize a and b
  call RANDOM_NUMBER(a)
  call mpp_clock_begin(id_full)
  do k = 1,n
     do j = 1,n
        do i = 1,n
           b(i,j,k) = 2*a(i,j,k)
        end do
     end do
  end do
  call mpp_clock_end(id_full)
!divide up among PSETs
  call mpp_pset_segment_array( pset, 1, n, ks, ke )
  write( stderr(),'(a,4i6)' )'pe, n, ks, ke=', pe, n, ks, ke
  call mpp_clock_begin(id_alloc)
  do k = ks,ke
     do j = 1,n
        do i = 1,n
           c(i,j,k) = 2*a(i,j,k)
        end do
     end do
  end do
  call mpp_pset_sync(pset)
  call mpp_clock_end(id_alloc)
  write( stderr(),'(a,i6,2es23.15)' )'b, c should be equal: pe b c=', &
       pe, sum(b), sum(c)
  call mpp_pset_print_chksum( pset, 'test_alloc', c(:,:,ks:ke) )
  call test_auto(n)
  call mpp_pset_delete(pset)
  call mpp_exit()

contains

  subroutine test_auto(m)
!same test as above, on auto array d
!this is how you create shared auto arrays
    integer, intent(in) :: m
    real :: d(m,m,m)
    integer :: js, je
#ifdef use_CRI_pointers
    pointer( pd, d )
    call mpp_pset_stack_push( pset, pd, size(d) )
#endif
    call mpp_pset_segment_array( pset, 1, m, js, je )
    call mpp_clock_begin(id_auto)
    do k = 1,m
       do j = js,je
          do i = 1,m
             d(i,j,k) = 2*a(i,j,k)
          end do
       end do
    end do
    call mpp_pset_sync(pset)
    call mpp_clock_end(id_auto)
    write( stderr(),'(a,i6,2es23.15)' )'b, d should be equal: pe b d=', &
         pe, sum(b), sum(d)
    call mpp_pset_print_chksum( pset, 'test_auto ', d(:,js:je,:) )
  end subroutine test_auto
    
end program test
#else
module null_mpp_pset_test
end module
#endif


module oda_core_mod
!
!<CONTACT EMAIL="matthew.harrison@noaa.gov"> Matthew Harrison
!</CONTACT>
!
!<OVERVIEW>
! core ocean data assimilation subroutines for ocean models. This module
! includes interfaces to :
!  
! (i)   initialize the ODA core with observations and model
! (ii)  request ocean state increments using observed or idealized data 
! (iii) calculate model guess differences and output to file
! (iv)  terminate the DA core.  
!  
! NOTE: Profile files conform to v0.1a profile metadata standard.
! This metadata standard will evolve in time and will maintain
! backward compability.  
!  
! NOTE: This code is still under development. ODA data structures should be 
! opaque in future releases.
!  
!</OVERVIEW>
!
!<NAMELIST NAME="oda_core_nml">
! <DATA NAME="max_misfit" TYPE="real">
!  flag measurement if abs(omf) exceeds max_misfit
!</DATA>  
! <DATA NAME="min_obs_err_t" TYPE="real">
! minumum rms temperature observation error (degC) for
! variable obs error, else nominal temp error  
!</DATA>    
! <DATA NAME="min_obs_err_s" TYPE="real">
! minimum rms salinity observation error (g/kg) for
! variable obs error,else nominal salt error  
!</DATA>    
! <DATA NAME="eta_tide_const" TYPE="real">
! Tidal internal displacement amplitude (meters) for observational error estimation.  
!</DATA>    
! <DATA NAME="min_prof_depth" TYPE="real">
! Minimum profile depth (meters)  
!</DATA>    
! <DATA NAME="max_prof_spacing" TYPE="real">
! Data must be contiguous to this resolution (meters). Otherwise flag is activated.
! </DATA>
! <DATA NAME="data_window" TYPE="integer">
! Half-width of profile time window (days)
! </DATA>
! <DATA NAME="add_tidal_aliasing" TYPE="logical">
! Add tidal aliasing to observation error. Use eta_tide_const * dT/dz to estimate
! observation.  
! </DATA>
! <DATA NAME="max_profiles" TYPE="integer">
! Allocation size of profile array
! </DATA>
! <DATA NAME="max_sfc_obs" TYPE="integer">
! Allocation size of surface data array
! </DATA>
! <DATA NAME="temp_obs_rmse" TYPE="real">
! nominal temperature error rms error
! </DATA>
! <DATA NAME="salt_obs_rmse" TYPE="real">
! nominal salinity error rms error
! </DATA>      
!</NAMELIST>  
  use fms_mod, only : file_exist,read_data
  use mpp_mod, only : mpp_error, FATAL, NOTE, mpp_sum, stdout,&
                      mpp_sync_self, mpp_pe,mpp_npes,mpp_root_pe,&
                      mpp_broadcast, input_nml_file
  use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, &
       domain2d, mpp_get_global_domain, mpp_update_domains
  use time_manager_mod, only : time_type, operator( <= ), operator( - ), &
       operator( > ), operator ( < ),  set_time, set_date, &
       get_date, get_time
  use get_cal_time_mod, only : get_cal_time
  use axis_utils_mod, only : frac_index  
  use constants_mod, only : radian, pi
  use oda_types_mod
  use write_ocean_data_mod, only : write_ocean_data_init
  
  implicit none

  private
  
  real, private :: max_misfit = 5.0 ! reject fg diff gt max_misfit


  real, parameter, private :: depth_min=0.0, depth_max=10000.
  real, parameter, private :: temp_min=-3.0, temp_max=40.
  real, parameter, private :: salt_min=0.0, salt_max=45.
  
  integer :: max_profiles = 250000, max_sfc_obs = 1 
  integer, parameter, private :: max_files=100 
  integer, parameter, private :: PROFILE_FILE = 1,SFC_FILE= 2,&
                                 IDEALIZED_PROFILES=3
  
  
! parameters for obs error inflation due to internal tidal displacements
  
  real, private :: min_obs_err_t = 0.5, min_obs_err_s=0.1, eta_tide_const = 7.0
  
  type(ocean_profile_type), target, save, private, allocatable  :: profiles(:)
  type(ocean_surface_type), target, save, private, allocatable  :: sfc_obs(:)  

  integer, private, save :: num_profiles, num_sfc_obs ! total number of observations 

  integer, private, save :: isc, iec, jsc, jec, isd, ied, jsd, jed  ! indices for local and global domain
  integer, private, save :: isg, ieg, jsg, jeg
  integer, private, save :: nk

! parameters used to restrict profiles
  real, private, save :: min_prof_depth = 200.0 ! profile data ending
                                                   ! above this level are
                                                   ! discarded.  
  real, private, save :: max_prof_spacing = 1.e5 ! reject profile data
                                                    ! if not contiguous
                                                    ! at this resolution

! internal arrays for forward and backward observations
  real, dimension(:,:,:), allocatable, private, save :: sum_wgt, nobs

  type(time_type) , dimension(0:100), public :: time_window

! the DA module maintains a unique grid,domain association
  
  type(grid_type), pointer :: Grd

! DA grid (1-d) coordinates.  Generalized horizontal coordinates are not supporte.
  
  real, allocatable, dimension(:) :: x_grid, y_grid

  real :: temp_obs_rmse = 0.7071
  real :: salt_obs_rmse = 0.1
  
  logical :: add_tidal_aliasing=.false.

  logical :: localize_data = .true.

  logical :: debug=.false.

  integer :: ndebug=10

  integer, allocatable, dimension(:) :: nprof_in_comp_domain
  
  namelist /oda_core_nml/ max_misfit,add_tidal_aliasing,min_obs_err_t,&
                          min_obs_err_s, eta_tide_const, debug, max_profiles,&
                          max_sfc_obs, temp_obs_rmse, salt_obs_rmse, ndebug
                          

! NOTE: Surface observation type is not yet implemented.

! transform from Grd => Obs
  
  interface forward_obs
     module procedure forward_obs_profile
     module procedure forward_obs_sfc
  end interface

! transform from Obs => Grd
  
  interface backward_obs
     module procedure backward_obs_profile
     module procedure backward_obs_sfc
  end interface


! one-time association between profile and grid, used for storing
! interpolation weights
  
  interface assign_forward_model
     module procedure assign_forward_model_profile
     module procedure assign_forward_model_sfc
  end interface

! duplicate observation array
  
  interface copy_obs
     module procedure copy_obs_prof
     module procedure copy_obs_sfc
  end interface

! multiply observation data by inverse error variance
 
  interface mult_obs_I_mse
     module procedure mult_obs_I_mse_profile
     module procedure mult_obs_I_mse_sfc
  end interface

! difference between two observations (e.g. model first guess and observations)
  
  interface diff_obs
     module procedure diff_obs_profile
     module procedure diff_obs_sfc
  end interface

! inflate observational error based on first guess misfit 
! and time window.
  
  interface adjust_obs_error
     module procedure adjust_obs_error_profile
     module procedure adjust_obs_error_sfc
  end interface


  interface nullify_obs
     module procedure nullify_obs_prof
  end interface
  
  public :: forward_obs, backward_obs, &
            copy_obs, adjust_obs_error, &
            oda_core_init, open_profile_dataset, get_obs, &
            assign_forward_model, diff_obs, mult_obs_I_mse, &
            purge_obs, nullify_obs
  
  contains


  subroutine open_profile_dataset(filename, localize)  
!    <DESCRIPTION>
!    open dataset containing profile information in fms station format.
!    store internally.
!    </DESCRIPTION>    
    
    use mpp_io_mod, only : mpp_open, mpp_get_atts, mpp_get_info, &
         mpp_get_fields, mpp_read, MPP_SINGLE, MPP_MULTI, MPP_NETCDF,&
         axistype, atttype, fieldtype, MPP_RDONLY, mpp_get_axes, mpp_close,&
         mpp_get_att_char
    
    character(len=*), intent(in) :: filename
    logical, intent(in), optional :: localize
    logical :: found_neighbor,continue_looking
    integer, parameter :: max_levels=1000
    integer :: unit, ndim, nvar, natt, nstation
    character(len=32) :: fldname, axisname
    type(atttype), allocatable, dimension(:), target :: global_atts
    type(atttype), pointer :: version => NULL()
    type(axistype), pointer :: depth_axis => NULL(), station_axis => NULL()
    type(axistype), allocatable, dimension(:), target :: axes
    type(fieldtype), allocatable, dimension(:), target :: fields
    
    type(fieldtype), pointer :: field_lon => NULL(), field_lat => NULL(), field_probe => NULL(),&
         field_time => NULL(), field_depth => NULL()
    type(fieldtype), pointer :: field_temp => NULL(), field_salt => NULL(), &
                                field_error => NULL(), field_link => NULL()
    ! NOTE: fields are restricted to be in separate files
    real :: lon, lat, time, depth(max_levels), temp(max_levels), salt(max_levels),&
         error(max_levels), rprobe, profile_error, rlink
    integer :: nlev, probe, yr, mon, day, hr, minu, sec, kl, outunit
    integer :: num_levs, num_levs_temp, num_levs_salt,&
               k, kk, ll, i, i0, j0, k0, nlevs, a, nn, ii, nlinks
    real :: ri0, rj0, rk0, dx1, dx2, dy1, dy2
    character(len=128) :: time_units, attname, catt
    type(time_type) :: profile_time
    integer :: flag_t(max_levels), flag_s(max_levels), cpe
    logical :: data_is_local, &
               continue
    logical :: found_temp=.false., found_salt=.false.
    real, dimension(max_links,max_levels) :: temp_bfr, salt_bfr, depth_bfr
    integer, dimension(max_links,max_levels) :: flag_t_bfr, flag_s_bfr
    real :: temp_missing=missing_value,salt_missing=missing_value,&
         depth_missing=missing_value
    real :: max_prof_depth, zdist
    
    
    ! read timeseries of local observational data from NetCDF files
    ! and allocate ocean_obs arrays.  

    ! File structure:
    !    dimensions:
    !       depth_index;station=UNLIMITED;
    !    variables:
    !       depth_index(depth_index);
    !       station(station);
    !       longitude(station);
    !       latitude(station);
    !       time(station); 
    !       data(station,depth_index);
    !       depth(station,depth_index);
    !       probe(station);
    !       err(station, depth_index);

    cpe = mpp_pe()

    dx1 = (x_grid(isc)-x_grid(isc-1))/2.0
    dx2 = (x_grid(iec+1)-x_grid(iec))/2.0
    dy1 = (y_grid(jsc)-y_grid(jsc-1))/2.0
    dy2 = (y_grid(jec+1)-y_grid(jec))/2.0
    
    localize_data = .true.

    if (PRESENT(localize)) localize_data = localize

    call mpp_open(unit,filename,form=MPP_NETCDF,fileset=MPP_SINGLE,&
         threading=MPP_MULTI,action=MPP_RDONLY)
    call mpp_get_info(unit, ndim, nvar, natt, nstation)

    outunit = stdout()
    write(outunit,*) 'Opened profile dataset :',trim(filename)

    ! get version number of profiles

    allocate(global_atts(natt))
    call mpp_get_atts(unit,global_atts)

    do i=1,natt
       catt = mpp_get_att_char(global_atts(i))
       select case (lowercase(trim(catt)))
       case ('version')
          version =>  global_atts(i)
       end select
    end do

    if (.NOT.ASSOCIATED(version)) then
        call mpp_error(NOTE,'no version number available for profile file, assuming v0.1a ')
    else
        write(outunit,*) 'Reading profile dataset version = ',trim(catt)
    endif
    
    
    ! get axis information

    allocate (axes(ndim))
    call mpp_get_axes(unit,axes)
    do i=1,ndim
       call mpp_get_atts(axes(i),name=axisname)
       select case (lowercase(trim(axisname)))
       case ('depth_index')
          depth_axis => axes(i)
       case ('station_index')
          station_axis => axes(i)
       end select
    end do

    if (.NOT.ASSOCIATED(depth_axis) .or. .NOT.ASSOCIATED(station_axis)) then
        call mpp_error(FATAL,'depth and/or station axes do not exist in input file')
    endif

    
! get selected field information.
! NOTE: not checking for all variables here.    

    allocate(fields(nvar))
    call mpp_get_fields(unit,fields)
    do i=1,nvar
       call mpp_get_atts(fields(i),name=fldname)
       select case (lowercase(trim(fldname)))
       case ('longitude')
           field_lon => fields(i)
       case ('latitude')
           field_lat => fields(i)
       case ('probe') 
           field_probe => fields(i)
       case ('time')
           field_time => fields(i)
       case ('temp')
           field_temp => fields(i)
       case ('salt')
           field_salt => fields(i)           
       case ('depth')
           field_depth => fields(i)
       case ('link')
           field_link => fields(i)
       case ('error')
           field_error => fields(i)
       end select
   enddo

    call mpp_get_atts(depth_axis,len=nlevs)

    if (nlevs > max_levels) call mpp_error(FATAL,'increase parameter max_levels ')

    if (nlevs < 1) call mpp_error(FATAL)

    outunit = stdout()
    write(outunit,*) 'There are ', nstation, ' records in this dataset'
    write(outunit,*) 'Searching for profiles matching selection criteria ...'

    if (ASSOCIATED(field_temp)) found_temp=.true.
    if (ASSOCIATED(field_salt)) found_salt=.true.

    if (.not. found_temp .and. .not. found_salt) then
        write(outunit,*) 'temp or salt not found in profile file'
        call mpp_error(FATAL)
    endif
    
    call mpp_get_atts(field_time,units=time_units)
    if (found_temp) call mpp_get_atts(field_temp,missing=temp_missing)
    if (found_salt) call mpp_get_atts(field_salt,missing=salt_missing)
    
    call mpp_get_atts(field_depth,missing=depth_missing)        

    if (found_salt) then
        write(outunit,*) 'temperature and salinity where available'
    else
        write(outunit,*) 'temperature only records'
    endif

    
    i=1
    continue=.true.
    
    do while (continue)

       depth(:) = missing_value
       temp(:)  = missing_value
       salt(:)  = missing_value       
! required fields       
       call mpp_read(unit,field_lon,lon,tindex=i)
       call mpp_read(unit,field_lat,lat, tindex=i)
       call mpp_read(unit,field_time,time,tindex=i)
       call mpp_read(unit,field_depth,depth(1:nlevs),tindex=i)
       if (found_temp) call mpp_read(unit,field_temp,temp(1:nlevs),tindex=i)
       if (found_salt) call mpp_read(unit,field_salt,salt(1:nlevs),tindex=i)       
! not required fields
       if (ASSOCIATED(field_error)) then
           call mpp_read(unit,field_error,profile_error,tindex=i)
       endif
       if (ASSOCIATED(field_probe)) then
           call mpp_read(unit, field_probe, rprobe,tindex=i)
       endif
       if (ASSOCIATED(field_link)) then
           call mpp_read(unit,field_link,rlink,tindex=i)
       else
           rlink = 0.0
       endif
       probe=rprobe
       data_is_local = .false.
! NOTE: assuming grid is modulo 360 here. This needs to be generalized.
       
       if (lon .lt. x_grid(isg-1) ) lon = lon + 360.0
       if (lon .gt. x_grid(ieg+1) ) lon = lon - 360.0

! localized data is within region bounded by halo points
! (halo size = 1) adjacent to boundary points of computational domain
       
       if (lon >= x_grid(isc-1) .and. &
           lon <  x_grid(iec+1) .and. &
           lat >= y_grid(jsc-1) .and. &
           lat <  y_grid(jec+1)) data_is_local = .true.

       
       profile_time = get_cal_time(time,time_units,'julian')

       
       if ( data_is_local .OR. .NOT.localize_data) then
           
           num_profiles=num_profiles+1
           if (num_profiles > max_profiles) then
               call mpp_error(FATAL,'maximum number of profiles exceeded.&
                    &Resize parameter max_profiles in ocean_obs_mod')
               
           endif

           call nullify_obs(Profiles(num_profiles))
           
           num_levs_temp = 0
           num_levs_salt = 0           
           do k = 1, nlevs
              
! flag=0 denotes a valid profile level, anything else
! is invalid. See NODC codes.
!================================================================
!0 -     accepted station
!1 -     failed annual standard deviation check
!2 -     two or more density inversions (Levitus, 1982 criteria)
!3 -     flagged cruise
!4 -     failed seasonal standard deviation check
!5 -     failed monthly standard deviation check
!6 -     flag 1 and flag 4
!7 -     bullseye from standard level data or failed annual and monthly
!        standard deviation check
!8 -     failed seasonal and monthly standard deviation check
!9 -     failed annual, seasonal, and monthly standard deviation check
!================================================================
              
              flag_t(k) = 0;flag_s(k) = 0
              
              if (.not.found_salt) then
                  flag_s(k) = 1
              endif
              
              if (depth(k) .eq. depth_missing .or. depth(k) .lt.depth_min&
                   .or. depth(k) .gt. depth_max) then
                  depth(k) = missing_value
                  flag_t(k)=1
                  flag_s(k)=1
              endif
              
              if (found_temp .and. flag_t(k) .eq. 0) then
                  if (temp(k) .eq. temp_missing .or. temp(k) .lt. temp_min&
                       .or. temp(k) .gt. temp_max) then
                      temp(k) = missing_value
                      flag_t(k) = 1
                      flag_s(k) = 1 ! flag salt if no temperature data
                  else 
                      num_levs_temp = num_levs_temp+1
                  endif
              endif
              if (found_salt .and. flag_s(k) .eq. 0) then
                  if (salt(k) .eq. salt_missing .or. salt(k) .lt. salt_min&
                       .or. salt(k) .gt. salt_max) then
                      salt(k) = missing_value
                      flag_s(k) = 1
                  else 
                      num_levs_salt = num_levs_salt+1
                  endif
              endif
              
           enddo

! large profile are stored externally in separate records
! follow the links to get complete profile
           
           ii=i+1
           nlinks = 0
           do while (rlink > 0.0 .and. nlinks .lt. max_links)
              nlinks=nlinks+1
              depth_bfr(nlinks,:) = missing_value
              temp_bfr(nlinks,:) = missing_value
              salt_bfr(nlinks,:) = missing_value              
              call mpp_read(unit,field_depth,depth_bfr(nlinks,1:nlevs),tindex=ii)
              if (found_temp) call mpp_read(unit,field_temp,temp_bfr(nlinks,1:nlevs),tindex=ii)
              if (found_salt) call mpp_read(unit,field_salt,salt_bfr(nlinks,1:nlevs),tindex=ii)
              call mpp_read(unit,field_link,rlink,tindex=ii)
              ii=ii+1
           enddo
           i=ii ! set record counter to start of next profile

           if (nlinks > 0) then
               do nn = 1, nlinks
                  do k=1, nlevs
                     flag_t_bfr(nn,k) = 0
                     flag_s_bfr(nn,k) = 0
                     if (depth_bfr(nn,k) .eq. depth_missing .or.&
                          depth_bfr(nn,k) .lt. depth_min .or. &
                          depth_bfr(nn,k) .gt. depth_max) then
                         depth_bfr(nn,k) = missing_value
                         flag_t_bfr(nn,k)  = 1
                         flag_s_bfr(nn,k)  = 1
                     endif
                     if (found_temp .and. flag_t_bfr(nn,k) .eq. 0) then
                         if (temp_bfr(nn,k) .eq. temp_missing .or.&
                              temp_bfr(nn,k) .lt. temp_min .or.&
                              temp_bfr(nn,k) .gt. temp_max) then
                             temp_bfr(nn,k) = missing_value
                             flag_t_bfr(nn,k) = 1
                             flag_s_bfr(nn,k) = 1                         
                         else 
                             num_levs_temp = num_levs_temp+1
                         endif
                     endif
                     if (found_salt .and. flag_s_bfr(nn,k) .eq. 0) then
                         if (salt_bfr(nn,k) .eq. salt_missing  .or.&
                              salt_bfr(nn,k) .lt. salt_min .or.&
                              salt_bfr(nn,k) .gt. salt_max) then
                             salt_bfr(nn,k) = missing_value
                             flag_t_bfr(nn,k) = 0                         
                             flag_s_bfr(nn,k) = 1
                         else
                             num_levs_salt = num_levs_salt+1
                         endif
                     endif
                  enddo
               enddo
           endif

           num_levs = max(num_levs_temp,num_levs_salt)
           
           if (num_levs == 0) then
               if (i .gt. nstation) continue = .false.
               cycle
           endif

           allocate(profiles(num_profiles)%depth(num_levs))
           profiles(num_profiles)%depth=missing_value
           if (num_levs_temp .gt. 0) then
               allocate(profiles(num_profiles)%data_t(num_levs))
               profiles(num_profiles)%data_t=missing_value
               allocate(profiles(num_profiles)%flag_t(num_levs))
               profiles(num_profiles)%flag_t= 1
               profiles(num_profiles)%nvar=1
           endif

           if (num_levs_salt .gt. 0) then
               allocate(profiles(num_profiles)%data_s(num_levs))
               profiles(num_profiles)%data_s=missing_value
               allocate(profiles(num_profiles)%flag_s(num_levs))
               profiles(num_profiles)%flag_s= 1
               profiles(num_profiles)%nvar=profiles(num_profiles)%nvar + 1
           endif
           

           if (probe < 1 )   probe = 0
           profiles(num_profiles)%probe = probe
           profiles(num_profiles)%levels = num_levs
           profiles(num_profiles)%lat = lat
           profiles(num_profiles)%lon = lon
           allocate(profiles(num_profiles)%ms_t(num_levs))
           profiles(num_profiles)%ms_t(:) = temp_obs_rmse**2.0 ! default error variance for temperature

           if(num_levs_salt .gt. 0) then
               allocate(profiles(num_profiles)%ms_s(num_levs))
               profiles(num_profiles)%ms_s(:) = salt_obs_rmse**2.0  ! default error variance for salinity
           endif
           
           kk= 1
           do k = 1, nlevs
              if (flag_t(k) .eq. 0) then
                  if (kk > profiles(num_profiles)%levels) then
                      call mpp_error(FATAL)
                  endif
                  profiles(num_profiles)%depth(kk) = depth(k)
                  profiles(num_profiles)%data_t(kk) = temp(k)
                  profiles(num_profiles)%flag_t(kk) = 0                  
                  if (found_salt .and. flag_s(k) .eq. 0) then
                      profiles(num_profiles)%data_s(kk) = salt(k)
                      profiles(num_profiles)%flag_s(kk) = 0
                  endif
                  kk=kk+1
              endif
           enddo

           do nn = 1, nlinks
              do k = 1, nlevs
                 if (flag_t_bfr(nn,k) .eq. 0) then
                     if (kk > profiles(num_profiles)%levels) then
                         call mpp_error(FATAL)
                     endif
                     profiles(num_profiles)%depth(kk) = depth_bfr(nn,k)
                     profiles(num_profiles)%data_t(kk) = temp_bfr(nn,k)
                     profiles(num_profiles)%flag_t(kk) = 0
                     if (found_salt .and. flag_s_bfr(nn,k) .eq. 0) then
                         profiles(num_profiles)%data_s(kk) = salt_bfr(nn,k)
                         profiles(num_profiles)%flag_s(kk) = 0
                     endif
                     kk=kk+1
                 endif
              enddo
           enddo
           
           profiles(num_profiles)%time = profile_time
           
! calculate interpolation coefficients (make sure to account for grid offsets here!)
! NOTE: this only works for lat/lon grids. Lower left indices.           
!       
           
           ri0 = frac_index(lon, x_grid(isg-1:ieg+1)) - 1 
           rj0 = frac_index(lat, y_grid(jsg-1:jeg+1)) - 1
           i0 = floor(ri0)
           j0 = floor(rj0)
           Profiles(num_profiles)%i_index = ri0
           Profiles(num_profiles)%j_index = rj0           
           Profiles(num_profiles)%accepted = .true.
           if (i0 < 0 .or. j0 < 0) then
               Profiles(num_profiles)%accepted = .false.
           endif
           if (i0 > ieg .or. j0 > jeg) then  
               call mpp_error(FATAL,'grid lat/lon index is out of bounds ')
           endif
           if ((i0 < isc-1 .or. i0 > iec) .and. localize_data) then
               call mpp_error(FATAL,'grid lat/lon index is out of bounds ')
           endif
           if ((j0 < jsc-1 .or. j0 > jec) .and. localize_data) then
               call mpp_error(FATAL,'grid lat/lon index is out of bounds ')
           endif
!
! flag the profile if it sits on a model land point
!           
           if (Profiles(num_profiles)%accepted ) then
               if (Grd%mask(i0,j0,1) == 0.0 .or. &
                    Grd%mask(i0+1,j0,1) == 0.0 .or. &
                    Grd%mask(i0,j0+1,1) == 0.0 .or. &
                    Grd%mask(i0+1,j0+1,1) == 0.0) then
                   Profiles(num_profiles)%accepted = .false.
               endif
           endif

           if (Profiles(num_profiles)%accepted) then
               allocate(Profiles(num_profiles)%k_index(Profiles(num_profiles)%levels))
               max_prof_depth=0.0
               do k=1, Profiles(num_profiles)%levels
                  k0=0
                  if (Profiles(num_profiles)%flag_t(k).eq.0) then
                      rk0 = frac_index(Profiles(num_profiles)%depth(k), Grd%z(:))
                      k0 = floor(rk0)
                      if ( k0 == -1) then
                          if (Profiles(num_profiles)%depth(k) .lt. Grd%z(1)) then
                              k0 = 1
                              rk0 = 1.0
                          else if (Profiles(num_profiles)%depth(k) .gt. Grd%z(Grd%nk)) then
                              Profiles(num_profiles)%flag_t(k) = 1
                          endif
                      endif
                  else
                      cycle
                  endif

                  if (k0 .gt. size(Grd%z)-1 ) then
                      write(*,*) 'k0 out of bounds, rk0,k0= ',rk0,k0
                     write(*,*) 'Z_bound= ',Grd%z_bound
                     write(*,*) 'Profile%depth= ',Profiles(num_profiles)%depth
                     
                      call mpp_error(FATAL)
                  endif
                  
                  Profiles(num_profiles)%k_index(k) = rk0

! flag depth level if adjacent model grid points are land

                  if (Profiles(num_profiles)%flag_t(k) .eq. 0) then
                      if (i0 .lt. 0 .or. j0 .lt. 0 .or. k0 .lt. 0) then
                          write(*,*) 'profile index out of bounds'
                          write(*,*) 'i0,j0,k0=',i0,j0,k0
                          write(*,*) 'lon,lat,depth=',Profiles(num_profiles)%lon,&
                               Profiles(num_profiles)%lat,Profiles(num_profiles)%depth(k)
                          call mpp_error(FATAL)
                      endif
                      
                      if (Grd%mask(i0,j0,k0) == 0.0 .or. &
                          Grd%mask(i0+1,j0,k0) == 0.0 .or. &
                          Grd%mask(i0,j0+1,k0) == 0.0 .or. &
                          Grd%mask(i0+1,j0+1,k0) == 0.0) then
                          Profiles(num_profiles)%flag_t(k) = 1
                      endif
                      if (Grd%mask(i0,j0,k0+1) == 0.0 .or. &
                          Grd%mask(i0+1,j0,k0+1) == 0.0 .or. &
                          Grd%mask(i0,j0+1,k0+1) == 0.0 .or. &
                          Grd%mask(i0+1,j0+1,k0+1) == 0.0) then
                          Profiles(num_profiles)%flag_t(k) = 1
                      endif
                      if (Profiles(num_profiles)%flag_t(k) .eq. 0) then
                          max_prof_depth = Profiles(num_profiles)%depth(k)
                      endif
                  endif

               enddo ! Prof%levels loop

! Flag profile if it is too shallow.
               
               if (max_prof_depth .lt. min_prof_depth) then
                   Profiles(num_profiles)%accepted = .false.
               endif

               found_neighbor=.false.
               
               do k=2,Profiles(num_profiles)%levels - 1
                  if (Profiles(num_profiles)%flag_t(k) .eq. 0) then
                      kk = k-1
                      found_neighbor = .false.
                      continue_looking = .true.
                      do while (continue_looking .and. kk .ge. 1)
                         if (Profiles(num_profiles)%flag_t(kk) .eq. 0) then
                             zdist = Profiles(num_profiles)%depth(k) - Profiles(num_profiles)%depth(kk)
                             if (zdist .gt. max_prof_spacing) then
                                 Profiles(num_profiles)%accepted = .false.
                                 goto 199
                             else 
                                 continue_looking = .false.
                                 found_neighbor = .true.
                             endif
                         else
                             kk = kk - 1
                         endif
                      end do
                      kk = k+1
                      continue_looking = .true.
                      do while (continue_looking .and. kk .le. Profiles(num_profiles)%levels)
                         if (Profiles(num_profiles)%flag_t(kk).eq. 0) then
                             zdist = Profiles(num_profiles)%depth(kk) - Profiles(num_profiles)%depth(k)
                             if (zdist .gt. max_prof_spacing) then
                                 Profiles(num_profiles)%accepted = .false.
                                 goto 199
                             else
                                 continue_looking = .false.
                                 found_neighbor = .true.
                             endif
                         else
                             kk = kk+1
                         endif
                      enddo
                  endif
               enddo

               if (.not. found_neighbor) Profiles(num_profiles)%accepted = .false.

199            continue
               
           endif ! if Prof%accept
       else ! data is not local
           i = i+1
       endif ! if data_is_local

       
       if (i .gt. nstation) continue = .false.

    enddo

!    a = nprof_in_comp_domain(cpe)


    
!    call mpp_broadcast(nprof_in_comp_domain(cpe),cpe)
    
!    call mpp_sum(a)

!    write(stdout(),*) 'A grand total of ',int(a),' profiles satisify acceptance criteria'

!    do i=0,mpp_npes()
!       write(stdout(),*) 'pe=',i,'profile count=',nprof_in_comp_domain(i)
!    enddo
    
    call mpp_sync_self()
    call mpp_close(unit)

  end subroutine open_profile_dataset

  subroutine get_obs(model_time, Prof, Sfc, nprof, nsfc)


    ! get profiles and sfc
    ! obs relevant to current analysis interval

    type(time_type), intent(in) :: model_time
    type(ocean_profile_type), dimension(:) :: Prof
    type(ocean_surface_type), dimension(:) :: Sfc
    integer, intent(inout) :: nprof, nsfc

    integer :: i,k,yr,mon,day,hr,minu,sec,a,mon_obs,yr_obs, outunit
    type(time_type) :: tdiff
    character(len=1) :: cchar

    nprof=0
    nsfc=0

    outunit = stdout()
    write(outunit,*) 'Gathering profiles for current analysis time'
    call get_date(model_time,yr,mon,day,hr,minu,sec)
    write(outunit,'(a,i4,a,i2,a,i2)') 'Current yyyy/mm/dd= ',yr,'/',mon,'/',day
    write(outunit,*) 'num_profiles=',num_profiles

    
    do i=1,num_profiles

       if (debug .and. i.le.ndebug) then
           call get_date(Profiles(i)%time,yr,mon,day,hr,minu,sec)
           write(*,*) 'in get_obs prof time: yy/mm/dd= ',yr,mon,day
       endif
       
       if (Profiles(i)%time <= model_time) then
           tdiff = model_time - Profiles(i)%time
       else
           tdiff = Profiles(i)%time - model_time
       endif

       if (debug .and. i .le. ndebug) then
           write(*,*) 'Prof%accepted=',Profiles(i)%accepted
       endif
       
       if (tdiff <= time_window(0) .and. &
            Profiles(i)%accepted) then
           nprof=nprof+1
           if (nprof > size(Prof,1)) &
                call mpp_error(FATAL,'increase size of Prof array before call to get_obs')
           call copy_obs(Profiles(i:i),Prof(nprof:nprof))
           Prof(nprof)%tdiff = tdiff
           if (debug .and. nprof .le. ndebug) then
              call get_time(tdiff,sec,day)
              write(*,'(a,i3,a,2f10.5)') 'Accepted profile #',i,' : lon,lat= ',Prof(nprof)%lon,Prof(nprof)%lat
              do k=1,Prof(nprof)%levels
                 if (Prof(nprof)%nvar .eq. 2) then
                     write(*,'(a,i3,a,2f10.5,2i2,2f8.5)') 'Profile #',i,' : temp,salt,flag_t,flag_s,ms_t,ms_s= ',&
                          Prof(nprof)%data_t(k),Prof(nprof)%data_s(k),Prof(nprof)%flag_t(k),Prof(nprof)%flag_s(k),&
                          Prof(nprof)%ms_t(k),Prof(nprof)%ms_s(k)
                 else
                     write(*,'(a,i3,a,2f10.5)') 'Profile #',i,' : temp,flag_t= ',Prof(nprof)%data_t(k),Prof(nprof)%flag_t(k)
                 endif
              enddo
          endif
          
      else
          if (debug .and. i .le. ndebug) then
              call get_time(tdiff,sec,day)
              write(*,'(a,i3,a,2f10.5)') 'Rejected profile #',i,' : lon,lat= ',Prof(i)%lon,Prof(i)%lat
              do k=1,Prof(i)%levels
                 if (Prof(i)%nvar .eq. 2) then
                     write(*,'(a,i3,a,2f10.5,2i2)') 'Profile #',i,' : temp,salt,flag_t,flag_s= ',Prof(i)%data_t(k),Prof(i)%data_s(k),Prof(i)%flag_t(k),Prof(i)%flag_s(k)
                 else
                     write(*,'(a,i3,a,2f10.5)') 'Profile #',i,' : temp,flag_t= ',Prof(i)%data_t(k),Prof(i)%flag_t(k)
                 endif
              enddo
          endif
      endif

    enddo

    a=nprof
    call mpp_sum(a)
    write(outunit,*) 'A total of ',a,'  profiles are being used for the current analysis step'

    return

  end subroutine get_obs

  subroutine oda_core_init(Domain, Grid, localize)

    use fms_mod, only : open_namelist_file, check_nml_error, close_file
    
    type(domain2d), intent(in) :: Domain
    type(grid_type), target, intent(in) :: Grid
    logical, intent(in), optional :: localize

      
    integer :: ioun, ierr, io_status
    
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, oda_core_nml, iostat=io_status)
#else
    ioun = open_namelist_file()
    read(ioun,nml=oda_core_nml,iostat = io_status)
    ierr = check_nml_error(io_status,'oda_core_nml')
    call close_file(ioun)      
#endif

!    allocate(nprof_in_comp_domain(0:mpp_npes()-1))
!    nprof_in_comp_domain = 0
    
    Grd => Grid
    
    call mpp_get_compute_domain(Domain,isc,iec,jsc,jec)
    call mpp_get_data_domain(Domain,isd,ied,jsd,jed)
    call mpp_get_global_domain(Domain,isg,ieg,jsg,jeg)
    nk = size(Grid%z)

    allocate(sum_wgt(isd:ied,jsd:jed,nk))
    allocate(nobs(isd:ied,jsd:jed,nk))

    if (PRESENT(localize)) localize_data = localize
    
    call init_observations(localize_data)

    call write_ocean_data_init()
    
  end subroutine oda_core_init

  subroutine purge_obs()

    num_profiles=0
    num_sfc_obs=0

  end subroutine purge_obs

  subroutine forward_obs_profile(Model_obs, fg_t, fg_s)

! map first guess to observation locations
! note that forward operator only becomes associated after
! this call

    type(ocean_profile_type), dimension(:), intent(inout) ::Model_obs    
    real, dimension(isd:ied,jsd:jed,nk) , intent(in) :: fg_t ! first guess for temperature
    real, dimension(isd:ied,jsd:jed,nk) , intent(in), optional :: fg_s ! first guess for salinity

    integer :: n, i0, j0, k, num_prof, k0
    real :: a,b,c

    character(len=128) :: mesg
    
    num_prof = size(Model_obs)

    sum_wgt = 0.0

    do n = 1, num_prof
       i0 = floor(Model_obs(n)%i_index)
       j0 = floor(Model_obs(n)%j_index)
       a = Model_obs(n)%i_index - i0 
       b = Model_obs(n)%j_index - j0 

       if (a >= 1.0 .or. a < 0.0 ) call mpp_error(FATAL)
       if (b >= 1.0 .or. b < 0.0 ) call mpp_error(FATAL)


       if (i0 < isc-1 .or. i0 > iec) then
           write(mesg,'(a,i4,2x,i4)') 'out of bounds in forward_obs: i0,j0= ',i0,j0
           call mpp_error(FATAL,trim(mesg))
       endif

       if (j0 < jsc-1 .or. j0 > jec) then
           write(mesg,*) 'out of bounds in forward_obs: i0,j0= ',i0,j0
           call mpp_error(FATAL,trim(mesg))
       endif

       if (ASSOCIATED(Model_obs(n)%data_t) .and. Model_obs(n)%accepted) then

           if (ASSOCIATED(Model_obs(n)%Forward_model%wgt))&
                Model_obs(n)%Forward_model%wgt => NULL()
           allocate(Model_obs(n)%Forward_model%wgt(2,2,2,Model_obs(n)%levels))

           Model_obs(n)%Forward_model%wgt = 0.0
           
           do k = 1, Model_obs(n)%levels
              if (Model_obs(n)%flag_t(k) .eq. 0) then
                  k0 = floor(Model_obs(n)%k_index(k))
                  if (k0 < 1 .or. k0 > Grd%nk-1) then
                      write(mesg,*) 'out of bounds in forward_obs: k0= ',k0
                      call mpp_error(FATAL,trim(mesg))
                  endif          
                  c =	 Model_obs(n)%k_index(k) - k0

                  if (c >= 1.0 .or. c < 0.0 ) call mpp_error(FATAL)

                  Model_obs(n)%Forward_model%wgt(1,1,1,k) = (1.0-a)*(1.0-b)*(1.0-c)
                  Model_obs(n)%Forward_model%wgt(2,1,1,k) = a*(1.0-b)*(1.0-c)
                  Model_obs(n)%Forward_model%wgt(1,2,1,k) = (1.0-a)*b*(1.0-c)
                  Model_obs(n)%Forward_model%wgt(2,2,1,k) = a*b*(1.0-c)
                  Model_obs(n)%Forward_model%wgt(1,1,2,k) = (1.0-a)*(1.0-b)*c
                  Model_obs(n)%Forward_model%wgt(2,1,2,k) = a*(1.0-b)*c
                  Model_obs(n)%Forward_model%wgt(1,2,2,k) = (1.0-a)*b*c
                  Model_obs(n)%Forward_model%wgt(2,2,2,k) = a*b*c

                  sum_wgt(i0,j0,k0) = sum_wgt(i0,j0,k0)+&
                       Model_obs(n)%Forward_model%wgt(1,1,1,k)
                  sum_wgt(i0+1,j0,k0) = sum_wgt(i0+1,j0,k0)+&
                       Model_obs(n)%Forward_model%wgt(2,1,1,k)
                  sum_wgt(i0,j0+1,k0) = sum_wgt(i0,j0+1,k0)+&
                       Model_obs(n)%Forward_model%wgt(1,2,1,k)
                  sum_wgt(i0+1,j0+1,k0) = sum_wgt(i0+1,j0+1,k0)+&
                       Model_obs(n)%Forward_model%wgt(2,2,1,k)
                  sum_wgt(i0,j0,k0+1) = sum_wgt(i0,j0,k0+1)+&
                       Model_obs(n)%Forward_model%wgt(1,1,2,k)
                  sum_wgt(i0+1,j0,k0+1) = sum_wgt(i0+1,j0,k0+1)+&
                       Model_obs(n)%Forward_model%wgt(2,1,2,k)
                  sum_wgt(i0,j0+1,k0+1) = sum_wgt(i0,j0+1,k0+1)+&
                       Model_obs(n)%Forward_model%wgt(1,2,2,k)
                  sum_wgt(i0+1,j0+1,k0+1) = sum_wgt(i0+1,j0+1,k0+1)+&
                       Model_obs(n)%Forward_model%wgt(2,2,2,k)
                  
                      
                  Model_obs(n)%data_t(k) = &
                       fg_t(i0,j0,k0)*Model_obs(n)%Forward_model%wgt(1,1,1,k) &
                     + fg_t(i0+1,j0,k0)*Model_obs(n)%Forward_model%wgt(2,1,1,k) &
                     + fg_t(i0,j0+1,k0)*Model_obs(n)%Forward_model%wgt(1,2,1,k) &
                     + fg_t(i0+1,j0+1,k0)*Model_obs(n)%Forward_model%wgt(2,2,1,k) &
                     + fg_t(i0,j0,k0+1)*Model_obs(n)%Forward_model%wgt(1,1,2,k) &
                     + fg_t(i0+1,j0,k0+1)*Model_obs(n)%Forward_model%wgt(2,1,2,k) &
                     + fg_t(i0,j0+1,k0+1)*Model_obs(n)%Forward_model%wgt(1,2,2,k) &
                     + fg_t(i0+1,j0+1,k0+1)*Model_obs(n)%Forward_model%wgt(2,2,2,k)

                  if (ASSOCIATED(Model_obs(n)%data_s) .and. PRESENT(fg_s)) then
                      Model_obs(n)%data_s(k) = &
                       fg_s(i0,j0,k0)*Model_obs(n)%Forward_model%wgt(1,1,1,k) &
                     + fg_s(i0+1,j0,k0)*Model_obs(n)%Forward_model%wgt(2,1,1,k) &
                     + fg_s(i0,j0+1,k0)*Model_obs(n)%Forward_model%wgt(1,2,1,k) &
                     + fg_s(i0+1,j0+1,k0)*Model_obs(n)%Forward_model%wgt(2,2,1,k) &
                     + fg_s(i0,j0,k0+1)*Model_obs(n)%Forward_model%wgt(1,1,2,k) &
                     + fg_s(i0+1,j0,k0+1)*Model_obs(n)%Forward_model%wgt(2,1,2,k) &
                     + fg_s(i0,j0+1,k0+1)*Model_obs(n)%Forward_model%wgt(1,2,2,k) &
                     + fg_s(i0+1,j0+1,k0+1)*Model_obs(n)%Forward_model%wgt(2,2,2,k) 
                  endif
              else
                  if (ASSOCIATED(Model_obs(n)%data_t)) then
                      Model_obs(n)%data_t(k) = missing_value
                  endif
                  if (ASSOCIATED(Model_obs(n)%data_s)) then
                      Model_obs(n)%data_s(k) = missing_value
                  endif                  
              endif
           enddo
       endif
    enddo

    return

  end subroutine forward_obs_profile





  subroutine forward_obs_sfc(Sfc, Guess, Diff)
    type(ocean_surface_type), intent(in) :: Sfc
    type(ocean_dist_type), intent(in) :: Guess
    type(ocean_surface_type), intent(inout) :: Diff


    return

  end subroutine forward_obs_sfc

  subroutine backward_obs_profile(Obs,model_t,model_s)
!
! map observations back to model locations
!
    type(ocean_profile_type), dimension(:), intent(in) :: Obs
    real, dimension(isd:ied,jsd:jed,nk), intent(inout) :: model_t
    real, dimension(isd:ied,jsd:jed,nk), intent(inout), optional :: model_s    

    real :: tmp
    integer :: i0,j0,k0,k,n

    model_t = 0.0
    if (PRESENT(model_s)) model_s = 0.0
    
    do n=1,size(Obs)
       if (ASSOCIATED(Obs(n)%data_t) .and. Obs(n)%accepted) then
           i0 = floor(Obs(n)%i_index)
           j0 = floor(Obs(n)%j_index) 
! profiles are assumed to lie           
! in domain bounded by first halo points

           if (i0 < isd .or. i0 > ied-1) cycle
           if (j0 < jsd .or. j0 > jed-1) cycle
           
           if (.not.ASSOCIATED(Obs(n)%Forward_model%wgt)) call mpp_error(FATAL,'forward operator not associated with obs')
           
           do k=1, Obs(n)%levels
              if (Obs(n)%flag_t(k) .eq. 0) then
                  k0 = floor(Obs(n)%k_index(k))
                  if (k0 < 1 .or. k0 > Grd%nk-1) call mpp_error(FATAL,'profile k indx out of bnds')
                  
                  tmp = Obs(n)%data_t(k) 
                  model_t(i0,j0,k0)       = model_t(i0,j0,k0) + tmp*Obs(n)%Forward_model%wgt(1,1,1,k)
                  model_t(i0+1,j0,k0)     = model_t(i0+1,j0,k0) + tmp*Obs(n)%Forward_model%wgt(2,1,1,k)
                  model_t(i0,j0+1,k0)     = model_t(i0,j0+1,k0) + tmp*Obs(n)%Forward_model%wgt(1,2,1,k)
                  model_t(i0+1,j0+1,k0)   = model_t(i0+1,j0+1,k0) + tmp*Obs(n)%Forward_model%wgt(2,2,1,k)
                  model_t(i0,j0,k0+1)     = model_t(i0,j0,k0+1) + tmp*Obs(n)%Forward_model%wgt(1,1,2,k)
                  model_t(i0+1,j0,k0+1)   = model_t(i0+1,j0,k0+1) + tmp*Obs(n)%Forward_model%wgt(2,1,2,k)
                  model_t(i0,j0+1,k0+1)   = model_t(i0,j0+1,k0+1) + tmp*Obs(n)%Forward_model%wgt(1,2,2,k)
                  model_t(i0+1,j0+1,k0+1) = model_t(i0+1,j0+1,k0+1) + tmp*Obs(n)%Forward_model%wgt(2,2,2,k)

                  if (PRESENT(model_s)) then

                      tmp = Obs(n)%data_s(k) 
                      model_s(i0,j0,k0)       = model_s(i0,j0,k0) + tmp*Obs(n)%Forward_model%wgt(1,1,1,k)
                      model_s(i0+1,j0,k0)     = model_s(i0+1,j0,k0) + tmp*Obs(n)%Forward_model%wgt(2,1,1,k)
                      model_s(i0,j0+1,k0)     = model_s(i0,j0+1,k0) + tmp*Obs(n)%Forward_model%wgt(1,2,1,k)
                      model_s(i0+1,j0+1,k0)   = model_s(i0+1,j0+1,k0) + tmp*Obs(n)%Forward_model%wgt(2,2,1,k)
                      model_s(i0,j0,k0+1)     = model_s(i0,j0,k0+1) + tmp*Obs(n)%Forward_model%wgt(1,1,2,k)
                      model_s(i0+1,j0,k0+1)   = model_s(i0+1,j0,k0+1) + tmp*Obs(n)%Forward_model%wgt(2,1,2,k)
                      model_s(i0,j0+1,k0+1)   = model_s(i0,j0+1,k0+1) + tmp*Obs(n)%Forward_model%wgt(1,2,2,k)
                      model_s(i0+1,j0+1,k0+1) = model_s(i0+1,j0+1,k0+1) + tmp*Obs(n)%Forward_model%wgt(2,2,2,k)                      
                  endif

              end if

                  
           end do
       end if
    end do


    where(sum_wgt > 0)
        model_t = model_t /sum_wgt
    elsewhere
        model_t = 0.0
    end where

    if (PRESENT(model_s)) then
        where(sum_wgt > 0)
            model_s = model_s /sum_wgt
        elsewhere
            model_s = 0.0
        end where
    endif
    
  end subroutine backward_obs_profile


  subroutine backward_obs_sfc(Obs,model)

    type(ocean_surface_type), dimension(:), intent(in) :: Obs
    real, dimension(isd:ied,jsd:jed,nk), intent(inout) :: model


  end subroutine backward_obs_sfc
  
  subroutine assign_forward_model_profile(Obs1,Obs2)

    type(ocean_profile_type), dimension(:), target, intent(in) :: Obs1
    type(ocean_profile_type), dimension(:), intent(inout) :: Obs2    


    integer :: n

    if (size(Obs1) .ne. size(Obs2)) call mpp_error(FATAL)

    do n=1,size(Obs1)

       Obs2(n)%Forward_model%wgt => Obs1(n)%Forward_model%wgt

    enddo

  end subroutine assign_forward_model_profile


  subroutine assign_forward_model_sfc(Obs1,Obs2)

    type(ocean_surface_type), target, intent(in) :: Obs1
    type(ocean_surface_type), intent(inout) :: Obs2    
    

    return
  end subroutine assign_forward_model_sfc
  
  subroutine diff_obs_profile(prof1, prof2, Diff)

    type(ocean_profile_type), dimension(:), intent(in) :: prof1
    type(ocean_profile_type), dimension(:), intent(in) :: prof2    
    type(ocean_profile_type), dimension(:), intent(inout) :: Diff

    integer :: n,k

    if (size(prof1) .ne. size(prof2) ) call mpp_error(FATAL)
    
    if (size(prof1) .ne. size(Diff) ) call mpp_error(FATAL)    


    do n=1,size(prof1)
       do k=1,prof1(n)%levels
          if (prof1(n)%flag_t(k) .eq. 0) then
              Diff(n)%data_t(k) = prof2(n)%data_t(k)-prof1(n)%data_t(k)
          else
              Diff(n)%data_t(k) = missing_value
          endif
          if (abs(Diff(n)%data_t(k)) .gt. max_misfit) then
              Diff(n)%flag_t(k) = 1
          endif
         if (ASSOCIATED(prof1(n)%data_s)) then
             if (prof1(n)%flag_s(k) .eq. 0) then
                 Diff(n)%data_s(k) = prof2(n)%data_s(k)-prof1(n)%data_s(k)
             else
                 Diff(n)%data_s(k) = missing_value
             endif
             if (abs(Diff(n)%data_s(k)) .gt. max_misfit) then
                 Diff(n)%flag_s(k) = 1
             endif
         endif
       enddo
    enddo


  end subroutine diff_obs_profile

  subroutine diff_obs_sfc(prof1,prof2,Diff)

    type(ocean_surface_type), dimension(:), intent(in) :: prof1, prof2
    type(ocean_surface_type), dimension(:), intent(inout) :: Diff


  end subroutine diff_obs_sfc
  
  subroutine copy_obs_prof(obs_in, obs_out)

    type(ocean_profile_type), dimension(:), intent(in) :: obs_in
    type(ocean_profile_type), dimension(:), intent(inout) :: obs_out


    integer :: n

    if (size(obs_in) .ne. size(obs_out)) call mpp_error(FATAL,&
         'size mismatch in call to copy_obs_prof')


    do n=1,size(obs_in)
       call nullify_obs(obs_out(n))
       Obs_out(n)%nvar = Obs_in(n)%nvar
       Obs_out(n)%project = Obs_in(n)%project
       Obs_out(n)%probe = Obs_in(n)%probe
       Obs_out(n)%ref_inst = Obs_in(n)%ref_inst
       Obs_out(n)%wod_cast_num = Obs_in(n)%wod_cast_num
       Obs_out(n)%fix_depth = Obs_in(n)%fix_depth
       Obs_out(n)%ocn_vehicle = Obs_in(n)%ocn_vehicle
       Obs_out(n)%database_id = Obs_in(n)%database_id
       Obs_out(n)%levels = Obs_in(n)%levels
       Obs_out(n)%profile_flag = Obs_in(n)%profile_flag
       Obs_out(n)%profile_flag_s = Obs_in(n)%profile_flag_s       
       Obs_out(n)%lon = Obs_in(n)%lon
       Obs_out(n)%lat = Obs_in(n)%lat
       Obs_out(n)%accepted = Obs_in(n)%accepted
       ALLOCATE(Obs_out(n)%depth(Obs_in(n)%levels))
       Obs_out(n)%depth(:) = Obs_in(n)%depth(:)
       ALLOCATE(Obs_out(n)%data_t(Obs_in(n)%levels))
       Obs_out(n)%data_t(:) = Obs_in(n)%data_t(:)
       ALLOCATE(Obs_out(n)%flag_t(Obs_in(n)%levels))
       Obs_out(n)%flag_t(:) = Obs_in(n)%flag_t(:)
       if (ASSOCIATED(Obs_in(n)%data_s)) then
           ALLOCATE(Obs_out(n)%data_s(Obs_in(n)%levels))
           Obs_out(n)%data_s(:) = Obs_in(n)%data_s(:)
           ALLOCATE(Obs_out(n)%flag_s(Obs_in(n)%levels))
           Obs_out(n)%flag_s(:) = Obs_in(n)%flag_s(:)          
       endif
       
       Obs_out(n)%time = Obs_in(n)%time
       Obs_out(n)%yyyy = Obs_in(n)%yyyy
       Obs_out(n)%mmdd = Obs_in(n)%mmdd
       Obs_out(n)%i_index = Obs_in(n)%i_index
       Obs_out(n)%j_index = Obs_in(n)%j_index
       ALLOCATE(Obs_out(n)%k_index(Obs_in(n)%levels))          
       Obs_out(n)%k_index = Obs_in(n)%k_index
       ALLOCATE(Obs_out(n)%ms_t(Obs_in(n)%levels))          
       Obs_out(n)%ms_t = Obs_in(n)%ms_t
       if (ASSOCIATED(Obs_in(n)%ms_s)) then       
           ALLOCATE(Obs_out(n)%ms_s(Obs_in(n)%levels))          
           Obs_out(n)%ms_s = Obs_in(n)%ms_s
       endif
       


       Obs_out(n)%tdiff = Obs_in(n)%tdiff
       Obs_out(n)%nbr_index = Obs_in(n)%nbr_index
       Obs_out(n)%nbr_dist  = Obs_in(n)%nbr_dist
       if (ASSOCIATED(Obs_in(n)%Model_grid)) &
            Obs_out(n)%Model_grid => Obs_in(n)%Model_Grid
    enddo
 
end subroutine copy_obs_prof

  subroutine copy_obs_sfc(Obs_in, Obs_out)
    type(ocean_surface_type), dimension(:), intent(in) :: Obs_in
    type(ocean_surface_type), dimension(:), intent(inout) :: Obs_out


    return

  end subroutine copy_obs_sfc

  subroutine adjust_obs_error_profile(Prof)

    use time_manager_mod, only : get_time
    
    type(ocean_profile_type), dimension(:), intent(inout) :: Prof
    integer :: secs, days, n, k, secs_w, days_w, m
    real :: tfac, Ims
    
    do n=1,size(Prof)
       call get_time(Prof(n)%tdiff,secs, days)
       m=Prof(n)%probe
       call get_time(time_window(m),secs_w,days_w)
       tfac = (days + secs/86400.) / days_w
       tfac = 1. - min(1.,tfac)
       if (tfac > 1.0 ) call mpp_error(FATAL)
       if (tfac < 0.0 ) call mpp_error(FATAL)
       do k=1,Prof(n)%levels
           Prof(n)%ms_t(k) = 1.0/ max(1.e-1,tfac) * Prof(n)%ms_t(k)
           if (ASSOCIATED(Prof(n)%data_s)) then
               Prof(n)%ms_s(k) = 1.0/ max(1.e-1,tfac) * Prof(n)%ms_s(k)
          endif
       end do
    end do

  end subroutine adjust_obs_error_profile

  subroutine adjust_obs_error_sfc(Diff)

    type(ocean_surface_type), intent(inout) :: Diff

    return
    
  end subroutine adjust_obs_error_sfc


  subroutine mult_obs_I_mse_profile(Obs)

    type(ocean_profile_type), dimension(:), intent(inout) :: Obs

    integer :: n,k
    real :: Ims
    
    do n=1,size(Obs)
       do k = 1, Obs(n)%levels
          Ims = 1/Obs(n)%ms_t(k)
          if (Obs(n)%flag_t(k) .eq. 0) Obs(n)%data_t(k) = Ims*Obs(n)%data_t(k)
          if (ASSOCIATED(Obs(n)%data_s)) then
              Ims = 1/Obs(n)%ms_s(k)
              if (Obs(n)%flag_s(k) .eq. 0) Obs(n)%data_s(k) = Ims*Obs(n)%data_s(k)
          endif
       end do
    end do
    
  end subroutine mult_obs_I_mse_profile

  subroutine mult_obs_I_mse_sfc(a, Obs)

    real, dimension(:), intent(in) :: a
    type(ocean_surface_type), intent(inout) :: Obs

  end subroutine mult_obs_I_mse_sfc


       

 ! </SUBROUTINE>
! <FUNCTION NAME="lowercase">
!   <DESCRIPTION>
! Turn a string from uppercase to lowercase, do nothing if the
! string is already in lowercase.
!   </DESCRIPTION>
 function lowercase (cs) 
 character(len=*), intent(in) :: cs
 character(len=len(cs))       :: lowercase 
 character :: ca(len(cs)) 

 integer, parameter :: co=iachar('a')-iachar('A') ! case offset
    
    ca = transfer(cs,"x",len(cs)) 
    where (ca >= "A" .and. ca <= "Z") ca = achar(iachar(ca)+co) 
    lowercase = transfer(ca,cs) 
    
  end function lowercase

  subroutine init_observations(localize)  

    use fms_mod, only : open_namelist_file,close_file,check_nml_error
    use mpp_io_mod, only : mpp_open, MPP_ASCII, MPP_RDONLY, MPP_MULTI, MPP_SINGLE
    use mpp_domains_mod, only : mpp_global_field
    
    logical, intent(in), optional :: localize

    integer :: data_window = 15 ! default data half-window is 15 days

    integer :: i,j
    
    
    type obs_entry_type
       character(len=128) :: filename
       character(len=16)  :: file_type
    end type obs_entry_type

    namelist /ocean_obs_nml/ data_window, max_prof_spacing, min_prof_depth
    
    character(len=128) :: input_files(max_files) = ''
    integer :: nfiles, filetype(max_files), ioun, io_status, ierr,&
                unit, nrecs, n
    character(len=256) :: record
    type(obs_entry_type) :: tbl_entry

    ioun = open_namelist_file()
    read(ioun,nml=ocean_obs_nml,iostat = io_status)
    ierr = check_nml_error(io_status,'ocean_obs_nml')
    call close_file(ioun)    

    time_window(:) = set_time(0,data_window)

    nfiles=0
    
    if (file_exist('ocean_obs_table') ) then
        call mpp_open(unit,'ocean_obs_table',action=MPP_RDONLY)
        nfiles = 0;nrecs=0
        do while (nfiles <= max_files)
           read(unit,'(a)',end=99,err=98) record
           nrecs=nrecs+1
           if (record(1:1) == '#') cycle
           read(record,*,err=98,end=98) tbl_entry
           nfiles=nfiles+1       
           input_files(nfiles) = tbl_entry%filename
           select case (trim(tbl_entry%file_type))
           case ('profiles')
               filetype(nfiles)    = PROFILE_FILE
           case ('sfc')
               filetype(nfiles)    = SFC_FILE
           case ('idealized')
               filetype(nfiles)    = IDEALIZED_PROFILES
           case default
               call mpp_error(FATAL,'error in obs_table entry format')
           end select
98         continue
        enddo
        call mpp_error(FATAL,' number of obs files exceeds max_files parameter')
99      continue

    endif
    num_profiles=0
    num_sfc_obs=0
    
! get local indices for Model grid
! Since we currently only support regular grids, the
! input 2-d grid array is converted to 1-d
! halo points are added

!    xhalo=isc-isd
!    yhalo=jsc-jsd
!    if (xhalo.ne.ied-iec) call mpp_error(FATAL)
!    if (yhalo.ne.jed-jec) call mpp_error(FATAL)    

    allocate(x_grid(isg-1:ieg+1))
    allocate(y_grid(jsg-1:jeg+1))


    x_grid(isg:ieg) = Grd%x(isg:ieg,jsg)
    y_grid(jsg:jeg) = Grd%y(ieg/4,jsg:jeg)

    allocate(Profiles(max_profiles))

     if (Grd%cyclic) then
         x_grid(isg-1) = x_grid(ieg) - 360. ! assume grid is modulo 360 which is reasonable for data assimilation
         x_grid(ieg+1) = x_grid(isg) + 360.
     else
         x_grid(isg-1) = x_grid(isg) - 1.e-10
         x_grid(ieg+1) = x_grid(ieg) + 1.e-10
     endif

     y_grid(jsg-1) = y_grid(jsg) - 1.e-10
     y_grid(jeg+1) = y_grid(jeg) + 1.e-10
     
    
    do n=1, nfiles
       select case (filetype(n))
       case (PROFILE_FILE)
           call open_profile_dataset(trim(input_files(n)), localize)
       case (IDEALIZED_PROFILES)
           call create_ideal_profiles(localize)
       case default
          call mpp_error(FATAL,'filetype not currently supported')
       end select
    enddo


    return

  end subroutine init_observations
  
   subroutine add_tidal_error(Prof)
! NOT IMPLEMENTED YET !!!
     type(ocean_profile_type), intent(inout) :: Prof

     integer :: k
     real :: dtdz, err, a1, a2
    
     if (.not.ASSOCIATED(prof%ms_t)) then
         allocate(prof%ms_t(prof%levels))
         prof%ms_t(:) = min_obs_err_t
     endif
     
     do k=2,prof%levels - 1
        if (prof%flag_t(k-1) .eq. 0 .and. prof%flag_t(k+1) .eq. 0) then 
            dtdz = (prof%data_t(k+1)-prof%data_t(k-1))/(prof%depth(k+1)-prof%depth(k-1))
            a1 = abs(dtdz) * eta_tide_const
            err = max(a1,min_obs_err_t)
            prof%ms_t(k) = err*err
            if (ASSOCIATED(prof%data_s)) then
                dtdz = (prof%data_s(k+1)-prof%data_s(k-1))/(prof%depth(k+1)-prof%depth(k-1))
                a1 = abs(dtdz) * eta_tide_const
                err = max(a1,min_obs_err_s)
                prof%ms_s(k) = err*err
            endif
        endif
     enddo

   end subroutine add_tidal_error

  subroutine create_ideal_profiles(localize)
!
    use field_manager_mod, only: MODEL_OCEAN, parse, find_field_index, get_field_methods, method_type, get_field_info
    
    logical, intent(in), optional :: localize
    logical :: localize_data = .true.
    integer, parameter :: nlevels = 100 ! number of vertical levels for idealized profiles
    real, parameter :: width_trans = 250.0 ! with over which to transition from sfc value to bottom value
    real, parameter :: bot_depth = 2000.0 ! bottom depth for idealized profiles
    real, allocatable, dimension(:) :: lon,lat, sst, sss, bot_temp, bot_salt, depth
    real, allocatable, dimension(:,:) :: temp, salt, temp_error, salt_error
    integer, allocatable, dimension(:) :: yr, mon, day, hr, mm, ss
    integer :: nstation, unit, n, noobs, i, k
    real :: ri0,rj0,rk0, mid_depth, dtdf, temp_cent, depthC_I_trans, dsdf, salt_cent
    type(time_type) :: profile_time
    logical :: data_is_local
    integer :: model, parse_ok, cpe
    integer :: i0,j0,k0
    real :: dz, a, dx1, dx2, dy1, dy2
    
    real :: temp_missing=missing_value,salt_missing=missing_value,depth_missing=missing_value
    character(len=32) :: fld_type, fld_name
    type(method_type), allocatable, dimension(:) :: ocean_obs_methods
    
    if (PRESENT(localize)) localize_data = localize


    cpe = mpp_pe()

    dx1 = (x_grid(isc)-x_grid(isc-1))/2.0
    dx2 = (x_grid(iec+1)-x_grid(iec))/2.0
    dy1 = (y_grid(jsc)-y_grid(jsc-1))/2.0
    dy2 = (y_grid(jec+1)-y_grid(jec))/2.0
    
    model = model_ocean
    n = find_field_index(model,'ideal_profiles')
    call get_field_info(n,fld_type,fld_name,model,noobs)

    allocate(ocean_obs_methods(noobs))
    allocate(lon(noobs),lat(noobs), yr(noobs), mon(noobs), day(noobs), &
         hr(noobs), mm(noobs), ss(noobs), &
         sst(noobs), sss(noobs), bot_temp(noobs), bot_salt(noobs))
    allocate(temp(noobs,nlevels), salt(noobs,nlevels), temp_error(noobs,nlevels), salt_error(noobs,nlevels))
    allocate(depth(nlevels))
    
    call get_field_methods(n,ocean_obs_methods)
    do i=1,noobs
       parse_ok = parse(ocean_obs_methods(i)%method_control,'lon',lon(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       if (lon(i) .lt. x_grid(isg) ) lon(i) = lon(i) + 360.0
       if (lon(i) .gt. x_grid(ieg) ) lon(i) = lon(i) - 360.0       
       parse_ok = parse(ocean_obs_methods(i)%method_control,'lat',lat(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'yr',yr(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')              
       parse_ok = parse(ocean_obs_methods(i)%method_control,'mon',mon(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'day',day(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'hr',hr(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'mm',mm(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'ss',ss(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'sst',sst(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'sss',sss(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'bot_temp',bot_temp(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
       parse_ok = parse(ocean_obs_methods(i)%method_control,'bot_salt',bot_salt(i))
       if (parse_ok == 0) call mpp_error(FATAL,'==>Error oda_core_mod: idealized_ocean_profiles table entry error')
    enddo

    if (noobs == 0 ) then
        call mpp_error(FATAL,'==> NOTE from oda_core_mod: no idealized profiles given in field table')
        return
    endif

    dz = bot_depth/(nlevels-1)
    
    do k=1,nlevels
       depth(k) = (k-1)*dz
    enddo
    
    mid_depth = bot_depth/2.0
    depthC_I_trans = mid_depth / width_trans
    do i=1,noobs
       dtdf = (bot_temp(i) - sst(i)) / (2.0*atan(1.0) + atan(depthC_I_trans))
       temp_cent = sst(i) + dtdf * atan(depthC_I_trans)
       temp(i,1) = sst(i)
       do k=2,nlevels-1
          temp(i,k) = temp_cent + dtdf * atan((depth(k)  - mid_depth)/width_trans)
       enddo
       temp(i,nlevels) = bot_temp(i)

       dsdf = (bot_salt(i) - sss(i)) / (2.0*atan(1.0) + atan(depthC_I_trans))
       salt_cent = sss(i) + dsdf * atan(depthC_I_trans)
       salt(i,1) = sss(i)
       do k=2,nlevels-1
          salt(i,k) = salt_cent + dsdf * atan((depth(k)  - mid_depth)/width_trans)
       enddo
       salt(i,nlevels) = bot_salt(i)
    enddo


    num_profiles=0
    do i=1,noobs

       data_is_local = .false.


! localized data is within region bounded by halo points
! (halo size = 1) adjacent to boundary points of computational domain
       
       if (lon(i) >= x_grid(isc-1) .and. &
            lon(i) <  x_grid(iec+1) .and. &
            lat(i) >= y_grid(jsc-1) .and. &
            lat(i) <  y_grid(jec+1)) data_is_local = .true.

      
       profile_time = set_date(yr(i),mon(i),day(i),hr(i),mm(i),ss(i))
       
       if ( data_is_local .OR. .NOT.localize_data) then
           if (lon(i) >= x_grid(isc)-dx1 .and. &
                lon(i) < x_grid(iec)+dx2 .and. &
                lat(i) >= y_grid(jsc)-dy1 .and. &
                lat(i) <  y_grid(jec)+dy2) then
!               nprof_in_comp_domain(cpe) = nprof_in_comp_domain(cpe)+1
           endif
           num_profiles=num_profiles+1
           if (num_profiles > max_profiles) then
               call mpp_error(FATAL,'maximum number of profiles exceeded.  Resize parameter max_profiles in ocean_obs_mod')
           endif


           profiles(num_profiles)%Model_Grid => Grd
           profiles(num_profiles)%nvar = 2
           profiles(num_profiles)%profile_flag = 0
           profiles(num_profiles)%profile_flag_s = 0
           profiles(num_profiles)%accepted = .true.
           allocate(profiles(num_profiles)%depth(nlevels))
           profiles(num_profiles)%depth=depth(1:nlevels)
           allocate(profiles(num_profiles)%data_t(nlevels))
           profiles(num_profiles)%data_t=temp(i,:)
           allocate(profiles(num_profiles)%flag_t(nlevels))
           profiles(num_profiles)%flag_t= 0               

           allocate(profiles(num_profiles)%data_s(nlevels))
           profiles(num_profiles)%data_s=salt(i,:)
           allocate(profiles(num_profiles)%flag_s(nlevels))
           profiles(num_profiles)%flag_s= 0

           profiles(num_profiles)%probe = 0
           profiles(num_profiles)%levels = nlevels
           profiles(num_profiles)%lat = lat(i)
           profiles(num_profiles)%lon = lon(i)
           allocate(profiles(num_profiles)%ms_t(nlevels))
           profiles(num_profiles)%ms_t(:) = min_obs_err_t ! default error variance for temperature
           allocate(profiles(num_profiles)%ms_s(nlevels))
           profiles(num_profiles)%ms_s(:) = min_obs_err_s  ! default error variance for salinity

           profiles(num_profiles)%time = profile_time
           
! calculate interpolation coefficients (make sure to account for grid offsets here!)
! note that this only works for lat/lon grids
           
           ri0 = frac_index(lon(i), x_grid(isg-1:ieg+1)) - 1 
           rj0 = frac_index(lat(i), y_grid(jsg-1:jeg+1)) - 1
           i0 = floor(ri0)
           j0 = floor(rj0)
           Profiles(num_profiles)%i_index = ri0
           Profiles(num_profiles)%j_index = rj0           
           Profiles(num_profiles)%accepted = .true.
           if (i0 < 0 .or. j0 < 0) then
               Profiles(num_profiles)%accepted = .false.
           endif
           if (i0 > ieg+1 .or. j0 > jeg+1) then
               call mpp_error(FATAL,'grid lat/lon index is out of bounds ')
           endif
           if (i0 < isc-1 .or. i0 > iec) then
               call mpp_error(FATAL,'grid lat/lon index is out of bounds ')
           endif
           if (j0 < jsc-1 .or. j0 > jec) then
               call mpp_error(FATAL,'grid lat/lon index is out of bounds ')
           endif
           if (Profiles(num_profiles)%accepted ) then
               if (Grd%mask(i0,j0,1) == 0.0 .or. &
                    Grd%mask(i0+1,j0,1) == 0.0 .or. &
                    Grd%mask(i0,j0+1,1) == 0.0 .or. &
                    Grd%mask(i0+1,j0+1,1) == 0.0) then
                   Profiles(num_profiles)%accepted = .false.
               endif
           endif


           
           if (Profiles(num_profiles)%accepted) then
               allocate(Profiles(num_profiles)%k_index(Profiles(num_profiles)%levels))
               do k=1, Profiles(num_profiles)%levels
                  rk0 = frac_index(Profiles(num_profiles)%depth(k), Grd%z(:))
                  k0 = floor(rk0)
                  if ( k0 == -1) then
                      if (Profiles(num_profiles)%depth(k) .ne. missing_value .and. &
                           Profiles(num_profiles)%depth(k) .lt. Grd%z(1)) then
                           k0 = 1
                           rk0 = 1.0
                       endif
                   endif


                  if (k0 .gt. size(Grd%z)-1 ) then
                      write(*,*) 'k0 out of bounds, rk0,k0= ',rk0,k0
                     write(*,*) 'Z_bound= ',Grd%z_bound
                      write(*,*) 'Profile%depth= ',Profiles(num_profiles)%depth
                      call mpp_error(FATAL)
                  endif
                  
                  Profiles(num_profiles)%k_index(k) = rk0
                  
                  if (Profiles(num_profiles)%flag_t(k) .eq. 0) then
                      if (Grd%mask(i0,j0,k0) == 0.0 .or. &
                          Grd%mask(i0+1,j0,k0) == 0.0 .or. &
                          Grd%mask(i0,j0+1,k0) == 0.0 .or. &
                          Grd%mask(i0+1,j0+1,k0) == 0.0) then
                          Profiles(num_profiles)%flag_t(k) = 1
                      endif
                      if (Grd%mask(i0,j0,k0+1) == 0.0 .or. &
                          Grd%mask(i0+1,j0,k0+1) == 0.0 .or. &
                          Grd%mask(i0,j0+1,k0+1) == 0.0 .or. &
                          Grd%mask(i0+1,j0+1,k0+1) == 0.0) then
                          Profiles(num_profiles)%flag_t(k) = 1
                      endif
                      if (Profiles(num_profiles)%data_t(k) == missing_value &
                         .or. Profiles(num_profiles)%depth(k) == missing_value) then
                          Profiles(num_profiles)%flag_t(k) = 1
                      endif
                  endif
                  
               enddo
           endif          
       endif

    enddo

!    a = nprof_in_comp_domain(cpe)

!    call mpp_broadcast(nprof_in_comp_domain(cpe),cpe)
    
!    call mpp_sum(a)

!    write(stdout(),*) 'A grand total of ',a,' profiles satisify acceptance criteria'

!    do i=0,mpp_npes()-1
!       write(stdout(),*) 'pe=',i,'profile count=',nprof_in_comp_domain(i)
!    enddo
    
  end subroutine create_ideal_profiles


  subroutine nullify_obs_prof(profile)

    type(ocean_profile_type), intent(inout) :: profile


    profile%nvar = 0
    profile%project=0
    profile%probe=0
    profile%ref_inst=0
    profile%wod_cast_num=0
    profile%fix_depth=0
    profile%ocn_vehicle=0
    profile%database_id=0
    profile%levels=0
    profile%profile_flag=-1
    profile%profile_flag_s=-1
    profile%lon=-1.0e10
    profile%lat=-1.0e10
    profile%accepted=.false.
    profile%nlinks=0
    if (ASSOCIATED(profile%next)) profile%next=>NULL()
    if (ASSOCIATED(profile%depth)) profile%depth=>NULL()
    if (ASSOCIATED(profile%data_t)) profile%data_t=>NULL()
    if (ASSOCIATED(profile%data_s)) profile%data_s=>NULL()
    if (ASSOCIATED(profile%flag_t)) profile%flag_t=>NULL()
    if (ASSOCIATED(profile%flag_s)) profile%flag_s=>NULL()
    profile%temp_err=0.0
    profile%salt_err=0.0
    if (ASSOCIATED(profile%ms_t)) profile%ms_t=>NULL()
    if (ASSOCIATED(profile%ms_s)) profile%ms_s=>NULL()    
    profile%time = set_time(0,0)
    profile%yyyy = 0
    profile%mmdd = 0
    if (ASSOCIATED(profile%model_time)) profile%model_time=>NULL()
    if (ASSOCIATED(profile%model_grid)) profile%model_grid=>NULL()
    if (ASSOCIATED(profile%k_index)) profile%k_index=>NULL()
    profile%i_index=-1.0
    profile%j_index=-1.0
    profile%tdiff = set_time(0,0)
    
  end subroutine nullify_obs_prof
  
end module oda_core_mod


module oda_types_mod
#define MAX_LEVS_FILE_ 50
  
!============================================================
! This module contains type declarations and default values
! for oda modules.  
!============================================================
  
! Contact: Matthew.Harrison@gfdl.noaa.gov

  use time_manager_mod, only : time_type, set_time
  use mpp_mod, only : stdout
  use mpp_domains_mod, only : domain2d
  
  implicit none

  private

! Controls record length for optimal storage  
  integer, parameter, public :: max_levels_file=MAX_LEVS_FILE_
! Maximum number of neighbors for QC or analysis
  integer, parameter, public :: max_neighbors=100 ! for profiles
! Maximum number of records per profile for storage   
  integer, parameter, public :: max_links=100 ! for profiles  
  
! List of variables for ODA   

  real, parameter, public :: missing_value=-1.e20
  
  type, public :: forward_model_type
     real, dimension(:,:,:,:), pointer :: wgt=>NULL() ! interpolation weights
  end type forward_model_type
  
  type, public :: ocean_profile_type
     integer :: nvar
     real    :: project ! e.g. FGGE, COARE, ACCE, ...
     real    :: probe ! MBT, XBT, drifting buoy
     real    :: ref_inst ! instrument (thermograph, hull sensor, ...)
     integer :: wod_cast_num
     real    :: fix_depth
     real    :: ocn_vehicle
     real    :: database_id
     integer :: levels
     integer :: profile_flag ! an overall flag for the profile
     integer :: profile_flag_s ! an overall flag for the profile salinity     
     real :: lat, lon
     logical :: accepted
     integer :: nlinks
     type(ocean_profile_type), pointer, dimension(:) :: next ! Large profiles are stored as linked list.
     integer, dimension(max_neighbors) :: nbr_index
     real, dimension(max_neighbors) :: nbr_dist ! distance in radians 
     real, dimension(:), pointer :: depth, data_t, data_s
     integer, dimension(:), pointer :: flag_t ! level-by-level flags for temp
     integer, dimension(:), pointer :: flag_s ! level-by-level flags for salinity
     real    :: temp_err, salt_err ! measurement error
     real, dimension(:), pointer :: ms_t      ! ms temperature by level
     real, dimension(:), pointer :: ms_s      ! ms salinity by level     
     type(time_type) :: time 
     integer         :: yyyy
     integer         :: mmdd
     type(time_type), pointer :: Model_time ! each profile can be associated with a first-guess field with an associated time and grid
     type(grid_type), pointer :: Model_grid 
     real :: i_index, j_index ! model longitude and latitude indices respectively
     real, dimension(:), pointer :: k_index     ! model depth indices
     type(forward_model_type) :: Forward_model  ! linear operation from model to observation
     type(time_type) :: tdiff      ! positive difference between model time and observation time
  end type ocean_profile_type

  type, public :: ocean_surface_type
     integer :: variable  ! variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID, ...)
     integer :: inst_type  ! instrument types are defined by platform class (e.g. MOORING, DROP) and instrument type (XBT, CTD, ...)
     integer :: qc_flag, nobs
     logical :: is_gridded
     integer :: nlon, nlat
     real, pointer, dimension(:) :: lat, lon
     logical :: accepted     
     real, pointer, dimension(:) :: data
     real, dimension(:), pointer :: ms     =>NULL() 
     real, dimension(:), pointer :: i_index=>NULL() , j_index=>NULL()  ! model indices
     real, pointer, dimension(:,:) :: data2=>NULL() 
     real, dimension(:,:), pointer :: ms2     =>NULL() 
     real, dimension(:,:), pointer :: i_index2=>NULL() , j_index2=>NULL()  ! model indices
     real :: k_index          
     type(forward_model_type) :: Forward_model
     type(time_type) :: time
     integer :: yyyy
     integer :: mmdd
     character(len=8) :: wmo_id
     type(time_type), pointer :: Model_time=>NULL() 
     type(grid_type), pointer :: Model_grid=>NULL()    
     ! positive difference between current model time 
     ! and observation time
     type(time_type) :: tdiff
  end type ocean_surface_type


  type, public :: grid_type
     real, pointer, dimension(:,:) :: x=>NULL() , y=>NULL() 
     real, pointer, dimension(:,:) :: x_bound=>NULL() , y_bound=>NULL()      
     real, pointer, dimension(:,:) :: dx=>NULL() , dy=>NULL() 
     real, pointer, dimension(:) :: z=>NULL() , z_bound=>NULL() 
     real, pointer, dimension(:) :: dz=>NULL() 
     real, pointer, dimension(:,:,:) :: mask=>NULL()
     type(domain2d), pointer :: Dom ! FMS domain type
     logical :: cyclic
     integer :: ni, nj, nk
  end type grid_type

  type, public :: field_type
     type(grid_type) :: grid
     real, pointer, dimension(:,:,:) :: data=>NULL() 
  end type field_type


  type, public :: field_dist_type_3d
     integer :: error_model
     character(len=32) :: name
     type(grid_type), pointer :: grid=>NULL() 
     real, pointer, dimension(:,:,:) :: ex=>NULL() , vr=>NULL()
     real, pointer, dimension(:,:,:) :: obs_d=>NULL() ! obs minus expected value
  end type field_dist_type_3d

  type, public :: field_dist_type_2d
     integer :: error_model
     character(len=32) :: name
     type(grid_type), pointer :: grid=>NULL() 
     real, pointer, dimension(:,:) :: ex=>NULL() , vr=>NULL() 
  end type field_dist_type_2d
     
  type, public :: ocean_dist_type
     type(field_dist_type_3d) :: temp,salt,u,v
     type(field_dist_type_2d) :: eta
  end type ocean_dist_type

  public init_obs
  
  interface init_obs
     module procedure init_obs_profile
  end interface
  
  contains

    subroutine oda_types_init()

      use fms_mod, only : open_namelist_file, check_nml_error, close_file
      

    end subroutine oda_types_init


    subroutine init_obs_profile(profile)

      type(ocean_profile_type), intent(inout) :: profile

      profile%nvar = 0
      profile%project = -1.0
      profile%probe   = -1.0
      profile%wod_cast_num = -1
      profile%ref_inst = -1.0
      profile%fix_depth = -1.0
      profile%ocn_vehicle = -1.0
      profile%database_id = -1.0
      profile%levels = 0
      profile%profile_flag = 0
      profile%profile_flag_s = 0
      profile%lat = -1.e10
      profile%lon = -1.e10
      profile%accepted = .true.
      if (ASSOCIATED(profile%next)) deallocate(profile%next)
      profile%nlinks = 0
      profile%nbr_index(:) = -1
      profile%nbr_dist(:) = -1.0
      if (ASSOCIATED(profile%depth)) deallocate(profile%depth)
      if (ASSOCIATED(profile%data_t)) deallocate(profile%data_t)
      if (ASSOCIATED(profile%data_s)) deallocate(profile%data_s)
      if (ASSOCIATED(profile%flag_t)) deallocate(profile%flag_t)
      if (ASSOCIATED(profile%flag_s)) deallocate(profile%flag_s)
      if (ASSOCIATED(profile%ms_t)) deallocate(profile%ms_t)
      if (ASSOCIATED(profile%ms_s)) deallocate(profile%ms_s)
      profile%temp_err = -1.0
      profile%salt_err = -1.0
      profile%time = set_time(0,0)
      profile%yyyy = 0
      profile%mmdd = 0      
      if (ASSOCIATED(profile%model_time)) deallocate(profile%model_time)
      if (ASSOCIATED(profile%model_grid)) deallocate(profile%model_grid)
      profile%i_index = -1
      profile%j_index = -1
      if (ASSOCIATED(profile%k_index)) deallocate(profile%k_index)
      profile%tdiff = set_time(0,0)

      return
      
    end subroutine init_obs_profile
    
end module oda_types_mod


module write_ocean_data_mod

 use mpp_io_mod, only : fieldtype, axistype, mpp_open,&
      MPP_OVERWR, MPP_NETCDF, MPP_MULTI, MPP_SINGLE,&
      mpp_write_meta, mpp_write, mpp_close
 use mpp_mod, only : mpp_error, FATAL
 use oda_types_mod, only : missing_value
 use oda_types_mod, only : ocean_profile_type, max_levels_file
 use time_manager_mod, only : time_type, get_time, set_date, operator ( - )

 implicit none

 private
 
 type(fieldtype), save :: lon_field, lat_field, time_field, data_t_field, data_s_field, &
      project_field,probe_field,ref_inst_field, fix_depth_field, database_id_field,&
      profile_flag_field, profile_flag_s_field, temp_err_field, salt_err_field, &
      flag_t_field, flag_s_field, ocn_vehicle_field,&
      depth_field, nvar_field, lon_index_field, lat_index_field, &
      yyyy_field, mmdd_field, link_field

 integer, parameter :: ref_yr=1900, ref_mon=1, ref_day=1,&
                       ref_hr=0, ref_min=0, ref_sec=0,max_files=1000

 integer :: ref_seconds, ref_days, chid, wmo_id

 integer,save :: nvar_out

 integer, save :: sta_num(max_files), unit_num(max_files), nfiles
 
 type(time_type) :: ref_time, time

 logical :: module_is_initialized=.false.
 
 public :: open_profile_file, write_profile, close_profile_file, &
      write_ocean_data_init
 
#include <netcdf.inc>
 
contains

function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset)

  character(len=*), intent(in) :: name
  integer, intent(in), optional :: nvar
  real, dimension(:), optional, intent(in) :: grid_lon, grid_lat
  integer, intent(in), optional :: thread, fset

  integer :: i, open_profile_file, unit
  integer :: threading, fileset  
  character(len=128) :: units, time_units
  real, dimension(max_levels_file) :: array

type(axistype) :: depth_axis, station_axis, lon_axis, lat_axis

threading=MPP_MULTI
fileset=MPP_SINGLE

if (PRESENT(thread)) threading=thread
if (PRESENT(fset)) fileset=fset

ref_time = set_date(ref_yr, ref_mon, ref_day, ref_hr, ref_min, ref_sec)
call get_time(ref_time, ref_seconds, ref_days)
call mpp_open(unit, trim(name), action=MPP_OVERWR, form=MPP_NETCDF,&
              threading=threading, fileset=fileset)

open_profile_file = unit

nfiles=nfiles+1

if (nfiles > max_files) call mpp_error(FATAL,'max number of profiles exceeded&
     &in module write_ocean_data, increase param : max_files')

unit_num(nfiles) = unit


nvar_out = 2
if (PRESENT(nvar)) nvar_out = nvar

if (PRESENT(grid_lon) .and. PRESENT(grid_lat)) then
   call mpp_write_meta(unit, lon_axis, 'grid_longitude','degrees_E',&
        'observational grid longitude',cartesian='X',sense=1,data=grid_lon)

   call mpp_write_meta(unit, lat_axis, 'grid_latitude','degrees_N',&
        'observational grid latitude', cartesian='Y',sense=1,data=grid_lat)
endif

!call mpp_write_meta(unit,depth_axis,'depth_index','none','depth index',&
!                  cartesian='Z',sense=-1)!,data=(/(float(i),i=1,max_levels_file)/))
!pgf90 complains about the above. This is a compiler bug. Workaround:
array = (/(float(i),i=1,max_levels_file)/)
call mpp_write_meta(unit,depth_axis,'depth_index','none','depth index',&
                    cartesian='Z',sense=-1,data=array)

call mpp_write_meta(unit,station_axis,'station_index','none',&
                    'station index', cartesian='T',sense=1)

if (PRESENT(grid_lon) .and. PRESENT(grid_lat)) then
   call mpp_write_meta(unit, lon_index_field, (/station_axis/),&
        'longitude_index','none','longitude_index', missing=missing_value)
   call mpp_write_meta(unit, lat_index_field, (/station_axis/),&
        'latitude_index','none','latitude_index',missing=missing_value)
endif

call mpp_write_meta(unit,nvar_field,(/station_axis/),&
     'nvar','none','temp (1) or temp and salt (2)')

call mpp_write_meta(unit,lon_field,(/station_axis/),&
                   'longitude','degrees_E','longitude',&
                    min=-1.0,max=361.0)

call mpp_write_meta(unit,lat_field,(/station_axis/),&
                   'latitude','degrees_N','latitude',&
                    min=-91.0,max=91.0)

call mpp_write_meta(unit,profile_flag_field,(/station_axis/),&
                   'profile_flag','none','profile_flag',&
                   min=0.0,max=10.0,missing=missing_value)


if (nvar_out .eq. 2) call mpp_write_meta(unit,profile_flag_s_field,(/station_axis/),&
                   'profile_flag_s','none','profile_flag for salt',&
                    min=0.0,max=10.0,missing=missing_value)


write(time_units,'(a,i4.4,a,i2.2,a,i2.2,a)')  'days since ',ref_yr,'-',ref_mon,'-',ref_day,' 00:00:00'

call mpp_write_meta(unit,time_field,(/station_axis/),&
                   'time',trim(time_units),'time')

call mpp_write_meta(unit,yyyy_field,(/station_axis/),&
     'yyyy','none','yyyy')

call mpp_write_meta(unit,mmdd_field,(/station_axis/),&
                   'mmdd','none','mmdd')



units='deg_C'
call mpp_write_meta(unit,temp_err_field,(/station_axis/),&
                   'temp_error',trim(units),'measurement error of temperature',missing=missing_value)

units='g/kg'
if (nvar_out .eq. 2) call mpp_write_meta(unit,salt_err_field,(/station_axis/),&
                   'salt_error',trim(units),'measurement error of salinity',missing=missing_value)

call mpp_write_meta(unit,project_field,(/station_axis/),&
     'project','none','see NODC codes')

call mpp_write_meta(unit,probe_field,(/station_axis/),&
     'probe','none','see NODC codes')

call mpp_write_meta(unit,ref_inst_field,(/station_axis/),&
     'ref_inst','none','see NODC codes')

call mpp_write_meta(unit,fix_depth_field,(/station_axis/),&
     'fix_depth','none','see NODC codes')

call mpp_write_meta(unit,database_id_field,(/station_axis/),&
     'database_id','none','see NODC codes')

call mpp_write_meta(unit,ocn_vehicle_field,(/station_axis/),&
     'ocn_vehicle','none','see NODC codes')

call mpp_write_meta(unit,link_field,(/station_axis/),&
     'link','none','partial_profile flag')


 units='degrees_C'
 call mpp_write_meta(unit,data_t_field,(/depth_axis,station_axis/),&
              'temp',trim(units),'in-situ temperature',&
                min=-10.0,max=50.0,missing=missing_value)

 units='g/kg'
 if (nvar_out .eq. 2) call mpp_write_meta(unit,data_s_field,(/depth_axis,station_axis/),&
                   'salt',trim(units),'salinity',&
                    min=0.0,max=50.0,missing=missing_value)

call mpp_write_meta(unit,depth_field,(/depth_axis,station_axis/),&
                   'depth','meters','depth of obs',&
                    min=0.0,max=7000.0,missing=missing_value)



call mpp_write_meta(unit,flag_t_field,(/depth_axis,station_axis/),&
     'temp_flag','none','temperature level flag (see NODC codes)',missing=missing_value)

if (nvar_out .eq. 2) call mpp_write_meta(unit,flag_s_field,(/depth_axis,station_axis/),&
     'salt_flag','none','salinity level flag (see NODC codes)',missing=missing_value)



call mpp_write(unit, depth_axis)

if (PRESENT(grid_lon).and.PRESENT(grid_lat)) then
   call mpp_write(unit, lon_axis)
   call mpp_write(unit, lat_axis)
endif

end function open_profile_file


subroutine write_profile(unit,profile)

use mpp_domains_mod, only : domain2d,mpp_get_compute_domain, &
                            mpp_get_data_domain
use mpp_mod, only : mpp_pe

integer, intent(in) :: unit
type(ocean_profile_type), intent(in) :: profile

real, dimension(max_levels_file) :: data_t, data_s, depth
integer :: levels, secs, days, i, j, nlinks
real :: profile_flag, profile_flag_s, days_since, error, nvar, station
real :: tmp_s
real, dimension(max_levels_file) :: flag_t, flag_s
logical :: grid_ptr = .false.
integer :: findex
integer :: isc,iec,jsc,jec,isd,ied,jsd,jed
logical :: debug=.false.

! find file index from file unit list

findex=-1
do i=1,nfiles
   if (unit_num(i) .eq. unit) then
       findex=i
       exit
   endif
enddo

if (findex .eq. -1) call mpp_error(FATAL,'Attempt write to unopened file in&
     &write_ocean_data_mod:write_profile_data')


sta_num(findex)=sta_num(findex)+1

station=sta_num(findex)

levels = min(profile%levels,max_levels_file)
data_t=missing_value;data_s=missing_value;depth=missing_value
flag_t=missing_value;flag_s=missing_value
data_t(1:levels)=profile%data_t(1:levels)
flag_t(1:levels)=profile%flag_t(1:levels)

if (ASSOCIATED(profile%Model_Grid)) grid_ptr = .true.


if (grid_ptr) then
    call mpp_get_compute_domain(profile%Model_Grid%Dom, isc, iec, jsc, jec)
    if (floor(profile%i_index) .lt. isc .or. floor(profile%i_index) .gt. iec) return
    if (floor(profile%j_index) .lt. jsc .or. floor(profile%j_index) .gt. jec) return    
endif

if (profile%nvar == 2) then
    data_s(1:levels)   = profile%data_s(1:levels)
    flag_s(1:levels)=profile%flag_s(1:levels)
endif
  
depth(1:levels)=profile%depth(1:levels) 
time = profile%time - ref_time
call get_time(time, secs, days)
days_since = days + secs/86400.


 nvar = profile%nvar
 call mpp_write(unit,nvar_field,nvar,station)
 call mpp_write(unit,data_t_field,data_t,station)
 if (nvar_out .eq. 2) call mpp_write(unit,data_s_field,data_s,station)
 call mpp_write(unit,depth_field,depth,station)
 call mpp_write(unit,project_field,profile%project,station)
 call mpp_write(unit,probe_field,profile%probe,station)
 call mpp_write(unit,ref_inst_field,profile%ref_inst,station)
 call mpp_write(unit,fix_depth_field,profile%fix_depth,station)
 call mpp_write(unit,ocn_vehicle_field,profile%ocn_vehicle,station)
 call mpp_write(unit,database_id_field,profile%database_id,station)
 profile_flag = profile%profile_flag
 call mpp_write(unit,profile_flag_field,profile_flag,station)
 profile_flag = profile%profile_flag_s
 if (nvar_out .eq. 2) call mpp_write(unit,profile_flag_s_field,profile_flag,station) 
 call mpp_write(unit,lon_field,profile%lon,station)
 call mpp_write(unit,lat_field,profile%lat,station)
 call mpp_write(unit,time_field,days_since,station)
 tmp_s = real(profile%yyyy)
 call mpp_write(unit,yyyy_field,tmp_s,station)
 tmp_s = real(profile%mmdd)
 call mpp_write(unit,mmdd_field,tmp_s,station) 
 call mpp_write(unit,temp_err_field,profile%temp_err,station)
 if (nvar_out .eq. 2) call mpp_write(unit,salt_err_field,profile%salt_err,station)
 nlinks = 0

 if (profile%levels .gt. max_levels_file) then
     nlinks = ceiling(float(profile%levels)/float(max_levels_file)) - 1
 endif

 if (nlinks .gt. 0) then
     call mpp_write(unit,link_field,1.,station)
 else
     call mpp_write(unit,link_field,0.,station)
 endif

if (profile%i_index .ne. -1.0 .and. profile%j_index .ne. -1.0) then
   call mpp_write(unit, lon_index_field,profile%i_index)
   call mpp_write(unit, lat_index_field,profile%j_index)
endif

do i = 1, nlinks
   sta_num(findex)=sta_num(findex)+1
   station=sta_num(findex)
   if (i.eq.nlinks) then
       levels = mod(profile%levels,max_levels_file)
       if (levels .eq. 0) levels = max_levels_file
   else
       levels = max_levels_file
   endif
   data_t = missing_value; data_s = missing_value; depth = missing_value
   flag_t=missing_value;flag_s=missing_value
   
   data_t(1:levels)=profile%data_t((max_levels_file*i)+1:(max_levels_file*i)+levels)
   flag_t(1:levels)=profile%flag_t((max_levels_file*i)+1:(max_levels_file*i)+levels)    

   if (profile%nvar == 2) then
       data_s(1:levels)   = profile%data_s((max_levels_file*i)+1:(max_levels_file*i)+levels)
       flag_s(1:levels)= profile%flag_s((max_levels_file*i)+1:(max_levels_file*i)+levels)

   endif
       
       
   depth(1:levels)=profile%depth((max_levels_file*i)+1:(max_levels_file*i)+levels)

   call mpp_write(unit,nvar_field,nvar,station)   
   call mpp_write(unit,data_t_field,data_t,station)
   if (nvar_out .eq. 2) call mpp_write(unit,data_s_field,data_s,station)
   call mpp_write(unit,depth_field,depth,station)
   
   call mpp_write(unit,project_field,profile%project,station)
   call mpp_write(unit,probe_field,profile%probe,station)
   call mpp_write(unit,ref_inst_field,profile%ref_inst,station)
   call mpp_write(unit,fix_depth_field,profile%fix_depth,station)
   call mpp_write(unit,ocn_vehicle_field,profile%ocn_vehicle,station)
   call mpp_write(unit,database_id_field,profile%database_id,station)
   profile_flag = profile%profile_flag
   call mpp_write(unit,profile_flag_field,profile_flag,station)
   profile_flag = profile%profile_flag_s
   if (nvar_out .eq. 2)   call mpp_write(unit,profile_flag_s_field,profile_flag,station) 
   call mpp_write(unit,lon_field,profile%lon,station)
   call mpp_write(unit,lat_field,profile%lat,station)
   call mpp_write(unit,time_field,days_since,station)
   tmp_s = real(profile%yyyy)
   call mpp_write(unit,yyyy_field,tmp_s,station)
   tmp_s = real(profile%mmdd)
   call mpp_write(unit,mmdd_field,tmp_s,station)   
   call mpp_write(unit,temp_err_field,profile%temp_err,station)
   if (nvar_out .eq. 2)   call mpp_write(unit,salt_err_field,profile%salt_err,station)

   if (profile%i_index .ne. -1.0 .and. profile%j_index .ne. -1.0) then
       call mpp_write(unit, lon_index_field,profile%i_index)
       call mpp_write(unit, lat_index_field,profile%j_index)
   endif

   if (i .lt. nlinks) then
       call mpp_write(unit,link_field,1.,station)
   else
       call mpp_write(unit,link_field,0.,station)
   endif
   
enddo

end subroutine write_profile

subroutine close_profile_file(unit)

  integer, intent(in) :: unit

  call mpp_close(unit)

end subroutine close_profile_file

subroutine write_ocean_data_init()

  module_is_initialized=.true.

  sta_num=0;unit_num=0;nfiles=0

  return
  
end subroutine write_ocean_data_init

end module write_ocean_data_mod
  
  


module xbt_adjust

  use oda_types_mod, only : ocean_profile_type, missing_value

  implicit none
  
  real, parameter :: s1=0.30731408,s2=6.707e-9,s3=-8.1899e-5,sa=3.227,&
                     sb=-2.17e-4
  real, parameter :: t1=0.29585798,t2=1.002e-9,t3=-3.1658e-5,ta=3.426,&
       tb=-4.7e-4

contains
  
subroutine xbt_drop_rate_adjust(station)


  type(ocean_profile_type), intent(inout) :: station


  integer :: k
  real :: dpth_orig, dpth_new,tdrop
  integer :: fix_depth
  
  if (.not. station%accepted) return

  fix_depth = int(station%fix_depth)
  select case(fix_depth)
  case(-1)
      return
  case(0)
      return      
  case(1)
! use Hanawa et al (1994) drop rate correction
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             dpth_new = (1.0417*dpth_orig) - (75.096*(1.0-((1.0-(0.0002063*dpth_orig)))**0.5))
             station%depth(k)=dpth_new
         endif
      enddo
      station%fix_depth=-1.0
  case (2)
! use Kizu et al (2005) correction
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             if (dpth_orig .le. 250.0) then
                 dpth_new = dpth_orig*0.9572
             else if (dpth_orig .le. 500.) then
                 dpth_new = dpth_orig*0.9565
             else if (dpth_orig .le. 750.0) then
                 dpth_new = dpth_orig*0.9558
             else if (dpth_orig .le. 1000.) then
                 dpth_new = dpth_orig*0.9550
             else if (dpth_orig .le. 1250.0) then
                 dpth_new = dpth_orig*0.9542
             else if (dpth_orig .le. 1500.0) then
                 dpth_new = dpth_orig*0.9533
             else
                 dpth_new = dpth_orig*0.9524
             endif
             station%depth(k)=dpth_new       
         endif
      enddo
      station%fix_depth=-1.0      
  case(103)
      do k=1,station%levels      
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             tdrop=(s1*dpth_orig + s2) - s3
             dpth_new = sa*tdrop + sb*tdrop*tdrop
             station%depth(k)=dpth_new             
         endif
      enddo
      station%fix_depth=-1.0      
  case(104)
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             tdrop=(t1*dpth_orig + t2) - t3
             dpth_new = ta*tdrop + tb*tdrop*tdrop
             station%depth(k)=dpth_new             
         endif
      enddo
      station%fix_depth=-1.0      
  end select

  return
end subroutine xbt_drop_rate_adjust

end module xbt_adjust


module platform_mod
!platform-dependent settings
#include <fms_platform.h>
  public
  integer, parameter :: r8_kind=DOUBLE_KIND, r4_kind=FLOAT_KIND, &
                        c8_kind=DOUBLE_KIND, c4_kind=FLOAT_KIND, &
                        l8_kind=LONG_KIND, l4_kind=INT_KIND, &
                        i8_kind=LONG_KIND, i4_kind=INT_KIND, i2_kind=SHORT_KIND
!could additionally define things like OS, compiler...: useful?
end module platform_mod


! Fortran-95 implementation of the Mersenne Twister 19937, following 
!   the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), 
!   adapted cosmetically by making the names more general.  
! Users must declare one or more variables of type randomNumberSequence in the calling 
!   procedure which are then initialized using a required seed. If the 
!   variable is not initialized the random numbers will all be 0. 
! For example: 
! program testRandoms 
!   use RandomNumbers
!   type(randomNumberSequence) :: randomNumbers
!   integer                    :: i
!   
!   randomNumbers = new_RandomNumberSequence(seed = 100)
!   do i = 1, 10
!     print ('(f12.10, 2x)'), getRandomReal(randomNumbers)
!   end do
! end program testRandoms
! 
! Fortran-95 implementation by 
!   Robert Pincus
!   NOAA-CIRES Climate Diagnostics Center
!   Boulder, CO 80305 
!   email: Robert.Pincus@colorado.edu
!
! This documentation in the original C program reads:
! -------------------------------------------------------------
!    A C-program for MT19937, with initialization improved 2002/2/10.
!    Coded by Takuji Nishimura and Makoto Matsumoto.
!    This is a faster version by taking Shawn Cokus's optimization,
!    Matthe Bellew's simplification, Isaku Wada's real version.
! 
!    Before using, initialize the state by using init_genrand(seed) 
!    or init_by_array(init_key, key_length).
! 
!    Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
!    All rights reserved.                          
! 
!    Redistribution and use in source and binary forms, with or without
!    modification, are permitted provided that the following conditions
!    are met:
! 
!      1. Redistributions of source code must retain the above copyright
!         notice, this list of conditions and the following disclaimer.
! 
!      2. Redistributions in binary form must reproduce the above copyright
!         notice, this list of conditions and the following disclaimer in the
!         documentation and/or other materials provided with the distribution.
! 
!      3. The names of its contributors may not be used to endorse or promote 
!         products derived from this software without specific prior written 
!         permission.
! 
!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
!    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
!    A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
!    CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
!    EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
!    PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
!    PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
!    LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
!    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! 
! 
!    Any feedback is very welcome.
!    http://www.math.keio.ac.jp/matumoto/emt.html
!    email: matumoto@math.keio.ac.jp
! -------------------------------------------------------------

module MersenneTwister_mod
! -------------------------------------------------------------
  implicit none
  private
  
  ! Algorithm parameters
  ! -------
  ! Period parameters
  integer, parameter :: blockSize = 624,         &
                        M         = 397,         &
                        MATRIX_A  = -1727483681, & ! constant vector a         (0x9908b0dfUL)
                        UMASK     = -2147483648, & ! most significant w-r bits (0x80000000UL)
                        LMASK     =  2147483647    ! least significant r bits  (0x7fffffffUL)
  ! Tempering parameters
  integer, parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL)
                        TMASKC= -272236544     ! (0xefc60000UL)
  ! -------

  ! The type containing the state variable  
  type randomNumberSequence
    integer                            :: currentElement ! = blockSize
    integer, dimension(0:blockSize -1) :: state ! = 0
  end type randomNumberSequence

  interface new_RandomNumberSequence
    module procedure initialize_scalar, initialize_vector
  end interface new_RandomNumberSequence 

  public :: randomNumberSequence
  public :: new_RandomNumberSequence, finalize_RandomNumberSequence, &
            getRandomInt, getRandomPositiveInt, getRandomReal
! -------------------------------------------------------------
contains
  ! -------------------------------------------------------------
  ! Private functions
  ! ---------------------------
  function mixbits(u, v)
    integer, intent( in) :: u, v
    integer              :: mixbits
    
    mixbits = ior(iand(u, UMASK), iand(v, LMASK))
  end function mixbits
  ! ---------------------------
  function twist(u, v)
    integer, intent( in) :: u, v
    integer              :: twist

    ! Local variable
    integer, parameter, dimension(0:1) :: t_matrix = (/ 0, MATRIX_A /)
    
    twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1)))
    twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1)))
  end function twist
  ! ---------------------------
  subroutine nextState(twister)
    type(randomNumberSequence), intent(inout) :: twister
    
    ! Local variables
    integer :: k
    
    do k = 0, blockSize - M - 1
      twister%state(k) = ieor(twister%state(k + M), &
                              twist(twister%state(k), twister%state(k + 1)))
    end do 
    do k = blockSize - M, blockSize - 2
      twister%state(k) = ieor(twister%state(k + M - blockSize), &
                              twist(twister%state(k), twister%state(k + 1)))
    end do 
    twister%state(blockSize - 1) = ieor(twister%state(M - 1), &
                                        twist(twister%state(blockSize - 1), twister%state(0)))
    twister%currentElement = 0

  end subroutine nextState
  ! ---------------------------
  elemental function temper(y)
    integer, intent(in) :: y
    integer             :: temper
    
    integer :: x
    
    ! Tempering
    x      = ieor(y, ishft(y, -11))
    x      = ieor(x, iand(ishft(x,  7), TMASKB))
    x      = ieor(x, iand(ishft(x, 15), TMASKC))
    temper = ieor(x, ishft(x, -18))
  end function temper
  ! -------------------------------------------------------------
  ! Public (but hidden) functions
  ! --------------------
  function initialize_scalar(seed) result(twister)
    integer,       intent(in   ) :: seed
    type(randomNumberSequence)                :: twister 
    
    integer :: i
    ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, 
    !   MSBs of the seed affect only MSBs of the array state[].                       
    !   2002/01/09 modified by Makoto Matsumoto            
    
    twister%state(0) = iand(seed, -1)
    do i = 1,  blockSize - 1 ! ubound(twister%state)
       twister%state(i) = 1812433253 * ieor(twister%state(i-1), &
                                            ishft(twister%state(i-1), -30)) + i
       twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines
    end do
    twister%currentElement = blockSize
  end function initialize_scalar
  ! -------------------------------------------------------------
  function initialize_vector(seed) result(twister)
    integer, dimension(0:), intent(in) :: seed
    type(randomNumberSequence)                      :: twister 
    
    integer :: i, j, k, nFirstLoop, nWraps
    
    nWraps  = 0
    twister = initialize_scalar(19650218)
    
    nFirstLoop = max(blockSize, size(seed))
    do k = 1, nFirstLoop
       i = mod(k + nWraps, blockSize)
       j = mod(k - 1,      size(seed))
       if(i == 0) then
         twister%state(i) = twister%state(blockSize - 1)
         twister%state(1) = ieor(twister%state(1),                                 &
                                 ieor(twister%state(1-1),                          & 
                                      ishft(twister%state(1-1), -30)) * 1664525) + & 
                            seed(j) + j ! Non-linear
         twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines
         nWraps = nWraps + 1
       else
         twister%state(i) = ieor(twister%state(i),                                 &
                                 ieor(twister%state(i-1),                          & 
                                      ishft(twister%state(i-1), -30)) * 1664525) + & 
                            seed(j) + j ! Non-linear
         twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines
      end if
    end do
    
    !
    ! Walk through the state array, beginning where we left off in the block above
    ! 
    do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1
      twister%state(i) = ieor(twister%state(i),                                 &
                              ieor(twister%state(i-1),                          & 
                                   ishft(twister%state(i-1), -30)) * 1566083941) - i ! Non-linear
      twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines
    end do
    
    twister%state(0) = twister%state(blockSize - 1) 
    
    do i = 1, mod(nFirstLoop, blockSize) + nWraps
      twister%state(i) = ieor(twister%state(i),                                 &
                              ieor(twister%state(i-1),                          & 
                                   ishft(twister%state(i-1), -30)) * 1566083941) - i ! Non-linear
      twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines
    end do
    
    twister%state(0) = UMASK 
    twister%currentElement = blockSize
    
  end function initialize_vector
  ! -------------------------------------------------------------
  ! Public functions
  ! --------------------
  function getRandomInt(twister)
    type(randomNumberSequence), intent(inout) :: twister
    integer                      :: getRandomInt
    ! Generate a random integer on the interval [0,0xffffffff]
    !   Equivalent to genrand_int32 in the C code. 
    !   Fortran doesn't have a type that's unsigned like C does, 
    !   so this is integers in the range -2**31 - 2**31
    ! All functions for getting random numbers call this one, 
    !   then manipulate the result
    
    if(twister%currentElement >= blockSize) call nextState(twister)
      
    getRandomInt = temper(twister%state(twister%currentElement))
    twister%currentElement = twister%currentElement + 1
  
  end function getRandomInt
  ! --------------------
  function getRandomPositiveInt(twister)
    type(randomNumberSequence), intent(inout) :: twister
    integer                      :: getRandomPositiveInt
    ! Generate a random integer on the interval [0,0x7fffffff]
    !   or [0,2**31]
    !   Equivalent to genrand_int31 in the C code. 
    
    ! Local integers
    integer :: localInt

    localInt = getRandomInt(twister)
    getRandomPositiveInt = ishft(localInt, -1)
  
  end function getRandomPositiveInt
  ! --------------------
  function getRandomReal(twister)
    type(randomNumberSequence), intent(inout) :: twister
    double precision             :: getRandomReal
    ! Generate a random number on [0,1]
    !   Equivalent to genrand_real1 in the C code
    !   The result is stored as double precision but has 32 bit resolution
    
    integer :: localInt
    
    localInt = getRandomInt(twister)
    if(localInt < 0) then
      getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
    else
      getRandomReal = dble(localInt            )/(2.0d0**32 - 1.0d0)
    end if
  end function getRandomReal
  ! --------------------
  subroutine finalize_RandomNumberSequence(twister)
    type(randomNumberSequence), intent(inout) :: twister
    
      twister%currentElement = blockSize
      twister%state(:) = 0
  end subroutine finalize_RandomNumberSequence
  ! --------------------  
end module MersenneTwister_mod



module random_numbers_mod 
  ! Generic module to wrap random number generators. 
  !   The module defines a type that identifies the particular stream of random 
  !   numbers, and has procedures for initializing it and getting real numbers 
  !   in the range 0 to 1. 
  ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. 
  !
  use MersenneTwister_mod, only: randomNumberSequence, & ! The random number engine.
                                 new_RandomNumberSequence, getRandomReal 
  use time_manager_mod, only: time_type, get_date
  implicit none
  private
  
  type randomNumberStream
    type(randomNumberSequence) :: theNumbers
  end type randomNumberStream
  
  interface getRandomNumbers
    module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D
  end interface getRandomNumbers
  
  interface initializeRandomNumberStream
    module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V
  end interface initializeRandomNumberStream

  public :: randomNumberStream,                             &
            initializeRandomNumberStream, getRandomNumbers, &
            constructSeed
contains
  ! ---------------------------------------------------------
  ! Initialization
  ! ---------------------------------------------------------
  function initializeRandomNumberStream_S(seed) result(new) 
    integer, intent( in)     :: seed
    type(randomNumberStream) :: new
    
    new%theNumbers = new_RandomNumberSequence(seed)
    
  end function initializeRandomNumberStream_S
  ! ---------------------------------------------------------
  function initializeRandomNumberStream_V(seed) result(new) 
    integer, dimension(:), intent( in) :: seed
    type(randomNumberStream)           :: new
    
    new%theNumbers = new_RandomNumberSequence(seed)
    
  end function initializeRandomNumberStream_V
  ! ---------------------------------------------------------
  ! Procedures for drawing random numbers
  ! ---------------------------------------------------------
  subroutine getRandomNumber_Scalar(stream, number)
    type(randomNumberStream), intent(inout) :: stream
    real,                     intent(  out) :: number
    
    number = getRandomReal(stream%theNumbers)
  end subroutine getRandomNumber_Scalar
  ! ---------------------------------------------------------
  subroutine getRandomNumber_1D(stream, numbers)
    type(randomNumberStream), intent(inout) :: stream
    real, dimension(:),       intent(  out) :: numbers
    
    ! Local variables
    integer :: i
    
    do i = 1, size(numbers)
      numbers(i) = getRandomReal(stream%theNumbers)
    end do
  end subroutine getRandomNumber_1D
  ! ---------------------------------------------------------
  subroutine getRandomNumber_2D(stream, numbers)
    type(randomNumberStream), intent(inout) :: stream
    real, dimension(:, :),    intent(  out) :: numbers
    
    ! Local variables
    integer :: i
    
    do i = 1, size(numbers, 2)
      call getRandomNumber_1D(stream, numbers(:, i))
    end do
  end subroutine getRandomNumber_2D
  ! ---------------------------------------------------------
  ! Constructs a unique seed from grid cell index and model date/time
  !   The perm is supplied we generate a different seed by 
  !   circularly shifting the bits of the seed - this is useful 
  !   if we want to create more than one seed for a given 
  !   column and model date/time. 
  !   Note that abs(perm) must be <= the number of bits used 
  !   to represent the default integer (likely 32) 
  ! ---------------------------------------------------------
  function constructSeed(i, j, time, perm) result(seed)
    integer,           intent( in)  :: i, j
    type(time_type),   intent( in) :: time
    integer, optional, intent( in) :: perm
    integer, dimension(8) :: seed
    
    ! Local variables
    integer :: year, month, day, hour, minute, second
    
    
    call get_date(time, year, month, day, hour, minute, second)
    seed = (/ i, j, year, month, day, hour, minute, second /)
    if(present(perm)) seed = ishftc(seed, perm)
  end function constructSeed
end module random_numbers_mod




module sat_vapor_pres_mod

!-----------------------------------------------------------------------
!
!                 saturation vapor pressure lookup
!                 saturation vapor specific humidity calculation
!                 saturation vapor mixing ratio calculation
!
!      routines for computing the saturation vapor pressure (es),
!      the specific humidity (qs) and vapor mixing ratio (mrs) at
!      a specified relative humidity, the derivatives of es, qs and mrs 
!      with respect to temperature, and initialization of the 
!      look-up table.
!
!-----------------------------------------------------------------------
!
!                               usage
!                               -----
!
!              call lookup_es  (temp, es, err_msg)
!
!              call lookup_des (temp, des, err_msg)
!
!              call lookup_es_des (temp, es, des, err_msg)
!
!              call lookup_es2 (temp, es, err_msg)
!
!              call lookup_des2 (temp, des, err_msg)
!
!              call lookup_es2_des2 (temp, es, des, err_msg)
!
!              call compute_qs (temp, press, qs, q, hc, dqsdT, esat, 
!                               err_msg, es_over_liq)
!
!              call compute_mrs (temp, press, mrs, mr, hc, dmrsdT, esat,
!                                err_msg, es_over_liq)
!
!    arguments
!    ---------
!      temp    intent in       temperature in degrees kelvin
!      es      intent out      saturation vapor pressure in Pascals
!      des     intent out      derivative of saturation vapor pressure
!                              with respect to temperature 
!                              (Pascals/degree)
!      press   intent in       atmospheric pressure in Pascals
!      qs      intent out      specific humidity at relative humidity hc
!                              (kg(vapor) / kg(moist air)
!      mrs     intent out      mixing ratio at relative humidity hc     
!                              (kg(vapor) / kg(dry air)
!
!   optional arguments
!   ------------------
!      q       intent in       vapor specific humidity
!                              (kg(vapor) / kg(moist air)
!      hc      intent in       relative humidity at which output
!                              fields are desired: default is 100 %
!      dqsdT   intent out      derivative of saturation specific 
!                              humidity with respect to temperature 
!                              (kg(vapor) / kg(moist air) /degree)
!      mr      intent in       vapor mixing ratio        
!                              (kg(vapor) / kg(dry air)
!      dmrsdT  intent out      derivative of saturation mixing ratio
!                              with respect to temperature 
!                              (kg(vapor) / kg(dry air) /degree)
!      esat    intent out      saturation vapor pressure
!                              (Pascals)
!      err_msg intent out      character string to hold error message
!      es_over_liq
!              intent  in      use es table wrt liquid only
!
!-----------------------------------------------------------------------

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Routines for determining the saturation vapor pressure 
!   (<TT>ES</TT>), saturation vapor specific humidity and saturation 
!   vapor mixing ratio, and their derivatives with respect to 
!   temperature.
! </OVERVIEW>

! <DESCRIPTION>
!   This module contains routines for determining the saturation vapor
!   pressure (<TT>ES</TT>) from lookup tables constructed using equations given
!   in the Smithsonian tables.  The <TT>ES</TT> lookup tables are valid between
!   -160C and +100C (approx 113K to 373K).

!   The values of <TT>ES</TT> are computed over ice from -160C to -20C,
!   over water from 0C to 100C, and a blended value (over water and ice)
!   from -20C to 0C.

!   Routines are also included to calculate the saturation specific
!   humidity and saturation mixing ratio for vapor, and their deriv-
!   atives with respect to temperature.  By default, the values returned
!   are those at saturation; optionally, values of q and mr at a spec-
!   ified relative humidity may instead be returned. Two forms are 
!   available; the approximate form that has been traditionally used in 
!   GCMs, and an exact form provided by SJ Lin in which saturation is 
!   reached while maintaining constant pressure and temperature.

!   This version was written for non-vector machines.
!   See the <LINK SRC="#NOTES">notes</LINK> section for details on vectorization.

! </DESCRIPTION>

! <PUBLIC>
!   Description summarizing public interface.
! </PUBLIC>

 use         constants_mod, only:  TFREEZE, RDGAS, RVGAS, HLV, ES0
 use        fms_mod, only:  write_version_number, stdout, stdlog, mpp_pe, mpp_root_pe, &
                            mpp_error, FATAL, fms_error_handler, open_namelist_file,   &
                            error_mesg, &
                            file_exist, check_nml_error
 use     mpp_io_mod, only:  mpp_close
 use        mpp_mod, only: input_nml_file
 use  sat_vapor_pres_k_mod, only:  sat_vapor_pres_init_k, lookup_es_k, &
                                   lookup_des_k, lookup_es_des_k, &
                                   lookup_es2_k,  &
                                   lookup_des2_k, lookup_es2_des2_k, &
                                   lookup_es3_k,  &
                                   lookup_des3_k, lookup_es3_des3_k, &
                                   compute_qs_k, compute_mrs_k

implicit none
private

 public :: lookup_es, lookup_des, sat_vapor_pres_init
 public :: lookup_es2, lookup_des2, lookup_es2_des2
 public :: lookup_es3, lookup_des3, lookup_es3_des3
 public :: lookup_es_des, compute_qs, compute_mrs
!public :: compute_es
 public :: escomp, descomp ! for backward compatibility
                           ! use lookup_es, lookup_des instead

!-----------------------------------------------------------------------
 
! <INTERFACE NAME="lookup_es">

!   <OVERVIEW>
!     For the given temperatures, returns the saturation vapor pressures.
!   </OVERVIEW>
!   <DESCRIPTION>
!     For the given temperatures these routines return the
!     saturation vapor pressure (esat). The return values are derived from
!     lookup tables (see notes below).
!   </DESCRIPTION>
!   <TEMPLATE>
!     call lookup_es( temp, esat, err_msg )
!   </TEMPLATE>
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Temperature in degrees Kelvin.
!   </IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Saturation vapor pressure in pascals.
!             May be a scalar, 1d, 2d, or 3d array.
!             Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="err_msg" UNITS="      " TYPE="character">
!     Character string containing error message to be returned to
!     calling routine.
!   </OUT>
!   <ERROR MSG="table overflow, nbad=##" STATUS="FATAL">
!     Temperature(s) provided to the saturation vapor pressure lookup
!          are outside the valid range of the lookup table (-160 to 100 deg C).
!          This may be due to a numerical instability in the model.
!          Information should have been printed to standard output to help
!          determine where the instability may have occurred.
!          If the lookup table needs a larger temperature range,
!          then parameters in the module header must be modified.
!   </ERROR> *

 interface lookup_es
   module procedure lookup_es_0d, lookup_es_1d, lookup_es_2d, lookup_es_3d
 end interface
! for backward compatibility (to be removed soon)
 interface escomp
   module procedure lookup_es_0d, lookup_es_1d, lookup_es_2d, lookup_es_3d
 end interface
! </INTERFACE>
!-----------------------------------------------------------------------
! <INTERFACE NAME="lookup_des">

!   <OVERVIEW>
!     For the given temperatures, returns the derivative of saturation vapor pressure
!     with respect to temperature.
!   </OVERVIEW>
!   <DESCRIPTION>
!     For the given temperatures these routines return the derivative of esat w.r.t.
!     temperature (desat). The return values are derived from
!     lookup tables (see notes below).
!   </DESCRIPTION>
!   <TEMPLATE>
!     call lookup_des( temp, desat )
!   </TEMPLATE>
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Temperature in degrees Kelvin.
!   </IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Derivative of saturation vapor pressure w.r.t. temperature
!                 in pascals/degree. May be a scalar, 1d, 2d, or 3d array.
!                 Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="err_msg" UNITS="      " TYPE="character">
!     Character string containing error message to be returned to
!     calling routine.
!   </OUT>
!   <ERROR MSG="table overflow, nbad=##" STATUS="FATAL">
!     Temperature(s) provided to the saturation vapor pressure lookup
!          are outside the valid range of the lookup table (-160 to 100 deg C).
!          This may be due to a numerical instability in the model.
!          Information should have been printed to standard output to help
!          determine where the instability may have occurred.
!          If the lookup table needs a larger temperature range,
!          then parameters in the module header must be modified.
!   </ERROR> *

 interface lookup_des
   module procedure lookup_des_0d, lookup_des_1d, lookup_des_2d, lookup_des_3d
 end interface
! </INTERFACE>
! for backward compatibility (to be removed soon)
 interface descomp
   module procedure lookup_des_0d, lookup_des_1d, lookup_des_2d, lookup_des_3d
 end interface

!-----------------------------------------------------------------------
 
! <INTERFACE NAME="lookup_es_des">

!   <OVERVIEW>
!     For the given temperatures, returns the saturation vapor pressure 
!     and the derivative of saturation vapor pressure with respect to
!     temperature.
!   </OVERVIEW>
!   <DESCRIPTION>
!     For the given temperatures these routines return the
!     saturation vapor pressure (esat) and the derivative of esat w.r.t
!     temperature (desat). The return values are derived from
!     lookup tables (see notes below).
!   </DESCRIPTION>
!   <TEMPLATE>
!     call lookup_es_des( temp, esat, desat, err_msg )
!   </TEMPLATE>
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Temperature in degrees Kelvin.
!   </IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Saturation vapor pressure in pascals.
!             May be a scalar, 1d, 2d, or 3d array.
!             Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="desat" UNITS="pascal/ degree" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Derivative of saturation vapor pressure w.r.t. temperature
!                 in pascals/degree. May be a scalar, 1d, 2d, or 3d array.
!                 Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="err_msg" UNITS="      " TYPE="character">
!     Character string containing error message to be returned to
!     calling routine.
!   </OUT>
!   <ERROR MSG="table overflow, nbad=##" STATUS="FATAL">
!     Temperature(s) provided to the saturation vapor pressure lookup
!          are outside the valid range of the lookup table (-160 to 100 deg C).
!          This may be due to a numerical instability in the model.
!          Information should have been printed to standard output to help
!          determine where the instability may have occurred.
!          If the lookup table needs a larger temperature range,
!          then parameters in the module header must be modified.
!   </ERROR> *

 interface lookup_es_des
   module procedure lookup_es_des_0d, lookup_es_des_1d, lookup_es_des_2d, lookup_es_des_3d
 end interface

 interface lookup_es2
   module procedure lookup_es2_0d, lookup_es2_1d, lookup_es2_2d, lookup_es2_3d
 end interface
 
 interface lookup_des2
   module procedure lookup_des2_0d, lookup_des2_1d, lookup_des2_2d, lookup_des2_3d
 end interface

 interface lookup_es2_des2
   module procedure lookup_es2_des2_0d, lookup_es2_des2_1d, lookup_es2_des2_2d, lookup_es2_des2_3d
 end interface


 interface lookup_es3
   module procedure lookup_es3_0d, lookup_es3_1d, lookup_es3_2d, lookup_es3_3d
 end interface
 
 interface lookup_des3
   module procedure lookup_des3_0d, lookup_des3_1d, lookup_des3_2d, lookup_des3_3d
 end interface

 interface lookup_es3_des3
   module procedure lookup_es3_des3_0d, lookup_es3_des3_1d, lookup_es3_des3_2d, lookup_es3_des3_3d
 end interface

!-----------------------------------------------------------------------
 
! <INTERFACE NAME="compute_qs">

!   <OVERVIEW>
!     For the given temperatures, pressures and optionally vapor 
!     specific humidity, returns the specific humidity at saturation 
!     (optionally at relative humidity hc instead of at saturation) and
!     optionally the derivative of saturation specific humidity w.r.t.
!     temperature, and the saturation vapor pressure.
!   </OVERVIEW>
!   <DESCRIPTION>
!     For the input temperature and pressure these routines return the
!     specific humidity (qsat) at saturation (unless optional argument
!     hc is used to specify the relative humidity at which qsat should
!     apply) and, if desired, the derivative of qsat w.r.t temperature 
!     (dqsdT) and / or the saturation vapor pressure (esat). If the 
!     optional input argument specific humidity (q) is present, the 
!     exact expression for qs is used; if q is not present the tradit-
!     ional form (valid at saturation) is used. if the optional qsat 
!     derivative argument is present, the derivative of qsat w.r.t. 
!     temperature will also be returned, defined consistent with the 
!     expression used for qsat. The return values are derived from 
!     lookup tables (see notes below).
!   </DESCRIPTION>
!   <TEMPLATE>
!     call compute_qs( temp, press, qsat, q, hc, dqsdT, esat, err_msg )
!   </TEMPLATE>
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Temperature in degrees Kelvin.
!   </IN>
!   <IN NAME="press" UNIT="Pascals" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Air pressure in Pascals.
!   </IN>
!   <OUT NAME="qsat" UNITS="kg(vapor) / kg(moist air)" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Specific humidity in kg (vapor) / kg (moist air)
!             May be a scalar, 1d, 2d, or 3d array.
!             Must have the same order and size as temp.
!   </OUT>
!   <IN NAME="q" UNIT="kg(vapor) / kg (moist air)" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Vapor specific humidity in kg (vapor) / kg (moist air).
!     If present, exact formulation for qsat and dqsdT will be used.
!   </IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)">
!     Relative humidity at which output variables are desired.
!     If not present, values will apply at saturation.
!   </IN>
!   <OUT NAME="dqsdT" UNITS="kg(vapor) / kg(moist air) / degree" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Derivative of saturation specific humidity w.r.t. temperature
!                 in kg(vapor) / kg(moist air) / degree. May be a 
!                 scalar, 1d, 2d, or 3d array.
!                 Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Saturation vapor pressure. May be a scalar, 1d, 2d, or 3d array.
!                 Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="err_msg" UNITS="      " TYPE="character">
!     Character string containing error message to be returned to
!     calling routine.
!   </OUT>
!   <ERROR MSG="table overflow, nbad=##" STATUS="FATAL">
!     Temperature(s) provided to the saturation vapor pressure lookup
!          are outside the valid range of the lookup table (-160 to 100 deg C).
!          This may be due to a numerical instability in the model.
!          Information should have been printed to standard output to help
!          determine where the instability may have occurred.
!          If the lookup table needs a larger temperature range,
!          then parameters in the module header must be modified.
!   </ERROR> *

 interface compute_qs
   module procedure compute_qs_0d, compute_qs_1d, compute_qs_2d, compute_qs_3d
 end interface

!-----------------------------------------------------------------------
 
! <INTERFACE NAME="compute_mrs">

!   <OVERVIEW>
!     For the given temperatures, pressures and optionally vapor 
!     mixing ratio, returns the  vapor mixing ratio at saturation 
!     (optionally at relative humidity hc instead of at saturation) and
!     optionally the derivative of saturation vapor mixing ratio w.r.t.
!     temperature, and the saturation vapor pressure.
!   </OVERVIEW>
!   <DESCRIPTION>
!     For the input temperature and pressure these routines return the
!     vapor mixing ratio (mrsat) at saturation (unless optional argument
!     hc is used to specify the relative humidity at which mrsat should
!     apply) and, if desired, the derivative of mrsat w.r.t temperature 
!     (dmrsdT) and / or the saturation vapor pressure (esat). If the 
!     optional input argument specific humidity (mr) is present, the 
!     exact expression for mrs is used; if qr is not present the tradit-
!     ional form (valid at saturation) is used. if the optional mrsat 
!     derivative argument is present, the derivative of mrsat w.r.t. 
!     temperature will also be returned, defined consistent with the 
!     expression used for mrsat. The return values are derived from 
!     lookup tables (see notes below).
!   </DESCRIPTION>
!   <TEMPLATE>
!     call compute_mrs( temp, press, mrsat, mr, hc, dmrsdT, esat, 
!                       err_msg )
!   </TEMPLATE>
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Temperature in degrees Kelvin.
!   </IN>
!   <IN NAME="press" UNIT="Pascals" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Air pressure in Pascals.
!   </IN>
!   <OUT NAME="mrsat" UNITS="kg(vapor) / kg (dry air)" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Vapor mixing ratio in kg (vapor) / kg (dry air)
!             May be a scalar, 1d, 2d, or 3d array.
!             Must have the same order and size as temp.
!   </OUT>
!   <IN NAME="mr" UNIT="kg(vapor) / kg (dry air)" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Vapor mixing ratio in kg (vapor) / kg (dry air).
!     If present, exact formulation for mrsat and dmrsdT will be used.
!   </IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)">
!     Relative humidity at which output variables are desired.
!     If not present, values will apply at saturation.
!   </IN>
!   <OUT NAME="dmrsdT" UNITS="kg(vapor) / kg(dry air) / degree" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Derivative of saturation vapor mixing ratio w.r.t. temperature
!                 in kg(vapor) / kg(dry air) / degree. May be a 
!                 scalar, 1d, 2d, or 3d array.
!                 Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Saturation vapor pressure. May be a scalar, 1d, 2d, or 3d array.
!                 Must have the same order and size as temp.
!   </OUT>
!   <OUT NAME="err_msg" UNITS="      " TYPE="character">
!     Character string containing error message to be returned to
!     calling routine.
!   </OUT>
!   <ERROR MSG="table overflow, nbad=##" STATUS="FATAL">
!     Temperature(s) provided to the saturation vapor pressure lookup
!          are outside the valid range of the lookup table (-160 to 100 deg C).
!          This may be due to a numerical instability in the model.
!          Information should have been printed to standard output to help
!          determine where the instability may have occurred.
!          If the lookup table needs a larger temperature range,
!          then parameters in the module header must be modified.
!   </ERROR> *

 interface compute_mrs
   module procedure compute_mrs_0d, compute_mrs_1d, compute_mrs_2d, compute_mrs_3d
 end interface

!-----------------------------------------------------------------------
! <INTERFACE NAME="compute_es">

!   <OVERVIEW>
!     For the given temperatures, computes the saturation vapor pressures. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     Computes saturation vapor pressure for the given temperature using
!     the equations given in the Smithsonian Meteorological Tables.
!     Between -20C and 0C a blended value over ice and water is returned.
!   </DESCRIPTION>
!   <TEMPLATE>
!     es = compute_es ( temp )
!   </TEMPLATE>
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Temperature in degrees Kelvin.
!   </IN>
!   <OUT NAME="es" UNITS="pascal" TYPE="real" DIM="(scalar),(:),(:,:),(:,:,:)">
!     Saturation vapor pressure in pascals.
!             May be a scalar, 1d, 2d, or 3d array.
!             Must have the same order and size as temp.
!   </OUT>

!interface compute_es
!  module procedure compute_es_0d, compute_es_1d, compute_es_2d, compute_es_3d
!end interface
! </INTERFACE>
!-----------------------------------------------------------------------
 interface temp_check
   module procedure temp_check_1d, temp_check_2d, temp_check_3d
 end interface

 interface show_all_bad
   module procedure show_all_bad_0d, show_all_bad_1d, show_all_bad_2d, show_all_bad_3d
 end interface
!-----------------------------------------------------------------------
!  cvs version and tag name

 character(len=128) :: version = '$Id: sat_vapor_pres.F90,v 18.0.4.1 2010/08/31 14:29:01 z1l Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

 logical :: module_is_initialized = .false.

!-----------------------------------------------------------------------
!  parameters for use in computing qs and mrs

 real, parameter    :: EPSILO = RDGAS/RVGAS
 real, parameter    :: ZVIR = RVGAS/RDGAS - 1.0

!-----------------------------------------------------------------------
!  parameters for table size and resolution

 integer :: tcmin = -160  ! minimum temperature (degC) in lookup table
 integer :: tcmax =  100  ! maximum temperature (degC) in lookup table
 integer :: esres =  10   ! table resolution (increments per degree)
 integer :: nsize  ! (tcmax-tcmin)*esres+1    !  lookup table size
 integer :: nlim   ! nsize-1

!-----------------------------------------------------------------------
!  variables needed by temp_check
 real :: tmin, dtinv, teps

! The default values below preserve the behavior of omsk and earlier revisions.
 logical :: show_bad_value_count_by_slice=.true.
 logical :: show_all_bad_values=.false.
 logical :: use_exact_qs = .false.
 logical :: do_simple             =.false.
 logical :: construct_table_wrt_liq = .false.
 logical :: construct_table_wrt_liq_and_ice = .false.

 namelist / sat_vapor_pres_nml / show_bad_value_count_by_slice, show_all_bad_values, &
                                 use_exact_qs, do_simple, &
                                 construct_table_wrt_liq, &
                                 construct_table_wrt_liq_and_ice

contains

!#######################################################################
! <SUBROUTINE NAME="lookup_es_0d" INTERFACE="lookup_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_0d ( temp, esat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: esat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_es_1d" INTERFACE="lookup_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_1d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:)
 real, intent(out) :: esat(:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

!-----------------------------------------------

 end subroutine lookup_es_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_es_2d" INTERFACE="lookup_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_2d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:,:)
 real, intent(out) :: esat(:,:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

!-----------------------------------------------

 end subroutine lookup_es_2d

!#######################################################################

! <SUBROUTINE NAME="lookup_es_3d" INTERFACE="lookup_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_3d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:,:,:)
 real, intent(out) :: esat(:,:,:)
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_tmp,err_msg)) return
   endif

 end subroutine lookup_es_3d


!#######################################################################
! <SUBROUTINE NAME="lookup_es2_0d" INTERFACE="lookup_es2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_0d ( temp, esat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: esat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es2_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_es2_1d" INTERFACE="lookup_es2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_1d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:)
 real, intent(out) :: esat(:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return
   endif

!-----------------------------------------------

 end subroutine lookup_es2_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_es2_2d" INTERFACE="lookup_es2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_2d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:,:)
 real, intent(out) :: esat(:,:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return
   endif

!-----------------------------------------------

 end subroutine lookup_es2_2d

!#######################################################################

! <SUBROUTINE NAME="lookup_es2_3d" INTERFACE="lookup_es2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_3d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:,:,:)
 real, intent(out) :: esat(:,:,:)
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2',err_msg_tmp,err_msg)) return
   endif

 end subroutine lookup_es2_3d


!#######################################################################
! <SUBROUTINE NAME="lookup_es3_0d" INTERFACE="lookup_es3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_0d ( temp, esat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: esat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es3_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_es3_1d" INTERFACE="lookup_es3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_1d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:)
 real, intent(out) :: esat(:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return
   endif

!-----------------------------------------------

 end subroutine lookup_es3_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_es3_2d" INTERFACE="lookup_es3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_2d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:,:)
 real, intent(out) :: esat(:,:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return
   endif

!-----------------------------------------------

 end subroutine lookup_es3_2d

!#######################################################################

! <SUBROUTINE NAME="lookup_es3_3d" INTERFACE="lookup_es3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_3d ( temp, esat, err_msg )

 real, intent(in)  :: temp(:,:,:)
 real, intent(out) :: esat(:,:,:)
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_k(temp, esat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3',err_msg_tmp,err_msg)) return
   endif

 end subroutine lookup_es3_3d


!#######################################################################
!  routines for computing derivative of es
!#######################################################################

! <SUBROUTINE NAME="lookup_des_0d" INTERFACE="lookup_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des_0d ( temp, desat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_des_k( temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_des_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_des_1d" INTERFACE="lookup_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des_1d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:)
 real, intent(out) :: desat(:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init
   if(present(err_msg)) err_msg=''

   call lookup_des_k(temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif
!-----------------------------------------------

 end subroutine lookup_des_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_des_2d" INTERFACE="lookup_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des_2d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:,:)
 real, intent(out) :: desat(:,:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------
   
   if (.not.module_is_initialized) call sat_vapor_pres_init
   
   call lookup_des_k(temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif
!-----------------------------------------------

 end subroutine lookup_des_2d

!#######################################################################
! <SUBROUTINE NAME="lookup_des_3d" INTERFACE="lookup_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des_3d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:,:,:)
 real, intent(out) :: desat(:,:,:)
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_des_k( temp, desat, nbad )

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg=''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des',err_msg_tmp,err_msg)) return
   endif

 end subroutine lookup_des_3d


! <SUBROUTINE NAME="lookup_des2_0d" INTERFACE="lookup_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des2_0d ( temp, desat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_des2_k( temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_des2_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_des2_1d" INTERFACE="lookup_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des2_1d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:)
 real, intent(out) :: desat(:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init
   if(present(err_msg)) err_msg=''

   call lookup_des2_k(temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return
   endif
!-----------------------------------------------

 end subroutine lookup_des2_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_des2_2d" INTERFACE="lookup_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des2_2d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:,:)
 real, intent(out) :: desat(:,:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------
   
   if (.not.module_is_initialized) call sat_vapor_pres_init
   
   call lookup_des2_k(temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return
   endif
!-----------------------------------------------

 end subroutine lookup_des2_2d

!#######################################################################
! <SUBROUTINE NAME="lookup_des2_3d" INTERFACE="lookup_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des2_3d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:,:,:)
 real, intent(out) :: desat(:,:,:)
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_des2_k( temp, desat, nbad )

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg=''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des2',err_msg_tmp,err_msg)) return
   endif

 end subroutine lookup_des2_3d


! <SUBROUTINE NAME="lookup_des3_0d" INTERFACE="lookup_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des3_0d ( temp, desat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_des3_k( temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_des3_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_des3_1d" INTERFACE="lookup_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des3_1d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:)
 real, intent(out) :: desat(:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------

   if (.not.module_is_initialized) call sat_vapor_pres_init
   if(present(err_msg)) err_msg=''

   call lookup_des3_k(temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return
   endif
!-----------------------------------------------

 end subroutine lookup_des3_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_des3_2d" INTERFACE="lookup_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des3_2d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:,:)
 real, intent(out) :: desat(:,:)
 character(len=*), intent(out), optional :: err_msg

 character(len=54) :: err_msg_local
 integer :: nbad
!-----------------------------------------------
   
   if (.not.module_is_initialized) call sat_vapor_pres_init
   
   call lookup_des3_k(temp, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return
   endif
!-----------------------------------------------

 end subroutine lookup_des3_2d

!#######################################################################
! <SUBROUTINE NAME="lookup_des3_3d" INTERFACE="lookup_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="desat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_des3_3d ( temp, desat, err_msg )

 real, intent(in)  :: temp (:,:,:)
 real, intent(out) :: desat(:,:,:)
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_des3_k( temp, desat, nbad )

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg=''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_des3',err_msg_tmp,err_msg)) return
   endif

 end subroutine lookup_des3_3d

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

!#######################################################################

! <SUBROUTINE NAME="lookup_es_des_0d" INTERFACE="lookup_es_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_des_0d ( temp, esat, desat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_des_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es_des_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_es_des_1d" INTERFACE="lookup_es_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_des_1d ( temp, esat, desat, err_msg )

 real, dimension(:), intent(in)  :: temp
 real, dimension(:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_des_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es_des_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_es_des_2d" INTERFACE="lookup_es_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_des_2d ( temp, esat, desat, err_msg )

 real, dimension(:,:), intent(in)  :: temp
 real, dimension(:,:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_des_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es_des_2d

!#######################################################################

! <SUBROUTINE NAME="lookup_es_des_3d" INTERFACE="lookup_es_des">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es_des_3d ( temp, esat, desat, err_msg )

 real, dimension(:,:,:), intent(in)  :: temp
 real, dimension(:,:,:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es_des_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es_des_3d

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="lookup_es2_des2_0d" INTERFACE="lookup_es2_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_des2_0d ( temp, esat, desat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_des2_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es2_des2_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_es2_des2_1d" INTERFACE="lookup_es2_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_des2_1d ( temp, esat, desat, err_msg )

 real, dimension(:), intent(in)  :: temp
 real, dimension(:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_des2_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es2_des2_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_es2_des2_2d" INTERFACE="lookup_es2_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_des2_2d ( temp, esat, desat, err_msg )

 real, dimension(:,:), intent(in)  :: temp
 real, dimension(:,:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_des2_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es2_des2_2d

!#######################################################################

! <SUBROUTINE NAME="lookup_es2_des2_3d" INTERFACE="lookup_es2_des2">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es2_des2_3d ( temp, esat, desat, err_msg )

 real, dimension(:,:,:), intent(in)  :: temp
 real, dimension(:,:,:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es2_des2_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es2_des2_3d


!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="lookup_es3_des3_0d" INTERFACE="lookup_es3_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(scalar)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_des3_0d ( temp, esat, desat, err_msg )

 real, intent(in)  :: temp
 real, intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_des3_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es3_des3_0d

!#######################################################################

! <SUBROUTINE NAME="lookup_es3_des3_1d" INTERFACE="lookup_es3_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_des3_1d ( temp, esat, desat, err_msg )

 real, dimension(:), intent(in)  :: temp
 real, dimension(:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_des3_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es3_des3_1d

!#######################################################################

! <SUBROUTINE NAME="lookup_es3_des3_2d" INTERFACE="lookup_es3_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_des3_2d ( temp, esat, desat, err_msg )

 real, dimension(:,:), intent(in)  :: temp
 real, dimension(:,:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_des3_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es3_des3_2d

!#######################################################################

! <SUBROUTINE NAME="lookup_es3_des3_3d" INTERFACE="lookup_es3_des3">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="esat" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="desat" UNITS="pascal / degree" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine lookup_es3_des3_3d ( temp, esat, desat, err_msg )

 real, dimension(:,:,:), intent(in)  :: temp
 real, dimension(:,:,:), intent(out) :: esat, desat
 character(len=*), intent(out), optional :: err_msg

 integer :: nbad
 character(len=128) :: err_msg_local

   if (.not.module_is_initialized) call sat_vapor_pres_init

   call lookup_es3_des3_k(temp, esat, desat, nbad)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return
   endif

 end subroutine lookup_es3_des3_3d

!#######################################################################

! <SUBROUTINE NAME="compute_qs_0d" INTERFACE="compute_qs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(SCALAR)"></IN>
!   <IN NAME="press UNIT="Pascals" TYPE="real" DIM="(SCALAR)"></IN>
!   <OUT NAME="qsat" UNITS="kg(vapor)/kg(moist air)" TYPE="real" DIM="(SCALAR)"></OUT>
!   <IN NAME="q" UNIT="kg(vapor)/kg(moistair)" TYPE="real" DIM="(SCALAR)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dqsdT" UNIT="kg(vapor)/kg(moistair)/ degree Kelvin" TYPE="real" DIM="(SCALAR)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(scalar)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_qs_0d ( temp, press, qsat, q, hc, dqsdT, esat, &
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp, press
 real, intent(out)                       :: qsat
 real, intent(in),              optional :: q, hc
 real, intent(out),             optional :: dqsdT, esat
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_qs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

   call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, hc, &
                       dqsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_qs_0d
 
!#######################################################################

! <SUBROUTINE NAME="compute_qs_1d" INTERFACE="compute_qs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <IN NAME="press UNIT="Pascals" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="qsat" UNITS="kg(vapor)/kg(moist air)" TYPE="real" DIM="(:)"></OUT>
!   <IN NAME="q" UNIT="kg(vapor)/kg(moistair)" TYPE="real" DIM="(:)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dqsdT" UNIT="kg(vapor)/kg(moistair)/ degree Kelvin" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(:)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_qs_1d ( temp, press, qsat, q, hc, dqsdT, esat, &
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp(:), press(:)
 real, intent(out)                       :: qsat(:)
 real, intent(in),              optional :: q(:)
real,  intent(in),              optional :: hc
 real, intent(out),             optional :: dqsdT(:), esat(:)
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_qs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

!  call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, dqsdT)
   call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, hc, &
                       dqsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_qs_1d


!#######################################################################

! <SUBROUTINE NAME="compute_qs_2d" INTERFACE="compute_qs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <IN NAME="press UNIT="Pascals" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="qsat" UNITS="kg(vapor)/kg(moist air)" TYPE="real" DIM="(;,:)"></OUT>
!   <IN NAME="q" UNIT="kg(vapor)/kg(moistair)" TYPE="real" DIM="(:,:)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dqsdT" UNIT="kg(vapor)/kg(moistair)/ degree Kelvin" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(:,:)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_qs_2d ( temp, press, qsat, q, hc, dqsdT, esat, &
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp(:,:), press(:,:)
 real, intent(out)                       :: qsat(:,:)
 real, intent(in),              optional :: q(:,:)
 real, intent(in),              optional :: hc      
 real, intent(out),             optional :: dqsdT(:,:), esat(:,:)
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_qs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

!  call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, dqsdT)
   call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, hc, &
                       dqsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_qs_2d

!#######################################################################

! <SUBROUTINE NAME="compute_qs_3d" INTERFACE="compute_qs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <IN NAME="press UNIT="Pascals" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="qsat" UNITS="kg(vapor)/kg(moist air)" TYPE="real" DIM="(;,:,:)"></OUT>
!   <IN NAME="q" UNIT="kg(vapor)/kg(moistair)" TYPE="real" DIM="(:,:,:)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dqsdT" UNIT="kg(vapor)/kg(moistair)/ degree Kelvin" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(:,:,:)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_qs_3d ( temp, press, qsat, q, hc, dqsdT, esat, &
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp(:,:,:), press(:,:,:)
 real, intent(out)                       :: qsat(:,:,:)
 real, intent(in),              optional :: q(:,:,:)
 real, intent(in),              optional :: hc           
 real, intent(out),             optional :: dqsdT(:,:,:), esat(:,:,:)
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_qs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

!  call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, dqsdT)
   call compute_qs_k (temp, press,  EPSILO, ZVIR, qsat, nbad, q, hc, &
                       dqsdT, esat, es_over_liq, es_over_liq_and_ice)


   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_qs_3d

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="compute_mrs_0d" INTERFACE="compute_mrs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(SCALAR)"></IN>
!   <IN NAME="press" UNIT="Pascals" TYPE="real" DIM="(SCALAR)"></IN>
!   <OUT NAME="mrsat" UNITS="kg(vapor)/kg(dry air)" TYPE="real" DIM="(SCALAR</OUT>
!   <IN NAME="mr" UNIT="kg(vapor)/kg(dry air)" TYPE="real" DIM="(SCALAR)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dmrsdT" UNIT="kg(vapor)/kg(dry air)/ degree Kelvin" TYPE="real" DIM="(SCALAR)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(scalar)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_mrs_0d ( temp, press, mrsat, mr, hc, dmrsdT, esat, &
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp, press             
 real, intent(out)                       :: mrsat
 real, intent(in),              optional :: mr, hc
 real, intent(out),             optional :: dmrsdT, esat
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_mrs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

   call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr,  &
                     hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_mrs_0d

!#######################################################################
!#######################################################################

! <SUBROUTINE NAME="compute_mrs_1d" INTERFACE="compute_mrs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <IN NAME="press" UNIT="Pascals" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="mrsat" UNITS="kg(vapor)/kg(dry air)" TYPE="real" DIM="(:)"></OUT>
!   <IN NAME="mr" UNIT="kg(vapor)/kg(dry air)" TYPE="real" DIM="(:)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dmrsdT" UNIT="kg(vapor)/kg(dry air)/ degree Kelvin" TYPE="real" DIM="(:)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(:)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_mrs_1d ( temp, press, mrsat, mr, hc, dmrsdT, esat,&
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp(:), press(:)       
 real, intent(out)                       :: mrsat(:)
 real, intent(in),              optional :: mr(:)
 real, intent(in),              optional :: hc     
 real, intent(out),             optional :: dmrsdT(:), esat(:)
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_mrs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

!  call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat,  &
!                                                     nbad, mr, dmrsdT)
   call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr,  &
                     hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_mrs_1d

!#######################################################################

! <SUBROUTINE NAME="compute_mrs_2d" INTERFACE="compute_mrs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <IN NAME="press" UNIT="Pascals" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="mrsat" UNITS="kg(vapor)/kg(dry air)" TYPE="real" DIM="(:,:)"></OUT>
!   <IN NAME="mr" UNIT="kg(vapor)/kg(dry air)" TYPE="real" DIM="(:,:)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dmrsdT" UNIT="kg(vapor)/kg(dry air)/ degree Kelvin" TYPE="real" DIM="(:,:)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(:,:)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_mrs_2d ( temp, press, mrsat, mr, hc, dmrsdT, esat,&
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp(:,:), press(:,:)    
 real, intent(out)                       :: mrsat(:,:)
 real, intent(in),              optional :: mr(:,:)
 real, intent(in),              optional :: hc         
 real, intent(out),             optional :: dmrsdT(:,:), esat(:,:)
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_mrs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

!  call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat,  &
!                                                     nbad, mr, dmrsdT)
   call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr,  &
                     hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_mrs_2d

!#######################################################################

! <SUBROUTINE NAME="compute_mrs_3d" INTERFACE="compute_mrs">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <IN NAME="press" UNIT="Pascals" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="mrsat" UNITS="kg(vapor)/kg(dry air)" TYPE="real" DIM="(:,:,:)"></OUT>
!   <IN NAME="mr" UNIT="kg(vapor)/kg(dry air)" TYPE="real" DIM="(:,:,:)"></IN>
!   <IN NAME="hc" UNIT="fraction" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="dmrsdT" UNIT="kg(vapor)/kg(dry air)/ degree Kelvin" TYPE="real" DIM="(:,:,:)"></OUT>
!   <OUT NAME="esat" UNITS="Pascals" TYPE="real" DIM="(:,:,:)"> </OUT>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>
! </SUBROUTINE>
 subroutine compute_mrs_3d ( temp, press, mrsat, mr, hc, dmrsdT, esat,&
                            err_msg, es_over_liq, es_over_liq_and_ice )

 real, intent(in)                        :: temp(:,:,:), press(:,:,:)  
 real, intent(out)                       :: mrsat(:,:,:)
 real, intent(in),              optional :: mr(:,:,:)
 real, intent(in),              optional :: hc           
 real, intent(out),             optional :: dmrsdT(:,:,:), esat(:,:,:)
 character(len=*), intent(out), optional :: err_msg
 logical,intent(in),            optional :: es_over_liq
 logical,intent(in),            optional :: es_over_liq_and_ice

 integer :: nbad
 character(len=128) :: err_msg_tmp

   if (.not.module_is_initialized) call sat_vapor_pres_init

   if (present(es_over_liq)) then
     if (.not. (construct_table_wrt_liq)) then
       call error_mesg ('compute_mrs', &
          'requesting es wrt liq, but that table not constructed', &
                                                                FATAL)
     endif
   endif
   if (present(es_over_liq_and_ice)) then
     if (.not. (construct_table_wrt_liq_and_ice)) then
       call error_mesg ('compute_qs', &
      'requesting es wrt liq and ice, but that table not constructed', &
                                                                FATAL)
     endif
   endif

!  call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat,   &
!                                                    nbad, mr, dmrsdT)
   call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr,  &
                     hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)

   if ( nbad == 0 ) then
     if(present(err_msg)) err_msg = ''
   else
     if(show_bad_value_count_by_slice) call temp_check ( temp )
     if(show_all_bad_values) call show_all_bad ( temp )
     write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad
     if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return
   endif

 end subroutine compute_mrs_3d


!#######################################################################

!#######################################################################

! <SUBROUTINE NAME="sat_vapor_pres_init">

!   <OVERVIEW>
!     Initializes the lookup tables for saturation vapor pressure. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     Initializes the lookup tables for saturation vapor pressure.
!     This routine will be called automatically the first time
!     <B>lookup_es</B> or <B>lookup_des</B> is called,
!     the user does not need to call this routine.
!     There are no arguments.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call sat_vapor_pres_init
!   </TEMPLATE>
!   <OUT NAME="err_msg" TYPE="character">  </OUT>

! </SUBROUTINE>
 subroutine sat_vapor_pres_init(err_msg)

!  =================================================================
!  +                                                               +
!  +             construction of the es table                      +
!  +                                                               +
!  + this table is constructed from es equations from the          +
!  + smithsonian tables.  the es input is computed from values     +
!  + (in one-tenth of a degree increments) of es over ice          +
!  + from -153c to 0c and values of es over water from 0c to 102c. +
!  + output table contains these data interleaved with their       +
!  + derivatives with respect to temperature except between -20c   +
!  + and 0c where blended (over water and over ice) es values and  +
!  + derivatives are calculated.                                   +
!  +   note: all es computation is done in pascals                 +
!  =================================================================

  character(len=*), intent(out), optional :: err_msg
  character(len=128) :: err_msg_local
  integer :: unit, ierr, io

! return silently if this routine has already been called
  if (module_is_initialized) return

!---- read namelist input ----
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, sat_vapor_pres_nml, iostat=io)
#else
  if (file_exist('input.nml')) then
     unit = open_namelist_file ( )
     ierr=1; do while (ierr /= 0)
        read  (unit, nml=sat_vapor_pres_nml, iostat=io, end=10)
        ierr = check_nml_error(io,'sat_vapor_pres_nml')
     enddo
10   call mpp_close (unit)
  endif
#endif

! write version number and namelist to log file
  call write_version_number (version, tagname)
  unit = stdlog()
  if (mpp_pe() == mpp_root_pe()) write (unit, nml=sat_vapor_pres_nml)

  if(do_simple) then
    tcmin = -350  
    tcmax =  350  
  endif
  nsize = (tcmax-tcmin)*esres+1 
  nlim  = nsize-1
  call sat_vapor_pres_init_k(nsize, real(tcmin), real(tcmax), TFREEZE, HLV, &
                             RVGAS, ES0, err_msg_local, use_exact_qs, do_simple, &
                             construct_table_wrt_liq, &
                             construct_table_wrt_liq_and_ice, &
                             teps, tmin, dtinv)
  if ( err_msg_local == '' ) then
     if(present(err_msg)) err_msg = ''
  else
     if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return
  endif

  module_is_initialized = .true.

end subroutine sat_vapor_pres_init

!#######################################################################
!#######################################################################
!-------------------------------------------------------------------
!                Computation of the es values
!
!   Saturation vapor pressure (es) values are computed from
!   equations in the Smithsonian meteorological tables page 350.
!   For temperatures < 0C, sat vapor pres is computed over ice.
!   For temperatures > -20C, sat vapor pres is computed over water.
!   Between -20C and 0C the returned value is blended (over water
!   and over ice).  All sat vapor pres values are returned in pascals.
!
!   Reference:  Smithsonian meteorological tables, page 350.
!-------------------------------------------------------------------

! <FUNCTION NAME="compute_es_1d" INTERFACE="compute_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:)"></IN>
!   <OUT NAME="es" UNITS="pascal" TYPE="real" DIM="(:)"></OUT>
! </FUNCTION>
!function compute_es_1d (tem) result (es)
!real, intent(in) :: tem(:)
!real :: es(size(tem,1))

!es = compute_es_k(tem, TFREEZE)

!end function compute_es_1d
!--------------------------------------------------------

! <FUNCTION NAME="compute_es_0d" INTERFACE="compute_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(scalar)"></IN>
!   <OUT NAME="es" UNITS="pascal" TYPE="real" DIM="(scalar)"></OUT>
! </FUNCTION>
!function compute_es_0d (tem) result (es)
!real, intent(in) :: tem
!real :: es
!real, dimension(1) :: tem1, es1

!  tem1(1) = tem
!  es1 = compute_es_1d (tem1)
!  es = es1(1)

!end function compute_es_0d

!--------------------------

! <FUNCTION NAME="compute_es_2d" INTERFACE="compute_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:)"></IN>
!   <OUT NAME="es" UNITS="pascal" TYPE="real" DIM="(:,:)"></OUT>
! </FUNCTION>
!function compute_es_2d (tem) result (es)
!real, intent(in) :: tem(:,:)
!real, dimension(size(tem,1),size(tem,2)) :: es
!integer :: j

!   do j = 1, size(tem,2)
!     es(:,j) = compute_es_1d (tem(:,j))
!   enddo

!end function compute_es_2d

!--------------------------
! <FUNCTION NAME="compute_es_3d" INTERFACE="compute_es">
!   <IN NAME="temp" UNIT="degrees Kelvin" TYPE="real" DIM="(:,:,:)"></IN>
!   <OUT NAME="es" UNITS="pascal" TYPE="real" DIM="(:,:,:)"></OUT>
! </FUNCTION>
!function compute_es_3d (tem) result (es)
!real, intent(in) :: tem(:,:,:)
!real, dimension(size(tem,1),size(tem,2),size(tem,3)) :: es
!integer :: j, k

!   do k = 1, size(tem,3)
!   do j = 1, size(tem,2)
!     es(:,j,k) = compute_es_1d (tem(:,j,k))
!   enddo
!   enddo

!end function compute_es_3d

!#######################################################################

 function check_1d ( temp ) result ( nbad )
 real   , intent(in)  :: temp(:)
 integer :: nbad, ind, i

   nbad = 0
   do i = 1, size(temp,1)
     ind = int(dtinv*(temp(i)-tmin+teps))
     if (ind < 0 .or. ind > nlim) nbad = nbad+1
   enddo

 end function check_1d

!------------------------------------------------

 function check_2d ( temp ) result ( nbad )
 real   , intent(in)  :: temp(:,:)
 integer :: nbad
 integer :: j

    nbad = 0
    do j = 1, size(temp,2)
      nbad = nbad + check_1d ( temp(:,j) )
    enddo
 end function check_2d

!#######################################################################

 subroutine temp_check_1d ( temp )
 real   , intent(in) :: temp(:)
 integer :: i, unit

   unit = stdout()
   write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))

 end subroutine temp_check_1d

!--------------------------------------------------------------

 subroutine temp_check_2d ( temp )
 real   , intent(in) :: temp(:,:)
 integer :: i, j, unit

   unit = stdout()
   write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
   write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))

 end subroutine temp_check_2d

!--------------------------------------------------------------

 subroutine temp_check_3d ( temp )
 real, intent(in)  :: temp(:,:,:)
 integer :: i, j, k, unit

   unit = stdout()
   write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
   write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
   write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))

 end subroutine temp_check_3d

!#######################################################################

subroutine show_all_bad_0d ( temp )
 real   , intent(in) :: temp
 integer :: ind, unit

 unit = stdout()
 ind = int(dtinv*(temp-tmin+teps))
 if (ind < 0 .or. ind > nlim) then
   write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
 endif
 
 end subroutine show_all_bad_0d

!--------------------------------------------------------------

 subroutine show_all_bad_1d ( temp )
 real   , intent(in) :: temp(:)
 integer :: i, ind, unit

 unit = stdout()
 do i=1,size(temp)
   ind = int(dtinv*(temp(i)-tmin+teps))
   if (ind < 0 .or. ind > nlim) then
     write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),'  at i=',i,' pe=',mpp_pe()
   endif
 enddo

 end subroutine show_all_bad_1d

!--------------------------------------------------------------

 subroutine show_all_bad_2d ( temp )
 real   , intent(in) :: temp(:,:)
 integer :: i, j, ind, unit

 unit = stdout()
 do j=1,size(temp,2)
 do i=1,size(temp,1)
   ind = int(dtinv*(temp(i,j)-tmin+teps))
   if (ind < 0 .or. ind > nlim) then
     write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),'  at i=',i,' j=',j,' pe=',mpp_pe()
   endif
 enddo
 enddo

 end subroutine show_all_bad_2d

!--------------------------------------------------------------

 subroutine show_all_bad_3d ( temp )
 real, intent(in)  :: temp(:,:,:)
 integer :: i, j, k, ind, unit

 unit = stdout()
 do k=1,size(temp,3)
 do j=1,size(temp,2)
 do i=1,size(temp,1)
   ind = int(dtinv*(temp(i,j,k)-tmin+teps))
   if (ind < 0 .or. ind > nlim) then
     write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),'  at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
   endif
 enddo
 enddo
 enddo

 end subroutine show_all_bad_3d

!#######################################################################
end module sat_vapor_pres_mod
!#######################################################################

! <INFO>

!   <REFERENCE>            
!     Smithsonian Meteorological Tables Page 350.
!   </REFERENCE>

!   <BUG>                  
!     No error checking is done to make sure that the size of the
!     input and output fields match.
!   </BUG>

!   <NOTE>
!     1. <B>Vectorization</B><BR/>
!        To create a vector version the lookup routines need to be modified.
!    The local variables: tmp, del, ind, should be changed to arrays
!    with the same size and order as input array temp.
!
!     2. <B>Construction of the <TT>ES</TT> tables</B><BR/>
!         The tables are constructed using the saturation vapor pressure (<TT>ES</TT>)
!    equations in the Smithsonian tables. The tables are valid between
!    -160C to +100C with increments at 1/10 degree. Between -160C and -20C
!    values of <TT>ES</TT> over ice are used, between 0C and 100C values of<TT> ES</TT>
!    over water are used, between -20C and 0C blended values of <TT>ES</TT>
!    (over water and over ice) are used.
!
!    There are three tables constructed: <TT>ES</TT>, first derivative 
!       (<TT>ES'</TT>), and
!    second derivative (<TT>ES</TT>'').  The ES table is constructed directly from
!    the equations in the Smithsonian tables. The <TT>ES</TT>' table is constructed
!    by bracketing temperature values at +/- 0.01 degrees. The <TT>ES</TT>'' table
!    is estimated by using centered differencing of the <TT>ES</TT>' table.
!
!     3. <B>Determination of <TT>es</TT> and <TT>es'</TT> from lookup tables</B><BR/>
!         Values of the saturation vapor pressure (<TT>es</TT>) and the 
!    derivative (<TT>es'</TT>) are determined at temperature (T) from the lookup 
!    tables (<TT>ES</TT>, <TT>ES'</TT>, <TT>ES''</TT>)
!    using the following formula.
!<PRE>
!    es (T) = ES(t) + ES'(t) * dt + 0.5 * ES''(t) * dt**2
!    es'(T) = ES'(t) + ES''(t) * dt
!
!    where     t = lookup table temperature closest to T
!             dt = T - t
!</PRE>
!
!     4. Internal (private) parameters<BR/>
!       These parameters can be modified to increase/decrease the size/range
!    of the lookup tables.
!<PRE>
!!    tcmin   The minimum temperature (in deg C) in the lookup tables.
!!              [integer, default: tcmin = -160]
!!
!!    tcmax   The maximum temperature (in deg C) in the lookup tables.
!!              [integer, default: tcmin = +100]
!!</PRE>
!!   </NOTE>
!
!!   <TESTPROGRAM NAME="test_sat_vapor_pres">
!<PRE>
!use sat_vapor_pres_mod
!implicit none
!
!integer, parameter :: ipts=500, jpts=100, kpts=50, nloop=1
!real, dimension(ipts,jpts,kpts) :: t,es,esn,des,desn
!integer :: n
!
!! generate temperatures between 120K and 340K
!  call random_number (t)
!  t = 130. + t * 200.
!
!! initialize the tables (optional)
!  call sat_vapor_pres_init
!
!! compute actual es and "almost" actual des
!   es = compute_es  (t)
!  des = compute_des (t)
!
!do n = 1, nloop
!! es and des
!  call lookup_es  (t, esn)
!  call lookup_des (t,desn)
!enddo
!
!! terminate, print deviation from actual
!  print *, 'size=',ipts,jpts,kpts,nloop
!  print *, 'err es  = ', sum((esn-es)**2)
!  print *, 'err des = ', sum((desn-des)**2)
!
!contains
!
!!----------------------------------
!! routine to estimate derivative
!
! function compute_des (tem) result (des)
! real, intent(in) :: tem(:,:,:)
! real, dimension(size(tem,1),size(tem,2),size(tem,3)) :: des,esp,esm
! real, parameter :: tdel = .01
!    esp = compute_es (tem+tdel)
!    esm = compute_es (tem-tdel)
!    des = (esp-esm)/(2*tdel)
! end function compute_des
!!----------------------------------
!
!end program test_sat_vapor_pres
!</PRE>
!   </TESTPROGRAM>
! </INFO>




 module sat_vapor_pres_k_mod

! This module is what I (pjp) think a kernel should be.
! There have been many proposals as to what a kernel should look like.
! If fact, so many different ideas have been expressed that the lack
! of agreement has greatly hampered progress.
! The only way to move forward is to limit the requirments for a kernel
! to only what is widely agreeded upon.
! I believe that there are only two things widely agreeded upon.

! 1) A kernel should be independent of the rest of FMS so that it can
!    easily be ported into another programming system.
!    This requires that a kernel does not access anything by use association.
!    The one exception is this kernel, because it is not practical for physics
!    modules to avoid using a module that computes the saturation vapor
!    pressure of water vapor.

! 2) For the sake of thread safety, module globals should be written only at initialization.
!    In this case, the module globals are the tables and a handful of scalars.

! 3) A kernel should not read from an external file.

! One of the things that was not widely agreeded upon is that a kernel should
! not be a fortran module. This complicates things greatly for questionable
! benefit and could be done as a second step anyway, if necessary.

 implicit none
 private

 character(len=128), parameter :: version = '$Id: sat_vapor_pres_k.F90,v 18.0 2010/03/02 23:58:26 fms Exp $'
 character(len=128), parameter :: tagname = '$Name: hiram_20101115_bw $'

 public :: sat_vapor_pres_init_k
 public :: lookup_es_k
 public :: lookup_des_k
 public :: lookup_es_des_k
 public :: lookup_es2_k
 public :: lookup_des2_k
 public :: lookup_es2_des2_k
 public :: lookup_es3_k
 public :: lookup_des3_k
 public :: lookup_es3_des3_k
 public :: compute_qs_k
 public :: compute_mrs_k

 interface lookup_es_k
   module procedure lookup_es_k_0d
   module procedure lookup_es_k_1d
   module procedure lookup_es_k_2d
   module procedure lookup_es_k_3d
 end interface

 interface lookup_des_k
   module procedure lookup_des_k_0d
   module procedure lookup_des_k_1d
   module procedure lookup_des_k_2d
   module procedure lookup_des_k_3d
 end interface

 interface lookup_es_des_k
   module procedure lookup_es_des_k_0d
   module procedure lookup_es_des_k_1d
   module procedure lookup_es_des_k_2d
   module procedure lookup_es_des_k_3d
 end interface

 interface lookup_es2_k
   module procedure lookup_es2_k_0d
   module procedure lookup_es2_k_1d
   module procedure lookup_es2_k_2d
   module procedure lookup_es2_k_3d
 end interface

 interface lookup_des2_k
   module procedure lookup_des2_k_0d
   module procedure lookup_des2_k_1d
   module procedure lookup_des2_k_2d
   module procedure lookup_des2_k_3d
 end interface

 interface lookup_es2_des2_k
   module procedure lookup_es2_des2_k_0d
   module procedure lookup_es2_des2_k_1d
   module procedure lookup_es2_des2_k_2d
   module procedure lookup_es2_des2_k_3d
 end interface

 interface lookup_es3_k
   module procedure lookup_es3_k_0d
   module procedure lookup_es3_k_1d
   module procedure lookup_es3_k_2d
   module procedure lookup_es3_k_3d
 end interface

 interface lookup_des3_k
   module procedure lookup_des3_k_0d
   module procedure lookup_des3_k_1d
   module procedure lookup_des3_k_2d
   module procedure lookup_des3_k_3d
 end interface

 interface lookup_es3_des3_k
   module procedure lookup_es3_des3_k_0d
   module procedure lookup_es3_des3_k_1d
   module procedure lookup_es3_des3_k_2d
   module procedure lookup_es3_des3_k_3d
 end interface

 interface compute_qs_k
   module procedure compute_qs_k_0d
   module procedure compute_qs_k_1d
   module procedure compute_qs_k_2d
   module procedure compute_qs_k_3d
 end interface

 interface compute_mrs_k
   module procedure compute_mrs_k_0d
   module procedure compute_mrs_k_1d
   module procedure compute_mrs_k_2d
   module procedure compute_mrs_k_3d
 end interface

 real :: dtres, tepsl, tminl, dtinvl
 integer :: table_siz
 real, dimension(:), allocatable :: TABLE   !  sat vapor pres (es)
 real, dimension(:), allocatable :: DTABLE  !  first derivative of es
 real, dimension(:), allocatable :: D2TABLE ! second derivative of es
 real, dimension(:), allocatable :: TABLE2  !  sat vapor pres (es)
 real, dimension(:), allocatable :: DTABLE2 !  first derivative of es
 real, dimension(:), allocatable :: D2TABLE2 ! second derivative of es
 real, dimension(:), allocatable :: TABLE3  !  sat vapor pres (es)
 real, dimension(:), allocatable :: DTABLE3 !  first derivative of es
 real, dimension(:), allocatable :: D2TABLE3 ! second derivative of es

 logical  :: use_exact_qs
 logical  :: module_is_initialized = .false.

 contains

 subroutine sat_vapor_pres_init_k(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, &
                                  use_exact_qs_input, do_simple,  &
                                  construct_table_wrt_liq, &
                                  construct_table_wrt_liq_and_ice, &
                                  teps, tmin, dtinv)

! This routine has been generalized to return tables for any temperature range and resolution

 integer, intent(in) :: table_size
 real, intent(in) :: tcmin ! TABLE(1)          = sat vapor pressure at temperature tcmin (deg C)
 real, intent(in) :: tcmax ! TABLE(table_size) = sat vapor pressure at temperature tcmax (deg C)
 real, intent(in) :: TFREEZE, HLV, RVGAS, ES0
 logical, intent(in)  :: use_exact_qs_input, do_simple
 logical, intent(in)  :: construct_table_wrt_liq
 logical, intent(in)  :: construct_table_wrt_liq_and_ice
 character(len=*), intent(out) :: err_msg
 real, intent(out), optional :: teps, tmin, dtinv

! increment used to generate derivative table
  real, dimension(3) :: tem(3), es(3)
  real :: hdtinv, tinrc, tfact
  integer :: i

      err_msg = ''

      if (module_is_initialized) return

      if(allocated(TABLE) .or. allocated(DTABLE) .or. allocated(D2TABLE)) then
        err_msg = 'Attempt to allocate sat vapor pressure tables when already allocated'
        return
      else
        allocate(TABLE(table_size), DTABLE(table_size), D2TABLE(table_size))
      endif
      
   if (construct_table_wrt_liq) then
      if(allocated(TABLE2) .or. allocated(DTABLE2) .or. allocated(D2TABLE2)) then
        err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated'
        return
      else
        allocate(TABLE2(table_size), DTABLE2(table_size), D2TABLE2(table_size))
      endif
   endif

   if (construct_table_wrt_liq_and_ice) then
      if(allocated(TABLE3) .or. allocated(DTABLE3) .or. allocated(D2TABLE3)) then
        err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated'
        return
      else
        allocate(TABLE3(table_size), DTABLE3(table_size), D2TABLE3(table_size))
      endif
   endif

      table_siz = table_size
      dtres = (tcmax - tcmin)/(table_size-1)
      tminl = real(tcmin)+TFREEZE  ! minimum valid temp in table
      dtinvl = 1./dtres
      tepsl = .5*dtres
      tinrc = .1*dtres
      if(present(teps )) teps =tepsl
      if(present(tmin )) tmin =tminl
      if(present(dtinv)) dtinv=dtinvl

! To be able to compute tables for any temperature range and resolution,
! and at the same time exactly reproduce answers from memphis revision,
! it is necessary to compute ftact differently than it is in memphis.
      tfact = 5*dtinvl

      hdtinv = dtinvl*0.5

! compute es tables from tcmin to tcmax
! estimate es derivative with small +/- difference

      if (do_simple) then

        do i = 1, table_size
          tem(1) = tminl + dtres*real(i-1)
          TABLE(i) = ES0*610.78*exp(-hlv/rvgas*(1./tem(1) - 1./tfreeze)) 
          DTABLE(i) = hlv*TABLE(i)/rvgas/tem(1)**2.
        enddo

      else

        do i = 1, table_size
          tem(1) = tminl + dtres*real(i-1)
          tem(2) = tem(1)-tinrc
          tem(3) = tem(1)+tinrc
          es = compute_es_k (tem, TFREEZE)
          TABLE(i) = es(1)
          DTABLE(i) = (es(3)-es(2))*tfact
        enddo

      endif !if (do_simple)

! compute one-half second derivative using centered differences
! differencing des values in the table

      do i = 2, table_size-1
         D2TABLE(i) = 0.25*dtinvl*(DTABLE(i+1)-DTABLE(i-1))
      enddo
    ! one-sided derivatives at boundaries

         D2TABLE(1) = 0.50*dtinvl*(DTABLE(2)-DTABLE(1))

         D2TABLE(table_size) = 0.50*dtinvl*&
              (DTABLE(table_size)-DTABLE(table_size-1))
      
   if (construct_table_wrt_liq) then
! compute es tables from tcmin to tcmax
! estimate es derivative with small +/- difference
 
      do i = 1, table_size
        tem(1) = tminl + dtres*real(i-1)
        tem(2) = tem(1)-tinrc
        tem(3) = tem(1)+tinrc
!   pass in flag to force all values to be wrt liquid
        es = compute_es_liq_k (tem, TFREEZE)
        TABLE2(i) = es(1)
        DTABLE2(i) = (es(3)-es(2))*tfact
      enddo
 
! compute one-half second derivative using centered differences
! differencing des values in the table

     do i = 2, table_size-1
       D2TABLE2(i) = 0.25*dtinvl*(DTABLE2(i+1)-DTABLE2(i-1))
     enddo
! one-sided derivatives at boundaries

     D2TABLE2(1) = 0.50*dtinvl*(DTABLE2(2)-DTABLE2(1))

     D2TABLE2(table_size) = 0.50*dtinvl*&
          (DTABLE2(table_size)-DTABLE2(table_size-1))
   endif


   if (construct_table_wrt_liq_and_ice) then
! compute es tables from tcmin to tcmax
! estimate es derivative with small +/- difference
 
      do i = 1, table_size
        tem(1) = tminl + dtres*real(i-1)
        tem(2) = tem(1)-tinrc
        tem(3) = tem(1)+tinrc
!   pass in flag to force all values to be wrt liquid
        es = compute_es_liq_ice_k (tem, TFREEZE)
        TABLE3(i) = es(1)
        DTABLE3(i) = (es(3)-es(2))*tfact
      enddo
 
! compute one-half second derivative using centered differences
! differencing des values in the table

     do i = 2, table_size-1
       D2TABLE3(i) = 0.25*dtinvl*(DTABLE3(i+1)-DTABLE3(i-1))
     enddo
! one-sided derivatives at boundaries

     D2TABLE3(1) = 0.50*dtinvl*(DTABLE3(2)-DTABLE3(1))

     D2TABLE3(table_size) = 0.50*dtinvl*&
          (DTABLE3(table_size)-DTABLE3(table_size-1))
   endif

      use_exact_qs = use_exact_qs_input
      module_is_initialized = .true.

 end subroutine sat_vapor_pres_init_k

!#######################################################################

 function compute_es_k(tem, TFREEZE) result (es)
 real, intent(in) :: tem(:), TFREEZE
 real :: es(size(tem,1))
         
 real    :: x, esice, esh2o, TBASW, TBASI
 integer :: i
 real, parameter :: ESBASW = 101324.60
 real, parameter :: ESBASI =    610.71

   TBASW = TFREEZE+100.
   TBASI = TFREEZE

   do i = 1, size(tem)

!  compute es over ice 

     if (tem(i) < TBASI) then
         x = -9.09718*(TBASI/tem(i)-1.0) - 3.56654*log10(TBASI/tem(i)) &
             +0.876793*(1.0-tem(i)/TBASI) + log10(ESBASI)
         esice =10.**(x)
     else
         esice = 0.
     endif

!  compute es over water greater than -20 c.
!  values over 100 c may not be valid
!  see smithsonian meteorological tables page 350.

     if (tem(i) > -20.+TBASI) then
         x = -7.90298*(TBASW/tem(i)-1) + 5.02808*log10(TBASW/tem(i)) &
             -1.3816e-07*(10**((1-tem(i)/TBASW)*11.344)-1)        &
             +8.1328e-03*(10**((TBASW/tem(i)-1)*(-3.49149))-1)    &
             +log10(ESBASW)
         esh2o = 10.**(x)
     else
         esh2o = 0.
     endif

!  derive blended es over ice and supercooled water between -20c and 0c

     if (tem(i) <= -20.+TBASI) then
         es(i) = esice
     else if (tem(i) >= TBASI) then
         es(i) = esh2o
     else
         es(i) = 0.05*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.)*esh2o)
     endif

   enddo

 end function compute_es_k

!#######################################################################

 function compute_es_liq_k(tem, TFREEZE) result (es)
 real, intent(in) :: tem(:), TFREEZE
 real :: es(size(tem,1))
         
 real    :: x, esh2o, TBASW
 integer :: i
 real, parameter :: ESBASW = 101324.60

   TBASW = TFREEZE+100.

   do i = 1, size(tem)


!  compute es over water for all temps.
!  values over 100 c may not be valid
!  see smithsonian meteorological tables page 350.

         x = -7.90298*(TBASW/tem(i)-1) + 5.02808*log10(TBASW/tem(i)) &
             -1.3816e-07*(10**((1-tem(i)/TBASW)*11.344)-1)        &
             +8.1328e-03*(10**((TBASW/tem(i)-1)*(-3.49149))-1)    &
             +log10(ESBASW)
         esh2o = 10.**(x)


         es(i) = esh2o

   enddo

 end function compute_es_liq_k

!#######################################################################

 function compute_es_liq_ice_k(tem, TFREEZE) result (es)
 real, intent(in) :: tem(:), TFREEZE
 real :: es(size(tem,1))
         
 real    :: x, TBASW, TBASI
 integer :: i
 real, parameter :: ESBASW = 101324.60
 real, parameter :: ESBASI =    610.71

   TBASW = TFREEZE+100.
   TBASI = TFREEZE

   do i = 1, size(tem)

     if (tem(i) < TBASI) then

!  compute es over ice 

         x = -9.09718*(TBASI/tem(i)-1.0) - 3.56654*log10(TBASI/tem(i)) &
             +0.876793*(1.0-tem(i)/TBASI) + log10(ESBASI)
         es(i) =10.**(x)
     else

!  compute es over water 
!  values over 100 c may not be valid
!  see smithsonian meteorological tables page 350.

         x = -7.90298*(TBASW/tem(i)-1) + 5.02808*log10(TBASW/tem(i)) &
             -1.3816e-07*(10**((1-tem(i)/TBASW)*11.344)-1)        &
             +8.1328e-03*(10**((TBASW/tem(i)-1)*(-3.49149))-1)    &
             +log10(ESBASW)
         es(i) = 10.**(x)
     endif

   enddo

 end function compute_es_liq_ice_k

!#######################################################################

 subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, &
                          dqsdT, esat, es_over_liq, es_over_liq_and_ice)

 real, intent(in),  dimension(:,:,:)           :: temp, press   
 real, intent(in)                              :: eps, zvir
 real, intent(out), dimension(:,:,:)           :: qs   
 integer, intent(out)                          :: nbad
 real, intent(in),  dimension(:,:,:), optional :: q
 real, intent(in),                    optional :: hc
 real, intent(out), dimension(:,:,:), optional :: dqsdT, esat
 logical,intent(in),                  optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real, dimension(size(temp,1), size(temp,2), size(temp,3)) ::   &
                                                  esloc, desat, denom
 integer :: i, j, k
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif
 if (present(es_over_liq)) then
   if (present (dqsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dqsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dqsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (q) .and. use_exact_qs) then
       qs = (1.0 + zvir*q)*eps*esloc/press
       if (present (dqsdT)) then
         dqsdT = (1.0 + zvir*q)*eps*desat/press
       endif
     else  ! (present(q))
       denom = press - (1.0 - eps)*esloc
       do k=1,size(qs,3)
         do j=1,size(qs,2)
           do i=1,size(qs,1)
             if (denom(i,j,k) > 0.0) then
               qs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k)         
             else
               qs(i,j,k) = eps
             endif
           end do
         end do
       end do
       if (present (dqsdT)) then
         dqsdT = eps*press*desat/denom**2
       endif
     endif ! (present(q))
   else ! (nbad = 0)
     qs = -999.
     if (present (dqsdT)) then
       dqsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif ! (nbad = 0)

     
 end subroutine compute_qs_k_3d

!#######################################################################

 subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, &
                          dqsdT, esat, es_over_liq, es_over_liq_and_ice)

 real, intent(in),  dimension(:,:)           :: temp, press   
 real, intent(in)                            :: eps, zvir
 real, intent(out), dimension(:,:)           :: qs   
 integer, intent(out)                        :: nbad
 real, intent(in),  dimension(:,:), optional :: q
 real, intent(in),                  optional :: hc
 real, intent(out), dimension(:,:), optional :: dqsdT, esat
 logical,intent(in),                optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real, dimension(size(temp,1), size(temp,2)) :: esloc, desat, denom
 integer :: i, j
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present(es_over_liq)) then
   if (present (dqsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dqsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dqsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (q) .and. use_exact_qs) then
       qs = (1.0 + zvir*q)*eps*esloc/press
       if (present (dqsdT)) then
         dqsdT = (1.0 + zvir*q)*eps*desat/press
       endif
     else  ! (present(q))
       denom = press - (1.0 - eps)*esloc
      do j=1,size(qs,2)
        do i=1,size(qs,1)
          if (denom(i,j) > 0.0) then
            qs(i,j) = eps*esloc(i,j)/denom(i,j)
          else
            qs(i,j) = eps
          endif
        end do
      end do
      if (present (dqsdT)) then
        dqsdT = eps*press*desat/denom**2
      endif
    endif ! (present(q))
   else ! (nbad = 0)
     qs = -999.
     if (present (dqsdT)) then
       dqsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif ! (nbad = 0)


 end subroutine compute_qs_k_2d

!#######################################################################

 subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, &
                          dqsdT, esat, es_over_liq, es_over_liq_and_ice)

 real, intent(in),  dimension(:)           :: temp, press   
 real, intent(in)                          :: eps, zvir
 real, intent(out), dimension(:)           :: qs   
 integer, intent(out)                      :: nbad
 real, intent(in),  dimension(:), optional :: q
 real, intent(in),                optional :: hc
 real, intent(out), dimension(:), optional :: dqsdT, esat
 logical,intent(in),              optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real, dimension(size(temp,1)) :: esloc, desat, denom
 integer :: i
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present(es_over_liq)) then
   if (present (dqsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dqsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dqsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (q) .and. use_exact_qs) then
       qs = (1.0 + zvir*q)*eps*esloc/press
       if (present (dqsdT)) then
         dqsdT = (1.0 + zvir*q)*eps*desat/press
       endif
     else  ! (present(q))
       denom = press - (1.0 - eps)*esloc
       do i=1,size(qs,1)
         if (denom(i) >  0.0) then
           qs(i) = eps*esloc(i)/denom(i)
         else
           qs(i) = eps
         endif
       end do
       if (present (dqsdT)) then
         dqsdT = eps*press*desat/denom**2
       endif
     endif ! (present(q))
   else ! (nbad = 0)
     qs = -999.
     if (present (dqsdT)) then
       dqsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif ! (nbad = 0)


 end subroutine compute_qs_k_1d

!#######################################################################

 subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, &
                          dqsdT, esat, es_over_liq, es_over_liq_and_ice)

 real, intent(in)                :: temp, press   
 real, intent(in)                :: eps, zvir
 real, intent(out)               :: qs   
 integer, intent(out)            :: nbad
 real, intent(in),      optional :: q
 real, intent(in),      optional :: hc
 real, intent(out),     optional :: dqsdT, esat
 logical,intent(in),    optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real    :: esloc, desat, denom
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present(es_over_liq)) then
   if (present (dqsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dqsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dqsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (q) .and. use_exact_qs) then
       qs = (1.0 + zvir*q)*eps*esloc/press
       if (present (dqsdT)) then
         dqsdT = (1.0 + zvir*q)*eps*desat/press
       endif
     else  ! (present(q))
       denom = press - (1.0 - eps)*esloc
       if (denom > 0.0) then
         qs = eps*esloc/denom
       else
         qs = eps
       endif
       if (present (dqsdT)) then
         dqsdT = eps*press*desat/denom**2
       endif
     endif ! (present(q))
   else ! (nbad = 0)
     qs = -999.
     if (present (dqsdT)) then
       dqsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif ! (nbad = 0)


 end subroutine compute_qs_k_0d

!#######################################################################

!#######################################################################

 subroutine compute_mrs_k_3d (temp, press, eps, zvir, mrs, nbad,   &
                 mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)

 real, intent(in),  dimension(:,:,:)           :: temp, press
 real, intent(in)                              :: eps, zvir
 real, intent(out), dimension(:,:,:)           :: mrs   
 integer, intent(out)                          :: nbad
 real, intent(in),  dimension(:,:,:), optional :: mr
 real, intent(in),                    optional :: hc
 real, intent(out), dimension(:,:,:), optional :: dmrsdT, esat
 logical,intent(in),                  optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real, dimension(size(temp,1), size(temp,2), size(temp,3)) ::    &
                                                    esloc, desat, denom
 integer :: i, j, k
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present (es_over_liq)) then
   if (present (dmrsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dmrsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dmrsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (mr) .and. use_exact_qs) then
       mrs = (eps + mr)*esloc/press
       if (present (dmrsdT)) then
         dmrsdT =  (eps + mr)*desat/press
       endif
     else ! (present (mr))
       denom = press - esloc
       do k=1,size(mrs,3)
         do j=1,size(mrs,2)
           do i=1,size(mrs,1)
             if (denom(i,j,k) > 0.0) then
               mrs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) 
             else
               mrs(i,j,k) = eps
             endif
           end do
         end do
       end do
       if (present (dmrsdT)) then
         dmrsdT = eps*press*desat/denom**2
       endif
     endif !(present (mr))
   else
     mrs = -999.
     if (present (dmrsdT)) then
       dmrsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif

     
 end subroutine compute_mrs_k_3d

!#######################################################################

 subroutine compute_mrs_k_2d (temp, press, eps, zvir, mrs, nbad,  &
                 mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)

 real, intent(in),  dimension(:,:)           :: temp, press
 real, intent(in)                            :: eps, zvir
 real, intent(out), dimension(:,:)           :: mrs   
 integer, intent(out)                        :: nbad
 real, intent(in), dimension(:,:), optional  :: mr
 real, intent(in),                 optional :: hc
 real, intent(out), dimension(:,:), optional :: dmrsdT, esat
 logical,intent(in),               optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real, dimension(size(temp,1), size(temp,2)) :: esloc, desat, denom
 integer :: i, j
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present (es_over_liq)) then
   if (present (dmrsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dmrsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dmrsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (mr) .and. use_exact_qs) then
       mrs = (eps + mr)*esloc/press
       if (present (dmrsdT)) then
         dmrsdT = (eps + mr)*desat/press
       endif
     else ! (present (mr))
       denom = press - esloc
       do j=1,size(mrs,2)
         do i=1,size(mrs,1)
           if (denom(i,j) > 0.0) then
             mrs(i,j) = eps*esloc(i,j)/denom(i,j) 
           else
             mrs(i,j) = eps
           endif
         end do
       end do
       if (present (dmrsdT)) then
         dmrsdT = eps*press*desat/denom**2
       endif
     endif !(present (mr))
   else
     mrs = -999.
     if (present (dmrsdT)) then
       dmrsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif


 end subroutine compute_mrs_k_2d

!#######################################################################

 subroutine compute_mrs_k_1d (temp, press, eps, zvir, mrs, nbad,  &
                 mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)

 real, intent(in),  dimension(:)           :: temp, press
 real, intent(in)                          :: eps, zvir
 real, intent(out), dimension(:)           :: mrs   
 integer, intent(out)                      :: nbad
 real, intent(in),  dimension(:), optional :: mr
 real, intent(in),                optional :: hc
 real, intent(out), dimension(:), optional :: dmrsdT, esat
 logical,intent(in),              optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real, dimension(size(temp,1)) :: esloc, desat, denom
 integer :: i
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present (es_over_liq)) then
   if (present (dmrsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dmrsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dmrsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (mr) .and. use_exact_qs) then
       mrs = (eps + mr)*esloc/press
       if (present (dmrsdT)) then
         dmrsdT =  (eps + mr)*desat/press
       endif
     else ! (present (mr))
       denom = press - esloc
       do i=1,size(mrs,1)
         if (denom(i) > 0.0) then
           mrs(i) = eps*esloc(i)/denom(i) 
         else
           mrs(i) = eps
         endif
       end do
       if (present (dmrsdT)) then
         dmrsdT = eps*press*desat/denom**2
       endif
     endif !(present (mr))
   else
     mrs = -999.
     if (present (dmrsdT)) then
       dmrsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif


 end subroutine compute_mrs_k_1d

!#######################################################################

 subroutine compute_mrs_k_0d (temp, press, eps, zvir, mrs, nbad,   &
                 mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)

 real, intent(in)                              :: temp, press
 real, intent(in)                              :: eps, zvir
 real, intent(out)                             :: mrs   
 integer, intent(out)                          :: nbad
 real, intent(in),                    optional :: mr
 real, intent(in),                    optional :: hc
 real, intent(out),                   optional :: dmrsdT, esat
 logical,intent(in),                  optional :: es_over_liq
 logical,intent(in),                  optional :: es_over_liq_and_ice

 real    :: esloc, desat, denom
 real    :: hc_loc

   if (present(hc)) then
     hc_loc = hc
   else
     hc_loc = 1.0
   endif

 if (present (es_over_liq)) then
   if (present (dmrsdT)) then
     call lookup_es2_des2_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es2_k (temp, esloc, nbad)
   endif
 else if (present(es_over_liq_and_ice)) then
   if (present (dmrsdT)) then
     call lookup_es3_des3_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es3_k (temp, esloc, nbad)
   endif
 else
   if (present (dmrsdT)) then
     call lookup_es_des_k (temp, esloc, desat, nbad)
     desat = desat*hc_loc
   else
     call lookup_es_k (temp, esloc, nbad)
   endif
 endif
   esloc = esloc*hc_loc
   if (present (esat)) then
     esat = esloc
   endif 
   if (nbad == 0) then
     if (present (mr) .and. use_exact_qs) then
       mrs = (eps + mr)*esloc/press
       if (present (dmrsdT)) then
         dmrsdT = (eps + mr)*desat/press
       endif
     else ! (present (mr))
       denom = press - esloc
       if (denom > 0.0) then
         mrs = eps*esloc/denom 
       else
         mrs = eps       
       endif
       if (present (dmrsdT)) then
         dmrsdT = eps*press*desat/denom**2
       endif
     endif !(present (mr))
   else
     mrs = -999.
     if (present (dmrsdT)) then
       dmrsdT = -999.
     endif
     if (present (esat)) then
       esat = -999.
     endif 
   endif


 end subroutine compute_mrs_k_0d



!#######################################################################

 subroutine lookup_es_des_k_3d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: esat, desat
 integer, intent(out)                 :: nbad

 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz) then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j,k) = TABLE(ind+1) +  &
                     del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
       desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_es_des_k_3d

!#######################################################################

 subroutine lookup_es_des_k_2d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: esat, desat
 integer, intent(out)               :: nbad

 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j) = TABLE(ind+1) + &
                   del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
       desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
     endif
   enddo
   enddo

 end subroutine lookup_es_des_k_2d

!#######################################################################

 subroutine lookup_es_des_k_1d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: esat, desat
 integer, intent(out)             :: nbad

 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i) = TABLE(ind+1) + &
                   del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
       desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
     endif
   enddo

 end subroutine lookup_es_des_k_1d

!#######################################################################

 subroutine lookup_es_des_k_0d (temp, esat, desat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: esat, desat
 integer, intent(out) :: nbad

 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     esat = TABLE(ind+1) + &
            del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
     desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
   endif

 end subroutine lookup_es_des_k_0d

!#######################################################################

 subroutine lookup_es_k_3d(temp, esat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j,k) = TABLE(ind+1) + &
                     del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_es_k_3d

!#######################################################################

 subroutine lookup_des_k_3d(temp, desat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_des_k_3d

!#######################################################################
 subroutine lookup_des_k_2d(temp, desat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
     endif
   enddo
   enddo

 end subroutine lookup_des_k_2d
!#######################################################################
 subroutine lookup_es_k_2d(temp, esat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1) +   &
                                                  del*D2TABLE(ind+1))
     endif
   enddo
   enddo

 end subroutine lookup_es_k_2d
!#######################################################################
 subroutine lookup_des_k_1d(temp, desat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
     endif 
   enddo

 end subroutine lookup_des_k_1d
!#######################################################################
 subroutine lookup_es_k_1d(temp, esat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
     endif
   enddo

 end subroutine lookup_es_k_1d
!#######################################################################
 subroutine lookup_des_k_0d(temp, desat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
   endif 

 end subroutine lookup_des_k_0d
!#######################################################################
 subroutine lookup_es_k_0d(temp, esat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
   endif 

 end subroutine lookup_es_k_0d
!#######################################################################

 subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: esat, desat
 integer, intent(out)                 :: nbad

 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz) then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j,k) = TABLE2(ind+1) +  &
                     del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
       desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_es2_des2_k_3d

!#######################################################################

 subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: esat, desat
 integer, intent(out)               :: nbad

 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j) = TABLE2(ind+1) + &
                   del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
       desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
     endif
   enddo
   enddo

 end subroutine lookup_es2_des2_k_2d

!#######################################################################

 subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: esat, desat
 integer, intent(out)             :: nbad

 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i) = TABLE2(ind+1) + &
                   del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
       desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
     endif
   enddo

 end subroutine lookup_es2_des2_k_1d

!#######################################################################

 subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: esat, desat
 integer, intent(out) :: nbad

 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     esat = TABLE2(ind+1) + &
            del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
     desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
   endif

 end subroutine lookup_es2_des2_k_0d

!#######################################################################

 subroutine lookup_es2_k_3d(temp, esat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j,k) = TABLE2(ind+1) + &
                     del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_es2_k_3d

!#######################################################################

 subroutine lookup_des2_k_3d(temp, desat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_des2_k_3d

!#######################################################################
 subroutine lookup_des2_k_2d(temp, desat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
     endif
   enddo
   enddo

 end subroutine lookup_des2_k_2d
!#######################################################################
 subroutine lookup_es2_k_2d(temp, esat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1) +   &
                                                  del*D2TABLE2(ind+1))
     endif
   enddo
   enddo

 end subroutine lookup_es2_k_2d
!#######################################################################
 subroutine lookup_des2_k_1d(temp, desat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
     endif 
   enddo

 end subroutine lookup_des2_k_1d
!#######################################################################
 subroutine lookup_es2_k_1d(temp, esat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
     endif
   enddo

 end subroutine lookup_es2_k_1d
!#######################################################################
 subroutine lookup_des2_k_0d(temp, desat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
   endif 

 end subroutine lookup_des2_k_0d
!#######################################################################
 subroutine lookup_es2_k_0d(temp, esat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
   endif 

 end subroutine lookup_es2_k_0d
!#######################################################################

!#######################################################################

 subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: esat, desat
 integer, intent(out)                 :: nbad

 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz) then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j,k) = TABLE3(ind+1) +  &
                     del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
       desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_es3_des3_k_3d

!#######################################################################

 subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: esat, desat
 integer, intent(out)               :: nbad

 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j) = TABLE3(ind+1) + &
                   del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
       desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
     endif
   enddo
   enddo

 end subroutine lookup_es3_des3_k_2d

!#######################################################################

 subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: esat, desat
 integer, intent(out)             :: nbad

 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i) = TABLE3(ind+1) + &
                   del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
       desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
     endif
   enddo

 end subroutine lookup_es3_des3_k_1d

!#######################################################################

 subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: esat, desat
 integer, intent(out) :: nbad

 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     esat = TABLE3(ind+1) + &
            del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
     desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
   endif

 end subroutine lookup_es3_des3_k_0d

!#######################################################################

 subroutine lookup_es3_k_3d(temp, esat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j,k) = TABLE3(ind+1) + &
                     del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_es3_k_3d

!#######################################################################

 subroutine lookup_des3_k_3d(temp, desat, nbad)
 real, intent(in),  dimension(:,:,:)  :: temp
 real, intent(out), dimension(:,:,:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j, k

   nbad = 0
   do k = 1, size(temp,3)
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j,k)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
     endif
   enddo
   enddo
   enddo

 end subroutine lookup_des3_k_3d

!#######################################################################
 subroutine lookup_des3_k_2d(temp, desat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
     endif
   enddo
   enddo

 end subroutine lookup_des3_k_2d
!#######################################################################
 subroutine lookup_es3_k_2d(temp, esat, nbad)
 real, intent(in),  dimension(:,:)  :: temp
 real, intent(out), dimension(:,:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i, j

   nbad = 0
   do j = 1, size(temp,2)
   do i = 1, size(temp,1)
     tmp = temp(i,j)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1) +   &
                                                  del*D2TABLE3(ind+1))
     endif
   enddo
   enddo

 end subroutine lookup_es3_k_2d
!#######################################################################
 subroutine lookup_des3_k_1d(temp, desat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
     endif 
   enddo

 end subroutine lookup_des3_k_1d
!#######################################################################
 subroutine lookup_es3_k_1d(temp, esat, nbad)
 real, intent(in),  dimension(:)  :: temp
 real, intent(out), dimension(:)  :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind, i

   nbad = 0
   do i = 1, size(temp,1)
     tmp = temp(i)-tminl
     ind = int(dtinvl*(tmp+tepsl))
     if (ind < 0 .or. ind >= table_siz)  then
       nbad = nbad+1
     else
       del = tmp-dtres*real(ind)
       esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
     endif
   enddo

 end subroutine lookup_es3_k_1d
!#######################################################################
 subroutine lookup_des3_k_0d(temp, desat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: desat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
   endif 

 end subroutine lookup_des3_k_0d
!#######################################################################
 subroutine lookup_es3_k_0d(temp, esat, nbad)
 real, intent(in)     :: temp
 real, intent(out)    :: esat
 integer, intent(out) :: nbad
 real    :: tmp, del
 integer :: ind

   nbad = 0
   tmp = temp-tminl
   ind = int(dtinvl*(tmp+tepsl))
   if (ind < 0 .or. ind >= table_siz)  then
     nbad = nbad+1
   else
     del = tmp-dtres*real(ind)
     esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
   endif 

 end subroutine lookup_es3_k_0d
!#######################################################################
 end module sat_vapor_pres_k_mod



module station_data_mod 
! <CONTACT EMAIL="Giang.Nong@gfdl.noaa.gov">
!   Giang Nong
! </CONTACT>
! <OVERVIEW>
! This module is used for outputing model results in a list
! of stations (not gridded arrrays). The user needs to supply
! a list of stations with lat, lon values of each station.
! Data at a single point (I,J) that is closest to each station will
! be written to a file. No interpolation is made when a station
! is between two or more grid points.<BR/>
! In the output file, a 3D field will have a format of array(n1,n2) and
! a 2D field is array(n1) where n1 is number of stations and n2 is number
! of vertical levels or depths.
! </OVERVIEW>
! <DESCRIPTION>
! Here are some basic steps of how to use station_data_mod <BR/>
!1/Call <TT>data_station_init</TT>  <BR/>
! user needs to supply 2 tables: list_stations and station_data_table as follows:<BR/>
! example of  list of stations (# sign means comment)<BR/>
!               #  station_id          lat    lon <BR/>
!                   station_1          20.4   100.8 <BR/>
! example of station_data_table (# sign means comment) <BR/>
! # General descriptor <BR/>
! Am2p14 station data <BR/>

!#  start time (should be the same as model's initial time) <BR/>
! 19800101 <BR/>
!# file inforamtion <BR/>
!#   filename,    output_frequency, frequency_unit, time_axis_unit <BR/>
!   "ocean_day"         1              "days"           "hours" <BR/>
!# field information <BR/>
!# module     field_name    filename    time_method   pack <BR/>
!  Ice_mod    temperature   ocean_day     . true.       2 <BR/>
!  Ice_mod    pressure      ocean_day      .false.      2    <BR/>
! 2/
! Call register_station_field to register each field that needs to be written to a file, the call
! <TT>register_station_field</TT> returns a field_id that will be used later in send_station_data <BR/>
! 3/
! Call <TT> send_station_data</TT> will send data at each station in the list
! to a file <BR/>
! 4/ Finally, call <TT>station_data_end</TT> after the last time step.<BR/>
! </DESCRIPTION>
use axis_utils_mod, only: nearest_index
use mpp_io_mod,    only : mpp_open, MPP_RDONLY, MPP_ASCII, mpp_close,MPP_OVERWR,MPP_NETCDF, &
                          mpp_write_meta, MPP_SINGLE, mpp_write, fieldtype,mpp_flush
use fms_mod,       only : error_mesg, FATAL, WARNING, stdlog, write_version_number,&
                          mpp_pe, lowercase, stdout, close_file, open_namelist_file, check_nml_error
use mpp_mod,       only : mpp_npes,  mpp_sync, mpp_root_pe, mpp_send, mpp_recv, mpp_max, &
                          mpp_get_current_pelist, input_nml_file
use mpp_domains_mod,only: domain2d, mpp_get_compute_domain
use diag_axis_mod, only : diag_axis_init
use diag_output_mod,only:  write_axis_meta_data, write_field_meta_data,diag_fieldtype,done_meta_data
use diag_manager_mod,only : get_date_dif, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, &
                            DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS
use diag_util_mod,only    : diag_time_inc
use time_manager_mod, only: operator(>),operator(>=),time_type,get_calendar_type,NO_CALENDAR,set_time, &
                            set_date, increment_date, increment_time
implicit none
private
integer, parameter  :: max_fields_per_file = 150
integer, parameter  :: max_files = 31
integer             :: num_files = 0
integer             :: num_stations = 0
integer             :: max_stations = 20
integer             :: max_output_fields = 100
integer             :: num_output_fields = 0
real                :: EMPTY = 0.0
real                :: MISSING = 1.E20
logical             :: module_is_initialized = .false.
logical             :: need_write_axis = .true.
integer             :: base_year, base_month, base_day, base_hour, base_minute, base_second
type (time_type)    :: base_time
character (len=10)  :: time_unit_list(6) = (/'seconds   ', 'minutes   ', &
     'hours     ', 'days      ', 'months    ', 'years     '/)
integer, parameter  :: EVERY_TIME =  0
integer, parameter  :: END_OF_RUN = -1
character(len=128)  :: version = ''
character(len=128)  :: tagname = ''  
character(len=256)  :: global_descriptor
character (len = 7) :: avg_name = 'average'
integer             :: total_pe
integer             :: lat_axis, lon_axis
integer, allocatable:: pelist(:)
character(len=32)   :: pelist_name
type file_type
   character(len=128)  :: name
   integer             :: output_freq
   integer             :: output_units
   integer             :: time_units
   integer             :: fields(max_fields_per_file)
   integer             :: num_fields
   integer             :: file_unit
   integer             :: time_axis_id, time_bounds_id
   type (time_type)    :: last_flush
   type(fieldtype)     :: f_avg_start, f_avg_end, f_avg_nitems, f_bounds
end type file_type
type station_type
   character(len=128)  :: name
   real                :: lat, lon
   integer             :: id
   integer             :: global_i, global_j  ! index of global grid
   integer             :: local_i, local_j    ! index on the current PE
   logical             :: need_compute        ! true if the station present in this PE
end type station_type

type group_field_type
   integer             :: output_file
   integer             :: num_station ! number of stations on this PE
   integer, pointer    :: station_id(:)  =>null() ! id of station on this PE
   character(len=128)  :: output_name, module_name,long_name, units
   logical             :: time_average,time_max,time_min, time_ops, register
   integer             :: pack, axes(2), num_axes
   character(len=8)    :: time_method   !could be: true, false, max, min, mean, ...
   real, pointer       :: buffer(:, :)=>null()
   integer             :: counter,nlevel
   type(time_type)     :: last_output, next_output
   type(fieldtype)     :: f_type
end type group_field_type

type global_field_type
   real, pointer       :: buffer(:,:)=>null()
   integer             :: counter
end type global_field_type   


type(global_field_type),save            :: global_field
type (file_type),save                   :: files(max_files)
type(group_field_type),allocatable,save :: output_fields(:)
type (station_type),allocatable         :: stations(:)
type(diag_fieldtype),save               :: diag_field
public register_station_field, send_station_data, station_data_init, station_data_end

interface register_station_field
    module procedure register_station_field2d
    module procedure register_station_field3d
end interface
interface send_station_data
    module procedure send_station_data_2d
    module procedure send_station_data_3d
end interface
contains

! <INTERFACE NAME="station_data_init">
! <TEMPLATE>
! station_data_init()
! </TEMPLATE>
!   <DESCRIPTION>
! read in lat. lon of each station<BR/>
! create station_id based on lat, lon<BR/>
! read station_data_table, initialize output_fields and output files<BR/>
!   </DESCRIPTION>
! </INTERFACE>
subroutine station_data_init()

character(len=128)    :: station_name
real                  :: lat, lon  
integer               :: iunit,nfiles,nfields,time_units,output_freq_units,j,station_id,io_status,logunit, ierr
logical               :: init_verbose
character(len=128)    :: record
type file_part_type
   character(len=128) :: name
   integer            :: output_freq
   character(len=10)  :: output_freq_units 
   integer            :: format    ! must always be 1 for netcdf files
   character(len=10)  :: time_unit
end type file_part_type
type field_part_type
   character(len=128) :: module_name,field_name,file_name
   character(len=8)   :: time_method   
   integer            :: pack
end type field_part_type

type(file_part_type)  :: record_files
type(field_part_type) :: record_fields

namelist /station_data_nml/ max_output_fields, max_stations,init_verbose

  if (module_is_initialized) return
  init_verbose = .false.
  total_pe = mpp_npes()
  allocate(pelist(total_pe))
  call mpp_get_current_pelist(pelist, pelist_name) 

! read namelist
#ifdef INTERNAL_FILE_NML
  read (input_nml_file, station_data_nml, iostat=io_status)
  ierr = check_nml_error(io_status, 'station_data_nml')
#else
  iunit = open_namelist_file ()
  ierr=1; do while (ierr /= 0)
  read  (iunit, nml=station_data_nml, iostat=io_status, end=10)
  ierr = check_nml_error(io_status, 'station_data_nml')
  enddo
10 call close_file (iunit)

#endif
  logunit = stdlog()
  write(logunit, station_data_nml)

  allocate(output_fields(max_output_fields), stations(max_stations))
! read list of stations
  if(init_verbose) then
     logunit = stdout()
     write(logunit, *) ' '
     write(logunit, *) '****** Summary of STATION information from list_stations ********'
     write(logunit, *) ' '
     write(logunit, *) 'station name      ', '   latitude ', '   longitude '
     write(logunit, *) ' '
  endif
  call mpp_open(iunit, 'list_stations',form=MPP_ASCII,action=MPP_RDONLY)
  do while (num_stations<max_stations)
     read(iunit,'(a)',end=76,err=75) record
     if (record(1:1) == '#') cycle 
     if(len_trim(record) < 1) cycle
     read(record, *, end = 76, err = 75) station_name, lat, lon 
     station_id = get_station_id(lat, lon)
     if(station_id > 0) then       
        stations(station_id)%name = station_name
     else
        call error_mesg('station_data_init','station DUPLICATED in file list_stations', FATAL)
     endif
     logunit = stdout()
     if( init_verbose.and.  mpp_pe() == mpp_root_pe()) &
          write(logunit,1)stations(station_id)%name,stations(station_id)%lat,stations(station_id)%lon
1 format(1x,A18, 1x,F8.2,4x,F8.2)     
75   continue
  enddo
  call error_mesg('station_data_init','max_stations exceeded, increase it via namelist', FATAL)
76 continue
  call mpp_close (iunit)
  logunit = stdout()
  if(init_verbose)  write(logunit, *)'*****************************************************************'
     
! read station_data table
  call mpp_open(iunit, 'station_data_table',form=MPP_ASCII,action=MPP_RDONLY)
! Read in the global file labeling string
  read(iunit, *, end = 99, err=99) global_descriptor

! Read in the base date
  read(iunit, *, end = 99, err = 99) base_year, base_month, base_day, &
       base_hour, base_minute, base_second
  if (get_calendar_type() /= NO_CALENDAR) then
     base_time = set_date(base_year, base_month, base_day, base_hour, &
          base_minute, base_second)
  else
! No calendar - ignore year and month
     base_time = set_time(base_hour*3600+base_minute*60+base_second, base_day)
     base_year  = 0
     base_month = 0
  end if
  nfiles=0
  do while (nfiles <= max_files)
     read(iunit,'(a)',end=86,err=85) record
     if (record(1:1) == '#') cycle        
     read(record,*,err=85,end=85)record_files%name,record_files%output_freq, &
          record_files%output_freq_units,record_files%format,record_files%time_unit
     if(record_files%format /= 1) cycle   !avoid reading field part
     time_units = 0
     output_freq_units = 0
     do j = 1, size(time_unit_list(:))
        if(record_files%time_unit == time_unit_list(j)) time_units = j
        if(record_files%output_freq_units == time_unit_list(j)) output_freq_units = j     
     end do
     if(time_units == 0) &
          call error_mesg('station_data_init',' check time unit in station_data_table',FATAL)
     if(output_freq_units == 0) & 
          call error_mesg('station_data_init',', check output_freq in station_data_table',FATAL)
      call init_file(record_files%name,record_files%output_freq, output_freq_units,time_units)
85    continue
   enddo
   call error_mesg('station_data_init','max_files exceeded, increase max_files', FATAL)
86 continue
   rewind(iunit)
   nfields=0
   do while (nfields <= max_output_fields)
       read(iunit,'(a)',end=94,err=93) record
       if (record(1:1) == '#') cycle
       read(record,*,end=93,err=93) record_fields
       if (record_fields%pack .gt. 8 .or.record_fields%pack .lt. 1) cycle !avoid reading file part
       nfields=nfields+1
       call init_output_field(record_fields%module_name,record_fields%field_name, &
            record_fields%file_name,record_fields%time_method,record_fields%pack)
93     continue
    enddo
    call error_mesg('station_data_init','max_output_fields exceeded, increase it via nml ', FATAL)
94  continue
    call close_file(iunit)
    call check_duplicate_output_fields
    call write_version_number (version, tagname)
    module_is_initialized = .true.
    return
99  continue
    call error_mesg('station_data_init','error reading station_datatable',FATAL)
end subroutine station_data_init
!----------------------------------------------------------------------
subroutine check_duplicate_output_fields()
! pair(output_name and output_file) should be unique in data_station_table, ERROR1
! pair(module_name and output_name) should be unique in data_station_table, ERROR2
integer            :: i, j, tmp_file
character(len=128) :: tmp_name, tmp_module

if(num_output_fields <= 1) return 
do i = 1, num_output_fields-1
   tmp_name = trim(output_fields(i)%output_name)
   tmp_file =  output_fields(i)%output_file
   tmp_module = trim(output_fields(i)%module_name)
   do j = i+1, num_output_fields
      if((tmp_name == trim(output_fields(j)%output_name)).and. &
           (tmp_file == output_fields(j)%output_file)) &
           call error_mesg (' ERROR1 in station_data_table:', &           
           &' module/field '//tmp_module//'/'//tmp_name//' duplicated', FATAL)
      if((tmp_name == trim(output_fields(j)%output_name)).and. &
           (tmp_module == trim(output_fields(j)%module_name))) &
           call error_mesg (' ERROR2 in station_data_table:', &           
           &' module/field '//tmp_module//'/'//tmp_name//' duplicated', FATAL)
   enddo
enddo
end subroutine check_duplicate_output_fields
!----------------------------------------------------------------------
function get_station_id(lat,lon)
  integer         :: get_station_id, i
  real, intent(in):: lat,lon
! each station should have distinct lat and lon
  get_station_id = -1
  do i = 1, num_stations
     if(stations(i)%lat == lat .and. stations(i)%lon == lon) return
  enddo
  num_stations = num_stations + 1
  stations(num_stations)%id = num_stations
  stations(num_stations)%lat = lat
  stations(num_stations)%lon = lon
  stations(num_stations)%need_compute = .false.
  stations(num_stations)%global_i = -1; stations(num_stations)%global_j = -1 
  stations(num_stations)%local_i = -1 ; stations(num_stations)%local_j = -1
  get_station_id = num_stations
end function get_station_id
!----------------------------------------------------------------------
subroutine init_file(filename, output_freq, output_units, time_units)
  character(len=*), intent(in) :: filename
  integer, intent(in)          :: output_freq, output_units, time_units
  character(len=128)           :: time_units_str
  real, dimension(1)           :: tdata

  num_files = num_files + 1
  if(num_files >= max_files) &
       call error_mesg('station_data, init_file', ' max_files exceeded, incease max_files', FATAL)
  files(num_files)%name = trim(filename)
  files(num_files)%output_freq = output_freq
  files(num_files)%output_units = output_units
  files(num_files)%time_units = time_units
  files(num_files)%num_fields = 0
  files(num_files)%last_flush = base_time
  files(num_files)%file_unit = -1
!---- register axis_id and time boundaries id
  write(time_units_str, 11) trim(time_unit_list(files(num_files)%time_units)), base_year, &
       base_month, base_day, base_hour, base_minute, base_second
11 format(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
  files(num_files)%time_axis_id = diag_axis_init ('Time', tdata, time_units_str, 'T',  &
       'Time' , set_name=trim(filename))
  files(num_files)%time_bounds_id = diag_axis_init('nv',(/1.,2./),'none','N','vertex number',&
       set_name=trim(filename))
end subroutine init_file

!--------------------------------------------------------------------------
subroutine init_output_field(module_name,field_name,file_name,time_method,pack)
  character(len=*), intent(in)           :: module_name, field_name, file_name
  character(len=*), intent(in)           :: time_method
  integer, intent(in)                    :: pack
  integer                                :: out_num, file_num,num_fields, method_selected, l1 
  character(len=8)                       :: t_method
! Get a number for this output field
  num_output_fields = num_output_fields + 1
  if(num_output_fields > max_output_fields) &
       call error_mesg('station_data', 'max_output_fields exceeded, increase it via nml', FATAL)
  out_num = num_output_fields
  file_num = find_file(file_name)
   if(file_num < 0) &
        call error_mesg('station_data,init_output_field', 'file '//trim(file_name) &
        //' is NOT found in station_data_table', FATAL)
! Insert this field into list of fields of this file
   files(file_num)%num_fields = files(file_num)%num_fields + 1
   if(files(file_num)%num_fields > max_fields_per_file) &
        call error_mesg('station_data, init_output_field', 'max_fields_per_file exceeded ', FATAL)
   num_fields = files(file_num)%num_fields
   files(file_num)%fields(num_fields)  = out_num
   output_fields(out_num)%output_name  = trim(field_name)
   output_fields(out_num)%module_name  = trim(module_name)
   output_fields(out_num)%counter      = 0
   output_fields(out_num)%output_file  = file_num
   output_fields(out_num)%pack         = pack
   output_fields(out_num)%time_average = .false.
   output_fields(out_num)%time_min     = .false.
   output_fields(out_num)%time_max     = .false. 
   output_fields(out_num)%time_ops     = .false.
   output_fields(out_num)%register     = .false.
   t_method = lowercase(time_method)
 select case (trim(t_method))
 case('.true.')
    output_fields(out_num)%time_average = .true.
    output_fields(out_num)%time_method  = 'mean'
 case('mean')
    output_fields(out_num)%time_average = .true.
    output_fields(out_num)%time_method  = 'mean'
 case('average')
    output_fields(out_num)%time_average = .true.
    output_fields(out_num)%time_method  = 'mean'
 case('avg')
    output_fields(out_num)%time_average = .true.
    output_fields(out_num)%time_method  = 'mean'
 case('.false.')
    output_fields(out_num)%time_average = .false.
     output_fields(out_num)%time_method  = 'point'
 case ('max')
    call error_mesg('station_data, init_output_field','time_method MAX is not supported',&
         FATAL)
    output_fields(out_num)%time_max = .true.
    output_fields(out_num)%time_method  = 'max'
    l1 = len_trim(output_fields(out_num)%output_name)
    if(output_fields(out_num)%output_name(l1-2:l1) /= 'max') &
           output_fields(out_num)%output_name = trim(field_name)//'_max'      
 case ('min')
    call error_mesg('station_data, init_output_field','time_method MIN is not supported',&
         FATAL)
    output_fields(out_num)%time_min = .true.
    output_fields(out_num)%time_method  = 'min'
    l1 = len_trim(output_fields(out_num)%output_name)
    if(output_fields(out_num)%output_name(l1-2:l1) /= 'min') &
         output_fields(out_num)%output_name = trim(field_name)//'_min'
 case default
    call error_mesg('station_data, init_output_field', 'error in time_method of field '&
         //trim(field_name), FATAL)
 end select
 if (files(file_num)%output_freq == EVERY_TIME) &
      output_fields(out_num)%time_average = .false.
 output_fields(out_num)%time_ops = output_fields(out_num)%time_min.or.output_fields(out_num)%time_max &
      .or.output_fields(out_num)%time_average
 output_fields(out_num)%time_method = trim(time_method)
end subroutine init_output_field
!--------------------------------------------------------------------------
function find_file(name)
integer                      :: find_file
character(len=*), intent(in) :: name
integer                      :: i

find_file = -1
do i = 1, num_files
   if(trim(files(i)%name) == trim(name)) then
      find_file = i
      return
   end if
end do
end function find_file
! <INTERFACE NAME="register_station_field">
! <TEMPLATE>
! register_station_field (module_name,fieldname,glo_lat,glo_lon,levels,init_time, 
!     domain,longname,units) <BR/>
! </TEMPLATE>
!   <DESCRIPTION>
! This function is similar to register_diag_field of diag_manager_mod. All arguments
! are inputs that user needs to supply, some are optional. The names of input args are
! self-describing.<BR/> levels is absent for 2D fields. <BR/>
! Note that pair (module_name, fieldname) must be unique in the 
! station_data_table or a fatal error will occur. <BR/>
! A field id is returned from this call that will be used later in send_station_data. <BR/>
!   </DESCRIPTION>
! </INTERFACE>


!--------------------------------------------------------------------------
function register_station_field2d (module_name,fieldname,glo_lat,glo_lon,init_time, &
     domain,longname,units)
  integer                                :: register_station_field2d
  character(len=*), intent(in)           :: module_name, fieldname
  real,dimension(:), intent(in)          :: glo_lat,glo_lon
  type(domain2d), intent(in)             :: domain
  type(time_type), intent(in)            :: init_time
  character(len=*), optional, intent(in) :: longname, units
  real                                   :: levels(1:1)

  levels = 0.
  register_station_field2d = register_station_field3d (module_name,fieldname,glo_lat,glo_lon,&
       levels,init_time,domain,longname,units)
end function register_station_field2d
!--------------------------------------------------------------------------

function register_station_field3d (module_name,fieldname,glo_lat,glo_lon,levels,init_time, &
     domain,longname,units)

! write field meta data on ROOT PE only
! allocate buffer
  integer                                :: register_station_field3d
  character(len=*), intent(in)           :: module_name, fieldname
  real,dimension(:), intent(in)          :: glo_lat,glo_lon,levels !in X,Y,Z direction respectively
  type(domain2d), intent(in)             :: domain
  type(time_type), intent(in)            :: init_time
  character(len=*), optional, intent(in) :: longname,units
  integer                                :: i,ii, nlat, nlon,nlevel, isc, iec, jsc, jec
  character(len=128)                     :: error_msg
  integer                                :: local_num_stations ! number of stations on this PE
  integer                                :: out_num ! position of this field in array output_fields
  integer                                :: file_num, freq, output_units, outunit
  real, allocatable                      :: station_values(:), level_values(:)
  character(len=128)                     :: longname2,units2


  if(PRESENT(longname)) then
     longname2 = longname
  else
     longname2 = fieldname
  endif
  if(PRESENT(units)) then
     units2 = units
  else
     units2 = "none"
  endif

  nlat = size(glo_lat); nlon = size(glo_lon); nlevel=size(levels)
  allocate(station_values(num_stations), level_values(nlevel))
  do i = 1, nlevel
     level_values(i) = real(i)
  enddo
! determine global index of this field in all stations
  outunit = stdout()
  do i = 1,num_stations
     station_values(i) = real(i)
     if(stations(i)%lat<glo_lat(1) .or. stations(i)%lat>glo_lat(nlat)) then
        write(error_msg,'(F9.3)') stations(i)%lat
        write(outunit,*) 'Station with latitude '//trim(error_msg)//' outside global latitude values'
        call error_mesg ('register_station_field', 'latitude out of range', FATAL)
     endif
      if(stations(i)%lon<glo_lon(1) .or. stations(i)%lon>glo_lon(nlon)) then
        write(error_msg,'(F9.3)') stations(i)%lon
        write(outunit,*) 'Station with longitude '//trim(error_msg)//' outside global longitude values'
        call error_mesg ('register_station_field', 'longitude out of range', FATAL)
     endif
     stations(i)%global_i = nearest_index(stations(i)%lon, glo_lon)
     stations(i)%global_j = nearest_index(stations(i)%lat, glo_lat)
     if(stations(i)%global_i<0 .or. stations(i)%global_j<0) &
          call error_mesg ('register_station_field', 'Error in global index of station',FATAL)
  enddo
! determine local index of this field in all stations , local index starts from 1
  call mpp_get_compute_domain(domain, isc,iec,jsc,jec)
  local_num_stations = 0
  do i = 1,num_stations
     if(isc<=stations(i)%global_i .and. iec>= stations(i)%global_i .and. &
        jsc<=stations(i)%global_j .and. jec>= stations(i)%global_j) then
        stations(i)%need_compute = .true.
        stations(i)%local_i = stations(i)%global_i - isc + 1
        stations(i)%local_j = stations(i)%global_j - jsc + 1
        local_num_stations = local_num_stations +1    
     endif
  enddo
! get the position of this field in the array output_fields
  out_num = find_output_field(module_name, fieldname)  
  if(out_num < 0 .and. mpp_pe() == mpp_root_pe()) then 
     call error_mesg ('register_station_field', &
          'module/field_name '//trim(module_name)//'/'//&
          trim(fieldname)//' NOT found in station_data table', WARNING)
     register_station_field3d = out_num
     return
  endif
  if(local_num_stations>0) then
     allocate(output_fields(out_num)%station_id(local_num_stations))
     allocate(output_fields(out_num)%buffer(local_num_stations,nlevel))
     output_fields(out_num)%buffer = EMPTY
! fill out list of available stations in this PE 
     ii=0
     do i = 1,num_stations       
        if(stations(i)%need_compute) then
           ii = ii+ 1
           if(ii>local_num_stations) call error_mesg ('register_station_field', &
                'error in determining local_num_station', FATAL)
           output_fields(out_num)%station_id(ii)=stations(i)%id
        endif
     enddo
  endif
  output_fields(out_num)%num_station = local_num_stations
  if( mpp_pe() == mpp_root_pe()) then
     allocate(global_field%buffer(num_stations,nlevel))
     global_field%buffer = MISSING
  endif
  output_fields(out_num)%register = .true.
  output_fields(out_num)%output_name = fieldname
  file_num = output_fields(out_num)%output_file
  output_fields(out_num)%last_output = init_time
  freq = files(file_num)%output_freq
  output_units = files(file_num)%output_units
  output_fields(out_num)%next_output = diag_time_inc(init_time, freq, output_units)
  register_station_field3d = out_num
  output_fields(out_num)%long_name = longname2
  output_fields(out_num)%units = units2
  output_fields(out_num)%nlevel = nlevel
! deal with axes
 
  output_fields(out_num)%axes(1) = diag_axis_init('Stations',station_values,'station number', 'X')
  if(nlevel == 1) then
     output_fields(out_num)%num_axes = 1     
  else
     output_fields(out_num)%num_axes = 2     
     output_fields(out_num)%axes(2) = diag_axis_init('Levels',level_values,'level number', 'Y' )   
  endif
  if(need_write_axis) then
     lat_axis = diag_axis_init('Latitude', stations(1:num_stations)%lat,'station latitudes', 'n')
     lon_axis = diag_axis_init('Longitude',stations(1:num_stations)%lon,  'station longitudes', 'n')
  endif
  need_write_axis = .false.
 
!  call mpp_sync()

end function register_station_field3d

!-------------------------------------------------------------------------

function find_output_field(module_name, field_name)
  integer find_output_field
  character(len=*), intent(in) :: module_name, field_name
  integer                      :: i

  find_output_field = -1
  do i = 1, num_output_fields
     if(trim(output_fields(i)%module_name) == trim(module_name) .and. &
          lowercase(trim(output_fields(i)%output_name)) == &
          lowercase(trim(field_name))) then 
        find_output_field = i
        return
     endif
  end do
end function find_output_field

!-------------------------------------------------------------------------
subroutine opening_file(file)
! open file, write axis meta_data for all files (only on ROOT PE, 
!                        do nothing on other PEs)
 integer, intent(in)  :: file
 character(len=128)   :: time_units
 integer              :: j,field_num,num_axes,axes(5),k
 logical              :: time_ops
 integer              :: time_axis_id(1),time_bounds_id(1)

 write(time_units, 11) trim(time_unit_list(files(file)%time_units)), base_year, &
      base_month, base_day, base_hour, base_minute, base_second
11 format(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
 call mpp_open(files(file)%file_unit, files(file)%name, action=MPP_OVERWR, &
       form=MPP_NETCDF, threading=MPP_SINGLE, fileset=MPP_SINGLE)
 call mpp_write_meta (files(file)%file_unit, 'title', cval=trim(global_descriptor))
 time_ops = .false.
 do j = 1, files(file)%num_fields
    field_num = files(file)%fields(j)
    if(output_fields(field_num)%time_ops) then
       time_ops = .true.
       exit
    endif
 enddo
!write axis meta data
 do j = 1, files(file)%num_fields
    field_num = files(file)%fields(j)
    num_axes = output_fields(field_num)%num_axes
    axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
    do k = 1,num_axes
       if(axes(k)<0) &
            call error_mesg ('station_data opening_file','output_name '// &
            trim(output_fields(field_num)%output_name)// &
            ' has axis_id = -1', FATAL)
    enddo
    axes(num_axes + 1) = lat_axis
    axes(num_axes + 2) = lon_axis
    axes(num_axes + 3) = files(file)%time_axis_id
! need in write_axis: name, unit,long_name
    call write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 3), time_ops)
    if(time_ops) then
       axes(num_axes + 4) = files(file)%time_bounds_id
       call write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 4))     
    endif
 end do
!write field meta data
 do j = 1, files(file)%num_fields
    field_num = files(file)%fields(j)
    num_axes = output_fields(field_num)%num_axes
    axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
    num_axes = num_axes + 1
    axes(num_axes) = files(file)%time_axis_id    
    diag_field = write_field_meta_data(files(file)%file_unit,output_fields(field_num)%output_name, &
         axes(1:num_axes),output_fields(field_num)%units, &
         output_fields(field_num)%long_name,time_method=output_fields(field_num)%time_method,&
         pack=output_fields(field_num)%pack)
    output_fields(field_num)%f_type = diag_field%Field
 end do
 if(time_ops) then
    time_axis_id(1) = files(file)%time_axis_id
    time_bounds_id(1) = files(file)%time_bounds_id
    diag_field=write_field_meta_data(files(file)%file_unit, avg_name // '_T1',time_axis_id, &
        time_units,"Start time for average period", pack=1)
    files(file)%f_avg_start = diag_field%Field

    diag_field=write_field_meta_data(files(file)%file_unit,avg_name // '_T2' ,time_axis_id, &
          time_units,"End time for average period", pack=1)
    files(file)%f_avg_end = diag_field%Field

    diag_field=write_field_meta_data(files(file)%file_unit,avg_name // '_DT' ,time_axis_id, &
          time_units,"Length of average period", pack=1)  
    files(file)%f_avg_nitems = diag_field%Field

    diag_field=write_field_meta_data(files(file)%file_unit, 'Time_bounds', (/time_bounds_id,time_axis_id/), &
           trim(time_unit_list(files(file)%time_units)), &
           'Time axis boundaries', pack=1) 
     files(file)%f_bounds =  diag_field%Field
 endif
 call done_meta_data(files(file)%file_unit)
end subroutine opening_file 
! <INTERFACE NAME="send_station_data">
! <TEMPLATE>
! send_station_data(field_id, data, time)
! </TEMPLATE>
!   <DESCRIPTION>
! data should have the size of compute domain(isc:iec,jsc:jec)<BR/>
! time is model's time<BR/>
! field_id is returned from <TT>register_station_field</TT><BR/>
! only data at stations will be be sent to root_pe which, in turn, sends to output file
!   </DESCRIPTION>
! </INTERFACE>
!-------------------------------------------------------------------------
subroutine send_station_data_2d(field_id, data, time)
  integer, intent(in)         :: field_id
  real,    intent(in)         :: data(:,:)
  type(time_type), intent(in) :: time
  real                        :: data3d(size(data,1),size(data,2),1)

  data3d(:,:,1) = data
  call send_station_data_3d(field_id, data3d, time)
end subroutine send_station_data_2d
!-------------------------------------------------------------------------
subroutine send_station_data_3d(field_id, data, time)
 
  integer, intent(in)         :: field_id
  real,    intent(in)         :: data(:,:,:)
  type(time_type), intent(in) :: time
  integer                     :: freq,units,file_num,local_num_stations,i,ii, max_counter
  integer                     :: index_x, index_y, station_id
  integer, allocatable        :: station_ids(:)  ! root_pe only,  to receive local station_ids
  real,    allocatable        :: tmp_buffer(:,:) ! root_pe only, to receive local buffer from each PE
  

  if (.not.module_is_initialized) &
     call error_mesg ('send_station_data_3d',' station_data NOT initialized', FATAL)

  if(field_id < 0) return  
  file_num = output_fields(field_id)%output_file
  if( mpp_pe() == mpp_root_pe() .and. files(file_num)%file_unit < 0) then
     call opening_file(file_num)
  endif
  freq = files(file_num)%output_freq
  units = files(file_num)%output_units
! compare time with next_output

  if (time > output_fields(field_id)%next_output .and. freq /= END_OF_RUN) then  ! time to write out     
! ALL PEs, including root PE, must send data to root PE        
     call mpp_send(output_fields(field_id)%num_station,plen=1,to_pe=mpp_root_pe())
     if(output_fields(field_id)%num_station > 0) then
        call mpp_send(output_fields(field_id)%station_id(1),plen=size(output_fields(field_id)%station_id),&
             to_pe=mpp_root_pe())
        call mpp_send(output_fields(field_id)%buffer(1,1),plen=size(output_fields(field_id)%buffer),&
             to_pe=mpp_root_pe())
     endif   
! get max_counter if the field is averaged
     if(output_fields(field_id)%time_average) then
        max_counter = output_fields(field_id)%counter
        call mpp_max(max_counter, pelist)
     endif
! receive local data from all PEs 
     if(mpp_pe() == mpp_root_pe()) then
        do i = 1,size(pelist)           
           call mpp_recv(local_num_stations,glen=1,from_pe=pelist(i))
           if(local_num_stations> 0) then
              allocate(station_ids(local_num_stations))
              allocate(tmp_buffer(local_num_stations,output_fields(field_id)%nlevel))
              call mpp_recv(station_ids(1), glen=size(station_ids), from_pe=pelist(i))
              call mpp_recv(tmp_buffer(1,1),glen=size(tmp_buffer),  from_pe=pelist(i)) 
              do ii = 1,local_num_stations
                 global_field%buffer(station_ids(ii),:) = tmp_buffer(ii,:)
              enddo
              deallocate(station_ids, tmp_buffer)
           endif
        enddo
! send global_buffer content to file
        if(output_fields(field_id)%time_average) then  
           if(max_counter == 0 ) &
                call error_mesg ('send_station_data','counter=0 for averaged field '// &
                output_fields(field_id)%output_name, FATAL)
           global_field%buffer = global_field%buffer/real(max_counter)
        endif
! check if global_field contains any missing values
        if(any(global_field%buffer == MISSING)) &
             call error_mesg ('send_station_data','Global_field contains MISSING, field '// &
             output_fields(field_id)%output_name, FATAL)
        call station_data_out(file_num,field_id,global_field%buffer,output_fields(field_id)%next_output)
        global_field%buffer = MISSING
     endif
     call mpp_sync()
! clear buffer, increment next_output time and reset counter on ALL PEs
     if(output_fields(field_id)%num_station>0)  output_fields(field_id)%buffer = EMPTY
     output_fields(field_id)%last_output = output_fields(field_id)%next_output
     output_fields(field_id)%next_output =  diag_time_inc(output_fields(field_id)%next_output,&
          freq, units)
     output_fields(field_id)%counter = 0; max_counter = 0
    
  endif
! accumulate buffer only
  do i = 1 , output_fields(field_id)%num_station
     station_id = output_fields(field_id)%station_id(i)
     index_x = stations(station_id)%local_i; index_y = stations(station_id)%local_j
     if(index_x>size(data,1) .or. index_y>size(data,2)) &
          call error_mesg ('send_station_data','local index out of range for field '// &
          output_fields(field_id)%output_name, FATAL) 
     if(output_fields(field_id)%time_average) then
        output_fields(field_id)%buffer(i,:) = output_fields(field_id)%buffer(i,:) + &
             data(index_x,index_y,:)                                          ! accumulate buffer 
     else                                                                     ! not average
        output_fields(field_id)%buffer(i,:) = data(index_x,index_y,:)
     endif
  enddo
  if(output_fields(field_id)%time_average) &
       output_fields(field_id)%counter = output_fields(field_id)%counter + 1
end subroutine send_station_data_3d
!------------------------------------------------------------------------

subroutine station_data_out(file, field, data, time,final_call_in)

  integer, intent(in)          :: file, field
  real, intent(inout)          :: data(:, :)
  type(time_type), intent(in)  :: time
  logical, optional, intent(in):: final_call_in
  logical                      :: final_call
  integer                      :: i, num
  real :: dif, time_data(2, 1, 1), dt_time(1, 1, 1), start_dif, end_dif

  final_call = .false.
  if(present(final_call_in)) final_call = final_call_in
  dif = get_date_dif(time, base_time, files(file)%time_units)
  call mpp_write(files(file)%file_unit,output_fields(field)%f_type, data, dif)
  start_dif = get_date_dif(output_fields(field)%last_output, base_time,files(file)%time_units)
  end_dif = dif
  do i = 1, files(file)%num_fields
     num = files(file)%fields(i)     
      if(output_fields(num)%time_ops) then
         if(num == field) then
            time_data(1, 1, 1) = start_dif
            call mpp_write(files(file)%file_unit, files(file)%f_avg_start, &
                 time_data(1:1,:,:), dif)
            time_data(2, 1, 1) = end_dif
            call mpp_write(files(file)%file_unit, files(file)%f_avg_end, &
                 time_data(2:2,:,:), dif)
            dt_time(1, 1, 1) = end_dif - start_dif
            call mpp_write(files(file)%file_unit, files(file)%f_avg_nitems, &
                 dt_time(1:1,:,:), dif)
! Include boundary variable for CF compliance
            call mpp_write(files(file)%file_unit, files(file)%f_bounds, &
                 time_data(1:2,:,:), dif)
            exit
         endif
      end if
   end do
   if(final_call) then
      if(time >= files(file)%last_flush) then
         call mpp_flush(files(file)%file_unit)
         files(file)%last_flush = time
      endif
   else
      if(time > files(file)%last_flush) then
         call mpp_flush(files(file)%file_unit)
         files(file)%last_flush = time
      endif
   endif
end subroutine station_data_out
! <INTERFACE NAME="station_data_end">
! <TEMPLATE>
! station_data_end(time)
! </TEMPLATE>
!   <DESCRIPTION>
! Must be called <TT> after the last time step</TT> to write the buffer content
!   </DESCRIPTION>
! </INTERFACE>


!-----------------------------------------------------------------------------
subroutine station_data_end(time)

  type(time_type), intent(in) :: time            !model's time
  integer                     :: freq, max_counter, local_num_stations
  integer                     :: file, nfield, field, pe, col
  integer, allocatable        :: station_ids(:)  ! root_pe only,  to receive local station_ids
  real,    allocatable        :: tmp_buffer(:,:) ! root_pe only, to receive local buffer from each PE

  do file = 1, num_files
     freq = files(file)%output_freq
     do nfield = 1, files(file)%num_fields
        field = files(file)%fields(nfield)
        if(.not. output_fields(field)%register) cycle
        if(time >= output_fields(field)%next_output .or. freq == END_OF_RUN) then
! ALL PEs, including root PE, must send data to root PE        
           call mpp_send(output_fields(field)%num_station,plen=1,to_pe=mpp_root_pe())
           if(output_fields(field)%num_station > 0) then
              call mpp_send(output_fields(field)%station_id(1),plen=size(output_fields(field)%station_id),&
                   to_pe=mpp_root_pe())
              call mpp_send(output_fields(field)%buffer(1,1),plen=size(output_fields(field)%buffer),&
                   to_pe=mpp_root_pe())
           endif
! get max_counter if the field is averaged
           if(output_fields(field)%time_average) then
              max_counter = output_fields(field)%counter
              call mpp_max(max_counter, pelist)
           endif
! only root PE receives local data from all PEs 
           if(mpp_pe() == mpp_root_pe()) then
              do pe = 1,size(pelist)           
                 call mpp_recv(local_num_stations,glen=1,from_pe=pelist(pe))
                 if(local_num_stations> 0) then
                    allocate(station_ids(local_num_stations))
                    allocate(tmp_buffer(local_num_stations,output_fields(field)%nlevel))
                    call mpp_recv(station_ids(1), glen=size(station_ids), from_pe=pelist(pe))
                    call mpp_recv(tmp_buffer(1,1),glen=size(tmp_buffer),from_pe=pelist(pe)) 
                    do col = 1,local_num_stations
                       global_field%buffer(station_ids(col),:) = tmp_buffer(col,:)
                    enddo
                    deallocate(station_ids, tmp_buffer)
                 endif
              enddo
! send global_buffer content to file
              if(output_fields(field)%time_average)then           
                 if(max_counter == 0 )&
                      call error_mesg ('send_station_end','counter=0 for averaged field '// &
                      output_fields(field)%output_name, FATAL)
                 global_field%buffer = global_field%buffer/real(max_counter)
              endif
! check if global_field contains any missing values
              if(any(global_field%buffer == MISSING)) &
                   call error_mesg ('send_station_end','Global_field contains MISSING, field '// &
                   output_fields(field)%output_name, FATAL)              
              call station_data_out(file,field,global_field%buffer,output_fields(field)%next_output,.true.)
              global_field%buffer = MISSING
           endif
           call mpp_sync()
        endif
!deallocate field buffer
        if(output_fields(field)%num_station>0) &
             deallocate(output_fields(field)%buffer, output_fields(field)%station_id)
     enddo ! nfield
  enddo    ! file
  if(mpp_pe() == mpp_root_pe()) deallocate(global_field%buffer)
end subroutine station_data_end
!-----------------------------------------------------------------------------------

end module station_data_mod





module time_interp_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Computes a weight and dates/indices for linearly interpolating between two dates.
! </OVERVIEW>

! <DESCRIPTION>
!     A time type is converted into two consecutive dates plus
!     a fraction representing the distance between the dates.
!     This information can be used to interpolate between the dates.
!     The dates may be expressed as years, months, or days or
!     as indices in an array.
! </DESCRIPTION>

! <PUBLIC>
!   Description summarizing public interface.
! </PUBLIC>

!-----------------------------------------------------------------------

use time_manager_mod, only: time_type, get_date, set_date, set_time, &
                            days_in_year, days_in_month, leap_year,  &
                            time_type_to_real, real_to_time_type,    &
                            get_calendar_type, JULIAN, GREGORIAN, NO_CALENDAR, &
                            operator(+), operator(-), operator(>),   &
                            operator(<), operator( // ), operator( / ),  &
                            operator(>=), operator(<=), operator( * ), &
                            operator(==), print_date, print_time

use          fms_mod, only: write_version_number, &
                            error_mesg, FATAL, stdout, stdlog, &
                            open_namelist_file, close_file, check_nml_error
use          mpp_mod, only: input_nml_file

implicit none
private

!-----------------------------------------------------------------------

public :: time_interp_init, time_interp, fraction_of_year

! <INTERFACE NAME="time_interp">

!   <OVERVIEW>
!      Returns a weight and dates or indices for interpolating between two dates. The
!      interface fraction_of_year is provided for backward compatibility with the
!      previous version. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns weight by interpolating Time between Time1 and Time2.
!      i.e. weight = (Time-Time1)/(Time2-Time1)
!      Time1 and Time2 may be specified by any of several different ways,
!      which is the reason for multiple interfaces.

!      If Time1 and Time2 are the begining and end of the year in which
!      Time falls, use first interface.

!      If Time1 and Time2 fall on year boundaries, use second interface.

!      If Time1 and Time2 fall on month boundaries, use third.

!      If Time1 and Time2 fall on day boundaries, use fourth.

!      If Time1 and Time2 are consecutive elements of an assending list, use fifth.
!      The fifth also returns the indices of Timelist between which Time falls.

!      The sixth interface is for cyclical data. Time_beg and Time_end specify the
!      begining and end of a repeating period. In this case:
!      weight = (Time_adjusted - Time1) / (Time2 - Time1)
!      Where:
!      Time1 = Timelist(index1)
!      Time2 = Timelist(index2)
!      Time_adjusted = Time - N*Period
!      Period = Time_end-Time_beg
!      N is between (Time-Time_end)/Period and (Time-Time_beg)/Period
!      That is, N is the integer that results in Time_adjusted that is between Time_beg and Time_end.
!      
!   </DESCRIPTION>
!   <TEMPLATE>
!     1. call time_interp( Time, weight )
!   </TEMPLATE>
!   <TEMPLATE>
!     2. call time_interp( Time, weight, year1, year2 )
!   </TEMPLATE>
!   <TEMPLATE>
!     3. call time_interp( Time, weight, year1, year2, month1, month2 )
!   </TEMPLATE>
!   <TEMPLATE>
!     4. call time_interp( Time, weight, year1, year2, month1, month2, day1, day2 )
!   </TEMPLATE>
!   <TEMPLATE>
!     5. call time_interp( Time, Timelist, weight, index1, index2 [, modtime] )
!   </TEMPLATE>
!   <TEMPLATE>
!     6. call time_interp( Time, Time_beg, Time_end, Timelist, weight, index1, index2 [,correct_leap_year_inconsistency])
!   </TEMPLATE>
!   <IN NAME="Time">
!      The time at which the the weight is computed.
!   </IN>
!   <IN NAME="Time_beg">
!      For cyclical interpolation: Time_beg specifies the begining time of a cycle.
!   </IN>
!   <IN NAME="Time_end">
!      For cyclical interpolation: Time_end specifies the ending time of a cycle.
!   </IN>
!   <IN NAME="Timelist">
!      For cyclical interpolation: Timelist is an array of times between Time_beg and Time_end.
!                                  Must be monotonically increasing.
!   </IN>
!   <IN NAME="modtime">
!   </IN>
!   <IN NAME="index1">
!      Timelist(index1) = The largest value of Timelist which is less than mod(Time,Time_end-Time_beg)
!   </IN>
!   <IN NAME="index2">
!      Timelist(index2) = The smallest value of Timelist which is greater than mod(Time,Time_end-Time_beg)
!   </IN>
!   <IN NAME="correct_leap_year_inconsistency">
!       Turns on a kluge for an inconsistency which may occur in a special case.
!       When the modulo time period (i.e. Time_end - Time_beg) is a whole number of years
!       and is not a multiple of 4, and the calendar in use has leap years, then it is
!       likely that the interpolation will involve mapping a common year onto a leap year.
!       In this case it is often desirable, but not absolutely necessary, to use data for
!       Feb 28 of the leap year when it is mapped onto a common year.
!       To turn this on, set correct_leap_year_inconsistency=.true.
!   </IN>
!   <OUT NAME="weight">
!     weight = (mod(Time,Time_end-Time_beg) - Timelist(index1)) / (Timelist(index2) - Timelist(index1))
!   </OUT>
!   <OUT NAME="year1"> </OUT>
!   <OUT NAME="year2"> </OUT>
!   <OUT NAME="month1"> </OUT>
!   <OUT NAME="month2"> </OUT>
!   <OUT NAME="day1"> </OUT>
!   <OUT NAME="day2"> </OUT>
!   <OUT NAME="index1"> </OUT>
!   <OUT NAME="index2"> </OUT>
!   <ERROR MSG="input time list not ascending order" STATUS="ERROR">
!     The list of input time types must have ascending dates.
!   </ERROR>
!   <ERROR MSG="modulo months must have same length" STATUS="ERROR">
!     The length of the current month for input Time and Time_list
!     must be the same when using the modulo month option. The
!     modulo month option is available but not supported. 
!   </ERROR>
!   <ERROR MSG="invalid value for argument modtime" STATUS="ERROR">
!     The optional argument modtime must have a value set by one
!     of the public parameters: NONE, YEAR, MONTH, DAY. The
!     MONTH and DAY options are available but not supported. 
!   </ERROR>
!   <ERROR MSG="period of list exceeds modulo period" STATUS="ERROR">
!     The difference between the last and first values in the input
!     Time list/array exceeds the length of the modulo period.
!   </ERROR>
!   <ERROR MSG="time before range of list or time after range of list" STATUS="ERROR">
!     The difference between the last and first values in the input
!     These errors occur when you are not using a modulo axis and
!     the input Time occurs before the first value in the Time
!     list/array or after the last value in the Time list/array. 
!   </ERROR>
!   <NOTE>
!     Examples: 
!     <PRE>
!       Time: Jan 01 00z    weight = 0.0 
!       Time: Jul 01        weight ~ 0.5 
!       Time: Dec 31 23z    weight ~ 1.0
!     </PRE>
!   </NOTE>

interface time_interp
    module procedure time_interp_frac,  time_interp_year, &
                     time_interp_month, time_interp_day,  &
                     time_interp_list,  time_interp_modulo
end interface
! </INTERFACE>

integer, public, parameter :: NONE=0, YEAR=1, MONTH=2, DAY=3

!-----------------------------------------------------------------------

   integer, parameter ::  secmin = 60, minhour = 60, hourday = 24,  &
                         sechour = secmin*minhour,                  &
                          secday = secmin*minhour*hourday

   integer, parameter :: monyear = 12
   integer, parameter :: halfday = secday/2

   integer :: yrmod, momod, dymod
   logical :: mod_leapyear

   character(len=128) :: version='$Id: time_interp.F90,v 18.0.4.1 2010/08/31 14:29:06 z1l Exp $'
   character(len=128) :: tagname='$Name: hiram_20101115_bw $'

   logical :: module_is_initialized=.FALSE.
   logical :: perthlike_behavior=.FALSE.

   namelist / time_interp_nml / perthlike_behavior

contains


 subroutine time_interp_init()
   integer :: ierr, io, namelist_unit, logunit

   if ( module_is_initialized ) return

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, time_interp_nml, iostat=io)
#else
   namelist_unit = open_namelist_file()
   ierr=1
   do while (ierr /= 0)
     read(namelist_unit, nml=time_interp_nml, iostat=io, end=20)
     ierr = check_nml_error (io, 'time_interp_nml')
   enddo
   20 call close_file (namelist_unit)
#endif

   call write_version_number( version, tagname )
   logunit = stdlog()
   write(logunit,time_interp_nml)

   module_is_initialized = .TRUE.

 end subroutine time_interp_init

!#######################################################################

! <SUBROUTINE NAME="time_interp_frac" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
! </SUBROUTINE>
!  returns the fractional time into the current year

 subroutine time_interp_frac ( Time, weight )

   type(time_type), intent(in)  :: Time 
   real           , intent(out) :: weight

   integer         :: year, month, day, hour, minute, second
   type(time_type) :: Year_beg, Year_end


   if ( .not. module_is_initialized ) call time_interp_init

!  ---- compute fractional time of year -----

     call get_date (Time, year, month, day, hour, minute, second) 

     Year_beg = set_date(year  , 1, 1) 
     Year_end = set_date(year+1, 1, 1)

     weight = (Time - Year_beg) // (Year_end - Year_beg)

 end subroutine time_interp_frac

!#######################################################################
! <SUBROUTINE NAME="fraction_of_year">
! <OVERVIEW>
!  Wrapper for backward compatibility
! </OVERVIEW>
! </SUBROUTINE>

 function fraction_of_year (Time)
 type(time_type), intent(in)  :: Time
 real :: fraction_of_year

  call time_interp_frac ( Time, fraction_of_year )

 end function fraction_of_year

!#######################################################################
! <SUBROUTINE NAME="time_interp_year" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="year1" TYPE="integer"> </OUT>
!   <OUT NAME="year2" TYPE="integer"> </OUT>
! </SUBROUTINE>
!  returns fractional time between mid points of consecutive years

 subroutine time_interp_year ( Time, weight, year1, year2 )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight
   integer        , intent(out) :: year1, year2

   integer :: year, month, day, hour, minute, second
   type (time_type) :: Mid_year, Mid_year1, Mid_year2


   if ( .not. module_is_initialized ) call time_interp_init()

      call get_date (Time, year, month, day, hour, minute, second)

    ! mid point of current year
      Mid_year = year_midpt(year)

      if ( Time >= Mid_year ) then
    ! current time is after mid point of current year
           year1  = year
           year2  = year+1
           Mid_year2 = year_midpt(year2)
           weight = (Time - Mid_year) // (Mid_year2 - Mid_year)
      else
    ! current time is before mid point of current year
           year2  = year
           year1  = year-1
           Mid_year1 = year_midpt(year1)
           weight = (Time - Mid_year1) // (Mid_year - Mid_year1)
      endif

 end subroutine time_interp_year

!#######################################################################
! <SUBROUTINE NAME="time_interp_month" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="year1" TYPE="integer"> </OUT>
!   <OUT NAME="year2" TYPE="integer"> </OUT>
!   <OUT NAME="month1" TYPE="integer"> </OUT>
!   <OUT NAME="month2" TYPE="integer"> </OUT>
! </SUBROUTINE>
!  returns fractional time between mid points of consecutive months

 subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight
   integer        , intent(out) :: year1, year2, month1, month2

   integer :: year, month, day, hour, minute, second,  &
              mid_month, cur_month, mid1, mid2

   if ( .not. module_is_initialized ) call time_interp_init()

      call get_date (Time, year, month, day, hour, minute, second)

    ! mid point of current month in seconds
      mid_month = days_in_month(Time) * halfday
    ! time into current month in seconds
      cur_month = second + secmin*minute + sechour*hour + secday*(day-1)

      if ( cur_month >= mid_month ) then
    ! current time is after mid point of current month
           year1  = year;  month1 = month
           year2  = year;  month2 = month+1
           if (month2 > monyear)  year2 = year2+1
           if (month2 > monyear) month2 = 1
           mid1 = mid_month
           mid2 = days_in_month(set_date(year2,month2,2)) * halfday
           weight = real(cur_month - mid1) / real(mid1+mid2)
      else
    ! current time is before mid point of current month
           year2  = year;  month2 = month
           year1  = year;  month1 = month-1
           if (month1 < 1)  year1 = year1-1
           if (month1 < 1) month1 = monyear
           mid1 = days_in_month(set_date(year1,month1,2)) * halfday
           mid2 = mid_month
           weight = real(cur_month + mid1) / real(mid1+mid2)
      endif

 end subroutine time_interp_month

!#######################################################################
! <SUBROUTINE NAME="time_interp_day" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="year1" TYPE="integer"> </OUT>
!   <OUT NAME="year2" TYPE="integer"> </OUT>
!   <OUT NAME="month1" TYPE="integer"> </OUT>
!   <OUT NAME="month2" TYPE="integer"> </OUT>
!   <OUT NAME="day1" TYPE="integer"> </OUT>
!   <OUT NAME="day2" TYPE="integer"> </OUT>
! </SUBROUTINE>
!  returns fractional time between mid points of consecutive days

 subroutine time_interp_day ( Time, weight, year1, year2, month1, month2, day1, day2 )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight
   integer        , intent(out) :: year1, year2, month1, month2, day1, day2

   integer :: year, month, day, hour, minute, second, sday

   if ( .not. module_is_initialized ) call time_interp_init()

      call get_date (Time, year, month, day, hour, minute, second)

    ! time into current day in seconds
      sday = second + secmin*minute + sechour*hour

      if ( sday >= halfday ) then
    ! current time is after mid point of day
           year1 = year;  month1 = month;  day1 = day
           year2 = year;  month2 = month;  day2 = day + 1
           weight  = real(sday - halfday) / real(secday)

           if (day2 > days_in_month(Time)) then
               month2 = month2 + 1
               day2 = 1
               if (month2 > monyear) then
                    month2 = 1;  year2 = year2+1
               endif
           endif
      else
    ! current time is before mid point of day
           year2 = year;  month2 = month;  day2 = day
           year1 = year;  month1 = month;  day1 = day - 1
           weight  = real(sday + halfday) / real(secday)

           if (day1 < 1) then
               month1 = month1 - 1
               if (month1 < 1) then
                   month1 = monyear;  year1 = year1-1
               endif
               day1 = days_in_month(set_date(year1,month1,2))
           endif
      endif

 end subroutine time_interp_day

!#######################################################################
! <SUBROUTINE NAME="time_interp_modulo" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <IN NAME="Time_beg" TYPE="time_type"> </IN>
!   <IN NAME="Time_end" TYPE="time_type"> </IN>
!   <IN NAME="Timelist" TYPE="time_type" DIM="(:)"> </IN>
!   <IN NAME="correct_leap_year_inconsistency" TYPE="logical, optional" DEFAULT=".false.">
!       Turns on a kluge for an inconsistency which may occur in a special case.
!       When the modulo time period (i.e. Time_end - Time_beg) is a whole number of years
!       and is not a multiple of 4, and the calendar in use has leap years, then it is
!       likely that the interpolation will involve mapping a common year onto a leap year.
!       In this case it is often desirable, but not absolutely necessary, to use data for
!       Feb 28 of the leap year when it is mapped onto a common year.
!       To turn this on, set correct_leap_year_inconsistency=.true. </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="index1" TYPE="real"> </OUT>
!   <OUT NAME="index2" TYPE="real"> </OUT>
! </SUBROUTINE>

subroutine time_interp_modulo(Time, Time_beg, Time_end, Timelist, weight, index1, index2, &
                              correct_leap_year_inconsistency)
type(time_type), intent(in)  :: Time, Time_beg, Time_end, Timelist(:)
real           , intent(out) :: weight
integer        , intent(out) :: index1, index2
logical, intent(in), optional :: correct_leap_year_inconsistency
  
  type(time_type) :: Period, T
  integer :: is, ie,i1,i2
  integer :: ys,ms,ds,hs,mins,ss ! components of the starting date
  integer :: ye,me,de,he,mine,se ! components of the ending date
  integer :: yt,mt,dt,ht,mint,st ! components of the current date
  integer :: dt1                 ! temporary value for day 
  integer :: n                   ! size of Timelist
  integer :: stdoutunit
  logical :: correct_lyr, calendar_has_leap_years, do_the_lyr_correction

  if ( .not. module_is_initialized ) call time_interp_init
  stdoutunit = stdout()
  n = size(Timelist)
  
  if (Time_beg>=Time_end) then
     call error_handler("end of the specified time loop interval must be later than its beginning")
  endif

  calendar_has_leap_years = (get_calendar_type() == JULIAN .or. get_calendar_type() == GREGORIAN)
  
  Period = Time_end-Time_beg ! period of the time axis

  if(present(correct_leap_year_inconsistency)) then
    correct_lyr = correct_leap_year_inconsistency
  else
    correct_lyr = .false.
  endif
  
  ! bring the requested time inside the specified time period
  T = Time

  do_the_lyr_correction = .false.

  ! Determine if the leap year correction needs to be done.
  ! It never needs to be done unless 3 conditions are met:
  ! 1) We are using a calendar with leap years
  ! 2) optional argument correct_leap_year_inconsistency is present and equals .true.
  ! 3) The modulo time period is an integer number of years
  ! If all of these are true then set do_the_lyr_correction to .true.

  if(calendar_has_leap_years .and. correct_lyr) then
    call get_date(Time_beg,ys,ms,ds,hs,mins,ss)
    call get_date(Time_end,ye,me,de,he,mine,se)
    if(ms==me.and.ds==de.and.hs==he.and.mins==mine.and.ss==se) then
      ! whole number of years
      do_the_lyr_correction = .true.
    endif
  endif

  if(do_the_lyr_correction) then
     call get_date(T,yt,mt,dt,ht,mint,st)
     yt = ys+modulo(yt-ys,ye-ys)
     dt1 = dt
     ! If it is Feb 29, but we map into a common year, use Feb 28
     if(mt==2.and.dt==29.and..not.leap_year(set_date(yt,1,1))) dt1=28
     T = set_date(yt,mt,dt1,ht,mint,st)
     if (T < Time_beg) then
       ! the requested time is within the first year, 
       ! but before the starting date. So we shift it to the last year.
       if(mt==2.and.dt==29.and..not.leap_year(set_date(ye,1,1))) dt=28
       T = set_date(ye,mt,dt,ht,mint,st)
     endif
  else
     do while ( T >= Time_end )
        T = T-Period
     enddo
     do while ( T < Time_beg )
        T = T+Period
     enddo
  endif
  
  ! find indices of the first and last records in the Timelist that are within 
  ! the requested time period.
  if (Time_end<=Timelist(1).or.Time_beg>=Timelist(n)) then
     if(get_calendar_type() == NO_CALENDAR) then
       call print_time(Time_beg,    'Time_beg'    )
       call print_time(Time_end,    'Time_end'    )
       call print_time(Timelist(1), 'Timelist(1)' )
       call print_time(Timelist(n), 'Timelist(n)' )
     else
       call print_date(Time_beg,    'Time_beg'    )
       call print_date(Time_end,    'Time_end'    )
       call print_date(Timelist(1), 'Timelist(1)' )
       call print_date(Timelist(n), 'Timelist(n)' )
     endif
     write(stdoutunit,*)'where n = size(Timelist) =',n
     call error_handler('the entire time list is outside the specified time loop interval')
  endif
  
  call bisect(Timelist,Time_beg,index1=i1,index2=i2)
  if (i1 < 1) then
     is = 1 ! Time_beg before lower boundary
  else if (Time_beg == Timelist(i1)) then
     is = i1 ! Time_beg right on the lower boundary
  else
     is = i2 ! Time_beg inside the interval or on upper boundary
  endif
  call bisect(Timelist,Time_end,index1=i1,index2=i2)
  if (Time_end > Timelist(i1)) then
    ie = i1
  else if (Time_end == Timelist(i1)) then
    if(Time_beg == Timelist(is)) then
      ! Timelist includes time levels at both the lower and upper ends of the period.
      ! The endpoints of Timelist specify the same point in the cycle.
      ! This ambiguity is resolved by ignoring the last time level.
      ie = i1-1
    else
      ie = i1
    endif
  else
!   This should never happen because bisect does not return i1 such that Time_end < Timelist(i1)
  endif
  if (is>=ie) then
     if(get_calendar_type() == NO_CALENDAR) then
       call print_time(Time_beg,    'Time_beg   =')
       call print_time(Time_end,    'Time_end   =')
       call print_time(Timelist(1), 'Timelist(1)=')
       call print_time(Timelist(n), 'Timelist(n)=')
     else
       call print_date(Time_beg,    'Time_beg   =')
       call print_date(Time_end,    'Time_end   =')
       call print_date(Timelist(1), 'Timelist(1)=')
       call print_date(Timelist(n), 'Timelist(n)=')
     endif
     write(stdoutunit,*)'where n = size(Timelist) =',n
     write(stdoutunit,*)'is =',is,'ie =',ie
     call error_handler('error in calculation of time list bounds within the specified time loop interval')
  endif
  
  ! handle special cases:
  if( T>=Timelist(ie) ) then
     ! time is after the end of the portion of the time list within the requested period
     index1 = ie;   index2 = is
     weight = (T-Timelist(ie))//(Period-(Timelist(ie)-Timelist(is)))
  else if (T<Timelist(is)) then
     ! time is before the beginning of the portion of the time list within the requested period
     index1 = ie;   index2 = is
     weight = 1.0-((Timelist(is)-T)//(Period-(Timelist(ie)-Timelist(is))))
  else
     call bisect(Timelist,T,index1,index2)
     weight = (T-Timelist(index1)) // (Timelist(index2)-Timelist(index1))
  endif

end subroutine time_interp_modulo

!#######################################################################
! given an array of times in ascending order and a specific time returns
! values of index1 and index2 such that the Timelist(index1)<=Time and
! Time<=Timelist(index2), and index2=index1+1
! index1=0, index2=1 or index=n, index2=n+1 are returned to indicate that 
! the time is out of range
subroutine bisect(Timelist,Time,index1,index2)
  type(time_type)  , intent(in)  :: Timelist(:)
  type(time_type)  , intent(in)  :: Time
  integer, optional, intent(out) :: index1, index2

  integer :: i,il,iu,n,i1,i2

  n = size(Timelist(:))
  
  if (Time==Timelist(1)) then
     i1 = 1 ; i2 = 2
  else if (Time==Timelist(n)) then
     i1 = n ; i2 = n+1
  else
     il = 0; iu=n+1
     do while(iu-il > 1)
        i = (iu+il)/2
        if(Timelist(i) > Time) then
           iu = i
        else
           il = i
        endif
     enddo
     i1 = il ; i2 = il+1
  endif

  if(PRESENT(index1)) index1 = i1
  if(PRESENT(index2)) index2 = i2
end subroutine bisect


!#######################################################################
! <SUBROUTINE NAME="time_interp_list" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <IN NAME="Timelist" TYPE="time_type" DIM="(:)"> </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="index1" TYPE="real"> </OUT>
!   <OUT NAME="index2" TYPE="real"> </OUT>
!   <IN NAME="modtime" TYPE="integer" > </IN>
! </SUBROUTINE>

subroutine time_interp_list ( Time, Timelist, weight, index1, index2, modtime )
type(time_type)  , intent(in)  :: Time, Timelist(:)
real             , intent(out) :: weight
integer          , intent(out) :: index1, index2
integer, optional, intent(in)  :: modtime

integer :: n, hr, mn, se, mtime
type(time_type) :: T, Ts, Te, Td, Period, Time_mod

  if ( .not. module_is_initialized ) call time_interp_init

  weight = 0.; index1 = 0; index2 = 0
  n = size(Timelist(:))

! setup modular time axis?
  mtime = NONE
  if (present(modtime)) then
     mtime = modtime
     Time_mod = (Timelist(1)+Timelist(n))/2
     call get_date (Time_mod, yrmod, momod, dymod, hr, mn, se)
     mod_leapyear = leap_year(Time_mod)
  endif

! set period for modulo axis
  select case (mtime)
     case (NONE)
       ! do nothing
     case (YEAR)
         Period = set_time(0,days_in_year(Time_mod))
     case (MONTH)
       ! month length must be equal
         if (days_in_month(Time_mod) /= days_in_month(Time)) &
         call error_handler ('modulo months must have same length')
         Period = set_time(0,days_in_month(Time_mod))
     case (DAY)
         Period = set_time(0,1)
     case default
         call error_handler ('invalid value for argument modtime')
  end select

! If modulo time is in effect and Timelist spans a time interval exactly equal to 
! the modulo period, then the endpoints of Timelist specify the same point in the cycle.
! This ambiguity is resolved by ignoring the last time level.
  if (mtime /= NONE .and. Timelist(size(Timelist))-Timelist(1) == Period) then
     n = size(Timelist) - 1
  else
     n = size(Timelist)
  endif

! starting and ending times from list
  Ts = Timelist(1)
  Te = Timelist(n)
  Td = Te-Ts
  T  = set_modtime(Time,mtime)

! Check that Timelist does not span a time interval greater than the modulo period
  if (mtime /= NONE) then
     if (Td > Period) call error_handler ('period of list exceeds modulo period')
  endif

! time falls on start or between start and end list values
  if ( T >= Ts .and. T < Te ) then
     call bisect(Timelist(1:n),T,index1,index2)
     weight = (T-Timelist(index1)) // (Timelist(index2)-Timelist(index1))

! time falls before starting list value
  else if ( T < Ts ) then
     if (mtime == NONE) call error_handler ('time before range of list')
     Td = Te-Ts
     weight = 1. - ((Ts-T) // (Period-Td))
     index1 = n
     index2 = 1

! time falls on ending list value
  else if ( T == Te ) then
    if(perthlike_behavior) then
       weight = 1.0
       index1 = n-1
       index2 = n
    else
       weight = 0.
       index1 = n
       if (mtime == NONE) then
         index2 = n
       else
         index2 = 1
       endif
    endif

! time falls after ending list value
  else if ( T > Te ) then
     if (mtime == NONE) call error_handler ('time after range of list')
     Td = Te-Ts
     weight = (T-Te) // (Period-Td)
     index1 = n
     index2 = 1
  endif

end subroutine time_interp_list

!#######################################################################
!  private routines
!#######################################################################

 function year_midpt (year)

   integer, intent(in) :: year
   type (time_type)    :: year_midpt, year_beg, year_end


   year_beg = set_date(year  , 1, 1)
   year_end = set_date(year+1, 1, 1)

   year_midpt = (year_beg + year_end) / 2
   
 end function year_midpt

!#######################################################################

 function month_midpt (year, month)

   integer, intent(in) :: year, month
   type (time_type)    :: month_midpt, month_beg, month_end

!  --- beginning of this month ---
   month_beg = set_date(year, month, 1)

!  --- start of next month ---
   if (month < 12) then
      month_end = set_date(year, month+1, 1)
   else
      month_end = set_date(year+1, 1, 1)
   endif

   month_midpt = (month_beg + month_end) / 2
   
 end function month_midpt

!#######################################################################

function set_modtime (Tin, modtime) result (Tout)
type(time_type), intent(in) :: Tin
integer, intent(in), optional :: modtime
type(time_type)             :: Tout
integer :: yr, mo, dy, hr, mn, se, mtime

  if(present(modtime)) then
    mtime = modtime
  else
    mtime = NONE
  endif

  select case (mtime)
    case (NONE)
       Tout = Tin
    case (YEAR)
       call get_date (Tin, yr, mo, dy, hr, mn, se)
       yr = yrmod
        ! correct leap year dates
          if (.not.mod_leapyear .and. mo == 2 .and. dy > 28) then
             mo = 3; dy = dy-28
          endif
       Tout = set_date (yr, mo, dy, hr, mn, se)
    case (MONTH)
       call get_date (Tin, yr, mo, dy, hr, mn, se)
       yr = yrmod; mo = momod
       Tout = set_date (yr, mo, dy, hr, mn, se)
    case (DAY)
       call get_date (Tin, yr, mo, dy, hr, mn, se)
       yr = yrmod; mo = momod; dy = dymod
       Tout = set_date (yr, mo, dy, hr, mn, se)
  end select

end function set_modtime

!#######################################################################

subroutine error_handler (string)
character(len=*), intent(in) :: string

  call error_mesg ('time_interp_mod', trim(string), FATAL)

! write (*,'(a)') 'ERROR in time_interp: ' // trim(string)
! stop 111

end subroutine error_handler

!#######################################################################

end module time_interp_mod

! <INFO>

!   <ERROR MSG="input time list not ascending order" STATUS="">
!     The list of input time types must have ascending dates.
!   </ERROR> *
!   <ERROR MSG="modulo months must have same length" STATUS="">
!     The length of the current month for input Time and Time_list
!     must be the same when using the modulo month option.
!     The modulo month option is available but not supported.
!   </ERROR> *
!   <ERROR MSG="invalid value for argument modtime" STATUS="">
!     The optional argument modtime must have a value set by one
!     of the public parameters: NONE, YEAR, MONTH, DAY.
!     The MONTH and DAY options are available but not supported.
!   </ERROR> *
!   <ERROR MSG="period of list exceeds modulo period" STATUS="">
!     The difference between the last and first values in the
!     input Time list/array exceeds the length of the modulo period.
!   </ERROR> *
!   <ERROR MSG="time before range of list or time after range of list" STATUS="">
!     These errors occur when you are not using a modulo axis and the
!     input Time occurs before the first value in the Time list/array
!     or after the last value in the Time list/array.
!   </ERROR> *
!   <NOTE>
!   For all routines in this module the calendar type in module
!   time_manager must be set.
!   </NOTE>
!   <NOTE>
!     The following private parameters are set by this module:
! <PRE>
!           seconds per minute = 60
!           minutes per hour   = 60
!           hours   per day    = 24
!           months  per year   = 12
! </PRE>
!   </NOTE>

! </INFO>

#ifdef test_time_interp_
 program test_time_interp
 use          fms_mod, only: fms_init, fms_end, stdout, stdlog, FATAL, mpp_error
 use time_manager_mod, only: get_date, set_time, set_date, time_manager_init, set_calendar_type, operator(+)
 use time_manager_mod, only: JULIAN, time_type, increment_time, NOLEAP, print_date
 use  time_interp_mod, only: time_interp_init, time_interp, NONE, YEAR, MONTH, DAY

 implicit none

 integer, parameter :: num_Time=6
 type(time_type) :: Time_beg, Time_end, Time(num_Time)
 type(time_type), allocatable, dimension(:) :: Timelist
 integer :: index1, index2, mo, yr, timelist_len, outunit, ntest, nline
 real :: weight

 integer :: nmin, nmax

 namelist / test_time_interp_nml / timelist_len

 call fms_init
 outunit = stdout()
 call set_calendar_type(JULIAN)
 call time_interp_init

 Time_beg = set_date(1, 1, 1)
 Time_end = set_date(2, 1, 1)
 Time(1) = Time_beg
 Time(2) = set_date(1, 1,16)
 Time(3) = set_date(1, 2, 1)
 Time(4) = set_date(1,12, 1)
 Time(5) = set_date(1,12,16)
 Time(6) = Time_end

! Tests with modulo time
 do nline=1,3
   if(nline == 1) then
     allocate(Timelist(12))
     do mo=1,12
       Timelist(mo) = set_date(1, mo, 1)
     enddo
   else if(nline == 2) then
     allocate(Timelist(13))
     do mo=1,12
       Timelist(mo) = set_date(1, mo, 1)
     enddo
     Timelist(13) = set_date(2, 1, 1)
   else if(nline == 3) then
     allocate(Timelist(12))
     do mo=2,12
       Timelist(mo-1) = set_date(1, mo, 1)
     enddo
     Timelist(12) = set_date(2, 1, 1)
   endif

   do ntest=1,num_Time
     call diagram(nline,ntest,modulo_time=.true.)
     call time_interp(Time(ntest), Time_beg, Time_end, Timelist, weight, index1, index2)
     write(outunit,*) 'time_interp_modulo:'
     write(outunit,'()')
     call print_date(Time(ntest),                'Time       =')
     call print_date(Time_beg,                   'Time_beg   =')
     call print_date(Time_end,                   'Time_end   =')
     call print_date(Timelist(1),                'Timelist(1)=')
     call print_date(Timelist(size(Timelist(:))),'Timelist(n)=')
     write(outunit,99) index1,index2,weight
     write(outunit,'()')

     call time_interp(Time(ntest), Timelist, weight, index1, index2, modtime=YEAR)
     write(outunit,*) 'time_interp_list with modtime=YEAR:'
     write(outunit,'()')
     call print_date(Time(ntest),                'Time       =')
     call print_date(Timelist(1),                'Timelist(1)=')
     call print_date(Timelist(size(Timelist(:))),'Timelist(n)=')
     write(outunit,99) index1,index2,weight
   enddo
   deallocate(Timelist)
 enddo

! Tests without modulo time
 do nline=1,3
   if(nline == 1) then
     allocate(Timelist(12))
     do mo=1,12
       Timelist(mo) = set_date(1, mo, 1)
     enddo
   else if(nline == 2) then
     allocate(Timelist(13))
     do mo=1,12
       Timelist(mo) = set_date(1, mo, 1)
     enddo
     Timelist(13) = set_date(2, 1, 1)
   else if(nline == 3) then
     allocate(Timelist(12))
     do mo=2,12
       Timelist(mo-1) = set_date(1, mo, 1)
     enddo
     Timelist(12) = set_date(2, 1, 1)
   endif

   if(nline == 1) then
     nmin = 1; nmax = 4
   else if(nline == 2) then
     nmin = 1; nmax = num_Time
   else if(nline == 3) then
     nmin = 3; nmax = num_Time
   endif
   do ntest=nmin,nmax
     call diagram(nline,ntest,modulo_time=.false.)
     call time_interp(Time(ntest), Timelist, weight, index1, index2, modtime=NONE)
     write(outunit,*) 'time_interp_list with modtime=NONE:'
     write(outunit,'()')
     call print_date(Time(ntest),                'Time       =')
     call print_date(Timelist(1),                'Timelist(1)=')
     call print_date(Timelist(size(Timelist(:))),'Timelist(n)=')
     write(outunit,99) index1,index2,weight
   enddo
   deallocate(Timelist)
 enddo

! More tests with modulo time
 Time_beg = set_date(1999, 1, 1)
 Time_end = set_date(2000, 1, 1)
 Time(1)  = set_date(1998, 1, 1)
 Time(2)  = set_date(1998, 2,28)
 Time(3)  = set_date(1998,12,16)
 Time(4)  = set_date(2000, 1, 1)
 Time(5)  = set_date(2000, 2,28)
 Time(6)  = set_date(2000, 2,29)

 allocate(Timelist(13))
 do mo=1,12
   Timelist(mo) = set_date(1999, mo, 1)
 enddo
 Timelist(13) = set_date(2000, 1, 1)

 write(outunit,'("<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>",/)')
 write(outunit,'()')
 write(outunit,*) 'time_interp_modulo with correct_leap_year_inconsistency=.true.'
 write(outunit,'()')
 write(outunit,'(" Jan 1 1999                                     Jan 1 2000")')
 write(outunit,'("    |                                               |")')
 write(outunit,'("    v                                               v")')
 write(outunit,'("    x---x---x---x---x---x---x---x---x---x---x---x---x")')
 write(outunit,'("    ^                                               ^")')
 write(outunit,'("    |                                               |")')
 write(outunit,'(" Time_beg                                        Time_end ")')
 write(outunit,'()')

 do ntest=1,num_Time
   call time_interp(Time(ntest), Time_beg, Time_end, Timelist, weight, index1, index2, correct_leap_year_inconsistency=.true.)
   call print_date(Time(ntest),' Time =')
   write(outunit,99) index1,index2,weight
   write(outunit,'()')
 enddo
 deallocate(Timelist)

! Tests of modulo time and leap year inconsistency
 Time_beg = set_date(1978, 1, 1)
 Time_end = set_date(1981, 1, 1)
 Time(1)  = set_date(1976, 2,28)
 Time(2)  = set_date(1976, 2,29)
 Time(3)  = set_date(1976, 3, 1)
 Time(4)  = set_date(1983, 2,28)
 Time(5)  = set_date(1983, 3, 1)
 Time(6)  = set_date(1981, 1, 1)
 allocate(Timelist(37))
 do yr=1978,1980
   do mo=1,12
     Timelist(12*(yr-1978)+mo) = set_date(yr, mo, 1)
   enddo
 enddo
 Timelist(37) = set_date(1981, 1, 1)

 write(outunit,'("<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>")')
 write(outunit,'()')
 write(outunit,*) 'time_interp_modulo with correct_leap_year_inconsistency=.true.'
 write(outunit,'()')
 write(outunit,'(" Jan 1 1978              Jan 1 1979              Jan 1 1980              Jan 1 1981")')
 write(outunit,'("     |                       |                       | <---- leap year ----> |")')
 write(outunit,'("     v                       v                       v                       v")')
 write(outunit,'("     x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x")')
 write(outunit,'("     ^                                                                       ^")')
 write(outunit,'("     |                                                                       |")')
 write(outunit,'("  Time_beg                                                               Time_end")')
 write(outunit,'()')

 do ntest=1,num_Time
   call time_interp(Time(ntest), Time_beg, Time_end, Timelist, weight, index1, index2, correct_leap_year_inconsistency=.true.)
   call print_date(Time(ntest),' Time=')
   write(outunit,99) index1,index2,weight
   write(outunit,'()')
 enddo
 deallocate(Timelist)

 allocate(Timelist(12))
 Timelist( 1) = set_date(1,  1, 16, hour=12) ! Jan midmonth
 Timelist( 2) = set_date(1,  2, 15, hour= 0) ! Feb midmonth (common year)
 Timelist( 3) = set_date(1,  3, 16, hour=12) ! Mar midmonth
 Timelist( 4) = set_date(1,  4, 16, hour= 0) ! Apr midmonth
 Timelist( 5) = set_date(1,  5, 16, hour=12) ! May midmonth
 Timelist( 6) = set_date(1,  6, 16, hour= 0) ! Jun midmonth
 Timelist( 7) = set_date(1,  7, 16, hour=12) ! Jul midmonth
 Timelist( 8) = set_date(1,  8, 16, hour=12) ! Aug midmonth
 Timelist( 9) = set_date(1,  9, 16, hour= 0) ! Sep midmonth
 Timelist(10) = set_date(1, 10, 16, hour=12) ! Oct midmonth
 Timelist(11) = set_date(1, 11, 16, hour= 0) ! Nov midmonth
 Timelist(12) = set_date(1, 12, 16, hour=12) ! Dec midmonth
 Time_beg = set_date(1, 1, 1)
 Time_end = set_date(2, 1, 1)
 call diagram(nline=4, ntest=0, modulo_time=.true.)
 do ntest=0,73
   Time(1) = set_date(1996, 1, 1) + set_time(seconds=0, days=5*ntest)
   call print_date(Time(1),' Time=')
   call time_interp(Time(1), Timelist, weight, index1, index2, modtime=YEAR)
   write(outunit,89) 'time_interp_list with modtime=YEAR:   ', index1,index2,weight
   call time_interp(Time(1), Time_beg, Time_end, Timelist, weight, index1, index2, correct_leap_year_inconsistency=.true.)
   write(outunit,89) 'time_interp_modulo: ', index1,index2,weight
   write(outunit,'()')
 enddo 

 99 format(' index1=',i3,'  index2=',i3,'  weight=',f18.15)
 89 format(a20,' index1=',i3,'  index2=',i3,'  weight=',f18.15)
 call fms_end

 contains

 subroutine diagram(nline,ntest,modulo_time)
 integer, intent(in) :: nline,ntest
 logical, intent(in) :: modulo_time

 write(outunit,'("<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>")')
 write(outunit,'()')
 if(modulo_time) then
   write(outunit,'(" Time_beg                                      Time_end")')
   write(outunit,'("  |                                               |")')
   write(outunit,'("  v                                               v")')
 endif

 if(nline == 1) then
   write(outunit,'("  x---x---x---x---x---x---x---x---x---x---x---x----")')
 else if(nline == 2) then
   write(outunit,'("  x---x---x---x---x---x---x---x---x---x---x---x---x")')
 else if(nline == 3) then
   write(outunit,'("  ----x---x---x---x---x---x---x---x---x---x---x---x")')
 else if(nline == 4) then
   write(outunit,'("  --x---x---x---x---x---x---x---x---x---x---x---x--")')
 endif

 if(ntest == 1) then
   write(outunit,'("  ^")  ')
   write(outunit,'("  |")  ')
   write(outunit,'(" Time")')
 else if(ntest == 2) then
   write(outunit,'("    ^")  ')
   write(outunit,'("    |")  ')
   write(outunit,'("   Time")')
 else if(ntest == 3) then
   write(outunit,'("      ^")  ')
   write(outunit,'("      |")  ')
   write(outunit,'("     Time")')
 else if(ntest == 4) then
   write(outunit,'("                                              ^")  ')
   write(outunit,'("                                              |")  ')
   write(outunit,'("                                             Time")')
 else if(ntest == 5) then
   write(outunit,'("                                                ^")  ')
   write(outunit,'("                                                |")  ')
   write(outunit,'("                                               Time")')
 else if(ntest == 6) then
   write(outunit,'("                                                  ^")  ')
   write(outunit,'("                                                  |")  ')
   write(outunit,'("                                                 Time")')
 endif
 write(outunit,'()')

 end subroutine diagram

 end program test_time_interp
#endif


#include  <fms_platform.h>

module time_interp_external_mod
!
!<CONTACT EMAIL="Matthew.Harrison@noaa.gov">M.J. Harrison</CONTACT>
!
!<REVIEWER EMAIL="hsimmons@iarc.uaf.edu">Harper Simmons</REVIEWER>
!
!<OVERVIEW>
! Perform I/O and time interpolation of external fields (contained in a file).
!</OVERVIEW>

!<DESCRIPTION>
! Perform I/O and time interpolation for external fields.
! Uses udunits library to calculate calendar dates and
! convert units.  Allows for reading data decomposed across
! model horizontal grid using optional domain2d argument
!
! data are defined over data domain for domain2d data
! (halo values are NOT updated by this module)
! 
!</DESCRIPTION>
!
!<NAMELIST NAME="time_interp_external_nml">
! <DATA NAME="num_io_buffers" TYPE="integer">
! size of record dimension for internal buffer.  This is useful for tuning i/o performance
! particularly for large datasets (e.g. daily flux fields)
! </DATA>
!</NAMELIST>

  use mpp_mod, only : mpp_error,FATAL,WARNING,mpp_pe, stdout, stdlog, NOTE
  use mpp_mod, only : input_nml_file
  use mpp_io_mod, only : mpp_open, mpp_get_atts, mpp_get_info, MPP_NETCDF, MPP_MULTI, MPP_SINGLE,&
       mpp_get_times, MPP_RDONLY, MPP_ASCII, default_axis,axistype,fieldtype,atttype, &
       mpp_get_axes, mpp_get_fields, mpp_read, default_field, mpp_close, &
       mpp_get_tavg_info, validtype, mpp_is_valid
  use time_manager_mod, only : time_type, get_date, set_date, operator ( >= ) , operator ( + ) , days_in_month, &
                            operator( - ), operator ( / ) , days_in_year, increment_time, &
                            set_time, get_time, operator( > ), get_calendar_type, NO_CALENDAR
  use get_cal_time_mod, only : get_cal_time
  use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, mpp_get_data_domain, &
       mpp_get_global_domain, NULL_DOMAIN2D
  use time_interp_mod, only : time_interp
  use axis_utils_mod, only : get_axis_cart, get_axis_modulo, get_axis_modulo_times
  use fms_mod, only : lowercase, open_namelist_file, check_nml_error, close_file
  use platform_mod, only: r8_kind
  use horiz_interp_mod, only : horiz_interp, horiz_interp_type

  implicit none
  private

  character(len=128), private :: version= &
   'CVS $Id: time_interp_external.F90,v 17.0.8.1.2.2 2010/09/08 21:00:16 wfc Exp $'
  character(len=128), private :: tagname='Tag $Name: hiram_20101115_bw $'

  integer, parameter, private :: max_fields = 1, modulo_year= 0001,max_files= 1
  integer, parameter, private :: LINEAR_TIME_INTERP = 1 ! not used currently
  integer, parameter, public  :: SUCCESS = 0, ERR_FIELD_NOT_FOUND = 1
  integer, private :: num_fields = 0, num_files=0
  ! denotes time intervals in file (interpreted from metadata)
  integer, private :: num_io_buffers = -1 ! set -1 to read all records from disk into memory 
  logical, private :: module_initialized = .false.
  logical, private :: debug_this_module = .false.

  public init_external_field, time_interp_external, time_interp_external_init, &
       time_interp_external_exit, get_external_field_size, get_time_axis

  private find_buf_index,&
         set_time_modulo

  type, private :: ext_fieldtype
     integer :: unit ! keep unit open when not reading all records
     character(len=128) :: name, units
     integer :: siz(4), ndim
     type(domain2d) :: domain
     type(axistype) :: axes(4)
     type(time_type), dimension(:), pointer :: time =>NULL() ! midpoint of time interval
     type(time_type), dimension(:), pointer :: start_time =>NULL(), end_time =>NULL()
     type(fieldtype) :: field ! mpp_io type
     type(time_type), dimension(:), pointer :: period =>NULL() 
     logical :: modulo_time ! denote climatological time axis
     real, dimension(:,:,:,:), pointer :: data =>NULL() ! defined over data domain or global domain
     logical, dimension(:,:,:,:), pointer :: mask =>NULL() ! defined over data domain or global domain
     integer, dimension(:), pointer :: ibuf  =>NULL() ! record numbers associated with buffers
     real, dimension(:,:,:), pointer :: buf3d  =>NULL() ! input data buffer
     type(validtype) :: valid ! data validator
     integer :: nbuf
     logical :: domain_present
     real(DOUBLE_KIND) :: slope, intercept
     integer :: isc,iec,jsc,jec
     type(time_type) :: modulo_time_beg, modulo_time_end
     logical :: have_modulo_times, correct_leap_year_inconsistency
  end type ext_fieldtype

  type, private :: filetype
     character(len=128) :: filename = ''
     integer :: unit = -1
  end type filetype

  interface time_interp_external
     module procedure time_interp_external_0d
     module procedure time_interp_external_2d
     module procedure time_interp_external_3d
  end interface

  type(ext_fieldtype), save, private, pointer :: field(:) => NULL()
  type(filetype),      save, private, pointer :: opened_files(:) => NULL()
!Balaji: really should use field%missing
  real(DOUBLE_KIND), private, parameter :: time_interp_missing=-1e99
  contains

! <SUBROUTINE NAME="time_interp_external_init">
!
! <DESCRIPTION>
! Initialize the time_interp_external module
! </DESCRIPTION>
!
    subroutine time_interp_external_init()

      integer :: ioun, io_status, logunit, ierr

      namelist /time_interp_external_nml/ num_io_buffers, debug_this_module

      ! open and read namelist

      if(module_initialized) return
      
      logunit = stdlog()
      write(logunit,'(/a/)') version
      write(logunit,'(/a/)') tagname

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, time_interp_external_nml, iostat=io_status)
      ierr = check_nml_error(io_status, 'time_interp_external_nml')
#else
      ioun = open_namelist_file ()
      ierr=1; do while (ierr /= 0)
      read  (ioun, nml=time_interp_external_nml, iostat=io_status, end=10)
      ierr = check_nml_error(io_status, 'time_interp_external_nml')
      enddo
10    call close_file (ioun)
#endif

      write(logunit,time_interp_external_nml)
      call realloc_fields(max_fields)
      call realloc_files(max_files)

      module_initialized = .true.

      return
      
    end  subroutine time_interp_external_init
! </SUBROUTINE> NAME="time_interp_external_init"


!<FUNCTION NAME="init_external_field" TYPE="integer">
!
!<DESCRIPTION>
! initialize an external field.  Buffer entire field to memory (default) or
! store "num_io_buffers" in memory to reduce memory allocations. 
! distributed reads are supported using the optional "domain" flag.  
! Units conversion via the optional "desired_units" flag using udunits_mod.
!
! Return integer id of field for future calls to time_interp_external.
!
! </DESCRIPTION>
!
!<IN  NAME="file" TYPE="character(len=*)">
! filename
!</IN>
!<IN  NAME="fieldname" TYPE="character(len=*)">
! fieldname (in file)
!</IN>
!<IN NAME="format" TYPE="integer">
! mpp_io flag for format of file (optional). Currently only "MPP_NETCDF" supported
!</IN>
!<IN NAME="threading" TYPE="integer">
! mpp_io flag for threading (optional).  "MPP_SINGLE" means root pe reads global field and distributes to other PEs
! "MPP_MULTI" means all PEs read data
!</IN>
!<IN NAME="domain" TYPE="mpp_domains_mod:domain2d">
! domain flag (optional)
!</IN>
!<IN NAME="desired_units" TYPE="character(len=*)">
! Target units for data (optional), e.g. convert from deg_K to deg_C.  
! Failure to convert using udunits will result in failure of this module.
!</IN>
!<IN NAME="verbose" TYPE="logical">
! verbose flag for debugging (optional).
!</IN>
!<INOUT NAME="axis_centers" TYPE="axistype" DIM="(4)">
! MPP_IO axistype array for grid centers ordered X-Y-Z-T (optional).
!</INOUT>
!<INOUT NAME="axis_sizes" TYPE="integer" DIM="(4)">
!  array of axis lengths ordered X-Y-Z-T (optional).
!</INOUT>


    function init_external_field(file,fieldname,format,threading,domain,desired_units,&
         verbose,axis_centers,axis_sizes,override,correct_leap_year_inconsistency,&
         permit_calendar_conversion,use_comp_domain,ierr)
      
      character(len=*), intent(in)            :: file,fieldname
      integer, intent(in), optional           :: format, threading
      logical, intent(in), optional           :: verbose 
      character(len=*), intent(in), optional  :: desired_units
      type(domain2d), intent(in), optional    :: domain
      type(axistype), intent(inout), optional :: axis_centers(4)
      integer, intent(inout), optional        :: axis_sizes(4)
      logical, intent(in), optional           :: override, correct_leap_year_inconsistency,&
           permit_calendar_conversion,use_comp_domain
      integer, intent(out), optional :: ierr
      
      integer :: init_external_field
      
      type(fieldtype), dimension(:), allocatable :: flds
      type(axistype), dimension(:), allocatable :: axes, fld_axes
      type(axistype) :: time_axis
      type(atttype), allocatable, dimension(:) :: global_atts
      
      real(DOUBLE_KIND) :: slope, intercept
      integer :: form, thread, fset, unit,ndim,nvar,natt,ntime,i,j, outunit
      integer :: iscomp,iecomp,jscomp,jecomp,isglobal,ieglobal,jsglobal,jeglobal
      integer :: isdata,iedata,jsdata,jedata, dxsize, dysize,dxsize_max,dysize_max
      logical :: verb, transpose_xy,use_comp_domain1
      real(KIND=r8_kind), dimension(:), allocatable :: tstamp, tstart, tend, tavg
      character(len=1) :: cart
      character(len=128) :: units, fld_units
      character(len=128) :: name, msg, calendar_type, timebeg, timeend
      integer :: siz(4), siz_in(4), gxsize, gysize,gxsize_max, gysize_max
      type(time_type) :: tdiff
      integer :: yr, mon, day, hr, minu, sec
      integer :: len, nfile, nfields_orig, nbuf, nx,ny

      if (.not. module_initialized) call mpp_error(FATAL,'Must call time_interp_external_init first')
      if(present(ierr)) ierr = SUCCESS
      use_comp_domain1 = .false.
      if(PRESENT(use_comp_domain)) use_comp_domain1 = use_comp_domain
      form=MPP_NETCDF
      if (PRESENT(format)) form = format
      thread = MPP_MULTI
      if (PRESENT(threading)) thread = threading
      fset = MPP_SINGLE
      verb=.false.
      if (PRESENT(verbose)) verb=verbose
      if (debug_this_module) verb = .true.
      units = 'same'
      if (PRESENT(desired_units)) then
          units = desired_units
          call mpp_error(FATAL,'==> Unit conversion via time_interp_external &
               &has been temporarily deprecated.  Previous versions of&
               &this module used udunits_mod to perform unit conversion.&
               &  Udunits_mod is in the process of being replaced since &
               &there were portability issues associated with this code.&
               & Please remove the desired_units argument from calls to &
               &this routine.')
      endif
      nfile = 0
      do i=1,num_files
         if(trim(opened_files(i)%filename) == trim(file)) then
            nfile = i
            exit  ! file is already opened
         endif
      enddo
      if(nfile == 0) then      
         call mpp_open(unit,trim(file),MPP_RDONLY,form,threading=thread,&
              fileset=fset)
         num_files = num_files + 1
         if(num_files > size(opened_files)) & ! not enough space in the file table, reallocate it
              call realloc_files(2*size(opened_files))
         opened_files(num_files)%filename = trim(file)
         opened_files(num_files)%unit = unit
      else
         unit = opened_files(nfile)%unit
      endif

      call mpp_get_info(unit,ndim,nvar,natt,ntime)
      
      if (ntime < 1) then
          write(msg,'(a15,a,a58)') 'external field ',trim(fieldname),&
           ' does not have an associated record dimension (REQUIRED) '
          call mpp_error(FATAL,trim(msg))
      endif       
      allocate(global_atts(natt))
      call mpp_get_atts(unit, global_atts)
      allocate(axes(ndim))
      call mpp_get_axes(unit, axes, time_axis)
      allocate(flds(nvar))
      call mpp_get_fields(unit,flds)
      allocate(tstamp(ntime),tstart(ntime),tend(ntime),tavg(ntime))
      call mpp_get_times(unit,tstamp)
      transpose_xy = .false.     
      isdata=1; iedata=1; jsdata=1; jedata=1
      gxsize=1; gysize=1
      siz_in = 1

      if (PRESENT(domain)) then
         call mpp_get_compute_domain(domain,iscomp,iecomp,jscomp,jecomp)
         nx = iecomp-iscomp+1; ny = jecomp-jscomp+1
         call mpp_get_data_domain(domain,isdata,iedata,jsdata,jedata,dxsize,dxsize_max,dysize,dysize_max)
         call mpp_get_global_domain(domain,isglobal,ieglobal,jsglobal,jeglobal,gxsize,gxsize_max,gysize,gysize_max)
      elseif(use_comp_domain1) then
         call mpp_error(FATAL,"init_external_field:"//&
              " use_comp_domain=true but domain is not present") 
      endif
      
      init_external_field = -1
      nfields_orig = num_fields

      outunit = stdout()
      do i=1,nvar
         call mpp_get_atts(flds(i),name=name,units=fld_units,ndim=ndim,siz=siz_in)
         call mpp_get_tavg_info(unit,flds(i),flds,tstamp,tstart,tend,tavg)

         ! why does it convert case of the field name?
         if (trim(lowercase(name)) /= trim(lowercase(fieldname))) cycle

         if (verb) write(outunit,*) 'found field ',trim(fieldname), ' in file !!'
         num_fields = num_fields + 1
         if(num_fields > size(field)) &
              call realloc_fields(size(field)*2)
         init_external_field = num_fields
         field(num_fields)%unit = unit
         field(num_fields)%name = trim(name)
         field(num_fields)%units = trim(fld_units)
         field(num_fields)%field = flds(i)
         field(num_fields)%isc = 1
         field(num_fields)%iec = 1
         field(num_fields)%jsc = 1
         field(num_fields)%jec = 1
         if (PRESENT(domain)) then
            field(num_fields)%domain_present = .true.
            field(num_fields)%domain = domain
            field(num_fields)%isc=iscomp;field(num_fields)%iec = iecomp
            field(num_fields)%jsc=jscomp;field(num_fields)%jec = jecomp
         else
            field(num_fields)%domain_present = .false.
         endif

         call mpp_get_atts(flds(i),valid=field(num_fields)%valid )
         allocate(fld_axes(ndim))
         call mpp_get_atts(flds(i),axes=fld_axes)
         if (ndim > 4) call mpp_error(FATAL, &
              'invalid array rank <=4d fields supported')
         field(num_fields)%siz = 1
         field(num_fields)%ndim = ndim
         do j=1,field(num_fields)%ndim
            cart = 'N'
            call get_axis_cart(fld_axes(j), cart)
            call mpp_get_atts(fld_axes(j),len=len)
            if (cart == 'N') then
               write(msg,'(a,"/",a)')  trim(file),trim(fieldname)
               call mpp_error(FATAL,'file/field '//trim(msg)// &
                    ' couldnt recognize axis atts in time_interp_external')
            endif
            select case (cart)
            case ('X')
               if (j.eq.2) transpose_xy = .true.
               if (.not.PRESENT(domain) .and. .not.PRESENT(override)) then
                  isdata=1;iedata=len
                  iscomp=1;iecomp=len
                  gxsize = len
                  dxsize = len
                  field(num_fields)%isc=iscomp;field(num_fields)%iec=iecomp
               elseif (PRESENT(override)) then
                  gxsize = len
                  if (PRESENT(axis_sizes)) axis_sizes(1) = len
               endif
               field(num_fields)%axes(1) = fld_axes(j)
               if(use_comp_domain1) then
                  field(num_fields)%siz(1) = nx
               else
                  field(num_fields)%siz(1) = dxsize
               endif
               if (len /= gxsize) then
                  write(msg,'(a,"/",a)')  trim(file),trim(fieldname)
                  call mpp_error(FATAL,'time_interp_ext, file/field '//trim(msg)//' x dim doesnt match model')
               endif
            case ('Y')
               field(num_fields)%axes(2) = fld_axes(j)
               if (.not.PRESENT(domain) .and. .not.PRESENT(override)) then
                  jsdata=1;jedata=len
                  jscomp=1;jecomp=len
                  gysize = len
                  dysize = len
                  field(num_fields)%jsc=jscomp;field(num_fields)%jec=jecomp
               elseif (PRESENT(override)) then
                  gysize = len 
                  if (PRESENT(axis_sizes)) axis_sizes(2) = len
               endif
               if(use_comp_domain1) then
                  field(num_fields)%siz(2) = ny
               else
                  field(num_fields)%siz(2) = dysize
               endif
               if (len /= gysize) then
                  write(msg,'(a,"/",a)')  trim(file),trim(fieldname)
                  call mpp_error(FATAL,'time_interp_ext, file/field '//trim(msg)//' y dim doesnt match model')
               endif
            case ('Z')
               field(num_fields)%axes(3) = fld_axes(j)
               field(num_fields)%siz(3) = siz_in(3)
            case ('T')
               field(num_fields)%axes(4) = fld_axes(j)
               field(num_fields)%siz(4) = ntime
            end select
         enddo
         siz = field(num_fields)%siz
         
         if (PRESENT(axis_centers)) then
            axis_centers = field(num_fields)%axes
         endif
         
         if (PRESENT(axis_sizes) .and. .not.PRESENT(override)) then
            axis_sizes = field(num_fields)%siz
         endif
         
         deallocate(fld_axes)
         if (verb) write(outunit,'(a,4i6)') 'field x,y,z,t local size= ',siz
         if (verb) write(outunit,*) 'field contains data in units = ',trim(field(num_fields)%units)
         if (transpose_xy) call mpp_error(FATAL,'axis ordering not supported')
         if (num_io_buffers == -1) then
            nbuf = min(siz(4),2)                 
         else
            if (num_io_buffers .le. 1) call mpp_error(FATAL,'time_interp_ext:num_io_buffers should be at least 2')
            nbuf = min(num_io_buffers,siz(4))
         endif
         allocate(field(num_fields)%data(isdata:iedata,jsdata:jedata,siz(3),nbuf),&
              field(num_fields)%mask(isdata:iedata,jsdata:jedata,siz(3),nbuf) )
            field(num_fields)%mask = .false.
            field(num_fields)%data = 0.0
         slope=1.0;intercept=0.0
!             if (units /= 'same') call convert_units(trim(field(num_fields)%units),trim(units),slope,intercept)
!             if (verb.and.units /= 'same') then
!                 write(outunit,*) 'attempting to convert data to units = ',trim(units)
!                 write(outunit,'(a,f8.3,a,f8.3)') 'factor = ',slope,' offset= ',intercept
!             endif
         field(num_fields)%slope = slope
         field(num_fields)%intercept = intercept
         allocate(field(num_fields)%ibuf(nbuf))
         field(num_fields)%ibuf = -1
         field(num_fields)%nbuf =  0 ! initialize buffer number so that first reading fills data(:,:,:,1)
         if(PRESENT(override)) then
            allocate(field(num_fields)%buf3d(gxsize,gysize,siz(3)))
         else
            allocate(field(num_fields)%buf3d(isdata:iedata,jsdata:jedata,siz(3)))
         endif
         
         allocate(field(num_fields)%time(ntime))
         allocate(field(num_fields)%period(ntime))
         allocate(field(num_fields)%start_time(ntime))
         allocate(field(num_fields)%end_time(ntime))
         
         call mpp_get_atts(time_axis,units=units,calendar=calendar_type)
         do j=1,ntime
            field(num_fields)%time(j)       = get_cal_time(tstamp(j),trim(units),trim(calendar_type),permit_calendar_conversion)
            field(num_fields)%start_time(j) = get_cal_time(tstart(j),trim(units),trim(calendar_type),permit_calendar_conversion)
            field(num_fields)%end_time(j)   = get_cal_time(  tend(j),trim(units),trim(calendar_type),permit_calendar_conversion)
         enddo
             
         if (field(num_fields)%modulo_time) then
            call set_time_modulo(field(num_fields)%Time)
            call set_time_modulo(field(num_fields)%start_time)
            call set_time_modulo(field(num_fields)%end_time)
         endif

         if(present(correct_leap_year_inconsistency)) then
           field(num_fields)%correct_leap_year_inconsistency = correct_leap_year_inconsistency
         else
           field(num_fields)%correct_leap_year_inconsistency = .false.
         endif
             
         if(get_axis_modulo_times(time_axis, timebeg, timeend)) then
           if(get_calendar_type() == NO_CALENDAR) then
             field(num_fields)%modulo_time_beg = set_time(timebeg)
             field(num_fields)%modulo_time_end = set_time(timeend)
           else
             field(num_fields)%modulo_time_beg = set_date(timebeg)
             field(num_fields)%modulo_time_end = set_date(timeend)
           endif
           field(num_fields)%have_modulo_times = .true.
         else
           field(num_fields)%have_modulo_times = .false.
         endif
         if(ntime == 1) then
            call mpp_error(NOTE, 'time_interp_external_mod: file '//trim(file)//'  has only one time level')
         else                
            do j= 1, ntime
               field(num_fields)%period(j) = field(num_fields)%end_time(j)-field(num_fields)%start_time(j)
               if (field(num_fields)%period(j) > set_time(0,0)) then
                  call get_time(field(num_fields)%period(j), sec, day)
                  sec = sec/2+mod(day,2)*43200
                  day = day/2
                  field(num_fields)%time(j) = field(num_fields)%start_time(j)+&
                       set_time(sec,day)
               else
                  if (j > 1 .and. j < ntime) then
                     tdiff = field(num_fields)%time(j+1) -  field(num_fields)%time(j-1)
                     call get_time(tdiff, sec, day)
                     sec = sec/2+mod(day,2)*43200
                     day = day/2
                     field(num_fields)%period(j) = set_time(sec,day)
                     sec = sec/2+mod(day,2)*43200
                     day = day/2
                     field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day)
                     field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day)
                  elseif ( j == 1) then
                     tdiff = field(num_fields)%time(2) -  field(num_fields)%time(1)
                     call get_time(tdiff, sec, day)
                     field(num_fields)%period(j) = set_time(sec,day)
                     sec = sec/2+mod(day,2)*43200
                     day = day/2
                     field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day)
                     field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day)
                  else
                     tdiff = field(num_fields)%time(ntime) -  field(num_fields)%time(ntime-1)
                     call get_time(tdiff, sec, day)
                     field(num_fields)%period(j) = set_time(sec,day)
                     sec = sec/2+mod(day,2)*43200
                     day = day/2
                     field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day)
                     field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day)
                  endif
               endif
            enddo
         endif
             
         do j=1,ntime-1
            if (field(num_fields)%time(j) >= field(num_fields)%time(j+1)) then
               write(msg,'(A,i20)') "times not monotonically increasing. Filename: " &
                    //TRIM(file)//"  field:  "//TRIM(fieldname)//" timeslice: ", j
               call mpp_error(FATAL, TRIM(msg))
            endif
         enddo
             
         field(num_fields)%modulo_time = get_axis_modulo(time_axis)
             
         if (verb) then
            if (field(num_fields)%modulo_time) write(outunit,*) 'data are being treated as modulo in time'
            do j= 1, ntime
               write(outunit,*) 'time index,  ', j
               call get_date(field(num_fields)%start_time(j),yr,mon,day,hr,minu,sec)
               write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') &
                    'start time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec
               call get_date(field(num_fields)%time(j),yr,mon,day,hr,minu,sec)
               write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') &
                    'mid time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec
               call get_date(field(num_fields)%end_time(j),yr,mon,day,hr,minu,sec)
               write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') &
                    'end time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec                  
            enddo
         end if

      enddo
    
      if (num_fields == nfields_orig) then
        if (present(ierr)) then
           ierr = ERR_FIELD_NOT_FOUND
        else
           call mpp_error(FATAL,'external field "'//trim(fieldname)//'" not found in file "'//trim(file)//'"')
        endif
      endif

      deallocate(global_atts)
      deallocate(axes)
      deallocate(flds)
      deallocate(tstamp, tstart, tend, tavg)

      return
      
    end function init_external_field
    
!</FUNCTION> NAME="init_external_field"


    subroutine time_interp_external_2d(index, time, data_in, interp, verbose,horz_interp, mask_out)

      integer, intent(in) :: index
      type(time_type), intent(in) :: time
      real, dimension(:,:), intent(inout) :: data_in
      integer, intent(in), optional :: interp
      logical, intent(in), optional :: verbose
      type(horiz_interp_type),intent(in), optional :: horz_interp
      logical, dimension(:,:), intent(out), optional :: mask_out ! set to true where output data is valid 

      real   , dimension(size(data_in,1), size(data_in,2), 1) :: data_out
      logical, dimension(size(data_in,1), size(data_in,2), 1) :: mask3d

      data_out(:,:,1) = data_in(:,:) ! fill initial values for the portions of array that are not touched by 3d routine
      call time_interp_external_3d(index, time, data_out, interp, verbose, horz_interp, mask3d)
      data_in(:,:) = data_out(:,:,1)
      if (PRESENT(mask_out)) mask_out(:,:) = mask3d(:,:,1)

      return
    end subroutine time_interp_external_2d

!<SUBROUTINE NAME="time_interp_external" >
!
!<DESCRIPTION>
! Provide data from external file interpolated to current model time.
! Data may be local to current processor or global, depending on 
! "init_external_field" flags.
!</DESCRIPTION>
!
!<IN NAME="index" TYPE="integer">
! index of external field from previous call to init_external_field
!</IN>
!<IN NAME="time" TYPE="time_manager_mod:time_type">
! target time for data
!</IN>
!<INOUT NAME="data" TYPE="real" DIM="(:,:),(:,:,:)">
! global or local data array 
!</INOUT>
!<IN NAME="interp" TYPE="integer">
! time_interp_external defined interpolation method (optional).  Currently this module only supports
! LINEAR_TIME_INTERP. 
!</IN>
!<IN NAME="verbose" TYPE="logical">
! verbose flag for debugging (optional).
!</IN>

    subroutine time_interp_external_3d(index, time, data, interp,verbose,horz_interp, mask_out)

      integer, intent(in) :: index
      type(time_type), intent(in) :: time
      real, dimension(:,:,:), intent(inout) :: data
      integer, intent(in), optional :: interp
      logical, intent(in), optional :: verbose
      type(horiz_interp_type),intent(in), optional :: horz_interp
      logical, dimension(:,:,:), intent(out), optional :: mask_out ! set to true where output data is valid 
      
      integer :: nx, ny, nz, interp_method, t1, t2
      integer :: i1, i2, isc, iec, jsc, jec, mod_time, outunit
      integer :: yy, mm, dd, hh, min, ss

      integer :: isu, ieu, jsu, jeu 
          ! these are boundaries of the updated portion of the "data" argument
          ! they are calculated using sizes of the "data" and isc,iec,jsc,jsc
          ! fileds from respective input field, to center the updated portion
          ! in the output array
 
      real :: w1,w2
      logical :: verb
      character(len=16) :: message1, message2

      nx = size(data,1)
      ny = size(data,2)
      nz = size(data,3)
      outunit = stdout()

      interp_method = LINEAR_TIME_INTERP
      if (PRESENT(interp)) interp_method = interp
      verb=.false.
      if (PRESENT(verbose)) verb=verbose
      if (debug_this_module) verb = .true.
      
      if (index < 1.or.index > num_fields) &
           call mpp_error(FATAL,'invalid index in call to time_interp_ext -- field was not initialized or failed to initialize')
     
      if (nx < field(index)%siz(1) .or. ny < field(index)%siz(2) .or. nz < field(index)%siz(3)) then
         write(message1,'(i6,2i5)') nx,ny,nz
         call mpp_error(FATAL,'field '//trim(field(index)%name)//' Array size mismatch in time_interp_external.'// &
         ' Array "data" is too small. shape(data)='//message1)
      endif

      if(PRESENT(mask_out)) then
        if (size(mask_out,1) /= nx .or. size(mask_out,2) /= ny .or. size(mask_out,3) /= nz) then
          write(message1,'(i6,2i5)') nx,ny,nz
          write(message2,'(i6,2i5)') size(mask_out,1),size(mask_out,2),size(mask_out,3)
          call mpp_error(FATAL,'field '//trim(field(index)%name)//' array size mismatch in time_interp_external.'// &
          ' Shape of array "mask_out" does not match that of array "data".'// &
          ' shape(data)='//message1//' shape(mask_out)='//message2)
        endif
      endif

      isc=field(index)%isc;iec=field(index)%iec
      jsc=field(index)%jsc;jec=field(index)%jec

      isu = (nx-(iec-isc+1))/2+1; ieu = isu+iec-isc
      jsu = (ny-(jec-jsc+1))/2+1; jeu = jsu+jec-jsc

      if (field(index)%siz(4) == 1) then
         ! only one record in the file => time-independent field
         call load_record(field(index),1,horz_interp)
         i1 = find_buf_index(1,field(index)%ibuf)
         where(field(index)%mask(isc:iec,jsc:jec,:,i1))
             data(isu:ieu,jsu:jeu,:) = field(index)%data(isc:iec,jsc:jec,:,i1)
         elsewhere
             data(isu:ieu,jsu:jeu,:) = time_interp_missing !field(index)%missing? Balaji
         end where
         if(PRESENT(mask_out)) &
              mask_out(isu:ieu,jsu:jeu,:) = field(index)%mask(isc:iec,jsc:jec,:,i1)
      else
        if(field(index)%have_modulo_times) then
          call time_interp(time,field(index)%modulo_time_beg, field(index)%modulo_time_end, field(index)%time(:), &
                          w2, t1, t2, field(index)%correct_leap_year_inconsistency)
        else
          if(field(index)%modulo_time) then
            mod_time=1
          else
            mod_time=0
          endif
          call time_interp(time,field(index)%time(:),w2,t1,t2,modtime=mod_time)
        endif
         w1 = 1.0-w2
         if (verb) then
            call get_date(time,yy,mm,dd,hh,min,ss)
            write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') &
                 'target time yyyy/mm/dd hh:mm:ss= ',yy,'/',mm,'/',dd,hh,':',min,':',ss
            write(outunit,*) 't1, t2, w1, w2= ', t1, t2, w1, w2
         endif
         call load_record(field(index),t1,horz_interp)
         call load_record(field(index),t2,horz_interp)
         i1 = find_buf_index(t1,field(index)%ibuf)
         i2 = find_buf_index(t2,field(index)%ibuf)

         if(i1<0.or.i2<0) &
              call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory')

         if (verb) then
            write(outunit,*) 'ibuf= ',field(index)%ibuf
            write(outunit,*) 'i1,i2= ',i1, i2
         endif

         where(field(index)%mask(isc:iec,jsc:jec,:,i1).and.field(index)%mask(isc:iec,jsc:jec,:,i2))
             data(isu:ieu,jsu:jeu,:) = field(index)%data(isc:iec,jsc:jec,:,i1)*w1 + &
                  field(index)%data(isc:iec,jsc:jec,:,i2)*w2
         elsewhere
             data(isu:ieu,jsu:jeu,:) = time_interp_missing !field(index)%missing? Balaji
         end where
         if(PRESENT(mask_out)) &
              mask_out(isu:ieu,jsu:jeu,:) = &
                                        field(index)%mask(isc:iec,jsc:jec,:,i1).and.&
                                        field(index)%mask(isc:iec,jsc:jec,:,i2)
      endif

    end subroutine time_interp_external_3d
!</SUBROUTINE> NAME="time_interp_external"
    
    subroutine time_interp_external_0d(index, time, data, verbose)

      integer, intent(in) :: index
      type(time_type), intent(in) :: time
      real, intent(inout) :: data
      logical, intent(in), optional :: verbose
      
      integer :: t1, t2, outunit
      integer :: i1, i2, mod_time
      integer :: yy, mm, dd, hh, min, ss

      real :: w1,w2
      logical :: verb

      outunit = stdout()
      verb=.false.
      if (PRESENT(verbose)) verb=verbose
      if (debug_this_module) verb = .true.
      
      if (index < 1.or.index > num_fields) &
           call mpp_error(FATAL,'invalid index in call to time_interp_ext -- field was not initialized or failed to initialize')
     
      if (field(index)%siz(4) == 1) then
         ! only one record in the file => time-independent field
         call load_record(field(index),1)
         i1 = find_buf_index(1,field(index)%ibuf)
         data = field(index)%data(1,1,1,i1)
      else
        if(field(index)%have_modulo_times) then
          call time_interp(time,field(index)%modulo_time_beg, field(index)%modulo_time_end, field(index)%time(:), &
                          w2, t1, t2, field(index)%correct_leap_year_inconsistency)
        else
          if(field(index)%modulo_time) then
            mod_time=1
          else
            mod_time=0
          endif
          call time_interp(time,field(index)%time(:),w2,t1,t2,modtime=mod_time)
        endif
         w1 = 1.0-w2
         if (verb) then
            call get_date(time,yy,mm,dd,hh,min,ss)
            write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') &
                 'target time yyyy/mm/dd hh:mm:ss= ',yy,'/',mm,'/',dd,hh,':',min,':',ss
            write(outunit,*) 't1, t2, w1, w2= ', t1, t2, w1, w2
         endif
         call load_record(field(index),t1)
         call load_record(field(index),t2)
         i1 = find_buf_index(t1,field(index)%ibuf)
         i2 = find_buf_index(t2,field(index)%ibuf)

         if(i1<0.or.i2<0) &
              call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory')
         data = field(index)%data(1,1,1,i1)*w1 + field(index)%data(1,1,1,i2)*w2
         if (verb) then
            write(outunit,*) 'ibuf= ',field(index)%ibuf
            write(outunit,*) 'i1,i2= ',i1, i2
         endif
      endif

    end subroutine time_interp_external_0d

    subroutine set_time_modulo(Time)

      type(time_type), intent(inout), dimension(:) :: Time

      integer :: ntime, n
      integer :: yr, mon, dy, hr, minu, sec
      
      ntime = size(Time(:))

      do n = 1, ntime
         call get_date(Time(n), yr, mon, dy, hr, minu, sec)
         yr = modulo_year
         Time(n) = set_date(yr, mon, dy, hr, minu, sec)
      enddo


    end subroutine set_time_modulo

! ============================================================================
! load specified record from file  
subroutine load_record(field, rec, interp)
  type(ext_fieldtype), intent(inout) :: field
  integer            , intent(in)    :: rec    ! record number
  type(horiz_interp_type), intent(in), optional :: interp

  ! ---- local vars 
  integer :: ib ! index in the array of input buffers
  integer :: isc,iec,jsc,jec ! boundaries of the domain
  integer :: outunit
  real    :: mask_in(size(field%buf3d,1),size(field%buf3d,2),size(field%buf3d,3))
  real    :: mask_out(field%isc:field%iec,field%jsc:field%jec,size(field%buf3d,3))

  outunit = stdout()
  ib = find_buf_index(rec,field%ibuf)
  if(ib>0) then
     ! do nothing, since field is already in memory
  else 
     isc=field%isc;iec=field%iec
     jsc=field%jsc;jec=field%jec
     if (field%domain_present.and..not.PRESENT(interp)) then
        if (debug_this_module) write(outunit,*) 'reading record with domain for field ',trim(field%name)
        call mpp_read(field%unit,field%field,field%domain,field%buf3d,rec)
     else
        if (debug_this_module) write(outunit,*) 'reading record without domain for field ',trim(field%name)
        call mpp_read(field%unit,field%field,field%buf3d,rec)
     endif

     ! calculate current buffer number in round-robin fasion
     field%nbuf = field%nbuf + 1
     if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1

     ib = field%nbuf
     ! interpolate to target grid
     if(PRESENT(interp)) then
        mask_in = 0.0
        where (mpp_is_valid(field%buf3d, field%valid)) mask_in = 1.0
        call horiz_interp(interp,field%buf3d,field%data(isc:iec,jsc:jec,:,ib), &
             mask_in=mask_in, &
             mask_out=mask_out)
        field%mask(isc:iec,jsc:jec,:,ib) = mask_out > 0
     else
        field%data(isc:iec,jsc:jec,:,ib) = field%buf3d(isc:iec,jsc:jec,:)
        field%mask(isc:iec,jsc:jec,:,ib) = mpp_is_valid(field%data(isc:iec,jsc:jec,:,ib),field%valid)
     endif
     field%ibuf(ib) = rec
     ! convert units
     where(field%mask(isc:iec,jsc:jec,:,ib)) field%data(isc:iec,jsc:jec,:,ib) = &
          field%data(isc:iec,jsc:jec,:,ib)*field%slope + field%intercept
  endif
  
end subroutine load_record


! ============================================================================
! reallocates array of fields, increasing its size
subroutine realloc_files(n)
  integer, intent(in) :: n ! new size

  type(filetype), pointer :: ptr(:)
  integer :: i

  if (associated(opened_files)) then
     if (n <= size(opened_files)) return ! do nothing, if requested size no more than current
  endif

  allocate(ptr(n))
  do i = 1, size(ptr)
     ptr(i)%filename = ''
     ptr(i)%unit = -1
  enddo
  
  if (associated(opened_files))then
     ptr(1:size(opened_files)) = opened_files(:)
     deallocate(opened_files)
  endif
  opened_files => ptr

end subroutine realloc_files

! ============================================================================
! reallocates array of fields,increasing its size
subroutine realloc_fields(n)
  integer, intent(in) :: n ! new size

  type(ext_fieldtype), pointer :: ptr(:)
  integer :: i, ier

  if (associated(field)) then
     if (n <= size(field)) return ! do nothing if requested size no more then current
  endif

!!$  write(stdout(),*) 'reallocating field array'

  allocate(ptr(n))
  do i=1,size(ptr)
     ptr(i)%unit=-1
     ptr(i)%name=''
     ptr(i)%units=''
     ptr(i)%siz=-1
     ptr(i)%ndim=-1
     ptr(i)%domain = NULL_DOMAIN2D
     ptr(i)%axes(:) = default_axis
     if (ASSOCIATED(ptr(i)%time))       DEALLOCATE(ptr(i)%time, stat=ier)
     if (ASSOCIATED(ptr(i)%start_time)) DEALLOCATE(ptr(i)%start_time, stat=ier)
     if (ASSOCIATED(ptr(i)%end_time))   DEALLOCATE(ptr(i)%end_time, stat=ier)
     ptr(i)%field = default_field
     if (ASSOCIATED(ptr(i)%period)) DEALLOCATE(ptr(i)%period, stat=ier)
     ptr(i)%modulo_time=.false.
     if (ASSOCIATED(ptr(i)%data)) DEALLOCATE(ptr(i)%data, stat=ier)
     if (ASSOCIATED(ptr(i)%ibuf)) DEALLOCATE(ptr(i)%ibuf, stat=ier)
     if (ASSOCIATED(ptr(i)%buf3d)) DEALLOCATE(ptr(i)%buf3d, stat=ier)
     ptr(i)%nbuf=-1
     ptr(i)%domain_present=.false.
     ptr(i)%slope=1.0
     ptr(i)%intercept=0.0
     ptr(i)%isc=-1;ptr(i)%iec=-1
     ptr(i)%jsc=-1;ptr(i)%jec=-1
  enddo
  if (associated(field)) then
     ptr(1:size(field)) = field(:)
     deallocate(field)
  endif
  field=>ptr

end subroutine realloc_fields


    function find_buf_index(indx,buf)
      integer :: indx
      integer, dimension(:) :: buf
      integer :: find_buf_index

      integer :: nbuf, i
      
      nbuf = size(buf(:))

      find_buf_index = -1

      do i=1,nbuf
         if (buf(i) == indx) then
            find_buf_index = i
            exit
         endif
      enddo

    end function find_buf_index

!<FUNCTION NAME="get_external_field_size" TYPE="integer" DIM="(4)">
!
!<DESCRIPTION>
! return size of field after call to init_external_field.
! Ordering is X/Y/Z/T.
! This call only makes sense for non-distributed reads.
!</DESCRIPTION>
!
!<IN NAME="index" TYPE="integer">
! returned from previous call to init_external_field.
!</IN>

    function get_external_field_size(index)

      integer :: index
      integer :: get_external_field_size(4)
      
      if (index .lt. 1 .or. index .gt. num_fields) &
           call mpp_error(FATAL,'invalid index in call to get_external_field_size')


      get_external_field_size(1) = field(index)%siz(1)
      get_external_field_size(2) = field(index)%siz(2)
      get_external_field_size(3) = field(index)%siz(3)
      get_external_field_size(4) = field(index)%siz(4)

    end function get_external_field_size
!</FUNCTION> NAME="get_external_field"

! ===========================================================================
subroutine get_time_axis(index, time)
  integer        , intent(in)  :: index   ! field id
  type(time_type), intent(out) :: time(:) ! array of time values to be filled

  integer :: n ! size of the data to be assigned
    
  if (index < 1.or.index > num_fields) &
       call mpp_error(FATAL,'invalid index in call to get_time_axis')

  n = min(size(time),size(field(index)%time))
  
  time(1:n) = field(index)%time(1:n)  
end subroutine

!<SUBROUTINE NAME="time_interp_external_exit">
!
!<DESCRIPTION>
! exit time_interp_external_mod.  Close all open files and
! release storage
!</DESCRIPTION>

    subroutine time_interp_external_exit()

      integer :: i,j
!
! release storage arrays
!
      do i=1,num_fields
         deallocate(field(i)%time,field(i)%start_time,field(i)%end_time,&
              field(i)%period,field(i)%data,field(i)%mask,field(i)%ibuf)
         if (ASSOCIATED(field(i)%buf3d)) deallocate(field(i)%buf3d)
         do j=1,4
            field(i)%axes(j) = default_axis
         enddo
         field(i)%domain = NULL_DOMAIN2D
         field(i)%field = default_field
         field(i)%nbuf = 0
         field(i)%slope = 0.
         field(i)%intercept = 0.
      enddo
      
      deallocate(field)
      deallocate(opened_files)

      num_fields = 0

      module_initialized = .false.

    end subroutine time_interp_external_exit
!</SUBROUTINE> NAME="time_interp_external_exit"

end module time_interp_external_mod

#ifdef test_time_interp_external

program test_time_interp_ext
use constants_mod, only: constants_init
use fms_mod,       only: open_namelist_file, check_nml_error
use mpp_mod, only : mpp_init, mpp_exit, mpp_npes, stdout, stdlog, FATAL, mpp_error
use mpp_mod, only : input_nml_file
use mpp_io_mod, only : mpp_io_init, mpp_io_exit, mpp_open, MPP_RDONLY, MPP_ASCII, mpp_close, &
                       axistype, mpp_get_axis_data
use mpp_domains_mod, only : mpp_domains_init, domain2d, mpp_define_layout, mpp_define_domains,&
     mpp_global_sum, mpp_global_max, mpp_global_min, BITWISE_EXACT_SUM, mpp_get_compute_domain, &
     mpp_domains_set_stack_size
use time_interp_external_mod, only : time_interp_external, time_interp_external_init,&
     time_interp_external_exit, time_interp_external, init_external_field, get_external_field_size
use time_manager_mod, only : get_date, set_date, time_manager_init, set_calendar_type, JULIAN, time_type, increment_time,&
                             NOLEAP
use horiz_interp_mod, only: horiz_interp, horiz_interp_init, horiz_interp_new, horiz_interp_del, horiz_interp_type
use axis_utils_mod, only: get_axis_bounds
implicit none



integer :: id, i, io_status, unit, ierr
character(len=128) :: filename, fieldname
type(time_type) :: time
real, allocatable, dimension(:,:,:) :: data_d, data_g
logical, allocatable, dimension(:,:,:) :: mask_d
type(domain2d) :: domain, domain_out
integer :: layout(2), fld_size(4)
integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
integer :: yy, mm, dd, hh, ss
real :: sm,mx,mn
character(len=12) :: cal_type
integer :: ntime=12,year0=1991,month0=1,day0=1,days_inc=31
type(horiz_interp_type) :: Hinterp
type(axistype) :: Axis_centers(4), Axis_bounds(4)
real :: lon_out(180,89), lat_out(180,89)
real, allocatable, dimension(:,:) :: lon_local_out, lat_local_out
real, allocatable, dimension(:) :: lon_in, lat_in
integer :: isc_o, iec_o, jsc_o, jec_o, outunit

namelist /test_time_interp_ext_nml/ filename, fieldname,ntime,year0,month0,&
     day0,days_inc, cal_type

call constants_init
call mpp_init
call mpp_io_init
call mpp_domains_init
call time_interp_external_init
call time_manager_init
call horiz_interp_init

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, test_time_interp_ext_nml, iostat=io_status)
      ierr = check_nml_error(io_status, 'test_time_interp_ext_nml')
#else
      unit = open_namelist_file ()
      ierr=1; do while (ierr /= 0)
      read  (unit, nml=test_time_interp_ext_nml, iostat=io_status, end=10)
      ierr = check_nml_error(io_status, 'test_time_interp_ext_nml')
      enddo
10    call close_file (unit)
#endif

outunit = stdlog()
write(outunit,test_time_interp_ext_nml)

select case (trim(cal_type))
case ('julian')
   call set_calendar_type(JULIAN)
case ('no_leap')
   call set_calendar_type(NOLEAP)
case default
   call mpp_error(FATAL,'invalid calendar type')
end select

outunit = stdout()
write(outunit,*) 'INTERPOLATING NON DECOMPOSED FIELDS'
write(outunit,*) '======================================'

call time_interp_external_init

id = init_external_field(filename,fieldname,verbose=.true.)

fld_size = get_external_field_size(id)

allocate(data_g(fld_size(1),fld_size(2),fld_size(3)))
data_g = 0

time = set_date(year0,month0,day0,0,0,0)

do i=1,ntime
   call time_interp_external(id,time,data_g,verbose=.true.)
   sm = sum(data_g)
   mn = minval(data_g)
   mx = maxval(data_g)
   write(outunit,*) 'sum= ', sm
   write(outunit,*) 'max= ', mx
   write(outunit,*) 'min= ', mn
   time = increment_time(time,0,days_inc)
enddo

call mpp_define_layout((/1,fld_size(1),1,fld_size(2)/),mpp_npes(),layout)
call mpp_define_domains((/1,fld_size(1),1,fld_size(2)/),layout,domain)
call mpp_get_compute_domain(domain,isc,iec,jsc,jec)
call mpp_get_compute_domain(domain,isd,ied,jsd,jed)

call mpp_domains_set_stack_size(fld_size(1)*fld_size(2)*min(fld_size(3),1)*2)
allocate(data_d(isd:ied,jsd:jed,fld_size(3)))
data_d = 0

write(outunit,*) 'INTERPOLATING DOMAIN DECOMPOSED FIELDS'
write(outunit,*) '======================================'

id = init_external_field(filename,fieldname,domain=domain, verbose=.true.)

time = set_date(year0,month0,day0)

do i=1,ntime
   call time_interp_external(id,time,data_d,verbose=.true.)
   sm = mpp_global_sum(domain,data_d,flags=BITWISE_EXACT_SUM)
   mx = mpp_global_max(domain,data_d)
   mn = mpp_global_min(domain,data_d)
   write(outunit,*) 'global sum= ', sm
   write(outunit,*) 'global max= ', mx
   write(outunit,*) 'global min= ', mn
   time = increment_time(time,0,days_inc)
enddo

write(outunit,*) 'INTERPOLATING DOMAIN DECOMPOSED FIELDS USING HORIZ INTERP'
write(outunit,*) '======================================'


! define a global 2 degree output grid

do i=1,180
   lon_out(i,:) = 2.0*i*atan(1.0)/45.0
enddo

do i=1,89
   lat_out(:,i) = (i-45)*2.0*atan(1.0)/45.0
enddo

call mpp_define_layout((/1,180,1,89/),mpp_npes(),layout)
call mpp_define_domains((/1,180,1,89/),layout,domain_out)
call mpp_get_compute_domain(domain_out,isc_o,iec_o,jsc_o,jec_o)

id = init_external_field(filename,fieldname,domain=domain_out,axis_centers=axis_centers,&
      verbose=.true., override=.true.)

allocate (lon_local_out(isc_o:iec_o,jsc_o:jec_o))
allocate (lat_local_out(isc_o:iec_o,jsc_o:jec_o))

lon_local_out(isc_o:iec_o,jsc_o:jec_o) = lon_out(isc_o:iec_o,jsc_o:jec_o)
lat_local_out(isc_o:iec_o,jsc_o:jec_o) = lat_out(isc_o:iec_o,jsc_o:jec_o)

call get_axis_bounds(axis_centers(1), axis_bounds(1), axis_centers)
call get_axis_bounds(axis_centers(2), axis_bounds(2), axis_centers)

allocate(lon_in(fld_size(1)+1))
allocate(lat_in(fld_size(2)+1))

call mpp_get_axis_data(axis_bounds(1), lon_in) ; lon_in = lon_in*atan(1.0)/45
call mpp_get_axis_data(axis_bounds(2), lat_in) ; lat_in = lat_in*atan(1.0)/45

call horiz_interp_new(Hinterp,lon_in,lat_in, lon_local_out, lat_local_out, &
     interp_method='bilinear')

time = set_date(year0,month0,day0)

deallocate(data_d)
allocate(data_d(isc_o:iec_o,jsc_o:jec_o,fld_size(3)))
allocate(mask_d(isc_o:iec_o,jsc_o:jec_o,fld_size(3)))
do i=1,ntime
   data_d = 0
   call time_interp_external(id,time,data_d,verbose=.true.,horz_interp=Hinterp, mask_out=mask_d)
   sm = mpp_global_sum(domain_out,data_d,flags=BITWISE_EXACT_SUM)
   mx = mpp_global_max(domain_out,data_d)
   mn = mpp_global_min(domain_out,data_d)
   write(outunit,*) 'global sum= ', sm
   write(outunit,*) 'global max= ', mx
   write(outunit,*) 'global min= ', mn
   
   where(mask_d) 
      data_d = 1.0
   elsewhere
      data_d = 0.0
   endwhere
   sm = mpp_global_sum(domain_out,data_d,flags=BITWISE_EXACT_SUM)
   write(outunit,*) 'n valid points= ', sm
   
   time = increment_time(time,0,days_inc)
enddo

call horiz_interp_del(Hinterp)


call time_interp_external_exit


call mpp_io_exit
call mpp_exit
stop

end program test_time_interp_ext
#endif
    
  

      









module get_cal_time_mod

!   <CONTACT EMAIL="fms@gfdl.noaa.gov">
!     fms
!   </CONTACT>
!   <OVERVIEW>
!      Given a time increment as a real number, and base time and calendar
!      as a character strings, returns time as a time_type variable.
!   </OVERVIEW>

use          fms_mod, only: error_mesg, FATAL, write_version_number, lowercase, &
                            open_namelist_file, check_nml_error, stdlog, close_file, &
                            mpp_pe, mpp_root_pe

use time_manager_mod, only: time_type, operator(+), operator(-), set_time, get_time, &
                            NO_CALENDAR, THIRTY_DAY_MONTHS, NOLEAP, JULIAN, GREGORIAN, &
                            set_calendar_type, get_calendar_type, set_date, &
                            get_date, days_in_month, valid_calendar_types
use mpp_mod,          only: input_nml_file

implicit none
private

public :: get_cal_time

logical :: module_is_initialized=.false. ! This module is initialized on
                                         ! the first call to get_cal_time
                                         ! because there is no constructor.
! <NAMELIST NAME="get_cal_time_nml">
! <DATA NAME="allow_calendar_conversion" TYPE="logical"  DEFAULT=".true.">
!   This sets the default value of the optional argument named "permit_calendar_conversion" of get_cal_time.
!   This namelist is deprecated as of the memphis release.
!   If calendar conversion is not desired, then it is recommended that permit_calendar_conversion 
!   be present in the call to get_cal_time and that it be set to .false.
! </DATA>

logical :: allow_calendar_conversion=.true.

namelist / get_cal_time_nml / allow_calendar_conversion
! </NAMELIST>

character(len=128) :: version='$Id: get_cal_time.F90,v 17.0.8.1 2010/08/31 14:29:08 z1l Exp $'
character(len=128) :: tagname='$Name: hiram_20101115_bw $'

contains
!------------------------------------------------------------------------
! <FUNCTION NAME="get_cal_time">
!   <TEMPLATE>
!     get_cal_time(time_increment, units, calendar, permit_calendar_conversion)
!   </TEMPLATE>
!   <IN NAME="time_increment" TYPE="real"> A time interval.</IN>
!   <IN NAME="units" TYPE="character">
!
! Examples of acceptable values of units:
!
! 'days since 1980-01-01 00:00:00',
! 'hours since 1980-1-1 0:0:0',
! 'minutes since 0001-4-12'
!
! The first word in the string must be
! 'years', 'months', 'days', 'hours', 'minutes' or 'seconds'.
! The second word must be 'since'
!
! year number must occupy 4 spaces.
! Number of months, days, hours, minutes, seconds may occupy 1 or 2 spaces
! year, month and day must be separated by a '-'
! hour, minute, second must be separated by a ':'
! hour, minute, second are optional. If not present then zero is assumed.
!
! Because months are not equal increments of time, and, for julian calendar,
! neither are years, the 'years since' and 'month since' cases deserve
! further explaination. 
!
! When 'years since' is used:
! The year number is increased by floor(time_increment)   to obtain a time T1.
! The year number is increased by floor(time_increment)+1 to obtain a time T2.
! The time returned is T1 + (time_increment-floor(time_increment))*(T2-T1).
!
! When 'months since' is used:
! The month number is increased by floor(time_increment). If it falls outside
! to range 1 to 12 then it is adjusted along with the year number to convert
! to a valid date. The number of days in the month of this date is used to
! compute the time interval of the fraction.
! That is:
! The month number is increased by floor(time_increment) to obtain a time T1.
! delt = the number of days in the month in which T1 falls.
! The time returned is T1 + ((time_increment-floor(time_increment))*delt.
! Two of the consequences of this scheme should be kept in mind.
! -- The time since should not be from the 29'th to 31'st of a month,
!    since an invalid date is likely to result, triggering an error stop.
! -- When time since is from the begining of a month, the fraction of a month
!    will never advance into the month after that which results from only
!    the whole number.
!
! When NO_CALENDAR is in effect, units attribute must specify a starting
! day and second, with day number appearing first
!
! Example: 'days since 100 0' Indicates 100 days 0 seconds
! </IN>
!
! <IN NAME="calendar" TYPE="character">
! Acceptable values of calendar are:
! 'noleap'
! '365_day'
! '360_day'
! 'julian'
! 'thirty_day_months'
! 'no_calendar'
! </IN>
!
! <IN NAME="permit_calendar_conversion" TYPE="logical, optional" DEFAULT="allow_calendar_conversion">
! It is sometimes desirable to allow the value of the intent(in) argument
! "calendar" to be different than the calendar in use by time_manager_mod.
! If this is not desirable, then the optional variable "permit_calendar_conversion"
! should be set to .false. so as to allow an error check.
! When calendar conversion is done, the time returned is the time in the
! time_manager's calendar, but corresponds to the date computed using the input calendar.
! For example, suppose the time_manager is using the julian calendar and
! the values of the input arguments of get_cal_time are:
! time_increment = 59.0
! units = 'days since 1980-1-1 00:00:00'
! calendar = 'noleap'
! Because it will use the noleap calendar to calculate the date, get_cal_time will return
! value of time for midnight March 1 1980, but it will be time in the julian calendar
! rather than the noleap calendar. It will never return a value of time corresponding
! to anytime during the day Feb 29.
!
! Another example:
! Suppose the time_manager is using either the noleap or julian calendars,
! and the values of the input arguments are:
! time_increment = 30.0
! units = 'days since 1980-1-1'
! calendar = 'thirty_day_months'
! In this case get_cal_time will return the value of time for Feb 1 1980 00:00:00,
! but in the time_manager's calendar.

! Calendar conversion may result in a fatal error when the input calendar type is
! a calendar that has more days per year than that of the time_manager's calendar.
! For example, if the input calendar type is julian and the time_manager's calendar
! is thirty_day_months, then get_cal_time will try to convert Jan 31 to a time in
! the thirty_day_months calendar, resulting in a fatal error.

! Note: this option was originally coded to allow noleap calendar as input when
! the julian calendar was in effect by the time_manager.
! </IN>
! 
!---------------------------------------------------------------------------------------------

function get_cal_time(time_increment, units, calendar, permit_calendar_conversion)
real, intent(in) :: time_increment
character(len=*), intent(in) :: units
character(len=*), intent(in) :: calendar
logical, intent(in), optional :: permit_calendar_conversion
type(time_type) :: get_cal_time
integer :: year, month, day, hour, minute, second
integer :: i1, i2, i3, i4, i5, i6, increment_seconds, increment_days, increment_years, increment_months
real    :: month_fraction
integer :: calendar_tm_i, calendar_in_i, namelist_unit, ierr, io, logunit
logical :: correct_form
character(len=32) :: calendar_in_c
character(len=64) :: err_msg
character(len=4) :: formt='(i )'
type(time_type) :: base_time, base_time_plus_one_yr, base_time_plus_one_mo
real :: dt
logical :: permit_conversion_local

if(.not.module_is_initialized) then
#ifdef INTERNAL_FILE_NML
      read (input_nml_file, get_cal_time_nml, iostat=io)
#else
  namelist_unit = open_namelist_file()
  ierr=1
  do while (ierr /= 0)
    read(namelist_unit, nml=get_cal_time_nml, iostat=io, end=20)
    ierr = check_nml_error (io, 'get_cal_time_nml')
  enddo
  20 call close_file (namelist_unit)
#endif

  call write_version_number (version, tagname)
  logunit = stdlog()
  if(mpp_pe() == mpp_root_pe()) write (logunit, nml=get_cal_time_nml)
  module_is_initialized = .true.
endif

if(present(permit_calendar_conversion)) then
  permit_conversion_local = permit_calendar_conversion
else
  permit_conversion_local = allow_calendar_conversion
endif

calendar_in_c = lowercase(trim(cut0(calendar)))

correct_form = (trim(calendar_in_c)) == 'noleap'     .or. (trim(calendar_in_c)) == '365_day' .or. &
               (trim(calendar_in_c)) == '360_day'    .or. (trim(calendar_in_c)) == 'julian'  .or. &
               (trim(calendar_in_c)) == 'no_calendar'.or. (trim(calendar_in_c)) == 'thirty_day_months' .or. &
               (trim(calendar_in_c)) == 'gregorian'

if(.not.correct_form) then
  call error_mesg('get_cal_time','"'//trim(calendar_in_c)//'"'// &
   ' is not an acceptable calendar attribute. acceptable calendars are: '// &
   ' noleap, 365_day, 360_day, julian, no_calendar, thirty_day_months, gregorian',FATAL)
endif

calendar_tm_i = get_calendar_type()

if(.not.permit_conversion_local) then
  correct_form = (trim(calendar_in_c) == 'noleap'            .and. calendar_tm_i == NOLEAP)            .or. &
                 (trim(calendar_in_c) == '365_day'           .and. calendar_tm_i == NOLEAP)            .or. &
                 (trim(calendar_in_c) == '360_day'           .and. calendar_tm_i == THIRTY_DAY_MONTHS) .or. &
                 (trim(calendar_in_c) == 'thirty_day_months' .and. calendar_tm_i == THIRTY_DAY_MONTHS) .or. &
                 (trim(calendar_in_c) == 'julian'            .and. calendar_tm_i == JULIAN)            .or. &
                 (trim(calendar_in_c) == 'no_calendar'       .and. calendar_tm_i == NO_CALENDAR)       .or. &
                 (trim(calendar_in_c) == 'gregorian'         .and. calendar_tm_i == GREGORIAN)
  if(.not.correct_form) then
    call error_mesg('get_cal_time','calendar not consistent with calendar type in use by time_manager.'// &
         ' calendar='//trim(calendar_in_c)//'. Type in use by time_manager='//valid_calendar_types(calendar_tm_i),FATAL)
  endif
endif

if (permit_conversion_local) then
    select case (trim(calendar_in_c))
    case ('noleap')
        calendar_in_i = NOLEAP
    case ('365_day')
        calendar_in_i = NOLEAP
    case ('360_day')
        calendar_in_i = THIRTY_DAY_MONTHS
    case ('thirty_day_months')
        calendar_in_i = THIRTY_DAY_MONTHS
    case ('julian')
        calendar_in_i = JULIAN
    case ('no_calendar')
        calendar_in_i = NO_CALENDAR
    case ('gregorian')
        calendar_in_i = GREGORIAN
    case default
        call error_mesg('get_cal_time', &
                 trim(calendar_in_c)//' is an invalid calendar type (specified in call to get_cal_time)',FATAL)
    end select
else
    calendar_in_i = calendar_tm_i
end if

correct_form = lowercase(units(1:10)) == 'days since'    .or. &
               lowercase(units(1:11)) == 'hours since'   .or. &
               lowercase(units(1:13)) == 'minutes since' .or. &
               lowercase(units(1:13)) == 'seconds since'

if(calendar_in_i /= NO_CALENDAR) then
  correct_form = correct_form .or. &
               lowercase(units(1:11)) == 'years since'   .or. &
               lowercase(units(1:12)) == 'months since'
endif

if(.not.correct_form) then
  call error_mesg('get_cal_time',trim(units)//' is an invalid string for units.' // &
        ' units must begin with a time unit then the word "since"' // &
        ' Valid time units are: "seconds" "minutes", "hours", "days", and, ' // &
        ' except when NO_CALENDAR is in effect, "months" and "years"',FATAL)
endif

if(calendar_in_i /= calendar_tm_i) then
! switch to calendar type specified as input argument,
! will switch back before returning.
  call set_calendar_type(calendar_in_i)
endif

! index(string, substring[,back])
! Returns the starting position of substring as a substring of string,
! or zero if it does not occur as a substring. Default value of back is
! .false. If back is .false., the starting position of the first such
! substring is returned. If back is .true., the starting position of the 
! last such substring is returned.
! Returns zero if substring is not a substring of string (regardless of value of back)

i1 = index(units,'since') + 5
if(calendar_in_i == NO_CALENDAR) then
  base_time = set_time(units(i1:len_trim(units)))
else
  base_time = set_date(units(i1:len_trim(units)))
endif

if(lowercase(units(1:10)) == 'days since') then
  increment_days = floor(time_increment)
  increment_seconds = 86400*(time_increment - increment_days) 
else if(lowercase(units(1:11)) == 'hours since') then
  increment_days = floor(time_increment/24)
  increment_seconds = 86400*(time_increment/24 - increment_days)
else if(lowercase(units(1:13)) == 'minutes since') then
  increment_days = floor(time_increment/1440)
  increment_seconds = 86400*(time_increment/1440 - increment_days)
else if(lowercase(units(1:13)) == 'seconds since') then
  increment_days = floor(time_increment/86400)
  increment_seconds = 86400*(time_increment/86400 - increment_days)
else if(lowercase(units(1:11)) == 'years since') then
! The time period between between (base_time + time_increment) and
! (base_time + time_increment + 1 year) may be 360, 365, or 366 days.
! This must be determined to handle time increments with year fractions.
  call get_date(base_time, year,month,day,hour,minute,second)
  base_time             = set_date(year+floor(time_increment)  ,month,day,hour,minute,second)
  base_time_plus_one_yr = set_date(year+floor(time_increment)+1,month,day,hour,minute,second)
  call get_time(base_time_plus_one_yr - base_time, second, day)
  dt = (day*86400+second)*(time_increment-floor(time_increment))
  increment_days = floor(dt/86400)
  increment_seconds = dt - increment_days*86400
else if(lowercase(units(1:12)) == 'months since') then
  month_fraction = time_increment - floor(time_increment)
  increment_years  = floor(time_increment/12)
  increment_months = floor(time_increment) - 12*increment_years
  call get_date(base_time, year,month,day,hour,minute,second)
  base_time = set_date(year+increment_years,month+increment_months  ,day,hour,minute,second)
  dt = 86400*days_in_month(base_time) * month_fraction
  increment_days = floor(dt/86400)
  increment_seconds = dt - increment_days*86400
else
  call error_mesg('get_cal_time','"'//trim(units)//'"'//' is not an acceptable units attribute of time.'// &
    ' It must begin with: "years since", "months since", "days since", "hours since", "minutes since", or "seconds since"',FATAL)
endif

if (calendar_in_i /= calendar_tm_i) then
    if(calendar_in_i == NO_CALENDAR .or. calendar_tm_i == NO_CALENDAR) then
      call error_mesg('get_cal_time','Cannot do calendar conversion because input calendar is '// &
       trim(valid_calendar_types(calendar_in_i))//' and time_manager is using '//trim(valid_calendar_types(calendar_tm_i))// &
       ' Conversion cannot be done if either is NO_CALENDAR',FATAL)
    endif
    call get_date(base_time,year, month, day, hour, minute, second)
    get_cal_time = set_date(year,month,day,hour,minute,second) + set_time(increment_seconds, increment_days)
    call get_date(get_cal_time,year,month,day,hour,minute,second)
    call set_calendar_type(calendar_tm_i)
    get_cal_time = set_date(year,month,day,hour,minute,second, err_msg=err_msg)
    if(err_msg /= '') then
      call error_mesg('get_cal_time','Error in function get_cal_time: '//trim(err_msg)// &
                      ' Note that the time_manager is using the '//trim(valid_calendar_types(calendar_tm_i))//' calendar '// &
                      'while the calendar type passed to function get_cal_time is '//calendar_in_c,FATAL)
    endif
else
    get_cal_time = base_time + set_time(increment_seconds, increment_days)
endif

end function get_cal_time
! </FUNCTION>
!------------------------------------------------------------------------
function cut0(string)
character(len=256) :: cut0
character(len=*), intent(in) :: string
integer :: i

cut0 = string

do i=1,len(string)
  if(ichar(string(i:i)) == 0 ) then
    cut0(i:i) = ' '
  endif
enddo

return
end function cut0
!------------------------------------------------------------------------
end module get_cal_time_mod


module time_manager_mod

! <CONTACT EMAIL="fms@gfdl.noaa.gov">
!   fms
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   A software package that provides a set of simple interfaces for
!   modelers to perform computations related to time and dates.
! </OVERVIEW>

! <DESCRIPTION>
!    The changes between the lima revision and this revision are more
!    extensive that all those between antwerp and lima.
!    A brief description of these changes follows.
!
!    1) Added option to set the smallest time increment to something less than one second.
!       This is controlled by calling the pubic subroutine set_ticks_per_second.
!
!    2) Gregorian calendar fixed.
!
!    3) Optional error flag added to calling arguments of public routines.
!       This allows the using routine to terminate the program. It is likely that more
!       diagnostic information is available from the user than from time_manager alone.
!       If the error flag is present then it is the responsibility of the using
!       routine to test it and add additional information to the error message.
!
!    4) Removed the restriction that time increments be positive in routines that increment or decrement
!       time and date. The option to prohibit negative increments can be turned on via optional argument.
!
!    5) subroutine set_date_c modified to handle strings that include only hours or only hours and minutes.
!       This complies with CF convensions.
!
!    6) Made calendar specific routines private.
!       They are not used, and should not be used, by any using code.
!
!    7) Error messages made more informative.
!
!    The module defines a type that can be used to represent discrete
!    times (accurate to one second) and to map these times into dates
!    using a variety of calendars. A time is mapped to a date by
!    representing the time with respect to an arbitrary base date (refer
!    to <B>NOTES</B> section for the <LINK SRC="#base date">base date</LINK> setting).
!
!    The time_manager provides a single defined type, time_type, which is
!    used to store time and date quantities. A time_type is a positive
!    definite quantity that represents an interval of time. It can be
!    most easily thought of as representing the number of seconds in some
!    time interval. A time interval can be mapped to a date under a given
!    calendar definition by using it to represent the time that has passed
!    since some base date. A number of interfaces are provided to operate
!    on time_type variables and their associated calendars. Time intervals
!    can be as large as n days where n is the largest number represented by
!    the default integer type on a compiler. This is typically considerably
!    greater than 10 million years (assuming 32 bit integer representation)
!    which is likely to be adequate for most applications. The description
!    of the interfaces is separated into two sections. The first deals with
!    operations on time intervals while the second deals with operations
!    that convert time intervals to dates for a given calendar.

!    The smallest increment of time is referred to as a tick.
!    A tick cannot be larger than 1 second, which also is the default.
!    The number of ticks per second is set via pubic subroutine set_ticks_per_second.
!    For example, ticks_per_second = 1000  will set the tick to one millisecond.
! </DESCRIPTION>

! <DATA NAME="time_type" TYPE="derived type">
!    Derived-type data variable used to store time and date quantities. It
!    contains three PRIVATE variables: days, seconds and ticks.
! </DATA>

use constants_mod, only: rseconds_per_day=>seconds_per_day
use fms_mod, only: error_mesg, FATAL, WARNING, write_version_number, stdout

implicit none
private

! Module defines a single type
public time_type

! Operators defined on time_type
public operator(+),  operator(-),   operator(*),   operator(/),  &
       operator(>),  operator(>=),  operator(==),  operator(/=), &
       operator(<),  operator(<=),  operator(//),  assignment(=)

! Subroutines and functions operating on time_type
public set_time, increment_time, decrement_time, get_time, interval_alarm
public repeat_alarm, time_type_to_real, real_to_time_type

! List of available calendar types
public    THIRTY_DAY_MONTHS,    JULIAN,    GREGORIAN,  NOLEAP,   NO_CALENDAR, INVALID_CALENDAR

! Subroutines and functions involving relations between time and calendar
public set_calendar_type
public get_calendar_type
public set_ticks_per_second
public get_ticks_per_second
public set_date
public get_date
public increment_date
public decrement_date
public days_in_month
public leap_year
public length_of_year
public days_in_year
public month_name

public valid_calendar_types

! Subroutines for printing version number and time type
public :: time_manager_init, print_time, print_date

! The following exist only for interpolator.F90
! interpolator.F90 uses them to do a calendar conversion,
! which is also done by get_cal_time. interpolator.F90
! should be modified to use get_cal_time instead.
! After interpolator.F90 is fixed, these can be removed
! and the corresponding private routines can be renamed.
! (e.g., rename set_date_julian_private to be just set_date_julian)
public :: set_date_julian, set_date_no_leap, get_date_julian, get_date_no_leap

public :: date_to_string

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

! Global data to define calendar type
integer, parameter :: THIRTY_DAY_MONTHS = 1,      JULIAN = 2, &
                      GREGORIAN = 3,              NOLEAP = 4, &
                      NO_CALENDAR = 0,  INVALID_CALENDAR =-1
integer, private :: calendar_type = NO_CALENDAR
integer, parameter :: max_type = 4

! Define number of days per month
integer, private :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
integer, parameter :: seconds_per_day = rseconds_per_day  ! This should automatically cast real to integer
integer, parameter :: days_in_400_year_period = 146097    ! Used only for gregorian
integer, dimension(days_in_400_year_period) :: coded_date ! Used only for gregorian
integer, dimension(400,12,31) :: date_to_day              ! Used only for gregorian
integer, parameter :: invalid_date=-1                     ! Used only for gregorian

! time_type is implemented as seconds and days to allow for larger intervals
type time_type
   private
   integer:: seconds
   integer:: days
   integer:: ticks
   integer:: dummy ! added as a workaround bug on IRIX64 (AP)
end type time_type

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

interface operator (+);   module procedure time_plus;        end interface
interface operator (-);   module procedure time_minus;       end interface
interface operator (*);   module procedure time_scalar_mult 
                          module procedure scalar_time_mult; end interface
interface operator (/);   module procedure time_scalar_divide
                          module procedure time_divide;      end interface
interface operator (>);   module procedure time_gt;          end interface
interface operator (>=);  module procedure time_ge;          end interface
interface operator (<);   module procedure time_lt;          end interface
interface operator (<=);  module procedure time_le;          end interface
interface operator (==);  module procedure time_eq;          end interface
interface operator (/=);  module procedure time_ne;          end interface
interface operator (//);  module procedure time_real_divide; end interface
interface assignment(=);  module procedure time_assignment;  end interface

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

interface set_time
  module procedure set_time_i, set_time_c
end interface

interface set_date
  module procedure set_date_i, set_date_c
end interface

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

character(len=128) :: version='$Id: time_manager.F90,v 18.0.4.1 2010/08/31 14:29:08 z1l Exp $'
character(len=128) :: tagname='$Name: hiram_20101115_bw $'
logical :: module_is_initialized = .false.

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

!  A tick is the smallest increment of time.
!  That is, smallest increment of time = (1/ticks_per_second) seconds

integer :: ticks_per_second = 1

!======================================================================
contains

! First define all operations on time intervals independent of calendar

!=========================================================================
! <FUNCTION NAME="set_time">

!   <OVERVIEW>
!     Given some number of seconds and days, returns the
!     corresponding time_type.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Given some number of seconds and days, returns the
!     corresponding time_type. set_time has two forms;
!     one accepts integer input, the other a character string.
!     For the first form, there are no restrictions on the range of the inputs,
!     except that the result must be positive time.
!     e.g. days=-1, seconds=86401 is acceptable.
!     For the second form, days and seconds must both be positive.
!   </DESCRIPTION>
!   <TEMPLATE>
!     1. set_time(seconds, days, ticks, err_msg)
!   </TEMPLATE>
!   <TEMPLATE>
!     2. set_time(time_string, err_msg, allow_rounding)
!   </TEMPLATE>

!   <IN NAME="seconds" UNITS="" TYPE="integer" DIM="(scalar)">
!     A number of seconds.
!   </IN>
!   <IN NAME="days" UNITS="" TYPE="integer" DIM="(scalar)">
!     A number of days.
!   </IN>
!   <IN NAME="ticks" UNITS="" TYPE="integer, optional" DIM="(scalar)">
!     A number of ticks.
!   </IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <IN NAME="time_string" TYPE="character">
!     Contains days and seconds separated by a single blank.
!     days must be integer, seconds may be integer or real.
!     Examples: '100 43200'  '100 43200.50'
!   </IN>
!   <IN NAME="allow_rounding"   TYPE="logical, optional" DEFAULT=".true.">
!     When .true., any fractions of a second will be rounded off to the nearest tick.
!     When .false., it is a fatal error if the second fraction cannot be exactly
!     represented by a number of ticks.
!   </IN>
!   <OUT NAME="set_time" UNITS="" TYPE="" DIM="" DEFAULT="">
!     A time interval corresponding to this number of days and seconds.
!   </OUT>

 function set_time_private(seconds, days, ticks, Time_out, err_msg)

! Returns a time interval corresponding to this number of days, seconds, and ticks.
! days, seconds and ticks may be negative, but resulting time must be positive.

! -- pjp --
! To understand why inputs may be negative,
! one needs to understand the intrinsic function "modulo".
! The expanation below is copied from a web page on fortran 90

! In addition, CEILING, FLOOR  and MODULO  have been added to Fortran 90.
! Only the last one is difficult to explain, which is most easily done with the examples from ISO (1991)

! MOD (8,5)    gives  3     MODULO (8,5)    gives  3
! MOD (-8,5)   gives -3     MODULO (-8,5)   gives  2
! MOD (8,-5)   gives  3     MODULO (8,-5)   gives -2
! MOD (-8,-5)  gives -3     MODULO (-8,-5)  gives -3

! I don't think it is difficult to explain.
! I think that is it sufficient to say this:
! "The result of modulo(n,m) has the sign of m"
! -- pjp --

 logical                       :: set_time_private
 integer, intent(in)           :: seconds, days, ticks
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg
 integer            :: seconds_new, days_new, ticks_new

 seconds_new = seconds + floor(ticks/real(ticks_per_second))
 ticks_new = modulo(ticks,ticks_per_second)
 days_new = days + floor(seconds_new/real(seconds_per_day))
 seconds_new = modulo(seconds_new,seconds_per_day)

 if ( seconds_new < 0 .or. ticks_new < 0) then
   call error_mesg('function set_time_i','Bad result for time. Contact those responsible for maintaining time_manager',FATAL)
 endif

 if(days_new < 0) then
   write(err_msg,'(a,i6,a,i6,a,i6)') 'time is negative. days=',days_new,' seconds=',seconds_new,' ticks=',ticks_new
   set_time_private = .false.
 else
   Time_out%days = days_new
   Time_out%seconds = seconds_new
   Time_out%ticks = ticks_new
   err_msg = ''
   set_time_private = .true.
 endif

 end function set_time_private
!---------------------------------------------------------------------------

 function set_time_i(seconds, days, ticks, err_msg)
 type(time_type)               :: set_time_i
 integer, intent(in)           :: seconds
 integer, intent(in), optional :: days, ticks
 character(len=*), intent(out), optional :: err_msg
 character(len=128) :: err_msg_local
 integer            :: odays, oticks

 if(.not.module_is_initialized) call time_manager_init

 odays  = 0; if(present(days))  odays  = days
 oticks = 0; if(present(ticks)) oticks = ticks
 if(present(err_msg)) err_msg = ''
 
 if(.not.set_time_private(seconds, odays, oticks, set_time_i, err_msg_local)) then
   if(error_handler('function set_time_i', trim(err_msg_local), err_msg)) return
 endif

 end function set_time_i
!---------------------------------------------------------------------------

 function set_time_c(string, err_msg, allow_rounding)

 type(time_type) :: set_time_c
 character(len=*), intent(in) :: string
 character(len=*), intent(out), optional :: err_msg
 logical, intent(in), optional :: allow_rounding

 character(len=4) :: formt='(i )'
 integer :: i1, i2, i3, day, second, tick, nsps
 character(len=32) :: string_sifted_left
 character(len=128) :: err_msg_local
 logical :: allow_rounding_local

 if(.not.module_is_initialized) call time_manager_init
 if(present(err_msg)) err_msg = ''
 allow_rounding_local=.true.; if(present(allow_rounding)) allow_rounding_local=allow_rounding

 err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string)

 string_sifted_left = adjustl(string)
 i1 = index(trim(string_sifted_left),' ')
 if(i1 == 0) then
   if(error_handler('function set_time_c', err_msg_local, err_msg)) return
 endif
 if(index(string,'-') /= 0 .or. index(string,':') /= 0) then
   if(error_handler('function set_time_c', err_msg_local, err_msg)) return
 endif

 i2 = index(trim(string_sifted_left),'.')
 i3 = len_trim(cut0(string_sifted_left))

 if(i2 /= 0) then ! There is no decimal point
 ! Check that decimal is on seconds (not days)
   if(i2 < i1) then
     if(error_handler('function set_time_c', err_msg_local, err_msg)) return
   endif
 endif
 write(formt(3:3),'(i1)') i1-1
 read(string_sifted_left(1:i1-1),formt) day

 if(i2 == 0) then ! There is no decimal point
   write(formt(3:3),'(i1)') i3-i1
   read(string_sifted_left(i1+1:i3),formt) second
   tick = 0
 else ! There is a decimal point
 ! nsps = spaces occupied by whole number of seconds
   nsps = i2-i1-1
   if(nsps == 0) then
     second = 0
   else
     write(formt(3:3),'(i1)') nsps
     read(string_sifted_left(i1+1:i2-1),formt) second
   endif

   if(.not.get_tick_from_string(string_sifted_left(i2:i3), err_msg_local, allow_rounding_local, tick)) then
     if(error_handler('function set_time_c', err_msg_local, err_msg)) return
   endif
 ! If tick has been rounded up to ticks_per_second, then bump up second.
   if(tick == ticks_per_second) then
     second = second + 1
     tick = 0
   endif
 endif

 if(.not.set_time_private(second, day, tick, set_time_c, err_msg_local)) then
   if(error_handler('function set_time_c', err_msg_local, err_msg)) return
 endif

 end function set_time_c
!---------------------------------------------------------------------------
! </FUNCTION>

 function get_tick_from_string(string, err_msg, allow_rounding, tick)

 logical :: get_tick_from_string
 character(len=*), intent(in) :: string
 character(len=*), intent(out) :: err_msg
 logical, intent(in) :: allow_rounding
 integer, intent(out) :: tick

 character(len=4) :: formt='(i )'
 integer :: i3, nspf, fraction, magnitude, tpsfrac

 err_msg = ''
 get_tick_from_string = .true.
 i3 = len_trim(string)
 nspf = i3 - 1 ! nspf = spaces occupied by fractional seconds, excluding decimal point
 if(nspf == 0) then
   tick = 0 ! Nothing to the right of the decimal point
 else
   write(formt(3:3),'(i1)') nspf
   read(string(2:i3),formt) fraction
   if(fraction == 0) then
     tick = 0 ! All zeros to the right of the decimal point
   else
     magnitude = 10**nspf
     tpsfrac = ticks_per_second*fraction
     if(allow_rounding) then
       tick = nint((real(tpsfrac)/magnitude))
     else 
       if(modulo(tpsfrac,magnitude) == 0) then
         tick = tpsfrac/magnitude
       else
         write(err_msg,'(a,i6)') 'Second fraction cannot be exactly represented with ticks.  '// &
                                 'fraction='//trim(string)//'  ticks_per_second=',ticks_per_second 
         get_tick_from_string = .false.
       endif
     endif 
   endif
 endif

 end function get_tick_from_string
!---------------------------------------------------------------------------
! <SUBROUTINE NAME="get_time">

!   <OVERVIEW>
!     Given a time interval, returns the corresponding seconds and days.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Given a time interval, returns the corresponding seconds and days.
!   </DESCRIPTION>
!   <TEMPLATE>
!     get_time(time, seconds, days, ticks, err_msg)
!   </TEMPLATE>

!   <IN NAME="time" TYPE="time_type">
!     A time interval. 
!   </IN>
!   <OUT NAME="seconds" UNITS="" TYPE="integer" DIM="(scalar)">
!     A number of seconds.
!   </OUT>
!   <OUT NAME="days" UNITS="" TYPE="integer" DIM="(scalar)">
!     A number of days.
!   </OUT>
!   <OUT NAME="ticks" UNITS="" TYPE="integer, optional" DIM="(scalar)">
!     A number of ticks.
!   </OUT>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>

subroutine get_time(Time, seconds, days, ticks, err_msg)

! Returns days and seconds ( < 86400 ) corresponding to a time.

type(time_type), intent(in) :: Time
integer, intent(out) :: seconds
integer, intent(out), optional :: days, ticks
character(len=*), intent(out), optional :: err_msg
character(len=128) :: err_msg_local

if(.not.module_is_initialized) call time_manager_init
if(present(err_msg)) err_msg = ''

seconds = Time%seconds

if(present(ticks)) then
  ticks = Time%ticks
else
  if(Time%ticks /= 0) then
    err_msg_local = 'subroutine get_time: ticks must be present when time has a second fraction'
    if(error_handler('subroutine get_time', err_msg_local, err_msg)) return
  endif
endif

if (present(days)) then
  days = Time%days
else
  if (Time%days > (huge(seconds) - seconds)/seconds_per_day) then
    err_msg_local = 'Integer overflow in seconds. Optional argument days must be present.'
    if(error_handler('subroutine get_time', err_msg_local, err_msg)) return
  endif
  seconds = seconds + Time%days * seconds_per_day
endif

end subroutine get_time
! </SUBROUTINE>

!-------------------------------------------------------------------------
! <FUNCTION NAME="increment_time">

!   <OVERVIEW>
!      Given a time and an increment of days and seconds, returns
!      a time that adds this increment to an input time.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Given a time and an increment of days and seconds, returns
!      a time that adds this increment to an input time.
!      Increments a time by seconds and days.
!   </DESCRIPTION>
!   <TEMPLATE>
!     increment_time(time, seconds, days, ticks, err_msg, allow_neg_inc)
!   </TEMPLATE>

!   <IN NAME="time"  TYPE="time_type" DIM="(scalar)">
!      A time interval.
!   </IN>
!   <IN NAME="seconds"  TYPE="integer" DIM="(scalar)">
!     Increment of seconds.
!   </IN>
!   <IN NAME="days" UNITS="" TYPE="integer, optional" DIM="(scalar)">
!     Increment of days.
!   </IN>
!   <IN NAME="ticks"  TYPE="integer, optional" DIM="(scalar)">
!     Increment of ticks.
!   </IN>
!   <OUT NAME="increment_time"  TYPE="time_type" DIM="(scalar)">
!     A time that adds this increment to the input time.
!     A negative result is a fatal error.
!   </OUT>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
!     When .false., it is a fatal error if any of the input time increments are negative.
!     This mimics the behavior of lima and earlier revisions.
!   </IN>

 function increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)

! Increments a time by seconds, days and ticks.

 type(time_type)               :: increment_time
 type(time_type), intent(in)   :: Time
 integer, intent(in)           :: seconds
 integer, intent(in), optional :: days, ticks
 character(len=*), intent(out), optional :: err_msg
 logical, intent(in), optional :: allow_neg_inc

 integer :: odays, oticks
 character(len=128) :: err_msg_local
 logical :: allow_neg_inc_local

 odays  = 0; if(present(days))  odays  = days
 oticks = 0; if(present(ticks)) oticks = ticks
 allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc

 if(.not.allow_neg_inc_local) then
   if(seconds < 0 .or. odays < 0 .or. oticks < 0) then
     write(err_msg_local,10) seconds, odays, oticks
     10 format('One or more time increments are negative: seconds=',i6,'  days=',i6,'  ticks=',i6)
     if(error_handler('function increment_time', err_msg_local, err_msg)) return
   endif
 endif

 if(.not.increment_time_private(Time, seconds, odays, oticks, increment_time, err_msg_local)) then
   if(error_handler('function increment_time', err_msg_local, err_msg)) return
 endif

 end function increment_time
! </FUNCTION>
!--------------------------------------------------------------------------

 function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg)

! Increments a time by seconds, days and ticks.

 logical                       :: increment_time_private
 type(time_type),  intent(in)  :: Time_in
 integer,          intent(in)  :: seconds, days, ticks
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg

! Watch for immediate overflow on days or seconds
 if(days >= huge(days) - Time_in%days)  then
   err_msg = 'Integer overflow in days in increment_time'
   increment_time_private = .false.
   return
 endif
 if(seconds >= huge(seconds) - Time_in%seconds) then
   err_msg = 'Integer overflow in seconds in increment_time'
   increment_time_private = .false.
   return
 endif

 increment_time_private = set_time_private(Time_in%seconds+seconds, Time_in%days+days, Time_in%ticks+ticks, Time_out, err_msg)

 end function increment_time_private

!--------------------------------------------------------------------------
! <FUNCTION NAME="decrement_time">

!   <OVERVIEW>
!      Given a time and a decrement of days and seconds, returns
!      a time that subtracts this decrement from an input time. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Decrements a time by seconds and days.
!   </DESCRIPTION>
!   <TEMPLATE>
!     Decrement_time(time, seconds, days, ticks, err_msg, allow_neg_inc)
!   </TEMPLATE>

!   <IN NAME="time"  TYPE="time_type" DIM="(scalar)">
!      A time interval.
!   </IN>
!   <IN NAME="seconds"  TYPE="integer" DIM="(scalar)">
!     Decrement of seconds.
!   </IN>    
!   <IN NAME="days"  TYPE="integer, optional" DIM="(scalar)">
!     Decrement of days.
!   </IN>
!   <IN NAME="ticks"  TYPE="integer, optional" DIM="(scalar)">
!     Decrement of ticks.
!   </IN>
!   <OUT NAME="decrement_time"  TYPE="time_type">
!      A time that subtracts this decrement from an input time.
!      A negative result is a fatal error.
!   </OUT>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
!     When .false., it is a fatal error if any of the input time increments are negative.
!     This mimics the behavior of lima and earlier revisions.
!   </IN>

function decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)

! Decrements a time by seconds, days and ticks.

type(time_type)               :: decrement_time
type(time_type), intent(in)   :: Time
integer, intent(in)           :: seconds
integer, intent(in), optional :: days, ticks
character(len=*), intent(out), optional :: err_msg
logical, intent(in), optional :: allow_neg_inc

integer            :: odays, oticks
character(len=128) :: err_msg_local
logical :: allow_neg_inc_local

odays  = 0;  if (present(days))   odays = days
oticks = 0;  if (present(ticks)) oticks = ticks
allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc

if(.not.allow_neg_inc_local) then
  if(seconds < 0 .or. odays < 0 .or. oticks < 0) then
    write(err_msg_local,10) seconds,odays,oticks
    10 format('One or more time increments are negative: seconds=',i6,'  days=',i6,'  ticks=',i6)
    if(error_handler('function decrement_time', err_msg_local, err_msg)) return
  endif
endif

 if(.not.increment_time_private(Time, -seconds, -odays, -oticks, decrement_time, err_msg_local)) then
   if(error_handler('function decrement_time', err_msg_local, err_msg)) return
 endif

end function decrement_time
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_gt  operator(>)">

!   <OVERVIEW>
!      Returns true if time1 > time2.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if time1 > time2.
!   </DESCRIPTION>
!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!       Returns true if time1 > time2
!   </OUT>
!   <TEMPLATE>
!     time_gt(time1, time2)
!   </TEMPLATE>

function time_gt(time1, time2)

! Returns true if time1 > time2

logical :: time_gt
type(time_type), intent(in) :: time1, time2

time_gt = (time1%days > time2%days)
if(time1%days == time2%days) then
   if(time1%seconds == time2%seconds) then
      time_gt = (time1%ticks > time2%ticks)
   else
      time_gt = (time1%seconds > time2%seconds)
   endif
endif

end function time_gt
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_ge; operator(>=)">

!   <OVERVIEW>
!      Returns true if time1 >= time2.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if time1 >= time2.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_ge(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!       Returns true if time1 >= time2
!   </OUT>

function time_ge(time1, time2)

! Returns true if time1 >= time2

logical :: time_ge
type(time_type), intent(in) :: time1, time2

time_ge = (time_gt(time1, time2) .or. time_eq(time1, time2))

end function time_ge
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_lt; operator(<)">

!   <OVERVIEW>
!      Returns true if time1 < time2.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if time1 < time2.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_lt(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!       Returns true if time1 < time2
!   </OUT>

function time_lt(time1, time2)

! Returns true if time1 < time2

logical :: time_lt
type(time_type), intent(in) :: time1, time2

time_lt = (time1%days < time2%days)
if(time1%days == time2%days)then
   if(time1%seconds == time2%seconds) then
      time_lt = (time1%ticks < time2%ticks)
   else
      time_lt = (time1%seconds < time2%seconds)
   endif
endif
end function time_lt
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_le; operator(<=)">

!   <OVERVIEW>
!      Returns true if time1 <= time2.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if time1 <= time2.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_le(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!       Returns true if time1 <= time2
!   </OUT>

function time_le(time1, time2)

! Returns true if time1 <= time2

logical :: time_le
type(time_type), intent(in) :: time1, time2

time_le = (time_lt(time1, time2) .or. time_eq(time1, time2))

end function time_le
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_eq; operator(==)">

!   <OVERVIEW>
!      Returns true if time1 == time2.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if time1 == time2.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_eq(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!       Returns true if time1 == time2
!   </OUT>

function time_eq(time1, time2)

! Returns true if time1 == time2

logical :: time_eq
type(time_type), intent(in) :: time1, time2

if(.not.module_is_initialized) call time_manager_init

time_eq = (time1%seconds == time2%seconds .and. time1%days == time2%days &
     .and. time1%ticks == time2%ticks)

end function time_eq
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_ne; operator(/=)">

!   <OVERVIEW>
!      Returns true if time1 /= time2.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if time1 /= time2.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_ne(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
!       Returns true if time1 /= time2
!   </OUT>

function time_ne(time1, time2)

! Returns true if time1 /= time2

logical :: time_ne
type(time_type), intent(in) :: time1, time2

time_ne = (.not. time_eq(time1, time2))

end function time_ne
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="time_plus; operator(+)">

!   <OVERVIEW>
!       Returns sum of two time_types.
!   </OVERVIEW>
!   <TEMPLATE>
!     time1 + time2
!   </TEMPLATE>
!   <DESCRIPTION>
!       Returns sum of two time_types.
!   </DESCRIPTION>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
!       Returns sum of two time_types.
!   </OUT>

function time_plus(time1, time2)

! Returns sum of two time_types

type(time_type) :: time_plus
type(time_type), intent(in) :: time1, time2

if(.not.module_is_initialized) call time_manager_init

time_plus = increment_time(time1, time2%seconds, time2%days, time2%ticks)

end function time_plus
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="time_minus; operator(-)">

!   <OVERVIEW>
!       Returns difference of two time_types.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Returns difference of two time_types. WARNING: a time type is positive 
!       so by definition time1 - time2  is the same as time2 - time1.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_minus(time1, time2)
!   </TEMPLATE>
!   <TEMPLATE>
!     time1 - time2
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
!       Returns difference of two time_types.
!   </OUT>

function time_minus(time1, time2)

! Returns difference of two time_types. WARNING: a time type is positive 
! so by definition time1 - time2  is the same as time2 - time1.

type(time_type) :: time_minus
type(time_type), intent(in) :: time1, time2

if(.not.module_is_initialized) call time_manager_init

if(time1 > time2) then
   time_minus = decrement_time(time1, time2%seconds, time2%days, time2%ticks)
else 
   time_minus = decrement_time(time2, time1%seconds, time1%days, time1%ticks)
endif

end function time_minus
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="time_scalar_mult; operator(*)">

!   <OVERVIEW>
!       Returns time multiplied by integer factor n.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Returns time multiplied by integer factor n.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_scalar_mult(time, n)
!   </TEMPLATE>

!   <IN NAME="time" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="n" UNITS="" TYPE="integer" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
!       Returns time multiplied by integer factor n.
!   </OUT>

function time_scalar_mult(time, n)

! Returns time multiplied by integer factor n

type(time_type)             :: time_scalar_mult
type(time_type), intent(in) :: time
integer, intent(in)         :: n
integer                     :: days, seconds, ticks, num_sec
double precision            :: sec_prod, tick_prod

if(.not.module_is_initialized) call time_manager_init

! Multiplying here in a reasonable fashion to avoid overflow is tricky
! Could multiply by some large factor n, and seconds could be up to 86399
! Need to avoid overflowing integers and wrapping around to negatives
! ticks could be up to ticks_per_second-1

tick_prod = dble(time%ticks) * dble(n)
num_sec   = tick_prod/dble(ticks_per_second)
sec_prod  = dble(time%seconds) * dble(n) + num_sec
ticks     = tick_prod - num_sec * ticks_per_second

! If sec_prod is large compared to precision of double precision, things
! can go bad.  Need to warn and abort on this.
! The same is true of tick_prod but is is more likely to happen to sec_prod,
! so let's just test sec_prod. (A test of tick_prod would be necessary only
! if ticks_per_second were greater than seconds_per_day)
if(sec_prod /= 0.0) then
   if(log10(sec_prod) > precision(sec_prod) - 3) call error_mesg('time_scalar_mult', &
      'Insufficient precision to handle scalar product in time_scalar_mult; contact developer',FATAL)
end if

days = sec_prod / dble(seconds_per_day)
seconds = sec_prod - dble(days) * dble(seconds_per_day)

time_scalar_mult = set_time(seconds, time%days * n + days, ticks)

end function time_scalar_mult
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="scalar_time_mult; operator(*)">

!   <OVERVIEW>
!       Returns time multiplied by integer factor n.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Returns time multiplied by integer factor n.
!   </DESCRIPTION>
!   <TEMPLATE>
!     n * time
!     scalar_time_mult(n, time)
!   </TEMPLATE>

!   <IN NAME="time" UNITS="" TYPE="time_type" DIM="">A time interval.</IN>
!   <IN NAME="n" UNITS="" TYPE="integer" DIM=""> An integer. </IN>
!   <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
!       Returns time multiplied by integer factor n.
!   </OUT>

function scalar_time_mult(n, time)

! Returns time multipled by integer factor n

type(time_type) :: scalar_time_mult
type(time_type), intent(in) :: time
integer, intent(in) :: n

scalar_time_mult = time_scalar_mult(time, n)

end function scalar_time_mult
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="time_divide; operator(/)">

!   <OVERVIEW>
!       Returns the largest integer, n, for which time1 >= time2 * n.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Returns the largest integer, n, for which time1 >= time2 * n.
!   </DESCRIPTION>
!   <TEMPLATE>
!     n = time1 / time2
!     time_divide(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="integer" DIM="" DEFAULT="">
!       Returns the largest integer, n, for which time1 >= time2 * n.
!   </OUT>

function time_divide(time1, time2)

! Returns the largest integer, n, for which time1 >= time2 * n.

integer                     :: time_divide
type(time_type), intent(in) :: time1, time2
double precision            :: d1, d2

if(.not.module_is_initialized) call time_manager_init

! Convert time intervals to floating point days; risky for general performance?
d1 = time1%days * dble(seconds_per_day) + dble(time1%seconds) + time1%ticks/dble(ticks_per_second)
d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + time2%ticks/dble(ticks_per_second)

! Get integer quotient of this, check carefully to avoid round-off problems.
time_divide = d1 / d2

! Verify time_divide*time2 is <= time1 and (time_divide + 1)*time2 is > time1
if(time_divide * time2 > time1 .or. (time_divide + 1) * time2 <= time1) &
   call error_mesg('time_divide',' quotient error :: notify developer',FATAL)

end function time_divide
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="time_real_divide; operator(//)">

!   <OVERVIEW>
!       Returns the double precision quotient of two times.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Returns the double precision quotient of two times.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time1 // time2
!     time_real_divide(time1, time2)
!   </TEMPLATE>

!   <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="integer" DIM="double precision" DEFAULT="">
!       Returns the double precision quotient of two times
!   </OUT>

function time_real_divide(time1, time2)

! Returns the double precision quotient of two times

double precision :: time_real_divide
type(time_type), intent(in) :: time1, time2
double precision :: d1, d2

if(.not.module_is_initialized) call time_manager_init

! Convert time intervals to floating point seconds; risky for general performance?
d1 = time1%days * dble(seconds_per_day) + dble(time1%seconds) + dble(time1%ticks)/dble(ticks_per_second)
d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + dble(time2%ticks)/dble(ticks_per_second)

time_real_divide = d1 / d2

end function time_real_divide
! </FUNCTION>

!-------------------------------------------------------------------------
! <SUBROUTINE NAME="time_assignment; assignment(=)">

!   <OVERVIEW>
!       Assigns all components of the time_type variable on
!       RHS to same components of time_type variable on LHS.
!   </OVERVIEW>
!   <DESCRIPTION>         
!       Assigns all components of the time_type variable on
!       RHS to same components of time_type variable on LHS.
!   </DESCRIPTION> 
!   <TEMPLATE>
!     time1 = time2
!   </TEMPLATE>

!   <OUT NAME="time1" UNITS="" TYPE="time_type" DIM="">
!      A time type variable.
!   </OUT>
!   <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
!      A time type variable.
!   </IN>

subroutine time_assignment(time1, time2)
type(time_type), intent(out) :: time1
type(time_type), intent(in)  :: time2
   time1%seconds = time2%seconds
   time1%days    = time2%days
   time1%ticks   = time2%ticks
end subroutine time_assignment
! </SUBROUTINE>

!-------------------------------------------------------------------------
! <FUNCTION NAME="time_type_to_real">
!   <OVERVIEW>
!       Converts time to seconds and returns it as a real number
!   </OVERVIEW>
!   <DESCRIPTION>
!       Converts time to seconds and returns it as a real number
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_type_to_real(time)
!   </TEMPLATE>
!   <IN NAME="time" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>

function time_type_to_real(time)

double precision            :: time_type_to_real
type(time_type), intent(in) :: time

if(.not.module_is_initialized) call time_manager_init

time_type_to_real = dble(time%days) * 86400.d0 + dble(time%seconds) + &
     dble(time%ticks)/dble(ticks_per_second)

end function time_type_to_real
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="real_to_time_type">
!   <OVERVIEW>
!       Converts a real number of seconds to a time_type variable
!   </OVERVIEW>
!   <DESCRIPTION>
!       Converts a real number of seconds to a time_type variable
!   </DESCRIPTION>
!   <TEMPLATE>
!     real_to_time_type(x, err_msg)
!   </TEMPLATE>
!   <IN NAME="x" UNITS="" TYPE="real" DIM="">
!      A real number of seconds
!   </IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <OUT NAME="real_to_time_type"  TYPE="time_type">
!   </OUT>

 function real_to_time_type(x, err_msg)
 type(time_type)  :: real_to_time_type
 real, intent(in) :: x
 character(len=*), intent(out), optional :: err_msg
 integer          :: seconds, days, ticks
 real             :: real_ticks
 character(len=128) :: err_msg_local

 if(.not.module_is_initialized) call time_manager_init

 days = floor(x/86400.)
 seconds = int(x - 86400.*days)
 real_ticks = x - int(x)
 ticks = nint(real_ticks * ticks_per_second)
 if(.not.set_time_private(seconds, days, ticks, real_to_time_type, err_msg_local)) then
   if(error_handler('function real_to_time_type', err_msg_local, err_msg)) return
 endif

 end function real_to_time_type
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="time_scalar_divide; operator(/)">

!   <OVERVIEW>
!       Returns the largest time, t, for which n * t <= time.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Returns the largest time, t, for which n * t <= time.
!   </DESCRIPTION>
!   <TEMPLATE>
!     time_scalar_divide(time, n)
!   </TEMPLATE>

!   <IN NAME="time" UNITS="" TYPE="time_type" DIM="">
!      A time interval.
!   </IN>
!   <IN NAME="n" UNITS="" TYPE="integer" DIM="">
!      An integer factor.
!   </IN>
!   <OUT NAME="" UNITS="" TYPE="integer" DIM="double precision" DEFAULT="">
!       Returns the largest time, t, for which n * t <= time.
!   </OUT>

function time_scalar_divide(time, n)

! Returns the largest time, t, for which n * t <= time

type(time_type) :: time_scalar_divide
type(time_type), intent(in) :: time
integer, intent(in) :: n
double precision :: d, div, dseconds_per_day, dticks_per_second
integer :: days, seconds, ticks
type(time_type) :: prod1, prod2
character(len=128) tmp1,tmp2
logical :: ltmp

! Convert time interval to floating point days; risky for general performance?
dseconds_per_day  = dble(seconds_per_day)
dticks_per_second = dble(ticks_per_second)
d = time%days*dseconds_per_day*dticks_per_second + dble(time%seconds)*dticks_per_second + dble(time%ticks)
div = d/dble(n)

days = div/(dseconds_per_day*dticks_per_second)
seconds = div/dticks_per_second - days*dseconds_per_day
ticks = div - (days*dseconds_per_day + dble(seconds))*dticks_per_second
time_scalar_divide = set_time(seconds, days, ticks)

! Need to make sure that roundoff isn't killing this
prod1 = n * time_scalar_divide
prod2 = n * (increment_time(time_scalar_divide, days=0, seconds=0, ticks=1))
if(prod1 > time .or. prod2 <= time) then
   call get_time(time, seconds, days, ticks)
   write(tmp1,20) days,seconds,ticks
   call get_time(time_scalar_divide, seconds, days, ticks)
   write(tmp2,30) n,days,seconds,ticks
   ltmp = error_handler('time_scalar_divide',' quotient error:'//trim(tmp1)//trim(tmp2))
 20 format('time=',i7,' days, ',i6,' seconds, ',i6,' ticks')
 30 format('   time divided by',i6,'=',i7,' days, ',i6,' seconds, ',i6,' ticks')
endif

end function time_scalar_divide
! </FUNCTION>

!-------------------------------------------------------------------------
! <FUNCTION NAME="interval_alarm">

!   <OVERVIEW>
!     Given a time, and a time interval, this function returns true
!     if this is the closest time step to the alarm time. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      This is a specialized operation that is frequently performed in models.
!      Given a time, and a time interval, this function is true if this is the
!      closest time step to the alarm time. The actual computation is:
! 
!             if((alarm_time - time) &#60;&#61; (time_interval / 2))
! 
!      If the function is true, the alarm time is incremented by the
!      alarm_interval; WARNING, this is a featured side effect. Otherwise, the
!      function is false and there are no other effects. CAUTION: if the
!      alarm_interval is smaller than the time_interval, the alarm may fail to
!      return true ever again.  Watch
!      for problems if the new alarm time is less than time + time_interval
!   </DESCRIPTION>
!   <TEMPLATE>
!      interval_alarm(time, time_interval, alarm, alarm_interval)
!   </TEMPLATE>

!   <IN NAME="time" TYPE="time_type"> Current time.  </IN>
!   <IN NAME="time_interval" TYPE="time_type"> A time interval.  </IN>
!   <IN NAME="alarm_interval" TYPE="time_type"> A time interval. </IN>
!   <OUT NAME="interval_alarm" TYPE="logical">
!     Returns either True or false.
!   </OUT>
!   <INOUT NAME="alarm" TYPE="time_type">
!     An alarm time, which is incremented by the alarm_interval
!                   if the function is true.
!   </INOUT>

function interval_alarm(time, time_interval, alarm, alarm_interval)

! Supports a commonly used type of test on times for models.  Given the
! current time, and a time for an alarm, determines if this is the closest
! time to the alarm time given a time step of time_interval.  If this
! is the closest time (alarm - time <= time_interval/2), the function 
! returns true and the alarm is incremented by the alarm_interval.  Watch
! for problems if the new alarm time is less than time + time_interval

logical :: interval_alarm
type(time_type), intent(in) :: time, time_interval, alarm_interval
type(time_type), intent(inout) :: alarm

if((alarm - time) <= (time_interval / 2)) then
   interval_alarm = .TRUE.
   alarm = alarm + alarm_interval
else
   interval_alarm = .FALSE.
end if

end function interval_alarm
! </FUNCTION>

!--------------------------------------------------------------------------
! <FUNCTION NAME="repeat_alarm">

!   <OVERVIEW>
!      Repeat_alarm supports an alarm that goes off with
!      alarm_frequency and lasts for alarm_length. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Repeat_alarm supports an alarm that goes off with alarm_frequency and
!      lasts for alarm_length.  If the nearest occurence of an alarm time
!      is less than half an alarm_length from the input time, repeat_alarm
!      is true.  For instance, if the alarm_frequency is 1 day, and the 
!      alarm_length is 2 hours, then repeat_alarm is true from time 2300 on 
!      day n to time 0100 on day n + 1 for all n.
!   </DESCRIPTION>
!   <TEMPLATE>
!      repeat_alarm(time, alarm_frequency, alarm_length)
!   </TEMPLATE>

!   <IN NAME="time" TYPE="time_type"> Current time.  </IN>
!   <IN NAME="alarm_frequency" TYPE="time_type">
!     A time interval for alarm_frequency.
!   </IN>
!   <IN NAME="alarm_length" TYPE="time_type">
!     A time interval for alarm_length.
!   </IN>
!   <OUT NAME="repeat_alarm" TYPE="logical">
!     Returns either True or false.
!   </OUT>

function repeat_alarm(time, alarm_frequency, alarm_length)

! Repeat_alarm supports an alarm that goes off with alarm_frequency and
! lasts for alarm_length.  If the nearest occurence of an alarm time
! is less than half an alarm_length from the input time, repeat_alarm
! is true.  For instance, if the alarm_frequency is 1 day, and the 
! alarm_length is 2 hours, then repeat_alarm is true from time 2300 on 
! day n to time 0100 on day n + 1 for all n.

logical :: repeat_alarm
type(time_type), intent(in) :: time, alarm_frequency, alarm_length
type(time_type) :: prev, next

prev = (time / alarm_frequency) * alarm_frequency
next = prev + alarm_frequency
if(time - prev <= alarm_length / 2 .or. next - time <= alarm_length / 2) then
   repeat_alarm = .TRUE.
else
   repeat_alarm = .FALSE.
endif

end function repeat_alarm
! </FUNCTION>

!--------------------------------------------------------------------------

!=========================================================================
! CALENDAR OPERATIONS BEGIN HERE
!=========================================================================

! <SUBROUTINE NAME="set_calendar_type">

!   <OVERVIEW>
!     Sets the default calendar type for mapping time intervals to dates.
!   </OVERVIEW>
!   <DESCRIPTION>
!     A constant number for setting the calendar type.
!   </DESCRIPTION>
!   <TEMPLATE> set_calendar_type(type, err_msg) </TEMPLATE>

!   <IN NAME="type" TYPE="integer" DIM="(scalar)" DEFAULT="NO_CALENDAR">
!     A constant number for setting the calendar type.
!   </IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>

subroutine set_calendar_type(type, err_msg)

! Selects calendar for default mapping from time to date. 

integer, intent(in) :: type
character(len=*), intent(out), optional :: err_msg
integer :: iday, days_this_month, year, month, day
logical :: leap
character(len=256) :: err_msg_local

if(.not.module_is_initialized) call time_manager_init()

if(present(err_msg)) err_msg = ''

if(type <  0 .or. type > max_type) then
  err_msg_local = 'Illegal calendar type'
  if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return
endif

if(seconds_per_day /= 86400 .and. type /= NO_CALENDAR ) then
  err_msg_local = 'Only calendar type NO_CALENDAR is allowed when seconds_per_day is not 86400.'// &
                  ' You are using '//trim(valid_calendar_types(type))//' and seconds_per_day='
  write(err_msg_local(len_trim(err_msg_local)+1:len_trim(err_msg_local)+8),'(i8)') seconds_per_day
  if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return
endif 

calendar_type = type

if(type == GREGORIAN) then
  date_to_day = invalid_date
  iday = 0
  do year=1,400
    leap = leap_year_gregorian_int(year)
    do month=1,12
      days_this_month = days_per_month(month)
      if(leap .and. month ==2) days_this_month = 29
      do day=1,days_this_month
        date_to_day(year,month,day) = iday
        iday = iday+1
        coded_date(iday) = day + 32*(month + 16*year)
      enddo ! do day
    enddo ! do month
  enddo ! do year
endif

end subroutine set_calendar_type
! </SUBROUTINE>

!------------------------------------------------------------------------
! <FUNCTION NAME="get_calendar_type">

!   <OVERVIEW>
!      Returns the value of the default calendar type for mapping
!      from time to date.
!   </OVERVIEW>
!   <DESCRIPTION>
!     There are no arguments in this function. It returns the value of
!     the default calendar type for mapping from time to date.
!   </DESCRIPTION>
!   <TEMPLATE>
!     get_calendar_type()
!   </TEMPLATE>

function get_calendar_type()

! Returns default calendar type for mapping from time to date.

integer :: get_calendar_type

get_calendar_type = calendar_type

end function get_calendar_type
! </FUNCTION>

!------------------------------------------------------------------------
! <SUBROUTINE NAME="set_ticks_per_second">

!   <OVERVIEW>
!     Sets the number of ticks per second.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Sets the number of ticks per second.
!   </DESCRIPTION>
!   <TEMPLATE> call set_ticks_per_second(ticks_per_second) </TEMPLATE>
!   <IN NAME="type" TYPE="integer" DIM="(scalar)" DEFAULT="1"> </IN>

subroutine set_ticks_per_second(tps)
integer, intent(in) :: tps

ticks_per_second = tps

end subroutine set_ticks_per_second

! </SUBROUTINE>

!------------------------------------------------------------------------
! <FUNCTION NAME="get_ticks_per_second">

!   <OVERVIEW>
!      Returns the number of ticks per second.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns the number of ticks per second.
!   </DESCRIPTION>
!   <TEMPLATE>
!     ticks_per_second = get_ticks_per_second()
!   </TEMPLATE>

function get_ticks_per_second()
integer :: get_ticks_per_second

get_ticks_per_second = ticks_per_second

end function get_ticks_per_second

! </FUNCTION>
!------------------------------------------------------------------------

!========================================================================
! START OF get_date BLOCK
! <SUBROUTINE NAME="get_date">

!   <OVERVIEW>
!      Given a time_interval, returns the corresponding date under
!      the selected calendar. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Given a time_interval, returns the corresponding date under
!      the selected calendar.
!   </DESCRIPTION>
!   <TEMPLATE>
!     get_date(time, year, month, day, hour, minute, second, tick, err_msg)
!   </TEMPLATE>
!   <IN NAME="time"    TYPE="time_type"> A time interval.</IN>
!   <OUT NAME="year"   TYPE="integer"></OUT>
!   <OUT NAME="month"  TYPE="integer"></OUT>
!   <OUT NAME="day"    TYPE="integer"></OUT>
!   <OUT NAME="hour"   TYPE="integer"></OUT>
!   <OUT NAME="minute" TYPE="integer"></OUT>
!   <OUT NAME="second" TYPE="integer"></OUT>
!   <OUT NAME="tick"   TYPE="integer, optional"></OUT>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
 subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg)

! Given a time, computes the corresponding date given the selected calendar

 type(time_type), intent(in)    :: time
 integer, intent(out)           :: second, minute, hour, day, month, year
 integer, intent(out), optional :: tick
 character(len=*), intent(out), optional :: err_msg
 character(len=128) :: err_msg_local
 integer :: tick1 

 if(.not.module_is_initialized) call time_manager_init
 if(present(err_msg)) err_msg = ''

 select case(calendar_type)
 case(THIRTY_DAY_MONTHS)
   call get_date_thirty   (time, year, month, day, hour, minute, second, tick1)
 case(GREGORIAN)
   call get_date_gregorian(time, year, month, day, hour, minute, second, tick1)
 case(JULIAN)
   call get_date_julian_private   (time, year, month, day, hour, minute, second, tick1)
 case(NOLEAP)
   call get_date_no_leap_private  (time, year, month, day, hour, minute, second, tick1)
 case(NO_CALENDAR)
   err_msg_local = 'Cannot produce a date when the calendar type is NO_CALENDAR'
   if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
 case default
   err_msg_local = 'Invalid calendar type'
   if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
 end select
 
 if(present(tick)) then
   tick = tick1
 else
   if(tick1 /= 0) then
     err_msg_local = 'tick must be present when time has a second fraction'
     if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
   endif
 endif

 end subroutine get_date
! </SUBROUTINE>
!------------------------------------------------------------------------

 subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick)

! Computes date corresponding to time for gregorian calendar

 type(time_type), intent(in) :: time
 integer, intent(out) :: year, month, day, hour, minute, second
 integer, intent(out) :: tick
 integer :: iday, isec

 if(Time%seconds >= 86400) then ! This check appears to be unecessary.
   call error_mesg('get_date','Time%seconds .ge. 86400 in subroutine get_date_gregorian',FATAL)
 endif

 iday = mod(Time%days+1,days_in_400_year_period)
 if(iday == 0) iday = days_in_400_year_period

 year = coded_date(iday)/512
 day = mod(coded_date(iday),32)
 month = coded_date(iday)/32 - 16*year

 year = year + 400*((Time%days)/days_in_400_year_period)

 hour = Time%seconds / 3600
 isec  = Time%seconds - 3600*hour
 minute = isec / 60
 second = isec - 60*minute 
 tick = time%ticks

 end subroutine get_date_gregorian

!------------------------------------------------------------------------
 function cut0(string)
 character(len=256) :: cut0
 character(len=*), intent(in) :: string
 integer :: i

 cut0 = string

 do i=1,len(string)
   if(ichar(string(i:i)) == 0 ) then
     cut0(i:i) = ' '
   endif
 enddo

 return
 end function cut0
!------------------------------------------------------------------------

 subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick)

! Base date for Julian calendar is year 1 with all multiples of 4 
! years being leap years.

 type(time_type), intent(in) :: time
 integer, intent(out) :: second, minute, hour, day, month, year
 integer, intent(out) :: tick
 integer :: m, t, nfour, nex, days_this_month
 logical :: leap

! find number of four year periods; also get modulo number of days
 nfour = time%days / (4 * 365 + 1) 
 day = modulo(time%days, (4 * 365 + 1))

! Find out what year in four year chunk
 nex = day / 365
 if(nex == 4) then
    nex = 3
    day = 366
 else
    day=modulo(day, 365) + 1
 endif

! Is this a leap year? 
 leap = (nex == 3)

 year = 1 + 4 * nfour + nex

! find month and day
 do m = 1, 12
   month = m
   days_this_month = days_per_month(m)
   if(leap .and. m == 2) days_this_month = 29
   if(day <= days_this_month) exit
   day = day - days_this_month
 end do

! find hour,minute and second
 t = time%seconds
 hour = t / (60 * 60)
 t = t - hour * (60 * 60)
 minute = t / 60
 second = t - 60 * minute
 tick = time%ticks
 end subroutine get_date_julian_private

!------------------------------------------------------------------------
 subroutine get_date_julian(time, year, month, day, hour, minute, second)

! No need to include tick in argument list because this routine
! exists only for interpolator.F90, which does not need it.

 type(time_type), intent(in) :: time
 integer, intent(out) :: second, minute, hour, day, month, year
 integer :: tick

 call get_date_julian_private(time, year, month, day, hour, minute, second, tick)

 end subroutine get_date_julian

!------------------------------------------------------------------------

 subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)

! Computes date corresponding to time interval for 30 day months, 12
! month years.

 type(time_type), intent(in) :: time
 integer, intent(out) :: second, minute, hour, day, month, year
 integer, intent(out) :: tick
 integer :: t, dmonth, dyear

 t = time%days
 dyear = t / (30 * 12)
 year = dyear + 1
 t = t - dyear * (30 * 12)
 dmonth = t / 30
 month = 1 + dmonth
 day = t -dmonth * 30 + 1

 t = time%seconds
 hour = t / (60 * 60) 
 t = t - hour * (60 * 60)
 minute = t / 60
 second = t - 60 * minute
 tick = time%ticks

 end subroutine get_date_thirty
!------------------------------------------------------------------------

 subroutine get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)

! Base date for NOLEAP calendar is year 1.

 type(time_type), intent(in) :: time
 integer, intent(out) :: second, minute, hour, day, month, year
 integer, intent(out) :: tick
 integer :: m, t

! get modulo number of days
 year = time%days / 365 + 1
 day = modulo(time%days, 365) + 1

! find month and day
 do m = 1, 12
   month = m
   if(day <= days_per_month(m)) exit
   day = day - days_per_month(m)
 end do

! find hour,minute and second
 t = time%seconds
 hour = t / (60 * 60)
 t = t - hour * (60 * 60)
 minute = t / 60
 second = t - 60 * minute
 tick = time%ticks

 end subroutine get_date_no_leap_private

!------------------------------------------------------------------------
 subroutine get_date_no_leap(time, year, month, day, hour, minute, second)

! No need to include tick in argument list because this routine
! exists only for interpolator.F90, which does not need it.

 type(time_type), intent(in) :: time
 integer, intent(out) :: second, minute, hour, day, month, year
 integer :: tick

 call get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)

 end subroutine get_date_no_leap
!------------------------------------------------------------------------

! END OF get_date BLOCK
!========================================================================
! START OF set_date BLOCK
! <FUNCTION NAME="set_date">

!   <OVERVIEW>
!      Given an input date in year, month, days, etc., creates a
!      time_type that represents this time interval from the
!      internally defined base date.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Given a date, computes the corresponding time given the selected
!      date time mapping algorithm. Note that it is possible to specify
!      any number of illegal dates; these should be checked for and generate
!      errors as appropriate.
!   </DESCRIPTION>
!   <TEMPLATE>
!     1. set_date(year, month, day, hours, minute, second, tick, err_msg)
!   </TEMPLATE>
!   <TEMPLATE>
!     2. set_date_c(time_string, zero_year_warning, err_msg, allow_rounding)
!      time_string is a character string containing a date formatted
!      according to CF conventions. e.g. '1980-12-31 23:59:59.9'
!   </TEMPLATE>
!   <IN NAME="time"   TYPE="time_type"> A time interval.</IN>
!   <IN NAME="year"   TYPE="integer"></IN>
!   <IN NAME="month"  TYPE="integer"></IN>
!   <IN NAME="day"    TYPE="integer"></IN>
!   <IN NAME="hour"   TYPE="integer"></IN>
!   <IN NAME="minute" TYPE="integer"></IN>
!   <IN NAME="second" TYPE="integer"></IN>
!   <IN NAME="tick"   TYPE="integer"></IN>
!   <IN NAME="zero_year_warning"   TYPE="logical">
!     If the year number is zero, it will be silently changed to one,
!     unless zero_year_warning=.true., in which case a WARNING message
!     will also be issued.
!   </IN>
!   <IN NAME="allow_rounding"   TYPE="logical, optional" DEFAULT=".true.">
!     When .true., any fractions of a second will be rounded off to the nearest tick.
!     When .false., it is a fatal error if the second fraction cannot be exactly
!     represented by a number of ticks.
!   </IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <OUT NAME="set_date" TYPE="time_type"> A time interval.</OUT>

 function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)

! Given a date, computes the corresponding time given the selected
! date time mapping algorithm.  Note that it is possible to specify
! any number of illegal dates; these are checked for and generate
! errors as appropriate.

 logical :: set_date_private
 integer, intent(in) :: year, month, day, hour, minute, second, tick
 type(time_type) :: Time_out
 character(len=*), intent(out) :: err_msg

 if(.not.module_is_initialized) call time_manager_init

 err_msg = ''

 select case(calendar_type)
 case(THIRTY_DAY_MONTHS)
   set_date_private = set_date_thirty   (year, month, day, hour, minute, second, tick, Time_out, err_msg)
 case(GREGORIAN)
   set_date_private = set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
 case(JULIAN)
   set_date_private = set_date_julian_private   (year, month, day, hour, minute, second, tick, Time_out, err_msg)
 case(NOLEAP)
   set_date_private = set_date_no_leap_private  (year, month, day, hour, minute, second, tick, Time_out, err_msg)
 case (NO_CALENDAR)
   err_msg = 'Cannot produce a date when calendar type is NO_CALENDAR'
   set_date_private = .false.
 case default
   err_msg = 'Invalid calendar type'
   set_date_private = .false.
 end select

 end function set_date_private
! </FUNCTION>

!------------------------------------------------------------------------
 function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
 type(time_type) :: set_date_i
 integer, intent(in) :: day, month, year
 integer, intent(in), optional :: second, minute, hour, tick
 character(len=*), intent(out), optional :: err_msg
 integer :: osecond, ominute, ohour, otick
 character(len=128) :: err_msg_local

 if(.not.module_is_initialized) call time_manager_init
 if(present(err_msg)) err_msg = ''
     
! Missing optionals are set to 0
 osecond = 0; if(present(second)) osecond = second
 ominute = 0; if(present(minute)) ominute = minute
 ohour   = 0; if(present(hour))   ohour   = hour
 otick   = 0; if(present(tick))   otick   = tick

 if(.not.set_date_private(year, month, day, ohour, ominute, osecond, otick, set_date_i, err_msg_local)) then
   if(error_handler('function set_date_i', err_msg_local, err_msg)) return
 endif

 end function set_date_i
!------------------------------------------------------------------------

 function set_date_c(string, zero_year_warning, err_msg, allow_rounding)

 ! Examples of acceptable forms of string:

 ! 1980-01-01 00:00:00
 ! 1980-01-01 00:00:00.50
 ! 1980-1-1 0:0:0
 ! 1980-1-1

 ! year number must occupy 4 spaces.
 ! months, days, hours, minutes, seconds may occupy 1 or 2 spaces
 ! year, month and day must be separated by a '-'
 ! hour, minute, second must be separated by a ':'
 ! hour, minute, second are optional. If not present then zero is assumed.
 ! second may be a real number.

 ! zero_year_warning:
 ! If the year number is zero, it will be silently changed to one,
 ! unless zero_year_warning=.true., in which case a WARNING message
 ! will also be issued

 type(time_type) :: set_date_c
 character(len=*), intent(in) :: string
 logical,          intent(in),  optional :: zero_year_warning
 character(len=*), intent(out), optional :: err_msg
 logical,          intent(in),  optional :: allow_rounding
 character(len=4) :: formt='(i )'
 logical :: correct_form, zero_year_warning_local, allow_rounding_local
 integer :: i1, i2, i3, i4, i5, i6, i7
 character(len=32) :: string_sifted_left
 integer :: year, month, day, hour, minute, second, tick
 character(len=128) :: err_msg_local
 
 if(.not.module_is_initialized) call time_manager_init()
 if(present(err_msg)) err_msg = ''
 if(present(zero_year_warning)) then
   zero_year_warning_local = zero_year_warning 
 else
   zero_year_warning_local = .true. 
 endif
 if(present(allow_rounding)) then
   allow_rounding_local = allow_rounding 
 else
   allow_rounding_local = .true. 
 endif

 string_sifted_left = adjustl(string)
 i1 = index(string_sifted_left,'-')
 i2 = index(string_sifted_left,'-',back=.true.)
 i3 = index(string_sifted_left,':')
 i4 = index(string_sifted_left,':',back=.true.)
 i5 = len_trim(cut0(string_sifted_left))
 i6 = index(string_sifted_left,'.',back=.true.)
 correct_form = (i1 > 1) ! year number must occupy at least 1 space
 correct_form = correct_form .and. (i2-i1 == 2 .or. i2-i1 == 3) ! month number must occupy 1 or 2 spaces
 if(.not.correct_form) then
   err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string)
   if(error_handler('function set_date_c', err_msg_local, err_msg)) return
 endif
 write(formt(3:3),'(i1)') i1-1
 read(string_sifted_left(1:i1-1),formt) year
 if(year == 0) then
   year = 1
   if(zero_year_warning_local) then
     call error_mesg('set_date_c','Year zero is invalid. Resetting year to 1', WARNING)
   endif
 endif
 write(formt(3:3),'(i1)') i2-i1-1
 read(string_sifted_left(i1+1:i2-1),formt) month
 i7 = min(i2+2,i5)
 read(string_sifted_left(i2+1:i7),'(i2)') day

 if(i3 == 0) then
! There are no minutes or seconds in the string
   minute = 0
   second = 0
   tick   = 0
   if(i5 <= i2+2) then
 !   There is no clocktime in the string at all
     hour = 0
   else
 !   The clocktime includes only hours
     read(string_sifted_left(i5-1:i5),'(i2)') hour
   endif
 else if(i3 == i4) then
 ! The string includes hours and minutes, but no seconds
   read(string_sifted_left(i3-2:i3-1),'(i2)') hour
   write(formt(3:3),'(i1)') i5-i3
   read(string_sifted_left(i3+1:i5),formt) minute
   second = 0
   tick = 0
 else
 ! The string includes hours, minutes, and seconds
   read(string_sifted_left(i3-2:i3-1),'(i2)') hour
   write(formt(3:3),'(i1)') i4-i3-1
   read(string_sifted_left(i3+1:i4-1),formt) minute
   write(formt(3:3),'(i1)') i5-i4
   if(i6 == 0) then
   ! There are no fractional seconds
     read(string_sifted_left(i4+1:i5),formt) second
     tick = 0
   else
     read(string_sifted_left(i4+1:i6-1),formt) second
     if(.not.get_tick_from_string(string_sifted_left(i6:i5), err_msg_local, allow_rounding_local, tick)) then
       if(error_handler('function set_date_c', err_msg_local, err_msg)) return
     endif
 !   If tick has been rounded up to ticks_per_second, then bump up second.
     if(tick == ticks_per_second) then
       second = second + 1
       tick = 0
     endif
   endif
 endif

 if(.not.set_date_private(year, month, day, hour, minute, second, tick, set_date_c, err_msg_local)) then
   if(error_handler('function set_date_c', err_msg_local, err_msg)) return
 endif

 end function set_date_c
!------------------------------------------------------------------------

 function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
 logical :: set_date_gregorian

! Computes time corresponding to date for gregorian calendar.

 integer,          intent(in)  :: year, month, day, hour, minute, second, tick
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg
 integer :: yr1, day1

 if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
   set_date_gregorian = .false.
   return
 endif

 Time_out%seconds = second + 60*(minute + 60*hour)

 yr1 = mod(year,400)
 if(yr1 == 0) yr1 = 400
 day1 = date_to_day(yr1,month,day)
  if(day1 == invalid_date) then
   err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
   set_date_gregorian = .false.
   return
 endif

 Time_out%days = day1 + days_in_400_year_period*((year-1)/400)
 Time_out%ticks = tick
 err_msg = ''
 set_date_gregorian = .true.

 end function set_date_gregorian

!------------------------------------------------------------------------

 function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
 logical :: set_date_julian_private

! Returns time corresponding to date for julian calendar.

 integer,          intent(in)  :: year, month, day, hour, minute, second, tick
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg
 integer :: ndays, m, nleapyr
 logical :: leap

 if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
   set_date_julian_private = .false.
   return
 endif

 if(month /= 2 .and. day > days_per_month(month)) then
   err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
   set_date_julian_private = .false.
   return
 endif

! Is this a leap year? 
 leap = (modulo(year,4) == 0)
! compute number of complete leap years from year 1
 nleapyr = (year - 1) / 4

! Finish checking for day specication errors
 if(month == 2 .and. (day > 29 .or. ((.not. leap) .and. day > 28))) then
   err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
   set_date_julian_private = .false.
   return
 endif

 ndays = 0
 do m = 1, month - 1
   ndays = ndays + days_per_month(m)
   if(leap .and. m == 2) ndays = ndays + 1
 enddo

 Time_out%seconds = second + 60 * (minute + 60 * hour)
 Time_out%days    = day -1 + ndays + 365*(year - nleapyr - 1) + 366*(nleapyr)
 Time_out%ticks   = tick
 err_msg = ''
 set_date_julian_private = .true.

 end function set_date_julian_private

!------------------------------------------------------------------------
 function set_date_julian(year, month, day, hour, minute, second)

! No need to include tick or err_msg in argument list because this
! routine exists only for interpolator.F90, which does not need them.

 type(time_type) :: set_date_julian
 integer, intent(in) :: year, month, day, hour, minute, second
 character(len=128) :: err_msg

 if(.not.set_date_julian_private(year, month, day, hour, minute, second, 0, set_date_julian, err_msg)) then
   call error_mesg('set_date_julian',trim(err_msg),FATAL)
 endif

 end function set_date_julian
!------------------------------------------------------------------------

 function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg)
 logical :: set_date_thirty

! Computes time corresponding to date for thirty day months.

 integer,          intent(in)  :: year, month, day, hour, minute, second, tick
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg

 if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
   set_date_thirty = .false.
   return
 endif

 if(day > 30) then
   err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
   set_date_thirty = .false.
   return
 endif

 Time_out%days    = (day - 1) + 30 * ((month - 1) + 12 * (year - 1))
 Time_out%seconds = second + 60 * (minute + 60 * hour)
 Time_out%ticks   = tick
 err_msg = ''
 set_date_thirty = .true.

 end function set_date_thirty

!------------------------------------------------------------------------

 function set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
 logical :: set_date_no_leap_private

! Computes time corresponding to date for fixed 365 day year calendar.

 integer,          intent(in)  :: year, month, day, hour, minute, second, tick
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg
 integer :: ndays, m

 if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
   set_date_no_leap_private = .false.
   return
 endif

 if(day > days_per_month(month)) then
   err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
   set_date_no_leap_private = .false.
   return
 endif

 ndays = 0
 do m = 1, month - 1
   ndays = ndays + days_per_month(m)
 enddo

! No need for err_msg in call to set_time because previous checks ensure positive value of time.
 Time_out = set_time(second + 60 * (minute + 60 * hour), day -1 + ndays + 365 * (year - 1), tick)
 err_msg = ''
 set_date_no_leap_private = .true.

 end function set_date_no_leap_private
!------------------------------------------------------------------------

 function set_date_no_leap(year, month, day, hour, minute, second)

! No need to include tick or err_msg in argument list because this
! routine exists only for interpolator.F90, which does not need them.

 type(time_type) :: set_date_no_leap
 integer, intent(in) :: year, month, day, hour, minute, second
 character(len=128) :: err_msg

 if(.not.set_date_no_leap_private(year, month, day, hour, minute, second, 0, set_date_no_leap, err_msg)) then
   call error_mesg('set_date_no_leap',trim(err_msg),FATAL)
 endif

 end function set_date_no_leap

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

 function valid_increments(year, month, day, hour, minute, second, tick, err_msg)
 logical :: valid_increments
 integer, intent(in) :: year, month, day, hour, minute, second, tick
 character(len=128), intent(out) :: err_msg

!  Check for invalid values

 err_msg = ''
 valid_increments = .true.
 if(second > 59 .or. second < 0 .or. minute > 59 .or. minute < 0 &
   .or. hour > 23 .or. hour < 0 .or. day > 31 .or. day < 1 &
   .or. month > 12 .or. month < 1 .or. year < 1) then
     err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
     valid_increments = .false.
     return
 endif
 if(tick < 0 .or. tick >= ticks_per_second) then
   write(err_msg,'(a,i6)') 'Invalid number of ticks. tick=',tick
   valid_increments = .false.
 endif

 end function valid_increments

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

 function convert_integer_date_to_char(year, month, day, hour, minute, second)
 character(len=19) :: convert_integer_date_to_char
 integer, intent(in) :: year, month, day
 integer, intent(in) :: hour, minute, second

 write(convert_integer_date_to_char,10) year,month,day,hour,minute,second
 10 format(i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)

 end function convert_integer_date_to_char

!=========================================================================
! END OF set_date BLOCK
!=========================================================================

! <FUNCTION NAME="increment_date">

!   <OVERVIEW>
!      Increments the date represented by a time interval and the
!      default calendar type by a number of seconds, etc. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Given a time and some date increment, computes a new time.  Depending
!      on the mapping algorithm from date to time, it may be possible to specify
!      undefined increments (i.e. if one increments by 68 days and 3 months in
!      a Julian calendar, it matters which order these operations are done and
!      we don't want to deal with stuff like that, make it an error).
!   </DESCRIPTION>
!   <TEMPLATE>
!      increment_date(time, years, months, days, hours, minutes, seconds, ticks, err_msg)
!   </TEMPLATE>
!   <IN NAME="time"    TYPE="time_type"> A time interval.</IN>
!   <IN NAME="years"   TYPE="integer">An increment of years.</IN>
!   <IN NAME="months"  TYPE="integer">An increment of months.</IN>
!   <IN NAME="days"    TYPE="integer">An increment of days.</IN>
!   <IN NAME="hours"   TYPE="integer">An increment of hours.</IN>
!   <IN NAME="minutes" TYPE="integer">An increment of minutes.</IN>
!   <IN NAME="seconds" TYPE="integer">An increment of seconds.</IN>
!   <IN NAME="ticks"   TYPE="integer">An increment of ticks.</IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <OUT NAME="increment_date" TYPE="time_type"> A new time based on the input 
!         time interval and the calendar type.
!   </OUT>
!   <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
!     When .false., it is a fatal error if any of the input time increments are negative.
!     This mimics the behavior of lima and earlier revisions.
!   </IN>
!   <NOTE>
!     For all but the thirty_day_months calendar, increments to months
!     and years must be made separately from other units because of the
!     non-associative nature of addition.
!     If the result is a negative time (i.e. date before the base date)
!     it is considered a fatal error.
!   </NOTE>

 function increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)

! Given a time and some date increment, computes a new time.  Depending
! on the mapping algorithm from date to time, it may be possible to specify
! undefined increments (i.e. if one increments by 68 days and 3 months in
! a Julian calendar, it matters which order these operations are done and
! we don't want to deal with stuff like that, make it an error).

! This routine operates in one of two modes.
! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments.
! 2. years and/or months are incremented, other time increments must be zero or absent arguments.

 type(time_type) :: increment_date
 type(time_type), intent(in) :: Time
 integer, intent(in), optional :: years, months, days, hours, minutes, seconds, ticks
 character(len=*), intent(out), optional :: err_msg
 logical, intent(in), optional :: allow_neg_inc

 integer :: oyears, omonths, odays, ohours, ominutes, oseconds, oticks
 character(len=128) :: err_msg_local
 logical :: allow_neg_inc_local

 if(.not.module_is_initialized) call time_manager_init
 if(present(err_msg)) err_msg = ''

! Missing optionals are set to 0
 oseconds = 0; if(present(seconds)) oseconds = seconds
 ominutes = 0; if(present(minutes)) ominutes = minutes
 ohours   = 0; if(present(hours))   ohours   = hours
 odays    = 0; if(present(days))    odays    = days
 omonths  = 0; if(present(months))  omonths  = months
 oyears   = 0; if(present(years))   oyears   = years
 oticks   = 0; if(present(ticks))   oticks   = ticks
 allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc

 if(.not.allow_neg_inc_local) then
   if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0) then
     write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
     if(error_handler('function increment_time', err_msg_local, err_msg)) return
   endif
 endif
 10 format('One or more time increments are negative: '// &
   'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6)

 if(.not.increment_date_private( &
     Time, oyears, omonths, odays, ohours, ominutes, oseconds, oticks, increment_date, err_msg_local)) then
   if(error_handler('function increment_date', err_msg_local, err_msg)) return
 endif
 
 end function increment_date

! </FUNCTION>

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

 function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)

! Given a time and some date increment, computes a new time.  Depending
! on the mapping algorithm from date to time, it may be possible to specify
! undefined increments (i.e. if one increments by 68 days and 3 months in
! a Julian calendar, it matters which order these operations are done and
! we don't want to deal with stuff like that, make it an error).

! This routine operates in one of two modes.
! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments.
! 2. years and/or months are incremented, other time increments must be zero or absent arguments.

! Negative increments are always allowed in the private version of this routine.

 logical :: increment_date_private
 type(time_type),  intent(in)  :: Time
 integer,          intent(in)  :: years, months, days, hours, minutes, seconds, ticks
 type(time_type),  intent(out) :: Time_out
 character(len=*), intent(out) :: err_msg
 integer :: cyear , cmonth , cday , chour , cminute , csecond , ctick 
 logical :: mode_1, mode_2

 err_msg = ''
 increment_date_private = .true.

 mode_1 = days /= 0 .or. hours /= 0 .or. minutes /= 0 .or. seconds /= 0 .or. ticks /= 0
 mode_2 = years /= 0 .or. months /= 0

 if(.not.mode_1 .and. .not.mode_2) then
 ! All time increments are zero
   Time_out = Time
   return
 endif

 if(mode_1 .and. mode_2) then
   err_msg = 'years and/or months must not be incremented with other time units'
   increment_date_private = .false.
   return
 endif

 if(mode_1) then
   csecond = seconds + 60 * (minutes + 60 * hours)
   increment_date_private = increment_time_private(Time, csecond, days, ticks, Time_out, err_msg)
 endif

 if(mode_2) then
 ! Convert Time to a date
   select case(calendar_type)
   case(THIRTY_DAY_MONTHS)
     call get_date_thirty   (Time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
   case(NOLEAP)
     call get_date_no_leap_private  (Time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
   case(JULIAN)
     call get_date_julian_private   (Time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
   case(GREGORIAN)
     call get_date_gregorian(Time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
   case(NO_CALENDAR)
     err_msg = 'Cannot increment a date when the calendar type is NO_CALENDAR'
     increment_date_private = .false.
     return
   case default
     err_msg = 'Invalid calendar type'
     increment_date_private = .false.
     return
   end select

 ! Add month increment
   cmonth = cmonth + months

 ! Adjust year and month number when cmonth falls outside the range 1 to 12
   cyear = cyear + floor((cmonth-1)/12.)
   cmonth = modulo((cmonth-1),12) + 1

 ! Add year increment
   cyear = cyear + years

 ! Convert this back into a time.
   select case(calendar_type)
   case(THIRTY_DAY_MONTHS)
     increment_date_private = set_date_thirty   (cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg)
   case(NOLEAP)
     increment_date_private = set_date_no_leap_private  (cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg)
   case(JULIAN)
     increment_date_private = set_date_julian_private   (cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg)
   case(GREGORIAN)
     increment_date_private = set_date_gregorian(cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg)
   end select
 endif ! if(mode_2)

 end function increment_date_private

!=========================================================================
! <FUNCTION NAME="decrement_date">

!   <OVERVIEW>
!      Decrements the date represented by a time interval and the
!      default calendar type by a number of seconds, etc. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Given a time and some date decrement, computes a new time.  Depending
!      on the mapping algorithm from date to time, it may be possible to specify
!      undefined decrements (i.e. if one decrements by 68 days and 3 months in
!      a Julian calendar, it matters which order these operations are done and
!      we don't want to deal with stuff like that, make it an error).
!   </DESCRIPTION>
!   <TEMPLATE>
!      decrement_date(time, years, months, days, hours, minutes, seconds, ticks, err_msg))
!   </TEMPLATE>
!   <IN NAME="time"    TYPE="time_type"> A time interval.</IN>
!   <IN NAME="years"   TYPE="integer">An decrement of years.</IN>
!   <IN NAME="months"  TYPE="integer">An decrement of months.</IN>
!   <IN NAME="days"    TYPE="integer">An decrement of days.</IN>
!   <IN NAME="hours"   TYPE="integer">An decrement of hours.</IN>
!   <IN NAME="minutes" TYPE="integer">An decrement of minutes.</IN>
!   <IN NAME="seconds" TYPE="integer">An decrement of seconds.</IN>
!   <IN NAME="ticks"   TYPE="integer">An decrement of ticks.</IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <OUT NAME="decrement_date" TYPE="time_type"> A new time based on the input 
!         time interval and the calendar type.
!   </OUT>
!   <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
!     When .false., it is a fatal error if any of the input time increments are negative.
!     This mimics the behavior of lima and earlier revisions.
!   </IN>
!   <NOTE>
!     For all but the thirty_day_months calendar, decrements to months
!     and years must be made separately from other units because of the
!     non-associative nature of addition.
!     If the result is a negative time (i.e. date before the base date)
!     it is considered a fatal error.
!   </NOTE>

 function decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)

 type(time_type) :: decrement_date
 type(time_type), intent(in) :: Time
 integer, intent(in), optional :: seconds, minutes, hours, days, months, years, ticks
 character(len=*), intent(out), optional :: err_msg
 logical, intent(in), optional :: allow_neg_inc

 integer :: oseconds, ominutes, ohours, odays, omonths, oyears, oticks
 character(len=128) :: err_msg_local
 logical :: allow_neg_inc_local

 if(present(err_msg)) err_msg = ''

 ! Missing optionals are set to 0
 oseconds = 0; if(present(seconds)) oseconds = seconds
 ominutes = 0; if(present(minutes)) ominutes = minutes
 ohours   = 0; if(present(hours))   ohours   = hours
 odays    = 0; if(present(days))    odays    = days
 omonths  = 0; if(present(months))  omonths  = months
 oyears   = 0; if(present(years))   oyears   = years
 oticks   = 0; if(present(ticks))   oticks   = ticks
 allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc

 if(.not.allow_neg_inc_local) then
   if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0) then
     write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
     if(error_handler('function decrement_date', err_msg_local, err_msg)) return
   endif
 endif
 10 format('One or more time increments are negative: '// &
   'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6)

 if(.not.increment_date_private( &
     Time, -oyears, -omonths, -odays, -ohours, -ominutes, -oseconds, -oticks, decrement_date, err_msg_local)) then
   if(error_handler('function decrement_date', err_msg_local, err_msg)) return
 endif

 end function decrement_date
 ! </FUNCTION>

!=========================================================================
! START days_in_month BLOCK
! <FUNCTION NAME="days_in_month">

!   <OVERVIEW>
!       Given a time interval, gives the number of days in the
!       month corresponding to the default calendar.
!   </OVERVIEW>
!   <DESCRIPTION>
!       Given a time, computes the corresponding date given the selected
!       date time mapping algorithm.
!   </DESCRIPTION>
!   <TEMPLATE> days_in_month(time) </TEMPLATE>

!   <IN NAME="time" UNITS="" TYPE="time_type" DIM="">A time interval.</IN>
!   <OUT NAME="days_in_month" UNITS="" TYPE="integer" DIM="" DEFAULT="">
!       The number of days in the month given the selected time
!       mapping algorithm.
!   </OUT>

function days_in_month(Time, err_msg)

! Given a time, computes the corresponding date given the selected
! date time mapping algorithm

integer :: days_in_month
type(time_type), intent(in) :: Time
character(len=*), intent(out), optional :: err_msg

if(.not.module_is_initialized) call time_manager_init
if(present(err_msg)) err_msg = ''

select case(calendar_type)
case(THIRTY_DAY_MONTHS)
   days_in_month = days_in_month_thirty(Time)
case(GREGORIAN)
   days_in_month = days_in_month_gregorian(Time)
case(JULIAN)
   days_in_month = days_in_month_julian(Time)
case(NOLEAP)
   days_in_month = days_in_month_no_leap(Time)
case(NO_CALENDAR)
   if(error_handler('function days_in_month', &
         'days_in_month makes no sense when the calendar type is NO_CALENDAR', err_msg)) return
case default
   if(error_handler('function days_in_month', 'Invalid calendar type', err_msg)) return
end select
end function days_in_month
! </FUNCTION>

!--------------------------------------------------------------------------

function days_in_month_gregorian(Time)

! Returns the number of days in a gregorian month.

integer :: days_in_month_gregorian
type(time_type), intent(in) :: Time
integer :: year, month, day, hour, minute, second, ticks

call get_date_gregorian(Time, year, month, day, hour, minute, second, ticks)
days_in_month_gregorian = days_per_month(month)
if(leap_year_gregorian_int(year) .and. month == 2) days_in_month_gregorian = 29

end function days_in_month_gregorian

!--------------------------------------------------------------------------
function days_in_month_julian(Time)

! Returns the number of days in a julian month.

integer :: days_in_month_julian
type(time_type), intent(in) :: Time
integer :: year, month, day, hour, minute, second, ticks

call get_date_julian_private(Time, year, month, day, hour, minute, second, ticks)
days_in_month_julian = days_per_month(month)
if(leap_year_julian(Time) .and. month == 2) days_in_month_julian = 29

end function days_in_month_julian

!--------------------------------------------------------------------------
function days_in_month_thirty(Time)

! Returns the number of days in a thirty day month (needed for transparent
! changes to calendar type).

integer :: days_in_month_thirty
type(time_type), intent(in) :: Time

days_in_month_thirty = 30

end function days_in_month_thirty

!--------------------------------------------------------------------------
function days_in_month_no_leap(Time)

! Returns the number of days in a 365 day year month.

integer :: days_in_month_no_leap
type(time_type), intent(in) :: Time
integer :: year, month, day, hour, minute, second, ticks

call get_date_no_leap_private(Time, year, month, day, hour, minute, second, ticks)
days_in_month_no_leap= days_per_month(month)

end function days_in_month_no_leap

! END OF days_in_month BLOCK
!==========================================================================
! START OF leap_year BLOCK
! <FUNCTION NAME="leap_year">

!   <OVERVIEW>
!      Returns true if the year corresponding to the input time is
!      a leap year. Always returns false for THIRTY_DAY_MONTHS and NOLEAP.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns true if the year corresponding to the input time is
!      a leap year. Always returns false for THIRTY_DAY_MONTHS and NOLEAP.
!   </DESCRIPTION>
!   <TEMPLATE> leap_year(time) </TEMPLATE>

!   <IN NAME="time" UNITS="" TYPE="time_type" DIM="">A time interval.</IN>
!   <OUT NAME="leap_year" UNITS="" TYPE="calendar_type" DIM="" DEFAULT="">
!      true if the year corresponding to the input time is a leap year.
!   </OUT>

function leap_year(Time, err_msg)

! Is this date in a leap year for default calendar?

logical :: leap_year
type(time_type), intent(in) :: Time
character(len=*), intent(out), optional :: err_msg

if(.not.module_is_initialized) call time_manager_init
if(present(err_msg)) err_msg=''

select case(calendar_type)
case(THIRTY_DAY_MONTHS)
   leap_year = leap_year_thirty(Time)
case(GREGORIAN)
   leap_year = leap_year_gregorian(Time)
case(JULIAN)
   leap_year = leap_year_julian(Time)
case(NOLEAP)
   leap_year = leap_year_no_leap(Time)
case default
   if(error_handler('function leap_year', 'Invalid calendar type in leap_year', err_msg)) return
end select
end function leap_year
! </FUNCTION>

!--------------------------------------------------------------------------

function leap_year_gregorian(Time)

! Is this a leap year for gregorian calendar?

logical :: leap_year_gregorian
type(time_type), intent(in) :: Time
integer :: seconds, minutes, hours, day, month, year

call get_date(Time, year, month, day, hours, minutes, seconds)
leap_year_gregorian = leap_year_gregorian_int(year)

end function leap_year_gregorian

!--------------------------------------------------------------------------

function leap_year_gregorian_int(year)
logical :: leap_year_gregorian_int
integer, intent(in) :: year

leap_year_gregorian_int = mod(year,4) == 0
leap_year_gregorian_int = leap_year_gregorian_int .and. .not.mod(year,100) == 0
leap_year_gregorian_int = leap_year_gregorian_int .or. mod(year,400) == 0

end function leap_year_gregorian_int

!--------------------------------------------------------------------------

function leap_year_julian(Time)

! Returns the number of days in a julian month.

logical :: leap_year_julian
type(time_type), intent(in) :: Time
integer :: seconds, minutes, hours, day, month, year

call get_date(Time, year, month, day, hours, minutes, seconds)
leap_year_julian = ((year / 4 * 4) == year)

end function leap_year_julian

!--------------------------------------------------------------------------

function leap_year_thirty(Time)

! No leap years in thirty day months, included for transparency. 

logical :: leap_year_thirty
type(time_type), intent(in) :: Time

leap_year_thirty = .FALSE.

end function leap_year_thirty

!--------------------------------------------------------------------------

function leap_year_no_leap(Time)

! Another tough one; no leap year returns false for leap year inquiry.

logical :: leap_year_no_leap
type(time_type), intent(in) :: Time

leap_year_no_leap = .FALSE.

end function leap_year_no_leap

!END OF leap_year BLOCK
!==========================================================================
! START OF length_of_year BLOCK
! <FUNCTION NAME="length_of_year">

!   <OVERVIEW>
!      Returns the mean length of the year in the default calendar setting. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      There are no arguments in this function. It returns the mean
!      length of the year in the default calendar setting.
!   </DESCRIPTION>
!   <TEMPLATE> length_of_year() </TEMPLATE>

function length_of_year()

! What is the length of the year for the default calendar type

type(time_type) :: length_of_year

if(.not.module_is_initialized) call time_manager_init

select case(calendar_type)
case(THIRTY_DAY_MONTHS)
   length_of_year = length_of_year_thirty()
case(GREGORIAN)
   length_of_year = length_of_year_gregorian()
case(JULIAN)
   length_of_year = length_of_year_julian()
case(NOLEAP)
   length_of_year = length_of_year_no_leap()
case default
   call error_mesg('length_of_year','Invalid calendar type in length_of_year',FATAL)
end select
end function length_of_year
! </FUNCTION>

!--------------------------------------------------------------------------

function length_of_year_thirty()

type(time_type) :: length_of_year_thirty

length_of_year_thirty = set_time(0, 360)

end function length_of_year_thirty

!---------------------------------------------------------------------------

function length_of_year_gregorian()

type(time_type) :: length_of_year_gregorian
integer :: days, seconds

days = days_in_400_year_period / 400
seconds = 86400*(days_in_400_year_period/400. - days)
length_of_year_gregorian = set_time(seconds, days)

end function length_of_year_gregorian

!--------------------------------------------------------------------------

function length_of_year_julian()

type(time_type) :: length_of_year_julian

length_of_year_julian = set_time((24 / 4) * 60 * 60, 365)

end function length_of_year_julian

!--------------------------------------------------------------------------

function length_of_year_no_leap()

type(time_type) :: length_of_year_no_leap

length_of_year_no_leap = set_time(0, 365)

end function length_of_year_no_leap

!--------------------------------------------------------------------------

! END OF length_of_year BLOCK
!==========================================================================

! START OF days_in_year BLOCK
! <FUNCTION NAME="days_in_year">

!   <OVERVIEW>
!      Returns the number of days in the calendar year corresponding to
!      the date represented by time for the default calendar.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns the number of days in the calendar year corresponding to
!      the date represented by time for the default calendar.
!   </DESCRIPTION>
!   <TEMPLATE> days_in_year(Time) </TEMPLATE>
!   <IN NAME="Time" TYPE="time_type">A time interval.</IN>
!   <OUT>
!      The number of days in this year for the default calendar type.
!   </OUT>


function days_in_year(Time)

! What is the number of days in this year for the default calendar type

integer :: days_in_year
type(time_type), intent(in) :: Time

if(.not.module_is_initialized) call time_manager_init

select case(calendar_type)
case(THIRTY_DAY_MONTHS)
   days_in_year = days_in_year_thirty(Time)
case(GREGORIAN)
   days_in_year = days_in_year_gregorian(Time)
case(JULIAN)
   days_in_year = days_in_year_julian(Time)
case(NOLEAP)
   days_in_year = days_in_year_no_leap(Time)
case default
   call error_mesg('days_in_year','Invalid calendar type in days_in_year',FATAL)
end select
end function days_in_year
! </FUNCTION>

!--------------------------------------------------------------------------

function days_in_year_thirty(Time)

integer :: days_in_year_thirty
type(time_type), intent(in) :: Time

days_in_year_thirty = 360

end function days_in_year_thirty

!---------------------------------------------------------------------------

function days_in_year_gregorian(Time)

integer :: days_in_year_gregorian
type(time_type), intent(in) :: Time

if(leap_year_gregorian(Time)) then
  days_in_year_gregorian = 366
else
  days_in_year_gregorian = 365
endif

end function days_in_year_gregorian

!--------------------------------------------------------------------------
function days_in_year_julian(Time)

integer :: days_in_year_julian
type(time_type), intent(in) :: Time

if(leap_year_julian(Time)) then
   days_in_year_julian = 366
else
   days_in_year_julian = 365
endif

end function days_in_year_julian

!--------------------------------------------------------------------------

function days_in_year_no_leap(Time)

integer :: days_in_year_no_leap
type(time_type), intent(in) :: Time

days_in_year_no_leap = 365

end function days_in_year_no_leap

!--------------------------------------------------------------------------

! END OF days_in_year BLOCK

!==========================================================================
! <FUNCTION NAME="month_name">

!   <OVERVIEW>
!      Returns a character string containing the name of the
!      month corresponding to month number n. 
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns a character string containing the name of the
!      month corresponding to month number n. Definition is the
!      same for all calendar types. 
!   </DESCRIPTION>
!   <TEMPLATE> month_name(n) </TEMPLATE>
!   <IN NAME="n" TYPE="integer">Month number.</IN>
!   <OUT NAME="month_name" TYPE="character(len=9)">
!      The character string associated with a month.
!      All calendars have 12 months and return full
!      month names, not abreviations.
!   </OUT>

function month_name(n)

! Returns character string associated with a month, for now, all calendars
! have 12 months and will return standard names.

character (len=9) :: month_name
integer, intent(in) :: n
character (len = 9), dimension(12) :: months = (/'January  ', 'February ', &
          'March    ', 'April    ', 'May      ', 'June     ', 'July     ', &
          'August   ', 'September', 'October  ', 'November ', 'December '/) 

if(.not.module_is_initialized) call time_manager_init

if(n < 1 .or. n > 12) call error_mesg('month_name','Illegal month index',FATAL)

month_name = months(n)

end function month_name
! </FUNCTION>

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

 function error_handler(routine, err_msg_local, err_msg)

! The purpose of this routine is to prevent the addition of an excessive amount of code in order to implement
! the error handling scheme involving an optional error flag of type character.
! It allows one line of code to accomplish what would otherwise require 6 lines.
! A value of .true. for this function is a flag to the caller that it should immediately return to it's caller.

 logical :: error_handler
 character(len=*), intent(in) :: routine, err_msg_local
 character(len=*), intent(out), optional :: err_msg

 error_handler = .false.
 if(present(err_msg)) then
   err_msg = err_msg_local
   error_handler = .true.    
 else
   call error_mesg(trim(routine),trim(err_msg_local),FATAL)
 endif

 end function error_handler

!==========================================================================
!------------------------------------------------------------------------
! <SUBROUTINE NAME="time_manager_init">

!   <OVERVIEW>
!      Writes the version information to the log file
!   </OVERVIEW>
!   <DESCRIPTION>
!      Initialization routine.
!      Writes the version information to the log file
!   </DESCRIPTION>
!   <TEMPLATE>time_manager_init()</TEMPLATE>

subroutine time_manager_init ( )

  if (module_is_initialized) return  ! silent return if already called

  call write_version_number (version, tagname)
  module_is_initialized = .true.

end subroutine time_manager_init
! </SUBROUTINE>

!------------------------------------------------------------------------
! <SUBROUTINE NAME="print_time">

!   <OVERVIEW>
!      Prints the given time_type argument as a time (using days, seconds and ticks)
!   </OVERVIEW>
!   <DESCRIPTION>
!      Prints the given time_type argument as a time (using days, seconds and ticks)
!      NOTE: there is no check for PE number.
!   </DESCRIPTION>
!   <TEMPLATE>print_time (time,str,unit)</TEMPLATE>
!   <IN NAME="time" TYPE="time_type"> Time that will be printed. </IN>
!   <IN NAME="str" TYPE="character (len=*)" DEFAULT="TIME: or DATE:"> 
!      Character string that precedes the printed time or date.
!   </IN>
!   <IN NAME="unit" TYPE="integer">
!      Unit number for printed output. The default unit is stdout.
!   </IN>
subroutine print_time (Time,str,unit)
type(time_type)  , intent(in) :: Time
character (len=*), intent(in), optional :: str
integer          , intent(in), optional :: unit
integer :: s,d,ticks, ns,nd,nt, unit_in
character(len=19) :: fmt

! prints the time to standard output (or optional unit) as days and seconds
! NOTE: there is no check for PE number

  unit_in = stdout()
  if (present(unit)) unit_in = unit

  call get_time (Time,s,d,ticks)

! format output
! get number of digits for days and seconds strings
   nd = int(log10(real(max(1,d))))+1
   ns = int(log10(real(max(1,s))))+1
   nt = int(log10(real(max(1,ticks))))+1
   write (fmt,10) nd, ns, nt
10 format ('(a,i',i2.2,',a,i',i2.2,',a,i',i2.2,')')

  if (present(str)) then
     write (unit_in,fmt) trim(str)//' day=', d, ', sec=', s, ', ticks=', ticks
  else
     write (unit_in,fmt)       'TIME: day=', d, ', sec=', s, ', ticks=', ticks
  endif

end subroutine print_time
! </SUBROUTINE>

!------------------------------------------------------------------------
! <SUBROUTINE NAME="print_date">

!   <OVERVIEW>
!      prints the time to standard output (or optional unit) as a date.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Prints the given time_type argument as a date (using year, month, day,
!      hour, minutes, seconds and ticks). NOTE: there is no check for PE number.
!   </DESCRIPTION>
!   <TEMPLATE> print_date (time,str,unit)
!   </TEMPLATE>
!   <IN NAME="time" TYPE="time_type"> Time that will be printed. </IN>
!   <IN NAME="str" TYPE="character (len=*)" DEFAULT="TIME: or DATE:"> 
!      Character string that precedes the printed time or date.
!   </IN>
!   <IN NAME="unit" TYPE="integer">
!      Unit number for printed output. The default unit is stdout.
!   </IN>

subroutine print_date (Time,str,unit)
type(time_type)  , intent(in) :: Time
character (len=*), intent(in), optional :: str
integer          , intent(in), optional :: unit
integer :: y,mo,d,h,m,s, unit_in
character(len=9) :: mon

! prints the time to standard output (or optional unit) as a date
! NOTE: there is no check for PE number

  unit_in = stdout()
  if (present(unit)) unit_in = unit

  call get_date (Time,y,mo,d,h,m,s)
  mon = month_name(mo)
  if (present(str)) then
     write (unit_in,10) trim(str)//' ', y,mon(1:3),' ',d,' ',h,':',m,':',s
  else
     write (unit_in,10)       'DATE: ', y,mon(1:3),' ',d,' ',h,':',m,':',s
  endif
10 format (a,i4,1x,a3,4(a1,i2.2))

end subroutine print_date
! </SUBROUTINE>

!------------------------------------------------------------------------
! <FUNCTION NAME="valid_calendar_types">

!   <OVERVIEW>
!     Returns a character string that describes the
!     calendar type corresponding to the input integer.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns a character string that describes the
!     calendar type corresponding to the input integer.
!   </DESCRIPTION>
!   <IN NAME="ncal" TYPE="integer">
!     An integer corresponding to a valid calendar type.
!   </IN>
!   <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
!     When present, and when non-blank, a fatal error condition as been detected.
!     The string itself is an error message.
!     It is recommended that, when err_msg is present in the call
!     to this routine, the next line of code should be something
!     similar to this:
!     if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
!   </OUT>
!   <OUT NAME="valid_calendar_types" TYPE="character(len=24)">
!     A character string describing the calendar type.
!   </OUT>

function valid_calendar_types(ncal, err_msg)
integer, intent(in) :: ncal
character(len=*), intent(out), optional :: err_msg
character(len=24) :: valid_calendar_types
character(len=128) :: err_msg_local

if(.not.module_is_initialized) call time_manager_init

if(present(err_msg)) err_msg = ''

if(ncal == NO_CALENDAR) then
  valid_calendar_types = 'NO_CALENDAR             '
else if(ncal == THIRTY_DAY_MONTHS) then
  valid_calendar_types = 'THIRTY_DAY_MONTHS       '
else if(ncal == JULIAN) then
  valid_calendar_types = 'JULIAN                  '
else if(ncal == GREGORIAN) then
  valid_calendar_types = 'GREGORIAN               '
else if(ncal == NOLEAP) then
  valid_calendar_types = 'NOLEAP                  '
else
  write(err_msg_local,'(a,i4,a)') 'calendar type=',ncal,' is invalid.'
  if(error_handler('function valid_calendar_types', err_msg_local, err_msg)) return
endif
end function valid_calendar_types
! </FUNCTION>
!------------------------------------------------------------------------

!--- get the a character string that represents the time. The format will be 
!--- yyyymmdd.hhmmss
function date_to_string(time, err_msg)
  type(time_type),  intent(in)            :: time
  character(len=*), intent(out), optional :: err_msg
  character(len=128)                      :: err_msg_local
  character(len=15)                       :: date_to_string
  integer                                 :: yr,mon,day,hr,min,sec

  if(present(err_msg)) err_msg = ''
  call get_date(time,yr,mon,day,hr,min,sec)
  if (yr <= 9999) then
     write(date_to_string,'(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec
  else
     write(err_msg_local, '(a,i4.4,a)') 'year = ', yr, ' should be less than 10000'
     if(error_handler('function date_to_string', err_msg_local, err_msg)) return
  endif

end function date_to_string

end module time_manager_mod

! <INFO>

!   <TESTPROGRAM NAME="time_main2">  
!    <PRE>
!        use time_manager_mod
!        implicit none
!        type(time_type) :: dt, init_date, astro_base_date, time, final_date
!        type(time_type) :: next_rad_time, mid_date
!        type(time_type) :: repeat_alarm_freq, repeat_alarm_length
!        integer :: num_steps, i, days, months, years, seconds, minutes, hours
!        integer :: months2, length
!        real :: astro_days
!   
!   !Set calendar type
!   !    call set_calendar_type(THIRTY_DAY_MONTHS)
!        call set_calendar_type(JULIAN)
!   !    call set_calendar_type(NOLEAP)
!   
!   ! Set timestep
!        dt = set_time(1100, 0)
!   
!   ! Set initial date
!        init_date = set_date(1992, 1, 1)
!   
!   ! Set date for astronomy delta calculation
!        astro_base_date = set_date(1970, 1, 1, 12, 0, 0)
!   
!   ! Copy initial time to model current time
!        time = init_date
!   
!   ! Determine how many steps to do to run one year
!        final_date = increment_date(init_date, years = 1)
!        num_steps = (final_date - init_date) / dt
!        write(*, *) 'Number of steps is' , num_steps
!   
!   ! Want to compute radiation at initial step, then every two hours
!        next_rad_time = time + set_time(7200, 0)
!   
!   ! Test repeat alarm
!        repeat_alarm_freq = set_time(0, 1)
!        repeat_alarm_length = set_time(7200, 0)
!   
!   ! Loop through a year
!        do i = 1, num_steps
!   
!   ! Increment time
!        time = time + dt
!   
!   ! Test repeat alarm
!        if(repeat_alarm(time, repeat_alarm_freq, repeat_alarm_length)) &
!        write(*, *) 'REPEAT ALARM IS TRUE'
!   
!   ! Should radiation be computed? Three possible tests.
!   ! First test assumes exact interval; just ask if times are equal
!   !     if(time == next_rad_time) then
!   ! Second test computes rad on last time step that is <= radiation time
!   !     if((next_rad_time - time) < dt .and. time < next_rad) then
!   ! Third test computes rad on time step closest to radiation time
!         if(interval_alarm(time, dt, next_rad_time, set_time(7200, 0))) then
!           call get_date(time, years, months, days, hours, minutes, seconds)
!           write(*, *) days, month_name(months), years, hours, minutes, seconds
!   
!   ! Need to compute real number of days between current time and astro_base
!           call get_time(time - astro_base_date, seconds, days)
!           astro_days = days + seconds / 86400.
!   !       write(*, *) 'astro offset ', astro_days
!        end if
!   
!   ! Can compute daily, monthly, yearly, hourly, etc. diagnostics as for rad
!   
!   ! Example: do diagnostics on last time step of this month
!        call get_date(time + dt, years, months2, days, hours, minutes, seconds)
!        call get_date(time, years, months, days, hours, minutes, seconds)
!        if(months /= months2) then
!           write(*, *) 'last timestep of month'
!           write(*, *) days, months, years, hours, minutes, seconds
!        endif
!   
!   ! Example: mid-month diagnostics; inefficient to make things clear
!        length = days_in_month(time)
!        call get_date(time, years, months, days, hours, minutes, seconds)
!        mid_date = set_date(years, months, 1) + set_time(0, length) / 2
!   
!        if(time < mid_date .and. (mid_date - time) < dt) then
!           write(*, *) 'mid-month time'
!           write(*, *) days, months, years, hours, minutes, seconds
!        endif
!   
!        end do
!   
!    </PRE>
!   end program time_main2

!   </TESTPROGRAM>
!   <NOTE>
!     The <a name="base date">base date</a> is implicitly defined so users don't 
!     need to be concerned with it. For the curious, the base date is defined as 
!     0 seconds, 0 minutes, 0 hours, day 1, month 1, year 1
!   </NOTE>
!   <NOTE>
!     Please note that a time is a positive definite quantity.
!   </NOTE>
!   <NOTE>
!     See the <LINK SRC="TEST PROGRAM">Test Program </LINK> for a simple program 
!     that shows some of the capabilities of the time manager.
!   </NOTE>
! </INFO>

#ifdef test_time_manager
 program test
 use          mpp_mod, only: input_nml_file
 use          fms_mod, only: fms_init, fms_end, stderr
 use          fms_mod, only: open_namelist_file, check_nml_error, close_file, open_file
 use    constants_mod, only: constants_init, rseconds_per_day=>seconds_per_day
 use       fms_io_mod, only: fms_io_exit
 use time_manager_mod, only: time_type, set_date, get_date, set_time, set_calendar_type, real_to_time_type
 use time_manager_mod, only: length_of_year, leap_year, days_in_month, days_in_year, print_time
 use time_manager_mod, only: set_ticks_per_second, get_ticks_per_second
 use time_manager_mod, only: decrement_date, increment_date, get_time, increment_time, decrement_time
 use time_manager_mod, only: JULIAN, GREGORIAN, THIRTY_DAY_MONTHS, NOLEAP
 use time_manager_mod, only: operator(-), operator(+),  operator(*),  operator(/),  &
                             operator(>), operator(>=), operator(==), operator(/=), &
                             operator(<), operator(<=), operator(//), assignment(=)

 implicit none

 type(time_type) :: Time, time1, time2
 real    :: xx
 integer :: yr, mo, day, hr, min, sec, ticks
 integer :: year, month, dday, days_this_month
 integer :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
 logical :: leap
 integer :: nr, icode, nmlunit, ierr, io, nn, errunit, outunit
 character(len=256) :: err_msg, char_date
 character(len=8),  allocatable, dimension(:) :: test_time
 character(len=23), allocatable, dimension(:) :: test_date
 character(len=8) :: test_name

logical :: test1 =.true.,test2 =.true.,test3 =.true.,test4 =.true.,test5 =.true.,test6 =.true.,test7 =.true.,test8 =.true.
logical :: test9 =.true.,test10=.true.,test11=.true.,test12=.true.,test13=.true.,test14=.true.,test15=.true.,test16=.true.
logical :: test17=.true.,test18=.true.,test19=.true.

 namelist / test_nml / test1 ,test2 ,test3 ,test4 ,test5 ,test6 ,test7 ,test8,  &
                       test9 ,test10,test11,test12,test13,test14,test15,test16, &
                       test17,test18,test19

 call fms_init
 call constants_init

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, test_nml, iostat=io)
#else
 nmlunit = open_namelist_file()
 ierr=1
 do while (ierr /= 0)
   read(nmlunit, nml=test_nml, iostat=io, end=12)
   ierr = check_nml_error (io, 'test_nml')
 enddo
 12 call close_file (nmlunit)
#endif

 outunit = open_file(file='test_time_manager.out', form='formatted', action='write')
 errunit = stderr()
 call set_ticks_per_second(10)

 !==============================================================================================
 ! Tests of set_time_i and get_time without ticks

 if(test1) then
   write(outunit,'(/,a)') '#################################  test1  #################################' 
   Time = set_time(seconds=2, days=1)
   call get_time(Time, sec, day, ticks)
   write(outunit,'(a,i2,a,i8,a,i2)') ' test1.1: days=',day,' seconds=',sec,' ticks=',ticks
   call get_time(Time, sec, day)
   write(outunit,'(a,i2,a,i8)') ' test1.2: days=',day,' seconds=',sec
   call get_time(Time, sec)
   write(outunit,'(a,i8)') ' test1.2: seconds=',sec
 endif
 !==============================================================================================
 ! Tests of set_time_i and get_time with ticks

 if(test2) then
   write(outunit,'(/,a)') '#################################  test2  #################################' 
   Time = set_time(seconds=2, days=1, ticks=5)
   call get_time(Time, sec, day, ticks)
   write(outunit,'(a,i2,a,i6,a,i2)') ' test2.1: days=',day,' seconds=',sec,' ticks=',ticks
   call get_time(Time, sec, ticks=ticks)
   write(outunit,'(a,i6,a,i2)') ' test2.2: seconds=',sec,' ticks=',ticks
   call get_time(Time, sec, day, err_msg=err_msg)
   if(err_msg /= '') then
     write(outunit,'(a)') ' test2.3 successful: '//trim(err_msg)
   else
     write(outunit,'(a,i2,a,i8)') ' test2.3 fails. days=',day,' seconds=',sec
   endif
   call get_time(Time, sec, err_msg=err_msg)
   if(err_msg /= '') then
     write(outunit,'(a)') ' test2.4 successful: '//trim(err_msg)
   else
     write(outunit,'(a,i8)') ' test2.4 fails.  seconds=',sec
   endif
 endif
 !==============================================================================================
 ! Tests of time operators
 ! Test of function scalar_time_mult is not necessary, it simply calls time_scalar_mult.
 ! Test of function time_ne is not necessary, it simply calls time_eq.
 ! Test of function time_ge is not necessary, it simply calls time_gt.
 ! Test of function time_le is not necessary, it simply calls time_lt and time_eq.
 ! Test of function time_ne is not necessary, it simply calls time_eq.

  if(test3) then
    write(outunit,'(/,a)') '#################################  test3  #################################'
 !  Test of function time_plus
    call print_time(set_time(seconds=0, days=2, ticks=5) + set_time(seconds=0, days=2, ticks=6), 'test3.1:', unit=outunit)

 !  Test of function time_minus
 !  The minus operator for time ensures a positive result. In effect is does this: abs(time1-time2)
    call print_time(set_time(seconds=0, days=2, ticks=5) - set_time(seconds=0, days=2, ticks=6), 'test3.2:', unit=outunit)

 !  Test of function time_scalar_mult.  Note that 25000*86399 is greater than huge = 2**31 - 1
    call print_time(2*set_time(seconds=0, days=2, ticks=6), 'test3.3:', unit=outunit)
    call print_time(25000*set_time(seconds=86399, days=0, ticks=0), 'test3.4:', unit=outunit)

 !  Test of function time_scalar_divide
    call print_time(set_time(seconds=0, days=60000, ticks=2)/2, 'test3.5:', unit=outunit)

 !  Test of function time_real_divide
    xx = set_time(seconds=0, days=60000, ticks=2)//set_time(seconds=86400)
    write(outunit,'("test3.6: xx=",f15.9)') xx

 !  Test of function time_divide
    nn = set_time(seconds=0, days=60000, ticks=2)//set_time(seconds=86400)
    write(outunit,'("test3.7: nn=",i6)') nn

 !  Test of function time_gt
    if(set_time(seconds=1, days=1, ticks=2) > set_time(seconds=1, days=1, ticks=1)) then
      write(outunit,'("test3.8 successful")')
    else
      write(outunit,'("test3.8 fails")')
    endif
    if(set_time(seconds=1, days=1, ticks=2) > set_time(seconds=1, days=1, ticks=2)) then
      write(outunit,'("test3.9 fails")')
    else
      write(outunit,'("test3.9 successful")')
    endif

 !  Test of function time_lt
    if(set_time(seconds=1, days=1, ticks=1) < set_time(seconds=1, days=1, ticks=2)) then
      write(outunit,'("test3.10 successful")')
    else
      write(outunit,'("test3.10 fails")')
    endif
    if(set_time(seconds=1, days=1, ticks=2) < set_time(seconds=1, days=1, ticks=2)) then
      write(outunit,'("test3.11 fails")')
    else
      write(outunit,'("test3.11 successful")')
    endif

 !  Test of function time_eq
    if(set_time(seconds=1, days=1, ticks=1) == set_time(seconds=1, days=1, ticks=1)) then
      write(outunit,'("test3.12 successful")')
    else
      write(outunit,'("test3.12 fails")')
    endif
    if(set_time(seconds=1, days=1, ticks=1) == set_time(seconds=1, days=1, ticks=2)) then
      write(outunit,'("test3.13 fails")')
    else
      write(outunit,'("test3.13 successful")')
    endif
  endif
 !==============================================================================================
 ! Tests of set_time_c

 if(test4) then
   write(outunit,'(/,a)') '#################################  test4  #################################'
   test_name = 'test4.  '
   allocate(test_time(15))
   test_time( 1: 6) = (/'1 10    ','1 10.   ','1 10.000','1  0.0  ','1   .000','1   .   '/)
   test_time( 7: 9) = (/'1 10.20 ','1 10.300','1  0.40 '/)
   test_time(10:15) = (/'1   .510','2 .50001','1.0 10.2','10.30000','10-0.40 ','10:1.510'/) ! invalid forms
   do nr=1,9
     write(test_name(7:8),'(i2.2)') nr
     Time = set_time(trim(test_time(nr)), err_msg=err_msg, allow_rounding=.false.)
     if(err_msg == '') then
       call print_time(Time, test_name//':', unit=outunit)
     else
       write(outunit,'(a)') test_name//' fails: '//trim(err_msg)
     endif
   enddo

   test_time(1:6) = (/'1   .510','2 .50001','1.0 10.2','10.30000','10-0.40 ','10:1.510'/)
   do nr=10,15
     write(test_name(7:8),'(i2.2)') nr
     Time = set_time(trim(test_time(nr)), err_msg=err_msg, allow_rounding=.false.)
     if(err_msg /= '') then
       write(outunit,'(a)') test_name//' successful: '//trim(err_msg)
     else
       write(outunit,'(a)') test_name//' fails '
     endif
   enddo
 endif

 !==============================================================================================
 ! Tests of set_date_i
 
 if(test5) then
   write(outunit,'(/,a)') '#################################  test5  #################################'
   call set_calendar_type(JULIAN)
   call print_time(set_date(1980, 1, 1, 0, 0, 0),' test5.1:', unit=outunit)
   call print_time(set_date(1980, 1, 2, 3, 4, 5, 6),' test5.2:', unit=outunit)
   call print_time(set_date(1980, 1, 2, tick=6),' test5.3:', unit=outunit)
   Time = set_date(1980, 1, 2, tick=10, err_msg=err_msg)
   if(err_msg == '') then
     write(outunit,'(a)') ' test5.4 fails'
   else
     write(outunit,'(a)') ' test5.4 successful: '//trim(err_msg)
   endif
 endif
 !==============================================================================================
 ! Tests of set_date_c

 if(test6) then
   write(outunit,'(/,a)') '#################################  test6  #################################'
   test_name = 'test6.  '
   call set_calendar_type(GREGORIAN)
   allocate(test_date(6))
   test_date(1:3) = (/' 1980-12-30 01:01:11   ',' 1980-12-30 01:01:11.50',' 1980-12-30 01:01:11.55'/)
   test_date(4:6) = (/' 1980-12-30 01:01:11.96','   1980-1-3 1:1:11     ','   1980-1-3 1:1:11.99  '/)
   do nr=1,6
     write(test_name(7:8),'(i2.2)') nr
     Time = set_date(trim(test_date(nr)), err_msg=err_msg, allow_rounding=.true., zero_year_warning=.true.)
     if(err_msg == '') then
       call print_time(Time,test_name//' successful:', unit=outunit)
     else
       write(outunit,'(a)') test_name//'fails: '//trim(err_msg)
     endif
   enddo
   call set_calendar_type(THIRTY_DAY_MONTHS)
   call print_time(set_date('1900-02-30 00:00:00'),'test6.7:', unit=outunit)
   Time = set_date('1900-01-31 00:00:00', err_msg=err_msg)
   if(err_msg == '') then
     write(outunit,'(a)') 'test6.8 fails'
   else
     write(outunit,'(a)') 'test6.8 successful '//trim(err_msg)
   endif
   call set_calendar_type(JULIAN)
   Time = set_date('1901-02-29 00:00:00', err_msg=err_msg)
   if(err_msg == '') then
     write(outunit,'(a)') 'test6.9 fails'
   else
     write(outunit,'(a)') 'test6.9 successful '//trim(err_msg)
   endif
 endif
!==============================================================================================
! Tests of decrement_date and increment_date

 if(test7) then
   write(outunit,'(/,a)') '#################################  test7  #################################'
   char_date = '1904-01-01 00:00:00'
   write(outunit,'(a)') ' Initial date='//trim(char_date)//':00'

   do nr=1,4
     write(outunit,'("=================================================================")')
     if(nr == 1) then
       call set_calendar_type(THIRTY_DAY_MONTHS)
       write(outunit,'(" THIRTY_DAY_MONTHS")')
     endif
     if(nr == 2) then
       call set_calendar_type(NOLEAP)
       write(outunit,'(" NOLEAP")')
     endif
     if(nr == 3) then
       call set_calendar_type(JULIAN)
       write(outunit,'(" JULIAN")')
     endif
     if(nr == 4) then
       call set_calendar_type(GREGORIAN)
       write(outunit,'(" GREGORIAN")')
     endif
     time1 = set_date(trim(char_date))
     do year=-1,1
       do month=-1,1
         write(outunit,'(" test of decrement_date increments: year=",i2," month=",i2)') year,month
         time2 = decrement_date(time1, year, month, err_msg=err_msg)
         if(err_msg /= '') then
           write(outunit,'(a)') 'test of decrement_date fails '//trim(err_msg)
         else
           call get_date(time2, yr, mo, day, hr, min, sec, ticks)
           write(outunit,20) yr, mo, day, hr, min, sec, ticks
         endif
       enddo
     enddo
     time1 = set_date(1, 1, 2, 1, 1, 1, 1, err_msg)
     write(outunit,'(" Initial date = 01-01-02 01:01:01:01")')
     do icode=0,242
       day   = modulo(icode/81,3) - 1
       hr    = modulo(icode/27,3) - 1
       min   = modulo(icode/9, 3) - 1
       sec   = modulo(icode/3, 3) - 1
       ticks = modulo(icode   ,3) - 1
       write(outunit,11) day, hr, min, sec, ticks
       time2 = increment_date(time1, 0, 0, day, hr, min, sec, ticks, err_msg)
       call get_date(time2, yr, mo, day, hr, min, sec, ticks)
       write(outunit,20) yr, mo, day, hr, min, sec, ticks
     enddo
   enddo
 endif

  11 format(' test of increment_date increments: day=',i2,' hr=',i2,' min=',i2,' sec=',i2,' ticks=',i2)
  20 format(' time=',i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2, ':', i2.2)
 !==============================================================================================
 ! Tests involving Feb 29

  if(test8) then
    write(outunit,'(/,a)') '#################################  test8  #################################'
    call set_calendar_type(THIRTY_DAY_MONTHS)
    Time = set_date('1904-02-29 00:00:00', err_msg=err_msg)
    if(err_msg == '') then
      call print_time(Time, 'test8.1 successful', unit=outunit)
    else
      write(outunit,'(a)') 'test8.1 fails: '//trim(err_msg)
    endif

    call set_calendar_type(NOLEAP)
    Time = set_date('1904-02-29 00:00:00', err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test8.2 fails'
    else
      write(outunit,'(a)') 'test8.2 successful: '//trim(err_msg)
    endif

    call set_calendar_type(GREGORIAN)
    Time = set_date('1900-02-29 00:00:00', err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test8.3 fails'
    else
      write(outunit,'(a)') 'test8.3 successful: '//trim(err_msg)
    endif
    Time = set_date('2000-02-29 00:00:00', err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test8.4 successful'
    else
      write(outunit,'(a)') 'test8.4 fails: '//trim(err_msg)
    endif

    call set_calendar_type(JULIAN)
    Time = set_date('1900-02-29 00:00:00', err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test8.5 successful'
    else
      write(outunit,'(a)') 'test8.5 fails: '//trim(err_msg)
    endif
    Time = set_date('1901-02-29 00:00:00', err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test8.6 fails'
    else
      write(outunit,'(a)') 'test8.6 successful: '//trim(err_msg)
    endif
  endif
 !==============================================================================================
 ! Tests of days_in_month

  if(test9) then
    write(outunit,'(/,a)') '#################################  test9  #################################'
    day = days_in_month(set_date('1901-02-28 00:00:00'))
    write(outunit,'(a,i4)') ' test9.1: day=',day
    day = days_in_month(set_date('1901-07-01 00:00:00'))
    write(outunit,'(a,i4)') ' test9.2: day=',day
  endif
 !==============================================================================================
 ! Tests of get_time error flag

  if(test10) then
    write(outunit,'(/,a)') '#################################  test10  #################################'
    Time = set_time(seconds=2, days=1, ticks=1)
    call get_time(Time, seconds=sec, days=day, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test10.1 fails'
    else
      write(outunit,'(a)') 'test10.1 successful: '//trim(err_msg)
    endif
    call set_calendar_type(GREGORIAN)
    Time = set_time(seconds=2, days=1, ticks=1)
    call get_date(Time, yr, mo, day, hr, min, sec, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test10.2 fails'
    else
      write(outunit,'(a)') 'test10.2 successful: '//trim(err_msg)
    endif
  endif
 !==============================================================================================
 ! Tests of increment_time and decrement_time
      
  if(test11) then
    write(outunit,'(/,a)') '#################################  test11  #################################'
    call print_time(increment_time(set_time(seconds=0, days=2), seconds=0, days=1),'test11.1:', unit=outunit)
    call print_time(decrement_time(set_time(seconds=0, days=2), seconds=0, days=1),'test11.2:', unit=outunit)
    call print_time(increment_time(set_time(seconds=0, days=2, ticks=5), seconds=400, days=1, ticks=14),'test11.3:', unit=outunit)
    call print_time(decrement_time(set_time(seconds=0, days=2, ticks=5), seconds=400, days=1, ticks=14),'test11.4:', unit=outunit)
  endif
 !==============================================================================================
 !  Tests of negative increments in increment_time and decrement_time

  if(test12) then
    write(outunit,'(/,a)') '#################################  test12  #################################'
    call print_time(increment_time(set_time(seconds=0, days=2), seconds=0, days=-1),'test12.1:', unit=outunit)
    call print_time(decrement_time(set_time(seconds=0, days=2), seconds=0, days=-1),'test12.2:', unit=outunit)
    call print_time(increment_time(set_time(seconds=0, days=2, ticks=5),seconds=-400,days=-1,ticks=-14),'test12.3:',unit=outunit)
    call print_time(decrement_time(set_time(seconds=0, days=2, ticks=5),seconds=-400,days=-1,ticks=-14),'test12.4:',unit=outunit)
  endif
 !==============================================================================================
 !  Test of trap for negative time

  if(test13) then
    write(outunit,'(/,a)') '#################################  test13  #################################'
    Time = set_time(seconds= 2, days=0, ticks=-21, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test13.1 fails'
    else
      write(outunit,'(a)') 'test13.1 successful: '//trim(err_msg)
    endif
  endif
 !==============================================================================================
 !  Tests of negative seconds and/or ticks

  if(test14) then
    write(outunit,'(/,a)') '#################################  test14  #################################'
    call print_time(set_time(seconds=-86399, days=2, ticks=-10),'test14.1:', unit=outunit)
    call print_time(set_time(seconds=-86390, days=2, ticks=-95),'test14.2:', unit=outunit)
    call print_time(set_time(seconds= 86400, days=2, ticks= 95),'test14.3:', unit=outunit)
  endif
 !==============================================================================================
 !  Tests of consistency of day numbering between calendars

  if(test15) then
    write(outunit,'(/,a)') '#################################  test15  #################################'
    call set_calendar_type(GREGORIAN)
    Time = set_date(1, 1, 1)
    call get_time(Time, sec, day)
    write(outunit,10) 'GREGORIAN',day

    call set_calendar_type(JULIAN)
    Time = set_date(1, 1, 1)
    call get_time(Time, sec, day)
    write(outunit,10) 'JULIAN',day

    call set_calendar_type(THIRTY_DAY_MONTHS)
    Time = set_date(1, 1, 1)
    call get_time(Time, sec, day)
    write(outunit,10) 'THIRTY_DAY_MONTHS',day

    call set_calendar_type(NOLEAP)
    Time = set_date(1, 1, 1)
    call get_time(Time, sec, day)
    write(outunit,10) 'NOLEAP',day
  endif

  10 format(a17,' Jan 1 year 1 is day=',i6)

 !==============================================================================================
 ! Tests of error message for invalid dates

  if(test16) then
    write(outunit,'(/,a)') '#################################  test16  #################################'
    call set_calendar_type(GREGORIAN)
    Time = set_date(1900, 1, 32, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.1 fails'
    else
      write(outunit,'(a)') 'test16.1 successful: '//trim(err_msg)
    endif

    Time = set_date(1900, 4, 31, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.2 fails'
    else
      write(outunit,'(a)') 'test16.2 successful: '//trim(err_msg)
    endif

    Time = set_date(1900, 2, 29, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.3 fails'
    else
      write(outunit,'(a)') 'test16.3 successful: '//trim(err_msg)
    endif

    call set_calendar_type(JULIAN)
    Time = set_date(1900, 1, 0, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.4 fails'
    else
      write(outunit,'(a)') 'test16.4 successful: '//trim(err_msg)
    endif

    call set_calendar_type(NOLEAP)
    Time = set_date(1900, 0, 1, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.5 fails'
    else
      write(outunit,'(a)') 'test16.5 successful: '//trim(err_msg)
    endif

    Time = set_date(1900, 1, 1, tick=11, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.6 fails'
    else
      write(outunit,'(a)') 'test16.6 successful: '//trim(err_msg)
    endif

    call set_calendar_type(THIRTY_DAY_MONTHS)
    Time = set_date(1900, 13, 1, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.7 fails'
    else
      write(outunit,'(a)') 'test16.7 successful: '//trim(err_msg)
    endif

    Time = set_date(1900, 12, 31, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.8 fails'
    else
      write(outunit,'(a)') 'test16.8 successful: '//trim(err_msg)
    endif

    call set_calendar_type(JULIAN)
    Time = set_date(1900, 4, 31, err_msg=err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test16.9 fails'
    else
      write(outunit,'(a)') 'test16.9 successful: '//trim(err_msg)
    endif
  endif
 !==============================================================================================
 !  Tests of Gregorian calendar
 !  This test loops through every day of an 400 year period and writes a line to the output file for each day.

  if(test17) then
    write(outunit,'(/,a)') '#################################  test17  #################################'
    write(errunit,'(/,a)') ' ====================================================='
    write(errunit,'(a)')   '  Warning: test17 produces voluminous output.'
    write(errunit,'(a)')   '  It can be turned off with: &test_nml test17=.false./'
    write(errunit,'(a,/)') ' ====================================================='
    call set_calendar_type(GREGORIAN)
    do year=1801,2200
      leap = mod(year,4) == 0
      leap = leap .and. .not.mod(year,100) == 0
      leap = leap .or. mod(year,400) == 0
      do month=1,12
        days_this_month = days_per_month(month)
        if(leap .and. month == 2) days_this_month = 29
        do dday=1,days_this_month
          Time = set_date(year, month, dday, 0, 0, 0) 
          call get_date(Time, yr, mo, day, hr, min, sec)
          write(outunit,100) yr, mo, day, leap_year(Time), days_in_month(Time), days_in_year(Time)
        enddo
      enddo
    enddo
  endif
  100 format('yr=',i4,' mo=',i2,' day=',i2,' leap=',L1,' days_in_month=',i2,' days_in_year=',i3)
 !==============================================================================================
 !  Tests of length_of_year

  if(test18) then
    write(outunit,'(/,a)') '#################################  test18  #################################'
    call set_calendar_type(THIRTY_DAY_MONTHS)
    call print_time(length_of_year(), 'length_of_year for THIRTY_DAY_MONTHS:', unit=outunit)
    call set_calendar_type(NOLEAP)
    call print_time(length_of_year(), 'length_of_year for NOLEAP:', unit=outunit)
    call set_calendar_type(JULIAN)
    call print_time(length_of_year(), 'length_of_year for JULIAN:', unit=outunit)
    call set_calendar_type(GREGORIAN)
    call print_time(length_of_year(), 'length_of_year for GREGORIAN:', unit=outunit)
  endif
 !==============================================================================================
 !  Tests of real_to_time_type

  if(test19) then
    write(outunit,'(/,a)') '#################################  test19  #################################'
    call print_time(real_to_time_type(86401.1), 'real_to_time_type(86401.1):', unit=outunit)
    Time = real_to_time_type(-1.0, err_msg)
    if(err_msg == '') then
      write(outunit,'(a)') 'test of real_to_time_type fails'
    else
      write(outunit,'(a)') 'test successful: '//trim(err_msg)
    endif
  endif
 !==============================================================================================
  write(outunit,'(/,a)') '############################################################################'
  write(outunit,'(a,i6)') ' ticks_per_second=',get_ticks_per_second()

 call fms_io_exit
 call fms_end
 end program test
#endif



module gaussian_topog_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Routines for creating Gaussian-shaped land surface topography
!   for latitude-longitude grids.
! </OVERVIEW>

! <DESCRIPTION>
!   Interfaces generate simple Gaussian-shaped mountains from
!   parameters specified by either argument list or namelist input.
!   The mountain shapes are controlled by the height, half-width,
!   and ridge-width parameters.
! </DESCRIPTION>

use  fms_mod, only: file_exist, open_namelist_file,  &
                    check_nml_error, close_file,     &
                    stdlog, write_version_number,    &
                    mpp_pe, mpp_root_pe,             &
                    error_mesg, FATAL

use constants_mod, only: pi

use mpp_mod,       only: input_nml_file

implicit none
private

public :: gaussian_topog_init, get_gaussian_topog

!-----------------------------------------------------------------------
! <NAMELIST NAME="gaussian_topog_nml">
!   <DATA NAME="height" UNITS="meter" TYPE="real" DIM="(mxmtns)" DEFAULT="0.">
!     Height in meters of the Gaussian mountains.
!    </DATA>
!   <DATA NAME="olon, olat" UNITS="degree" TYPE="real" DIM="(mxmtns)" DEFAULT="0.">
!     The longitude and latitude of mountain origins (in degrees).
!    </DATA>
!   <DATA NAME="wlon, wlat" UNITS="degree" TYPE="real" DIM="(mxmtns)" DEFAULT="0.">
!     The longitude and latitude half-width of mountain tails (in degrees).
!    </DATA>
!   <DATA NAME="rlon, rlat" UNITS="degree" TYPE="real" DIM="(mxmtns)" DEFAULT="0.">
!     The longitude and latitude half-width of mountain ridges (in degrees).  For a
!     "standard" Gaussian mountain set rlon=rlat=0.
!    </DATA>
!
!    <DATA NAME="NOTE">
!     The variables in this namelist are only used when routine
!     <TT>gaussian_topog_init</TT> is called.  The namelist variables
!     are dimensioned (by 10), so that multiple mountains can be generated.
!
!     Internal parameter mxmtns = 10. By default no mountains are generated. 
!    </DATA>

   integer, parameter :: maxmts = 10

   real, dimension(maxmts) :: height = 0.
   real, dimension(maxmts) ::  olon  = 0.
   real, dimension(maxmts) ::  olat  = 0.
   real, dimension(maxmts) ::  wlon  = 0.
   real, dimension(maxmts) ::  wlat  = 0.
   real, dimension(maxmts) ::  rlon  = 0.
   real, dimension(maxmts) ::  rlat  = 0.

   namelist /gaussian_topog_nml/ height, olon, olat, wlon, wlat, rlon, rlat
! </NAMELIST>

!-----------------------------------------------------------------------

character(len=128) :: version = '$Id: gaussian_topog.F90,v 13.0.20.1 2010/08/31 14:29:10 z1l Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

logical :: do_nml = .true.
logical :: module_is_initialized = .FALSE.

!-----------------------------------------------------------------------

contains

!#######################################################################

! <SUBROUTINE NAME="gaussian_topog_init">

!   <OVERVIEW>
!     Returns a surface height field that consists
!     of the sum of one or more Gaussian-shaped mountains.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns a land surface topography that consists of a "set" of
!     simple Gaussian-shaped mountains.  The height, position,
!     width, and elongation of the mountains can be controlled
!     by variables in namelist <LINK SRC="#NAMELIST">&#38;gaussian_topog_nml</LINK>.
!   </DESCRIPTION>
!   <TEMPLATE>
!     <B>call gaussian_topog_init</B> ( lon, lat, zsurf )
!   </TEMPLATE>

!   <IN NAME="lon" UNITS="radians" TYPE="real" DIM="(:)">
!     The mean grid box longitude in radians.
!   </IN>
!   <IN NAME="lat" UNITS="radians" TYPE="real" DIM="(:)">
!     The mean grid box latitude in radians.
!   </IN>
!   <OUT NAME="zsurf" UNITS="meter" TYPE="real" DIM="(:,:)">
!     The surface height (in meters).
!     The size of this field must be size(lon) by size(lat).
!   </OUT>

subroutine gaussian_topog_init ( lon, lat, zsurf )

real, intent(in)  :: lon(:), lat(:)
real, intent(out) :: zsurf(:,:)

integer :: n

  if (.not.module_is_initialized) then
     call write_version_number( version, tagname )
  endif

  if(any(shape(zsurf) /= (/size(lon(:)),size(lat(:))/))) then
    call error_mesg ('get_gaussian_topog in topography_mod', &
     'shape(zsurf) is not equal to (/size(lon),size(lat)/)', FATAL)
  endif

  if (do_nml) call read_namelist

! compute sum of all non-zero mountains
  zsurf(:,:) = 0.
  do n = 1, maxmts
    if ( height(n) == 0. ) cycle
    zsurf = zsurf + get_gaussian_topog ( lon, lat, height(n), &
                olon(n), olat(n), wlon(n), wlat(n), rlon(n), rlat(n))
  enddo
 module_is_initialized = .TRUE.                    

end subroutine gaussian_topog_init
! </SUBROUTINE>

!#######################################################################

! <FUNCTION NAME="get_gaussian_topog">

!   <OVERVIEW>
!     Returns a simple surface height field that consists of a single
!     Gaussian-shaped mountain.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns a single Gaussian-shaped mountain.
!     The height, position, width, and elongation of the mountain
!     is controlled by optional arguments.
!   </DESCRIPTION>
!   <TEMPLATE>
!     zsurf = <B>get_gaussian_topog</B> ( lon, lat, height
!                    [, olond, olatd, wlond, wlatd, rlond, rlatd ] )
!   </TEMPLATE>

!   <IN NAME="lon" UNITS="radians" TYPE="real" DIM="(:)">
!     The mean grid box longitude in radians.
!   </IN>
!   <IN NAME="lat" UNITS="radians" TYPE="real" DIM="(:)">
!     The mean grid box latitude in radians.
!   </IN>
!   <IN NAME="height" UNITS="meter" TYPE="real" DIM="(scalar)">
!     Maximum surface height in meters.
!   </IN>
!   <IN NAME="olond, olatd" UNITS="degrees" TYPE="real" DIM="(scalar)">
!     Position/origin of mountain in degrees longitude and latitude.
!     This is the location of the maximum height.
!   </IN>
!   <IN NAME="wlond, wlatd" UNITS="degrees" TYPE="real" DIM="(scalar)" DEFAULT="15.">
!     Gaussian half-width of mountain in degrees longitude and latitude.
!   </IN>
!   <IN NAME="rlond, rlatd" UNITS="degrees" TYPE="real" DIM="(scalar)" DEFAULT="0.">
!     Ridge half-width of mountain in degrees longitude and latitude.
!                    This is the elongation of the maximum height.
!   </IN>
!   <OUT NAME="zsurf" UNITS="meter" TYPE="real" DIM="(:,:)">
!     The surface height (in meters).
!              The size of the returned field is size(lon) by size(lat).
!   </OUT>
!   <ERROR MSG="shape(zsurf) is not equal to (/size(lon),size(lat)/)" STATUS="FATAL">
!     Check the input grid size and output field size.
!     The input grid is defined at the midpoint of grid boxes.
!   </ERROR>
!   <NOTE>
!     Mountains do not wrap around the poles.
!   </NOTE>

function get_gaussian_topog ( lon, lat, height,                          &
                              olond, olatd, wlond, wlatd, rlond, rlatd ) &
                     result ( zsurf )

real, intent(in)  :: lon(:), lat(:)
real, intent(in)  :: height
real, intent(in), optional :: olond, olatd, wlond, wlatd, rlond, rlatd
real :: zsurf(size(lon,1),size(lat,1))

integer :: i, j
real    :: olon, olat, wlon, wlat, rlon, rlat
real    :: tpi, dtr, dx, dy, xx, yy

  if (do_nml) call read_namelist

! no need to compute mountain if height=0
  if ( height == 0. ) then
       zsurf(:,:) = 0.
       return
  endif

  tpi = 2.0*pi
  dtr = tpi/360.

! defaults and convert degrees to radians (dtr)
  olon = 90.*dtr;  if (present(olond)) olon=olond*dtr
  olat = 45.*dtr;  if (present(olatd)) olat=olatd*dtr
  wlon = 15.*dtr;  if (present(wlond)) wlon=wlond*dtr
  wlat = 15.*dtr;  if (present(wlatd)) wlat=wlatd*dtr
  rlon =  0.    ;  if (present(rlond)) rlon=rlond*dtr
  rlat =  0.    ;  if (present(rlatd)) rlat=rlatd*dtr

! compute gaussian-shaped mountain
    do j=1,size(lat(:))
      dy = abs(lat(j) - olat)   ! dist from y origin
      yy = max(0., dy-rlat)/wlat
      do i=1,size(lon(:))
        dx = abs(lon(i) - olon) ! dist from x origin
        dx = min(dx, abs(dx-tpi))  ! To ensure that: -pi <= dx <= pi
        xx = max(0., dx-rlon)/wlon
        zsurf(i,j) = height*exp(-xx**2 - yy**2)
      enddo
    enddo

end function get_gaussian_topog
! </FUNCTION>

!#######################################################################

subroutine read_namelist

   integer :: unit, ierr, io
   real    :: dtr

!  read namelist

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, gaussian_topog_nml, iostat=io)
#else
   if ( file_exist('input.nml')) then
      unit = open_namelist_file ( )
      ierr=1; do while (ierr /= 0)
         read  (unit, nml=gaussian_topog_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'gaussian_topog_nml')
      enddo
 10   call close_file (unit)
   endif
#endif

!  write version and namelist to log file

   if (mpp_pe() == mpp_root_pe()) then
      unit = stdlog()
      write (unit, nml=gaussian_topog_nml)
   endif

   do_nml = .false.

end subroutine read_namelist

!#######################################################################

end module gaussian_topog_mod

! <INFO>
!   <NOTE>
!     NAMELIST FOR GENERATING GAUSSIAN MOUNTAINS
!
!  * multiple mountains can be generated
!  * the final mountains are the sum of all
!
!       height = height in meters
!       olon, olat = longitude,latitude origin              (degrees)
!       rlon, rlat = longitude,latitude half-width of ridge (degrees)
!       wlon, wlat = longitude,latitude half-width of tail  (degrees)
!
!       Note: For the standard gaussian mountain
!             set rlon = rlat = 0 .
!
! <PRE>
!
!       height -->   ___________________________
!                   /                           \
!                  /              |              \
!    gaussian     /               |               \
!      sides --> /                |                \
!               /               olon                \
!         _____/                olat                 \______
!
!              |    |             |
!              |<-->|<----------->|
!              |wlon|    rlon     |
!               wlat     rlat
!
! </PRE>
!
!See the <LINK SRC="topography.html#TEST PROGRAM">topography </LINK>module documentation for a test program.
!   </NOTE>
! </INFO>



module topography_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Routines for creating land surface topography fields and land-water masks
!   for latitude-longitude grids.
! </OVERVIEW>

! <DESCRIPTION>
!   This module generates realistic mountains and land-water masks
!   on a specified latitude-longitude grid by interpolating from the
!   1/6 degree Navy mean topography and percent water data sets.
!   The fields that can be generated are mean and standard deviation
!   of topography within the specified grid boxes; and land-ocean (or
!   water) mask and land-ocean (or water) fractional area.
!
!   The interpolation scheme conserves the area-weighted average
!   of the input data by using module horiz_interp.
!
!   The interfaces get_gaussian_topog and gaussian_topog_init are documented in <LINK SRC="gaussian_topog.html">gaussian_topog_mod</LINK>.
! </DESCRIPTION>

use gaussian_topog_mod, only: gaussian_topog_init, get_gaussian_topog
use   horiz_interp_mod, only: horiz_interp_type, horiz_interp_new, &
                              horiz_interp, horiz_interp_del

use            fms_mod, only: file_exist, check_nml_error,               &
                              open_namelist_file, close_file, stdlog,    &
                              mpp_pe, mpp_root_pe, write_version_number, &
                              open_ieee32_file, error_mesg, FATAL, NOTE, &
                              mpp_error
use         fms_io_mod, only: read_data
use      constants_mod, only: PI
use            mpp_mod, only: input_nml_file

implicit none
private

public :: topography_init,                 &
          get_topog_mean, get_topog_stdev, &
          get_ocean_frac, get_ocean_mask,  &
          get_water_frac, get_water_mask,  &
          gaussian_topog_init, get_gaussian_topog

interface get_topog_mean
  module procedure get_topog_mean_1d, get_topog_mean_2d
end interface
interface get_topog_stdev
  module procedure get_topog_stdev_1d, get_topog_stdev_2d
end interface
interface get_ocean_frac
  module procedure get_ocean_frac_1d, get_ocean_frac_2d
end interface
interface get_ocean_mask
  module procedure get_ocean_mask_1d, get_ocean_mask_2d
end interface
interface get_water_frac
  module procedure get_water_frac_1d, get_water_frac_2d
end interface
interface get_water_mask
  module procedure get_water_mask_1d, get_water_mask_2d
end interface

!-----------------------------------------------------------------------
! <NAMELIST NAME="topography_nml">
!   <DATA NAME="topog_file" TYPE="character" DEFAULT="DATA/navy_topography.data">
!       Name of topography file.
!   </DATA>
!   <DATA NAME="water_file" TYPE="character" DEFAULT="DATA/navy_pctwater.data">
!       Name of percent water file.
!   </DATA>

   character(len=128) :: topog_file = 'DATA/navy_topography.data', &
                         water_file = 'DATA/navy_pctwater.data'
   namelist /topography_nml/ topog_file, water_file
! </NAMELIST>

!-----------------------------------------------------------------------
! --- resolution of the topography data set ---
! <DATASET NAME="">
!   This module uses the 1/6 degree U.S. Navy mean topography
!   and percent water data sets.
!
!   These data sets have been re-formatted to separate 32-bit IEEE files.
!   The names of these files is specified by the <LINK SRC="#NAMELIST">namelist</LINK> input.
!
!The format for both files is as follows:
! <PRE>
!     record = 1    nlon, nlat
!     record = 2    blon, blat
!     record = 3    data
! </PRE>
!where:
! <PRE>
!     nlon, nlat = The number of longitude and latitude points
!                  in the horizontal grid.  For the 1/6 degree
!                  data sets this is 2160 x 1080. [integer]
!     blon, blat = The longitude and latitude grid box boundaries in degrees.
!                     [real :: blon(nlon+1), blat(nlat+1)]
!
!     data       = The topography or percent water data.
!                    [real :: data(nlon,nlat)]
! </PRE>
! </DATASET>
  integer :: unit
  integer :: ipts, jpts
  integer, parameter :: COMPUTE_STDEV = 123  ! use this flag to
                                             !   compute st dev

!-----------------------------------------------------------------------

 character(len=128) :: version = '$Id: topography.F90,v 17.0.6.1 2010/08/31 14:29:10 z1l Exp $'
 character(len=128) :: tagname = '$Name: hiram_20101115_bw $'

 logical :: module_is_initialized = .FALSE.

!-----------------------------------------------------------------------

 contains

!#######################################################################

   subroutine topography_init ()

     if ( module_is_initialized ) return

     call write_version_number (version,tagname)
     call read_namelist
     module_is_initialized = .TRUE.

   end subroutine topography_init

!#######################################################################

! <FUNCTION NAME="get_topog_mean">

!   <OVERVIEW>
!     Returns a "realistic" mean surface height field. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns realistic mountains on a latitude-longtude grid.
!     The returned field is the mean topography for the given grid boxes.
!     Computed using a conserving area-weighted interpolation.
!     The current input data set is the 1/6 degree Navy mean topography.
!   </DESCRIPTION>
!   <TEMPLATE>
!     flag = <B>get_topog_mean</B> ( blon, blat, zmean )
!   </TEMPLATE>

!   <IN NAME="blon" TYPE="real" DIM="(:)">
!     The longitude (in radians) at grid box boundaries.
!   </IN>
!   <IN NAME="blat" TYPE="real" DIM="(:)">
!     The latitude (in radians) at grid box boundaries.
!   </IN>
!   <OUT NAME="zmean" UNIT=" meter" TYPE="real" DIM="(:,:)">
!     The mean surface height (meters).
!     The size of this field must be size(blon)-1 by size(blat)-1.
!   </OUT>
!   <OUT NAME="get_topog_mean" TYPE="logical">
!     A logical value of TRUE is returned if the surface height field
!     was successfully created. A value of FALSE may be returned if the
!     input topography data set was not readable.
!   </OUT>

!   <ERROR MSG="shape(zmean) is not equal to (/size(blon)-1,size(blat)-1/))" STATUS="FATAL">
!     Check the input grid size and output field size.
!   </ERROR>

 function get_topog_mean_1d (blon, blat, zmean)

   real, intent(in),  dimension(:)   :: blon, blat
   real, intent(out), dimension(:,:) :: zmean
   logical :: get_topog_mean_1d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(zmean(:,:)) /= (/size(blon(:))-1,size(blat(:))-1/)) ) &
        call error_mesg('get_topog_mean_1d','shape(zmean) is not&
            & equal to (/size(blon)-1,size(blat)-1/))', FATAL)

   if ( open_topog_file(topog_file) ) then
       call interp_topog_1d ( blon, blat, zmean )
       get_topog_mean_1d = .true.
   else
       get_topog_mean_1d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_topog_mean_1d

!############################################################

 function get_topog_mean_2d (blon, blat, zmean)

   real, intent(in),  dimension(:,:) :: blon, blat
   real, intent(out), dimension(:,:) :: zmean
   logical :: get_topog_mean_2d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(zmean(:,:)) /= (/size(blon,1)-1,size(blon,2)-1/)) .or. &
        any(shape(zmean(:,:)) /= (/size(blat,1)-1,size(blat,2)-1/)) ) &
        call error_mesg('get_topog_mean_2d','shape(zmean) is not&
            & equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)

   if ( open_topog_file(topog_file) ) then
       call interp_topog_2d ( blon, blat, zmean )
       get_topog_mean_2d = .true.
   else
       get_topog_mean_2d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_topog_mean_2d

! </FUNCTION>
!#######################################################################

! <FUNCTION NAME="get_topog_stdev">

!   <OVERVIEW>
!     Returns a standard deviation of higher resolution topography with 
!     the given model grid boxes. 
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns the standard deviation of the "finer" input topography data set,
!     currently the Navy 1/6 degree mean topography data, within the
!     boundaries of the given input grid.
!   </DESCRIPTION>
!   <TEMPLATE>
!     flag = <B>get_topog_stdev</B> ( blon, blat, stdev )
!   </TEMPLATE>
!   <IN NAME="blon" TYPE="real" DIM="(:)">
!     The longitude (in radians) at grid box boundaries.
!   </IN>
!   <IN NAME="blat" TYPE="real" DIM="(:)">
!     The latitude (in radians) at grid box boundaries.
!   </IN>
!   <OUT NAME="stdev" UNITS="meter" TYPE="real" DIM="(:,:)">
!     The standard deviation of surface height (in meters) within
!     given input model grid boxes.
!     The size of this field must be size(blon)-1 by size(blat)-1.
!   </OUT>
!   <OUT NAME="get_topog_stdev" TYPE="logical">
!     A logical value of TRUE is returned if the output field was
!     successfully created. A value of FALSE may be returned if the
!     input topography data set was not readable.
!   </OUT>

 function get_topog_stdev_1d (blon, blat, stdev)

   real, intent(in),  dimension(:)   :: blon, blat
   real, intent(out), dimension(:,:) :: stdev
   logical :: get_topog_stdev_1d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(stdev(:,:)) /= (/size(blon(:))-1,size(blat(:))-1/)) ) &
       call error_mesg('get_topog_stdev','shape(stdev) is not&
            & equal to (/size(blon)-1,size(blat)-1/))', FATAL)

   if ( open_topog_file(topog_file) ) then
       call interp_topog_1d ( blon, blat, stdev, flag=COMPUTE_STDEV )
       get_topog_stdev_1d = .true.
   else
       get_topog_stdev_1d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_topog_stdev_1d

!#######################################################################

 function get_topog_stdev_2d (blon, blat, stdev)

   real, intent(in),  dimension(:,:) :: blon, blat
   real, intent(out), dimension(:,:) :: stdev
   logical :: get_topog_stdev_2d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(stdev(:,:)) /= (/size(blon,1)-1,size(blon,2)-1/)) .or. &
        any(shape(stdev(:,:)) /= (/size(blat,1)-1,size(blat,2)-1/)) ) &
        call error_mesg('get_topog_stdev_2d','shape(stdev) is not&
            & equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)

   if ( open_topog_file(topog_file) ) then
       call interp_topog_2d ( blon, blat, stdev, flag=COMPUTE_STDEV )
       get_topog_stdev_2d = .true.
   else
       get_topog_stdev_2d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_topog_stdev_2d

! </FUNCTION>
!#######################################################################

! <FUNCTION NAME="get_ocean_frac">

!   <OVERVIEW>
!      Returns fractional area covered by ocean in a grid box.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns fractional area covered by ocean in the given model grid boxes.
!   </DESCRIPTION>
!   <TEMPLATE>
!     flag = <B>get_ocean_frac</B> ( blon, blat, ocean_frac )
!   </TEMPLATE>

!   <IN NAME="blon" UNITS="radians" TYPE="real" DIM="(:)">
!     The longitude (in radians) at grid box boundaries.
!   </IN>
!   <IN NAME="blat" UNITS="radians" TYPE="real" DIM="(:)">
!     The latitude (in radians) at grid box boundaries.
!   </IN>
!   <OUT NAME="ocean_frac" TYPE="real" DIM="(:,:)">
!     The fractional amount (0 to 1) of ocean in a grid box.
!     The size of this field must be size(blon)-1 by size(blat)-1.
!   </OUT>
!   <OUT NAME="get_ocean_frac" TYPE="logical">
!     A logical value of TRUE is returned if the output field
!     was successfully created. A value of FALSE may be returned
!     if the Navy 1/6 degree percent water data set was not readable.
!   </OUT>

 function get_ocean_frac_1d (blon, blat, ocean_frac)

 real, intent(in),  dimension(:)   :: blon, blat
 real, intent(out), dimension(:,:) :: ocean_frac
 logical :: get_ocean_frac_1d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(ocean_frac(:,:)) /= (/size(blon(:))-1,size(blat(:))-1/)) ) &
        call error_mesg('get_ocean_frac','shape(ocean_frac) is not&
                 & equal to (/size(blon)-1,size(blat)-1/))', FATAL)

   if ( open_topog_file(water_file) ) then
       call interp_water_1d ( blon, blat, ocean_frac, do_ocean=.true. )
       get_ocean_frac_1d = .true.
   else
       get_ocean_frac_1d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_ocean_frac_1d

!#######################################################################

 function get_ocean_frac_2d (blon, blat, ocean_frac)

 real, intent(in),  dimension(:,:) :: blon, blat
 real, intent(out), dimension(:,:) :: ocean_frac
 logical :: get_ocean_frac_2d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(ocean_frac(:,:)) /= (/size(blon,1)-1,size(blon,2)-1/)) .or. &
        any(shape(ocean_frac(:,:)) /= (/size(blat,1)-1,size(blat,2)-1/)) ) &
        call error_mesg('get_ocean_frac_2d','shape(ocean_frac) is not&
            & equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)

   if ( open_topog_file(water_file) ) then
       call interp_water_2d ( blon, blat, ocean_frac, do_ocean=.true. )
       get_ocean_frac_2d = .true.
   else
       get_ocean_frac_2d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_ocean_frac_2d

! </FUNCTION>
!#######################################################################
! <FUNCTION NAME="get_ocean_mask">

!   <OVERVIEW>
!     Returns a land-ocean mask in a grid box.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns a land-ocean mask in the given model grid boxes.
!   </DESCRIPTION>
!   <TEMPLATE>
!     flag = <B>get_ocean_mask</B> ( blon, blat, ocean_mask )
!   </TEMPLATE>

!   <IN NAME="blon" UNITS="radians" TYPE="real" DIM="(:)">
!     The longitude (in radians) at grid box boundaries.
!   </IN>
!   <IN NAME="blat" UNITS="radians" TYPE="real" DIM="(:)">
!     The latitude (in radians) at grid box boundaries.
!   </IN>
!   <OUT NAME="ocean_frac" TYPE="real" DIM="(:,:)">
!     The fractional amount (0 to 1) of ocean in a grid box.
!     The size of this field must be size(blon)-1 by size(blat)-1.
!   </OUT>
!   <OUT NAME="get_ocean_mask" TYPE="logical">
!     A logical value of TRUE is returned if the output field
!     was successfully created. A value of FALSE may be returned
!     if the Navy 1/6 degree percent water data set was not readable.
!   </OUT>

 function get_ocean_mask_1d (blon, blat, ocean_mask)

 real   , intent(in),  dimension(:)   :: blon, blat
 logical, intent(out), dimension(:,:) :: ocean_mask
 logical :: get_ocean_mask_1d

 real, dimension(size(ocean_mask,1),size(ocean_mask,2)) :: ocean_frac
!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

 if ( get_ocean_frac(blon, blat, ocean_frac) ) then
   where (ocean_frac > 0.50)
     ocean_mask = .true.
   elsewhere
     ocean_mask = .false.
   end where
   get_ocean_mask_1d = .true.
 else
   get_ocean_mask_1d = .false.
 endif

!-----------------------------------------------------------------------

 end function get_ocean_mask_1d

!#######################################################################

 function get_ocean_mask_2d (blon, blat, ocean_mask)

 real   , intent(in),  dimension(:,:) :: blon, blat
 logical, intent(out), dimension(:,:) :: ocean_mask
 logical :: get_ocean_mask_2d

 real, dimension(size(ocean_mask,1),size(ocean_mask,2)) :: ocean_frac
!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

 if ( get_ocean_frac(blon, blat, ocean_frac) ) then
   where (ocean_frac > 0.50)
     ocean_mask = .true.
   elsewhere
     ocean_mask = .false.
   end where
   get_ocean_mask_2d = .true.
 else
   get_ocean_mask_2d = .false.
 endif

!-----------------------------------------------------------------------

 end function get_ocean_mask_2d

! </FUNCTION>
!#######################################################################
! <FUNCTION NAME="get_water_frac">

!   <OVERVIEW>
!     Returns fractional area covered by water.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns the percent of water in a grid box.
!   </DESCRIPTION>
!   <TEMPLATE>
!     flag = <B>get_water_frac</B> ( blon, blat, water_frac )
!   </TEMPLATE>

!   <IN NAME="blon" UNITS="radians" TYPE="real" DIM="(:)">
!     The longitude (in radians) at grid box boundaries.
!   </IN>
!   <IN NAME="blat" UNITS="radians" TYPE="real" DIM="(:)">
!     The latitude (in radians) at grid box boundaries.
!   </IN>
!   <OUT NAME="water_frac" TYPE="real" DIM="(:,:)">
!     The fractional amount (0 to 1) of water in a grid box.
!     The size of this field must be size(blon)-1 by size(blat)-1.
!   </OUT>
!   <OUT NAME="get_water_frac" TYPE="logical">
!     A logical value of TRUE is returned if the output field
!     was successfully created. A value of FALSE may be returned
!     if the Navy 1/6 degree percent water data set was not readable.
!   </OUT>
!   <ERROR MSG="shape(water_frac) is not equal to (/size(blon)-1,size(blat)-1/))" STATUS="FATAL">
!      Check the input grid size and output field size.
!   </ERROR>

 function get_water_frac_1d (blon, blat, water_frac)

 real, intent(in),  dimension(:)   :: blon, blat
 real, intent(out), dimension(:,:) :: water_frac
 logical :: get_water_frac_1d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(water_frac(:,:)) /= (/size(blon(:))-1,size(blat(:))-1/)) ) &
        call error_mesg('get_water_frac_1d','shape(water_frac) is not&
                 & equal to (/size(blon)-1,size(blat)-1/))', FATAL)

   if ( open_topog_file(water_file) ) then
       call interp_water_1d ( blon, blat, water_frac )
       get_water_frac_1d = .true.
   else
       get_water_frac_1d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_water_frac_1d

!#######################################################################

 function get_water_frac_2d (blon, blat, water_frac)

 real, intent(in),  dimension(:,:) :: blon, blat
 real, intent(out), dimension(:,:) :: water_frac
 logical :: get_water_frac_2d

!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

   if ( any(shape(water_frac(:,:)) /= (/size(blon,1)-1,size(blon,2)-1/)) .or. &
        any(shape(water_frac(:,:)) /= (/size(blat,1)-1,size(blat,2)-1/)) ) &
        call error_mesg('get_water_frac_2d','shape(water_frac) is not&
            & equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)

   if ( open_topog_file(water_file) ) then
       call interp_water_2d ( blon, blat, water_frac )
       get_water_frac_2d = .true.
   else
       get_water_frac_2d = .false.
   endif

!-----------------------------------------------------------------------

 end function get_water_frac_2d

! </FUNCTION>
!#######################################################################
! <FUNCTION NAME="get_water_mask">

!   <OVERVIEW>
!     Returns a land-water mask in a grid box.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Returns a land-water mask in the given model grid boxes.
!   </DESCRIPTION>
!   <TEMPLATE>
!     flag = <B>get_water_mask</B> ( blon, blat, water_mask )
!   </TEMPLATE>

!   <IN NAME="blon" UNITS="radians" TYPE="real" DIM="(:)">
!     The longitude (in radians) at grid box boundaries.
!   </IN>
!   <IN NAME="blat" UNITS="radians" TYPE="real" DIM="(:)">
!     The latitude (in radians) at grid box boundaries.
!   </IN>
!   <OUT NAME="water_mask" TYPE="real" DIM="(:,:)">
!     A binary mask for water (true) or land (false).
!     The size of this field must be size(blon)-1 by size(blat)-1.
!   </OUT>
!   <OUT NAME="get_water_mask" TYPE="logical">
!     A logical value of TRUE is returned if the output field
!     was successfully created. A value of FALSE may be returned
!     if the Navy 1/6 degree percent water data set was not readable.
!   </OUT>

 function get_water_mask_1d (blon, blat, water_mask)

 real   , intent(in),  dimension(:)   :: blon, blat
 logical, intent(out), dimension(:,:) :: water_mask
 logical :: get_water_mask_1d

 real, dimension(size(water_mask,1),size(water_mask,2)) :: water_frac
!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

 if ( get_water_frac(blon, blat, water_frac) ) then
   where (water_frac > 0.50)
     water_mask = .true.
   elsewhere
     water_mask = .false.
   end where
   get_water_mask_1d = .true.
 else
   get_water_mask_1d = .false.
 endif

!-----------------------------------------------------------------------

 end function get_water_mask_1d

!#######################################################################

 function get_water_mask_2d (blon, blat, water_mask)

 real   , intent(in),  dimension(:,:) :: blon, blat
 logical, intent(out), dimension(:,:) :: water_mask
 logical :: get_water_mask_2d

 real, dimension(size(water_mask,1),size(water_mask,2)) :: water_frac
!-----------------------------------------------------------------------
   if (.not. module_is_initialized) call topography_init()

 if ( get_water_frac(blon, blat, water_frac) ) then
   where (water_frac > 0.50)
     water_mask = .true.
   elsewhere
     water_mask = .false.
   end where
   get_water_mask_2d = .true.
 else
   get_water_mask_2d = .false.
 endif

!-----------------------------------------------------------------------

 end function get_water_mask_2d

! </FUNCTION>

!#######################################################################
!##################   private interfaces below here   ##################
!#######################################################################

 function open_topog_file ( filename )
 character(len=*), intent(in) :: filename
 logical :: open_topog_file
 real    :: r_ipts, r_jpts
 integer :: namelen

 namelen = len(trim(filename))
  if ( file_exist(filename) .AND. filename(namelen-2:namelen) == '.nc') then
     if (mpp_pe() == mpp_root_pe()) call mpp_error ('topography_mod', &
            'Reading NetCDF formatted input data file: '//filename, NOTE)
     call read_data(filename, 'ipts', r_ipts, no_domain=.true.)
     call read_data(filename, 'jpts', r_jpts, no_domain=.true.)
     ipts = nint(r_ipts)
     jpts = nint(r_jpts)
     open_topog_file = .true.
  else
     if ( file_exist(filename) ) then
        if (mpp_pe() == mpp_root_pe()) call mpp_error ('topography_mod', &
             'Reading native formatted input data file: '//filename, NOTE)
        unit = open_ieee32_file (trim(filename), 'read')
        read (unit) ipts, jpts
        open_topog_file = .true.
     else
        open_topog_file = .false.
     endif
  endif

 end function open_topog_file

!#######################################################################

 subroutine interp_topog_1d ( blon, blat, zout, flag )
 real   , intent(in)  :: blon(:), blat(:)
 real   , intent(out) :: zout(:,:)
 integer, intent(in), optional :: flag

 real :: xdat(ipts+1), ydat(jpts+1)
 real :: zdat(ipts,jpts)
 real :: zout2(size(zout,1),size(zout,2))

    call input_data ( topog_file, xdat, ydat, zdat )

    call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )

! compute standard deviation if necessary
    if (present(flag)) then
       if (flag == COMPUTE_STDEV) then
           zdat = zdat*zdat
           call horiz_interp ( zdat, xdat, ydat, blon, blat, zout2 )
           zout = zout2 - zout*zout
           where (zout > 0.0)
             zout = sqrt ( zout )
           elsewhere
             zout = 0.0
           endwhere
       endif
    endif

 end subroutine interp_topog_1d

!#######################################################################

 subroutine interp_topog_2d ( blon, blat, zout, flag )
 real   , intent(in)  :: blon(:,:), blat(:,:)
 real   , intent(out) :: zout(:,:)
 integer, intent(in), optional :: flag

 real :: xdat(ipts+1), ydat(jpts+1)
 real :: zdat(ipts,jpts)
 real :: zout2(size(zout,1),size(zout,2))
 integer :: js, je
 type (horiz_interp_type) :: Interp

    call input_data ( topog_file, xdat, ydat, zdat )
    call find_indices ( minval(blat), maxval(blat), ydat, js, je )

    call horiz_interp_new ( Interp, xdat, ydat(js:je+1), blon, blat )
    call horiz_interp     ( Interp, zdat(:,js:je), zout )

! compute standard deviation if necessary
    if (present(flag)) then
       if (flag == COMPUTE_STDEV) then
           zdat = zdat*zdat
           call horiz_interp ( Interp, zdat(:,js:je), zout2 )
           zout = zout2 - zout*zout
           where (zout > 0.0)
             zout = sqrt ( zout )
           elsewhere
             zout = 0.0
           endwhere
       endif
    endif

    call horiz_interp_del ( Interp )

 end subroutine interp_topog_2d

!#######################################################################

 subroutine find_indices ( ybeg, yend, ydat, js, je )
 real,    intent(in)  :: ybeg, yend, ydat(:)
 integer, intent(out) :: js, je
 integer :: j

   js = 1
   do j = 1, size(ydat(:))-1
      if (ybeg >= ydat(j) .and. ybeg <= ydat(j+1)) then
         js = j
         exit
      endif
   enddo

   je = size(ydat(:))-1
   do j = js, size(ydat(:))-1
      if (yend >= ydat(j) .and. yend <= ydat(j+1)) then
         je = j
         exit
      endif
   enddo

   !print '(a,i2,2(a,f10.5),2(a,i4))', "PE=",mpp_pe(),"  phs=",ybeg,"  phn=",yend,"  js=",js,"  je=",je

 end subroutine find_indices

!#######################################################################

 subroutine input_data ( ifile, xdat, ydat, zdat )
 character(len=*), intent(in) :: ifile
 real, intent(out) :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
 integer :: nc

   nc = len_trim(ifile)

! note: ipts,jpts,unit are global

  if ( file_exist(trim(ifile)) .AND. ifile(nc-2:nc) == '.nc') then
     call read_data(trim(ifile), 'xdat', xdat, no_domain=.true.)
     call read_data(trim(ifile), 'ydat', ydat, no_domain=.true.)
     call read_data(trim(ifile), 'zdat', zdat, no_domain=.true.)
  else
    read (unit) xdat, ydat    ! read lon/lat edges in radians
    read (unit) zdat          ! read land surface height in meters
    call close_file (unit)
 endif

 end subroutine input_data

!#######################################################################

 subroutine interp_water_1d ( blon, blat, zout, do_ocean )
 real   , intent(in)  :: blon(:), blat(:)
 real   , intent(out) :: zout(:,:)
 logical, intent(in), optional :: do_ocean

 real :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)

    call input_data ( water_file, xdat, ydat, zdat )

! only use designated ocean points
    if (present(do_ocean)) then
        if (do_ocean) call determine_ocean_points (zdat)
    endif

! interpolate onto output grid
    call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )

 end subroutine interp_water_1d

!#######################################################################

 subroutine interp_water_2d ( blon, blat, zout, do_ocean )
 real   , intent(in)  :: blon(:,:), blat(:,:)
 real   , intent(out) :: zout(:,:)
 logical, intent(in), optional :: do_ocean

 real :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)

    call input_data ( water_file, xdat, ydat, zdat )

! only use designated ocean points
    if (present(do_ocean)) then
        if (do_ocean) call determine_ocean_points (zdat)
    endif

! interpolate onto output grid
    call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )

 end subroutine interp_water_2d

!#######################################################################

 subroutine determine_ocean_points ( pctwater )
 real, intent(inout) :: pctwater(:,:)
 logical :: ocean(size(pctwater,1),size(pctwater,2))
 integer :: i, j, m, n, im, ip, jm, jp, new 

 real :: ocean_pct_crit = .500

  ! resolution of the grid
    m = size(pctwater,1)
    n = size(pctwater,2)

  ! the 1/6 degree navy percent water data set
  ! designates ocean grid boxes as 100 percent water
  ! all other grid boxes have <= 99 percent water

  ! set a mask for ocean grid boxes
    ocean = (pctwater > .999) 
    new = count(ocean)

  ! set land grid boxes that have sufficient amount of water
  ! to ocean grid boxes when they are adjacent to ocean points
  ! iterate until there are no new ocean points
    do 
    if (new == 0) exit 
    new = 0 

       do j = 1, n
       do i = 1, m
          if (.not.ocean(i,j) .and. pctwater(i,j) > ocean_pct_crit) then
             im = i-1; ip = i+1; jm = j-1; jp = j+1
             if (im == 0)   im = m  
             if (ip == m+1) ip = 1
             if (jm == 0)   jm = 1
             if (jp == n+1) jp = n
           ! check the 8 grid boxes that surround this grid box
             if (ocean(im,j ) .or. ocean(ip,j ) .or. ocean(i ,jm) .or. ocean(i ,jp) .or. &
                 ocean(im,jm) .or. ocean(ip,jm) .or. ocean(ip,jp) .or. ocean(im,jp)) then
                 ocean(i,j) = .true.
                 new = new + 1
             endif
          endif
       enddo
       enddo
      !print *, 'new=',new

    enddo

  ! final step is to elimate water percentage if land
    where (.not.ocean) pctwater = 0.

 end subroutine determine_ocean_points

!#######################################################################
! reads the namelist file, write namelist to log file, 
! and initializes constants

subroutine read_namelist

   integer :: unit, ierr, io

!  read namelist

#ifdef INTERNAL_FILE_NML
      read (input_nml_file, topography_nml, iostat=io)
#else
   if ( file_exist('input.nml')) then
      unit = open_namelist_file ( )
      ierr=1; do while (ierr /= 0)
         read  (unit, nml=topography_nml, iostat=io, end=10)
         ierr = check_nml_error(io,'topography_nml')
      enddo
 10   call close_file (unit)
   endif
#endif

!  write version and namelist to log file

   if (mpp_pe() == mpp_root_pe()) then
     unit = stdlog()
     write (unit, nml=topography_nml)
   endif

end subroutine read_namelist

!#######################################################################

end module topography_mod

! <INFO>

!   <TESTPROGRAM NAME="">  
!  
!  To run this program you will need the topography and percent water
!  data sets and use the following namelist (in file input.nml).
!  
!   &amp;gaussian_topog_nml
!     height = 5000., 3000., 3000., 3000.,
!     olon   =   90.,  255.,  285.,    0.,
!     olat   =   45.,   45.,  -15.,  -90.,
!     wlon   =   15.,   10.,    5.,  180.,
!     wlat   =   15.,   25.,   25.,   20., /
!  
!  program test
!  
!  ! test program for topography and gaussian_topog modules
!  <PRE>  
!  use topography_mod
!  implicit none
!  
!  integer, parameter :: nlon=24, nlat=18
!  real :: x(nlon), y(nlat), xb(nlon+1), yb(nlat+1), z(nlon,nlat)
!  real :: hpi, rtd
!  integer :: i,j
!  logical :: a
!  
!  ! gaussian mountain parameters
!  real, parameter :: ht=4000.
!  real, parameter :: x0=90., y0=45. ! origin in degrees
!  real, parameter :: xw=15., yw=15. ! half-width in degees
!  real, parameter :: xr=30., yr= 0. ! ridge-width in degrees
!  
!  ! create lat/lon grid in radians
!    hpi = acos(0.0)
!    rtd = 90./hpi ! rad to deg
!    do i=1,nlon
!      xb(i) = 4.*hpi*real(i-1)/real(nlon)
!    enddo
!      xb(nlon+1) = xb(1)+4.*hpi
!      yb(1) = -hpi
!    do j=2,nlat
!      yb(j) = yb(j-1) + 2.*hpi/real(nlat)
!    enddo
!      yb(nlat+1) = hpi
!  ! mid-point of grid boxes
!    x(1:nlon) = 0.5*(xb(1:nlon)+xb(2:nlon+1))
!    y(1:nlat) = 0.5*(yb(1:nlat)+yb(2:nlat+1))
!  ! test topography_mod routines
!    a = get_topog_mean(xb,yb,z)
!    call printz ('get_topog_mean')
!  
!    a = get_water_frac(xb,yb,z)
!    z = z*100. ! in percent
!    call printz ('get_water_frac')
!  
!    a = get_ocean_frac(xb,yb,z)
!    z = z*100. ! in percent
!    call printz ('get_ocean_frac')
!  
!  ! test gaussian_topog_mod routines
!    a = .true.
!    z = get_gaussian_topog(x,y,ht,x0,y0,xw,yw,xr,yr)
!    call printz ('get_gaussian_topog')
!  
!    call gaussian_topog_init (x,y,z)
!    call printz ('gaussian_topog_init')
!  
!  contains
!  
!  ! simple printout of topog/water array
!    subroutine printz (lab)
!    character(len=*), intent(in) :: lab
!     if (a) then
!        print '(/a)', trim(lab)
!     else
!        print '(/a)', 'no data available: '//trim(lab)
!        return
!     endif
!      ! print full grid
!        print '(3x,25i5)', (nint(x(i)*rtd),i=1,nlon)
!      do j=nlat,1,-1
!        print '(i3,25i5)', nint(y(j)*rtd), (nint(z(i,j)),i=1,nlon)
!      enddo
!    end subroutine printz
!  
!  end program test
!   </PRE>
!   </TESTPROGRAM>

!   <BUG>                  
!      Water mask produces some possible erroneous water points along
!      the coast of Antarctic (at about 90W).
!   </BUG>

!   <FUTURE>Use of netcdf data sets. </FUTURE>
!   <FUTURE>Incorporate other topography and ocean data sets. </FUTURE>
! 
! </INFO>


module tracer_manager_mod
! <CONTACT EMAIL="William.Cooke@noaa.gov">
!   William Cooke
! </CONTACT>

! <REVIEWER EMAIL="Matthew.Harrison@noaa.gov">
!   Matt Harrison
! </REVIEWER>

! <REVIEWER EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </REVIEWER>

! <REVIEWER EMAIL="Peter.Phillipps@noaa.gov">
!   Peter Phillipps
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Code to manage the simple addition of tracers to the FMS code.
!     This code keeps track of the numbers and names of tracers included
!     in a tracer table.
! </OVERVIEW>

! <DESCRIPTION>
!     This code is a grouping of calls which will allow the simple
!     introduction of tracers into the FMS framework. It is designed to
!     allow users of a variety of component models interact easily with
!     the dynamical core of the model. 
!     
!     In calling the tracer manager routines the user must provide a
!     parameter identifying the model that the user is working with. This
!     parameter is defined within field_manager as MODEL_X 
!     where X is one of [ATMOS, OCEAN, LAND, ICE].
!
!     In many of these calls the argument list includes model and tracer_index. These 
!     are the parameter corresponding to the component model and the tracer_index N is 
!     the Nth tracer within the component model. Therefore a call with MODEL_ATMOS and 5 
!     is different from a call with MODEL_OCEAN and 5.
!
! </DESCRIPTION>


!----------------------------------------------------------------------

use           mpp_mod, only : mpp_error,          &
                              mpp_pe,             &
                              mpp_root_pe,        &
                              FATAL,              &
                              WARNING,            &
                              NOTE,               &
                              stdlog
use        mpp_io_mod, only : mpp_open,           &
                              mpp_close,          &
                              MPP_ASCII,          &
                              MPP_APPEND,         &
                              MPP_RDONLY
use           fms_mod, only : lowercase,          &
                              write_version_number

use field_manager_mod, only : field_manager_init, &
                              get_field_info,     &
                              get_field_methods,  &
                              MODEL_ATMOS,        &
                              MODEL_LAND,         &
                              MODEL_OCEAN,        &
                              MODEL_ICE,          &
                              MODEL_COUPLER,      &
                              NUM_MODELS,         &
                              method_type,        &
                              default_method,     &
                              parse,              &
                              fm_copy_list,       &
                              fm_change_list,     &
                              fm_modify_name,     &
                              fm_query_method,    &
                              fm_new_value,       &
                              fm_exists,          &
                              MODEL_NAMES

implicit none
private

!-----------------------------------------------------------------------

public  tracer_manager_init, &
        tracer_manager_end,  &
        check_if_prognostic, &
        get_tracer_indices,  &
        get_tracer_index,    &
        get_tracer_names,    &
        get_tracer_name,     &
        query_method,        &
        set_tracer_atts,     &
        set_tracer_profile,  &
        register_tracers,    &
        get_number_tracers,  &
        NO_TRACER,           &
        MAX_TRACER_FIELDS

!-----------------------------------------------------------------------
interface get_tracer_index
  module procedure get_tracer_index_integer, get_tracer_index_logical
end interface
!-----------------------------------------------------------------------

integer            :: num_tracer_fields = 0
integer, parameter :: MAX_TRACER_FIELDS = 120
integer, parameter :: MAX_TRACER_METHOD = 20
integer, parameter :: NO_TRACER         = 1-HUGE(1)
integer, parameter :: NOTRACER          = -HUGE(1)

integer :: total_tracers(NUM_MODELS), prog_tracers(NUM_MODELS), diag_tracers(NUM_MODELS)
logical :: model_registered(NUM_MODELS) = .FALSE.

type, private ::  tracer_type
   character(len=32)        :: tracer_name, tracer_units
   character(len=128)       :: tracer_longname
   integer                  :: num_methods, model, instances
   logical                  :: is_prognostic, instances_set
   logical                  :: needs_init
end type tracer_type

type, private ::  tracer_name_type
   character(len=32)  :: model_name, tracer_name, tracer_units
   character(len=128) :: tracer_longname
end type tracer_name_type


type, private :: inst_type
   character(len=128) :: name
   integer            :: instances
end type inst_type

type(tracer_type), save  :: tracers(MAX_TRACER_FIELDS)
type(inst_type)  , save  :: instantiations(MAX_TRACER_FIELDS)

character(len=128) :: version = '$Id: tracer_manager.F90,v 16.0 2008/07/30 22:48:11 fms Exp $'
character(len=128) :: tagname = '$Name: hiram_20101115_bw $'
logical            :: module_is_initialized = .false.

logical            :: verbose_local
integer            :: TRACER_ARRAY(NUM_MODELS,MAX_TRACER_FIELDS)

contains

!
!#######################################################################
!
! <SUBROUTINE NAME="tracer_manager_init">
!   <OVERVIEW>
!      It is not necessary to call this routine.
!      It is included only for backward compatability.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine writes the version and tagname to the logfile and 
!     sets the module initialization flag.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call tracer_manager_init
!   </TEMPLATE>
subroutine tracer_manager_init
integer :: model, num_tracers, num_prog, num_diag

  if(module_is_initialized) return
  module_is_initialized = .TRUE.

  call write_version_number (version, tagname)
  call field_manager_init()
  TRACER_ARRAY = NOTRACER
  do model=1,NUM_MODELS 
    call get_tracer_meta_data(model, num_tracers, num_prog, num_diag)
  enddo

end subroutine tracer_manager_init
! </SUBROUTINE>

!#######################################################################
! <SUBROUTINE NAME="get_tracer_meta_data">
!   <OVERVIEW>
! read tracer table and store tracer information associated with "model"
! in "tracers" array. 
!   </OVERVIEW>
subroutine get_tracer_meta_data(model, num_tracers,num_prog,num_diag)

integer,  intent(in) :: model ! model being used
integer, intent(out) :: num_tracers, num_prog, num_diag
character(len=256)    :: warnmesg

character(len=32)  :: name_type, type, name
integer :: n, m, mod, num_tracer_methods, nfields, swop
integer :: j, log_unit, num_methods
logical :: flag_type
type(method_type), dimension(MAX_TRACER_METHOD) :: methods
integer :: instances, siz_inst,i
character(len = 32) :: digit,suffnam

character(len=128) :: list_name , control
integer            :: index_list_name
logical :: fm_success

!   <ERROR MSG="invalid model type" STATUS="FATAL">
!     The index for the model type is invalid.
!   </ERROR>
if (model .ne. MODEL_ATMOS .and. model .ne. MODEL_LAND .and. &
    model .ne. MODEL_OCEAN .and. model .ne. MODEL_ICE  .and. &
    model .ne. MODEL_COUPLER) call mpp_error(FATAL,'tracer_manager_init : invalid model type')

! One should only call get_tracer_meta_data once for each model type
! Therefore need to set up an array to stop the subroutine being 
! unnecssarily called multiple times.

if ( model_registered(model) ) then
! This routine has already been called for the component model.
! Fill in the values from the previous registration and return.
  num_tracers = total_tracers(model)
  num_prog    = prog_tracers(model)
  num_diag    = diag_tracers(model) 
  return
endif

! Initialize the number of tracers to zero.
num_tracers = 0; num_prog = 0; num_diag = 0

call field_manager_init(nfields=nfields)

!   <ERROR MSG="No tracers are available to be registered." STATUS="NOTE">
!      No tracers are available to be registered. This means that the field
!      table does not exist or is empty.
!   </ERROR>
if (nfields == 0 ) then
if (mpp_pe() == mpp_root_pe()) &
  call mpp_error(NOTE,'tracer_manager_init : No tracers are available to be registered.')
  return
endif

! search through field entries for model tracers
total_tracers(model) = 0

do n=1,nfields
   call get_field_info(n,type,name,mod,num_methods)

   if (mod == model .and. type == 'tracer') then
         num_tracer_fields = num_tracer_fields + 1
         total_tracers(model) = total_tracers(model) + 1
         TRACER_ARRAY(model,total_tracers(model))  = num_tracer_fields
!   <ERROR MSG="MAX_TRACER_FIELDS exceeded" STATUS="FATAL">
!     The maximum number of tracer fields has been exceeded.
!   </ERROR>
         if(num_tracer_fields > MAX_TRACER_FIELDS) call mpp_error(FATAL,'tracer_manager_init: MAX_TRACER_FIELDS exceeded')
         tracers(num_tracer_fields)%model          = model
         tracers(num_tracer_fields)%tracer_name    = name
         tracers(num_tracer_fields)%tracer_units   = 'none'
         tracers(num_tracer_fields)%tracer_longname = tracers(num_tracer_fields)%tracer_name
         tracers(num_tracer_fields)%instances_set   = .FALSE.
         num_tracer_methods     = 0
         methods = default_method ! initialize methods array
         call get_field_methods(n,methods)
         do j=1,num_methods
            select case (methods(j)%method_type) 
            case ('units')
               tracers(num_tracer_fields)%tracer_units   = methods(j)%method_name
            case ('longname')
               tracers(num_tracer_fields)%tracer_longname = methods(j)%method_name
            case ('instances')
!               tracers(num_tracer_fields)%instances = methods(j)%method_name
               siz_inst = parse(methods(j)%method_name,"",instances)
               tracers(num_tracer_fields)%instances = instances
               tracers(num_tracer_fields)%instances_set   = .TRUE.
            case default
               num_tracer_methods = num_tracer_methods+1
!               tracers(num_tracer_fields)%methods(num_tracer_methods) = methods(j)
            end select
         enddo
         tracers(num_tracer_fields)%num_methods = num_tracer_methods
         tracers(num_tracer_fields)%needs_init = .false.
         flag_type = query_method ('tracer_type',model,total_tracers(model),name_type)
         if (flag_type .and. name_type == 'diagnostic') then
            tracers(num_tracer_fields)%is_prognostic = .false.
         else   
            tracers(num_tracer_fields)%is_prognostic = .true.
         endif   
         if (tracers(num_tracer_fields)%is_prognostic) then
            num_prog = num_prog+1
         else
            num_diag = num_diag+1
         endif
   endif
enddo

! Now cycle through the tracers and add additional instances of the tracers.

do n = 1, num_tracer_fields !{
!   call get_field_info(n,type,name,mod,num_methods)

  if ( model == tracers(n)%model .and. tracers(n)%instances_set ) then !{ We have multiple instances of this tracer

    if ( num_tracer_fields + tracers(n)%instances > MAX_TRACER_FIELDS ) then
      write(warnmesg, '("tracer_manager_init: Number of tracers will exceed MAX_TRACER_FIELDS with &
                       &multiple (",I3," instances) setup of tracer ",A)') tracers(n)%instances,tracers(n)%tracer_name
      call mpp_error(FATAL, warnmesg)
    endif                        

    do i = 2, tracers(n)%instances !{
      num_tracer_fields = num_tracer_fields + 1
      total_tracers(model) = total_tracers(model) + 1
      TRACER_ARRAY(model,total_tracers(model))  = num_tracer_fields
      ! Copy the original tracer type to the multiple instances.
      tracers(num_tracer_fields) = tracers(n)
      if ( query_method ('instances', model,model_tracer_number(model,n),name, control)) then !{
          
        if (i .lt. 10) then  !{
           write (suffnam,'(''suffix'',i1)') i
           siz_inst = parse(control, suffnam,digit)
           if (siz_inst == 0 ) then
             write (digit,'(''_'',i1)') i
           else
             digit = "_"//trim(digit)
           endif  
        elseif (i .lt. 100) then  !}{
           write (suffnam,'(''suffix'',i2)') i
           siz_inst = parse(control, suffnam,digit)
           if (siz_inst == 0 ) then
             write (digit,'(''_'',i2)') i
           else
             digit = "_"//trim(digit)
           endif
        else  !}{
          call mpp_error(FATAL, 'tracer_manager_init: MULTIPLE_TRACER_SET_UP exceeds 100 for '//tracers(n)%tracer_name )
        endif  !}

        select case(model)
          case (MODEL_COUPLER)
            list_name = "/coupler_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
          case (MODEL_ATMOS)
            list_name = "/atmos_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
          case (MODEL_OCEAN)
            list_name = "/ocean_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
          case (MODEL_ICE  )
            list_name = "/ice_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
          case (MODEL_LAND )
            list_name = "/land_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
          case default
            list_name = "/default/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
        end select

        if (mpp_pe() == mpp_root_pe() ) write (*,*) "Creating list name = ",trim(list_name)//trim(digit)

        index_list_name = fm_copy_list(trim(list_name),digit, create = .true.)
        tracers(num_tracer_fields)%tracer_name = trim(tracers(num_tracer_fields)%tracer_name)//trim(digit)
      endif !}
         
      if (tracers(num_tracer_fields)%is_prognostic) then !{
         num_prog = num_prog+1
      else !}{
         num_diag = num_diag+1
      endif !}
    enddo !}
    ! Multiple instances of tracers were found so need to rename the original tracer.
    digit = "_1" 
    siz_inst = parse(control, "suffix1",digit)
    if (siz_inst > 0 ) then !{
      digit = "_"//trim(digit)
    endif !}
    fm_success = fm_modify_name(trim(list_name), trim(tracers(n)%tracer_name)//trim(digit))
    tracers(n)%tracer_name = trim(tracers(n)%tracer_name)//trim(digit)
  endif !}
enddo !}

! Find any field entries with the instances keyword.
do n=1,nfields
   call get_field_info(n,type,name,mod,num_methods)

   if ( mod == model .and. type == 'instances' ) then
      call get_field_methods(n,methods)
      do j=1,num_methods

         if (.not.get_tracer_index(mod,methods(j)%method_type,m)) then 
           call mpp_error(FATAL,'tracer_manager_init: The instances keyword was found for undefined tracer '&
           //trim(methods(j)%method_type))
         else
           if ( tracers(m)%instances_set ) &
              call mpp_error(FATAL,'tracer_manager_init: The instances keyword was found for '&
              //trim(methods(j)%method_type)//' but has previously been defined in the tracer entry')
           siz_inst = parse(methods(j)%method_name,"",instances)
           tracers(m)%instances = instances
           call mpp_error(NOTE,'tracer_manager_init: '//trim(instantiations(j)%name)// &
                               ' will have '//trim(methods(j)%method_name)//' instances')
         endif
         if ( num_tracer_fields + instances > MAX_TRACER_FIELDS ) then
           write(warnmesg, '("tracer_manager_init: Number of tracers will exceed MAX_TRACER_FIELDS with &
                       &multiple (",I3," instances) setup of tracer ",A)') tracers(m)%instances,tracers(m)%tracer_name
           call mpp_error(FATAL, warnmesg)
         endif                        
! We have found a valid tracer that has more than one instantiation.
! We need to modify that tracer name to tracer_1 and add extra tracers for the extra instantiations.
         if (instances .eq. 1) then
           siz_inst = parse(methods(j)%method_control, 'suffix1',digit)
           if (siz_inst == 0 ) then
             digit = '_1'
           else
             digit = "_"//trim(digit)
           endif  
         endif
         do i = 2, instances
           num_tracer_fields = num_tracer_fields + 1
           total_tracers(model) = total_tracers(model) + 1
           TRACER_ARRAY(model,total_tracers(model))  = num_tracer_fields
           tracers(num_tracer_fields)                =  tracers(m)
           
           if (i .lt. 10) then  !{
             write (suffnam,'(''suffix'',i1)') i
             siz_inst = parse(methods(j)%method_control, suffnam,digit)
             if (siz_inst == 0 ) then
               write (digit,'(''_'',i1)') i
             else
               digit = "_"//trim(digit)
             endif  
          elseif (i .lt. 100) then  !}{
             write (suffnam,'(''suffix'',i2)') i
             siz_inst = parse(methods(j)%method_control, suffnam,digit)
             if (siz_inst == 0 ) then
               write (digit,'(''_'',i2)') i
             else
               digit = "_"//trim(digit)
             endif
          else  !}{
            call mpp_error(FATAL, 'tracer_manager_init: MULTIPLE_TRACER_SET_UP exceeds 100 for '&
                                  //tracers(num_tracer_fields)%tracer_name )
          endif  !}

          select case(model)
            case (MODEL_COUPLER)
              list_name = "/coupler_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
            case (MODEL_ATMOS)
              list_name = "/atmos_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
            case (MODEL_OCEAN)
              list_name = "/ocean_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
            case (MODEL_ICE  )
              list_name = "/ice_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
            case (MODEL_LAND )
              list_name = "/land_mod/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
            case default
              list_name = "/default/tracer/"//trim(tracers(num_tracer_fields)%tracer_name)
          end select

          if (mpp_pe() == mpp_root_pe() ) write (*,*) "Creating list name = ",trim(list_name)

          index_list_name = fm_copy_list(trim(list_name),digit, create = .true.)

          tracers(num_tracer_fields)%tracer_name    =  trim(tracers(num_tracer_fields)%tracer_name)//digit
          if (tracers(num_tracer_fields)%is_prognostic) then
            num_prog = num_prog+1
          else
            num_diag = num_diag+1
          endif
        enddo
!Now rename the original tracer to tracer_1 (or if suffix1 present to tracer_'value_of_suffix1')
        siz_inst = parse(methods(j)%method_control, 'suffix1',digit)
        if (siz_inst == 0 ) then
          digit = '_1'
        else
          digit = "_"//trim(digit)
        endif  
        fm_success = fm_modify_name(trim(list_name), trim(tracers(m)%tracer_name)//trim(digit))
        tracers(m)%tracer_name    =  trim(tracers(m)%tracer_name)//trim(digit)
      enddo
   endif
enddo

num_tracers = num_prog + num_diag
! Make the number of tracers available publicly.
total_tracers(model)    = num_tracers
prog_tracers(model)     = num_prog
diag_tracers(model)     = num_diag
model_registered(model) = .TRUE.

! Now sort through the tracer fields and sort them so that the 
! prognostic tracers are first.

do n=1, num_tracers
  if (.not.check_if_prognostic(model,n) .and. n.le.num_prog) then 
  ! This is a diagnostic tracer so find a prognostic tracer to swop with
    do m = n, num_tracers
       if (check_if_prognostic(model,m) .and. .not.check_if_prognostic(model,n)) then
           swop = TRACER_ARRAY(model,n)
           TRACER_ARRAY(model,n) = TRACER_ARRAY(model,m)
           TRACER_ARRAY(model,m) = swop
           cycle
       endif
    enddo
  endif
enddo

do n=1, num_tracer_fields
  call print_tracer_info(model,n)
enddo

log_unit = stdlog()
if ( mpp_pe() == mpp_root_pe() ) then
   write (log_unit,15) trim(MODEL_NAMES(model)),total_tracers(model)
endif

15 format ('Number of tracers in field table for ',A,' model = ',i4)

end subroutine get_tracer_meta_data
!</SUBROUTINE>


function model_tracer_number(model,n)
integer, intent(in) :: model, n
integer model_tracer_number

integer :: i

model_tracer_number = NO_TRACER

do i = 1, MAX_TRACER_FIELDS
  if ( TRACER_ARRAY(model,i) == n ) then
    model_tracer_number = i
    return
  endif
enddo

end function model_tracer_number

!#######################################################################
!
! <SUBROUTINE NAME="register_tracers">

!   <OVERVIEW>
!      It is not necessary to call this routine.
!      It is included only for backward compatability.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine returns the total number of valid tracers,
!     the number of prognostic and diagnostic tracers.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call register_tracers(model, num_tracers,num_prog,num_diag)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter to identify which model is being used.
!   </IN>
!   <OUT NAME="num_tracers" TYPE="integer">
!    The total number of valid tracers within the component model.
!   </OUT>
!   <OUT NAME="num_prog" TYPE="integer">
!     The number of prognostic tracers within the component model.
!   </OUT>
!   <OUT NAME="num_diag" TYPE="integer">
!     The number of diagnostic tracers within the component model.
!   </OUT>
subroutine register_tracers(model, num_tracers, num_prog, num_diag, num_family)
integer, intent(in) :: model
integer, intent(out) :: num_tracers, num_prog, num_diag
integer, intent(out), optional :: num_family

if(.not.module_is_initialized) call tracer_manager_init

call get_number_tracers(model, num_tracers, num_prog, num_diag, num_family)

end subroutine register_tracers
!</SUBROUTINE>

!#######################################################################

! <SUBROUTINE NAME="get_number_tracers">
!   <OVERVIEW>
!      A routine to return the number of tracers included in a component model.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine returns the total number of valid tracers,
!     the number of prognostic and diagnostic tracers
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_number_tracers(model, num_tracers,num_prog,num_diag)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter to identify which model is being used.
!   </IN>
!   <OUT NAME="num_tracers" TYPE="integer, optional">
!    The total number of valid tracers within the component model.
!   </OUT>
!   <OUT NAME="num_prog" TYPE="integer, optional">
!     The number of prognostic tracers within the component model.
!   </OUT>
!   <OUT NAME="num_diag" TYPE="integer, optional">
!     The number of diagnostic tracers within the component model.
!   </OUT>
subroutine get_number_tracers(model, num_tracers, num_prog, num_diag, num_family)

integer,  intent(in) :: model
integer, intent(out), optional :: num_tracers, num_prog, num_diag, num_family

if(.not.module_is_initialized) call tracer_manager_init

!   <ERROR MSG="Model number is invalid." STATUS="FATAL">
!     The index of the component model is invalid.
!   </ERROR>
if (model .ne. MODEL_ATMOS .and. model .ne. MODEL_LAND .and. &
    model .ne. MODEL_OCEAN .and. model .ne. MODEL_ICE  .and. &
    model .ne. MODEL_COUPLER)  &
    call mpp_error(FATAL,"get_number_tracers : Model number is invalid.")

if (present(num_tracers)) num_tracers = total_tracers(model)
if (present(num_prog))    num_prog    = prog_tracers(model)
if (present(num_diag))    num_diag    = diag_tracers(model)
if (present(num_family))  num_family  = 0 ! Needed only for backward compatability with lima

end subroutine get_number_tracers
!</SUBROUTINE>


! <SUBROUTINE NAME="get_tracer_indices">

!   <OVERVIEW>
!     Routine to return the component model tracer indices as defined within
!     the tracer manager.
!   </OVERVIEW>
!   <DESCRIPTION>
!     If several models are being used or redundant tracers have been written to
! the tracer_table, then the indices in the component model and the tracer
! manager may not have a one to one correspondence. Therefore the component
! model needs to know what index to pass to calls to tracer_manager routines in
! order that the correct tracer information be accessed.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_tracer_indices(model, ind, prog_ind, diag_ind)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter to identify which model is being used.
!   </IN>
!   <OUT NAME="ind" TYPE="integer, optional" DIM="(:)" >
! An array containing the tracer manager defined indices for
!             all the tracers within the component model.
!   </OUT>
!   <OUT NAME="prog_ind" TYPE="integer, optional" DIM="(:)" >
! An array containing the tracer manager defined indices for
!             the prognostic tracers within the component model.
!   </OUT>
!   <OUT NAME="diag_ind" TYPE="integer, optional" DIM="(:)" >
! An array containing the tracer manager defined indices for
!             the diagnostic tracers within the component model.
!   </OUT>
subroutine get_tracer_indices(model, ind, prog_ind, diag_ind, fam_ind)

integer, intent(in) :: model
integer, intent(out), dimension(:), optional :: ind, prog_ind, diag_ind, fam_ind

integer :: i, j, np, nd, n

if(.not.module_is_initialized) call tracer_manager_init

nd=0;np=0;n=0

! Initialize arrays with dummy values
if (PRESENT(ind))      ind      = NO_TRACER
if (PRESENT(prog_ind)) prog_ind = NO_TRACER
if (PRESENT(diag_ind)) diag_ind = NO_TRACER
if (PRESENT(fam_ind))  fam_ind  = NO_TRACER

do i = 1, MAX_TRACER_FIELDS
j = TRACER_ARRAY(model,i)
 if ( j /= NOTRACER) then
   if ( model == tracers(j)%model) then
      if (PRESENT(ind)) then
         n=n+1
!   <ERROR MSG="index array size too small in get_tracer_indices" STATUS="FATAL">
!     The global index array is too small and cannot contain all the tracer numbers.
!   </ERROR>
         if (n > size(ind(:))) call mpp_error(FATAL,'get_tracer_indices : index array size too small in get_tracer_indices')
         ind(n) = i
      endif

      if (tracers(j)%is_prognostic.and.PRESENT(prog_ind)) then
         np=np+1
!   <ERROR MSG="prognostic array size too small in get_tracer_indices" STATUS="FATAL">
!     The prognostic index array is too small and cannot contain all the tracer numbers.
!   </ERROR>
         if ( np > size( prog_ind(:)))call mpp_error(FATAL,&
                                          'get_tracer_indices : prognostic array size too small in get_tracer_indices')
         prog_ind(np) = i
      else if (.not.tracers(j)%is_prognostic .and. PRESENT(diag_ind)) then
         nd = nd+1
!   <ERROR MSG="diagnostic array size too small in get_tracer_indices" STATUS="FATAL">
!     The diagnostic index array is too small and cannot contain all the tracer numbers.
!   </ERROR>
         if (nd > size(diag_ind(:))) call mpp_error(FATAL,&
                                         'get_tracer_indices : diagnostic array size too small in get_tracer_indices')
         diag_ind(nd) = i
      endif
   endif
 endif
enddo

return
end subroutine get_tracer_indices
!</SUBROUTINE>

!<FUNCTION NAME= "get_tracer_index">
!   <OVERVIEW>
!     Function which returns the number assigned to the tracer name.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This is a function which returns the index, as implied within the component model.
!     There are two overloaded interfaces: one of type integer, one logical.
!   </DESCRIPTION>
!   <TEMPLATE>
!     integer: index = get_tracer_index(model, name,        indices, verbose)
!     logical:    if ( get_tracer_index(model, name, index, indices, verbose) ) then
!   </TEMPLATE>
!   <IN NAME="model" TYPE="integer">
!     A parameter to identify which model is being used.
!   </IN>
!   <IN NAME="name" TYPE="character">
!     The name of the tracer (as assigned in the field table).
!   </IN>
!   <IN NAME="indices" TYPE="integer, optional" DIM="(:)">
!     An array indices.
!     When present, the returned index will limit the search for the tracer
!     to those tracers whos indices are amoung those in array "indices".
!     This would be useful when it is desired to limit the search to a subset
!     of the tracers. Such a subset might be the diagnostic or prognostic tracers.
!     (Note that subroutine get_tracer_indices returns these subsets)
!   </IN>
!   <IN NAME="verbose" TYPE="logical, optional">
!     A flag to allow the message saying that a tracer with this name has not 
!     been found. This should only be used for debugging purposes.
!   </IN>
!   <OUT NAME="get_tracer_index" TYPE="integer">
!     integer function:
!       The index of the tracer named "name". 
!       If no tracer by that name exists then the returned value is NO_TRACER.
!     logical function:
!       If no tracer by that name exists then the returned value is .false.,
!       otherwise the returned value is .true.
!   </OUT>
function get_tracer_index_integer(model, name, indices, verbose)

integer, intent(in)                         :: model
character(len=*), intent(in)                :: name
integer, intent(in), dimension(:), optional :: indices
logical, intent(in), optional               :: verbose
integer :: get_tracer_index_integer

integer :: i

if(.not.module_is_initialized) call tracer_manager_init

get_tracer_index_integer = NO_TRACER

if (PRESENT(indices)) then
    do i = 1, size(indices(:))
       if (model == tracers(indices(i))%model .and. lowercase(trim(name)) == trim(tracers(indices(i))%tracer_name)) then
           get_tracer_index_integer = i
           exit
       endif
    enddo
else
    do i=1, num_tracer_fields
       if(TRACER_ARRAY(model,i) == NOTRACER) cycle
       if (lowercase(trim(name)) == trim(tracers(TRACER_ARRAY(model,i))%tracer_name)) then
           get_tracer_index_integer = i!TRACER_ARRAY(model,i)
           exit
       endif
    enddo
end if

verbose_local=.FALSE.
if (present(verbose)) verbose_local=verbose

if (verbose_local) then
! <ERROR MSG="tracer with this name not found: X" STATUS="NOTE">
  if (get_tracer_index_integer == NO_TRACER ) then
    call mpp_error(NOTE,'get_tracer_index : tracer with this name not found: '//trim(name))
  endif
! </ERROR>
endif
   
return

end function get_tracer_index_integer

!#######################################################################
function get_tracer_index_logical(model, name, index, indices, verbose)

integer, intent(in)                         :: model
character(len=*), intent(in)                :: name
integer, intent(out)                        :: index
integer, intent(in), dimension(:), optional :: indices
logical, intent(in), optional               :: verbose
logical :: get_tracer_index_logical

index = get_tracer_index_integer(model, name, indices, verbose)
if(index == NO_TRACER) then
  get_tracer_index_logical = .false.
else
  get_tracer_index_logical = .true.
endif

end function get_tracer_index_logical
!</FUNCTION>

!#######################################################################
! <SUBROUTINE NAME="tracer_manager_end" >
!   <OVERVIEW>
!     Routine to write to the log file that the tracer manager is ending.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Routine to write to the log file that the tracer manager is ending.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call tracer_manager_end
!   </TEMPLATE>
subroutine tracer_manager_end

integer :: log_unit

log_unit = stdlog()
if ( mpp_pe() == mpp_root_pe() ) then
   write (log_unit,'(/,(a))') 'Exiting tracer_manager, have a nice day ...'
endif

module_is_initialized = .FALSE.

end subroutine tracer_manager_end
!</SUBROUTINE>

!#######################################################################
!
subroutine print_tracer_info(model,n)
!
! Routine to print out the components of the tracer.
! This is useful for informational purposes.
! Used in get_tracer_meta_data.
!
! Arguments:
! INTENT IN
!  i            : index of the tracer that is being printed.
!
integer, intent(in) :: model,n
integer :: i,log_unit

if(.not.module_is_initialized) call tracer_manager_init

if(mpp_pe()==mpp_root_pe() .and. TRACER_ARRAY(model,n)> 0 ) then
  i = TRACER_ARRAY(model,n)
  log_unit = stdlog()
  write(log_unit, *)'----------------------------------------------------'
  write(log_unit, *) 'Contents of tracer entry ', i
  write(log_unit, *) 'Model type and field name'
  write(log_unit, *) 'Model                : ', tracers(i)%model
  write(log_unit, *) 'Field name           : ', trim(tracers(i)%tracer_name)
  write(log_unit, *) 'Tracer units         : ', trim(tracers(i)%tracer_units)
  write(log_unit, *) 'Tracer longname      : ', trim(tracers(i)%tracer_longname)
  write(log_unit, *) 'Tracer is_prognostic : ', tracers(i)%is_prognostic
  write(log_unit, *)'----------------------------------------------------'
endif

900 FORMAT(A,2(1x,E12.6))
901 FORMAT(E12.6,1x,E12.6)


end subroutine print_tracer_info

!#######################################################################
!
! <SUBROUTINE NAME="get_tracer_names" >
!   <OVERVIEW>
!     Routine to find the names associated with a tracer number.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine can return the name, long name and units associated
!     with a tracer.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call get_tracer_names(model,n,name,longname, units)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="n" TYPE="integer">
!     Tracer number.
!   </IN>
!   <OUT NAME="name" TYPE="character" >
!     Field name associated with tracer number.
!   </OUT>
!   <OUT NAME="longname" TYPE="character, optional" >
!     The long name associated with tracer number.
!   </OUT>
!   <OUT NAME="units" TYPE="character, optional" >
!     The units associated with tracer number.
!   </OUT>

subroutine get_tracer_names(model,n,name,longname, units, err_msg)

integer,          intent(in)  :: model, n
character (len=*),intent(out) :: name
character (len=*), intent(out), optional :: longname, units, err_msg
character (len=128) :: err_msg_local
integer :: n1
character(len=11) :: chn

if(.not.module_is_initialized) call tracer_manager_init

 if (n < 1 .or. n > total_tracers(model)) then
   write(chn, '(i11)') n
   err_msg_local = ' Invalid tracer index.  Model name = '//trim(MODEL_NAMES(model))//',  Index='//trim(chn)
   if(error_handler('get_tracer_names', err_msg_local, err_msg)) return
 endif
 n1 = TRACER_ARRAY(model,n)

name = trim(tracers(n1)%tracer_name)
if (PRESENT(longname)) longname = trim(tracers(n1)%tracer_longname)
if (PRESENT(units))    units    = trim(tracers(n1)%tracer_units)

end subroutine get_tracer_names
!</SUBROUTINE>
!
!#######################################################################
!
! <FUNCTION NAME="get_tracer_name" >
!   <OVERVIEW>
!     Routine to find the names associated with a tracer number.
!   </OVERVIEW>
!   <DESCRIPTION>
!     This routine can return the name, long name and units associated with a tracer.
!     The return value of get_tracer_name is .false. when a FATAL error condition is
!     detected, otherwise the return value is .true.
!   </DESCRIPTION>
!   <TEMPLATE>
!     if(.not.get_tracer_name(model,n,name,longname, units, err_msg)) call mpp_error(.....
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="n" TYPE="integer">
!     Tracer number.
!   </IN>
!   <OUT NAME="name" TYPE="character" >
!     Field name associated with tracer number.
!   </OUT>
!   <OUT NAME="longname" TYPE="character, optional" >
!     The long name associated with tracer number.
!   </OUT>
!   <OUT NAME="units" TYPE="character, optional" >
!     The units associated with tracer number.
!   </OUT>
!   <OUT NAME="err_msg" TYPE="character, optional" >
!     When present:
!       If a FATAL error condition is detected then err_msg will contain an error message
!       and the return value of get_tracer_name will be .false.
!       If no FATAL error is detected err_msg will be filled with space characters and
!       and the return value of get_tracer_name will be .true.
!     When not present:
!       A FATAL error will result in termination inside get_tracer_name without returning.
!       If no FATAL error is detected the return value of get_tracer_name will be .true.
!   </OUT>

function get_tracer_name(model,n,name,longname, units, err_msg)

logical :: get_tracer_name
integer,          intent(in)  :: model, n
character (len=*),intent(out) :: name
character (len=*), intent(out), optional :: longname, units, err_msg
character (len=128) :: err_msg_local
integer :: n1
character(len=11) :: chn

if(.not.module_is_initialized) call tracer_manager_init

 if (n < 1 .or. n > total_tracers(model)) then
   write(chn, '(i11)') n
   err_msg_local = ' Invalid tracer index.  Model name = '//trim(MODEL_NAMES(model))//',  Index='//trim(chn)
   if(error_handler('get_tracer_name', err_msg_local, err_msg)) then
     get_tracer_name = .false.
     return
   endif
 else
   get_tracer_name = .true.
 endif
 n1 = TRACER_ARRAY(model,n)

name = trim(tracers(n1)%tracer_name)
if (PRESENT(longname)) longname = trim(tracers(n1)%tracer_longname)
if (PRESENT(units))    units    = trim(tracers(n1)%tracer_units)

end function get_tracer_name
!</FUNCTION>
!
!#######################################################################
!
!<FUNCTION NAME= "check_if_prognostic">
!   <OVERVIEW>
!    Function to see if a tracer is prognostic or diagnostic.
!   </OVERVIEW>
!   <DESCRIPTION>
!    All tracers are assumed to be prognostic when read in from the field_table
!    However a tracer can be changed to a diagnostic tracer by adding the line
!    "tracer_type","diagnostic"
!    to the tracer description in field_table.
!   </DESCRIPTION>
!   <TEMPLATE>
!     logical =check_if_prognostic(model, n)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="n" TYPE="integer">
!     Tracer number
!   </IN>
!   <OUT NAME="check_if_prognostic" TYPE="logical">
!     A logical flag set TRUE if the tracer is 
!                        prognostic.
!   </OUT>
function check_if_prognostic(model, n, err_msg)

integer, intent(in) :: model, n
logical             :: check_if_prognostic
character(len=*), intent(out), optional :: err_msg
character(len=128) :: err_msg_local
character(len=11) :: chn

if(.not.module_is_initialized) call tracer_manager_init

if (n < 1 .or. n > total_tracers(model)) then
  write(chn, '(i11)') n
  err_msg_local = ' Invalid tracer index.  Model name = '//trim(MODEL_NAMES(model))//',  Index='//trim(chn)
  check_if_prognostic = .true.
  if(error_handler('check_if_prognostic', err_msg_local, err_msg)) return
endif

!Convert local model index to tracer_manager index

check_if_prognostic = tracers(TRACER_ARRAY(model,n))%is_prognostic

end function check_if_prognostic
!</FUNCTION>
!
!#######################################################################
!
! <SUBROUTINE NAME="set_tracer_profile" >
!   <OVERVIEW>
!     Subroutine to set the tracer field to the wanted profile.
!   </OVERVIEW>
!   <DESCRIPTION>
!     If the profile type is 'fixed' then the tracer field values are set 
! equal to the surface value.
! If the profile type is 'profile' then the top/bottom of model and
! surface values are read and an exponential profile is calculated,
! with the profile being dependent on the number of levels in the
! component model. This should be called from the part of the dynamical
! core where tracer restarts are called in the event that a tracer
! restart file does not exist.
!
!  This can be activated by adding a method to the field_table
! e.g.
!  "profile_type","fixed","surface_value = 1e-12"
!  would return values of surf_value = 1e-12 and a multiplier of 1.0
!  One can use these to initialize the entire field with a value of 1e-12.
!
!  "profile_type","profile","surface_value = 1e-12, top_value = 1e-15"
!   In a 15 layer model this would return values of surf_value = 1e-12 and 
!   multiplier = 0.6309573 i.e 1e-15 = 1e-12*(0.6309573^15)
!   In this case the model should be MODEL_ATMOS as you have a "top" value.
!
!   If you wish to initialize the ocean model, one can use bottom_value instead
!   of top_value.

!   </DESCRIPTION>
!   <TEMPLATE>
!     call set_tracer_profile(model, n, tracer)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="n" TYPE="integer">
!     Tracer number.
!   </IN>
!   <INOUT NAME="tracer_array" TYPE="real">
!     The initialized tracer array.
!   </INOUT>

subroutine set_tracer_profile(model, n, tracer, err_msg)

integer,  intent(in)  :: model, n
   real, intent(inout), dimension(:,:,:) :: tracer
character(len=*), intent(out), optional :: err_msg

real    :: surf_value, multiplier
integer :: numlevels, k, n1, flag
real    :: top_value, bottom_value
character(len=80) :: scheme, control,profile_type
character(len=128) :: err_msg_local
character(len=11) :: chn

if(.not.module_is_initialized) call tracer_manager_init

if (n < 1 .or. n > total_tracers(model)) then
  write(chn, '(i11)') n
  err_msg_local = ' Invalid tracer index.  Model name = '//trim(MODEL_NAMES(model))//',  Index='//trim(chn)
  if(error_handler('set_tracer_profile', err_msg_local, err_msg)) return
endif
n1 = TRACER_ARRAY(model,n)

!default values
profile_type  = 'Fixed'
surf_value = 0.0E+00
top_value  = surf_value
bottom_value = surf_value
multiplier = 1.0

tracer = surf_value

if ( query_method ( 'profile_type',model,n,scheme,control)) then
!Change the tracer_number to the tracer_manager version

  if(lowercase(trim(scheme(1:5))).eq.'fixed') then
    profile_type                   = 'Fixed'
    flag =parse(control,'surface_value',surf_value)
    multiplier = 1.0
    tracer = surf_value
  endif

  if(lowercase(trim(scheme(1:7))).eq.'profile') then
    profile_type                   = 'Profile'
    flag=parse(control,'surface_value',surf_value)
    if (surf_value .eq. 0.0) &
      call mpp_error(FATAL,'set_tracer_profile : Cannot have a zero surface value for an exponential profile. Tracer '&
                           //tracers(n1)%tracer_name//" "//control//" "//scheme)
    select case (tracers(n1)%model)
      case (MODEL_ATMOS)
        flag=parse(control,'top_value',top_value)
        if(mpp_pe()==mpp_root_pe() .and. flag == 0) &
           call mpp_error(NOTE,'set_tracer_profile : Parameter top_value needs to be defined for the tracer profile.')
      case (MODEL_OCEAN)
        flag =parse(control,'bottom_value',bottom_value)
        if(mpp_pe() == mpp_root_pe() .and. flag == 0) &
           call mpp_error(NOTE,'set_tracer_profile : Parameter bottom_value needs to be defined for the tracer profile.')
      case default
!   Should there be a NOTE or WARNING message here?
    end select

! If profile type is profile then set the surface value to the input
! value and calculate the vertical multiplier.
! 
! Assume an exponential decay/increase from the surface to the top level
!  C = C0 exp ( -multiplier* level_number)
!  => multiplier = exp [ ln(Ctop/Csurf)/number_of_levels]
!
numlevels = size(tracer,3) -1
    select case (tracers(n1)%model)
      case (MODEL_ATMOS)
        multiplier = exp( log (top_value/surf_value) /numlevels)
        tracer(:,:,1) = surf_value
        do k = 2, size(tracer,3)
          tracer(:,:,k) = tracer(:,:,k-1) * multiplier
        enddo
      case (MODEL_OCEAN)
        multiplier = exp( log (bottom_value/surf_value) /numlevels)
        tracer(:,:,size(tracer,3)) = surf_value
        do k = size(tracer,3) - 1, 1, -1
          tracer(:,:,k) = tracer(:,:,k+1) * multiplier
        enddo
      case default
    end select
  endif !scheme.eq.profile

  if (mpp_pe() == mpp_root_pe() ) write(*,700) 'Tracer ',trim(tracers(n1)%tracer_name),    &
                            ' initialized with surface value of ',surf_value, &
                            ' and vertical multiplier of ',multiplier
  700 FORMAT (3A,E12.6,A,F10.6)

endif ! end of query scheme

end subroutine set_tracer_profile
!</SUBROUTINE>

!
!#######################################################################
!
! <FUNCTION NAME="query_method" >
!   <OVERVIEW>
!     A function to query the "methods" associated with each tracer.
!   </OVERVIEW>
!   <DESCRIPTION>
!     A function to query the "methods" associated with each tracer. The
!  "methods" are the parameters of the component model that can be
!  adjusted by user by placing formatted strings, associated with a
!  particular tracer, within the field table.
!  These methods can control the advection, wet deposition, dry
!  deposition or initial profile of the tracer in question. Any
!  parametrization can use this function as long as a routine for parsing
!  the name and control strings are provided by that routine.
!   </DESCRIPTION>
!   <TEMPLATE>
!     logical =query_method  (method_type, model, n, name, control)
!   </TEMPLATE>

!   <IN NAME="method_type" TYPE="character">
!     The method that is being requested.
!   </IN>
!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="n" TYPE="integer">
!     Tracer number
!   </IN>
!   <OUT NAME="name" TYPE="character">
!     A string containing the modified name to be used with
!     method_type. i.e. "2nd_order" might be the default for 
!     advection. One could use "4th_order" here to modify 
!     that behaviour.
!   </OUT>
!   <OUT NAME="control" TYPE="character, optional">
!     A string containing the modified parameters that are 
!     associated with the method_type and name.
!   </OUT>
!   <OUT NAME="query_method" TYPE="logical">
!      A flag to show whether method_type exists with regard to
!      tracer n. If method_type is not present then one must
!      have default values.
!   </OUT>

!<NOTE>
!  At present the tracer manager module allows the initialization of a tracer
!  profile if a restart does not exist for that tracer. 
!  Options for this routine are as follows
!
!  Tracer profile setup
!  ==================================================================
!  |method_type  |method_name  |method_control                      |
!  ==================================================================
!  |profile_type |fixed        |surface_value = X                   |
!  |profile_type |profile      |surface_value = X, top_value = Y    |(atmosphere)
!  |profile_type |profile      |surface_value = X, bottom_value = Y |(ocean)
!  ==================================================================
!
!</NOTE>
 function query_method  (method_type, model, n, name, control, err_msg)
!
!  A function to query the schemes associated with each tracer. 
!  
!  INTENT IN
!   method_type  : The method that is being requested.
!   model        : The model that you are calling this function from.
!   n            : The tracer number.
!  INTENT OUT
!   name         : A string containing the modified name to be used with
!                  method_type. i.e. "2nd_order" might be the default for 
!                  advection. One could use "4th_order" here to modify 
!                  that behaviour.
!   control      : A string containing the modified parameters that are 
!                  associated with the method_type and name.
!   query_method : A flag to show whether method_type exists with regard 
!                  to tracer n. If method_type is not present then one
!                  must have default values.

 character(len=*), intent(in)            :: method_type
 integer         , intent(in)            :: model, n
 character(len=*), intent(out)           :: name
 character(len=*), intent(out), optional :: control, err_msg
 logical                                 :: query_method

 integer :: n1
 character(len=256) :: list_name, control_tr
 character(len=11)  :: chn
 character(len=128) :: err_msg_local

 if(.not.module_is_initialized) call tracer_manager_init

!Convert the local model tracer number to the tracer_manager version.

 if (n < 1 .or. n > total_tracers(model)) then
   write(chn, '(i11)') n
   err_msg_local = ' Invalid tracer index.  Model name = '//trim(MODEL_NAMES(model))//',  Index='//trim(chn)
   if(error_handler('query_method', err_msg_local, err_msg)) return
 endif

 n1 = TRACER_ARRAY(model,n)

 select case(model)
  case (MODEL_COUPLER)
   list_name = "/coupler_mod/tracer/"//trim(tracers(n1)%tracer_name)//"/"//trim(method_type)
  case (MODEL_ATMOS)
   list_name = "/atmos_mod/tracer/"//trim(tracers(n1)%tracer_name)//"/"//trim(method_type)
  case (MODEL_OCEAN)
   list_name = "/ocean_mod/tracer/"//trim(tracers(n1)%tracer_name)//"/"//trim(method_type)
  case (MODEL_ICE  )
   list_name = "/ice_mod/tracer/"//trim(tracers(n1)%tracer_name)//"/"//trim(method_type)
  case (MODEL_LAND )
   list_name = "/land_mod/tracer/"//trim(tracers(n1)%tracer_name)//"/"//trim(method_type)
  case default
   list_name = "/default/tracer/"//trim(tracers(n1)%tracer_name)//"/"//trim(method_type)
 end select

 name = ''
 control_tr = ''
 query_method = fm_query_method(list_name, name, control_tr)

 if ( present(control)) control = trim(control_tr)

 end function query_method
!</FUNCTION>

!<SUBROUTINE NAME="set_tracer_atts">
!   <OVERVIEW>
!     A subroutine to allow the user set the tracer longname and units from the 
!     tracer initialization routine.
!   </OVERVIEW>
!   <DESCRIPTION>
!     A function to allow the user set the tracer longname and units from the 
!     tracer initialization routine. It seems sensible that the user who is 
!     coding the tracer code will know what units they are working in and it 
!     is probably safer to set the value in the tracer code rather than in 
!     the field table.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call set_tracer_atts(model, name, longname, units)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="name" TYPE="character">
!     Tracer name.
!   </IN>
!   <OUT NAME="longname" TYPE="character, optional">
!     A string describing the longname of the tracer for output to NetCDF files
!   </OUT>
!   <OUT NAME="units" TYPE="character, optional">
!     A string describing the units of the tracer for output to NetCDF files
!   </OUT>
subroutine set_tracer_atts(model, name, longname, units)

integer, intent(in)                    :: model
character(len=*), intent(in)           :: name
character(len=*), intent(in), optional :: longname, units

integer :: n, index
logical :: success
character(len=128) :: list_name

if ( get_tracer_index(model,name,n) ) then
    tracers(TRACER_ARRAY(model,n))%tracer_units   = units
    tracers(TRACER_ARRAY(model,n))%tracer_longname = longname
  select case(model)
    case(MODEL_COUPLER) 
      list_name = "/coupler_mod/tracer/"//trim(name)
    case(MODEL_ATMOS) 
      list_name = "/atmos_mod/tracer/"//trim(name)
    case(MODEL_OCEAN) 
      list_name = "/ocean_mod/tracer/"//trim(name)
    case(MODEL_LAND) 
      list_name = "/land_mod/tracer/"//trim(name)
    case(MODEL_ICE) 
      list_name = "/ice_mod/tracer/"//trim(name)
    case DEFAULT 
      list_name = "/"//trim(name)
  end select      

! Method_type is a list, method_name is a name of a parameter and method_control has the value.
!    list_name = trim(list_name)//"/longname"
  if ( fm_exists(list_name)) then
    success = fm_change_list(list_name)
    if ( present(longname) ) then
      if ( longname .ne. "" ) index = fm_new_value('longname',longname)
    endif
    if ( present(units) ) then
      if (units .ne. "" ) index = fm_new_value('units',units)
    endif
  endif  
    
else
    call mpp_error(NOTE,'set_tracer_atts : Trying to set longname and/or units for non-existent tracer : '//trim(name))
endif

end subroutine set_tracer_atts
!</SUBROUTINE>

!<SUBROUTINE NAME="set_tracer_method">
!   <OVERVIEW> 
!      A subroutine to allow the user to set some tracer specific methods.
!   </OVERVIEW>
!   <DESCRIPTION>
!      A subroutine to allow the user to set methods for a specific tracer. 
!   </DESCRIPTION>
!   <TEMPLATE>
!     call set_tracer_method(model, name, method_type, method_name, method_control)
!   </TEMPLATE>

!   <IN NAME="model" TYPE="integer">
!     A parameter representing the component model in use.
!   </IN>
!   <IN NAME="name" TYPE="character">
!     Tracer name.
!   </IN>
!   <IN NAME="method_type" TYPE="character">
!     The type of the method to be set.
!   </IN>
!   <IN NAME="method_name" TYPE="character">
!     The name of the method to be set.
!   </IN>
!   <IN NAME="method_control" TYPE="character">
!     The control parameters of the method to be set.
!   </IN>
     
subroutine set_tracer_method(model, name, method_type, method_name, method_control)

integer, intent(in)                    :: model
character(len=*), intent(in)           :: name
character(len=*), intent(in)           :: method_type
character(len=*), intent(in)           :: method_name
character(len=*), intent(in)           :: method_control

integer :: n, num_method, index
logical :: success
character(len=128) :: list_name

if ( get_tracer_index(model,name,n) ) then
  tracers(n)%num_methods = tracers(n)%num_methods + 1
  num_method = tracers(n)%num_methods

  select case(model)
    case(MODEL_COUPLER)
      list_name = "/coupler_mod/tracer/"//trim(name)
    case(MODEL_ATMOS)
      list_name = "/atmos_mod/tracer/"//trim(name)
    case(MODEL_OCEAN)
      list_name = "/ocean_mod/tracer/"//trim(name)
    case(MODEL_LAND)
      list_name = "/land_mod/tracer/"//trim(name)
    case(MODEL_ICE)
      list_name = "/ice_mod/tracer/"//trim(name)
    case DEFAULT
      list_name = "/"//trim(name)
  end select      

  if ( method_control .ne. "" ) then
! Method_type is a list, method_name is a name of a parameter and method_control has the value.
    list_name = trim(list_name)//"/"//trim(method_type)
    if ( fm_exists(list_name)) then
      success = fm_change_list(list_name)
      index = fm_new_value(method_type,method_control)
    endif
  else
    call mpp_error(NOTE,'set_tracer_method : Trying to set a method for non-existent tracer : '//trim(name))
  endif
endif

end subroutine set_tracer_method
!</SUBROUTINE>

function error_handler(routine, err_msg_local, err_msg)
logical :: error_handler
character(len=*), intent(in) :: routine, err_msg_local
character(len=*), intent(out), optional :: err_msg

if(present(err_msg)) then
  err_msg = err_msg_local
  error_handler = .true.    
else
  call mpp_error(FATAL,trim(routine)//': '//trim(err_msg_local))
endif

end function error_handler

end module tracer_manager_mod


module tridiagonal_mod

! <CONTACT EMAIL="Isaac.Held@noaa.gov">
!    Isaac Held 
! </CONTACT>
! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!    Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Solves the tridiagonal system of equations.
! </OVERVIEW>
! <DESCRIPTION>
!     The following schematic represents the system of equations solved,
!     where X is the solution.
! <PRE> 
!     | B(1)  A(1)   0     0                .......            0    |  |X(1)|   |D(1)|
!     | C(2)  B(2)  A(2)   0                .......            0    |  |X(2)|   |D(2)|
!     |  0    C(3)  B(3)  A(3)  0           .......            0    |  | .. |   | .. |
!     |  ..........................................                 |  | .. | = | .. |
!     |  ..........................................                 |  | .. |   | .. |
!     |                                  C(N-2) B(N-2) A(N-2)  0    |  | .. |   | .. |
!     |                                    0    C(N-1) B(N-1) A(N-1)|  | .. |   | .. |
!     |                                    0      0    C(N)   B(N)  |  |X(N)|   |D(N)|
! 
! </PRE>
!  To solve this system 
! <PRE>
!   call tri_invert(X,D,A,B,C)
!
!       real, intent(out), dimension(:,:,:) :: X
!       real, intent(in),  dimension(:,:,:) :: D
!       real, optional,    dimension(:,:,:) :: A,B,C
! </PRE>
! For simplicity (?), A and C are assumed to be dimensioned the same size 
! as B, D, and X, although any input values for A(N) and C(1) are ignored.
! (some checks are needed here)
!
! If A is not present, it is assumed that the matrix (A,B.C) has not been changed 
! since the last call to tri_invert.
!
! To release memory, 
! <PRE>
!    call close_tridiagonal
! </PRE>
! The following module variables are used to retain the relevant information
! if one recalls tri_invert without changing (A,B,C)


! </DESCRIPTION>

!--------------------------------------------------------------------------
real,    private, allocatable, dimension(:,:,:) :: e,g,cc
real,    private, allocatable, dimension(:,:)   :: bb
logical, private :: init_tridiagonal = .false.
!--------------------------------------------------------------------------

contains

!--------------------------------------------------------------------------

! <SUBROUTINE NAME="tri_invert">

!   <OVERVIEW>
!     Sets up and solves the tridiagonal system of equations.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Sets up and solves the tridiagonal system of equations.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call tri_invert ( x,d,a,b,c)
!   </TEMPLATE>

!   <IN NAME="d" TYPE="real" DIM="(:,:,:)">
!     The right-hand side term, see the schematic above.
!   </IN>
!   <OUT NAME="x" TYPE="real" DIM="(:,:,:)">
!     The solution to the tridiagonal system of equations.
!   </OUT>
!   <INOUT NAME="a,b,c" TYPE="real" DIM="(:,:,:)">
!     The left-hand-side terms (matrix), see the schematic above.
!             If A is not present, it is assumed that the matrix (A,B.C)
!             has not been changed since the last call to tri_invert.
!   </INOUT>

!   <NOTE>
!      For simplicity, A and C are assumed to be dimensioned the same size
!      as B, D, and X, although any input values for A(N) and C(1) are ignored.
!      There are no checks to make sure the sizes agree.
!   </NOTE>
!   <NOTE>
!      The value of A(N) is modified on output, and B and C are unchanged.
!   </NOTE>

subroutine tri_invert(x,d,a,b,c)

implicit none

real, intent(out), dimension(:,:,:) :: x
real, intent(in),  dimension(:,:,:) :: d
real, optional,    dimension(:,:,:) :: a,b,c

real, dimension(size(x,1),size(x,2),size(x,3)) :: f
integer :: k

if(present(a)) then
  init_tridiagonal = .true.

  if(allocated(e))     deallocate(e)
  if(allocated(g))     deallocate(g)
  if(allocated(bb))    deallocate(bb)
  if(allocated(cc))    deallocate(cc)
  allocate(e (size(x,1),size(x,2),size(x,3)))
  allocate(g (size(x,1),size(x,2),size(x,3)))
  allocate(bb(size(x,1),size(x,2)))
  allocate(cc(size(x,1),size(x,2),size(x,3)))
  
  e(:,:,1) = - a(:,:,1)/b(:,:,1)
  a(:,:,size(x,3)) = 0.0

  do  k= 2,size(x,3)
    g(:,:,k) = 1/(b(:,:,k)+c(:,:,k)*e(:,:,k-1))
    e(:,:,k) = - a(:,:,k)*g(:,:,k)
  end do
  cc = c
  bb = 1.0/b(:,:,1)

end if

! if(.not.init_tridiagonal) error

f(:,:,1) =  d(:,:,1)*bb
do k= 2, size(x,3)
  f(:,:,k) = (d(:,:,k) - cc(:,:,k)*f(:,:,k-1))*g(:,:,k)
end do

x(:,:,size(x,3)) = f(:,:,size(x,3))
do k = size(x,3)-1,1,-1
  x(:,:,k) = e(:,:,k)*x(:,:,k+1)+f(:,:,k)
end do

return
end subroutine tri_invert
! </SUBROUTINE>

!-----------------------------------------------------------------

! <SUBROUTINE NAME="close_tridiagonal">

!   <OVERVIEW>
!     Releases memory used by the solver.
!   </OVERVIEW>
!   <DESCRIPTION>
!     Releases memory used by the solver.
!   </DESCRIPTION>
!   <TEMPLATE>
!     call close_tridiagonal
!   </TEMPLATE>

!   <NOTE>
!     There are no arguments to this routine.
!   </NOTE>

subroutine close_tridiagonal

implicit none

deallocate(e)
deallocate(g)
deallocate(bb)
deallocate(cc)

return
end subroutine close_tridiagonal
! </SUBROUTINE>

!----------------------------------------------------------------



end module tridiagonal_mod

! <INFO>

!   <BUG>
!     Optional arguments A,B,C have no intent declaration,
!     so the default intent is inout. The value of A(N) is modified
!     on output, and B and C are unchanged.                  
!   </BUG>
!   <NOTE>
!       The following private allocatable arrays save the relevant information
!  if one recalls tri_invert without changing (A,B,C):
!  <PRE>
!        allocate ( e  (size(x,1), size(x,2), size(x,3)) )
!        allocate ( g  (size(x,1), size(x,2), size(x,3)) )
!        allocate ( cc (size(x,1), size(x,2), size(x,3)) )
!        allocate ( bb (size(x,1), size(x,2)) )
! </PRE>
!  This storage is deallocated when close_tridiagonal is called.
!   </NOTE>
!   <FUTURE>
!     Maybe a cleaner version?
!   </FUTURE>

! </INFO>
